From a5f4eb305ddd6aad446bf147b9afadb1c2018a2a Mon Sep 17 00:00:00 2001 From: "Benjamin Kovach]" Date: Tue, 5 Aug 2014 13:33:31 -0400 Subject: [PATCH 0001/1580] Main -> --- psci/Commands.hs | 8 ++++---- psci/Main.hs | 33 +++++++++++++++++---------------- 2 files changed, 21 insertions(+), 20 deletions(-) diff --git a/psci/Commands.hs b/psci/Commands.hs index 88a67aca8c..001f3f516f 100644 --- a/psci/Commands.hs +++ b/psci/Commands.hs @@ -24,7 +24,7 @@ data Command -- | -- A purescript expression -- - = Expression Expr + = Expression Value -- | -- Show the help command -- @@ -48,14 +48,14 @@ data Command -- | -- Binds a value to a name -- - | Let (Expr -> Expr) + | Let (Value -> Value) -- | -- Find the type of an expression -- - | TypeOf Expr + | TypeOf Value -- | -- Find the kind of an expression - -- + -- | KindOf Type -- | diff --git a/psci/Main.hs b/psci/Main.hs index d815642eba..148dc0e804 100644 --- a/psci/Main.hs +++ b/psci/Main.hs @@ -66,7 +66,7 @@ data PSCiState = PSCiState { psciImportedFilenames :: [FilePath] , psciImportedModuleNames :: [P.ModuleName] , psciLoadedModules :: [(FilePath, P.Module)] - , psciLetBindings :: [P.Expr -> P.Expr] + , psciLetBindings :: [P.Value -> P.Value] } -- State helpers @@ -92,7 +92,7 @@ updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modu -- | -- Updates the state to have more let bindings. -- -updateLets :: (P.Expr -> P.Expr) -> PSCiState -> PSCiState +updateLets :: (P.Value -> P.Value) -> PSCiState -> PSCiState updateLets name st = st { psciLetBindings = name : psciLetBindings st } -- File helpers @@ -242,11 +242,11 @@ mkdirp = createDirectoryIfMissing True . takeDirectory -- | -- Makes a volatile module to execute the current expression. -- -createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module +createTemporaryModule :: Bool -> PSCiState -> P.Value -> P.Module createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetBindings = lets} value = let - moduleName = P.ModuleName [P.ProperName "Main"] - importDecl m = P.ImportDeclaration m P.Unqualified Nothing + moduleName = P.ModuleName [P.ProperName "$PSCI"] + importDecl m = P.ImportDeclaration m Nothing Nothing traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"] trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print")) itValue = foldl (\x f -> f x) value lets @@ -263,8 +263,8 @@ createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetB createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module createTemporaryModuleForKind PSCiState{psciImportedModuleNames = imports} typ = let - moduleName = P.ModuleName [P.ProperName "Main"] - importDecl m = P.ImportDeclaration m P.Unqualified Nothing + moduleName = P.ModuleName [P.ProperName "$PSCI"] + importDecl m = P.ImportDeclaration m Nothing Nothing itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ in P.Module moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing @@ -278,15 +278,15 @@ indexFile = ".psci_modules" ++ pathSeparator : "index.js" -- | -- Takes a value declaration and evaluates it with the current state. -- -handleDeclaration :: P.Expr -> PSCI () +handleDeclaration :: P.Value -> PSCI () handleDeclaration value = do st <- PSCI $ lift get let m = createTemporaryModule True st value - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("Main.purs", m)]) + e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) case e of Left err -> PSCI $ outputStrLn err Right _ -> do - psciIO $ writeFile indexFile $ "require('Main').main();" + psciIO $ writeFile indexFile $ "require('$PSCI').main();" process <- psciIO findNodeProcess result <- psciIO $ traverse (\node -> readProcessWithExitCode node [indexFile] "") process case result of @@ -297,15 +297,15 @@ handleDeclaration value = do -- | -- Takes a value and prints its type -- -handleTypeOf :: P.Expr -> PSCI () +handleTypeOf :: P.Value -> PSCI () handleTypeOf value = do st <- PSCI $ lift get let m = createTemporaryModule False st value - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("Main.purs", m)]) + e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) case e of Left err -> PSCI $ outputStrLn err Right env' -> - case M.lookup (P.ModuleName [P.ProperName "Main"], P.Ident "it") (P.names env') of + case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty Nothing -> PSCI $ outputStrLn "Could not find type" @@ -316,8 +316,8 @@ handleKindOf :: P.Type -> PSCI () handleKindOf typ = do st <- PSCI $ lift get let m = createTemporaryModuleForKind st typ - mName = P.ModuleName [P.ProperName "Main"] - e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("Main.purs", m)]) + mName = P.ModuleName [P.ProperName "$PSCI"] + e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("$PSCI.purs", m)]) case e of Left err -> PSCI $ outputStrLn err Right env' -> @@ -325,7 +325,7 @@ handleKindOf typ = do Just (_, typ') -> do let chk = P.CheckState env' 0 0 (Just mName) k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk - case k of + case k of Left errStack -> PSCI . outputStrLn . P.prettyPrintErrorStack False $ errStack Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind Nothing -> PSCI $ outputStrLn "Could not find kind" @@ -340,6 +340,7 @@ getCommand = do firstLine <- getInputLine "> " case firstLine of Nothing -> return (Right Nothing) + Just "" -> return (Right Nothing) Just s@ (':' : _) -> return . either Left (Right . Just) $ parseCommand s -- The start of a command Just s -> either Left (Right . Just) . parseCommand <$> go [s] where From d1bd11dc615d01be53680383db9fd2f0a73bb032 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 9 Sep 2015 15:53:41 -0700 Subject: [PATCH 0002/1580] Make some errors simpler. Fix #1387. --- src/Language/PureScript/Errors.hs | 27 ++++++++++++++++----------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 77a6a40bc3..57def6d47a 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -443,9 +443,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , indent . line $ path ] goSimple InvalidDoBind = - line "Bind statement cannot be the last statement in a do block" + line "Bind statement cannot be the last statement in a do block. The last statement must be an expression." goSimple InvalidDoLet = - line "Let statement cannot be the last statement in a do block" + line "Let statement cannot be the last statement in a do block. The last statement must be an expression." goSimple CannotReorderOperators = line "Unable to reorder operators" goSimple UnspecifiedSkolemScope = @@ -453,11 +453,11 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError goSimple OverlappingNamesInLet = line "Overlapping names in let binding." goSimple (InfiniteType ty) = - paras [ line "Infinite type detected: " + paras [ line "An infinite type was inferred for an expression: " , indent $ line $ prettyPrintType ty ] goSimple (InfiniteKind ki) = - paras [ line "Infinite kind detected: " + paras [ line "An infinite kind was inferred for a type: " , indent $ line $ prettyPrintKind ki ] goSimple (MultipleFixities name) = @@ -534,9 +534,11 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError goSimple (UndefinedTypeVariable name) = line $ "Type variable " ++ show name ++ " is undefined" goSimple (PartiallyAppliedSynonym name) = - line $ "Partially applied type synonym " ++ show name + paras [ line $ "Partially applied type synonym " ++ show name + , line "Type synonyms must be applied to all of their type arguments." + ] goSimple (EscapedSkolem binding) = - paras $ [ line "Rigid/skolem type variable has escaped." ] + paras $ [ line "A type variable has escaped its scope." ] <> foldMap (\expr -> [ line "Relevant expression: " , indent $ line $ prettyPrintValue expr ]) binding @@ -610,7 +612,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError goSimple TypeSynonymInstance = line "Type synonym instances are disallowed" goSimple (OrphanInstance nm cnm ts) = - line $ "Instance " ++ show nm ++ " for " ++ show cnm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is an orphan instance" + paras [ line $ "Instance " ++ show nm ++ " for " ++ show cnm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is an orphan instance." + , line "An orphan instance is an instance which is defined in neither the class module nor the data type module." + , line "Consider moving the instance, if possible, or using a newtype wrapper." + ] goSimple InvalidNewtype = line "Newtypes must define a single constructor with a single argument" goSimple (InvalidInstanceHead ty) = @@ -634,13 +639,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError goSimple (WildcardInferredType ty) = line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty goSimple (NotExhaustivePattern bs b) = - indent $ paras $ [ line "Pattern could not be determined to cover all cases." - , line $ "The definition has the following uncovered cases:\n" + indent $ paras $ [ line "A case expression could not be determined to cover all inputs." + , line $ "The following additional cases are required to cover all inputs:\n" , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ] ++ if not b then [line "..."] else [] goSimple (OverlappingPattern bs b) = - indent $ paras $ [ line "Redundant cases have been detected." - , line $ "The definition has the following redundant cases:\n" + indent $ paras $ [ line "A case expression contains redundant cases." + , line $ "The expression has the following redundant cases:\n" , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ] ++ if not b then [line "..."] else [] go (NotYetDefined names err) = From 6d8efc22ac544b370143282ebde552a662f0af3e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 9 Sep 2015 16:03:37 -0700 Subject: [PATCH 0003/1580] Implement @hdgarrood's suggestion for psc-publish --- src/Language/PureScript/Publish/ErrorsWarnings.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index b4d5125c2c..9ef1374c2b 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -162,6 +162,12 @@ displayUserError e = case e of , para "Note: tagged versions must be in one of the following forms:" , indented (para "* v{MAJOR}.{MINOR}.{PATCH} (example: \"v1.6.2\")") , indented (para "* {MAJOR}.{MINOR}.{PATCH} (example: \"1.6.2\")") + , spacer + , para (concat + [ "If the version you are publishing is not yet tagged, you might want to use" + , "the --dry-run flag instead, which removes this requirement. Run" + , "psc-publish --help for more details." + ]) ] AmbiguousVersions vs -> vcat $ From 09634479b96790581ba2ac1a756e9b452b7a42ee Mon Sep 17 00:00:00 2001 From: Konstantin Zudov Date: Thu, 10 Sep 2015 06:05:37 +0300 Subject: [PATCH 0004/1580] Bump stackage resolvers --- .travis.yml | 6 +++--- stack-lts-3.yaml | 2 +- stack-nightly.yaml | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 76a1a73400..30283da694 100644 --- a/.travis.yml +++ b/.travis.yml @@ -18,11 +18,11 @@ matrix: - env: GHCVER=7.10.1 compiler: ": #GHC 7.10.1" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.10.2 STACKAGE=lts=3.2 RUNSDISTTESTS=YES - compiler: ": #GHC 7.10.2 lts-3.2" + - env: GHCVER=7.10.2 STACKAGE=lts=3.4 RUNSDISTTESTS=YES + compiler: ": #GHC 7.10.2 lts-3.4" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - env: GHCVER=7.10.2 STACKAGE=nightly-2015-08-24 - compiler: ": #GHC 7.10.2 nightly-2015-08-24" + compiler: ": #GHC 7.10.2 nightly-2015-09-09" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} before_install: - unset CC diff --git a/stack-lts-3.yaml b/stack-lts-3.yaml index 6d0ad788a8..9e1254bc87 100644 --- a/stack-lts-3.yaml +++ b/stack-lts-3.yaml @@ -2,4 +2,4 @@ flags: {} packages: - '.' extra-deps: -resolver: lts-3.2 +resolver: lts-3.4 diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 5d1533d08c..26c1a4e917 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -2,4 +2,4 @@ flags: {} packages: - '.' extra-deps: -resolver: nightly-2015-08-24 +resolver: nightly-2015-09-09 From 3e3f80337b2c254f40145a7a2d9cb7c174a91e7d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 10 Sep 2015 17:43:37 -0700 Subject: [PATCH 0005/1580] s/redudant/unreachable --- src/Language/PureScript/Errors.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 57def6d47a..c85799e733 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -639,15 +639,16 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError goSimple (WildcardInferredType ty) = line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty goSimple (NotExhaustivePattern bs b) = - indent $ paras $ [ line "A case expression could not be determined to cover all inputs." - , line $ "The following additional cases are required to cover all inputs:\n" + paras $ [ line "A case expression could not be determined to cover all inputs." + , line "The following additional cases are required to cover all inputs:\n" , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) - ] ++ if not b then [line "..."] else [] + ] ++ + [ line "..." | not b ] goSimple (OverlappingPattern bs b) = - indent $ paras $ [ line "A case expression contains redundant cases." - , line $ "The expression has the following redundant cases:\n" + paras $ [ line "A case expression contains unreachable cases:\n" , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) - ] ++ if not b then [line "..."] else [] + ] ++ + [ line "..." | not b ] go (NotYetDefined names err) = paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":" , indent $ go err From 3652252002d13d4707a6fef1a7a96195eaa2c031 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 10 Sep 2015 17:58:15 -0700 Subject: [PATCH 0006/1580] Support constraints without forall --- examples/passing/NakedConstraint.purs | 12 ++++++++++++ src/Language/PureScript/Parser/Types.hs | 22 +++++++++++----------- 2 files changed, 23 insertions(+), 11 deletions(-) create mode 100644 examples/passing/NakedConstraint.purs diff --git a/examples/passing/NakedConstraint.purs b/examples/passing/NakedConstraint.purs new file mode 100644 index 0000000000..d7b58c9f59 --- /dev/null +++ b/examples/passing/NakedConstraint.purs @@ -0,0 +1,12 @@ +module Main where + +import Control.Monad.Eff.Console + +class Partial where + +data List a = Nil | Cons a (List a) + +head :: (Partial) => List Int -> Int +head (Cons x _) = x + +main = log "Done" diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index a982abf4e1..7cd1602e06 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -63,7 +63,7 @@ parseTypeConstructor = TypeConstructor <$> parseQualified properName parseForAll :: TokenParser Type parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot) - <*> parseConstrainedType + <*> parseType -- | -- Parse a type as it appears in e.g. a data constructor @@ -79,21 +79,21 @@ parseTypeAtom = indented *> P.choice (map P.try , parseTypeConstructor , parseForAll , parens parseRow - , parens parsePolyType ]) + , parseConstrainedType + , parens parsePolyType + ]) parseConstrainedType :: TokenParser Type parseConstrainedType = do - constraints <- P.optionMaybe . P.try $ do - constraints <- parens . commaSep1 $ do - className <- parseQualified properName - indented - ty <- P.many parseTypeAtom - return (className, ty) - _ <- rfatArrow - return constraints + constraints <- parens . commaSep1 $ do + className <- parseQualified properName + indented + ty <- P.many parseTypeAtom + return (className, ty) + _ <- rfatArrow indented ty <- parseType - return $ maybe ty (flip ConstrainedType ty) constraints + return $ ConstrainedType constraints ty parseAnyType :: TokenParser Type parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P. "type" From bcddafc94852d2bb126b346e4eaff11eb934083d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 10 Sep 2015 21:59:42 -0700 Subject: [PATCH 0007/1580] Fix #1042, better messages for ExpectedType errors. --- examples/failing/KindStar.purs | 8 ++++++++ src/Language/PureScript/Errors.hs | 8 +++++--- src/Language/PureScript/TypeChecker.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 14 +++++++------- 4 files changed, 21 insertions(+), 11 deletions(-) create mode 100644 examples/failing/KindStar.purs diff --git a/examples/failing/KindStar.purs b/examples/failing/KindStar.purs new file mode 100644 index 0000000000..12a1d652a3 --- /dev/null +++ b/examples/failing/KindStar.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith ExpectedType + +module X where + +data List a = Nil | Cons a (List a) + +test :: List +test = Nil diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index c85799e733..5dda4ac46b 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -128,7 +128,7 @@ data SimpleErrorMessage | OverlappingArgNames (Maybe Ident) | MissingClassMember Ident | ExtraneousClassMember Ident - | ExpectedType Kind + | ExpectedType Type Kind | IncorrectConstructorArity (Qualified ProperName) | SubsumptionCheckFailed | ExprDoesNotHaveType Expr Type @@ -590,8 +590,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError line $ "Member " ++ show ident ++ " has not been implemented" goSimple (ExtraneousClassMember ident) = line $ "Member " ++ show ident ++ " is not a member of the class being instantiated" - goSimple (ExpectedType kind) = - line $ "Expected type of kind *, was " ++ prettyPrintKind kind + goSimple (ExpectedType ty kind) = + paras [ line "In a type-annotated expression x :: t, the type t must have kind *." + , line $ "The error arises from the type " ++ prettyPrintType ty ++ " having the kind " ++ prettyPrintKind kind ++ " instead." + ] goSimple (IncorrectConstructorArity nm) = line $ "Wrong number of arguments to constructor " ++ show nm goSimple SubsumptionCheckFailed = line $ "Unable to check type subsumption" diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 0a126dd6e5..5075b9f99a 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -206,7 +206,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix warnAndRethrow (onErrorMessages (ErrorInForeignImport name)) $ do env <- getEnv kind <- kindOf moduleName ty - guardWith (errorMessage (ExpectedType kind)) $ kind == Star + guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star case M.lookup (moduleName, name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) }) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 2121a976de..ae8ec5cf09 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -141,7 +141,7 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do ty' <- replaceTypeWildcards ty -- Kind check (kind, args) <- liftCheck $ kindOfWithScopedVars ty - checkTypeKind kind + checkTypeKind ty kind -- Check the type with the new names in scope ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty' val'' <- if checkType @@ -190,8 +190,8 @@ replaceTypeClassDictionaries mn = -- | -- Check the kind of a type, failing if it is not of kind *. -- -checkTypeKind :: Kind -> UnifyT t Check () -checkTypeKind kind = guardWith (errorMessage (ExpectedType kind)) $ kind == Star +checkTypeKind :: Type -> Kind -> UnifyT t Check () +checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star -- | -- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns @@ -301,7 +301,7 @@ infer' (SuperClassDictionary className tys) = do infer' (TypedValue checkType val ty) = do Just moduleName <- checkCurrentModule <$> get (kind, args) <- liftCheck $ kindOfWithScopedVars ty - checkTypeKind kind + checkTypeKind ty kind ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val return $ TypedValue True val' ty' @@ -313,7 +313,7 @@ inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do Just moduleName <- checkCurrentModule <$> get (kind, args) <- liftCheck $ kindOfWithScopedVars ty - checkTypeKind kind + checkTypeKind ty kind let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined) ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv @@ -527,7 +527,7 @@ check' (SuperClassDictionary className tys) _ = do check' (TypedValue checkType val ty1) ty2 = do Just moduleName <- checkCurrentModule <$> get (kind, args) <- liftCheck $ kindOfWithScopedVars ty1 - checkTypeKind kind + checkTypeKind ty1 kind ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2 val' <- subsumes (Just val) ty1' ty2' @@ -582,7 +582,7 @@ check' val ty | containsTypeSynonyms ty = do ty' <- introduceSkolemScope <=< expandAllTypeSynonyms <=< replaceTypeWildcards $ ty check val ty' check' val kt@(KindedType ty kind) = do - checkTypeKind kind + checkTypeKind ty kind val' <- check' val ty return $ TypedValue True val' kt check' (PositionedValue pos _ val) ty = From 1376700f1d061045c287cc57db19929ab94bdac6 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 11 Sep 2015 14:52:04 -0700 Subject: [PATCH 0008/1580] Only use Show for debugging. --- psc-docs/Main.hs | 8 +- psc-publish/tests/Test.hs | 2 +- psci/Completion.hs | 22 +-- src/Language/PureScript/AST/Binders.hs | 2 +- src/Language/PureScript/AST/Declarations.hs | 16 +- src/Language/PureScript/AST/Operators.hs | 14 +- src/Language/PureScript/AST/SourcePos.hs | 4 +- src/Language/PureScript/Bundle.hs | 18 +- src/Language/PureScript/CodeGen/Externs.hs | 38 ++--- src/Language/PureScript/CodeGen/JS.hs | 6 +- src/Language/PureScript/CodeGen/JS/AST.hs | 6 +- src/Language/PureScript/Comments.hs | 2 +- src/Language/PureScript/CoreFn/Binders.hs | 2 +- src/Language/PureScript/CoreFn/Expr.hs | 6 +- src/Language/PureScript/CoreFn/Literals.hs | 2 +- src/Language/PureScript/CoreFn/Meta.hs | 4 +- src/Language/PureScript/CoreFn/Module.hs | 2 +- src/Language/PureScript/Docs/AsMarkdown.hs | 2 +- src/Language/PureScript/Docs/Convert.hs | 23 ++- src/Language/PureScript/Docs/Render.hs | 2 +- .../PureScript/Docs/RenderedCode/Render.hs | 2 +- src/Language/PureScript/Environment.hs | 18 +- src/Language/PureScript/Errors.hs | 156 +++++++++--------- src/Language/PureScript/Kinds.hs | 2 +- src/Language/PureScript/Linter/Exhaustive.hs | 3 +- src/Language/PureScript/Make.hs | 4 +- src/Language/PureScript/Names.hs | 28 ++-- src/Language/PureScript/Parser/Lexer.hs | 8 +- src/Language/PureScript/Pretty/Common.hs | 2 +- src/Language/PureScript/Pretty/Types.hs | 8 +- src/Language/PureScript/Pretty/Values.hs | 32 ++-- src/Language/PureScript/Publish.hs | 4 +- .../PureScript/Publish/ErrorsWarnings.hs | 2 +- src/Language/PureScript/Renamer.hs | 4 +- src/Language/PureScript/Sugar/Names.hs | 12 +- src/Language/PureScript/Sugar/Names/Env.hs | 8 +- .../PureScript/Sugar/Names/Imports.hs | 25 +-- src/Language/PureScript/Sugar/Operators.hs | 4 +- src/Language/PureScript/Sugar/TypeClasses.hs | 4 +- .../PureScript/TypeChecker/Entailment.hs | 2 +- .../PureScript/TypeClassDictionaries.hs | 6 +- src/Language/PureScript/Types.hs | 4 +- 42 files changed, 258 insertions(+), 261 deletions(-) diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index a82a8f3496..79b7fdc607 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -152,10 +152,10 @@ inputFile = strArgument $ <> help "The input .purs file(s)" instance Read Format where - readsPrec _ "etags" = [(Etags, "")] - readsPrec _ "ctags" = [(Ctags, "")] - readsPrec _ "markdown" = [(Markdown, "")] - readsPrec _ _ = [] + readsPrec _ "etags" = [(Etags, "")] + readsPrec _ "ctags" = [(Ctags, "")] + readsPrec _ "markdown" = [(Markdown, "")] + readsPrec _ _ = [] format :: Parser Format format = option auto $ value Markdown diff --git a/psc-publish/tests/Test.hs b/psc-publish/tests/Test.hs index aa19781c35..7e594b74d2 100644 --- a/psc-publish/tests/Test.hs +++ b/psc-publish/tests/Test.hs @@ -60,7 +60,7 @@ data TestResult = ParseFailed String | Mismatch ByteString ByteString -- ^ encoding before, encoding after | Pass ByteString - deriving (Show) + deriving (Show, Read) -- | Test JSON encoding/decoding; parse the package, roundtrip to/from JSON, -- and check we get the same string. diff --git a/psci/Completion.hs b/psci/Completion.hs index b4716cdbfd..3565275697 100644 --- a/psci/Completion.hs +++ b/psci/Completion.hs @@ -41,7 +41,7 @@ data CompletionContext | CtxIdentifier | CtxType | CtxFixed String - deriving (Show) + deriving (Show, Read) -- | -- Loads module, function, and file completions. @@ -143,34 +143,34 @@ getImportedModules = asks psciImportedModules getModuleNames :: CompletionM [String] getModuleNames = moduleNames <$> getLoadedModules -mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [(a, P.Declaration)]) -> CompletionM [String] -mapLoadedModulesAndQualify f = do +mapLoadedModulesAndQualify :: (a -> String) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String] +mapLoadedModulesAndQualify sho f = do ms <- getLoadedModules let argPairs = do m <- ms fm <- f m return (m, fm) - concat <$> traverse (uncurry getAllQualifications) argPairs + concat <$> traverse (uncurry (getAllQualifications sho)) argPairs getIdentNames :: CompletionM [String] -getIdentNames = mapLoadedModulesAndQualify identNames +getIdentNames = mapLoadedModulesAndQualify P.showIdent identNames getDctorNames :: CompletionM [String] -getDctorNames = mapLoadedModulesAndQualify dctorNames +getDctorNames = mapLoadedModulesAndQualify P.runProperName dctorNames getTypeNames :: CompletionM [String] -getTypeNames = mapLoadedModulesAndQualify typeDecls +getTypeNames = mapLoadedModulesAndQualify P.runProperName typeDecls -- | Given a module and a declaration in that module, return all possible ways -- it could have been referenced given the current PSCiState - including fully -- qualified, qualified using an alias, and unqualified. -getAllQualifications :: (Show a) => P.Module -> (a, P.Declaration) -> CompletionM [String] -getAllQualifications m (declName, decl) = do +getAllQualifications :: (a -> String) -> P.Module -> (a, P.Declaration) -> CompletionM [String] +getAllQualifications sho m (declName, decl) = do imports <- getAllImportsOf m let fullyQualified = qualifyWith (Just (P.getModuleName m)) let otherQuals = nub (concatMap qualificationsUsing imports) return $ fullyQualified : otherQuals where - qualifyWith mMod = show (P.Qualified mMod declName) + qualifyWith mMod = P.showQualified sho (P.Qualified mMod declName) referencedBy refs = P.isExported (Just refs) decl qualificationsUsing (_, importType, asQ') = @@ -222,7 +222,7 @@ dctorNames = nubOnFst . concatMap go . P.exportedDeclarations go _ = [] moduleNames :: [P.Module] -> [String] -moduleNames ms = nub [show moduleName | P.Module _ _ moduleName _ _ <- ms] +moduleNames ms = nub [P.runModuleName moduleName | P.Module _ _ moduleName _ _ <- ms] directivesFirst :: Completion -> Completion -> Ordering directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2 diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index f264c23aaf..a827a578a9 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -69,7 +69,7 @@ data Binder -- | -- A binder with source position information -- - | PositionedBinder SourceSpan [Comment] Binder deriving (Show, Eq, D.Data, D.Typeable) + | PositionedBinder SourceSpan [Comment] Binder deriving (Show, Read, Eq, D.Data, D.Typeable) -- | -- Collect all names introduced in binders in an expression diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 6e1e5073c1..298a7c656f 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -42,7 +42,7 @@ import Language.PureScript.Environment -- a list of declarations, and a list of the declarations that are -- explicitly exported. If the export list is Nothing, everything is exported. -- -data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable) +data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, Read, D.Data, D.Typeable) -- | Return a module's name. getModuleName :: Module -> ModuleName @@ -76,7 +76,7 @@ data DeclarationRef -- A declaration reference with source position information -- | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef - deriving (Show, D.Data, D.Typeable) + deriving (Show, Read, D.Data, D.Typeable) instance Eq DeclarationRef where (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors' @@ -108,7 +108,7 @@ data ImportDeclarationType -- An import with a list of references to hide: `import M hiding (foo)` -- | Hiding [DeclarationRef] - deriving (Show, D.Data, D.Typeable) + deriving (Show, Read, D.Data, D.Typeable) -- | -- The data type of declarations @@ -171,7 +171,7 @@ data Declaration -- A declaration with source position information -- | PositionedDeclaration SourceSpan [Comment] Declaration - deriving (Show, D.Data, D.Typeable) + deriving (Show, Read, D.Data, D.Typeable) -- | The members of a type class instance declaration data TypeInstanceBody @@ -179,7 +179,7 @@ data TypeInstanceBody = DerivedInstance -- | This is a regular (explicit) instance | ExplicitInstance [Declaration] - deriving (Show, D.Data, D.Typeable) + deriving (Show, Read, D.Data, D.Typeable) mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f) @@ -406,7 +406,7 @@ data Expr -- | -- A value with source position information -- - | PositionedValue SourceSpan [Comment] Expr deriving (Show, D.Data, D.Typeable) + | PositionedValue SourceSpan [Comment] Expr deriving (Show, Read, D.Data, D.Typeable) -- | -- An alternative in a case statement @@ -420,7 +420,7 @@ data CaseAlternative = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: Either [(Guard, Expr)] Expr - } deriving (Show, D.Data, D.Typeable) + } deriving (Show, Read, D.Data, D.Typeable) -- | -- A statement in a do-notation block @@ -441,4 +441,4 @@ data DoNotationElement -- | -- A do notation element with source position information -- - | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, D.Data, D.Typeable) + | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, Read, D.Data, D.Typeable) diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs index 53b60cd7d8..00e2b911d7 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -29,20 +29,20 @@ type Precedence = Integer -- | -- Associativity for infix operators -- -data Associativity = Infixl | Infixr | Infix deriving (Eq, Ord, D.Data, D.Typeable) +data Associativity = Infixl | Infixr | Infix deriving (Show, Read, Eq, Ord, D.Data, D.Typeable) -instance Show Associativity where - show Infixl = "infixl" - show Infixr = "infixr" - show Infix = "infix" +showAssoc :: Associativity -> String +showAssoc Infixl = "infixl" +showAssoc Infixr = "infixr" +showAssoc Infix = "infix" instance A.ToJSON Associativity where - toJSON = A.toJSON . show + toJSON = A.toJSON . showAssoc -- | -- Fixity data for infix operators -- -data Fixity = Fixity Associativity Precedence deriving (Show, Eq, Ord, D.Data, D.Typeable) +data Fixity = Fixity Associativity Precedence deriving (Show, Read, Eq, Ord, D.Data, D.Typeable) instance A.ToJSON Fixity where toJSON (Fixity associativity precedence) = diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index a60f93288e..5154a089c1 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -35,7 +35,7 @@ data SourcePos = SourcePos -- Column number -- , sourcePosColumn :: Int - } deriving (Eq, Ord, Show, D.Data, D.Typeable) + } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable) displaySourcePos :: SourcePos -> String displaySourcePos sp = @@ -58,7 +58,7 @@ data SourceSpan = SourceSpan -- End of the span -- , spanEnd :: SourcePos - } deriving (Eq, Ord, Show, D.Data, D.Typeable) + } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable) displayStartEndPos :: SourceSpan -> String displayStartEndPos sp = diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 6db4539ea9..ac9258aecb 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -56,16 +56,20 @@ data ErrorMessage | UnableToParseModule String | UnsupportedExport | ErrorInModule ModuleIdentifier ErrorMessage - deriving Show + deriving (Show, Read) -- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules. data ModuleType = Regular | Foreign - deriving (Show, Eq, Ord) + deriving (Show, Read, Eq, Ord) + +showModuleType :: ModuleType -> String +showModuleType Regular = "Regular" +showModuleType Foreign = "Foreign" -- | A module is identified by its module name and its type. -data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord) +data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Read, Eq, Ord) moduleName :: ModuleIdentifier -> String moduleName (ModuleIdentifier name _) = name @@ -81,7 +85,7 @@ type Key = (ModuleIdentifier, String) data ExportType = RegularExport String | ForeignReexport - deriving (Show, Eq, Ord) + deriving (Show, Read, Eq, Ord) -- | There are four types of module element we are interested in: -- @@ -97,10 +101,10 @@ data ModuleElement | Member JSNode Bool String [JSNode] [Key] | ExportsList [(ExportType, String, JSNode, [Key])] | Other JSNode - deriving Show + deriving (Show, Read) -- | A module is just a list of elements of the types listed above. -data Module = Module ModuleIdentifier [ModuleElement] deriving Show +data Module = Module ModuleIdentifier [ModuleElement] deriving (Show, Read) -- | Prepare an error message for consumption by humans. printErrorMessage :: ErrorMessage -> [String] @@ -127,7 +131,7 @@ printErrorMessage (ErrorInModule mid e) = : map (" " ++) (printErrorMessage e) where displayIdentifier (ModuleIdentifier name ty) = - name ++ " (" ++ show ty ++ ")" + name ++ " (" ++ showModuleType ty ++ ")" -- | Unpack the node inside a JSNode. This is useful when pattern matching. node :: JSNode -> Node diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs index 4e4c0e3687..c07df8df70 100644 --- a/src/Language/PureScript/CodeGen/Externs.hs +++ b/src/Language/PureScript/CodeGen/Externs.hs @@ -49,22 +49,22 @@ moduleToPs (Module _ _ moduleName ds (Just exts)) env = intercalate "\n" . execW listRef :: DeclarationRef -> Maybe String listRef (PositionedDeclarationRef _ _ d) = listRef d - listRef (TypeRef name Nothing) = Just $ show name ++ "()" - listRef (TypeRef name (Just dctors)) = Just $ show name ++ "(" ++ intercalate ", " (map show dctors) ++ ")" - listRef (ValueRef name) = Just $ show name - listRef (TypeClassRef name) = Just $ show name - listRef (ModuleRef name) = Just $ "module " ++ show name + listRef (TypeRef name Nothing) = Just $ runProperName name ++ "()" + listRef (TypeRef name (Just dctors)) = Just $ runProperName name ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")" + listRef (ValueRef name) = Just $ showIdent name + listRef (TypeClassRef name) = Just $ runProperName name + listRef (ModuleRef name) = Just $ "module " ++ runModuleName name listRef _ = Nothing declToPs :: Declaration -> Writer [String] () declToPs (ImportDeclaration mn imp Nothing) = - tell ["import " ++ show mn ++ importToPs imp] + tell ["import " ++ runModuleName mn ++ importToPs imp] declToPs (ImportDeclaration mn imp (Just qual)) = - tell ["import qualified " ++ show mn ++ importToPs imp ++ " as " ++ show qual] + tell ["import qualified " ++ runModuleName mn ++ importToPs imp ++ " as " ++ runModuleName qual] declToPs (FixityDeclaration (Fixity assoc prec) op) = case find exportsOp exts of Nothing -> return () - Just _ -> tell [ unwords [ show assoc, show prec, op ] ] + Just _ -> tell [ unwords [ showAssoc assoc, show prec, op ] ] where exportsOp :: DeclarationRef -> Bool exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r @@ -86,14 +86,14 @@ moduleToPs (Module _ _ moduleName ds (Just exts)) env = intercalate "\n" . execW exportToPs (PositionedDeclarationRef _ _ r) = exportToPs r exportToPs (TypeRef pn dctors) = case Qualified (Just moduleName) pn `M.lookup` types env of - Nothing -> error $ show pn ++ " has no kind in exportToPs" + Nothing -> error $ runProperName pn ++ " has no kind in exportToPs" Just (kind, ExternData) -> - tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind] + tell ["foreign import data " ++ runProperName pn ++ " :: " ++ prettyPrintKind kind] Just (_, DataType args tys) -> do let dctors' = fromMaybe (map fst tys) dctors printDctor dctor = case dctor `lookup` tys of Nothing -> Nothing - Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs) + Just tyArgs -> Just $ runProperName dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs) let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors') then "newtype" else "data" @@ -101,7 +101,7 @@ moduleToPs (Module _ _ moduleName ds (Just exts)) env = intercalate "\n" . execW tell [dtype ++ " " ++ typeName ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))] Just (_, TypeSynonym) -> case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of - Nothing -> error $ show pn ++ " has no type synonym info in exportToPs" + Nothing -> error $ runProperName pn ++ " has no type synonym info in exportToPs" Just (args, synTy) -> let typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args) @@ -110,29 +110,29 @@ moduleToPs (Module _ _ moduleName ds (Just exts)) env = intercalate "\n" . execW exportToPs (ValueRef ident) = case (moduleName, ident) `M.lookup` names env of - Nothing -> error $ show ident ++ " has no type in exportToPs" + Nothing -> error $ showIdent ident ++ " has no type in exportToPs" Just (ty, nk, _) | nk == Public || nk == External -> - tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty] + tell ["foreign import " ++ showIdent ident ++ " :: " ++ prettyPrintType ty] _ -> return () exportToPs (TypeClassRef className) = case Qualified (Just moduleName) className `M.lookup` typeClasses env of - Nothing -> error $ show className ++ " has no type class definition in exportToPs" + Nothing -> error $ runProperName className ++ " has no type class definition in exportToPs" Just (args, members, implies) -> do let impliesString = if null implies then "" - else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= " + else "(" ++ intercalate ", " (map (\(pn, tys') -> showQualified runProperName pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= " typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing className)) (map toTypeVar args) tell ["class " ++ impliesString ++ typeName ++ " where"] forM_ (filter (isValueExported . fst) members) $ \(member ,ty) -> - tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ] + tell [ " " ++ showIdent member ++ " :: " ++ prettyPrintType ty ] exportToPs (TypeInstanceRef ident) = do let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} = fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find (\tcd -> tcdName tcd == Qualified (Just moduleName) ident && tcdType tcd == TCDRegular) . maybe [] (M.elems >=> M.elems) . M.lookup (Just moduleName) $ typeClassDictionaries env let constraintsText = case fromMaybe [] deps of [] -> "" - cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => " - tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)] + cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> showQualified runProperName pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => " + tell ["foreign import instance " ++ showIdent ident ++ " :: " ++ constraintsText ++ showQualified runProperName className ++ " " ++ unwords (map prettyPrintTypeAtom tys)] exportToPs (ModuleRef _) = return () diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index e918703876..0be08d582f 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -172,7 +172,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do then foreignIdent ident else varToJs qi valueToJs (Var (_, _, _, Just IsForeign) ident) = - error $ "Encountered an unqualified reference to a foreign ident " ++ show ident + error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident valueToJs (Var _ ident) = return $ varToJs ident valueToJs (Case (maybeSpan, _, _, _) values binders) = do @@ -320,8 +320,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do done'' <- go remain done' js <- binderToJs argVar done'' binder return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js) - binderToJs _ _ b@(ConstructorBinder{}) = - error $ "Invalid ConstructorBinder in binderToJs: " ++ show b + binderToJs _ _ ConstructorBinder{} = + error "binderToJs: Invalid ConstructorBinder in binderToJs" binderToJs varName done (NamedBinder _ ident binder) = do js <- binderToJs varName done binder return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js) diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index 24d961a583..90be9747af 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -53,7 +53,7 @@ data UnaryOperator -- | -- Constructor -- - | JSNew deriving (Show, Eq, Data, Typeable) + | JSNew deriving (Show, Read, Eq, Data, Typeable) -- | -- Built-in binary operators @@ -134,7 +134,7 @@ data BinaryOperator -- | -- Bitwise right shift with zero-fill -- - | ZeroFillShiftRight deriving (Show, Eq, Data, Typeable) + | ZeroFillShiftRight deriving (Show, Read, Eq, Data, Typeable) -- | -- Data type for simplified Javascript expressions @@ -255,7 +255,7 @@ data JS -- | -- Commented Javascript -- - | JSComment [Comment] JS deriving (Show, Eq, Data, Typeable) + | JSComment [Comment] JS deriving (Show, Read, Eq, Data, Typeable) -- -- Traversals diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs index d6249efcea..fe73b737b8 100644 --- a/src/Language/PureScript/Comments.hs +++ b/src/Language/PureScript/Comments.hs @@ -22,4 +22,4 @@ import qualified Data.Data as D data Comment = LineComment String | BlockComment String - deriving (Show, Eq, Ord, D.Data, D.Typeable) + deriving (Show, Read, Eq, Ord, D.Data, D.Typeable) diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index 595f2cc227..77303a1b3e 100644 --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -45,4 +45,4 @@ data Binder a -- | -- A binder which binds its input to an identifier -- - | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable, Functor) + | NamedBinder a Ident (Binder a) deriving (Show, Read, D.Data, D.Typeable, Functor) diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index 67decc3058..8d86bf590e 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -64,7 +64,7 @@ data Expr a -- | -- A let binding -- - | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable, Functor) + | Let a [Bind a] (Expr a) deriving (Show, Read, D.Data, D.Typeable, Functor) -- | -- A let or module binding. @@ -77,7 +77,7 @@ data Bind a -- | -- Mutually recursive binding group for several values -- - | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable, Functor) + | Rec [(Ident, Expr a)] deriving (Show, Read, D.Data, D.Typeable, Functor) -- | -- A guard is just a boolean-valued expression that appears alongside a set of binders @@ -96,7 +96,7 @@ data CaseAlternative a = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a) - } deriving (Show, D.Data, D.Typeable) + } deriving (Show, Read, D.Data, D.Typeable) instance Functor CaseAlternative where diff --git a/src/Language/PureScript/CoreFn/Literals.hs b/src/Language/PureScript/CoreFn/Literals.hs index fed1814f91..7f49c0c814 100644 --- a/src/Language/PureScript/CoreFn/Literals.hs +++ b/src/Language/PureScript/CoreFn/Literals.hs @@ -47,4 +47,4 @@ data Literal a -- | -- An object literal -- - | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable, Functor) + | ObjectLiteral [(String, a)] deriving (Show, Read, D.Data, D.Typeable, Functor) diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs index 3d215246d7..bbd2abe634 100644 --- a/src/Language/PureScript/CoreFn/Meta.hs +++ b/src/Language/PureScript/CoreFn/Meta.hs @@ -39,7 +39,7 @@ data Meta -- | -- The contained reference is for a foreign member -- - | IsForeign deriving (Show, D.Data, D.Typeable) + | IsForeign deriving (Show, Read, D.Data, D.Typeable) -- | -- Data constructor metadata @@ -52,4 +52,4 @@ data ConstructorType -- | -- The constructor is for a type with multiple construcors -- - | SumType deriving (Show, D.Data, D.Typeable) + | SumType deriving (Show, Read, D.Data, D.Typeable) diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index b69e169af7..c9ceeb1467 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -26,6 +26,6 @@ data Module a = Module , moduleExports :: [Ident] , moduleForeign :: [ForeignDecl] , moduleDecls :: [Bind a] - } deriving (Show) + } deriving (Show, Read) type ForeignDecl = (Ident, Type) diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 516ea44c77..5476489d90 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -98,7 +98,7 @@ childToString f decl@ChildDeclaration{..} = data First = First | NotFirst - deriving (Show, Eq, Ord) + deriving (Show, Read, Eq, Ord) type Docs = Writer [String] () diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index cfeaee0fdd..b598ddeacc 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -26,7 +26,7 @@ import Language.PureScript.Docs.Types -- convertModule :: P.Module -> Module convertModule m@(P.Module _ coms moduleName _ _) = - Module (show moduleName) comments (declarations m) + Module (P.runModuleName moduleName) comments (declarations m) where comments = convertComments coms declarations = @@ -106,13 +106,13 @@ addDefaultFixity decl@Declaration{..} defaultFixity = P.Fixity P.Infixl (-1) getDeclarationTitle :: P.Declaration -> Maybe String -getDeclarationTitle (P.TypeDeclaration name _) = Just (show name) -getDeclarationTitle (P.ExternDeclaration name _) = Just (show name) -getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name) -getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name) -getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name) -getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name) -getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name) +getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name) +getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name) +getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name) +getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name) +getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) +getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name) +getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name) getDeclarationTitle (P.FixityDeclaration _ name) = Just ("(" ++ name ++ ")") getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d getDeclarationTitle _ = Nothing @@ -142,7 +142,7 @@ convertDeclaration (P.DataDeclaration dtype _ args ctors) title = info = DataDeclaration dtype args children = map convertCtor ctors convertCtor (ctor', tys) = - ChildDeclaration (show ctor') Nothing Nothing (ChildDataConstructor tys) + ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys) convertDeclaration (P.ExternDataDeclaration _ kind') title = basicDeclaration title (ExternDataDeclaration kind') convertDeclaration (P.TypeSynonymDeclaration _ args ty) title = @@ -155,7 +155,7 @@ convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = do convertClassMember (P.PositionedDeclaration _ _ d) = convertClassMember d convertClassMember (P.TypeDeclaration ident' ty) = - ChildDeclaration (show ident') Nothing Nothing (ChildTypeClassMember ty) + ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty) convertClassMember _ = error "Invalid argument to convertClassMember." convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = do @@ -163,7 +163,7 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit where classNameString = unQual className typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys) - unQual x = let (P.Qualified _ y) = x in show y + unQual x = let (P.Qualified _ y) = x in P.runProperName y extractProperNames (P.TypeConstructor n) = [unQual n] extractProperNames (P.SaturatedTypeSynonym n _) = [unQual n] @@ -225,4 +225,3 @@ collectBookmarks' m = map (P.getModuleName m, ) (mapMaybe getDeclarationTitle (P.exportedDeclarations m)) - diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 7726cce177..29b9b06f63 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -29,7 +29,7 @@ renderDeclarationWithOptions opts Declaration{..} = , renderType' ty ] DataDeclaration dtype args -> - [ keyword (show dtype) + [ keyword (P.showDataDeclType dtype) , renderType' (typeApp declTitle args) ] ExternDataDeclaration kind' -> diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index 9ab8a1cb05..35030fa42c 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -45,7 +45,7 @@ typeLiterals = mkPattern match , syntax "}" ] match (TypeConstructor (Qualified mn name)) = - Just (ctor (show name) (maybeToContainingModule mn)) + Just (ctor (runProperName name) (maybeToContainingModule mn)) match (ConstrainedType deps ty) = Just $ mintersperse sp [ syntax "(" <> constraints <> syntax ")" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 1818e803f7..3e6773d885 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -57,7 +57,7 @@ data Environment = Environment { -- Type classes -- , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint]) - } deriving (Show) + } deriving (Show, Read) -- | -- The initial environment with no values and only the default javascript types defined @@ -76,7 +76,7 @@ data NameVisibility -- | -- The name is defined in the another binding group, or has been made visible by a function binder -- - | Defined deriving (Show, Eq) + | Defined deriving (Show, Read, Eq) -- | -- A flag for whether a name is for an private or public value - only public values will be @@ -95,7 +95,7 @@ data NameKind -- | -- A name for member introduced by foreign import -- - | External deriving (Show, Eq, Data, Typeable) + | External deriving (Show, Read, Eq, Data, Typeable) -- | -- The kinds of a type @@ -121,7 +121,7 @@ data TypeKind -- A scoped type variable -- | ScopedTypeVar - deriving (Show, Eq, Data, Typeable) + deriving (Show, Read, Eq, Data, Typeable) -- | -- The type ('data' or 'newtype') of a data type declaration @@ -134,14 +134,14 @@ data DataDeclType -- | -- A newtype constructor -- - | Newtype deriving (Eq, Ord, Data, Typeable) + | Newtype deriving (Show, Read, Eq, Ord, Data, Typeable) -instance Show DataDeclType where - show Data = "data" - show Newtype = "newtype" +showDataDeclType :: DataDeclType -> String +showDataDeclType Data = "data" +showDataDeclType Newtype = "newtype" instance A.ToJSON DataDeclType where - toJSON = A.toJSON . show + toJSON = A.toJSON . showDataDeclType instance A.FromJSON DataDeclType where parseJSON = A.withText "DataDeclType" $ \str -> diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 5dda4ac46b..8169125072 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -309,7 +309,7 @@ onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleE onErrorMessages f = MultipleErrors . map f . runMultipleErrors -- | The various types of things which might need to be relabelled in errors messages. -data LabelType = TypeLabel | SkolemLabel String deriving (Show, Eq, Ord) +data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord) -- | A map from rigid type variable name/unknown variable pairs to new variables. type UnknownMap = M.Map (LabelType, Unknown) Unknown @@ -430,13 +430,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , indent . prettyPrintParseError $ err ] goSimple (MissingFFIModule mn) = - line $ "Missing FFI implementations for module " ++ show mn + line $ "Missing FFI implementations for module " ++ runModuleName mn goSimple (UnnecessaryFFIModule mn path) = - paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ show mn ++ ": " + paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ runModuleName mn ++ ": " , indent . line $ path ] goSimple (MultipleFFIModules mn paths) = - paras $ [ line $ "Multiple FFI implementations have been provided for module " ++ show mn ++ ": " ] + paras $ [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": " ] ++ map (indent . line) paths goSimple (InvalidExternsFile path) = paras [ line "Externs file is invalid: " @@ -461,80 +461,80 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , indent $ line $ prettyPrintKind ki ] goSimple (MultipleFixities name) = - line $ "Multiple fixity declarations for " ++ show name + line $ "Multiple fixity declarations for " ++ showIdent name goSimple (OrphanTypeDeclaration nm) = - line $ "Orphan type declaration for " ++ show nm + line $ "Orphan type declaration for " ++ showIdent nm goSimple (OrphanFixityDeclaration op) = line $ "Orphan fixity declaration for " ++ show op goSimple (RedefinedModule name filenames) = - paras $ [ line $ "Module " ++ show name ++ " has been defined multiple times:" - ] ++ map (indent . line . displaySourceSpan) filenames + paras $ line ("Module " ++ runModuleName name ++ " has been defined multiple times:") + : map (indent . line . displaySourceSpan) filenames goSimple (RedefinedIdent name) = - line $ "Name " ++ show name ++ " has been defined multiple times" + line $ "Name " ++ showIdent name ++ " has been defined multiple times" goSimple (UnknownModule mn) = - line $ "Unknown module " ++ show mn + line $ "Unknown module " ++ runModuleName mn goSimple (UnknownType name) = - line $ "Unknown type " ++ show name + line $ "Unknown type " ++ showQualified runProperName name goSimple (UnknownTypeClass name) = - line $ "Unknown type class " ++ show name + line $ "Unknown type class " ++ showQualified runProperName name goSimple (UnknownValue name) = - line $ "Unknown value " ++ show name + line $ "Unknown value " ++ showQualified showIdent name goSimple (UnknownTypeConstructor name) = - line $ "Unknown type constructor " ++ show name + line $ "Unknown type constructor " ++ showQualified runProperName name goSimple (UnknownDataConstructor dc tc) = - line $ "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc + line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc goSimple (UnknownImportType mn name) = - line $ "Module " ++ show mn ++ " does not export type " ++ show name + line $ "Module " ++ runModuleName mn ++ " does not export type " ++ runProperName name goSimple (UnknownExportType name) = - line $ "Cannot export unknown type " ++ show name + line $ "Cannot export unknown type " ++ runProperName name goSimple (UnknownImportTypeClass mn name) = - line $ "Module " ++ show mn ++ " does not export type class " ++ show name + line $ "Module " ++ runModuleName mn ++ " does not export type class " ++ runProperName name goSimple (UnknownExportTypeClass name) = - line $ "Cannot export unknown type class " ++ show name + line $ "Cannot export unknown type class " ++ runProperName name goSimple (UnknownImportValue mn name) = - line $ "Module " ++ show mn ++ " does not export value " ++ show name + line $ "Module " ++ runModuleName mn ++ " does not export value " ++ showIdent name goSimple (UnknownExportValue name) = - line $ "Cannot export unknown value " ++ show name + line $ "Cannot export unknown value " ++ showIdent name goSimple (UnknownExportModule name) = - line $ "Cannot export unknown module " ++ show name ++ ", it either does not exist or has not been imported by the current module" + line $ "Cannot export unknown module " ++ runModuleName name ++ ", it either does not exist or has not been imported by the current module" goSimple (UnknownImportDataConstructor mn tcon dcon) = - line $ "Module " ++ show mn ++ " does not export data constructor " ++ show dcon ++ " for type " ++ show tcon + line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon goSimple (UnknownExportDataConstructor tcon dcon) = - line $ "Cannot export data constructor " ++ show dcon ++ " for type " ++ show tcon ++ " as it has not been declared" + line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ " as it has not been declared" goSimple (ConflictingImport nm mn) = - line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ show mn + line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ runModuleName mn goSimple (ConflictingImports nm m1 m2) = - line $ "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2 + line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2 goSimple (ConflictingTypeDecls nm) = - line $ "Conflicting type declarations for " ++ show nm + line $ "Conflicting type declarations for " ++ runProperName nm goSimple (ConflictingCtorDecls nm) = - line $ "Conflicting data constructor declarations for " ++ show nm + line $ "Conflicting data constructor declarations for " ++ runProperName nm goSimple (TypeConflictsWithClass nm) = - line $ "Type " ++ show nm ++ " conflicts with type class declaration of the same name" + line $ "Type " ++ runProperName nm ++ " conflicts with type class declaration of the same name" goSimple (CtorConflictsWithClass nm) = - line $ "Data constructor " ++ show nm ++ " conflicts with type class declaration of the same name" + line $ "Data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name" goSimple (ClassConflictsWithType nm) = - line $ "Type class " ++ show nm ++ " conflicts with type declaration of the same name" + line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name" goSimple (ClassConflictsWithCtor nm) = - line $ "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name" + line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name" goSimple (DuplicateClassExport nm) = - line $ "Duplicate export declaration for type class " ++ show nm + line $ "Duplicate export declaration for type class " ++ runProperName nm goSimple (DuplicateValueExport nm) = - line $ "Duplicate export declaration for value " ++ show nm + line $ "Duplicate export declaration for value " ++ showIdent nm goSimple (CycleInDeclaration nm) = - line $ "Cycle in declaration of " ++ show nm + line $ "Cycle in declaration of " ++ showIdent nm goSimple (CycleInModules mns) = - line $ "Cycle in module dependencies: " ++ intercalate ", " (map show mns) + line $ "Cycle in module dependencies: " ++ intercalate ", " (map runModuleName mns) goSimple (CycleInTypeSynonym pn) = - line $ "Cycle in type synonym" ++ foldMap ((" " ++) . show) pn + line $ "Cycle in type synonym" ++ foldMap ((" " ++) . runProperName) pn goSimple (NameIsUndefined ident) = - line $ show ident ++ " is undefined" + line $ showIdent ident ++ " is undefined" goSimple (NameNotInScope ident) = - line $ show ident ++ " may not be defined in the current scope" + line $ showIdent ident ++ " may not be defined in the current scope" goSimple (UndefinedTypeVariable name) = - line $ "Type variable " ++ show name ++ " is undefined" + line $ "Type variable " ++ runProperName name ++ " is undefined" goSimple (PartiallyAppliedSynonym name) = - paras [ line $ "Partially applied type synonym " ++ show name + paras [ line $ "Partially applied type synonym " ++ showQualified runProperName name , line "Type synonyms must be applied to all of their type arguments." ] goSimple (EscapedSkolem binding) = @@ -561,18 +561,18 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , indent $ line $ prettyPrintType t2 ] goSimple (OverlappingInstances nm ts (d : ds)) = - paras [ line $ "Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":" - , indent $ paras (line (show d ++ " (chosen)") : map (line . show) ds) + paras [ line $ "Overlapping instances found for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":" + , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds) ] goSimple OverlappingInstances{} = error "OverlappingInstances: empty instance list" goSimple (NoInstanceFound nm ts) = - line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) + line $ "No instance found for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) goSimple (PossiblyInfiniteInstance nm ts) = - line $ "Instance for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is possibly infinite." + line $ "Instance for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is possibly infinite." goSimple (CannotDerive nm ts) = - line $ "Cannot derive " ++ show nm ++ " instance for " ++ unwords (map prettyPrintTypeAtom ts) + line $ "Cannot derive " ++ showQualified runProperName nm ++ " instance for " ++ unwords (map prettyPrintTypeAtom ts) goSimple (CannotFindDerivingType nm) = - line $ "Cannot derive instance, because the type declaration for " ++ show nm ++ " could not be found." + line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found." goSimple (DuplicateLabel l expr) = paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ] <> foldMap (\expr' -> [ line "Relevant expression: " @@ -581,22 +581,22 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError goSimple (DuplicateTypeArgument name) = line $ "Duplicate type argument " ++ show name goSimple (DuplicateValueDeclaration nm) = - line $ "Duplicate value declaration for " ++ show nm + line $ "Duplicate value declaration for " ++ showIdent nm goSimple (ArgListLengthsDiffer ident) = - line $ "Argument list lengths differ in declaration " ++ show ident + line $ "Argument list lengths differ in declaration " ++ showIdent ident goSimple (OverlappingArgNames ident) = - line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident + line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident goSimple (MissingClassMember ident) = - line $ "Member " ++ show ident ++ " has not been implemented" + line $ "Member " ++ showIdent ident ++ " has not been implemented" goSimple (ExtraneousClassMember ident) = - line $ "Member " ++ show ident ++ " is not a member of the class being instantiated" + line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated" goSimple (ExpectedType ty kind) = paras [ line "In a type-annotated expression x :: t, the type t must have kind *." , line $ "The error arises from the type " ++ prettyPrintType ty ++ " having the kind " ++ prettyPrintKind kind ++ " instead." ] goSimple (IncorrectConstructorArity nm) = - line $ "Wrong number of arguments to constructor " ++ show nm - goSimple SubsumptionCheckFailed = line $ "Unable to check type subsumption" + line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm + goSimple SubsumptionCheckFailed = line "Unable to check type subsumption" goSimple (ExprDoesNotHaveType expr ty) = paras [ line "Expression" , indent $ line $ prettyPrintValue expr @@ -614,7 +614,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError goSimple TypeSynonymInstance = line "Type synonym instances are disallowed" goSimple (OrphanInstance nm cnm ts) = - paras [ line $ "Instance " ++ show nm ++ " for " ++ show cnm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is an orphan instance." + paras [ line $ "Instance " ++ showIdent nm ++ " for " ++ showQualified runProperName cnm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is an orphan instance." , line "An orphan instance is an instance which is defined in neither the class module nor the data type module." , line "Consider moving the instance, if possible, or using a newtype wrapper." ] @@ -625,19 +625,19 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , indent $ line $ prettyPrintType ty ] goSimple (TransitiveExportError x ys) = - paras $ (line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ") + paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ") : map (line . prettyPrintExport) ys goSimple (ShadowedName nm) = - line $ "Name '" ++ show nm ++ "' was shadowed." + line $ "Name '" ++ showIdent nm ++ "' was shadowed." goSimple (ClassOperator className opName) = - paras [ line $ "Class '" ++ show className ++ "' declares operator " ++ show opName ++ "." - , indent $ line $ "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:" - , indent $ line $ show opName ++ " = someMember" + paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "." + , indent $ line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:" + , indent $ line $ showIdent opName ++ " = someMember" ] goSimple (MisleadingEmptyTypeImport mn name) = - line $ "Importing type " ++ show name ++ "(..) from " ++ show mn ++ " is misleading as it has no exported data constructors" + line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors" goSimple (ImportHidingModule name) = - line $ "Attempted to hide module " ++ show name ++ " in import expression, this is not permitted" + line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted" goSimple (WildcardInferredType ty) = line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty goSimple (NotExhaustivePattern bs b) = @@ -652,7 +652,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError ] ++ [ line "..." | not b ] go (NotYetDefined names err) = - paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":" + paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":" , indent $ go err ] go (ErrorUnifyingTypes t1 t2 err) = @@ -668,7 +668,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , go err ] go (ErrorInModule mn err) = - paras [ lineWithLevel $ "in module " ++ show mn ++ ":" + paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":" , go err ] go (ErrorInSubsumption t1 t2 err) = @@ -679,7 +679,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , go err ] go (ErrorInInstance name ts err) = - paras [ lineWithLevel $ "in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":" + paras [ lineWithLevel $ "in type class instance " ++ showQualified runProperName name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":" , go err ] go (ErrorCheckingKind ty err) = @@ -709,15 +709,15 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , go err ] go (ErrorInDataConstructor nm err) = - paras [ lineWithLevel $ "in data constructor " ++ show nm ++ ":" + paras [ lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":" , go err ] go (ErrorInTypeConstructor nm err) = - paras [ lineWithLevel $ "in type constructor " ++ show nm ++ ":" + paras [ lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":" , go err ] go (ErrorInBindingGroup nms err) = - paras [ lineWithLevel $ "in binding group " ++ intercalate ", " (map show nms) ++ ":" + paras [ lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":" , go err ] go (ErrorInDataBindingGroup err) = @@ -725,15 +725,15 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , go err ] go (ErrorInTypeSynonym name err) = - paras [ lineWithLevel $ "in type synonym " ++ show name ++ ":" + paras [ lineWithLevel $ "in type synonym " ++ runProperName name ++ ":" , go err ] go (ErrorInValueDeclaration n err) = - paras [ lineWithLevel $ "in value declaration " ++ show n ++ ":" + paras [ lineWithLevel $ "in value declaration " ++ showIdent n ++ ":" , go err ] go (ErrorInForeignImport nm err) = - paras [ lineWithLevel $ "in foreign import " ++ show nm ++ ":" + paras [ lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":" , go err ] go (PositionedError srcSpan err) = @@ -753,8 +753,8 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError suggestions :: ErrorMessage -> [Box.Box] suggestions = suggestions' . unwrapErrorMessage where - suggestions' (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ show im ++ ":" - , indent . line $ "import " ++ show im ++ " hiding (" ++ nm ++ ")" + suggestions' (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":" + , indent . line $ "import " ++ runModuleName im ++ " hiding (" ++ nm ++ ")" ] suggestions' (TypesDoNotUnify t1 t2) | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"] @@ -768,11 +768,11 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError -- Pretty print and export declaration -- prettyPrintExport :: DeclarationRef -> String - prettyPrintExport (TypeRef pn _) = show pn - prettyPrintExport (ValueRef ident) = show ident - prettyPrintExport (TypeClassRef pn) = show pn - prettyPrintExport (TypeInstanceRef ident) = show ident - prettyPrintExport (ModuleRef name) = "module " ++ show name + prettyPrintExport (TypeRef pn _) = runProperName pn + prettyPrintExport (ValueRef ident) = showIdent ident + prettyPrintExport (TypeClassRef pn) = runProperName pn + prettyPrintExport (TypeInstanceRef ident) = showIdent ident + prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref -- | diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 4355844cab..1c63b7d6b9 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -49,7 +49,7 @@ data Kind -- | -- Function kinds -- - | FunKind Kind Kind deriving (Show, Eq, Ord, Data, Typeable) + | FunKind Kind Kind deriving (Show, Read, Eq, Ord, Data, Typeable) $(A.deriveJSON A.defaultOptions ''Kind) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 7bd22daf3c..b6ed4639a8 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -69,7 +69,7 @@ getConstructors env defmn n = extractConstructors lnte getConsDataName con = qualifyName nm defmn con where nm = case getConsInfo con of - Nothing -> error $ "ProperName " ++ show con ++ " not in the scope of the current environment in getConsDataName." + Nothing -> error $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName." Just (_, pm, _, _) -> pm getConsInfo :: (Qualified ProperName) -> Maybe (DataDeclType, ProperName, Type, [Ident]) @@ -280,4 +280,3 @@ checkExhaustiveDecls env mn ds = -- checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m () checkExhaustiveModule env (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds - diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 598f33e056..a9f67e6c3e 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -86,7 +86,7 @@ import qualified Paths_purescript as Paths -- | Progress messages from the make process data ProgressMessage = CompilingModule ModuleName - deriving (Show, Eq, Ord) + deriving (Show, Read, Eq, Ord) -- | Render a progress message renderProgressMessage :: ProgressMessage -> String @@ -139,7 +139,7 @@ data RebuildPolicy -- | Never rebuild this module = RebuildNever -- | Always rebuild this module - | RebuildAlways deriving (Show, Eq, Ord) + | RebuildAlways deriving (Show, Read, Eq, Ord) -- | -- Compiles in "make" mode, compiling each module separately to a js files and an externs file diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 28eb8ae804..6d7ea535a4 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -36,28 +36,25 @@ data Ident -- | -- A symbolic name for an infix operator -- - | Op String deriving (Eq, Ord, Data, Typeable) + | Op String deriving (Show, Read, Eq, Ord, Data, Typeable) runIdent :: Ident -> String runIdent (Ident i) = i runIdent (Op op) = op -instance Show Ident where - show (Ident s) = s - show (Op op) = '(':op ++ ")" +showIdent :: Ident -> String +showIdent (Ident i) = i +showIdent (Op op) = '(' : op ++ ")" -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. -- -newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable) - -instance Show ProperName where - show = runProperName +newtype ProperName = ProperName { runProperName :: String } deriving (Show, Read, Eq, Ord, Data, Typeable) -- | -- Module names -- -data ModuleName = ModuleName [ProperName] deriving (Eq, Ord, Data, Typeable) +data ModuleName = ModuleName [ProperName] deriving (Show, Read, Eq, Ord, Data, Typeable) runModuleName :: ModuleName -> String runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns) @@ -70,20 +67,17 @@ moduleNameFromString = ModuleName . splitProperNames s' -> ProperName w : splitProperNames s'' where (w, s'') = break (== '.') s' -instance Show ModuleName where - show = runModuleName - -- | -- A qualified name, i.e. a name with an optional module name -- -data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable, Functor) +data Qualified a = Qualified (Maybe ModuleName) a deriving (Show, Read, Eq, Ord, Data, Typeable, Functor) -instance (Show a) => Show (Qualified a) where - show (Qualified Nothing a) = show a - show (Qualified (Just name) a) = show name ++ "." ++ show a +showQualified :: (a -> String) -> Qualified a -> String +showQualified f (Qualified Nothing a) = f a +showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a instance (a ~ ProperName) => A.ToJSON (Qualified a) where - toJSON = A.toJSON . show + toJSON = A.toJSON . showQualified runProperName instance (a ~ ProperName) => A.FromJSON (Qualified a) where parseJSON = diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 449c05574b..e57288ea22 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -115,7 +115,7 @@ data Token | CharLiteral Char | StringLiteral String | Number (Either Integer Double) - deriving (Show, Eq, Ord) + deriving (Show, Read, Eq, Ord) prettyPrintToken :: Token -> String prettyPrintToken LParen = "(" @@ -153,8 +153,9 @@ data PositionedToken = PositionedToken , ptComments :: [Comment] } deriving (Eq) +-- Parsec requires this instance for various token-level combinators instance Show PositionedToken where - show = show . ptToken + show = prettyPrintToken . ptToken lex :: FilePath -> String -> Either P.ParseError [PositionedToken] lex filePath input = P.parse parseTokens filePath input @@ -251,7 +252,7 @@ parseToken = P.choice where -- lookAhead doesn't consume any input if its parser succeeds -- if notFollowedBy fails though, the consumed '0' will break the choice chain - consumeLeadingZero = P.lookAhead (P.char '0' >> + consumeLeadingZero = P.lookAhead (P.char '0' >> (P.notFollowedBy P.digit P. "no leading zero in number literal")) -- | @@ -517,4 +518,3 @@ reservedTypeNames = [ "forall", "where" ] -- opChars :: [Char] opChars = ":!#$%&*+./<=>?@\\^|-~" - diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 4c11054f02..75c278ded0 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -25,7 +25,7 @@ import Language.PureScript.Parser.Lexer (reservedPsNames, opChars) parens :: String -> String parens s = ('(':s) ++ ")" -newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord) +newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Read, Eq, Ord) -- | -- Number of characters per identation level diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 37e006cd49..ede0d11ce2 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -26,6 +26,7 @@ import Control.Arrow ((<+>)) import Control.PatternArrows import Language.PureScript.Types +import Language.PureScript.Names import Language.PureScript.Kinds import Language.PureScript.Pretty.Common import Language.PureScript.Pretty.Kinds @@ -37,11 +38,11 @@ typeLiterals = mkPattern match match TypeWildcard = Just "_" match (TypeVar var) = Just var match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }" - match (TypeConstructor ctor) = Just $ show ctor + match (TypeConstructor ctor) = Just $ showQualified runProperName ctor match (TUnknown u) = Just $ '_' : show u match (Skolem name s _) = Just $ name ++ show s - match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty - match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">" + match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> showQualified runProperName pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty + match (SaturatedTypeSynonym name args) = Just $ showQualified runProperName name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">" match REmpty = Just "()" match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")" match _ = Nothing @@ -124,4 +125,3 @@ prettyPrintTypeAtom = fromMaybe (error "Incomplete pattern") . pattern matchType -- prettyPrintType :: Type -> String prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders - diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index e476b3764a..68892732e7 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -50,11 +50,11 @@ literals = mkPattern' match match (ObjectConstructor ps) = prettyPrintObject' ps match (ObjectGetter prop) = return $ "(." ++ prop ++ ")" match (TypeClassDictionaryConstructorApp className ps) = concat <$> sequence - [ return (show className ++ "(\n") + [ return (showQualified runProperName className ++ "(\n") , match ps , return ")" ] - match (Constructor name) = return $ show name + match (Constructor name) = return $ showQualified runProperName name match (Case values binders) = concat <$> sequence [ return "case " , unwords <$> forM values prettyPrintValue' @@ -70,7 +70,7 @@ literals = mkPattern' match , return "in " , prettyPrintValue' val ] - match (Var ident) = return $ show ident + match (Var ident) = return $ showQualified showIdent ident match (Do els) = concat <$> sequence [ return "do\n" , withIndent $ prettyPrintMany prettyPrintDoNotationElement els @@ -78,16 +78,16 @@ literals = mkPattern' match ] match (OperatorSection op (Right val)) = return $ "(" ++ prettyPrintValue op ++ " " ++ prettyPrintValue val ++ ")" match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ prettyPrintValue op ++ ")" - match (TypeClassDictionary (name, tys) _) = return $ "<>" - match (SuperClassDictionary name _) = return $ "<>" + match (TypeClassDictionary (name, tys) _) = return $ "<>" + match (SuperClassDictionary name _) = return $ "<>" match (TypedValue _ val _) = prettyPrintValue' val match (PositionedValue _ _ val) = prettyPrintValue' val match _ = mzero prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String -prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty +prettyPrintDeclaration (TypeDeclaration ident ty) = return $ showIdent ident ++ " :: " ++ prettyPrintType ty prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = concat <$> sequence - [ return $ show ident ++ " = " + [ return $ showIdent ident ++ " = " , prettyPrintValue' val ] prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d @@ -165,7 +165,7 @@ app = mkPattern match lam :: Pattern PrinterState Expr (String, Expr) lam = mkPattern match where - match (Abs (Left arg) val) = Just (show arg, val) + match (Abs (Left arg) val) = Just (showIdent arg, val) match _ = Nothing -- | @@ -195,20 +195,20 @@ prettyPrintBinderAtom (CharBinder c) = show c prettyPrintBinderAtom (NumberBinder num) = either show show num prettyPrintBinderAtom (BooleanBinder True) = "true" prettyPrintBinderAtom (BooleanBinder False) = "false" -prettyPrintBinderAtom (VarBinder ident) = show ident -prettyPrintBinderAtom (ConstructorBinder ctor []) = show ctor -prettyPrintBinderAtom (ObjectBinder bs) = - "{ " +prettyPrintBinderAtom (VarBinder ident) = showIdent ident +prettyPrintBinderAtom (ConstructorBinder ctor []) = showQualified runProperName ctor +prettyPrintBinderAtom (ObjectBinder bs) = + "{ " ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs) ++ " }" where prettyPrintObjectPropertyBinder :: (String, Binder) -> String prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder prettyPrintBinderAtom (ArrayBinder bs) = - "[ " + "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]" -prettyPrintBinderAtom (NamedBinder ident binder) = show ident ++ "@" ++ prettyPrintBinder binder +prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder prettyPrintBinderAtom b = parens (prettyPrintBinder b) @@ -216,7 +216,7 @@ prettyPrintBinderAtom b = parens (prettyPrintBinder b) -- Generate a pretty-printed string representing a Binder -- prettyPrintBinder :: Binder -> String -prettyPrintBinder (ConstructorBinder ctor []) = show ctor -prettyPrintBinder (ConstructorBinder ctor args) = show ctor ++ " " ++ unwords (map prettyPrintBinderAtom args) +prettyPrintBinder (ConstructorBinder ctor []) = showQualified runProperName ctor +prettyPrintBinder (ConstructorBinder ctor args) = showQualified runProperName ctor ++ " " ++ unwords (map prettyPrintBinderAtom args) prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder prettyPrintBinder b = prettyPrintBinderAtom b diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 40811cc0e1..7cd8316a77 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -147,7 +147,7 @@ getModulesAndBookmarks = do renderModules bookmarks modules = return (bookmarks, map D.convertModule modules) -data TreeStatus = Clean | Dirty deriving (Show, Eq, Ord, Enum) +data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum) getGitWorkingTreeStatus :: PrepareM TreeStatus getGitWorkingTreeStatus = do @@ -228,7 +228,7 @@ data DependencyStatus | ResolvedVersion String -- ^ Resolved to a version. The String argument is the resolution tag (eg, -- "v0.1.0"). - deriving (Show, Eq) + deriving (Show, Read, Eq) -- Go through all bower dependencies which contain purescript code, and -- extract their versions. diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 9ef1374c2b..9abcb27199 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -204,7 +204,7 @@ displayUserError e = case e of ParseAndDesugarError (D.ParseError err) -> vcat [ para "Parse error:" - , indented (para (show err)) + , indented (P.prettyPrintMultipleErrorsBox False err) ] ParseAndDesugarError (D.SortModulesError err) -> vcat diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index 7576e518a8..6d67d8a170 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -100,7 +100,7 @@ lookupIdent name = do name' <- gets $ M.lookup name . rsBoundNames case name' of Just name'' -> return name'' - Nothing -> error $ "Rename scope is missing ident '" ++ show name ++ "'" + Nothing -> error $ "Rename scope is missing ident '" ++ showIdent name ++ "'" -- | -- Finds idents introduced by declarations. @@ -119,7 +119,7 @@ renameInModules = map go where go :: Module Ann -> Module Ann go m@(Module _ _ _ _ _ decls) = m { moduleDecls = map (renameInDecl' (findDeclIdents decls)) decls } - + renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann renameInDecl' scope = runRename scope . renameInDecl True diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index dd282c9662..48d75aa5e8 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -208,12 +208,12 @@ renameInModule env imports (Module ss coms mn decls exps) = -- Update names so unqualified references become qualified, and locally -- qualified references are replaced with their canoncial qualified names -- (e.g. M.Map -> Data.Map.Map). - update :: (Ord a, Show a) => (Qualified a -> SimpleErrorMessage) - -> M.Map (Qualified a) (Qualified a, ModuleName) - -> (Exports -> a -> Maybe (Qualified a)) - -> Qualified a - -> Maybe SourceSpan - -> m (Qualified a) + update :: (Ord a) => (Qualified a -> SimpleErrorMessage) + -> M.Map (Qualified a) (Qualified a, ModuleName) + -> (Exports -> a -> Maybe (Qualified a)) + -> Qualified a + -> Maybe SourceSpan + -> m (Qualified a) update unknown imps getE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imps, mn') of -- We found the name in our imports, so we return the name for it, diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 115fbafcd5..a5c7fd72c6 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -67,7 +67,7 @@ data Imports = Imports -- The list of modules that have been imported into the current scope. -- , importedModules :: [ModuleName] - } deriving (Show) + } deriving (Show, Read) -- | -- An empty 'Imports' value. @@ -95,7 +95,7 @@ data Exports = Exports -- came from. -- , exportedValues :: [(Ident, ModuleName)] - } deriving (Show) + } deriving (Show, Read) -- | -- An empty 'Exports' value. @@ -184,7 +184,7 @@ exportValue exps name mn = do -- Adds an entry to a list of exports unless it is already present, in which case an error is -- returned. -- -addExport :: (MonadError MultipleErrors m, Eq a, Show a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)] +addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)] addExport what name mn exports = if any ((== name) . fst) exports then throwConflictError what name @@ -193,5 +193,5 @@ addExport what name mn exports = -- | -- Raises an error for when there is more than one definition for something. -- -throwConflictError :: (MonadError MultipleErrors m, Show a) => (a -> SimpleErrorMessage) -> a -> m b +throwConflictError :: (MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> a -> m b throwConflictError conflict = throwError . errorMessage . conflict diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index b82182e873..22951f0daa 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -111,7 +111,7 @@ resolveImport currentModule importModule exps imps impQual = check _ = error "Invalid argument to checkRefs" -- Check that an explicitly imported item exists in the module it is being imported from - checkImportExists :: (Eq a, Show a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m () + checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m () checkImportExists unknown exports item = when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item @@ -149,20 +149,20 @@ resolveImport currentModule importModule exps imps impQual = importExplicit imp (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos . warnWithPosition pos $ importExplicit imp r importExplicit imp (ValueRef name) = do - values' <- updateImports (importedValues imp) (exportedValues exps) name + values' <- updateImports (importedValues imp) showIdent (exportedValues exps) name return $ imp { importedValues = values' } importExplicit imp (TypeRef name dctors) = do - types' <- updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name + types' <- updateImports (importedTypes imp) runProperName (first fst `map` exportedTypes exps) name let exportedDctors :: [(ProperName, ModuleName)] exportedDctors = allExportedDataConstructors name dctorNames :: [ProperName] dctorNames = fst `map` exportedDctors maybe (return ()) (mapM_ $ checkDctorExists name dctorNames) dctors when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name - dctors' <- foldM (flip updateImports exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors) + dctors' <- foldM (\m -> updateImports m runProperName exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors) return $ imp { importedTypes = types', importedDataConstructors = dctors' } importExplicit imp (TypeClassRef name) = do - typeClasses' <- updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name + typeClasses' <- updateImports (importedTypeClasses imp) runProperName (exportedTypeClasses exps) name return $ imp { importedTypeClasses = typeClasses' } importExplicit _ _ = error "Invalid argument to importExplicit" @@ -174,11 +174,12 @@ resolveImport currentModule importModule exps imps impQual = Just ((_, dctors), mn) -> map (, mn) dctors -- Add something to the Imports if it does not already exist there - updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a, ModuleName) - -> [(a, ModuleName)] - -> a - -> m (M.Map (Qualified a) (Qualified a, ModuleName)) - updateImports imps' exps' name = case M.lookup (Qualified impQual name) imps' of + updateImports :: (Ord a) => M.Map (Qualified a) (Qualified a, ModuleName) + -> (a -> String) + -> [(a, ModuleName)] + -> a + -> m (M.Map (Qualified a) (Qualified a, ModuleName)) + updateImports imps' render exps' name = case M.lookup (Qualified impQual name) imps' of -- If the name is not already present add it to the list, after looking up -- where it was originally defined @@ -195,8 +196,8 @@ resolveImport currentModule importModule exps imps impQual = | otherwise -> throwError . errorMessage $ err where err = if currentModule `elem` [mn, importModule] - then ConflictingImport (show name) importModule - else ConflictingImports (show name) mn importModule + then ConflictingImport (render name) importModule + else ConflictingImports (render name) mn importModule Just (Qualified Nothing _, _) -> error "Invalid state in updateImports" diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 17e5a41d02..3e279f58e9 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -131,8 +131,8 @@ 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 "")) +token :: (P.Stream s Identity t) => (t -> Maybe a) -> P.Parsec s u a +token = P.token (const "") (const (P.initialPos "")) parseValue :: P.Parsec Chain () Expr parseValue = token (either Just (const Nothing)) P. "expression" diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index aa9a1f8d75..3a0ad8287e 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -292,10 +292,10 @@ typeClassMemberName :: Declaration -> String typeClassMemberName (TypeDeclaration ident _) = runIdent ident typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d -typeClassMemberName d = error $ "Invalid declaration in type class definition: " ++ show d +typeClassMemberName d = error "typeClassMemberName: Invalid declaration in type class definition" superClassDictionaryNames :: [Constraint] -> [String] superClassDictionaryNames supers = - [ C.__superclass_ ++ show pn ++ "_" ++ show (index :: Integer) + [ C.__superclass_ ++ showQualified runProperName pn ++ "_" ++ show (index :: Integer) | (index, (pn, _)) <- zip [0..] supers ] diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 00b467ad42..d75814a895 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -122,7 +122,7 @@ entails env moduleName context = solve dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts) dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) = - App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index) + App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index) (dictionaryValueToValue dict)) valUndefined -- Ensure that a substitution is valid diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 33435c2c93..4fdaab1ed6 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -38,7 +38,7 @@ data TypeClassDictionaryInScope , tcdDependencies :: Maybe [Constraint] -- | The type of this dictionary , tcdType :: TypeClassDictionaryType - } deriving (Show, Data, Typeable) + } deriving (Show, Read, Data, Typeable) -- | -- The type of a type class dictionary @@ -51,7 +51,7 @@ data TypeClassDictionaryType -- | -- A type class dictionary which is an alias for an imported dictionary from another module -- - | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable) + | TCDAlias (Qualified Ident) deriving (Show, Read, Eq, Data, Typeable) -- | -- A simplified representation of expressions which are used to represent type @@ -74,7 +74,7 @@ data DictionaryValue -- A subclass dictionary -- | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer - deriving (Show, Ord, Eq) + deriving (Show, Read, Ord, Eq) -- | -- Find the original dictionary which a type class dictionary in scope refers to diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index c9b6ef43a9..c8a23fc34f 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -39,7 +39,7 @@ import Language.PureScript.Traversals -- | -- An identifier for the scope of a skolem variable -- -newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Eq, Ord, Data, Typeable, A.ToJSON, A.FromJSON) +newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Read, Eq, Ord, Data, Typeable, A.ToJSON, A.FromJSON) -- | -- The type of types @@ -105,7 +105,7 @@ data Type -- | -- A placeholder used in pretty printing -- - | PrettyPrintForAll [String] Type deriving (Show, Eq, Ord, Data, Typeable) + | PrettyPrintForAll [String] Type deriving (Show, Read,Eq, Ord, Data, Typeable) -- | -- A typeclass constraint From 2676004f840842157135c7804f9c6f05e43c00ce Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 11 Sep 2015 15:17:10 -0700 Subject: [PATCH 0009/1580] Fix warning --- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 3a0ad8287e..d7438a149c 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -292,7 +292,7 @@ typeClassMemberName :: Declaration -> String typeClassMemberName (TypeDeclaration ident _) = runIdent ident typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d -typeClassMemberName d = error "typeClassMemberName: Invalid declaration in type class definition" +typeClassMemberName _ = error "typeClassMemberName: Invalid declaration in type class definition" superClassDictionaryNames :: [Constraint] -> [String] superClassDictionaryNames supers = From 866651305b1559fd98a9b733d2d4d69e8ddd754d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 12 Sep 2015 11:46:02 -0700 Subject: [PATCH 0010/1580] Fix #1310 --- examples/failing/1310.purs | 18 ++++++++++++++++++ src/Language/PureScript/TypeChecker/Unify.hs | 5 +++-- 2 files changed, 21 insertions(+), 2 deletions(-) create mode 100644 examples/failing/1310.purs diff --git a/examples/failing/1310.purs b/examples/failing/1310.purs new file mode 100644 index 0000000000..5bc04429a8 --- /dev/null +++ b/examples/failing/1310.purs @@ -0,0 +1,18 @@ +-- @shouldFailWith NoInstanceFound + +module Issue1310 where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console + +class Inject f g where + inj :: forall a. f a -> g a + +instance inject :: Inject f f where + inj x = x + +foreign import data Oops :: ! + +main :: forall eff. Eff (oops :: Oops | eff) Unit +main = inj (log "Oops") diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index e803dbfe3a..28e7431a64 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -169,8 +169,9 @@ unifiesWith e r1@(RCons _ _ _) r2@(RCons _ _ _) = go [] REmpty [] REmpty = True go [] (TypeVar v1) [] (TypeVar v2) = v1 == v2 go [] (Skolem _ s1 _) [] (Skolem _ s2 _) = s1 == s2 - go _ (TUnknown _) _ _ = True - go _ _ _ (TUnknown _) = True + go [] (TUnknown _) _ _ = True + go _ _ [] (TUnknown _) = True + go _ (TUnknown _) _ (TUnknown _) = True go _ _ _ _ = False unifiesWith _ _ _ = False From 0888adac0a000cc03b62a950f70cb1a1b53f1156 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 13 Sep 2015 13:18:32 +0100 Subject: [PATCH 0011/1580] Warn on shadowed type var within a single type --- src/Language/PureScript/Errors.hs | 6 +++++- src/Language/PureScript/Linter.hs | 32 +++++++++++++++++++++++-------- src/Language/PureScript/Types.hs | 15 +++++++++++++++ 3 files changed, 44 insertions(+), 9 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8169125072..fa94dd2b68 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -140,6 +140,7 @@ data SimpleErrorMessage | InvalidInstanceHead Type | TransitiveExportError DeclarationRef [DeclarationRef] | ShadowedName Ident + | ShadowedTypeVar String | WildcardInferredType Type | NotExhaustivePattern [[Binder]] Bool | OverlappingPattern [[Binder]] Bool @@ -266,6 +267,7 @@ errorCode em = case unwrapErrorMessage em of InvalidInstanceHead{} -> "InvalidInstanceHead" TransitiveExportError{} -> "TransitiveExportError" ShadowedName{} -> "ShadowedName" + ShadowedTypeVar{} -> "ShadowedTypeVar" WildcardInferredType{} -> "WildcardInferredType" NotExhaustivePattern{} -> "NotExhaustivePattern" OverlappingPattern{} -> "OverlappingPattern" @@ -628,7 +630,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ") : map (line . prettyPrintExport) ys goSimple (ShadowedName nm) = - line $ "Name '" ++ showIdent nm ++ "' was shadowed." + line $ "Name '" ++ showIdent nm ++ "' was shadowed" + goSimple (ShadowedTypeVar tv) = + line $ "Type variable '" ++ tv ++ "' was shadowed" goSimple (ClassOperator className opName) = paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "." , indent $ line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:" diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 9d1f6dc2c1..8e1e01a25a 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -33,6 +33,7 @@ import Control.Monad.Writer.Class import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Errors +import Language.PureScript.Types import Language.PureScript.Linter.Exhaustive as L -- | Lint the PureScript AST. @@ -59,7 +60,7 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ f' :: Declaration -> MultipleErrors f' (PositionedDeclaration pos _ dec) = onErrorMessages (PositionedError pos) (f' dec) - f' dec = f dec + f' dec = f dec <> checkShadowedTypeVars dec in tell (f' d) where @@ -75,17 +76,32 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ stepD s _ = (s, mempty) stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors) - stepE s (Abs (Left name) _) = bind s name + stepE s (Abs (Left name) _) = bindName s name stepE s (Let ds' _) = - case mapAccumL bind s (nub (mapMaybe getDeclIdent ds')) of + case mapAccumL bindName s (nub (mapMaybe getDeclIdent ds')) of (s', es) -> (s', mconcat es) stepE s _ = (s, mempty) stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors) - stepB s (VarBinder name) = bind s name - stepB s (NamedBinder name _) = bind s name + stepB s (VarBinder name) = bindName s name + stepB s (NamedBinder name _) = bindName s name stepB s _ = (s, mempty) - bind :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors) - bind s name | name `S.member` s = (s, errorMessage (ShadowedName name)) - | otherwise = (S.insert name s, mempty) + bindName :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors) + bindName = bind ShadowedName + + checkShadowedTypeVars :: Declaration -> MultipleErrors + checkShadowedTypeVars d = + let (f, _, _, _, _) = accumTypes go in f d + where + go :: Type -> MultipleErrors + go = everythingWithContextOnTypes S.empty mempty mappend step + step :: S.Set String -> Type -> (S.Set String, MultipleErrors) + step s (ForAll tv _ _) = bindVar s tv + step s _ = (s, mempty) + bindVar :: S.Set String -> String -> (S.Set String, MultipleErrors) + bindVar = bind ShadowedTypeVar + + bind :: (Ord a) => (a -> SimpleErrorMessage) -> S.Set a -> a -> (S.Set a, MultipleErrors) + bind mkError s name | name `S.member` s = (s, errorMessage (mkError name)) + | otherwise = (S.insert name s, mempty) diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index c8a23fc34f..4d35699e52 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -312,3 +312,18 @@ everythingOnTypes (<>) f = go go t@(PrettyPrintObject t1) = f t <> go t1 go t@(PrettyPrintForAll _ t1) = f t <> go t1 go other = f other + +everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type -> (s, r)) -> Type -> r +everythingWithContextOnTypes s0 r0 (<>) f = go' s0 + where + go' s t = let (s', r) = f s t in r <> go s' t + go s (TypeApp t1 t2) = go' s t1 <> go' s t2 + go s (SaturatedTypeSynonym _ tys) = foldl (<>) r0 (map (go' s) tys) + go s (ForAll _ ty _) = go' s ty + go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap snd cs) <> go' s ty + go s (RCons _ ty rest) = go' s ty <> go' s rest + go s (KindedType ty _) = go' s ty + go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2 + go s (PrettyPrintObject t1) = go' s t1 + go s (PrettyPrintForAll _ t1) = go' s t1 + go _ _ = r0 From 3ba23c75226e06b5ed62e967ab03df73621eb79c Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 13 Sep 2015 13:32:19 +0100 Subject: [PATCH 0012/1580] Warn on unused type variable --- src/Language/PureScript/Errors.hs | 4 ++++ src/Language/PureScript/Linter.hs | 24 +++++++++++++++++------- 2 files changed, 21 insertions(+), 7 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index fa94dd2b68..9d3f0dcbcd 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -141,6 +141,7 @@ data SimpleErrorMessage | TransitiveExportError DeclarationRef [DeclarationRef] | ShadowedName Ident | ShadowedTypeVar String + | UnusedTypeVar String | WildcardInferredType Type | NotExhaustivePattern [[Binder]] Bool | OverlappingPattern [[Binder]] Bool @@ -268,6 +269,7 @@ errorCode em = case unwrapErrorMessage em of TransitiveExportError{} -> "TransitiveExportError" ShadowedName{} -> "ShadowedName" ShadowedTypeVar{} -> "ShadowedTypeVar" + UnusedTypeVar{} -> "UnusedTypeVar" WildcardInferredType{} -> "WildcardInferredType" NotExhaustivePattern{} -> "NotExhaustivePattern" OverlappingPattern{} -> "OverlappingPattern" @@ -633,6 +635,8 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError line $ "Name '" ++ showIdent nm ++ "' was shadowed" goSimple (ShadowedTypeVar tv) = line $ "Type variable '" ++ tv ++ "' was shadowed" + goSimple (UnusedTypeVar tv) = + line $ "Type variable '" ++ tv ++ "' was declared but not used" goSimple (ClassOperator className opName) = paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "." , indent $ line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:" diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 8e1e01a25a..770ee21731 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -19,7 +19,7 @@ module Language.PureScript.Linter (lint, module L) where -import Data.List (mapAccumL, nub) +import Data.List (mapAccumL, nub, (\\)) import Data.Maybe (mapMaybe) import Data.Monoid @@ -60,7 +60,7 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ f' :: Declaration -> MultipleErrors f' (PositionedDeclaration pos _ dec) = onErrorMessages (PositionedError pos) (f' dec) - f' dec = f dec <> checkShadowedTypeVars dec + f' dec = f dec <> checkTypeVars dec in tell (f' d) where @@ -90,17 +90,27 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ bindName :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors) bindName = bind ShadowedName - checkShadowedTypeVars :: Declaration -> MultipleErrors - checkShadowedTypeVars d = - let (f, _, _, _, _) = accumTypes go in f d + checkTypeVars :: Declaration -> MultipleErrors + checkTypeVars d = + let (checkShadow, _, _, _, _) = accumTypes (everythingWithContextOnTypes S.empty mempty mappend step) + (checkUnused, _, _, _, _) = accumTypes findUnused + in checkShadow d <> checkUnused d where - go :: Type -> MultipleErrors - go = everythingWithContextOnTypes S.empty mempty mappend step step :: S.Set String -> Type -> (S.Set String, MultipleErrors) step s (ForAll tv _ _) = bindVar s tv step s _ = (s, mempty) bindVar :: S.Set String -> String -> (S.Set String, MultipleErrors) bindVar = bind ShadowedTypeVar + findUnused :: Type -> MultipleErrors + findUnused ty = + let used = usedTypeVariables ty + declared = everythingOnTypes (++) go ty + unused = nub declared \\ nub used + in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused + where + go :: Type -> [String] + go (ForAll tv _ _) = [tv] + go _ = [] bind :: (Ord a) => (a -> SimpleErrorMessage) -> S.Set a -> a -> (S.Set a, MultipleErrors) bind mkError s name | name `S.member` s = (s, errorMessage (mkError name)) From ab73d58e7e1596733468c3ee5e3dec004022a39c Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 13 Sep 2015 14:18:38 +0100 Subject: [PATCH 0013/1580] Improve context info for lint warnings --- src/Language/PureScript/Errors.hs | 8 ++++++++ src/Language/PureScript/Linter.hs | 20 +++++++++++--------- 2 files changed, 19 insertions(+), 9 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 9d3f0dcbcd..946801a042 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -170,6 +170,7 @@ data ErrorMessage | ErrorInDataBindingGroup ErrorMessage | ErrorInTypeSynonym ProperName ErrorMessage | ErrorInValueDeclaration Ident ErrorMessage + | ErrorInTypeDeclaration Ident ErrorMessage | ErrorInForeignImport Ident ErrorMessage | PositionedError SourceSpan ErrorMessage | SimpleErrorWrapper SimpleErrorMessage @@ -340,6 +341,7 @@ unwrapErrorMessage em = case em of (ErrorInTypeConstructor _ err) -> unwrapErrorMessage err (ErrorInTypeSynonym _ err) -> unwrapErrorMessage err (ErrorInValueDeclaration _ err) -> unwrapErrorMessage err + (ErrorInTypeDeclaration _ err) -> unwrapErrorMessage err (ErrorInferringType _ err) -> unwrapErrorMessage err (ErrorUnifyingTypes _ _ err) -> unwrapErrorMessage err (NotYetDefined _ err) -> unwrapErrorMessage err @@ -386,6 +388,7 @@ onTypesInErrorMessageM f = g g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> (g e) g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> (g e) g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> (g e) + g (ErrorInTypeDeclaration x e) = ErrorInTypeDeclaration x <$> (g e) g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> (g e) g (PositionedError x e) = PositionedError x <$> (g e) g (SimpleErrorWrapper sem) = SimpleErrorWrapper <$> gSimple sem @@ -740,6 +743,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError paras [ lineWithLevel $ "in value declaration " ++ showIdent n ++ ":" , go err ] + go (ErrorInTypeDeclaration n err) = + paras [ lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":" + , go err + ] go (ErrorInForeignImport nm err) = paras [ lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":" , go err @@ -805,6 +812,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err) unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err) unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err) + unwrap pos (ErrorInTypeDeclaration nm err) = ErrorInTypeDeclaration nm (unwrap pos err) unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err) unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err) unwrap _ (PositionedError pos err) = unwrap (Just pos) err diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 770ee21731..e8a2e270c8 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -60,7 +60,9 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ f' :: Declaration -> MultipleErrors f' (PositionedDeclaration pos _ dec) = onErrorMessages (PositionedError pos) (f' dec) - f' dec = f dec <> checkTypeVars dec + f' dec@(ValueDeclaration name _ _ _) = onErrorMessages (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec) + f' (TypeDeclaration name ty) = onErrorMessages (ErrorInTypeDeclaration name) (checkTypeVars ty) + f' dec = f dec <> checkTypeVarsInDecl dec in tell (f' d) where @@ -90,11 +92,11 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ bindName :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors) bindName = bind ShadowedName - checkTypeVars :: Declaration -> MultipleErrors - checkTypeVars d = - let (checkShadow, _, _, _, _) = accumTypes (everythingWithContextOnTypes S.empty mempty mappend step) - (checkUnused, _, _, _, _) = accumTypes findUnused - in checkShadow d <> checkUnused d + checkTypeVarsInDecl :: Declaration -> MultipleErrors + checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d + + checkTypeVars :: Type -> MultipleErrors + checkTypeVars ty = everythingWithContextOnTypes S.empty mempty mappend step ty <> findUnused ty where step :: S.Set String -> Type -> (S.Set String, MultipleErrors) step s (ForAll tv _ _) = bindVar s tv @@ -102,9 +104,9 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ bindVar :: S.Set String -> String -> (S.Set String, MultipleErrors) bindVar = bind ShadowedTypeVar findUnused :: Type -> MultipleErrors - findUnused ty = - let used = usedTypeVariables ty - declared = everythingOnTypes (++) go ty + findUnused ty' = + let used = usedTypeVariables ty' + declared = everythingOnTypes (++) go ty' unused = nub declared \\ nub used in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused where From 67d3473ae71aac1d361725b057df55f2437471e7 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 13 Sep 2015 16:22:49 -0700 Subject: [PATCH 0014/1580] Fix #922 --- src/Language/PureScript/TypeChecker/Types.hs | 23 ++++++++++++-------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index ae8ec5cf09..653d5075f2 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -282,10 +282,12 @@ infer' v@(Constructor c) = do Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty return $ TypedValue True v' ty' infer' (Case vals binders) = do - ts <- mapM infer vals + (vals', ts) <- fmap unzip $ forM vals $ \val -> do + TypedValue _ val' ty <- infer val + instantiatePolyTypeWithUnknowns val' ty ret <- fresh - binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders - return $ TypedValue True (Case ts binders') ret + binders' <- checkBinders ts ret binders + return $ TypedValue True (Case vals' binders') ret infer' (IfThenElse cond th el) = do cond' <- check cond tyBoolean v2@(TypedValue _ _ t2) <- infer th @@ -376,7 +378,7 @@ inferBinder val (ConstructorBinder ctor binders) = do go [] ty' = case (val, ty') of (TypeConstructor _, TypeApp _ _) -> throwIncorrectArity _ -> do - _ <- subsumes Nothing val ty' + _ <- val =?= ty' return M.empty go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction = M.union <$> inferBinder obj binder <*> go binders' ret @@ -537,8 +539,9 @@ check' (TypedValue checkType val ty1) ty2 = do val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val return $ TypedValue checkType val''' ty2' check' (Case vals binders) ret = do - vals' <- mapM infer vals - let ts = map (\(TypedValue _ _ t) -> t) vals' + (vals', ts) <- fmap unzip $ forM vals $ \val -> do + TypedValue _ val' ty <- infer val + instantiatePolyTypeWithUnknowns val' ty binders' <- checkBinders ts ret binders return $ TypedValue True (Case vals' binders') ret check' (IfThenElse cond th el) ty = do @@ -567,14 +570,16 @@ check' (Accessor prop val) ty = do rest <- fresh val' <- check val (TypeApp tyObject (RCons prop ty rest)) return $ TypedValue True (Accessor prop val') ty -check' (Constructor c) ty = do +check' v@(Constructor c) ty = do env <- getEnv case M.lookup c (dataConstructors env) of Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing Just (_, _, ty1, _) -> do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 - _ <- subsumes Nothing repl ty - return $ TypedValue True (Constructor c) ty + mv <- subsumes (Just v) repl ty + case mv of + Nothing -> throwError . errorMessage $ SubsumptionCheckFailed + Just v' -> return $ TypedValue True v' ty check' (Let ds val) ty = do (ds', val') <- inferLetBinding [] ds val (`check` ty) return $ TypedValue True (Let ds' val') ty From 92f17753d84dc2235aa1a5b37ef7711e0c08f482 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 13 Sep 2015 16:43:30 -0700 Subject: [PATCH 0015/1580] Fix #862 --- examples/passing/862.purs | 8 ++++++++ src/Language/PureScript/TypeChecker/Types.hs | 7 ++++++- 2 files changed, 14 insertions(+), 1 deletion(-) create mode 100644 examples/passing/862.purs diff --git a/examples/passing/862.purs b/examples/passing/862.purs new file mode 100644 index 0000000000..97c664d5cb --- /dev/null +++ b/examples/passing/862.purs @@ -0,0 +1,8 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console + +id' = (\x -> x) <$> \y -> y + +main = log (id' "Done") diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index ae8ec5cf09..0785625bce 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -587,7 +587,12 @@ check' val kt@(KindedType ty kind) = do return $ TypedValue True val' kt check' (PositionedValue pos _ val) ty = warnAndRethrowWithPosition pos $ check' val ty -check' val ty = throwError . errorMessage $ ExprDoesNotHaveType val ty +check' val ty = do + TypedValue _ val' ty' <- infer val + mt <- subsumes (Just val') ty' ty + case mt of + Nothing -> throwError . errorMessage $ SubsumptionCheckFailed + Just v' -> return $ TypedValue True v' ty containsTypeSynonyms :: Type -> Bool containsTypeSynonyms = everythingOnTypes (||) go where From b5a1b021496805e1ec351007141cf817d181d763 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 13 Sep 2015 16:54:33 -0700 Subject: [PATCH 0016/1580] Fix some expected error messages in tests --- examples/failing/Arrays.purs | 2 +- examples/failing/MultipleErrors.purs | 4 ++-- examples/failing/Rank2Types.purs | 2 +- examples/failing/TypeError.purs | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/examples/failing/Arrays.purs b/examples/failing/Arrays.purs index 6c7d763cb3..479b351234 100644 --- a/examples/failing/Arrays.purs +++ b/examples/failing/Arrays.purs @@ -1,4 +1,4 @@ --- @shouldFailWith ExprDoesNotHaveType +-- @shouldFailWith TypesDoNotUnify module Main where import Prelude diff --git a/examples/failing/MultipleErrors.purs b/examples/failing/MultipleErrors.purs index ecc9b1e8ae..b1d8a8cacd 100644 --- a/examples/failing/MultipleErrors.purs +++ b/examples/failing/MultipleErrors.purs @@ -1,5 +1,5 @@ --- @shouldFailWith ExprDoesNotHaveType --- @shouldFailWith ExprDoesNotHaveType +-- @shouldFailWith TypesDoNotUnify +-- @shouldFailWith TypesDoNotUnify module MultipleErrors where import Prelude diff --git a/examples/failing/Rank2Types.purs b/examples/failing/Rank2Types.purs index 5cb50eff08..68438fde6b 100644 --- a/examples/failing/Rank2Types.purs +++ b/examples/failing/Rank2Types.purs @@ -1,4 +1,4 @@ --- @shouldFailWith ExprDoesNotHaveType +-- @shouldFailWith TypesDoNotUnify module Main where import Prelude diff --git a/examples/failing/TypeError.purs b/examples/failing/TypeError.purs index ad26361f80..8e028b3772 100644 --- a/examples/failing/TypeError.purs +++ b/examples/failing/TypeError.purs @@ -1,4 +1,4 @@ --- @shouldFailWith ExprDoesNotHaveType +-- @shouldFailWith TypesDoNotUnify module Main where import Prelude From 6e15cb0c27084eb854e51eb22075d8c234cdc26e Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 14 Sep 2015 07:41:56 +0300 Subject: [PATCH 0017/1580] Bump semigroups upper bound to <0.18 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 3dd3a2bbcd..5a2097d218 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -57,7 +57,7 @@ library Glob >= 0.7 && < 0.8, process >= 1.2.0 && < 1.3, safe >= 0.3.9 && < 0.4, - semigroups >= 0.16.2 && < 0.17 + semigroups >= 0.16.2 && < 0.18 exposed-modules: Language.PureScript Language.PureScript.AST From 268acb561c7c422d02bfd2fe8ef39436935966dd Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 14 Sep 2015 10:46:06 -0700 Subject: [PATCH 0018/1580] Restrict the number of binders when checking exhaustivity, fix #1469, fix #1288. --- src/Language/PureScript/Linter/Exhaustive.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index b6ed4639a8..8f798ed5ab 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -223,6 +223,8 @@ missingAlternative env mn ca uncovered where mcases = missingCases env mn uncovered ca + + -- | -- Main exhaustivity checking function -- Starting with the set `uncovered = { _ }` (nothing covered, one `_` for each function argument), @@ -235,9 +237,10 @@ checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([init step :: ([[Binder]], (Maybe Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Maybe Bool, [[Binder]])) step (uncovered, (nec, redundant)) ca = let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered) - cond = or <$> sequenceA pr - in (concat missed, (liftA2 (&&) cond nec, - if fromMaybe True cond then redundant else caseAlternativeBinders ca : redundant)) + (missed', approx) = splitAt 10000 (concat missed) + cond = liftA2 (&&) (or <$> sequenceA pr) nec + in (missed', (if null approx then cond else Nothing, + if fromMaybe True cond then redundant else caseAlternativeBinders ca : redundant)) #if __GLASGOW_HASKELL__ < 710 where sequenceA = foldr (liftA2 (:)) (pure []) From 4637a088d9a6cdff719c9169681fb07b77d02220 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sat, 19 Sep 2015 13:12:34 +0300 Subject: [PATCH 0019/1580] Bump aeson upper bound to <0.11 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 5a2097d218..faf7ee4d59 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -45,7 +45,7 @@ library pattern-arrows >= 0.0.2 && < 0.1, time -any, boxes >= 0.1.4 && < 0.2.0, - aeson >= 0.8 && < 0.10, + aeson >= 0.8 && < 0.11, vector -any, bower-json >= 0.7, aeson-better-errors >= 0.8, From d9728d02ab9e81e9662b3083ce2127170239aeec Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 21 Sep 2015 16:44:53 -0700 Subject: [PATCH 0020/1580] Revert "Fix #922" --- src/Language/PureScript/TypeChecker/Types.hs | 23 ++++++++------------ 1 file changed, 9 insertions(+), 14 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index d0fb5bb774..0785625bce 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -282,12 +282,10 @@ infer' v@(Constructor c) = do Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty return $ TypedValue True v' ty' infer' (Case vals binders) = do - (vals', ts) <- fmap unzip $ forM vals $ \val -> do - TypedValue _ val' ty <- infer val - instantiatePolyTypeWithUnknowns val' ty + ts <- mapM infer vals ret <- fresh - binders' <- checkBinders ts ret binders - return $ TypedValue True (Case vals' binders') ret + binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders + return $ TypedValue True (Case ts binders') ret infer' (IfThenElse cond th el) = do cond' <- check cond tyBoolean v2@(TypedValue _ _ t2) <- infer th @@ -378,7 +376,7 @@ inferBinder val (ConstructorBinder ctor binders) = do go [] ty' = case (val, ty') of (TypeConstructor _, TypeApp _ _) -> throwIncorrectArity _ -> do - _ <- val =?= ty' + _ <- subsumes Nothing val ty' return M.empty go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction = M.union <$> inferBinder obj binder <*> go binders' ret @@ -539,9 +537,8 @@ check' (TypedValue checkType val ty1) ty2 = do val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val return $ TypedValue checkType val''' ty2' check' (Case vals binders) ret = do - (vals', ts) <- fmap unzip $ forM vals $ \val -> do - TypedValue _ val' ty <- infer val - instantiatePolyTypeWithUnknowns val' ty + vals' <- mapM infer vals + let ts = map (\(TypedValue _ _ t) -> t) vals' binders' <- checkBinders ts ret binders return $ TypedValue True (Case vals' binders') ret check' (IfThenElse cond th el) ty = do @@ -570,16 +567,14 @@ check' (Accessor prop val) ty = do rest <- fresh val' <- check val (TypeApp tyObject (RCons prop ty rest)) return $ TypedValue True (Accessor prop val') ty -check' v@(Constructor c) ty = do +check' (Constructor c) ty = do env <- getEnv case M.lookup c (dataConstructors env) of Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing Just (_, _, ty1, _) -> do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 - mv <- subsumes (Just v) repl ty - case mv of - Nothing -> throwError . errorMessage $ SubsumptionCheckFailed - Just v' -> return $ TypedValue True v' ty + _ <- subsumes Nothing repl ty + return $ TypedValue True (Constructor c) ty check' (Let ds val) ty = do (ds', val') <- inferLetBinding [] ds val (`check` ty) return $ TypedValue True (Let ds' val') ty From 72ce9000b184fa660010deba20ee872bc71eab53 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 11 Sep 2015 18:04:17 -0700 Subject: [PATCH 0021/1580] WIP: new externs file format --- psci/Parser.hs | 1 - purescript.cabal | 2 +- src/Language/PureScript/AST/Declarations.hs | 18 +- src/Language/PureScript/AST/Operators.hs | 9 + src/Language/PureScript/AST/SourcePos.hs | 14 +- src/Language/PureScript/AST/Traversals.hs | 1 - src/Language/PureScript/CodeGen.hs | 5 - src/Language/PureScript/CodeGen/Externs.hs | 144 ---------------- src/Language/PureScript/Comments.hs | 4 + src/Language/PureScript/CoreFn/Desugar.hs | 1 - .../PureScript/Docs/ParseAndDesugar.hs | 2 +- src/Language/PureScript/Environment.hs | 8 +- src/Language/PureScript/Externs.hs | 163 ++++++++++++++++++ src/Language/PureScript/Linter.hs | 1 - src/Language/PureScript/Make.hs | 82 ++++----- src/Language/PureScript/Names.hs | 9 +- .../PureScript/Parser/Declarations.hs | 10 -- src/Language/PureScript/Sugar.hs | 26 +-- .../PureScript/Sugar/BindingGroups.hs | 1 - src/Language/PureScript/Sugar/Names.hs | 48 +++++- src/Language/PureScript/Sugar/Names/Env.hs | 18 +- .../PureScript/Sugar/Names/Imports.hs | 37 ++-- src/Language/PureScript/Sugar/Operators.hs | 14 +- src/Language/PureScript/Sugar/TypeClasses.hs | 20 ++- src/Language/PureScript/TypeChecker.hs | 12 +- .../PureScript/TypeChecker/Entailment.hs | 17 +- src/Language/PureScript/TypeChecker/Monad.hs | 3 +- src/Language/PureScript/TypeChecker/Types.hs | 2 +- .../PureScript/TypeClassDictionaries.hs | 22 --- 29 files changed, 378 insertions(+), 316 deletions(-) delete mode 100644 src/Language/PureScript/CodeGen/Externs.hs create mode 100644 src/Language/PureScript/Externs.hs diff --git a/psci/Parser.hs b/psci/Parser.hs index e506c4a864..d4a3a2d50c 100644 --- a/psci/Parser.hs +++ b/psci/Parser.hs @@ -131,7 +131,6 @@ acceptable P.DataDeclaration{} = True acceptable P.TypeSynonymDeclaration{} = True acceptable P.ExternDeclaration{} = True acceptable P.ExternDataDeclaration{} = True -acceptable P.ExternInstanceDeclaration{} = True acceptable P.TypeClassDeclaration{} = True acceptable P.TypeInstanceDeclaration{} = True acceptable _ = False diff --git a/purescript.cabal b/purescript.cabal index 3dd3a2bbcd..5a4a35a99e 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -68,8 +68,8 @@ library Language.PureScript.AST.Traversals Language.PureScript.AST.Exported Language.PureScript.Bundle + Language.PureScript.Externs Language.PureScript.CodeGen - Language.PureScript.CodeGen.Externs Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.AST Language.PureScript.CodeGen.JS.Common diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 298a7c656f..7c8f915fd1 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -14,10 +14,13 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} module Language.PureScript.AST.Declarations where +import Data.Aeson.TH + import qualified Data.Data as D import qualified Data.Map as M @@ -147,10 +150,6 @@ data Declaration -- | ExternDataDeclaration ProperName Kind -- | - -- A type class instance foreign import - -- - | ExternInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] - -- | -- A fixity declaration (fixity data, operator name) -- | FixityDeclaration Fixity String @@ -222,14 +221,6 @@ isExternDataDecl ExternDataDeclaration{} = True isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d isExternDataDecl _ = False --- | --- Test if a declaration is a type class instance foreign import --- -isExternInstanceDecl :: Declaration -> Bool -isExternInstanceDecl ExternInstanceDeclaration{} = True -isExternInstanceDecl (PositionedDeclaration _ _ d) = isExternInstanceDecl d -isExternInstanceDecl _ = False - -- | -- Test if a declaration is a fixity declaration -- @@ -442,3 +433,6 @@ data DoNotationElement -- A do notation element with source position information -- | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, Read, D.Data, D.Typeable) + +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType) diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs index 00e2b911d7..291490f8bf 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -36,9 +36,18 @@ showAssoc Infixl = "infixl" showAssoc Infixr = "infixr" showAssoc Infix = "infix" +readAssoc :: String -> Associativity +readAssoc "infixl" = Infixl +readAssoc "infixr" = Infixr +readAssoc "infix" = Infix +readAssoc _ = error "readAssoc: no parse" + instance A.ToJSON Associativity where toJSON = A.toJSON . showAssoc +instance A.FromJSON Associativity where + parseJSON = fmap readAssoc . A.parseJSON + -- | -- Fixity data for infix operators -- diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 5154a089c1..1b0ea5b8b8 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -20,7 +20,7 @@ module Language.PureScript.AST.SourcePos where import qualified Data.Data as D -import Data.Aeson ((.=)) +import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A -- | @@ -46,6 +46,11 @@ instance A.ToJSON SourcePos where toJSON SourcePos{..} = A.toJSON [sourcePosLine, sourcePosColumn] +instance A.FromJSON SourcePos where + parseJSON arr = do + [line, col] <- A.parseJSON arr + return $ SourcePos line col + data SourceSpan = SourceSpan { -- | -- Source name @@ -77,5 +82,12 @@ instance A.ToJSON SourceSpan where , "end" .= spanEnd ] +instance A.FromJSON SourceSpan where + parseJSON = A.withObject "SourceSpan" $ \o -> + SourceSpan <$> + o .: "name" <*> + o .: "start" <*> + o .: "end" + internalModuleSourceSpan :: String -> SourceSpan internalModuleSourceSpan name = SourceSpan name (SourcePos 0 0) (SourcePos 0 0) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index c31c59bd05..b05867b70e 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -397,7 +397,6 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con where forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors) forDecls (ExternDeclaration _ ty) = f ty - forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys) forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies) forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys) forDecls (TypeSynonymDeclaration _ _ ty) = f ty diff --git a/src/Language/PureScript/CodeGen.hs b/src/Language/PureScript/CodeGen.hs index fb16fb57fc..ee305ff870 100644 --- a/src/Language/PureScript/CodeGen.hs +++ b/src/Language/PureScript/CodeGen.hs @@ -13,13 +13,8 @@ -- -- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript -- --- [@Language.PureScript.CodeGen.Externs@] Code generator for extern (foreign import) files --- --- [@Language.PureScript.CodeGen.Optimize@] Optimization passes for generated Javascript --- ----------------------------------------------------------------------------- module Language.PureScript.CodeGen (module C) where import Language.PureScript.CodeGen.JS as C -import Language.PureScript.CodeGen.Externs as C diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs deleted file mode 100644 index c07df8df70..0000000000 --- a/src/Language/PureScript/CodeGen/Externs.hs +++ /dev/null @@ -1,144 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen.Externs --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations. --- ------------------------------------------------------------------------------ - -module Language.PureScript.CodeGen.Externs ( - moduleToPs -) where - -import Data.List (intercalate, find) -import Data.Maybe (fromMaybe, mapMaybe) -import qualified Data.Map as M - -import Control.Monad.Writer - -import Language.PureScript.AST -import Language.PureScript.Comments -import Language.PureScript.Environment -import Language.PureScript.Kinds -import Language.PureScript.Names -import Language.PureScript.Pretty -import Language.PureScript.TypeClassDictionaries -import Language.PureScript.Types - --- | --- Generate foreign imports for all declarations in a module --- -moduleToPs :: Module -> Environment -> String -moduleToPs (Module _ _ _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs" -moduleToPs (Module _ _ moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do - let exps = listRefs exts - tell ["module " ++ runModuleName moduleName ++ (if null exps then "" else " (" ++ exps ++ ")") ++ " where"] - mapM_ declToPs ds - mapM_ exportToPs exts - where - - listRefs :: [DeclarationRef] -> String - listRefs = intercalate ", " . mapMaybe listRef - - listRef :: DeclarationRef -> Maybe String - listRef (PositionedDeclarationRef _ _ d) = listRef d - listRef (TypeRef name Nothing) = Just $ runProperName name ++ "()" - listRef (TypeRef name (Just dctors)) = Just $ runProperName name ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")" - listRef (ValueRef name) = Just $ showIdent name - listRef (TypeClassRef name) = Just $ runProperName name - listRef (ModuleRef name) = Just $ "module " ++ runModuleName name - listRef _ = Nothing - - declToPs :: Declaration -> Writer [String] () - declToPs (ImportDeclaration mn imp Nothing) = - tell ["import " ++ runModuleName mn ++ importToPs imp] - declToPs (ImportDeclaration mn imp (Just qual)) = - tell ["import qualified " ++ runModuleName mn ++ importToPs imp ++ " as " ++ runModuleName qual] - declToPs (FixityDeclaration (Fixity assoc prec) op) = - case find exportsOp exts of - Nothing -> return () - Just _ -> tell [ unwords [ showAssoc assoc, show prec, op ] ] - where - exportsOp :: DeclarationRef -> Bool - exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r - exportsOp (ValueRef ident') = ident' == Op op - exportsOp _ = False - declToPs (PositionedDeclaration _ com d) = mapM_ commentToPs com >> declToPs d - declToPs _ = return () - - importToPs :: ImportDeclarationType -> String - importToPs Implicit = "" - importToPs (Explicit refs) = " (" ++ listRefs refs ++ ")" - importToPs (Hiding refs) = " hiding (" ++ listRefs refs ++ ")" - - commentToPs :: Comment -> Writer [String] () - commentToPs (LineComment s) = tell ["-- " ++ s] - commentToPs (BlockComment s) = tell ["{- " ++ s ++ " -}"] - - exportToPs :: DeclarationRef -> Writer [String] () - exportToPs (PositionedDeclarationRef _ _ r) = exportToPs r - exportToPs (TypeRef pn dctors) = - case Qualified (Just moduleName) pn `M.lookup` types env of - Nothing -> error $ runProperName pn ++ " has no kind in exportToPs" - Just (kind, ExternData) -> - tell ["foreign import data " ++ runProperName pn ++ " :: " ++ prettyPrintKind kind] - Just (_, DataType args tys) -> do - let dctors' = fromMaybe (map fst tys) dctors - printDctor dctor = case dctor `lookup` tys of - Nothing -> Nothing - Just tyArgs -> Just $ runProperName dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs) - let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors') - then "newtype" - else "data" - typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args) - tell [dtype ++ " " ++ typeName ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))] - Just (_, TypeSynonym) -> - case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of - Nothing -> error $ runProperName pn ++ " has no type synonym info in exportToPs" - Just (args, synTy) -> - let - typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args) - in tell ["type " ++ typeName ++ " = " ++ prettyPrintType synTy] - _ -> error "Invalid input in exportToPs" - - exportToPs (ValueRef ident) = - case (moduleName, ident) `M.lookup` names env of - Nothing -> error $ showIdent ident ++ " has no type in exportToPs" - Just (ty, nk, _) | nk == Public || nk == External -> - tell ["foreign import " ++ showIdent ident ++ " :: " ++ prettyPrintType ty] - _ -> return () - exportToPs (TypeClassRef className) = - case Qualified (Just moduleName) className `M.lookup` typeClasses env of - Nothing -> error $ runProperName className ++ " has no type class definition in exportToPs" - Just (args, members, implies) -> do - let impliesString = if null implies - then "" - else "(" ++ intercalate ", " (map (\(pn, tys') -> showQualified runProperName pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= " - typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing className)) (map toTypeVar args) - tell ["class " ++ impliesString ++ typeName ++ " where"] - forM_ (filter (isValueExported . fst) members) $ \(member ,ty) -> - tell [ " " ++ showIdent member ++ " :: " ++ prettyPrintType ty ] - - exportToPs (TypeInstanceRef ident) = do - let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} = - fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find (\tcd -> tcdName tcd == Qualified (Just moduleName) ident && tcdType tcd == TCDRegular) . maybe [] (M.elems >=> M.elems) . M.lookup (Just moduleName) $ typeClassDictionaries env - let constraintsText = case fromMaybe [] deps of - [] -> "" - cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> showQualified runProperName pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => " - tell ["foreign import instance " ++ showIdent ident ++ " :: " ++ constraintsText ++ showQualified runProperName className ++ " " ++ unwords (map prettyPrintTypeAtom tys)] - - exportToPs (ModuleRef _) = return () - - toTypeVar :: (String, Maybe Kind) -> Type - toTypeVar (s, Nothing) = TypeVar s - toTypeVar (s, Just k) = KindedType (TypeVar s) k - - isValueExported :: Ident -> Bool - isValueExported ident = ValueRef ident `elem` exts diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs index fe73b737b8..351731be27 100644 --- a/src/Language/PureScript/Comments.hs +++ b/src/Language/PureScript/Comments.hs @@ -14,12 +14,16 @@ ----------------------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Comments where +import Data.Aeson.TH import qualified Data.Data as D data Comment = LineComment String | BlockComment String deriving (Show, Read, Eq, Ord, D.Data, D.Typeable) + +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index a963d7bf60..e5ed85747a 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -225,7 +225,6 @@ importToCoreFn _ = Nothing -- externToCoreFn :: A.Declaration -> Maybe ForeignDecl externToCoreFn (A.ExternDeclaration name ty) = Just (name, ty) -externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, tyObject) externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d externToCoreFn _ = Nothing diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndDesugar.hs index 9dcfc7ff5f..b422748cae 100644 --- a/src/Language/PureScript/Docs/ParseAndDesugar.hs +++ b/src/Language/PureScript/Docs/ParseAndDesugar.hs @@ -122,7 +122,7 @@ desugar :: [P.Module] -> Either P.MultipleErrors [P.Module] desugar = P.evalSupplyT 0 . desugar' where desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module] - desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports + desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports [] ignoreWarnings m = liftM fst (runWriterT m) parseFile :: FilePath -> IO (FilePath, String) diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 3e6773d885..006c1fad61 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -14,11 +14,13 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Environment where import Data.Data import Data.Maybe (fromMaybe) +import Data.Aeson.TH import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Aeson as A @@ -42,8 +44,8 @@ data Environment = Environment { -- , types :: M.Map (Qualified ProperName) (Kind, TypeKind) -- | - -- Data constructors currently in scope, along with their associated data type constructors - -- + -- Data constructors currently in scope, along with their associated type + -- constructor name, argument types and return type. , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident]) -- | -- Type synonyms currently in scope @@ -266,3 +268,5 @@ isNewtypeConstructor e ctor = case lookupConstructor e ctor of lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility) lookupValue env (Qualified (Just mn) ident) = (mn, ident) `M.lookup` names env lookupValue _ _ = Nothing + +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs new file mode 100644 index 0000000000..1368da8835 --- /dev/null +++ b/src/Language/PureScript/Externs.hs @@ -0,0 +1,163 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Externs +-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.PureScript.Externs + ( ExternsFile(..) + , ExternsDeclaration(..) + , moduleToExternsFile + , applyExternsFileToEnvironment + ) where + +import Data.List (find, foldl') +import Data.Maybe (mapMaybe, maybeToList, fromMaybe) +import Data.Foldable (fold) +import Data.Version (showVersion) +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid +#endif +import Data.Aeson.TH + +import qualified Data.Map as M + +import Language.PureScript.AST +import Language.PureScript.Environment +import Language.PureScript.Names +import Language.PureScript.Types +import Language.PureScript.Kinds +import Language.PureScript.TypeClassDictionaries + +import Paths_purescript as Paths + +-- | The data which will be serialized to an externs file +data ExternsFile = ExternsFile + { + -- ^ The externs version + efVersion :: String + -- ^ Module name + , efModuleName :: ModuleName + -- ^ List of module exports + , efExports :: [DeclarationRef] + -- ^ List of module imports + , efImports :: [(ModuleName, ImportDeclarationType, Maybe ModuleName)] + -- ^ List of operators and their fixities + , efFixities :: [(Associativity, Precedence, String)] + -- ^ List of type and value declaration + , efDeclarations :: [ExternsDeclaration] + } deriving (Show, Read) + +-- | A type or value declaration appearing in an externs file +data ExternsDeclaration = + -- ^ A type declaration + EDType ProperName Kind TypeKind + -- ^ A type synonym + | EDTypeSynonym ProperName [(String, Maybe Kind)] Type + -- ^ A data construtor + | EDDataConstructor ProperName DataDeclType ProperName Type [Ident] + -- ^ A value declaration + | EDValue Ident Type + -- ^ A type class declaration + | EDClass ProperName [(String, Maybe Kind)] [(Ident, Type)] [Constraint] + -- ^ An instance declaration + | EDInstance (Qualified ProperName) Ident [Type] (Maybe [Constraint]) + deriving (Show, Read) + +-- | Convert an externs file back into a module +applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment +applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclarations + where + applyDecl :: Environment -> ExternsDeclaration -> Environment + applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) } + applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) } + applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } + applyDecl env (EDValue ident ty) = env { names = M.insert (efModuleName, ident) (ty, External, Defined) (names env) } + applyDecl env (EDClass pn args members cs) = env { typeClasses = M.insert (qual pn) (args, members, cs) (typeClasses env) } + applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) } + where + dict :: TypeClassDictionaryInScope + dict = TypeClassDictionaryInScope (qual ident) [] className tys cs + + updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a + updateMap f = M.alter (Just . f . fold) + + qual :: a -> Qualified a + qual = Qualified (Just efModuleName) + +-- | Generate an externs file for all declarations in a module +moduleToExternsFile :: Module -> Environment -> ExternsFile +moduleToExternsFile (Module _ _ _ _ Nothing) _ = error "moduleToExternsFile: module exports were not elaborated" +moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} + where + efVersion = showVersion Paths.version + efModuleName = mn + efExports = exps + efImports = mapMaybe importDecl ds + efFixities = mapMaybe fixityDecl ds + efDeclarations = concatMap toExternsDeclaration efExports + + fixityDecl :: Declaration -> Maybe (Associativity, Precedence, String) + fixityDecl (FixityDeclaration (Fixity assoc prec) op) = fmap (const (assoc, prec, op)) (find exportsOp exps) + where + exportsOp :: DeclarationRef -> Bool + exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r + exportsOp (ValueRef ident') = ident' == Op op + exportsOp _ = False + fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d + fixityDecl _ = Nothing + + importDecl :: Declaration -> Maybe (ModuleName, ImportDeclarationType, Maybe ModuleName) + importDecl (ImportDeclaration m mt qmn) = Just (m, mt, qmn) + importDecl (PositionedDeclaration _ _ d) = importDecl d + importDecl _ = Nothing + + toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration] + toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r + toExternsDeclaration (TypeRef pn dctors) = + case Qualified (Just mn) pn `M.lookup` types env of + Nothing -> error "toExternsDeclaration: no kind in toExternsDeclaration" + Just (kind, TypeSynonym) + | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ] + Just (kind, ExternData) -> [ EDType pn kind ExternData ] + Just (kind, tk@(DataType _ tys)) -> + EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args + | dctor <- fromMaybe (map fst tys) dctors + , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env)) + ] + _ -> error "toExternsDeclaration: Invalid input" + toExternsDeclaration (ValueRef ident) + | Just (ty, _, _) <- (mn, ident) `M.lookup` names env + = [ EDValue ident ty ] + toExternsDeclaration (TypeClassRef className) + | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env + , Just (kind, TypeSynonym) <- M.lookup (Qualified (Just mn) className) (types env) + , Just (_, synTy) <- Qualified (Just mn) className `M.lookup` typeSynonyms env + = [ EDType className kind TypeSynonym + , EDTypeSynonym className args synTy + , EDClass className args members implies + ] + toExternsDeclaration (TypeInstanceRef ident) + = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies + | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env)) + , m2 <- M.elems m1 + , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2) + ] + toExternsDeclaration _ = [] + +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile) diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 9d1f6dc2c1..8cce726795 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -48,7 +48,6 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d getDeclIdent (ValueDeclaration ident _ _ _) = Just ident getDeclIdent (ExternDeclaration ident _) = Just ident - getDeclIdent (ExternInstanceDeclaration ident _ _ _) = Just ident getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident getDeclIdent (BindingGroupDeclaration _) = error "lint: binding groups should not be desugared yet." getDeclIdent _ = Nothing diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index a9f67e6c3e..99d28fc913 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -48,14 +48,18 @@ import Control.Monad.Writer.Strict import Control.Monad.Supply import Data.Function (on) -import Data.List (sortBy, groupBy) +import Data.Either (partitionEithers) +import Data.List (sortBy, groupBy, foldl') import Data.Maybe (fromMaybe) import Data.Time.Clock +import Data.String (fromString) import Data.Foldable (for_) #if __GLASGOW_HASKELL__ < 710 import Data.Traversable (traverse) #endif import Data.Version (showVersion) +import Data.Aeson (encode, decode) +import qualified Data.ByteString.Lazy as B import qualified Data.Map as M import qualified Data.Set as S @@ -65,14 +69,13 @@ import System.FilePath ((), takeDirectory) import System.IO.Error (tryIOError) import Language.PureScript.AST -import Language.PureScript.CodeGen.Externs (moduleToPs) +import Language.PureScript.Externs import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Linter import Language.PureScript.ModuleDependencies import Language.PureScript.Names import Language.PureScript.Options -import Language.PureScript.Parser import Language.PureScript.Pretty import Language.PureScript.Renamer import Language.PureScript.Sugar @@ -116,7 +119,7 @@ data MakeActions m = MakeActions { -- | -- Read the externs file for a module as a string and also return the actual -- path for the file. - , readExterns :: ModuleName -> m (FilePath, String) + , readExterns :: ModuleName -> m (FilePath, B.ByteString) -- | -- Run the code generator for the module and write any required output files. -- @@ -130,7 +133,7 @@ data MakeActions m = MakeActions { -- | -- Generated code for an externs file. -- -type Externs = String +type Externs = B.ByteString -- | -- Determines when to rebuild a module @@ -161,18 +164,16 @@ make MakeActions{..} ms = do (Left RebuildNever, Just _) -> s _ -> S.insert moduleName' s) S.empty sorted - marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted - for_ marked $ \(willRebuild, m) -> when willRebuild (lint m) - (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked) - evalSupplyT nextVar $ go initEnvironment desugared + (externs, toBuild) <- partitionEithers <$> rebuildIfNecessary (reverseDependencies graph) toRebuild sorted + for_ toBuild lint + (desugared, nextVar) <- runSupplyT 0 $ desugar externs toBuild + let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs + evalSupplyT nextVar $ go env desugared where - go :: Environment -> [(Bool, Module)] -> SupplyT m Environment + go :: Environment -> [Module] -> SupplyT m Environment go env [] = return env - go env ((False, m) : ms') = do - (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m - go env' ms' - go env ((True, m@(Module ss coms moduleName' _ exps)) : ms') = do + go env (m@(Module ss coms moduleName' _ exps) : ms') = do lift . progress $ CompilingModule moduleName' (checked@(Module _ _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m checkExhaustiveModule env' checked @@ -180,27 +181,28 @@ make MakeActions{..} ms = do let mod' = Module ss coms moduleName' regrouped exps corefn = CF.moduleToCoreFn env' mod' [renamed] = renameInModules [corefn] - exts = moduleToPs mod' env' + exts = encode $ moduleToExternsFile mod' env' codegen renamed env' exts go env' ms' - rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)] - rebuildIfNecessary _ _ [] = return [] - rebuildIfNecessary graph toRebuild (m@(Module _ _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do - let deps = fromMaybe [] $ moduleName' `M.lookup` graph - toRebuild' = toRebuild `S.union` S.fromList deps - (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms' - rebuildIfNecessary graph toRebuild (Module _ _ moduleName' _ _ : ms') = do - (path, externs) <- readExterns moduleName' - externsModules <- fmap (map snd) . alterErrors $ parseModulesFromFiles id [(path, externs)] - case externsModules of - [m'@(Module _ _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms' - _ -> throwError . errorMessage . InvalidExternsFile $ path + rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [Either ExternsFile Module] + rebuildIfNecessary graph = rebuildIfNecessary' where - alterErrors = flip catchError $ \(MultipleErrors errs) -> - throwError . MultipleErrors $ flip map errs $ \e -> case e of - SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err) - _ -> e + rebuildIfNecessary' :: S.Set ModuleName -> [Module] -> m [Either ExternsFile Module] + rebuildIfNecessary' _ [] = return [] + rebuildIfNecessary' toRebuild (m@(Module _ _ moduleName' _ _) : ms') + | moduleName' `S.member` toRebuild = rebuild toRebuild m moduleName' ms' + rebuildIfNecessary' toRebuild (m@(Module _ _ moduleName' _ _) : ms') = do + (_, externsJson) <- readExterns moduleName' + case decode externsJson of + Just externs + | efVersion externs == showVersion Paths.version -> (Left externs :) <$> rebuildIfNecessary' toRebuild ms' + _ -> rebuild toRebuild m moduleName' ms' + + rebuild :: S.Set ModuleName -> Module -> ModuleName -> [Module] -> m [Either ExternsFile Module] + rebuild toRebuild m moduleName ms' = do + let deps = fromMaybe [] $ moduleName `M.lookup` graph + (Right m :) <$> rebuildIfNecessary' (toRebuild `S.union` S.fromList deps) ms' reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName] reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ] @@ -268,12 +270,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = getOutputTimestamp mn = do let filePath = runModuleName mn jsFile = outputDir filePath "index.js" - externsFile = outputDir filePath "externs.purs" + externsFile = outputDir filePath "externs.json" min <$> getTimestamp jsFile <*> getTimestamp externsFile - readExterns :: ModuleName -> Make (FilePath, String) + readExterns :: ModuleName -> Make (FilePath, B.ByteString) readExterns mn = do - let path = outputDir runModuleName mn "externs.purs" + let path = outputDir runModuleName mn "externs.json" (path, ) <$> readTextFile path codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make () @@ -290,12 +292,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude let filePath = runModuleName mn jsFile = outputDir filePath "index.js" - externsFile = outputDir filePath "externs.purs" + externsFile = outputDir filePath "externs.json" foreignFile = outputDir filePath "foreign.js" prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix] js = unlines $ map ("// " ++) prefix ++ [pjs] lift $ do - writeTextFile jsFile js + writeTextFile jsFile (fromString js) for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile) writeTextFile externsFile exts @@ -307,13 +309,13 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = exists <- doesFileExist path traverse (const $ getModificationTime path) $ guard exists - readTextFile :: FilePath -> Make String - readTextFile path = makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ readFile path + readTextFile :: FilePath -> Make B.ByteString + readTextFile path = makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ B.readFile path - writeTextFile :: FilePath -> String -> Make () + writeTextFile :: FilePath -> B.ByteString -> Make () writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do mkdirp path - writeFile path text + B.writeFile path text where mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 6d7ea535a4..ae09708100 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -15,6 +15,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GADTs #-} module Language.PureScript.Names where @@ -22,6 +23,7 @@ module Language.PureScript.Names where import Data.List import Data.Data import Data.List.Split (splitOn) +import Data.Aeson.TH import qualified Data.Aeson as A import qualified Data.Text as T @@ -54,7 +56,7 @@ newtype ProperName = ProperName { runProperName :: String } deriving (Show, Read -- | -- Module names -- -data ModuleName = ModuleName [ProperName] deriving (Show, Read, Eq, Ord, Data, Typeable) +newtype ModuleName = ModuleName [ProperName] deriving (Show, Read, Eq, Ord, Data, Typeable) runModuleName :: ModuleName -> String runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns) @@ -89,7 +91,6 @@ instance (a ~ ProperName) => A.FromJSON (Qualified a) where where reconstructModuleName = moduleNameFromString . intercalate "." . reverse - -- | -- Provide a default module name, if a name is unqualified -- @@ -109,3 +110,7 @@ mkQualified name mn = Qualified (Just mn) name isUnqualified :: Qualified a -> Bool isUnqualified (Qualified Nothing _) = True isUnqualified _ = False + +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ProperName) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index ef9768a829..0c8963bd8b 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -115,16 +115,6 @@ parseExternDeclaration :: TokenParser Declaration parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *> (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName) <*> (indented *> doubleColon *> parseKind) - <|> (do reserved "instance" - name <- parseIdent <* indented <* doubleColon - deps <- P.option [] $ do - deps' <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom))) - indented - rfatArrow - return deps' - className <- indented *> parseQualified properName - tys <- P.many (indented *> noWildcards parseTypeAtom) - return $ ExternInstanceDeclaration name deps className tys) <|> (do ident <- parseIdent -- TODO: add a wiki page link with migration info -- TODO: remove this deprecation warning in 0.8 diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index eeafd21976..ba3722715b 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -29,6 +29,7 @@ import Control.Monad.Supply.Class import Language.PureScript.AST import Language.PureScript.Errors +import Language.PureScript.Externs import Language.PureScript.Sugar.BindingGroups as S import Language.PureScript.Sugar.CaseDeclarations as S @@ -63,15 +64,16 @@ import Language.PureScript.Sugar.TypeDeclarations as S -- -- * Group mutually recursive value and data declarations into binding groups. -- -desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module] -desugar = map removeSignedLiterals - >>> mapM desugarObjectConstructors - >=> mapM desugarOperatorSections - >=> mapM desugarDoModule - >=> desugarCasesModule - >=> desugarTypeDeclarationsModule - >=> desugarImports - >=> rebracket - >=> mapM deriveInstances - >=> desugarTypeClasses - >=> createBindingGroupsModule +desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] +desugar externs = + map removeSignedLiterals + >>> mapM desugarObjectConstructors + >=> mapM desugarOperatorSections + >=> mapM desugarDoModule + >=> desugarCasesModule + >=> desugarTypeDeclarationsModule + >=> desugarImports externs + >=> rebracket externs + >=> mapM deriveInstances + >=> desugarTypeClasses externs + >=> createBindingGroupsModule diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 968ef1e79a..f06e3ba003 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -78,7 +78,6 @@ createBindingGroups moduleName = mapM f <=< handleDecls bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName) return $ filter isImportDecl ds ++ filter isExternDataDecl ds ++ - filter isExternInstanceDecl ds ++ dataBindingGroupDecls ++ filter isTypeClassDeclaration ds ++ filter isTypeClassInstanceDeclaration ds ++ diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 48d75aa5e8..f9b3cda15e 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -13,6 +13,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Sugar.Names (desugarImports) where @@ -34,6 +35,7 @@ import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Errors import Language.PureScript.Traversals +import Language.PureScript.Externs import Language.PureScript.Sugar.Names.Env import Language.PureScript.Sugar.Names.Imports import Language.PureScript.Sugar.Names.Exports @@ -42,11 +44,47 @@ import Language.PureScript.Sugar.Names.Exports -- Replaces all local names with qualified names within a list of modules. The -- modules should be topologically sorted beforehand. -- -desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module] -desugarImports modules = do - env <- foldM updateEnv initEnv modules - mapM (renameInModule' env) modules +desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] +desugarImports externs modules = do + env <- foldM externsEnv primEnv externs + env' <- foldM updateEnv env modules + mapM (renameInModule' env') modules where + -- | Create an environment from a collection of externs files + externsEnv :: Env -> ExternsFile -> m Env + externsEnv env ExternsFile{..} = do + let members = Exports{..} + ss = internalModuleSourceSpan "" + env' = M.insert efModuleName (ss, nullImports, members) env + fromEFImport (mn, mt, qmn) = (mn, [(Nothing, mt, qmn)]) + imps <- foldM (resolveModuleImport efModuleName env') nullImports (map fromEFImport efImports) + exps <- resolveExports env' efModuleName imps members efExports + return $ M.insert efModuleName (ss, imps, exps) env + where + + exportedTypes :: [((ProperName, [ProperName]), ModuleName)] + exportedTypes = mapMaybe toExportedType efExports + where + toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName) + where + forTyCon :: ExternsDeclaration -> Maybe ProperName + forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn + forTyCon _ = Nothing + toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r + toExportedType _ = Nothing + exportedTypeClasses :: [(ProperName, ModuleName)] + exportedTypeClasses = mapMaybe toExportedTypeClass efExports + where + toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName) + toExportedTypeClass (PositionedDeclarationRef _ _ r) = toExportedTypeClass r + toExportedTypeClass _ = Nothing + exportedValues :: [(Ident, ModuleName)] + exportedValues = mapMaybe toExportedValue efExports + where + toExportedValue (ValueRef ident) = Just (ident, efModuleName) + toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r + toExportedValue _ = Nothing + updateEnv :: Env -> Module -> m Env updateEnv env m@(Module ss _ mn _ refs) = case mn `M.lookup` env of @@ -120,8 +158,6 @@ renameInModule env imports (Module ss coms mn decls exps) = (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds) updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) = (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> mapM (updateTypesEverywhere pos) ts <*> pure ds) - updateDecl (pos, bound) (ExternInstanceDeclaration name cs cn ts) = - (,) (pos, bound) <$> (ExternInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn Nothing <*> mapM (updateTypesEverywhere pos) ts) updateDecl (pos, bound) (TypeDeclaration name ty) = (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty) updateDecl (pos, bound) (ExternDeclaration name ty) = diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index a5c7fd72c6..62f8514249 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -12,10 +12,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} ---{-# LANGUAGE ScopedTypeVariables #-} ---{-# LANGUAGE PatternGuards #-} ---{-# LANGUAGE RankNTypes #-} ---{-# LANGUAGE TupleSections #-} module Language.PureScript.Sugar.Names.Env ( Imports(..) @@ -23,7 +19,7 @@ module Language.PureScript.Sugar.Names.Env , Exports(..) , nullExports , Env - , initEnv + , primEnv , envModuleSourceSpan , envModuleImports , envModuleExports @@ -32,11 +28,11 @@ module Language.PureScript.Sugar.Names.Env , exportValue ) where +import qualified Data.Map as M + import Control.Monad import Control.Monad.Error.Class (MonadError(..)) -import qualified Data.Map as M - import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Environment @@ -136,11 +132,9 @@ primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] [] where mkTypeEntry (Qualified _ name) = ((name, []), ModuleName [ProperName "Prim"]) --- | --- The initial global import/export environment containing the @Prim@ module. --- -initEnv :: Env -initEnv = M.singleton +-- | Environment which only contains the Prim module. +primEnv :: Env +primEnv = M.singleton (ModuleName [ProperName "Prim"]) (internalModuleSourceSpan "", nullImports, primExports) diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 22951f0daa..c2e3cf98db 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -16,7 +16,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -module Language.PureScript.Sugar.Names.Imports (resolveImports) where +module Language.PureScript.Sugar.Names.Imports + ( resolveImports + , resolveModuleImport + ) where import Data.List (find) import Data.Maybe (fromMaybe, isNothing) @@ -59,25 +62,29 @@ findImports = foldM (go Nothing) M.empty -- | -- Constructs a set of imports for a module. -- -resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports +resolveImports :: (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports resolveImports env (Module _ _ currentModule decls _) = censor (onErrorMessages (ErrorInModule currentModule)) $ do scope <- M.insert currentModule [(Nothing, Implicit, Nothing)] <$> findImports decls - foldM resolveImport' nullImports (M.toList scope) + foldM (resolveModuleImport currentModule env) nullImports (M.toList scope) + +-- | Constructs a set of imports for a single module import. +resolveModuleImport :: + forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> Env -> Imports -> + (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) -> + m Imports +resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps where - - resolveImport' :: Imports -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) -> m Imports - resolveImport' ie (mn, imps) = foldM go ie imps + go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports + go ie' (pos, typ, impQual) = do + modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env + let ie'' = ie' { importedModules = mn : importedModules ie' } + positioned $ resolveImport currentModule mn modExports ie'' impQual typ where - go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports - go ie' (pos, typ, impQual) = do - modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env - let ie'' = ie' { importedModules = mn : importedModules ie' } - positioned $ resolveImport currentModule mn modExports ie'' impQual typ - where - positioned err = case pos of - Nothing -> err - Just pos' -> rethrowWithPosition pos' err + positioned err = case pos of + Nothing -> err + Just pos' -> rethrowWithPosition pos' err -- | -- Extends the local environment for a module by resolving an import of another module. diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 3e279f58e9..13983b0357 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -20,6 +20,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} module Language.PureScript.Sugar.Operators ( @@ -31,6 +32,7 @@ module Language.PureScript.Sugar.Operators ( import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Names +import Language.PureScript.Externs #if __GLASGOW_HASKELL__ < 710 import Control.Applicative @@ -52,9 +54,9 @@ import qualified Language.PureScript.Constants as C -- | -- Remove explicit parentheses and reorder binary operator applications -- -rebracket :: (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module] -rebracket ms = do - let fixities = concatMap collectFixities ms +rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] +rebracket externs ms = do + let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities mapM (rebracketModule opTable) ms @@ -80,6 +82,12 @@ removeParens = go (Parens val) = val go val = val +externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity)] +externsFixities ExternsFile{..} = + [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec) + | (assoc, prec, op) <- efFixities + ] + collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)] collectFixities (Module _ _ moduleName ds _) = concatMap collect ds where diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index d7438a149c..bda1de26d1 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -15,6 +15,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} module Language.PureScript.Sugar.TypeClasses @@ -28,6 +29,7 @@ import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Kinds import Language.PureScript.Names +import Language.PureScript.Externs import Language.PureScript.Sugar.CaseDeclarations import Control.Monad.Supply.Class import Language.PureScript.Types @@ -45,7 +47,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust) import qualified Data.Map as M -type MemberMap = M.Map (ModuleName, ProperName) Declaration +type MemberMap = M.Map (ModuleName, ProperName) ([(String, Maybe Kind)], [Constraint], [Declaration]) type Desugar = StateT MemberMap @@ -53,8 +55,15 @@ type Desugar = StateT MemberMap -- Add type synonym declarations for type class dictionary types, and value declarations for type class -- instance dictionary expressions. -- -desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module] -desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule +desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] +desugarTypeClasses externs = flip evalStateT initialState . mapM desugarModule + where + initialState :: MemberMap + initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) + + fromExternsDecl :: ModuleName -> ExternsDeclaration -> Maybe ((ModuleName, ProperName), ([(String, Maybe Kind)], [Constraint], [Declaration])) + fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members)) + fromExternsDecl _ _ = Nothing desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module desugarModule (Module ss coms name decls (Just exps)) = do @@ -166,9 +175,8 @@ desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErro desugarDecl mn exps = go where go d@(TypeClassDeclaration name args implies members) = do - modify (M.insert (mn, name) d) + modify (M.insert (mn, name) (args, implies, members)) return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) - go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d]) go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = error "Derived instanced should have been desugared" go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do desugared <- desugarCases members @@ -239,7 +247,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = m <- get -- Lookup the type arguments and member types for the type class - (TypeClassDeclaration _ args implies tyDecls) <- + (args, implies, tyDecls) <- maybe (throwError . errorMessage $ UnknownTypeClass className) return $ M.lookup (qualify mn className) m diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 5075b9f99a..63770d50ac 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -212,17 +212,12 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) }) return d go (d@(FixityDeclaration{})) = return d - go (d@(ImportDeclaration importedModule _ _)) = do - instances <- lookupTypeClassDictionaries $ Just importedModule - addTypeClassDictionaries (Just moduleName) instances - return d + go (d@(ImportDeclaration{})) = return d go (d@(TypeClassDeclaration pn args implies tys)) = do addTypeClass moduleName pn args implies tys return d go (d@(TypeInstanceDeclaration dictName deps className tys _)) = goInstance d dictName deps className tys - go (d@(ExternInstanceDeclaration dictName deps className tys)) = - goInstance d dictName deps className tys go (PositionedDeclaration pos com d) = warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d @@ -239,8 +234,8 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix mapM_ (checkTypeClassInstance moduleName) tys forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd checkOrphanInstance moduleName className tys - let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) TCDRegular - addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (canonicalizeDictionary dict) dict + let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) + addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict return d where @@ -295,7 +290,6 @@ typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRe exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2 exports (ValueRef id1) (ValueRef id2) = id1 == id2 exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2 - exports (TypeInstanceRef id1) (TypeInstanceRef id2) = id1 == id2 exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2 exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2 exports _ _ = False diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index d75814a895..187bd987fc 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -22,7 +22,7 @@ module Language.PureScript.TypeChecker.Entailment ( import Data.Function (on) import Data.List -import Data.Maybe (maybeToList) +import Data.Maybe (maybeToList, mapMaybe) #if __GLASGOW_HASKELL__ < 710 import Data.Foldable (foldMap) #endif @@ -54,8 +54,15 @@ import qualified Language.PureScript.Constants as C entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Check Expr entails env moduleName context = solve where - forClassName :: Qualified ProperName -> [TypeClassDictionaryInScope] - forClassName cn = findDicts cn Nothing ++ findDicts cn (Just moduleName) + forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope] + forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys)) + forClassName _ _ = error "forClassName: expected qualified class name" + + ctorModules :: Type -> Maybe ModuleName + ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn + ctorModules (TypeConstructor (Qualified Nothing _)) = error "ctorModules: unqualified type name" + ctorModules (TypeApp ty _) = ctorModules ty + ctorModules _ = Nothing findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope] findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context @@ -69,7 +76,7 @@ entails env moduleName context = solve go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' go work className' tys' = do let instances = do - tcd <- forClassName className' + tcd <- forClassName className' tys' -- Make sure the type unifies with the type in the type instance definition subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd) return (subst, tcd) @@ -77,7 +84,7 @@ entails env moduleName context = solve -- Solve any necessary subgoals args <- solveSubgoals subst (tcdDependencies tcd) return $ foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index) - (mkDictionary (canonicalizeDictionary tcd) args) + (mkDictionary (tcdName tcd) args) (tcdPath tcd) where diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 62c56480d4..22c0d8c22d 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -76,7 +76,7 @@ withScopedTypeVars mn ks = bindTypes (M.fromList (map (\(name, k) -> (Qualified withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a withTypeClassDictionaries entries action = do orig <- get - let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (canonicalizeDictionary entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ] + let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdName entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ] modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith M.union) (typeClassDictionaries . checkEnv $ st) mentries } } a <- action modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } } @@ -276,4 +276,3 @@ liftUnifyWarnings replace unify = do let uust = unifyCurrentSubstitution ust tell $ onErrorMessages (replace uust) w return (a, uust) - diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index ae8ec5cf09..feb5af2997 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -469,7 +469,7 @@ check' val t@(ConstrainedType constraints ty) = do name (supName, instantiateSuperclass (map fst args) supArgs instanceTy) ) superclasses [0..] - return (TypeClassDictionaryInScope name path className instanceTy Nothing TCDRegular : supDicts) + return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts) instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type] instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 4fdaab1ed6..6c0ccd5eae 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -36,23 +36,8 @@ data TypeClassDictionaryInScope , tcdInstanceTypes :: [Type] -- | Type class dependencies which must be satisfied to construct this dictionary , tcdDependencies :: Maybe [Constraint] - -- | The type of this dictionary - , tcdType :: TypeClassDictionaryType } deriving (Show, Read, 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, Read, Eq, Data, Typeable) - -- | -- A simplified representation of expressions which are used to represent type -- class dictionaries at runtime, which can be compared for equality @@ -75,10 +60,3 @@ data DictionaryValue -- | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer deriving (Show, Read, Ord, Eq) - --- | --- 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 From 7cf48f0250c4a072822029a3ce19eb76c4242268 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 22 Sep 2015 20:09:49 -0700 Subject: [PATCH 0022/1580] Fix type class issue with synonyms --- src/Language/PureScript/TypeChecker/Entailment.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 187bd987fc..ac430853a1 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -75,10 +75,14 @@ entails env moduleName context = solve go :: Int -> Qualified ProperName -> [Type] -> Check DictionaryValue go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' go work className' tys' = do + -- We need to desugar synonyms here so that forClassName can find the correct modules + -- in types hidden inside the synonyms. + -- TODO: this can go away when synonyms get desugared up front. + tys'' <- mapM expandAllTypeSynonyms tys' let instances = do - tcd <- forClassName className' tys' + tcd <- forClassName className' tys'' -- Make sure the type unifies with the type in the type instance definition - subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd) + subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys'' (tcdInstanceTypes tcd) return (subst, tcd) (subst, tcd) <- unique instances -- Solve any necessary subgoals From 7be61fe08c669fe5bd4c977ff8152693ffedfe2b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 22 Sep 2015 21:12:02 -0700 Subject: [PATCH 0023/1580] Fix #922, take 3 --- examples/passing/922.purs | 20 ++++++++++ src/Language/PureScript/TypeChecker/Types.hs | 39 +++++++++++++++----- 2 files changed, 50 insertions(+), 9 deletions(-) create mode 100644 examples/passing/922.purs diff --git a/examples/passing/922.purs b/examples/passing/922.purs new file mode 100644 index 0000000000..07a7ad15a9 --- /dev/null +++ b/examples/passing/922.purs @@ -0,0 +1,20 @@ +module Main where + +import Prelude + +import Control.Monad.Eff.Console + +class Default a where + def :: a + +instance defaultString :: Default String where + def = "Done" + +data I a = I a + +instance defaultI :: (Default a) => Default (I a) where + def = I def + +main = do + case def of + I s -> log s diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index ae8ec5cf09..8faccc188e 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -282,10 +282,10 @@ infer' v@(Constructor c) = do Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty return $ TypedValue True v' ty' infer' (Case vals binders) = do - ts <- mapM infer vals + (vals', ts) <- instantiateForBinders vals binders ret <- fresh - binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders - return $ TypedValue True (Case ts binders') ret + binders' <- checkBinders ts ret binders + return $ TypedValue True (Case vals' binders') ret infer' (IfThenElse cond th el) = do cond' <- check cond tyBoolean v2@(TypedValue _ _ t2) <- infer th @@ -376,7 +376,7 @@ inferBinder val (ConstructorBinder ctor binders) = do go [] ty' = case (val, ty') of (TypeConstructor _, TypeApp _ _) -> throwIncorrectArity _ -> do - _ <- subsumes Nothing val ty' + _ <- val =?= ty' return M.empty go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction = M.union <$> inferBinder obj binder <*> go binders' ret @@ -408,6 +408,26 @@ inferBinder val (NamedBinder name binder) = do inferBinder val (PositionedBinder pos _ binder) = warnAndRethrowWithPosition pos $ inferBinder val binder +-- | Returns true if a binder requires its argument type to be a monotype. +-- | If this is the case, we need to instantiate any polymorphic types before checking binders. +binderRequiresMonotype :: Binder -> Bool +binderRequiresMonotype NullBinder = False +binderRequiresMonotype (VarBinder _) = False +binderRequiresMonotype (NamedBinder _ b) = binderRequiresMonotype b +binderRequiresMonotype (PositionedBinder _ _ b) = binderRequiresMonotype b +binderRequiresMonotype _ = True + +-- | Instantiate polytypes only when necessitated by a binder. +instantiateForBinders :: [Expr] -> [CaseAlternative] -> UnifyT Type Check ([Expr], [Type]) +instantiateForBinders vals cas = fmap unzip $ zipWithM (\val inst -> do + TypedValue _ val' ty <- infer val + if inst + then instantiatePolyTypeWithUnknowns val' ty + else return (val', ty)) vals shouldInstantiate + where + shouldInstantiate :: [Bool] + shouldInstantiate = map (any binderRequiresMonotype) . transpose . map caseAlternativeBinders $ cas + -- | -- Check the types of the return values in a set of binders in a case statement -- @@ -537,8 +557,7 @@ check' (TypedValue checkType val ty1) ty2 = do val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val return $ TypedValue checkType val''' ty2' check' (Case vals binders) ret = do - vals' <- mapM infer vals - let ts = map (\(TypedValue _ _ t) -> t) vals' + (vals', ts) <- instantiateForBinders vals binders binders' <- checkBinders ts ret binders return $ TypedValue True (Case vals' binders') ret check' (IfThenElse cond th el) ty = do @@ -567,14 +586,16 @@ check' (Accessor prop val) ty = do rest <- fresh val' <- check val (TypeApp tyObject (RCons prop ty rest)) return $ TypedValue True (Accessor prop val') ty -check' (Constructor c) ty = do +check' v@(Constructor c) ty = do env <- getEnv case M.lookup c (dataConstructors env) of Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing Just (_, _, ty1, _) -> do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 - _ <- subsumes Nothing repl ty - return $ TypedValue True (Constructor c) ty + mv <- subsumes (Just v) repl ty + case mv of + Nothing -> throwError . errorMessage $ SubsumptionCheckFailed + Just v' -> return $ TypedValue True v' ty check' (Let ds val) ty = do (ds', val') <- inferLetBinding [] ds val (`check` ty) return $ TypedValue True (Let ds' val') ty From b9cb5d9449fefbdd7720e6fe024ebae7dd47198e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 23 Sep 2015 20:09:08 -0700 Subject: [PATCH 0024/1580] CPP for GHC < 7.10 --- src/Language/PureScript/AST/SourcePos.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 1b0ea5b8b8..e1d8fc5351 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -12,6 +12,7 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} @@ -23,6 +24,10 @@ import qualified Data.Data as D import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif + -- | -- Source position information -- From 907ebdabeb75f0ed682e78fa970e130880da7e8b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 23 Sep 2015 20:29:25 -0700 Subject: [PATCH 0025/1580] Give names for all JSON fields --- src/Language/PureScript/Externs.hs | 77 ++++++++++++++++++---- src/Language/PureScript/Sugar/Names.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 4 +- 3 files changed, 68 insertions(+), 15 deletions(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 1368da8835..6a608da521 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -20,6 +20,8 @@ module Language.PureScript.Externs ( ExternsFile(..) + , ExternsImport(..) + , ExternsFixity(..) , ExternsDeclaration(..) , moduleToExternsFile , applyExternsFileToEnvironment @@ -55,27 +57,76 @@ data ExternsFile = ExternsFile -- ^ List of module exports , efExports :: [DeclarationRef] -- ^ List of module imports - , efImports :: [(ModuleName, ImportDeclarationType, Maybe ModuleName)] + , efImports :: [ExternsImport] -- ^ List of operators and their fixities - , efFixities :: [(Associativity, Precedence, String)] + , efFixities :: [ExternsFixity] -- ^ List of type and value declaration , efDeclarations :: [ExternsDeclaration] } deriving (Show, Read) +-- | A module import in an externs file +data ExternsImport = ExternsImport + { + -- ^ The imported module + eiModule :: ModuleName + -- ^ The import type: regular, qualified or hiding + , eiImportType :: ImportDeclarationType + -- ^ The imported-as name, for qualified imports + , eiImportedAs :: Maybe ModuleName + } deriving (Show, Read) + +-- | A fixity declaration in an externs file +data ExternsFixity = ExternsFixity + { + -- ^ The associativity of the operator + efAssociativity :: Associativity + -- ^ The precedence level of the operator + , efPrecedence :: Precedence + -- ^ The operator symbol + , efOperator :: String + } deriving (Show, Read) + -- | A type or value declaration appearing in an externs file data ExternsDeclaration = -- ^ A type declaration - EDType ProperName Kind TypeKind + EDType + { edTypeName :: ProperName + , edTypeKind :: Kind + , edTypeDeclarationKind :: TypeKind + } -- ^ A type synonym - | EDTypeSynonym ProperName [(String, Maybe Kind)] Type + | EDTypeSynonym + { edTypeSynonymName :: ProperName + , edTypeSynonymArguments :: [(String, Maybe Kind)] + , edTypeSynonymType :: Type + } -- ^ A data construtor - | EDDataConstructor ProperName DataDeclType ProperName Type [Ident] + | EDDataConstructor + { edDataCtorName :: ProperName + , edDataCtorOrigin :: DataDeclType + , edDataCtorTypeCtor :: ProperName + , edDataCtorType :: Type + , edDataCtorFields :: [Ident] + } -- ^ A value declaration - | EDValue Ident Type + | EDValue + { edValueName :: Ident + , edValueType :: Type + } -- ^ A type class declaration - | EDClass ProperName [(String, Maybe Kind)] [(Ident, Type)] [Constraint] + | EDClass + { edClassName :: ProperName + , edClassTypeArguments :: [(String, Maybe Kind)] + , edClassMembers :: [(Ident, Type)] + , edClassConstraints :: [Constraint] + } -- ^ An instance declaration - | EDInstance (Qualified ProperName) Ident [Type] (Maybe [Constraint]) + | EDInstance + { edInstanceClassName :: Qualified ProperName + , edInstanceName :: Ident + , edInstanceTypes :: [Type] + , edInstanceConstraints :: Maybe [Constraint] + } deriving (Show, Read) -- | Convert an externs file back into a module @@ -111,8 +162,8 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} efFixities = mapMaybe fixityDecl ds efDeclarations = concatMap toExternsDeclaration efExports - fixityDecl :: Declaration -> Maybe (Associativity, Precedence, String) - fixityDecl (FixityDeclaration (Fixity assoc prec) op) = fmap (const (assoc, prec, op)) (find exportsOp exps) + fixityDecl :: Declaration -> Maybe ExternsFixity + fixityDecl (FixityDeclaration (Fixity assoc prec) op) = fmap (const (ExternsFixity assoc prec op)) (find exportsOp exps) where exportsOp :: DeclarationRef -> Bool exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r @@ -121,8 +172,8 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d fixityDecl _ = Nothing - importDecl :: Declaration -> Maybe (ModuleName, ImportDeclarationType, Maybe ModuleName) - importDecl (ImportDeclaration m mt qmn) = Just (m, mt, qmn) + importDecl :: Declaration -> Maybe ExternsImport + importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn) importDecl (PositionedDeclaration _ _ d) = importDecl d importDecl _ = Nothing @@ -159,5 +210,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} ] toExternsDeclaration _ = [] +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFixity) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index f9b3cda15e..cd4c97630c 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -56,7 +56,7 @@ desugarImports externs modules = do let members = Exports{..} ss = internalModuleSourceSpan "" env' = M.insert efModuleName (ss, nullImports, members) env - fromEFImport (mn, mt, qmn) = (mn, [(Nothing, mt, qmn)]) + fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, mt, qmn)]) imps <- foldM (resolveModuleImport efModuleName env') nullImports (map fromEFImport efImports) exps <- resolveExports env' efModuleName imps members efExports return $ M.insert efModuleName (ss, imps, exps) env diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 13983b0357..e32e83a3d7 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -83,9 +83,9 @@ removeParens = go val = val externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity)] -externsFixities ExternsFile{..} = +externsFixities ExternsFile{..} = [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec) - | (assoc, prec, op) <- efFixities + | ExternsFixity assoc prec op <- efFixities ] collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)] From 5f4bf906eedc7df4d498a5297988c2ef42fc4599 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 24 Sep 2015 21:26:14 -0700 Subject: [PATCH 0026/1580] Remove dodgy check rule --- src/Language/PureScript/TypeChecker/Types.hs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 90b0b130d8..67c9bc561b 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -599,9 +599,6 @@ check' v@(Constructor c) ty = do check' (Let ds val) ty = do (ds', val') <- inferLetBinding [] ds val (`check` ty) return $ TypedValue True (Let ds' val') ty -check' val ty | containsTypeSynonyms ty = do - ty' <- introduceSkolemScope <=< expandAllTypeSynonyms <=< replaceTypeWildcards $ ty - check val ty' check' val kt@(KindedType ty kind) = do checkTypeKind ty kind val' <- check' val ty @@ -615,12 +612,6 @@ check' val ty = do Nothing -> throwError . errorMessage $ SubsumptionCheckFailed Just v' -> return $ TypedValue True v' ty -containsTypeSynonyms :: Type -> Bool -containsTypeSynonyms = everythingOnTypes (||) go where - go (SaturatedTypeSynonym _ _) = True - go _ = False - - -- | -- Check the type of a collection of named record fields -- From e3177bfaae5a4244188019d32f3976e146084157 Mon Sep 17 00:00:00 2001 From: Konstantin Zudov Date: Fri, 25 Sep 2015 20:58:30 +0300 Subject: [PATCH 0027/1580] Ghci-like handling of Ctrl-C, Ctrl-D in psci - When Ctrl-C (UserInterrupt) is pressed, cancel the current input - When Ctrl-D (End of Input) is pressed: - if the input is empty interpret as "there would be no more commands, you may :quit" and quit - if the input isn't empty interpret as "the end of the current command" and execute the current command (whenether it's single-line or multi-line mode) --- psci/PSCi.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 8512f68ac8..810d01ae3e 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -437,10 +437,10 @@ handleKindOf typ = do -- Parses the input and returns either a Metacommand, or an error as a string. -- getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command)) -getCommand singleLineMode = do - firstLine <- getInputLine "> " +getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do + firstLine <- withInterrupt $ getInputLine "> " case firstLine of - Nothing -> return (Right Nothing) + Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty Just "" -> return (Right Nothing) Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s Just s -> either Left (Right . Just) . parseCommand <$> go [s] From 067b0b6993b4879e59b6d36fe8762f02f86f14e7 Mon Sep 17 00:00:00 2001 From: Benjamin Kovach Date: Fri, 25 Sep 2015 14:26:16 -0400 Subject: [PATCH 0028/1580] Begin work on decls --- src/Language/PureScript/Declarations.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs index a3b7689f8a..e3058bd76b 100644 --- a/src/Language/PureScript/Declarations.hs +++ b/src/Language/PureScript/Declarations.hs @@ -464,7 +464,11 @@ data Binder -- | -- A binder with source position information -- - | PositionedBinder SourcePos Binder deriving (Show, D.Data, D.Typeable) + | PositionedBinder SourcePos Binder + -- | + -- A binder with a type annotation + -- + | TypedBinder Type Binder deriving (Show, D.Data, D.Typeable) -- | -- Collect all names introduced in binders in an expression From 120a1e6f88f89448fda65b9e87277f2d0d33d913 Mon Sep 17 00:00:00 2001 From: Konstantin Zudov Date: Fri, 25 Sep 2015 22:42:31 +0300 Subject: [PATCH 0029/1580] Don't psci on Ctrl-C, just interrupt the current command --- psci/PSCi.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 810d01ae3e..26923ab436 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -555,7 +555,10 @@ loop PSCiOptions{..} = do Left err -> outputStrLn err >> go Right Nothing -> go Right (Just QuitPSCi) -> outputStrLn quitMessage - Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go + Right (Just c') -> do + handleInterrupt (outputStrLn "Interrupted.") + (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c'))) + go multiLineMode :: Parser Bool multiLineMode = switch $ From 6dd900ae4ef9e100077df69c5cac3bc2cc2ec399 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 26 Sep 2015 11:58:08 -0700 Subject: [PATCH 0030/1580] Expand type synonyms eagerly --- src/Language/PureScript/Docs/Convert.hs | 1 - src/Language/PureScript/Make.hs | 4 +- src/Language/PureScript/Pretty/Types.hs | 1 - src/Language/PureScript/Sugar/Names.hs | 1 - src/Language/PureScript/TypeChecker.hs | 16 ++-- .../PureScript/TypeChecker/Entailment.hs | 3 - src/Language/PureScript/TypeChecker/Rows.hs | 1 - .../PureScript/TypeChecker/Subsumption.hs | 6 -- .../PureScript/TypeChecker/Synonyms.hs | 86 +++++-------------- src/Language/PureScript/TypeChecker/Types.hs | 34 ++------ src/Language/PureScript/TypeChecker/Unify.hs | 13 --- src/Language/PureScript/Types.hs | 12 --- 12 files changed, 35 insertions(+), 143 deletions(-) diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index b598ddeacc..aa47fd3d65 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -166,7 +166,6 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit unQual x = let (P.Qualified _ y) = x in P.runProperName y extractProperNames (P.TypeConstructor n) = [unQual n] - extractProperNames (P.SaturatedTypeSynonym n _) = [unQual n] extractProperNames _ = [] childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index a9f67e6c3e..d54772744f 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -170,11 +170,11 @@ make MakeActions{..} ms = do go :: Environment -> [(Bool, Module)] -> SupplyT m Environment go env [] = return env go env ((False, m) : ms') = do - (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m + (_, env') <- lift . runCheck' env $ typeCheckModule m go env' ms' go env ((True, m@(Module ss coms moduleName' _ exps)) : ms') = do lift . progress $ CompilingModule moduleName' - (checked@(Module _ _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m + (checked@(Module _ _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule m checkExhaustiveModule env' checked regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated let mod' = Module ss coms moduleName' regrouped exps diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index ede0d11ce2..c6d56ab4f5 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -42,7 +42,6 @@ typeLiterals = mkPattern match match (TUnknown u) = Just $ '_' : show u match (Skolem name s _) = Just $ name ++ show s match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> showQualified runProperName pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty - match (SaturatedTypeSynonym name args) = Just $ showQualified runProperName name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">" match REmpty = Just "()" match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")" match _ = Nothing diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 48d75aa5e8..6575265eb5 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -171,7 +171,6 @@ renameInModule env imports (Module ss coms mn decls exps) = where updateType :: Type -> m Type updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos - updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t updateType t = return t diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 5075b9f99a..5202e78934 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -132,8 +132,8 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms -- -- * Process module imports -- -typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration] -typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds +typeCheckAll :: ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration] +typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds where go :: Declaration -> Check Declaration go (DataDeclaration dtype name args dctors) = do @@ -181,7 +181,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix go (ValueDeclaration name nameKind [] (Right val)) = warnAndRethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do valueIsNotDefined moduleName name - [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)] + [(_, (val', ty))] <- typesOf moduleName [(name, val)] addValue moduleName name ty nameKind return $ ValueDeclaration name nameKind [] $ Right val' go (ValueDeclaration{}) = error "Binders were not desugared" @@ -189,7 +189,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix warnAndRethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do forM_ (map (\(ident, _, _) -> ident) vals) $ \name -> valueIsNotDefined moduleName name - tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals + tys <- typesOf moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals vals' <- forM [ (name, val, nameKind, ty) | (name, nameKind, _) <- vals , (name', (val, ty)) <- tys @@ -272,11 +272,11 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix -- Type check an entire module and ensure all types and classes defined within the module that are -- required by exported members are also exported. -- -typeCheckModule :: Maybe ModuleName -> Module -> Check Module -typeCheckModule _ (Module _ _ _ _ Nothing) = error "exports should have been elaborated" -typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRethrow (onErrorMessages (ErrorInModule mn)) $ do +typeCheckModule :: Module -> Check Module +typeCheckModule (Module _ _ _ _ Nothing) = error "exports should have been elaborated" +typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (onErrorMessages (ErrorInModule mn)) $ do modify (\s -> s { checkCurrentModule = Just mn }) - decls' <- typeCheckAll mainModuleName mn exps decls + decls' <- typeCheckAll mn exps decls forM_ exps $ \e -> do checkTypesAreExported e checkClassMembersAreExported e diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index d75814a895..7a7c8ee619 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -145,9 +145,6 @@ typeHeadsAreEqual _ _ t (TypeVar v) = Jus typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just [] typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 <*> typeHeadsAreEqual m e t1 t2 -typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of - Left _ -> Nothing - Right t1 -> typeHeadsAreEqual m e t1 t2 typeHeadsAreEqual _ _ REmpty REmpty = Just [] typeHeadsAreEqual m e r1@(RCons _ _ _) r2@(RCons _ _ _) = let (s1, r1') = rowToList r1 diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs index 2bd7b7f23c..1b16e1018d 100644 --- a/src/Language/PureScript/TypeChecker/Rows.hs +++ b/src/Language/PureScript/TypeChecker/Rows.hs @@ -46,7 +46,6 @@ checkDuplicateLabels = where checkDups :: Type -> Check () checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2 - checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts checkDups (ForAll _ t _) = checkDups t checkDups (ConstrainedType args t) = do mapM_ checkDups $ concatMap snd args diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index b370a29aa9..3d10214c37 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -57,12 +57,6 @@ subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) _ <- subsumes Nothing arg2 arg1 _ <- subsumes Nothing ret1 ret2 return val -subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do - ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs - subsumes val ty1 ty2 -subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do - ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs - subsumes val ty1 ty2 subsumes' val (KindedType ty1 _) ty2 = subsumes val ty1 ty2 subsumes' val ty1 (KindedType ty2 _) = diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 71a24226f8..0796665c21 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -9,22 +9,18 @@ -- Portability : -- -- | --- Functions for replacing fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor +-- Functions for replacing fully applied type synonyms -- ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE CPP #-} module Language.PureScript.TypeChecker.Synonyms ( - saturateAllTypeSynonyms, - desaturateAllTypeSynonyms, - replaceAllTypeSynonyms, - expandAllTypeSynonyms, - expandTypeSynonym, - expandTypeSynonym' + replaceAllTypeSynonyms ) where import Data.Maybe (fromMaybe) @@ -38,73 +34,31 @@ import Control.Monad.State import Language.PureScript.Environment import Language.PureScript.Errors -import Language.PureScript.Names import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types -- | --- Build a type substitution for a type synonym +-- Replace fully applied type synonyms. -- -buildTypeSubstitution :: M.Map (Qualified ProperName) Int -> Type -> Either ErrorMessage (Maybe Type) -buildTypeSubstitution m = go 0 [] +replaceAllTypeSynonyms' :: Environment -> Type -> Either MultipleErrors Type +replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try where - go :: Int -> [Type] -> Type -> Either ErrorMessage (Maybe Type) - go c args (TypeConstructor ctor) | M.lookup ctor m == Just c = return (Just $ SaturatedTypeSynonym ctor args) - go c _ (TypeConstructor ctor) | M.lookup ctor m > Just c = throwError $ SimpleErrorWrapper $ PartiallyAppliedSynonym ctor - go c args (TypeApp f arg) = go (c + 1) (arg:args) f - go _ _ _ = return Nothing - --- | --- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor --- -saturateAllTypeSynonyms :: M.Map (Qualified ProperName) Int -> Type -> Either ErrorMessage Type -saturateAllTypeSynonyms syns = everywhereOnTypesTopDownM replace - where - replace t = fromMaybe t <$> buildTypeSubstitution syns t + try :: Type -> Either MultipleErrors Type + try t = fromMaybe t <$> go 0 [] t --- | --- \"Desaturate\" @SaturatedTypeSynonym@s --- -desaturateAllTypeSynonyms :: Type -> Type -desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym - where - replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args - replaceSaturatedTypeSynonym t = t - --- | --- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate --- better error messages during unification. --- -replaceAllTypeSynonyms' :: Environment -> Type -> Either ErrorMessage Type -replaceAllTypeSynonyms' env d = - let - syns = length . fst <$> typeSynonyms env - in - saturateAllTypeSynonyms syns d + go :: Int -> [Type] -> Type -> Either MultipleErrors (Maybe Type) + go c args (TypeConstructor ctor) + | Just (synArgs, body) <- M.lookup ctor (typeSynonyms env) + , c == length synArgs + = let repl = replaceAllTypeVars (zip (map fst synArgs) args) body + in Just <$> try repl + | Just (synArgs, _) <- M.lookup ctor (typeSynonyms env) + , length synArgs > c + = throwError . errorMessage $ PartiallyAppliedSynonym ctor + go c args (TypeApp f arg) = go (c + 1) (arg : args) f + go _ _ _ = return Nothing replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type replaceAllTypeSynonyms d = do env <- getEnv - either (throwError . singleError) return $ replaceAllTypeSynonyms' env d - --- | --- Replace a type synonym and its arguments with the aliased type --- -expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either ErrorMessage Type -expandTypeSynonym' env name args = - case M.lookup name (typeSynonyms env) of - Just (synArgs, body) -> do - let repl = replaceAllTypeVars (zip (map fst synArgs) args) body - replaceAllTypeSynonyms' env repl - Nothing -> error "Type synonym was not defined" - -expandTypeSynonym :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type -expandTypeSynonym name args = do - env <- getEnv - either (throwError . singleError) return $ expandTypeSynonym' env name args - -expandAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type -expandAllTypeSynonyms = everywhereOnTypesTopDownM go - where - go (SaturatedTypeSynonym name args) = expandTypeSynonym name args - go other = return other + either throwError return $ replaceAllTypeSynonyms' env d diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 67c9bc561b..dbe130f147 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -67,24 +67,17 @@ import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types -import qualified Language.PureScript.Constants as C -- | -- Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. -- -typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))] -typesOf mainModuleName moduleName vals = do +typesOf :: ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))] +typesOf moduleName vals = do tys <- fmap tidyUp . liftUnifyWarnings replace $ do (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals - ds1 <- parU typed $ \e -> do - triple@(_, (_, ty)) <- checkTypedBindingGroupElement moduleName e dict - checkMain (fst e) ty - return triple - ds2 <- forM untyped $ \e -> do - triple@(_, (_, ty)) <- typeForBindingGroupElement e dict untypedDict - checkMain (fst e) ty - return triple + ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict + ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict return $ ds1 ++ ds2 forM tys $ \(ident, (val, ty)) -> do @@ -94,21 +87,13 @@ typesOf mainModuleName moduleName vals = do skolemEscapeCheck val' -- Check rows do not contain duplicate labels checkDuplicateLabels val' - -- Remove type synonyms placeholders, and replace - -- top-level unification variables with named type variables. - let val'' = overTypes desaturateAllTypeSynonyms val' - ty' = varIfUnknown . desaturateAllTypeSynonyms $ ty - return (ident, (val'', ty')) + return (ident, (val', varIfUnknown ty)) where -- 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 -- Replace all the wildcards types with their inferred types replace sub (SimpleErrorWrapper (WildcardInferredType ty)) = SimpleErrorWrapper $ WildcardInferredType (sub $? ty) replace _ em = em - -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a - checkMain nm ty = when (Just moduleName == mainModuleName && nm == 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 type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) @@ -346,9 +331,6 @@ inferProperty :: Type -> String -> UnifyT Type Check (Maybe Type) inferProperty (TypeApp obj row) prop | obj == tyObject = do let (props, _) = rowToList row return $ lookup prop props -inferProperty (SaturatedTypeSynonym name args) prop = do - replaced <- introduceSkolemScope <=< expandTypeSynonym name $ args - inferProperty replaced prop inferProperty (ForAll ident ty _) prop = do replaced <- replaceVarWithUnknown ident ty inferProperty replaced prop @@ -493,9 +475,6 @@ check' val t@(ConstrainedType constraints ty) = do instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type] instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs -check' val (SaturatedTypeSynonym name args) = do - ty <- introduceSkolemScope <=< expandTypeSynonym name $ args - check val ty check' val u@(TUnknown _) = do val'@(TypedValue _ _ ty) <- infer val -- Don't unify an unknown with an inferred polytype @@ -674,9 +653,6 @@ checkFunctionApplication' fn u@(TUnknown _) arg ret = do ret' <- maybe fresh return ret u =?= function ty ret' return (ret', App fn arg') -checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do - ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs - checkFunctionApplication fn ty arg ret checkFunctionApplication' fn (KindedType ty _) arg ret = checkFunctionApplication fn ty arg ret checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 28e7431a64..4dd5a63314 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -69,10 +69,6 @@ unifyTypes t1 t2 = rethrow (onErrorMessages (ErrorUnifyingTypes t1 t2)) $ unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return () unifyTypes' (TUnknown u) t = u =:= t unifyTypes' t (TUnknown u) = u =:= t - unifyTypes' (SaturatedTypeSynonym name args) ty = do - ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ args - ty1 `unifyTypes` ty - unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty unifyTypes' (ForAll ident1 ty1 sc1) (ForAll ident2 ty2 sc2) = case (sc1, sc2) of (Just sc1', Just sc2') -> do @@ -132,10 +128,6 @@ unifyRows r1 r2 = rest <- fresh u1 =:= rowFromList (sd2, rest) u2 =:= rowFromList (sd1, rest) - unifyRows' sd1 (SaturatedTypeSynonym name args) sd2 r2' = do - r1' <- expandTypeSynonym name $ args - unifyRows (rowFromList (sd1, r1')) (rowFromList (sd2, r2')) - unifyRows' sd1 r1' sd2 r2'@(SaturatedTypeSynonym _ _) = unifyRows' sd2 r2' sd1 r1' unifyRows' [] REmpty [] REmpty = return () unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return () unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return () @@ -150,11 +142,6 @@ unifiesWith _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True unifiesWith _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True unifiesWith e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2 -unifiesWith e (SaturatedTypeSynonym name args) t2 = - case expandTypeSynonym' e name args of - Left _ -> False - Right t1 -> unifiesWith e t1 t2 -unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1 unifiesWith _ REmpty REmpty = True unifiesWith e r1@(RCons _ _ _) r2@(RCons _ _ _) = let (s1, r1') = rowToList r1 diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 4d35699e52..8e6f91d459 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -66,10 +66,6 @@ data Type -- | TypeApp Type Type -- | - -- A type synonym which is \"saturated\", i.e. fully applied - -- - | SaturatedTypeSynonym (Qualified ProperName) [Type] - -- | -- Forall quantifier -- | ForAll String Type (Maybe SkolemScope) @@ -161,7 +157,6 @@ replaceAllTypeVars = go [] Just r -> r Nothing -> TypeVar v go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2) - go bs m (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs m) ts go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f | v `elem` usedVars = let v' = genName v (keys ++ bs ++ usedVars) @@ -200,7 +195,6 @@ freeTypeVariables = nub . go [] go :: [String] -> Type -> [String] 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 go bound (ForAll v t _) = go (v : bound) t go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t go bound (RCons _ t r) = go bound t ++ go bound r @@ -247,7 +241,6 @@ everywhereOnTypes :: (Type -> Type) -> Type -> Type everywhereOnTypes f = go where go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2)) - go (SaturatedTypeSynonym name tys) = f (SaturatedTypeSynonym name (map go tys)) go (ForAll arg ty sco) = f (ForAll arg (go ty) sco) go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty)) go (RCons name ty rest) = f (RCons name (go ty) (go rest)) @@ -261,7 +254,6 @@ everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type everywhereOnTypesTopDown f = go . f where go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2)) - go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name (map (go . f) tys) go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty)) go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest)) @@ -275,7 +267,6 @@ everywhereOnTypesM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> everywhereOnTypesM f = go where go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f - go (SaturatedTypeSynonym name tys) = (SaturatedTypeSynonym name <$> mapM go tys) >>= f go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f @@ -289,7 +280,6 @@ everywhereOnTypesTopDownM :: (Functor m, Applicative m, Monad m) => (Type -> m T everywhereOnTypesTopDownM f = go <=< f where go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go) - go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name <$> mapM (go <=< f) tys go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go) go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go) @@ -303,7 +293,6 @@ everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r everythingOnTypes (<>) f = go where go t@(TypeApp t1 t2) = f t <> go t1 <> go t2 - go t@(SaturatedTypeSynonym _ tys) = foldl (<>) (f t) (map go tys) go t@(ForAll _ ty _) = f t <> go ty go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty go t@(RCons _ ty rest) = f t <> go ty <> go rest @@ -318,7 +307,6 @@ everythingWithContextOnTypes s0 r0 (<>) f = go' s0 where go' s t = let (s', r) = f s t in r <> go s' t go s (TypeApp t1 t2) = go' s t1 <> go' s t2 - go s (SaturatedTypeSynonym _ tys) = foldl (<>) r0 (map (go' s) tys) go s (ForAll _ ty _) = go' s ty go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap snd cs) <> go' s ty go s (RCons _ ty rest) = go' s ty <> go' s rest From 4a42750f0c58723a09d5ce14cdd76660e4865992 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 26 Sep 2015 12:51:01 -0700 Subject: [PATCH 0031/1580] Add a warning, and a test. --- examples/passing/LargeSumType.purs | 33 +++++++++ src/Language/PureScript/Errors.hs | 6 ++ src/Language/PureScript/Linter/Exhaustive.hs | 75 ++++++++++++-------- 3 files changed, 84 insertions(+), 30 deletions(-) create mode 100644 examples/passing/LargeSumType.purs diff --git a/examples/passing/LargeSumType.purs b/examples/passing/LargeSumType.purs new file mode 100644 index 0000000000..1cc8ff0e84 --- /dev/null +++ b/examples/passing/LargeSumType.purs @@ -0,0 +1,33 @@ +module Main where + +data Large = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z + +explode A A = "A" +explode B B = "B" +explode C C = "C" +explode D D = "D" +explode E E = "E" +explode F F = "F" +explode G G = "G" +explode H H = "H" +explode I I = "I" +explode J J = "J" +explode K K = "K" +explode L L = "L" +explode M M = "M" +explode N N = "N" +explode O O = "O" +explode P P = "P" +explode Q Q = "Q" +explode R R = "R" +explode S S = "S" +explode T T = "T" +explode U U = "U" +explode V V = "V" +explode W W = "W" +explode X X = "X" +explode Y Y = "Y" +explode Z Z = "Z" +explode _ _ = "" + +main = Control.Monad.Eff.Console.log "Done" \ No newline at end of file diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8169125072..b6b9fa6c47 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -143,6 +143,7 @@ data SimpleErrorMessage | WildcardInferredType Type | NotExhaustivePattern [[Binder]] Bool | OverlappingPattern [[Binder]] Bool + | IncompleteExhaustivityCheck | ClassOperator ProperName Ident | MisleadingEmptyTypeImport ModuleName ProperName | ImportHidingModule ModuleName @@ -269,6 +270,7 @@ errorCode em = case unwrapErrorMessage em of WildcardInferredType{} -> "WildcardInferredType" NotExhaustivePattern{} -> "NotExhaustivePattern" OverlappingPattern{} -> "OverlappingPattern" + IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck" ClassOperator{} -> "ClassOperator" MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport" ImportHidingModule{} -> "ImportHidingModule" @@ -651,6 +653,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ] ++ [ line "..." | not b ] + goSimple IncompleteExhaustivityCheck = + paras [ line "An exhaustivity check was abandoned due to too many possible cases." + , line "You may want to decomposing your data types into smaller types." + ] go (NotYetDefined names err) = paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":" , indent $ go err diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 8f798ed5ab..38e90f47f8 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -29,6 +29,9 @@ import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.List (foldl', sortBy, nub) import Data.Function (on) +#if __GLASGOW_HASKELL__ < 710 +import Data.Traversable (sequenceA) +#endif import Control.Monad (unless) import Control.Applicative @@ -45,6 +48,14 @@ import Language.PureScript.Errors import Language.PureScript.AST.Traversals (everywhereOnValuesTopDownM) +-- | There are two modes of failure for the redudancy check: +-- +-- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy. +-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder. +-- +-- We want to warn the user in the first case. +data RedudancyError = Incomplete | Unknown + -- | -- Qualifies a propername from a given qualified propername and a default module name -- @@ -59,20 +70,20 @@ qualifyName n defmn qn = Qualified (Just mn) n -- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe) -- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"]) -- -getConstructors :: Environment -> ModuleName -> (Qualified ProperName) -> [(ProperName, [Type])] +getConstructors :: Environment -> ModuleName -> Qualified ProperName -> [(ProperName, [Type])] getConstructors env defmn n = extractConstructors lnte where qpn :: Qualified ProperName qpn = getConsDataName n - getConsDataName :: (Qualified ProperName) -> (Qualified ProperName) + getConsDataName :: Qualified ProperName -> Qualified ProperName getConsDataName con = qualifyName nm defmn con where nm = case getConsInfo con of Nothing -> error $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName." Just (_, pm, _, _) -> pm - getConsInfo :: (Qualified ProperName) -> Maybe (DataDeclType, ProperName, Type, [Ident]) + getConsInfo :: Qualified ProperName -> Maybe (DataDeclType, ProperName, Type, [Ident]) getConsInfo con = M.lookup con dce where dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident]) @@ -103,27 +114,27 @@ genericMerge _ [] [] = [] genericMerge f bs [] = map (\(s, b) -> f s (Just b) Nothing) bs genericMerge f [] bs = map (\(s, b) -> f s Nothing (Just b)) bs genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs') - | s < s' = (f s (Just b) Nothing) : genericMerge f bs bsr - | s > s' = (f s' Nothing (Just b')) : genericMerge f bsl bs' - | otherwise = (f s (Just b) (Just b')) : genericMerge f bs bs' + | s < s' = f s (Just b) Nothing : genericMerge f bs bsr + | s > s' = f s' Nothing (Just b') : genericMerge f bsl bs' + | otherwise = f s (Just b) (Just b') : genericMerge f bs bs' -- | -- Find the uncovered set between two binders: -- the first binder is the case we are trying to cover, the second one is the matching binder -- -missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Maybe Bool) -missingCasesSingle _ _ _ NullBinder = ([], Just True) -missingCasesSingle _ _ _ (VarBinder _) = ([], Just True) +missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedudancyError Bool) +missingCasesSingle _ _ _ NullBinder = ([], return True) +missingCasesSingle _ _ _ (VarBinder _) = ([], return True) missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b missingCasesSingle env mn br (NamedBinder _ bl) = missingCasesSingle env mn br bl missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) = - (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, Just True) + (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, return True) where allPatterns = map (\(p, t) -> ConstructorBinder (qualifyName p mn con) (initialize $ length t)) $ getConstructors env mn con missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs') | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr) - | otherwise = ([cb], Just False) + | otherwise = ([cb], return False) missingCasesSingle env mn NullBinder (ObjectBinder bs) = (map (ObjectBinder . zip (map fst bs)) allMisses, pr) where @@ -146,12 +157,12 @@ missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') = compBS e s b b' = (s, compB e b b') (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs' -missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], Just True) +missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], return True) missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br) - | bl == br = ([], Just True) - | otherwise = ([BooleanBinder bl], Just False) + | bl == br = ([], return True) + | otherwise = ([BooleanBinder bl], return False) missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb -missingCasesSingle _ _ b _ = ([b], Nothing) +missingCasesSingle _ _ b _ = ([b], Left Unknown) -- | -- Returns the uncovered set of binders @@ -179,7 +190,7 @@ missingCasesSingle _ _ b _ = ([b], Nothing) -- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker -- (which ought to be available soon), or increase the complexity of the algorithm. -- -missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Maybe Bool) +missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedudancyError Bool) missingCasesMultiple env mn = go where go [] [] = ([], pure True) @@ -213,18 +224,16 @@ isExhaustiveGuard (Right _) = True -- | -- Returns the uncovered set of case alternatives -- -missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Maybe Bool) +missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedudancyError Bool) missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca) -missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Maybe Bool) +missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedudancyError Bool) missingAlternative env mn ca uncovered | isExhaustiveGuard (caseAlternativeResult ca) = mcases | otherwise = ([uncovered], snd mcases) where mcases = missingCases env mn uncovered ca - - -- | -- Main exhaustivity checking function -- Starting with the set `uncovered = { _ }` (nothing covered, one `_` for each function argument), @@ -234,25 +243,31 @@ missingAlternative env mn ca uncovered checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m () checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas where - step :: ([[Binder]], (Maybe Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Maybe Bool, [[Binder]])) + step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]])) step (uncovered, (nec, redundant)) ca = let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered) (missed', approx) = splitAt 10000 (concat missed) cond = liftA2 (&&) (or <$> sequenceA pr) nec - in (missed', (if null approx then cond else Nothing, - if fromMaybe True cond then redundant else caseAlternativeBinders ca : redundant)) -#if __GLASGOW_HASKELL__ < 710 - where - sequenceA = foldr (liftA2 (:)) (pure []) -#endif - - makeResult :: ([[Binder]], (Maybe Bool, [[Binder]])) -> m () - makeResult (bss, (_, bss')) = + in (missed', ( if null approx + then cond + else Left Incomplete + , if either (const True) id cond + then redundant + else caseAlternativeBinders ca : redundant + ) + ) + + makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m () + makeResult (bss, (rr, bss')) = do unless (null bss) tellExhaustive unless (null bss') tellRedundant + case rr of + Left Incomplete -> tellIncomplete + _ -> return () where tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss' + tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck -- | -- Exhaustivity checking over a list of declarations From 641395ee5c495ddb1cbe66b771849ed617a25f2d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 26 Sep 2015 13:19:03 -0700 Subject: [PATCH 0032/1580] Fix warnings --- src/Language/PureScript/TypeChecker/Entailment.hs | 1 - src/Language/PureScript/TypeChecker/Subsumption.hs | 2 -- src/Language/PureScript/TypeChecker/Unify.hs | 1 - 3 files changed, 4 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 7a7c8ee619..dc3bf3ee45 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -41,7 +41,6 @@ import Language.PureScript.Errors import Language.PureScript.Environment import Language.PureScript.Names import Language.PureScript.TypeChecker.Monad -import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 3d10214c37..b7898e885c 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -20,7 +20,6 @@ module Language.PureScript.TypeChecker.Subsumption ( import Data.List (sortBy) import Data.Ord (comparing) -import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Unify @@ -29,7 +28,6 @@ import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Skolems -import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.TypeChecker.Unify import Language.PureScript.Types diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 4dd5a63314..6f64e4aa94 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -40,7 +40,6 @@ import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Skolems -import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.Types instance Partial Type where From c6a9b919646d37d9ff4b79046ced4055e75e4d05 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 26 Sep 2015 13:53:53 -0700 Subject: [PATCH 0033/1580] Remove unused function arguments --- .../PureScript/TypeChecker/Entailment.hs | 29 +++++++++---------- src/Language/PureScript/TypeChecker/Types.hs | 4 +-- src/Language/PureScript/TypeChecker/Unify.hs | 21 +++++++------- 3 files changed, 25 insertions(+), 29 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index dc3bf3ee45..f83d86e163 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -38,7 +38,6 @@ import Control.Monad.Writer.Class (tell) import Language.PureScript.AST import Language.PureScript.Errors -import Language.PureScript.Environment import Language.PureScript.Names import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Unify @@ -50,8 +49,8 @@ import qualified Language.PureScript.Constants as C -- Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. -- -entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Check Expr -entails env moduleName context = solve +entails :: ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Check Expr +entails moduleName context = solve where forClassName :: Qualified ProperName -> [TypeClassDictionaryInScope] forClassName cn = findDicts cn Nothing ++ findDicts cn (Just moduleName) @@ -70,7 +69,7 @@ entails env moduleName context = solve let instances = do tcd <- forClassName className' -- Make sure the type unifies with the type in the type instance definition - subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd) + subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName) tys' (tcdInstanceTypes tcd) return (subst, tcd) (subst, tcd) <- unique instances -- Solve any necessary subgoals @@ -128,7 +127,7 @@ entails env moduleName context = solve verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)] verifySubstitution subst = do let grps = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ subst - guard (all (pairwise (unifiesWith env) . map snd) grps) + guard (all (pairwise unifiesWith . map snd) grps) return $ map head grps valUndefined :: Expr @@ -138,21 +137,21 @@ entails env moduleName context = solve -- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup), -- and return a substitution from type variables to types which makes the type heads unify. -- -typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)] -typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just [] -typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)] -typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just [] -typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 - <*> typeHeadsAreEqual m e t1 t2 -typeHeadsAreEqual _ _ REmpty REmpty = Just [] -typeHeadsAreEqual m e r1@(RCons _ _ _) r2@(RCons _ _ _) = +typeHeadsAreEqual :: ModuleName -> Type -> Type -> Maybe [(String, Type)] +typeHeadsAreEqual _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just [] +typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)] +typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just [] +typeHeadsAreEqual m (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m h1 h2 + <*> typeHeadsAreEqual m t1 t2 +typeHeadsAreEqual _ REmpty REmpty = Just [] +typeHeadsAreEqual m r1@RCons{} r2@RCons{} = let (s1, r1') = rowToList r1 (s2, r2') = rowToList r2 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] - in (++) <$> foldMap (\(t1, t2) -> typeHeadsAreEqual m e t1 t2) int + in (++) <$> foldMap (uncurry (typeHeadsAreEqual m)) int <*> go sd1 r1' sd2 r2' where go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)] @@ -162,7 +161,7 @@ typeHeadsAreEqual m e r1@(RCons _ _ _) r2@(RCons _ _ _) = go [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = Just [] go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))] go _ _ _ _ = Nothing -typeHeadsAreEqual _ _ _ _ = Nothing +typeHeadsAreEqual _ _ _ = Nothing -- | -- Check all values in a list pairwise match a predicate diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index dbe130f147..ddf94a74da 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -167,9 +167,7 @@ replaceTypeClassDictionaries mn = let (_, f, _) = everywhereOnValuesTopDownM return go return in f where - go (TypeClassDictionary constraint dicts) = do - env <- getEnv - entails env mn dicts constraint + go (TypeClassDictionary constraint dicts) = entails mn dicts constraint go other = return other -- | diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 6f64e4aa94..ed4275e3a9 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -36,7 +36,6 @@ import Control.Monad.Unify import Control.Monad.Writer import Control.Monad.Error.Class (MonadError(..)) -import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Skolems @@ -135,21 +134,21 @@ unifyRows r1 r2 = -- | -- Check that two types unify -- -unifiesWith :: Environment -> Type -> Type -> Bool -unifiesWith _ (TUnknown u1) (TUnknown u2) | u1 == u2 = True -unifiesWith _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True -unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True -unifiesWith _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True -unifiesWith e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2 -unifiesWith _ REmpty REmpty = True -unifiesWith e r1@(RCons _ _ _) r2@(RCons _ _ _) = +unifiesWith :: Type -> Type -> Bool +unifiesWith (TUnknown u1) (TUnknown u2) | u1 == u2 = True +unifiesWith (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True +unifiesWith (TypeVar v1) (TypeVar v2) | v1 == v2 = True +unifiesWith (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True +unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2 +unifiesWith REmpty REmpty = True +unifiesWith r1@(RCons _ _ _) r2@(RCons _ _ _) = let (s1, r1') = rowToList r1 (s2, r2') = rowToList r2 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] - in all (\(t1, t2) -> unifiesWith e t1 t2) int && go sd1 r1' sd2 r2' + in all (uncurry unifiesWith) int && go sd1 r1' sd2 r2' where go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool go [] REmpty [] REmpty = True @@ -159,7 +158,7 @@ unifiesWith e r1@(RCons _ _ _) r2@(RCons _ _ _) = go _ _ [] (TUnknown _) = True go _ (TUnknown _) _ (TUnknown _) = True go _ _ _ _ = False -unifiesWith _ _ _ = False +unifiesWith _ _ = False -- | -- Replace a single type variable with a new unification variable From a88ca7be2a6bc479531352953a9056e970ad1f1b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 26 Sep 2015 14:25:05 -0700 Subject: [PATCH 0034/1580] Fxi #1482 --- bundle/README | 0 1 file changed, 0 insertions(+), 0 deletions(-) mode change 100755 => 100644 bundle/README diff --git a/bundle/README b/bundle/README old mode 100755 new mode 100644 From 6d8194100124fd7b46d1c478ff9c358f40ac1d6c Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 29 Sep 2015 14:28:43 +0300 Subject: [PATCH 0035/1580] Bump process upper bound --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 3856c4abf0..a19031b05d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -55,7 +55,7 @@ library language-javascript == 0.5.*, syb -any, Glob >= 0.7 && < 0.8, - process >= 1.2.0 && < 1.3, + process >= 1.2.0 && < 1.4, safe >= 0.3.9 && < 0.4, semigroups >= 0.16.2 && < 0.18 From 106dc0b695a4fdd77ea24e8389cb4e15cded5922 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 29 Sep 2015 14:30:00 +0300 Subject: [PATCH 0036/1580] Bump stackage snapshots --- .travis.yml | 8 ++++---- stack-lts-3.yaml | 2 +- stack-nightly.yaml | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/.travis.yml b/.travis.yml index 30283da694..546292eacf 100644 --- a/.travis.yml +++ b/.travis.yml @@ -18,11 +18,11 @@ matrix: - env: GHCVER=7.10.1 compiler: ": #GHC 7.10.1" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.10.2 STACKAGE=lts=3.4 RUNSDISTTESTS=YES - compiler: ": #GHC 7.10.2 lts-3.4" + - env: GHCVER=7.10.2 STACKAGE=lts=3.6 RUNSDISTTESTS=YES + compiler: ": #GHC 7.10.2 lts-3.6" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.10.2 STACKAGE=nightly-2015-08-24 - compiler: ": #GHC 7.10.2 nightly-2015-09-09" + - env: GHCVER=7.10.2 STACKAGE=nightly-2015-09-29 + compiler: ": #GHC 7.10.2 nightly-2015-09-29" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} before_install: - unset CC diff --git a/stack-lts-3.yaml b/stack-lts-3.yaml index 9e1254bc87..c69fe3dd83 100644 --- a/stack-lts-3.yaml +++ b/stack-lts-3.yaml @@ -2,4 +2,4 @@ flags: {} packages: - '.' extra-deps: -resolver: lts-3.4 +resolver: lts-3.6 diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 26c1a4e917..cd12fa35d9 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -2,4 +2,4 @@ flags: {} packages: - '.' extra-deps: -resolver: nightly-2015-09-09 +resolver: nightly-2015-09-29 From d225b7ddd7e42de1c5d8aa373918ba237823f88e Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 29 Sep 2015 14:40:48 +0300 Subject: [PATCH 0037/1580] Fix lts-2.22 travis job --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 546292eacf..f62a8ecd91 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,8 +9,8 @@ matrix: - env: GHCVER=7.8.4 COVERAGE_SUITE=psci-tests compiler: ": #GHC 7.8.4 - psci-tests" addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.8.4 STACKAGE=lts-22 - compiler: ": #GHC 7.8.4 - lts-2.22" + - env: GHCVER=7.8.4 STACKAGE=lts-2.22 + compiler: ": #GHC 7.8.4 - lts-2.22-1" addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - env: GHCVER=7.6.3 compiler: ": #GHC 7.6.3" From 0ebab5ba22c979ca5830c4225770a537a4ed8f13 Mon Sep 17 00:00:00 2001 From: senju Date: Fri, 2 Oct 2015 02:23:36 +0900 Subject: [PATCH 0038/1580] fixed #1496. --- examples/passing/UTF8Sourcefile.purs | 10 ++++++++++ psc/Main.hs | 6 ++++-- purescript.cabal | 1 + src/System/IO/UTF8.hs | 9 +++++++++ tests/Main.hs | 7 ++++--- 5 files changed, 28 insertions(+), 5 deletions(-) create mode 100644 examples/passing/UTF8Sourcefile.purs create mode 100644 src/System/IO/UTF8.hs diff --git a/examples/passing/UTF8Sourcefile.purs b/examples/passing/UTF8Sourcefile.purs new file mode 100644 index 0000000000..da102a330d --- /dev/null +++ b/examples/passing/UTF8Sourcefile.purs @@ -0,0 +1,10 @@ +module Main where + +import Control.Monad.Eff.Console + +-- '→' is multibyte sequence \u2192. +utf8multibyte = "Hello λ→ world!!" + +main = do + log "done" + diff --git a/psc/Main.hs b/psc/Main.hs index be0d11a639..d89be911c5 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -32,6 +32,7 @@ import Options.Applicative as Opts import System.Exit (exitSuccess, exitFailure) import System.IO (hPutStrLn, stderr) +import System.IO.UTF8 import System.FilePath.Glob (glob) import qualified Language.PureScript as P @@ -60,7 +61,7 @@ compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = d let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input moduleFiles <- readInput (InputOptions pursFiles) inputForeign <- globWarningOnMisses warnFileTypeNotFound inputForeignGlob - foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readFile inFile) + foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile) case runWriterT (parseInputs moduleFiles foreignFiles) of Left errs -> do hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs) @@ -93,7 +94,7 @@ globWarningOnMisses warn = concatMapM globWithWarning concatMapM f = liftM concat . mapM f readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)] -readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile +readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readUTF8File inFile parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m) => [(Either P.RebuildPolicy FilePath, String)] @@ -178,6 +179,7 @@ pscMakeOptions = PSCMakeOptions <$> many inputFile <*> options <*> (not <$> noPrefix) + main :: IO () main = execParser opts >>= compile where diff --git a/purescript.cabal b/purescript.cabal index a19031b05d..6ce480cbd9 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -162,6 +162,7 @@ library Control.Monad.Supply Control.Monad.Supply.Class + System.IO.UTF8 exposed: True buildable: True hs-source-dirs: src diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs new file mode 100644 index 0000000000..d2b8ff9787 --- /dev/null +++ b/src/System/IO/UTF8.hs @@ -0,0 +1,9 @@ +module System.IO.UTF8 +where +import System.IO (hGetContents, hSetEncoding, openFile, utf8, IOMode (..)) + +readUTF8File :: FilePath -> IO String +readUTF8File inFile = do + h <- openFile inFile ReadMode + hSetEncoding h utf8 + hGetContents h diff --git a/tests/Main.hs b/tests/Main.hs index 6644c8a2d3..6d202e1b54 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -66,6 +66,7 @@ import System.Exit import System.Process import System.FilePath import System.Directory +import System.IO.UTF8 import qualified System.Info import qualified System.FilePath.Glob as Glob @@ -97,7 +98,7 @@ makeActions foreigns = (P.buildMakeActions modulesDir (error "makeActions: input readInput :: [FilePath] -> IO [(FilePath, String)] readInput inputFiles = forM inputFiles $ \inputFile -> do - text <- readFile inputFile + text <- readUTF8File inputFile return (inputFile, text) type TestM = WriterT [(FilePath, String)] IO @@ -157,7 +158,7 @@ assertDoesNotCompile inputFiles foreigns = do where getShouldFailWith = - readFile + readUTF8File >>> liftIO >>> fmap ( lines >>> mapMaybe (stripPrefix "-- @shouldFailWith ") @@ -184,7 +185,7 @@ main = do supportPurs <- supportFiles "purs" supportJS <- supportFiles "js" - foreignFiles <- forM supportJS (\f -> (f,) <$> readFile f) + foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f) Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles let passing = cwd "examples" "passing" From ae8cfaafb2e1ccd54ddcdfc13ef8e70d046829e0 Mon Sep 17 00:00:00 2001 From: senju Date: Fri, 2 Oct 2015 03:00:14 +0900 Subject: [PATCH 0039/1580] CONTRIBUTORS.md - Adding Senju. --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 5e1db35120..cac0aadc49 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -53,6 +53,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). . ### Companies From 6d1b5ec3af12812810701b766a12f7c9aceabe75 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 26 Sep 2015 17:14:23 -0700 Subject: [PATCH 0040/1580] Parallel builds --- LICENSE | 235 +++++++++++++----- license-generator/generate | 3 + psci/PSCi.hs | 8 +- purescript.cabal | 5 +- src/Language/PureScript/AST/Traversals.hs | 6 +- src/Language/PureScript/Make.hs | 154 +++++++----- src/Language/PureScript/ModuleDependencies.hs | 16 +- 7 files changed, 285 insertions(+), 142 deletions(-) diff --git a/LICENSE b/LICENSE index 8135c9564a..6f84bf88b2 100644 --- a/LICENSE +++ b/LICENSE @@ -31,6 +31,7 @@ PureScript uses the following Haskell library packages. Their license files foll array attoparsec base + binary blaze-builder bower-json boxes @@ -45,9 +46,10 @@ PureScript uses the following Haskell library packages. Their license files foll haskeline integer-gmp language-javascript + lifted-base + monad-control mtl nats - old-locale optparse-applicative parsec pattern-arrows @@ -59,12 +61,14 @@ PureScript uses the following Haskell library packages. Their license files foll scientific semigroups split + stm syb template-haskell terminfo text time transformers + transformers-base transformers-compat unix unordered-containers @@ -449,6 +453,39 @@ base LICENSE file: ----------------------------------------------------------------------------- +binary LICENSE file: + + Copyright (c) Lennart Kolmodin + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + blaze-builder LICENSE file: Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 2011 @@ -967,6 +1004,70 @@ language-javascript LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +lifted-base LICENSE file: + + Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + • Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + • Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + • Neither the name of the author nor the names of other contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +monad-control LICENSE file: + + Copyright © 2010, Bas van Dijk, Anders Kaseorg + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + • Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + • Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + • Neither the name of the author nor the names of other contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + mtl LICENSE file: The Glasgow Haskell Compiler License @@ -1034,72 +1135,6 @@ nats LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -old-locale LICENSE file: - - This library (libraries/base) is derived from code from two - sources: - - * Code from the GHC project which is largely (c) The University of - Glasgow, and distributable under a BSD-style license (see below), - - * Code from the Haskell 98 Report which is (c) Simon Peyton Jones - and freely redistributable (but see the full license for - restrictions). - - The full text of these licenses is reproduced below. Both of the - licenses are BSD-style or compatible. - - ----------------------------------------------------------------------------- - - The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - - Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - - - Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - - - Neither name of the University nor the names of its contributors may be - used to endorse or promote products derived from this software without - specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF - GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - DAMAGE. - - ----------------------------------------------------------------------------- - - Code derived from the document "Report on the Programming Language - Haskell 98", is distributed under the following license: - - Copyright (c) 2002 Simon Peyton Jones - - The authors intend this Report to belong to the entire Haskell - community, and so we grant permission to copy and distribute it for - any purpose, provided that it is reproduced in its entirety, - including this Notice. Modified versions of this Report may also be - copied and distributed for any purpose, provided that the modified - version is clearly presented as such, and that it does not claim to - be a definition of the Haskell 98 Language. - - ----------------------------------------------------------------------------- - optparse-applicative LICENSE file: Copyright (c) 2012, Paolo Capriotti @@ -1450,6 +1485,40 @@ split LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +stm LICENSE file: + + The Glasgow Haskell Compiler License + + Copyright 2004, The University Court of the University of Glasgow. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. + syb LICENSE file: This library (libraries/syb) is derived from code from several @@ -1674,6 +1743,36 @@ transformers LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +transformers-base LICENSE file: + + Copyright (c) 2011, Mikhail Vorozhtsov, Bas van Dijk + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + - Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + - Neither the names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + transformers-compat LICENSE file: Copyright 2012 Edward Kmett @@ -1836,7 +1935,7 @@ vector LICENSE file: void LICENSE file: - Copyright 2013 Edward Kmett + Copyright 2015 Edward Kmett All rights reserved. diff --git a/license-generator/generate b/license-generator/generate index 2746322b3d..3973f334aa 100755 --- a/license-generator/generate +++ b/license-generator/generate @@ -9,6 +9,9 @@ set -e # exit on error set -u # exit on undefined variable set -o pipefail # propagate nonzero exit codes through pipelines +export LC_CTYPE=C +export LANG=C + if ! which cabal-dependency-licenses >/dev/null; then echo "$0: the program 'cabal-dependency-licenses' is required." >&2 echo "$0: see Hackage: https://hackage.haskell.org/package/cabal-dependency-licenses" >&2 diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 26923ab436..b9156d5a25 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -263,10 +263,10 @@ makeIO f io = do make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment make PSCiState{..} ms = P.make actions' (map snd (psciLoadedModules ++ ms)) - where - filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms) - actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False - actions' = actions { P.progress = const (return ()) } + where + filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms) + actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False + actions' = actions { P.progress = const (return ()) } -- | -- Takes a value declaration and evaluates it with the current state. diff --git a/purescript.cabal b/purescript.cabal index 3856c4abf0..ff5dff97b5 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -32,6 +32,9 @@ source-repository head library build-depends: base >=4.6 && <5, + lifted-base >= 0.2.3 && < 0.2.4, + monad-control >= 1.0.0.0 && < 1.1, + transformers-base >= 0.4.0 && < 0.5, containers -any, unordered-containers -any, dlist -any, @@ -175,7 +178,7 @@ executable psc main-is: Main.hs buildable: True hs-source-dirs: psc - ghc-options: -Wall -O2 -fno-warn-unused-do-bind + ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N" executable psci build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index b05867b70e..282ea69aa4 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -216,10 +216,10 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') f' d = f d g' v@(UnaryMinus v1) = g v <> g' v1 - g' v@(BinaryNoParens op v1 v2) = g v <> g op <> g' v1 <> g' v2 + g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2 g' v@(Parens v1) = g v <> g' v1 - g' v@(OperatorSection op (Left v1)) = g v <> g op <> g' v1 - g' v@(OperatorSection op (Right v1)) = g v <> g op <> g' v1 + g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1 + g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs) g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs) g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs)) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 99d28fc913..26f613861d 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -19,6 +19,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} module Language.PureScript.Make @@ -39,29 +41,31 @@ module Language.PureScript.Make #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif -import Control.Arrow ((&&&)) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.Except import Control.Monad.Reader import Control.Monad.Writer.Strict import Control.Monad.Supply +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Trans.Control (MonadBaseControl(..)) -import Data.Function (on) -import Data.Either (partitionEithers) -import Data.List (sortBy, groupBy, foldl') -import Data.Maybe (fromMaybe) +import Control.Concurrent.Lifted as C + +import Data.List (foldl') +import Data.Maybe (fromMaybe, catMaybes) import Data.Time.Clock import Data.String (fromString) import Data.Foldable (for_) #if __GLASGOW_HASKELL__ < 710 import Data.Traversable (traverse) #endif +import Data.Traversable (for) import Data.Version (showVersion) import Data.Aeson (encode, decode) import qualified Data.ByteString.Lazy as B -import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.Map as M import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing) @@ -150,65 +154,89 @@ data RebuildPolicy -- If timestamps have not changed, the externs file can be used to provide the module's types without -- having to typecheck the module again. -- -make :: forall m. (Functor m, Applicative m, Monad m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +make :: forall m. (Functor m, Applicative m, Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [Module] -> m Environment make MakeActions{..} ms = do - (sorted, graph) <- sortModules $ map importPrim ms - toRebuild <- foldM (\s (Module _ _ moduleName' _ _) -> do - inputTimestamp <- getInputTimestamp moduleName' - outputTimestamp <- getOutputTimestamp moduleName' - return $ case (inputTimestamp, outputTimestamp) of - (Right (Just t1), Just t2) | t1 < t2 -> s - (Left RebuildNever, Just _) -> s - _ -> S.insert moduleName' s) S.empty sorted - - (externs, toBuild) <- partitionEithers <$> rebuildIfNecessary (reverseDependencies graph) toRebuild sorted - for_ toBuild lint - (desugared, nextVar) <- runSupplyT 0 $ desugar externs toBuild - let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs - evalSupplyT nextVar $ go env desugared - where + (sorted, graph) <- sortModules ms + + barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar) + + for_ sorted $ \m -> fork $ do + let deps = fromMaybe (error "make: module not found in dependency graph.") (lookup (getModuleName m) graph) + buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted) + + -- Wait for all threads to complete, and collect errors. + errors <- catMaybes <$> for barriers (takeMVar . snd . snd) + + -- All threads have completed, rethrow any caught errors. + unless (null errors) $ throwError (mconcat errors) + + -- Bundle up all the externs and return them as an Environment + externs <- sequence <$> for barriers (takeMVar . fst . snd) + return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment (fromMaybe (error "make: externs were missing but no errors reported.") externs) - go :: Environment -> [Module] -> SupplyT m Environment - go env [] = return env - go env (m@(Module ss coms moduleName' _ exps) : ms') = do - lift . progress $ CompilingModule moduleName' - (checked@(Module _ _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m - checkExhaustiveModule env' checked - regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated - let mod' = Module ss coms moduleName' regrouped exps - corefn = CF.moduleToCoreFn env' mod' - [renamed] = renameInModules [corefn] - exts = encode $ moduleToExternsFile mod' env' - codegen renamed env' exts - go env' ms' - - rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [Either ExternsFile Module] - rebuildIfNecessary graph = rebuildIfNecessary' - where - rebuildIfNecessary' :: S.Set ModuleName -> [Module] -> m [Either ExternsFile Module] - rebuildIfNecessary' _ [] = return [] - rebuildIfNecessary' toRebuild (m@(Module _ _ moduleName' _ _) : ms') - | moduleName' `S.member` toRebuild = rebuild toRebuild m moduleName' ms' - rebuildIfNecessary' toRebuild (m@(Module _ _ moduleName' _ _) : ms') = do - (_, externsJson) <- readExterns moduleName' - case decode externsJson of - Just externs - | efVersion externs == showVersion Paths.version -> (Left externs :) <$> rebuildIfNecessary' toRebuild ms' - _ -> rebuild toRebuild m moduleName' ms' - - rebuild :: S.Set ModuleName -> Module -> ModuleName -> [Module] -> m [Either ExternsFile Module] - rebuild toRebuild m moduleName ms' = do - let deps = fromMaybe [] $ moduleName `M.lookup` graph - (Right m :) <$> rebuildIfNecessary' (toRebuild `S.union` S.fromList deps) ms' - -reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName] -reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ] where - combine :: (Ord a) => [(a, b)] -> M.Map a [b] - combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst) + -- Sort a list so its elements appear in the same order as in another list. + inOrderOf :: (Ord a) => [a] -> [a] -> [a] + inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys + + buildModule :: [(ModuleName, (C.MVar (Maybe ExternsFile), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m () + buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do + outputTimestamp <- getOutputTimestamp moduleName + dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps + inputTimestamp <- getInputTimestamp moduleName + + let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of + (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2 + (Right (Just t1), Nothing, Just t2) -> t1 > t2 + (Left RebuildNever, _, Just _) -> False + _ -> True + + exts <- if shouldRebuild + then do + mexterns <- sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps + + for mexterns $ \externs -> do + progress $ CompilingModule moduleName + let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs + lint m + ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m] + (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule Nothing desugared + checkExhaustiveModule env' checked + regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated + let mod' = Module ss coms moduleName regrouped exps + corefn = CF.moduleToCoreFn env' mod' + [renamed] = renameInModules [corefn] + exts = moduleToExternsFile mod' env' + evalSupplyT nextVar $ codegen renamed env' $ encode exts + return exts + else do + mexts <- decodeExterns . snd <$> readExterns moduleName + return $ Just $ fromMaybe (error "make: externs files are out of date. Try 'rm output/*/externs.json'.") mexts + + markComplete exts Nothing + where + markComplete :: Maybe ExternsFile -> Maybe MultipleErrors -> m () + markComplete externs errors = do + putMVar (fst $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) externs + putMVar (snd $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) errors + + maximumMaybe :: (Ord a) => [a] -> Maybe a + maximumMaybe [] = Nothing + maximumMaybe xs = Just $ maximum xs + + -- Make sure a dependency exists + shouldExist :: Maybe UTCTime -> UTCTime + shouldExist (Just t) = t + shouldExist _ = error "make: dependency should already have been built." + + decodeExterns :: B.ByteString -> Maybe ExternsFile + decodeExterns bs = do + externs <- decode bs + guard $ efVersion externs == showVersion Paths.version + return externs -- | -- Add an import declaration for a module if it does not already explicitly import it. @@ -231,6 +259,14 @@ importPrim = addDefaultImport (ModuleName [ProperName C.prim]) newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options) +instance MonadBase IO Make where + liftBase = liftIO + +instance MonadBaseControl IO Make where + type StM Make a = Either MultipleErrors (a, MultipleErrors) + liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake) + restoreM = Make . restoreM + -- | -- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings. -- diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 0425a43cad..cc4736b0af 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -23,20 +23,17 @@ import Control.Monad.Error.Class (MonadError(..)) import Data.Graph import Data.List (nub) -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Errors --- | --- A list of modules with their dependencies --- +-- | A list of modules with their transitive dependencies type ModuleGraph = [(ModuleName, [ModuleName])] --- | --- Sort a collection of modules based on module dependencies. +-- | Sort a collection of modules based on module dependencies. -- -- Reports an error if the module graph contains a cycle. -- @@ -44,7 +41,12 @@ sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleG sortModules ms = do let verts = map (\m@(Module _ _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms ms' <- mapM toModule $ stronglyConnComp verts - let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts + let (graph, fromVertex, toVertex) = graphFromEdges verts + moduleGraph = do (_, mn, _) <- verts + let v = fromMaybe (error "sortModules: vertex not found") (toVertex mn) + deps = reachable graph v + toKey i = case fromVertex i of (_, key, _) -> key + return (mn, filter (/= mn) (map toKey deps)) return (ms', moduleGraph) -- | From 46ded7d8f15c3cf2641c36492bacd0b8f564ff4e Mon Sep 17 00:00:00 2001 From: Michael Ficarra Date: Sun, 4 Oct 2015 12:47:23 -0700 Subject: [PATCH 0041/1580] fixes #1502: make `qualified` keyword optional in qualified imports --- examples/passing/OptionalQualified.purs | 13 +++++++++++ .../passing/QualifiedQualifiedImports.purs | 6 +++++ .../PureScript/Parser/Declarations.hs | 23 ++++++++++--------- 3 files changed, 31 insertions(+), 11 deletions(-) create mode 100644 examples/passing/OptionalQualified.purs create mode 100644 examples/passing/QualifiedQualifiedImports.purs diff --git a/examples/passing/OptionalQualified.purs b/examples/passing/OptionalQualified.purs new file mode 100644 index 0000000000..fccfd7ae4b --- /dev/null +++ b/examples/passing/OptionalQualified.purs @@ -0,0 +1,13 @@ +module Main where + +-- qualified import with the "qualified" keyword +import qualified Prelude as P + +-- qualified import without the "qualified" keyword +import Control.Monad.Eff.Console as Console + +bind = P.bind + +main = do + message <- P.return "success!" + Console.log message diff --git a/examples/passing/QualifiedQualifiedImports.purs b/examples/passing/QualifiedQualifiedImports.purs new file mode 100644 index 0000000000..91c188c275 --- /dev/null +++ b/examples/passing/QualifiedQualifiedImports.purs @@ -0,0 +1,6 @@ +module Main where + +-- qualified import with qualified imported names +import qualified Control.Monad.Eff.Console (log) as Console + +main = Console.log "Success!" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 0c8963bd8b..af0eaea850 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -151,24 +151,25 @@ parseImportDeclaration' = do where stdImport = do moduleName' <- moduleName - stdImportHiding moduleName' <|> stdImportQualifying moduleName' + suffixHiding moduleName' <|> suffixQualifyingList moduleName' where - stdImportHiding mn = do + suffixHiding mn = do reserved "hiding" - declType <- importDeclarationType Hiding - return (mn, declType, Nothing) - stdImportQualifying mn = do - declType <- importDeclarationType Explicit + declType <- qualifyingList Hiding return (mn, declType, Nothing) + suffixQualifyingList mn = do + declType <- qualifyingList Explicit + qName <- P.optionMaybe qualifiedName + return (mn, declType, qName) + qualifiedName = reserved "as" *> moduleName qualImport = do reserved "qualified" indented moduleName' <- moduleName - declType <- importDeclarationType Explicit - reserved "as" - asQ <- moduleName - return (moduleName', declType, Just asQ) - importDeclarationType expectedType = do + declType <- qualifyingList Explicit + qName <- qualifiedName + return (moduleName', declType, Just qName) + qualifyingList expectedType = do idents <- P.optionMaybe $ indented *> parens (commaSep parseDeclarationRef) return $ fromMaybe Implicit (expectedType <$> idents) From 132a430d2225c6452462a60f9d5ae20f8f456c65 Mon Sep 17 00:00:00 2001 From: creek Date: Sun, 4 Oct 2015 17:02:16 +0200 Subject: [PATCH 0042/1580] refactoring and cleaning up --- src/Language/PureScript/AST/Exported.hs | 2 +- src/Language/PureScript/Bundle.hs | 2 +- src/Language/PureScript/CodeGen/JS.hs | 3 +- .../CodeGen/JS/Optimizer/Inliner.hs | 2 +- .../PureScript/CodeGen/JS/Optimizer/TCO.hs | 2 +- .../PureScript/CodeGen/JS/Optimizer/Unused.hs | 2 +- src/Language/PureScript/CoreFn/Expr.hs | 2 +- src/Language/PureScript/Docs/Convert.hs | 4 +- src/Language/PureScript/Docs/Render.hs | 5 +- src/Language/PureScript/Docs/Types.hs | 2 +- src/Language/PureScript/Errors.hs | 67 +++++++++---------- .../PureScript/Parser/Declarations.hs | 29 ++++---- src/Language/PureScript/Parser/Kinds.hs | 2 +- src/Language/PureScript/Parser/Lexer.hs | 2 +- src/Language/PureScript/Pretty/JS.hs | 26 +++---- src/Language/PureScript/Publish.hs | 2 +- .../PureScript/Publish/ErrorsWarnings.hs | 29 ++++---- src/Language/PureScript/Renamer.hs | 6 +- src/Language/PureScript/Sugar/DoNotation.hs | 4 +- src/Language/PureScript/Sugar/Names.hs | 2 +- .../PureScript/Sugar/Names/Exports.hs | 5 +- .../PureScript/Sugar/TypeDeclarations.hs | 2 +- .../PureScript/TypeChecker/Entailment.hs | 5 +- src/Language/PureScript/TypeChecker/Types.hs | 2 +- src/Language/PureScript/TypeChecker/Unify.hs | 6 +- src/Language/PureScript/Types.hs | 6 +- 26 files changed, 107 insertions(+), 114 deletions(-) diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index 54f55f4763..a7ad53f5f8 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -66,7 +66,7 @@ filterInstances (Just exps) = -- * the name is defined in a different module (and must be exported from -- that module; the code would fail to compile otherwise). visibleOutside _ (Qualified (Just _) _) = True - visibleOutside refs (Qualified Nothing n) = any (== n) refs + visibleOutside refs (Qualified Nothing n) = n `elem` refs typeName (TypeRef n _) = Just n typeName (PositionedDeclarationRef _ _ r) = typeName r diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index ac9258aecb..64f7cc2ed8 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -385,7 +385,7 @@ isModuleEmpty (Module _ els) = all isElementEmpty els where isElementEmpty :: ModuleElement -> Bool isElementEmpty (ExportsList exps) = null exps - isElementEmpty (Require _ _ _) = True + isElementEmpty Require{} = True isElementEmpty (Other _) = True isElementEmpty _ = False diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 0be08d582f..5db67d5c62 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -27,6 +27,7 @@ module Language.PureScript.CodeGen.JS ) where import Data.List ((\\), delete, intersect) +import Data.Maybe (isNothing) import qualified Data.Traversable as T (traverse) #if __GLASGOW_HASKELL__ < 710 @@ -62,7 +63,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do comments <- not <$> asks optionsNoComments let strict = JSStringLiteral "use strict" let header = if comments && not (null coms) then JSComment coms strict else strict - let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || foreign_ == Nothing] + let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_] let moduleBody = header : foreign' ++ jsImports ++ concat optimized let foreignExps = exps `intersect` (fst `map` foreigns) let standardExps = exps \\ foreignExps diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index 59bbba4725..eeaafe04c8 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -255,7 +255,7 @@ inlineFnComposition = everywhereOnJSTopDownM convert return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]]) convert other = return other isFnCompose :: JS -> JS -> Bool - isFnCompose dict' fn = isDict semigroupoidFn dict' && (isPreludeFn (C.<<<) fn || isPreludeFn (C.compose) fn) + isFnCompose dict' fn = isDict semigroupoidFn dict' && (isPreludeFn (C.<<<) fn || isPreludeFn C.compose fn) isDict :: (String, String) -> JS -> Bool isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs index 52bf06f6e2..3908e5fb49 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs @@ -124,5 +124,5 @@ tco' = everywhereOnJS convert hasFunction :: JS -> Bool hasFunction = getAny . everythingOnJS mappend (Any . isFunction) where - isFunction (JSFunction _ _ _) = True + isFunction JSFunction{} = True isFunction _ = False diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs index 3d748fc2a6..7a3b6d34cf 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs @@ -29,7 +29,7 @@ removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go) where go :: [JS] -> [JS] go jss | not (any isJSReturn jss) = jss - | otherwise = let (body, ret : _) = span (not . isJSReturn) jss in body ++ [ret] + | otherwise = let (body, ret : _) = break isJSReturn jss in body ++ [ret] isJSReturn (JSReturn _) = True isJSReturn _ = False diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index 8d86bf590e..39a1006217 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -101,7 +101,7 @@ data CaseAlternative a = CaseAlternative instance Functor CaseAlternative where fmap f (CaseAlternative cabs car) = CaseAlternative - (fmap (fmap f) $ cabs) + (fmap (fmap f) cabs) (either (Left . fmap (fmap f *** fmap f)) (Right . fmap f) car) -- | diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index b598ddeacc..9adaaf5eea 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -147,7 +147,7 @@ convertDeclaration (P.ExternDataDeclaration _ kind') title = basicDeclaration title (ExternDataDeclaration kind') convertDeclaration (P.TypeSynonymDeclaration _ args ty) title = basicDeclaration title (TypeSynonymDeclaration args ty) -convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = do +convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = Just (Right (mkDeclaration title info) { declChildren = children }) where info = TypeClassDeclaration args implies @@ -158,7 +158,7 @@ convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = do ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty) convertClassMember _ = error "Invalid argument to convertClassMember." -convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = do +convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = Just (Left (classNameString : typeNameStrings, AugmentChild childDecl)) where classNameString = unQual className diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 29b9b06f63..ec290be9dc 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -10,6 +10,7 @@ module Language.PureScript.Docs.Render where +import Data.Maybe (maybeToList) import Data.Monoid ((<>)) import qualified Language.PureScript as P @@ -46,7 +47,7 @@ renderDeclarationWithOptions opts Declaration{..} = ] TypeClassDeclaration args implies -> [ keywordClass ] - ++ maybe [] (:[]) superclasses + ++ maybeToList superclasses ++ [renderType' (typeApp declTitle args)] ++ if any (isTypeClassMember . cdeclInfo) declChildren then [keywordWhere] @@ -75,7 +76,7 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} = [ keywordInstance , ident cdeclTitle , syntax "::" - ] ++ maybe [] (:[]) (renderConstraints constraints) + ] ++ maybeToList (renderConstraints constraints) ++ [ renderType' ty ] ChildDataConstructor args -> [ renderType' typeApp' ] diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 61fba63ae4..131f0a11be 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -425,7 +425,7 @@ asSourceSpan = P.SourceSpan <$> key "name" asString instance A.ToJSON a => A.ToJSON (Package a) where toJSON Package{..} = - A.object $ + A.object [ "packageMeta" .= pkgMeta , "version" .= showVersion pkgVersion , "versionTag" .= pkgVersionTag diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 0261434b87..ec408ca3f8 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -20,7 +20,7 @@ module Language.PureScript.Errors where import Data.Either (lefts, rights) -import Data.List (intercalate, transpose) +import Data.List (intercalate, transpose, nub) import Data.Function (on) #if __GLASGOW_HASKELL__ < 710 import Data.Foldable (fold, foldMap) @@ -52,7 +52,6 @@ import qualified Text.PrettyPrint.Boxes as Box import qualified Text.Parsec as P import qualified Text.Parsec.Error as PE import Text.Parsec.Error (Message(..)) -import Data.List (nub) -- | -- A type of error messages @@ -366,33 +365,33 @@ replaceUnknowns = everywhereOnTypesM replaceTypes onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage onTypesInErrorMessageM f = g where - gSimple (InfiniteType t) = InfiniteType <$> (f t) - gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> (f t1) <*> (f t2) - gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> (f t1) <*> (f t2) - gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> (f t) - gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> (f t) - gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> (pure e) + gSimple (InfiniteType t) = InfiniteType <$> f t + gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2 + gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2 + gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t + gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> f t + gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t gSimple other = pure other - g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> (f t1) <*> (f t2) <*> (g em) - g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> (f t1) <*> (f t2) <*> (g e) - g (ErrorCheckingType e t em) = ErrorCheckingType e <$> (f t) <*> (g em) - g (ErrorCheckingKind t em) = ErrorCheckingKind <$> (f t) <*> g em - g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> (f t1) <*> (pure e2) <*> (g em) - g (NotYetDefined x e) = NotYetDefined x <$> (g e) - g (ErrorInExpression x e) = ErrorInExpression x <$> (g e) - g (ErrorInModule x e) = ErrorInModule x <$> (g e) - g (ErrorInInstance x y e) = ErrorInInstance x y <$> (g e) - g (ErrorInferringType x e) = ErrorInferringType x <$> (g e) - g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> (g e) - g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> (g e) - g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> (g e) - g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> (g e) - g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> (g e) - g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> (g e) - g (ErrorInTypeDeclaration x e) = ErrorInTypeDeclaration x <$> (g e) - g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> (g e) - g (PositionedError x e) = PositionedError x <$> (g e) + g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> f t1 <*> f t2 <*> g em + g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> f t1 <*> f t2 <*> g e + g (ErrorCheckingType e t em) = ErrorCheckingType e <$> f t <*> g em + g (ErrorCheckingKind t em) = ErrorCheckingKind <$> f t <*> g em + g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> f t1 <*> pure e2 <*> g em + g (NotYetDefined x e) = NotYetDefined x <$> g e + g (ErrorInExpression x e) = ErrorInExpression x <$> g e + g (ErrorInModule x e) = ErrorInModule x <$> g e + g (ErrorInInstance x y e) = ErrorInInstance x y <$> g e + g (ErrorInferringType x e) = ErrorInferringType x <$> g e + g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> g e + g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> g e + g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> g e + g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> g e + g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> g e + g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> g e + g (ErrorInTypeDeclaration x e) = ErrorInTypeDeclaration x <$> g e + g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> g e + g (PositionedError x e) = PositionedError x <$> g e g (SimpleErrorWrapper sem) = SimpleErrorWrapper <$> gSimple sem -- | @@ -738,7 +737,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , go err ] go (ErrorInDataBindingGroup err) = - paras [ lineWithLevel $ "in data binding group:" + paras [ lineWithLevel "in data binding group:" , go err ] go (ErrorInTypeSynonym name err) = @@ -857,7 +856,7 @@ prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do , result ] prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do - result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full level + result <- forM es $ liftM (Box.moveRight 2) . prettyPrintSingleError full level return $ Box.vcat Box.left [ Box.text intro , Box.vsep 1 Box.left result @@ -865,7 +864,7 @@ prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do -- | Pretty print a Parsec ParseError as a Box prettyPrintParseError :: P.ParseError -> Box.Box -prettyPrintParseError = (prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input") . PE.errorMessages +prettyPrintParseError = prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . PE.errorMessages -- | -- Pretty print ParseError detail messages. @@ -878,9 +877,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd | otherwise = Box.vcat Box.left $ map Box.text $ clean [showSysUnExpect,showUnExpect,showExpect,showMessages] where - (sysUnExpect,msgs1) = span ((SysUnExpect "") ==) msgs - (unExpect,msgs2) = span ((UnExpect "") ==) msgs1 - (expect,messages) = span ((Expect "") ==) msgs2 + (sysUnExpect,msgs1) = span (SysUnExpect "" ==) msgs + (unExpect,msgs2) = span (UnExpect "" ==) msgs1 + (expect,messages) = span (Expect "" ==) msgs2 showExpect = showMany msgExpecting expect showUnExpect = showMany msgUnExpected unExpect @@ -928,7 +927,7 @@ renderBox = unlines . map trimEnd . lines . Box.render interpretMultipleErrorsAndWarnings :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => (Either MultipleErrors a, MultipleErrors) -> m a interpretMultipleErrorsAndWarnings (err, ws) = do tell ws - either throwError return $ err + either throwError return err -- | -- Rethrow an error with a more detailed error message in the case of failure diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 0c8963bd8b..be8d54b851 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -175,9 +175,9 @@ parseImportDeclaration' = do parseDeclarationRef :: TokenParser DeclarationRef parseDeclarationRef = - parseModuleRef <|> ( - withSourceSpan PositionedDeclarationRef $ - ValueRef <$> parseIdent + parseModuleRef <|> + withSourceSpan PositionedDeclarationRef + (ValueRef <$> parseIdent <|> do name <- properName dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName) return $ maybe (TypeClassRef name) (TypeRef name) dctors @@ -203,8 +203,8 @@ parseTypeClassDeclaration = do mark (P.many (same *> positioned parseTypeDeclaration)) return $ TypeClassDeclaration className idents implies members -parseTypeInstanceDeclaration :: TokenParser Declaration -parseTypeInstanceDeclaration = do +parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) +parseInstanceDeclaration = do reserved "instance" name <- parseIdent <* indented <* doubleColon deps <- P.optionMaybe $ do @@ -214,24 +214,21 @@ parseTypeInstanceDeclaration = do return deps className <- indented *> parseQualified properName ty <- P.many (indented *> noWildcards parseTypeAtom) + return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty + +parseTypeInstanceDeclaration :: TokenParser Declaration +parseTypeInstanceDeclaration = do + instanceDecl <- parseInstanceDeclaration members <- P.option [] . P.try $ do indented *> reserved "where" mark (P.many (same *> positioned parseValueDeclaration)) - return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty (ExplicitInstance members) + return $ instanceDecl (ExplicitInstance members) parseDerivingInstanceDeclaration :: TokenParser Declaration parseDerivingInstanceDeclaration = do reserved "derive" - reserved "instance" - name <- parseIdent <* indented <* doubleColon - deps <- P.optionMaybe $ do - deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom))) - indented - rfatArrow - return deps - className <- indented *> parseQualified properName - ty <- P.many (indented *> noWildcards parseTypeAtom) - return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty DerivedInstance + instanceDecl <- parseInstanceDeclaration + return $ instanceDecl DerivedInstance positioned :: TokenParser Declaration -> TokenParser Declaration positioned = withSourceSpan PositionedDeclaration diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs index 9773b42565..f45473c55c 100644 --- a/src/Language/PureScript/Parser/Kinds.hs +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -46,4 +46,4 @@ parseKind :: TokenParser Kind parseKind = P.buildExpressionParser operators parseTypeAtom P. "kind" where operators = [ [ P.Prefix (symbol' "#" >> return Row) ] - , [ P.Infix ((P.try rarrow) >> return FunKind) P.AssocRight ] ] + , [ P.Infix (P.try rarrow >> return FunKind) P.AssocRight ] ] diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index e57288ea22..a4a285747a 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -479,7 +479,7 @@ identifier = token go P. "identifier" go _ = Nothing validModuleName :: String -> Bool -validModuleName s = not ('_' `elem` s) +validModuleName s = '_' `notElem` s -- | -- A list of purescript reserved identifiers diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 6fcf1cc86d..22a17ab812 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -45,13 +45,13 @@ literals = mkPattern' match match (JSStringLiteral s) = return $ string s match (JSBooleanLiteral True) = return "true" match (JSBooleanLiteral False) = return "false" - match (JSArrayLiteral xs) = fmap concat $ sequence + match (JSArrayLiteral xs) = concat <$> sequence [ return "[ " - , fmap (intercalate ", ") $ forM xs prettyPrintJS' + , intercalate ", " <$> forM xs prettyPrintJS' , return " ]" ] match (JSObjectLiteral []) = return "{}" - match (JSObjectLiteral ps) = fmap concat $ sequence + match (JSObjectLiteral ps) = concat <$> sequence [ return "{\n" , withIndent $ do jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value @@ -65,7 +65,7 @@ literals = mkPattern' match objectPropertyToString :: String -> String objectPropertyToString s | identNeedsEscaping s = show s | otherwise = s - match (JSBlock sts) = fmap concat $ sequence + match (JSBlock sts) = concat <$> sequence [ return "{\n" , withIndent $ prettyStatements sts , return "\n" @@ -73,23 +73,23 @@ literals = mkPattern' match , return "}" ] match (JSVar ident) = return ident - match (JSVariableIntroduction ident value) = fmap concat $ sequence + match (JSVariableIntroduction ident value) = concat <$> sequence [ return "var " , return ident , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value ] - match (JSAssignment target value) = fmap concat $ sequence + match (JSAssignment target value) = concat <$> sequence [ prettyPrintJS' target , return " = " , prettyPrintJS' value ] - match (JSWhile cond sts) = fmap concat $ sequence + match (JSWhile cond sts) = concat <$> sequence [ return "while (" , prettyPrintJS' cond , return ") " , prettyPrintJS' sts ] - match (JSFor ident start end sts) = fmap concat $ sequence + match (JSFor ident start end sts) = concat <$> sequence [ return $ "for (var " ++ ident ++ " = " , prettyPrintJS' start , return $ "; " ++ ident ++ " < " @@ -97,30 +97,30 @@ literals = mkPattern' match , return $ "; " ++ ident ++ "++) " , prettyPrintJS' sts ] - match (JSForIn ident obj sts) = fmap concat $ sequence + match (JSForIn ident obj sts) = concat <$> sequence [ return $ "for (var " ++ ident ++ " in " , prettyPrintJS' obj , return ") " , prettyPrintJS' sts ] - match (JSIfElse cond thens elses) = fmap concat $ sequence + match (JSIfElse cond thens elses) = concat <$> sequence [ return "if (" , prettyPrintJS' cond , return ") " , prettyPrintJS' thens , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses ] - match (JSReturn value) = fmap concat $ sequence + match (JSReturn value) = concat <$> sequence [ return "return " , prettyPrintJS' value ] - match (JSThrow value) = fmap concat $ sequence + match (JSThrow value) = concat <$> sequence [ return "throw " , prettyPrintJS' value ] match (JSBreak lbl) = return $ "break " ++ lbl match (JSContinue lbl) = return $ "continue " ++ lbl - match (JSLabel lbl js) = fmap concat $ sequence + match (JSLabel lbl js) = concat <$> sequence [ return $ lbl ++ ": " , prettyPrintJS' js ] diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 7cd8316a77..e80c9647a6 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -153,7 +153,7 @@ getGitWorkingTreeStatus :: PrepareM TreeStatus getGitWorkingTreeStatus = do out <- readProcess' "git" ["status", "--porcelain"] "" return $ - if null . filter (not . null) . lines $ out + if all null . lines $ out then Clean else Dirty diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 9abcb27199..72244383fe 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -98,10 +98,10 @@ renderError err = case err of UserError e -> vcat - [ para (concat - [ "There is a problem with your package, which meant that " - , "it could not be published." - ]) + [ para ( + "There is a problem with your package, which meant that " ++ + "it could not be published." + ) , para "Details:" , indented (displayUserError e) ] @@ -123,10 +123,10 @@ renderError err = displayUserError :: UserError -> Box displayUserError e = case e of BowerJSONNotFound -> - para (concat - [ "The bower.json file was not found. Please create one, or run " - , "`pulp init`." - ]) + para ( + "The bower.json file was not found. Please create one, or run " ++ + "`pulp init`." + ) BowerExecutableNotFound names -> para (concat [ "The Bower executable was not found (tried: ", format names, "). Please" @@ -217,10 +217,10 @@ displayUserError e = case e of , indented (P.prettyPrintMultipleErrorsBox False err) ] DirtyWorkingTree -> - para (concat - [ "Your git working tree is dirty. Please commit, discard, or stash " - , "your changes first." - ]) + para ( + "Your git working tree is dirty. Please commit, discard, or stash " ++ + "your changes first." + ) displayRepositoryError :: RepositoryFieldError -> Box displayRepositoryError err = case err of @@ -356,12 +356,11 @@ warnUndeclaredDependencies pkgNames = are = pl "are" "is" dependencies = pl "dependencies" "a dependency" in vcat $ - [ para (concat + para (concat [ "The following Bower ", packages, " ", are, " installed, but not " , "declared as ", dependencies, " in your bower.json file:" ]) - ] ++ - bulletedList runPackageName (NonEmpty.toList pkgNames) + : bulletedList runPackageName (NonEmpty.toList pkgNames) warnUnacceptableVersions :: NonEmpty (PackageName, String) -> Box warnUnacceptableVersions pkgs = diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index 6d67d8a170..ab20854016 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -80,12 +80,12 @@ updateScope :: Ident -> Rename Ident updateScope i@(Ident name) | name == C.__unused = return i updateScope name = do scope <- get - name' <- case name `S.member` rsUsedNames scope of - True -> do + name' <- if name `S.member` rsUsedNames scope + then do let newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ] Just newName = find (`S.notMember` rsUsedNames scope) newNames return newName - False -> return name + else return name modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s) , rsUsedNames = S.insert name' (rsUsedNames s) } diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 17da9d3ac2..be86c202c7 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -42,13 +42,13 @@ desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError MultipleE desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarDo <*> pure exts desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration -desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d) +desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> rethrowWithPosition pos (desugarDo d) desugarDo d = let (f, _, _) = everywhereOnValuesM return replace return in f d where bind :: Expr - bind = Var (Qualified Nothing (Ident (C.bind))) + bind = Var (Qualified Nothing (Ident C.bind)) replace :: Expr -> m Expr replace (Do els) = go els diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index cd4c97630c..8135db9688 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -132,7 +132,7 @@ elaborateImports imps (Module ss coms mn decls exps) = Module ss coms mn decls' let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const []) in mkImport `map` nub (f `concatMap` decls) ++ decls fqValues :: Expr -> [ModuleName] - fqValues (Var (Qualified (Just mn') _)) | notElem mn' (importedModules imps) = [mn'] + fqValues (Var (Qualified (Just mn') _)) | mn' `notElem` importedModules imps = [mn'] fqValues _ = [] mkImport :: ModuleName -> Declaration mkImport mn' = ImportDeclaration mn' (Explicit []) Nothing diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 2c0f87cf65..14a443207d 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -205,9 +205,8 @@ filterModule mn exps refs = do -- the data constructor to check. checkDcon :: ProperName -> [ProperName] -> ProperName -> m () checkDcon tcon exps' name = - if name `elem` exps' - then return () - else throwError . errorMessage $ UnknownExportDataConstructor tcon name + unless (name `elem` exps') $ + throwError . errorMessage $ UnknownExportDataConstructor tcon name -- Takes a list of all the exportable classes, the accumulated list of -- filtered exports, and a `DeclarationRef` for an explicit export. When the diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 1ed4231ef9..7a1667f010 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -59,7 +59,7 @@ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d' return (ident, nameKind, PositionedValue pos com val) fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name -desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError . errorMessage $ OrphanTypeDeclaration name +desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do let (_, f, _) = everywhereOnValuesTopDownM return go return f' (Left gs) = Left <$> mapM (pairM return f) gs diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index ac430853a1..3cd0223f3c 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -13,7 +13,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} module Language.PureScript.TypeChecker.Entailment ( @@ -160,14 +159,14 @@ typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynon Left _ -> Nothing Right t1 -> typeHeadsAreEqual m e t1 t2 typeHeadsAreEqual _ _ REmpty REmpty = Just [] -typeHeadsAreEqual m e r1@(RCons _ _ _) r2@(RCons _ _ _) = +typeHeadsAreEqual m e r1@RCons{} r2@RCons{} = let (s1, r1') = rowToList r1 (s2, r2') = rowToList r2 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] - in (++) <$> foldMap (\(t1, t2) -> typeHeadsAreEqual m e t1 t2) int + in (++) <$> foldMap (uncurry (typeHeadsAreEqual m e)) int <*> go sd1 r1' sd2 r2' where go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)] diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index cbca0cfa2f..3356f7f6b2 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -419,7 +419,7 @@ binderRequiresMonotype _ = True -- | Instantiate polytypes only when necessitated by a binder. instantiateForBinders :: [Expr] -> [CaseAlternative] -> UnifyT Type Check ([Expr], [Type]) -instantiateForBinders vals cas = fmap unzip $ zipWithM (\val inst -> do +instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do TypedValue _ val' ty <- infer val if inst then instantiatePolyTypeWithUnknowns val' ty diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 28e7431a64..1e55f3aa74 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -133,7 +133,7 @@ unifyRows r1 r2 = u1 =:= rowFromList (sd2, rest) u2 =:= rowFromList (sd1, rest) unifyRows' sd1 (SaturatedTypeSynonym name args) sd2 r2' = do - r1' <- expandTypeSynonym name $ args + r1' <- expandTypeSynonym name args unifyRows (rowFromList (sd1, r1')) (rowFromList (sd2, r2')) unifyRows' sd1 r1' sd2 r2'@(SaturatedTypeSynonym _ _) = unifyRows' sd2 r2' sd1 r1' unifyRows' [] REmpty [] REmpty = return () @@ -156,14 +156,14 @@ unifiesWith e (SaturatedTypeSynonym name args) t2 = Right t1 -> unifiesWith e t1 t2 unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1 unifiesWith _ REmpty REmpty = True -unifiesWith e r1@(RCons _ _ _) r2@(RCons _ _ _) = +unifiesWith e r1@RCons{} r2@RCons{} = let (s1, r1') = rowToList r1 (s2, r2') = rowToList r2 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] - in all (\(t1, t2) -> unifiesWith e t1 t2) int && go sd1 r1' sd2 r2' + in all (uncurry (unifiesWith e)) int && go sd1 r1' sd2 r2' where go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool go [] REmpty [] REmpty = True diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 4d35699e52..d662e83d30 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -22,6 +22,7 @@ module Language.PureScript.Types where import Data.Data import Data.List (nub) +import Data.Maybe (fromMaybe) import qualified Data.Aeson as A import qualified Data.Aeson.TH as A @@ -156,10 +157,7 @@ replaceAllTypeVars = go [] where go :: [String] -> [(String, Type)] -> Type -> Type - go _ m (TypeVar v) = - case v `lookup` m of - Just r -> r - Nothing -> TypeVar v + go _ m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m) go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2) go bs m (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs m) ts go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f From 0c35b83dd6b123516440c352eba68d825be6bc8c Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 7 Oct 2015 20:49:16 -0700 Subject: [PATCH 0043/1580] Use boxes library to print types and values. --- src/Language/PureScript/Errors.hs | 147 +++++++++----- src/Language/PureScript/Names.hs | 4 + src/Language/PureScript/Pretty/Common.hs | 11 + src/Language/PureScript/Pretty/Kinds.hs | 34 ++-- src/Language/PureScript/Pretty/Types.hs | 91 +++++---- src/Language/PureScript/Pretty/Values.hs | 243 +++++++++-------------- 6 files changed, 273 insertions(+), 257 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index ec408ca3f8..fa336517d6 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -427,7 +427,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError ] goSimple (ErrorParsingExterns err) = paras [ lineWithLevel "parsing externs files: " - , indent . prettyPrintParseError $ err + , prettyPrintParseError err ] goSimple (ErrorParsingFFIModule path) = paras [ line "Unable to parse module from FFI file: " @@ -435,7 +435,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError ] goSimple (ErrorParsingModule err) = paras [ line "Unable to parse module: " - , indent . prettyPrintParseError $ err + , prettyPrintParseError err ] goSimple (MissingFFIModule mn) = line $ "Missing FFI implementations for module " ++ runModuleName mn @@ -444,8 +444,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , indent . line $ path ] goSimple (MultipleFFIModules mn paths) = - paras $ [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": " ] - ++ map (indent . line) paths + paras [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": " + , indent . paras $ map line paths + ] goSimple (InvalidExternsFile path) = paras [ line "Externs file is invalid: " , indent . line $ path @@ -462,11 +463,11 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError line "Overlapping names in let binding." goSimple (InfiniteType ty) = paras [ line "An infinite type was inferred for an expression: " - , indent $ line $ prettyPrintType ty + , indent $ typeAsBox ty ] goSimple (InfiniteKind ki) = paras [ line "An infinite kind was inferred for a type: " - , indent $ line $ prettyPrintKind ki + , indent $ kindAsBox ki ] goSimple (MultipleFixities name) = line $ "Multiple fixity declarations for " ++ showIdent name @@ -475,8 +476,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError goSimple (OrphanFixityDeclaration op) = line $ "Orphan fixity declaration for " ++ show op goSimple (RedefinedModule name filenames) = - paras $ line ("Module " ++ runModuleName name ++ " has been defined multiple times:") - : map (indent . line . displaySourceSpan) filenames + paras [ line ("Module " ++ runModuleName name ++ " has been defined multiple times:") + , indent . paras $ map (line . displaySourceSpan) filenames + ] goSimple (RedefinedIdent name) = line $ "Name " ++ showIdent name ++ " has been defined multiple times" goSimple (UnknownModule mn) = @@ -548,43 +550,60 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError goSimple (EscapedSkolem binding) = paras $ [ line "A type variable has escaped its scope." ] <> foldMap (\expr -> [ line "Relevant expression: " - , indent $ line $ prettyPrintValue expr + , indent $ prettyPrintValue expr ]) binding goSimple (TypesDoNotUnify t1 t2) = paras [ line "Cannot unify type" - , indent $ line $ prettyPrintType t1 + , indent $ typeAsBox t1 , line "with type" - , indent $ line $ prettyPrintType t2 + , indent $ typeAsBox t2 ] goSimple (KindsDoNotUnify k1 k2) = paras [ line "Cannot unify kind" - , indent $ line $ prettyPrintKind k1 + , indent $ kindAsBox k1 , line "with kind" - , indent $ line $ prettyPrintKind k2 + , indent $ kindAsBox k2 ] goSimple (ConstrainedTypeUnified t1 t2) = paras [ line "Cannot unify constrained type" - , indent $ line $ prettyPrintType t1 + , indent $ typeAsBox t1 , line "with type" - , indent $ line $ prettyPrintType t2 + , indent $ typeAsBox t2 ] goSimple (OverlappingInstances nm ts (d : ds)) = - paras [ line $ "Overlapping instances found for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":" + paras [ line "Overlapping instances found for" + , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] + , line "The following instances were found:" , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds) ] goSimple OverlappingInstances{} = error "OverlappingInstances: empty instance list" goSimple (NoInstanceFound nm ts) = - line $ "No instance found for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) + paras [ line "No instance found for" + , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] + ] goSimple (PossiblyInfiniteInstance nm ts) = - line $ "Instance for " ++ showQualified runProperName nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is possibly infinite." + paras [ line "Instance for" + , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] + , line "is possibly infinite." + ] goSimple (CannotDerive nm ts) = - line $ "Cannot derive " ++ showQualified runProperName nm ++ " instance for " ++ unwords (map prettyPrintTypeAtom ts) + paras [ line "Cannot derive an instance for" + , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] + ] goSimple (CannotFindDerivingType nm) = line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found." goSimple (DuplicateLabel l expr) = paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ] <> foldMap (\expr' -> [ line "Relevant expression: " - , indent $ line $ prettyPrintValue expr' + , indent $ prettyPrintValue expr' ]) expr goSimple (DuplicateTypeArgument name) = line $ "Duplicate type argument " ++ show name @@ -600,29 +619,40 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated" goSimple (ExpectedType ty kind) = paras [ line "In a type-annotated expression x :: t, the type t must have kind *." - , line $ "The error arises from the type " ++ prettyPrintType ty ++ " having the kind " ++ prettyPrintKind kind ++ " instead." + , line "The error arises from the type" + , indent $ typeAsBox ty + , line "having the kind" + , indent $ kindAsBox kind + , line "instead." ] goSimple (IncorrectConstructorArity nm) = line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm goSimple SubsumptionCheckFailed = line "Unable to check type subsumption" goSimple (ExprDoesNotHaveType expr ty) = paras [ line "Expression" - , indent $ line $ prettyPrintValue expr + , indent $ prettyPrintValue expr , line "does not have type" - , indent $ line $ prettyPrintType ty + , indent $ typeAsBox ty ] goSimple (PropertyIsMissing prop row) = - line $ "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop + paras [ line "Row" + , indent $ prettyPrintRowWith '(' ')' row + , line $ "lacks required property " ++ show prop + ] goSimple (CannotApplyFunction fn arg) = paras [ line "Cannot apply function of type" - , indent $ line $ prettyPrintType fn + , indent $ typeAsBox fn , line "to argument" - , indent $ line $ prettyPrintValue arg + , indent $ prettyPrintValue arg ] goSimple TypeSynonymInstance = line "Type synonym instances are disallowed" goSimple (OrphanInstance nm cnm ts) = - paras [ line $ "Instance " ++ showIdent nm ++ " for " ++ showQualified runProperName cnm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is an orphan instance." + paras [ line $ "Instance " ++ showIdent nm ++ " for " + , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] + , line "is an orphan instance." , line "An orphan instance is an instance which is defined in neither the class module nor the data type module." , line "Consider moving the instance, if possible, or using a newtype wrapper." ] @@ -630,7 +660,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError line "Newtypes must define a single constructor with a single argument" goSimple (InvalidInstanceHead ty) = paras [ line "Invalid type in class instance head:" - , indent $ line $ prettyPrintType ty + , indent $ typeAsBox ty ] goSimple (TransitiveExportError x ys) = paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ") @@ -643,15 +673,17 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError line $ "Type variable '" ++ tv ++ "' was declared but not used" goSimple (ClassOperator className opName) = paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "." - , indent $ line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:" - , indent $ line $ showIdent opName ++ " = someMember" + , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:" + , indent . line $ showIdent opName ++ " = someMember" ] goSimple (MisleadingEmptyTypeImport mn name) = line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors" goSimple (ImportHidingModule name) = line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted" goSimple (WildcardInferredType ty) = - line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty + paras [ line "The wildcard type definition has the inferred type " + , indent $ typeAsBox ty + ] goSimple (NotExhaustivePattern bs b) = paras $ [ line "A case expression could not be determined to cover all inputs." , line "The following additional cases are required to cover all inputs:\n" @@ -669,18 +701,18 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError ] go (NotYetDefined names err) = paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":" - , indent $ go err + , go err ] go (ErrorUnifyingTypes t1 t2 err) = paras [ lineWithLevel "unifying type " - , indent $ line $ prettyPrintType t1 + , indent $ typeAsBox t1 , line "with type" - , indent $ line $ prettyPrintType t2 + , indent $ typeAsBox t2 , go err ] go (ErrorInExpression expr err) = paras [ lineWithLevel "in expression:" - , indent $ line $ prettyPrintValue expr + , indent $ prettyPrintValue expr , go err ] go (ErrorInModule mn err) = @@ -689,39 +721,42 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError ] go (ErrorInSubsumption t1 t2 err) = paras [ lineWithLevel "checking that type " - , indent $ line $ prettyPrintType t1 + , indent $ typeAsBox t1 , line "subsumes type" - , indent $ line $ prettyPrintType t2 + , indent $ typeAsBox t2 , go err ] - go (ErrorInInstance name ts err) = - paras [ lineWithLevel $ "in type class instance " ++ showQualified runProperName name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":" + go (ErrorInInstance nm ts err) = + paras [ lineWithLevel "in type class instance" + , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] , go err ] go (ErrorCheckingKind ty err) = paras [ lineWithLevel "checking kind of type " - , indent $ line $ prettyPrintType ty + , indent $ typeAsBox ty , go err ] go (ErrorInferringType expr err) = paras [ lineWithLevel "inferring type of value " - , indent $ line $ prettyPrintValue expr + , indent $ prettyPrintValue expr , go err ] go (ErrorCheckingType expr ty err) = paras [ lineWithLevel "checking that value " - , indent $ line $ prettyPrintValue expr + , indent $ prettyPrintValue expr , line "has type" - , indent $ line $ prettyPrintType ty + , indent $ typeAsBox ty , go err ] go (ErrorInApplication f t a err) = paras [ lineWithLevel "applying function" - , indent $ line $ prettyPrintValue f + , indent $ prettyPrintValue f , line "of type" - , indent $ line $ prettyPrintType t + , indent $ typeAsBox t , line "to argument" - , indent $ line $ prettyPrintValue a + , indent $ prettyPrintValue a , go err ] go (ErrorInDataConstructor nm err) = @@ -758,7 +793,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError ] go (PositionedError srcSpan err) = paras [ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":" - , indent $ go err + , go err ] go (SimpleErrorWrapper sem) = goSimple sem @@ -842,11 +877,11 @@ prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox fu -- | Pretty print warnings as a Box prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box -prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Multiple warnings found:" full +prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full -- | Pretty print errors as a Box prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box -prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Multiple errors found:" full +prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do @@ -856,11 +891,12 @@ prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do , result ] prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do - result <- forM es $ liftM (Box.moveRight 2) . prettyPrintSingleError full level - return $ - Box.vcat Box.left [ Box.text intro - , Box.vsep 1 Box.left result - ] + result <- forM es $ prettyPrintSingleError full level + return $ Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result + where + withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":") + , Box.moveRight 2 err + ] -- | Pretty print a Parsec ParseError as a Box prettyPrintParseError :: P.ParseError -> Box.Box @@ -910,8 +946,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd clean = nub . filter (not . null) +-- | Indent to the right, and pad on top and bottom. indent :: Box.Box -> Box.Box -indent = Box.moveRight 2 +indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2 line :: String -> Box.Box line = Box.text diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index ae09708100..1b003d25eb 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -104,6 +104,10 @@ qualify _ (Qualified (Just m) a) = (m, a) mkQualified :: a -> ModuleName -> Qualified a mkQualified name mn = Qualified (Just mn) name +-- | Remove the module name from a qualified name +disqualify :: Qualified a -> a +disqualify (Qualified _ a) = a + -- | -- Checks whether a qualified value is actually qualified with a module reference -- diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 75c278ded0..ce6fc33d33 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -17,8 +17,11 @@ module Language.PureScript.Pretty.Common where import Control.Monad.State import Data.List (intercalate) + import Language.PureScript.Parser.Lexer (reservedPsNames, opChars) +import Text.PrettyPrint.Boxes + -- | -- Wrap a string in parentheses -- @@ -67,3 +70,11 @@ prettyPrintObjectKey :: String -> String prettyPrintObjectKey s | s `elem` reservedPsNames = show s | any (`elem` opChars) s = show s | otherwise = s + +-- | Place a box before another, vertically when the first box takes up multiple lines. +before :: Box -> Box -> Box +before b1 b2 | rows b1 > 1 = b1 // b2 + | otherwise = b1 <> b2 + +beforeWithSpace :: Box -> Box -> Box +beforeWithSpace b1 = before (b1 <> text " ") diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs index 53f8f82491..57c3d6fb9d 100644 --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -14,7 +14,8 @@ ----------------------------------------------------------------------------- module Language.PureScript.Pretty.Kinds ( - prettyPrintKind + prettyPrintKind, + kindAsBox ) where import Data.Maybe (fromMaybe) @@ -23,14 +24,15 @@ import Control.Arrow (ArrowPlus(..)) import Control.PatternArrows import Language.PureScript.Kinds -import Language.PureScript.Pretty.Common -typeLiterals :: Pattern () Kind String +import Text.PrettyPrint.Boxes (Box(), text, render, (<>)) + +typeLiterals :: Pattern () Kind Box typeLiterals = mkPattern match where - match Star = Just "*" - match Bang = Just "!" - match (KUnknown u) = Just $ 'u' : show u + match Star = Just $ text "*" + match Bang = Just $ text "!" + match (KUnknown u) = Just $ text $ 'u' : show u match _ = Nothing matchRow :: Pattern () Kind ((), Kind) @@ -45,15 +47,17 @@ funKind = mkPattern match match (FunKind arg ret) = Just (arg, ret) match _ = Nothing --- | --- Generate a pretty-printed string representing a Kind --- +-- | Generate a pretty-printed string representing a Kind prettyPrintKind :: Kind -> String -prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind () +prettyPrintKind = render . kindAsBox + +kindAsBox :: Kind -> Box +kindAsBox = fromMaybe (error "Incomplete pattern") . pattern matchKind () where - matchKind :: Pattern () Kind String - matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind) - operators :: OperatorTable () Kind String + matchKind :: Pattern () Kind Box + matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap ((text "(" <>) . (<> text ")")) matchKind) + + operators :: OperatorTable () Kind Box operators = - OperatorTable [ [ Wrap matchRow $ \_ k -> "# " ++ k] - , [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ] + OperatorTable [ [ Wrap matchRow $ \_ k -> text "# " <> k] + , [ AssocR funKind $ \arg ret -> arg <> text " -> " <> ret ] ] diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index ede0d11ce2..c7af21904c 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -14,13 +14,15 @@ ----------------------------------------------------------------------------- module Language.PureScript.Pretty.Types ( + typeAsBox, prettyPrintType, + typeAtomAsBox, prettyPrintTypeAtom, + prettyPrintRowWith, prettyPrintRow ) where import Data.Maybe (fromMaybe) -import Data.List (intercalate) import Control.Arrow ((<+>)) import Control.PatternArrows @@ -32,36 +34,54 @@ import Language.PureScript.Pretty.Common import Language.PureScript.Pretty.Kinds import Language.PureScript.Environment -typeLiterals :: Pattern () Type String +import Text.PrettyPrint.Boxes hiding ((<+>)) + +typeLiterals :: Pattern () Type Box typeLiterals = mkPattern match where - match TypeWildcard = Just "_" - match (TypeVar var) = Just var - match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }" - match (TypeConstructor ctor) = Just $ showQualified runProperName ctor - match (TUnknown u) = Just $ '_' : show u - match (Skolem name s _) = Just $ name ++ show s - match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> showQualified runProperName pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty - match (SaturatedTypeSynonym name args) = Just $ showQualified runProperName name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">" - match REmpty = Just "()" - match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")" + match TypeWildcard = Just $ text "_" + match (TypeVar var) = Just $ text var + match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row + match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor + match (TUnknown u) = Just $ text $ '_' : show u + match (Skolem name s _) = Just $ text $ name ++ show s + match (ConstrainedType deps ty) = Just $ constraintsAsBox deps `before` (text ") => " <> typeAsBox ty) + match REmpty = Just $ text "()" + match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row match _ = Nothing +constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box +constraintsAsBox = vcat left . zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] + where + constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys) + -- | -- Generate a pretty-printed string representing a Row -- -prettyPrintRow :: Type -> String -prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList [] +prettyPrintRowWith :: Char -> Char -> Type -> Box +prettyPrintRowWith open close = uncurry listToBox . toList [] where - nameAndTypeToPs :: String -> Type -> String - nameAndTypeToPs name ty = prettyPrintObjectKey name ++ " :: " ++ prettyPrintType ty - tailToPs :: Type -> String - tailToPs REmpty = "" - tailToPs other = " | " ++ prettyPrintType other + nameAndTypeToPs :: Char -> String -> Type -> Box + nameAndTypeToPs start name ty = text (start : ' ' : prettyPrintObjectKey name ++ " :: ") <> typeAsBox ty + + tailToPs :: Type -> Box + tailToPs REmpty = nullBox + tailToPs other = text "| " <> typeAsBox other + + listToBox :: [(String, Type)] -> Type -> Box + listToBox [] REmpty = text [open, close] + listToBox [] rest = text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ] + listToBox ts rest = vcat left $ + zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++ + [ tailToPs rest, text [close] ] + toList :: [(String, Type)] -> Type -> ([(String, Type)], Type) toList tys (RCons name ty row) = toList ((name, ty):tys) row toList tys r = (tys, r) +prettyPrintRow :: Type -> String +prettyPrintRow = render . prettyPrintRowWith '(' ')' + typeApp :: Pattern () Type (Type, Type) typeApp = mkPattern match where @@ -92,19 +112,19 @@ insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes go idents other = PrettyPrintForAll idents other convertForAlls other = other -matchTypeAtom :: Pattern () Type String -matchTypeAtom = typeLiterals <+> fmap parens matchType +matchTypeAtom :: Pattern () Type Box +matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType -matchType :: Pattern () Type String +matchType :: Pattern () Type Box matchType = buildPrettyPrinter operators matchTypeAtom where - operators :: OperatorTable () Type String + operators :: OperatorTable () Type Box operators = - OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ] - , [ AssocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret + OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ] + , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret) ] - , [ Wrap forall_ $ \idents ty -> "forall " ++ unwords idents ++ ". " ++ ty ] - , [ Wrap kinded $ \k ty -> ty ++ " :: " ++ prettyPrintKind k ] + , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ] + , [ Wrap kinded $ \k ty -> ty `before` (text " :: " <> kindAsBox k) ] ] forall_ :: Pattern () Type ([String], Type) @@ -113,15 +133,16 @@ forall_ = mkPattern match match (PrettyPrintForAll idents ty) = Just (idents, ty) match _ = Nothing --- | --- Generate a pretty-printed string representing a Type, as it should appear inside parentheses --- +typeAtomAsBox :: Type -> Box +typeAtomAsBox = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders + +-- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses prettyPrintTypeAtom :: Type -> String -prettyPrintTypeAtom = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders +prettyPrintTypeAtom = render . typeAtomAsBox +typeAsBox :: Type -> Box +typeAsBox = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders --- | --- Generate a pretty-printed string representing a Type --- +-- | Generate a pretty-printed string representing a Type prettyPrintType :: Type -> String -prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders +prettyPrintType = render . typeAsBox diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 68892732e7..72dcbf73d6 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -21,173 +21,112 @@ module Language.PureScript.Pretty.Values ( prettyPrintBinderAtom ) where -import Data.Maybe (fromMaybe) import Data.List (intercalate) -import Control.Arrow ((<+>), runKleisli, second) -import Control.PatternArrows -import Control.Monad.State -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif +import Control.Arrow (second) import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Pretty.Common -import Language.PureScript.Pretty.Types (prettyPrintType, prettyPrintTypeAtom) +import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox) -literals :: Pattern PrinterState Expr String -literals = mkPattern' match +import Text.PrettyPrint.Boxes + +-- | Render an aligned list of items separated with commas +list :: Char -> Char -> (a -> Box) -> [a] -> Box +list open close _ [] = text [open, close] +list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ close ] ]) where - match :: Expr -> StateT PrinterState Maybe String - match (NumericLiteral n) = return $ either show show n - match (StringLiteral s) = return $ show s - match (CharLiteral c) = return $ show c - match (BooleanLiteral True) = return "true" - match (BooleanLiteral False) = return "false" - match (ArrayLiteral xs) = return $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]" - match (ObjectLiteral ps) = prettyPrintObject' $ second Just `map` ps - match (ObjectConstructor ps) = prettyPrintObject' ps - match (ObjectGetter prop) = return $ "(." ++ prop ++ ")" - match (TypeClassDictionaryConstructorApp className ps) = concat <$> sequence - [ return (showQualified runProperName className ++ "(\n") - , match ps - , return ")" - ] - match (Constructor name) = return $ showQualified runProperName name - match (Case values binders) = concat <$> sequence - [ return "case " - , unwords <$> forM values prettyPrintValue' - , return " of\n" - , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders - , currentIndent - ] - match (Let ds val) = concat <$> sequence - [ return "let\n" - , withIndent $ prettyPrintMany prettyPrintDeclaration ds - , return "\n" - , currentIndent - , return "in " - , prettyPrintValue' val - ] - match (Var ident) = return $ showQualified showIdent ident - match (Do els) = concat <$> sequence - [ return "do\n" - , withIndent $ prettyPrintMany prettyPrintDoNotationElement els - , currentIndent - ] - match (OperatorSection op (Right val)) = return $ "(" ++ prettyPrintValue op ++ " " ++ prettyPrintValue val ++ ")" - match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ prettyPrintValue op ++ ")" - match (TypeClassDictionary (name, tys) _) = return $ "<>" - match (SuperClassDictionary name _) = return $ "<>" - match (TypedValue _ val _) = prettyPrintValue' val - match (PositionedValue _ _ val) = prettyPrintValue' val - match _ = mzero - -prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String -prettyPrintDeclaration (TypeDeclaration ident ty) = return $ showIdent ident ++ " :: " ++ prettyPrintType ty -prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = concat <$> sequence - [ return $ showIdent ident ++ " = " - , prettyPrintValue' val - ] + toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a + +prettyPrintObject :: [(String, Maybe Expr)] -> Box +prettyPrintObject = list '{' '}' prettyPrintObjectProperty + where + prettyPrintObjectProperty :: (String, Maybe Expr) -> Box + prettyPrintObjectProperty (key, value) = text (prettyPrintObjectKey key ++ ": ") <> maybe (text "_") prettyPrintValue value + +-- | Pretty-print an expression +prettyPrintValue :: Expr -> Box +prettyPrintValue (IfThenElse cond th el) = + (text "if " <> prettyPrintValueAtom cond) + // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom th + , text "else " <> prettyPrintValueAtom el + ]) +prettyPrintValue (Accessor prop val) = prettyPrintValueAtom val <> text ("." ++ show prop) +prettyPrintValue (ObjectUpdate o ps) = prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue val) ps +prettyPrintValue (ObjectUpdater o ps) = maybe (text "_") prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") prettyPrintValue val) ps +prettyPrintValue (App val arg) = prettyPrintValueAtom val `beforeWithSpace` prettyPrintValueAtom arg +prettyPrintValue (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue val) +prettyPrintValue (TypeClassDictionaryConstructorApp className ps) = + text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom ps +prettyPrintValue (Case values binders) = + (text "case " <> foldl1 beforeWithSpace (map prettyPrintValueAtom values) <> text " of") // + moveRight 2 (vcat left (map prettyPrintCaseAlternative binders)) +prettyPrintValue (Let ds val) = + text "let" // + moveRight 2 (vcat left (map prettyPrintDeclaration ds)) // + (text "in " <> prettyPrintValue val) +prettyPrintValue (Do els) = + text "do " <> vcat left (map prettyPrintDoNotationElement els) +prettyPrintValue (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys +prettyPrintValue (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) +prettyPrintValue (PositionedValue _ _ val) = prettyPrintValue val +prettyPrintValue expr = prettyPrintValueAtom expr + +-- | Pretty-print an atomic expression, adding parentheses if necessary. +prettyPrintValueAtom :: Expr -> Box +prettyPrintValueAtom (NumericLiteral n) = text $ either show show n +prettyPrintValueAtom (StringLiteral s) = text $ show s +prettyPrintValueAtom (CharLiteral c) = text $ show c +prettyPrintValueAtom (BooleanLiteral True) = text "true" +prettyPrintValueAtom (BooleanLiteral False) = text "false" +prettyPrintValueAtom (ArrayLiteral xs) = list '[' ']' prettyPrintValue xs +prettyPrintValueAtom (ObjectLiteral ps) = prettyPrintObject $ second Just `map` ps +prettyPrintValueAtom (ObjectConstructor ps) = prettyPrintObject ps +prettyPrintValueAtom (ObjectGetter prop) = text $ "_." ++ show prop +prettyPrintValueAtom (Constructor name) = text $ runProperName (disqualify name) +prettyPrintValueAtom (Var ident) = text $ showIdent (disqualify ident) +prettyPrintValueAtom (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue op) `beforeWithSpace` prettyPrintValue val) `before` text ")" +prettyPrintValueAtom (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue val) `beforeWithSpace` prettyPrintValue op) `before` text ")" +prettyPrintValueAtom (TypedValue _ val _) = prettyPrintValue val +prettyPrintValueAtom (PositionedValue _ _ val) = prettyPrintValueAtom val +prettyPrintValueAtom expr = (text "(" <> prettyPrintValue expr) `before` text ")" + +prettyPrintDeclaration :: Declaration -> Box +prettyPrintDeclaration (TypeDeclaration ident ty) = + text (showIdent ident ++ " :: ") <> typeAsBox ty +prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = + text (showIdent ident ++ " = ") <> prettyPrintValue val prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration" -prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String +prettyPrintCaseAlternative :: CaseAlternative -> Box prettyPrintCaseAlternative (CaseAlternative binders result) = - concat <$> sequence - [ return (unwords (map prettyPrintBinderAtom binders)) - , prettyPrintResult result - ] + text (unwords (map prettyPrintBinderAtom binders)) <> prettyPrintResult result where - prettyPrintResult (Left gs) = concat <$> sequence - [ return "\n" - , withIndent $ prettyPrintMany prettyPrintGuardedValue gs - ] - prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v - - prettyPrintGuardedValue (grd, val) = - concat <$> sequence - [ return "| " - , prettyPrintValue' grd - , return " -> " - , prettyPrintValue' val - ] - -prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String + prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box + prettyPrintResult (Left gs) = + vcat left (map prettyPrintGuardedValue gs) + prettyPrintResult (Right v) = text " -> " <> prettyPrintValue v + + prettyPrintGuardedValue :: (Guard, Expr) -> Box + prettyPrintGuardedValue (grd, val) = foldl1 before + [ text " | " + , prettyPrintValue grd + , text " -> " + , prettyPrintValue val + ] + +prettyPrintDoNotationElement :: DoNotationElement -> Box prettyPrintDoNotationElement (DoNotationValue val) = - prettyPrintValue' val + prettyPrintValue val prettyPrintDoNotationElement (DoNotationBind binder val) = - concat <$> sequence - [ return (prettyPrintBinder binder) - , return " <- " - , prettyPrintValue' val - ] + text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue val prettyPrintDoNotationElement (DoNotationLet ds) = - concat <$> sequence - [ return "let " - , withIndent $ prettyPrintMany prettyPrintDeclaration ds - ] + text "let" // + moveRight 2 (vcat left (map prettyPrintDeclaration ds)) prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el -prettyPrintObject' :: [(String, Maybe Expr)] -> StateT PrinterState Maybe String -prettyPrintObject' [] = return "{}" -prettyPrintObject' ps = return $ "{ " ++ intercalate ", " (map prettyPrintObjectProperty ps) ++ "}" - where - prettyPrintObjectProperty :: (String, Maybe Expr) -> String - prettyPrintObjectProperty (key, value) = prettyPrintObjectKey key ++ ": " ++ maybe "_" prettyPrintValue value - -ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr) -ifThenElse = mkPattern match - where - match (IfThenElse cond th el) = Just ((th, el), cond) - match _ = Nothing - -accessor :: Pattern PrinterState Expr (String, Expr) -accessor = mkPattern match - where - match (Accessor prop val) = Just (prop, val) - match _ = Nothing - -objectUpdate :: Pattern PrinterState Expr ([String], Expr) -objectUpdate = mkPattern match - where - match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o) - match (ObjectUpdater o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ maybe "_" prettyPrintValue val, fromMaybe (Var (Qualified Nothing $ Ident "_")) o) - match _ = Nothing - -app :: Pattern PrinterState Expr (String, Expr) -app = mkPattern match - where - match (App val arg) = Just (prettyPrintValue arg, val) - match _ = Nothing - -lam :: Pattern PrinterState Expr (String, Expr) -lam = mkPattern match - where - match (Abs (Left arg) val) = Just (showIdent arg, val) - match _ = Nothing - --- | --- Generate a pretty-printed string representing an expression --- -prettyPrintValue :: Expr -> String -prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue' - -prettyPrintValue' :: Expr -> StateT PrinterState Maybe String -prettyPrintValue' = runKleisli $ runPattern matchValue - where - matchValue :: Pattern PrinterState Expr String - matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue) - operators :: OperatorTable PrinterState Expr String - operators = - OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ] - , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ] - , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ] - , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ] - , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ] - ] - prettyPrintBinderAtom :: Binder -> String prettyPrintBinderAtom NullBinder = "_" prettyPrintBinderAtom (StringBinder str) = show str @@ -196,7 +135,7 @@ prettyPrintBinderAtom (NumberBinder num) = either show show num prettyPrintBinderAtom (BooleanBinder True) = "true" prettyPrintBinderAtom (BooleanBinder False) = "false" prettyPrintBinderAtom (VarBinder ident) = showIdent ident -prettyPrintBinderAtom (ConstructorBinder ctor []) = showQualified runProperName ctor +prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor) prettyPrintBinderAtom (ObjectBinder bs) = "{ " ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs) @@ -216,7 +155,7 @@ prettyPrintBinderAtom b = parens (prettyPrintBinder b) -- Generate a pretty-printed string representing a Binder -- prettyPrintBinder :: Binder -> String -prettyPrintBinder (ConstructorBinder ctor []) = showQualified runProperName ctor -prettyPrintBinder (ConstructorBinder ctor args) = showQualified runProperName ctor ++ " " ++ unwords (map prettyPrintBinderAtom args) +prettyPrintBinder (ConstructorBinder ctor []) = runProperName (disqualify ctor) +prettyPrintBinder (ConstructorBinder ctor args) = runProperName (disqualify ctor) ++ " " ++ unwords (map prettyPrintBinderAtom args) prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder prettyPrintBinder b = prettyPrintBinderAtom b From 9345724c9eb7624036aa9ad16884f2fd80238920 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 11 Oct 2015 11:22:28 -0700 Subject: [PATCH 0044/1580] Change data structure for error message hints --- psci/PSCi.hs | 4 +- src/Language/PureScript/Errors.hs | 505 ++++++++---------- src/Language/PureScript/Linter.hs | 8 +- src/Language/PureScript/Linter/Exhaustive.hs | 6 +- src/Language/PureScript/Make.hs | 6 +- .../PureScript/Parser/Declarations.hs | 2 +- src/Language/PureScript/Pretty/Values.hs | 3 +- .../PureScript/Sugar/BindingGroups.hs | 2 +- .../PureScript/Sugar/CaseDeclarations.hs | 2 +- src/Language/PureScript/Sugar/Names.hs | 2 +- .../PureScript/Sugar/Names/Exports.hs | 4 +- .../PureScript/Sugar/Names/Imports.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- .../PureScript/Sugar/TypeDeclarations.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 16 +- src/Language/PureScript/TypeChecker/Kinds.hs | 4 +- .../PureScript/TypeChecker/Skolems.hs | 2 +- .../PureScript/TypeChecker/Subsumption.hs | 2 +- .../PureScript/TypeChecker/Synonyms.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 8 +- src/Language/PureScript/TypeChecker/Unify.hs | 2 +- 22 files changed, 269 insertions(+), 319 deletions(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 26923ab436..339d06cd27 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -464,7 +464,7 @@ handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods)) handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do foreignsOrError <- psciIO . runMake $ do - foreignFile <- makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile absPath)) (readFile absPath) + foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath) P.parseForeignModulesFromFiles [(absPath, foreignFile)] case foreignsOrError of Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err @@ -533,7 +533,7 @@ loop PSCiOptions{..} = do historyFilename <- getHistoryFilename let settings = defaultSettings { historyFile = Just historyFilename } foreignsOrError <- runMake $ do - foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile inFile)) (readFile inFile)) + foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile)) P.parseForeignModulesFromFiles foreignFilesContent case foreignsOrError of Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index fa336517d6..5f9a109ead 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -20,10 +20,11 @@ module Language.PureScript.Errors where import Data.Either (lefts, rights) -import Data.List (intercalate, transpose, nub) +import Data.List (intercalate, transpose, nub, nubBy, partition) import Data.Function (on) #if __GLASGOW_HASKELL__ < 710 import Data.Foldable (fold, foldMap) +import Data.Traversable (traverse) #else import Data.Foldable (fold) #endif @@ -53,9 +54,7 @@ import qualified Text.Parsec as P import qualified Text.Parsec.Error as PE import Text.Parsec.Error (Message(..)) --- | --- A type of error messages --- +-- | A type of error messages data SimpleErrorMessage = ErrorParsingExterns P.ParseError | ErrorParsingFFIModule FilePath @@ -148,39 +147,47 @@ data SimpleErrorMessage | ClassOperator ProperName Ident | MisleadingEmptyTypeImport ModuleName ProperName | ImportHidingModule ModuleName - deriving (Show) - --- | --- Wrapper of simpler errors --- -data ErrorMessage - = NotYetDefined [Ident] ErrorMessage - | ErrorUnifyingTypes Type Type ErrorMessage - | ErrorInExpression Expr ErrorMessage - | ErrorInModule ModuleName ErrorMessage - | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage - | ErrorInSubsumption Type Type ErrorMessage - | ErrorCheckingType Expr Type ErrorMessage - | ErrorCheckingKind Type ErrorMessage - | ErrorInferringType Expr ErrorMessage - | ErrorInApplication Expr Type Expr ErrorMessage - | ErrorInDataConstructor ProperName ErrorMessage - | ErrorInTypeConstructor ProperName ErrorMessage - | ErrorInBindingGroup [Ident] ErrorMessage - | ErrorInDataBindingGroup ErrorMessage - | ErrorInTypeSynonym ProperName ErrorMessage - | ErrorInValueDeclaration Ident ErrorMessage - | ErrorInTypeDeclaration Ident ErrorMessage - | ErrorInForeignImport Ident ErrorMessage - | PositionedError SourceSpan ErrorMessage - | SimpleErrorWrapper SimpleErrorMessage - deriving (Show) + deriving Show + +-- | Error message hints, providing more detailed information about failure. +data ErrorMessageHint + = NotYetDefined [Ident] + | ErrorUnifyingTypes Type Type + | ErrorInExpression Expr + | ErrorInModule ModuleName + | ErrorInInstance (Qualified ProperName) [Type] + | ErrorInSubsumption Type Type + | ErrorCheckingType Expr Type + | ErrorCheckingKind Type + | ErrorInferringType Expr + | ErrorInApplication Expr Type Expr + | ErrorInDataConstructor ProperName + | ErrorInTypeConstructor ProperName + | ErrorInBindingGroup [Ident] + | ErrorInDataBindingGroup + | ErrorInTypeSynonym ProperName + | ErrorInValueDeclaration Ident + | ErrorInTypeDeclaration Ident + | ErrorInForeignImport Ident + | PositionedError SourceSpan + deriving Show + +-- | Categories of hints +data HintCategory + = ExprHint + | KindHint + | CheckHint + | PositionHint + | OtherHint + deriving (Show, Eq) + +data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show) instance UnificationError Type ErrorMessage where - occursCheckFailed t = SimpleErrorWrapper $ InfiniteType t + occursCheckFailed t = ErrorMessage [] $ InfiniteType t instance UnificationError Kind ErrorMessage where - occursCheckFailed k = SimpleErrorWrapper $ InfiniteKind k + occursCheckFailed k = ErrorMessage [] $ InfiniteKind k -- | -- Get the error code for a particular error type @@ -299,7 +306,7 @@ nonEmpty = not . null . runMultipleErrors -- Create an error set from a single simple error message -- errorMessage :: SimpleErrorMessage -> MultipleErrors -errorMessage err = MultipleErrors [SimpleErrorWrapper err] +errorMessage err = MultipleErrors [ErrorMessage [] err] -- | @@ -308,12 +315,14 @@ errorMessage err = MultipleErrors [SimpleErrorWrapper err] singleError :: ErrorMessage -> MultipleErrors singleError = MultipleErrors . pure --- | --- Lift a function on ErrorMessage to a function on MultipleErrors --- +-- | Lift a function on ErrorMessage to a function on MultipleErrors onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors onErrorMessages f = MultipleErrors . map f . runMultipleErrors +-- | Add a hint to an error message +addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors +addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint : hints) se + -- | The various types of things which might need to be relabelled in errors messages. data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord) @@ -327,27 +336,7 @@ data Level = Error | Warning deriving Show -- Extract nested error messages from wrapper errors -- unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage -unwrapErrorMessage em = case em of - (ErrorCheckingKind _ err) -> unwrapErrorMessage err - (ErrorCheckingType _ _ err) -> unwrapErrorMessage err - (ErrorInApplication _ _ _ err) -> unwrapErrorMessage err - (ErrorInBindingGroup _ err) -> unwrapErrorMessage err - (ErrorInDataBindingGroup err) -> unwrapErrorMessage err - (ErrorInDataConstructor _ err) -> unwrapErrorMessage err - (ErrorInExpression _ err) -> unwrapErrorMessage err - (ErrorInForeignImport _ err) -> unwrapErrorMessage err - (ErrorInInstance _ _ err) -> unwrapErrorMessage err - (ErrorInModule _ err) -> unwrapErrorMessage err - (ErrorInSubsumption _ _ err) -> unwrapErrorMessage err - (ErrorInTypeConstructor _ err) -> unwrapErrorMessage err - (ErrorInTypeSynonym _ err) -> unwrapErrorMessage err - (ErrorInValueDeclaration _ err) -> unwrapErrorMessage err - (ErrorInTypeDeclaration _ err) -> unwrapErrorMessage err - (ErrorInferringType _ err) -> unwrapErrorMessage err - (ErrorUnifyingTypes _ _ err) -> unwrapErrorMessage err - (NotYetDefined _ err) -> unwrapErrorMessage err - (PositionedError _ err) -> unwrapErrorMessage err - (SimpleErrorWrapper sem) -> sem +unwrapErrorMessage (ErrorMessage _ se) = se replaceUnknowns :: Type -> State UnknownMap Type replaceUnknowns = everywhereOnTypesM replaceTypes @@ -363,7 +352,7 @@ replaceUnknowns = everywhereOnTypesM replaceTypes replaceTypes other = return other onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage -onTypesInErrorMessageM f = g +onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple where gSimple (InfiniteType t) = InfiniteType <$> f t gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2 @@ -373,204 +362,191 @@ onTypesInErrorMessageM f = g gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t gSimple other = pure other - g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> f t1 <*> f t2 <*> g em - g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> f t1 <*> f t2 <*> g e - g (ErrorCheckingType e t em) = ErrorCheckingType e <$> f t <*> g em - g (ErrorCheckingKind t em) = ErrorCheckingKind <$> f t <*> g em - g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> f t1 <*> pure e2 <*> g em - g (NotYetDefined x e) = NotYetDefined x <$> g e - g (ErrorInExpression x e) = ErrorInExpression x <$> g e - g (ErrorInModule x e) = ErrorInModule x <$> g e - g (ErrorInInstance x y e) = ErrorInInstance x y <$> g e - g (ErrorInferringType x e) = ErrorInferringType x <$> g e - g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> g e - g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> g e - g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> g e - g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> g e - g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> g e - g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> g e - g (ErrorInTypeDeclaration x e) = ErrorInTypeDeclaration x <$> g e - g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> g e - g (PositionedError x e) = PositionedError x <$> g e - g (SimpleErrorWrapper sem) = SimpleErrorWrapper <$> gSimple sem + gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2 + gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2 + gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t + gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t + gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2 + gHint other = pure other -- | -- Pretty print a single error, simplifying if necessary -- prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box -prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) +prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFirst . reverseHints <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) where - -- | + -- Pretty print an ErrorMessage - -- prettyPrintErrorMessage :: ErrorMessage -> Box.Box - prettyPrintErrorMessage em = + prettyPrintErrorMessage (ErrorMessage hints simple) = paras $ - go em:suggestions em ++ + map renderHint hints ++ + renderSimpleErrorMessage simple : + suggestions simple ++ [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."] where wikiUri :: String wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e - go :: ErrorMessage -> Box.Box - goSimple (CannotGetFileInfo path) = + renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box + renderSimpleErrorMessage (CannotGetFileInfo path) = paras [ line "Unable to read file info: " , indent . line $ path ] - goSimple (CannotReadFile path) = + renderSimpleErrorMessage (CannotReadFile path) = paras [ line "Unable to read file: " , indent . line $ path ] - goSimple (CannotWriteFile path) = + renderSimpleErrorMessage (CannotWriteFile path) = paras [ line "Unable to write file: " , indent . line $ path ] - goSimple (ErrorParsingExterns err) = + renderSimpleErrorMessage (ErrorParsingExterns err) = paras [ lineWithLevel "parsing externs files: " , prettyPrintParseError err ] - goSimple (ErrorParsingFFIModule path) = + renderSimpleErrorMessage (ErrorParsingFFIModule path) = paras [ line "Unable to parse module from FFI file: " , indent . line $ path ] - goSimple (ErrorParsingModule err) = + renderSimpleErrorMessage (ErrorParsingModule err) = paras [ line "Unable to parse module: " , prettyPrintParseError err ] - goSimple (MissingFFIModule mn) = + renderSimpleErrorMessage (MissingFFIModule mn) = line $ "Missing FFI implementations for module " ++ runModuleName mn - goSimple (UnnecessaryFFIModule mn path) = + renderSimpleErrorMessage (UnnecessaryFFIModule mn path) = paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ runModuleName mn ++ ": " , indent . line $ path ] - goSimple (MultipleFFIModules mn paths) = + renderSimpleErrorMessage (MultipleFFIModules mn paths) = paras [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": " , indent . paras $ map line paths ] - goSimple (InvalidExternsFile path) = + renderSimpleErrorMessage (InvalidExternsFile path) = paras [ line "Externs file is invalid: " , indent . line $ path ] - goSimple InvalidDoBind = + renderSimpleErrorMessage InvalidDoBind = line "Bind statement cannot be the last statement in a do block. The last statement must be an expression." - goSimple InvalidDoLet = + renderSimpleErrorMessage InvalidDoLet = line "Let statement cannot be the last statement in a do block. The last statement must be an expression." - goSimple CannotReorderOperators = + renderSimpleErrorMessage CannotReorderOperators = line "Unable to reorder operators" - goSimple UnspecifiedSkolemScope = + renderSimpleErrorMessage UnspecifiedSkolemScope = line "Skolem variable scope is unspecified" - goSimple OverlappingNamesInLet = + renderSimpleErrorMessage OverlappingNamesInLet = line "Overlapping names in let binding." - goSimple (InfiniteType ty) = + renderSimpleErrorMessage (InfiniteType ty) = paras [ line "An infinite type was inferred for an expression: " , indent $ typeAsBox ty ] - goSimple (InfiniteKind ki) = + renderSimpleErrorMessage (InfiniteKind ki) = paras [ line "An infinite kind was inferred for a type: " , indent $ kindAsBox ki ] - goSimple (MultipleFixities name) = + renderSimpleErrorMessage (MultipleFixities name) = line $ "Multiple fixity declarations for " ++ showIdent name - goSimple (OrphanTypeDeclaration nm) = + renderSimpleErrorMessage (OrphanTypeDeclaration nm) = line $ "Orphan type declaration for " ++ showIdent nm - goSimple (OrphanFixityDeclaration op) = + renderSimpleErrorMessage (OrphanFixityDeclaration op) = line $ "Orphan fixity declaration for " ++ show op - goSimple (RedefinedModule name filenames) = + renderSimpleErrorMessage (RedefinedModule name filenames) = paras [ line ("Module " ++ runModuleName name ++ " has been defined multiple times:") , indent . paras $ map (line . displaySourceSpan) filenames ] - goSimple (RedefinedIdent name) = + renderSimpleErrorMessage (RedefinedIdent name) = line $ "Name " ++ showIdent name ++ " has been defined multiple times" - goSimple (UnknownModule mn) = + renderSimpleErrorMessage (UnknownModule mn) = line $ "Unknown module " ++ runModuleName mn - goSimple (UnknownType name) = + renderSimpleErrorMessage (UnknownType name) = line $ "Unknown type " ++ showQualified runProperName name - goSimple (UnknownTypeClass name) = + renderSimpleErrorMessage (UnknownTypeClass name) = line $ "Unknown type class " ++ showQualified runProperName name - goSimple (UnknownValue name) = + renderSimpleErrorMessage (UnknownValue name) = line $ "Unknown value " ++ showQualified showIdent name - goSimple (UnknownTypeConstructor name) = + renderSimpleErrorMessage (UnknownTypeConstructor name) = line $ "Unknown type constructor " ++ showQualified runProperName name - goSimple (UnknownDataConstructor dc tc) = + renderSimpleErrorMessage (UnknownDataConstructor dc tc) = line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc - goSimple (UnknownImportType mn name) = + renderSimpleErrorMessage (UnknownImportType mn name) = line $ "Module " ++ runModuleName mn ++ " does not export type " ++ runProperName name - goSimple (UnknownExportType name) = + renderSimpleErrorMessage (UnknownExportType name) = line $ "Cannot export unknown type " ++ runProperName name - goSimple (UnknownImportTypeClass mn name) = + renderSimpleErrorMessage (UnknownImportTypeClass mn name) = line $ "Module " ++ runModuleName mn ++ " does not export type class " ++ runProperName name - goSimple (UnknownExportTypeClass name) = + renderSimpleErrorMessage (UnknownExportTypeClass name) = line $ "Cannot export unknown type class " ++ runProperName name - goSimple (UnknownImportValue mn name) = + renderSimpleErrorMessage (UnknownImportValue mn name) = line $ "Module " ++ runModuleName mn ++ " does not export value " ++ showIdent name - goSimple (UnknownExportValue name) = + renderSimpleErrorMessage (UnknownExportValue name) = line $ "Cannot export unknown value " ++ showIdent name - goSimple (UnknownExportModule name) = + renderSimpleErrorMessage (UnknownExportModule name) = line $ "Cannot export unknown module " ++ runModuleName name ++ ", it either does not exist or has not been imported by the current module" - goSimple (UnknownImportDataConstructor mn tcon dcon) = + renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) = line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon - goSimple (UnknownExportDataConstructor tcon dcon) = + renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) = line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ " as it has not been declared" - goSimple (ConflictingImport nm mn) = + renderSimpleErrorMessage (ConflictingImport nm mn) = line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ runModuleName mn - goSimple (ConflictingImports nm m1 m2) = + renderSimpleErrorMessage (ConflictingImports nm m1 m2) = line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2 - goSimple (ConflictingTypeDecls nm) = + renderSimpleErrorMessage (ConflictingTypeDecls nm) = line $ "Conflicting type declarations for " ++ runProperName nm - goSimple (ConflictingCtorDecls nm) = + renderSimpleErrorMessage (ConflictingCtorDecls nm) = line $ "Conflicting data constructor declarations for " ++ runProperName nm - goSimple (TypeConflictsWithClass nm) = + renderSimpleErrorMessage (TypeConflictsWithClass nm) = line $ "Type " ++ runProperName nm ++ " conflicts with type class declaration of the same name" - goSimple (CtorConflictsWithClass nm) = + renderSimpleErrorMessage (CtorConflictsWithClass nm) = line $ "Data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name" - goSimple (ClassConflictsWithType nm) = + renderSimpleErrorMessage (ClassConflictsWithType nm) = line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name" - goSimple (ClassConflictsWithCtor nm) = + renderSimpleErrorMessage (ClassConflictsWithCtor nm) = line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name" - goSimple (DuplicateClassExport nm) = + renderSimpleErrorMessage (DuplicateClassExport nm) = line $ "Duplicate export declaration for type class " ++ runProperName nm - goSimple (DuplicateValueExport nm) = + renderSimpleErrorMessage (DuplicateValueExport nm) = line $ "Duplicate export declaration for value " ++ showIdent nm - goSimple (CycleInDeclaration nm) = + renderSimpleErrorMessage (CycleInDeclaration nm) = line $ "Cycle in declaration of " ++ showIdent nm - goSimple (CycleInModules mns) = + renderSimpleErrorMessage (CycleInModules mns) = line $ "Cycle in module dependencies: " ++ intercalate ", " (map runModuleName mns) - goSimple (CycleInTypeSynonym pn) = + renderSimpleErrorMessage (CycleInTypeSynonym pn) = line $ "Cycle in type synonym" ++ foldMap ((" " ++) . runProperName) pn - goSimple (NameIsUndefined ident) = + renderSimpleErrorMessage (NameIsUndefined ident) = line $ showIdent ident ++ " is undefined" - goSimple (NameNotInScope ident) = + renderSimpleErrorMessage (NameNotInScope ident) = line $ showIdent ident ++ " may not be defined in the current scope" - goSimple (UndefinedTypeVariable name) = + renderSimpleErrorMessage (UndefinedTypeVariable name) = line $ "Type variable " ++ runProperName name ++ " is undefined" - goSimple (PartiallyAppliedSynonym name) = + renderSimpleErrorMessage (PartiallyAppliedSynonym name) = paras [ line $ "Partially applied type synonym " ++ showQualified runProperName name , line "Type synonyms must be applied to all of their type arguments." ] - goSimple (EscapedSkolem binding) = + renderSimpleErrorMessage (EscapedSkolem binding) = paras $ [ line "A type variable has escaped its scope." ] <> foldMap (\expr -> [ line "Relevant expression: " , indent $ prettyPrintValue expr ]) binding - goSimple (TypesDoNotUnify t1 t2) + renderSimpleErrorMessage (TypesDoNotUnify t1 t2) = paras [ line "Cannot unify type" , indent $ typeAsBox t1 , line "with type" , indent $ typeAsBox t2 ] - goSimple (KindsDoNotUnify k1 k2) = + renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = paras [ line "Cannot unify kind" , indent $ kindAsBox k1 , line "with kind" , indent $ kindAsBox k2 ] - goSimple (ConstrainedTypeUnified t1 t2) = + renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) = paras [ line "Cannot unify constrained type" , indent $ typeAsBox t1 , line "with type" , indent $ typeAsBox t2 ] - goSimple (OverlappingInstances nm ts (d : ds)) = + renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) = paras [ line "Overlapping instances found for" , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) @@ -578,46 +554,46 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , line "The following instances were found:" , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds) ] - goSimple OverlappingInstances{} = error "OverlappingInstances: empty instance list" - goSimple (NoInstanceFound nm ts) = + renderSimpleErrorMessage OverlappingInstances{} = error "OverlappingInstances: empty instance list" + renderSimpleErrorMessage (NoInstanceFound nm ts) = paras [ line "No instance found for" , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) ] ] - goSimple (PossiblyInfiniteInstance nm ts) = + renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) = paras [ line "Instance for" , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) ] , line "is possibly infinite." ] - goSimple (CannotDerive nm ts) = + renderSimpleErrorMessage (CannotDerive nm ts) = paras [ line "Cannot derive an instance for" , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) ] ] - goSimple (CannotFindDerivingType nm) = + renderSimpleErrorMessage (CannotFindDerivingType nm) = line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found." - goSimple (DuplicateLabel l expr) = + renderSimpleErrorMessage (DuplicateLabel l expr) = paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ] <> foldMap (\expr' -> [ line "Relevant expression: " , indent $ prettyPrintValue expr' ]) expr - goSimple (DuplicateTypeArgument name) = + renderSimpleErrorMessage (DuplicateTypeArgument name) = line $ "Duplicate type argument " ++ show name - goSimple (DuplicateValueDeclaration nm) = + renderSimpleErrorMessage (DuplicateValueDeclaration nm) = line $ "Duplicate value declaration for " ++ showIdent nm - goSimple (ArgListLengthsDiffer ident) = + renderSimpleErrorMessage (ArgListLengthsDiffer ident) = line $ "Argument list lengths differ in declaration " ++ showIdent ident - goSimple (OverlappingArgNames ident) = + renderSimpleErrorMessage (OverlappingArgNames ident) = line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident - goSimple (MissingClassMember ident) = + renderSimpleErrorMessage (MissingClassMember ident) = line $ "Member " ++ showIdent ident ++ " has not been implemented" - goSimple (ExtraneousClassMember ident) = + renderSimpleErrorMessage (ExtraneousClassMember ident) = line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated" - goSimple (ExpectedType ty kind) = + renderSimpleErrorMessage (ExpectedType ty kind) = paras [ line "In a type-annotated expression x :: t, the type t must have kind *." , line "The error arises from the type" , indent $ typeAsBox ty @@ -625,29 +601,29 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , indent $ kindAsBox kind , line "instead." ] - goSimple (IncorrectConstructorArity nm) = + renderSimpleErrorMessage (IncorrectConstructorArity nm) = line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm - goSimple SubsumptionCheckFailed = line "Unable to check type subsumption" - goSimple (ExprDoesNotHaveType expr ty) = + renderSimpleErrorMessage SubsumptionCheckFailed = line "Unable to check type subsumption" + renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) = paras [ line "Expression" , indent $ prettyPrintValue expr , line "does not have type" , indent $ typeAsBox ty ] - goSimple (PropertyIsMissing prop row) = + renderSimpleErrorMessage (PropertyIsMissing prop row) = paras [ line "Row" , indent $ prettyPrintRowWith '(' ')' row , line $ "lacks required property " ++ show prop ] - goSimple (CannotApplyFunction fn arg) = + renderSimpleErrorMessage (CannotApplyFunction fn arg) = paras [ line "Cannot apply function of type" , indent $ typeAsBox fn , line "to argument" , indent $ prettyPrintValue arg ] - goSimple TypeSynonymInstance = + renderSimpleErrorMessage TypeSynonymInstance = line "Type synonym instances are disallowed" - goSimple (OrphanInstance nm cnm ts) = + renderSimpleErrorMessage (OrphanInstance nm cnm ts) = paras [ line $ "Instance " ++ showIdent nm ++ " for " , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm) , Box.vcat Box.left (map typeAtomAsBox ts) @@ -656,146 +632,118 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , line "An orphan instance is an instance which is defined in neither the class module nor the data type module." , line "Consider moving the instance, if possible, or using a newtype wrapper." ] - goSimple InvalidNewtype = + renderSimpleErrorMessage InvalidNewtype = line "Newtypes must define a single constructor with a single argument" - goSimple (InvalidInstanceHead ty) = + renderSimpleErrorMessage (InvalidInstanceHead ty) = paras [ line "Invalid type in class instance head:" , indent $ typeAsBox ty ] - goSimple (TransitiveExportError x ys) = + renderSimpleErrorMessage (TransitiveExportError x ys) = paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ") : map (line . prettyPrintExport) ys - goSimple (ShadowedName nm) = + renderSimpleErrorMessage (ShadowedName nm) = line $ "Name '" ++ showIdent nm ++ "' was shadowed" - goSimple (ShadowedTypeVar tv) = + renderSimpleErrorMessage (ShadowedTypeVar tv) = line $ "Type variable '" ++ tv ++ "' was shadowed" - goSimple (UnusedTypeVar tv) = + renderSimpleErrorMessage (UnusedTypeVar tv) = line $ "Type variable '" ++ tv ++ "' was declared but not used" - goSimple (ClassOperator className opName) = + renderSimpleErrorMessage (ClassOperator className opName) = paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "." , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:" , indent . line $ showIdent opName ++ " = someMember" ] - goSimple (MisleadingEmptyTypeImport mn name) = + renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) = line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors" - goSimple (ImportHidingModule name) = + renderSimpleErrorMessage (ImportHidingModule name) = line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted" - goSimple (WildcardInferredType ty) = + renderSimpleErrorMessage (WildcardInferredType ty) = paras [ line "The wildcard type definition has the inferred type " , indent $ typeAsBox ty ] - goSimple (NotExhaustivePattern bs b) = + renderSimpleErrorMessage (NotExhaustivePattern bs b) = paras $ [ line "A case expression could not be determined to cover all inputs." , line "The following additional cases are required to cover all inputs:\n" , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ] ++ [ line "..." | not b ] - goSimple (OverlappingPattern bs b) = + renderSimpleErrorMessage (OverlappingPattern bs b) = paras $ [ line "A case expression contains unreachable cases:\n" , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ] ++ [ line "..." | not b ] - goSimple IncompleteExhaustivityCheck = + renderSimpleErrorMessage IncompleteExhaustivityCheck = paras [ line "An exhaustivity check was abandoned due to too many possible cases." , line "You may want to decomposing your data types into smaller types." ] - go (NotYetDefined names err) = - paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":" - , go err - ] - go (ErrorUnifyingTypes t1 t2 err) = + + renderHint :: ErrorMessageHint -> Box.Box + renderHint (NotYetDefined names) = + line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":" + renderHint (ErrorUnifyingTypes t1 t2) = paras [ lineWithLevel "unifying type " , indent $ typeAsBox t1 , line "with type" , indent $ typeAsBox t2 - , go err ] - go (ErrorInExpression expr err) = + renderHint (ErrorInExpression expr) = paras [ lineWithLevel "in expression:" , indent $ prettyPrintValue expr - , go err ] - go (ErrorInModule mn err) = + renderHint (ErrorInModule mn) = paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":" - , go err ] - go (ErrorInSubsumption t1 t2 err) = + renderHint (ErrorInSubsumption t1 t2) = paras [ lineWithLevel "checking that type " , indent $ typeAsBox t1 , line "subsumes type" , indent $ typeAsBox t2 - , go err ] - go (ErrorInInstance nm ts err) = + renderHint (ErrorInInstance nm ts) = paras [ lineWithLevel "in type class instance" , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) ] - , go err ] - go (ErrorCheckingKind ty err) = + renderHint (ErrorCheckingKind ty) = paras [ lineWithLevel "checking kind of type " , indent $ typeAsBox ty - , go err ] - go (ErrorInferringType expr err) = + renderHint (ErrorInferringType expr) = paras [ lineWithLevel "inferring type of value " , indent $ prettyPrintValue expr - , go err ] - go (ErrorCheckingType expr ty err) = + renderHint (ErrorCheckingType expr ty) = paras [ lineWithLevel "checking that value " , indent $ prettyPrintValue expr , line "has type" , indent $ typeAsBox ty - , go err ] - go (ErrorInApplication f t a err) = + renderHint (ErrorInApplication f t a) = paras [ lineWithLevel "applying function" , indent $ prettyPrintValue f , line "of type" , indent $ typeAsBox t , line "to argument" , indent $ prettyPrintValue a - , go err - ] - go (ErrorInDataConstructor nm err) = - paras [ lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":" - , go err - ] - go (ErrorInTypeConstructor nm err) = - paras [ lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":" - , go err ] - go (ErrorInBindingGroup nms err) = - paras [ lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":" - , go err - ] - go (ErrorInDataBindingGroup err) = - paras [ lineWithLevel "in data binding group:" - , go err - ] - go (ErrorInTypeSynonym name err) = - paras [ lineWithLevel $ "in type synonym " ++ runProperName name ++ ":" - , go err - ] - go (ErrorInValueDeclaration n err) = - paras [ lineWithLevel $ "in value declaration " ++ showIdent n ++ ":" - , go err - ] - go (ErrorInTypeDeclaration n err) = - paras [ lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":" - , go err - ] - go (ErrorInForeignImport nm err) = - paras [ lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":" - , go err - ] - go (PositionedError srcSpan err) = - paras [ lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":" - , go err - ] - go (SimpleErrorWrapper sem) = goSimple sem + renderHint (ErrorInDataConstructor nm) = + lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":" + renderHint (ErrorInTypeConstructor nm) = + lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":" + renderHint (ErrorInBindingGroup nms) = + lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":" + renderHint ErrorInDataBindingGroup = + lineWithLevel "in data binding group:" + renderHint (ErrorInTypeSynonym name) = + lineWithLevel $ "in type synonym " ++ runProperName name ++ ":" + renderHint (ErrorInValueDeclaration n) = + lineWithLevel $ "in value declaration " ++ showIdent n ++ ":" + renderHint (ErrorInTypeDeclaration n) = + lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":" + renderHint (ErrorInForeignImport nm) = + lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":" + renderHint (PositionedError srcSpan) = + lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":" lineWithLevel :: String -> Box.Box lineWithLevel text = line $ show level ++ " " ++ text @@ -805,23 +753,19 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError Error -> "error" Warning -> "warning" - suggestions :: ErrorMessage -> [Box.Box] - suggestions = suggestions' . unwrapErrorMessage - where - suggestions' (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":" + suggestions :: SimpleErrorMessage -> [Box.Box] + suggestions (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":" , indent . line $ "import " ++ runModuleName im ++ " hiding (" ++ nm ++ ")" ] - suggestions' (TypesDoNotUnify t1 t2) - | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"] - | otherwise = [] - suggestions' _ = [] + suggestions (TypesDoNotUnify t1 t2) + | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"] + | otherwise = [] + suggestions _ = [] paras :: [Box.Box] -> Box.Box paras = Box.vcat Box.left - -- | -- Pretty print and export declaration - -- prettyPrintExport :: DeclarationRef -> String prettyPrintExport (TypeRef pn _) = runProperName pn prettyPrintExport (ValueRef ident) = showIdent ident @@ -830,38 +774,44 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref - -- | - -- Simplify an error message - -- - simplifyErrorMessage :: ErrorMessage -> ErrorMessage - simplifyErrorMessage = unwrap Nothing + -- Hints get added at the front, so we need to reverse them before rendering + reverseHints :: ErrorMessage -> ErrorMessage + reverseHints (ErrorMessage hints simple) = ErrorMessage (reverse hints) simple + + -- | Put positional hints at the front of the list + positionHintsFirst :: ErrorMessage -> ErrorMessage + positionHintsFirst (ErrorMessage hints simple) = ErrorMessage (uncurry (++) $ partition (isPositionHint . hintCategory) hints) simple where - unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage - unwrap pos (ErrorInExpression _ err) = unwrap pos err - unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err) - unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err) - unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err - unwrap pos (ErrorInferringType _ err) = unwrap pos err - unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err - unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err) - unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err) - unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err - unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err) - unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err) - unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err) - unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err) - unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err) - unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err) - unwrap pos (ErrorInTypeDeclaration nm err) = ErrorInTypeDeclaration nm (unwrap pos err) - unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err) - unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err) - unwrap _ (PositionedError pos err) = unwrap (Just pos) err - unwrap pos other = wrap pos other - - wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage - wrap Nothing = id - wrap (Just pos) = PositionedError pos + isPositionHint :: HintCategory -> Bool + isPositionHint PositionHint = True + isPositionHint OtherHint = True + isPositionHint _ = False + -- | Simplify an error message + simplifyErrorMessage :: ErrorMessage -> ErrorMessage + simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple + where + -- Take the last instance of each "hint category" + simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint] + simplifyHints = reverse . nubBy categoriesEqual . reverse + + -- Don't remove hints in the "other" category + categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool + categoriesEqual x y = + case (hintCategory x, hintCategory y) of + (OtherHint, _) -> False + (_, OtherHint) -> False + (c1, c2) -> c1 == c2 + + hintCategory :: ErrorMessageHint -> HintCategory + hintCategory ErrorCheckingType{} = ExprHint + hintCategory ErrorInferringType{} = ExprHint + hintCategory ErrorInExpression{} = ExprHint + hintCategory ErrorUnifyingTypes{} = CheckHint + hintCategory ErrorInSubsumption{} = CheckHint + hintCategory ErrorInApplication{} = CheckHint + hintCategory PositionedError{} = PositionHint + hintCategory _ = OtherHint -- | -- Pretty print multiple errors @@ -988,8 +938,7 @@ warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter Multiple warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage -withPosition _ (PositionedError pos err) = withPosition pos err -withPosition pos err = PositionedError pos err +withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se -- | -- Collect errors in in parallel diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 6da6e5051a..161de1ab15 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -40,7 +40,7 @@ import Language.PureScript.Linter.Exhaustive as L -- | -- | Right now, this pass only performs a shadowing check. lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m () -lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ lintDeclaration ds +lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds where moduleNames :: S.Set Ident moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds)) @@ -58,9 +58,9 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend stepD stepE stepB def def f' :: Declaration -> MultipleErrors - f' (PositionedDeclaration pos _ dec) = onErrorMessages (PositionedError pos) (f' dec) - f' dec@(ValueDeclaration name _ _ _) = onErrorMessages (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec) - f' (TypeDeclaration name ty) = onErrorMessages (ErrorInTypeDeclaration name) (checkTypeVars ty) + f' (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' dec) + f' dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec) + f' (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty) f' dec = f dec <> checkTypeVarsInDecl dec in tell (f' d) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 38e90f47f8..3303b8e12b 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -281,8 +281,8 @@ checkExhaustiveDecls env mn ds = where convert :: (Ident, NameKind, Expr) -> Declaration convert (name, nk, e) = ValueDeclaration name nk [] (Right e) - f' d@(ValueDeclaration name _ _ _) = censor (onErrorMessages (ErrorInValueDeclaration name)) $ f d - f' (PositionedDeclaration pos com dec) = PositionedDeclaration pos com <$> censor (onErrorMessages (PositionedError pos)) (f' dec) + f' d@(ValueDeclaration name _ _ _) = censor (addHint (ErrorInValueDeclaration name)) $ f d + f' (PositionedDeclaration pos com dec) = PositionedDeclaration pos com <$> censor (addHint (PositionedError pos)) (f' dec) -- Don't generate two warnings for desugared dictionaries. f' d@TypeInstanceDeclaration{} = return d f' d = f d @@ -297,4 +297,4 @@ checkExhaustiveDecls env mn ds = -- Exhaustivity checking over a single module -- checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m () -checkExhaustiveModule env (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds +checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 99d28fc913..a1edf421ac 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -305,15 +305,15 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = requiresForeign = not . null . CF.moduleForeign getTimestamp :: FilePath -> Make (Maybe UTCTime) - getTimestamp path = makeIO (const (SimpleErrorWrapper $ CannotGetFileInfo path)) $ do + getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do exists <- doesFileExist path traverse (const $ getModificationTime path) $ guard exists readTextFile :: FilePath -> Make B.ByteString - readTextFile path = makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ B.readFile path + readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path writeTextFile :: FilePath -> B.ByteString -> Make () - writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do + writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do mkdirp path B.writeFile path text where diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 92ef9b8ee3..9a7e740087 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -293,7 +293,7 @@ parseModulesFromFiles toFilePath input = do collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ] toPositionedError :: P.ParseError -> ErrorMessage -toPositionedError perr = PositionedError (SourceSpan name start end) (SimpleErrorWrapper (ErrorParsingModule perr)) +toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr) where name = (P.sourceName . P.errorPos) perr start = (toSourcePos . P.errorPos) perr diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 72dcbf73d6..9fd2ef276e 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -70,6 +70,7 @@ prettyPrintValue (Do els) = text "do " <> vcat left (map prettyPrintDoNotationElement els) prettyPrintValue (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys prettyPrintValue (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) +prettyPrintValue (TypedValue _ val _) = prettyPrintValue val prettyPrintValue (PositionedValue _ _ val) = prettyPrintValue val prettyPrintValue expr = prettyPrintValueAtom expr @@ -88,7 +89,7 @@ prettyPrintValueAtom (Constructor name) = text $ runProperName (disqualify name) prettyPrintValueAtom (Var ident) = text $ showIdent (disqualify ident) prettyPrintValueAtom (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue op) `beforeWithSpace` prettyPrintValue val) `before` text ")" prettyPrintValueAtom (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue val) `beforeWithSpace` prettyPrintValue op) `before` text ")" -prettyPrintValueAtom (TypedValue _ val _) = prettyPrintValue val +prettyPrintValueAtom (TypedValue _ val _) = prettyPrintValueAtom val prettyPrintValueAtom (PositionedValue _ _ val) = prettyPrintValueAtom val prettyPrintValueAtom expr = (text "(" <> prettyPrintValue expr) `before` text ")" diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index f06e3ba003..29e6706049 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -184,7 +184,7 @@ toBindingGroup moduleName (CyclicSCC ds') = cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n - cycleError d ds@(_:_) = rethrow (onErrorMessages (NotYetDefined (map getIdent ds))) $ cycleError d [] + cycleError d ds@(_:_) = rethrow (addHint (NotYetDefined (map getIdent ds))) $ cycleError d [] cycleError _ _ = error "Expected ValueDeclaration" toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index af7ab011aa..4a99da563d 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -50,7 +50,7 @@ isLeft (Right _) = False -- desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module] desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) -> - rethrow (onErrorMessages (ErrorInModule name)) $ + rethrow (addHint (ErrorInModule name)) $ Module ss coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 8135db9688..02eb03f483 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -98,7 +98,7 @@ desugarImports externs modules = do renameInModule' :: Env -> Module -> m Module renameInModule' env m@(Module _ _ mn _ _) = - rethrow (onErrorMessages (ErrorInModule mn)) $ do + rethrow (addHint (ErrorInModule mn)) $ do let (_, imps, exps) = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn env elaborateImports imps <$> renameInModule env imps (elaborateExports exps m) diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 14a443207d..34c16492bd 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -43,7 +43,7 @@ import Language.PureScript.Sugar.Names.Env -- findExportable :: forall m. (Applicative m, MonadError MultipleErrors m) => Module -> m Exports findExportable (Module _ _ mn ds _) = - rethrow (onErrorMessages (ErrorInModule mn)) $ foldM updateExports nullExports ds + rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds where updateExports :: Exports -> Declaration -> m Exports updateExports exps (TypeClassDeclaration tcn _ _ ds') = do @@ -67,7 +67,7 @@ findExportable (Module _ _ mn ds _) = -- resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports resolveExports env mn imps exps refs = - rethrow (onErrorMessages (ErrorInModule mn)) $ do + rethrow (addHint (ErrorInModule mn)) $ do filtered <- filterModule mn exps refs foldM elaborateModuleExports filtered refs diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index c2e3cf98db..0839ba08f7 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -64,7 +64,7 @@ findImports = foldM (go Nothing) M.empty -- resolveImports :: (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports resolveImports env (Module _ _ currentModule decls _) = - censor (onErrorMessages (ErrorInModule currentModule)) $ do + censor (addHint (ErrorInModule currentModule)) $ do scope <- M.insert currentModule [(Nothing, Implicit, Nothing)] <$> findImports decls foldM (resolveModuleImport currentModule env) nullImports (M.toList scope) diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index e32e83a3d7..767a4f62c1 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -102,7 +102,7 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m go [] = return () go [_] = return () go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y = - rethrow (onErrorMessages (ErrorInModule mn)) $ + rethrow (addHint (ErrorInModule mn)) $ rethrowWithPosition pos $ throwError . errorMessage $ MultipleFixities name go (_ : rest) = go rest diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index bda1de26d1..e393673df2 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -243,7 +243,7 @@ unit = TypeApp tyObject REmpty typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration typeInstanceDictionaryDeclaration name mn deps className tys decls = - rethrow (onErrorMessages (ErrorInInstance className tys)) $ do + rethrow (addHint (ErrorInInstance className tys)) $ do m <- get -- Lookup the type arguments and member types for the type class diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 7a1667f010..3416b81614 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -39,7 +39,7 @@ import Language.PureScript.Traversals -- desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module] desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) -> - rethrow (onErrorMessages (ErrorInModule name)) $ + rethrow (addHint (ErrorInModule name)) $ Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps -- | diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 63770d50ac..fda738c0bb 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -51,7 +51,7 @@ addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) } forM_ dctors $ \(dctor, tys) -> - warnAndRethrow (onErrorMessages (ErrorInDataConstructor dctor)) $ + warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $ addDataConstructor moduleName dtype name (map fst args) dctor tys addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check () @@ -137,7 +137,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix where go :: Declaration -> Check Declaration go (DataDeclaration dtype name args dctors) = do - warnAndRethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do + warnAndRethrow (addHint (ErrorInTypeConstructor name)) $ do when (dtype == Newtype) $ checkNewtype dctors checkDuplicateTypeArguments $ map fst args ctorKind <- kindsOf True moduleName name args (concatMap snd dctors) @@ -150,7 +150,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype checkNewtype _ = throwError . errorMessage $ InvalidNewtype go (d@(DataBindingGroupDeclaration tys)) = do - warnAndRethrow (onErrorMessages ErrorInDataBindingGroup) $ do + warnAndRethrow (addHint ErrorInDataBindingGroup) $ do let syns = mapMaybe toTypeSynonym tys let dataDecls = mapMaybe toDataDecl tys (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls) @@ -171,7 +171,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d' toDataDecl _ = Nothing go (TypeSynonymDeclaration name args ty) = do - warnAndRethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do + warnAndRethrow (addHint (ErrorInTypeSynonym name)) $ do checkDuplicateTypeArguments $ map fst args kind <- kindsOf False moduleName name args [ty] let args' = args `withKinds` kind @@ -179,14 +179,14 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix return $ TypeSynonymDeclaration name args ty go (TypeDeclaration{}) = error "Type declarations should have been removed" go (ValueDeclaration name nameKind [] (Right val)) = - warnAndRethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do + warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do valueIsNotDefined moduleName name [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)] addValue moduleName name ty nameKind return $ ValueDeclaration name nameKind [] $ Right val' go (ValueDeclaration{}) = error "Binders were not desugared" go (BindingGroupDeclaration vals) = - warnAndRethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do + warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do forM_ (map (\(ident, _, _) -> ident) vals) $ \name -> valueIsNotDefined moduleName name tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals @@ -203,7 +203,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) } return d go (d@(ExternDeclaration name ty)) = do - warnAndRethrow (onErrorMessages (ErrorInForeignImport name)) $ do + warnAndRethrow (addHint (ErrorInForeignImport name)) $ do env <- getEnv kind <- kindOf moduleName ty guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star @@ -269,7 +269,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix -- typeCheckModule :: Maybe ModuleName -> Module -> Check Module typeCheckModule _ (Module _ _ _ _ Nothing) = error "exports should have been elaborated" -typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRethrow (onErrorMessages (ErrorInModule mn)) $ do +typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do modify (\s -> s { checkCurrentModule = Just mn }) decls' <- typeCheckAll mainModuleName mn exps decls forM_ exps $ \e -> do diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 5cfe53ef6e..ea6febb574 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -83,7 +83,7 @@ kindOf _ ty = fst <$> kindOfWithScopedVars ty -- kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)]) kindOfWithScopedVars ty = - rethrow (onErrorMessages (ErrorCheckingKind ty)) $ + rethrow (addHint (ErrorCheckingKind ty)) $ fmap tidyUp . liftUnify $ infer ty where tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k) @@ -161,7 +161,7 @@ starIfUnknown k = k -- Infer a kind for a type -- infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)]) -infer ty = rethrow (onErrorMessages (ErrorCheckingKind ty)) $ infer' ty +infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)]) infer' (ForAll ident ty _) = do diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index f282e14cc9..c388b6fc42 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -92,7 +92,7 @@ skolemEscapeCheck root@TypedValue{} = let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def in case f root of [] -> return () - ((binding, val) : _) -> throwError . singleError $ ErrorInExpression val $ SimpleErrorWrapper $ EscapedSkolem binding + ((binding, val) : _) -> throwError . singleError $ ErrorMessage [ ErrorInExpression val ] $ EscapedSkolem binding where def s _ = (s, []) diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index b370a29aa9..8356812884 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -37,7 +37,7 @@ import Language.PureScript.Types -- Check whether one type subsumes another, rethrowing errors to provide a better error message -- subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr) -subsumes val ty1 ty2 = rethrow (onErrorMessages (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2 +subsumes val ty1 ty2 = rethrow (addHint (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2 -- | -- Check whether one type subsumes another diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 71a24226f8..8555b28d8e 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -50,7 +50,7 @@ buildTypeSubstitution m = go 0 [] where go :: Int -> [Type] -> Type -> Either ErrorMessage (Maybe Type) go c args (TypeConstructor ctor) | M.lookup ctor m == Just c = return (Just $ SaturatedTypeSynonym ctor args) - go c _ (TypeConstructor ctor) | M.lookup ctor m > Just c = throwError $ SimpleErrorWrapper $ PartiallyAppliedSynonym ctor + go c _ (TypeConstructor ctor) | M.lookup ctor m > Just c = throwError $ ErrorMessage [] $ PartiallyAppliedSynonym ctor go c args (TypeApp f arg) = go (c + 1) (arg:args) f go _ _ _ = return Nothing diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 3356f7f6b2..a31bb2c68e 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -103,7 +103,7 @@ typesOf mainModuleName moduleName vals = do -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts -- Replace all the wildcards types with their inferred types - replace sub (SimpleErrorWrapper (WildcardInferredType ty)) = SimpleErrorWrapper $ WildcardInferredType (sub $? ty) + replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty) replace _ em = em -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a checkMain nm ty = when (Just moduleName == mainModuleName && nm == Ident C.main) $ do @@ -214,7 +214,7 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty) -- Infer a type for a value, rethrowing any error to provide a more useful error message -- infer :: Expr -> UnifyT Type Check Expr -infer val = rethrow (onErrorMessages (ErrorInferringType val)) $ infer' val +infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val -- | -- Infer a type for a value @@ -457,7 +457,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do -- Check the type of a value, rethrowing errors to provide a better error message -- check :: Expr -> Type -> UnifyT Type Check Expr -check val ty = rethrow (onErrorMessages (ErrorCheckingType val ty)) $ check' val ty +check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty -- | -- Check the type of a value @@ -646,7 +646,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where -- Check the type of a function application, rethrowing errors to provide a better error message -- checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr) -checkFunctionApplication fn fnTy arg ret = rethrow (onErrorMessages (ErrorInApplication fn fnTy arg)) $ do +checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication fn fnTy arg)) $ do subst <- unifyCurrentSubstitution <$> UnifyT get checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret) diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 1e55f3aa74..ad12a117bb 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -63,7 +63,7 @@ instance Unifiable Check Type where -- Unify two types, updating the current substitution -- unifyTypes :: Type -> Type -> UnifyT Type Check () -unifyTypes t1 t2 = rethrow (onErrorMessages (ErrorUnifyingTypes t1 t2)) $ +unifyTypes t1 t2 = rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ unifyTypes' t1 t2 where unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return () From 4eb79ad6f8c0b187603d0b52e3d6fe6a93f2c0a6 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 11 Oct 2015 13:39:43 -0700 Subject: [PATCH 0045/1580] Fix #1261 --- src/Language/PureScript/Linter/Exhaustive.hs | 47 ++++++++++++-------- 1 file changed, 28 insertions(+), 19 deletions(-) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 3303b8e12b..c869b3858c 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -46,8 +46,6 @@ import Language.PureScript.Kinds import Language.PureScript.Types as P import Language.PureScript.Errors -import Language.PureScript.AST.Traversals (everywhereOnValuesTopDownM) - -- | There are two modes of failure for the redudancy check: -- -- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy. @@ -273,25 +271,36 @@ checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([init -- Exhaustivity checking over a list of declarations -- checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m () -checkExhaustiveDecls env mn ds = - let (f, _, _) = everywhereOnValuesTopDownM return checkExpr return +checkExhaustiveDecls env mn = mapM_ onDecl + where + onDecl :: Declaration -> m () + onDecl (BindingGroupDeclaration bs) = mapM_ (onDecl . convert) bs + where + convert :: (Ident, NameKind, Expr) -> Declaration + convert (name, nk, e) = ValueDeclaration name nk [] (Right e) + onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr e) + onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec) + onDecl _ = return () - f' :: Declaration -> m Declaration - f' d@(BindingGroupDeclaration bs) = mapM_ (f' . convert) bs >> return d - where - convert :: (Ident, NameKind, Expr) -> Declaration - convert (name, nk, e) = ValueDeclaration name nk [] (Right e) - f' d@(ValueDeclaration name _ _ _) = censor (addHint (ErrorInValueDeclaration name)) $ f d - f' (PositionedDeclaration pos com dec) = PositionedDeclaration pos com <$> censor (addHint (PositionedError pos)) (f' dec) - -- Don't generate two warnings for desugared dictionaries. - f' d@TypeInstanceDeclaration{} = return d - f' d = f d + onExpr :: Expr -> m () + onExpr (UnaryMinus e) = onExpr e + onExpr (ArrayLiteral es) = mapM_ onExpr es + onExpr (ObjectLiteral es) = mapM_ (onExpr . snd) es + onExpr (TypeClassDictionaryConstructorApp _ e) = onExpr e + onExpr (Accessor _ e) = onExpr e + onExpr (ObjectUpdate o es) = onExpr o >> mapM_ (onExpr . snd) es + onExpr (Abs _ e) = onExpr e + onExpr (App e1 e2) = onExpr e1 >> onExpr e2 + onExpr (IfThenElse e1 e2 e3) = onExpr e1 >> onExpr e2 >> onExpr e3 + onExpr (Case es cas) = checkExhaustive env mn (length es) cas >> mapM_ onCaseAlternative cas + onExpr (TypedValue _ e _) = onExpr e + onExpr (Let ds e) = mapM_ onDecl ds >> onExpr e + onExpr (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr e) + onExpr _ = return () - in mapM_ f' ds - where - checkExpr :: Expr -> m Expr - checkExpr c@(Case expr cas) = checkExhaustive env mn (length expr) cas >> return c - checkExpr other = return other + onCaseAlternative :: CaseAlternative -> m () + onCaseAlternative (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr e >> onExpr g) es + onCaseAlternative (CaseAlternative _ (Right e)) = onExpr e -- | -- Exhaustivity checking over a single module From 0f5cf75bad60eed760df0798a52638714aab18ca Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 11 Oct 2015 14:30:59 -0700 Subject: [PATCH 0046/1580] Warnings for missing top-level type declarations, fix #1333 --- src/Language/PureScript/Errors.hs | 8 +++ .../PureScript/Sugar/TypeDeclarations.hs | 63 ++++++++++--------- 2 files changed, 41 insertions(+), 30 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 5f9a109ead..4f165f393f 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -141,6 +141,7 @@ data SimpleErrorMessage | ShadowedTypeVar String | UnusedTypeVar String | WildcardInferredType Type + | MissingTypeDeclaration Ident | NotExhaustivePattern [[Binder]] Bool | OverlappingPattern [[Binder]] Bool | IncompleteExhaustivityCheck @@ -279,6 +280,7 @@ errorCode em = case unwrapErrorMessage em of ShadowedTypeVar{} -> "ShadowedTypeVar" UnusedTypeVar{} -> "UnusedTypeVar" WildcardInferredType{} -> "WildcardInferredType" + MissingTypeDeclaration{} -> "MissingTypeDeclaration" NotExhaustivePattern{} -> "NotExhaustivePattern" OverlappingPattern{} -> "OverlappingPattern" IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck" @@ -660,6 +662,12 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir paras [ line "The wildcard type definition has the inferred type " , indent $ typeAsBox ty ] + renderSimpleErrorMessage (MissingTypeDeclaration ident) = + paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "." + , line "It is good practice to provide type declarations as a form of documentation." + , line "Consider using a type wildcard to display the inferred type:" + , indent $ line $ showIdent ident ++ " :: _" + ] renderSimpleErrorMessage (NotExhaustivePattern bs b) = paras $ [ line "A case expression could not be determined to cover all inputs." , line "The following additional cases are required to cover all inputs:\n" diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 3416b81614..0311c78a90 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -15,10 +15,10 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module Language.PureScript.Sugar.TypeDeclarations ( - desugarTypeDeclarations, desugarTypeDeclarationsModule ) where @@ -27,6 +27,7 @@ import Control.Applicative #endif import Control.Monad (forM) import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class (MonadWriter(tell)) import Language.PureScript.AST import Language.PureScript.Names @@ -37,36 +38,38 @@ import Language.PureScript.Traversals -- | -- Replace all top level type declarations in a module with type annotations -- -desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module] +desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module] desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) -> rethrow (addHint (ErrorInModule name)) $ Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps - --- | --- Replace all top level type declarations with type annotations --- -desugarTypeDeclarations :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] -desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do - (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds) - return (PositionedDeclaration pos com d' : ds') -desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do - (_, nameKind, val) <- fromValueDeclaration d - desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest) where - fromValueDeclaration :: (Functor m, Applicative m, MonadError MultipleErrors m) => Declaration -> m (Ident, NameKind, Expr) - fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val) - fromValueDeclaration (PositionedDeclaration pos com d') = do - (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d' - return (ident, nameKind, PositionedValue pos com val) - fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name -desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name -desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do - let (_, f, _) = everywhereOnValuesTopDownM return go return - f' (Left gs) = Left <$> mapM (pairM return f) gs - f' (Right v) = Right <$> f v - (:) <$> (ValueDeclaration name nameKind bs <$> f' 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 [] + + desugarTypeDeclarations :: [Declaration] -> m [Declaration] + desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do + (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds) + return (PositionedDeclaration pos com d' : ds') + desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do + (_, nameKind, val) <- fromValueDeclaration d + desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest) + where + fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr) + fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val) + fromValueDeclaration (PositionedDeclaration pos com d') = do + (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d' + return (ident, nameKind, PositionedValue pos com val) + fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name + desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name + desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do + case val of + Right TypedValue{} -> return () + Left _ -> error "desugarTypeDeclarations: cases were not desugared" + _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name) + let (_, f, _) = everywhereOnValuesTopDownM return go return + f' (Left gs) = Left <$> mapM (pairM return f) gs + f' (Right v) = Right <$> f v + (:) <$> (ValueDeclaration name nameKind bs <$> f' 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 [] From 1e3b1ec68e6833d5ec4e51e6e490c62bf6033a6f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 11 Oct 2015 15:09:38 -0700 Subject: [PATCH 0047/1580] Remove inferProperty judgment --- src/Language/PureScript/TypeChecker/Types.hs | 28 +++----------------- 1 file changed, 4 insertions(+), 24 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index a31bb2c68e..5217ce86f2 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -246,15 +246,10 @@ infer' (ObjectUpdate o ps) = do o' <- TypedValue True <$> check o oldTy <*> pure oldTy 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 - case propTy of - Nothing -> do - field <- fresh - rest <- fresh - _ <- 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 + field <- fresh + rest <- fresh + typed <- check val (TypeApp tyObject (RCons prop field rest)) + return $ TypedValue True (Accessor prop typed) field infer' (Abs (Left arg) ret) = do ty <- fresh Just moduleName <- checkCurrentModule <$> get @@ -339,21 +334,6 @@ inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethr return (PositionedDeclaration pos com d' : ds', val') inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding" --- | --- Infer the type of a property inside a record with a given type --- -inferProperty :: Type -> String -> UnifyT Type Check (Maybe Type) -inferProperty (TypeApp obj row) prop | obj == tyObject = do - let (props, _) = rowToList row - return $ lookup prop props -inferProperty (SaturatedTypeSynonym name args) prop = do - replaced <- introduceSkolemScope <=< expandTypeSynonym name $ args - inferProperty replaced prop -inferProperty (ForAll ident ty _) prop = do - replaced <- replaceVarWithUnknown ident ty - inferProperty replaced prop -inferProperty _ _ = return Nothing - -- | -- Infer the types of variables brought into scope by a binder -- From 1dcf381952612b5a21236bbc125df8e70768e371 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 12 Oct 2015 16:45:39 -0700 Subject: [PATCH 0048/1580] Only warn on top-level declarations #1333 --- .../PureScript/Sugar/TypeDeclarations.hs | 35 ++++++++++--------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 0311c78a90..f6ecf37509 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -25,7 +25,7 @@ module Language.PureScript.Sugar.TypeDeclarations ( #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif -import Control.Monad (forM) +import Control.Monad (forM, when) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(tell)) @@ -41,16 +41,16 @@ import Language.PureScript.Traversals desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module] desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) -> rethrow (addHint (ErrorInModule name)) $ - Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps + Module ss coms name <$> desugarTypeDeclarations True ds <*> pure exps where - desugarTypeDeclarations :: [Declaration] -> m [Declaration] - desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do - (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds) + desugarTypeDeclarations :: Bool -> [Declaration] -> m [Declaration] + desugarTypeDeclarations reqd (PositionedDeclaration pos com d : ds) = do + (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations reqd (d : ds) return (PositionedDeclaration pos com d' : ds') - desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do + desugarTypeDeclarations reqd (TypeDeclaration name ty : d : rest) = do (_, nameKind, val) <- fromValueDeclaration d - desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest) + desugarTypeDeclarations reqd (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest) where fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr) fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val) @@ -58,18 +58,19 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) -> (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d' return (ident, nameKind, PositionedValue pos com val) fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name - desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name - desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do - case val of - Right TypedValue{} -> return () - Left _ -> error "desugarTypeDeclarations: cases were not desugared" - _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name) + desugarTypeDeclarations _ [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name + desugarTypeDeclarations reqd (ValueDeclaration name nameKind bs val : rest) = do + -- At the top level, match a type signature or emit a warning. + when reqd $ case val of + Right TypedValue{} -> return () + Left _ -> error "desugarTypeDeclarations: cases were not desugared" + _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name) let (_, f, _) = everywhereOnValuesTopDownM return go return f' (Left gs) = Left <$> mapM (pairM return f) gs f' (Right v) = Right <$> f v - (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest + (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations reqd rest where - go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val' + go (Let ds val') = Let <$> desugarTypeDeclarations False ds <*> pure val' go other = return other - desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds - desugarTypeDeclarations [] = return [] + desugarTypeDeclarations reqd (d:ds) = (:) d <$> desugarTypeDeclarations reqd ds + desugarTypeDeclarations _ [] = return [] From 3fa95cc6e4e814d71d52e24062d6e9ecef3c16d3 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 13 Oct 2015 20:46:58 +0200 Subject: [PATCH 0049/1580] changes the recommended build tool to stack fixes #1446, because stack takes care of installing alex and happy. --- INSTALL.md | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/INSTALL.md b/INSTALL.md index 6611709570..5e4bc78648 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -24,15 +24,25 @@ requirements. ## Compiling from source GHC 7.6.1 or newer is required to compile from source. The easiest way is to -use `cabal-install`: +use stack: ``` -$ cabal update && cabal install purescript +$ stack install purescript ``` +This will then copy the compiler and utilities into `~/.local/bin`. + + +If you don't have stack installed yet there are install instructions +[here](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md). + +If you don't have ghc installed yet, stack will prompt you to run `stack setup` +which will install ghc for you. + The PureScript compiler has been known to run on OS X 10.6 when built with GHC 7.6. + ## The "curses" library `psci` depends on the `curses` library (via the Haskell package `terminfo`). If From 93fd3b7196c07497961bc518edbb0e31d0900cf0 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 13 Oct 2015 16:07:04 -0700 Subject: [PATCH 0050/1580] Recurse into case expressions when checking exhaustivity --- .gitignore | 1 + src/Language/PureScript/Linter/Exhaustive.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 3be7b04c51..c5a67d110c 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,4 @@ node_modules tmp/ .stack-work/ tests/support/flattened/ +output diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index c869b3858c..43af289806 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -292,7 +292,7 @@ checkExhaustiveDecls env mn = mapM_ onDecl onExpr (Abs _ e) = onExpr e onExpr (App e1 e2) = onExpr e1 >> onExpr e2 onExpr (IfThenElse e1 e2 e3) = onExpr e1 >> onExpr e2 >> onExpr e3 - onExpr (Case es cas) = checkExhaustive env mn (length es) cas >> mapM_ onCaseAlternative cas + onExpr (Case es cas) = checkExhaustive env mn (length es) cas >> mapM_ onExpr es >> mapM_ onCaseAlternative cas onExpr (TypedValue _ e _) = onExpr e onExpr (Let ds e) = mapM_ onDecl ds >> onExpr e onExpr (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr e) From f61d03fe7c72b8f8d294fbe40619a9dac57f86fb Mon Sep 17 00:00:00 2001 From: Benjamin Kovach Date: Mon, 28 Sep 2015 15:18:16 -0400 Subject: [PATCH 0051/1580] Add Typed Binders --- examples/failing/TypedBinders.purs | 10 +++ examples/failing/TypedBinders2.purs | 9 +++ examples/failing/TypedBinders3.purs | 12 ++++ examples/passing/TypedBinders.purs | 62 +++++++++++++++++++ src/Language/PureScript/AST/Binders.hs | 8 ++- src/Language/PureScript/AST/Traversals.hs | 6 ++ src/Language/PureScript/CoreFn/Desugar.hs | 2 + src/Language/PureScript/Linter.hs | 1 + .../PureScript/Parser/Declarations.hs | 4 +- src/Language/PureScript/Pretty/Values.hs | 1 + src/Language/PureScript/Sugar/Names.hs | 4 ++ src/Language/PureScript/TypeChecker/Types.hs | 1 + 12 files changed, 118 insertions(+), 2 deletions(-) create mode 100644 examples/failing/TypedBinders.purs create mode 100644 examples/failing/TypedBinders2.purs create mode 100644 examples/failing/TypedBinders3.purs create mode 100644 examples/passing/TypedBinders.purs diff --git a/examples/failing/TypedBinders.purs b/examples/failing/TypedBinders.purs new file mode 100644 index 0000000000..bbe1ce6702 --- /dev/null +++ b/examples/failing/TypedBinders.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +import Prelude + +test = (\f :: Int -> Int -> f 10) id + +main = do + let t1 = test + Control.Monad.Eff.Console.log "Done" \ No newline at end of file diff --git a/examples/failing/TypedBinders2.purs b/examples/failing/TypedBinders2.purs new file mode 100644 index 0000000000..21b5caf470 --- /dev/null +++ b/examples/failing/TypedBinders2.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prelude + +main = do + s :: String <- Control.Monad.Eff.Console.log "Foo" + Control.Monad.Eff.Console.log "Done" + diff --git a/examples/failing/TypedBinders3.purs b/examples/failing/TypedBinders3.purs new file mode 100644 index 0000000000..14987bcb63 --- /dev/null +++ b/examples/failing/TypedBinders3.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prelude + +test = case 1 of + (0 :: String) -> true + _ -> false + +main = do + let t = test + Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/TypedBinders.purs b/examples/passing/TypedBinders.purs new file mode 100644 index 0000000000..ff66e4d3fd --- /dev/null +++ b/examples/passing/TypedBinders.purs @@ -0,0 +1,62 @@ +module Main where + +import Prelude + +data Tuple a b = Tuple a b + +class MonadState s m where + get :: m s + put :: s -> m {} + +data State s a = State (s -> Tuple s a) + +runState s (State f) = f s + +instance functorState :: Functor (State s) where + map = liftM1 + +instance applyState :: Apply (State s) where + apply = ap + +instance applicativeState :: Applicative (State s) where + pure a = State $ \s -> Tuple s a + +instance bindState :: Bind (State s) where + bind f g = State $ \s -> case runState s f of + Tuple s1 a -> runState s1 (g a) + +instance monadState :: Monad (State s) + +instance monadStateState :: MonadState s (State s) where + get = State (\s -> Tuple s s) + put s = State (\_ -> Tuple s {}) + +modify :: forall m s. (Prelude.Monad m, MonadState s m) => (s -> s) -> m {} +modify f = do + s <- get + put (f s) + +test :: Tuple String String +test = runState "" $ do + modify $ (++) "World!" + modify $ (++) "Hello, " + str :: String <- get + return str + +test2 :: (Int -> Int) -> Int +test2 = (\(f :: Int -> Int) -> f 10) + +test3 :: Int -> Boolean +test3 n = case n of + (0 :: Int) -> true + _ -> false + +test4 :: Tuple Int Int -> Tuple Int Int +test4 = (\(Tuple a b :: Tuple Int Int) -> Tuple b a) + +main = do + let t1 = test + t2 = test2 id + t3 = test3 1 + t4 = test4 (Tuple 1 0) + Control.Monad.Eff.Console.log "Done" \ No newline at end of file diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index a827a578a9..d228bf6fc8 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -21,6 +21,7 @@ import qualified Data.Data as D import Language.PureScript.AST.SourcePos import Language.PureScript.Names import Language.PureScript.Comments +import Language.PureScript.Types -- | -- Data type for binders @@ -69,7 +70,11 @@ data Binder -- | -- A binder with source position information -- - | PositionedBinder SourceSpan [Comment] Binder deriving (Show, Read, Eq, D.Data, D.Typeable) + | PositionedBinder SourceSpan [Comment] Binder + -- | + -- A binder with a type annotation + -- + | TypedBinder Type Binder deriving (Show, Read, Eq, D.Data, D.Typeable) -- | -- Collect all names introduced in binders in an expression @@ -83,4 +88,5 @@ binderNames = go [] go ns (ArrayBinder bs) = foldl go ns bs go ns (NamedBinder name b) = go (name : ns) b go ns (PositionedBinder _ _ b) = go ns b + go ns (TypedBinder _ b) = go ns b go ns _ = ns diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index b05867b70e..6e90f5d5ae 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -79,6 +79,7 @@ everywhereOnValues f g h = (f', g', h') h' (ArrayBinder bs) = h (ArrayBinder (map h' bs)) h' (NamedBinder name b) = h (NamedBinder name (h' b)) h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b)) + h' (TypedBinder t b) = h (TypedBinder t (h' b)) h' other = h other handleCaseAlternative :: CaseAlternative -> CaseAlternative @@ -135,6 +136,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h') h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h') + h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h') h' other = h other handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs @@ -187,6 +189,7 @@ everywhereOnValuesM f g h = (f', g', h') h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h + h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h h' other = h other handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs @@ -242,6 +245,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs) h' b@(NamedBinder _ b1) = h b <> h' b1 h' b@(PositionedBinder _ _ b1) = h b <> h' b1 + h' b@(TypedBinder _ b1) = h b <> h' b1 h' b = h b i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val @@ -310,6 +314,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs) h' s (NamedBinder _ b1) = h'' s b1 h' s (PositionedBinder _ _ b1) = h'' s b1 + h' s (TypedBinder _ b1) = h'' s b1 h' _ _ = r0 i'' s ca = let (s', r) = i s ca in r <> i' s' ca @@ -379,6 +384,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs h' s (NamedBinder name b) = NamedBinder name <$> h'' s b h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b + h' s (TypedBinder t b) = TypedBinder t <$> h'' s b h' _ other = return other i'' s = uncurry i' <=< i s diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index e5ed85747a..f691589241 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -166,6 +166,8 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b) binderToCoreFn _ com (A.PositionedBinder ss com1 b) = binderToCoreFn (Just ss) (com ++ com1) b + binderToCoreFn ss com (A.TypedBinder _ b) = + binderToCoreFn ss com b -- | -- Gets metadata for values. diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 6da6e5051a..052d21842f 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -86,6 +86,7 @@ lint (Module _ _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors) stepB s (VarBinder name) = bindName s name stepB s (NamedBinder name _) = bindName s name + stepB s (TypedBinder _ b) = stepB s b stepB s _ = (s, mempty) bindName :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 0c8963bd8b..3343e26d42 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -525,10 +525,12 @@ parseIdentifierAndBinder = do -- Parse a binder -- parseBinder :: TokenParser Binder -parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators parseBinderAtom) +parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators (buildPostfixParser postfixTable parseBinderAtom)) where -- TODO: remove this deprecation warning in 0.8 operators = [ [ P.Infix (P.try $ C.indented *> colon *> featureWasRemoved "Cons binders are no longer supported. Consider using purescript-lists or purescript-sequences instead.") P.AssocRight ] ] + postfixTable = [ \b -> flip TypedBinder b <$> (P.try (indented *> doubleColon) *> parseType) + ] parseBinderAtom :: TokenParser Binder parseBinderAtom = P.choice (map P.try [ parseNullBinder diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 68892732e7..385886a484 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -219,4 +219,5 @@ prettyPrintBinder :: Binder -> String prettyPrintBinder (ConstructorBinder ctor []) = showQualified runProperName ctor prettyPrintBinder (ConstructorBinder ctor args) = showQualified runProperName ctor ++ " " ++ unwords (map prettyPrintBinderAtom args) prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder +prettyPrintBinder (TypedBinder ty binder) = prettyPrintType ty ++ " :: " ++ prettyPrintBinder binder prettyPrintBinder b = prettyPrintBinderAtom b diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index cd4c97630c..01d9dcbbd9 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -190,6 +190,10 @@ renameInModule env imports (Module ss coms mn decls exps) = return ((Just pos, bound), v) updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b) + updateBinder s (TypedBinder t b) = do + (s'@ (span', _), b') <- updateBinder s b + t' <- updateTypesEverywhere span' t + return (s', TypedBinder t' b') updateBinder s v = return (s, v) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index b2bf4532ad..659947d950 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -407,6 +407,7 @@ inferBinder val (NamedBinder name binder) = do return $ M.insert name val m inferBinder val (PositionedBinder pos _ binder) = warnAndRethrowWithPosition pos $ inferBinder val binder +inferBinder val (TypedBinder ty binder) = val =?= ty >> inferBinder val binder -- | Returns true if a binder requires its argument type to be a monotype. -- | If this is the case, we need to instantiate any polymorphic types before checking binders. From abcc3ccb19a92600d43c1af0bf0d9fcb59e39cea Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Wed, 14 Oct 2015 15:20:47 +0100 Subject: [PATCH 0052/1580] Don't require that all types are exported --- src/Language/PureScript/TypeChecker.hs | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 6e6f52de2d..6fde231a06 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -273,7 +273,6 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint modify (\s -> s { checkCurrentModule = Just mn }) decls' <- typeCheckAll mn exps decls forM_ exps $ \e -> do - checkTypesAreExported e checkClassMembersAreExported e checkClassesAreExported e return $ Module ss coms mn decls' (Just exps) @@ -295,17 +294,6 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint exports _ _ = False checkMemberExport _ _ = return () - -- Check that all the type constructors defined in the current module that appear in member types - -- have also been exported from the module - checkTypesAreExported :: DeclarationRef -> Check () - checkTypesAreExported = checkMemberExport findTcons - where - findTcons :: Type -> [DeclarationRef] - findTcons = everythingOnTypes (++) go - where - go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (error "Data constructors unused in checkTypesAreExported")] - go _ = [] - -- Check that all the classes defined in the current module that appear in member types have also -- been exported from the module checkClassesAreExported :: DeclarationRef -> Check () From ad0dcb7235e941b130e954f723492105f65798c8 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 14 Oct 2015 08:31:23 -0700 Subject: [PATCH 0053/1580] Fix #1524, render kinds as single line strings. --- src/Language/PureScript/Errors.hs | 8 +++---- src/Language/PureScript/Pretty/Kinds.hs | 29 ++++++++++--------------- src/Language/PureScript/Pretty/Types.hs | 2 +- 3 files changed, 17 insertions(+), 22 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 4d52208f24..4b60d799ed 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -447,7 +447,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir ] renderSimpleErrorMessage (InfiniteKind ki) = paras [ line "An infinite kind was inferred for a type: " - , indent $ kindAsBox ki + , indent $ line $ prettyPrintKind ki ] renderSimpleErrorMessage (MultipleFixities name) = line $ "Multiple fixity declarations for " ++ showIdent name @@ -542,9 +542,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir ] renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = paras [ line "Cannot unify kind" - , indent $ kindAsBox k1 + , indent $ line $ prettyPrintKind k1 , line "with kind" - , indent $ kindAsBox k2 + , indent $ line $ prettyPrintKind k2 ] renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) = paras [ line "Cannot unify constrained type" @@ -604,7 +604,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , line "The error arises from the type" , indent $ typeAsBox ty , line "having the kind" - , indent $ kindAsBox kind + , indent $ line $ prettyPrintKind kind , line "instead." ] renderSimpleErrorMessage (IncorrectConstructorArity nm) = diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs index 57c3d6fb9d..236dd56465 100644 --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -14,8 +14,7 @@ ----------------------------------------------------------------------------- module Language.PureScript.Pretty.Kinds ( - prettyPrintKind, - kindAsBox + prettyPrintKind ) where import Data.Maybe (fromMaybe) @@ -24,15 +23,14 @@ import Control.Arrow (ArrowPlus(..)) import Control.PatternArrows import Language.PureScript.Kinds +import Language.PureScript.Pretty.Common -import Text.PrettyPrint.Boxes (Box(), text, render, (<>)) - -typeLiterals :: Pattern () Kind Box +typeLiterals :: Pattern () Kind String typeLiterals = mkPattern match where - match Star = Just $ text "*" - match Bang = Just $ text "!" - match (KUnknown u) = Just $ text $ 'u' : show u + match Star = Just "*" + match Bang = Just "!" + match (KUnknown u) = Just $ 'u' : show u match _ = Nothing matchRow :: Pattern () Kind ((), Kind) @@ -49,15 +47,12 @@ funKind = mkPattern match -- | Generate a pretty-printed string representing a Kind prettyPrintKind :: Kind -> String -prettyPrintKind = render . kindAsBox - -kindAsBox :: Kind -> Box -kindAsBox = fromMaybe (error "Incomplete pattern") . pattern matchKind () +prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind () where - matchKind :: Pattern () Kind Box - matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap ((text "(" <>) . (<> text ")")) matchKind) + matchKind :: Pattern () Kind String + matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind) - operators :: OperatorTable () Kind Box + operators :: OperatorTable () Kind String operators = - OperatorTable [ [ Wrap matchRow $ \_ k -> text "# " <> k] - , [ AssocR funKind $ \arg ret -> arg <> text " -> " <> ret ] ] + OperatorTable [ [ Wrap matchRow $ \_ k -> "# " ++ k] + , [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ] diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index c7af21904c..f901486b29 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -124,7 +124,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret) ] , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ] - , [ Wrap kinded $ \k ty -> ty `before` (text " :: " <> kindAsBox k) ] + , [ Wrap kinded $ \k ty -> ty `before` (text (" :: " ++ prettyPrintKind k)) ] ] forall_ :: Pattern () Type ([String], Type) From 24d5d0e1c0e8bfbb145592a7ce930bed8fed983d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 14 Oct 2015 18:31:48 -0700 Subject: [PATCH 0054/1580] Kind check constraint contexts, fix #1071 --- examples/failing/1071.purs | 8 ++++++++ src/Language/PureScript/Pretty/Types.hs | 12 +++++++----- src/Language/PureScript/TypeChecker/Kinds.hs | 4 ++-- 3 files changed, 17 insertions(+), 7 deletions(-) create mode 100644 examples/failing/1071.purs diff --git a/examples/failing/1071.purs b/examples/failing/1071.purs new file mode 100644 index 0000000000..806f51a8f0 --- /dev/null +++ b/examples/failing/1071.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +class Foo a b where + foo :: a -> b + +bar :: forall a. (Foo a) => a -> a +bar a = a diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index c7af21904c..dc403609d9 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -45,15 +45,17 @@ typeLiterals = mkPattern match match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor match (TUnknown u) = Just $ text $ '_' : show u match (Skolem name s _) = Just $ text $ name ++ show s - match (ConstrainedType deps ty) = Just $ constraintsAsBox deps `before` (text ") => " <> typeAsBox ty) + match (ConstrainedType deps ty) = Just $ constraintsAsBox deps ty match REmpty = Just $ text "()" match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row match _ = Nothing -constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box -constraintsAsBox = vcat left . zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] - where - constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys) +constraintsAsBox :: [(Qualified ProperName, [Type])] -> Type -> Box +constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> typeAsBox ty +constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> typeAsBox ty) + +constraintAsBox :: Qualified ProperName -> [Type] -> Box +constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys) -- | -- Generate a pretty-printed string representing a Row diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index ea6febb574..26c2e8757e 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -215,8 +215,8 @@ infer' other = (, []) <$> go other return $ Row k1 go (ConstrainedType deps ty) = do forM_ deps $ \(className, tys) -> do - _ <- go $ foldl TypeApp (TypeConstructor className) tys - return () + k <- go $ foldl TypeApp (TypeConstructor className) tys + k =?= Star k <- go ty k =?= Star return Star From 4fc4a02f13ed87935341eaef8f8fb30003c1043a Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Thu, 15 Oct 2015 17:02:22 +0100 Subject: [PATCH 0055/1580] Revert "Don't require that all types are exported" --- src/Language/PureScript/TypeChecker.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 6fde231a06..6e6f52de2d 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -273,6 +273,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint modify (\s -> s { checkCurrentModule = Just mn }) decls' <- typeCheckAll mn exps decls forM_ exps $ \e -> do + checkTypesAreExported e checkClassMembersAreExported e checkClassesAreExported e return $ Module ss coms mn decls' (Just exps) @@ -294,6 +295,17 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint exports _ _ = False checkMemberExport _ _ = return () + -- Check that all the type constructors defined in the current module that appear in member types + -- have also been exported from the module + checkTypesAreExported :: DeclarationRef -> Check () + checkTypesAreExported = checkMemberExport findTcons + where + findTcons :: Type -> [DeclarationRef] + findTcons = everythingOnTypes (++) go + where + go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (error "Data constructors unused in checkTypesAreExported")] + go _ = [] + -- Check that all the classes defined in the current module that appear in member types have also -- been exported from the module checkClassesAreExported :: DeclarationRef -> Check () From 91130e412355c9035c59c2eca74b14b42ba7f2c2 Mon Sep 17 00:00:00 2001 From: Benjamin Kovach Date: Thu, 15 Oct 2015 16:10:52 -0400 Subject: [PATCH 0056/1580] Fix a silly mistake --- src/Language/PureScript/Pretty/Values.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 385886a484..eb47d564fb 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -219,5 +219,5 @@ prettyPrintBinder :: Binder -> String prettyPrintBinder (ConstructorBinder ctor []) = showQualified runProperName ctor prettyPrintBinder (ConstructorBinder ctor args) = showQualified runProperName ctor ++ " " ++ unwords (map prettyPrintBinderAtom args) prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder -prettyPrintBinder (TypedBinder ty binder) = prettyPrintType ty ++ " :: " ++ prettyPrintBinder binder +prettyPrintBinder (TypedBinder ty binder) = prettyPrintBinder binder ++ " :: " ++ prettyPrintType ty prettyPrintBinder b = prettyPrintBinderAtom b From 3492dd5d606472b4e3cf9b35e04fbe53e745c858 Mon Sep 17 00:00:00 2001 From: Benjamin Kovach Date: Thu, 15 Oct 2015 18:11:00 -0400 Subject: [PATCH 0057/1580] Merge with master + fix error --- src/Language/PureScript/Pretty/Values.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 31eae5be08..c5ca10728c 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -28,7 +28,7 @@ import Control.Arrow (second) import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Pretty.Common -import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox) +import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox, prettyPrintType) import Text.PrettyPrint.Boxes @@ -129,6 +129,7 @@ prettyPrintDoNotationElement (DoNotationLet ds) = prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el prettyPrintBinderAtom :: Binder -> String + prettyPrintBinderAtom NullBinder = "_" prettyPrintBinderAtom (StringBinder str) = show str prettyPrintBinderAtom (CharBinder c) = show c @@ -159,5 +160,6 @@ prettyPrintBinder :: Binder -> String prettyPrintBinder (ConstructorBinder ctor []) = runProperName (disqualify ctor) prettyPrintBinder (ConstructorBinder ctor args) = runProperName (disqualify ctor) ++ " " ++ unwords (map prettyPrintBinderAtom args) prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder -prettyPrintBinder (TypedBinder ty binder) = prettyPrintBinder binder ++ " :: " ++ prettyPrintType ty +prettyPrintBinder (TypedBinder ty binder) = + prettyPrintBinder binder ++ " :: " ++ prettyPrintType ty prettyPrintBinder b = prettyPrintBinderAtom b From b8dd46b9630e9c349aec4fd073eb9cc906de9590 Mon Sep 17 00:00:00 2001 From: Konstantin Zudov Date: Fri, 16 Oct 2015 03:20:21 +0300 Subject: [PATCH 0058/1580] Include stack files in the distribution --- purescript.cabal | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/purescript.cabal b/purescript.cabal index 41e8ab7bf9..9c9801fb01 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -25,6 +25,10 @@ extra-source-files: examples/passing/*.purs , tests/support/bower.json , tests/support/setup-win.cmd , psci/tests/data/Sample.purs + , stack.yaml + , stack-lts-2.yaml + , stack-lts-3.yaml + , stack-nightly.yaml source-repository head type: git From bfc986c3fba81069e2377eb5d50702d0430d467e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 15 Oct 2015 17:33:51 -0700 Subject: [PATCH 0059/1580] Don't deploy from coverage build --- .travis.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index f62a8ecd91..a759b326ef 100644 --- a/.travis.yml +++ b/.travis.yml @@ -15,7 +15,7 @@ matrix: - env: GHCVER=7.6.3 compiler: ": #GHC 7.6.3" addons: {apt: {packages: [cabal-install-1.22,ghc-7.6.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.10.1 + - env: GHCVER=7.10.1 DEPLOY=yes compiler: ": #GHC 7.10.1" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - env: GHCVER=7.10.2 STACKAGE=lts=3.6 RUNSDISTTESTS=YES @@ -74,6 +74,7 @@ deploy: on: all_branches: true tags: true + condition: "$DEPLOY = yes" cache: directories: - ~/cabal-sandboxes From 5618f8e341a58493e5a4ec9c32c95465380b514e Mon Sep 17 00:00:00 2001 From: Benjamin Kovach Date: Thu, 15 Oct 2015 20:52:18 -0400 Subject: [PATCH 0060/1580] Remove type annotation in pretty print + add exhaustivity checker case --- src/Language/PureScript/Linter/Exhaustive.hs | 1 + src/Language/PureScript/Pretty/Values.hs | 5 ++--- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 43af289806..fd6df8bf52 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -160,6 +160,7 @@ missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br) | bl == br = ([], return True) | otherwise = ([BooleanBinder bl], return False) missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb +missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb missingCasesSingle _ _ b _ = ([b], Left Unknown) -- | diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index c5ca10728c..73f6fc9e2c 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -28,7 +28,7 @@ import Control.Arrow (second) import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Pretty.Common -import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox, prettyPrintType) +import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox) import Text.PrettyPrint.Boxes @@ -160,6 +160,5 @@ prettyPrintBinder :: Binder -> String prettyPrintBinder (ConstructorBinder ctor []) = runProperName (disqualify ctor) prettyPrintBinder (ConstructorBinder ctor args) = runProperName (disqualify ctor) ++ " " ++ unwords (map prettyPrintBinderAtom args) prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder -prettyPrintBinder (TypedBinder ty binder) = - prettyPrintBinder binder ++ " :: " ++ prettyPrintType ty +prettyPrintBinder (TypedBinder _ binder) = prettyPrintBinder binder prettyPrintBinder b = prettyPrintBinderAtom b From bb853e2cfaedf2be1ea7e8393768290633024e41 Mon Sep 17 00:00:00 2001 From: Benjamin Kovach Date: Thu, 15 Oct 2015 21:06:50 -0400 Subject: [PATCH 0061/1580] Add missing cases --- src/Language/PureScript/Sugar/CaseDeclarations.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 4a99da563d..5b55a44a12 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -104,12 +104,14 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = isVarBinder NullBinder = True isVarBinder (VarBinder _) = True isVarBinder (PositionedBinder _ _ b) = isVarBinder b + isVarBinder (TypedBinder _ b) = isVarBinder b isVarBinder _ = False fromVarBinder :: Binder -> m Ident fromVarBinder NullBinder = Ident <$> freshName fromVarBinder (VarBinder name) = return name fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b + fromVarBinder (TypedBinder _ b) = fromVarBinder b fromVarBinder _ = error "fromVarBinder: Invalid argument" toDecls ds@(ValueDeclaration ident _ bs result : _) = do let tuples = map toTuple ds From 3997a88af34371851d34d6bde2ea49089b1ceb72 Mon Sep 17 00:00:00 2001 From: Konstantin Zudov Date: Fri, 16 Oct 2015 04:07:08 +0300 Subject: [PATCH 0062/1580] Included some more files in the distribution --- purescript.cabal | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/purescript.cabal b/purescript.cabal index 9c9801fb01..a896701499 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -29,6 +29,10 @@ extra-source-files: examples/passing/*.purs , stack-lts-2.yaml , stack-lts-3.yaml , stack-nightly.yaml + , README.md + , INSTALL.md + , CONTRIBUTORS.md + , CONTRIBUTING.md source-repository head type: git From 880de6eb4d5552a857a9747f8d72f622728631b7 Mon Sep 17 00:00:00 2001 From: Benjamin Kovach Date: Thu, 15 Oct 2015 21:19:00 -0400 Subject: [PATCH 0063/1580] Add some TODOs for polymorphic typed binders --- src/Language/PureScript/Parser/Declarations.hs | 1 + src/Language/PureScript/TypeChecker/Types.hs | 2 ++ 2 files changed, 3 insertions(+) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 7b11062583..a9347d152f 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -527,6 +527,7 @@ parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators where -- TODO: remove this deprecation warning in 0.8 operators = [ [ P.Infix (P.try $ C.indented *> colon *> featureWasRemoved "Cons binders are no longer supported. Consider using purescript-lists or purescript-sequences instead.") P.AssocRight ] ] + -- TODO: parsePolyType when adding support for polymorphic types postfixTable = [ \b -> flip TypedBinder b <$> (P.try (indented *> doubleColon) *> parseType) ] parseBinderAtom :: TokenParser Binder diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 20ae326090..c34fb5f0d1 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -370,6 +370,8 @@ inferBinder val (NamedBinder name binder) = do return $ M.insert name val m inferBinder val (PositionedBinder pos _ binder) = warnAndRethrowWithPosition pos $ inferBinder val binder +-- TODO: When adding support for polymorphic types, check subsumption here +-- and change the definition of `binderRequiresMonotype` inferBinder val (TypedBinder ty binder) = val =?= ty >> inferBinder val binder -- | Returns true if a binder requires its argument type to be a monotype. From 3e353ad45351918b309a21a166a536a85cbaf265 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 15 Oct 2015 18:36:10 -0700 Subject: [PATCH 0064/1580] Fix #881, improve error for out-of-order declarations in instance --- examples/failing/881.purs | 13 ++++++ src/Language/PureScript/TypeChecker.hs | 61 ++++++++++++++++---------- 2 files changed, 50 insertions(+), 24 deletions(-) create mode 100644 examples/failing/881.purs diff --git a/examples/failing/881.purs b/examples/failing/881.purs new file mode 100644 index 0000000000..2b409cd24a --- /dev/null +++ b/examples/failing/881.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith DuplicateValueDeclaration +module Main where + +data X = X | Y + +class Foo a where + foo :: a -> a + bar :: a + +instance fooX :: Foo X where + foo X = X + bar = X + foo Y = Y diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 6e6f52de2d..edf6b0a7d3 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -27,7 +27,7 @@ import Language.PureScript.TypeChecker.Types as T import Language.PureScript.TypeChecker.Synonyms as T import Data.Maybe -import Data.List (nub, (\\)) +import Data.List (nub, (\\), sort, group) import Data.Foldable (for_) import qualified Data.Map as M @@ -216,8 +216,14 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds go (d@(TypeClassDeclaration pn args implies tys)) = do addTypeClass moduleName pn args implies tys return d - go (d@(TypeInstanceDeclaration dictName deps className tys _)) = - goInstance d dictName deps className tys + go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do + mapM_ (checkTypeClassInstance moduleName) tys + forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd + checkOrphanInstance dictName className tys + _ <- traverseTypeInstanceBody checkInstanceMembers body + let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) + addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict + return d go (PositionedDeclaration pos com d) = warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d @@ -229,29 +235,36 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds warnAndRethrowWithPosition pos $ checkOrphanFixities d checkOrphanFixities _ = return () - goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> Check Declaration - goInstance d dictName deps className tys = do - mapM_ (checkTypeClassInstance moduleName) tys - forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd - checkOrphanInstance moduleName className tys - let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) - addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict - return d - + checkInstanceMembers :: [Declaration] -> Check [Declaration] + checkInstanceMembers instDecls = do + let idents = sort . map head . group . map memberName $ instDecls + for_ (firstDuplicate idents) $ \ident -> + throwError . errorMessage $ DuplicateValueDeclaration ident + return instDecls where + memberName :: Declaration -> Ident + memberName (ValueDeclaration ident _ _ _) = ident + memberName (PositionedDeclaration _ _ d) = memberName d + memberName _ = error "checkInstanceMembers: Invalid declaration in type instance definition" - checkOrphanInstance :: ModuleName -> Qualified ProperName -> [Type] -> Check () - checkOrphanInstance mn (Qualified (Just mn') _) tys' - | mn == mn' || any checkType tys' = return () - | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys' - where - checkType :: Type -> Bool - checkType (TypeVar _) = False - checkType (TypeConstructor (Qualified (Just mn'') _)) = mn == mn'' - checkType (TypeConstructor (Qualified Nothing _)) = error "Unqualified type name in checkOrphanInstance" - checkType (TypeApp t1 _) = checkType t1 - checkType _ = error "Invalid type in instance in checkOrphanInstance" - checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance" + firstDuplicate :: (Eq a) => [a] -> Maybe a + firstDuplicate (x : xs@(y : _)) + | x == y = Just x + | otherwise = firstDuplicate xs + firstDuplicate _ = Nothing + + checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> Check () + checkOrphanInstance dictName className@(Qualified (Just mn') _) tys' + | moduleName == mn' || any checkType tys' = return () + | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys' + where + checkType :: Type -> Bool + checkType (TypeVar _) = False + checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn'' + checkType (TypeConstructor (Qualified Nothing _)) = error "Unqualified type name in checkOrphanInstance" + checkType (TypeApp t1 _) = checkType t1 + checkType _ = error "Invalid type in instance in checkOrphanInstance" + checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance" -- | -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, From 7c17fffb2c6fc83090899b1904ac4925a021fe94 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 18 Oct 2015 14:27:01 -0700 Subject: [PATCH 0065/1580] Fix #1476 --- src/Language/PureScript/Pretty/Values.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 73f6fc9e2c..2e358134b7 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -98,6 +98,10 @@ prettyPrintDeclaration (TypeDeclaration ident ty) = text (showIdent ident ++ " :: ") <> typeAsBox ty prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = text (showIdent ident ++ " = ") <> prettyPrintValue val +prettyPrintDeclaration (BindingGroupDeclaration ds) = + vsep 1 left (map (prettyPrintDeclaration . toDecl) ds) + where + toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e) prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration" From 38034d289e5738e4200eade101e886ab1e2b314e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 18 Oct 2015 16:11:46 -0700 Subject: [PATCH 0066/1580] Fix #1535 --- src/Language/PureScript/Make.hs | 43 ++++++++++++++++++--------------- 1 file changed, 23 insertions(+), 20 deletions(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index bb0a95225a..4dce3b523f 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -176,8 +176,9 @@ make MakeActions{..} ms = do unless (null errors) $ throwError (mconcat errors) -- Bundle up all the externs and return them as an Environment - externs <- sequence <$> for barriers (takeMVar . fst . snd) - return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment (fromMaybe (error "make: externs were missing but no errors reported.") externs) + (warnings, externs) <- unzip . fromMaybe (error "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd) + tell (mconcat warnings) + return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs where checkModuleNamesAreUnique :: m () @@ -199,12 +200,12 @@ make MakeActions{..} ms = do inOrderOf :: (Ord a) => [a] -> [a] -> [a] inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys - buildModule :: [(ModuleName, (C.MVar (Maybe ExternsFile), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m () + buildModule :: [(ModuleName, (C.MVar (Maybe (MultipleErrors, ExternsFile)), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m () buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do -- We need to wait for dependencies to be built, before checking if the current -- module should be rebuilt, so the first thing to do is to wait on the -- MVars for the module's dependencies. - mexterns <- sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps + mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps outputTimestamp <- getOutputTimestamp moduleName dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps @@ -218,20 +219,22 @@ make MakeActions{..} ms = do let rebuild = case mexterns of - Just externs -> do - progress $ CompilingModule moduleName - let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs - lint m - ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m] - (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared - checkExhaustiveModule env' checked - regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated - let mod' = Module ss coms moduleName regrouped exps - corefn = CF.moduleToCoreFn env' mod' - [renamed] = renameInModules [corefn] - exts = moduleToExternsFile mod' env' - evalSupplyT nextVar $ codegen renamed env' $ encode exts - markComplete (Just exts) Nothing + Just (_, externs) -> do + (exts, warnings) <- listen $ do + progress $ CompilingModule moduleName + let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs + lint m + ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m] + (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared + checkExhaustiveModule env' checked + regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated + let mod' = Module ss coms moduleName regrouped exps + corefn = CF.moduleToCoreFn env' mod' + [renamed] = renameInModules [corefn] + exts = moduleToExternsFile mod' env' + evalSupplyT nextVar $ codegen renamed env' $ encode exts + return exts + markComplete (Just (warnings, exts)) Nothing Nothing -> markComplete Nothing Nothing if shouldRebuild @@ -239,10 +242,10 @@ make MakeActions{..} ms = do else do mexts <- decodeExterns . snd <$> readExterns moduleName case mexts of - Just exts -> markComplete (Just exts) Nothing + Just exts -> markComplete (Just (mempty, exts)) Nothing Nothing -> rebuild where - markComplete :: Maybe ExternsFile -> Maybe MultipleErrors -> m () + markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m () markComplete externs errors = do putMVar (fst $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) externs putMVar (snd $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) errors From 6183fb2f730a9a154ef55894345d2bd4635d465d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 19 Oct 2015 07:54:39 -0700 Subject: [PATCH 0067/1580] Add Stackage badges --- README.md | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 3e3fba4bd7..aa4a4ff132 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,11 @@ A small strongly typed programming language with expressive types that compiles to Javascript, written in and inspired by Haskell. -[![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript) [![Coverage Status](https://coveralls.io/repos/purescript/purescript/badge.svg?branch=master)](https://coveralls.io/r/purescript/purescript?branch=master) +[![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript) + +[![Stackage LTS 2](http://stackage.org/package/purescript/badge/lts-2)](http://stackage.org/lts-2/package/purescript) +[![Stackage LTS 3](http://stackage.org/package/purescript/badge/lts-3)](http://stackage.org/lts-3/package/purescript) +[![Stackage Nightly](http://stackage.org/package/purescript/badge/nightly)](http://stackage.org/nightly/package/purescript) ## Language info From 6967332e3c48b05c553f434e6f5ad6c7045ed64d Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 19 Oct 2015 23:41:22 +0100 Subject: [PATCH 0068/1580] Add export check for synonyms and types in dctors --- src/Language/PureScript/TypeChecker.hs | 37 ++++++++++++++++++-------- 1 file changed, 26 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 6e6f52de2d..14d0e08154 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -280,21 +280,36 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint where checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check () + checkMemberExport extract dr@(TypeRef name dctors) = do + env <- getEnv + case M.lookup (Qualified (Just mn) name) (typeSynonyms env) of + Nothing -> return () + Just (_, ty) -> checkExport dr extract ty + case dctors of + Nothing -> return () + Just dctors' -> forM_ dctors' $ \dctor -> + case M.lookup (Qualified (Just mn) dctor) (dataConstructors env) of + Nothing -> return () + Just (_, _, ty, _) -> checkExport dr extract ty + return () checkMemberExport extract dr@(ValueRef name) = do ty <- lookupVariable mn (Qualified (Just mn) name) - case filter (not . exported) (extract ty) of - [] -> return () - hidden -> throwError . errorMessage $ TransitiveExportError dr hidden - where - exported e = any (exports e) exps - exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2 - exports (ValueRef id1) (ValueRef id2) = id1 == id2 - exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2 - exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2 - exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2 - exports _ _ = False + checkExport dr extract ty checkMemberExport _ _ = return () + checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> Check () + checkExport dr extract ty = case filter (not . exported) (extract ty) of + [] -> return () + hidden -> throwError . errorMessage $ TransitiveExportError dr hidden + where + exported e = any (exports e) exps + exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2 + exports (ValueRef id1) (ValueRef id2) = id1 == id2 + exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2 + exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2 + exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2 + exports _ _ = False + -- 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 () From 9f124ab2136eac65a581a1e18b631cbf7c07dcfc Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 19 Oct 2015 23:44:01 +0100 Subject: [PATCH 0069/1580] Add tests for the improved transitive export check --- examples/failing/TransitiveDctorExport.purs | 5 +++++ examples/failing/TransitiveSynonymExport.purs | 5 +++++ 2 files changed, 10 insertions(+) create mode 100644 examples/failing/TransitiveDctorExport.purs create mode 100644 examples/failing/TransitiveSynonymExport.purs diff --git a/examples/failing/TransitiveDctorExport.purs b/examples/failing/TransitiveDctorExport.purs new file mode 100644 index 0000000000..1de81ebf32 --- /dev/null +++ b/examples/failing/TransitiveDctorExport.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith TransitiveExportError +module Main (Y(..)) where + +type X = Int +data Y = Y X diff --git a/examples/failing/TransitiveSynonymExport.purs b/examples/failing/TransitiveSynonymExport.purs new file mode 100644 index 0000000000..9778e1fcf8 --- /dev/null +++ b/examples/failing/TransitiveSynonymExport.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith TransitiveExportError +module Main (Y()) where + +type X = Int +type Y = X From 80b7684b0455d5171aa959d15d857524982daf80 Mon Sep 17 00:00:00 2001 From: aspidites Date: Tue, 20 Oct 2015 14:38:42 -0400 Subject: [PATCH 0070/1580] Added a type signatue to main. --- core-tests/tests/generic-deriving/Main.purs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/core-tests/tests/generic-deriving/Main.purs b/core-tests/tests/generic-deriving/Main.purs index a83b0815e0..9ed946f8c7 100755 --- a/core-tests/tests/generic-deriving/Main.purs +++ b/core-tests/tests/generic-deriving/Main.purs @@ -2,6 +2,8 @@ module GenericDeriving where import Prelude +import Control.Monad.Eff (Eff()) +import Control.Monad.Eff.Console (CONSOLE()) import Data.Generic data Void @@ -17,4 +19,5 @@ data A a derive instance genericA :: (Generic a) => Generic (A a) +main :: forall eff. Eff (console :: CONSOLE | eff) Unit main = Control.Monad.Eff.Console.log (gShow (D { a: C [ A 1.0 "test", B 42, D { a: true } ] })) From 8178604c9350821078c4b701f6f3763a3395d8e8 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 20 Oct 2015 12:28:36 -0700 Subject: [PATCH 0071/1580] -> 0.7.5 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index a896701499..44b577fb0e 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.7.4.1 +version: 0.7.5 cabal-version: >=1.8 build-type: Simple license: MIT From f6f38a029c15f22fc03381b5faf077b93b615c44 Mon Sep 17 00:00:00 2001 From: Sergei Trofimovich Date: Wed, 21 Oct 2015 22:35:04 +0100 Subject: [PATCH 0072/1580] Language.PureScript.Externs: fix haddock markup Haddock is unhappy about trailing '-- ^' comments being used as leading. Signed-off-by: Sergei Trofimovich --- src/Language/PureScript/Externs.hs | 36 +++++++++++++++--------------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 6a608da521..206d8a08de 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -50,57 +50,57 @@ import Paths_purescript as Paths -- | The data which will be serialized to an externs file data ExternsFile = ExternsFile { - -- ^ The externs version + -- | The externs version efVersion :: String - -- ^ Module name + -- | Module name , efModuleName :: ModuleName - -- ^ List of module exports + -- | List of module exports , efExports :: [DeclarationRef] - -- ^ List of module imports + -- | List of module imports , efImports :: [ExternsImport] - -- ^ List of operators and their fixities + -- | List of operators and their fixities , efFixities :: [ExternsFixity] - -- ^ List of type and value declaration + -- | List of type and value declaration , efDeclarations :: [ExternsDeclaration] } deriving (Show, Read) -- | A module import in an externs file data ExternsImport = ExternsImport { - -- ^ The imported module + -- | The imported module eiModule :: ModuleName - -- ^ The import type: regular, qualified or hiding + -- | The import type: regular, qualified or hiding , eiImportType :: ImportDeclarationType - -- ^ The imported-as name, for qualified imports + -- | The imported-as name, for qualified imports , eiImportedAs :: Maybe ModuleName } deriving (Show, Read) -- | A fixity declaration in an externs file data ExternsFixity = ExternsFixity { - -- ^ The associativity of the operator + -- | The associativity of the operator efAssociativity :: Associativity - -- ^ The precedence level of the operator + -- | The precedence level of the operator , efPrecedence :: Precedence - -- ^ The operator symbol + -- | The operator symbol , efOperator :: String } deriving (Show, Read) -- | A type or value declaration appearing in an externs file data ExternsDeclaration = - -- ^ A type declaration + -- | A type declaration EDType { edTypeName :: ProperName , edTypeKind :: Kind , edTypeDeclarationKind :: TypeKind } - -- ^ A type synonym + -- | A type synonym | EDTypeSynonym { edTypeSynonymName :: ProperName , edTypeSynonymArguments :: [(String, Maybe Kind)] , edTypeSynonymType :: Type } - -- ^ A data construtor + -- | A data construtor | EDDataConstructor { edDataCtorName :: ProperName , edDataCtorOrigin :: DataDeclType @@ -108,19 +108,19 @@ data ExternsDeclaration = , edDataCtorType :: Type , edDataCtorFields :: [Ident] } - -- ^ A value declaration + -- | A value declaration | EDValue { edValueName :: Ident , edValueType :: Type } - -- ^ A type class declaration + -- | A type class declaration | EDClass { edClassName :: ProperName , edClassTypeArguments :: [(String, Maybe Kind)] , edClassMembers :: [(Ident, Type)] , edClassConstraints :: [Constraint] } - -- ^ An instance declaration + -- | An instance declaration | EDInstance { edInstanceClassName :: Qualified ProperName , edInstanceName :: Ident From 383136ef755cfd8b5416c94b614c414b63524bf3 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Thu, 22 Oct 2015 07:23:01 +0100 Subject: [PATCH 0073/1580] Grammar --- src/Language/PureScript/Errors.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 4b60d799ed..1bc5ebe67a 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -685,7 +685,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir [ line "..." | not b ] renderSimpleErrorMessage IncompleteExhaustivityCheck = paras [ line "An exhaustivity check was abandoned due to too many possible cases." - , line "You may want to decomposing your data types into smaller types." + , line "You may want to decompose your data types into smaller types." ] renderHint :: ErrorMessageHint -> Box.Box From 5897440b447d1dbe51ce6a10f50be160e352fbfa Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 23 Oct 2015 14:28:38 -0700 Subject: [PATCH 0074/1580] Fix #1543 --- src/Language/PureScript/Pretty/Types.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index e9757430b3..f227ee11ca 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -45,14 +45,13 @@ typeLiterals = mkPattern match match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor match (TUnknown u) = Just $ text $ '_' : show u match (Skolem name s _) = Just $ text $ name ++ show s - match (ConstrainedType deps ty) = Just $ constraintsAsBox deps ty match REmpty = Just $ text "()" match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row match _ = Nothing -constraintsAsBox :: [(Qualified ProperName, [Type])] -> Type -> Box -constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> typeAsBox ty -constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> typeAsBox ty) +constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box -> Box +constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty +constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty) constraintAsBox :: Qualified ProperName -> [Type] -> Box constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys) @@ -114,6 +113,12 @@ insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes go idents other = PrettyPrintForAll idents other convertForAlls other = other +constrained :: Pattern () Type ([Constraint], Type) +constrained = mkPattern match + where + match (ConstrainedType deps ty) = Just (deps, ty) + match _ = Nothing + matchTypeAtom :: Pattern () Type Box matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType @@ -125,6 +130,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ] , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret) ] + , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ] , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ] , [ Wrap kinded $ \k ty -> ty `before` (text (" :: " ++ prettyPrintKind k)) ] ] From 85c07370e6c878e5119490a06a6a5e4de6e4b208 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 23 Oct 2015 14:33:27 -0700 Subject: [PATCH 0075/1580] Fix #1551 --- examples/passing/TypedBinders.purs | 7 ++++++- src/Language/PureScript/TypeChecker/Types.hs | 4 +++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/examples/passing/TypedBinders.purs b/examples/passing/TypedBinders.purs index ff66e4d3fd..6f8ca7b6d5 100644 --- a/examples/passing/TypedBinders.purs +++ b/examples/passing/TypedBinders.purs @@ -54,9 +54,14 @@ test3 n = case n of test4 :: Tuple Int Int -> Tuple Int Int test4 = (\(Tuple a b :: Tuple Int Int) -> Tuple b a) +type Int1 = Int + +test5 :: Int1 -> Int1 +test5 = \(x :: Int1) -> x + main = do let t1 = test t2 = test2 id t3 = test3 1 t4 = test4 (Tuple 1 0) - Control.Monad.Eff.Console.log "Done" \ No newline at end of file + Control.Monad.Eff.Console.log "Done" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index c34fb5f0d1..b6f35d394e 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -372,7 +372,9 @@ inferBinder val (PositionedBinder pos _ binder) = warnAndRethrowWithPosition pos $ inferBinder val binder -- TODO: When adding support for polymorphic types, check subsumption here -- and change the definition of `binderRequiresMonotype` -inferBinder val (TypedBinder ty binder) = val =?= ty >> inferBinder val binder +inferBinder val (TypedBinder ty binder) = do + ty' <- replaceAllTypeSynonyms ty + val =?= ty' >> inferBinder val binder -- | Returns true if a binder requires its argument type to be a monotype. -- | If this is the case, we need to instantiate any polymorphic types before checking binders. From a016cba0b99773d62f330f9c5f2f849b8af69178 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 23 Oct 2015 15:47:57 -0700 Subject: [PATCH 0076/1580] Try to fix #1548 --- src/Language/PureScript/Make.hs | 44 ++++++++++++++++----------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 4dce3b523f..ea1ea7cf39 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -207,19 +207,19 @@ make MakeActions{..} ms = do -- MVars for the module's dependencies. mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps - outputTimestamp <- getOutputTimestamp moduleName - dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps - inputTimestamp <- getInputTimestamp moduleName - - let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of - (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2 - (Right (Just t1), Nothing, Just t2) -> t1 > t2 - (Left RebuildNever, _, Just _) -> False - _ -> True - - let rebuild = - case mexterns of - Just (_, externs) -> do + case mexterns of + Just (_, externs) -> do + outputTimestamp <- getOutputTimestamp moduleName + dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps + inputTimestamp <- getInputTimestamp moduleName + + let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of + (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2 + (Right (Just t1), Nothing, Just t2) -> t1 > t2 + (Left RebuildNever, _, Just _) -> False + _ -> True + + let rebuild = do (exts, warnings) <- listen $ do progress $ CompilingModule moduleName let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs @@ -235,15 +235,15 @@ make MakeActions{..} ms = do evalSupplyT nextVar $ codegen renamed env' $ encode exts return exts markComplete (Just (warnings, exts)) Nothing - Nothing -> markComplete Nothing Nothing - - if shouldRebuild - then rebuild - else do - mexts <- decodeExterns . snd <$> readExterns moduleName - case mexts of - Just exts -> markComplete (Just (mempty, exts)) Nothing - Nothing -> rebuild + + if shouldRebuild + then rebuild + else do + mexts <- decodeExterns . snd <$> readExterns moduleName + case mexts of + Just exts -> markComplete (Just (mempty, exts)) Nothing + Nothing -> rebuild + Nothing -> markComplete Nothing Nothing where markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m () markComplete externs errors = do From 82a2649257ccafa1407bfe2f4e2aabbdae429a28 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 23 Oct 2015 16:12:48 -0700 Subject: [PATCH 0077/1580] Fix #1534 --- src/Language/PureScript/Errors.hs | 8 ++--- .../PureScript/Sugar/TypeDeclarations.hs | 29 ++++++++----------- src/Language/PureScript/TypeChecker/Types.hs | 3 ++ 3 files changed, 19 insertions(+), 21 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 1bc5ebe67a..85bf4759c0 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -142,7 +142,7 @@ data SimpleErrorMessage | ShadowedTypeVar String | UnusedTypeVar String | WildcardInferredType Type - | MissingTypeDeclaration Ident + | MissingTypeDeclaration Ident Type | NotExhaustivePattern [[Binder]] Bool | OverlappingPattern [[Binder]] Bool | IncompleteExhaustivityCheck @@ -666,11 +666,11 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir paras [ line "The wildcard type definition has the inferred type " , indent $ typeAsBox ty ] - renderSimpleErrorMessage (MissingTypeDeclaration ident) = + renderSimpleErrorMessage (MissingTypeDeclaration ident ty) = paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "." , line "It is good practice to provide type declarations as a form of documentation." - , line "Consider using a type wildcard to display the inferred type:" - , indent $ line $ showIdent ident ++ " :: _" + , line $ "The inferred type of " ++ showIdent ident ++ " was:" + , indent $ typeAsBox ty ] renderSimpleErrorMessage (NotExhaustivePattern bs b) = paras $ [ line "A case expression could not be determined to cover all inputs." diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index f6ecf37509..19f30ae880 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -41,16 +41,16 @@ import Language.PureScript.Traversals desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module] desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) -> rethrow (addHint (ErrorInModule name)) $ - Module ss coms name <$> desugarTypeDeclarations True ds <*> pure exps + Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps where - desugarTypeDeclarations :: Bool -> [Declaration] -> m [Declaration] - desugarTypeDeclarations reqd (PositionedDeclaration pos com d : ds) = do - (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations reqd (d : ds) + desugarTypeDeclarations :: [Declaration] -> m [Declaration] + desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do + (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds) return (PositionedDeclaration pos com d' : ds') - desugarTypeDeclarations reqd (TypeDeclaration name ty : d : rest) = do + desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do (_, nameKind, val) <- fromValueDeclaration d - desugarTypeDeclarations reqd (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest) + desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest) where fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr) fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val) @@ -58,19 +58,14 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) -> (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d' return (ident, nameKind, PositionedValue pos com val) fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name - desugarTypeDeclarations _ [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name - desugarTypeDeclarations reqd (ValueDeclaration name nameKind bs val : rest) = do - -- At the top level, match a type signature or emit a warning. - when reqd $ case val of - Right TypedValue{} -> return () - Left _ -> error "desugarTypeDeclarations: cases were not desugared" - _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name) + desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name + desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do let (_, f, _) = everywhereOnValuesTopDownM return go return f' (Left gs) = Left <$> mapM (pairM return f) gs f' (Right v) = Right <$> f v - (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations reqd rest + (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest where - go (Let ds val') = Let <$> desugarTypeDeclarations False ds <*> pure val' + go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val' go other = return other - desugarTypeDeclarations reqd (d:ds) = (:) d <$> desugarTypeDeclarations reqd ds - desugarTypeDeclarations _ [] = return [] + desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds + desugarTypeDeclarations [] = return [] diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index c34fb5f0d1..cdc7cf3b5a 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -50,6 +50,7 @@ import Control.Monad import Control.Monad.State import Control.Monad.Unify import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class (tell) import Language.PureScript.AST import Language.PureScript.Environment @@ -93,6 +94,7 @@ typesOf moduleName vals = do tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts -- Replace all the wildcards types with their inferred types replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty) + replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (sub $? ty)) replace _ em = em type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) @@ -139,6 +141,7 @@ typeForBindingGroupElement (ident, val) dict untypedDict = 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) + tell . errorMessage $ MissingTypeDeclaration ident ty return (ident, (TypedValue True val' ty, ty)) -- | From c193571483b803d6b7b655c3b1f7b7f7f5f9586f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 23 Oct 2015 16:15:20 -0700 Subject: [PATCH 0078/1580] Remove unused imports --- src/Language/PureScript/Sugar/TypeDeclarations.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 19f30ae880..f435e9452c 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -25,9 +25,8 @@ module Language.PureScript.Sugar.TypeDeclarations ( #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif -import Control.Monad (forM, when) +import Control.Monad (forM) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(tell)) import Language.PureScript.AST import Language.PureScript.Names @@ -38,7 +37,7 @@ import Language.PureScript.Traversals -- | -- Replace all top level type declarations in a module with type annotations -- -desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Module] -> m [Module] +desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module] desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) -> rethrow (addHint (ErrorInModule name)) $ Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps From 00a47058e00193c2cbf302f668e47241d94be246 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 23 Oct 2015 17:27:14 -0700 Subject: [PATCH 0079/1580] Friendlier errors --- src/Language/PureScript/Errors.hs | 208 +++++++++--------- src/Language/PureScript/Sugar/Operators.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- .../PureScript/TypeChecker/Subsumption.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 8 +- src/Language/PureScript/TypeChecker/Unify.hs | 4 +- 6 files changed, 111 insertions(+), 115 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 1bc5ebe67a..387ca3ddb0 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -42,7 +42,6 @@ import Control.Monad.Trans.State.Lazy import Control.Arrow(first) import Language.PureScript.AST -import Language.PureScript.Environment (isObject, isFunction) import Language.PureScript.Pretty import Language.PureScript.Types import Language.PureScript.Names @@ -62,13 +61,11 @@ data SimpleErrorMessage | MissingFFIModule ModuleName | MultipleFFIModules ModuleName [FilePath] | UnnecessaryFFIModule ModuleName FilePath - | InvalidExternsFile FilePath | CannotGetFileInfo FilePath | CannotReadFile FilePath | CannotWriteFile FilePath | InfiniteType Type | InfiniteKind Kind - | CannotReorderOperators | MultipleFixities Ident | OrphanTypeDeclaration Ident | OrphanFixityDeclaration String @@ -112,7 +109,6 @@ data SimpleErrorMessage | UndefinedTypeVariable ProperName | PartiallyAppliedSynonym (Qualified ProperName) | EscapedSkolem (Maybe Expr) - | UnspecifiedSkolemScope | TypesDoNotUnify Type Type | KindsDoNotUnify Kind Kind | ConstrainedTypeUnified Type Type @@ -126,10 +122,9 @@ data SimpleErrorMessage | ArgListLengthsDiffer Ident | OverlappingArgNames (Maybe Ident) | MissingClassMember Ident - | ExtraneousClassMember Ident + | ExtraneousClassMember Ident (Qualified ProperName) | ExpectedType Type Kind | IncorrectConstructorArity (Qualified ProperName) - | SubsumptionCheckFailed | ExprDoesNotHaveType Expr Type | PropertyIsMissing String Type | CannotApplyFunction Type Expr @@ -202,13 +197,11 @@ errorCode em = case unwrapErrorMessage em of MissingFFIModule{} -> "MissingFFIModule" MultipleFFIModules{} -> "MultipleFFIModules" UnnecessaryFFIModule{} -> "UnnecessaryFFIModule" - InvalidExternsFile{} -> "InvalidExternsFile" CannotGetFileInfo{} -> "CannotGetFileInfo" CannotReadFile{} -> "CannotReadFile" CannotWriteFile{} -> "CannotWriteFile" InfiniteType{} -> "InfiniteType" InfiniteKind{} -> "InfiniteKind" - CannotReorderOperators -> "CannotReorderOperators" MultipleFixities{} -> "MultipleFixities" OrphanTypeDeclaration{} -> "OrphanTypeDeclaration" OrphanFixityDeclaration{} -> "OrphanFixityDeclaration" @@ -252,7 +245,6 @@ errorCode em = case unwrapErrorMessage em of UndefinedTypeVariable{} -> "UndefinedTypeVariable" PartiallyAppliedSynonym{} -> "PartiallyAppliedSynonym" EscapedSkolem{} -> "EscapedSkolem" - UnspecifiedSkolemScope -> "UnspecifiedSkolemScope" TypesDoNotUnify{} -> "TypesDoNotUnify" KindsDoNotUnify{} -> "KindsDoNotUnify" ConstrainedTypeUnified{} -> "ConstrainedTypeUnified" @@ -269,7 +261,6 @@ errorCode em = case unwrapErrorMessage em of ExtraneousClassMember{} -> "ExtraneousClassMember" ExpectedType{} -> "ExpectedType" IncorrectConstructorArity{} -> "IncorrectConstructorArity" - SubsumptionCheckFailed -> "SubsumptionCheckFailed" ExprDoesNotHaveType{} -> "ExprDoesNotHaveType" PropertyIsMissing{} -> "PropertyIsMissing" CannotApplyFunction{} -> "CannotApplyFunction" @@ -385,9 +376,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir prettyPrintErrorMessage (ErrorMessage hints simple) = paras $ map renderHint hints ++ - renderSimpleErrorMessage simple : - suggestions simple ++ - [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "."] + [ renderSimpleErrorMessage simple + , line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "." + ] where wikiUri :: String wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e @@ -410,37 +401,37 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , prettyPrintParseError err ] renderSimpleErrorMessage (ErrorParsingFFIModule path) = - paras [ line "Unable to parse module from FFI file: " + paras [ line "Unable to parse foreign module:" , indent . line $ path + , line "Ensure that all foreign modules contain a single module header at the start of a line, as follows:" + , indent $ line "// module A.B.C" ] renderSimpleErrorMessage (ErrorParsingModule err) = paras [ line "Unable to parse module: " , prettyPrintParseError err ] renderSimpleErrorMessage (MissingFFIModule mn) = - line $ "Missing FFI implementations for module " ++ runModuleName mn + paras [ line $ "Missing foreign module implementation for module " ++ runModuleName mn + , line $ "Provide your foreign module implementation using the --ffi command line option, and ensure that your module contains the following module header:" + , indent . line $ "// module " ++ runModuleName mn + ] renderSimpleErrorMessage (UnnecessaryFFIModule mn path) = - paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ runModuleName mn ++ ": " + paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ runModuleName mn ++ ": " , indent . line $ path + , line $ "Module " ++ runModuleName mn ++ " does not contain any foreign import declarations, so a foreign module is not necessary." ] renderSimpleErrorMessage (MultipleFFIModules mn paths) = - paras [ line $ "Multiple FFI implementations have been provided for module " ++ runModuleName mn ++ ": " + paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": " , indent . paras $ map line paths - ] - renderSimpleErrorMessage (InvalidExternsFile path) = - paras [ line "Externs file is invalid: " - , indent . line $ path + , line "Foreign modules are identified by a unique module name, as follows:" + , indent $ line "// module A.B.C" ] renderSimpleErrorMessage InvalidDoBind = - line "Bind statement cannot be the last statement in a do block. The last statement must be an expression." + line "The last statement in a 'do' block must be an expression, but this block ends with a binder." renderSimpleErrorMessage InvalidDoLet = - line "Let statement cannot be the last statement in a do block. The last statement must be an expression." - renderSimpleErrorMessage CannotReorderOperators = - line "Unable to reorder operators" - renderSimpleErrorMessage UnspecifiedSkolemScope = - line "Skolem variable scope is unspecified" + line "The last statement in a 'do' block must be an expression, but this block ends with a let binding." renderSimpleErrorMessage OverlappingNamesInLet = - line "Overlapping names in let binding." + line "The same name was used more than once in a let binding." renderSimpleErrorMessage (InfiniteType ty) = paras [ line "An infinite type was inferred for an expression: " , indent $ typeAsBox ty @@ -450,17 +441,17 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , indent $ line $ prettyPrintKind ki ] renderSimpleErrorMessage (MultipleFixities name) = - line $ "Multiple fixity declarations for " ++ showIdent name + line $ "There are multiple fixity/precedence declarations for " ++ showIdent name renderSimpleErrorMessage (OrphanTypeDeclaration nm) = - line $ "Orphan type declaration for " ++ showIdent nm + line $ "The type declaration for " ++ showIdent nm ++ " should be followed by its definition." renderSimpleErrorMessage (OrphanFixityDeclaration op) = - line $ "Orphan fixity declaration for " ++ show op + line $ "The fixity/precedence declaration for " ++ show op ++ " should appear in the same module as its definition." renderSimpleErrorMessage (RedefinedModule name filenames) = - paras [ line ("Module " ++ runModuleName name ++ " has been defined multiple times:") + paras [ line ("The module " ++ runModuleName name ++ " has been defined multiple times:") , indent . paras $ map (line . displaySourceSpan) filenames ] renderSimpleErrorMessage (RedefinedIdent name) = - line $ "Name " ++ showIdent name ++ " has been defined multiple times" + line $ "The name " ++ showIdent name ++ " has been defined multiple times" renderSimpleErrorMessage (UnknownModule mn) = line $ "Unknown module " ++ runModuleName mn renderSimpleErrorMessage (UnknownType name) = @@ -474,25 +465,30 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (UnknownDataConstructor dc tc) = line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc renderSimpleErrorMessage (UnknownImportType mn name) = - line $ "Module " ++ runModuleName mn ++ " does not export type " ++ runProperName name + line $ "The type " ++ runProperName name ++ " is not exported by the module " ++ runModuleName mn renderSimpleErrorMessage (UnknownExportType name) = line $ "Cannot export unknown type " ++ runProperName name renderSimpleErrorMessage (UnknownImportTypeClass mn name) = - line $ "Module " ++ runModuleName mn ++ " does not export type class " ++ runProperName name + line $ "The type class " ++ runProperName name ++ " is not exported by the module " ++ runModuleName mn renderSimpleErrorMessage (UnknownExportTypeClass name) = line $ "Cannot export unknown type class " ++ runProperName name renderSimpleErrorMessage (UnknownImportValue mn name) = - line $ "Module " ++ runModuleName mn ++ " does not export value " ++ showIdent name + line $ "The value " ++ showIdent name ++ " is not exported by the module " ++ runModuleName mn renderSimpleErrorMessage (UnknownExportValue name) = line $ "Cannot export unknown value " ++ showIdent name renderSimpleErrorMessage (UnknownExportModule name) = - line $ "Cannot export unknown module " ++ runModuleName name ++ ", it either does not exist or has not been imported by the current module" + paras [ line $ "Cannot export unknown module " ++ runModuleName name + , line "It either does not exist or has not been imported by the current module." + ] renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) = - line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon + line $ "The data constructor " ++ runProperName dcon ++ " (for type " ++ runProperName tcon ++ ") is not exported by the module " ++ runModuleName mn renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) = - line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ " as it has not been declared" + line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared." renderSimpleErrorMessage (ConflictingImport nm mn) = - line $ "Cannot declare " ++ show nm ++ " since another declaration of that name was imported from " ++ runModuleName mn + paras [ line $ "Cannot declare " ++ show nm ++ ", since another declaration of that name was imported from the module " ++ runModuleName mn + , line $ "Consider hiding " ++ show nm ++ " when importing " ++ runModuleName mn ++ ":" + , indent . line $ "import " ++ runModuleName mn ++ " hiding (" ++ nm ++ ")" + ] renderSimpleErrorMessage (ConflictingImports nm m1 m2) = line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2 renderSimpleErrorMessage (ConflictingTypeDecls nm) = @@ -500,33 +496,41 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (ConflictingCtorDecls nm) = line $ "Conflicting data constructor declarations for " ++ runProperName nm renderSimpleErrorMessage (TypeConflictsWithClass nm) = - line $ "Type " ++ runProperName nm ++ " conflicts with type class declaration of the same name" + line $ "The type " ++ runProperName nm ++ " conflicts with type class declaration of the same name." renderSimpleErrorMessage (CtorConflictsWithClass nm) = - line $ "Data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name" + line $ "The data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name." renderSimpleErrorMessage (ClassConflictsWithType nm) = - line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name" + line $ "The type class " ++ runProperName nm ++ " conflicts with type declaration of the same name." renderSimpleErrorMessage (ClassConflictsWithCtor nm) = - line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name" + line $ "The type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name." renderSimpleErrorMessage (DuplicateModuleName mn) = - line $ "Module " ++ runModuleName mn ++ " has been defined multiple times." + line $ "The module " ++ runModuleName mn ++ " has been defined multiple times." renderSimpleErrorMessage (DuplicateClassExport nm) = line $ "Duplicate export declaration for type class " ++ runProperName nm renderSimpleErrorMessage (DuplicateValueExport nm) = line $ "Duplicate export declaration for value " ++ showIdent nm renderSimpleErrorMessage (CycleInDeclaration nm) = - line $ "Cycle in declaration of " ++ showIdent nm + paras [ line $ "The declaration of " ++ showIdent nm ++ " contains a cycle." + , line $ "The value of " ++ showIdent nm ++ " may not be defined here, so this reference is not allowed." + , line "You might be able to evaluate this expression lazily, using something like Control.Lazy.fix" + ] renderSimpleErrorMessage (CycleInModules mns) = - line $ "Cycle in module dependencies: " ++ intercalate ", " (map runModuleName mns) - renderSimpleErrorMessage (CycleInTypeSynonym pn) = - line $ "Cycle in type synonym" ++ foldMap ((" " ++) . runProperName) pn + line $ "There is a cycle in the module dependencies: " ++ intercalate ", " (map runModuleName mns) + renderSimpleErrorMessage (CycleInTypeSynonym name) = + paras [ line $ case name of + Just pn -> "A cycle appears in the definition of the type synonym " ++ runProperName pn + Nothing -> "A cycle appears in a set of type synonym definitions." + , line "Cycles are disallowed because they can lead to loops in the type checker." + , line "Consider using a 'newtype' instead." + ] renderSimpleErrorMessage (NameIsUndefined ident) = - line $ showIdent ident ++ " is undefined" + line $ "The name " ++ showIdent ident ++ " is undefined." renderSimpleErrorMessage (NameNotInScope ident) = - line $ showIdent ident ++ " may not be defined in the current scope" + line $ "The name " ++ showIdent ident ++ " may not be defined in the current scope." renderSimpleErrorMessage (UndefinedTypeVariable name) = - line $ "Type variable " ++ runProperName name ++ " is undefined" + line $ "The type variable " ++ runProperName name ++ " is undefined." renderSimpleErrorMessage (PartiallyAppliedSynonym name) = - paras [ line $ "Partially applied type synonym " ++ showQualified runProperName name + paras [ line $ "The type synonym " ++ showQualified runProperName name ++ " is partially applied." , line "Type synonyms must be applied to all of their type arguments." ] renderSimpleErrorMessage (EscapedSkolem binding) = @@ -535,25 +539,25 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , indent $ prettyPrintValue expr ]) binding renderSimpleErrorMessage (TypesDoNotUnify t1 t2) - = paras [ line "Cannot unify type" + = paras [ line "The type" , indent $ typeAsBox t1 - , line "with type" + , line "cannot be made equal to the type" , indent $ typeAsBox t2 ] renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = - paras [ line "Cannot unify kind" + paras [ line "The kind" , indent $ line $ prettyPrintKind k1 - , line "with kind" + , line "cannot be made equal to the kind" , indent $ line $ prettyPrintKind k2 ] renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) = - paras [ line "Cannot unify constrained type" + paras [ line "The constrained type" , indent $ typeAsBox t1 - , line "with type" + , line "cannot be made equal to the kind" , indent $ typeAsBox t2 ] renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) = - paras [ line "Overlapping instances found for" + paras [ line "Overlapping type class instances found for" , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) ] @@ -562,43 +566,43 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir ] renderSimpleErrorMessage OverlappingInstances{} = error "OverlappingInstances: empty instance list" renderSimpleErrorMessage (NoInstanceFound nm ts) = - paras [ line "No instance found for" + paras [ line "No type class instance was found for" , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) ] ] renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) = - paras [ line "Instance for" + paras [ line "The type class instance for" , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) ] , line "is possibly infinite." ] renderSimpleErrorMessage (CannotDerive nm ts) = - paras [ line "Cannot derive an instance for" + paras [ line "Cannot derive a type class instance for" , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) ] ] renderSimpleErrorMessage (CannotFindDerivingType nm) = - line $ "Cannot derive instance, because the type declaration for " ++ runProperName nm ++ " could not be found." + line $ "Cannot derive a type class instance, because the type declaration for " ++ runProperName nm ++ " could not be found." renderSimpleErrorMessage (DuplicateLabel l expr) = - paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ] + paras $ [ line $ "The duplicate label " ++ show l ++ " appears in a row type." ] <> foldMap (\expr' -> [ line "Relevant expression: " , indent $ prettyPrintValue expr' ]) expr renderSimpleErrorMessage (DuplicateTypeArgument name) = - line $ "Duplicate type argument " ++ show name + line $ "The type argument " ++ show name ++ " appears more than once." renderSimpleErrorMessage (DuplicateValueDeclaration nm) = - line $ "Duplicate value declaration for " ++ showIdent nm + line $ "Multiple value declarations exist for " ++ showIdent nm ++ "." renderSimpleErrorMessage (ArgListLengthsDiffer ident) = line $ "Argument list lengths differ in declaration " ++ showIdent ident renderSimpleErrorMessage (OverlappingArgNames ident) = line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident renderSimpleErrorMessage (MissingClassMember ident) = - line $ "Member " ++ showIdent ident ++ " has not been implemented" - renderSimpleErrorMessage (ExtraneousClassMember ident) = - line $ "Member " ++ showIdent ident ++ " is not a member of the class being instantiated" + line $ "The type class member " ++ showIdent ident ++ " has not been implemented." + renderSimpleErrorMessage (ExtraneousClassMember ident className) = + line $ showIdent ident ++ " is not a member of type class " ++ showQualified runProperName className renderSimpleErrorMessage (ExpectedType ty kind) = paras [ line "In a type-annotated expression x :: t, the type t must have kind *." , line "The error arises from the type" @@ -608,29 +612,28 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , line "instead." ] renderSimpleErrorMessage (IncorrectConstructorArity nm) = - line $ "Wrong number of arguments to constructor " ++ showQualified runProperName nm - renderSimpleErrorMessage SubsumptionCheckFailed = line "Unable to check type subsumption" + line $ "The data constructor " ++ showQualified runProperName nm ++ " was given the wrong number of arguments in a case expression." renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) = - paras [ line "Expression" + paras [ line "The expression" , indent $ prettyPrintValue expr , line "does not have type" , indent $ typeAsBox ty ] renderSimpleErrorMessage (PropertyIsMissing prop row) = - paras [ line "Row" + paras [ line "The row type" , indent $ prettyPrintRowWith '(' ')' row - , line $ "lacks required property " ++ show prop + , line $ "lacks the required property " ++ show prop ] renderSimpleErrorMessage (CannotApplyFunction fn arg) = - paras [ line "Cannot apply function of type" + paras [ line "A function of type" , indent $ typeAsBox fn - , line "to argument" + , line "can not be applied to the argument" , indent $ prettyPrintValue arg ] renderSimpleErrorMessage TypeSynonymInstance = - line "Type synonym instances are disallowed" + line "Type class instances for type synonyms are disallowed." renderSimpleErrorMessage (OrphanInstance nm cnm ts) = - paras [ line $ "Instance " ++ showIdent nm ++ " for " + paras [ line $ "The type class instance " ++ showIdent nm ++ " for " , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm) , Box.vcat Box.left (map typeAtomAsBox ts) ] @@ -639,29 +642,31 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , line "Consider moving the instance, if possible, or using a newtype wrapper." ] renderSimpleErrorMessage InvalidNewtype = - line "Newtypes must define a single constructor with a single argument" + line "Newtypes must define a single constructor with a single argument." renderSimpleErrorMessage (InvalidInstanceHead ty) = - paras [ line "Invalid type in class instance head:" + paras [ line "An invalid type appears in a type class instance head:" , indent $ typeAsBox ty ] renderSimpleErrorMessage (TransitiveExportError x ys) = paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ") : map (line . prettyPrintExport) ys renderSimpleErrorMessage (ShadowedName nm) = - line $ "Name '" ++ showIdent nm ++ "' was shadowed" + line $ "The name '" ++ showIdent nm ++ "' was shadowed." renderSimpleErrorMessage (ShadowedTypeVar tv) = - line $ "Type variable '" ++ tv ++ "' was shadowed" + line $ "The type variable '" ++ tv ++ "' was shadowed." renderSimpleErrorMessage (UnusedTypeVar tv) = - line $ "Type variable '" ++ tv ++ "' was declared but not used" + line $ "The type variable '" ++ tv ++ "' was declared but not used." renderSimpleErrorMessage (ClassOperator className opName) = - paras [ line $ "Class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "." + paras [ line $ "The type class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "." , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:" , indent . line $ showIdent opName ++ " = someMember" ] renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) = - line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors" + line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors." renderSimpleErrorMessage (ImportHidingModule name) = - line $ "Attempted to hide module " ++ runModuleName name ++ " in import expression, this is not permitted" + paras [ line $ "'hiding' imports cannot be used to hide modules." + , line $ "An attempt was made to hide the import of " ++ runModuleName name + ] renderSimpleErrorMessage (WildcardInferredType ty) = paras [ line "The wildcard type definition has the inferred type " , indent $ typeAsBox ty @@ -692,9 +697,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderHint (NotYetDefined names) = line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":" renderHint (ErrorUnifyingTypes t1 t2) = - paras [ lineWithLevel "unifying type " + paras [ lineWithLevel "while trying to make the type " , indent $ typeAsBox t1 - , line "with type" + , line "equal to the type" , indent $ typeAsBox t2 ] renderHint (ErrorInExpression expr) = @@ -705,9 +710,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":" ] renderHint (ErrorInSubsumption t1 t2) = - paras [ lineWithLevel "checking that type " + paras [ lineWithLevel "checking that the type" , indent $ typeAsBox t1 - , line "subsumes type" + , line "is more general than the type" , indent $ typeAsBox t2 ] renderHint (ErrorInInstance nm ts) = @@ -717,25 +722,25 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir ] ] renderHint (ErrorCheckingKind ty) = - paras [ lineWithLevel "checking kind of type " + paras [ lineWithLevel "checking the kind of the type" , indent $ typeAsBox ty ] renderHint (ErrorInferringType expr) = - paras [ lineWithLevel "inferring type of value " + paras [ lineWithLevel "inferring the type of the expression" , indent $ prettyPrintValue expr ] renderHint (ErrorCheckingType expr ty) = - paras [ lineWithLevel "checking that value " + paras [ lineWithLevel "checking that the expression" , indent $ prettyPrintValue expr - , line "has type" + , line "has the type" , indent $ typeAsBox ty ] renderHint (ErrorInApplication f t a) = - paras [ lineWithLevel "applying function" + paras [ lineWithLevel "applying a function" , indent $ prettyPrintValue f , line "of type" , indent $ typeAsBox t - , line "to argument" + , line "to the argument" , indent $ prettyPrintValue a ] renderHint (ErrorInDataConstructor nm) = @@ -765,15 +770,6 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir Error -> "error" Warning -> "warning" - suggestions :: SimpleErrorMessage -> [Box.Box] - suggestions (ConflictingImport nm im) = [ line $ "Possible fix: hide " ++ show nm ++ " when importing " ++ runModuleName im ++ ":" - , indent . line $ "import " ++ runModuleName im ++ " hiding (" ++ nm ++ ")" - ] - suggestions (TypesDoNotUnify t1 t2) - | isObject t1 && isFunction t2 = [line "Note that function composition in PureScript is defined using (<<<)"] - | otherwise = [] - suggestions _ = [] - paras :: [Box.Box] -> Box.Box paras = Box.vcat Box.left diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 767a4f62c1..f7f24beb2a 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -129,7 +129,7 @@ matchOperators ops = parseChains extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r extendChain other = [Left other] bracketChain :: Chain -> m Expr - bracketChain = either (const . throwError . errorMessage $ CannotReorderOperators) return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression" + bracketChain = either (\_ -> error "matchOperators: cannot reorder operators") return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression" opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft] : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]] diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index e393673df2..03f92feed7 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -289,7 +289,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do - _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident) return $ lookup ident tys' + _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys' return val memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do val <- memberToValue tys' d diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index d87acfcbdd..0e2f02a056 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -50,7 +50,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) = sko <- newSkolemConstant let sk = skolemize ident sko sco' ty2 subsumes val ty1 sk - Nothing -> throwError . errorMessage $ UnspecifiedSkolemScope + Nothing -> error "subsumes: unspecified skolem scope" subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do _ <- subsumes Nothing arg2 arg1 _ <- subsumes Nothing ret1 ret2 diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index c34fb5f0d1..4611e1f57b 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -496,7 +496,7 @@ check' v@(Var var) ty = do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty v' <- subsumes (Just v) repl ty' case v' of - Nothing -> throwError . errorMessage $ SubsumptionCheckFailed + Nothing -> error "check: unable to check the subsumes relation." Just v'' -> return $ TypedValue True v'' ty' check' (SuperClassDictionary className tys) _ = do {- @@ -515,7 +515,7 @@ check' (TypedValue checkType val ty1) ty2 = do ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2 val' <- subsumes (Just val) ty1' ty2' case val' of - Nothing -> throwError . errorMessage $ SubsumptionCheckFailed + Nothing -> error "check: unable to check the subsumes relation." Just _ -> do val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val return $ TypedValue checkType val''' ty2' @@ -557,7 +557,7 @@ check' v@(Constructor c) ty = do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 mv <- subsumes (Just v) repl ty case mv of - Nothing -> throwError . errorMessage $ SubsumptionCheckFailed + Nothing -> error "check: unable to check the subsumes relation." Just v' -> return $ TypedValue True v' ty check' (Let ds val) ty = do (ds', val') <- inferLetBinding [] ds val (`check` ty) @@ -572,7 +572,7 @@ check' val ty = do TypedValue _ val' ty' <- infer val mt <- subsumes (Just val') ty' ty case mt of - Nothing -> throwError . errorMessage $ SubsumptionCheckFailed + Nothing -> error "check: unable to check the subsumes relation." Just v' -> return $ TypedValue True v' ty -- | diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 5c2ff5525b..8241d99842 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -74,12 +74,12 @@ unifyTypes t1 t2 = rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ let sk1 = skolemize ident1 sko sc1' ty1 let sk2 = skolemize ident2 sko sc2' ty2 sk1 `unifyTypes` sk2 - _ -> error "Skolemized type variable was not given a scope" + _ -> error "unifyTypes: unspecified skolem scope" unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do sko <- newSkolemConstant let sk = skolemize ident sko sc ty1 sk `unifyTypes` ty2 - unifyTypes' ForAll{} _ = throwError . errorMessage $ UnspecifiedSkolemScope + unifyTypes' ForAll{} _ = error "unifyTypes: unspecified skolem scope" unifyTypes' ty f@ForAll{} = f `unifyTypes` ty unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return () unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) = From abcc6a8d6de5961dddda800b6f6ebc892c910c33 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 23 Oct 2015 17:34:06 -0700 Subject: [PATCH 0080/1580] Four more --- src/Language/PureScript/Errors.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 387ca3ddb0..cd8b0b80cf 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -411,7 +411,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , prettyPrintParseError err ] renderSimpleErrorMessage (MissingFFIModule mn) = - paras [ line $ "Missing foreign module implementation for module " ++ runModuleName mn + paras [ line $ "The foreign module implementation for module " ++ runModuleName mn ++ " is missing." , line $ "Provide your foreign module implementation using the --ffi command line option, and ensure that your module contains the following module header:" , indent . line $ "// module " ++ runModuleName mn ] @@ -496,13 +496,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (ConflictingCtorDecls nm) = line $ "Conflicting data constructor declarations for " ++ runProperName nm renderSimpleErrorMessage (TypeConflictsWithClass nm) = - line $ "The type " ++ runProperName nm ++ " conflicts with type class declaration of the same name." + line $ "The type " ++ runProperName nm ++ " conflicts with a type class declaration of the same name." renderSimpleErrorMessage (CtorConflictsWithClass nm) = - line $ "The data constructor " ++ runProperName nm ++ " conflicts with type class declaration of the same name." + line $ "The data constructor " ++ runProperName nm ++ " conflicts with a type class declaration of the same name." renderSimpleErrorMessage (ClassConflictsWithType nm) = - line $ "The type class " ++ runProperName nm ++ " conflicts with type declaration of the same name." + line $ "The type class " ++ runProperName nm ++ " conflicts with a type declaration of the same name." renderSimpleErrorMessage (ClassConflictsWithCtor nm) = - line $ "The type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name." + line $ "The type class " ++ runProperName nm ++ " conflicts with a data constructor declaration of the same name." renderSimpleErrorMessage (DuplicateModuleName mn) = line $ "The module " ++ runModuleName mn ++ " has been defined multiple times." renderSimpleErrorMessage (DuplicateClassExport nm) = From 1059be81dc1170e4354cfebba7c79ca3855bfc85 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 23 Oct 2015 17:51:45 -0700 Subject: [PATCH 0081/1580] Remove unused import --- src/Language/PureScript/TypeChecker/Subsumption.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 0e2f02a056..a1a9a16bed 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -20,7 +20,6 @@ module Language.PureScript.TypeChecker.Subsumption ( import Data.List (sortBy) import Data.Ord (comparing) -import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Unify import Language.PureScript.AST From 688fc66c27cfd4d8505cd11006a9eac6b55e1f31 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 24 Oct 2015 14:42:28 -0700 Subject: [PATCH 0082/1580] Add internalError, make some of @garyb's suggested changes. --- psci/PSCi.hs | 6 +- purescript.cabal | 1 + src/Language/PureScript.hs | 1 + src/Language/PureScript/AST/Operators.hs | 4 +- src/Language/PureScript/CodeGen/JS.hs | 5 +- .../PureScript/CodeGen/JS/Optimizer/Common.hs | 3 +- src/Language/PureScript/CoreFn/Desugar.hs | 7 +- src/Language/PureScript/Crash.hs | 9 +++ src/Language/PureScript/Docs/Convert.hs | 2 +- .../PureScript/Docs/RenderedCode/Render.hs | 5 +- src/Language/PureScript/Environment.hs | 3 +- src/Language/PureScript/Errors.hs | 76 +++++++++---------- src/Language/PureScript/Externs.hs | 7 +- src/Language/PureScript/Linter.hs | 3 +- src/Language/PureScript/Linter/Exhaustive.hs | 5 +- src/Language/PureScript/Make.hs | 15 ++-- src/Language/PureScript/ModuleDependencies.hs | 3 +- src/Language/PureScript/Pretty/JS.hs | 5 +- src/Language/PureScript/Pretty/Kinds.hs | 3 +- src/Language/PureScript/Pretty/Types.hs | 5 +- src/Language/PureScript/Pretty/Values.hs | 3 +- .../PureScript/Sugar/BindingGroups.hs | 11 +-- .../PureScript/Sugar/CaseDeclarations.hs | 5 +- src/Language/PureScript/Sugar/DoNotation.hs | 3 +- src/Language/PureScript/Sugar/Names.hs | 3 +- .../PureScript/Sugar/Names/Exports.hs | 15 ++-- .../PureScript/Sugar/Names/Imports.hs | 13 ++-- src/Language/PureScript/Sugar/Operators.hs | 5 +- src/Language/PureScript/Sugar/TypeClasses.hs | 15 ++-- .../PureScript/Sugar/TypeClasses/Deriving.hs | 7 +- .../PureScript/Sugar/TypeDeclarations.hs | 3 +- src/Language/PureScript/TypeChecker.hs | 27 +++---- .../PureScript/TypeChecker/Entailment.hs | 5 +- src/Language/PureScript/TypeChecker/Kinds.hs | 3 +- src/Language/PureScript/TypeChecker/Monad.hs | 2 +- .../PureScript/TypeChecker/Skolems.hs | 3 +- .../PureScript/TypeChecker/Subsumption.hs | 3 +- src/Language/PureScript/TypeChecker/Types.hs | 25 +++--- src/Language/PureScript/TypeChecker/Unify.hs | 5 +- tests/Main.hs | 4 +- tests/common/TestsSetup.hs | 4 +- 41 files changed, 188 insertions(+), 144 deletions(-) create mode 100644 src/Language/PureScript/Crash.hs diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 8a704e0537..74ea9b5309 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -71,7 +71,7 @@ supportModule :: P.Module supportModule = case P.parseModulesFromFiles id [("", code)] of Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps - _ -> error "Support module could not be parsed" + _ -> P.internalError "Support module could not be parsed" where code :: String code = unlines @@ -390,7 +390,7 @@ printModuleSignatures moduleName env = findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames) showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType - showType _ = error "The impossible happened in printModuleSignatures." + showType _ = P.internalError "The impossible happened in printModuleSignatures." -- | -- Browse a module and displays its signature (if module exists). @@ -482,7 +482,7 @@ handleCommand (KindOf typ) = handleKindOf typ handleCommand (BrowseModule moduleName) = handleBrowse moduleName handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules handleCommand (ShowInfo QueryImport) = handleShowImportedModules -handleCommand QuitPSCi = error "`handleCommand QuitPSCi` was called. This is a bug." +handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug." whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI () whenFileExists filePath f = do diff --git a/purescript.cabal b/purescript.cabal index 44b577fb0e..ced8493aab 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -79,6 +79,7 @@ library Language.PureScript.AST.Traversals Language.PureScript.AST.Exported Language.PureScript.Bundle + Language.PureScript.Crash Language.PureScript.Externs Language.PureScript.CodeGen Language.PureScript.CodeGen.JS diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index 670ce2437e..06812a2cc7 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -26,6 +26,7 @@ module Language.PureScript import Data.Version (Version) import Language.PureScript.AST as P +import Language.PureScript.Crash as P import Language.PureScript.Comments as P import Language.PureScript.Environment as P import Language.PureScript.Errors as P hiding (indent) diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs index 291490f8bf..2afae9a366 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -21,6 +21,8 @@ import qualified Data.Data as D import Data.Aeson ((.=)) import qualified Data.Aeson as A +import Language.PureScript.Crash + -- | -- A precedence level for an infix operator -- @@ -40,7 +42,7 @@ readAssoc :: String -> Associativity readAssoc "infixl" = Infixl readAssoc "infixr" = Infixr readAssoc "infix" = Infix -readAssoc _ = error "readAssoc: no parse" +readAssoc _ = internalError "readAssoc: no parse" instance A.ToJSON Associativity where toJSON = A.toJSON . showAssoc diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 5db67d5c62..3916a943a1 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -38,6 +38,7 @@ import Control.Monad (replicateM, forM) import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class +import Language.PureScript.Crash import Language.PureScript.AST.SourcePos import Language.PureScript.CodeGen.JS.AST as AST import Language.PureScript.CodeGen.JS.Common as Common @@ -272,7 +273,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do go (v:vs) done' (b:bs) = do done'' <- go vs done' bs binderToJs v done'' b - go _ _ _ = error "Invalid arguments to bindersToJs" + go _ _ _ = internalError "Invalid arguments to bindersToJs" failedPatternError :: [String] -> JS failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral errorMessage) (JSArrayLiteral $ zipWith valueError names vals)] @@ -322,7 +323,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do js <- binderToJs argVar done'' binder return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js) binderToJs _ _ ConstructorBinder{} = - error "binderToJs: Invalid ConstructorBinder in binderToJs" + internalError "binderToJs: Invalid ConstructorBinder in binderToJs" binderToJs varName done (NamedBinder _ ident binder) = do js <- binderToJs varName done binder return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs index 11b1cdfd07..1cc24d3c79 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs @@ -17,6 +17,7 @@ module Language.PureScript.CodeGen.JS.Optimizer.Common where import Data.Maybe (fromMaybe) +import Language.PureScript.Crash import Language.PureScript.CodeGen.JS.AST applyAll :: [a -> a] -> a -> a @@ -63,7 +64,7 @@ targetVariable :: JS -> String targetVariable (JSVar var) = var targetVariable (JSAccessor _ tgt) = targetVariable tgt targetVariable (JSIndexer _ tgt) = targetVariable tgt -targetVariable _ = error "Invalid argument to targetVariable" +targetVariable _ = internalError "Invalid argument to targetVariable" isUpdated :: String -> JS -> Bool isUpdated var1 = everythingOnJS (||) check diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index f691589241..f07e2c20db 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -21,6 +21,7 @@ import qualified Data.Map as M import Control.Arrow (second, (***)) +import Language.PureScript.Crash import Language.PureScript.AST.SourcePos import Language.PureScript.AST.Traversals import Language.PureScript.CoreFn.Ann @@ -41,7 +42,7 @@ import qualified Language.PureScript.AST as A -- moduleToCoreFn :: Environment -> A.Module -> Module Ann moduleToCoreFn _ (A.Module _ _ _ _ Nothing) = - error "Module exports were not elaborated before moduleToCoreFn" + internalError "Module exports were not elaborated before moduleToCoreFn" moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls exps' = nub $ concatMap exportToCoreFn exps @@ -98,7 +99,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = exprToCoreFn ss com ty (A.Abs (Left name) v) = Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) exprToCoreFn _ _ _ (A.Abs _ _) = - error "Abs with Binder argument was not desugared before exprToCoreFn mn" + internalError "Abs with Binder argument was not desugared before exprToCoreFn mn" exprToCoreFn ss com ty (A.App v1 v2) = App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2) exprToCoreFn ss com ty (A.Var ident) = @@ -193,7 +194,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName) typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) - typeConstructor _ = error "Invalid argument to typeConstructor" + typeConstructor _ = internalError "Invalid argument to typeConstructor" -- | -- Find module names from qualified references to values. This is used to diff --git a/src/Language/PureScript/Crash.hs b/src/Language/PureScript/Crash.hs new file mode 100644 index 0000000000..ab4cdc1b58 --- /dev/null +++ b/src/Language/PureScript/Crash.hs @@ -0,0 +1,9 @@ +module Language.PureScript.Crash where + +-- | Exit with an error message and a crash report link. +internalError :: String -> a +internalError = + error + . ("An internal error ocurred during compilation: " ++) + . (++ "\nPlease report this at https://github.com/purescript/purescript/issues") + . show diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 3d49800f8f..b34829119b 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -157,7 +157,7 @@ convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = convertClassMember (P.TypeDeclaration ident' ty) = ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty) convertClassMember _ = - error "Invalid argument to convertClassMember." + P.internalError "convertDeclaration: Invalid argument to convertClassMember." convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = Just (Left (classNameString : typeNameStrings, AugmentChild childDecl)) where diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index 35030fa42c..1af0c09896 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -22,6 +22,7 @@ import Data.Maybe (fromMaybe) import Control.Arrow ((<+>)) import Control.PatternArrows +import Language.PureScript.Crash import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Kinds @@ -163,7 +164,7 @@ renderKind = kind . prettyPrintKind -- renderTypeAtom :: Type -> RenderedCode renderTypeAtom = - fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . preprocessType defaultRenderTypeOptions + fromMaybe (internalError "Incomplete pattern") . pattern matchTypeAtom () . preprocessType defaultRenderTypeOptions -- | @@ -181,4 +182,4 @@ defaultRenderTypeOptions = RenderTypeOptions { prettyPrintObjects = True } renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode renderTypeWithOptions opts = - fromMaybe (error "Incomplete pattern") . pattern matchType () . preprocessType opts + fromMaybe (internalError "Incomplete pattern") . pattern matchType () . preprocessType opts diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 006c1fad61..7e54c0301d 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -25,6 +25,7 @@ import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Aeson as A +import Language.PureScript.Crash import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.TypeClassDictionaries @@ -252,7 +253,7 @@ primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star -- lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident]) lookupConstructor env ctor = - fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env + fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env -- | -- Checks whether a data constructor is for a newtype. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index cd8b0b80cf..5eb6e1a870 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -41,6 +41,7 @@ import Control.Applicative ((<$>), (<*>), Applicative, pure) import Control.Monad.Trans.State.Lazy import Control.Arrow(first) +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Pretty import Language.PureScript.Types @@ -105,7 +106,6 @@ data SimpleErrorMessage | CycleInTypeSynonym (Maybe ProperName) | CycleInModules [ModuleName] | NameIsUndefined Ident - | NameNotInScope Ident | UndefinedTypeVariable ProperName | PartiallyAppliedSynonym (Qualified ProperName) | EscapedSkolem (Maybe Expr) @@ -130,7 +130,7 @@ data SimpleErrorMessage | CannotApplyFunction Type Expr | TypeSynonymInstance | OrphanInstance Ident (Qualified ProperName) [Type] - | InvalidNewtype + | InvalidNewtype ProperName | InvalidInstanceHead Type | TransitiveExportError DeclarationRef [DeclarationRef] | ShadowedName Ident @@ -241,7 +241,6 @@ errorCode em = case unwrapErrorMessage em of CycleInTypeSynonym{} -> "CycleInTypeSynonym" CycleInModules{} -> "CycleInModules" NameIsUndefined{} -> "NameIsUndefined" - NameNotInScope{} -> "NameNotInScope" UndefinedTypeVariable{} -> "UndefinedTypeVariable" PartiallyAppliedSynonym{} -> "PartiallyAppliedSynonym" EscapedSkolem{} -> "EscapedSkolem" @@ -266,7 +265,7 @@ errorCode em = case unwrapErrorMessage em of CannotApplyFunction{} -> "CannotApplyFunction" TypeSynonymInstance -> "TypeSynonymInstance" OrphanInstance{} -> "OrphanInstance" - InvalidNewtype -> "InvalidNewtype" + InvalidNewtype{} -> "InvalidNewtype" InvalidInstanceHead{} -> "InvalidInstanceHead" TransitiveExportError{} -> "TransitiveExportError" ShadowedName{} -> "ShadowedName" @@ -403,18 +402,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (ErrorParsingFFIModule path) = paras [ line "Unable to parse foreign module:" , indent . line $ path - , line "Ensure that all foreign modules contain a single module header at the start of a line, as follows:" - , indent $ line "// module A.B.C" ] renderSimpleErrorMessage (ErrorParsingModule err) = paras [ line "Unable to parse module: " , prettyPrintParseError err ] renderSimpleErrorMessage (MissingFFIModule mn) = - paras [ line $ "The foreign module implementation for module " ++ runModuleName mn ++ " is missing." - , line $ "Provide your foreign module implementation using the --ffi command line option, and ensure that your module contains the following module header:" - , indent . line $ "// module " ++ runModuleName mn - ] + line $ "The foreign module implementation for module " ++ runModuleName mn ++ " is missing." renderSimpleErrorMessage (UnnecessaryFFIModule mn path) = paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ runModuleName mn ++ ": " , indent . line $ path @@ -423,8 +417,6 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (MultipleFFIModules mn paths) = paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": " , indent . paras $ map line paths - , line "Foreign modules are identified by a unique module name, as follows:" - , indent $ line "// module A.B.C" ] renderSimpleErrorMessage InvalidDoBind = line "The last statement in a 'do' block must be an expression, but this block ends with a binder." @@ -451,7 +443,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , indent . paras $ map (line . displaySourceSpan) filenames ] renderSimpleErrorMessage (RedefinedIdent name) = - line $ "The name " ++ showIdent name ++ " has been defined multiple times" + line $ "The value " ++ showIdent name ++ " has been defined multiple times" renderSimpleErrorMessage (UnknownModule mn) = line $ "Unknown module " ++ runModuleName mn renderSimpleErrorMessage (UnknownType name) = @@ -465,15 +457,21 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (UnknownDataConstructor dc tc) = line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc renderSimpleErrorMessage (UnknownImportType mn name) = - line $ "The type " ++ runProperName name ++ " is not exported by the module " ++ runModuleName mn + paras [ line $ "Cannot import the type " ++ runProperName name ++ " from module " ++ runModuleName mn + , line "It either does not exist or the module does not export it." + ] renderSimpleErrorMessage (UnknownExportType name) = line $ "Cannot export unknown type " ++ runProperName name renderSimpleErrorMessage (UnknownImportTypeClass mn name) = - line $ "The type class " ++ runProperName name ++ " is not exported by the module " ++ runModuleName mn + paras [ line $ "Cannot import the type class " ++ runProperName name ++ " from module " ++ runModuleName mn + , line "It either does not exist or the module does not export it." + ] renderSimpleErrorMessage (UnknownExportTypeClass name) = line $ "Cannot export unknown type class " ++ runProperName name renderSimpleErrorMessage (UnknownImportValue mn name) = - line $ "The value " ++ showIdent name ++ " is not exported by the module " ++ runModuleName mn + paras [ line $ "Cannot import the value " ++ showIdent name ++ " from module " ++ runModuleName mn + , line "It either does not exist or the module does not export it." + ] renderSimpleErrorMessage (UnknownExportValue name) = line $ "Cannot export unknown value " ++ showIdent name renderSimpleErrorMessage (UnknownExportModule name) = @@ -481,7 +479,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , line "It either does not exist or has not been imported by the current module." ] renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) = - line $ "The data constructor " ++ runProperName dcon ++ " (for type " ++ runProperName tcon ++ ") is not exported by the module " ++ runModuleName mn + line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) = line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared." renderSimpleErrorMessage (ConflictingImport nm mn) = @@ -510,10 +508,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (DuplicateValueExport nm) = line $ "Duplicate export declaration for value " ++ showIdent nm renderSimpleErrorMessage (CycleInDeclaration nm) = - paras [ line $ "The declaration of " ++ showIdent nm ++ " contains a cycle." - , line $ "The value of " ++ showIdent nm ++ " may not be defined here, so this reference is not allowed." - , line "You might be able to evaluate this expression lazily, using something like Control.Lazy.fix" - ] + line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = line $ "There is a cycle in the module dependencies: " ++ intercalate ", " (map runModuleName mns) renderSimpleErrorMessage (CycleInTypeSynonym name) = @@ -524,9 +519,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , line "Consider using a 'newtype' instead." ] renderSimpleErrorMessage (NameIsUndefined ident) = - line $ "The name " ++ showIdent ident ++ " is undefined." - renderSimpleErrorMessage (NameNotInScope ident) = - line $ "The name " ++ showIdent ident ++ " may not be defined in the current scope." + line $ "The value " ++ showIdent ident ++ " is undefined." renderSimpleErrorMessage (UndefinedTypeVariable name) = line $ "The type variable " ++ runProperName name ++ " is undefined." renderSimpleErrorMessage (PartiallyAppliedSynonym name) = @@ -539,21 +532,21 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , indent $ prettyPrintValue expr ]) binding renderSimpleErrorMessage (TypesDoNotUnify t1 t2) - = paras [ line "The type" + = paras [ line "Could not match expected type" , indent $ typeAsBox t1 - , line "cannot be made equal to the type" + , line "with actual type" , indent $ typeAsBox t2 ] renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = - paras [ line "The kind" + paras [ line "Could not match expected kind" , indent $ line $ prettyPrintKind k1 - , line "cannot be made equal to the kind" + , line "with actual kind" , indent $ line $ prettyPrintKind k2 ] renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) = - paras [ line "The constrained type" + paras [ line "Could not match the constrained type" , indent $ typeAsBox t1 - , line "cannot be made equal to the kind" + , line "with type" , indent $ typeAsBox t2 ] renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) = @@ -563,8 +556,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir ] , line "The following instances were found:" , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds) + , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended." + , line "They may be disallowed completely in a future version of the compiler." ] - renderSimpleErrorMessage OverlappingInstances{} = error "OverlappingInstances: empty instance list" + renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list" renderSimpleErrorMessage (NoInstanceFound nm ts) = paras [ line "No type class instance was found for" , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) @@ -587,7 +582,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (CannotFindDerivingType nm) = line $ "Cannot derive a type class instance, because the type declaration for " ++ runProperName nm ++ " could not be found." renderSimpleErrorMessage (DuplicateLabel l expr) = - paras $ [ line $ "The duplicate label " ++ show l ++ " appears in a row type." ] + paras $ [ line $ "The label " ++ show l ++ " appears more than once in a row type." ] <> foldMap (\expr' -> [ line "Relevant expression: " , indent $ prettyPrintValue expr' ]) expr @@ -622,7 +617,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (PropertyIsMissing prop row) = paras [ line "The row type" , indent $ prettyPrintRowWith '(' ')' row - , line $ "lacks the required property " ++ show prop + , line $ "lacks the required label " ++ show prop ] renderSimpleErrorMessage (CannotApplyFunction fn arg) = paras [ line "A function of type" @@ -641,11 +636,14 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , line "An orphan instance is an instance which is defined in neither the class module nor the data type module." , line "Consider moving the instance, if possible, or using a newtype wrapper." ] - renderSimpleErrorMessage InvalidNewtype = - line "Newtypes must define a single constructor with a single argument." + renderSimpleErrorMessage (InvalidNewtype name) = + paras [ line $ "The newtype " ++ runProperName name ++ " is invalid." + , line "Newtypes must define a single constructor with a single argument." + ] renderSimpleErrorMessage (InvalidInstanceHead ty) = - paras [ line "An invalid type appears in a type class instance head:" + paras [ line "Type class instance head is invalid due to the use of the type" , indent $ typeAsBox ty + , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form." ] renderSimpleErrorMessage (TransitiveExportError x ys) = paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ") @@ -697,9 +695,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderHint (NotYetDefined names) = line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":" renderHint (ErrorUnifyingTypes t1 t2) = - paras [ lineWithLevel "while trying to make the type " + paras [ lineWithLevel "while trying to match the type " , indent $ typeAsBox t1 - , line "equal to the type" + , line "with the type" , indent $ typeAsBox t2 ] renderHint (ErrorInExpression expr) = @@ -712,7 +710,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderHint (ErrorInSubsumption t1 t2) = paras [ lineWithLevel "checking that the type" , indent $ typeAsBox t1 - , line "is more general than the type" + , line "is at least as general as the type" , indent $ typeAsBox t2 ] renderHint (ErrorInInstance nm ts) = diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 206d8a08de..bed882bb63 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -38,6 +38,7 @@ import Data.Aeson.TH import qualified Data.Map as M +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Names @@ -152,7 +153,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar -- | Generate an externs file for all declarations in a module moduleToExternsFile :: Module -> Environment -> ExternsFile -moduleToExternsFile (Module _ _ _ _ Nothing) _ = error "moduleToExternsFile: module exports were not elaborated" +moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated" moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} where efVersion = showVersion Paths.version @@ -181,7 +182,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r toExternsDeclaration (TypeRef pn dctors) = case Qualified (Just mn) pn `M.lookup` types env of - Nothing -> error "toExternsDeclaration: no kind in toExternsDeclaration" + Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration" Just (kind, TypeSynonym) | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ] Just (kind, ExternData) -> [ EDType pn kind ExternData ] @@ -190,7 +191,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} | dctor <- fromMaybe (map fst tys) dctors , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env)) ] - _ -> error "toExternsDeclaration: Invalid input" + _ -> internalError "toExternsDeclaration: Invalid input" toExternsDeclaration (ValueRef ident) | Just (ty, _, _) <- (mn, ident) `M.lookup` names env = [ EDValue ident ty ] diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index fb98e72f35..2e1c0fa3ee 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -30,6 +30,7 @@ import Control.Applicative #endif import Control.Monad.Writer.Class +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Errors @@ -50,7 +51,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl getDeclIdent (ValueDeclaration ident _ _ _) = Just ident getDeclIdent (ExternDeclaration ident _) = Just ident getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident - getDeclIdent (BindingGroupDeclaration _) = error "lint: binding groups should not be desugared yet." + getDeclIdent (BindingGroupDeclaration _) = internalError "lint: binding groups should not be desugared yet." getDeclIdent _ = Nothing lintDeclaration :: Declaration -> m () diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index fd6df8bf52..d0184bcfeb 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -38,6 +38,7 @@ import Control.Applicative import Control.Arrow (first, second) import Control.Monad.Writer.Class +import Language.PureScript.Crash import Language.PureScript.AST.Binders import Language.PureScript.AST.Declarations import Language.PureScript.Environment @@ -92,7 +93,7 @@ getConstructors env defmn n = extractConstructors lnte extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])] extractConstructors (Just (_, DataType _ pt)) = pt - extractConstructors _ = error "Data name not in the scope of the current environment in extractConstructors" + extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors" -- | -- Replicates a wildcard binder @@ -197,7 +198,7 @@ missingCasesMultiple env mn = go where (miss1, pr1) = missingCasesSingle env mn x y (miss2, pr2) = go xs ys - go _ _ = error "Argument lengths did not match in missingCasesMultiple." + go _ _ = internalError "Argument lengths did not match in missingCasesMultiple." -- | -- Guard handling diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 4dce3b523f..bd2fc64762 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -72,6 +72,7 @@ import System.Directory import System.FilePath ((), takeDirectory) import System.IO.Error (tryIOError) +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Externs import Language.PureScript.Environment @@ -166,7 +167,7 @@ make MakeActions{..} ms = do barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar) for_ sorted $ \m -> fork $ do - let deps = fromMaybe (error "make: module not found in dependency graph.") (lookup (getModuleName m) graph) + let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph) buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted) -- Wait for all threads to complete, and collect errors. @@ -176,7 +177,7 @@ make MakeActions{..} ms = do unless (null errors) $ throwError (mconcat errors) -- Bundle up all the externs and return them as an Environment - (warnings, externs) <- unzip . fromMaybe (error "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd) + (warnings, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd) tell (mconcat warnings) return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs @@ -205,7 +206,7 @@ make MakeActions{..} ms = do -- We need to wait for dependencies to be built, before checking if the current -- module should be rebuilt, so the first thing to do is to wait on the -- MVars for the module's dependencies. - mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps + mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps outputTimestamp <- getOutputTimestamp moduleName dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps @@ -247,8 +248,8 @@ make MakeActions{..} ms = do where markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m () markComplete externs errors = do - putMVar (fst $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) externs - putMVar (snd $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) errors + putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs + putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors maximumMaybe :: (Ord a) => [a] -> Maybe a maximumMaybe [] = Nothing @@ -257,7 +258,7 @@ make MakeActions{..} ms = do -- Make sure a dependency exists shouldExist :: Maybe UTCTime -> UTCTime shouldExist (Just t) = t - shouldExist _ = error "make: dependency should already have been built." + shouldExist _ = internalError "make: dependency should already have been built." decodeExterns :: B.ByteString -> Maybe ExternsFile decodeExterns bs = do @@ -324,7 +325,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime)) getInputTimestamp mn = do - let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap + let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap e1 <- traverseEither getTimestamp path fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns return $ fmap (max fPath) e1 diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index cc4736b0af..9e22c65f94 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -25,6 +25,7 @@ import Data.Graph import Data.List (nub) import Data.Maybe (fromMaybe, mapMaybe) +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types @@ -43,7 +44,7 @@ sortModules ms = do ms' <- mapM toModule $ stronglyConnComp verts let (graph, fromVertex, toVertex) = graphFromEdges verts moduleGraph = do (_, mn, _) <- verts - let v = fromMaybe (error "sortModules: vertex not found") (toVertex mn) + let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn) deps = reachable graph v toKey i = case fromVertex i of (_, key, _) -> key return (mn, filter (/= mn) (map toKey deps)) diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 22a17ab812..51eba66efb 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -30,6 +30,7 @@ import Control.Monad.State import Control.PatternArrows import qualified Control.Arrow as A +import Language.PureScript.Crash import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Common import Language.PureScript.Pretty.Common @@ -251,13 +252,13 @@ prettyStatements sts = do -- Generate a pretty-printed string representing a Javascript expression -- prettyPrintJS1 :: JS -> String -prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS' +prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS' -- | -- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level -- prettyPrintJS :: [JS] -> String -prettyPrintJS = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements +prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements -- | -- Generate an indented, pretty-printed string representing a Javascript expression diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs index 236dd56465..3ceff6a64f 100644 --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -22,6 +22,7 @@ import Data.Maybe (fromMaybe) import Control.Arrow (ArrowPlus(..)) import Control.PatternArrows +import Language.PureScript.Crash import Language.PureScript.Kinds import Language.PureScript.Pretty.Common @@ -47,7 +48,7 @@ funKind = mkPattern match -- | Generate a pretty-printed string representing a Kind prettyPrintKind :: Kind -> String -prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind () +prettyPrintKind = fromMaybe (internalError "Incomplete pattern") . pattern matchKind () where matchKind :: Pattern () Kind String matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index e9757430b3..586f849bf7 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -27,6 +27,7 @@ import Data.Maybe (fromMaybe) import Control.Arrow ((<+>)) import Control.PatternArrows +import Language.PureScript.Crash import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds @@ -136,14 +137,14 @@ forall_ = mkPattern match match _ = Nothing typeAtomAsBox :: Type -> Box -typeAtomAsBox = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders +typeAtomAsBox = fromMaybe (internalError "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders -- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses prettyPrintTypeAtom :: Type -> String prettyPrintTypeAtom = render . typeAtomAsBox typeAsBox :: Type -> Box -typeAsBox = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders +typeAsBox = fromMaybe (internalError "Incomplete pattern") . pattern matchType () . insertPlaceholders -- | Generate a pretty-printed string representing a Type prettyPrintType :: Type -> String diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 2e358134b7..7c198153e6 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -25,6 +25,7 @@ import Data.List (intercalate) import Control.Arrow (second) +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Pretty.Common @@ -103,7 +104,7 @@ prettyPrintDeclaration (BindingGroupDeclaration ds) = where toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e) prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d -prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration" +prettyPrintDeclaration _ = internalError "Invalid argument to prettyPrintDeclaration" prettyPrintCaseAlternative :: CaseAlternative -> Box prettyPrintCaseAlternative (CaseAlternative binders result) = diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 29e6706049..d40083f6ee 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -35,6 +35,7 @@ import Control.Monad.Error.Class (MonadError(..)) import qualified Data.Set as S +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types @@ -145,13 +146,13 @@ usedProperNames moduleName = getIdent :: Declaration -> Ident getIdent (ValueDeclaration ident _ _ _) = ident getIdent (PositionedDeclaration _ _ d) = getIdent d -getIdent _ = error "Expected ValueDeclaration" +getIdent _ = internalError "Expected ValueDeclaration" getProperName :: Declaration -> ProperName getProperName (DataDeclaration _ pn _ _) = pn getProperName (TypeSynonymDeclaration pn _ _) = pn getProperName (PositionedDeclaration _ _ d) = getProperName d -getProperName _ = error "Expected DataDeclaration" +getProperName _ = internalError "Expected DataDeclaration" -- | -- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration). @@ -185,7 +186,7 @@ toBindingGroup moduleName (CyclicSCC ds') = cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n cycleError d ds@(_:_) = rethrow (addHint (NotYetDefined (map getIdent ds))) $ cycleError d [] - cycleError _ _ = error "Expected ValueDeclaration" + cycleError _ _ = internalError "Expected ValueDeclaration" toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration toDataBindingGroup (AcyclicSCC d) = return d @@ -203,6 +204,6 @@ isTypeSynonym _ = Nothing fromValueDecl :: Declaration -> (Ident, NameKind, Expr) fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val) -fromValueDecl ValueDeclaration{} = error "Binders should have been desugared" +fromValueDecl ValueDeclaration{} = internalError "Binders should have been desugared" fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d -fromValueDecl _ = error "Expected ValueDeclaration" +fromValueDecl _ = internalError "Expected ValueDeclaration" diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 5b55a44a12..e3e5062cec 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -23,6 +23,7 @@ module Language.PureScript.Sugar.CaseDeclarations ( desugarCasesModule ) where +import Language.PureScript.Crash import Data.Maybe (catMaybes) import Data.List (nub, groupBy) @@ -112,7 +113,7 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = fromVarBinder (VarBinder name) = return name fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b fromVarBinder (TypedBinder _ b) = fromVarBinder b - fromVarBinder _ = error "fromVarBinder: Invalid argument" + fromVarBinder _ = internalError "fromVarBinder: Invalid argument" toDecls ds@(ValueDeclaration ident _ bs result : _) = do let tuples = map toTuple ds unless (all ((== length bs) . length . fst) tuples) $ @@ -129,7 +130,7 @@ toDecls ds = return ds toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr) toTuple (ValueDeclaration _ _ bs result) = (bs, result) toTuple (PositionedDeclaration _ _ d) = toTuple d -toTuple _ = error "Not a value declaration" +toTuple _ = internalError "Not a value declaration" makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration makeCaseDeclaration ident alternatives = do diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index be86c202c7..72e6fa7a0e 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -22,6 +22,7 @@ module Language.PureScript.Sugar.DoNotation ( desugarDoModule ) where +import Language.PureScript.Crash import Language.PureScript.Names import Language.PureScript.AST import Language.PureScript.Errors @@ -56,7 +57,7 @@ desugarDo d = replace other = return other go :: [DoNotationElement] -> m Expr - go [] = error "The impossible happened in desugarDo" + go [] = internalError "The impossible happened in desugarDo" go [DoNotationValue val] = return val go (DoNotationValue val : rest) = do rest' <- go rest diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index ee2811531a..a885348b76 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -30,6 +30,7 @@ import Control.Monad.Writer (MonadWriter(..)) import qualified Data.Map as M +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Types @@ -99,7 +100,7 @@ desugarImports externs modules = do renameInModule' :: Env -> Module -> m Module renameInModule' env m@(Module _ _ mn _ _) = rethrow (addHint (ErrorInModule mn)) $ do - let (_, imps, exps) = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn env + let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env elaborateImports imps <$> renameInModule env imps (elaborateExports exps m) -- | diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 34c16492bd..192cd5f2ff 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -33,6 +33,7 @@ import Control.Monad.Error.Class (MonadError(..)) import qualified Data.Map as M +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Errors @@ -52,7 +53,7 @@ findExportable (Module _ _ mn ds _) = where go exps'' (TypeDeclaration name _) = exportValue exps'' name mn go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d - go _ _ = error "Invalid declaration in TypeClassDeclaration" + go _ _ = internalError "Invalid declaration in TypeClassDeclaration" updateExports exps (DataDeclaration _ tn _ dcs) = exportType exps tn (map fst dcs) mn updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn @@ -137,24 +138,24 @@ resolveExports env mn imps exps refs = resolveTypeExports tctors dctors = map go tctors where go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName) - go (Qualified (Just mn'') name) = fromMaybe (error "Missing value in resolveTypeExports") $ do + go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do exps' <- envModuleExports <$> mn'' `M.lookup` env ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps') let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mnOrig then Just dctor else Nothing) dctors return ((name, intersect relevantDctors dctors'), mnOrig) - go (Qualified Nothing _) = error "Unqualified value in resolveTypeExports" + go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports" -- Looks up an imported class and re-qualifies it with the original module it -- came from. resolveClass :: Qualified ProperName -> (ProperName, ModuleName) - resolveClass className = splitQual $ fromMaybe (error "Missing value in resolveClass") $ + resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $ resolve exportedTypeClasses className -- Looks up an imported value and re-qualifies it with the original module it -- came from. resolveValue :: Qualified Ident -> (Ident, ModuleName) - resolveValue ident = splitQual $ fromMaybe (error "Missing value in resolveValue") $ + resolveValue ident = splitQual $ fromMaybe (internalError "Missing value in resolveValue") $ resolve exportedValues ident resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a) @@ -162,13 +163,13 @@ resolveExports env mn imps exps refs = exps' <- envModuleExports <$> mn'' `M.lookup` env mn''' <- snd <$> find ((== a) . fst) (f exps') return $ Qualified (Just mn''') a - resolve _ _ = error "Unqualified value in resolve" + resolve _ _ = internalError "Unqualified value in resolve" -- A partial function that takes a qualified value and extracts the value and -- qualified module components. splitQual :: Qualified a -> (a, ModuleName) splitQual (Qualified (Just mn'') a) = (a, mn'') - splitQual _ = error "Unqualified value in splitQual" + splitQual _ = internalError "Unqualified value in splitQual" -- | -- Filters the full list of exportable values, types, and classes for a module diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 0839ba08f7..ab03420da4 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -34,6 +34,7 @@ import Control.Monad.Writer (MonadWriter(..), censor) import qualified Data.Map as M +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Errors @@ -115,7 +116,7 @@ resolveImport currentModule importModule exps imps impQual = checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name --check (ModuleRef name) = -- checkImportExists (const UnknownModule) (exportedModules exps) name - check _ = error "Invalid argument to checkRefs" + check _ = internalError "Invalid argument to checkRefs" -- Check that an explicitly imported item exists in the module it is being imported from checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m () @@ -171,13 +172,13 @@ resolveImport currentModule importModule exps imps impQual = importExplicit imp (TypeClassRef name) = do typeClasses' <- updateImports (importedTypeClasses imp) runProperName (exportedTypeClasses exps) name return $ imp { importedTypeClasses = typeClasses' } - importExplicit _ _ = error "Invalid argument to importExplicit" + importExplicit _ _ = internalError "Invalid argument to importExplicit" -- Find all exported data constructors for a given type allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)] allExportedDataConstructors name = case find ((== name) . fst . fst) (exportedTypes exps) of - Nothing -> error "Invalid state in allExportedDataConstructors" + Nothing -> internalError "Invalid state in allExportedDataConstructors" Just ((_, dctors), mn) -> map (, mn) dctors -- Add something to the Imports if it does not already exist there @@ -191,7 +192,7 @@ resolveImport currentModule importModule exps imps impQual = -- If the name is not already present add it to the list, after looking up -- where it was originally defined Nothing -> - let mnOrig = fromMaybe (error "Invalid state in updateImports") (name `lookup` exps') + let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) imps' -- If the name already is present check whether it's a duplicate import @@ -199,7 +200,7 @@ resolveImport currentModule importModule exps imps impQual = -- re-exports A, importing A and B in C should not result in a "conflicting -- import for `x`" error Just (Qualified (Just mn) _, mnOrig) - | mnOrig == fromMaybe (error "Invalid state in updateImports") (name `lookup` exps') -> return imps' + | mnOrig == fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') -> return imps' | otherwise -> throwError . errorMessage $ err where err = if currentModule `elem` [mn, importModule] @@ -207,4 +208,4 @@ resolveImport currentModule importModule exps imps impQual = else ConflictingImports (render name) mn importModule Just (Qualified Nothing _, _) -> - error "Invalid state in updateImports" + internalError "Invalid state in updateImports" diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index f7f24beb2a..116c2a0502 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -29,6 +29,7 @@ module Language.PureScript.Sugar.Operators ( desugarOperatorSections ) where +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Names @@ -93,7 +94,7 @@ collectFixities (Module _ _ moduleName ds _) = concatMap collect ds where collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)] collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)] - collect FixityDeclaration{} = error "Fixity without srcpos info" + collect FixityDeclaration{} = internalError "Fixity without srcpos info" collect _ = [] ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m () @@ -129,7 +130,7 @@ matchOperators ops = parseChains extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r extendChain other = [Left other] bracketChain :: Chain -> m Expr - bracketChain = either (\_ -> error "matchOperators: cannot reorder operators") return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression" + bracketChain = either (\_ -> internalError "matchOperators: cannot reorder operators") return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression" opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft] : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]] diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 03f92feed7..97ea9c4e8a 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -24,6 +24,7 @@ module Language.PureScript.Sugar.TypeClasses , superClassDictionaryNames ) where +import Language.PureScript.Crash import Language.PureScript.AST hiding (isExported) import Language.PureScript.Environment import Language.PureScript.Errors @@ -75,7 +76,7 @@ desugarModule (Module ss coms name decls (Just exps)) = do | isTypeClassDeclaration d1 && not (isTypeClassDeclaration d2) = LT | not (isTypeClassDeclaration d1) && isTypeClassDeclaration d2 = GT | otherwise = EQ -desugarModule _ = error "Exports should have been elaborated in name desugaring" +desugarModule _ = internalError "Exports should have been elaborated in name desugaring" {- Desugar type class and type class instance declarations -- @@ -177,7 +178,7 @@ desugarDecl mn exps = go go d@(TypeClassDeclaration name args implies members) = do modify (M.insert (mn, name) (args, implies, members)) return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) - go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = error "Derived instanced should have been desugared" + go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do desugared <- desugarCases members dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared @@ -200,7 +201,7 @@ desugarDecl mn exps = go isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps - isExported _ _ = error "Names should have been qualified in name desugaring" + isExported _ _ = internalError "Names should have been qualified in name desugaring" matchesTypeRef :: ProperName -> DeclarationRef -> Bool matchesTypeRef pn (TypeRef pn' _) = pn == pn' @@ -216,7 +217,7 @@ desugarDecl mn exps = go memberToNameAndType :: Declaration -> (Ident, Type) memberToNameAndType (TypeDeclaration ident ty) = (ident, ty) memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d -memberToNameAndType _ = error "Invalid declaration in type class definition" +memberToNameAndType _ = internalError "Invalid declaration in type class definition" typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration typeClassDictionaryDeclaration name args implies members = @@ -236,7 +237,7 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) = moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty)) typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) = PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d -typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition" +typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" unit :: Type unit = TypeApp tyObject REmpty @@ -294,13 +295,13 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do val <- memberToValue tys' d return (PositionedValue pos com val) - memberToValue _ _ = error "Invalid declaration in type instance definition" + memberToValue _ _ = internalError "Invalid declaration in type instance definition" typeClassMemberName :: Declaration -> String typeClassMemberName (TypeDeclaration ident _) = runIdent ident typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d -typeClassMemberName _ = error "typeClassMemberName: Invalid declaration in type class definition" +typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration in type class definition" superClassDictionaryNames :: [Constraint] -> [String] superClassDictionaryNames supers = diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 10dc9e1280..d83d383297 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -36,6 +36,7 @@ import Control.Monad (replicateM) import Control.Monad.Supply.Class (MonadSupply, freshName) import Control.Monad.Error.Class (MonadError(..)) +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Errors @@ -116,7 +117,7 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl $ decomposeRec rec toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d -mkSpineFunction _ _ = error "mkSpineFunction: expected DataDeclaration" +mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration" mkSignatureFunction :: ModuleName -> Declaration -> Expr mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args @@ -145,7 +146,7 @@ mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map m mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature) (TypedValue False (mkGenVar "anyProxy") (proxy typ)) mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d -mkSignatureFunction _ _ = error "mkSignatureFunction: expected DataDeclaration" +mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration" mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args) @@ -194,7 +195,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs) where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d -mkFromSpineFunction _ _ = error "mkFromSpineFunction: expected DataDeclaration" +mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration" -- Helpers diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index f6ecf37509..87a764492c 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -29,6 +29,7 @@ import Control.Monad (forM, when) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(tell)) +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Environment @@ -63,7 +64,7 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) -> -- At the top level, match a type signature or emit a warning. when reqd $ case val of Right TypedValue{} -> return () - Left _ -> error "desugarTypeDeclarations: cases were not desugared" + Left _ -> internalError "desugarTypeDeclarations: cases were not desugared" _ -> tell (addHint (ErrorInValueDeclaration name) $ errorMessage $ MissingTypeDeclaration name) let (_, f, _) = everywhereOnValuesTopDownM return go return f' (Left gs) = Left <$> mapM (pairM return f) gs diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 7164eebb55..37333b34f8 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -38,6 +38,7 @@ import Control.Applicative ((<$>), (<*)) import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) +import Language.PureScript.Crash import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds @@ -90,7 +91,7 @@ addTypeClass moduleName pn args implies ds = where toPair (TypeDeclaration ident ty) = (ident, ty) toPair (PositionedDeclaration _ _ d) = toPair d - toPair _ = error "Invalid declaration in TypeClassDeclaration" + toPair _ = internalError "Invalid declaration in TypeClassDeclaration" addTypeClassDictionaries :: Maybe ModuleName -> M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) -> Check () addTypeClassDictionaries mn entries = @@ -147,8 +148,8 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds where checkNewtype :: [(ProperName, [Type])] -> Check () checkNewtype [(_, [_])] = return () - checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype - checkNewtype _ = throwError . errorMessage $ InvalidNewtype + checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name + checkNewtype _ = throwError . errorMessage $ InvalidNewtype name go (d@(DataBindingGroupDeclaration tys)) = do warnAndRethrow (addHint ErrorInDataBindingGroup) $ do let syns = mapMaybe toTypeSynonym tys @@ -177,14 +178,14 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds let args' = args `withKinds` kind addTypeSynonym moduleName name args' ty kind return $ TypeSynonymDeclaration name args ty - go (TypeDeclaration{}) = error "Type declarations should have been removed" + go (TypeDeclaration{}) = internalError "Type declarations should have been removed" go (ValueDeclaration name nameKind [] (Right val)) = warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do valueIsNotDefined moduleName name [(_, (val', ty))] <- typesOf moduleName [(name, val)] addValue moduleName name ty nameKind return $ ValueDeclaration name nameKind [] $ Right val' - go (ValueDeclaration{}) = error "Binders were not desugared" + go (ValueDeclaration{}) = internalError "Binders were not desugared" go (BindingGroupDeclaration vals) = warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do forM_ (map (\(ident, _, _) -> ident) vals) $ \name -> @@ -245,7 +246,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds memberName :: Declaration -> Ident memberName (ValueDeclaration ident _ _ _) = ident memberName (PositionedDeclaration _ _ d) = memberName d - memberName _ = error "checkInstanceMembers: Invalid declaration in type instance definition" + memberName _ = internalError "checkInstanceMembers: Invalid declaration in type instance definition" firstDuplicate :: (Eq a) => [a] -> Maybe a firstDuplicate (x : xs@(y : _)) @@ -261,10 +262,10 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds checkType :: Type -> Bool checkType (TypeVar _) = False checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn'' - checkType (TypeConstructor (Qualified Nothing _)) = error "Unqualified type name in checkOrphanInstance" + checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance" checkType (TypeApp t1 _) = checkType t1 - checkType _ = error "Invalid type in instance in checkOrphanInstance" - checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance" + checkType _ = internalError "Invalid type in instance in checkOrphanInstance" + checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance" -- | -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, @@ -274,14 +275,14 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds withKinds [] _ = [] withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2 - withKinds _ _ = error "Invalid arguments to peelKinds" + withKinds _ _ = internalError "Invalid arguments to peelKinds" -- | -- Type check an entire module and ensure all types and classes defined within the module that are -- required by exported members are also exported. -- typeCheckModule :: Module -> Check Module -typeCheckModule (Module _ _ _ _ Nothing) = error "exports should have been elaborated" +typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated" typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do modify (\s -> s { checkCurrentModule = Just mn }) decls' <- typeCheckAll mn exps decls @@ -331,7 +332,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint findTcons :: Type -> [DeclarationRef] findTcons = everythingOnTypes (++) go where - go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (error "Data constructors unused in checkTypesAreExported")] + go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (internalError "Data constructors unused in checkTypesAreExported")] go _ = [] -- Check that all the classes defined in the current module that appear in member types have also @@ -361,5 +362,5 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint extractMemberName :: Declaration -> Ident extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d extractMemberName (TypeDeclaration memberName _) = memberName - extractMemberName _ = error "Unexpected declaration in typeclass member list" + extractMemberName _ = internalError "Unexpected declaration in typeclass member list" checkClassMembersAreExported _ = return () diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 63490c48a0..3bc4f3037e 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -35,6 +35,7 @@ import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (tell) +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Names @@ -53,11 +54,11 @@ entails moduleName context = solve where forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope] forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys)) - forClassName _ _ = error "forClassName: expected qualified class name" + forClassName _ _ = internalError "forClassName: expected qualified class name" ctorModules :: Type -> Maybe ModuleName ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn - ctorModules (TypeConstructor (Qualified Nothing _)) = error "ctorModules: unqualified type name" + ctorModules (TypeConstructor (Qualified Nothing _)) = internalError "ctorModules: unqualified type name" ctorModules (TypeApp ty _) = ctorModules ty ctorModules _ = Nothing diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 26c2e8757e..6b024e1985 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -40,6 +40,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State import Control.Monad.Unify +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Kinds @@ -220,4 +221,4 @@ infer' other = (, []) <$> go other k <- go ty k =?= Star return Star - go _ = error "Invalid argument to infer" + go _ = internalError "Invalid argument to infer" diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 22c0d8c22d..33a791e906 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -153,7 +153,7 @@ checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, Mona checkVisibility currentModule name@(Qualified _ var) = do vis <- getVisibility currentModule name case vis of - Undefined -> throwError . errorMessage $ NameNotInScope var + Undefined -> throwError . errorMessage $ CycleInDeclaration var _ -> return () -- | diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index c388b6fc42..46e8d4a4bc 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -33,6 +33,7 @@ import Control.Applicative import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Unify +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad @@ -115,4 +116,4 @@ skolemEscapeCheck root@TypedValue{} = where go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val) go' _ = mempty -skolemEscapeCheck _ = error "Untyped value passed to skolemEscapeCheck" +skolemEscapeCheck _ = internalError "Untyped value passed to skolemEscapeCheck" diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index a1a9a16bed..c4f2904128 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -22,6 +22,7 @@ import Data.Ord (comparing) import Control.Monad.Unify +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Errors @@ -49,7 +50,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) = sko <- newSkolemConstant let sk = skolemize ident sko sco' ty2 subsumes val ty1 sk - Nothing -> error "subsumes: unspecified skolem scope" + Nothing -> internalError "subsumes: unspecified skolem scope" subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do _ <- subsumes Nothing arg2 arg1 _ <- subsumes Nothing ret1 ret2 diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 4611e1f57b..ba321190a4 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -51,6 +51,7 @@ import Control.Monad.State import Control.Monad.Unify import Control.Monad.Error.Class (MonadError(..)) +import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Errors @@ -138,7 +139,7 @@ typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT typeForBindingGroupElement (ident, val) dict untypedDict = 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) + ty =?= fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict) return (ident, (TypedValue True val' ty, ty)) -- | @@ -189,7 +190,7 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do instantiatePolyTypeWithUnknowns val ty' instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do dicts <- getTypeClassDictionaries - (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty + (_, ty') <- instantiatePolyTypeWithUnknowns (internalError "Types under a constraint cannot themselves be constrained") ty return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty') instantiatePolyTypeWithUnknowns val ty = return (val, ty) @@ -239,7 +240,7 @@ infer' (Abs (Left arg) ret) = do withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do body@(TypedValue _ _ bodyTy) <- infer' ret return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy -infer' (Abs (Right _) _) = error "Binder was not desugared" +infer' (Abs (Right _) _) = internalError "Binder was not desugared" infer' (App f arg) = do f'@(TypedValue _ _ ft) <- infer f (ret, app) <- checkFunctionApplication f' ft arg Nothing @@ -284,7 +285,7 @@ infer' (TypedValue checkType val ty) = do val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val return $ TypedValue True val' ty' infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val -infer' _ = error "Invalid argument to infer" +infer' _ = internalError "Invalid argument to infer" inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr) inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) @@ -315,7 +316,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do (d' : ds', val') <- inferLetBinding seen (d : ds) ret j return (PositionedDeclaration pos com d' : ds', val') -inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding" +inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding" -- | -- Infer the types of variables brought into scope by a binder @@ -332,7 +333,7 @@ inferBinder val (ConstructorBinder ctor binders) = do env <- getEnv case M.lookup ctor (dataConstructors env) of Just (_, _, ty, _) -> do - (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty + (_, fn) <- instantiatePolyTypeWithUnknowns (internalError "Data constructor types cannot contain constraints") ty fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn go binders fn' where @@ -449,7 +450,7 @@ check' val t@(ConstrainedType constraints ty) = do newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> Check [TypeClassDictionaryInScope] newDictionaries path name (className, instanceTy) = do tcs <- gets (typeClasses . checkEnv) - let (args, _, superclasses) = fromMaybe (error "newDictionaries: type class lookup failed") $ M.lookup className tcs + let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs supDicts <- join <$> zipWithM (\(supName, supArgs) index -> newDictionaries ((supName, index) : path) name @@ -484,7 +485,7 @@ check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do Just moduleName <- checkCurrentModule <$> get ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy return $ TypedValue True (Abs (Left arg) ret') ty -check' (Abs (Right _) _) _ = error "Binder was not desugared" +check' (Abs (Right _) _) _ = internalError "Binder was not desugared" check' (App f arg) ret = do f'@(TypedValue _ _ ft) <- infer f (_, app) <- checkFunctionApplication f' ft arg (Just ret) @@ -496,7 +497,7 @@ check' v@(Var var) ty = do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty v' <- subsumes (Just v) repl ty' case v' of - Nothing -> error "check: unable to check the subsumes relation." + Nothing -> internalError "check: unable to check the subsumes relation." Just v'' -> return $ TypedValue True v'' ty' check' (SuperClassDictionary className tys) _ = do {- @@ -515,7 +516,7 @@ check' (TypedValue checkType val ty1) ty2 = do ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2 val' <- subsumes (Just val) ty1' ty2' case val' of - Nothing -> error "check: unable to check the subsumes relation." + Nothing -> internalError "check: unable to check the subsumes relation." Just _ -> do val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val return $ TypedValue checkType val''' ty2' @@ -557,7 +558,7 @@ check' v@(Constructor c) ty = do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 mv <- subsumes (Just v) repl ty case mv of - Nothing -> error "check: unable to check the subsumes relation." + Nothing -> internalError "check: unable to check the subsumes relation." Just v' -> return $ TypedValue True v' ty check' (Let ds val) ty = do (ds', val') <- inferLetBinding [] ds val (`check` ty) @@ -572,7 +573,7 @@ check' val ty = do TypedValue _ val' ty' <- infer val mt <- subsumes (Just val') ty' ty case mt of - Nothing -> error "check: unable to check the subsumes relation." + Nothing -> internalError "check: unable to check the subsumes relation." Just v' -> return $ TypedValue True v' ty -- | diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 8241d99842..4ffe2b63e2 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -36,6 +36,7 @@ import Control.Monad.Unify import Control.Monad.Writer import Control.Monad.Error.Class (MonadError(..)) +import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Skolems @@ -74,12 +75,12 @@ unifyTypes t1 t2 = rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ let sk1 = skolemize ident1 sko sc1' ty1 let sk2 = skolemize ident2 sko sc2' ty2 sk1 `unifyTypes` sk2 - _ -> error "unifyTypes: unspecified skolem scope" + _ -> internalError "unifyTypes: unspecified skolem scope" unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do sko <- newSkolemConstant let sk = skolemize ident sko sc ty1 sk `unifyTypes` ty2 - unifyTypes' ForAll{} _ = error "unifyTypes: unspecified skolem scope" + unifyTypes' ForAll{} _ = internalError "unifyTypes: unspecified skolem scope" unifyTypes' ty f@ForAll{} = f `unifyTypes` ty unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return () unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) = diff --git a/tests/Main.hs b/tests/Main.hs index 6d202e1b54..c6173b8b2b 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -78,7 +78,7 @@ modulesDir :: FilePath modulesDir = ".test_modules" "node_modules" makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make -makeActions foreigns = (P.buildMakeActions modulesDir (error "makeActions: input file map was read.") foreigns False) +makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False) { P.getInputTimestamp = getInputTimestamp , P.getOutputTimestamp = getOutputTimestamp } @@ -94,7 +94,7 @@ makeActions foreigns = (P.buildMakeActions modulesDir (error "makeActions: input getOutputTimestamp mn = do let filePath = modulesDir P.runModuleName mn exists <- liftIO $ doesDirectoryExist filePath - return (if exists then Just (error "getOutputTimestamp: read timestamp") else Nothing) + return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing) readInput :: [FilePath] -> IO [(FilePath, String)] readInput inputFiles = forM inputFiles $ \inputFile -> do diff --git a/tests/common/TestsSetup.hs b/tests/common/TestsSetup.hs index cc853ecb11..2dc1458d99 100644 --- a/tests/common/TestsSetup.hs +++ b/tests/common/TestsSetup.hs @@ -28,6 +28,8 @@ import System.Process import System.Directory import System.Info +import Language.PureScript.Crash + findNodeProcess :: IO (Maybe String) findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names where @@ -35,7 +37,7 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names fetchSupportCode :: IO () fetchSupportCode = do - node <- fromMaybe (error "cannot find node executable") <$> findNodeProcess + node <- fromMaybe (internalError "cannot find node executable") <$> findNodeProcess setCurrentDirectory "tests/support" if System.Info.os == "mingw32" then callProcess "setup-win.cmd" [] From 8432b7caa31b6e90080a118319cb55f94f54b1d3 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 24 Oct 2015 14:49:28 -0700 Subject: [PATCH 0083/1580] Remove some 'the's --- src/Language/PureScript/Errors.hs | 82 ++++++++++++++++--------------- 1 file changed, 42 insertions(+), 40 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 5eb6e1a870..89b38e2973 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -457,19 +457,19 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (UnknownDataConstructor dc tc) = line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc renderSimpleErrorMessage (UnknownImportType mn name) = - paras [ line $ "Cannot import the type " ++ runProperName name ++ " from module " ++ runModuleName mn + paras [ line $ "Cannot import type " ++ runProperName name ++ " from module " ++ runModuleName mn , line "It either does not exist or the module does not export it." ] renderSimpleErrorMessage (UnknownExportType name) = line $ "Cannot export unknown type " ++ runProperName name renderSimpleErrorMessage (UnknownImportTypeClass mn name) = - paras [ line $ "Cannot import the type class " ++ runProperName name ++ " from module " ++ runModuleName mn + paras [ line $ "Cannot import type class " ++ runProperName name ++ " from module " ++ runModuleName mn , line "It either does not exist or the module does not export it." ] renderSimpleErrorMessage (UnknownExportTypeClass name) = line $ "Cannot export unknown type class " ++ runProperName name renderSimpleErrorMessage (UnknownImportValue mn name) = - paras [ line $ "Cannot import the value " ++ showIdent name ++ " from module " ++ runModuleName mn + paras [ line $ "Cannot import value " ++ showIdent name ++ " from module " ++ runModuleName mn , line "It either does not exist or the module does not export it." ] renderSimpleErrorMessage (UnknownExportValue name) = @@ -483,7 +483,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) = line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared." renderSimpleErrorMessage (ConflictingImport nm mn) = - paras [ line $ "Cannot declare " ++ show nm ++ ", since another declaration of that name was imported from the module " ++ runModuleName mn + paras [ line $ "Cannot declare " ++ show nm ++ ", since another declaration of that name was imported from module " ++ runModuleName mn , line $ "Consider hiding " ++ show nm ++ " when importing " ++ runModuleName mn ++ ":" , indent . line $ "import " ++ runModuleName mn ++ " hiding (" ++ nm ++ ")" ] @@ -494,15 +494,15 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (ConflictingCtorDecls nm) = line $ "Conflicting data constructor declarations for " ++ runProperName nm renderSimpleErrorMessage (TypeConflictsWithClass nm) = - line $ "The type " ++ runProperName nm ++ " conflicts with a type class declaration of the same name." + line $ "Type " ++ runProperName nm ++ " conflicts with a type class declaration with the same name." renderSimpleErrorMessage (CtorConflictsWithClass nm) = - line $ "The data constructor " ++ runProperName nm ++ " conflicts with a type class declaration of the same name." + line $ "Data constructor " ++ runProperName nm ++ " conflicts with a type class declaration with the same name." renderSimpleErrorMessage (ClassConflictsWithType nm) = - line $ "The type class " ++ runProperName nm ++ " conflicts with a type declaration of the same name." + line $ "Type class " ++ runProperName nm ++ " conflicts with a type declaration with the same name." renderSimpleErrorMessage (ClassConflictsWithCtor nm) = - line $ "The type class " ++ runProperName nm ++ " conflicts with a data constructor declaration of the same name." + line $ "Type class " ++ runProperName nm ++ " conflicts with a data constructor declaration with the same name." renderSimpleErrorMessage (DuplicateModuleName mn) = - line $ "The module " ++ runModuleName mn ++ " has been defined multiple times." + line $ "Module " ++ runModuleName mn ++ " has been defined multiple times." renderSimpleErrorMessage (DuplicateClassExport nm) = line $ "Duplicate export declaration for type class " ++ runProperName nm renderSimpleErrorMessage (DuplicateValueExport nm) = @@ -510,20 +510,22 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (CycleInDeclaration nm) = line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = - line $ "There is a cycle in the module dependencies: " ++ intercalate ", " (map runModuleName mns) + paras [ line $ "There is a cycle in module dependencies in these modules: " + , indent $ paras (map (line . runModuleName) mns) + ] renderSimpleErrorMessage (CycleInTypeSynonym name) = paras [ line $ case name of - Just pn -> "A cycle appears in the definition of the type synonym " ++ runProperName pn + Just pn -> "A cycle appears in the definition of type synonym " ++ runProperName pn Nothing -> "A cycle appears in a set of type synonym definitions." , line "Cycles are disallowed because they can lead to loops in the type checker." , line "Consider using a 'newtype' instead." ] renderSimpleErrorMessage (NameIsUndefined ident) = - line $ "The value " ++ showIdent ident ++ " is undefined." + line $ "Value " ++ showIdent ident ++ " is undefined." renderSimpleErrorMessage (UndefinedTypeVariable name) = - line $ "The type variable " ++ runProperName name ++ " is undefined." + line $ "Type variable " ++ runProperName name ++ " is undefined." renderSimpleErrorMessage (PartiallyAppliedSynonym name) = - paras [ line $ "The type synonym " ++ showQualified runProperName name ++ " is partially applied." + paras [ line $ "Type synonym " ++ showQualified runProperName name ++ " is partially applied." , line "Type synonyms must be applied to all of their type arguments." ] renderSimpleErrorMessage (EscapedSkolem binding) = @@ -544,7 +546,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , indent $ line $ prettyPrintKind k2 ] renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) = - paras [ line "Could not match the constrained type" + paras [ line "Could not match constrained type" , indent $ typeAsBox t1 , line "with type" , indent $ typeAsBox t2 @@ -567,7 +569,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir ] ] renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) = - paras [ line "The type class instance for" + paras [ line "Type class instance for" , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) ] @@ -582,12 +584,12 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (CannotFindDerivingType nm) = line $ "Cannot derive a type class instance, because the type declaration for " ++ runProperName nm ++ " could not be found." renderSimpleErrorMessage (DuplicateLabel l expr) = - paras $ [ line $ "The label " ++ show l ++ " appears more than once in a row type." ] + paras $ [ line $ "Label " ++ show l ++ " appears more than once in a row type." ] <> foldMap (\expr' -> [ line "Relevant expression: " , indent $ prettyPrintValue expr' ]) expr renderSimpleErrorMessage (DuplicateTypeArgument name) = - line $ "The type argument " ++ show name ++ " appears more than once." + line $ "Type argument " ++ show name ++ " appears more than once." renderSimpleErrorMessage (DuplicateValueDeclaration nm) = line $ "Multiple value declarations exist for " ++ showIdent nm ++ "." renderSimpleErrorMessage (ArgListLengthsDiffer ident) = @@ -595,7 +597,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage (OverlappingArgNames ident) = line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident renderSimpleErrorMessage (MissingClassMember ident) = - line $ "The type class member " ++ showIdent ident ++ " has not been implemented." + line $ "Type class member " ++ showIdent ident ++ " has not been implemented." renderSimpleErrorMessage (ExtraneousClassMember ident className) = line $ showIdent ident ++ " is not a member of type class " ++ showQualified runProperName className renderSimpleErrorMessage (ExpectedType ty kind) = @@ -607,17 +609,17 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , line "instead." ] renderSimpleErrorMessage (IncorrectConstructorArity nm) = - line $ "The data constructor " ++ showQualified runProperName nm ++ " was given the wrong number of arguments in a case expression." + line $ "Data constructor " ++ showQualified runProperName nm ++ " was given the wrong number of arguments in a case expression." renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) = - paras [ line "The expression" + paras [ line "Expression" , indent $ prettyPrintValue expr , line "does not have type" , indent $ typeAsBox ty ] renderSimpleErrorMessage (PropertyIsMissing prop row) = - paras [ line "The row type" + paras [ line "Row type" , indent $ prettyPrintRowWith '(' ')' row - , line $ "lacks the required label " ++ show prop + , line $ "lacks required label " ++ show prop ] renderSimpleErrorMessage (CannotApplyFunction fn arg) = paras [ line "A function of type" @@ -628,7 +630,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderSimpleErrorMessage TypeSynonymInstance = line "Type class instances for type synonyms are disallowed." renderSimpleErrorMessage (OrphanInstance nm cnm ts) = - paras [ line $ "The type class instance " ++ showIdent nm ++ " for " + paras [ line $ "Type class instance " ++ showIdent nm ++ " for " , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm) , Box.vcat Box.left (map typeAtomAsBox ts) ] @@ -637,11 +639,11 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , line "Consider moving the instance, if possible, or using a newtype wrapper." ] renderSimpleErrorMessage (InvalidNewtype name) = - paras [ line $ "The newtype " ++ runProperName name ++ " is invalid." + paras [ line $ "Newtype " ++ runProperName name ++ " is invalid." , line "Newtypes must define a single constructor with a single argument." ] renderSimpleErrorMessage (InvalidInstanceHead ty) = - paras [ line "Type class instance head is invalid due to the use of the type" + paras [ line "Type class instance head is invalid due to use of type" , indent $ typeAsBox ty , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form." ] @@ -649,13 +651,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ") : map (line . prettyPrintExport) ys renderSimpleErrorMessage (ShadowedName nm) = - line $ "The name '" ++ showIdent nm ++ "' was shadowed." + line $ "Name '" ++ showIdent nm ++ "' was shadowed." renderSimpleErrorMessage (ShadowedTypeVar tv) = - line $ "The type variable '" ++ tv ++ "' was shadowed." + line $ "Type variable '" ++ tv ++ "' was shadowed." renderSimpleErrorMessage (UnusedTypeVar tv) = - line $ "The type variable '" ++ tv ++ "' was declared but not used." + line $ "Type variable '" ++ tv ++ "' was declared but not used." renderSimpleErrorMessage (ClassOperator className opName) = - paras [ line $ "The type class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "." + paras [ line $ "Type class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "." , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:" , indent . line $ showIdent opName ++ " = someMember" ] @@ -666,7 +668,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , line $ "An attempt was made to hide the import of " ++ runModuleName name ] renderSimpleErrorMessage (WildcardInferredType ty) = - paras [ line "The wildcard type definition has the inferred type " + paras [ line "Wildcard type definition has the inferred type " , indent $ typeAsBox ty ] renderSimpleErrorMessage (MissingTypeDeclaration ident) = @@ -695,9 +697,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir renderHint (NotYetDefined names) = line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":" renderHint (ErrorUnifyingTypes t1 t2) = - paras [ lineWithLevel "while trying to match the type " + paras [ lineWithLevel "while trying to match type " , indent $ typeAsBox t1 - , line "with the type" + , line "with type" , indent $ typeAsBox t2 ] renderHint (ErrorInExpression expr) = @@ -708,9 +710,9 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":" ] renderHint (ErrorInSubsumption t1 t2) = - paras [ lineWithLevel "checking that the type" + paras [ lineWithLevel "checking that type" , indent $ typeAsBox t1 - , line "is at least as general as the type" + , line "is at least as general as type" , indent $ typeAsBox t2 ] renderHint (ErrorInInstance nm ts) = @@ -720,17 +722,17 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir ] ] renderHint (ErrorCheckingKind ty) = - paras [ lineWithLevel "checking the kind of the type" + paras [ lineWithLevel "checking kind of type" , indent $ typeAsBox ty ] renderHint (ErrorInferringType expr) = - paras [ lineWithLevel "inferring the type of the expression" + paras [ lineWithLevel "inferring type of expression" , indent $ prettyPrintValue expr ] renderHint (ErrorCheckingType expr ty) = - paras [ lineWithLevel "checking that the expression" + paras [ lineWithLevel "checking that expression" , indent $ prettyPrintValue expr - , line "has the type" + , line "has type" , indent $ typeAsBox ty ] renderHint (ErrorInApplication f t a) = @@ -738,7 +740,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , indent $ prettyPrintValue f , line "of type" , indent $ typeAsBox t - , line "to the argument" + , line "to argument" , indent $ prettyPrintValue a ] renderHint (ErrorInDataConstructor nm) = From 3aa0748c40547ddb9a0bca5ac7976d8a610591ce Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 24 Oct 2015 14:55:32 -0700 Subject: [PATCH 0084/1580] Remove unused import --- src/Language/PureScript/Sugar/TypeDeclarations.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 59596ab739..f435e9452c 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -28,7 +28,6 @@ import Control.Applicative import Control.Monad (forM) import Control.Monad.Error.Class (MonadError(..)) -import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Environment From 21d6f4bece3ad004ca5b89166d2f9ef57043ceab Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 24 Oct 2015 15:20:20 -0700 Subject: [PATCH 0085/1580] Fix #1557 --- src/Language/PureScript/Errors.hs | 24 +++++++------------- src/Language/PureScript/TypeChecker/Types.hs | 4 ++-- 2 files changed, 10 insertions(+), 18 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8d2066a192..6065740f34 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -20,7 +20,7 @@ module Language.PureScript.Errors where import Data.Either (lefts, rights) -import Data.List (intercalate, transpose, nub, nubBy, partition) +import Data.List (intercalate, transpose, nub, nubBy) import Data.Function (on) #if __GLASGOW_HASKELL__ < 710 import Data.Foldable (fold, foldMap) @@ -154,6 +154,7 @@ data ErrorMessageHint | ErrorInModule ModuleName | ErrorInInstance (Qualified ProperName) [Type] | ErrorInSubsumption Type Type + | ErrorCheckingAccessor Expr String | ErrorCheckingType Expr Type | ErrorCheckingKind Type | ErrorInferringType Expr @@ -367,8 +368,8 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse -- Pretty print a single error, simplifying if necessary -- prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box -prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFirst . reverseHints <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) - where +prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) + where -- Pretty print an ErrorMessage prettyPrintErrorMessage :: ErrorMessage -> Box.Box @@ -735,6 +736,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir , line "has type" , indent $ typeAsBox ty ] + renderHint (ErrorCheckingAccessor expr prop) = + paras [ lineWithLevel "checking type of property accessor" + , indent $ prettyPrintValue (Accessor prop expr) + ] renderHint (ErrorInApplication f t a) = paras [ lineWithLevel "applying a function" , indent $ prettyPrintValue f @@ -782,19 +787,6 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage . positionHintsFir prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref - -- Hints get added at the front, so we need to reverse them before rendering - reverseHints :: ErrorMessage -> ErrorMessage - reverseHints (ErrorMessage hints simple) = ErrorMessage (reverse hints) simple - - -- | Put positional hints at the front of the list - positionHintsFirst :: ErrorMessage -> ErrorMessage - positionHintsFirst (ErrorMessage hints simple) = ErrorMessage (uncurry (++) $ partition (isPositionHint . hintCategory) hints) simple - where - isPositionHint :: HintCategory -> Bool - isPositionHint PositionHint = True - isPositionHint OtherHint = True - isPositionHint _ = False - -- | Simplify an error message simplifyErrorMessage :: ErrorMessage -> ErrorMessage simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index cc7fa03223..50faa623c7 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -232,7 +232,7 @@ infer' (ObjectUpdate o ps) = do let oldTy = TypeApp tyObject $ rowFromList (oldTys, row) o' <- TypedValue True <$> check o oldTy <*> pure oldTy return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row) -infer' (Accessor prop val) = do +infer' (Accessor prop val) = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do field <- fresh rest <- fresh typed <- check val (TypeApp tyObject (RCons prop field rest)) @@ -551,7 +551,7 @@ check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do 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 +check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do rest <- fresh val' <- check val (TypeApp tyObject (RCons prop ty rest)) return $ TypedValue True (Accessor prop val') ty From b1dfaf12fb841845f59061ab2ce31209924ffd5b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 25 Oct 2015 15:37:14 -0700 Subject: [PATCH 0086/1580] Display hints after main error, resolve #1563 --- src/Language/PureScript/Errors.hs | 202 ++++++++++-------- .../PureScript/Sugar/BindingGroups.hs | 23 +- 2 files changed, 128 insertions(+), 97 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6065740f34..9bfdac6ddd 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -56,8 +56,7 @@ import Text.Parsec.Error (Message(..)) -- | A type of error messages data SimpleErrorMessage - = ErrorParsingExterns P.ParseError - | ErrorParsingFFIModule FilePath + = ErrorParsingFFIModule FilePath | ErrorParsingModule P.ParseError | MissingFFIModule ModuleName | MultipleFFIModules ModuleName [FilePath] @@ -148,8 +147,7 @@ data SimpleErrorMessage -- | Error message hints, providing more detailed information about failure. data ErrorMessageHint - = NotYetDefined [Ident] - | ErrorUnifyingTypes Type Type + = ErrorUnifyingTypes Type Type | ErrorInExpression Expr | ErrorInModule ModuleName | ErrorInInstance (Qualified ProperName) [Type] @@ -192,7 +190,6 @@ instance UnificationError Kind ErrorMessage where -- errorCode :: ErrorMessage -> String errorCode em = case unwrapErrorMessage em of - ErrorParsingExterns{} -> "ErrorParsingExterns" ErrorParsingFFIModule{} -> "ErrorParsingFFIModule" ErrorParsingModule{} -> "ErrorParsingModule" MissingFFIModule{} -> "MissingFFIModule" @@ -375,9 +372,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError prettyPrintErrorMessage :: ErrorMessage -> Box.Box prettyPrintErrorMessage (ErrorMessage hints simple) = paras $ - map renderHint hints ++ - [ renderSimpleErrorMessage simple - , line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this " ++ levelText ++ "." + [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints + , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, " + , line $ "or to contribute content related to this " ++ levelText ++ "." + ] ] where wikiUri :: String @@ -396,10 +394,6 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError paras [ line "Unable to write file: " , indent . line $ path ] - renderSimpleErrorMessage (ErrorParsingExterns err) = - paras [ lineWithLevel "parsing externs files: " - , prettyPrintParseError err - ] renderSimpleErrorMessage (ErrorParsingFFIModule path) = paras [ line "Unable to parse foreign module:" , indent . line $ path @@ -694,81 +688,117 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , line "You may want to decompose your data types into smaller types." ] - renderHint :: ErrorMessageHint -> Box.Box - renderHint (NotYetDefined names) = - line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":" - renderHint (ErrorUnifyingTypes t1 t2) = - paras [ lineWithLevel "while trying to match type " - , indent $ typeAsBox t1 - , line "with type" - , indent $ typeAsBox t2 - ] - renderHint (ErrorInExpression expr) = - paras [ lineWithLevel "in expression:" - , indent $ prettyPrintValue expr - ] - renderHint (ErrorInModule mn) = - paras [ lineWithLevel $ "in module " ++ runModuleName mn ++ ":" - ] - renderHint (ErrorInSubsumption t1 t2) = - paras [ lineWithLevel "checking that type" - , indent $ typeAsBox t1 - , line "is at least as general as type" - , indent $ typeAsBox t2 - ] - renderHint (ErrorInInstance nm ts) = - paras [ lineWithLevel "in type class instance" - , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) - ] - ] - renderHint (ErrorCheckingKind ty) = - paras [ lineWithLevel "checking kind of type" - , indent $ typeAsBox ty - ] - renderHint (ErrorInferringType expr) = - paras [ lineWithLevel "inferring type of expression" - , indent $ prettyPrintValue expr - ] - renderHint (ErrorCheckingType expr ty) = - paras [ lineWithLevel "checking that expression" - , indent $ prettyPrintValue expr - , line "has type" - , indent $ typeAsBox ty + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box + renderHint (ErrorUnifyingTypes t1 t2) detail = + paras [ detail + , Box.hsep 1 Box.top [ line "while trying to match type" + , typeAsBox t1 + ] + , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type" + , typeAsBox t2 + ] + ] + renderHint (ErrorInExpression expr) detail = + paras [ detail + , Box.hsep 1 Box.top [ Box.text "in the expression" + , prettyPrintValue expr + ] + ] + renderHint (ErrorInModule mn) detail = + paras [ line $ "in module " ++ runModuleName mn + , detail + ] + renderHint (ErrorInSubsumption t1 t2) detail = + paras [ detail + , Box.hsep 1 Box.top [ line "while checking that type" + , typeAsBox t1 + ] + , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "is at least as general as type" + , typeAsBox t2 + ] + ] + renderHint (ErrorInInstance nm ts) detail = + paras [ detail + , Box.hsep 1 Box.top [ line "in type class instance" + , line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] + ] + renderHint (ErrorCheckingKind ty) detail = + paras [ detail + , Box.hsep 1 Box.top [ line "while checking the kind of" + , typeAsBox ty + ] + ] + renderHint (ErrorInferringType expr) detail = + paras [ detail + , Box.hsep 1 Box.top [ line "while inferring the type of" + , prettyPrintValue expr + ] + ] + renderHint (ErrorCheckingType expr ty) detail = + paras [ detail + , Box.hsep 1 Box.top [ line "while checking that expression" + , prettyPrintValue expr + ] + , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type" + , typeAsBox ty + ] + ] + renderHint (ErrorCheckingAccessor expr prop) detail = + paras [ detail + , Box.hsep 1 Box.top [ line "while checking type of property accessor" + , prettyPrintValue (Accessor prop expr) + ] + ] + renderHint (ErrorInApplication f t a) detail = + paras [ detail + , Box.hsep 1 Box.top [ line "while applying a function" + , prettyPrintValue f + ] + , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type" + , typeAsBox t + ] + , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument" + , prettyPrintValue a + ] + ] + renderHint (ErrorInDataConstructor nm) detail = + paras [ detail + , line $ "in data constructor " ++ runProperName nm + ] + renderHint (ErrorInTypeConstructor nm) detail = + paras [ detail + , line $ "in type constructor " ++ runProperName nm + ] + renderHint (ErrorInBindingGroup nms) detail = + paras [ detail + , line $ "in binding group " ++ intercalate ", " (map showIdent nms) + ] + renderHint ErrorInDataBindingGroup detail = + paras [ detail + , line "in data binding group" + ] + renderHint (ErrorInTypeSynonym name) detail = + paras [ detail + , line $ "in type synonym " ++ runProperName name + ] + renderHint (ErrorInValueDeclaration n) detail = + paras [ detail + , line $ "in value declaration " ++ showIdent n + ] + renderHint (ErrorInTypeDeclaration n) detail = + paras [ detail + , line $ "in type declaration for " ++ showIdent n + ] + renderHint (ErrorInForeignImport nm) detail = + paras [ detail + , line $ "in foreign import " ++ showIdent nm + ] + renderHint (PositionedError srcSpan) detail = + paras [ line $ "at " ++ displaySourceSpan srcSpan + , detail ] - renderHint (ErrorCheckingAccessor expr prop) = - paras [ lineWithLevel "checking type of property accessor" - , indent $ prettyPrintValue (Accessor prop expr) - ] - renderHint (ErrorInApplication f t a) = - paras [ lineWithLevel "applying a function" - , indent $ prettyPrintValue f - , line "of type" - , indent $ typeAsBox t - , line "to argument" - , indent $ prettyPrintValue a - ] - renderHint (ErrorInDataConstructor nm) = - lineWithLevel $ "in data constructor " ++ runProperName nm ++ ":" - renderHint (ErrorInTypeConstructor nm) = - lineWithLevel $ "in type constructor " ++ runProperName nm ++ ":" - renderHint (ErrorInBindingGroup nms) = - lineWithLevel $ "in binding group " ++ intercalate ", " (map showIdent nms) ++ ":" - renderHint ErrorInDataBindingGroup = - lineWithLevel "in data binding group:" - renderHint (ErrorInTypeSynonym name) = - lineWithLevel $ "in type synonym " ++ runProperName name ++ ":" - renderHint (ErrorInValueDeclaration n) = - lineWithLevel $ "in value declaration " ++ showIdent n ++ ":" - renderHint (ErrorInTypeDeclaration n) = - lineWithLevel $ "in type declaration for " ++ showIdent n ++ ":" - renderHint (ErrorInForeignImport nm) = - lineWithLevel $ "in foreign import " ++ showIdent nm ++ ":" - renderHint (PositionedError srcSpan) = - lineWithLevel $ "at " ++ displaySourceSpan srcSpan ++ ":" - - lineWithLevel :: String -> Box.Box - lineWithLevel text = line $ show level ++ " " ++ text levelText :: String levelText = case level of diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index d40083f6ee..e0257fcc78 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -16,6 +16,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Sugar.BindingGroups ( createBindingGroups, @@ -28,6 +29,7 @@ import Data.Graph import Data.List (nub, intersect) import Data.Maybe (isJust, mapMaybe) #if __GLASGOW_HASKELL__ < 710 +import Data.Foldable (foldMap) import Control.Applicative #endif import Control.Monad ((<=<)) @@ -54,20 +56,20 @@ createBindingGroupsModule = mapM $ \(Module ss coms name ds exps) -> Module ss c collapseBindingGroupsModule :: [Module] -> [Module] collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps -createBindingGroups :: (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration] +createBindingGroups :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration] createBindingGroups moduleName = mapM f <=< handleDecls where (f, _, _) = everywhereOnValuesTopDownM return handleExprs return - handleExprs :: (Functor m, MonadError MultipleErrors m) => Expr -> m Expr + handleExprs :: Expr -> m Expr handleExprs (Let ds val) = flip Let val <$> handleDecls ds handleExprs other = return other -- | -- Replace all sets of mutually-recursive declarations with binding groups -- - handleDecls :: (Functor m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] + handleDecls :: [Declaration] -> m [Declaration] handleDecls ds = do let values = filter isValueDecl ds dataDecls = filter isDataDecl ds @@ -158,7 +160,7 @@ getProperName _ = internalError "Expected DataDeclaration" -- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration). -- -- -toBindingGroup :: (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration +toBindingGroup :: forall m. (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration toBindingGroup _ (AcyclicSCC d) = return d toBindingGroup moduleName (CyclicSCC ds') = -- Once we have a mutually-recursive group of declarations, we need to sort @@ -178,15 +180,14 @@ toBindingGroup moduleName (CyclicSCC ds') = valueVerts :: [(Declaration, Ident, [Ident])] valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds' - toBinding :: (MonadError MultipleErrors m) => SCC Declaration -> m (Ident, NameKind, Expr) + toBinding :: SCC Declaration -> m (Ident, NameKind, Expr) toBinding (AcyclicSCC d) = return $ fromValueDecl d - toBinding (CyclicSCC ~(d:ds)) = cycleError d ds + toBinding (CyclicSCC ds) = throwError $ foldMap cycleError ds - cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a - cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds - cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n - cycleError d ds@(_:_) = rethrow (addHint (NotYetDefined (map getIdent ds))) $ cycleError d [] - cycleError _ _ = internalError "Expected ValueDeclaration" + cycleError :: Declaration -> MultipleErrors + cycleError (PositionedDeclaration p _ d) = onErrorMessages (withPosition p) $ cycleError d + cycleError (ValueDeclaration n _ _ (Right _)) = errorMessage $ CycleInDeclaration n + cycleError _ = internalError "cycleError: Expected ValueDeclaration" toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration toDataBindingGroup (AcyclicSCC d) = return d From a2dae2f77d53a5329741a1c751f33adcf6667bde Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 25 Oct 2015 16:06:00 -0700 Subject: [PATCH 0087/1580] Update MutRec.purs --- examples/failing/MutRec.purs | 1 + 1 file changed, 1 insertion(+) diff --git a/examples/failing/MutRec.purs b/examples/failing/MutRec.purs index c444cc3929..8168608381 100644 --- a/examples/failing/MutRec.purs +++ b/examples/failing/MutRec.purs @@ -1,4 +1,5 @@ -- @shouldFailWith CycleInDeclaration +-- @shouldFailWith CycleInDeclaration module MutRec where import Prelude From c84d2fda498ef749163037f07952a500fa58ea17 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 25 Oct 2015 16:22:55 -0700 Subject: [PATCH 0088/1580] Fix #1169 --- src/Language/PureScript/TypeChecker/Types.hs | 21 ++++++++++---------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 50faa623c7..bd9dec8345 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -338,18 +338,17 @@ inferBinder val (ConstructorBinder ctor binders) = do Just (_, _, ty, _) -> do (_, fn) <- instantiatePolyTypeWithUnknowns (internalError "Data constructor types cannot contain constraints") ty fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn - go binders fn' - where - go [] ty' = case (val, ty') of - (TypeConstructor _, TypeApp _ _) -> throwIncorrectArity - _ -> do - _ <- val =?= ty' - return M.empty - go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction = - M.union <$> inferBinder obj binder <*> go binders' ret - go _ _ = throwIncorrectArity - throwIncorrectArity = throwError . errorMessage $ IncorrectConstructorArity ctor + let (args, ret) = peelArgs fn' + unless (length args == length binders) . throwError . errorMessage $ IncorrectConstructorArity ctor + ret =?= val + M.unions <$> zipWithM inferBinder (reverse args) binders _ -> throwError . errorMessage $ UnknownDataConstructor ctor Nothing + where + peelArgs :: Type -> ([Type], Type) + peelArgs = go [] + where + go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret + go args ret = (args, ret) inferBinder val (ObjectBinder props) = do row <- fresh rest <- fresh From 16c3bc6f53184793c05666b590c6098214fc7f38 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 25 Oct 2015 16:48:58 -0700 Subject: [PATCH 0089/1580] Fix ExtraRecordField example --- examples/failing/ExtraRecordField.purs | 3 +-- src/Language/PureScript/Errors.hs | 14 ++++++++++---- src/Language/PureScript/TypeChecker/Types.hs | 20 ++++++++++---------- 3 files changed, 21 insertions(+), 16 deletions(-) diff --git a/examples/failing/ExtraRecordField.purs b/examples/failing/ExtraRecordField.purs index de15fee34d..aa57b05013 100644 --- a/examples/failing/ExtraRecordField.purs +++ b/examples/failing/ExtraRecordField.purs @@ -1,5 +1,4 @@ --- @shouldFailWith PropertyIsMissing --- TODO: Make this fail with a new error ExtraProperty instead. +-- @shouldFailWith AdditionalProperty module ExtraRecordField where import Prelude ((<>)) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6065740f34..5762f57eeb 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -126,7 +126,8 @@ data SimpleErrorMessage | ExpectedType Type Kind | IncorrectConstructorArity (Qualified ProperName) | ExprDoesNotHaveType Expr Type - | PropertyIsMissing String Type + | PropertyIsMissing String Expr + | AdditionalProperty String Expr | CannotApplyFunction Type Expr | TypeSynonymInstance | OrphanInstance Ident (Qualified ProperName) [Type] @@ -263,6 +264,7 @@ errorCode em = case unwrapErrorMessage em of IncorrectConstructorArity{} -> "IncorrectConstructorArity" ExprDoesNotHaveType{} -> "ExprDoesNotHaveType" PropertyIsMissing{} -> "PropertyIsMissing" + AdditionalProperty{} -> "AdditionalProperty" CannotApplyFunction{} -> "CannotApplyFunction" TypeSynonymInstance -> "TypeSynonymInstance" OrphanInstance{} -> "OrphanInstance" @@ -353,7 +355,6 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2 gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t - gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> f t gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t gSimple other = pure other @@ -617,11 +618,16 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , line "does not have type" , indent $ typeAsBox ty ] - renderSimpleErrorMessage (PropertyIsMissing prop row) = + renderSimpleErrorMessage (PropertyIsMissing prop expr) = paras [ line "Row type" - , indent $ prettyPrintRowWith '(' ')' row + , indent $ prettyPrintValue expr , line $ "lacks required label " ++ show prop ] + renderSimpleErrorMessage (AdditionalProperty prop expr) = + paras [ line "Type of expression" + , indent $ prettyPrintValue expr + , line $ "contains additional label " ++ show prop + ] renderSimpleErrorMessage (CannotApplyFunction fn arg) = paras [ line "A function of type" , indent $ typeAsBox fn diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 50faa623c7..5d2fc118ca 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -534,22 +534,22 @@ check' (IfThenElse cond th el) ty = do th' <- check th ty el' <- check el ty return $ TypedValue True (IfThenElse cond' th' el') ty -check' (ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do +check' e@(ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do ensureNoDuplicateProperties ps - ps' <- checkProperties ps row False + ps' <- checkProperties e ps row False return $ TypedValue True (ObjectLiteral ps') t check' (TypeClassDictionaryConstructorApp name ps) t = do ps' <- check' ps t return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t -check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do +check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do ensureNoDuplicateProperties ps -- We need to be careful to avoid duplicate labels here. - -- We check _obj_ agaist the type _t_ with the types in _ps_ replaced with unknowns. + -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns. let (propsToCheck, rest) = rowToList row (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck us <- zip (map fst removedProps) <$> replicateM (length ps) fresh obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest))) - ps' <- checkProperties ps row True + ps' <- checkProperties e ps row True return $ TypedValue True (ObjectUpdate obj' ps') t check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do rest <- fresh @@ -586,8 +586,8 @@ check' val ty = do -- -- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case. -- -checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)] -checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where +checkProperties :: Expr -> [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)] +checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where go [] [] REmpty = return [] go [] [] u@(TUnknown _) | lax = return [] @@ -595,8 +595,8 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where return [] go [] [] Skolem{} | lax = return [] go [] ((p, _): _) _ | lax = return [] - | otherwise = throwError . errorMessage $ PropertyIsMissing p row - go ((p,_):_) [] REmpty = throwError . errorMessage $ PropertyIsMissing p row + | otherwise = throwError . errorMessage $ PropertyIsMissing p expr + go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty p expr go ((p,v):ps') ts r = case lookup p ts of Nothing -> do @@ -609,7 +609,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where v' <- check v ty ps'' <- go ps' (delete (p, ty) ts) r return $ (p, v') : ps'' - go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType (ObjectLiteral ps) (TypeApp tyObject row) + go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyObject row) -- | -- Check the type of a function application, rethrowing errors to provide a better error message From 0b8a09f58a16f598d90bfd2d2927421abff8b825 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 25 Oct 2015 17:34:04 -0700 Subject: [PATCH 0090/1580] Fix #1315 --- examples/failing/MissingRecordField.purs | 3 +-- src/Language/PureScript/Errors.hs | 18 ++++++------------ .../PureScript/TypeChecker/Subsumption.hs | 12 ++++++++++-- src/Language/PureScript/TypeChecker/Types.hs | 4 ++-- 4 files changed, 19 insertions(+), 18 deletions(-) diff --git a/examples/failing/MissingRecordField.purs b/examples/failing/MissingRecordField.purs index eb6ebd9495..2b865e9fcc 100644 --- a/examples/failing/MissingRecordField.purs +++ b/examples/failing/MissingRecordField.purs @@ -1,5 +1,4 @@ --- @shouldFailWith TypesDoNotUnify --- TODO: Update type checker to make this fail with PropertyIsMissing instead. +-- @shouldFailWith PropertyIsMissing module MissingRecordField where import Prelude ((>)) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 5762f57eeb..1384b85083 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -126,8 +126,8 @@ data SimpleErrorMessage | ExpectedType Type Kind | IncorrectConstructorArity (Qualified ProperName) | ExprDoesNotHaveType Expr Type - | PropertyIsMissing String Expr - | AdditionalProperty String Expr + | PropertyIsMissing String + | AdditionalProperty String | CannotApplyFunction Type Expr | TypeSynonymInstance | OrphanInstance Ident (Qualified ProperName) [Type] @@ -618,16 +618,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , line "does not have type" , indent $ typeAsBox ty ] - renderSimpleErrorMessage (PropertyIsMissing prop expr) = - paras [ line "Row type" - , indent $ prettyPrintValue expr - , line $ "lacks required label " ++ show prop - ] - renderSimpleErrorMessage (AdditionalProperty prop expr) = - paras [ line "Type of expression" - , indent $ prettyPrintValue expr - , line $ "contains additional label " ++ show prop - ] + renderSimpleErrorMessage (PropertyIsMissing prop) = + line $ "Type of expression lacks required label " ++ show prop ++ "." + renderSimpleErrorMessage (AdditionalProperty prop) = + line $ "Type of expression contains additional label " ++ show prop ++ "." renderSimpleErrorMessage (CannotApplyFunction fn arg) = paras [ line "A function of type" , indent $ typeAsBox fn diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index c4f2904128..9acf9b6a0e 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -21,6 +21,7 @@ import Data.List (sortBy) import Data.Ord (comparing) import Control.Monad.Unify +import Control.Monad.Error.Class (throwError) import Language.PureScript.Crash import Language.PureScript.AST @@ -77,10 +78,17 @@ subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject | p1 == p2 = do _ <- subsumes Nothing ty1 ty2 go ts1 ts2 r1' r2' | p1 < p2 = do rest <- fresh - r2' =?= RCons p1 ty1 rest + -- What happens next is a bit of a hack. + -- TODO: in the new type checker, object properties will probably be restricted to being monotypes + -- in which case, this branch of the subsumes function should not even be necessary. + case r2' of + REmpty -> throwError . errorMessage $ AdditionalProperty p1 + _ -> r2' =?= RCons p1 ty1 rest go ts1 ((p2, ty2) : ts2) r1' rest | otherwise = do rest <- fresh - r1' =?= RCons p2 ty2 rest + case r1' of + REmpty -> throwError . errorMessage $ PropertyIsMissing p2 + _ -> r1' =?= RCons p2 ty2 rest go ((p1, ty1) : ts1) ts2 rest r2' subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1 subsumes' val ty1 ty2 = do diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 5d2fc118ca..011691ccc0 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -595,8 +595,8 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh return [] go [] [] Skolem{} | lax = return [] go [] ((p, _): _) _ | lax = return [] - | otherwise = throwError . errorMessage $ PropertyIsMissing p expr - go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty p expr + | otherwise = throwError . errorMessage $ PropertyIsMissing p + go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty p go ((p,v):ps') ts r = case lookup p ts of Nothing -> do From 2afa7b126a1892ea5e0e52e95b8885faf7f89d26 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 25 Oct 2015 17:42:26 -0700 Subject: [PATCH 0091/1580] Fix #1534 again --- src/Language/PureScript/TypeChecker/Types.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 50faa623c7..0a79c9b7bd 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -79,7 +79,7 @@ typesOf moduleName vals = do tys <- fmap tidyUp . liftUnifyWarnings replace $ do (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict - ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict + ds2 <- forM untyped $ \e -> typeForBindingGroupElement True e dict untypedDict return $ ds1 ++ ds2 forM tys $ \(ident, (val, ty)) -> do @@ -137,12 +137,12 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do else return (TypedValue False val' ty'') return (ident, (val'', ty'')) -typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type)) -typeForBindingGroupElement (ident, val) dict untypedDict = do +typeForBindingGroupElement :: Bool -> (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type)) +typeForBindingGroupElement warn (ident, val) dict untypedDict = do -- Infer the type with the new names in scope TypedValue _ val' ty <- bindNames dict $ infer val ty =?= fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict) - tell . errorMessage $ MissingTypeDeclaration ident ty + when warn . tell . errorMessage $ MissingTypeDeclaration ident ty return (ident, (TypedValue True val' ty, ty)) -- | @@ -311,7 +311,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do Just moduleName <- checkCurrentModule <$> get (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds) ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict - ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict + ds2' <- forM untyped $ \e -> typeForBindingGroupElement False e dict untypedDict let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] bindNames dict $ do makeBindingGroupVisible From 8d0963c48bb9705d2c6dfaaae83873ec334912f9 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 26 Oct 2015 08:06:51 -0700 Subject: [PATCH 0092/1580] Add failing test case for #1169 --- examples/failing/1169.purs | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 examples/failing/1169.purs diff --git a/examples/failing/1169.purs b/examples/failing/1169.purs new file mode 100644 index 0000000000..6382925f1e --- /dev/null +++ b/examples/failing/1169.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith IncorrectConstructorArity +module Test where + +data Outer a = Outer a + +data Inner a b = Inner a b + +test1 :: forall a b. Outer (Inner a b) -> Boolean +test1 (Outer (Inner _)) = true + +test2 :: forall a b. Inner a b -> Boolean +test2 (Inner _) = true From 724ac1d684c57df54a3e3825b43c46418b16ae42 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 26 Oct 2015 11:28:07 -0700 Subject: [PATCH 0093/1580] Fix #1570 --- examples/failing/1570.purs | 6 ++++++ examples/passing/1570.purs | 6 ++++++ psci/PSCi.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 2 +- src/Language/PureScript/TypeChecker/Kinds.hs | 4 ++-- src/Language/PureScript/TypeChecker/Skolems.hs | 13 +++++++++---- src/Language/PureScript/TypeChecker/Types.hs | 12 ++++++++---- 7 files changed, 33 insertions(+), 12 deletions(-) create mode 100644 examples/failing/1570.purs create mode 100644 examples/passing/1570.purs diff --git a/examples/failing/1570.purs b/examples/failing/1570.purs new file mode 100644 index 0000000000..3855838c28 --- /dev/null +++ b/examples/failing/1570.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith ExpectedType +module M where + +data F a = F a + +test = \(x :: F) -> x diff --git a/examples/passing/1570.purs b/examples/passing/1570.purs new file mode 100644 index 0000000000..258e4e5098 --- /dev/null +++ b/examples/passing/1570.purs @@ -0,0 +1,6 @@ +module Main where + +test :: forall a. a -> a +test = \(x :: a) -> x + +main = Control.Monad.Eff.Console.log "Done" diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 74ea9b5309..04402ebd4e 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -425,7 +425,7 @@ handleKindOf typ = do case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of Just (_, typ') -> do let chk = P.CheckState env' 0 0 (Just mName) - k = fst . runWriter . runExceptT $ L.runStateT (P.unCheck (P.kindOf mName typ')) chk + k = fst . runWriter . runExceptT $ L.runStateT (P.unCheck (P.kindOf typ')) chk case k of Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 37333b34f8..4c41bf396e 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -206,7 +206,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds go (d@(ExternDeclaration name ty)) = do warnAndRethrow (addHint (ErrorInForeignImport name)) $ do env <- getEnv - kind <- kindOf moduleName ty + kind <- kindOf ty guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star case M.lookup (moduleName, name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 6b024e1985..e0aa8cf078 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -76,8 +76,8 @@ instance Unifiable Check Kind where -- | -- Infer the kind of a single type -- -kindOf :: ModuleName -> Type -> Check Kind -kindOf _ ty = fst <$> kindOfWithScopedVars ty +kindOf :: Type -> Check Kind +kindOf ty = fst <$> kindOfWithScopedVars ty -- | -- Infer the kind of a single type, returning the kinds of any scoped type variables diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 46e8d4a4bc..d1ab4c5cd2 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -72,11 +72,16 @@ skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope) -- only example of scoped type variables. -- skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr -skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id go id in f +skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id onExpr onBinder in f where - go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts) - go (TypedValue check val ty) = TypedValue check val (skolemize ident sko scope ty) - go other = other + onExpr :: Expr -> Expr + onExpr (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts) + onExpr (TypedValue check val ty) = TypedValue check val (skolemize ident sko scope ty) + onExpr other = other + + onBinder :: Binder -> Binder + onBinder (TypedBinder ty b) = TypedBinder (skolemize ident sko scope ty) b + onBinder other = other -- | -- Ensure skolem variables do not escape their scope diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 43ad5965a7..92255b2f23 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -373,11 +373,15 @@ inferBinder val (NamedBinder name binder) = do return $ M.insert name val m inferBinder val (PositionedBinder pos _ binder) = warnAndRethrowWithPosition pos $ inferBinder val binder --- TODO: When adding support for polymorphic types, check subsumption here --- and change the definition of `binderRequiresMonotype` +-- TODO: When adding support for polymorphic types, check subsumption here, +-- change the definition of `binderRequiresMonotype`, +-- and use `kindOfWithScopedVars`. inferBinder val (TypedBinder ty binder) = do - ty' <- replaceAllTypeSynonyms ty - val =?= ty' >> inferBinder val binder + ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty + kind <- liftCheck $ kindOf ty1 + checkTypeKind ty1 kind + val =?= ty1 + inferBinder val binder -- | Returns true if a binder requires its argument type to be a monotype. -- | If this is the case, we need to instantiate any polymorphic types before checking binders. From b3bb653dc63e10e960417451d9d8d80f6891e6a2 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 26 Oct 2015 12:57:37 -0700 Subject: [PATCH 0094/1580] Fix #1297, reduce memory usage from WriterT --- psc/Main.hs | 9 ++-- psci/PSCi.hs | 2 +- purescript.cabal | 1 + src/Control/Monad/Logger.hs | 75 +++++++++++++++++++++++++++++++++ src/Language/PureScript/Make.hs | 11 ++--- 5 files changed, 87 insertions(+), 11 deletions(-) create mode 100644 src/Control/Monad/Logger.hs diff --git a/psc/Main.hs b/psc/Main.hs index d89be911c5..1914cf5935 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -71,15 +71,14 @@ compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = d hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings) let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix - e <- runMake opts $ P.make makeActions (map snd ms) + (e, warnings') <- runMake opts $ P.make makeActions (map snd ms) + when (P.nonEmpty warnings') $ + hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings') case e of Left errs -> do hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs) exitFailure - Right (_, warnings') -> do - when (P.nonEmpty warnings') $ - hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings') - exitSuccess + Right _ -> exitSuccess warnFileTypeNotFound :: String -> IO () warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 74ea9b5309..fcad07e818 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -254,7 +254,7 @@ modulesDir = ".psci_modules" ++ pathSeparator : "node_modules" -- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the -- options and ignores the warning messages. runMake :: P.Make a -> IO (Either P.MultipleErrors a) -runMake mk = fmap (fmap fst) $ P.runMake P.defaultOptions mk +runMake mk = fmap fst $ P.runMake P.defaultOptions mk makeIO :: (IOError -> P.ErrorMessage) -> IO a -> P.Make a makeIO f io = do diff --git a/purescript.cabal b/purescript.cabal index ced8493aab..d86ac3a3d1 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -170,6 +170,7 @@ library Language.PureScript.Publish.ErrorsWarnings Language.PureScript.Publish.BoxesHelpers + Control.Monad.Logger Control.Monad.Unify Control.Monad.Supply Control.Monad.Supply.Class diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs new file mode 100644 index 0000000000..fdf056303c --- /dev/null +++ b/src/Control/Monad/Logger.hs @@ -0,0 +1,75 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.Logger +-- Author : Phil Freeman +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | A replacement for WriterT IO which uses mutable references. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Control.Monad.Logger where + +import Data.IORef + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif +import Control.Monad (ap) +import Control.Monad.IO.Class +import Control.Monad.Writer.Class +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Trans.Control (MonadBaseControl(..)) + +-- | A replacement for WriterT IO which uses mutable references. +data Logger w a = Logger { runLogger :: IORef w -> IO a } + +-- | Run a Logger computation, starting with an empty log. +runLogger' :: (Monoid w) => Logger w a -> IO (a, w) +runLogger' l = do + r <- newIORef mempty + a <- runLogger l r + w <- readIORef r + return (a, w) + +instance Functor (Logger w) where + fmap f (Logger l) = Logger $ \r -> fmap f (l r) + +instance (Monoid w) => Applicative (Logger w) where + pure = Logger . const . pure + (<*>) = ap + +instance (Monoid w) => Monad (Logger w) where + return = pure + Logger l >>= f = Logger $ \r -> l r >>= \a -> runLogger (f a) r + +instance (Monoid w) => MonadIO (Logger w) where + liftIO = Logger . const + +instance (Monoid w) => MonadWriter w (Logger w) where + tell w = Logger $ \r -> modifyIORef' r (mappend w) + listen l = Logger $ \r -> do + (a, w) <- liftIO (runLogger' l) + modifyIORef' r (mappend w) + return (a, w) + pass l = Logger $ \r -> do + ((a, f), w) <- liftIO (runLogger' l) + modifyIORef' r (mappend (f w)) + return a + +instance (Monoid w) => MonadBase IO (Logger w) where + liftBase = liftIO + +instance (Monoid w) => MonadBaseControl IO (Logger w) where + type StM (Logger w) a = a + liftBaseWith f = Logger $ \r -> liftBaseWith $ \q -> f (q . flip runLogger r) + restoreM = return diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 8c41b79bec..261612567a 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -43,9 +43,10 @@ import Control.Applicative #endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Trans.Except import Control.Monad.Reader -import Control.Monad.Writer.Strict +import Control.Monad.Logger import Control.Monad.Supply import Control.Monad.Base (MonadBase(..)) import Control.Monad.Trans.Control (MonadBaseControl(..)) @@ -284,22 +285,22 @@ importPrim = addDefaultImport (ModuleName [ProperName C.prim]) -- | -- A monad for running make actions -- -newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a } +newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options) instance MonadBase IO Make where liftBase = liftIO instance MonadBaseControl IO Make where - type StM Make a = Either MultipleErrors (a, MultipleErrors) + type StM Make a = Either MultipleErrors a liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake) restoreM = Make . restoreM -- | -- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings. -- -runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors)) -runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake +runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors) +runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a makeIO f io = do From b6fe164d84c395423c1fb4c5c88be33887767a79 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 26 Oct 2015 12:59:56 -0700 Subject: [PATCH 0095/1580] Fix tests --- tests/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/Main.hs b/tests/Main.hs index c6173b8b2b..eca712953d 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -104,7 +104,7 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do type TestM = WriterT [(FilePath, String)] IO runTest :: P.Make a -> IO (Either P.MultipleErrors a) -runTest = fmap (fmap fst) . P.runMake P.defaultOptions +runTest = fmap fst . P.runMake P.defaultOptions compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment) compile inputFiles foreigns = runTest $ do From bd2e5839ee15c028402122fce7e890757d30f689 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 26 Oct 2015 13:51:17 -0700 Subject: [PATCH 0096/1580] Fix build for GHC < 7.10 --- src/Control/Monad/Logger.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs index fdf056303c..acb4da0291 100644 --- a/src/Control/Monad/Logger.hs +++ b/src/Control/Monad/Logger.hs @@ -22,6 +22,7 @@ module Control.Monad.Logger where import Data.IORef #if __GLASGOW_HASKELL__ < 710 +import Data.Monoid import Control.Applicative #endif import Control.Monad (ap) From 6a378be5ac331db09ccc72e88228e4e55eb369c0 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 26 Oct 2015 14:13:03 -0700 Subject: [PATCH 0097/1580] Fix double-warning issue --- src/Control/Monad/Logger.hs | 8 +++----- src/Language/PureScript/Make.hs | 3 +-- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs index acb4da0291..4d8ab2f2bc 100644 --- a/src/Control/Monad/Logger.hs +++ b/src/Control/Monad/Logger.hs @@ -57,15 +57,13 @@ instance (Monoid w) => MonadIO (Logger w) where liftIO = Logger . const instance (Monoid w) => MonadWriter w (Logger w) where - tell w = Logger $ \r -> modifyIORef' r (mappend w) + tell w = Logger $ \r -> atomicModifyIORef' r $ \w' -> (mappend w' w, ()) listen l = Logger $ \r -> do (a, w) <- liftIO (runLogger' l) - modifyIORef' r (mappend w) - return (a, w) + atomicModifyIORef' r $ \w' -> (mappend w' w, (a, w)) pass l = Logger $ \r -> do ((a, f), w) <- liftIO (runLogger' l) - modifyIORef' r (mappend (f w)) - return a + atomicModifyIORef' r $ \w' -> (mappend w' (f w), a) instance (Monoid w) => MonadBase IO (Logger w) where liftBase = liftIO diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 261612567a..06a114c4b2 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -178,8 +178,7 @@ make MakeActions{..} ms = do unless (null errors) $ throwError (mconcat errors) -- Bundle up all the externs and return them as an Environment - (warnings, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd) - tell (mconcat warnings) + (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd) return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs where From cfcf62ee1b8fc860e63204f48aac800c2c8b6d6f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 26 Oct 2015 14:50:28 -0700 Subject: [PATCH 0098/1580] -> 0.7.5.1 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index d86ac3a3d1..689bda1223 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.7.5 +version: 0.7.5.1 cabal-version: >=1.8 build-type: Simple license: MIT From 9d8bae194be87a2a59be6751b32abd72ce96aa3c Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 27 Oct 2015 11:57:41 -0700 Subject: [PATCH 0099/1580] Fix build for < GHC 7.10 --- src/Language/PureScript/Make.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 06a114c4b2..7682066edc 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -59,6 +59,7 @@ import Data.Time.Clock import Data.String (fromString) import Data.Foldable (for_) #if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (mempty, mconcat) import Data.Traversable (traverse) #endif import Data.Traversable (for) From a70e397e829a6764f418531674f96302879e5a7e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 27 Oct 2015 12:02:56 -0700 Subject: [PATCH 0100/1580] -> 0.7.5.2 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 689bda1223..51cf166b0d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.7.5.1 +version: 0.7.5.2 cabal-version: >=1.8 build-type: Simple license: MIT From e350fea840c4ceb9acbeb09279bcacfecb2628ff Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 28 Oct 2015 16:49:16 -0700 Subject: [PATCH 0101/1580] Fix #1072 --- examples/failing/EmptyClass.purs | 7 +++++++ examples/passing/NakedConstraint.purs | 2 +- src/Language/PureScript/Parser/Declarations.hs | 2 +- 3 files changed, 9 insertions(+), 2 deletions(-) create mode 100644 examples/failing/EmptyClass.purs diff --git a/examples/failing/EmptyClass.purs b/examples/failing/EmptyClass.purs new file mode 100644 index 0000000000..fde8f7ef76 --- /dev/null +++ b/examples/failing/EmptyClass.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +class Foo x where + +bar :: String +bar = "hello" diff --git a/examples/passing/NakedConstraint.purs b/examples/passing/NakedConstraint.purs index d7b58c9f59..1fe4e9d874 100644 --- a/examples/passing/NakedConstraint.purs +++ b/examples/passing/NakedConstraint.purs @@ -2,7 +2,7 @@ module Main where import Control.Monad.Eff.Console -class Partial where +class Partial data List a = Nil | Cons a (List a) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index a9347d152f..4a0ef87a59 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -201,7 +201,7 @@ parseTypeClassDeclaration = do idents <- P.many (indented *> kindedIdent) members <- P.option [] . P.try $ do indented *> reserved "where" - mark (P.many (same *> positioned parseTypeDeclaration)) + indented *> mark (P.many (same *> positioned parseTypeDeclaration)) return $ TypeClassDeclaration className idents implies members parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) From c059120dc70df48213a3d722a7c6050a34f6094d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 28 Oct 2015 17:25:46 -0700 Subject: [PATCH 0102/1580] Fix #1577, fix #1130 --- src/Language/PureScript/Errors.hs | 13 +++++++++---- src/Language/PureScript/TypeChecker/Types.hs | 2 +- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 34311e9f3a..a5618f9fbe 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -156,6 +156,7 @@ data ErrorMessageHint | ErrorCheckingAccessor Expr String | ErrorCheckingType Expr Type | ErrorCheckingKind Type + | ErrorCheckingGuard | ErrorInferringType Expr | ErrorInApplication Expr Type Expr | ErrorInDataConstructor ProperName @@ -530,15 +531,15 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , indent $ prettyPrintValue expr ]) binding renderSimpleErrorMessage (TypesDoNotUnify t1 t2) - = paras [ line "Could not match expected type" + = paras [ line "Could not match type" , indent $ typeAsBox t1 - , line "with actual type" + , line "with type" , indent $ typeAsBox t2 ] renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = - paras [ line "Could not match expected kind" + paras [ line "Could not match kind" , indent $ line $ prettyPrintKind k1 - , line "with actual kind" + , line "with kind" , indent $ line $ prettyPrintKind k2 ] renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) = @@ -730,6 +731,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , typeAsBox ty ] ] + renderHint ErrorCheckingGuard detail = + paras [ detail + , line "while checking the type of a guard clause" + ] renderHint (ErrorInferringType expr) detail = paras [ detail , Box.hsep 1 Box.top [ line "while inferring the type of" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 92255b2f23..fc8b61694a 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -418,7 +418,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do case result of Left gs -> do gs' <- forM gs $ \(grd, val) -> do - grd' <- check grd tyBoolean + grd' <- rethrow (addHint ErrorCheckingGuard) $ check grd tyBoolean val' <- TypedValue True <$> check val ret <*> pure ret return (grd', val') return $ Left gs' From 2704b3816bd919146e2f3b6bce594f22364bd18e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 28 Oct 2015 17:33:24 -0700 Subject: [PATCH 0103/1580] All you need is nub. Fix #1582 --- src/Language/PureScript/Linter/Exhaustive.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index d0184bcfeb..4adc578eff 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -246,7 +246,7 @@ checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([init step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]])) step (uncovered, (nec, redundant)) ca = let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered) - (missed', approx) = splitAt 10000 (concat missed) + (missed', approx) = splitAt 10000 (nub (concat missed)) cond = liftA2 (&&) (or <$> sequenceA pr) nec in (missed', ( if null approx then cond From 81f6d69222d09bb6665d2999eb9fef80d34d34d4 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 28 Oct 2015 18:03:56 -0700 Subject: [PATCH 0104/1580] Fix #1465 --- src/Language/PureScript/TypeChecker/Monad.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 33a791e906..7757c3d1ba 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -24,6 +24,7 @@ module Language.PureScript.TypeChecker.Monad where import Data.Maybe +import Data.Foldable (for_) import qualified Data.Map as M #if __GLASGOW_HASKELL__ < 710 @@ -67,8 +68,13 @@ bindTypes newNames action = do -- | -- Temporarily bind a collection of names to types -- -withScopedTypeVars :: (Functor m, MonadState CheckState m) => ModuleName -> [(String, Kind)] -> m a -> m a -withScopedTypeVars mn ks = bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) +withScopedTypeVars :: (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName -> [(String, Kind)] -> m a -> m a +withScopedTypeVars mn ks ma = do + orig <- get + for_ ks $ \(name, _) -> + when (Qualified (Just mn) (ProperName name) `M.member` types (checkEnv orig)) $ + tell . errorMessage $ ShadowedTypeVar name + bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma -- | -- Temporarily make a collection of type class dictionaries available From cb9ac8654de44e4b643ca8ca82ef62a560f70952 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 28 Oct 2015 20:18:06 -0700 Subject: [PATCH 0105/1580] Pre-AMP fix --- src/Language/PureScript/TypeChecker/Monad.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 7757c3d1ba..182526fd7e 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -68,7 +68,7 @@ bindTypes newNames action = do -- | -- Temporarily bind a collection of names to types -- -withScopedTypeVars :: (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName -> [(String, Kind)] -> m a -> m a +withScopedTypeVars :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName -> [(String, Kind)] -> m a -> m a withScopedTypeVars mn ks ma = do orig <- get for_ ks $ \(name, _) -> From 232bb8183c04efa41a5b9d538650a5de4627f849 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 28 Oct 2015 21:15:05 -0700 Subject: [PATCH 0106/1580] Fix #1578 --- src/Language/PureScript/Sugar/Names.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index a885348b76..90bebb7a30 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -26,7 +26,7 @@ import Control.Applicative (Applicative(..), (<$>), (<*>)) #endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer (MonadWriter(..)) +import Control.Monad.Writer (MonadWriter(..), censor) import qualified Data.Map as M @@ -47,10 +47,13 @@ import Language.PureScript.Sugar.Names.Exports -- desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] desugarImports externs modules = do - env <- foldM externsEnv primEnv externs + env <- silence $ foldM externsEnv primEnv externs env' <- foldM updateEnv env modules mapM (renameInModule' env') modules where + silence :: m a -> m a + silence = censor (const mempty) + -- | Create an environment from a collection of externs files externsEnv :: Env -> ExternsFile -> m Env externsEnv env ExternsFile{..} = do From 893379f7aa11b0d35f1279f12524b94daea00b7c Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 28 Oct 2015 21:33:04 -0700 Subject: [PATCH 0107/1580] Fix < 7.10 --- src/Language/PureScript/Sugar/Names.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 90bebb7a30..810acefc53 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -22,6 +22,7 @@ import Data.List (find, nub) import Data.Maybe (fromMaybe, mapMaybe) #if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (mempty) import Control.Applicative (Applicative(..), (<$>), (<*>)) #endif import Control.Monad From 62192bd6b5ecd2d7dd12512fbd0a2f6fbca0be68 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 29 Oct 2015 09:46:02 -0700 Subject: [PATCH 0108/1580] -> 0.7.5.3 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 51cf166b0d..e2e84325fb 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.7.5.2 +version: 0.7.5.3 cabal-version: >=1.8 build-type: Simple license: MIT From da5983f489d8ed52bb3e0e4fc25bb3f34f38315f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 30 Oct 2015 12:58:34 -0700 Subject: [PATCH 0109/1580] Parse modules in parallel --- LICENSE | 914 +++++++++--------- purescript.cabal | 3 +- .../PureScript/Parser/Declarations.hs | 20 +- 3 files changed, 492 insertions(+), 445 deletions(-) diff --git a/LICENSE b/LICENSE index 6f84bf88b2..4aed8f101f 100644 --- a/LICENSE +++ b/LICENSE @@ -51,6 +51,7 @@ PureScript uses the following Haskell library packages. Their license files foll mtl nats optparse-applicative + parallel parsec pattern-arrows pretty @@ -111,22 +112,22 @@ HUnit LICENSE file: HUnit is Copyright (c) Dean Herington, 2002, all rights reserved, and is distributed as free software under the following license. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions, and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions, and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - The names of the copyright holders may not be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -142,24 +143,24 @@ HUnit LICENSE file: aeson LICENSE file: Copyright (c) 2011, MailRank, Inc. - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE @@ -175,7 +176,7 @@ aeson LICENSE file: aeson-better-errors LICENSE file: Copyright (c) 2015 Harry Garrood - + Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including @@ -183,10 +184,10 @@ aeson-better-errors LICENSE file: distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. @@ -199,10 +200,10 @@ ansi-terminal LICENSE file: Copyright (c) 2008, Maximilian Bolingbroke All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of @@ -210,7 +211,7 @@ ansi-terminal LICENSE file: provided with the distribution. * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR @@ -223,19 +224,19 @@ ansi-terminal LICENSE file: ansi-wl-pprint LICENSE file: Copyright 2008, Daan Leijen and Max Bolingbroke. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + This software is provided by the copyright holders "as is" and any express or implied warranties, including, but not limited to, the implied warranties of merchantability and fitness for a particular @@ -251,43 +252,43 @@ ansi-wl-pprint LICENSE file: array LICENSE file: This library (libraries/base) is derived from code from several - sources: - + sources: + * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), - + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones and freely redistributable (but see the full license for restrictions). - + * Code from the Haskell Foreign Function Interface specification, which is (c) Manuel M. T. Chakravarty and freely redistributable (but see the full license for restrictions). - + The full text of these licenses is reproduced below. All of the licenses are BSD-style or compatible. - + ----------------------------------------------------------------------------- - + The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -300,14 +301,14 @@ array LICENSE file: LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + ----------------------------------------------------------------------------- - + Code derived from the document "Report on the Programming Language Haskell 98", is distributed under the following license: - + Copyright (c) 2002 Simon Peyton Jones - + The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, @@ -315,15 +316,15 @@ array LICENSE file: copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Language. - + ----------------------------------------------------------------------------- - + Code derived from the document "The Haskell 98 Foreign Function Interface, An Addendum to the Haskell 98 Report" is distributed under the following license: - + Copyright (c) 2002 Manuel M. T. Chakravarty - + The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, @@ -331,30 +332,30 @@ array LICENSE file: copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Foreign Function Interface. - + ----------------------------------------------------------------------------- attoparsec LICENSE file: Copyright (c) Lennart Kolmodin - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE @@ -370,43 +371,43 @@ attoparsec LICENSE file: base LICENSE file: This library (libraries/base) is derived from code from several - sources: - + sources: + * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), - + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones and freely redistributable (but see the full license for restrictions). - + * Code from the Haskell Foreign Function Interface specification, which is (c) Manuel M. T. Chakravarty and freely redistributable (but see the full license for restrictions). - + The full text of these licenses is reproduced below. All of the licenses are BSD-style or compatible. - + ----------------------------------------------------------------------------- - + The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -419,14 +420,14 @@ base LICENSE file: LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + ----------------------------------------------------------------------------- - + Code derived from the document "Report on the Programming Language Haskell 98", is distributed under the following license: - + Copyright (c) 2002 Simon Peyton Jones - + The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, @@ -434,15 +435,15 @@ base LICENSE file: copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Language. - + ----------------------------------------------------------------------------- - + Code derived from the document "The Haskell 98 Foreign Function Interface, An Addendum to the Haskell 98 Report" is distributed under the following license: - + Copyright (c) 2002 Manuel M. T. Chakravarty - + The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, @@ -450,30 +451,30 @@ base LICENSE file: copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Foreign Function Interface. - + ----------------------------------------------------------------------------- binary LICENSE file: Copyright (c) Lennart Kolmodin - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE @@ -489,24 +490,24 @@ binary LICENSE file: blaze-builder LICENSE file: Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 2011 - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + * Neither the name of Jasper Van der Jeugt nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR @@ -522,7 +523,7 @@ blaze-builder LICENSE file: bower-json LICENSE file: Copyright (c) 2015 Harry Garrood - + Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including @@ -530,10 +531,10 @@ bower-json LICENSE file: distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. @@ -545,7 +546,7 @@ bower-json LICENSE file: boxes LICENSE file: Copyright (c) Brent Yorgey 2008 - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: @@ -557,9 +558,9 @@ boxes LICENSE file: 3. Neither the name of the author nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + All other rights are reserved. - + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE @@ -578,9 +579,9 @@ bytestring LICENSE file: (c) Duncan Coutts 2006-2015 (c) David Roundy 2003-2005 (c) Simon Meier 2010-2011 - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: @@ -592,7 +593,7 @@ bytestring LICENSE file: 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE @@ -608,24 +609,24 @@ bytestring LICENSE file: containers LICENSE file: The Glasgow Haskell Compiler License - + Copyright 2004, The University Court of the University of Glasgow. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -644,28 +645,28 @@ deepseq LICENSE file: This library (deepseq) is derived from code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below). - + ----------------------------------------------------------------------------- - + The Glasgow Haskell Compiler License - - Copyright 2001-2009, The University Court of the University of Glasgow. + + Copyright 2001-2009, The University Court of the University of Glasgow. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -678,45 +679,45 @@ deepseq LICENSE file: LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + ----------------------------------------------------------------------------- directory LICENSE file: This library (libraries/base) is derived from code from two - sources: - + sources: + * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), - + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones and freely redistributable (but see the full license for restrictions). - + The full text of these licenses is reproduced below. Both of the licenses are BSD-style or compatible. - + ----------------------------------------------------------------------------- - + The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -729,14 +730,14 @@ directory LICENSE file: LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + ----------------------------------------------------------------------------- - + Code derived from the document "Report on the Programming Language Haskell 98", is distributed under the following license: - + Copyright (c) 2002 Simon Peyton Jones - + The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, @@ -744,31 +745,31 @@ directory LICENSE file: copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Language. - + ----------------------------------------------------------------------------- dlist LICENSE file: Copyright (c) 2006-2009 Don Stewart, 2013-2014 Sean Leather - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + * Neither the name of Don Stewart nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR @@ -785,23 +786,23 @@ filepath LICENSE file: Copyright Neil Mitchell 2005-2015. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + * Neither the name of Neil Mitchell nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR @@ -817,39 +818,39 @@ filepath LICENSE file: ghc-prim LICENSE file: This library (libraries/ghc-prim) is derived from code from several - sources: - + sources: + * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), - + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones and freely redistributable (but see the full license for restrictions). - + The full text of these licenses is reproduced below. All of the licenses are BSD-style or compatible. - + ----------------------------------------------------------------------------- - + The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -862,14 +863,14 @@ ghc-prim LICENSE file: LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + ----------------------------------------------------------------------------- - + Code derived from the document "Report on the Programming Language Haskell 98", is distributed under the following license: - + Copyright (c) 2002 Simon Peyton Jones - + The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, @@ -877,29 +878,29 @@ ghc-prim LICENSE file: copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Language. - + hashable LICENSE file: Copyright Milan Straka 2010 - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + * Neither the name of Milan Straka nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR @@ -916,17 +917,17 @@ haskeline LICENSE file: Copyright 2007-2009, Judah Jacobson. All Rights Reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistribution of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistribution in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE @@ -941,24 +942,24 @@ haskeline LICENSE file: integer-gmp LICENSE file: Copyright (c) 2014, Herbert Valerio Riedel - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + * Neither the name of Herbert Valerio Riedel nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR @@ -974,24 +975,24 @@ integer-gmp LICENSE file: language-javascript LICENSE file: Copyright (c)2010, Alan Zimmerman - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + * Neither the name of Alan Zimmerman nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR @@ -1008,22 +1009,22 @@ lifted-base LICENSE file: Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + • Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + • Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + • Neither the name of the author nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR @@ -1040,22 +1041,22 @@ monad-control LICENSE file: Copyright © 2010, Bas van Dijk, Anders Kaseorg All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + • Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + • Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + • Neither the name of the author nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR @@ -1071,24 +1072,24 @@ monad-control LICENSE file: mtl LICENSE file: The Glasgow Haskell Compiler License - + Copyright 2004, The University Court of the University of Glasgow. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1105,24 +1106,24 @@ mtl LICENSE file: nats LICENSE file: Copyright 2011-2014 Edward Kmett - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE @@ -1138,24 +1139,24 @@ nats LICENSE file: optparse-applicative LICENSE file: Copyright (c) 2012, Paolo Capriotti - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + * Neither the name of Paolo Capriotti nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR @@ -1168,19 +1169,61 @@ optparse-applicative LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +parallel LICENSE file: + + This library (libraries/parallel) is derived from code from + the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below). + + ----------------------------------------------------------------------------- + + The Glasgow Haskell Compiler License + + Copyright 2004, The University Court of the University of Glasgow. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. + + ----------------------------------------------------------------------------- + parsec LICENSE file: Copyright 1999-2000, Daan Leijen; 2007, Paolo Martini. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + This software is provided by the copyright holders "as is" and any express or implied warranties, including, but not limited to, the implied warranties of merchantability and fitness for a particular purpose are disclaimed. In no @@ -1195,19 +1238,19 @@ parsec LICENSE file: pattern-arrows LICENSE file: The MIT License (MIT) - + Copyright (c) 2013 Phil Freeman - + Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR @@ -1220,28 +1263,28 @@ pretty LICENSE file: This library (libraries/pretty) is derived from code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below). - + ----------------------------------------------------------------------------- - + The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1254,28 +1297,28 @@ pretty LICENSE file: LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + ----------------------------------------------------------------------------- primitive LICENSE file: Copyright (c) 2008-2009, Roman Leshchinskiy All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1288,44 +1331,44 @@ primitive LICENSE file: LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + process LICENSE file: This library (libraries/process) is derived from code from two - sources: - + sources: + * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), - + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones and freely redistributable (but see the full license for restrictions). - + The full text of these licenses is reproduced below. Both of the licenses are BSD-style or compatible. - + ----------------------------------------------------------------------------- - + The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1338,14 +1381,14 @@ process LICENSE file: LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + ----------------------------------------------------------------------------- - + Code derived from the document "Report on the Programming Language Haskell 98", is distributed under the following license: - + Copyright (c) 2002 Simon Peyton Jones - + The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, @@ -1353,7 +1396,7 @@ process LICENSE file: copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Language. - + ----------------------------------------------------------------------------- rts LICENSE file: @@ -1364,23 +1407,23 @@ safe LICENSE file: Copyright Neil Mitchell 2007-2015. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + * Neither the name of Neil Mitchell nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR @@ -1396,24 +1439,24 @@ safe LICENSE file: scientific LICENSE file: Copyright (c) 2013, Bas van Dijk - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + * Neither the name of Bas van Dijk nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR @@ -1429,20 +1472,20 @@ scientific LICENSE file: semigroups LICENSE file: Copyright 2011-2015 Edward Kmett - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE @@ -1458,9 +1501,9 @@ semigroups LICENSE file: split LICENSE file: Copyright (c) 2008 Brent Yorgey, Louis Wasserman - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: @@ -1472,7 +1515,7 @@ split LICENSE file: 3. Neither the name of the author nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE @@ -1488,24 +1531,24 @@ split LICENSE file: stm LICENSE file: The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1521,112 +1564,112 @@ stm LICENSE file: syb LICENSE file: - This library (libraries/syb) is derived from code from several - sources: - - * Code from the GHC project which is largely (c) The University of - Glasgow, and distributable under a BSD-style license (see below), - - * Code from the Haskell 98 Report which is (c) Simon Peyton Jones - and freely redistributable (but see the full license for - restrictions). - - * Code from the Haskell Foreign Function Interface specification, - which is (c) Manuel M. T. Chakravarty and freely redistributable - (but see the full license for restrictions). - - The full text of these licenses is reproduced below. All of the - licenses are BSD-style or compatible. - - ----------------------------------------------------------------------------- - - The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - - Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - - - Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - - - Neither name of the University nor the names of its contributors may be - used to endorse or promote products derived from this software without - specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF - GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - DAMAGE. - - ----------------------------------------------------------------------------- - - Code derived from the document "Report on the Programming Language - Haskell 98", is distributed under the following license: - - Copyright (c) 2002 Simon Peyton Jones - - The authors intend this Report to belong to the entire Haskell - community, and so we grant permission to copy and distribute it for - any purpose, provided that it is reproduced in its entirety, - including this Notice. Modified versions of this Report may also be - copied and distributed for any purpose, provided that the modified - version is clearly presented as such, and that it does not claim to - be a definition of the Haskell 98 Language. - - ----------------------------------------------------------------------------- - - Code derived from the document "The Haskell 98 Foreign Function - Interface, An Addendum to the Haskell 98 Report" is distributed under - the following license: - - Copyright (c) 2002 Manuel M. T. Chakravarty - - The authors intend this Report to belong to the entire Haskell - community, and so we grant permission to copy and distribute it for - any purpose, provided that it is reproduced in its entirety, - including this Notice. Modified versions of this Report may also be - copied and distributed for any purpose, provided that the modified - version is clearly presented as such, and that it does not claim to - be a definition of the Haskell 98 Foreign Function Interface. - - ----------------------------------------------------------------------------- + This library (libraries/syb) is derived from code from several + sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + + * Code from the Haskell Foreign Function Interface specification, + which is (c) Manuel M. T. Chakravarty and freely redistributable + (but see the full license for restrictions). + + The full text of these licenses is reproduced below. All of the + licenses are BSD-style or compatible. + + ----------------------------------------------------------------------------- + + The Glasgow Haskell Compiler License + + Copyright 2004, The University Court of the University of Glasgow. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. + + ----------------------------------------------------------------------------- + + Code derived from the document "Report on the Programming Language + Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + + ----------------------------------------------------------------------------- + + Code derived from the document "The Haskell 98 Foreign Function + Interface, An Addendum to the Haskell 98 Report" is distributed under + the following license: + + Copyright (c) 2002 Manuel M. T. Chakravarty + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Foreign Function Interface. + + ----------------------------------------------------------------------------- template-haskell LICENSE file: - + The Glasgow Haskell Compiler License - + Copyright 2002-2007, The University Court of the University of Glasgow. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1639,23 +1682,23 @@ template-haskell LICENSE file: LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + terminfo LICENSE file: Copyright 2007, Judah Jacobson. All Rights Reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistribution of source code must retain the above copyright notice, this list of conditions and the following disclamer. - + - Redistribution in binary form must reproduce the above copyright notice, this list of conditions and the following disclamer in the documentation and/or other materials provided with the distribution. - + THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE @@ -1671,19 +1714,19 @@ text LICENSE file: Copyright (c) 2008-2009, Tom Harper All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR @@ -1700,36 +1743,36 @@ time LICENSE file: TimeLib is Copyright (c) Ashley Yakeley, 2004-2014. All rights reserved. Certain sections are Copyright 2004, The University Court of the University of Glasgow. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Neither name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. transformers LICENSE file: The Glasgow Haskell Compiler License - + Copyright 2004, The University Court of the University of Glasgow. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1747,19 +1790,19 @@ transformers-base LICENSE file: Copyright (c) 2011, Mikhail Vorozhtsov, Bas van Dijk All rights reserved. - - Redistribution and use in source and binary forms, with or without + + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - - - Redistributions of source code must retain the above copyright notice, + + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - - Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the + - Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - - Neither the names of the copyright owners nor the names of the - contributors may be used to endorse or promote products derived + - Neither the names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR @@ -1771,29 +1814,29 @@ transformers-base LICENSE file: THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + transformers-compat LICENSE file: Copyright 2012 Edward Kmett - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE @@ -1809,24 +1852,24 @@ transformers-compat LICENSE file: unix LICENSE file: The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1843,24 +1886,24 @@ unix LICENSE file: unordered-containers LICENSE file: Copyright (c) 2010, Johan Tibell - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + * Neither the name of Johan Tibell nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR @@ -1904,21 +1947,21 @@ vector LICENSE file: Copyright (c) 2008-2012, Roman Leshchinskiy All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1931,29 +1974,29 @@ vector LICENSE file: LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - + void LICENSE file: Copyright 2015 Edward Kmett - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE @@ -1965,4 +2008,3 @@ void LICENSE file: STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - diff --git a/purescript.cabal b/purescript.cabal index e2e84325fb..653a0c58f6 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -68,7 +68,8 @@ library Glob >= 0.7 && < 0.8, process >= 1.2.0 && < 1.4, safe >= 0.3.9 && < 0.4, - semigroups >= 0.16.2 && < 0.18 + semigroups >= 0.16.2 && < 0.18, + parallel >= 3.2 && < 3.3 exposed-modules: Language.PureScript Language.PureScript.AST diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 4a0ef87a59..682821d9bd 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -37,6 +37,7 @@ import Data.Maybe (fromMaybe) import Control.Applicative import Control.Arrow ((+++)) import Control.Monad.Error.Class (MonadError(..)) +import Control.Parallel.Strategies (withStrategy, parList, rseq) import Language.PureScript.AST import Language.PureScript.Comments @@ -274,23 +275,26 @@ parseModule = do let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end) return $ Module ss comments name decls exports --- | --- Parse a collection of modules --- +-- | Parse a collection of modules in parallel parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m, Functor m) => (k -> FilePath) -> [(k, String)] -> m [(k, Module)] parseModulesFromFiles toFilePath input = do - modules <- parU input $ \(k, content) -> do + modules <- flip parU id $ map wrapError $ inParallel $ flip map input $ \(k, content) -> do let filename = toFilePath k - ts <- wrapError $ lex filename content - ms <- wrapError $ runTokenParser filename parseModules ts + ts <- lex filename content + ms <- runTokenParser filename parseModules ts return (k, ms) return $ collect modules where - wrapError :: Either P.ParseError a -> m a - wrapError = either (throwError . MultipleErrors . pure . toPositionedError) return collect :: [(k, [v])] -> [(k, v)] collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ] + wrapError :: Either P.ParseError a -> m a + wrapError = either (throwError . MultipleErrors . pure . toPositionedError) return + -- It is enough to force each parse result to WHNF, since success or failure can't be + -- determined until the end of the file, so this effectively distributes parsing of each file + -- to a different spark. + inParallel :: [Either P.ParseError (k, [Module])] -> [Either P.ParseError (k, [Module])] + inParallel = withStrategy (parList rseq) toPositionedError :: P.ParseError -> ErrorMessage toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr) From 47c0ffb2d481592085aa9bfdff3d67d1a3ad8046 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Wed, 14 Oct 2015 22:57:05 +0100 Subject: [PATCH 0110/1580] Give warnings on unused imports (implicit and explicit) --- CONTRIBUTORS.md | 1 + purescript.cabal | 1 + src/Language/PureScript/Errors.hs | 12 ++- src/Language/PureScript/Linter.hs | 1 + src/Language/PureScript/Linter/Imports.hs | 73 +++++++++++++++++++ src/Language/PureScript/Sugar/Names.hs | 37 ++++++---- .../PureScript/Sugar/Names/Imports.hs | 3 + 7 files changed, 114 insertions(+), 14 deletions(-) create mode 100644 src/Language/PureScript/Linter/Imports.hs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index cac0aadc49..62370ced50 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -36,6 +36,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@natefaubion](https://github.com/natefaubion) (Nathan Faubion) My existing contributions and all future contributions until further notice are Copyright Nathan Faubion, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@nicodelpiano](https://github.com/nicodelpiano) (Nicolas Del Piano) My existing contributions and all future contributions until further notice are Copyright Nicolas Del Piano, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@nullobject](https://github.com/nullobject) (Josh Bassett) My existing contributions and all future contributions until further notice are Copyright Josh Bassett, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@nwolverson](https://github.com/nwolverson) (Nicholas Wolverson) My existing contributions and all future contributions until further notice are Copyright Nicholas Wolverson, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@osa1](https://github.com/osa1) (Ömer Sinan Ağacan) - My existing contributions and all future contributions until further notice are Copyright Ömer Sinan Ağacan, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@paf31](https://github.com/paf31) (Phil Freeman) My existing contributions and all future contributions until further notice are Copyright Phil Freeman, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@paulyoung](https://github.com/paulyoung) (Paul Young) My existing contributions and all future contributions until further notice are Copyright Paul Young, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). diff --git a/purescript.cabal b/purescript.cabal index e2e84325fb..201f589b48 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -108,6 +108,7 @@ library Language.PureScript.Kinds Language.PureScript.Linter Language.PureScript.Linter.Exhaustive + Language.PureScript.Linter.Imports Language.PureScript.Make Language.PureScript.ModuleDependencies Language.PureScript.Names diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index a5618f9fbe..2370f56bde 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -144,7 +144,9 @@ data SimpleErrorMessage | ClassOperator ProperName Ident | MisleadingEmptyTypeImport ModuleName ProperName | ImportHidingModule ModuleName - deriving Show + | UnusedImport ModuleName + | UnusedExplicitImport ModuleName [String] + deriving (Show) -- | Error message hints, providing more detailed information about failure. data ErrorMessageHint @@ -280,6 +282,8 @@ errorCode em = case unwrapErrorMessage em of ClassOperator{} -> "ClassOperator" MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport" ImportHidingModule{} -> "ImportHidingModule" + UnusedImport{} -> "UnusedImport" + UnusedExplicitImport{} -> "UnusedExplicitImport" -- | -- A stack trace for an error @@ -688,6 +692,12 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError paras [ line "An exhaustivity check was abandoned due to too many possible cases." , line "You may want to decompose your data types into smaller types." ] + renderSimpleErrorMessage (UnusedImport name) = + line $ "The import of module " ++ runModuleName name ++ " is redundant" + + renderSimpleErrorMessage (UnusedExplicitImport name names) = + paras [ line $ "The import of module " ++ runModuleName name ++ " contains the following unused references:" + , indent $ paras $ map line names ] renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 2e1c0fa3ee..1a9886865a 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -36,6 +36,7 @@ import Language.PureScript.Names import Language.PureScript.Errors import Language.PureScript.Types import Language.PureScript.Linter.Exhaustive as L +import Language.PureScript.Linter.Imports as L -- | Lint the PureScript AST. -- | diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs new file mode 100644 index 0000000000..6008fc2990 --- /dev/null +++ b/src/Language/PureScript/Linter/Imports.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} + +module Language.PureScript.Linter.Imports (findUnusedImports, Name(..), UsedImports()) where + +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import Data.List ((\\)) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class +import Control.Monad(unless,when) +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif +import Data.Foldable (forM_) + +import Language.PureScript.AST.Declarations +import Language.PureScript.AST.SourcePos +import Language.PureScript.Names as P + +import Language.PureScript.Errors +import Language.PureScript.Sugar.Names.Env +import Language.PureScript.Sugar.Names.Imports + +import qualified Language.PureScript.Constants as C + +-- | Imported name used in some type or expression. +data Name = IdentName (Qualified Ident) | IsProperName (Qualified ProperName) + +-- | Map of module name to list of imported names from that module which have been used. +type UsedImports = M.Map ModuleName [Name] + +-- | +-- Find and warn on any unused import statements (qualified or unqualified) +-- or references in an explicit import list. +-- +findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Imports -> UsedImports -> m () +findUnusedImports (Module _ _ _ mdecls _) _ usedImps = do + imps <- findImports mdecls + forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` autoIncludes) $ + forM_ decls $ \(ss, declType, qualifierName) -> censor (onErrorMessages $ addModuleLocError ss) $ + let usedNames = mapMaybe (matchName qualifierName) $ sugarNames ++ M.findWithDefault [] mni usedImps in + case declType of + Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni + Explicit declrefs -> do + let idents = mapMaybe runDeclRef declrefs + let diff = idents \\ usedNames + unless (null diff) $ tell $ errorMessage $ UnusedExplicitImport mni diff + _ -> return () + where + sugarNames :: [ Name ] + sugarNames = [ IdentName $ Qualified Nothing (Ident C.bind) ] + + autoIncludes :: [ ModuleName ] + autoIncludes = [ ModuleName [ProperName C.prim] ] + +matchName :: Maybe ModuleName -> Name -> Maybe String +matchName qual (IdentName (Qualified q x)) | q == qual = Just $ runIdent x +matchName qual (IsProperName (Qualified q x)) | q == qual = Just $ runProperName x +matchName _ _ = Nothing + +runDeclRef :: DeclarationRef -> Maybe String +runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref +runDeclRef (ValueRef ident) = Just $ runIdent ident +runDeclRef (TypeRef pn _) = Just $ runProperName pn +runDeclRef _ = Nothing + +addModuleLocError :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage +addModuleLocError sp err = + case sp of + Just pos -> withPosition pos err + _ -> err diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 810acefc53..069c2d6a5b 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -28,6 +28,7 @@ import Control.Applicative (Applicative(..), (<$>), (<*>)) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer (MonadWriter(..), censor) +import Control.Monad.State.Lazy import qualified Data.Map as M @@ -41,6 +42,7 @@ import Language.PureScript.Externs import Language.PureScript.Sugar.Names.Env import Language.PureScript.Sugar.Names.Imports import Language.PureScript.Sugar.Names.Exports +import Language.PureScript.Linter.Imports -- | -- Replaces all local names with qualified names within a list of modules. The @@ -103,9 +105,11 @@ desugarImports externs modules = do renameInModule' :: Env -> Module -> m Module renameInModule' env m@(Module _ _ mn _ _) = - rethrow (addHint (ErrorInModule mn)) $ do + warnAndRethrow (addHint (ErrorInModule mn)) $ do let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env - elaborateImports imps <$> renameInModule env imps (elaborateExports exps m) + (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m) + findUnusedImports m imps used + return $ elaborateImports imps m' -- | -- Make all exports for a module explicit. This may still effect modules that @@ -146,10 +150,11 @@ elaborateImports imps (Module ss coms mn decls exps) = Module ss coms mn decls' -- Replaces all local names with qualified names within a module and checks that all existing -- qualified names are valid. -- -renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> Imports -> Module -> m Module +renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) => Env -> Imports -> Module -> m Module renameInModule env imports (Module ss coms mn decls exps) = Module ss coms mn <$> parU decls go <*> pure exps where + (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration) @@ -168,7 +173,7 @@ renameInModule env imports (Module ss coms mn decls exps) = updateDecl (pos, bound) (ExternDeclaration name ty) = (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty) updateDecl s d = return (s, d) - + -- updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr) updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v) @@ -189,7 +194,7 @@ renameInModule env imports (Module ss coms mn decls exps) = updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty) updateValue s v = return (s, v) - + -- updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder) updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v) @@ -201,8 +206,8 @@ renameInModule env imports (Module ss coms mn decls exps) = return (s', TypedBinder t' b') updateBinder s v = return (s, v) - - updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative) + -- + updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative) updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c) @@ -223,16 +228,16 @@ renameInModule env imports (Module ss coms mn decls exps) = updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts) updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) - updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) + updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) IsProperName updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) - updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) + updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) IsProperName updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) - updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) + updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) IsProperName updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident) - updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) + updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName -- Used when performing an update to qualify values and classes with their -- module of original definition. @@ -255,16 +260,22 @@ renameInModule env imports (Module ss coms mn decls exps) = update :: (Ord a) => (Qualified a -> SimpleErrorMessage) -> M.Map (Qualified a) (Qualified a, ModuleName) -> (Exports -> a -> Maybe (Qualified a)) + -> (Qualified a -> Name) -> Qualified a -> Maybe SourceSpan -> m (Qualified a) - update unknown imps getE qname@(Qualified mn' name) pos = positioned $ + update unknown imps getE toName qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imps, mn') of -- We found the name in our imports, so we return the name for it, -- qualifying with the name of the module it was originally defined in -- rather than the module we're importing from, to handle the case of -- re-exports. - (Just (_, mnOrig), _) -> return $ Qualified (Just mnOrig) name + (Just (qn, mnOrig), _) -> do + case qn of + Qualified (Just mnNew) _ -> + modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result + _ -> return () + return $ Qualified (Just mnOrig) name -- If the name wasn't found in our imports but was qualified then we need -- to check whether it's a failed import from a "pseudo" module (created -- by qualified importing). If that's not the case, then we just need to diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index ab03420da4..c74aaaec63 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -19,6 +19,7 @@ module Language.PureScript.Sugar.Names.Imports ( resolveImports , resolveModuleImport + , findImports ) where import Data.List (find) @@ -40,8 +41,10 @@ import Language.PureScript.Names import Language.PureScript.Errors import Language.PureScript.Sugar.Names.Env +-- | -- Finds the imports within a module, mapping the imported module name to an optional set of -- explicitly imported declarations. +-- findImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) findImports = foldM (go Nothing) M.empty where From 9314ff804573928d8748f7d2f85193bf95341e8a Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 1 Nov 2015 01:16:49 +0000 Subject: [PATCH 0111/1580] Type constructors mark their type used. Show operators properly --- src/Language/PureScript/Linter/Imports.hs | 30 +++++++++++++++-------- src/Language/PureScript/Sugar/Names.hs | 4 +-- 2 files changed, 22 insertions(+), 12 deletions(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 6008fc2990..8269c18143 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -6,7 +6,7 @@ module Language.PureScript.Linter.Imports (findUnusedImports, Name(..), UsedImpo import qualified Data.Map as M import Data.Maybe (mapMaybe) -import Data.List ((\\)) +import Data.List ((\\), find) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class import Control.Monad(unless,when) @@ -26,7 +26,7 @@ import Language.PureScript.Sugar.Names.Imports import qualified Language.PureScript.Constants as C -- | Imported name used in some type or expression. -data Name = IdentName (Qualified Ident) | IsProperName (Qualified ProperName) +data Name = IdentName (Qualified Ident) | IsProperName (Qualified ProperName) | DctorName (Qualified ProperName) -- | Map of module name to list of imported names from that module which have been used. type UsedImports = M.Map ModuleName [Name] @@ -35,12 +35,12 @@ type UsedImports = M.Map ModuleName [Name] -- Find and warn on any unused import statements (qualified or unqualified) -- or references in an explicit import list. -- -findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Imports -> UsedImports -> m () -findUnusedImports (Module _ _ _ mdecls _) _ usedImps = do +findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports -> m () +findUnusedImports (Module _ _ _ mdecls _) env usedImps = do imps <- findImports mdecls forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` autoIncludes) $ forM_ decls $ \(ss, declType, qualifierName) -> censor (onErrorMessages $ addModuleLocError ss) $ - let usedNames = mapMaybe (matchName qualifierName) $ sugarNames ++ M.findWithDefault [] mni usedImps in + let usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) $ sugarNames ++ M.findWithDefault [] mni usedImps in case declType of Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni Explicit declrefs -> do @@ -55,14 +55,24 @@ findUnusedImports (Module _ _ _ mdecls _) _ usedImps = do autoIncludes :: [ ModuleName ] autoIncludes = [ ModuleName [ProperName C.prim] ] -matchName :: Maybe ModuleName -> Name -> Maybe String -matchName qual (IdentName (Qualified q x)) | q == qual = Just $ runIdent x -matchName qual (IsProperName (Qualified q x)) | q == qual = Just $ runProperName x -matchName _ _ = Nothing + typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName + typeForDCtor mn pn = + getTy <$> find matches tys + where + matches ((_, ctors), _) = pn `elem` ctors + getTy ((ty, _), _) = ty + tys :: [((ProperName, [ProperName]), ModuleName)] + tys = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env + +matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String +matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x +matchName _ qual (IsProperName (Qualified q x)) | q == qual = Just $ runProperName x +matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x +matchName _ _ _ = Nothing runDeclRef :: DeclarationRef -> Maybe String runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref -runDeclRef (ValueRef ident) = Just $ runIdent ident +runDeclRef (ValueRef ident) = Just $ showIdent ident runDeclRef (TypeRef pn _) = Just $ runProperName pn runDeclRef _ = Nothing diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 069c2d6a5b..ccb465fad9 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -108,7 +108,7 @@ desugarImports externs modules = do warnAndRethrow (addHint (ErrorInModule mn)) $ do let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m) - findUnusedImports m imps used + findUnusedImports m env used return $ elaborateImports imps m' -- | @@ -231,7 +231,7 @@ renameInModule env imports (Module ss coms mn decls exps) = updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) IsProperName updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) - updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) IsProperName + updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) IsProperName From 117d5d3cd25122aa3859f0425f196e623aa08490 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 1 Nov 2015 11:10:50 -0800 Subject: [PATCH 0112/1580] New approach to unification --- psci/PSCi.hs | 12 +- purescript.cabal | 1 - src/Control/Monad/Unify.hs | 160 ---------- src/Language/PureScript/Errors.hs | 17 +- src/Language/PureScript/Kinds.hs | 3 +- src/Language/PureScript/TypeChecker.hs | 139 ++++++--- .../PureScript/TypeChecker/Entailment.hs | 20 +- src/Language/PureScript/TypeChecker/Kinds.hs | 214 +++++++------ src/Language/PureScript/TypeChecker/Monad.hs | 213 +++++-------- src/Language/PureScript/TypeChecker/Rows.hs | 20 +- .../PureScript/TypeChecker/Skolems.hs | 21 +- .../PureScript/TypeChecker/Subsumption.hs | 40 +-- src/Language/PureScript/TypeChecker/Types.hs | 286 +++++++++++------- src/Language/PureScript/TypeChecker/Unify.hs | 119 +++++--- src/Language/PureScript/Types.hs | 3 +- 15 files changed, 635 insertions(+), 633 deletions(-) delete mode 100644 src/Control/Monad/Unify.hs diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 0912c04013..7d31fc8af9 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -35,12 +35,11 @@ import Control.Arrow (first) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.Class -import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.Except (ExceptT(), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.State.Strict import Control.Monad.IO.Class (liftIO) -import Control.Monad.Writer.Strict (runWriter) -import qualified Control.Monad.Trans.State.Lazy as L +import Control.Monad.Writer.Strict (Writer(), runWriter) import Options.Applicative as Opts @@ -424,8 +423,11 @@ handleKindOf typ = do Right env' -> case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of Just (_, typ') -> do - let chk = P.CheckState env' 0 0 (Just mName) - k = fst . runWriter . runExceptT $ L.runStateT (P.unCheck (P.kindOf typ')) chk + let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName } + k = check (P.kindOf typ') chk + + check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState) + check sew cs = fst . runWriter . runExceptT . runStateT sew $ cs case k of Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind diff --git a/purescript.cabal b/purescript.cabal index 09f90f15ed..e5c61cffda 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -173,7 +173,6 @@ library Language.PureScript.Publish.BoxesHelpers Control.Monad.Logger - Control.Monad.Unify Control.Monad.Supply Control.Monad.Supply.Class diff --git a/src/Control/Monad/Unify.hs b/src/Control/Monad/Unify.hs deleted file mode 100644 index 53db603e34..0000000000 --- a/src/Control/Monad/Unify.hs +++ /dev/null @@ -1,160 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Control.Monad.Unify --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- --- ------------------------------------------------------------------------------ - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Control.Monad.Unify where - -import Data.Monoid - -import Control.Applicative -import Control.Monad.State -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) - -import Data.HashMap.Strict as M - --- | --- Untyped unification variables --- -type Unknown = Int - --- | --- A type which can contain unification variables --- -class Partial t where - unknown :: Unknown -> t - isUnknown :: t -> Maybe Unknown - unknowns :: t -> [Unknown] - ($?) :: Substitution t -> t -> t - --- | --- Identifies types which support unification --- -class (Partial t) => Unifiable m t | t -> m where - (=?=) :: t -> t -> UnifyT t m () - --- | --- A substitution maintains a mapping from unification variables to their values --- -data Substitution t = Substitution { runSubstitution :: M.HashMap Int t } - -instance (Partial t) => Monoid (Substitution t) where - mempty = Substitution M.empty - s1 `mappend` s2 = Substitution $ - M.map (s2 $?) (runSubstitution s1) `M.union` - M.map (s1 $?) (runSubstitution s2) - --- | --- State required for type checking --- -data UnifyState t = UnifyState { - -- | - -- The next fresh unification variable - -- - unifyNextVar :: Int - -- | - -- The current substitution - -- - , unifyCurrentSubstitution :: Substitution t - } - --- | --- An empty @UnifyState@ --- -defaultUnifyState :: (Partial t) => UnifyState t -defaultUnifyState = UnifyState 0 mempty - --- | --- A class for errors which support unification errors --- -class UnificationError t e where - occursCheckFailed :: t -> e - --- | --- The type checking monad, which provides the state of the type checker, and error reporting capabilities --- -newtype UnifyT t m a = UnifyT { unUnify :: StateT (UnifyState t) m a } - deriving (Functor, Monad, Applicative, Alternative, MonadPlus, MonadWriter w) - -instance (MonadState s m) => MonadState s (UnifyT t m) where - get = UnifyT . lift $ get - put = UnifyT . lift . put - -instance (MonadError e m) => MonadError e (UnifyT t m) where - throwError = UnifyT . throwError - catchError e f = UnifyT $ catchError (unUnify e) (unUnify . f) - --- | --- Run a computation in the Unify monad, failing with an error, or succeeding with a return value and the new next unification variable --- -runUnify :: UnifyState t -> UnifyT t m a -> m (a, UnifyState t) -runUnify s = flip runStateT s . unUnify - --- | --- Substitute a single unification variable --- -substituteOne :: (Partial t) => Unknown -> t -> Substitution t -substituteOne u t = Substitution $ M.singleton u t - --- | --- Replace a unification variable with the specified value in the current substitution --- -(=:=) :: (UnificationError t e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m () -(=:=) u t' = do - st <- UnifyT get - let sub = unifyCurrentSubstitution st - let t = sub $? t' - occursCheck u t - let current = sub $? unknown u - case isUnknown current of - Just u1 | u1 == u -> return () - _ -> current =?= t - UnifyT $ modify $ \s -> s { unifyCurrentSubstitution = substituteOne u t <> unifyCurrentSubstitution s } - --- | --- Perform the occurs check, to make sure a unification variable does not occur inside a value --- -occursCheck :: (UnificationError t e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m () -occursCheck u t = - case isUnknown t of - Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ occursCheckFailed t - _ -> return () - --- | --- Generate a fresh untyped unification variable --- -fresh' :: (Monad m) => UnifyT t m Unknown -fresh' = do - st <- UnifyT get - UnifyT $ modify $ \s -> s { unifyNextVar = succ (unifyNextVar s) } - return $ unifyNextVar st - --- | --- Generate a fresh unification variable at a specific type --- -fresh :: (Monad m, Partial t) => UnifyT t m t -fresh = do - u <- fresh' - return $ unknown u - - - diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 2370f56bde..d7738af66f 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -32,7 +32,6 @@ import Data.Foldable (fold) import qualified Data.Map as M import Control.Monad -import Control.Monad.Unify import Control.Monad.Writer import Control.Monad.Error.Class (MonadError(..)) #if __GLASGOW_HASKELL__ < 710 @@ -183,12 +182,6 @@ data HintCategory data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show) -instance UnificationError Type ErrorMessage where - occursCheckFailed t = ErrorMessage [] $ InfiniteType t - -instance UnificationError Kind ErrorMessage where - occursCheckFailed k = ErrorMessage [] $ InfiniteKind k - -- | -- Get the error code for a particular error type -- @@ -291,12 +284,6 @@ errorCode em = case unwrapErrorMessage em of newtype MultipleErrors = MultipleErrors { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid) -instance UnificationError Type MultipleErrors where - occursCheckFailed t = MultipleErrors [occursCheckFailed t] - -instance UnificationError Kind MultipleErrors where - occursCheckFailed k = MultipleErrors [occursCheckFailed k] - -- | Check whether a collection of errors is empty or not. nonEmpty :: MultipleErrors -> Bool nonEmpty = not . null . runMultipleErrors @@ -326,7 +313,7 @@ addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord) -- | A map from rigid type variable name/unknown variable pairs to new variables. -type UnknownMap = M.Map (LabelType, Unknown) Unknown +type UnknownMap = M.Map (LabelType, Int) Int -- | How critical the issue is data Level = Error | Warning deriving Show @@ -340,7 +327,7 @@ unwrapErrorMessage (ErrorMessage _ se) = se replaceUnknowns :: Type -> State UnknownMap Type replaceUnknowns = everywhereOnTypesM replaceTypes where - lookupTable :: (LabelType, Unknown) -> UnknownMap -> (Unknown, UnknownMap) + lookupTable :: (LabelType, Int) -> UnknownMap -> (Int, UnknownMap) lookupTable x m = case M.lookup x m of Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m) Just i -> (i, m) diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 1c63b7d6b9..888a8cd4d3 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -24,7 +24,6 @@ import qualified Data.Aeson.TH as A #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif -import Control.Monad.Unify (Unknown) -- | -- The data type of kinds @@ -33,7 +32,7 @@ data Kind -- | -- Unification variable of type Kind -- - = KUnknown Unknown + = KUnknown Int -- | -- The kind of types -- diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 4c41bf396e..5cd89a00ca 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -13,7 +13,9 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Language.PureScript.TypeChecker ( @@ -29,14 +31,17 @@ import Language.PureScript.TypeChecker.Synonyms as T import Data.Maybe import Data.List (nub, (\\), sort, group) import Data.Foldable (for_) +import Data.Traversable (for) import qualified Data.Map as M #if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*)) +import Control.Applicative #endif -import Control.Monad.State +import Control.Monad (when, unless, void) +import Control.Monad.State.Class (MonadState(..), modify) import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) import Language.PureScript.Crash import Language.PureScript.Types @@ -47,15 +52,31 @@ import Language.PureScript.TypeClassDictionaries import Language.PureScript.Environment import Language.PureScript.Errors -addDataType :: ModuleName -> DataDeclType -> ProperName -> [(String, Maybe Kind)] -> [(ProperName, [Type])] -> Kind -> Check () +addDataType :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + DataDeclType -> + ProperName -> + [(String, Maybe Kind)] -> + [(ProperName, [Type])] -> + Kind -> + m () addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) } - forM_ dctors $ \(dctor, tys) -> + for_ dctors $ \(dctor, tys) -> warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $ addDataConstructor moduleName dtype name (map fst args) dctor tys -addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check () +addDataConstructor :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + DataDeclType -> + ProperName -> + [String] -> + ProperName -> + [Type] -> + m () addDataConstructor moduleName dtype name args dctor tys = do env <- getEnv mapM_ checkTypeSynonyms tys @@ -65,26 +86,50 @@ addDataConstructor moduleName dtype name args dctor tys = do let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]] putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } -addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check () +addTypeSynonym :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + ProperName -> + [(String, Maybe Kind)] -> + Type -> + Kind -> + m () addTypeSynonym moduleName name args ty kind = do env <- getEnv checkTypeSynonyms ty putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env) , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) } -valueIsNotDefined :: ModuleName -> Ident -> Check () +valueIsNotDefined :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + Ident -> + m () valueIsNotDefined moduleName name = do env <- getEnv case M.lookup (moduleName, name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name Nothing -> return () -addValue :: ModuleName -> Ident -> Type -> NameKind -> Check () +addValue :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + Ident -> + Type -> + NameKind -> + m () addValue moduleName name ty nameKind = do env <- getEnv putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) }) -addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Check () +addTypeClass :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + ProperName -> + [(String, Maybe Kind)] -> + [Constraint] -> + [Declaration] -> + m () addTypeClass moduleName pn args implies ds = let members = map toPair ds in modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } } @@ -93,19 +138,30 @@ addTypeClass moduleName pn args implies ds = toPair (PositionedDeclaration _ _ d) = toPair d toPair _ = internalError "Invalid declaration in TypeClassDeclaration" -addTypeClassDictionaries :: Maybe ModuleName -> M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) -> Check () +addTypeClassDictionaries :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Maybe ModuleName -> + M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) -> + m () addTypeClassDictionaries mn entries = modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } } where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st) -checkDuplicateTypeArguments :: [String] -> Check () +checkDuplicateTypeArguments :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + [String] -> + m () checkDuplicateTypeArguments args = for_ firstDup $ \dup -> throwError . errorMessage $ DuplicateTypeArgument dup where firstDup :: Maybe String firstDup = listToMaybe $ args \\ nub args -checkTypeClassInstance :: ModuleName -> Type -> Check () +checkTypeClassInstance :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + Type -> + m () checkTypeClassInstance _ (TypeVar _) = return () checkTypeClassInstance _ (TypeConstructor ctor) = do env <- getEnv @@ -117,7 +173,10 @@ checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty -- | -- Check that type synonyms are fully-applied in a type -- -checkTypeSynonyms :: Type -> Check () +checkTypeSynonyms :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Type -> + m () checkTypeSynonyms = void . replaceAllTypeSynonyms -- | @@ -133,10 +192,15 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms -- -- * Process module imports -- -typeCheckAll :: ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration] +typeCheckAll :: forall m. + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + [DeclarationRef] -> + [Declaration] -> + m [Declaration] typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds where - go :: Declaration -> Check Declaration + go :: Declaration -> m Declaration go (DataDeclaration dtype name args dctors) = do warnAndRethrow (addHint (ErrorInTypeConstructor name)) $ do when (dtype == Newtype) $ checkNewtype dctors @@ -146,7 +210,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds addDataType moduleName dtype name args' dctors ctorKind return $ DataDeclaration dtype name args dctors where - checkNewtype :: [(ProperName, [Type])] -> Check () + checkNewtype :: [(ProperName, [Type])] -> m () checkNewtype [(_, [_])] = return () checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name checkNewtype _ = throwError . errorMessage $ InvalidNewtype name @@ -155,11 +219,11 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds let syns = mapMaybe toTypeSynonym tys let dataDecls = mapMaybe toDataDecl tys (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls) - forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do + for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do checkDuplicateTypeArguments $ map fst args let args' = args `withKinds` ctorKind addDataType moduleName dtype name args' dctors ctorKind - forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do + for_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do checkDuplicateTypeArguments $ map fst args let args' = args `withKinds` kind addTypeSynonym moduleName name args' ty kind @@ -188,14 +252,14 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds go (ValueDeclaration{}) = internalError "Binders were not desugared" go (BindingGroupDeclaration vals) = warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do - forM_ (map (\(ident, _, _) -> ident) vals) $ \name -> + for_ (map (\(ident, _, _) -> ident) vals) $ \name -> valueIsNotDefined moduleName name tys <- typesOf moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals - vals' <- forM [ (name, val, nameKind, ty) - | (name, nameKind, _) <- vals - , (name', (val, ty)) <- tys - , name == name' - ] $ \(name, val, nameKind, ty) -> do + vals' <- for [ (name, val, nameKind, ty) + | (name, nameKind, _) <- vals + , (name', (val, ty)) <- tys + , name == name' + ] $ \(name, val, nameKind, ty) -> do addValue moduleName name ty nameKind return (name, nameKind, val) return $ BindingGroupDeclaration vals' @@ -219,7 +283,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds return d go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do mapM_ (checkTypeClassInstance moduleName) tys - forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd + for_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd checkOrphanInstance dictName className tys _ <- traverseTypeInstanceBody checkInstanceMembers body let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) @@ -228,7 +292,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds go (PositionedDeclaration pos com d) = warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d - checkOrphanFixities :: Declaration -> Check () + checkOrphanFixities :: Declaration -> m () checkOrphanFixities (FixityDeclaration _ name) = do env <- getEnv guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env @@ -236,7 +300,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds warnAndRethrowWithPosition pos $ checkOrphanFixities d checkOrphanFixities _ = return () - checkInstanceMembers :: [Declaration] -> Check [Declaration] + checkInstanceMembers :: [Declaration] -> m [Declaration] checkInstanceMembers instDecls = do let idents = sort . map head . group . map memberName $ instDecls for_ (firstDuplicate idents) $ \ident -> @@ -254,7 +318,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds | otherwise = firstDuplicate xs firstDuplicate _ = Nothing - checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> Check () + checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> m () checkOrphanInstance dictName className@(Qualified (Just mn') _) tys' | moduleName == mn' || any checkType tys' = return () | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys' @@ -281,19 +345,22 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds -- Type check an entire module and ensure all types and classes defined within the module that are -- required by exported members are also exported. -- -typeCheckModule :: Module -> Check Module +typeCheckModule :: forall m. + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Module -> + m Module typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated" typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do modify (\s -> s { checkCurrentModule = Just mn }) decls' <- typeCheckAll mn exps decls - forM_ exps $ \e -> do + for_ exps $ \e -> do checkTypesAreExported e checkClassMembersAreExported e checkClassesAreExported e return $ Module ss coms mn decls' (Just exps) where - checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check () + checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m () checkMemberExport extract dr@(TypeRef name dctors) = do env <- getEnv case M.lookup (Qualified (Just mn) name) (typeSynonyms env) of @@ -301,7 +368,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint Just (_, ty) -> checkExport dr extract ty case dctors of Nothing -> return () - Just dctors' -> forM_ dctors' $ \dctor -> + Just dctors' -> for_ dctors' $ \dctor -> case M.lookup (Qualified (Just mn) dctor) (dataConstructors env) of Nothing -> return () Just (_, _, ty, _) -> checkExport dr extract ty @@ -311,7 +378,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint checkExport dr extract ty checkMemberExport _ _ = return () - checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> Check () + checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m () checkExport dr extract ty = case filter (not . exported) (extract ty) of [] -> return () hidden -> throwError . errorMessage $ TransitiveExportError dr hidden @@ -326,7 +393,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint -- 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 :: DeclarationRef -> m () checkTypesAreExported = checkMemberExport findTcons where findTcons :: Type -> [DeclarationRef] @@ -337,7 +404,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint -- Check that all the classes defined in the current module that appear in member types have also -- been exported from the module - checkClassesAreExported :: DeclarationRef -> Check () + checkClassesAreExported :: DeclarationRef -> m () checkClassesAreExported = checkMemberExport findClasses where findClasses :: Type -> [DeclarationRef] @@ -349,7 +416,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name extractCurrentModuleClass _ = Nothing - checkClassMembersAreExported :: DeclarationRef -> Check () + checkClassMembersAreExported :: DeclarationRef -> m () checkClassMembersAreExported dr@(TypeClassRef name) = do let members = ValueRef `map` head (mapMaybe findClassMembers decls) let missingMembers = members \\ exps diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 3bc4f3037e..9496a029c0 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -14,6 +14,8 @@ ----------------------------------------------------------------------------- {-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} module Language.PureScript.TypeChecker.Entailment ( entails @@ -33,13 +35,12 @@ import Control.Applicative import Control.Arrow (Arrow(..)) import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (tell) +import Control.Monad.Writer.Class (MonadWriter(..)) import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Names -import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types @@ -49,7 +50,12 @@ import qualified Language.PureScript.Constants as C -- Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. -- -entails :: ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Check Expr +entails :: forall m. + (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> + Constraint -> + m Expr entails moduleName context = solve where forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope] @@ -65,12 +71,12 @@ entails moduleName context = solve findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope] findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context - solve :: Constraint -> Check Expr + solve :: Constraint -> m Expr solve (className, tys) = do dict <- go 0 className tys return $ dictionaryValueToValue dict where - go :: Int -> Qualified ProperName -> [Type] -> Check DictionaryValue + go :: Int -> Qualified ProperName -> [Type] -> m DictionaryValue go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' go work className' tys' = do let instances = do @@ -86,7 +92,7 @@ entails moduleName context = solve (tcdPath tcd) where - unique :: [(a, TypeClassDictionaryInScope)] -> Check (a, TypeClassDictionaryInScope) + unique :: [(a, TypeClassDictionaryInScope)] -> m (a, TypeClassDictionaryInScope) unique [] = throwError . errorMessage $ NoInstanceFound className' tys' unique [a] = return a unique tcds | pairwise overlapping (map snd tcds) = do @@ -109,7 +115,7 @@ entails moduleName context = solve -- Create dictionaries for subgoals which still need to be solved by calling go recursively -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively. - solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> Check (Maybe [DictionaryValue]) + solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> m (Maybe [DictionaryValue]) solveSubgoals _ Nothing = return Nothing solveSubgoals subst (Just subgoals) = do dict <- mapM (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index e0aa8cf078..a3e659e8a3 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -13,10 +13,11 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module Language.PureScript.TypeChecker.Kinds ( @@ -26,9 +27,6 @@ module Language.PureScript.TypeChecker.Kinds ( kindsOfAll ) where -import Data.Maybe (fromMaybe) - -import qualified Data.HashMap.Strict as H import qualified Data.Map as M import Control.Arrow (second) @@ -37,8 +35,8 @@ import Control.Applicative #endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.State -import Control.Monad.Unify import Language.PureScript.Crash import Language.PureScript.Environment @@ -48,177 +46,213 @@ import Language.PureScript.Names import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types -instance Partial Kind where - unknown = KUnknown - isUnknown (KUnknown u) = Just u - isUnknown _ = Nothing - unknowns = everythingOnKinds (++) go - where - go (KUnknown u) = [u] - go _ = [] - ($?) sub = everywhereOnKinds go - where - go t@(KUnknown u) = fromMaybe t $ H.lookup u (runSubstitution sub) - go other = other - -instance Unifiable Check Kind where - KUnknown u1 =?= KUnknown u2 | u1 == u2 = return () - KUnknown u =?= k = u =:= k - k =?= KUnknown u = u =:= k - Star =?= Star = return () - Bang =?= Bang = return () - Row k1 =?= Row k2 = k1 =?= k2 - FunKind k1 k2 =?= FunKind k3 k4 = do - k1 =?= k3 - k2 =?= k4 - k1 =?= k2 = UnifyT . lift . throwError . errorMessage $ KindsDoNotUnify k1 k2 +-- | Generate a fresh kind variable +freshKind :: (MonadState CheckState m) => m Kind +freshKind = do + k <- gets checkNextKind + modify $ \st -> st { checkNextKind = k + 1 } + return $ KUnknown k --- | --- Infer the kind of a single type --- -kindOf :: Type -> Check Kind +-- | Update the substitution to solve a kind constraint +solveKind :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Kind -> m () +solveKind u k = do + occursCheck u k + modify $ \cs -> cs { checkSubstitution = + (checkSubstitution cs) { substKind = + M.insert u k $ substKind $ checkSubstitution cs + } + } + +-- | Apply a substitution to a kind +substituteKind :: Substitution -> Kind -> Kind +substituteKind sub = everywhereOnKinds go + where + go (KUnknown u) = + case M.lookup u (substKind sub) of + Nothing -> KUnknown u + Just (KUnknown u1) | u1 == u -> KUnknown u1 + Just t -> substituteKind sub t + go other = other + +-- | Make sure that an unknown does not occur in a kind +occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Kind -> m () +occursCheck _ KUnknown{} = return () +occursCheck u k = void $ everywhereOnKindsM go k + where + go (KUnknown u') | u == u' = throwError . errorMessage . InfiniteKind $ k + go other = return other + +-- | Unify two kinds +unifyKinds :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Kind -> Kind -> m () +unifyKinds k1 k2 = do + sub <- gets checkSubstitution + go (substituteKind sub k1) (substituteKind sub k2) + where + go (KUnknown u1) (KUnknown u2) | u1 == u2 = return () + go (KUnknown u) k = solveKind u k + go k (KUnknown u) = solveKind u k + go Star Star = return () + go Bang Bang = return () + go (Row k1') (Row k2') = go k1' k2' + go (FunKind k1' k2') (FunKind k3 k4) = do + go k1' k3 + go k2' k4 + go k1' k2' = throwError . errorMessage $ KindsDoNotUnify k1' k2' + +-- | Infer the kind of a single type +kindOf :: + (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => + Type -> + m Kind kindOf ty = fst <$> kindOfWithScopedVars ty --- | --- Infer the kind of a single type, returning the kinds of any scoped type variables --- -kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)]) +-- | Infer the kind of a single type, returning the kinds of any scoped type variables +kindOfWithScopedVars :: + (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => + Type -> + m (Kind, [(String, Kind)]) kindOfWithScopedVars ty = rethrow (addHint (ErrorCheckingKind ty)) $ fmap tidyUp . liftUnify $ infer ty where - tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k) - , map (second (starIfUnknown . (sub $?))) args + tidyUp ((k, args), sub) = ( starIfUnknown (substituteKind sub k) + , map (second (starIfUnknown . substituteKind sub)) args ) --- | --- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors --- -kindsOf :: Bool -> ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Type] -> Check Kind +-- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors +kindsOf :: + (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => + Bool -> + ModuleName -> + ProperName -> + [(String, Maybe Kind)] -> + [Type] -> + m Kind kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do - tyCon <- fresh - kargs <- replicateM (length args) fresh + tyCon <- freshKind + kargs <- replicateM (length args) freshKind rest <- zipWithM freshKindVar args kargs let dict = (name, tyCon) : rest bindLocalTypeVariables moduleName dict $ solveTypes isData ts kargs tyCon where - tidyUp (k, sub) = starIfUnknown $ sub $? k + tidyUp (k, sub) = starIfUnknown $ substituteKind sub k -freshKindVar :: (String, Maybe Kind) -> Kind -> UnifyT Kind Check (ProperName, Kind) +freshKindVar :: + (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => + (String, Maybe Kind) -> + Kind -> + m (ProperName, Kind) freshKindVar (arg, Nothing) kind = return (ProperName arg, kind) freshKindVar (arg, Just kind') kind = do - kind =?= kind' + unifyKinds kind kind' return (ProperName arg, kind') --- | --- Simultaneously infer the kinds of several mutually recursive type constructors --- -kindsOfAll :: ModuleName -> [(ProperName, [(String, Maybe Kind)], Type)] -> [(ProperName, [(String, Maybe Kind)], [Type])] -> Check ([Kind], [Kind]) +-- | Simultaneously infer the kinds of several mutually recursive type constructors +kindsOfAll :: + (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => + ModuleName -> + [(ProperName, [(String, Maybe Kind)], Type)] -> + [(ProperName, [(String, Maybe Kind)], [Type])] -> + m ([Kind], [Kind]) kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do - synVars <- replicateM (length syns) fresh + synVars <- replicateM (length syns) freshKind let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars bindLocalTypeVariables moduleName dict $ do - tyCons <- replicateM (length tys) fresh + tyCons <- replicateM (length tys) freshKind let dict' = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons bindLocalTypeVariables moduleName dict' $ do data_ks <- zipWithM (\tyCon (_, args, ts) -> do - kargs <- replicateM (length args) fresh + kargs <- replicateM (length args) freshKind argDict <- zipWithM freshKindVar args kargs bindLocalTypeVariables moduleName argDict $ solveTypes True ts kargs tyCon) tyCons tys syn_ks <- zipWithM (\synVar (_, args, ty) -> do - kargs <- replicateM (length args) fresh + kargs <- replicateM (length args) freshKind argDict <- zipWithM freshKindVar args kargs bindLocalTypeVariables moduleName argDict $ 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) + tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . substituteKind sub) ks1, map (starIfUnknown . substituteKind sub) ks2) --- | --- Solve the set of kind constraints associated with the data constructors for a type constructor --- -solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind +-- | Solve the set of kind constraints associated with the data constructors for a type constructor +solveTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Bool -> [Type] -> [Kind] -> Kind -> m Kind solveTypes isData ts kargs tyCon = do ks <- mapM (fmap fst . infer) ts when isData $ do - tyCon =?= foldr FunKind Star kargs - forM_ ks $ \k -> k =?= Star + unifyKinds tyCon (foldr FunKind Star kargs) + forM_ ks $ \k -> unifyKinds k Star unless isData $ - tyCon =?= foldr FunKind (head ks) kargs + unifyKinds tyCon (foldr FunKind (head ks) kargs) return tyCon --- | --- Default all unknown kinds to the Star kind of types --- +-- | Default all unknown kinds to the Star kind of types starIfUnknown :: Kind -> Kind starIfUnknown (KUnknown _) = Star starIfUnknown (Row k) = Row (starIfUnknown k) starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2) starIfUnknown k = k --- | --- Infer a kind for a type --- -infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)]) +-- | Infer a kind for a type +infer :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)]) infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty -infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)]) +infer' :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)]) infer' (ForAll ident ty _) = do - k1 <- fresh + k1 <- freshKind Just moduleName <- checkCurrentModule <$> get (k2, args) <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty - k2 =?= Star + unifyKinds k2 Star return (Star, (ident, k1) : args) infer' (KindedType ty k) = do (k', args) <- infer ty - k =?= k' + unifyKinds k k' return (k', args) infer' other = (, []) <$> go other where - go :: Type -> UnifyT Kind Check Kind + go :: Type -> m Kind go (ForAll ident ty _) = do - k1 <- fresh + k1 <- freshKind Just moduleName <- checkCurrentModule <$> get k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ go ty - k2 =?= Star + unifyKinds k2 Star return Star go (KindedType ty k) = do k' <- go ty - k =?= k' + unifyKinds k k' return k' - go TypeWildcard = fresh + go TypeWildcard = freshKind go (TypeVar v) = do Just moduleName <- checkCurrentModule <$> get - UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) + lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) go (Skolem v _ _) = do Just moduleName <- checkCurrentModule <$> get - UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) + lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) go (TypeConstructor v) = do - env <- liftCheck getEnv + env <- getEnv case M.lookup v (types env) of - Nothing -> UnifyT . lift . throwError . errorMessage $ UnknownTypeConstructor v + Nothing -> throwError . errorMessage $ UnknownTypeConstructor v Just (kind, _) -> return kind go (TypeApp t1 t2) = do - k0 <- fresh + k0 <- freshKind k1 <- go t1 k2 <- go t2 - k1 =?= FunKind k2 k0 + unifyKinds k1 (FunKind k2 k0) return k0 go REmpty = do - k <- fresh + k <- freshKind return $ Row k go (RCons _ ty row) = do k1 <- go ty k2 <- go row - k2 =?= Row k1 + unifyKinds k2 (Row k1) return $ Row k1 go (ConstrainedType deps ty) = do forM_ deps $ \(className, tys) -> do k <- go $ foldl TypeApp (TypeConstructor className) tys - k =?= Star + unifyKinds k Star k <- go ty - k =?= Star + unifyKinds k Star return Star go _ = internalError "Invalid argument to infer" diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 33a791e906..4f62bbd3e9 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -27,13 +27,13 @@ import Data.Maybe import qualified Data.Map as M #if __GLASGOW_HASKELL__ < 710 +import Data.Monoid import Control.Applicative #endif +import Control.Arrow (second) import Control.Monad.State -import Control.Monad.Unify -import Control.Monad.Writer.Strict import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Trans.Except +import Control.Monad.Writer.Class (MonadWriter(..), listen, censor) import Language.PureScript.Environment import Language.PureScript.Errors @@ -42,9 +42,36 @@ import Language.PureScript.Names import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types --- | --- Temporarily bind a collection of names to values --- +-- | A substitution of unification variables for types or kinds +data Substitution = Substitution + { substType :: M.Map Int Type -- ^ Type substitution + , substKind :: M.Map Int Kind -- ^ Kind substitution + } + +-- | An empty substitution +emptySubstitution :: Substitution +emptySubstitution = Substitution M.empty M.empty + +-- | State required for type checking +data CheckState = CheckState + { checkEnv :: Environment -- ^ The current @Environment@ + , checkNextType :: Int -- ^ The next type unification variable + , checkNextKind :: Int -- ^ The next kind unification variable + , checkNextSkolem :: Int -- ^ The next skolem variable + , checkNextSkolemScope :: Int -- ^ The next skolem scope constant + , checkNextDictName :: Int -- ^ The next type class dictionary name + , checkCurrentModule :: Maybe ModuleName -- ^ The current module + , checkSubstitution :: Substitution -- ^ The current substitution + } + +-- | Create an empty @CheckState@ +emptyCheckState :: Environment -> CheckState +emptyCheckState env = CheckState env 0 0 0 0 0 Nothing emptySubstitution + +-- | Unification variables +type Unknown = Int + +-- | Temporarily bind a collection of names to values bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a bindNames newNames action = do orig <- get @@ -53,9 +80,7 @@ bindNames newNames action = do modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } } return a --- | --- Temporarily bind a collection of names to types --- +-- | Temporarily bind a collection of names to types bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a bindTypes newNames action = do orig <- get @@ -64,15 +89,11 @@ bindTypes newNames action = do modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } } return a --- | --- Temporarily bind a collection of names to types --- +-- | Temporarily bind a collection of names to types withScopedTypeVars :: (Functor m, MonadState CheckState m) => ModuleName -> [(String, Kind)] -> m a -> m a withScopedTypeVars mn ks = bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) --- | --- Temporarily make a collection of type class dictionaries available --- +-- | Temporarily make a collection of type class dictionaries available withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a withTypeClassDictionaries entries action = do orig <- get @@ -82,35 +103,30 @@ withTypeClassDictionaries entries action = do modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } } return a --- | --- Get the currently available map of type class dictionaries --- -getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))) +-- | Get the currently available map of type class dictionaries +getTypeClassDictionaries :: + (Functor m, MonadState CheckState m) => + m (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))) getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get --- | --- Lookup type class dictionaries in a module. --- -lookupTypeClassDictionaries :: (Functor m, MonadState CheckState m) => Maybe ModuleName -> m (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) +-- | Lookup type class dictionaries in a module. +lookupTypeClassDictionaries :: + (Functor m, MonadState CheckState m) => + Maybe ModuleName -> + m (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get --- | --- Temporarily bind a collection of names to local variables --- +-- | Temporarily bind a collection of names to local variables bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a bindLocalVariables moduleName bindings = bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility))) --- | --- Temporarily bind a collection of names to local type variables --- +-- | Temporarily bind a collection of names to local type variables bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a bindLocalTypeVariables moduleName bindings = bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable))) --- | --- Update the visibility of all names to Defined --- +-- | Update the visibility of all names to Defined makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m () makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) } @@ -126,9 +142,7 @@ preservingNames action = do modifyEnv $ \e -> e { names = orig } return a --- | --- Lookup the type of a value by name in the @Environment@ --- +-- | Lookup the type of a value by name in the @Environment@ lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type lookupVariable currentModule (Qualified moduleName var) = do env <- getEnv @@ -136,9 +150,7 @@ lookupVariable currentModule (Qualified moduleName var) = do Nothing -> throwError . errorMessage $ NameIsUndefined var Just (ty, _, _) -> return ty --- | --- Lookup the visibility of a value by name in the @Environment@ --- +-- | Lookup the visibility of a value by name in the @Environment@ getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility getVisibility currentModule (Qualified moduleName var) = do env <- getEnv @@ -146,9 +158,7 @@ getVisibility currentModule (Qualified moduleName var) = do Nothing -> throwError . errorMessage $ NameIsUndefined var Just (_, _, vis) -> return vis --- | --- Assert that a name is visible --- +-- | Assert that a name is visible checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m () checkVisibility currentModule name@(Qualified _ var) = do vis <- getVisibility currentModule name @@ -156,9 +166,7 @@ checkVisibility currentModule name@(Qualified _ var) = do Undefined -> throwError . errorMessage $ CycleInDeclaration var _ -> return () --- | --- Lookup the kind of a type by name in the @Environment@ --- +-- | Lookup the kind of a type by name in the @Environment@ lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind lookupTypeVariable currentModule (Qualified moduleName name) = do env <- getEnv @@ -166,113 +174,56 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do Nothing -> throwError . errorMessage $ UndefinedTypeVariable name Just (k, _) -> return k --- | --- State required for type checking: --- -data CheckState = CheckState { - -- | - -- The current @Environment@ - -- - checkEnv :: Environment - -- | - -- The next fresh unification variable name - -- - , checkNextVar :: Int - -- | - -- The next type class dictionary name - -- - , checkNextDictName :: Int - -- | - -- The current module - -- - , checkCurrentModule :: Maybe ModuleName - } - --- | --- The type checking monad, which provides the state of the type checker, and error reporting capabilities --- -newtype Check a = Check { unCheck :: StateT CheckState (ExceptT MultipleErrors (Writer MultipleErrors)) a } - deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError MultipleErrors, MonadWriter MultipleErrors) - --- | --- Get the current @Environment@ --- +-- | Get the current @Environment@ getEnv :: (Functor m, MonadState CheckState m) => m Environment getEnv = checkEnv <$> get --- | --- Update the @Environment@ --- +-- | Update the @Environment@ putEnv :: (MonadState CheckState m) => Environment -> m () putEnv env = modify (\s -> s { checkEnv = env }) --- | --- Modify the @Environment@ --- +-- | Modify the @Environment@ modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m () modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) }) --- | --- Run a computation in the Check monad, starting with an empty @Environment@ --- -runCheck :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Check a -> m (a, Environment) +-- | Run a computation in the typechecking monad, starting with an empty @Environment@ +runCheck :: (Functor m) => StateT CheckState m a -> m (a, Environment) runCheck = runCheck' initEnvironment --- | --- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@. --- -runCheck' :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Environment -> Check a -> m (a, Environment) -runCheck' env = interpretMultipleErrorsAndWarnings . unwrapCheckWithWarnings env - where - unwrapCheckWithWarnings :: Environment -> Check a -> (Either MultipleErrors (a, Environment), MultipleErrors) - unwrapCheckWithWarnings e = - (\(rc, w) -> (envCheck rc, w)) - . runWriter - . runExceptT - . flip runStateT (CheckState e 0 0 Nothing) - . unCheck - envCheck :: Either MultipleErrors (a, CheckState) -> Either MultipleErrors (a, Environment) - envCheck rc = do - (a, s) <- rc - return (a, checkEnv s) +-- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@. +runCheck' :: (Functor m) => Environment -> StateT CheckState m a -> m (a, Environment) +runCheck' env check = fmap (second checkEnv) $ runStateT check (emptyCheckState env) --- | --- Make an assertion, failing with an error message --- +-- | Make an assertion, failing with an error message guardWith :: (MonadError e m) => e -> Bool -> m () guardWith _ True = return () guardWith e False = throwError e --- | --- Generate new type class dictionary name --- -freshDictionaryName :: Check Int +-- | Generate new type class dictionary name +freshDictionaryName :: (Functor m, MonadState CheckState m) => m Int freshDictionaryName = do n <- checkNextDictName <$> get modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) } return n --- | --- Lift a computation in the @Check@ monad into the substitution monad. --- -liftCheck :: Check a -> UnifyT t Check a -liftCheck = UnifyT . lift - --- | --- Run a computation in the substitution monad, generating a return value and the final substitution. --- -liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t) +-- | Run a computation in the substitution monad, generating a return value and the final substitution. +liftUnify :: + (MonadState CheckState m, MonadWriter MultipleErrors m) => + m a -> + m (a, Substitution) liftUnify = liftUnifyWarnings (const id) --- | --- Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values. --- -liftUnifyWarnings :: (Partial t) => (Substitution t -> ErrorMessage -> ErrorMessage) -> UnifyT t Check a -> Check (a, Substitution t) -liftUnifyWarnings replace unify = do - st <- get - let ru = runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify - ((a, ust), w) <- censor (const mempty) . listen $ ru - modify $ \st' -> st' { checkNextVar = unifyNextVar ust } - let uust = unifyCurrentSubstitution ust - tell $ onErrorMessages (replace uust) w - return (a, uust) +-- | Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values. +liftUnifyWarnings :: + (MonadState CheckState m, MonadWriter MultipleErrors m) => + (Substitution -> ErrorMessage -> ErrorMessage) -> + m a -> + m (a, Substitution) +liftUnifyWarnings replace ma = do + orig <- get + modify $ \st -> st { checkSubstitution = emptySubstitution } + (a, w) <- censor (const mempty) . listen $ ma + subst <- gets checkSubstitution + tell . onErrorMessages (replace subst) $ w + modify $ \st -> st { checkSubstitution = checkSubstitution orig } + return (a, subst) diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs index 1b16e1018d..bf10f36ea8 100644 --- a/src/Language/PureScript/TypeChecker/Rows.hs +++ b/src/Language/PureScript/TypeChecker/Rows.hs @@ -13,38 +13,44 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} + module Language.PureScript.TypeChecker.Rows ( checkDuplicateLabels ) where import Data.List +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State.Class (MonadState(..)) import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types --- | --- Ensure rows do not contain duplicate labels --- -checkDuplicateLabels :: Expr -> Check () +-- | Ensure rows do not contain duplicate labels +checkDuplicateLabels :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m () checkDuplicateLabels = let (_, f, _) = everywhereOnValuesM def go def in void . f where - def :: a -> Check a + def :: a -> m a def = return - go :: Expr -> Check Expr + go :: Expr -> m Expr go e@(TypedValue _ val ty) = do checkDups ty return e where - checkDups :: Type -> Check () + checkDups :: Type -> m () checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2 checkDups (ForAll _ t _) = checkDups t checkDups (ConstrainedType args t) = do diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index d1ab4c5cd2..f540e5302f 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -14,6 +14,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} module Language.PureScript.TypeChecker.Skolems ( newSkolemConstant, @@ -31,7 +32,7 @@ import Data.Monoid import Control.Applicative #endif import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Unify +import Control.Monad.State.Class (MonadState(..), gets, modify) import Language.PureScript.Crash import Language.PureScript.AST @@ -42,13 +43,16 @@ import Language.PureScript.Types -- | -- Generate a new skolem constant -- -newSkolemConstant :: UnifyT Type Check Int -newSkolemConstant = fresh' +newSkolemConstant :: (MonadState CheckState m) => m Int +newSkolemConstant = do + s <- gets checkNextSkolem + modify $ \st -> st { checkNextSkolem = s + 1 } + return s -- | -- Introduce skolem scope at every occurence of a ForAll -- -introduceSkolemScope :: Type -> UnifyT Type Check Type +introduceSkolemScope :: (Functor m, Applicative m, MonadState CheckState m) => Type -> m Type introduceSkolemScope = everywhereOnTypesM go where go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope) @@ -57,8 +61,11 @@ introduceSkolemScope = everywhereOnTypesM go -- | -- Generate a new skolem scope -- -newSkolemScope :: UnifyT Type Check SkolemScope -newSkolemScope = SkolemScope <$> fresh' +newSkolemScope :: (MonadState CheckState m) => m SkolemScope +newSkolemScope = do + s <- gets checkNextSkolemScope + modify $ \st -> st { checkNextSkolemScope = s + 1 } + return $ SkolemScope s -- | -- Skolemize a type variable by replacing its instances with fresh skolem constants @@ -86,7 +93,7 @@ skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id on -- | -- Ensure skolem variables do not escape their scope -- -skolemEscapeCheck :: Expr -> Check () +skolemEscapeCheck :: (MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m () skolemEscapeCheck (TypedValue False _ _) = return () skolemEscapeCheck root@TypedValue{} = -- Every skolem variable is created when a ForAll type is skolemized. diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 9acf9b6a0e..7e4d9afb78 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -13,6 +13,9 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} + module Language.PureScript.TypeChecker.Subsumption ( subsumes ) where @@ -20,8 +23,11 @@ module Language.PureScript.TypeChecker.Subsumption ( import Data.List (sortBy) import Data.Ord (comparing) -import Control.Monad.Unify -import Control.Monad.Error.Class (throwError) +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State.Class (MonadState(..)) import Language.PureScript.Crash import Language.PureScript.AST @@ -32,16 +38,16 @@ import Language.PureScript.TypeChecker.Skolems import Language.PureScript.TypeChecker.Unify import Language.PureScript.Types --- | --- Check whether one type subsumes another, rethrowing errors to provide a better error message --- -subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr) +-- | Check that one type subsumes another, rethrowing errors to provide a better error message +subsumes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr) subsumes val ty1 ty2 = rethrow (addHint (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2 --- | --- Check whether one type subsumes another --- -subsumes' :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr) +-- | Check tahat one type subsumes another +subsumes' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => + Maybe Expr -> + Type -> + Type -> + m (Maybe Expr) subsumes' val (ForAll ident ty1 _) ty2 = do replaced <- replaceVarWithUnknown ident ty1 subsumes val replaced ty2 @@ -72,25 +78,25 @@ subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject go ts1' ts2' r1' r2' return val where - go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2') - go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1') + go [] ts2 r1' r2' = unifyTypes r1' (rowFromList (ts2, r2')) + go ts1 [] r1' r2' = unifyTypes r2' (rowFromList (ts1, r1')) go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2' | p1 == p2 = do _ <- subsumes Nothing ty1 ty2 go ts1 ts2 r1' r2' - | p1 < p2 = do rest <- fresh + | p1 < p2 = do rest <- freshType -- What happens next is a bit of a hack. -- TODO: in the new type checker, object properties will probably be restricted to being monotypes -- in which case, this branch of the subsumes function should not even be necessary. case r2' of REmpty -> throwError . errorMessage $ AdditionalProperty p1 - _ -> r2' =?= RCons p1 ty1 rest + _ -> unifyTypes r2' (RCons p1 ty1 rest) go ts1 ((p2, ty2) : ts2) r1' rest - | otherwise = do rest <- fresh + | otherwise = do rest <- freshType case r1' of REmpty -> throwError . errorMessage $ PropertyIsMissing p2 - _ -> r1' =?= RCons p2 ty2 rest + _ -> unifyTypes r1' (RCons p2 ty2 rest) go ((p1, ty1) : ts1) ts2 rest r2' subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1 subsumes' val ty1 ty2 = do - ty1 =?= ty2 + unifyTypes ty1 ty2 return val diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index fc8b61694a..60bab48c4a 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -14,6 +14,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} @@ -47,10 +48,9 @@ import qualified Data.Map as M import Control.Applicative #endif import Control.Monad -import Control.Monad.State -import Control.Monad.Unify +import Control.Monad.State.Class (MonadState(..), gets) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (tell) +import Control.Monad.Writer.Class (MonadWriter(..)) import Language.PureScript.Crash import Language.PureScript.AST @@ -70,11 +70,13 @@ import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types --- | --- Infer the types of multiple mutually-recursive values, and return elaborated values including +-- | Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. --- -typesOf :: ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))] +typesOf :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + [(Ident, Expr)] -> + m [(Ident, (Expr, Type))] typesOf moduleName vals = do tys <- fmap tidyUp . liftUnifyWarnings replace $ do (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals @@ -92,17 +94,21 @@ typesOf moduleName vals = do return (ident, (val', varIfUnknown ty)) where -- 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 + tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (substituteType sub) val, substituteType sub ty))) ts -- Replace all the wildcards types with their inferred types - replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty) - replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (sub $? ty)) + replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints . WildcardInferredType $ substituteType sub ty + replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (substituteType sub ty)) replace _ em = em type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) type UntypedData = [(Ident, Type)] -typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData) +typeDictionaryForBindingGroup :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + [(Ident, Expr)] -> + m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData) typeDictionaryForBindingGroup moduleName vals = do let -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed @@ -114,7 +120,7 @@ typeDictionaryForBindingGroup moduleName vals = do typedDict = map (\(ident, (_, ty, _)) -> (ident, ty)) typed -- Create fresh unification variables for the types of untyped declarations - untypedNames <- replicateM (length untyped) fresh + untypedNames <- replicateM (length untyped) freshType let -- Make a map of names to the unification variables of untyped declarations @@ -123,12 +129,17 @@ typeDictionaryForBindingGroup moduleName vals = do dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict) return (untyped, typed, dict, untypedDict) -checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> UnifyT Type Check (Ident, (Expr, Type)) +checkTypedBindingGroupElement :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + (Ident, (Expr, Type, Bool)) -> + TypeData -> + m (Ident, (Expr, Type)) checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do -- Replace type wildcards ty' <- replaceTypeWildcards ty -- Kind check - (kind, args) <- liftCheck $ kindOfWithScopedVars ty + (kind, args) <- kindOfWithScopedVars ty checkTypeKind ty kind -- Check the type with the new names in scope ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty' @@ -137,17 +148,21 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do else return (TypedValue False val' ty'') return (ident, (val'', ty'')) -typeForBindingGroupElement :: Bool -> (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type)) +typeForBindingGroupElement :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Bool -> + (Ident, Expr) -> + TypeData -> + UntypedData -> + m (Ident, (Expr, Type)) typeForBindingGroupElement warn (ident, val) dict untypedDict = do -- Infer the type with the new names in scope TypedValue _ val' ty <- bindNames dict $ infer val - ty =?= fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict) + unifyTypes ty $ fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict) when warn . tell . errorMessage $ MissingTypeDeclaration ident ty return (ident, (TypedValue True val' ty, ty)) --- | --- Check if a value contains a type annotation --- +-- | Check if a value contains a type annotation isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool)) isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType)) isTyped (name, value) = Left (name, value) @@ -163,10 +178,12 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' g (TypeClassDictionary (nm, tys) sco) = TypeClassDictionary (nm, map f tys) sco g other = other --- | --- Replace type class dictionary placeholders with inferred type class dictionaries --- -replaceTypeClassDictionaries :: ModuleName -> Expr -> Check Expr +-- | Replace type class dictionary placeholders with inferred type class dictionaries +replaceTypeClassDictionaries :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + Expr -> + m Expr replaceTypeClassDictionaries mn = let (_, f, _) = everywhereOnValuesTopDownM return go return in f @@ -174,20 +191,24 @@ replaceTypeClassDictionaries mn = go (TypeClassDictionary constraint dicts) = entails mn dicts constraint go other = return other --- | --- Check the kind of a type, failing if it is not of kind *. --- -checkTypeKind :: Type -> Kind -> UnifyT t Check () +-- | Check the kind of a type, failing if it is not of kind *. +checkTypeKind :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) => + Type -> + Kind -> + m () checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star --- | --- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns +-- | Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns -- or TypeClassDictionary values. -- -- This is necessary during type checking to avoid unifying a polymorphic type with a -- unification variable. --- -instantiatePolyTypeWithUnknowns :: Expr -> Type -> UnifyT Type Check (Expr, Type) +instantiatePolyTypeWithUnknowns :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) => + Expr -> + Type -> + m (Expr, Type) instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do ty' <- replaceVarWithUnknown ident ty instantiatePolyTypeWithUnknowns val ty' @@ -197,16 +218,18 @@ instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty') instantiatePolyTypeWithUnknowns val ty = return (val, ty) --- | --- Infer a type for a value, rethrowing any error to provide a more useful error message --- -infer :: Expr -> UnifyT Type Check Expr +-- | Infer a type for a value, rethrowing any error to provide a more useful error message +infer :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Expr -> + m Expr infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val --- | --- Infer a type for a value --- -infer' :: Expr -> UnifyT Type Check Expr +-- | Infer a type for a value +infer' :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Expr -> + m Expr infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt infer' v@(NumericLiteral (Right _)) = return $ TypedValue True v tyNumber infer' v@(StringLiteral _) = return $ TypedValue True v tyString @@ -214,8 +237,8 @@ infer' v@(CharLiteral _) = return $ TypedValue True v tyChar infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean infer' (ArrayLiteral vals) = do ts <- mapM infer vals - els <- fresh - forM_ ts $ \(TypedValue _ _ t) -> els =?= t + els <- freshType + forM_ ts $ \(TypedValue _ _ t) -> unifyTypes els t return $ TypedValue True (ArrayLiteral ts) (TypeApp tyArray els) infer' (ObjectLiteral ps) = do ensureNoDuplicateProperties ps @@ -225,20 +248,20 @@ infer' (ObjectLiteral ps) = do return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty infer' (ObjectUpdate o ps) = do ensureNoDuplicateProperties ps - row <- fresh + row <- freshType 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 + oldTys <- zip (map fst ps) <$> replicateM (length ps) freshType let oldTy = TypeApp tyObject $ rowFromList (oldTys, row) o' <- TypedValue True <$> check o oldTy <*> pure oldTy return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row) infer' (Accessor prop val) = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do - field <- fresh - rest <- fresh + field <- freshType + rest <- freshType typed <- check val (TypeApp tyObject (RCons prop field rest)) return $ TypedValue True (Accessor prop typed) field infer' (Abs (Left arg) ret) = do - ty <- fresh + ty <- freshType Just moduleName <- checkCurrentModule <$> get withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do body@(TypedValue _ _ bodyTy) <- infer' ret @@ -265,7 +288,7 @@ infer' v@(Constructor c) = do return $ TypedValue True v' ty' infer' (Case vals binders) = do (vals', ts) <- instantiateForBinders vals binders - ret <- fresh + ret <- freshType binders' <- checkBinders ts ret binders return $ TypedValue True (Case vals' binders') ret infer' (IfThenElse cond th el) = do @@ -282,7 +305,7 @@ infer' (SuperClassDictionary className tys) = do return $ TypeClassDictionary (className, tys) dicts infer' (TypedValue checkType val ty) = do Just moduleName <- checkCurrentModule <$> get - (kind, args) <- liftCheck $ kindOfWithScopedVars ty + (kind, args) <- kindOfWithScopedVars ty checkTypeKind ty kind ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val @@ -290,22 +313,28 @@ infer' (TypedValue checkType val ty) = do infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val infer' _ = internalError "Invalid argument to infer" -inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr) +inferLetBinding :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + [Declaration] -> + [Declaration] -> + Expr -> + (Expr -> m Expr) -> + m ([Declaration], Expr) inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do Just moduleName <- checkCurrentModule <$> get - (kind, args) <- liftCheck $ kindOfWithScopedVars ty + (kind, args) <- kindOfWithScopedVars ty checkTypeKind ty kind let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined) ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do - valTy <- fresh + valTy <- freshType Just moduleName <- checkCurrentModule <$> get let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined) TypedValue _ val' valTy' <- bindNames dict $ infer val - valTy =?= valTy' + unifyTypes valTy valTy' bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do Just moduleName <- checkCurrentModule <$> get @@ -321,16 +350,18 @@ inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethr return (PositionedDeclaration pos com d' : ds', val') inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding" --- | --- Infer the types of variables brought into scope by a binder --- -inferBinder :: Type -> Binder -> UnifyT Type Check (M.Map Ident Type) +-- | Infer the types of variables brought into scope by a binder +inferBinder :: forall m. + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Type -> + Binder -> + m (M.Map Ident Type) inferBinder _ NullBinder = return M.empty -inferBinder val (StringBinder _) = val =?= tyString >> return M.empty -inferBinder val (CharBinder _) = val =?= tyChar >> return M.empty -inferBinder val (NumberBinder (Left _)) = val =?= tyInt >> return M.empty -inferBinder val (NumberBinder (Right _)) = val =?= tyNumber >> return M.empty -inferBinder val (BooleanBinder _) = val =?= tyBoolean >> return M.empty +inferBinder val (StringBinder _) = unifyTypes val tyString >> return M.empty +inferBinder val (CharBinder _) = unifyTypes val tyChar >> return M.empty +inferBinder val (NumberBinder (Left _)) = unifyTypes val tyInt >> return M.empty +inferBinder val (NumberBinder (Right _)) = unifyTypes val tyNumber >> return M.empty +inferBinder val (BooleanBinder _) = unifyTypes val tyBoolean >> return M.empty inferBinder val (VarBinder name) = return $ M.singleton name val inferBinder val (ConstructorBinder ctor binders) = do env <- getEnv @@ -340,7 +371,7 @@ inferBinder val (ConstructorBinder ctor binders) = do fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn let (args, ret) = peelArgs fn' unless (length args == length binders) . throwError . errorMessage $ IncorrectConstructorArity ctor - ret =?= val + unifyTypes ret val M.unions <$> zipWithM inferBinder (reverse args) binders _ -> throwError . errorMessage $ UnknownDataConstructor ctor Nothing where @@ -350,23 +381,23 @@ inferBinder val (ConstructorBinder ctor binders) = do go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret go args ret = (args, ret) inferBinder val (ObjectBinder props) = do - row <- fresh - rest <- fresh + row <- freshType + rest <- freshType m1 <- inferRowProperties row rest props - val =?= TypeApp tyObject row + unifyTypes val (TypeApp tyObject row) return m1 where - inferRowProperties :: Type -> Type -> [(String, Binder)] -> UnifyT Type Check (M.Map Ident Type) - inferRowProperties nrow row [] = nrow =?= row >> return M.empty + inferRowProperties :: Type -> Type -> [(String, Binder)] -> m (M.Map Ident Type) + inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty inferRowProperties nrow row ((name, binder):binders) = do - propTy <- fresh + propTy <- freshType m1 <- inferBinder propTy binder m2 <- inferRowProperties nrow (RCons name propTy row) binders return $ m1 `M.union` m2 inferBinder val (ArrayBinder binders) = do - el <- fresh + el <- freshType m1 <- M.unions <$> mapM (inferBinder el) binders - val =?= TypeApp tyArray el + unifyTypes val (TypeApp tyArray el) return m1 inferBinder val (NamedBinder name binder) = do m <- inferBinder val binder @@ -378,9 +409,9 @@ inferBinder val (PositionedBinder pos _ binder) = -- and use `kindOfWithScopedVars`. inferBinder val (TypedBinder ty binder) = do ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty - kind <- liftCheck $ kindOf ty1 + kind <- kindOf ty1 checkTypeKind ty1 kind - val =?= ty1 + unifyTypes val ty1 inferBinder val binder -- | Returns true if a binder requires its argument type to be a monotype. @@ -393,7 +424,11 @@ binderRequiresMonotype (PositionedBinder _ _ b) = binderRequiresMonotype b binderRequiresMonotype _ = True -- | Instantiate polytypes only when necessitated by a binder. -instantiateForBinders :: [Expr] -> [CaseAlternative] -> UnifyT Type Check ([Expr], [Type]) +instantiateForBinders :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + [Expr] -> + [CaseAlternative] -> + m ([Expr], [Type]) instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do TypedValue _ val' ty <- infer val if inst @@ -406,7 +441,12 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do -- | -- Check the types of the return values in a set of binders in a case statement -- -checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative] +checkBinders :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + [Type] -> + Type -> + [CaseAlternative] -> + m [CaseAlternative] checkBinders _ _ [] = return [] checkBinders nvals ret (CaseAlternative binders result : bs) = do guardWith (errorMessage $ OverlappingArgNames Nothing) $ @@ -431,13 +471,21 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do -- | -- Check the type of a value, rethrowing errors to provide a better error message -- -check :: Expr -> Type -> UnifyT Type Check Expr +check :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Expr -> + Type -> + m Expr check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty -- | -- Check the type of a value -- -check' :: Expr -> Type -> UnifyT Type Check Expr +check' :: forall m. + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Expr -> + Type -> + m Expr check' val (ForAll ident ty _) = do scope <- newSkolemScope sko <- newSkolemConstant @@ -447,15 +495,15 @@ check' val (ForAll ident ty _) = do return $ TypedValue True val' (ForAll ident ty (Just scope)) check' val t@(ConstrainedType constraints ty) = do dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do - n <- liftCheck freshDictionaryName + n <- freshDictionaryName return $ Ident $ "__dict_" ++ className ++ "_" ++ show n - dicts <- join <$> liftCheck (zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints) + dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty return $ TypedValue True (foldr (Abs . Left) val' dictNames) t where -- | Add a dictionary for the constraint to the scope, and dictionaries - -- for all implies superclass instances. - newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> Check [TypeClassDictionaryInScope] + -- for all implied superclass instances. + newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> m [TypeClassDictionaryInScope] newDictionaries path name (className, instanceTy) = do tcs <- gets (typeClasses . checkEnv) let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs @@ -472,7 +520,7 @@ check' val u@(TUnknown _) = do val'@(TypedValue _ _ ty) <- infer val -- Don't unify an unknown with an inferred polytype (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty - ty' =?= u + unifyTypes ty' u return $ TypedValue True val'' ty' check' v@(NumericLiteral (Left _)) t | t == tyInt = return $ TypedValue True v t @@ -485,11 +533,11 @@ check' v@(CharLiteral _) t | t == tyChar = check' v@(BooleanLiteral _) t | t == tyBoolean = return $ TypedValue True v t check' (ArrayLiteral vals) t@(TypeApp a ty) = do - a =?= tyArray + unifyTypes a tyArray array <- ArrayLiteral <$> forM vals (`check` ty) return $ TypedValue True array t check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do - t =?= tyFunction + unifyTypes t tyFunction Just moduleName <- checkCurrentModule <$> get ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy return $ TypedValue True (Abs (Left arg) ret') ty @@ -518,7 +566,7 @@ check' (SuperClassDictionary className tys) _ = do return $ TypeClassDictionary (className, tys) dicts check' (TypedValue checkType val ty1) ty2 = do Just moduleName <- checkCurrentModule <$> get - (kind, args) <- liftCheck $ kindOfWithScopedVars ty1 + (kind, args) <- kindOfWithScopedVars ty1 checkTypeKind ty1 kind ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2 @@ -550,12 +598,12 @@ check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns. let (propsToCheck, rest) = rowToList row (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck - us <- zip (map fst removedProps) <$> replicateM (length ps) fresh + us <- zip (map fst removedProps) <$> replicateM (length ps) freshType obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest))) ps' <- checkProperties e ps row True return $ TypedValue True (ObjectUpdate obj' ps') t check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do - rest <- fresh + rest <- freshType val' <- check val (TypeApp tyObject (RCons prop ty rest)) return $ TypedValue True (Accessor prop val') ty check' v@(Constructor c) ty = do @@ -589,12 +637,18 @@ check' val ty = do -- -- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case. -- -checkProperties :: Expr -> [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)] +checkProperties :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Expr -> + [(String, Expr)] -> + Type -> + Bool -> + m [(String, Expr)] checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where go [] [] REmpty = return [] go [] [] u@(TUnknown _) | lax = return [] - | otherwise = do u =?= REmpty + | otherwise = do unifyTypes u REmpty return [] go [] [] Skolem{} | lax = return [] go [] ((p, _): _) _ | lax = return [] @@ -604,8 +658,8 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh case lookup p ts of Nothing -> do v'@(TypedValue _ _ ty) <- infer v - rest <- fresh - r =?= RCons p ty rest + rest <- freshType + unifyTypes r (RCons p ty rest) ps'' <- go ps' ts rest return $ (p, v') : ps'' Just ty -> do @@ -614,20 +668,28 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh return $ (p, v') : ps'' go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyObject row) --- | --- Check the type of a function application, rethrowing errors to provide a better error message --- -checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr) +-- | Check the type of a function application, rethrowing errors to provide a better error message +checkFunctionApplication :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Expr -> + Type -> + Expr -> + Maybe Type -> + m (Type, Expr) checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication fn fnTy arg)) $ do - subst <- unifyCurrentSubstitution <$> UnifyT get - checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret) - --- | --- Check the type of a function application --- -checkFunctionApplication' :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr) + subst <- gets checkSubstitution + checkFunctionApplication' fn (substituteType subst fnTy) arg (substituteType subst <$> ret) + +-- | Check the type of a function application +checkFunctionApplication' :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Expr -> + Type -> + Expr -> + Maybe Type -> + m (Type, Expr) checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do - tyFunction' =?= tyFunction + unifyTypes tyFunction' tyFunction arg' <- check arg argTy case ret of Nothing -> return (retTy, App fn arg') @@ -643,8 +705,8 @@ checkFunctionApplication' fn u@(TUnknown _) arg ret = do (arg'', t') <- instantiatePolyTypeWithUnknowns arg' t return $ TypedValue True arg'' t' let ty = (\(TypedValue _ _ t) -> t) arg' - ret' <- maybe fresh return ret - u =?= function ty ret' + ret' <- maybe freshType return ret + unifyTypes u (function ty ret') return (ret', App fn arg') checkFunctionApplication' fn (KindedType ty _) arg ret = checkFunctionApplication fn ty arg ret @@ -655,11 +717,15 @@ checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ = return (fnTy, App fn dict) checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg --- | --- Compute the meet of two types, i.e. the most general type which both types subsume. --- TODO: handle constrained types --- -meet :: Expr -> Expr -> Type -> Type -> UnifyT Type Check (Expr, Expr, Type) +-- | Compute the meet of two types, i.e. the most general type which both types subsume. +-- TODO: is this really needed? +meet :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) => + Expr -> + Expr -> + Type -> + Type -> + m (Expr, Expr, Type) meet e1 e2 (ForAll ident t1 _) t2 = do t1' <- replaceVarWithUnknown ident t1 meet e1 e2 t1' t2 @@ -667,7 +733,7 @@ meet e1 e2 t1 (ForAll ident t2 _) = do t2' <- replaceVarWithUnknown ident t2 meet e1 e2 t1 t2' meet e1 e2 t1 t2 = do - t1 =?= t2 + unifyTypes t1 t2 return (e1, e2, t1) -- | diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 4ffe2b63e2..241c52e599 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -13,12 +13,16 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} module Language.PureScript.TypeChecker.Unify ( + freshType, + solveType, + substituteType, unifyTypes, unifyRows, unifiesWith, @@ -28,13 +32,15 @@ module Language.PureScript.TypeChecker.Unify ( ) where import Data.List (nub, sort) -import Data.Maybe (fromMaybe) -import qualified Data.HashMap.Strict as H +import qualified Data.Map as M +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif import Control.Monad -import Control.Monad.Unify -import Control.Monad.Writer import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.State.Class (MonadState(..), gets, modify) import Language.PureScript.Crash import Language.PureScript.Errors @@ -42,32 +48,59 @@ import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Skolems import Language.PureScript.Types -instance Partial Type where - unknown = TUnknown - isUnknown (TUnknown u) = Just u - isUnknown _ = Nothing - unknowns = everythingOnTypes (++) go - where - go (TUnknown u) = [u] - go _ = [] - ($?) sub = everywhereOnTypes go - where - go t@(TUnknown u) = fromMaybe t $ H.lookup u (runSubstitution sub) - go other = other - -instance Unifiable Check Type where - (=?=) = unifyTypes +-- | Generate a fresh type variable +freshType :: (MonadState CheckState m) => m Type +freshType = do + t <- gets checkNextType + modify $ \st -> st { checkNextType = t + 1 } + return $ TUnknown t --- | --- Unify two types, updating the current substitution --- -unifyTypes :: Type -> Type -> UnifyT Type Check () -unifyTypes t1 t2 = rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ - unifyTypes' t1 t2 +-- | Update the substitution to solve a type constraint +solveType :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Type -> m () +solveType u t = do + occursCheck u t + modify $ \cs -> cs { checkSubstitution = + (checkSubstitution cs) { substType = + M.insert u t $ substType $ checkSubstitution cs + } + } + +-- | Apply a substitution to a type +substituteType :: Substitution -> Type -> Type +substituteType sub = everywhereOnTypes go + where + go (TUnknown u) = + case M.lookup u (substType sub) of + Nothing -> TUnknown u + Just (TUnknown u1) | u1 == u -> TUnknown u1 + Just t -> substituteType sub t + go other = other + +-- | Make sure that an unknown does not occur in a type +occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Type -> m () +occursCheck _ TUnknown{} = return () +occursCheck u t = void $ everywhereOnTypesM go t + where + go (TUnknown u') | u == u' = throwError . errorMessage . InfiniteType $ t + go other = return other + +-- | Compute a list of all unknowns appearing in a type +unknownsInType :: Type -> [Int] +unknownsInType t = everythingOnTypes (.) go t [] + where + go :: Type -> [Int] -> [Int] + go (TUnknown u) = (u :) + go _ = id + +-- | Unify two types, updating the current substitution +unifyTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m () +unifyTypes t1 t2 = do + sub <- gets checkSubstitution + rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ unifyTypes' (substituteType sub t1) (substituteType sub t2) where unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return () - unifyTypes' (TUnknown u) t = u =:= t - unifyTypes' t (TUnknown u) = u =:= t + unifyTypes' (TUnknown u) t = solveType u t + unifyTypes' t (TUnknown u) = solveType u t unifyTypes' (ForAll ident1 ty1 sc1) (ForAll ident2 ty2 sc2) = case (sc1, sc2) of (Just sc1', Just sc2') -> do @@ -106,7 +139,7 @@ unifyTypes t1 t2 = rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ -- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification -- error. -- -unifyRows :: Type -> Type -> UnifyT Type Check () +unifyRows :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m () unifyRows r1 r2 = let (s1, r1') = rowToList r1 @@ -115,18 +148,18 @@ unifyRows r1 r2 = sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] in do - forM_ int (uncurry (=?=)) + forM_ int (uncurry unifyTypes) unifyRows' sd1 r1' sd2 r2' where - unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> UnifyT Type Check () - unifyRows' [] (TUnknown u) sd r = u =:= rowFromList (sd, r) - unifyRows' sd r [] (TUnknown u) = u =:= rowFromList (sd, r) + unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> m () + unifyRows' [] (TUnknown u) sd r = solveType u (rowFromList (sd, r)) + unifyRows' sd r [] (TUnknown u) = solveType u (rowFromList (sd, r)) unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do forM_ sd1 $ \(_, t) -> occursCheck u2 t forM_ sd2 $ \(_, t) -> occursCheck u1 t - rest <- fresh - u1 =:= rowFromList (sd2, rest) - u2 =:= rowFromList (sd1, rest) + rest <- freshType + solveType u1 (rowFromList (sd2, rest)) + solveType u2 (rowFromList (sd1, rest)) unifyRows' [] REmpty [] REmpty = return () unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return () unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return () @@ -164,21 +197,21 @@ unifiesWith _ _ = False -- | -- Replace a single type variable with a new unification variable -- -replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type +replaceVarWithUnknown :: (MonadState CheckState m) => String -> Type -> m Type replaceVarWithUnknown ident ty = do - tu <- fresh + tu <- freshType return $ replaceTypeVars ident tu ty -- | -- Replace type wildcards with unknowns -- -replaceTypeWildcards :: Type -> UnifyT t Check Type +replaceTypeWildcards :: (Functor m, Applicative m, MonadWriter MultipleErrors m, MonadState CheckState m) => Type -> m Type replaceTypeWildcards = everywhereOnTypesM replace where replace TypeWildcard = do - u <- fresh' - liftCheck . tell $ errorMessage . WildcardInferredType $ TUnknown u - return $ TUnknown u + t <- freshType + tell . errorMessage $ WildcardInferredType t + return t replace other = return other -- | @@ -186,7 +219,7 @@ replaceTypeWildcards = everywhereOnTypesM replace -- varIfUnknown :: Type -> Type varIfUnknown ty = - let unks = nub $ unknowns ty + let unks = nub $ unknownsInType ty toName = (:) 't' . show ty' = everywhereOnTypes typeToVar ty typeToVar :: Type -> Type diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index dec6641aa3..5f5cbca16b 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -26,7 +26,6 @@ import Data.Maybe (fromMaybe) import qualified Data.Aeson as A import qualified Data.Aeson.TH as A -import Control.Monad.Unify import Control.Arrow (second) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative @@ -49,7 +48,7 @@ data Type -- | -- A unification variable of type Type -- - = TUnknown Unknown + = TUnknown Int -- | -- A named type variable -- From de7b3dd39efa88298426a03d330d42ffecfb5c4a Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 2 Nov 2015 15:22:19 -0800 Subject: [PATCH 0113/1580] Bump semigroups dependency --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 09f90f15ed..ce97e68e80 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -68,7 +68,7 @@ library Glob >= 0.7 && < 0.8, process >= 1.2.0 && < 1.4, safe >= 0.3.9 && < 0.4, - semigroups >= 0.16.2 && < 0.18, + semigroups >= 0.16.2 && < 0.19, parallel >= 3.2 && < 3.3 exposed-modules: Language.PureScript From 5cc3031433473b948c6ee5169259b8886a1c032b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 2 Nov 2015 17:04:17 -0800 Subject: [PATCH 0114/1580] Field puns, fix #921 --- examples/passing/FieldPuns.purs | 8 ++++++++ src/Language/PureScript/Parser/Declarations.hs | 12 +++++++----- 2 files changed, 15 insertions(+), 5 deletions(-) create mode 100644 examples/passing/FieldPuns.purs diff --git a/examples/passing/FieldPuns.purs b/examples/passing/FieldPuns.purs new file mode 100644 index 0000000000..d30444aecf --- /dev/null +++ b/examples/passing/FieldPuns.purs @@ -0,0 +1,8 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console + +greet { greeting, name } = log $ greeting <> ", " <> name <> "." + +main = greet { greeting: "Hello", name: "World" } diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 682821d9bd..3a5be3be1f 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -517,11 +517,13 @@ parseNullBinder :: TokenParser Binder parseNullBinder = underscore *> return NullBinder parseIdentifierAndBinder :: TokenParser (String, Binder) -parseIdentifierAndBinder = do - name <- lname <|> stringLiteral - C.indented *> (equals <|> colon) - binder <- C.indented *> parseBinder - return (name, binder) +parseIdentifierAndBinder = + do name <- lname + b <- P.option (VarBinder (Ident name)) rest + return (name, b) + <|> (,) <$> stringLiteral <*> rest + where + rest = C.indented *> (equals <|> colon) *> C.indented *> parseBinder -- | -- Parse a binder From 621a5a78bb02731632166e9bbd156bd3c21412ba Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 4 Nov 2015 11:59:52 +0200 Subject: [PATCH 0115/1580] Use base-compat in tests --- purescript.cabal | 4 ++-- tests/Main.hs | 10 +++------- tests/common/TestsSetup.hs | 11 +++-------- 3 files changed, 8 insertions(+), 17 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index ce97e68e80..24fd3554b2 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -260,7 +260,7 @@ test-suite tests build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, mtl -any, parsec -any, purescript -any, transformers -any, process -any, transformers-compat -any, time -any, - Glob -any + Glob -any, base-compat >=0.6.0 type: exitcode-stdio-1.0 main-is: Main.hs other-modules: TestsSetup @@ -272,7 +272,7 @@ test-suite psci-tests mtl -any, optparse-applicative >= 0.10.0, parsec -any, haskeline >= 0.7.0.0, purescript -any, transformers -any, transformers-compat -any, process -any, HUnit -any, time -any, - Glob -any + Glob -any, base-compat >=0.6.0 type: exitcode-stdio-1.0 main-is: Main.hs other-modules: TestsSetup diff --git a/tests/Main.hs b/tests/Main.hs index eca712953d..999d8cc91d 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -16,7 +16,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} -- Failing tests can specify the kind of error that should be thrown with a -- @shouldFailWith declaration. For example: @@ -35,6 +34,9 @@ module Main (main) where +import Prelude () +import Prelude.Compat + import qualified Language.PureScript as P import qualified Language.PureScript.CodeGen.JS as J import qualified Language.PureScript.CoreFn as CF @@ -42,18 +44,12 @@ import qualified Language.PureScript.CoreFn as CF import Data.Char (isSpace) import Data.Maybe (mapMaybe, fromMaybe) import Data.List (isSuffixOf, sort, stripPrefix) -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable (traverse) -#endif import Data.Time.Clock (UTCTime()) import qualified Data.Map as M import Control.Monad import Control.Monad.IO.Class (liftIO) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Arrow ((>>>)) import Control.Monad.Reader diff --git a/tests/common/TestsSetup.hs b/tests/common/TestsSetup.hs index 2dc1458d99..1ec2cd1824 100644 --- a/tests/common/TestsSetup.hs +++ b/tests/common/TestsSetup.hs @@ -10,18 +10,13 @@ -- | -- ----------------------------------------------------------------------------- - -{-# LANGUAGE CPP #-} - module TestsSetup where -import Data.Maybe (fromMaybe) +import Prelude () +import Prelude.Compat -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif +import Data.Maybe (fromMaybe) import Control.Monad - import Control.Monad.Trans.Maybe import System.Process From 6572dbcda5a23cf06f20521790a91dcfffd44c86 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 4 Nov 2015 13:33:25 +0200 Subject: [PATCH 0116/1580] Add GHC 7.10.3 to build matrix --- .travis.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.travis.yml b/.travis.yml index a759b326ef..2bece9c0f5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -24,6 +24,9 @@ matrix: - env: GHCVER=7.10.2 STACKAGE=nightly-2015-09-29 compiler: ": #GHC 7.10.2 nightly-2015-09-29" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} + - env: GHCVER=7.10.3 + compiler: ": #GHC 7.10.3" + addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} before_install: - unset CC - export PATH="/opt/ghc/$GHCVER/bin:$PATH" From 8f7583efcb101ccf820a1634a9c994a49e88759b Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 4 Nov 2015 18:51:08 +0200 Subject: [PATCH 0117/1580] Write license-generator in Haskell --- CONTRIBUTING.md | 2 +- LICENSE | 125 +++++++++++++++++++++++++++++++++ license-generator/generate | 47 ------------- license-generator/generate.hs | 40 +++++++++++ license-generator/tmp/.gitkeep | 0 5 files changed, 166 insertions(+), 48 deletions(-) delete mode 100755 license-generator/generate create mode 100644 license-generator/generate.hs delete mode 100644 license-generator/tmp/.gitkeep diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 18ee4083e1..d47af73fd0 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -30,7 +30,7 @@ updated. You can automate this (if you have bash): - get a copy of [cabal-dependency-licenses][] -- run at the command line: `./license/generate > LICENSE` +- run at the command line: `runhaskell license-generator/generate.hs > LICENSE` [cabal-dependency-licenses]: https://github.com/jaspervdj/cabal-dependency-licenses diff --git a/LICENSE b/LICENSE index 4aed8f101f..00e252bec2 100644 --- a/LICENSE +++ b/LICENSE @@ -31,6 +31,7 @@ PureScript uses the following Haskell library packages. Their license files foll array attoparsec base + base-compat binary blaze-builder bower-json @@ -50,6 +51,7 @@ PureScript uses the following Haskell library packages. Their license files foll monad-control mtl nats + old-locale optparse-applicative parallel parsec @@ -64,6 +66,7 @@ PureScript uses the following Haskell library packages. Their license files foll split stm syb + tagged template-haskell terminfo text @@ -454,6 +457,28 @@ base LICENSE file: ----------------------------------------------------------------------------- +base-compat LICENSE file: + + Copyright (c) 2012-2015 Simon Hengel and Ryan Scott + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + THE SOFTWARE. + binary LICENSE file: Copyright (c) Lennart Kolmodin @@ -1136,6 +1161,72 @@ nats LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +old-locale LICENSE file: + + This library (libraries/base) is derived from code from two + sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + + The full text of these licenses is reproduced below. Both of the + licenses are BSD-style or compatible. + + ----------------------------------------------------------------------------- + + The Glasgow Haskell Compiler License + + Copyright 2004, The University Court of the University of Glasgow. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. + + ----------------------------------------------------------------------------- + + Code derived from the document "Report on the Programming Language + Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + + ----------------------------------------------------------------------------- + optparse-applicative LICENSE file: Copyright (c) 2012, Paolo Capriotti @@ -1648,6 +1739,39 @@ syb LICENSE file: ----------------------------------------------------------------------------- +tagged LICENSE file: + + Copyright (c) 2009-2015 Edward Kmett + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Edward Kmett nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + template-haskell LICENSE file: @@ -2008,3 +2132,4 @@ void LICENSE file: STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/license-generator/generate b/license-generator/generate deleted file mode 100755 index 3973f334aa..0000000000 --- a/license-generator/generate +++ /dev/null @@ -1,47 +0,0 @@ -#!/bin/bash -# Generates the LICENSE file and prints it to standard output. -# Example use: -# -# ./license/generate > LICENSE -# - -set -e # exit on error -set -u # exit on undefined variable -set -o pipefail # propagate nonzero exit codes through pipelines - -export LC_CTYPE=C -export LANG=C - -if ! which cabal-dependency-licenses >/dev/null; then - echo "$0: the program 'cabal-dependency-licenses' is required." >&2 - echo "$0: see Hackage: https://hackage.haskell.org/package/cabal-dependency-licenses" >&2 - exit 1 -fi - -echo_header() { - cat license-generator/header.txt -} - -echo_deps_names() { - cabal-dependency-licenses \ - | grep '^- ' | sed 's/^..//' | gsort -h -} - -echo_deps_licenses() { - while read dep; do - echo "fetching LICENSE for: ${dep}" >&2 - echo "${dep} LICENSE file:" - echo "" - curl --silent "https://hackage.haskell.org/package/${dep}/src/LICENSE" \ - | sed 's/^/ /g' # indent by 2 characters - echo "" - done -} - -echo_deps_names > license-generator/tmp/deps.txt - -echo_header -echo "" -sed >= putStr + +depsNames :: IO [String] +depsNames = do + i <- readProcess "cabal-dependency-licenses" [] "" + return $ sort $ map (drop 2) $ filter startsWithDash $ lines i + where + startsWithDash ('-' : _) = True + startsWithDash _ = False + +depsLicense :: String -> IO () +depsLicense dep = do + let licenseFile = if dep == "Glob" then "LICENSE.txt" else "LICENSE" + hPutStrLn stderr dep + license <- readProcess "curl" ["--silent", "https://hackage.haskell.org/package/" ++ dep ++ "/src/" ++ licenseFile] "" + putStrLn $ dep ++ " LICENSE file:" + putStrLn "" + putStrLn $ f license + where + f = unlines . map trimEnd . map (" " ++) . lines + trimEnd = reverse . dropWhile isSpace . reverse + +main :: IO () +main = do + deps <-depsNames + echoHeader + putStrLn "" + forM_ deps $ \d -> putStr " " >> putStrLn d + putStrLn "" + forM_ deps depsLicense diff --git a/license-generator/tmp/.gitkeep b/license-generator/tmp/.gitkeep deleted file mode 100644 index e69de29bb2..0000000000 From d1d281aa1f304222b2d84ec774e12d9321dfa05e Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 5 Nov 2015 06:46:59 +0200 Subject: [PATCH 0118/1580] Use base-compat in psci --- psci/Completion.hs | 11 +++-------- psci/PSCi.hs | 15 +++++++-------- psci/Parser.hs | 9 ++------- psci/tests/Main.hs | 7 +++---- purescript.cabal | 2 +- 5 files changed, 16 insertions(+), 28 deletions(-) diff --git a/psci/Completion.hs b/psci/Completion.hs index 3565275697..d09b9082d1 100644 --- a/psci/Completion.hs +++ b/psci/Completion.hs @@ -1,19 +1,14 @@ -{-# LANGUAGE CPP #-} - module Completion where +import Prelude () +import Prelude.Compat + import Data.Maybe (mapMaybe) import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix) import Data.Char (isUpper) import Data.Function (on) -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable (traverse) -#endif import Control.Arrow (second) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>)) -#endif import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) import Control.Monad.Trans.State.Strict diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 0912c04013..8a75c19f25 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -17,15 +17,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} module PSCi where +import Prelude () +import Prelude.Compat + import Data.Foldable (traverse_) import Data.List (intercalate, nub, sort) -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable (traverse) -#endif import Data.Tuple (swap) import Data.Version (showVersion) import qualified Data.Map as M @@ -507,7 +506,7 @@ loadUserConfig = onFirstFileMatching readCommands pathGetters if exists then do ls <- lines <$> readFile configFile - case mapM parseCommand ls of + case traverse parseCommand ls of Left err -> print err >> exitFailure Right cs -> return $ Just cs else @@ -524,8 +523,8 @@ consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", loop :: PSCiOptions -> IO () loop PSCiOptions{..} = do config <- loadUserConfig - inputFiles <- concat <$> mapM glob psciInputFile - foreignFiles <- concat <$> mapM glob psciForeignInputFiles + inputFiles <- concat <$> traverse glob psciInputFile + foreignFiles <- concat <$> traverse glob psciForeignInputFiles modulesOrFirstError <- loadAllModules inputFiles case modulesOrFirstError of Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure @@ -540,7 +539,7 @@ loop PSCiOptions{..} = do Right foreigns -> flip evalStateT (PSCiState inputFiles [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do outputStrLn prologueMessage - traverse_ (mapM_ (runPSCI . handleCommand)) config + traverse_ (traverse_ (runPSCI . handleCommand)) config modules' <- lift $ gets psciLoadedModules unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines [ "PSCi requires the purescript-console module to be installed." diff --git a/psci/Parser.hs b/psci/Parser.hs index d4a3a2d50c..cb00db16ed 100644 --- a/psci/Parser.hs +++ b/psci/Parser.hs @@ -13,21 +13,16 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Parser ( parseCommand ) where -import Prelude hiding (lex) +import Prelude () +import Prelude.Compat hiding (lex) import Data.Char (isSpace) import Data.List (intercalate) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative hiding (many) -#endif - import Text.Parsec hiding ((<|>)) import qualified Language.PureScript as P diff --git a/psci/tests/Main.hs b/psci/tests/Main.hs index bc4af94ecd..d3d6d3b79c 100644 --- a/psci/tests/Main.hs +++ b/psci/tests/Main.hs @@ -1,14 +1,13 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} module Main where +import Prelude () +import Prelude.Compat + import Control.Monad.Trans.State.Strict (runStateT) import Control.Monad (when, forM) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Writer.Strict (runWriterT) import Control.Monad.Trans.Except (runExceptT) diff --git a/purescript.cabal b/purescript.cabal index 24fd3554b2..ac264429de 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -197,7 +197,7 @@ executable psci build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, mtl -any, optparse-applicative >= 0.10.0, parsec -any, haskeline >= 0.7.0.0, purescript -any, transformers -any, - transformers-compat -any, process -any, time -any, Glob -any + transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0 main-is: Main.hs buildable: True From 2978939dec1d5e60b3d38e768753797726f841e3 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 5 Nov 2015 07:54:51 +0200 Subject: [PATCH 0119/1580] Use base-compat across package --- purescript.cabal | 1 + src/Control/Monad/Logger.hs | 8 +- src/Control/Monad/Supply.hs | 7 +- src/Language/PureScript/AST/Declarations.hs | 8 +- src/Language/PureScript/AST/SourcePos.hs | 8 +- src/Language/PureScript/AST/Traversals.hs | 125 ++++++++---------- src/Language/PureScript/Bundle.hs | 13 +- src/Language/PureScript/CodeGen/JS.hs | 7 +- src/Language/PureScript/CodeGen/JS/AST.hs | 10 +- .../PureScript/CodeGen/JS/Optimizer.hs | 7 +- .../CodeGen/JS/Optimizer/Inliner.hs | 8 +- .../PureScript/Docs/ParseAndDesugar.hs | 13 +- .../PureScript/Docs/RenderedCode/Render.hs | 9 +- .../PureScript/Docs/RenderedCode/Types.hs | 9 +- src/Language/PureScript/Docs/Types.hs | 7 +- src/Language/PureScript/Errors.hs | 12 +- src/Language/PureScript/Externs.hs | 7 +- src/Language/PureScript/Kinds.hs | 7 +- src/Language/PureScript/Linter.hs | 7 +- src/Language/PureScript/Linter/Exhaustive.hs | 7 +- src/Language/PureScript/Linter/Imports.hs | 7 +- src/Language/PureScript/Make.hs | 21 ++- src/Language/PureScript/Parser/JS.hs | 8 +- src/Language/PureScript/Parser/Kinds.hs | 8 +- src/Language/PureScript/Pretty/JS.hs | 14 +- src/Language/PureScript/Pretty/Values.hs | 2 - src/Language/PureScript/Publish.hs | 14 +- .../PureScript/Publish/ErrorsWarnings.hs | 10 +- src/Language/PureScript/Renamer.hs | 27 ++-- src/Language/PureScript/Sugar.hs | 15 +-- .../PureScript/Sugar/BindingGroups.hs | 8 +- .../PureScript/Sugar/CaseDeclarations.hs | 7 +- src/Language/PureScript/Sugar/DoNotation.hs | 7 +- src/Language/PureScript/Sugar/Names.hs | 16 +-- .../PureScript/Sugar/Names/Exports.hs | 10 +- .../PureScript/Sugar/Names/Imports.hs | 16 +-- .../PureScript/Sugar/ObjectWildcards.hs | 7 +- src/Language/PureScript/Sugar/Operators.hs | 11 +- src/Language/PureScript/Sugar/TypeClasses.hs | 11 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 9 +- .../PureScript/Sugar/TypeDeclarations.hs | 7 +- src/Language/PureScript/Traversals.hs | 7 +- src/Language/PureScript/TypeChecker.hs | 17 ++- .../PureScript/TypeChecker/Entailment.hs | 15 +-- src/Language/PureScript/TypeChecker/Kinds.hs | 9 +- src/Language/PureScript/TypeChecker/Monad.hs | 7 +- .../PureScript/TypeChecker/Skolems.hs | 8 +- .../PureScript/TypeChecker/Synonyms.hs | 7 +- src/Language/PureScript/TypeChecker/Types.hs | 17 ++- src/Language/PureScript/Types.hs | 7 +- 50 files changed, 260 insertions(+), 349 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index ac264429de..ba4edbfc31 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -40,6 +40,7 @@ source-repository head library build-depends: base >=4.6 && <5, + base-compat >=0.6.0, lifted-base >= 0.2.3 && < 0.2.4, monad-control >= 1.0.0.0 && < 1.1, transformers-base >= 0.4.0 && < 0.5, diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs index 4d8ab2f2bc..069b78194e 100644 --- a/src/Control/Monad/Logger.hs +++ b/src/Control/Monad/Logger.hs @@ -12,19 +12,17 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module Control.Monad.Logger where +import Prelude () +import Prelude.Compat + import Data.IORef -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -import Control.Applicative -#endif import Control.Monad (ap) import Control.Monad.IO.Class import Control.Monad.Writer.Class diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs index ef08980e58..1ae1e7234a 100644 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -14,15 +14,14 @@ ----------------------------------------------------------------------------- {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} module Control.Monad.Supply where +import Prelude () +import Prelude.Compat + import Data.Functor.Identity -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 7c8f915fd1..07ff4b1b98 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -15,10 +15,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} module Language.PureScript.AST.Declarations where +import Prelude () +import Prelude.Compat + import Data.Aeson.TH import qualified Data.Data as D @@ -26,10 +28,6 @@ import qualified Data.Map as M import Control.Monad.Identity -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - import Language.PureScript.AST.Binders import Language.PureScript.AST.Operators import Language.PureScript.AST.SourcePos diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index e1d8fc5351..10fd8c9699 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -12,7 +12,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} @@ -20,14 +19,13 @@ module Language.PureScript.AST.SourcePos where +import Prelude () +import Prelude.Compat + import qualified Data.Data as D import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - -- | -- Source position information -- diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 1d97ebc25c..3378a6c314 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -12,21 +12,12 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Language.PureScript.AST.Traversals where -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (Monoid(..), mconcat) -#endif -import Data.Maybe (mapMaybe) -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable (traverse) -#endif +import Prelude () +import Prelude.Compat -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif +import Data.Maybe (mapMaybe) import Control.Monad import Control.Arrow ((***), (+++), second) @@ -101,10 +92,10 @@ everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) => (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder) everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) where - f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds - f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val - f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds - f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds + f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds + f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val + f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds + f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> traverse (f' <=< f) ds f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f') f' other = f other @@ -114,37 +105,37 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (Parens v) = Parens <$> (g v >>= g') g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g')) g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g')) - g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs - g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs - g' (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g' <=< g)) vs + g' (ArrayLiteral vs) = ArrayLiteral <$> traverse (g' <=< g) vs + g' (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g' <=< g)) vs + g' (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g' <=< g)) vs g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g') g' (Accessor prop v) = Accessor prop <$> (g v >>= g') - g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs - g' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> mapM (sndM $ maybeM (g' <=< g)) vs + g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs + g' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> traverse (sndM $ maybeM (g' <=< g)) vs g' (Abs name v) = Abs name <$> (g v >>= g') g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g') g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g') - g' (Case vs alts) = Case <$> mapM (g' <=< g) vs <*> mapM handleCaseAlternative alts + g' (Case vs alts) = Case <$> traverse (g' <=< g) vs <*> traverse handleCaseAlternative alts g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty - g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g') - g' (Do es) = Do <$> mapM handleDoNotationElement es + g' (Let ds v) = Let <$> traverse (f' <=< f) ds <*> (g v >>= g') + g' (Do es) = Do <$> traverse handleDoNotationElement es g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g') g' other = g other - h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs - h' (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h' <=< h)) bs - h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs + h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs + h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs + h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h') h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h') h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h') h' other = h other - handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs - <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val + handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse (h' <=< h) bs + <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v - handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds + handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e everywhereOnValuesM :: (Functor m, Applicative m, Monad m) => @@ -154,11 +145,11 @@ everywhereOnValuesM :: (Functor m, Applicative m, Monad m) => (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder) everywhereOnValuesM f g h = (f', g', h') where - f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f - f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f - f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f - f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f - f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (mapM f') ds) >>= f + f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f + f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f + f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f + f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> traverse f' ds) >>= f + f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f f' other = f other @@ -167,37 +158,37 @@ everywhereOnValuesM f g h = (f', g', h') g' (Parens v) = (Parens <$> g' v) >>= g g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g - g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g - g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g - g' (ObjectConstructor vs) = (ObjectConstructor <$> mapM (sndM $ maybeM g') vs) >>= g + g' (ArrayLiteral vs) = (ArrayLiteral <$> traverse g' vs) >>= g + g' (ObjectLiteral vs) = (ObjectLiteral <$> traverse (sndM g') vs) >>= g + g' (ObjectConstructor vs) = (ObjectConstructor <$> traverse (sndM $ maybeM g') vs) >>= g g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g - g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g - g' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> mapM (sndM $ maybeM g') vs) >>= g + g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g + g' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> traverse (sndM $ maybeM g') vs) >>= g g' (Abs name v) = (Abs name <$> g' v) >>= g g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g - g' (Case vs alts) = (Case <$> mapM g' vs <*> mapM handleCaseAlternative alts) >>= g + g' (Case vs alts) = (Case <$> traverse g' vs <*> traverse handleCaseAlternative alts) >>= g g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g - g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g - g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g + g' (Let ds v) = (Let <$> traverse f' ds <*> g' v) >>= g + g' (Do es) = (Do <$> traverse handleDoNotationElement es) >>= g g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g g' other = g other - h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h - h' (ObjectBinder bs) = (ObjectBinder <$> mapM (sndM h') bs) >>= h - h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h + h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h + h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h + h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h h' other = h other - handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs - <*> eitherM (mapM (pairM g' g')) g' val + handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse h' bs + <*> eitherM (traverse (pairM g' g')) g' val handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v - handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds + handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e everythingOnValues :: (r -> r -> r) -> @@ -345,11 +336,11 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j where f'' s = uncurry f' <=< f s - f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f'' s) ds - f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val - f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds - f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds - f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (mapM (f'' s)) ds + f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds + f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val + f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds + f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> traverse (f'' s) ds + f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1 f' _ other = return other @@ -360,28 +351,28 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g' s (Parens v) = Parens <$> g'' s v g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v) g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v) - g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs - g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs - g' s (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g'' s)) vs + g' s (ArrayLiteral vs) = ArrayLiteral <$> traverse (g'' s) vs + g' s (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g'' s)) vs + g' s (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g'' s)) vs g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v g' s (Accessor prop v) = Accessor prop <$> g'' s v - g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs - g' s (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> mapM (sndM $ maybeM (g'' s)) vs + g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs + g' s (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> traverse (sndM $ maybeM (g'' s)) vs g' s (Abs name v) = Abs name <$> g'' s v g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3 - g' s (Case vs alts) = Case <$> mapM (g'' s) vs <*> mapM (i'' s) alts + g' s (Case vs alts) = Case <$> traverse (g'' s) vs <*> traverse (i'' s) alts g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty - g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v - g' s (Do es) = Do <$> mapM (j'' s) es + g' s (Let ds v) = Let <$> traverse (f'' s) ds <*> g'' s v + g' s (Do es) = Do <$> traverse (j'' s) es g' s (PositionedValue pos com v) = PositionedValue pos com <$> g'' s v g' _ other = return other h'' s = uncurry h' <=< h s - h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h'' s) bs - h' s (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h'' s)) bs - h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs + h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs + h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs + h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs h' s (NamedBinder name b) = NamedBinder name <$> h'' s b h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b h' s (TypedBinder t b) = TypedBinder t <$> h'' s b @@ -389,13 +380,13 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j i'' s = uncurry i' <=< i s - i' s (CaseAlternative bs val) = CaseAlternative <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val + i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val j'' s = uncurry j' <=< j s j' s (DoNotationValue v) = DoNotationValue <$> g'' s v j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v - j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds + j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1 accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 64f7cc2ed8..69558b01db 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -20,7 +20,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Bundle ( bundle @@ -31,6 +30,9 @@ module Language.PureScript.Bundle ( , printErrorMessage ) where +import Prelude () +import Prelude.Compat + import Data.List (nub) import Data.Maybe (mapMaybe, catMaybes) import Data.Generics (everything, everywhere, mkQ, mkT) @@ -39,9 +41,6 @@ import Data.Version (showVersion) import qualified Data.Set as S -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad import Control.Monad.Error.Class import Language.JavaScript.Parser @@ -212,7 +211,7 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es) -- Other constructor. toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSNode -> m Module toModule mids mid top - | JSSourceElementsTop ns <- node top = Module mid <$> mapM toModuleElement ns + | JSSourceElementsTop ns <- node top = Module mid <$> traverse toModuleElement ns | otherwise = err InvalidTopLevel where err = throwError . ErrorInModule mid @@ -262,7 +261,7 @@ toModule mids mid top , JSOperator eq <- node op , JSLiteral "=" <- node eq , JSObjectLiteral _ props _ <- node obj - = ExportsList <$> mapM toExport (filter (not . isSeparator) (map node props)) + = ExportsList <$> traverse toExport (filter (not . isSeparator) (map node props)) where toExport :: Node -> m (ExportType, String, JSNode, [Key]) toExport (JSPropertyNameandValue name _ [val] ) = @@ -544,7 +543,7 @@ bundle inputStrs entryPoints mainModule namespace = do let mids = S.fromList (map (moduleName . fst) input) - modules <- mapM (fmap withDeps . uncurry (toModule mids)) input + modules <- traverse (fmap withDeps . uncurry (toModule mids)) input let compiled = compile modules entryPoints sorted = sortModules (filter (not . isModuleEmpty) compiled) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 3916a943a1..e4093304e3 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -17,7 +17,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.CodeGen.JS ( module AST @@ -26,13 +25,13 @@ module Language.PureScript.CodeGen.JS , mainCall ) where +import Prelude () +import Prelude.Compat + import Data.List ((\\), delete, intersect) import Data.Maybe (isNothing) import qualified Data.Traversable as T (traverse) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Arrow ((&&&)) import Control.Monad (replicateM, forM) import Control.Monad.Reader (MonadReader, asks) diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index 90be9747af..a5ec412cdd 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -14,18 +14,14 @@ ----------------------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE CPP #-} module Language.PureScript.CodeGen.JS.AST where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative, (<$>), (<*>)) -#endif +import Prelude () +import Prelude.Compat + import Control.Monad.Identity import Data.Data -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable (traverse) -#endif import Language.PureScript.Comments import Language.PureScript.Traversals diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs index 9d2e2ab767..5e2a38e9fb 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -32,15 +32,14 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} module Language.PureScript.CodeGen.JS.Optimizer ( optimize ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative) -#endif +import Prelude () +import Prelude.Compat + import Control.Monad.Reader (MonadReader, ask, asks) import Control.Monad.Supply.Class (MonadSupply) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index eeaafe04c8..8b42305b90 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -13,8 +13,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Language.PureScript.CodeGen.JS.Optimizer.Inliner ( inlineVariables, inlineValues, @@ -26,9 +24,9 @@ module Language.PureScript.CodeGen.JS.Optimizer.Inliner ( evaluateIifes ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative) -#endif +import Prelude () +import Prelude.Compat + import Control.Monad.Supply.Class (MonadSupply, freshName) import Data.Maybe (fromMaybe) diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndDesugar.hs index b422748cae..a8b107fd78 100644 --- a/src/Language/PureScript/Docs/ParseAndDesugar.hs +++ b/src/Language/PureScript/Docs/ParseAndDesugar.hs @@ -1,17 +1,16 @@ {-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Docs.ParseAndDesugar ( parseAndDesugar , ParseDesugarError(..) ) where +import Prelude () +import Prelude.Compat + import qualified Data.Map as M import Control.Arrow (first) import Control.Monad -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Trans.Except import Control.Monad.Writer.Strict (runWriterT) @@ -53,8 +52,8 @@ parseAndDesugar :: -> ([Bookmark] -> [P.Module] -> IO a) -> IO (Either ParseDesugarError a) parseAndDesugar inputFiles depsFiles callback = do - inputFiles' <- mapM (parseAs Local) inputFiles - depsFiles' <- mapM (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles + inputFiles' <- traverse (parseAs Local) inputFiles + depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles runExceptT $ do ms <- parseFiles (inputFiles' ++ depsFiles') @@ -122,7 +121,7 @@ desugar :: [P.Module] -> Either P.MultipleErrors [P.Module] desugar = P.evalSupplyT 0 . desugar' where desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module] - desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports [] + desugar' = traverse P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports [] ignoreWarnings m = liftM fst (runWriterT m) parseFile :: FilePath -> IO (FilePath, String) diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index 1af0c09896..1d6766e582 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - -- | Functions for producing RenderedCode values from PureScript Type values. module Language.PureScript.Docs.RenderedCode.Render ( @@ -11,12 +9,11 @@ module Language.PureScript.Docs.RenderedCode.Render ( defaultRenderTypeOptions, renderTypeWithOptions ) where + +import Prelude () +import Prelude.Compat -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid ((<>), mconcat, mempty) -#else import Data.Monoid ((<>)) -#endif import Data.Maybe (fromMaybe) import Control.Arrow ((<+>)) diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 63e2b2178d..8ae8760e65 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -1,6 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -- | Data types and functions for representing a simplified form of PureScript -- code, intended for use in e.g. HTML documentation. @@ -31,11 +30,9 @@ module Language.PureScript.Docs.RenderedCode.Types , keywordWhere ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>), (*>), pure) -import Data.Foldable -import Data.Monoid -#endif +import Prelude () +import Prelude.Compat + import qualified Data.Aeson as A import Data.Aeson.BetterErrors import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 131f0a11be..15ec473c20 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -2,7 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Docs.Types ( module Language.PureScript.Docs.Types @@ -10,10 +9,10 @@ module Language.PureScript.Docs.Types ) where +import Prelude () +import Prelude.Compat + import Control.Arrow (first, (***)) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<$), (<*>), pure) -#endif import Control.Monad (when) import Data.Maybe (mapMaybe) import Data.Version diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 2370f56bde..7f65248fd0 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -15,19 +15,16 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Errors where +import Prelude () +import Prelude.Compat + import Data.Either (lefts, rights) import Data.List (intercalate, transpose, nub, nubBy) import Data.Function (on) -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable (fold, foldMap) -import Data.Traversable (traverse) -#else import Data.Foldable (fold) -#endif import qualified Data.Map as M @@ -35,9 +32,6 @@ import Control.Monad import Control.Monad.Unify import Control.Monad.Writer import Control.Monad.Error.Class (MonadError(..)) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>), Applicative, pure) -#endif import Control.Monad.Trans.State.Lazy import Control.Arrow(first) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index bed882bb63..036a748b31 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -13,7 +13,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} @@ -27,13 +26,13 @@ module Language.PureScript.Externs , applyExternsFileToEnvironment ) where +import Prelude () +import Prelude.Compat + import Data.List (find, foldl') import Data.Maybe (mapMaybe, maybeToList, fromMaybe) import Data.Foldable (fold) import Data.Version (showVersion) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif import Data.Aeson.TH import qualified Data.Map as M diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 1c63b7d6b9..ca0d58c0d5 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -14,16 +14,15 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Kinds where +import Prelude () +import Prelude.Compat + import Data.Data import qualified Data.Aeson.TH as A -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Unify (Unknown) -- | diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 1a9886865a..c3eef817df 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -15,19 +15,18 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Linter (lint, module L) where +import Prelude () +import Prelude.Compat + import Data.List (mapAccumL, nub, (\\)) import Data.Maybe (mapMaybe) import Data.Monoid import qualified Data.Set as S -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Writer.Class import Language.PureScript.Crash diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 4adc578eff..f36cc2144a 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -18,20 +18,19 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Linter.Exhaustive ( checkExhaustive , checkExhaustiveModule ) where +import Prelude () +import Prelude.Compat + import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.List (foldl', sortBy, nub) import Data.Function (on) -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable (sequenceA) -#endif import Control.Monad (unless) import Control.Applicative diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 8269c18143..6a73cfb332 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -1,18 +1,17 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Linter.Imports (findUnusedImports, Name(..), UsedImports()) where +import Prelude () +import Prelude.Compat + import qualified Data.Map as M import Data.Maybe (mapMaybe) import Data.List ((\\), find) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class import Control.Monad(unless,when) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Data.Foldable (forM_) import Language.PureScript.AST.Declarations diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 7682066edc..4888ca6165 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -21,7 +21,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Make ( @@ -38,14 +37,16 @@ module Language.PureScript.Make , buildMakeActions ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif -import Control.Monad +import Prelude () +import Prelude.Compat + +import Control.Monad hiding (sequence) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except -import Control.Monad.Reader +import Control.Monad.IO.Class +import Control.Monad.Reader (MonadReader(..), ReaderT(..)) import Control.Monad.Logger import Control.Monad.Supply import Control.Monad.Base (MonadBase(..)) @@ -58,10 +59,6 @@ import Data.Maybe (fromMaybe, catMaybes) import Data.Time.Clock import Data.String (fromString) import Data.Foldable (for_) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mempty, mconcat) -import Data.Traversable (traverse) -#endif import Data.Traversable (for) import Data.Version (showVersion) import Data.Aeson (encode, decode) @@ -207,12 +204,12 @@ make MakeActions{..} ms = do -- We need to wait for dependencies to be built, before checking if the current -- module should be rebuilt, so the first thing to do is to wait on the -- MVars for the module's dependencies. - mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps + mexterns <- fmap unzip . sequence <$> traverse (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps case mexterns of Just (_, externs) -> do outputTimestamp <- getOutputTimestamp moduleName - dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps + dependencyTimestamp <- maximumMaybe <$> traverse (fmap shouldExist . getOutputTimestamp) deps inputTimestamp <- getInputTimestamp moduleName let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs index 43cb04ebf4..a25f7d88d1 100644 --- a/src/Language/PureScript/Parser/JS.hs +++ b/src/Language/PureScript/Parser/JS.hs @@ -13,16 +13,15 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Parser.JS ( ForeignJS() , parseForeignModulesFromFiles ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((*>), (<*)) -#endif +import Prelude () +import Prelude.Compat hiding (lex) + import Control.Monad (forM_, when, msum) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -32,7 +31,6 @@ import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Parser.Common import Language.PureScript.Parser.Lexer -import Prelude hiding (lex) import qualified Data.Map as M import qualified Text.Parsec as PS diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs index f45473c55c..83e62da0a8 100644 --- a/src/Language/PureScript/Parser/Kinds.hs +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -13,18 +13,16 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Language.PureScript.Parser.Kinds ( parseKind ) where +import Prelude () +import Prelude.Compat + import Language.PureScript.Kinds import Language.PureScript.Parser.Common import Language.PureScript.Parser.Lexer -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 51eba66efb..0bab0c6fe1 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -13,20 +13,18 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Language.PureScript.Pretty.JS ( prettyPrintJS ) where -import Data.List +import Prelude () +import Prelude.Compat + +import Data.List hiding (concat, concatMap) import Data.Maybe (fromMaybe) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Arrow ((<+>)) -import Control.Monad.State +import Control.Monad.State hiding (sequence) import Control.PatternArrows import qualified Control.Arrow as A @@ -199,7 +197,7 @@ app :: Pattern PrinterState JS (String, JS) app = mkPattern' match where match (JSApp val args) = do - jss <- mapM prettyPrintJS' args + jss <- traverse prettyPrintJS' args return (intercalate ", " jss, val) match _ = mzero diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 7c198153e6..79d9f5cb04 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -13,8 +13,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Language.PureScript.Pretty.Values ( prettyPrintValue, prettyPrintBinder, diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index e80c9647a6..9441781c21 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -2,7 +2,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Publish ( preparePackage @@ -19,7 +18,8 @@ module Language.PureScript.Publish , getResolvedDependencies ) where -import Prelude hiding (userError) +import Prelude () +import Prelude.Compat hiding (userError) import Data.Maybe import Data.Char (isSpace) @@ -28,15 +28,13 @@ import Data.List.Split (splitOn) import Data.List.NonEmpty (NonEmpty(..)) import Data.Version import Data.Function (on) +import Data.Foldable (traverse_) import Safe (headMay) import Data.Aeson.BetterErrors import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Category ((>>>)) import Control.Arrow ((***)) import Control.Exception (catch, try) @@ -304,7 +302,7 @@ asDependencyStatus = do warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM () warnUndeclared declared actual = - mapM_ (warn . UndeclaredDependency) (actual \\ declared) + traverse_ (warn . UndeclaredDependency) (actual \\ declared) handleDeps :: [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)] @@ -314,8 +312,8 @@ handleDeps deps = do (x:xs) -> userError (MissingDependencies (x :| xs)) [] -> do - mapM_ (warn . NoResolvedVersion) noVersion - withVersions <- catMaybes <$> mapM tryExtractVersion' installed + traverse_ (warn . NoResolvedVersion) noVersion + withVersions <- catMaybes <$> traverse tryExtractVersion' installed filterM (liftIO . isPureScript . bowerDir . fst) withVersions where diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 72244383fe..a7b1196ff1 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Publish.ErrorsWarnings ( PackageError(..) @@ -16,16 +15,13 @@ module Language.PureScript.Publish.ErrorsWarnings , renderWarnings ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>)) -#endif +import Prelude () +import Prelude.Compat + import Data.Aeson.BetterErrors import Data.Version import Data.Maybe import Data.Monoid -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable (foldMap) -#endif import Data.List (intersperse, intercalate) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index ab20854016..c651bfc561 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -16,13 +16,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Renamer (renameInModules) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif +import Prelude () +import Prelude.Compat + import Control.Monad.State import Data.List (find) @@ -135,8 +134,8 @@ renameInDecl isTopLevel (NonRec name val) = do name' <- if isTopLevel then return name else updateScope name NonRec name' <$> renameInValue val renameInDecl isTopLevel (Rec ds) = do - ds' <- mapM updateNames ds - Rec <$> mapM updateValues ds' + ds' <- traverse updateNames ds + Rec <$> traverse updateValues ds' where updateNames :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann) updateNames (name, val) = do @@ -155,7 +154,7 @@ renameInValue c@(Constructor{}) = return c renameInValue (Accessor ann prop v) = Accessor ann prop <$> renameInValue v renameInValue (ObjectUpdate ann obj vs) = - ObjectUpdate ann <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs + ObjectUpdate ann <$> renameInValue obj <*> traverse (\(name, v) -> (,) name <$> renameInValue v) vs renameInValue e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = return e renameInValue (Abs ann name v) = newScope $ Abs ann <$> updateScope name <*> renameInValue v @@ -165,16 +164,16 @@ renameInValue (Var ann (Qualified Nothing name)) = Var ann . Qualified Nothing <$> lookupIdent name renameInValue v@(Var{}) = return v renameInValue (Case ann vs alts) = - newScope $ Case ann <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts + newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts renameInValue (Let ann ds v) = - newScope $ Let ann <$> mapM (renameInDecl False) ds <*> renameInValue v + newScope $ Let ann <$> traverse (renameInDecl False) ds <*> renameInValue v -- | -- Renames within literals. -- renameInLiteral :: (a -> Rename a) -> Literal a -> Rename (Literal a) -renameInLiteral rename (ArrayLiteral bs) = ArrayLiteral <$> mapM rename bs -renameInLiteral rename (ObjectLiteral bs) = ObjectLiteral <$> mapM (sndM rename) bs +renameInLiteral rename (ArrayLiteral bs) = ArrayLiteral <$> traverse rename bs +renameInLiteral rename (ObjectLiteral bs) = ObjectLiteral <$> traverse (sndM rename) bs renameInLiteral _ l = return l -- | @@ -182,8 +181,8 @@ renameInLiteral _ l = return l -- renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann) renameInCaseAlternative (CaseAlternative bs v) = newScope $ - CaseAlternative <$> mapM renameInBinder bs - <*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v + CaseAlternative <$> traverse renameInBinder bs + <*> eitherM (traverse (pairM renameInValue renameInValue)) renameInValue v -- | -- Renames within binders. @@ -195,6 +194,6 @@ renameInBinder (LiteralBinder ann b) = renameInBinder (VarBinder ann name) = VarBinder ann <$> updateScope name renameInBinder (ConstructorBinder ann tctor dctor bs) = - ConstructorBinder ann tctor dctor <$> mapM renameInBinder bs + ConstructorBinder ann tctor dctor <$> traverse renameInBinder bs renameInBinder (NamedBinder ann name b) = NamedBinder ann <$> updateScope name <*> renameInBinder b diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index ba3722715b..0b50a5f29f 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -14,15 +14,14 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar (desugar, module S) where +import Prelude () +import Prelude.Compat + import Control.Monad import Control.Category ((>>>)) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Error.Class (MonadError()) import Control.Monad.Writer.Class (MonadWriter()) import Control.Monad.Supply.Class @@ -67,13 +66,13 @@ import Language.PureScript.Sugar.TypeDeclarations as S desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] desugar externs = map removeSignedLiterals - >>> mapM desugarObjectConstructors - >=> mapM desugarOperatorSections - >=> mapM desugarDoModule + >>> traverse desugarObjectConstructors + >=> traverse desugarOperatorSections + >=> traverse desugarDoModule >=> desugarCasesModule >=> desugarTypeDeclarationsModule >=> desugarImports externs >=> rebracket externs - >=> mapM deriveInstances + >=> traverse deriveInstances >=> desugarTypeClasses externs >=> createBindingGroupsModule diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index e0257fcc78..ff6c03f090 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -15,7 +15,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Sugar.BindingGroups ( @@ -25,13 +24,12 @@ module Language.PureScript.Sugar.BindingGroups ( collapseBindingGroupsModule ) where +import Prelude () +import Prelude.Compat + import Data.Graph import Data.List (nub, intersect) import Data.Maybe (isJust, mapMaybe) -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable (foldMap) -import Control.Applicative -#endif import Control.Monad ((<=<)) import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index e3e5062cec..8380d4ced6 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -16,20 +16,19 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.CaseDeclarations ( desugarCases, desugarCasesModule ) where +import Prelude () +import Prelude.Compat + import Language.PureScript.Crash import Data.Maybe (catMaybes) import Data.List (nub, groupBy) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad ((<=<), forM, replicateM, join, unless) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 72e6fa7a0e..c91012a3f2 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -16,12 +16,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.DoNotation ( desugarDoModule ) where +import Prelude () +import Prelude.Compat + import Language.PureScript.Crash import Language.PureScript.Names import Language.PureScript.AST @@ -29,9 +31,6 @@ import Language.PureScript.Errors import qualified Language.PureScript.Constants as C -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index ccb465fad9..2cf496bd8c 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -11,20 +11,18 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Sugar.Names (desugarImports) where +import Prelude () +import Prelude.Compat + import Data.List (find, nub) import Data.Maybe (fromMaybe, mapMaybe) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mempty) -import Control.Applicative (Applicative(..), (<$>), (<*>)) -#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer (MonadWriter(..), censor) @@ -52,7 +50,7 @@ desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWr desugarImports externs modules = do env <- silence $ foldM externsEnv primEnv externs env' <- foldM updateEnv env modules - mapM (renameInModule' env') modules + traverse (renameInModule' env') modules where silence :: m a -> m a silence = censor (const mempty) @@ -161,13 +159,13 @@ renameInModule env imports (Module ss coms mn decls exps) = updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d) updateDecl (pos, bound) (DataDeclaration dtype name args dctors) = - (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors) + (,) (pos, bound) <$> (DataDeclaration dtype name args <$> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors) updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) = (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty) updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) = (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds) updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) = - (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> mapM (updateTypesEverywhere pos) ts <*> pure ds) + (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> traverse (updateTypesEverywhere pos) ts <*> pure ds) updateDecl (pos, bound) (TypeDeclaration name ty) = (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty) updateDecl (pos, bound) (ExternDeclaration name ty) = @@ -225,7 +223,7 @@ renameInModule env imports (Module ss coms mn decls exps) = updateType t = return t updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint] - updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts) + updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts) updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) IsProperName diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 192cd5f2ff..7b82792cf4 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -11,7 +11,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -22,12 +21,13 @@ module Language.PureScript.Sugar.Names.Exports , resolveExports ) where +import Prelude () +import Prelude.Compat + import Data.List (find, intersect) import Data.Maybe (fromMaybe, mapMaybe) +import Data.Foldable (traverse_) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative(..), (<$>)) -#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) @@ -197,7 +197,7 @@ filterModule mn exps refs = do Nothing -> throwError . errorMessage . UnknownExportType $ name Just ((_, dcons), _) -> do let expDcons' = fromMaybe dcons expDcons - mapM_ (checkDcon name dcons) expDcons' + traverse_ (checkDcon name dcons) expDcons' return $ ((name, expDcons'), mn) : result filterTypes _ result _ = return result diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index c74aaaec63..13ffc10f6a 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -11,7 +11,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -22,13 +21,14 @@ module Language.PureScript.Sugar.Names.Imports , findImports ) where +import Prelude () +import Prelude.Compat + import Data.List (find) import Data.Maybe (fromMaybe, isNothing) +import Data.Foldable (traverse_) import Control.Arrow (first) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative(..), (<$>)) -#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer (MonadWriter(..), censor) @@ -57,7 +57,7 @@ findImports = foldM (go Nothing) M.empty -- Ensure that classes don't appear in an `import X hiding (...)` checkImportRefType :: ImportDeclarationType -> m () - checkImportRefType (Hiding refs) = mapM_ checkImportRef refs + checkImportRefType (Hiding refs) = traverse_ checkImportRef refs checkImportRefType _ = return () checkImportRef :: DeclarationRef -> m () checkImportRef (ModuleRef name) = throwError . errorMessage $ ImportHidingModule name @@ -105,7 +105,7 @@ resolveImport currentModule importModule exps imps impQual = -- Check that a 'DeclarationRef' refers to an importable symbol checkRefs :: [DeclarationRef] -> m () - checkRefs = mapM_ check + checkRefs = traverse_ check where check (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ check r @@ -114,7 +114,7 @@ resolveImport currentModule importModule exps imps impQual = check (TypeRef name dctors) = do checkImportExists UnknownImportType ((fst . fst) `map` exportedTypes exps) name let allDctors = fst `map` allExportedDataConstructors name - maybe (return ()) (mapM_ $ checkDctorExists name allDctors) dctors + maybe (return ()) (traverse_ $ checkDctorExists name allDctors) dctors check (TypeClassRef name) = checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name --check (ModuleRef name) = @@ -168,7 +168,7 @@ resolveImport currentModule importModule exps imps impQual = exportedDctors = allExportedDataConstructors name dctorNames :: [ProperName] dctorNames = fst `map` exportedDctors - maybe (return ()) (mapM_ $ checkDctorExists name dctorNames) dctors + maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name dctors' <- foldM (\m -> updateImports m runProperName exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors) return $ imp { importedTypes = types', importedDataConstructors = dctors' } diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 6b4f6cd93a..a68331e048 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -14,15 +14,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.ObjectWildcards ( desugarObjectConstructors ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif +import Prelude () +import Prelude.Compat + import Control.Arrow (second) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 116c2a0502..ffc069c636 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -21,7 +21,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.Operators ( rebracket, @@ -29,15 +28,15 @@ module Language.PureScript.Sugar.Operators ( desugarOperatorSections ) where +import Prelude () +import Prelude.Compat + import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Externs -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class @@ -60,7 +59,7 @@ rebracket externs ms = do let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities - mapM (rebracketModule opTable) ms + traverse (rebracketModule opTable) ms removeSignedLiterals :: Module -> Module removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts @@ -164,7 +163,7 @@ matchOp op = do guard $ ident == op desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module -desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> mapM goDecl ds <*> pure exts +desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> traverse goDecl ds <*> pure exts where goDecl :: Declaration -> m Declaration diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 97ea9c4e8a..44300e35bb 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -16,7 +16,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.TypeClasses ( desugarTypeClasses @@ -24,6 +23,9 @@ module Language.PureScript.Sugar.TypeClasses , superClassDictionaryNames ) where +import Prelude () +import Prelude.Compat + import Language.PureScript.Crash import Language.PureScript.AST hiding (isExported) import Language.PureScript.Environment @@ -37,9 +39,6 @@ import Language.PureScript.Types import qualified Language.PureScript.Constants as C -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Arrow (first, second) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State @@ -57,7 +56,7 @@ type Desugar = StateT MemberMap -- instance dictionary expressions. -- desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] -desugarTypeClasses externs = flip evalStateT initialState . mapM desugarModule +desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule where initialState :: MemberMap initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) @@ -262,7 +261,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys -- Create values for the type instance members - members <- zip (map typeClassMemberName decls) <$> mapM (memberToValue memberTypes) decls + members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls -- Create the type of the dictionary -- The type is an object type, but depending on type instance dependencies, may be constrained. diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index d83d383297..d82e655203 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -19,19 +19,18 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.TypeClasses.Deriving ( deriveInstances ) where -import Data.List +import Prelude () +import Prelude.Compat + +import Data.List (foldl', find, sortBy) import Data.Maybe (fromMaybe) import Data.Ord (comparing) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad (replicateM) import Control.Monad.Supply.Class (MonadSupply, freshName) import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index f435e9452c..8282dd5e02 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -16,15 +16,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.TypeDeclarations ( desugarTypeDeclarationsModule ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif +import Prelude () +import Prelude.Compat + import Control.Monad (forM) import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Traversals.hs b/src/Language/PureScript/Traversals.hs index 67bb5133fb..74107290c0 100644 --- a/src/Language/PureScript/Traversals.hs +++ b/src/Language/PureScript/Traversals.hs @@ -12,13 +12,10 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Language.PureScript.Traversals where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif +import Prelude () +import Prelude.Compat fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b) fstM f (a, b) = flip (,) b <$> f a diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 4c41bf396e..70629cd3a3 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -14,13 +14,15 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} module Language.PureScript.TypeChecker ( module T, typeCheckModule ) where +import Prelude () +import Prelude.Compat + import Language.PureScript.TypeChecker.Monad as T import Language.PureScript.TypeChecker.Kinds as T import Language.PureScript.TypeChecker.Types as T @@ -28,13 +30,10 @@ import Language.PureScript.TypeChecker.Synonyms as T import Data.Maybe import Data.List (nub, (\\), sort, group) -import Data.Foldable (for_) +import Data.Foldable (for_, traverse_) import qualified Data.Map as M -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*)) -#endif import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) @@ -58,7 +57,7 @@ addDataType moduleName dtype name args dctors ctorKind = do addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check () addDataConstructor moduleName dtype name args dctor tys = do env <- getEnv - mapM_ checkTypeSynonyms tys + traverse_ checkTypeSynonyms tys let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args) let dctorTy = foldr function retTy tys let polyType = mkForAll args dctorTy @@ -134,7 +133,7 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms -- * Process module imports -- typeCheckAll :: ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration] -typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds +typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities ds where go :: Declaration -> Check Declaration go (DataDeclaration dtype name args dctors) = do @@ -218,8 +217,8 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds addTypeClass moduleName pn args implies tys return d go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do - mapM_ (checkTypeClassInstance moduleName) tys - forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd + traverse_ (checkTypeClassInstance moduleName) tys + forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . snd checkOrphanInstance dictName className tys _ <- traverseTypeInstanceBody checkInstanceMembers body let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 3bc4f3037e..06fd566863 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -13,23 +13,18 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Language.PureScript.TypeChecker.Entailment ( entails ) where +import Prelude () +import Prelude.Compat + import Data.Function (on) -import Data.List +import Data.List (minimumBy, sortBy, groupBy) import Data.Maybe (maybeToList, mapMaybe) -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable (foldMap) -#endif import qualified Data.Map as M -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Arrow (Arrow(..)) import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) @@ -112,7 +107,7 @@ entails moduleName context = solve solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> Check (Maybe [DictionaryValue]) solveSubgoals _ Nothing = return Nothing solveSubgoals subst (Just subgoals) = do - dict <- mapM (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals + dict <- traverse (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals return $ Just dict -- Make a dictionary from subgoal dictionaries by applying the correct function diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index e0aa8cf078..8f842d41d9 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -17,7 +17,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} module Language.PureScript.TypeChecker.Kinds ( kindOf, @@ -26,15 +25,15 @@ module Language.PureScript.TypeChecker.Kinds ( kindsOfAll ) where +import Prelude () +import Prelude.Compat + import Data.Maybe (fromMaybe) import qualified Data.HashMap.Strict as H import qualified Data.Map as M import Control.Arrow (second) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State @@ -141,7 +140,7 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do -- solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind solveTypes isData ts kargs tyCon = do - ks <- mapM (fmap fst . infer) ts + ks <- traverse (fmap fst . infer) ts when isData $ do tyCon =?= foldr FunKind Star kargs forM_ ks $ \k -> k =?= Star diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 182526fd7e..7ea732bcf2 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -19,17 +19,16 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE CPP #-} module Language.PureScript.TypeChecker.Monad where +import Prelude () +import Prelude.Compat + import Data.Maybe import Data.Foldable (for_) import qualified Data.Map as M -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.State import Control.Monad.Unify import Control.Monad.Writer.Strict diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index d1ab4c5cd2..127453d34f 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -13,8 +13,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Language.PureScript.TypeChecker.Skolems ( newSkolemConstant, introduceSkolemScope, @@ -24,12 +22,12 @@ module Language.PureScript.TypeChecker.Skolems ( skolemEscapeCheck ) where +import Prelude () +import Prelude.Compat + import Data.List (nub, (\\)) import Data.Monoid -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Unify diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 0796665c21..ae85eee0cf 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -17,18 +17,17 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE CPP #-} module Language.PureScript.TypeChecker.Synonyms ( replaceAllTypeSynonyms ) where +import Prelude () +import Prelude.Compat + import Data.Maybe (fromMaybe) import qualified Data.Map as M -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index fc8b61694a..58546108fd 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -16,7 +16,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} module Language.PureScript.TypeChecker.Types ( typesOf @@ -38,14 +37,14 @@ module Language.PureScript.TypeChecker.Types ( Check a function of a given type returns a value of another type when applied to its arguments -} +import Prelude () +import Prelude.Compat + import Data.Either (lefts, rights) -import Data.List +import Data.List (transpose, nub, (\\), partition, delete) import Data.Maybe (fromMaybe) import qualified Data.Map as M -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad import Control.Monad.State import Control.Monad.Unify @@ -213,20 +212,20 @@ infer' v@(StringLiteral _) = return $ TypedValue True v tyString infer' v@(CharLiteral _) = return $ TypedValue True v tyChar infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean infer' (ArrayLiteral vals) = do - ts <- mapM infer vals + ts <- traverse infer vals els <- fresh forM_ ts $ \(TypedValue _ _ t) -> els =?= t return $ TypedValue True (ArrayLiteral ts) (TypeApp tyArray els) infer' (ObjectLiteral ps) = do ensureNoDuplicateProperties ps - ts <- mapM (infer . snd) ps + ts <- traverse (infer . snd) ps let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts ty = TypeApp tyObject $ rowFromList (fields, REmpty) return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty infer' (ObjectUpdate o ps) = do ensureNoDuplicateProperties ps row <- fresh - newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps + newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh let oldTy = TypeApp tyObject $ rowFromList (oldTys, row) @@ -365,7 +364,7 @@ inferBinder val (ObjectBinder props) = do return $ m1 `M.union` m2 inferBinder val (ArrayBinder binders) = do el <- fresh - m1 <- M.unions <$> mapM (inferBinder el) binders + m1 <- M.unions <$> traverse (inferBinder el) binders val =?= TypeApp tyArray el return m1 inferBinder val (NamedBinder name binder) = do diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index dec6641aa3..e85b94b6a8 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -16,10 +16,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Types where +import Prelude () +import Prelude.Compat + import Data.Data import Data.List (nub) import Data.Maybe (fromMaybe) @@ -28,9 +30,6 @@ import qualified Data.Aeson.TH as A import Control.Monad.Unify import Control.Arrow (second) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad ((<=<)) import Language.PureScript.Names From 2c7b5341877b279a56401ab35707269c57f6eb2d Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Tue, 3 Nov 2015 19:50:42 -0600 Subject: [PATCH 0120/1580] Add --require-path options to psc-bundle --- psc-bundle/Main.hs | 11 ++++++++++- src/Language/PureScript/Bundle.hs | 26 ++++++++++++++------------ 2 files changed, 24 insertions(+), 13 deletions(-) diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index 5b66605977..789fffa667 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -48,6 +48,7 @@ data Options = Options , optionsEntryPoints :: [String] , optionsMainModule :: Maybe String , optionsNamespace :: String + , optionsRequirePath :: Maybe FilePath } deriving Show -- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier. @@ -74,7 +75,7 @@ app Options{..} = do let entryIds = (map (`ModuleIdentifier` Regular) optionsEntryPoints) - bundle input entryIds optionsMainModule optionsNamespace + bundle input entryIds optionsMainModule optionsNamespace optionsRequirePath -- | Command line options parser. options :: Parser Options @@ -83,6 +84,7 @@ options = Options <$> some inputFile <*> many entryPoint <*> optional mainModule <*> namespace + <*> optional requirePath where inputFile :: Parser FilePath inputFile = strArgument $ @@ -113,6 +115,13 @@ options = Options <$> some inputFile <> Opts.value "PS" <> showDefault <> help "Specify the namespace that PureScript modules will be exported to when running in the browser." + + requirePath :: Parser FilePath + requirePath = strOption $ + short 'r' + <> long "require-path" + <> Opts.value "" + <> help "The path prefix used in require() calls in the generated JavaScript" -- | Make it go. main :: IO () diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 69558b01db..2d2fc92c3f 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -33,8 +33,8 @@ module Language.PureScript.Bundle ( import Prelude () import Prelude.Compat -import Data.List (nub) -import Data.Maybe (mapMaybe, catMaybes) +import Data.List (nub, stripPrefix) +import Data.Maybe (mapMaybe, catMaybes, fromMaybe) import Data.Generics (everything, everywhere, mkQ, mkT) import Data.Graph import Data.Version (showVersion) @@ -138,12 +138,13 @@ node (NN n) = n node (NT n _ _) = n -- | Calculate the ModuleIdentifier which a require(...) statement imports. -checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier -checkImportPath "./foreign" m _ = +checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier +checkImportPath _ "./foreign" m _ = Just (ModuleIdentifier (moduleName m) Foreign) -checkImportPath name _ names - | name `S.member` names = Just (ModuleIdentifier name Regular) -checkImportPath _ _ _ = Nothing +checkImportPath requirePath name _ names + | Just name' <- stripPrefix (fromMaybe "" requirePath) name + , name' `S.member` names = Just (ModuleIdentifier name' Regular) +checkImportPath _ _ _ _ = Nothing -- | Compute the dependencies of all elements in a module, and add them to the tree. -- @@ -209,8 +210,8 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es) -- -- Each type of module element is matched using pattern guards, and everything else is bundled into the -- Other constructor. -toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSNode -> m Module -toModule mids mid top +toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module +toModule requirePath mids mid top | JSSourceElementsTop ns <- node top = Module mid <$> traverse toModuleElement ns | otherwise = err InvalidTopLevel where @@ -226,7 +227,7 @@ toModule mids mid top , JSIdentifier "require" <- node req , JSArguments _ [ impS ] _ <- node impP , JSStringLiteral _ importPath <- node impS - , Just importPath' <- checkImportPath importPath mid mids + , Just importPath' <- checkImportPath requirePath importPath mid mids = pure (Require n importName importPath') toModuleElement n | JSVariables var [ varIntro ] _ <- node n @@ -535,15 +536,16 @@ bundle :: forall m. (Applicative m, MonadError ErrorMessage m) -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination -> Maybe String -- ^ An optional main module. -> String -- ^ The namespace (e.g. PS). + -> Maybe FilePath -- ^ The require path prefix -> m String -bundle inputStrs entryPoints mainModule namespace = do +bundle inputStrs entryPoints mainModule namespace requirePath = do input <- forM inputStrs $ \(ident, js) -> do ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident) return (ident, ast) let mids = S.fromList (map (moduleName . fst) input) - modules <- traverse (fmap withDeps . uncurry (toModule mids)) input + modules <- traverse (fmap withDeps . uncurry (toModule requirePath mids)) input let compiled = compile modules entryPoints sorted = sortModules (filter (not . isModuleEmpty) compiled) From ae84a66a1fd1392dae5704b3a2406dc484487b85 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 5 Nov 2015 11:03:23 -0800 Subject: [PATCH 0121/1580] Fix redundant import --- src/Language/PureScript/TypeChecker/Monad.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 08569f182c..c2bbc0a2a6 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -26,7 +26,6 @@ import Prelude () import Prelude.Compat import Data.Maybe -import Data.Foldable (for_) import qualified Data.Map as M import Control.Arrow (second) From fe69c1ce69bcdc676055b39d19af3a72e1280964 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 5 Nov 2015 11:50:12 -0800 Subject: [PATCH 0122/1580] Constraints --- src/Language/PureScript/TypeChecker/Entailment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index f79baf8938..c290f0fb51 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -47,7 +47,7 @@ import qualified Language.PureScript.Constants as C -- return a type class dictionary reference. -- entails :: forall m. - (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> From b70991f7c8776f81f13765808f5825d6a6fcbe6e Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sat, 7 Nov 2015 12:55:04 +0200 Subject: [PATCH 0123/1580] Apply few automatic refactorings --- psc-bundle/Main.hs | 27 +++++++++++++-------------- psc-docs/Ctags.hs | 2 +- psc-docs/Etags.hs | 4 +--- psc-publish/tests/Test.hs | 4 ++-- psci/Completion.hs | 8 ++------ psci/PSCi.hs | 7 +++---- tests/Main.hs | 1 - 7 files changed, 22 insertions(+), 31 deletions(-) diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index 789fffa667..819c87a479 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -12,7 +12,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -53,16 +52,16 @@ data Options = Options -- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier. guessModuleIdentifier :: (Applicative m, MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier -guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> (guessModuleType (takeFileName filename)) +guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> guessModuleType (takeFileName filename) where guessModuleType "index.js" = pure Regular - guessModuleType "foreign.js" = pure Foreign + guessModuleType "foreign.js" = pure Foreign guessModuleType name = throwError $ UnsupportedModulePath name -- | The main application function. -- This function parses the input files, performs dead code elimination, filters empty modules -- and generates and prints the final Javascript bundle. -app :: forall m. (Applicative m, MonadError ErrorMessage m, MonadIO m) => Options -> m String +app :: (Applicative m, MonadError ErrorMessage m, MonadIO m) => Options -> m String app Options{..} = do inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles when (null inputFiles) . liftIO $ do @@ -72,11 +71,11 @@ app Options{..} = do js <- liftIO (readFile filename) mid <- guessModuleIdentifier filename return (mid, js) - - let entryIds = (map (`ModuleIdentifier` Regular) optionsEntryPoints) + + let entryIds = map (`ModuleIdentifier` Regular) optionsEntryPoints bundle input entryIds optionsMainModule optionsNamespace optionsRequirePath - + -- | Command line options parser. options :: Parser Options options = Options <$> some inputFile @@ -85,29 +84,29 @@ options = Options <$> some inputFile <*> optional mainModule <*> namespace <*> optional requirePath - where + where inputFile :: Parser FilePath inputFile = strArgument $ metavar "FILE" <> help "The input .js file(s)" - + outputFile :: Parser FilePath outputFile = strOption $ short 'o' <> long "output" <> help "The output .js file" - + entryPoint :: Parser String entryPoint = strOption $ short 'm' <> long "module" <> help "Entry point module name(s). All code which is not a transitive dependency of an entry point module will be removed." - + mainModule :: Parser String mainModule = strOption $ long "main" <> help "Generate code to run the main method in the specified module." - + namespace :: Parser String namespace = strOption $ short 'n' @@ -122,8 +121,8 @@ options = Options <$> some inputFile <> long "require-path" <> Opts.value "" <> help "The path prefix used in require() calls in the generated JavaScript" - --- | Make it go. + +-- | Make it go. main :: IO () main = do opts <- execParser (info (version <*> helper <*> options) infoModList) diff --git a/psc-docs/Ctags.hs b/psc-docs/Ctags.hs index 36355349f1..d5018eaeb3 100644 --- a/psc-docs/Ctags.hs +++ b/psc-docs/Ctags.hs @@ -5,7 +5,7 @@ import Tags import Data.List (sort) dumpCtags :: [(String, P.Module)] -> [String] -dumpCtags = sort . concat . (map renderModCtags) +dumpCtags = sort . concatMap renderModCtags renderModCtags :: (String, P.Module) -> [String] renderModCtags (path, mdl) = sort tagLines diff --git a/psc-docs/Etags.hs b/psc-docs/Etags.hs index cb3c98c76a..5aec45dd1a 100644 --- a/psc-docs/Etags.hs +++ b/psc-docs/Etags.hs @@ -4,12 +4,10 @@ import qualified Language.PureScript as P import Tags dumpEtags :: [(String, P.Module)] -> [String] -dumpEtags = concat . (map renderModEtags) +dumpEtags = concatMap renderModEtags renderModEtags :: (String, P.Module) -> [String] renderModEtags (path, mdl) = ["\x0c", path ++ "," ++ show tagsLen] ++ tagLines where tagsLen = sum $ map length tagLines tagLines = map tagLine $ tags mdl tagLine (name, line) = "\x7f" ++ name ++ "\x01" ++ show line ++ "," - - diff --git a/psc-publish/tests/Test.hs b/psc-publish/tests/Test.hs index 7e594b74d2..9ebc7a7df1 100644 --- a/psc-publish/tests/Test.hs +++ b/psc-publish/tests/Test.hs @@ -46,8 +46,8 @@ clonePackage = do readProcess "git" ["tag", "v999.0.0"] "" >>= putStr bowerInstall :: IO () -bowerInstall = do - pushd packageDir $ do +bowerInstall = + pushd packageDir $ readProcess "bower" ["install"] "" >>= putStr getPackage :: IO UploadedPackage diff --git a/psci/Completion.hs b/psci/Completion.hs index d09b9082d1..8a52463911 100644 --- a/psci/Completion.hs +++ b/psci/Completion.hs @@ -172,12 +172,8 @@ getAllQualifications sho m (declName, decl) = do let q = qualifyWith asQ' in case importType of P.Implicit -> [q] - P.Explicit refs -> if referencedBy refs - then [q] - else [] - P.Hiding refs -> if referencedBy refs - then [] - else [q] + P.Explicit refs -> [q | referencedBy refs] + P.Hiding refs -> [q | not $ referencedBy refs] -- | Returns all the ImportedModule values referring to imports of a particular diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 8a75c19f25..e78f2c07bf 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -29,7 +29,6 @@ import Data.Tuple (swap) import Data.Version (showVersion) import qualified Data.Map as M -import Control.Applicative import Control.Arrow (first) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) @@ -253,7 +252,7 @@ modulesDir = ".psci_modules" ++ pathSeparator : "node_modules" -- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the -- options and ignores the warning messages. runMake :: P.Make a -> IO (Either P.MultipleErrors a) -runMake mk = fmap fst $ P.runMake P.defaultOptions mk +runMake mk = fst <$> P.runMake P.defaultOptions mk makeIO :: (IOError -> P.ErrorMessage) -> IO a -> P.Make a makeIO f io = do @@ -441,8 +440,8 @@ getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do case firstLine of Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty Just "" -> return (Right Nothing) - Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s - Just s -> either Left (Right . Just) . parseCommand <$> go [s] + Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s + Just s -> fmap Just . parseCommand <$> go [s] where go :: [String] -> InputT (StateT PSCiState IO) String go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " " diff --git a/tests/Main.hs b/tests/Main.hs index 999d8cc91d..1b5c834dae 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -14,7 +14,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} -- Failing tests can specify the kind of error that should be thrown with a From 522a99b1fd58928de74bd2b9dfb276df34f49f9d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 7 Nov 2015 14:13:39 -0800 Subject: [PATCH 0124/1580] Fix #1175 --- examples/failing/1175.purs | 11 +++++++++++ src/Language/PureScript/Sugar/TypeDeclarations.hs | 6 +++++- 2 files changed, 16 insertions(+), 1 deletion(-) create mode 100644 examples/failing/1175.purs diff --git a/examples/failing/1175.purs b/examples/failing/1175.purs new file mode 100644 index 0000000000..13f1f703b9 --- /dev/null +++ b/examples/failing/1175.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith TypesDoNotUnify +module X where + +class Foo where + foo :: String + +instance f :: Foo where + foo = "a" + where + bar :: String + bar = 1 diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 8282dd5e02..8294d82cea 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -61,9 +61,13 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) -> let (_, f, _) = everywhereOnValuesTopDownM return go return f' (Left gs) = Left <$> mapM (pairM return f) gs f' (Right v) = Right <$> f v - (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest + (:) <$> (ValueDeclaration name nameKind bs <$> f' val) + <*> desugarTypeDeclarations rest where go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val' go other = return other + desugarTypeDeclarations (TypeInstanceDeclaration nm deps cls args (ExplicitInstance ds) : rest) = + (:) <$> (TypeInstanceDeclaration nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds) + <*> desugarTypeDeclarations rest desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds desugarTypeDeclarations [] = return [] From 0d7c8f097da8137e107adfecd7c9f21e9f40e6aa Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 7 Nov 2015 14:57:54 -0800 Subject: [PATCH 0125/1580] Fix #1335, track scoped type variables when skolemizing --- .../PureScript/TypeChecker/Skolems.hs | 28 +++++++++++++------ 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 6dcc887194..a5c0514272 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -29,6 +29,7 @@ import Prelude.Compat import Data.List (nub, (\\)) import Data.Monoid +import Data.Functor.Identity (Identity(), runIdentity) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets, modify) @@ -38,6 +39,7 @@ import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types +import Language.PureScript.Traversals (defS) -- | -- Generate a new skolem constant @@ -78,16 +80,26 @@ skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope) -- only example of scoped type variables. -- skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr -skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id onExpr onBinder in f +skolemizeTypesInValue ident sko scope = + let + (_, f, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS + in runIdentity . f where - onExpr :: Expr -> Expr - onExpr (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts) - onExpr (TypedValue check val ty) = TypedValue check val (skolemize ident sko scope ty) - onExpr other = other + onExpr :: [String] -> Expr -> Identity ([String], Expr) + onExpr sco (SuperClassDictionary c ts) + | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope) ts)) + onExpr sco (TypedValue check val ty) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ty)) + onExpr sco other = return (sco, other) - onBinder :: Binder -> Binder - onBinder (TypedBinder ty b) = TypedBinder (skolemize ident sko scope ty) b - onBinder other = other + onBinder :: [String] -> Binder -> Identity ([String], Binder) + onBinder sco (TypedBinder ty b) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ty) b) + onBinder sco other = return (sco, other) + + peelTypeVars :: Type -> [String] + peelTypeVars (ForAll i ty _) = i : peelTypeVars ty + peelTypeVars _ = [] -- | -- Ensure skolem variables do not escape their scope From 79e7a092778d89481cb2a1f27b3212be2420be05 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 7 Nov 2015 14:58:44 -0800 Subject: [PATCH 0126/1580] Add test case --- examples/passing/1335.purs | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 examples/passing/1335.purs diff --git a/examples/passing/1335.purs b/examples/passing/1335.purs new file mode 100644 index 0000000000..e2a7347923 --- /dev/null +++ b/examples/passing/1335.purs @@ -0,0 +1,12 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +x :: forall a. a -> String +x a = y "Done" + where + y :: forall a. (Show a) => a -> String + y a = show (a :: a) + +main = log (x 0) From f090fbdfc76a231fc5c9c947798198f00f72c019 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 7 Nov 2015 15:03:39 -0800 Subject: [PATCH 0127/1580] Fix #1591, use the 'negate' in scope --- src/Language/PureScript/Sugar/Operators.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index ffc069c636..5934b9fe39 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -66,7 +66,7 @@ removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) where (f', _, _) = everywhereOnValues id go id - go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val + go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val go other = other rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module From 5c16e8544e8d17faf7555565056ff86969749aea Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 7 Nov 2015 18:23:32 -0800 Subject: [PATCH 0128/1580] Fix #1590, limit depth of pretty-printed expressions --- src/Language/PureScript/Errors.hs | 24 ++-- src/Language/PureScript/Pretty/Values.hs | 142 ++++++++++++----------- 2 files changed, 88 insertions(+), 78 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 427379e5ea..261052ee4c 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -513,7 +513,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError renderSimpleErrorMessage (EscapedSkolem binding) = paras $ [ line "A type variable has escaped its scope." ] <> foldMap (\expr -> [ line "Relevant expression: " - , indent $ prettyPrintValue expr + , indent $ prettyPrintValue valueDepth expr ]) binding renderSimpleErrorMessage (TypesDoNotUnify t1 t2) = paras [ line "Could not match type" @@ -568,7 +568,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError renderSimpleErrorMessage (DuplicateLabel l expr) = paras $ [ line $ "Label " ++ show l ++ " appears more than once in a row type." ] <> foldMap (\expr' -> [ line "Relevant expression: " - , indent $ prettyPrintValue expr' + , indent $ prettyPrintValue valueDepth expr' ]) expr renderSimpleErrorMessage (DuplicateTypeArgument name) = line $ "Type argument " ++ show name ++ " appears more than once." @@ -594,7 +594,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError line $ "Data constructor " ++ showQualified runProperName nm ++ " was given the wrong number of arguments in a case expression." renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) = paras [ line "Expression" - , indent $ prettyPrintValue expr + , indent $ prettyPrintValue valueDepth expr , line "does not have type" , indent $ typeAsBox ty ] @@ -606,7 +606,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError paras [ line "A function of type" , indent $ typeAsBox fn , line "can not be applied to the argument" - , indent $ prettyPrintValue arg + , indent $ prettyPrintValue valueDepth arg ] renderSimpleErrorMessage TypeSynonymInstance = line "Type class instances for type synonyms are disallowed." @@ -693,7 +693,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError renderHint (ErrorInExpression expr) detail = paras [ detail , Box.hsep 1 Box.top [ Box.text "in the expression" - , prettyPrintValue expr + , prettyPrintValue valueDepth expr ] ] renderHint (ErrorInModule mn) detail = @@ -729,13 +729,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError renderHint (ErrorInferringType expr) detail = paras [ detail , Box.hsep 1 Box.top [ line "while inferring the type of" - , prettyPrintValue expr + , prettyPrintValue valueDepth expr ] ] renderHint (ErrorCheckingType expr ty) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking that expression" - , prettyPrintValue expr + , prettyPrintValue valueDepth expr ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type" , typeAsBox ty @@ -744,19 +744,19 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError renderHint (ErrorCheckingAccessor expr prop) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking type of property accessor" - , prettyPrintValue (Accessor prop expr) + , prettyPrintValue valueDepth (Accessor prop expr) ] ] renderHint (ErrorInApplication f t a) detail = paras [ detail , Box.hsep 1 Box.top [ line "while applying a function" - , prettyPrintValue f + , prettyPrintValue valueDepth f ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type" , typeAsBox t ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument" - , prettyPrintValue a + , prettyPrintValue valueDepth a ] ] renderHint (ErrorInDataConstructor nm) detail = @@ -796,6 +796,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , detail ] + valueDepth :: Int + valueDepth | full = 1000 + | otherwise = 3 + levelText :: String levelText = case level of Error -> "error" diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 79d9f5cb04..3064bc2ef9 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -38,101 +38,107 @@ list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ cl where toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a -prettyPrintObject :: [(String, Maybe Expr)] -> Box -prettyPrintObject = list '{' '}' prettyPrintObjectProperty +ellipsis :: Box +ellipsis = text "..." + +prettyPrintObject :: Int -> [(String, Maybe Expr)] -> Box +prettyPrintObject d = list '{' '}' prettyPrintObjectProperty where prettyPrintObjectProperty :: (String, Maybe Expr) -> Box - prettyPrintObjectProperty (key, value) = text (prettyPrintObjectKey key ++ ": ") <> maybe (text "_") prettyPrintValue value + prettyPrintObjectProperty (key, value) = text (prettyPrintObjectKey key ++ ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value -- | Pretty-print an expression -prettyPrintValue :: Expr -> Box -prettyPrintValue (IfThenElse cond th el) = - (text "if " <> prettyPrintValueAtom cond) - // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom th - , text "else " <> prettyPrintValueAtom el +prettyPrintValue :: Int -> Expr -> Box +prettyPrintValue d _ | d < 0 = text "..." +prettyPrintValue d (IfThenElse cond th el) = + (text "if " <> prettyPrintValueAtom (d - 1) cond) + // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th + , text "else " <> prettyPrintValueAtom (d - 1) el ]) -prettyPrintValue (Accessor prop val) = prettyPrintValueAtom val <> text ("." ++ show prop) -prettyPrintValue (ObjectUpdate o ps) = prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue val) ps -prettyPrintValue (ObjectUpdater o ps) = maybe (text "_") prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") prettyPrintValue val) ps -prettyPrintValue (App val arg) = prettyPrintValueAtom val `beforeWithSpace` prettyPrintValueAtom arg -prettyPrintValue (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue val) -prettyPrintValue (TypeClassDictionaryConstructorApp className ps) = - text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom ps -prettyPrintValue (Case values binders) = - (text "case " <> foldl1 beforeWithSpace (map prettyPrintValueAtom values) <> text " of") // - moveRight 2 (vcat left (map prettyPrintCaseAlternative binders)) -prettyPrintValue (Let ds val) = +prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ show prop) +prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps +prettyPrintValue d (ObjectUpdater o ps) = maybe (text "_") (prettyPrintValueAtom (d - 1)) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") (prettyPrintValue (d - 1)) val) ps +prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg +prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) +prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) = + text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom (d - 1) ps +prettyPrintValue d (Case values binders) = + (text "case " <> foldl1 beforeWithSpace (map (prettyPrintValueAtom (d - 1)) values) <> text " of") // + moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders)) +prettyPrintValue d (Let ds val) = text "let" // - moveRight 2 (vcat left (map prettyPrintDeclaration ds)) // - (text "in " <> prettyPrintValue val) -prettyPrintValue (Do els) = - text "do " <> vcat left (map prettyPrintDoNotationElement els) -prettyPrintValue (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys -prettyPrintValue (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) -prettyPrintValue (TypedValue _ val _) = prettyPrintValue val -prettyPrintValue (PositionedValue _ _ val) = prettyPrintValue val -prettyPrintValue expr = prettyPrintValueAtom expr + moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) // + (text "in " <> prettyPrintValue (d - 1) val) +prettyPrintValue d (Do els) = + text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) +prettyPrintValue _ (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys +prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) +prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val +prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val +prettyPrintValue d expr = prettyPrintValueAtom d expr -- | Pretty-print an atomic expression, adding parentheses if necessary. -prettyPrintValueAtom :: Expr -> Box -prettyPrintValueAtom (NumericLiteral n) = text $ either show show n -prettyPrintValueAtom (StringLiteral s) = text $ show s -prettyPrintValueAtom (CharLiteral c) = text $ show c -prettyPrintValueAtom (BooleanLiteral True) = text "true" -prettyPrintValueAtom (BooleanLiteral False) = text "false" -prettyPrintValueAtom (ArrayLiteral xs) = list '[' ']' prettyPrintValue xs -prettyPrintValueAtom (ObjectLiteral ps) = prettyPrintObject $ second Just `map` ps -prettyPrintValueAtom (ObjectConstructor ps) = prettyPrintObject ps -prettyPrintValueAtom (ObjectGetter prop) = text $ "_." ++ show prop -prettyPrintValueAtom (Constructor name) = text $ runProperName (disqualify name) -prettyPrintValueAtom (Var ident) = text $ showIdent (disqualify ident) -prettyPrintValueAtom (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue op) `beforeWithSpace` prettyPrintValue val) `before` text ")" -prettyPrintValueAtom (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue val) `beforeWithSpace` prettyPrintValue op) `before` text ")" -prettyPrintValueAtom (TypedValue _ val _) = prettyPrintValueAtom val -prettyPrintValueAtom (PositionedValue _ _ val) = prettyPrintValueAtom val -prettyPrintValueAtom expr = (text "(" <> prettyPrintValue expr) `before` text ")" - -prettyPrintDeclaration :: Declaration -> Box -prettyPrintDeclaration (TypeDeclaration ident ty) = +prettyPrintValueAtom :: Int -> Expr -> Box +prettyPrintValueAtom _ (NumericLiteral n) = text $ either show show n +prettyPrintValueAtom _ (StringLiteral s) = text $ show s +prettyPrintValueAtom _ (CharLiteral c) = text $ show c +prettyPrintValueAtom _ (BooleanLiteral True) = text "true" +prettyPrintValueAtom _ (BooleanLiteral False) = text "false" +prettyPrintValueAtom d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs +prettyPrintValueAtom d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps +prettyPrintValueAtom d (ObjectConstructor ps) = prettyPrintObject (d - 1) ps +prettyPrintValueAtom _ (ObjectGetter prop) = text $ "_." ++ show prop +prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name) +prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident) +prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")" +prettyPrintValueAtom d (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue (d - 1) val) `beforeWithSpace` prettyPrintValue (d - 1) op) `before` text ")" +prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val +prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val +prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")" + +prettyPrintDeclaration :: Int -> Declaration -> Box +prettyPrintDeclaration d _ | d < 0 = ellipsis +prettyPrintDeclaration _ (TypeDeclaration ident ty) = text (showIdent ident ++ " :: ") <> typeAsBox ty -prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = - text (showIdent ident ++ " = ") <> prettyPrintValue val -prettyPrintDeclaration (BindingGroupDeclaration ds) = - vsep 1 left (map (prettyPrintDeclaration . toDecl) ds) +prettyPrintDeclaration d (ValueDeclaration ident _ [] (Right val)) = + text (showIdent ident ++ " = ") <> prettyPrintValue (d - 1) val +prettyPrintDeclaration d (BindingGroupDeclaration ds) = + vsep 1 left (map (prettyPrintDeclaration (d - 1) . toDecl) ds) where toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e) -prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d -prettyPrintDeclaration _ = internalError "Invalid argument to prettyPrintDeclaration" +prettyPrintDeclaration d (PositionedDeclaration _ _ decl) = prettyPrintDeclaration d decl +prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration" -prettyPrintCaseAlternative :: CaseAlternative -> Box -prettyPrintCaseAlternative (CaseAlternative binders result) = +prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box +prettyPrintCaseAlternative d _ | d < 0 = ellipsis +prettyPrintCaseAlternative d (CaseAlternative binders result) = text (unwords (map prettyPrintBinderAtom binders)) <> prettyPrintResult result where prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box prettyPrintResult (Left gs) = vcat left (map prettyPrintGuardedValue gs) - prettyPrintResult (Right v) = text " -> " <> prettyPrintValue v + prettyPrintResult (Right v) = text " -> " <> prettyPrintValue (d - 1) v prettyPrintGuardedValue :: (Guard, Expr) -> Box prettyPrintGuardedValue (grd, val) = foldl1 before [ text " | " - , prettyPrintValue grd + , prettyPrintValue (d - 1) grd , text " -> " - , prettyPrintValue val + , prettyPrintValue (d - 1) val ] -prettyPrintDoNotationElement :: DoNotationElement -> Box -prettyPrintDoNotationElement (DoNotationValue val) = - prettyPrintValue val -prettyPrintDoNotationElement (DoNotationBind binder val) = - text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue val -prettyPrintDoNotationElement (DoNotationLet ds) = +prettyPrintDoNotationElement :: Int -> DoNotationElement -> Box +prettyPrintDoNotationElement d _ | d < 0 = ellipsis +prettyPrintDoNotationElement d (DoNotationValue val) = + prettyPrintValue d val +prettyPrintDoNotationElement d (DoNotationBind binder val) = + text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue d val +prettyPrintDoNotationElement d (DoNotationLet ds) = text "let" // - moveRight 2 (vcat left (map prettyPrintDeclaration ds)) -prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el + moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) +prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el prettyPrintBinderAtom :: Binder -> String - prettyPrintBinderAtom NullBinder = "_" prettyPrintBinderAtom (StringBinder str) = show str prettyPrintBinderAtom (CharBinder c) = show c From c0274e295769afba31db48c653e19150020f5642 Mon Sep 17 00:00:00 2001 From: Konstantin Zudov Date: Sun, 8 Nov 2015 07:56:12 +0200 Subject: [PATCH 0129/1580] Missing space in an error message --- src/Language/PureScript/Errors.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 427379e5ea..e8e14158e8 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -577,7 +577,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError renderSimpleErrorMessage (ArgListLengthsDiffer ident) = line $ "Argument list lengths differ in declaration " ++ showIdent ident renderSimpleErrorMessage (OverlappingArgNames ident) = - line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident + line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration " ++) . showIdent) ident renderSimpleErrorMessage (MissingClassMember ident) = line $ "Type class member " ++ showIdent ident ++ " has not been implemented." renderSimpleErrorMessage (ExtraneousClassMember ident className) = From 94cc306efa3446b0d9eeae67bdc41ca278f0e53a Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sat, 7 Nov 2015 13:32:06 +0200 Subject: [PATCH 0130/1580] Reformat files to unix line-endings --- .../PureScript/Sugar/TypeClasses/Deriving.hs | 464 +++++++++--------- 1 file changed, 232 insertions(+), 232 deletions(-) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index d82e655203..156430dedc 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -1,232 +1,232 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Sugar.TypeClasses.Deriving --- Copyright : (c) Gershom Bazerman 2015 --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- This module implements the generic deriving elaboration that takes place during desugaring. --- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.PureScript.Sugar.TypeClasses.Deriving ( - deriveInstances -) where - -import Prelude () -import Prelude.Compat - -import Data.List (foldl', find, sortBy) -import Data.Maybe (fromMaybe) -import Data.Ord (comparing) - -import Control.Monad (replicateM) -import Control.Monad.Supply.Class (MonadSupply, freshName) -import Control.Monad.Error.Class (MonadError(..)) - -import Language.PureScript.Crash -import Language.PureScript.AST -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.Types -import qualified Language.PureScript.Constants as C - --- | Elaborates deriving instance declarations by code generation. -deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module -deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts - --- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration, --- elaborates that into an instance declaration via code generation. -deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration -deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance) - | className == Qualified (Just dataGeneric) (ProperName C.generic) - , Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty - , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon -deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) - = throwError . errorMessage $ CannotDerive className tys -deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d -deriveInstance _ _ e = return e - -unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName) -unwrapTypeConstructor (TypeConstructor tyCon) = Just tyCon -unwrapTypeConstructor (TypeApp ty (TypeVar _)) = unwrapTypeConstructor ty -unwrapTypeConstructor _ = Nothing - -dataGeneric :: ModuleName -dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] - -dataMaybe :: ModuleName -dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ] - -deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> m [Declaration] -deriveGeneric mn ds tyConNm = do - tyCon <- findTypeDecl tyConNm ds - toSpine <- mkSpineFunction mn tyCon - fromSpine <- mkFromSpineFunction mn tyCon - let toSignature = mkSignatureFunction mn tyCon - return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine) - , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine) - , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature) - ] - -findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration -findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl - where - isTypeDecl :: Declaration -> Bool - isTypeDecl (DataDeclaration _ nm _ _) | nm == tyConNm = True - isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d - isTypeDecl _ = False - -mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr -mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args - where - prodConstructor :: Expr -> Expr - prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd"))) - - recordConstructor :: Expr -> Expr - recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord"))) - - mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative - mkCtorClause (ctorName, tys) = do - idents <- replicateM (length tys) (fmap Ident freshName) - return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents)) - where - caseResult idents = - App (prodConstructor (StringLiteral . runProperName $ ctorName)) - . ArrayLiteral - $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys - - toSpineFun :: Expr -> Type -> Expr - toSpineFun i r | Just rec <- objectType r = - lamNull . recordConstructor . ArrayLiteral . - map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)]) - $ decomposeRec rec - toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i -mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d -mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration" - -mkSignatureFunction :: ModuleName -> Declaration -> Expr -mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args - where - mkSigProd :: [Expr] -> Expr - mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral - - mkSigRec :: [Expr] -> Expr - mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral - - proxy :: Type -> Type - proxy = TypeApp (TypeConstructor (Qualified (Just dataGeneric) (ProperName "Proxy"))) - - mkProdClause :: (ProperName, [Type]) -> Expr - mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName)) - , ("sigValues", ArrayLiteral . map mkProductSignature $ tys) - ] - - mkProductSignature :: Type -> Expr - mkProductSignature r | Just rec <- objectType r = - lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str) - , ("recValue", mkProductSignature typ) - ] - | (str, typ) <- decomposeRec rec - ] - mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature) - (TypedValue False (mkGenVar "anyProxy") (proxy typ)) -mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d -mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration" - -mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr -mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args) - where - mkJust :: Expr -> Expr - mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just"))) - - mkNothing :: Expr - mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing")) - - prodBinder :: [Binder] -> Binder - prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd")) - - recordBinder :: [Binder] -> Binder - recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord")) - - mkAlternative :: (ProperName, [Type]) -> m CaseAlternative - mkAlternative (ctorName, tys) = do - idents <- replicateM (length tys) (fmap Ident freshName) - return $ CaseAlternative [ prodBinder [ StringBinder (runProperName ctorName), ArrayBinder (map VarBinder idents)]] - . Right - $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName)) - (zipWith fromSpineFun (map (Var . (Qualified Nothing)) idents) tys) - - addCatch :: [CaseAlternative] -> [CaseAlternative] - addCatch = (++ [catchAll]) - where - catchAll = CaseAlternative [NullBinder] (Right mkNothing) - - fromSpineFun e r - | Just rec <- objectType r - = App (lamCase "r" [ mkRecCase (decomposeRec rec) - , CaseAlternative [NullBinder] (Right mkNothing) - ]) - (App e (mkPrelVar "unit")) - - fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit")) - - mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs) - ] - ] - . Right - $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs) - - mkRecFun :: [(String, Type)] -> Expr - mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs) - where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs -mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d -mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration" - --- Helpers - -objectType :: Type -> Maybe Type -objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec -objectType _ = Nothing - -lam :: String -> Expr -> Expr -lam s = Abs (Left (Ident s)) - -lamNull :: Expr -> Expr -lamNull = lam "$q" - -lamCase :: String -> [CaseAlternative] -> Expr -lamCase s = lam s . Case [mkVar s] - -liftApplicative :: Expr -> [Expr] -> Expr -liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e) - -mkVarMn :: Maybe ModuleName -> String -> Expr -mkVarMn mn s = Var (Qualified mn (Ident s)) - -mkVar :: String -> Expr -mkVar s = mkVarMn Nothing s - -mkPrelVar :: String -> Expr -mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s - -mkGenVar :: String -> Expr -mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) s - -decomposeRec :: Type -> [(String, Type)] -decomposeRec = sortBy (comparing fst) . go - where go (RCons str typ typs) = (str, typ) : decomposeRec typs - go _ = [] +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Sugar.TypeClasses.Deriving +-- Copyright : (c) Gershom Bazerman 2015 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- This module implements the generic deriving elaboration that takes place during desugaring. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.PureScript.Sugar.TypeClasses.Deriving ( + deriveInstances +) where + +import Prelude () +import Prelude.Compat + +import Data.List (foldl', find, sortBy) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) + +import Control.Monad (replicateM) +import Control.Monad.Supply.Class (MonadSupply, freshName) +import Control.Monad.Error.Class (MonadError(..)) + +import Language.PureScript.Crash +import Language.PureScript.AST +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Names +import Language.PureScript.Types +import qualified Language.PureScript.Constants as C + +-- | Elaborates deriving instance declarations by code generation. +deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module +deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts + +-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration, +-- elaborates that into an instance declaration via code generation. +deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration +deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance) + | className == Qualified (Just dataGeneric) (ProperName C.generic) + , Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty + , mn == fromMaybe mn mn' + = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon +deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) + = throwError . errorMessage $ CannotDerive className tys +deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d +deriveInstance _ _ e = return e + +unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName) +unwrapTypeConstructor (TypeConstructor tyCon) = Just tyCon +unwrapTypeConstructor (TypeApp ty (TypeVar _)) = unwrapTypeConstructor ty +unwrapTypeConstructor _ = Nothing + +dataGeneric :: ModuleName +dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] + +dataMaybe :: ModuleName +dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ] + +deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> m [Declaration] +deriveGeneric mn ds tyConNm = do + tyCon <- findTypeDecl tyConNm ds + toSpine <- mkSpineFunction mn tyCon + fromSpine <- mkFromSpineFunction mn tyCon + let toSignature = mkSignatureFunction mn tyCon + return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine) + , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine) + , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature) + ] + +findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration +findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl + where + isTypeDecl :: Declaration -> Bool + isTypeDecl (DataDeclaration _ nm _ _) | nm == tyConNm = True + isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d + isTypeDecl _ = False + +mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr +mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args + where + prodConstructor :: Expr -> Expr + prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd"))) + + recordConstructor :: Expr -> Expr + recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord"))) + + mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative + mkCtorClause (ctorName, tys) = do + idents <- replicateM (length tys) (fmap Ident freshName) + return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents)) + where + caseResult idents = + App (prodConstructor (StringLiteral . runProperName $ ctorName)) + . ArrayLiteral + $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys + + toSpineFun :: Expr -> Type -> Expr + toSpineFun i r | Just rec <- objectType r = + lamNull . recordConstructor . ArrayLiteral . + map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)]) + $ decomposeRec rec + toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i +mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d +mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration" + +mkSignatureFunction :: ModuleName -> Declaration -> Expr +mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args + where + mkSigProd :: [Expr] -> Expr + mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral + + mkSigRec :: [Expr] -> Expr + mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral + + proxy :: Type -> Type + proxy = TypeApp (TypeConstructor (Qualified (Just dataGeneric) (ProperName "Proxy"))) + + mkProdClause :: (ProperName, [Type]) -> Expr + mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName)) + , ("sigValues", ArrayLiteral . map mkProductSignature $ tys) + ] + + mkProductSignature :: Type -> Expr + mkProductSignature r | Just rec <- objectType r = + lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str) + , ("recValue", mkProductSignature typ) + ] + | (str, typ) <- decomposeRec rec + ] + mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature) + (TypedValue False (mkGenVar "anyProxy") (proxy typ)) +mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d +mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration" + +mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr +mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args) + where + mkJust :: Expr -> Expr + mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just"))) + + mkNothing :: Expr + mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing")) + + prodBinder :: [Binder] -> Binder + prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd")) + + recordBinder :: [Binder] -> Binder + recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord")) + + mkAlternative :: (ProperName, [Type]) -> m CaseAlternative + mkAlternative (ctorName, tys) = do + idents <- replicateM (length tys) (fmap Ident freshName) + return $ CaseAlternative [ prodBinder [ StringBinder (runProperName ctorName), ArrayBinder (map VarBinder idents)]] + . Right + $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName)) + (zipWith fromSpineFun (map (Var . (Qualified Nothing)) idents) tys) + + addCatch :: [CaseAlternative] -> [CaseAlternative] + addCatch = (++ [catchAll]) + where + catchAll = CaseAlternative [NullBinder] (Right mkNothing) + + fromSpineFun e r + | Just rec <- objectType r + = App (lamCase "r" [ mkRecCase (decomposeRec rec) + , CaseAlternative [NullBinder] (Right mkNothing) + ]) + (App e (mkPrelVar "unit")) + + fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit")) + + mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs) + ] + ] + . Right + $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs) + + mkRecFun :: [(String, Type)] -> Expr + mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs) + where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs +mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d +mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration" + +-- Helpers + +objectType :: Type -> Maybe Type +objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec +objectType _ = Nothing + +lam :: String -> Expr -> Expr +lam s = Abs (Left (Ident s)) + +lamNull :: Expr -> Expr +lamNull = lam "$q" + +lamCase :: String -> [CaseAlternative] -> Expr +lamCase s = lam s . Case [mkVar s] + +liftApplicative :: Expr -> [Expr] -> Expr +liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e) + +mkVarMn :: Maybe ModuleName -> String -> Expr +mkVarMn mn s = Var (Qualified mn (Ident s)) + +mkVar :: String -> Expr +mkVar s = mkVarMn Nothing s + +mkPrelVar :: String -> Expr +mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s + +mkGenVar :: String -> Expr +mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) s + +decomposeRec :: Type -> [(String, Type)] +decomposeRec = sortBy (comparing fst) . go + where go (RCons str typ typs) = (str, typ) : decomposeRec typs + go _ = [] From fb13db912a1a661fe2da98ae5e91762a80677111 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sat, 7 Nov 2015 19:52:16 +0200 Subject: [PATCH 0131/1580] Apply few more automatic refactorings --- src/Language/PureScript.hs | 1 - src/Language/PureScript/Bundle.hs | 3 +-- src/Language/PureScript/Docs/Render.hs | 4 +--- src/Language/PureScript/Linter.hs | 1 - src/Language/PureScript/Parser/Lexer.hs | 2 +- src/Language/PureScript/Pretty/Types.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses/Deriving.hs | 10 +++++----- 7 files changed, 9 insertions(+), 14 deletions(-) diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index 06812a2cc7..ea6b19570e 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -15,7 +15,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 2d2fc92c3f..cee556fdf8 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -19,7 +19,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE RecordWildCards #-} module Language.PureScript.Bundle ( bundle @@ -531,7 +530,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem -- | The bundling function. -- This function performs dead code elimination, filters empty modules -- and generates and prints the final Javascript bundle. -bundle :: forall m. (Applicative m, MonadError ErrorMessage m) +bundle :: (Applicative m, MonadError ErrorMessage m) => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination -> Maybe String -- ^ An optional main module. diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index ec290be9dc..a19ecebec0 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -49,9 +49,7 @@ renderDeclarationWithOptions opts Declaration{..} = [ keywordClass ] ++ maybeToList superclasses ++ [renderType' (typeApp declTitle args)] - ++ if any (isTypeClassMember . cdeclInfo) declChildren - then [keywordWhere] - else [] + ++ [keywordWhere | any (isTypeClassMember . cdeclInfo) declChildren] where superclasses diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index c3eef817df..10991c8cc1 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -12,7 +12,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index a4a285747a..acdb940f96 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -158,7 +158,7 @@ instance Show PositionedToken where show = prettyPrintToken . ptToken lex :: FilePath -> String -> Either P.ParseError [PositionedToken] -lex filePath input = P.parse parseTokens filePath input +lex = P.parse parseTokens parseTokens :: P.Parsec String u [PositionedToken] parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 20ceabe54b..717e610b94 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -133,7 +133,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom ] , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ] , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ] - , [ Wrap kinded $ \k ty -> ty `before` (text (" :: " ++ prettyPrintKind k)) ] + , [ Wrap kinded $ \k ty -> ty `before` text (" :: " ++ prettyPrintKind k) ] ] forall_ :: Pattern () Type ([String], Type) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 156430dedc..f9c8926a41 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -168,7 +168,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch return $ CaseAlternative [ prodBinder [ StringBinder (runProperName ctorName), ArrayBinder (map VarBinder idents)]] . Right $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName)) - (zipWith fromSpineFun (map (Var . (Qualified Nothing)) idents) tys) + (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys) addCatch :: [CaseAlternative] -> [CaseAlternative] addCatch = (++ [catchAll]) @@ -191,7 +191,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs) mkRecFun :: [(String, Type)] -> Expr - mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs) + mkRecFun xs = mkJust $ foldr lam recLiteral (map fst xs) where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration" @@ -218,13 +218,13 @@ mkVarMn :: Maybe ModuleName -> String -> Expr mkVarMn mn s = Var (Qualified mn (Ident s)) mkVar :: String -> Expr -mkVar s = mkVarMn Nothing s +mkVar = mkVarMn Nothing mkPrelVar :: String -> Expr -mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s +mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude])) mkGenVar :: String -> Expr -mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) s +mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) decomposeRec :: Type -> [(String, Type)] decomposeRec = sortBy (comparing fst) . go From 7b4222cb4effe35436655da6caec8b07f6e3659e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 8 Nov 2015 15:14:19 -0800 Subject: [PATCH 0132/1580] Fix #1090, allow accessors in operator sections --- examples/passing/OperatorSections.purs | 6 +++++ .../PureScript/Parser/Declarations.hs | 22 +++++++++++-------- 2 files changed, 19 insertions(+), 9 deletions(-) diff --git a/examples/passing/OperatorSections.purs b/examples/passing/OperatorSections.purs index a9c426caed..0143d346cd 100644 --- a/examples/passing/OperatorSections.purs +++ b/examples/passing/OperatorSections.purs @@ -8,4 +8,10 @@ main = do assert $ (2.0 /) 4.0 == 0.5 assert $ (`const` 1.0) 2.0 == 2.0 assert $ (1.0 `const`) 2.0 == 1.0 + let foo = { x: 2.0 } + assert $ (/ foo.x) 4.0 == 2.0 + assert $ (foo.x /) 4.0 == 0.5 + let (//) x y = x.x / y.x + assert $ (// foo { x = 4.0 }) { x: 4.0 } == 1.0 + assert $ (foo { x = 4.0 } //) { x: 4.0 } == 1.0 Control.Monad.Eff.Console.log "Done!" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 3a5be3be1f..6f0b73654c 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -414,8 +414,8 @@ parseInfixExpr = P.between tick tick parseValue parseOperatorSection :: TokenParser Expr parseOperatorSection = parens $ left <|> right where - right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> parseValueAtom) - left = flip OperatorSection <$> (Left <$> parseValueAtom) <* indented <*> parseInfixExpr + right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> indexersAndAccessors) + left = flip OperatorSection <$> (Left <$> indexersAndAccessors) <* indented <*> parseInfixExpr parsePropertyUpdate :: TokenParser (String, Maybe Expr) parsePropertyUpdate = do @@ -449,21 +449,25 @@ parseDoNotationElement = P.choice parseObjectGetter :: TokenParser Expr parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) +-- | Expressions including indexers and record updates +indexersAndAccessors :: TokenParser Expr +indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom + where + postfixTable = [ parseAccessor + , P.try . parseUpdaterBody . Just ] + -- | -- Parse a value -- parseValue :: TokenParser Expr parseValue = withSourceSpan PositionedValue (P.buildExpressionParser operators - . C.buildPostfixParser postfixTable2 + . C.buildPostfixParser postfixTable $ indexersAndAccessors) P. "expression" where - indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom - postfixTable1 = [ parseAccessor - , P.try . parseUpdaterBody . Just ] - postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v - , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v - ] + postfixTable = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v + , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v + ] operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus) ] , [ P.Infix (P.try (C.indented *> parseInfixExpr P. "infix expression") >>= \ident -> From eae6a4d1fd9aa91e8c686071f2667e1daa3eb8a7 Mon Sep 17 00:00:00 2001 From: "Balaji R. Rao" Date: Mon, 9 Nov 2015 00:44:35 +0530 Subject: [PATCH 0133/1580] Record constructor field puns, fix #921 --- examples/passing/FieldConsPuns.purs | 10 ++++++++++ src/Language/PureScript/Parser/Declarations.hs | 9 +++++++-- 2 files changed, 17 insertions(+), 2 deletions(-) create mode 100644 examples/passing/FieldConsPuns.purs diff --git a/examples/passing/FieldConsPuns.purs b/examples/passing/FieldConsPuns.purs new file mode 100644 index 0000000000..9a775e050e --- /dev/null +++ b/examples/passing/FieldConsPuns.purs @@ -0,0 +1,10 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console + +greet { greeting, name } = log $ greeting <> ", " <> name <> "." + +main = greet { greeting, name} where + greeting = "Hello" + name = "World" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 3a5be3be1f..59c0f22dc1 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -334,9 +334,14 @@ parseObjectLiteral :: TokenParser Expr parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue) parseIdentifierAndValue :: TokenParser (String, Maybe Expr) -parseIdentifierAndValue = (,) <$> (C.indented *> (lname <|> stringLiteral) <* C.indented <* colon) - <*> (C.indented *> val) +parseIdentifierAndValue = + do + name <- C.indented *> lname + b <- P.option (Just $ Var $ Qualified Nothing (Ident name)) rest + return (name, b) + <|> (,) <$> (C.indented *> stringLiteral) <*> rest where + rest = C.indented *> colon *> C.indented *> val val = (Just <$> parseValue) <|> (underscore *> pure Nothing) parseAbs :: TokenParser Expr From 177db3e4dd2011e5df017d6c145d778c6e0d5ee5 Mon Sep 17 00:00:00 2001 From: Michael Ficarra Date: Tue, 10 Nov 2015 19:22:55 -0800 Subject: [PATCH 0134/1580] fixes #1602: escape sequences for characters with code point below 0x10 --- examples/passing/StringEscapes.purs | 13 +++++++++++++ src/Language/PureScript/Pretty/JS.hs | 1 + 2 files changed, 14 insertions(+) create mode 100644 examples/passing/StringEscapes.purs diff --git a/examples/passing/StringEscapes.purs b/examples/passing/StringEscapes.purs new file mode 100644 index 0000000000..cad3ebeb05 --- /dev/null +++ b/examples/passing/StringEscapes.purs @@ -0,0 +1,13 @@ +module Main where + +import Prelude ((==), bind) +import Test.Assert (assert) + +singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C" +hex = "\x1d306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0" +decimal = "\119558\9731\966\224\0" == "𝌆☃φà\0" + +main = do + assert singleCharacter + assert hex + assert decimal diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 0bab0c6fe1..7707e65e82 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -166,6 +166,7 @@ string s = '"' : concatMap encodeChar s ++ "\"" encodeChar '\\' = "\\\\" encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) "" encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) "" + encodeChar c | fromEnum c < 0x10 = "\\x0" ++ showHex (fromEnum c) "" encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) "" encodeChar c = [c] From cf1d81deeb9e076bdf1ce99d0ca078b6c5f77780 Mon Sep 17 00:00:00 2001 From: Michael Ficarra Date: Tue, 10 Nov 2015 19:58:28 -0800 Subject: [PATCH 0135/1580] support escapes for characters outside of BMP (code points > 0xFFFF) --- examples/passing/StringEscapes.purs | 4 +++- src/Language/PureScript/Pretty/JS.hs | 5 +++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/examples/passing/StringEscapes.purs b/examples/passing/StringEscapes.purs index cad3ebeb05..2d9774420d 100644 --- a/examples/passing/StringEscapes.purs +++ b/examples/passing/StringEscapes.purs @@ -4,10 +4,12 @@ import Prelude ((==), bind) import Test.Assert (assert) singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C" -hex = "\x1d306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0" +hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0" decimal = "\119558\9731\966\224\0" == "𝌆☃φà\0" +surrogatePair = "\xD834\xDF06" == "\x1D306" main = do assert singleCharacter assert hex assert decimal + assert surrogatePair diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 7707e65e82..4bb53f1c0c 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -164,6 +164,11 @@ string s = '"' : concatMap encodeChar s ++ "\"" encodeChar '\r' = "\\r" encodeChar '"' = "\\\"" encodeChar '\\' = "\\\\" + encodeChar c | fromEnum c > 0xFFFF = "\\u" ++ showHex highSurrogate "" ++ "\\u" ++ showHex lowSurrogate "" + where + (h, l) = divMod (fromEnum c - 0x10000) 0x400 + highSurrogate = h + 0xD800 + lowSurrogate = l + 0xDC00 encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) "" encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) "" encodeChar c | fromEnum c < 0x10 = "\\x0" ++ showHex (fromEnum c) "" From 618c99086115928654d957a1c46f84f3d8cc11ac Mon Sep 17 00:00:00 2001 From: Michael Ficarra Date: Wed, 11 Nov 2015 11:41:36 -0800 Subject: [PATCH 0136/1580] small optimisation in encodeChar --- src/Language/PureScript/Pretty/JS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 4bb53f1c0c..2a1f6e0016 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -164,7 +164,7 @@ string s = '"' : concatMap encodeChar s ++ "\"" encodeChar '\r' = "\\r" encodeChar '"' = "\\\"" encodeChar '\\' = "\\\\" - encodeChar c | fromEnum c > 0xFFFF = "\\u" ++ showHex highSurrogate "" ++ "\\u" ++ showHex lowSurrogate "" + encodeChar c | fromEnum c > 0xFFFF = "\\u" ++ showHex highSurrogate ("\\u" ++ showHex lowSurrogate "") where (h, l) = divMod (fromEnum c - 0x10000) 0x400 highSurrogate = h + 0xD800 From f8d6c4840dd123ee029d497ff2b26458c037dc17 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 11 Nov 2015 19:11:15 -0800 Subject: [PATCH 0137/1580] Fix #1596, don't show type checker warnings in the event of an error --- src/Language/PureScript/Errors.hs | 16 +++++++--------- src/Language/PureScript/Sugar/Names/Imports.hs | 2 +- src/Language/PureScript/TypeChecker/Monad.hs | 6 +++--- 3 files changed, 11 insertions(+), 13 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8b0b0cfa8b..26ee4fc30a 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -32,7 +32,7 @@ import Control.Monad import Control.Monad.Writer import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.State.Lazy -import Control.Arrow(first) +import Control.Arrow (first) import Language.PureScript.Crash import Language.PureScript.AST @@ -938,20 +938,18 @@ renderBox = unlines . map trimEnd . lines . Box.render where trimEnd = reverse . dropWhile (== ' ') . reverse --- | --- Interpret multiple errors and warnings in a monad supporting errors and warnings --- -interpretMultipleErrorsAndWarnings :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => (Either MultipleErrors a, MultipleErrors) -> m a -interpretMultipleErrorsAndWarnings (err, ws) = do - tell ws - either throwError return err - -- | -- Rethrow an error with a more detailed error message in the case of failure -- rethrow :: (MonadError e m) => (e -> e) -> m a -> m a rethrow f = flip catchError $ \e -> throwError (f e) +reifyErrors :: (MonadError e m) => m a -> m (Either e a) +reifyErrors ma = catchError (fmap Right ma) (return . Left) + +reflectErrors :: (MonadError e m) => m (Either e a) -> m a +reflectErrors ma = ma >>= either throwError return + warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a warnAndRethrow f = rethrow f . censor f diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 13ffc10f6a..70d61b25f1 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -158,7 +158,7 @@ resolveImport currentModule importModule exps imps impQual = -- Import something explicitly importExplicit :: Imports -> DeclarationRef -> m Imports importExplicit imp (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos . warnWithPosition pos $ importExplicit imp r + warnAndRethrowWithPosition pos $ importExplicit imp r importExplicit imp (ValueRef name) = do values' <- updateImports (importedValues imp) showIdent (exportedValues exps) name return $ imp { importedValues = values' } diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index c2bbc0a2a6..0e93a1c449 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -211,21 +211,21 @@ freshDictionaryName = do -- | Run a computation in the substitution monad, generating a return value and the final substitution. liftUnify :: - (MonadState CheckState m, MonadWriter MultipleErrors m) => + (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => m a -> m (a, Substitution) liftUnify = liftUnifyWarnings (const id) -- | Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values. liftUnifyWarnings :: - (MonadState CheckState m, MonadWriter MultipleErrors m) => + (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => (Substitution -> ErrorMessage -> ErrorMessage) -> m a -> m (a, Substitution) liftUnifyWarnings replace ma = do orig <- get modify $ \st -> st { checkSubstitution = emptySubstitution } - (a, w) <- censor (const mempty) . listen $ ma + (a, w) <- reflectErrors . censor (const mempty) . reifyErrors . listen $ ma subst <- gets checkSubstitution tell . onErrorMessages (replace subst) $ w modify $ \st -> st { checkSubstitution = checkSubstitution orig } From 1912dfed5df4839c7bfec5c57d3e8aa35370ea99 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 11 Nov 2015 21:32:43 -0800 Subject: [PATCH 0138/1580] GHC <= 7.10 --- src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/TypeChecker/Monad.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 26ee4fc30a..ad68559cef 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -944,7 +944,7 @@ renderBox = unlines . map trimEnd . lines . Box.render rethrow :: (MonadError e m) => (e -> e) -> m a -> m a rethrow f = flip catchError $ \e -> throwError (f e) -reifyErrors :: (MonadError e m) => m a -> m (Either e a) +reifyErrors :: (Functor m, MonadError e m) => m a -> m (Either e a) reifyErrors ma = catchError (fmap Right ma) (return . Left) reflectErrors :: (MonadError e m) => m (Either e a) -> m a diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 0e93a1c449..97eea4ca7d 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -211,14 +211,14 @@ freshDictionaryName = do -- | Run a computation in the substitution monad, generating a return value and the final substitution. liftUnify :: - (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => + (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => m a -> m (a, Substitution) liftUnify = liftUnifyWarnings (const id) -- | Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values. liftUnifyWarnings :: - (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => + (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => (Substitution -> ErrorMessage -> ErrorMessage) -> m a -> m (a, Substitution) From db4168ec76e788e8764802940f11ca548c0e5579 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 1 Nov 2015 20:29:02 +0000 Subject: [PATCH 0139/1580] Fix warnings for unqualified implicit imports --- src/Language/PureScript/Linter/Imports.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 6a73cfb332..b1a664cf74 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -39,7 +39,7 @@ findUnusedImports (Module _ _ _ mdecls _) env usedImps = do imps <- findImports mdecls forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` autoIncludes) $ forM_ decls $ \(ss, declType, qualifierName) -> censor (onErrorMessages $ addModuleLocError ss) $ - let usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) $ sugarNames ++ M.findWithDefault [] mni usedImps in + let usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) $ sugarNames mni ++ M.findWithDefault [] mni usedImps in case declType of Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni Explicit declrefs -> do @@ -48,8 +48,9 @@ findUnusedImports (Module _ _ _ mdecls _) env usedImps = do unless (null diff) $ tell $ errorMessage $ UnusedExplicitImport mni diff _ -> return () where - sugarNames :: [ Name ] - sugarNames = [ IdentName $ Qualified Nothing (Ident C.bind) ] + sugarNames :: ModuleName -> [ Name ] + sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ] + sugarNames _ = [] autoIncludes :: [ ModuleName ] autoIncludes = [ ModuleName [ProperName C.prim] ] From a719aa0655ad603f5b2428fe34cdbb05095c10aa Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 1 Nov 2015 21:59:33 +0000 Subject: [PATCH 0140/1580] Don't warn on re-exported modules --- src/Language/PureScript/Linter/Imports.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index b1a664cf74..b8aacac102 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -35,9 +35,9 @@ type UsedImports = M.Map ModuleName [Name] -- or references in an explicit import list. -- findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports -> m () -findUnusedImports (Module _ _ _ mdecls _) env usedImps = do +findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do imps <- findImports mdecls - forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` autoIncludes) $ + forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $ forM_ decls $ \(ss, declType, qualifierName) -> censor (onErrorMessages $ addModuleLocError ss) $ let usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) $ sugarNames mni ++ M.findWithDefault [] mni usedImps in case declType of @@ -52,8 +52,12 @@ findUnusedImports (Module _ _ _ mdecls _) env usedImps = do sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ] sugarNames _ = [] - autoIncludes :: [ ModuleName ] - autoIncludes = [ ModuleName [ProperName C.prim] ] + -- rely on exports being elaborated by this point + alwaysUsedModules :: [ ModuleName ] + alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe isExport) mexports + where + isExport (ModuleRef mn) = Just mn + isExport _ = Nothing typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName typeForDCtor mn pn = From 39d1e265848d57ab90b8701aab605f42c197f673 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 1 Nov 2015 22:42:47 +0000 Subject: [PATCH 0141/1580] Also suppress import warnings for modules re-exported via qualified name --- src/Language/PureScript/Linter/Imports.hs | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index b8aacac102..dd6b737853 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -38,15 +38,16 @@ findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, Mona findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do imps <- findImports mdecls forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $ - forM_ decls $ \(ss, declType, qualifierName) -> censor (onErrorMessages $ addModuleLocError ss) $ - let usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) $ sugarNames mni ++ M.findWithDefault [] mni usedImps in - case declType of - Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni - Explicit declrefs -> do - let idents = mapMaybe runDeclRef declrefs - let diff = idents \\ usedNames - unless (null diff) $ tell $ errorMessage $ UnusedExplicitImport mni diff - _ -> return () + forM_ decls $ \(ss, declType, qualifierName) -> + censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $ + let usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) $ sugarNames mni ++ M.findWithDefault [] mni usedImps in + case declType of + Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni + Explicit declrefs -> do + let idents = mapMaybe runDeclRef declrefs + let diff = idents \\ usedNames + unless (null diff) $ tell $ errorMessage $ UnusedExplicitImport mni diff + _ -> return () where sugarNames :: ModuleName -> [ Name ] sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ] @@ -59,6 +60,10 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do isExport (ModuleRef mn) = Just mn isExport _ = Nothing + qnameUsed :: Maybe ModuleName -> Bool + qnameUsed (Just qn) = qn `elem` alwaysUsedModules + qnameUsed Nothing = False + typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName typeForDCtor mn pn = getTy <$> find matches tys From 3c6e62e96de1cb6f884639cd6bcf11a16adbfbf5 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 8 Nov 2015 18:08:10 +0000 Subject: [PATCH 0142/1580] Simplify warning on all explicit imports unused --- src/Language/PureScript/Linter/Imports.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index dd6b737853..9475d66264 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -46,7 +46,10 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do Explicit declrefs -> do let idents = mapMaybe runDeclRef declrefs let diff = idents \\ usedNames - unless (null diff) $ tell $ errorMessage $ UnusedExplicitImport mni diff + case (length diff, length idents) of + (0, _) -> return () + (n, m) | n == m -> tell $ errorMessage $ UnusedImport mni + _ -> tell $ errorMessage $ UnusedExplicitImport mni diff _ -> return () where sugarNames :: ModuleName -> [ Name ] From 6a894b4a8d78e6908441532761c4eb031f18a6af Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Mon, 9 Nov 2015 22:48:51 +0000 Subject: [PATCH 0143/1580] Warn on unused data constructors --- src/Language/PureScript/Errors.hs | 12 +++++++ src/Language/PureScript/Linter/Imports.hs | 43 +++++++++++++++++++---- 2 files changed, 49 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8b0b0cfa8b..951fc2bb4e 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -139,6 +139,8 @@ data SimpleErrorMessage | ImportHidingModule ModuleName | UnusedImport ModuleName | UnusedExplicitImport ModuleName [String] + | UnusedDctorImport ProperName + | UnusedDctorExplicitImport ProperName [ProperName] deriving (Show) -- | Error message hints, providing more detailed information about failure. @@ -271,6 +273,9 @@ errorCode em = case unwrapErrorMessage em of ImportHidingModule{} -> "ImportHidingModule" UnusedImport{} -> "UnusedImport" UnusedExplicitImport{} -> "UnusedExplicitImport" + UnusedDctorImport{} -> "UnusedDctorImport" + UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport" + -- | -- A stack trace for an error @@ -680,6 +685,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError paras [ line $ "The import of module " ++ runModuleName name ++ " contains the following unused references:" , indent $ paras $ map line names ] + renderSimpleErrorMessage (UnusedDctorImport name) = + line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used" + + renderSimpleErrorMessage (UnusedDctorExplicitImport name names) = + paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:" + , indent $ paras $ map (line .runProperName) names ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 9475d66264..18e8765cd8 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -8,7 +8,7 @@ import Prelude.Compat import qualified Data.Map as M import Data.Maybe (mapMaybe) -import Data.List ((\\), find) +import Data.List ((\\), find, intersect) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class import Control.Monad(unless,when) @@ -40,8 +40,10 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $ forM_ decls $ \(ss, declType, qualifierName) -> censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $ - let usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) $ sugarNames mni ++ M.findWithDefault [] mni usedImps in - case declType of + let names = sugarNames mni ++ M.findWithDefault [] mni usedImps + usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names + usedDctors = mapMaybe (matchDctor qualifierName) names + in case declType of Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni Explicit declrefs -> do let idents = mapMaybe runDeclRef declrefs @@ -50,6 +52,17 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do (0, _) -> return () (n, m) | n == m -> tell $ errorMessage $ UnusedImport mni _ -> tell $ errorMessage $ UnusedExplicitImport mni diff + + -- If we've not already warned a type is unused, check its data constructors + forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do + let allCtors = dctorsForType mni tn + when (runProperName tn `elem` usedNames) $ case (c, null $ usedDctors `intersect` allCtors) of + (_, True) -> tell $ errorMessage $ UnusedDctorImport tn + (Just ctors, False) -> let ddiff = ctors \\ usedDctors + in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff + _ -> return () + return () + _ -> return () where sugarNames :: ModuleName -> [ Name ] @@ -67,14 +80,23 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do qnameUsed (Just qn) = qn `elem` alwaysUsedModules qnameUsed Nothing = False + dtys :: ModuleName -> [((ProperName, [ProperName]), ModuleName)] + dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env + + dctorsForType :: ModuleName -> ProperName -> [ProperName] + dctorsForType mn tn = + maybe [] getDctors (find matches $ dtys mn) + where + matches ((ty, _),_) = ty == tn + getDctors ((_,ctors),_) = ctors + typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName typeForDCtor mn pn = - getTy <$> find matches tys + getTy <$> find matches (dtys mn) where matches ((_, ctors), _) = pn `elem` ctors getTy ((ty, _), _) = ty - tys :: [((ProperName, [ProperName]), ModuleName)] - tys = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env + matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x @@ -82,12 +104,21 @@ matchName _ qual (IsProperName (Qualified q x)) | q == qual = Just $ runProperNa matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x matchName _ _ _ = Nothing +matchDctor :: Maybe ModuleName -> Name -> Maybe ProperName +matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x +matchDctor _ _ = Nothing + runDeclRef :: DeclarationRef -> Maybe String runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref runDeclRef (ValueRef ident) = Just $ showIdent ident runDeclRef (TypeRef pn _) = Just $ runProperName pn runDeclRef _ = Nothing +getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName]) +getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref +getTypeRef (TypeRef pn x) = Just (pn, x) +getTypeRef _ = Nothing + addModuleLocError :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage addModuleLocError sp err = case sp of From b20be15a207fa9740a690bb27bd819d18dc5c36b Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Thu, 12 Nov 2015 22:54:22 +0000 Subject: [PATCH 0144/1580] Don't warn unused data constructors when none imported --- src/Language/PureScript/Linter/Imports.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 18e8765cd8..01f195a15a 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -57,9 +57,11 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do let allCtors = dctorsForType mni tn when (runProperName tn `elem` usedNames) $ case (c, null $ usedDctors `intersect` allCtors) of - (_, True) -> tell $ errorMessage $ UnusedDctorImport tn - (Just ctors, False) -> let ddiff = ctors \\ usedDctors - in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff + (Nothing, True) -> tell $ errorMessage $ UnusedDctorImport tn + (Just (_:_), True) -> tell $ errorMessage $ UnusedDctorImport tn + (Just ctors, _) -> + let ddiff = ctors \\ usedDctors + in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff _ -> return () return () From ff53b06033ea05821f6b1231b2a0c8f95f607e89 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 13 Nov 2015 01:20:00 +0100 Subject: [PATCH 0145/1580] Fix missing spaces in psc-publish error message --- src/Language/PureScript/Publish/ErrorsWarnings.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index a7b1196ff1..5319c0f595 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -160,9 +160,9 @@ displayUserError e = case e of , indented (para "* {MAJOR}.{MINOR}.{PATCH} (example: \"1.6.2\")") , spacer , para (concat - [ "If the version you are publishing is not yet tagged, you might want to use" - , "the --dry-run flag instead, which removes this requirement. Run" - , "psc-publish --help for more details." + [ "If the version you are publishing is not yet tagged, you might " + , "want to use the --dry-run flag instead, which removes this " + , "requirement. Run psc-publish --help for more details." ]) ] AmbiguousVersions vs -> From 84e513daddb742b30c9265258cdc102301f81920 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 14 Nov 2015 01:12:53 +0100 Subject: [PATCH 0146/1580] Remove useless constructor BowerJSONNameMissing That kind of validation happens inside bower-json. --- src/Language/PureScript/Publish/ErrorsWarnings.hs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 5319c0f595..7c9458180a 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -56,7 +56,6 @@ data UserError = BowerJSONNotFound | BowerExecutableNotFound [String] -- list of executable names tried | CouldntParseBowerJSON (ParseError BowerError) - | BowerJSONNameMissing | TagMustBeCheckedOut | AmbiguousVersions [Version] -- Invariant: should contain at least two elements | BadRepositoryField RepositoryFieldError @@ -138,14 +137,6 @@ displayUserError e = case e of ] , para "Please ensure that your bower.json file is valid JSON." ] - BowerJSONNameMissing -> - vcat - [ successivelyIndented - [ "In bower.json:" - , "the \"name\" key was not found." - ] - , para "Please give your package a name first." - ] TagMustBeCheckedOut -> vcat [ para (concat From 7b71cab8238bfc7224f4360a9cdeed45ab946623 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 14 Nov 2015 01:29:21 +0100 Subject: [PATCH 0147/1580] Better bower.json error reporting for psc-publish Fixes #1560 - Use the functions for displaying errors from bower-json and aeson-better-errors instead of using the Show instance - Rename the inaccurately named `CouldntParseBowerJson` constructor. --- src/Language/PureScript/Publish.hs | 2 +- src/Language/PureScript/Publish/ErrorsWarnings.hs | 15 +++++++-------- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 9441781c21..08fb718d1e 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -122,7 +122,7 @@ preparePackage' opts = do requireCleanWorkingTree pkgMeta <- liftIO (Bower.decodeFile "bower.json") - >>= flip catchLeft (userError . CouldntParseBowerJSON) + >>= flip catchLeft (userError . CouldntDecodeBowerJSON) (pkgVersionTag, pkgVersion) <- publishGetVersion opts pkgGithub <- getBowerInfo pkgMeta (pkgBookmarks, pkgModules) <- getModulesAndBookmarks diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 7c9458180a..d758b1946a 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -29,7 +29,7 @@ import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as T import Control.Exception (IOException) -import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName) +import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName, showBowerError) import qualified Web.Bower.PackageMeta as Bower import qualified Language.PureScript as P @@ -55,7 +55,7 @@ data PackageWarning data UserError = BowerJSONNotFound | BowerExecutableNotFound [String] -- list of executable names tried - | CouldntParseBowerJSON (ParseError BowerError) + | CouldntDecodeBowerJSON (ParseError BowerError) | TagMustBeCheckedOut | AmbiguousVersions [Version] -- Invariant: should contain at least two elements | BadRepositoryField RepositoryFieldError @@ -129,13 +129,12 @@ displayUserError e = case e of ]) where format = intercalate ", " . map show - CouldntParseBowerJSON err -> + CouldntDecodeBowerJSON err -> vcat - [ successivelyIndented - [ "The bower.json file could not be parsed as JSON:" - , "aeson reported: " ++ show err - ] - , para "Please ensure that your bower.json file is valid JSON." + [ para "There was a problem with your bower.json file:" + , indented (vcat (map (para . T.unpack) (displayError showBowerError err))) + , spacer + , para "Please ensure that your bower.json file is valid." ] TagMustBeCheckedOut -> vcat From 9829ec7a8208ff55918b8705c97fd41d3861cd48 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 14 Nov 2015 04:06:48 +0100 Subject: [PATCH 0148/1580] Reduce noise in instance declarations `instance showFoo :: Show Foo` is now rendered as `Show Foo`, since the extra information is mostly just noise. --- src/Language/PureScript/Docs/Render.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index a19ecebec0..1177391e2b 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -71,11 +71,7 @@ renderChildDeclarationWithOptions :: RenderTypeOptions -> ChildDeclaration -> Re renderChildDeclarationWithOptions opts ChildDeclaration{..} = mintersperse sp $ case cdeclInfo of ChildInstance constraints ty -> - [ keywordInstance - , ident cdeclTitle - , syntax "::" - ] ++ maybeToList (renderConstraints constraints) - ++ [ renderType' ty ] + maybeToList (renderConstraints constraints) ++ [ renderType' ty ] ChildDataConstructor args -> [ renderType' typeApp' ] where From 293128e8ae40c29ee65f320c801ac089c666a92e Mon Sep 17 00:00:00 2001 From: suppi Date: Sun, 15 Nov 2015 00:24:30 +0200 Subject: [PATCH 0149/1580] adding more information to psci :browse command --- CONTRIBUTORS.md | 1 + psci/PSCi.hs | 116 +++++++++++++++++++++++++++++++++++++++++------ purescript.cabal | 5 +- 3 files changed, 105 insertions(+), 17 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 62370ced50..3901dfe9bb 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -56,6 +56,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). . +- [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/psci/PSCi.hs b/psci/PSCi.hs index c501850930..d75cceee87 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -24,7 +24,8 @@ import Prelude () import Prelude.Compat import Data.Foldable (traverse_) -import Data.List (intercalate, nub, sort) +import Data.Maybe (mapMaybe) +import Data.List (intersperse, intercalate, nub, sort) import Data.Tuple (swap) import Data.Version (showVersion) import qualified Data.Map as M @@ -48,6 +49,7 @@ import System.FilePath (pathSeparator, (), isPathSeparator) import System.FilePath.Glob (glob) import System.Process (readProcessWithExitCode) import System.IO.Error (tryIOError) +import qualified Text.PrettyPrint.Boxes as Box import qualified Language.PureScript as P import qualified Language.PureScript.Names as N @@ -374,20 +376,104 @@ handleTypeOf val = do -- Pretty print a module's signatures -- printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI () -printModuleSignatures moduleName env = - PSCI $ let namesEnv = P.names env - moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv - in case moduleNamesIdent of - [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions." - _ -> ( outputStrLn - . unlines - . sort - . map (showType . findType namesEnv)) moduleNamesIdent - where findType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) - findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames) - showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String - showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType - showType _ = P.internalError "The impossible happened in printModuleSignatures." +printModuleSignatures moduleName (P.Environment {..}) = + PSCI $ + -- get relevant components of a module from environment + let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names + moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses + moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types + + in + -- print each component + (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left) + [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses + , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types + , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions + ] + + where printModule's showF = Box.vsep 1 Box.left . showF + + findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) + findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames) + + showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box + showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType + showNameType _ = P.internalError "The impossible happened in printModuleSignatures." + + findTypeClass :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) + findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses) + + showTypeClass :: (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) -> Maybe Box.Box + showTypeClass (_, Nothing) = Nothing + showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) = + let constraints = + if null constrs + then Box.text "" + else Box.text "(" + Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs) + Box.<> Box.text ") <= " + className = + Box.text (P.runProperName name) + Box.<> Box.text (concatMap ((' ':) . fst) vars) + classBody = + Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body) + + in + Just $ + (Box.text "class " + Box.<> constraints + Box.<> className + Box.<+> if null body then Box.text "" else Box.text "where") + Box.// Box.moveRight 2 classBody + + + findType :: M.Map (P.Qualified P.ProperName) (P.Kind, P.TypeKind) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind)) + findType envTypes name = (name, M.lookup name envTypes) + + showType :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) + -> M.Map (P.Qualified P.ProperName) (P.DataDeclType, P.ProperName, P.Type, [P.Ident]) + -> M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], P.Type) + -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind)) + -> Maybe Box.Box + showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) = + case (typ, M.lookup n typeSynonymsEnv) of + (Just (_, P.TypeSynonym), Just (typevars, dtType)) -> + if M.member n typeClassesEnv + then + Nothing + else + Just $ + Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) + Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType) + + (Just (_, P.DataType typevars pt), _) -> + let prefix = + case pt of + [(dtProperName,_)] -> + case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of + Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType + _ -> "data" + _ -> "data" + + in + Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt + + _ -> + Nothing + + where printCons pt = + Box.moveRight 2 $ + Box.vcat Box.left $ + mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $ + map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt + + prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t + + mapFirstRest _ _ [] = [] + mapFirstRest f g (x:xs) = f x : map g xs + + trimEnd = reverse . dropWhile (== ' ') . reverse + -- | -- Browse a module and displays its signature (if module exists). diff --git a/purescript.cabal b/purescript.cabal index 45c5c35006..06aca22dd3 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -197,7 +197,8 @@ executable psci build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, mtl -any, optparse-applicative >= 0.10.0, parsec -any, haskeline >= 0.7.0.0, purescript -any, transformers -any, - transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0 + transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0, + boxes >= 0.1.4 && < 0.2.0 main-is: Main.hs buildable: True @@ -272,7 +273,7 @@ test-suite psci-tests mtl -any, optparse-applicative >= 0.10.0, parsec -any, haskeline >= 0.7.0.0, purescript -any, transformers -any, transformers-compat -any, process -any, HUnit -any, time -any, - Glob -any, base-compat >=0.6.0 + Glob -any, base-compat >=0.6.0, boxes >= 0.1.4 && < 0.2.0 type: exitcode-stdio-1.0 main-is: Main.hs other-modules: TestsSetup From e177fb39a0c3cdcfae436833aab2b3b8641c3528 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 14 Nov 2015 20:20:38 -0800 Subject: [PATCH 0150/1580] Fix #1632, instantiate type variables in anyProxy calls in generic instances. --- core-tests/tests/generic-deriving/Main.purs | 6 +++- .../PureScript/Sugar/TypeClasses/Deriving.hs | 29 ++++++++++--------- 2 files changed, 21 insertions(+), 14 deletions(-) diff --git a/core-tests/tests/generic-deriving/Main.purs b/core-tests/tests/generic-deriving/Main.purs index 9ed946f8c7..a0aae6a755 100755 --- a/core-tests/tests/generic-deriving/Main.purs +++ b/core-tests/tests/generic-deriving/Main.purs @@ -17,7 +17,11 @@ data A a | D { a :: a } | E Void -derive instance genericA :: (Generic a) => Generic (A a) +derive instance genericA :: (Generic b) => Generic (A b) + +newtype X b = X b + +derive instance genericX :: Generic (X String) main :: forall eff. Eff (console :: CONSOLE | eff) Unit main = Control.Monad.Eff.Console.log (gShow (D { a: C [ A 1.0 "test", B 42, D { a: true } ] })) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index f9c8926a41..790083f616 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -52,17 +52,19 @@ deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (derive deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance) | className == Qualified (Just dataGeneric) (ProperName C.generic) - , Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty + , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon + = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) = throwError . errorMessage $ CannotDerive className tys deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d deriveInstance _ _ e = return e -unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName) -unwrapTypeConstructor (TypeConstructor tyCon) = Just tyCon -unwrapTypeConstructor (TypeApp ty (TypeVar _)) = unwrapTypeConstructor ty +unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName, [Type]) +unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, []) +unwrapTypeConstructor (TypeApp ty arg) = do + (tyCon, args) <- unwrapTypeConstructor ty + return (tyCon, arg : args) unwrapTypeConstructor _ = Nothing dataGeneric :: ModuleName @@ -71,12 +73,12 @@ dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] dataMaybe :: ModuleName dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ] -deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> m [Declaration] -deriveGeneric mn ds tyConNm = do +deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration] +deriveGeneric mn ds tyConNm args = do tyCon <- findTypeDecl tyConNm ds toSpine <- mkSpineFunction mn tyCon fromSpine <- mkFromSpineFunction mn tyCon - let toSignature = mkSignatureFunction mn tyCon + let toSignature = mkSignatureFunction mn tyCon args return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine) , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine) , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature) @@ -118,8 +120,8 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration" -mkSignatureFunction :: ModuleName -> Declaration -> Expr -mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args +mkSignatureFunction :: ModuleName -> Declaration -> [Type] -> Expr +mkSignatureFunction _ (DataDeclaration _ _ tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args where mkSigProd :: [Expr] -> Expr mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral @@ -132,7 +134,7 @@ mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map m mkProdClause :: (ProperName, [Type]) -> Expr mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName)) - , ("sigValues", ArrayLiteral . map mkProductSignature $ tys) + , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys) ] mkProductSignature :: Type -> Expr @@ -144,8 +146,9 @@ mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map m ] mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature) (TypedValue False (mkGenVar "anyProxy") (proxy typ)) -mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d -mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration" + instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs) +mkSignatureFunction mn (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction mn d classArgs +mkSignatureFunction _ _ _ = internalError "mkSignatureFunction: expected DataDeclaration" mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args) From 759b3c68505535e06078d185593b773de68f1ab5 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 15 Nov 2015 13:37:57 -0800 Subject: [PATCH 0151/1580] Update generic deriving for latest purescript-generics changes --- src/Language/PureScript/Sugar/TypeClasses/Deriving.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index f9c8926a41..c086ed0ac4 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -105,7 +105,7 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents)) where caseResult idents = - App (prodConstructor (StringLiteral . runProperName $ ctorName)) + App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName)) . ArrayLiteral $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys @@ -119,10 +119,12 @@ mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration" mkSignatureFunction :: ModuleName -> Declaration -> Expr -mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args +mkSignatureFunction mn (DataDeclaration _ name _ args) = lamNull . mkSigProd $ map mkProdClause args where mkSigProd :: [Expr] -> Expr - mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral + mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) + (StringLiteral (showQualified runProperName (Qualified (Just mn) name))) + ) . ArrayLiteral mkSigRec :: [Expr] -> Expr mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral @@ -131,7 +133,7 @@ mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map m proxy = TypeApp (TypeConstructor (Qualified (Just dataGeneric) (ProperName "Proxy"))) mkProdClause :: (ProperName, [Type]) -> Expr - mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName)) + mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))) , ("sigValues", ArrayLiteral . map mkProductSignature $ tys) ] From 5cc5ec5b4e8fbf473b2a26d1379fcee9f821790f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 16 Nov 2015 11:13:31 -0800 Subject: [PATCH 0152/1580] Add Gitter badge --- README.md | 1 + 1 file changed, 1 insertion(+) diff --git a/README.md b/README.md index aa4a4ff132..5f2df6f345 100644 --- a/README.md +++ b/README.md @@ -3,6 +3,7 @@ A small strongly typed programming language with expressive types that compiles to Javascript, written in and inspired by Haskell. [![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript) +[![Join the chat at https://gitter.im/purescript/purescript](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/purescript/purescript?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) [![Stackage LTS 2](http://stackage.org/package/purescript/badge/lts-2)](http://stackage.org/lts-2/package/purescript) [![Stackage LTS 3](http://stackage.org/package/purescript/badge/lts-3)](http://stackage.org/lts-3/package/purescript) From 8cbbd3952d517e5fce18fc796b6856e0021f4291 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 16 Nov 2015 11:14:55 -0800 Subject: [PATCH 0153/1580] Use consistent badge image --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 5f2df6f345..e6288fa960 100644 --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ A small strongly typed programming language with expressive types that compiles to Javascript, written in and inspired by Haskell. [![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript) -[![Join the chat at https://gitter.im/purescript/purescript](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/purescript/purescript?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) +[![Join the chat at https://gitter.im/purescript/purescript](https://img.shields.io/badge/gitter-chat-lightblue.svg)](https://gitter.im/purescript/purescript?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) [![Stackage LTS 2](http://stackage.org/package/purescript/badge/lts-2)](http://stackage.org/lts-2/package/purescript) [![Stackage LTS 3](http://stackage.org/package/purescript/badge/lts-3)](http://stackage.org/lts-3/package/purescript) From 18b5c18de5c3c1cd4311ce7466c782ef7444ef37 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 16 Nov 2015 11:49:58 -0800 Subject: [PATCH 0154/1580] Update README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index e6288fa960..cc391f75f8 100644 --- a/README.md +++ b/README.md @@ -3,7 +3,6 @@ A small strongly typed programming language with expressive types that compiles to Javascript, written in and inspired by Haskell. [![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript) -[![Join the chat at https://gitter.im/purescript/purescript](https://img.shields.io/badge/gitter-chat-lightblue.svg)](https://gitter.im/purescript/purescript?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) [![Stackage LTS 2](http://stackage.org/package/purescript/badge/lts-2)](http://stackage.org/lts-2/package/purescript) [![Stackage LTS 3](http://stackage.org/package/purescript/badge/lts-3)](http://stackage.org/lts-3/package/purescript) @@ -27,3 +26,4 @@ A small strongly typed programming language with expressive types that compiles - [#purescript IRC @ FreeNode](http://webchat.freenode.net/?channels=purescript) - [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript) - [Google Group](https://groups.google.com/forum/#!forum/purescript) +- [Gitter Channel](https://gitter.im/purescript/purescript?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) From ef94ae2682a0b101ae2f7d1b140f6ad8e8146288 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 17 Nov 2015 09:19:23 +0100 Subject: [PATCH 0155/1580] psc-publish: only warn on dirty working tree on dry runs As opposed to erroring. --- psc-publish/Main.hs | 11 ++++++-- src/Language/PureScript/Publish.hs | 17 ++++++++---- .../PureScript/Publish/ErrorsWarnings.hs | 26 ++++++++++++++----- 3 files changed, 41 insertions(+), 13 deletions(-) diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs index d691d2a98f..912f460c96 100644 --- a/psc-publish/Main.hs +++ b/psc-publish/Main.hs @@ -9,12 +9,20 @@ import Options.Applicative hiding (str) import qualified Paths_purescript as Paths import Language.PureScript.Publish +import Language.PureScript.Publish.ErrorsWarnings dryRun :: Parser Bool dryRun = switch $ long "dry-run" <> help "Produce no output, and don't require a tagged version to be checked out." +dryRunOptions :: PublishOptions +dryRunOptions = defaultPublishOptions + { publishGetVersion = return dummyVersion + , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn + } + where dummyVersion = ("0.0.0", Version [0,0,0] []) + main :: IO () main = execParser opts >>= publish where @@ -30,8 +38,7 @@ publish :: Bool -> IO () publish isDryRun = if isDryRun then do - let dummyVersion = ("0.0.0", Version [0,0,0] []) - _ <- preparePackage $ defaultPublishOptions { publishGetVersion = return dummyVersion } + _ <- preparePackage dryRunOptions putStrLn "Dry run completed, no errors." else do pkg <- preparePackage defaultPublishOptions diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 08fb718d1e..904607e8f2 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -8,10 +8,14 @@ module Language.PureScript.Publish , preparePackage' , PrepareM() , runPrepareM + , warn + , userError + , internalError + , otherError , PublishOptions(..) , defaultPublishOptions , getGitWorkingTreeStatus - , requireCleanWorkingTree + , checkCleanWorkingTree , getVersionFromGitTag , getBowerInfo , getModulesAndBookmarks @@ -63,11 +67,14 @@ data PublishOptions = PublishOptions { -- | How to obtain the version tag and version that the data being -- generated will refer to. publishGetVersion :: PrepareM (String, Version) + , -- | What to do when the working tree is dirty + publishWorkingTreeDirty :: PrepareM () } defaultPublishOptions :: PublishOptions defaultPublishOptions = PublishOptions { publishGetVersion = getVersionFromGitTag + , publishWorkingTreeDirty = userError DirtyWorkingTree } -- | Attempt to retrieve package metadata from the current directory. @@ -119,7 +126,7 @@ preparePackage' opts = do exists <- liftIO (doesFileExist "bower.json") unless exists (userError BowerJSONNotFound) - requireCleanWorkingTree + checkCleanWorkingTree opts pkgMeta <- liftIO (Bower.decodeFile "bower.json") >>= flip catchLeft (userError . CouldntDecodeBowerJSON) @@ -155,11 +162,11 @@ getGitWorkingTreeStatus = do then Clean else Dirty -requireCleanWorkingTree :: PrepareM () -requireCleanWorkingTree = do +checkCleanWorkingTree :: PublishOptions -> PrepareM () +checkCleanWorkingTree opts = do status <- getGitWorkingTreeStatus unless (status == Clean) $ - userError DirtyWorkingTree + publishWorkingTreeDirty opts getVersionFromGitTag :: PrepareM (String, Version) getVersionFromGitTag = do diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index d758b1946a..c001de80f0 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -49,6 +49,7 @@ data PackageWarning = NoResolvedVersion PackageName | UndeclaredDependency PackageName | UnacceptableVersion (PackageName, String) + | DirtyWorkingTree_Warn deriving (Show) -- | An error that should be fixed by the user. @@ -279,21 +280,24 @@ data CollectedWarnings = CollectedWarnings { noResolvedVersions :: [PackageName] , undeclaredDependencies :: [PackageName] , unacceptableVersions :: [(PackageName, String)] + , dirtyWorkingTree :: Any } deriving (Show, Eq, Ord) instance Monoid CollectedWarnings where - mempty = CollectedWarnings mempty mempty mempty - mappend (CollectedWarnings as bs cs) (CollectedWarnings as' bs' cs') = - CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') + mempty = CollectedWarnings mempty mempty mempty mempty + mappend (CollectedWarnings as bs cs d) + (CollectedWarnings as' bs' cs' d') = + CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') (d <> d') collectWarnings :: [PackageWarning] -> CollectedWarnings collectWarnings = foldMap singular where singular w = case w of - NoResolvedVersion pn -> CollectedWarnings [pn] [] [] - UndeclaredDependency pn -> CollectedWarnings [] [pn] [] - UnacceptableVersion t -> CollectedWarnings [] [] [t] + NoResolvedVersion pn -> CollectedWarnings [pn] mempty mempty mempty + UndeclaredDependency pn -> CollectedWarnings mempty [pn] mempty mempty + UnacceptableVersion t -> CollectedWarnings mempty mempty [t] mempty + DirtyWorkingTree_Warn -> CollectedWarnings mempty mempty mempty (Any True) renderWarnings :: [PackageWarning] -> Box renderWarnings warns = @@ -302,6 +306,9 @@ renderWarnings warns = mboxes = [ go warnNoResolvedVersions noResolvedVersions , go warnUndeclaredDependencies undeclaredDependencies , go warnUnacceptableVersions unacceptableVersions + , if getAny dirtyWorkingTree + then Just warnDirtyWorkingTree + else Nothing ] in case catMaybes mboxes of [] -> nullBox @@ -377,5 +384,12 @@ warnUnacceptableVersions pkgs = where showTuple (pkgName, tag) = runPackageName pkgName ++ "#" ++ tag +warnDirtyWorkingTree :: Box +warnDirtyWorkingTree = + para (concat + [ "Your working tree is dirty. (Note: this would be an error if it " + , "were not a dry run)" + ]) + printWarnings :: [PackageWarning] -> IO () printWarnings = printToStderr . renderWarnings From fc4090fd1fddca5cfda91b2be03937356a93e19c Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 17 Nov 2015 20:12:15 -0800 Subject: [PATCH 0156/1580] Missed fromSpine --- core-tests/tests/generic-deriving/Main.purs | 4 ++-- src/Language/PureScript/Sugar/TypeClasses/Deriving.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/core-tests/tests/generic-deriving/Main.purs b/core-tests/tests/generic-deriving/Main.purs index a0aae6a755..868fde6e9e 100755 --- a/core-tests/tests/generic-deriving/Main.purs +++ b/core-tests/tests/generic-deriving/Main.purs @@ -14,7 +14,7 @@ data A a = A Number String | B Int | C (Array (A a)) - | D { a :: a } + | D { "asgård" :: a } | E Void derive instance genericA :: (Generic b) => Generic (A b) @@ -24,4 +24,4 @@ newtype X b = X b derive instance genericX :: Generic (X String) main :: forall eff. Eff (console :: CONSOLE | eff) Unit -main = Control.Monad.Eff.Console.log (gShow (D { a: C [ A 1.0 "test", B 42, D { a: true } ] })) +main = Control.Monad.Eff.Console.log (gShow (D { "asgård": C [ A 1.0 "test", B 42, D { "asgård": true } ] })) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 6911a9ce06..63269db3d0 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -170,7 +170,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch mkAlternative :: (ProperName, [Type]) -> m CaseAlternative mkAlternative (ctorName, tys) = do idents <- replicateM (length tys) (fmap Ident freshName) - return $ CaseAlternative [ prodBinder [ StringBinder (runProperName ctorName), ArrayBinder (map VarBinder idents)]] + return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]] . Right $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName)) (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys) From a284c4cf25163ecefbc0eddd8410eb9bf630751e Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Wed, 18 Nov 2015 07:04:36 -0600 Subject: [PATCH 0157/1580] Use Types.Proxy.Proxy instead of Data.Generic.Proxy This fixes #1573. It changes the deriving mechanism to use `Types.Proxy.Proxy` from purescript-proxy instead of `Data.Generic.Proxy` from purescript-generics. This requires the changes in purescript/purescript-generics#19. --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Sugar/TypeClasses/Deriving.hs | 5 ++++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 3901dfe9bb..fde3d54143 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -57,6 +57,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). . - [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 63269db3d0..2c789b1e3d 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -73,6 +73,9 @@ dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] dataMaybe :: ModuleName dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ] +typesProxy :: ModuleName +typesProxy = ModuleName [ ProperName "Types", ProperName "Proxy" ] + deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration] deriveGeneric mn ds tyConNm args = do tyCon <- findTypeDecl tyConNm ds @@ -132,7 +135,7 @@ mkSignatureFunction mn (DataDeclaration _ name tyArgs args) classArgs = lamNull mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral proxy :: Type -> Type - proxy = TypeApp (TypeConstructor (Qualified (Just dataGeneric) (ProperName "Proxy"))) + proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy"))) mkProdClause :: (ProperName, [Type]) -> Expr mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))) From a10c53d8e90288f100cbed95ea19459dfa827f9b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 18 Nov 2015 08:59:34 -0800 Subject: [PATCH 0158/1580] -> 0.7.6 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 06aca22dd3..95915858a7 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.7.5.3 +version: 0.7.6 cabal-version: >=1.8 build-type: Simple license: MIT From 92bf4e90e237e8112615cdc5256c7242e11f63cc Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 18 Nov 2015 13:44:52 -0800 Subject: [PATCH 0159/1580] Type.Proxy, not Types.Proxy --- purescript.cabal | 2 +- src/Language/PureScript/Sugar/TypeClasses/Deriving.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 95915858a7..65b733af05 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.7.6 +version: 0.7.6.1 cabal-version: >=1.8 build-type: Simple license: MIT diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 2c789b1e3d..08840f6999 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -74,7 +74,7 @@ dataMaybe :: ModuleName dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ] typesProxy :: ModuleName -typesProxy = ModuleName [ ProperName "Types", ProperName "Proxy" ] +typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ] deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration] deriveGeneric mn ds tyConNm args = do From 3fd1574b077e18053226a52fbef23dcf580e3a94 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Thu, 19 Nov 2015 12:09:04 +0000 Subject: [PATCH 0160/1580] Ignore md5 files in bundle dir --- bundle/.gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/bundle/.gitignore b/bundle/.gitignore index f0a1bcfa73..0b1382f9bb 100644 --- a/bundle/.gitignore +++ b/bundle/.gitignore @@ -1,3 +1,4 @@ build/ *.tar.gz *.sha +*.md5 From 85a46e131210275bfee890d9cbed9c8583e5f9b6 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 19 Nov 2015 16:38:14 -0800 Subject: [PATCH 0161/1580] Fix #1479, encode .js files as UTF8. --- examples/passing/UnicodeIdentifier.purs | 5 +++++ src/Language/PureScript/Make.hs | 22 ++++++++++++---------- src/System/IO/UTF8.hs | 24 ++++++++++++++++++++---- 3 files changed, 37 insertions(+), 14 deletions(-) create mode 100644 examples/passing/UnicodeIdentifier.purs diff --git a/examples/passing/UnicodeIdentifier.purs b/examples/passing/UnicodeIdentifier.purs new file mode 100644 index 0000000000..0be0e3e7e0 --- /dev/null +++ b/examples/passing/UnicodeIdentifier.purs @@ -0,0 +1,5 @@ +module Main where + +f asgård = asgård + +main = Control.Monad.Eff.Console.log (f "Done") diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 4888ca6165..d3cb52c0a8 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -63,6 +63,7 @@ import Data.Traversable (for) import Data.Version (showVersion) import Data.Aeson (encode, decode) import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.UTF8 as BU8 import qualified Data.Set as S import qualified Data.Map as M @@ -70,6 +71,7 @@ import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing) import System.FilePath ((), takeDirectory) import System.IO.Error (tryIOError) +import System.IO.UTF8 (readUTF8File, writeUTF8File) import Language.PureScript.Crash import Language.PureScript.AST @@ -123,7 +125,7 @@ data MakeActions m = MakeActions { -- | -- Read the externs file for a module as a string and also return the actual -- path for the file. - , readExterns :: ModuleName -> m (FilePath, B.ByteString) + , readExterns :: ModuleName -> m (FilePath, Externs) -- | -- Run the code generator for the module and write any required output files. -- @@ -137,7 +139,7 @@ data MakeActions m = MakeActions { -- | -- Generated code for an externs file. -- -type Externs = B.ByteString +type Externs = String -- | -- Determines when to rebuild a module @@ -231,7 +233,7 @@ make MakeActions{..} ms = do corefn = CF.moduleToCoreFn env' mod' [renamed] = renameInModules [corefn] exts = moduleToExternsFile mod' env' - evalSupplyT nextVar $ codegen renamed env' $ encode exts + evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts return exts markComplete (Just (warnings, exts)) Nothing @@ -258,9 +260,9 @@ make MakeActions{..} ms = do shouldExist (Just t) = t shouldExist _ = internalError "make: dependency should already have been built." - decodeExterns :: B.ByteString -> Maybe ExternsFile + decodeExterns :: Externs -> Maybe ExternsFile decodeExterns bs = do - externs <- decode bs + externs <- decode (fromString bs) guard $ efVersion externs == showVersion Paths.version return externs @@ -335,7 +337,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = externsFile = outputDir filePath "externs.json" min <$> getTimestamp jsFile <*> getTimestamp externsFile - readExterns :: ModuleName -> Make (FilePath, B.ByteString) + readExterns :: ModuleName -> Make (FilePath, Externs) readExterns mn = do let path = outputDir runModuleName mn "externs.json" (path, ) <$> readTextFile path @@ -371,13 +373,13 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = exists <- doesFileExist path traverse (const $ getModificationTime path) $ guard exists - readTextFile :: FilePath -> Make B.ByteString - readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path + readTextFile :: FilePath -> Make String + readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path - writeTextFile :: FilePath -> B.ByteString -> Make () + writeTextFile :: FilePath -> String -> Make () writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do mkdirp path - B.writeFile path text + writeUTF8File path text where mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs index d2b8ff9787..2352d39de9 100644 --- a/src/System/IO/UTF8.hs +++ b/src/System/IO/UTF8.hs @@ -1,9 +1,25 @@ module System.IO.UTF8 + where -import System.IO (hGetContents, hSetEncoding, openFile, utf8, IOMode (..)) + +import System.IO ( IOMode(..) + , hGetContents + , hSetEncoding + , hClose + , hPutStr + , openFile + , utf8 + ) readUTF8File :: FilePath -> IO String readUTF8File inFile = do - h <- openFile inFile ReadMode - hSetEncoding h utf8 - hGetContents h + h <- openFile inFile ReadMode + hSetEncoding h utf8 + hGetContents h + +writeUTF8File :: FilePath -> String -> IO () +writeUTF8File inFile text = do + h <- openFile inFile WriteMode + hSetEncoding h utf8 + hPutStr h text + hClose h From f1107f06bba57ccbaa666ca43046f463d845c4f5 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 21 Nov 2015 13:13:41 +0000 Subject: [PATCH 0162/1580] Fix missing data constructors in re-exports --- src/Language/PureScript/Sugar/Names/Exports.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 7b82792cf4..6b46696abd 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -141,7 +141,7 @@ resolveExports env mn imps exps refs = go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do exps' <- envModuleExports <$> mn'' `M.lookup` env ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps') - let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mnOrig then Just dctor else Nothing) dctors + let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mn'' then Just dctor else Nothing) dctors return ((name, intersect relevantDctors dctors'), mnOrig) go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports" From dc467ad37f482cc5130bee6986bef1b8730b76ac Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 21 Nov 2015 13:23:04 +0000 Subject: [PATCH 0163/1580] Fix codegen error with instance for re-exported class --- src/Language/PureScript/CoreFn/Desugar.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index f07e2c20db..85c869237d 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -203,9 +203,13 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = -- findQualModules :: [A.Declaration] -> [ModuleName] findQualModules decls = - let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues fqBinders (const []) (const []) + let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const []) in f `concatMap` decls where + fqDecls :: A.Declaration -> [ModuleName] + fqDecls (A.TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn] + fqDecls _ = [] + fqValues :: A.Expr -> [ModuleName] fqValues (A.Var (Qualified (Just mn) _)) = [mn] fqValues (A.Constructor (Qualified (Just mn) _)) = [mn] From 17eaed523c3ea49040db1cdcd046218d38aa5f80 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 21 Nov 2015 15:33:03 +0000 Subject: [PATCH 0164/1580] Allow import hiding with qualified imports --- src/Language/PureScript/Parser/Declarations.hs | 13 +++---------- 1 file changed, 3 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index c48c472c8c..7986573639 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -152,16 +152,9 @@ parseImportDeclaration' = do where stdImport = do moduleName' <- moduleName - suffixHiding moduleName' <|> suffixQualifyingList moduleName' - where - suffixHiding mn = do - reserved "hiding" - declType <- qualifyingList Hiding - return (mn, declType, Nothing) - suffixQualifyingList mn = do - declType <- qualifyingList Explicit - qName <- P.optionMaybe qualifiedName - return (mn, declType, qName) + declType <- reserved "hiding" *> qualifyingList Hiding <|> qualifyingList Explicit + qName <- P.optionMaybe qualifiedName + return (moduleName', declType, qName) qualifiedName = reserved "as" *> moduleName qualImport = do reserved "qualified" From 46fb2e337544fb87f649872e87a014efdf630cfb Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 21 Nov 2015 09:02:23 -0800 Subject: [PATCH 0165/1580] Update CONTRIBUTORS.md --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index fde3d54143..de711daf04 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -26,6 +26,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@joneshf](https://github.com/joneshf) (Hardy Jones) - My existing contributions and all future contributions until further notice are Copyright Hardy Jones, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@kRITZCREEK](https://github.com/kRITZCREEK) (Christoph Hegemann) - My existing contributions and all future contributions until further notice are Copyright Christoph Hegemann, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@L8D](https://github.com/L8D) (Tenor Biel) My existing contributions and all future contributions until further notice are Copyright Tenor Biel, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@leighman](http://github.com/leighman) (Jack Leigh) My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@lukerandall](https://github.com/lukerandall) (Luke Randall) My existing contributions and all future contributions until further notice are Copyright Luke Randall, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@michaelficarra](https://github.com/michaelficarra) (Michael Ficarra) My existing contributions and all future contributions until further notice are Copyright Michael Ficarra, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@MichaelXavier](https://github.com/MichaelXavier) (Michael Xavier) - My existing contributions and all future contributions until further notice are Copyright Michael Xavier, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. From 42702e84a8a388cb17684570152ddeb5659b18bf Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 21 Nov 2015 18:52:30 +0000 Subject: [PATCH 0166/1580] Add deprecation warning for import qualified syntax --- psci/PSCi.hs | 2 +- psci/Parser.hs | 4 +++- src/Language/PureScript/AST/Declarations.hs | 3 ++- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- src/Language/PureScript/Docs/ParseAndDesugar.hs | 4 ++-- src/Language/PureScript/Errors.hs | 6 ++++++ src/Language/PureScript/Externs.hs | 2 +- src/Language/PureScript/Make.hs | 4 ++-- src/Language/PureScript/ModuleDependencies.hs | 2 +- src/Language/PureScript/Parser/Declarations.hs | 10 +++++----- src/Language/PureScript/Sugar/Names.hs | 2 +- src/Language/PureScript/Sugar/Names/Imports.hs | 5 +++-- 12 files changed, 28 insertions(+), 18 deletions(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index d75cceee87..75afe912ba 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -242,7 +242,7 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} = P.Module (P.internalModuleSourceSpan "") [] moduleName (importDecl `map` imports) Nothing importDecl :: ImportedModule -> P.Declaration -importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ +importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False indexFile :: FilePath indexFile = ".psci_modules" ++ pathSeparator : "index.js" diff --git a/psci/Parser.hs b/psci/Parser.hs index cb00db16ed..b8b0675f74 100644 --- a/psci/Parser.hs +++ b/psci/Parser.hs @@ -106,7 +106,9 @@ psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls) -- | Imports must be handled separately from other declarations, so that -- :show import works, for example. psciImport :: P.TokenParser Command -psciImport = Import <$> P.parseImportDeclaration' +psciImport = do + (mn, declType, asQ, _) <- P.parseImportDeclaration' + return $ Import (mn, declType, asQ) -- | Any other declaration that we don't need a 'special case' parser for -- (like let or import declarations). diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 07ff4b1b98..3f20c84493 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -153,8 +153,9 @@ data Declaration | FixityDeclaration Fixity String -- | -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name) + -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9) -- - | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName) + | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName) Bool -- | -- A type class declaration (name, argument, implies, member declarations) -- diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index f07e2c20db..df5c99a544 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -219,7 +219,7 @@ findQualModules decls = -- Desugars import declarations from AST to CoreFn representation. -- importToCoreFn :: A.Declaration -> Maybe ModuleName -importToCoreFn (A.ImportDeclaration name _ _) = Just name +importToCoreFn (A.ImportDeclaration name _ _ _) = Just name importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d importToCoreFn _ = Nothing diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndDesugar.hs index a8b107fd78..2406db8850 100644 --- a/src/Language/PureScript/Docs/ParseAndDesugar.hs +++ b/src/Language/PureScript/Docs/ParseAndDesugar.hs @@ -108,9 +108,9 @@ fileInfoToString (FromDep _ fn) = fn addDefaultImport :: P.ModuleName -> P.Module -> P.Module addDefaultImport toImport m@(P.Module ss coms mn decls exps) = if isExistingImport `any` decls || mn == toImport then m - else P.Module ss coms mn (P.ImportDeclaration toImport P.Implicit Nothing : decls) exps + else P.Module ss coms mn (P.ImportDeclaration toImport P.Implicit Nothing False : decls) exps where - isExistingImport (P.ImportDeclaration mn' _ _) | mn' == toImport = True + isExistingImport (P.ImportDeclaration mn' _ _ _) | mn' == toImport = True isExistingImport (P.PositionedDeclaration _ _ d) = isExistingImport d isExistingImport _ = False diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 5c675ed5fa..5732d1106d 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -141,6 +141,7 @@ data SimpleErrorMessage | UnusedExplicitImport ModuleName [String] | UnusedDctorImport ProperName | UnusedDctorExplicitImport ProperName [ProperName] + | DeprecatedQualifiedSyntax ModuleName ModuleName deriving (Show) -- | Error message hints, providing more detailed information about failure. @@ -275,6 +276,7 @@ errorCode em = case unwrapErrorMessage em of UnusedExplicitImport{} -> "UnusedExplicitImport" UnusedDctorImport{} -> "UnusedDctorImport" UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport" + DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax" -- | @@ -692,6 +694,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:" , indent $ paras $ map (line .runProperName) names ] + renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) = + paras [ line $ "The import of type " ++ runModuleName name ++ " as " ++ runModuleName qualName ++ " uses the deprecated 'import qualified' syntax." + , line $ "This syntax form will be removed in PureScript 0.9." ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 036a748b31..9273ff818f 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -173,7 +173,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} fixityDecl _ = Nothing importDecl :: Declaration -> Maybe ExternsImport - importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn) + importDecl (ImportDeclaration m mt qmn _) = Just (ExternsImport m mt qmn) importDecl (PositionedDeclaration _ _ d) = importDecl d importDecl _ = Nothing diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 4888ca6165..014a415e51 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -270,9 +270,9 @@ make MakeActions{..} ms = do addDefaultImport :: ModuleName -> Module -> Module addDefaultImport toImport m@(Module ss coms mn decls exps) = if isExistingImport `any` decls || mn == toImport then m - else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps + else Module ss coms mn (ImportDeclaration toImport Implicit Nothing False : decls) exps where - isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True + isExistingImport (ImportDeclaration mn' _ _ _) | mn' == toImport = True isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d isExistingImport _ = False diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 9e22c65f94..b88417853a 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -57,7 +57,7 @@ usedModules :: Declaration -> [ModuleName] usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f where forDecls :: Declaration -> [ModuleName] - forDecls (ImportDeclaration mn _ _) = [mn] + forDecls (ImportDeclaration mn _ _ _) = [mn] forDecls _ = [] forValues :: Expr -> [ModuleName] diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 7986573639..dd5fdfab1a 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -141,10 +141,10 @@ parseFixityDeclaration = do parseImportDeclaration :: TokenParser Declaration parseImportDeclaration = do - (mn, declType, asQ) <- parseImportDeclaration' - return $ ImportDeclaration mn declType asQ + (mn, declType, asQ, isOldSyntax) <- parseImportDeclaration' + return $ ImportDeclaration mn declType asQ isOldSyntax -parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName) +parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName, Bool) parseImportDeclaration' = do reserved "import" indented @@ -154,7 +154,7 @@ parseImportDeclaration' = do moduleName' <- moduleName declType <- reserved "hiding" *> qualifyingList Hiding <|> qualifyingList Explicit qName <- P.optionMaybe qualifiedName - return (moduleName', declType, qName) + return (moduleName', declType, qName, False) qualifiedName = reserved "as" *> moduleName qualImport = do reserved "qualified" @@ -162,7 +162,7 @@ parseImportDeclaration' = do moduleName' <- moduleName declType <- qualifyingList Explicit qName <- qualifiedName - return (moduleName', declType, Just qName) + return (moduleName', declType, Just qName, True) qualifyingList expectedType = do idents <- P.optionMaybe $ indented *> parens (commaSep parseDeclarationRef) return $ fromMaybe Implicit (expectedType <$> idents) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 2cf496bd8c..5fd2df9d6d 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -142,7 +142,7 @@ elaborateImports imps (Module ss coms mn decls exps) = Module ss coms mn decls' fqValues (Var (Qualified (Just mn') _)) | mn' `notElem` importedModules imps = [mn'] fqValues _ = [] mkImport :: ModuleName -> Declaration - mkImport mn' = ImportDeclaration mn' (Explicit []) Nothing + mkImport mn' = ImportDeclaration mn' (Explicit []) Nothing False -- | -- Replaces all local names with qualified names within a module and checks that all existing diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 70d61b25f1..fe6f1739a6 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -25,7 +25,7 @@ import Prelude () import Prelude.Compat import Data.List (find) -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (fromMaybe, isNothing, fromJust) import Data.Foldable (traverse_) import Control.Arrow (first) @@ -48,7 +48,8 @@ import Language.PureScript.Sugar.Names.Env findImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) findImports = foldM (go Nothing) M.empty where - go pos result (ImportDeclaration mn typ qual) = do + go pos result (ImportDeclaration mn typ qual isOldSyntax) = do + when isOldSyntax . tell . errorMessage $ DeprecatedQualifiedSyntax mn (fromJust qual) checkImportRefType typ let imp = (pos, typ, qual) return $ M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result From 2fa21f96acb326fcc2efdc076559b786b4cbf3d3 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 21 Nov 2015 13:13:36 -0800 Subject: [PATCH 0167/1580] Sort rows in unification errors --- src/Language/PureScript/Errors.hs | 36 +++++++++++++++----- src/Language/PureScript/Pretty/Types.hs | 2 +- src/Language/PureScript/TypeChecker/Unify.hs | 2 +- 3 files changed, 30 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 5732d1106d..f16f4adbc1 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -21,8 +21,9 @@ module Language.PureScript.Errors where import Prelude () import Prelude.Compat +import Data.Ord (comparing) import Data.Either (lefts, rights) -import Data.List (intercalate, transpose, nub, nubBy) +import Data.List (intercalate, transpose, nub, nubBy, sortBy) import Data.Function (on) import Data.Foldable (fold) @@ -32,7 +33,7 @@ import Control.Monad import Control.Monad.Writer import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.State.Lazy -import Control.Arrow (first) +import Control.Arrow (first, (&&&)) import Language.PureScript.Crash import Language.PureScript.AST @@ -522,12 +523,31 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError <> foldMap (\expr -> [ line "Relevant expression: " , indent $ prettyPrintValue valueDepth expr ]) binding - renderSimpleErrorMessage (TypesDoNotUnify t1 t2) - = paras [ line "Could not match type" - , indent $ typeAsBox t1 - , line "with type" - , indent $ typeAsBox t2 - ] + renderSimpleErrorMessage (TypesDoNotUnify u1 u2) + = let (sorted1, sorted2) = sortRows u1 u2 + + sortRows :: Type -> Type -> (Type, Type) + sortRows r1@RCons{} r2@RCons{} = sortRows' (rowToList r1) (rowToList r2) + sortRows t1 t2 = (t1, t2) + + -- Put the common labels last + sortRows' :: ([(String, Type)], Type) -> ([(String, Type)], Type) -> (Type, Type) + sortRows' (s1, r1) (s2, r2) = + let common :: [(String, (Type, Type))] + common = sortBy (comparing fst) $ [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] + + sd1, sd2 :: [(String, Type)] + sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] + sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] + in ( rowFromList (sortBy (comparing fst) sd1 ++ map (fst &&& fst . snd) common, r1) + , rowFromList (sortBy (comparing fst) sd2 ++ map (fst &&& snd . snd) common, r2) + ) + in paras [ line "Could not match type" + , indent $ typeAsBox sorted1 + , line "with type" + , indent $ typeAsBox sorted2 + ] + renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = paras [ line "Could not match kind" , indent $ line $ prettyPrintKind k1 diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 717e610b94..b915b3164c 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -79,7 +79,7 @@ prettyPrintRowWith open close = uncurry listToBox . toList [] toList :: [(String, Type)] -> Type -> ([(String, Type)], Type) toList tys (RCons name ty row) = toList ((name, ty):tys) row - toList tys r = (tys, r) + toList tys r = (reverse tys, r) prettyPrintRow :: Type -> String prettyPrintRow = render . prettyPrintRowWith '(' ')' diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 241c52e599..cd2a7265bb 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -163,7 +163,7 @@ unifyRows r1 r2 = unifyRows' [] REmpty [] REmpty = return () unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return () unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return () - unifyRows' sd3 r3 sd4 r4 = throwError . errorMessage $ TypesDoNotUnify (rowFromList (sd3, r3)) (rowFromList (sd4, r4)) + unifyRows' _ _ _ _ = throwError . errorMessage $ TypesDoNotUnify r1 r2 -- | -- Check that two types unify From c2f0d1fa6e904635760dadd338548fbd97245293 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 21 Nov 2015 14:10:39 -0800 Subject: [PATCH 0168/1580] Fix #1636, instantiate polytypes fully, even under constraints. --- src/Language/PureScript/TypeChecker/Types.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index ef4d4e172f..d13234454c 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -213,8 +213,7 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do instantiatePolyTypeWithUnknowns val ty' instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do dicts <- getTypeClassDictionaries - (_, ty') <- instantiatePolyTypeWithUnknowns (internalError "Types under a constraint cannot themselves be constrained") ty - return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty') + instantiatePolyTypeWithUnknowns (foldl App val (map (flip TypeClassDictionary dicts) constraints)) ty instantiatePolyTypeWithUnknowns val ty = return (val, ty) -- | Infer a type for a value, rethrowing any error to provide a more useful error message From 84f86a622a81291f962c554f87482db9c8d085b2 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 22 Nov 2015 12:11:58 +0000 Subject: [PATCH 0169/1580] Warn about unused class imports --- src/Language/PureScript/Linter/Imports.hs | 11 +++++++++-- src/Language/PureScript/Sugar/Names.hs | 4 ++-- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 01f195a15a..bea80bc27d 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -25,7 +25,11 @@ import Language.PureScript.Sugar.Names.Imports import qualified Language.PureScript.Constants as C -- | Imported name used in some type or expression. -data Name = IdentName (Qualified Ident) | IsProperName (Qualified ProperName) | DctorName (Qualified ProperName) +data Name + = IdentName (Qualified Ident) + | TypeName (Qualified ProperName) + | DctorName (Qualified ProperName) + | ClassName (Qualified ProperName) -- | Map of module name to list of imported names from that module which have been used. type UsedImports = M.Map ModuleName [Name] @@ -63,6 +67,7 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do let ddiff = ctors \\ usedDctors in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff _ -> return () + return () _ -> return () @@ -102,7 +107,8 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x -matchName _ qual (IsProperName (Qualified q x)) | q == qual = Just $ runProperName x +matchName _ qual (TypeName (Qualified q x)) | q == qual = Just $ runProperName x +matchName _ qual (ClassName (Qualified q x)) | q == qual = Just $ runProperName x matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x matchName _ _ _ = Nothing @@ -114,6 +120,7 @@ runDeclRef :: DeclarationRef -> Maybe String runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref runDeclRef (ValueRef ident) = Just $ showIdent ident runDeclRef (TypeRef pn _) = Just $ runProperName pn +runDeclRef (TypeClassRef pn) = Just $ runProperName pn runDeclRef _ = Nothing getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName]) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 5fd2df9d6d..a0a4d00b83 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -226,13 +226,13 @@ renameInModule env imports (Module ss coms mn decls exps) = updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts) updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) - updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) IsProperName + updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TypeName updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) - updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) IsProperName + updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) ClassName updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident) updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName From 1209e86d3637a96ef01b5b1c86a525b2e933a9f9 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 22 Nov 2015 14:10:53 -0800 Subject: [PATCH 0170/1580] Add information about skolems to type errors --- src/Language/PureScript/Errors.hs | 110 +++++++++++------- src/Language/PureScript/Pretty/Types.hs | 2 +- .../PureScript/TypeChecker/Entailment.hs | 14 +-- src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- .../PureScript/TypeChecker/Skolems.hs | 16 +-- .../PureScript/TypeChecker/Subsumption.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 7 +- src/Language/PureScript/TypeChecker/Unify.hs | 14 +-- src/Language/PureScript/Types.hs | 3 +- 9 files changed, 102 insertions(+), 68 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index f16f4adbc1..0c3012f0d2 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -14,6 +14,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiParamTypeClasses #-} module Language.PureScript.Errors where @@ -24,7 +25,6 @@ import Prelude.Compat import Data.Ord (comparing) import Data.Either (lefts, rights) import Data.List (intercalate, transpose, nub, nubBy, sortBy) -import Data.Function (on) import Data.Foldable (fold) import qualified Data.Map as M @@ -33,7 +33,7 @@ import Control.Monad import Control.Monad.Writer import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.State.Lazy -import Control.Arrow (first, (&&&)) +import Control.Arrow ((&&&)) import Language.PureScript.Crash import Language.PureScript.AST @@ -311,11 +311,16 @@ onErrorMessages f = MultipleErrors . map f . runMultipleErrors addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint : hints) se --- | The various types of things which might need to be relabelled in errors messages. -data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord) - -- | A map from rigid type variable name/unknown variable pairs to new variables. -type UnknownMap = M.Map (LabelType, Int) Int +data TypeMap = TypeMap + { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan) + , umNextSkolem :: Int + , umUnknownMap :: M.Map Int Int + , umNextUnknown :: Int + } deriving Show + +defaultUnknownMap :: TypeMap +defaultUnknownMap = TypeMap M.empty 0 M.empty 0 -- | How critical the issue is data Level = Error | Warning deriving Show @@ -326,56 +331,80 @@ data Level = Error | Warning deriving Show unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage unwrapErrorMessage (ErrorMessage _ se) = se -replaceUnknowns :: Type -> State UnknownMap Type +replaceUnknowns :: Type -> State TypeMap Type replaceUnknowns = everywhereOnTypesM replaceTypes where - lookupTable :: (LabelType, Int) -> UnknownMap -> (Int, UnknownMap) - lookupTable x m = case M.lookup x m of - Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m) - Just i -> (i, m) - - replaceTypes :: Type -> State UnknownMap Type - replaceTypes (TUnknown u) = state $ first TUnknown . lookupTable (TypeLabel, u) - replaceTypes (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (SkolemLabel name, s) + replaceTypes :: Type -> State TypeMap Type + replaceTypes (TUnknown u) = do + m <- get + case M.lookup u (umUnknownMap m) of + Nothing -> do + let u' = umNextUnknown m + put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextUnknown = u' + 1 } + return (TUnknown u') + Just u' -> return (TUnknown u') + replaceTypes (Skolem name s sko ss) = do + m <- get + case M.lookup s (umSkolemMap m) of + Nothing -> do + let s' = umNextSkolem m + put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextSkolem = s' + 1 } + return (Skolem name s' sko ss) + Just (_, s', _) -> return (Skolem name s' sko ss) replaceTypes other = return other onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple where - gSimple (InfiniteType t) = InfiniteType <$> f t - gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2 - gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2 - gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t - gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e - gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t - gSimple other = pure other - gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2 - gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2 - gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t - gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t - gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2 - gHint other = pure other + gSimple (InfiniteType t) = InfiniteType <$> f t + gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2 + gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2 + gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t + gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e + gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t + gSimple other = pure other + + gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2 + gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2 + gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t + gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t + gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2 + gHint other = pure other -- | -- Pretty print a single error, simplifying if necessary -- -prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State UnknownMap Box.Box -prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) +prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State TypeMap Box.Box +prettyPrintSingleError full level e = do + em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) + um <- get + return (prettyPrintErrorMessage um em) where -- Pretty print an ErrorMessage - prettyPrintErrorMessage :: ErrorMessage -> Box.Box - prettyPrintErrorMessage (ErrorMessage hints simple) = + prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box + prettyPrintErrorMessage typeMap (ErrorMessage hints simple) = paras $ - [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints - , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, " - , line $ "or to contribute content related to this " ++ levelText ++ "." - ] - ] + foldr renderHint (indent (renderSimpleErrorMessage simple)) hints + : typeInformation + ++ [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, " + , line $ "or to contribute content related to this " ++ levelText ++ "." + ] + ] where wikiUri :: String wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e + typeInformation :: [Box.Box] + typeInformation = M.elems . M.mapMaybe skolemInfo . umSkolemMap $ typeMap + where + skolemInfo :: (String, Int, Maybe SourceSpan) -> Maybe Box.Box + skolemInfo (name, s, Just ss) = + Just . Box.moveDown 1 $ paras [ line $ "(" ++ name ++ show s ++ " is a rigid type variable" + , line $ " bound at " ++ displayStartEndPos ss ++ ")" + ] + skolemInfo _ = Nothing + renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box renderSimpleErrorMessage (CannotGetFileInfo path) = paras [ line "Unable to read file info: " @@ -878,6 +907,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError hintCategory ErrorUnifyingTypes{} = CheckHint hintCategory ErrorInSubsumption{} = CheckHint hintCategory ErrorInApplication{} = CheckHint + hintCategory ErrorCheckingKind{} = CheckHint hintCategory PositionedError{} = PositionHint hintCategory _ = OtherHint @@ -895,13 +925,13 @@ prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox fu -- | Pretty print warnings as a Box prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box -prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full +prettyPrintMultipleWarningsBox full = flip evalState defaultUnknownMap . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full -- | Pretty print errors as a Box prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box -prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full +prettyPrintMultipleErrorsBox full = flip evalState defaultUnknownMap . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full -prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box +prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State TypeMap Box.Box prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do result <- prettyPrintSingleError full level e return $ diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index b915b3164c..63c4853e61 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -45,7 +45,7 @@ typeLiterals = mkPattern match match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor match (TUnknown u) = Just $ text $ '_' : show u - match (Skolem name s _) = Just $ text $ name ++ show s + match (Skolem name s _ _) = Just $ text $ name ++ show s match REmpty = Just $ text "()" match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row match _ = Nothing diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index c290f0fb51..6ca8412c0c 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -147,7 +147,7 @@ entails moduleName context = solve -- and return a substitution from type variables to types which makes the type heads unify. -- typeHeadsAreEqual :: ModuleName -> Type -> Type -> Maybe [(String, Type)] -typeHeadsAreEqual _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just [] +typeHeadsAreEqual _ (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Just [] typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)] typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just [] typeHeadsAreEqual m (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m h1 h2 @@ -164,12 +164,12 @@ typeHeadsAreEqual m r1@RCons{} r2@RCons{} = <*> go sd1 r1' sd2 r2' where go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)] - go [] REmpty [] REmpty = Just [] - go [] (TUnknown _) _ _ = Just [] - go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = Just [] - go [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = Just [] - go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))] - go _ _ _ _ = Nothing + go [] REmpty [] REmpty = Just [] + go [] (TUnknown _) _ _ = Just [] + go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = Just [] + go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = Just [] + go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))] + go _ _ _ _ = Nothing typeHeadsAreEqual _ _ _ = Nothing -- | diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 37872f2d6b..976aecda72 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -226,7 +226,7 @@ infer' other = (, []) <$> go other go (TypeVar v) = do Just moduleName <- checkCurrentModule <$> get lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) - go (Skolem v _ _) = do + go (Skolem v _ _ _) = do Just moduleName <- checkCurrentModule <$> get lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) go (TypeConstructor v) = do diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index a5c0514272..a345c08c6b 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -71,30 +71,30 @@ newSkolemScope = do -- | -- Skolemize a type variable by replacing its instances with fresh skolem constants -- -skolemize :: String -> Int -> SkolemScope -> Type -> Type -skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope) +skolemize :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type +skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss) -- | -- This function has one purpose - to skolemize type variables appearing in a -- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the -- only example of scoped type variables. -- -skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr -skolemizeTypesInValue ident sko scope = +skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr +skolemizeTypesInValue ident sko scope ss = let (_, f, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS in runIdentity . f where onExpr :: [String] -> Expr -> Identity ([String], Expr) onExpr sco (SuperClassDictionary c ts) - | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope) ts)) + | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope ss) ts)) onExpr sco (TypedValue check val ty) - | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ty)) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty)) onExpr sco other = return (sco, other) onBinder :: [String] -> Binder -> Identity ([String], Binder) onBinder sco (TypedBinder ty b) - | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ty) b) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ss ty) b) onBinder sco other = return (sco, other) peelTypeVars :: Type -> [String] @@ -129,7 +129,7 @@ skolemEscapeCheck root@TypedValue{} = collectSkolems :: Type -> [SkolemScope] collectSkolems = nub . everythingOnTypes (++) collect where - collect (Skolem _ _ scope) = [scope] + collect (Skolem _ _ scope _) = [scope] collect _ = [] go scos _ = (scos, []) findBindingScope :: SkolemScope -> Maybe Expr diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 7e4d9afb78..023642e9ea 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -55,7 +55,7 @@ subsumes' val ty1 (ForAll ident ty2 sco) = case sco of Just sco' -> do sko <- newSkolemConstant - let sk = skolemize ident sko sco' ty2 + let sk = skolemize ident sko sco' Nothing ty2 subsumes val ty1 sk Nothing -> internalError "subsumes: unspecified skolem scope" subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index d13234454c..eb2ef303ea 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -487,8 +487,11 @@ check' :: forall m. check' val (ForAll ident ty _) = do scope <- newSkolemScope sko <- newSkolemConstant - let sk = skolemize ident sko scope ty - let skVal = skolemizeTypesInValue ident sko scope val + let ss = case val of + PositionedValue pos _ _ -> Just pos + _ -> Nothing + sk = skolemize ident sko scope ss ty + skVal = skolemizeTypesInValue ident sko scope ss val val' <- check skVal sk return $ TypedValue True val' (ForAll ident ty (Just scope)) check' val t@(ConstrainedType constraints ty) = do diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index cd2a7265bb..92d7b7f56b 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -105,13 +105,13 @@ unifyTypes t1 t2 = do case (sc1, sc2) of (Just sc1', Just sc2') -> do sko <- newSkolemConstant - let sk1 = skolemize ident1 sko sc1' ty1 - let sk2 = skolemize ident2 sko sc2' ty2 + let sk1 = skolemize ident1 sko sc1' Nothing ty1 + let sk2 = skolemize ident2 sko sc2' Nothing ty2 sk1 `unifyTypes` sk2 _ -> internalError "unifyTypes: unspecified skolem scope" unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do sko <- newSkolemConstant - let sk = skolemize ident sko sc ty1 + let sk = skolemize ident sko sc Nothing ty1 sk `unifyTypes` ty2 unifyTypes' ForAll{} _ = internalError "unifyTypes: unspecified skolem scope" unifyTypes' ty f@ForAll{} = f `unifyTypes` ty @@ -121,7 +121,7 @@ unifyTypes t1 t2 = do unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do t3 `unifyTypes` t5 t4 `unifyTypes` t6 - unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return () + unifyTypes' (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = return () unifyTypes' (KindedType ty1 _) ty2 = ty1 `unifyTypes` ty2 unifyTypes' ty1 (KindedType ty2 _) = ty1 `unifyTypes` ty2 unifyTypes' r1@RCons{} r2 = unifyRows r1 r2 @@ -162,7 +162,7 @@ unifyRows r1 r2 = solveType u2 (rowFromList (sd1, rest)) unifyRows' [] REmpty [] REmpty = return () unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return () - unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return () + unifyRows' [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = return () unifyRows' _ _ _ _ = throwError . errorMessage $ TypesDoNotUnify r1 r2 -- | @@ -170,7 +170,7 @@ unifyRows r1 r2 = -- unifiesWith :: Type -> Type -> Bool unifiesWith (TUnknown u1) (TUnknown u2) | u1 == u2 = True -unifiesWith (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True +unifiesWith (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = True unifiesWith (TypeVar v1) (TypeVar v2) | v1 == v2 = True unifiesWith (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2 @@ -187,7 +187,7 @@ unifiesWith r1@RCons{} r2@RCons{} = go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool go [] REmpty [] REmpty = True go [] (TypeVar v1) [] (TypeVar v2) = v1 == v2 - go [] (Skolem _ s1 _) [] (Skolem _ s2 _) = s1 == s2 + go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2 go [] (TUnknown _) _ _ = True go _ _ [] (TUnknown _) = True go _ (TUnknown _) _ (TUnknown _) = True diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 940a5c3f14..7727cff115 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -34,6 +34,7 @@ import Control.Monad ((<=<)) import Language.PureScript.Names import Language.PureScript.Kinds import Language.PureScript.Traversals +import Language.PureScript.AST.SourcePos -- | -- An identifier for the scope of a skolem variable @@ -75,7 +76,7 @@ data Type -- | -- A skolem constant -- - | Skolem String Int SkolemScope + | Skolem String Int SkolemScope (Maybe SourceSpan) -- | -- An empty row -- From ed29a5961b204787f5b629e4715ea0418686c553 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 22 Nov 2015 23:04:04 +0000 Subject: [PATCH 0171/1580] Warn on duplicate imports --- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Errors.hs | 38 ++++++++++++++++--- .../PureScript/Sugar/Names/Imports.hs | 35 +++++++++++++++-- 3 files changed, 65 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 3f20c84493..2e06986c63 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -109,7 +109,7 @@ data ImportDeclarationType -- An import with a list of references to hide: `import M hiding (foo)` -- | Hiding [DeclarationRef] - deriving (Show, Read, D.Data, D.Typeable) + deriving (Eq, Show, Read, D.Data, D.Typeable) -- | -- The data type of declarations diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index f16f4adbc1..0e4e973cbc 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -143,6 +143,9 @@ data SimpleErrorMessage | UnusedDctorImport ProperName | UnusedDctorExplicitImport ProperName [ProperName] | DeprecatedQualifiedSyntax ModuleName ModuleName + | RedundantUnqualifiedImport ModuleName ImportDeclarationType + | DuplicateSelectiveImport ModuleName + | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) deriving (Show) -- | Error message hints, providing more detailed information about failure. @@ -278,6 +281,9 @@ errorCode em = case unwrapErrorMessage em of UnusedDctorImport{} -> "UnusedDctorImport" UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport" DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax" + RedundantUnqualifiedImport{} -> "RedundantUnqualifiedImport" + DuplicateSelectiveImport{} -> "DuplicateSelectiveImport" + DuplicateImport{} -> "DuplicateImport" -- | @@ -718,6 +724,15 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError paras [ line $ "The import of type " ++ runModuleName name ++ " as " ++ runModuleName qualName ++ " uses the deprecated 'import qualified' syntax." , line $ "This syntax form will be removed in PureScript 0.9." ] + renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) = + line $ "Import of " ++ prettyPrintImport name imp Nothing ++ " is redundant due to a whole-module import" + + renderSimpleErrorMessage (DuplicateSelectiveImport name) = + line $ "There is an existing import of " ++ runModuleName name ++ ", consider merging the import lists" + + renderSimpleErrorMessage (DuplicateImport name imp qual) = + line $ "Duplicate import of " ++ prettyPrintImport name imp qual + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail @@ -849,11 +864,24 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError -- Pretty print and export declaration prettyPrintExport :: DeclarationRef -> String prettyPrintExport (TypeRef pn _) = runProperName pn - prettyPrintExport (ValueRef ident) = showIdent ident - prettyPrintExport (TypeClassRef pn) = runProperName pn - prettyPrintExport (TypeInstanceRef ident) = showIdent ident - prettyPrintExport (ModuleRef name) = "module " ++ runModuleName name - prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref + prettyPrintExport ref = prettyPrintRef ref + + prettyPrintRef :: DeclarationRef -> String + prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)" + prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")" + prettyPrintRef (ValueRef ident) = showIdent ident + prettyPrintRef (TypeClassRef pn) = runProperName pn + prettyPrintRef (TypeInstanceRef ident) = showIdent ident + prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name + prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref + + prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String + prettyPrintImport mn idt qual = + let i = case idt of + Implicit -> runModuleName mn + Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" + Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")" + in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual -- | Simplify an error message simplifyErrorMessage :: ErrorMessage -> ErrorMessage diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index fe6f1739a6..f3c21ab37a 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -24,9 +24,9 @@ module Language.PureScript.Sugar.Names.Imports import Prelude () import Prelude.Compat -import Data.List (find) -import Data.Maybe (fromMaybe, isNothing, fromJust) -import Data.Foldable (traverse_) +import Data.List (find, delete) +import Data.Maybe (fromMaybe, isJust, isNothing, fromJust) +import Data.Foldable (traverse_, for_) import Control.Arrow (first) import Control.Monad @@ -70,9 +70,36 @@ findImports = foldM (go Nothing) M.empty resolveImports :: (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports resolveImports env (Module _ _ currentModule decls _) = censor (addHint (ErrorInModule currentModule)) $ do - scope <- M.insert currentModule [(Nothing, Implicit, Nothing)] <$> findImports decls + imports <- findImports decls + + for_ (M.toList imports) $ \(mn, imps) -> do + let unqual = filter (\(_, _, q) -> isJust q) (reverse imps) + + when (length imps > 1) $ for_ (selfCartesianSubset imps) $ + \((_, t1, q1), (pos, t2, q2)) -> + when (t1 == t2 && q1 == q2) $ + maybe id warnWithPosition pos $ + tell . errorMessage $ DuplicateImport mn t2 q2 + + when (length unqual > 1) $ + case find (\(_, typ, _) -> typ == Implicit) unqual of + Just i -> + for_ (delete i unqual) $ \(pos, typ, _) -> + maybe id warnWithPosition pos $ + tell $ errorMessage $ RedundantUnqualifiedImport mn typ + Nothing -> + for_ (tail unqual) $ \(pos, _, _) -> + maybe id warnWithPosition pos $ + tell $ errorMessage $ DuplicateSelectiveImport mn + + let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports foldM (resolveModuleImport currentModule env) nullImports (M.toList scope) + where + selfCartesianSubset :: [a] -> [(a, a)] + selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs + selfCartesianSubset [] = [] + -- | Constructs a set of imports for a single module import. resolveModuleImport :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => From e7430f75a64019910733a3a978a39e28de1b5a6c Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 22 Nov 2015 16:16:01 -0800 Subject: [PATCH 0172/1580] Fix #1185, fix #1369, add everythingWithScope traversal to correct some scoping issues. --- examples/passing/1185.purs | 13 +++ src/Language/PureScript/AST/Traversals.hs | 107 ++++++++++++++++++ src/Language/PureScript/Linter.hs | 74 ++++++------ .../PureScript/Sugar/BindingGroups.hs | 18 +-- 4 files changed, 165 insertions(+), 47 deletions(-) create mode 100644 examples/passing/1185.purs diff --git a/examples/passing/1185.purs b/examples/passing/1185.purs new file mode 100644 index 0000000000..eddb5891d7 --- /dev/null +++ b/examples/passing/1185.purs @@ -0,0 +1,13 @@ +module Main where + +data Person = Person String Boolean + +getName :: Person -> String +getName p = case p of + Person name true -> name + _ -> "Unknown" + +name :: String +name = getName (Person "John Smith" true) + +main = Control.Monad.Eff.Console.log "Done" diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 3378a6c314..330aaaa74e 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -18,6 +18,10 @@ import Prelude () import Prelude.Compat import Data.Maybe (mapMaybe) +import Data.List (mapAccumL) +import Data.Foldable (fold) +import qualified Data.Set as S + import Control.Monad import Control.Arrow ((***), (+++), second) @@ -25,6 +29,7 @@ import Language.PureScript.AST.Binders import Language.PureScript.AST.Declarations import Language.PureScript.Types import Language.PureScript.Traversals +import Language.PureScript.Names everywhereOnValues :: (Declaration -> Declaration) -> (Expr -> Expr) -> @@ -389,6 +394,108 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1 +everythingWithScope :: + (Monoid r) => + (S.Set Ident -> Declaration -> r) -> + (S.Set Ident -> Expr -> r) -> + (S.Set Ident -> Binder -> r) -> + (S.Set Ident -> CaseAlternative -> r) -> + (S.Set Ident -> DoNotationElement -> r) -> + S.Set Ident -> Declaration -> r +everythingWithScope f g h i j = f'' + where + -- Avoid importing Data.Monoid and getting shadowed names above + (<>) = mappend + + f'' s a = f s a <> f' s a + + f' s (DataBindingGroupDeclaration ds) = + let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds)) + in foldMap (f'' s') ds + f' s (ValueDeclaration name _ bs (Right val)) = + let s' = S.insert name s + in foldMap (h'' s') bs <> g'' s' val + f' s (ValueDeclaration name _ bs (Left gs)) = + let s' = S.insert name s + s'' = S.union s' (S.fromList (concatMap binderNames bs)) + in foldMap (h'' s') bs <> foldMap (\(grd, val) -> g'' s'' grd <> g'' s'' val) gs + f' s (BindingGroupDeclaration ds) = + let s' = S.union s (S.fromList (map (\(name, _, _) -> name) ds)) + in foldMap (\(_, _, val) -> g'' s' val) ds + f' s (TypeClassDeclaration _ _ _ ds) = foldMap (f'' s) ds + f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds + f' s (PositionedDeclaration _ _ d) = f'' s d + f' _ _ = mempty + + g'' s a = g s a <> g' s a + + g' s (UnaryMinus v1) = g'' s v1 + g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2 + g' s (Parens v1) = g'' s v1 + g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v + g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v + g' s (ArrayLiteral vs) = foldMap (g'' s) vs + g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs + g' s (ObjectConstructor vs) = foldMap (g'' s) (mapMaybe snd vs) + g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 + g' s (Accessor _ v1) = g'' s v1 + g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs + g' s (ObjectUpdater obj vs) = foldMap (g'' s) obj <> foldMap (g'' s) (mapMaybe snd vs) + g' s (Abs (Left name) v1) = + let s' = S.insert name s + in g'' s' v1 + g' s (Abs (Right b) v1) = + let s' = S.union (S.fromList (binderNames b)) s + in g'' s' v1 + g' s (App v1 v2) = g'' s v1 <> g'' s v2 + g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 + g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts + g' s (TypedValue _ v1 _) = g'' s v1 + g' s (Let ds v1) = + let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds)) + in foldMap (f'' s') ds <> g'' s' v1 + g' s (Do es) = fold . snd . mapAccumL j'' s $ es + g' s (PositionedValue _ _ v1) = g'' s v1 + g' _ _ = mempty + + h'' s a = h s a <> h' s a + + h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs + h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs + h' s (ArrayBinder bs) = foldMap (h'' s) bs + h' s (NamedBinder name b1) = + let s' = S.insert name s + in h'' s' b1 + h' s (PositionedBinder _ _ b1) = h'' s b1 + h' s (TypedBinder _ b1) = h'' s b1 + h' _ _ = mempty + + i'' s a = i s a <> i' s a + + i' s (CaseAlternative bs (Right val)) = + let s' = S.union s (S.fromList (concatMap binderNames bs)) + in foldMap (h'' s) bs <> g'' s' val + i' s (CaseAlternative bs (Left gs)) = + let s' = S.union s (S.fromList (concatMap binderNames bs)) + in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs + + j'' s a = let (s', r) = j' s a in (s', j s a <> r) + + j' s (DoNotationValue v) = (s, g'' s v) + j' s (DoNotationBind b v) = + let s' = S.union (S.fromList (binderNames b)) s + in (s', h'' s b <> g'' s' v) + j' s (DoNotationLet ds) = + let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds)) + in (s', foldMap (f'' s') ds) + j' s (PositionedDoNotationElement _ _ e1) = j'' s e1 + + getDeclIdent :: Declaration -> Maybe Ident + getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d + getDeclIdent (ValueDeclaration ident _ _ _) = Just ident + getDeclIdent (TypeDeclaration ident _) = Just ident + getDeclIdent _ = Nothing + accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r) accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) where diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 10991c8cc1..77b9abef7c 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -14,13 +14,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} module Language.PureScript.Linter (lint, module L) where import Prelude () import Prelude.Compat -import Data.List (mapAccumL, nub, (\\)) +import Data.List (nub, (\\)) import Data.Maybe (mapMaybe) import Data.Monoid @@ -54,43 +55,46 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl getDeclIdent _ = Nothing lintDeclaration :: Declaration -> m () - lintDeclaration d = - let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend stepD stepE stepB def def - - f' :: Declaration -> MultipleErrors - f' (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' dec) - f' dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (f dec <> checkTypeVarsInDecl dec) - f' (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty) - f' dec = f dec <> checkTypeVarsInDecl dec - - in tell (f' d) + lintDeclaration = tell . f where - def s _ = (s, mempty) + warningsInDecl = everythingWithScope stepD stepE stepB (\_ _ -> mempty) stepDo moduleNames + + f :: Declaration -> MultipleErrors + f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec) + f dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl dec <> checkTypeVarsInDecl dec) + f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty) + f dec = warningsInDecl dec <> checkTypeVarsInDecl dec - stepD :: S.Set Ident -> Declaration -> (S.Set Ident, MultipleErrors) - stepD s (TypeClassDeclaration name _ _ decls) = (s, foldr go mempty decls) + stepD :: S.Set Ident -> Declaration -> MultipleErrors + stepD _ (TypeClassDeclaration name _ _ decls) = foldMap go decls + where + go :: Declaration -> MultipleErrors + go (PositionedDeclaration _ _ d') = go d' + go (TypeDeclaration op@(Op _) _) = errorMessage (ClassOperator name op) + go _ = mempty + stepD _ _ = mempty + + stepE :: S.Set Ident -> Expr -> MultipleErrors + stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name) + stepE s (Let ds' _) = foldMap go ds' + where + go d | Just i <- getDeclIdent d + , i `S.member` s = errorMessage (ShadowedName i) + | otherwise = mempty + stepE _ _ = mempty + + stepB :: S.Set Ident -> Binder -> MultipleErrors + stepB s (VarBinder name) | name `S.member` s = errorMessage (ShadowedName name) + stepB s (NamedBinder name _) | name `S.member` s = errorMessage (ShadowedName name) + stepB _ _ = mempty + + stepDo :: S.Set Ident -> DoNotationElement -> MultipleErrors + stepDo s (DoNotationLet ds') = foldMap go ds' where - go :: Declaration -> MultipleErrors -> MultipleErrors - go (PositionedDeclaration _ _ d') errs = go d' errs - go (TypeDeclaration op@(Op _) _) errs = errorMessage (ClassOperator name op) <> errs - go _ errs = errs - stepD s _ = (s, mempty) - - stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors) - stepE s (Abs (Left name) _) = bindName s name - stepE s (Let ds' _) = - case mapAccumL bindName s (nub (mapMaybe getDeclIdent ds')) of - (s', es) -> (s', mconcat es) - stepE s _ = (s, mempty) - - stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors) - stepB s (VarBinder name) = bindName s name - stepB s (NamedBinder name _) = bindName s name - stepB s (TypedBinder _ b) = stepB s b - stepB s _ = (s, mempty) - - bindName :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors) - bindName = bind ShadowedName + go d | Just i <- getDeclIdent d + , i `S.member` s = errorMessage (ShadowedName i) + | otherwise = mempty + stepDo _ _ = mempty checkTypeVarsInDecl :: Declaration -> MultipleErrors checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index ff6c03f090..64fa11a031 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -102,20 +102,14 @@ collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val collapseBindingGroupsForValue other = other usedIdents :: ModuleName -> Declaration -> [Ident] -usedIdents moduleName = - let (f, _, _, _, _) = everythingWithContextOnValues S.empty [] (++) def usedNamesE usedNamesB def def - in nub . f +usedIdents moduleName = nub . everythingWithScope def usedNamesE def def def S.empty where - def s _ = (s, []) - - usedNamesE :: S.Set Ident -> Expr -> (S.Set Ident, [Ident]) - usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = (scope, [name]) - usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = (scope, [name]) - usedNamesE scope (Abs (Left name) _) = (name `S.insert` scope, []) - usedNamesE scope _ = (scope, []) + def _ _ = [] - usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident]) - usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), []) + usedNamesE :: S.Set Ident -> Expr -> [Ident] + usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = [name] + usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = [name] + usedNamesE _ _ = [] usedImmediateIdents :: ModuleName -> Declaration -> [Ident] usedImmediateIdents moduleName = From b88c0637a8500fdbe80c34380ae9ea1946d4bb52 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 22 Nov 2015 16:39:38 -0800 Subject: [PATCH 0173/1580] Fix tests. --- src/Language/PureScript/AST/Traversals.hs | 8 ++++++-- src/Language/PureScript/Linter.hs | 6 +++--- src/Language/PureScript/Sugar/BindingGroups.hs | 9 ++++++++- 3 files changed, 17 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 330aaaa74e..0f7e62cb01 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -401,8 +401,12 @@ everythingWithScope :: (S.Set Ident -> Binder -> r) -> (S.Set Ident -> CaseAlternative -> r) -> (S.Set Ident -> DoNotationElement -> r) -> - S.Set Ident -> Declaration -> r -everythingWithScope f g h i j = f'' + ( S.Set Ident -> Declaration -> r + , S.Set Ident -> Expr -> r + , S.Set Ident -> Binder -> r + , S.Set Ident -> CaseAlternative -> r + , S.Set Ident -> DoNotationElement -> r) +everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) where -- Avoid importing Data.Monoid and getting shadowed names above (<>) = mappend diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 77b9abef7c..1ed552da49 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -57,13 +57,13 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl lintDeclaration :: Declaration -> m () lintDeclaration = tell . f where - warningsInDecl = everythingWithScope stepD stepE stepB (\_ _ -> mempty) stepDo moduleNames + (warningsInDecl, _, _, _, _) = everythingWithScope stepD stepE stepB (\_ _ -> mempty) stepDo f :: Declaration -> MultipleErrors f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec) - f dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl dec <> checkTypeVarsInDecl dec) + f dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec) f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty) - f dec = warningsInDecl dec <> checkTypeVarsInDecl dec + f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec stepD :: S.Set Ident -> Declaration -> MultipleErrors stepD _ (TypeClassDeclaration name _ _ decls) = foldMap go decls diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 64fa11a031..6b330c44d7 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -102,10 +102,17 @@ collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val collapseBindingGroupsForValue other = other usedIdents :: ModuleName -> Declaration -> [Ident] -usedIdents moduleName = nub . everythingWithScope def usedNamesE def def def S.empty +usedIdents moduleName = nub . usedIdents' S.empty . getValue where def _ _ = [] + getValue (ValueDeclaration _ _ [] (Right val)) = val + getValue ValueDeclaration{} = internalError "Binders should have been desugared" + getValue (PositionedDeclaration _ _ d) = getValue d + getValue _ = internalError "Expected ValueDeclaration" + + (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def + usedNamesE :: S.Set Ident -> Expr -> [Ident] usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = [name] usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = [name] From 3dc8f3574b9848c04f00ad54803023e63f80b494 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 22 Nov 2015 23:26:39 +0000 Subject: [PATCH 0174/1580] Fix two cases where errors were missing context --- src/Language/PureScript/Sugar/Names/Imports.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index f3c21ab37a..fba9ba3079 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -31,7 +31,7 @@ import Data.Foldable (traverse_, for_) import Control.Arrow (first) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer (MonadWriter(..), censor) +import Control.Monad.Writer (MonadWriter(..)) import qualified Data.Map as M @@ -53,7 +53,7 @@ findImports = foldM (go Nothing) M.empty checkImportRefType typ let imp = (pos, typ, qual) return $ M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result - go _ result (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go (Just pos) result d + go _ result (PositionedDeclaration pos _ d) = warnAndRethrowWithPosition pos $ go (Just pos) result d go _ result _ = return result -- Ensure that classes don't appear in an `import X hiding (...)` @@ -69,7 +69,7 @@ findImports = foldM (go Nothing) M.empty -- resolveImports :: (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports resolveImports env (Module _ _ currentModule decls _) = - censor (addHint (ErrorInModule currentModule)) $ do + warnAndRethrow (addHint (ErrorInModule currentModule)) $ do imports <- findImports decls for_ (M.toList imports) $ \(mn, imps) -> do From a0723167fe7f1bca9a674b6b34dd4fb328131f73 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 23 Nov 2015 09:35:51 +0000 Subject: [PATCH 0175/1580] Check int values are within range in codegen --- examples/failing/IntOutOfRange.purs | 6 ++++ src/Language/PureScript/CodeGen/JS.hs | 51 ++++++++++++++++----------- src/Language/PureScript/Errors.hs | 6 ++++ tests/support/bower.json | 2 +- 4 files changed, 43 insertions(+), 22 deletions(-) create mode 100644 examples/failing/IntOutOfRange.purs diff --git a/examples/failing/IntOutOfRange.purs b/examples/failing/IntOutOfRange.purs new file mode 100644 index 0000000000..4ca27433ba --- /dev/null +++ b/examples/failing/IntOutOfRange.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith IntOutOfRange + +module Main where + +n :: Int +n = 35028715023 diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index e4093304e3..cdaf71bd55 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -34,6 +34,7 @@ import qualified Data.Traversable as T (traverse) import Control.Arrow ((&&&)) import Control.Monad (replicateM, forM) +import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class @@ -43,6 +44,7 @@ import Language.PureScript.CodeGen.JS.AST as AST import Language.PureScript.CodeGen.JS.Common as Common import Language.PureScript.CoreFn import Language.PureScript.Names +import Language.PureScript.Errors import Language.PureScript.CodeGen.JS.Optimizer import Language.PureScript.Options import Language.PureScript.Traversals (sndM) @@ -54,22 +56,23 @@ import System.FilePath.Posix (()) -- Generate code in the simplified Javascript intermediate representation for all declarations in a -- module. -- -moduleToJs :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSupply m) +moduleToJs :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) => Module Ann -> Maybe JS -> m [JS] -moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do - jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps - jsDecls <- mapM bindToJs decls - optimized <- T.traverse (T.traverse optimize) jsDecls - comments <- not <$> asks optionsNoComments - let strict = JSStringLiteral "use strict" - let header = if comments && not (null coms) then JSComment coms strict else strict - let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_] - let moduleBody = header : foreign' ++ jsImports ++ concat optimized - let foreignExps = exps `intersect` (fst `map` foreigns) - let standardExps = exps \\ foreignExps - let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps - ++ map (runIdent &&& foreignIdent) foreignExps - return $ moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps'] +moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = + rethrow (addHint (ErrorInModule mn)) $ do + jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps + jsDecls <- mapM bindToJs decls + optimized <- T.traverse (T.traverse optimize) jsDecls + comments <- not <$> asks optionsNoComments + let strict = JSStringLiteral "use strict" + let header = if comments && not (null coms) then JSComment coms strict else strict + let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_] + let moduleBody = header : foreign' ++ jsImports ++ concat optimized + let foreignExps = exps `intersect` (fst `map` foreigns) + let standardExps = exps \\ foreignExps + let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps + ++ map (runIdent &&& foreignIdent) foreignExps + return $ moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps'] where @@ -129,8 +132,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do -- Generate code in the simplified Javascript intermediate representation for a value or expression. -- valueToJs :: Expr Ann -> m JS - valueToJs (Literal _ l) = - literalToValueJS l + valueToJs (Literal (pos, _, _, _) l) = + maybe id rethrowWithPosition pos $ literalToValueJS l valueToJs (Var (_, _, _, Just (IsConstructor _ [])) name) = return $ JSAccessor "value" $ qualifiedToJS id name valueToJs (Var (_, _, _, Just (IsConstructor _ _)) name) = @@ -207,7 +210,13 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) [] literalToValueJS :: Literal (Expr Ann) -> m JS - literalToValueJS (NumericLiteral n) = return $ JSNumericLiteral n + literalToValueJS (NumericLiteral (Left i)) = + let minInt = -2147483648 + maxInt = 2147483647 + in if i < minInt || i > maxInt + then throwError . errorMessage $ IntOutOfRange i "JavaScript" minInt maxInt + else return $ JSNumericLiteral (Left i) + literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral (Right n) literalToValueJS (StringLiteral s) = return $ JSStringLiteral s literalToValueJS (CharLiteral c) = return $ JSStringLiteral [c] literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b @@ -275,10 +284,10 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do go _ _ _ = internalError "Invalid arguments to bindersToJs" failedPatternError :: [String] -> JS - failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral errorMessage) (JSArrayLiteral $ zipWith valueError names vals)] + failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral failedPatternMessage) (JSArrayLiteral $ zipWith valueError names vals)] - errorMessage :: String - errorMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": " + failedPatternMessage :: String + failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": " valueError :: String -> JS -> JS valueError _ l@(JSNumericLiteral _) = l diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8b8e33373f..38e060acd3 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -146,6 +146,7 @@ data SimpleErrorMessage | RedundantUnqualifiedImport ModuleName ImportDeclarationType | DuplicateSelectiveImport ModuleName | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) + | IntOutOfRange Integer String Integer Integer deriving (Show) -- | Error message hints, providing more detailed information about failure. @@ -284,6 +285,7 @@ errorCode em = case unwrapErrorMessage em of RedundantUnqualifiedImport{} -> "RedundantUnqualifiedImport" DuplicateSelectiveImport{} -> "DuplicateSelectiveImport" DuplicateImport{} -> "DuplicateImport" + IntOutOfRange{} -> "IntOutOfRange" -- | @@ -762,6 +764,10 @@ prettyPrintSingleError full level e = do renderSimpleErrorMessage (DuplicateImport name imp qual) = line $ "Duplicate import of " ++ prettyPrintImport name imp qual + renderSimpleErrorMessage (IntOutOfRange value backend lo hi) = + paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend." + , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail diff --git a/tests/support/bower.json b/tests/support/bower.json index 9d1b7d2d98..c29e6e82bc 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -2,7 +2,7 @@ "name": "purescript-test-suite-support", "dependencies": { "purescript-eff": "0.1.0", - "purescript-prelude": "0.1.1", + "purescript-prelude": "0.1.3", "purescript-assert": "0.1.1", "purescript-st": "0.1.0", "purescript-console": "0.1.0", From e56923080bf9f9168357ceaf47de6db298e36ef0 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 23 Nov 2015 16:19:10 +0000 Subject: [PATCH 0176/1580] Fix up shadowed module names in JS codegen --- examples/passing/ShadowedModuleName.purs | 15 +++++ src/Language/PureScript/CodeGen/JS.hs | 71 +++++++++++++++++++++--- 2 files changed, 79 insertions(+), 7 deletions(-) create mode 100644 examples/passing/ShadowedModuleName.purs diff --git a/examples/passing/ShadowedModuleName.purs b/examples/passing/ShadowedModuleName.purs new file mode 100644 index 0000000000..3b303904f9 --- /dev/null +++ b/examples/passing/ShadowedModuleName.purs @@ -0,0 +1,15 @@ +module Test where + + data Z = Z String + + runZ :: Z -> String + runZ (Z s) = s + +module Main where + + import Test + import Control.Monad.Eff.Console + + data Test = Test + + main = log (runZ (Z "done")) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index cdaf71bd55..c45e7fdba2 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -29,7 +29,8 @@ import Prelude () import Prelude.Compat import Data.List ((\\), delete, intersect) -import Data.Maybe (isNothing) +import Data.Maybe (isNothing, fromMaybe) +import qualified Data.Map as M import qualified Data.Traversable as T (traverse) import Control.Arrow ((&&&)) @@ -60,8 +61,11 @@ moduleToJs :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSup => Module Ann -> Maybe JS -> m [JS] moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = rethrow (addHint (ErrorInModule mn)) $ do - jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps - jsDecls <- mapM bindToJs decls + let usedNames = concatMap getNames decls + let mnLookup = renameImports usedNames imps + jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps + let decls' = renameModules mnLookup decls + jsDecls <- mapM bindToJs decls' optimized <- T.traverse (T.traverse optimize) jsDecls comments <- not <$> asks optionsNoComments let strict = JSStringLiteral "use strict" @@ -77,13 +81,66 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = where -- | - -- Generates Javascript code for a module import. + -- Extracts all declaration names from a binding group. -- - importToJs :: ModuleName -> m JS - importToJs mn' = do + getNames :: Bind Ann -> [Ident] + getNames (NonRec ident _) = [ident] + getNames (Rec vals) = map fst vals + + -- | + -- Creates alternative names for each module to ensure they don't collide + -- with declaration names. + -- + renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName + renameImports ids mns = go M.empty ids mns + where + go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName + go acc used (mn' : mns') = + let mni = Ident $ runModuleName mn' + in if mni `elem` used + then let newName = freshModuleName 1 mn' used + in go (M.insert mn' newName acc) (Ident (runModuleName newName) : used) mns' + else go (M.insert mn' mn' acc) (mni : used) mns' + go acc _ [] = acc + + freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName + freshModuleName i mn'@(ModuleName pns) used = + let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) ++ "_" ++ show i] + in if Ident (runModuleName newName) `elem` used + then freshModuleName (i + 1) mn' used + else newName + + -- | + -- Generates Javascript code for a module import, binding the required module + -- to the alternative + -- + importToJs :: M.Map ModuleName ModuleName -> ModuleName -> m JS + importToJs mnLookup mn' = do path <- asks optionsRequirePath + let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup let moduleBody = JSApp (JSVar "require") [JSStringLiteral (maybe id () path $ runModuleName mn')] - return $ JSVariableIntroduction (moduleNameToJs mn') (Just moduleBody) + return $ JSVariableIntroduction (moduleNameToJs mnSafe) (Just moduleBody) + + -- | + -- Replaces the `ModuleName`s in the AST so that the generated code refers to + -- the collision-avoiding renamed module imports. + -- + renameModules :: M.Map ModuleName ModuleName -> [Bind Ann] -> [Bind Ann] + renameModules mnLookup binds = + let (f, _, _) = everywhereOnValues id goExpr goBinder + in map f binds + where + goExpr :: Expr a -> Expr a + goExpr (Var ann q) = Var ann (renameQual q) + goExpr e = e + goBinder :: Binder a -> Binder a + goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs + goBinder b = b + renameQual :: Qualified a -> Qualified a + renameQual (Qualified (Just mn') a) = + let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup + in Qualified (Just mnSafe) a + renameQual q = q -- | -- Generate code in the simplified Javascript intermediate representation for a declaration From 521d20e62a9dad7111e4774b6cfe04d86731add1 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 23 Nov 2015 17:06:07 -0800 Subject: [PATCH 0177/1580] Fix #1664, check kind before expanding wildcards. --- examples/passing/1664.purs | 16 ++++++++++++++++ src/Language/PureScript/TypeChecker/Types.hs | 4 ++-- 2 files changed, 18 insertions(+), 2 deletions(-) create mode 100644 examples/passing/1664.purs diff --git a/examples/passing/1664.purs b/examples/passing/1664.purs new file mode 100644 index 0000000000..40260c78ca --- /dev/null +++ b/examples/passing/1664.purs @@ -0,0 +1,16 @@ +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console + +data Identity a = Identity a + +newtype IdentityEff e a = IdentityEff (Eff e (Identity a)) + +test :: forall e a. IdentityEff e a -> IdentityEff e Unit +test (IdentityEff action) = IdentityEff $ do + (Identity x :: Identity _) <- action + return $ Identity unit + +main = log "Done" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index eb2ef303ea..7ae8adcacb 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -406,9 +406,9 @@ inferBinder val (PositionedBinder pos _ binder) = -- change the definition of `binderRequiresMonotype`, -- and use `kindOfWithScopedVars`. inferBinder val (TypedBinder ty binder) = do + kind <- kindOf ty + checkTypeKind ty kind ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty - kind <- kindOf ty1 - checkTypeKind ty1 kind unifyTypes val ty1 inferBinder val binder From b90fc77eaf11606d36c78ce714e3a5ab9ba59b5d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 23 Nov 2015 17:40:43 -0800 Subject: [PATCH 0178/1580] Fix #1662, display extra type info in instance errors --- src/Language/PureScript/Errors.hs | 56 ++++++++++++++++++++++--------- 1 file changed, 41 insertions(+), 15 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 38e060acd3..80288ce860 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -370,6 +370,15 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t + gSimple (NoInstanceFound cl ts) = NoInstanceFound cl <$> traverse f ts + gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts + gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts + gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts + gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k + gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts + gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty + gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty + gSimple other = pure other gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2 @@ -377,6 +386,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2 + gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts gHint other = pure other -- | @@ -392,26 +402,33 @@ prettyPrintSingleError full level e = do -- Pretty print an ErrorMessage prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box prettyPrintErrorMessage typeMap (ErrorMessage hints simple) = - paras $ - foldr renderHint (indent (renderSimpleErrorMessage simple)) hints - : typeInformation - ++ [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, " - , line $ "or to contribute content related to this " ++ levelText ++ "." - ] - ] + paras + [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints + , Box.moveDown 1 typeInformation + , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, " + , line $ "or to contribute content related to this " ++ levelText ++ "." + ] + ] where wikiUri :: String wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e - typeInformation :: [Box.Box] - typeInformation = M.elems . M.mapMaybe skolemInfo . umSkolemMap $ typeMap + typeInformation :: Box.Box + typeInformation | not (null types) = Box.hsep 1 Box.left [ line "where", paras types] + | otherwise = Box.emptyBox 0 0 where - skolemInfo :: (String, Int, Maybe SourceSpan) -> Maybe Box.Box - skolemInfo (name, s, Just ss) = - Just . Box.moveDown 1 $ paras [ line $ "(" ++ name ++ show s ++ " is a rigid type variable" - , line $ " bound at " ++ displayStartEndPos ss ++ ")" - ] - skolemInfo _ = Nothing + types :: [Box.Box] + types = map skolemInfo (M.elems (umSkolemMap typeMap)) ++ + map unknownInfo (M.elems (umUnknownMap typeMap)) + + skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box + skolemInfo (name, s, ss) = + paras $ + line (name ++ show s ++ " is a rigid type variable") + : foldMap (return . line . (" bound at " ++) . displayStartEndPos) ss + + unknownInfo :: Int -> Box.Box + unknownInfo u = line $ "_" ++ show u ++ " is an unknown type" renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box renderSimpleErrorMessage (CannotGetFileInfo path) = @@ -613,7 +630,16 @@ prettyPrintSingleError full level e = do , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) ] + , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation." + | any containsUnknowns ts + ] ] + where + containsUnknowns :: Type -> Bool + containsUnknowns = everythingOnTypes (||) go + where + go TUnknown{} = True + go _ = False renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) = paras [ line "Type class instance for" , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) From e9b676f852068b58944006c720b741fa7905697e Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 24 Nov 2015 14:37:03 +0000 Subject: [PATCH 0179/1580] Remove unnecessary elaborateImports from Names --- src/Language/PureScript/Sugar/Names.hs | 25 ++++--------------------- 1 file changed, 4 insertions(+), 21 deletions(-) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index a0a4d00b83..6b5918e156 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -107,7 +107,7 @@ desugarImports externs modules = do let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m) findUnusedImports m env used - return $ elaborateImports imps m' + return m' -- | -- Make all exports for a module explicit. This may still effect modules that @@ -127,23 +127,6 @@ elaborateExports exps (Module ss coms mn decls refs) = my :: (Exports -> [(a, ModuleName)]) -> [a] my f = fst `map` filter ((== mn) . snd) (f exps) --- | --- Add `import X ()` for any modules where there are only fully qualified references to members. --- This ensures transitive instances are included when using a member from a module. --- -elaborateImports :: Imports -> Module -> Module -elaborateImports imps (Module ss coms mn decls exps) = Module ss coms mn decls' exps - where - decls' :: [Declaration] - decls' = - let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const []) - in mkImport `map` nub (f `concatMap` decls) ++ decls - fqValues :: Expr -> [ModuleName] - fqValues (Var (Qualified (Just mn') _)) | mn' `notElem` importedModules imps = [mn'] - fqValues _ = [] - mkImport :: ModuleName -> Declaration - mkImport mn' = ImportDeclaration mn' (Explicit []) Nothing False - -- | -- Replaces all local names with qualified names within a module and checks that all existing -- qualified names are valid. @@ -171,7 +154,7 @@ renameInModule env imports (Module ss coms mn decls exps) = updateDecl (pos, bound) (ExternDeclaration name ty) = (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty) updateDecl s d = return (s, d) - -- + updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr) updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v) @@ -192,7 +175,7 @@ renameInModule env imports (Module ss coms mn decls exps) = updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty) updateValue s v = return (s, v) - -- + updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder) updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v) @@ -204,7 +187,7 @@ renameInModule env imports (Module ss coms mn decls exps) = return (s', TypedBinder t' b') updateBinder s v = return (s, v) - -- + updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative) updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c) From e9f57069bb6b2c73f516f678df6e24b85f453024 Mon Sep 17 00:00:00 2001 From: Michael Karg Date: Wed, 25 Nov 2015 23:08:38 +0100 Subject: [PATCH 0180/1580] fixes purescript/#1673 --- psc-bundle/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index 819c87a479..8f29558287 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -70,7 +70,7 @@ app Options{..} = do input <- for inputFiles $ \filename -> do js <- liftIO (readFile filename) mid <- guessModuleIdentifier filename - return (mid, js) + length js `seq` return (mid, js) let entryIds = map (`ModuleIdentifier` Regular) optionsEntryPoints From 2cf5ec044ee729a797695b498b95a92e7c921652 Mon Sep 17 00:00:00 2001 From: Michael Karg Date: Thu, 26 Nov 2015 00:44:21 +0100 Subject: [PATCH 0181/1580] add comment --- psc-bundle/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index 8f29558287..5a4201b7da 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -70,7 +70,7 @@ app Options{..} = do input <- for inputFiles $ \filename -> do js <- liftIO (readFile filename) mid <- guessModuleIdentifier filename - length js `seq` return (mid, js) + length js `seq` return (mid, js) -- evaluate readFile till EOF before returning, not to exhaust file handles let entryIds = map (`ModuleIdentifier` Regular) optionsEntryPoints From e96d7b619ac56b11fa4d58762387e7f0e3e0abed Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 27 Nov 2015 15:04:16 +0000 Subject: [PATCH 0182/1580] Warn on duplicate values in import lists --- src/Language/PureScript/AST/Declarations.hs | 25 +++++++ src/Language/PureScript/Errors.hs | 10 +++ src/Language/PureScript/Linter/Imports.hs | 4 +- .../PureScript/Sugar/Names/Imports.hs | 74 +++++++++++++++---- 4 files changed, 95 insertions(+), 18 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 2e06986c63..d9348f17a6 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -15,6 +15,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} module Language.PureScript.AST.Declarations where @@ -22,6 +23,8 @@ import Prelude () import Prelude.Compat import Data.Aeson.TH +import Data.List (nub, (\\)) +import Data.Maybe (mapMaybe) import qualified Data.Data as D import qualified Data.Map as M @@ -93,6 +96,28 @@ isModuleRef :: DeclarationRef -> Bool isModuleRef (ModuleRef _) = True isModuleRef _ = False +-- | +-- Finds duplicate values in a list of declaration refs. The returned values +-- are the duplicate refs with data constructors elided, and then a separate +-- list of duplicate data constructors. +-- +findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName]) +findDuplicateRefs refs = + let positionless = stripPosInfo `map` refs + simplified = simplifyTypeRefs `map` positionless + dupeRefs = nub $ simplified \\ nub simplified + dupeCtors = concat $ flip mapMaybe positionless $ \case + TypeRef _ (Just dctors) -> + let dupes = dctors \\ nub dctors + in if null dupes then Nothing else Just dupes + _ -> Nothing + in (dupeRefs, dupeCtors) + where + stripPosInfo (PositionedDeclarationRef _ _ ref) = stripPosInfo ref + stripPosInfo other = other + simplifyTypeRefs (TypeRef pn _) = TypeRef pn Nothing + simplifyTypeRefs other = other + -- | -- The data type which specifies type of import declaration -- diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 80288ce860..b9bbc9bdd3 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -146,6 +146,8 @@ data SimpleErrorMessage | RedundantUnqualifiedImport ModuleName ImportDeclarationType | DuplicateSelectiveImport ModuleName | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) + | DuplicateImportRef String + | DuplicateExportRef String | IntOutOfRange Integer String Integer Integer deriving (Show) @@ -285,6 +287,8 @@ errorCode em = case unwrapErrorMessage em of RedundantUnqualifiedImport{} -> "RedundantUnqualifiedImport" DuplicateSelectiveImport{} -> "DuplicateSelectiveImport" DuplicateImport{} -> "DuplicateImport" + DuplicateImportRef{} -> "DuplicateImportRef" + DuplicateExportRef{} -> "DuplicateExportRef" IntOutOfRange{} -> "IntOutOfRange" @@ -790,6 +794,12 @@ prettyPrintSingleError full level e = do renderSimpleErrorMessage (DuplicateImport name imp qual) = line $ "Duplicate import of " ++ prettyPrintImport name imp qual + renderSimpleErrorMessage (DuplicateImportRef ref) = + line $ "Import list contains multiple references to " ++ ref + + renderSimpleErrorMessage (DuplicateExportRef ref) = + line $ "Export list contains multiple references to " ++ ref + renderSimpleErrorMessage (IntOutOfRange value backend lo hi) = paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend." , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ] diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index bea80bc27d..d3fd87ee94 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -8,7 +8,7 @@ import Prelude.Compat import qualified Data.Map as M import Data.Maybe (mapMaybe) -import Data.List ((\\), find, intersect) +import Data.List ((\\), find, intersect, nub) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class import Control.Monad(unless,when) @@ -50,7 +50,7 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do in case declType of Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni Explicit declrefs -> do - let idents = mapMaybe runDeclRef declrefs + let idents = nub (mapMaybe runDeclRef declrefs) let diff = idents \\ usedNames case (length diff, length idents) of (0, _) -> return () diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index fba9ba3079..13018c0501 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -14,6 +14,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} module Language.PureScript.Sugar.Names.Imports ( resolveImports @@ -24,9 +25,10 @@ module Language.PureScript.Sugar.Names.Imports import Prelude () import Prelude.Compat -import Data.List (find, delete) +import Data.List (find, delete, (\\)) import Data.Maybe (fromMaybe, isJust, isNothing, fromJust) import Data.Foldable (traverse_, for_) +import Data.Traversable (for) import Control.Arrow (first) import Control.Monad @@ -64,33 +66,48 @@ findImports = foldM (go Nothing) M.empty checkImportRef (ModuleRef name) = throwError . errorMessage $ ImportHidingModule name checkImportRef _ = return () +type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) + -- | -- Constructs a set of imports for a module. -- -resolveImports :: (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports +resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports resolveImports env (Module _ _ currentModule decls _) = warnAndRethrow (addHint (ErrorInModule currentModule)) $ do imports <- findImports decls for_ (M.toList imports) $ \(mn, imps) -> do - let unqual = filter (\(_, _, q) -> isJust q) (reverse imps) - when (length imps > 1) $ for_ (selfCartesianSubset imps) $ - \((_, t1, q1), (pos, t2, q2)) -> - when (t1 == t2 && q1 == q2) $ - maybe id warnWithPosition pos $ - tell . errorMessage $ DuplicateImport mn t2 q2 + -- Better ordering for the warnings: the list is in last-import-first + -- order, but we want the first appearence of an import to be the primary, + -- and warnings to appear for later imports + let imps' = reverse imps + + warned <- foldM (checkDuplicateImports mn) [] (selfCartesianSubset imps') + + let unqual = filter (\(_, _, q) -> isJust q) (imps' \\ warned) - when (length unqual > 1) $ - case find (\(_, typ, _) -> typ == Implicit) unqual of + warned' <- (warned ++) <$> + if (length unqual < 2) + then return [] + else case find (\(_, typ, _) -> typ == Implicit) unqual of Just i -> - for_ (delete i unqual) $ \(pos, typ, _) -> - maybe id warnWithPosition pos $ - tell $ errorMessage $ RedundantUnqualifiedImport mn typ + for (delete i unqual) $ \i'@(pos, typ, _) -> do + warn pos $ RedundantUnqualifiedImport mn typ + return i' Nothing -> - for_ (tail unqual) $ \(pos, _, _) -> - maybe id warnWithPosition pos $ - tell $ errorMessage $ DuplicateSelectiveImport mn + for (tail unqual) $ \i@(pos, _, _) -> do + warn pos $ DuplicateSelectiveImport mn + return i + + for_ (imps' \\ warned') $ \(pos, typ, _) -> + let (dupeRefs, dupeDctors) = findDuplicateRefs $ case typ of + Explicit refs -> refs + Hiding refs -> refs + _ -> [] + in warnDupeRefs pos dupeRefs >> warnDupeDctors pos dupeDctors + + return () let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports foldM (resolveModuleImport currentModule env) nullImports (M.toList scope) @@ -100,6 +117,31 @@ resolveImports env (Module _ _ currentModule decls _) = selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs selfCartesianSubset [] = [] + checkDuplicateImports :: ModuleName -> [ImportDef] -> (ImportDef, ImportDef) -> m [ImportDef] + checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) = + if (t1 == t2 && q1 == q2) + then do + warn pos $ DuplicateImport mn t2 q2 + return $ (pos, t2, q2) : xs + else return xs + + warnDupeRefs :: Maybe SourceSpan -> [DeclarationRef] -> m () + warnDupeRefs pos = traverse_ $ \case + TypeRef name _ -> warnDupe pos $ "type " ++ runProperName name + ValueRef name -> warnDupe pos $ "value " ++ runIdent name + TypeClassRef name -> warnDupe pos $ "class " ++ runProperName name + ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name + _ -> return () + + warnDupeDctors :: Maybe SourceSpan -> [ProperName] -> m () + warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName) + + warnDupe :: Maybe SourceSpan -> String -> m () + warnDupe pos ref = warn pos $ DuplicateImportRef ref + + warn :: Maybe SourceSpan -> SimpleErrorMessage -> m () + warn pos msg = maybe id warnWithPosition pos $ tell . errorMessage $ msg + -- | Constructs a set of imports for a single module import. resolveModuleImport :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => From 4ed379b03fa067e00fd8b6bcedb29b487c672d57 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 27 Nov 2015 15:21:00 +0000 Subject: [PATCH 0183/1580] Warn on duplicate values in export lists --- .../PureScript/Sugar/Names/Exports.hs | 21 ++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 6b46696abd..3c02f635ac 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -15,6 +15,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} module Language.PureScript.Sugar.Names.Exports ( findExportable @@ -29,6 +30,7 @@ import Data.Maybe (fromMaybe, mapMaybe) import Data.Foldable (traverse_) import Control.Monad +import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Error.Class (MonadError(..)) import qualified Data.Map as M @@ -66,14 +68,31 @@ findExportable (Module _ _ mn ds _) = -- Resolves the exports for a module, filtering out members that have not been -- exported and elaborating re-exports of other modules. -- -resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports +resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports resolveExports env mn imps exps refs = rethrow (addHint (ErrorInModule mn)) $ do filtered <- filterModule mn exps refs + let (dupeRefs, dupeDctors) = findDuplicateRefs refs + warnDupeRefs dupeRefs + warnDupeDctors dupeDctors foldM elaborateModuleExports filtered refs where + warnDupeRefs :: [DeclarationRef] -> m () + warnDupeRefs = traverse_ $ \case + TypeRef name _ -> warnDupe $ "type " ++ runProperName name + ValueRef name -> warnDupe $ "value " ++ runIdent name + TypeClassRef name -> warnDupe $ "class " ++ runProperName name + ModuleRef name -> warnDupe $ "module " ++ runModuleName name + _ -> return () + + warnDupeDctors :: [ProperName] -> m () + warnDupeDctors = traverse_ (warnDupe . ("data constructor " ++) . runProperName) + + warnDupe :: String -> m () + warnDupe ref = tell . errorMessage $ DuplicateExportRef ref + -- Takes the current module's imports, the accumulated list of exports, and a -- `DeclarationRef` for an explicit export. When the ref refers to another -- module, export anything from the imports that matches for that module. From f2c04c3643284cbf48abf612ded62a56940fc981 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 28 Nov 2015 18:08:04 +0000 Subject: [PATCH 0184/1580] Remove unhelpful isExplicitQualModule check --- src/Language/PureScript/Sugar/Names.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 6b5918e156..f92db94264 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -262,15 +262,12 @@ renameInModule env imports (Module ss coms mn decls exps) = -- by qualified importing). If that's not the case, then we just need to -- check it refers to a symbol in another module. (Nothing, Just mn'') -> do - when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname modExports <- getExports mn'' maybe (throwError . errorMessage $ unknown qname) return (getE modExports name) -- If neither of the above cases are true then it's an undefined or -- unimported symbol. _ -> throwError . errorMessage $ unknown qname where - isExplicitQualModule :: ModuleName -> Bool - isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imps) positioned err = case pos of Nothing -> err Just pos' -> rethrowWithPosition pos' err From 0d5ad255958b19b8ab82ce9b3d9904bceab7edfe Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 28 Nov 2015 18:32:54 +0000 Subject: [PATCH 0185/1580] Warn when import X hiding (..) imports nothing --- src/Language/PureScript/Errors.hs | 5 +++++ src/Language/PureScript/Sugar/Names/Imports.hs | 13 +++++++++++-- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 80288ce860..7f9235e9d3 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -147,6 +147,7 @@ data SimpleErrorMessage | DuplicateSelectiveImport ModuleName | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) | IntOutOfRange Integer String Integer Integer + | RedundantEmptyHidingImport ModuleName deriving (Show) -- | Error message hints, providing more detailed information about failure. @@ -286,6 +287,7 @@ errorCode em = case unwrapErrorMessage em of DuplicateSelectiveImport{} -> "DuplicateSelectiveImport" DuplicateImport{} -> "DuplicateImport" IntOutOfRange{} -> "IntOutOfRange" + RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport" -- | @@ -794,6 +796,9 @@ prettyPrintSingleError full level e = do paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend." , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ] + renderSimpleErrorMessage (RedundantEmptyHidingImport mn) = + line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden." + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index fba9ba3079..d1c04fd97d 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -56,7 +56,7 @@ findImports = foldM (go Nothing) M.empty go _ result (PositionedDeclaration pos _ d) = warnAndRethrowWithPosition pos $ go (Just pos) result d go _ result _ = return result - -- Ensure that classes don't appear in an `import X hiding (...)` + -- Ensure that modules don't appear in an `import X hiding (...)` checkImportRefType :: ImportDeclarationType -> m () checkImportRefType (Hiding refs) = traverse_ checkImportRef refs checkImportRefType _ = return () @@ -129,7 +129,16 @@ resolveImport currentModule importModule exps imps impQual = resolveByType :: ImportDeclarationType -> m Imports resolveByType Implicit = importAll importExplicit resolveByType (Explicit explImports) = checkRefs explImports >> foldM importExplicit imps explImports - resolveByType (Hiding hiddenImports) = checkRefs hiddenImports >> importAll (importNonHidden hiddenImports) + resolveByType (Hiding hiddenImports) = do + checkRefs hiddenImports + imps' <- importAll (importNonHidden hiddenImports) + let isEmptyImport + = M.null (importedTypes imps') + && M.null (importedDataConstructors imps') + && M.null (importedTypeClasses imps') + && M.null (importedValues imps') + when isEmptyImport $ tell . errorMessage $ RedundantEmptyHidingImport importModule + return imps' -- Check that a 'DeclarationRef' refers to an importable symbol checkRefs :: [DeclarationRef] -> m () From bbfbd3f24951e70d2dfff82a6fdc0781a52c9b44 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 29 Nov 2015 14:50:40 +0000 Subject: [PATCH 0186/1580] Show identifiers correctly in ctags --- psc-docs/Tags.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/psc-docs/Tags.hs b/psc-docs/Tags.hs index 461a7f6117..d370f05d63 100644 --- a/psc-docs/Tags.hs +++ b/psc-docs/Tags.hs @@ -10,9 +10,9 @@ tags = concatMap dtags . P.exportedDeclarations dtags _ = [] names (P.DataDeclaration _ name _ dcons) = P.runProperName name : consNames where consNames = map (\(cname, _) -> P.runProperName cname) dcons - names (P.TypeDeclaration ident _) = [show ident] - names (P.ExternDeclaration ident _) = [show ident] + names (P.TypeDeclaration ident _) = [P.showIdent ident] + names (P.ExternDeclaration ident _) = [P.showIdent ident] names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name] names (P.TypeClassDeclaration name _ _ _) = [P.runProperName name] - names (P.TypeInstanceDeclaration name _ _ _ _) = [show name] + names (P.TypeInstanceDeclaration name _ _ _ _) = [P.showIdent name] names _ = [] From 5aa3b6006308fd51dd9c2c6755b0755f41c0b2a0 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 30 Nov 2015 03:50:26 +0000 Subject: [PATCH 0187/1580] Introduce class keyword for refs, allow type refs without () --- psci/PSCi.hs | 19 +-- src/Language/PureScript/AST/Declarations.hs | 25 ++-- src/Language/PureScript/AST/Exported.hs | 3 + src/Language/PureScript/Errors.hs | 27 ++-- src/Language/PureScript/Linter/Imports.hs | 9 +- .../PureScript/Parser/Declarations.hs | 36 ++--- src/Language/PureScript/Sugar/Names.hs | 60 +++++---- src/Language/PureScript/Sugar/Names/Env.hs | 18 +-- .../PureScript/Sugar/Names/Imports.hs | 123 +++++++++++------- 9 files changed, 162 insertions(+), 158 deletions(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 75afe912ba..de5f54d0ba 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -1,23 +1,11 @@ ------------------------------------------------------------------------------ --- --- Module : PSCi --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- PureScript Compiler Interactive. --- ------------------------------------------------------------------------------ - {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +-- | +-- PureScript Compiler Interactive. +-- module PSCi where import Prelude () @@ -336,6 +324,7 @@ handleShowImportedModules = do showRef (P.TypeRef pn dctors) = show pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" showRef (P.ValueRef ident) = show ident showRef (P.TypeClassRef pn) = show pn + showRef (P.ProperRef pn) = show pn showRef (P.TypeInstanceRef ident) = show ident showRef (P.ModuleRef name) = "module " ++ show name showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index d9348f17a6..5702f3c10d 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -1,22 +1,11 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.AST.Declarations --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | Data types for modules and declarations --- ------------------------------------------------------------------------------ - {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE LambdaCase #-} +-- | +-- Data types for modules and declarations +-- module Language.PureScript.AST.Declarations where import Prelude () @@ -77,6 +66,10 @@ data DeclarationRef -- | ModuleRef ModuleName -- | + -- An unspecified ProperName ref. This will be replaced with a TypeClassRef + -- or TypeRef during name desugaring. + | ProperRef ProperName + -- | -- A declaration reference with source position information -- | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef @@ -87,12 +80,14 @@ instance Eq DeclarationRef where (ValueRef name) == (ValueRef name') = name == name' (TypeClassRef name) == (TypeClassRef name') = name == name' (TypeInstanceRef name) == (TypeInstanceRef name') = name == name' - (ModuleRef name) == (ModuleRef name') = name == name' + (ModuleRef name) == (ModuleRef name') = name == name' + (ProperRef name) == (ProperRef name') = name == name' (PositionedDeclarationRef _ _ r) == r' = r == r' r == (PositionedDeclarationRef _ _ r') = r == r' _ == _ = False isModuleRef :: DeclarationRef -> Bool +isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r isModuleRef (ModuleRef _) = True isModuleRef _ = False diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index a7ad53f5f8..b2fd1c9279 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -118,6 +118,9 @@ isExported (Just exps) decl = any (matches decl) exps matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident' matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident' + matches (DataDeclaration _ ident _ _) (ProperRef ident') = ident == ident' + matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = ident == ident' + matches (PositionedDeclaration _ _ d) r = d `matches` r matches d (PositionedDeclarationRef _ _ r) = d `matches` r matches _ _ = False diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 870e4eea80..3caec7e247 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1,17 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Error --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} @@ -143,6 +129,8 @@ data SimpleErrorMessage | UnusedDctorImport ProperName | UnusedDctorExplicitImport ProperName [ProperName] | DeprecatedQualifiedSyntax ModuleName ModuleName + | DeprecatedClassImport ModuleName ProperName + | DeprecatedClassExport ProperName | RedundantUnqualifiedImport ModuleName ImportDeclarationType | DuplicateSelectiveImport ModuleName | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) @@ -285,6 +273,8 @@ errorCode em = case unwrapErrorMessage em of UnusedDctorImport{} -> "UnusedDctorImport" UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport" DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax" + DeprecatedClassImport{} -> "DeprecatedClassImport" + DeprecatedClassExport{} -> "DeprecatedClassExport" RedundantUnqualifiedImport{} -> "RedundantUnqualifiedImport" DuplicateSelectiveImport{} -> "DuplicateSelectiveImport" DuplicateImport{} -> "DuplicateImport" @@ -787,6 +777,14 @@ prettyPrintSingleError full level e = do paras [ line $ "The import of type " ++ runModuleName name ++ " as " ++ runModuleName qualName ++ " uses the deprecated 'import qualified' syntax." , line $ "This syntax form will be removed in PureScript 0.9." ] + renderSimpleErrorMessage (DeprecatedClassImport mn name) = + paras [ line $ "The import of class " ++ runProperName name ++ " from " ++ runModuleName mn ++ " uses the deprecated syntax that omits the class keyword." + , line $ "This syntax form will be removed in PureScript 0.9." ] + + renderSimpleErrorMessage (DeprecatedClassExport name) = + paras [ line $ "The export of class " ++ runProperName name ++ " uses the deprecated syntax that omits the class keyword." + , line $ "This syntax form will be removed in PureScript 0.9." ] + renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) = line $ "Import of " ++ prettyPrintImport name imp Nothing ++ " is redundant due to a whole-module import" @@ -947,6 +945,7 @@ prettyPrintSingleError full level e = do prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")" prettyPrintRef (ValueRef ident) = showIdent ident prettyPrintRef (TypeClassRef pn) = runProperName pn + prettyPrintRef (ProperRef pn) = runProperName pn prettyPrintRef (TypeInstanceRef ident) = showIdent ident prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index d3fd87ee94..bdd606be22 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -11,7 +11,7 @@ import Data.Maybe (mapMaybe) import Data.List ((\\), find, intersect, nub) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class -import Control.Monad(unless,when) +import Control.Monad (unless,when) import Data.Foldable (forM_) import Language.PureScript.AST.Declarations @@ -78,10 +78,11 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do -- rely on exports being elaborated by this point alwaysUsedModules :: [ ModuleName ] - alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe isExport) mexports + alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe extractModule) mexports where - isExport (ModuleRef mn) = Just mn - isExport _ = Nothing + extractModule (PositionedDeclarationRef _ _ r) = extractModule r + extractModule (ModuleRef mn) = Just mn + extractModule _ = Nothing qnameUsed :: Maybe ModuleName -> Bool qnameUsed (Just qn) = qn `elem` alwaysUsedModules diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index dd5fdfab1a..3698f9c475 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -1,22 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Parser.Declarations --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- Parsers for module definitions and declarations --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +-- | +-- Parsers for module definitions and declarations +-- module Language.PureScript.Parser.Declarations ( parseDeclaration, parseModule, @@ -170,18 +158,16 @@ parseImportDeclaration' = do parseDeclarationRef :: TokenParser DeclarationRef parseDeclarationRef = - parseModuleRef <|> withSourceSpan PositionedDeclarationRef - (ValueRef <$> parseIdent - <|> do name <- properName - dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName) - return $ maybe (TypeClassRef name) (TypeRef name) dctors - ) + $ (ValueRef <$> parseIdent) + <|> parseProperRef + <|> (TypeClassRef <$> (reserved "class" *> properName)) + <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName)) where - parseModuleRef :: TokenParser DeclarationRef - parseModuleRef = do - name <- indented *> reserved "module" *> moduleName - return $ ModuleRef name + parseProperRef = do + name <- properName + dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName) + return $ maybe (ProperRef name) (TypeRef name) dctors parseTypeClassDeclaration :: TokenParser Declaration parseTypeClassDeclaration = do diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index f92db94264..824bf44f8a 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -1,16 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Sugar.Names --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -49,8 +36,9 @@ import Language.PureScript.Linter.Imports desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] desugarImports externs modules = do env <- silence $ foldM externsEnv primEnv externs - env' <- foldM updateEnv env modules - traverse (renameInModule' env') modules + modules' <- traverse updateExportRefs modules + (modules'', env') <- foldM updateEnv ([], env) modules' + traverse (renameInModule' env') modules'' where silence :: m a -> m a silence = censor (const mempty) @@ -90,16 +78,16 @@ desugarImports externs modules = do toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r toExportedValue _ = Nothing - updateEnv :: Env -> Module -> m Env - updateEnv env m@(Module ss _ mn _ refs) = + updateEnv :: ([Module], Env) -> Module -> m ([Module], Env) + updateEnv (ms, env) m@(Module ss _ mn _ refs) = case mn `M.lookup` env of Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss] Nothing -> do members <- findExportable m let env' = M.insert mn (ss, nullImports, members) env - imps <- resolveImports env' m + (m', imps) <- resolveImports env' m exps <- maybe (return members) (resolveExports env' mn imps members) refs - return $ M.insert mn (ss, imps, exps) env + return (m' : ms, M.insert mn (ss, imps, exps) env) renameInModule' :: Env -> Module -> m Module renameInModule' env m@(Module _ _ mn _ _) = @@ -262,7 +250,7 @@ renameInModule env imports (Module ss coms mn decls exps) = -- by qualified importing). If that's not the case, then we just need to -- check it refers to a symbol in another module. (Nothing, Just mn'') -> do - modExports <- getExports mn'' + modExports <- getExports env mn'' maybe (throwError . errorMessage $ unknown qname) return (getE modExports name) -- If neither of the above cases are true then it's an undefined or -- unimported symbol. @@ -272,6 +260,32 @@ renameInModule env imports (Module ss coms mn decls exps) = Nothing -> err Just pos' -> rethrowWithPosition pos' err - -- Gets the exports for a module, or an error message if the module doesn't exist - getExports :: ModuleName -> m Exports - getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') (return . envModuleExports) $ M.lookup mn' env +-- | +-- Replaces `ProperRef` export values with a `TypeRef` or `TypeClassRef` +-- depending on what is availble within the module. Warns when a `ProperRef` +-- desugars into a `TypeClassRef`. +-- +updateExportRefs :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> m Module +updateExportRefs (Module ss coms mn decls exps) = + Module ss coms mn decls <$> traverse (traverse updateRef) exps + where + + updateRef :: DeclarationRef -> m DeclarationRef + updateRef (ProperRef name) + | name `elem` classNames = do + tell . errorMessage $ DeprecatedClassExport name + return $ TypeClassRef name + -- Fall through case here - assume it's a type if it's not a class. + -- If it's a reference to something that doesn't actually exist it will + -- be picked up elsewhere + | otherwise = return $ TypeRef name (Just []) + updateRef (PositionedDeclarationRef pos com ref) = + warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref + updateRef other = return other + + classNames :: [ProperName] + classNames = mapMaybe go decls + where + go (PositionedDeclaration _ _ d) = go d + go (TypeClassDeclaration name _ _ _) = Just name + go _ = Nothing diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 62f8514249..d2e5ee5327 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -1,16 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Sugar.Names.Env --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleContexts #-} module Language.PureScript.Sugar.Names.Env @@ -26,6 +13,7 @@ module Language.PureScript.Sugar.Names.Env , exportType , exportTypeClass , exportValue + , getExports ) where import qualified Data.Map as M @@ -189,3 +177,7 @@ addExport what name mn exports = -- throwConflictError :: (MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> a -> m b throwConflictError conflict = throwError . errorMessage . conflict + +-- Gets the exports for a module, or an error message if the module doesn't exist +getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports +getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index da445169bd..ee86fc26b5 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -1,16 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Sugar.Names.Imports --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -47,34 +34,36 @@ import Language.PureScript.Sugar.Names.Env -- Finds the imports within a module, mapping the imported module name to an optional set of -- explicitly imported declarations. -- -findImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) +findImports + :: forall m + . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => [Declaration] + -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) findImports = foldM (go Nothing) M.empty where go pos result (ImportDeclaration mn typ qual isOldSyntax) = do when isOldSyntax . tell . errorMessage $ DeprecatedQualifiedSyntax mn (fromJust qual) - checkImportRefType typ let imp = (pos, typ, qual) return $ M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result go _ result (PositionedDeclaration pos _ d) = warnAndRethrowWithPosition pos $ go (Just pos) result d go _ result _ = return result - -- Ensure that modules don't appear in an `import X hiding (...)` - checkImportRefType :: ImportDeclarationType -> m () - checkImportRefType (Hiding refs) = traverse_ checkImportRef refs - checkImportRefType _ = return () - checkImportRef :: DeclarationRef -> m () - checkImportRef (ModuleRef name) = throwError . errorMessage $ ImportHidingModule name - checkImportRef _ = return () - type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -- | -- Constructs a set of imports for a module. -- -resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m Imports -resolveImports env (Module _ _ currentModule decls _) = +resolveImports + :: forall m + . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Env + -> Module + -> m (Module, Imports) +resolveImports env (Module ss coms currentModule decls exps) = warnAndRethrow (addHint (ErrorInModule currentModule)) $ do - imports <- findImports decls + + decls' <- traverse updateImportRef decls + imports <- findImports decls' for_ (M.toList imports) $ \(mn, imps) -> do @@ -110,7 +99,8 @@ resolveImports env (Module _ _ currentModule decls _) = return () let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports - foldM (resolveModuleImport currentModule env) nullImports (M.toList scope) + resolved <- foldM (resolveModuleImport currentModule env) nullImports (M.toList scope) + return (Module ss coms currentModule decls' exps, resolved) where selfCartesianSubset :: [a] -> [(a, a)] @@ -142,12 +132,38 @@ resolveImports env (Module _ _ currentModule decls _) = warn :: Maybe SourceSpan -> SimpleErrorMessage -> m () warn pos msg = maybe id warnWithPosition pos $ tell . errorMessage $ msg + updateImportRef :: Declaration -> m Declaration + updateImportRef (PositionedDeclaration pos com d) = + warnWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d + updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do + modExports <- getExports env mn + typ' <- case typ of + Implicit -> return Implicit + Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs + Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs + return $ ImportDeclaration mn typ' qual isOldSyntax + updateImportRef other = return other + + updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef + updateProperRef importModule modExports (ProperRef name) = + if name `elem` (fst `map` exportedTypeClasses modExports) + then do + tell . errorMessage $ DeprecatedClassImport importModule name + return $ TypeClassRef name + else return $ TypeRef name (Just []) + updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) = + PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref + updateProperRef _ _ other = return other + -- | Constructs a set of imports for a single module import. -resolveModuleImport :: - forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - ModuleName -> Env -> Imports -> - (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) -> - m Imports +resolveModuleImport + :: forall m + . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => ModuleName + -> Env + -> Imports + -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) + -> m Imports resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps where go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports @@ -163,17 +179,24 @@ resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps -- | -- Extends the local environment for a module by resolving an import of another module. -- -resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> ModuleName -> Exports -> Imports -> Maybe ModuleName -> ImportDeclarationType -> m Imports -resolveImport currentModule importModule exps imps impQual = - resolveByType +resolveImport + :: forall m + . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => ModuleName + -> ModuleName + -> Exports + -> Imports + -> Maybe ModuleName + -> ImportDeclarationType + -> m Imports +resolveImport currentModule importModule exps imps impQual = resolveByType where resolveByType :: ImportDeclarationType -> m Imports resolveByType Implicit = importAll importExplicit - resolveByType (Explicit explImports) = checkRefs explImports >> foldM importExplicit imps explImports - resolveByType (Hiding hiddenImports) = do - checkRefs hiddenImports - imps' <- importAll (importNonHidden hiddenImports) + resolveByType (Explicit refs) = checkRefs False refs >> foldM importExplicit imps refs + resolveByType (Hiding refs) = do + imps' <- checkRefs True refs >> importAll (importNonHidden refs) let isEmptyImport = M.null (importedTypes imps') && M.null (importedDataConstructors imps') @@ -183,8 +206,8 @@ resolveImport currentModule importModule exps imps impQual = return imps' -- Check that a 'DeclarationRef' refers to an importable symbol - checkRefs :: [DeclarationRef] -> m () - checkRefs = traverse_ check + checkRefs :: Bool -> [DeclarationRef] -> m () + checkRefs isHiding = traverse_ check where check (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ check r @@ -196,9 +219,9 @@ resolveImport currentModule importModule exps imps impQual = maybe (return ()) (traverse_ $ checkDctorExists name allDctors) dctors check (TypeClassRef name) = checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name - --check (ModuleRef name) = - -- checkImportExists (const UnknownModule) (exportedModules exps) name - check _ = internalError "Invalid argument to checkRefs" + check (ModuleRef name) | isHiding = + throwError . errorMessage $ ImportHidingModule name + check r = internalError $ "Invalid argument to checkRefs: " ++ show r -- Check that an explicitly imported item exists in the module it is being imported from checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m () @@ -264,11 +287,13 @@ resolveImport currentModule importModule exps imps impQual = Just ((_, dctors), mn) -> map (, mn) dctors -- Add something to the Imports if it does not already exist there - updateImports :: (Ord a) => M.Map (Qualified a) (Qualified a, ModuleName) - -> (a -> String) - -> [(a, ModuleName)] - -> a - -> m (M.Map (Qualified a) (Qualified a, ModuleName)) + updateImports + :: (Ord a) + => M.Map (Qualified a) (Qualified a, ModuleName) + -> (a -> String) + -> [(a, ModuleName)] + -> a + -> m (M.Map (Qualified a) (Qualified a, ModuleName)) updateImports imps' render exps' name = case M.lookup (Qualified impQual name) imps' of -- If the name is not already present add it to the list, after looking up From 0c86e7fc03c68750ac678cd4acce2a3fa6cc7ee4 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 30 Nov 2015 14:35:28 +0000 Subject: [PATCH 0188/1580] Add tests for new type & class ref syntax --- examples/passing/ClassRefSyntax.purs | 13 +++++++++++++ examples/passing/TypeWithoutParens.purs | 16 ++++++++++++++++ 2 files changed, 29 insertions(+) create mode 100644 examples/passing/ClassRefSyntax.purs create mode 100644 examples/passing/TypeWithoutParens.purs diff --git a/examples/passing/ClassRefSyntax.purs b/examples/passing/ClassRefSyntax.purs new file mode 100644 index 0000000000..b4a187d778 --- /dev/null +++ b/examples/passing/ClassRefSyntax.purs @@ -0,0 +1,13 @@ +module Lib (class X, go) where + + class X a where + go :: a -> a + +module Main where + + import Lib (class X, go) + + go' :: forall a. (X a) => a -> a + go' = go + + main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/TypeWithoutParens.purs b/examples/passing/TypeWithoutParens.purs new file mode 100644 index 0000000000..4aca41368f --- /dev/null +++ b/examples/passing/TypeWithoutParens.purs @@ -0,0 +1,16 @@ +module Lib (X, Y) where + + data X = X + type Y = X + +module Main where + + import Lib (X, Y) + + idX :: X -> X + idX x = x + + idY :: Y -> Y + idY y = y + + main = Control.Monad.Eff.Console.log "Done" From 0d88ee2d2d43ec86bffaaf04f634db0c18a9ad96 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 30 Nov 2015 18:48:28 +0000 Subject: [PATCH 0189/1580] Don't use show in PSCI showRef --- psci/PSCi.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index de5f54d0ba..a477d7ee88 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -321,12 +321,12 @@ handleShowImportedModules = do refsList refs = "(" ++ commaList (map showRef refs) ++ ")" showRef :: P.DeclarationRef -> String - showRef (P.TypeRef pn dctors) = show pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" - showRef (P.ValueRef ident) = show ident - showRef (P.TypeClassRef pn) = show pn - showRef (P.ProperRef pn) = show pn - showRef (P.TypeInstanceRef ident) = show ident - showRef (P.ModuleRef name) = "module " ++ show name + showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" + showRef (P.ValueRef ident) = N.runIdent ident + showRef (P.TypeClassRef pn) = N.runProperName pn + showRef (P.ProperRef pn) = N.runProperName pn + showRef (P.TypeInstanceRef ident) = N.runIdent ident + showRef (P.ModuleRef name) = "module " ++ N.runModuleName name showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref commaList :: [String] -> String From 5c65ab9325bb1cb590dfe4ec940e9d9eb2bfccac Mon Sep 17 00:00:00 2001 From: Michael Karg Date: Wed, 2 Dec 2015 00:06:24 +0100 Subject: [PATCH 0190/1580] added as a contributor --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index de711daf04..d72c50c688 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -28,6 +28,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@L8D](https://github.com/L8D) (Tenor Biel) My existing contributions and all future contributions until further notice are Copyright Tenor Biel, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@leighman](http://github.com/leighman) (Jack Leigh) My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@lukerandall](https://github.com/lukerandall) (Luke Randall) My existing contributions and all future contributions until further notice are Copyright Luke Randall, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@mgmeier](https://github.com/mgmeier) (Michael Karg) My existing contributions and all future contributions until further notice are Copyright Michael Gilliland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@michaelficarra](https://github.com/michaelficarra) (Michael Ficarra) My existing contributions and all future contributions until further notice are Copyright Michael Ficarra, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@MichaelXavier](https://github.com/MichaelXavier) (Michael Xavier) - My existing contributions and all future contributions until further notice are Copyright Michael Xavier, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@mjgpy3](https://github.com/mjgpy3) (Michael Gilliland) My existing contributions and all future contributions until further notice are Copyright Michael Gilliland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). From db2a0e3cd0a8e0efe97d06113aad8417e71173ac Mon Sep 17 00:00:00 2001 From: Pascal Hartig Date: Sat, 5 Dec 2015 14:21:05 +0000 Subject: [PATCH 0191/1580] Fix psc-publish test psc-publish wasn't updated to the signature changes in `preparePackage` which now expects PublishOptions as argument. --- psc-publish/tests/Test.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/psc-publish/tests/Test.hs b/psc-publish/tests/Test.hs index 9ebc7a7df1..814b1fdaca 100644 --- a/psc-publish/tests/Test.hs +++ b/psc-publish/tests/Test.hs @@ -19,9 +19,11 @@ import qualified Data.ByteString.Lazy as BL import Data.ByteString.Lazy (ByteString) import qualified Data.Aeson as A import Data.Aeson.BetterErrors +import Data.Version import Main import Language.PureScript.Docs +import Language.PureScript.Publish pkgName = "purescript-prelude" packageUrl = "https://github.com/purescript/" ++ pkgName @@ -50,11 +52,17 @@ bowerInstall = pushd packageDir $ readProcess "bower" ["install"] "" >>= putStr +testRunOptions :: PublishOptions +testRunOptions = defaultPublishOptions + { publishGetVersion = return testVersion + } + where testVersion = ("v999.0.0", Version [999,0,0] []) + getPackage :: IO UploadedPackage getPackage = do clonePackage bowerInstall - pushd packageDir preparePackage + pushd packageDir $ preparePackage testRunOptions data TestResult = ParseFailed String From 0e0c37b9cb65cb00b9d7d19653b68277dcce07ef Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 5 Dec 2015 21:47:33 +0000 Subject: [PATCH 0192/1580] Improve deprecated syntax warning messages --- src/Language/PureScript/Errors.hs | 24 ++++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 3caec7e247..f27ab0008a 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -774,16 +774,28 @@ prettyPrintSingleError full level e = do , indent $ paras $ map (line .runProperName) names ] renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) = - paras [ line $ "The import of type " ++ runModuleName name ++ " as " ++ runModuleName qualName ++ " uses the deprecated 'import qualified' syntax." - , line $ "This syntax form will be removed in PureScript 0.9." ] + paras [ line $ "Import uses the deprecated 'qualified' syntax:" + , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName + , line "Should instead use the form:" + , indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName + , line $ "The deprecated syntax will be removed in PureScript 0.9." + ] renderSimpleErrorMessage (DeprecatedClassImport mn name) = - paras [ line $ "The import of class " ++ runProperName name ++ " from " ++ runModuleName mn ++ " uses the deprecated syntax that omits the class keyword." - , line $ "This syntax form will be removed in PureScript 0.9." ] + paras [ line $ "Class import from " ++ runModuleName mn ++ " uses deprecated syntax that omits the 'class' keyword:" + , indent $ line $ runProperName name + , line "Should instead use the form:" + , indent $ line $ "class " ++ runProperName name + , line $ "The deprecated syntax will be removed in PureScript 0.9." + ] renderSimpleErrorMessage (DeprecatedClassExport name) = - paras [ line $ "The export of class " ++ runProperName name ++ " uses the deprecated syntax that omits the class keyword." - , line $ "This syntax form will be removed in PureScript 0.9." ] + paras [ line $ "Class export uses deprecated syntax that omits the 'class' keyword:" + , indent $ line $ runProperName name + , line "Should instead use the form:" + , indent $ line $ "class " ++ runProperName name + , line $ "The deprecated syntax will be removed in PureScript 0.9." + ] renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) = line $ "Import of " ++ prettyPrintImport name imp Nothing ++ " is redundant due to a whole-module import" From bb8aaa8198851c29341a15e7d7467b3313bc397b Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Wed, 2 Dec 2015 00:00:50 +0000 Subject: [PATCH 0193/1580] Warn on unspecified imports --- psci/Completion.hs | 2 +- psci/PSCi.hs | 7 +-- psci/tests/Main.hs | 4 +- src/Language/PureScript/AST/Declarations.hs | 22 +++++++++- .../PureScript/Docs/ParseAndDesugar.hs | 11 +---- src/Language/PureScript/Errors.hs | 13 +++++- src/Language/PureScript/Linter/Imports.hs | 44 +++++++++++++++++-- src/Language/PureScript/Make.hs | 12 ----- .../PureScript/Parser/Declarations.hs | 6 ++- .../PureScript/Sugar/Names/Imports.hs | 8 ++-- 10 files changed, 88 insertions(+), 41 deletions(-) diff --git a/psci/Completion.hs b/psci/Completion.hs index 8a52463911..5de762fa6f 100644 --- a/psci/Completion.hs +++ b/psci/Completion.hs @@ -171,7 +171,7 @@ getAllQualifications sho m (declName, decl) = do qualificationsUsing (_, importType, asQ') = let q = qualifyWith asQ' in case importType of - P.Implicit -> [q] + P.Implicit _ -> [q] P.Explicit refs -> [q | referencedBy refs] P.Hiding refs -> [q | not $ referencedBy refs] diff --git a/psci/PSCi.hs b/psci/PSCi.hs index a477d7ee88..5f2de5f1e6 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -315,10 +315,11 @@ handleShowImportedModules = do Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn' Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType - showDeclType P.Implicit = "" + showDeclType (P.Implicit True) = " (..)" + showDeclType (P.Implicit False) = "" showDeclType (P.Explicit refs) = refsList refs - showDeclType (P.Hiding refs) = "hiding " ++ refsList refs - refsList refs = "(" ++ commaList (map showRef refs) ++ ")" + showDeclType (P.Hiding refs) = " hiding " ++ refsList refs + refsList refs = " (" ++ commaList (map showRef refs) ++ ")" showRef :: P.DeclarationRef -> String showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" diff --git a/psci/tests/Main.hs b/psci/tests/Main.hs index d3d6d3b79c..0e244a3ec6 100644 --- a/psci/tests/Main.hs +++ b/psci/tests/Main.hs @@ -141,11 +141,11 @@ getPSCiState = do Left err -> print err >> exitFailure Right modules -> - let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)] + let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit True, Nothing)] in return (PSCiState [] imports modules foreigns [] []) controlMonadSTasST :: ImportedModule -controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST")) +controlMonadSTasST = (s "Control.Monad.ST", P.Implicit True, Just (s "ST")) where s = P.moduleNameFromString diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 5702f3c10d..2b770d059b 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -41,6 +41,18 @@ data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [Decla getModuleName :: Module -> ModuleName getModuleName (Module _ _ name _ _) = name +-- | +-- Add an import declaration for a module if it does not already explicitly import it. +-- +addDefaultImport :: ModuleName -> Module -> Module +addDefaultImport toImport m@(Module ss coms mn decls exps) = + if isExistingImport `any` decls || mn == toImport then m + else Module ss coms mn (ImportDeclaration toImport (Implicit True) Nothing False : decls) exps + where + isExistingImport (ImportDeclaration mn' _ _ _) | mn' == toImport = True + isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d + isExistingImport _ = False + -- | -- An item in a list of explicit imports or exports -- @@ -118,9 +130,11 @@ findDuplicateRefs refs = -- data ImportDeclarationType -- | - -- An import with no explicit list: `import M` + -- An import with no explicit list: `import M`. The boolean signifies whether + -- the import was imported with `(..)` or not. Without `(..)` a warning is + -- raised for each member implicitly imported. -- - = Implicit + = Implicit Bool -- | -- An import with an explicit list of references to import: `import M (foo)` -- @@ -131,6 +145,10 @@ data ImportDeclarationType | Hiding [DeclarationRef] deriving (Eq, Show, Read, D.Data, D.Typeable) +isImplicit :: ImportDeclarationType -> Bool +isImplicit (Implicit _) = True +isImplicit _ = False + -- | -- The data type of declarations -- diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndDesugar.hs index 2406db8850..cff4a67c97 100644 --- a/src/Language/PureScript/Docs/ParseAndDesugar.hs +++ b/src/Language/PureScript/Docs/ParseAndDesugar.hs @@ -105,17 +105,8 @@ fileInfoToString :: FileInfo -> FilePath fileInfoToString (Local fn) = fn fileInfoToString (FromDep _ fn) = fn -addDefaultImport :: P.ModuleName -> P.Module -> P.Module -addDefaultImport toImport m@(P.Module ss coms mn decls exps) = - if isExistingImport `any` decls || mn == toImport then m - else P.Module ss coms mn (P.ImportDeclaration toImport P.Implicit Nothing False : decls) exps - where - isExistingImport (P.ImportDeclaration mn' _ _ _) | mn' == toImport = True - isExistingImport (P.PositionedDeclaration _ _ d) = isExistingImport d - isExistingImport _ = False - importPrim :: P.Module -> P.Module -importPrim = addDefaultImport (P.ModuleName [P.ProperName C.prim]) +importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim]) desugar :: [P.Module] -> Either P.MultipleErrors [P.Module] desugar = P.evalSupplyT 0 . desugar' diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index f27ab0008a..a04e1820ff 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -138,6 +138,7 @@ data SimpleErrorMessage | DuplicateExportRef String | IntOutOfRange Integer String Integer Integer | RedundantEmptyHidingImport ModuleName + | ImplicitImport ModuleName [DeclarationRef] deriving (Show) -- | Error message hints, providing more detailed information about failure. @@ -282,6 +283,7 @@ errorCode em = case unwrapErrorMessage em of DuplicateExportRef{} -> "DuplicateExportRef" IntOutOfRange{} -> "IntOutOfRange" RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport" + ImplicitImport{} -> "ImplicitImport" -- | @@ -819,6 +821,11 @@ prettyPrintSingleError full level e = do renderSimpleErrorMessage (RedundantEmptyHidingImport mn) = line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden." + renderSimpleErrorMessage (ImplicitImport mn refs) = + paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: " + , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" + ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail @@ -954,9 +961,10 @@ prettyPrintSingleError full level e = do prettyPrintRef :: DeclarationRef -> String prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)" + prettyPrintRef (TypeRef pn (Just [])) = runProperName pn prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")" prettyPrintRef (ValueRef ident) = showIdent ident - prettyPrintRef (TypeClassRef pn) = runProperName pn + prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn prettyPrintRef (ProperRef pn) = runProperName pn prettyPrintRef (TypeInstanceRef ident) = showIdent ident prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name @@ -965,7 +973,8 @@ prettyPrintSingleError full level e = do prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String prettyPrintImport mn idt qual = let i = case idt of - Implicit -> runModuleName mn + Implicit True -> runModuleName mn ++ " (..)" + Implicit False -> runModuleName mn Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")" in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index bdd606be22..616a432f9d 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -16,6 +16,7 @@ import Data.Foldable (forM_) import Language.PureScript.AST.Declarations import Language.PureScript.AST.SourcePos +import Language.PureScript.Crash import Language.PureScript.Names as P import Language.PureScript.Errors @@ -30,6 +31,19 @@ data Name | TypeName (Qualified ProperName) | DctorName (Qualified ProperName) | ClassName (Qualified ProperName) + deriving (Eq) + +getIdentName :: Name -> Maybe Ident +getIdentName (IdentName (Qualified _ name)) = Just name +getIdentName _ = Nothing + +getTypeName :: Name -> Maybe ProperName +getTypeName (TypeName (Qualified _ name)) = Just name +getTypeName _ = Nothing + +getClassName :: Name -> Maybe ProperName +getClassName (ClassName (Qualified _ name)) = Just name +getClassName _ = Nothing -- | Map of module name to list of imported names from that module which have been used. type UsedImports = M.Map ModuleName [Name] @@ -44,11 +58,21 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $ forM_ decls $ \(ss, declType, qualifierName) -> censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $ - let names = sugarNames mni ++ M.findWithDefault [] mni usedImps + let names = nub $ sugarNames mni ++ M.findWithDefault [] mni usedImps usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names usedDctors = mapMaybe (matchDctor qualifierName) names in case declType of - Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni + Implicit _ | null usedNames -> tell $ errorMessage $ UnusedImport mni + Implicit False -> + let classRefs = TypeClassRef <$> mapMaybe getClassName names + valueRefs = ValueRef <$> mapMaybe getIdentName names + types = mapMaybe getTypeName names + typesWithDctors = reconstructTypeRefs mni usedDctors + typesWithoutDctors = filter (`M.notMember` typesWithDctors) types + typesRefs + = map (flip TypeRef (Just [])) typesWithoutDctors + ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors) + in tell $ errorMessage $ ImplicitImport mni (classRefs ++ typesRefs ++ valueRefs) Explicit declrefs -> do let idents = nub (mapMaybe runDeclRef declrefs) let diff = idents \\ usedNames @@ -76,6 +100,20 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ] sugarNames _ = [] + reconstructTypeRefs :: ModuleName -> [ProperName] -> M.Map ProperName [ProperName] + reconstructTypeRefs mni = foldr accumDctors M.empty + where + accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor) + + findTypeForDctor :: ModuleName -> ProperName -> ProperName + findTypeForDctor mn dctor = + case mn `M.lookup` env of + Just (_, _, exps) -> + case find (elem dctor . snd . fst) (exportedTypes exps) of + Just ((ty, _), _) -> ty + Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor" + Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor" + -- rely on exports being elaborated by this point alwaysUsedModules :: [ ModuleName ] alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe extractModule) mexports @@ -121,7 +159,7 @@ runDeclRef :: DeclarationRef -> Maybe String runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref runDeclRef (ValueRef ident) = Just $ showIdent ident runDeclRef (TypeRef pn _) = Just $ runProperName pn -runDeclRef (TypeClassRef pn) = Just $ runProperName pn +runDeclRef (TypeClassRef pn) = Just $ "class " ++ runProperName pn runDeclRef _ = Nothing getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName]) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 4e00625fb7..f4e7890960 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -266,18 +266,6 @@ make MakeActions{..} ms = do guard $ efVersion externs == showVersion Paths.version return externs --- | --- Add an import declaration for a module if it does not already explicitly import it. --- -addDefaultImport :: ModuleName -> Module -> Module -addDefaultImport toImport m@(Module ss coms mn decls exps) = - if isExistingImport `any` decls || mn == toImport then m - else Module ss coms mn (ImportDeclaration toImport Implicit Nothing False : decls) exps - where - isExistingImport (ImportDeclaration mn' _ _ _) | mn' == toImport = True - isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d - isExistingImport _ = False - importPrim :: Module -> Module importPrim = addDefaultImport (ModuleName [ProperName C.prim]) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 3698f9c475..8b17c3d127 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -152,8 +152,10 @@ parseImportDeclaration' = do qName <- qualifiedName return (moduleName', declType, Just qName, True) qualifyingList expectedType = do - idents <- P.optionMaybe $ indented *> parens (commaSep parseDeclarationRef) - return $ fromMaybe Implicit (expectedType <$> idents) + declType <- P.optionMaybe + $ P.try (expectedType <$> (indented *> parens (commaSep parseDeclarationRef))) + <|> (const (Implicit True) <$> (indented *> parens (symbol' ".."))) + return $ fromMaybe (Implicit False) declType parseDeclarationRef :: TokenParser DeclarationRef diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index ee86fc26b5..50d1bdd76a 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -79,7 +79,7 @@ resolveImports env (Module ss coms currentModule decls exps) = warned' <- (warned ++) <$> if (length unqual < 2) then return [] - else case find (\(_, typ, _) -> typ == Implicit) unqual of + else case find (\(_, typ, _) -> isImplicit typ) unqual of Just i -> for (delete i unqual) $ \i'@(pos, typ, _) -> do warn pos $ RedundantUnqualifiedImport mn typ @@ -98,7 +98,7 @@ resolveImports env (Module ss coms currentModule decls exps) = return () - let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports + let scope = M.insert currentModule [(Nothing, Implicit True, Nothing)] imports resolved <- foldM (resolveModuleImport currentModule env) nullImports (M.toList scope) return (Module ss coms currentModule decls' exps, resolved) @@ -138,7 +138,7 @@ resolveImports env (Module ss coms currentModule decls exps) = updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do modExports <- getExports env mn typ' <- case typ of - Implicit -> return Implicit + Implicit b -> return $ Implicit b Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs return $ ImportDeclaration mn typ' qual isOldSyntax @@ -193,7 +193,7 @@ resolveImport currentModule importModule exps imps impQual = resolveByType where resolveByType :: ImportDeclarationType -> m Imports - resolveByType Implicit = importAll importExplicit + resolveByType (Implicit _) = importAll importExplicit resolveByType (Explicit refs) = checkRefs False refs >> foldM importExplicit imps refs resolveByType (Hiding refs) = do imps' <- checkRefs True refs >> importAll (importNonHidden refs) From e20d2998664ee232909d7efd57daf88e2af8c0cc Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Wed, 2 Dec 2015 17:24:44 +0000 Subject: [PATCH 0194/1580] Delay errors about scope conflicts until they are unavoidable --- examples/failing/ConflictingExports.purs | 16 ++++++ examples/failing/ConflictingExports2.purs | 13 +++++ examples/failing/ConflictingImports.purs | 19 +++++++ examples/failing/ConflictingImports2.purs | 16 ++++++ examples/passing/NonConflictingExports.purs | 14 +++++ .../passing/PendingConflictingImports.purs | 17 ++++++ .../passing/PendingConflictingImports2.purs | 14 +++++ src/Language/PureScript/Errors.hs | 15 ++---- src/Language/PureScript/Sugar/Names.hs | 45 +++++++++------- src/Language/PureScript/Sugar/Names/Env.hs | 50 +++++++++++++---- .../PureScript/Sugar/Names/Exports.hs | 42 +++++++-------- .../PureScript/Sugar/Names/Imports.hs | 53 ++++++------------- 12 files changed, 216 insertions(+), 98 deletions(-) create mode 100644 examples/failing/ConflictingExports.purs create mode 100644 examples/failing/ConflictingExports2.purs create mode 100644 examples/failing/ConflictingImports.purs create mode 100644 examples/failing/ConflictingImports2.purs create mode 100644 examples/passing/NonConflictingExports.purs create mode 100644 examples/passing/PendingConflictingImports.purs create mode 100644 examples/passing/PendingConflictingImports2.purs diff --git a/examples/failing/ConflictingExports.purs b/examples/failing/ConflictingExports.purs new file mode 100644 index 0000000000..1aef23b3bd --- /dev/null +++ b/examples/failing/ConflictingExports.purs @@ -0,0 +1,16 @@ +-- @shouldFailWith ScopeConflict +module A where + + thing :: Int + thing = 1 + +module B where + + thing :: Int + thing = 2 + +-- Fails here because re-exporting forces any scope conflicts to be resolved +module Main (module A, module B) where + + import A + import B diff --git a/examples/failing/ConflictingExports2.purs b/examples/failing/ConflictingExports2.purs new file mode 100644 index 0000000000..352548c2a9 --- /dev/null +++ b/examples/failing/ConflictingExports2.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith ScopeConflict +module A where + + thing :: Int + thing = 1 + +-- Fails here because re-exporting forces any scope conflicts to be resolved +module Main (thing, module A) where + + import A + + thing :: Int + thing = 2 diff --git a/examples/failing/ConflictingImports.purs b/examples/failing/ConflictingImports.purs new file mode 100644 index 0000000000..64eb1cc1da --- /dev/null +++ b/examples/failing/ConflictingImports.purs @@ -0,0 +1,19 @@ +-- @shouldFailWith ScopeConflict +module A where + + thing :: Int + thing = 1 + +module B where + + thing :: Int + thing = 2 + +module Main where + + import A + import B + + -- Error due to referencing `thing` which is in scope as A.thing and B.thing + what :: Int + what = thing diff --git a/examples/failing/ConflictingImports2.purs b/examples/failing/ConflictingImports2.purs new file mode 100644 index 0000000000..ef56fdd1a5 --- /dev/null +++ b/examples/failing/ConflictingImports2.purs @@ -0,0 +1,16 @@ +-- @shouldFailWith ScopeConflict +module A where + + thing :: Int + thing = 1 + +module Main where + + import A + + thing :: Int + thing = 2 + + -- Error due to referencing `thing` which is in scope as A.thing and Main.thing + what :: Int + what = thing diff --git a/examples/passing/NonConflictingExports.purs b/examples/passing/NonConflictingExports.purs new file mode 100644 index 0000000000..9dff502541 --- /dev/null +++ b/examples/passing/NonConflictingExports.purs @@ -0,0 +1,14 @@ +module A where + + thing :: Int + thing = 1 + +-- No failure here as the export `thing` only refers to Main.thing +module Main (thing, main) where + + import A + + thing :: Int + thing = 2 + + main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/PendingConflictingImports.purs b/examples/passing/PendingConflictingImports.purs new file mode 100644 index 0000000000..942ed42342 --- /dev/null +++ b/examples/passing/PendingConflictingImports.purs @@ -0,0 +1,17 @@ +module A where + + thing :: Int + thing = 1 + +module B where + + thing :: Int + thing = 2 + +module Main where + + -- No error as we never force `thing` to be resolved in `Main` + import A + import B + + main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/PendingConflictingImports2.purs b/examples/passing/PendingConflictingImports2.purs new file mode 100644 index 0000000000..f578dde132 --- /dev/null +++ b/examples/passing/PendingConflictingImports2.purs @@ -0,0 +1,14 @@ +module A where + + thing :: Int + thing = 1 + +module Main where + + import A + + -- No error as we never force `thing` to be resolved in `Main` + thing :: Int + thing = 2 + + main = Control.Monad.Eff.Console.log "Done" diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index a04e1820ff..7f5651b511 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -67,8 +67,7 @@ data SimpleErrorMessage | UnknownExportModule ModuleName | UnknownImportDataConstructor ModuleName ProperName ProperName | UnknownExportDataConstructor ProperName ProperName - | ConflictingImport String ModuleName - | ConflictingImports String ModuleName ModuleName + | ScopeConflict String [ModuleName] | ConflictingTypeDecls ProperName | ConflictingCtorDecls ProperName | TypeConflictsWithClass ProperName @@ -212,8 +211,7 @@ errorCode em = case unwrapErrorMessage em of UnknownExportModule{} -> "UnknownExportModule" UnknownImportDataConstructor{} -> "UnknownImportDataConstructor" UnknownExportDataConstructor{} -> "UnknownExportDataConstructor" - ConflictingImport{} -> "ConflictingImport" - ConflictingImports{} -> "ConflictingImports" + ScopeConflict{} -> "ScopeConflict" ConflictingTypeDecls{} -> "ConflictingTypeDecls" ConflictingCtorDecls{} -> "ConflictingCtorDecls" TypeConflictsWithClass{} -> "TypeConflictsWithClass" @@ -524,13 +522,10 @@ prettyPrintSingleError full level e = do line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) = line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared." - renderSimpleErrorMessage (ConflictingImport nm mn) = - paras [ line $ "Cannot declare " ++ show nm ++ ", since another declaration of that name was imported from module " ++ runModuleName mn - , line $ "Consider hiding " ++ show nm ++ " when importing " ++ runModuleName mn ++ ":" - , indent . line $ "import " ++ runModuleName mn ++ " hiding (" ++ nm ++ ")" + renderSimpleErrorMessage (ScopeConflict nm ms) = + paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:" + , indent $ paras $ map (line . runModuleName) ms ] - renderSimpleErrorMessage (ConflictingImports nm m1 m2) = - line $ "Conflicting imports for " ++ nm ++ " from modules " ++ runModuleName m1 ++ " and " ++ runModuleName m2 renderSimpleErrorMessage (ConflictingTypeDecls nm) = line $ "Conflicting type declarations for " ++ runProperName nm renderSimpleErrorMessage (ConflictingCtorDecls nm) = diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 824bf44f8a..b6a77fe012 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -50,7 +50,7 @@ desugarImports externs modules = do ss = internalModuleSourceSpan "" env' = M.insert efModuleName (ss, nullImports, members) env fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, mt, qmn)]) - imps <- foldM (resolveModuleImport efModuleName env') nullImports (map fromEFImport efImports) + imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports) exps <- resolveExports env' efModuleName imps members efExports return $ M.insert efModuleName (ss, imps, exps) env where @@ -197,16 +197,16 @@ renameInModule env imports (Module ss coms mn decls exps) = updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts) updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) - updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TypeName + updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TypeName (("type " ++) . runProperName) updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) - updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName + updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName) updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) - updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) ClassName + updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) ClassName (("class " ++) . runProperName) updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident) - updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName + updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent) -- Used when performing an update to qualify values and classes with their -- module of original definition. @@ -226,25 +226,30 @@ renameInModule env imports (Module ss coms mn decls exps) = -- Update names so unqualified references become qualified, and locally -- qualified references are replaced with their canoncial qualified names -- (e.g. M.Map -> Data.Map.Map). - update :: (Ord a) => (Qualified a -> SimpleErrorMessage) - -> M.Map (Qualified a) (Qualified a, ModuleName) - -> (Exports -> a -> Maybe (Qualified a)) - -> (Qualified a -> Name) - -> Qualified a - -> Maybe SourceSpan - -> m (Qualified a) - update unknown imps getE toName qname@(Qualified mn' name) pos = positioned $ + update + :: (Ord a, Show a) + => (Qualified a -> SimpleErrorMessage) + -> M.Map (Qualified a) [(Qualified a, ModuleName)] + -> (Exports -> a -> Maybe (Qualified a)) + -> (Qualified a -> Name) + -> (a -> String) + -> Qualified a + -> Maybe SourceSpan + -> m (Qualified a) + update unknown imps getE toName render qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imps, mn') of + -- We found the name in our imports, so we return the name for it, -- qualifying with the name of the module it was originally defined in -- rather than the module we're importing from, to handle the case of - -- re-exports. - (Just (qn, mnOrig), _) -> do - case qn of - Qualified (Just mnNew) _ -> - modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result - _ -> return () + -- re-exports. If there are multiple options for the name to resolve to + -- in scope, we throw an error. + (Just options, _) -> do + checkImportConflicts render options + let (Qualified (Just mnNew) _, mnOrig) = head options + modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result return $ Qualified (Just mnOrig) name + -- If the name wasn't found in our imports but was qualified then we need -- to check whether it's a failed import from a "pseudo" module (created -- by qualified importing). If that's not the case, then we just need to @@ -252,9 +257,11 @@ renameInModule env imports (Module ss coms mn decls exps) = (Nothing, Just mn'') -> do modExports <- getExports env mn'' maybe (throwError . errorMessage $ unknown qname) return (getE modExports name) + -- If neither of the above cases are true then it's an undefined or -- unimported symbol. _ -> throwError . errorMessage $ unknown qname + where positioned err = case pos of Nothing -> err diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index d2e5ee5327..0b0728750c 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Sugar.Names.Env ( Imports(..) @@ -14,14 +15,18 @@ module Language.PureScript.Sugar.Names.Env , exportTypeClass , exportValue , getExports + , checkImportConflicts ) where +import Data.Function (on) +import Data.List (groupBy, sortBy, nub) import qualified Data.Map as M import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Names import Language.PureScript.Environment import Language.PureScript.Errors @@ -34,19 +39,19 @@ data Imports = Imports -- | -- Local names for types within a module mapped to to their qualified names -- - importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName) + importedTypes :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)] -- | -- Local names for data constructors within a module mapped to to their qualified names -- - , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName) + , importedDataConstructors :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)] -- | -- Local names for classes within a module mapped to to their qualified names -- - , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName, ModuleName) + , importedTypeClasses :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)] -- | -- Local names for values within a module mapped to to their qualified names -- - , importedValues :: M.Map (Qualified Ident) (Qualified Ident, ModuleName) + , importedValues :: M.Map (Qualified Ident) [(Qualified Ident, ModuleName)] -- | -- The list of modules that have been imported into the current scope. -- @@ -132,15 +137,17 @@ primEnv = M.singleton -- exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports exportType exps name dctors mn = do - let exTypes = exportedTypes exps + let exTypes' = exportedTypes exps + let exTypes = filter ((/= mn) . snd) exTypes' let exDctors = (snd . fst) `concatMap` exTypes let exClasses = exportedTypeClasses exps - when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ConflictingTypeDecls name + + when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name forM_ dctors $ \dctor -> do when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor - return $ exps { exportedTypes = ((name, dctors), mn) : exTypes } + return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' } -- | -- Safely adds a class to some exports, returning an error if a conflict occurs. @@ -149,7 +156,7 @@ exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName -> Mod exportTypeClass exps name mn = do let exTypes = exportedTypes exps let exDctors = (snd . fst) `concatMap` exTypes - when (any (\((name', _), _) -> name == name') exTypes) $ throwConflictError ClassConflictsWithType name + when (any ((== name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps) return $ exps { exportedTypeClasses = classes } @@ -168,9 +175,9 @@ exportValue exps name mn = do -- addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)] addExport what name mn exports = - if any ((== name) . fst) exports + if any (\(name', mn') -> name == name' && mn /= mn') exports then throwConflictError what name - else return $ (name, mn) : exports + else return $ nub $ (name, mn) : exports -- | -- Raises an error for when there is more than one definition for something. @@ -181,3 +188,26 @@ throwConflictError conflict = throwError . errorMessage . conflict -- Gets the exports for a module, or an error message if the module doesn't exist getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env + +-- | +-- When reading a value from the imports, check that there are no conflicts in +-- scope. +-- +checkImportConflicts + :: forall m a + . (MonadError MultipleErrors m, Ord a) + => (a -> String) + -> [(Qualified a, ModuleName)] + -> m () +checkImportConflicts render xs = + let byOrig = groupBy ((==) `on` snd) . sortBy (compare `on` snd) $ xs + in + if length byOrig > 1 + then throwError . errorMessage $ ScopeConflict (render' (fst . head $ xs)) (map (getQual . fst . head) byOrig) + else return () + where + getQual :: Qualified a -> ModuleName + getQual (Qualified (Just mn) _) = mn + getQual _ = internalError "unexpected unqualified name in checkImportConflicts" + render' :: Qualified a -> String + render' (Qualified _ a) = render a diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 3c02f635ac..3ec1903ccc 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -1,16 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Sugar.Names.Exports --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -110,20 +97,31 @@ resolveExports env mn imps exps refs = let isPseudo = isPseudoModule name when (not isPseudo && not (isImportedModule name)) $ throwError . errorMessage . UnknownExportModule $ name - let reTypes = extract isPseudo name (importedTypes imps) - let reDctors = extract isPseudo name (importedDataConstructors imps) - let reClasses = extract isPseudo name (importedTypeClasses imps) - let reValues = extract isPseudo name (importedValues imps) + reTypes <- extract isPseudo name (("type " ++) . runProperName) (importedTypes imps) + reDctors <- extract isPseudo name (("data constructor " ++) . runProperName) (importedDataConstructors imps) + reClasses <- extract isPseudo name (("class " ++) . runProperName) (importedTypeClasses imps) + reValues <- extract isPseudo name (("value " ++) . runIdent) (importedValues imps) result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors) result'' <- foldM (uncurry . exportTypeClass) result' (map resolveClass reClasses) foldM (uncurry . exportValue) result'' (map resolveValue reValues) elaborateModuleExports result _ = return result -- Extracts a list of values for a module based on a lookup table. If the - -- boolean is true the values are filtered by the qualification of the - extract :: Bool -> ModuleName -> M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a] - extract True name = map fst . M.elems . M.filterWithKey (\k _ -> eqQual name k) - extract False name = map fst . M.elems . M.filter (eqQual name . fst) + -- boolean is true the values are filtered by the qualification + extract + :: (Ord a) + => Bool + -> ModuleName + -> (a -> String) + -> M.Map (Qualified a) [(Qualified a, ModuleName)] + -> m [Qualified a] + extract useQual name render = fmap (map (fst . head . snd)) . go useQual . M.toList + where + go True = filterM (return . eqQual name . fst) + go False = filterM $ \(_, options) -> do + let isMatch = any (eqQual name . fst) options + when (length options > 1) $ checkImportConflicts render options + return isMatch -- Check whether a module name refers to a "pseudo module" that came into -- existence in an import scope due to importing one or more modules as @@ -135,7 +133,7 @@ resolveExports env mn imps exps refs = -- function to either extract the keys or values. We test the keys to see if a -- value being re-exported belongs to a qualified module, and we test the -- values if that fails to see whether the value has been imported at all. - testQuals :: (forall a. M.Map (Qualified a) (Qualified a, ModuleName) -> [Qualified a]) -> ModuleName -> Bool + testQuals :: (forall a b. M.Map (Qualified a) b -> [Qualified a]) -> ModuleName -> Bool testQuals f mn' = any (eqQual mn') (f (importedTypes imps)) || any (eqQual mn') (f (importedDataConstructors imps)) || any (eqQual mn') (f (importedTypeClasses imps)) diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 50d1bdd76a..18f84f3272 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -99,7 +99,7 @@ resolveImports env (Module ss coms currentModule decls exps) = return () let scope = M.insert currentModule [(Nothing, Implicit True, Nothing)] imports - resolved <- foldM (resolveModuleImport currentModule env) nullImports (M.toList scope) + resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope) return (Module ss coms currentModule decls' exps, resolved) where @@ -159,18 +159,17 @@ resolveImports env (Module ss coms currentModule decls exps) = resolveModuleImport :: forall m . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => ModuleName - -> Env + => Env -> Imports -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) -> m Imports -resolveModuleImport currentModule env ie (mn, imps) = foldM go ie imps +resolveModuleImport env ie (mn, imps) = foldM go ie imps where go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports go ie' (pos, typ, impQual) = do modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env let ie'' = ie' { importedModules = mn : importedModules ie' } - positioned $ resolveImport currentModule mn modExports ie'' impQual typ + positioned $ resolveImport mn modExports ie'' impQual typ where positioned err = case pos of Nothing -> err @@ -183,13 +182,12 @@ resolveImport :: forall m . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName - -> ModuleName -> Exports -> Imports -> Maybe ModuleName -> ImportDeclarationType -> m Imports -resolveImport currentModule importModule exps imps impQual = resolveByType +resolveImport importModule exps imps impQual = resolveByType where resolveByType :: ImportDeclarationType -> m Imports @@ -262,20 +260,20 @@ resolveImport currentModule importModule exps imps impQual = resolveByType importExplicit imp (PositionedDeclarationRef pos _ r) = warnAndRethrowWithPosition pos $ importExplicit imp r importExplicit imp (ValueRef name) = do - values' <- updateImports (importedValues imp) showIdent (exportedValues exps) name + let values' = updateImports (importedValues imp) (exportedValues exps) name return $ imp { importedValues = values' } importExplicit imp (TypeRef name dctors) = do - types' <- updateImports (importedTypes imp) runProperName (first fst `map` exportedTypes exps) name + let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name let exportedDctors :: [(ProperName, ModuleName)] exportedDctors = allExportedDataConstructors name dctorNames :: [ProperName] dctorNames = fst `map` exportedDctors maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name - dctors' <- foldM (\m -> updateImports m runProperName exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors) + let dctors' = foldl (\m -> updateImports m exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors) return $ imp { importedTypes = types', importedDataConstructors = dctors' } importExplicit imp (TypeClassRef name) = do - typeClasses' <- updateImports (importedTypeClasses imp) runProperName (exportedTypeClasses exps) name + let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name return $ imp { importedTypeClasses = typeClasses' } importExplicit _ _ = internalError "Invalid argument to importExplicit" @@ -286,33 +284,14 @@ resolveImport currentModule importModule exps imps impQual = resolveByType Nothing -> internalError "Invalid state in allExportedDataConstructors" Just ((_, dctors), mn) -> map (, mn) dctors - -- Add something to the Imports if it does not already exist there + -- Add something to an import resolution list updateImports :: (Ord a) - => M.Map (Qualified a) (Qualified a, ModuleName) - -> (a -> String) + => M.Map (Qualified a) [(Qualified a, ModuleName)] -> [(a, ModuleName)] -> a - -> m (M.Map (Qualified a) (Qualified a, ModuleName)) - updateImports imps' render exps' name = case M.lookup (Qualified impQual name) imps' of - - -- If the name is not already present add it to the list, after looking up - -- where it was originally defined - Nothing -> - let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') - in return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name, mnOrig) imps' - - -- If the name already is present check whether it's a duplicate import - -- before rejecting it. For example, if module A defines X, and module B - -- re-exports A, importing A and B in C should not result in a "conflicting - -- import for `x`" error - Just (Qualified (Just mn) _, mnOrig) - | mnOrig == fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') -> return imps' - | otherwise -> throwError . errorMessage $ err - where - err = if currentModule `elem` [mn, importModule] - then ConflictingImport (render name) importModule - else ConflictingImports (render name) mn importModule - - Just (Qualified Nothing _, _) -> - internalError "Invalid state in updateImports" + -> M.Map (Qualified a) [(Qualified a, ModuleName)] + updateImports imps' exps' name = + let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') + currNames = fromMaybe [] (M.lookup (Qualified impQual name) imps') + in M.insert (Qualified impQual name) ((Qualified (Just importModule) name, mnOrig) : currNames) imps' From 6492c771a856c17182bbf869a110a54295db44de Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 5 Dec 2015 23:32:03 +0000 Subject: [PATCH 0195/1580] Error when re-exporting a pseudo module with conflicts --- .../failing/ConflictingQualifiedImports.purs | 17 +++++++++++++++++ .../failing/ConflictingQualifiedImports2.purs | 15 +++++++++++++++ src/Language/PureScript/Sugar/Names/Exports.hs | 9 ++++----- 3 files changed, 36 insertions(+), 5 deletions(-) create mode 100644 examples/failing/ConflictingQualifiedImports.purs create mode 100644 examples/failing/ConflictingQualifiedImports2.purs diff --git a/examples/failing/ConflictingQualifiedImports.purs b/examples/failing/ConflictingQualifiedImports.purs new file mode 100644 index 0000000000..a85aa60b46 --- /dev/null +++ b/examples/failing/ConflictingQualifiedImports.purs @@ -0,0 +1,17 @@ +-- @shouldFailWith ScopeConflict +module A where + + thing :: Int + thing = 1 + +module B where + + thing :: Int + thing = 2 + +module Main where + + import A as X + import B as X + + foo = X.thing diff --git a/examples/failing/ConflictingQualifiedImports2.purs b/examples/failing/ConflictingQualifiedImports2.purs new file mode 100644 index 0000000000..fd5efa546b --- /dev/null +++ b/examples/failing/ConflictingQualifiedImports2.purs @@ -0,0 +1,15 @@ +-- @shouldFailWith ScopeConflict +module A where + + thing :: Int + thing = 1 + +module B where + + thing :: Int + thing = 2 + +module Main (module X) where + + import A as X + import B as X diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 3ec1903ccc..bd3389ad96 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -115,12 +115,11 @@ resolveExports env mn imps exps refs = -> (a -> String) -> M.Map (Qualified a) [(Qualified a, ModuleName)] -> m [Qualified a] - extract useQual name render = fmap (map (fst . head . snd)) . go useQual . M.toList + extract useQual name render = fmap (map (fst . head . snd)) . go . M.toList where - go True = filterM (return . eqQual name . fst) - go False = filterM $ \(_, options) -> do - let isMatch = any (eqQual name . fst) options - when (length options > 1) $ checkImportConflicts render options + go = filterM $ \(name', options) -> do + let isMatch = if useQual then eqQual name name' else any (eqQual name . fst) options + when (isMatch && length options > 1) $ checkImportConflicts render options return isMatch -- Check whether a module name refers to a "pseudo module" that came into From b7b396f0ba9d0363187e8364fb00eea68f276ac6 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 12 Dec 2015 00:37:26 +0000 Subject: [PATCH 0196/1580] Drop paren requirement for constraints --- examples/passing/UntupledConstraints.purs | 17 ++++++++++ .../PureScript/Parser/Declarations.hs | 13 +++++--- src/Language/PureScript/Parser/Types.hs | 32 ++++++------------- 3 files changed, 36 insertions(+), 26 deletions(-) create mode 100644 examples/passing/UntupledConstraints.purs diff --git a/examples/passing/UntupledConstraints.purs b/examples/passing/UntupledConstraints.purs new file mode 100644 index 0000000000..55cff87654 --- /dev/null +++ b/examples/passing/UntupledConstraints.purs @@ -0,0 +1,17 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console + +class Show a <= Nonsense a where + method :: a -> a + +data Box a = Box a + +instance showBox :: Show a => Show (Box a) where + show (Box a) = "Box " <> show a + +strangeThing :: forall m. Semigroup (m Unit) => m Unit -> m Unit -> m Unit +strangeThing x y = x <> y + +main = log "Done" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 8b17c3d127..4ae39b8507 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -33,6 +33,7 @@ import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Kinds import Language.PureScript.Names +import Language.PureScript.Types import Language.PureScript.Parser.Common import Language.PureScript.Parser.Kinds import Language.PureScript.Parser.Lexer @@ -174,9 +175,9 @@ parseDeclarationRef = parseTypeClassDeclaration :: TokenParser Declaration parseTypeClassDeclaration = do reserved "class" - implies <- P.option [] $ do + implies <- P.option [] $ P.try $ do indented - implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom))) + implies <- P.try (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint) lfatArrow return implies className <- indented *> properName @@ -185,13 +186,17 @@ parseTypeClassDeclaration = do indented *> reserved "where" indented *> mark (P.many (same *> positioned parseTypeDeclaration)) return $ TypeClassDeclaration className idents implies members + where + +parseConstraint :: TokenParser Constraint +parseConstraint = (,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom) parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) parseInstanceDeclaration = do reserved "instance" name <- parseIdent <* indented <* doubleColon - deps <- P.optionMaybe $ do - deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom))) + deps <- P.optionMaybe $ P.try $ do + deps <- P.try (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint) indented rfatArrow return deps diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 7cd1602e06..5e3f3bb0c2 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -1,18 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Parser.Types --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- Parsers for types --- ------------------------------------------------------------------------------ - module Language.PureScript.Parser.Types ( parseType, parsePolyType, @@ -70,7 +55,8 @@ parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> id -- parseTypeAtom :: TokenParser Type parseTypeAtom = indented *> P.choice (map P.try - [ parseArray + [ parseConstrainedType + , parseArray , parseArrayOf , parseFunction , parseObject @@ -79,21 +65,23 @@ parseTypeAtom = indented *> P.choice (map P.try , parseTypeConstructor , parseForAll , parens parseRow - , parseConstrainedType , parens parsePolyType ]) parseConstrainedType :: TokenParser Type parseConstrainedType = do - constraints <- parens . commaSep1 $ do - className <- parseQualified properName - indented - ty <- P.many parseTypeAtom - return (className, ty) + constraints <- P.try (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint) _ <- rfatArrow indented ty <- parseType return $ ConstrainedType constraints ty + where + parseConstraint = do + className <- parseQualified properName + indented + ty <- P.many parseTypeAtom + return (className, ty) + parseAnyType :: TokenParser Type parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P. "type" From 8d3b8b3c231fe8507e6abce029aa4b7316628a71 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 6 Dec 2015 17:42:38 +0000 Subject: [PATCH 0197/1580] Introduce operator aliases --- examples/failing/OperatorAliasNoExport.purs | 7 +++ examples/passing/OperatorAlias.purs | 11 ++++ purescript.cabal | 2 +- src/Language/PureScript/AST/Declarations.hs | 4 +- src/Language/PureScript/AST/Exported.hs | 2 +- src/Language/PureScript/CoreFn/Desugar.hs | 17 +----- src/Language/PureScript/Docs/AsMarkdown.hs | 8 ++- src/Language/PureScript/Docs/Convert.hs | 17 +++--- src/Language/PureScript/Docs/Types.hs | 11 ++-- src/Language/PureScript/Errors.hs | 14 ++++- src/Language/PureScript/Externs.hs | 22 ++----- src/Language/PureScript/Linter.hs | 22 ++----- .../PureScript/Parser/Declarations.hs | 3 +- .../PureScript/Sugar/Names/Exports.hs | 1 + src/Language/PureScript/Sugar/Operators.hs | 58 ++++++++++--------- src/Language/PureScript/TypeChecker.hs | 48 ++++++++------- 16 files changed, 133 insertions(+), 114 deletions(-) create mode 100644 examples/failing/OperatorAliasNoExport.purs create mode 100644 examples/passing/OperatorAlias.purs diff --git a/examples/failing/OperatorAliasNoExport.purs b/examples/failing/OperatorAliasNoExport.purs new file mode 100644 index 0000000000..5a089ba0a0 --- /dev/null +++ b/examples/failing/OperatorAliasNoExport.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith TransitiveExportError +module Test ((?!)) where + +infixl 4 what as ?! + +what :: forall a b. a -> b -> a +what a _ = a diff --git a/examples/passing/OperatorAlias.purs b/examples/passing/OperatorAlias.purs new file mode 100644 index 0000000000..d3615deb47 --- /dev/null +++ b/examples/passing/OperatorAlias.purs @@ -0,0 +1,11 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console + +infixl 4 what as ?! + +what :: forall a b. a -> b -> a +what a _ = a + +main = log $ "Done" ?! true diff --git a/purescript.cabal b/purescript.cabal index 65b733af05..82afa8ba84 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.7.6.1 +version: 0.8.0.0 cabal-version: >=1.8 build-type: Simple license: MIT diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 2b770d059b..82a32832f6 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -186,9 +186,9 @@ data Declaration -- | ExternDataDeclaration ProperName Kind -- | - -- A fixity declaration (fixity data, operator name) + -- A fixity declaration (fixity data, operator name, value the operator is an alias for) -- - | FixityDeclaration Fixity String + | FixityDeclaration Fixity String (Maybe Ident) -- | -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name) -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9) diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index b2fd1c9279..872d5cefdf 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -112,7 +112,7 @@ isExported (Just exps) decl = any (matches decl) exps matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident' matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident' matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident' - matches (FixityDeclaration _ name) (ValueRef ident') = name == runIdent ident' + matches (FixityDeclaration _ name _) (ValueRef ident') = name == runIdent ident' matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident' matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident' matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident' diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 23e9c172ca..e6ce2a8736 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,17 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CoreFn.Desugar --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | The AST -> CoreFn desugaring step --- ------------------------------------------------------------------------------ - module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where import Data.Function (on) @@ -68,6 +54,9 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) = [NonRec name (exprToCoreFn ss com Nothing e)] + declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) = + let qname = Qualified (Just mn) alias + in [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta qname) (Qualified Nothing alias))] declToCoreFn ss _ (A.BindingGroupDeclaration ds) = [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds] declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) = diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 5476489d90..94959a6665 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -45,7 +45,7 @@ declAsMarkdown decl@Declaration{..} = do zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children spacer - for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer) + for_ declFixity (\(fixity, alias) -> fixityAsMarkdown fixity alias >> spacer) for_ declComments tell' @@ -68,9 +68,11 @@ codeToString = outputWith elemAsMarkdown elemAsMarkdown (Keyword x) = x elemAsMarkdown Space = " " -fixityAsMarkdown :: P.Fixity -> Docs -fixityAsMarkdown (P.Fixity associativity precedence) = +fixityAsMarkdown :: P.Fixity -> Maybe String -> Docs +fixityAsMarkdown (P.Fixity associativity precedence) alias = + -- TODO: link alias name to member tell' $ concat [ "_" + , maybe "" (\i -> "alias for " ++ i ++ " - ") alias , associativityStr , " / precedence " , show precedence diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index b34829119b..5fb7d2f602 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -11,6 +11,9 @@ module Language.PureScript.Docs.Convert , collectBookmarks ) where +import Prelude () +import Prelude.Compat + import Control.Monad import Control.Category ((>>>)) import Data.Either @@ -68,7 +71,7 @@ type IntermediateDeclaration -- with their associativity and precedence. data DeclarationAugment = AugmentChild ChildDeclaration - | AugmentFixity P.Fixity + | AugmentFixity P.Fixity (Maybe P.Ident) -- | Augment top-level declarations; the second pass. See the comments under -- the type synonym IntermediateDeclaration for more information. @@ -86,8 +89,8 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) = case a of AugmentChild child -> d { declChildren = declChildren d ++ [child] } - AugmentFixity fixity -> - d { declFixity = Just fixity } + AugmentFixity fixity alias -> + d { declFixity = Just (fixity, P.runIdent <$> alias) } -- | Add the default operator fixity for operators which do not have associated -- fixity declarations. @@ -97,7 +100,7 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) = addDefaultFixity :: Declaration -> Declaration addDefaultFixity decl@Declaration{..} | isOp declTitle && isNothing declFixity = - decl { declFixity = Just defaultFixity } + decl { declFixity = Just (defaultFixity, Nothing) } | otherwise = decl where @@ -113,7 +116,7 @@ getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProper getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name) -getDeclarationTitle (P.FixityDeclaration _ name) = Just ("(" ++ name ++ ")") +getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")") getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d getDeclarationTitle _ = Nothing @@ -170,8 +173,8 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) classApp = foldl P.TypeApp (P.TypeConstructor className) tys -convertDeclaration (P.FixityDeclaration fixity _) title = - Just (Left ([title], AugmentFixity fixity)) +convertDeclaration (P.FixityDeclaration fixity _ alias) title = + Just (Left ([title], AugmentFixity fixity alias)) convertDeclaration (P.PositionedDeclaration srcSpan com d') title = fmap (addComments . addSourceSpan) (convertDeclaration d' title) where diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 15ec473c20..1d81b42845 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -84,7 +84,7 @@ data Declaration = Declaration , declComments :: Maybe String , declSourceSpan :: Maybe P.SourceSpan , declChildren :: [ChildDeclaration] - , declFixity :: Maybe P.Fixity + , declFixity :: Maybe (P.Fixity, Maybe String) , declInfo :: DeclarationInfo } deriving (Show, Eq, Ord) @@ -307,9 +307,12 @@ asDeclaration = <*> key "fixity" (perhaps asFixity) <*> key "info" asDeclarationInfo -asFixity :: Parse PackageError P.Fixity -asFixity = P.Fixity <$> key "associativity" asAssociativity - <*> key "precedence" asIntegral +asFixity :: Parse PackageError (P.Fixity, Maybe String) +asFixity = do + fixity <- P.Fixity <$> key "associativity" asAssociativity + <*> key "precedence" asIntegral + alias <- keyMay "alias" asString + return (fixity, alias) parseAssociativity :: String -> Maybe P.Associativity parseAssociativity str = case str of diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 7f5651b511..cb5f102748 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -127,6 +127,7 @@ data SimpleErrorMessage | UnusedExplicitImport ModuleName [String] | UnusedDctorImport ProperName | UnusedDctorExplicitImport ProperName [ProperName] + | DeprecatedOperatorDecl String | DeprecatedQualifiedSyntax ModuleName ModuleName | DeprecatedClassImport ModuleName ProperName | DeprecatedClassExport ProperName @@ -271,6 +272,7 @@ errorCode em = case unwrapErrorMessage em of UnusedExplicitImport{} -> "UnusedExplicitImport" UnusedDctorImport{} -> "UnusedDctorImport" UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport" + DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl" DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax" DeprecatedClassImport{} -> "DeprecatedClassImport" DeprecatedClassExport{} -> "DeprecatedClassExport" @@ -712,8 +714,9 @@ prettyPrintSingleError full level e = do , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form." ] renderSimpleErrorMessage (TransitiveExportError x ys) = - paras $ line ("An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ") - : map (line . prettyPrintExport) ys + paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: " + , indent $ paras $ map (line . prettyPrintExport) ys + ] renderSimpleErrorMessage (ShadowedName nm) = line $ "Name '" ++ showIdent nm ++ "' was shadowed." renderSimpleErrorMessage (ShadowedTypeVar tv) = @@ -770,6 +773,13 @@ prettyPrintSingleError full level e = do paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:" , indent $ paras $ map (line .runProperName) names ] + renderSimpleErrorMessage (DeprecatedOperatorDecl name) = + paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function." + , line "Operator aliases are declared by using a fixity declaration, for example:" + , indent $ line $ "infixl 9 someFunction as " ++ name + , line $ "Support for value-declared operators will be removed in PureScript 0.9." + ] + renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) = paras [ line $ "Import uses the deprecated 'qualified' syntax:" , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 9273ff818f..16006f13db 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -1,22 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Externs --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations. --- ------------------------------------------------------------------------------ - {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} +-- | +-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations. +-- module Language.PureScript.Externs ( ExternsFile(..) , ExternsImport(..) @@ -84,6 +72,8 @@ data ExternsFixity = ExternsFixity , efPrecedence :: Precedence -- | The operator symbol , efOperator :: String + -- | The value the operator is an alias for + , efAlias :: Maybe Ident } deriving (Show, Read) -- | A type or value declaration appearing in an externs file @@ -163,7 +153,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} efDeclarations = concatMap toExternsDeclaration efExports fixityDecl :: Declaration -> Maybe ExternsFixity - fixityDecl (FixityDeclaration (Fixity assoc prec) op) = fmap (const (ExternsFixity assoc prec op)) (find exportsOp exps) + fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) = fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps) where exportsOp :: DeclarationRef -> Bool exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 1ed552da49..8ab464910d 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -1,21 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Linter --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | This module implements a simple linting pass on the PureScript AST. --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternGuards #-} +-- | +-- This module implements a simple linting pass on the PureScript AST. +-- module Language.PureScript.Linter (lint, module L) where import Prelude () @@ -66,11 +55,12 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec stepD :: S.Set Ident -> Declaration -> MultipleErrors - stepD _ (TypeClassDeclaration name _ _ decls) = foldMap go decls + stepD _ (ValueDeclaration (Op name) _ _ _) = errorMessage (DeprecatedOperatorDecl name) + stepD _ (TypeClassDeclaration _ _ _ decls) = foldMap go decls where go :: Declaration -> MultipleErrors go (PositionedDeclaration _ _ d') = go d' - go (TypeDeclaration op@(Op _) _) = errorMessage (ClassOperator name op) + go (TypeDeclaration (Op name) _) = errorMessage (DeprecatedOperatorDecl name) go _ = mempty stepD _ _ = mempty diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 8b17c3d127..259a69429e 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -124,8 +124,9 @@ parseFixityDeclaration :: TokenParser Declaration parseFixityDeclaration = do fixity <- parseFixity indented + alias <- P.optionMaybe $ (Ident <$> identifier) <* reserved "as" name <- symbol - return $ FixityDeclaration fixity name + return $ FixityDeclaration fixity name alias parseImportDeclaration :: TokenParser Declaration parseImportDeclaration = do diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index bd3389ad96..194566d0ff 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -47,6 +47,7 @@ findExportable (Module _ _ mn ds _) = updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn + updateExports exps (FixityDeclaration _ name (Just _)) = exportValue exps (Op name) mn updateExports exps (ExternDeclaration name _) = exportValue exps name mn updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d updateExports exps _ = return exps diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 5934b9fe39..fe9d33502a 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -1,13 +1,8 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Sugar.Operators --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + -- | -- This module implements the desugaring pass which reapplies binary operators based -- on their fixity data and removes explicit parentheses. @@ -15,13 +10,6 @@ -- The value parser ignores fixity data when parsing binary operator applications, so -- it is necessary to reorder them here. -- ------------------------------------------------------------------------------ - -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} - module Language.PureScript.Sugar.Operators ( rebracket, removeSignedLiterals, @@ -44,6 +32,8 @@ import Control.Monad.Supply.Class import Data.Function (on) import Data.Functor.Identity import Data.List (groupBy, sortBy) +import Data.Maybe (mapMaybe, fromMaybe) +import qualified Data.Map as M import qualified Text.Parsec as P import qualified Text.Parsec.Pos as P @@ -57,9 +47,24 @@ import qualified Language.PureScript.Constants as C rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] rebracket externs ms = do let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms - ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities - let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities - traverse (rebracketModule opTable) ms + ensureNoDuplicates $ map (\(i, pos, _, _) -> (i, pos)) fixities + let opTable = customOperatorTable $ map (\(i, _, f, _) -> (i, f)) fixities + ms' <- traverse (rebracketModule opTable) ms + let aliased = M.fromList (mapMaybe makeLookupEntry fixities) + return $ renameAliasedOperators aliased `map` ms' + + where + + makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe Ident) -> Maybe (Qualified Ident, Qualified Ident) + makeLookupEntry (qname@(Qualified qual _), _, _, Just alias) = Just (qname, Qualified qual alias) + makeLookupEntry _ = Nothing + + renameAliasedOperators :: M.Map (Qualified Ident) (Qualified Ident) -> Module -> Module + renameAliasedOperators aliased (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts + where + (f', _, _) = everywhereOnValues id go id + go (Var name) = Var $ fromMaybe name (name `M.lookup` aliased) + go other = other removeSignedLiterals :: Module -> Module removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts @@ -82,17 +87,18 @@ removeParens = go (Parens val) = val go val = val -externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity)] +externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)] externsFixities ExternsFile{..} = - [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec) - | ExternsFixity assoc prec op <- efFixities + [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias) + | ExternsFixity assoc prec op alias <- efFixities ] -collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)] +collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)] collectFixities (Module _ _ moduleName ds _) = concatMap collect ds where - collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)] - collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)] + collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)] + collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) = + [(Qualified (Just moduleName) (Op name), pos, fixity, alias)] collect FixityDeclaration{} = internalError "Fixity without srcpos info" collect _ = [] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 70a89c8c90..400c935da3 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -1,22 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- The top-level type checker, which checks all declarations in a module. --- ------------------------------------------------------------------------------ - {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +-- | +-- The top-level type checker, which checks all declarations in a module. +-- module Language.PureScript.TypeChecker ( module T, typeCheckModule @@ -196,7 +184,7 @@ typeCheckAll :: forall m. [DeclarationRef] -> [Declaration] -> m [Declaration] -typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities ds +typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds where go :: Declaration -> m Declaration go (DataDeclaration dtype name args dctors) = do @@ -290,13 +278,16 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities d go (PositionedDeclaration pos com d) = warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d - checkOrphanFixities :: Declaration -> m () - checkOrphanFixities (FixityDeclaration _ name) = do + checkFixities :: Declaration -> m () + checkFixities (FixityDeclaration _ name (Just alias)) = do + ty <- lookupVariable moduleName (Qualified (Just moduleName) alias) + addValue moduleName (Op name) ty Public + checkFixities (FixityDeclaration _ name _) = do env <- getEnv guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env - checkOrphanFixities (PositionedDeclaration pos _ d) = - warnAndRethrowWithPosition pos $ checkOrphanFixities d - checkOrphanFixities _ = return () + checkFixities (PositionedDeclaration pos _ d) = + warnAndRethrowWithPosition pos $ checkFixities d + checkFixities _ = return () checkInstanceMembers :: [Declaration] -> m [Declaration] checkInstanceMembers instDecls = do @@ -355,6 +346,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint checkTypesAreExported e checkClassMembersAreExported e checkClassesAreExported e + checkNonAliasesAreExported e return $ Module ss coms mn decls' (Just exps) where @@ -429,3 +421,17 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint extractMemberName (TypeDeclaration memberName _) = memberName extractMemberName _ = internalError "Unexpected declaration in typeclass member list" checkClassMembersAreExported _ = return () + + checkNonAliasesAreExported :: DeclarationRef -> m () + checkNonAliasesAreExported dr@(ValueRef (Op name)) = + case listToMaybe (mapMaybe getAlias decls) of + Just alias -> + when (not $ any (== ValueRef alias) exps) $ + throwError . errorMessage $ TransitiveExportError dr [ValueRef alias] + _ -> return () + where + getAlias :: Declaration -> Maybe Ident + getAlias (PositionedDeclaration _ _ d) = getAlias d + getAlias (FixityDeclaration _ name' alias) | name == name' = alias + getAlias _ = Nothing + checkNonAliasesAreExported _ = return () From f14015ee5cf76762feeb679d863a486cdf2706ed Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 12 Dec 2015 21:05:21 +0000 Subject: [PATCH 0198/1580] Fix incorrect unused class warning --- src/Language/PureScript/Linter/Imports.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 616a432f9d..1fc0b1fd99 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -159,7 +159,7 @@ runDeclRef :: DeclarationRef -> Maybe String runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref runDeclRef (ValueRef ident) = Just $ showIdent ident runDeclRef (TypeRef pn _) = Just $ runProperName pn -runDeclRef (TypeClassRef pn) = Just $ "class " ++ runProperName pn +runDeclRef (TypeClassRef pn) = Just $ runProperName pn runDeclRef _ = Nothing getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName]) From 11b2662979ee65d64758e95a0925c6b483800061 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 24 Nov 2015 19:17:49 -0800 Subject: [PATCH 0199/1580] Fix #1523, add --json-errors flag. --- psc/JSON.hs | 69 +++++++++++++++++++++++++++++++ psc/Main.hs | 58 ++++++++++++++++---------- purescript.cabal | 7 +++- src/Language/PureScript/Errors.hs | 30 +++++++++++++- 4 files changed, 139 insertions(+), 25 deletions(-) create mode 100644 psc/JSON.hs diff --git a/psc/JSON.hs b/psc/JSON.hs new file mode 100644 index 0000000000..09a364f144 --- /dev/null +++ b/psc/JSON.hs @@ -0,0 +1,69 @@ +----------------------------------------------------------------------------- +-- +-- Module : Main +-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE TemplateHaskell #-} + +module JSON where + +import Prelude () +import Prelude.Compat + +import qualified Data.Aeson.TH as A + +import qualified Language.PureScript as P + +data ErrorPosition = ErrorPosition + { startLine :: Int + , startColumn :: Int + , endLine :: Int + , endColumn :: Int + } + +data JSONError = JSONError + { position :: Maybe ErrorPosition + , message :: String + , errorCode :: String + , filename :: Maybe String + , moduleName :: Maybe String + } + +data JSONResult = JSONResult + { warnings :: [JSONError] + , errors :: [JSONError] + } + +$(A.deriveJSON A.defaultOptions ''ErrorPosition) +$(A.deriveJSON A.defaultOptions ''JSONError) +$(A.deriveJSON A.defaultOptions ''JSONResult) + +toJSONErrors :: Bool -> P.Level -> P.MultipleErrors -> [JSONError] +toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErrors + +toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError +toJSONError verbose level e = + JSONError (toErrorPosition <$> sspan) + (P.renderBox (P.prettyPrintSingleError' verbose level (P.stripModuleAndSpan e))) + (P.errorCode e) + (P.spanName <$> sspan) + (P.runModuleName <$> P.errorModule e) + where + sspan :: Maybe P.SourceSpan + sspan = P.errorSpan e + + toErrorPosition :: P.SourceSpan -> ErrorPosition + toErrorPosition ss = + ErrorPosition (P.sourcePosLine (P.spanStart ss)) + (P.sourcePosColumn (P.spanStart ss)) + (P.sourcePosLine (P.spanEnd ss)) + (P.sourcePosColumn (P.spanEnd ss)) diff --git a/psc/Main.hs b/psc/Main.hs index 1914cf5935..2a8d4a9a88 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -27,6 +27,9 @@ import Control.Monad.Writer.Strict import Data.List (isSuffixOf, partition) import Data.Version (showVersion) import qualified Data.Map as M +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.UTF8 as BU8 import Options.Applicative as Opts @@ -40,45 +43,54 @@ import qualified Paths_purescript as Paths import Language.PureScript.Make +import JSON + data PSCMakeOptions = PSCMakeOptions { pscmInput :: [FilePath] , pscmForeignInput :: [FilePath] , pscmOutputDir :: FilePath , pscmOpts :: P.Options , pscmUsePrefix :: Bool + , pscmJSONErrors :: Bool } data InputOptions = InputOptions { ioInputFiles :: [FilePath] } +-- | Argumnets: verbose, use JSON, warnings, errors +printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO () +printWarningsAndErrors verbose False warnings errors = do + when (P.nonEmpty warnings) $ + hPutStrLn stderr (P.prettyPrintMultipleWarnings verbose warnings) + case errors of + Left errs -> do + hPutStrLn stderr (P.prettyPrintMultipleErrors verbose errs) + exitFailure + Right _ -> return () +printWarningsAndErrors verbose True warnings errors = do + hPutStrLn stderr . BU8.toString . B.toStrict . A.encode $ + JSONResult (toJSONErrors verbose P.Warning warnings) + (either (toJSONErrors verbose P.Error) (const []) errors) + either (const exitFailure) (const (return ())) errors + compile :: PSCMakeOptions -> IO () -compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = do - input <- globWarningOnMisses warnFileTypeNotFound inputGlob +compile PSCMakeOptions{..} = do + input <- globWarningOnMisses warnFileTypeNotFound pscmInput when (null input) $ do hPutStrLn stderr "psc: No input files." exitFailure let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input moduleFiles <- readInput (InputOptions pursFiles) - inputForeign <- globWarningOnMisses warnFileTypeNotFound inputForeignGlob + inputForeign <- globWarningOnMisses warnFileTypeNotFound pscmForeignInput foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile) - case runWriterT (parseInputs moduleFiles foreignFiles) of - Left errs -> do - hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs) - exitFailure - Right ((ms, foreigns), warnings) -> do - when (P.nonEmpty warnings) $ - hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings) - let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms - makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix - (e, warnings') <- runMake opts $ P.make makeActions (map snd ms) - when (P.nonEmpty warnings') $ - hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings') - case e of - Left errs -> do - hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs) - exitFailure - Right _ -> exitSuccess + (makeErrors, makeWarnings) <- runMake pscmOpts $ do + (ms, foreigns) <- parseInputs moduleFiles foreignFiles + let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms + makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix + P.make makeActions (map snd ms) + printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors + exitSuccess warnFileTypeNotFound :: String -> IO () warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++) @@ -161,6 +173,10 @@ noPrefix = switch $ <> long "no-prefix" <> help "Do not include comment header" +jsonErrors :: Parser Bool +jsonErrors = switch $ + long "json-errors" + <> help "Print errors to stderr as JSON" options :: Parser P.Options options = P.Options <$> noTco @@ -177,7 +193,7 @@ pscMakeOptions = PSCMakeOptions <$> many inputFile <*> outputDirectory <*> options <*> (not <$> noPrefix) - + <*> jsonErrors main :: IO () main = execParser opts >>= compile diff --git a/purescript.cabal b/purescript.cabal index 65b733af05..462234723d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -185,12 +185,15 @@ library ghc-options: -Wall -O2 executable psc - build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, + build-depends: base >=4 && <5, base-compat >=0.6.0, + containers -any, directory -any, filepath -any, mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any, - time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8 + time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8, + aeson >= 0.8 && < 0.11, bytestring -any, utf8-string >= 1 && < 2 main-is: Main.hs buildable: True hs-source-dirs: psc + other-modules: JSON ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N" executable psci diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 80288ce860..7da67987b2 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -184,6 +184,31 @@ data HintCategory data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show) +-- | Get the source span for an error +errorSpan :: ErrorMessage -> Maybe SourceSpan +errorSpan = findHint matchSpan + where + matchSpan (PositionedError ss) = Just ss + matchSpan _ = Nothing + +-- | Get the module name for an error +errorModule :: ErrorMessage -> Maybe ModuleName +errorModule = findHint matchModule + where + matchModule (ErrorInModule mn) = Just mn + matchModule _ = Nothing + +findHint :: (ErrorMessageHint -> Maybe a) -> ErrorMessage -> Maybe a +findHint f (ErrorMessage hints _) = getLast . foldMap (Last . f) $ hints + +-- | Remove the module name and span hints from an error +stripModuleAndSpan :: ErrorMessage -> ErrorMessage +stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldStrip) hints) e + where + shouldStrip (ErrorInModule _) = True + shouldStrip (PositionedError _) = True + shouldStrip _ = False + -- | -- Get the error code for a particular error type -- @@ -287,7 +312,6 @@ errorCode em = case unwrapErrorMessage em of DuplicateImport{} -> "DuplicateImport" IntOutOfRange{} -> "IntOutOfRange" - -- | -- A stack trace for an error -- @@ -304,7 +328,6 @@ nonEmpty = not . null . runMultipleErrors errorMessage :: SimpleErrorMessage -> MultipleErrors errorMessage err = MultipleErrors [ErrorMessage [] err] - -- | -- Create an error set from a single error message -- @@ -389,6 +412,9 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts gHint other = pure other +prettyPrintSingleError' :: Bool -> Level -> ErrorMessage ->Box.Box +prettyPrintSingleError' full level = flip evalState defaultUnknownMap . prettyPrintSingleError full level + -- | -- Pretty print a single error, simplifying if necessary -- From ab7e5f6bf641cc193075f46cef2ec49b0259f5ee Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 12 Dec 2015 23:30:42 +0100 Subject: [PATCH 0200/1580] Test psc-publish as part of the main test suite --- .gitmodules | 3 + purescript.cabal | 4 +- tests/Main.hs | 10 +++ .../tests/Test.hs => tests/TestPscPublish.hs | 66 +++++++------------ tests/support/prelude | 1 + 5 files changed, 39 insertions(+), 45 deletions(-) create mode 100644 .gitmodules rename psc-publish/tests/Test.hs => tests/TestPscPublish.hs (57%) create mode 160000 tests/support/prelude diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000000..9c44d52cc7 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "tests/support/prelude"] + path = tests/support/prelude + url = https://github.com/purescript/purescript-prelude diff --git a/purescript.cabal b/purescript.cabal index 82afa8ba84..75dac8962b 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -261,10 +261,12 @@ test-suite tests build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, mtl -any, parsec -any, purescript -any, transformers -any, process -any, transformers-compat -any, time -any, - Glob -any, base-compat >=0.6.0 + Glob -any, aeson-better-errors -any, bytestring -any, aeson -any, + base-compat -any type: exitcode-stdio-1.0 main-is: Main.hs other-modules: TestsSetup + TestPscPublish buildable: True hs-source-dirs: tests tests/common diff --git a/tests/Main.hs b/tests/Main.hs index 1b5c834dae..b892d38cfb 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -68,6 +68,7 @@ import qualified System.FilePath.Glob as Glob import Text.Parsec (ParseError) import TestsSetup +import TestPscPublish modulesDir :: FilePath modulesDir = ".test_modules" "node_modules" @@ -171,6 +172,11 @@ assertDoesNotCompile inputFiles foreigns = do main :: IO () main = do + testCompiler + testPscPublish + +testCompiler :: IO () +testCompiler = do fetchSupportCode cwd <- getCurrentDirectory @@ -203,6 +209,10 @@ main = do in putStrLn $ fp' ++ ": " ++ err exitFailure +testPscPublish :: IO () +testPscPublish = do + testPackage "tests/support/prelude" + supportModules :: [String] supportModules = [ "Control.Monad.Eff.Class" diff --git a/psc-publish/tests/Test.hs b/tests/TestPscPublish.hs similarity index 57% rename from psc-publish/tests/Test.hs rename to tests/TestPscPublish.hs index 814b1fdaca..43f53637be 100644 --- a/psc-publish/tests/Test.hs +++ b/tests/TestPscPublish.hs @@ -2,33 +2,24 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# LANGUAGE ScopedTypeVariables #-} --- | To run these tests: --- --- * `cabal repl psc-publish` --- * `:l psc-publish/tests/Test.hs` --- * `test` - -module Test where +module TestPscPublish where import Control.Monad import Control.Applicative import Control.Exception import System.Process import System.Directory +import System.IO +import System.Exit import qualified Data.ByteString.Lazy as BL import Data.ByteString.Lazy (ByteString) import qualified Data.Aeson as A import Data.Aeson.BetterErrors import Data.Version -import Main import Language.PureScript.Docs import Language.PureScript.Publish -pkgName = "purescript-prelude" -packageUrl = "https://github.com/purescript/" ++ pkgName -packageDir = "tmp/" ++ pkgName - pushd :: forall a. FilePath -> IO a -> IO a pushd dir act = do original <- getCurrentDirectory @@ -37,44 +28,12 @@ pushd dir act = do setCurrentDirectory original either throwIO return result -clonePackage :: IO () -clonePackage = do - createDirectoryIfMissing True packageDir - pushd packageDir $ do - exists <- doesDirectoryExist ".git" - unless exists $ do - putStrLn ("Cloning " ++ pkgName ++ " into " ++ packageDir ++ "...") - readProcess "git" ["clone", packageUrl, "."] "" >>= putStr - readProcess "git" ["tag", "v999.0.0"] "" >>= putStr - -bowerInstall :: IO () -bowerInstall = - pushd packageDir $ - readProcess "bower" ["install"] "" >>= putStr - -testRunOptions :: PublishOptions -testRunOptions = defaultPublishOptions - { publishGetVersion = return testVersion - } - where testVersion = ("v999.0.0", Version [999,0,0] []) - -getPackage :: IO UploadedPackage -getPackage = do - clonePackage - bowerInstall - pushd packageDir $ preparePackage testRunOptions - data TestResult = ParseFailed String | Mismatch ByteString ByteString -- ^ encoding before, encoding after | Pass ByteString deriving (Show, Read) --- | Test JSON encoding/decoding; parse the package, roundtrip to/from JSON, --- and check we get the same string. -test :: IO TestResult -test = roundTrip <$> getPackage - roundTrip :: UploadedPackage -> TestResult roundTrip pkg = let before = A.encode pkg @@ -85,3 +44,22 @@ roundTrip pkg = if before == after then Pass before else Mismatch before after + +testRunOptions :: PublishOptions +testRunOptions = defaultPublishOptions + { publishGetVersion = return testVersion + } + where testVersion = ("v999.0.0", Version [999,0,0] []) + +-- | Given a directory which contains a package, produce JSON from it, and then +-- | attempt to parse it again, and ensure that it doesn't change. +testPackage :: String -> IO () +testPackage dir = do + pushd dir $ do + r <- roundTrip <$> preparePackage testRunOptions + case r of + Pass _ -> pure () + other -> do + hPutStrLn stderr ("psc-publish tests failed on " ++ dir ++ ":") + hPutStrLn stderr (show other) + exitFailure \ No newline at end of file diff --git a/tests/support/prelude b/tests/support/prelude new file mode 160000 index 0000000000..5b8da18fd7 --- /dev/null +++ b/tests/support/prelude @@ -0,0 +1 @@ +Subproject commit 5b8da18fd7b8d57a85df49ec64099a81b13f42f7 From 0d104d9d29e62edae39b0eaf058eb65dfb3fc9e7 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 12 Dec 2015 15:02:51 -0800 Subject: [PATCH 0201/1580] Fix #1645, implement new indentation rules for types --- src/Language/PureScript/Pretty/Types.hs | 18 ++++++++++++------ src/Language/PureScript/Pretty/Values.hs | 1 + 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 63c4853e61..3c568bab9d 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -121,21 +121,27 @@ constrained = mkPattern match match _ = Nothing matchTypeAtom :: Pattern () Type Box -matchTypeAtom = typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) matchType +matchTypeAtom = typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) matchType matchType :: Pattern () Type Box matchType = buildPrettyPrinter operators matchTypeAtom where operators :: OperatorTable () Type Box operators = - OperatorTable [ [ AssocL typeApp $ \f x -> f `beforeWithSpace` x ] - , [ AssocR appliedFunction $ \arg ret -> (arg <> text " ") `before` (text "-> " <> ret) - ] + OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ] + , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text "-> " <> ret) ] , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ] - , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ] - , [ Wrap kinded $ \k ty -> ty `before` text (" :: " ++ prettyPrintKind k) ] + , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text ("forall " ++ unwords idents ++ ".")) ty ] + , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ prettyPrintKind k)) ] ] + -- If both boxes span a single line, keep them on the same line, or else + -- use the specified function to modify the second box, then combine vertically. + keepSingleLinesOr :: (Box -> Box) -> Box -> Box -> Box + keepSingleLinesOr f b1 b2 + | rows b1 > 1 || rows b2 > 1 = vcat left [ b1, f b2 ] + | otherwise = hcat top [ b1, text " ", b2] + forall_ :: Pattern () Type ([String], Type) forall_ = mkPattern match where diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 3064bc2ef9..9ef9a0c799 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -160,6 +160,7 @@ prettyPrintBinderAtom (ArrayBinder bs) = ++ " ]" prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder +prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder prettyPrintBinderAtom b = parens (prettyPrintBinder b) -- | From a8209f1245a4419c0e07b7ca8fb61d94d08f5b92 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 12 Dec 2015 12:53:13 -0800 Subject: [PATCH 0202/1580] Fix #1700, remove featureRemoved calls in parser (for 0.8) --- src/Language/PureScript/Docs/Convert.hs | 2 +- src/Language/PureScript/Parser/Common.hs | 5 ----- src/Language/PureScript/Parser/Declarations.hs | 7 +------ src/Language/PureScript/Parser/Types.hs | 13 ------------- 4 files changed, 2 insertions(+), 25 deletions(-) diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index b34829119b..175b191728 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -93,7 +93,7 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) = -- fixity declarations. -- -- TODO: This may no longer be necessary after issue 806 is resolved, hopefully --- in 0.8. +-- in 0.9. addDefaultFixity :: Declaration -> Declaration addDefaultFixity decl@Declaration{..} | isOp declTitle && isNothing declFixity = diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index 2460e40fa2..973daf2094 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -27,11 +27,6 @@ import Language.PureScript.Names import qualified Text.Parsec as P -featureWasRemoved :: String -> TokenParser a -featureWasRemoved err = do - pos <- P.getPosition - error $ "It looks like you are trying to use a feature from a previous version of the compiler:\n" ++ err ++ "\nat " ++ show pos - properName :: TokenParser ProperName properName = ProperName <$> uname diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 4ae39b8507..af8de6ceaf 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -106,9 +106,6 @@ parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "imp (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName) <*> (indented *> doubleColon *> parseKind) <|> (do ident <- parseIdent - -- TODO: add a wiki page link with migration info - -- TODO: remove this deprecation warning in 0.8 - _ <- P.optional $ stringLiteral *> featureWasRemoved "Inline foreign string literals are no longer supported." ty <- indented *> doubleColon *> noWildcards parsePolyType return $ ExternDeclaration ident ty)) @@ -524,10 +521,8 @@ parseIdentifierAndBinder = -- Parse a binder -- parseBinder :: TokenParser Binder -parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators (buildPostfixParser postfixTable parseBinderAtom)) +parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable parseBinderAtom) where - -- TODO: remove this deprecation warning in 0.8 - operators = [ [ P.Infix (P.try $ C.indented *> colon *> featureWasRemoved "Cons binders are no longer supported. Consider using purescript-lists or purescript-sequences instead.") P.AssocRight ] ] -- TODO: parsePolyType when adding support for polymorphic types postfixTable = [ \b -> flip TypedBinder b <$> (P.try (indented *> doubleColon) *> parseType) ] diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 5e3f3bb0c2..81f297ab8f 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -17,17 +17,6 @@ import Language.PureScript.Environment import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P --- TODO: remove these deprecation warnings in 0.8 -parseArray :: TokenParser Type -parseArray = do - _ <- squares $ return tyArray - featureWasRemoved "Array notation is no longer supported. Use Array instead of []." - -parseArrayOf :: TokenParser Type -parseArrayOf = do - _ <- squares $ TypeApp tyArray <$> parseType - featureWasRemoved "Array notation is no longer supported. Use Array _ instead of [_]." - parseFunction :: TokenParser Type parseFunction = parens $ rarrow >> return tyFunction @@ -56,8 +45,6 @@ parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> id parseTypeAtom :: TokenParser Type parseTypeAtom = indented *> P.choice (map P.try [ parseConstrainedType - , parseArray - , parseArrayOf , parseFunction , parseObject , parseTypeWildcard From 8114b6e2d9712c7ccc958baa412950228b298d38 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 12 Dec 2015 01:54:43 +0000 Subject: [PATCH 0203/1580] Add native Partial constraint --- examples/passing/EmptyTypeClass.purs | 6 +- examples/passing/NakedConstraint.purs | 2 - src/Language/PureScript/Environment.hs | 35 +++++++--- src/Language/PureScript/Errors.hs | 9 ++- src/Language/PureScript/Linter/Exhaustive.hs | 71 +++++++++++--------- src/Language/PureScript/Sugar/Names/Env.hs | 6 +- 6 files changed, 79 insertions(+), 50 deletions(-) diff --git a/examples/passing/EmptyTypeClass.purs b/examples/passing/EmptyTypeClass.purs index 81d5ab3155..065a829f82 100644 --- a/examples/passing/EmptyTypeClass.purs +++ b/examples/passing/EmptyTypeClass.purs @@ -2,11 +2,11 @@ module Main where import Prelude -class Partial +class PartialP -head :: forall a. (Partial) => Array a -> a +head :: forall a. (PartialP) => Array a -> a head [x] = x -instance allowPartials :: Partial +instance allowPartials :: PartialP main = Control.Monad.Eff.Console.log $ head ["Done"] diff --git a/examples/passing/NakedConstraint.purs b/examples/passing/NakedConstraint.purs index 1fe4e9d874..f4b3a551a5 100644 --- a/examples/passing/NakedConstraint.purs +++ b/examples/passing/NakedConstraint.purs @@ -2,8 +2,6 @@ module Main where import Control.Monad.Eff.Console -class Partial - data List a = Nil | Cons a (List a) head :: (Partial) => List Int -> Int diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 7e54c0301d..4575546501 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -66,7 +66,7 @@ data Environment = Environment { -- The initial environment with no values and only the default javascript types defined -- initEnvironment :: Environment -initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty +initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses -- | -- The visibility of a name in scope @@ -236,17 +236,32 @@ function :: Type -> Type -> Type function t1 = TypeApp (TypeApp tyFunction t1) -- | --- The primitive types in the external javascript environment with their associated kinds. +-- The primitive types in the external javascript environment with their +-- associated kinds. There is also a pseudo `Partial` type that corresponds to +-- the class with the same name. -- 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 "Char" , (Star, ExternData)) - , (primName "Number" , (Star, ExternData)) - , (primName "Int" , (Star, ExternData)) - , (primName "Boolean" , (Star, ExternData)) ] +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 "Char", (Star, ExternData)) + , (primName "Number", (Star, ExternData)) + , (primName "Int", (Star, ExternData)) + , (primName "Boolean", (Star, ExternData)) + , (primName "Partial", (Star, ExternData)) + ] + +-- | +-- The primitive class map. This just contains to `Partial` class, used as a +-- kind of magic constraint for partial functions. +-- +primClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint]) +primClasses = + M.fromList + [ (primName "Partial", ([], [], [])) ] -- | -- Finds information about data constructors from the current environment. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 928306d8af..89f7c5f509 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -773,9 +773,12 @@ prettyPrintSingleError full level e = do renderSimpleErrorMessage (NotExhaustivePattern bs b) = paras $ [ line "A case expression could not be determined to cover all inputs." , line "The following additional cases are required to cover all inputs:\n" - , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) - ] ++ - [ line "..." | not b ] + , indent $ paras $ + [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ] + ++ [ line "..." | not b ] + , line "Or alternatively, add a Partial constraint to the type of the enclosing value." + , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9." + ] renderSimpleErrorMessage (OverlappingPattern bs b) = paras $ [ line "A case expression contains unreachable cases:\n" , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index f36cc2144a..524478b85b 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -19,10 +19,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.PureScript.Linter.Exhaustive - ( checkExhaustive - , checkExhaustiveModule - ) where +module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where import Prelude () import Prelude.Compat @@ -48,7 +45,7 @@ import Language.PureScript.Errors -- | There are two modes of failure for the redudancy check: -- --- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy. +-- 1. Exhaustivity was incomplete due to too many cases, so we couldn't determine redundancy. -- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder. -- -- We want to warn the user in the first case. @@ -239,8 +236,8 @@ missingAlternative env mn ca uncovered -- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses. -- Then, returns the uncovered set of case alternatives. -- -checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m () -checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas +checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m () +checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas where step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]])) step (uncovered, (nec, redundant)) ca = @@ -258,13 +255,13 @@ checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([init makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m () makeResult (bss, (rr, bss')) = - do unless (null bss) tellExhaustive + do unless (hasConstraint || null bss) tellNonExhaustive unless (null bss') tellRedundant case rr of - Left Incomplete -> tellIncomplete + Left Incomplete -> unless hasConstraint tellIncomplete _ -> return () where - tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss + tellNonExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss' tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck @@ -279,29 +276,43 @@ checkExhaustiveDecls env mn = mapM_ onDecl where convert :: (Ident, NameKind, Expr) -> Declaration convert (name, nk, e) = ValueDeclaration name nk [] (Right e) - onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr e) + onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr False e) onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec) onDecl _ = return () - onExpr :: Expr -> m () - onExpr (UnaryMinus e) = onExpr e - onExpr (ArrayLiteral es) = mapM_ onExpr es - onExpr (ObjectLiteral es) = mapM_ (onExpr . snd) es - onExpr (TypeClassDictionaryConstructorApp _ e) = onExpr e - onExpr (Accessor _ e) = onExpr e - onExpr (ObjectUpdate o es) = onExpr o >> mapM_ (onExpr . snd) es - onExpr (Abs _ e) = onExpr e - onExpr (App e1 e2) = onExpr e1 >> onExpr e2 - onExpr (IfThenElse e1 e2 e3) = onExpr e1 >> onExpr e2 >> onExpr e3 - onExpr (Case es cas) = checkExhaustive env mn (length es) cas >> mapM_ onExpr es >> mapM_ onCaseAlternative cas - onExpr (TypedValue _ e _) = onExpr e - onExpr (Let ds e) = mapM_ onDecl ds >> onExpr e - onExpr (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr e) - onExpr _ = return () - - onCaseAlternative :: CaseAlternative -> m () - onCaseAlternative (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr e >> onExpr g) es - onCaseAlternative (CaseAlternative _ (Right e)) = onExpr e + onExpr :: Bool -> Expr -> m () + onExpr isP (UnaryMinus e) = onExpr isP e + onExpr isP (ArrayLiteral es) = mapM_ (onExpr isP) es + onExpr isP (ObjectLiteral es) = mapM_ (onExpr isP . snd) es + onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e + onExpr isP (Accessor _ e) = onExpr isP e + onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es + onExpr isP (Abs _ e) = onExpr isP e + onExpr isP (App e1 e2) = onExpr isP e1 >> onExpr isP e2 + onExpr isP (IfThenElse e1 e2 e3) = onExpr isP e1 >> onExpr isP e2 >> onExpr isP e3 + onExpr isP (Case es cas) = checkExhaustive isP env mn (length es) cas >> mapM_ (onExpr isP) es >> mapM_ (onCaseAlternative isP) cas + onExpr isP (TypedValue _ e ty) = onExpr (isP || hasPartialConstraint ty) e + onExpr isP (Let ds e) = mapM_ onDecl ds >> onExpr isP e + onExpr isP (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr isP e) + onExpr _ _ = return () + + onCaseAlternative :: Bool -> CaseAlternative -> m () + onCaseAlternative isP (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr isP e >> onExpr isP g) es + onCaseAlternative isP (CaseAlternative _ (Right e)) = onExpr isP e + + hasPartialConstraint :: Type -> Bool + hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs + where + go :: Qualified ProperName -> Bool + go qname + | qname == partialClass = True + | otherwise = + case qname `M.lookup` typeClasses env of + Just ([], _, cs') -> any (go . fst) cs' + _ -> False + partialClass :: Qualified ProperName + partialClass = primName "Partial" + hasPartialConstraint _ = False -- | -- Exhaustivity checking over a single module diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 0b0728750c..8f1623613a 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -20,6 +20,7 @@ module Language.PureScript.Sugar.Names.Env import Data.Function (on) import Data.List (groupBy, sortBy, nub) +import Data.Maybe (fromJust) import qualified Data.Map as M import Control.Monad @@ -121,9 +122,10 @@ envModuleExports (_, _, exps) = exps -- The exported types from the @Prim@ module -- primExports :: Exports -primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] [] +primExports = Exports (mkTypeEntry `map` M.keys primTypes) (mkClassEntry `map` M.keys primClasses) [] where - mkTypeEntry (Qualified _ name) = ((name, []), ModuleName [ProperName "Prim"]) + mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn) + mkClassEntry (Qualified mn name) = (name, fromJust mn) -- | Environment which only contains the Prim module. primEnv :: Env From bcb8d326a4be60a8d2829ae85f30ccb3641e8569 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Mon, 7 Dec 2015 20:14:14 -0600 Subject: [PATCH 0204/1580] Match multiple expressions in case statements --- examples/failing/CaseBinderLengthsDiffer.purs | 6 +++ examples/passing/CaseMultipleExpressions.purs | 19 +++++++++ src/Language/PureScript/Errors.hs | 7 ++++ .../PureScript/Parser/Declarations.hs | 4 +- .../PureScript/Sugar/CaseDeclarations.hs | 42 +++++++++++++++---- 5 files changed, 69 insertions(+), 9 deletions(-) create mode 100644 examples/failing/CaseBinderLengthsDiffer.purs create mode 100644 examples/passing/CaseMultipleExpressions.purs diff --git a/examples/failing/CaseBinderLengthsDiffer.purs b/examples/failing/CaseBinderLengthsDiffer.purs new file mode 100644 index 0000000000..69e0e0ae64 --- /dev/null +++ b/examples/failing/CaseBinderLengthsDiffer.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith CaseBinderLengthDiffers +module Main where + +test = case 1, 2 of + 1, 2, 3 -> 42 + _, _ -> 43 diff --git a/examples/passing/CaseMultipleExpressions.purs b/examples/passing/CaseMultipleExpressions.purs new file mode 100644 index 0000000000..763a425cf6 --- /dev/null +++ b/examples/passing/CaseMultipleExpressions.purs @@ -0,0 +1,19 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console +import Control.Monad.Eff + +doIt :: forall eff. Eff eff Boolean +doIt = return true + +set = do + log "Testing..." + case 42, 10 of + 42, 10 -> doIt + _ , _ -> return false + +main = do + b <- set + case b of + true -> log "Done" diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 89f7c5f509..e4d2a01787 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -139,6 +139,7 @@ data SimpleErrorMessage | IntOutOfRange Integer String Integer Integer | RedundantEmptyHidingImport ModuleName | ImplicitImport ModuleName [DeclarationRef] + | CaseBinderLengthDiffers Int [Binder] deriving (Show) -- | Error message hints, providing more detailed information about failure. @@ -309,6 +310,7 @@ errorCode em = case unwrapErrorMessage em of IntOutOfRange{} -> "IntOutOfRange" RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport" ImplicitImport{} -> "ImplicitImport" + CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers" -- | -- A stack trace for an error @@ -860,6 +862,11 @@ prettyPrintSingleError full level e = do , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ] + renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) = + paras $ [ line $ "Binder list length differs in case alternative:" + , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs + , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "." ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 59a7f6fbb6..71ef37277a 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -349,11 +349,11 @@ parseConstructor :: TokenParser Expr parseConstructor = Constructor <$> C.parseQualified C.properName parseCase :: TokenParser Expr -parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (return <$> parseValue) +parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (commaSep1 parseValue) <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative))) parseCaseAlternative :: TokenParser CaseAlternative -parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder) +parseCaseAlternative = CaseAlternative <$> (commaSep1 parseBinder) <*> (Left <$> (C.indented *> P.many1 ((,) <$> parseGuard <*> (indented *> rarrow *> parseValue) diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 8380d4ced6..d6574113f6 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -26,8 +26,8 @@ import Prelude () import Prelude.Compat import Language.PureScript.Crash -import Data.Maybe (catMaybes) -import Data.List (nub, groupBy) +import Data.Maybe (catMaybes, mapMaybe) +import Data.List (nub, groupBy, foldl1') import Control.Monad ((<=<), forM, replicateM, join, unless) import Control.Monad.Error.Class (MonadError(..)) @@ -51,14 +51,42 @@ isLeft (Right _) = False desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module] desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) -> rethrow (addHint (ErrorInModule name)) $ - Module ss coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps + Module ss coms name <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps -desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] +-- | +-- Validates that case head and binder lengths match. +-- +validateCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] +validateCases = flip parU f + where + (f, _, _) = everywhereOnValuesM return validate return + + validate :: Expr -> m Expr + validate c@(Case vs alts) = do + let l = length vs + alts' = filter ((l /=) . length . caseAlternativeBinders) alts + unless (null alts') $ + throwError . MultipleErrors $ fmap (altError l) (caseAlternativeBinders <$> alts') + return c + validate other = return other + + altError :: Int -> [Binder] -> ErrorMessage + altError l bs = withPosition pos $ ErrorMessage [] $ CaseBinderLengthDiffers l bs + where + pos = foldl1' widenSpan (mapMaybe positionedBinder bs) + + widenSpan (SourceSpan n start end) (SourceSpan _ start' end') = + SourceSpan n (min start start') (max end end') + + positionedBinder (PositionedBinder p _ _) = Just p + positionedBinder _ = Nothing + +desugarAbs :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] desugarAbs = flip parU f where (f, _, _) = everywhereOnValuesM return replace return - replace :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Expr -> m Expr + replace :: Expr -> m Expr replace (Abs (Right binder) val) = do ident <- Ident <$> freshName return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)] @@ -67,10 +95,10 @@ desugarAbs = flip parU f -- | -- Replace all top-level binders with case expressions. -- -desugarCases :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] +desugarCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup where - desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] + desugarRest :: [Declaration] -> m [Declaration] desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) = (:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest desugarRest (ValueDeclaration name nameKind bs result : rest) = From 6684fa0ee45cbbf7966f84cfa9d1b8de3b9f8088 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 14 Dec 2015 15:37:49 -0800 Subject: [PATCH 0205/1580] Reduce backtracking in parser --- .../PureScript/Parser/Declarations.hs | 121 +++++++++--------- src/Language/PureScript/Parser/Kinds.hs | 7 +- src/Language/PureScript/Parser/Types.hs | 22 ++-- 3 files changed, 79 insertions(+), 71 deletions(-) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index ae12c72872..c0f5d530f2 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -76,7 +76,7 @@ parseTypeDeclaration = parseTypeSynonymDeclaration :: TokenParser Declaration parseTypeSynonymDeclaration = - TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName) + TypeSynonymDeclaration <$> (reserved "type" *> indented *> properName) <*> many (indented *> kindedIdent) <*> (indented *> equals *> noWildcards parsePolyType) @@ -102,8 +102,8 @@ parseValueDeclaration = do return $ maybe value (`Let` value) whereClause parseExternDeclaration :: TokenParser Declaration -parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *> - (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName) +parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *> + (ExternDataDeclaration <$> (reserved "data" *> indented *> properName) <*> (indented *> doubleColon *> parseKind) <|> (do ident <- parseIdent ty <- indented *> doubleColon *> noWildcards parsePolyType @@ -111,9 +111,9 @@ parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "imp parseAssociativity :: TokenParser Associativity parseAssociativity = - (P.try (reserved "infixl") >> return Infixl) <|> - (P.try (reserved "infixr") >> return Infixr) <|> - (P.try (reserved "infix") >> return Infix) + (reserved "infixl" *> return Infixl) <|> + (reserved "infixr" *> return Infixr) <|> + (reserved "infix" *> return Infix) parseFixity :: TokenParser Fixity parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural) @@ -156,7 +156,6 @@ parseImportDeclaration' = do <|> (const (Implicit True) <$> (indented *> parens (symbol' ".."))) return $ fromMaybe (Implicit False) declType - parseDeclarationRef :: TokenParser DeclarationRef parseDeclarationRef = withSourceSpan PositionedDeclarationRef @@ -173,9 +172,9 @@ parseDeclarationRef = parseTypeClassDeclaration :: TokenParser Declaration parseTypeClassDeclaration = do reserved "class" - implies <- P.option [] $ P.try $ do + implies <- P.option [] . P.try $ do indented - implies <- P.try (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint) + implies <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint) lfatArrow return implies className <- indented *> properName @@ -194,7 +193,7 @@ parseInstanceDeclaration = do reserved "instance" name <- parseIdent <* indented <* doubleColon deps <- P.optionMaybe $ P.try $ do - deps <- P.try (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint) + deps <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint) indented rfatArrow return deps @@ -326,11 +325,12 @@ parseIdentifierAndValue = <|> (,) <$> (C.indented *> stringLiteral) <*> rest where rest = C.indented *> colon *> C.indented *> val - val = (Just <$> parseValue) <|> (underscore *> pure Nothing) + val = (underscore *> pure Nothing) <|> (Just <$> parseValue) parseAbs :: TokenParser Expr parseAbs = do symbol' "\\" + -- TODO: remove this 'try' after operator aliases are finished (0.9) args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens))) C.indented *> rarrow value <- parseValue @@ -346,7 +346,7 @@ parseConstructor :: TokenParser Expr parseConstructor = Constructor <$> C.parseQualified C.properName parseCase :: TokenParser Expr -parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (commaSep1 parseValue) +parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue) <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative))) parseCaseAlternative :: TokenParser CaseAlternative @@ -375,23 +375,25 @@ parseLet = do parseValueAtom :: TokenParser Expr parseValueAtom = P.choice - [ P.try parseNumericLiteral - , P.try parseCharLiteral - , P.try parseStringLiteral - , P.try parseBooleanLiteral - , parseArrayLiteral - , P.try parseObjectLiteral - , P.try parseObjectGetter - , parseAbs - , P.try parseConstructor - , P.try parseVar - , parseCase - , parseIfThenElse - , parseDo - , parseLet - , P.try $ Parens <$> parens parseValue - , parseOperatorSection - , P.try parseObjectUpdaterWildcard ] + [ parseNumericLiteral + , parseCharLiteral + , parseStringLiteral + , parseBooleanLiteral + , parseArrayLiteral + , P.try parseObjectLiteral + , P.try parseObjectGetter + , parseAbs + , P.try parseConstructor + , P.try parseVar + , parseCase + , parseIfThenElse + , parseDo + , parseLet + , P.try $ Parens <$> parens parseValue + , parseOperatorSection + -- TODO: combine this with parseObjectGetter + , parseObjectUpdaterWildcard + ] -- | -- Parse an expression in backticks or an operator @@ -427,13 +429,14 @@ parseDoNotationLet :: TokenParser DoNotationElement parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration))) parseDoNotationBind :: TokenParser DoNotationElement -parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> larrow *> parseValue) +parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* C.indented <* larrow) <*> parseValue parseDoNotationElement :: TokenParser DoNotationElement parseDoNotationElement = P.choice - [ P.try parseDoNotationBind + [ parseDoNotationBind , parseDoNotationLet - , P.try (DoNotationValue <$> parseValue) ] + , DoNotationValue <$> parseValue + ] parseObjectGetter :: TokenParser Expr parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) @@ -443,7 +446,8 @@ indexersAndAccessors :: TokenParser Expr indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom where postfixTable = [ parseAccessor - , P.try . parseUpdaterBody . Just ] + , P.try . parseUpdaterBody . Just + ] -- | -- Parse a value @@ -455,9 +459,9 @@ parseValue = withSourceSpan PositionedValue $ indexersAndAccessors) P. "expression" where postfixTable = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v - , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v + , \v -> flip (TypedValue True) <$> (C.indented *> doubleColon *> parsePolyType) <*> pure v ] - operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus) + operators = [ [ P.Prefix (C.indented *> symbol' "-" *> return UnaryMinus) ] , [ P.Infix (P.try (C.indented *> parseInfixExpr P. "infix expression") >>= \ident -> return (BinaryNoParens ident)) P.AssocRight @@ -487,9 +491,6 @@ parseNumberBinder = NumberBinder <$> (sign <*> number) <|> (symbol' "+" >> return id) <|> return id -parseVarBinder :: TokenParser Binder -parseVarBinder = VarBinder <$> C.parseIdent - parseNullaryConstructorBinder :: TokenParser Binder parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure [] @@ -502,9 +503,13 @@ parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdenti parseArrayBinder :: TokenParser Binder parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder) -parseNamedBinder :: TokenParser Binder -parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at) - <*> (C.indented *> parseBinder) +parseVarOrNamedBinder :: TokenParser Binder +parseVarOrNamedBinder = do + -- TODO: once operator aliases are finalized in 0.9, this 'try' won't be needed + -- any more since identifiers in binders won't be 'Op's. + name <- P.try C.parseIdent + let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinder) + parseNamedBinder <|> return (VarBinder name) parseNullBinder :: TokenParser Binder parseNullBinder = underscore *> return NullBinder @@ -525,38 +530,38 @@ parseBinder :: TokenParser Binder parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable parseBinderAtom) where -- TODO: parsePolyType when adding support for polymorphic types - postfixTable = [ \b -> flip TypedBinder b <$> (P.try (indented *> doubleColon) *> parseType) + postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType) ] parseBinderAtom :: TokenParser Binder - parseBinderAtom = P.choice (map P.try + parseBinderAtom = P.choice [ parseNullBinder , parseCharBinder , parseStringBinder , parseBooleanBinder , parseNumberBinder - , parseNamedBinder - , parseVarBinder + , parseVarOrNamedBinder , parseConstructorBinder , parseObjectBinder , parseArrayBinder - , parens parseBinder ]) P. "binder" + , parens parseBinder + ] P. "binder" -- | -- Parse a binder as it would appear in a top level declaration -- parseBinderNoParens :: TokenParser Binder -parseBinderNoParens = P.choice (map P.try - [ parseNullBinder - , parseCharBinder - , parseStringBinder - , parseBooleanBinder - , parseNumberBinder - , parseNamedBinder - , parseVarBinder - , parseNullaryConstructorBinder - , parseObjectBinder - , parseArrayBinder - , parens parseBinder ]) P. "binder" +parseBinderNoParens = P.choice + [ parseNullBinder + , parseCharBinder + , parseStringBinder + , parseBooleanBinder + , parseNumberBinder + , parseVarOrNamedBinder + , parseNullaryConstructorBinder + , parseObjectBinder + , parseArrayBinder + , parens parseBinder + ] P. "binder" -- | -- Parse a guard diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs index 83e62da0a8..ef67827d25 100644 --- a/src/Language/PureScript/Parser/Kinds.hs +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -33,10 +33,11 @@ parseBang :: TokenParser Kind parseBang = const Bang <$> symbol' "!" parseTypeAtom :: TokenParser Kind -parseTypeAtom = indented *> P.choice (map P.try +parseTypeAtom = indented *> P.choice [ parseStar , parseBang - , parens parseKind ]) + , parens parseKind + ] -- | -- Parse a kind -- @@ -44,4 +45,4 @@ parseKind :: TokenParser Kind parseKind = P.buildExpressionParser operators parseTypeAtom P. "kind" where operators = [ [ P.Prefix (symbol' "#" >> return Row) ] - , [ P.Infix (P.try rarrow >> return FunKind) P.AssocRight ] ] + , [ P.Infix (rarrow >> return FunKind) P.AssocRight ] ] diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 81f297ab8f..8e8d729412 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -18,7 +18,7 @@ import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P parseFunction :: TokenParser Type -parseFunction = parens $ rarrow >> return tyFunction +parseFunction = parens rarrow >> return tyFunction parseObject :: TokenParser Type parseObject = braces $ TypeApp tyObject <$> parseRow @@ -36,24 +36,25 @@ parseTypeConstructor :: TokenParser Type parseTypeConstructor = TypeConstructor <$> parseQualified properName parseForAll :: TokenParser Type -parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot) +parseForAll = mkForAll <$> (reserved "forall" *> P.many1 (indented *> identifier) <* indented <* dot) <*> parseType -- | -- Parse a type as it appears in e.g. a data constructor -- parseTypeAtom :: TokenParser Type -parseTypeAtom = indented *> P.choice (map P.try - [ parseConstrainedType - , parseFunction +parseTypeAtom = indented *> P.choice + [ P.try parseConstrainedType + , P.try parseFunction , parseObject , parseTypeWildcard + , parseForAll , parseTypeVariable , parseTypeConstructor - , parseForAll - , parens parseRow + -- This try is needed due to some unfortunate ambiguities between rows and kinded types + , P.try (parens parseRow) , parens parsePolyType - ]) + ] parseConstrainedType :: TokenParser Type parseConstrainedType = do @@ -74,8 +75,9 @@ parseAnyType :: TokenParser Type parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P. "type" where operators = [ [ P.Infix (return TypeApp) P.AssocLeft ] - , [ P.Infix (rarrow >> return function) P.AssocRight ] ] - postfixTable = [ \t -> KindedType t <$> (P.try (indented *> doubleColon) *> parseKind) + , [ P.Infix (rarrow >> return function) P.AssocRight ] + ] + postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind) ] -- | From 4236b78b7d7d1213704dc21cf4b0c59590571ede Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 13 Dec 2015 16:40:17 +0000 Subject: [PATCH 0206/1580] Renamer updates --- examples/passing/1697.purs | 24 ++++++++ src/Control/Monad/Supply/Class.hs | 22 ++----- src/Language/PureScript/CodeGen/JS.hs | 19 ++---- src/Language/PureScript/CodeGen/JS/Common.hs | 14 +---- src/Language/PureScript/Make.hs | 19 +----- src/Language/PureScript/Names.hs | 37 ++++++------ src/Language/PureScript/Renamer.hs | 58 +++++++++---------- .../PureScript/Sugar/CaseDeclarations.hs | 28 +++------ src/Language/PureScript/Sugar/DoNotation.hs | 20 ++----- .../PureScript/Sugar/ObjectWildcards.hs | 20 +------ src/Language/PureScript/Sugar/Operators.hs | 2 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 24 ++------ src/Language/PureScript/TypeChecker.hs | 5 +- src/Language/PureScript/TypeChecker/Monad.hs | 10 +--- src/Language/PureScript/TypeChecker/Types.hs | 50 ++++++---------- 15 files changed, 131 insertions(+), 221 deletions(-) create mode 100644 examples/passing/1697.purs diff --git a/examples/passing/1697.purs b/examples/passing/1697.purs new file mode 100644 index 0000000000..44f42894eb --- /dev/null +++ b/examples/passing/1697.purs @@ -0,0 +1,24 @@ +module Main where + +import Prelude + +_2 :: forall a. a -> a +_2 a = a + +x :: forall m. (Monad m) => m Unit +x = do + _ <- pure unit + pure unit + +y :: forall m. (Monad m) => m Unit +y = do + _ <- pure unit + pure unit + +wtf :: forall m. (Monad m) => m Unit +wtf = do + _ <- pure unit + let tmp = _2 1 + pure unit + +main = Control.Monad.Eff.Console.log "Done" diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index 3869224537..02c185a8a5 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -1,20 +1,8 @@ ------------------------------------------------------------------------------ --- --- Module : Control.Monad.Supply.Class --- Copyright : (c) PureScript 2015 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE MultiParamTypeClasses #-} + -- | -- A class for monads supporting a supply of fresh names -- ------------------------------------------------------------------------------ - -{-# LANGUAGE MultiParamTypeClasses #-} - module Control.Monad.Supply.Class where import Control.Monad.Supply @@ -22,15 +10,15 @@ import Control.Monad.State class (Monad m) => MonadSupply m where fresh :: m Integer - + instance (Monad m) => MonadSupply (SupplyT m) where fresh = SupplyT $ do n <- get put (n + 1) return n - + instance (MonadSupply m) => MonadSupply (StateT s m) where fresh = lift fresh freshName :: (MonadSupply m) => m String -freshName = liftM (('_' :) . show) fresh +freshName = liftM (('$' :) . show) fresh diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index c45e7fdba2..96392baa9f 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -1,23 +1,11 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen.JS --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- This module generates code in the simplified Javascript intermediate representation from Purescript code --- ------------------------------------------------------------------------------ - {-# LANGUAGE GADTs #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | +-- This module generates code in the simplified Javascript intermediate representation from Purescript code +-- module Language.PureScript.CodeGen.JS ( module AST , module Common @@ -180,6 +168,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = accessor :: Ident -> JS -> JS accessor (Ident prop) = accessorString prop accessor (Op op) = JSIndexer (JSStringLiteral op) + accessor (GenIdent _ _) = internalError "GenIdent in accessor" accessorString :: String -> JS -> JS accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop) diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 6ba0e78ac9..64adaa043c 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -1,23 +1,12 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen.Common --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Common code generation utility functions -- ------------------------------------------------------------------------------ - module Language.PureScript.CodeGen.JS.Common where import Data.Char import Data.List (intercalate) +import Language.PureScript.Crash import Language.PureScript.Names -- | @@ -33,6 +22,7 @@ identToJs :: Ident -> String identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name identToJs (Ident name) = concatMap identCharToString name identToJs (Op op) = concatMap identCharToString op +identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" -- | -- Test if a string is a valid JS identifier without escaping. diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index f4e7890960..30866d3975 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -1,17 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Make --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -225,8 +211,9 @@ make MakeActions{..} ms = do progress $ CompilingModule moduleName let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs lint m - ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m] - (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared + ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do + [desugared] <- desugar externs [m] + runCheck' env $ typeCheckModule desugared checkExhaustiveModule env' checked regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated let mod' = Module ss coms moduleName regrouped exps diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 1b003d25eb..e3a8da7f24 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -1,25 +1,16 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Names --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- Data types for names --- ------------------------------------------------------------------------------ - {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GADTs #-} +-- | +-- Data types for names +-- module Language.PureScript.Names where +import Control.Monad (liftM) +import Control.Monad.Supply.Class + import Data.List import Data.Data import Data.List.Split (splitOn) @@ -38,15 +29,27 @@ data Ident -- | -- A symbolic name for an infix operator -- - | Op String deriving (Show, Read, Eq, Ord, Data, Typeable) + | Op String + -- | + -- A generated name for an identifier + -- + | GenIdent (Maybe String) Integer deriving (Show, Read, Eq, Ord, Data, Typeable) runIdent :: Ident -> String runIdent (Ident i) = i runIdent (Op op) = op +runIdent (GenIdent Nothing n) = "$" ++ show n +runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n showIdent :: Ident -> String -showIdent (Ident i) = i showIdent (Op op) = '(' : op ++ ")" +showIdent i = runIdent i + +freshIdent :: (MonadSupply m) => String -> m Ident +freshIdent name = liftM (GenIdent (Just name)) fresh + +freshIdent' :: (MonadSupply m) => m Ident +freshIdent' = liftM (GenIdent Nothing) fresh -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index c651bfc561..9897badaa7 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -1,22 +1,9 @@ ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Renamer --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- Renaming pass that prevents shadowing of local identifiers. --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Renaming pass that prevents shadowing of local identifiers. +-- module Language.PureScript.Renamer (renameInModules) where import Prelude () @@ -25,6 +12,7 @@ import Prelude.Compat import Control.Monad.State import Data.List (find) +import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -76,19 +64,31 @@ newScope x = do -- unique name is generated and stored. -- updateScope :: Ident -> Rename Ident -updateScope i@(Ident name) | name == C.__unused = return i -updateScope name = do - scope <- get - name' <- if name `S.member` rsUsedNames scope - then do - let newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ] - Just newName = find (`S.notMember` rsUsedNames scope) newNames - return newName - else return name - modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s) - , rsUsedNames = S.insert name' (rsUsedNames s) - } - return name' +updateScope ident = + case ident of + Ident name + | name == C.__unused -> return ident + | last name == '\'' -> go ident $ Ident $ init name ++ "ʹ" -- '\x02b9' + GenIdent name _ -> go ident $ Ident (fromMaybe "v" name) + _ -> go ident ident + where + go :: Ident -> Ident -> Rename Ident + go keyName baseName = do + scope <- get + let usedNames = rsUsedNames scope + name' = + if baseName `S.member` usedNames + then getNewName usedNames baseName + else baseName + modify $ \s -> s { rsBoundNames = M.insert keyName name' (rsBoundNames s) + , rsUsedNames = S.insert name' (rsUsedNames s) + } + return name' + getNewName :: S.Set Ident -> Ident -> Ident + getNewName usedNames name = + fromJust $ find + (`S.notMember` usedNames) + [ Ident (runIdent name ++ show (i :: Int)) | i <- [1..] ] -- | -- Finds the new name to use for an ident. diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index d6574113f6..4858599ca0 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -1,22 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CaseDeclarations --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + -- | -- This module implements the desugaring pass which replaces top-level binders with -- case expressions. -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Language.PureScript.Sugar.CaseDeclarations ( desugarCases, desugarCasesModule @@ -88,7 +76,7 @@ desugarAbs = flip parU f replace :: Expr -> m Expr replace (Abs (Right binder) val) = do - ident <- Ident <$> freshName + ident <- freshIdent' return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)] replace other = return other @@ -136,7 +124,7 @@ toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = isVarBinder _ = False fromVarBinder :: Binder -> m Ident - fromVarBinder NullBinder = Ident <$> freshName + fromVarBinder NullBinder = freshIdent' fromVarBinder (VarBinder name) = return name fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b fromVarBinder (TypedBinder _ b) = fromVarBinder b @@ -165,7 +153,7 @@ makeCaseDeclaration ident alternatives = do argNames = map join $ foldl1 resolveNames namedArgs args <- if allUnique (catMaybes argNames) then mapM argName argNames - else replicateM (length argNames) (Ident <$> freshName) + else replicateM (length argNames) freshIdent' let vars = map (Var . Qualified Nothing) args binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] value = foldr (Abs . Left) (Case vars binders) args @@ -190,9 +178,7 @@ makeCaseDeclaration ident alternatives = do argName :: Maybe Ident -> m Ident argName (Just name) = return name - argName _ = do - name <- freshName - return (Ident name) + argName _ = freshIdent' -- Combine two lists of potential names from two case alternatives -- by zipping correspoding columns. diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index c91012a3f2..e175bbefbf 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -1,22 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Sugar.DoNotation --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + -- | -- This module implements the desugaring pass which replaces do-notation statements with -- appropriate calls to bind from the Prelude.Monad type class. -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Language.PureScript.Sugar.DoNotation ( desugarDoModule ) where @@ -68,7 +56,7 @@ desugarDo d = return $ App (App bind val) (Abs (Left ident) rest') go (DoNotationBind binder val : rest) = do rest' <- go rest - ident <- Ident <$> freshName + ident <- freshIdent' return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')])) go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet go (DoNotationLet ds : rest) = do diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index a68331e048..136e892315 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -1,17 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Sugar.ObjectWildcards --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -44,10 +30,10 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps desugarExpr (ObjectUpdater Nothing ps) = do - obj <- Ident <$> freshName + obj <- freshIdent' Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps desugarExpr (ObjectGetter prop) = do - arg <- Ident <$> freshName + arg <- freshIdent' return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg))) desugarExpr e = return e @@ -63,5 +49,5 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr)) mkProp (name, Just e) = return (Nothing, (name, e)) mkProp (name, Nothing) = do - arg <- Ident <$> freshName + arg <- freshIdent' return (Just arg, (name, Var (Qualified Nothing arg))) diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index fe9d33502a..b4828c83a6 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -178,6 +178,6 @@ desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> trav goExpr :: Expr -> m Expr goExpr (OperatorSection op (Left val)) = return $ App op val goExpr (OperatorSection op (Right val)) = do - arg <- Ident <$> freshName + arg <- freshIdent' return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val goExpr other = return other diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 08840f6999..254945e8b1 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -1,18 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Sugar.TypeClasses.Deriving --- Copyright : (c) Gershom Bazerman 2015 --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- This module implements the generic deriving elaboration that takes place during desugaring. --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -20,6 +5,9 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | +-- This module implements the generic deriving elaboration that takes place during desugaring. +-- module Language.PureScript.Sugar.TypeClasses.Deriving ( deriveInstances ) where @@ -32,7 +20,7 @@ import Data.Maybe (fromMaybe) import Data.Ord (comparing) import Control.Monad (replicateM) -import Control.Monad.Supply.Class (MonadSupply, freshName) +import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Error.Class (MonadError(..)) import Language.PureScript.Crash @@ -106,7 +94,7 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative mkCtorClause (ctorName, tys) = do - idents <- replicateM (length tys) (fmap Ident freshName) + idents <- replicateM (length tys) freshIdent' return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents)) where caseResult idents = @@ -172,7 +160,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch mkAlternative :: (ProperName, [Type]) -> m CaseAlternative mkAlternative (ctorName, tys) = do - idents <- replicateM (length tys) (fmap Ident freshName) + idents <- replicateM (length tys) freshIdent' return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]] . Right $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName)) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 400c935da3..3c7b24b40b 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -25,6 +25,7 @@ import Data.Foldable (for_, traverse_) import qualified Data.Map as M import Control.Monad (when, unless, void, forM, forM_) +import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.State.Class (MonadState(..), modify) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -179,7 +180,7 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms -- * Process module imports -- typeCheckAll :: forall m. - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> [DeclarationRef] -> [Declaration] -> @@ -335,7 +336,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds -- required by exported members are also exported. -- typeCheckModule :: forall m. - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> m Module typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated" diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 97eea4ca7d..57354c150f 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -57,14 +57,13 @@ data CheckState = CheckState , checkNextKind :: Int -- ^ The next kind unification variable , checkNextSkolem :: Int -- ^ The next skolem variable , checkNextSkolemScope :: Int -- ^ The next skolem scope constant - , checkNextDictName :: Int -- ^ The next type class dictionary name , checkCurrentModule :: Maybe ModuleName -- ^ The current module , checkSubstitution :: Substitution -- ^ The current substitution } -- | Create an empty @CheckState@ emptyCheckState :: Environment -> CheckState -emptyCheckState env = CheckState env 0 0 0 0 0 Nothing emptySubstitution +emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution -- | Unification variables type Unknown = Int @@ -202,13 +201,6 @@ guardWith :: (MonadError e m) => e -> Bool -> m () guardWith _ True = return () guardWith e False = throwError e --- | Generate new type class dictionary name -freshDictionaryName :: (Functor m, MonadState CheckState m) => m Int -freshDictionaryName = do - n <- checkNextDictName <$> get - modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) } - return n - -- | Run a computation in the substitution monad, generating a return value and the final substitution. liftUnify :: (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 7ae8adcacb..d9671cae76 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -1,23 +1,11 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker.Types --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- This module implements the type checker --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +-- | +-- This module implements the type checker +-- module Language.PureScript.TypeChecker.Types ( typesOf ) where @@ -48,6 +36,7 @@ import qualified Data.Map as M import Control.Monad import Control.Monad.State.Class (MonadState(..), gets) +import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -72,7 +61,7 @@ import Language.PureScript.Types -- | Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. typesOf :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> [(Ident, Expr)] -> m [(Ident, (Expr, Type))] @@ -129,7 +118,7 @@ typeDictionaryForBindingGroup moduleName vals = do return (untyped, typed, dict, untypedDict) checkTypedBindingGroupElement :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> @@ -148,7 +137,7 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do return (ident, (val'', ty'')) typeForBindingGroupElement :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Bool -> (Ident, Expr) -> TypeData -> @@ -218,14 +207,14 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty) -- | Infer a type for a value, rethrowing any error to provide a more useful error message infer :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> m Expr infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val -- | Infer a type for a value infer' :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> m Expr infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt @@ -312,7 +301,7 @@ infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val infer' _ = internalError "Invalid argument to infer" inferLetBinding :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] -> [Declaration] -> Expr -> @@ -423,7 +412,7 @@ binderRequiresMonotype _ = True -- | Instantiate polytypes only when necessitated by a binder. instantiateForBinders :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Expr] -> [CaseAlternative] -> m ([Expr], [Type]) @@ -440,7 +429,7 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do -- Check the types of the return values in a set of binders in a case statement -- checkBinders :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Type] -> Type -> [CaseAlternative] -> @@ -470,7 +459,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do -- Check the type of a value, rethrowing errors to provide a better error message -- check :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> Type -> m Expr @@ -480,7 +469,7 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty -- Check the type of a value -- check' :: forall m. - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> Type -> m Expr @@ -495,9 +484,8 @@ check' val (ForAll ident ty _) = do val' <- check skVal sk return $ TypedValue True val' (ForAll ident ty (Just scope)) check' val t@(ConstrainedType constraints ty) = do - dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do - n <- freshDictionaryName - return $ Ident $ "__dict_" ++ className ++ "_" ++ show n + dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> + freshIdent ("dict" ++ className) dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty return $ TypedValue True (foldr (Abs . Left) val' dictNames) t @@ -639,7 +627,7 @@ check' val ty = do -- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case. -- checkProperties :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> [(String, Expr)] -> Type -> @@ -671,7 +659,7 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh -- | Check the type of a function application, rethrowing errors to provide a better error message checkFunctionApplication :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> Type -> Expr -> @@ -683,7 +671,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication -- | Check the type of a function application checkFunctionApplication' :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> Type -> Expr -> From 0c87efeff2afa3210726791d68a53078bed52bbe Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 15 Dec 2015 18:08:50 -0800 Subject: [PATCH 0207/1580] Add release notes script --- make_release_notes | 2 ++ 1 file changed, 2 insertions(+) create mode 100755 make_release_notes diff --git a/make_release_notes b/make_release_notes new file mode 100755 index 0000000000..edf84a2d22 --- /dev/null +++ b/make_release_notes @@ -0,0 +1,2 @@ +curl https://api.github.com/repos/purescript/purescript/pulls?state=closed\&per_page=100 \ + | jq -r '.[] | ("- " + .title + " (@" + .user.login + ")")' From e66c773c5b71bc49d4835474c1ab4ea5eb882a74 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 16 Dec 2015 15:07:45 +0100 Subject: [PATCH 0208/1580] Ensure no duplicates appear in the PSCiState - Use a Set for imported filenames, to ensure there are no duplicates - Use a Map for loaded modules, keyed by module name, to ensure that there are no duplicates - Provide new accessors using the old types Maybe if a duplicate module is loaded, silently forgetting the old module isn't the right approach, though. Especially if the filenames were different. --- psci/PSCi.hs | 21 ++++++++++--------- psci/Types.hs | 58 +++++++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 60 insertions(+), 19 deletions(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 5f2de5f1e6..f228882ffd 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -129,7 +129,7 @@ loadAllImportedModules = do modulesOrFirstError <- psciIO $ loadAllModules files case modulesOrFirstError of Left errs -> printErrors errs - Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules } + Right modules -> PSCI . lift . modify $ updateModules modules -- | -- Expands tilde in path. @@ -249,11 +249,12 @@ makeIO f io = do either (throwError . P.singleError . f) return e make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment -make PSCiState{..} ms = P.make actions' (map snd (psciLoadedModules ++ ms)) +make st@PSCiState{..} ms = P.make actions' (map snd (loadedModules ++ ms)) where - filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms) + filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (loadedModules ++ ms) actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False actions' = actions { P.progress = const (return ()) } + loadedModules = psciLoadedModules st -- | -- Takes a value declaration and evaluates it with the current state. @@ -294,7 +295,7 @@ handleDecls ds = do -- handleShowLoadedModules :: PSCI () handleShowLoadedModules = do - PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get + loadedModules <- PSCI $ lift $ gets psciLoadedModules psciIO $ readModules loadedModules >>= putStrLn return () where readModules = return . unlines . sort . nub . map toModuleName @@ -547,11 +548,11 @@ handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns) handleCommand ResetState = do files <- psciImportedFilenames <$> PSCI (lift get) - PSCI . lift . modify $ \st -> st - { psciImportedFilenames = files - , psciImportedModules = [] - , psciLetBindings = [] - } + PSCI . lift . modify $ \st -> + (foldl (flip updateImportedFiles) st files) + { psciImportedModules = [] + , psciLetBindings = [] + } loadAllImportedModules handleCommand (TypeOf val) = handleTypeOf val handleCommand (KindOf typ) = handleKindOf typ @@ -614,7 +615,7 @@ loop PSCiOptions{..} = do case foreignsOrError of Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure Right foreigns -> - flip evalStateT (PSCiState inputFiles [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do + flip evalStateT (mkPSCiState inputFiles [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do outputStrLn prologueMessage traverse_ (traverse_ (runPSCI . handleCommand)) config modules' <- lift $ gets psciLoadedModules diff --git a/psci/Types.hs b/psci/Types.hs index 107a353db7..a176af531b 100644 --- a/psci/Types.hs +++ b/psci/Types.hs @@ -15,7 +15,10 @@ module Types where -import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map import qualified Language.PureScript as P data PSCiOptions = PSCiOptions @@ -32,14 +35,48 @@ data PSCiOptions = PSCiOptions -- because it makes more sense to apply the binding to the final evaluated expression. -- data PSCiState = PSCiState - { psciImportedFilenames :: [FilePath] + { _psciImportedFilenames :: Set FilePath , psciImportedModules :: [ImportedModule] - , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)] - , psciForeignFiles :: M.Map P.ModuleName FilePath + , _psciLoadedModules :: Map P.ModuleName (Either P.RebuildPolicy FilePath, P.Module) + , psciForeignFiles :: Map P.ModuleName FilePath , psciLetBindings :: [P.Declaration] , psciNodeFlags :: [String] } +-- Public psci state accessors + +-- | Get the imported filenames as a list. +psciImportedFilenames :: PSCiState -> [FilePath] +psciImportedFilenames = Set.toList . _psciImportedFilenames + +-- | Get the loaded modules as a list. +psciLoadedModules :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] +psciLoadedModules = Map.elems . _psciLoadedModules + +mkPSCiState :: [FilePath] + -> [ImportedModule] + -> [(Either P.RebuildPolicy FilePath, P.Module)] + -> Map P.ModuleName FilePath + -> [P.Declaration] + -> [String] + -> PSCiState +mkPSCiState files imported loaded foreign lets nodeFlags = + (initialPSCiState + |> each files updateImportedFiles + |> each imported updateImportedModules + |> updateModules loaded) + { psciForeignFiles = foreign + , psciLetBindings = lets + , psciNodeFlags = nodeFlags + } + where + x |> f = f x + each xs f st = foldl (flip f) st xs + +initialPSCiState :: PSCiState +initialPSCiState = + PSCiState Set.empty [] Map.empty Map.empty [] [] + -- | All of the data that is contained by an ImportDeclaration in the AST. -- That is: -- @@ -65,10 +102,10 @@ allImportsOf m (PSCiState{psciImportedModules = is}) = -- State helpers -- | --- Updates the state to have more imported modules. +-- Updates the state to have more imported files. -- updateImportedFiles :: FilePath -> PSCiState -> PSCiState -updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st } +updateImportedFiles filename st = st { _psciImportedFilenames = Set.insert filename (_psciImportedFilenames st) } -- | -- Updates the state to have more imported modules. @@ -80,7 +117,10 @@ updateImportedModules im st = st { psciImportedModules = im : psciImportedModule -- Updates the state to have more loaded files. -- updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState -updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules } +updateModules modules st = + st { _psciLoadedModules = foldl (\m mdl -> Map.insert (keyFor mdl) mdl m) (_psciLoadedModules st) modules } + where + keyFor = P.getModuleName . snd -- | -- Updates the state to have more let bindings. @@ -91,8 +131,8 @@ updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds } -- | -- Updates the state to have more let bindings. -- -updateForeignFiles :: M.Map P.ModuleName FilePath -> PSCiState -> PSCiState -updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `M.union` fs } +updateForeignFiles :: Map P.ModuleName FilePath -> PSCiState -> PSCiState +updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `Map.union` fs } -- | -- Valid Meta-commands for PSCI From ea002354b43764e41466e2e2923d5bc08813fb18 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 18 Dec 2015 11:43:31 -0800 Subject: [PATCH 0209/1580] Unicode operators --- examples/passing/UnicodeOperators.purs | 20 ++++++++++++++++++++ src/Language/PureScript/Parser/Lexer.hs | 10 +++++----- src/Language/PureScript/Pretty/Common.hs | 4 ++-- 3 files changed, 27 insertions(+), 7 deletions(-) create mode 100644 examples/passing/UnicodeOperators.purs diff --git a/examples/passing/UnicodeOperators.purs b/examples/passing/UnicodeOperators.purs new file mode 100644 index 0000000000..3fa3347419 --- /dev/null +++ b/examples/passing/UnicodeOperators.purs @@ -0,0 +1,20 @@ +module Main where + +compose :: forall a b c. (b -> c) -> (a -> b) -> a -> c +compose f g a = f (g a) + +infixr 9 compose as ∘ + +test1 = (\x -> x) ∘ \y -> y + +elem :: forall a b. a -> (a -> Boolean) -> Boolean +elem x f = f x + +infixl 1 elem as ∈ + +emptySet :: forall a. a -> Boolean +emptySet _ = true + +test2 = 1 ∈ emptySet + +main = Control.Monad.Eff.Console.log "Done" diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index acdb940f96..20ddf8b5cc 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -67,13 +67,13 @@ module Language.PureScript.Parser.Lexer , natural , reservedPsNames , reservedTypeNames - , opChars + , isSymbolChar ) where import Prelude hiding (lex) -import Data.Char (isSpace) +import Data.Char (isSpace, isAscii, isSymbol) import Control.Monad (void, guard) import Data.Functor.Identity @@ -233,7 +233,7 @@ parseToken = P.choice uidentLetter = P.alphaNum <|> P.char '_' symbolChar :: P.Parsec String u Char - symbolChar = P.oneOf opChars + symbolChar = P.satisfy isSymbolChar parseCharLiteral :: P.Parsec String u Char parseCharLiteral = PT.charLiteral tokenParser @@ -516,5 +516,5 @@ reservedTypeNames = [ "forall", "where" ] -- | -- The characters allowed for use in operators -- -opChars :: [Char] -opChars = ":!#$%&*+./<=>?@\\^|-~" +isSymbolChar :: Char -> Bool +isSymbolChar c = (c `elem` ":!#$%&*+./<=>?@\\^|-~") || (not (isAscii c) && isSymbol c) diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index ce6fc33d33..59b5451090 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -18,7 +18,7 @@ module Language.PureScript.Pretty.Common where import Control.Monad.State import Data.List (intercalate) -import Language.PureScript.Parser.Lexer (reservedPsNames, opChars) +import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar) import Text.PrettyPrint.Boxes @@ -68,7 +68,7 @@ prettyPrintMany f xs = do -- prettyPrintObjectKey :: String -> String prettyPrintObjectKey s | s `elem` reservedPsNames = show s - | any (`elem` opChars) s = show s + | any isSymbolChar s = show s | otherwise = s -- | Place a box before another, vertically when the first box takes up multiple lines. From f835dcdfdc750bf59e4dac9bceb905765753ee36 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 18 Dec 2015 22:12:21 +0100 Subject: [PATCH 0210/1580] Remove importedFilenames field of PSCiState It's not really needed, as that information is already available via the _pcsiLoadedModules field. Additionally: - Change the Either P.RebuildPolicy FilePath to a simple FilePath. We were never actually storing Lefts in there. - Change the _psciLoadedModules to a Map mapping each filename to a list of modules. This way, we avoid accidentally creating duplicate modules (which aren't really duplicates). --- psci/PSCi.hs | 35 ++++++++++++------------ psci/Types.hs | 68 +++++++++++++++++++++------------------------- psci/tests/Main.hs | 2 +- 3 files changed, 49 insertions(+), 56 deletions(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index f228882ffd..7ecc476d84 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -113,12 +113,12 @@ loadModule filename = do -- | -- Load all modules. -- -loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(Either P.RebuildPolicy FilePath, P.Module)]) +loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)]) loadAllModules files = do filesAndContent <- forM files $ \filename -> do content <- readFile filename - return (Right filename, content) - return $ P.parseModulesFromFiles (either (const "") id) filesAndContent + return (filename, content) + return $ P.parseModulesFromFiles id filesAndContent -- | -- Load all modules, updating the application state @@ -248,13 +248,14 @@ makeIO f io = do e <- liftIO $ tryIOError io either (throwError . P.singleError . f) return e -make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> P.Make P.Environment -make st@PSCiState{..} ms = P.make actions' (map snd (loadedModules ++ ms)) +make :: PSCiState -> [P.Module] -> P.Make P.Environment +make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms) where - filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (loadedModules ++ ms) + filePathMap = M.fromList $ (first P.getModuleName . swap) `map` allModules actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False actions' = actions { P.progress = const (return ()) } loadedModules = psciLoadedModules st + allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms -- | -- Takes a value declaration and evaluates it with the current state. @@ -264,7 +265,7 @@ handleDeclaration val = do st <- PSCI $ lift get let m = createTemporaryModule True st val let nodeArgs = psciNodeFlags st ++ [indexFile] - e <- psciIO . runMake $ make st [(Left P.RebuildAlways, supportModule), (Left P.RebuildAlways, m)] + e <- psciIO . runMake $ make st [supportModule, m] case e of Left errs -> printErrors errs Right _ -> do @@ -285,7 +286,7 @@ handleDecls ds = do st <- PSCI $ lift get let st' = updateLets ds st let m = createTemporaryModule False st' (P.ObjectLiteral []) - e <- psciIO . runMake $ make st' [(Left P.RebuildAlways, m)] + e <- psciIO . runMake $ make st' [m] case e of Left err -> printErrors err Right _ -> PSCI $ lift (put st') @@ -341,7 +342,7 @@ handleImport :: ImportedModule -> PSCI () handleImport im = do st <- updateImportedModules im <$> PSCI (lift get) let m = createTemporaryModuleForImports st - e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)] + e <- psciIO . runMake $ make st [m] case e of Left errs -> printErrors errs Right _ -> do @@ -355,7 +356,7 @@ handleTypeOf :: P.Expr -> PSCI () handleTypeOf val = do st <- PSCI $ lift get let m = createTemporaryModule False st val - e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)] + e <- psciIO . runMake $ make st [m] case e of Left errs -> printErrors errs Right env' -> @@ -492,7 +493,7 @@ handleKindOf typ = do st <- PSCI $ lift get let m = createTemporaryModuleForKind st typ mName = P.ModuleName [P.ProperName "$PSCI"] - e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)] + e <- psciIO . runMake $ make st [m] case e of Left errs -> printErrors errs Right env' -> @@ -534,11 +535,10 @@ handleCommand ShowHelp = PSCI $ outputStrLn helpMessage handleCommand (Import im) = handleImport im handleCommand (Decls l) = handleDecls l handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do - PSCI . lift $ modify (updateImportedFiles absPath) m <- psciIO $ loadModule absPath case m of Left err -> PSCI $ outputStrLn err - Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods)) + Right mods -> PSCI . lift $ modify (updateModules (map (absPath,) mods)) handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do foreignsOrError <- psciIO . runMake $ do foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath) @@ -549,10 +549,9 @@ handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do handleCommand ResetState = do files <- psciImportedFilenames <$> PSCI (lift get) PSCI . lift . modify $ \st -> - (foldl (flip updateImportedFiles) st files) - { psciImportedModules = [] - , psciLetBindings = [] - } + st { psciImportedModules = [] + , psciLetBindings = [] + } loadAllImportedModules handleCommand (TypeOf val) = handleTypeOf val handleCommand (KindOf typ) = handleKindOf typ @@ -615,7 +614,7 @@ loop PSCiOptions{..} = do case foreignsOrError of Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure Right foreigns -> - flip evalStateT (mkPSCiState inputFiles [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do + flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do outputStrLn prologueMessage traverse_ (traverse_ (runPSCI . handleCommand)) config modules' <- lift $ gets psciLoadedModules diff --git a/psci/Types.hs b/psci/Types.hs index a176af531b..1f9ba2a87d 100644 --- a/psci/Types.hs +++ b/psci/Types.hs @@ -15,8 +15,7 @@ module Types where -import Data.Set (Set) -import qualified Data.Set as Set +import Control.Arrow (second) import Data.Map (Map) import qualified Data.Map as Map import qualified Language.PureScript as P @@ -35,34 +34,25 @@ data PSCiOptions = PSCiOptions -- because it makes more sense to apply the binding to the final evaluated expression. -- data PSCiState = PSCiState - { _psciImportedFilenames :: Set FilePath - , psciImportedModules :: [ImportedModule] - , _psciLoadedModules :: Map P.ModuleName (Either P.RebuildPolicy FilePath, P.Module) + { psciImportedModules :: [ImportedModule] + , _psciLoadedModules :: Map FilePath [P.Module] , psciForeignFiles :: Map P.ModuleName FilePath , psciLetBindings :: [P.Declaration] , psciNodeFlags :: [String] } --- Public psci state accessors - --- | Get the imported filenames as a list. -psciImportedFilenames :: PSCiState -> [FilePath] -psciImportedFilenames = Set.toList . _psciImportedFilenames - --- | Get the loaded modules as a list. -psciLoadedModules :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -psciLoadedModules = Map.elems . _psciLoadedModules - -mkPSCiState :: [FilePath] - -> [ImportedModule] - -> [(Either P.RebuildPolicy FilePath, P.Module)] - -> Map P.ModuleName FilePath - -> [P.Declaration] - -> [String] - -> PSCiState -mkPSCiState files imported loaded foreign lets nodeFlags = +initialPSCiState :: PSCiState +initialPSCiState = + PSCiState [] Map.empty Map.empty [] [] + +mkPSCiState :: [ImportedModule] + -> [(FilePath, P.Module)] + -> Map P.ModuleName FilePath + -> [P.Declaration] + -> [String] + -> PSCiState +mkPSCiState imported loaded foreign lets nodeFlags = (initialPSCiState - |> each files updateImportedFiles |> each imported updateImportedModules |> updateModules loaded) { psciForeignFiles = foreign @@ -73,9 +63,18 @@ mkPSCiState files imported loaded foreign lets nodeFlags = x |> f = f x each xs f st = foldl (flip f) st xs -initialPSCiState :: PSCiState -initialPSCiState = - PSCiState Set.empty [] Map.empty Map.empty [] [] +-- Public psci state accessors + +-- | Get the imported filenames as a list. +psciImportedFilenames :: PSCiState -> [FilePath] +psciImportedFilenames = Map.keys . _psciLoadedModules + +-- | Get the loaded modules as a list. +psciLoadedModules :: PSCiState -> [(FilePath, P.Module)] +psciLoadedModules = collect . Map.toList . _psciLoadedModules + where + collect :: [(k, [v])] -> [(k, v)] + collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ] -- | All of the data that is contained by an ImportDeclaration in the AST. -- That is: @@ -101,12 +100,6 @@ allImportsOf m (PSCiState{psciImportedModules = is}) = -- State helpers --- | --- Updates the state to have more imported files. --- -updateImportedFiles :: FilePath -> PSCiState -> PSCiState -updateImportedFiles filename st = st { _psciImportedFilenames = Set.insert filename (_psciImportedFilenames st) } - -- | -- Updates the state to have more imported modules. -- @@ -114,13 +107,14 @@ updateImportedModules :: ImportedModule -> PSCiState -> PSCiState updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st } -- | --- Updates the state to have more loaded files. +-- Updates the state to have more loaded modules (available for import, but +-- not necessarily imported). -- -updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState +updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState updateModules modules st = - st { _psciLoadedModules = foldl (\m mdl -> Map.insert (keyFor mdl) mdl m) (_psciLoadedModules st) modules } + st { _psciLoadedModules = Map.union (go modules) (_psciLoadedModules st) } where - keyFor = P.getModuleName . snd + go = Map.fromListWith (++) . map (second (:[])) -- | -- Updates the state to have more let bindings. diff --git a/psci/tests/Main.hs b/psci/tests/Main.hs index 0e244a3ec6..57a9ecc171 100644 --- a/psci/tests/Main.hs +++ b/psci/tests/Main.hs @@ -142,7 +142,7 @@ getPSCiState = do print err >> exitFailure Right modules -> let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit True, Nothing)] - in return (PSCiState [] imports modules foreigns [] []) + in return (mkPSCiState imports modules foreigns [] []) controlMonadSTasST :: ImportedModule controlMonadSTasST = (s "Control.Monad.ST", P.Implicit True, Just (s "ST")) From dc97d0c72cd3501b3357667d44ec0c247b2ca2fd Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 18 Dec 2015 22:28:15 +0100 Subject: [PATCH 0211/1580] Fix the name of handleDeclaration oops --- psci/PSCi.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 7ecc476d84..9df3ec2c93 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -258,10 +258,10 @@ make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms) allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms -- | --- Takes a value declaration and evaluates it with the current state. +-- Takes a value expression and evaluates it with the current state. -- -handleDeclaration :: P.Expr -> PSCI () -handleDeclaration val = do +handleExpression :: P.Expr -> PSCI () +handleExpression val = do st <- PSCI $ lift get let m = createTemporaryModule True st val let nodeArgs = psciNodeFlags st ++ [indexFile] @@ -530,7 +530,7 @@ getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do -- Performs an action for each meta-command given, and also for expressions. -- handleCommand :: Command -> PSCI () -handleCommand (Expression val) = handleDeclaration val +handleCommand (Expression val) = handleExpression val handleCommand ShowHelp = PSCI $ outputStrLn helpMessage handleCommand (Import im) = handleImport im handleCommand (Decls l) = handleDecls l From 500fb119d6765f39fe203804b9ca399713267603 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 18 Dec 2015 22:28:29 +0100 Subject: [PATCH 0212/1580] Remove a now-unnecessary line of code --- psci/PSCi.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 9df3ec2c93..dd293e105a 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -547,7 +547,6 @@ handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns) handleCommand ResetState = do - files <- psciImportedFilenames <$> PSCI (lift get) PSCI . lift . modify $ \st -> st { psciImportedModules = [] , psciLetBindings = [] From 50b4c6d735ddd56bb9e584b2351b8ac241defb4b Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 19 Dec 2015 00:04:21 +0100 Subject: [PATCH 0213/1580] Rename default 'main' in psci This allows people to use main inside psci without getting unexplained (from their point of view, at least) errors --- psci/PSCi.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 5f2de5f1e6..3c82c38127 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -202,7 +202,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval")) mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))) itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val - mainDecl = P.ValueDeclaration (P.Ident "main") P.Public [] $ Right mainValue + mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue decls = if exec then [itDecl, mainDecl] else [itDecl] in P.Module (P.internalModuleSourceSpan "") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing @@ -267,7 +267,7 @@ handleDeclaration val = do case e of Left errs -> printErrors errs Right _ -> do - psciIO $ writeFile indexFile "require('$PSCI').main();" + psciIO $ writeFile indexFile "require('$PSCI')['$main']();" process <- psciIO findNodeProcess result <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process case result of From 0c9617ac2a71037ea02cef4d1530e8f12213e6ec Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 19 Dec 2015 22:21:14 +0000 Subject: [PATCH 0214/1580] Remove special handling of primes from renamer --- src/Language/PureScript/Renamer.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index 9897badaa7..f497b92126 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -66,9 +66,7 @@ newScope x = do updateScope :: Ident -> Rename Ident updateScope ident = case ident of - Ident name - | name == C.__unused -> return ident - | last name == '\'' -> go ident $ Ident $ init name ++ "ʹ" -- '\x02b9' + Ident name | name == C.__unused -> return ident GenIdent name _ -> go ident $ Ident (fromMaybe "v" name) _ -> go ident ident where From 9fecb2ac264669049234963639bf609f73851dc2 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 21 Nov 2015 11:54:10 +0000 Subject: [PATCH 0215/1580] Revise reserved & built in names list --- src/Language/PureScript/CodeGen/JS/Common.hs | 266 ++++++++++++------- 1 file changed, 163 insertions(+), 103 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 64adaa043c..8c004b3dd9 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -9,6 +9,11 @@ import Data.List (intercalate) import Language.PureScript.Crash import Language.PureScript.Names +moduleNameToJs :: ModuleName -> String +moduleNameToJs (ModuleName pns) = + let name = intercalate "_" (runProperName `map` pns) + in if nameIsJsBuiltIn name then "$$" ++ name else name + -- | -- Convert an Ident into a valid Javascript identifier: -- @@ -19,8 +24,9 @@ import Language.PureScript.Names -- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value. -- identToJs :: Ident -> String -identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name -identToJs (Ident name) = concatMap identCharToString name +identToJs (Ident name) + | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name + | otherwise = concatMap identCharToString name identToJs (Op op) = concatMap identCharToString op identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" @@ -65,107 +71,161 @@ identCharToString c = '$' : show (ord c) -- nameIsJsReserved :: String -> Bool nameIsJsReserved name = - name `elem` [ "abstract" - , "arguments" - , "boolean" - , "break" - , "byte" - , "case" - , "catch" - , "char" - , "class" - , "const" - , "continue" - , "debugger" - , "default" - , "delete" - , "do" - , "double" - , "else" - , "enum" - , "eval" - , "export" - , "extends" - , "final" - , "finally" - , "float" - , "for" - , "function" - , "goto" - , "if" - , "implements" - , "import" - , "in" - , "instanceof" - , "int" - , "interface" - , "let" - , "long" - , "native" - , "new" - , "null" - , "package" - , "private" - , "protected" - , "public" - , "return" - , "short" - , "static" - , "super" - , "switch" - , "synchronized" - , "this" - , "throw" - , "throws" - , "transient" - , "try" - , "typeof" - , "var" - , "void" - , "volatile" - , "while" - , "with" - , "yield" ] || properNameIsJsReserved name - -moduleNameToJs :: ModuleName -> String -moduleNameToJs (ModuleName pns) = - let name = intercalate "_" (runProperName `map` pns) - in if properNameIsJsReserved name then "$$" ++ name else name + name `elem` jsAnyReserved -- | --- Checks whether a proper name is reserved in Javascript. +-- Checks whether a name matches a built-in value in Javascript. -- -properNameIsJsReserved :: String -> Bool -properNameIsJsReserved name = - name `elem` [ "Infinity" - , "NaN" - , "Object" - , "Function" - , "Boolean" - , "Error" - , "EvalError" - , "InternalError" - , "RangeError" - , "ReferenceError" - , "SyntaxError" - , "TypeError" - , "URIError" - , "Number" - , "Math" - , "Date" - , "String" - , "RegExp" - , "Array" - , "Int8Array" - , "Uint8Array" - , "Uint8ClampedArray" - , "Int16Array" - , "Uint16Array" - , "Int32Array" - , "Uint32Array" - , "Float32Array" - , "Float64Array" - , "ArrayBuffer" - , "DataView" - , "JSON" - , "Intl" ] +nameIsJsBuiltIn :: String -> Bool +nameIsJsBuiltIn name = + elem name + [ "arguments" + , "Array" + , "ArrayBuffer" + , "Boolean" + , "DataView" + , "Date" + , "decodeURI" + , "decodeURIComponent" + , "encodeURI" + , "encodeURIComponent" + , "Error" + , "escape" + , "eval" + , "EvalError" + , "Float32Array" + , "Float64Array" + , "Function" + , "Infinity" + , "Int16Array" + , "Int32Array" + , "Int8Array" + , "Intl" + , "isFinite" + , "isNaN" + , "JSON" + , "Map" + , "Math" + , "NaN" + , "Number" + , "Object" + , "parseFloat" + , "parseInt" + , "Promise" + , "Proxy" + , "RangeError" + , "ReferenceError" + , "Reflect" + , "RegExp" + , "Set" + , "SIMD" + , "String" + , "Symbol" + , "SyntaxError" + , "TypeError" + , "Uint16Array" + , "Uint32Array" + , "Uint8Array" + , "Uint8ClampedArray" + , "undefined" + , "unescape" + , "URIError" + , "WeakMap" + , "WeakSet" + ] + +jsAnyReserved :: [String] +jsAnyReserved = + concat + [ jsKeywords + , jsSometimesReserved + , jsFutureReserved + , jsFutureReservedStrict + , jsOldReserved + , jsLiterals + ] + +jsKeywords :: [String] +jsKeywords = + [ "break" + , "case" + , "catch" + , "class" + , "const" + , "continue" + , "debugger" + , "default" + , "delete" + , "do" + , "else" + , "export" + , "extends" + , "finally" + , "for" + , "function" + , "if" + , "import" + , "in" + , "instanceof" + , "new" + , "return" + , "super" + , "switch" + , "this" + , "throw" + , "try" + , "typeof" + , "var" + , "void" + , "while" + , "with" + ] + +jsSometimesReserved :: [String] +jsSometimesReserved = + [ "await" + , "let" + , "static" + , "yield" + ] + +jsFutureReserved :: [String] +jsFutureReserved = + [ "enum" ] + +jsFutureReservedStrict :: [String] +jsFutureReservedStrict = + [ "implements" + , "interface" + , "package" + , "private" + , "protected" + , "public" + ] + +jsOldReserved :: [String] +jsOldReserved = + [ "abstract" + , "boolean" + , "byte" + , "char" + , "double" + , "final" + , "float" + , "goto" + , "int" + , "long" + , "native" + , "short" + , "synchronized" + , "throws" + , "transient" + , "volatile" + ] + +jsLiterals :: [String] +jsLiterals = + [ "null" + , "true" + , "false" + ] From 6ee91351c0b99aff91e02799adf0f1e0d1405986 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 19 Dec 2015 17:22:01 -0800 Subject: [PATCH 0216/1580] Fix #1723, revert parser change. --- src/Language/PureScript/Parser/Declarations.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index c0f5d530f2..1c86fdafc3 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -324,8 +324,8 @@ parseIdentifierAndValue = return (name, b) <|> (,) <$> (C.indented *> stringLiteral) <*> rest where - rest = C.indented *> colon *> C.indented *> val - val = (underscore *> pure Nothing) <|> (Just <$> parseValue) + rest = C.indented *> colon *> C.indented *> val + val = P.try (Just <$> parseValue) <|> (underscore *> pure Nothing) parseAbs :: TokenParser Expr parseAbs = do From 33851dcb718979c554177da641e186dd26dcf0fe Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 19 Dec 2015 17:33:15 -0800 Subject: [PATCH 0217/1580] Fix #1732, calculate type map separately for each error --- psc/JSON.hs | 2 +- src/Language/PureScript/Errors.hs | 32 ++++++++++++++----------------- 2 files changed, 15 insertions(+), 19 deletions(-) diff --git a/psc/JSON.hs b/psc/JSON.hs index 09a364f144..9239be550c 100644 --- a/psc/JSON.hs +++ b/psc/JSON.hs @@ -53,7 +53,7 @@ toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErro toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError toJSONError verbose level e = JSONError (toErrorPosition <$> sspan) - (P.renderBox (P.prettyPrintSingleError' verbose level (P.stripModuleAndSpan e))) + (P.renderBox (P.prettyPrintSingleError verbose level (P.stripModuleAndSpan e))) (P.errorCode e) (P.spanName <$> sspan) (P.runModuleName <$> P.errorModule e) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index e4d2a01787..26d799e78a 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -412,14 +412,11 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts gHint other = pure other -prettyPrintSingleError' :: Bool -> Level -> ErrorMessage ->Box.Box -prettyPrintSingleError' full level = flip evalState defaultUnknownMap . prettyPrintSingleError full level - -- | -- Pretty print a single error, simplifying if necessary -- -prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> State TypeMap Box.Box -prettyPrintSingleError full level e = do +prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> Box.Box +prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) um <- get return (prettyPrintErrorMessage um em) @@ -1061,22 +1058,21 @@ prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox fu -- | Pretty print warnings as a Box prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box -prettyPrintMultipleWarningsBox full = flip evalState defaultUnknownMap . prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full +prettyPrintMultipleWarningsBox full = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full -- | Pretty print errors as a Box prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box -prettyPrintMultipleErrorsBox full = flip evalState defaultUnknownMap . prettyPrintMultipleErrorsWith Error "Error found:" "Error" full - -prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State TypeMap Box.Box -prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do - result <- prettyPrintSingleError full level e - return $ - Box.vcat Box.left [ Box.text intro - , result - ] -prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do - result <- forM es $ prettyPrintSingleError full level - return $ Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result +prettyPrintMultipleErrorsBox full = prettyPrintMultipleErrorsWith Error "Error found:" "Error" full + +prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> Box.Box +prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = + let result = prettyPrintSingleError full level e + in Box.vcat Box.left [ Box.text intro + , result + ] +prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = + let result = map (prettyPrintSingleError full level) es + in Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result where withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":") , Box.moveRight 2 err From 9d0a9eaf906b9f3fec0764b3e65438a2136de94f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 19 Dec 2015 17:44:34 -0800 Subject: [PATCH 0218/1580] Fix #1742, revert import (..) change --- psci/PSCi.hs | 3 +-- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Parser/Declarations.hs | 4 +--- 3 files changed, 3 insertions(+), 6 deletions(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 0ab737c021..aef24f33b5 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -317,8 +317,7 @@ handleShowImportedModules = do Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn' Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType - showDeclType (P.Implicit True) = " (..)" - showDeclType (P.Implicit False) = "" + showDeclType (P.Implicit _) = "" showDeclType (P.Explicit refs) = refsList refs showDeclType (P.Hiding refs) = " hiding " ++ refsList refs refsList refs = " (" ++ commaList (map showRef refs) ++ ")" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 82a32832f6..eb86b1cac0 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -131,7 +131,7 @@ findDuplicateRefs refs = data ImportDeclarationType -- | -- An import with no explicit list: `import M`. The boolean signifies whether - -- the import was imported with `(..)` or not. Without `(..)` a warning is + -- the import was generated by the compiler. If not, a warning is -- raised for each member implicitly imported. -- = Implicit Bool diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index c0f5d530f2..6844175485 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -151,9 +151,7 @@ parseImportDeclaration' = do qName <- qualifiedName return (moduleName', declType, Just qName, True) qualifyingList expectedType = do - declType <- P.optionMaybe - $ P.try (expectedType <$> (indented *> parens (commaSep parseDeclarationRef))) - <|> (const (Implicit True) <$> (indented *> parens (symbol' ".."))) + declType <- P.optionMaybe (expectedType <$> (indented *> parens (commaSep parseDeclarationRef))) return $ fromMaybe (Implicit False) declType parseDeclarationRef :: TokenParser DeclarationRef From 3c5c1cb505a69174fa09d208216b3f68aa96c4f7 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 21 Dec 2015 00:18:48 +0000 Subject: [PATCH 0219/1580] Remove further remnants of `import M (..)` --- psci/Completion.hs | 2 +- psci/PSCi.hs | 2 +- psci/tests/Main.hs | 4 ++-- src/Language/PureScript/AST/Declarations.hs | 10 ++++------ src/Language/PureScript/Errors.hs | 3 +-- src/Language/PureScript/Linter/Imports.hs | 3 +-- src/Language/PureScript/Parser/Declarations.hs | 2 +- src/Language/PureScript/Sugar/Names/Imports.hs | 6 +++--- 8 files changed, 14 insertions(+), 18 deletions(-) diff --git a/psci/Completion.hs b/psci/Completion.hs index 5de762fa6f..8a52463911 100644 --- a/psci/Completion.hs +++ b/psci/Completion.hs @@ -171,7 +171,7 @@ getAllQualifications sho m (declName, decl) = do qualificationsUsing (_, importType, asQ') = let q = qualifyWith asQ' in case importType of - P.Implicit _ -> [q] + P.Implicit -> [q] P.Explicit refs -> [q | referencedBy refs] P.Hiding refs -> [q | not $ referencedBy refs] diff --git a/psci/PSCi.hs b/psci/PSCi.hs index aef24f33b5..47e72f001b 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -317,7 +317,7 @@ handleShowImportedModules = do Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn' Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType - showDeclType (P.Implicit _) = "" + showDeclType P.Implicit = "" showDeclType (P.Explicit refs) = refsList refs showDeclType (P.Hiding refs) = " hiding " ++ refsList refs refsList refs = " (" ++ commaList (map showRef refs) ++ ")" diff --git a/psci/tests/Main.hs b/psci/tests/Main.hs index 57a9ecc171..af24736487 100644 --- a/psci/tests/Main.hs +++ b/psci/tests/Main.hs @@ -141,11 +141,11 @@ getPSCiState = do Left err -> print err >> exitFailure Right modules -> - let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit True, Nothing)] + let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)] in return (mkPSCiState imports modules foreigns [] []) controlMonadSTasST :: ImportedModule -controlMonadSTasST = (s "Control.Monad.ST", P.Implicit True, Just (s "ST")) +controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST")) where s = P.moduleNameFromString diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index eb86b1cac0..c9056537a8 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -47,7 +47,7 @@ getModuleName (Module _ _ name _ _) = name addDefaultImport :: ModuleName -> Module -> Module addDefaultImport toImport m@(Module ss coms mn decls exps) = if isExistingImport `any` decls || mn == toImport then m - else Module ss coms mn (ImportDeclaration toImport (Implicit True) Nothing False : decls) exps + else Module ss coms mn (ImportDeclaration toImport Implicit Nothing False : decls) exps where isExistingImport (ImportDeclaration mn' _ _ _) | mn' == toImport = True isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d @@ -130,11 +130,9 @@ findDuplicateRefs refs = -- data ImportDeclarationType -- | - -- An import with no explicit list: `import M`. The boolean signifies whether - -- the import was generated by the compiler. If not, a warning is - -- raised for each member implicitly imported. + -- An import with no explicit list: `import M`. -- - = Implicit Bool + = Implicit -- | -- An import with an explicit list of references to import: `import M (foo)` -- @@ -146,7 +144,7 @@ data ImportDeclarationType deriving (Eq, Show, Read, D.Data, D.Typeable) isImplicit :: ImportDeclarationType -> Bool -isImplicit (Implicit _) = True +isImplicit Implicit = True isImplicit _ = False -- | diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index e4d2a01787..f4e7ef7039 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1014,8 +1014,7 @@ prettyPrintSingleError full level e = do prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String prettyPrintImport mn idt qual = let i = case idt of - Implicit True -> runModuleName mn ++ " (..)" - Implicit False -> runModuleName mn + Implicit -> runModuleName mn Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")" in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 1fc0b1fd99..2c1af3288a 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -62,8 +62,7 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names usedDctors = mapMaybe (matchDctor qualifierName) names in case declType of - Implicit _ | null usedNames -> tell $ errorMessage $ UnusedImport mni - Implicit False -> + Implicit -> let classRefs = TypeClassRef <$> mapMaybe getClassName names valueRefs = ValueRef <$> mapMaybe getIdentName names types = mapMaybe getTypeName names diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 6844175485..e456876326 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -152,7 +152,7 @@ parseImportDeclaration' = do return (moduleName', declType, Just qName, True) qualifyingList expectedType = do declType <- P.optionMaybe (expectedType <$> (indented *> parens (commaSep parseDeclarationRef))) - return $ fromMaybe (Implicit False) declType + return $ fromMaybe Implicit declType parseDeclarationRef :: TokenParser DeclarationRef parseDeclarationRef = diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 18f84f3272..a5ce3edd1a 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -98,7 +98,7 @@ resolveImports env (Module ss coms currentModule decls exps) = return () - let scope = M.insert currentModule [(Nothing, Implicit True, Nothing)] imports + let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope) return (Module ss coms currentModule decls' exps, resolved) @@ -138,7 +138,7 @@ resolveImports env (Module ss coms currentModule decls exps) = updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do modExports <- getExports env mn typ' <- case typ of - Implicit b -> return $ Implicit b + Implicit -> return Implicit Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs return $ ImportDeclaration mn typ' qual isOldSyntax @@ -191,7 +191,7 @@ resolveImport importModule exps imps impQual = resolveByType where resolveByType :: ImportDeclarationType -> m Imports - resolveByType (Implicit _) = importAll importExplicit + resolveByType Implicit = importAll importExplicit resolveByType (Explicit refs) = checkRefs False refs >> foldM importExplicit imps refs resolveByType (Hiding refs) = do imps' <- checkRefs True refs >> importAll (importNonHidden refs) From 1b52c24f186f7aaf60b7acc3a32a2068a5f6b69e Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 19 Dec 2015 22:42:02 +0000 Subject: [PATCH 0220/1580] Allow use of bottom integer --- examples/failing/IntOutOfRange.purs | 2 +- examples/passing/NegativeIntInRange.purs | 8 +++++ src/Language/PureScript/CodeGen/JS.hs | 43 +++++++++++++++++------- 3 files changed, 39 insertions(+), 14 deletions(-) create mode 100644 examples/passing/NegativeIntInRange.purs diff --git a/examples/failing/IntOutOfRange.purs b/examples/failing/IntOutOfRange.purs index 4ca27433ba..1d22217917 100644 --- a/examples/failing/IntOutOfRange.purs +++ b/examples/failing/IntOutOfRange.purs @@ -3,4 +3,4 @@ module Main where n :: Int -n = 35028715023 +n = 2147483648 diff --git a/examples/passing/NegativeIntInRange.purs b/examples/passing/NegativeIntInRange.purs new file mode 100644 index 0000000000..734d4a167b --- /dev/null +++ b/examples/passing/NegativeIntInRange.purs @@ -0,0 +1,8 @@ +module Main where + +import Prelude + +n :: Int +n = -2147483648 + +main = Control.Monad.Eff.Console.log "Done" diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 96392baa9f..e6491e1261 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -10,7 +10,6 @@ module Language.PureScript.CodeGen.JS ( module AST , module Common , moduleToJs - , mainCall ) where import Prelude () @@ -19,10 +18,11 @@ import Prelude.Compat import Data.List ((\\), delete, intersect) import Data.Maybe (isNothing, fromMaybe) import qualified Data.Map as M -import qualified Data.Traversable as T (traverse) +import qualified Data.Foldable as F +import qualified Data.Traversable as T import Control.Arrow ((&&&)) -import Control.Monad (replicateM, forM) +import Control.Monad (replicateM, forM, void) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class @@ -45,8 +45,12 @@ import System.FilePath.Posix (()) -- Generate code in the simplified Javascript intermediate representation for all declarations in a -- module. -- -moduleToJs :: forall m. (Applicative m, Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) - => Module Ann -> Maybe JS -> m [JS] +moduleToJs + :: forall m + . (Applicative m, Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) + => Module Ann + -> Maybe JS + -> m [JS] moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls @@ -55,6 +59,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = let decls' = renameModules mnLookup decls jsDecls <- mapM bindToJs decls' optimized <- T.traverse (T.traverse optimize) jsDecls + F.traverse_ (F.traverse_ checkIntegers) optimized comments <- not <$> asks optionsNoComments let strict = JSStringLiteral "use strict" let header = if comments && not (null coms) then JSComment coms strict else strict @@ -256,12 +261,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) [] literalToValueJS :: Literal (Expr Ann) -> m JS - literalToValueJS (NumericLiteral (Left i)) = - let minInt = -2147483648 - maxInt = 2147483647 - in if i < minInt || i > maxInt - then throwError . errorMessage $ IntOutOfRange i "JavaScript" minInt maxInt - else return $ JSNumericLiteral (Left i) + literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral (Left i) literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral (Right n) literalToValueJS (StringLiteral s) = return $ JSStringLiteral s literalToValueJS (CharLiteral c) = return $ JSStringLiteral [c] @@ -414,5 +414,22 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = js <- binderToJs elVar done'' binder return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js) -mainCall :: ModuleName -> String -> JS -mainCall mmi ns = JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar ns))) [] + -- Check that all integers fall within the valid int range for JavaScript. + checkIntegers :: JS -> m () + checkIntegers = void . everywhereOnJSTopDownM go + where + go :: JS -> m JS + go (JSUnary Negate (JSNumericLiteral (Left i))) = + -- Move the negation inside the literal; since this is a top-down + -- traversal doing this replacement will stop the next case from raising + -- the error when attempting to use -2147483648, as if left unrewritten + -- the value is `JSUnary Negate (JSNumericLiteral (Left 2147483648))`, and + -- 2147483648 is larger than the maximum allowed int. + return $ JSNumericLiteral (Left (-i)) + go js@(JSNumericLiteral (Left i)) = + let minInt = -2147483648 + maxInt = 2147483647 + in if i < minInt || i > maxInt + then throwError . errorMessage $ IntOutOfRange i "JavaScript" minInt maxInt + else return js + go other = return other From 293f0020c06746975e2a43dd372e9a472907b124 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 21 Dec 2015 01:43:38 +0000 Subject: [PATCH 0221/1580] Don't warn about implicit qualified imports --- src/Language/PureScript/Linter/Imports.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 2c1af3288a..98f9d05a4b 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -7,7 +7,7 @@ import Prelude () import Prelude.Compat import qualified Data.Map as M -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, isNothing) import Data.List ((\\), find, intersect, nub) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class @@ -62,7 +62,7 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names usedDctors = mapMaybe (matchDctor qualifierName) names in case declType of - Implicit -> + Implicit | isNothing qualifierName -> let classRefs = TypeClassRef <$> mapMaybe getClassName names valueRefs = ValueRef <$> mapMaybe getIdentName names types = mapMaybe getTypeName names From 3d84af651fbc59b04ba595c6a872b637ef23bd0f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 20 Dec 2015 17:46:48 -0800 Subject: [PATCH 0222/1580] Remove meet judgment, #1719 --- src/Language/PureScript/TypeChecker/Types.hs | 27 +++----------------- 1 file changed, 4 insertions(+), 23 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index d9671cae76..249b153d75 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -280,10 +280,10 @@ infer' (Case vals binders) = do return $ TypedValue True (Case vals' binders') ret infer' (IfThenElse cond th el) = do cond' <- check cond tyBoolean - v2@(TypedValue _ _ t2) <- infer th - v3@(TypedValue _ _ t3) <- infer el - (v2', v3', t) <- meet v2 v3 t2 t3 - return $ TypedValue True (IfThenElse cond' v2' v3') t + th'@(TypedValue _ _ thTy) <- infer th + el'@(TypedValue _ _ elTy) <- infer el + unifyTypes thTy elTy + return $ TypedValue True (IfThenElse cond' th' el') thTy infer' (Let ds val) = do (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer return $ TypedValue True (Let ds' val') valTy @@ -706,25 +706,6 @@ checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ = return (fnTy, App fn dict) checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg --- | Compute the meet of two types, i.e. the most general type which both types subsume. --- TODO: is this really needed? -meet :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) => - Expr -> - Expr -> - Type -> - Type -> - m (Expr, Expr, Type) -meet e1 e2 (ForAll ident t1 _) t2 = do - t1' <- replaceVarWithUnknown ident t1 - meet e1 e2 t1' t2 -meet e1 e2 t1 (ForAll ident t2 _) = do - t2' <- replaceVarWithUnknown ident t2 - meet e1 e2 t1 t2' -meet e1 e2 t1 t2 = do - unifyTypes t1 t2 - return (e1, e2, t1) - -- | -- Ensure a set of property names and value does not contain duplicate labels -- From ffd3594085b756cc9eeb022f1e24792c8a63b308 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 21 Dec 2015 12:39:33 +0000 Subject: [PATCH 0223/1580] Remove bind import linter special case --- src/Language/PureScript/Linter/Imports.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 98f9d05a4b..4774585dff 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -58,7 +58,7 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $ forM_ decls $ \(ss, declType, qualifierName) -> censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $ - let names = nub $ sugarNames mni ++ M.findWithDefault [] mni usedImps + let names = nub $ M.findWithDefault [] mni usedImps usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names usedDctors = mapMaybe (matchDctor qualifierName) names in case declType of @@ -95,10 +95,6 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do _ -> return () where - sugarNames :: ModuleName -> [ Name ] - sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ] - sugarNames _ = [] - reconstructTypeRefs :: ModuleName -> [ProperName] -> M.Map ProperName [ProperName] reconstructTypeRefs mni = foldr accumDctors M.empty where From 640418025a7b3cfeb673706da9b57da908e7bc32 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 21 Dec 2015 03:51:55 +0000 Subject: [PATCH 0224/1580] Allow operator aliases for imported values --- examples/passing/OperatorAliasElsewhere.purs | 14 ++++++++++ src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/CoreFn/Desugar.hs | 4 +-- src/Language/PureScript/Docs/AsMarkdown.hs | 17 ++++++------ src/Language/PureScript/Docs/Convert.hs | 14 +++++----- src/Language/PureScript/Docs/Render.hs | 11 ++++++++ .../PureScript/Docs/RenderedCode/Render.hs | 9 +++++-- .../PureScript/Docs/RenderedCode/Types.hs | 6 +++++ src/Language/PureScript/Docs/Types.hs | 26 ++++++++++++++----- src/Language/PureScript/Externs.hs | 2 +- src/Language/PureScript/ModuleDependencies.hs | 1 + src/Language/PureScript/Names.hs | 17 +----------- .../PureScript/Parser/Declarations.hs | 2 +- src/Language/PureScript/Sugar/Names.hs | 2 ++ src/Language/PureScript/Sugar/Operators.hs | 18 ++++++------- src/Language/PureScript/TypeChecker.hs | 5 ++-- 16 files changed, 94 insertions(+), 56 deletions(-) create mode 100644 examples/passing/OperatorAliasElsewhere.purs diff --git a/examples/passing/OperatorAliasElsewhere.purs b/examples/passing/OperatorAliasElsewhere.purs new file mode 100644 index 0000000000..952fa83093 --- /dev/null +++ b/examples/passing/OperatorAliasElsewhere.purs @@ -0,0 +1,14 @@ +module Def where + +what :: forall a b. a -> b -> a +what a _ = a + +module Main where + +import Prelude +import Def (what) +import Control.Monad.Eff.Console + +infixl 4 what as ?! + +main = log $ "Done" ?! true diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index c9056537a8..8d4fbf7ea1 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -186,7 +186,7 @@ data Declaration -- | -- A fixity declaration (fixity data, operator name, value the operator is an alias for) -- - | FixityDeclaration Fixity String (Maybe Ident) + | FixityDeclaration Fixity String (Maybe (Qualified Ident)) -- | -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name) -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index e6ce2a8736..f48ac7cabd 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -55,8 +55,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) = [NonRec name (exprToCoreFn ss com Nothing e)] declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) = - let qname = Qualified (Just mn) alias - in [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta qname) (Qualified Nothing alias))] + [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta alias) alias)] declToCoreFn ss _ (A.BindingGroupDeclaration ds) = [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds] declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) = @@ -197,6 +196,7 @@ findQualModules decls = where fqDecls :: A.Declaration -> [ModuleName] fqDecls (A.TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn] + fqDecls (A.FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn] fqDecls _ = [] fqValues :: A.Expr -> [ModuleName] diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 94959a6665..f843b7049d 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -31,21 +31,22 @@ moduleAsMarkdown Module{..} = do headerLevel 2 $ "Module " ++ modName spacer for_ modComments tell' - mapM_ declAsMarkdown modDeclarations + mapM_ (declAsMarkdown modName) modDeclarations spacer -declAsMarkdown :: Declaration -> Docs -declAsMarkdown decl@Declaration{..} = do +declAsMarkdown :: String -> Declaration -> Docs +declAsMarkdown mn decl@Declaration{..} = do + let options = defaultRenderTypeOptions { currentModule = Just (P.moduleNameFromString mn) } headerLevel 4 (ticks declTitle) spacer let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren fencedBlock $ do - tell' (codeToString $ Render.renderDeclaration decl) + tell' (codeToString $ Render.renderDeclarationWithOptions options decl) zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children spacer - for_ declFixity (\(fixity, alias) -> fixityAsMarkdown fixity alias >> spacer) + for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer) for_ declComments tell' @@ -68,11 +69,9 @@ codeToString = outputWith elemAsMarkdown elemAsMarkdown (Keyword x) = x elemAsMarkdown Space = " " -fixityAsMarkdown :: P.Fixity -> Maybe String -> Docs -fixityAsMarkdown (P.Fixity associativity precedence) alias = - -- TODO: link alias name to member +fixityAsMarkdown :: P.Fixity -> Docs +fixityAsMarkdown (P.Fixity associativity precedence) = tell' $ concat [ "_" - , maybe "" (\i -> "alias for " ++ i ++ " - ") alias , associativityStr , " / precedence " , show precedence diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 03ba431aae..bd973bab12 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -71,7 +71,7 @@ type IntermediateDeclaration -- with their associativity and precedence. data DeclarationAugment = AugmentChild ChildDeclaration - | AugmentFixity P.Fixity (Maybe P.Ident) + | AugmentFixity P.Fixity -- | Augment top-level declarations; the second pass. See the comments under -- the type synonym IntermediateDeclaration for more information. @@ -89,8 +89,8 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) = case a of AugmentChild child -> d { declChildren = declChildren d ++ [child] } - AugmentFixity fixity alias -> - d { declFixity = Just (fixity, P.runIdent <$> alias) } + AugmentFixity fixity -> + d { declFixity = Just fixity } -- | Add the default operator fixity for operators which do not have associated -- fixity declarations. @@ -100,7 +100,7 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) = addDefaultFixity :: Declaration -> Declaration addDefaultFixity decl@Declaration{..} | isOp declTitle && isNothing declFixity = - decl { declFixity = Just (defaultFixity, Nothing) } + decl { declFixity = Just defaultFixity } | otherwise = decl where @@ -173,8 +173,10 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) classApp = foldl P.TypeApp (P.TypeConstructor className) tys -convertDeclaration (P.FixityDeclaration fixity _ alias) title = - Just (Left ([title], AugmentFixity fixity alias)) +convertDeclaration (P.FixityDeclaration fixity _ Nothing) title = + Just (Left ([title], AugmentFixity fixity)) +convertDeclaration (P.FixityDeclaration fixity _ (Just alias)) title = + Just $ Right $ (mkDeclaration title (AliasDeclaration alias fixity)) { declFixity = Just fixity } convertDeclaration (P.PositionedDeclaration srcSpan com d') title = fmap (addComments . addSourceSpan) (convertDeclaration d' title) where diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 1177391e2b..6d48d2f50a 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -61,8 +61,19 @@ renderDeclarationWithOptions opts Declaration{..} = isTypeClassMember (ChildTypeClassMember _) = True isTypeClassMember _ = False + AliasDeclaration for (P.Fixity associativity precedence) -> + [ keywordFixity associativity + , syntax $ show precedence + , ident $ P.showQualified P.runIdent $ dequalifyCurrentModule for + , keyword "as" + , ident . tail . init $ declTitle + ] + where renderType' = renderTypeWithOptions opts + dequalifyCurrentModule (P.Qualified mn a) + | mn == currentModule opts = P.Qualified Nothing a + | otherwise = P.Qualified mn a renderChildDeclaration :: ChildDeclaration -> RenderedCode renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index 1d6766e582..432738ed73 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -9,7 +9,7 @@ module Language.PureScript.Docs.RenderedCode.Render ( defaultRenderTypeOptions, renderTypeWithOptions ) where - + import Prelude () import Prelude.Compat @@ -172,10 +172,15 @@ renderType = renderTypeWithOptions defaultRenderTypeOptions data RenderTypeOptions = RenderTypeOptions { prettyPrintObjects :: Bool + , currentModule :: Maybe ModuleName } defaultRenderTypeOptions :: RenderTypeOptions -defaultRenderTypeOptions = RenderTypeOptions { prettyPrintObjects = True } +defaultRenderTypeOptions = + RenderTypeOptions + { prettyPrintObjects = True + , currentModule = Nothing + } renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode renderTypeWithOptions opts = diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 8ae8760e65..307663a594 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -28,6 +28,7 @@ module Language.PureScript.Docs.RenderedCode.Types , keywordClass , keywordInstance , keywordWhere + , keywordFixity ) where import Prelude () @@ -189,3 +190,8 @@ keywordInstance = keyword "instance" keywordWhere :: RenderedCode keywordWhere = keyword "where" + +keywordFixity :: P.Associativity -> RenderedCode +keywordFixity P.Infixl = keyword "infixl" +keywordFixity P.Infixr = keyword "infixr" +keywordFixity P.Infix = keyword "infix" diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 1d81b42845..3d2604dc37 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -84,7 +84,7 @@ data Declaration = Declaration , declComments :: Maybe String , declSourceSpan :: Maybe P.SourceSpan , declChildren :: [ChildDeclaration] - , declFixity :: Maybe (P.Fixity, Maybe String) + , declFixity :: Maybe P.Fixity -- TODO: remove in 0.9 , declInfo :: DeclarationInfo } deriving (Show, Eq, Ord) @@ -126,6 +126,12 @@ data DeclarationInfo -- members are represented as child declarations. -- | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint] + + -- | + -- An operator alias declaration, with the member the alias is for and the + -- operator's fixity. + -- + | AliasDeclaration (P.Qualified P.Ident) P.Fixity deriving (Show, Eq, Ord) declInfoToString :: DeclarationInfo -> String @@ -134,6 +140,7 @@ declInfoToString (DataDeclaration _ _) = "data" declInfoToString (ExternDataDeclaration _) = "externData" declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym" declInfoToString (TypeClassDeclaration _ _) = "typeClass" +declInfoToString (AliasDeclaration _ _) = "alias" data ChildDeclaration = ChildDeclaration { cdeclTitle :: String @@ -307,12 +314,10 @@ asDeclaration = <*> key "fixity" (perhaps asFixity) <*> key "info" asDeclarationInfo -asFixity :: Parse PackageError (P.Fixity, Maybe String) -asFixity = do - fixity <- P.Fixity <$> key "associativity" asAssociativity - <*> key "precedence" asIntegral - alias <- keyMay "alias" asString - return (fixity, alias) +asFixity :: Parse PackageError P.Fixity +asFixity = + P.Fixity <$> key "associativity" asAssociativity + <*> key "precedence" asIntegral parseAssociativity :: String -> Maybe P.Associativity parseAssociativity str = case str of @@ -341,6 +346,9 @@ asDeclarationInfo = do "typeClass" -> TypeClassDeclaration <$> key "arguments" asTypeArguments <*> key "superclasses" (eachInArray asConstraint) + "alias" -> + AliasDeclaration <$> key "for" asQualifiedIdent + <*> key "fixity" asFixity other -> throwCustomError (InvalidDeclarationType other) @@ -394,6 +402,9 @@ asConstraint = (,) <$> nth 0 asQualifiedProperName asQualifiedProperName :: Parse e (P.Qualified P.ProperName) asQualifiedProperName = fromAesonParser +asQualifiedIdent :: Parse e (P.Qualified P.Ident) +asQualifiedIdent = fromAesonParser + asBookmarks :: Parse BowerError [Bookmark] asBookmarks = eachInArray asBookmark @@ -478,6 +489,7 @@ instance A.ToJSON DeclarationInfo where ExternDataDeclaration kind -> ["kind" .= kind] TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty] TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super] + AliasDeclaration for fixity -> ["for" .= for, "fixity" .= fixity] instance A.ToJSON ChildDeclarationInfo where toJSON info = A.object $ "declType" .= childDeclInfoToString info : props diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 16006f13db..a8cb962fc5 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -73,7 +73,7 @@ data ExternsFixity = ExternsFixity -- | The operator symbol , efOperator :: String -- | The value the operator is an alias for - , efAlias :: Maybe Ident + , efAlias :: Maybe (Qualified Ident) } deriving (Show, Read) -- | A type or value declaration appearing in an externs file diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index b88417853a..8b08793b4a 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -58,6 +58,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues ( where forDecls :: Declaration -> [ModuleName] forDecls (ImportDeclaration mn _ _ _) = [mn] + forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn] forDecls _ = [] forValues :: Expr -> [ModuleName] diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index e3a8da7f24..eca3262428 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -13,10 +13,7 @@ import Control.Monad.Supply.Class import Data.List import Data.Data -import Data.List.Split (splitOn) import Data.Aeson.TH -import qualified Data.Aeson as A -import qualified Data.Text as T -- | -- Names for value identifiers @@ -81,19 +78,6 @@ showQualified :: (a -> String) -> Qualified a -> String showQualified f (Qualified Nothing a) = f a showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a -instance (a ~ ProperName) => A.ToJSON (Qualified a) where - toJSON = A.toJSON . showQualified runProperName - -instance (a ~ ProperName) => A.FromJSON (Qualified a) where - parseJSON = - A.withText "Qualified ProperName" $ \str -> - return $ case reverse (splitOn "." (T.unpack str)) of - [name] -> Qualified Nothing (ProperName name) - (name:rest) -> Qualified (Just (reconstructModuleName rest)) (ProperName name) - _ -> Qualified Nothing (ProperName "") - where - reconstructModuleName = moduleNameFromString . intercalate "." . reverse - -- | -- Provide a default module name, if a name is unqualified -- @@ -118,6 +102,7 @@ isUnqualified :: Qualified a -> Bool isUnqualified (Qualified Nothing _) = True isUnqualified _ = False +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ProperName) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 0adfff98d1..33bbcfbb77 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -122,7 +122,7 @@ parseFixityDeclaration :: TokenParser Declaration parseFixityDeclaration = do fixity <- parseFixity indented - alias <- P.optionMaybe $ (Ident <$> identifier) <* reserved "as" + alias <- P.optionMaybe $ parseQualified (Ident <$> identifier) <* reserved "as" name <- symbol return $ FixityDeclaration fixity name alias diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index b6a77fe012..ba0a26725b 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -141,6 +141,8 @@ renameInModule env imports (Module ss coms mn decls exps) = (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty) updateDecl (pos, bound) (ExternDeclaration name ty) = (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty) + updateDecl (pos, bound) (FixityDeclaration fx name alias) = + (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (`updateValueName` pos) alias) updateDecl s d = return (s, d) updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr) diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index b4828c83a6..4d401facf2 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} -- | -- This module implements the desugaring pass which reapplies binary operators based @@ -55,9 +56,8 @@ rebracket externs ms = do where - makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe Ident) -> Maybe (Qualified Ident, Qualified Ident) - makeLookupEntry (qname@(Qualified qual _), _, _, Just alias) = Just (qname, Qualified qual alias) - makeLookupEntry _ = Nothing + makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident)) -> Maybe (Qualified Ident, Qualified Ident) + makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias renameAliasedOperators :: M.Map (Qualified Ident) (Qualified Ident) -> Module -> Module renameAliasedOperators aliased (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts @@ -87,16 +87,16 @@ removeParens = go (Parens val) = val go val = val -externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)] +externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))] externsFixities ExternsFile{..} = - [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias) - | ExternsFixity assoc prec op alias <- efFixities - ] + [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias) + | ExternsFixity assoc prec op alias <- efFixities + ] -collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)] +collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))] collectFixities (Module _ _ moduleName ds _) = concatMap collect ds where - collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe Ident)] + collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))] collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) = [(Qualified (Just moduleName) (Op name), pos, fixity, alias)] collect FixityDeclaration{} = internalError "Fixity without srcpos info" diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 3c7b24b40b..607b1b498a 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -281,7 +281,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds checkFixities :: Declaration -> m () checkFixities (FixityDeclaration _ name (Just alias)) = do - ty <- lookupVariable moduleName (Qualified (Just moduleName) alias) + ty <- lookupVariable moduleName alias addValue moduleName (Op name) ty Public checkFixities (FixityDeclaration _ name _) = do env <- getEnv @@ -433,6 +433,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint where getAlias :: Declaration -> Maybe Ident getAlias (PositionedDeclaration _ _ d) = getAlias d - getAlias (FixityDeclaration _ name' alias) | name == name' = alias + getAlias (FixityDeclaration _ name' (Just (Qualified (Just mn') alias))) + | mn == mn' && name == name' = Just alias getAlias _ = Nothing checkNonAliasesAreExported _ = return () From 8c7cc69754249fd1d53204fb126fb3744a4d1975 Mon Sep 17 00:00:00 2001 From: "(cdep)illabout" Date: Sat, 26 Dec 2015 00:56:52 +0900 Subject: [PATCH 0225/1580] Change Logger datatype into a newtype. This changes Control.Monad.Logger.Logger from a datatype to a newtype. Since newtypes disappear at runtime, this should produce an (extremely) minor speedup. --- src/Control/Monad/Logger.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs index 069b78194e..f8e8e7ca1f 100644 --- a/src/Control/Monad/Logger.hs +++ b/src/Control/Monad/Logger.hs @@ -30,7 +30,7 @@ import Control.Monad.Base (MonadBase(..)) import Control.Monad.Trans.Control (MonadBaseControl(..)) -- | A replacement for WriterT IO which uses mutable references. -data Logger w a = Logger { runLogger :: IORef w -> IO a } +newtype Logger w a = Logger { runLogger :: IORef w -> IO a } -- | Run a Logger computation, starting with an empty log. runLogger' :: (Monoid w) => Logger w a -> IO (a, w) From 86acebbe3a0fb7cbc203d2ce45b223a228a78168 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 25 Dec 2015 03:21:36 +0000 Subject: [PATCH 0226/1580] Fix warning about values missing from virtual modules --- examples/failing/1733.purs | 13 +++++++++++++ src/Language/PureScript/Sugar/Names.hs | 11 ++++++++--- src/Language/PureScript/Sugar/Names/Env.hs | 12 +++++++++--- src/Language/PureScript/Sugar/Names/Imports.hs | 6 +++++- 4 files changed, 35 insertions(+), 7 deletions(-) create mode 100644 examples/failing/1733.purs diff --git a/examples/failing/1733.purs b/examples/failing/1733.purs new file mode 100644 index 0000000000..8dfbf18102 --- /dev/null +++ b/examples/failing/1733.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith UnknownValue + +module Main where + +import Thingy as Thing + +main = Thing.doesntExist "hi" + +module Thingy where + +foo :: Int +foo = 1 + diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index ba0a26725b..cc331b09a1 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -16,6 +16,7 @@ import Control.Monad.Writer (MonadWriter(..), censor) import Control.Monad.State.Lazy import qualified Data.Map as M +import qualified Data.Set as S import Language.PureScript.Crash import Language.PureScript.AST @@ -257,17 +258,21 @@ renameInModule env imports (Module ss coms mn decls exps) = -- by qualified importing). If that's not the case, then we just need to -- check it refers to a symbol in another module. (Nothing, Just mn'') -> do - modExports <- getExports env mn'' - maybe (throwError . errorMessage $ unknown qname) return (getE modExports name) + case M.lookup mn'' env of + Nothing + | mn'' `S.member` importedVirtualModules imports -> throwUnknown + | otherwise -> throwError . errorMessage $ UnknownModule mn'' + Just env' -> maybe throwUnknown return (getE (envModuleExports env') name) -- If neither of the above cases are true then it's an undefined or -- unimported symbol. - _ -> throwError . errorMessage $ unknown qname + _ -> throwUnknown where positioned err = case pos of Nothing -> err Just pos' -> rethrowWithPosition pos' err + throwUnknown = throwError . errorMessage $ unknown qname -- | -- Replaces `ProperRef` export values with a `TypeRef` or `TypeClassRef` diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 8f1623613a..15300afd44 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -22,6 +22,7 @@ import Data.Function (on) import Data.List (groupBy, sortBy, nub) import Data.Maybe (fromJust) import qualified Data.Map as M +import qualified Data.Set as S import Control.Monad import Control.Monad.Error.Class (MonadError(..)) @@ -54,16 +55,21 @@ data Imports = Imports -- , importedValues :: M.Map (Qualified Ident) [(Qualified Ident, ModuleName)] -- | - -- The list of modules that have been imported into the current scope. + -- The modules that have been imported into the current scope. -- - , importedModules :: [ModuleName] + , importedModules :: S.Set ModuleName + -- | + -- The names of "virtual" modules that come into existence when "import as" + -- is used. + -- + , importedVirtualModules :: S.Set ModuleName } deriving (Show, Read) -- | -- An empty 'Imports' value. -- nullImports :: Imports -nullImports = Imports M.empty M.empty M.empty M.empty [] +nullImports = Imports M.empty M.empty M.empty M.empty S.empty S.empty -- | -- The exported declarations from a module. diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index a5ce3edd1a..ac0cf9a55c 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -23,6 +23,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer (MonadWriter(..)) import qualified Data.Map as M +import qualified Data.Set as S import Language.PureScript.Crash import Language.PureScript.AST @@ -168,7 +169,10 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports go ie' (pos, typ, impQual) = do modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env - let ie'' = ie' { importedModules = mn : importedModules ie' } + let virtualModules = importedVirtualModules ie' + ie'' = ie' { importedModules = S.insert mn (importedModules ie') + , importedVirtualModules = maybe virtualModules (`S.insert` virtualModules) impQual + } positioned $ resolveImport mn modExports ie'' impQual typ where positioned err = case pos of From d09d4302fc6fe6e1750d33d5c3b3256e0c045735 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 27 Dec 2015 02:16:18 +0100 Subject: [PATCH 0227/1580] Remove ParseDesugarError data type There's no reason to distinguish the individual cases, I think, so this data type just adds noise for no benefit. --- psc-docs/Main.hs | 8 +----- .../PureScript/Docs/ParseAndDesugar.hs | 25 +++++++------------ src/Language/PureScript/Publish.hs | 2 +- .../PureScript/Publish/ErrorsWarnings.hs | 17 +++---------- 4 files changed, 14 insertions(+), 38 deletions(-) diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index 79b7fdc607..23db235b09 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -70,13 +70,7 @@ docgen (PSCDocsOptions fmt inputGlob output) = do Markdown -> do e <- D.parseAndDesugar input [] (\_ ms -> return ms) case e of - Left (D.ParseError err) -> do - hPutStrLn stderr $ show err - exitFailure - Left (D.SortModulesError err) -> do - hPutStrLn stderr $ P.prettyPrintMultipleErrors False err - exitFailure - Left (D.DesugarError err) -> do + Left err -> do hPutStrLn stderr $ P.prettyPrintMultipleErrors False err exitFailure Right ms' -> diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndDesugar.hs index cff4a67c97..8a7c3b1c59 100644 --- a/src/Language/PureScript/Docs/ParseAndDesugar.hs +++ b/src/Language/PureScript/Docs/ParseAndDesugar.hs @@ -2,7 +2,6 @@ module Language.PureScript.Docs.ParseAndDesugar ( parseAndDesugar - , ParseDesugarError(..) ) where import Prelude () @@ -24,12 +23,6 @@ import qualified Language.PureScript.Constants as C import Language.PureScript.Docs.Types import Language.PureScript.Docs.Convert (collectBookmarks) -data ParseDesugarError - = ParseError P.MultipleErrors - | SortModulesError P.MultipleErrors - | DesugarError P.MultipleErrors - deriving (Show) - -- | -- Given: -- @@ -50,7 +43,7 @@ parseAndDesugar :: [FilePath] -> [(PackageName, FilePath)] -> ([Bookmark] -> [P.Module] -> IO a) - -> IO (Either ParseDesugarError a) + -> IO (Either P.MultipleErrors a) parseAndDesugar inputFiles depsFiles callback = do inputFiles' <- traverse (parseAs Local) inputFiles depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles @@ -63,15 +56,15 @@ parseAndDesugar inputFiles depsFiles callback = do parseFiles :: [(FileInfo, FilePath)] - -> ExceptT ParseDesugarError IO [(FileInfo, P.Module)] + -> ExceptT P.MultipleErrors IO [(FileInfo, P.Module)] parseFiles = - throwLeft ParseError . P.parseModulesFromFiles fileInfoToString + throwLeft . P.parseModulesFromFiles fileInfoToString sortModules :: [P.Module] - -> ExceptT ParseDesugarError IO [P.Module] + -> ExceptT P.MultipleErrors IO [P.Module] sortModules = - fmap fst . throwLeft SortModulesError . sortModules' . map importPrim + fmap fst . throwLeft . sortModules' . map importPrim where sortModules' :: [P.Module] -> Either P.MultipleErrors ([P.Module], P.ModuleGraph) sortModules' = P.sortModules @@ -79,9 +72,9 @@ sortModules = desugarWithBookmarks :: [(FileInfo, P.Module)] -> [P.Module] - -> ExceptT ParseDesugarError IO ([Bookmark], [P.Module]) + -> ExceptT P.MultipleErrors IO ([Bookmark], [P.Module]) desugarWithBookmarks msInfo msSorted = do - msDesugared <- throwLeft DesugarError (desugar msSorted) + msDesugared <- throwLeft (desugar msSorted) let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo) msPackages = map (addPackage msDeps) msDesugared @@ -89,8 +82,8 @@ desugarWithBookmarks msInfo msSorted = do return (bookmarks, takeLocals msPackages) -throwLeft :: (MonadError e m) => (l -> e) -> Either l r -> m r -throwLeft f = either (throwError . f) return +throwLeft :: (MonadError l m) => Either l r -> m r +throwLeft = either throwError return -- | Specifies whether a PureScript source file is considered as: -- diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 904607e8f2..7dd899ce1f 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -147,7 +147,7 @@ getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module]) getModulesAndBookmarks = do (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles liftIO (D.parseAndDesugar inputFiles depsFiles renderModules) - >>= either (userError . ParseAndDesugarError) return + >>= either (userError . CompileError) return where renderModules bookmarks modules = return (bookmarks, map D.convertModule modules) diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index c001de80f0..baec5aad69 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -33,7 +33,6 @@ import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName, showBower import qualified Web.Bower.PackageMeta as Bower import qualified Language.PureScript as P -import qualified Language.PureScript.Docs as D import Language.PureScript.Publish.BoxesHelpers @@ -61,7 +60,7 @@ data UserError | AmbiguousVersions [Version] -- Invariant: should contain at least two elements | BadRepositoryField RepositoryFieldError | MissingDependencies (NonEmpty PackageName) - | ParseAndDesugarError D.ParseDesugarError + | CompileError P.MultipleErrors | DirtyWorkingTree deriving (Show) @@ -188,19 +187,9 @@ displayUserError e = case e of [ "Please install ", them, " first, by running `bower install`." ]) ] - ParseAndDesugarError (D.ParseError err) -> + CompileError err -> vcat - [ para "Parse error:" - , indented (P.prettyPrintMultipleErrorsBox False err) - ] - ParseAndDesugarError (D.SortModulesError err) -> - vcat - [ para "Error in sortModules:" - , indented (P.prettyPrintMultipleErrorsBox False err) - ] - ParseAndDesugarError (D.DesugarError err) -> - vcat - [ para "Error while desugaring:" + [ para "Compile error:" , indented (P.prettyPrintMultipleErrorsBox False err) ] DirtyWorkingTree -> From 9f8cffaaf1c95ca1ed6d5ba48166033c5bb1c755 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 27 Dec 2015 14:43:06 +0100 Subject: [PATCH 0228/1580] uses the latest resolver when stack installing This is so that users get an "up to date" version of purescript when their global stack config is set to an old resolver. --- INSTALL.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/INSTALL.md b/INSTALL.md index 5e4bc78648..c58652f0b5 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -27,7 +27,7 @@ GHC 7.6.1 or newer is required to compile from source. The easiest way is to use stack: ``` -$ stack install purescript +$ stack install --resolver lts purescript ``` This will then copy the compiler and utilities into `~/.local/bin`. From c099eee28db0e124fa2dad3fa29625a17ed16bf5 Mon Sep 17 00:00:00 2001 From: Brandon Martin Date: Mon, 21 Dec 2015 09:09:37 -0700 Subject: [PATCH 0229/1580] allow git@github.com in extractGithub. Fixes #1549 --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Publish.hs | 7 ++++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index d72c50c688..e7e8d262d3 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -60,6 +60,7 @@ This file lists the contributors to the PureScript compiler project, and the ter . - [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 904607e8f2..8d1806cd48 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -41,6 +41,7 @@ import qualified Data.Text.Lazy.Encoding as TL import Control.Category ((>>>)) import Control.Arrow ((***)) +import Control.Applicative ((<|>)) import Control.Exception (catch, try) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.Except @@ -197,7 +198,7 @@ getBowerInfo = either (userError . BadRepositoryField) return . tryExtract extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo) extractGithub = - stripPrefix "git://github.com/" + matchUrl >>> fmap (splitOn "/") >=> takeTwo >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit)) @@ -212,6 +213,10 @@ extractGithub = | ".git" `isSuffixOf` str = take (length str - 4) str | otherwise = str + matchUrl :: String -> Maybe String + matchUrl str = + stripPrefix "git@github.com:" str <|> stripPrefix "git://github.com/" str + readProcess' :: String -> [String] -> String -> PrepareM String readProcess' prog args stdin = do out <- liftIO (catch (Right <$> readProcess prog args stdin) From 0c31b54a71b5cb47471914eb2737aae3e7e68f3e Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 29 Dec 2015 14:28:50 +0000 Subject: [PATCH 0230/1580] Warn about unspecified constructors in type imports --- src/Language/PureScript/Errors.hs | 7 +++++++ src/Language/PureScript/Linter/Imports.hs | 13 +++++++------ 2 files changed, 14 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 4fbb56f20b..2e2978b8e5 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -139,6 +139,7 @@ data SimpleErrorMessage | IntOutOfRange Integer String Integer Integer | RedundantEmptyHidingImport ModuleName | ImplicitImport ModuleName [DeclarationRef] + | ImplicitDctorImport ProperName [ProperName] | CaseBinderLengthDiffers Int [Binder] deriving (Show) @@ -310,6 +311,7 @@ errorCode em = case unwrapErrorMessage em of IntOutOfRange{} -> "IntOutOfRange" RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport" ImplicitImport{} -> "ImplicitImport" + ImplicitDctorImport{} -> "ImplicitDctorImport" CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers" -- | @@ -859,6 +861,11 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ] + renderSimpleErrorMessage (ImplicitDctorImport ty ctors) = + paras [ line $ "Import of type " ++ runProperName ty ++ " has unspecified data constructors, consider using the explicit form: " + , indent $ line $ runProperName ty ++ " (" ++ intercalate ", " (map runProperName ctors) ++ ")" + ] + renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) = paras $ [ line $ "Binder list length differs in case alternative:" , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 4774585dff..283beda50a 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -83,13 +83,14 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do -- If we've not already warned a type is unused, check its data constructors forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do let allCtors = dctorsForType mni tn - when (runProperName tn `elem` usedNames) $ case (c, null $ usedDctors `intersect` allCtors) of - (Nothing, True) -> tell $ errorMessage $ UnusedDctorImport tn - (Just (_:_), True) -> tell $ errorMessage $ UnusedDctorImport tn - (Just ctors, _) -> - let ddiff = ctors \\ usedDctors + when (runProperName tn `elem` usedNames) $ case (c, usedDctors `intersect` allCtors) of + (_, []) -> + tell $ errorMessage $ UnusedDctorImport tn + (Nothing, usedDctors') -> + tell $ errorMessage $ ImplicitDctorImport tn usedDctors' + (Just ctors, usedDctors') -> + let ddiff = ctors \\ usedDctors' in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff - _ -> return () return () From 8ca3d1e68bb49ca979a8272f3913cdcefc115cd9 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Wed, 30 Dec 2015 01:44:55 +0000 Subject: [PATCH 0231/1580] Distinguish between the different ProperNames --- hierarchy/Main.hs | 3 +- psci/Completion.hs | 10 +- psci/PSCi.hs | 30 ++-- purescript.cabal | 2 + src/Language/PureScript.hs | 1 - src/Language/PureScript/AST/Binders.hs | 19 +-- src/Language/PureScript/AST/Declarations.hs | 28 ++-- src/Language/PureScript/AST/Exported.hs | 57 ++++--- src/Language/PureScript/CoreFn/Binders.hs | 21 +-- src/Language/PureScript/CoreFn/Desugar.hs | 14 +- src/Language/PureScript/CoreFn/Expr.hs | 19 +-- src/Language/PureScript/Docs/Convert.hs | 2 +- src/Language/PureScript/Docs/Render.hs | 8 +- .../PureScript/Docs/RenderedCode/Render.hs | 5 +- src/Language/PureScript/Docs/Types.hs | 2 +- src/Language/PureScript/Environment.hs | 36 ++-- src/Language/PureScript/Errors.hs | 82 ++++----- src/Language/PureScript/Externs.hs | 22 +-- src/Language/PureScript/Linter/Exhaustive.hs | 67 ++++---- src/Language/PureScript/Linter/Imports.hs | 38 +++-- src/Language/PureScript/Make.hs | 1 - src/Language/PureScript/Names.hs | 46 +++++- src/Language/PureScript/Parser/Common.hs | 18 +- .../PureScript/Parser/Declarations.hs | 2 +- src/Language/PureScript/Pretty/Types.hs | 32 ++-- .../PureScript/Sugar/BindingGroups.hs | 128 ++++++++------ src/Language/PureScript/Sugar/Names.hs | 81 ++++++--- src/Language/PureScript/Sugar/Names/Env.hs | 23 ++- .../PureScript/Sugar/Names/Exports.hs | 39 ++++- .../PureScript/Sugar/Names/Imports.hs | 29 ++-- src/Language/PureScript/Sugar/TypeClasses.hs | 101 +++++++----- .../PureScript/Sugar/TypeClasses/Deriving.hs | 46 ++++-- src/Language/PureScript/TypeChecker.hs | 156 +++++++++--------- .../PureScript/TypeChecker/Entailment.hs | 41 ++--- src/Language/PureScript/TypeChecker/Kinds.hs | 115 +++++++------ src/Language/PureScript/TypeChecker/Monad.hs | 95 +++++++---- src/Language/PureScript/TypeChecker/Types.hs | 17 +- .../PureScript/TypeClassDictionaries.hs | 20 +-- src/Language/PureScript/Types.hs | 22 +-- 39 files changed, 805 insertions(+), 673 deletions(-) diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs index 76b8c95199..dcba30919e 100644 --- a/hierarchy/Main.hs +++ b/hierarchy/Main.hs @@ -14,6 +14,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE TupleSections #-} +{-# LANGUAGE DataKinds #-} module Main where @@ -38,7 +39,7 @@ data HierarchyOptions = HierarchyOptions , hierarchyOutput :: Maybe FilePath } -newtype SuperMap = SuperMap { unSuperMap :: Either P.ProperName (P.ProperName, P.ProperName) } +newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) ((P.ProperName 'P.ClassName), (P.ProperName 'P.ClassName)) } deriving Eq instance Show SuperMap where diff --git a/psci/Completion.hs b/psci/Completion.hs index 8a52463911..564d9044f8 100644 --- a/psci/Completion.hs +++ b/psci/Completion.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} + module Completion where import Prelude () @@ -184,10 +186,10 @@ getAllImportsOf = asks . allImportsOf nubOnFst :: Eq a => [(a, b)] -> [(a, b)] nubOnFst = nubBy ((==) `on` fst) -typeDecls :: P.Module -> [(N.ProperName, P.Declaration)] +typeDecls :: P.Module -> [(N.ProperName 'N.TypeName, P.Declaration)] typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations where - getTypeName :: P.Declaration -> Maybe (N.ProperName, P.Declaration) + getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, P.Declaration) getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d) getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d) getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d @@ -204,10 +206,10 @@ identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d getDeclNames _ = [] -dctorNames :: P.Module -> [(N.ProperName, P.Declaration)] +dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)] dctorNames = nubOnFst . concatMap go . P.exportedDeclarations where - go :: P.Declaration -> [(N.ProperName, P.Declaration)] + go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)] go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors) go (P.PositionedDeclaration _ _ d) = go d go _ = [] diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 47e72f001b..a296c23df6 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE DataKinds #-} -- | -- PureScript Compiler Interactive. @@ -326,7 +327,7 @@ handleShowImportedModules = do showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" showRef (P.ValueRef ident) = N.runIdent ident showRef (P.TypeClassRef pn) = N.runProperName pn - showRef (P.ProperRef pn) = N.runProperName pn + showRef (P.ProperRef pn) = pn showRef (P.TypeInstanceRef ident) = N.runIdent ident showRef (P.ModuleRef name) = "module " ++ N.runModuleName name showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref @@ -391,10 +392,15 @@ printModuleSignatures moduleName (P.Environment {..}) = showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType showNameType _ = P.internalError "The impossible happened in printModuleSignatures." - findTypeClass :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) + findTypeClass + :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) + -> P.Qualified (P.ProperName 'P.ClassName) + -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses) - showTypeClass :: (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) -> Maybe Box.Box + showTypeClass + :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) + -> Maybe Box.Box showTypeClass (_, Nothing) = Nothing showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) = let constraints = @@ -418,18 +424,22 @@ printModuleSignatures moduleName (P.Environment {..}) = Box.// Box.moveRight 2 classBody - findType :: M.Map (P.Qualified P.ProperName) (P.Kind, P.TypeKind) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind)) + findType + :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind) + -> P.Qualified (P.ProperName 'P.TypeName) + -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind)) findType envTypes name = (name, M.lookup name envTypes) - showType :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) - -> M.Map (P.Qualified P.ProperName) (P.DataDeclType, P.ProperName, P.Type, [P.Ident]) - -> M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], P.Type) - -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind)) - -> Maybe Box.Box + showType + :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) + -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident]) + -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type) + -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind)) + -> Maybe Box.Box showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) = case (typ, M.lookup n typeSynonymsEnv) of (Just (_, P.TypeSynonym), Just (typevars, dtType)) -> - if M.member n typeClassesEnv + if M.member (fmap P.coerceProperName n) typeClassesEnv then Nothing else diff --git a/purescript.cabal b/purescript.cabal index 50e130a576..69d75cff5d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -178,6 +178,8 @@ library Control.Monad.Supply.Class System.IO.UTF8 + + extensions: DataKinds exposed: True buildable: True hs-source-dirs: src diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index ea6b19570e..21ecd64ec4 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -13,7 +13,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index d228bf6fc8..c4adadd922 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -1,19 +1,8 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.AST.Binders --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | Case binders --- ------------------------------------------------------------------------------ - {-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Case binders +-- module Language.PureScript.AST.Binders where import qualified Data.Data as D @@ -54,7 +43,7 @@ data Binder -- | -- A binder which matches a data constructor -- - | ConstructorBinder (Qualified ProperName) [Binder] + | ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder] -- | -- A binder which matches a record and binds its properties -- diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 8d4fbf7ea1..3a0cd34646 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -60,7 +60,7 @@ data DeclarationRef -- | -- A type constructor with data constructors -- - = TypeRef ProperName (Maybe [ProperName]) + = TypeRef (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName]) -- | -- A value -- @@ -68,7 +68,7 @@ data DeclarationRef -- | -- A type class -- - | TypeClassRef ProperName + | TypeClassRef (ProperName 'ClassName) -- | -- A type class instance, created during typeclass desugaring (name, class name, instance types) -- @@ -80,7 +80,7 @@ data DeclarationRef -- | -- An unspecified ProperName ref. This will be replaced with a TypeClassRef -- or TypeRef during name desugaring. - | ProperRef ProperName + | ProperRef String -- | -- A declaration reference with source position information -- @@ -108,7 +108,7 @@ isModuleRef _ = False -- are the duplicate refs with data constructors elided, and then a separate -- list of duplicate data constructors. -- -findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName]) +findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName 'ConstructorName]) findDuplicateRefs refs = let positionless = stripPosInfo `map` refs simplified = simplifyTypeRefs `map` positionless @@ -154,7 +154,7 @@ data Declaration -- | -- A data type declaration (data or newtype, name, arguments, data constructors) -- - = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])] + = DataDeclaration DataDeclType (ProperName 'TypeName) [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])] -- | -- A minimal mutually recursive set of data type declarations -- @@ -162,7 +162,7 @@ data Declaration -- | -- A type synonym declaration (name, arguments, type) -- - | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type + | TypeSynonymDeclaration (ProperName 'TypeName) [(String, Maybe Kind)] Type -- | -- A type declaration for a value (name, ty) -- @@ -182,7 +182,7 @@ data Declaration -- | -- A data type foreign import (name, kind) -- - | ExternDataDeclaration ProperName Kind + | ExternDataDeclaration (ProperName 'TypeName) Kind -- | -- A fixity declaration (fixity data, operator name, value the operator is an alias for) -- @@ -195,12 +195,12 @@ data Declaration -- | -- A type class declaration (name, argument, implies, member declarations) -- - | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration] + | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [Declaration] -- | -- A type instance declaration (name, dependencies, class name, instance types, member -- declarations) -- - | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] TypeInstanceBody + | TypeInstanceDeclaration Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody -- | -- A declaration with source position information -- @@ -390,7 +390,7 @@ data Expr -- | -- A data constructor -- - | Constructor (Qualified ProperName) + | Constructor (Qualified (ProperName 'ConstructorName)) -- | -- 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. @@ -412,7 +412,7 @@ data Expr -- An application of a typeclass dictionary constructor. The value should be -- an ObjectLiteral. -- - | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr + | TypeClassDictionaryConstructorApp (Qualified (ProperName 'ClassName)) Expr -- | -- 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 @@ -420,15 +420,15 @@ data Expr -- at superclass implementations when searching for a dictionary, the type class name and -- instance type, and the type class dictionaries in scope. -- - | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))) + | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))) -- | -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring. -- - | TypeClassDictionaryAccessor (Qualified ProperName) Ident + | TypeClassDictionaryAccessor (Qualified (ProperName 'ClassName)) Ident -- | -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking -- - | SuperClassDictionary (Qualified ProperName) [Type] + | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type] -- | -- A value with source position information -- diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index 872d5cefdf..ec04824464 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -1,8 +1,7 @@ - -module Language.PureScript.AST.Exported ( - exportedDeclarations, - isExported -) where +module Language.PureScript.AST.Exported + ( exportedDeclarations + , isExported + ) where import Control.Category ((>>>)) import Data.Maybe (mapMaybe) @@ -23,12 +22,12 @@ import Language.PureScript.Names -- instances will be incorrectly removed in some cases. -- exportedDeclarations :: Module -> [Declaration] -exportedDeclarations (Module _ _ _ decls exps) = go decls +exportedDeclarations (Module _ _ mn decls exps) = go decls where go = flattenDecls >>> filter (isExported exps) >>> map (filterDataConstructors exps) - >>> filterInstances exps + >>> filterInstances mn exps -- | -- Filter out all data constructors from a declaration which are not exported. @@ -52,10 +51,15 @@ filterDataConstructors _ other = other -- produce incorrect results if this is not the case - for example, type class -- instances will be incorrectly removed in some cases. -- -filterInstances :: Maybe [DeclarationRef] -> [Declaration] -> [Declaration] -filterInstances Nothing = id -filterInstances (Just exps) = - let refs = mapMaybe typeName exps ++ mapMaybe typeClassName exps +filterInstances + :: ModuleName + -> Maybe [DeclarationRef] + -> [Declaration] + -> [Declaration] +filterInstances _ Nothing = id +filterInstances mn (Just exps) = + let refs = Left `map` mapMaybe typeClassName exps + ++ Right `map` mapMaybe typeName exps in filter (all (visibleOutside refs) . typeInstanceConstituents) where -- Given a Qualified ProperName, and a list of all exported types and type @@ -65,13 +69,24 @@ filterInstances (Just exps) = -- * the name is defined in the same module and is exported, -- * the name is defined in a different module (and must be exported from -- that module; the code would fail to compile otherwise). - visibleOutside _ (Qualified (Just _) _) = True - visibleOutside refs (Qualified Nothing n) = n `elem` refs - + visibleOutside + :: [Either (ProperName 'ClassName) (ProperName 'TypeName)] + -> Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName)) + -> Bool + visibleOutside refs q + | either checkQual checkQual q = True + | otherwise = either (Left . disqualify) (Right . disqualify) q `elem` refs + + -- Check that a qualified name is qualified for a different module + checkQual :: Qualified a -> Bool + checkQual q = isQualified q && not (isQualifiedWith mn q) + + typeName :: DeclarationRef -> Maybe (ProperName 'TypeName) typeName (TypeRef n _) = Just n typeName (PositionedDeclarationRef _ _ r) = typeName r typeName _ = Nothing + typeClassName :: DeclarationRef -> Maybe (ProperName 'ClassName) typeClassName (TypeClassRef n) = Just n typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r typeClassName _ = Nothing @@ -79,17 +94,17 @@ filterInstances (Just exps) = -- | -- Get all type and type class names referenced by a type instance declaration. -- -typeInstanceConstituents :: Declaration -> [Qualified ProperName] +typeInstanceConstituents :: Declaration -> [Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))] typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) = - className : (concatMap fromConstraint constraints ++ concatMap fromType tys) + Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys) where - fromConstraint (name, tys') = name : concatMap fromType tys' + fromConstraint (name, tys') = Left name : concatMap fromType tys' fromType = everythingOnTypes (++) go -- Note that type synonyms are disallowed in instance declarations, so -- we don't need to handle them here. - go (TypeConstructor n) = [n] + go (TypeConstructor n) = [Right n] go (ConstrainedType cs _) = concatMap fromConstraint cs go _ = [] @@ -118,8 +133,8 @@ isExported (Just exps) decl = any (matches decl) exps matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident' matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident' - matches (DataDeclaration _ ident _ _) (ProperRef ident') = ident == ident' - matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = ident == ident' + matches (DataDeclaration _ ident _ _) (ProperRef ident') = runProperName ident == ident' + matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = runProperName ident == ident' matches (PositionedDeclaration _ _ d) r = d `matches` r matches d (PositionedDeclarationRef _ _ r) = d `matches` r @@ -129,7 +144,7 @@ isExported (Just exps) decl = any (matches decl) exps -- Test if a data constructor for a given type is exported, given a module's -- export list. Prefer 'exportedDeclarations' to this function, where possible. -- -isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool +isDctorExported :: ProperName 'TypeName -> Maybe [DeclarationRef] -> ProperName 'ConstructorName -> Bool isDctorExported _ Nothing _ = True isDctorExported ident (Just exps) ctor = test `any` exps where diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index 77303a1b3e..5126f0e111 100644 --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -1,20 +1,9 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CoreFn.Binders --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | The core functional representation for binders --- ------------------------------------------------------------------------------ - {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} +-- | +-- The core functional representation for binders +-- module Language.PureScript.CoreFn.Binders where import qualified Data.Data as D @@ -39,9 +28,9 @@ data Binder a -- | VarBinder a Ident -- | - -- A binder which matches a data constructor (type name, constructor name, binders) + -- A binder which matches a data constructor -- - | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) [Binder a] + | ConstructorBinder a (Qualified (ProperName 'TypeName)) (Qualified (ProperName 'ConstructorName)) [Binder a] -- | -- A binder which binds its input to an identifier -- diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index f48ac7cabd..dbc971784d 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -170,7 +170,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = -- | -- Gets metadata for data constructors. -- - getConstructorMeta :: Qualified ProperName -> Meta + getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta getConstructorMeta ctor = case lookupConstructor env ctor of (Newtype, _, _, _) -> IsNewtype @@ -178,9 +178,15 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType in IsConstructor constructorType fields where - numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int + + numConstructors + :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident])) + -> Int numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env - typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName) + + typeConstructor + :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident])) + -> (ModuleName, ProperName 'TypeName) typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) typeConstructor _ = internalError "Invalid argument to typeConstructor" @@ -255,5 +261,5 @@ mkTypeClassConstructor ss com supers members = -- | -- Converts a ProperName to an Ident. -- -properToIdent :: ProperName -> Ident +properToIdent :: ProperName a -> Ident properToIdent = Ident . runProperName diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index 39a1006217..65f0695c8d 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -1,20 +1,9 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CoreFn.Expr --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | The core functional representation --- ------------------------------------------------------------------------------ - {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} +-- | +-- The core functional representation +-- module Language.PureScript.CoreFn.Expr where import Control.Arrow ((***)) @@ -36,7 +25,7 @@ data Expr a -- | -- A data constructor (type name, constructor name, field names) -- - | Constructor a ProperName ProperName [Ident] + | Constructor a (ProperName 'TypeName) (ProperName 'ConstructorName) [Ident] -- | -- A record property accessor -- diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index bd973bab12..3ade6181a3 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -172,7 +172,7 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit extractProperNames _ = [] childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) - classApp = foldl P.TypeApp (P.TypeConstructor className) tys + classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys convertDeclaration (P.FixityDeclaration fixity _ Nothing) title = Just (Left ([title], AugmentFixity fixity)) convertDeclaration (P.FixityDeclaration fixity _ (Just alias)) title = diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 6d48d2f50a..82ff0ea753 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -97,12 +97,12 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} = where renderType' = renderTypeWithOptions opts -renderConstraint :: (P.Qualified P.ProperName, [P.Type]) -> RenderedCode +renderConstraint :: P.Constraint -> RenderedCode renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions -renderConstraintWithOptions :: RenderTypeOptions -> (P.Qualified P.ProperName, [P.Type]) -> RenderedCode +renderConstraintWithOptions :: RenderTypeOptions -> P.Constraint -> RenderedCode renderConstraintWithOptions opts (pn, tys) = - renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor pn) tys + renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName pn)) tys renderConstraints :: [P.Constraint] -> Maybe RenderedCode renderConstraints = renderConstraintsWithOptions defaultRenderTypeOptions @@ -119,7 +119,7 @@ renderConstraintsWithOptions opts constraints mintersperse (syntax "," <> sp) (map (renderConstraintWithOptions opts) constraints) -notQualified :: String -> P.Qualified P.ProperName +notQualified :: String -> P.Qualified (P.ProperName a) notQualified = P.Qualified Nothing . P.ProperName typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index 432738ed73..5b04b134a5 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -52,9 +52,10 @@ typeLiterals = mkPattern match ] where constraints = mintersperse (syntax "," <> sp) (map renderDep deps) + renderDep :: Constraint -> RenderedCode renderDep (pn, tys) = - let instApp = foldl TypeApp (TypeConstructor pn) tys - in renderType instApp + let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys + in renderType instApp match REmpty = Just (syntax "()") match row@RCons{} = diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 3d2604dc37..83f9d2c11f 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -399,7 +399,7 @@ asConstraint :: Parse PackageError P.Constraint asConstraint = (,) <$> nth 0 asQualifiedProperName <*> nth 1 (eachInArray asType) -asQualifiedProperName :: Parse e (P.Qualified P.ProperName) +asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a)) asQualifiedProperName = fromAesonParser asQualifiedIdent :: Parse e (P.Qualified P.Ident) diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 4575546501..b133db1f60 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -1,17 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Environment --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -43,23 +29,23 @@ data Environment = Environment { -- | -- Type names currently in scope -- - , types :: M.Map (Qualified ProperName) (Kind, TypeKind) + , types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) -- | -- Data constructors currently in scope, along with their associated type -- constructor name, argument types and return type. - , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident]) + , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident]) -- | -- Type synonyms currently in scope -- - , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type) + , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type) -- | -- Available type class dictionaries -- - , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) + , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -- | -- Type classes -- - , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint]) + , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint]) } deriving (Show, Read) -- | @@ -107,7 +93,7 @@ data TypeKind -- | -- Data type -- - = DataType [(String, Maybe Kind)] [(ProperName, [Type])] + = DataType [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])] -- | -- Type synonym -- @@ -156,7 +142,7 @@ instance A.FromJSON DataDeclType where -- | -- Construct a ProperName in the Prim module -- -primName :: String -> Qualified ProperName +primName :: String -> Qualified (ProperName a) primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName -- | @@ -240,7 +226,7 @@ function t1 = TypeApp (TypeApp tyFunction t1) -- associated kinds. There is also a pseudo `Partial` type that corresponds to -- the class with the same name. -- -primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind) +primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) primTypes = M.fromList [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData)) @@ -258,7 +244,7 @@ primTypes = -- The primitive class map. This just contains to `Partial` class, used as a -- kind of magic constraint for partial functions. -- -primClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint]) +primClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint]) primClasses = M.fromList [ (primName "Partial", ([], [], [])) ] @@ -266,14 +252,14 @@ primClasses = -- | -- Finds information about data constructors from the current environment. -- -lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident]) +lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, Type, [Ident]) lookupConstructor env ctor = fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env -- | -- Checks whether a data constructor is for a newtype. -- -isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool +isNewtypeConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> Bool isNewtypeConstructor e ctor = case lookupConstructor e ctor of (Newtype, _, _, _) -> True (Data, _, _, _) -> False diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 2e2978b8e5..fe6d8bf651 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -53,63 +53,63 @@ data SimpleErrorMessage | RedefinedIdent Ident | OverlappingNamesInLet | UnknownModule ModuleName - | UnknownType (Qualified ProperName) - | UnknownTypeClass (Qualified ProperName) + | UnknownType (Qualified (ProperName 'TypeName)) + | UnknownTypeClass (Qualified (ProperName 'ClassName)) | UnknownValue (Qualified Ident) - | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName)) - | UnknownTypeConstructor (Qualified ProperName) - | UnknownImportType ModuleName ProperName - | UnknownExportType ProperName - | UnknownImportTypeClass ModuleName ProperName - | UnknownExportTypeClass ProperName + | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName))) + | UnknownTypeConstructor (Qualified (ProperName 'TypeName)) + | UnknownImportType ModuleName (ProperName 'TypeName) + | UnknownExportType (ProperName 'TypeName) + | UnknownImportTypeClass ModuleName (ProperName 'ClassName) + | UnknownExportTypeClass (ProperName 'ClassName) | UnknownImportValue ModuleName Ident | UnknownExportValue Ident | UnknownExportModule ModuleName - | UnknownImportDataConstructor ModuleName ProperName ProperName - | UnknownExportDataConstructor ProperName ProperName + | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName) + | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName) | ScopeConflict String [ModuleName] - | ConflictingTypeDecls ProperName - | ConflictingCtorDecls ProperName - | TypeConflictsWithClass ProperName - | CtorConflictsWithClass ProperName - | ClassConflictsWithType ProperName - | ClassConflictsWithCtor ProperName + | ConflictingTypeDecls (ProperName 'TypeName) + | ConflictingCtorDecls (ProperName 'ConstructorName) + | TypeConflictsWithClass (ProperName 'TypeName) + | CtorConflictsWithClass (ProperName 'ConstructorName) + | ClassConflictsWithType (ProperName 'ClassName) + | ClassConflictsWithCtor (ProperName 'ClassName) | DuplicateModuleName ModuleName - | DuplicateClassExport ProperName + | DuplicateClassExport (ProperName 'ClassName) | DuplicateValueExport Ident | DuplicateTypeArgument String | InvalidDoBind | InvalidDoLet | CycleInDeclaration Ident - | CycleInTypeSynonym (Maybe ProperName) + | CycleInTypeSynonym (Maybe (ProperName 'TypeName)) | CycleInModules [ModuleName] | NameIsUndefined Ident - | UndefinedTypeVariable ProperName - | PartiallyAppliedSynonym (Qualified ProperName) + | UndefinedTypeVariable (ProperName 'TypeName) + | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName)) | EscapedSkolem (Maybe Expr) | TypesDoNotUnify Type Type | KindsDoNotUnify Kind Kind | ConstrainedTypeUnified Type Type - | OverlappingInstances (Qualified ProperName) [Type] [Qualified Ident] - | NoInstanceFound (Qualified ProperName) [Type] - | PossiblyInfiniteInstance (Qualified ProperName) [Type] - | CannotDerive (Qualified ProperName) [Type] - | CannotFindDerivingType ProperName + | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident] + | NoInstanceFound (Qualified (ProperName 'ClassName)) [Type] + | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type] + | CannotDerive (Qualified (ProperName 'ClassName)) [Type] + | CannotFindDerivingType (ProperName 'TypeName) | DuplicateLabel String (Maybe Expr) | DuplicateValueDeclaration Ident | ArgListLengthsDiffer Ident | OverlappingArgNames (Maybe Ident) | MissingClassMember Ident - | ExtraneousClassMember Ident (Qualified ProperName) + | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName)) | ExpectedType Type Kind - | IncorrectConstructorArity (Qualified ProperName) + | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName)) | ExprDoesNotHaveType Expr Type | PropertyIsMissing String | AdditionalProperty String | CannotApplyFunction Type Expr | TypeSynonymInstance - | OrphanInstance Ident (Qualified ProperName) [Type] - | InvalidNewtype ProperName + | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type] + | InvalidNewtype (ProperName 'TypeName) | InvalidInstanceHead Type | TransitiveExportError DeclarationRef [DeclarationRef] | ShadowedName Ident @@ -120,17 +120,17 @@ data SimpleErrorMessage | NotExhaustivePattern [[Binder]] Bool | OverlappingPattern [[Binder]] Bool | IncompleteExhaustivityCheck - | ClassOperator ProperName Ident - | MisleadingEmptyTypeImport ModuleName ProperName + | ClassOperator (ProperName 'ClassName) Ident + | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName) | ImportHidingModule ModuleName | UnusedImport ModuleName | UnusedExplicitImport ModuleName [String] - | UnusedDctorImport ProperName - | UnusedDctorExplicitImport ProperName [ProperName] + | UnusedDctorImport (ProperName 'TypeName) + | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName] | DeprecatedOperatorDecl String | DeprecatedQualifiedSyntax ModuleName ModuleName - | DeprecatedClassImport ModuleName ProperName - | DeprecatedClassExport ProperName + | DeprecatedClassImport ModuleName (ProperName 'ClassName) + | DeprecatedClassExport (ProperName 'ClassName) | RedundantUnqualifiedImport ModuleName ImportDeclarationType | DuplicateSelectiveImport ModuleName | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) @@ -139,7 +139,7 @@ data SimpleErrorMessage | IntOutOfRange Integer String Integer Integer | RedundantEmptyHidingImport ModuleName | ImplicitImport ModuleName [DeclarationRef] - | ImplicitDctorImport ProperName [ProperName] + | ImplicitDctorImport (ProperName 'TypeName) [ProperName 'ConstructorName] | CaseBinderLengthDiffers Int [Binder] deriving (Show) @@ -148,7 +148,7 @@ data ErrorMessageHint = ErrorUnifyingTypes Type Type | ErrorInExpression Expr | ErrorInModule ModuleName - | ErrorInInstance (Qualified ProperName) [Type] + | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type] | ErrorInSubsumption Type Type | ErrorCheckingAccessor Expr String | ErrorCheckingType Expr Type @@ -156,11 +156,11 @@ data ErrorMessageHint | ErrorCheckingGuard | ErrorInferringType Expr | ErrorInApplication Expr Type Expr - | ErrorInDataConstructor ProperName - | ErrorInTypeConstructor ProperName + | ErrorInDataConstructor (ProperName 'ConstructorName) + | ErrorInTypeConstructor (ProperName 'TypeName) | ErrorInBindingGroup [Ident] | ErrorInDataBindingGroup - | ErrorInTypeSynonym ProperName + | ErrorInTypeSynonym (ProperName 'TypeName) | ErrorInValueDeclaration Ident | ErrorInTypeDeclaration Ident | ErrorInForeignImport Ident @@ -1010,7 +1010,7 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")" prettyPrintRef (ValueRef ident) = showIdent ident prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn - prettyPrintRef (ProperRef pn) = runProperName pn + prettyPrintRef (ProperRef name) = name prettyPrintRef (TypeInstanceRef ident) = showIdent ident prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index a8cb962fc5..5bdc3049ba 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -80,21 +80,21 @@ data ExternsFixity = ExternsFixity data ExternsDeclaration = -- | A type declaration EDType - { edTypeName :: ProperName + { edTypeName :: ProperName 'TypeName , edTypeKind :: Kind , edTypeDeclarationKind :: TypeKind } -- | A type synonym | EDTypeSynonym - { edTypeSynonymName :: ProperName + { edTypeSynonymName :: ProperName 'TypeName , edTypeSynonymArguments :: [(String, Maybe Kind)] , edTypeSynonymType :: Type } -- | A data construtor | EDDataConstructor - { edDataCtorName :: ProperName + { edDataCtorName :: ProperName 'ConstructorName , edDataCtorOrigin :: DataDeclType - , edDataCtorTypeCtor :: ProperName + , edDataCtorTypeCtor :: ProperName 'TypeName , edDataCtorType :: Type , edDataCtorFields :: [Ident] } @@ -105,14 +105,14 @@ data ExternsDeclaration = } -- | A type class declaration | EDClass - { edClassName :: ProperName + { edClassName :: ProperName 'ClassName , edClassTypeArguments :: [(String, Maybe Kind)] , edClassMembers :: [(Ident, Type)] , edClassConstraints :: [Constraint] } -- | An instance declaration | EDInstance - { edInstanceClassName :: Qualified ProperName + { edInstanceClassName :: Qualified (ProperName 'ClassName) , edInstanceName :: Ident , edInstanceTypes :: [Type] , edInstanceConstraints :: Maybe [Constraint] @@ -178,7 +178,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} Just (kind, tk@(DataType _ tys)) -> EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args | dctor <- fromMaybe (map fst tys) dctors - , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env)) + , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env) ] _ -> internalError "toExternsDeclaration: Invalid input" toExternsDeclaration (ValueRef ident) @@ -186,10 +186,10 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} = [ EDValue ident ty ] toExternsDeclaration (TypeClassRef className) | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env - , Just (kind, TypeSynonym) <- M.lookup (Qualified (Just mn) className) (types env) - , Just (_, synTy) <- Qualified (Just mn) className `M.lookup` typeSynonyms env - = [ EDType className kind TypeSynonym - , EDTypeSynonym className args synTy + , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env + , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env + = [ EDType (coerceProperName className) kind TypeSynonym + , EDTypeSynonym (coerceProperName className) args synTy , EDClass className args members implies ] toExternsDeclaration (TypeInstanceRef ident) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 524478b85b..4496b387df 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -1,24 +1,12 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Exhaustive --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- | Module for exhaustivity checking over pattern matching definitions --- | The algorithm analyses the clauses of a definition one by one from top --- | to bottom, where in each step it has the cases already missing (uncovered), --- | and it generates the new set of missing cases. --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module for exhaustivity checking over pattern matching definitions +-- The algorithm analyses the clauses of a definition one by one from top +-- to bottom, where in each step it has the cases already missing (uncovered), +-- and it generates the new set of missing cases. +-- module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where import Prelude () @@ -54,7 +42,11 @@ data RedudancyError = Incomplete | Unknown -- | -- Qualifies a propername from a given qualified propername and a default module name -- -qualifyName :: a -> ModuleName -> Qualified a -> Qualified a +qualifyName + :: (ProperName a) + -> ModuleName + -> Qualified (ProperName b) + -> Qualified (ProperName a) qualifyName n defmn qn = Qualified (Just mn) n where (mn, _) = qualify defmn qn @@ -65,31 +57,28 @@ qualifyName n defmn qn = Qualified (Just mn) n -- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe) -- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"]) -- -getConstructors :: Environment -> ModuleName -> Qualified ProperName -> [(ProperName, [Type])] +getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'ConstructorName) -> [(ProperName 'ConstructorName, [Type])] getConstructors env defmn n = extractConstructors lnte where - qpn :: Qualified ProperName - qpn = getConsDataName n - getConsDataName :: Qualified ProperName -> Qualified ProperName - getConsDataName con = qualifyName nm defmn con - where - nm = case getConsInfo con of - Nothing -> error $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName." - Just (_, pm, _, _) -> pm - - getConsInfo :: Qualified ProperName -> Maybe (DataDeclType, ProperName, Type, [Ident]) - getConsInfo con = M.lookup con dce - where - dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident]) - dce = dataConstructors env + extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName 'ConstructorName, [Type])] + extractConstructors (Just (_, DataType _ pt)) = pt + extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors" lnte :: Maybe (Kind, TypeKind) lnte = M.lookup qpn (types env) - extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName, [Type])] - extractConstructors (Just (_, DataType _ pt)) = pt - extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors" + qpn :: Qualified (ProperName 'TypeName) + qpn = getConsDataName n + + getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName) + getConsDataName con = + case getConsInfo con of + Nothing -> internalError $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName." + Just (_, pm, _, _) -> qualifyName pm defmn con + + getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, Type, [Ident]) + getConsInfo con = M.lookup con (dataConstructors env) -- | -- Replicates a wildcard binder @@ -303,14 +292,14 @@ checkExhaustiveDecls env mn = mapM_ onDecl hasPartialConstraint :: Type -> Bool hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs where - go :: Qualified ProperName -> Bool + go :: Qualified (ProperName 'ClassName) -> Bool go qname | qname == partialClass = True | otherwise = case qname `M.lookup` typeClasses env of Just ([], _, cs') -> any (go . fst) cs' _ -> False - partialClass :: Qualified ProperName + partialClass :: Qualified (ProperName 'ClassName) partialClass = primName "Partial" hasPartialConstraint _ = False diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 283beda50a..6574b23b1c 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -28,21 +28,21 @@ import qualified Language.PureScript.Constants as C -- | Imported name used in some type or expression. data Name = IdentName (Qualified Ident) - | TypeName (Qualified ProperName) - | DctorName (Qualified ProperName) - | ClassName (Qualified ProperName) + | TyName (Qualified (ProperName 'TypeName)) + | DctorName (Qualified (ProperName 'ConstructorName)) + | TyClassName (Qualified (ProperName 'ClassName)) deriving (Eq) getIdentName :: Name -> Maybe Ident getIdentName (IdentName (Qualified _ name)) = Just name getIdentName _ = Nothing -getTypeName :: Name -> Maybe ProperName -getTypeName (TypeName (Qualified _ name)) = Just name +getTypeName :: Name -> Maybe (ProperName 'TypeName) +getTypeName (TyName (Qualified _ name)) = Just name getTypeName _ = Nothing -getClassName :: Name -> Maybe ProperName -getClassName (ClassName (Qualified _ name)) = Just name +getClassName :: Name -> Maybe (ProperName 'ClassName) +getClassName (TyClassName (Qualified _ name)) = Just name getClassName _ = Nothing -- | Map of module name to list of imported names from that module which have been used. @@ -96,12 +96,12 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do _ -> return () where - reconstructTypeRefs :: ModuleName -> [ProperName] -> M.Map ProperName [ProperName] + reconstructTypeRefs :: ModuleName -> [ProperName 'ConstructorName] -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName] reconstructTypeRefs mni = foldr accumDctors M.empty where accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor) - findTypeForDctor :: ModuleName -> ProperName -> ProperName + findTypeForDctor :: ModuleName -> ProperName 'ConstructorName -> ProperName 'TypeName findTypeForDctor mn dctor = case mn `M.lookup` env of Just (_, _, exps) -> @@ -122,17 +122,17 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do qnameUsed (Just qn) = qn `elem` alwaysUsedModules qnameUsed Nothing = False - dtys :: ModuleName -> [((ProperName, [ProperName]), ModuleName)] + dtys :: ModuleName -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env - dctorsForType :: ModuleName -> ProperName -> [ProperName] + dctorsForType :: ModuleName -> ProperName 'TypeName -> [ProperName 'ConstructorName] dctorsForType mn tn = maybe [] getDctors (find matches $ dtys mn) where matches ((ty, _),_) = ty == tn getDctors ((_,ctors),_) = ctors - typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName + typeForDCtor :: ModuleName -> ProperName 'ConstructorName -> Maybe (ProperName 'TypeName) typeForDCtor mn pn = getTy <$> find matches (dtys mn) where @@ -140,14 +140,18 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do getTy ((ty, _), _) = ty -matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String +matchName + :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName)) + -> Maybe ModuleName + -> Name + -> Maybe String matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x -matchName _ qual (TypeName (Qualified q x)) | q == qual = Just $ runProperName x -matchName _ qual (ClassName (Qualified q x)) | q == qual = Just $ runProperName x +matchName _ qual (TyName (Qualified q x)) | q == qual = Just $ runProperName x +matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperName x matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x matchName _ _ _ = Nothing -matchDctor :: Maybe ModuleName -> Name -> Maybe ProperName +matchDctor :: Maybe ModuleName -> Name -> Maybe (ProperName 'ConstructorName) matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x matchDctor _ _ = Nothing @@ -158,7 +162,7 @@ runDeclRef (TypeRef pn _) = Just $ runProperName pn runDeclRef (TypeClassRef pn) = Just $ runProperName pn runDeclRef _ = Nothing -getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName]) +getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref getTypeRef (TypeRef pn x) = Just (pn, x) getTypeRef _ = Nothing diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 30866d3975..cf9898dd55 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TupleSections #-} diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index eca3262428..a4090755b1 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE KindSignatures #-} -- | -- Data types for names @@ -13,6 +14,7 @@ import Control.Monad.Supply.Class import Data.List import Data.Data +import Data.Aeson import Data.Aeson.TH -- | @@ -51,12 +53,32 @@ freshIdent' = liftM (GenIdent Nothing) fresh -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. -- -newtype ProperName = ProperName { runProperName :: String } deriving (Show, Read, Eq, Ord, Data, Typeable) +newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String } + deriving (Show, Read, Eq, Ord, Data, Typeable) + +instance ToJSON (ProperName a) where + toJSON = toJSON . runProperName + +instance FromJSON (ProperName a) where + parseJSON = fmap ProperName . parseJSON + +-- | +-- The closed set of proper name types. +-- +data ProperNameType = TypeName | ConstructorName | ClassName | Namespace + +-- | +-- Coerces a ProperName from one ProperNameType to another. This should be used +-- with care, and is primarily used to convert ClassNames into TypeNames after +-- classes have been desugared. +-- +coerceProperName :: ProperName a -> ProperName b +coerceProperName = ProperName . runProperName -- | -- Module names -- -newtype ModuleName = ModuleName [ProperName] deriving (Show, Read, Eq, Ord, Data, Typeable) +newtype ModuleName = ModuleName [ProperName 'Namespace] deriving (Show, Read, Eq, Ord, Data, Typeable) runModuleName :: ModuleName -> String runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns) @@ -98,11 +120,23 @@ disqualify (Qualified _ a) = a -- | -- Checks whether a qualified value is actually qualified with a module reference -- +isQualified :: Qualified a -> Bool +isQualified (Qualified Nothing _) = False +isQualified _ = True + +-- | +-- Checks whether a qualified value is not actually qualified with a module reference +-- isUnqualified :: Qualified a -> Bool -isUnqualified (Qualified Nothing _) = True -isUnqualified _ = False +isUnqualified = not . isQualified + +-- | +-- Checks whether a qualified value is qualified with a particular module +-- +isQualifiedWith :: ModuleName -> Qualified a -> Bool +isQualifiedWith mn (Qualified (Just mn') _) = mn == mn' +isQualifiedWith _ _ = False $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident) -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ProperName) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName) diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index 973daf2094..1088834ae1 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -1,20 +1,8 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Parser.Common --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE FlexibleContexts #-} + -- | -- Constants, and utility functions to be used when parsing -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} - module Language.PureScript.Parser.Common where import Control.Applicative @@ -27,7 +15,7 @@ import Language.PureScript.Names import qualified Text.Parsec as P -properName :: TokenParser ProperName +properName :: TokenParser (ProperName a) properName = ProperName <$> uname -- | diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 33bbcfbb77..0a5e004de1 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -165,7 +165,7 @@ parseDeclarationRef = parseProperRef = do name <- properName dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName) - return $ maybe (ProperRef name) (TypeRef name) dctors + return $ maybe (ProperRef (runProperName name)) (TypeRef name) dctors parseTypeClassDeclaration :: TokenParser Declaration parseTypeClassDeclaration = do diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 3c568bab9d..1d14bdbc2a 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -1,26 +1,14 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Pretty.Types --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Pretty printer for Types -- ------------------------------------------------------------------------------ - -module Language.PureScript.Pretty.Types ( - typeAsBox, - prettyPrintType, - typeAtomAsBox, - prettyPrintTypeAtom, - prettyPrintRowWith, - prettyPrintRow -) where +module Language.PureScript.Pretty.Types + ( typeAsBox + , prettyPrintType + , typeAtomAsBox + , prettyPrintTypeAtom + , prettyPrintRowWith + , prettyPrintRow + ) where import Data.Maybe (fromMaybe) @@ -50,11 +38,11 @@ typeLiterals = mkPattern match match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row match _ = Nothing -constraintsAsBox :: [(Qualified ProperName, [Type])] -> Box -> Box +constraintsAsBox :: [Constraint] -> Box -> Box constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty) -constraintAsBox :: Qualified ProperName -> [Type] -> Box +constraintAsBox :: Qualified (ProperName a) -> [Type] -> Box constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys) -- | diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 6b330c44d7..3949673403 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -1,60 +1,61 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.BindingGroups --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} + -- | -- This module implements the desugaring pass which creates binding groups from sets of -- mutually-recursive value declarations and mutually-recursive type declarations. -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.PureScript.Sugar.BindingGroups ( - createBindingGroups, - createBindingGroupsModule, - collapseBindingGroups, - collapseBindingGroupsModule -) where +module Language.PureScript.Sugar.BindingGroups + ( createBindingGroups + , createBindingGroupsModule + , collapseBindingGroups + , collapseBindingGroupsModule + ) where import Prelude () import Prelude.Compat -import Data.Graph -import Data.List (nub, intersect) -import Data.Maybe (isJust, mapMaybe) import Control.Monad ((<=<)) import Control.Monad.Error.Class (MonadError(..)) +import Data.Graph +import Data.List (nub, intersect) +import Data.Maybe (isJust, mapMaybe) import qualified Data.Set as S -import Language.PureScript.Crash import Language.PureScript.AST -import Language.PureScript.Names -import Language.PureScript.Types +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors +import Language.PureScript.Names +import Language.PureScript.Types -- | -- Replace all sets of mutually-recursive declarations in a module with binding groups -- -createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module] -createBindingGroupsModule = mapM $ \(Module ss coms name ds exps) -> Module ss coms name <$> createBindingGroups name ds <*> pure exps +createBindingGroupsModule + :: (Functor m, Applicative m, MonadError MultipleErrors m) + => [Module] + -> m [Module] +createBindingGroupsModule = + mapM $ \(Module ss coms name ds exps) -> + Module ss coms name <$> createBindingGroups name ds <*> pure exps -- | -- Collapse all binding groups in a module to individual declarations -- collapseBindingGroupsModule :: [Module] -> [Module] -collapseBindingGroupsModule = map $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps - -createBindingGroups :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration] +collapseBindingGroupsModule = + map $ \(Module ss coms name ds exps) -> + Module ss coms name (collapseBindingGroups ds) exps + +createBindingGroups + :: forall m + . (Functor m, Applicative m, MonadError MultipleErrors m) + => ModuleName + -> [Declaration] + -> m [Declaration] createBindingGroups moduleName = mapM f <=< handleDecls where @@ -71,8 +72,8 @@ createBindingGroups moduleName = mapM f <=< handleDecls handleDecls ds = do let values = filter isValueDecl ds dataDecls = filter isDataDecl ds - allProperNames = map getProperName dataDecls - dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls + allProperNames = map getTypeName dataDecls + dataVerts = map (\d -> (d, getTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup let allIdents = map getIdent values valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values @@ -90,11 +91,15 @@ createBindingGroups moduleName = mapM f <=< handleDecls -- Collapse all binding groups to individual declarations -- collapseBindingGroups :: [Declaration] -> [Declaration] -collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go +collapseBindingGroups = + let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id + in map f . concatMap go where go (DataBindingGroupDeclaration ds) = ds - go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds - go (PositionedDeclaration pos com d) = map (PositionedDeclaration pos com) $ go d + go (BindingGroupDeclaration ds) = + map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds + go (PositionedDeclaration pos com d) = + map (PositionedDeclaration pos com) $ go d go other = [other] collapseBindingGroupsForValue :: Expr -> Expr @@ -114,8 +119,10 @@ usedIdents moduleName = nub . usedIdents' S.empty . getValue (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def usedNamesE :: S.Set Ident -> Expr -> [Ident] - usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = [name] - usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = [name] + usedNamesE scope (Var (Qualified Nothing name)) + | name `S.notMember` scope = [name] + usedNamesE scope (Var (Qualified (Just moduleName') name)) + | moduleName == moduleName' && name `S.notMember` scope = [name] usedNamesE _ _ = [] usedImmediateIdents :: ModuleName -> Declaration -> [Ident] @@ -127,21 +134,24 @@ usedImmediateIdents moduleName = usedNamesE :: Bool -> Expr -> (Bool, [Ident]) usedNamesE True (Var (Qualified Nothing name)) = (True, [name]) - usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name]) + usedNamesE True (Var (Qualified (Just moduleName') name)) + | moduleName == moduleName' = (True, [name]) usedNamesE True (Abs _ _) = (False, []) usedNamesE scope _ = (scope, []) -usedProperNames :: ModuleName -> Declaration -> [ProperName] -usedProperNames moduleName = +usedTypeNames :: ModuleName -> Declaration -> [ProperName 'TypeName] +usedTypeNames moduleName = let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames) in nub . f where - usedNames :: Type -> [ProperName] - usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual -> - case qual of - (Qualified (Just moduleName') name, _) | moduleName == moduleName' -> Just name + usedNames :: Type -> [ProperName 'TypeName] + usedNames (ConstrainedType constraints _) = + flip mapMaybe constraints $ \case + (Qualified (Just moduleName') name, _) + | moduleName == moduleName' -> Just (coerceProperName name) _ -> Nothing - usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name] + usedNames (TypeConstructor (Qualified (Just moduleName') name)) + | moduleName == moduleName' = [name] usedNames _ = [] getIdent :: Declaration -> Ident @@ -149,17 +159,22 @@ getIdent (ValueDeclaration ident _ _ _) = ident getIdent (PositionedDeclaration _ _ d) = getIdent d getIdent _ = internalError "Expected ValueDeclaration" -getProperName :: Declaration -> ProperName -getProperName (DataDeclaration _ pn _ _) = pn -getProperName (TypeSynonymDeclaration pn _ _) = pn -getProperName (PositionedDeclaration _ _ d) = getProperName d -getProperName _ = internalError "Expected DataDeclaration" +getTypeName :: Declaration -> ProperName 'TypeName +getTypeName (DataDeclaration _ pn _ _) = pn +getTypeName (TypeSynonymDeclaration pn _ _) = pn +getTypeName (PositionedDeclaration _ _ d) = getTypeName d +getTypeName _ = internalError "Expected DataDeclaration" -- | -- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration). -- -- -toBindingGroup :: forall m. (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration +toBindingGroup + :: forall m + . (Functor m, MonadError MultipleErrors m) + => ModuleName + -> SCC Declaration + -> m Declaration toBindingGroup _ (AcyclicSCC d) = return d toBindingGroup moduleName (CyclicSCC ds') = -- Once we have a mutually-recursive group of declarations, we need to sort @@ -188,7 +203,10 @@ toBindingGroup moduleName (CyclicSCC ds') = cycleError (ValueDeclaration n _ _ (Right _)) = errorMessage $ CycleInDeclaration n cycleError _ = internalError "cycleError: Expected ValueDeclaration" -toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration +toDataBindingGroup + :: MonadError MultipleErrors m + => SCC Declaration + -> m Declaration toDataBindingGroup (AcyclicSCC d) = return d toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn) @@ -197,7 +215,7 @@ toDataBindingGroup (CyclicSCC ds') | all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing | otherwise = return $ DataBindingGroupDeclaration ds' -isTypeSynonym :: Declaration -> Maybe ProperName +isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName) isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d isTypeSynonym _ = Nothing diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index cc331b09a1..155fccf843 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -56,17 +56,17 @@ desugarImports externs modules = do return $ M.insert efModuleName (ss, imps, exps) env where - exportedTypes :: [((ProperName, [ProperName]), ModuleName)] + exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] exportedTypes = mapMaybe toExportedType efExports where toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName) where - forTyCon :: ExternsDeclaration -> Maybe ProperName + forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName) forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn forTyCon _ = Nothing toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r toExportedType _ = Nothing - exportedTypeClasses :: [(ProperName, ModuleName)] + exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)] exportedTypeClasses = mapMaybe toExportedTypeClass efExports where toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName) @@ -120,14 +120,23 @@ elaborateExports exps (Module ss coms mn decls refs) = -- Replaces all local names with qualified names within a module and checks that all existing -- qualified names are valid. -- -renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) => Env -> Imports -> Module -> m Module +renameInModule + :: forall m + . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) + => Env + -> Imports + -> Module + -> m Module renameInModule env imports (Module ss coms mn decls exps) = Module ss coms mn <$> parU decls go <*> pure exps where (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS - updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration) + updateDecl + :: (Maybe SourceSpan, [Ident]) + -> Declaration + -> m ((Maybe SourceSpan, [Ident]), Declaration) updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d) updateDecl (pos, bound) (DataDeclaration dtype name args dctors) = @@ -146,7 +155,10 @@ renameInModule env imports (Module ss coms mn decls exps) = (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (`updateValueName` pos) alias) updateDecl s d = return (s, d) - updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr) + updateValue + :: (Maybe SourceSpan, [Ident]) + -> Expr + -> m ((Maybe SourceSpan, [Ident]), Expr) updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v) updateValue (pos, bound) (Abs (Left arg) val') = @@ -167,7 +179,10 @@ renameInModule env imports (Module ss coms mn decls exps) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty) updateValue s v = return (s, v) - updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder) + updateBinder + :: (Maybe SourceSpan, [Ident]) + -> Binder + -> m ((Maybe SourceSpan, [Ident]), Binder) updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v) updateBinder s@(pos, _) (ConstructorBinder name b) = @@ -179,7 +194,10 @@ renameInModule env imports (Module ss coms mn decls exps) = updateBinder s v = return (s, v) - updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative) + updateCase + :: (Maybe SourceSpan, [Ident]) + -> CaseAlternative + -> m ((Maybe SourceSpan, [Ident]), CaseAlternative) updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c) @@ -199,16 +217,25 @@ renameInModule env imports (Module ss coms mn decls exps) = updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint] updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts) - updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) - updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TypeName (("type " ++) . runProperName) + updateTypeName + :: Qualified (ProperName 'TypeName) + -> Maybe SourceSpan + -> m (Qualified (ProperName 'TypeName)) + updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TyName (("type " ++) . runProperName) - updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) + updateDataConstructorName + :: Qualified (ProperName 'ConstructorName) + -> Maybe SourceSpan + -> m (Qualified (ProperName 'ConstructorName)) updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName) - updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) - updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) ClassName (("class " ++) . runProperName) + updateClassName + :: Qualified (ProperName 'ClassName) + -> Maybe SourceSpan + -> m (Qualified (ProperName 'ClassName)) + updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) TyClassName (("class " ++) . runProperName) - updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident) + updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident) updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent) -- Used when performing an update to qualify values and classes with their @@ -218,12 +245,18 @@ renameInModule env imports (Module ss coms mn decls exps) = -- Used when performing an update to qualify types with their module of -- original definition. - resolveType :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName) + resolveType + :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] + -> ProperName 'TypeName + -> Maybe (Qualified (ProperName 'TypeName)) resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys -- Used when performing an update to qualify data constructors with their -- module of original definition. - resolveDctor :: [((ProperName, [ProperName]), ModuleName)] -> ProperName -> Maybe (Qualified ProperName) + resolveDctor + :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] + -> ProperName 'ConstructorName + -> Maybe (Qualified (ProperName 'ConstructorName)) resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys -- Update names so unqualified references become qualified, and locally @@ -279,25 +312,29 @@ renameInModule env imports (Module ss coms mn decls exps) = -- depending on what is availble within the module. Warns when a `ProperRef` -- desugars into a `TypeClassRef`. -- -updateExportRefs :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> m Module +updateExportRefs + :: forall m + . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Module + -> m Module updateExportRefs (Module ss coms mn decls exps) = Module ss coms mn decls <$> traverse (traverse updateRef) exps where updateRef :: DeclarationRef -> m DeclarationRef updateRef (ProperRef name) - | name `elem` classNames = do - tell . errorMessage $ DeprecatedClassExport name - return $ TypeClassRef name + | ProperName name `elem` classNames = do + tell . errorMessage . DeprecatedClassExport $ ProperName name + return . TypeClassRef $ ProperName name -- Fall through case here - assume it's a type if it's not a class. -- If it's a reference to something that doesn't actually exist it will -- be picked up elsewhere - | otherwise = return $ TypeRef name (Just []) + | otherwise = return $ TypeRef (ProperName name) (Just []) updateRef (PositionedDeclarationRef pos com ref) = warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref updateRef other = return other - classNames :: [ProperName] + classNames :: [ProperName 'ClassName] classNames = mapMaybe go decls where go (PositionedDeclaration _ _ d) = go d diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 15300afd44..6820ac5a92 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -41,15 +41,15 @@ data Imports = Imports -- | -- Local names for types within a module mapped to to their qualified names -- - importedTypes :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)] + importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [(Qualified (ProperName 'TypeName), ModuleName)] -- | -- Local names for data constructors within a module mapped to to their qualified names -- - , importedDataConstructors :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)] + , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [(Qualified (ProperName 'ConstructorName), ModuleName)] -- | -- Local names for classes within a module mapped to to their qualified names -- - , importedTypeClasses :: M.Map (Qualified ProperName) [(Qualified ProperName, ModuleName)] + , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [(Qualified (ProperName 'ClassName), ModuleName)] -- | -- Local names for values within a module mapped to to their qualified names -- @@ -80,12 +80,12 @@ data Exports = Exports -- The types exported from each module along with the module they originally -- came from. -- - exportedTypes :: [((ProperName, [ProperName]), ModuleName)] + exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] -- | -- The classes exported from each module along with the module they originally -- came from. -- - , exportedTypeClasses :: [(ProperName, ModuleName)] + , exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)] -- | -- The values exported from each module along with the module they originally -- came from. @@ -143,29 +143,28 @@ primEnv = M.singleton -- Safely adds a type and its data constructors to some exports, returning an -- error if a conflict occurs. -- -exportType :: (MonadError MultipleErrors m) => Exports -> ProperName -> [ProperName] -> ModuleName -> m Exports +exportType :: (MonadError MultipleErrors m) => Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ModuleName -> m Exports exportType exps name dctors mn = do let exTypes' = exportedTypes exps let exTypes = filter ((/= mn) . snd) exTypes' let exDctors = (snd . fst) `concatMap` exTypes let exClasses = exportedTypeClasses exps - when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name - when (any ((== name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name + when (any ((== coerceProperName name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name forM_ dctors $ \dctor -> do when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor - when (any ((== dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor + when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' } -- | -- Safely adds a class to some exports, returning an error if a conflict occurs. -- -exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName -> ModuleName -> m Exports +exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName 'ClassName -> ModuleName -> m Exports exportTypeClass exps name mn = do let exTypes = exportedTypes exps let exDctors = (snd . fst) `concatMap` exTypes - when (any ((== name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name - when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name + when (any ((== coerceProperName name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name + when (coerceProperName name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps) return $ exps { exportedTypeClasses = classes } diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 194566d0ff..6b1e68ee33 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -75,7 +75,7 @@ resolveExports env mn imps exps refs = ModuleRef name -> warnDupe $ "module " ++ runModuleName name _ -> return () - warnDupeDctors :: [ProperName] -> m () + warnDupeDctors :: [ProperName 'ConstructorName] -> m () warnDupeDctors = traverse_ (warnDupe . ("data constructor " ++) . runProperName) warnDupe :: String -> m () @@ -151,10 +151,15 @@ resolveExports env mn imps exps refs = -- Constructs a list of types with their data constructors and the original -- module they were defined in from a list of type and data constructor names. - resolveTypeExports :: [Qualified ProperName] -> [Qualified ProperName] -> [((ProperName, [ProperName]), ModuleName)] + resolveTypeExports + :: [Qualified (ProperName 'TypeName)] + -> [Qualified (ProperName 'ConstructorName)] + -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] resolveTypeExports tctors dctors = map go tctors where - go :: Qualified ProperName -> ((ProperName, [ProperName]), ModuleName) + go + :: Qualified (ProperName 'TypeName) + -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName) go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do exps' <- envModuleExports <$> mn'' `M.lookup` env ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps') @@ -165,7 +170,7 @@ resolveExports env mn imps exps refs = -- Looks up an imported class and re-qualifies it with the original module it -- came from. - resolveClass :: Qualified ProperName -> (ProperName, ModuleName) + resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ModuleName) resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $ resolve exportedTypeClasses className @@ -192,7 +197,13 @@ resolveExports env mn imps exps refs = -- Filters the full list of exportable values, types, and classes for a module -- based on a list of export declaration references. -- -filterModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> Exports -> [DeclarationRef] -> m Exports +filterModule + :: forall m + . (Applicative m, MonadError MultipleErrors m) + => ModuleName + -> Exports + -> [DeclarationRef] + -> m Exports filterModule mn exps refs = do types <- foldM (filterTypes $ exportedTypes exps) [] refs values <- foldM (filterValues $ exportedValues exps) [] refs @@ -206,7 +217,11 @@ filterModule mn exps refs = do -- explicit export. When the ref refers to a type in the list of exportable -- values, the type and specified data constructors are included in the -- result. - filterTypes :: [((ProperName, [ProperName]), ModuleName)] -> [((ProperName, [ProperName]), ModuleName)] -> DeclarationRef -> m [((ProperName, [ProperName]), ModuleName)] + filterTypes + :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] + -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] + -> DeclarationRef + -> m [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] filterTypes exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes exps' result r filterTypes exps' result (TypeRef name expDcons) = @@ -221,7 +236,11 @@ filterModule mn exps refs = do -- Ensures a data constructor is exportable for a given type. Takes a type -- name, a list of exportable data constructors for the type, and the name of -- the data constructor to check. - checkDcon :: ProperName -> [ProperName] -> ProperName -> m () + checkDcon + :: ProperName 'TypeName + -> [ProperName 'ConstructorName] + -> ProperName 'ConstructorName + -> m () checkDcon tcon exps' name = unless (name `elem` exps') $ throwError . errorMessage $ UnknownExportDataConstructor tcon name @@ -230,7 +249,11 @@ filterModule mn exps refs = do -- filtered exports, and a `DeclarationRef` for an explicit export. When the -- ref refers to a class in the list of exportable classes, the class is -- included in the result. - filterClasses :: [(ProperName, ModuleName)] -> [(ProperName, ModuleName)] -> DeclarationRef -> m [(ProperName, ModuleName)] + filterClasses + :: [(ProperName 'ClassName, ModuleName)] + -> [(ProperName 'ClassName, ModuleName)] + -> DeclarationRef + -> m [(ProperName 'ClassName, ModuleName)] filterClasses exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterClasses exps' result r filterClasses exps' result (TypeClassRef name) = diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index ac0cf9a55c..caa155a650 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -124,7 +124,7 @@ resolveImports env (Module ss coms currentModule decls exps) = ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name _ -> return () - warnDupeDctors :: Maybe SourceSpan -> [ProperName] -> m () + warnDupeDctors :: Maybe SourceSpan -> [ProperName 'ConstructorName] -> m () warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName) warnDupe :: Maybe SourceSpan -> String -> m () @@ -147,11 +147,11 @@ resolveImports env (Module ss coms currentModule decls exps) = updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef updateProperRef importModule modExports (ProperRef name) = - if name `elem` (fst `map` exportedTypeClasses modExports) + if ProperName name `elem` (fst `map` exportedTypeClasses modExports) then do - tell . errorMessage $ DeprecatedClassImport importModule name - return $ TypeClassRef name - else return $ TypeRef name (Just []) + tell . errorMessage $ DeprecatedClassImport importModule (ProperName name) + return . TypeClassRef $ ProperName name + else return $ TypeRef (ProperName name) (Just []) updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) = PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref updateProperRef _ _ other = return other @@ -226,13 +226,22 @@ resolveImport importModule exps imps impQual = resolveByType check r = internalError $ "Invalid argument to checkRefs: " ++ show r -- Check that an explicitly imported item exists in the module it is being imported from - checkImportExists :: (Eq a) => (ModuleName -> a -> SimpleErrorMessage) -> [a] -> a -> m () + checkImportExists + :: Eq a + => (ModuleName -> a -> SimpleErrorMessage) + -> [a] + -> a + -> m () checkImportExists unknown exports item = when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item -- Ensure that an explicitly imported data constructor exists for the type it is being imported -- from - checkDctorExists :: ProperName -> [ProperName] -> ProperName -> m () + checkDctorExists + :: ProperName 'TypeName + -> [ProperName 'ConstructorName] + -> ProperName 'ConstructorName + -> m () checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon) importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports @@ -268,9 +277,9 @@ resolveImport importModule exps imps impQual = resolveByType return $ imp { importedValues = values' } importExplicit imp (TypeRef name dctors) = do let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name - let exportedDctors :: [(ProperName, ModuleName)] + let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)] exportedDctors = allExportedDataConstructors name - dctorNames :: [ProperName] + dctorNames :: [ProperName 'ConstructorName] dctorNames = fst `map` exportedDctors maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name @@ -282,7 +291,7 @@ resolveImport importModule exps imps impQual = resolveByType importExplicit _ _ = internalError "Invalid argument to importExplicit" -- Find all exported data constructors for a given type - allExportedDataConstructors :: ProperName -> [(ProperName, ModuleName)] + allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)] allExportedDataConstructors name = case find ((== name) . fst . fst) (exportedTypes exps) of Nothing -> internalError "Invalid state in allExportedDataConstructors" diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 44300e35bb..03a7324f40 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -1,22 +1,11 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Sugar.TypeClasses --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + -- | -- This module implements the desugaring pass which creates type synonyms for type class dictionaries -- and dictionary expressions for type class instances. -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} - module Language.PureScript.Sugar.TypeClasses ( desugarTypeClasses , typeClassMemberName @@ -47,7 +36,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust) import qualified Data.Map as M -type MemberMap = M.Map (ModuleName, ProperName) ([(String, Maybe Kind)], [Constraint], [Declaration]) +type MemberMap = M.Map (ModuleName, ProperName 'ClassName) ([(String, Maybe Kind)], [Constraint], [Declaration]) type Desugar = StateT MemberMap @@ -55,17 +44,27 @@ type Desugar = StateT MemberMap -- Add type synonym declarations for type class dictionary types, and value declarations for type class -- instance dictionary expressions. -- -desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] +desugarTypeClasses + :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) + => [ExternsFile] + -> [Module] + -> m [Module] desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule where initialState :: MemberMap initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) - fromExternsDecl :: ModuleName -> ExternsDeclaration -> Maybe ((ModuleName, ProperName), ([(String, Maybe Kind)], [Constraint], [Declaration])) + fromExternsDecl + :: ModuleName + -> ExternsDeclaration + -> Maybe ((ModuleName, ProperName 'ClassName), ([(String, Maybe Kind)], [Constraint], [Declaration])) fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members)) fromExternsDecl _ _ = Nothing -desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module +desugarModule + :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) + => Module + -> Desugar m Module desugarModule (Module ss coms name decls (Just exps)) = do (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps) return $ Module ss coms name (concat declss) $ Just (exps ++ catMaybes newExpss) @@ -171,7 +170,12 @@ desugarModule _ = internalError "Exports should have been elaborated in name des -- return new Sub(fooString, ""); -- }; -} -desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration]) +desugarDecl + :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) + => ModuleName + -> [DeclarationRef] + -> Declaration + -> Desugar m (Maybe DeclarationRef, [Declaration]) desugarDecl mn exps = go where go d@(TypeClassDeclaration name args implies members) = do @@ -187,48 +191,60 @@ desugarDecl mn exps = go return (dr, map (PositionedDeclaration pos com) ds) go other = return (Nothing, [other]) - expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef + expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef expRef name className tys | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name | otherwise = Nothing - isExportedClass :: Qualified ProperName -> Bool + isExportedClass :: Qualified (ProperName 'ClassName) -> Bool isExportedClass = isExported (elem . TypeClassRef) - isExportedType :: Qualified ProperName -> Bool + isExportedType :: Qualified (ProperName 'TypeName) -> Bool isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn) - isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool + isExported + :: (ProperName a -> [DeclarationRef] -> Bool) + -> Qualified (ProperName a) + -> Bool isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps isExported _ _ = internalError "Names should have been qualified in name desugaring" - matchesTypeRef :: ProperName -> DeclarationRef -> Bool + matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool matchesTypeRef pn (TypeRef pn' _) = pn == pn' matchesTypeRef _ _ = False - getConstructors :: Type -> [Qualified ProperName] + getConstructors :: Type -> [Qualified (ProperName 'TypeName)] getConstructors = everythingOnTypes (++) getConstructor - - getConstructor :: Type -> [Qualified ProperName] - getConstructor (TypeConstructor tcname) = [tcname] - getConstructor _ = [] + where + getConstructor (TypeConstructor tcname) = [tcname] + getConstructor _ = [] memberToNameAndType :: Declaration -> (Ident, Type) memberToNameAndType (TypeDeclaration ident ty) = (ident, ty) memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d memberToNameAndType _ = internalError "Invalid declaration in type class definition" -typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration +typeClassDictionaryDeclaration + :: ProperName 'ClassName + -> [(String, Maybe Kind)] + -> [Constraint] + -> [Declaration] + -> Declaration typeClassDictionaryDeclaration name args implies members = let superclassTypes = superClassDictionaryNames implies `zip` - [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs) + [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs) | (superclass, tyArgs) <- implies ] members' = map (first runIdent . memberToNameAndType) members mtys = members' ++ superclassTypes - in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty)) - -typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration + in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyObject $ rowFromList (mtys, REmpty)) + +typeClassMemberToDictionaryAccessor + :: ModuleName + -> ProperName 'ClassName + -> [(String, Maybe Kind)] + -> Declaration + -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) = let className = Qualified (Just mn) name in ValueDeclaration ident Private [] $ Right $ @@ -241,7 +257,16 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration unit :: Type unit = TypeApp tyObject REmpty -typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration +typeInstanceDictionaryDeclaration + :: forall m + . (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) + => Ident + -> ModuleName + -> [Constraint] + -> Qualified (ProperName 'ClassName) + -> [Type] + -> [Declaration] + -> Desugar m Declaration typeInstanceDictionaryDeclaration name mn deps className tys decls = rethrow (addHint (ErrorInInstance className tys)) $ do m <- get @@ -273,7 +298,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = ] let props = ObjectLiteral (members ++ superclasses) - dictTy = foldl TypeApp (TypeConstructor className) tys + dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy) dict = TypeClassDictionaryConstructorApp className props result = ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy)) @@ -287,7 +312,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = declName (TypeDeclaration ident _) = Just ident declName _ = Nothing - memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr + memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys' return val diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 254945e8b1..86b0f824f8 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -8,9 +8,7 @@ -- | -- This module implements the generic deriving elaboration that takes place during desugaring. -- -module Language.PureScript.Sugar.TypeClasses.Deriving ( - deriveInstances -) where +module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where import Prelude () import Prelude.Compat @@ -32,12 +30,20 @@ import Language.PureScript.Types import qualified Language.PureScript.Constants as C -- | Elaborates deriving instance declarations by code generation. -deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module +deriveInstances + :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) + => Module + -> m Module deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts -- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration, -- elaborates that into an instance declaration via code generation. -deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration +deriveInstance + :: (Functor m, MonadError MultipleErrors m, MonadSupply m) + => ModuleName + -> [Declaration] + -> Declaration + -> m Declaration deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance) | className == Qualified (Just dataGeneric) (ProperName C.generic) , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty @@ -48,7 +54,7 @@ deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d deriveInstance _ _ e = return e -unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName, [Type]) +unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type]) unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, []) unwrapTypeConstructor (TypeApp ty arg) = do (tyCon, args) <- unwrapTypeConstructor ty @@ -64,7 +70,13 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ] typesProxy :: ModuleName typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ] -deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration] +deriveGeneric + :: (Functor m, MonadError MultipleErrors m, MonadSupply m) + => ModuleName + -> [Declaration] + -> ProperName 'TypeName + -> [Type] + -> m [Declaration] deriveGeneric mn ds tyConNm args = do tyCon <- findTypeDecl tyConNm ds toSpine <- mkSpineFunction mn tyCon @@ -75,7 +87,11 @@ deriveGeneric mn ds tyConNm args = do , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature) ] -findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration +findTypeDecl + :: (Functor m, MonadError MultipleErrors m) + => ProperName 'TypeName + -> [Declaration] + -> m Declaration findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl where isTypeDecl :: Declaration -> Bool @@ -92,7 +108,7 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl recordConstructor :: Expr -> Expr recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord"))) - mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative + mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative mkCtorClause (ctorName, tys) = do idents <- replicateM (length tys) freshIdent' return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents)) @@ -125,10 +141,12 @@ mkSignatureFunction mn (DataDeclaration _ name tyArgs args) classArgs = lamNull proxy :: Type -> Type proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy"))) - mkProdClause :: (ProperName, [Type]) -> Expr - mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))) - , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys) - ] + mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr + mkProdClause (ctorName, tys) = + ObjectLiteral + [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))) + , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys) + ] mkProductSignature :: Type -> Expr mkProductSignature r | Just rec <- objectType r = @@ -158,7 +176,7 @@ mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch recordBinder :: [Binder] -> Binder recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord")) - mkAlternative :: (ProperName, [Type]) -> m CaseAlternative + mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative mkAlternative (ctorName, tys) = do idents <- replicateM (length tys) freshIdent' return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 607b1b498a..21401bad25 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -39,15 +39,15 @@ import Language.PureScript.TypeClassDictionaries import Language.PureScript.Environment import Language.PureScript.Errors -addDataType :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - ModuleName -> - DataDeclType -> - ProperName -> - [(String, Maybe Kind)] -> - [(ProperName, [Type])] -> - Kind -> - m () +addDataType + :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => ModuleName + -> DataDeclType + -> ProperName 'TypeName + -> [(String, Maybe Kind)] + -> [(ProperName 'ConstructorName, [Type])] + -> Kind + -> m () addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) } @@ -55,15 +55,15 @@ addDataType moduleName dtype name args dctors ctorKind = do warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $ addDataConstructor moduleName dtype name (map fst args) dctor tys -addDataConstructor :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - ModuleName -> - DataDeclType -> - ProperName -> - [String] -> - ProperName -> - [Type] -> - m () +addDataConstructor + :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => ModuleName + -> DataDeclType + -> ProperName 'TypeName + -> [String] + -> ProperName 'ConstructorName + -> [Type] + -> m () addDataConstructor moduleName dtype name args dctor tys = do env <- getEnv traverse_ checkTypeSynonyms tys @@ -73,50 +73,50 @@ addDataConstructor moduleName dtype name args dctor tys = do let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]] putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } -addTypeSynonym :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - ModuleName -> - ProperName -> - [(String, Maybe Kind)] -> - Type -> - Kind -> - m () +addTypeSynonym + :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => ModuleName + -> ProperName 'TypeName + -> [(String, Maybe Kind)] + -> Type + -> Kind + -> m () addTypeSynonym moduleName name args ty kind = do env <- getEnv checkTypeSynonyms ty putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env) , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) } -valueIsNotDefined :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - ModuleName -> - Ident -> - m () +valueIsNotDefined + :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => ModuleName + -> Ident + -> m () valueIsNotDefined moduleName name = do env <- getEnv case M.lookup (moduleName, name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name Nothing -> return () -addValue :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - ModuleName -> - Ident -> - Type -> - NameKind -> - m () +addValue + :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => ModuleName + -> Ident + -> Type + -> NameKind + -> m () addValue moduleName name ty nameKind = do env <- getEnv putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) }) -addTypeClass :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - ModuleName -> - ProperName -> - [(String, Maybe Kind)] -> - [Constraint] -> - [Declaration] -> - m () +addTypeClass + :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => ModuleName + -> ProperName 'ClassName + -> [(String, Maybe Kind)] + -> [Constraint] + -> [Declaration] + -> m () addTypeClass moduleName pn args implies ds = let members = map toPair ds in modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } } @@ -125,30 +125,30 @@ addTypeClass moduleName pn args implies ds = toPair (PositionedDeclaration _ _ d) = toPair d toPair _ = internalError "Invalid declaration in TypeClassDeclaration" -addTypeClassDictionaries :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - Maybe ModuleName -> - M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) -> - m () +addTypeClassDictionaries + :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Maybe ModuleName + -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope) + -> m () addTypeClassDictionaries mn entries = modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } } where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st) -checkDuplicateTypeArguments :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - [String] -> - m () +checkDuplicateTypeArguments + :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => [String] + -> m () checkDuplicateTypeArguments args = for_ firstDup $ \dup -> throwError . errorMessage $ DuplicateTypeArgument dup where firstDup :: Maybe String firstDup = listToMaybe $ args \\ nub args -checkTypeClassInstance :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - ModuleName -> - Type -> - m () +checkTypeClassInstance + :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => ModuleName + -> Type + -> m () checkTypeClassInstance _ (TypeVar _) = return () checkTypeClassInstance _ (TypeConstructor ctor) = do env <- getEnv @@ -160,10 +160,10 @@ checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty -- | -- Check that type synonyms are fully-applied in a type -- -checkTypeSynonyms :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - Type -> - m () +checkTypeSynonyms + :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Type + -> m () checkTypeSynonyms = void . replaceAllTypeSynonyms -- | @@ -179,12 +179,13 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms -- -- * Process module imports -- -typeCheckAll :: forall m. - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - ModuleName -> - [DeclarationRef] -> - [Declaration] -> - m [Declaration] +typeCheckAll + :: forall m + . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => ModuleName + -> [DeclarationRef] + -> [Declaration] + -> m [Declaration] typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds where go :: Declaration -> m Declaration @@ -197,7 +198,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds addDataType moduleName dtype name args' dctors ctorKind return $ DataDeclaration dtype name args dctors where - checkNewtype :: [(ProperName, [Type])] -> m () + checkNewtype :: [(ProperName 'ConstructorName, [Type])] -> m () checkNewtype [(_, [_])] = return () checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name checkNewtype _ = throwError . errorMessage $ InvalidNewtype name @@ -308,7 +309,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds | otherwise = firstDuplicate xs firstDuplicate _ = Nothing - checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> m () + checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m () checkOrphanInstance dictName className@(Qualified (Just mn') _) tys' | moduleName == mn' || any checkType tys' = return () | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys' @@ -335,10 +336,11 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds -- Type check an entire module and ensure all types and classes defined within the module that are -- required by exported members are also exported. -- -typeCheckModule :: forall m. - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - Module -> - m Module +typeCheckModule + :: forall m + . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Module + -> m Module typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated" typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do modify (\s -> s { checkCurrentModule = Just mn }) @@ -403,7 +405,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint where go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs go _ = [] - extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName + extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName) extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name extractCurrentModuleClass _ = Nothing diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 6ca8412c0c..48d878a1c2 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -1,24 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker.Entailment --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- Type class entailment --- ------------------------------------------------------------------------------ - {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} -module Language.PureScript.TypeChecker.Entailment ( - entails -) where +-- | +-- Type class entailment +-- +module Language.PureScript.TypeChecker.Entailment (entails) where import Prelude () import Prelude.Compat @@ -46,15 +32,16 @@ import qualified Language.PureScript.Constants as C -- Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. -- -entails :: forall m. - (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - ModuleName -> - M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> - Constraint -> - m Expr +entails + :: forall m + . (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => ModuleName + -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) + -> Constraint + -> m Expr entails moduleName context = solve where - forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope] + forClassName :: Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope] forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys)) forClassName _ _ = internalError "forClassName: expected qualified class name" @@ -64,7 +51,7 @@ entails moduleName context = solve ctorModules (TypeApp ty _) = ctorModules ty ctorModules _ = Nothing - findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope] + findDicts :: Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope] findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context solve :: Constraint -> m Expr @@ -72,7 +59,7 @@ entails moduleName context = solve dict <- go 0 className tys return $ dictionaryValueToValue dict where - go :: Int -> Qualified ProperName -> [Type] -> m DictionaryValue + go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> m DictionaryValue go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' go work className' tys' = do let instances = do diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 976aecda72..ae3325b31c 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -1,18 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker.Kinds --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- This module implements the kind checker --- ------------------------------------------------------------------------------ - {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} @@ -20,12 +5,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} -module Language.PureScript.TypeChecker.Kinds ( - kindOf, - kindOfWithScopedVars, - kindsOf, - kindsOfAll -) where +-- | +-- This module implements the kind checker +-- +module Language.PureScript.TypeChecker.Kinds + ( kindOf + , kindOfWithScopedVars + , kindsOf + , kindsOfAll + ) where import Prelude () import Prelude.Compat @@ -54,7 +42,11 @@ freshKind = do return $ KUnknown k -- | Update the substitution to solve a kind constraint -solveKind :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Kind -> m () +solveKind + :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) + => Int + -> Kind + -> m () solveKind u k = do occursCheck u k modify $ \cs -> cs { checkSubstitution = @@ -75,7 +67,11 @@ substituteKind sub = everywhereOnKinds go go other = other -- | Make sure that an unknown does not occur in a kind -occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Kind -> m () +occursCheck + :: (Functor m, Applicative m, MonadError MultipleErrors m) + => Int + -> Kind + -> m () occursCheck _ KUnknown{} = return () occursCheck u k = void $ everywhereOnKindsM go k where @@ -83,7 +79,11 @@ occursCheck u k = void $ everywhereOnKindsM go k go other = return other -- | Unify two kinds -unifyKinds :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Kind -> Kind -> m () +unifyKinds + :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) + => Kind + -> Kind + -> m () unifyKinds k1 k2 = do sub <- gets checkSubstitution go (substituteKind sub k1) (substituteKind sub k2) @@ -100,10 +100,10 @@ unifyKinds k1 k2 = do go k1' k2' = throwError . errorMessage $ KindsDoNotUnify k1' k2' -- | Infer the kind of a single type -kindOf :: - (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => - Type -> - m Kind +kindOf + :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) + => Type + -> m Kind kindOf ty = fst <$> kindOfWithScopedVars ty -- | Infer the kind of a single type, returning the kinds of any scoped type variables @@ -120,14 +120,14 @@ kindOfWithScopedVars ty = ) -- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors -kindsOf :: - (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => - Bool -> - ModuleName -> - ProperName -> - [(String, Maybe Kind)] -> - [Type] -> - m Kind +kindsOf + :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) + => Bool + -> ModuleName + -> ProperName 'TypeName + -> [(String, Maybe Kind)] + -> [Type] + -> m Kind kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do tyCon <- freshKind kargs <- replicateM (length args) freshKind @@ -138,23 +138,23 @@ kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do where tidyUp (k, sub) = starIfUnknown $ substituteKind sub k -freshKindVar :: - (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => - (String, Maybe Kind) -> - Kind -> - m (ProperName, Kind) +freshKindVar + :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) + => (String, Maybe Kind) + -> Kind + -> m (ProperName 'TypeName, Kind) freshKindVar (arg, Nothing) kind = return (ProperName arg, kind) freshKindVar (arg, Just kind') kind = do unifyKinds kind kind' return (ProperName arg, kind') -- | Simultaneously infer the kinds of several mutually recursive type constructors -kindsOfAll :: - (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => - ModuleName -> - [(ProperName, [(String, Maybe Kind)], Type)] -> - [(ProperName, [(String, Maybe Kind)], [Type])] -> - m ([Kind], [Kind]) +kindsOfAll + :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) + => ModuleName + -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)] + -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])] + -> m ([Kind], [Kind]) kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do synVars <- replicateM (length syns) freshKind let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars @@ -177,7 +177,13 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . substituteKind sub) ks1, map (starIfUnknown . substituteKind sub) ks2) -- | Solve the set of kind constraints associated with the data constructors for a type constructor -solveTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Bool -> [Type] -> [Kind] -> Kind -> m Kind +solveTypes + :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) + => Bool + -> [Type] + -> [Kind] + -> Kind + -> m Kind solveTypes isData ts kargs tyCon = do ks <- traverse (fmap fst . infer) ts when isData $ do @@ -195,10 +201,17 @@ starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2) starIfUnknown k = k -- | Infer a kind for a type -infer :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)]) +infer + :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) + => Type + -> m (Kind, [(String, Kind)]) infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty -infer' :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)]) +infer' + :: forall m + . (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) + => Type + -> m (Kind, [(String, Kind)]) infer' (ForAll ident ty _) = do k1 <- freshKind Just moduleName <- checkCurrentModule <$> get @@ -250,7 +263,7 @@ infer' other = (, []) <$> go other return $ Row k1 go (ConstrainedType deps ty) = do forM_ deps $ \(className, tys) -> do - k <- go $ foldl TypeApp (TypeConstructor className) tys + k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys unifyKinds k Star k <- go ty unifyKinds k Star diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 57354c150f..752e9be53d 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -1,18 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker.Monad --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- Monads for type checking and type inference and associated data types --- ------------------------------------------------------------------------------ - {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} @@ -20,6 +5,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +-- | +-- Monads for type checking and type inference and associated data types +-- module Language.PureScript.TypeChecker.Monad where import Prelude () @@ -69,7 +57,11 @@ emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution type Unknown = Int -- | Temporarily bind a collection of names to values -bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a +bindNames + :: MonadState CheckState m + => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) + -> m a + -> m a bindNames newNames action = do orig <- get modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } } @@ -78,7 +70,11 @@ bindNames newNames action = do return a -- | Temporarily bind a collection of names to types -bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a +bindTypes + :: MonadState CheckState m + => M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) + -> m a + -> m a bindTypes newNames action = do orig <- get modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } } @@ -87,7 +83,12 @@ bindTypes newNames action = do return a -- | Temporarily bind a collection of names to types -withScopedTypeVars :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName -> [(String, Kind)] -> m a -> m a +withScopedTypeVars + :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m) + => ModuleName + -> [(String, Kind)] + -> m a + -> m a withScopedTypeVars mn ks ma = do orig <- get forM_ ks $ \(name, _) -> @@ -96,7 +97,11 @@ withScopedTypeVars mn ks ma = do bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma -- | Temporarily make a collection of type class dictionaries available -withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a +withTypeClassDictionaries + :: MonadState CheckState m + => [TypeClassDictionaryInScope] + -> m a + -> m a withTypeClassDictionaries entries action = do orig <- get let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdName entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ] @@ -106,25 +111,35 @@ withTypeClassDictionaries entries action = do return a -- | Get the currently available map of type class dictionaries -getTypeClassDictionaries :: - (Functor m, MonadState CheckState m) => - m (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))) +getTypeClassDictionaries + :: (Functor m, MonadState CheckState m) + => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))) getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get -- | Lookup type class dictionaries in a module. -lookupTypeClassDictionaries :: - (Functor m, MonadState CheckState m) => - Maybe ModuleName -> - m (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) +lookupTypeClassDictionaries + :: (Functor m, MonadState CheckState m) + => Maybe ModuleName + -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get -- | Temporarily bind a collection of names to local variables -bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a +bindLocalVariables + :: (Functor m, MonadState CheckState m) + => ModuleName + -> [(Ident, Type, NameVisibility)] + -> m a + -> m a bindLocalVariables moduleName bindings = bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility))) -- | Temporarily bind a collection of names to local type variables -bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a +bindLocalTypeVariables + :: (Functor m, MonadState CheckState m) + => ModuleName + -> [(ProperName 'TypeName, Kind)] + -> m a + -> m a bindLocalTypeVariables moduleName bindings = bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable))) @@ -145,7 +160,11 @@ preservingNames action = do return a -- | Lookup the type of a value by name in the @Environment@ -lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type +lookupVariable + :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) + => ModuleName + -> Qualified Ident + -> m Type lookupVariable currentModule (Qualified moduleName var) = do env <- getEnv case M.lookup (fromMaybe currentModule moduleName, var) (names env) of @@ -153,7 +172,11 @@ lookupVariable currentModule (Qualified moduleName var) = do Just (ty, _, _) -> return ty -- | Lookup the visibility of a value by name in the @Environment@ -getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility +getVisibility + :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) + => ModuleName + -> Qualified Ident + -> m NameVisibility getVisibility currentModule (Qualified moduleName var) = do env <- getEnv case M.lookup (fromMaybe currentModule moduleName, var) (names env) of @@ -161,7 +184,11 @@ getVisibility currentModule (Qualified moduleName var) = do Just (_, _, vis) -> return vis -- | Assert that a name is visible -checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m () +checkVisibility + :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) + => ModuleName + -> Qualified Ident + -> m () checkVisibility currentModule name@(Qualified _ var) = do vis <- getVisibility currentModule name case vis of @@ -169,7 +196,11 @@ checkVisibility currentModule name@(Qualified _ var) = do _ -> return () -- | Lookup the kind of a type by name in the @Environment@ -lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind +lookupTypeVariable + :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) + => ModuleName + -> Qualified (ProperName 'TypeName) + -> m Kind lookupTypeVariable currentModule (Qualified moduleName name) = do env <- getEnv case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index d9671cae76..fbeb3210a6 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -468,11 +468,12 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty -- | -- Check the type of a value -- -check' :: forall m. - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - Expr -> - Type -> - m Expr +check' + :: forall m + . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Expr + -> Type + -> m Expr check' val (ForAll ident ty _) = do scope <- newSkolemScope sko <- newSkolemConstant @@ -492,7 +493,11 @@ check' val t@(ConstrainedType constraints ty) = do where -- | Add a dictionary for the constraint to the scope, and dictionaries -- for all implied superclass instances. - newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> m [TypeClassDictionaryInScope] + newDictionaries + :: [(Qualified (ProperName 'ClassName), Integer)] + -> Qualified Ident + -> (Qualified (ProperName 'ClassName), [Type]) + -> m [TypeClassDictionaryInScope] newDictionaries path name (className, instanceTy) = do tcs <- gets (typeClasses . checkEnv) let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 6c0ccd5eae..b556a89228 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -1,17 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeClassDictionaries --- Copyright : (c) 2014 Phil Freeman --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - {-# LANGUAGE DeriveDataTypeable #-} module Language.PureScript.TypeClassDictionaries where @@ -29,9 +15,9 @@ data TypeClassDictionaryInScope -- | The identifier with which the dictionary can be accessed at runtime tcdName :: Qualified Ident -- | How to obtain this instance via superclass relationships - , tcdPath :: [(Qualified ProperName, Integer)] + , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)] -- | The name of the type class to which this type class instance applies - , tcdClassName :: Qualified ProperName + , tcdClassName :: Qualified (ProperName 'ClassName) -- | The types to which this type class instance applies , tcdInstanceTypes :: [Type] -- | Type class dependencies which must be satisfied to construct this dictionary @@ -58,5 +44,5 @@ data DictionaryValue -- | -- A subclass dictionary -- - | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer + | SubclassDictionaryValue DictionaryValue (Qualified (ProperName 'ClassName)) Integer deriving (Show, Read, Ord, Eq) diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 7727cff115..1d817b939b 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -1,22 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Types --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- Data types for types --- ------------------------------------------------------------------------------ - {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} +-- | +-- Data types for types +-- module Language.PureScript.Types where import Prelude () @@ -60,7 +48,7 @@ data Type -- | -- A type constructor -- - | TypeConstructor (Qualified ProperName) + | TypeConstructor (Qualified (ProperName 'TypeName)) -- | -- A type application -- @@ -106,7 +94,7 @@ data Type -- | -- A typeclass constraint -- -type Constraint = (Qualified ProperName, [Type]) +type Constraint = (Qualified (ProperName 'ClassName), [Type]) $(A.deriveJSON A.defaultOptions ''Type) From 95f2b12cfe94cb4394bdf4fa346a401518c24652 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Thu, 31 Dec 2015 20:01:31 +0000 Subject: [PATCH 0232/1580] Remove errorlink in JSON to separate field --- psc/JSON.hs | 4 +++- src/Language/PureScript/Errors.hs | 26 +++++++++++++++----------- 2 files changed, 18 insertions(+), 12 deletions(-) diff --git a/psc/JSON.hs b/psc/JSON.hs index 9239be550c..f07a084e11 100644 --- a/psc/JSON.hs +++ b/psc/JSON.hs @@ -34,6 +34,7 @@ data JSONError = JSONError { position :: Maybe ErrorPosition , message :: String , errorCode :: String + , errorLink :: String , filename :: Maybe String , moduleName :: Maybe String } @@ -53,8 +54,9 @@ toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErro toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError toJSONError verbose level e = JSONError (toErrorPosition <$> sspan) - (P.renderBox (P.prettyPrintSingleError verbose level (P.stripModuleAndSpan e))) + (P.renderBox (P.prettyPrintSingleError verbose level False (P.stripModuleAndSpan e))) (P.errorCode e) + (P.wikiUri e) (P.spanName <$> sspan) (P.runModuleName <$> P.errorModule e) where diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 2e2978b8e5..d2050967af 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -414,11 +414,16 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts gHint other = pure other + +wikiUri :: ErrorMessage -> String +wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e + + -- | -- Pretty print a single error, simplifying if necessary -- -prettyPrintSingleError :: Bool -> Level -> ErrorMessage -> Box.Box -prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do +prettyPrintSingleError :: Bool -> Level -> Bool -> ErrorMessage -> Box.Box +prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap $ do em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) um <- get return (prettyPrintErrorMessage um em) @@ -427,17 +432,16 @@ prettyPrintSingleError full level e = flip evalState defaultUnknownMap $ do -- Pretty print an ErrorMessage prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box prettyPrintErrorMessage typeMap (ErrorMessage hints simple) = - paras + paras $ [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints , Box.moveDown 1 typeInformation - , Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri ++ " for more information, " - , line $ "or to contribute content related to this " ++ levelText ++ "." - ] + ] ++ + [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri e ++ " for more information, " + , line $ "or to contribute content related to this " ++ levelText ++ "." + ] + | showWiki ] where - wikiUri :: String - wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e - typeInformation :: Box.Box typeInformation | not (null types) = Box.hsep 1 Box.left [ line "where", paras types] | otherwise = Box.emptyBox 0 0 @@ -1072,12 +1076,12 @@ prettyPrintMultipleErrorsBox full = prettyPrintMultipleErrorsWith Error "Error f prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> Box.Box prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = - let result = prettyPrintSingleError full level e + let result = prettyPrintSingleError full level True e in Box.vcat Box.left [ Box.text intro , result ] prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = - let result = map (prettyPrintSingleError full level) es + let result = map (prettyPrintSingleError full level True) es in Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result where withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":") From d1a956da45c3eb49503837480df4fbea29e85d3b Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Thu, 31 Dec 2015 21:08:38 +0000 Subject: [PATCH 0233/1580] Remove Data/Typeable deriving --- src/Language/PureScript/AST/Binders.hs | 7 ++---- src/Language/PureScript/AST/Declarations.hs | 21 ++++++++-------- src/Language/PureScript/AST/Operators.hs | 25 ++++++------------- src/Language/PureScript/AST/SourcePos.hs | 23 ++++------------- src/Language/PureScript/CodeGen/JS/AST.hs | 24 +++++------------- src/Language/PureScript/Comments.hs | 20 +++------------ src/Language/PureScript/CoreFn/Binders.hs | 6 ++--- src/Language/PureScript/CoreFn/Expr.hs | 12 ++++----- src/Language/PureScript/CoreFn/Literals.hs | 23 ++++------------- src/Language/PureScript/CoreFn/Meta.hs | 25 +++++-------------- src/Language/PureScript/Environment.hs | 10 ++++---- src/Language/PureScript/Kinds.hs | 19 ++------------ src/Language/PureScript/Names.hs | 13 +++++----- .../PureScript/TypeClassDictionaries.hs | 7 ++---- src/Language/PureScript/Types.hs | 8 +++--- 15 files changed, 73 insertions(+), 170 deletions(-) diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index c4adadd922..d0b6b81c19 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -1,12 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -- | -- Case binders -- module Language.PureScript.AST.Binders where -import qualified Data.Data as D - import Language.PureScript.AST.SourcePos import Language.PureScript.Names import Language.PureScript.Comments @@ -63,7 +59,8 @@ data Binder -- | -- A binder with a type annotation -- - | TypedBinder Type Binder deriving (Show, Read, Eq, D.Data, D.Typeable) + | TypedBinder Type Binder + deriving (Show, Read, Eq) -- | -- Collect all names introduced in binders in an expression diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 3a0cd34646..a75d5dd08f 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE LambdaCase #-} @@ -15,7 +14,6 @@ import Data.Aeson.TH import Data.List (nub, (\\)) import Data.Maybe (mapMaybe) -import qualified Data.Data as D import qualified Data.Map as M import Control.Monad.Identity @@ -35,7 +33,8 @@ import Language.PureScript.Environment -- a list of declarations, and a list of the declarations that are -- explicitly exported. If the export list is Nothing, everything is exported. -- -data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, Read, D.Data, D.Typeable) +data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) + deriving (Show, Read) -- | Return a module's name. getModuleName :: Module -> ModuleName @@ -85,7 +84,7 @@ data DeclarationRef -- A declaration reference with source position information -- | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef - deriving (Show, Read, D.Data, D.Typeable) + deriving (Show, Read) instance Eq DeclarationRef where (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors' @@ -141,7 +140,7 @@ data ImportDeclarationType -- An import with a list of references to hide: `import M hiding (foo)` -- | Hiding [DeclarationRef] - deriving (Eq, Show, Read, D.Data, D.Typeable) + deriving (Eq, Show, Read) isImplicit :: ImportDeclarationType -> Bool isImplicit Implicit = True @@ -205,7 +204,7 @@ data Declaration -- A declaration with source position information -- | PositionedDeclaration SourceSpan [Comment] Declaration - deriving (Show, Read, D.Data, D.Typeable) + deriving (Show, Read) -- | The members of a type class instance declaration data TypeInstanceBody @@ -213,7 +212,7 @@ data TypeInstanceBody = DerivedInstance -- | This is a regular (explicit) instance | ExplicitInstance [Declaration] - deriving (Show, Read, D.Data, D.Typeable) + deriving (Show, Read) mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f) @@ -432,7 +431,8 @@ data Expr -- | -- A value with source position information -- - | PositionedValue SourceSpan [Comment] Expr deriving (Show, Read, D.Data, D.Typeable) + | PositionedValue SourceSpan [Comment] Expr + deriving (Show, Read) -- | -- An alternative in a case statement @@ -446,7 +446,7 @@ data CaseAlternative = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: Either [(Guard, Expr)] Expr - } deriving (Show, Read, D.Data, D.Typeable) + } deriving (Show, Read) -- | -- A statement in a do-notation block @@ -467,7 +467,8 @@ data DoNotationElement -- | -- A do notation element with source position information -- - | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, Read, D.Data, D.Typeable) + | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement + deriving (Show, Read) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType) diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs index 2afae9a366..241f6c44e6 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -1,23 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.AST.Operators --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | Operators fixity and associativity --- ------------------------------------------------------------------------------ - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Operators fixity and associativity +-- module Language.PureScript.AST.Operators where -import qualified Data.Data as D import Data.Aeson ((.=)) import qualified Data.Aeson as A @@ -31,7 +18,8 @@ type Precedence = Integer -- | -- Associativity for infix operators -- -data Associativity = Infixl | Infixr | Infix deriving (Show, Read, Eq, Ord, D.Data, D.Typeable) +data Associativity = Infixl | Infixr | Infix + deriving (Show, Read, Eq, Ord) showAssoc :: Associativity -> String showAssoc Infixl = "infixl" @@ -53,7 +41,8 @@ instance A.FromJSON Associativity where -- | -- Fixity data for infix operators -- -data Fixity = Fixity Associativity Precedence deriving (Show, Read, Eq, Ord, D.Data, D.Typeable) +data Fixity = Fixity Associativity Precedence + deriving (Show, Read, Eq, Ord) instance A.ToJSON Fixity where toJSON (Fixity associativity precedence) = diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 10fd8c9699..35d5903421 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -1,28 +1,15 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.AST.SourcePos --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | Source position information --- ------------------------------------------------------------------------------ - -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +-- | +-- Source position information +-- module Language.PureScript.AST.SourcePos where import Prelude () import Prelude.Compat -import qualified Data.Data as D import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A @@ -38,7 +25,7 @@ data SourcePos = SourcePos -- Column number -- , sourcePosColumn :: Int - } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable) + } deriving (Show, Read, Eq, Ord) displaySourcePos :: SourcePos -> String displaySourcePos sp = @@ -66,7 +53,7 @@ data SourceSpan = SourceSpan -- End of the span -- , spanEnd :: SourcePos - } deriving (Show, Read, Eq, Ord, D.Data, D.Typeable) + } deriving (Show, Read, Eq, Ord) displayStartEndPos :: SourceSpan -> String displayStartEndPos sp = diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index a5ec412cdd..3b8236d6ae 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -1,27 +1,12 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen.JS.AST --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Data types for the intermediate simplified-Javascript AST -- ------------------------------------------------------------------------------ - -{-# LANGUAGE DeriveDataTypeable #-} - module Language.PureScript.CodeGen.JS.AST where import Prelude () import Prelude.Compat import Control.Monad.Identity -import Data.Data import Language.PureScript.Comments import Language.PureScript.Traversals @@ -49,7 +34,8 @@ data UnaryOperator -- | -- Constructor -- - | JSNew deriving (Show, Read, Eq, Data, Typeable) + | JSNew + deriving (Show, Read, Eq) -- | -- Built-in binary operators @@ -130,7 +116,8 @@ data BinaryOperator -- | -- Bitwise right shift with zero-fill -- - | ZeroFillShiftRight deriving (Show, Read, Eq, Data, Typeable) + | ZeroFillShiftRight + deriving (Show, Read, Eq) -- | -- Data type for simplified Javascript expressions @@ -251,7 +238,8 @@ data JS -- | -- Commented Javascript -- - | JSComment [Comment] JS deriving (Show, Read, Eq, Data, Typeable) + | JSComment [Comment] JS + deriving (Show, Read, Eq) -- -- Traversals diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs index 351731be27..2e72595f98 100644 --- a/src/Language/PureScript/Comments.hs +++ b/src/Language/PureScript/Comments.hs @@ -1,29 +1,15 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Parser.Comments --- Copyright : (c) Phil Freeman 2015 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE TemplateHaskell #-} + -- | -- Defines the types of source code comments -- ------------------------------------------------------------------------------ - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} - module Language.PureScript.Comments where import Data.Aeson.TH -import qualified Data.Data as D data Comment = LineComment String | BlockComment String - deriving (Show, Read, Eq, Ord, D.Data, D.Typeable) + deriving (Show, Read, Eq, Ord) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment) diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index 5126f0e111..15b833de47 100644 --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} -- | @@ -6,8 +5,6 @@ -- module Language.PureScript.CoreFn.Binders where -import qualified Data.Data as D - import Language.PureScript.CoreFn.Literals import Language.PureScript.Names @@ -34,4 +31,5 @@ data Binder a -- | -- A binder which binds its input to an identifier -- - | NamedBinder a Ident (Binder a) deriving (Show, Read, D.Data, D.Typeable, Functor) + | NamedBinder a Ident (Binder a) + deriving (Show, Read, Functor) diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index 65f0695c8d..2445556e7e 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} -- | @@ -8,8 +7,6 @@ module Language.PureScript.CoreFn.Expr where import Control.Arrow ((***)) -import qualified Data.Data as D - import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Literals import Language.PureScript.Names @@ -53,7 +50,8 @@ data Expr a -- | -- A let binding -- - | Let a [Bind a] (Expr a) deriving (Show, Read, D.Data, D.Typeable, Functor) + | Let a [Bind a] (Expr a) + deriving (Show, Read, Functor) -- | -- A let or module binding. @@ -66,7 +64,8 @@ data Bind a -- | -- Mutually recursive binding group for several values -- - | Rec [(Ident, Expr a)] deriving (Show, Read, D.Data, D.Typeable, Functor) + | Rec [(Ident, Expr a)] + deriving (Show, Read, Functor) -- | -- A guard is just a boolean-valued expression that appears alongside a set of binders @@ -85,7 +84,8 @@ data CaseAlternative a = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a) - } deriving (Show, Read, D.Data, D.Typeable) + } + deriving (Show, Read) instance Functor CaseAlternative where diff --git a/src/Language/PureScript/CoreFn/Literals.hs b/src/Language/PureScript/CoreFn/Literals.hs index 7f49c0c814..cdc71b40ce 100644 --- a/src/Language/PureScript/CoreFn/Literals.hs +++ b/src/Language/PureScript/CoreFn/Literals.hs @@ -1,24 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CoreFn.Literals --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | The core functional representation for literal values. --- ------------------------------------------------------------------------------ - -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} +-- | +-- The core functional representation for literal values. +-- module Language.PureScript.CoreFn.Literals where -import qualified Data.Data as D - -- | -- Data type for literal values. Parameterised so it can be used for Exprs and -- Binders. @@ -47,4 +33,5 @@ data Literal a -- | -- An object literal -- - | ObjectLiteral [(String, a)] deriving (Show, Read, D.Data, D.Typeable, Functor) + | ObjectLiteral [(String, a)] + deriving (Show, Read, Functor) diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs index bbd2abe634..91d77a0aa4 100644 --- a/src/Language/PureScript/CoreFn/Meta.hs +++ b/src/Language/PureScript/CoreFn/Meta.hs @@ -1,23 +1,8 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CoreFn.Meta --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | Metadata annotations for core functional representation +-- | +-- Metadata annotations for core functional representation -- ------------------------------------------------------------------------------ - -{-# LANGUAGE DeriveDataTypeable #-} - module Language.PureScript.CoreFn.Meta where -import qualified Data.Data as D - import Language.PureScript.Names -- | @@ -39,7 +24,8 @@ data Meta -- | -- The contained reference is for a foreign member -- - | IsForeign deriving (Show, Read, D.Data, D.Typeable) + | IsForeign + deriving (Show, Read) -- | -- Data constructor metadata @@ -52,4 +38,5 @@ data ConstructorType -- | -- The constructor is for a type with multiple construcors -- - | SumType deriving (Show, Read, D.Data, D.Typeable) + | SumType + deriving (Show, Read) diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index b133db1f60..56f48f0202 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Environment where -import Data.Data import Data.Maybe (fromMaybe) import Data.Aeson.TH import qualified Data.Map as M @@ -84,7 +82,8 @@ data NameKind -- | -- A name for member introduced by foreign import -- - | External deriving (Show, Read, Eq, Data, Typeable) + | External + deriving (Show, Read, Eq) -- | -- The kinds of a type @@ -110,7 +109,7 @@ data TypeKind -- A scoped type variable -- | ScopedTypeVar - deriving (Show, Read, Eq, Data, Typeable) + deriving (Show, Read, Eq) -- | -- The type ('data' or 'newtype') of a data type declaration @@ -123,7 +122,8 @@ data DataDeclType -- | -- A newtype constructor -- - | Newtype deriving (Show, Read, Eq, Ord, Data, Typeable) + | Newtype + deriving (Show, Read, Eq, Ord) showDataDeclType :: DataDeclType -> String showDataDeclType Data = "data" diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index bf37e4801c..c19c773cd7 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -1,18 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Kinds --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Kinds where @@ -20,7 +5,6 @@ module Language.PureScript.Kinds where import Prelude () import Prelude.Compat -import Data.Data import qualified Data.Aeson.TH as A -- | @@ -46,7 +30,8 @@ data Kind -- | -- Function kinds -- - | FunKind Kind Kind deriving (Show, Read, Eq, Ord, Data, Typeable) + | FunKind Kind Kind + deriving (Show, Read, Eq, Ord) $(A.deriveJSON A.defaultOptions ''Kind) diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index a4090755b1..99a55c771f 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE EmptyDataDecls #-} @@ -13,7 +12,6 @@ import Control.Monad (liftM) import Control.Monad.Supply.Class import Data.List -import Data.Data import Data.Aeson import Data.Aeson.TH @@ -32,7 +30,8 @@ data Ident -- | -- A generated name for an identifier -- - | GenIdent (Maybe String) Integer deriving (Show, Read, Eq, Ord, Data, Typeable) + | GenIdent (Maybe String) Integer + deriving (Show, Read, Eq, Ord) runIdent :: Ident -> String runIdent (Ident i) = i @@ -54,7 +53,7 @@ freshIdent' = liftM (GenIdent Nothing) fresh -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. -- newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String } - deriving (Show, Read, Eq, Ord, Data, Typeable) + deriving (Show, Read, Eq, Ord) instance ToJSON (ProperName a) where toJSON = toJSON . runProperName @@ -78,7 +77,8 @@ coerceProperName = ProperName . runProperName -- | -- Module names -- -newtype ModuleName = ModuleName [ProperName 'Namespace] deriving (Show, Read, Eq, Ord, Data, Typeable) +newtype ModuleName = ModuleName [ProperName 'Namespace] + deriving (Show, Read, Eq, Ord) runModuleName :: ModuleName -> String runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns) @@ -94,7 +94,8 @@ moduleNameFromString = ModuleName . splitProperNames -- | -- A qualified name, i.e. a name with an optional module name -- -data Qualified a = Qualified (Maybe ModuleName) a deriving (Show, Read, Eq, Ord, Data, Typeable, Functor) +data Qualified a = Qualified (Maybe ModuleName) a + deriving (Show, Read, Eq, Ord, Functor) showQualified :: (a -> String) -> Qualified a -> String showQualified f (Qualified Nothing a) = f a diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index b556a89228..19ac0461bb 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -1,9 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable #-} - module Language.PureScript.TypeClassDictionaries where -import Data.Data - import Language.PureScript.Names import Language.PureScript.Types @@ -22,7 +18,8 @@ data TypeClassDictionaryInScope , tcdInstanceTypes :: [Type] -- | Type class dependencies which must be satisfied to construct this dictionary , tcdDependencies :: Maybe [Constraint] - } deriving (Show, Read, Data, Typeable) + } + deriving (Show, Read) -- | -- A simplified representation of expressions which are used to represent type diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 1d817b939b..f2505ed2c6 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -10,7 +9,6 @@ module Language.PureScript.Types where import Prelude () import Prelude.Compat -import Data.Data import Data.List (nub) import Data.Maybe (fromMaybe) import qualified Data.Aeson as A @@ -27,7 +25,8 @@ import Language.PureScript.AST.SourcePos -- | -- An identifier for the scope of a skolem variable -- -newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Read, Eq, Ord, Data, Typeable, A.ToJSON, A.FromJSON) +newtype SkolemScope = SkolemScope { runSkolemScope :: Int } + deriving (Show, Read, Eq, Ord, A.ToJSON, A.FromJSON) -- | -- The type of types @@ -89,7 +88,8 @@ data Type -- | -- A placeholder used in pretty printing -- - | PrettyPrintForAll [String] Type deriving (Show, Read,Eq, Ord, Data, Typeable) + | PrettyPrintForAll [String] Type + deriving (Show, Read, Eq, Ord) -- | -- A typeclass constraint From 526e700e6669c5741da398b0e3a665b6a1fea653 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Thu, 31 Dec 2015 23:23:21 +0000 Subject: [PATCH 0234/1580] Fix #1779 spurious UnusedDctorImport --- src/Language/PureScript/Linter/Imports.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 283beda50a..d48239ab0e 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -84,7 +84,7 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do let allCtors = dctorsForType mni tn when (runProperName tn `elem` usedNames) $ case (c, usedDctors `intersect` allCtors) of - (_, []) -> + (_, []) | c /= Just [] -> tell $ errorMessage $ UnusedDctorImport tn (Nothing, usedDctors') -> tell $ errorMessage $ ImplicitDctorImport tn usedDctors' From a98f28a3c81fd67f6d87852a670a24291dffb379 Mon Sep 17 00:00:00 2001 From: Pascal Hartig Date: Thu, 31 Dec 2015 20:32:03 +0100 Subject: [PATCH 0235/1580] Allow https://github.com URLs for psc-publish Follow-up to #1549, #1752. The HTTPS git access is preferable in a lot of network scenarios (e.g. public WiFi) where other ports are restricted and should work just fine as only read access is needed. --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Publish.hs | 17 ++++++++++------- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index e7e8d262d3..6a000bc2aa 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -61,6 +61,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 0fba2bba7a..7b3a8194e4 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -41,7 +41,6 @@ import qualified Data.Text.Lazy.Encoding as TL import Control.Category ((>>>)) import Control.Arrow ((***)) -import Control.Applicative ((<|>)) import Control.Exception (catch, try) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.Except @@ -197,8 +196,7 @@ getBowerInfo = either (userError . BadRepositoryField) return . tryExtract maybe (Left NotOnGithub) Right (extractGithub repositoryUrl) extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo) -extractGithub = - matchUrl +extractGithub = stripGitHubPrefixes >>> fmap (splitOn "/") >=> takeTwo >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit)) @@ -208,15 +206,20 @@ extractGithub = takeTwo [x, y] = Just (x, y) takeTwo _ = Nothing + stripGitHubPrefixes :: String -> Maybe String + stripGitHubPrefixes = stripPrefixes [ "git://github.com/" + , "https://github.com/" + , "git@github.com:" + ] + + stripPrefixes :: [String] -> String -> Maybe String + stripPrefixes prefixes str = msum $ (`stripPrefix` str) <$> prefixes + dropDotGit :: String -> String dropDotGit str | ".git" `isSuffixOf` str = take (length str - 4) str | otherwise = str - matchUrl :: String -> Maybe String - matchUrl str = - stripPrefix "git@github.com:" str <|> stripPrefix "git://github.com/" str - readProcess' :: String -> [String] -> String -> PrepareM String readProcess' prog args stdin = do out <- liftIO (catch (Right <$> readProcess prog args stdin) From 9cf87653e91834c61b325865891ab75f203b8b9f Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 2 Jan 2016 22:39:25 +0000 Subject: [PATCH 0236/1580] Remove warning about implicitly importing data constructors The warning is obnoxious and does not help with the safety issue the same way implicit module imports does, as per later discussion in #1741 --- src/Language/PureScript/Errors.hs | 7 ------- src/Language/PureScript/Linter/Imports.hs | 3 +-- 2 files changed, 1 insertion(+), 9 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index e9a6c3914c..ccd977295b 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -139,7 +139,6 @@ data SimpleErrorMessage | IntOutOfRange Integer String Integer Integer | RedundantEmptyHidingImport ModuleName | ImplicitImport ModuleName [DeclarationRef] - | ImplicitDctorImport (ProperName 'TypeName) [ProperName 'ConstructorName] | CaseBinderLengthDiffers Int [Binder] deriving (Show) @@ -311,7 +310,6 @@ errorCode em = case unwrapErrorMessage em of IntOutOfRange{} -> "IntOutOfRange" RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport" ImplicitImport{} -> "ImplicitImport" - ImplicitDctorImport{} -> "ImplicitDctorImport" CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers" -- | @@ -865,11 +863,6 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ] - renderSimpleErrorMessage (ImplicitDctorImport ty ctors) = - paras [ line $ "Import of type " ++ runProperName ty ++ " has unspecified data constructors, consider using the explicit form: " - , indent $ line $ runProperName ty ++ " (" ++ intercalate ", " (map runProperName ctors) ++ ")" - ] - renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) = paras $ [ line $ "Binder list length differs in case alternative:" , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 6145cdbb60..485c4d9499 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -86,11 +86,10 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do when (runProperName tn `elem` usedNames) $ case (c, usedDctors `intersect` allCtors) of (_, []) | c /= Just [] -> tell $ errorMessage $ UnusedDctorImport tn - (Nothing, usedDctors') -> - tell $ errorMessage $ ImplicitDctorImport tn usedDctors' (Just ctors, usedDctors') -> let ddiff = ctors \\ usedDctors' in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff + _ -> return () return () From 0e0a7233a182603d0041d5362460b121197c23b8 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 3 Jan 2016 16:18:54 +0000 Subject: [PATCH 0237/1580] Better unused import warnings --- src/Language/PureScript/Linter/Imports.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 6145cdbb60..1931e62d79 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -71,7 +71,12 @@ findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do typesRefs = map (flip TypeRef (Just [])) typesWithoutDctors ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors) - in tell $ errorMessage $ ImplicitImport mni (classRefs ++ typesRefs ++ valueRefs) + allRefs = classRefs ++ typesRefs ++ valueRefs + in tell $ errorMessage $ + if null allRefs + then UnusedImport mni + else ImplicitImport mni allRefs + Explicit [] -> tell $ errorMessage $ UnusedImport mni Explicit declrefs -> do let idents = nub (mapMaybe runDeclRef declrefs) let diff = idents \\ usedNames From 2d5f547e8ab2221d9f29431ed25c33f3c1bc4c81 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 29 Dec 2015 08:03:45 +0000 Subject: [PATCH 0238/1580] Add desugarImports variant which produces an Env Add a variant of Language.PureScript.Sugar.Names.desugarImports which also returns the Env, built up during desugaring imports. We also export Env and related types (Imports, Exports), so that people can get useful information out of the the Env value in this new variant. --- src/Language/PureScript/Sugar/Names.hs | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 155fccf843..13b8b87b82 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -1,8 +1,15 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} -module Language.PureScript.Sugar.Names (desugarImports) where +module Language.PureScript.Sugar.Names + ( desugarImports + , desugarImportsWithEnv + , Env + , Imports(..) + , Exports(..) + ) where import Prelude () import Prelude.Compat @@ -35,11 +42,20 @@ import Language.PureScript.Linter.Imports -- modules should be topologically sorted beforehand. -- desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] -desugarImports externs modules = do +desugarImports externs modules = + fmap snd (desugarImportsWithEnv externs modules) + +desugarImportsWithEnv + :: forall m + . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => [ExternsFile] + -> [Module] + -> m (Env, [Module]) +desugarImportsWithEnv externs modules = do env <- silence $ foldM externsEnv primEnv externs modules' <- traverse updateExportRefs modules (modules'', env') <- foldM updateEnv ([], env) modules' - traverse (renameInModule' env') modules'' + (env',) <$> traverse (renameInModule' env') modules'' where silence :: m a -> m a silence = censor (const mempty) From 4c1d5affe1ed5db1c5ab48fb5776685f517e5602 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 29 Dec 2015 08:36:36 +0000 Subject: [PATCH 0239/1580] Refactor parseAndDesugar * Generalised to work with any Monad which has both MonadIO and MonadError MultipleErrors instances * Remove the useless callback parameter; now, just return the modules and bookmarks instead. --- psc-docs/Main.hs | 5 +- purescript.cabal | 3 +- .../PureScript/Docs/ParseAndDesugar.hs | 49 +++++++++++-------- src/Language/PureScript/Publish.hs | 15 ++++-- 4 files changed, 44 insertions(+), 28 deletions(-) diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index 23db235b09..4d06ce3733 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -16,6 +16,7 @@ module Main where import Control.Applicative +import Control.Monad.Trans.Except (runExceptT) import Control.Arrow (first, second) import Control.Category ((>>>)) import Control.Monad.Writer @@ -68,12 +69,12 @@ docgen (PSCDocsOptions fmt inputGlob output) = do Etags -> dumpTags input dumpEtags Ctags -> dumpTags input dumpCtags Markdown -> do - e <- D.parseAndDesugar input [] (\_ ms -> return ms) + e <- liftIO . runExceptT $ D.parseAndDesugar input [] case e of Left err -> do hPutStrLn stderr $ P.prettyPrintMultipleErrors False err exitFailure - Right ms' -> + Right (ms', _) -> case output of EverythingToStdOut -> putStrLn (D.renderModulesAsMarkdown ms') diff --git a/purescript.cabal b/purescript.cabal index 69d75cff5d..a4fa0dbd04 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -220,7 +220,8 @@ executable psc-docs build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0, process -any, mtl -any, split -any, ansi-wl-pprint -any, directory -any, - filepath -any, Glob -any + filepath -any, Glob -any, transformers -any, + transformers-compat -any main-is: Main.hs buildable: True hs-source-dirs: psc-docs diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndDesugar.hs index 8a7c3b1c59..3bed0eff77 100644 --- a/src/Language/PureScript/Docs/ParseAndDesugar.hs +++ b/src/Language/PureScript/Docs/ParseAndDesugar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} module Language.PureScript.Docs.ParseAndDesugar ( parseAndDesugar @@ -11,7 +12,6 @@ import qualified Data.Map as M import Control.Arrow (first) import Control.Monad -import Control.Monad.Trans.Except import Control.Monad.Writer.Strict (runWriterT) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) @@ -29,40 +29,40 @@ import Language.PureScript.Docs.Convert (collectBookmarks) -- * A list of local source files -- * A list of source files from external dependencies, together with their -- package names --- * A callback, taking a list of bookmarks, and a list of desugared modules -- -- This function does the following: -- -- * Parse all of the input and dependency source files --- * Partially desugar all of the resulting modules +-- * Partially desugar all of the resulting modules (just enough for +-- producing documentation from them) -- * Collect a list of bookmarks from the whole set of source files -- * Collect a list of desugared modules from just the input source files (not -- dependencies) --- * Call the callback with the bookmarks and desugared module list. +-- * Return the desugared modules and the bookmarks. parseAndDesugar :: + (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) => [FilePath] -> [(PackageName, FilePath)] - -> ([Bookmark] -> [P.Module] -> IO a) - -> IO (Either P.MultipleErrors a) -parseAndDesugar inputFiles depsFiles callback = do + -> m ([P.Module], [Bookmark]) +parseAndDesugar inputFiles depsFiles = do inputFiles' <- traverse (parseAs Local) inputFiles depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles - runExceptT $ do - ms <- parseFiles (inputFiles' ++ depsFiles') - ms' <- sortModules (map snd ms) - (bs, ms'') <- desugarWithBookmarks ms ms' - liftIO $ callback bs ms'' + ms <- parseFiles (inputFiles' ++ depsFiles') + ms' <- sortModules (map snd ms) + desugarWithBookmarks ms ms' parseFiles :: + (MonadError P.MultipleErrors m, MonadIO m) => [(FileInfo, FilePath)] - -> ExceptT P.MultipleErrors IO [(FileInfo, P.Module)] + -> m [(FileInfo, P.Module)] parseFiles = throwLeft . P.parseModulesFromFiles fileInfoToString sortModules :: + (Functor m, MonadError P.MultipleErrors m, MonadIO m) => [P.Module] - -> ExceptT P.MultipleErrors IO [P.Module] + -> m [P.Module] sortModules = fmap fst . throwLeft . sortModules' . map importPrim where @@ -70,9 +70,10 @@ sortModules = sortModules' = P.sortModules desugarWithBookmarks :: + (MonadError P.MultipleErrors m, MonadIO m) => [(FileInfo, P.Module)] -> [P.Module] - -> ExceptT P.MultipleErrors IO ([Bookmark], [P.Module]) + -> m ([P.Module], [Bookmark]) desugarWithBookmarks msInfo msSorted = do msDesugared <- throwLeft (desugar msSorted) @@ -80,7 +81,7 @@ desugarWithBookmarks msInfo msSorted = do msPackages = map (addPackage msDeps) msDesugared bookmarks = concatMap collectBookmarks msPackages - return (bookmarks, takeLocals msPackages) + return (takeLocals msPackages, bookmarks) throwLeft :: (MonadError l m) => Either l r -> m r throwLeft = either throwError return @@ -101,18 +102,24 @@ fileInfoToString (FromDep _ fn) = fn importPrim :: P.Module -> P.Module importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim]) -desugar :: [P.Module] -> Either P.MultipleErrors [P.Module] +desugar :: + (Functor m, Applicative m, MonadError P.MultipleErrors m) => + [P.Module] + -> m [P.Module] desugar = P.evalSupplyT 0 . desugar' where - desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module] - desugar' = traverse P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports [] + desugar' = + traverse P.desugarDoModule + >=> P.desugarCasesModule + >=> ignoreWarnings . P.desugarImports [] + ignoreWarnings m = liftM fst (runWriterT m) parseFile :: FilePath -> IO (FilePath, String) parseFile input' = (,) input' <$> readFile input' -parseAs :: (FilePath -> a) -> FilePath -> IO (a, String) -parseAs g = fmap (first g) . parseFile +parseAs :: (Functor m, MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String) +parseAs g = fmap (first g) . liftIO . parseFile getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName getDepsModuleNames = foldl go M.empty diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 7b3a8194e4..94b55ec322 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -146,11 +146,18 @@ preparePackage' opts = do getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module]) getModulesAndBookmarks = do (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles - liftIO (D.parseAndDesugar inputFiles depsFiles renderModules) - >>= either (userError . CompileError) return + (modules', bookmarks) <- parseAndDesugar inputFiles depsFiles + + return (bookmarks, map D.convertModule modules') + where - renderModules bookmarks modules = - return (bookmarks, map D.convertModule modules) + parseAndDesugar inputFiles depsFiles = do + r <- liftIO . runExceptT $ D.parseAndDesugar inputFiles depsFiles + case r of + Right r' -> + return r' + Left err -> + userError (CompileError err) data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum) From 0f4e0fd062e84fbac3dd6217491b20db51cc0829 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 29 Dec 2015 08:40:57 +0000 Subject: [PATCH 0240/1580] Return the imports/exports Env in parseAndDesugar This new information will be necessary for documenting re-exports. --- psc-docs/Main.hs | 2 +- src/Language/PureScript/Docs/ParseAndDesugar.hs | 15 ++++++++------- src/Language/PureScript/Publish.hs | 2 +- 3 files changed, 10 insertions(+), 9 deletions(-) diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index 4d06ce3733..02caefc008 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -74,7 +74,7 @@ docgen (PSCDocsOptions fmt inputGlob output) = do Left err -> do hPutStrLn stderr $ P.prettyPrintMultipleErrors False err exitFailure - Right (ms', _) -> + Right (ms', _, _) -> case output of EverythingToStdOut -> putStrLn (D.renderModulesAsMarkdown ms') diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndDesugar.hs index 3bed0eff77..b5813ed54e 100644 --- a/src/Language/PureScript/Docs/ParseAndDesugar.hs +++ b/src/Language/PureScript/Docs/ParseAndDesugar.hs @@ -38,12 +38,13 @@ import Language.PureScript.Docs.Convert (collectBookmarks) -- * Collect a list of bookmarks from the whole set of source files -- * Collect a list of desugared modules from just the input source files (not -- dependencies) --- * Return the desugared modules and the bookmarks. +-- * Return the desugared modules, the bookmarks, and the imports/exports +-- Env (which is needed for producing documentation). parseAndDesugar :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) => [FilePath] -> [(PackageName, FilePath)] - -> m ([P.Module], [Bookmark]) + -> m ([P.Module], [Bookmark], P.Env) parseAndDesugar inputFiles depsFiles = do inputFiles' <- traverse (parseAs Local) inputFiles depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles @@ -73,15 +74,15 @@ desugarWithBookmarks :: (MonadError P.MultipleErrors m, MonadIO m) => [(FileInfo, P.Module)] -> [P.Module] - -> m ([P.Module], [Bookmark]) + -> m ([P.Module], [Bookmark], P.Env) desugarWithBookmarks msInfo msSorted = do - msDesugared <- throwLeft (desugar msSorted) + (env, msDesugared) <- throwLeft (desugar msSorted) let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo) msPackages = map (addPackage msDeps) msDesugared bookmarks = concatMap collectBookmarks msPackages - return (takeLocals msPackages, bookmarks) + return (takeLocals msPackages, bookmarks, env) throwLeft :: (MonadError l m) => Either l r -> m r throwLeft = either throwError return @@ -105,13 +106,13 @@ importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim]) desugar :: (Functor m, Applicative m, MonadError P.MultipleErrors m) => [P.Module] - -> m [P.Module] + -> m (P.Env, [P.Module]) desugar = P.evalSupplyT 0 . desugar' where desugar' = traverse P.desugarDoModule >=> P.desugarCasesModule - >=> ignoreWarnings . P.desugarImports [] + >=> ignoreWarnings . P.desugarImportsWithEnv [] ignoreWarnings m = liftM fst (runWriterT m) diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 94b55ec322..fe913d6187 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -146,7 +146,7 @@ preparePackage' opts = do getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module]) getModulesAndBookmarks = do (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles - (modules', bookmarks) <- parseAndDesugar inputFiles depsFiles + (modules', bookmarks, _) <- parseAndDesugar inputFiles depsFiles return (bookmarks, map D.convertModule modules') From 4fbebffe8b4d6c8c94358874f345aac6d3d5c782 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 31 Dec 2015 10:41:39 +0000 Subject: [PATCH 0241/1580] Make tests a bit easier to follow Clearly demarcate each section of the test suite. --- tests/Main.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/tests/Main.hs b/tests/Main.hs index b892d38cfb..3c4eb87316 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -172,9 +172,19 @@ assertDoesNotCompile inputFiles foreigns = do main :: IO () main = do + heading "Main compiler test suite" testCompiler + heading "psc-publish test suite" testPscPublish + where + heading msg = do + putStrLn "" + putStrLn $ replicate 79 '#' + putStrLn $ "# " ++ msg + putStrLn $ replicate 79 '#' + putStrLn "" + testCompiler :: IO () testCompiler = do fetchSupportCode From 2ed7800a3bdb14915e1806a6d98c30df9087973f Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 31 Dec 2015 10:42:51 +0000 Subject: [PATCH 0242/1580] Log to stdout during psc-publish tests This is what cabal seems to expect us to do. --- tests/TestPscPublish.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 43f53637be..657105d07e 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -60,6 +60,6 @@ testPackage dir = do case r of Pass _ -> pure () other -> do - hPutStrLn stderr ("psc-publish tests failed on " ++ dir ++ ":") - hPutStrLn stderr (show other) - exitFailure \ No newline at end of file + putStrLn ("psc-publish tests failed on " ++ dir ++ ":") + putStrLn (show other) + exitFailure From c3b8b3642a3e93eab25ad1ca21223c5a07ee263f Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 29 Dec 2015 14:43:25 +0000 Subject: [PATCH 0243/1580] Add tests for Language.PureScript.Docs In particular, tests for documentation for re-exports. --- .gitignore | 2 + .travis.yml | 2 + core-tests/test-everything.sh | 8 +- examples/docs/bower.json | 19 ++ .../purescript-prelude/src/Prelude.purs | 8 + examples/docs/src/Clash.purs | 32 +++ examples/docs/src/DuplicateNames.purs | 9 + examples/docs/src/Example.purs | 7 + examples/docs/src/Example2.purs | 7 + examples/docs/src/MultiVirtual.purs | 27 ++ examples/docs/src/NewOperators.purs | 12 + examples/docs/src/NotAllCtors.purs | 5 + examples/docs/src/OldOperators.purs | 10 + examples/docs/src/ReExportedTypeClass.purs | 5 + .../docs/src/SolitaryTypeClassMember.purs | 6 + examples/docs/src/SomeTypeClass.purs | 5 + examples/docs/src/Transitive1.purs | 5 + examples/docs/src/Transitive2.purs | 5 + examples/docs/src/Transitive3.purs | 4 + .../docs/src/TypeClassWithoutMembers.purs | 11 + examples/docs/src/UTF8.purs | 7 + examples/docs/src/Virtual.purs | 5 + purescript.cabal | 4 + tests/Main.hs | 8 +- tests/TestDocs.hs | 232 ++++++++++++++++++ 25 files changed, 441 insertions(+), 4 deletions(-) create mode 100644 examples/docs/bower.json create mode 100644 examples/docs/bower_components/purescript-prelude/src/Prelude.purs create mode 100644 examples/docs/src/Clash.purs create mode 100644 examples/docs/src/DuplicateNames.purs create mode 100644 examples/docs/src/Example.purs create mode 100644 examples/docs/src/Example2.purs create mode 100644 examples/docs/src/MultiVirtual.purs create mode 100644 examples/docs/src/NewOperators.purs create mode 100644 examples/docs/src/NotAllCtors.purs create mode 100644 examples/docs/src/OldOperators.purs create mode 100644 examples/docs/src/ReExportedTypeClass.purs create mode 100644 examples/docs/src/SolitaryTypeClassMember.purs create mode 100644 examples/docs/src/SomeTypeClass.purs create mode 100644 examples/docs/src/Transitive1.purs create mode 100644 examples/docs/src/Transitive2.purs create mode 100644 examples/docs/src/Transitive3.purs create mode 100644 examples/docs/src/TypeClassWithoutMembers.purs create mode 100644 examples/docs/src/UTF8.purs create mode 100644 examples/docs/src/Virtual.purs create mode 100644 tests/TestDocs.hs diff --git a/.gitignore b/.gitignore index c5a67d110c..a9cf995eff 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,5 @@ tmp/ .stack-work/ tests/support/flattened/ output +examples/docs/docs/ +core-tests/full-core-docs.md diff --git a/.travis.yml b/.travis.yml index 2bece9c0f5..9370ce0921 100644 --- a/.travis.yml +++ b/.travis.yml @@ -57,6 +57,8 @@ install: # Snapshot state of the sandbox now, so we don't need to make new one for test install - rm -rf ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none} - cp -r .cabal-sandbox ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none} + # Install bower globally (for psc-docs/psc-publish tests) + - npm install -g bower script: - ./travis/configure.sh - cabal build --ghc-options="-Werror" diff --git a/core-tests/test-everything.sh b/core-tests/test-everything.sh index a0b7eaf905..6aa0ebf1ea 100755 --- a/core-tests/test-everything.sh +++ b/core-tests/test-everything.sh @@ -18,9 +18,7 @@ if [ "$force_reinstall" = "true" ] && [ -d "bower_components" ]; then rm -r bower_components fi -npm install bower - -node_modules/.bin/bower i \ +bower i \ purescript-prelude \ purescript-eff \ purescript-st \ @@ -75,3 +73,7 @@ fi ../dist/build/psc/psc tests/*/*.purs \ 'bower_components/purescript-*/src/**/*.purs' \ --ffi 'bower_components/purescript-*/src/**/*.js' + +../dist/build/psc-docs/psc-docs tests/*/*.purs \ + 'bower_components/purescript-*/src/**/*.purs' \ + > full-core-docs.md diff --git a/examples/docs/bower.json b/examples/docs/bower.json new file mode 100644 index 0000000000..f4f13d5d4c --- /dev/null +++ b/examples/docs/bower.json @@ -0,0 +1,19 @@ +{ + "name": "docs-test-package", + "version": "1.0.0", + "moduleType": [ + "node" + ], + "repository": { + "type": "git", + "url": "git://github.com/not-real/not-a-real-repo.git" + }, + "ignore": [ + "**/.*", + "node_modules", + "bower_components", + "output" + ], + "dependencies": { + } +} diff --git a/examples/docs/bower_components/purescript-prelude/src/Prelude.purs b/examples/docs/bower_components/purescript-prelude/src/Prelude.purs new file mode 100644 index 0000000000..84b40b0508 --- /dev/null +++ b/examples/docs/bower_components/purescript-prelude/src/Prelude.purs @@ -0,0 +1,8 @@ +module Prelude where + +newtype Unit = Unit {} + +unit :: Unit +unit = Unit {} + +data Boolean2 = True | False diff --git a/examples/docs/src/Clash.purs b/examples/docs/src/Clash.purs new file mode 100644 index 0000000000..6da44eeddf --- /dev/null +++ b/examples/docs/src/Clash.purs @@ -0,0 +1,32 @@ +module Clash (module Clash1) where + +import Clash1 as Clash1 +import Clash2 as Clash2 + +module Clash1 (module Clash1a) where + +import Clash1a + +module Clash1a where + +value :: Int +value = 0 + +type Type = Int + +class TypeClass a where + typeClassMember :: a + +module Clash2 (module Clash2a) where + +import Clash2a + +module Clash2a where + +value :: String +value = "hello" + +type Type = String + +class TypeClass a b where + typeClassMember :: a -> b diff --git a/examples/docs/src/DuplicateNames.purs b/examples/docs/src/DuplicateNames.purs new file mode 100644 index 0000000000..879fec0654 --- /dev/null +++ b/examples/docs/src/DuplicateNames.purs @@ -0,0 +1,9 @@ +module DuplicateNames + ( module DuplicateNames + , module Prelude + ) where + +import Prelude (Unit) + +unit :: Int +unit = 0 diff --git a/examples/docs/src/Example.purs b/examples/docs/src/Example.purs new file mode 100644 index 0000000000..0babd1d60a --- /dev/null +++ b/examples/docs/src/Example.purs @@ -0,0 +1,7 @@ +module Example + ( module Prelude + , module Example2 + ) where + +import Prelude (Unit()) +import Example2 (one) diff --git a/examples/docs/src/Example2.purs b/examples/docs/src/Example2.purs new file mode 100644 index 0000000000..f038961e0f --- /dev/null +++ b/examples/docs/src/Example2.purs @@ -0,0 +1,7 @@ +module Example2 where + +one :: Int +one = 1 + +two :: Int +two = 2 diff --git a/examples/docs/src/MultiVirtual.purs b/examples/docs/src/MultiVirtual.purs new file mode 100644 index 0000000000..61ef6f8db2 --- /dev/null +++ b/examples/docs/src/MultiVirtual.purs @@ -0,0 +1,27 @@ +module MultiVirtual + ( module X ) + where + +import MultiVirtual1 as X +import MultiVirtual2 as X + + +module MultiVirtual1 where + +foo :: Int +foo = 1 + +module MultiVirtual2 + ( module MultiVirtual2 + , module MultiVirtual3 + ) where + +import MultiVirtual3 + +bar :: Int +bar = 2 + +module MultiVirtual3 where + +baz :: Int +baz = 3 diff --git a/examples/docs/src/NewOperators.purs b/examples/docs/src/NewOperators.purs new file mode 100644 index 0000000000..b8c20c4781 --- /dev/null +++ b/examples/docs/src/NewOperators.purs @@ -0,0 +1,12 @@ +module NewOperators + ( module NewOperators2 ) + where + +import NewOperators2 + +module NewOperators2 where + +infixl 8 _compose as >>> + +_compose :: forall a b c. (b -> c) -> (a -> b) -> (a -> c) +_compose f g x = f (g x) diff --git a/examples/docs/src/NotAllCtors.purs b/examples/docs/src/NotAllCtors.purs new file mode 100644 index 0000000000..bfe9ffcb3b --- /dev/null +++ b/examples/docs/src/NotAllCtors.purs @@ -0,0 +1,5 @@ +module NotAllCtors + ( module Prelude ) + where + +import Prelude (Boolean2(True)) diff --git a/examples/docs/src/OldOperators.purs b/examples/docs/src/OldOperators.purs new file mode 100644 index 0000000000..6a69323c65 --- /dev/null +++ b/examples/docs/src/OldOperators.purs @@ -0,0 +1,10 @@ + +-- Remove this after 0.9. +module OldOperators (module OldOperators2) where + +import OldOperators2 + +module OldOperators2 where + +(>>) :: forall a. a -> a -> a +(>>) a b = b diff --git a/examples/docs/src/ReExportedTypeClass.purs b/examples/docs/src/ReExportedTypeClass.purs new file mode 100644 index 0000000000..17d5c4d3fe --- /dev/null +++ b/examples/docs/src/ReExportedTypeClass.purs @@ -0,0 +1,5 @@ +module ReExportedTypeClass + ( module SomeTypeClass ) + where + +import SomeTypeClass diff --git a/examples/docs/src/SolitaryTypeClassMember.purs b/examples/docs/src/SolitaryTypeClassMember.purs new file mode 100644 index 0000000000..2e94edcb6d --- /dev/null +++ b/examples/docs/src/SolitaryTypeClassMember.purs @@ -0,0 +1,6 @@ +module SolitaryTypeClassMember + ( module SomeTypeClass ) + where + +import SomeTypeClass (member) + diff --git a/examples/docs/src/SomeTypeClass.purs b/examples/docs/src/SomeTypeClass.purs new file mode 100644 index 0000000000..204820fc1b --- /dev/null +++ b/examples/docs/src/SomeTypeClass.purs @@ -0,0 +1,5 @@ + +module SomeTypeClass where + +class SomeClass a where + member :: a diff --git a/examples/docs/src/Transitive1.purs b/examples/docs/src/Transitive1.purs new file mode 100644 index 0000000000..862f128dd2 --- /dev/null +++ b/examples/docs/src/Transitive1.purs @@ -0,0 +1,5 @@ +module Transitive1 + ( module Transitive2 ) + where + +import Transitive2 diff --git a/examples/docs/src/Transitive2.purs b/examples/docs/src/Transitive2.purs new file mode 100644 index 0000000000..e607d1e0bd --- /dev/null +++ b/examples/docs/src/Transitive2.purs @@ -0,0 +1,5 @@ +module Transitive2 + ( module Transitive3 ) + where + +import Transitive3 diff --git a/examples/docs/src/Transitive3.purs b/examples/docs/src/Transitive3.purs new file mode 100644 index 0000000000..abf974b13d --- /dev/null +++ b/examples/docs/src/Transitive3.purs @@ -0,0 +1,4 @@ +module Transitive3 where + +transitive3 :: Int +transitive3 = 0 diff --git a/examples/docs/src/TypeClassWithoutMembers.purs b/examples/docs/src/TypeClassWithoutMembers.purs new file mode 100644 index 0000000000..fb926cfa6f --- /dev/null +++ b/examples/docs/src/TypeClassWithoutMembers.purs @@ -0,0 +1,11 @@ +module TypeClassWithoutMembers + ( module Intermediate ) + where + +import Intermediate + +module Intermediate + ( module SomeTypeClass ) + where + +import SomeTypeClass (SomeClass) diff --git a/examples/docs/src/UTF8.purs b/examples/docs/src/UTF8.purs new file mode 100644 index 0000000000..258c6e125f --- /dev/null +++ b/examples/docs/src/UTF8.purs @@ -0,0 +1,7 @@ +module UTF8 where + +import Prelude (Unit, unit) + +-- | üÜäÄ 😰 +thing :: Unit +thing = unit diff --git a/examples/docs/src/Virtual.purs b/examples/docs/src/Virtual.purs new file mode 100644 index 0000000000..35f454a171 --- /dev/null +++ b/examples/docs/src/Virtual.purs @@ -0,0 +1,5 @@ +module Virtual + ( module VirtualPrelude ) + where + +import Prelude as VirtualPrelude diff --git a/purescript.cabal b/purescript.cabal index a4fa0dbd04..1c819801a4 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -20,6 +20,9 @@ tested-with: GHC==7.8 extra-source-files: examples/passing/*.purs , examples/failing/*.purs + , examples/docs/bower_components/purescript-prelude/src/*.purs + , examples/docs/bower.json + , examples/docs/src/*.purs , tests/support/setup.js , tests/support/package.json , tests/support/bower.json @@ -273,6 +276,7 @@ test-suite tests main-is: Main.hs other-modules: TestsSetup TestPscPublish + TestDocs buildable: True hs-source-dirs: tests tests/common diff --git a/tests/Main.hs b/tests/Main.hs index 3c4eb87316..9a56f95d88 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -30,6 +30,7 @@ -- -- @shouldFailWith TypesDoNotUnify -- -- @shouldFailWith TypesDoNotUnify -- -- @shouldFailWith TransitiveExportError +-- module Main (main) where @@ -39,6 +40,7 @@ import Prelude.Compat import qualified Language.PureScript as P import qualified Language.PureScript.CodeGen.JS as J import qualified Language.PureScript.CoreFn as CF +import qualified Language.PureScript.Docs as Docs import Data.Char (isSpace) import Data.Maybe (mapMaybe, fromMaybe) @@ -69,6 +71,7 @@ import Text.Parsec (ParseError) import TestsSetup import TestPscPublish +import qualified TestDocs modulesDir :: FilePath modulesDir = ".test_modules" "node_modules" @@ -176,6 +179,8 @@ main = do testCompiler heading "psc-publish test suite" testPscPublish + heading "Documentation test suite" + TestDocs.main where heading msg = do @@ -211,7 +216,7 @@ testCompiler = do assertDoesNotCompile (supportPurs ++ [failing inputFile]) foreigns if null failures - then exitSuccess + then pure () else do putStrLn "Failures:" forM_ failures $ \(fp, err) -> @@ -223,6 +228,7 @@ testPscPublish :: IO () testPscPublish = do testPackage "tests/support/prelude" + supportModules :: [String] supportModules = [ "Control.Monad.Eff.Class" diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs new file mode 100644 index 0000000000..477cc130d6 --- /dev/null +++ b/tests/TestDocs.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} + +module TestDocs where + +import Prelude () +import Prelude.Compat + +import Data.Version (Version(..)) + +import Control.Monad hiding (forM_) +import Control.Applicative +import Control.Arrow +import Data.Maybe (fromMaybe) +import Data.List ((\\)) +import Data.Foldable +import Data.Traversable +import System.Exit +import qualified Text.Parsec as Parsec + +import qualified Language.PureScript as P +import qualified Language.PureScript.Docs as Docs +import qualified Language.PureScript.Publish as Publish + +import qualified TestPscPublish + +publishOpts :: Publish.PublishOptions +publishOpts = Publish.defaultPublishOptions + { Publish.publishGetVersion = return testVersion + , Publish.publishWorkingTreeDirty = return () + } + where testVersion = ("v999.0.0", Version [999,0,0] []) + +main :: IO () +main = do + TestPscPublish.pushd "examples/docs" $ do + Docs.Package{..} <- Publish.preparePackage publishOpts + forM_ testCases $ \(mn, pragmas) -> + let mdl = takeJust ("module not found in docs: " ++ mn) + (find ((==) mn . Docs.modName) pkgModules) + in forM_ pragmas (flip runAssertionIO mdl) + +takeJust :: String -> Maybe a -> a +takeJust msg = maybe (error msg) id + +data Assertion + -- | Assert that a particular declaration is documented with the given + -- children + = ShouldBeDocumented P.ModuleName String [String] + -- | Assert that a particular declaration is not documented + | ShouldNotBeDocumented P.ModuleName String + -- | Assert that a particular declaration exists, but without a particular + -- child. + | ChildShouldNotBeDocumented P.ModuleName String String + -- | Assert that a particular declaration has a particular type class + -- constraint. + | ShouldBeConstrained P.ModuleName String String + deriving (Show) + +data AssertionFailure + -- | A declaration was not documented, but should have been + = NotDocumented P.ModuleName String + -- | A child declaration was not documented, but should have been + | ChildrenNotDocumented P.ModuleName String [String] + -- | A declaration was documented, but should not have been + | Documented P.ModuleName String + -- | A child declaration was documented, but should not have been + | ChildDocumented P.ModuleName String String + -- | A constraint was missing. + | ConstraintMissing P.ModuleName String String + -- | A declaration had the wrong "type" (ie, value, type, type class) + -- Fields: declaration title, expected "type", actual "type". + | WrongDeclarationType P.ModuleName String String String + deriving (Show) + +data AssertionResult + = Pass + | Fail AssertionFailure + deriving (Show) + +runAssertion :: Assertion -> Docs.Module -> AssertionResult +runAssertion assertion Docs.Module{..} = + case assertion of + ShouldBeDocumented mn decl children -> + case findChildren decl (declarationsFor mn) of + Nothing -> + Fail (NotDocumented mn decl) + Just actualChildren -> + case children \\ actualChildren of + [] -> Pass + cs -> Fail (ChildrenNotDocumented mn decl cs) + + ShouldNotBeDocumented mn decl -> + case findChildren decl (declarationsFor mn) of + Just _ -> + Fail (Documented mn decl) + Nothing -> + Pass + + ChildShouldNotBeDocumented mn decl child -> + case findChildren decl (declarationsFor mn) of + Just children -> + if child `elem` children + then Fail (ChildDocumented mn decl child) + else Pass + Nothing -> + Fail (NotDocumented mn decl) + + ShouldBeConstrained mn decl tyClass -> + case find ((==) decl . Docs.declTitle) (declarationsFor mn) of + Nothing -> + Fail (NotDocumented mn decl) + Just Docs.Declaration{..} -> + case declInfo of + Docs.ValueDeclaration ty -> + if checkConstrained ty tyClass + then Pass + else Fail (ConstraintMissing mn decl tyClass) + _ -> + Fail (WrongDeclarationType mn decl "value" + (Docs.declInfoToString declInfo)) + + where + declarationsFor mn = + if P.runModuleName mn == modName + then modDeclarations + else fromMaybe [] (lookup mn modReExports) + + findChildren title = + fmap childrenTitles . find ((==) title . Docs.declTitle) + + childrenTitles = map Docs.cdeclTitle . Docs.declChildren + +checkConstrained ty tyClass = + -- Note that we don't recurse on ConstrainedType if none of the constraints + -- match; this is by design, as constraints should be moved to the front + -- anyway. + case ty of + P.ConstrainedType cs _ | any (matches tyClass) cs -> + True + P.ForAll _ ty' _ -> + checkConstrained ty' tyClass + _ -> + False + where + matches className = + (==) className . P.runProperName . P.disqualify . fst + +runAssertionIO :: Assertion -> Docs.Module -> IO () +runAssertionIO assertion mdl = do + putStrLn ("In " ++ Docs.modName mdl ++ ": " ++ show assertion) + case runAssertion assertion mdl of + Pass -> pure () + fail -> do + putStrLn (show fail) + exitFailure + +testCases :: [(String, [Assertion])] +testCases = + [ ("Example", + [ -- From dependencies + ShouldBeDocumented (n "Prelude") "Unit" [] + , ShouldNotBeDocumented (n "Prelude") "unit" + + -- From local files + , ShouldBeDocumented (n "Example2") "one" [] + , ShouldNotBeDocumented (n "Example2") "two" + ]) + , ("Example2", + [ ShouldBeDocumented (n "Example2") "one" [] + , ShouldBeDocumented (n "Example2") "two" [] + ]) + + , ("UTF8", + [ ShouldBeDocumented (n "UTF8") "thing" [] + ]) + + , ("Transitive1", + [ ShouldBeDocumented (n "Transitive2") "transitive3" [] + ]) + + , ("NotAllCtors", + [ ShouldBeDocumented (n "Prelude") "Boolean2" ["True"] + , ChildShouldNotBeDocumented (n "Prelude") "Boolean2" "False" + ]) + + , ("DuplicateNames", + [ ShouldBeDocumented (n "Prelude") "Unit" [] + , ShouldBeDocumented (n "DuplicateNames") "unit" [] + , ShouldNotBeDocumented (n "Prelude") "unit" + ]) + + , ("MultiVirtual", + [ ShouldBeDocumented (n "MultiVirtual1") "foo" [] + , ShouldBeDocumented (n "MultiVirtual2") "bar" [] + , ShouldBeDocumented (n "MultiVirtual2") "baz" [] + ]) + + , ("Clash", + [ ShouldBeDocumented (n "Clash1") "value" [] + , ShouldBeDocumented (n "Clash1") "Type" [] + , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"] + ]) + + , ("SolitaryTypeClassMember", + [ ShouldBeDocumented (n "SomeTypeClass") "member" [] + , ShouldNotBeDocumented (n "SomeTypeClass") "SomeClass" + , ShouldBeConstrained (n "SomeTypeClass") "member" "SomeClass" + ]) + + , ("ReExportedTypeClass", + [ ShouldBeDocumented (n "SomeTypeClass") "SomeClass" ["member"] + ]) + + , ("TypeClassWithoutMembers", + [ ShouldBeDocumented (n "Intermediate") "SomeClass" [] + , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member" + ]) + + -- Remove this after 0.9. + , ("OldOperators", + [ ShouldBeDocumented (n "OldOperators2") "(>>)" [] + ]) + + , ("NewOperators", + [ ShouldBeDocumented (n "NewOperators2") "(>>>)" [] + ]) + ] + + where + n = P.moduleNameFromString From c0aeec91681fb4486051ab607bc8c6f6d40fd924 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 29 Dec 2015 08:48:14 +0000 Subject: [PATCH 0244/1580] Documentation for re-exports (fixes #1677) * Add a new field in Language.PureScript.Docs.Types.Module for re-exported declarations * Split two child modules out of Language.PureScript.Docs.Convert: Single, which is essentially what Convert previously was, and ReExports, which handles re-exports. * Handle re-exports while converting declarations for documentation (which were previously just ignored). Notably, converting docs can now throw MultipleErrors as a result (although if the code compiles normally, it should always succeed here too). * Update Language.PureScript.Docs.AsMarkdown to include re-exports in the generated documentation. * Export more values from Language.PureScript.Docs.AsMarkdown (because psc-docs needs them now) As an incidental consequence of the above changes, this commit also fixes #1681. --- psc-docs/Main.hs | 73 +-- purescript.cabal | 2 + src/Language/PureScript/Docs/AsMarkdown.hs | 33 +- src/Language/PureScript/Docs/Convert.hs | 256 +++------- .../PureScript/Docs/Convert/ReExports.hs | 444 ++++++++++++++++++ .../PureScript/Docs/Convert/Single.hs | 230 +++++++++ .../PureScript/Docs/ParseAndDesugar.hs | 10 +- src/Language/PureScript/Docs/Render.hs | 5 +- src/Language/PureScript/Docs/Types.hs | 72 ++- src/Language/PureScript/Publish.hs | 6 +- 10 files changed, 877 insertions(+), 254 deletions(-) create mode 100644 src/Language/PureScript/Docs/Convert/ReExports.hs create mode 100644 src/Language/PureScript/Docs/Convert/Single.hs diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index 02caefc008..5300518504 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -69,55 +69,68 @@ docgen (PSCDocsOptions fmt inputGlob output) = do Etags -> dumpTags input dumpEtags Ctags -> dumpTags input dumpCtags Markdown -> do - e <- liftIO . runExceptT $ D.parseAndDesugar input [] - case e of - Left err -> do - hPutStrLn stderr $ P.prettyPrintMultipleErrors False err - exitFailure - Right (ms', _, _) -> - case output of - EverythingToStdOut -> - putStrLn (D.renderModulesAsMarkdown ms') - ToStdOut names -> do - let (ms, missing) = takeModulesByName ms' names - guardMissing missing - putStrLn (D.renderModulesAsMarkdown ms) - ToFiles names -> do - let (ms, missing) = takeModulesByName' ms' names - guardMissing missing - let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms - forM_ ms'' $ \grp -> do - let fp = fst (head grp) - createDirectoryIfMissing True (takeDirectory fp) - writeFile fp (D.renderModulesAsMarkdown $ snd `map` grp) + ms <- runExceptT (D.parseAndDesugar input [] + >>= ((\(ms, _, env) -> D.convertModulesInPackage env ms))) + >>= successOrExit + + case output of + EverythingToStdOut -> + putStrLn (D.runDocs (D.modulesAsMarkdown ms)) + ToStdOut names -> do + let (ms', missing) = takeByName ms (map P.runModuleName names) + guardMissing missing + putStrLn (D.runDocs (D.modulesAsMarkdown ms')) + ToFiles names -> do + let (ms', missing) = takeByName' ms (map (first P.runModuleName) names) + guardMissing missing + + let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms' + forM_ ms'' $ \grp -> do + let fp = fst (head grp) + createDirectoryIfMissing True (takeDirectory fp) + writeFile fp (D.runDocs (D.modulesAsMarkdown (map snd grp))) + where guardMissing [] = return () guardMissing [mn] = do - hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ show mn ++ "\"") + hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ mn ++ "\"") exitFailure guardMissing mns = do hPutStrLn stderr "psc-docs: error: unknown modules:" forM_ mns $ \mn -> - hPutStrLn stderr (" * " ++ show mn) + hPutStrLn stderr (" * " ++ mn) exitFailure + successOrExit :: Either P.MultipleErrors a -> IO a + successOrExit act = + case act of + Right x -> + return x + Left err -> do + hPutStrLn stderr $ P.prettyPrintMultipleErrors False err + exitFailure + + takeByName = takeModulesByName D.modName + takeByName' = takeModulesByName' D.modName + -- | -- Given a list of module names and a list of modules, return a list of modules -- whose names appeared in the given name list, together with a list of names -- for which no module could be found in the module list. -- -takeModulesByName :: [P.Module] -> [P.ModuleName] -> ([P.Module], [P.ModuleName]) -takeModulesByName modules names = - first (map fst) (takeModulesByName' modules (map (,()) names)) +takeModulesByName :: (Eq n) => (m -> n) -> [m] -> [n] -> ([m], [n]) +takeModulesByName getModuleName modules names = + first (map fst) (takeModulesByName' getModuleName modules (map (,()) names)) -- | --- Like takeModulesByName but also keeps some extra data with the module. +-- Like takeModulesByName, but also keeps some extra information with each +-- module. -- -takeModulesByName' :: [P.Module] -> [(P.ModuleName, a)] -> ([(P.Module, a)], [P.ModuleName]) -takeModulesByName' modules = foldl go ([], []) +takeModulesByName' :: (Eq n) => (m -> n) -> [m] -> [(n, a)] -> ([(m, a)], [n]) +takeModulesByName' getModuleName modules = foldl go ([], []) where go (ms, missing) (name, x) = - case find ((== name) . P.getModuleName) modules of + case find ((== name) . getModuleName) modules of Just m -> ((m, x) : ms, missing) Nothing -> (ms, name : missing) diff --git a/purescript.cabal b/purescript.cabal index 1c819801a4..a1a21a83e1 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -162,6 +162,8 @@ library Language.PureScript.Docs Language.PureScript.Docs.Convert + Language.PureScript.Docs.Convert.Single + Language.PureScript.Docs.Convert.ReExports Language.PureScript.Docs.Render Language.PureScript.Docs.Types Language.PureScript.Docs.RenderedCode diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index f843b7049d..e0b6e4b9c4 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -1,10 +1,19 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} -module Language.PureScript.Docs.AsMarkdown ( - renderModulesAsMarkdown -) where +module Language.PureScript.Docs.AsMarkdown + ( renderModulesAsMarkdown + , Docs + , runDocs + , modulesAsMarkdown + ) where -import Control.Monad.Writer hiding (First) +import Prelude () +import Prelude.Compat + +import Control.Monad (unless, zipWithM_) +import Control.Monad.Writer (Writer, tell, execWriter) +import Control.Monad.Error.Class (MonadError) import Data.Foldable (for_) import Data.List (partition) @@ -19,9 +28,14 @@ import qualified Language.PureScript.Docs.Render as Render -- Take a list of modules and render them all in order, returning a single -- Markdown-formatted String. -- -renderModulesAsMarkdown :: [P.Module] -> String -renderModulesAsMarkdown = - runDocs . modulesAsMarkdown . map Convert.convertModule +renderModulesAsMarkdown :: + (Functor m, Applicative m, + MonadError P.MultipleErrors m) => + P.Env -> + [P.Module] -> + m String +renderModulesAsMarkdown env = + fmap (runDocs . modulesAsMarkdown) . Convert.convertModules env modulesAsMarkdown :: [Module] -> Docs modulesAsMarkdown = mapM_ moduleAsMarkdown @@ -33,6 +47,11 @@ moduleAsMarkdown Module{..} = do for_ modComments tell' mapM_ (declAsMarkdown modName) modDeclarations spacer + for_ modReExports $ \(mn, decls) -> do + let modName' = P.runModuleName mn + headerLevel 3 $ "Re-exported from " ++ modName' ++ ":" + spacer + mapM_ (declAsMarkdown modName') decls declAsMarkdown :: String -> Declaration -> Docs declAsMarkdown mn decl@Declaration{..} = do diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 3ade6181a3..9d34a45c6f 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -2,230 +2,86 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} -- | Functions for converting PureScript ASTs into values of the data types -- from Language.PureScript.Docs. module Language.PureScript.Docs.Convert - ( convertModule + ( convertModules + , convertModulesInPackage , collectBookmarks ) where import Prelude () import Prelude.Compat -import Control.Monad +import Control.Monad.Error.Class (MonadError) +import Control.Arrow ((&&&)) import Control.Category ((>>>)) -import Data.Either -import Data.Maybe (mapMaybe, isNothing) -import Data.List (nub, isPrefixOf, isSuffixOf) +import qualified Data.Map as Map import qualified Language.PureScript as P import Language.PureScript.Docs.Types +import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks) +import Language.PureScript.Docs.Convert.ReExports (updateReExports) -- | --- Convert a single Module. +-- Like convertModules, except that it takes a list of modules, together with +-- their dependency status, and discards dependency modules in the resulting +-- documentation. -- -convertModule :: P.Module -> Module -convertModule m@(P.Module _ coms moduleName _ _) = - Module (P.runModuleName moduleName) comments (declarations m) +convertModulesInPackage :: + (Functor m, MonadError P.MultipleErrors m) => + P.Env -> + [InPackage P.Module] -> + m [Module] +convertModulesInPackage env modules = + go modules where - comments = convertComments coms - declarations = - P.exportedDeclarations - >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d) - >>> augmentDeclarations - >>> map addDefaultFixity + localNames = + map (P.runModuleName . P.getModuleName) (takeLocals modules) + go = + map ignorePackage + >>> convertModules env + >>> fmap (filter ((`elem` localNames) . modName)) --- | The data type for an intermediate stage which we go through during --- converting. --- --- In the first pass, we take all top level declarations in the module, and --- collect other information which will later be used to augment the top level --- declarations. These two situation correspond to the Right and Left --- constructors, respectively. +-- | +-- Convert a group of modules to the intermediate format, designed for +-- producing documentation from. It is also necessary to pass an Env containing +-- imports/exports information about the list of modules, which is needed for +-- documenting re-exports. -- --- In the second pass, we go over all of the Left values and augment the --- relevant declarations, leaving only the augmented Right values. +-- Preconditions: -- --- Note that in the Left case, we provide a [String] as well as augment --- information. The [String] value should be a list of titles of declarations --- that the augmentation should apply to. For example, for a type instance --- declaration, that would be any types or type classes mentioned in the --- instance. For a fixity declaration, it would be just the relevant operator's --- name. -type IntermediateDeclaration - = Either ([String], DeclarationAugment) Declaration - --- | Some data which will be used to augment a Declaration in the --- output. +-- * If any module in the list re-exports documentation from other +-- modules, those modules must also be included in the list. +-- * The modules passed must have had names desugared and re-exports +-- elaborated first. -- --- The AugmentChild constructor allows us to move all children under their --- respective parents. It is only necessary for type instance declarations, --- since they appear at the top level in the AST, and since they might need to --- appear as children in two places (for example, if a data type defined in a --- module is an instance of a type class also defined in that module). +-- If either of these are not satisfied, an internal error will be thrown. To +-- avoid this, it is recommended to use +-- Language.PureScript.Docs.ParseAndDesugar to construct the inputs to this +-- function. -- --- The AugmentFixity constructor allows us to augment operator definitions --- with their associativity and precedence. -data DeclarationAugment - = AugmentChild ChildDeclaration - | AugmentFixity P.Fixity +convertModules :: + (Functor m, MonadError P.MultipleErrors m) => + P.Env -> + [P.Module] -> + m [Module] +convertModules env = + P.sortModules >>> fmap (convertSorted env . fst) --- | Augment top-level declarations; the second pass. See the comments under --- the type synonym IntermediateDeclaration for more information. -augmentDeclarations :: [IntermediateDeclaration] -> [Declaration] -augmentDeclarations (partitionEithers -> (augments, toplevels)) = - foldl go toplevels augments - where - go ds (parentTitles, a) = - map (\d -> - if declTitle d `elem` parentTitles - then augmentWith a d - else d) ds - - augmentWith a d = - case a of - AugmentChild child -> - d { declChildren = declChildren d ++ [child] } - AugmentFixity fixity -> - d { declFixity = Just fixity } - --- | Add the default operator fixity for operators which do not have associated --- fixity declarations. +-- | +-- Convert a sorted list of modules. -- --- TODO: This may no longer be necessary after issue 806 is resolved, hopefully --- in 0.9. -addDefaultFixity :: Declaration -> Declaration -addDefaultFixity decl@Declaration{..} - | isOp declTitle && isNothing declFixity = - decl { declFixity = Just defaultFixity } - | otherwise = - decl - where - isOp :: String -> Bool - isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str - defaultFixity = P.Fixity P.Infixl (-1) - -getDeclarationTitle :: P.Declaration -> Maybe String -getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name) -getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name) -getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name) -getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name) -getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) -getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name) -getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name) -getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")") -getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d -getDeclarationTitle _ = Nothing - --- | Create a basic Declaration value. -mkDeclaration :: String -> DeclarationInfo -> Declaration -mkDeclaration title info = - Declaration { declTitle = title - , declComments = Nothing - , declSourceSpan = Nothing - , declChildren = [] - , declFixity = Nothing - , declInfo = info - } - -basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration -basicDeclaration title info = Just $ Right $ mkDeclaration title info - -convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration -convertDeclaration (P.TypeDeclaration _ ty) title = - basicDeclaration title (ValueDeclaration ty) -convertDeclaration (P.ExternDeclaration _ ty) title = - basicDeclaration title (ValueDeclaration ty) -convertDeclaration (P.DataDeclaration dtype _ args ctors) title = - Just (Right (mkDeclaration title info) { declChildren = children }) - where - info = DataDeclaration dtype args - children = map convertCtor ctors - convertCtor (ctor', tys) = - ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys) -convertDeclaration (P.ExternDataDeclaration _ kind') title = - basicDeclaration title (ExternDataDeclaration kind') -convertDeclaration (P.TypeSynonymDeclaration _ args ty) title = - basicDeclaration title (TypeSynonymDeclaration args ty) -convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = - Just (Right (mkDeclaration title info) { declChildren = children }) - where - info = TypeClassDeclaration args implies - children = map convertClassMember ds - convertClassMember (P.PositionedDeclaration _ _ d) = - convertClassMember d - convertClassMember (P.TypeDeclaration ident' ty) = - ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty) - convertClassMember _ = - P.internalError "convertDeclaration: Invalid argument to convertClassMember." -convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = - Just (Left (classNameString : typeNameStrings, AugmentChild childDecl)) - where - classNameString = unQual className - typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys) - unQual x = let (P.Qualified _ y) = x in P.runProperName y - - extractProperNames (P.TypeConstructor n) = [unQual n] - extractProperNames _ = [] - - childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) - classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys -convertDeclaration (P.FixityDeclaration fixity _ Nothing) title = - Just (Left ([title], AugmentFixity fixity)) -convertDeclaration (P.FixityDeclaration fixity _ (Just alias)) title = - Just $ Right $ (mkDeclaration title (AliasDeclaration alias fixity)) { declFixity = Just fixity } -convertDeclaration (P.PositionedDeclaration srcSpan com d') title = - fmap (addComments . addSourceSpan) (convertDeclaration d' title) - where - addComments (Right d) = - Right (d { declComments = convertComments com }) - addComments (Left augment) = - Left (withAugmentChild (\d -> d { cdeclComments = convertComments com }) - augment) - - addSourceSpan (Right d) = - Right (d { declSourceSpan = Just srcSpan }) - addSourceSpan (Left augment) = - Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan }) - augment) - - withAugmentChild f (t, a) = - case a of - AugmentChild d -> (t, AugmentChild (f d)) - _ -> (t, a) -convertDeclaration _ _ = Nothing - -convertComments :: [P.Comment] -> Maybe String -convertComments cs = do - let raw = concatMap toLines cs - guard (all hasPipe raw && not (null raw)) - return (go raw) - where - go = unlines . map stripPipes - - toLines (P.LineComment s) = [s] - toLines (P.BlockComment s) = lines s - - hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False } - - stripPipes = dropPipe . dropWhile (== ' ') - - dropPipe ('|':' ':s) = s - dropPipe ('|':s) = s - dropPipe s = s - --- | Go through a PureScript module and extract a list of Bookmarks; references --- to data types or values, to be used as a kind of index. These are used for --- generating links in the HTML documentation, for example. -collectBookmarks :: InPackage P.Module -> [Bookmark] -collectBookmarks (Local m) = map Local (collectBookmarks' m) -collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m) - -collectBookmarks' :: P.Module -> [(P.ModuleName, String)] -collectBookmarks' m = - map (P.getModuleName m, ) - (mapMaybe getDeclarationTitle - (P.exportedDeclarations m)) +convertSorted :: P.Env -> [P.Module] -> [Module] +convertSorted env modules = + let + traversalOrder = + map P.getModuleName modules + moduleMap = + Map.fromList $ map (P.getModuleName &&& convertSingleModule) modules + in + Map.elems (updateReExports env traversalOrder moduleMap) diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs new file mode 100644 index 0000000000..998b1062bd --- /dev/null +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -0,0 +1,444 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} + +module Language.PureScript.Docs.Convert.ReExports + ( updateReExports + ) where + +import Prelude () +import Prelude.Compat + +import Control.Monad +import Control.Monad.Trans.State.Strict (execState) +import Control.Monad.State.Class (MonadState, gets, modify) +import Control.Arrow ((&&&), first, second) +import Data.Either +import Data.Maybe (mapMaybe) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid ((<>)) + +import qualified Language.PureScript as P + +import Language.PureScript.Docs.Types + +-- | +-- Given: +-- +-- * The Imports/Exports Env +-- * An order to traverse the modules (which must be topological) +-- * A map of modules, indexed by their names, which are assumed to not +-- have their re-exports listed yet +-- +-- This function adds all the missing re-exports. +-- +updateReExports :: + P.Env -> + [P.ModuleName] -> + Map P.ModuleName Module -> + Map P.ModuleName Module +updateReExports env order modules = + execState action modules + where + action = + void (traverse go order) + + go mn = do + mdl <- lookup' mn + reExports <- getReExports env mn + let mdl' = mdl { modReExports = reExports } + modify (Map.insert mn mdl') + + lookup' mn = do + v <- gets (Map.lookup mn) + case v of + Just v' -> + pure v' + Nothing -> + internalError ("Module missing: " ++ P.runModuleName mn) + +-- | +-- Collect all of the re-exported declarations for a single module. +-- +-- We require that modules have already been sorted (P.sortModules) in order to +-- ensure that by the time we convert a particular module, all its dependencies +-- have already been converted. +-- +getReExports :: + (Functor m, Applicative m, + MonadState (Map P.ModuleName Module) m) => + P.Env -> + P.ModuleName -> + m [(P.ModuleName, [Declaration])] +getReExports env mn = + case Map.lookup mn env of + Nothing -> + internalError ("Module missing: " ++ P.runModuleName mn) + Just (_, imports, exports) -> + let notLocal = (/= mn) . fst + in filter notLocal <$> collectDeclarations imports exports + +-- | +-- Assemble a list of declarations re-exported from a particular module, based +-- on the Imports and Exports value for that module, and by extracting the +-- declarations from the current state. +-- +-- This function works by searching through the lists of exported declarations +-- in the Exports, and looking them up in the associated Imports value to find +-- the module they were imported from. +-- +-- Additionally: +-- +-- * Attempts to move re-exported type class members under their parent +-- type classes, if possible, or otherwise, "promote" them from +-- ChildDeclarations to proper Declarations. +-- * Filters data declarations to ensure that only re-exported data +-- constructors are listed. +-- * Filters type class declarations to ensure that only re-exported type +-- class members are listed. +-- +collectDeclarations :: + (Functor m, Applicative m, MonadState (Map P.ModuleName Module) m) => + P.Imports -> + P.Exports -> + m [(P.ModuleName, [Declaration])] +collectDeclarations imports exports = do + valsAndMembers <- collect lookupValueDeclaration impVals expVals + typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs + types <- collect lookupTypeDeclaration impTypes expTypes + + let (vals, classes) = handleTypeClassMembers valsAndMembers typeClasses + + let filteredTypes = filterDataConstructors expCtors types + let filteredClasses = filterTypeClassMembers (map fst expVals) classes + + pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals])) + + where + collect lookup' imps exps = + Map.fromListWith (<>) <$> traverse (uncurry lookup') + (map (findImport imps) exps) + + expVals = P.exportedValues exports + impVals = concat (Map.elems (P.importedValues imports)) + + expTypes = map (first fst) (P.exportedTypes exports) + impTypes = concat (Map.elems (P.importedTypes imports)) + + expCtors = concatMap (snd . fst) (P.exportedTypes exports) + + expTCs = P.exportedTypeClasses exports + impTCs = concat (Map.elems (P.importedTypeClasses imports)) + +-- | +-- Given a list of imported declarations (of a particular kind, ie. type, data, +-- class, value, etc), and the name of an exported declaration of the same +-- kind, together with the module it was originally defined in, return a tuple +-- of: +-- +-- * the module that exported declaration was imported from (note that +-- this can be different from the module it was originally defined in, if +-- it is a re-export), +-- * that same declaration's name. +-- +-- This function uses a type variable for names because we want to be able to +-- instantiate @name@ as both 'P.Ident' and 'P.ProperName'. +-- +findImport :: + (Show name, Eq name) => + [(P.Qualified name, P.ModuleName)] -> + (name, P.ModuleName) -> + (P.ModuleName, name) +findImport imps (name, orig) = + case filter (\(qual, mn) -> P.disqualify qual == name && mn == orig) imps of + [(P.Qualified (Just importedFrom) _, _)] -> + (importedFrom, name) + other -> + internalError ("findImport: unexpected result: " ++ show other) + +lookupValueDeclaration :: + (MonadState (Map P.ModuleName Module) m, Applicative m) => + P.ModuleName -> + P.Ident -> + m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration]) +lookupValueDeclaration importedFrom ident = do + decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom + let + rs = + filter (\d -> declTitle d == P.showIdent ident + && (isValue d || isAlias d)) decls + errOther other = + internalError + ("lookupValueDeclaration: unexpected result:\n" ++ + "other: " ++ show other ++ "\n" ++ + "ident: " ++ show ident ++ "\n" ++ + "decls: " ++ show decls) + + case rs of + [r] -> + pure (importedFrom, [Right r]) + [] -> + -- It's a type class member. + -- Note that we need to filter based on the child declaration info using + -- `isTypeClassMember` anyway, because child declarations of type classes + -- are not necessarily members; they could also be instances. + let + allTypeClassChildDecls = + decls + |> mapMaybe (\d -> (d,) <$> typeClassConstraintFor d) + |> concatMap (\(d, constr) -> + map (declTitle d, constr,) + (declChildren d)) + + matchesIdent cdecl = + cdeclTitle cdecl == P.showIdent ident + + matchesAndIsTypeClassMember = + uncurry (&&) . (matchesIdent &&& isTypeClassMember) + + in + case filter (matchesAndIsTypeClassMember . thd) allTypeClassChildDecls of + [r'] -> + pure (importedFrom, [Left r']) + other -> + errOther other + other -> do + errOther other + + where + thd :: (a, b, c) -> c + thd (_, _, x) = x + +-- | +-- Extract a particular type declaration. For data declarations, constructors +-- are only included in the output if they are listed in the arguments. +-- +lookupTypeDeclaration :: + (MonadState (Map P.ModuleName Module) m, Applicative m) => + P.ModuleName -> + P.ProperName 'P.TypeName -> + m (P.ModuleName, [Declaration]) +lookupTypeDeclaration importedFrom ty = do + decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom + let + ds = filter (\d -> declTitle d == P.runProperName ty && isType d) decls + case ds of + [d] -> + pure (importedFrom, [d]) + other -> + internalError + ("lookupTypeDeclaration: unexpected result: " ++ show other) + +lookupTypeClassDeclaration :: + (MonadState (Map P.ModuleName Module) m, Applicative m) => + P.ModuleName -> + P.ProperName 'P.ClassName -> + m (P.ModuleName, [Declaration]) +lookupTypeClassDeclaration importedFrom tyClass = do + decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom + let + ds = filter (\d -> declTitle d == P.runProperName tyClass + && isTypeClass d) + decls + case ds of + [d] -> + pure (importedFrom, [d]) + other -> + internalError ("lookupTypeClassDeclaration: unexpected result: " + ++ (unlines . map show) other) + +-- | +-- Get the full list of declarations for a particular module out of the +-- state, or raise an internal error if it is not there. +-- +lookupModuleDeclarations :: + (Applicative m, MonadState (Map P.ModuleName Module) m) => + String -> + P.ModuleName -> + m [Declaration] +lookupModuleDeclarations definedIn moduleName = do + mmdl <- gets (Map.lookup moduleName) + case mmdl of + Nothing -> + internalError (definedIn ++ ": module missing: " + ++ P.runModuleName moduleName) + Just mdl -> + pure (allDeclarations mdl) + +handleTypeClassMembers :: + Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] -> + Map P.ModuleName [Declaration] -> + (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration]) +handleTypeClassMembers valsAndMembers typeClasses = + let + moduleEnvs = + Map.unionWith (<>) + (fmap valsAndMembersToEnv valsAndMembers) + (fmap typeClassesToEnv typeClasses) + in + moduleEnvs + |> fmap handleEnv + |> splitMap + +valsAndMembersToEnv :: + [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv +valsAndMembersToEnv xs = + let (envUnhandledMembers, envValues) = partitionEithers xs + envTypeClasses = [] + in TypeClassEnv{..} + +typeClassesToEnv :: [Declaration] -> TypeClassEnv +typeClassesToEnv classes = + TypeClassEnv + { envUnhandledMembers = [] + , envValues = [] + , envTypeClasses = classes + } + +-- | +-- An intermediate data type, used for either moving type class members under +-- their parent type classes, or promoting them to normal Declaration values +-- if their parent type class has not been re-exported. +-- +data TypeClassEnv = TypeClassEnv + { -- | + -- Type class members which have not yet been dealt with. The String is the + -- name of the type class they belong to, and the constraint is used to + -- make sure that they have the correct type if they get promoted. + -- + envUnhandledMembers :: [(String, P.Constraint, ChildDeclaration)] + -- | + -- A list of normal value declarations. Type class members will be added to + -- this list if their parent type class is not available. + -- + , envValues :: [Declaration] + -- | + -- A list of type class declarations. Type class members will be added to + -- their parents in this list, if they exist. + -- + , envTypeClasses :: [Declaration] + } + deriving (Show) + +instance Monoid TypeClassEnv where + mempty = + TypeClassEnv mempty mempty mempty + mappend (TypeClassEnv a1 b1 c1) + (TypeClassEnv a2 b2 c2) = + TypeClassEnv (a1 <> a2) (b1 <> b2) (c1 <> c2) + +-- | +-- Take a TypeClassEnv and handle all of the type class members in it, either +-- adding them to their parent classes, or promoting them to normal Declaration +-- values. +-- +-- Returns a tuple of (values, type classes). +-- +handleEnv :: TypeClassEnv -> ([Declaration], [Declaration]) +handleEnv TypeClassEnv{..} = + envUnhandledMembers + |> foldl go (envValues, mkMap envTypeClasses) + |> second Map.elems + + where + mkMap = + Map.fromList . map (declTitle &&& id) + + go (values, tcs) (title, constraint, childDecl) = + case Map.lookup title tcs of + Just _ -> + -- Leave the state unchanged; if the type class is there, the child + -- will be too. + (values, tcs) + Nothing -> + (promoteChild constraint childDecl : values, tcs) + + promoteChild constraint ChildDeclaration{..} = + case cdeclInfo of + ChildTypeClassMember typ -> + Declaration + { declTitle = cdeclTitle + , declComments = cdeclComments + , declSourceSpan = cdeclSourceSpan + , declChildren = [] + , declFixity = Nothing + , declInfo = ValueDeclaration (addConstraint constraint typ) + } + _ -> + internalError + ("handleEnv: Bad child declaration passed to promoteChild: " + ++ cdeclTitle) + + addConstraint constraint = + P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint] + +splitMap :: (Ord k) => Map k (v1, v2) -> (Map k v1, Map k v2) +splitMap = foldl go (Map.empty, Map.empty) . Map.toList + where + go (m1, m2) (k, (v1, v2)) = + (Map.insert k v1 m1, Map.insert k v2 m2) + +-- | +-- Given a list of exported constructor names, remove any data constructor +-- names in the provided Map of declarations which are not in the list. +-- +filterDataConstructors :: + [P.ProperName 'P.ConstructorName] -> + Map P.ModuleName [Declaration] -> + Map P.ModuleName [Declaration] +filterDataConstructors = + filterExportedChildren isDataConstructor P.runProperName + +-- | +-- Given a list of exported type class member names, remove any data +-- type class member names in the provided Map of declarations which are not in +-- the list. +-- +filterTypeClassMembers :: + [P.Ident] -> + Map P.ModuleName [Declaration] -> + Map P.ModuleName [Declaration] +filterTypeClassMembers = + filterExportedChildren isTypeClassMember P.showIdent + +filterExportedChildren :: + (Functor f) => + (ChildDeclaration -> Bool) -> + (name -> String) -> + [name] -> + f [Declaration] -> + f [Declaration] +filterExportedChildren isTargetedKind runName expNames = + fmap filterDecls + where + filterDecls = + map (filterChildren (\c -> not (isTargetedKind c) || + cdeclTitle c `elem` expNames')) + + expNames' = map runName expNames + +allDeclarations :: Module -> [Declaration] +allDeclarations Module{..} = + modDeclarations ++ concatMap snd modReExports + +(|>) :: a -> (a -> b) -> b +x |> f = f x + +internalError :: String -> a +internalError = P.internalError . ("Docs.Convert.ReExports: " ++) + +-- | +-- If the provided Declaration is a TypeClassDeclaration, construct an +-- appropriate Constraint for use with the types of its members. +-- +typeClassConstraintFor :: Declaration -> Maybe P.Constraint +typeClassConstraintFor Declaration{..} = + case declInfo of + TypeClassDeclaration tyArgs _ -> + Just (P.Qualified Nothing (P.ProperName declTitle), mkConstraint tyArgs) + _ -> + Nothing + where + mkConstraint = map (P.TypeVar . fst) diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs new file mode 100644 index 0000000000..e95ed70945 --- /dev/null +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} + +module Language.PureScript.Docs.Convert.Single + ( convertSingleModule + , collectBookmarks + ) where + +import Prelude () +import Prelude.Compat + +import Control.Monad +import Control.Category ((>>>)) +import Data.Maybe (mapMaybe, isNothing) +import Data.Either +import Data.List (nub, isPrefixOf, isSuffixOf) + +import qualified Language.PureScript as P + +import Language.PureScript.Docs.Types + +-- | +-- Convert a single Module, but ignore re-exports; any re-exported types or +-- values will not appear in the result. +-- +convertSingleModule :: P.Module -> Module +convertSingleModule m@(P.Module _ coms moduleName _ _) = + Module (P.runModuleName moduleName) comments (declarations m) [] + where + comments = convertComments coms + declarations = + P.exportedDeclarations + >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d) + >>> augmentDeclarations + >>> map addDefaultFixity + +-- | The data type for an intermediate stage which we go through during +-- converting. +-- +-- In the first pass, we take all top level declarations in the module, and +-- collect other information which will later be used to augment the top level +-- declarations. These two situation correspond to the Right and Left +-- constructors, respectively. +-- +-- In the second pass, we go over all of the Left values and augment the +-- relevant declarations, leaving only the augmented Right values. +-- +-- Note that in the Left case, we provide a [String] as well as augment +-- information. The [String] value should be a list of titles of declarations +-- that the augmentation should apply to. For example, for a type instance +-- declaration, that would be any types or type classes mentioned in the +-- instance. For a fixity declaration, it would be just the relevant operator's +-- name. +type IntermediateDeclaration + = Either ([String], DeclarationAugment) Declaration + +-- | Some data which will be used to augment a Declaration in the +-- output. +-- +-- The AugmentChild constructor allows us to move all children under their +-- respective parents. It is only necessary for type instance declarations, +-- since they appear at the top level in the AST, and since they might need to +-- appear as children in two places (for example, if a data type defined in a +-- module is an instance of a type class also defined in that module). +-- +-- The AugmentFixity constructor allows us to augment operator definitions +-- with their associativity and precedence. +data DeclarationAugment + = AugmentChild ChildDeclaration + | AugmentFixity P.Fixity + +-- | Augment top-level declarations; the second pass. See the comments under +-- the type synonym IntermediateDeclaration for more information. +augmentDeclarations :: [IntermediateDeclaration] -> [Declaration] +augmentDeclarations (partitionEithers -> (augments, toplevels)) = + foldl go toplevels augments + where + go ds (parentTitles, a) = + map (\d -> + if declTitle d `elem` parentTitles + then augmentWith a d + else d) ds + + augmentWith a d = + case a of + AugmentChild child -> + d { declChildren = declChildren d ++ [child] } + AugmentFixity fixity -> + d { declFixity = Just fixity } + +-- | Add the default operator fixity for operators which do not have associated +-- fixity declarations. +-- +-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully +-- in 0.9. +addDefaultFixity :: Declaration -> Declaration +addDefaultFixity decl@Declaration{..} + | isOp declTitle && isNothing declFixity = + decl { declFixity = Just defaultFixity } + | otherwise = + decl + where + isOp :: String -> Bool + isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str + defaultFixity = P.Fixity P.Infixl (-1) + +getDeclarationTitle :: P.Declaration -> Maybe String +getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name) +getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name) +getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name) +getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name) +getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) +getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name) +getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name) +getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")") +getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d +getDeclarationTitle _ = Nothing + +-- | Create a basic Declaration value. +mkDeclaration :: String -> DeclarationInfo -> Declaration +mkDeclaration title info = + Declaration { declTitle = title + , declComments = Nothing + , declSourceSpan = Nothing + , declChildren = [] + , declFixity = Nothing + , declInfo = info + } + +basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration +basicDeclaration title info = Just $ Right $ mkDeclaration title info + +convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration +convertDeclaration (P.TypeDeclaration _ ty) title = + basicDeclaration title (ValueDeclaration ty) +convertDeclaration (P.ExternDeclaration _ ty) title = + basicDeclaration title (ValueDeclaration ty) +convertDeclaration (P.DataDeclaration dtype _ args ctors) title = + Just (Right (mkDeclaration title info) { declChildren = children }) + where + info = DataDeclaration dtype args + children = map convertCtor ctors + convertCtor (ctor', tys) = + ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys) +convertDeclaration (P.ExternDataDeclaration _ kind') title = + basicDeclaration title (ExternDataDeclaration kind') +convertDeclaration (P.TypeSynonymDeclaration _ args ty) title = + basicDeclaration title (TypeSynonymDeclaration args ty) +convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = + Just (Right (mkDeclaration title info) { declChildren = children }) + where + info = TypeClassDeclaration args implies + children = map convertClassMember ds + convertClassMember (P.PositionedDeclaration _ _ d) = + convertClassMember d + convertClassMember (P.TypeDeclaration ident' ty) = + ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty) + convertClassMember _ = + P.internalError "convertDeclaration: Invalid argument to convertClassMember." +convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = + Just (Left (classNameString : typeNameStrings, AugmentChild childDecl)) + where + classNameString = unQual className + typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys) + unQual x = let (P.Qualified _ y) = x in P.runProperName y + + extractProperNames (P.TypeConstructor n) = [unQual n] + extractProperNames _ = [] + + childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) + classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys +convertDeclaration (P.FixityDeclaration fixity _ Nothing) title = + Just (Left ([title], AugmentFixity fixity)) +convertDeclaration (P.FixityDeclaration fixity _ (Just alias)) title = + Just $ Right $ (mkDeclaration title (AliasDeclaration alias fixity)) { declFixity = Just fixity } +convertDeclaration (P.PositionedDeclaration srcSpan com d') title = + fmap (addComments . addSourceSpan) (convertDeclaration d' title) + where + addComments (Right d) = + Right (d { declComments = convertComments com }) + addComments (Left augment) = + Left (withAugmentChild (\d -> d { cdeclComments = convertComments com }) + augment) + + addSourceSpan (Right d) = + Right (d { declSourceSpan = Just srcSpan }) + addSourceSpan (Left augment) = + Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan }) + augment) + + withAugmentChild f (t, a) = + case a of + AugmentChild d -> (t, AugmentChild (f d)) + _ -> (t, a) +convertDeclaration _ _ = Nothing + +convertComments :: [P.Comment] -> Maybe String +convertComments cs = do + let raw = concatMap toLines cs + guard (all hasPipe raw && not (null raw)) + return (go raw) + where + go = unlines . map stripPipes + + toLines (P.LineComment s) = [s] + toLines (P.BlockComment s) = lines s + + hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False } + + stripPipes = dropPipe . dropWhile (== ' ') + + dropPipe ('|':' ':s) = s + dropPipe ('|':s) = s + dropPipe s = s + +-- | Go through a PureScript module and extract a list of Bookmarks; references +-- to data types or values, to be used as a kind of index. These are used for +-- generating links in the HTML documentation, for example. +collectBookmarks :: InPackage P.Module -> [Bookmark] +collectBookmarks (Local m) = map Local (collectBookmarks' m) +collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m) + +collectBookmarks' :: P.Module -> [(P.ModuleName, String)] +collectBookmarks' m = + map (P.getModuleName m, ) + (mapMaybe getDeclarationTitle + (P.exportedDeclarations m)) diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndDesugar.hs index b5813ed54e..2f0302a5e9 100644 --- a/src/Language/PureScript/Docs/ParseAndDesugar.hs +++ b/src/Language/PureScript/Docs/ParseAndDesugar.hs @@ -33,18 +33,18 @@ import Language.PureScript.Docs.Convert (collectBookmarks) -- This function does the following: -- -- * Parse all of the input and dependency source files +-- * Associate each dependency module with its package name, thereby +-- distinguishing these from local modules -- * Partially desugar all of the resulting modules (just enough for -- producing documentation from them) -- * Collect a list of bookmarks from the whole set of source files --- * Collect a list of desugared modules from just the input source files (not --- dependencies) -- * Return the desugared modules, the bookmarks, and the imports/exports -- Env (which is needed for producing documentation). parseAndDesugar :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) => [FilePath] -> [(PackageName, FilePath)] - -> m ([P.Module], [Bookmark], P.Env) + -> m ([InPackage P.Module], [Bookmark], P.Env) parseAndDesugar inputFiles depsFiles = do inputFiles' <- traverse (parseAs Local) inputFiles depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles @@ -74,7 +74,7 @@ desugarWithBookmarks :: (MonadError P.MultipleErrors m, MonadIO m) => [(FileInfo, P.Module)] -> [P.Module] - -> m ([P.Module], [Bookmark], P.Env) + -> m ([InPackage P.Module], [Bookmark], P.Env) desugarWithBookmarks msInfo msSorted = do (env, msDesugared) <- throwLeft (desugar msSorted) @@ -82,7 +82,7 @@ desugarWithBookmarks msInfo msSorted = do msPackages = map (addPackage msDeps) msDesugared bookmarks = concatMap collectBookmarks msPackages - return (takeLocals msPackages, bookmarks, env) + return (msPackages, bookmarks, env) throwLeft :: (MonadError l m) => Either l r -> m r throwLeft = either throwError return diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 82ff0ea753..d954fcc1ce 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -49,7 +49,7 @@ renderDeclarationWithOptions opts Declaration{..} = [ keywordClass ] ++ maybeToList superclasses ++ [renderType' (typeApp declTitle args)] - ++ [keywordWhere | any (isTypeClassMember . cdeclInfo) declChildren] + ++ [keywordWhere | any isTypeClassMember declChildren] where superclasses @@ -58,9 +58,6 @@ renderDeclarationWithOptions opts Declaration{..} = syntax "(" <> mintersperse (syntax "," <> sp) (map renderConstraint implies) <> syntax ")" <> sp <> syntax "<=" - - isTypeClassMember (ChildTypeClassMember _) = True - isTypeClassMember _ = False AliasDeclaration for (P.Fixity associativity precedence) -> [ keywordFixity associativity , syntax $ show precedence diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 83f9d2c11f..8d19cfb4dc 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -76,6 +76,8 @@ data Module = Module { modName :: String , modComments :: Maybe String , modDeclarations :: [Declaration] + -- Re-exported values from other modules + , modReExports :: [(P.ModuleName, [Declaration])] } deriving (Show, Eq, Ord) @@ -142,6 +144,37 @@ declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym" declInfoToString (TypeClassDeclaration _ _) = "typeClass" declInfoToString (AliasDeclaration _ _) = "alias" +isTypeClass :: Declaration -> Bool +isTypeClass Declaration{..} = + case declInfo of + TypeClassDeclaration{} -> True + _ -> False + +isValue :: Declaration -> Bool +isValue Declaration{..} = + case declInfo of + ValueDeclaration{} -> True + _ -> False + +isType :: Declaration -> Bool +isType Declaration{..} = + case declInfo of + TypeSynonymDeclaration{} -> True + DataDeclaration{} -> True + ExternDataDeclaration{} -> True + _ -> False + +isAlias :: Declaration -> Bool +isAlias Declaration{..} = + case declInfo of + AliasDeclaration{} -> True + _ -> False + +-- | Discard any children which do not satisfy the given predicate. +filterChildren :: (ChildDeclaration -> Bool) -> Declaration -> Declaration +filterChildren p decl = + decl { declChildren = filter p (declChildren decl) } + data ChildDeclaration = ChildDeclaration { cdeclTitle :: String , cdeclComments :: Maybe String @@ -174,6 +207,18 @@ childDeclInfoToString (ChildInstance _ _) = "instance" childDeclInfoToString (ChildDataConstructor _) = "dataConstructor" childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember" +isTypeClassMember :: ChildDeclaration -> Bool +isTypeClassMember ChildDeclaration{..} = + case cdeclInfo of + ChildTypeClassMember{} -> True + _ -> False + +isDataConstructor :: ChildDeclaration -> Bool +isDataConstructor ChildDeclaration{..} = + case cdeclInfo of + ChildDataConstructor{} -> True + _ -> False + newtype GithubUser = GithubUser { runGithubUser :: String } deriving (Show, Eq, Ord) @@ -304,6 +349,7 @@ asModule = Module <$> key "name" asString <*> key "comments" (perhaps asString) <*> key "declarations" (eachInArray asDeclaration) + <*> key "reExports" (eachInArray asReExport) asDeclaration :: Parse PackageError Declaration asDeclaration = @@ -314,6 +360,19 @@ asDeclaration = <*> key "fixity" (perhaps asFixity) <*> key "info" asDeclarationInfo +asReExport :: Parse PackageError (P.ModuleName, [Declaration]) +asReExport = + (,) <$> key "moduleName" fromAesonParser + <*> key "declarations" (eachInArray asDeclaration) + +asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a) +asInPackage inner = + build <$> key "package" (perhaps (withString parsePackageName)) + <*> key "item" inner + where + build Nothing = Local + build (Just pn) = FromDep pn + asFixity :: Parse PackageError P.Fixity asFixity = P.Fixity <$> key "associativity" asAssociativity @@ -410,12 +469,8 @@ asBookmarks = eachInArray asBookmark asBookmark :: Parse BowerError Bookmark asBookmark = - build <$> key "package" (perhaps (withString parsePackageName)) - <*> key "item" ((,) <$> nth 0 (P.moduleNameFromString <$> asString) - <*> nth 1 asString) - where - build Nothing = Local - build (Just pn) = FromDep pn + asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asString) + <*> nth 1 asString) asResolvedDependencies :: Parse PackageError [(PackageName, Version)] asResolvedDependencies = @@ -460,7 +515,12 @@ instance A.ToJSON Module where A.object [ "name" .= modName , "comments" .= modComments , "declarations" .= modDeclarations + , "reExports" .= map toObj modReExports ] + where + toObj (mn, decls) = A.object [ "moduleName" .= mn + , "declarations" .= decls + ] instance A.ToJSON Declaration where toJSON Declaration{..} = diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index fe913d6187..210504fbfe 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -146,9 +146,11 @@ preparePackage' opts = do getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module]) getModulesAndBookmarks = do (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles - (modules', bookmarks, _) <- parseAndDesugar inputFiles depsFiles + (modules', bookmarks, env) <- parseAndDesugar inputFiles depsFiles - return (bookmarks, map D.convertModule modules') + case runExcept (D.convertModulesInPackage env modules') of + Right modules -> return (bookmarks, modules) + Left err -> userError (CompileError err) where parseAndDesugar inputFiles depsFiles = do From 94b4044bc7dace59e2d850856d2ed7154ab3e72b Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 3 Jan 2016 15:58:34 +0000 Subject: [PATCH 0245/1580] Disable psc-publish test suite temporarily --- tests/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/Main.hs b/tests/Main.hs index 9a56f95d88..9433b19474 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -177,10 +177,10 @@ main :: IO () main = do heading "Main compiler test suite" testCompiler - heading "psc-publish test suite" - testPscPublish heading "Documentation test suite" TestDocs.main + -- heading "psc-publish test suite" + -- testPscPublish where heading msg = do From e40d4d0e4267442925bf6ee75455648ae922dd0e Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 9 Jan 2016 20:57:23 +0000 Subject: [PATCH 0246/1580] Don't apply module collision renaming to current module --- src/Language/PureScript/CodeGen/JS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index e6491e1261..c77df0fe54 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -90,7 +90,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName go acc used (mn' : mns') = let mni = Ident $ runModuleName mn' - in if mni `elem` used + in if mn' /= mn && mni `elem` used then let newName = freshModuleName 1 mn' used in go (M.insert mn' newName acc) (Ident (runModuleName newName) : used) mns' else go (M.insert mn' mn' acc) (mni : used) mns' From 7ab867f54dfef13d1fa4c24e964c932cacd7b4c9 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 9 Jan 2016 21:05:00 +0000 Subject: [PATCH 0247/1580] Add position info to UnknownModule error --- src/Language/PureScript/Sugar/Names/Imports.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index caa155a650..886c8fc3b6 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -135,7 +135,7 @@ resolveImports env (Module ss coms currentModule decls exps) = updateImportRef :: Declaration -> m Declaration updateImportRef (PositionedDeclaration pos com d) = - warnWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d + warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do modExports <- getExports env mn typ' <- case typ of From 2dbb329546c467e13d2c6ede86502c345681a87f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 9 Jan 2016 14:39:19 -0800 Subject: [PATCH 0248/1580] Fix #1796, don't print to stderr when using json errors --- psc/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/psc/Main.hs b/psc/Main.hs index 2a8d4a9a88..6f7d8d00ba 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -76,13 +76,13 @@ printWarningsAndErrors verbose True warnings errors = do compile :: PSCMakeOptions -> IO () compile PSCMakeOptions{..} = do - input <- globWarningOnMisses warnFileTypeNotFound pscmInput - when (null input) $ do + input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput + when (null input && not pscmJSONErrors) $ do hPutStrLn stderr "psc: No input files." exitFailure let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input moduleFiles <- readInput (InputOptions pursFiles) - inputForeign <- globWarningOnMisses warnFileTypeNotFound pscmForeignInput + inputForeign <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmForeignInput foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile) (makeErrors, makeWarnings) <- runMake pscmOpts $ do (ms, foreigns) <- parseInputs moduleFiles foreignFiles From ce9743335acee10b1d0dd3ae13baf4db284e7f6e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 9 Jan 2016 15:37:56 -0800 Subject: [PATCH 0249/1580] Fix #1802, fix #1797, remove redundant hints and whitespace in errors --- src/Language/PureScript/Errors.hs | 50 ++++++++++++++++++++++++------- 1 file changed, 39 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index ccd977295b..d0f08d130e 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1,6 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiParamTypeClasses #-} module Language.PureScript.Errors where @@ -9,6 +8,7 @@ import Prelude () import Prelude.Compat import Data.Ord (comparing) +import Data.Char (isSpace) import Data.Either (lefts, rights) import Data.List (intercalate, transpose, nub, nubBy, sortBy) import Data.Foldable (fold) @@ -412,11 +412,9 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts gHint other = pure other - wikiUri :: ErrorMessage -> String wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e - -- | -- Pretty print a single error, simplifying if necessary -- @@ -432,17 +430,17 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap prettyPrintErrorMessage typeMap (ErrorMessage hints simple) = paras $ [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints - , Box.moveDown 1 typeInformation ] ++ + maybe [] (return . Box.moveDown 1) typeInformation ++ [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri e ++ " for more information, " , line $ "or to contribute content related to this " ++ levelText ++ "." ] - | showWiki + | showWiki ] where - typeInformation :: Box.Box - typeInformation | not (null types) = Box.hsep 1 Box.left [ line "where", paras types] - | otherwise = Box.emptyBox 0 0 + typeInformation :: Maybe Box.Box + typeInformation | not (null types) = Just $ Box.hsep 1 Box.left [ line "where", paras types ] + | otherwise = Nothing where types :: [Box.Box] types = map skolemInfo (M.elems (umSkolemMap typeMap)) ++ @@ -1026,7 +1024,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap where -- Take the last instance of each "hint category" simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint] - simplifyHints = reverse . nubBy categoriesEqual . reverse + simplifyHints = reverse . nubBy categoriesEqual . stripRedudantHints simple . reverse -- Don't remove hints in the "other" category categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool @@ -1036,6 +1034,30 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap (_, OtherHint) -> False (c1, c2) -> c1 == c2 + -- | See https://github.com/purescript/purescript/issues/1802 + stripRedudantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint] + stripRedudantHints CannotApplyFunction{} = stripFirst isApplicationHint + where + isApplicationHint ErrorInApplication{} = True + isApplicationHint _ = False + stripRedudantHints ExprDoesNotHaveType{} = stripFirst isCheckHint + where + isCheckHint ErrorCheckingType{} = True + isCheckHint _ = False + stripRedudantHints TypesDoNotUnify{} = stripFirst isUnifyHint + where + isUnifyHint ErrorUnifyingTypes{} = True + isUnifyHint _ = False + stripRedudantHints _ = id + + stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint] + stripFirst p (PositionedError pos : hs) = PositionedError pos : stripFirst p hs + stripFirst p (ErrorInModule mn : hs) = ErrorInModule mn : stripFirst p hs + stripFirst p (hint : hs) + | p hint = hs + | otherwise = hint : hs + stripFirst _ [] = [] + hintCategory :: ErrorMessageHint -> HintCategory hintCategory ErrorCheckingType{} = ExprHint hintCategory ErrorInferringType{} = ExprHint @@ -1137,9 +1159,15 @@ line :: String -> Box.Box line = Box.text renderBox :: Box.Box -> String -renderBox = unlines . map trimEnd . lines . Box.render +renderBox = unlines + . map (dropWhileEnd isSpace) + . dropWhile whiteSpace + . dropWhileEnd whiteSpace + . lines + . Box.render where - trimEnd = reverse . dropWhile (== ' ') . reverse + dropWhileEnd p = reverse . dropWhile p . reverse + whiteSpace = all isSpace -- | -- Rethrow an error with a more detailed error message in the case of failure From 9aa05e3d7897bbd261d22c007c81ce036c0bbf11 Mon Sep 17 00:00:00 2001 From: Rob Howard Date: Sun, 10 Jan 2016 19:44:37 +1100 Subject: [PATCH 0250/1580] Quotes psc-docs examples to avoid some shells incorrectly globbing files. --- psc-docs/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index 23db235b09..00c401efc8 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -230,16 +230,16 @@ examples = PP.vcat $ map PP.text [ "Examples:" , " print documentation for Data.List to stdout:" - , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\" + , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\" , " --docgen Data.List" , "" , " write documentation for Data.List to docs/Data.List.md:" - , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\" + , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\" , " --docgen Data.List:docs/Data.List.md" , "" , " write documentation for Data.List to docs/Data.List.md, and" , " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:" - , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\" + , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\" , " --docgen Data.List:docs/Data.List.md \\" , " --docgen Data.List.Lazy:docs/Data.List.Lazy.md" ] From d9d397eded09691072bd9906b21526291e1943de Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 10 Jan 2016 18:16:59 +0000 Subject: [PATCH 0251/1580] Enhancements to import linting --- src/Language/PureScript/AST/Declarations.hs | 4 + src/Language/PureScript/Errors.hs | 15 + src/Language/PureScript/Linter/Imports.hs | 316 ++++++++++++++------ src/Language/PureScript/Sugar/Names.hs | 2 +- 4 files changed, 249 insertions(+), 88 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index a75d5dd08f..858df12431 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -146,6 +146,10 @@ isImplicit :: ImportDeclarationType -> Bool isImplicit Implicit = True isImplicit _ = False +isExplicit :: ImportDeclarationType -> Bool +isExplicit (Explicit _) = True +isExplicit _ = False + -- | -- The data type of declarations -- diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index ccd977295b..290e5bf4e8 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -138,7 +138,9 @@ data SimpleErrorMessage | DuplicateExportRef String | IntOutOfRange Integer String Integer Integer | RedundantEmptyHidingImport ModuleName + | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef] | ImplicitImport ModuleName [DeclarationRef] + | HidingImport ModuleName [DeclarationRef] | CaseBinderLengthDiffers Int [Binder] deriving (Show) @@ -309,7 +311,9 @@ errorCode em = case unwrapErrorMessage em of DuplicateExportRef{} -> "DuplicateExportRef" IntOutOfRange{} -> "IntOutOfRange" RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport" + ImplicitQualifiedImport{} -> "ImplicitQualifiedImport" ImplicitImport{} -> "ImplicitImport" + HidingImport{} -> "HidingImport" CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers" -- | @@ -858,11 +862,22 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap renderSimpleErrorMessage (RedundantEmptyHidingImport mn) = line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden." + renderSimpleErrorMessage (ImplicitQualifiedImport importedModule asModule refs) = + paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports." + , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:" + , indent $ line $ "import " ++ runModuleName importedModule ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ") as " ++ runModuleName asModule + ] + renderSimpleErrorMessage (ImplicitImport mn refs) = paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: " , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ] + renderSimpleErrorMessage (HidingImport mn refs) = + paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: " + , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" + ] + renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) = paras $ [ line $ "Binder list length differs in case alternative:" , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 3a844c2df0..bd62f9131d 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -1,18 +1,23 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} -module Language.PureScript.Linter.Imports (findUnusedImports, Name(..), UsedImports()) where +module Language.PureScript.Linter.Imports + ( lintImports + , Name(..) + , UsedImports() + ) where import Prelude () import Prelude.Compat -import qualified Data.Map as M -import Data.Maybe (mapMaybe, isNothing) -import Data.List ((\\), find, intersect, nub) +import Control.Monad (unless, when) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class -import Control.Monad (unless,when) + import Data.Foldable (forM_) +import Data.List ((\\), find, intersect, nub) +import Data.Maybe (mapMaybe) +import qualified Data.Map as M import Language.PureScript.AST.Declarations import Language.PureScript.AST.SourcePos @@ -31,118 +36,247 @@ data Name | TyName (Qualified (ProperName 'TypeName)) | DctorName (Qualified (ProperName 'ConstructorName)) | TyClassName (Qualified (ProperName 'ClassName)) - deriving (Eq) + deriving (Eq, Show) -getIdentName :: Name -> Maybe Ident -getIdentName (IdentName (Qualified _ name)) = Just name -getIdentName _ = Nothing +getIdentName :: Maybe ModuleName -> Name -> Maybe Ident +getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name +getIdentName _ _ = Nothing -getTypeName :: Name -> Maybe (ProperName 'TypeName) -getTypeName (TyName (Qualified _ name)) = Just name -getTypeName _ = Nothing +getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName) +getTypeName q (TyName (Qualified q' name)) | q == q' = Just name +getTypeName _ _ = Nothing -getClassName :: Name -> Maybe (ProperName 'ClassName) -getClassName (TyClassName (Qualified _ name)) = Just name -getClassName _ = Nothing +getClassName :: Maybe ModuleName -> Name -> Maybe (ProperName 'ClassName) +getClassName q (TyClassName (Qualified q' name)) | q == q' = Just name +getClassName _ _ = Nothing -- | Map of module name to list of imported names from that module which have been used. type UsedImports = M.Map ModuleName [Name] -- | --- Find and warn on any unused import statements (qualified or unqualified) --- or references in an explicit import list. +-- Find and warn on: +-- +-- * Unused import statements (qualified or unqualified) +-- +-- * Unused references in an explicit import list -- -findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports -> m () -findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do - imps <- findImports mdecls - forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $ - forM_ decls $ \(ss, declType, qualifierName) -> - censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $ - let names = nub $ M.findWithDefault [] mni usedImps - usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names - usedDctors = mapMaybe (matchDctor qualifierName) names - in case declType of - Implicit | isNothing qualifierName -> - let classRefs = TypeClassRef <$> mapMaybe getClassName names - valueRefs = ValueRef <$> mapMaybe getIdentName names - types = mapMaybe getTypeName names - typesWithDctors = reconstructTypeRefs mni usedDctors - typesWithoutDctors = filter (`M.notMember` typesWithDctors) types - typesRefs - = map (flip TypeRef (Just [])) typesWithoutDctors - ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors) - allRefs = classRefs ++ typesRefs ++ valueRefs - in tell $ errorMessage $ - if null allRefs - then UnusedImport mni - else ImplicitImport mni allRefs - Explicit [] -> tell $ errorMessage $ UnusedImport mni - Explicit declrefs -> do - let idents = nub (mapMaybe runDeclRef declrefs) - let diff = idents \\ usedNames - case (length diff, length idents) of - (0, _) -> return () - (n, m) | n == m -> tell $ errorMessage $ UnusedImport mni - _ -> tell $ errorMessage $ UnusedExplicitImport mni diff - - -- If we've not already warned a type is unused, check its data constructors - forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do - let allCtors = dctorsForType mni tn - when (runProperName tn `elem` usedNames) $ case (c, usedDctors `intersect` allCtors) of - (_, []) | c /= Just [] -> - tell $ errorMessage $ UnusedDctorImport tn - (Just ctors, usedDctors') -> - let ddiff = ctors \\ usedDctors' - in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff - _ -> return () - - return () - - _ -> return () +-- * Implicit imports of modules +-- +-- * Implicit imports into a virtual module (unless the virtual module only has +-- members from one module imported) +-- +-- * Imports using `hiding` (this is another form of implicit importing) +-- +lintImports + :: forall m + . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Module + -> Env + -> UsedImports + -> m () +lintImports (Module _ _ mn mdecls mexports) env usedImps = do + + let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env) + usedImps' = foldr (elaborateUsed scope) usedImps exportedModules + + imps <- M.toAscList <$> findImports mdecls + + forM_ imps $ \(mni, decls) -> + unless (isPrim mni) $ do + forM_ decls $ \(ss, declType, qualifierName) -> + censor (onErrorMessages $ addModuleLocError ss) $ do + let names = nub $ M.findWithDefault [] mni usedImps' + lintImportDecl env mni qualifierName names declType + + forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do + let mnis = nub $ map (\(_, _, mni) -> mni) entries + unless (length mnis == 1) $ do + let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries + forM_ implicits $ \(ss, _, mni) -> + censor (onErrorMessages $ addModuleLocError ss) $ do + let names = nub $ M.findWithDefault [] mni usedImps' + usedRefs = findUsedRefs env mni (Just mnq) names + unless (null usedRefs) $ + tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs + + return () + where - reconstructTypeRefs :: ModuleName -> [ProperName 'ConstructorName] -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName] - reconstructTypeRefs mni = foldr accumDctors M.empty - where - accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor) - findTypeForDctor :: ModuleName -> ProperName 'ConstructorName -> ProperName 'TypeName - findTypeForDctor mn dctor = - case mn `M.lookup` env of - Just (_, _, exps) -> - case find (elem dctor . snd . fst) (exportedTypes exps) of - Just ((ty, _), _) -> ty - Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor" - Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor" + -- Checks whether a module is the Prim module - used to suppress any checks + -- made, as Prim is always implicitly imported. + isPrim :: ModuleName -> Bool + isPrim = (== ModuleName [ProperName C.prim]) + + -- Creates a map of virtual modules mapped to all the declarations that + -- import to that module, with the corresponding source span, import type, + -- and module being imported + byQual + :: [(ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])] + -> M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, ModuleName)] + byQual = foldr goImp M.empty + where + goImp (mni, xs) acc = foldr (goDecl mni) acc xs + goDecl mni (ss, declType, Just qmn) acc = + let entry = (ss, declType, mni) + in M.alter (Just . maybe [entry] (entry :)) qmn acc + goDecl _ _ acc = acc - -- rely on exports being elaborated by this point - alwaysUsedModules :: [ ModuleName ] - alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe extractModule) mexports + -- The list of modules that are being re-exported by the current module. Any + -- module that appears in this list is always considered to be used. + exportedModules :: [ModuleName] + exportedModules = nub $ maybe [] (mapMaybe extractModule) mexports where extractModule (PositionedDeclarationRef _ _ r) = extractModule r - extractModule (ModuleRef mn) = Just mn + extractModule (ModuleRef mne) = Just mne extractModule _ = Nothing - qnameUsed :: Maybe ModuleName -> Bool - qnameUsed (Just qn) = qn `elem` alwaysUsedModules - qnameUsed Nothing = False + -- Elaborates the UsedImports to include values from modules that are being + -- re-exported. This ensures explicit export hints are printed for modules + -- that are implicitly exported and then re-exported. + elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports + elaborateUsed scope mne used = + let classes = extractByQual mne (importedTypeClasses scope) TyClassName + types = extractByQual mne (importedTypes scope) TyName + dctors = extractByQual mne (importedDataConstructors scope) DctorName + values = extractByQual mne (importedValues scope) IdentName + in foldr go used (classes ++ types ++ dctors ++ values) + where + go :: (ModuleName, Name) -> UsedImports -> UsedImports + go (q, name) acc = M.alter (Just . maybe [name] (name :)) q acc + + extractByQual + :: (Eq a) + => ModuleName + -> M.Map (Qualified a) [(Qualified a, ModuleName)] + -> (Qualified a -> Name) + -> [(ModuleName, Name)] + extractByQual k m toName = mapMaybe go (M.toList m) + where + go (q@(Qualified mnq _), is) | isUnqualified q || isQualifiedWith k q = + case fst (head is) of + Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name) + _ -> internalError "unqualified name in extractByQual" + go _ = Nothing - dtys :: ModuleName -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] +lintImportDecl + :: forall m + . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Env + -> ModuleName + -> Maybe ModuleName + -> [Name] + -> ImportDeclarationType + -> m () +lintImportDecl env mni qualifierName names declType = + case declType of + Implicit -> case qualifierName of + Nothing -> checkImplicit ImplicitImport + Just q -> + let usedModuleNames = mapMaybe extractQualName names + in unless (q `elem` usedModuleNames) unused + Hiding _ -> checkImplicit HidingImport + Explicit [] -> unused + Explicit declrefs -> checkExplicit declrefs + + where + + checkImplicit + :: (ModuleName -> [DeclarationRef] -> SimpleErrorMessage) + -> m () + checkImplicit warning = + let allRefs = findUsedRefs env mni qualifierName names + in if null allRefs + then unused + else tell $ errorMessage $ warning mni allRefs + + checkExplicit + :: [DeclarationRef] + -> m () + checkExplicit declrefs = do + let idents = nub (mapMaybe runDeclRef declrefs) + dctors = mapMaybe (matchDctor qualifierName) names + usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names + diff = idents \\ usedNames + case (length diff, length idents) of + (0, _) -> return () + (n, m) | n == m -> unused + _ -> tell $ errorMessage $ UnusedExplicitImport mni diff + + -- If we've not already warned a type is unused, check its data constructors + forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do + let allCtors = dctorsForType mni tn + when (runProperName tn `elem` usedNames) $ case (c, dctors `intersect` allCtors) of + (_, []) | c /= Just [] -> + tell $ errorMessage $ UnusedDctorImport tn + (Just ctors, dctors') -> + let ddiff = ctors \\ dctors' + in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff + _ -> return () + return () + + unused :: m () + unused = tell $ errorMessage $ UnusedImport mni + + dtys + :: ModuleName + -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env - dctorsForType :: ModuleName -> ProperName 'TypeName -> [ProperName 'ConstructorName] + dctorsForType + :: ModuleName + -> ProperName 'TypeName + -> [ProperName 'ConstructorName] dctorsForType mn tn = maybe [] getDctors (find matches $ dtys mn) where matches ((ty, _),_) = ty == tn getDctors ((_,ctors),_) = ctors - typeForDCtor :: ModuleName -> ProperName 'ConstructorName -> Maybe (ProperName 'TypeName) + typeForDCtor + :: ModuleName + -> ProperName 'ConstructorName + -> Maybe (ProperName 'TypeName) typeForDCtor mn pn = getTy <$> find matches (dtys mn) where matches ((_, ctors), _) = pn `elem` ctors getTy ((ty, _), _) = ty +findUsedRefs :: Env -> ModuleName -> Maybe ModuleName -> [Name] -> [DeclarationRef] +findUsedRefs env mni qualifierName names = + let + classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names + valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names + types = mapMaybe (getTypeName qualifierName) names + dctors = mapMaybe (matchDctor qualifierName) names + typesWithDctors = reconstructTypeRefs dctors + typesWithoutDctors = filter (`M.notMember` typesWithDctors) types + typesRefs + = map (flip TypeRef (Just [])) typesWithoutDctors + ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors) + in classRefs ++ typesRefs ++ valueRefs + + where + + reconstructTypeRefs + :: [ProperName 'ConstructorName] + -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName] + reconstructTypeRefs = foldr accumDctors M.empty + where + accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor) + + findTypeForDctor + :: ModuleName + -> ProperName 'ConstructorName + -> ProperName 'TypeName + findTypeForDctor mn dctor = + case mn `M.lookup` env of + Just (_, _, exps) -> + case find (elem dctor . snd . fst) (exportedTypes exps) of + Just ((ty, _), _) -> ty + Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor" + Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor" matchName :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName)) @@ -155,6 +289,12 @@ matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperNam matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x matchName _ _ _ = Nothing +extractQualName :: Name -> Maybe ModuleName +extractQualName (IdentName (Qualified q _)) = q +extractQualName (TyName (Qualified q _)) = q +extractQualName (TyClassName (Qualified q _)) = q +extractQualName (DctorName (Qualified q _)) = q + matchDctor :: Maybe ModuleName -> Name -> Maybe (ProperName 'ConstructorName) matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x matchDctor _ _ = Nothing @@ -166,7 +306,9 @@ runDeclRef (TypeRef pn _) = Just $ runProperName pn runDeclRef (TypeClassRef pn) = Just $ runProperName pn runDeclRef _ = Nothing -getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) +getTypeRef + :: DeclarationRef + -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref getTypeRef (TypeRef pn x) = Just (pn, x) getTypeRef _ = Nothing diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 155fccf843..41a36c797f 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -95,7 +95,7 @@ desugarImports externs modules = do warnAndRethrow (addHint (ErrorInModule mn)) $ do let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m) - findUnusedImports m env used + lintImports m env used return m' -- | From 4961b372791c83a36492b139e91645088c308b82 Mon Sep 17 00:00:00 2001 From: "(cdep)illabout" Date: Tue, 12 Jan 2016 10:57:31 +0900 Subject: [PATCH 0252/1580] Add myself to the CONTRIBUTORS.md file. --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index d72c50c688..924e679c46 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -12,6 +12,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@balajirrao](https://github.com/balajirrao) (Balaji Rao) - My existing contributions and all future contributions until further notice are Copyright Balaji Rao, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@bergmark](https://github.com/bergmark) (Adam Bergmark) - My existing contributions and all future contributions until further notice are Copyright Adam Bergmark, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@Bogdanp](https://github.com/Bogdanp) (Bogdan Paul Popa) My existing contributions and all future contributions until further notice are Copyright Bogdan Paul Popa, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@cdepillabout](https://github.com/cdepillabout) (Dennis Gosnell) My existing contributions and all future contributions until further notice are Copyright Dennis Gosnell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@davidchambers](https://github.com/davidchambers) (David Chambers) My existing contributions and all future contributions until further notice are Copyright David Chambers, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@dckc](https://github.com/dckc) (Dan Connolly) My existing contributions and all future contributions until further notice are Copyright Dan Connolly, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@dylex](https://github.com/dylex) (Dylan Simon) My existing and all future contributions to the PureScript compiler until further notice are Copyright Dylan Simon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). From 761106e45528a18d075b2dfa7176e5167e7c10c1 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 13 Jan 2016 23:08:56 +0000 Subject: [PATCH 0253/1580] Relax rules for docs comments, fixes #1820 --- .../PureScript/Docs/Convert/Single.hs | 24 ++++++++++--------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index e95ed70945..ceec9b31ca 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -11,6 +11,7 @@ module Language.PureScript.Docs.Convert.Single import Prelude () import Prelude.Compat +import Data.Maybe (catMaybes) import Control.Monad import Control.Category ((>>>)) @@ -200,21 +201,22 @@ convertDeclaration _ _ = Nothing convertComments :: [P.Comment] -> Maybe String convertComments cs = do let raw = concatMap toLines cs - guard (all hasPipe raw && not (null raw)) - return (go raw) - where - go = unlines . map stripPipes + let docs = catMaybes (map stripPipe raw) + guard (not (null docs)) + pure (unlines docs) + where toLines (P.LineComment s) = [s] toLines (P.BlockComment s) = lines s - hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False } - - stripPipes = dropPipe . dropWhile (== ' ') - - dropPipe ('|':' ':s) = s - dropPipe ('|':s) = s - dropPipe s = s + stripPipe s' = + case dropWhile (== ' ') s' of + ('|':' ':s) -> + Just s + ('|':s) -> + Just s + _ -> + Nothing -- | Go through a PureScript module and extract a list of Bookmarks; references -- to data types or values, to be used as a kind of index. These are used for From 17b5c055e3671d9d4e34a7e1e665c665214ea2e9 Mon Sep 17 00:00:00 2001 From: Antti Holvikari Date: Thu, 14 Jan 2016 08:22:27 +0200 Subject: [PATCH 0254/1580] Rename `foreign` argument to fix compiling issue --- psci/Types.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/psci/Types.hs b/psci/Types.hs index 1f9ba2a87d..7465cdf6e5 100644 --- a/psci/Types.hs +++ b/psci/Types.hs @@ -51,11 +51,11 @@ mkPSCiState :: [ImportedModule] -> [P.Declaration] -> [String] -> PSCiState -mkPSCiState imported loaded foreign lets nodeFlags = +mkPSCiState imported loaded foreigns lets nodeFlags = (initialPSCiState |> each imported updateImportedModules |> updateModules loaded) - { psciForeignFiles = foreign + { psciForeignFiles = foreigns , psciLetBindings = lets , psciNodeFlags = nodeFlags } From 70ddf2be5596c0ee2e5ce19c3edbdc5770449d93 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 16 Jan 2016 15:40:03 -0800 Subject: [PATCH 0255/1580] Fix #1794, preserve external require expressions when minifying --- src/Language/PureScript/Bundle.hs | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index cee556fdf8..3efa43f38a 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -95,7 +95,7 @@ data ExportType -- Each is labelled with the original AST node which generated it, so that we can dump it back -- into the output during codegen. data ModuleElement - = Require JSNode String ModuleIdentifier + = Require JSNode String (Either String ModuleIdentifier) | Member JSNode Bool String [JSNode] [Key] | ExportsList [(ExportType, String, JSNode, [Key])] | Other JSNode @@ -137,13 +137,13 @@ node (NN n) = n node (NT n _ _) = n -- | Calculate the ModuleIdentifier which a require(...) statement imports. -checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier +checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier checkImportPath _ "./foreign" m _ = - Just (ModuleIdentifier (moduleName m) Foreign) + Right (ModuleIdentifier (moduleName m) Foreign) checkImportPath requirePath name _ names | Just name' <- stripPrefix (fromMaybe "" requirePath) name - , name' `S.member` names = Just (ModuleIdentifier name' Regular) -checkImportPath _ _ _ _ = Nothing + , name' `S.member` names = Right (ModuleIdentifier name' Regular) +checkImportPath _ name _ _ = Left name -- | Compute the dependencies of all elements in a module, and add them to the tree. -- @@ -166,7 +166,7 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es) imports = mapMaybe toImport es where toImport :: ModuleElement -> Maybe (String, ModuleIdentifier) - toImport (Require _ nm mid) = Just (nm, mid) + toImport (Require _ nm (Right mid)) = Just (nm, mid) toImport _ = Nothing -- | Collects all member names in scope, so that we can identify dependencies of the second type. @@ -226,7 +226,7 @@ toModule requirePath mids mid top , JSIdentifier "require" <- node req , JSArguments _ [ impS ] _ <- node impP , JSStringLiteral _ importPath <- node impS - , Just importPath' <- checkImportPath requirePath importPath mid mids + , importPath' <- checkImportPath requirePath importPath mid mids = pure (Require n importName importPath') toModuleElement n | JSVariables var [ varIntro ] _ <- node n @@ -371,7 +371,7 @@ sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (top return (m, mid, mapMaybe getKey els) getKey :: ModuleElement -> Maybe ModuleIdentifier - getKey (Require _ _ mi) = Just mi + getKey (Require _ _ (Right mi)) = Just mi getKey _ = Nothing -- | A module is empty if it contains no exported members (in other words, @@ -416,9 +416,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem declToJS (Require _ nm req) = [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ]) [ NN (JSVarDecl (sp (JSIdentifier nm)) - [ sp (JSLiteral "=") - , moduleReference sp (moduleName req) - ]) + (sp (JSLiteral "=") : either require (return . moduleReference sp . moduleName) req)) ] (nt (JSLiteral ";"))) ] declToJS (ExportsList exps) = map toExport exps @@ -467,6 +465,11 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem , lf ] + require :: String -> [JSNode] + require mn = [ sp (JSIdentifier "require") + , NN (JSArguments (nt (JSLiteral "(")) [ nt (JSStringLiteral '"' mn) ] (nt (JSLiteral ")"))) + ] + moduleReference :: (Node -> JSNode) -> String -> JSNode moduleReference f mn = NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ] From 75876fefb22811198038e0684ba12c66cd34fbb5 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 16 Jan 2016 15:56:27 -0800 Subject: [PATCH 0256/1580] Fix #1825, generate fresh binder names unless all names in case are equal --- examples/failing/1825.purs | 9 +++++++ .../PureScript/Sugar/CaseDeclarations.hs | 27 +++++++------------ 2 files changed, 18 insertions(+), 18 deletions(-) create mode 100644 examples/failing/1825.purs diff --git a/examples/failing/1825.purs b/examples/failing/1825.purs new file mode 100644 index 0000000000..0ffc5f240a --- /dev/null +++ b/examples/failing/1825.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith UnknownValue + +module Main where + +data W = X | Y | Z + +bad X a = a +bad Y _ = a +bad Z a = a diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 4858599ca0..da646f609d 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -150,7 +150,7 @@ toTuple _ = internalError "Not a value declaration" makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration makeCaseDeclaration ident alternatives = do let namedArgs = map findName . fst <$> alternatives - argNames = map join $ foldl1 resolveNames namedArgs + argNames = foldl1 resolveNames namedArgs args <- if allUnique (catMaybes argNames) then mapM argName argNames else replicateM (length argNames) freshIdent' @@ -160,14 +160,11 @@ makeCaseDeclaration ident alternatives = do return $ ValueDeclaration ident Public [] (Right value) where -- We will construct a table of potential names. - -- VarBinders will become Just (Just _) which is a potential name. - -- NullBinder will become Just Nothing, which indicates that we may + -- VarBinders will become Just _ which is a potential name. + -- Everything else becomes Nothing, which indicates that we -- have to generate a name. - -- Everything else becomes Nothing, which indicates that we definitely - -- have to generate a name. - findName :: Binder -> Maybe (Maybe Ident) - findName NullBinder = Just Nothing - findName (VarBinder name) = Just (Just name) + findName :: Binder -> Maybe Ident + findName (VarBinder name) = Just name findName (PositionedBinder _ _ binder) = findName binder findName _ = Nothing @@ -182,19 +179,13 @@ makeCaseDeclaration ident alternatives = do -- Combine two lists of potential names from two case alternatives -- by zipping correspoding columns. - resolveNames :: [Maybe (Maybe Ident)] -> - [Maybe (Maybe Ident)] -> - [Maybe (Maybe Ident)] + resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident] resolveNames = zipWith resolveName -- Resolve a pair of names. VarBinder beats NullBinder, and everything -- else results in Nothing. - resolveName :: Maybe (Maybe Ident) -> - Maybe (Maybe Ident) -> - Maybe (Maybe Ident) - resolveName (Just (Just a)) (Just (Just b)) - | a == b = Just (Just a) + resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident + resolveName (Just a) (Just b) + | a == b = Just a | otherwise = Nothing - resolveName (Just Nothing) a = a - resolveName a (Just Nothing) = a resolveName _ _ = Nothing From 3ea5bf4cd7232cedc141bcdfb637528595f1d381 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 10 Jan 2016 10:25:03 +0000 Subject: [PATCH 0257/1580] Expose error suggestions in JSON --- psc/JSON.hs | 9 ++ src/Language/PureScript/Errors.hs | 102 +++++++++++++++------- src/Language/PureScript/Linter/Imports.hs | 12 +-- 3 files changed, 86 insertions(+), 37 deletions(-) diff --git a/psc/JSON.hs b/psc/JSON.hs index f07a084e11..c6fb051685 100644 --- a/psc/JSON.hs +++ b/psc/JSON.hs @@ -30,6 +30,8 @@ data ErrorPosition = ErrorPosition , endColumn :: Int } +data ErrorSuggestion = ErrorSuggestion { replacement :: String } + data JSONError = JSONError { position :: Maybe ErrorPosition , message :: String @@ -37,6 +39,7 @@ data JSONError = JSONError , errorLink :: String , filename :: Maybe String , moduleName :: Maybe String + , suggestion :: Maybe ErrorSuggestion } data JSONResult = JSONResult @@ -47,6 +50,8 @@ data JSONResult = JSONResult $(A.deriveJSON A.defaultOptions ''ErrorPosition) $(A.deriveJSON A.defaultOptions ''JSONError) $(A.deriveJSON A.defaultOptions ''JSONResult) +$(A.deriveJSON A.defaultOptions ''ErrorSuggestion) + toJSONErrors :: Bool -> P.Level -> P.MultipleErrors -> [JSONError] toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErrors @@ -59,6 +64,7 @@ toJSONError verbose level e = (P.wikiUri e) (P.spanName <$> sspan) (P.runModuleName <$> P.errorModule e) + (toSuggestion <$> (P.errorSuggestion $ P.unwrapErrorMessage e)) where sspan :: Maybe P.SourceSpan sspan = P.errorSpan e @@ -69,3 +75,6 @@ toJSONError verbose level e = (P.sourcePosColumn (P.spanStart ss)) (P.sourcePosLine (P.spanEnd ss)) (P.sourcePosColumn (P.spanEnd ss)) + toSuggestion :: P.ErrorSuggestion -> ErrorSuggestion +-- TODO: Adding a newline because source spans chomp everything up to the next character + toSuggestion (P.ErrorSuggestion s) = ErrorSuggestion $ if null s then s else s ++ "\n" diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8fdcf39b74..64870574e1 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -124,7 +124,7 @@ data SimpleErrorMessage | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName) | ImportHidingModule ModuleName | UnusedImport ModuleName - | UnusedExplicitImport ModuleName [String] + | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef] | UnusedDctorImport (ProperName 'TypeName) | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName] | DeprecatedOperatorDecl String @@ -179,6 +179,8 @@ data HintCategory data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show) +newtype ErrorSuggestion = ErrorSuggestion String + -- | Get the source span for an error errorSpan :: ErrorMessage -> Maybe SourceSpan errorSpan = findHint matchSpan @@ -419,6 +421,40 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse wikiUri :: ErrorMessage -> String wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e +-- TODO Other possible suggestions: +-- WildcardInferredType - source span not small enough +-- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert +-- DeprecatedClassExport, DeprecatedClassImport, would want to replace smaller span? +errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion +errorSuggestion err = case err of + UnusedImport{} -> emptySuggestion + RedundantEmptyHidingImport{} -> emptySuggestion + DuplicateImport{} -> emptySuggestion + RedundantUnqualifiedImport{} -> emptySuggestion + DeprecatedQualifiedSyntax name qualName -> suggest $ + "import " ++ runModuleName name ++ " as " ++ runModuleName qualName + UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual + ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing + ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) + _ -> Nothing + + where + emptySuggestion = Just $ ErrorSuggestion "" + suggest = Just . ErrorSuggestion + + importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String + importSuggestion mn refs qual = + "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ++ qstr qual + + qstr :: Maybe ModuleName -> String + qstr (Just mn) = " as " ++ runModuleName mn + qstr Nothing = "" + +showSuggestion :: SimpleErrorMessage -> String +showSuggestion suggestion = case errorSuggestion suggestion of + Just (ErrorSuggestion x) -> x + _ -> "" + -- | -- Pretty print a single error, simplifying if necessary -- @@ -796,9 +832,11 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap renderSimpleErrorMessage (UnusedImport name) = line $ "The import of module " ++ runModuleName name ++ " is redundant" - renderSimpleErrorMessage (UnusedExplicitImport name names) = - paras [ line $ "The import of module " ++ runModuleName name ++ " contains the following unused references:" - , indent $ paras $ map line names ] + renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) = + paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:" + , indent $ paras $ map line names + , line $ "It could be replaced with:" + , indent $ line $ showSuggestion msg ] renderSimpleErrorMessage (UnusedDctorImport name) = line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used" @@ -860,15 +898,15 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap renderSimpleErrorMessage (RedundantEmptyHidingImport mn) = line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden." - renderSimpleErrorMessage (ImplicitQualifiedImport importedModule asModule refs) = + renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) = paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports." , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:" - , indent $ line $ "import " ++ runModuleName importedModule ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ") as " ++ runModuleName asModule + , indent $ line $ showSuggestion msg ] - renderSimpleErrorMessage (ImplicitImport mn refs) = + renderSimpleErrorMessage msg@(ImplicitImport mn _) = paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: " - , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" + , indent $ line $ showSuggestion msg ] renderSimpleErrorMessage (HidingImport mn refs) = @@ -1009,30 +1047,6 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap paras :: [Box.Box] -> Box.Box paras = Box.vcat Box.left - -- Pretty print and export declaration - prettyPrintExport :: DeclarationRef -> String - prettyPrintExport (TypeRef pn _) = runProperName pn - prettyPrintExport ref = prettyPrintRef ref - - prettyPrintRef :: DeclarationRef -> String - prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)" - prettyPrintRef (TypeRef pn (Just [])) = runProperName pn - prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")" - prettyPrintRef (ValueRef ident) = showIdent ident - prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn - prettyPrintRef (ProperRef name) = name - prettyPrintRef (TypeInstanceRef ident) = showIdent ident - prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name - prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref - - prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String - prettyPrintImport mn idt qual = - let i = case idt of - Implicit -> runModuleName mn - Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" - Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")" - in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual - -- | Simplify an error message simplifyErrorMessage :: ErrorMessage -> ErrorMessage simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple @@ -1084,6 +1098,30 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap hintCategory PositionedError{} = PositionHint hintCategory _ = OtherHint +-- Pretty print and export declaration +prettyPrintExport :: DeclarationRef -> String +prettyPrintExport (TypeRef pn _) = runProperName pn +prettyPrintExport ref = prettyPrintRef ref + +prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String +prettyPrintImport mn idt qual = + let i = case idt of + Implicit -> runModuleName mn + Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" + Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")" + in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual + +prettyPrintRef :: DeclarationRef -> String +prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)" +prettyPrintRef (TypeRef pn (Just [])) = runProperName pn +prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")" +prettyPrintRef (ValueRef ident) = showIdent ident +prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn +prettyPrintRef (ProperRef name) = name +prettyPrintRef (TypeInstanceRef ident) = showIdent ident +prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name +prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref + -- | -- Pretty print multiple errors -- diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index bd62f9131d..6ac06e919d 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -185,10 +185,9 @@ lintImportDecl env mni qualifierName names declType = :: (ModuleName -> [DeclarationRef] -> SimpleErrorMessage) -> m () checkImplicit warning = - let allRefs = findUsedRefs env mni qualifierName names - in if null allRefs - then unused - else tell $ errorMessage $ warning mni allRefs + if null allRefs + then unused + else tell $ errorMessage $ warning mni allRefs checkExplicit :: [DeclarationRef] @@ -201,7 +200,7 @@ lintImportDecl env mni qualifierName names declType = case (length diff, length idents) of (0, _) -> return () (n, m) | n == m -> unused - _ -> tell $ errorMessage $ UnusedExplicitImport mni diff + _ -> tell $ errorMessage $ UnusedExplicitImport mni diff qualifierName allRefs -- If we've not already warned a type is unused, check its data constructors forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do @@ -218,6 +217,9 @@ lintImportDecl env mni qualifierName names declType = unused :: m () unused = tell $ errorMessage $ UnusedImport mni + allRefs :: [DeclarationRef] + allRefs = findUsedRefs env mni qualifierName names + dtys :: ModuleName -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] From 1b948d0d413159fccbb06eb7301b636c32998d6e Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 17 Jan 2016 18:24:18 +0000 Subject: [PATCH 0258/1580] Include module name in re-exports internal errors Include the module name for all internal errors encountered during collection of documentation for re-exported declarations, just for the sake of helping debugging. --- .../PureScript/Docs/Convert/ReExports.hs | 100 ++++++++++++------ 1 file changed, 67 insertions(+), 33 deletions(-) diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 998b1062bd..467627ef1a 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -13,6 +13,8 @@ import Prelude.Compat import Control.Monad import Control.Monad.Trans.State.Strict (execState) import Control.Monad.State.Class (MonadState, gets, modify) +import Control.Monad.Trans.Reader (runReaderT) +import Control.Monad.Reader.Class (MonadReader, ask) import Control.Arrow ((&&&), first, second) import Data.Either import Data.Maybe (mapMaybe) @@ -76,9 +78,12 @@ getReExports env mn = case Map.lookup mn env of Nothing -> internalError ("Module missing: " ++ P.runModuleName mn) - Just (_, imports, exports) -> - let notLocal = (/= mn) . fst - in filter notLocal <$> collectDeclarations imports exports + Just (_, imports, exports) -> do + allExports <- runReaderT (collectDeclarations imports exports) mn + pure (filter notLocal allExports) + + where + notLocal = (/= mn) . fst -- | -- Assemble a list of declarations re-exported from a particular module, based @@ -100,7 +105,9 @@ getReExports env mn = -- class members are listed. -- collectDeclarations :: - (Functor m, Applicative m, MonadState (Map P.ModuleName Module) m) => + (Functor m, Applicative m, + MonadState (Map P.ModuleName Module) m, + MonadReader P.ModuleName m) => P.Imports -> P.Exports -> m [(P.ModuleName, [Declaration])] @@ -109,7 +116,7 @@ collectDeclarations imports exports = do typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs types <- collect lookupTypeDeclaration impTypes expTypes - let (vals, classes) = handleTypeClassMembers valsAndMembers typeClasses + (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses let filteredTypes = filterDataConstructors expCtors types let filteredClasses = filterTypeClassMembers (map fst expVals) classes @@ -117,9 +124,9 @@ collectDeclarations imports exports = do pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals])) where - collect lookup' imps exps = - Map.fromListWith (<>) <$> traverse (uncurry lookup') - (map (findImport imps) exps) + collect lookup' imps exps = do + imps' <- traverse (findImport imps) exps + Map.fromListWith (<>) <$> traverse (uncurry lookup') imps' expVals = P.exportedValues exports impVals = concat (Map.elems (P.importedValues imports)) @@ -147,19 +154,21 @@ collectDeclarations imports exports = do -- instantiate @name@ as both 'P.Ident' and 'P.ProperName'. -- findImport :: - (Show name, Eq name) => + (Show name, Eq name, Applicative m, MonadReader P.ModuleName m) => [(P.Qualified name, P.ModuleName)] -> (name, P.ModuleName) -> - (P.ModuleName, name) + m (P.ModuleName, name) findImport imps (name, orig) = case filter (\(qual, mn) -> P.disqualify qual == name && mn == orig) imps of [(P.Qualified (Just importedFrom) _, _)] -> - (importedFrom, name) + pure (importedFrom, name) other -> - internalError ("findImport: unexpected result: " ++ show other) + internalErrorInModule ("findImport: unexpected result: " ++ show other) lookupValueDeclaration :: - (MonadState (Map P.ModuleName Module) m, Applicative m) => + (Applicative m, + MonadState (Map P.ModuleName Module) m, + MonadReader P.ModuleName m) => P.ModuleName -> P.Ident -> m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration]) @@ -170,7 +179,7 @@ lookupValueDeclaration importedFrom ident = do filter (\d -> declTitle d == P.showIdent ident && (isValue d || isAlias d)) decls errOther other = - internalError + internalErrorInModule ("lookupValueDeclaration: unexpected result:\n" ++ "other: " ++ show other ++ "\n" ++ "ident: " ++ show ident ++ "\n" ++ @@ -216,7 +225,9 @@ lookupValueDeclaration importedFrom ident = do -- are only included in the output if they are listed in the arguments. -- lookupTypeDeclaration :: - (MonadState (Map P.ModuleName Module) m, Applicative m) => + (Applicative m, + MonadState (Map P.ModuleName Module) m, + MonadReader P.ModuleName m) => P.ModuleName -> P.ProperName 'P.TypeName -> m (P.ModuleName, [Declaration]) @@ -228,11 +239,13 @@ lookupTypeDeclaration importedFrom ty = do [d] -> pure (importedFrom, [d]) other -> - internalError + internalErrorInModule ("lookupTypeDeclaration: unexpected result: " ++ show other) lookupTypeClassDeclaration :: - (MonadState (Map P.ModuleName Module) m, Applicative m) => + (Applicative m, + MonadState (Map P.ModuleName Module) m, + MonadReader P.ModuleName m) => P.ModuleName -> P.ProperName 'P.ClassName -> m (P.ModuleName, [Declaration]) @@ -246,15 +259,18 @@ lookupTypeClassDeclaration importedFrom tyClass = do [d] -> pure (importedFrom, [d]) other -> - internalError ("lookupTypeClassDeclaration: unexpected result: " - ++ (unlines . map show) other) + internalErrorInModule + ("lookupTypeClassDeclaration: unexpected result: " + ++ (unlines . map show) other) -- | -- Get the full list of declarations for a particular module out of the -- state, or raise an internal error if it is not there. -- lookupModuleDeclarations :: - (Applicative m, MonadState (Map P.ModuleName Module) m) => + (Applicative m, + MonadState (Map P.ModuleName Module) m, + MonadReader P.ModuleName m) => String -> P.ModuleName -> m [Declaration] @@ -262,15 +278,18 @@ lookupModuleDeclarations definedIn moduleName = do mmdl <- gets (Map.lookup moduleName) case mmdl of Nothing -> - internalError (definedIn ++ ": module missing: " - ++ P.runModuleName moduleName) + internalErrorInModule + (definedIn ++ ": module missing: " + ++ P.runModuleName moduleName) Just mdl -> pure (allDeclarations mdl) handleTypeClassMembers :: + (Functor m, Applicative m, + MonadReader P.ModuleName m) => Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] -> Map P.ModuleName [Declaration] -> - (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration]) + m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration]) handleTypeClassMembers valsAndMembers typeClasses = let moduleEnvs = @@ -279,8 +298,8 @@ handleTypeClassMembers valsAndMembers typeClasses = (fmap typeClassesToEnv typeClasses) in moduleEnvs - |> fmap handleEnv - |> splitMap + |> traverse handleEnv + |> fmap splitMap valsAndMembersToEnv :: [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv @@ -336,11 +355,15 @@ instance Monoid TypeClassEnv where -- -- Returns a tuple of (values, type classes). -- -handleEnv :: TypeClassEnv -> ([Declaration], [Declaration]) +handleEnv :: + (Functor m, Applicative m, + MonadReader P.ModuleName m) => + TypeClassEnv -> + m ([Declaration], [Declaration]) handleEnv TypeClassEnv{..} = envUnhandledMembers - |> foldl go (envValues, mkMap envTypeClasses) - |> second Map.elems + |> foldM go (envValues, mkMap envTypeClasses) + |> fmap (second Map.elems) where mkMap = @@ -351,14 +374,15 @@ handleEnv TypeClassEnv{..} = Just _ -> -- Leave the state unchanged; if the type class is there, the child -- will be too. - (values, tcs) - Nothing -> - (promoteChild constraint childDecl : values, tcs) + pure (values, tcs) + Nothing -> do + c <- promoteChild constraint childDecl + pure (c : values, tcs) promoteChild constraint ChildDeclaration{..} = case cdeclInfo of ChildTypeClassMember typ -> - Declaration + pure $ Declaration { declTitle = cdeclTitle , declComments = cdeclComments , declSourceSpan = cdeclSourceSpan @@ -367,7 +391,7 @@ handleEnv TypeClassEnv{..} = , declInfo = ValueDeclaration (addConstraint constraint typ) } _ -> - internalError + internalErrorInModule ("handleEnv: Bad child declaration passed to promoteChild: " ++ cdeclTitle) @@ -429,6 +453,16 @@ x |> f = f x internalError :: String -> a internalError = P.internalError . ("Docs.Convert.ReExports: " ++) +internalErrorInModule :: + (MonadReader P.ModuleName m) => + String -> + m a +internalErrorInModule msg = do + mn <- ask + internalError + ("while collecting re-exports for module: " ++ P.runModuleName mn ++ + ", " ++ msg) + -- | -- If the provided Declaration is a TypeClassDeclaration, construct an -- appropriate Constraint for use with the types of its members. From 2a915fd1496b8011616f1529d5f7ab0d5066fe7b Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 18 Jan 2016 14:54:09 +0000 Subject: [PATCH 0259/1580] psc-docs: Fix crash for certain kinds of reexports Fixes #1831: crashes in psc-docs and psc-publish when encountering modules which re-export declarations which were imported from more than one module. For example, if: * a module A defines and exports a value `foo` * another module B re-exports `foo` from A * C re-exports both A and B this would cause a crash. With this fix, we document `foo` as having been re-exported from whichever module out of A and B appears first in the Imports list from C's Env. --- examples/docs/src/ImportedTwice.purs | 27 +++++++++++++++++++ .../PureScript/Docs/Convert/ReExports.hs | 18 +++++++++---- 2 files changed, 40 insertions(+), 5 deletions(-) create mode 100644 examples/docs/src/ImportedTwice.purs diff --git a/examples/docs/src/ImportedTwice.purs b/examples/docs/src/ImportedTwice.purs new file mode 100644 index 0000000000..fc135458aa --- /dev/null +++ b/examples/docs/src/ImportedTwice.purs @@ -0,0 +1,27 @@ +-- See also an example in the wild: purescript-transformers v0.8.4. +-- Control.Monad.RWS.Trans re-exports `lift` from both Control.Monad.Trans +-- (where it is originally defined) and Control.Monad.RWS.Class (which +-- re-exports it from Control.Monad.Trans). + +module ImportedTwice + ( module A + , module B + ) + where + +import A +import B + +module A + ( module B ) + where + +import B + +bar :: Int +bar = 1 + +module B where + +foo :: Int +foo = 0 diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 467627ef1a..a42d0e68af 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -159,11 +159,19 @@ findImport :: (name, P.ModuleName) -> m (P.ModuleName, name) findImport imps (name, orig) = - case filter (\(qual, mn) -> P.disqualify qual == name && mn == orig) imps of - [(P.Qualified (Just importedFrom) _, _)] -> - pure (importedFrom, name) - other -> - internalErrorInModule ("findImport: unexpected result: " ++ show other) + let + matches (qual, mn) = P.disqualify qual == name && mn == orig + matching = filter matches imps + getQualified (P.Qualified mname _) = mname + in + case mapMaybe (getQualified . fst) matching of + -- A value can occur more than once if it is imported twice (eg, if it is + -- exported by A, re-exported from A by B, and C imports it from both A + -- and B). In this case, we just take its first appearance. + (importedFrom:_) -> + pure (importedFrom, name) + [] -> + internalErrorInModule ("findImport: not found: " ++ show (name, orig)) lookupValueDeclaration :: (Applicative m, From ab5af8870c73e3e20d3565822503ec5e4648197c Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 20 Jan 2016 19:24:51 +0000 Subject: [PATCH 0260/1580] Fix generic deriving bug with >1 type argument --- .../PureScript/Sugar/TypeClasses/Deriving.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 86b0f824f8..d011a35c7d 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -17,6 +17,7 @@ import Data.List (foldl', find, sortBy) import Data.Maybe (fromMaybe) import Data.Ord (comparing) +import Control.Arrow (second) import Control.Monad (replicateM) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Error.Class (MonadError(..)) @@ -55,11 +56,13 @@ deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration p deriveInstance _ _ e = return e unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type]) -unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, []) -unwrapTypeConstructor (TypeApp ty arg) = do - (tyCon, args) <- unwrapTypeConstructor ty - return (tyCon, arg : args) -unwrapTypeConstructor _ = Nothing +unwrapTypeConstructor = fmap (second reverse) . go + where + go (TypeConstructor tyCon) = Just (tyCon, []) + go (TypeApp ty arg) = do + (tyCon, args) <- go ty + return (tyCon, arg : args) + go _ = Nothing dataGeneric :: ModuleName dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] From ebb7f8d29a8177ad23621b93da77c9200c5af9ae Mon Sep 17 00:00:00 2001 From: sharkdp Date: Wed, 20 Jan 2016 23:18:47 +0100 Subject: [PATCH 0261/1580] Add myself to the CONTRIBUTORS.md file. --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index fa70525ede..3e7e06bc73 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -51,6 +51,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@robdaemon](https://github.com/robdaemon) (Robert Roland) My existing contributions and all future contributions until further notice are Copyright Robert Roland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@RossMeikleham](https://github.com/RossMeikleham) (Ross Meikleham) My existing contributions and all future contributions until further notice are Copyright Ross Meikleham, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@sebastiaanvisser](https://github.com/sebastiaanvisser) (Sebastiaan Visser) - My existing contributions and all future contributions until further notice are Copyright Sebastiaan Visser, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. +- [@sharkdp](https://github.com/sharkdp) (David Peter) My existing contributions and all future contributions until further notice are Copyright David Peter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@sztupi](https://github.com/sztupi) (Attila Sztupak) My existing contributions and all future contributions until further notice are Copyright Attila Sztupak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@taku0](https://github.com/taku0) - My existing contributions and all future contributions until further notice are Copyright taku0, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@trofi](https://github.com/trofi) (Sergei Trofimovich) My existing contributions and all future contributions until further notice are Copyright Sergei Trofimovich, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). From e935aa37980493085fd6a7c1b197ff16849fcba4 Mon Sep 17 00:00:00 2001 From: sharkdp Date: Thu, 21 Jan 2016 08:43:32 +0100 Subject: [PATCH 0262/1580] Fix #1839, Renaming for nested constructor binders This commit changes the `everywhereOnValues` traversal in `CoreFn.Traversals` to call the binder function `h` recursively on nested binders. --- src/Language/PureScript/CoreFn/Traversals.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs index a5791684b9..8b10f678c5 100644 --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -40,6 +40,7 @@ everywhereOnValues f g h = (f', g', h') h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b)) h' (NamedBinder a name b) = h (NamedBinder a name (h' b)) + h' (ConstructorBinder a q1 q2 bs) = h (ConstructorBinder a q1 q2 (map h' bs)) h' b = h b handleCaseAlternative ca = From d866f68371b9df8f040512fcde29494a6847f0af Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Thu, 21 Jan 2016 22:52:33 +0000 Subject: [PATCH 0263/1580] Updates & fixes for JS inliner --- .../PureScript/CodeGen/JS/Optimizer.hs | 22 +- .../PureScript/CodeGen/JS/Optimizer/Common.hs | 27 +- .../CodeGen/JS/Optimizer/Inliner.hs | 324 ++++++++++-------- .../CodeGen/JS/Optimizer/MagicDo.hs | 53 +-- src/Language/PureScript/Constants.hs | 124 +++++-- 5 files changed, 320 insertions(+), 230 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs index 5e2a38e9fb..014d0358bb 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -1,13 +1,5 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen.JS.Optimizer --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE FlexibleContexts #-} + -- | -- This module optimizes code in the simplified-Javascript intermediate representation. -- @@ -29,13 +21,7 @@ -- -- * Inlining primitive Javascript operators -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} - -module Language.PureScript.CodeGen.JS.Optimizer ( - optimize -) where +module Language.PureScript.CodeGen.JS.Optimizer (optimize) where import Prelude () import Prelude.Compat @@ -79,7 +65,9 @@ optimize' js = do , inlineVariables , inlineValues , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x] + , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp f [x] , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x] + , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp f [x] , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer , inlineCommonOperators ]) js diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs index 1cc24d3c79..2bbb99a9ca 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs @@ -1,18 +1,6 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen.JS.Optimizer.Common --- Copyright : (c) Phil Freeman 2013-14 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Common functions used by the various optimizer phases -- ------------------------------------------------------------------------------ - module Language.PureScript.CodeGen.JS.Optimizer.Common where import Data.Maybe (fromMaybe) @@ -76,3 +64,18 @@ isUpdated var1 = everythingOnJS (||) check removeFromBlock :: ([JS] -> [JS]) -> JS -> JS removeFromBlock go (JSBlock sts) = JSBlock (go sts) removeFromBlock _ js = js + +isFn :: (String, String) -> JS -> Bool +isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName +isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName +isFn _ _ = False + +isFn' :: [(String, String)] -> JS -> Bool +isFn' xs js = any (`isFn` js) xs + +isDict :: (String, String) -> JS -> Bool +isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName +isDict _ _ = False + +isDict' :: [(String, String)] -> JS -> Bool +isDict' xs js = any (`isDict` js) xs diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index 8b42305b90..a0b326b021 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -1,28 +1,16 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen.JS.Optimizer.Inliner --- Copyright : (c) Phil Freeman 2013-14 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- This module provides basic inlining capabilities -- ------------------------------------------------------------------------------ - -module Language.PureScript.CodeGen.JS.Optimizer.Inliner ( - inlineVariables, - inlineValues, - inlineOperator, - inlineCommonOperators, - inlineFnComposition, - etaConvert, - unThunk, - evaluateIifes -) where +module Language.PureScript.CodeGen.JS.Optimizer.Inliner + ( inlineVariables + , inlineValues + , inlineOperator + , inlineCommonOperators + , inlineFnComposition + , etaConvert + , unThunk + , evaluateIifes + ) where import Prelude () import Prelude.Compat @@ -93,26 +81,26 @@ inlineValues :: JS -> JS inlineValues = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp fn [dict]) | isDict semiringNumber dict && isFn fnZero fn = JSNumericLiteral (Left 0) - | isDict semiringNumber dict && isFn fnOne fn = JSNumericLiteral (Left 1) - | isDict semiringInt dict && isFn fnZero fn = JSNumericLiteral (Left 0) - | isDict semiringInt dict && isFn fnOne fn = JSNumericLiteral (Left 1) - | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral False - | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral True + convert (JSApp fn [dict]) + | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral (Left 0) + | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral (Left 1) + | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral False + | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral True convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) - | isDict semiringInt dict && isFn fnAdd fn = JSBinary BitwiseOr (JSBinary Add x y) (JSNumericLiteral (Left 0)) - | isDict semiringInt dict && isFn fnMultiply fn = JSBinary BitwiseOr (JSBinary Multiply x y) (JSNumericLiteral (Left 0)) - | isDict moduloSemiringInt dict && isFn fnDivide fn = JSBinary BitwiseOr (JSBinary Divide x y) (JSNumericLiteral (Left 0)) - | isDict ringInt dict && isFn fnSubtract fn = JSBinary BitwiseOr (JSBinary Subtract x y) (JSNumericLiteral (Left 0)) + | isDict' semiringInt dict && isFn' fnAdd fn = intOp Add x y + | isDict' semiringInt dict && isFn' fnMultiply fn = intOp Multiply x y + | isDict' moduloSemiringInt dict && isFn' fnDivide fn = intOp Divide x y + | isDict' ringInt dict && isFn' fnSubtract fn = intOp Subtract x y convert other = other - fnZero = (C.prelude, C.zero) - fnOne = (C.prelude, C.one) - fnBottom = (C.prelude, C.bottom) - fnTop = (C.prelude, C.top) - fnAdd = (C.prelude, (C.+)) - fnDivide = (C.prelude, (C./)) - fnMultiply = (C.prelude, (C.*)) - fnSubtract = (C.prelude, (C.-)) + fnZero = [(C.prelude, C.zero), (C.dataSemiring, C.zero)] + fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)] + fnBottom = [(C.prelude, C.bottom), (C.dataBounded, C.bottom)] + fnTop = [(C.prelude, C.top), (C.dataBounded, C.top)] + fnAdd = [(C.prelude, (C.+)), (C.prelude, (C.add)), (C.dataSemiring, (C.+)), (C.dataSemiring, (C.add))] + fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataModuloSemiring, C.div)] + fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))] + fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)] + intOp op x y = JSBinary BitwiseOr (JSBinary op x y) (JSNumericLiteral (Left 0)) inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS inlineOperator (m, op) f = everywhereOnJS convert @@ -126,43 +114,54 @@ inlineOperator (m, op) f = everywhereOnJS convert inlineCommonOperators :: JS -> JS inlineCommonOperators = applyAll $ - [ binary semiringNumber (C.+) Add - , binary semiringNumber (C.*) Multiply - - , binary ringNumber (C.-) Subtract - , unary ringNumber C.negate Negate - , binary ringInt (C.-) Subtract - , unary ringInt C.negate Negate - - , binary moduloSemiringNumber (C./) Divide - , binary moduloSemiringInt C.mod Modulus - - , binary eqNumber (C.==) EqualTo - , binary eqNumber (C./=) NotEqualTo - , binary eqInt (C.==) EqualTo - , binary eqInt (C./=) NotEqualTo - , binary eqString (C.==) EqualTo - , binary eqString (C./=) NotEqualTo - , binary eqBoolean (C.==) EqualTo - , binary eqBoolean (C./=) NotEqualTo - - , binary ordNumber (C.<) LessThan - , binary ordNumber (C.>) GreaterThan - , binary ordNumber (C.<=) LessThanOrEqualTo - , binary ordNumber (C.>=) GreaterThanOrEqualTo - , binary ordInt (C.<) LessThan - , binary ordInt (C.>) GreaterThan - , binary ordInt (C.<=) LessThanOrEqualTo - , binary ordInt (C.>=) GreaterThanOrEqualTo - - , binary semigroupString (C.<>) Add - , binary semigroupString (C.++) Add - - , binary booleanAlgebraBoolean (C.&&) And - , binary booleanAlgebraBoolean (C.||) Or - , binaryFunction booleanAlgebraBoolean C.conj And - , binaryFunction booleanAlgebraBoolean C.disj Or - , unary booleanAlgebraBoolean C.not Not + [ binary semiringNumber opAdd Add + , binary semiringNumber opMul Multiply + + , binary ringNumber opSub Subtract + , unary ringNumber opNegate Negate + , binary ringInt opSub Subtract + , unary ringInt opNegate Negate + + , binary moduloSemiringNumber opDiv Divide + , binary moduloSemiringInt opMod Modulus + + , binary eqNumber opEq EqualTo + , binary eqNumber opNotEq NotEqualTo + , binary eqInt opEq EqualTo + , binary eqInt opNotEq NotEqualTo + , binary eqString opEq EqualTo + , binary eqString opNotEq NotEqualTo + , binary eqChar opEq EqualTo + , binary eqChar opNotEq NotEqualTo + , binary eqBoolean opEq EqualTo + , binary eqBoolean opNotEq NotEqualTo + + , binary ordBoolean opLessThan LessThan + , binary ordBoolean opLessThanOrEq LessThanOrEqualTo + , binary ordBoolean opGreaterThan GreaterThan + , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo + , binary ordChar opLessThan LessThan + , binary ordChar opLessThanOrEq LessThanOrEqualTo + , binary ordChar opGreaterThan GreaterThan + , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo + , binary ordInt opLessThan LessThan + , binary ordInt opLessThanOrEq LessThanOrEqualTo + , binary ordInt opGreaterThan GreaterThan + , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo + , binary ordNumber opLessThan LessThan + , binary ordNumber opLessThanOrEq LessThanOrEqualTo + , binary ordNumber opGreaterThan GreaterThan + , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo + , binary ordString opLessThan LessThan + , binary ordString opLessThanOrEq LessThanOrEqualTo + , binary ordString opGreaterThan GreaterThan + , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo + + , binary semigroupString opAppend Add + + , binary booleanAlgebraBoolean opConj And + , binary booleanAlgebraBoolean opDisj Or + , unary booleanAlgebraBoolean opNot Not , binary' C.dataIntBits (C..|.) BitwiseOr , binary' C.dataIntBits (C..&.) BitwiseAnd @@ -174,11 +173,11 @@ inlineCommonOperators = applyAll $ ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] where - binary :: (String, String) -> String -> BinaryOperator -> JS -> JS - binary dict opString op = everywhereOnJS convert + binary :: [(String, String)] -> [(String, String)] -> BinaryOperator -> JS -> JS + binary dict fns op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = JSBinary op x y + convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary op x y convert other = other binary' :: String -> String -> BinaryOperator -> JS -> JS binary' moduleName opString op = everywhereOnJS convert @@ -186,17 +185,11 @@ inlineCommonOperators = applyAll $ convert :: JS -> JS convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y convert other = other - binaryFunction :: (String, String) -> String -> BinaryOperator -> JS -> JS - binaryFunction dict fnName op = everywhereOnJS convert - where - convert :: JS -> JS - convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isPreludeFn fnName fn && isDict dict dict' = JSBinary op x y - convert other = other - unary :: (String, String) -> String -> UnaryOperator -> JS -> JS - unary dict fnName op = everywhereOnJS convert + unary :: [(String, String)] -> [(String, String)] -> UnaryOperator -> JS -> JS + unary dicts fns op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp fn [dict']) [x]) | isPreludeFn fnName fn && isDict dict dict' = JSUnary op x + convert (JSApp (JSApp fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary op x convert other = other unary' :: String -> String -> UnaryOperator -> JS -> JS unary' moduleName fnName op = everywhereOnJS convert @@ -246,71 +239,130 @@ inlineFnComposition :: (Applicative m, MonadSupply m) => JS -> m JS inlineFnComposition = everywhereOnJSTopDownM convert where convert :: (MonadSupply m) => JS -> m JS - convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z]) | isFnCompose dict' fn = - return $ JSApp x [JSApp y [z]] - convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isFnCompose dict' fn = do - arg <- freshName - return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]]) + convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z]) + | isFnCompose dict' fn = return $ JSApp x [JSApp y [z]] + | isFnComposeFlipped dict' fn = return $ JSApp y [JSApp x [z]] + convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) + | isFnCompose dict' fn = do + arg <- freshName + return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]]) + | isFnComposeFlipped dict' fn = do + arg <- freshName + return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp y [JSApp x [JSVar arg]]]) convert other = return other isFnCompose :: JS -> JS -> Bool - isFnCompose dict' fn = isDict semigroupoidFn dict' && (isPreludeFn (C.<<<) fn || isPreludeFn C.compose fn) + isFnCompose dict' fn = isDict' semigroupoidFn dict' && isFn' fnCompose fn + isFnComposeFlipped :: JS -> JS -> Bool + isFnComposeFlipped dict' fn = isDict' semigroupoidFn dict' && isFn' fnComposeFlipped fn + fnCompose :: [(String, String)] + fnCompose = [(C.prelude, C.compose), (C.prelude, (C.<<<)), (C.controlSemigroupoid, C.compose)] + fnComposeFlipped :: [(String, String)] + fnComposeFlipped = [(C.prelude, (C.>>>)), (C.controlSemigroupoid, C.composeFlipped)] + +semiringNumber :: [(String, String)] +semiringNumber = [(C.prelude, C.semiringNumber), (C.dataSemiring, C.semiringNumber)] + +semiringInt :: [(String, String)] +semiringInt = [(C.prelude, C.semiringInt), (C.dataSemiring, C.semiringInt)] + +ringNumber :: [(String, String)] +ringNumber = [(C.prelude, C.ringNumber), (C.dataRing, C.ringNumber)] + +ringInt :: [(String, String)] +ringInt = [(C.prelude, C.ringInt), (C.dataRing, C.ringInt)] + +moduloSemiringNumber :: [(String, String)] +moduloSemiringNumber = [(C.prelude, C.moduloSemiringNumber), (C.dataModuloSemiring, C.moduloSemiringNumber)] + +moduloSemiringInt :: [(String, String)] +moduloSemiringInt = [(C.prelude, C.moduloSemiringInt), (C.dataModuloSemiring, C.moduloSemiringInt)] + +eqNumber :: [(String, String)] +eqNumber = [(C.prelude, C.eqNumber), (C.dataEq, C.eqNumber)] + +eqInt :: [(String, String)] +eqInt = [(C.prelude, C.eqInt), (C.dataEq, C.eqInt)] + +eqString :: [(String, String)] +eqString = [(C.prelude, C.eqString), (C.dataEq, C.eqString)] + +eqChar :: [(String, String)] +eqChar = [(C.prelude, C.eqChar), (C.dataEq, C.eqChar)] + +eqBoolean :: [(String, String)] +eqBoolean = [(C.prelude, C.eqBoolean), (C.dataEq, C.eqBoolean)] + +ordBoolean :: [(String, String)] +ordBoolean = [(C.prelude, C.ordBoolean), (C.dataOrd, C.ordBoolean)] + +ordNumber :: [(String, String)] +ordNumber = [(C.prelude, C.ordNumber), (C.dataOrd, C.ordNumber)] + +ordInt :: [(String, String)] +ordInt = [(C.prelude, C.ordInt), (C.dataOrd, C.ordInt)] + +ordString :: [(String, String)] +ordString = [(C.prelude, C.ordString), (C.dataOrd, C.ordString)] + +ordChar :: [(String, String)] +ordChar = [(C.prelude, C.ordChar), (C.dataOrd, C.ordChar)] + +semigroupString :: [(String, String)] +semigroupString = [(C.prelude, C.semigroupString), (C.dataSemigroup, C.semigroupString)] -isDict :: (String, String) -> JS -> Bool -isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName -isDict _ _ = False +boundedBoolean :: [(String, String)] +boundedBoolean = [(C.prelude, C.boundedBoolean), (C.dataBounded, C.boundedBoolean)] -isFn :: (String, String) -> JS -> Bool -isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName -isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName -isFn _ _ = False +booleanAlgebraBoolean :: [(String, String)] +booleanAlgebraBoolean = [(C.prelude, C.booleanAlgebraBoolean), (C.dataBooleanAlgebra, C.booleanAlgebraBoolean)] -isPreludeFn :: String -> JS -> Bool -isPreludeFn fnName = isFn (C.prelude, fnName) +semigroupoidFn :: [(String, String)] +semigroupoidFn = [(C.prelude, C.semigroupoidFn), (C.controlSemigroupoid, C.semigroupoidFn)] -semiringNumber :: (String, String) -semiringNumber = (C.prelude, C.semiringNumber) +opAdd :: [(String, String)] +opAdd = [(C.prelude, (C.+)), (C.prelude, C.add), (C.dataSemiring, C.add)] -semiringInt :: (String, String) -semiringInt = (C.prelude, C.semiringInt) +opMul :: [(String, String)] +opMul = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, C.mul)] -ringNumber :: (String, String) -ringNumber = (C.prelude, C.ringNumber) +opEq :: [(String, String)] +opEq = [(C.prelude, (C.==)), (C.prelude, C.eq), (C.dataEq, C.eq)] -ringInt :: (String, String) -ringInt = (C.prelude, C.ringInt) +opNotEq :: [(String, String)] +opNotEq = [(C.prelude, (C./=)), (C.dataEq, C.notEq)] -moduloSemiringNumber :: (String, String) -moduloSemiringNumber = (C.prelude, C.moduloSemiringNumber) +opLessThan :: [(String, String)] +opLessThan = [(C.prelude, (C.<)), (C.dataOrd, C.lessThan)] -moduloSemiringInt :: (String, String) -moduloSemiringInt = (C.prelude, C.moduloSemiringInt) +opLessThanOrEq :: [(String, String)] +opLessThanOrEq = [(C.prelude, (C.<=)), (C.dataOrd, C.lessThanOrEq)] -eqNumber :: (String, String) -eqNumber = (C.prelude, C.eqNumber) +opGreaterThan :: [(String, String)] +opGreaterThan = [(C.prelude, (C.>)), (C.dataOrd, C.greaterThan)] -eqInt :: (String, String) -eqInt = (C.prelude, C.eqInt) +opGreaterThanOrEq :: [(String, String)] +opGreaterThanOrEq = [(C.prelude, (C.>=)), (C.dataOrd, C.greaterThanOrEq)] -eqString :: (String, String) -eqString = (C.prelude, C.eqNumber) +opAppend :: [(String, String)] +opAppend = [(C.prelude, (C.<>)), (C.prelude, (C.++)), (C.prelude, C.append), (C.dataSemigroup, C.append)] -eqBoolean :: (String, String) -eqBoolean = (C.prelude, C.eqNumber) +opSub :: [(String, String)] +opSub = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)] -ordNumber :: (String, String) -ordNumber = (C.prelude, C.ordNumber) +opNegate :: [(String, String)] +opNegate = [(C.prelude, C.negate), (C.dataRing, C.negate)] -ordInt :: (String, String) -ordInt = (C.prelude, C.ordInt) +opDiv :: [(String, String)] +opDiv = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataModuloSemiring, C.div)] -semigroupString :: (String, String) -semigroupString = (C.prelude, C.semigroupString) +opMod :: [(String, String)] +opMod = [(C.prelude, C.mod), (C.dataModuloSemiring, C.mod)] -boundedBoolean :: (String, String) -boundedBoolean = (C.prelude, C.boundedBoolean) +opConj :: [(String, String)] +opConj = [(C.prelude, (C.&&)), (C.prelude, C.conj), (C.dataBooleanAlgebra, C.conj)] -booleanAlgebraBoolean :: (String, String) -booleanAlgebraBoolean = (C.prelude, C.booleanAlgebraBoolean) +opDisj :: [(String, String)] +opDisj = [(C.prelude, (C.||)), (C.prelude, C.disj), (C.dataBooleanAlgebra, C.disj)] -semigroupoidFn :: (String, String) -semigroupoidFn = (C.prelude, C.semigroupoidFn) +opNot :: [(String, String)] +opNot = [(C.prelude, C.not), (C.dataBooleanAlgebra, C.not)] diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs index 2f57bc8c9c..fb5eda80fe 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs @@ -1,29 +1,14 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen.JS.Optimizer.MagicDo --- Copyright : (c) Phil Freeman 2013-14 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- This module implements the "Magic Do" optimization, which inlines calls to return -- and bind for the Eff monad, as well as some of its actions. -- ------------------------------------------------------------------------------ - -module Language.PureScript.CodeGen.JS.Optimizer.MagicDo ( - magicDo -) where +module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (magicDo) where import Data.List (nub) import Data.Maybe (fromJust, isJust) import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.CodeGen.JS.Common -import Language.PureScript.Names +import Language.PureScript.CodeGen.JS.Optimizer.Common import Language.PureScript.Options import qualified Language.PureScript.Constants as C @@ -54,9 +39,7 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert fnName = "__do" -- Desugar monomorphic calls to >>= and return for the Eff monad convert :: JS -> JS - -- Desugar return - convert (JSApp (JSApp ret [val]) []) | isReturn ret = val - -- Desugar pure + -- Desugar pure & return convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val -- Desugar >> convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind = @@ -72,33 +55,19 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) [] convert other = other -- Check if an expression represents a monomorphic call to >>= for the Eff monad - isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True + isBind (JSApp fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True isBind _ = False - -- Check if an expression represents a monomorphic call to return for the Eff monad - isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True - isReturn _ = False - -- Check if an expression represents a monomorphic call to pure for the Eff applicative - isPure (JSApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True + -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative + isPure (JSApp fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True isPure _ = False -- Check if an expression represents the polymorphic >>= function - isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && (prop `elem` map identToJs [Ident C.bind, Op (C.>>=)]) - isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && (bind `elem` [C.bind, (C.>>=)]) - isBindPoly _ = False - -- Check if an expression represents the polymorphic return function - isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped - isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return - isRetPoly _ = False - -- Check if an expression represents the polymorphic pure function - isPurePoly (JSAccessor pure' (JSVar prelude)) = prelude == C.prelude && pure' == C.pure' - isPurePoly (JSIndexer (JSStringLiteral pure') (JSVar prelude)) = prelude == C.prelude && pure' == C.pure' - isPurePoly _ = False - -- Check if an expression represents a function in the Ef module + isBindPoly = isFn' [(C.prelude, C.bind), (C.prelude, (C.>>=)), (C.controlBind, C.bind)] + -- Check if an expression represents the polymorphic pure or return function + isPurePoly = isFn' [(C.prelude, C.pure'), (C.prelude, C.return), (C.controlApplicative, C.pure')] + -- Check if an expression represents a function in the Eff module isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name' isEffFunc _ _ = False - -- Check if an expression represents the Monad Eff dictionary - isEffDict name (JSVar ident) | ident == name = True - isEffDict name (JSAccessor prop (JSVar eff)) = eff == C.eff && prop == name - isEffDict _ _ = False + -- Remove __do function applications which remain after desugaring undo :: JS -> JS undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 1614449779..573654ac5f 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -1,18 +1,6 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Constants --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Various constants which refer to things in the Prelude -- ------------------------------------------------------------------------------ - module Language.PureScript.Constants where -- Operators @@ -20,59 +8,107 @@ module Language.PureScript.Constants where ($) :: String ($) = "$" +apply :: String +apply = "apply" + (#) :: String (#) = "#" +applyFlipped :: String +applyFlipped = "applyFlipped" + (<>) :: String (<>) = "<>" (++) :: String (++) = "++" +append :: String +append = "append" + (>>=) :: String (>>=) = ">>=" +bind :: String +bind = "bind" + (+) :: String (+) = "+" +add :: String +add = "add" + (-) :: String (-) = "-" +sub :: String +sub = "sub" + (*) :: String (*) = "*" +mul :: String +mul = "mul" + (/) :: String (/) = "/" +div :: String +div = "div" + (%) :: String (%) = "%" +mod :: String +mod = "mod" + (<) :: String (<) = "<" +lessThan :: String +lessThan = "lessThan" + (>) :: String (>) = ">" +greaterThan :: String +greaterThan = "greaterThan" + (<=) :: String (<=) = "<=" +lessThanOrEq :: String +lessThanOrEq = "lessThanOrEq" + (>=) :: String (>=) = ">=" +greaterThanOrEq :: String +greaterThanOrEq = "greaterThanOrEq" + (==) :: String (==) = "==" +eq :: String +eq = "eq" + (/=) :: String (/=) = "/=" +notEq :: String +notEq = "notEq" + (&&) :: String (&&) = "&&" +conj :: String +conj = "conj" + (||) :: String (||) = "||" -bind :: String -bind = "bind" +disj :: String +disj = "disj" unsafeIndex :: String unsafeIndex = "unsafeIndex" @@ -92,6 +128,12 @@ unsafeIndex = "unsafeIndex" compose :: String compose = "compose" +(>>>) :: String +(>>>) = ">>>" + +composeFlipped :: String +composeFlipped = "composeFlipped" + -- Functions negate :: String @@ -100,15 +142,6 @@ negate = "negate" not :: String not = "not" -conj :: String -conj = "conj" - -disj :: String -disj = "disj" - -mod :: String -mod = "mod" - shl :: String shl = "shl" @@ -211,12 +244,21 @@ moduloSemiringNumber = "moduloSemiringNumber" moduloSemiringInt :: String moduloSemiringInt = "moduloSemiringInt" +ordBoolean :: String +ordBoolean = "ordBoolean" + ordNumber :: String ordNumber = "ordNumber" ordInt :: String ordInt = "ordInt" +ordString :: String +ordString = "ordString" + +ordChar :: String +ordChar = "ordChar" + eqNumber :: String eqNumber = "eqNumber" @@ -226,6 +268,9 @@ eqInt = "eqInt" eqString :: String eqString = "eqString" +eqChar :: String +eqChar = "eqChar" + eqBoolean :: String eqBoolean = "eqBoolean" @@ -285,6 +330,39 @@ eff = "Control_Monad_Eff" st :: String st = "Control_Monad_ST" +controlApplicative :: String +controlApplicative = "Control_Applicative" + +controlSemigroupoid :: String +controlSemigroupoid = "Control_Semigroupoid" + +controlBind :: String +controlBind = "Control_Bind" + +dataBounded :: String +dataBounded = "Data_Bounded" + +dataSemigroup :: String +dataSemigroup = "Data_Semigroup" + +dataModuloSemiring :: String +dataModuloSemiring = "Data_ModuloSemiring" + +dataBooleanAlgebra :: String +dataBooleanAlgebra = "Data_BooleanAlgebra" + +dataEq :: String +dataEq = "Data_Eq" + +dataOrd :: String +dataOrd = "Data_Ord" + +dataSemiring :: String +dataSemiring = "Data_Semiring" + +dataRing :: String +dataRing = "Data_Ring" + dataFunction :: String dataFunction = "Data_Function" From cfb5c0c8a0582870bc8b232b5b063f32f05ae891 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Thu, 21 Jan 2016 23:29:51 +0000 Subject: [PATCH 0264/1580] Add missing cases to usedModules --- src/Language/PureScript/ModuleDependencies.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 8b08793b4a..b1f3e845f7 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -23,7 +23,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Data.Graph import Data.List (nub) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe) import Language.PureScript.Crash import Language.PureScript.AST @@ -54,22 +54,24 @@ sortModules ms = do -- Calculate a list of used modules based on explicit imports and qualified names -- usedModules :: Declaration -> [ModuleName] -usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f +usedModules d = + let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) + (g, _, _, _, _) = accumTypes (everythingOnTypes (++) forTypes) + in nub (f d ++ g d) where forDecls :: Declaration -> [ModuleName] forDecls (ImportDeclaration mn _ _ _) = [mn] forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn] + forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn] forDecls _ = [] forValues :: Expr -> [ModuleName] forValues (Var (Qualified (Just mn) _)) = [mn] forValues (Constructor (Qualified (Just mn) _)) = [mn] - forValues (TypedValue _ _ ty) = forTypes ty forValues _ = [] forTypes :: Type -> [ModuleName] forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn] - forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs forTypes _ = [] -- | From 5a3cb289b96667a9844d9ca39c83c8478cb6949f Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 22 Jan 2016 02:39:29 +0000 Subject: [PATCH 0265/1580] Support new location of `otherwise` in exhaustivity checker --- src/Language/PureScript/Linter/Exhaustive.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 4496b387df..c63e7664cd 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -203,6 +203,7 @@ isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs isOtherwise :: Expr -> Bool isOtherwise (TypedValue _ (BooleanLiteral True) _) = True isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True + isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) _) = True isOtherwise _ = False isExhaustiveGuard (Right _) = True From 1934294ad77b214491356f7929b6a38985f3462e Mon Sep 17 00:00:00 2001 From: suppi Date: Fri, 22 Jan 2016 12:24:03 +0200 Subject: [PATCH 0266/1580] adding qualified name lookup for psci :browse --- psci/PSCi.hs | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index a296c23df6..4ea0342014 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -14,7 +14,7 @@ import Prelude.Compat import Data.Foldable (traverse_) import Data.Maybe (mapMaybe) -import Data.List (intersperse, intercalate, nub, sort) +import Data.List (intersperse, intercalate, nub, sort, find) import Data.Tuple (swap) import Data.Version (showVersion) import qualified Data.Map as M @@ -486,9 +486,22 @@ handleBrowse moduleName = do case env of Left errs -> printErrors errs Right env' -> - if moduleName `notElem` (nub . map ((\ (P.Module _ _ modName _ _ ) -> modName) . snd)) (psciLoadedModules st) - then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid." - else printModuleSignatures moduleName env' + if isModInEnv moduleName st + then printModuleSignatures moduleName env' + else case lookupUnQualifiedModName moduleName st of + Just unQualifiedName -> + if isModInEnv unQualifiedName st + then printModuleSignatures unQualifiedName env' + else failNotInEnv moduleName + Nothing -> + failNotInEnv moduleName + where + isModInEnv modName = + any ((== modName) . P.getModuleName . snd) . psciLoadedModules + failNotInEnv modName = + PSCI $ outputStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid." + lookupUnQualifiedModName quaModName st = + (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st) -- | Pretty-print errors printErrors :: P.MultipleErrors -> PSCI () From cca823fde37833521a445749bdb9c9fbb279cf5b Mon Sep 17 00:00:00 2001 From: nicodelpiano Date: Tue, 26 Jan 2016 01:56:16 -0300 Subject: [PATCH 0267/1580] Solves #1853 --- src/Language/PureScript/Linter/Exhaustive.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index c63e7664cd..b28905b5a8 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -31,13 +31,13 @@ import Language.PureScript.Kinds import Language.PureScript.Types as P import Language.PureScript.Errors --- | There are two modes of failure for the redudancy check: +-- | There are two modes of failure for the redundancy check: -- -- 1. Exhaustivity was incomplete due to too many cases, so we couldn't determine redundancy. -- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder. -- -- We want to warn the user in the first case. -data RedudancyError = Incomplete | Unknown +data RedundancyError = Incomplete | Unknown -- | -- Qualifies a propername from a given qualified propername and a default module name @@ -106,7 +106,7 @@ genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs') -- Find the uncovered set between two binders: -- the first binder is the case we are trying to cover, the second one is the matching binder -- -missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedudancyError Bool) +missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedundancyError Bool) missingCasesSingle _ _ _ NullBinder = ([], return True) missingCasesSingle _ _ _ (VarBinder _) = ([], return True) missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b @@ -175,7 +175,7 @@ missingCasesSingle _ _ b _ = ([b], Left Unknown) -- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker -- (which ought to be available soon), or increase the complexity of the algorithm. -- -missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedudancyError Bool) +missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool) missingCasesMultiple env mn = go where go [] [] = ([], pure True) @@ -210,10 +210,10 @@ isExhaustiveGuard (Right _) = True -- | -- Returns the uncovered set of case alternatives -- -missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedudancyError Bool) +missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedundancyError Bool) missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca) -missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedudancyError Bool) +missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool) missingAlternative env mn ca uncovered | isExhaustiveGuard (caseAlternativeResult ca) = mcases | otherwise = ([uncovered], snd mcases) @@ -229,13 +229,13 @@ missingAlternative env mn ca uncovered checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m () checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas where - step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]])) + step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]])) step (uncovered, (nec, redundant)) ca = let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered) (missed', approx) = splitAt 10000 (nub (concat missed)) - cond = liftA2 (&&) (or <$> sequenceA pr) nec + cond = or <$> sequenceA pr in (missed', ( if null approx - then cond + then liftA2 (&&) cond nec else Left Incomplete , if either (const True) id cond then redundant @@ -243,7 +243,7 @@ checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ fold ) ) - makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m () + makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m () makeResult (bss, (rr, bss')) = do unless (hasConstraint || null bss) tellNonExhaustive unless (null bss') tellRedundant From 5481c38d2f128b9c4929f330b6cffba17fcc42ca Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 25 Jan 2016 15:02:05 +0000 Subject: [PATCH 0268/1580] Workaround for TCO/composition inlining interaction --- examples/passing/TCO.purs | 20 ++++++++++++++++ .../PureScript/CodeGen/JS/Optimizer.hs | 24 +++++++++++-------- .../CodeGen/JS/Optimizer/Inliner.hs | 6 ++--- 3 files changed, 37 insertions(+), 13 deletions(-) create mode 100644 examples/passing/TCO.purs diff --git a/examples/passing/TCO.purs b/examples/passing/TCO.purs new file mode 100644 index 0000000000..85671785f3 --- /dev/null +++ b/examples/passing/TCO.purs @@ -0,0 +1,20 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (print) + +main = do + let f x = x + 1 + let v = 0 + print (applyN 0 f v) + print (applyN 1 f v) + print (applyN 2 f v) + print (applyN 3 f v) + print (applyN 4 f v) + +applyN :: forall a. Int -> (a -> a) -> a -> a +applyN = go id + where + go f n _ | n <= 0 = f + go f n g = go (f >>> g) (n - 1) g + diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs index 014d0358bb..0b28e17b73 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -51,11 +51,21 @@ optimize js = do optimize' :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => JS -> m JS optimize' js = do opts <- ask - untilFixedPoint (inlineFnComposition . applyAll + js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll + [ inlineCommonValues + , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x] + , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp f [x] + , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x] + , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp f [x] + , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer + , inlineCommonOperators + ]) js + untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js' + where + tidyUp :: JS -> JS + tidyUp = applyAll [ collapseNestedBlocks , collapseNestedIfs - , tco opts - , magicDo opts , removeCodeAfterReturnStatements , removeUnusedArg , removeUndefinedApp @@ -63,13 +73,7 @@ optimize' js = do , etaConvert , evaluateIifes , inlineVariables - , inlineValues - , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x] - , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp f [x] - , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x] - , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp f [x] - , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer - , inlineCommonOperators ]) js + ] untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a untilFixedPoint f = go diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index a0b326b021..2b5cbd3dde 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -3,7 +3,7 @@ -- module Language.PureScript.CodeGen.JS.Optimizer.Inliner ( inlineVariables - , inlineValues + , inlineCommonValues , inlineOperator , inlineCommonOperators , inlineFnComposition @@ -77,8 +77,8 @@ inlineVariables = everywhereOnJS $ removeFromBlock go go (map (replaceIdent var js) sts) go (s:sts) = s : go sts -inlineValues :: JS -> JS -inlineValues = everywhereOnJS convert +inlineCommonValues :: JS -> JS +inlineCommonValues = everywhereOnJS convert where convert :: JS -> JS convert (JSApp fn [dict]) From 280726b80fca701743b3ee9794216da50a8c1398 Mon Sep 17 00:00:00 2001 From: David Lindbom Date: Sat, 23 Jan 2016 20:58:09 +0100 Subject: [PATCH 0269/1580] Extended parser to accept unicode arrows --- CONTRIBUTORS.md | 1 + examples/passing/UnicodeType.purs | 23 +++++++++++++++++++++++ src/Language/PureScript/Parser/Lexer.hs | 6 ++++++ src/Language/PureScript/Parser/Types.hs | 2 +- 4 files changed, 31 insertions(+), 1 deletion(-) create mode 100644 examples/passing/UnicodeType.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 3e7e06bc73..b4c76eb334 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -64,6 +64,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@DavidLindbom](https://github.com/DavidLindbom) (David Lindbom) My existing contributions and all future contributions until further notice are Copyright David Lindbom, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/examples/passing/UnicodeType.purs b/examples/passing/UnicodeType.purs new file mode 100644 index 0000000000..7e4ecb9ccd --- /dev/null +++ b/examples/passing/UnicodeType.purs @@ -0,0 +1,23 @@ +module Main where + +import Prelude + +class (Monad m) ⇐ Monad1 m where + f1 :: Int + +class (Monad m) <= Monad2 m where + f2 :: Int + +f ∷ ∀ m. Monad m ⇒ Int → m Int +f n = do + n' ← return n + return n' + +f' :: forall m. Monad m => Int -> m Int +f' n = do + n' <- return n + return n' + +(←→) a b = a ←→ b + +main = Control.Monad.Eff.Console.log "Done" diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 20ddf8b5cc..4cabc01991 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -185,10 +185,15 @@ parsePositionedToken = P.try $ do parseToken :: P.Parsec String u Token parseToken = P.choice [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow + , P.try $ P.string "←" *> P.notFollowedBy symbolChar *> pure LArrow , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow + , P.try $ P.string "⇐" *> P.notFollowedBy symbolChar *> pure LFatArrow , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow + , P.try $ P.string "→" *> P.notFollowedBy symbolChar *> pure RArrow , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow + , P.try $ P.string "⇒" *> P.notFollowedBy symbolChar *> pure RFatArrow , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon + , P.try $ P.string "∷" *> P.notFollowedBy symbolChar *> pure DoubleColon , P.try $ P.char '(' *> pure LParen , P.try $ P.char ')' *> pure RParen , P.try $ P.char '{' *> pure LBrace @@ -411,6 +416,7 @@ reserved :: String -> TokenParser () reserved s = token go P. show s where go (LName s') | s == s' = Just () + go (Symbol s') | s == s' = Just () go _ = Nothing uname :: TokenParser String diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 8e8d729412..ca14aa5585 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -36,7 +36,7 @@ parseTypeConstructor :: TokenParser Type parseTypeConstructor = TypeConstructor <$> parseQualified properName parseForAll :: TokenParser Type -parseForAll = mkForAll <$> (reserved "forall" *> P.many1 (indented *> identifier) <* indented <* dot) +parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (indented *> identifier) <* indented <* dot) <*> parseType -- | From 22c9dfdaec294adb53257be090748dbf06cbb118 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 2 Feb 2016 21:12:45 -0800 Subject: [PATCH 0270/1580] Fix #1846, start work on '_ - 1' syntax for sections --- examples/failing/AnonArgument.purs | 5 +++ .../passing/ExplicitOperatorSections.purs | 11 +++++ src/Language/PureScript/AST/Declarations.hs | 19 ++------ src/Language/PureScript/AST/Traversals.hs | 23 +--------- src/Language/PureScript/Errors.hs | 44 +++++++++++-------- .../PureScript/Parser/Declarations.hs | 34 ++++++-------- src/Language/PureScript/Pretty/Values.hs | 4 +- .../PureScript/Sugar/ObjectWildcards.hs | 41 ++++++++++------- src/Language/PureScript/Sugar/Operators.hs | 10 +---- 9 files changed, 88 insertions(+), 103 deletions(-) create mode 100644 examples/failing/AnonArgument.purs create mode 100644 examples/passing/ExplicitOperatorSections.purs diff --git a/examples/failing/AnonArgument.purs b/examples/failing/AnonArgument.purs new file mode 100644 index 0000000000..74759b0b64 --- /dev/null +++ b/examples/failing/AnonArgument.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith IncorrectAnonymousArgument +module Main where + +test :: Int -> Int +test = _ diff --git a/examples/passing/ExplicitOperatorSections.purs b/examples/passing/ExplicitOperatorSections.purs new file mode 100644 index 0000000000..cd88833f64 --- /dev/null +++ b/examples/passing/ExplicitOperatorSections.purs @@ -0,0 +1,11 @@ +module Main where + +import Prelude + +subtractOne :: Int -> Int +subtractOne = _ - 1 + +addOne :: Int -> Int +addOne = 1 + _ + +main = Control.Monad.Eff.Console.log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 858df12431..333e4c3229 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -334,11 +334,6 @@ data Expr -- | BinaryNoParens Expr Expr Expr -- | - -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor - -- will be removed. - -- - | Parens Expr - -- | -- Operator section. This will be removed during desugaring and replaced with a partially applied -- operator or lambda to flip the arguments. -- @@ -352,11 +347,6 @@ data Expr -- | ObjectLiteral [(String, Expr)] -- | - -- An object constructor (object literal with underscores). This will be removed during - -- desugaring and expanded into a lambda that returns an object literal. - -- - | ObjectConstructor [(String, Maybe Expr)] - -- | -- An object property getter (e.g. `_.x`). This will be removed during -- desugaring and expanded into a lambda that reads a property from an object. -- @@ -370,11 +360,6 @@ data Expr -- | ObjectUpdate Expr [(String, Expr)] -- | - -- Partial record updater. This will be removed during desugaring and - -- expanded into a lambda that returns an object update. - -- - | ObjectUpdater (Maybe Expr) [(String, Maybe Expr)] - -- | -- Function introduction -- | Abs (Either Ident Binder) Expr @@ -433,6 +418,10 @@ data Expr -- | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type] -- | + -- A placeholder for an anonymous function argument + -- + | AnonymousArgument + -- | -- A value with source position information -- | PositionedValue SourceSpan [Comment] Expr diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 0f7e62cb01..5a9a852359 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -23,7 +23,7 @@ import Data.Foldable (fold) import qualified Data.Set as S import Control.Monad -import Control.Arrow ((***), (+++), second) +import Control.Arrow ((***), (+++)) import Language.PureScript.AST.Binders import Language.PureScript.AST.Declarations @@ -49,16 +49,13 @@ everywhereOnValues f g h = (f', g', h') g' :: Expr -> Expr g' (UnaryMinus v) = g (UnaryMinus (g' v)) g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2)) - g' (Parens v) = g (Parens (g' v)) g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v)) g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v)) g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs)) g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs)) - g' (ObjectConstructor vs) = g (ObjectConstructor (map (second (fmap g')) vs)) g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v)) g' (Accessor prop v) = g (Accessor prop (g' v)) g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs)) - g' (ObjectUpdater obj vs) = g (ObjectUpdater (fmap g' obj) (map (second (fmap g')) vs)) g' (Abs name v) = g (Abs name (g' v)) g' (App v1 v2) = g (App (g' v1) (g' v2)) g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3)) @@ -107,16 +104,13 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g') g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g') - g' (Parens v) = Parens <$> (g v >>= g') g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g')) g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g')) g' (ArrayLiteral vs) = ArrayLiteral <$> traverse (g' <=< g) vs g' (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g' <=< g)) vs - g' (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g' <=< g)) vs g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g') g' (Accessor prop v) = Accessor prop <$> (g v >>= g') g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs - g' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> traverse (sndM $ maybeM (g' <=< g)) vs g' (Abs name v) = Abs name <$> (g v >>= g') g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g') g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g') @@ -160,16 +154,13 @@ everywhereOnValuesM f g h = (f', g', h') g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g - g' (Parens v) = (Parens <$> g' v) >>= g g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g g' (ArrayLiteral vs) = (ArrayLiteral <$> traverse g' vs) >>= g g' (ObjectLiteral vs) = (ObjectLiteral <$> traverse (sndM g') vs) >>= g - g' (ObjectConstructor vs) = (ObjectConstructor <$> traverse (sndM $ maybeM g') vs) >>= g g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g - g' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> traverse (sndM $ maybeM g') vs) >>= g g' (Abs name v) = (Abs name <$> g' v) >>= g g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g @@ -216,16 +207,13 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') g' v@(UnaryMinus v1) = g v <> g' v1 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2 - g' v@(Parens v1) = g v <> g' v1 g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1 g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs) g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs) - g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs)) g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1 g' v@(Accessor _ v1) = g v <> g' v1 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs) - g' v@(ObjectUpdater obj vs) = foldl (<>) (maybe (g v) (\x -> g v <> g' x) obj) (map g' (mapMaybe snd vs)) g' v@(Abs _ v1) = g v <> g' v1 g' v@(App v1 v2) = g v <> g' v1 <> g' v2 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3 @@ -283,16 +271,13 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' g' s (UnaryMinus v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 - g' s (Parens v1) = g'' s v1 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs) g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs) - g' s (ObjectConstructor vs) = foldl (<>) r0 (map (g'' s) (mapMaybe snd vs)) g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs) - g' s (ObjectUpdater obj vs) = foldl (<>) (maybe r0 (g'' s) obj) (map (g'' s) (mapMaybe snd vs)) g' s (Abs _ v1) = g'' s v1 g' s (App v1 v2) = g'' s v1 <> g'' s v2 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 @@ -353,16 +338,13 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g' s (UnaryMinus v) = UnaryMinus <$> g'' s v g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2 - g' s (Parens v) = Parens <$> g'' s v g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v) g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v) g' s (ArrayLiteral vs) = ArrayLiteral <$> traverse (g'' s) vs g' s (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g'' s)) vs - g' s (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g'' s)) vs g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v g' s (Accessor prop v) = Accessor prop <$> g'' s v g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs - g' s (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> traverse (sndM $ maybeM (g'' s)) vs g' s (Abs name v) = Abs name <$> g'' s v g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3 @@ -435,16 +417,13 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' s (UnaryMinus v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2 - g' s (Parens v1) = g'' s v1 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v g' s (ArrayLiteral vs) = foldMap (g'' s) vs g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs - g' s (ObjectConstructor vs) = foldMap (g'' s) (mapMaybe snd vs) g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs - g' s (ObjectUpdater obj vs) = foldMap (g'' s) obj <> foldMap (g'' s) (mapMaybe snd vs) g' s (Abs (Left name) v1) = let s' = S.insert name s in g'' s' v1 diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 64870574e1..9666285dfa 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -142,6 +142,7 @@ data SimpleErrorMessage | ImplicitImport ModuleName [DeclarationRef] | HidingImport ModuleName [DeclarationRef] | CaseBinderLengthDiffers Int [Binder] + | IncorrectAnonymousArgument deriving (Show) -- | Error message hints, providing more detailed information about failure. @@ -317,6 +318,7 @@ errorCode em = case unwrapErrorMessage em of ImplicitImport{} -> "ImplicitImport" HidingImport{} -> "HidingImport" CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers" + IncorrectAnonymousArgument -> "IncorrectAnonymousArgument" -- | -- A stack trace for an error @@ -798,7 +800,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) = line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors." renderSimpleErrorMessage (ImportHidingModule name) = - paras [ line $ "'hiding' imports cannot be used to hide modules." + paras [ line "'hiding' imports cannot be used to hide modules." , line $ "An attempt was made to hide the import of " ++ runModuleName name ] renderSimpleErrorMessage (WildcardInferredType ty) = @@ -812,14 +814,14 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , indent $ typeAsBox ty ] renderSimpleErrorMessage (NotExhaustivePattern bs b) = - paras $ [ line "A case expression could not be determined to cover all inputs." - , line "The following additional cases are required to cover all inputs:\n" - , indent $ paras $ - [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ] - ++ [ line "..." | not b ] - , line "Or alternatively, add a Partial constraint to the type of the enclosing value." - , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9." - ] + paras [ line "A case expression could not be determined to cover all inputs." + , line "The following additional cases are required to cover all inputs:\n" + , indent $ paras $ + [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ] + ++ [ line "..." | not b ] + , line "Or alternatively, add a Partial constraint to the type of the enclosing value." + , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9." + ] renderSimpleErrorMessage (OverlappingPattern bs b) = paras $ [ line "A case expression contains unreachable cases:\n" , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) @@ -835,7 +837,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) = paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:" , indent $ paras $ map line names - , line $ "It could be replaced with:" + , line "It could be replaced with:" , indent $ line $ showSuggestion msg ] renderSimpleErrorMessage (UnusedDctorImport name) = @@ -849,15 +851,15 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function." , line "Operator aliases are declared by using a fixity declaration, for example:" , indent $ line $ "infixl 9 someFunction as " ++ name - , line $ "Support for value-declared operators will be removed in PureScript 0.9." + , line "Support for value-declared operators will be removed in PureScript 0.9." ] renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) = - paras [ line $ "Import uses the deprecated 'qualified' syntax:" + paras [ line "Import uses the deprecated 'qualified' syntax:" , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName , line "Should instead use the form:" , indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName - , line $ "The deprecated syntax will be removed in PureScript 0.9." + , line "The deprecated syntax will be removed in PureScript 0.9." ] renderSimpleErrorMessage (DeprecatedClassImport mn name) = @@ -865,15 +867,15 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , indent $ line $ runProperName name , line "Should instead use the form:" , indent $ line $ "class " ++ runProperName name - , line $ "The deprecated syntax will be removed in PureScript 0.9." + , line "The deprecated syntax will be removed in PureScript 0.9." ] renderSimpleErrorMessage (DeprecatedClassExport name) = - paras [ line $ "Class export uses deprecated syntax that omits the 'class' keyword:" + paras [ line "Class export uses deprecated syntax that omits the 'class' keyword:" , indent $ line $ runProperName name , line "Should instead use the form:" , indent $ line $ "class " ++ runProperName name - , line $ "The deprecated syntax will be removed in PureScript 0.9." + , line "The deprecated syntax will be removed in PureScript 0.9." ] renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) = @@ -915,9 +917,13 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap ] renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) = - paras $ [ line $ "Binder list length differs in case alternative:" - , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs - , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "." ] + paras [ line "Binder list length differs in case alternative:" + , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs + , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "." + ] + + renderSimpleErrorMessage IncorrectAnonymousArgument = + line "An anonymous function argument appears in an invalid context." renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 0a5e004de1..ea940b2c31 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -312,18 +312,17 @@ parseArrayLiteral :: TokenParser Expr parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue) parseObjectLiteral :: TokenParser Expr -parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue) +parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue) -parseIdentifierAndValue :: TokenParser (String, Maybe Expr) +parseIdentifierAndValue :: TokenParser (String, Expr) parseIdentifierAndValue = do name <- C.indented *> lname - b <- P.option (Just $ Var $ Qualified Nothing (Ident name)) rest + b <- P.option (Var $ Qualified Nothing (Ident name)) rest return (name, b) <|> (,) <$> (C.indented *> stringLiteral) <*> rest where - rest = C.indented *> colon *> C.indented *> val - val = P.try (Just <$> parseValue) <|> (underscore *> pure Nothing) + rest = C.indented *> colon *> C.indented *> parseValue parseAbs :: TokenParser Expr parseAbs = do @@ -373,13 +372,13 @@ parseLet = do parseValueAtom :: TokenParser Expr parseValueAtom = P.choice - [ parseNumericLiteral + [ parseAnonymousArgument + , parseNumericLiteral , parseCharLiteral , parseStringLiteral , parseBooleanLiteral , parseArrayLiteral , P.try parseObjectLiteral - , P.try parseObjectGetter , parseAbs , P.try parseConstructor , P.try parseVar @@ -387,10 +386,8 @@ parseValueAtom = P.choice , parseIfThenElse , parseDo , parseLet - , P.try $ Parens <$> parens parseValue + , P.try $ parens parseValue , parseOperatorSection - -- TODO: combine this with parseObjectGetter - , parseObjectUpdaterWildcard ] -- | @@ -406,11 +403,11 @@ parseOperatorSection = parens $ left <|> right right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> indexersAndAccessors) left = flip OperatorSection <$> (Left <$> indexersAndAccessors) <* indented <*> parseInfixExpr -parsePropertyUpdate :: TokenParser (String, Maybe Expr) +parsePropertyUpdate :: TokenParser (String, Expr) parsePropertyUpdate = do name <- lname <|> stringLiteral _ <- C.indented *> equals - value <- C.indented *> (underscore *> pure Nothing) <|> (Just <$> parseValue) + value <- C.indented *> parseValue return (name, value) parseAccessor :: Expr -> TokenParser Expr @@ -436,15 +433,12 @@ parseDoNotationElement = P.choice , DoNotationValue <$> parseValue ] -parseObjectGetter :: TokenParser Expr -parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) - -- | Expressions including indexers and record updates indexersAndAccessors :: TokenParser Expr indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom where postfixTable = [ parseAccessor - , P.try . parseUpdaterBody . Just + , P.try . parseUpdaterBody ] -- | @@ -466,11 +460,11 @@ parseValue = withSourceSpan PositionedValue ] ] -parseUpdaterBody :: Maybe Expr -> TokenParser Expr -parseUpdaterBody v = ObjectUpdater v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate))) +parseUpdaterBody :: Expr -> TokenParser Expr +parseUpdaterBody v = ObjectUpdate v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate))) -parseObjectUpdaterWildcard :: TokenParser Expr -parseObjectUpdaterWildcard = underscore *> C.indented *> parseUpdaterBody Nothing +parseAnonymousArgument :: TokenParser Expr +parseAnonymousArgument = underscore *> pure AnonymousArgument parseStringBinder :: TokenParser Binder parseStringBinder = StringBinder <$> stringLiteral diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 9ef9a0c799..d59a163aaa 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -57,7 +57,6 @@ prettyPrintValue d (IfThenElse cond th el) = ]) prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ show prop) prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps -prettyPrintValue d (ObjectUpdater o ps) = maybe (text "_") (prettyPrintValueAtom (d - 1)) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") (prettyPrintValue (d - 1)) val) ps prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) = @@ -86,8 +85,7 @@ prettyPrintValueAtom _ (BooleanLiteral True) = text "true" prettyPrintValueAtom _ (BooleanLiteral False) = text "false" prettyPrintValueAtom d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs prettyPrintValueAtom d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps -prettyPrintValueAtom d (ObjectConstructor ps) = prettyPrintObject (d - 1) ps -prettyPrintValueAtom _ (ObjectGetter prop) = text $ "_." ++ show prop +prettyPrintValueAtom _ AnonymousArgument = text "_" prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name) prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident) prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")" diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 136e892315..30b56bc26e 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -8,12 +8,11 @@ module Language.PureScript.Sugar.ObjectWildcards ( import Prelude () import Prelude.Compat -import Control.Arrow (second) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class import Data.List (partition) -import Data.Maybe (isJust, fromJust, catMaybes) +import Data.Maybe (catMaybes) import Language.PureScript.AST import Language.PureScript.Errors @@ -24,30 +23,42 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma where desugarDecl :: Declaration -> m Declaration - (desugarDecl, _, _) = everywhereOnValuesM return desugarExpr return + desugarDecl (PositionedDeclaration pos com d) = rethrowWithPosition pos $ PositionedDeclaration pos com <$> desugarDecl d + desugarDecl other = f other + where + (f, _, _) = everywhereOnValuesTopDownM return desugarExpr return desugarExpr :: Expr -> m Expr - desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps - desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps - desugarExpr (ObjectUpdater Nothing ps) = do + desugarExpr AnonymousArgument = throwError . errorMessage $ IncorrectAnonymousArgument + desugarExpr (BinaryNoParens op val u) | isAnonymousArgument u = return $ OperatorSection op (Left val) + desugarExpr (BinaryNoParens op u val) | isAnonymousArgument u = return $ OperatorSection op (Right val) + desugarExpr (ObjectLiteral ps) = wrapLambda ObjectLiteral ps + desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do obj <- freshIdent' Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps - desugarExpr (ObjectGetter prop) = do + desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps + desugarExpr (Accessor prop u) | isAnonymousArgument u = do arg <- freshIdent' return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg))) desugarExpr e = return e - wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> m Expr + wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr wrapLambda mkVal ps = - let (props, args) = partition (isJust . snd) ps + let (args, props) = partition (isAnonymousArgument . snd) ps in if null args - then return . mkVal $ second fromJust `map` props + then return $ mkVal props else do (args', ps') <- unzip <$> mapM mkProp ps return $ foldr (Abs . Left) (mkVal ps') (catMaybes args') - mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr)) - mkProp (name, Just e) = return (Nothing, (name, e)) - mkProp (name, Nothing) = do - arg <- freshIdent' - return (Just arg, (name, Var (Qualified Nothing arg))) + isAnonymousArgument :: Expr -> Bool + isAnonymousArgument AnonymousArgument = True + isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e + isAnonymousArgument _ = False + + mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr)) + mkProp (name, e) + | isAnonymousArgument e = do + arg <- freshIdent' + return (Just arg, (name, Var (Qualified Nothing arg))) + | otherwise = return (Nothing, (name, e)) diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 4d401facf2..7bd650b0da 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -77,15 +77,7 @@ removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module rebracketModule opTable (Module ss coms mn ds exts) = let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return - in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts - -removeParens :: Declaration -> Declaration -removeParens = - let (f, _, _) = everywhereOnValues id go id - in f - where - go (Parens val) = val - go val = val + in Module ss coms mn <$> parU ds f <*> pure exts externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))] externsFixities ExternsFile{..} = From 39841807f909f5e1dd584c53f820e573cc4d83a0 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 4 Feb 2016 18:01:44 +0000 Subject: [PATCH 0271/1580] Use stackage over HTTPS Stackage has started redirecting permanently to HTTPS, which is breaking the CI build, so this should fix it. --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 9370ce0921..6e4db803ce 100644 --- a/.travis.yml +++ b/.travis.yml @@ -51,7 +51,7 @@ install: - mkdir -p .cabal-sandbox - cabal sandbox init --sandbox .cabal-sandbox # Download stackage cabal.config, not sure whether filtering is necessary - - if [ -n "$STACKAGE" ]; then curl http://www.stackage.org/$STACKAGE/cabal.config | grep -v purescript > cabal.config; fi + - if [ -n "$STACKAGE" ]; then curl https://www.stackage.org/$STACKAGE/cabal.config | grep -v purescript > cabal.config; fi - cabal install --only-dependencies --enable-tests - cabal install hpc-coveralls # Snapshot state of the sandbox now, so we don't need to make new one for test install From 20f1200532678510ff2ec4ee28d376619c51e3c8 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 5 Feb 2016 02:18:19 +0100 Subject: [PATCH 0272/1580] apply hlint suggestions --- src/Language/PureScript/TypeChecker.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 21401bad25..cc58e6db00 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -230,14 +230,14 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds let args' = args `withKinds` kind addTypeSynonym moduleName name args' ty kind return $ TypeSynonymDeclaration name args ty - go (TypeDeclaration{}) = internalError "Type declarations should have been removed" + go TypeDeclaration{} = internalError "Type declarations should have been removed" go (ValueDeclaration name nameKind [] (Right val)) = warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do valueIsNotDefined moduleName name [(_, (val', ty))] <- typesOf moduleName [(name, val)] addValue moduleName name ty nameKind return $ ValueDeclaration name nameKind [] $ Right val' - go (ValueDeclaration{}) = internalError "Binders were not desugared" + go ValueDeclaration{} = internalError "Binders were not desugared" go (BindingGroupDeclaration vals) = warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do for_ (map (\(ident, _, _) -> ident) vals) $ \name -> @@ -264,8 +264,8 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds Just _ -> throwError . errorMessage $ RedefinedIdent name Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) }) return d - go (d@(FixityDeclaration{})) = return d - go (d@(ImportDeclaration{})) = return d + go (d@FixityDeclaration{}) = return d + go (d@ImportDeclaration{}) = return d go (d@(TypeClassDeclaration pn args implies tys)) = do addTypeClass moduleName pn args implies tys return d @@ -429,7 +429,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint checkNonAliasesAreExported dr@(ValueRef (Op name)) = case listToMaybe (mapMaybe getAlias decls) of Just alias -> - when (not $ any (== ValueRef alias) exps) $ + unless (ValueRef alias `elem` exps) $ throwError . errorMessage $ TransitiveExportError dr [ValueRef alias] _ -> return () where From a4510ee873656d564a02a55d843c23100addf3bc Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 4 Feb 2016 20:45:40 -0800 Subject: [PATCH 0273/1580] Add Parens constructor back, ensure new operator sections are parenthesized --- examples/passing/ExplicitOperatorSections.purs | 4 ++-- src/Language/PureScript/AST/Declarations.hs | 8 ++++++++ src/Language/PureScript/AST/Traversals.hs | 7 +++++++ src/Language/PureScript/Parser/Declarations.hs | 2 +- src/Language/PureScript/Sugar/ObjectWildcards.hs | 14 ++++++++++++-- src/Language/PureScript/Sugar/Operators.hs | 10 +++++++++- 6 files changed, 39 insertions(+), 6 deletions(-) diff --git a/examples/passing/ExplicitOperatorSections.purs b/examples/passing/ExplicitOperatorSections.purs index cd88833f64..c77cf55392 100644 --- a/examples/passing/ExplicitOperatorSections.purs +++ b/examples/passing/ExplicitOperatorSections.purs @@ -3,9 +3,9 @@ module Main where import Prelude subtractOne :: Int -> Int -subtractOne = _ - 1 +subtractOne = (_ - 1) addOne :: Int -> Int -addOne = 1 + _ +addOne = (1 + _) main = Control.Monad.Eff.Console.log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 333e4c3229..843227ca78 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -334,6 +334,14 @@ data Expr -- | BinaryNoParens Expr Expr Expr -- | + -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor + -- will be removed. + -- + -- Note: although it seems this constructor is not used, it _is_ useful, since it prevents + -- certain traversals from matching. + -- + | Parens Expr + -- | -- Operator section. This will be removed during desugaring and replaced with a partially applied -- operator or lambda to flip the arguments. -- diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 5a9a852359..37a563c42f 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -49,6 +49,7 @@ everywhereOnValues f g h = (f', g', h') g' :: Expr -> Expr g' (UnaryMinus v) = g (UnaryMinus (g' v)) g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2)) + g' (Parens v) = g (Parens (g' v)) g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v)) g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v)) g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs)) @@ -104,6 +105,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g') g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g') + g' (Parens v) = Parens <$> (g v >>= g') g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g')) g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g')) g' (ArrayLiteral vs) = ArrayLiteral <$> traverse (g' <=< g) vs @@ -154,6 +156,7 @@ everywhereOnValuesM f g h = (f', g', h') g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g + g' (Parens v) = (Parens <$> g' v) >>= g g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g g' (ArrayLiteral vs) = (ArrayLiteral <$> traverse g' vs) >>= g @@ -207,6 +210,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') g' v@(UnaryMinus v1) = g v <> g' v1 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2 + g' v@(Parens v1) = g v <> g' v1 g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1 g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs) @@ -271,6 +275,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' g' s (UnaryMinus v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 + g' s (Parens v1) = g'' s v1 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs) @@ -338,6 +343,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g' s (UnaryMinus v) = UnaryMinus <$> g'' s v g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2 + g' s (Parens v) = Parens <$> g'' s v g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v) g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v) g' s (ArrayLiteral vs) = ArrayLiteral <$> traverse (g'' s) vs @@ -417,6 +423,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' s (UnaryMinus v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2 + g' s (Parens v1) = g'' s v1 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v g' s (ArrayLiteral vs) = foldMap (g'' s) vs diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index ea940b2c31..0d890d38ea 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -386,7 +386,7 @@ parseValueAtom = P.choice , parseIfThenElse , parseDo , parseLet - , P.try $ parens parseValue + , P.try $ Parens <$> parens parseValue , parseOperatorSection ] diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 30b56bc26e..2e84f087bf 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Sugar.ObjectWildcards ( @@ -30,8 +31,13 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma desugarExpr :: Expr -> m Expr desugarExpr AnonymousArgument = throwError . errorMessage $ IncorrectAnonymousArgument - desugarExpr (BinaryNoParens op val u) | isAnonymousArgument u = return $ OperatorSection op (Left val) - desugarExpr (BinaryNoParens op u val) | isAnonymousArgument u = return $ OperatorSection op (Right val) + desugarExpr (Parens b) + | b' <- stripPositionInfo b + , BinaryNoParens op val u <- b' + , isAnonymousArgument u = return $ OperatorSection op (Left val) + | b' <- stripPositionInfo b + , BinaryNoParens op u val <- b' + , isAnonymousArgument u = return $ OperatorSection op (Right val) desugarExpr (ObjectLiteral ps) = wrapLambda ObjectLiteral ps desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do obj <- freshIdent' @@ -51,6 +57,10 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma (args', ps') <- unzip <$> mapM mkProp ps return $ foldr (Abs . Left) (mkVal ps') (catMaybes args') + stripPositionInfo :: Expr -> Expr + stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e + stripPositionInfo e = e + isAnonymousArgument :: Expr -> Bool isAnonymousArgument AnonymousArgument = True isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 7bd650b0da..4d401facf2 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -77,7 +77,15 @@ removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module rebracketModule opTable (Module ss coms mn ds exts) = let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return - in Module ss coms mn <$> parU ds f <*> pure exts + in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts + +removeParens :: Declaration -> Declaration +removeParens = + let (f, _, _) = everywhereOnValues id go id + in f + where + go (Parens val) = val + go val = val externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))] externsFixities ExternsFile{..} = From c9aac3cb987c2a7b6fdb9498abc408a863fb22ef Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 4 Feb 2016 20:48:06 -0800 Subject: [PATCH 0274/1580] More tests --- examples/failing/{AnonArgument.purs => AnonArgument1.purs} | 0 examples/failing/AnonArgument2.purs | 7 +++++++ examples/failing/AnonArgument3.purs | 5 +++++ examples/passing/ExplicitOperatorSections.purs | 3 +++ 4 files changed, 15 insertions(+) rename examples/failing/{AnonArgument.purs => AnonArgument1.purs} (100%) create mode 100644 examples/failing/AnonArgument2.purs create mode 100644 examples/failing/AnonArgument3.purs diff --git a/examples/failing/AnonArgument.purs b/examples/failing/AnonArgument1.purs similarity index 100% rename from examples/failing/AnonArgument.purs rename to examples/failing/AnonArgument1.purs diff --git a/examples/failing/AnonArgument2.purs b/examples/failing/AnonArgument2.purs new file mode 100644 index 0000000000..746a008c07 --- /dev/null +++ b/examples/failing/AnonArgument2.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith IncorrectAnonymousArgument +module Main where + +import Prelude + +test :: Int -> Int +test = 1 + 2 * _ diff --git a/examples/failing/AnonArgument3.purs b/examples/failing/AnonArgument3.purs new file mode 100644 index 0000000000..34f9814cf3 --- /dev/null +++ b/examples/failing/AnonArgument3.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith IncorrectAnonymousArgument +module Main where + +test :: Int -> Int +test = 1 + _ diff --git a/examples/passing/ExplicitOperatorSections.purs b/examples/passing/ExplicitOperatorSections.purs index c77cf55392..b8e6fbfc1c 100644 --- a/examples/passing/ExplicitOperatorSections.purs +++ b/examples/passing/ExplicitOperatorSections.purs @@ -8,4 +8,7 @@ subtractOne = (_ - 1) addOne :: Int -> Int addOne = (1 + _) +named :: Int -> Int +named = (_ `sub` 1) + main = Control.Monad.Eff.Console.log "Done" From 6566dd4aba9bfef4257ad7c5ccaa20eccc195fb4 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 4 Feb 2016 21:22:15 -0800 Subject: [PATCH 0275/1580] Deprecation warnings --- src/Language/PureScript/Errors.hs | 29 ++++++++++++++++++++++++++++- src/Language/PureScript/Linter.hs | 1 + 2 files changed, 29 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 9666285dfa..b5216efbcc 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -24,6 +24,7 @@ import Control.Arrow ((&&&)) import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Pretty +import Language.PureScript.Pretty.Common (before) import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds @@ -128,6 +129,7 @@ data SimpleErrorMessage | UnusedDctorImport (ProperName 'TypeName) | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName] | DeprecatedOperatorDecl String + | DeprecatedOperatorSection Expr (Either Expr Expr) | DeprecatedQualifiedSyntax ModuleName ModuleName | DeprecatedClassImport ModuleName (ProperName 'ClassName) | DeprecatedClassExport (ProperName 'ClassName) @@ -304,6 +306,7 @@ errorCode em = case unwrapErrorMessage em of UnusedDctorImport{} -> "UnusedDctorImport" UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport" DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl" + DeprecatedOperatorSection{} -> "DeprecatedOperatorSection" DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax" DeprecatedClassImport{} -> "DeprecatedClassImport" DeprecatedClassExport{} -> "DeprecatedClassExport" @@ -426,7 +429,7 @@ wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ error -- TODO Other possible suggestions: -- WildcardInferredType - source span not small enough -- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert --- DeprecatedClassExport, DeprecatedClassImport, would want to replace smaller span? +-- DeprecatedClassExport, DeprecatedClassImport, DeprecatedOperatorSection, would want to replace smaller span? errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion errorSuggestion err = case err of UnusedImport{} -> emptySuggestion @@ -854,6 +857,30 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , line "Support for value-declared operators will be removed in PureScript 0.9." ] + renderSimpleErrorMessage (DeprecatedOperatorSection op val) = + paras [ line "An operator section uses legacy syntax. Operator sections are now written using anonymous function syntax:" + , indent $ foldr1 before $ + case val of + Left l -> + [ line "(" + , prettyPrintValue valueDepth l + , line " " + , renderOperator op + , line " _)" + ] + Right r -> + [ line "(_ " + , renderOperator op + , line " " + , prettyPrintValue valueDepth r + , line ")" + ] + , line "Support for legacy operator sections will be removed in PureScript 0.9." + ] + where + renderOperator (PositionedValue _ _ ex) = renderOperator ex + renderOperator (Var (Qualified _ (Op ident))) = line ident + renderOperator other = Box.hcat Box.top [ line "`", prettyPrintValue valueDepth other, line "`" ] renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) = paras [ line "Import uses the deprecated 'qualified' syntax:" , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 8ab464910d..3e554ef126 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -71,6 +71,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl go d | Just i <- getDeclIdent d , i `S.member` s = errorMessage (ShadowedName i) | otherwise = mempty + stepE _ (OperatorSection op val) = errorMessage $ DeprecatedOperatorSection op val stepE _ _ = mempty stepB :: S.Set Ident -> Binder -> MultipleErrors From 7d936d3b64257fe4ad203f2514ab8192eae5b142 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 4 Feb 2016 14:55:24 +0000 Subject: [PATCH 0276/1580] Infer types in psc-{docs,publish} Fixes #1834 Instead of taking types from the partially-desugared AST, we now insert wildcard types for value declarations without explicit type signatures in the first pass, and then we typecheck if necessary in order to insert the real types for all value declarations later on, using the Environment obtained during typechecking. This involved: * Changing the module name field in the Docs.Types.Module type to a real P.ModuleName; to be frank, it really ought to have been that type to begin with. * Refactoring ParseAndDesugar so that it no longer does any desugaring. With this new pipeline, it is easier to pass modules that are not desugared at all into Docs.Convert. Also renamed ParseAndDesugar appropriately. * Re-reversing the modules in Sugar.Names; desugarImports was previously (unintentionally) reversing the list of modules. This new code depends on those modules remaining in a topologically sorted order, which is why this change was necessary. --- examples/docs/src/ExplicitTypeSignatures.purs | 16 ++ psc-docs/Main.hs | 12 +- purescript.cabal | 2 +- src/Language/PureScript/Docs.hs | 2 +- src/Language/PureScript/Docs/AsMarkdown.hs | 16 +- src/Language/PureScript/Docs/Convert.hs | 169 ++++++++++++++---- .../PureScript/Docs/Convert/Single.hs | 10 +- ...ParseAndDesugar.hs => ParseAndBookmark.hs} | 69 ++----- src/Language/PureScript/Docs/Types.hs | 6 +- src/Language/PureScript/Publish.hs | 8 +- src/Language/PureScript/Sugar/Names.hs | 3 +- tests/TestDocs.hs | 49 ++++- 12 files changed, 247 insertions(+), 115 deletions(-) create mode 100644 examples/docs/src/ExplicitTypeSignatures.purs rename src/Language/PureScript/Docs/{ParseAndDesugar.hs => ParseAndBookmark.hs} (59%) diff --git a/examples/docs/src/ExplicitTypeSignatures.purs b/examples/docs/src/ExplicitTypeSignatures.purs new file mode 100644 index 0000000000..396ca1447c --- /dev/null +++ b/examples/docs/src/ExplicitTypeSignatures.purs @@ -0,0 +1,16 @@ + +module ExplicitTypeSignatures where + +-- This should use the explicit type signature so that the type variable name +-- is preserved. +explicit :: forall something. something -> something +explicit x + | true = x + | false = x + +-- This should use the inferred type. +anInt :: _ +anInt = 0 + +-- This should infer a type. +aNumber = 1.0 diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index f979587c4d..6374dff209 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -69,19 +69,19 @@ docgen (PSCDocsOptions fmt inputGlob output) = do Etags -> dumpTags input dumpEtags Ctags -> dumpTags input dumpCtags Markdown -> do - ms <- runExceptT (D.parseAndDesugar input [] - >>= ((\(ms, _, env) -> D.convertModulesInPackage env ms))) + ms <- runExceptT (D.parseAndBookmark input [] + >>= (fst >>> D.convertModulesInPackage)) >>= successOrExit case output of EverythingToStdOut -> putStrLn (D.runDocs (D.modulesAsMarkdown ms)) ToStdOut names -> do - let (ms', missing) = takeByName ms (map P.runModuleName names) + let (ms', missing) = takeByName ms names guardMissing missing putStrLn (D.runDocs (D.modulesAsMarkdown ms')) ToFiles names -> do - let (ms', missing) = takeByName' ms (map (first P.runModuleName) names) + let (ms', missing) = takeByName' ms names guardMissing missing let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms' @@ -93,12 +93,12 @@ docgen (PSCDocsOptions fmt inputGlob output) = do where guardMissing [] = return () guardMissing [mn] = do - hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ mn ++ "\"") + hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ P.runModuleName mn ++ "\"") exitFailure guardMissing mns = do hPutStrLn stderr "psc-docs: error: unknown modules:" forM_ mns $ \mn -> - hPutStrLn stderr (" * " ++ mn) + hPutStrLn stderr (" * " ++ P.runModuleName mn) exitFailure successOrExit :: Either P.MultipleErrors a -> IO a diff --git a/purescript.cabal b/purescript.cabal index a1a21a83e1..16f11acc9e 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -170,7 +170,7 @@ library Language.PureScript.Docs.RenderedCode.Types Language.PureScript.Docs.RenderedCode.Render Language.PureScript.Docs.AsMarkdown - Language.PureScript.Docs.ParseAndDesugar + Language.PureScript.Docs.ParseAndBookmark Language.PureScript.Docs.Utils.MonoidExtras Language.PureScript.Publish diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs index 837403fc70..bd84e8b942 100644 --- a/src/Language/PureScript/Docs.hs +++ b/src/Language/PureScript/Docs.hs @@ -11,4 +11,4 @@ import Language.PureScript.Docs.RenderedCode.Types as Docs import Language.PureScript.Docs.RenderedCode.Render as Docs import Language.PureScript.Docs.Convert as Docs import Language.PureScript.Docs.Render as Docs -import Language.PureScript.Docs.ParseAndDesugar as Docs +import Language.PureScript.Docs.ParseAndBookmark as Docs diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index e0b6e4b9c4..9d1f0a6a89 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -31,31 +31,29 @@ import qualified Language.PureScript.Docs.Render as Render renderModulesAsMarkdown :: (Functor m, Applicative m, MonadError P.MultipleErrors m) => - P.Env -> [P.Module] -> m String -renderModulesAsMarkdown env = - fmap (runDocs . modulesAsMarkdown) . Convert.convertModules env +renderModulesAsMarkdown = + fmap (runDocs . modulesAsMarkdown) . Convert.convertModules modulesAsMarkdown :: [Module] -> Docs modulesAsMarkdown = mapM_ moduleAsMarkdown moduleAsMarkdown :: Module -> Docs moduleAsMarkdown Module{..} = do - headerLevel 2 $ "Module " ++ modName + headerLevel 2 $ "Module " ++ P.runModuleName modName spacer for_ modComments tell' mapM_ (declAsMarkdown modName) modDeclarations spacer for_ modReExports $ \(mn, decls) -> do - let modName' = P.runModuleName mn - headerLevel 3 $ "Re-exported from " ++ modName' ++ ":" + headerLevel 3 $ "Re-exported from " ++ P.runModuleName mn ++ ":" spacer - mapM_ (declAsMarkdown modName') decls + mapM_ (declAsMarkdown mn) decls -declAsMarkdown :: String -> Declaration -> Docs +declAsMarkdown :: P.ModuleName -> Declaration -> Docs declAsMarkdown mn decl@Declaration{..} = do - let options = defaultRenderTypeOptions { currentModule = Just (P.moduleNameFromString mn) } + let options = defaultRenderTypeOptions { currentModule = Just mn } headerLevel 4 (ticks declTitle) spacer diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 9d34a45c6f..3b988896bf 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -16,12 +16,17 @@ module Language.PureScript.Docs.Convert import Prelude () import Prelude.Compat -import Control.Monad.Error.Class (MonadError) -import Control.Arrow ((&&&)) +import Control.Arrow ((&&&), second) import Control.Category ((>>>)) +import Control.Monad +import Control.Monad.State (runStateT) +import Control.Monad.Writer.Strict (runWriterT) +import Control.Monad.Error.Class (MonadError) import qualified Data.Map as Map +import Text.Parsec (eof) import qualified Language.PureScript as P +import qualified Language.PureScript.Constants as C import Language.PureScript.Docs.Types import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks) @@ -33,18 +38,17 @@ import Language.PureScript.Docs.Convert.ReExports (updateReExports) -- documentation. -- convertModulesInPackage :: - (Functor m, MonadError P.MultipleErrors m) => - P.Env -> + (Functor m, Applicative m, MonadError P.MultipleErrors m) => [InPackage P.Module] -> m [Module] -convertModulesInPackage env modules = +convertModulesInPackage modules = go modules where localNames = - map (P.runModuleName . P.getModuleName) (takeLocals modules) + map P.getModuleName (takeLocals modules) go = map ignorePackage - >>> convertModules env + >>> convertModules >>> fmap (filter ((`elem` localNames) . modName)) -- | @@ -53,35 +57,140 @@ convertModulesInPackage env modules = -- imports/exports information about the list of modules, which is needed for -- documenting re-exports. -- --- Preconditions: +-- Note that the whole module dependency graph must be included in the list; if +-- some modules import things from other modules, then those modules must also +-- be included. -- --- * If any module in the list re-exports documentation from other --- modules, those modules must also be included in the list. --- * The modules passed must have had names desugared and re-exports --- elaborated first. --- --- If either of these are not satisfied, an internal error will be thrown. To --- avoid this, it is recommended to use --- Language.PureScript.Docs.ParseAndDesugar to construct the inputs to this --- function. +-- For value declarations, if explicit type signatures are omitted, or a +-- wildcard type is used, then we typecheck the modules and use the inferred +-- types. -- convertModules :: - (Functor m, MonadError P.MultipleErrors m) => - P.Env -> + (Functor m, Applicative m, MonadError P.MultipleErrors m) => [P.Module] -> m [Module] -convertModules env = - P.sortModules >>> fmap (convertSorted env . fst) +convertModules = + P.sortModules + >>> fmap (fst >>> map importPrim) + >=> convertSorted + +importPrim :: P.Module -> P.Module +importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim]) -- | -- Convert a sorted list of modules. -- -convertSorted :: P.Env -> [P.Module] -> [Module] -convertSorted env modules = - let - traversalOrder = - map P.getModuleName modules - moduleMap = - Map.fromList $ map (P.getModuleName &&& convertSingleModule) modules - in - Map.elems (updateReExports env traversalOrder moduleMap) +convertSorted :: + (Functor m, Applicative m, MonadError P.MultipleErrors m) => + [P.Module] -> + m [Module] +convertSorted modules = do + (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules + + modulesWithTypes <- typeCheckIfNecessary modules convertedModules + let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes) + + let traversalOrder = map P.getModuleName modules + pure (Map.elems (updateReExports env traversalOrder moduleMap)) + +-- | +-- If any exported value declarations have either wildcard type signatures, or +-- none at all, then typecheck in order to fill them in with the inferred +-- types. +-- +typeCheckIfNecessary :: + (Functor m, Applicative m, MonadError P.MultipleErrors m) => + [P.Module] -> + [Module] -> + m [Module] +typeCheckIfNecessary modules convertedModules = + if any hasWildcards convertedModules + then go + else pure convertedModules + + where + hasWildcards = + any ((==) (ValueDeclaration P.TypeWildcard) . declInfo) . modDeclarations + + go = do + checkEnv <- snd <$> typeCheck modules + pure (map (insertValueTypes checkEnv) convertedModules) + +-- | +-- Typechecks all the modules together. Also returns the final 'P.Environment', +-- which is useful for adding in inferred types where explicit declarations +-- were not provided. +-- +typeCheck :: + (Functor m, MonadError P.MultipleErrors m) => + [P.Module] -> + m ([P.Module], P.Environment) +typeCheck = + (P.desugar [] >=> check) + >>> fmap (second P.checkEnv) + >>> P.evalSupplyT 0 + >>> ignoreWarnings + + where + check ms = + runStateT + (traverse P.typeCheckModule ms) + (P.emptyCheckState P.initEnvironment) + + ignoreWarnings = + fmap fst . runWriterT + +-- | +-- Updates all the types of the ValueDeclarations inside the module based on +-- their types inside the given Environment. +-- +insertValueTypes :: + P.Environment -> Module -> Module +insertValueTypes env m = + m { modDeclarations = map go (modDeclarations m) } + where + go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard }) = + let + ident = parseIdent (declTitle d) + ty = lookupName ident + in + d { declInfo = ValueDeclaration ty } + go other = + other + + parseIdent = + either (err . ("failed to parse Ident: " ++)) id . runParser P.parseIdent + + lookupName name = + let key = (modName m, name) + in case Map.lookup key (P.names env) of + Just (ty, _, _) -> + ty + Nothing -> + err ("name not found: " ++ show key) + + err msg = + P.internalError ("Docs.Convert.insertValueTypes: " ++ msg) + +runParser :: P.TokenParser a -> String -> Either String a +runParser p s = either (Left . show) Right $ do + ts <- P.lex "" s + P.runTokenParser "" (p <* eof) ts + +-- | +-- Partially desugar modules so that they are suitable for extracting +-- documentation information from. +-- +partiallyDesugar :: + (Functor m, Applicative m, MonadError P.MultipleErrors m) => + [P.Module] + -> m (P.Env, [P.Module]) +partiallyDesugar = P.evalSupplyT 0 . desugar' + where + desugar' = + traverse P.desugarDoModule + >=> P.desugarCasesModule + >=> P.desugarTypeDeclarationsModule + >=> ignoreWarnings . P.desugarImportsWithEnv [] + + ignoreWarnings = fmap fst . runWriterT diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index ceec9b31ca..cade0ec68d 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -29,7 +29,7 @@ import Language.PureScript.Docs.Types -- convertSingleModule :: P.Module -> Module convertSingleModule m@(P.Module _ coms moduleName _ _) = - Module (P.runModuleName moduleName) comments (declarations m) [] + Module moduleName comments (declarations m) [] where comments = convertComments coms declarations = @@ -109,7 +109,7 @@ addDefaultFixity decl@Declaration{..} defaultFixity = P.Fixity P.Infixl (-1) getDeclarationTitle :: P.Declaration -> Maybe String -getDeclarationTitle (P.TypeDeclaration name _) = Just (P.showIdent name) +getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name) getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name) getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name) getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name) @@ -135,8 +135,12 @@ basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration basicDeclaration title info = Just $ Right $ mkDeclaration title info convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration -convertDeclaration (P.TypeDeclaration _ ty) title = +convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title = basicDeclaration title (ValueDeclaration ty) +convertDeclaration (P.ValueDeclaration _ _ _ _) title = + -- If no explicit type declaration was provided, insert a wildcard, so that + -- the actual type will be added during type checking. + basicDeclaration title (ValueDeclaration P.TypeWildcard) convertDeclaration (P.ExternDeclaration _ ty) title = basicDeclaration title (ValueDeclaration ty) convertDeclaration (P.DataDeclaration dtype _ args ctors) title = diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndBookmark.hs similarity index 59% rename from src/Language/PureScript/Docs/ParseAndDesugar.hs rename to src/Language/PureScript/Docs/ParseAndBookmark.hs index 2f0302a5e9..ed9482092f 100644 --- a/src/Language/PureScript/Docs/ParseAndDesugar.hs +++ b/src/Language/PureScript/Docs/ParseAndBookmark.hs @@ -1,8 +1,8 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} -module Language.PureScript.Docs.ParseAndDesugar - ( parseAndDesugar +module Language.PureScript.Docs.ParseAndBookmark + ( parseAndBookmark ) where import Prelude () @@ -10,16 +10,13 @@ import Prelude.Compat import qualified Data.Map as M import Control.Arrow (first) -import Control.Monad -import Control.Monad.Writer.Strict (runWriterT) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Web.Bower.PackageMeta (PackageName) import qualified Language.PureScript as P -import qualified Language.PureScript.Constants as C import Language.PureScript.Docs.Types import Language.PureScript.Docs.Convert (collectBookmarks) @@ -35,23 +32,18 @@ import Language.PureScript.Docs.Convert (collectBookmarks) -- * Parse all of the input and dependency source files -- * Associate each dependency module with its package name, thereby -- distinguishing these from local modules --- * Partially desugar all of the resulting modules (just enough for --- producing documentation from them) -- * Collect a list of bookmarks from the whole set of source files --- * Return the desugared modules, the bookmarks, and the imports/exports --- Env (which is needed for producing documentation). -parseAndDesugar :: +-- * Return the parsed modules and the bookmarks +parseAndBookmark :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) => [FilePath] -> [(PackageName, FilePath)] - -> m ([InPackage P.Module], [Bookmark], P.Env) -parseAndDesugar inputFiles depsFiles = do + -> m ([InPackage P.Module], [Bookmark]) +parseAndBookmark inputFiles depsFiles = do inputFiles' <- traverse (parseAs Local) inputFiles depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles - ms <- parseFiles (inputFiles' ++ depsFiles') - ms' <- sortModules (map snd ms) - desugarWithBookmarks ms ms' + addBookmarks <$> parseFiles (inputFiles' ++ depsFiles') parseFiles :: (MonadError P.MultipleErrors m, MonadIO m) => @@ -60,29 +52,16 @@ parseFiles :: parseFiles = throwLeft . P.parseModulesFromFiles fileInfoToString -sortModules :: - (Functor m, MonadError P.MultipleErrors m, MonadIO m) => - [P.Module] - -> m [P.Module] -sortModules = - fmap fst . throwLeft . sortModules' . map importPrim - where - sortModules' :: [P.Module] -> Either P.MultipleErrors ([P.Module], P.ModuleGraph) - sortModules' = P.sortModules - -desugarWithBookmarks :: - (MonadError P.MultipleErrors m, MonadIO m) => +addBookmarks :: [(FileInfo, P.Module)] - -> [P.Module] - -> m ([InPackage P.Module], [Bookmark], P.Env) -desugarWithBookmarks msInfo msSorted = do - (env, msDesugared) <- throwLeft (desugar msSorted) - - let msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo) - msPackages = map (addPackage msDeps) msDesugared - bookmarks = concatMap collectBookmarks msPackages - - return (msPackages, bookmarks, env) + -> ([InPackage P.Module], [Bookmark]) +addBookmarks msInfo = + let + msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo) + msPackages = map (addPackage msDeps . snd) msInfo + bookmarks = concatMap collectBookmarks msPackages + in + (msPackages, bookmarks) throwLeft :: (MonadError l m) => Either l r -> m r throwLeft = either throwError return @@ -100,22 +79,6 @@ fileInfoToString :: FileInfo -> FilePath fileInfoToString (Local fn) = fn fileInfoToString (FromDep _ fn) = fn -importPrim :: P.Module -> P.Module -importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim]) - -desugar :: - (Functor m, Applicative m, MonadError P.MultipleErrors m) => - [P.Module] - -> m (P.Env, [P.Module]) -desugar = P.evalSupplyT 0 . desugar' - where - desugar' = - traverse P.desugarDoModule - >=> P.desugarCasesModule - >=> ignoreWarnings . P.desugarImportsWithEnv [] - - ignoreWarnings m = liftM fst (runWriterT m) - parseFile :: FilePath -> IO (FilePath, String) parseFile input' = (,) input' <$> readFile input' diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 8d19cfb4dc..600429f313 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -73,7 +73,7 @@ packageName :: Package a -> PackageName packageName = bowerName . pkgMeta data Module = Module - { modName :: String + { modName :: P.ModuleName , modComments :: Maybe String , modDeclarations :: [Declaration] -- Re-exported values from other modules @@ -346,7 +346,7 @@ parseVersion' str = asModule :: Parse PackageError Module asModule = - Module <$> key "name" asString + Module <$> key "name" (P.moduleNameFromString <$> asString) <*> key "comments" (perhaps asString) <*> key "declarations" (eachInArray asDeclaration) <*> key "reExports" (eachInArray asReExport) @@ -512,7 +512,7 @@ instance A.ToJSON NotYetKnown where instance A.ToJSON Module where toJSON Module{..} = - A.object [ "name" .= modName + A.object [ "name" .= P.runModuleName modName , "comments" .= modComments , "declarations" .= modDeclarations , "reExports" .= map toObj modReExports diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 210504fbfe..7666d8b2d2 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -146,15 +146,15 @@ preparePackage' opts = do getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module]) getModulesAndBookmarks = do (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles - (modules', bookmarks, env) <- parseAndDesugar inputFiles depsFiles + (modules', bookmarks) <- parseAndBookmark inputFiles depsFiles - case runExcept (D.convertModulesInPackage env modules') of + case runExcept (D.convertModulesInPackage modules') of Right modules -> return (bookmarks, modules) Left err -> userError (CompileError err) where - parseAndDesugar inputFiles depsFiles = do - r <- liftIO . runExceptT $ D.parseAndDesugar inputFiles depsFiles + parseAndBookmark inputFiles depsFiles = do + r <- liftIO . runExceptT $ D.parseAndBookmark inputFiles depsFiles case r of Right r' -> return r' diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 5e75fc9200..c3f8e7eac4 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -17,6 +17,7 @@ import Prelude.Compat import Data.List (find, nub) import Data.Maybe (fromMaybe, mapMaybe) +import Control.Arrow (first) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer (MonadWriter(..), censor) @@ -54,7 +55,7 @@ desugarImportsWithEnv desugarImportsWithEnv externs modules = do env <- silence $ foldM externsEnv primEnv externs modules' <- traverse updateExportRefs modules - (modules'', env') <- foldM updateEnv ([], env) modules' + (modules'', env') <- first reverse <$> foldM updateEnv ([], env) modules' (env',) <$> traverse (renameInModule' env') modules'' where silence :: m a -> m a diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 477cc130d6..379a4e6699 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -14,6 +14,7 @@ import Control.Applicative import Control.Arrow import Data.Maybe (fromMaybe) import Data.List ((\\)) +import Data.Monoid import Data.Foldable import Data.Traversable import System.Exit @@ -36,8 +37,8 @@ main :: IO () main = do TestPscPublish.pushd "examples/docs" $ do Docs.Package{..} <- Publish.preparePackage publishOpts - forM_ testCases $ \(mn, pragmas) -> - let mdl = takeJust ("module not found in docs: " ++ mn) + forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) -> + let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn) (find ((==) mn . Docs.modName) pkgModules) in forM_ pragmas (flip runAssertionIO mdl) @@ -56,8 +57,16 @@ data Assertion -- | Assert that a particular declaration has a particular type class -- constraint. | ShouldBeConstrained P.ModuleName String String + -- | Assert that a particular value declaration exists, and its type + -- satisfies the given predicate. + | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool)) deriving (Show) +newtype ShowFn a = ShowFn a + +instance Show (ShowFn a) where + show _ = "" + data AssertionFailure -- | A declaration was not documented, but should have been = NotDocumented P.ModuleName String @@ -72,6 +81,11 @@ data AssertionFailure -- | A declaration had the wrong "type" (ie, value, type, type class) -- Fields: declaration title, expected "type", actual "type". | WrongDeclarationType P.ModuleName String String String + -- | A value declaration had the wrong type (in the sense of "type + -- checking"), eg, because the inferred type was used when the explicit type + -- should have been. + -- Fields: module name, declaration name, actual type. + | ValueDeclarationWrongType P.ModuleName String P.Type deriving (Show) data AssertionResult @@ -121,9 +135,24 @@ runAssertion assertion Docs.Module{..} = Fail (WrongDeclarationType mn decl "value" (Docs.declInfoToString declInfo)) + ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) -> + case find ((==) decl . Docs.declTitle) (declarationsFor mn) of + Nothing -> + Fail (NotDocumented mn decl) + Just Docs.Declaration{..} -> + case declInfo of + Docs.ValueDeclaration ty -> + if tyPredicate ty + then Pass + else Fail + (ValueDeclarationWrongType mn decl ty) + _ -> + Fail (WrongDeclarationType mn decl "value" + (Docs.declInfoToString declInfo)) + where declarationsFor mn = - if P.runModuleName mn == modName + if mn == modName then modDeclarations else fromMaybe [] (lookup mn modReExports) @@ -149,7 +178,7 @@ checkConstrained ty tyClass = runAssertionIO :: Assertion -> Docs.Module -> IO () runAssertionIO assertion mdl = do - putStrLn ("In " ++ Docs.modName mdl ++ ": " ++ show assertion) + putStrLn ("In " ++ P.runModuleName (Docs.modName mdl) ++ ": " ++ show assertion) case runAssertion assertion mdl of Pass -> pure () fail -> do @@ -226,7 +255,19 @@ testCases = , ("NewOperators", [ ShouldBeDocumented (n "NewOperators2") "(>>>)" [] ]) + + , ("ExplicitTypeSignatures", + [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something")) + , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn ((==) P.tyInt)) + , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn ((==) P.tyNumber)) + ]) ] where n = P.moduleNameFromString + + hasTypeVar varName = + getAny . P.everythingOnTypes (<>) (Any . isVar varName) + + isVar varName (P.TypeVar name) | varName == name = True + isVar _ _ = False From 469b5aebfdc43123bcf769744109a4cde2c6bed4 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 5 Feb 2016 21:01:48 -0800 Subject: [PATCH 0277/1580] Eq deriving --- .../PureScript/Sugar/TypeClasses/Deriving.hs | 318 ++++++++++-------- 1 file changed, 187 insertions(+), 131 deletions(-) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index d011a35c7d..e2c0552782 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -50,6 +50,10 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args + | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) eq + , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty + , mn == fromMaybe mn mn' + = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) = throwError . errorMessage $ CannotDerive className tys deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d @@ -73,22 +77,193 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ] typesProxy :: ModuleName typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ] +eq :: ProperName 'ClassName +eq = ProperName "Eq" + deriveGeneric - :: (Functor m, MonadError MultipleErrors m, MonadSupply m) + :: forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName 'TypeName -> [Type] -> m [Declaration] -deriveGeneric mn ds tyConNm args = do +deriveGeneric mn ds tyConNm dargs = do tyCon <- findTypeDecl tyConNm ds - toSpine <- mkSpineFunction mn tyCon - fromSpine <- mkFromSpineFunction mn tyCon - let toSignature = mkSignatureFunction mn tyCon args + toSpine <- mkSpineFunction tyCon + fromSpine <- mkFromSpineFunction tyCon + let toSignature = mkSignatureFunction tyCon dargs return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine) , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine) , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature) ] + where + mkSpineFunction :: Declaration -> m Expr + mkSpineFunction (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args + where + prodConstructor :: Expr -> Expr + prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd"))) + + recordConstructor :: Expr -> Expr + recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord"))) + + mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative + mkCtorClause (ctorName, tys) = do + idents <- replicateM (length tys) freshIdent' + return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents)) + where + caseResult idents = + App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName)) + . ArrayLiteral + $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys + + toSpineFun :: Expr -> Type -> Expr + toSpineFun i r | Just rec <- objectType r = + lamNull . recordConstructor . ArrayLiteral . + map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)]) + $ decomposeRec rec + toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i + mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d + mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration" + + mkSignatureFunction :: Declaration -> [Type] -> Expr + mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args + where + mkSigProd :: [Expr] -> Expr + mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) + (StringLiteral (showQualified runProperName (Qualified (Just mn) name))) + ) . ArrayLiteral + + mkSigRec :: [Expr] -> Expr + mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral + + proxy :: Type -> Type + proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy"))) + + mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr + mkProdClause (ctorName, tys) = + ObjectLiteral + [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))) + , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys) + ] + + mkProductSignature :: Type -> Expr + mkProductSignature r | Just rec <- objectType r = + lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str) + , ("recValue", mkProductSignature typ) + ] + | (str, typ) <- decomposeRec rec + ] + mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature) + (TypedValue False (mkGenVar "anyProxy") (proxy typ)) + instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs) + mkSignatureFunction (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction d classArgs + mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration" + + mkFromSpineFunction :: Declaration -> m Expr + mkFromSpineFunction (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args) + where + mkJust :: Expr -> Expr + mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just"))) + + mkNothing :: Expr + mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing")) + + prodBinder :: [Binder] -> Binder + prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd")) + + recordBinder :: [Binder] -> Binder + recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord")) + + mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative + mkAlternative (ctorName, tys) = do + idents <- replicateM (length tys) freshIdent' + return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]] + . Right + $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName)) + (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys) + + addCatch :: [CaseAlternative] -> [CaseAlternative] + addCatch = (++ [catchAll]) + where + catchAll = CaseAlternative [NullBinder] (Right mkNothing) + + fromSpineFun e r + | Just rec <- objectType r + = App (lamCase "r" [ mkRecCase (decomposeRec rec) + , CaseAlternative [NullBinder] (Right mkNothing) + ]) + (App e (mkPrelVar "unit")) + + fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit")) + + mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs) + ] + ] + . Right + $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs) + + mkRecFun :: [(String, Type)] -> Expr + mkRecFun xs = mkJust $ foldr lam recLiteral (map fst xs) + where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs + mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d + mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration" + + -- Helpers + + liftApplicative :: Expr -> [Expr] -> Expr + liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e) + + mkPrelVar :: String -> Expr + mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude])) + + mkGenVar :: String -> Expr + mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) + +deriveEq :: + forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m) + => ModuleName + -> [Declaration] + -> ProperName 'TypeName + -> m [Declaration] +deriveEq mn ds tyConNm = do + tyCon <- findTypeDecl tyConNm ds + eqFun <- mkEqFunction tyCon + return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ] + where + mkEqFunction :: Declaration -> m Expr + mkEqFunction (DataDeclaration _ _ _ args) = lamCase2 "$x" "$y" <$> (addCatch <$> mapM mkCtorClause args) + mkEqFunction (PositionedDeclaration _ _ d) = mkEqFunction d + mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration" + + preludeConj :: Expr -> Expr -> Expr + preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.conj))) + + preludeEq :: Expr -> Expr -> Expr + preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.eq))) + + addCatch :: [CaseAlternative] -> [CaseAlternative] + addCatch = (++ [catchAll]) + where + catchAll = CaseAlternative [NullBinder, NullBinder] (Right (BooleanLiteral False)) + + mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative + mkCtorClause (ctorName, tys) = do + [identsL, identsR] <- replicateM 2 (replicateM (length tys) freshIdent') + let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys + return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests)) + where + caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents) + + conjAll :: [Expr] -> Expr + conjAll [] = BooleanLiteral True + conjAll xs = foldl1 preludeConj xs + + toEqTest :: Expr -> Expr -> Type -> Expr + toEqTest l r ty | Just rec <- objectType ty = + conjAll + . map (\(str, typ) -> toEqTest (Accessor str l) (Accessor str r) typ) + $ decomposeRec rec + toEqTest l r _ = preludeEq l r findTypeDecl :: (Functor m, MonadError MultipleErrors m) @@ -102,123 +277,6 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d isTypeDecl _ = False -mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr -mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args - where - prodConstructor :: Expr -> Expr - prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd"))) - - recordConstructor :: Expr -> Expr - recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord"))) - - mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative - mkCtorClause (ctorName, tys) = do - idents <- replicateM (length tys) freshIdent' - return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents)) - where - caseResult idents = - App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName)) - . ArrayLiteral - $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys - - toSpineFun :: Expr -> Type -> Expr - toSpineFun i r | Just rec <- objectType r = - lamNull . recordConstructor . ArrayLiteral . - map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)]) - $ decomposeRec rec - toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i -mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d -mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration" - -mkSignatureFunction :: ModuleName -> Declaration -> [Type] -> Expr -mkSignatureFunction mn (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args - where - mkSigProd :: [Expr] -> Expr - mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) - (StringLiteral (showQualified runProperName (Qualified (Just mn) name))) - ) . ArrayLiteral - - mkSigRec :: [Expr] -> Expr - mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral - - proxy :: Type -> Type - proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy"))) - - mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr - mkProdClause (ctorName, tys) = - ObjectLiteral - [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))) - , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys) - ] - - mkProductSignature :: Type -> Expr - mkProductSignature r | Just rec <- objectType r = - lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str) - , ("recValue", mkProductSignature typ) - ] - | (str, typ) <- decomposeRec rec - ] - mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature) - (TypedValue False (mkGenVar "anyProxy") (proxy typ)) - instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs) -mkSignatureFunction mn (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction mn d classArgs -mkSignatureFunction _ _ _ = internalError "mkSignatureFunction: expected DataDeclaration" - -mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr -mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args) - where - mkJust :: Expr -> Expr - mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just"))) - - mkNothing :: Expr - mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing")) - - prodBinder :: [Binder] -> Binder - prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd")) - - recordBinder :: [Binder] -> Binder - recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord")) - - mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative - mkAlternative (ctorName, tys) = do - idents <- replicateM (length tys) freshIdent' - return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]] - . Right - $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName)) - (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys) - - addCatch :: [CaseAlternative] -> [CaseAlternative] - addCatch = (++ [catchAll]) - where - catchAll = CaseAlternative [NullBinder] (Right mkNothing) - - fromSpineFun e r - | Just rec <- objectType r - = App (lamCase "r" [ mkRecCase (decomposeRec rec) - , CaseAlternative [NullBinder] (Right mkNothing) - ]) - (App e (mkPrelVar "unit")) - - fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit")) - - mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs) - ] - ] - . Right - $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs) - - mkRecFun :: [(String, Type)] -> Expr - mkRecFun xs = mkJust $ foldr lam recLiteral (map fst xs) - where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs -mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d -mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration" - --- Helpers - -objectType :: Type -> Maybe Type -objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec -objectType _ = Nothing - lam :: String -> Expr -> Expr lam s = Abs (Left (Ident s)) @@ -228,8 +286,8 @@ lamNull = lam "$q" lamCase :: String -> [CaseAlternative] -> Expr lamCase s = lam s . Case [mkVar s] -liftApplicative :: Expr -> [Expr] -> Expr -liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e) +lamCase2 :: String -> String -> [CaseAlternative] -> Expr +lamCase2 s t = lam s . lam t . Case [mkVar s, mkVar t] mkVarMn :: Maybe ModuleName -> String -> Expr mkVarMn mn s = Var (Qualified mn (Ident s)) @@ -237,13 +295,11 @@ mkVarMn mn s = Var (Qualified mn (Ident s)) mkVar :: String -> Expr mkVar = mkVarMn Nothing -mkPrelVar :: String -> Expr -mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude])) - -mkGenVar :: String -> Expr -mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) +objectType :: Type -> Maybe Type +objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec +objectType _ = Nothing decomposeRec :: Type -> [(String, Type)] decomposeRec = sortBy (comparing fst) . go - where go (RCons str typ typs) = (str, typ) : decomposeRec typs - go _ = [] + where go (RCons str typ typs) = (str, typ) : decomposeRec typs + go _ = [] From 00dfbdd6b2c7467a88858118cb2a8b94f84e646d Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sat, 6 Feb 2016 13:50:07 +0100 Subject: [PATCH 0278/1580] fix stack.yaml syntax error --- stack-lts-3.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack-lts-3.yaml b/stack-lts-3.yaml index c69fe3dd83..dd8640a332 100644 --- a/stack-lts-3.yaml +++ b/stack-lts-3.yaml @@ -1,5 +1,5 @@ flags: {} packages: - '.' -extra-deps: +extra-deps: [] resolver: lts-3.6 From d5d0adfb0399d0eeec190378f7c4608de2baa463 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 6 Feb 2016 15:50:05 -0800 Subject: [PATCH 0279/1580] Ord deriving --- src/Language/PureScript/Constants.hs | 3 + .../PureScript/Sugar/TypeClasses/Deriving.hs | 65 +++++++++++++++++-- 2 files changed, 64 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 573654ac5f..6a57d3f3ff 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -98,6 +98,9 @@ eq = "eq" notEq :: String notEq = "notEq" +compare :: String +compare = "compare" + (&&) :: String (&&) = "&&" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index e2c0552782..133d3f7adc 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -50,10 +50,14 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args - | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) eq + | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Eq") , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon + | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Ord") + , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty + , mn == fromMaybe mn mn' + = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) = throwError . errorMessage $ CannotDerive className tys deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d @@ -77,9 +81,6 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ] typesProxy :: ModuleName typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ] -eq :: ProperName 'ClassName -eq = ProperName "Eq" - deriveGeneric :: forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName @@ -265,6 +266,62 @@ deriveEq mn ds tyConNm = do $ decomposeRec rec toEqTest l r _ = preludeEq l r +deriveOrd :: + forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m) + => ModuleName + -> [Declaration] + -> ProperName 'TypeName + -> m [Declaration] +deriveOrd mn ds tyConNm = do + tyCon <- findTypeDecl tyConNm ds + compareFun <- mkCompareFunction tyCon + return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ] + where + mkCompareFunction :: Declaration -> m Expr + mkCompareFunction (DataDeclaration _ _ _ args) = lamCase2 "$x" "$y" <$> (concat <$> mapM mkCtorClauses args) + mkCompareFunction (PositionedDeclaration _ _ d) = mkCompareFunction d + mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration" + + preludeCtor :: String -> Expr + preludeCtor = Constructor . Qualified (Just (ModuleName [ProperName C.prelude])) . ProperName + + preludeAppend :: Expr -> Expr -> Expr + preludeAppend = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.append))) + + preludeCompare :: Expr -> Expr -> Expr + preludeCompare = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.compare))) + + mkCtorClauses :: (ProperName 'ConstructorName, [Type]) -> m [CaseAlternative] + mkCtorClauses (ctorName, tys) = do + [identsL, identsR] <- replicateM 2 (replicateM (length tys) freshIdent') + let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys + return [ CaseAlternative [ caseBinder identsL + , caseBinder identsR + ] + (Right (appendAll tests)) + , CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) + , NullBinder + ] + (Right (preludeCtor "LT")) + , CaseAlternative [ NullBinder + , ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) + ] + (Right (preludeCtor "GT")) + ] + where + caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents) + + appendAll :: [Expr] -> Expr + appendAll [] = preludeCtor "EQ" + appendAll xs = foldl1 preludeAppend xs + + toOrdering :: Expr -> Expr -> Type -> Expr + toOrdering l r ty | Just rec <- objectType ty = + appendAll + . map (\(str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ) + $ decomposeRec rec + toOrdering l r _ = preludeCompare l r + findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName 'TypeName From 05e5c188222011fd589a7c69f5ea854f15c10a94 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 6 Feb 2016 15:53:36 -0800 Subject: [PATCH 0280/1580] Deriving tests --- examples/passing/Deriving.purs | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 examples/passing/Deriving.purs diff --git a/examples/passing/Deriving.purs b/examples/passing/Deriving.purs new file mode 100644 index 0000000000..738d7bcbc1 --- /dev/null +++ b/examples/passing/Deriving.purs @@ -0,0 +1,19 @@ +module Main where + +import Prelude +import Test.Assert + +data X = X Int | Y String + +derive instance eqX :: Eq X + +derive instance ordX :: Ord X + +main = do + assert $ X 0 == X 0 + assert $ X 0 /= X 1 + assert $ Y "Foo" == Y "Foo" + assert $ Y "Foo" /= Y "Bar" + assert $ X 0 < X 1 + assert $ X 0 < Y "Foo" + assert $ Y "Bar" < Y "Baz" From 3000b40c1d801ae5a3ecf82b8f1254f5982c3ac7 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 6 Feb 2016 18:15:10 +0000 Subject: [PATCH 0281/1580] Tidy up the test suites * Consolidate both test suites into a single one; the "psci-tests" suite is now gone * Enable warnings (-Wall) on the test suites, and fix all warnings * Check in all test support code instead of fetching it every time. This means that tests no longer need npm or bower to run, and so we can * Re-enable the psc-publish tests, which work now that the support code is checked in. * Rename all the psci modules like `Types` -> `PSCi.Types` so that it's clearer what they're for, especially in the tests. * Tidy up the tests a bit so that the structure is a bit clearer - specifically, `tests/Main.hs` no longer has any tests directly inside it. Instead, it imports tests from other modules, like `TestPscPublish`, `TestCompiler`, etc. * Remove the need to import `TestPscPublish` from `TestDocs` - it was only because of `pushd`, which has been moved into `TestUtils`. * Remove the parts of the build scripts which are no longer necessary now that there is just one test suite. * Ignore dirty working trees during the psc-publish tests, as they just get in the way. --- .gitignore | 1 - .travis.yml | 5 +- psci/PSCi.hs | 10 +- psci/{ => PSCi}/Completion.hs | 6 +- psci/{ => PSCi}/Directive.hs | 4 +- psci/{ => PSCi}/IO.hs | 2 +- psci/{ => PSCi}/Parser.hs | 6 +- psci/{ => PSCi}/Types.hs | 2 +- purescript.cabal | 45 +- tests/Main.hs | 212 +---- tests/TestCompiler.hs | 194 ++++ tests/TestDocs.hs | 15 +- tests/TestPscPublish.hs | 17 +- psci/tests/Main.hs => tests/TestPsci.hs | 13 +- tests/{common/TestsSetup.hs => TestUtils.hs} | 26 +- .../flattened/Control-Monad-Eff-Class.purs | 24 + .../flattened/Control-Monad-Eff-Console.js | 18 + .../flattened/Control-Monad-Eff-Console.purs | 18 + .../flattened/Control-Monad-Eff-Unsafe.js | 8 + .../flattened/Control-Monad-Eff-Unsafe.purs | 10 + tests/support/flattened/Control-Monad-Eff.js | 62 ++ .../support/flattened/Control-Monad-Eff.purs | 67 ++ tests/support/flattened/Control-Monad-ST.js | 38 + tests/support/flattened/Control-Monad-ST.purs | 42 + tests/support/flattened/Data-Function.js | 233 +++++ tests/support/flattened/Data-Function.purs | 113 +++ tests/support/flattened/Prelude.js | 228 +++++ tests/support/flattened/Prelude.purs | 872 ++++++++++++++++++ tests/support/flattened/Test-Assert.js | 27 + tests/support/flattened/Test-Assert.purs | 46 + .../data => tests/support/psci}/Sample.purs | 0 travis/after.sh | 22 +- travis/configure.sh | 2 +- 33 files changed, 2094 insertions(+), 294 deletions(-) rename psci/{ => PSCi}/Completion.hs (99%) rename psci/{ => PSCi}/Directive.hs (98%) rename psci/{ => PSCi}/IO.hs (96%) rename psci/{ => PSCi}/Parser.hs (98%) rename psci/{ => PSCi}/Types.hs (99%) create mode 100644 tests/TestCompiler.hs rename psci/tests/Main.hs => tests/TestPsci.hs (95%) rename tests/{common/TestsSetup.hs => TestUtils.hs} (66%) create mode 100644 tests/support/flattened/Control-Monad-Eff-Class.purs create mode 100644 tests/support/flattened/Control-Monad-Eff-Console.js create mode 100644 tests/support/flattened/Control-Monad-Eff-Console.purs create mode 100644 tests/support/flattened/Control-Monad-Eff-Unsafe.js create mode 100644 tests/support/flattened/Control-Monad-Eff-Unsafe.purs create mode 100644 tests/support/flattened/Control-Monad-Eff.js create mode 100644 tests/support/flattened/Control-Monad-Eff.purs create mode 100644 tests/support/flattened/Control-Monad-ST.js create mode 100644 tests/support/flattened/Control-Monad-ST.purs create mode 100644 tests/support/flattened/Data-Function.js create mode 100644 tests/support/flattened/Data-Function.purs create mode 100644 tests/support/flattened/Prelude.js create mode 100644 tests/support/flattened/Prelude.purs create mode 100644 tests/support/flattened/Test-Assert.js create mode 100644 tests/support/flattened/Test-Assert.purs rename {psci/tests/data => tests/support/psci}/Sample.purs (100%) diff --git a/.gitignore b/.gitignore index a9cf995eff..0047b5c8f6 100644 --- a/.gitignore +++ b/.gitignore @@ -14,7 +14,6 @@ bower_components/ node_modules tmp/ .stack-work/ -tests/support/flattened/ output examples/docs/docs/ core-tests/full-core-docs.md diff --git a/.travis.yml b/.travis.yml index 6e4db803ce..0df9bebff1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,13 +2,10 @@ language: c sudo: false matrix: include: - - env: GHCVER=7.8.4 COVERAGE_SUITE=tests + - env: GHCVER=7.8.4 COVERAGE=true compiler: ": #GHC 7.8.4 - tests" # ^ HACK before https://github.com/travis-ci/travis-ci/issues/4393 is resolved addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.8.4 COVERAGE_SUITE=psci-tests - compiler: ": #GHC 7.8.4 - psci-tests" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - env: GHCVER=7.8.4 STACKAGE=lts-2.22 compiler: ": #GHC 7.8.4 - lts-2.22-1" addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 4ea0342014..d088e9a51c 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -44,11 +44,11 @@ import qualified Language.PureScript as P import qualified Language.PureScript.Names as N import qualified Paths_purescript as Paths -import qualified Directive as D -import Completion (completion) -import IO (mkdirp) -import Parser (parseCommand) -import Types +import qualified PSCi.Directive as D +import PSCi.Completion (completion) +import PSCi.IO (mkdirp) +import PSCi.Parser (parseCommand) +import PSCi.Types -- | The name of the PSCI support module supportModuleName :: P.ModuleName diff --git a/psci/Completion.hs b/psci/PSCi/Completion.hs similarity index 99% rename from psci/Completion.hs rename to psci/PSCi/Completion.hs index 564d9044f8..26965e7c71 100644 --- a/psci/Completion.hs +++ b/psci/PSCi/Completion.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds #-} -module Completion where +module PSCi.Completion where import Prelude () import Prelude.Compat @@ -19,8 +19,8 @@ import System.Console.Haskeline import qualified Language.PureScript as P import qualified Language.PureScript.Names as N -import qualified Directive as D -import Types +import qualified PSCi.Directive as D +import PSCi.Types -- Completions may read the state, but not modify it. type CompletionM = ReaderT PSCiState IO diff --git a/psci/Directive.hs b/psci/PSCi/Directive.hs similarity index 98% rename from psci/Directive.hs rename to psci/PSCi/Directive.hs index f2a3ca6928..92f8853df2 100644 --- a/psci/Directive.hs +++ b/psci/PSCi/Directive.hs @@ -13,13 +13,13 @@ -- ----------------------------------------------------------------------------- -module Directive where +module PSCi.Directive where import Data.Maybe (fromJust, listToMaybe) import Data.List (isPrefixOf) import Data.Tuple (swap) -import Types +import PSCi.Types -- | -- List of all avaliable directives. diff --git a/psci/IO.hs b/psci/PSCi/IO.hs similarity index 96% rename from psci/IO.hs rename to psci/PSCi/IO.hs index 36a55d16a5..92668a96ec 100644 --- a/psci/IO.hs +++ b/psci/PSCi/IO.hs @@ -12,7 +12,7 @@ -- ----------------------------------------------------------------------------- -module IO where +module PSCi.IO where import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) diff --git a/psci/Parser.hs b/psci/PSCi/Parser.hs similarity index 98% rename from psci/Parser.hs rename to psci/PSCi/Parser.hs index b8b0675f74..526f3d6eac 100644 --- a/psci/Parser.hs +++ b/psci/PSCi/Parser.hs @@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -module Parser +module PSCi.Parser ( parseCommand ) where @@ -28,8 +28,8 @@ import Text.Parsec hiding ((<|>)) import qualified Language.PureScript as P import Language.PureScript.Parser.Common (mark, same) -import qualified Directive as D -import Types +import qualified PSCi.Directive as D +import PSCi.Types -- | -- Parses PSCI metacommands or expressions input from the user. diff --git a/psci/Types.hs b/psci/PSCi/Types.hs similarity index 99% rename from psci/Types.hs rename to psci/PSCi/Types.hs index 7465cdf6e5..72c562bbce 100644 --- a/psci/Types.hs +++ b/psci/PSCi/Types.hs @@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -module Types where +module PSCi.Types where import Control.Arrow (second) import Data.Map (Map) diff --git a/purescript.cabal b/purescript.cabal index a1a21a83e1..50befa7e1a 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -27,7 +27,13 @@ extra-source-files: examples/passing/*.purs , tests/support/package.json , tests/support/bower.json , tests/support/setup-win.cmd - , psci/tests/data/Sample.purs + , tests/support/flattened/*.purs + , tests/support/flattened/*.js + , tests/support/psci/*.purs + , tests/support/prelude/bower.json + , tests/support/prelude/src/*.purs + , tests/support/prelude/src/*.js + , tests/support/prelude/LICENSE , stack.yaml , stack-lts-2.yaml , stack-lts-3.yaml @@ -213,12 +219,12 @@ executable psci main-is: Main.hs buildable: True hs-source-dirs: psci psci/main - other-modules: Types - Parser - Directive - Completion - PSCi - IO + other-modules: PSCi + PSCi.Types + PSCi.Parser + PSCi.Directive + PSCi.Completion + PSCi.IO ghc-options: -Wall -O2 executable psc-docs @@ -273,24 +279,15 @@ test-suite tests filepath -any, mtl -any, parsec -any, purescript -any, transformers -any, process -any, transformers-compat -any, time -any, Glob -any, aeson-better-errors -any, bytestring -any, aeson -any, - base-compat -any + base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any, + boxes -any, HUnit -any + ghc-options: -Wall type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: TestsSetup - TestPscPublish + other-modules: TestUtils + TestCompiler TestDocs + TestPscPublish + TestPsci buildable: True - hs-source-dirs: tests tests/common - -test-suite psci-tests - build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, - mtl -any, optparse-applicative >= 0.10.0, parsec -any, - haskeline >= 0.7.0.0, purescript -any, transformers -any, - transformers-compat -any, process -any, HUnit -any, time -any, - Glob -any, base-compat >=0.6.0, boxes >= 0.1.4 && < 0.2.0 - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: TestsSetup - buildable: True - hs-source-dirs: psci psci/tests tests/common - ghc-options: -Wall + hs-source-dirs: tests psci diff --git a/tests/Main.hs b/tests/Main.hs index 9433b19474..ac267d97ff 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -16,171 +16,26 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} --- Failing tests can specify the kind of error that should be thrown with a --- @shouldFailWith declaration. For example: --- --- "-- @shouldFailWith TypesDoNotUnify" --- --- will cause the test to fail unless that module fails to compile with exactly --- one TypesDoNotUnify error. --- --- If a module is expected to produce multiple type errors, then use multiple --- @shouldFailWith lines; for example: --- --- -- @shouldFailWith TypesDoNotUnify --- -- @shouldFailWith TypesDoNotUnify --- -- @shouldFailWith TransitiveExportError --- - module Main (main) where import Prelude () import Prelude.Compat -import qualified Language.PureScript as P -import qualified Language.PureScript.CodeGen.JS as J -import qualified Language.PureScript.CoreFn as CF -import qualified Language.PureScript.Docs as Docs - -import Data.Char (isSpace) -import Data.Maybe (mapMaybe, fromMaybe) -import Data.List (isSuffixOf, sort, stripPrefix) -import Data.Time.Clock (UTCTime()) - -import qualified Data.Map as M - -import Control.Monad -import Control.Monad.IO.Class (liftIO) -import Control.Arrow ((>>>)) - -import Control.Monad.Reader -import Control.Monad.Writer.Strict -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Except -import Control.Monad.Error.Class - -import System.Exit -import System.Process -import System.FilePath -import System.Directory -import System.IO.UTF8 -import qualified System.Info -import qualified System.FilePath.Glob as Glob - -import Text.Parsec (ParseError) - -import TestsSetup -import TestPscPublish +import qualified TestCompiler +import qualified TestPscPublish import qualified TestDocs - -modulesDir :: FilePath -modulesDir = ".test_modules" "node_modules" - -makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make -makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False) - { P.getInputTimestamp = getInputTimestamp - , P.getOutputTimestamp = getOutputTimestamp - } - where - getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime)) - getInputTimestamp mn - | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever) - | otherwise = return (Left P.RebuildAlways) - where - isSupportModule = flip elem supportModules - - getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime) - getOutputTimestamp mn = do - let filePath = modulesDir P.runModuleName mn - exists <- liftIO $ doesDirectoryExist filePath - return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing) - -readInput :: [FilePath] -> IO [(FilePath, String)] -readInput inputFiles = forM inputFiles $ \inputFile -> do - text <- readUTF8File inputFile - return (inputFile, text) - -type TestM = WriterT [(FilePath, String)] IO - -runTest :: P.Make a -> IO (Either P.MultipleErrors a) -runTest = fmap fst . P.runMake P.defaultOptions - -compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment) -compile inputFiles foreigns = runTest $ do - fs <- liftIO $ readInput inputFiles - ms <- P.parseModulesFromFiles id fs - P.make (makeActions foreigns) (map snd ms) - -assert :: [FilePath] -> - M.Map P.ModuleName FilePath -> - (Either P.MultipleErrors P.Environment -> IO (Maybe String)) -> - TestM () -assert inputFiles foreigns f = do - e <- liftIO $ compile inputFiles foreigns - maybeErr <- liftIO $ f e - case maybeErr of - Just err -> tell [(last inputFiles, err)] - Nothing -> return () - -assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM () -assertCompiles inputFiles foreigns = do - liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully" - assert inputFiles foreigns $ \e -> - case e of - Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs - Right _ -> do - process <- findNodeProcess - let entryPoint = modulesDir "index.js" - writeFile entryPoint "require('Main').main()" - result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process - case result of - Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing - Just (ExitFailure _, _, err) -> return $ Just err - Nothing -> return $ Just "Couldn't find node.js executable" - -assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM () -assertDoesNotCompile inputFiles foreigns = do - let testFile = last inputFiles - liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile" - shouldFailWith <- getShouldFailWith testFile - assert inputFiles foreigns $ \e -> - case e of - Left errs -> do - putStrLn (P.prettyPrintMultipleErrors False errs) - return $ if null shouldFailWith - then Just $ "shouldFailWith declaration is missing (errors were: " - ++ show (map P.errorCode (P.runMultipleErrors errs)) - ++ ")" - else checkShouldFailWith shouldFailWith errs - Right _ -> - return $ Just "Should not have compiled" - - where - getShouldFailWith = - readUTF8File - >>> liftIO - >>> fmap ( lines - >>> mapMaybe (stripPrefix "-- @shouldFailWith ") - >>> map trim - ) - - checkShouldFailWith expected errs = - let actual = map P.errorCode $ P.runMultipleErrors errs - in if sort expected == sort actual - then Nothing - else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual - - trim = - dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse +import qualified TestPsci main :: IO () main = do heading "Main compiler test suite" - testCompiler + TestCompiler.main heading "Documentation test suite" TestDocs.main - -- heading "psc-publish test suite" - -- testPscPublish + heading "psc-publish test suite" + TestPscPublish.main + heading "psci test suite" + TestPsci.main where heading msg = do @@ -189,54 +44,3 @@ main = do putStrLn $ "# " ++ msg putStrLn $ replicate 79 '#' putStrLn "" - -testCompiler :: IO () -testCompiler = do - fetchSupportCode - cwd <- getCurrentDirectory - - let supportDir = cwd "tests" "support" "flattened" - let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir - - supportPurs <- supportFiles "purs" - supportJS <- supportFiles "js" - - foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f) - Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles - - let passing = cwd "examples" "passing" - passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing - let failing = cwd "examples" "failing" - failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing - - failures <- execWriterT $ do - forM_ passingTestCases $ \inputFile -> - assertCompiles (supportPurs ++ [passing inputFile]) foreigns - forM_ failingTestCases $ \inputFile -> - assertDoesNotCompile (supportPurs ++ [failing inputFile]) foreigns - - if null failures - then pure () - else do - putStrLn "Failures:" - forM_ failures $ \(fp, err) -> - let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp - in putStrLn $ fp' ++ ": " ++ err - exitFailure - -testPscPublish :: IO () -testPscPublish = do - testPackage "tests/support/prelude" - - -supportModules :: [String] -supportModules = - [ "Control.Monad.Eff.Class" - , "Control.Monad.Eff.Console" - , "Control.Monad.Eff" - , "Control.Monad.Eff.Unsafe" - , "Control.Monad.ST" - , "Data.Function" - , "Prelude" - , "Test.Assert" - ] diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs new file mode 100644 index 0000000000..43b07282ee --- /dev/null +++ b/tests/TestCompiler.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} + +module TestCompiler where + +-- Failing tests can specify the kind of error that should be thrown with a +-- @shouldFailWith declaration. For example: +-- +-- "-- @shouldFailWith TypesDoNotUnify" +-- +-- will cause the test to fail unless that module fails to compile with exactly +-- one TypesDoNotUnify error. +-- +-- If a module is expected to produce multiple type errors, then use multiple +-- @shouldFailWith lines; for example: +-- +-- -- @shouldFailWith TypesDoNotUnify +-- -- @shouldFailWith TypesDoNotUnify +-- -- @shouldFailWith TransitiveExportError + +import Prelude () +import Prelude.Compat + +import qualified Language.PureScript as P + +import Data.Char (isSpace) +import Data.Maybe (mapMaybe, fromMaybe) +import Data.List (isSuffixOf, sort, stripPrefix) +import Data.Time.Clock (UTCTime()) + +import qualified Data.Map as M + +import Control.Monad +import Control.Arrow ((>>>)) + +import Control.Monad.Reader +import Control.Monad.Writer.Strict +import Control.Monad.Trans.Except + +import System.Exit +import System.Process hiding (cwd) +import System.FilePath +import System.Directory +import System.IO.UTF8 +import qualified System.FilePath.Glob as Glob + +import TestUtils + +main :: IO () +main = do + cwd <- getCurrentDirectory + + let supportDir = cwd "tests" "support" "flattened" + let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir + + supportPurs <- supportFiles "purs" + supportJS <- supportFiles "js" + + foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f) + Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles + + let passing = cwd "examples" "passing" + passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing + let failing = cwd "examples" "failing" + failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing + + failures <- execWriterT $ do + forM_ passingTestCases $ \inputFile -> + assertCompiles (supportPurs ++ [passing inputFile]) foreigns + forM_ failingTestCases $ \inputFile -> + assertDoesNotCompile (supportPurs ++ [failing inputFile]) foreigns + + if null failures + then pure () + else do + putStrLn "Failures:" + forM_ failures $ \(fp, err) -> + let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp + in putStrLn $ fp' ++ ": " ++ err + exitFailure + +modulesDir :: FilePath +modulesDir = ".test_modules" "node_modules" + +makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make +makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False) + { P.getInputTimestamp = getInputTimestamp + , P.getOutputTimestamp = getOutputTimestamp + } + where + getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime)) + getInputTimestamp mn + | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever) + | otherwise = return (Left P.RebuildAlways) + where + isSupportModule = flip elem supportModules + + getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime) + getOutputTimestamp mn = do + let filePath = modulesDir P.runModuleName mn + exists <- liftIO $ doesDirectoryExist filePath + return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing) + +readInput :: [FilePath] -> IO [(FilePath, String)] +readInput inputFiles = forM inputFiles $ \inputFile -> do + text <- readUTF8File inputFile + return (inputFile, text) + +type TestM = WriterT [(FilePath, String)] IO + +runTest :: P.Make a -> IO (Either P.MultipleErrors a) +runTest = fmap fst . P.runMake P.defaultOptions + +compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment) +compile inputFiles foreigns = runTest $ do + fs <- liftIO $ readInput inputFiles + ms <- P.parseModulesFromFiles id fs + P.make (makeActions foreigns) (map snd ms) + +assert :: [FilePath] -> + M.Map P.ModuleName FilePath -> + (Either P.MultipleErrors P.Environment -> IO (Maybe String)) -> + TestM () +assert inputFiles foreigns f = do + e <- liftIO $ compile inputFiles foreigns + maybeErr <- liftIO $ f e + case maybeErr of + Just err -> tell [(last inputFiles, err)] + Nothing -> return () + +assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM () +assertCompiles inputFiles foreigns = do + liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully" + assert inputFiles foreigns $ \e -> + case e of + Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs + Right _ -> do + process <- findNodeProcess + let entryPoint = modulesDir "index.js" + writeFile entryPoint "require('Main').main()" + result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process + case result of + Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing + Just (ExitFailure _, _, err) -> return $ Just err + Nothing -> return $ Just "Couldn't find node.js executable" + +assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM () +assertDoesNotCompile inputFiles foreigns = do + let testFile = last inputFiles + liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile" + shouldFailWith <- getShouldFailWith testFile + assert inputFiles foreigns $ \e -> + case e of + Left errs -> do + putStrLn (P.prettyPrintMultipleErrors False errs) + return $ if null shouldFailWith + then Just $ "shouldFailWith declaration is missing (errors were: " + ++ show (map P.errorCode (P.runMultipleErrors errs)) + ++ ")" + else checkShouldFailWith shouldFailWith errs + Right _ -> + return $ Just "Should not have compiled" + + where + getShouldFailWith = + readUTF8File + >>> liftIO + >>> fmap ( lines + >>> mapMaybe (stripPrefix "-- @shouldFailWith ") + >>> map trim + ) + + checkShouldFailWith expected errs = + let actual = map P.errorCode $ P.runMultipleErrors errs + in if sort expected == sort actual + then Nothing + else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual + + trim = + dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse + +supportModules :: [String] +supportModules = + [ "Control.Monad.Eff.Class" + , "Control.Monad.Eff.Console" + , "Control.Monad.Eff" + , "Control.Monad.Eff.Unsafe" + , "Control.Monad.ST" + , "Data.Function" + , "Prelude" + , "Test.Assert" + ] diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 477cc130d6..6215f925c1 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -9,21 +9,17 @@ import Prelude.Compat import Data.Version (Version(..)) -import Control.Monad hiding (forM_) -import Control.Applicative -import Control.Arrow +import Data.Monoid ((<>)) import Data.Maybe (fromMaybe) import Data.List ((\\)) import Data.Foldable -import Data.Traversable import System.Exit -import qualified Text.Parsec as Parsec import qualified Language.PureScript as P import qualified Language.PureScript.Docs as Docs import qualified Language.PureScript.Publish as Publish -import qualified TestPscPublish +import TestUtils publishOpts :: Publish.PublishOptions publishOpts = Publish.defaultPublishOptions @@ -34,7 +30,7 @@ publishOpts = Publish.defaultPublishOptions main :: IO () main = do - TestPscPublish.pushd "examples/docs" $ do + pushd "examples/docs" $ do Docs.Package{..} <- Publish.preparePackage publishOpts forM_ testCases $ \(mn, pragmas) -> let mdl = takeJust ("module not found in docs: " ++ mn) @@ -132,6 +128,7 @@ runAssertion assertion Docs.Module{..} = childrenTitles = map Docs.cdeclTitle . Docs.declChildren +checkConstrained :: P.Type -> String -> Bool checkConstrained ty tyClass = -- Note that we don't recurse on ConstrainedType if none of the constraints -- match; this is by design, as constraints should be moved to the front @@ -152,8 +149,8 @@ runAssertionIO assertion mdl = do putStrLn ("In " ++ Docs.modName mdl ++ ": " ++ show assertion) case runAssertion assertion mdl of Pass -> pure () - fail -> do - putStrLn (show fail) + Fail reason -> do + putStrLn ("Failed: " <> show reason) exitFailure testCases :: [(String, [Assertion])] diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 657105d07e..49321edff6 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -20,13 +20,11 @@ import Data.Version import Language.PureScript.Docs import Language.PureScript.Publish -pushd :: forall a. FilePath -> IO a -> IO a -pushd dir act = do - original <- getCurrentDirectory - setCurrentDirectory dir - result <- try act :: IO (Either IOException a) - setCurrentDirectory original - either throwIO return result +import TestUtils + +main :: IO () +main = do + testPackage "tests/support/prelude" data TestResult = ParseFailed String @@ -48,6 +46,7 @@ roundTrip pkg = testRunOptions :: PublishOptions testRunOptions = defaultPublishOptions { publishGetVersion = return testVersion + , publishWorkingTreeDirty = return () } where testVersion = ("v999.0.0", Version [999,0,0] []) @@ -58,7 +57,9 @@ testPackage dir = do pushd dir $ do r <- roundTrip <$> preparePackage testRunOptions case r of - Pass _ -> pure () + Pass _ -> do + putStrLn ("psc-publish test passed for: " ++ dir) + pure () other -> do putStrLn ("psc-publish tests failed on " ++ dir ++ ":") putStrLn (show other) diff --git a/psci/tests/Main.hs b/tests/TestPsci.hs similarity index 95% rename from psci/tests/Main.hs rename to tests/TestPsci.hs index af24736487..206e6d889a 100644 --- a/psci/tests/Main.hs +++ b/tests/TestPsci.hs @@ -1,7 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -module Main where +module TestPsci where import Prelude () import Prelude.Compat @@ -24,14 +24,11 @@ import Test.HUnit import qualified Language.PureScript as P import PSCi -import Completion -import Types - -import TestsSetup +import PSCi.Completion +import PSCi.Types main :: IO () main = do - fetchSupportCode Counts{..} <- runTestTT allTests when (errors + failures > 0) exitFailure @@ -65,8 +62,8 @@ completionTestData = , ("import qualified Control.Monad.Eff.", map ("import qualified Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"]) -- :load, :module should complete file paths - , (":l psci/tests/data/", [":l psci/tests/data/Sample.purs"]) - , (":module psci/tests/data/", [":module psci/tests/data/Sample.purs"]) + , (":l tests/support/psci/", [":l tests/support/psci/Sample.purs"]) + , (":module tests/support/psci/", [":module tests/support/psci/Sample.purs"]) -- :quit, :help, :reset should not complete , (":help ", []) diff --git a/tests/common/TestsSetup.hs b/tests/TestUtils.hs similarity index 66% rename from tests/common/TestsSetup.hs rename to tests/TestUtils.hs index 1ec2cd1824..7195db24bf 100644 --- a/tests/common/TestsSetup.hs +++ b/tests/TestUtils.hs @@ -10,7 +10,9 @@ -- | -- ----------------------------------------------------------------------------- -module TestsSetup where +{-# LANGUAGE ScopedTypeVariables #-} + +module TestUtils where import Prelude () import Prelude.Compat @@ -18,6 +20,7 @@ import Prelude.Compat import Data.Maybe (fromMaybe) import Control.Monad import Control.Monad.Trans.Maybe +import Control.Exception import System.Process import System.Directory @@ -30,8 +33,16 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names where names = ["nodejs", "node"] -fetchSupportCode :: IO () -fetchSupportCode = do +-- | +-- Fetches code necessary to run the tests with. The resulting support code +-- should then be checked in, so that npm/bower etc is not required to run the +-- tests. +-- +-- Simply rerun this (via ghci is probably easiest) when the support code needs +-- updating. +-- +updateSupportCode :: IO () +updateSupportCode = do node <- fromMaybe (internalError "cannot find node executable") <$> findNodeProcess setCurrentDirectory "tests/support" if System.Info.os == "mingw32" @@ -43,3 +54,12 @@ fetchSupportCode = do callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"] callProcess node ["setup.js"] setCurrentDirectory "../.." + +pushd :: forall a. FilePath -> IO a -> IO a +pushd dir act = do + original <- getCurrentDirectory + setCurrentDirectory dir + result <- try act :: IO (Either IOException a) + setCurrentDirectory original + either throwIO return result + diff --git a/tests/support/flattened/Control-Monad-Eff-Class.purs b/tests/support/flattened/Control-Monad-Eff-Class.purs new file mode 100644 index 0000000000..dbfd58ebcf --- /dev/null +++ b/tests/support/flattened/Control-Monad-Eff-Class.purs @@ -0,0 +1,24 @@ +module Control.Monad.Eff.Class + ( MonadEff + , liftEff + ) where + +import Prelude + +import Control.Monad.Eff + +-- | The `MonadEff` class captures those monads which support native effects. +-- | +-- | Instances are provided for `Eff` itself, and the standard monad transformers. +-- | +-- | `liftEff` can be used in any appropriate monad transformer stack to lift an action +-- | of type `Eff eff a` into the monad. +-- | +-- | Note that `MonadEff` is parameterized by the row of effects, so type inference can be +-- | tricky. It is generally recommended to either work with a polymorphic row of effects, +-- | or a concrete, closed row of effects such as `(trace :: Trace)`. +class (Monad m) <= MonadEff eff m where + liftEff :: forall a. Eff eff a -> m a + +instance monadEffEff :: MonadEff eff (Eff eff) where + liftEff = id diff --git a/tests/support/flattened/Control-Monad-Eff-Console.js b/tests/support/flattened/Control-Monad-Eff-Console.js new file mode 100644 index 0000000000..9ccfc26b45 --- /dev/null +++ b/tests/support/flattened/Control-Monad-Eff-Console.js @@ -0,0 +1,18 @@ +/* global exports, console */ +"use strict"; + +// module Control.Monad.Eff.Console + +exports.log = function (s) { + return function () { + console.log(s); + return {}; + }; +}; + +exports.error = function (s) { + return function () { + console.error(s); + return {}; + }; +}; diff --git a/tests/support/flattened/Control-Monad-Eff-Console.purs b/tests/support/flattened/Control-Monad-Eff-Console.purs new file mode 100644 index 0000000000..0a03ee4d3e --- /dev/null +++ b/tests/support/flattened/Control-Monad-Eff-Console.purs @@ -0,0 +1,18 @@ +module Control.Monad.Eff.Console where + +import Prelude + +import Control.Monad.Eff + +-- | The `CONSOLE` effect represents those computations which write to the console. +foreign import data CONSOLE :: ! + +-- | Write a message to the console. +foreign import log :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit + +-- | Write an error to the console. +foreign import error :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit + +-- | Write a value to the console, using its `Show` instance to produce a `String`. +print :: forall a eff. (Show a) => a -> Eff (console :: CONSOLE | eff) Unit +print = log <<< show diff --git a/tests/support/flattened/Control-Monad-Eff-Unsafe.js b/tests/support/flattened/Control-Monad-Eff-Unsafe.js new file mode 100644 index 0000000000..bada18a47e --- /dev/null +++ b/tests/support/flattened/Control-Monad-Eff-Unsafe.js @@ -0,0 +1,8 @@ +/* global exports */ +"use strict"; + +// module Control.Monad.Eff.Unsafe + +exports.unsafeInterleaveEff = function (f) { + return f; +}; diff --git a/tests/support/flattened/Control-Monad-Eff-Unsafe.purs b/tests/support/flattened/Control-Monad-Eff-Unsafe.purs new file mode 100644 index 0000000000..5d6f104483 --- /dev/null +++ b/tests/support/flattened/Control-Monad-Eff-Unsafe.purs @@ -0,0 +1,10 @@ +module Control.Monad.Eff.Unsafe where + +import Prelude + +import Control.Monad.Eff + +-- | Change the type of an effectful computation, allowing it to be run in another context. +-- | +-- | Note: use of this function can result in arbitrary side-effects. +foreign import unsafeInterleaveEff :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a diff --git a/tests/support/flattened/Control-Monad-Eff.js b/tests/support/flattened/Control-Monad-Eff.js new file mode 100644 index 0000000000..1498f2139d --- /dev/null +++ b/tests/support/flattened/Control-Monad-Eff.js @@ -0,0 +1,62 @@ +/* global exports */ +"use strict"; + +// module Control.Monad.Eff + +exports.returnE = function (a) { + return function () { + return a; + }; +}; + +exports.bindE = function (a) { + return function (f) { + return function () { + return f(a())(); + }; + }; +}; + +exports.runPure = function (f) { + return f(); +}; + +exports.untilE = function (f) { + return function () { + while (!f()); + return {}; + }; +}; + +exports.whileE = function (f) { + return function (a) { + return function () { + while (f()) { + a(); + } + return {}; + }; + }; +}; + +exports.forE = function (lo) { + return function (hi) { + return function (f) { + return function () { + for (var i = lo; i < hi; i++) { + f(i)(); + } + }; + }; + }; +}; + +exports.foreachE = function (as) { + return function (f) { + return function () { + for (var i = 0, l = as.length; i < l; i++) { + f(as[i])(); + } + }; + }; +}; diff --git a/tests/support/flattened/Control-Monad-Eff.purs b/tests/support/flattened/Control-Monad-Eff.purs new file mode 100644 index 0000000000..0417c198b7 --- /dev/null +++ b/tests/support/flattened/Control-Monad-Eff.purs @@ -0,0 +1,67 @@ +module Control.Monad.Eff + ( Eff() + , Pure() + , runPure + , untilE, whileE, forE, foreachE + ) where + +import Prelude + +-- | The `Eff` type constructor is used to represent _native_ effects. +-- | +-- | See [Handling Native Effects with the Eff Monad](https://github.com/purescript/purescript/wiki/Handling-Native-Effects-with-the-Eff-Monad) for more details. +-- | +-- | The first type parameter is a row of effects which represents the contexts in which a computation can be run, and the second type parameter is the return type. +foreign import data Eff :: # ! -> * -> * + +foreign import returnE :: forall e a. a -> Eff e a + +foreign import bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b + +-- | The `Pure` type synonym represents _pure_ computations, i.e. ones in which all effects have been handled. +-- | +-- | The `runPure` function can be used to run pure computations and obtain their result. +type Pure a = forall e. Eff e a + +-- | Run a pure computation and return its result. +-- | +-- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach +-- | is to use parentheses instead. +foreign import runPure :: forall a. Pure a -> a + +instance functorEff :: Functor (Eff e) where + map = liftA1 + +instance applyEff :: Apply (Eff e) where + apply = ap + +instance applicativeEff :: Applicative (Eff e) where + pure = returnE + +instance bindEff :: Bind (Eff e) where + bind = bindE + +instance monadEff :: Monad (Eff e) + +-- | Loop until a condition becomes `true`. +-- | +-- | `untilE b` is an effectful computation which repeatedly runs the effectful computation `b`, +-- | until its return value is `true`. +foreign import untilE :: forall e. Eff e Boolean -> Eff e Unit + +-- | Loop while a condition is `true`. +-- | +-- | `whileE b m` is effectful computation which runs the effectful computation `b`. If its result is +-- | `true`, it runs the effectful computation `m` and loops. If not, the computation ends. +foreign import whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit + +-- | Loop over a consecutive collection of numbers. +-- | +-- | `forE lo hi f` runs the computation returned by the function `f` for each of the inputs +-- | between `lo` (inclusive) and `hi` (exclusive). +foreign import forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit + +-- | Loop over an array of values. +-- | +-- | `foreach xs f` runs the computation returned by the function `f` for each of the inputs `xs`. +foreign import foreachE :: forall e a. Array a -> (a -> Eff e Unit) -> Eff e Unit diff --git a/tests/support/flattened/Control-Monad-ST.js b/tests/support/flattened/Control-Monad-ST.js new file mode 100644 index 0000000000..64597c12c9 --- /dev/null +++ b/tests/support/flattened/Control-Monad-ST.js @@ -0,0 +1,38 @@ +/* global exports */ +"use strict"; + +// module Control.Monad.ST + +exports.newSTRef = function (val) { + return function () { + return { value: val }; + }; +}; + +exports.readSTRef = function (ref) { + return function () { + return ref.value; + }; +}; + +exports.modifySTRef = function (ref) { + return function (f) { + return function () { + /* jshint boss: true */ + return ref.value = f(ref.value); + }; + }; +}; + +exports.writeSTRef = function (ref) { + return function (a) { + return function () { + /* jshint boss: true */ + return ref.value = a; + }; + }; +}; + +exports.runST = function (f) { + return f; +}; diff --git a/tests/support/flattened/Control-Monad-ST.purs b/tests/support/flattened/Control-Monad-ST.purs new file mode 100644 index 0000000000..ac113e58a0 --- /dev/null +++ b/tests/support/flattened/Control-Monad-ST.purs @@ -0,0 +1,42 @@ +module Control.Monad.ST where + +import Prelude + +import Control.Monad.Eff (Eff(), runPure) + +-- | The `ST` effect represents _local mutation_, i.e. mutation which does not "escape" into the surrounding computation. +-- | +-- | An `ST` computation is parameterized by a phantom type which is used to restrict the set of reference cells it is allowed to access. +-- | +-- | The `runST` function can be used to handle the `ST` effect. +foreign import data ST :: * -> ! + +-- | The type `STRef s a` represents a mutable reference holding a value of type `a`, which can be used with the `ST s` effect. +foreign import data STRef :: * -> * -> * + +-- | Create a new mutable reference. +foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a) + +-- | Read the current value of a mutable reference. +foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a + +-- | Modify the value of a mutable reference by applying a function to the current value. +foreign import modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a + +-- | Set the value of a mutable reference. +foreign import writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a + +-- | Run an `ST` computation. +-- | +-- | Note: the type of `runST` uses a rank-2 type to constrain the phantom type `s`, such that the computation must not leak any mutable references +-- | to the surrounding computation. +-- | +-- | It may cause problems to apply this function using the `$` operator. The recommended approach is to use parentheses instead. +foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a + +-- | A convenience function which combines `runST` with `runPure`, which can be used when the only required effect is `ST`. +-- | +-- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach +-- | is to use parentheses instead. +pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a +pureST st = runPure (runST st) diff --git a/tests/support/flattened/Data-Function.js b/tests/support/flattened/Data-Function.js new file mode 100644 index 0000000000..0d6d0f4ede --- /dev/null +++ b/tests/support/flattened/Data-Function.js @@ -0,0 +1,233 @@ +/* global exports */ +"use strict"; + +// module Data.Function + +exports.mkFn0 = function (fn) { + return function () { + return fn({}); + }; +}; + +exports.mkFn1 = function (fn) { + return function (a) { + return fn(a); + }; +}; + +exports.mkFn2 = function (fn) { + /* jshint maxparams: 2 */ + return function (a, b) { + return fn(a)(b); + }; +}; + +exports.mkFn3 = function (fn) { + /* jshint maxparams: 3 */ + return function (a, b, c) { + return fn(a)(b)(c); + }; +}; + +exports.mkFn4 = function (fn) { + /* jshint maxparams: 4 */ + return function (a, b, c, d) { + return fn(a)(b)(c)(d); + }; +}; + +exports.mkFn5 = function (fn) { + /* jshint maxparams: 5 */ + return function (a, b, c, d, e) { + return fn(a)(b)(c)(d)(e); + }; +}; + +exports.mkFn6 = function (fn) { + /* jshint maxparams: 6 */ + return function (a, b, c, d, e, f) { + return fn(a)(b)(c)(d)(e)(f); + }; +}; + +exports.mkFn7 = function (fn) { + /* jshint maxparams: 7 */ + return function (a, b, c, d, e, f, g) { + return fn(a)(b)(c)(d)(e)(f)(g); + }; +}; + +exports.mkFn8 = function (fn) { + /* jshint maxparams: 8 */ + return function (a, b, c, d, e, f, g, h) { + return fn(a)(b)(c)(d)(e)(f)(g)(h); + }; +}; + +exports.mkFn9 = function (fn) { + /* jshint maxparams: 9 */ + return function (a, b, c, d, e, f, g, h, i) { + return fn(a)(b)(c)(d)(e)(f)(g)(h)(i); + }; +}; + +exports.mkFn10 = function (fn) { + /* jshint maxparams: 10 */ + return function (a, b, c, d, e, f, g, h, i, j) { + return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j); + }; +}; + +exports.runFn0 = function (fn) { + return fn(); +}; + +exports.runFn1 = function (fn) { + return function (a) { + return fn(a); + }; +}; + +exports.runFn2 = function (fn) { + return function (a) { + return function (b) { + return fn(a, b); + }; + }; +}; + +exports.runFn3 = function (fn) { + return function (a) { + return function (b) { + return function (c) { + return fn(a, b, c); + }; + }; + }; +}; + +exports.runFn4 = function (fn) { + return function (a) { + return function (b) { + return function (c) { + return function (d) { + return fn(a, b, c, d); + }; + }; + }; + }; +}; + +exports.runFn5 = function (fn) { + return function (a) { + return function (b) { + return function (c) { + return function (d) { + return function (e) { + return fn(a, b, c, d, e); + }; + }; + }; + }; + }; +}; + +exports.runFn6 = function (fn) { + return function (a) { + return function (b) { + return function (c) { + return function (d) { + return function (e) { + return function (f) { + return fn(a, b, c, d, e, f); + }; + }; + }; + }; + }; + }; +}; + +exports.runFn7 = function (fn) { + return function (a) { + return function (b) { + return function (c) { + return function (d) { + return function (e) { + return function (f) { + return function (g) { + return fn(a, b, c, d, e, f, g); + }; + }; + }; + }; + }; + }; + }; +}; + +exports.runFn8 = function (fn) { + return function (a) { + return function (b) { + return function (c) { + return function (d) { + return function (e) { + return function (f) { + return function (g) { + return function (h) { + return fn(a, b, c, d, e, f, g, h); + }; + }; + }; + }; + }; + }; + }; + }; +}; + +exports.runFn9 = function (fn) { + return function (a) { + return function (b) { + return function (c) { + return function (d) { + return function (e) { + return function (f) { + return function (g) { + return function (h) { + return function (i) { + return fn(a, b, c, d, e, f, g, h, i); + }; + }; + }; + }; + }; + }; + }; + }; + }; +}; + +exports.runFn10 = function (fn) { + return function (a) { + return function (b) { + return function (c) { + return function (d) { + return function (e) { + return function (f) { + return function (g) { + return function (h) { + return function (i) { + return function (j) { + return fn(a, b, c, d, e, f, g, h, i, j); + }; + }; + }; + }; + }; + }; + }; + }; + }; + }; +}; diff --git a/tests/support/flattened/Data-Function.purs b/tests/support/flattened/Data-Function.purs new file mode 100644 index 0000000000..37ceca1aa0 --- /dev/null +++ b/tests/support/flattened/Data-Function.purs @@ -0,0 +1,113 @@ +module Data.Function where + +import Prelude + +-- | The `on` function is used to change the domain of a binary operator. +-- | +-- | For example, we can create a function which compares two records based on the values of their `x` properties: +-- | +-- | ```purescript +-- | compareX :: forall r. { x :: Number | r } -> { x :: Number | r } -> Ordering +-- | compareX = compare `on` _.x +-- | ``` +on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c +on f g x y = g x `f` g y + +-- | A function of zero arguments +foreign import data Fn0 :: * -> * + +-- | A function of one argument +foreign import data Fn1 :: * -> * -> * + +-- | A function of two arguments +foreign import data Fn2 :: * -> * -> * -> * + +-- | A function of three arguments +foreign import data Fn3 :: * -> * -> * -> * -> * + +-- | A function of four arguments +foreign import data Fn4 :: * -> * -> * -> * -> * -> * + +-- | A function of five arguments +foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> * + +-- | A function of six arguments +foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> * + +-- | A function of seven arguments +foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> * + +-- | A function of eight arguments +foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * + +-- | A function of nine arguments +foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * + +-- | A function of ten arguments +foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * + +-- | Create a function of no arguments +foreign import mkFn0 :: forall a. (Unit -> a) -> Fn0 a + +-- | Create a function of one argument +foreign import mkFn1 :: forall a b. (a -> b) -> Fn1 a b + +-- | Create a function of two arguments from a curried function +foreign import mkFn2 :: forall a b c. (a -> b -> c) -> Fn2 a b c + +-- | Create a function of three arguments from a curried function +foreign import mkFn3 :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d + +-- | Create a function of four arguments from a curried function +foreign import mkFn4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e + +-- | Create a function of five arguments from a curried function +foreign import mkFn5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f + +-- | Create a function of six arguments from a curried function +foreign import mkFn6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g + +-- | Create a function of seven arguments from a curried function +foreign import mkFn7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h + +-- | Create a function of eight arguments from a curried function +foreign import mkFn8 :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i + +-- | Create a function of nine arguments from a curried function +foreign import mkFn9 :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j + +-- | Create a function of ten arguments from a curried function +foreign import mkFn10 :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k + +-- | Apply a function of no arguments +foreign import runFn0 :: forall a. Fn0 a -> a + +-- | Apply a function of one argument +foreign import runFn1 :: forall a b. Fn1 a b -> a -> b + +-- | Apply a function of two arguments +foreign import runFn2 :: forall a b c. Fn2 a b c -> a -> b -> c + +-- | Apply a function of three arguments +foreign import runFn3 :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d + +-- | Apply a function of four arguments +foreign import runFn4 :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e + +-- | Apply a function of five arguments +foreign import runFn5 :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f + +-- | Apply a function of six arguments +foreign import runFn6 :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g + +-- | Apply a function of seven arguments +foreign import runFn7 :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h + +-- | Apply a function of eight arguments +foreign import runFn8 :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i + +-- | Apply a function of nine arguments +foreign import runFn9 :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j + +-- | Apply a function of ten arguments +foreign import runFn10 :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k diff --git a/tests/support/flattened/Prelude.js b/tests/support/flattened/Prelude.js new file mode 100644 index 0000000000..72a855a76c --- /dev/null +++ b/tests/support/flattened/Prelude.js @@ -0,0 +1,228 @@ +/* global exports */ +"use strict"; + +// module Prelude + +//- Functor -------------------------------------------------------------------- + +exports.arrayMap = function (f) { + return function (arr) { + var l = arr.length; + var result = new Array(l); + for (var i = 0; i < l; i++) { + result[i] = f(arr[i]); + } + return result; + }; +}; + +//- Bind ----------------------------------------------------------------------- + +exports.arrayBind = function (arr) { + return function (f) { + var result = []; + for (var i = 0, l = arr.length; i < l; i++) { + Array.prototype.push.apply(result, f(arr[i])); + } + return result; + }; +}; + +//- Monoid --------------------------------------------------------------------- + +exports.concatString = function (s1) { + return function (s2) { + return s1 + s2; + }; +}; + +exports.concatArray = function (xs) { + return function (ys) { + return xs.concat(ys); + }; +}; + +//- Semiring ------------------------------------------------------------------- + +exports.intAdd = function (x) { + return function (y) { + /* jshint bitwise: false */ + return x + y | 0; + }; +}; + +exports.intMul = function (x) { + return function (y) { + /* jshint bitwise: false */ + return x * y | 0; + }; +}; + +exports.numAdd = function (n1) { + return function (n2) { + return n1 + n2; + }; +}; + +exports.numMul = function (n1) { + return function (n2) { + return n1 * n2; + }; +}; + +//- ModuloSemiring ------------------------------------------------------------- + +exports.intDiv = function (x) { + return function (y) { + /* jshint bitwise: false */ + return x / y | 0; + }; +}; + +exports.intMod = function (x) { + return function (y) { + return x % y; + }; +}; + +exports.numDiv = function (n1) { + return function (n2) { + return n1 / n2; + }; +}; + +//- Ring ----------------------------------------------------------------------- + +exports.intSub = function (x) { + return function (y) { + /* jshint bitwise: false */ + return x - y | 0; + }; +}; + +exports.numSub = function (n1) { + return function (n2) { + return n1 - n2; + }; +}; + +//- Eq ------------------------------------------------------------------------- + +exports.refEq = function (r1) { + return function (r2) { + return r1 === r2; + }; +}; + +exports.refIneq = function (r1) { + return function (r2) { + return r1 !== r2; + }; +}; + +exports.eqArrayImpl = function (f) { + return function (xs) { + return function (ys) { + if (xs.length !== ys.length) return false; + for (var i = 0; i < xs.length; i++) { + if (!f(xs[i])(ys[i])) return false; + } + return true; + }; + }; +}; + +exports.ordArrayImpl = function (f) { + return function (xs) { + return function (ys) { + var i = 0; + var xlen = xs.length; + var ylen = ys.length; + while (i < xlen && i < ylen) { + var x = xs[i]; + var y = ys[i]; + var o = f(x)(y); + if (o !== 0) { + return o; + } + i++; + } + if (xlen === ylen) { + return 0; + } else if (xlen > ylen) { + return -1; + } else { + return 1; + } + }; + }; +}; + +//- Ord ------------------------------------------------------------------------ + +exports.unsafeCompareImpl = function (lt) { + return function (eq) { + return function (gt) { + return function (x) { + return function (y) { + return x < y ? lt : x > y ? gt : eq; + }; + }; + }; + }; +}; + +//- Bounded -------------------------------------------------------------------- + +exports.topInt = 2147483647; +exports.bottomInt = -2147483648; + +exports.topChar = String.fromCharCode(65535); +exports.bottomChar = String.fromCharCode(0); + +//- BooleanAlgebra ------------------------------------------------------------- + +exports.boolOr = function (b1) { + return function (b2) { + return b1 || b2; + }; +}; + +exports.boolAnd = function (b1) { + return function (b2) { + return b1 && b2; + }; +}; + +exports.boolNot = function (b) { + return !b; +}; + +//- Show ----------------------------------------------------------------------- + +exports.showIntImpl = function (n) { + return n.toString(); +}; + +exports.showNumberImpl = function (n) { + /* jshint bitwise: false */ + return n === (n | 0) ? n + ".0" : n.toString(); +}; + +exports.showCharImpl = function (c) { + return c === "'" ? "'\\''" : "'" + c + "'"; +}; + +exports.showStringImpl = function (s) { + return JSON.stringify(s); +}; + +exports.showArrayImpl = function (f) { + return function (xs) { + var ss = []; + for (var i = 0, l = xs.length; i < l; i++) { + ss[i] = f(xs[i]); + } + return "[" + ss.join(",") + "]"; + }; +}; diff --git a/tests/support/flattened/Prelude.purs b/tests/support/flattened/Prelude.purs new file mode 100644 index 0000000000..21ec9095fa --- /dev/null +++ b/tests/support/flattened/Prelude.purs @@ -0,0 +1,872 @@ +module Prelude + ( Unit(), unit + , ($), (#) + , flip + , const + , asTypeOf + , otherwise + , Semigroupoid, compose, (<<<), (>>>) + , Category, id + , Functor, map, (<$>), (<#>), void + , Apply, apply, (<*>) + , Applicative, pure, liftA1 + , Bind, bind, (>>=) + , Monad, return, liftM1, ap + , Semigroup, append, (<>), (++) + , Semiring, add, zero, mul, one, (+), (*) + , ModuloSemiring, div, mod, (/) + , Ring, sub, negate, (-) + , Num + , DivisionRing + , Eq, eq, (==), (/=) + , Ordering(..), Ord, compare, (<), (>), (<=), (>=) + , unsafeCompare + , Bounded, top, bottom + , BoundedOrd + , BooleanAlgebra, conj, disj, not, (&&), (||) + , Show, show + ) where + +-- | The `Unit` type has a single inhabitant, called `unit`. It represents +-- | values with no computational content. +-- | +-- | `Unit` is often used, wrapped in a monadic type constructor, as the +-- | return type of a computation where only +-- | the _effects_ are important. +newtype Unit = Unit {} + +-- | `unit` is the sole inhabitant of the `Unit` type. +unit :: Unit +unit = Unit {} + +infixr 0 $ +infixl 1 # + +-- | Applies a function to its argument. +-- | +-- | ```purescript +-- | length $ groupBy productCategory $ filter isInStock $ products +-- | ``` +-- | +-- | is equivalent to: +-- | +-- | ```purescript +-- | length (groupBy productCategory (filter isInStock products)) +-- | ``` +-- | +-- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of +-- | left: `a $ b $ c $ d x = a $ (b $ (c $ (d $ x))) = a (b (c (d x)))` +($) :: forall a b. (a -> b) -> a -> b +($) f x = f x + +-- | Applies an argument to a function. +-- | +-- | ```purescript +-- | products # filter isInStock # groupBy productCategory # length +-- | ``` +-- | +-- | is equivalent to: +-- | +-- | ```purescript +-- | length (groupBy productCategory (filter isInStock products)) +-- | ``` +-- | +-- | `(#)` is different from [`($)`](#-1) because it is left-infix instead of +-- | right: `x # a # b # c # d = (((x # a) # b) # c) # d = d (c (b (a x)))` +(#) :: forall a b. a -> (a -> b) -> b +(#) x f = f x + +-- | Flips the order of the arguments to a function of two arguments. +-- | +-- | ```purescript +-- | flip const 1 2 = const 2 1 = 2 +-- | ``` +flip :: forall a b c. (a -> b -> c) -> b -> a -> c +flip f b a = f a b + +-- | Returns its first argument and ignores its second. +-- | +-- | ```purescript +-- | const 1 "hello" = 1 +-- | ``` +const :: forall a b. a -> b -> a +const a _ = a + +-- | This function returns its first argument, and can be used to assert type +-- | equalities. This can be useful when types are otherwise ambiguous. +-- | +-- | ```purescript +-- | main = print $ [] `asTypeOf` [0] +-- | ``` +-- | +-- | If instead, we had written `main = print []`, the type of the argument +-- | `[]` would have been ambiguous, resulting in a compile-time error. +asTypeOf :: forall a. a -> a -> a +asTypeOf x _ = x + +-- | An alias for `true`, which can be useful in guard clauses: +-- | +-- | ```purescript +-- | max x y | x >= y = x +-- | | otherwise = y +-- | ``` +otherwise :: Boolean +otherwise = true + +-- | A `Semigroupoid` is similar to a [`Category`](#category) but does not +-- | require an identity element `id`, just composable morphisms. +-- | +-- | `Semigroupoid`s must satisfy the following law: +-- | +-- | - Associativity: `p <<< (q <<< r) = (p <<< q) <<< r` +-- | +-- | One example of a `Semigroupoid` is the function type constructor `(->)`, +-- | with `(<<<)` defined as function composition. +class Semigroupoid a where + compose :: forall b c d. a c d -> a b c -> a b d + +instance semigroupoidFn :: Semigroupoid (->) where + compose f g x = f (g x) + +infixr 9 >>> +infixr 9 <<< + +-- | `(<<<)` is an alias for `compose`. +(<<<) :: forall a b c d. (Semigroupoid a) => a c d -> a b c -> a b d +(<<<) = compose + +-- | Forwards composition, or `(<<<)` with its arguments reversed. +(>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d +(>>>) = flip compose + +-- | `Category`s consist of objects and composable morphisms between them, and +-- | as such are [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids` +-- | must have an identity element. +-- | +-- | Instances must satisfy the following law in addition to the +-- | `Semigroupoid` law: +-- | +-- | - Identity: `id <<< p = p <<< id = p` +class (Semigroupoid a) <= Category a where + id :: forall t. a t t + +instance categoryFn :: Category (->) where + id x = x + +-- | A `Functor` is a type constructor which supports a mapping operation +-- | `(<$>)`. +-- | +-- | `(<$>)` can be used to turn functions `a -> b` into functions +-- | `f a -> f b` whose argument and return types use the type constructor `f` +-- | to represent some computational context. +-- | +-- | Instances must satisfy the following laws: +-- | +-- | - Identity: `(<$>) id = id` +-- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)` +class Functor f where + map :: forall a b. (a -> b) -> f a -> f b + +instance functorFn :: Functor ((->) r) where + map = compose + +instance functorArray :: Functor Array where + map = arrayMap + +foreign import arrayMap :: forall a b. (a -> b) -> Array a -> Array b + +infixl 4 <$> +infixl 1 <#> + +-- | `(<$>)` is an alias for `map` +(<$>) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b +(<$>) = map + +-- | `(<#>)` is `(<$>)` with its arguments reversed. For example: +-- | +-- | ```purescript +-- | [1, 2, 3] <#> \n -> n * n +-- | ``` +(<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b +(<#>) fa f = f <$> fa + +-- | The `void` function is used to ignore the type wrapped by a +-- | [`Functor`](#functor), replacing it with `Unit` and keeping only the type +-- | information provided by the type constructor itself. +-- | +-- | `void` is often useful when using `do` notation to change the return type +-- | of a monadic computation: +-- | +-- | ```purescript +-- | main = forE 1 10 \n -> void do +-- | print n +-- | print (n * n) +-- | ``` +void :: forall f a. (Functor f) => f a -> f Unit +void fa = const unit <$> fa + +-- | The `Apply` class provides the `(<*>)` which is used to apply a function +-- | to an argument under a type constructor. +-- | +-- | `Apply` can be used to lift functions of two or more arguments to work on +-- | values wrapped with the type constructor `f`. It might also be understood +-- | in terms of the `lift2` function: +-- | +-- | ```purescript +-- | lift2 :: forall f a b c. (Apply f) => (a -> b -> c) -> f a -> f b -> f c +-- | lift2 f a b = f <$> a <*> b +-- | ``` +-- | +-- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts +-- | the function application operator `($)` to arguments wrapped with the +-- | type constructor `f`. +-- | +-- | Instances must satisfy the following law in addition to the `Functor` +-- | laws: +-- | +-- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)` +-- | +-- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor. +class (Functor f) <= Apply f where + apply :: forall a b. f (a -> b) -> f a -> f b + +instance applyFn :: Apply ((->) r) where + apply f g x = f x (g x) + +instance applyArray :: Apply Array where + apply = ap + +infixl 4 <*> + +-- | `(<*>)` is an alias for `apply`. +(<*>) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b +(<*>) = apply + +-- | The `Applicative` type class extends the [`Apply`](#apply) type class +-- | with a `pure` function, which can be used to create values of type `f a` +-- | from values of type `a`. +-- | +-- | Where [`Apply`](#apply) provides the ability to lift functions of two or +-- | more arguments to functions whose arguments are wrapped using `f`, and +-- | [`Functor`](#functor) provides the ability to lift functions of one +-- | argument, `pure` can be seen as the function which lifts functions of +-- | _zero_ arguments. That is, `Applicative` functors support a lifting +-- | operation for any number of function arguments. +-- | +-- | Instances must satisfy the following laws in addition to the `Apply` +-- | laws: +-- | +-- | - Identity: `(pure id) <*> v = v` +-- | - Composition: `(pure <<<) <*> f <*> g <*> h = f <*> (g <*> h)` +-- | - Homomorphism: `(pure f) <*> (pure x) = pure (f x)` +-- | - Interchange: `u <*> (pure y) = (pure ($ y)) <*> u` +class (Apply f) <= Applicative f where + pure :: forall a. a -> f a + +instance applicativeFn :: Applicative ((->) r) where + pure = const + +instance applicativeArray :: Applicative Array where + pure x = [x] + +-- | `return` is an alias for `pure`. +return :: forall m a. (Applicative m) => a -> m a +return = pure + +-- | `liftA1` provides a default implementation of `(<$>)` for any +-- | [`Applicative`](#applicative) functor, without using `(<$>)` as provided +-- | by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass +-- | relationship. +-- | +-- | `liftA1` can therefore be used to write [`Functor`](#functor) instances +-- | as follows: +-- | +-- | ```purescript +-- | instance functorF :: Functor F where +-- | map = liftA1 +-- | ``` +liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b +liftA1 f a = pure f <*> a + +-- | The `Bind` type class extends the [`Apply`](#apply) type class with a +-- | "bind" operation `(>>=)` which composes computations in sequence, using +-- | the return value of one computation to determine the next computation. +-- | +-- | The `>>=` operator can also be expressed using `do` notation, as follows: +-- | +-- | ```purescript +-- | x >>= f = do y <- x +-- | f y +-- | ``` +-- | +-- | where the function argument of `f` is given the name `y`. +-- | +-- | Instances must satisfy the following law in addition to the `Apply` +-- | laws: +-- | +-- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)` +-- | +-- | Associativity tells us that we can regroup operations which use `do` +-- | notation so that we can unambiguously write, for example: +-- | +-- | ```purescript +-- | do x <- m1 +-- | y <- m2 x +-- | m3 x y +-- | ``` +class (Apply m) <= Bind m where + bind :: forall a b. m a -> (a -> m b) -> m b + +instance bindFn :: Bind ((->) r) where + bind m f x = f (m x) x + +instance bindArray :: Bind Array where + bind = arrayBind + +foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b + +infixl 1 >>= + +-- | `(>>=)` is an alias for `bind`. +(>>=) :: forall m a b. (Bind m) => m a -> (a -> m b) -> m b +(>>=) = bind + +-- | The `Monad` type class combines the operations of the `Bind` and +-- | `Applicative` type classes. Therefore, `Monad` instances represent type +-- | constructors which support sequential composition, and also lifting of +-- | functions of arbitrary arity. +-- | +-- | Instances must satisfy the following laws in addition to the +-- | `Applicative` and `Bind` laws: +-- | +-- | - Left Identity: `pure x >>= f = f x` +-- | - Right Identity: `x >>= pure = x` +class (Applicative m, Bind m) <= Monad m + +instance monadFn :: Monad ((->) r) +instance monadArray :: Monad Array + +-- | `liftM1` provides a default implementation of `(<$>)` for any +-- | [`Monad`](#monad), without using `(<$>)` as provided by the +-- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship. +-- | +-- | `liftM1` can therefore be used to write [`Functor`](#functor) instances +-- | as follows: +-- | +-- | ```purescript +-- | instance functorF :: Functor F where +-- | map = liftM1 +-- | ``` +liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b +liftM1 f a = do + a' <- a + return (f a') + +-- | `ap` provides a default implementation of `(<*>)` for any +-- | [`Monad`](#monad), without using `(<*>)` as provided by the +-- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship. +-- | +-- | `ap` can therefore be used to write [`Apply`](#apply) instances as +-- | follows: +-- | +-- | ```purescript +-- | instance applyF :: Apply F where +-- | apply = ap +-- | ``` +ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b +ap f a = do + f' <- f + a' <- a + return (f' a') + +-- | The `Semigroup` type class identifies an associative operation on a type. +-- | +-- | Instances are required to satisfy the following law: +-- | +-- | - Associativity: `(x <> y) <> z = x <> (y <> z)` +-- | +-- | One example of a `Semigroup` is `String`, with `(<>)` defined as string +-- | concatenation. +class Semigroup a where + append :: a -> a -> a + +infixr 5 <> +infixr 5 ++ + +-- | `(<>)` is an alias for `append`. +(<>) :: forall s. (Semigroup s) => s -> s -> s +(<>) = append + +-- | `(++)` is an alternative alias for `append`. +(++) :: forall s. (Semigroup s) => s -> s -> s +(++) = append + +instance semigroupString :: Semigroup String where + append = concatString + +instance semigroupUnit :: Semigroup Unit where + append _ _ = unit + +instance semigroupFn :: (Semigroup s') => Semigroup (s -> s') where + append f g = \x -> f x <> g x + +instance semigroupOrdering :: Semigroup Ordering where + append LT _ = LT + append GT _ = GT + append EQ y = y + +instance semigroupArray :: Semigroup (Array a) where + append = concatArray + +foreign import concatString :: String -> String -> String +foreign import concatArray :: forall a. Array a -> Array a -> Array a + +-- | The `Semiring` class is for types that support an addition and +-- | multiplication operation. +-- | +-- | Instances must satisfy the following laws: +-- | +-- | - Commutative monoid under addition: +-- | - Associativity: `(a + b) + c = a + (b + c)` +-- | - Identity: `zero + a = a + zero = a` +-- | - Commutative: `a + b = b + a` +-- | - Monoid under multiplication: +-- | - Associativity: `(a * b) * c = a * (b * c)` +-- | - Identity: `one * a = a * one = a` +-- | - Multiplication distributes over addition: +-- | - Left distributivity: `a * (b + c) = (a * b) + (a * c)` +-- | - Right distributivity: `(a + b) * c = (a * c) + (b * c)` +-- | - Annihiliation: `zero * a = a * zero = zero` +class Semiring a where + add :: a -> a -> a + zero :: a + mul :: a -> a -> a + one :: a + +instance semiringInt :: Semiring Int where + add = intAdd + zero = 0 + mul = intMul + one = 1 + +instance semiringNumber :: Semiring Number where + add = numAdd + zero = 0.0 + mul = numMul + one = 1.0 + +instance semiringUnit :: Semiring Unit where + add _ _ = unit + zero = unit + mul _ _ = unit + one = unit + +infixl 6 + +infixl 7 * + +-- | `(+)` is an alias for `add`. +(+) :: forall a. (Semiring a) => a -> a -> a +(+) = add + +-- | `(*)` is an alias for `mul`. +(*) :: forall a. (Semiring a) => a -> a -> a +(*) = mul + +foreign import intAdd :: Int -> Int -> Int +foreign import intMul :: Int -> Int -> Int +foreign import numAdd :: Number -> Number -> Number +foreign import numMul :: Number -> Number -> Number + +-- | The `Ring` class is for types that support addition, multiplication, +-- | and subtraction operations. +-- | +-- | Instances must satisfy the following law in addition to the `Semiring` +-- | laws: +-- | +-- | - Additive inverse: `a - a = (zero - a) + a = zero` +class (Semiring a) <= Ring a where + sub :: a -> a -> a + +instance ringInt :: Ring Int where + sub = intSub + +instance ringNumber :: Ring Number where + sub = numSub + +instance ringUnit :: Ring Unit where + sub _ _ = unit + +infixl 6 - + +-- | `(-)` is an alias for `sub`. +(-) :: forall a. (Ring a) => a -> a -> a +(-) = sub + +-- | `negate x` can be used as a shorthand for `zero - x`. +negate :: forall a. (Ring a) => a -> a +negate a = zero - a + +foreign import intSub :: Int -> Int -> Int +foreign import numSub :: Number -> Number -> Number + +-- | The `ModuloSemiring` class is for types that support addition, +-- | multiplication, division, and modulo (division remainder) operations. +-- | +-- | Instances must satisfy the following law in addition to the `Semiring` +-- | laws: +-- | +-- | - Remainder: ``a / b * b + (a `mod` b) = a`` +class (Semiring a) <= ModuloSemiring a where + div :: a -> a -> a + mod :: a -> a -> a + +instance moduloSemiringInt :: ModuloSemiring Int where + div = intDiv + mod = intMod + +instance moduloSemiringNumber :: ModuloSemiring Number where + div = numDiv + mod _ _ = 0.0 + +instance moduloSemiringUnit :: ModuloSemiring Unit where + div _ _ = unit + mod _ _ = unit + +infixl 7 / + +-- | `(/)` is an alias for `div`. +(/) :: forall a. (ModuloSemiring a) => a -> a -> a +(/) = div + +foreign import intDiv :: Int -> Int -> Int +foreign import numDiv :: Number -> Number -> Number +foreign import intMod :: Int -> Int -> Int + +-- | A `Ring` where every nonzero element has a multiplicative inverse. +-- | +-- | Instances must satisfy the following law in addition to the `Ring` and +-- | `ModuloSemiring` laws: +-- | +-- | - Multiplicative inverse: `(one / x) * x = one` +-- | +-- | As a consequence of this ```a `mod` b = zero``` as no divide operation +-- | will have a remainder. +class (Ring a, ModuloSemiring a) <= DivisionRing a + +instance divisionRingNumber :: DivisionRing Number +instance divisionRingUnit :: DivisionRing Unit + +-- | The `Num` class is for types that are commutative fields. +-- | +-- | Instances must satisfy the following law in addition to the +-- | `DivisionRing` laws: +-- | +-- | - Commutative multiplication: `a * b = b * a` +class (DivisionRing a) <= Num a + +instance numNumber :: Num Number +instance numUnit :: Num Unit + +-- | The `Eq` type class represents types which support decidable equality. +-- | +-- | `Eq` instances should satisfy the following laws: +-- | +-- | - Reflexivity: `x == x = true` +-- | - Symmetry: `x == y = y == x` +-- | - Transitivity: if `x == y` and `y == z` then `x == z` +class Eq a where + eq :: a -> a -> Boolean + +infix 4 == +infix 4 /= + +-- | `(==)` is an alias for `eq`. Tests whether one value is equal to another. +(==) :: forall a. (Eq a) => a -> a -> Boolean +(==) = eq + +-- | `(/=)` tests whether one value is _not equal_ to another. Shorthand for +-- | `not (x == y)`. +(/=) :: forall a. (Eq a) => a -> a -> Boolean +(/=) x y = not (x == y) + +instance eqBoolean :: Eq Boolean where + eq = refEq + +instance eqInt :: Eq Int where + eq = refEq + +instance eqNumber :: Eq Number where + eq = refEq + +instance eqChar :: Eq Char where + eq = refEq + +instance eqString :: Eq String where + eq = refEq + +instance eqUnit :: Eq Unit where + eq _ _ = true + +instance eqArray :: (Eq a) => Eq (Array a) where + eq = eqArrayImpl (==) + +instance eqOrdering :: Eq Ordering where + eq LT LT = true + eq GT GT = true + eq EQ EQ = true + eq _ _ = false + +foreign import refEq :: forall a. a -> a -> Boolean +foreign import refIneq :: forall a. a -> a -> Boolean +foreign import eqArrayImpl :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Boolean + +-- | The `Ordering` data type represents the three possible outcomes of +-- | comparing two values: +-- | +-- | `LT` - The first value is _less than_ the second. +-- | `GT` - The first value is _greater than_ the second. +-- | `EQ` - The first value is _equal to_ the second. +data Ordering = LT | GT | EQ + +-- | The `Ord` type class represents types which support comparisons with a +-- | _total order_. +-- | +-- | `Ord` instances should satisfy the laws of total orderings: +-- | +-- | - Reflexivity: `a <= a` +-- | - Antisymmetry: if `a <= b` and `b <= a` then `a = b` +-- | - Transitivity: if `a <= b` and `b <= c` then `a <= c` +class (Eq a) <= Ord a where + compare :: a -> a -> Ordering + +instance ordBoolean :: Ord Boolean where + compare = unsafeCompare + +instance ordInt :: Ord Int where + compare = unsafeCompare + +instance ordNumber :: Ord Number where + compare = unsafeCompare + +instance ordString :: Ord String where + compare = unsafeCompare + +instance ordChar :: Ord Char where + compare = unsafeCompare + +instance ordUnit :: Ord Unit where + compare _ _ = EQ + +instance ordArray :: (Ord a) => Ord (Array a) where + compare xs ys = compare 0 $ ordArrayImpl (\x y -> case compare x y of + EQ -> 0 + LT -> 1 + GT -> -1) xs ys + +foreign import ordArrayImpl :: forall a. (a -> a -> Int) -> Array a -> Array a -> Int + +instance ordOrdering :: Ord Ordering where + compare LT LT = EQ + compare EQ EQ = EQ + compare GT GT = EQ + compare LT _ = LT + compare EQ LT = GT + compare EQ GT = LT + compare GT _ = GT + +infixl 4 < +infixl 4 > +infixl 4 <= +infixl 4 >= + +-- | Test whether one value is _strictly less than_ another. +(<) :: forall a. (Ord a) => a -> a -> Boolean +(<) a1 a2 = case a1 `compare` a2 of + LT -> true + _ -> false + +-- | Test whether one value is _strictly greater than_ another. +(>) :: forall a. (Ord a) => a -> a -> Boolean +(>) a1 a2 = case a1 `compare` a2 of + GT -> true + _ -> false + +-- | Test whether one value is _non-strictly less than_ another. +(<=) :: forall a. (Ord a) => a -> a -> Boolean +(<=) a1 a2 = case a1 `compare` a2 of + GT -> false + _ -> true + +-- | Test whether one value is _non-strictly greater than_ another. +(>=) :: forall a. (Ord a) => a -> a -> Boolean +(>=) a1 a2 = case a1 `compare` a2 of + LT -> false + _ -> true + +unsafeCompare :: forall a. a -> a -> Ordering +unsafeCompare = unsafeCompareImpl LT EQ GT + +foreign import unsafeCompareImpl :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering + +-- | The `Bounded` type class represents types that are finite. +-- | +-- | Although there are no "internal" laws for `Bounded`, every value of `a` +-- | should be considered less than or equal to `top` by some means, and greater +-- | than or equal to `bottom`. +-- | +-- | The lack of explicit `Ord` constraint allows flexibility in the use of +-- | `Bounded` so it can apply to total and partially ordered sets, boolean +-- | algebras, etc. +class Bounded a where + top :: a + bottom :: a + +instance boundedBoolean :: Bounded Boolean where + top = true + bottom = false + +instance boundedUnit :: Bounded Unit where + top = unit + bottom = unit + +instance boundedOrdering :: Bounded Ordering where + top = GT + bottom = LT + +instance boundedInt :: Bounded Int where + top = topInt + bottom = bottomInt + +-- | Characters fall within the Unicode range. +instance boundedChar :: Bounded Char where + top = topChar + bottom = bottomChar + +instance boundedFn :: (Bounded b) => Bounded (a -> b) where + top _ = top + bottom _ = bottom + +foreign import topInt :: Int +foreign import bottomInt :: Int + +foreign import topChar :: Char +foreign import bottomChar :: Char + +-- | The `BoundedOrd` type class represents totally ordered finite data types. +-- | +-- | Instances should satisfy the following law in addition to the `Ord` laws: +-- | +-- | - Ordering: `bottom <= a <= top` +class (Bounded a, Ord a) <= BoundedOrd a + +instance boundedOrdBoolean :: BoundedOrd Boolean where +instance boundedOrdUnit :: BoundedOrd Unit where +instance boundedOrdOrdering :: BoundedOrd Ordering where +instance boundedOrdInt :: BoundedOrd Int where +instance boundedOrdChar :: BoundedOrd Char where + +-- | The `BooleanAlgebra` type class represents types that behave like boolean +-- | values. +-- | +-- | Instances should satisfy the following laws in addition to the `Bounded` +-- | laws: +-- | +-- | - Associativity: +-- | - `a || (b || c) = (a || b) || c` +-- | - `a && (b && c) = (a && b) && c` +-- | - Commutativity: +-- | - `a || b = b || a` +-- | - `a && b = b && a` +-- | - Distributivity: +-- | - `a && (b || c) = (a && b) || (a && c)` +-- | - `a || (b && c) = (a || b) && (a || c)` +-- | - Identity: +-- | - `a || bottom = a` +-- | - `a && top = a` +-- | - Idempotent: +-- | - `a || a = a` +-- | - `a && a = a` +-- | - Absorption: +-- | - `a || (a && b) = a` +-- | - `a && (a || b) = a` +-- | - Annhiliation: +-- | - `a || top = top` +-- | - Complementation: +-- | - `a && not a = bottom` +-- | - `a || not a = top` +class (Bounded a) <= BooleanAlgebra a where + conj :: a -> a -> a + disj :: a -> a -> a + not :: a -> a + +instance booleanAlgebraBoolean :: BooleanAlgebra Boolean where + conj = boolAnd + disj = boolOr + not = boolNot + +instance booleanAlgebraUnit :: BooleanAlgebra Unit where + conj _ _ = unit + disj _ _ = unit + not _ = unit + +instance booleanAlgebraFn :: (BooleanAlgebra b) => BooleanAlgebra (a -> b) where + conj fx fy a = fx a `conj` fy a + disj fx fy a = fx a `disj` fy a + not fx a = not (fx a) + +infixr 3 && +infixr 2 || + +-- | `(&&)` is an alias for `conj`. +(&&) :: forall a. (BooleanAlgebra a) => a -> a -> a +(&&) = conj + +-- | `(||)` is an alias for `disj`. +(||) :: forall a. (BooleanAlgebra a) => a -> a -> a +(||) = disj + +foreign import boolOr :: Boolean -> Boolean -> Boolean +foreign import boolAnd :: Boolean -> Boolean -> Boolean +foreign import boolNot :: Boolean -> Boolean + +-- | The `Show` type class represents those types which can be converted into +-- | a human-readable `String` representation. +-- | +-- | While not required, it is recommended that for any expression `x`, the +-- | string `show x` be executable PureScript code which evaluates to the same +-- | value as the expression `x`. +class Show a where + show :: a -> String + +instance showBoolean :: Show Boolean where + show true = "true" + show false = "false" + +instance showInt :: Show Int where + show = showIntImpl + +instance showNumber :: Show Number where + show = showNumberImpl + +instance showChar :: Show Char where + show = showCharImpl + +instance showString :: Show String where + show = showStringImpl + +instance showUnit :: Show Unit where + show _ = "unit" + +instance showArray :: (Show a) => Show (Array a) where + show = showArrayImpl show + +instance showOrdering :: Show Ordering where + show LT = "LT" + show GT = "GT" + show EQ = "EQ" + +foreign import showIntImpl :: Int -> String +foreign import showNumberImpl :: Number -> String +foreign import showCharImpl :: Char -> String +foreign import showStringImpl :: String -> String +foreign import showArrayImpl :: forall a. (a -> String) -> Array a -> String diff --git a/tests/support/flattened/Test-Assert.js b/tests/support/flattened/Test-Assert.js new file mode 100644 index 0000000000..ad1a67ca49 --- /dev/null +++ b/tests/support/flattened/Test-Assert.js @@ -0,0 +1,27 @@ +/* global exports */ +"use strict"; + +// module Test.Assert + +exports["assert'"] = function (message) { + return function (success) { + return function () { + if (!success) throw new Error(message); + return {}; + }; + }; +}; + +exports.checkThrows = function (fn) { + return function () { + try { + fn(); + return false; + } catch (e) { + if (e instanceof Error) return true; + var err = new Error("Threw something other than an Error"); + err.something = e; + throw err; + } + }; +}; diff --git a/tests/support/flattened/Test-Assert.purs b/tests/support/flattened/Test-Assert.purs new file mode 100644 index 0000000000..66b8622158 --- /dev/null +++ b/tests/support/flattened/Test-Assert.purs @@ -0,0 +1,46 @@ +module Test.Assert + ( assert' + , assert + , assertThrows + , assertThrows' + , ASSERT() + ) where + +import Control.Monad.Eff (Eff()) +import Prelude + +-- | Assertion effect type. +foreign import data ASSERT :: ! + +-- | Throws a runtime exception with message "Assertion failed" when the boolean +-- | value is false. +assert :: forall e. Boolean -> Eff (assert :: ASSERT | e) Unit +assert = assert' "Assertion failed" + +-- | Throws a runtime exception with the specified message when the boolean +-- | value is false. +foreign import assert' :: forall e. String -> Boolean -> Eff (assert :: ASSERT | e) Unit + +-- | Throws a runtime exception with message "Assertion failed: An error should +-- | have been thrown", unless the argument throws an exception when evaluated. +-- | +-- | This function is specifically for testing unsafe pure code; for example, +-- | to make sure that an exception is thrown if a precondition is not +-- | satisfied. Functions which use `Eff (err :: EXCEPTION | eff) a` can be +-- | tested with `catchException` instead. +assertThrows :: forall e a. (Unit -> a) -> Eff (assert :: ASSERT | e) Unit +assertThrows = assertThrows' "Assertion failed: An error should have been thrown" + +-- | Throws a runtime exception with the specified message, unless the argument +-- | throws an exception when evaluated. +-- | +-- | This function is specifically for testing unsafe pure code; for example, +-- | to make sure that an exception is thrown if a precondition is not +-- | satisfied. Functions which use `Eff (err :: EXCEPTION | eff) a` can be +-- | tested with `catchException` instead. +assertThrows' :: forall e a. String -> (Unit -> a) -> Eff (assert :: ASSERT | e) Unit +assertThrows' msg fn = + checkThrows fn >>= assert' msg + + +foreign import checkThrows :: forall e a. (Unit -> a) -> Eff (assert :: ASSERT | e) Boolean diff --git a/psci/tests/data/Sample.purs b/tests/support/psci/Sample.purs similarity index 100% rename from psci/tests/data/Sample.purs rename to tests/support/psci/Sample.purs diff --git a/travis/after.sh b/travis/after.sh index 3da0f1c0ef..58511bd67f 100755 --- a/travis/after.sh +++ b/travis/after.sh @@ -4,22 +4,10 @@ pushd core-tests/ ./test-everything.sh popd -if ! git describe --tags --exact-match >/dev/null 2>/dev/null && [ -n "$COVERAGE_SUITE" ] +if ! git describe --tags --exact-match >/dev/null 2>/dev/null && [ "$COVERAGE" = "true" ] then - case "$COVERAGE_SUITE" in - "tests") - ./.cabal-sandbox/bin/hpc-coveralls \ - --exclude-dir=dist/build/autogen \ - --exclude-dir=tests \ - tests;; - "psci-tests") - ./.cabal-sandbox/bin/hpc-coveralls \ - --exclude-dir=dist/build/autogen \ - --exclude-dir=src \ - --exclude-dir=psci/tests \ - psci-tests;; - *) - echo "unrecognised test suite $COVERAGE_SUITE" - exit 1;; - esac + ./.cabal-sandbox/bin/hpc-coveralls \ + --exclude-dir=dist/build/autogen \ + --exclude-dir=tests \ + tests fi diff --git a/travis/configure.sh b/travis/configure.sh index a11f1c9a00..d5ce1f751b 100755 --- a/travis/configure.sh +++ b/travis/configure.sh @@ -8,7 +8,7 @@ then configure_flags="--disable-optimization $configure_flags" fi -if [ -n "$COVERAGE_SUITE" ] +if [ "$COVERAGE" = "true" ] then configure_flags="--enable-coverage $configure_flags" fi From 14de64728330986d5af26bc2cb3367478dac8f24 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 6 Feb 2016 16:23:58 -0800 Subject: [PATCH 0282/1580] More efficient derived instances for Ord --- .../PureScript/Sugar/TypeClasses/Deriving.hs | 83 +++++++++++-------- 1 file changed, 50 insertions(+), 33 deletions(-) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 133d3f7adc..e1116c5699 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -99,7 +99,9 @@ deriveGeneric mn ds tyConNm dargs = do ] where mkSpineFunction :: Declaration -> m Expr - mkSpineFunction (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args + mkSpineFunction (DataDeclaration _ _ _ args) = do + x <- freshIdent' + lamCase x <$> mapM mkCtorClause args where prodConstructor :: Expr -> Expr prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd"))) @@ -122,7 +124,7 @@ deriveGeneric mn ds tyConNm dargs = do lamNull . recordConstructor . ArrayLiteral . map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)]) $ decomposeRec rec - toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i + toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration" @@ -154,14 +156,16 @@ deriveGeneric mn ds tyConNm dargs = do ] | (str, typ) <- decomposeRec rec ] - mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature) - (TypedValue False (mkGenVar "anyProxy") (proxy typ)) + mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature)) + (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ)) instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs) mkSignatureFunction (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction d classArgs mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration" mkFromSpineFunction :: Declaration -> m Expr - mkFromSpineFunction (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args) + mkFromSpineFunction (DataDeclaration _ _ _ args) = do + x <- freshIdent' + lamCase x <$> (addCatch <$> mapM mkAlternative args) where mkJust :: Expr -> Expr mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just"))) @@ -188,36 +192,37 @@ deriveGeneric mn ds tyConNm dargs = do where catchAll = CaseAlternative [NullBinder] (Right mkNothing) + fromSpineFun :: Expr -> Type -> Expr fromSpineFun e r | Just rec <- objectType r - = App (lamCase "r" [ mkRecCase (decomposeRec rec) - , CaseAlternative [NullBinder] (Right mkNothing) - ]) - (App e (mkPrelVar "unit")) - - fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit")) + = App (lamCase (Ident "r") [ mkRecCase (decomposeRec rec) + , CaseAlternative [NullBinder] (Right mkNothing) + ]) + (App e (mkPrelVar (Ident "unit"))) + fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit"))) + mkRecCase :: [(String, Type)] -> CaseAlternative mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs) ] ] . Right - $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs) + $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs) mkRecFun :: [(String, Type)] -> Expr - mkRecFun xs = mkJust $ foldr lam recLiteral (map fst xs) - where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs + mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs) + where recLiteral = ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration" -- Helpers liftApplicative :: Expr -> [Expr] -> Expr - liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e) + liftApplicative = foldl' (\x e -> App (App (mkPrelVar (Ident "apply")) x) e) - mkPrelVar :: String -> Expr + mkPrelVar :: Ident -> Expr mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude])) - mkGenVar :: String -> Expr + mkGenVar :: Ident -> Expr mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) deriveEq :: @@ -232,7 +237,10 @@ deriveEq mn ds tyConNm = do return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ] where mkEqFunction :: Declaration -> m Expr - mkEqFunction (DataDeclaration _ _ _ args) = lamCase2 "$x" "$y" <$> (addCatch <$> mapM mkCtorClause args) + mkEqFunction (DataDeclaration _ _ _ args) = do + x <- freshIdent "x" + y <- freshIdent "y" + lamCase2 x y <$> (addCatch <$> mapM mkCtorClause args) mkEqFunction (PositionedDeclaration _ _ d) = mkEqFunction d mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration" @@ -249,7 +257,8 @@ deriveEq mn ds tyConNm = do mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative mkCtorClause (ctorName, tys) = do - [identsL, identsR] <- replicateM 2 (replicateM (length tys) freshIdent') + identsL <- replicateM (length tys) (freshIdent "l") + identsR <- replicateM (length tys) (freshIdent "r") let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests)) where @@ -278,22 +287,23 @@ deriveOrd mn ds tyConNm = do return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ] where mkCompareFunction :: Declaration -> m Expr - mkCompareFunction (DataDeclaration _ _ _ args) = lamCase2 "$x" "$y" <$> (concat <$> mapM mkCtorClauses args) + mkCompareFunction (DataDeclaration _ _ _ args) = do + x <- freshIdent "x" + y <- freshIdent "y" + lamCase2 x y <$> (concat <$> mapM mkCtorClauses args) mkCompareFunction (PositionedDeclaration _ _ d) = mkCompareFunction d mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration" preludeCtor :: String -> Expr preludeCtor = Constructor . Qualified (Just (ModuleName [ProperName C.prelude])) . ProperName - preludeAppend :: Expr -> Expr -> Expr - preludeAppend = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.append))) - preludeCompare :: Expr -> Expr -> Expr preludeCompare = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.compare))) mkCtorClauses :: (ProperName 'ConstructorName, [Type]) -> m [CaseAlternative] mkCtorClauses (ctorName, tys) = do - [identsL, identsR] <- replicateM 2 (replicateM (length tys) freshIdent') + identsL <- replicateM (length tys) (freshIdent "l") + identsR <- replicateM (length tys) (freshIdent "r") let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys return [ CaseAlternative [ caseBinder identsL , caseBinder identsR @@ -313,7 +323,14 @@ deriveOrd mn ds tyConNm = do appendAll :: [Expr] -> Expr appendAll [] = preludeCtor "EQ" - appendAll xs = foldl1 preludeAppend xs + appendAll [x] = x + appendAll (x : xs) = Case [x] [ CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "LT")) [] ] + (Right (preludeCtor "LT")) + , CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "GT")) [] ] + (Right (preludeCtor "GT")) + , CaseAlternative [ NullBinder ] + (Right (appendAll xs)) + ] toOrdering :: Expr -> Expr -> Type -> Expr toOrdering l r ty | Just rec <- objectType ty = @@ -334,22 +351,22 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d isTypeDecl _ = False -lam :: String -> Expr -> Expr -lam s = Abs (Left (Ident s)) +lam :: Ident -> Expr -> Expr +lam = Abs . Left lamNull :: Expr -> Expr -lamNull = lam "$q" +lamNull = lam (Ident "$q") -- TODO: use GenIdent -lamCase :: String -> [CaseAlternative] -> Expr +lamCase :: Ident -> [CaseAlternative] -> Expr lamCase s = lam s . Case [mkVar s] -lamCase2 :: String -> String -> [CaseAlternative] -> Expr +lamCase2 :: Ident -> Ident -> [CaseAlternative] -> Expr lamCase2 s t = lam s . lam t . Case [mkVar s, mkVar t] -mkVarMn :: Maybe ModuleName -> String -> Expr -mkVarMn mn s = Var (Qualified mn (Ident s)) +mkVarMn :: Maybe ModuleName -> Ident -> Expr +mkVarMn mn = Var . Qualified mn -mkVar :: String -> Expr +mkVar :: Ident -> Expr mkVar = mkVarMn Nothing objectType :: Type -> Maybe Type From 6bbecf25a9e1bbfa1ec65959f57987cc222c1f9d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 6 Feb 2016 16:31:39 -0800 Subject: [PATCH 0283/1580] Fix redundant case warning in derived Ord instances --- .../PureScript/Sugar/TypeClasses/Deriving.hs | 34 ++++++++++++------- 1 file changed, 21 insertions(+), 13 deletions(-) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index e1116c5699..feaf3ef8d7 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -290,34 +290,42 @@ deriveOrd mn ds tyConNm = do mkCompareFunction (DataDeclaration _ _ _ args) = do x <- freshIdent "x" y <- freshIdent "y" - lamCase2 x y <$> (concat <$> mapM mkCtorClauses args) + lamCase2 x y <$> (concat <$> mapM mkCtorClauses (splitLast args)) mkCompareFunction (PositionedDeclaration _ _ d) = mkCompareFunction d mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration" + splitLast :: [a] -> [(a, Bool)] + splitLast [] = [] + splitLast [x] = [(x, True)] + splitLast (x : xs) = (x, False) : splitLast xs + preludeCtor :: String -> Expr preludeCtor = Constructor . Qualified (Just (ModuleName [ProperName C.prelude])) . ProperName preludeCompare :: Expr -> Expr -> Expr preludeCompare = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.compare))) - mkCtorClauses :: (ProperName 'ConstructorName, [Type]) -> m [CaseAlternative] - mkCtorClauses (ctorName, tys) = do + mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative] + mkCtorClauses ((ctorName, tys), isLast) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys - return [ CaseAlternative [ caseBinder identsL + extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) + , NullBinder + ] + (Right (preludeCtor "LT")) + , CaseAlternative [ NullBinder + , ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) + ] + (Right (preludeCtor "GT")) + ] + | otherwise = [] + return $ CaseAlternative [ caseBinder identsL , caseBinder identsR ] (Right (appendAll tests)) - , CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) - , NullBinder - ] - (Right (preludeCtor "LT")) - , CaseAlternative [ NullBinder - , ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) - ] - (Right (preludeCtor "GT")) - ] + : extras + where caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents) From 8838396090833e4d8cc8e3d4ac6b24800d4a44cc Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 6 Feb 2016 16:45:28 -0800 Subject: [PATCH 0284/1580] Add tests for records and nested types --- examples/passing/Deriving.purs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/examples/passing/Deriving.purs b/examples/passing/Deriving.purs index 738d7bcbc1..26d1e80f18 100644 --- a/examples/passing/Deriving.purs +++ b/examples/passing/Deriving.purs @@ -9,6 +9,10 @@ derive instance eqX :: Eq X derive instance ordX :: Ord X +newtype Z = Z { left :: X, right :: X } + +derive instance eqZ :: Eq Z + main = do assert $ X 0 == X 0 assert $ X 0 /= X 1 @@ -17,3 +21,5 @@ main = do assert $ X 0 < X 1 assert $ X 0 < Y "Foo" assert $ Y "Bar" < Y "Baz" + assert $ z == z where + z = Z { left: X 0, right: Y "Foo" } From b4e5bf2b336aa400b50cec3b6c8274d4bc8e0297 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 6 Feb 2016 16:50:58 -0800 Subject: [PATCH 0285/1580] More tests, handle Void types --- examples/passing/Deriving.purs | 6 ++++++ .../PureScript/Sugar/TypeClasses/Deriving.hs | 13 +++++++++++-- 2 files changed, 17 insertions(+), 2 deletions(-) diff --git a/examples/passing/Deriving.purs b/examples/passing/Deriving.purs index 26d1e80f18..fb1b65ec99 100644 --- a/examples/passing/Deriving.purs +++ b/examples/passing/Deriving.purs @@ -3,6 +3,12 @@ module Main where import Prelude import Test.Assert +data V + +derive instance eqV :: Eq V + +derive instance ordV :: Ord V + data X = X Int | Y String derive instance eqX :: Eq X diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index feaf3ef8d7..6a9344cf77 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -251,7 +251,9 @@ deriveEq mn ds tyConNm = do preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.eq))) addCatch :: [CaseAlternative] -> [CaseAlternative] - addCatch = (++ [catchAll]) + addCatch xs + | length xs /= 1 = xs ++ [catchAll] + | otherwise = xs -- Avoid redundant case where catchAll = CaseAlternative [NullBinder, NullBinder] (Right (BooleanLiteral False)) @@ -290,7 +292,7 @@ deriveOrd mn ds tyConNm = do mkCompareFunction (DataDeclaration _ _ _ args) = do x <- freshIdent "x" y <- freshIdent "y" - lamCase2 x y <$> (concat <$> mapM mkCtorClauses (splitLast args)) + lamCase2 x y <$> (addCatch . concat <$> mapM mkCtorClauses (splitLast args)) mkCompareFunction (PositionedDeclaration _ _ d) = mkCompareFunction d mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration" @@ -299,6 +301,13 @@ deriveOrd mn ds tyConNm = do splitLast [x] = [(x, True)] splitLast (x : xs) = (x, False) : splitLast xs + addCatch :: [CaseAlternative] -> [CaseAlternative] + addCatch xs + | null xs = [catchAll] -- No type constructors + | otherwise = xs + where + catchAll = CaseAlternative [NullBinder, NullBinder] (Right (preludeCtor "EQ")) + preludeCtor :: String -> Expr preludeCtor = Constructor . Qualified (Just (ModuleName [ProperName C.prelude])) . ProperName From e7537d7ee103b6e65b17bd1972206f0963b3fd94 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 9 Feb 2016 16:48:28 +0200 Subject: [PATCH 0286/1580] Bump bounds --- purescript.cabal | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 50befa7e1a..9e3a729de4 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -16,7 +16,7 @@ author: Phil Freeman , Hardy Jones , Harry Garrood -tested-with: GHC==7.8 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1 extra-source-files: examples/passing/*.purs , examples/failing/*.purs @@ -60,13 +60,13 @@ library filepath -any, mtl >= 2.1.0 && < 2.3.0, parsec -any, - transformers >= 0.3.0 && < 0.5, + transformers >= 0.3.0 && < 0.6, transformers-compat >= 0.3.0, utf8-string >= 1 && < 2, pattern-arrows >= 0.0.2 && < 0.1, time -any, boxes >= 0.1.4 && < 0.2.0, - aeson >= 0.8 && < 0.11, + aeson >= 0.8 && < 0.12, vector -any, bower-json >= 0.7, aeson-better-errors >= 0.8, @@ -76,7 +76,7 @@ library language-javascript == 0.5.*, syb -any, Glob >= 0.7 && < 0.8, - process >= 1.2.0 && < 1.4, + process >= 1.2.0 && < 1.5, safe >= 0.3.9 && < 0.4, semigroups >= 0.16.2 && < 0.19, parallel >= 3.2 && < 3.3 @@ -202,7 +202,7 @@ executable psc containers -any, directory -any, filepath -any, mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any, time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8, - aeson >= 0.8 && < 0.11, bytestring -any, utf8-string >= 1 && < 2 + aeson >= 0.8 && < 0.12, bytestring -any, utf8-string >= 1 && < 2 main-is: Main.hs buildable: True hs-source-dirs: psc From a4da062efb368d3dd5da5eec2037e813984eb062 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 9 Feb 2016 16:53:43 +0200 Subject: [PATCH 0287/1580] Add GHC8.0.1 to build matrix --- .travis.yml | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/.travis.yml b/.travis.yml index 0df9bebff1..c83c1b1a31 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,32 +2,35 @@ language: c sudo: false matrix: include: - - env: GHCVER=7.8.4 COVERAGE=true + - env: GHCVER=7.8.4 CABALVER=1.22 COVERAGE=true compiler: ": #GHC 7.8.4 - tests" # ^ HACK before https://github.com/travis-ci/travis-ci/issues/4393 is resolved addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.8.4 STACKAGE=lts-2.22 + - env: GHCVER=7.8.4 CABALVER=1.22 STACKAGE=lts-2.22 compiler: ": #GHC 7.8.4 - lts-2.22-1" addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.6.3 + - env: GHCVER=7.6.3 CABALVER=1.22 compiler: ": #GHC 7.6.3" addons: {apt: {packages: [cabal-install-1.22,ghc-7.6.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.10.1 DEPLOY=yes + - env: GHCVER=7.10.1 CABALVER=1.22 DEPLOY=yes compiler: ": #GHC 7.10.1" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.10.2 STACKAGE=lts=3.6 RUNSDISTTESTS=YES + - env: GHCVER=7.10.2 CABALVER=1.22 STACKAGE=lts=3.6 RUNSDISTTESTS=YES compiler: ": #GHC 7.10.2 lts-3.6" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.10.2 STACKAGE=nightly-2015-09-29 + - env: GHCVER=7.10.2 CABALVER=1.22 STACKAGE=nightly-2015-09-29 compiler: ": #GHC 7.10.2 nightly-2015-09-29" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.10.3 + - env: GHCVER=7.10.3 CABALVER=1.22 compiler: ": #GHC 7.10.3" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} + - env: GHCVER=8.0.1 CABALVER=1.24 + compiler: ": #GHC 8.0.1" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} before_install: - unset CC - export PATH="/opt/ghc/$GHCVER/bin:$PATH" - - export PATH="/opt/cabal/1.22/bin:$PATH" + - export PATH="/opt/cabal/$CABALVER/bin:$PATH" - export PATH="$HOME/.cabal/bin:$PATH" - export PATH="/opt/happy/1.19.5/bin:/$PATH" - export PATH="/opt/alex/3.1.4/bin:/$PATH" From 76fb7f856140b82a3aceaee7ef80872c56ffd5b7 Mon Sep 17 00:00:00 2001 From: Zhen Zhang Date: Sat, 13 Feb 2016 20:26:12 +0800 Subject: [PATCH 0288/1580] refactor PSCi code --- CONTRIBUTORS.md | 1 + psci/PSCi.hs | 568 +++++++++-------------------------------- psci/PSCi/Directive.hs | 4 + psci/PSCi/IO.hs | 51 +++- psci/PSCi/Message.hs | 53 ++++ psci/PSCi/Module.hs | 106 ++++++++ psci/PSCi/Option.hs | 57 +++++ psci/PSCi/Printer.hs | 131 ++++++++++ psci/PSCi/Types.hs | 3 + purescript.cabal | 12 +- tests/TestPsci.hs | 2 +- 11 files changed, 534 insertions(+), 454 deletions(-) create mode 100644 psci/PSCi/Message.hs create mode 100644 psci/PSCi/Module.hs create mode 100644 psci/PSCi/Option.hs create mode 100644 psci/PSCi/Printer.hs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index b4c76eb334..7c844185fd 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -65,6 +65,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@DavidLindbom](https://github.com/DavidLindbom) (David Lindbom) My existing contributions and all future contributions until further notice are Copyright David Lindbom, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/psci/PSCi.hs b/psci/PSCi.hs index d088e9a51c..ea119c5a17 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -7,16 +7,14 @@ -- | -- PureScript Compiler Interactive. -- -module PSCi where +module PSCi (runPSCi) where import Prelude () import Prelude.Compat import Data.Foldable (traverse_) -import Data.Maybe (mapMaybe) -import Data.List (intersperse, intercalate, nub, sort, find) +import Data.List (intercalate, nub, sort, find) import Data.Tuple (swap) -import Data.Version (showVersion) import qualified Data.Map as M import Control.Arrow (first) @@ -24,102 +22,87 @@ import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.Class import Control.Monad.Trans.Except (ExceptT(), runExceptT) -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.State.Strict import Control.Monad.IO.Class (liftIO) import Control.Monad.Writer.Strict (Writer(), runWriter) -import Options.Applicative as Opts - import System.Console.Haskeline -import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory) +import System.Directory (doesFileExist, getHomeDirectory, getCurrentDirectory) import System.Exit -import System.FilePath (pathSeparator, (), isPathSeparator) +import System.FilePath (()) import System.FilePath.Glob (glob) import System.Process (readProcessWithExitCode) import System.IO.Error (tryIOError) -import qualified Text.PrettyPrint.Boxes as Box import qualified Language.PureScript as P import qualified Language.PureScript.Names as N -import qualified Paths_purescript as Paths -import qualified PSCi.Directive as D import PSCi.Completion (completion) -import PSCi.IO (mkdirp) import PSCi.Parser (parseCommand) +import PSCi.Option import PSCi.Types - --- | The name of the PSCI support module -supportModuleName :: P.ModuleName -supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"] - --- | Support module, contains code to evaluate terms -supportModule :: P.Module -supportModule = - case P.parseModulesFromFiles id [("", code)] of - Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps - _ -> P.internalError "Support module could not be parsed" - where - code :: String - code = unlines - [ "module S where" - , "" - , "import Prelude" - , "import Control.Monad.Eff" - , "import Control.Monad.Eff.Console" - , "import Control.Monad.Eff.Unsafe" - , "" - , "class Eval a where" - , " eval :: a -> Eff (console :: CONSOLE) Unit" - , "" - , "instance evalShow :: (Show a) => Eval a where" - , " eval = print" - , "" - , "instance evalEff :: (Eval a) => Eval (Eff eff a) where" - , " eval x = unsafeInterleaveEff x >>= eval" - ] - --- File helpers - -onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a) -onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants +import PSCi.Message +import PSCi.IO +import PSCi.Printer +import PSCi.Module -- | --- Locates the node executable. --- Checks for either @nodejs@ or @node@. +-- PSCI monad -- -findNodeProcess :: IO (Maybe String) -findNodeProcess = onFirstFileMatching findExecutable names - where names = ["nodejs", "node"] +newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad) --- | --- Grabs the filename where the history is stored. --- -getHistoryFilename :: IO FilePath -getHistoryFilename = do - home <- getHomeDirectory - let filename = home ".purescript" "psci_history" - mkdirp filename - return filename +psciIO :: IO a -> PSCI a +psciIO io = PSCI . lift $ lift io -- | --- Loads a file for use with imports. +-- The runner -- -loadModule :: FilePath -> IO (Either String [P.Module]) -loadModule filename = do - content <- readFile filename - return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)] +runPSCi :: IO () +runPSCi = getOpt >>= loop -- | --- Load all modules. +-- The PSCI main loop. -- -loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)]) -loadAllModules files = do - filesAndContent <- forM files $ \filename -> do - content <- readFile filename - return (filename, content) - return $ P.parseModulesFromFiles id filesAndContent +loop :: PSCiOptions -> IO () +loop PSCiOptions{..} = do + config <- loadUserConfig + inputFiles <- concat <$> traverse glob psciInputFile + foreignFiles <- concat <$> traverse glob psciForeignInputFiles + modulesOrFirstError <- loadAllModules inputFiles + case modulesOrFirstError of + Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure + Right modules -> do + historyFilename <- getHistoryFilename + let settings = defaultSettings { historyFile = Just historyFilename } + foreignsOrError <- runMake $ do + foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile)) + P.parseForeignModulesFromFiles foreignFilesContent + case foreignsOrError of + Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure + Right foreigns -> + flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do + outputStrLn prologueMessage + traverse_ (traverse_ (runPSCI . handleCommand)) config + modules' <- lift $ gets psciLoadedModules + unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines + [ "PSCi requires the purescript-console module to be installed." + , "For help getting started, visit http://wiki.purescript.org/PSCi" + ] + go + where + go :: InputT (StateT PSCiState IO) () + go = do + c <- getCommand (not psciMultiLineMode) + case c of + Left err -> outputStrLn err >> go + Right Nothing -> go + Right (Just QuitPSCi) -> outputStrLn quitMessage + Right (Just c') -> do + handleInterrupt (outputStrLn "Interrupted.") + (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c'))) + go + +-- Compile the module -- | -- Load all modules, updating the application state @@ -129,116 +112,9 @@ loadAllImportedModules = do files <- PSCI . lift $ fmap psciImportedFilenames get modulesOrFirstError <- psciIO $ loadAllModules files case modulesOrFirstError of - Left errs -> printErrors errs + Left errs -> PSCI $ printErrors errs Right modules -> PSCI . lift . modify $ updateModules modules --- | --- Expands tilde in path. --- -expandTilde :: FilePath -> IO FilePath -expandTilde ('~':p:rest) | isPathSeparator p = ( rest) <$> getHomeDirectory -expandTilde p = return p - --- Messages - --- | --- The help message. --- -helpMessage :: String -helpMessage = "The following commands are available:\n\n " ++ - intercalate "\n " (map line D.help) ++ - "\n\n" ++ extraHelp - where - line :: (Directive, String, String) -> String - line (dir, arg, desc) = - let cmd = ':' : D.stringFor dir - in unwords [ cmd - , replicate (11 - length cmd) ' ' - , arg - , replicate (11 - length arg) ' ' - , desc - ] - - extraHelp = - "Further information is available on the PureScript wiki:\n" ++ - " --> https://github.com/purescript/purescript/wiki/psci" - - --- | --- The welcome prologue. --- -prologueMessage :: String -prologueMessage = intercalate "\n" - [ " ____ ____ _ _ " - , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ " - , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|" - , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ " - , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|" - , " |_| " - , "" - , ":? shows help" - ] - --- | --- The quit message. --- -quitMessage :: String -quitMessage = "See ya!" - --- | --- PSCI monad --- -newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad) - -psciIO :: IO a -> PSCI a -psciIO io = PSCI . lift $ lift io - --- | --- Makes a volatile module to execute the current expression. --- -createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module -createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val = - let - moduleName = P.ModuleName [P.ProperName "$PSCI"] - trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval")) - mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))) - itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val - mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue - decls = if exec then [itDecl, mainDecl] else [itDecl] - in - P.Module (P.internalModuleSourceSpan "") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing - - --- | --- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration. --- -createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module -createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ = - let - moduleName = P.ModuleName [P.ProperName "$PSCI"] - itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ - in - P.Module (P.internalModuleSourceSpan "") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing - --- | --- Makes a volatile module to execute the current imports. --- -createTemporaryModuleForImports :: PSCiState -> P.Module -createTemporaryModuleForImports PSCiState{psciImportedModules = imports} = - let - moduleName = P.ModuleName [P.ProperName "$PSCI"] - in - P.Module (P.internalModuleSourceSpan "") [] moduleName (importDecl `map` imports) Nothing - -importDecl :: ImportedModule -> P.Declaration -importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False - -indexFile :: FilePath -indexFile = ".psci_modules" ++ pathSeparator : "index.js" - -modulesDir :: FilePath -modulesDir = ".psci_modules" ++ pathSeparator : "node_modules" - -- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the -- options and ignores the warning messages. runMake :: P.Make a -> IO (Either P.MultipleErrors a) @@ -258,6 +134,58 @@ make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms) loadedModules = psciLoadedModules st allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms + +-- Commands + +-- | +-- Parses the input and returns either a Metacommand, or an error as a string. +-- +getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command)) +getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do + firstLine <- withInterrupt $ getInputLine "> " + case firstLine of + Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty + Just "" -> return (Right Nothing) + Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s + Just s -> fmap Just . parseCommand <$> go [s] + where + go :: [String] -> InputT (StateT PSCiState IO) String + go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " " + +-- | +-- Performs an action for each meta-command given, and also for expressions. +-- +handleCommand :: Command -> PSCI () +handleCommand (Expression val) = handleExpression val +handleCommand ShowHelp = PSCI $ outputStrLn helpMessage +handleCommand (Import im) = handleImport im +handleCommand (Decls l) = handleDecls l +handleCommand (LoadFile filePath) = PSCI $ whenFileExists filePath $ \absPath -> do + m <- lift . lift $ loadModule absPath + case m of + Left err -> outputStrLn err + Right mods -> lift $ modify (updateModules (map (absPath,) mods)) +handleCommand (LoadForeign filePath) = PSCI $ whenFileExists filePath $ \absPath -> do + foreignsOrError <- lift . lift . runMake $ do + foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath) + P.parseForeignModulesFromFiles [(absPath, foreignFile)] + case foreignsOrError of + Left err -> outputStrLn $ P.prettyPrintMultipleErrors False err + Right foreigns -> lift $ modify (updateForeignFiles foreigns) +handleCommand ResetState = do + PSCI . lift . modify $ \st -> + st { psciImportedModules = [] + , psciLetBindings = [] + } + loadAllImportedModules +handleCommand (TypeOf val) = handleTypeOf val +handleCommand (KindOf typ) = handleKindOf typ +handleCommand (BrowseModule moduleName) = handleBrowse moduleName +handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules +handleCommand (ShowInfo QueryImport) = handleShowImportedModules +handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug." + + -- | -- Takes a value expression and evaluates it with the current state. -- @@ -268,7 +196,7 @@ handleExpression val = do let nodeArgs = psciNodeFlags st ++ [indexFile] e <- psciIO . runMake $ make st [supportModule, m] case e of - Left errs -> printErrors errs + Left errs -> PSCI $ printErrors errs Right _ -> do psciIO $ writeFile indexFile "require('$PSCI')['$main']();" process <- psciIO findNodeProcess @@ -289,7 +217,7 @@ handleDecls ds = do let m = createTemporaryModule False st' (P.ObjectLiteral []) e <- psciIO . runMake $ make st' [m] case e of - Left err -> printErrors err + Left err -> PSCI $ printErrors err Right _ -> PSCI $ lift (put st') -- | @@ -344,7 +272,7 @@ handleImport im = do let m = createTemporaryModuleForImports st e <- psciIO . runMake $ make st [m] case e of - Left errs -> printErrors errs + Left errs -> PSCI $ printErrors errs Right _ -> do PSCI $ lift $ put st return () @@ -358,124 +286,12 @@ handleTypeOf val = do let m = createTemporaryModule False st val e <- psciIO . runMake $ make st [m] case e of - Left errs -> printErrors errs + Left errs -> PSCI $ printErrors errs Right env' -> case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty Nothing -> PSCI $ outputStrLn "Could not find type" --- | --- Pretty print a module's signatures --- -printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI () -printModuleSignatures moduleName (P.Environment {..}) = - PSCI $ - -- get relevant components of a module from environment - let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names - moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses - moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types - - in - -- print each component - (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left) - [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses - , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types - , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions - ] - - where printModule's showF = Box.vsep 1 Box.left . showF - - findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) - findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames) - - showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box - showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType - showNameType _ = P.internalError "The impossible happened in printModuleSignatures." - - findTypeClass - :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) - -> P.Qualified (P.ProperName 'P.ClassName) - -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) - findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses) - - showTypeClass - :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) - -> Maybe Box.Box - showTypeClass (_, Nothing) = Nothing - showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) = - let constraints = - if null constrs - then Box.text "" - else Box.text "(" - Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs) - Box.<> Box.text ") <= " - className = - Box.text (P.runProperName name) - Box.<> Box.text (concatMap ((' ':) . fst) vars) - classBody = - Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body) - - in - Just $ - (Box.text "class " - Box.<> constraints - Box.<> className - Box.<+> if null body then Box.text "" else Box.text "where") - Box.// Box.moveRight 2 classBody - - - findType - :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind) - -> P.Qualified (P.ProperName 'P.TypeName) - -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind)) - findType envTypes name = (name, M.lookup name envTypes) - - showType - :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) - -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident]) - -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type) - -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind)) - -> Maybe Box.Box - showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) = - case (typ, M.lookup n typeSynonymsEnv) of - (Just (_, P.TypeSynonym), Just (typevars, dtType)) -> - if M.member (fmap P.coerceProperName n) typeClassesEnv - then - Nothing - else - Just $ - Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) - Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType) - - (Just (_, P.DataType typevars pt), _) -> - let prefix = - case pt of - [(dtProperName,_)] -> - case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of - Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType - _ -> "data" - _ -> "data" - - in - Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt - - _ -> - Nothing - - where printCons pt = - Box.moveRight 2 $ - Box.vcat Box.left $ - mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $ - map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt - - prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t - - mapFirstRest _ _ [] = [] - mapFirstRest f g (x:xs) = f x : map g xs - - trimEnd = reverse . dropWhile (== ' ') . reverse - - -- | -- Browse a module and displays its signature (if module exists). -- @@ -484,14 +300,14 @@ handleBrowse moduleName = do st <- PSCI $ lift get env <- psciIO . runMake $ make st [] case env of - Left errs -> printErrors errs + Left errs -> PSCI $ printErrors errs Right env' -> if isModInEnv moduleName st - then printModuleSignatures moduleName env' + then PSCI $ printModuleSignatures moduleName env' else case lookupUnQualifiedModName moduleName st of Just unQualifiedName -> if isModInEnv unQualifiedName st - then printModuleSignatures unQualifiedName env' + then PSCI $ printModuleSignatures unQualifiedName env' else failNotInEnv moduleName Nothing -> failNotInEnv moduleName @@ -503,10 +319,6 @@ handleBrowse moduleName = do lookupUnQualifiedModName quaModName st = (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st) --- | Pretty-print errors -printErrors :: P.MultipleErrors -> PSCI () -printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False - -- | -- Takes a value and prints its kind -- @@ -517,7 +329,7 @@ handleKindOf typ = do mName = P.ModuleName [P.ProperName "$PSCI"] e <- psciIO . runMake $ make st [m] case e of - Left errs -> printErrors errs + Left errs -> PSCI $ printErrors errs Right env' -> case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of Just (_, typ') -> do @@ -531,63 +343,7 @@ handleKindOf typ = do Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind Nothing -> PSCI $ outputStrLn "Could not find kind" --- Commands - --- | --- Parses the input and returns either a Metacommand, or an error as a string. --- -getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command)) -getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do - firstLine <- withInterrupt $ getInputLine "> " - case firstLine of - Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty - Just "" -> return (Right Nothing) - Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s - Just s -> fmap Just . parseCommand <$> go [s] - where - go :: [String] -> InputT (StateT PSCiState IO) String - go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " " - --- | --- Performs an action for each meta-command given, and also for expressions. --- -handleCommand :: Command -> PSCI () -handleCommand (Expression val) = handleExpression val -handleCommand ShowHelp = PSCI $ outputStrLn helpMessage -handleCommand (Import im) = handleImport im -handleCommand (Decls l) = handleDecls l -handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do - m <- psciIO $ loadModule absPath - case m of - Left err -> PSCI $ outputStrLn err - Right mods -> PSCI . lift $ modify (updateModules (map (absPath,) mods)) -handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do - foreignsOrError <- psciIO . runMake $ do - foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath) - P.parseForeignModulesFromFiles [(absPath, foreignFile)] - case foreignsOrError of - Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err - Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns) -handleCommand ResetState = do - PSCI . lift . modify $ \st -> - st { psciImportedModules = [] - , psciLetBindings = [] - } - loadAllImportedModules -handleCommand (TypeOf val) = handleTypeOf val -handleCommand (KindOf typ) = handleKindOf typ -handleCommand (BrowseModule moduleName) = handleBrowse moduleName -handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules -handleCommand (ShowInfo QueryImport) = handleShowImportedModules -handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug." - -whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI () -whenFileExists filePath f = do - absPath <- psciIO $ expandTilde filePath - exists <- psciIO $ doesFileExist absPath - if exists - then f absPath - else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath +-- Misc -- | -- Attempts to read initial commands from '.psci' in the present working @@ -610,92 +366,6 @@ loadUserConfig = onFirstFileMatching readCommands pathGetters else return Nothing - -- | Checks if the Console module is defined consoleIsDefined :: [P.Module] -> Bool consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", "Eff", "Console" ])) . P.getModuleName) - --- | --- The PSCI main loop. --- -loop :: PSCiOptions -> IO () -loop PSCiOptions{..} = do - config <- loadUserConfig - inputFiles <- concat <$> traverse glob psciInputFile - foreignFiles <- concat <$> traverse glob psciForeignInputFiles - modulesOrFirstError <- loadAllModules inputFiles - case modulesOrFirstError of - Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure - Right modules -> do - historyFilename <- getHistoryFilename - let settings = defaultSettings { historyFile = Just historyFilename } - foreignsOrError <- runMake $ do - foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile)) - P.parseForeignModulesFromFiles foreignFilesContent - case foreignsOrError of - Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure - Right foreigns -> - flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do - outputStrLn prologueMessage - traverse_ (traverse_ (runPSCI . handleCommand)) config - modules' <- lift $ gets psciLoadedModules - unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines - [ "PSCi requires the purescript-console module to be installed." - , "For help getting started, visit http://wiki.purescript.org/PSCi" - ] - go - where - go :: InputT (StateT PSCiState IO) () - go = do - c <- getCommand (not psciMultiLineMode) - case c of - Left err -> outputStrLn err >> go - Right Nothing -> go - Right (Just QuitPSCi) -> outputStrLn quitMessage - Right (Just c') -> do - handleInterrupt (outputStrLn "Interrupted.") - (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c'))) - go - -multiLineMode :: Parser Bool -multiLineMode = switch $ - long "multi-line-mode" - <> short 'm' - <> Opts.help "Run in multi-line mode (use ^D to terminate commands)" - -inputFile :: Parser FilePath -inputFile = strArgument $ - metavar "FILE" - <> Opts.help "Optional .purs files to load on start" - -inputForeignFile :: Parser FilePath -inputForeignFile = strOption $ - short 'f' - <> long "ffi" - <> help "The input .js file(s) providing foreign import implementations" - -nodeFlagsFlag :: Parser [String] -nodeFlagsFlag = option parser $ - long "node-opts" - <> metavar "NODE_OPTS" - <> value [] - <> Opts.help "Flags to pass to node, separated by spaces" - where - parser = words <$> str - -psciOptions :: Parser PSCiOptions -psciOptions = PSCiOptions <$> multiLineMode - <*> many inputFile - <*> many inputForeignFile - <*> nodeFlagsFlag - -runPSCi :: IO () -runPSCi = execParser opts >>= loop - where - opts = info (version <*> helper <*> psciOptions) infoModList - infoModList = fullDesc <> headerInfo <> footerInfo - headerInfo = header "psci - Interactive mode for PureScript" - footerInfo = footer $ "psci " ++ showVersion Paths.version - - version :: Parser (a -> a) - version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden diff --git a/psci/PSCi/Directive.hs b/psci/PSCi/Directive.hs index 92f8853df2..3d0cad5a38 100644 --- a/psci/PSCi/Directive.hs +++ b/psci/PSCi/Directive.hs @@ -15,6 +15,10 @@ module PSCi.Directive where +import Prelude () +import Prelude.Compat + + import Data.Maybe (fromJust, listToMaybe) import Data.List (isPrefixOf) import Data.Tuple (swap) diff --git a/psci/PSCi/IO.hs b/psci/PSCi/IO.hs index 92668a96ec..fea644a448 100644 --- a/psci/PSCi/IO.hs +++ b/psci/PSCi/IO.hs @@ -14,8 +14,55 @@ module PSCi.IO where -import System.Directory (createDirectoryIfMissing) -import System.FilePath (takeDirectory) +import Prelude () +import Prelude.Compat + +import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable, doesFileExist) +import System.FilePath (takeDirectory, (), isPathSeparator) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Control.Monad (msum) +import Control.Monad.IO.Class (MonadIO, liftIO) +import System.Console.Haskeline (outputStrLn, InputT) mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory + +-- File helpers + +onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a) +onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants + +-- | +-- Locates the node executable. +-- Checks for either @nodejs@ or @node@. +-- +findNodeProcess :: IO (Maybe String) +findNodeProcess = onFirstFileMatching findExecutable names + where names = ["nodejs", "node"] + +-- | +-- Grabs the filename where the history is stored. +-- +getHistoryFilename :: IO FilePath +getHistoryFilename = do + home <- getHomeDirectory + let filename = home ".purescript" "psci_history" + mkdirp filename + return filename + + +-- | +-- Expands tilde in path. +-- +expandTilde :: FilePath -> IO FilePath +expandTilde ('~':p:rest) | isPathSeparator p = ( rest) <$> getHomeDirectory +expandTilde p = return p + + +whenFileExists :: MonadIO m => FilePath -> (FilePath -> InputT m ()) -> InputT m () +whenFileExists filePath f = do + absPath <- liftIO $ expandTilde filePath + exists <- liftIO $ doesFileExist absPath + if exists + then f absPath + else outputStrLn $ "Couldn't locate: " ++ filePath diff --git a/psci/PSCi/Message.hs b/psci/PSCi/Message.hs new file mode 100644 index 0000000000..bd20b48b4c --- /dev/null +++ b/psci/PSCi/Message.hs @@ -0,0 +1,53 @@ +module PSCi.Message where + + +import Data.List (intercalate) +import qualified PSCi.Directive as D +import PSCi.Types + +-- Messages + +-- | +-- The help message. +-- +helpMessage :: String +helpMessage = "The following commands are available:\n\n " ++ + intercalate "\n " (map line D.help) ++ + "\n\n" ++ extraHelp + where + line :: (Directive, String, String) -> String + line (dir, arg, desc) = + let cmd = ':' : D.stringFor dir + in unwords [ cmd + , replicate (11 - length cmd) ' ' + , arg + , replicate (11 - length arg) ' ' + , desc + ] + + extraHelp = + "Further information is available on the PureScript wiki:\n" ++ + " --> https://github.com/purescript/purescript/wiki/psci" + + +-- | +-- The welcome prologue. +-- +prologueMessage :: String +prologueMessage = intercalate "\n" + [ " ____ ____ _ _ " + , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ " + , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|" + , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ " + , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|" + , " |_| " + , "" + , ":? shows help" + ] + +-- | +-- The quit message. +-- +quitMessage :: String +quitMessage = "See ya!" + diff --git a/psci/PSCi/Module.hs b/psci/PSCi/Module.hs new file mode 100644 index 0000000000..ead2c0057a --- /dev/null +++ b/psci/PSCi/Module.hs @@ -0,0 +1,106 @@ +module PSCi.Module where + +import Prelude () +import Prelude.Compat + +import qualified Language.PureScript as P +import PSCi.Types +import System.FilePath (pathSeparator) +import Control.Monad + +-- | The name of the PSCI support module +supportModuleName :: P.ModuleName +supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"] + +-- | Support module, contains code to evaluate terms +supportModule :: P.Module +supportModule = + case P.parseModulesFromFiles id [("", code)] of + Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps + _ -> P.internalError "Support module could not be parsed" + where + code :: String + code = unlines + [ "module S where" + , "" + , "import Prelude" + , "import Control.Monad.Eff" + , "import Control.Monad.Eff.Console" + , "import Control.Monad.Eff.Unsafe" + , "" + , "class Eval a where" + , " eval :: a -> Eff (console :: CONSOLE) Unit" + , "" + , "instance evalShow :: (Show a) => Eval a where" + , " eval = print" + , "" + , "instance evalEff :: (Eval a) => Eval (Eff eff a) where" + , " eval x = unsafeInterleaveEff x >>= eval" + ] + +-- Module Management + +-- | +-- Loads a file for use with imports. +-- +loadModule :: FilePath -> IO (Either String [P.Module]) +loadModule filename = do + content <- readFile filename + return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)] + +-- | +-- Load all modules. +-- +loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)]) +loadAllModules files = do + filesAndContent <- forM files $ \filename -> do + content <- readFile filename + return (filename, content) + return $ P.parseModulesFromFiles id filesAndContent + + +-- | +-- Makes a volatile module to execute the current expression. +-- +createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module +createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val = + let + moduleName = P.ModuleName [P.ProperName "$PSCI"] + trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval")) + mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))) + itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val + mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue + decls = if exec then [itDecl, mainDecl] else [itDecl] + in + P.Module (P.internalModuleSourceSpan "") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing + + +-- | +-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration. +-- +createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module +createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ = + let + moduleName = P.ModuleName [P.ProperName "$PSCI"] + itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ + in + P.Module (P.internalModuleSourceSpan "") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing + +-- | +-- Makes a volatile module to execute the current imports. +-- +createTemporaryModuleForImports :: PSCiState -> P.Module +createTemporaryModuleForImports PSCiState{psciImportedModules = imports} = + let + moduleName = P.ModuleName [P.ProperName "$PSCI"] + in + P.Module (P.internalModuleSourceSpan "") [] moduleName (importDecl `map` imports) Nothing + +importDecl :: ImportedModule -> P.Declaration +importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False + +indexFile :: FilePath +indexFile = ".psci_modules" ++ pathSeparator : "index.js" + +modulesDir :: FilePath +modulesDir = ".psci_modules" ++ pathSeparator : "node_modules" diff --git a/psci/PSCi/Option.hs b/psci/PSCi/Option.hs new file mode 100644 index 0000000000..1b75001190 --- /dev/null +++ b/psci/PSCi/Option.hs @@ -0,0 +1,57 @@ +module PSCi.Option ( + getOpt +) where + +import Prelude () +import Prelude.Compat + +import Options.Applicative as Opts +import Data.Version (showVersion) + +import PSCi.Types +import qualified Paths_purescript as Paths + +-- Parse Command line option + +multiLineMode :: Parser Bool +multiLineMode = switch $ + long "multi-line-mode" + <> short 'm' + <> Opts.help "Run in multi-line mode (use ^D to terminate commands)" + +inputFile :: Parser FilePath +inputFile = strArgument $ + metavar "FILE" + <> Opts.help "Optional .purs files to load on start" + +inputForeignFile :: Parser FilePath +inputForeignFile = strOption $ + short 'f' + <> long "ffi" + <> help "The input .js file(s) providing foreign import implementations" + +nodeFlagsFlag :: Parser [String] +nodeFlagsFlag = option parser $ + long "node-opts" + <> metavar "NODE_OPTS" + <> value [] + <> Opts.help "Flags to pass to node, separated by spaces" + where + parser = words <$> str + +psciOptions :: Parser PSCiOptions +psciOptions = PSCiOptions <$> multiLineMode + <*> many inputFile + <*> many inputForeignFile + <*> nodeFlagsFlag + +version :: Parser (a -> a) +version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden + +getOpt :: IO PSCiOptions +getOpt = execParser opts + where + opts = info (version <*> helper <*> psciOptions) infoModList + infoModList = fullDesc <> headerInfo <> footerInfo + headerInfo = header "psci - Interactive mode for PureScript" + footerInfo = footer $ "psci " ++ showVersion Paths.version diff --git a/psci/PSCi/Printer.hs b/psci/PSCi/Printer.hs new file mode 100644 index 0000000000..1d128eb5b2 --- /dev/null +++ b/psci/PSCi/Printer.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} + +module PSCi.Printer where + +import Prelude () +import Prelude.Compat + +import qualified Language.PureScript as P +import qualified Text.PrettyPrint.Boxes as Box +import qualified Data.Map as M +import System.Console.Haskeline +import Data.Maybe (mapMaybe) +import Data.List (intersperse) +import Control.Monad.IO.Class (MonadIO) + +-- Printers + +-- | +-- Pretty print a module's signatures +-- +printModuleSignatures :: MonadIO m => P.ModuleName -> P.Environment -> InputT m () +printModuleSignatures moduleName (P.Environment {..}) = + -- get relevant components of a module from environment + let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names + moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses + moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types + + in + -- print each component + (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left) + [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses + , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types + , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions + ] + + where printModule's showF = Box.vsep 1 Box.left . showF + + findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) + findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames) + + showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box + showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType + showNameType _ = P.internalError "The impossible happened in printModuleSignatures." + + findTypeClass + :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) + -> P.Qualified (P.ProperName 'P.ClassName) + -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) + findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses) + + showTypeClass + :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) + -> Maybe Box.Box + showTypeClass (_, Nothing) = Nothing + showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) = + let constraints = + if null constrs + then Box.text "" + else Box.text "(" + Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs) + Box.<> Box.text ") <= " + className = + Box.text (P.runProperName name) + Box.<> Box.text (concatMap ((' ':) . fst) vars) + classBody = + Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body) + + in + Just $ + (Box.text "class " + Box.<> constraints + Box.<> className + Box.<+> if null body then Box.text "" else Box.text "where") + Box.// Box.moveRight 2 classBody + + + findType + :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind) + -> P.Qualified (P.ProperName 'P.TypeName) + -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind)) + findType envTypes name = (name, M.lookup name envTypes) + + showType + :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) + -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident]) + -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type) + -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind)) + -> Maybe Box.Box + showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) = + case (typ, M.lookup n typeSynonymsEnv) of + (Just (_, P.TypeSynonym), Just (typevars, dtType)) -> + if M.member (fmap P.coerceProperName n) typeClassesEnv + then + Nothing + else + Just $ + Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) + Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType) + + (Just (_, P.DataType typevars pt), _) -> + let prefix = + case pt of + [(dtProperName,_)] -> + case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of + Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType + _ -> "data" + _ -> "data" + + in + Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt + + _ -> + Nothing + + where printCons pt = + Box.moveRight 2 $ + Box.vcat Box.left $ + mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $ + map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt + + prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t + + mapFirstRest _ _ [] = [] + mapFirstRest f g (x:xs) = f x : map g xs + + trimEnd = reverse . dropWhile (== ' ') . reverse + +-- | Pretty-print errors +printErrors :: MonadIO m => P.MultipleErrors -> InputT m () +printErrors = outputStrLn . P.prettyPrintMultipleErrors False diff --git a/psci/PSCi/Types.hs b/psci/PSCi/Types.hs index 72c562bbce..3627d41a20 100644 --- a/psci/PSCi/Types.hs +++ b/psci/PSCi/Types.hs @@ -15,6 +15,9 @@ module PSCi.Types where +import Prelude () +import Prelude.Compat + import Control.Arrow (second) import Data.Map (Map) import qualified Data.Map as Map diff --git a/purescript.cabal b/purescript.cabal index 9e3a729de4..dbf9602dca 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -206,7 +206,7 @@ executable psc main-is: Main.hs buildable: True hs-source-dirs: psc - other-modules: JSON + other-modules: JSON, Paths_purescript ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N" executable psci @@ -225,6 +225,11 @@ executable psci PSCi.Directive PSCi.Completion PSCi.IO + PSCi.Message + PSCi.Option + PSCi.Module + PSCi.Printer + Paths_purescript ghc-options: -Wall -O2 executable psc-docs @@ -234,6 +239,7 @@ executable psc-docs filepath -any, Glob -any, transformers -any, transformers-compat -any main-is: Main.hs + other-modules: Paths_purescript buildable: True hs-source-dirs: psc-docs other-modules: Ctags @@ -244,6 +250,7 @@ executable psc-docs executable psc-publish build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any main-is: Main.hs + other-modules: Paths_purescript buildable: True hs-source-dirs: psc-publish ghc-options: -Wall -O2 @@ -253,6 +260,7 @@ executable psc-hierarchy process -any, mtl -any, parsec -any, filepath -any, directory -any, Glob -any main-is: Main.hs + other-modules: Paths_purescript buildable: True hs-source-dirs: hierarchy other-modules: @@ -260,7 +268,7 @@ executable psc-hierarchy executable psc-bundle main-is: Main.hs - other-modules: + other-modules: Paths_purescript other-extensions: build-depends: base >=4 && <5, purescript -any, diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index 206e6d889a..3d058df020 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -23,7 +23,7 @@ import Test.HUnit import qualified Language.PureScript as P -import PSCi +import PSCi.Module (loadAllModules) import PSCi.Completion import PSCi.Types From c9a223516923fc249c31a125dcb4c02d282856d4 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 21 Feb 2016 20:13:11 -0800 Subject: [PATCH 0289/1580] Update TestDocs.hs to fix tests build --- tests/TestDocs.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index fc3a3d2b62..5fdb41618d 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -9,10 +9,9 @@ import Prelude.Compat import Data.Version (Version(..)) -import Data.Monoid ((<>)) +import Data.Monoid import Data.Maybe (fromMaybe) import Data.List ((\\)) -import Data.Monoid import Data.Foldable import System.Exit From 9a377c48cef11ea2722f0856f9c5a95a335363c9 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 19 Feb 2016 11:49:44 +0000 Subject: [PATCH 0290/1580] Operator aliases for data constructors --- .../failing/DctorOperatorAliasExport.purs | 6 + examples/failing/InvalidOperatorInBinder.purs | 12 ++ examples/passing/DctorOperatorAlias.purs | 35 ++++ purescript.cabal | 3 + src/Language/PureScript/AST/Binders.hs | 20 ++ src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/AST/Traversals.hs | 18 +- src/Language/PureScript/CoreFn/Desugar.hs | 24 ++- src/Language/PureScript/Docs/Render.hs | 6 +- src/Language/PureScript/Docs/Types.hs | 7 +- src/Language/PureScript/Errors.hs | 13 ++ src/Language/PureScript/Externs.hs | 5 +- src/Language/PureScript/ModuleDependencies.hs | 3 +- .../PureScript/Parser/Declarations.hs | 25 ++- src/Language/PureScript/Sugar/Names.hs | 4 +- src/Language/PureScript/Sugar/Operators.hs | 175 ++++++++++-------- .../PureScript/Sugar/Operators/Binders.hs | 43 +++++ .../PureScript/Sugar/Operators/Common.hs | 53 ++++++ .../PureScript/Sugar/Operators/Expr.hs | 52 ++++++ src/Language/PureScript/TypeChecker.hs | 59 ++++-- src/Language/PureScript/TypeChecker/Types.hs | 6 + 21 files changed, 451 insertions(+), 120 deletions(-) create mode 100644 examples/failing/DctorOperatorAliasExport.purs create mode 100644 examples/failing/InvalidOperatorInBinder.purs create mode 100644 examples/passing/DctorOperatorAlias.purs create mode 100644 src/Language/PureScript/Sugar/Operators/Binders.hs create mode 100644 src/Language/PureScript/Sugar/Operators/Common.hs create mode 100644 src/Language/PureScript/Sugar/Operators/Expr.hs diff --git a/examples/failing/DctorOperatorAliasExport.purs b/examples/failing/DctorOperatorAliasExport.purs new file mode 100644 index 0000000000..0f46596c1d --- /dev/null +++ b/examples/failing/DctorOperatorAliasExport.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith TransitiveDctorExportError +module Data.List (List, (:)) where + + data List a = Cons a (List a) | Nil + + infixr 6 Cons as : diff --git a/examples/failing/InvalidOperatorInBinder.purs b/examples/failing/InvalidOperatorInBinder.purs new file mode 100644 index 0000000000..5cf6fd852f --- /dev/null +++ b/examples/failing/InvalidOperatorInBinder.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith InvalidOperatorInBinder +module Main where + +data List a = Cons a (List a) | Nil + +cons ∷ ∀ a. a → List a → List a +cons = Cons + +infixl 6 cons as : + +get ∷ ∀ a. List a → a +get (_ : x : _) = x diff --git a/examples/passing/DctorOperatorAlias.purs b/examples/passing/DctorOperatorAlias.purs new file mode 100644 index 0000000000..31b00271c6 --- /dev/null +++ b/examples/passing/DctorOperatorAlias.purs @@ -0,0 +1,35 @@ +module Data.List where + + data List a = Cons a (List a) | Nil + + infixr 6 Cons as : + +module Main where + + import Prelude (Unit, bind, (==)) + import Control.Monad.Eff (Eff) + import Control.Monad.Eff.Console (CONSOLE, log) + import Test.Assert (ASSERT, assert') + import Data.List (List(..), (:)) + + infixl 6 Cons as ! + + get1 ∷ ∀ a. a → List a → a + get1 y xs = case xs of + _ : x : _ → x + _ → y + + get2 ∷ ∀ a. a → List a → a + get2 _ (_ : x : _) = x + get2 y _ = y + + get3 ∷ ∀ a. a → List a → a + get3 _ (_ ! (x ! _)) = x + get3 y _ = y + + main ∷ Eff (assert ∷ ASSERT, console ∷ CONSOLE) Unit + main = do + assert' "Incorrect result!" (get1 0 (1 : 2 : 3 : Nil) == 2) + assert' "Incorrect result!" (get2 0 (1 ! (2 ! (3 ! Nil))) == 2) + assert' "Incorrect result!" (get3 0.0 (1.0 : 2.0 : (3.0 ! Nil)) == 2.0) + log "Done" diff --git a/purescript.cabal b/purescript.cabal index de5358099b..a1c13a0bb6 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -149,6 +149,9 @@ library Language.PureScript.Sugar.Names.Exports Language.PureScript.Sugar.ObjectWildcards Language.PureScript.Sugar.Operators + Language.PureScript.Sugar.Operators.Common + Language.PureScript.Sugar.Operators.Expr + Language.PureScript.Sugar.Operators.Binders Language.PureScript.Sugar.TypeClasses Language.PureScript.Sugar.TypeClasses.Deriving Language.PureScript.Sugar.TypeDeclarations diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index d0b6b81c19..2ff3fe48d7 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -41,6 +41,24 @@ data Binder -- | ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder] -- | + -- A operator alias binder. During the rebracketing phase of desugaring, + -- this data constructor will be removed. + -- + | OpBinder (Qualified Ident) + -- | + -- Binary operator application. During the rebracketing phase of desugaring, + -- this data constructor will be removed. + -- + | BinaryNoParensBinder Binder Binder Binder + -- | + -- Explicit parentheses. During the rebracketing phase of desugaring, this + -- data constructor will be removed. + -- + -- Note: although it seems this constructor is not used, it _is_ useful, + -- since it prevents certain traversals from matching. + -- + | ParensInBinder Binder + -- | -- A binder which matches a record and binds its properties -- | ObjectBinder [(String, Binder)] @@ -70,6 +88,8 @@ binderNames = go [] where go ns (VarBinder name) = name : ns go ns (ConstructorBinder _ bs) = foldl go ns bs + go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3] + go ns (ParensInBinder b) = go ns b go ns (ObjectBinder bs) = foldl go ns (map snd bs) go ns (ArrayBinder bs) = foldl go ns bs go ns (NamedBinder name b) = go (name : ns) b diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 843227ca78..2b92a04df1 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -189,7 +189,7 @@ data Declaration -- | -- A fixity declaration (fixity data, operator name, value the operator is an alias for) -- - | FixityDeclaration Fixity String (Maybe (Qualified Ident)) + | FixityDeclaration Fixity String (Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName)))) -- | -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name) -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 37a563c42f..ce800a27f4 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -69,6 +69,8 @@ everywhereOnValues f g h = (f', g', h') h' :: Binder -> Binder h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs)) + h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3)) + h' (ParensInBinder b) = h (ParensInBinder (h' b)) h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs)) h' (ArrayBinder bs) = h (ArrayBinder (map h' bs)) h' (NamedBinder name b) = h (NamedBinder name (h' b)) @@ -124,6 +126,8 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' other = g other h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs + h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h') + h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h') h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h') @@ -175,6 +179,8 @@ everywhereOnValuesM f g h = (f', g', h') g' other = g other h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h + h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h + h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h @@ -229,6 +235,8 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') g' v = g v h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs) + h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3 + h' b@(ParensInBinder b1) = h b <> h' b1 h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs) h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs) h' b@(NamedBinder _ b1) = h b <> h' b1 @@ -296,6 +304,8 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' h'' s b = let (s', r) = h s b in r <> h' s' b h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs) + h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3 + h' s (ParensInBinder b) = h'' s b h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs) h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs) h' s (NamedBinder _ b1) = h'' s b1 @@ -364,6 +374,8 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j h'' s = uncurry h' <=< h s h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs + h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3 + h' s (ParensInBinder b) = ParensInBinder <$> h'' s b h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs h' s (NamedBinder name b) = NamedBinder name <$> h'' s b @@ -451,11 +463,11 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) h'' s a = h s a <> h' s a h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs + h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3] + h' s (ParensInBinder b) = h'' s b h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs h' s (ArrayBinder bs) = foldMap (h'' s) bs - h' s (NamedBinder name b1) = - let s' = S.insert name s - in h'' s' b1 + h' s (NamedBinder name b1) = h'' (S.insert name s) b1 h' s (PositionedBinder _ _ b1) = h'' s b1 h' s (TypedBinder _ b1) = h'' s b1 h' _ _ = mempty diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index dbc971784d..e73a4bbcba 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -55,7 +55,9 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) = [NonRec name (exprToCoreFn ss com Nothing e)] declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) = - [NonRec (Op name) (Var (ss, com, Nothing, getValueMeta alias) alias)] + let meta = either getValueMeta (Just . getConstructorMeta) alias + alias' = either id (fmap properToIdent) alias + in [NonRec (Op name) (Var (ss, com, Nothing, meta) alias')] declToCoreFn ss _ (A.BindingGroupDeclaration ds) = [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds] declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) = @@ -157,6 +159,12 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = binderToCoreFn (Just ss) (com ++ com1) b binderToCoreFn ss com (A.TypedBinder _ b) = binderToCoreFn ss com b + binderToCoreFn _ _ A.OpBinder{} = + internalError "OpBinder should have been desugared before binderToCoreFn" + binderToCoreFn _ _ A.BinaryNoParensBinder{} = + internalError "BinaryNoParensBinder should have been desugared before binderToCoreFn" + binderToCoreFn _ _ A.ParensInBinder{} = + internalError "ParensInBinder should have been desugared before binderToCoreFn" -- | -- Gets metadata for values. @@ -201,19 +209,23 @@ findQualModules decls = in f `concatMap` decls where fqDecls :: A.Declaration -> [ModuleName] - fqDecls (A.TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn] - fqDecls (A.FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn] + fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q + fqDecls (A.FixityDeclaration _ _ (Just eq)) = either getQual getQual eq fqDecls _ = [] fqValues :: A.Expr -> [ModuleName] - fqValues (A.Var (Qualified (Just mn) _)) = [mn] - fqValues (A.Constructor (Qualified (Just mn) _)) = [mn] + fqValues (A.Var q) = getQual q + fqValues (A.Constructor q) = getQual q fqValues _ = [] fqBinders :: A.Binder -> [ModuleName] - fqBinders (A.ConstructorBinder (Qualified (Just mn) _) _) = [mn] + fqBinders (A.ConstructorBinder q _) = getQual q fqBinders _ = [] + getQual :: Qualified a -> [ModuleName] + getQual (Qualified (Just mn) _) = [mn] + getQual _ = [] + -- | -- Desugars import declarations from AST to CoreFn representation. -- diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index d954fcc1ce..ca53c9107b 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -61,7 +61,11 @@ renderDeclarationWithOptions opts Declaration{..} = AliasDeclaration for (P.Fixity associativity precedence) -> [ keywordFixity associativity , syntax $ show precedence - , ident $ P.showQualified P.runIdent $ dequalifyCurrentModule for + , ident $ + either + (P.showQualified P.runIdent . dequalifyCurrentModule) + (P.showQualified P.runProperName . dequalifyCurrentModule) + for , keyword "as" , ident . tail . init $ declTitle ] diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 600429f313..28bbad45df 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -133,7 +133,7 @@ data DeclarationInfo -- An operator alias declaration, with the member the alias is for and the -- operator's fixity. -- - | AliasDeclaration (P.Qualified P.Ident) P.Fixity + | AliasDeclaration (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName))) P.Fixity deriving (Show, Eq, Ord) declInfoToString :: DeclarationInfo -> String @@ -406,11 +406,14 @@ asDeclarationInfo = do TypeClassDeclaration <$> key "arguments" asTypeArguments <*> key "superclasses" (eachInArray asConstraint) "alias" -> - AliasDeclaration <$> key "for" asQualifiedIdent + AliasDeclaration <$> key "for" asAliasFor <*> key "fixity" asFixity other -> throwCustomError (InvalidDeclarationType other) +asAliasFor :: Parse e (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName))) +asAliasFor = fromAesonParser + asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)] asTypeArguments = eachInArray asTypeArgument where diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index b5216efbcc..f220306097 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -113,6 +113,7 @@ data SimpleErrorMessage | InvalidNewtype (ProperName 'TypeName) | InvalidInstanceHead Type | TransitiveExportError DeclarationRef [DeclarationRef] + | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName) | ShadowedName Ident | ShadowedTypeVar String | UnusedTypeVar String @@ -145,6 +146,7 @@ data SimpleErrorMessage | HidingImport ModuleName [DeclarationRef] | CaseBinderLengthDiffers Int [Binder] | IncorrectAnonymousArgument + | InvalidOperatorInBinder Ident Ident deriving (Show) -- | Error message hints, providing more detailed information about failure. @@ -290,6 +292,7 @@ errorCode em = case unwrapErrorMessage em of InvalidNewtype{} -> "InvalidNewtype" InvalidInstanceHead{} -> "InvalidInstanceHead" TransitiveExportError{} -> "TransitiveExportError" + TransitiveDctorExportError{} -> "TransitiveDctorExportError" ShadowedName{} -> "ShadowedName" ShadowedTypeVar{} -> "ShadowedTypeVar" UnusedTypeVar{} -> "UnusedTypeVar" @@ -322,6 +325,7 @@ errorCode em = case unwrapErrorMessage em of HidingImport{} -> "HidingImport" CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers" IncorrectAnonymousArgument -> "IncorrectAnonymousArgument" + InvalidOperatorInBinder{} -> "InvalidOperatorInBinder" -- | -- A stack trace for an error @@ -789,6 +793,10 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: " , indent $ paras $ map (line . prettyPrintExport) ys ] + renderSimpleErrorMessage (TransitiveDctorExportError x ctor) = + paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following data constructor to also be exported: " + , indent $ line $ runProperName ctor + ] renderSimpleErrorMessage (ShadowedName nm) = line $ "Name '" ++ showIdent nm ++ "' was shadowed." renderSimpleErrorMessage (ShadowedTypeVar tv) = @@ -952,6 +960,11 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap renderSimpleErrorMessage IncorrectAnonymousArgument = line "An anonymous function argument appears in an invalid context." + renderSimpleErrorMessage (InvalidOperatorInBinder op fn) = + paras $ [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "." + , line "Only aliases for data constructors may be used in patterns." + ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 5bdc3049ba..b334a8bf5d 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -73,7 +73,7 @@ data ExternsFixity = ExternsFixity -- | The operator symbol , efOperator :: String -- | The value the operator is an alias for - , efAlias :: Maybe (Qualified Ident) + , efAlias :: Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))) } deriving (Show, Read) -- | A type or value declaration appearing in an externs file @@ -153,7 +153,8 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} efDeclarations = concatMap toExternsDeclaration efExports fixityDecl :: Declaration -> Maybe ExternsFixity - fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) = fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps) + fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) = + fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps) where exportsOp :: DeclarationRef -> Bool exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index b1f3e845f7..93b85e8329 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -61,7 +61,8 @@ usedModules d = where forDecls :: Declaration -> [ModuleName] forDecls (ImportDeclaration mn _ _ _) = [mn] - forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn] + forDecls (FixityDeclaration _ _ (Just (Left (Qualified (Just mn) _)))) = [mn] + forDecls (FixityDeclaration _ _ (Just (Right (Qualified (Just mn) _)))) = [mn] forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn] forDecls _ = [] diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 0d890d38ea..c6e9ad464c 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -122,9 +122,12 @@ parseFixityDeclaration :: TokenParser Declaration parseFixityDeclaration = do fixity <- parseFixity indented - alias <- P.optionMaybe $ parseQualified (Ident <$> identifier) <* reserved "as" + alias <- P.optionMaybe $ aliased <* reserved "as" name <- symbol return $ FixityDeclaration fixity name alias + where + aliased = (Left <$> parseQualified (Ident <$> identifier)) + <|> (Right <$> parseQualified (ProperName <$> uname)) parseImportDeclaration :: TokenParser Declaration parseImportDeclaration = do @@ -519,8 +522,19 @@ parseIdentifierAndBinder = -- Parse a binder -- parseBinder :: TokenParser Binder -parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable parseBinderAtom) +parseBinder = + withSourceSpan + PositionedBinder + ( P.buildExpressionParser operators + . buildPostfixParser postfixTable + $ parseBinderAtom + ) where + operators = + [ [ P.Infix (P.try (C.indented *> parseOpBinder P. "binder operator") >>= \op -> + return (BinaryNoParensBinder op)) P.AssocRight + ] + ] -- TODO: parsePolyType when adding support for polymorphic types postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType) ] @@ -535,9 +549,12 @@ parseBinder = withSourceSpan PositionedBinder (buildPostfixParser postfixTable p , parseConstructorBinder , parseObjectBinder , parseArrayBinder - , parens parseBinder + , ParensInBinder <$> parens parseBinder ] P. "binder" + parseOpBinder :: TokenParser Binder + parseOpBinder = OpBinder <$> parseQualified (Op <$> symbol) + -- | -- Parse a binder as it would appear in a top level declaration -- @@ -552,7 +569,7 @@ parseBinderNoParens = P.choice , parseNullaryConstructorBinder , parseObjectBinder , parseArrayBinder - , parens parseBinder + , ParensInBinder <$> parens parseBinder ] P. "binder" -- | diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index c3f8e7eac4..0df1869dcf 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -169,7 +169,7 @@ renameInModule env imports (Module ss coms mn decls exps) = updateDecl (pos, bound) (ExternDeclaration name ty) = (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty) updateDecl (pos, bound) (FixityDeclaration fx name alias) = - (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (`updateValueName` pos) alias) + (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (eitherM (`updateValueName` pos) (`updateDataConstructorName` pos)) alias) updateDecl s d = return (s, d) updateValue @@ -204,6 +204,8 @@ renameInModule env imports (Module ss coms mn decls exps) = return ((Just pos, bound), v) updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b) + updateBinder s@(pos, _) (OpBinder name) = + (,) s <$> (OpBinder <$> updateValueName name pos) updateBinder s (TypedBinder t b) = do (s'@ (span', _), b') <- updateBinder s b t' <- updateTypesEverywhere span' t diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 4d401facf2..4b09c2c0b2 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -20,51 +20,92 @@ module Language.PureScript.Sugar.Operators ( import Prelude () import Prelude.Compat -import Language.PureScript.Crash import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Errors -import Language.PureScript.Names import Language.PureScript.Externs +import Language.PureScript.Names +import Language.PureScript.Sugar.Operators.Binders +import Language.PureScript.Sugar.Operators.Expr +import Language.PureScript.Traversals (defS) -import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class import Data.Function (on) -import Data.Functor.Identity import Data.List (groupBy, sortBy) -import Data.Maybe (mapMaybe, fromMaybe) +import Data.Maybe (mapMaybe) import qualified Data.Map as M -import qualified Text.Parsec as P -import qualified Text.Parsec.Pos as P -import qualified Text.Parsec.Expr as P - import qualified Language.PureScript.Constants as C +-- TODO: in 0.9 operators names can have their own type rather than being in a sum with `Ident`, and `AliasName` no longer needs to be optional + +-- | +-- An operator associated with its declaration position, fixity, and the name +-- of the function or data constructor it is an alias for. +-- +type FixityRecord = (Qualified Ident, SourceSpan, Fixity, Maybe AliasName) + +-- | +-- An operator can be an alias for a function or a data constructor. +-- +type AliasName = Either (Qualified Ident) (Qualified (ProperName 'ConstructorName)) + -- | -- Remove explicit parentheses and reorder binary operator applications -- -rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] +rebracket + :: forall m + . (Applicative m, MonadError MultipleErrors m) + => [ExternsFile] + -> [Module] + -> m [Module] rebracket externs ms = do let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms ensureNoDuplicates $ map (\(i, pos, _, _) -> (i, pos)) fixities let opTable = customOperatorTable $ map (\(i, _, f, _) -> (i, f)) fixities ms' <- traverse (rebracketModule opTable) ms let aliased = M.fromList (mapMaybe makeLookupEntry fixities) - return $ renameAliasedOperators aliased `map` ms' + mapM (renameAliasedOperators aliased) ms' where - makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident)) -> Maybe (Qualified Ident, Qualified Ident) + makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, AliasName) makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias - renameAliasedOperators :: M.Map (Qualified Ident) (Qualified Ident) -> Module -> Module - renameAliasedOperators aliased (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts + renameAliasedOperators :: M.Map (Qualified Ident) AliasName -> Module -> m Module + renameAliasedOperators aliased (Module ss coms mn ds exts) = + Module ss coms mn <$> mapM f' ds <*> pure exts where - (f', _, _) = everywhereOnValues id go id - go (Var name) = Var $ fromMaybe name (name `M.lookup` aliased) - go other = other + (f', _, _, _, _) = everywhereWithContextOnValuesM Nothing goDecl goExpr goBinder defS defS + + goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration) + goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d) + goDecl pos other = return (pos, other) + + goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) + goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) + goExpr pos (Var name) = return (pos, case name `M.lookup` aliased of + Just (Left alias) -> Var alias + Just (Right alias) -> Constructor alias + Nothing -> Var name) + goExpr pos other = return (pos, other) + + goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) + goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b) + goBinder pos (BinaryNoParensBinder (OpBinder name) lhs rhs) = case name `M.lookup` aliased of + Just (Left alias) -> + maybe id rethrowWithPosition pos $ + throwError . errorMessage $ InvalidOperatorInBinder (disqualify name) (disqualify alias) + Just (Right alias) -> + return (pos, ConstructorBinder alias [lhs, rhs]) + Nothing -> + maybe id rethrowWithPosition pos $ + throwError . errorMessage $ UnknownValue name + goBinder _ (BinaryNoParensBinder _ _ _) = + internalError "BinaryNoParensBinder has no OpBinder" + goBinder pos other = return (pos, other) removeSignedLiterals :: Module -> Module removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts @@ -74,35 +115,46 @@ removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val go other = other -rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module +rebracketModule + :: (Applicative m, MonadError MultipleErrors m) + => [[(Qualified Ident, Associativity)]] + -> Module + -> m Module rebracketModule opTable (Module ss coms mn ds exts) = - let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return + let (f, _, _) = everywhereOnValuesTopDownM return (matchExprOperators opTable) (matchBinderOperators opTable) in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts removeParens :: Declaration -> Declaration removeParens = - let (f, _, _) = everywhereOnValues id go id + let (f, _, _) = everywhereOnValues id goExpr goBinder in f where - go (Parens val) = val - go val = val - -externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))] + goExpr (Parens val) = val + goExpr val = val + goBinder (ParensInBinder b) = b + goBinder b = b + +externsFixities + :: ExternsFile + -> [FixityRecord] externsFixities ExternsFile{..} = [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias) | ExternsFixity assoc prec op alias <- efFixities ] -collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))] +collectFixities :: Module -> [FixityRecord] collectFixities (Module _ _ moduleName ds _) = concatMap collect ds where - collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))] + collect :: Declaration -> [FixityRecord] collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) = [(Qualified (Just moduleName) (Op name), pos, fixity, alias)] collect FixityDeclaration{} = internalError "Fixity without srcpos info" collect _ = [] -ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m () +ensureNoDuplicates + :: MonadError MultipleErrors m + => [(Qualified Ident, SourceSpan)] + -> m () ensureNoDuplicates m = go $ sortBy (compare `on` fst) m where go [] = return () @@ -113,63 +165,24 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m throwError . errorMessage $ MultipleFixities name go (_ : rest) = go rest -customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] +customOperatorTable + :: [(Qualified Ident, Fixity)] + -> [[(Qualified Ident, Associativity)]] customOperatorTable fixities = let - applyUserOp ident t1 = App (App (Var ident) t1) - userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities - sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps - groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted + userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities + sorted = sortBy (flip compare `on` (\(_, p, _) -> p)) userOps + groups = groupBy ((==) `on` (\(_, p, _) -> p)) sorted in - map (map (\(name, f, _, a) -> (name, f, a))) groups - -type Chain = [Either Expr Expr] - -matchOperators :: forall m. (MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> m Expr -matchOperators ops = parseChains - where - parseChains :: Expr -> m Expr - parseChains b@BinaryNoParens{} = bracketChain (extendChain b) - parseChains other = return other - extendChain :: Expr -> Chain - extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r - extendChain other = [Left other] - bracketChain :: Chain -> m Expr - bracketChain = either (\_ -> internalError "matchOperators: cannot reorder operators") return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression" - opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft] - : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops - ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]] - -toAssoc :: Associativity -> P.Assoc -toAssoc Infixl = P.AssocLeft -toAssoc Infixr = P.AssocRight -toAssoc Infix = P.AssocNone - -token :: (P.Stream s Identity t) => (t -> Maybe a) -> P.Parsec s u a -token = P.token (const "") (const (P.initialPos "")) - -parseValue :: P.Parsec Chain () Expr -parseValue = token (either Just (const Nothing)) P. "expression" - -parseOp :: P.Parsec Chain () (Qualified Ident) -parseOp = token (either (const Nothing) fromOp) P. "operator" - where - fromOp (Var q@(Qualified _ (Op _))) = Just q - fromOp _ = Nothing - -parseTicks :: P.Parsec Chain () Expr -parseTicks = token (either (const Nothing) fromOther) P. "infix function" - where - fromOther (Var (Qualified _ (Op _))) = Nothing - fromOther v = Just v - -matchOp :: Qualified Ident -> P.Parsec Chain () () -matchOp op = do - ident <- parseOp - guard $ ident == op - -desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module -desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> traverse goDecl ds <*> pure exts + map (map (\(name, _, a) -> (name, a))) groups + +desugarOperatorSections + :: forall m + . (Applicative m, MonadSupply m, MonadError MultipleErrors m) + => Module + -> m Module +desugarOperatorSections (Module ss coms mn ds exts) = + Module ss coms mn <$> traverse goDecl ds <*> pure exts where goDecl :: Declaration -> m Declaration diff --git a/src/Language/PureScript/Sugar/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs new file mode 100644 index 0000000000..fc6fbf7b64 --- /dev/null +++ b/src/Language/PureScript/Sugar/Operators/Binders.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.PureScript.Sugar.Operators.Binders where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Error.Class (MonadError(..)) + +import qualified Text.Parsec as P +import qualified Text.Parsec.Expr as P + +import Language.PureScript.Crash +import Language.PureScript.AST +import Language.PureScript.Errors +import Language.PureScript.Names +import Language.PureScript.Sugar.Operators.Common + +matchBinderOperators + :: forall m + . MonadError MultipleErrors m + => [[(Qualified Ident, Associativity)]] + -> Binder + -> m Binder +matchBinderOperators ops = parseChains + where + parseChains :: Binder -> m Binder + parseChains b@BinaryNoParensBinder{} = bracketChain (extendChain b) + parseChains other = return other + extendChain :: Binder -> Chain Binder + extendChain (BinaryNoParensBinder op l r) = Left l : Right op : extendChain r + extendChain other = [Left other] + bracketChain :: Chain Binder -> m Binder + bracketChain = + either + (\_ -> internalError "matchBinderOperators: cannot reorder operators") + return + . P.parse opParser "operator expression" + opParser = P.buildExpressionParser (opTable ops fromOp reapply) parseValue <* P.eof + fromOp (OpBinder q@(Qualified _ (Op _))) = Just q + fromOp _ = Nothing + reapply = BinaryNoParensBinder . OpBinder diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs new file mode 100644 index 0000000000..a447ab6d9a --- /dev/null +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.PureScript.Sugar.Operators.Common where + +import Prelude () +import Prelude.Compat + +import Control.Monad.State + +import Data.Functor.Identity + +import qualified Text.Parsec as P +import qualified Text.Parsec.Pos as P +import qualified Text.Parsec.Expr as P + +import Language.PureScript.AST +import Language.PureScript.Names + +type Chain a = [Either a a] + +toAssoc :: Associativity -> P.Assoc +toAssoc Infixl = P.AssocLeft +toAssoc Infixr = P.AssocRight +toAssoc Infix = P.AssocNone + +token :: (P.Stream s Identity t) => (t -> Maybe a) -> P.Parsec s u a +token = P.token (const "") (const (P.initialPos "")) + +parseValue :: P.Parsec (Chain a) () a +parseValue = token (either Just (const Nothing)) P. "expression" + +parseOp + :: (a -> (Maybe (Qualified Ident))) + -> P.Parsec (Chain a) () (Qualified Ident) +parseOp fromOp = token (either (const Nothing) fromOp) P. "operator" + +matchOp + :: (a -> (Maybe (Qualified Ident))) + -> Qualified Ident + -> P.Parsec (Chain a) () () +matchOp fromOp op = do + ident <- parseOp fromOp + guard $ ident == op + +opTable + :: [[(Qualified Ident, Associativity)]] + -> (a -> Maybe (Qualified Ident)) + -> (Qualified Ident -> a -> a -> a) + -> [[P.Operator (Chain a) () Identity a]] +opTable ops fromOp reapply = + map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >> return (reapply name)) (toAssoc a))) ops + ++ [[ P.Infix (P.try (parseOp fromOp >>= \ident -> return (reapply ident))) P.AssocLeft ]] diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs new file mode 100644 index 0000000000..7ffafdf775 --- /dev/null +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.PureScript.Sugar.Operators.Expr where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Error.Class (MonadError(..)) + +import qualified Text.Parsec as P +import qualified Text.Parsec.Expr as P + +import Language.PureScript.Crash +import Language.PureScript.AST +import Language.PureScript.Errors +import Language.PureScript.Names +import Language.PureScript.Sugar.Operators.Common + +matchExprOperators + :: forall m + . MonadError MultipleErrors m + => [[(Qualified Ident, Associativity)]] + -> Expr + -> m Expr +matchExprOperators ops = parseChains + where + parseChains :: Expr -> m Expr + parseChains b@BinaryNoParens{} = bracketChain (extendChain b) + parseChains other = return other + extendChain :: Expr -> Chain Expr + extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r + extendChain other = [Left other] + bracketChain :: Chain Expr -> m Expr + bracketChain = + either + (\_ -> internalError "matchExprOperators: cannot reorder operators") + return + . P.parse opParser "operator expression" + opParser = P.buildExpressionParser opTable' parseValue <* P.eof + opTable' = + [ P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft ] + : opTable ops fromOp reapply + fromOp (Var q@(Qualified _ (Op _))) = Just q + fromOp _ = Nothing + reapply op t1 t2 = App (App (Var op) t1) t2 + +parseTicks :: P.Parsec (Chain Expr) () Expr +parseTicks = token (either (const Nothing) fromOther) P. "infix function" + where + fromOther (Var (Qualified _ (Op _))) = Nothing + fromOther v = Just v diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index cc58e6db00..6684639942 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -19,7 +19,7 @@ import Language.PureScript.TypeChecker.Types as T import Language.PureScript.TypeChecker.Synonyms as T import Data.Maybe -import Data.List (nub, (\\), sort, group) +import Data.List (nub, nubBy, (\\), sort, group) import Data.Foldable (for_, traverse_) import qualified Data.Map as M @@ -30,14 +30,14 @@ import Control.Monad.State.Class (MonadState(..), modify) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) -import Language.PureScript.Crash -import Language.PureScript.Types -import Language.PureScript.Names -import Language.PureScript.Kinds import Language.PureScript.AST -import Language.PureScript.TypeClassDictionaries +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors +import Language.PureScript.Kinds +import Language.PureScript.Names +import Language.PureScript.TypeClassDictionaries +import Language.PureScript.Types addDataType :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) @@ -281,9 +281,14 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d checkFixities :: Declaration -> m () - checkFixities (FixityDeclaration _ name (Just alias)) = do + checkFixities (FixityDeclaration _ name (Just (Left alias))) = do ty <- lookupVariable moduleName alias addValue moduleName (Op name) ty Public + checkFixities (FixityDeclaration _ name (Just (Right alias))) = do + env <- getEnv + case M.lookup alias (dataConstructors env) of + Nothing -> throwError . errorMessage $ UnknownDataConstructor alias Nothing + Just (_, _, ty, _) -> addValue moduleName (Op name) ty Public checkFixities (FixityDeclaration _ name _) = do env <- getEnv guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env @@ -349,7 +354,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint checkTypesAreExported e checkClassMembersAreExported e checkClassesAreExported e - checkNonAliasesAreExported e + checkNonAliasesAreExported (exportedDataConstructors exps) e return $ Module ss coms mn decls' (Just exps) where @@ -374,7 +379,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m () checkExport dr extract ty = case filter (not . exported) (extract ty) of [] -> return () - hidden -> throwError . errorMessage $ TransitiveExportError dr hidden + hidden -> throwError . errorMessage $ TransitiveExportError dr (nubBy nubEq hidden) where exported e = any (exports e) exps exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2 @@ -383,6 +388,11 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2 exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2 exports _ _ = False + -- We avoid Eq for `nub`bing as the dctor part of `TypeRef` evaluates to + -- `error` for the values generated here (we don't need them anyway) + nubEq (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2 + nubEq r1 r2 = r1 == r2 + -- Check that all the type constructors defined in the current module that appear in member types -- have also been exported from the module @@ -425,17 +435,30 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint extractMemberName _ = internalError "Unexpected declaration in typeclass member list" checkClassMembersAreExported _ = return () - checkNonAliasesAreExported :: DeclarationRef -> m () - checkNonAliasesAreExported dr@(ValueRef (Op name)) = + checkNonAliasesAreExported :: [ProperName 'ConstructorName] -> DeclarationRef -> m () + checkNonAliasesAreExported exportedDctors dr@(ValueRef (Op name)) = case listToMaybe (mapMaybe getAlias decls) of - Just alias -> - unless (ValueRef alias `elem` exps) $ - throwError . errorMessage $ TransitiveExportError dr [ValueRef alias] + Just (Left ident) -> + unless (ValueRef ident `elem` exps) $ + throwError . errorMessage $ TransitiveExportError dr [ValueRef ident] + Just (Right ctor) -> + unless (ctor `elem` exportedDctors) $ + throwError . errorMessage $ TransitiveDctorExportError dr ctor _ -> return () where - getAlias :: Declaration -> Maybe Ident + getAlias :: Declaration -> Maybe (Either Ident (ProperName 'ConstructorName)) getAlias (PositionedDeclaration _ _ d) = getAlias d - getAlias (FixityDeclaration _ name' (Just (Qualified (Just mn') alias))) - | mn == mn' && name == name' = Just alias + getAlias (FixityDeclaration _ name' (Just alias)) | name == name' = + case alias of + Left (Qualified (Just mn') ident) | mn == mn' -> Just (Left ident) + Right (Qualified (Just mn') ctor) | mn == mn' -> Just (Right ctor) + _ -> Nothing getAlias _ = Nothing - checkNonAliasesAreExported _ = return () + checkNonAliasesAreExported _ _ = return () + + exportedDataConstructors :: [DeclarationRef] -> [ProperName 'ConstructorName] + exportedDataConstructors = foldMap extractCtor + where + extractCtor :: DeclarationRef -> [ProperName 'ConstructorName] + extractCtor (TypeRef _ (Just ctors)) = ctors + extractCtor _ = [] diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index fbeb3210a6..97acd0e1ff 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -400,6 +400,12 @@ inferBinder val (TypedBinder ty binder) = do ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty unifyTypes val ty1 inferBinder val binder +inferBinder _ OpBinder{} = + internalError "OpBinder should have been desugared before inferBinder" +inferBinder _ BinaryNoParensBinder{} = + internalError "BinaryNoParensBinder should have been desugared before inferBinder" +inferBinder _ ParensInBinder{} = + internalError "ParensInBinder should have been desugared before inferBinder" -- | Returns true if a binder requires its argument type to be a monotype. -- | If this is the case, we need to instantiate any polymorphic types before checking binders. From 849459eb97e17ea37540a0c8d9eb1b6021c99ed3 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 21 Feb 2016 13:06:40 +0000 Subject: [PATCH 0291/1580] Add Source Map support. - Add sourcemaps license. Manually removed a few deletions - Use Emit typeclass, move JS sourcespans into each ctor - Remove sourcemaps from stackage build plans for travis, version is too old - Keep source positions for literals --- .travis.yml | 2 +- LICENSE | 34 +++ psc/Main.hs | 6 + purescript.cabal | 3 +- src/Language/PureScript/CodeGen/JS.hs | 263 +++++++++-------- src/Language/PureScript/CodeGen/JS/AST.hs | 265 +++++++++++------- .../PureScript/CodeGen/JS/Optimizer.hs | 10 +- .../PureScript/CodeGen/JS/Optimizer/Blocks.hs | 8 +- .../PureScript/CodeGen/JS/Optimizer/Common.hs | 36 +-- .../CodeGen/JS/Optimizer/Inliner.hs | 100 +++---- .../CodeGen/JS/Optimizer/MagicDo.hs | 68 ++--- .../PureScript/CodeGen/JS/Optimizer/TCO.hs | 64 +++-- .../PureScript/CodeGen/JS/Optimizer/Unused.hs | 6 +- src/Language/PureScript/CoreFn/Binders.hs | 11 +- src/Language/PureScript/CoreFn/Desugar.hs | 53 ++-- src/Language/PureScript/CoreFn/Expr.hs | 8 +- src/Language/PureScript/CoreFn/Meta.hs | 6 +- src/Language/PureScript/CoreFn/Module.hs | 2 +- src/Language/PureScript/CoreFn/Traversals.hs | 4 +- src/Language/PureScript/Make.hs | 47 +++- src/Language/PureScript/Options.hs | 5 +- .../PureScript/Parser/Declarations.hs | 2 +- src/Language/PureScript/Pretty.hs | 3 - src/Language/PureScript/Pretty/Common.hs | 105 ++++++- src/Language/PureScript/Pretty/JS.hs | 223 ++++++++------- src/Language/PureScript/Pretty/Values.hs | 2 - src/Language/PureScript/Renamer.hs | 18 +- src/Language/PureScript/TypeChecker/Types.hs | 9 +- stack-lts-2.yaml | 1 + stack-lts-3.yaml | 3 +- stack-nightly.yaml | 1 + 31 files changed, 830 insertions(+), 538 deletions(-) diff --git a/.travis.yml b/.travis.yml index c83c1b1a31..ef17b76983 100644 --- a/.travis.yml +++ b/.travis.yml @@ -51,7 +51,7 @@ install: - mkdir -p .cabal-sandbox - cabal sandbox init --sandbox .cabal-sandbox # Download stackage cabal.config, not sure whether filtering is necessary - - if [ -n "$STACKAGE" ]; then curl https://www.stackage.org/$STACKAGE/cabal.config | grep -v purescript > cabal.config; fi + - if [ -n "$STACKAGE" ]; then curl https://www.stackage.org/$STACKAGE/cabal.config | egrep -v 'purescript|sourcemap' > cabal.config; fi - cabal install --only-dependencies --enable-tests - cabal install hpc-coveralls # Snapshot state of the sandbox now, so we don't need to make new one for test install diff --git a/LICENSE b/LICENSE index 00e252bec2..1c4fc066d4 100644 --- a/LICENSE +++ b/LICENSE @@ -63,6 +63,7 @@ PureScript uses the following Haskell library packages. Their license files foll safe scientific semigroups + sourcemap split stm syb @@ -1589,6 +1590,39 @@ semigroups LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +sourcemap LICENSE file: + + Copyright (c) 2012, Chris Done + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Chris Done nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + split LICENSE file: Copyright (c) 2008 Brent Yorgey, Louis Wasserman diff --git a/psc/Main.hs b/psc/Main.hs index 6f7d8d00ba..86393469ff 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -177,6 +177,11 @@ jsonErrors :: Parser Bool jsonErrors = switch $ long "json-errors" <> help "Print errors to stderr as JSON" +sourceMaps :: Parser Bool +sourceMaps = switch $ + long "source-maps" + <> help "Generate source maps" + options :: Parser P.Options options = P.Options <$> noTco @@ -186,6 +191,7 @@ options = P.Options <$> noTco <*> verboseErrors <*> (not <$> comments) <*> requirePath + <*> sourceMaps pscMakeOptions :: Parser PSCMakeOptions pscMakeOptions = PSCMakeOptions <$> many inputFile diff --git a/purescript.cabal b/purescript.cabal index a1c13a0bb6..93a3a4de39 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -79,7 +79,8 @@ library process >= 1.2.0 && < 1.5, safe >= 0.3.9 && < 0.4, semigroups >= 0.16.2 && < 0.19, - parallel >= 3.2 && < 3.3 + parallel >= 3.2 && < 3.3, + sourcemap >= 0.1.6 exposed-modules: Language.PureScript Language.PureScript.AST diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index c77df0fe54..3b2de22b70 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -55,21 +55,21 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps - jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps + jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd $ imps let decls' = renameModules mnLookup decls jsDecls <- mapM bindToJs decls' optimized <- T.traverse (T.traverse optimize) jsDecls F.traverse_ (F.traverse_ checkIntegers) optimized comments <- not <$> asks optionsNoComments - let strict = JSStringLiteral "use strict" - let header = if comments && not (null coms) then JSComment coms strict else strict - let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_] + let strict = JSStringLiteral Nothing "use strict" + let header = if comments && not (null coms) then JSComment Nothing coms strict else strict + let foreign' = [JSVariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_] let moduleBody = header : foreign' ++ jsImports ++ concat optimized let foreignExps = exps `intersect` (fst `map` foreigns) let standardExps = exps \\ foreignExps - let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps + let exps' = JSObjectLiteral Nothing $ map (runIdent &&& (JSVar Nothing) . identToJs) standardExps ++ map (runIdent &&& foreignIdent) foreignExps - return $ moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps'] + return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps'] where @@ -77,23 +77,23 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- Extracts all declaration names from a binding group. -- getNames :: Bind Ann -> [Ident] - getNames (NonRec ident _) = [ident] - getNames (Rec vals) = map fst vals + getNames (NonRec _ ident _) = [ident] + getNames (Rec vals) = map (snd . fst) vals -- | -- Creates alternative names for each module to ensure they don't collide -- with declaration names. -- - renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName + renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName) renameImports ids mns = go M.empty ids mns where - go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName - go acc used (mn' : mns') = + go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName) + go acc used ((ann, mn') : mns') = let mni = Ident $ runModuleName mn' in if mn' /= mn && mni `elem` used then let newName = freshModuleName 1 mn' used - in go (M.insert mn' newName acc) (Ident (runModuleName newName) : used) mns' - else go (M.insert mn' mn' acc) (mni : used) mns' + in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns' + else go (M.insert mn' (ann, mn') acc) (mni : used) mns' go acc _ [] = acc freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName @@ -107,18 +107,18 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- Generates Javascript code for a module import, binding the required module -- to the alternative -- - importToJs :: M.Map ModuleName ModuleName -> ModuleName -> m JS + importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS importToJs mnLookup mn' = do path <- asks optionsRequirePath - let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - let moduleBody = JSApp (JSVar "require") [JSStringLiteral (maybe id () path $ runModuleName mn')] - return $ JSVariableIntroduction (moduleNameToJs mnSafe) (Just moduleBody) + let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup + let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (maybe id () path $ runModuleName mn')] + withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody) -- | -- Replaces the `ModuleName`s in the AST so that the generated code refers to -- the collision-avoiding renamed module imports. -- - renameModules :: M.Map ModuleName ModuleName -> [Bind Ann] -> [Bind Ann] + renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann] renameModules mnLookup binds = let (f, _, _) = everywhereOnValues id goExpr goBinder in map f binds @@ -131,7 +131,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = goBinder b = b renameQual :: Qualified a -> Qualified a renameQual (Qualified (Just mn') a) = - let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup + let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup in Qualified (Just mnSafe) a renameQual q = q @@ -139,8 +139,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- Generate code in the simplified Javascript intermediate representation for a declaration -- bindToJs :: Bind Ann -> m [JS] - bindToJs (NonRec ident val) = return <$> nonRecToJS ident val - bindToJs (Rec vals) = forM vals (uncurry nonRecToJS) + bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val + bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS) -- | -- Generate code in the simplified Javascript intermediate representation for a single non-recursive @@ -148,22 +148,30 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- -- The main purpose of this function is to handle code generation for comments. -- - nonRecToJS :: Ident -> Expr Ann -> m JS - nonRecToJS i e@(extractAnn -> (_, com, _, _)) | not (null com) = do + nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS + nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do withoutComment <- asks optionsNoComments if withoutComment - then nonRecToJS i (modifyAnn removeComments e) - else JSComment com <$> nonRecToJS i (modifyAnn removeComments e) - nonRecToJS ident val = do + then nonRecToJS a i (modifyAnn removeComments e) + else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e) + nonRecToJS (ss, _, _, _) ident val = do js <- valueToJs val - return $ JSVariableIntroduction (identToJs ident) (Just js) + withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js) + + withPos :: Maybe SourceSpan -> JS -> m JS + withPos (Just ss) js = do + withSM <- asks optionsSourceMaps + return $ if withSM + then withSourceSpan ss js + else js + withPos Nothing js = return js -- | -- Generate code in the simplified Javascript intermediate representation for a variable based on a -- PureScript identifier. -- var :: Ident -> JS - var = JSVar . identToJs + var = JSVar Nothing . identToJs -- | -- Generate code in the simplified Javascript intermediate representation for an accessor based on @@ -172,102 +180,106 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- accessor :: Ident -> JS -> JS accessor (Ident prop) = accessorString prop - accessor (Op op) = JSIndexer (JSStringLiteral op) + accessor (Op op) = JSIndexer Nothing (JSStringLiteral Nothing op) accessor (GenIdent _ _) = internalError "GenIdent in accessor" accessorString :: String -> JS -> JS - accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop) - | otherwise = JSAccessor prop + accessorString prop | identNeedsEscaping prop = JSIndexer Nothing (JSStringLiteral Nothing prop) + | otherwise = JSAccessor Nothing prop -- | -- Generate code in the simplified Javascript intermediate representation for a value or expression. -- valueToJs :: Expr Ann -> m JS - valueToJs (Literal (pos, _, _, _) l) = + valueToJs e = + let (ss, _, _, _) = extractAnn e in + withPos ss =<< valueToJs' e + + valueToJs' :: Expr Ann -> m JS + valueToJs' (Literal (pos, _, _, _) l) = maybe id rethrowWithPosition pos $ literalToValueJS l - valueToJs (Var (_, _, _, Just (IsConstructor _ [])) name) = - return $ JSAccessor "value" $ qualifiedToJS id name - valueToJs (Var (_, _, _, Just (IsConstructor _ _)) name) = - return $ JSAccessor "create" $ qualifiedToJS id name - valueToJs (Accessor _ prop val) = + valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) = + return $ JSAccessor Nothing "value" $ qualifiedToJS id name + valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) = + return $ JSAccessor Nothing "create" $ qualifiedToJS id name + valueToJs' (Accessor _ prop val) = accessorString prop <$> valueToJs val - valueToJs (ObjectUpdate _ o ps) = do + valueToJs' (ObjectUpdate _ o ps) = do obj <- valueToJs o sts <- mapM (sndM valueToJs) ps extendObj obj sts - valueToJs e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = + valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = let args = unAbs e - in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args) + in return $ JSFunction Nothing Nothing (map identToJs args) (JSBlock Nothing $ map assign args) where unAbs :: Expr Ann -> [Ident] unAbs (Abs _ arg val) = arg : unAbs val unAbs _ = [] assign :: Ident -> JS - assign name = JSAssignment (accessorString (runIdent name) (JSVar "this")) + assign name = JSAssignment Nothing (accessorString (runIdent name) (JSVar Nothing "this")) (var name) - valueToJs (Abs _ arg val) = do + valueToJs' (Abs _ arg val) = do ret <- valueToJs val - return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret]) - valueToJs e@App{} = do + return $ JSFunction Nothing Nothing [identToJs arg] (JSBlock Nothing [JSReturn Nothing ret]) + valueToJs' e@App{} = do let (f, args) = unApp e [] args' <- mapM valueToJs args case f of Var (_, _, _, Just IsNewtype) _ -> return (head args') Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields -> - return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args' + return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args' Var (_, _, _, Just IsTypeClassConstructor) name -> - return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args' - _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs f + return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args' + _ -> flip (foldl (\fn a -> JSApp Nothing fn [a])) args' <$> valueToJs f where unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann]) unApp (App _ val arg) args = unApp val (arg : args) unApp other args = (other, args) - valueToJs (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) = + valueToJs' (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) = return $ if mn' == mn then foreignIdent ident else varToJs qi - valueToJs (Var (_, _, _, Just IsForeign) ident) = + valueToJs' (Var (_, _, _, Just IsForeign) ident) = error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident - valueToJs (Var _ ident) = - return $ varToJs ident - valueToJs (Case (maybeSpan, _, _, _) values binders) = do + valueToJs' (Var _ ident) = return $ varToJs ident + valueToJs' (Case (maybeSpan, _, _, _) values binders) = do vals <- mapM valueToJs values bindersToJs maybeSpan binders vals - valueToJs (Let _ ds val) = do + valueToJs' (Let _ ds val) = do ds' <- concat <$> mapM bindToJs ds ret <- valueToJs val - return $ JSApp (JSFunction Nothing [] (JSBlock (ds' ++ [JSReturn ret]))) [] - valueToJs (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = - return $ JSVariableIntroduction ctor (Just $ - JSObjectLiteral [("create", - JSFunction Nothing ["value"] - (JSBlock [JSReturn $ JSVar "value"]))]) - valueToJs (Constructor _ _ (ProperName ctor) []) = - return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock []) - , JSAssignment (JSAccessor "value" (JSVar ctor)) - (JSUnary JSNew $ JSApp (JSVar ctor) []) ] - valueToJs (Constructor _ _ (ProperName ctor) fields) = + return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (ds' ++ [JSReturn Nothing ret]))) [] + valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = + return $ JSVariableIntroduction Nothing ctor (Just $ + JSObjectLiteral Nothing [("create", + JSFunction Nothing Nothing ["value"] + (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))]) + valueToJs' (Constructor _ _ (ProperName ctor) []) = + return $ iife ctor [ JSFunction Nothing (Just ctor) [] (JSBlock Nothing []) + , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing ctor)) + (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) []) ] + valueToJs' (Constructor _ _ (ProperName ctor) fields) = let constructor = - let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ] - in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body) + let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] + in JSFunction Nothing (Just ctor) (identToJs `map` fields) (JSBlock Nothing body) createFn = - let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields) - in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields + let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) (var `map` fields) + in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields in return $ iife ctor [ constructor - , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn + , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing ctor)) createFn ] iife :: String -> [JS] -> JS - iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) [] + iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) [] literalToValueJS :: Literal (Expr Ann) -> m JS - literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral (Left i) - literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral (Right n) - literalToValueJS (StringLiteral s) = return $ JSStringLiteral s - literalToValueJS (CharLiteral c) = return $ JSStringLiteral [c] - literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b - literalToValueJS (ArrayLiteral xs) = JSArrayLiteral <$> mapM valueToJs xs - literalToValueJS (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM valueToJs) ps + literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i) + literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n) + literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s + literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing [c] + literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b + literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs + literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps -- | -- Shallow copy an object. @@ -277,16 +289,16 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = newObj <- freshName key <- freshName let - jsKey = JSVar key - jsNewObj = JSVar newObj - block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj]) - objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral []) - copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing] - cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey] - assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)] - stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js + jsKey = JSVar Nothing key + jsNewObj = JSVar Nothing newObj + block = JSBlock Nothing (objAssign:copy:extend ++ [JSReturn Nothing jsNewObj]) + objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing []) + copy = JSForIn Nothing key obj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing] + cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" obj) [jsKey] + assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey obj)] + stToAssign (s, js) = JSAssignment Nothing (JSAccessor Nothing s jsNewObj) js extend = map stToAssign sts - return $ JSApp (JSFunction Nothing [] block) [] + return $ JSApp Nothing (JSFunction Nothing Nothing [] block) [] -- | -- Generate code in the simplified Javascript intermediate representation for a reference to a @@ -301,12 +313,12 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- variable that may have a qualified name. -- qualifiedToJS :: (a -> Ident) -> Qualified a -> JS - qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar . runIdent $ f a - qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar (moduleNameToJs mn')) - qualifiedToJS f (Qualified _ a) = JSVar $ identToJs (f a) + qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar Nothing . runIdent $ f a + qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar Nothing (moduleNameToJs mn')) + qualifiedToJS f (Qualified _ a) = JSVar Nothing $ identToJs (f a) foreignIdent :: Ident -> JS - foreignIdent ident = accessorString (runIdent ident) (JSVar "$foreign") + foreignIdent ident = accessorString (runIdent ident) (JSVar Nothing "$foreign") -- | -- Generate code in the simplified Javascript intermediate representation for pattern match binders @@ -315,11 +327,11 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [JS] -> m JS bindersToJs maybeSpan binders vals = do valNames <- replicateM (length vals) freshName - let assignments = zipWith JSVariableIntroduction valNames (map Just vals) + let assignments = zipWith (JSVariableIntroduction Nothing) valNames (map Just vals) jss <- forM binders $ \(CaseAlternative bs result) -> do ret <- guardsToJs result go valNames ret bs - return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ failedPatternError valNames]))) + return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (assignments ++ concat jss ++ [JSThrow Nothing $ failedPatternError valNames]))) [] where go :: [String] -> [JS] -> [Binder Ann] -> m [JS] @@ -330,43 +342,48 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = go _ _ _ = internalError "Invalid arguments to bindersToJs" failedPatternError :: [String] -> JS - failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral failedPatternMessage) (JSArrayLiteral $ zipWith valueError names vals)] + failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)] failedPatternMessage :: String failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": " valueError :: String -> JS -> JS - valueError _ l@(JSNumericLiteral _) = l - valueError _ l@(JSStringLiteral _) = l - valueError _ l@(JSBooleanLiteral _) = l - valueError s _ = JSAccessor "name" . JSAccessor "constructor" $ JSVar s + valueError _ l@(JSNumericLiteral _ _) = l + valueError _ l@(JSStringLiteral _ _) = l + valueError _ l@(JSBooleanLiteral _ _) = l + valueError s _ = JSAccessor Nothing "name" . JSAccessor Nothing "constructor" $ JSVar Nothing s guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS] guardsToJs (Left gs) = forM gs $ \(cond, val) -> do cond' <- valueToJs cond done <- valueToJs val - return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing - guardsToJs (Right v) = return . JSReturn <$> valueToJs v + return $ JSIfElse Nothing cond' (JSBlock Nothing [JSReturn Nothing done]) Nothing + guardsToJs (Right v) = return . JSReturn Nothing <$> valueToJs v + + binderToJs :: String -> [JS] -> Binder Ann -> m [JS] + binderToJs s done binder = + let (ss, _, _, _) = extractBinderAnn binder in + traverse (withPos ss) =<< binderToJs' s done binder -- | -- Generate code in the simplified Javascript intermediate representation for a pattern match -- binder. -- - binderToJs :: String -> [JS] -> Binder Ann -> m [JS] - binderToJs _ done (NullBinder{}) = return done - binderToJs varName done (LiteralBinder _ l) = + binderToJs' :: String -> [JS] -> Binder Ann -> m [JS] + binderToJs' _ done (NullBinder{}) = return done + binderToJs' varName done (LiteralBinder _ l) = literalToBinderJS varName done l - binderToJs varName done (VarBinder _ ident) = - return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done) - binderToJs varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) = + binderToJs' varName done (VarBinder _ ident) = + return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : done) + binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) = binderToJs varName done b - binderToJs varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do + binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do js <- go (zip fields bs) done return $ case ctorType of ProductType -> js SumType -> - [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS (Ident . runProperName) ctor)) - (JSBlock js) + [JSIfElse Nothing (JSInstanceOf Nothing (JSVar Nothing varName) (qualifiedToJS (Ident . runProperName) ctor)) + (JSBlock Nothing js) Nothing] where go :: [(Ident, Binder Ann)] -> [JS] -> m [JS] @@ -375,24 +392,24 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = argVar <- freshName done'' <- go remain done' js <- binderToJs argVar done'' binder - return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js) - binderToJs _ _ ConstructorBinder{} = + return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (identToJs field) (JSVar Nothing varName))) : js) + binderToJs' _ _ ConstructorBinder{} = internalError "binderToJs: Invalid ConstructorBinder in binderToJs" - binderToJs varName done (NamedBinder _ ident binder) = do + binderToJs' varName done (NamedBinder _ ident binder) = do js <- binderToJs varName done binder - return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js) + return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : js) literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS] literalToBinderJS varName done (NumericLiteral num) = - return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing] + return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSNumericLiteral Nothing num)) (JSBlock Nothing done) Nothing] literalToBinderJS varName done (CharLiteral c) = - return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral [c])) (JSBlock done) Nothing] + return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing [c])) (JSBlock Nothing done) Nothing] literalToBinderJS varName done (StringLiteral str) = - return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing] + return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing str)) (JSBlock Nothing done) Nothing] literalToBinderJS varName done (BooleanLiteral True) = - return [JSIfElse (JSVar varName) (JSBlock done) Nothing] + return [JSIfElse Nothing (JSVar Nothing varName) (JSBlock Nothing done) Nothing] literalToBinderJS varName done (BooleanLiteral False) = - return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing] + return [JSIfElse Nothing (JSUnary Nothing Not (JSVar Nothing varName)) (JSBlock Nothing done) Nothing] literalToBinderJS varName done (ObjectLiteral bs) = go done bs where go :: [JS] -> [(String, Binder Ann)] -> m [JS] @@ -401,10 +418,10 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = propVar <- freshName done'' <- go done' bs' js <- binderToJs propVar done'' binder - return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js) + return (JSVariableIntroduction Nothing propVar (Just (accessorString prop (JSVar Nothing varName))) : js) literalToBinderJS varName done (ArrayLiteral bs) = do js <- go done 0 bs - return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing] + return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSAccessor Nothing "length" (JSVar Nothing varName)) (JSNumericLiteral Nothing (Left (fromIntegral $ length bs)))) (JSBlock Nothing js) Nothing] where go :: [JS] -> Integer -> [Binder Ann] -> m [JS] go done' _ [] = return done' @@ -412,21 +429,21 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = elVar <- freshName done'' <- go done' (index + 1) bs' js <- binderToJs elVar done'' binder - return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js) + return (JSVariableIntroduction Nothing elVar (Just (JSIndexer Nothing (JSNumericLiteral Nothing (Left index)) (JSVar Nothing varName))) : js) -- Check that all integers fall within the valid int range for JavaScript. checkIntegers :: JS -> m () checkIntegers = void . everywhereOnJSTopDownM go where go :: JS -> m JS - go (JSUnary Negate (JSNumericLiteral (Left i))) = + go (JSUnary _ Negate (JSNumericLiteral ss (Left i))) = -- Move the negation inside the literal; since this is a top-down -- traversal doing this replacement will stop the next case from raising -- the error when attempting to use -2147483648, as if left unrewritten -- the value is `JSUnary Negate (JSNumericLiteral (Left 2147483648))`, and -- 2147483648 is larger than the maximum allowed int. - return $ JSNumericLiteral (Left (-i)) - go js@(JSNumericLiteral (Left i)) = + return $ JSNumericLiteral ss (Left (-i)) + go js@(JSNumericLiteral _ (Left i)) = let minInt = -2147483648 maxInt = 2147483647 in if i < minInt || i > maxInt diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index 3b8236d6ae..59f7bc1a5d 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -10,6 +10,7 @@ import Control.Monad.Identity import Language.PureScript.Comments import Language.PureScript.Traversals +import Language.PureScript.AST (SourceSpan(..)) -- | -- Built-in unary operators @@ -126,120 +127,190 @@ data JS -- | -- A numeric literal -- - = JSNumericLiteral (Either Integer Double) + = JSNumericLiteral (Maybe SourceSpan) (Either Integer Double) -- | -- A string literal -- - | JSStringLiteral String + | JSStringLiteral (Maybe SourceSpan) String -- | -- A boolean literal -- - | JSBooleanLiteral Bool + | JSBooleanLiteral (Maybe SourceSpan) Bool -- | -- A unary operator application -- - | JSUnary UnaryOperator JS + | JSUnary (Maybe SourceSpan) UnaryOperator JS -- | -- A binary operator application -- - | JSBinary BinaryOperator JS JS + | JSBinary (Maybe SourceSpan) BinaryOperator JS JS -- | -- An array literal -- - | JSArrayLiteral [JS] + | JSArrayLiteral (Maybe SourceSpan) [JS] -- | -- An array indexer expression -- - | JSIndexer JS JS + | JSIndexer (Maybe SourceSpan) JS JS -- | -- An object literal -- - | JSObjectLiteral [(String, JS)] + | JSObjectLiteral (Maybe SourceSpan) [(String, JS)] -- | -- An object property accessor expression -- - | JSAccessor String JS + | JSAccessor (Maybe SourceSpan) String JS -- | -- A function introduction (optional name, arguments, body) -- - | JSFunction (Maybe String) [String] JS + | JSFunction (Maybe SourceSpan) (Maybe String) [String] JS -- | -- Function application -- - | JSApp JS [JS] + | JSApp (Maybe SourceSpan) JS [JS] -- | -- Variable -- - | JSVar String + | JSVar (Maybe SourceSpan) String -- | -- Conditional expression -- - | JSConditional JS JS JS + | JSConditional (Maybe SourceSpan) JS JS JS -- | -- A block of expressions in braces -- - | JSBlock [JS] + | JSBlock (Maybe SourceSpan) [JS] -- | -- A variable introduction and optional initialization -- - | JSVariableIntroduction String (Maybe JS) + | JSVariableIntroduction (Maybe SourceSpan) String (Maybe JS) -- | -- A variable assignment -- - | JSAssignment JS JS + | JSAssignment (Maybe SourceSpan) JS JS -- | -- While loop -- - | JSWhile JS JS + | JSWhile (Maybe SourceSpan) JS JS -- | -- For loop -- - | JSFor String JS JS JS + | JSFor (Maybe SourceSpan) String JS JS JS -- | -- ForIn loop -- - | JSForIn String JS JS + | JSForIn (Maybe SourceSpan) String JS JS -- | -- If-then-else statement -- - | JSIfElse JS JS (Maybe JS) + | JSIfElse (Maybe SourceSpan) JS JS (Maybe JS) -- | -- Return statement -- - | JSReturn JS + | JSReturn (Maybe SourceSpan) JS -- | -- Throw statement -- - | JSThrow JS + | JSThrow (Maybe SourceSpan) JS -- | -- Type-Of operator -- - | JSTypeOf JS + | JSTypeOf (Maybe SourceSpan) JS -- | -- InstanceOf test -- - | JSInstanceOf JS JS + | JSInstanceOf (Maybe SourceSpan) JS JS -- | -- Labelled statement -- - | JSLabel String JS + | JSLabel (Maybe SourceSpan) String JS -- | -- Break statement -- - | JSBreak String + | JSBreak (Maybe SourceSpan) String -- | -- Continue statement -- - | JSContinue String + | JSContinue (Maybe SourceSpan) String -- | -- Raw Javascript (generated when parsing fails for an inline foreign import declaration) -- - | JSRaw String + | JSRaw (Maybe SourceSpan) String -- | -- Commented Javascript -- - | JSComment [Comment] JS - deriving (Show, Read, Eq) + | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Read, Eq) + +withSourceSpan :: SourceSpan -> JS -> JS +withSourceSpan withSpan = go + where + ss :: Maybe SourceSpan + ss = Just withSpan + + go :: JS -> JS + go (JSNumericLiteral _ n) = JSNumericLiteral ss n + go (JSStringLiteral _ s) = JSStringLiteral ss s + go (JSBooleanLiteral _ b) = JSBooleanLiteral ss b + go (JSUnary _ op j) = JSUnary ss op j + go (JSBinary _ op j1 j2) = JSBinary ss op j1 j2 + go (JSArrayLiteral _ js) = JSArrayLiteral ss js + go (JSIndexer _ j1 j2) = JSIndexer ss j1 j2 + go (JSObjectLiteral _ js) = JSObjectLiteral ss js + go (JSAccessor _ prop j) = JSAccessor ss prop j + go (JSFunction _ name args j) = JSFunction ss name args j + go (JSApp _ j js) = JSApp ss j js + go (JSVar _ s) = JSVar ss s + go (JSConditional _ j1 j2 j3) = JSConditional ss j1 j2 j3 + go (JSBlock _ js) = JSBlock ss js + go (JSVariableIntroduction _ name j) = JSVariableIntroduction ss name j + go (JSAssignment _ j1 j2) = JSAssignment ss j1 j2 + go (JSWhile _ j1 j2) = JSWhile ss j1 j2 + go (JSFor _ name j1 j2 j3) = JSFor ss name j1 j2 j3 + go (JSForIn _ name j1 j2) = JSForIn ss name j1 j2 + go (JSIfElse _ j1 j2 j3) = JSIfElse ss j1 j2 j3 + go (JSReturn _ js) = JSReturn ss js + go (JSThrow _ js) = JSThrow ss js + go (JSTypeOf _ js) = JSTypeOf ss js + go (JSInstanceOf _ j1 j2) = JSInstanceOf ss j1 j2 + go (JSLabel _ name js) = JSLabel ss name js + go (JSBreak _ s) = JSBreak ss s + go (JSContinue _ s) = JSContinue ss s + go (JSRaw _ s) = JSRaw ss s + go (JSComment _ com j) = JSComment ss com j + +getSourceSpan :: JS -> Maybe SourceSpan +getSourceSpan = go + where + go :: JS -> Maybe SourceSpan + go (JSNumericLiteral ss _) = ss + go (JSStringLiteral ss _) = ss + go (JSBooleanLiteral ss _) = ss + go (JSUnary ss _ _) = ss + go (JSBinary ss _ _ _) = ss + go (JSArrayLiteral ss _) = ss + go (JSIndexer ss _ _) = ss + go (JSObjectLiteral ss _) = ss + go (JSAccessor ss _ _) = ss + go (JSFunction ss _ _ _) = ss + go (JSApp ss _ _) = ss + go (JSVar ss _) = ss + go (JSConditional ss _ _ _) = ss + go (JSBlock ss _) = ss + go (JSVariableIntroduction ss _ _) = ss + go (JSAssignment ss _ _) = ss + go (JSWhile ss _ _) = ss + go (JSFor ss _ _ _ _) = ss + go (JSForIn ss _ _ _) = ss + go (JSIfElse ss _ _ _) = ss + go (JSReturn ss _) = ss + go (JSThrow ss _) = ss + go (JSTypeOf ss _) = ss + go (JSInstanceOf ss _ _) = ss + go (JSLabel ss _ _) = ss + go (JSBreak ss _) = ss + go (JSContinue ss _) = ss + go (JSRaw ss _) = ss + go (JSComment ss _ _) = ss -- -- Traversals @@ -249,28 +320,28 @@ everywhereOnJS :: (JS -> JS) -> JS -> JS everywhereOnJS f = go where go :: JS -> JS - go (JSUnary op j) = f (JSUnary op (go j)) - go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2)) - go (JSArrayLiteral js) = f (JSArrayLiteral (map go js)) - go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2)) - go (JSObjectLiteral js) = f (JSObjectLiteral (map (fmap go) js)) - go (JSAccessor prop j) = f (JSAccessor prop (go j)) - go (JSFunction name args j) = f (JSFunction name args (go j)) - go (JSApp j js) = f (JSApp (go j) (map go js)) - go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3)) - go (JSBlock js) = f (JSBlock (map go js)) - go (JSVariableIntroduction name j) = f (JSVariableIntroduction name (fmap go j)) - go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2)) - go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2)) - go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3)) - go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2)) - go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) (fmap go j3)) - go (JSReturn js) = f (JSReturn (go js)) - go (JSThrow js) = f (JSThrow (go js)) - go (JSTypeOf js) = f (JSTypeOf (go js)) - go (JSLabel name js) = f (JSLabel name (go js)) - go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2)) - go (JSComment com j) = f (JSComment com (go j)) + go (JSUnary ss op j) = f (JSUnary ss op (go j)) + go (JSBinary ss op j1 j2) = f (JSBinary ss op (go j1) (go j2)) + go (JSArrayLiteral ss js) = f (JSArrayLiteral ss (map go js)) + go (JSIndexer ss j1 j2) = f (JSIndexer ss (go j1) (go j2)) + go (JSObjectLiteral ss js) = f (JSObjectLiteral ss (map (fmap go) js)) + go (JSAccessor ss prop j) = f (JSAccessor ss prop (go j)) + go (JSFunction ss name args j) = f (JSFunction ss name args (go j)) + go (JSApp ss j js) = f (JSApp ss (go j) (map go js)) + go (JSConditional ss j1 j2 j3) = f (JSConditional ss (go j1) (go j2) (go j3)) + go (JSBlock ss js) = f (JSBlock ss (map go js)) + go (JSVariableIntroduction ss name j) = f (JSVariableIntroduction ss name (fmap go j)) + go (JSAssignment ss j1 j2) = f (JSAssignment ss (go j1) (go j2)) + go (JSWhile ss j1 j2) = f (JSWhile ss (go j1) (go j2)) + go (JSFor ss name j1 j2 j3) = f (JSFor ss name (go j1) (go j2) (go j3)) + go (JSForIn ss name j1 j2) = f (JSForIn ss name (go j1) (go j2)) + go (JSIfElse ss j1 j2 j3) = f (JSIfElse ss (go j1) (go j2) (fmap go j3)) + go (JSReturn ss js) = f (JSReturn ss (go js)) + go (JSThrow ss js) = f (JSThrow ss (go js)) + go (JSTypeOf ss js) = f (JSTypeOf ss (go js)) + go (JSLabel ss name js) = f (JSLabel ss name (go js)) + go (JSInstanceOf ss j1 j2) = f (JSInstanceOf ss (go j1) (go j2)) + go (JSComment ss com j) = f (JSComment ss com (go j)) go other = f other everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS @@ -280,54 +351,54 @@ everywhereOnJSTopDownM :: (Applicative m, Monad m) => (JS -> m JS) -> JS -> m JS everywhereOnJSTopDownM f = f >=> go where f' = f >=> go - go (JSUnary op j) = JSUnary op <$> f' j - go (JSBinary op j1 j2) = JSBinary op <$> f' j1 <*> f' j2 - go (JSArrayLiteral js) = JSArrayLiteral <$> traverse f' js - go (JSIndexer j1 j2) = JSIndexer <$> f' j1 <*> f' j2 - go (JSObjectLiteral js) = JSObjectLiteral <$> traverse (sndM f') js - go (JSAccessor prop j) = JSAccessor prop <$> f' j - go (JSFunction name args j) = JSFunction name args <$> f' j - go (JSApp j js) = JSApp <$> f' j <*> traverse f' js - go (JSConditional j1 j2 j3) = JSConditional <$> f' j1 <*> f' j2 <*> f' j3 - go (JSBlock js) = JSBlock <$> traverse f' js - go (JSVariableIntroduction name j) = JSVariableIntroduction name <$> traverse f' j - go (JSAssignment j1 j2) = JSAssignment <$> f' j1 <*> f' j2 - go (JSWhile j1 j2) = JSWhile <$> f' j1 <*> f' j2 - go (JSFor name j1 j2 j3) = JSFor name <$> f' j1 <*> f' j2 <*> f' j3 - go (JSForIn name j1 j2) = JSForIn name <$> f' j1 <*> f' j2 - go (JSIfElse j1 j2 j3) = JSIfElse <$> f' j1 <*> f' j2 <*> traverse f' j3 - go (JSReturn j) = JSReturn <$> f' j - go (JSThrow j) = JSThrow <$> f' j - go (JSTypeOf j) = JSTypeOf <$> f' j - go (JSLabel name j) = JSLabel name <$> f' j - go (JSInstanceOf j1 j2) = JSInstanceOf <$> f' j1 <*> f' j2 - go (JSComment com j) = JSComment com <$> f' j + go (JSUnary ss op j) = JSUnary ss op <$> f' j + go (JSBinary ss op j1 j2) = JSBinary ss op <$> f' j1 <*> f' j2 + go (JSArrayLiteral ss js) = JSArrayLiteral ss <$> traverse f' js + go (JSIndexer ss j1 j2) = JSIndexer ss <$> f' j1 <*> f' j2 + go (JSObjectLiteral ss js) = JSObjectLiteral ss <$> traverse (sndM f') js + go (JSAccessor ss prop j) = JSAccessor ss prop <$> f' j + go (JSFunction ss name args j) = JSFunction ss name args <$> f' j + go (JSApp ss j js) = JSApp ss <$> f' j <*> traverse f' js + go (JSConditional ss j1 j2 j3) = JSConditional ss <$> f' j1 <*> f' j2 <*> f' j3 + go (JSBlock ss js) = JSBlock ss <$> traverse f' js + go (JSVariableIntroduction ss name j) = JSVariableIntroduction ss name <$> traverse f' j + go (JSAssignment ss j1 j2) = JSAssignment ss <$> f' j1 <*> f' j2 + go (JSWhile ss j1 j2) = JSWhile ss <$> f' j1 <*> f' j2 + go (JSFor ss name j1 j2 j3) = JSFor ss name <$> f' j1 <*> f' j2 <*> f' j3 + go (JSForIn ss name j1 j2) = JSForIn ss name <$> f' j1 <*> f' j2 + go (JSIfElse ss j1 j2 j3) = JSIfElse ss <$> f' j1 <*> f' j2 <*> traverse f' j3 + go (JSReturn ss j) = JSReturn ss <$> f' j + go (JSThrow ss j) = JSThrow ss <$> f' j + go (JSTypeOf ss j) = JSTypeOf ss <$> f' j + go (JSLabel ss name j) = JSLabel ss name <$> f' j + go (JSInstanceOf ss j1 j2) = JSInstanceOf ss <$> f' j1 <*> f' j2 + go (JSComment ss com j) = JSComment ss com <$> f' j go other = f other everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r everythingOnJS (<>) f = go where - go j@(JSUnary _ j1) = f j <> go j1 - go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2 - go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js) - go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2 - go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go . snd) js) - go j@(JSAccessor _ j1) = f j <> go j1 - go j@(JSFunction _ _ j1) = f j <> go j1 - go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js) - go j@(JSConditional j1 j2 j3) = f j <> go j1 <> go j2 <> go j3 - go j@(JSBlock js) = foldl (<>) (f j) (map go js) - go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1 - go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2 - go j@(JSWhile j1 j2) = f j <> go j1 <> go j2 - go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3 - go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2 - go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2 - go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3 - go j@(JSReturn j1) = f j <> go j1 - go j@(JSThrow j1) = f j <> go j1 - go j@(JSTypeOf j1) = f j <> go j1 - go j@(JSLabel _ j1) = f j <> go j1 - go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2 - go j@(JSComment _ j1) = f j <> go j1 + go j@(JSUnary _ _ j1) = f j <> go j1 + go j@(JSBinary _ _ j1 j2) = f j <> go j1 <> go j2 + go j@(JSArrayLiteral _ js) = foldl (<>) (f j) (map go js) + go j@(JSIndexer _ j1 j2) = f j <> go j1 <> go j2 + go j@(JSObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js) + go j@(JSAccessor _ _ j1) = f j <> go j1 + go j@(JSFunction _ _ _ j1) = f j <> go j1 + go j@(JSApp _ j1 js) = foldl (<>) (f j <> go j1) (map go js) + go j@(JSConditional _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3 + go j@(JSBlock _ js) = foldl (<>) (f j) (map go js) + go j@(JSVariableIntroduction _ _ (Just j1)) = f j <> go j1 + go j@(JSAssignment _ j1 j2) = f j <> go j1 <> go j2 + go j@(JSWhile _ j1 j2) = f j <> go j1 <> go j2 + go j@(JSFor _ _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3 + go j@(JSForIn _ _ j1 j2) = f j <> go j1 <> go j2 + go j@(JSIfElse _ j1 j2 Nothing) = f j <> go j1 <> go j2 + go j@(JSIfElse _ j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3 + go j@(JSReturn _ j1) = f j <> go j1 + go j@(JSThrow _ j1) = f j <> go j1 + go j@(JSTypeOf _ j1) = f j <> go j1 + go j@(JSLabel _ _ j1) = f j <> go j1 + go j@(JSInstanceOf _ j1 j2) = f j <> go j1 <> go j2 + go j@(JSComment _ _ j1) = f j <> go j1 go other = f other diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs index 0b28e17b73..5836b4618e 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -53,11 +53,11 @@ optimize' js = do opts <- ask js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll [ inlineCommonValues - , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x] - , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp f [x] - , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x] - , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp f [x] - , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer + , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp Nothing f [x] + , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x] + , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp Nothing f [x] + , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x] + , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing) , inlineCommonOperators ]) js untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js' diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs index 68c29c7a7f..2abd781d68 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs @@ -27,16 +27,16 @@ collapseNestedBlocks :: JS -> JS collapseNestedBlocks = everywhereOnJS collapse where collapse :: JS -> JS - collapse (JSBlock sts) = JSBlock (concatMap go sts) + collapse (JSBlock ss sts) = JSBlock ss (concatMap go sts) collapse js = js go :: JS -> [JS] - go (JSBlock sts) = sts + go (JSBlock _ sts) = sts go s = [s] collapseNestedIfs :: JS -> JS collapseNestedIfs = everywhereOnJS collapse where collapse :: JS -> JS - collapse (JSIfElse cond1 (JSBlock [JSIfElse cond2 body Nothing]) Nothing) = - JSIfElse (JSBinary And cond1 cond2) body Nothing + collapse (JSIfElse s1 cond1 (JSBlock _ [JSIfElse s2 cond2 body Nothing]) Nothing) = + JSIfElse s1 (JSBinary s2 And cond1 cond2) body Nothing collapse js = js diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs index 2bbb99a9ca..25cb33145f 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs @@ -14,67 +14,67 @@ applyAll = foldl1 (.) replaceIdent :: String -> JS -> JS -> JS replaceIdent var1 js = everywhereOnJS replace where - replace (JSVar var2) | var1 == var2 = js + replace (JSVar _ var2) | var1 == var2 = js replace other = other replaceIdents :: [(String, JS)] -> JS -> JS replaceIdents vars = everywhereOnJS replace where - replace v@(JSVar var) = fromMaybe v $ lookup var vars + replace v@(JSVar _ var) = fromMaybe v $ lookup var vars replace other = other isReassigned :: String -> JS -> Bool isReassigned var1 = everythingOnJS (||) check where check :: JS -> Bool - check (JSFunction _ args _) | var1 `elem` args = True - check (JSVariableIntroduction arg _) | var1 == arg = True - check (JSAssignment (JSVar arg) _) | var1 == arg = True - check (JSFor arg _ _ _) | var1 == arg = True - check (JSForIn arg _ _) | var1 == arg = True + check (JSFunction _ _ args _) | var1 `elem` args = True + check (JSVariableIntroduction _ arg _) | var1 == arg = True + check (JSAssignment _ (JSVar _ arg) _) | var1 == arg = True + check (JSFor _ arg _ _ _) | var1 == arg = True + check (JSForIn _ arg _ _) | var1 == arg = True check _ = False isRebound :: JS -> JS -> Bool isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js) where - variablesOf (JSVar var) = [var] + variablesOf (JSVar _ var) = [var] variablesOf _ = [] isUsed :: String -> JS -> Bool isUsed var1 = everythingOnJS (||) check where check :: JS -> Bool - check (JSVar var2) | var1 == var2 = True - check (JSAssignment target _) | var1 == targetVariable target = True + check (JSVar _ var2) | var1 == var2 = True + check (JSAssignment _ target _) | var1 == targetVariable target = True check _ = False targetVariable :: JS -> String -targetVariable (JSVar var) = var -targetVariable (JSAccessor _ tgt) = targetVariable tgt -targetVariable (JSIndexer _ tgt) = targetVariable tgt +targetVariable (JSVar _ var) = var +targetVariable (JSAccessor _ _ tgt) = targetVariable tgt +targetVariable (JSIndexer _ _ tgt) = targetVariable tgt targetVariable _ = internalError "Invalid argument to targetVariable" isUpdated :: String -> JS -> Bool isUpdated var1 = everythingOnJS (||) check where check :: JS -> Bool - check (JSAssignment target _) | var1 == targetVariable target = True + check (JSAssignment _ target _) | var1 == targetVariable target = True check _ = False removeFromBlock :: ([JS] -> [JS]) -> JS -> JS -removeFromBlock go (JSBlock sts) = JSBlock (go sts) +removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts) removeFromBlock _ js = js isFn :: (String, String) -> JS -> Bool -isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName -isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName +isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) = x == fnName && y == moduleName +isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = x == fnName && y == moduleName isFn _ _ = False isFn' :: [(String, String)] -> JS -> Bool isFn' xs js = any (`isFn` js) xs isDict :: (String, String) -> JS -> Bool -isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName +isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName isDict _ _ = False isDict' :: [(String, String)] -> JS -> Bool diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index 2b5cbd3dde..6b9f4e7095 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -29,42 +29,42 @@ import qualified Language.PureScript.Constants as C -- Needs to be: { 0..toFixed(10); } -- Probably needs to be fixed in pretty-printer instead. shouldInline :: JS -> Bool -shouldInline (JSVar _) = True -shouldInline (JSNumericLiteral _) = True -shouldInline (JSStringLiteral _) = True -shouldInline (JSBooleanLiteral _) = True -shouldInline (JSAccessor _ val) = shouldInline val -shouldInline (JSIndexer index val) = shouldInline index && shouldInline val +shouldInline (JSVar _ _) = True +shouldInline (JSNumericLiteral _ _) = True +shouldInline (JSStringLiteral _ _) = True +shouldInline (JSBooleanLiteral _ _) = True +shouldInline (JSAccessor _ _ val) = shouldInline val +shouldInline (JSIndexer _ index val) = shouldInline index && shouldInline val shouldInline _ = False etaConvert :: JS -> JS etaConvert = everywhereOnJS convert where convert :: JS -> JS - convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)]) + convert (JSBlock ss [JSReturn _ (JSApp _ (JSFunction _ Nothing idents block@(JSBlock _ body)) args)]) | all shouldInline args && - not (any (`isRebound` block) (map JSVar idents)) && + not (any (`isRebound` block) (map (JSVar Nothing) idents)) && not (any (`isRebound` block) args) - = JSBlock (map (replaceIdents (zip idents args)) body) - convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn + = JSBlock ss (map (replaceIdents (zip idents args)) body) + convert (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ (JSApp _ fn [])])) = fn convert js = js unThunk :: JS -> JS unThunk = everywhereOnJS convert where convert :: JS -> JS - convert (JSBlock []) = JSBlock [] - convert (JSBlock jss) = + convert (JSBlock ss []) = JSBlock ss [] + convert (JSBlock ss jss) = case last jss of - JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body - _ -> JSBlock jss + JSReturn _ (JSApp _ (JSFunction _ Nothing [] (JSBlock _ body)) []) -> JSBlock ss $ init jss ++ body + _ -> JSBlock ss jss convert js = js evaluateIifes :: JS -> JS evaluateIifes = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret + convert (JSApp _ (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ ret])) []) = ret convert js = js inlineVariables :: JS -> JS @@ -72,7 +72,7 @@ inlineVariables = everywhereOnJS $ removeFromBlock go where go :: [JS] -> [JS] go [] = [] - go (JSVariableIntroduction var (Just js) : sts) + go (JSVariableIntroduction _ var (Just js) : sts) | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) = go (map (replaceIdent var js) sts) go (s:sts) = s : go sts @@ -81,16 +81,16 @@ inlineCommonValues :: JS -> JS inlineCommonValues = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp fn [dict]) - | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral (Left 0) - | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral (Left 1) - | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral False - | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral True - convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) - | isDict' semiringInt dict && isFn' fnAdd fn = intOp Add x y - | isDict' semiringInt dict && isFn' fnMultiply fn = intOp Multiply x y - | isDict' moduloSemiringInt dict && isFn' fnDivide fn = intOp Divide x y - | isDict' ringInt dict && isFn' fnSubtract fn = intOp Subtract x y + convert (JSApp ss fn [dict]) + | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral ss (Left 0) + | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral ss (Left 1) + | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral ss False + | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral ss True + convert (JSApp ss (JSApp _ (JSApp _ fn [dict]) [x]) [y]) + | isDict' semiringInt dict && isFn' fnAdd fn = intOp ss Add x y + | isDict' semiringInt dict && isFn' fnMultiply fn = intOp ss Multiply x y + | isDict' moduloSemiringInt dict && isFn' fnDivide fn = intOp ss Divide x y + | isDict' ringInt dict && isFn' fnSubtract fn = intOp ss Subtract x y convert other = other fnZero = [(C.prelude, C.zero), (C.dataSemiring, C.zero)] fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)] @@ -100,16 +100,16 @@ inlineCommonValues = everywhereOnJS convert fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataModuloSemiring, C.div)] fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))] fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)] - intOp op x y = JSBinary BitwiseOr (JSBinary op x y) (JSNumericLiteral (Left 0)) + intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0)) inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS inlineOperator (m, op) f = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y + convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y convert other = other - isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op) - isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op' + isOp (JSAccessor _ longForm (JSVar _ m')) = m == m' && longForm == identToJs (Op op) + isOp (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) = m == m' && op == op' isOp _ = False inlineCommonOperators :: JS -> JS @@ -177,49 +177,49 @@ inlineCommonOperators = applyAll $ binary dict fns op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary op x y + convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary ss op x y convert other = other binary' :: String -> String -> BinaryOperator -> JS -> JS binary' moduleName opString op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y + convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y convert other = other unary :: [(String, String)] -> [(String, String)] -> UnaryOperator -> JS -> JS unary dicts fns op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp (JSApp fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary op x + convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary ss op x convert other = other unary' :: String -> String -> UnaryOperator -> JS -> JS unary' moduleName fnName op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp fn [x]) | isFn (moduleName, fnName) fn = JSUnary op x + convert (JSApp ss fn [x]) | isFn (moduleName, fnName) fn = JSUnary ss op x convert other = other mkFn :: Int -> JS -> JS mkFn 0 = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN = - JSFunction Nothing [] (JSBlock js) + convert (JSApp _ mkFnN [JSFunction s1 Nothing [_] (JSBlock s2 js)]) | isNFn C.mkFn 0 mkFnN = + JSFunction s1 Nothing [] (JSBlock s2 js) convert other = other mkFn n = everywhereOnJS convert where convert :: JS -> JS - convert orig@(JSApp mkFnN [fn]) | isNFn C.mkFn n mkFnN = + convert orig@(JSApp ss mkFnN [fn]) | isNFn C.mkFn n mkFnN = case collectArgs n [] fn of - Just (args, js) -> JSFunction Nothing args (JSBlock js) + Just (args, js) -> JSFunction ss Nothing args (JSBlock ss js) Nothing -> orig convert other = other collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS]) - collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js) - collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret + collectArgs 1 acc (JSFunction _ Nothing [oneArg] (JSBlock _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js) + collectArgs m acc (JSFunction _ Nothing [oneArg] (JSBlock _ [JSReturn _ ret])) = collectArgs (m - 1) (oneArg : acc) ret collectArgs _ _ _ = Nothing isNFn :: String -> Int -> JS -> Bool - isNFn prefix n (JSVar name) = name == (prefix ++ show n) - isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n) + isNFn prefix n (JSVar _ name) = name == (prefix ++ show n) + isNFn prefix n (JSAccessor _ name (JSVar _ dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n) isNFn _ _ _ = False runFn :: Int -> JS -> JS @@ -229,8 +229,8 @@ inlineCommonOperators = applyAll $ convert js = fromMaybe js $ go n [] js go :: Int -> [JS] -> JS -> Maybe JS - go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc) - go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs + go 0 acc (JSApp ss runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp ss fn acc) + go m acc (JSApp _ lhs [arg]) = go (m - 1) (arg : acc) lhs go _ _ _ = Nothing -- (f <<< g $ x) = f (g x) @@ -239,16 +239,16 @@ inlineFnComposition :: (Applicative m, MonadSupply m) => JS -> m JS inlineFnComposition = everywhereOnJSTopDownM convert where convert :: (MonadSupply m) => JS -> m JS - convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z]) - | isFnCompose dict' fn = return $ JSApp x [JSApp y [z]] - | isFnComposeFlipped dict' fn = return $ JSApp y [JSApp x [z]] - convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) + convert (JSApp s1 (JSApp s2 (JSApp _ (JSApp _ fn [dict']) [x]) [y]) [z]) + | isFnCompose dict' fn = return $ JSApp s1 x [JSApp s2 y [z]] + | isFnComposeFlipped dict' fn = return $ JSApp s2 y [JSApp s1 x [z]] + convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isFnCompose dict' fn = do arg <- freshName - return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]]) + return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing x [JSApp Nothing y [JSVar Nothing arg]]]) | isFnComposeFlipped dict' fn = do arg <- freshName - return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp y [JSApp x [JSVar arg]]]) + return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing y [JSApp Nothing x [JSVar Nothing arg]]]) convert other = return other isFnCompose :: JS -> JS -> Bool isFnCompose dict' fn = isDict' semigroupoidFn dict' && isFn' fnCompose fn diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs index fb5eda80fe..30edbf0af9 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs @@ -40,46 +40,46 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert -- Desugar monomorphic calls to >>= and return for the Eff monad convert :: JS -> JS -- Desugar pure & return - convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val + convert (JSApp _ (JSApp _ pure' [val]) []) | isPure pure' = val -- Desugar >> - convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind = - JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : map applyReturns js ) + convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [] (JSBlock s2 js)]) | isBind bind = + JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSApp s2 m [] : map applyReturns js ) -- Desugar >>= - convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind = - JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : map applyReturns js) + convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [arg] (JSBlock s2 js)]) | isBind bind = + JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSVariableIntroduction s2 arg (Just (JSApp s2 m [])) : map applyReturns js) -- Desugar untilE - convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f = - JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn $ JSObjectLiteral []])) [] + convert (JSApp s1 (JSApp _ f [arg]) []) | isEffFunc C.untilE f = + JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSUnary s1 Not (JSApp s1 arg [])) (JSBlock s1 []), JSReturn s1 $ JSObjectLiteral s1 []])) [] -- Desugar whileE - convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f = - JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) [] + convert (JSApp _ (JSApp _ (JSApp s1 f [arg1]) [arg2]) []) | isEffFunc C.whileE f = + JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSApp s1 arg1 []) (JSBlock s1 [ JSApp s1 arg2 [] ]), JSReturn s1 $ JSObjectLiteral s1 []])) [] convert other = other -- Check if an expression represents a monomorphic call to >>= for the Eff monad - isBind (JSApp fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True + isBind (JSApp _ fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True isBind _ = False -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative - isPure (JSApp fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True + isPure (JSApp _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True isPure _ = False -- Check if an expression represents the polymorphic >>= function isBindPoly = isFn' [(C.prelude, C.bind), (C.prelude, (C.>>=)), (C.controlBind, C.bind)] -- Check if an expression represents the polymorphic pure or return function isPurePoly = isFn' [(C.prelude, C.pure'), (C.prelude, C.return), (C.controlApplicative, C.pure')] -- Check if an expression represents a function in the Eff module - isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name' + isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name' isEffFunc _ _ = False -- Remove __do function applications which remain after desugaring undo :: JS -> JS - undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body + undo (JSReturn _ (JSApp _ (JSFunction _ (Just ident) [] body) [])) | ident == fnName = body undo other = other applyReturns :: JS -> JS - applyReturns (JSReturn ret) = JSReturn (JSApp ret []) - applyReturns (JSBlock jss) = JSBlock (map applyReturns jss) - applyReturns (JSWhile cond js) = JSWhile cond (applyReturns js) - applyReturns (JSFor v lo hi js) = JSFor v lo hi (applyReturns js) - applyReturns (JSForIn v xs js) = JSForIn v xs (applyReturns js) - applyReturns (JSIfElse cond t f) = JSIfElse cond (applyReturns t) (applyReturns `fmap` f) + applyReturns (JSReturn ss ret) = JSReturn ss (JSApp ss ret []) + applyReturns (JSBlock ss jss) = JSBlock ss (map applyReturns jss) + applyReturns (JSWhile ss cond js) = JSWhile ss cond (applyReturns js) + applyReturns (JSFor ss v lo hi js) = JSFor ss v lo hi (applyReturns js) + applyReturns (JSForIn ss v xs js) = JSForIn ss v xs (applyReturns js) + applyReturns (JSIfElse ss cond t f) = JSIfElse ss cond (applyReturns t) (applyReturns `fmap` f) applyReturns other = other -- | @@ -91,7 +91,7 @@ inlineST = everywhereOnJS convertBlock -- Look for runST blocks and inline the STRefs there. -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then -- we can be more aggressive about inlining, and actually turn STRefs into local variables. - convertBlock (JSApp f [arg]) | isSTFunc C.runST f = + convertBlock (JSApp _ f [arg]) | isSTFunc C.runST f = let refs = nub . findSTRefsIn $ arg usages = findAllSTUsagesIn arg allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages @@ -101,34 +101,34 @@ inlineST = everywhereOnJS convertBlock -- Convert a block in a safe way, preserving object wrappers of references, -- or in a more aggressive way, turning wrappers into local variables depending on the -- agg(ressive) parameter. - convert agg (JSApp 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 = - if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg - convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f = - if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref]) + convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f = + JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(C.stRefValue, arg)]]) + convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f = + if agg then ref else JSAccessor s1 C.stRefValue ref + convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f = + if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) arg + convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f = + if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) (JSApp s1 func [JSAccessor s1 C.stRefValue ref]) convert _ other = other -- Check if an expression represents a function in the ST module - isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name' + isSTFunc name (JSAccessor _ name' (JSVar _ st)) = st == C.st && name == name' isSTFunc _ _ = False -- Find all ST Refs initialized in this block findSTRefsIn = everythingOnJS (++) isSTRef where - isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident] + isSTRef (JSVariableIntroduction _ ident (Just (JSApp _ (JSApp _ f [_]) []))) | isSTFunc C.newSTRef f = [ident] isSTRef _ = [] -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef findAllSTUsagesIn = everythingOnJS (++) isSTUsage where - isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref] - isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref] + isSTUsage (JSApp _ (JSApp _ f [ref]) []) | isSTFunc C.readSTRef f = [ref] + isSTUsage (JSApp _ (JSApp _ (JSApp _ f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref] isSTUsage _ = [] -- Find all uses of a variable appearingIn ref = everythingOnJS (++) isVar where - isVar e@(JSVar v) | v == ref = [e] + isVar e@(JSVar _ v) | v == ref = [e] isVar _ = [] -- Convert a JS value to a String if it is a JSVar - toVar (JSVar v) = Just v + toVar (JSVar _ v) = Just v toVar _ = Nothing diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs index 3908e5fb49..8cff91010c 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs @@ -40,7 +40,7 @@ tco' = everywhereOnJS convert copyVar arg = "__copy_" ++ arg convert :: JS -> JS - convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) = + convert js@(JSVariableIntroduction ss name (Just fn@JSFunction {})) = let (argss, body', replace) = collectAllFunctionArgs [] id fn in case () of @@ -48,19 +48,19 @@ tco' = everywhereOnJS convert let allArgs = concat $ reverse argss in - JSVariableIntroduction name (Just (replace (toLoop name allArgs body'))) + JSVariableIntroduction ss name (Just (replace (toLoop name allArgs body'))) | otherwise -> js convert js = js collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS) - collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) = - collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body - collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) = - (args : allArgs, body, f . JSFunction ident (map copyVar args)) - collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) = - collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body - collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) = - (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args)) + collectAllFunctionArgs allArgs f (JSFunction s1 ident args (JSBlock s2 (body@(JSReturn _ _):_))) = + collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction s1 ident (map copyVar args) (JSBlock s2 [b]))) body + collectAllFunctionArgs allArgs f (JSFunction ss ident args body@(JSBlock _ _)) = + (args : allArgs, body, f . JSFunction ss ident (map copyVar args)) + collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args (JSBlock s3 [body]))) = + collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn s1 (JSFunction s2 ident (map copyVar args) (JSBlock s3 [b])))) body + collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args body@(JSBlock _ _))) = + (args : allArgs, body, f . JSReturn s1 . JSFunction s2 ident (map copyVar args)) collectAllFunctionArgs allArgs f body = (allArgs, body, f) isTailCall :: String -> JS -> Bool @@ -77,51 +77,53 @@ tco' = everywhereOnJS convert && numSelfCallWithFnArgs == 0 where countSelfCalls :: JS -> Int - countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1 + countSelfCalls (JSApp _ (JSVar _ ident') _) | ident == ident' = 1 countSelfCalls _ = 0 - + countSelfCallsInTailPosition :: JS -> Int - countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1 + countSelfCallsInTailPosition (JSReturn _ ret) | isSelfCall ident ret = 1 countSelfCallsInTailPosition _ = 0 - + countSelfCallsUnderFunctions :: JS -> Int - countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js' + countSelfCallsUnderFunctions (JSFunction _ _ _ js') = everythingOnJS (+) countSelfCalls js' countSelfCallsUnderFunctions _ = 0 - + countSelfCallsWithFnArgs :: JS -> Int countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0 toLoop :: String -> [String] -> JS -> JS - toLoop ident allArgs js = JSBlock $ - map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++ - [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ] + toLoop ident allArgs js = JSBlock rootSS $ + map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs ++ + [ JSLabel rootSS tcoLabel $ JSWhile rootSS (JSBooleanLiteral rootSS True) (JSBlock rootSS [ everywhereOnJS loopify js ]) ] where + rootSS = Nothing + loopify :: JS -> JS - loopify (JSReturn ret) | isSelfCall ident ret = + loopify (JSReturn ss ret) | isSelfCall ident ret = let allArgumentValues = concat $ collectSelfCallArgs [] ret in - JSBlock $ zipWith (\val arg -> - JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs + JSBlock ss $ zipWith (\val arg -> + JSVariableIntroduction ss (tcoVar arg) (Just val)) allArgumentValues allArgs ++ map (\arg -> - JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs - ++ [ JSContinue tcoLabel ] + JSAssignment ss (JSVar ss arg) (JSVar ss (tcoVar arg))) allArgs + ++ [ JSContinue ss tcoLabel ] loopify other = other collectSelfCallArgs :: [[JS]] -> JS -> [[JS]] - collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn + collectSelfCallArgs allArgumentValues (JSApp _ fn args') = collectSelfCallArgs (args' : allArgumentValues) fn collectSelfCallArgs allArgumentValues _ = allArgumentValues isSelfCall :: String -> JS -> Bool - isSelfCall ident (JSApp (JSVar ident') _) = ident == ident' - isSelfCall ident (JSApp fn _) = isSelfCall ident fn + isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident' + isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn isSelfCall _ _ = False isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool - isSelfCallWithFnArgs ident (JSVar ident') args | ident == ident' && any hasFunction args = True - isSelfCallWithFnArgs ident (JSApp fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc) + isSelfCallWithFnArgs ident (JSVar _ ident') args | ident == ident' && any hasFunction args = True + isSelfCallWithFnArgs ident (JSApp _ fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc) isSelfCallWithFnArgs _ _ _ = False - - hasFunction :: JS -> Bool + + hasFunction :: JS -> Bool hasFunction = getAny . everythingOnJS mappend (Any . isFunction) where isFunction JSFunction{} = True diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs index 7a3b6d34cf..0f3d851519 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs @@ -30,17 +30,17 @@ removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go) go :: [JS] -> [JS] go jss | not (any isJSReturn jss) = jss | otherwise = let (body, ret : _) = break isJSReturn jss in body ++ [ret] - isJSReturn (JSReturn _) = True + isJSReturn (JSReturn _ _) = True isJSReturn _ = False removeUnusedArg :: JS -> JS removeUnusedArg = everywhereOnJS convert where - convert (JSFunction name [arg] body) | arg == C.__unused = JSFunction name [] body + convert (JSFunction ss name [arg] body) | arg == C.__unused = JSFunction ss name [] body convert js = js removeUndefinedApp :: JS -> JS removeUndefinedApp = everywhereOnJS convert where - convert (JSApp fn [JSVar arg]) | arg == C.undefined = JSApp fn [] + convert (JSApp ss fn [JSVar _ arg]) | arg == C.undefined = JSApp ss fn [] convert js = js diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index 15b833de47..ae8a0146cc 100644 --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -31,5 +31,12 @@ data Binder a -- | -- A binder which binds its input to an identifier -- - | NamedBinder a Ident (Binder a) - deriving (Show, Read, Functor) + | NamedBinder a Ident (Binder a) deriving (Show, Read, Functor) + + +extractBinderAnn :: Binder a -> a +extractBinderAnn (NullBinder a) = a +extractBinderAnn (LiteralBinder a _) = a +extractBinderAnn (VarBinder a _) = a +extractBinderAnn (ConstructorBinder a _ _ _) = a +extractBinderAnn (NamedBinder a _ _) = a diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index e73a4bbcba..9816bc0049 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,5 +1,9 @@ module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where +import Prelude () +import Prelude.Compat + + import Data.Function (on) import Data.List (sort, sortBy, nub) import Data.Maybe (mapMaybe) @@ -30,38 +34,52 @@ moduleToCoreFn :: Environment -> A.Module -> Module Ann moduleToCoreFn _ (A.Module _ _ _ _ Nothing) = internalError "Module exports were not elaborated before moduleToCoreFn" moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = - let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls + let imports = mapMaybe importToCoreFn decls ++ findQualModules decls + imports' = nub $ filter (keepImp imports) imports-- TODO could be more efficient exps' = nub $ concatMap exportToCoreFn exps externs = nub $ mapMaybe externToCoreFn decls decls' = concatMap (declToCoreFn Nothing []) decls - in Module coms mn imports exps' externs decls' + in Module coms mn imports' exps' externs decls' where + -- Remove duplicate imports favoring the one containing sourcespan info + keepImp :: [(Ann, ModuleName)] -> (Ann, ModuleName) -> Bool + keepImp imps (a, i) = hasSS a || not (any hasDup imps) + where + hasDup (a', i') = i == i' && hasSS a' + + hasSS :: Ann -> Bool + hasSS (Just _, _, _, _) = True + hasSS _ = False + + ssA :: Maybe SourceSpan -> Ann + ssA ss = (ss, [], Nothing, Nothing) + -- | -- Desugars member declarations from AST to CoreFn representation. -- declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann] declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) = - [NonRec (properToIdent ctor) $ + [NonRec (ssA ss) (properToIdent ctor) $ Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))] declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) = error $ "Found newtype with multiple constructors: " ++ show d declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) = flip map ctors $ \(ctor, _) -> let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor) - in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields + in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) = - [NonRec name (exprToCoreFn ss com Nothing e)] + [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) = let meta = either getValueMeta (Just . getConstructorMeta) alias alias' = either id (fmap properToIdent) alias - in [NonRec (Op name) (Var (ss, com, Nothing, meta) alias')] + in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) alias')] declToCoreFn ss _ (A.BindingGroupDeclaration ds) = - [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds] + [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds] declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) = - [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members] + [NonRec (ssA ss) (properToIdent name) $ mkTypeClassConstructor ss com supers members] declToCoreFn _ com (A.PositionedDeclaration ss com1 d) = declToCoreFn (Just ss) (com ++ com1) d declToCoreFn _ _ _ = [] @@ -203,35 +221,36 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = -- ensure instances are imported from any module that is referenced by the -- current module, not just from those that are imported explicitly (#667). -- -findQualModules :: [A.Declaration] -> [ModuleName] +findQualModules :: [A.Declaration] -> [(Ann, ModuleName)] findQualModules decls = let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const []) in f `concatMap` decls where - fqDecls :: A.Declaration -> [ModuleName] + fqDecls :: A.Declaration -> [(Ann, ModuleName)] fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q fqDecls (A.FixityDeclaration _ _ (Just eq)) = either getQual getQual eq fqDecls _ = [] - fqValues :: A.Expr -> [ModuleName] + fqValues :: A.Expr -> [(Ann, ModuleName)] fqValues (A.Var q) = getQual q fqValues (A.Constructor q) = getQual q fqValues _ = [] - fqBinders :: A.Binder -> [ModuleName] + fqBinders :: A.Binder -> [(Ann, ModuleName)] fqBinders (A.ConstructorBinder q _) = getQual q fqBinders _ = [] - getQual :: Qualified a -> [ModuleName] - getQual (Qualified (Just mn) _) = [mn] + getQual :: Qualified a -> [(Ann, ModuleName)] + getQual (Qualified (Just mn) _) = [(nullAnn, mn)] getQual _ = [] -- | -- Desugars import declarations from AST to CoreFn representation. -- -importToCoreFn :: A.Declaration -> Maybe ModuleName -importToCoreFn (A.ImportDeclaration name _ _ _) = Just name -importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d +importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName) +importToCoreFn (A.ImportDeclaration name _ _ _) = Just (nullAnn, name) +importToCoreFn (A.PositionedDeclaration ss _ d) = + ((,) (Just ss, [], Nothing, Nothing) . snd) <$> importToCoreFn d importToCoreFn _ = Nothing -- | diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index 2445556e7e..c4117d7f7d 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -60,12 +60,11 @@ data Bind a -- | -- Non-recursive binding for a single value -- - = NonRec Ident (Expr a) + = NonRec a Ident (Expr a) -- | -- Mutually recursive binding group for several values -- - | Rec [(Ident, Expr a)] - deriving (Show, Read, Functor) + | Rec [((a, Ident), Expr a)] deriving (Show, Read, Functor) -- | -- A guard is just a boolean-valued expression that appears alongside a set of binders @@ -84,8 +83,7 @@ data CaseAlternative a = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a) - } - deriving (Show, Read) + } deriving (Show, Read) instance Functor CaseAlternative where diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs index 91d77a0aa4..da583aeed7 100644 --- a/src/Language/PureScript/CoreFn/Meta.hs +++ b/src/Language/PureScript/CoreFn/Meta.hs @@ -24,8 +24,7 @@ data Meta -- | -- The contained reference is for a foreign member -- - | IsForeign - deriving (Show, Read) + | IsForeign deriving (Show, Read, Eq) -- | -- Data constructor metadata @@ -38,5 +37,4 @@ data ConstructorType -- | -- The constructor is for a type with multiple construcors -- - | SumType - deriving (Show, Read) + | SumType deriving (Show, Read, Eq) diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index c9ceeb1467..383c9ca40b 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -22,7 +22,7 @@ import Language.PureScript.Types data Module a = Module { moduleComments :: [Comment] , moduleName :: ModuleName - , moduleImports :: [ModuleName] + , moduleImports :: [(a, ModuleName)] , moduleExports :: [Ident] , moduleForeign :: [ForeignDecl] , moduleDecls :: [Bind a] diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs index 8b10f678c5..91a077e9d9 100644 --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -26,7 +26,7 @@ everywhereOnValues :: (Bind a -> Bind a) -> (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a) everywhereOnValues f g h = (f', g', h') where - f' (NonRec name e) = f (NonRec name (g' e)) + f' (NonRec a name e) = f (NonRec a name (g' e)) f' (Rec es) = f (Rec (map (second g') es)) g' (Literal ann e) = g (Literal ann (handleLiteral g' e)) @@ -61,7 +61,7 @@ everythingOnValues :: (r -> r -> r) -> (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r) everythingOnValues (<>) f g h i = (f', g', h', i') where - f' b@(NonRec _ e) = f b <> g' e + f' b@(NonRec _ _ e) = f b <> g' e f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es) g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l)) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index cf9898dd55..af45b358d8 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -31,7 +31,7 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except import Control.Monad.IO.Class -import Control.Monad.Reader (MonadReader(..), ReaderT(..)) +import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) import Control.Monad.Logger import Control.Monad.Supply import Control.Monad.Base (MonadBase(..)) @@ -52,9 +52,12 @@ import qualified Data.ByteString.UTF8 as BU8 import qualified Data.Set as S import qualified Data.Map as M +import SourceMap.Types +import SourceMap + import System.Directory - (doesFileExist, getModificationTime, createDirectoryIfMissing) -import System.FilePath ((), takeDirectory) + (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) +import System.FilePath ((), takeDirectory, makeRelative, splitPath) import System.IO.Error (tryIOError) import System.IO.UTF8 (readUTF8File, writeUTF8File) @@ -68,6 +71,7 @@ import Language.PureScript.ModuleDependencies import Language.PureScript.Names import Language.PureScript.Options import Language.PureScript.Pretty +import Language.PureScript.Pretty.Common(SMap(..)) import Language.PureScript.Renamer import Language.PureScript.Sugar import Language.PureScript.TypeChecker @@ -324,20 +328,51 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = | not $ requiresForeign m -> do tell $ errorMessage $ UnnecessaryFFIModule mn path return Nothing - | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"] + | otherwise -> return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"] Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn | otherwise -> return Nothing - pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude + rawJs <- J.moduleToJs m foreignInclude + dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory + sourceMaps <- lift $ asks optionsSourceMaps + let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, []) let filePath = runModuleName mn jsFile = outputDir filePath "index.js" + mapFile = outputDir filePath "index.js.map" externsFile = outputDir filePath "externs.json" foreignFile = outputDir filePath "foreign.js" prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix] js = unlines $ map ("// " ++) prefix ++ [pjs] + mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else "" lift $ do - writeTextFile jsFile (fromString js) + writeTextFile jsFile (fromString $ js ++ mapRef) for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile) writeTextFile externsFile exts + lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings + + genSourceMap :: String -> String -> Int -> [SMap] -> Make () + genSourceMap dir mapFile extraLines mappings = do + let pathToDir = iterate (".." ) ".." !! length (splitPath outputDir) + sourceFile = case mappings of + ((SMap file _ _):_) -> Just $ pathToDir makeRelative dir file + _ -> Nothing + let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings = + map (\(SMap _ orig gen) -> Mapping { + mapOriginal = Just $ convertPos $ add 0 (-1) orig + , mapSourceFile = sourceFile + , mapGenerated = convertPos $ add (extraLines+1) 0 gen + , mapName = Nothing + }) $ + mappings + } + let mapping = generate rawMapping + writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping + where + add :: Int -> Int -> SourcePos -> SourcePos + add n m (SourcePos n' m') = SourcePos (n+n') (m+m') + + convertPos :: SourcePos -> Pos + convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } = + Pos { posLine = fromIntegral l, posColumn = fromIntegral c } requiresForeign :: CF.Module a -> Bool requiresForeign = not . null . CF.moduleForeign diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index 7421e56783..a68bb9f8a7 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -41,9 +41,12 @@ data Options = Options { -- | -- The path to prepend to require statements , optionsRequirePath :: Maybe FilePath + -- | + -- Generate soure maps + , optionsSourceMaps :: Bool } deriving Show -- | -- Default make options defaultOptions :: Options -defaultOptions = Options False False Nothing False False False Nothing +defaultOptions = Options False False Nothing False False False Nothing False diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index c6e9ad464c..67e1533f9d 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -374,7 +374,7 @@ parseLet = do return $ Let ds result parseValueAtom :: TokenParser Expr -parseValueAtom = P.choice +parseValueAtom = withSourceSpan PositionedValue $ P.choice [ parseAnonymousArgument , parseNumericLiteral , parseCharLiteral diff --git a/src/Language/PureScript/Pretty.hs b/src/Language/PureScript/Pretty.hs index 7d569c53ef..959fed5f29 100644 --- a/src/Language/PureScript/Pretty.hs +++ b/src/Language/PureScript/Pretty.hs @@ -27,6 +27,3 @@ import Language.PureScript.Pretty.Kinds as P import Language.PureScript.Pretty.Values as P import Language.PureScript.Pretty.Types as P import Language.PureScript.Pretty.JS as P - - - diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 59b5451090..58aa9b2e88 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -13,12 +13,18 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Language.PureScript.Pretty.Common where -import Control.Monad.State -import Data.List (intercalate) +import Prelude () +import Prelude.Compat + +import Control.Monad.State (StateT, modify, get) +import Data.List (elemIndices, intersperse) import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar) +import Language.PureScript.AST (SourcePos(..), SourceSpan(..)) import Text.PrettyPrint.Boxes @@ -26,9 +32,90 @@ import Text.PrettyPrint.Boxes -- Wrap a string in parentheses -- parens :: String -> String -parens s = ('(':s) ++ ")" +parens s = '(':s ++ ")" + +parensPos :: (Emit gen) => gen -> gen +parensPos s = emit "(" `mappend` s `mappend` emit ")" + +-- | +-- Generalize intercalate slightly for monoids +-- +intercalate :: Monoid m => m -> [m] -> m +intercalate x xs = mconcat (intersperse x xs) + +class (Monoid gen) => Emit gen where + emit :: String -> gen + addMapping :: SourceSpan -> gen + +data SMap = SMap String SourcePos SourcePos + +-- | +-- String with length and source-map entries +-- +newtype StrPos = StrPos (SourcePos, String, [SMap]) + +-- | +-- Make a monoid where append consists of concatenating the string part, adding the lengths +-- appropriately and advancing source mappings on the right hand side to account for +-- the length of the left. +-- +instance Monoid StrPos where + mempty = StrPos (SourcePos 0 0, "", []) + + StrPos (a,b,c) `mappend` StrPos (a',b',c') = StrPos (a `addPos` a', b ++ b', c ++ (bumpPos a <$> c')) + + mconcat ms = + let s' = concatMap (\(StrPos(_, s, _)) -> s) ms + (p, maps) = foldl plus (SourcePos 0 0, []) ms + in + StrPos (p, s', concat $ reverse maps) + where + plus :: (SourcePos, [[SMap]]) -> StrPos -> (SourcePos, [[SMap]]) + plus (a, c) (StrPos (a', _, c')) = (a `addPos` a', (bumpPos a <$> c') : c) + +instance Emit StrPos where + -- | + -- Augment a string with its length (rows/column) + -- + emit str = + let newlines = elemIndices '\n' str + index = if null newlines then 0 else last newlines + 1 + in + StrPos (SourcePos { sourcePosLine = length newlines, sourcePosColumn = length str - index }, str, []) + + -- | + -- Add a new mapping entry for given source position with initially zero generated position + -- + addMapping (SourceSpan { spanName = file, spanStart = startPos }) = StrPos (zeroPos, mempty, [mapping]) + where + mapping = SMap file startPos zeroPos + zeroPos = SourcePos 0 0 + +newtype PlainString = PlainString String deriving Monoid + +runPlainString :: PlainString -> String +runPlainString (PlainString s) = s + +instance Emit PlainString where + emit = PlainString + addMapping _ = mempty + +addMapping' :: (Emit gen) => Maybe SourceSpan -> gen +addMapping' (Just ss) = addMapping ss +addMapping' Nothing = mempty + +bumpPos :: SourcePos -> SMap -> SMap +bumpPos p (SMap f s g) = SMap f s $ p `addPos` g + +addPos :: SourcePos -> SourcePos -> SourcePos +addPos (SourcePos n m) (SourcePos 0 m') = SourcePos n (m+m') +addPos (SourcePos n _) (SourcePos n' m') = SourcePos (n+n') m' + + +data PrinterState = PrinterState { indent :: Int } -newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Read, Eq, Ord) +emptyPrinterState :: PrinterState +emptyPrinterState = PrinterState { indent = 0 } -- | -- Number of characters per identation level @@ -39,7 +126,7 @@ blockIndent = 4 -- | -- Pretty print with a new indentation level -- -withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String +withIndent :: (Emit gen) => StateT PrinterState Maybe gen -> StateT PrinterState Maybe gen withIndent action = do modify $ \st -> st { indent = indent st + blockIndent } result <- action @@ -49,19 +136,19 @@ withIndent action = do -- | -- Get the current indentation level -- -currentIndent :: StateT PrinterState Maybe String +currentIndent :: (Emit gen) => StateT PrinterState Maybe gen currentIndent = do current <- get - return $ replicate (indent current) ' ' + return $ emit $ replicate (indent current) ' ' -- | -- Print many lines -- -prettyPrintMany :: (a -> StateT PrinterState Maybe String) -> [a] -> StateT PrinterState Maybe String +prettyPrintMany :: (Emit gen) => (a -> StateT PrinterState Maybe gen) -> [a] -> StateT PrinterState Maybe gen prettyPrintMany f xs = do ss <- mapM f xs indentString <- currentIndent - return $ intercalate "\n" $ map (indentString ++) ss + return $ intercalate (emit "\n") $ map (\s -> mappend indentString s) ss -- | -- Prints an object key, escaping reserved names. diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 2a1f6e0016..5e8a654c86 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -14,13 +14,12 @@ ----------------------------------------------------------------------------- module Language.PureScript.Pretty.JS ( - prettyPrintJS + prettyPrintJS, prettyPrintJSWithSourceMaps ) where import Prelude () import Prelude.Compat -import Data.List hiding (concat, concatMap) import Data.Maybe (fromMaybe) import Control.Arrow ((<+>)) @@ -34,103 +33,110 @@ import Language.PureScript.CodeGen.JS.Common import Language.PureScript.Pretty.Common import Language.PureScript.Comments + +import Language.PureScript.AST (SourceSpan(..)) + import Numeric -literals :: Pattern PrinterState JS String -literals = mkPattern' match +import Data.Monoid + +literals :: (Emit gen) => Pattern PrinterState JS gen +literals = mkPattern' match' where - match :: JS -> StateT PrinterState Maybe String - match (JSNumericLiteral n) = return $ either show show n - match (JSStringLiteral s) = return $ string s - match (JSBooleanLiteral True) = return "true" - match (JSBooleanLiteral False) = return "false" - match (JSArrayLiteral xs) = concat <$> sequence - [ return "[ " - , intercalate ", " <$> forM xs prettyPrintJS' - , return " ]" + match' :: (Emit gen) => JS -> StateT PrinterState Maybe gen + match' js = (addMapping' (getSourceSpan js) <>) <$> match js + + match :: (Emit gen) => JS -> StateT PrinterState Maybe gen + match (JSNumericLiteral _ n) = return $ emit $ either show show n + match (JSStringLiteral _ s) = return $ string s + match (JSBooleanLiteral _ True) = return $ emit "true" + match (JSBooleanLiteral _ False) = return $ emit "false" + match (JSArrayLiteral _ xs) = mconcat <$> sequence + [ return $ emit "[ " + , intercalate (emit ", ") <$> forM xs prettyPrintJS' + , return $ emit " ]" ] - match (JSObjectLiteral []) = return "{}" - match (JSObjectLiteral ps) = concat <$> sequence - [ return "{\n" + match (JSObjectLiteral _ []) = return $ emit "{}" + match (JSObjectLiteral _ ps) = mconcat <$> sequence + [ return $ emit "{\n" , withIndent $ do - jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value + jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key <> emit ": ") <>) . prettyPrintJS' $ value indentString <- currentIndent - return $ intercalate ", \n" $ map (indentString ++) jss - , return "\n" + return $ intercalate (emit ", \n") $ map (indentString <>) jss + , return $ emit "\n" , currentIndent - , return "}" + , return $ emit "}" ] where - objectPropertyToString :: String -> String - objectPropertyToString s | identNeedsEscaping s = show s - | otherwise = s - match (JSBlock sts) = concat <$> sequence - [ return "{\n" + objectPropertyToString :: (Emit gen) => String -> gen + objectPropertyToString s | identNeedsEscaping s = emit $ show s + | otherwise = emit s + match (JSBlock _ sts) = mconcat <$> sequence + [ return $ emit "{\n" , withIndent $ prettyStatements sts - , return "\n" + , return $ emit "\n" , currentIndent - , return "}" + , return $ emit "}" ] - match (JSVar ident) = return ident - match (JSVariableIntroduction ident value) = concat <$> sequence - [ return "var " - , return ident - , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value + match (JSVar _ ident) = return $ emit ident + match (JSVariableIntroduction _ ident value) = mconcat <$> sequence + [ return $ emit $ "var " ++ ident + , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value ] - match (JSAssignment target value) = concat <$> sequence + match (JSAssignment _ target value) = mconcat <$> sequence [ prettyPrintJS' target - , return " = " + , return $ emit " = " , prettyPrintJS' value ] - match (JSWhile cond sts) = concat <$> sequence - [ return "while (" + match (JSWhile _ cond sts) = mconcat <$> sequence + [ return $ emit "while (" , prettyPrintJS' cond - , return ") " + , return $ emit ") " , prettyPrintJS' sts ] - match (JSFor ident start end sts) = concat <$> sequence - [ return $ "for (var " ++ ident ++ " = " + match (JSFor _ ident start end sts) = mconcat <$> sequence + [ return $ emit $ "for (var " ++ ident ++ " = " , prettyPrintJS' start - , return $ "; " ++ ident ++ " < " + , return $ emit $ "; " ++ ident ++ " < " , prettyPrintJS' end - , return $ "; " ++ ident ++ "++) " + , return $ emit $ "; " ++ ident ++ "++) " , prettyPrintJS' sts ] - match (JSForIn ident obj sts) = concat <$> sequence - [ return $ "for (var " ++ ident ++ " in " + match (JSForIn _ ident obj sts) = mconcat <$> sequence + [ return $ emit $ "for (var " ++ ident ++ " in " , prettyPrintJS' obj - , return ") " + , return $ emit ") " , prettyPrintJS' sts ] - match (JSIfElse cond thens elses) = concat <$> sequence - [ return "if (" + match (JSIfElse _ cond thens elses) = mconcat <$> sequence + [ return $ emit "if (" , prettyPrintJS' cond - , return ") " + , return $ emit ") " , prettyPrintJS' thens - , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses + , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintJS') elses ] - match (JSReturn value) = concat <$> sequence - [ return "return " + match (JSReturn _ value) = mconcat <$> sequence + [ return $ emit "return " , prettyPrintJS' value ] - match (JSThrow value) = concat <$> sequence - [ return "throw " + match (JSThrow _ value) = mconcat <$> sequence + [ return $ emit "throw " , prettyPrintJS' value ] - match (JSBreak lbl) = return $ "break " ++ lbl - match (JSContinue lbl) = return $ "continue " ++ lbl - match (JSLabel lbl js) = concat <$> sequence - [ return $ lbl ++ ": " + match (JSBreak _ lbl) = return $ emit $ "break " ++ lbl + match (JSContinue _ lbl) = return $ emit $ "continue " ++ lbl + match (JSLabel _ lbl js) = mconcat <$> sequence + [ return $ emit $ lbl ++ ": " , prettyPrintJS' js ] - match (JSComment com js) = fmap concat $ sequence $ - [ return "\n" + match (JSComment _ com js) = fmap mconcat $ sequence $ + [ return $ emit "\n" , currentIndent - , return "/**\n" + , return $ emit "/**\n" ] ++ map asLine (concatMap commentLines com) ++ [ currentIndent - , return " */\n" + , return $ emit " */\n" , currentIndent , prettyPrintJS' js ] @@ -139,21 +145,21 @@ literals = mkPattern' match commentLines (LineComment s) = [s] commentLines (BlockComment s) = lines s - asLine :: String -> StateT PrinterState Maybe String + asLine :: (Emit gen) => String -> StateT PrinterState Maybe gen asLine s = do i <- currentIndent - return $ i ++ " * " ++ removeComments s ++ "\n" + return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n" removeComments :: String -> String removeComments ('*' : '/' : s) = removeComments s removeComments (c : s) = c : removeComments s removeComments [] = [] - match (JSRaw js) = return js + match (JSRaw _ js) = return $ emit js match _ = mzero -string :: String -> String -string s = '"' : concatMap encodeChar s ++ "\"" +string :: (Emit gen) => String -> gen +string s = emit $ '"' : concatMap encodeChar s ++ "\"" where encodeChar :: Char -> String encodeChar '\b' = "\\b" @@ -175,114 +181,121 @@ string s = '"' : concatMap encodeChar s ++ "\"" encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) "" encodeChar c = [c] -conditional :: Pattern PrinterState JS ((JS, JS), JS) +conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS) conditional = mkPattern match where - match (JSConditional cond th el) = Just ((th, el), cond) + match (JSConditional ss cond th el) = Just ((ss, th, el), cond) match _ = Nothing -accessor :: Pattern PrinterState JS (String, JS) +accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS) accessor = mkPattern match where - match (JSAccessor prop val) = Just (prop, val) + match (JSAccessor _ prop val) = Just (emit prop, val) match _ = Nothing -indexer :: Pattern PrinterState JS (String, JS) +indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS) indexer = mkPattern' match where - match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val + match (JSIndexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val + match _ = mzero -lam :: Pattern PrinterState JS ((Maybe String, [String]), JS) +lam :: Pattern PrinterState JS ((Maybe String, [String], Maybe SourceSpan), JS) lam = mkPattern match where - match (JSFunction name args ret) = Just ((name, args), ret) + match (JSFunction ss name args ret) = Just ((name, args, ss), ret) match _ = Nothing -app :: Pattern PrinterState JS (String, JS) +app :: (Emit gen) => Pattern PrinterState JS (gen, JS) app = mkPattern' match where - match (JSApp val args) = do + match (JSApp _ val args) = do jss <- traverse prettyPrintJS' args - return (intercalate ", " jss, val) + return (intercalate (emit ", ") jss, val) match _ = mzero typeOf :: Pattern PrinterState JS ((), JS) typeOf = mkPattern match where - match (JSTypeOf val) = Just ((), val) + match (JSTypeOf _ val) = Just ((), val) match _ = Nothing instanceOf :: Pattern PrinterState JS (JS, JS) instanceOf = mkPattern match where - match (JSInstanceOf val ty) = Just (val, ty) + match (JSInstanceOf _ val ty) = Just (val, ty) match _ = Nothing -unary' :: UnaryOperator -> (JS -> String) -> Operator PrinterState JS String -unary' op mkStr = Wrap match (++) +unary' :: (Emit gen) => UnaryOperator -> (JS -> String) -> Operator PrinterState JS gen +unary' op mkStr = Wrap match (<>) where - match :: Pattern PrinterState JS (String, JS) + match :: (Emit gen) => Pattern PrinterState JS (gen, JS) match = mkPattern match' where - match' (JSUnary op' val) | op' == op = Just (mkStr val, val) + match' (JSUnary _ op' val) | op' == op = Just (emit $ mkStr val, val) match' _ = Nothing -unary :: UnaryOperator -> String -> Operator PrinterState JS String +unary :: (Emit gen) => UnaryOperator -> String -> Operator PrinterState JS gen unary op str = unary' op (const str) -negateOperator :: Operator PrinterState JS String +negateOperator :: (Emit gen) => Operator PrinterState JS gen negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-") where - isNegate (JSUnary Negate _) = True + isNegate (JSUnary _ Negate _) = True isNegate _ = False -binary :: BinaryOperator -> String -> Operator PrinterState JS String -binary op str = AssocL match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2) +binary :: (Emit gen) => BinaryOperator -> String -> Operator PrinterState JS gen +binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " ++ str ++ " ") <> v2) where match :: Pattern PrinterState JS (JS, JS) match = mkPattern match' where - match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2) + match' (JSBinary _ op' v1 v2) | op' == op = Just (v1, v2) match' _ = Nothing -prettyStatements :: [JS] -> StateT PrinterState Maybe String +prettyStatements :: (Emit gen) => [JS] -> StateT PrinterState Maybe gen prettyStatements sts = do jss <- forM sts prettyPrintJS' indentString <- currentIndent - return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss + return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss -- | -- Generate a pretty-printed string representing a Javascript expression -- -prettyPrintJS1 :: JS -> String +prettyPrintJS1 :: (Emit gen) => JS -> gen prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS' -- | -- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level -- +prettyPrintJSWithSourceMaps :: [JS] -> (String, [SMap]) +prettyPrintJSWithSourceMaps js = + let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js + in (s, mp) + prettyPrintJS :: [JS] -> String -prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements +prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . fmap runPlainString . flip evalStateT (PrinterState 0) . prettyStatements -- | -- Generate an indented, pretty-printed string representing a Javascript expression -- -prettyPrintJS' :: JS -> StateT PrinterState Maybe String +prettyPrintJS' :: (Emit gen) => JS -> StateT PrinterState Maybe gen prettyPrintJS' = A.runKleisli $ runPattern matchValue where - matchValue :: Pattern PrinterState JS String - matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue) - operators :: OperatorTable PrinterState JS String + matchValue :: (Emit gen) => Pattern PrinterState JS gen + matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue) + operators :: (Emit gen) => OperatorTable PrinterState JS gen operators = - OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ] - , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ] - , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ] + OperatorTable [ [ Wrap accessor $ \prop val -> val <> emit "." <> prop ] + , [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ] + , [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ] , [ unary JSNew "new " ] - , [ Wrap lam $ \(name, args) ret -> "function " + , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <> + emit ("function " ++ fromMaybe "" name - ++ "(" ++ intercalate ", " args ++ ") " - ++ ret ] - , [ Wrap typeOf $ \_ s -> "typeof " ++ s ] + ++ "(" ++ intercalate ", " args ++ ") ") + <> ret ] + , [ Wrap typeOf $ \_ s -> emit "typeof " <> s ] , [ unary Not "!" , unary BitwiseNot "~" , unary Positive "+" @@ -299,7 +312,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue , binary LessThanOrEqualTo "<=" , binary GreaterThan ">" , binary GreaterThanOrEqualTo ">=" - , AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ] + , AssocR instanceOf $ \v1 v2 -> v1 <> emit " instanceof " <> v2 ] , [ binary EqualTo "===" , binary NotEqualTo "!==" ] , [ binary BitwiseAnd "&" ] @@ -307,5 +320,5 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue , [ binary BitwiseOr "|" ] , [ binary And "&&" ] , [ binary Or "||" ] - , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ] + , [ Wrap conditional $ \(ss, th, el) cond -> cond <> addMapping' ss <> emit " ? " <> prettyPrintJS1 th <> addMapping' ss <> emit " : " <> prettyPrintJS1 el ] ] diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index d59a163aaa..867e6f522c 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -19,8 +19,6 @@ module Language.PureScript.Pretty.Values ( prettyPrintBinderAtom ) where -import Data.List (intercalate) - import Control.Arrow (second) import Language.PureScript.Crash diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index f497b92126..3dda3d43a9 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -105,8 +105,8 @@ lookupIdent name = do findDeclIdents :: [Bind Ann] -> [Ident] findDeclIdents = concatMap go where - go (NonRec ident _) = [ident] - go (Rec ds) = map fst ds + go (NonRec _ ident _) = [ident] + go (Rec ds) = map (snd . fst) ds -- | -- Renames within each declaration in a module. @@ -128,19 +128,19 @@ renameInModules = map go -- another in the current scope. -- renameInDecl :: Bool -> Bind Ann -> Rename (Bind Ann) -renameInDecl isTopLevel (NonRec name val) = do +renameInDecl isTopLevel (NonRec a name val) = do name' <- if isTopLevel then return name else updateScope name - NonRec name' <$> renameInValue val + NonRec a name' <$> renameInValue val renameInDecl isTopLevel (Rec ds) = do ds' <- traverse updateNames ds Rec <$> traverse updateValues ds' where - updateNames :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann) - updateNames (name, val) = do + updateNames :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann) + updateNames ((a, name), val) = do name' <- if isTopLevel then return name else updateScope name - return (name', val) - updateValues :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann) - updateValues (name, val) = (,) name <$> renameInValue val + return ((a, name'), val) + updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann) + updateValues (aname, val) = (,) aname <$> renameInValue val -- | -- Renames within a value. diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 97acd0e1ff..74bd82fd58 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -297,7 +297,9 @@ infer' (TypedValue checkType val ty) = do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val return $ TypedValue True val' ty' -infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val +infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do + TypedValue t v ty <- infer' val + return $ TypedValue t (PositionedValue pos c v) ty infer' _ = internalError "Invalid argument to infer" inferLetBinding :: @@ -623,8 +625,9 @@ check' val kt@(KindedType ty kind) = do checkTypeKind ty kind val' <- check' val ty return $ TypedValue True val' kt -check' (PositionedValue pos _ val) ty = - warnAndRethrowWithPosition pos $ check' val ty +check' (PositionedValue pos c val) ty = warnAndRethrowWithPosition pos $ do + TypedValue t v ty' <- check' val ty + return $ TypedValue t (PositionedValue pos c v) ty' check' val ty = do TypedValue _ val' ty' <- infer val mt <- subsumes (Just val') ty' ty diff --git a/stack-lts-2.yaml b/stack-lts-2.yaml index 6bf1652a92..ffb912457f 100644 --- a/stack-lts-2.yaml +++ b/stack-lts-2.yaml @@ -6,4 +6,5 @@ extra-deps: - bower-json-0.7.0.0 - boxes-0.1.4 - pattern-arrows-0.0.2 +- sourcemap-0.1.6 resolver: lts-2.22 diff --git a/stack-lts-3.yaml b/stack-lts-3.yaml index dd8640a332..9e16515ed3 100644 --- a/stack-lts-3.yaml +++ b/stack-lts-3.yaml @@ -1,5 +1,6 @@ flags: {} packages: - '.' -extra-deps: [] +extra-deps: +- sourcemap-0.1.6 resolver: lts-3.6 diff --git a/stack-nightly.yaml b/stack-nightly.yaml index cd12fa35d9..3801289517 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -2,4 +2,5 @@ flags: {} packages: - '.' extra-deps: +- sourcemap-0.1.6 resolver: nightly-2015-09-29 From 0311a00290a30b1111e11182e9d89cd254354c3e Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Wed, 24 Feb 2016 08:03:25 +0000 Subject: [PATCH 0292/1580] Remove position from atoms (hanging error printer) --- src/Language/PureScript/Parser/Declarations.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 67e1533f9d..c6e9ad464c 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -374,7 +374,7 @@ parseLet = do return $ Let ds result parseValueAtom :: TokenParser Expr -parseValueAtom = withSourceSpan PositionedValue $ P.choice +parseValueAtom = P.choice [ parseAnonymousArgument , parseNumericLiteral , parseCharLiteral From e14e3f6ed66961c8700c395173ffb07cd9c8d926 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 8 Feb 2016 01:57:32 +0100 Subject: [PATCH 0293/1580] Adds psc-ide to the project --- bundle/README | 15 +- bundle/build.sh | 20 +- bundle/winbuild.sh | 20 +- psc-ide-client/Main.hs | 57 +++ psc-ide-server/Main.hs | 135 ++++++ psc-ide-server/PROTOCOL.md | 409 ++++++++++++++++++ psc-ide-server/README.md | 40 ++ purescript.cabal | 66 ++- src/Language/PureScript/Ide.hs | 199 +++++++++ src/Language/PureScript/Ide/CaseSplit.hs | 157 +++++++ src/Language/PureScript/Ide/CodecJSON.hs | 13 + src/Language/PureScript/Ide/Command.hs | 101 +++++ src/Language/PureScript/Ide/Completion.hs | 35 ++ src/Language/PureScript/Ide/Error.hs | 43 ++ src/Language/PureScript/Ide/Externs.hs | 102 +++++ src/Language/PureScript/Ide/Filter.hs | 110 +++++ src/Language/PureScript/Ide/Matcher.hs | 100 +++++ src/Language/PureScript/Ide/Pursuit.hs | 65 +++ src/Language/PureScript/Ide/Reexports.hs | 73 ++++ src/Language/PureScript/Ide/SourceFile.hs | 106 +++++ src/Language/PureScript/Ide/State.hs | 80 ++++ src/Language/PureScript/Ide/Types.hs | 240 ++++++++++ src/Language/PureScript/Ide/Watcher.hs | 40 ++ stack-lts-2.yaml | 1 + tests/Language/PureScript/Ide/FilterSpec.hs | 59 +++ tests/Language/PureScript/Ide/MatcherSpec.hs | 31 ++ .../Language/PureScript/Ide/ReexportsSpec.hs | 77 ++++ tests/Language/PureScript/IdeSpec.hs | 35 ++ tests/Main.hs | 3 + tests/PscIdeSpec.hs | 1 + tests/TestPscIde.hs | 7 + 31 files changed, 2415 insertions(+), 25 deletions(-) create mode 100644 psc-ide-client/Main.hs create mode 100644 psc-ide-server/Main.hs create mode 100644 psc-ide-server/PROTOCOL.md create mode 100644 psc-ide-server/README.md create mode 100644 src/Language/PureScript/Ide.hs create mode 100644 src/Language/PureScript/Ide/CaseSplit.hs create mode 100644 src/Language/PureScript/Ide/CodecJSON.hs create mode 100644 src/Language/PureScript/Ide/Command.hs create mode 100644 src/Language/PureScript/Ide/Completion.hs create mode 100644 src/Language/PureScript/Ide/Error.hs create mode 100644 src/Language/PureScript/Ide/Externs.hs create mode 100644 src/Language/PureScript/Ide/Filter.hs create mode 100644 src/Language/PureScript/Ide/Matcher.hs create mode 100644 src/Language/PureScript/Ide/Pursuit.hs create mode 100644 src/Language/PureScript/Ide/Reexports.hs create mode 100644 src/Language/PureScript/Ide/SourceFile.hs create mode 100644 src/Language/PureScript/Ide/State.hs create mode 100644 src/Language/PureScript/Ide/Types.hs create mode 100644 src/Language/PureScript/Ide/Watcher.hs create mode 100644 tests/Language/PureScript/Ide/FilterSpec.hs create mode 100644 tests/Language/PureScript/Ide/MatcherSpec.hs create mode 100644 tests/Language/PureScript/Ide/ReexportsSpec.hs create mode 100644 tests/Language/PureScript/IdeSpec.hs create mode 100644 tests/PscIdeSpec.hs create mode 100644 tests/TestPscIde.hs diff --git a/bundle/README b/bundle/README index 30fd0412e9..42596cfb6e 100644 --- a/bundle/README +++ b/bundle/README @@ -10,12 +10,15 @@ Installation Instructions This bundle contains the following executables: -- psc The PureScript compiler -- psci The PureScript interactive REPL (requires NodeJS) -- psc-docs A Markdown documentation generator for PureScript code -- psc-bundle Bundles together CommonJS modules produced by `psc` into a - single JavaScript file; useful for running in the browser. -- psc-publish Generates documentation packages for uploading to Pursuit +- psc The PureScript compiler +- psci The PureScript interactive REPL (requires NodeJS) +- psc-docs A Markdown documentation generator for PureScript code +- psc-bundle Bundles together CommonJS modules produced by `psc` into a + single JavaScript file; useful for running in the browser. +- psc-publish Generates documentation packages for uploading to Pursuit +- psc-ide-server Provides Editor Support in the form of type information and + autocompletion +- psc-ide-client Utility to query psc-ide-server Copy these files anywhere on your PATH. diff --git a/bundle/build.sh b/bundle/build.sh index 61c422ca18..33ef75cac0 100755 --- a/bundle/build.sh +++ b/bundle/build.sh @@ -21,16 +21,20 @@ strip ../dist/build/psci/psci strip ../dist/build/psc-docs/psc-docs strip ../dist/build/psc-publish/psc-publish strip ../dist/build/psc-bundle/psc-bundle +strip ../dist/build/psc-ide-server/psc-ide-server +strip ../dist/build/psc-ide-client/psc-ide-client # Copy files to staging directory -cp ../dist/build/psc/psc build/purescript/ -cp ../dist/build/psci/psci build/purescript/ -cp ../dist/build/psc-docs/psc-docs build/purescript/ -cp ../dist/build/psc-publish/psc-publish build/purescript/ -cp ../dist/build/psc-bundle/psc-bundle build/purescript/ -cp README build/purescript/ -cp ../LICENSE build/purescript/ -cp ../INSTALL.md build/purescript/ +cp ../dist/build/psc/psc build/purescript/ +cp ../dist/build/psci/psci build/purescript/ +cp ../dist/build/psc-docs/psc-docs build/purescript/ +cp ../dist/build/psc-publish/psc-publish build/purescript/ +cp ../dist/build/psc-bundle/psc-bundle build/purescript/ +cp ../dist/build/psc-ide-server/psc-ide-server build/purescript/ +cp ../dist/build/psc-ide-client/psc-ide-client build/purescript/ +cp README build/purescript/ +cp ../LICENSE build/purescript/ +cp ../INSTALL.md build/purescript/ # Make the binary bundle pushd build > /dev/null diff --git a/bundle/winbuild.sh b/bundle/winbuild.sh index f0bfb7e595..cdc5d84394 100644 --- a/bundle/winbuild.sh +++ b/bundle/winbuild.sh @@ -17,16 +17,20 @@ strip ../dist/build/psci/psci.exe strip ../dist/build/psc-docs/psc-docs.exe strip ../dist/build/psc-publish/psc-publish.exe strip ../dist/build/psc-bundle/psc-bundle.exe +strip ../dist/build/psc-ide-server/psc-ide-server +strip ../dist/build/psc-ide-client/psc-ide-client # Copy files to staging directory -cp ../dist/build/psc/psc.exe build/purescript/ -cp ../dist/build/psci/psci.exe build/purescript/ -cp ../dist/build/psc-docs/psc-docs.exe build/purescript/ -cp ../dist/build/psc-publish/psc-publish.exe build/purescript/ -cp ../dist/build/psc-bundle/psc-bundle.exe build/purescript/ -cp README build/purescript/ -cp ../LICENSE build/purescript/ -cp ../INSTALL.md build/purescript/ +cp ../dist/build/psc/psc.exe build/purescript/ +cp ../dist/build/psci/psci.exe build/purescript/ +cp ../dist/build/psc-docs/psc-docs.exe build/purescript/ +cp ../dist/build/psc-publish/psc-publish.exe build/purescript/ +cp ../dist/build/psc-bundle/psc-bundle.exe build/purescript/ +cp ../dist/build/psc-ide-server/psc-ide-server.exe build/purescript/ +cp ../dist/build/psc-ide-client/psc-ide-client.exe build/purescript/ +cp README build/purescript/ +cp ../LICENSE build/purescript/ +cp ../INSTALL.md build/purescript/ # Make the binary bundle pushd build diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs new file mode 100644 index 0000000000..7007815ae5 --- /dev/null +++ b/psc-ide-client/Main.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Prelude () +import Prelude.Compat + +import Control.Exception +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Version (showVersion) +import Network +import Options.Applicative +import System.Exit +import System.IO + +import qualified Paths_purescript as Paths + +data Options = Options + { optionsPort :: Maybe Int + } + +main :: IO () +main = do + Options port <- execParser opts + let port' = PortNumber . fromIntegral $ fromMaybe 4242 port + client port' + where + parser = + Options <$> + optional (option auto (long "port" <> short 'p')) + opts = info (version <*> parser) mempty + version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden + +client :: PortID -> IO () +client port = do + h <- + connectTo "localhost" port `catch` + (\(SomeException e) -> + putStrLn + ("Couldn't connect to psc-ide-server on port: " ++ + show port ++ " Error: " ++ show e) >> + exitFailure) + cmd <- T.getLine + -- Temporary fix for emacs windows bug + let cleanedCmd = removeSurroundingTicks cmd + -- + T.hPutStrLn h cleanedCmd + res <- T.hGetLine h + putStrLn (T.unpack res) + hFlush stdout + hClose h + +-- TODO: Fix this in the emacs plugin by using a real process over shellcommands +removeSurroundingTicks :: Text -> Text +removeSurroundingTicks = T.dropWhile (== '\'') . T.dropWhileEnd (== '\'') diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs new file mode 100644 index 0000000000..6188c49864 --- /dev/null +++ b/psc-ide-server/Main.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Prelude () +import Prelude.Compat + +import Control.Concurrent (forkFinally) +import Control.Concurrent.STM +import Control.Exception (bracketOnError) +import Control.Monad +import "monad-logger" Control.Monad.Logger +import Control.Monad.Reader +import Control.Monad.Trans.Except +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Version (showVersion) +import Language.PureScript.Ide +import Language.PureScript.Ide.CodecJSON +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Watcher +import Network hiding (socketPort) +import Network.BSD (getProtocolNumber) +import Network.Socket hiding (PortNumber, Type, + accept, sClose) +import Options.Applicative +import System.Directory +import System.FilePath +import System.IO + +import qualified Paths_purescript as Paths + +-- "Borrowed" from the Idris Compiler +-- Copied from upstream impl of listenOn +-- bound to localhost interface instead of iNADDR_ANY +listenOnLocalhost :: PortID -> IO Socket +listenOnLocalhost (PortNumber port) = do + proto <- getProtocolNumber "tcp" + localhost <- inet_addr "127.0.0.1" + bracketOnError + (socket AF_INET Stream proto) + sClose + (\sock -> do + setSocketOption sock ReuseAddr 1 + bindSocket sock (SockAddrInet port localhost) + listen sock maxListenQueue + pure sock) +listenOnLocalhost _ = error "Wrong Porttype" + +data Options = Options + { optionsDirectory :: Maybe FilePath + , optionsOutputPath :: FilePath + , optionsPort :: PortID + , optionsDebug :: Bool + } + +main :: IO () +main = do + Options dir outputPath port debug <- execParser opts + maybe (pure ()) setCurrentDirectory dir + serverState <- newTVarIO emptyPscIdeState + cwd <- getCurrentDirectory + _ <- forkFinally (watcher serverState (cwd outputPath)) print + let conf = + Configuration + { + confDebug = debug + , confOutputPath = outputPath + } + let env = + PscIdeEnvironment + { + envStateVar = serverState + , envConfiguration = conf + } + startServer port env + where + parser = + Options <$> + optional (strOption (long "directory" <> short 'd')) <*> + strOption (long "output-directory" <> value "output/") <*> + (PortNumber . fromIntegral <$> + option auto (long "port" <> short 'p' <> value (4242 :: Integer))) <*> + switch (long "debug") + opts = info (version <*> parser) mempty + version = abortOption + (InfoMsg (showVersion Paths.version)) + (long "version" <> help "Show the version number") + +startServer :: PortID -> PscIdeEnvironment -> IO () +startServer port env = withSocketsDo $ do + sock <- listenOnLocalhost port + runLogger (runReaderT (forever (loop sock)) env) + where + runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (envConfiguration env)) + + loop :: (PscIde m, MonadLogger m) => Socket -> m () + loop sock = do + (cmd,h) <- acceptCommand sock + case decodeT cmd of + Just cmd' -> do + result <- runExceptT (handleCommand cmd') + $(logDebug) ("Answer was: " <> T.pack (show result)) + liftIO (hFlush stdout) + case result of + -- What function can I use to clean this up? + Right r -> liftIO $ T.hPutStrLn h (encodeT r) + Left err -> liftIO $ T.hPutStrLn h (encodeT err) + Nothing -> do + $(logDebug) ("Parsing the command failed. Command: " <> cmd) + liftIO $ do + T.hPutStrLn h (encodeT (GeneralError "Error parsing Command.")) + hFlush stdout + liftIO (hClose h) + + +acceptCommand :: (Applicative m, MonadIO m, MonadLogger m) + => Socket -> m (T.Text, Handle) +acceptCommand sock = do + h <- acceptConnection + $(logDebug) "Accepted a connection" + cmd <- liftIO (T.hGetLine h) + $(logDebug) cmd + pure (cmd, h) + where + acceptConnection = liftIO $ do + (h,_,_) <- accept sock + hSetEncoding h utf8 + hSetBuffering h LineBuffering + pure h diff --git a/psc-ide-server/PROTOCOL.md b/psc-ide-server/PROTOCOL.md new file mode 100644 index 0000000000..0a3f00197e --- /dev/null +++ b/psc-ide-server/PROTOCOL.md @@ -0,0 +1,409 @@ +# Protocol + +Encode the following JSON formats into a single line string and pass them to +`psc-ide-client`s stdin. You can then read the result from `psc-ide-client`s +stdout as a single line. The result needs to be unwrapped from the "wrapper" +which separates success from failure. This wrapper is described at the end of +this document. + +## Command: +### Load +The `load` command "loads" the requested modules into the server +for completion and type info. + +**Params:** + - `modules :: (optional) [ModuleName]`: A list of modules to load. + psc-ide-server will try to parse all the declarations in these modules + - `dependencies :: (optional) [ModuleName]`: A list of modules to load + including their dependencies. In contrast to the `module` field, all the + imports in these Modules will also be loaded. + +```json +{ + "command": "load", + "params": { + "modules": (optional)["Module.Name1", "Module.Name2"], + "dependencies": (optional)["Module.Name3"] + } +} +``` + +**Result:** + +The Load Command returns a string. + +### Type +The `type` command looks up the type for a given identifier. + +**Params:** + - `search :: String`: The identifier to look for. Only matches on equality. + - `filters :: [Filter]`: These filters will be applied before looking for the + identifier. These filters get combined with *AND*, so a candidate must match *ALL* + of them to be eligible. +```json +{ + "command": "type", + "params": { + "search": "filterM", + "filters": [Filter] + } +} +``` + +**Result:** +The possible types are returned in the same format as completions + +### Complete +The `complete` command looks up possible completions/corrections. + +**Params**: + - `filters :: [Filter]`: The same as for the `type` command. A candidate must match + all filters. + - `matcher :: (optional) Matcher`: The strategy used for matching candidates after filtering. + Results are scored internally and will be returned in the descending order where + the nth element is better then the n+1-th. + + If no matcher is given every candidate, that passes the filters, is returned in no + particular order. +```json +{ + "command": "complete", + "params": { + "filters": [Filter], + "matcher": (optional) Matcher + } +} +``` + +**Result:** + +The following format is returned as the Result: + +```json +[ + { + "module": "Data.Array", + "identifier": "filter", + "type": "forall a. (a -> Boolean) -> Array a -> Array a" + } +] +``` + + +### CaseSplit + +The CaseSplit command takes a line of source code, an area in that line of code +and replaces it with all patterns for a given type. The parameter `annotations` +is used to turn type annotations on or off for the constructor fields. + +```json +{ + "command": "caseSplit", + "params": { + "line": "elem a as", + "begin": 8, + "end": 10, + "annotations": true, + "type": "List" + } +} +``` + +**Result:** + +The following format is returned as the Result: + +```json +[ + "elem a Nil", + "elem a (Cons (_ :: a) (_ :: List a))" +] +``` +You should then be able to replace the affected line of code in the editor with the new suggestions. + +### Add Clause + +The AddClause command takes a typedeclaration and generates a function template for the given type. +The `annotations` option turns type annotations on or off for the function arguments. + +```json +{ + "command": "addClause", + "params": { + "line": "elem :: forall a. (Eq a) => a -> List a", + "annotations": true + } +} +``` + +**Result:** + +The following format is returned as the Result: + +```json +[ + "elem :: forall a. (Eq a) => a -> List a", + "elem ( _ :: a) = ?elem" +] +``` +You should then be able to replace the affected line of code in the editor with the new suggestions. + +### Pursuit +The `pursuit` command looks up the packages/completions for a given identifier from Pursuit. + +**Params:** + - `query :: String`: With `type: "package"` this should be a module name. With + `type: "completion"` this can be any string to look up. + - `type :: String`: Takes the following values: + - `package`: Looks for packages that contain the given module name. + - `completion` Looks for declarations for the query from Pursuit. + +```json +{ + "command": "pursuit", + "params": { + "query": "Data.Array", + "type": "package" + } +} +``` + +**Result:** + +`package` returns: + +```json +[ + { + "module": "Module1.Name", + "package": "purescript-packagename" + } +] +``` + +`completion` returns: + +```json +[ + { + "module": "Data.Array", + "identifier": "filter", + "type": "forall a. (a -> Boolean) -> Array a -> Array a", + "package": "purescript-arrays" + } +] +``` + +### List + +#### Loaded Modules + +`list` of type `loadedModules` lists all loaded modules (This means they can be searched for completions etc) + +```json +{ + "command": "list", + "params": { + "type": "loadedModules" + } +} +``` + +#### Response: + +The list loadedModules command returns a list of strings. + +#### Available Modules + +`list` of type `availableModules` lists all available modules. (This basically +means the contents of the `output/` folder.)) + +```json +{ + "command": "list", + "params": { + "type": "availableModules" + } +} +``` + +#### Response: + +The list availableModules command returns a list of strings. + +#### Imports + +The list commmand can also list the imports for a given file. + +```json +{ + "command": "list", + "params": { + "type": "import", + "file": "/home/kritzcreek/Documents/psc-ide/examples/Main.purs" + } +} +``` + +#### Response: + +The list import command returns a list of imports where imports are of the following form: + +Implicit Import(`import Data.Array`): +```json +[ + { + "module": "Data.Array", + "importType": "implicit" + } +] +``` + +Implicit qualified Import(`import qualified Data.Array as A`): +```json +[ + { + "module": "Data.Array", + "importType": "implicit", + "qualifier": "A" + } +] +``` + +Explicit Import(`import Data.Array (filter, filterM, join)`): +```json +[ + { + "module": "Data.Array", + "importType": "explicit", + "identifiers": ["filter", "filterM", "join"] + } +] +``` + +Hiding Import(`import Data.Array hiding (filter, filterM, join)`): +```json +[ + { + "module": "Data.Array", + "importType": "hiding", + "identifiers": ["filter", "filterM", "join"] + } +] +``` +### Cwd/Quit +`cwd` returns the working directory of the server(should be your project root). + +`quit` quits the server. + +```json +{ + "command": "cwd|quit" +} +``` + +**Result:** +These commands return strings. + +## Filter: + +### Exact filter +The Exact filter only keeps identifiers that are equal to the search term. + +```json +{ + "filter": "exact", + "params": { + "search": "filterM" + } +} +``` +### Prefix filter +The Prefix filter keeps identifiers/modules/data declarations that +are prefixed by the search term. + +```json +{ + "filter": "prefix", + "params": { + "search": "filt" + } +} +``` + +### Module filter +The Module filter only keeps identifiers that appear in the listed modules. + +```json +{ + "filter": "modules", + "params": { + "modules": ["My.Module"] + } +} +``` + +### Dependency filter +The Dependency filter only keeps identifiers that appear in the listed modules +and in any of their dependencies/imports. + +```json +{ + "filter": "dependencies", + "params": { + "modules": ["My.Module"] + } +} +``` + +## Matcher: + +### Flex matcher +Matches any occurence of the search string with intersections + +The scoring measures how far the matches span the string, where +closer is better. The matches then get sorted with highest score first. + +Examples: +- flMa matches **fl**ex**Ma**tcher. Score: 14.28 +- sons matches **so**rtCompletio**ns**. Score: 6.25 +```json + +{ + "matcher": "flex", + "params": { + "search": "filt" + } +} +``` + +### Distance Matcher + +The Distance matcher is meant to provide corrections for typos. It calculates +the edit distance in between the search and the loaded identifiers. + +```json +{ + "matcher": "distance", + "params": { + "search": "dilterM", + "maximumDistance": 3 + } +} +``` + +## Responses + +All Responses are wrapped in the following format: + +```json +{ + "resultType": "success|error", + "result": Result|Error +} +``` + +### Error + +Errors at this point are merely Error strings. Newlines are escaped like `\n` +and should be taken care of by the editor-plugin. diff --git a/psc-ide-server/README.md b/psc-ide-server/README.md new file mode 100644 index 0000000000..4398a7c3fc --- /dev/null +++ b/psc-ide-server/README.md @@ -0,0 +1,40 @@ +psc-ide +=== + +A tool which provides editor support for the PureScript programming language. + +## Editor Integration +* [@epost](https://github.com/epost) wrote a plugin to integrate psc-ide with Emacs at https://github.com/epost/psc-ide-emacs. +* Atom integration is available with https://github.com/nwolverson/atom-ide-purescript. +* Visual Studio Code integration is available with https://github.com/nwolverson/vscode-ide-purescript. +* Vim integration is available here: https://github.com/FrigoEU/psc-ide-vim. + +## Running the Server +Start the server by running the `psc-ide-server` executable. +It supports the following options: + +- `-p / --port` specify a port. Defaults to 4242 +- `-d / --directory` specify the toplevel directory of your project. Defaults to + the current directory +- `--output-directory`: Specify where to look for compiled output inside your + project directory. Defaults to `output/`, relative to either the current + directory or the directory specified by `-d`. +- `--debug`: Enables some logging meant for debugging +- `--version`: Output psc-ide version + +## Issuing queries + +After you started the server you can start issuing requests using +`psc-ide-client`. Make sure you start by loading the modules before you try to +query them. + +`psc-ide-server` expects the build externs.purs inside the `output/` folder of +your project after running `pulp build` or `psc-make` respectively. + +(If you changed the port of the server you can change the port for +`psc-ide-client` by using the -p option accordingly) + +## Protocol + +For documentation about the protocol have a look at: +[PROTOCOL.md](PROTOCOL.md) diff --git a/purescript.cabal b/purescript.cabal index 93a3a4de39..55bb81f481 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -14,7 +14,8 @@ Homepage: http://www.purescript.org/ author: Phil Freeman , Gary Burgess , Hardy Jones , - Harry Garrood + Harry Garrood , + Christoph Hegemann tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1 @@ -80,7 +81,15 @@ library safe >= 0.3.9 && < 0.4, semigroups >= 0.16.2 && < 0.19, parallel >= 3.2 && < 3.3, - sourcemap >= 0.1.6 + sourcemap >= 0.1.6, + stm >= 0.2.4.0, + regex-tdfa -any, + edit-distance -any, + fsnotify >= 0.2.1, + monad-logger >= 0.3 && < 0.4, + pipes >= 4.0.0 && < 4.2.0 , + pipes-http -any, + http-types -any exposed-modules: Language.PureScript Language.PureScript.AST @@ -188,6 +197,22 @@ library Language.PureScript.Publish.ErrorsWarnings Language.PureScript.Publish.BoxesHelpers + Language.PureScript.Ide + Language.PureScript.Ide.Command + Language.PureScript.Ide.Externs + Language.PureScript.Ide.Error + Language.PureScript.Ide.CodecJSON + Language.PureScript.Ide.Pursuit + Language.PureScript.Ide.Completion + Language.PureScript.Ide.Matcher + Language.PureScript.Ide.Filter + Language.PureScript.Ide.Types + Language.PureScript.Ide.State + Language.PureScript.Ide.CaseSplit + Language.PureScript.Ide.SourceFile + Language.PureScript.Ide.Watcher + Language.PureScript.Ide.Reexports + Control.Monad.Logger Control.Monad.Supply Control.Monad.Supply.Class @@ -286,13 +311,46 @@ executable psc-bundle ghc-options: -Wall -O2 hs-source-dirs: psc-bundle +executable psc-ide-server + main-is: Main.hs + other-modules: + other-extensions: + build-depends: base >=4 && <5 + , purescript -any + , directory -any + , filepath -any + , monad-logger -any + , mtl -any + , transformers -any + , transformers-compat -any + , network -any + , optparse-applicative >= 0.10.0 + , stm -any + , text -any + , base-compat >=0.6.0 + ghc-options: -Wall -O2 -threaded + hs-source-dirs: psc-ide-server + +executable psc-ide-client + main-is: Main.hs + other-modules: + other-extensions: + build-depends: base >=4 && <5 + , mtl -any + , text -any + , optparse-applicative >= 0.10.0 + , network -any + , base-compat >=0.6.0 + ghc-options: -Wall -O2 + hs-source-dirs: psc-ide-client + test-suite tests build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, mtl -any, parsec -any, purescript -any, transformers -any, process -any, transformers-compat -any, time -any, Glob -any, aeson-better-errors -any, bytestring -any, aeson -any, base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any, - boxes -any, HUnit -any + boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any ghc-options: -Wall type: exitcode-stdio-1.0 main-is: Main.hs @@ -301,5 +359,7 @@ test-suite tests TestDocs TestPscPublish TestPsci + TestPscIde + PscIdeSpec buildable: True hs-source-dirs: tests psci diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs new file mode 100644 index 0000000000..3d9a45af02 --- /dev/null +++ b/src/Language/PureScript/Ide.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Language.PureScript.Ide where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Error.Class +import Control.Monad.IO.Class +import "monad-logger" Control.Monad.Logger +import Control.Monad.Reader.Class +import Data.Foldable +import qualified Data.Map.Lazy as M +import Data.Maybe (catMaybes, mapMaybe) +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Language.PureScript.Ide.CaseSplit as CS +import Language.PureScript.Ide.Command +import Language.PureScript.Ide.Completion +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Externs +import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Matcher +import Language.PureScript.Ide.Pursuit +import Language.PureScript.Ide.Reexports +import Language.PureScript.Ide.SourceFile +import Language.PureScript.Ide.State +import Language.PureScript.Ide.Types +import System.Directory +import System.FilePath +import System.Exit + + +handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => + Command -> m Success +handleCommand (Load modules deps) = + loadModulesAndDeps modules deps +handleCommand (Type search filters) = + findType search filters +handleCommand (Complete filters matcher) = + findCompletions filters matcher +handleCommand (Pursuit query Package) = + findPursuitPackages query +handleCommand (Pursuit query Identifier) = + findPursuitCompletions query +handleCommand (List LoadedModules) = + printModules +handleCommand (List AvailableModules) = + listAvailableModules +handleCommand (List (Imports fp)) = + importsForFile fp +handleCommand (CaseSplit l b e wca t) = + caseSplit l b e wca t +handleCommand (AddClause l wca) = + pure $ addClause l wca +handleCommand Cwd = + TextResult . T.pack <$> liftIO getCurrentDirectory +handleCommand Quit = liftIO exitSuccess + +findCompletions :: (PscIde m, MonadLogger m) => + [Filter] -> Matcher -> m Success +findCompletions filters matcher = + CompletionResult . getCompletions filters matcher <$> getAllModulesWithReexports + +findType :: (PscIde m, MonadLogger m) => + DeclIdent -> [Filter] -> m Success +findType search filters = + CompletionResult . getExactMatches search filters <$> getAllModulesWithReexports + +findPursuitCompletions :: (Applicative m, MonadIO m, MonadLogger m) => + PursuitQuery -> m Success +findPursuitCompletions (PursuitQuery q) = + PursuitResult <$> liftIO (searchPursuitForDeclarations q) + +findPursuitPackages :: (Applicative m, MonadIO m, MonadLogger m) => + PursuitQuery -> m Success +findPursuitPackages (PursuitQuery q) = + PursuitResult <$> liftIO (findPackagesForModuleIdent q) + +loadExtern ::(PscIde m, MonadLogger m, MonadError PscIdeError m) => + FilePath -> m () +loadExtern fp = do + m <- readExternFile fp + insertModule m + +printModules :: (PscIde m) => m Success +printModules = printModules' <$> getPscIdeState + +printModules' :: M.Map ModuleIdent [ExternDecl] -> Success +printModules' = ModuleList . M.keys + +listAvailableModules :: PscIde m => m Success +listAvailableModules = do + outputPath <- confOutputPath . envConfiguration <$> ask + liftIO $ do + cwd <- getCurrentDirectory + dirs <- getDirectoryContents (cwd outputPath) + return (ModuleList (listAvailableModules' dirs)) + +listAvailableModules' :: [FilePath] -> [Text] +listAvailableModules' dirs = + let cleanedModules = filter (`notElem` [".", ".."]) dirs + in map T.pack cleanedModules + +caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => + Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success +caseSplit l b e csa t = do + patterns <- CS.makePattern l b e csa <$> CS.caseSplit t + pure (MultilineTextResult patterns) + +addClause :: Text -> CS.WildcardAnnotations -> Success +addClause t wca = MultilineTextResult (CS.addClause t wca) + +importsForFile :: (Applicative m, MonadIO m, MonadLogger m, MonadError PscIdeError m) => + FilePath -> m Success +importsForFile fp = do + imports <- getImportsForFile fp + pure (ImportList imports) + +-- | The first argument is a set of modules to load. The second argument +-- denotes modules for which to load dependencies +loadModulesAndDeps :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => + [ModuleIdent] -> [ModuleIdent] -> m Success +loadModulesAndDeps mods deps = do + r1 <- mapM loadModule (mods ++ deps) + r2 <- mapM loadModuleDependencies deps + let moduleResults = T.concat r1 + let dependencyResults = T.concat r2 + pure (TextResult (moduleResults <> ", " <> dependencyResults)) + +loadModuleDependencies ::(PscIde m, MonadLogger m, MonadError PscIdeError m) => + ModuleIdent -> m Text +loadModuleDependencies moduleName = do + m <- getModule moduleName + case getDependenciesForModule <$> m of + Just deps -> do + mapM_ loadModule deps + -- We need to load the modules, that get reexported from the dependencies + depModules <- catMaybes <$> mapM getModule deps + -- What to do with errors here? This basically means a reexported dependency + -- doesn't exist in the output/ folder + traverse_ loadReexports depModules + pure ("Dependencies for " <> moduleName <> " loaded.") + Nothing -> throwError (ModuleNotFound moduleName) + +loadReexports :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => + Module -> m [ModuleIdent] +loadReexports m = case getReexports m of + [] -> pure [] + exportDeps -> do + -- I'm fine with this crashing on a failed pattern match. + -- If this ever fails I'll need to look at GADTs + let reexports = map (\(Export mn) -> mn) exportDeps + $(logDebug) ("Loading reexports for module: " <> fst m <> + " reexports: " <> T.intercalate ", " reexports) + traverse_ loadModule reexports + exportDepsModules <- catMaybes <$> traverse getModule reexports + exportDepDeps <- traverse loadReexports exportDepsModules + return $ concat exportDepDeps + +getDependenciesForModule :: Module -> [ModuleIdent] +getDependenciesForModule (_, decls) = mapMaybe getDependencyName decls + where getDependencyName (Dependency dependencyName _ _) = Just dependencyName + getDependencyName _ = Nothing + +loadModule :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => + ModuleIdent -> m Text +loadModule "Prim" = pure "Prim won't be loaded" +loadModule mn = do + path <- filePathFromModule mn + loadExtern path + $(logDebug) ("Loaded extern file at: " <> T.pack path) + pure ("Loaded extern file at: " <> T.pack path) + +filePathFromModule :: (PscIde m, MonadError PscIdeError m) => + ModuleIdent -> m FilePath +filePathFromModule moduleName = do + outputPath <- confOutputPath . envConfiguration <$> ask + cwd <- liftIO getCurrentDirectory + let path = cwd outputPath T.unpack moduleName "externs.json" + ex <- liftIO $ doesFileExist path + if ex + then pure path + else throwError (ModuleFileNotFound moduleName) + +-- | Taken from Data.Either.Utils +maybeToEither :: MonadError e m => + e -- ^ (Left e) will be returned if the Maybe value is Nothing + -> Maybe a -- ^ (Right a) will be returned if this is (Just a) + -> m a +maybeToEither errorval Nothing = throwError errorval +maybeToEither _ (Just normalval) = return normalval diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs new file mode 100644 index 0000000000..83dbeab2af --- /dev/null +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} + +module Language.PureScript.Ide.CaseSplit + ( WildcardAnnotations() + , explicitAnnotations + , noAnnotations + , makePattern + , addClause + , caseSplit + ) where + +import Prelude () +import Prelude.Compat hiding (lex) + +import Control.Monad.Error.Class +import "monad-logger" Control.Monad.Logger +import Data.List (find) +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Language.PureScript.AST +import Language.PureScript.Environment +import Language.PureScript.Externs +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Externs (unwrapPositioned) +import Language.PureScript.Ide.State +import Language.PureScript.Ide.Types hiding (Type) +import Language.PureScript.Names +import Language.PureScript.Parser.Common (runTokenParser) +import Language.PureScript.Parser.Declarations +import Language.PureScript.Parser.Lexer (lex) +import Language.PureScript.Parser.Types +import Language.PureScript.Pretty +import Language.PureScript.Types +import Text.Parsec as P + +type Constructor = (ProperName 'ConstructorName, [Type]) + +newtype WildcardAnnotations = WildcardAnnotations Bool + +explicitAnnotations :: WildcardAnnotations +explicitAnnotations = WildcardAnnotations True + +noAnnotations :: WildcardAnnotations +noAnnotations = WildcardAnnotations False + +caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => + Text -> m [Constructor] +caseSplit q = do + (tc, args) <- splitTypeConstructor (parseType' (T.unpack q)) + (EDType _ _ (DataType typeVars ctors)) <- findTypeDeclaration tc + let applyTypeVars = everywhereOnTypes (replaceAllTypeVars (zip (map fst typeVars) args)) + let appliedCtors = map (\(n, ts) -> (n, map applyTypeVars ts)) ctors + pure appliedCtors + +{- ["EDType { + edTypeName = ProperName {runProperName = \"Either\"} + , edTypeKind = FunKind Star (FunKind Star Star) + , edTypeDeclarationKind = + DataType [(\"a\",Just Star),(\"b\",Just Star)] + [(ProperName {runProperName = \"Left\"},[TypeVar \"a\"]) + ,(ProperName {runProperName = \"Right\"},[TypeVar \"b\"])]}"] +-} + +findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => + ProperName 'TypeName -> m ExternsDeclaration +findTypeDeclaration q = do + efs <- getExternFiles + let m = getFirst $ foldMap (findTypeDeclaration' q) efs + case m of + Just mn -> pure mn + Nothing -> throwError (GeneralError "Not Found") + +findTypeDeclaration' :: + ProperName 'TypeName + -> ExternsFile + -> First ExternsDeclaration +findTypeDeclaration' t ExternsFile{..} = + First $ find (\case + EDType tn _ _ -> tn == t + _ -> False) efDeclarations + +splitTypeConstructor :: (Applicative m, MonadError PscIdeError m) => + Type -> m (ProperName 'TypeName, [Type]) +splitTypeConstructor = go [] + where + go acc (TypeApp ty arg) = go (arg : acc) ty + go acc (TypeConstructor tc) = pure (disqualify tc, acc) + go _ _ = throwError (GeneralError "Failed to read TypeConstructor") + +prettyCtor :: WildcardAnnotations -> Constructor -> Text +prettyCtor _ (ctorName, []) = T.pack (runProperName ctorName) +prettyCtor wsa (ctorName, ctorArgs) = + "("<> T.pack (runProperName ctorName) <> " " + <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")" + +prettyPrintWildcard :: WildcardAnnotations -> Type -> Text +prettyPrintWildcard (WildcardAnnotations True) = prettyWildcard +prettyPrintWildcard (WildcardAnnotations False) = const "_" + +prettyWildcard :: Type -> Text +prettyWildcard t = "( _ :: " <> T.strip (T.pack (prettyPrintTypeAtom t)) <> ")" + +-- | Constructs Patterns to insert into a sourcefile +makePattern :: Text -- ^ Current line + -> Int -- ^ Begin of the split + -> Int -- ^ End of the split + -> WildcardAnnotations -- ^ Whether to explicitly type the splits + -> [Constructor] -- ^ Constructors to split + -> [Text] +makePattern t x y wsa = makePattern' (T.take x t) (T.drop y t) + where + makePattern' lhs rhs = map (\ctor -> lhs <> prettyCtor wsa ctor <> rhs) + +addClause :: Text -> WildcardAnnotations -> [Text] +addClause s wca = + let (fName, fType) = parseTypeDeclaration' (T.unpack s) + (args, _) = splitFunctionType fType + template = T.pack (runIdent fName) <> " " <> + T.unwords (map (prettyPrintWildcard wca) args) <> + " = ?" <> (T.strip . T.pack . runIdent $ fName) + in [s, template] + +parseType' :: String -> Type +parseType' s = let (Right t) = do + ts <- lex "" s + runTokenParser "" (parseType <* P.eof) ts + in t + +parseTypeDeclaration' :: String -> (Ident, Type) +parseTypeDeclaration' s = + let x = do + ts <- lex "" s + runTokenParser "" (parseDeclaration <* P.eof) ts + in + case unwrapPositioned <$> x of + Right (TypeDeclaration i t) -> (i, t) + y -> error (show y) + +splitFunctionType :: Type -> ([Type], Type) +splitFunctionType t = (arguments, returns) + where + returns = last splitted + arguments = init splitted + splitted = splitType' t + splitType' (ForAll _ t' _) = splitType' t' + splitType' (ConstrainedType _ t') = splitType' t' + splitType' (TypeApp (TypeApp t' lhs) rhs) + | t' == tyFunction = lhs : splitType' rhs + splitType' t' = [t'] diff --git a/src/Language/PureScript/Ide/CodecJSON.hs b/src/Language/PureScript/Ide/CodecJSON.hs new file mode 100644 index 0000000000..8a264c0925 --- /dev/null +++ b/src/Language/PureScript/Ide/CodecJSON.hs @@ -0,0 +1,13 @@ +module Language.PureScript.Ide.CodecJSON where + +import Data.Aeson +import Data.Text (Text()) +import Data.Text.Lazy (toStrict, fromStrict) +import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) + +encodeT :: (ToJSON a) => a -> Text +encodeT = toStrict . decodeUtf8 . encode + +decodeT :: (FromJSON a) => Text -> Maybe a +decodeT = decode . encodeUtf8 . fromStrict + diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs new file mode 100644 index 0000000000..d7387d4412 --- /dev/null +++ b/src/Language/PureScript/Ide/Command.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.PureScript.Ide.Command where + +import Prelude () +import Prelude.Compat + +import Control.Monad +import Data.Aeson +import Data.Maybe +import Data.Text (Text) +import Language.PureScript.Ide.CaseSplit +import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Matcher +import Language.PureScript.Ide.Types + +data Command + = Load { loadModules :: [ModuleIdent] + , loadDependencies :: [ModuleIdent]} + | Type { typeSearch :: DeclIdent + , typeFilters :: [Filter]} + | Complete { completeFilters :: [Filter] + , completeMatcher :: Matcher} + | Pursuit { pursuitQuery :: PursuitQuery + , pursuitSearchType :: PursuitSearchType} + | List {listType :: ListType} + | CaseSplit { + caseSplitLine :: Text + , caseSplitBegin :: Int + , caseSplitEnd :: Int + , caseSplitAnnotations :: WildcardAnnotations + , caseSplitType :: Type} + | AddClause { + addClauseLine :: Text + , addClauseAnnotations :: WildcardAnnotations} + | Cwd + | Quit + +data ListType = LoadedModules | Imports FilePath | AvailableModules + +instance FromJSON ListType where + parseJSON = withObject "ListType" $ \o -> do + (listType' :: String) <- o .: "type" + case listType' of + "import" -> do + fp <- o .: "file" + return (Imports fp) + "loadedModules" -> return LoadedModules + "availableModules" -> return AvailableModules + _ -> mzero + +instance FromJSON Command where + parseJSON = withObject "command" $ \o -> do + (command :: String) <- o .: "command" + case command of + "list" -> do + listType' <- o .:? "params" + return $ List (fromMaybe LoadedModules listType') + "cwd" -> return Cwd + "quit" -> return Quit + "load" -> do + params <- o .: "params" + mods <- params .:? "modules" + deps <- params .:? "dependencies" + return $ Load (fromMaybe [] mods) (fromMaybe [] deps) + "type" -> do + params <- o .: "params" + search <- params .: "search" + filters <- params .: "filters" + return $ Type search filters + "complete" -> do + params <- o .: "params" + filters <- params .:? "filters" + matcher <- params .:? "matcher" + return $ Complete (fromMaybe [] filters) (fromMaybe mempty matcher) + "pursuit" -> do + params <- o .: "params" + query <- params .: "query" + queryType <- params .: "type" + return $ Pursuit query queryType + "caseSplit" -> do + params <- o .: "params" + line <- params .: "line" + begin <- params .: "begin" + end <- params .: "end" + annotations <- params .: "annotations" + type' <- params .: "type" + return $ CaseSplit line begin end (if annotations + then explicitAnnotations + else noAnnotations) type' + "addClause" -> do + params <- o .: "params" + line <- params .: "line" + annotations <- params .: "annotations" + return $ AddClause line (if annotations + then explicitAnnotations + else noAnnotations) + _ -> mzero + diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs new file mode 100644 index 0000000000..d0430ad23a --- /dev/null +++ b/src/Language/PureScript/Ide/Completion.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.PureScript.Ide.Completion + (getCompletions, getExactMatches) + where + +import Prelude () +import Prelude.Compat + +import Data.Maybe (mapMaybe) +import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Matcher +import Language.PureScript.Ide.Types + +-- | Applies the CompletionFilters and the Matcher to the given Modules +-- and sorts the found Completions according to the Matching Score +getCompletions :: [Filter] -> Matcher -> [Module] -> [Completion] +getCompletions filters matcher modules = + runMatcher matcher $ completionsFromModules (applyFilters filters modules) + +getExactMatches :: DeclIdent -> [Filter] -> [Module] -> [Completion] +getExactMatches search filters modules = + completionsFromModules $ + applyFilters (equalityFilter search : filters) modules + +completionsFromModules :: [Module] -> [Completion] +completionsFromModules = foldMap completionFromModule + where + completionFromModule :: Module -> [Completion] + completionFromModule (moduleIdent, decls) = mapMaybe (completionFromDecl moduleIdent) decls + +completionFromDecl :: ModuleIdent -> ExternDecl -> Maybe Completion +completionFromDecl mi (FunctionDecl name type') = Just (Completion (mi, name, type')) +completionFromDecl mi (DataDecl name kind) = Just (Completion (mi, name, kind)) +completionFromDecl _ (ModuleDecl name _) = Just (Completion ("module", name, "module")) +completionFromDecl _ _ = Nothing diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs new file mode 100644 index 0000000000..9b5d1fb00e --- /dev/null +++ b/src/Language/PureScript/Ide/Error.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.PureScript.Ide.Error + (ErrorMsg, PscIdeError(..), textError, first) + where + +import Data.Aeson +import Data.Monoid +import Data.Text (Text, pack) +import Language.PureScript.Ide.Types (ModuleIdent) +import qualified Text.Parsec.Error as P + +type ErrorMsg = String + +data PscIdeError + = GeneralError ErrorMsg + | NotFound Text + | ModuleNotFound ModuleIdent + | ModuleFileNotFound ModuleIdent + | ParseError P.ParseError ErrorMsg + deriving (Show, Eq) + +instance ToJSON PscIdeError where + toJSON err = object + [ + "resultType" .= ("error" :: Text), + "result" .= textError err + ] + +textError :: PscIdeError -> Text +textError (GeneralError msg) = pack msg +textError (NotFound ident) = "Symbol '" <> ident <> "' not found." +textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found." +textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found" +textError (ParseError parseError msg) = pack $ msg <> ": " <> show (escape parseError) + where + -- escape newlines and other special chars so we can send the error over the socket as a single line + escape :: P.ParseError -> String + escape = show + +-- | Specialized version of `first` from `Data.Bifunctors` +first :: (a -> b) -> Either a r -> Either b r +first f (Left x) = Left (f x) +first _ (Right r2) = Right r2 diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs new file mode 100644 index 0000000000..67e9cd7867 --- /dev/null +++ b/src/Language/PureScript/Ide/Externs.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.PureScript.Ide.Externs + ( + ExternDecl(..), + ModuleIdent, + DeclIdent, + Type, + Fixity(..), + readExternFile, + convertExterns, + unwrapPositioned, + unwrapPositionedRef + ) where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Error.Class +import Control.Monad.IO.Class +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Language.PureScript.AST.Declarations as D +import qualified Language.PureScript.Externs as PE +import Language.PureScript.Ide.CodecJSON +import Language.PureScript.Ide.Error (PscIdeError (..)) +import Language.PureScript.Ide.Types +import qualified Language.PureScript.Names as N +import qualified Language.PureScript.Pretty as PP + +readExternFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) => + FilePath -> m PE.ExternsFile +readExternFile fp = do + parseResult <- liftIO (decodeT <$> T.readFile fp) + case parseResult of + Nothing -> throwError . GeneralError $ "Parsing the extern at: " ++ fp ++ " failed" + Just externs -> pure externs + +moduleNameToText :: N.ModuleName -> Text +moduleNameToText = T.pack . N.runModuleName + +properNameToText :: N.ProperName a -> Text +properNameToText = T.pack . N.runProperName + +identToText :: N.Ident -> Text +identToText = T.pack . N.runIdent + +convertExterns :: PE.ExternsFile -> Module +convertExterns ef = (moduleName, exportDecls ++ importDecls ++ otherDecls) + where + moduleName = moduleNameToText (PE.efModuleName ef) + importDecls = convertImport <$> PE.efImports ef + exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (PE.efExports ef) + -- Ignoring operator fixities for now since we're not using them + -- operatorDecls = convertOperator <$> PE.efFixities ef + otherDecls = mapMaybe convertDecl (PE.efDeclarations ef) + +convertImport :: PE.ExternsImport -> ExternDecl +convertImport ei = Dependency + (moduleNameToText (PE.eiModule ei)) + [] + (moduleNameToText <$> PE.eiImportedAs ei) + +convertExport :: D.DeclarationRef -> Maybe ExternDecl +convertExport (D.ModuleRef mn) = Just (Export (moduleNameToText mn)) +convertExport _ = Nothing + +convertDecl :: PE.ExternsDeclaration -> Maybe ExternDecl +convertDecl PE.EDType{..} = Just $ + DataDecl + (properNameToText edTypeName) + (packAndStrip (PP.prettyPrintKind edTypeKind)) +convertDecl PE.EDTypeSynonym{..} = Just $ + DataDecl + (properNameToText edTypeSynonymName) + (packAndStrip (PP.prettyPrintType edTypeSynonymType)) +convertDecl PE.EDDataConstructor{..} = Just $ + DataDecl + (properNameToText edDataCtorName) + (packAndStrip (PP.prettyPrintType edDataCtorType)) +convertDecl PE.EDValue{..} = Just $ + FunctionDecl + (identToText edValueName) + (packAndStrip (PP.prettyPrintType edValueType)) +convertDecl _ = Nothing + +packAndStrip :: String -> Text +packAndStrip = T.unwords . fmap T.strip . T.lines . T.pack + +unwrapPositioned :: D.Declaration -> D.Declaration +unwrapPositioned (D.PositionedDeclaration _ _ x) = x +unwrapPositioned x = x + +unwrapPositionedRef :: D.DeclarationRef -> D.DeclarationRef +unwrapPositionedRef (D.PositionedDeclarationRef _ _ x) = x +unwrapPositionedRef x = x diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs new file mode 100644 index 0000000000..47deed9acf --- /dev/null +++ b/src/Language/PureScript/Ide/Filter.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Language.PureScript.Ide.Filter + (Filter, moduleFilter, prefixFilter, equalityFilter, dependencyFilter, + runFilter, applyFilters) + where + +import Prelude () +import Prelude.Compat + +import Control.Monad +import Data.Aeson +import Data.Foldable +import Data.Maybe (listToMaybe, mapMaybe) +import Data.Monoid +import Data.Text (Text, isPrefixOf) +import Language.PureScript.Ide.Types + +newtype Filter = Filter (Endo [Module]) deriving(Monoid) + +mkFilter :: ([Module] -> [Module]) -> Filter +mkFilter = Filter . Endo + +-- | Only keeps the given Modules +moduleFilter :: [ModuleIdent] -> Filter +moduleFilter = + mkFilter . moduleFilter' + +moduleFilter' :: [ModuleIdent] -> [Module] -> [Module] +moduleFilter' moduleIdents = filter (flip elem moduleIdents . fst) + +-- | Only keeps the given Modules and all of their dependencies +dependencyFilter :: [ModuleIdent] -> Filter +dependencyFilter = mkFilter . dependencyFilter' + +dependencyFilter' :: [ModuleIdent] -> [Module] -> [Module] +dependencyFilter' moduleIdents mods = + moduleFilter' (concatMap (getDepForModule mods) moduleIdents) mods + where + getDepForModule :: [Module] -> ModuleIdent -> [ModuleIdent] + getDepForModule ms moduleIdent = + moduleIdent : maybe [] extractDeps (findModule moduleIdent ms) + + findModule :: ModuleIdent -> [Module] -> Maybe Module + findModule i ms = listToMaybe $ filter go ms + where go (mn, _) = i == mn + + extractDeps :: Module -> [ModuleIdent] + extractDeps = mapMaybe extractDep . snd + where extractDep (Dependency n _ _) = Just n + extractDep _ = Nothing + +-- | Only keeps Identifiers that start with the given prefix +prefixFilter :: Text -> Filter +prefixFilter "" = mkFilter id +prefixFilter t = mkFilter $ identFilter prefix t + where + prefix :: ExternDecl -> Text -> Bool + prefix (FunctionDecl name _) search = search `isPrefixOf` name + prefix (DataDecl name _) search = search `isPrefixOf` name + prefix (ModuleDecl name _) search = search `isPrefixOf` name + prefix _ _ = False + + +-- | Only keeps Identifiers that are equal to the search string +equalityFilter :: Text -> Filter +equalityFilter = mkFilter . identFilter equality + where + equality :: ExternDecl -> Text -> Bool + equality (FunctionDecl name _) prefix = prefix == name + equality (DataDecl name _) prefix = prefix == name + equality _ _ = False + + +identFilter :: (ExternDecl -> Text -> Bool ) -> Text -> [Module] -> [Module] +identFilter predicate search = + filter (not . null . snd) . fmap filterModuleDecls + where + filterModuleDecls :: Module -> Module + filterModuleDecls (moduleIdent,decls) = + (moduleIdent, filter (`predicate` search) decls) + +runFilter :: Filter -> [Module] -> [Module] +runFilter (Filter f)= appEndo f + +applyFilters :: [Filter] -> [Module] -> [Module] +applyFilters = runFilter . fold + +instance FromJSON Filter where + parseJSON = withObject "filter" $ \o -> do + (filter' :: String) <- o .: "filter" + case filter' of + "exact" -> do + params <- o .: "params" + search <- params .: "search" + return $ equalityFilter search + "prefix" -> do + params <- o.: "params" + search <- params .: "search" + return $ prefixFilter search + "modules" -> do + params <- o .: "params" + modules <- params .: "modules" + return $ moduleFilter modules + "dependencies" -> do + params <- o .: "params" + deps <- params .: "modules" + return $ dependencyFilter deps + _ -> mzero diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs new file mode 100644 index 0000000000..cb92cc3e33 --- /dev/null +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Language.PureScript.Ide.Matcher (Matcher, flexMatcher, runMatcher) where + +import Prelude () +import Prelude.Compat + +import Control.Monad +import Data.Aeson +import Data.Function (on) +import Data.List (sortBy) +import Data.Maybe (mapMaybe) +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Language.PureScript.Ide.Types +import Text.EditDistance +import Text.Regex.TDFA ((=~)) + + +type ScoredCompletion = (Completion, Double) + +newtype Matcher = Matcher (Endo [Completion]) deriving(Monoid) + +instance FromJSON Matcher where + parseJSON = withObject "matcher" $ \o -> do + (matcher :: Maybe String) <- o .:? "matcher" + case matcher of + Just "flex" -> do + params <- o .: "params" + search <- params .: "search" + pure $ flexMatcher search + Just "distance" -> do + params <- o .: "params" + search <- params .: "search" + maxDist <- params .: "maximumDistance" + pure $ distanceMatcher search maxDist + Just _ -> mzero + Nothing -> return mempty + +-- | Matches any occurence of the search string with intersections +-- | +-- | The scoring measures how far the matches span the string where +-- | closer is better. +-- | Examples: +-- | flMa matches flexMatcher. Score: 14.28 +-- | sons matches sortCompletions. Score: 6.25 +flexMatcher :: Text -> Matcher +flexMatcher pattern = mkMatcher (flexMatch pattern) + +distanceMatcher :: Text -> Int -> Matcher +distanceMatcher q maxDist = mkMatcher (distanceMatcher' q maxDist) + +distanceMatcher' :: Text -> Int -> [Completion] -> [ScoredCompletion] +distanceMatcher' q maxDist = mapMaybe go + where + go c@(Completion (_, y, _)) = let d = dist (T.unpack y) + in if d <= maxDist + then Just (c, 1 / fromIntegral d) + else Nothing + dist = levenshteinDistance defaultEditCosts (T.unpack q) + +mkMatcher :: ([Completion] -> [ScoredCompletion]) -> Matcher +mkMatcher matcher = Matcher . Endo $ fmap fst . sortCompletions . matcher + +runMatcher :: Matcher -> [Completion] -> [Completion] +runMatcher (Matcher m)= appEndo m + +sortCompletions :: [ScoredCompletion] -> [ScoredCompletion] +sortCompletions = sortBy (flip compare `on` snd) + +flexMatch :: Text -> [Completion] -> [ScoredCompletion] +flexMatch pattern = mapMaybe (flexRate pattern) + +flexRate :: Text -> Completion -> Maybe ScoredCompletion +flexRate pattern c@(Completion (_,ident,_)) = do + score <- flexScore pattern ident + return (c, score) + +-- FlexMatching ala Sublime. +-- Borrowed from: http://cdewaka.com/2013/06/fuzzy-pattern-matching-in-haskell/ +-- +-- By string =~ pattern we'll get the start of the match and the length of +-- the matchas a (start, length) tuple if there's a match. +-- If match fails then it would be (-1,0) +flexScore :: Text -> DeclIdent -> Maybe Double +flexScore "" _ = Nothing +flexScore pat str = + case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of + (-1,0) -> Nothing + (start,len) -> Just $ calcScore start (start + len) + where + Just (first,pattern) = T.uncons pat + -- This just interleaves the search string with .* + -- abcd -> a.*b.*c.*d + pat' = first `T.cons` T.concatMap (T.snoc ".*") pattern + calcScore start end = + 100.0 / fromIntegral ((1 + start) * (end - start + 1)) diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs new file mode 100644 index 0000000000..8a6987d3a6 --- /dev/null +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.PureScript.Ide.Pursuit where + +import Prelude () +import Prelude.Compat + +import qualified Control.Exception as E +import Data.Aeson +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (fromStrict) +import Data.Foldable (toList) +import Data.Monoid ((<>)) +import Data.Maybe (mapMaybe) +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import Language.PureScript.Ide.Types +import Network.HTTP.Types.Header (hAccept) +import Pipes.HTTP +import qualified Pipes.Prelude as P + +-- We need to remove trailing dots because Pursuit will return a 400 otherwise +-- TODO: remove this when the issue is fixed at Pursuit +queryPursuit :: Text -> IO ByteString +queryPursuit q = do + let qClean = T.dropWhileEnd (== '.') q + req' <- parseUrl "http://pursuit.purescript.org/search" + let req = req' + { queryString=("q=" <> (fromString . T.unpack) qClean) + , requestHeaders=[(hAccept, "application/json")] + } + m <- newManager tlsManagerSettings + withHTTP req m $ \resp -> + P.fold (\x a -> x <> a) "" id $ responseBody resp + + +handler :: HttpException -> IO [a] +handler StatusCodeException{} = return [] +handler _ = return [] + +searchPursuitForDeclarations :: Text -> IO [PursuitResponse] +searchPursuitForDeclarations query = + (do r <- queryPursuit query + let results' = decode (fromStrict r) :: Maybe Array + case results' of + Nothing -> pure [] + Just results -> pure (mapMaybe isDeclarationResponse (map fromJSON (toList results)))) `E.catch` + handler + where + isDeclarationResponse (Success a@DeclarationResponse{}) = Just a + isDeclarationResponse _ = Nothing + +findPackagesForModuleIdent :: Text -> IO [PursuitResponse] +findPackagesForModuleIdent query = + (do r <- queryPursuit query + let results' = decode (fromStrict r) :: Maybe Array + case results' of + Nothing -> pure [] + Just results -> pure (mapMaybe isModuleResponse (map fromJSON (toList results)))) `E.catch` + handler + where + isModuleResponse (Success a@ModuleResponse{}) = Just a + isModuleResponse _ = Nothing diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs new file mode 100644 index 0000000000..8831e777a4 --- /dev/null +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} +module Language.PureScript.Ide.Reexports where + + +import Prelude () +import Prelude.Compat + +import Data.List (union) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Language.PureScript.Ide.Types + +getReexports :: Module -> [ExternDecl] +getReexports (mn, decls)= concatMap getExport decls + where getExport d + | (Export mn') <- d + , mn /= mn' = replaceExportWithAliases decls mn' + | otherwise = [] + +dependencyToExport :: ExternDecl -> ExternDecl +dependencyToExport (Dependency m _ _) = Export m +dependencyToExport decl = decl + +replaceExportWithAliases :: [ExternDecl] -> ModuleIdent -> [ExternDecl] +replaceExportWithAliases decls ident = + case filter isMatch decls of + [] -> [Export ident] + aliases -> map dependencyToExport aliases + where isMatch d + | Dependency _ _ (Just alias) <- d + , alias == ident = True + | otherwise = False + +replaceReexport :: ExternDecl -> Module -> Module -> Module +replaceReexport e@(Export _) (m, decls) (_, newDecls) = + (m, filter (/= e) decls `union` newDecls) +replaceReexport _ _ _ = error "Should only get Exports here." + +emptyModule :: Module +emptyModule = ("Empty", []) + +isExport :: ExternDecl -> Bool +isExport (Export _) = True +isExport _ = False + +removeExportDecls :: Module -> Module +removeExportDecls = fmap (filter (not . isExport)) + +replaceReexports :: Module -> Map ModuleIdent [ExternDecl] -> Module +replaceReexports m db = result + where reexports = getReexports m + result = foldl go (removeExportDecls m) reexports + + go :: Module -> ExternDecl -> Module + go m' re@(Export name) = replaceReexport re m' (getModule name) + go _ _ = error "partiality! woohoo" + + getModule :: ModuleIdent -> Module + getModule name = clean res + where res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db + -- we have to do this because keeping self exports in will result in + -- infinite loops + clean (mn, decls) = (mn,) (filter (/= Export mn) decls) + +resolveReexports :: Map ModuleIdent [ExternDecl] -> Module -> Module +resolveReexports modules m = do + let replaced = replaceReexports m modules + if null . getReexports $ replaced + then replaced + else resolveReexports modules replaced diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs new file mode 100644 index 0000000000..ab22ba218a --- /dev/null +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +module Language.PureScript.Ide.SourceFile where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Error.Class +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import Data.Maybe (mapMaybe) +import Data.Monoid +import qualified Data.Text as T +import qualified Language.PureScript.AST.Declarations as D +import qualified Language.PureScript.AST.SourcePos as SP +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Externs (unwrapPositioned, + unwrapPositionedRef) +import Language.PureScript.Ide.Types +import qualified Language.PureScript.Names as N +import qualified Language.PureScript.Parser as P +import System.Directory + +parseModuleFromFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) => + FilePath -> m D.Module +parseModuleFromFile fp = do + exists <- liftIO (doesFileExist fp) + if exists + then do + content <- liftIO (readFile fp) + let m = do tokens <- P.lex fp content + P.runTokenParser "" P.parseModule tokens + either (throwError . (`ParseError` "File could not be parsed.")) pure m + else throwError (NotFound "File does not exist.") + +-- data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) + +getDeclarations :: D.Module -> [D.Declaration] +getDeclarations (D.Module _ _ _ declarations _) = declarations + +getImports :: D.Module -> [D.Declaration] +getImports (D.Module _ _ _ declarations _) = + mapMaybe isImport declarations + where + isImport (D.PositionedDeclaration _ _ (i@D.ImportDeclaration{})) = Just i + isImport _ = Nothing + +getImportsForFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) => + FilePath -> m [ModuleImport] +getImportsForFile fp = do + module' <- parseModuleFromFile fp + let imports = getImports module' + pure (mkModuleImport . unwrapPositionedImport <$> imports) + where mkModuleImport (D.ImportDeclaration mn importType' qualifier _) = + ModuleImport + (T.pack (N.runModuleName mn)) + importType' + (T.pack . N.runModuleName <$> qualifier) + mkModuleImport _ = error "Shouldn't have gotten anything but Imports here" + unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier b) = + D.ImportDeclaration mn (unwrapImportType importType') qualifier b + unwrapPositionedImport x = x + unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls) + unwrapImportType (D.Hiding decls) = D.Hiding (map unwrapPositionedRef decls) + unwrapImportType D.Implicit = D.Implicit + +getPositionedImports :: D.Module -> [D.Declaration] +getPositionedImports (D.Module _ _ _ declarations _) = + mapMaybe isImport declarations + where + isImport i@(D.PositionedDeclaration _ _ (D.ImportDeclaration{})) = Just i + isImport _ = Nothing + +getDeclPosition :: D.Module -> String -> Maybe SP.SourceSpan +getDeclPosition m ident = + let decls = getDeclarations m + in getFirst (foldMap (match ident) decls) + where match q (D.PositionedDeclaration ss _ decl) = First (if go q decl + then Just ss + else Nothing) + match _ _ = First Nothing + + go q (D.DataDeclaration _ name _ constructors) = + properEqual name q || any (\(x,_) -> properEqual x q) constructors + go q (D.DataBindingGroupDeclaration decls) = any (go q) decls + go q (D.TypeSynonymDeclaration name _ _) = properEqual name q + go q (D.TypeDeclaration ident' _) = identEqual ident' q + go q (D.ValueDeclaration ident' _ _ _) = identEqual ident' q + go q (D.ExternDeclaration ident' _) = identEqual ident' q + go q (D.ExternDataDeclaration name _) = properEqual name q + go q (D.TypeClassDeclaration name _ _ members) = + properEqual name q || any (go q . unwrapPositioned) members + go q (D.TypeInstanceDeclaration ident' _ _ _ _) = + identEqual ident' q + go _ _ = False + + properEqual x q = N.runProperName x == q + identEqual x q = N.runIdent x == q + +goToDefinition :: String -> FilePath -> IO (Maybe SP.SourceSpan) +goToDefinition q fp = do + m <- runExceptT (parseModuleFromFile fp) + case m of + Right module' -> return $ getDeclPosition module' q + Left _ -> return Nothing diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs new file mode 100644 index 0000000000..dc015cba71 --- /dev/null +++ b/src/Language/PureScript/Ide/State.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Language.PureScript.Ide.State where + +import Prelude () +import Prelude.Compat + +import Control.Concurrent.STM +import Control.Monad.IO.Class +import "monad-logger" Control.Monad.Logger +import Control.Monad.Reader.Class +import qualified Data.Map.Lazy as M +import Data.Maybe (catMaybes) +import Data.Monoid +import qualified Data.Text as T +import Language.PureScript.Externs +import Language.PureScript.Ide.Externs +import Language.PureScript.Ide.Reexports +import Language.PureScript.Ide.Types +import Language.PureScript.Names + +getPscIdeState :: (PscIde m, Functor m) => + m (M.Map ModuleIdent [ExternDecl]) +getPscIdeState = do + stateVar <- envStateVar <$> ask + liftIO $ pscStateModules <$> readTVarIO stateVar + +getExternFiles :: (PscIde m, Functor m) => + m (M.Map ModuleName ExternsFile) +getExternFiles = do + stateVar <- envStateVar <$> ask + liftIO (externsFiles <$> readTVarIO stateVar) + +getAllDecls :: (PscIde m, Functor m) => m [ExternDecl] +getAllDecls = concat <$> getPscIdeState + +getAllModules :: (PscIde m, Functor m) => m [Module] +getAllModules = M.toList <$> getPscIdeState + +getAllModulesWithReexports :: (PscIde m, MonadLogger m, Applicative m) => + m [Module] +getAllModulesWithReexports = do + mis <- M.keys <$> getPscIdeState + ms <- traverse getModuleWithReexports mis + pure (catMaybes ms) + +getModule :: (PscIde m, MonadLogger m, Applicative m) => + ModuleIdent -> m (Maybe Module) +getModule m = do + modules <- getPscIdeState + pure ((m,) <$> M.lookup m modules) + +getModuleWithReexports :: (PscIde m, MonadLogger m, Applicative m) => + ModuleIdent -> m (Maybe Module) +getModuleWithReexports mi = do + m <- getModule mi + modules <- getPscIdeState + pure $ resolveReexports modules <$> m + +insertModule ::(PscIde m, MonadLogger m) => + ExternsFile -> m () +insertModule externsFile = do + env <- ask + let moduleName = efModuleName externsFile + $(logDebug) $ "Inserting Module: " <> (T.pack (runModuleName moduleName)) + liftIO . atomically $ insertModule' (envStateVar env) externsFile + +insertModule' :: TVar PscIdeState -> ExternsFile -> STM () +insertModule' st ef = do + modifyTVar (st) $ \x -> + x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x) + , pscStateModules = let (mn, decls ) = convertExterns ef + in M.insert mn decls (pscStateModules x) + } diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs new file mode 100644 index 0000000000..0d8d429333 --- /dev/null +++ b/src/Language/PureScript/Ide/Types.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.PureScript.Ide.Types where + +import Prelude () +import Prelude.Compat + +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Reader.Class +import Control.Monad.Trans +import Data.Aeson +import Data.Map.Lazy as M +import Data.Maybe (maybeToList) +import Data.Text (Text (), pack, unpack) +import qualified Language.PureScript.AST.Declarations as D +import Language.PureScript.Externs +import Language.PureScript.Names +import qualified Language.PureScript.Names as N + +import Text.Parsec +import Text.Parsec.Text + +type ModuleIdent = Text +type DeclIdent = Text +type Type = Text + +data Fixity = Infix | Infixl | Infixr deriving(Show, Eq, Ord) + +data ExternDecl + = FunctionDecl { functionName :: DeclIdent + , functionType :: Type + } + | FixityDeclaration Fixity + Int + DeclIdent + | Dependency { dependencyModule :: ModuleIdent + , dependencyNames :: [Text] + , dependencyAlias :: Maybe Text + } + | ModuleDecl ModuleIdent + [DeclIdent] + | DataDecl DeclIdent + Text + | Export ModuleIdent + deriving (Show,Eq,Ord) + +instance ToJSON ExternDecl where + toJSON (FunctionDecl n t) = object ["name" .= n, "type" .= t] + toJSON (ModuleDecl n t) = object ["name" .= n, "type" .= t] + toJSON (DataDecl n t) = object ["name" .= n, "type" .= t] + toJSON (Dependency n names _) = object ["module" .= n, "names" .= names] + toJSON (FixityDeclaration f p n) = object ["name" .= n + , "fixity" .= show f + , "precedence" .= p] + toJSON (Export _) = object [] + +type Module = (ModuleIdent, [ExternDecl]) + +data Configuration = + Configuration { + confOutputPath :: FilePath + , confDebug :: Bool + } + +data PscIdeEnvironment = + PscIdeEnvironment { + envStateVar :: TVar PscIdeState + , envConfiguration :: Configuration + } + +type PscIde m = (Applicative m, MonadIO m, MonadReader PscIdeEnvironment m) + +data PscIdeState = + PscIdeState { + pscStateModules :: M.Map Text [ExternDecl] + , externsFiles :: M.Map ModuleName ExternsFile + } deriving Show + +emptyPscIdeState :: PscIdeState +emptyPscIdeState = PscIdeState M.empty M.empty + +newtype Completion = + Completion (ModuleIdent, DeclIdent, Type) + deriving (Show,Eq) + +data ModuleImport = + ModuleImport { + importModuleName :: ModuleIdent + , importType :: D.ImportDeclarationType + , importQualifier :: Maybe Text + } deriving(Show) + +instance Eq ModuleImport where + mi1 == mi2 = importModuleName mi1 == importModuleName mi2 + && importQualifier mi1 == importQualifier mi2 + +instance ToJSON ModuleImport where + toJSON (ModuleImport mn D.Implicit qualifier) = + object $ ["module" .= mn + , "importType" .= ("implicit" :: Text) + ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier) + toJSON (ModuleImport mn (D.Explicit refs) _) = + object ["module" .= mn + , "importType" .= ("explicit" :: Text) + , "identifiers" .= (identifierFromDeclarationRef <$> refs)] + toJSON (ModuleImport mn (D.Hiding refs) _) = + object ["module" .= mn + , "importType" .= ("hiding" :: Text) + , "identifiers" .= (identifierFromDeclarationRef <$> refs)] + +identifierFromDeclarationRef :: D.DeclarationRef -> String +identifierFromDeclarationRef (D.TypeRef name _) = N.runProperName name +identifierFromDeclarationRef (D.ValueRef ident) = N.runIdent ident +identifierFromDeclarationRef (D.TypeClassRef name) = N.runProperName name +identifierFromDeclarationRef _ = "" + +instance FromJSON Completion where + parseJSON (Object o) = do + m <- o .: "module" + d <- o .: "identifier" + t <- o .: "type" + return $ Completion (m, d, t) + parseJSON _ = mzero + +instance ToJSON Completion where + toJSON (Completion (m,d,t)) = + object ["module" .= m, "identifier" .= d, "type" .= t] + +data Success = + CompletionResult [Completion] + | TextResult Text + | MultilineTextResult [Text] + | PursuitResult [PursuitResponse] + | ImportList [ModuleImport] + | ModuleList [ModuleIdent] + deriving(Show, Eq) + +encodeSuccess :: (ToJSON a) => a -> Value +encodeSuccess res = + object ["resultType" .= ("success" :: Text), "result" .= res] + +instance ToJSON Success where + toJSON (CompletionResult cs) = encodeSuccess cs + toJSON (TextResult t) = encodeSuccess t + toJSON (MultilineTextResult ts) = encodeSuccess ts + toJSON (PursuitResult resp) = encodeSuccess resp + toJSON (ImportList decls) = encodeSuccess decls + toJSON (ModuleList modules) = encodeSuccess modules + +newtype PursuitQuery = PursuitQuery Text + deriving (Show, Eq) + +data PursuitSearchType = Package | Identifier + deriving (Show, Eq) + +instance FromJSON PursuitSearchType where + parseJSON (String t) = case t of + "package" -> return Package + "completion" -> return Identifier + _ -> mzero + parseJSON _ = mzero + +instance FromJSON PursuitQuery where + parseJSON o = fmap PursuitQuery (parseJSON o) + +data PursuitResponse + = ModuleResponse { moduleResponseName :: Text + , moduleResponsePackage :: Text} + | DeclarationResponse { declarationResponseType :: Text + , declarationResponseModule :: Text + , declarationResponseIdent :: Text + , declarationResponsePackage :: Text + } + deriving (Show,Eq) + +instance FromJSON PursuitResponse where + parseJSON (Object o) = do + package <- o .: "package" + info <- o .: "info" + (type' :: String) <- info .: "type" + case type' of + "module" -> do + name <- info .: "module" + return + ModuleResponse + { moduleResponseName = name + , moduleResponsePackage = package + } + "declaration" -> do + moduleName <- info .: "module" + Right (ident, declType) <- typeParse <$> o .: "text" + return + DeclarationResponse + { declarationResponseType = declType + , declarationResponseModule = moduleName + , declarationResponseIdent = ident + , declarationResponsePackage = package + } + _ -> mzero + parseJSON _ = mzero + + +typeParse :: Text -> Either Text (Text, Text) +typeParse t = case parse parseType "" t of + Right (x,y) -> Right (pack x, pack y) + Left err -> Left (pack (show err)) + where + parseType :: Parser (String, String) + parseType = do + name <- identifier + _ <- string "::" + spaces + type' <- many1 anyChar + return (unpack name, type') + +identifier :: Parser Text +identifier = do + spaces + ident <- + -- necessary for being able to parse the following ((++), concat) + between (char '(') (char ')') (many1 (noneOf ", )")) <|> + many1 (noneOf ", )") + spaces + return (pack ident) + +instance ToJSON PursuitResponse where + toJSON ModuleResponse{..} = + object ["module" .= moduleResponseName, "package" .= moduleResponsePackage] + toJSON DeclarationResponse{..} = + object + [ "module" .= declarationResponseModule + , "ident" .= declarationResponseIdent + , "type" .= declarationResponseType + , "package" .= declarationResponsePackage] diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs new file mode 100644 index 0000000000..9a6c1ff684 --- /dev/null +++ b/src/Language/PureScript/Ide/Watcher.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE RecordWildCards #-} +module Language.PureScript.Ide.Watcher where + +import Prelude () +import Prelude.Compat + +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Trans.Except +import qualified Data.Map as M +import Data.Maybe (isJust) +import Language.PureScript.Externs +import Language.PureScript.Ide.Externs +import Language.PureScript.Ide.State +import Language.PureScript.Ide.Types +import System.FilePath +import System.FSNotify + + +reloadFile :: TVar PscIdeState -> FilePath -> IO () +reloadFile stateVar fp = do + (Right ef@ExternsFile{..}) <- runExceptT $ readExternFile fp + reloaded <- atomically $ do + st <- readTVar stateVar + if isLoaded efModuleName st + then + insertModule' stateVar ef *> pure True + else + pure False + when reloaded $ putStrLn $ "Reloaded File at: " ++ fp + where + isLoaded name st = isJust (M.lookup name (externsFiles st)) + +watcher :: TVar PscIdeState -> FilePath -> IO () +watcher stateVar fp = withManager $ \mgr -> do + _ <- watchTree mgr fp + (\ev -> takeFileName (eventPath ev) == "externs.json") + (reloadFile stateVar . eventPath) + forever (threadDelay 10000) diff --git a/stack-lts-2.yaml b/stack-lts-2.yaml index ffb912457f..566ec38e0b 100644 --- a/stack-lts-2.yaml +++ b/stack-lts-2.yaml @@ -7,4 +7,5 @@ extra-deps: - boxes-0.1.4 - pattern-arrows-0.0.2 - sourcemap-0.1.6 +- fsnotify-0.2.1 resolver: lts-2.22 diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs new file mode 100644 index 0000000000..4469127d7d --- /dev/null +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.PureScript.Ide.FilterSpec where + +import Data.Text (Text) +import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Types +import Test.Hspec + +modules :: [Module] +modules = + [ + ("Module.A", [FunctionDecl "function1" ""]), + ("Module.B", [DataDecl "data1" ""]), + ("Module.C", [ModuleDecl "Module.C" []]), + ("Module.D", [Dependency "Module.C" [] Nothing, FunctionDecl "asd" ""]) + ] + +runEq :: Text -> [Module] +runEq s = runFilter (equalityFilter s) modules +runPrefix :: Text -> [Module] +runPrefix s = runFilter (prefixFilter s) modules +runModule :: [ModuleIdent] -> [Module] +runModule ms = runFilter (moduleFilter ms) modules +runDependency :: [ModuleIdent] -> [Module] +runDependency ms = runFilter (dependencyFilter ms) modules + +spec :: Spec +spec = do + describe "equality Filter" $ do + it "removes empty modules" $ + runEq "test" `shouldBe` [] + it "keeps function declarations that are equal" $ + runEq "function1" `shouldBe` [head modules] + -- TODO: It would be more sensible to match Constructors + it "keeps data declarations that are equal" $ + runEq "data1" `shouldBe` [modules !! 1] + describe "prefixFilter" $ do + it "keeps everything on empty string" $ + runPrefix "" `shouldBe` modules + it "keeps functionname prefix matches" $ + runPrefix "fun" `shouldBe` [head modules] + it "keeps data decls prefix matches" $ + runPrefix "dat" `shouldBe` [modules !! 1] + it "keeps module decl prefix matches" $ + runPrefix "Mod" `shouldBe` [modules !! 2] + describe "moduleFilter" $ do + it "removes everything on empty input" $ + runModule [] `shouldBe` [] + it "only keeps the specified modules" $ + runModule ["Module.A", "Module.C"] `shouldBe` [head modules, modules !! 2] + it "ignores modules that are not in scope" $ + runModule ["Module.A", "Module.C", "Unknown"] `shouldBe` [head modules, modules !! 2] + describe "dependencyFilter" $ do + it "removes everything on empty input" $ + runDependency [] `shouldBe` [] + it "only keeps the specified modules if they have no imports" $ + runDependency ["Module.A", "Module.B"] `shouldBe` [head modules, modules !! 1] + it "keeps the specified modules and their imports" $ + runDependency ["Module.A", "Module.D"] `shouldBe` [head modules, modules !! 2, modules !! 3] diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs new file mode 100644 index 0000000000..7e12981038 --- /dev/null +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Language.PureScript.Ide.MatcherSpec where + +import Data.Text (Text) +import Language.PureScript.Ide.Matcher +import Language.PureScript.Ide.Types +import Test.Hspec + +completions :: [Completion] +completions = [ + Completion ("", "firstResult", ""), + Completion ("", "secondResult", ""), + Completion ("", "fiult", "") + ] + +mkResult :: [Int] -> [Completion] +mkResult = map (completions !!) + +runFlex :: Text -> [Completion] +runFlex s = runMatcher (flexMatcher s) completions + +spec :: Spec +spec = do + describe "Flex Matcher" $ do + it "doesn't match on an empty string" $ + runFlex "" `shouldBe` [] + it "matches on equality" $ + runFlex "firstResult" `shouldBe` mkResult [0] + it "scores short matches higher and sorts accordingly" $ + runFlex "filt" `shouldBe` mkResult [2, 0] diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs new file mode 100644 index 0000000000..d9a98ff8a9 --- /dev/null +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.PureScript.Ide.ReexportsSpec where + +import Control.Exception (evaluate) +import Data.List (sort) +import qualified Data.Map as Map +import Language.PureScript.Ide.Reexports +import Language.PureScript.Ide.Types +import Test.Hspec + +decl1 :: ExternDecl +decl1 = FunctionDecl "filter" "asdasd" +decl2 :: ExternDecl +decl2 = DataDecl "Tree" "* -> *" +decl3 :: ExternDecl +decl3 = DataDecl "TreeAsd" "* -> *" +dep1 :: ExternDecl +dep1 = Dependency "Test.Foo" [] (Just "T") +dep2 :: ExternDecl +dep2 = Dependency "Test.Bar" [] (Just "T") + +circularModule :: Module +circularModule = ("Circular", [Export "Circular"]) + +module1 :: Module +module1 = ("Module1", [Export "Module2", Export "Module3", decl1]) + +module2 :: Module +module2 = ("Module2", [decl2]) + +module3 :: Module +module3 = ("Module3", [decl3]) + +module4 :: Module +module4 = ("Module4", [Export "T", decl1, dep1, dep2]) + +result :: Module +result = ("Module1", [decl1, decl2, Export "Module3"]) + +db :: Map.Map ModuleIdent [ExternDecl] +db = Map.fromList [module1, module2, module3] + +shouldBeEqualSorted :: Module -> Module -> Expectation +shouldBeEqualSorted (n1, d1) (n2, d2) = (n1, sort d1) `shouldBe` (n2, sort d2) + +spec :: Spec +spec = do + describe "Reexports" $ do + it "finds all reexports" $ + getReexports module1 `shouldBe` [Export "Module2", Export "Module3"] + + it "replaces a reexport with another module" $ + replaceReexport (Export "Module2") module1 module2 `shouldBeEqualSorted` result + + it "adds another module even if there is no export statement" $ + replaceReexport (Export "Module2") ("Module1", [decl1, Export "Module3"]) module2 + `shouldBeEqualSorted` result + + it "only adds a declaration once" $ + let replaced = replaceReexport (Export "Module2") module1 module2 + in replaceReexport (Export "Module2") replaced module2 `shouldBeEqualSorted` result + + it "should error when given a non-Export to replace" $ + evaluate (replaceReexport decl1 module1 module2) + `shouldThrow` errorCall "Should only get Exports here." + it "replaces all Exports with their corresponding declarations" $ + replaceReexports module1 db `shouldBe` ("Module1", [decl1, decl2, decl3]) + + it "does not list itself as a reexport" $ + getReexports circularModule `shouldBe` [] + + it "does not include circular references when replacing reexports" $ + replaceReexports circularModule (uncurry Map.singleton circularModule ) + `shouldBe` ("Circular", []) + + it "replaces exported aliases with imported module" $ + getReexports module4 `shouldBe` [Export "Test.Foo", Export "Test.Bar"] diff --git a/tests/Language/PureScript/IdeSpec.hs b/tests/Language/PureScript/IdeSpec.hs new file mode 100644 index 0000000000..5f89e82e07 --- /dev/null +++ b/tests/Language/PureScript/IdeSpec.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +module Language.PureScript.IdeSpec where + +import Control.Concurrent.STM +import Control.Monad.Reader +import Data.List +import qualified Data.Map as Map +import Language.PureScript.Ide +import Language.PureScript.Ide.Types +import Test.Hspec + +testState :: PscIdeState +testState = PscIdeState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])]) (Map.empty) + +defaultConfig :: Configuration +defaultConfig = + Configuration + { + confOutputPath = "output/" + , confDebug = False + } + +spec :: SpecWith () +spec = do + describe "list" $ do + describe "loadedModules" $ do + it "returns an empty list when no modules are loaded" $ do + st <- newTVarIO emptyPscIdeState + result <- runReaderT printModules (PscIdeEnvironment st defaultConfig) + result `shouldBe` ModuleList [] + it "returns the list of loaded modules" $ do + st <- newTVarIO testState + ModuleList result <- runReaderT printModules (PscIdeEnvironment st defaultConfig) + sort result `shouldBe` sort ["Data.Array", "Control.Monad.Eff"] diff --git a/tests/Main.hs b/tests/Main.hs index ac267d97ff..152cd44e56 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -25,6 +25,7 @@ import qualified TestCompiler import qualified TestPscPublish import qualified TestDocs import qualified TestPsci +import qualified TestPscIde main :: IO () main = do @@ -36,6 +37,8 @@ main = do TestPscPublish.main heading "psci test suite" TestPsci.main + heading "psc-ide test suite" + TestPscIde.main where heading msg = do diff --git a/tests/PscIdeSpec.hs b/tests/PscIdeSpec.hs new file mode 100644 index 0000000000..1dbe9bb47a --- /dev/null +++ b/tests/PscIdeSpec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=PscIdeSpec #-} diff --git a/tests/TestPscIde.hs b/tests/TestPscIde.hs new file mode 100644 index 0000000000..1a6e0722f5 --- /dev/null +++ b/tests/TestPscIde.hs @@ -0,0 +1,7 @@ +module TestPscIde where + +import qualified PscIdeSpec +import Test.Hspec + +main :: IO () +main = hspec PscIdeSpec.spec From e7b1265fb457c80142df48bb1779fe4682c21a3d Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 24 Feb 2016 22:33:18 +0100 Subject: [PATCH 0294/1580] remove lts-2 build from travis --- .travis.yml | 3 --- 1 file changed, 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index ef17b76983..23cc898d34 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,9 +6,6 @@ matrix: compiler: ": #GHC 7.8.4 - tests" # ^ HACK before https://github.com/travis-ci/travis-ci/issues/4393 is resolved addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.8.4 CABALVER=1.22 STACKAGE=lts-2.22 - compiler: ": #GHC 7.8.4 - lts-2.22-1" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - env: GHCVER=7.6.3 CABALVER=1.22 compiler: ": #GHC 7.6.3" addons: {apt: {packages: [cabal-install-1.22,ghc-7.6.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} From b4c68f24e812926307be3d9620302f5be9004073 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 25 Feb 2016 10:10:21 +0200 Subject: [PATCH 0295/1580] Update travis 2016-02-25 Also `stack.yaml`s --- .travis.yml | 13 ++++++++----- stack-lts-2.yaml | 6 ++++-- stack-lts-3.yaml | 4 ++-- stack-lts-5.yaml | 5 +++++ stack-nightly.yaml | 5 ++--- stack.yaml | 2 +- 6 files changed, 22 insertions(+), 13 deletions(-) create mode 100644 stack-lts-5.yaml diff --git a/.travis.yml b/.travis.yml index 23cc898d34..54e217de66 100644 --- a/.travis.yml +++ b/.travis.yml @@ -12,12 +12,15 @@ matrix: - env: GHCVER=7.10.1 CABALVER=1.22 DEPLOY=yes compiler: ": #GHC 7.10.1" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.10.2 CABALVER=1.22 STACKAGE=lts=3.6 RUNSDISTTESTS=YES - compiler: ": #GHC 7.10.2 lts-3.6" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.10.2 CABALVER=1.22 STACKAGE=nightly-2015-09-29 - compiler: ": #GHC 7.10.2 nightly-2015-09-29" + - env: GHCVER=7.10.2 CABALVER=1.22 STACKAGE=lts-3.22 RUNSDISTTESTS=YES + compiler: ": #GHC 7.10.2 lts-3.22" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} + - env: GHCVER=7.10.3 CABALVER=1.22 STACKAGE=lts-5.4 RUNSDISTTESTS=YES + compiler: ": #GHC 7.10.3 lts-5.4" + addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} + - env: GHCVER=7.10.3 CABALVER=1.22 STACKAGE=nightly-2016-02-25 + compiler: ": #GHC 7.10.3 nightly-2016-02-25" + addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - env: GHCVER=7.10.3 CABALVER=1.22 compiler: ": #GHC 7.10.3" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} diff --git a/stack-lts-2.yaml b/stack-lts-2.yaml index 566ec38e0b..49a6a68088 100644 --- a/stack-lts-2.yaml +++ b/stack-lts-2.yaml @@ -1,4 +1,4 @@ -flags: {} +resolver: lts-2.22 packages: - '.' extra-deps: @@ -8,4 +8,6 @@ extra-deps: - pattern-arrows-0.0.2 - sourcemap-0.1.6 - fsnotify-0.2.1 -resolver: lts-2.22 +- hfsevents-0.1.6 +- pipes-http-1.0.2 +flags: {} diff --git a/stack-lts-3.yaml b/stack-lts-3.yaml index 9e16515ed3..69f14a9168 100644 --- a/stack-lts-3.yaml +++ b/stack-lts-3.yaml @@ -1,6 +1,6 @@ -flags: {} +resolver: lts-3.22 packages: - '.' extra-deps: - sourcemap-0.1.6 -resolver: lts-3.6 +flags: {} diff --git a/stack-lts-5.yaml b/stack-lts-5.yaml new file mode 100644 index 0000000000..34bfedcd16 --- /dev/null +++ b/stack-lts-5.yaml @@ -0,0 +1,5 @@ +resolver: lts-5.4 +packages: +- '.' +extra-deps: [] +flags: {} diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 3801289517..2a5da385e4 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -1,6 +1,5 @@ flags: {} packages: - '.' -extra-deps: -- sourcemap-0.1.6 -resolver: nightly-2015-09-29 +extra-deps: [] +resolver: nightly-2016-02-25 diff --git a/stack.yaml b/stack.yaml index 671f47345e..0db6065aea 120000 --- a/stack.yaml +++ b/stack.yaml @@ -1 +1 @@ -stack-lts-3.yaml \ No newline at end of file +stack-lts-5.yaml \ No newline at end of file From d167155cbedb8580ae379b13c0aceda061e1b404 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Thu, 25 Feb 2016 22:40:30 +0000 Subject: [PATCH 0296/1580] Fix source map path with default output dir --- src/Language/PureScript/Make.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index af45b358d8..c1d327c34b 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -57,7 +57,7 @@ import SourceMap import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) -import System.FilePath ((), takeDirectory, makeRelative, splitPath) +import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise) import System.IO.Error (tryIOError) import System.IO.UTF8 (readUTF8File, writeUTF8File) @@ -351,7 +351,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do - let pathToDir = iterate (".." ) ".." !! length (splitPath outputDir) + let pathToDir = iterate (".." ) ".." !! length (splitPath $ normalise outputDir) sourceFile = case mappings of ((SMap file _ _):_) -> Just $ pathToDir makeRelative dir file _ -> Nothing From 6caa04886f015e483608feeed2d2fdc16f001427 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 27 Feb 2016 12:33:03 -0800 Subject: [PATCH 0297/1580] Update CONTRIBUTORS.md --- CONTRIBUTORS.md | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 7c844185fd..46867ac9d1 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -13,7 +13,10 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@bergmark](https://github.com/bergmark) (Adam Bergmark) - My existing contributions and all future contributions until further notice are Copyright Adam Bergmark, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@Bogdanp](https://github.com/Bogdanp) (Bogdan Paul Popa) My existing contributions and all future contributions until further notice are Copyright Bogdan Paul Popa, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@cdepillabout](https://github.com/cdepillabout) (Dennis Gosnell) My existing contributions and all future contributions until further notice are Copyright Dennis Gosnell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@chrissmoak](https://github.com/chrissmoak) (Chris Smoak) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@davidchambers](https://github.com/davidchambers) (David Chambers) My existing contributions and all future contributions until further notice are Copyright David Chambers, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@DavidLindbom](https://github.com/DavidLindbom) (David Lindbom) My existing contributions and all future contributions until further notice are Copyright David Lindbom, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@dckc](https://github.com/dckc) (Dan Connolly) My existing contributions and all future contributions until further notice are Copyright Dan Connolly, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@dylex](https://github.com/dylex) (Dylan Simon) My existing and all future contributions to the PureScript compiler until further notice are Copyright Dylan Simon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@eamelink](https://github.com/eamelink) (Erik Bakker) - My existing contributions and all future contributions until further notice are Copyright Erik Bakker, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. @@ -22,6 +25,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@etrepum](https://github.com/etrepum) (Bob Ippolito) My existing contributions and all future contributions until further notice are Copyright Bob Ippolito, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@joneshf](https://github.com/joneshf) (Hardy Jones) - My existing contributions and all future contributions until further notice are Copyright Hardy Jones, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. @@ -42,6 +46,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@nwolverson](https://github.com/nwolverson) (Nicholas Wolverson) My existing contributions and all future contributions until further notice are Copyright Nicholas Wolverson, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@osa1](https://github.com/osa1) (Ömer Sinan Ağacan) - My existing contributions and all future contributions until further notice are Copyright Ömer Sinan Ağacan, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@paf31](https://github.com/paf31) (Phil Freeman) My existing contributions and all future contributions until further notice are Copyright Phil Freeman, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@paulyoung](https://github.com/paulyoung) (Paul Young) My existing contributions and all future contributions until further notice are Copyright Paul Young, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@pelotom](https://github.com/pelotom) (Thomas Crockett) My existing contributions and all future contributions until further notice are Copyright Thomas Crockett, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@phadej](https://github.com/phadej) (Oleg Grenrus) My existing contributions and all future contributions until further notice are Copyright Oleg Grenrus, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). @@ -51,21 +56,16 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@robdaemon](https://github.com/robdaemon) (Robert Roland) My existing contributions and all future contributions until further notice are Copyright Robert Roland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@RossMeikleham](https://github.com/RossMeikleham) (Ross Meikleham) My existing contributions and all future contributions until further notice are Copyright Ross Meikleham, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@sebastiaanvisser](https://github.com/sebastiaanvisser) (Sebastiaan Visser) - My existing contributions and all future contributions until further notice are Copyright Sebastiaan Visser, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. +- [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@sharkdp](https://github.com/sharkdp) (David Peter) My existing contributions and all future contributions until further notice are Copyright David Peter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@sztupi](https://github.com/sztupi) (Attila Sztupak) My existing contributions and all future contributions until further notice are Copyright Attila Sztupak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@taku0](https://github.com/taku0) - My existing contributions and all future contributions until further notice are Copyright taku0, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@trofi](https://github.com/trofi) (Sergei Trofimovich) My existing contributions and all future contributions until further notice are Copyright Sergei Trofimovich, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -. -- [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@DavidLindbom](https://github.com/DavidLindbom) (David Lindbom) My existing contributions and all future contributions until further notice are Copyright David Lindbom, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies From 57a3833a0048a9b0b1962c2ddd9635fd4a2d438d Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 28 Feb 2016 20:32:01 +0000 Subject: [PATCH 0298/1580] Allow one open import without warning --- examples/failing/ConflictingExports2.purs | 13 ---- examples/failing/ConflictingImports2.purs | 12 ++-- examples/passing/ResolvableScopeConflict.purs | 25 +++++++ .../passing/ResolvableScopeConflict2.purs | 22 ++++++ .../passing/ResolvableScopeConflict3.purs | 15 ++++ .../PureScript/Docs/Convert/ReExports.hs | 6 +- src/Language/PureScript/Errors.hs | 9 +++ src/Language/PureScript/Linter/Imports.hs | 19 +++-- src/Language/PureScript/Sugar/Names.hs | 9 +-- src/Language/PureScript/Sugar/Names/Env.hs | 70 +++++++++++++++---- .../PureScript/Sugar/Names/Exports.hs | 10 +-- .../PureScript/Sugar/Names/Imports.hs | 63 ++++++++++------- 12 files changed, 197 insertions(+), 76 deletions(-) delete mode 100644 examples/failing/ConflictingExports2.purs create mode 100644 examples/passing/ResolvableScopeConflict.purs create mode 100644 examples/passing/ResolvableScopeConflict2.purs create mode 100644 examples/passing/ResolvableScopeConflict3.purs diff --git a/examples/failing/ConflictingExports2.purs b/examples/failing/ConflictingExports2.purs deleted file mode 100644 index 352548c2a9..0000000000 --- a/examples/failing/ConflictingExports2.purs +++ /dev/null @@ -1,13 +0,0 @@ --- @shouldFailWith ScopeConflict -module A where - - thing :: Int - thing = 1 - --- Fails here because re-exporting forces any scope conflicts to be resolved -module Main (thing, module A) where - - import A - - thing :: Int - thing = 2 diff --git a/examples/failing/ConflictingImports2.purs b/examples/failing/ConflictingImports2.purs index ef56fdd1a5..02a21b69de 100644 --- a/examples/failing/ConflictingImports2.purs +++ b/examples/failing/ConflictingImports2.purs @@ -4,13 +4,17 @@ module A where thing :: Int thing = 1 -module Main where - - import A +module B where thing :: Int thing = 2 - -- Error due to referencing `thing` which is in scope as A.thing and Main.thing +module Main where + + import A (thing) + import B (thing) + + -- Error due to referencing `thing` which is explicitly in scope as A.thing + -- and B.thing what :: Int what = thing diff --git a/examples/passing/ResolvableScopeConflict.purs b/examples/passing/ResolvableScopeConflict.purs new file mode 100644 index 0000000000..c187806772 --- /dev/null +++ b/examples/passing/ResolvableScopeConflict.purs @@ -0,0 +1,25 @@ +module A where + + thing :: Int + thing = 1 + +module B where + + thing :: Int + thing = 2 + + zing :: Int + zing = 3 + +module Main where + + import A (thing) + import B + + -- Not an error as although we have `thing` in scope from both A and B, it is + -- imported explicitly from A, giving it a resolvable solution. + what :: Boolean -> Int + what true = thing + what false = zing + + main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ResolvableScopeConflict2.purs b/examples/passing/ResolvableScopeConflict2.purs new file mode 100644 index 0000000000..971e51b045 --- /dev/null +++ b/examples/passing/ResolvableScopeConflict2.purs @@ -0,0 +1,22 @@ +module A where + + thing :: Int + thing = 2 + + zing :: Int + zing = 3 + +module Main where + + import A + + thing :: Int + thing = 1 + + -- Not an error as although we have `thing` in scope from both Main and A, + -- as the local declaration takes precedence over the implicit import + what :: Boolean -> Int + what true = thing + what false = zing + + main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ResolvableScopeConflict3.purs b/examples/passing/ResolvableScopeConflict3.purs new file mode 100644 index 0000000000..86a996b829 --- /dev/null +++ b/examples/passing/ResolvableScopeConflict3.purs @@ -0,0 +1,15 @@ +module A where + + thing :: Int + thing = 1 + +module Main (thing, main, module A) where + + import A + + thing :: Int + thing = 2 + + main = Control.Monad.Eff.Console.log "Done" + + diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index a42d0e68af..a9330f95d6 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -155,16 +155,16 @@ collectDeclarations imports exports = do -- findImport :: (Show name, Eq name, Applicative m, MonadReader P.ModuleName m) => - [(P.Qualified name, P.ModuleName)] -> + [P.ImportRecord name] -> (name, P.ModuleName) -> m (P.ModuleName, name) findImport imps (name, orig) = let - matches (qual, mn) = P.disqualify qual == name && mn == orig + matches (P.ImportRecord qual mn _) = P.disqualify qual == name && mn == orig matching = filter matches imps getQualified (P.Qualified mname _) = mname in - case mapMaybe (getQualified . fst) matching of + case mapMaybe (getQualified . P.importName) matching of -- A value can occur more than once if it is imported twice (eg, if it is -- exported by A, re-exported from A by B, and C imports it from both A -- and B). In this case, we just take its first appearance. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index f220306097..9c5d2d69c8 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -69,6 +69,7 @@ data SimpleErrorMessage | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName) | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName) | ScopeConflict String [ModuleName] + | ScopeShadowing String (Maybe ModuleName) [ModuleName] | ConflictingTypeDecls (ProperName 'TypeName) | ConflictingCtorDecls (ProperName 'ConstructorName) | TypeConflictsWithClass (ProperName 'TypeName) @@ -248,6 +249,7 @@ errorCode em = case unwrapErrorMessage em of UnknownImportDataConstructor{} -> "UnknownImportDataConstructor" UnknownExportDataConstructor{} -> "UnknownExportDataConstructor" ScopeConflict{} -> "ScopeConflict" + ScopeShadowing{} -> "ScopeShadowing" ConflictingTypeDecls{} -> "ConflictingTypeDecls" ConflictingCtorDecls{} -> "ConflictingCtorDecls" TypeConflictsWithClass{} -> "TypeConflictsWithClass" @@ -604,6 +606,13 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:" , indent $ paras $ map (line . runModuleName) ms ] + renderSimpleErrorMessage (ScopeShadowing nm exmn ms) = + paras [ line $ "Shadowed definitions are in scope for " ++ nm ++ " from the following open imports:" + , indent $ paras $ map (line . ("import " ++) . runModuleName) ms + , line $ "These will be ignored and the " ++ case exmn of + Just exmn' -> "declaration from " ++ runModuleName exmn' ++ " will be used." + Nothing -> "local declaration will be used." + ] renderSimpleErrorMessage (ConflictingTypeDecls nm) = line $ "Conflicting type declarations for " ++ runProperName nm renderSimpleErrorMessage (ConflictingCtorDecls nm) = diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 6ac06e919d..68753b213d 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -17,6 +17,7 @@ import Control.Monad.Writer.Class import Data.Foldable (forM_) import Data.List ((\\), find, intersect, nub) import Data.Maybe (mapMaybe) +import Data.Monoid (Sum(..)) import qualified Data.Map as M import Language.PureScript.AST.Declarations @@ -78,6 +79,8 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env) usedImps' = foldr (elaborateUsed scope) usedImps exportedModules + numImplicitImports = getSum $ foldMap (Sum . countImplicitImports) mdecls + allowImplicit = numImplicitImports == 1 imps <- M.toAscList <$> findImports mdecls @@ -86,7 +89,7 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do forM_ decls $ \(ss, declType, qualifierName) -> censor (onErrorMessages $ addModuleLocError ss) $ do let names = nub $ M.findWithDefault [] mni usedImps' - lintImportDecl env mni qualifierName names declType + lintImportDecl env mni qualifierName names declType allowImplicit forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do let mnis = nub $ map (\(_, _, mni) -> mni) entries @@ -103,6 +106,11 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do where + countImplicitImports :: Declaration -> Int + countImplicitImports (ImportDeclaration mn' Implicit _ _) | not (isPrim mn') = 1 + countImplicitImports (PositionedDeclaration _ _ d) = countImplicitImports d + countImplicitImports _ = 0 + -- Checks whether a module is the Prim module - used to suppress any checks -- made, as Prim is always implicitly imported. isPrim :: ModuleName -> Bool @@ -148,13 +156,13 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do extractByQual :: (Eq a) => ModuleName - -> M.Map (Qualified a) [(Qualified a, ModuleName)] + -> M.Map (Qualified a) [ImportRecord a] -> (Qualified a -> Name) -> [(ModuleName, Name)] extractByQual k m toName = mapMaybe go (M.toList m) where go (q@(Qualified mnq _), is) | isUnqualified q || isQualifiedWith k q = - case fst (head is) of + case importName (head is) of Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name) _ -> internalError "unqualified name in extractByQual" go _ = Nothing @@ -167,11 +175,12 @@ lintImportDecl -> Maybe ModuleName -> [Name] -> ImportDeclarationType + -> Bool -> m () -lintImportDecl env mni qualifierName names declType = +lintImportDecl env mni qualifierName names declType allowImplicit = case declType of Implicit -> case qualifierName of - Nothing -> checkImplicit ImplicitImport + Nothing -> unless allowImplicit (checkImplicit ImplicitImport) Just q -> let usedModuleNames = mapMaybe extractQualName names in unless (q `elem` usedModuleNames) unused diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 0df1869dcf..8fd50da1a7 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -7,6 +7,8 @@ module Language.PureScript.Sugar.Names ( desugarImports , desugarImportsWithEnv , Env + , ImportRecord(..) + , ImportProvenance(..) , Imports(..) , Exports(..) ) where @@ -67,7 +69,7 @@ desugarImportsWithEnv externs modules = do let members = Exports{..} ss = internalModuleSourceSpan "" env' = M.insert efModuleName (ss, nullImports, members) env - fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, mt, qmn)]) + fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)]) imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports) exps <- resolveExports env' efModuleName imps members efExports return $ M.insert efModuleName (ss, imps, exps) env @@ -284,7 +286,7 @@ renameInModule env imports (Module ss coms mn decls exps) = update :: (Ord a, Show a) => (Qualified a -> SimpleErrorMessage) - -> M.Map (Qualified a) [(Qualified a, ModuleName)] + -> M.Map (Qualified a) [ImportRecord a] -> (Exports -> a -> Maybe (Qualified a)) -> (Qualified a -> Name) -> (a -> String) @@ -300,8 +302,7 @@ renameInModule env imports (Module ss coms mn decls exps) = -- re-exports. If there are multiple options for the name to resolve to -- in scope, we throw an error. (Just options, _) -> do - checkImportConflicts render options - let (Qualified (Just mnNew) _, mnOrig) = head options + (mnNew, mnOrig) <- checkImportConflicts mn render options modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result return $ Qualified (Just mnOrig) name diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 6820ac5a92..5af2c7612d 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -2,7 +2,9 @@ {-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Sugar.Names.Env - ( Imports(..) + ( ImportRecord(..) + , ImportProvenance(..) + , Imports(..) , nullImports , Exports(..) , nullExports @@ -19,13 +21,14 @@ module Language.PureScript.Sugar.Names.Env ) where import Data.Function (on) -import Data.List (groupBy, sortBy, nub) +import Data.List (groupBy, sortBy, nub, delete) import Data.Maybe (fromJust) import qualified Data.Map as M import qualified Data.Set as S import Control.Monad import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) import Language.PureScript.AST import Language.PureScript.Crash @@ -33,6 +36,30 @@ import Language.PureScript.Names import Language.PureScript.Environment import Language.PureScript.Errors +-- | +-- The details for an import: the name of the thing that is being imported +-- (`A.x` if importing from `A`), the module that the thing was originally +-- defined in (for re-export resolution), and the import provenance (see below). +-- +data ImportRecord a = + ImportRecord + { importName :: Qualified a + , importSourceModule :: ModuleName + , importProvenance :: ImportProvenance + } + deriving (Eq, Ord, Show, Read) + +-- | +-- Used to track how an import was introduced into scope. This allows us to +-- handle the one-open-import special case that allows a name conflict to become +-- a warning rather than being an unresolvable situation. +-- +data ImportProvenance + = FromImplicit + | FromExplicit + | Local + deriving (Eq, Ord, Show, Read) + -- | -- The imported declarations for a module, including the module's own members. -- @@ -41,19 +68,19 @@ data Imports = Imports -- | -- Local names for types within a module mapped to to their qualified names -- - importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [(Qualified (ProperName 'TypeName), ModuleName)] + importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [ImportRecord (ProperName 'TypeName)] -- | -- Local names for data constructors within a module mapped to to their qualified names -- - , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [(Qualified (ProperName 'ConstructorName), ModuleName)] + , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [ImportRecord (ProperName 'ConstructorName)] -- | -- Local names for classes within a module mapped to to their qualified names -- - , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [(Qualified (ProperName 'ClassName), ModuleName)] + , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [ImportRecord (ProperName 'ClassName)] -- | -- Local names for values within a module mapped to to their qualified names -- - , importedValues :: M.Map (Qualified Ident) [(Qualified Ident, ModuleName)] + , importedValues :: M.Map (Qualified Ident) [ImportRecord Ident] -- | -- The modules that have been imported into the current scope. -- @@ -202,16 +229,29 @@ getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return -- checkImportConflicts :: forall m a - . (MonadError MultipleErrors m, Ord a) - => (a -> String) - -> [(Qualified a, ModuleName)] - -> m () -checkImportConflicts render xs = - let byOrig = groupBy ((==) `on` snd) . sortBy (compare `on` snd) $ xs + . (Show a, MonadError MultipleErrors m, MonadWriter MultipleErrors m, Ord a) + => ModuleName + -> (a -> String) + -> [ImportRecord a] + -> m (ModuleName, ModuleName) +checkImportConflicts currentModule render xs = + let + byOrig = sortBy (compare `on` importSourceModule) xs + groups = groupBy ((==) `on` importSourceModule) byOrig + nonImplicit = filter ((/= FromImplicit) . importProvenance) xs + name = render' (importName . head $ xs) + conflictModules = map (getQual . importName . head) groups in - if length byOrig > 1 - then throwError . errorMessage $ ScopeConflict (render' (fst . head $ xs)) (map (getQual . fst . head) byOrig) - else return () + if length groups > 1 + then case nonImplicit of + [ImportRecord (Qualified (Just mnNew) _) mnOrig _] -> do + let warningModule = if mnNew == currentModule then Nothing else Just mnNew + tell . errorMessage $ ScopeShadowing name warningModule $ delete mnNew conflictModules + return (mnNew, mnOrig) + _ -> throwError . errorMessage $ ScopeConflict name conflictModules + else + let ImportRecord (Qualified (Just mnNew) _) mnOrig _ = head byOrig + in return (mnNew, mnOrig) where getQual :: Qualified a -> ModuleName getQual (Qualified (Just mn) _) = mn diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 6b1e68ee33..84776cd879 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -110,17 +110,17 @@ resolveExports env mn imps exps refs = -- Extracts a list of values for a module based on a lookup table. If the -- boolean is true the values are filtered by the qualification extract - :: (Ord a) + :: (Show a, Ord a) => Bool -> ModuleName -> (a -> String) - -> M.Map (Qualified a) [(Qualified a, ModuleName)] + -> M.Map (Qualified a) [ImportRecord a] -> m [Qualified a] - extract useQual name render = fmap (map (fst . head . snd)) . go . M.toList + extract useQual name render = fmap (map (importName . head . snd)) . go . M.toList where go = filterM $ \(name', options) -> do - let isMatch = if useQual then eqQual name name' else any (eqQual name . fst) options - when (isMatch && length options > 1) $ checkImportConflicts render options + let isMatch = if useQual then eqQual name name' else any (eqQual name . importName) options + when (isMatch && length options > 1) $ void $ checkImportConflicts mn render options return isMatch -- Check whether a module name refers to a "pseudo module" that came into diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 886c8fc3b6..c0e3276b7a 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -99,7 +99,8 @@ resolveImports env (Module ss coms currentModule decls exps) = return () - let scope = M.insert currentModule [(Nothing, Implicit, Nothing)] imports + let imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports + scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports' resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope) return (Module ss coms currentModule decls' exps, resolved) @@ -162,11 +163,13 @@ resolveModuleImport . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Imports - -> (ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) + -> (ModuleName, [(Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)]) -> m Imports resolveModuleImport env ie (mn, imps) = foldM go ie imps where - go :: Imports -> (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -> m Imports + go :: Imports + -> (Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName) + -> m Imports go ie' (pos, typ, impQual) = do modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env let virtualModules = importedVirtualModules ie' @@ -189,15 +192,16 @@ resolveImport -> Exports -> Imports -> Maybe ModuleName - -> ImportDeclarationType + -> Maybe ImportDeclarationType -> m Imports resolveImport importModule exps imps impQual = resolveByType where - resolveByType :: ImportDeclarationType -> m Imports - resolveByType Implicit = importAll importExplicit - resolveByType (Explicit refs) = checkRefs False refs >> foldM importExplicit imps refs - resolveByType (Hiding refs) = do + resolveByType :: Maybe ImportDeclarationType -> m Imports + resolveByType Nothing = importAll (importRef Local) + resolveByType (Just Implicit) = importAll (importRef FromImplicit) + resolveByType (Just (Explicit refs)) = checkRefs False refs >> foldM (importRef FromExplicit) imps refs + resolveByType (Just (Hiding refs)) = do imps' <- checkRefs True refs >> importAll (importNonHidden refs) let isEmptyImport = M.null (importedTypes imps') @@ -246,7 +250,7 @@ resolveImport importModule exps imps impQual = resolveByType importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports importNonHidden hidden m ref | isHidden ref = return m - | otherwise = importExplicit m ref + | otherwise = importRef FromImplicit m ref where -- TODO: rework this to be not confusing isHidden :: DeclarationRef -> Bool @@ -268,27 +272,26 @@ resolveImport importModule exps imps impQual = resolveByType imp'' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp' (exportedValues exps) foldM (\m (name, _) -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps) - -- Import something explicitly - importExplicit :: Imports -> DeclarationRef -> m Imports - importExplicit imp (PositionedDeclarationRef pos _ r) = - warnAndRethrowWithPosition pos $ importExplicit imp r - importExplicit imp (ValueRef name) = do - let values' = updateImports (importedValues imp) (exportedValues exps) name + importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports + importRef prov imp (PositionedDeclarationRef pos _ r) = + warnAndRethrowWithPosition pos $ importRef prov imp r + importRef prov imp (ValueRef name) = do + let values' = updateImports (importedValues imp) (exportedValues exps) name prov return $ imp { importedValues = values' } - importExplicit imp (TypeRef name dctors) = do - let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name + importRef prov imp (TypeRef name dctors) = do + let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name prov let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)] exportedDctors = allExportedDataConstructors name dctorNames :: [ProperName 'ConstructorName] dctorNames = fst `map` exportedDctors maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name - let dctors' = foldl (\m -> updateImports m exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors) + let dctors' = foldl (\m d -> updateImports m exportedDctors d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors) return $ imp { importedTypes = types', importedDataConstructors = dctors' } - importExplicit imp (TypeClassRef name) = do - let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name + importRef prov imp (TypeClassRef name) = do + let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov return $ imp { importedTypeClasses = typeClasses' } - importExplicit _ _ = internalError "Invalid argument to importExplicit" + importRef _ _ _ = internalError "Invalid argument to importRef" -- Find all exported data constructors for a given type allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)] @@ -300,11 +303,17 @@ resolveImport importModule exps imps impQual = resolveByType -- Add something to an import resolution list updateImports :: (Ord a) - => M.Map (Qualified a) [(Qualified a, ModuleName)] + => M.Map (Qualified a) [ImportRecord a] -> [(a, ModuleName)] -> a - -> M.Map (Qualified a) [(Qualified a, ModuleName)] - updateImports imps' exps' name = - let mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') - currNames = fromMaybe [] (M.lookup (Qualified impQual name) imps') - in M.insert (Qualified impQual name) ((Qualified (Just importModule) name, mnOrig) : currNames) imps' + -> ImportProvenance + -> M.Map (Qualified a) [ImportRecord a] + updateImports imps' exps' name prov = + let + mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') + rec = ImportRecord (Qualified (Just importModule) name) mnOrig prov + in + M.alter + (\currNames -> Just $ rec : fromMaybe [] currNames) + (Qualified impQual name) + imps' From f77c176700e5cdcd19cdbefedf0192d3e2471281 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 28 Feb 2016 17:31:06 -0800 Subject: [PATCH 0299/1580] v0.8.1.0 --- purescript.cabal | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 55bb81f481..dbfd46f1d1 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.8.0.0 +version: 0.8.1.0 cabal-version: >=1.8 build-type: Simple license: MIT @@ -31,10 +31,6 @@ extra-source-files: examples/passing/*.purs , tests/support/flattened/*.purs , tests/support/flattened/*.js , tests/support/psci/*.purs - , tests/support/prelude/bower.json - , tests/support/prelude/src/*.purs - , tests/support/prelude/src/*.js - , tests/support/prelude/LICENSE , stack.yaml , stack-lts-2.yaml , stack-lts-3.yaml From bdb4987f5d61c6615e846cb8f8d7d44af173496c Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 28 Feb 2016 20:33:02 -0800 Subject: [PATCH 0300/1580] Add back Prelude to cabal file --- purescript.cabal | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/purescript.cabal b/purescript.cabal index dbfd46f1d1..dd4cf029bf 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -26,6 +26,10 @@ extra-source-files: examples/passing/*.purs , examples/docs/src/*.purs , tests/support/setup.js , tests/support/package.json + , tests/support/prelude/bower.json + , tests/support/prelude/src/*.purs + , tests/support/prelude/src/*.js + , tests/support/prelude/LICENSE , tests/support/bower.json , tests/support/setup-win.cmd , tests/support/flattened/*.purs From af90fd52f93b5c47888178e71cd8152a9f484d37 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 28 Feb 2016 21:23:53 -0800 Subject: [PATCH 0301/1580] Fix bundler to use stack --- bundle/build.sh | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/bundle/build.sh b/bundle/build.sh index 33ef75cac0..b6433ef4aa 100755 --- a/bundle/build.sh +++ b/bundle/build.sh @@ -16,25 +16,25 @@ pushd ${SCRIPTPATH} > /dev/null mkdir -p build/purescript/ # Strip the binaries -strip ../dist/build/psc/psc -strip ../dist/build/psci/psci -strip ../dist/build/psc-docs/psc-docs -strip ../dist/build/psc-publish/psc-publish -strip ../dist/build/psc-bundle/psc-bundle -strip ../dist/build/psc-ide-server/psc-ide-server -strip ../dist/build/psc-ide-client/psc-ide-client +strip ~/.local/bin/psc +strip ~/.local/bin/psci +strip ~/.local/bin/psc-docs +strip ~/.local/bin/psc-publish +strip ~/.local/bin/psc-bundle +strip ~/.local/bin/psc-ide-server +strip ~/.local/bin/psc-ide-client # Copy files to staging directory -cp ../dist/build/psc/psc build/purescript/ -cp ../dist/build/psci/psci build/purescript/ -cp ../dist/build/psc-docs/psc-docs build/purescript/ -cp ../dist/build/psc-publish/psc-publish build/purescript/ -cp ../dist/build/psc-bundle/psc-bundle build/purescript/ -cp ../dist/build/psc-ide-server/psc-ide-server build/purescript/ -cp ../dist/build/psc-ide-client/psc-ide-client build/purescript/ -cp README build/purescript/ -cp ../LICENSE build/purescript/ -cp ../INSTALL.md build/purescript/ +cp ~/.local/bin/psc build/purescript/ +cp ~/.local/bin/psci build/purescript/ +cp ~/.local/bin/psc-docs build/purescript/ +cp ~/.local/bin/psc-publish build/purescript/ +cp ~/.local/bin/psc-bundle build/purescript/ +cp ~/.local/bin/psc-ide-server build/purescript/ +cp ~/.local/bin/psc-ide-client build/purescript/ +cp README build/purescript/ +cp ../LICENSE build/purescript/ +cp ../INSTALL.md build/purescript/ # Make the binary bundle pushd build > /dev/null From 37323734bd07faadd54e70030a63186c24756873 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 28 Feb 2016 22:14:56 -0800 Subject: [PATCH 0302/1580] Add stack bundler script --- bundle/build-stack.sh | 50 +++++++++++++++++++++++++++++++++++++++++++ bundle/build.sh | 34 ++++++++++++++--------------- 2 files changed, 67 insertions(+), 17 deletions(-) create mode 100755 bundle/build-stack.sh diff --git a/bundle/build-stack.sh b/bundle/build-stack.sh new file mode 100755 index 0000000000..b6433ef4aa --- /dev/null +++ b/bundle/build-stack.sh @@ -0,0 +1,50 @@ +set -e + +SCRIPTPATH=$( cd "$(dirname "$0")" ; pwd -P ) + +OS=$1 + +if [ -z $OS ] +then + echo "Usage: build.sh osname" + exit 1 +fi + +pushd ${SCRIPTPATH} > /dev/null + +# Make the staging directory +mkdir -p build/purescript/ + +# Strip the binaries +strip ~/.local/bin/psc +strip ~/.local/bin/psci +strip ~/.local/bin/psc-docs +strip ~/.local/bin/psc-publish +strip ~/.local/bin/psc-bundle +strip ~/.local/bin/psc-ide-server +strip ~/.local/bin/psc-ide-client + +# Copy files to staging directory +cp ~/.local/bin/psc build/purescript/ +cp ~/.local/bin/psci build/purescript/ +cp ~/.local/bin/psc-docs build/purescript/ +cp ~/.local/bin/psc-publish build/purescript/ +cp ~/.local/bin/psc-bundle build/purescript/ +cp ~/.local/bin/psc-ide-server build/purescript/ +cp ~/.local/bin/psc-ide-client build/purescript/ +cp README build/purescript/ +cp ../LICENSE build/purescript/ +cp ../INSTALL.md build/purescript/ + +# Make the binary bundle +pushd build > /dev/null +tar -zcvf ../$OS.tar.gz purescript +popd > /dev/null + +# Calculate the SHA hash +shasum $OS.tar.gz > $OS.sha + +# Remove the staging directory +rm -rf build/ + +popd > /dev/null diff --git a/bundle/build.sh b/bundle/build.sh index b6433ef4aa..33ef75cac0 100755 --- a/bundle/build.sh +++ b/bundle/build.sh @@ -16,25 +16,25 @@ pushd ${SCRIPTPATH} > /dev/null mkdir -p build/purescript/ # Strip the binaries -strip ~/.local/bin/psc -strip ~/.local/bin/psci -strip ~/.local/bin/psc-docs -strip ~/.local/bin/psc-publish -strip ~/.local/bin/psc-bundle -strip ~/.local/bin/psc-ide-server -strip ~/.local/bin/psc-ide-client +strip ../dist/build/psc/psc +strip ../dist/build/psci/psci +strip ../dist/build/psc-docs/psc-docs +strip ../dist/build/psc-publish/psc-publish +strip ../dist/build/psc-bundle/psc-bundle +strip ../dist/build/psc-ide-server/psc-ide-server +strip ../dist/build/psc-ide-client/psc-ide-client # Copy files to staging directory -cp ~/.local/bin/psc build/purescript/ -cp ~/.local/bin/psci build/purescript/ -cp ~/.local/bin/psc-docs build/purescript/ -cp ~/.local/bin/psc-publish build/purescript/ -cp ~/.local/bin/psc-bundle build/purescript/ -cp ~/.local/bin/psc-ide-server build/purescript/ -cp ~/.local/bin/psc-ide-client build/purescript/ -cp README build/purescript/ -cp ../LICENSE build/purescript/ -cp ../INSTALL.md build/purescript/ +cp ../dist/build/psc/psc build/purescript/ +cp ../dist/build/psci/psci build/purescript/ +cp ../dist/build/psc-docs/psc-docs build/purescript/ +cp ../dist/build/psc-publish/psc-publish build/purescript/ +cp ../dist/build/psc-bundle/psc-bundle build/purescript/ +cp ../dist/build/psc-ide-server/psc-ide-server build/purescript/ +cp ../dist/build/psc-ide-client/psc-ide-client build/purescript/ +cp README build/purescript/ +cp ../LICENSE build/purescript/ +cp ../INSTALL.md build/purescript/ # Make the binary bundle pushd build > /dev/null From caeb1f31c98cfc9aa4510ebb6a4977ff49bfc9c6 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 29 Feb 2016 15:01:20 +0000 Subject: [PATCH 0303/1580] Fix Windows build script --- bundle/winbuild.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/bundle/winbuild.sh b/bundle/winbuild.sh index cdc5d84394..ac69ea48d8 100644 --- a/bundle/winbuild.sh +++ b/bundle/winbuild.sh @@ -17,8 +17,8 @@ strip ../dist/build/psci/psci.exe strip ../dist/build/psc-docs/psc-docs.exe strip ../dist/build/psc-publish/psc-publish.exe strip ../dist/build/psc-bundle/psc-bundle.exe -strip ../dist/build/psc-ide-server/psc-ide-server -strip ../dist/build/psc-ide-client/psc-ide-client +strip ../dist/build/psc-ide-server/psc-ide-server.exe +strip ../dist/build/psc-ide-client/psc-ide-client.exe # Copy files to staging directory cp ../dist/build/psc/psc.exe build/purescript/ From 6aef07d876fa321de7401564697e86ca361e8c13 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 29 Feb 2016 15:04:30 +0000 Subject: [PATCH 0304/1580] Fix pretty printer spinning --- src/Language/PureScript/Pretty/Values.hs | 32 ++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 867e6f522c..b1ab730e42 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -57,6 +57,7 @@ prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> tex prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) +prettyPrintValue d (Abs (Right arg) val) = text ('\\' : prettyPrintBinder arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) = text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom (d - 1) ps prettyPrintValue d (Case values binders) = @@ -70,9 +71,24 @@ prettyPrintValue d (Do els) = text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) prettyPrintValue _ (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) +prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = + text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">" prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val -prettyPrintValue d expr = prettyPrintValueAtom d expr +prettyPrintValue d expr@NumericLiteral{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@StringLiteral{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@CharLiteral{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@BooleanLiteral{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@ArrayLiteral{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@ObjectLiteral{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@OperatorSection{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@BinaryNoParens{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@Parens{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@ObjectGetter{} = prettyPrintValueAtom d expr -- | Pretty-print an atomic expression, adding parentheses if necessary. prettyPrintValueAtom :: Int -> Expr -> Box @@ -88,8 +104,16 @@ prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify nam prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident) prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")" prettyPrintValueAtom d (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue (d - 1) val) `beforeWithSpace` prettyPrintValue (d - 1) op) `before` text ")" +prettyPrintValueAtom d (BinaryNoParens op lhs rhs) = + prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs + where + printOp (Var (Qualified _ (Op opName))) = text opName + printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`" prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val +prettyPrintValueAtom d (Parens expr) = (text "(" <> prettyPrintValue d expr) `before` text ")" +prettyPrintValueAtom d (UnaryMinus expr) = text "(-" <> prettyPrintValue d expr <> text ")" +prettyPrintValueAtom _ (ObjectGetter field) = text "_." <> text field prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")" prettyPrintDeclaration :: Int -> Declaration -> Box @@ -143,6 +167,7 @@ prettyPrintBinderAtom (BooleanBinder True) = "true" prettyPrintBinderAtom (BooleanBinder False) = "false" prettyPrintBinderAtom (VarBinder ident) = showIdent ident prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor) +prettyPrintBinderAtom b@ConstructorBinder{} = parens (prettyPrintBinder b) prettyPrintBinderAtom (ObjectBinder bs) = "{ " ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs) @@ -157,7 +182,10 @@ prettyPrintBinderAtom (ArrayBinder bs) = prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder -prettyPrintBinderAtom b = parens (prettyPrintBinder b) +prettyPrintBinderAtom (OpBinder op) = showIdent (disqualify op) +prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) = + prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2 +prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b) -- | -- Generate a pretty-printed string representing a Binder From ac586930069cf490e60fc98f6f600215157b4dd5 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 29 Feb 2016 15:15:50 +0000 Subject: [PATCH 0305/1580] Fix true not being treated as an infallible guard --- src/Language/PureScript/Linter/Exhaustive.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index b28905b5a8..8ccfc6e184 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -201,9 +201,11 @@ isExhaustiveGuard :: Either [(Guard, Expr)] Expr -> Bool isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs where isOtherwise :: Expr -> Bool - isOtherwise (TypedValue _ (BooleanLiteral True) _) = True - isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) _) = True - isOtherwise (TypedValue _ (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) _) = True + isOtherwise (BooleanLiteral True) = True + isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True + isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True + isOtherwise (TypedValue _ e _) = isOtherwise e + isOtherwise (PositionedValue _ _ e) = isOtherwise e isOtherwise _ = False isExhaustiveGuard (Right _) = True From 3c8b32e7ef1ed9e1ca3fb046f71064c1a801baa4 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 29 Feb 2016 16:58:38 +0000 Subject: [PATCH 0306/1580] Fix detection of single open import --- src/Language/PureScript/Linter/Imports.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 68753b213d..63fccba7c4 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -79,8 +79,8 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env) usedImps' = foldr (elaborateUsed scope) usedImps exportedModules - numImplicitImports = getSum $ foldMap (Sum . countImplicitImports) mdecls - allowImplicit = numImplicitImports == 1 + numOpenImports = getSum $ foldMap (Sum . countOpenImports) mdecls + allowImplicit = numOpenImports == 1 imps <- M.toAscList <$> findImports mdecls @@ -106,10 +106,11 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do where - countImplicitImports :: Declaration -> Int - countImplicitImports (ImportDeclaration mn' Implicit _ _) | not (isPrim mn') = 1 - countImplicitImports (PositionedDeclaration _ _ d) = countImplicitImports d - countImplicitImports _ = 0 + countOpenImports :: Declaration -> Int + countOpenImports (ImportDeclaration mn' Implicit Nothing _) | not (isPrim mn') = 1 + countOpenImports (ImportDeclaration mn' (Hiding _) Nothing _) | not (isPrim mn') = 1 + countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d + countOpenImports _ = 0 -- Checks whether a module is the Prim module - used to suppress any checks -- made, as Prim is always implicitly imported. From 38618a54902d64a8cddbafffa079edc91e1bfc90 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 29 Feb 2016 11:15:51 -0800 Subject: [PATCH 0307/1580] 0.8.2 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index dd4cf029bf..e2da1cfd1b 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.8.1.0 +version: 0.8.2.0 cabal-version: >=1.8 build-type: Simple license: MIT From c8e3d88b32f92b8fe8bf9c76048bf3631aca3c1d Mon Sep 17 00:00:00 2001 From: David Lindbom Date: Tue, 1 Mar 2016 21:29:24 +0100 Subject: [PATCH 0308/1580] Fix indentation bug #1881 --- examples/failing/1881.purs | 6 ++++++ examples/passing/1881.purs | 17 +++++++++++++++++ src/Language/PureScript/Parser/Declarations.hs | 1 + 3 files changed, 24 insertions(+) create mode 100644 examples/failing/1881.purs create mode 100644 examples/passing/1881.purs diff --git a/examples/failing/1881.purs b/examples/failing/1881.purs new file mode 100644 index 0000000000..aee7bd5100 --- /dev/null +++ b/examples/failing/1881.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +foo = +bar :: Int +bar = 3 diff --git a/examples/passing/1881.purs b/examples/passing/1881.purs new file mode 100644 index 0000000000..325e761699 --- /dev/null +++ b/examples/passing/1881.purs @@ -0,0 +1,17 @@ +module Main where + +foo = + 1 + +bar + = 2 + +baz + = + 3 + +qux + = + 3 + +main = Control.Monad.Eff.Console.log "Done" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index c6e9ad464c..7ee1dc0b64 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -93,6 +93,7 @@ parseValueDeclaration = do where parseValueWithWhereClause :: TokenParser Expr parseValueWithWhereClause = do + C.indented value <- parseValue whereClause <- P.optionMaybe $ do C.indented From 3ed6f052016064ef16285d1b5031960390e0751d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 1 Mar 2016 21:24:48 -0800 Subject: [PATCH 0309/1580] Infer types with class constraints (work in progress) --- .../PureScript/TypeChecker/Entailment.hs | 56 ++++++++++++------- src/Language/PureScript/TypeChecker/Types.hs | 18 +++--- 2 files changed, 46 insertions(+), 28 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 48d878a1c2..5a63edb2a1 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -18,6 +18,7 @@ import Control.Arrow (Arrow(..)) import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Supply.Class (MonadSupply(..)) import Language.PureScript.Crash import Language.PureScript.AST @@ -34,11 +35,11 @@ import qualified Language.PureScript.Constants as C -- entails :: forall m - . (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint - -> m Expr + -> m (Expr, [(Ident, Constraint)]) entails moduleName context = solve where forClassName :: Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope] @@ -54,12 +55,12 @@ entails moduleName context = solve findDicts :: Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope] findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context - solve :: Constraint -> m Expr + solve :: Constraint -> m (Expr, [(Ident, Constraint)]) solve (className, tys) = do - dict <- go 0 className tys - return $ dictionaryValueToValue dict + (dict, unsolved) <- go 0 className tys + return (dictionaryValueToValue dict, unsolved) where - go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> m DictionaryValue + go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> m (DictionaryValue, [(Ident, Constraint)]) go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' go work className' tys' = do let instances = do @@ -67,21 +68,33 @@ entails moduleName context = solve -- Make sure the type unifies with the type in the type instance definition subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName) tys' (tcdInstanceTypes tcd) return (subst, tcd) - (subst, tcd) <- unique instances - -- Solve any necessary subgoals - args <- solveSubgoals subst (tcdDependencies tcd) - return $ foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index) - (mkDictionary (tcdName tcd) args) - (tcdPath tcd) + solution <- unique instances + case solution of + Left (subst, tcd) -> do + -- Solve any necessary subgoals + (args, unsolved) <- solveSubgoals subst (tcdDependencies tcd) + let match = foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index) + (mkDictionary (tcdName tcd) args) + (tcdPath tcd) + return (match, unsolved) + Right unsolved@(Qualified _ (ProperName unsolvedClassName), _) -> do + ident <- freshIdent ("dict" ++ unsolvedClassName) + return (LocalDictionaryValue (Qualified Nothing ident), [(ident, unsolved)]) where - unique :: [(a, TypeClassDictionaryInScope)] -> m (a, TypeClassDictionaryInScope) - unique [] = throwError . errorMessage $ NoInstanceFound className' tys' - unique [a] = return a + unique :: [(a, TypeClassDictionaryInScope)] -> m (Either (a, TypeClassDictionaryInScope) Constraint) + unique [] | all canBeGeneralized tys' = return $ Right (className, tys) + | otherwise = throwError . errorMessage $ NoInstanceFound className' tys' + unique [a] = return $ Left a unique tcds | pairwise overlapping (map snd tcds) = do tell . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds) - return (head tcds) - | otherwise = return (minimumBy (compare `on` length . tcdPath . snd) tcds) + return $ Left (head tcds) + | otherwise = return $ Left (minimumBy (compare `on` length . tcdPath . snd) tcds) + + canBeGeneralized :: Type -> Bool + canBeGeneralized TUnknown{} = True + canBeGeneralized Skolem{} = True + canBeGeneralized _ = False -- | -- Check if two dictionaries are overlapping @@ -98,11 +111,12 @@ entails moduleName context = solve -- Create dictionaries for subgoals which still need to be solved by calling go recursively -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively. - solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> m (Maybe [DictionaryValue]) - solveSubgoals _ Nothing = return Nothing + solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> m (Maybe [DictionaryValue], [(Ident, Constraint)]) + solveSubgoals _ Nothing = return (Nothing, []) solveSubgoals subst (Just subgoals) = do - dict <- traverse (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals - return $ Just dict + zipped <- traverse (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals + let (dicts, unsolved) = unzip zipped + return (Just dicts, concat unsolved) -- Make a dictionary from subgoal dictionaries by applying the correct function mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 74bd82fd58..becfa30eb4 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -39,6 +39,7 @@ import Control.Monad.State.Class (MonadState(..), gets) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Trans.Writer (WriterT(..)) import Language.PureScript.Crash import Language.PureScript.AST @@ -74,13 +75,16 @@ typesOf moduleName vals = do forM tys $ \(ident, (val, ty)) -> do -- Replace type class dictionary placeholders with actual dictionaries - val' <- replaceTypeClassDictionaries moduleName val + (val', unsolved) <- replaceTypeClassDictionaries moduleName val -- Check skolem variables did not escape their scope skolemEscapeCheck val' -- Check rows do not contain duplicate labels checkDuplicateLabels val' - return (ident, (val', varIfUnknown ty)) + return (ident, (foldr (Abs . Left) val' (map fst unsolved), varIfUnknown (constrain unsolved ty))) where + -- | Generalize over any unsolved constraints + constrain [] = id + constrain cs = ConstrainedType (map snd cs) -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (substituteType sub) val, substituteType sub ty))) ts -- Replace all the wildcards types with their inferred types @@ -168,16 +172,16 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' -- | Replace type class dictionary placeholders with inferred type class dictionaries replaceTypeClassDictionaries :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => ModuleName -> Expr -> - m Expr + m (Expr, [(Ident, Constraint)]) replaceTypeClassDictionaries mn = - let (_, f, _) = everywhereOnValuesTopDownM return go return - in f + let (_, f, _) = everywhereOnValuesTopDownM return (WriterT . go) return + in runWriterT . f where go (TypeClassDictionary constraint dicts) = entails mn dicts constraint - go other = return other + go other = return (other, []) -- | Check the kind of a type, failing if it is not of kind *. checkTypeKind :: From 855c37239ea0dc07f096f0a370b38c3d1145c4e5 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 2 Mar 2016 18:45:50 -0800 Subject: [PATCH 0310/1580] Only generalize types for declarations without type annotations --- .../PureScript/TypeChecker/Entailment.hs | 7 ++++--- src/Language/PureScript/TypeChecker/Types.hs | 16 +++++++++------- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 5a63edb2a1..8d35cb441e 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -36,11 +36,12 @@ import qualified Language.PureScript.Constants as C entails :: forall m . (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) - => ModuleName + => Bool + -> ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> m (Expr, [(Ident, Constraint)]) -entails moduleName context = solve +entails shouldGeneralize moduleName context = solve where forClassName :: Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope] forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys)) @@ -83,7 +84,7 @@ entails moduleName context = solve where unique :: [(a, TypeClassDictionaryInScope)] -> m (Either (a, TypeClassDictionaryInScope) Constraint) - unique [] | all canBeGeneralized tys' = return $ Right (className, tys) + unique [] | shouldGeneralize && all canBeGeneralized tys' = return $ Right (className, tys) | otherwise = throwError . errorMessage $ NoInstanceFound className' tys' unique [a] = return $ Left a unique tcds | pairwise overlapping (map snd tcds) = do diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index becfa30eb4..c23baf8a0e 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} -- | -- This module implements the type checker @@ -71,22 +72,22 @@ typesOf moduleName vals = do (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict ds2 <- forM untyped $ \e -> typeForBindingGroupElement True e dict untypedDict - return $ ds1 ++ ds2 + return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2) - forM tys $ \(ident, (val, ty)) -> do + forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do -- Replace type class dictionary placeholders with actual dictionaries - (val', unsolved) <- replaceTypeClassDictionaries moduleName val + (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize moduleName val -- Check skolem variables did not escape their scope skolemEscapeCheck val' -- Check rows do not contain duplicate labels checkDuplicateLabels val' - return (ident, (foldr (Abs . Left) val' (map fst unsolved), varIfUnknown (constrain unsolved ty))) + return (ident, (foldr (Abs . Left . fst) val' unsolved, varIfUnknown (constrain unsolved ty))) where -- | Generalize over any unsolved constraints constrain [] = id constrain cs = ConstrainedType (map snd cs) -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values - tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (substituteType sub) val, substituteType sub ty))) ts + tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts -- Replace all the wildcards types with their inferred types replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints . WildcardInferredType $ substituteType sub ty replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (substituteType sub ty)) @@ -173,14 +174,15 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' -- | Replace type class dictionary placeholders with inferred type class dictionaries replaceTypeClassDictionaries :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => + Bool -> ModuleName -> Expr -> m (Expr, [(Ident, Constraint)]) -replaceTypeClassDictionaries mn = +replaceTypeClassDictionaries shouldGeneralize mn = let (_, f, _) = everywhereOnValuesTopDownM return (WriterT . go) return in runWriterT . f where - go (TypeClassDictionary constraint dicts) = entails mn dicts constraint + go (TypeClassDictionary constraint dicts) = entails shouldGeneralize mn dicts constraint go other = return (other, []) -- | Check the kind of a type, failing if it is not of kind *. From 8a318971aa5b6676c4b15b582ad7b609ea14404e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 3 Mar 2016 22:17:12 -0800 Subject: [PATCH 0311/1580] Tests, Check all unknowns in unsolved constraints will be generalized --- examples/failing/ConstraintInference.purs | 10 ++++++++++ examples/passing/ConstraintInference.purs | 7 +++++++ src/Language/PureScript/TypeChecker/Types.hs | 8 ++++++++ src/Language/PureScript/TypeChecker/Unify.hs | 1 + 4 files changed, 26 insertions(+) create mode 100644 examples/failing/ConstraintInference.purs create mode 100644 examples/passing/ConstraintInference.purs diff --git a/examples/failing/ConstraintInference.purs b/examples/failing/ConstraintInference.purs new file mode 100644 index 0000000000..f451fa0712 --- /dev/null +++ b/examples/failing/ConstraintInference.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith NoInstanceFound + +module Main where + +import Prelude + +spin :: forall a b. a -> b +spin x = spin x + +test = show <<< spin diff --git a/examples/passing/ConstraintInference.purs b/examples/passing/ConstraintInference.purs new file mode 100644 index 0000000000..1c97c66169 --- /dev/null +++ b/examples/passing/ConstraintInference.purs @@ -0,0 +1,7 @@ +module Main where + +import Prelude + +shout = Control.Monad.Eff.Console.log <<< (<> "!") <<< show + +main = shout "Done" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index c23baf8a0e..076f2dcf27 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -77,6 +77,14 @@ typesOf moduleName vals = do forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do -- Replace type class dictionary placeholders with actual dictionaries (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize moduleName val + let unsolvedTypeVars = nub $ unknownsInType ty + -- Make sure any unsolved type constraints only use type variables which appear + -- unknown in the inferred type. + when shouldGeneralize $ + forM_ unsolved $ \(_, (className, classTys)) -> do + let constraintTypeVars = nub $ foldMap unknownsInType classTys + when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ + throwError . errorMessage $ NoInstanceFound className classTys -- Check skolem variables did not escape their scope skolemEscapeCheck val' -- Check rows do not contain duplicate labels diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 92d7b7f56b..edf826cb2e 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -23,6 +23,7 @@ module Language.PureScript.TypeChecker.Unify ( freshType, solveType, substituteType, + unknownsInType, unifyTypes, unifyRows, unifiesWith, From d9acad2be0d47879348c807e19acf5737b09f1ef Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 4 Mar 2016 08:28:04 -0800 Subject: [PATCH 0312/1580] Generalize types properly in MissingTypeDeclaration warnings --- examples/passing/ContextSimplification.purs | 9 +++++++++ src/Language/PureScript/TypeChecker/Types.hs | 20 +++++++++++--------- 2 files changed, 20 insertions(+), 9 deletions(-) create mode 100644 examples/passing/ContextSimplification.purs diff --git a/examples/passing/ContextSimplification.purs b/examples/passing/ContextSimplification.purs new file mode 100644 index 0000000000..3e32ef32ad --- /dev/null +++ b/examples/passing/ContextSimplification.purs @@ -0,0 +1,9 @@ +module Main where + +import Prelude + +-- Here, we should simplify the context so that only one Eq +-- constraint is added. +usesEqTwice x = if x == x then x == x else false + +main = Control.Monad.Eff.Console.log "Done" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 076f2dcf27..37838616ee 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -71,16 +71,19 @@ typesOf moduleName vals = do tys <- fmap tidyUp . liftUnifyWarnings replace $ do (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict - ds2 <- forM untyped $ \e -> typeForBindingGroupElement True e dict untypedDict + ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2) forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do -- Replace type class dictionary placeholders with actual dictionaries (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize moduleName val let unsolvedTypeVars = nub $ unknownsInType ty + -- Generalize and constrain the type + let generalized = generalize unsolved ty -- Make sure any unsolved type constraints only use type variables which appear -- unknown in the inferred type. - when shouldGeneralize $ + when shouldGeneralize $ do + tell . errorMessage $ MissingTypeDeclaration ident generalized forM_ unsolved $ \(_, (className, classTys)) -> do let constraintTypeVars = nub $ foldMap unknownsInType classTys when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ @@ -89,16 +92,17 @@ typesOf moduleName vals = do skolemEscapeCheck val' -- Check rows do not contain duplicate labels checkDuplicateLabels val' - return (ident, (foldr (Abs . Left . fst) val' unsolved, varIfUnknown (constrain unsolved ty))) + return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized)) where - -- | Generalize over any unsolved constraints + -- | Generalize type vars using forall and add inferred constraints + generalize unsolved = varIfUnknown . constrain unsolved + -- | Add any unsolved constraints constrain [] = id constrain cs = ConstrainedType (map snd cs) -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts -- Replace all the wildcards types with their inferred types replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints . WildcardInferredType $ substituteType sub ty - replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (substituteType sub ty)) replace _ em = em type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) @@ -151,16 +155,14 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do typeForBindingGroupElement :: (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - Bool -> (Ident, Expr) -> TypeData -> UntypedData -> m (Ident, (Expr, Type)) -typeForBindingGroupElement warn (ident, val) dict untypedDict = do +typeForBindingGroupElement (ident, val) dict untypedDict = do -- Infer the type with the new names in scope TypedValue _ val' ty <- bindNames dict $ infer val unifyTypes ty $ fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict) - when warn . tell . errorMessage $ MissingTypeDeclaration ident ty return (ident, (TypedValue True val' ty, ty)) -- | Check if a value contains a type annotation @@ -343,7 +345,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do Just moduleName <- checkCurrentModule <$> get (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds) ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict - ds2' <- forM untyped $ \e -> typeForBindingGroupElement False e dict untypedDict + ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] bindNames dict $ do makeBindingGroupVisible From fdc94352319ca3c09076c7965c861497676464c6 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 4 Mar 2016 09:40:43 -0800 Subject: [PATCH 0313/1580] Basic context simplification --- examples/passing/ContextSimplification.purs | 10 ++- .../PureScript/TypeChecker/Entailment.hs | 68 ++++++++++++++----- src/Language/PureScript/TypeChecker/Types.hs | 15 ---- 3 files changed, 58 insertions(+), 35 deletions(-) diff --git a/examples/passing/ContextSimplification.purs b/examples/passing/ContextSimplification.purs index 3e32ef32ad..88c5835281 100644 --- a/examples/passing/ContextSimplification.purs +++ b/examples/passing/ContextSimplification.purs @@ -1,9 +1,13 @@ module Main where import Prelude +import Control.Monad.Eff.Console --- Here, we should simplify the context so that only one Eq +shout = log <<< (<> "!") <<< show + +-- Here, we should simplify the context so that only one Show -- constraint is added. -usesEqTwice x = if x == x then x == x else false +usesShowTwice true = shout +usesShowTwice false = print -main = Control.Monad.Eff.Console.log "Done" +main = usesShowTwice true "Done" diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 8d35cb441e..3ed036b177 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -4,7 +4,7 @@ -- | -- Type class entailment -- -module Language.PureScript.TypeChecker.Entailment (entails) where +module Language.PureScript.TypeChecker.Entailment (Context, replaceTypeClassDictionaries) where import Prelude () import Prelude.Compat @@ -16,8 +16,8 @@ import qualified Data.Map as M import Control.Arrow (Arrow(..)) import Control.Monad.State +import Control.Monad.Writer import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Supply.Class (MonadSupply(..)) import Language.PureScript.Crash @@ -29,6 +29,30 @@ import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types import qualified Language.PureScript.Constants as C +-- | The 'Context' tracks those constraints which can be satisfied. +type Context = M.Map (Maybe ModuleName) + (M.Map (Qualified (ProperName 'ClassName)) + (M.Map (Qualified Ident) + TypeClassDictionaryInScope)) + +-- | Merge two type class contexts +combineContexts :: Context -> Context -> Context +combineContexts = M.unionWith (M.unionWith M.union) + +-- | Replace type class dictionary placeholders with inferred type class dictionaries +replaceTypeClassDictionaries + :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) + => Bool + -> ModuleName + -> Expr + -> m (Expr, [(Ident, Constraint)]) +replaceTypeClassDictionaries shouldGeneralize mn = + let (_, f, _) = everywhereOnValuesTopDownM return (WriterT . go) return + in flip evalStateT M.empty . runWriterT . f + where + go (TypeClassDictionary constraint dicts) = entails shouldGeneralize mn dicts constraint + go other = return (other, []) + -- | -- Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. @@ -38,14 +62,14 @@ entails . (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => Bool -> ModuleName - -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) + -> Context -> Constraint - -> m (Expr, [(Ident, Constraint)]) + -> StateT Context m (Expr, [(Ident, Constraint)]) entails shouldGeneralize moduleName context = solve where - forClassName :: Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope] - forClassName cn@(Qualified (Just mn) _) tys = concatMap (findDicts cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys)) - forClassName _ _ = internalError "forClassName: expected qualified class name" + forClassName :: Context -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope] + forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys)) + forClassName _ _ _ = internalError "forClassName: expected qualified class name" ctorModules :: Type -> Maybe ModuleName ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn @@ -53,23 +77,25 @@ entails shouldGeneralize moduleName context = solve ctorModules (TypeApp ty _) = ctorModules ty ctorModules _ = Nothing - findDicts :: Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope] - findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context + findDicts :: Context -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope] + findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx - solve :: Constraint -> m (Expr, [(Ident, Constraint)]) + solve :: Constraint -> StateT Context m (Expr, [(Ident, Constraint)]) solve (className, tys) = do (dict, unsolved) <- go 0 className tys return (dictionaryValueToValue dict, unsolved) where - go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> m (DictionaryValue, [(Ident, Constraint)]) + go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> StateT Context m (DictionaryValue, [(Ident, Constraint)]) go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' go work className' tys' = do + -- Get the inferred constraint context so far, and merge it with the global context + inferred <- get let instances = do - tcd <- forClassName className' tys' + tcd <- forClassName (combineContexts context inferred) className' tys' -- Make sure the type unifies with the type in the type instance definition subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName) tys' (tcdInstanceTypes tcd) return (subst, tcd) - solution <- unique instances + solution <- lift $ unique instances case solution of Left (subst, tcd) -> do -- Solve any necessary subgoals @@ -78,9 +104,16 @@ entails shouldGeneralize moduleName context = solve (mkDictionary (tcdName tcd) args) (tcdPath tcd) return (match, unsolved) - Right unsolved@(Qualified _ (ProperName unsolvedClassName), _) -> do - ident <- freshIdent ("dict" ++ unsolvedClassName) - return (LocalDictionaryValue (Qualified Nothing ident), [(ident, unsolved)]) + Right unsolved@(unsolvedClassName@(Qualified _ pn), unsolvedTys) -> do + -- Generate a fresh name for the unsolved constraint's new dictionary + ident <- freshIdent ("dict" ++ runProperName pn) + let qident = Qualified Nothing ident + -- Store the new dictionary in the Context so that we can solve this goal in + -- future. + let newDict = TypeClassDictionaryInScope qident [] unsolvedClassName unsolvedTys Nothing + newContext = M.singleton Nothing (M.singleton unsolvedClassName (M.singleton qident newDict)) + modify (combineContexts newContext) + return (LocalDictionaryValue qident, [(ident, unsolved)]) where unique :: [(a, TypeClassDictionaryInScope)] -> m (Either (a, TypeClassDictionaryInScope) Constraint) @@ -112,7 +145,7 @@ entails shouldGeneralize moduleName context = solve -- Create dictionaries for subgoals which still need to be solved by calling go recursively -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively. - solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> m (Maybe [DictionaryValue], [(Ident, Constraint)]) + solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT Context m (Maybe [DictionaryValue], [(Ident, Constraint)]) solveSubgoals _ Nothing = return (Nothing, []) solveSubgoals subst (Just subgoals) = do zipped <- traverse (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals @@ -149,6 +182,7 @@ entails shouldGeneralize moduleName context = solve -- and return a substitution from type variables to types which makes the type heads unify. -- typeHeadsAreEqual :: ModuleName -> Type -> Type -> Maybe [(String, Type)] +typeHeadsAreEqual _ (TUnknown u1) (TUnknown u2) | u1 == u2 = Just [] typeHeadsAreEqual _ (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Just [] typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)] typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just [] diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 37838616ee..ff6a33bfb5 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -40,7 +40,6 @@ import Control.Monad.State.Class (MonadState(..), gets) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) -import Control.Monad.Trans.Writer (WriterT(..)) import Language.PureScript.Crash import Language.PureScript.AST @@ -181,20 +180,6 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' g (TypeClassDictionary (nm, tys) sco) = TypeClassDictionary (nm, map f tys) sco g other = other --- | Replace type class dictionary placeholders with inferred type class dictionaries -replaceTypeClassDictionaries :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => - Bool -> - ModuleName -> - Expr -> - m (Expr, [(Ident, Constraint)]) -replaceTypeClassDictionaries shouldGeneralize mn = - let (_, f, _) = everywhereOnValuesTopDownM return (WriterT . go) return - in runWriterT . f - where - go (TypeClassDictionary constraint dicts) = entails shouldGeneralize mn dicts constraint - go other = return (other, []) - -- | Check the kind of a type, failing if it is not of kind *. checkTypeKind :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) => From 67fe2c709f43e84a0d6e190b64f70b1ddfa21603 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 4 Mar 2016 09:42:38 -0800 Subject: [PATCH 0314/1580] Update MonadState example --- examples/passing/MonadState.purs | 51 ++++++++++++++++++++------------ 1 file changed, 32 insertions(+), 19 deletions(-) diff --git a/examples/passing/MonadState.purs b/examples/passing/MonadState.purs index c2cd0e7107..8d64394be1 100644 --- a/examples/passing/MonadState.purs +++ b/examples/passing/MonadState.purs @@ -1,12 +1,16 @@ module Main where import Prelude +import Control.Monad.Eff.Console data Tuple a b = Tuple a b -class MonadState s m where +instance showTuple :: (Show a, Show b) => Show (Tuple a b) where + show (Tuple a b) = "(" <> show a <> ", " <> show b <> ")" + +class Monad m <= MonadState s m where get :: m s - put :: s -> m {} + put :: s -> m Unit data State s a = State (s -> Tuple s a) @@ -29,20 +33,29 @@ instance monadState :: Monad (State s) instance monadStateState :: MonadState s (State s) where get = State (\s -> Tuple s s) - put s = State (\_ -> Tuple s {}) - -modify :: forall m s. (Prelude.Monad m, MonadState s m) => (s -> s) -> m {} -modify f = do - s <- get - put (f s) - -test :: Tuple String String -test = runState "" $ do - modify $ (++) "World!" - modify $ (++) "Hello, " - get - -main = do - let t1 = test - Control.Monad.Eff.Console.log "Done" - + put s = State (\_ -> Tuple s unit) + +-- Without the call to same, the following strange (but correct, in the absence of +-- functional dependencies) type: +-- +-- forall m t1 t2. +-- ( Bind m +-- , MonadState t1 m +-- , MonadState t2 m +-- ) => (t1 -> t2) -> m Unit +-- +-- With the type hint, the inferred type is more sensible: +-- +-- forall m t. +-- ( Bind m +-- , MonadState t m +-- ) => (t -> t) -> m Unit +modify f = + do + s <- get + put (same f s) + where + same :: forall a. (a -> a) -> (a -> a) + same = id + +main = print $ runState 0 (modify (+ 1)) From 9c29a145b8abb10e1a7615556e81196c542e2337 Mon Sep 17 00:00:00 2001 From: bagl Date: Sun, 6 Mar 2016 00:40:40 +0100 Subject: [PATCH 0315/1580] Desugar operator section always to lambda Fix issue #1916 --- examples/failing/OperatorSections.purs | 7 +++++++ src/Language/PureScript/AST/Declarations.hs | 3 +-- src/Language/PureScript/Sugar/Operators.hs | 9 ++++++--- 3 files changed, 14 insertions(+), 5 deletions(-) create mode 100644 examples/failing/OperatorSections.purs diff --git a/examples/failing/OperatorSections.purs b/examples/failing/OperatorSections.purs new file mode 100644 index 0000000000..f53d7399a3 --- /dev/null +++ b/examples/failing/OperatorSections.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith CannotApplyFunction +module Main where + +import Prelude + +main = do + (true `not` _) \ No newline at end of file diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 2b92a04df1..5e6e1fe81f 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -342,8 +342,7 @@ data Expr -- | Parens Expr -- | - -- Operator section. This will be removed during desugaring and replaced with a partially applied - -- operator or lambda to flip the arguments. + -- Operator section. This will be removed during desugaring and replaced with lambda. -- | OperatorSection Expr (Either Expr Expr) -- | diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 4b09c2c0b2..d183a56ab7 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -189,8 +189,11 @@ desugarOperatorSections (Module ss coms mn ds exts) = (goDecl, _, _) = everywhereOnValuesM return goExpr return goExpr :: Expr -> m Expr - goExpr (OperatorSection op (Left val)) = return $ App op val - goExpr (OperatorSection op (Right val)) = do + goExpr (OperatorSection op eVal) = do arg <- freshIdent' - return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val + let var = Var (Qualified Nothing arg) + f2 a b = Abs (Left arg) $ App (App op a) b + return $ case eVal of + Left val -> f2 val var + Right val -> f2 var val goExpr other = return other From d63fcadea1a7cb2c3a64766e327cb8fc43baa2f1 Mon Sep 17 00:00:00 2001 From: bagl Date: Sun, 6 Mar 2016 01:01:54 +0100 Subject: [PATCH 0316/1580] Add missing newline --- examples/failing/OperatorSections.purs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/examples/failing/OperatorSections.purs b/examples/failing/OperatorSections.purs index f53d7399a3..7be5b3f21b 100644 --- a/examples/failing/OperatorSections.purs +++ b/examples/failing/OperatorSections.purs @@ -4,4 +4,5 @@ module Main where import Prelude main = do - (true `not` _) \ No newline at end of file + (true `not` _) + From f5511ded08cdf155ee6a6169c53738d32b620a8a Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 7 Mar 2016 21:28:36 +0100 Subject: [PATCH 0317/1580] adds a --help command to the psc-ide executables Should fix the problems in https://github.com/purescript-contrib/node-purescript-bin/pull/16 so that we can add psc-ide executables to the npm bundle. --- psc-ide-client/Main.hs | 13 ++++++------- psc-ide-server/Main.hs | 2 +- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs index 7007815ae5..17c05963e5 100644 --- a/psc-ide-client/Main.hs +++ b/psc-ide-client/Main.hs @@ -5,7 +5,6 @@ import Prelude () import Prelude.Compat import Control.Exception -import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -18,19 +17,19 @@ import System.IO import qualified Paths_purescript as Paths data Options = Options - { optionsPort :: Maybe Int - } + { optionsPort :: PortID + } main :: IO () main = do Options port <- execParser opts - let port' = PortNumber . fromIntegral $ fromMaybe 4242 port - client port' + client port where parser = Options <$> - optional (option auto (long "port" <> short 'p')) - opts = info (version <*> parser) mempty + (PortNumber . fromIntegral <$> + option auto (long "port" <> short 'p' <> value (4242 :: Integer))) + opts = info (version <*> helper <*> parser) mempty version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden client :: PortID -> IO () diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 6188c49864..db2528ff63 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -87,7 +87,7 @@ main = do (PortNumber . fromIntegral <$> option auto (long "port" <> short 'p' <> value (4242 :: Integer))) <*> switch (long "debug") - opts = info (version <*> parser) mempty + opts = info (version <*> helper <*> parser) mempty version = abortOption (InfoMsg (showVersion Paths.version)) (long "version" <> help "Show the version number") From 1f8c9ed281dab1672e3f22665d17e5b8089ae069 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 7 Mar 2016 22:26:52 +0100 Subject: [PATCH 0318/1580] catches EOF exceptions thrown in acceptCommand This stops the server from crashing if the client terminates the connection before sending any data. The emacs plugin somehow does this from time to time and I consider it reasonable to not have the server die because a client disconnects anyway. --- psc-ide-server/Main.hs | 55 ++++++++++++++++++++++++++---------------- 1 file changed, 34 insertions(+), 21 deletions(-) diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 6188c49864..e7e9ace2b2 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -11,8 +11,9 @@ import Prelude.Compat import Control.Concurrent (forkFinally) import Control.Concurrent.STM -import Control.Exception (bracketOnError) +import Control.Exception (bracketOnError, catchJust) import Control.Monad +import Control.Monad.Error.Class import "monad-logger" Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Except @@ -32,6 +33,7 @@ import Options.Applicative import System.Directory import System.FilePath import System.IO +import System.IO.Error (isEOFError) import qualified Paths_purescript as Paths @@ -101,32 +103,43 @@ startServer port env = withSocketsDo $ do loop :: (PscIde m, MonadLogger m) => Socket -> m () loop sock = do - (cmd,h) <- acceptCommand sock - case decodeT cmd of - Just cmd' -> do - result <- runExceptT (handleCommand cmd') - $(logDebug) ("Answer was: " <> T.pack (show result)) - liftIO (hFlush stdout) - case result of - -- What function can I use to clean this up? - Right r -> liftIO $ T.hPutStrLn h (encodeT r) - Left err -> liftIO $ T.hPutStrLn h (encodeT err) - Nothing -> do - $(logDebug) ("Parsing the command failed. Command: " <> cmd) - liftIO $ do - T.hPutStrLn h (encodeT (GeneralError "Error parsing Command.")) - hFlush stdout - liftIO (hClose h) + accepted <- runExceptT $ acceptCommand sock + case accepted of + Left err -> $(logDebug) err + Right (cmd, h) -> do + case decodeT cmd of + Just cmd' -> do + result <- runExceptT (handleCommand cmd') + $(logDebug) ("Answer was: " <> T.pack (show result)) + liftIO (hFlush stdout) + case result of + -- What function can I use to clean this up? + Right r -> liftIO $ T.hPutStrLn h (encodeT r) + Left err -> liftIO $ T.hPutStrLn h (encodeT err) + Nothing -> do + $(logDebug) ("Parsing the command failed. Command: " <> cmd) + liftIO $ do + T.hPutStrLn h (encodeT (GeneralError "Error parsing Command.")) + hFlush stdout + liftIO (hClose h) -acceptCommand :: (Applicative m, MonadIO m, MonadLogger m) +acceptCommand :: (Applicative m, MonadIO m, MonadLogger m, MonadError T.Text m) => Socket -> m (T.Text, Handle) acceptCommand sock = do h <- acceptConnection $(logDebug) "Accepted a connection" - cmd <- liftIO (T.hGetLine h) - $(logDebug) cmd - pure (cmd, h) + cmd' <- liftIO (catchJust + -- this means that the connection was + -- terminated without receiving any input + (\e -> if isEOFError e then Just () else Nothing) + (Just <$> T.hGetLine h) + (const (pure Nothing))) + case cmd' of + Nothing -> throwError "Connection was closed before any input arrived" + Just cmd -> do + $(logDebug) cmd + pure (cmd, h) where acceptConnection = liftIO $ do (h,_,_) <- accept sock From e9253c06111c52ea1c815effc9e53346e5ef0737 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 7 Mar 2016 21:59:38 -0600 Subject: [PATCH 0319/1580] Remove GHC 8 build for now --- .travis.yml | 3 --- 1 file changed, 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 54e217de66..e80e4c0eae 100644 --- a/.travis.yml +++ b/.travis.yml @@ -24,9 +24,6 @@ matrix: - env: GHCVER=7.10.3 CABALVER=1.22 compiler: ": #GHC 7.10.3" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=8.0.1 CABALVER=1.24 - compiler: ": #GHC 8.0.1" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} before_install: - unset CC - export PATH="/opt/ghc/$GHCVER/bin:$PATH" From e5655c8db56c7119d1e02e0a9392e8cfd57278d2 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Thu, 3 Mar 2016 02:14:27 +0000 Subject: [PATCH 0320/1580] Use generic Literal in the AST --- psci/PSCi.hs | 2 +- purescript.cabal | 2 +- src/Language/PureScript/AST.hs | 18 +- src/Language/PureScript/AST/Binders.hs | 31 +- src/Language/PureScript/AST/Declarations.hs | 25 +- .../PureScript/{CoreFn => AST}/Literals.hs | 4 +- src/Language/PureScript/AST/Traversals.hs | 300 ++++++++++++------ src/Language/PureScript/CoreFn.hs | 17 +- src/Language/PureScript/CoreFn/Binders.hs | 2 +- src/Language/PureScript/CoreFn/Desugar.hs | 32 +- src/Language/PureScript/CoreFn/Expr.hs | 2 +- src/Language/PureScript/CoreFn/Traversals.hs | 17 +- src/Language/PureScript/Linter/Exhaustive.hs | 21 +- .../PureScript/Parser/Declarations.hs | 63 ++-- src/Language/PureScript/Pretty/Values.hs | 67 ++-- .../PureScript/Sugar/ObjectWildcards.hs | 8 +- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 78 +++-- src/Language/PureScript/TypeChecker/Types.hs | 50 +-- 19 files changed, 374 insertions(+), 367 deletions(-) rename src/Language/PureScript/{CoreFn => AST}/Literals.hs (87%) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index ea119c5a17..5a21193c54 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -214,7 +214,7 @@ handleDecls :: [P.Declaration] -> PSCI () handleDecls ds = do st <- PSCI $ lift get let st' = updateLets ds st - let m = createTemporaryModule False st' (P.ObjectLiteral []) + let m = createTemporaryModule False st' (P.Literal (P.ObjectLiteral [])) e <- psciIO . runMake $ make st' [m] case e of Left err -> PSCI $ printErrors err diff --git a/purescript.cabal b/purescript.cabal index e2da1cfd1b..7f9e5ff648 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -96,6 +96,7 @@ library Language.PureScript.AST.Binders Language.PureScript.AST.Declarations Language.PureScript.AST.Operators + Language.PureScript.AST.Literals Language.PureScript.AST.SourcePos Language.PureScript.AST.Traversals Language.PureScript.AST.Exported @@ -119,7 +120,6 @@ library Language.PureScript.CoreFn.Binders Language.PureScript.CoreFn.Desugar Language.PureScript.CoreFn.Expr - Language.PureScript.CoreFn.Literals Language.PureScript.CoreFn.Meta Language.PureScript.CoreFn.Module Language.PureScript.CoreFn.Traversals diff --git a/src/Language/PureScript/AST.hs b/src/Language/PureScript/AST.hs index 417ec41c03..fe82e27200 100644 --- a/src/Language/PureScript/AST.hs +++ b/src/Language/PureScript/AST.hs @@ -1,24 +1,14 @@ ------------------------------------------------------------------------------ +-- | +-- The initial PureScript AST -- --- Module : Language.PureScript.AST --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | The initial PureScript AST --- ------------------------------------------------------------------------------ - module Language.PureScript.AST ( module AST ) where import Language.PureScript.AST.Binders as AST import Language.PureScript.AST.Declarations as AST +import Language.PureScript.AST.Exported as AST +import Language.PureScript.AST.Literals as AST import Language.PureScript.AST.Operators as AST import Language.PureScript.AST.SourcePos as AST import Language.PureScript.AST.Traversals as AST -import Language.PureScript.AST.Exported as AST diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index 2ff3fe48d7..21ef3cafcb 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -4,6 +4,7 @@ module Language.PureScript.AST.Binders where import Language.PureScript.AST.SourcePos +import Language.PureScript.AST.Literals import Language.PureScript.Names import Language.PureScript.Comments import Language.PureScript.Types @@ -17,21 +18,9 @@ data Binder -- = NullBinder -- | - -- A binder which matches a boolean literal + -- A binder which matches a literal -- - | BooleanBinder Bool - -- | - -- A binder which matches a string literal - -- - | StringBinder String - -- | - -- A binder which matches a character literal - -- - | CharBinder Char - -- | - -- A binder which matches a numeric literal - -- - | NumberBinder (Either Integer Double) + | LiteralBinder (Literal Binder) -- | -- A binder which binds an identifier -- @@ -59,14 +48,6 @@ data Binder -- | ParensInBinder 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 binds its input to an identifier -- | NamedBinder Ident Binder @@ -86,13 +67,15 @@ data Binder binderNames :: Binder -> [Ident] binderNames = go [] where + go ns (LiteralBinder b) = lit ns b go ns (VarBinder name) = name : ns go ns (ConstructorBinder _ bs) = foldl go ns bs go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3] go ns (ParensInBinder b) = go ns b - go ns (ObjectBinder bs) = foldl go ns (map snd bs) - go ns (ArrayBinder bs) = foldl go ns bs go ns (NamedBinder name b) = go (name : ns) b go ns (PositionedBinder _ _ b) = go ns b go ns (TypedBinder _ b) = go ns b go ns _ = ns + lit ns (ObjectLiteral bs) = foldl go ns (map snd bs) + lit ns (ArrayLiteral bs) = foldl go ns bs + lit ns _ = ns diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 2b92a04df1..e2c5fa4dd8 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -19,6 +19,7 @@ import qualified Data.Map as M import Control.Monad.Identity import Language.PureScript.AST.Binders +import Language.PureScript.AST.Literals import Language.PureScript.AST.Operators import Language.PureScript.AST.SourcePos import Language.PureScript.Types @@ -309,21 +310,9 @@ type Guard = Expr -- data Expr -- | - -- A numeric literal + -- A literal value -- - = NumericLiteral (Either Integer Double) - -- | - -- A string literal - -- - | StringLiteral String - -- | - -- A character literal - -- - | CharLiteral Char - -- | - -- A boolean literal - -- - | BooleanLiteral Bool + = Literal (Literal Expr) -- | -- A prefix -, will be desugared -- @@ -347,14 +336,6 @@ data Expr -- | OperatorSection Expr (Either Expr Expr) -- | - -- An array literal - -- - | ArrayLiteral [Expr] - -- | - -- An object literal - -- - | ObjectLiteral [(String, Expr)] - -- | -- An object property getter (e.g. `_.x`). This will be removed during -- desugaring and expanded into a lambda that reads a property from an object. -- diff --git a/src/Language/PureScript/CoreFn/Literals.hs b/src/Language/PureScript/AST/Literals.hs similarity index 87% rename from src/Language/PureScript/CoreFn/Literals.hs rename to src/Language/PureScript/AST/Literals.hs index cdc71b40ce..d14a36bc9a 100644 --- a/src/Language/PureScript/CoreFn/Literals.hs +++ b/src/Language/PureScript/AST/Literals.hs @@ -3,7 +3,7 @@ -- | -- The core functional representation for literal values. -- -module Language.PureScript.CoreFn.Literals where +module Language.PureScript.AST.Literals where -- | -- Data type for literal values. Parameterised so it can be used for Exprs and @@ -34,4 +34,4 @@ data Literal a -- An object literal -- | ObjectLiteral [(String, a)] - deriving (Show, Read, Functor) + deriving (Eq, Ord, Show, Read, Functor) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index ce800a27f4..55634a5739 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -1,17 +1,8 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.AST.Traversals --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | AST traversal helpers --- ------------------------------------------------------------------------------ +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- AST traversal helpers +-- module Language.PureScript.AST.Traversals where import Prelude () @@ -26,15 +17,20 @@ import Control.Monad import Control.Arrow ((***), (+++)) import Language.PureScript.AST.Binders +import Language.PureScript.AST.Literals import Language.PureScript.AST.Declarations import Language.PureScript.Types import Language.PureScript.Traversals import Language.PureScript.Names -everywhereOnValues :: (Declaration -> Declaration) -> - (Expr -> Expr) -> - (Binder -> Binder) -> - (Declaration -> Declaration, Expr -> Expr, Binder -> Binder) +everywhereOnValues + :: (Declaration -> Declaration) + -> (Expr -> Expr) + -> (Binder -> Binder) + -> ( Declaration -> Declaration + , Expr -> Expr + , Binder -> Binder + ) everywhereOnValues f g h = (f', g', h') where f' :: Declaration -> Declaration @@ -47,13 +43,12 @@ everywhereOnValues f g h = (f', g', h') f' other = f other g' :: Expr -> Expr + g' (Literal l) = g (Literal (lit g' l)) g' (UnaryMinus v) = g (UnaryMinus (g' v)) g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2)) g' (Parens v) = g (Parens (g' v)) g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v)) g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v)) - g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs)) - g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs)) g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v)) g' (Accessor prop v) = g (Accessor prop (g' v)) g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs)) @@ -71,13 +66,17 @@ everywhereOnValues f g h = (f', g', h') h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs)) h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3)) h' (ParensInBinder b) = h (ParensInBinder (h' b)) - h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs)) - h' (ArrayBinder bs) = h (ArrayBinder (map h' bs)) + h' (LiteralBinder l) = h (LiteralBinder (lit h' l)) h' (NamedBinder name b) = h (NamedBinder name (h' b)) h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b)) h' (TypedBinder t b) = h (TypedBinder t (h' b)) h' other = h other + lit :: (a -> a) -> Literal a -> Literal a + lit go (ArrayLiteral as) = ArrayLiteral (map go as) + lit go (ObjectLiteral as) = ObjectLiteral (map (fmap go) as) + lit _ other = other + handleCaseAlternative :: CaseAlternative -> CaseAlternative handleCaseAlternative ca = ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca) @@ -90,13 +89,20 @@ everywhereOnValues f g h = (f', g', h') handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds) handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e) -everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) => - (Declaration -> m Declaration) -> - (Expr -> m Expr) -> - (Binder -> m Binder) -> - (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder) +everywhereOnValuesTopDownM + :: forall m + . (Functor m, Applicative m, Monad m) + => (Declaration -> m Declaration) + -> (Expr -> m Expr) + -> (Binder -> m Binder) + -> ( Declaration -> m Declaration + , Expr -> m Expr + , Binder -> m Binder + ) everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) where + + f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds @@ -105,13 +111,13 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f') f' other = f other + g' :: Expr -> m Expr + g' (Literal l) = Literal <$> lit (g >=> g') l g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g') g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g') g' (Parens v) = Parens <$> (g v >>= g') g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g')) g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g')) - g' (ArrayLiteral vs) = ArrayLiteral <$> traverse (g' <=< g) vs - g' (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g' <=< g)) vs g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g') g' (Accessor prop v) = Accessor prop <$> (g v >>= g') g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs @@ -125,31 +131,47 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g') g' other = g other + h' :: Binder -> m Binder + h' (LiteralBinder l) = LiteralBinder <$> lit (h >=> h') l h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h') h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h') - h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs - h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h') h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h') h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h') h' other = h other - handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse (h' <=< h) bs - <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val + lit :: (a -> m a) -> Literal a -> m (Literal a) + lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as + lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as + lit _ other = pure other + + handleCaseAlternative :: CaseAlternative -> m CaseAlternative + handleCaseAlternative (CaseAlternative bs val) = + CaseAlternative + <$> traverse (h' <=< h) bs + <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val + handleDoNotationElement :: DoNotationElement -> m DoNotationElement handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e -everywhereOnValuesM :: (Functor m, Applicative m, Monad m) => - (Declaration -> m Declaration) -> - (Expr -> m Expr) -> - (Binder -> m Binder) -> - (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder) +everywhereOnValuesM + :: forall m + . (Functor m, Applicative m, Monad m) + => (Declaration -> m Declaration) + -> (Expr -> m Expr) + -> (Binder -> m Binder) + -> ( Declaration -> m Declaration + , Expr -> m Expr + , Binder -> m Binder + ) everywhereOnValuesM f g h = (f', g', h') where + + f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f @@ -158,13 +180,13 @@ everywhereOnValuesM f g h = (f', g', h') f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f f' other = f other + g' :: Expr -> m Expr + g' (Literal l) = (Literal <$> lit g' l) >>= g g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g g' (Parens v) = (Parens <$> g' v) >>= g g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g - g' (ArrayLiteral vs) = (ArrayLiteral <$> traverse g' vs) >>= g - g' (ObjectLiteral vs) = (ObjectLiteral <$> traverse (sndM g') vs) >>= g g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g @@ -178,33 +200,51 @@ everywhereOnValuesM f g h = (f', g', h') g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g g' other = g other + h' :: Binder -> m Binder + h' (LiteralBinder l) = (LiteralBinder <$> lit h' l) >>= h h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h - h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h - h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h h' other = h other - handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse h' bs - <*> eitherM (traverse (pairM g' g')) g' val + lit :: (a -> m a) -> Literal a -> m (Literal a) + lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as + lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as + lit _ other = pure other + + handleCaseAlternative :: CaseAlternative -> m CaseAlternative + handleCaseAlternative (CaseAlternative bs val) = + CaseAlternative + <$> traverse h' bs + <*> eitherM (traverse (pairM g' g')) g' val + handleDoNotationElement :: DoNotationElement -> m DoNotationElement handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e -everythingOnValues :: (r -> r -> r) -> - (Declaration -> r) -> - (Expr -> r) -> - (Binder -> r) -> - (CaseAlternative -> r) -> - (DoNotationElement -> r) -> - (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r) +everythingOnValues + :: forall r + . (r -> r -> r) + -> (Declaration -> r) + -> (Expr -> r) + -> (Binder -> r) + -> (CaseAlternative -> r) + -> (DoNotationElement -> r) + -> ( Declaration -> r + , Expr -> r + , Binder -> r + , CaseAlternative -> r + , DoNotationElement -> r + ) everythingOnValues (<>) f g h i j = (f', g', h', i', j') where + + f' :: Declaration -> r f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds) f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs) @@ -214,13 +254,13 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1 f' d = f d + g' :: Expr -> r + g' v@(Literal l) = lit (g v) g' l g' v@(UnaryMinus v1) = g v <> g' v1 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2 g' v@(Parens v1) = g v <> g' v1 g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1 g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1 - g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs) - g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs) g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1 g' v@(Accessor _ v1) = g v <> g' v1 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs) @@ -234,42 +274,53 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') g' v@(PositionedValue _ _ v1) = g v <> g' v1 g' v = g v + h' :: Binder -> r + h' b@(LiteralBinder l) = lit (h b) h' l h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs) h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3 h' b@(ParensInBinder b1) = h b <> h' b1 - h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs) - h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs) h' b@(NamedBinder _ b1) = h b <> h' b1 h' b@(PositionedBinder _ _ b1) = h b <> h' b1 h' b@(TypedBinder _ b1) = h b <> h' b1 h' b = h b + lit :: r -> (a -> r) -> Literal a -> r + lit r go (ArrayLiteral as) = foldl (<>) r (map go as) + lit r go (ObjectLiteral as) = foldl (<>) r (map (go . snd) as) + lit r _ _ = r + + i' :: CaseAlternative -> r i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs) + j' :: DoNotationElement -> r j' e@(DoNotationValue v) = j e <> g' v j' e@(DoNotationBind b v) = j e <> h' b <> g' v j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds) j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1 -everythingWithContextOnValues :: - s -> - r -> - (r -> r -> r) -> - (s -> Declaration -> (s, r)) -> - (s -> Expr -> (s, r)) -> - (s -> Binder -> (s, r)) -> - (s -> CaseAlternative -> (s, r)) -> - (s -> DoNotationElement -> (s, r)) -> - ( Declaration -> r - , Expr -> r - , Binder -> r - , CaseAlternative -> r - , DoNotationElement -> r) +everythingWithContextOnValues + :: forall s r + . s + -> r + -> (r -> r -> r) + -> (s -> Declaration -> (s, r)) + -> (s -> Expr -> (s, r)) + -> (s -> Binder -> (s, r)) + -> (s -> CaseAlternative -> (s, r)) + -> (s -> DoNotationElement -> (s, r)) + -> ( Declaration -> r + , Expr -> r + , Binder -> r + , CaseAlternative -> r + , DoNotationElement -> r) everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0) where + + f'' :: s -> Declaration -> r f'' s d = let (s', r) = f s d in r <> f' s' d + f' :: s -> Declaration -> r f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds) f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs) @@ -279,15 +330,16 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' f' s (PositionedDeclaration _ _ d1) = f'' s d1 f' _ _ = r0 + g'' :: s -> Expr -> r g'' s v = let (s', r) = g s v in r <> g' s' v + g' :: s -> Expr -> r + g' s (Literal l) = lit g'' s l g' s (UnaryMinus v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 g' s (Parens v1) = g'' s v1 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v - g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs) - g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs) g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs) @@ -301,42 +353,54 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' g' s (PositionedValue _ _ v1) = g'' s v1 g' _ _ = r0 + h'' :: s -> Binder -> r h'' s b = let (s', r) = h s b in r <> h' s' b + h' :: s -> Binder -> r + h' s (LiteralBinder l) = lit h'' s l h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs) h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3 h' s (ParensInBinder b) = h'' s b - h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs) - h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs) h' s (NamedBinder _ b1) = h'' s b1 h' s (PositionedBinder _ _ b1) = h'' s b1 h' s (TypedBinder _ b1) = h'' s b1 h' _ _ = r0 + lit :: (s -> a -> r) -> s -> Literal a -> r + lit go s (ArrayLiteral as) = foldl (<>) r0 (map (go s) as) + lit go s (ObjectLiteral as) = foldl (<>) r0 (map (go s . snd) as) + lit _ _ _ = r0 + + i'' :: s -> CaseAlternative -> r i'' s ca = let (s', r) = i s ca in r <> i' s' ca + i' :: s -> CaseAlternative -> r i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs) + j'' :: s -> DoNotationElement -> r j'' s e = let (s', r) = j s e in r <> j' s' e + j' :: s -> DoNotationElement -> r j' s (DoNotationValue v) = g'' s v j' s (DoNotationBind b v) = h'' s b <> g'' s v j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds) j' s (PositionedDoNotationElement _ _ e1) = j'' s e1 -everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) => - s -> - (s -> Declaration -> m (s, Declaration)) -> - (s -> Expr -> m (s, Expr)) -> - (s -> Binder -> m (s, Binder)) -> - (s -> CaseAlternative -> m (s, CaseAlternative)) -> - (s -> DoNotationElement -> m (s, DoNotationElement)) -> - ( Declaration -> m Declaration - , Expr -> m Expr - , Binder -> m Binder - , CaseAlternative -> m CaseAlternative - , DoNotationElement -> m DoNotationElement) +everywhereWithContextOnValuesM + :: forall m s + . (Functor m, Applicative m, Monad m) + => s + -> (s -> Declaration -> m (s, Declaration)) + -> (s -> Expr -> m (s, Expr)) + -> (s -> Binder -> m (s, Binder)) + -> (s -> CaseAlternative -> m (s, CaseAlternative)) + -> (s -> DoNotationElement -> m (s, DoNotationElement)) + -> ( Declaration -> m Declaration + , Expr -> m Expr + , Binder -> m Binder + , CaseAlternative -> m CaseAlternative + , DoNotationElement -> m DoNotationElement) everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0) where f'' s = uncurry f' <=< f s @@ -351,13 +415,12 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g'' s = uncurry g' <=< g s + g' s (Literal l) = Literal <$> lit g'' s l g' s (UnaryMinus v) = UnaryMinus <$> g'' s v g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2 g' s (Parens v) = Parens <$> g'' s v g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v) g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v) - g' s (ArrayLiteral vs) = ArrayLiteral <$> traverse (g'' s) vs - g' s (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g'' s)) vs g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v g' s (Accessor prop v) = Accessor prop <$> g'' s v g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs @@ -373,16 +436,20 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j h'' s = uncurry h' <=< h s + h' s (LiteralBinder l) = LiteralBinder <$> lit h'' s l h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3 h' s (ParensInBinder b) = ParensInBinder <$> h'' s b - h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs - h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs h' s (NamedBinder name b) = NamedBinder name <$> h'' s b h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b h' s (TypedBinder t b) = TypedBinder t <$> h'' s b h' _ other = return other + lit :: (s -> a -> m a) -> s -> Literal a -> m (Literal a) + lit go s (ArrayLiteral as) = ArrayLiteral <$> traverse (go s) as + lit go s (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM (go s)) as + lit _ _ other = return other + i'' s = uncurry i' <=< i s i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val @@ -394,25 +461,29 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1 -everythingWithScope :: - (Monoid r) => - (S.Set Ident -> Declaration -> r) -> - (S.Set Ident -> Expr -> r) -> - (S.Set Ident -> Binder -> r) -> - (S.Set Ident -> CaseAlternative -> r) -> - (S.Set Ident -> DoNotationElement -> r) -> - ( S.Set Ident -> Declaration -> r - , S.Set Ident -> Expr -> r - , S.Set Ident -> Binder -> r - , S.Set Ident -> CaseAlternative -> r - , S.Set Ident -> DoNotationElement -> r) +everythingWithScope + :: forall r + . (Monoid r) + => (S.Set Ident -> Declaration -> r) + -> (S.Set Ident -> Expr -> r) + -> (S.Set Ident -> Binder -> r) + -> (S.Set Ident -> CaseAlternative -> r) + -> (S.Set Ident -> DoNotationElement -> r) + -> ( S.Set Ident -> Declaration -> r + , S.Set Ident -> Expr -> r + , S.Set Ident -> Binder -> r + , S.Set Ident -> CaseAlternative -> r + , S.Set Ident -> DoNotationElement -> r + ) everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) where -- Avoid importing Data.Monoid and getting shadowed names above (<>) = mappend + f'' :: S.Set Ident -> Declaration -> r f'' s a = f s a <> f' s a + f' :: S.Set Ident -> Declaration -> r f' s (DataBindingGroupDeclaration ds) = let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds)) in foldMap (f'' s') ds @@ -431,15 +502,16 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) f' s (PositionedDeclaration _ _ d) = f'' s d f' _ _ = mempty + g'' :: S.Set Ident -> Expr -> r g'' s a = g s a <> g' s a + g' :: S.Set Ident -> Expr -> r + g' s (Literal l) = lit g'' s l g' s (UnaryMinus v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2 g' s (Parens v1) = g'' s v1 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v - g' s (ArrayLiteral vs) = foldMap (g'' s) vs - g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs @@ -460,20 +532,28 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' s (PositionedValue _ _ v1) = g'' s v1 g' _ _ = mempty + h'' :: S.Set Ident -> Binder -> r h'' s a = h s a <> h' s a + h' :: S.Set Ident -> Binder -> r + h' s (LiteralBinder l) = lit h'' s l h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3] h' s (ParensInBinder b) = h'' s b - h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs - h' s (ArrayBinder bs) = foldMap (h'' s) bs h' s (NamedBinder name b1) = h'' (S.insert name s) b1 h' s (PositionedBinder _ _ b1) = h'' s b1 h' s (TypedBinder _ b1) = h'' s b1 h' _ _ = mempty + lit :: (S.Set Ident -> a -> r) -> S.Set Ident -> Literal a -> r + lit go s (ArrayLiteral as) = foldMap (go s) as + lit go s (ObjectLiteral as) = foldMap (go s . snd) as + lit _ _ _ = mempty + + i'' :: S.Set Ident -> CaseAlternative -> r i'' s a = i s a <> i' s a + i' :: S.Set Ident -> CaseAlternative -> r i' s (CaseAlternative bs (Right val)) = let s' = S.union s (S.fromList (concatMap binderNames bs)) in foldMap (h'' s) bs <> g'' s' val @@ -481,8 +561,10 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) let s' = S.union s (S.fromList (concatMap binderNames bs)) in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs + j'' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r) j'' s a = let (s', r) = j' s a in (s', j s a <> r) + j' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r) j' s (DoNotationValue v) = (s, g'' s v) j' s (DoNotationBind b v) = let s' = S.union (S.fromList (binderNames b)) s @@ -498,7 +580,15 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) getDeclIdent (TypeDeclaration ident _) = Just ident getDeclIdent _ = Nothing -accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r) +accumTypes + :: (Monoid r) + => (Type -> r) + -> ( Declaration -> r + , Expr -> r + , Binder -> r + , CaseAlternative -> r + , DoNotationElement -> r + ) accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) where forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors) diff --git a/src/Language/PureScript/CoreFn.hs b/src/Language/PureScript/CoreFn.hs index a06840eebc..ffebd2efa7 100644 --- a/src/Language/PureScript/CoreFn.hs +++ b/src/Language/PureScript/CoreFn.hs @@ -1,17 +1,6 @@ ------------------------------------------------------------------------------ +-- | +-- The core functional representation -- --- Module : Language.PureScript.CoreFn --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | The core functional representation --- ------------------------------------------------------------------------------ - module Language.PureScript.CoreFn ( module C ) where @@ -20,7 +9,7 @@ import Language.PureScript.CoreFn.Ann as C import Language.PureScript.CoreFn.Binders as C import Language.PureScript.CoreFn.Desugar as C import Language.PureScript.CoreFn.Expr as C -import Language.PureScript.CoreFn.Literals as C +import Language.PureScript.AST.Literals as C import Language.PureScript.CoreFn.Meta as C import Language.PureScript.CoreFn.Module as C import Language.PureScript.CoreFn.Traversals as C diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index ae8a0146cc..7f6623bd58 100644 --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -5,7 +5,7 @@ -- module Language.PureScript.CoreFn.Binders where -import Language.PureScript.CoreFn.Literals +import Language.PureScript.AST.Literals import Language.PureScript.Names -- | diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 9816bc0049..9f5b4c4893 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -17,7 +17,7 @@ import Language.PureScript.AST.Traversals import Language.PureScript.CoreFn.Ann import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Expr -import Language.PureScript.CoreFn.Literals +import Language.PureScript.AST.Literals import Language.PureScript.CoreFn.Meta import Language.PureScript.CoreFn.Module import Language.PureScript.Environment @@ -88,18 +88,8 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = -- Desugars expressions from AST to CoreFn representation. -- exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann - exprToCoreFn ss com ty (A.NumericLiteral v) = - Literal (ss, com, ty, Nothing) (NumericLiteral v) - exprToCoreFn ss com ty (A.StringLiteral v) = - Literal (ss, com, ty, Nothing) (StringLiteral v) - exprToCoreFn ss com ty (A.CharLiteral v) = - Literal (ss, com, ty, Nothing) (CharLiteral v) - exprToCoreFn ss com ty (A.BooleanLiteral v) = - Literal (ss, com, ty, Nothing) (BooleanLiteral v) - exprToCoreFn ss com ty (A.ArrayLiteral vs) = - Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn ss [] Nothing) vs) - exprToCoreFn ss com ty (A.ObjectLiteral vs) = - Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn ss [] Nothing)) vs) + exprToCoreFn ss com ty (A.Literal lit) = + Literal (ss, com, ty, Nothing) (fmap (exprToCoreFn ss com Nothing) lit) exprToCoreFn ss com ty (A.Accessor name v) = Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) exprToCoreFn ss com ty (A.ObjectUpdate obj vs) = @@ -126,7 +116,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = exprToCoreFn ss com (Just ty) v exprToCoreFn ss com ty (A.Let ds v) = Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v) - exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) = + exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.Literal (A.ObjectLiteral vs)) _)) = let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name) in foldl (App (ss, com, Nothing, Nothing)) ctor args @@ -152,25 +142,15 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = -- Desugars case binders from AST to CoreFn representation. -- binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann + binderToCoreFn ss com (A.LiteralBinder lit) = + LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit) binderToCoreFn ss com (A.NullBinder) = NullBinder (ss, com, Nothing, Nothing) - binderToCoreFn ss com (A.BooleanBinder b) = - LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b) - binderToCoreFn ss com (A.StringBinder s) = - LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s) - binderToCoreFn ss com (A.CharBinder c) = - LiteralBinder (ss, com, Nothing, Nothing) (CharLiteral c) - binderToCoreFn ss com (A.NumberBinder n) = - LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n) binderToCoreFn ss com (A.VarBinder name) = VarBinder (ss, com, Nothing, Nothing) name binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) = let (_, tctor, _, _) = lookupConstructor env dctor in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs) - binderToCoreFn ss com (A.ObjectBinder bs) = - LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn ss [])) bs) - binderToCoreFn ss com (A.ArrayBinder bs) = - LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn ss []) bs) binderToCoreFn ss com (A.NamedBinder name b) = NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b) binderToCoreFn _ com (A.PositionedBinder ss com1 b) = diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index c4117d7f7d..961c70b3a3 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -8,7 +8,7 @@ module Language.PureScript.CoreFn.Expr where import Control.Arrow ((***)) import Language.PureScript.CoreFn.Binders -import Language.PureScript.CoreFn.Literals +import Language.PureScript.AST.Literals import Language.PureScript.Names -- | diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs index 91a077e9d9..613062ef25 100644 --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -1,24 +1,13 @@ ------------------------------------------------------------------------------ +-- | +-- CoreFn traversal helpers -- --- Module : Language.PureScript.CoreFn.Traversals --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | CoreFn traversal helpers --- ------------------------------------------------------------------------------ - module Language.PureScript.CoreFn.Traversals where import Control.Arrow (second, (***), (+++)) import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Expr -import Language.PureScript.CoreFn.Literals +import Language.PureScript.AST.Literals everywhereOnValues :: (Bind a -> Bind a) -> (Expr a -> Expr a) -> diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 8ccfc6e184..b2f914ca6e 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -24,6 +24,7 @@ import Control.Monad.Writer.Class import Language.PureScript.Crash import Language.PureScript.AST.Binders +import Language.PureScript.AST.Literals import Language.PureScript.AST.Declarations import Language.PureScript.Environment import Language.PureScript.Names as P @@ -119,12 +120,12 @@ missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) = missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs') | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr) | otherwise = ([cb], return False) -missingCasesSingle env mn NullBinder (ObjectBinder bs) = - (map (ObjectBinder . zip (map fst bs)) allMisses, pr) +missingCasesSingle env mn NullBinder (LiteralBinder (ObjectLiteral bs)) = + (map (LiteralBinder . ObjectLiteral . zip (map fst bs)) allMisses, pr) where (allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs) -missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') = - (map (ObjectBinder . zip sortedNames) allMisses, pr) +missingCasesSingle env mn (LiteralBinder (ObjectLiteral bs)) (LiteralBinder (ObjectLiteral bs')) = + (map (LiteralBinder . ObjectLiteral . zip sortedNames) allMisses, pr) where (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders) @@ -141,10 +142,10 @@ missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') = compBS e s b b' = (s, compB e b b') (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs' -missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], return True) -missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br) +missingCasesSingle _ _ NullBinder (LiteralBinder (BooleanLiteral b)) = ([LiteralBinder . BooleanLiteral $ not b], return True) +missingCasesSingle _ _ (LiteralBinder (BooleanLiteral bl)) (LiteralBinder (BooleanLiteral br)) | bl == br = ([], return True) - | otherwise = ([BooleanBinder bl], return False) + | otherwise = ([LiteralBinder $ BooleanLiteral bl], return False) missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb missingCasesSingle _ _ b _ = ([b], Left Unknown) @@ -201,7 +202,7 @@ isExhaustiveGuard :: Either [(Guard, Expr)] Expr -> Bool isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs where isOtherwise :: Expr -> Bool - isOtherwise (BooleanLiteral True) = True + isOtherwise (Literal (BooleanLiteral True)) = True isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True isOtherwise (TypedValue _ e _) = isOtherwise e @@ -274,8 +275,8 @@ checkExhaustiveDecls env mn = mapM_ onDecl onExpr :: Bool -> Expr -> m () onExpr isP (UnaryMinus e) = onExpr isP e - onExpr isP (ArrayLiteral es) = mapM_ (onExpr isP) es - onExpr isP (ObjectLiteral es) = mapM_ (onExpr isP . snd) es + onExpr isP (Literal (ArrayLiteral es)) = mapM_ (onExpr isP) es + onExpr isP (Literal (ObjectLiteral es)) = mapM_ (onExpr isP . snd) es onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e onExpr isP (Accessor _ e) = onExpr isP e onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index c6e9ad464c..839cd363c3 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -299,23 +299,23 @@ parseModules = mark (P.many (same *> parseModule)) <* P.eof booleanLiteral :: TokenParser Bool booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False) -parseNumericLiteral :: TokenParser Expr +parseNumericLiteral :: TokenParser (Literal a) parseNumericLiteral = NumericLiteral <$> number -parseCharLiteral :: TokenParser Expr +parseCharLiteral :: TokenParser (Literal a) parseCharLiteral = CharLiteral <$> charLiteral -parseStringLiteral :: TokenParser Expr +parseStringLiteral :: TokenParser (Literal a) parseStringLiteral = StringLiteral <$> stringLiteral -parseBooleanLiteral :: TokenParser Expr +parseBooleanLiteral :: TokenParser (Literal a) parseBooleanLiteral = BooleanLiteral <$> booleanLiteral -parseArrayLiteral :: TokenParser Expr -parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue) +parseArrayLiteral :: TokenParser a -> TokenParser (Literal a) +parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p) -parseObjectLiteral :: TokenParser Expr -parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue) +parseObjectLiteral :: TokenParser (String, a) -> TokenParser (Literal a) +parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p) parseIdentifierAndValue :: TokenParser (String, Expr) parseIdentifierAndValue = @@ -376,12 +376,12 @@ parseLet = do parseValueAtom :: TokenParser Expr parseValueAtom = P.choice [ parseAnonymousArgument - , parseNumericLiteral - , parseCharLiteral - , parseStringLiteral - , parseBooleanLiteral - , parseArrayLiteral - , P.try parseObjectLiteral + , Literal <$> parseNumericLiteral + , Literal <$> parseCharLiteral + , Literal <$> parseStringLiteral + , Literal <$> parseBooleanLiteral + , Literal <$> parseArrayLiteral parseValue + , Literal <$> P.try (parseObjectLiteral parseIdentifierAndValue) , parseAbs , P.try parseConstructor , P.try parseVar @@ -469,17 +469,8 @@ parseUpdaterBody v = ObjectUpdate v <$> (C.indented *> braces (commaSep1 (C.inde parseAnonymousArgument :: TokenParser Expr parseAnonymousArgument = underscore *> pure AnonymousArgument -parseStringBinder :: TokenParser Binder -parseStringBinder = StringBinder <$> stringLiteral - -parseCharBinder :: TokenParser Binder -parseCharBinder = CharBinder <$> charLiteral - -parseBooleanBinder :: TokenParser Binder -parseBooleanBinder = BooleanBinder <$> booleanLiteral - -parseNumberBinder :: TokenParser Binder -parseNumberBinder = NumberBinder <$> (sign <*> number) +parseNumberLiteral :: TokenParser Binder +parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number) where sign :: TokenParser (Either Integer Double -> Either Integer Double) sign = (symbol' "-" >> return (negate +++ negate)) @@ -492,11 +483,11 @@ parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properN parseConstructorBinder :: TokenParser Binder parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens) -parseObjectBinder :: TokenParser Binder -parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdentifierAndBinder)) +parseObjectBinder:: TokenParser Binder +parseObjectBinder= LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder) parseArrayBinder :: TokenParser Binder -parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder) +parseArrayBinder = LiteralBinder <$> parseArrayLiteral (C.indented *> parseBinder) parseVarOrNamedBinder :: TokenParser Binder parseVarOrNamedBinder = do @@ -541,10 +532,10 @@ parseBinder = parseBinderAtom :: TokenParser Binder parseBinderAtom = P.choice [ parseNullBinder - , parseCharBinder - , parseStringBinder - , parseBooleanBinder - , parseNumberBinder + , LiteralBinder <$> parseCharLiteral + , LiteralBinder <$> parseStringLiteral + , LiteralBinder <$> parseBooleanLiteral + , parseNumberLiteral , parseVarOrNamedBinder , parseConstructorBinder , parseObjectBinder @@ -561,10 +552,10 @@ parseBinder = parseBinderNoParens :: TokenParser Binder parseBinderNoParens = P.choice [ parseNullBinder - , parseCharBinder - , parseStringBinder - , parseBooleanBinder - , parseNumberBinder + , LiteralBinder <$> parseCharLiteral + , LiteralBinder <$> parseStringLiteral + , LiteralBinder <$> parseBooleanLiteral + , parseNumberLiteral , parseVarOrNamedBinder , parseNullaryConstructorBinder , parseObjectBinder diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index b1ab730e42..e5a04e8804 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -1,18 +1,6 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Pretty.Values --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Pretty printer for values -- ------------------------------------------------------------------------------ - module Language.PureScript.Pretty.Values ( prettyPrintValue, prettyPrintBinder, @@ -75,12 +63,7 @@ prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">" prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val -prettyPrintValue d expr@NumericLiteral{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@StringLiteral{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@CharLiteral{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@BooleanLiteral{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@ArrayLiteral{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@ObjectLiteral{} = prettyPrintValueAtom d expr +prettyPrintValue d (Literal l) = prettyPrintLiteralValue d l prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr @@ -92,13 +75,7 @@ prettyPrintValue d expr@ObjectGetter{} = prettyPrintValueAtom d expr -- | Pretty-print an atomic expression, adding parentheses if necessary. prettyPrintValueAtom :: Int -> Expr -> Box -prettyPrintValueAtom _ (NumericLiteral n) = text $ either show show n -prettyPrintValueAtom _ (StringLiteral s) = text $ show s -prettyPrintValueAtom _ (CharLiteral c) = text $ show c -prettyPrintValueAtom _ (BooleanLiteral True) = text "true" -prettyPrintValueAtom _ (BooleanLiteral False) = text "false" -prettyPrintValueAtom d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs -prettyPrintValueAtom d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps +prettyPrintValueAtom d (Literal l) = prettyPrintLiteralValue d l prettyPrintValueAtom _ AnonymousArgument = text "_" prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name) prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident) @@ -116,6 +93,15 @@ prettyPrintValueAtom d (UnaryMinus expr) = text "(-" <> prettyPrintValue d expr prettyPrintValueAtom _ (ObjectGetter field) = text "_." <> text field prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")" +prettyPrintLiteralValue :: Int -> Literal Expr -> Box +prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n +prettyPrintLiteralValue _ (StringLiteral s) = text $ show s +prettyPrintLiteralValue _ (CharLiteral c) = text $ show c +prettyPrintLiteralValue _ (BooleanLiteral True) = text "true" +prettyPrintLiteralValue _ (BooleanLiteral False) = text "false" +prettyPrintLiteralValue d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs +prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps + prettyPrintDeclaration :: Int -> Declaration -> Box prettyPrintDeclaration d _ | d < 0 = ellipsis prettyPrintDeclaration _ (TypeDeclaration ident ty) = @@ -160,32 +146,35 @@ prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrin prettyPrintBinderAtom :: Binder -> String prettyPrintBinderAtom NullBinder = "_" -prettyPrintBinderAtom (StringBinder str) = show str -prettyPrintBinderAtom (CharBinder c) = show c -prettyPrintBinderAtom (NumberBinder num) = either show show num -prettyPrintBinderAtom (BooleanBinder True) = "true" -prettyPrintBinderAtom (BooleanBinder False) = "false" +prettyPrintBinderAtom (LiteralBinder l) = prettyPrintLiteralBinder l prettyPrintBinderAtom (VarBinder ident) = showIdent ident prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor) prettyPrintBinderAtom b@ConstructorBinder{} = parens (prettyPrintBinder b) -prettyPrintBinderAtom (ObjectBinder bs) = +prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder +prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder +prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder +prettyPrintBinderAtom (OpBinder op) = showIdent (disqualify op) +prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) = + prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2 +prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b) + +prettyPrintLiteralBinder :: Literal Binder -> String +prettyPrintLiteralBinder (StringLiteral str) = show str +prettyPrintLiteralBinder (CharLiteral c) = show c +prettyPrintLiteralBinder (NumericLiteral num) = either show show num +prettyPrintLiteralBinder (BooleanLiteral True) = "true" +prettyPrintLiteralBinder (BooleanLiteral False) = "false" +prettyPrintLiteralBinder (ObjectLiteral bs) = "{ " ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs) ++ " }" where prettyPrintObjectPropertyBinder :: (String, Binder) -> String prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder -prettyPrintBinderAtom (ArrayBinder bs) = +prettyPrintLiteralBinder (ArrayLiteral bs) = "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]" -prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder -prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder -prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder -prettyPrintBinderAtom (OpBinder op) = showIdent (disqualify op) -prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) = - prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2 -prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b) -- | -- Generate a pretty-printed string representing a Binder diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 2e84f087bf..a2bb574ecc 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -19,7 +19,11 @@ import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Names -desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module +desugarObjectConstructors + :: forall m + . (Applicative m, MonadSupply m, MonadError MultipleErrors m) + => Module + -> m Module desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts where @@ -38,7 +42,7 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma | b' <- stripPositionInfo b , BinaryNoParens op u val <- b' , isAnonymousArgument u = return $ OperatorSection op (Right val) - desugarExpr (ObjectLiteral ps) = wrapLambda ObjectLiteral ps + desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do obj <- freshIdent' Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 03a7324f40..d0cf61fd22 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -297,7 +297,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs ] - let props = ObjectLiteral (members ++ superclasses) + let props = Literal $ ObjectLiteral (members ++ superclasses) dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy) dict = TypeClassDictionaryConstructorApp className props diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 6a9344cf77..404e2a7f3f 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -115,15 +115,21 @@ deriveGeneric mn ds tyConNm dargs = do return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents)) where caseResult idents = - App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName)) - . ArrayLiteral + App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName)) + . Literal . ArrayLiteral $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys toSpineFun :: Expr -> Type -> Expr toSpineFun i r | Just rec <- objectType r = - lamNull . recordConstructor . ArrayLiteral . - map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)]) - $ decomposeRec rec + lamNull . recordConstructor . Literal . ArrayLiteral + . map + (\(str,typ) -> + Literal $ ObjectLiteral + [ ("recLabel", Literal (StringLiteral str)) + , ("recValue", toSpineFun (Accessor str i) typ) + ] + ) + $ decomposeRec rec toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration" @@ -132,30 +138,37 @@ deriveGeneric mn ds tyConNm dargs = do mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args where mkSigProd :: [Expr] -> Expr - mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) - (StringLiteral (showQualified runProperName (Qualified (Just mn) name))) - ) . ArrayLiteral + mkSigProd = + App + (App + (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) + (Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) name)))) + ) + . Literal + . ArrayLiteral mkSigRec :: [Expr] -> Expr - mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral + mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . Literal . ArrayLiteral proxy :: Type -> Type proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy"))) mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr mkProdClause (ctorName, tys) = - ObjectLiteral - [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))) - , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys) + Literal $ ObjectLiteral + [ ("sigConstructor", Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))) + , ("sigValues", Literal . ArrayLiteral . map (mkProductSignature . instantiate) $ tys) ] mkProductSignature :: Type -> Expr mkProductSignature r | Just rec <- objectType r = - lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str) - , ("recValue", mkProductSignature typ) - ] - | (str, typ) <- decomposeRec rec - ] + lamNull . mkSigRec $ + [ Literal $ ObjectLiteral + [ ("recLabel", Literal (StringLiteral str)) + , ("recValue", mkProductSignature typ) + ] + | (str, typ) <- decomposeRec rec + ] mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature)) (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ)) instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs) @@ -182,10 +195,17 @@ deriveGeneric mn ds tyConNm dargs = do mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative mkAlternative (ctorName, tys) = do idents <- replicateM (length tys) freshIdent' - return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]] - . Right - $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName)) - (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys) + return $ + CaseAlternative + [ prodBinder + [ LiteralBinder (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))) + , LiteralBinder (ArrayLiteral (map VarBinder idents)) + ] + ] + . Right + $ liftApplicative + (mkJust $ Constructor (Qualified (Just mn) ctorName)) + (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys) addCatch :: [CaseAlternative] -> [CaseAlternative] addCatch = (++ [catchAll]) @@ -202,15 +222,15 @@ deriveGeneric mn ds tyConNm dargs = do fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit"))) mkRecCase :: [(String, Type)] -> CaseAlternative - mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs) - ] - ] - . Right - $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs) + mkRecCase rs = + CaseAlternative + [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . Ident . fst) rs)) ] ] + . Right + $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs) mkRecFun :: [(String, Type)] -> Expr mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs) - where recLiteral = ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs + where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration" @@ -255,7 +275,7 @@ deriveEq mn ds tyConNm = do | length xs /= 1 = xs ++ [catchAll] | otherwise = xs -- Avoid redundant case where - catchAll = CaseAlternative [NullBinder, NullBinder] (Right (BooleanLiteral False)) + catchAll = CaseAlternative [NullBinder, NullBinder] (Right (Literal (BooleanLiteral False))) mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative mkCtorClause (ctorName, tys) = do @@ -267,7 +287,7 @@ deriveEq mn ds tyConNm = do caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents) conjAll :: [Expr] -> Expr - conjAll [] = BooleanLiteral True + conjAll [] = Literal (BooleanLiteral True) conjAll xs = foldl1 preludeConj xs toEqTest :: Expr -> Expr -> Type -> Expr diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 74bd82fd58..e9646f34d1 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -217,22 +217,22 @@ infer' :: (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> m Expr -infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt -infer' v@(NumericLiteral (Right _)) = return $ TypedValue True v tyNumber -infer' v@(StringLiteral _) = return $ TypedValue True v tyString -infer' v@(CharLiteral _) = return $ TypedValue True v tyChar -infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean -infer' (ArrayLiteral vals) = do +infer' v@(Literal (NumericLiteral (Left _))) = return $ TypedValue True v tyInt +infer' v@(Literal (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber +infer' v@(Literal (StringLiteral _)) = return $ TypedValue True v tyString +infer' v@(Literal (CharLiteral _)) = return $ TypedValue True v tyChar +infer' v@(Literal (BooleanLiteral _)) = return $ TypedValue True v tyBoolean +infer' (Literal (ArrayLiteral vals)) = do ts <- traverse infer vals els <- freshType forM_ ts $ \(TypedValue _ _ t) -> unifyTypes els t - return $ TypedValue True (ArrayLiteral ts) (TypeApp tyArray els) -infer' (ObjectLiteral ps) = do + return $ TypedValue True (Literal (ArrayLiteral ts)) (TypeApp tyArray els) +infer' (Literal (ObjectLiteral ps)) = do ensureNoDuplicateProperties ps ts <- traverse (infer . snd) ps let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts ty = TypeApp tyObject $ rowFromList (fields, REmpty) - return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty + return $ TypedValue True (Literal (ObjectLiteral (zip (map fst ps) ts))) ty infer' (ObjectUpdate o ps) = do ensureNoDuplicateProperties ps row <- freshType @@ -346,11 +346,11 @@ inferBinder :: forall m. Binder -> m (M.Map Ident Type) inferBinder _ NullBinder = return M.empty -inferBinder val (StringBinder _) = unifyTypes val tyString >> return M.empty -inferBinder val (CharBinder _) = unifyTypes val tyChar >> return M.empty -inferBinder val (NumberBinder (Left _)) = unifyTypes val tyInt >> return M.empty -inferBinder val (NumberBinder (Right _)) = unifyTypes val tyNumber >> return M.empty -inferBinder val (BooleanBinder _) = unifyTypes val tyBoolean >> return M.empty +inferBinder val (LiteralBinder (StringLiteral _)) = unifyTypes val tyString >> return M.empty +inferBinder val (LiteralBinder (CharLiteral _)) = unifyTypes val tyChar >> return M.empty +inferBinder val (LiteralBinder (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty +inferBinder val (LiteralBinder (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty +inferBinder val (LiteralBinder (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty inferBinder val (VarBinder name) = return $ M.singleton name val inferBinder val (ConstructorBinder ctor binders) = do env <- getEnv @@ -369,7 +369,7 @@ inferBinder val (ConstructorBinder ctor binders) = do where go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret go args ret = (args, ret) -inferBinder val (ObjectBinder props) = do +inferBinder val (LiteralBinder (ObjectLiteral props)) = do row <- freshType rest <- freshType m1 <- inferRowProperties row rest props @@ -383,7 +383,7 @@ inferBinder val (ObjectBinder props) = do m1 <- inferBinder propTy binder m2 <- inferRowProperties nrow (RCons name propTy row) binders return $ m1 `M.union` m2 -inferBinder val (ArrayBinder binders) = do +inferBinder val (LiteralBinder (ArrayLiteral binders)) = do el <- freshType m1 <- M.unions <$> traverse (inferBinder el) binders unifyTypes val (TypeApp tyArray el) @@ -524,19 +524,19 @@ check' val u@(TUnknown _) = do (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty unifyTypes ty' u return $ TypedValue True val'' ty' -check' v@(NumericLiteral (Left _)) t | t == tyInt = +check' v@(Literal (NumericLiteral (Left _))) t | t == tyInt = return $ TypedValue True v t -check' v@(NumericLiteral (Right _)) t | t == tyNumber = +check' v@(Literal (NumericLiteral (Right _))) t | t == tyNumber = return $ TypedValue True v t -check' v@(StringLiteral _) t | t == tyString = +check' v@(Literal (StringLiteral _)) t | t == tyString = return $ TypedValue True v t -check' v@(CharLiteral _) t | t == tyChar = +check' v@(Literal (CharLiteral _)) t | t == tyChar = return $ TypedValue True v t -check' v@(BooleanLiteral _) t | t == tyBoolean = +check' v@(Literal (BooleanLiteral _)) t | t == tyBoolean = return $ TypedValue True v t -check' (ArrayLiteral vals) t@(TypeApp a ty) = do +check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do unifyTypes a tyArray - array <- ArrayLiteral <$> forM vals (`check` ty) + array <- Literal . ArrayLiteral <$> forM vals (`check` ty) return $ TypedValue True array t check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do unifyTypes t tyFunction @@ -587,10 +587,10 @@ check' (IfThenElse cond th el) ty = do th' <- check th ty el' <- check el ty return $ TypedValue True (IfThenElse cond' th' el') ty -check' e@(ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do +check' e@(Literal (ObjectLiteral ps)) t@(TypeApp obj row) | obj == tyObject = do ensureNoDuplicateProperties ps ps' <- checkProperties e ps row False - return $ TypedValue True (ObjectLiteral ps') t + return $ TypedValue True (Literal (ObjectLiteral ps')) t check' (TypeClassDictionaryConstructorApp name ps) t = do ps' <- check' ps t return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t From 40aaca79ab08fe0170ebe27ff1b1fc05087ec28e Mon Sep 17 00:00:00 2001 From: Petr Date: Tue, 8 Mar 2016 16:10:32 +0100 Subject: [PATCH 0321/1580] Update CONTRIBUTORS.md --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 46867ac9d1..6e334162bb 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -9,6 +9,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@anthok88](https://github.com/anthoq88) - My existing contributions and all future contributions until further notice are Copyright anthoq88, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license - [@ardumont](https://github.com/ardumont) (Antoine R. Dumont) My existing contributions and all future contributions until further notice are Copyright Antoine R. Dumont, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@aspidites](https://github.com/aspidites) (Edwin Marshall) My existing contributions and all future contributions until further notice are Copyright Edwin Marshall, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@bagl](https://github.com/bagl) (Petr Vapenka) My existing contributions and all future contributions until further notice are Copyright Petr Vapenka, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@balajirrao](https://github.com/balajirrao) (Balaji Rao) - My existing contributions and all future contributions until further notice are Copyright Balaji Rao, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@bergmark](https://github.com/bergmark) (Adam Bergmark) - My existing contributions and all future contributions until further notice are Copyright Adam Bergmark, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@Bogdanp](https://github.com/Bogdanp) (Bogdan Paul Popa) My existing contributions and all future contributions until further notice are Copyright Bogdan Paul Popa, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). From 8baa6ddadc6f277dc3b57f46505aca1a2ea1aad6 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 8 Mar 2016 23:28:43 +0000 Subject: [PATCH 0322/1580] Drop support for GHC 7.8 and older Resolves #1919 * Bump minimum `base` version bound in purescript.cabal so that GHC 7.8 and older get errors at dependency resolution time instead of compile time * Update "tested-with" section in purescript.cabal * Update minimum supported version to GHC 7.10.1 in INSTALL.md. * Use --resolver=nightly for the suggested stack install command (the latest lts release is often out of date and unsupported) * Remove the travis builds which use GHC < 7.10. We will also need to update http://www.purescript.org/download/. I think that's everything. --- .travis.yml | 7 ------- INSTALL.md | 12 ++++-------- purescript.cabal | 4 ++-- 3 files changed, 6 insertions(+), 17 deletions(-) diff --git a/.travis.yml b/.travis.yml index e80e4c0eae..43f6415cbb 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,13 +2,6 @@ language: c sudo: false matrix: include: - - env: GHCVER=7.8.4 CABALVER=1.22 COVERAGE=true - compiler: ": #GHC 7.8.4 - tests" - # ^ HACK before https://github.com/travis-ci/travis-ci/issues/4393 is resolved - addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.6.3 CABALVER=1.22 - compiler: ": #GHC 7.6.3" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.6.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - env: GHCVER=7.10.1 CABALVER=1.22 DEPLOY=yes compiler: ": #GHC 7.10.1" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} diff --git a/INSTALL.md b/INSTALL.md index c58652f0b5..210a8fa123 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -6,8 +6,8 @@ alternatively Stack Overflow. ## Using prebuilt binaries -The prebuilt binaries are compiled with GHC 7.8.4, and therefore they should -run on any operating system supported by GHC 7.8.4, such as: +The prebuilt binaries are compiled with GHC 7.10.1, and therefore they should +run on any operating system supported by GHC 7.10.1, such as: * Windows 2000 or later, * OS X 10.7 or later, @@ -23,11 +23,11 @@ requirements. ## Compiling from source -GHC 7.6.1 or newer is required to compile from source. The easiest way is to +GHC 7.10.1 or newer is required to compile from source. The easiest way is to use stack: ``` -$ stack install --resolver lts purescript +$ stack install --resolver=nightly purescript ``` This will then copy the compiler and utilities into `~/.local/bin`. @@ -39,10 +39,6 @@ If you don't have stack installed yet there are install instructions If you don't have ghc installed yet, stack will prompt you to run `stack setup` which will install ghc for you. -The PureScript compiler has been known to run on OS X 10.6 when built with GHC -7.6. - - ## The "curses" library `psci` depends on the `curses` library (via the Haskell package `terminfo`). If diff --git a/purescript.cabal b/purescript.cabal index 7f9e5ff648..508efefe13 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -17,7 +17,7 @@ author: Phil Freeman , Harry Garrood , Christoph Hegemann -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1 +tested-with: GHC==7.10.1, GHC==7.10.2, GHC==7.10.3 extra-source-files: examples/passing/*.purs , examples/failing/*.purs @@ -49,7 +49,7 @@ source-repository head location: https://github.com/purescript/purescript.git library - build-depends: base >=4.6 && <5, + build-depends: base >=4.8 && <5, base-compat >=0.6.0, lifted-base >= 0.2.3 && < 0.2.4, monad-control >= 1.0.0.0 && < 1.1, From 794d45e871af18597cba0d64bac3069ec149d12f Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 8 Mar 2016 23:40:14 +0000 Subject: [PATCH 0323/1580] Remove support for stack LTS 3 and older * Remove the Travis lts-3 build * Remove the stack.yaml files for lts-2 and lts-3. * Update tested-with in purescript.cabal now that we no longer test on GHC 7.10.2 --- .travis.yml | 3 --- purescript.cabal | 5 ++--- stack-lts-2.yaml | 13 ------------- stack-lts-3.yaml | 6 ------ 4 files changed, 2 insertions(+), 25 deletions(-) delete mode 100644 stack-lts-2.yaml delete mode 100644 stack-lts-3.yaml diff --git a/.travis.yml b/.travis.yml index 43f6415cbb..8616c77821 100644 --- a/.travis.yml +++ b/.travis.yml @@ -5,9 +5,6 @@ matrix: - env: GHCVER=7.10.1 CABALVER=1.22 DEPLOY=yes compiler: ": #GHC 7.10.1" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.10.2 CABALVER=1.22 STACKAGE=lts-3.22 RUNSDISTTESTS=YES - compiler: ": #GHC 7.10.2 lts-3.22" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - env: GHCVER=7.10.3 CABALVER=1.22 STACKAGE=lts-5.4 RUNSDISTTESTS=YES compiler: ": #GHC 7.10.3 lts-5.4" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} diff --git a/purescript.cabal b/purescript.cabal index 508efefe13..055017735f 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -17,7 +17,7 @@ author: Phil Freeman , Harry Garrood , Christoph Hegemann -tested-with: GHC==7.10.1, GHC==7.10.2, GHC==7.10.3 +tested-with: GHC==7.10.1, GHC==7.10.3 extra-source-files: examples/passing/*.purs , examples/failing/*.purs @@ -36,8 +36,7 @@ extra-source-files: examples/passing/*.purs , tests/support/flattened/*.js , tests/support/psci/*.purs , stack.yaml - , stack-lts-2.yaml - , stack-lts-3.yaml + , stack-lts-5.yaml , stack-nightly.yaml , README.md , INSTALL.md diff --git a/stack-lts-2.yaml b/stack-lts-2.yaml deleted file mode 100644 index 49a6a68088..0000000000 --- a/stack-lts-2.yaml +++ /dev/null @@ -1,13 +0,0 @@ -resolver: lts-2.22 -packages: -- '.' -extra-deps: -- aeson-better-errors-0.8.0 -- bower-json-0.7.0.0 -- boxes-0.1.4 -- pattern-arrows-0.0.2 -- sourcemap-0.1.6 -- fsnotify-0.2.1 -- hfsevents-0.1.6 -- pipes-http-1.0.2 -flags: {} diff --git a/stack-lts-3.yaml b/stack-lts-3.yaml deleted file mode 100644 index 69f14a9168..0000000000 --- a/stack-lts-3.yaml +++ /dev/null @@ -1,6 +0,0 @@ -resolver: lts-3.22 -packages: -- '.' -extra-deps: -- sourcemap-0.1.6 -flags: {} From eada392ad9032c0d85c679a2c87d7c0ece456480 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 9 Mar 2016 19:16:33 +0000 Subject: [PATCH 0324/1580] Use GHC 7.10.3 for compiling release binaries --- .travis.yml | 5 +---- INSTALL.md | 4 ++-- purescript.cabal | 2 +- 3 files changed, 4 insertions(+), 7 deletions(-) diff --git a/.travis.yml b/.travis.yml index 8616c77821..131f162114 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,16 +2,13 @@ language: c sudo: false matrix: include: - - env: GHCVER=7.10.1 CABALVER=1.22 DEPLOY=yes - compiler: ": #GHC 7.10.1" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - env: GHCVER=7.10.3 CABALVER=1.22 STACKAGE=lts-5.4 RUNSDISTTESTS=YES compiler: ": #GHC 7.10.3 lts-5.4" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - env: GHCVER=7.10.3 CABALVER=1.22 STACKAGE=nightly-2016-02-25 compiler: ": #GHC 7.10.3 nightly-2016-02-25" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.10.3 CABALVER=1.22 + - env: GHCVER=7.10.3 CABALVER=1.22 DEPLOY=yes compiler: ": #GHC 7.10.3" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} before_install: diff --git a/INSTALL.md b/INSTALL.md index 210a8fa123..4414a13c2e 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -6,8 +6,8 @@ alternatively Stack Overflow. ## Using prebuilt binaries -The prebuilt binaries are compiled with GHC 7.10.1, and therefore they should -run on any operating system supported by GHC 7.10.1, such as: +The prebuilt binaries are compiled with GHC 7.10.3, and therefore they should +run on any operating system supported by GHC 7.10.3, such as: * Windows 2000 or later, * OS X 10.7 or later, diff --git a/purescript.cabal b/purescript.cabal index 055017735f..941b9207da 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -17,7 +17,7 @@ author: Phil Freeman , Harry Garrood , Christoph Hegemann -tested-with: GHC==7.10.1, GHC==7.10.3 +tested-with: GHC==7.10.3 extra-source-files: examples/passing/*.purs , examples/failing/*.purs From d6a02ca44c64458465dae60b18a561c19b432f6a Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Thu, 10 Mar 2016 01:38:56 +0100 Subject: [PATCH 0325/1580] lots of formatting. The "real" change in this commit is getting rid of the partial accessor functions that @hdgarrod pointed out in PureScript.Ide.Types. --- src/Language/PureScript/Ide/CaseSplit.hs | 9 -- src/Language/PureScript/Ide/Completion.hs | 8 +- src/Language/PureScript/Ide/Error.hs | 23 ++-- src/Language/PureScript/Ide/Matcher.hs | 12 +- src/Language/PureScript/Ide/Pursuit.hs | 22 ++-- src/Language/PureScript/Ide/Reexports.hs | 40 +++--- src/Language/PureScript/Ide/SourceFile.hs | 73 ++++++----- src/Language/PureScript/Ide/State.hs | 6 +- src/Language/PureScript/Ide/Types.hs | 152 +++++++++++----------- 9 files changed, 168 insertions(+), 177 deletions(-) diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 83dbeab2af..af2d680432 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -60,15 +60,6 @@ caseSplit q = do let appliedCtors = map (\(n, ts) -> (n, map applyTypeVars ts)) ctors pure appliedCtors -{- ["EDType { - edTypeName = ProperName {runProperName = \"Either\"} - , edTypeKind = FunKind Star (FunKind Star Star) - , edTypeDeclarationKind = - DataType [(\"a\",Just Star),(\"b\",Just Star)] - [(ProperName {runProperName = \"Left\"},[TypeVar \"a\"]) - ,(ProperName {runProperName = \"Right\"},[TypeVar \"b\"])]}"] --} - findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => ProperName 'TypeName -> m ExternsDeclaration findTypeDeclaration q = do diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index d0430ad23a..c81306680a 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -24,12 +24,12 @@ getExactMatches search filters modules = completionsFromModules :: [Module] -> [Completion] completionsFromModules = foldMap completionFromModule - where - completionFromModule :: Module -> [Completion] - completionFromModule (moduleIdent, decls) = mapMaybe (completionFromDecl moduleIdent) decls + where + completionFromModule :: Module -> [Completion] + completionFromModule (moduleIdent, decls) = mapMaybe (completionFromDecl moduleIdent) decls completionFromDecl :: ModuleIdent -> ExternDecl -> Maybe Completion completionFromDecl mi (FunctionDecl name type') = Just (Completion (mi, name, type')) completionFromDecl mi (DataDecl name kind) = Just (Completion (mi, name, kind)) -completionFromDecl _ (ModuleDecl name _) = Just (Completion ("module", name, "module")) +completionFromDecl _ (ModuleDecl name _) = Just (Completion ("module", name, "module")) completionFromDecl _ _ = Nothing diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 9b5d1fb00e..02812111b2 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -21,21 +21,20 @@ data PscIdeError instance ToJSON PscIdeError where toJSON err = object - [ - "resultType" .= ("error" :: Text), - "result" .= textError err - ] + [ "resultType" .= ("error" :: Text) + , "result" .= textError err + ] textError :: PscIdeError -> Text -textError (GeneralError msg) = pack msg -textError (NotFound ident) = "Symbol '" <> ident <> "' not found." -textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found." -textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found" -textError (ParseError parseError msg) = pack $ msg <> ": " <> show (escape parseError) - where +textError (GeneralError msg) = pack msg +textError (NotFound ident) = "Symbol '" <> ident <> "' not found." +textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found." +textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found" +textError (ParseError parseError msg) = pack $ msg <> ": " <> show (escape parseError) + where -- escape newlines and other special chars so we can send the error over the socket as a single line - escape :: P.ParseError -> String - escape = show + escape :: P.ParseError -> String + escape = show -- | Specialized version of `first` from `Data.Bifunctors` first :: (a -> b) -> Either a r -> Either b r diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index cb92cc3e33..56a8138d63 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -76,8 +76,8 @@ flexMatch pattern = mapMaybe (flexRate pattern) flexRate :: Text -> Completion -> Maybe ScoredCompletion flexRate pattern c@(Completion (_,ident,_)) = do - score <- flexScore pattern ident - return (c, score) + score <- flexScore pattern ident + return (c, score) -- FlexMatching ala Sublime. -- Borrowed from: http://cdewaka.com/2013/06/fuzzy-pattern-matching-in-haskell/ @@ -88,13 +88,13 @@ flexRate pattern c@(Completion (_,ident,_)) = do flexScore :: Text -> DeclIdent -> Maybe Double flexScore "" _ = Nothing flexScore pat str = - case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of - (-1,0) -> Nothing - (start,len) -> Just $ calcScore start (start + len) + case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of + (-1,0) -> Nothing + (start,len) -> Just $ calcScore start (start + len) where Just (first,pattern) = T.uncons pat -- This just interleaves the search string with .* -- abcd -> a.*b.*c.*d pat' = first `T.cons` T.concatMap (T.snoc ".*") pattern calcScore start end = - 100.0 / fromIntegral ((1 + start) * (end - start + 1)) + 100.0 / fromIntegral ((1 + start) * (end - start + 1)) diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs index 8a6987d3a6..ed401f4f50 100644 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -10,9 +10,9 @@ import qualified Control.Exception as E import Data.Aeson import Data.ByteString (ByteString) import Data.ByteString.Lazy (fromStrict) -import Data.Foldable (toList) +import Data.Foldable (toList) +import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) -import Data.Maybe (mapMaybe) import Data.String import Data.Text (Text) import qualified Data.Text as T @@ -33,12 +33,12 @@ queryPursuit q = do } m <- newManager tlsManagerSettings withHTTP req m $ \resp -> - P.fold (\x a -> x <> a) "" id $ responseBody resp + P.fold (<>) "" id $ responseBody resp handler :: HttpException -> IO [a] -handler StatusCodeException{} = return [] -handler _ = return [] +handler StatusCodeException{} = pure [] +handler _ = pure [] searchPursuitForDeclarations :: Text -> IO [PursuitResponse] searchPursuitForDeclarations query = @@ -54,12 +54,12 @@ searchPursuitForDeclarations query = findPackagesForModuleIdent :: Text -> IO [PursuitResponse] findPackagesForModuleIdent query = - (do r <- queryPursuit query - let results' = decode (fromStrict r) :: Maybe Array - case results' of - Nothing -> pure [] - Just results -> pure (mapMaybe isModuleResponse (map fromJSON (toList results)))) `E.catch` - handler + (do r <- queryPursuit query + let results' = decode (fromStrict r) :: Maybe Array + case results' of + Nothing -> pure [] + Just results -> pure (mapMaybe isModuleResponse (map fromJSON (toList results)))) `E.catch` + handler where isModuleResponse (Success a@ModuleResponse{}) = Just a isModuleResponse _ = Nothing diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 8831e777a4..fa00f5652f 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -15,10 +15,10 @@ import Language.PureScript.Ide.Types getReexports :: Module -> [ExternDecl] getReexports (mn, decls)= concatMap getExport decls - where getExport d - | (Export mn') <- d - , mn /= mn' = replaceExportWithAliases decls mn' - | otherwise = [] + where getExport d + | (Export mn') <- d + , mn /= mn' = replaceExportWithAliases decls mn' + | otherwise = [] dependencyToExport :: ExternDecl -> ExternDecl dependencyToExport (Dependency m _ _) = Export m @@ -51,23 +51,25 @@ removeExportDecls = fmap (filter (not . isExport)) replaceReexports :: Module -> Map ModuleIdent [ExternDecl] -> Module replaceReexports m db = result - where reexports = getReexports m - result = foldl go (removeExportDecls m) reexports + where + reexports = getReexports m + result = foldl go (removeExportDecls m) reexports - go :: Module -> ExternDecl -> Module - go m' re@(Export name) = replaceReexport re m' (getModule name) - go _ _ = error "partiality! woohoo" + go :: Module -> ExternDecl -> Module + go m' re@(Export name) = replaceReexport re m' (getModule name) + go _ _ = error "partiality! woohoo" - getModule :: ModuleIdent -> Module - getModule name = clean res - where res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db - -- we have to do this because keeping self exports in will result in - -- infinite loops - clean (mn, decls) = (mn,) (filter (/= Export mn) decls) + getModule :: ModuleIdent -> Module + getModule name = clean res + where + res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db + -- we have to do this because keeping self exports in will result in + -- infinite loops + clean (mn, decls) = (mn,) (filter (/= Export mn) decls) resolveReexports :: Map ModuleIdent [ExternDecl] -> Module -> Module -resolveReexports modules m = do +resolveReexports modules m = let replaced = replaceReexports m modules - if null . getReexports $ replaced - then replaced - else resolveReexports modules replaced + in if null (getReexports replaced) + then replaced + else resolveReexports modules replaced diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index ab22ba218a..e7988b01fa 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -52,18 +52,19 @@ getImportsForFile fp = do module' <- parseModuleFromFile fp let imports = getImports module' pure (mkModuleImport . unwrapPositionedImport <$> imports) - where mkModuleImport (D.ImportDeclaration mn importType' qualifier _) = - ModuleImport - (T.pack (N.runModuleName mn)) - importType' - (T.pack . N.runModuleName <$> qualifier) - mkModuleImport _ = error "Shouldn't have gotten anything but Imports here" - unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier b) = - D.ImportDeclaration mn (unwrapImportType importType') qualifier b - unwrapPositionedImport x = x - unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls) - unwrapImportType (D.Hiding decls) = D.Hiding (map unwrapPositionedRef decls) - unwrapImportType D.Implicit = D.Implicit + where + mkModuleImport (D.ImportDeclaration mn importType' qualifier _) = + ModuleImport + (T.pack (N.runModuleName mn)) + importType' + (T.pack . N.runModuleName <$> qualifier) + mkModuleImport _ = error "Shouldn't have gotten anything but Imports here" + unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier b) = + D.ImportDeclaration mn (unwrapImportType importType') qualifier b + unwrapPositionedImport x = x + unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls) + unwrapImportType (D.Hiding decls) = D.Hiding (map unwrapPositionedRef decls) + unwrapImportType D.Implicit = D.Implicit getPositionedImports :: D.Module -> [D.Declaration] getPositionedImports (D.Module _ _ _ declarations _) = @@ -73,34 +74,34 @@ getPositionedImports (D.Module _ _ _ declarations _) = isImport _ = Nothing getDeclPosition :: D.Module -> String -> Maybe SP.SourceSpan -getDeclPosition m ident = - let decls = getDeclarations m - in getFirst (foldMap (match ident) decls) - where match q (D.PositionedDeclaration ss _ decl) = First (if go q decl - then Just ss - else Nothing) - match _ _ = First Nothing +getDeclPosition m ident = getFirst (foldMap (match ident) decls) + where + decls = getDeclarations m + match q (D.PositionedDeclaration ss _ decl) = First (if go q decl + then Just ss + else Nothing) + match _ _ = First Nothing - go q (D.DataDeclaration _ name _ constructors) = - properEqual name q || any (\(x,_) -> properEqual x q) constructors - go q (D.DataBindingGroupDeclaration decls) = any (go q) decls - go q (D.TypeSynonymDeclaration name _ _) = properEqual name q - go q (D.TypeDeclaration ident' _) = identEqual ident' q - go q (D.ValueDeclaration ident' _ _ _) = identEqual ident' q - go q (D.ExternDeclaration ident' _) = identEqual ident' q - go q (D.ExternDataDeclaration name _) = properEqual name q - go q (D.TypeClassDeclaration name _ _ members) = - properEqual name q || any (go q . unwrapPositioned) members - go q (D.TypeInstanceDeclaration ident' _ _ _ _) = - identEqual ident' q - go _ _ = False + go q (D.DataDeclaration _ name _ constructors) = + properEqual name q || any (\(x,_) -> properEqual x q) constructors + go q (D.DataBindingGroupDeclaration decls') = any (go q) decls' + go q (D.TypeSynonymDeclaration name _ _) = properEqual name q + go q (D.TypeDeclaration ident' _) = identEqual ident' q + go q (D.ValueDeclaration ident' _ _ _) = identEqual ident' q + go q (D.ExternDeclaration ident' _) = identEqual ident' q + go q (D.ExternDataDeclaration name _) = properEqual name q + go q (D.TypeClassDeclaration name _ _ members) = + properEqual name q || any (go q . unwrapPositioned) members + go q (D.TypeInstanceDeclaration ident' _ _ _ _) = + identEqual ident' q + go _ _ = False - properEqual x q = N.runProperName x == q - identEqual x q = N.runIdent x == q + properEqual x q = N.runProperName x == q + identEqual x q = N.runIdent x == q goToDefinition :: String -> FilePath -> IO (Maybe SP.SourceSpan) goToDefinition q fp = do m <- runExceptT (parseModuleFromFile fp) case m of - Right module' -> return $ getDeclPosition module' q - Left _ -> return Nothing + Right module' -> pure (getDeclPosition module' q) + Left _ -> pure Nothing diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index dc015cba71..c6a966692c 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -73,8 +73,8 @@ insertModule externsFile = do insertModule' :: TVar PscIdeState -> ExternsFile -> STM () insertModule' st ef = do - modifyTVar (st) $ \x -> + modifyTVar st $ \x -> x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x) - , pscStateModules = let (mn, decls ) = convertExterns ef - in M.insert mn decls (pscStateModules x) + , pscStateModules = let (mn, decls) = convertExterns ef + in M.insert mn decls (pscStateModules x) } diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 0d8d429333..d3a7bd9075 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -33,21 +33,26 @@ type Type = Text data Fixity = Infix | Infixl | Infixr deriving(Show, Eq, Ord) data ExternDecl - = FunctionDecl { functionName :: DeclIdent - , functionType :: Type - } - | FixityDeclaration Fixity - Int - DeclIdent - | Dependency { dependencyModule :: ModuleIdent - , dependencyNames :: [Text] - , dependencyAlias :: Maybe Text - } - | ModuleDecl ModuleIdent - [DeclIdent] - | DataDecl DeclIdent - Text - | Export ModuleIdent + -- | A function/value declaration + = FunctionDecl + DeclIdent -- The functions name + Type -- The functions type + | FixityDeclaration Fixity Int DeclIdent + -- | A Dependency onto another Module + | Dependency + ModuleIdent -- name of the dependency + [Text] -- explicit imports + (Maybe Text) -- An eventual qualifier + + -- | A module declaration + | ModuleDecl + ModuleIdent -- The modules name + [DeclIdent] -- The exported identifiers + -- | A data/newtype declaration + | DataDecl DeclIdent -- The type name + Text -- The "type" + -- | An exported module + | Export ModuleIdent -- The exported Modules name deriving (Show,Eq,Ord) instance ToJSON ExternDecl where @@ -63,22 +68,22 @@ instance ToJSON ExternDecl where type Module = (ModuleIdent, [ExternDecl]) data Configuration = - Configuration { - confOutputPath :: FilePath + Configuration + { confOutputPath :: FilePath , confDebug :: Bool } data PscIdeEnvironment = - PscIdeEnvironment { - envStateVar :: TVar PscIdeState + PscIdeEnvironment + { envStateVar :: TVar PscIdeState , envConfiguration :: Configuration } type PscIde m = (Applicative m, MonadIO m, MonadReader PscIdeEnvironment m) data PscIdeState = - PscIdeState { - pscStateModules :: M.Map Text [ExternDecl] + PscIdeState + { pscStateModules :: M.Map Text [ExternDecl] , externsFiles :: M.Map ModuleName ExternsFile } deriving Show @@ -90,29 +95,32 @@ newtype Completion = deriving (Show,Eq) data ModuleImport = - ModuleImport { - importModuleName :: ModuleIdent + ModuleImport + { importModuleName :: ModuleIdent , importType :: D.ImportDeclarationType , importQualifier :: Maybe Text } deriving(Show) instance Eq ModuleImport where - mi1 == mi2 = importModuleName mi1 == importModuleName mi2 - && importQualifier mi1 == importQualifier mi2 + mi1 == mi2 = + importModuleName mi1 == importModuleName mi2 + && importQualifier mi1 == importQualifier mi2 instance ToJSON ModuleImport where toJSON (ModuleImport mn D.Implicit qualifier) = - object $ ["module" .= mn - , "importType" .= ("implicit" :: Text) - ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier) + object $ [ "module" .= mn + , "importType" .= ("implicit" :: Text) + ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier) toJSON (ModuleImport mn (D.Explicit refs) _) = - object ["module" .= mn + object [ "module" .= mn , "importType" .= ("explicit" :: Text) - , "identifiers" .= (identifierFromDeclarationRef <$> refs)] + , "identifiers" .= (identifierFromDeclarationRef <$> refs) + ] toJSON (ModuleImport mn (D.Hiding refs) _) = - object ["module" .= mn + object [ "module" .= mn , "importType" .= ("hiding" :: Text) - , "identifiers" .= (identifierFromDeclarationRef <$> refs)] + , "identifiers" .= (identifierFromDeclarationRef <$> refs) + ] identifierFromDeclarationRef :: D.DeclarationRef -> String identifierFromDeclarationRef (D.TypeRef name _) = N.runProperName name @@ -121,16 +129,16 @@ identifierFromDeclarationRef (D.TypeClassRef name) = N.runProperName name identifierFromDeclarationRef _ = "" instance FromJSON Completion where - parseJSON (Object o) = do - m <- o .: "module" - d <- o .: "identifier" - t <- o .: "type" - return $ Completion (m, d, t) - parseJSON _ = mzero + parseJSON (Object o) = do + m <- o .: "module" + d <- o .: "identifier" + t <- o .: "type" + pure (Completion (m, d, t)) + parseJSON _ = mzero instance ToJSON Completion where - toJSON (Completion (m,d,t)) = - object ["module" .= m, "identifier" .= d, "type" .= t] + toJSON (Completion (m,d,t)) = + object ["module" .= m, "identifier" .= d, "type" .= t] data Success = CompletionResult [Completion] @@ -161,23 +169,22 @@ data PursuitSearchType = Package | Identifier instance FromJSON PursuitSearchType where parseJSON (String t) = case t of - "package" -> return Package - "completion" -> return Identifier + "package" -> pure Package + "completion" -> pure Identifier _ -> mzero parseJSON _ = mzero instance FromJSON PursuitQuery where - parseJSON o = fmap PursuitQuery (parseJSON o) - -data PursuitResponse - = ModuleResponse { moduleResponseName :: Text - , moduleResponsePackage :: Text} - | DeclarationResponse { declarationResponseType :: Text - , declarationResponseModule :: Text - , declarationResponseIdent :: Text - , declarationResponsePackage :: Text - } - deriving (Show,Eq) + parseJSON o = PursuitQuery <$> (parseJSON o) + +data PursuitResponse = + -- | A Pursuit Response for a module. Consists of the modules name and the + -- package it belongs to + ModuleResponse ModuleIdent Text + -- | A Pursuit Response for a declaration. Consist of the declarations type, + -- module, name and package + | DeclarationResponse Type ModuleIdent DeclIdent Text + deriving (Show,Eq) instance FromJSON PursuitResponse where parseJSON (Object o) = do @@ -186,22 +193,12 @@ instance FromJSON PursuitResponse where (type' :: String) <- info .: "type" case type' of "module" -> do - name <- info .: "module" - return - ModuleResponse - { moduleResponseName = name - , moduleResponsePackage = package - } + name <- info .: "module" + pure (ModuleResponse name package) "declaration" -> do - moduleName <- info .: "module" - Right (ident, declType) <- typeParse <$> o .: "text" - return - DeclarationResponse - { declarationResponseType = declType - , declarationResponseModule = moduleName - , declarationResponseIdent = ident - , declarationResponsePackage = package - } + moduleName <- info .: "module" + Right (ident, declType) <- typeParse <$> o .: "text" + pure (DeclarationResponse declType moduleName ident package) _ -> mzero parseJSON _ = mzero @@ -217,7 +214,7 @@ typeParse t = case parse parseType "" t of _ <- string "::" spaces type' <- many1 anyChar - return (unpack name, type') + pure (unpack name, type') identifier :: Parser Text identifier = do @@ -227,14 +224,15 @@ identifier = do between (char '(') (char ')') (many1 (noneOf ", )")) <|> many1 (noneOf ", )") spaces - return (pack ident) + pure (pack ident) instance ToJSON PursuitResponse where - toJSON ModuleResponse{..} = - object ["module" .= moduleResponseName, "package" .= moduleResponsePackage] - toJSON DeclarationResponse{..} = + toJSON (ModuleResponse name package) = + object ["module" .= name, "package" .= package] + toJSON (DeclarationResponse module' ident type' package) = object - [ "module" .= declarationResponseModule - , "ident" .= declarationResponseIdent - , "type" .= declarationResponseType - , "package" .= declarationResponsePackage] + [ "module" .= module' + , "ident" .= ident + , "type" .= type' + , "package" .= package + ] From f1dfe1e8ab22692ae9e256261c585832b4e878b7 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Thu, 10 Mar 2016 03:42:26 +0100 Subject: [PATCH 0326/1580] removes superfluous constraints. Since GHC 7.10 Monad is a superclass of Applicative. --- psc-bundle/Main.hs | 4 +- psc-ide-server/Main.hs | 2 +- psc/Main.hs | 2 +- src/Control/Monad/Supply.hs | 2 +- src/Language/PureScript/AST/Traversals.hs | 6 +-- src/Language/PureScript/Bundle.hs | 4 +- src/Language/PureScript/CodeGen/JS.hs | 2 +- src/Language/PureScript/CodeGen/JS/AST.hs | 2 +- .../PureScript/CodeGen/JS/Optimizer.hs | 4 +- .../CodeGen/JS/Optimizer/Inliner.hs | 2 +- src/Language/PureScript/Docs/AsMarkdown.hs | 3 +- src/Language/PureScript/Docs/Convert.hs | 12 +++--- .../PureScript/Docs/Convert/ReExports.hs | 35 +++++++---------- .../PureScript/Docs/ParseAndBookmark.hs | 4 +- src/Language/PureScript/Errors.hs | 8 ++-- src/Language/PureScript/Ide.hs | 6 +-- src/Language/PureScript/Ide/CaseSplit.hs | 2 +- src/Language/PureScript/Ide/Externs.hs | 2 +- src/Language/PureScript/Ide/SourceFile.hs | 7 ++-- src/Language/PureScript/Ide/State.hs | 14 +++---- src/Language/PureScript/Ide/Types.hs | 2 +- src/Language/PureScript/Kinds.hs | 2 +- src/Language/PureScript/Linter.hs | 2 +- src/Language/PureScript/Linter/Exhaustive.hs | 4 +- src/Language/PureScript/Linter/Imports.hs | 4 +- src/Language/PureScript/Make.hs | 2 +- .../PureScript/Parser/Declarations.hs | 2 +- src/Language/PureScript/Parser/JS.hs | 2 +- src/Language/PureScript/Sugar.hs | 2 +- .../PureScript/Sugar/BindingGroups.hs | 6 +-- .../PureScript/Sugar/CaseDeclarations.hs | 12 +++--- src/Language/PureScript/Sugar/DoNotation.hs | 4 +- src/Language/PureScript/Sugar/Names.hs | 8 ++-- .../PureScript/Sugar/Names/Exports.hs | 6 +-- .../PureScript/Sugar/Names/Imports.hs | 8 ++-- .../PureScript/Sugar/ObjectWildcards.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 6 +-- src/Language/PureScript/Sugar/TypeClasses.hs | 8 ++-- .../PureScript/Sugar/TypeClasses/Deriving.hs | 12 +++--- .../PureScript/Sugar/TypeDeclarations.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 24 ++++++------ .../PureScript/TypeChecker/Entailment.hs | 2 +- src/Language/PureScript/TypeChecker/Kinds.hs | 22 +++++------ src/Language/PureScript/TypeChecker/Monad.hs | 30 +++++++-------- src/Language/PureScript/TypeChecker/Rows.hs | 2 +- .../PureScript/TypeChecker/Skolems.hs | 2 +- .../PureScript/TypeChecker/Subsumption.hs | 4 +- .../PureScript/TypeChecker/Synonyms.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 38 +++++++++---------- src/Language/PureScript/TypeChecker/Unify.hs | 10 ++--- src/Language/PureScript/Types.hs | 4 +- 51 files changed, 174 insertions(+), 185 deletions(-) diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index 5a4201b7da..31dc89e863 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -51,7 +51,7 @@ data Options = Options } deriving Show -- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier. -guessModuleIdentifier :: (Applicative m, MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier +guessModuleIdentifier :: (MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> guessModuleType (takeFileName filename) where guessModuleType "index.js" = pure Regular @@ -61,7 +61,7 @@ guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory f -- | The main application function. -- This function parses the input files, performs dead code elimination, filters empty modules -- and generates and prints the final Javascript bundle. -app :: (Applicative m, MonadError ErrorMessage m, MonadIO m) => Options -> m String +app :: (MonadError ErrorMessage m, MonadIO m) => Options -> m String app Options{..} = do inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles when (null inputFiles) . liftIO $ do diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 7062c2621c..77f22439f7 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -124,7 +124,7 @@ startServer port env = withSocketsDo $ do liftIO (hClose h) -acceptCommand :: (Applicative m, MonadIO m, MonadLogger m, MonadError T.Text m) +acceptCommand :: (MonadIO m, MonadLogger m, MonadError T.Text m) => Socket -> m (T.Text, Handle) acceptCommand sock = do h <- acceptConnection diff --git a/psc/Main.hs b/psc/Main.hs index 86393469ff..3ea11b6e75 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -107,7 +107,7 @@ globWarningOnMisses warn = concatMapM globWithWarning readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)] readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readUTF8File inFile -parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m) +parseInputs :: (MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m) => [(Either P.RebuildPolicy FilePath, String)] -> [(FilePath, P.ForeignJS)] -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName FilePath) diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs index 1ae1e7234a..0b002e4554 100644 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -27,7 +27,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader import Control.Monad.Writer -newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } +newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r) runSupplyT :: Integer -> SupplyT m a -> m (a, Integer) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 55634a5739..4ea8c5bfda 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -91,7 +91,7 @@ everywhereOnValues f g h = (f', g', h') everywhereOnValuesTopDownM :: forall m - . (Functor m, Applicative m, Monad m) + . (Monad m) => (Declaration -> m Declaration) -> (Expr -> m Expr) -> (Binder -> m Binder) @@ -160,7 +160,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) everywhereOnValuesM :: forall m - . (Functor m, Applicative m, Monad m) + . (Monad m) => (Declaration -> m Declaration) -> (Expr -> m Expr) -> (Binder -> m Binder) @@ -389,7 +389,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' everywhereWithContextOnValuesM :: forall m s - . (Functor m, Applicative m, Monad m) + . (Monad m) => s -> (s -> Declaration -> m (s, Declaration)) -> (s -> Expr -> m (s, Expr)) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 3efa43f38a..fdd122f905 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -209,7 +209,7 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es) -- -- Each type of module element is matched using pattern guards, and everything else is bundled into the -- Other constructor. -toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module +toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module toModule requirePath mids mid top | JSSourceElementsTop ns <- node top = Module mid <$> traverse toModuleElement ns | otherwise = err InvalidTopLevel @@ -533,7 +533,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem -- | The bundling function. -- This function performs dead code elimination, filters empty modules -- and generates and prints the final Javascript bundle. -bundle :: (Applicative m, MonadError ErrorMessage m) +bundle :: (MonadError ErrorMessage m) => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination -> Maybe String -- ^ An optional main module. diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 3b2de22b70..e3634d649d 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -47,7 +47,7 @@ import System.FilePath.Posix (()) -- moduleToJs :: forall m - . (Applicative m, Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) + . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) => Module Ann -> Maybe JS -> m [JS] diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index 59f7bc1a5d..dd9a69a4dd 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -347,7 +347,7 @@ everywhereOnJS f = go everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS everywhereOnJSTopDown f = runIdentity . everywhereOnJSTopDownM (Identity . f) -everywhereOnJSTopDownM :: (Applicative m, Monad m) => (JS -> m JS) -> JS -> m JS +everywhereOnJSTopDownM :: (Monad m) => (JS -> m JS) -> JS -> m JS everywhereOnJSTopDownM f = f >=> go where f' = f >=> go diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs index 5836b4618e..d270949456 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -43,12 +43,12 @@ import Language.PureScript.CodeGen.JS.Optimizer.Blocks -- | -- Apply a series of optimizer passes to simplified Javascript code -- -optimize :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => JS -> m JS +optimize :: (Monad m, MonadReader Options m, MonadSupply m) => JS -> m JS optimize js = do noOpt <- asks optionsNoOptimizations if noOpt then return js else optimize' js -optimize' :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => JS -> m JS +optimize' :: (Monad m, MonadReader Options m, MonadSupply m) => JS -> m JS optimize' js = do opts <- ask js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index 6b9f4e7095..c022f1d9e5 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -235,7 +235,7 @@ inlineCommonOperators = applyAll $ -- (f <<< g $ x) = f (g x) -- (f <<< g) = \x -> f (g x) -inlineFnComposition :: (Applicative m, MonadSupply m) => JS -> m JS +inlineFnComposition :: (MonadSupply m) => JS -> m JS inlineFnComposition = everywhereOnJSTopDownM convert where convert :: (MonadSupply m) => JS -> m JS diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 9d1f0a6a89..b2de1d6bf3 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -29,8 +29,7 @@ import qualified Language.PureScript.Docs.Render as Render -- Markdown-formatted String. -- renderModulesAsMarkdown :: - (Functor m, Applicative m, - MonadError P.MultipleErrors m) => + (MonadError P.MultipleErrors m) => [P.Module] -> m String renderModulesAsMarkdown = diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 3b988896bf..9678ecce66 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -38,7 +38,7 @@ import Language.PureScript.Docs.Convert.ReExports (updateReExports) -- documentation. -- convertModulesInPackage :: - (Functor m, Applicative m, MonadError P.MultipleErrors m) => + (MonadError P.MultipleErrors m) => [InPackage P.Module] -> m [Module] convertModulesInPackage modules = @@ -66,7 +66,7 @@ convertModulesInPackage modules = -- types. -- convertModules :: - (Functor m, Applicative m, MonadError P.MultipleErrors m) => + (MonadError P.MultipleErrors m) => [P.Module] -> m [Module] convertModules = @@ -81,7 +81,7 @@ importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim]) -- Convert a sorted list of modules. -- convertSorted :: - (Functor m, Applicative m, MonadError P.MultipleErrors m) => + (MonadError P.MultipleErrors m) => [P.Module] -> m [Module] convertSorted modules = do @@ -99,7 +99,7 @@ convertSorted modules = do -- types. -- typeCheckIfNecessary :: - (Functor m, Applicative m, MonadError P.MultipleErrors m) => + (MonadError P.MultipleErrors m) => [P.Module] -> [Module] -> m [Module] @@ -122,7 +122,7 @@ typeCheckIfNecessary modules convertedModules = -- were not provided. -- typeCheck :: - (Functor m, MonadError P.MultipleErrors m) => + (MonadError P.MultipleErrors m) => [P.Module] -> m ([P.Module], P.Environment) typeCheck = @@ -182,7 +182,7 @@ runParser p s = either (Left . show) Right $ do -- documentation information from. -- partiallyDesugar :: - (Functor m, Applicative m, MonadError P.MultipleErrors m) => + (MonadError P.MultipleErrors m) => [P.Module] -> m (P.Env, [P.Module]) partiallyDesugar = P.evalSupplyT 0 . desugar' diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index a9330f95d6..e9473f51c5 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -69,8 +69,7 @@ updateReExports env order modules = -- have already been converted. -- getReExports :: - (Functor m, Applicative m, - MonadState (Map P.ModuleName Module) m) => + (MonadState (Map P.ModuleName Module) m) => P.Env -> P.ModuleName -> m [(P.ModuleName, [Declaration])] @@ -105,9 +104,7 @@ getReExports env mn = -- class members are listed. -- collectDeclarations :: - (Functor m, Applicative m, - MonadState (Map P.ModuleName Module) m, - MonadReader P.ModuleName m) => + (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) => P.Imports -> P.Exports -> m [(P.ModuleName, [Declaration])] @@ -154,7 +151,7 @@ collectDeclarations imports exports = do -- instantiate @name@ as both 'P.Ident' and 'P.ProperName'. -- findImport :: - (Show name, Eq name, Applicative m, MonadReader P.ModuleName m) => + (Show name, Eq name, MonadReader P.ModuleName m) => [P.ImportRecord name] -> (name, P.ModuleName) -> m (P.ModuleName, name) @@ -174,9 +171,8 @@ findImport imps (name, orig) = internalErrorInModule ("findImport: not found: " ++ show (name, orig)) lookupValueDeclaration :: - (Applicative m, - MonadState (Map P.ModuleName Module) m, - MonadReader P.ModuleName m) => + (MonadState (Map P.ModuleName Module) m, + MonadReader P.ModuleName m) => P.ModuleName -> P.Ident -> m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration]) @@ -233,9 +229,8 @@ lookupValueDeclaration importedFrom ident = do -- are only included in the output if they are listed in the arguments. -- lookupTypeDeclaration :: - (Applicative m, - MonadState (Map P.ModuleName Module) m, - MonadReader P.ModuleName m) => + (MonadState (Map P.ModuleName Module) m, + MonadReader P.ModuleName m) => P.ModuleName -> P.ProperName 'P.TypeName -> m (P.ModuleName, [Declaration]) @@ -251,9 +246,8 @@ lookupTypeDeclaration importedFrom ty = do ("lookupTypeDeclaration: unexpected result: " ++ show other) lookupTypeClassDeclaration :: - (Applicative m, - MonadState (Map P.ModuleName Module) m, - MonadReader P.ModuleName m) => + (MonadState (Map P.ModuleName Module) m, + MonadReader P.ModuleName m) => P.ModuleName -> P.ProperName 'P.ClassName -> m (P.ModuleName, [Declaration]) @@ -276,9 +270,8 @@ lookupTypeClassDeclaration importedFrom tyClass = do -- state, or raise an internal error if it is not there. -- lookupModuleDeclarations :: - (Applicative m, - MonadState (Map P.ModuleName Module) m, - MonadReader P.ModuleName m) => + (MonadState (Map P.ModuleName Module) m, + MonadReader P.ModuleName m) => String -> P.ModuleName -> m [Declaration] @@ -293,8 +286,7 @@ lookupModuleDeclarations definedIn moduleName = do pure (allDeclarations mdl) handleTypeClassMembers :: - (Functor m, Applicative m, - MonadReader P.ModuleName m) => + (MonadReader P.ModuleName m) => Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] -> Map P.ModuleName [Declaration] -> m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration]) @@ -364,8 +356,7 @@ instance Monoid TypeClassEnv where -- Returns a tuple of (values, type classes). -- handleEnv :: - (Functor m, Applicative m, - MonadReader P.ModuleName m) => + (MonadReader P.ModuleName m) => TypeClassEnv -> m ([Declaration], [Declaration]) handleEnv TypeClassEnv{..} = diff --git a/src/Language/PureScript/Docs/ParseAndBookmark.hs b/src/Language/PureScript/Docs/ParseAndBookmark.hs index ed9482092f..cfb32d55dd 100644 --- a/src/Language/PureScript/Docs/ParseAndBookmark.hs +++ b/src/Language/PureScript/Docs/ParseAndBookmark.hs @@ -35,7 +35,7 @@ import Language.PureScript.Docs.Convert (collectBookmarks) -- * Collect a list of bookmarks from the whole set of source files -- * Return the parsed modules and the bookmarks parseAndBookmark :: - (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) => + (MonadError P.MultipleErrors m, MonadIO m) => [FilePath] -> [(PackageName, FilePath)] -> m ([InPackage P.Module], [Bookmark]) @@ -82,7 +82,7 @@ fileInfoToString (FromDep _ fn) = fn parseFile :: FilePath -> IO (FilePath, String) parseFile input' = (,) input' <$> readFile input' -parseAs :: (Functor m, MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String) +parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String) parseAs g = fmap (first g) . liftIO . parseFile getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 9c5d2d69c8..94f16f5496 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1283,7 +1283,7 @@ renderBox = unlines rethrow :: (MonadError e m) => (e -> e) -> m a -> m a rethrow f = flip catchError $ \e -> throwError (f e) -reifyErrors :: (Functor m, MonadError e m) => m a -> m (Either e a) +reifyErrors :: (MonadError e m) => m a -> m (Either e a) reifyErrors ma = catchError (fmap Right ma) (return . Left) reflectErrors :: (MonadError e m) => m (Either e a) -> m a @@ -1310,13 +1310,13 @@ withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : h -- | -- Collect errors in in parallel -- -parU :: (MonadError MultipleErrors m, Functor m) => [a] -> (a -> m b) -> m [b] +parU :: (MonadError MultipleErrors m) => [a] -> (a -> m b) -> m [b] parU xs f = forM xs (withError . f) >>= collectErrors where - withError :: (MonadError MultipleErrors m, Functor m) => m a -> m (Either MultipleErrors a) + withError :: (MonadError MultipleErrors m) => m a -> m (Either MultipleErrors a) withError u = catchError (Right <$> u) (return . Left) - collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a] + collectErrors :: (MonadError MultipleErrors m) => [Either MultipleErrors a] -> m [a] collectErrors es = case lefts es of [] -> return $ rights es errs -> throwError $ fold errs diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 3d9a45af02..a77734ed30 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -74,12 +74,12 @@ findType :: (PscIde m, MonadLogger m) => findType search filters = CompletionResult . getExactMatches search filters <$> getAllModulesWithReexports -findPursuitCompletions :: (Applicative m, MonadIO m, MonadLogger m) => +findPursuitCompletions :: (MonadIO m, MonadLogger m) => PursuitQuery -> m Success findPursuitCompletions (PursuitQuery q) = PursuitResult <$> liftIO (searchPursuitForDeclarations q) -findPursuitPackages :: (Applicative m, MonadIO m, MonadLogger m) => +findPursuitPackages :: (MonadIO m, MonadLogger m) => PursuitQuery -> m Success findPursuitPackages (PursuitQuery q) = PursuitResult <$> liftIO (findPackagesForModuleIdent q) @@ -118,7 +118,7 @@ caseSplit l b e csa t = do addClause :: Text -> CS.WildcardAnnotations -> Success addClause t wca = MultilineTextResult (CS.addClause t wca) -importsForFile :: (Applicative m, MonadIO m, MonadLogger m, MonadError PscIdeError m) => +importsForFile :: (MonadIO m, MonadLogger m, MonadError PscIdeError m) => FilePath -> m Success importsForFile fp = do imports <- getImportsForFile fp diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index af2d680432..d82610eec7 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -78,7 +78,7 @@ findTypeDeclaration' t ExternsFile{..} = EDType tn _ _ -> tn == t _ -> False) efDeclarations -splitTypeConstructor :: (Applicative m, MonadError PscIdeError m) => +splitTypeConstructor :: (MonadError PscIdeError m) => Type -> m (ProperName 'TypeName, [Type]) splitTypeConstructor = go [] where diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 67e9cd7867..0ce7a8ec4b 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -34,7 +34,7 @@ import Language.PureScript.Ide.Types import qualified Language.PureScript.Names as N import qualified Language.PureScript.Pretty as PP -readExternFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) => +readExternFile :: (MonadIO m, MonadError PscIdeError m) => FilePath -> m PE.ExternsFile readExternFile fp = do parseResult <- liftIO (decodeT <$> T.readFile fp) diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index e7988b01fa..846a8faee7 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -3,8 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.SourceFile where -import Prelude () -import Prelude.Compat +import Prelude import Control.Monad.Error.Class import Control.Monad.IO.Class @@ -22,7 +21,7 @@ import qualified Language.PureScript.Names as N import qualified Language.PureScript.Parser as P import System.Directory -parseModuleFromFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) => +parseModuleFromFile :: (MonadIO m, MonadError PscIdeError m) => FilePath -> m D.Module parseModuleFromFile fp = do exists <- liftIO (doesFileExist fp) @@ -46,7 +45,7 @@ getImports (D.Module _ _ _ declarations _) = isImport (D.PositionedDeclaration _ _ (i@D.ImportDeclaration{})) = Just i isImport _ = Nothing -getImportsForFile :: (Applicative m, MonadIO m, MonadError PscIdeError m) => +getImportsForFile :: (MonadIO m, MonadError PscIdeError m) => FilePath -> m [ModuleImport] getImportsForFile fp = do module' <- parseModuleFromFile fp diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index c6a966692c..5daf19cf2d 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -25,38 +25,38 @@ import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.Types import Language.PureScript.Names -getPscIdeState :: (PscIde m, Functor m) => +getPscIdeState :: (PscIde m) => m (M.Map ModuleIdent [ExternDecl]) getPscIdeState = do stateVar <- envStateVar <$> ask liftIO $ pscStateModules <$> readTVarIO stateVar -getExternFiles :: (PscIde m, Functor m) => +getExternFiles :: (PscIde m) => m (M.Map ModuleName ExternsFile) getExternFiles = do stateVar <- envStateVar <$> ask liftIO (externsFiles <$> readTVarIO stateVar) -getAllDecls :: (PscIde m, Functor m) => m [ExternDecl] +getAllDecls :: (PscIde m) => m [ExternDecl] getAllDecls = concat <$> getPscIdeState -getAllModules :: (PscIde m, Functor m) => m [Module] +getAllModules :: (PscIde m) => m [Module] getAllModules = M.toList <$> getPscIdeState -getAllModulesWithReexports :: (PscIde m, MonadLogger m, Applicative m) => +getAllModulesWithReexports :: (PscIde m, MonadLogger m) => m [Module] getAllModulesWithReexports = do mis <- M.keys <$> getPscIdeState ms <- traverse getModuleWithReexports mis pure (catMaybes ms) -getModule :: (PscIde m, MonadLogger m, Applicative m) => +getModule :: (PscIde m, MonadLogger m) => ModuleIdent -> m (Maybe Module) getModule m = do modules <- getPscIdeState pure ((m,) <$> M.lookup m modules) -getModuleWithReexports :: (PscIde m, MonadLogger m, Applicative m) => +getModuleWithReexports :: (PscIde m, MonadLogger m) => ModuleIdent -> m (Maybe Module) getModuleWithReexports mi = do m <- getModule mi diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index d3a7bd9075..badc7d4fef 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -79,7 +79,7 @@ data PscIdeEnvironment = , envConfiguration :: Configuration } -type PscIde m = (Applicative m, MonadIO m, MonadReader PscIdeEnvironment m) +type PscIde m = (MonadIO m, MonadReader PscIdeEnvironment m) data PscIdeState = PscIdeState diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index c19c773cd7..f9876b1c66 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -42,7 +42,7 @@ everywhereOnKinds f = go go (FunKind k1 k2) = f (FunKind (go k1) (go k2)) go other = f other -everywhereOnKindsM :: (Functor m, Applicative m, Monad m) => (Kind -> m Kind) -> Kind -> m Kind +everywhereOnKindsM :: Monad m => (Kind -> m Kind) -> Kind -> m Kind everywhereOnKindsM f = go where go (Row k1) = (Row <$> go k1) >>= f diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 3e554ef126..c5de54816c 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -29,7 +29,7 @@ import Language.PureScript.Linter.Imports as L -- | Lint the PureScript AST. -- | -- | Right now, this pass only performs a shadowing check. -lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m () +lint :: forall m. (MonadWriter MultipleErrors m) => Module -> m () lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds where moduleNames :: S.Set Ident diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index b2f914ca6e..ce43a9510c 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -261,7 +261,7 @@ checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ fold -- | -- Exhaustivity checking over a list of declarations -- -checkExhaustiveDecls :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> ModuleName -> [Declaration] -> m () +checkExhaustiveDecls :: forall m. MonadWriter MultipleErrors m => Environment -> ModuleName -> [Declaration] -> m () checkExhaustiveDecls env mn = mapM_ onDecl where onDecl :: Declaration -> m () @@ -310,5 +310,5 @@ checkExhaustiveDecls env mn = mapM_ onDecl -- | -- Exhaustivity checking over a single module -- -checkExhaustiveModule :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Environment -> Module -> m () +checkExhaustiveModule :: forall m. MonadWriter MultipleErrors m => Environment -> Module -> m () checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 63fccba7c4..25819db068 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -70,7 +70,7 @@ type UsedImports = M.Map ModuleName [Name] -- lintImports :: forall m - . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports @@ -170,7 +170,7 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do lintImportDecl :: forall m - . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Maybe ModuleName diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index c1d327c34b..4221a80008 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -145,7 +145,7 @@ data RebuildPolicy -- If timestamps have not changed, the externs file can be used to provide the module's types without -- having to typecheck the module again. -- -make :: forall m. (Functor m, Applicative m, Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [Module] -> m Environment diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index bd3cb65728..bf7b96c1bb 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -261,7 +261,7 @@ parseModule = do return $ Module ss comments name decls exports -- | Parse a collection of modules in parallel -parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m, Functor m) => +parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m) => (k -> FilePath) -> [(k, String)] -> m [(k, Module)] parseModulesFromFiles toFilePath input = do modules <- flip parU id $ map wrapError $ inParallel $ flip map input $ \(k, content) -> do diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs index a25f7d88d1..9defab4d44 100644 --- a/src/Language/PureScript/Parser/JS.hs +++ b/src/Language/PureScript/Parser/JS.hs @@ -36,7 +36,7 @@ import qualified Text.Parsec as PS type ForeignJS = String -parseForeignModulesFromFiles :: (Functor m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +parseForeignModulesFromFiles :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [(FilePath, ForeignJS)] -> m (M.Map ModuleName FilePath) parseForeignModulesFromFiles files = do diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 0b50a5f29f..68388e9e6f 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -63,7 +63,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S -- -- * Group mutually recursive value and data declarations into binding groups. -- -desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] +desugar :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] desugar externs = map removeSignedLiterals >>> traverse desugarObjectConstructors diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 3949673403..d92a5cd478 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -35,7 +35,7 @@ import Language.PureScript.Types -- Replace all sets of mutually-recursive declarations in a module with binding groups -- createBindingGroupsModule - :: (Functor m, Applicative m, MonadError MultipleErrors m) + :: (MonadError MultipleErrors m) => [Module] -> m [Module] createBindingGroupsModule = @@ -52,7 +52,7 @@ collapseBindingGroupsModule = createBindingGroups :: forall m - . (Functor m, Applicative m, MonadError MultipleErrors m) + . (MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration] @@ -171,7 +171,7 @@ getTypeName _ = internalError "Expected DataDeclaration" -- toBindingGroup :: forall m - . (Functor m, MonadError MultipleErrors m) + . (MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index da646f609d..095bad3c10 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -36,7 +36,7 @@ isLeft (Right _) = False -- | -- Replace all top-level binders in a module with case expressions. -- -desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module] +desugarCasesModule :: (MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module] desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) -> rethrow (addHint (ErrorInModule name)) $ Module ss coms name <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps @@ -44,7 +44,7 @@ desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) -> -- | -- Validates that case head and binder lengths match. -- -validateCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] +validateCases :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] validateCases = flip parU f where (f, _, _) = everywhereOnValuesM return validate return @@ -69,7 +69,7 @@ validateCases = flip parU f positionedBinder (PositionedBinder p _ _) = Just p positionedBinder _ = Nothing -desugarAbs :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] +desugarAbs :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] desugarAbs = flip parU f where (f, _, _) = everywhereOnValuesM return replace return @@ -83,7 +83,7 @@ desugarAbs = flip parU f -- | -- Replace all top-level binders with case expressions. -- -desugarCases :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] +desugarCases :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup where desugarRest :: [Declaration] -> m [Declaration] @@ -109,7 +109,7 @@ inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2 inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2 inSameGroup _ _ = False -toDecls :: forall m. (Functor m, Applicative m, Monad m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] +toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do args <- mapM fromVarBinder bs let body = foldr (Abs . Left) val args @@ -147,7 +147,7 @@ toTuple (ValueDeclaration _ _ bs result) = (bs, result) toTuple (PositionedDeclaration _ _ d) = toTuple d toTuple _ = internalError "Not a value declaration" -makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration +makeCaseDeclaration :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration makeCaseDeclaration ident alternatives = do let namedArgs = map findName . fst <$> alternatives argNames = foldl1 resolveNames namedArgs diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index e175bbefbf..ee923caa4a 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -26,10 +26,10 @@ import Control.Monad.Supply.Class -- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.bind function, -- and all @DoNotationLet@ constructors with let expressions. -- -desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module +desugarDoModule :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Module -> m Module desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarDo <*> pure exts -desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration +desugarDo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> rethrowWithPosition pos (desugarDo d) desugarDo d = let (f, _, _) = everywhereOnValuesM return replace return diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 8fd50da1a7..410f905fc4 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -44,13 +44,13 @@ import Language.PureScript.Linter.Imports -- Replaces all local names with qualified names within a list of modules. The -- modules should be topologically sorted beforehand. -- -desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] +desugarImports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] desugarImports externs modules = fmap snd (desugarImportsWithEnv externs modules) desugarImportsWithEnv :: forall m - . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m (Env, [Module]) @@ -141,7 +141,7 @@ elaborateExports exps (Module ss coms mn decls refs) = -- renameInModule :: forall m - . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) => Env -> Imports -> Module @@ -334,7 +334,7 @@ renameInModule env imports (Module ss coms mn decls exps) = -- updateExportRefs :: forall m - . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> m Module updateExportRefs (Module ss coms mn decls exps) = diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 84776cd879..765cacd0a4 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -31,7 +31,7 @@ import Language.PureScript.Sugar.Names.Env -- | -- Finds all exportable members of a module, disregarding any explicit exports. -- -findExportable :: forall m. (Applicative m, MonadError MultipleErrors m) => Module -> m Exports +findExportable :: forall m. (MonadError MultipleErrors m) => Module -> m Exports findExportable (Module _ _ mn ds _) = rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds where @@ -56,7 +56,7 @@ findExportable (Module _ _ mn ds _) = -- Resolves the exports for a module, filtering out members that have not been -- exported and elaborating re-exports of other modules. -- -resolveExports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports +resolveExports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports resolveExports env mn imps exps refs = rethrow (addHint (ErrorInModule mn)) $ do filtered <- filterModule mn exps refs @@ -199,7 +199,7 @@ resolveExports env mn imps exps refs = -- filterModule :: forall m - . (Applicative m, MonadError MultipleErrors m) + . (MonadError MultipleErrors m) => ModuleName -> Exports -> [DeclarationRef] diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index c0e3276b7a..c03517809e 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -37,7 +37,7 @@ import Language.PureScript.Sugar.Names.Env -- findImports :: forall m - . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) findImports = foldM (go Nothing) M.empty @@ -56,7 +56,7 @@ type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) -- resolveImports :: forall m - . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Module -> m (Module, Imports) @@ -160,7 +160,7 @@ resolveImports env (Module ss coms currentModule decls exps) = -- | Constructs a set of imports for a single module import. resolveModuleImport :: forall m - . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> Imports -> (ModuleName, [(Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)]) @@ -187,7 +187,7 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps -- resolveImport :: forall m - . (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> Exports -> Imports diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index a2bb574ecc..61a4d05347 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -21,7 +21,7 @@ import Language.PureScript.Names desugarObjectConstructors :: forall m - . (Applicative m, MonadSupply m, MonadError MultipleErrors m) + . (MonadSupply m, MonadError MultipleErrors m) => Module -> m Module desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 4b09c2c0b2..f0540103f8 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -57,7 +57,7 @@ type AliasName = Either (Qualified Ident) (Qualified (ProperName 'ConstructorNam -- rebracket :: forall m - . (Applicative m, MonadError MultipleErrors m) + . (MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] @@ -116,7 +116,7 @@ removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) go other = other rebracketModule - :: (Applicative m, MonadError MultipleErrors m) + :: (MonadError MultipleErrors m) => [[(Qualified Ident, Associativity)]] -> Module -> m Module @@ -178,7 +178,7 @@ customOperatorTable fixities = desugarOperatorSections :: forall m - . (Applicative m, MonadSupply m, MonadError MultipleErrors m) + . (MonadSupply m, MonadError MultipleErrors m) => Module -> m Module desugarOperatorSections (Module ss coms mn ds exts) = diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index d0cf61fd22..1b9ab39c72 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -45,7 +45,7 @@ type Desugar = StateT MemberMap -- instance dictionary expressions. -- desugarTypeClasses - :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) + :: (MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] @@ -62,7 +62,7 @@ desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModu fromExternsDecl _ _ = Nothing desugarModule - :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) + :: (MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module desugarModule (Module ss coms name decls (Just exps)) = do @@ -171,7 +171,7 @@ desugarModule _ = internalError "Exports should have been elaborated in name des -- }; -} desugarDecl - :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) + :: (MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration @@ -259,7 +259,7 @@ unit = TypeApp tyObject REmpty typeInstanceDictionaryDeclaration :: forall m - . (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) + . (MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 404e2a7f3f..f788d485fc 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -32,7 +32,7 @@ import qualified Language.PureScript.Constants as C -- | Elaborates deriving instance declarations by code generation. deriveInstances - :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) + :: (MonadError MultipleErrors m, MonadSupply m) => Module -> m Module deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts @@ -40,7 +40,7 @@ deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (derive -- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration, -- elaborates that into an instance declaration via code generation. deriveInstance - :: (Functor m, MonadError MultipleErrors m, MonadSupply m) + :: (MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration @@ -82,7 +82,7 @@ typesProxy :: ModuleName typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ] deriveGeneric - :: forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m) + :: forall m. (MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName 'TypeName @@ -246,7 +246,7 @@ deriveGeneric mn ds tyConNm dargs = do mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) deriveEq :: - forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m) + forall m. (MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName 'TypeName @@ -298,7 +298,7 @@ deriveEq mn ds tyConNm = do toEqTest l r _ = preludeEq l r deriveOrd :: - forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m) + forall m. (MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName 'TypeName @@ -377,7 +377,7 @@ deriveOrd mn ds tyConNm = do toOrdering l r _ = preludeCompare l r findTypeDecl - :: (Functor m, MonadError MultipleErrors m) + :: (MonadError MultipleErrors m) => ProperName 'TypeName -> [Declaration] -> m Declaration diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 8294d82cea..8072ff29df 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -36,7 +36,7 @@ import Language.PureScript.Traversals -- | -- Replace all top level type declarations in a module with type annotations -- -desugarTypeDeclarationsModule :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module] +desugarTypeDeclarationsModule :: forall m. (MonadError MultipleErrors m) => [Module] -> m [Module] desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) -> rethrow (addHint (ErrorInModule name)) $ Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 6684639942..d020b44491 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -40,7 +40,7 @@ import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types addDataType - :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> DataDeclType -> ProperName 'TypeName @@ -56,7 +56,7 @@ addDataType moduleName dtype name args dctors ctorKind = do addDataConstructor moduleName dtype name (map fst args) dctor tys addDataConstructor - :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> DataDeclType -> ProperName 'TypeName @@ -74,7 +74,7 @@ addDataConstructor moduleName dtype name args dctor tys = do putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } addTypeSynonym - :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> ProperName 'TypeName -> [(String, Maybe Kind)] @@ -88,7 +88,7 @@ addTypeSynonym moduleName name args ty kind = do , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) } valueIsNotDefined - :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> Ident -> m () @@ -99,7 +99,7 @@ valueIsNotDefined moduleName name = do Nothing -> return () addValue - :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> Ident -> Type @@ -110,7 +110,7 @@ addValue moduleName name ty nameKind = do putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) }) addTypeClass - :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> ProperName 'ClassName -> [(String, Maybe Kind)] @@ -126,7 +126,7 @@ addTypeClass moduleName pn args implies ds = toPair _ = internalError "Invalid declaration in TypeClassDeclaration" addTypeClassDictionaries - :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Maybe ModuleName -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope) -> m () @@ -135,7 +135,7 @@ addTypeClassDictionaries mn entries = where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st) checkDuplicateTypeArguments - :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [String] -> m () checkDuplicateTypeArguments args = for_ firstDup $ \dup -> @@ -145,7 +145,7 @@ checkDuplicateTypeArguments args = for_ firstDup $ \dup -> firstDup = listToMaybe $ args \\ nub args checkTypeClassInstance - :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> Type -> m () @@ -161,7 +161,7 @@ checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty -- Check that type synonyms are fully-applied in a type -- checkTypeSynonyms - :: (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Type -> m () checkTypeSynonyms = void . replaceAllTypeSynonyms @@ -181,7 +181,7 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms -- typeCheckAll :: forall m - . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> [DeclarationRef] -> [Declaration] @@ -343,7 +343,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds -- typeCheckModule :: forall m - . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> m Module typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated" diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 48d878a1c2..6243d7c46b 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -34,7 +34,7 @@ import qualified Language.PureScript.Constants as C -- entails :: forall m - . (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index ae3325b31c..188cf9737e 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -43,7 +43,7 @@ freshKind = do -- | Update the substitution to solve a kind constraint solveKind - :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) + :: (MonadError MultipleErrors m, MonadState CheckState m) => Int -> Kind -> m () @@ -68,7 +68,7 @@ substituteKind sub = everywhereOnKinds go -- | Make sure that an unknown does not occur in a kind occursCheck - :: (Functor m, Applicative m, MonadError MultipleErrors m) + :: (MonadError MultipleErrors m) => Int -> Kind -> m () @@ -80,7 +80,7 @@ occursCheck u k = void $ everywhereOnKindsM go k -- | Unify two kinds unifyKinds - :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) + :: (MonadError MultipleErrors m, MonadState CheckState m) => Kind -> Kind -> m () @@ -101,14 +101,14 @@ unifyKinds k1 k2 = do -- | Infer the kind of a single type kindOf - :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) + :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => Type -> m Kind kindOf ty = fst <$> kindOfWithScopedVars ty -- | Infer the kind of a single type, returning the kinds of any scoped type variables kindOfWithScopedVars :: - (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => + (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => Type -> m (Kind, [(String, Kind)]) kindOfWithScopedVars ty = @@ -121,7 +121,7 @@ kindOfWithScopedVars ty = -- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors kindsOf - :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) + :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => Bool -> ModuleName -> ProperName 'TypeName @@ -139,7 +139,7 @@ kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do tidyUp (k, sub) = starIfUnknown $ substituteKind sub k freshKindVar - :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) + :: (MonadError MultipleErrors m, MonadState CheckState m) => (String, Maybe Kind) -> Kind -> m (ProperName 'TypeName, Kind) @@ -150,7 +150,7 @@ freshKindVar (arg, Just kind') kind = do -- | Simultaneously infer the kinds of several mutually recursive type constructors kindsOfAll - :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) + :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)] -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])] @@ -178,7 +178,7 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do -- | Solve the set of kind constraints associated with the data constructors for a type constructor solveTypes - :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) + :: (MonadError MultipleErrors m, MonadState CheckState m) => Bool -> [Type] -> [Kind] @@ -202,14 +202,14 @@ starIfUnknown k = k -- | Infer a kind for a type infer - :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) + :: (MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)]) infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty infer' :: forall m - . (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) + . (MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)]) infer' (ForAll ident ty _) = do diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 752e9be53d..e06466a119 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -84,7 +84,7 @@ bindTypes newNames action = do -- | Temporarily bind a collection of names to types withScopedTypeVars - :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName -> [(String, Kind)] -> m a @@ -112,20 +112,20 @@ withTypeClassDictionaries entries action = do -- | Get the currently available map of type class dictionaries getTypeClassDictionaries - :: (Functor m, MonadState CheckState m) + :: (MonadState CheckState m) => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))) getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get -- | Lookup type class dictionaries in a module. lookupTypeClassDictionaries - :: (Functor m, MonadState CheckState m) + :: (MonadState CheckState m) => Maybe ModuleName -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get -- | Temporarily bind a collection of names to local variables bindLocalVariables - :: (Functor m, MonadState CheckState m) + :: (MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a @@ -135,7 +135,7 @@ bindLocalVariables moduleName bindings = -- | Temporarily bind a collection of names to local type variables bindLocalTypeVariables - :: (Functor m, MonadState CheckState m) + :: (MonadState CheckState m) => ModuleName -> [(ProperName 'TypeName, Kind)] -> m a @@ -144,15 +144,15 @@ bindLocalTypeVariables moduleName bindings = bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable))) -- | Update the visibility of all names to Defined -makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m () +makeBindingGroupVisible :: (MonadState CheckState m) => m () makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) } -- | Update the visibility of all names to Defined in the scope of the provided action -withBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a +withBindingGroupVisible :: (MonadState CheckState m) => m a -> m a withBindingGroupVisible action = preservingNames $ makeBindingGroupVisible >> action -- | Perform an action while preserving the names from the @Environment@. -preservingNames :: (Functor m, MonadState CheckState m) => m a -> m a +preservingNames :: (MonadState CheckState m) => m a -> m a preservingNames action = do orig <- gets (names . checkEnv) a <- action @@ -161,7 +161,7 @@ preservingNames action = do -- | Lookup the type of a value by name in the @Environment@ lookupVariable - :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) + :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type @@ -173,7 +173,7 @@ lookupVariable currentModule (Qualified moduleName var) = do -- | Lookup the visibility of a value by name in the @Environment@ getVisibility - :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) + :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility @@ -185,7 +185,7 @@ getVisibility currentModule (Qualified moduleName var) = do -- | Assert that a name is visible checkVisibility - :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) + :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m () @@ -197,7 +197,7 @@ checkVisibility currentModule name@(Qualified _ var) = do -- | Lookup the kind of a type by name in the @Environment@ lookupTypeVariable - :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) + :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified (ProperName 'TypeName) -> m Kind @@ -208,7 +208,7 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do Just (k, _) -> return k -- | Get the current @Environment@ -getEnv :: (Functor m, MonadState CheckState m) => m Environment +getEnv :: (MonadState CheckState m) => m Environment getEnv = checkEnv <$> get -- | Update the @Environment@ @@ -234,14 +234,14 @@ guardWith e False = throwError e -- | Run a computation in the substitution monad, generating a return value and the final substitution. liftUnify :: - (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => + (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => m a -> m (a, Substitution) liftUnify = liftUnifyWarnings (const id) -- | Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values. liftUnifyWarnings :: - (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => + (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => (Substitution -> ErrorMessage -> ErrorMessage) -> m a -> m (a, Substitution) diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs index bf10f36ea8..ba07ba304b 100644 --- a/src/Language/PureScript/TypeChecker/Rows.hs +++ b/src/Language/PureScript/TypeChecker/Rows.hs @@ -36,7 +36,7 @@ import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types -- | Ensure rows do not contain duplicate labels -checkDuplicateLabels :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m () +checkDuplicateLabels :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m () checkDuplicateLabels = let (_, f, _) = everywhereOnValuesM def go def in void . f diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index a345c08c6b..f302cd57a2 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -53,7 +53,7 @@ newSkolemConstant = do -- | -- Introduce skolem scope at every occurence of a ForAll -- -introduceSkolemScope :: (Functor m, Applicative m, MonadState CheckState m) => Type -> m Type +introduceSkolemScope :: (MonadState CheckState m) => Type -> m Type introduceSkolemScope = everywhereOnTypesM go where go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope) diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 023642e9ea..fceef79822 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -39,11 +39,11 @@ import Language.PureScript.TypeChecker.Unify import Language.PureScript.Types -- | Check that one type subsumes another, rethrowing errors to provide a better error message -subsumes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr) +subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr) subsumes val ty1 ty2 = rethrow (addHint (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2 -- | Check tahat one type subsumes another -subsumes' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => +subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index ae85eee0cf..b2600cc067 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -57,7 +57,7 @@ replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try go c args (TypeApp f arg) = go (c + 1) (arg : args) f go _ _ _ = return Nothing -replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type +replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => Type -> m Type replaceAllTypeSynonyms d = do env <- getEnv either throwError return $ replaceAllTypeSynonyms' env d diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index e9646f34d1..fa8f7a332c 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -61,7 +61,7 @@ import Language.PureScript.Types -- | Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. typesOf :: - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> [(Ident, Expr)] -> m [(Ident, (Expr, Type))] @@ -93,7 +93,7 @@ type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) type UntypedData = [(Ident, Type)] typeDictionaryForBindingGroup :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> [(Ident, Expr)] -> m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData) @@ -118,7 +118,7 @@ typeDictionaryForBindingGroup moduleName vals = do return (untyped, typed, dict, untypedDict) checkTypedBindingGroupElement :: - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> @@ -137,7 +137,7 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do return (ident, (val'', ty'')) typeForBindingGroupElement :: - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Bool -> (Ident, Expr) -> TypeData -> @@ -168,7 +168,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' -- | Replace type class dictionary placeholders with inferred type class dictionaries replaceTypeClassDictionaries :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> Expr -> m Expr @@ -181,7 +181,7 @@ replaceTypeClassDictionaries mn = -- | Check the kind of a type, failing if it is not of kind *. checkTypeKind :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) => + (MonadState CheckState m, MonadError MultipleErrors m) => Type -> Kind -> m () @@ -193,7 +193,7 @@ checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind = -- This is necessary during type checking to avoid unifying a polymorphic type with a -- unification variable. instantiatePolyTypeWithUnknowns :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) => + (MonadState CheckState m, MonadError MultipleErrors m) => Expr -> Type -> m (Expr, Type) @@ -207,14 +207,14 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty) -- | Infer a type for a value, rethrowing any error to provide a more useful error message infer :: - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> m Expr infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val -- | Infer a type for a value infer' :: - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> m Expr infer' v@(Literal (NumericLiteral (Left _))) = return $ TypedValue True v tyInt @@ -303,7 +303,7 @@ infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do infer' _ = internalError "Invalid argument to infer" inferLetBinding :: - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] -> [Declaration] -> Expr -> @@ -341,7 +341,7 @@ inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding" -- | Infer the types of variables brought into scope by a binder inferBinder :: forall m. - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Type -> Binder -> m (M.Map Ident Type) @@ -420,7 +420,7 @@ binderRequiresMonotype _ = True -- | Instantiate polytypes only when necessitated by a binder. instantiateForBinders :: - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Expr] -> [CaseAlternative] -> m ([Expr], [Type]) @@ -437,7 +437,7 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do -- Check the types of the return values in a set of binders in a case statement -- checkBinders :: - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Type] -> Type -> [CaseAlternative] -> @@ -467,7 +467,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do -- Check the type of a value, rethrowing errors to provide a better error message -- check :: - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> Type -> m Expr @@ -478,7 +478,7 @@ check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty -- check' :: forall m - . (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> Type -> m Expr @@ -641,7 +641,7 @@ check' val ty = do -- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case. -- checkProperties :: - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> [(String, Expr)] -> Type -> @@ -673,7 +673,7 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh -- | Check the type of a function application, rethrowing errors to provide a better error message checkFunctionApplication :: - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> Type -> Expr -> @@ -685,7 +685,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication -- | Check the type of a function application checkFunctionApplication' :: - (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> Type -> Expr -> @@ -723,7 +723,7 @@ checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApply -- | Compute the meet of two types, i.e. the most general type which both types subsume. -- TODO: is this really needed? meet :: - (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) => + (MonadState CheckState m, MonadError MultipleErrors m) => Expr -> Expr -> Type -> diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 92d7b7f56b..0aea0a1126 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -56,7 +56,7 @@ freshType = do return $ TUnknown t -- | Update the substitution to solve a type constraint -solveType :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Type -> m () +solveType :: (MonadError MultipleErrors m, MonadState CheckState m) => Int -> Type -> m () solveType u t = do occursCheck u t modify $ \cs -> cs { checkSubstitution = @@ -77,7 +77,7 @@ substituteType sub = everywhereOnTypes go go other = other -- | Make sure that an unknown does not occur in a type -occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Type -> m () +occursCheck :: (MonadError MultipleErrors m) => Int -> Type -> m () occursCheck _ TUnknown{} = return () occursCheck u t = void $ everywhereOnTypesM go t where @@ -93,7 +93,7 @@ unknownsInType t = everythingOnTypes (.) go t [] go _ = id -- | Unify two types, updating the current substitution -unifyTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m () +unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m () unifyTypes t1 t2 = do sub <- gets checkSubstitution rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ unifyTypes' (substituteType sub t1) (substituteType sub t2) @@ -139,7 +139,7 @@ unifyTypes t1 t2 = do -- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification -- error. -- -unifyRows :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m () +unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m () unifyRows r1 r2 = let (s1, r1') = rowToList r1 @@ -205,7 +205,7 @@ replaceVarWithUnknown ident ty = do -- | -- Replace type wildcards with unknowns -- -replaceTypeWildcards :: (Functor m, Applicative m, MonadWriter MultipleErrors m, MonadState CheckState m) => Type -> m Type +replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState CheckState m) => Type -> m Type replaceTypeWildcards = everywhereOnTypesM replace where replace TypeWildcard = do diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index f2505ed2c6..925095b1e3 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -248,7 +248,7 @@ everywhereOnTypesTopDown f = go . f go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t)) go other = f other -everywhereOnTypesM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type +everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type everywhereOnTypesM f = go where go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f @@ -261,7 +261,7 @@ everywhereOnTypesM f = go go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f go other = f other -everywhereOnTypesTopDownM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) -> Type -> m Type +everywhereOnTypesTopDownM :: Monad m => (Type -> m Type) -> Type -> m Type everywhereOnTypesTopDownM f = go <=< f where go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go) From 02271bf2c51aec3838765d9e51877008a72a5a6d Mon Sep 17 00:00:00 2001 From: Steve Date: Thu, 3 Mar 2016 22:23:15 +0800 Subject: [PATCH 0327/1580] Upgrade optparse-applicative to >= 0.12.1 for all executables. The upgraded library fixes issue #1838 - better errors for unrecognised command line options. --- purescript.cabal | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 941b9207da..4287479e8e 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -228,7 +228,7 @@ library executable psc build-depends: base >=4 && <5, base-compat >=0.6.0, containers -any, directory -any, filepath -any, - mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any, + mtl -any, optparse-applicative >= 0.12.1, parsec -any, purescript -any, time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8, aeson >= 0.8 && < 0.12, bytestring -any, utf8-string >= 1 && < 2 main-is: Main.hs @@ -239,7 +239,7 @@ executable psc executable psci build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, - mtl -any, optparse-applicative >= 0.10.0, parsec -any, + mtl -any, optparse-applicative >= 0.12.1, parsec -any, haskeline >= 0.7.0.0, purescript -any, transformers -any, transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0, boxes >= 0.1.4 && < 0.2.0 @@ -262,7 +262,7 @@ executable psci executable psc-docs build-depends: base >=4 && <5, purescript -any, - optparse-applicative >= 0.10.0, process -any, mtl -any, + optparse-applicative >= 0.12.1, process -any, mtl -any, split -any, ansi-wl-pprint -any, directory -any, filepath -any, Glob -any, transformers -any, transformers-compat -any @@ -284,7 +284,7 @@ executable psc-publish ghc-options: -Wall -O2 executable psc-hierarchy - build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0, + build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.12.1, process -any, mtl -any, parsec -any, filepath -any, directory -any, Glob -any main-is: Main.hs @@ -305,7 +305,7 @@ executable psc-bundle mtl -any, transformers -any, transformers-compat -any, - optparse-applicative >= 0.10.0, + optparse-applicative >= 0.12.1, Glob -any ghc-options: -Wall -O2 hs-source-dirs: psc-bundle @@ -323,7 +323,7 @@ executable psc-ide-server , transformers -any , transformers-compat -any , network -any - , optparse-applicative >= 0.10.0 + , optparse-applicative >= 0.12.1 , stm -any , text -any , base-compat >=0.6.0 @@ -337,7 +337,7 @@ executable psc-ide-client build-depends: base >=4 && <5 , mtl -any , text -any - , optparse-applicative >= 0.10.0 + , optparse-applicative >= 0.12.1 , network -any , base-compat >=0.6.0 ghc-options: -Wall -O2 From 6bb8d5e4cd02079d7cedf30e390e690ae2c1b39f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 12 Mar 2016 18:33:28 -0800 Subject: [PATCH 0328/1580] Fix #1889, improve performance by avoiding whitespace operations on large strings --- src/Language/PureScript/Errors.hs | 21 ++++++++++--------- .../PureScript/Publish/ErrorsWarnings.hs | 2 +- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 94f16f5496..3cb82cc830 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1181,31 +1181,32 @@ prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref -- Pretty print multiple errors -- prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String -prettyPrintMultipleErrors full = renderBox . prettyPrintMultipleErrorsBox full +prettyPrintMultipleErrors full = unlines . map renderBox . prettyPrintMultipleErrorsBox full -- | -- Pretty print multiple warnings -- -prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String -prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox full +prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String +prettyPrintMultipleWarnings full = unlines . map renderBox . prettyPrintMultipleWarningsBox full -- | Pretty print warnings as a Box -prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box +prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> [Box.Box] prettyPrintMultipleWarningsBox full = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full -- | Pretty print errors as a Box -prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box +prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box] prettyPrintMultipleErrorsBox full = prettyPrintMultipleErrorsWith Error "Error found:" "Error" full -prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> Box.Box +prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box] prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = let result = prettyPrintSingleError full level True e - in Box.vcat Box.left [ Box.text intro - , result - ] + in [ Box.vcat Box.left [ Box.text intro + , result + ] + ] prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = let result = map (prettyPrintSingleError full level True) es - in Box.vsep 1 Box.left $ concat $ zipWith withIntro [1 :: Int ..] result + in concat $ zipWith withIntro [1 :: Int ..] result where withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":") , Box.moveRight 2 err diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index baec5aad69..4e7258fb9f 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -190,7 +190,7 @@ displayUserError e = case e of CompileError err -> vcat [ para "Compile error:" - , indented (P.prettyPrintMultipleErrorsBox False err) + , indented (vcat (P.prettyPrintMultipleErrorsBox False err)) ] DirtyWorkingTree -> para ( From 209d8f509e282e2d2151dfb9d08dc36422e09749 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 13 Mar 2016 02:34:56 +0000 Subject: [PATCH 0329/1580] Try Trusty dist for Travis --- .travis.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 131f162114..7758098083 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,5 +1,6 @@ language: c -sudo: false +dist: trusty +sudo: required matrix: include: - env: GHCVER=7.10.3 CABALVER=1.22 STACKAGE=lts-5.4 RUNSDISTTESTS=YES From f8b2780b3b8da1a839f26e93b14d88a83c67e8a1 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 13 Mar 2016 13:11:12 -0700 Subject: [PATCH 0330/1580] Revert "Fix indentation bug #1881" --- examples/failing/1881.purs | 6 ------ examples/passing/1881.purs | 17 ----------------- src/Language/PureScript/Parser/Declarations.hs | 1 - 3 files changed, 24 deletions(-) delete mode 100644 examples/failing/1881.purs delete mode 100644 examples/passing/1881.purs diff --git a/examples/failing/1881.purs b/examples/failing/1881.purs deleted file mode 100644 index aee7bd5100..0000000000 --- a/examples/failing/1881.purs +++ /dev/null @@ -1,6 +0,0 @@ --- @shouldFailWith ErrorParsingModule -module Main where - -foo = -bar :: Int -bar = 3 diff --git a/examples/passing/1881.purs b/examples/passing/1881.purs deleted file mode 100644 index 325e761699..0000000000 --- a/examples/passing/1881.purs +++ /dev/null @@ -1,17 +0,0 @@ -module Main where - -foo = - 1 - -bar - = 2 - -baz - = - 3 - -qux - = - 3 - -main = Control.Monad.Eff.Console.log "Done" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index bf7b96c1bb..930f07c854 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -93,7 +93,6 @@ parseValueDeclaration = do where parseValueWithWhereClause :: TokenParser Expr parseValueWithWhereClause = do - C.indented value <- parseValue whereClause <- P.optionMaybe $ do C.indented From 2ad297cd7698c5296ccd704c8f0da8a43c2d861c Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 13 Mar 2016 23:24:25 +0000 Subject: [PATCH 0331/1580] Expose hiding import suggestion in JSON --- src/Language/PureScript/Errors.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 3cb82cc830..3ebf72b2ee 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -447,6 +447,7 @@ errorSuggestion err = case err of UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) + HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing _ -> Nothing where @@ -955,9 +956,9 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , indent $ line $ showSuggestion msg ] - renderSimpleErrorMessage (HidingImport mn refs) = + renderSimpleErrorMessage msg@(HidingImport mn _) = paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: " - , indent $ line $ "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" + , indent $ line $ showSuggestion msg ] renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) = From 8735fb0d326305bc568ca1048c30fbe126596831 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Mon, 14 Mar 2016 22:56:51 +0000 Subject: [PATCH 0332/1580] Default require path to ../, warn from psc --- psc-bundle/Main.hs | 3 +-- psc/Main.hs | 2 +- src/Language/PureScript/Bundle.hs | 2 +- src/Language/PureScript/CodeGen/JS.hs | 2 +- src/Language/PureScript/Errors.hs | 5 +++++ src/Language/PureScript/Make.hs | 3 +++ 6 files changed, 12 insertions(+), 5 deletions(-) diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index 31dc89e863..834ac5c78c 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -119,8 +119,7 @@ options = Options <$> some inputFile requirePath = strOption $ short 'r' <> long "require-path" - <> Opts.value "" - <> help "The path prefix used in require() calls in the generated JavaScript" + <> help "The path prefix used in require() calls in the generated JavaScript [deprecated]" -- | Make it go. main :: IO () diff --git a/psc/Main.hs b/psc/Main.hs index 3ea11b6e75..fc90127404 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -138,7 +138,7 @@ requirePath :: Parser (Maybe FilePath) requirePath = optional $ strOption $ short 'r' <> long "require-path" - <> help "The path prefix to use for require() calls in the generated JavaScript" + <> help "The path prefix to use for require() calls in the generated JavaScript [deprecated]" noTco :: Parser Bool noTco = switch $ diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index fdd122f905..38caa2d4a1 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -141,7 +141,7 @@ checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String checkImportPath _ "./foreign" m _ = Right (ModuleIdentifier (moduleName m) Foreign) checkImportPath requirePath name _ names - | Just name' <- stripPrefix (fromMaybe "" requirePath) name + | Just name' <- stripPrefix (fromMaybe "../" requirePath) name , name' `S.member` names = Right (ModuleIdentifier name' Regular) checkImportPath _ name _ _ = Left name diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index e3634d649d..7c4fbb6a2c 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -111,7 +111,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = importToJs mnLookup mn' = do path <- asks optionsRequirePath let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (maybe id () path $ runModuleName mn')] + let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (fromMaybe ".." path runModuleName mn')] withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody) -- | diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 3cb82cc830..f6dac6b88f 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -148,6 +148,7 @@ data SimpleErrorMessage | CaseBinderLengthDiffers Int [Binder] | IncorrectAnonymousArgument | InvalidOperatorInBinder Ident Ident + | DeprecatedRequirePath deriving (Show) -- | Error message hints, providing more detailed information about failure. @@ -328,6 +329,7 @@ errorCode em = case unwrapErrorMessage em of CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers" IncorrectAnonymousArgument -> "IncorrectAnonymousArgument" InvalidOperatorInBinder{} -> "InvalidOperatorInBinder" + DeprecatedRequirePath{} -> "DeprecatedRequirePath" -- | -- A stack trace for an error @@ -974,6 +976,9 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , line "Only aliases for data constructors may be used in patterns." ] + renderSimpleErrorMessage DeprecatedRequirePath = + line "The require-path option is deprecated and will be removed in PureScript 0.9." + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 4221a80008..a06c556b8d 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -150,6 +150,9 @@ make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadE -> [Module] -> m Environment make MakeActions{..} ms = do + requirePath <- asks optionsRequirePath + when (requirePath /= Nothing) $ tell $ errorMessage DeprecatedRequirePath + checkModuleNamesAreUnique (sorted, graph) <- sortModules ms From 55731aaab7ffb675c1c55b2524e96f62ffd7f154 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Mon, 14 Mar 2016 23:31:03 +0000 Subject: [PATCH 0333/1580] Add -r deprecation warning to psc-bundle --- psc-bundle/Main.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index 834ac5c78c..eab72f4888 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -125,6 +125,7 @@ options = Options <$> some inputFile main :: IO () main = do opts <- execParser (info (version <*> helper <*> options) infoModList) + when (optionsRequirePath opts /= Nothing) $ hPutStrLn stderr "The require-path option is deprecated and will be removed in PureScript 0.9." output <- runExceptT (app opts) case output of Left err -> do From 9cd8b3b8aa526246a0322de54b24377967f98f44 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 17 Mar 2016 01:17:34 +0000 Subject: [PATCH 0334/1580] Bump dependency on bower-json bower-json-0.8.0 fixes parsing of license, main, and moduleType fields. In particular, we need the license field for #1714. --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 4287479e8e..9de851aeda 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -68,7 +68,7 @@ library boxes >= 0.1.4 && < 0.2.0, aeson >= 0.8 && < 0.12, vector -any, - bower-json >= 0.7, + bower-json >= 0.8, aeson-better-errors >= 0.8, bytestring -any, text -any, From 25c0e6b5a7bc7bf303fd40eb2a0f72f3cc2629af Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 17 Mar 2016 01:23:58 +0000 Subject: [PATCH 0335/1580] Don't use Stackage versions of bower-json --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 7758098083..47ba7ac827 100644 --- a/.travis.yml +++ b/.travis.yml @@ -36,7 +36,7 @@ install: - mkdir -p .cabal-sandbox - cabal sandbox init --sandbox .cabal-sandbox # Download stackage cabal.config, not sure whether filtering is necessary - - if [ -n "$STACKAGE" ]; then curl https://www.stackage.org/$STACKAGE/cabal.config | egrep -v 'purescript|sourcemap' > cabal.config; fi + - if [ -n "$STACKAGE" ]; then curl https://www.stackage.org/$STACKAGE/cabal.config | egrep -v 'purescript|sourcemap|bower-json' > cabal.config; fi - cabal install --only-dependencies --enable-tests - cabal install hpc-coveralls # Snapshot state of the sandbox now, so we don't need to make new one for test install From d82aef5473bb2e19f853665bad960ec7dabe07af Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 17 Mar 2016 01:52:59 +0000 Subject: [PATCH 0336/1580] Add bower-json to extra-deps --- stack-lts-5.yaml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/stack-lts-5.yaml b/stack-lts-5.yaml index 34bfedcd16..2671991235 100644 --- a/stack-lts-5.yaml +++ b/stack-lts-5.yaml @@ -1,5 +1,6 @@ resolver: lts-5.4 packages: - '.' -extra-deps: [] +extra-deps: +- bower-json-0.8.0 flags: {} From 7d69a33183447ab235808030b4c909548fcc8fd1 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 17 Mar 2016 21:30:14 +0000 Subject: [PATCH 0337/1580] Update stackage nightly This stackage nightly is the first to contain bower-json-0.8.0, so this commit allows purescript to build with stack-nightly.yaml. --- stack-nightly.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 2a5da385e4..c389d15f15 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -2,4 +2,4 @@ flags: {} packages: - '.' extra-deps: [] -resolver: nightly-2016-02-25 +resolver: nightly-2016-03-17 From 0c5b8cc79233f59b2092ec035aec349776467019 Mon Sep 17 00:00:00 2001 From: faineance Date: Thu, 17 Mar 2016 22:36:15 +0000 Subject: [PATCH 0338/1580] various fixes --- license-generator/generate.hs | 2 +- psc-bundle/Main.hs | 3 ++- psc-docs/Main.hs | 4 ++-- psci/PSCi.hs | 2 +- src/Control/Monad/Supply/Class.hs | 2 +- src/Language/PureScript/CodeGen/JS.hs | 6 +++--- src/Language/PureScript/CodeGen/JS/Common.hs | 2 +- .../PureScript/CodeGen/JS/Optimizer/Inliner.hs | 6 +++--- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- src/Language/PureScript/Docs/Convert.hs | 2 -- src/Language/PureScript/Docs/Convert/ReExports.hs | 6 ++---- src/Language/PureScript/Docs/Convert/Single.hs | 7 +++---- src/Language/PureScript/Errors.hs | 15 ++++++++------- src/Language/PureScript/Ide/CaseSplit.hs | 3 ++- src/Language/PureScript/Ide/State.hs | 11 +++++------ src/Language/PureScript/Ide/Types.hs | 1 - src/Language/PureScript/Linter/Imports.hs | 2 +- src/Language/PureScript/Make.hs | 7 +++---- src/Language/PureScript/Parser/Declarations.hs | 1 - src/Language/PureScript/Pretty/Common.hs | 2 +- src/Language/PureScript/Pretty/JS.hs | 3 +-- src/Language/PureScript/Sugar/Names/Exports.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 2 +- src/Language/PureScript/TypeChecker/Monad.hs | 1 - 24 files changed, 43 insertions(+), 51 deletions(-) diff --git a/license-generator/generate.hs b/license-generator/generate.hs index ac2292501c..6980c3cfb6 100644 --- a/license-generator/generate.hs +++ b/license-generator/generate.hs @@ -27,7 +27,7 @@ depsLicense dep = do putStrLn "" putStrLn $ f license where - f = unlines . map trimEnd . map (" " ++) . lines + f = unlines . map (trimEnd . (" " ++)) . lines trimEnd = reverse . dropWhile isSpace . reverse main :: IO () diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index eab72f4888..f97e36f3f9 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -19,6 +19,7 @@ module Main (main) where +import Data.Maybe import Data.Traversable (for) import Data.Version (showVersion) @@ -125,7 +126,7 @@ options = Options <$> some inputFile main :: IO () main = do opts <- execParser (info (version <*> helper <*> options) infoModList) - when (optionsRequirePath opts /= Nothing) $ hPutStrLn stderr "The require-path option is deprecated and will be removed in PureScript 0.9." + when (isJust (optionsRequirePath opts)) $ hPutStrLn stderr "The require-path option is deprecated and will be removed in PureScript 0.9." output <- runExceptT (app opts) case output of Left err -> do diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index 6374dff209..70650c8b23 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -32,7 +32,7 @@ import qualified Text.PrettyPrint.ANSI.Leijen as PP import qualified Language.PureScript as P import qualified Paths_purescript as Paths import System.Exit (exitFailure) -import System.IO (hPutStrLn, stderr) +import System.IO (hPutStrLn, hPrint, stderr) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) import System.FilePath.Glob (glob) @@ -139,7 +139,7 @@ dumpTags input renderTags = do e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input) case e of Left err -> do - hPutStrLn stderr (show err) + hPrint stderr err exitFailure Right ms -> ldump (renderTags (pairs ms)) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 5a21193c54..756149449c 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -337,7 +337,7 @@ handleKindOf typ = do k = check (P.kindOf typ') chk check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState) - check sew cs = fst . runWriter . runExceptT . runStateT sew $ cs + check sew = fst . runWriter . runExceptT . runStateT sew case k of Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index 02c185a8a5..8621e2e2db 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -21,4 +21,4 @@ instance (MonadSupply m) => MonadSupply (StateT s m) where fresh = lift fresh freshName :: (MonadSupply m) => m String -freshName = liftM (('$' :) . show) fresh +freshName = fmap (('$' :) . show) fresh diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 7c4fbb6a2c..d4a1e8fc02 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -55,7 +55,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps - jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd $ imps + jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd imps let decls' = renameModules mnLookup decls jsDecls <- mapM bindToJs decls' optimized <- T.traverse (T.traverse optimize) jsDecls @@ -67,7 +67,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = let moduleBody = header : foreign' ++ jsImports ++ concat optimized let foreignExps = exps `intersect` (fst `map` foreigns) let standardExps = exps \\ foreignExps - let exps' = JSObjectLiteral Nothing $ map (runIdent &&& (JSVar Nothing) . identToJs) standardExps + let exps' = JSObjectLiteral Nothing $ map (runIdent &&& JSVar Nothing . identToJs) standardExps ++ map (runIdent &&& foreignIdent) foreignExps return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps'] @@ -85,7 +85,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- with declaration names. -- renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName) - renameImports ids mns = go M.empty ids mns + renameImports = go M.empty where go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName) go acc used ((ann, mn') : mns') = diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 8c004b3dd9..720d829aea 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -78,7 +78,7 @@ nameIsJsReserved name = -- nameIsJsBuiltIn :: String -> Bool nameIsJsBuiltIn name = - elem name + name `elem` [ "arguments" , "Array" , "ArrayBuffer" diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index c022f1d9e5..bcc2b395b3 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -96,9 +96,9 @@ inlineCommonValues = everywhereOnJS convert fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)] fnBottom = [(C.prelude, C.bottom), (C.dataBounded, C.bottom)] fnTop = [(C.prelude, C.top), (C.dataBounded, C.top)] - fnAdd = [(C.prelude, (C.+)), (C.prelude, (C.add)), (C.dataSemiring, (C.+)), (C.dataSemiring, (C.add))] - fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataModuloSemiring, C.div)] - fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))] + fnAdd = [(C.prelude, (C.+)), (C.prelude, C.add), (C.dataSemiring, (C.+)), (C.dataSemiring, C.add)] + fnDivide = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataModuloSemiring, C.div)] + fnMultiply = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, (C.*)), (C.dataSemiring, C.mul)] fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)] intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0)) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 9f5b4c4893..0c86329de2 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -144,7 +144,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann binderToCoreFn ss com (A.LiteralBinder lit) = LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit) - binderToCoreFn ss com (A.NullBinder) = + binderToCoreFn ss com A.NullBinder = NullBinder (ss, com, Nothing, Nothing) binderToCoreFn ss com (A.VarBinder name) = VarBinder (ss, com, Nothing, Nothing) name diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 9678ecce66..2cb83cb275 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -1,7 +1,5 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} -- | Functions for converting PureScript ASTs into values of the data types diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index e9473f51c5..0c67f885ff 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} @@ -217,8 +216,7 @@ lookupValueDeclaration importedFrom ident = do pure (importedFrom, [Left r']) other -> errOther other - other -> do - errOther other + other -> errOther other where thd :: (a, b, c) -> c @@ -381,7 +379,7 @@ handleEnv TypeClassEnv{..} = promoteChild constraint ChildDeclaration{..} = case cdeclInfo of ChildTypeClassMember typ -> - pure $ Declaration + pure Declaration { declTitle = cdeclTitle , declComments = cdeclComments , declSourceSpan = cdeclSourceSpan diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index cade0ec68d..fd9845c25c 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -11,11 +11,10 @@ module Language.PureScript.Docs.Convert.Single import Prelude () import Prelude.Compat -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe, isNothing) import Control.Monad import Control.Category ((>>>)) -import Data.Maybe (mapMaybe, isNothing) import Data.Either import Data.List (nub, isPrefixOf, isSuffixOf) @@ -137,7 +136,7 @@ basicDeclaration title info = Just $ Right $ mkDeclaration title info convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title = basicDeclaration title (ValueDeclaration ty) -convertDeclaration (P.ValueDeclaration _ _ _ _) title = +convertDeclaration (P.ValueDeclaration {}) title = -- If no explicit type declaration was provided, insert a wildcard, so that -- the actual type will be added during type checking. basicDeclaration title (ValueDeclaration P.TypeWildcard) @@ -205,7 +204,7 @@ convertDeclaration _ _ = Nothing convertComments :: [P.Comment] -> Maybe String convertComments cs = do let raw = concatMap toLines cs - let docs = catMaybes (map stripPipe raw) + let docs = mapMaybe stripPipe raw guard (not (null docs)) pure (unlines docs) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6c78672d9a..c6bdb149fd 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -637,7 +637,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap renderSimpleErrorMessage (CycleInDeclaration nm) = line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = - paras [ line $ "There is a cycle in module dependencies in these modules: " + paras [ line "There is a cycle in module dependencies in these modules: " , indent $ paras (map (line . runModuleName) mns) ] renderSimpleErrorMessage (CycleInTypeSynonym name) = @@ -671,7 +671,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap sortRows' :: ([(String, Type)], Type) -> ([(String, Type)], Type) -> (Type, Type) sortRows' (s1, r1) (s2, r2) = let common :: [(String, (Type, Type))] - common = sortBy (comparing fst) $ [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] + common = sortBy (comparing fst) [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] sd1, sd2 :: [(String, Type)] sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] @@ -840,8 +840,9 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap paras [ line "A case expression could not be determined to cover all inputs." , line "The following additional cases are required to cover all inputs:\n" , indent $ paras $ - [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ] - ++ [ line "..." | not b ] + Box.hsep 1 Box.left + (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) + : [line "..." | not b] , line "Or alternatively, add a Partial constraint to the type of the enclosing value." , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9." ] @@ -973,7 +974,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap line "An anonymous function argument appears in an invalid context." renderSimpleErrorMessage (InvalidOperatorInBinder op fn) = - paras $ [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "." + paras [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "." , line "Only aliases for data constructors may be used in patterns." ] @@ -1197,11 +1198,11 @@ prettyPrintMultipleWarnings full = unlines . map renderBox . prettyPrintMultiple -- | Pretty print warnings as a Box prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> [Box.Box] -prettyPrintMultipleWarningsBox full = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full +prettyPrintMultipleWarningsBox = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" -- | Pretty print errors as a Box prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box] -prettyPrintMultipleErrorsBox full = prettyPrintMultipleErrorsWith Error "Error found:" "Error" full +prettyPrintMultipleErrorsBox = prettyPrintMultipleErrorsWith Error "Error found:" "Error" prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box] prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index d82610eec7..92fa4e946e 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -19,6 +19,7 @@ module Language.PureScript.Ide.CaseSplit import Prelude () import Prelude.Compat hiding (lex) +import Control.Arrow (second) import Control.Monad.Error.Class import "monad-logger" Control.Monad.Logger import Data.List (find) @@ -57,7 +58,7 @@ caseSplit q = do (tc, args) <- splitTypeConstructor (parseType' (T.unpack q)) (EDType _ _ (DataType typeVars ctors)) <- findTypeDeclaration tc let applyTypeVars = everywhereOnTypes (replaceAllTypeVars (zip (map fst typeVars) args)) - let appliedCtors = map (\(n, ts) -> (n, map applyTypeVars ts)) ctors + let appliedCtors = map (second (map applyTypeVars)) ctors pure appliedCtors findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 5daf19cf2d..80791c2756 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -72,9 +72,8 @@ insertModule externsFile = do liftIO . atomically $ insertModule' (envStateVar env) externsFile insertModule' :: TVar PscIdeState -> ExternsFile -> STM () -insertModule' st ef = do - modifyTVar st $ \x -> - x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x) - , pscStateModules = let (mn, decls) = convertExterns ef - in M.insert mn decls (pscStateModules x) - } +insertModule' st ef = modifyTVar st $ \x -> + x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x) + , pscStateModules = let (mn, decls) = convertExterns ef + in M.insert mn decls (pscStateModules x) + } diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index badc7d4fef..8692e69dd2 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Ide.Types where diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 25819db068..446ede2f30 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -152,7 +152,7 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do in foldr go used (classes ++ types ++ dctors ++ values) where go :: (ModuleName, Name) -> UsedImports -> UsedImports - go (q, name) acc = M.alter (Just . maybe [name] (name :)) q acc + go (q, name) = M.alter (Just . maybe [name] (name :)) q extractByQual :: (Eq a) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index a06c556b8d..ddc0d109ac 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -40,7 +40,7 @@ import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Concurrent.Lifted as C import Data.List (foldl', sort) -import Data.Maybe (fromMaybe, catMaybes) +import Data.Maybe (fromMaybe, catMaybes, isJust) import Data.Time.Clock import Data.String (fromString) import Data.Foldable (for_) @@ -151,7 +151,7 @@ make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadE -> m Environment make MakeActions{..} ms = do requirePath <- asks optionsRequirePath - when (requirePath /= Nothing) $ tell $ errorMessage DeprecatedRequirePath + when (isJust requirePath) $ tell $ errorMessage DeprecatedRequirePath checkModuleNamesAreUnique @@ -364,8 +364,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = , mapSourceFile = sourceFile , mapGenerated = convertPos $ add (extraLines+1) 0 gen , mapName = Nothing - }) $ - mappings + }) mappings } let mapping = generate rawMapping writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 930f07c854..42d225354f 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -184,7 +184,6 @@ parseTypeClassDeclaration = do indented *> reserved "where" indented *> mark (P.many (same *> positioned parseTypeDeclaration)) return $ TypeClassDeclaration className idents implies members - where parseConstraint :: TokenParser Constraint parseConstraint = (,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom) diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 58aa9b2e88..c2ff4d4683 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -148,7 +148,7 @@ prettyPrintMany :: (Emit gen) => (a -> StateT PrinterState Maybe gen) -> [a] -> prettyPrintMany f xs = do ss <- mapM f xs indentString <- currentIndent - return $ intercalate (emit "\n") $ map (\s -> mappend indentString s) ss + return $ intercalate (emit "\n") $ map (mappend indentString) ss -- | -- Prints an object key, escaping reserved names. diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 5e8a654c86..5477361640 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -274,8 +274,7 @@ prettyPrintJSWithSourceMaps js = in (s, mp) prettyPrintJS :: [JS] -> String -prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . fmap runPlainString . flip evalStateT (PrinterState 0) . prettyStatements - +prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements -- | -- Generate an indented, pretty-printed string representing a Javascript expression -- diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 765cacd0a4..242b5a0586 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -164,7 +164,7 @@ resolveExports env mn imps exps refs = exps' <- envModuleExports <$> mn'' `M.lookup` env ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps') let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mn'' then Just dctor else Nothing) dctors - return ((name, intersect relevantDctors dctors'), mnOrig) + return ((name, relevantDctors `intersect` dctors'), mnOrig) go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports" diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index fa39cd157c..01f8522857 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -103,7 +103,7 @@ rebracket externs ms = do Nothing -> maybe id rethrowWithPosition pos $ throwError . errorMessage $ UnknownValue name - goBinder _ (BinaryNoParensBinder _ _ _) = + goBinder _ (BinaryNoParensBinder {}) = internalError "BinaryNoParensBinder has no OpBinder" goBinder pos other = return (pos, other) diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index e06466a119..adfe3c3860 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} From 0fc343d6aed1721cda2b6a67db7c713be2db90b6 Mon Sep 17 00:00:00 2001 From: faineance Date: Fri, 18 Mar 2016 08:36:47 +0000 Subject: [PATCH 0339/1580] more fixes --- src/Language/PureScript/TypeChecker/Monad.hs | 3 +-- tests/TestDocs.hs | 8 ++++---- tests/TestPscPublish.hs | 2 +- 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index adfe3c3860..e4ac9d875c 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -224,8 +224,7 @@ runCheck = runCheck' initEnvironment -- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@. runCheck' :: (Functor m) => Environment -> StateT CheckState m a -> m (a, Environment) -runCheck' env check = fmap (second checkEnv) $ runStateT check (emptyCheckState env) - +runCheck' env check = second checkEnv <$> runStateT check (emptyCheckState env) -- | Make an assertion, failing with an error message guardWith :: (MonadError e m) => e -> Bool -> m () guardWith _ True = return () diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 5fdb41618d..15bb01616b 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -35,10 +35,10 @@ main = do forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) -> let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn) (find ((==) mn . Docs.modName) pkgModules) - in forM_ pragmas (flip runAssertionIO mdl) + in forM_ pragmas (`runAssertionIO` mdl) takeJust :: String -> Maybe a -> a -takeJust msg = maybe (error msg) id +takeJust msg = fromMaybe (error msg) data Assertion -- | Assert that a particular declaration is documented with the given @@ -254,8 +254,8 @@ testCases = , ("ExplicitTypeSignatures", [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something")) - , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn ((==) P.tyInt)) - , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn ((==) P.tyNumber)) + , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==)) + , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==)) ]) ] diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 49321edff6..ccfcd9a4c4 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -62,5 +62,5 @@ testPackage dir = do pure () other -> do putStrLn ("psc-publish tests failed on " ++ dir ++ ":") - putStrLn (show other) + print other exitFailure From 6e14069f76e975b348185a32ea18aa537814a036 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 20 Mar 2016 16:22:53 +0100 Subject: [PATCH 0340/1580] escapes regexy chars when using the flexMatcher This stops the server from crashing on queries like "<*" --- src/Language/PureScript/Ide/Matcher.hs | 32 +++++++++++++++++--------- 1 file changed, 21 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index 56a8138d63..65244a6d32 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -86,15 +86,25 @@ flexRate pattern c@(Completion (_,ident,_)) = do -- the matchas a (start, length) tuple if there's a match. -- If match fails then it would be (-1,0) flexScore :: Text -> DeclIdent -> Maybe Double -flexScore "" _ = Nothing flexScore pat str = - case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of - (-1,0) -> Nothing - (start,len) -> Just $ calcScore start (start + len) - where - Just (first,pattern) = T.uncons pat - -- This just interleaves the search string with .* - -- abcd -> a.*b.*c.*d - pat' = first `T.cons` T.concatMap (T.snoc ".*") pattern - calcScore start end = - 100.0 / fromIntegral ((1 + start) * (end - start + 1)) + case T.uncons pat of + Nothing -> Nothing + Just (first, pattern) -> + case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of + (-1,0) -> Nothing + (start,len) -> Just $ calcScore start (start + len) + where + escapedPattern :: [Text] + escapedPattern = map escape (T.unpack pattern) + + -- escape prepends a backslash to "regexy" characters to prevent the + -- matcher from crashing when trying to build the regex + escape :: Char -> Text + escape c = if c `elem` ("[\\^$.|?*+(){}" :: String) + then T.pack ['\\', c] + else T.singleton c + -- This just interleaves the search pattern with .* + -- abcd[*] -> a.*b.*c.*d.*[*] + pat' = escape first <> foldMap (<> ".*") escapedPattern + calcScore start end = + 100.0 / fromIntegral ((1 + start) * (end - start + 1)) From c9cbe4a32d5127a971816449496684390676b8c1 Mon Sep 17 00:00:00 2001 From: David Lindbom Date: Mon, 21 Mar 2016 17:36:43 +0100 Subject: [PATCH 0341/1580] Fix indentation bug #1881 --- examples/failing/1881.purs | 6 ++++++ examples/passing/1881.purs | 17 +++++++++++++++++ src/Language/PureScript/Parser/Declarations.hs | 1 + 3 files changed, 24 insertions(+) create mode 100644 examples/failing/1881.purs create mode 100644 examples/passing/1881.purs diff --git a/examples/failing/1881.purs b/examples/failing/1881.purs new file mode 100644 index 0000000000..aee7bd5100 --- /dev/null +++ b/examples/failing/1881.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +foo = +bar :: Int +bar = 3 diff --git a/examples/passing/1881.purs b/examples/passing/1881.purs new file mode 100644 index 0000000000..325e761699 --- /dev/null +++ b/examples/passing/1881.purs @@ -0,0 +1,17 @@ +module Main where + +foo = + 1 + +bar + = 2 + +baz + = + 3 + +qux + = + 3 + +main = Control.Monad.Eff.Console.log "Done" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 930f07c854..bf7b96c1bb 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -93,6 +93,7 @@ parseValueDeclaration = do where parseValueWithWhereClause :: TokenParser Expr parseValueWithWhereClause = do + C.indented value <- parseValue whereClause <- P.optionMaybe $ do C.indented From d1d1fb37897a36bb45eeb6a1118e84c435533bcc Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 23 Mar 2016 00:08:54 +0100 Subject: [PATCH 0342/1580] respond with an error instead of crashing If the user supplies a type that cannot be parsed --- src/Language/PureScript/Ide/CaseSplit.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index d82610eec7..2e54cdbd6e 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -54,7 +54,8 @@ noAnnotations = WildcardAnnotations False caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => Text -> m [Constructor] caseSplit q = do - (tc, args) <- splitTypeConstructor (parseType' (T.unpack q)) + type' <- parseType' (T.unpack q) + (tc, args) <- splitTypeConstructor type' (EDType _ _ (DataType typeVars ctors)) <- findTypeDeclaration tc let applyTypeVars = everywhereOnTypes (replaceAllTypeVars (zip (map fst typeVars) args)) let appliedCtors = map (\(n, ts) -> (n, map applyTypeVars ts)) ctors @@ -119,11 +120,14 @@ addClause s wca = " = ?" <> (T.strip . T.pack . runIdent $ fName) in [s, template] -parseType' :: String -> Type -parseType' s = let (Right t) = do - ts <- lex "" s - runTokenParser "" (parseType <* P.eof) ts - in t +parseType' :: (MonadError PscIdeError m) => + String -> m Type +parseType' s = + case lex "" s >>= runTokenParser "" (parseType <* P.eof) of + Right type' -> pure type' + Left err -> + throwError (GeneralError ("Parsing the splittype failed with:" + ++ show err)) parseTypeDeclaration' :: String -> (Ident, Type) parseTypeDeclaration' s = From 1b17b5c1bf5e78415b7b2e07c301581734900898 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 23 Mar 2016 16:29:55 +0100 Subject: [PATCH 0343/1580] Better error message for psc-publish tests * Uses Either instead of exitFailure inside preparePackage * Exposes a new unsafePreparePackage which is basically the old preparePackage. * Prints a suggestion to update the git submodules in case of an error inside prepare Package --- psc-publish/Main.hs | 4 ++-- src/Language/PureScript/Publish.hs | 12 +++++++--- .../PureScript/Publish/BoxesHelpers.hs | 3 +++ .../PureScript/Publish/ErrorsWarnings.hs | 4 ++++ tests/TestDocs.hs | 19 ++++++++------- tests/TestPscPublish.hs | 24 ++++++++++++++----- 6 files changed, 47 insertions(+), 19 deletions(-) diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs index 912f460c96..d7d397c467 100644 --- a/psc-publish/Main.hs +++ b/psc-publish/Main.hs @@ -38,8 +38,8 @@ publish :: Bool -> IO () publish isDryRun = if isDryRun then do - _ <- preparePackage dryRunOptions + _ <- unsafePreparePackage dryRunOptions putStrLn "Dry run completed, no errors." else do - pkg <- preparePackage defaultPublishOptions + pkg <- unsafePreparePackage defaultPublishOptions BL.putStrLn (A.encode pkg) diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 7666d8b2d2..e5f515d4bd 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -6,6 +6,7 @@ module Language.PureScript.Publish ( preparePackage , preparePackage' + , unsafePreparePackage , PrepareM() , runPrepareM , warn @@ -79,11 +80,16 @@ defaultPublishOptions = PublishOptions -- | Attempt to retrieve package metadata from the current directory. -- Calls exitFailure if no package metadata could be retrieved. -preparePackage :: PublishOptions -> IO D.UploadedPackage +unsafePreparePackage :: PublishOptions -> IO D.UploadedPackage +unsafePreparePackage opts = either (\e -> printError e >> exitFailure) pure =<< preparePackage opts + +-- | Attempt to retrieve package metadata from the current directory. +-- Returns a PackageError on failure +preparePackage :: PublishOptions -> IO (Either PackageError D.UploadedPackage) preparePackage opts = runPrepareM (preparePackage' opts) - >>= either (\e -> printError e >> exitFailure) - handleWarnings + >>= either (pure . Left) (fmap Right . handleWarnings) + where handleWarnings (result, warns) = do printWarnings warns diff --git a/src/Language/PureScript/Publish/BoxesHelpers.hs b/src/Language/PureScript/Publish/BoxesHelpers.hs index 3e214a6d92..169f094fc4 100644 --- a/src/Language/PureScript/Publish/BoxesHelpers.hs +++ b/src/Language/PureScript/Publish/BoxesHelpers.hs @@ -36,3 +36,6 @@ bulletedList f = map (indented . para . ("* " ++) . f) printToStderr :: Boxes.Box -> IO () printToStderr = hPutStr stderr . Boxes.render + +printToStdout :: Boxes.Box -> IO () +printToStdout = putStr . Boxes.render diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 4e7258fb9f..3765deeeaf 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -10,6 +10,7 @@ module Language.PureScript.Publish.ErrorsWarnings , RepositoryFieldError(..) , JSONSource(..) , printError + , printErrorToStdout , renderError , printWarnings , renderWarnings @@ -88,6 +89,9 @@ data OtherError printError :: PackageError -> IO () printError = printToStderr . renderError +printErrorToStdout :: PackageError -> IO () +printErrorToStdout = printToStdout . renderError + renderError :: PackageError -> Box renderError err = case err of diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 5fdb41618d..8361d45a17 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -18,6 +18,7 @@ import System.Exit import qualified Language.PureScript as P import qualified Language.PureScript.Docs as Docs import qualified Language.PureScript.Publish as Publish +import qualified Language.PureScript.Publish.ErrorsWarnings as Publish import TestUtils @@ -29,16 +30,18 @@ publishOpts = Publish.defaultPublishOptions where testVersion = ("v999.0.0", Version [999,0,0] []) main :: IO () -main = do - pushd "examples/docs" $ do - Docs.Package{..} <- Publish.preparePackage publishOpts - forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) -> - let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn) - (find ((==) mn . Docs.modName) pkgModules) - in forM_ pragmas (flip runAssertionIO mdl) +main = pushd "examples/docs" $ do + res <- Publish.preparePackage publishOpts + case res of + Left e -> Publish.printErrorToStdout e >> exitFailure + Right Docs.Package{..} -> + forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) -> + let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn) + (find ((==) mn . Docs.modName) pkgModules) + in forM_ pragmas (flip runAssertionIO mdl) takeJust :: String -> Maybe a -> a -takeJust msg = maybe (error msg) id +takeJust msg = fromMaybe (error msg) data Assertion -- | Assert that a particular declaration is documented with the given diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 49321edff6..a2df918dfc 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -19,12 +19,12 @@ import Data.Version import Language.PureScript.Docs import Language.PureScript.Publish +import Language.PureScript.Publish.ErrorsWarnings as Publish import TestUtils main :: IO () -main = do - testPackage "tests/support/prelude" +main = testPackage "tests/support/prelude" data TestResult = ParseFailed String @@ -53,10 +53,11 @@ testRunOptions = defaultPublishOptions -- | Given a directory which contains a package, produce JSON from it, and then -- | attempt to parse it again, and ensure that it doesn't change. testPackage :: String -> IO () -testPackage dir = do - pushd dir $ do - r <- roundTrip <$> preparePackage testRunOptions - case r of +testPackage dir = pushd dir $ do + res <- preparePackage testRunOptions + case res of + Left e -> preparePackageError e + Right package -> case roundTrip package of Pass _ -> do putStrLn ("psc-publish test passed for: " ++ dir) pure () @@ -64,3 +65,14 @@ testPackage dir = do putStrLn ("psc-publish tests failed on " ++ dir ++ ":") putStrLn (show other) exitFailure + where + preparePackageError e@(UserError BowerJSONNotFound) = do + Publish.printErrorToStdout e + putStrLn "" + putStrLn "==========================================" + putStrLn "Did you forget to update the submodules?" + putStrLn "$ git submodule sync; git submodule update" + putStrLn "==========================================" + putStrLn "" + exitFailure + preparePackageError e = Publish.printErrorToStdout e >> exitFailure From 2162c48f6eb5b6c6eacbdccb653529a4e73ba9ba Mon Sep 17 00:00:00 2001 From: faineance Date: Wed, 16 Mar 2016 21:45:47 +0000 Subject: [PATCH 0344/1580] Error on missing LICENSE file or if bower.json has no license --- CONTRIBUTORS.md | 1 + examples/docs/LICENSE | 1 + examples/docs/bower.json | 3 ++- purescript.cabal | 1 + src/Language/PureScript/Publish.hs | 22 +++++++++++++------ .../PureScript/Publish/ErrorsWarnings.hs | 15 +++++++++++++ 6 files changed, 35 insertions(+), 8 deletions(-) create mode 100644 examples/docs/LICENSE diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 6e334162bb..700c3c872f 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -24,6 +24,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@epost](https://github.com/epost) (Erik Post) - My existing contributions and all future contributions until further notice are Copyright Erik Post, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license - [@erdeszt](https://github.com/erdeszt) (Tibor Erdesz) My existing contributions and all future contributions until further notice are Copyright Tibor Erdesz, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@etrepum](https://github.com/etrepum) (Bob Ippolito) My existing contributions and all future contributions until further notice are Copyright Bob Ippolito, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@faineance](https://github.com/faineance) My existing contributions and all future contributions until further notice are Copyright faineance, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). diff --git a/examples/docs/LICENSE b/examples/docs/LICENSE new file mode 100644 index 0000000000..c993dba4ab --- /dev/null +++ b/examples/docs/LICENSE @@ -0,0 +1 @@ +This isn't a real license, it's just here for the sake of the tests. diff --git a/examples/docs/bower.json b/examples/docs/bower.json index f4f13d5d4c..fea039d8c5 100644 --- a/examples/docs/bower.json +++ b/examples/docs/bower.json @@ -15,5 +15,6 @@ "output" ], "dependencies": { - } + }, + "license": "replaceme" } diff --git a/purescript.cabal b/purescript.cabal index 9de851aeda..84c9af2243 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -23,6 +23,7 @@ extra-source-files: examples/passing/*.purs , examples/failing/*.purs , examples/docs/bower_components/purescript-prelude/src/*.purs , examples/docs/bower.json + , examples/docs/LICENSE , examples/docs/src/*.purs , tests/support/setup.js , tests/support/package.json diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 7666d8b2d2..d5d78f8f0e 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -17,7 +17,7 @@ module Language.PureScript.Publish , getGitWorkingTreeStatus , checkCleanWorkingTree , getVersionFromGitTag - , getBowerInfo + , getBowerRepositoryInfo , getModulesAndBookmarks , getResolvedDependencies ) where @@ -121,19 +121,24 @@ otherError = throwError . OtherError catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b catchLeft a f = either f pure a +unlessM :: Monad m => m Bool -> m () -> m () +unlessM cond act = cond >>= flip unless act + preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage preparePackage' opts = do - exists <- liftIO (doesFileExist "bower.json") - unless exists (userError BowerJSONNotFound) - + unlessM (liftIO (doesFileExist "bower.json")) (userError BowerJSONNotFound) checkCleanWorkingTree opts pkgMeta <- liftIO (Bower.decodeFile "bower.json") >>= flip catchLeft (userError . CouldntDecodeBowerJSON) + unlessM (liftIO (doesFileExist "LICENSE")) (userError LicenseNotFound) + (pkgVersionTag, pkgVersion) <- publishGetVersion opts - pkgGithub <- getBowerInfo pkgMeta + pkgGithub <- getBowerRepositoryInfo pkgMeta (pkgBookmarks, pkgModules) <- getModulesAndBookmarks + unless (bowerLicenseExists pkgMeta) (userError NoLicenseSpecified) + let declaredDeps = map fst (bowerDependencies pkgMeta ++ bowerDevDependencies pkgMeta) pkgResolvedDependencies <- getResolvedDependencies declaredDeps @@ -193,8 +198,8 @@ getVersionFromGitTag = do dropPrefix prefix str = fromMaybe str (stripPrefix prefix str) -getBowerInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo) -getBowerInfo = either (userError . BadRepositoryField) return . tryExtract +getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo) +getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract where tryExtract pkgMeta = case bowerRepository pkgMeta of @@ -204,6 +209,9 @@ getBowerInfo = either (userError . BadRepositoryField) return . tryExtract (Left (BadRepositoryType repositoryType)) maybe (Left NotOnGithub) Right (extractGithub repositoryUrl) +bowerLicenseExists :: PackageMeta -> Bool +bowerLicenseExists = any (not . null) . bowerLicense + extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo) extractGithub = stripGitHubPrefixes >>> fmap (splitOn "/") diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 4e7258fb9f..5db5738286 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -54,11 +54,13 @@ data PackageWarning -- | An error that should be fixed by the user. data UserError = BowerJSONNotFound + | LicenseNotFound | BowerExecutableNotFound [String] -- list of executable names tried | CouldntDecodeBowerJSON (ParseError BowerError) | TagMustBeCheckedOut | AmbiguousVersions [Version] -- Invariant: should contain at least two elements | BadRepositoryField RepositoryFieldError + | NoLicenseSpecified | MissingDependencies (NonEmpty PackageName) | CompileError P.MultipleErrors | DirtyWorkingTree @@ -70,6 +72,7 @@ data RepositoryFieldError | NotOnGithub deriving (Show) + -- | An error that probably indicates a bug in this module. data InternalError = JSONError JSONSource (ParseError BowerError) @@ -122,6 +125,12 @@ displayUserError e = case e of "The bower.json file was not found. Please create one, or run " ++ "`pulp init`." ) + LicenseNotFound -> + para (concat + ["No LICENSE file was found. Please create one. ", + "Distributing code without a license means that nobody ", + "will be able to (legally) use it." + ]) BowerExecutableNotFound names -> para (concat [ "The Bower executable was not found (tried: ", format names, "). Please" @@ -168,6 +177,12 @@ displayUserError e = case e of ] ++ bulletedList showVersion vs BadRepositoryField err -> displayRepositoryError err + NoLicenseSpecified -> + para (concat + ["No license specified in bower.json. Please add one. ", + "Distributing code without a license means that nobody ", + "will be able to (legally) use it." + ]) MissingDependencies pkgs -> let singular = NonEmpty.length pkgs == 1 pl a b = if singular then b else a From fd59e1aa257c5f1a22bd556cf21ca74c26051d8f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 26 Mar 2016 12:36:16 -0700 Subject: [PATCH 0345/1580] 0.8.3.0 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 84c9af2243..9c0040dee5 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.8.2.0 +version: 0.8.3.0 cabal-version: >=1.8 build-type: Simple license: MIT From 362a23905c9158851e097c9a5fb8a8ab87145efb Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Wed, 30 Mar 2016 18:42:01 +0100 Subject: [PATCH 0346/1580] Update to use language-purescript 0.6.x --- purescript.cabal | 2 +- src/Language/PureScript/Bundle.hs | 371 +++++++++++++++--------------- stack-lts-5.yaml | 1 + stack-nightly.yaml | 3 +- 4 files changed, 186 insertions(+), 191 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 9c0040dee5..7c8442b04e 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -74,7 +74,7 @@ library bytestring -any, text -any, split -any, - language-javascript == 0.5.*, + language-javascript == 0.6.*, syb -any, Glob >= 0.7 && < 0.8, process >= 1.2.0 && < 1.5, diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 38caa2d4a1..0e354272ac 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -43,6 +43,7 @@ import qualified Data.Set as S import Control.Monad import Control.Monad.Error.Class import Language.JavaScript.Parser +import Language.JavaScript.Parser.AST import qualified Paths_purescript as Paths @@ -83,7 +84,7 @@ type Key = (ModuleIdentifier, String) data ExportType = RegularExport String | ForeignReexport - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) -- | There are four types of module element we are interested in: -- @@ -95,14 +96,14 @@ data ExportType -- Each is labelled with the original AST node which generated it, so that we can dump it back -- into the output during codegen. data ModuleElement - = Require JSNode String (Either String ModuleIdentifier) - | Member JSNode Bool String [JSNode] [Key] - | ExportsList [(ExportType, String, JSNode, [Key])] - | Other JSNode - deriving (Show, Read) + = Require JSStatement String (Either String ModuleIdentifier) + | Member JSStatement Bool String JSExpression [Key] + | ExportsList [(ExportType, String, JSExpression, [Key])] + | Other JSStatement + deriving (Show) -- | A module is just a list of elements of the types listed above. -data Module = Module ModuleIdentifier [ModuleElement] deriving (Show, Read) +data Module = Module ModuleIdentifier [ModuleElement] deriving (Show) -- | Prepare an error message for consumption by humans. printErrorMessage :: ErrorMessage -> [String] @@ -131,11 +132,6 @@ printErrorMessage (ErrorInModule mid e) = displayIdentifier (ModuleIdentifier name ty) = name ++ " (" ++ showModuleType ty ++ ")" --- | Unpack the node inside a JSNode. This is useful when pattern matching. -node :: JSNode -> Node -node (NN n) = n -node (NT n _ _) = n - -- | Calculate the ModuleIdentifier which a require(...) statement imports. checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier checkImportPath _ "./foreign" m _ = @@ -179,114 +175,124 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es) -- | Calculate dependencies and add them to the current element. expandDeps :: ModuleElement -> ModuleElement - expandDeps (Member n f nm decl _) = Member n f nm decl (nub (concatMap (dependencies modulePath) decl)) + expandDeps (Member n f nm decl _) = Member n f nm decl (nub $ dependencies modulePath decl) expandDeps (ExportsList exps) = ExportsList (map expand exps) where expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1)) expandDeps other = other - dependencies :: ModuleIdentifier -> JSNode -> [(ModuleIdentifier, String)] + dependencies :: ModuleIdentifier -> JSExpression -> [(ModuleIdentifier, String)] dependencies m = everything (++) (mkQ [] toReference) where - toReference :: Node -> [(ModuleIdentifier, String)] - toReference (JSMemberDot [ mn ] _ nm) - | JSIdentifier mn' <- node mn - , JSIdentifier nm' <- node nm + toReference :: JSExpression -> [(ModuleIdentifier, String)] + toReference (JSMemberDot mn _ nm) + | JSIdentifier _ mn' <- mn + , JSIdentifier _ nm' <- nm , Just mid <- lookup mn' imports = [(mid, nm')] - toReference (JSMemberSquare [ mn ] _ nm _) - | JSIdentifier mn' <- node mn - , JSExpression [ s ] <- node nm - , JSStringLiteral _ nm' <- node s + toReference (JSMemberSquare mn _ nm _) + | JSIdentifier _ mn' <- mn + , Just nm' <- fromStringLiteral nm , Just mid <- lookup mn' imports = [(mid, nm')] - toReference (JSIdentifier nm) + toReference (JSIdentifier _ nm) | nm `elem` boundNames = [(m, nm)] toReference _ = [] +-- String literals include the quote chars +fromStringLiteral :: JSExpression -> Maybe String +fromStringLiteral (JSStringLiteral _ str) = Just $ trimStringQuotes str +fromStringLiteral _ = Nothing + +trimStringQuotes :: String -> String +trimStringQuotes str = reverse $ drop 1 $ reverse $ drop 1 $ str + +commaList :: JSCommaList a -> [a] +commaList JSLNil = [] +commaList (JSLOne x) = [x] +commaList (JSLCons l _ x) = commaList l ++ [x] + +trailingCommaList :: JSCommaTrailingList a -> [a] +trailingCommaList (JSCTLComma l _) = commaList l +trailingCommaList (JSCTLNone l) = commaList l + -- | Attempt to create a Module from a Javascript AST. -- -- Each type of module element is matched using pattern guards, and everything else is bundled into the -- Other constructor. -toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module +toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSAST -> m Module toModule requirePath mids mid top - | JSSourceElementsTop ns <- node top = Module mid <$> traverse toModuleElement ns + | JSAstProgram smts _ <- top = Module mid <$> traverse toModuleElement smts | otherwise = err InvalidTopLevel where err = throwError . ErrorInModule mid - toModuleElement :: JSNode -> m ModuleElement - toModuleElement n - | JSVariables var [ varIntro ] _ <- node n - , JSLiteral "var" <- node var - , JSVarDecl impN [ eq, req, impP ] <- node varIntro - , JSIdentifier importName <- node impN - , JSLiteral "=" <- node eq - , JSIdentifier "require" <- node req - , JSArguments _ [ impS ] _ <- node impP - , JSStringLiteral _ importPath <- node impS + toModuleElement :: JSStatement -> m ModuleElement + -- var ModuleName = require("file"); + toModuleElement stmt + | JSVariable _ jsInit _ <- stmt + , [JSVarInitExpression var varInit] <- commaList jsInit + , JSIdentifier _ importName <- var + , JSVarInit _ jsInitEx <- varInit + , JSMemberExpression req _ argsE _ <- jsInitEx + , JSIdentifier _ "require" <- req + , [ Just importPath ] <- map fromStringLiteral (commaList argsE) , importPath' <- checkImportPath requirePath importPath mid mids - = pure (Require n importName importPath') - toModuleElement n - | JSVariables var [ varIntro ] _ <- node n - , JSLiteral "var" <- node var - , JSVarDecl declN (eq : decl) <- node varIntro - , JSIdentifier name <- node declN - , JSLiteral "=" <- node eq - = pure (Member n False name decl []) - toModuleElement n - | JSExpression (e : op : decl) <- node n - , Just name <- accessor (node e) - , JSOperator eq <- node op - , JSLiteral "=" <- node eq - = pure (Member n True name decl []) + = pure (Require stmt importName importPath') + -- var foo = expr; + toModuleElement stmt + | JSVariable _ jsInit _ <- stmt + , [JSVarInitExpression var varInit] <- commaList jsInit + , JSIdentifier _ name <- var + , JSVarInit _ decl <- varInit + = pure (Member stmt False name decl []) + -- exports.foo = expr; exports["foo"] = expr; + toModuleElement stmt + | JSAssignStatement e (JSAssign _) decl _ <- stmt + , Just name <- accessor e + = pure (Member stmt True name decl []) where - accessor :: Node -> Maybe String - accessor (JSMemberDot [ exports ] _ nm) - | JSIdentifier "exports" <- node exports - , JSIdentifier name <- node nm + accessor :: JSExpression -> Maybe String + accessor (JSMemberDot exports _ nm) + | JSIdentifier _ "exports" <- exports + , JSIdentifier _ name <- nm = Just name - accessor (JSMemberSquare [ exports ] _ nm _) - | JSIdentifier "exports" <- node exports - , JSExpression [e] <- node nm - , JSStringLiteral _ name <- node e + accessor (JSMemberSquare exports _ nm _) + | JSIdentifier _ "exports" <- exports + , Just name <- fromStringLiteral nm = Just name accessor _ = Nothing - toModuleElement n - | JSExpression (mnExp : op : obj: _) <- node n - , JSMemberDot [ mn ] _ e <- node mnExp - , JSIdentifier "module" <- node mn - , JSIdentifier "exports" <- node e - , JSOperator eq <- node op - , JSLiteral "=" <- node eq - , JSObjectLiteral _ props _ <- node obj - = ExportsList <$> traverse toExport (filter (not . isSeparator) (map node props)) + -- module.exports = { ... } + toModuleElement stmt + | JSAssignStatement e (JSAssign _) decl _ <- stmt + , JSMemberDot module' _ exports <- e + , JSIdentifier _ "module" <- module' + , JSIdentifier _ "exports" <- exports + , JSObjectLiteral _ props _ <- decl + = (ExportsList <$> traverse toExport (trailingCommaList props)) where - toExport :: Node -> m (ExportType, String, JSNode, [Key]) - toExport (JSPropertyNameandValue name _ [val] ) = - (,,val,[]) <$> exportType (node val) - <*> extractLabel (node name) - toExport _ = err UnsupportedExport - - exportType :: Node -> m ExportType - exportType (JSMemberDot [f] _ _) - | JSIdentifier "$foreign" <- node f - = pure ForeignReexport - exportType (JSMemberSquare [f] _ _ _) - | JSIdentifier "$foreign" <- node f - = pure ForeignReexport - exportType (JSIdentifier s) = pure (RegularExport s) - exportType _ = err UnsupportedExport - - extractLabel :: Node -> m String - extractLabel (JSStringLiteral _ nm) = pure nm - extractLabel (JSIdentifier nm) = pure nm - extractLabel _ = err UnsupportedExport - - isSeparator :: Node -> Bool - isSeparator (JSLiteral ",") = True - isSeparator _ = False + toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key]) + toExport (JSPropertyNameandValue name _ [val]) = + (,,val,[]) <$> exportType val + <*> extractLabel name + toExport _ = err UnsupportedExport + + exportType :: JSExpression -> m ExportType + exportType (JSMemberDot f _ _) + | JSIdentifier _ "$foreign" <- f + = pure ForeignReexport + exportType (JSMemberSquare f _ _ _) + | JSIdentifier _ "$foreign" <- f + = pure ForeignReexport + exportType (JSIdentifier _ s) = pure (RegularExport s) + exportType _ = err UnsupportedExport +-- + extractLabel :: JSPropertyName -> m String + extractLabel (JSPropertyString _ nm) = pure (trimStringQuotes nm) + extractLabel (JSPropertyIdent _ nm) = pure nm + extractLabel _ = err UnsupportedExport + toModuleElement other = pure (Other other) -- | Eliminate unused code based on the specified entry point set. @@ -339,10 +345,6 @@ compile modules entryPoints = filteredModules where go :: [ModuleElement] -> [ModuleElement] go [] = [] - go (d : Other semi : rest) - | JSLiteral ";" <- node semi - , not (isDeclUsed d) - = go rest go (d : rest) | not (isDeclUsed d) = go rest | otherwise = d : go rest @@ -405,130 +407,121 @@ codeGen :: Maybe String -- ^ main module -> String -- ^ namespace -> [Module] -- ^ input modules -> String -codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElementsTop (prelude ++ concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule))) +codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (prelude : concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule) JSNoAnnot) where - moduleToJS :: Module -> [JSNode] + moduleToJS :: Module -> [JSStatement] moduleToJS (Module mn ds) = wrap (moduleName mn) (indent (concatMap declToJS ds)) where - declToJS :: ModuleElement -> [JSNode] + declToJS :: ModuleElement -> [JSStatement] declToJS (Member n _ _ _ _) = [n] declToJS (Other n) = [n] declToJS (Require _ nm req) = - [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ]) - [ NN (JSVarDecl (sp (JSIdentifier nm)) - (sp (JSLiteral "=") : either require (return . moduleReference sp . moduleName) req)) - ] - (nt (JSLiteral ";"))) ] + [ + JSVariable lfsp + (cList [ + JSVarInitExpression (JSIdentifier sp nm) + (JSVarInit sp $ either require (moduleReference sp . moduleName) req ) + ]) (JSSemi JSNoAnnot) + ] declToJS (ExportsList exps) = map toExport exps where - toExport :: (ExportType, String, JSNode, [Key]) -> JSNode + toExport :: (ExportType, String, JSExpression, [Key]) -> JSStatement toExport (_, nm, val, _) = - NN (JSExpression [ NN (JSMemberSquare [ NT (JSIdentifier "exports") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] ] - (nt (JSLiteral "[")) - (NN (JSExpression [ nt (JSStringLiteral '"' nm) ])) - (nt (JSLiteral "]"))) - , NN (JSOperator (sp (JSLiteral "="))) - , reindent val - , nt (JSLiteral ";") - ]) - - reindent :: JSNode -> JSNode - reindent (NT n _ _) = sp n - reindent nn = nn - - indent :: [JSNode] -> [JSNode] + JSAssignStatement + (JSMemberSquare (JSIdentifier lfsp "exports") JSNoAnnot + (str nm) JSNoAnnot) + (JSAssign sp) + val + (JSSemi JSNoAnnot) + + -- comma lists are reverse-consed + cList :: [a] -> JSCommaList a + cList [] = JSLNil + cList [x] = JSLOne x + cList l = go $ reverse l + where + go [x] = JSLOne x + go (h:t)= JSLCons (go t) JSNoAnnot h + go [] = error "Invalid case in comma-list" + + indent :: [JSStatement] -> [JSStatement] indent = everywhere (mkT squash) where - squash (NT n pos ann) = NT n (keepCol pos) (map splat ann) - squash nn = nn + squash JSNoAnnot = (JSAnnot (TokenPn 0 0 2) []) + squash (JSAnnot pos ann) = JSAnnot (keepCol pos) (map splat ann) splat (CommentA pos s) = CommentA (keepCol pos) s splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w splat ann = ann - keepCol (TokenPn _ _ c) = TokenPn 0 0 (c + 2) - - prelude :: [JSNode] - prelude = - [ NN (JSVariables (NT (JSLiteral "var") tokenPosnEmpty [ CommentA tokenPosnEmpty ("// Generated by psc-bundle " ++ showVersion Paths.version) - , WhiteSpace tokenPosnEmpty "\n" - ]) - [ NN (JSVarDecl (sp (JSIdentifier optionsNamespace)) - [ sp (JSLiteral "=") - , NN (JSObjectLiteral (sp (JSLiteral "{")) - [] - (sp (JSLiteral "}"))) - ]) - ] - (nt (JSLiteral ";"))) - , lf - ] + keepCol (TokenPn _ _ c) = TokenPn 0 0 (if c >= 0 then c + 2 else 2) + + prelude :: JSStatement + prelude = JSVariable (JSAnnot tokenPosnEmpty [ CommentA tokenPosnEmpty $ "// Generated by psc-bundle " ++ showVersion Paths.version + , WhiteSpace tokenPosnEmpty "\n" ]) + (cList [ + JSVarInitExpression (JSIdentifier sp optionsNamespace) + (JSVarInit sp (emptyObj sp)) + ]) (JSSemi JSNoAnnot) + + require :: String -> JSExpression + require mn = + JSMemberExpression (JSIdentifier JSNoAnnot "require") JSNoAnnot (cList [ str mn ]) JSNoAnnot + + moduleReference :: JSAnnot -> String -> JSExpression + moduleReference a mn = + JSMemberSquare (JSIdentifier a optionsNamespace) JSNoAnnot + (str mn) JSNoAnnot - require :: String -> [JSNode] - require mn = [ sp (JSIdentifier "require") - , NN (JSArguments (nt (JSLiteral "(")) [ nt (JSStringLiteral '"' mn) ] (nt (JSLiteral ")"))) - ] + str :: String -> JSExpression + str s = JSStringLiteral JSNoAnnot $ "\"" ++ s ++ "\"" - moduleReference :: (Node -> JSNode) -> String -> JSNode - moduleReference f mn = - NN (JSMemberSquare [ f (JSIdentifier optionsNamespace) ] - (nt (JSLiteral "[")) - (NN (JSExpression [ nt (JSStringLiteral '"' mn) ])) - (nt (JSLiteral "]"))) - wrap :: String -> [JSNode] -> [JSNode] + emptyObj :: JSAnnot -> JSExpression + emptyObj a = JSObjectLiteral a (JSCTLNone JSLNil) JSNoAnnot + + wrap :: String -> [JSStatement] -> [JSStatement] wrap mn ds = - [ NN (JSExpression [ NN (JSExpressionParen (nt (JSLiteral "(")) - (NN (JSExpression [ NN (JSFunctionExpression (nt (JSLiteral "function")) - [] - (nt (JSLiteral "(") ) [nt (JSIdentifier "exports")] (nt (JSLiteral ")")) - (NN (JSBlock [sp (JSLiteral "{")] - (lf : ds) - [nl (JSLiteral "}")])))])) - (nt (JSLiteral ")"))) - , NN (JSArguments (nt (JSLiteral "(")) - [ NN (JSExpression [ moduleReference nt mn - , NN (JSOperator (sp (JSLiteral "="))) - , NN (JSExpressionBinary "||" - [ moduleReference sp mn ] - (sp (JSLiteral "||")) - [ emptyObj ]) - ]) - ] - (nt (JSLiteral ")"))) - ]) - , nt (JSLiteral ";") - , lf + [ + JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot + (JSLOne (JSIdentName JSNoAnnot "exports")) JSNoAnnot + (JSBlock sp (lfHead ds) lf)) -- \n not quite in right place + JSNoAnnot) + JSNoAnnot + (JSLOne (JSAssignExpression (moduleReference JSNoAnnot mn) (JSAssign sp) + (JSExpressionBinary (moduleReference sp mn) (JSBinOpOr sp) (emptyObj sp)))) + JSNoAnnot + (JSSemi JSNoAnnot) ] where - emptyObj = NN (JSObjectLiteral (sp (JSLiteral "{")) [] (nt (JSLiteral "}"))) + lfHead (h:t) = (addAnn (WhiteSpace tokenPosnEmpty "\n ") h) : t + lfHead x = x + + addAnn :: CommentAnnotation -> JSStatement -> JSStatement + addAnn a (JSExpressionStatement (JSStringLiteral ann s) _) = + (JSExpressionStatement (JSStringLiteral (appendAnn a ann) s) (JSSemi JSNoAnnot)) + addAnn _ x = x - runMain :: String -> [JSNode] + appendAnn a JSNoAnnot = (JSAnnot tokenPosnEmpty [a]) + appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty " "]) + + runMain :: String -> [JSStatement] runMain mn = - [ NN (JSExpression [ NN (JSMemberDot [ NN (JSMemberSquare [ nl (JSIdentifier optionsNamespace) ] - (nt (JSLiteral "[")) - (NN (JSExpression [ nt (JSStringLiteral '"' mn) ])) - (nt (JSLiteral "]"))) - ] - (nt (JSLiteral ".")) - (nt (JSIdentifier "main"))) - , NN (JSArguments (nt (JSLiteral "(")) [] (nt (JSLiteral ")"))) - ]) - , nt (JSLiteral ";") - ] + [JSMethodCall + (JSMemberDot (moduleReference lf mn) JSNoAnnot + (JSIdentifier JSNoAnnot "main")) + JSNoAnnot (cList []) JSNoAnnot (JSSemi JSNoAnnot)] - nt :: Node -> JSNode - nt n = NT n tokenPosnEmpty [] + lf :: JSAnnot + lf = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ] - lf :: JSNode - lf = NT (JSLiteral "") tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ] - sp :: Node -> JSNode - sp n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ] + lfsp :: JSAnnot + lfsp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] - nl :: Node -> JSNode - nl n = NT n tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ] + sp :: JSAnnot + sp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ] -- | The bundling function. -- This function performs dead code elimination, filters empty modules diff --git a/stack-lts-5.yaml b/stack-lts-5.yaml index 2671991235..9f87d0ed7c 100644 --- a/stack-lts-5.yaml +++ b/stack-lts-5.yaml @@ -3,4 +3,5 @@ packages: - '.' extra-deps: - bower-json-0.8.0 +- language-javascript-0.6.0.4 flags: {} diff --git a/stack-nightly.yaml b/stack-nightly.yaml index c389d15f15..22c2f0d0e0 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -1,5 +1,6 @@ flags: {} packages: - '.' -extra-deps: [] +extra-deps: +- language-javascript-0.6.0.4 resolver: nightly-2016-03-17 From a42b939be1e71bbbd3b720d69435c217e46611bb Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Wed, 30 Mar 2016 20:27:27 +0100 Subject: [PATCH 0347/1580] Update travis.yml --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 47ba7ac827..4da6339081 100644 --- a/.travis.yml +++ b/.travis.yml @@ -35,8 +35,8 @@ install: fi - mkdir -p .cabal-sandbox - cabal sandbox init --sandbox .cabal-sandbox - # Download stackage cabal.config, not sure whether filtering is necessary - - if [ -n "$STACKAGE" ]; then curl https://www.stackage.org/$STACKAGE/cabal.config | egrep -v 'purescript|sourcemap|bower-json' > cabal.config; fi + # Download stackage cabal.config. Filter this package and 'extra deps' + - if [ -n "$STACKAGE" ]; then curl https://www.stackage.org/$STACKAGE/cabal.config | egrep -v 'purescript|language-javascript|bower-json' > cabal.config; fi - cabal install --only-dependencies --enable-tests - cabal install hpc-coveralls # Snapshot state of the sandbox now, so we don't need to make new one for test install From 838ba7bc8b50130956df3eb08ac69c4750b60e70 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Wed, 30 Mar 2016 01:06:06 +0100 Subject: [PATCH 0348/1580] Fix for rendered constrained types needing parens. See https://github.com/purescript/pursuit/issues/176 --- CONTRIBUTORS.md | 1 + examples/docs/src/ConstrainedArgument.purs | 9 +++++ src/Language/PureScript/Docs/AsMarkdown.hs | 1 + .../PureScript/Docs/RenderedCode/Render.hs | 36 ++++++++++++------- tests/TestDocs.hs | 30 ++++++++++++++++ 5 files changed, 65 insertions(+), 12 deletions(-) create mode 100644 examples/docs/src/ConstrainedArgument.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 700c3c872f..3180fca9ec 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -68,6 +68,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/examples/docs/src/ConstrainedArgument.purs b/examples/docs/src/ConstrainedArgument.purs new file mode 100644 index 0000000000..65156a59c6 --- /dev/null +++ b/examples/docs/src/ConstrainedArgument.purs @@ -0,0 +1,9 @@ +module ConstrainedArgument where + +class Foo t + +type WithoutArgs = forall a. (Partial => a) -> a +type WithArgs = forall a. (Foo a => a) -> a +type MultiWithoutArgs = forall a. ((Partial, Partial) => a) -> a +type MultiWithArgs = forall a b. ((Foo a, Foo b) => a) -> a + diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index b2de1d6bf3..9843931ddf 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -6,6 +6,7 @@ module Language.PureScript.Docs.AsMarkdown , Docs , runDocs , modulesAsMarkdown + , codeToString ) where import Prelude () diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index 5b04b134a5..6f9bbd0829 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -44,18 +44,6 @@ typeLiterals = mkPattern match ] match (TypeConstructor (Qualified mn name)) = Just (ctor (runProperName name) (maybeToContainingModule mn)) - match (ConstrainedType deps ty) = - Just $ mintersperse sp - [ syntax "(" <> constraints <> syntax ")" - , syntax "=>" - , renderType ty - ] - where - constraints = mintersperse (syntax "," <> sp) (map renderDep deps) - renderDep :: Constraint -> RenderedCode - renderDep (pn, tys) = - let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys - in renderType instApp match REmpty = Just (syntax "()") match row@RCons{} = @@ -63,6 +51,23 @@ typeLiterals = mkPattern match match _ = Nothing +renderConstraint :: Constraint -> RenderedCode +renderConstraint (pn, tys) = + let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys + in renderType instApp + +renderConstraints :: [Constraint] -> RenderedCode -> RenderedCode +renderConstraints deps ty = + mintersperse sp + [ if length deps == 1 + then constraints + else syntax "(" <> constraints <> syntax ")" + , syntax "=>" + , ty + ] + where + constraints = mintersperse (syntax "," <> sp) (map renderConstraint deps) + -- | -- Render code representing a Row -- @@ -104,6 +109,12 @@ kinded = mkPattern match match (KindedType t k) = Just (k, t) match _ = Nothing +constrained :: Pattern () Type ([Constraint], Type) +constrained = mkPattern match + where + match (ConstrainedType deps ty) = Just (deps, ty) + match _ = Nothing + matchTypeAtom :: Pattern () Type RenderedCode matchTypeAtom = typeLiterals <+> fmap parens matchType where @@ -116,6 +127,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom operators = OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ] , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ] + , [ Wrap constrained $ \deps ty -> renderConstraints deps ty ] , [ Wrap forall_ $ \idents ty -> mconcat [syntax "forall", sp, mintersperse sp (map ident idents), syntax ".", sp, ty] ] , [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ] ] diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 91bdf529c3..1af8bd4567 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -17,6 +17,7 @@ import System.Exit import qualified Language.PureScript as P import qualified Language.PureScript.Docs as Docs +import Language.PureScript.Docs.AsMarkdown (codeToString) import qualified Language.PureScript.Publish as Publish import qualified Language.PureScript.Publish.ErrorsWarnings as Publish @@ -59,6 +60,10 @@ data Assertion -- | Assert that a particular value declaration exists, and its type -- satisfies the given predicate. | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool)) + -- | Assert that a particular type alias exists, and its corresponding + -- type, when rendered, matches a given string exactly + -- fields: module, type synonym name, expected type + | TypeSynonymShouldRenderAs P.ModuleName String String deriving (Show) newtype ShowFn a = ShowFn a @@ -85,6 +90,9 @@ data AssertionFailure -- should have been. -- Fields: module name, declaration name, actual type. | ValueDeclarationWrongType P.ModuleName String P.Type + -- | A Type synonym has been rendered in an unexpected format + -- Fields: module name, declaration name, expected rendering, actual rendering + | TypeSynonymMismatch P.ModuleName String String String deriving (Show) data AssertionResult @@ -149,6 +157,21 @@ runAssertion assertion Docs.Module{..} = Fail (WrongDeclarationType mn decl "value" (Docs.declInfoToString declInfo)) + TypeSynonymShouldRenderAs mn decl expected -> + case find ((==) decl . Docs.declTitle) (declarationsFor mn) of + Nothing -> + Fail (NotDocumented mn decl) + Just Docs.Declaration{..} -> + case declInfo of + Docs.TypeSynonymDeclaration [] ty -> + let actual = codeToString (Docs.renderType ty) in + if actual == expected + then Pass + else Fail (TypeSynonymMismatch mn decl expected actual) + _ -> + Fail (WrongDeclarationType mn decl "synonym" + (Docs.declInfoToString declInfo)) + where declarationsFor mn = if mn == modName @@ -261,6 +284,13 @@ testCases = , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==)) , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==)) ]) + + , ("ConstrainedArgument", + [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a" + , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a" + , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a" + , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a" + ]) ] where From c696253d7082bbe65f785170f3f8c98671790774 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Thu, 31 Mar 2016 22:20:14 +0100 Subject: [PATCH 0349/1580] everythingWithScope improperly traversing binary ops --- src/Language/PureScript/AST/Traversals.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 4ea8c5bfda..4a75f9a54d 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -508,7 +508,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' :: S.Set Ident -> Expr -> r g' s (Literal l) = lit g'' s l g' s (UnaryMinus v1) = g'' s v1 - g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2 + g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 g' s (Parens v1) = g'' s v1 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v From e17d536052761592a5dd4a235bf286ddd4af050d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 2 Apr 2016 16:52:33 -0700 Subject: [PATCH 0350/1580] Fix #1991, instantiate polymorphic types before unification in if..then.else --- examples/passing/1991.purs | 20 ++++++++++++++++++++ src/Language/PureScript/TypeChecker/Types.hs | 8 +++++--- 2 files changed, 25 insertions(+), 3 deletions(-) create mode 100644 examples/passing/1991.purs diff --git a/examples/passing/1991.purs b/examples/passing/1991.purs new file mode 100644 index 0000000000..96738faf9a --- /dev/null +++ b/examples/passing/1991.purs @@ -0,0 +1,20 @@ +module Main where + +import Prelude + +singleton :: forall a. a -> Array a +singleton x = [x] + +empty :: forall a. Array a +empty = [] + +foldMap :: forall a m. (Semigroup m) => (a -> m) -> Array a -> m +foldMap f [a, b, c, d, e] = f a <> f b <> f c <> f d <> f e + +regression :: Array Int +regression = + let as = [1,2,3,4,5] + as' = foldMap (\x -> if 1 < x && x < 4 then singleton x else empty) as + in as' + +main = Control.Monad.Eff.Console.log "Done" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index bd8f600e0f..e8ac6159aa 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -179,7 +179,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' g (TypedValue checkTy val t) = TypedValue checkTy val (f t) g (TypeClassDictionary (nm, tys) sco) = TypeClassDictionary (nm, map f tys) sco g other = other - + -- | Check the kind of a type, failing if it is not of kind *. checkTypeKind :: (MonadState CheckState m, MonadError MultipleErrors m) => @@ -283,8 +283,10 @@ infer' (IfThenElse cond th el) = do cond' <- check cond tyBoolean th'@(TypedValue _ _ thTy) <- infer th el'@(TypedValue _ _ elTy) <- infer el - unifyTypes thTy elTy - return $ TypedValue True (IfThenElse cond' th' el') thTy + (th'', thTy') <- instantiatePolyTypeWithUnknowns th' thTy + (el'', elTy') <- instantiatePolyTypeWithUnknowns el' elTy + unifyTypes thTy' elTy' + return $ TypedValue True (IfThenElse cond' th'' el'') thTy' infer' (Let ds val) = do (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer return $ TypedValue True (Let ds' val') valTy From da0c6fe4f37289d06f05f8c4aa32b3ecf46d6d82 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 3 Apr 2016 11:57:33 +0100 Subject: [PATCH 0351/1580] Use utf8 when writing to stdout and stderr Resolves #1992 --- psc-bundle/Main.hs | 21 +++++---------------- psc-docs/Main.hs | 20 +++++--------------- psc-publish/Main.hs | 7 ++++++- psc/Main.hs | 21 +++++---------------- 4 files changed, 21 insertions(+), 48 deletions(-) diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index f97e36f3f9..a5eee56413 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -1,25 +1,12 @@ ------------------------------------------------------------------------------ --- --- Module : psc-bundle --- Copyright : (c) Phil Freeman 2015 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | Bundles compiled PureScript modules for the browser. --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} +-- | Bundles compiled PureScript modules for the browser. module Main (main) where -import Data.Maybe +import Data.Maybe import Data.Traversable (for) import Data.Version (showVersion) @@ -32,7 +19,7 @@ import Control.Monad.IO.Class import System.FilePath (takeFileName, takeDirectory) import System.FilePath.Glob (glob) import System.Exit (exitFailure) -import System.IO (stderr, hPutStrLn) +import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8) import System.Directory (createDirectoryIfMissing) import Language.PureScript.Bundle @@ -125,6 +112,8 @@ options = Options <$> some inputFile -- | Make it go. main :: IO () main = do + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 opts <- execParser (info (version <*> helper <*> options) infoModList) when (isJust (optionsRequirePath opts)) $ hPutStrLn stderr "The require-path option is deprecated and will be removed in PureScript 0.9." output <- runExceptT (app opts) diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index 70650c8b23..9d4ff6dbb8 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -1,17 +1,4 @@ {-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- --- --- Module : Main --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ module Main where @@ -32,7 +19,7 @@ import qualified Text.PrettyPrint.ANSI.Leijen as PP import qualified Language.PureScript as P import qualified Paths_purescript as Paths import System.Exit (exitFailure) -import System.IO (hPutStrLn, hPrint, stderr) +import System.IO (hPutStrLn, hPrint, hSetEncoding, stderr, stdout, utf8) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) import System.FilePath.Glob (glob) @@ -228,7 +215,10 @@ buildOptions (fmt, input, mapping) = exitFailure main :: IO () -main = execParser opts >>= buildOptions >>= docgen +main = do + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + execParser opts >>= buildOptions >>= docgen where opts = info (version <*> helper <*> pscDocsOptions) infoModList infoModList = fullDesc <> headerInfo <> footerInfo diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs index d7d397c467..7242235851 100644 --- a/psc-publish/Main.hs +++ b/psc-publish/Main.hs @@ -7,6 +7,8 @@ import qualified Data.ByteString.Lazy.Char8 as BL import Options.Applicative hiding (str) +import System.IO (hSetEncoding, stderr, stdout, utf8) + import qualified Paths_purescript as Paths import Language.PureScript.Publish import Language.PureScript.Publish.ErrorsWarnings @@ -24,7 +26,10 @@ dryRunOptions = defaultPublishOptions where dummyVersion = ("0.0.0", Version [0,0,0] []) main :: IO () -main = execParser opts >>= publish +main = do + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + execParser opts >>= publish where opts = info (version <*> helper <*> dryRun) infoModList infoModList = fullDesc <> headerInfo <> footerInfo diff --git a/psc/Main.hs b/psc/Main.hs index fc90127404..72e364b82a 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -1,17 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Main --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} @@ -34,7 +20,7 @@ import qualified Data.ByteString.UTF8 as BU8 import Options.Applicative as Opts import System.Exit (exitSuccess, exitFailure) -import System.IO (hPutStrLn, stderr) +import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8) import System.IO.UTF8 import System.FilePath.Glob (glob) @@ -202,7 +188,10 @@ pscMakeOptions = PSCMakeOptions <$> many inputFile <*> jsonErrors main :: IO () -main = execParser opts >>= compile +main = do + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + execParser opts >>= compile where opts = info (version <*> helper <*> pscMakeOptions) infoModList infoModList = fullDesc <> headerInfo <> footerInfo From 90a755f6db79bdc2dff4df641b3c38e74e66cb52 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 5 Apr 2016 19:49:57 -0700 Subject: [PATCH 0352/1580] Disallow constraint generalization for recursive functions. Fix #1978, disallow constraint generalization for recursive functions. --- examples/failing/Generalization1.purs | 11 ++++++++ examples/failing/Generalization2.purs | 8 ++++++ examples/passing/Generalization1.purs | 10 +++++++ src/Language/PureScript/Errors.hs | 12 ++++++++- src/Language/PureScript/TypeChecker.hs | 4 +-- src/Language/PureScript/TypeChecker/Types.hs | 28 +++++++++++++++----- 6 files changed, 64 insertions(+), 9 deletions(-) create mode 100644 examples/failing/Generalization1.purs create mode 100644 examples/failing/Generalization2.purs create mode 100644 examples/passing/Generalization1.purs diff --git a/examples/failing/Generalization1.purs b/examples/failing/Generalization1.purs new file mode 100644 index 0000000000..a4a7b9b02d --- /dev/null +++ b/examples/failing/Generalization1.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith CannotGeneralizeRecursiveFunction +module Main where + +import Prelude + +foo 0 x _ = x +foo n x y = x <> bar (n - 1) x y + +bar 0 x _ = x +bar n x y = y <> foo (n - 1) x y + diff --git a/examples/failing/Generalization2.purs b/examples/failing/Generalization2.purs new file mode 100644 index 0000000000..9fa8e1cb45 --- /dev/null +++ b/examples/failing/Generalization2.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith CannotGeneralizeRecursiveFunction +module Main where + +import Prelude + +test n m | n <= 1 = m + | otherwise = test (n - 1) (m <> m) + diff --git a/examples/passing/Generalization1.purs b/examples/passing/Generalization1.purs new file mode 100644 index 0000000000..a956ab6068 --- /dev/null +++ b/examples/passing/Generalization1.purs @@ -0,0 +1,10 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (print) + +main = do + print (sum 1.0 2.0) + print (sum 1 2) + +sum x y = x + y diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index c6bdb149fd..1fad2dd1d2 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -149,6 +149,7 @@ data SimpleErrorMessage | IncorrectAnonymousArgument | InvalidOperatorInBinder Ident Ident | DeprecatedRequirePath + | CannotGeneralizeRecursiveFunction Ident Type deriving (Show) -- | Error message hints, providing more detailed information about failure. @@ -330,6 +331,7 @@ errorCode em = case unwrapErrorMessage em of IncorrectAnonymousArgument -> "IncorrectAnonymousArgument" InvalidOperatorInBinder{} -> "InvalidOperatorInBinder" DeprecatedRequirePath{} -> "DeprecatedRequirePath" + CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction" -- | -- A stack trace for an error @@ -420,6 +422,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty + gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty gSimple other = pure other @@ -981,6 +984,13 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap renderSimpleErrorMessage DeprecatedRequirePath = line "The require-path option is deprecated and will be removed in PureScript 0.9." + renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) = + paras [ line $ "Unable to generalize the type of the recursive function " ++ showIdent ident ++ "." + , line $ "The inferred type of " ++ showIdent ident ++ " was:" + , indent $ typeAsBox ty + , line "Try adding a type signature." + ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail @@ -1202,7 +1212,7 @@ prettyPrintMultipleWarningsBox = prettyPrintMultipleErrorsWith Warning "Warning -- | Pretty print errors as a Box prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box] -prettyPrintMultipleErrorsBox = prettyPrintMultipleErrorsWith Error "Error found:" "Error" +prettyPrintMultipleErrorsBox = prettyPrintMultipleErrorsWith Error "Error found:" "Error" prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box] prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index d020b44491..15b13aa3ba 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -234,7 +234,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds go (ValueDeclaration name nameKind [] (Right val)) = warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do valueIsNotDefined moduleName name - [(_, (val', ty))] <- typesOf moduleName [(name, val)] + [(_, (val', ty))] <- typesOf NonRecursiveBindingGroup moduleName [(name, val)] addValue moduleName name ty nameKind return $ ValueDeclaration name nameKind [] $ Right val' go ValueDeclaration{} = internalError "Binders were not desugared" @@ -242,7 +242,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do for_ (map (\(ident, _, _) -> ident) vals) $ \name -> valueIsNotDefined moduleName name - tys <- typesOf moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals + tys <- typesOf RecursiveBindingGroup moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals vals' <- forM [ (name, val, nameKind, ty) | (name, nameKind, _) <- vals , (name', (val, ty)) <- tys diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index e8ac6159aa..bc90c67220 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -7,9 +7,10 @@ -- | -- This module implements the type checker -- -module Language.PureScript.TypeChecker.Types ( - typesOf -) where +module Language.PureScript.TypeChecker.Types + ( BindingGroupType(..) + , typesOf + ) where {- The following functions represent the corresponding type checking judgements: @@ -59,14 +60,20 @@ import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types +data BindingGroupType + = RecursiveBindingGroup + | NonRecursiveBindingGroup + deriving (Show, Eq, Ord) + -- | Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. typesOf :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + BindingGroupType -> ModuleName -> [(Ident, Expr)] -> m [(Ident, (Expr, Type))] -typesOf moduleName vals = do +typesOf bindingGroupType moduleName vals = do tys <- fmap tidyUp . liftUnifyWarnings replace $ do (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict @@ -79,14 +86,23 @@ typesOf moduleName vals = do let unsolvedTypeVars = nub $ unknownsInType ty -- Generalize and constrain the type let generalized = generalize unsolved ty - -- Make sure any unsolved type constraints only use type variables which appear - -- unknown in the inferred type. + when shouldGeneralize $ do + -- Show the inferred type in a warning tell . errorMessage $ MissingTypeDeclaration ident generalized + -- For non-recursive binding groups, can generalize over constraints. + -- For recursive binding groups, we throw an error here for now. + when (bindingGroupType == RecursiveBindingGroup && not (null unsolved)) + . throwError + . errorMessage + $ CannotGeneralizeRecursiveFunction ident generalized + -- Make sure any unsolved type constraints only use type variables which appear + -- unknown in the inferred type. forM_ unsolved $ \(_, (className, classTys)) -> do let constraintTypeVars = nub $ foldMap unknownsInType classTys when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ throwError . errorMessage $ NoInstanceFound className classTys + -- Check skolem variables did not escape their scope skolemEscapeCheck val' -- Check rows do not contain duplicate labels From 0d78fc1cf1cf2d8af34530761f8d29efacd311de Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 6 Apr 2016 05:06:19 +0200 Subject: [PATCH 0353/1580] [psc-ide] - Import helper commands * Adds import parsing and adding an implicit import * addImport statement this will search the loaded modules for the given identifier and add a simple Value import for now * reply with Completions rather then just the ModuleName * Adds tests to cover some of the functionality * fix warnings * Set up integration tests for psc-ide * try to put the compiled binaries on travis's PATH * fix warnings and give the server more startup time * allow specifying an output file * allow specifying the module to load * tests writing out changed imports to temp files * addImplicitImport command for Integration tests * more tests * fix warnings and try to put things on the path * don't clutter the main .gitignore * documents new commands * actually use the supplied filters also does some cleanup * formatting and documentation * adds support files to cabal file * make typesynonym import work The current internal format generate two seperate entries for typesynonyms so we need to flatten the list of matches by modulename * adds documentation and shortens parseImport * reduce duplication in Language.PureScript.Errors * Adding bsermons as contributor. * fix typo in module header * apply span suggestion (Thanks that looks better) * work around special case in prettyPrintImport also adds a test to cover this case * refactors import tests also adds a testcase for when an identifier to import cannot be found * Try harder to correctly detect the import section * More robust parsing by using the moduleParser on the entire importsection at once * keeps trailing newlines or comments inside the modulebody * don't duplicate refs in explicit imports * make a selfreferencing import a noop Don't add an import for an identifier defined in the module itself tiny bit of refactoring * add a testcase for the selfreferencing import case * adds a loadAll command to psc-ide This command loads every compiled module it detects inside the output folder. This command is somewhat of a necessity to make the import lookup useful. We can now start the server, load all the compiled modules and have import completion for all the modules in our project. Previously we'd have to either load a file that already imported a certain module or we had to scan the output folder ourself. * remove superfluous instances, fix cabal warnings * drag the ExternDecl through the Matcher * extend ExternDecl type * fix warnings and clean up a bit * remove duplicate entries when inserting externs Typeclasses generated 3 entries: 1. The TypeclassDeclaration 2. A TypeDeclaration 3. A TypesynonymDeclaration The last two also applied to TypeDeclarations * turn the typeclass test "on" add dtor test * use the "class" syntax when importing typeclasses also look up the type belonging to a dataconstructor and import all types with an open dataconstructor list like: import Data.Maybe (Maybe(..)) * always imports newtypes as dataconstructors The same goes for data declarations with matching constructor and type names. In the case of matching typename and constructorname but different types we just tell the user we can't decide for now. * test the new behaviour * add testcases for dataconstructor imports * move text json encoding into util * handle dataconstructor imports * turn ProperRef into TypeRef this workaround shouldn't be necessary after typeclass import syntax is unambiguous from type import * bracket operators in imports * start a new importsection if there are no imports * make completionFromMatch total * don't add an explicit import for an already implicit one * add type synonym declaration do not raise undecidable error for parameterized type declarations. * preserve the order of implicit imports This makes sure we don't change the set of warnings for implicit imports * introduce an Ord instance for imports This rates qualified Implicit imports greater than non-qualified ones. This way the first Implicit unqualified import appears at the top when sorting. * formatting * rebasing * revert to master --- .travis.yml | 3 + CONTRIBUTORS.md | 1 + psc-ide-server/Main.hs | 17 +- psc-ide-server/PROTOCOL.md | 98 ++++- purescript.cabal | 22 +- src/Language/PureScript/Ide.hs | 84 +++-- src/Language/PureScript/Ide/CaseSplit.hs | 85 +++-- src/Language/PureScript/Ide/CodecJSON.hs | 13 - src/Language/PureScript/Ide/Command.hs | 92 ++++- src/Language/PureScript/Ide/Completion.hs | 17 +- src/Language/PureScript/Ide/Error.hs | 21 +- src/Language/PureScript/Ide/Externs.hs | 104 ++--- src/Language/PureScript/Ide/Filter.hs | 39 +- src/Language/PureScript/Ide/Imports.hs | 355 ++++++++++++++++++ src/Language/PureScript/Ide/Matcher.hs | 71 ++-- src/Language/PureScript/Ide/Pursuit.hs | 14 + src/Language/PureScript/Ide/Reexports.hs | 16 + src/Language/PureScript/Ide/SourceFile.hs | 17 +- src/Language/PureScript/Ide/State.hs | 27 +- src/Language/PureScript/Ide/Types.hs | 94 +++-- src/Language/PureScript/Ide/Util.hs | 65 ++++ src/Language/PureScript/Ide/Watcher.hs | 15 + tests/Language/PureScript/Ide/FilterSpec.hs | 10 +- .../PureScript/Ide/Imports/IntegrationSpec.hs | 101 +++++ tests/Language/PureScript/Ide/ImportsSpec.hs | 125 ++++++ tests/Language/PureScript/Ide/Integration.hs | 238 ++++++++++++ tests/Language/PureScript/Ide/MatcherSpec.hs | 39 +- .../Language/PureScript/Ide/ReexportsSpec.hs | 9 +- tests/Language/PureScript/IdeSpec.hs | 16 +- tests/support/pscide/.gitignore | 7 + tests/support/pscide/src/ImportsSpec.purs | 5 + tests/support/pscide/src/ImportsSpec1.purs | 32 ++ tests/support/pscide/src/Main.purs | 7 + 33 files changed, 1584 insertions(+), 275 deletions(-) delete mode 100644 src/Language/PureScript/Ide/CodecJSON.hs create mode 100644 src/Language/PureScript/Ide/Imports.hs create mode 100644 src/Language/PureScript/Ide/Util.hs create mode 100644 tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs create mode 100644 tests/Language/PureScript/Ide/ImportsSpec.hs create mode 100644 tests/Language/PureScript/Ide/Integration.hs create mode 100644 tests/support/pscide/.gitignore create mode 100644 tests/support/pscide/src/ImportsSpec.purs create mode 100644 tests/support/pscide/src/ImportsSpec1.purs create mode 100644 tests/support/pscide/src/Main.purs diff --git a/.travis.yml b/.travis.yml index 4da6339081..2e6b496922 100644 --- a/.travis.yml +++ b/.travis.yml @@ -19,6 +19,9 @@ before_install: - export PATH="$HOME/.cabal/bin:$PATH" - export PATH="/opt/happy/1.19.5/bin:/$PATH" - export PATH="/opt/alex/3.1.4/bin:/$PATH" + - export PATH="$HOME/build/purescript/purescript/dist/build/psc:/$PATH" + - export PATH="$HOME/build/purescript/purescript/dist/build/psc-ide-server:/$PATH" + - export PATH="$HOME/build/purescript/purescript/dist/build/psc-ide-client:/$PATH" install: - cabal --version - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 3180fca9ec..0120af5496 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -69,6 +69,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 77f22439f7..896b135d40 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -1,9 +1,24 @@ +----------------------------------------------------------------------------- +-- +-- Module : Main +-- Description : The server accepting commands for psc-ide +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- The server accepting commands for psc-ide +----------------------------------------------------------------------------- + {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} + module Main where import Prelude () @@ -21,7 +36,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Version (showVersion) import Language.PureScript.Ide -import Language.PureScript.Ide.CodecJSON +import Language.PureScript.Ide.Util import Language.PureScript.Ide.Error import Language.PureScript.Ide.Types import Language.PureScript.Ide.Watcher diff --git a/psc-ide-server/PROTOCOL.md b/psc-ide-server/PROTOCOL.md index 0a3f00197e..820b125fa6 100644 --- a/psc-ide-server/PROTOCOL.md +++ b/psc-ide-server/PROTOCOL.md @@ -8,8 +8,9 @@ this document. ## Command: ### Load -The `load` command "loads" the requested modules into the server -for completion and type info. +The `load` command "loads" the requested modules into the server for completion +and type info. If the `params` object is left off, the `load` command will try +to detect all the compiled modules in your project and load them. **Params:** - `modules :: (optional) [ModuleName]`: A list of modules to load. @@ -21,7 +22,7 @@ for completion and type info. ```json { "command": "load", - "params": { + "params": (optional) { "modules": (optional)["Module.Name1", "Module.Name2"], "dependencies": (optional)["Module.Name3"] } @@ -148,6 +149,97 @@ The following format is returned as the Result: ``` You should then be able to replace the affected line of code in the editor with the new suggestions. +### Import + +For now all of the import related commands work with a file on the filesystem. + +You can specify it with the `file` parameter. + +If you supply the optional `outfile` parameter, the output will be written to +that file, and an info message will be returned from the client. + +If you don't supply `outfile`, the server responds with a list of strings which, +when inserted into a file linewise create the module with the applied changes. + +Arguments: + +- `file` :: String +- `outfile` :: Maybe String +- `filters` :: Maybe [Filter] + +Example: + +```json +{ + "command": "import", + "params": { + "file": "/home/creek/Documents/chromacannon/src/Main.purs", + "outfile": "/home/creek/Documents/chromacannon/src/Main.purs", + "filters": [{ + "filter": "modules", + "params": { + "modules": ["My.Module"] + } + }], + "importCommand": { + "yadda": "yadda" + } + } +} +``` + + +#### Subcommand `addImplicitImport` + +This command just adds an unqualified import for the given modulename. + +Arguments: +- `moduleName :: String` + +Example: +```json +{ + "command": "import", + "params": { + "file": "/home/creek/Documents/chromacannon/src/Main.purs", + "importCommand": { + "importCommand": "addImplicitImport", + "module": "Data.Array.LOL" + } + } +} +``` +#### Subcommand `addImport` + +This command takes an identifier and searches the currently loaded modules for +it. If it finds no matches it responds with an Error. If it finds exactly one +match it adds the import and returns. If it finds more than one match it +responds with a list of the found matches as completions like the complete +command. + +You can also supply a list of filters like the ones for completion. This way you +can narrow down the search to a certain module and resolve the case in which +more then one match was found. + +Arguments: +- `moduleName :: String` +- `filters :: [Filter]` + +Example: +```json +{ + "command": "import", + "params": { + "file": "/home/creek/Documents/chromacannon/src/Demo.purs", + "outfile": "/home/creek/Documents/chromacannon/src/Demo.purs", + "importCommand": { + "importCommand": "addImport", + "identifier": "bind" + } + } +} +``` + ### Pursuit The `pursuit` command looks up the packages/completions for a given identifier from Pursuit. diff --git a/purescript.cabal b/purescript.cabal index 7c8442b04e..6655592ced 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -36,6 +36,7 @@ extra-source-files: examples/passing/*.purs , tests/support/flattened/*.purs , tests/support/flattened/*.js , tests/support/psci/*.purs + , tests/support/pscide/src/*.purs , stack.yaml , stack-lts-5.yaml , stack-nightly.yaml @@ -201,7 +202,6 @@ library Language.PureScript.Ide.Command Language.PureScript.Ide.Externs Language.PureScript.Ide.Error - Language.PureScript.Ide.CodecJSON Language.PureScript.Ide.Pursuit Language.PureScript.Ide.Completion Language.PureScript.Ide.Matcher @@ -212,6 +212,8 @@ library Language.PureScript.Ide.SourceFile Language.PureScript.Ide.Watcher Language.PureScript.Ide.Reexports + Language.PureScript.Ide.Imports + Language.PureScript.Ide.Util Control.Monad.Logger Control.Monad.Supply @@ -313,7 +315,7 @@ executable psc-bundle executable psc-ide-server main-is: Main.hs - other-modules: + other-modules: Paths_purescript other-extensions: build-depends: base >=4 && <5 , purescript -any @@ -333,7 +335,7 @@ executable psc-ide-server executable psc-ide-client main-is: Main.hs - other-modules: + other-modules: Paths_purescript other-extensions: build-depends: base >=4 && <5 , mtl -any @@ -350,7 +352,8 @@ test-suite tests transformers -any, process -any, transformers-compat -any, time -any, Glob -any, aeson-better-errors -any, bytestring -any, aeson -any, base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any, - boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any + boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any, + vector -any, utf8-string -any ghc-options: -Wall type: exitcode-stdio-1.0 main-is: Main.hs @@ -361,5 +364,16 @@ test-suite tests TestPsci TestPscIde PscIdeSpec + Language.PureScript.Ide.FilterSpec + Language.PureScript.Ide.ImportsSpec + Language.PureScript.Ide.Imports.IntegrationSpec + Language.PureScript.Ide.Integration + Language.PureScript.Ide.MatcherSpec + Language.PureScript.Ide.ReexportsSpec + Language.PureScript.IdeSpec + PSCi.Completion + PSCi.Directive + PSCi.Module + PSCi.Types buildable: True hs-source-dirs: tests psci diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index a77734ed30..21840a2080 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -1,3 +1,17 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide +-- Description : Interface for the psc-ide-server +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Interface for the psc-ide-server +----------------------------------------------------------------------------- + {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -6,7 +20,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -module Language.PureScript.Ide where +module Language.PureScript.Ide + ( handleCommand + -- for tests + , printModules + ) where import Prelude () import Prelude.Compat @@ -27,12 +45,14 @@ import Language.PureScript.Ide.Completion import Language.PureScript.Ide.Error import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Imports hiding (Import) import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Pursuit import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.State import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util import System.Directory import System.FilePath import System.Exit @@ -40,39 +60,48 @@ import System.Exit handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => Command -> m Success +handleCommand (Load [] []) = loadAllModules handleCommand (Load modules deps) = - loadModulesAndDeps modules deps + loadModulesAndDeps modules deps handleCommand (Type search filters) = - findType search filters + findType search filters handleCommand (Complete filters matcher) = - findCompletions filters matcher + findCompletions filters matcher handleCommand (Pursuit query Package) = - findPursuitPackages query + findPursuitPackages query handleCommand (Pursuit query Identifier) = - findPursuitCompletions query + findPursuitCompletions query handleCommand (List LoadedModules) = - printModules + printModules handleCommand (List AvailableModules) = - listAvailableModules + listAvailableModules handleCommand (List (Imports fp)) = - importsForFile fp + importsForFile fp handleCommand (CaseSplit l b e wca t) = - caseSplit l b e wca t + caseSplit l b e wca t handleCommand (AddClause l wca) = - pure $ addClause l wca + pure $ addClause l wca +handleCommand (Import fp outfp _ (AddImplicitImport mn)) = do + rs <- addImplicitImport fp mn + answerRequest outfp rs +handleCommand (Import fp outfp filters (AddImportForIdentifier ident)) = do + rs <- addImportForIdentifier fp ident filters + case rs of + Right rs' -> answerRequest outfp rs' + Left question -> pure $ CompletionResult (mapMaybe completionFromMatch question) handleCommand Cwd = - TextResult . T.pack <$> liftIO getCurrentDirectory + TextResult . T.pack <$> liftIO getCurrentDirectory handleCommand Quit = liftIO exitSuccess findCompletions :: (PscIde m, MonadLogger m) => [Filter] -> Matcher -> m Success findCompletions filters matcher = - CompletionResult . getCompletions filters matcher <$> getAllModulesWithReexports + CompletionResult . mapMaybe completionFromMatch . getCompletions filters matcher <$> getAllModulesWithReexports findType :: (PscIde m, MonadLogger m) => DeclIdent -> [Filter] -> m Success findType search filters = - CompletionResult . getExactMatches search filters <$> getAllModulesWithReexports + CompletionResult . mapMaybe completionFromMatch . getExactMatches search filters <$> getAllModulesWithReexports findPursuitCompletions :: (MonadIO m, MonadLogger m) => PursuitQuery -> m Success @@ -179,6 +208,26 @@ loadModule mn = do $(logDebug) ("Loaded extern file at: " <> T.pack path) pure ("Loaded extern file at: " <> T.pack path) +loadAllModules :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => m Success +loadAllModules = do + outputPath <- confOutputPath . envConfiguration <$> ask + cwd <- liftIO getCurrentDirectory + let outputDirectory = cwd outputPath + liftIO (getDirectoryContents outputDirectory) + >>= liftIO . traverse (getExternsPath outputDirectory) + >>= traverse_ loadExtern . catMaybes + pure (TextResult "All modules loaded.") + where + getExternsPath :: FilePath -> FilePath -> IO (Maybe FilePath) + getExternsPath outputDirectory d + | d `elem` [".", ".."] = pure Nothing + | otherwise = do + let file = outputDirectory d "externs.json" + ex <- doesFileExist file + if ex + then pure (Just file) + else pure Nothing + filePathFromModule :: (PscIde m, MonadError PscIdeError m) => ModuleIdent -> m FilePath filePathFromModule moduleName = do @@ -190,10 +239,3 @@ filePathFromModule moduleName = do then pure path else throwError (ModuleFileNotFound moduleName) --- | Taken from Data.Either.Utils -maybeToEither :: MonadError e m => - e -- ^ (Left e) will be returned if the Maybe value is Nothing - -> Maybe a -- ^ (Right a) will be returned if this is (Just a) - -> m a -maybeToEither errorval Nothing = throwError errorval -maybeToEither _ (Just normalval) = return normalval diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 0e4d089240..450ba5f05c 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -1,3 +1,17 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.CaseSplit +-- Description : Casesplitting and adding function clauses +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Casesplitting and adding function clauses +----------------------------------------------------------------------------- + {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -26,23 +40,18 @@ import Data.List (find) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T -import Language.PureScript.AST -import Language.PureScript.Environment +import qualified Language.PureScript as P + import Language.PureScript.Externs import Language.PureScript.Ide.Error import Language.PureScript.Ide.Externs (unwrapPositioned) import Language.PureScript.Ide.State -import Language.PureScript.Ide.Types hiding (Type) -import Language.PureScript.Names -import Language.PureScript.Parser.Common (runTokenParser) -import Language.PureScript.Parser.Declarations -import Language.PureScript.Parser.Lexer (lex) -import Language.PureScript.Parser.Types -import Language.PureScript.Pretty -import Language.PureScript.Types -import Text.Parsec as P - -type Constructor = (ProperName 'ConstructorName, [Type]) +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util + +import Text.Parsec as Parsec + +type Constructor = (P.ProperName 'P.ConstructorName, [P.Type]) newtype WildcardAnnotations = WildcardAnnotations Bool @@ -57,13 +66,13 @@ caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => caseSplit q = do type' <- parseType' (T.unpack q) (tc, args) <- splitTypeConstructor type' - (EDType _ _ (DataType typeVars ctors)) <- findTypeDeclaration tc - let applyTypeVars = everywhereOnTypes (replaceAllTypeVars (zip (map fst typeVars) args)) + (EDType _ _ (P.DataType typeVars ctors)) <- findTypeDeclaration tc + let applyTypeVars = P.everywhereOnTypes (P.replaceAllTypeVars (zip (map fst typeVars) args)) let appliedCtors = map (second (map applyTypeVars)) ctors pure appliedCtors findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => - ProperName 'TypeName -> m ExternsDeclaration + P.ProperName 'P.TypeName -> m ExternsDeclaration findTypeDeclaration q = do efs <- getExternFiles let m = getFirst $ foldMap (findTypeDeclaration' q) efs @@ -72,7 +81,7 @@ findTypeDeclaration q = do Nothing -> throwError (GeneralError "Not Found") findTypeDeclaration' :: - ProperName 'TypeName + P.ProperName 'P.TypeName -> ExternsFile -> First ExternsDeclaration findTypeDeclaration' t ExternsFile{..} = @@ -81,25 +90,25 @@ findTypeDeclaration' t ExternsFile{..} = _ -> False) efDeclarations splitTypeConstructor :: (MonadError PscIdeError m) => - Type -> m (ProperName 'TypeName, [Type]) + P.Type -> m (P.ProperName 'P.TypeName, [P.Type]) splitTypeConstructor = go [] where - go acc (TypeApp ty arg) = go (arg : acc) ty - go acc (TypeConstructor tc) = pure (disqualify tc, acc) + go acc (P.TypeApp ty arg) = go (arg : acc) ty + go acc (P.TypeConstructor tc) = pure (P.disqualify tc, acc) go _ _ = throwError (GeneralError "Failed to read TypeConstructor") prettyCtor :: WildcardAnnotations -> Constructor -> Text -prettyCtor _ (ctorName, []) = T.pack (runProperName ctorName) +prettyCtor _ (ctorName, []) = runProperNameT ctorName prettyCtor wsa (ctorName, ctorArgs) = - "("<> T.pack (runProperName ctorName) <> " " + "("<> runProperNameT ctorName <> " " <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")" -prettyPrintWildcard :: WildcardAnnotations -> Type -> Text +prettyPrintWildcard :: WildcardAnnotations -> P.Type -> Text prettyPrintWildcard (WildcardAnnotations True) = prettyWildcard prettyPrintWildcard (WildcardAnnotations False) = const "_" -prettyWildcard :: Type -> Text -prettyWildcard t = "( _ :: " <> T.strip (T.pack (prettyPrintTypeAtom t)) <> ")" +prettyWildcard :: P.Type -> Text +prettyWildcard t = "( _ :: " <> T.strip (T.pack (P.prettyPrintTypeAtom t)) <> ")" -- | Constructs Patterns to insert into a sourcefile makePattern :: Text -- ^ Current line @@ -116,38 +125,38 @@ addClause :: Text -> WildcardAnnotations -> [Text] addClause s wca = let (fName, fType) = parseTypeDeclaration' (T.unpack s) (args, _) = splitFunctionType fType - template = T.pack (runIdent fName) <> " " <> + template = runIdentT fName <> " " <> T.unwords (map (prettyPrintWildcard wca) args) <> - " = ?" <> (T.strip . T.pack . runIdent $ fName) + " = ?" <> (T.strip . runIdentT $ fName) in [s, template] parseType' :: (MonadError PscIdeError m) => - String -> m Type + String -> m P.Type parseType' s = - case lex "" s >>= runTokenParser "" (parseType <* P.eof) of + case P.lex "" s >>= P.runTokenParser "" (P.parseType <* Parsec.eof) of Right type' -> pure type' Left err -> throwError (GeneralError ("Parsing the splittype failed with:" ++ show err)) -parseTypeDeclaration' :: String -> (Ident, Type) +parseTypeDeclaration' :: String -> (P.Ident, P.Type) parseTypeDeclaration' s = let x = do - ts <- lex "" s - runTokenParser "" (parseDeclaration <* P.eof) ts + ts <- P.lex "" s + P.runTokenParser "" (P.parseDeclaration <* Parsec.eof) ts in case unwrapPositioned <$> x of - Right (TypeDeclaration i t) -> (i, t) + Right (P.TypeDeclaration i t) -> (i, t) y -> error (show y) -splitFunctionType :: Type -> ([Type], Type) +splitFunctionType :: P.Type -> ([P.Type], P.Type) splitFunctionType t = (arguments, returns) where returns = last splitted arguments = init splitted splitted = splitType' t - splitType' (ForAll _ t' _) = splitType' t' - splitType' (ConstrainedType _ t') = splitType' t' - splitType' (TypeApp (TypeApp t' lhs) rhs) - | t' == tyFunction = lhs : splitType' rhs + splitType' (P.ForAll _ t' _) = splitType' t' + splitType' (P.ConstrainedType _ t') = splitType' t' + splitType' (P.TypeApp (P.TypeApp t' lhs) rhs) + | t' == P.tyFunction = lhs : splitType' rhs splitType' t' = [t'] diff --git a/src/Language/PureScript/Ide/CodecJSON.hs b/src/Language/PureScript/Ide/CodecJSON.hs deleted file mode 100644 index 8a264c0925..0000000000 --- a/src/Language/PureScript/Ide/CodecJSON.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Language.PureScript.Ide.CodecJSON where - -import Data.Aeson -import Data.Text (Text()) -import Data.Text.Lazy (toStrict, fromStrict) -import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) - -encodeT :: (ToJSON a) => a -> Text -encodeT = toStrict . decodeUtf8 . encode - -decodeT :: (FromJSON a) => Text -> Maybe a -decodeT = decode . encodeUtf8 . fromStrict - diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index d7387d4412..dbec3f1fe3 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -1,3 +1,17 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.Command +-- Description : Datatypes for the commands psc-ide accepts +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Datatypes for the commands psc-ide accepts +----------------------------------------------------------------------------- + {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -11,33 +25,64 @@ import Control.Monad import Data.Aeson import Data.Maybe import Data.Text (Text) +import Language.PureScript (ModuleName, + moduleNameFromString) import Language.PureScript.Ide.CaseSplit import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types data Command - = Load { loadModules :: [ModuleIdent] - , loadDependencies :: [ModuleIdent]} - | Type { typeSearch :: DeclIdent - , typeFilters :: [Filter]} - | Complete { completeFilters :: [Filter] - , completeMatcher :: Matcher} - | Pursuit { pursuitQuery :: PursuitQuery - , pursuitSearchType :: PursuitSearchType} - | List {listType :: ListType} - | CaseSplit { - caseSplitLine :: Text + = Load + { loadModules :: [ModuleIdent] + , loadDependencies :: [ModuleIdent] + } + | Type + { typeSearch :: DeclIdent + , typeFilters :: [Filter] + } + | Complete + { completeFilters :: [Filter] + , completeMatcher :: Matcher + } + | Pursuit + { pursuitQuery :: PursuitQuery + , pursuitSearchType :: PursuitSearchType + } + | CaseSplit + { caseSplitLine :: Text , caseSplitBegin :: Int , caseSplitEnd :: Int , caseSplitAnnotations :: WildcardAnnotations - , caseSplitType :: Type} - | AddClause { - addClauseLine :: Text - , addClauseAnnotations :: WildcardAnnotations} + , caseSplitType :: Text + } + | AddClause + { addClauseLine :: Text + , addClauseAnnotations :: WildcardAnnotations + } + -- Import InputFile OutputFile + | Import FilePath (Maybe FilePath) [Filter] ImportCommand + | List { listType :: ListType } | Cwd | Quit +data ImportCommand + = AddImplicitImport ModuleName + | AddImportForIdentifier DeclIdent + deriving (Show, Eq) + +instance FromJSON ImportCommand where + parseJSON = withObject "ImportCommand" $ \o -> do + (command :: String) <- o .: "importCommand" + case command of + "addImplicitImport" -> do + mn <- o .: "module" + pure (AddImplicitImport (moduleNameFromString mn)) + "addImport" -> do + ident <- o .: "identifier" + pure (AddImportForIdentifier ident) + _ -> mzero + data ListType = LoadedModules | Imports FilePath | AvailableModules instance FromJSON ListType where @@ -60,11 +105,11 @@ instance FromJSON Command where return $ List (fromMaybe LoadedModules listType') "cwd" -> return Cwd "quit" -> return Quit - "load" -> do - params <- o .: "params" - mods <- params .:? "modules" - deps <- params .:? "dependencies" - return $ Load (fromMaybe [] mods) (fromMaybe [] deps) + "load" -> + maybe (pure (Load [] [])) (\params -> do + mods <- params .:? "modules" + deps <- params .:? "dependencies" + pure $ Load (fromMaybe [] mods) (fromMaybe [] deps)) =<< o .:? "params" "type" -> do params <- o .: "params" search <- params .: "search" @@ -97,5 +142,12 @@ instance FromJSON Command where return $ AddClause line (if annotations then explicitAnnotations else noAnnotations) + "import" -> do + params <- o .: "params" + fp <- params .: "file" + out <- params .:? "outfile" + filters <- params .:? "filters" + importCommand <- params .: "importCommand" + pure $ Import fp out (fromMaybe [] filters) importCommand _ -> mzero diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index c81306680a..f120c6fe30 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -13,23 +13,20 @@ import Language.PureScript.Ide.Types -- | Applies the CompletionFilters and the Matcher to the given Modules -- and sorts the found Completions according to the Matching Score -getCompletions :: [Filter] -> Matcher -> [Module] -> [Completion] +getCompletions :: [Filter] -> Matcher -> [Module] -> [Match] getCompletions filters matcher modules = runMatcher matcher $ completionsFromModules (applyFilters filters modules) -getExactMatches :: DeclIdent -> [Filter] -> [Module] -> [Completion] +getExactMatches :: DeclIdent -> [Filter] -> [Module] -> [Match] getExactMatches search filters modules = completionsFromModules $ applyFilters (equalityFilter search : filters) modules -completionsFromModules :: [Module] -> [Completion] +completionsFromModules :: [Module] -> [Match] completionsFromModules = foldMap completionFromModule where - completionFromModule :: Module -> [Completion] - completionFromModule (moduleIdent, decls) = mapMaybe (completionFromDecl moduleIdent) decls + completionFromModule :: Module -> [Match] + completionFromModule (moduleIdent, decls) = mapMaybe (matchFromDecl moduleIdent) decls -completionFromDecl :: ModuleIdent -> ExternDecl -> Maybe Completion -completionFromDecl mi (FunctionDecl name type') = Just (Completion (mi, name, type')) -completionFromDecl mi (DataDecl name kind) = Just (Completion (mi, name, kind)) -completionFromDecl _ (ModuleDecl name _) = Just (Completion ("module", name, "module")) -completionFromDecl _ _ = Nothing +matchFromDecl :: ModuleIdent -> ExternDecl -> Maybe Match +matchFromDecl mi = Just . Match mi diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 02812111b2..37cccb39ee 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -1,6 +1,20 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.Error +-- Description : Error types for psc-ide +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Error types for psc-ide +----------------------------------------------------------------------------- + {-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Error - (ErrorMsg, PscIdeError(..), textError, first) + (ErrorMsg, PscIdeError(..), textError) where import Data.Aeson @@ -35,8 +49,3 @@ textError (ParseError parseError msg) = pack $ msg <> ": " <> show (escape parse -- escape newlines and other special chars so we can send the error over the socket as a single line escape :: P.ParseError -> String escape = show - --- | Specialized version of `first` from `Data.Bifunctors` -first :: (a -> b) -> Either a r -> Either b r -first f (Left x) = Left (f x) -first _ (Right r2) = Right r2 diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 0ce7a8ec4b..de64116099 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -1,3 +1,17 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.Externs +-- Description : Handles externs files for psc-ide +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Handles externs files for psc-ide +----------------------------------------------------------------------------- + {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -5,34 +19,32 @@ {-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Ide.Externs - ( - ExternDecl(..), + ( ExternDecl(..), ModuleIdent, DeclIdent, - Type, - Fixity(..), readExternFile, convertExterns, unwrapPositioned, unwrapPositionedRef ) where -import Prelude () +import Prelude () import Prelude.Compat import Control.Monad.Error.Class import Control.Monad.IO.Class -import Data.Maybe (mapMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Language.PureScript.AST.Declarations as D -import qualified Language.PureScript.Externs as PE -import Language.PureScript.Ide.CodecJSON -import Language.PureScript.Ide.Error (PscIdeError (..)) +import Data.List (nub) +import Data.Maybe (mapMaybe) +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Language.PureScript.Ide.Error (PscIdeError (..)) import Language.PureScript.Ide.Types -import qualified Language.PureScript.Names as N -import qualified Language.PureScript.Pretty as PP +import Language.PureScript.Ide.Util + +import qualified Language.PureScript as P +import qualified Language.PureScript.Externs as PE readExternFile :: (MonadIO m, MonadError PscIdeError m) => FilePath -> m PE.ExternsFile @@ -42,17 +54,14 @@ readExternFile fp = do Nothing -> throwError . GeneralError $ "Parsing the extern at: " ++ fp ++ " failed" Just externs -> pure externs -moduleNameToText :: N.ModuleName -> Text -moduleNameToText = T.pack . N.runModuleName +moduleNameToText :: P.ModuleName -> Text +moduleNameToText = T.pack . P.runModuleName -properNameToText :: N.ProperName a -> Text -properNameToText = T.pack . N.runProperName - -identToText :: N.Ident -> Text -identToText = T.pack . N.runIdent +identToText :: P.Ident -> Text +identToText = T.pack . P.runIdent convertExterns :: PE.ExternsFile -> Module -convertExterns ef = (moduleName, exportDecls ++ importDecls ++ otherDecls) +convertExterns ef = (moduleName, exportDecls ++ importDecls ++ decls) where moduleName = moduleNameToText (PE.efModuleName ef) importDecls = convertImport <$> PE.efImports ef @@ -61,42 +70,45 @@ convertExterns ef = (moduleName, exportDecls ++ importDecls ++ otherDecls) -- operatorDecls = convertOperator <$> PE.efFixities ef otherDecls = mapMaybe convertDecl (PE.efDeclarations ef) + typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration otherDecls) + decls = nub $ appEndo typeClassFilter otherDecls + +removeTypeDeclarationsForClass :: ExternDecl -> Endo [ExternDecl] +removeTypeDeclarationsForClass (TypeClassDeclaration n) = Endo (filter notDuplicate) + where notDuplicate (TypeDeclaration n' _) = runProperNameT n /= runProperNameT n' + notDuplicate (TypeSynonymDeclaration n' _) = runProperNameT n /= runProperNameT n' + notDuplicate _ = True +removeTypeDeclarationsForClass _ = mempty + +isTypeClassDeclaration :: ExternDecl -> Bool +isTypeClassDeclaration TypeClassDeclaration{} = True +isTypeClassDeclaration _ = False + convertImport :: PE.ExternsImport -> ExternDecl convertImport ei = Dependency (moduleNameToText (PE.eiModule ei)) [] (moduleNameToText <$> PE.eiImportedAs ei) -convertExport :: D.DeclarationRef -> Maybe ExternDecl -convertExport (D.ModuleRef mn) = Just (Export (moduleNameToText mn)) +convertExport :: P.DeclarationRef -> Maybe ExternDecl +convertExport (P.ModuleRef mn) = Just (Export (moduleNameToText mn)) convertExport _ = Nothing convertDecl :: PE.ExternsDeclaration -> Maybe ExternDecl -convertDecl PE.EDType{..} = Just $ - DataDecl - (properNameToText edTypeName) - (packAndStrip (PP.prettyPrintKind edTypeKind)) +convertDecl PE.EDType{..} = Just $ TypeDeclaration edTypeName edTypeKind convertDecl PE.EDTypeSynonym{..} = Just $ - DataDecl - (properNameToText edTypeSynonymName) - (packAndStrip (PP.prettyPrintType edTypeSynonymType)) + TypeSynonymDeclaration edTypeSynonymName edTypeSynonymType convertDecl PE.EDDataConstructor{..} = Just $ - DataDecl - (properNameToText edDataCtorName) - (packAndStrip (PP.prettyPrintType edDataCtorType)) + DataConstructor (runProperNameT edDataCtorName) edDataCtorTypeCtor edDataCtorType convertDecl PE.EDValue{..} = Just $ - FunctionDecl - (identToText edValueName) - (packAndStrip (PP.prettyPrintType edValueType)) -convertDecl _ = Nothing - -packAndStrip :: String -> Text -packAndStrip = T.unwords . fmap T.strip . T.lines . T.pack + ValueDeclaration (identToText edValueName) edValueType +convertDecl PE.EDClass{..} = Just $ TypeClassDeclaration edClassName +convertDecl PE.EDInstance{} = Nothing -unwrapPositioned :: D.Declaration -> D.Declaration -unwrapPositioned (D.PositionedDeclaration _ _ x) = x +unwrapPositioned :: P.Declaration -> P.Declaration +unwrapPositioned (P.PositionedDeclaration _ _ x) = x unwrapPositioned x = x -unwrapPositionedRef :: D.DeclarationRef -> D.DeclarationRef -unwrapPositionedRef (D.PositionedDeclarationRef _ _ x) = x +unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef +unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = x unwrapPositionedRef x = x diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 47deed9acf..8055e36493 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -1,10 +1,30 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.Filter +-- Description : Filters for psc-ide commands +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Filters for psc-ide commands +----------------------------------------------------------------------------- + {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} + module Language.PureScript.Ide.Filter - (Filter, moduleFilter, prefixFilter, equalityFilter, dependencyFilter, - runFilter, applyFilters) - where + ( Filter + , moduleFilter + , prefixFilter + , equalityFilter + , dependencyFilter + , runFilter + , applyFilters + ) where import Prelude () import Prelude.Compat @@ -16,6 +36,7 @@ import Data.Maybe (listToMaybe, mapMaybe) import Data.Monoid import Data.Text (Text, isPrefixOf) import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util newtype Filter = Filter (Endo [Module]) deriving(Monoid) @@ -57,10 +78,9 @@ prefixFilter "" = mkFilter id prefixFilter t = mkFilter $ identFilter prefix t where prefix :: ExternDecl -> Text -> Bool - prefix (FunctionDecl name _) search = search `isPrefixOf` name - prefix (DataDecl name _) search = search `isPrefixOf` name - prefix (ModuleDecl name _) search = search `isPrefixOf` name - prefix _ _ = False + prefix Export{} _ = False + prefix Dependency{} _ = False + prefix ed search = search `isPrefixOf` identifierFromExternDecl ed -- | Only keeps Identifiers that are equal to the search string @@ -68,10 +88,7 @@ equalityFilter :: Text -> Filter equalityFilter = mkFilter . identFilter equality where equality :: ExternDecl -> Text -> Bool - equality (FunctionDecl name _) prefix = prefix == name - equality (DataDecl name _) prefix = prefix == name - equality _ _ = False - + equality ed search = identifierFromExternDecl ed == search identFilter :: (ExternDecl -> Text -> Bool ) -> Text -> [Module] -> [Module] identFilter predicate search = diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs new file mode 100644 index 0000000000..8fe4dcfc39 --- /dev/null +++ b/src/Language/PureScript/Ide/Imports.hs @@ -0,0 +1,355 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.Imports +-- Description : Provides functionality to manage imports +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Provides functionality to manage imports +----------------------------------------------------------------------------- + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +module Language.PureScript.Ide.Imports + ( addImplicitImport + , addImportForIdentifier + , answerRequest + -- for tests + , parseImport + , prettyPrintImportSection + , addImplicitImport' + , addExplicitImport' + , sliceImportSection + , prettyPrintImport' + , Import(Import) + ) + where + +import Control.Applicative ((<|>)) +import Control.Monad.Error.Class +import Control.Monad.IO.Class +import "monad-logger" Control.Monad.Logger +import Data.Bifunctor (first, second) +import Data.Function (on) +import qualified Data.List as List +import Data.Maybe (isNothing) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Language.PureScript as P +import Language.PureScript.Ide.Completion +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Externs (unwrapPositioned, + unwrapPositionedRef) +import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.State +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util + +data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) + deriving (Eq, Show) + +instance Ord Import where + compare = compImport + +compImportType :: P.ImportDeclarationType -> P.ImportDeclarationType -> Ordering +compImportType P.Implicit P.Implicit = EQ +compImportType P.Implicit _ = LT +compImportType (P.Explicit _) (P.Hiding _) = LT +compImportType (P.Explicit _) (P.Explicit _) = EQ +compImportType (P.Explicit _) P.Implicit = GT +compImportType (P.Hiding _) (P.Hiding _) = EQ +compImportType (P.Hiding _) _ = GT + +compImport :: Import -> Import -> Ordering +compImport (Import n i q) (Import n' i' q') + | compImportType i i' /= EQ = compImportType i i' + -- This means that for a stable sort, the first implicit import will stay + -- the first implicit import + | P.isImplicit i && isNothing q = LT + | P.isImplicit i && isNothing q' = GT + | otherwise = compare n n' + +-- | Reads a file and returns the (lines before the imports, the imports, the +-- lines after the imports) +parseImportsFromFile :: (MonadIO m, MonadError PscIdeError m) => + FilePath -> m (P.ModuleName, [Text], [Import], [Text]) +parseImportsFromFile fp = do + file <- liftIO (TIO.readFile fp) + case sliceImportSection (T.lines file) of + Right res -> pure res + Left err -> throwError (GeneralError err) + +parseImportsWithModuleName :: [Text] -> Either String (P.ModuleName, [Import]) +parseImportsWithModuleName ls = do + (P.Module _ _ mn decls _) <- moduleParse ls + pure (mn, concatMap mkImport (unwrapPositioned <$> decls)) + where + mkImport (P.ImportDeclaration mn (P.Explicit refs) qual _) = + [Import mn (P.Explicit (unwrapPositionedRef <$> refs)) qual] + mkImport (P.ImportDeclaration mn it qual _) = [Import mn it qual] + mkImport _ = [] + +sliceImportSection :: [Text] -> Either String (P.ModuleName, [Text], [Import], [Text]) +sliceImportSection ts = + case foldl step (ModuleHeader 0) (zip [0..] ts) of + Res start end -> + let + (moduleHeader, (importSection, remainingFile)) = + List.splitAt (succ (end - start)) `second` List.splitAt start ts + in + (\(mn, is) -> (mn, moduleHeader, is, remainingFile)) <$> + parseImportsWithModuleName (moduleHeader <> importSection) + + -- If we don't find any imports, we insert a newline after the module + -- declaration and begin a new importsection + ModuleHeader ix -> + let (moduleHeader, remainingFile) = List.splitAt (succ ix) ts + in + (\(mn, is) -> (mn, moduleHeader ++ [""], is, remainingFile)) <$> + parseImportsWithModuleName moduleHeader + _ -> Left "Failed to detect the import section" + +data ImportStateMachine = ModuleHeader Int | ImportSection Int Int | Res Int Int + +-- | We start in the +-- +-- * ModuleHeader state. +-- +-- We skip every line we encounter, that doesn't start with "import". If we find +-- a line that starts with module we store that linenumber. Once we find a line +-- with "import" we store its linenumber as the start of the import section and +-- change into the +-- +-- * ImportSection state +-- +-- For any line that starts with import or whitespace(is thus indented) we +-- expand the end of the import section to that line and continue. If we +-- encounter a commented or empty line, we continue moving forward in the +-- ImportSection state but don't expand the import section end yet. This allows +-- us to exclude newlines or comments that directly follow the import section. +-- Once we encounter a line that is not a comment, newline, indentation or +-- import we switch into the +-- +-- * Res state +-- +-- , which just shortcuts to the end of the file and carries the detected import +-- section boundaries +step :: ImportStateMachine -> (Int, Text) -> ImportStateMachine +step (ModuleHeader mi) (ix, l) + | T.isPrefixOf "module " l = ModuleHeader ix + | T.isPrefixOf "import " l = ImportSection ix ix + | otherwise = ModuleHeader mi +step (ImportSection start lastImportLine) (ix, l) + | any (`T.isPrefixOf` l) ["import", " "] = ImportSection start ix + | T.isPrefixOf "--" l || l == "" = ImportSection start lastImportLine + | otherwise = Res start lastImportLine +step (Res start end) _ = Res start end + +moduleParse :: [Text] -> Either String P.Module +moduleParse t = first show $ do + tokens <- (P.lex "" . T.unpack . T.unlines) t + P.runTokenParser "" P.parseModule tokens + +-- | Adds an implicit import like @import Prelude@ to a Sourcefile. +addImplicitImport :: (MonadIO m, MonadError PscIdeError m) + => FilePath -- ^ The Sourcefile read from + -> P.ModuleName -- ^ The module to import + -> m [Text] +addImplicitImport fp mn = do + (_, pre, imports, post) <- parseImportsFromFile fp + let newImportSection = addImplicitImport' imports mn + pure $ pre ++ newImportSection ++ post + +addImplicitImport' :: [Import] -> P.ModuleName -> [Text] +addImplicitImport' imports mn = + -- We need to append the new import, because there could already be implicit + -- imports and we need to preserve the order on these, as the first implicit + -- import is the one that doesn't generate warnings. + prettyPrintImportSection ( imports ++ [Import mn P.Implicit Nothing]) + +-- | Adds an explicit import like @import Prelude (unit)@ to a Sourcefile. If an +-- explicit import already exists for the given module, it adds the identifier +-- to that imports list. +-- +-- So @addExplicitImport "/File.purs" "bind" "Prelude"@ with an already existing +-- @import Prelude (bind)@ in the file File.purs returns @["import Prelude +-- (bind, unit)"]@ +addExplicitImport :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) => + FilePath -> ExternDecl -> P.ModuleName -> m [Text] +addExplicitImport fp decl moduleName = do + (mn, pre, imports, post) <- parseImportsFromFile fp + let newImportSection = + -- TODO: Open an issue when this PR is merged, we should optimise this + -- so that this case does not write to disc + if mn == moduleName + then imports + else addExplicitImport' decl moduleName imports + pure (pre ++ prettyPrintImportSection newImportSection ++ post) + +addExplicitImport' :: ExternDecl -> P.ModuleName -> [Import] -> [Import] +addExplicitImport' decl moduleName imports = + let + isImplicitlyImported = + not . null $ filter (\case + (Import mn P.Implicit Nothing) -> mn == moduleName + _ -> False) imports + matches (Import mn (P.Explicit _) Nothing) = mn == moduleName + matches _ = False + freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) Nothing + in + if isImplicitlyImported + then imports + else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports + where + refFromDeclaration (TypeClassDeclaration n) = P.TypeClassRef n + refFromDeclaration (DataConstructor n tn _) = + P.TypeRef tn (Just [P.ProperName (T.unpack n)]) + refFromDeclaration (TypeDeclaration n _) = P.TypeRef n (Just []) + refFromDeclaration d = + let + ident = T.unpack (identifierFromExternDecl d) + in + P.ValueRef ((if all P.isSymbolChar ident then P.Op else P.Ident) ident) + + -- | Adds a declaration to an import: + -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) + insertDeclIntoImport :: ExternDecl -> Import -> Import + insertDeclIntoImport decl' (Import mn (P.Explicit refs) Nothing) = + Import mn (P.Explicit (insertDeclIntoRefs decl' refs)) Nothing + insertDeclIntoImport _ is = is + + insertDeclIntoRefs :: ExternDecl -> [P.DeclarationRef] -> [P.DeclarationRef] + insertDeclIntoRefs (DataConstructor dtor tn _) refs = + let + dtor' = P.ProperName (T.unpack dtor) + -- TODO: Get rid of this once typeclasses can't be imported like types + refs' = properRefToTypeRef <$> refs + in + updateAtFirstOrPrepend (matchType tn) (insertDtor dtor') (P.TypeRef tn (Just [dtor'])) refs' + insertDeclIntoRefs dr refs = List.nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) + + insertDtor dtor (P.TypeRef tn' dtors) = + case dtors of + Just dtors' -> P.TypeRef tn' (Just (List.nub (dtor : dtors'))) + -- This means the import was opened. We don't add anything in this case + -- import Data.Maybe (Maybe(..)) -> import Data.Maybe (Maybe(Just)) + Nothing -> P.TypeRef tn' Nothing + insertDtor _ refs = refs + + + -- TODO: Get rid of this once typeclasses can't be imported like types + properRefToTypeRef (P.ProperRef n) = P.TypeRef (P.ProperName n) (Just []) + properRefToTypeRef r = r + + matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool + matchType tn (P.TypeRef n _) = tn == n + matchType _ _ = False + +updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a] +updateAtFirstOrPrepend p t d l = + case List.findIndex p l of + Nothing -> d : l + Just ix -> + let (x, a : y) = List.splitAt ix l + in x ++ [t a] ++ y + +-- | Looks up the given identifier in the currently loaded modules. +-- +-- * Throws an error if the identifier cannot be found. +-- +-- * If exactly one match is found, adds an explicit import to the importsection +-- +-- * If more than one possible imports are found, reports the possibilities as a +-- list of completions. +addImportForIdentifier :: (PscIde m, MonadError PscIdeError m, MonadLogger m) + => FilePath -- ^ The Sourcefile to read from + -> Text -- ^ The identifier to import + -> [Filter] -- ^ Filters to apply before searching for + -- the identifier + -> m (Either [Match] [Text]) +addImportForIdentifier fp ident filters = do + modules <- getAllModulesWithReexports + case getExactMatches ident filters modules of + [] -> + throwError (NotFound "Couldn't find the given identifier. \ + \Have you loaded the corresponding module?") + + -- Only one match was found for the given identifier, so we can insert it + -- right away + [Match m decl] -> + Right <$> addExplicitImport fp decl (P.moduleNameFromString (T.unpack m)) + + -- This case comes up for newtypes and dataconstructors. Because values and + -- types don't share a namespace we can get multiple matches from the same + -- module. This also happens for parameterized types, as these generate both + -- a type aswell as a type synonym. + + ms@[Match m1 d1, Match m2 d2] -> + if m1 /= m2 + -- If the modules don't line up we just ask the user to specify the + -- module + then pure $ Left ms + else case decideRedundantCase d1 d2 <|> decideRedundantCase d2 d1 of + -- If dataconstructor and type line up we just import the + -- dataconstructor as that will give us an unnecessary import warning at + -- worst + Just decl -> + Right <$> addExplicitImport fp decl (P.moduleNameFromString (T.unpack m1)) + -- Here we need the user to specify whether he wanted a dataconstructor + -- or a type + Nothing -> + throwError (GeneralError "Undecidable between type and dataconstructor") + + -- Multiple matches were found so we need to ask the user to clarify which + -- module he meant + xs -> + pure $ Left xs + where + decideRedundantCase dtor@(DataConstructor _ t _) (TypeDeclaration t' _) = + if t == t' then Just dtor else Nothing + decideRedundantCase TypeDeclaration{} ts@TypeSynonymDeclaration{} = + Just ts + decideRedundantCase _ _ = Nothing + +prettyPrintImport' :: Import -> Text +-- TODO: remove this clause once P.prettyPrintImport can properly handle PositionedRefs +prettyPrintImport' (Import mn (P.Explicit refs) qual) = + T.pack $ "import " ++ P.prettyPrintImport mn (P.Explicit (unwrapPositionedRef <$> refs)) qual +prettyPrintImport' (Import mn idt qual) = + T.pack $ "import " ++ P.prettyPrintImport mn idt qual + +prettyPrintImportSection :: [Import] -> [Text] +prettyPrintImportSection imports = map prettyPrintImport' (List.sort imports) + +-- | Writes a list of lines to @Just filepath@ and responds with a @TextResult@, +-- or returns the lines as a @MultilineTextResult@ if @Nothing@ was given as the +-- first argument. +answerRequest :: (MonadIO m) => Maybe FilePath -> [Text] -> m Success +answerRequest outfp rs = + case outfp of + Nothing -> pure $ MultilineTextResult rs + Just outfp' -> do + liftIO $ TIO.writeFile outfp' (T.unlines rs) + pure $ TextResult $ "Written to " <> T.pack outfp' + +-- | Test and ghci helper +parseImport :: Text -> Maybe Import +parseImport t = + case P.lex "" (T.unpack t) + >>= P.runTokenParser "" P.parseImportDeclaration' of + Right (mn, P.Explicit refs, mmn, _) -> + Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn) + Right (mn, idt, mmn, _) -> Just (Import mn idt mmn) + Left _ -> Nothing + diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index 65244a6d32..d99a36ef6d 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -1,7 +1,26 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.Matcher +-- Description : Matchers for psc-ide commands +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Matchers for psc-ide commands +----------------------------------------------------------------------------- + {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.PureScript.Ide.Matcher (Matcher, flexMatcher, runMatcher) where + +module Language.PureScript.Ide.Matcher + ( Matcher + , flexMatcher + , runMatcher + ) where import Prelude () import Prelude.Compat @@ -16,13 +35,14 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util import Text.EditDistance import Text.Regex.TDFA ((=~)) -type ScoredCompletion = (Completion, Double) +type ScoredMatch = (Match, Double) -newtype Matcher = Matcher (Endo [Completion]) deriving(Monoid) +newtype Matcher = Matcher (Endo [Match]) deriving(Monoid) instance FromJSON Matcher where parseJSON = withObject "matcher" $ \o -> do @@ -41,42 +61,43 @@ instance FromJSON Matcher where Nothing -> return mempty -- | Matches any occurence of the search string with intersections --- | --- | The scoring measures how far the matches span the string where --- | closer is better. --- | Examples: --- | flMa matches flexMatcher. Score: 14.28 --- | sons matches sortCompletions. Score: 6.25 +-- +-- The scoring measures how far the matches span the string where +-- closer is better. +-- Examples: +-- flMa matches flexMatcher. Score: 14.28 +-- sons matches sortCompletions. Score: 6.25 flexMatcher :: Text -> Matcher -flexMatcher pattern = mkMatcher (flexMatch pattern) +flexMatcher p = mkMatcher (flexMatch p) distanceMatcher :: Text -> Int -> Matcher distanceMatcher q maxDist = mkMatcher (distanceMatcher' q maxDist) -distanceMatcher' :: Text -> Int -> [Completion] -> [ScoredCompletion] +distanceMatcher' :: Text -> Int -> [Match] -> [ScoredMatch] distanceMatcher' q maxDist = mapMaybe go where - go c@(Completion (_, y, _)) = let d = dist (T.unpack y) - in if d <= maxDist - then Just (c, 1 / fromIntegral d) - else Nothing + go m = let d = dist (T.unpack y) + y = identifierFromMatch m + in if d <= maxDist + then Just (m, 1 / fromIntegral d) + else Nothing dist = levenshteinDistance defaultEditCosts (T.unpack q) -mkMatcher :: ([Completion] -> [ScoredCompletion]) -> Matcher +mkMatcher :: ([Match] -> [ScoredMatch]) -> Matcher mkMatcher matcher = Matcher . Endo $ fmap fst . sortCompletions . matcher -runMatcher :: Matcher -> [Completion] -> [Completion] +runMatcher :: Matcher -> [Match] -> [Match] runMatcher (Matcher m)= appEndo m -sortCompletions :: [ScoredCompletion] -> [ScoredCompletion] +sortCompletions :: [ScoredMatch] -> [ScoredMatch] sortCompletions = sortBy (flip compare `on` snd) -flexMatch :: Text -> [Completion] -> [ScoredCompletion] -flexMatch pattern = mapMaybe (flexRate pattern) +flexMatch :: Text -> [Match] -> [ScoredMatch] +flexMatch = mapMaybe . flexRate -flexRate :: Text -> Completion -> Maybe ScoredCompletion -flexRate pattern c@(Completion (_,ident,_)) = do - score <- flexScore pattern ident +flexRate :: Text -> Match -> Maybe ScoredMatch +flexRate p c = do + score <- flexScore p (identifierFromMatch c) return (c, score) -- FlexMatching ala Sublime. @@ -89,13 +110,13 @@ flexScore :: Text -> DeclIdent -> Maybe Double flexScore pat str = case T.uncons pat of Nothing -> Nothing - Just (first, pattern) -> + Just (first, p) -> case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of (-1,0) -> Nothing (start,len) -> Just $ calcScore start (start + len) where escapedPattern :: [Text] - escapedPattern = map escape (T.unpack pattern) + escapedPattern = map escape (T.unpack p) -- escape prepends a backslash to "regexy" characters to prevent the -- matcher from crashing when trying to build the regex diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs index ed401f4f50..7a9eb9da7f 100644 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -1,3 +1,17 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.Pursuit +-- Description : Pursuit client for psc-ide +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Pursuit client for psc-ide +----------------------------------------------------------------------------- + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index fa00f5652f..2ab8a851e8 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -1,6 +1,22 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.Reexports +-- Description : Resolves reexports for psc-ide +-- Copyright : Christoph Hegemann 2016 +-- Brian Sermons 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Resolves reexports for psc-ide +----------------------------------------------------------------------------- + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TupleSections #-} + module Language.PureScript.Ide.Reexports where diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 846a8faee7..24ce7dea08 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -1,6 +1,21 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.SourceFile +-- Description : Getting declarations from PureScript sourcefiles +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Getting declarations from PureScript sourcefiles +----------------------------------------------------------------------------- + {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} + module Language.PureScript.Ide.SourceFile where import Prelude @@ -69,7 +84,7 @@ getPositionedImports :: D.Module -> [D.Declaration] getPositionedImports (D.Module _ _ _ declarations _) = mapMaybe isImport declarations where - isImport i@(D.PositionedDeclaration _ _ (D.ImportDeclaration{})) = Just i + isImport i@(D.PositionedDeclaration _ _ D.ImportDeclaration{}) = Just i isImport _ = Nothing getDeclPosition :: D.Module -> String -> Maybe SP.SourceSpan diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 80791c2756..b649fe8c77 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -1,3 +1,17 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.State +-- Description : Functions to access psc-ide's state +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Functions to access psc-ide's state +----------------------------------------------------------------------------- + {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -68,12 +82,13 @@ insertModule ::(PscIde m, MonadLogger m) => insertModule externsFile = do env <- ask let moduleName = efModuleName externsFile - $(logDebug) $ "Inserting Module: " <> (T.pack (runModuleName moduleName)) + $(logDebug) $ "Inserting Module: " <> T.pack (runModuleName moduleName) liftIO . atomically $ insertModule' (envStateVar env) externsFile insertModule' :: TVar PscIdeState -> ExternsFile -> STM () -insertModule' st ef = modifyTVar st $ \x -> - x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x) - , pscStateModules = let (mn, decls) = convertExterns ef - in M.insert mn decls (pscStateModules x) - } +insertModule' st ef = + modifyTVar st $ \x -> + x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x) + , pscStateModules = let (mn, decls) = convertExterns ef + in M.insert mn decls (pscStateModules x) + } diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 8692e69dd2..d1349e1e8c 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -1,3 +1,17 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.Types +-- Description : Type definitions for psc-ide +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Type definitions for psc-ide +----------------------------------------------------------------------------- + {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -19,51 +33,40 @@ import Data.Maybe (maybeToList) import Data.Text (Text (), pack, unpack) import qualified Language.PureScript.AST.Declarations as D import Language.PureScript.Externs -import Language.PureScript.Names import qualified Language.PureScript.Names as N +import qualified Language.PureScript as P import Text.Parsec import Text.Parsec.Text +type Ident = Text +type DeclIdent = Text type ModuleIdent = Text -type DeclIdent = Text -type Type = Text - -data Fixity = Infix | Infixl | Infixr deriving(Show, Eq, Ord) data ExternDecl -- | A function/value declaration - = FunctionDecl - DeclIdent -- The functions name - Type -- The functions type - | FixityDeclaration Fixity Int DeclIdent + = ValueDeclaration Ident P.Type + | TypeDeclaration (P.ProperName 'P.TypeName) P.Kind + | TypeSynonymDeclaration (P.ProperName 'P.TypeName) P.Type -- | A Dependency onto another Module | Dependency ModuleIdent -- name of the dependency [Text] -- explicit imports (Maybe Text) -- An eventual qualifier - -- | A module declaration | ModuleDecl ModuleIdent -- The modules name [DeclIdent] -- The exported identifiers -- | A data/newtype declaration - | DataDecl DeclIdent -- The type name - Text -- The "type" + | DataConstructor + DeclIdent -- ^ The type name + (P.ProperName 'P.TypeName) + P.Type -- ^ The "type" -- | An exported module + | TypeClassDeclaration (P.ProperName 'P.ClassName) | Export ModuleIdent -- The exported Modules name deriving (Show,Eq,Ord) -instance ToJSON ExternDecl where - toJSON (FunctionDecl n t) = object ["name" .= n, "type" .= t] - toJSON (ModuleDecl n t) = object ["name" .= n, "type" .= t] - toJSON (DataDecl n t) = object ["name" .= n, "type" .= t] - toJSON (Dependency n names _) = object ["module" .= n, "names" .= names] - toJSON (FixityDeclaration f p n) = object ["name" .= n - , "fixity" .= show f - , "precedence" .= p] - toJSON (Export _) = object [] - type Module = (ModuleIdent, [ExternDecl]) data Configuration = @@ -83,15 +86,22 @@ type PscIde m = (MonadIO m, MonadReader PscIdeEnvironment m) data PscIdeState = PscIdeState { pscStateModules :: M.Map Text [ExternDecl] - , externsFiles :: M.Map ModuleName ExternsFile + , externsFiles :: M.Map P.ModuleName ExternsFile } deriving Show emptyPscIdeState :: PscIdeState emptyPscIdeState = PscIdeState M.empty M.empty +data Match = Match ModuleIdent ExternDecl + deriving (Show, Eq) + newtype Completion = - Completion (ModuleIdent, DeclIdent, Type) - deriving (Show,Eq) + Completion (ModuleIdent, DeclIdent, Text) + deriving (Show,Eq) + +instance ToJSON Completion where + toJSON (Completion (m,d,t)) = + object ["module" .= m, "identifier" .= d, "type" .= t] data ModuleImport = ModuleImport @@ -127,18 +137,6 @@ identifierFromDeclarationRef (D.ValueRef ident) = N.runIdent ident identifierFromDeclarationRef (D.TypeClassRef name) = N.runProperName name identifierFromDeclarationRef _ = "" -instance FromJSON Completion where - parseJSON (Object o) = do - m <- o .: "module" - d <- o .: "identifier" - t <- o .: "type" - pure (Completion (m, d, t)) - parseJSON _ = mzero - -instance ToJSON Completion where - toJSON (Completion (m,d,t)) = - object ["module" .= m, "identifier" .= d, "type" .= t] - data Success = CompletionResult [Completion] | TextResult Text @@ -174,7 +172,7 @@ instance FromJSON PursuitSearchType where parseJSON _ = mzero instance FromJSON PursuitQuery where - parseJSON o = PursuitQuery <$> (parseJSON o) + parseJSON o = PursuitQuery <$> parseJSON o data PursuitResponse = -- | A Pursuit Response for a module. Consists of the modules name and the @@ -182,7 +180,7 @@ data PursuitResponse = ModuleResponse ModuleIdent Text -- | A Pursuit Response for a declaration. Consist of the declarations type, -- module, name and package - | DeclarationResponse Type ModuleIdent DeclIdent Text + | DeclarationResponse Text ModuleIdent DeclIdent Text deriving (Show,Eq) instance FromJSON PursuitResponse where @@ -215,15 +213,15 @@ typeParse t = case parse parseType "" t of type' <- many1 anyChar pure (unpack name, type') -identifier :: Parser Text -identifier = do - spaces - ident <- - -- necessary for being able to parse the following ((++), concat) - between (char '(') (char ')') (many1 (noneOf ", )")) <|> - many1 (noneOf ", )") - spaces - pure (pack ident) + identifier :: Parser Text + identifier = do + spaces + ident <- + -- necessary for being able to parse the following ((++), concat) + between (char '(') (char ')') (many1 (noneOf ", )")) <|> + many1 (noneOf ", )") + spaces + pure (pack ident) instance ToJSON PursuitResponse where toJSON (ModuleResponse name package) = diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs new file mode 100644 index 0000000000..d963282b55 --- /dev/null +++ b/src/Language/PureScript/Ide/Util.hs @@ -0,0 +1,65 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.Util +-- Description : Generally useful functions and conversions +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Generally useful functions and conversions +----------------------------------------------------------------------------- + +{-# LANGUAGE OverloadedStrings #-} + +module Language.PureScript.Ide.Util where + +import Data.Aeson +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Lazy (fromStrict, toStrict) +import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) +import qualified Language.PureScript as P +import Language.PureScript.Ide.Types + +runProperNameT :: P.ProperName a -> Text +runProperNameT = T.pack . P.runProperName + +runIdentT :: P.Ident -> Text +runIdentT = T.pack . P.runIdent + +prettyTypeT :: P.Type -> Text +prettyTypeT = T.unwords . fmap T.strip . T.lines . T.pack . P.prettyPrintType + +identifierFromExternDecl :: ExternDecl -> Text +identifierFromExternDecl (ValueDeclaration name _) = name +identifierFromExternDecl (TypeDeclaration name _) = runProperNameT name +identifierFromExternDecl (TypeSynonymDeclaration name _) = runProperNameT name +identifierFromExternDecl (DataConstructor name _ _) = name +identifierFromExternDecl (TypeClassDeclaration name) = runProperNameT name +identifierFromExternDecl (ModuleDecl name _) = name +identifierFromExternDecl Dependency{} = "~Dependency~" +identifierFromExternDecl Export{} = "~Export~" + +identifierFromMatch :: Match -> Text +identifierFromMatch (Match _ ed) = identifierFromExternDecl ed + +completionFromMatch :: Match -> Maybe Completion +completionFromMatch (Match _ Dependency{}) = Nothing +completionFromMatch (Match _ Export{}) = Nothing +completionFromMatch (Match m d) = Just $ case d of + ValueDeclaration name type' -> Completion (m, name, prettyTypeT type') + TypeDeclaration name kind -> Completion (m, runProperNameT name, T.pack $ P.prettyPrintKind kind) + TypeSynonymDeclaration name kind -> Completion (m, runProperNameT name, prettyTypeT kind) + DataConstructor name _ type' -> Completion (m, name, prettyTypeT type') + TypeClassDeclaration name -> Completion (m, runProperNameT name, "class") + ModuleDecl name _ -> Completion ("module", name, "module") + _ -> error "the impossible happened in completionFromMatch" + +encodeT :: (ToJSON a) => a -> Text +encodeT = toStrict . decodeUtf8 . encode + +decodeT :: (FromJSON a) => Text -> Maybe a +decodeT = decode . encodeUtf8 . fromStrict diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs index 9a6c1ff684..184df16471 100644 --- a/src/Language/PureScript/Ide/Watcher.hs +++ b/src/Language/PureScript/Ide/Watcher.hs @@ -1,4 +1,19 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.Watcher +-- Description : File watcher for externs files +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- File watcher for externs files +----------------------------------------------------------------------------- + {-# LANGUAGE RecordWildCards #-} + module Language.PureScript.Ide.Watcher where import Prelude () diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index 4469127d7d..700e30ea61 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -4,15 +4,19 @@ module Language.PureScript.Ide.FilterSpec where import Data.Text (Text) import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Types +import qualified Language.PureScript as P import Test.Hspec +value :: Text -> ExternDecl +value s = ValueDeclaration s P.TypeWildcard + modules :: [Module] modules = [ - ("Module.A", [FunctionDecl "function1" ""]), - ("Module.B", [DataDecl "data1" ""]), + ("Module.A", [value "function1"]), + ("Module.B", [value "data1"]), ("Module.C", [ModuleDecl "Module.C" []]), - ("Module.D", [Dependency "Module.C" [] Nothing, FunctionDecl "asd" ""]) + ("Module.D", [Dependency "Module.C" [] Nothing, value "asd"]) ] runEq :: Text -> [Module] diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs new file mode 100644 index 0000000000..999281993a --- /dev/null +++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.PureScript.Ide.Imports.IntegrationSpec where + +import Control.Monad +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Language.PureScript.Ide.Integration as Integration +import Test.Hspec + +import System.Directory +import System.FilePath + +setup :: IO () +setup = do + Integration.deleteOutputFolder + s <- Integration.compileTestProject + unless s $ fail "Failed to compile .purs sources" + Integration.quitServer -- kill a eventually running psc-ide-server instance + _ <- Integration.startServer + mapM_ Integration.loadModuleWithDeps ["ImportsSpec", "ImportsSpec1"] + +teardown :: IO () +teardown = Integration.quitServer + +withSupportFiles :: (FilePath -> FilePath -> IO a) -> IO () +withSupportFiles test = do + pdir <- Integration.projectDirectory + let sourceFp = pdir "src" "ImportsSpec.purs" + outFp = pdir "src" "ImportsSpecOut.tmp" + Integration.deleteFileIfExists outFp + void $ test sourceFp outFp + +outputFileShouldBe :: [Text] -> IO () +outputFileShouldBe expectation = do + outFp <- ( "src" "ImportsSpecOut.tmp") <$> Integration.projectDirectory + outRes <- TIO.readFile outFp + shouldBe (T.lines outRes) expectation + +spec :: Spec +spec = beforeAll_ setup $ afterAll_ teardown $ describe "Adding imports" $ do + let + sourceFileSkeleton :: [Text] -> [Text] + sourceFileSkeleton importSection = + [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId = id"] + it "adds an implicit import" $ do + withSupportFiles (Integration.addImplicitImport "Prelude") + outputFileShouldBe (sourceFileSkeleton + [ "import Prelude" + , "import Main (id)" + ]) + it "adds an explicit unqualified import" $ do + withSupportFiles (Integration.addImport "exportedFunction") + outputFileShouldBe (sourceFileSkeleton + [ "import ImportsSpec1 (exportedFunction)" + , "import Main (id)" + ]) + it "adds an explicit unqualified import (type)" $ do + withSupportFiles (Integration.addImport "MyType") + outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyType)" + , "import Main (id)" + ]) + it "adds an explicit unqualified import (parameterized type)" $ do + withSupportFiles (Integration.addImport "MyParamType") + outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyParamType)" + , "import Main (id)" + ]) + it "adds an explicit unqualified import (typeclass)" $ do + withSupportFiles (Integration.addImport "ATypeClass") + outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (class ATypeClass)" + , "import Main (id)"]) + it "adds an explicit unqualified import (dataconstructor)" $ do + withSupportFiles (Integration.addImport "MyJust") + outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyMaybe(MyJust))" + , "import Main (id)"]) + it "adds an explicit unqualified import (newtype)" $ do + withSupportFiles (Integration.addImport "MyNewtype") + outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyNewtype(MyNewtype))" + , "import Main (id)"]) + it "adds an explicit unqualified import (typeclass member function)" $ do + withSupportFiles (Integration.addImport "typeClassFun") + outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (typeClassFun)" + , "import Main (id)"]) + it "doesn't add a newtypes constructor if only the type is exported" $ do + withSupportFiles (Integration.addImport "OnlyTypeExported") + outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (OnlyTypeExported)" + , "import Main (id)"]) + it "doesn't add an import if the identifier is defined in the module itself" $ do + withSupportFiles (Integration.addImport "myId") + outputFileShouldBe (sourceFileSkeleton [ "import Main (id)"]) + it "responds with an error if it's undecidable whether we want a type or constructor" $ + withSupportFiles (\sourceFp outFp -> do + r <- Integration.addImport "SpecialCase" sourceFp outFp + shouldBe False (Integration.resultIsSuccess r) + shouldBe False =<< doesFileExist outFp) + it "responds with an error if the identifier cannot be found and doesn't \ + \write to the output file" $ + withSupportFiles (\sourceFp outFp -> do + r <- Integration.addImport "doesntExist" sourceFp outFp + shouldBe False (Integration.resultIsSuccess r) + shouldBe False =<< doesFileExist outFp) diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs new file mode 100644 index 0000000000..36cbe25dfe --- /dev/null +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.PureScript.Ide.ImportsSpec where + +import Data.Maybe (fromJust) +import Data.Text (Text) +import qualified Language.PureScript as P +import Language.PureScript.Ide.Imports +import Language.PureScript.Ide.Types +import Test.Hspec + +simpleFile :: [Text] +simpleFile = + [ "module Main where" + , "import Prelude" + , "" + , "myFunc x y = x + y" + ] + +splitSimpleFile :: (P.ModuleName, [Text], [Import], [Text]) +splitSimpleFile = fromRight $ sliceImportSection simpleFile + where + fromRight (Right r) = r + fromRight (Left _) = error "fromRight" + +withImports :: [Text] -> [Text] +withImports is = + take 2 simpleFile ++ is ++ drop 2 simpleFile + +testParseImport :: Text -> Import +testParseImport = fromJust . parseImport + +preludeImport, arrayImport, listImport, consoleImport, maybeImport :: Import +preludeImport = testParseImport "import Prelude" +arrayImport = testParseImport "import Data.Array (head, cons)" +listImport = testParseImport "import Data.List as List" +consoleImport = testParseImport "import Control.Monad.Eff.Console (log) as Console" +maybeImport = testParseImport "import Data.Maybe (Maybe(Just))" + +spec :: Spec +spec = do + describe "determining the importsection" $ do + let moduleSkeleton imports = + Right (P.moduleNameFromString "Main", take 1 simpleFile, imports, drop 2 simpleFile) + it "finds a simple import" $ + shouldBe (sliceImportSection simpleFile) (moduleSkeleton [preludeImport]) + + it "allows multiline import statements" $ + shouldBe + (sliceImportSection (withImports [ "import Data.Array (head," + , " cons)" + ])) + (moduleSkeleton [preludeImport, arrayImport]) + describe "pretty printing imports" $ do + it "pretty prints a simple import" $ + shouldBe (prettyPrintImport' preludeImport) "import Prelude" + it "pretty prints an explicit import" $ + shouldBe (prettyPrintImport' arrayImport) "import Data.Array (head, cons)" + it "pretty prints a qualified import" $ + shouldBe (prettyPrintImport' listImport) "import Data.List as List" + it "pretty prints a qualified explicit import" $ + shouldBe (prettyPrintImport' consoleImport) "import Control.Monad.Eff.Console (log) as Console" + it "pretty prints an import with a datatype (and PositionedRef's for the dtors)" $ + shouldBe (prettyPrintImport' maybeImport) "import Data.Maybe (Maybe(Just))" + + describe "import commands" $ do + let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i + addValueImport i mn is = + prettyPrintImportSection (addExplicitImport' (ValueDeclaration i P.TypeWildcard) mn is) + addDtorImport i t mn is = + prettyPrintImportSection (addExplicitImport' (DataConstructor i t P.TypeWildcard) mn is) + it "adds an implicit unqualified import" $ + shouldBe + (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map")) + [ "import Prelude" + , "import Data.Map" + ] + it "adds an explicit unqualified import" $ + shouldBe + (addValueImport "head" (P.moduleNameFromString "Data.Array") simpleFileImports) + [ "import Prelude" + , "import Data.Array (head)" + ] + it "doesn't add an import if the containing module is imported implicitly" $ + shouldBe + (addValueImport "const" (P.moduleNameFromString "Prelude") simpleFileImports) + ["import Prelude"] + let Right (_, _, explicitImports, _) = sliceImportSection (withImports ["import Data.Array (tail)"]) + it "adds an identifier to an explicit import list" $ + shouldBe + (addValueImport "head" (P.moduleNameFromString "Data.Array") explicitImports) + [ "import Prelude" + , "import Data.Array (head, tail)" + ] + it "adds an operator to an explicit import list" $ + shouldBe + (addValueImport "<~>" (P.moduleNameFromString "Data.Array") explicitImports) + [ "import Prelude" + , "import Data.Array ((<~>), tail)" + ] + it "adds the type for a given DataConstructor" $ + shouldBe + (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") simpleFileImports) + [ "import Prelude" + , "import Data.Maybe (Maybe(Just))" + ] + it "adds a dataconstructor to an existing type import" $ do + let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"]) + shouldBe + (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") typeImports) + [ "import Prelude" + , "import Data.Maybe (Maybe(Just))" + ] + it "doesn't add a dataconstructor to an existing type import with open dtors" $ do + let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe(..))"]) + shouldBe + (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") typeImports) + [ "import Prelude" + , "import Data.Maybe (Maybe(..))" + ] + it "doesn't add an identifier to an explicit import list if it's already imported" $ + shouldBe + (addValueImport "tail" (P.moduleNameFromString "Data.Array") explicitImports) + [ "import Prelude" + , "import Data.Array (tail)" + ] diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs new file mode 100644 index 0000000000..7a57662247 --- /dev/null +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -0,0 +1,238 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.Integration +-- Description : A psc-ide client for use in integration tests +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- A psc-ide client for use in integration tests +----------------------------------------------------------------------------- + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Language.PureScript.Ide.Integration + ( + -- managing the server process + startServer + , withServer + , stopServer + , quitServer + -- util + , compileTestProject + , deleteOutputFolder + , projectDirectory + , deleteFileIfExists + -- sending commands + , loadModuleWithDeps + , getFlexCompletions + , getType + , addImport + , addImplicitImport + -- checking results + , resultIsSuccess + , parseCompletions + , parseTextResult + ) where + +import Control.Concurrent (threadDelay) +import Control.Exception +import Control.Monad (join, when) +import Data.Aeson +import Data.Aeson.Types +import qualified Data.ByteString.Lazy.UTF8 as BSL +import Data.Either (isRight) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import qualified Data.Vector as V +import Language.PureScript.Ide.Util +import System.Directory +import System.Exit +import System.FilePath +import System.Process + +projectDirectory :: IO FilePath +projectDirectory = do + cd <- getCurrentDirectory + return $ cd "tests" "support" "pscide" + +startServer :: IO ProcessHandle +startServer = do + pdir <- projectDirectory + (_, _, _, procHandle) <- createProcess $ (shell "psc-ide-server") {cwd=Just pdir} + threadDelay 500000 -- give the server 500ms to start up + return procHandle + +stopServer :: ProcessHandle -> IO () +stopServer = terminateProcess + +withServer :: IO a -> IO a +withServer s = do + _ <- startServer + r <- s + quitServer + return r + +-- project management utils + +compileTestProject :: IO Bool +compileTestProject = do + pdir <- projectDirectory + (_, _, _, procHandle) <- createProcess $ + (shell $ "psc " ++ fileGlob) {cwd=Just pdir + ,std_out=CreatePipe + ,std_err=CreatePipe + } + isSuccess <$> waitForProcess procHandle + +deleteOutputFolder :: IO () +deleteOutputFolder = do + odir <- fmap ( "output") projectDirectory + whenM (doesDirectoryExist odir) (removeDirectoryRecursive odir) + +deleteFileIfExists :: FilePath -> IO () +deleteFileIfExists fp = whenM (doesFileExist fp) (removeFile fp) + +whenM :: Monad m => m Bool -> m () -> m () +whenM p f = do + x <- p + when x f + +isSuccess :: ExitCode -> Bool +isSuccess ExitSuccess = True +isSuccess (ExitFailure _) = False + +fileGlob :: String +fileGlob = unwords + [ "\"src/**/*.purs\"" + , "\"src/**/*.js\"" + , "\"bower_components/purescript-*/**/*.purs\"" + , "\"bower_components/purescript-*/**/*.js\"" + ] + +-- Integration Testing API + +sendCommand :: Value -> IO String +sendCommand v = readCreateProcess + ((shell "psc-ide-client") { std_out=CreatePipe + , std_err=CreatePipe + }) + (T.unpack (encodeT v)) + +quitServer :: IO () +quitServer = do + let quitCommand = object ["command" .= ("quit" :: String)] + _ <- try $ sendCommand quitCommand :: IO (Either SomeException String) + return () + +loadModuleWithDeps :: String -> IO String +loadModuleWithDeps m = sendCommand $ load [] [m] + +getFlexCompletions :: String -> IO [(String, String, String)] +getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q))) + +getType :: String -> IO [(String, String, String)] +getType q = parseCompletions <$> sendCommand (typeC q []) + +addImport :: String -> FilePath -> FilePath -> IO String +addImport identifier fp outfp = sendCommand (addImportC identifier fp outfp) + +addImplicitImport :: String -> FilePath -> FilePath -> IO String +addImplicitImport mn fp outfp = sendCommand (addImplicitImportC mn fp outfp) + +-- Command Encoding + +commandWrapper :: String -> Value -> Value +commandWrapper c p = object ["command" .= c, "params" .= p] + +load :: [String] -> [String] -> Value +load ms ds = commandWrapper "load" (object ["modules" .= ms, "dependencies" .= ds]) + +typeC :: String -> [Value] -> Value +typeC q filters = commandWrapper "type" (object ["search" .= q, "filters" .= filters]) + +addImportC :: String -> FilePath -> FilePath -> Value +addImportC identifier = addImportW $ + object [ "importCommand" .= ("addImport" :: String) + , "identifier" .= identifier + ] + +addImplicitImportC :: String -> FilePath -> FilePath -> Value +addImplicitImportC mn = addImportW $ + object [ "importCommand" .= ("addImplicitImport" :: String) + , "module" .= mn + ] + +addImportW :: Value -> FilePath -> FilePath -> Value +addImportW importCommand fp outfp = + commandWrapper "import" (object [ "file" .= fp + , "outfile" .= outfp + , "importCommand" .= importCommand + ]) + + +completion :: [Value] -> Maybe Value -> Value +completion filters matcher = + let + matcher' = case matcher of + Nothing -> [] + Just m -> ["matcher" .= m] + in + commandWrapper "complete" (object $ "filters" .= filters : matcher') + +flexMatcher :: String -> Value +flexMatcher q = object [ "matcher" .= ("flex" :: String) + , "params" .= object ["search" .= q] + ] + +-- Result parsing + +unwrapResult :: Value -> Parser (Either String Value) +unwrapResult = withObject "result" $ \o -> do + (rt :: String) <- o .: "resultType" + case rt of + "error" -> do + res <- o .: "result" + pure (Left res) + "success" -> do + res <- o .: "result" + pure (Right res) + _ -> fail "lol" + +withResult :: (Value -> Parser a) -> Value -> Parser (Either String a) +withResult p v = do + r <- unwrapResult v + case r of + Left err -> pure (Left err) + Right res -> Right <$> p res + +completionParser :: Value -> Parser [(String, String, String)] +completionParser = withArray "res" $ \cs -> + mapM (withObject "completion" $ \o -> do + ident <- o .: "identifier" + module' <- o .: "module" + ty <- o .: "type" + pure (module', ident, ty)) (V.toList cs) + +valueFromString :: String -> Value +valueFromString = fromJust . decode . BSL.fromString + +resultIsSuccess :: String -> Bool +resultIsSuccess = isRight . join . parseEither unwrapResult . valueFromString + +parseCompletions :: String -> [(String, String, String)] +parseCompletions s = fromJust $ do + cs <- parseMaybe (withResult completionParser) (valueFromString s) + case cs of + Left _ -> error "Failed to parse completions" + Right cs' -> pure cs' + +parseTextResult :: String -> String +parseTextResult s = fromJust $ do + r <- parseMaybe (withResult (withText "tr" pure)) (valueFromString s) + case r of + Left _ -> error "Failed to parse textResult" + Right r' -> pure (T.unpack r') diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs index 7e12981038..13cef33b2a 100644 --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -2,24 +2,40 @@ module Language.PureScript.Ide.MatcherSpec where -import Data.Text (Text) +import Data.Text (Text) +import Language.PureScript.Ide.Integration import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types +import qualified Language.PureScript as P import Test.Hspec -completions :: [Completion] +value :: Text -> ExternDecl +value s = ValueDeclaration s P.TypeWildcard + +completions :: [Match] completions = [ - Completion ("", "firstResult", ""), - Completion ("", "secondResult", ""), - Completion ("", "fiult", "") + Match "" $ value "firstResult", + Match "" $ value "secondResult", + Match "" $ value "fiult" ] -mkResult :: [Int] -> [Completion] +mkResult :: [Int] -> [Match] mkResult = map (completions !!) -runFlex :: Text -> [Completion] +runFlex :: Text -> [Match] runFlex s = runMatcher (flexMatcher s) completions +setup :: IO () +setup = do + deleteOutputFolder + _ <- compileTestProject + _ <- startServer + _ <- loadModuleWithDeps "Main" + return () + +teardown :: IO () +teardown = quitServer + spec :: Spec spec = do describe "Flex Matcher" $ do @@ -29,3 +45,12 @@ spec = do runFlex "firstResult" `shouldBe` mkResult [0] it "scores short matches higher and sorts accordingly" $ runFlex "filt" `shouldBe` mkResult [2, 0] + + beforeAll_ setup $ afterAll_ teardown $ + describe "Integration Tests: Flex Matcher" $ do + it "doesn't match on an empty string" $ do + cs <- getFlexCompletions "" + cs `shouldBe` [] + it "matches on equality" $ do + cs <- getFlexCompletions "const" + cs `shouldBe` [("Main", "const", "forall a b. a -> b -> a")] diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index d9a98ff8a9..42d28f0e93 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -6,14 +6,15 @@ import Data.List (sort) import qualified Data.Map as Map import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.Types +import qualified Language.PureScript as P import Test.Hspec decl1 :: ExternDecl -decl1 = FunctionDecl "filter" "asdasd" +decl1 = ValueDeclaration "filter" P.TypeWildcard decl2 :: ExternDecl -decl2 = DataDecl "Tree" "* -> *" +decl2 = ValueDeclaration "map" P.TypeWildcard decl3 :: ExternDecl -decl3 = DataDecl "TreeAsd" "* -> *" +decl3 = ValueDeclaration "catMaybe" P.TypeWildcard dep1 :: ExternDecl dep1 = Dependency "Test.Foo" [] (Just "T") dep2 :: ExternDecl @@ -44,7 +45,7 @@ shouldBeEqualSorted :: Module -> Module -> Expectation shouldBeEqualSorted (n1, d1) (n2, d2) = (n1, sort d1) `shouldBe` (n2, sort d2) spec :: Spec -spec = do +spec = describe "Reexports" $ do it "finds all reexports" $ getReexports module1 `shouldBe` [Export "Module2", Export "Module3"] diff --git a/tests/Language/PureScript/IdeSpec.hs b/tests/Language/PureScript/IdeSpec.hs index 5f89e82e07..83533f16d5 100644 --- a/tests/Language/PureScript/IdeSpec.hs +++ b/tests/Language/PureScript/IdeSpec.hs @@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} + module Language.PureScript.IdeSpec where import Control.Concurrent.STM import Control.Monad.Reader import Data.List -import qualified Data.Map as Map +import qualified Data.Map as Map import Language.PureScript.Ide import Language.PureScript.Ide.Types import Test.Hspec testState :: PscIdeState -testState = PscIdeState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])]) (Map.empty) +testState = PscIdeState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])]) Map.empty defaultConfig :: Configuration defaultConfig = @@ -22,13 +22,13 @@ defaultConfig = } spec :: SpecWith () -spec = do - describe "list" $ do +spec = + describe "list" $ describe "loadedModules" $ do it "returns an empty list when no modules are loaded" $ do - st <- newTVarIO emptyPscIdeState - result <- runReaderT printModules (PscIdeEnvironment st defaultConfig) - result `shouldBe` ModuleList [] + st <- newTVarIO emptyPscIdeState + result <- runReaderT printModules (PscIdeEnvironment st defaultConfig) + result `shouldBe` ModuleList [] it "returns the list of loaded modules" $ do st <- newTVarIO testState ModuleList result <- runReaderT printModules (PscIdeEnvironment st defaultConfig) diff --git a/tests/support/pscide/.gitignore b/tests/support/pscide/.gitignore new file mode 100644 index 0000000000..85360eb7ff --- /dev/null +++ b/tests/support/pscide/.gitignore @@ -0,0 +1,7 @@ +/bower_components/ +/node_modules/ +/.pulp-cache/ +/output/ +/.psci* +/src/.webpack.js +/src/*.tmp diff --git a/tests/support/pscide/src/ImportsSpec.purs b/tests/support/pscide/src/ImportsSpec.purs new file mode 100644 index 0000000000..04a7227f43 --- /dev/null +++ b/tests/support/pscide/src/ImportsSpec.purs @@ -0,0 +1,5 @@ +module ImportsSpec where + +import Main (id) + +myId = id diff --git a/tests/support/pscide/src/ImportsSpec1.purs b/tests/support/pscide/src/ImportsSpec1.purs new file mode 100644 index 0000000000..098a55d2ac --- /dev/null +++ b/tests/support/pscide/src/ImportsSpec1.purs @@ -0,0 +1,32 @@ +module ImportsSpec1 + ( exportedFunction + , MyType + , MyParamType + , MyNewtype(..) + , MyMaybe(..) + , SpecialCase + , X(..) + , class ATypeClass + , typeClassFun + , OnlyTypeExported + ) + where + +exportedFunction ∷ ∀ a. a → a +exportedFunction x = x + +type MyType = String + +type MyParamType a = Array a + +newtype MyNewtype = MyNewtype String + +data MyMaybe a = MyJust a | MyNothing + +data SpecialCase +data X = SpecialCase + +newtype OnlyTypeExported = OnlyTypeExported String + +class ATypeClass a where + typeClassFun ∷ a -> a diff --git a/tests/support/pscide/src/Main.purs b/tests/support/pscide/src/Main.purs new file mode 100644 index 0000000000..ca679385b0 --- /dev/null +++ b/tests/support/pscide/src/Main.purs @@ -0,0 +1,7 @@ +module Main where + +id :: forall a. a -> a +id x = x + +const :: forall a b. a -> b -> a +const x _ = x From 5fe25aabc2107584d1d514530b263c18a1058494 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 6 Apr 2016 04:07:28 +0100 Subject: [PATCH 0354/1580] Check that FFI imports match with implementations * Refactor foreign module parsing Extract functions for matching certain types of nodes in a JS AST, in preparation for checking that FFI declarations match with foreign imports. * Add getExportedIdentifiers Also update comments * Check for unused or missing FFI declarations --- src/Language/PureScript/Bundle.hs | 147 +++++++++++++++++++-------- src/Language/PureScript/Errors.hs | 25 ++++- src/Language/PureScript/Make.hs | 61 ++++++++++- src/Language/PureScript/Parser/JS.hs | 2 +- 4 files changed, 181 insertions(+), 54 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 0e354272ac..13f6605c97 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -27,6 +27,7 @@ module Language.PureScript.Bundle ( , ModuleType(..) , ErrorMessage(..) , printErrorMessage + , getExportedIdentifiers ) where import Prelude () @@ -229,53 +230,20 @@ toModule requirePath mids mid top err = throwError . ErrorInModule mid toModuleElement :: JSStatement -> m ModuleElement - -- var ModuleName = require("file"); toModuleElement stmt - | JSVariable _ jsInit _ <- stmt - , [JSVarInitExpression var varInit] <- commaList jsInit - , JSIdentifier _ importName <- var - , JSVarInit _ jsInitEx <- varInit - , JSMemberExpression req _ argsE _ <- jsInitEx - , JSIdentifier _ "require" <- req - , [ Just importPath ] <- map fromStringLiteral (commaList argsE) - , importPath' <- checkImportPath requirePath importPath mid mids - = pure (Require stmt importName importPath') - -- var foo = expr; - toModuleElement stmt - | JSVariable _ jsInit _ <- stmt - , [JSVarInitExpression var varInit] <- commaList jsInit - , JSIdentifier _ name <- var - , JSVarInit _ decl <- varInit - = pure (Member stmt False name decl []) - -- exports.foo = expr; exports["foo"] = expr; + | Just (importName, importPath) <- matchRequire requirePath mids mid stmt + = pure (Require stmt importName importPath) toModuleElement stmt - | JSAssignStatement e (JSAssign _) decl _ <- stmt - , Just name <- accessor e - = pure (Member stmt True name decl []) - where - accessor :: JSExpression -> Maybe String - accessor (JSMemberDot exports _ nm) - | JSIdentifier _ "exports" <- exports - , JSIdentifier _ name <- nm - = Just name - accessor (JSMemberSquare exports _ nm _) - | JSIdentifier _ "exports" <- exports - , Just name <- fromStringLiteral nm - = Just name - accessor _ = Nothing - -- module.exports = { ... } + | Just (exported, name, decl) <- matchMember stmt + = pure (Member stmt exported name decl []) toModuleElement stmt - | JSAssignStatement e (JSAssign _) decl _ <- stmt - , JSMemberDot module' _ exports <- e - , JSIdentifier _ "module" <- module' - , JSIdentifier _ "exports" <- exports - , JSObjectLiteral _ props _ <- decl + | Just props <- matchExportsAssignment stmt = (ExportsList <$> traverse toExport (trailingCommaList props)) where toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key]) toExport (JSPropertyNameandValue name _ [val]) = (,,val,[]) <$> exportType val - <*> extractLabel name + <*> extractLabel' name toExport _ = err UnsupportedExport exportType :: JSExpression -> m ExportType @@ -287,14 +255,105 @@ toModule requirePath mids mid top = pure ForeignReexport exportType (JSIdentifier _ s) = pure (RegularExport s) exportType _ = err UnsupportedExport --- - extractLabel :: JSPropertyName -> m String - extractLabel (JSPropertyString _ nm) = pure (trimStringQuotes nm) - extractLabel (JSPropertyIdent _ nm) = pure nm - extractLabel _ = err UnsupportedExport + + extractLabel' = maybe (err UnsupportedExport) pure . extractLabel toModuleElement other = pure (Other other) +-- Get a list of all the exported identifiers from a foreign module. +-- +-- TODO: what if we assign to exports.foo and then later assign to +-- module.exports (presumably overwriting exports.foo)? +getExportedIdentifiers :: (MonadError ErrorMessage m) + => String + -> JSAST + -> m [String] +getExportedIdentifiers mname top + | JSAstProgram stmts _ <- top = concat <$> traverse go stmts + | otherwise = err InvalidTopLevel + where + err = throwError . ErrorInModule (ModuleIdentifier mname Foreign) + + go stmt + | Just props <- matchExportsAssignment stmt + = traverse toIdent (trailingCommaList props) + | Just (True, name, _) <- matchMember stmt + = pure [name] + | otherwise + = pure [] + + toIdent (JSPropertyNameandValue name _ [_]) = + extractLabel' name + toIdent _ = + err UnsupportedExport + + extractLabel' = maybe (err UnsupportedExport) pure . extractLabel + +-- Matches JS statements like this: +-- var ModuleName = require("file"); +matchRequire :: Maybe FilePath + -> S.Set String + -> ModuleIdentifier + -> JSStatement + -> Maybe (String, Either String ModuleIdentifier) +matchRequire requirePath mids mid stmt + | JSVariable _ jsInit _ <- stmt + , [JSVarInitExpression var varInit] <- commaList jsInit + , JSIdentifier _ importName <- var + , JSVarInit _ jsInitEx <- varInit + , JSMemberExpression req _ argsE _ <- jsInitEx + , JSIdentifier _ "require" <- req + , [ Just importPath ] <- map fromStringLiteral (commaList argsE) + , importPath' <- checkImportPath requirePath importPath mid mids + = Just (importName, importPath') + | otherwise + = Nothing + +-- Matches JS member declarations. +matchMember :: JSStatement -> Maybe (Bool, String, JSExpression) +matchMember stmt + -- var foo = expr; + | JSVariable _ jsInit _ <- stmt + , [JSVarInitExpression var varInit] <- commaList jsInit + , JSIdentifier _ name <- var + , JSVarInit _ decl <- varInit + = Just (False, name, decl) + -- exports.foo = expr; exports["foo"] = expr; + | JSAssignStatement e (JSAssign _) decl _ <- stmt + , Just name <- accessor e + = Just (True, name, decl) + | otherwise + = Nothing + where + accessor :: JSExpression -> Maybe String + accessor (JSMemberDot exports _ nm) + | JSIdentifier _ "exports" <- exports + , JSIdentifier _ name <- nm + = Just name + accessor (JSMemberSquare exports _ nm _) + | JSIdentifier _ "exports" <- exports + , Just name <- fromStringLiteral nm + = Just name + accessor _ = Nothing + +-- Matches assignments to module.exports, like this: +-- module.exports = { ... } +matchExportsAssignment :: JSStatement -> Maybe JSObjectPropertyList +matchExportsAssignment stmt + | JSAssignStatement e (JSAssign _) decl _ <- stmt + , JSMemberDot module' _ exports <- e + , JSIdentifier _ "module" <- module' + , JSIdentifier _ "exports" <- exports + , JSObjectLiteral _ props _ <- decl + = Just props + | otherwise + = Nothing + +extractLabel :: JSPropertyName -> Maybe String +extractLabel (JSPropertyString _ nm) = Just (trimStringQuotes nm) +extractLabel (JSPropertyIdent _ nm) = Just nm +extractLabel _ = Nothing + -- | Eliminate unused code based on the specified entry point set. compile :: [Module] -> [ModuleIdentifier] -> [Module] compile modules [] = modules diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 1fad2dd1d2..3b97919753 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -12,6 +12,7 @@ import Data.Char (isSpace) import Data.Either (lefts, rights) import Data.List (intercalate, transpose, nub, nubBy, sortBy) import Data.Foldable (fold) +import Data.Maybe (maybeToList) import qualified Data.Map as M @@ -28,6 +29,7 @@ import Language.PureScript.Pretty.Common (before) import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds +import qualified Language.PureScript.Bundle as Bundle import qualified Text.PrettyPrint.Boxes as Box @@ -37,11 +39,13 @@ import Text.Parsec.Error (Message(..)) -- | A type of error messages data SimpleErrorMessage - = ErrorParsingFFIModule FilePath + = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) | ErrorParsingModule P.ParseError | MissingFFIModule ModuleName | MultipleFFIModules ModuleName [FilePath] | UnnecessaryFFIModule ModuleName FilePath + | MissingFFIImplementations ModuleName [Ident] + | UnusedFFIImplementations ModuleName [Ident] | CannotGetFileInfo FilePath | CannotReadFile FilePath | CannotWriteFile FilePath @@ -224,6 +228,8 @@ errorCode em = case unwrapErrorMessage em of MissingFFIModule{} -> "MissingFFIModule" MultipleFFIModules{} -> "MultipleFFIModules" UnnecessaryFFIModule{} -> "UnnecessaryFFIModule" + MissingFFIImplementations{} -> "MissingFFIImplementations" + UnusedFFIImplementations{} -> "UnusedFFIImplementations" CannotGetFileInfo{} -> "CannotGetFileInfo" CannotReadFile{} -> "CannotReadFile" CannotWriteFile{} -> "CannotWriteFile" @@ -525,10 +531,11 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap paras [ line "Unable to write file: " , indent . line $ path ] - renderSimpleErrorMessage (ErrorParsingFFIModule path) = - paras [ line "Unable to parse foreign module:" - , indent . line $ path - ] + renderSimpleErrorMessage (ErrorParsingFFIModule path extra) = + paras $ [ line "Unable to parse foreign module:" + , indent . line $ path + ] ++ + (map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra))) renderSimpleErrorMessage (ErrorParsingModule err) = paras [ line "Unable to parse module: " , prettyPrintParseError err @@ -540,6 +547,14 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , indent . line $ path , line $ "Module " ++ runModuleName mn ++ " does not contain any foreign import declarations, so a foreign module is not necessary." ] + renderSimpleErrorMessage (MissingFFIImplementations mn idents) = + paras [ line $ "The following values are not defined in the foreign module for module " ++ runModuleName mn ++ ": " + , indent . paras $ map (line . runIdent) idents + ] + renderSimpleErrorMessage (UnusedFFIImplementations mn idents) = + paras [ line $ "The following definitions in the foreign module for module " ++ runModuleName mn ++ " are unused: " + , indent . paras $ map (line . runIdent) idents + ] renderSimpleErrorMessage (MultipleFFIModules mn paths) = paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": " , indent . paras $ map line paths diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index ddc0d109ac..024bd67f5c 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -25,6 +25,7 @@ module Language.PureScript.Make import Prelude () import Prelude.Compat +import Control.Applicative ((<|>)) import Control.Monad hiding (sequence) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -52,6 +53,8 @@ import qualified Data.ByteString.UTF8 as BU8 import qualified Data.Set as S import qualified Data.Map as M +import qualified Text.Parsec as Parsec + import SourceMap.Types import SourceMap @@ -61,6 +64,8 @@ import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise import System.IO.Error (tryIOError) import System.IO.UTF8 (readUTF8File, writeUTF8File) +import qualified Language.JavaScript.Parser as JS + import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Externs @@ -76,6 +81,8 @@ import Language.PureScript.Renamer import Language.PureScript.Sugar import Language.PureScript.TypeChecker import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Bundle as Bundle +import qualified Language.PureScript.Parser as PSParser import qualified Language.PureScript.CodeGen.JS as J import qualified Language.PureScript.CoreFn as CF @@ -331,7 +338,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = | not $ requiresForeign m -> do tell $ errorMessage $ UnnecessaryFFIModule mn path return Nothing - | otherwise -> return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"] + | otherwise -> do + checkForeignDecls m path + return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"] Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn | otherwise -> return Nothing rawJs <- J.moduleToJs m foreignInclude @@ -384,9 +393,6 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = exists <- doesFileExist path traverse (const $ getModificationTime path) $ guard exists - readTextFile :: FilePath -> Make String - readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path - writeTextFile :: FilePath -> String -> Make () writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do mkdirp path @@ -397,3 +403,50 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = progress :: ProgressMessage -> Make () progress = liftIO . putStrLn . renderProgressMessage + +readTextFile :: FilePath -> Make String +readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path + +-- | +-- Check that the declarations in a given PureScript module match with those +-- in its corresponding foreign module. +-- +checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make () +checkForeignDecls m path = do + jsStr <- lift $ readTextFile path + js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path + + foreignIdentsStrs <- either errorParsingModule pure $ getExps js + let foreignIdents = + either + (internalError . ("checkForeignDecls: unexpected idents: " ++) . show) + S.fromList + (traverse parseIdent foreignIdentsStrs) + let importedIdents = S.fromList $ map fst (CF.moduleForeign m) + + let unusedFFI = foreignIdents S.\\ importedIdents + unless (null unusedFFI) $ + tell . errorMessage . UnusedFFIImplementations mname $ + S.toList unusedFFI + + let missingFFI = importedIdents S.\\ foreignIdents + unless (null missingFFI) $ + throwError . errorMessage . MissingFFIImplementations mname $ + S.toList missingFFI + + where + mname = CF.moduleName m + + errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a + errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just + + getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String] + getExps = Bundle.getExportedIdentifiers (runModuleName mname) + + -- TODO: Handling for parenthesised operators should be removed after 0.9. + parseIdent :: String -> Either String Ident + parseIdent str = try str <|> try ("(" ++ str ++ ")") + where + try s = either (Left . show) Right $ do + ts <- PSParser.lex "" s + PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs index 9defab4d44..7043991705 100644 --- a/src/Language/PureScript/Parser/JS.hs +++ b/src/Language/PureScript/Parser/JS.hs @@ -43,7 +43,7 @@ parseForeignModulesFromFiles files = do foreigns <- parU files $ \(path, file) -> case findModuleName (lines file) of Just name -> return (name, path) - Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path) + Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path Nothing) let grouped = groupBy ((==) `on` fst) $ sortBy (compare `on` fst) foreigns forM_ grouped $ \grp -> when (length grp > 1) $ do From ac6017e71fce979640fefd6ec0297d245efe6ba6 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 5 Apr 2016 20:08:02 -0700 Subject: [PATCH 0355/1580] 0.8.4.0 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 6655592ced..72446215bb 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.8.3.0 +version: 0.8.4.0 cabal-version: >=1.8 build-type: Simple license: MIT From c513026f9e6eca422828a4f5af74a768a02c142f Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Wed, 6 Apr 2016 23:45:47 +0100 Subject: [PATCH 0356/1580] Add a Windows version for the stack bundle script --- bundle/winbuild-stack.sh | 46 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) create mode 100644 bundle/winbuild-stack.sh diff --git a/bundle/winbuild-stack.sh b/bundle/winbuild-stack.sh new file mode 100644 index 0000000000..48e79c986e --- /dev/null +++ b/bundle/winbuild-stack.sh @@ -0,0 +1,46 @@ +## This Windows-specific version of build.sh can be run in an msys environment +## to create a .tar.gz bundle for Windows users. +## msysgit contains all of the pieces needed to run this script. + +set -e + +SCRIPTPATH=$( cd "$(dirname "$0")" ; pwd -P ) + +pushd ${SCRIPTPATH} > /dev/null + +# Make the staging directory +mkdir -p build/purescript/ + +# Strip the binaries +strip $APPDATA/local/bin/psc.exe +strip $APPDATA/local/bin/psci.exe +strip $APPDATA/local/bin/psc-docs.exe +strip $APPDATA/local/bin/psc-publish.exe +strip $APPDATA/local/bin/psc-bundle.exe +strip $APPDATA/local/bin/psc-ide-server.exe +strip $APPDATA/local/bin/psc-ide-client.exe + +# Copy files to staging directory +cp $APPDATA/local/bin/psc.exe build/purescript/ +cp $APPDATA/local/bin/psci.exe build/purescript/ +cp $APPDATA/local/bin/psc-docs.exe build/purescript/ +cp $APPDATA/local/bin/psc-publish.exe build/purescript/ +cp $APPDATA/local/bin/psc-bundle.exe build/purescript/ +cp $APPDATA/local/bin/psc-ide-server.exe build/purescript/ +cp $APPDATA/local/bin/psc-ide-client.exe build/purescript/ +cp README build/purescript/ +cp ../LICENSE build/purescript/ +cp ../INSTALL.md build/purescript/ + +# Make the binary bundle +pushd build > /dev/null +tar -zcvf ../win64.tar.gz purescript +popd > /dev/null + +# Calculate the MD5 hash +md5sum win64.tar.gz > win64.md5 + +# Remove the staging directory +rm -rf build/ + +popd > /dev/null From f55bfe72ecdb31942f734fa2582f3129d9cd1b79 Mon Sep 17 00:00:00 2001 From: Sergei Trofimovich Date: Thu, 7 Apr 2016 21:15:19 +0100 Subject: [PATCH 0357/1580] Language/PureScript/Ide/Types.hs: fix haddock markup MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Failed as: src/Language/PureScript/Ide/Types.hs:63:7: parse error on input ‘(’ Signed-off-by: Sergei Trofimovich --- src/Language/PureScript/Ide/Types.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index d1349e1e8c..54e2fc5d2d 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -59,9 +59,9 @@ data ExternDecl [DeclIdent] -- The exported identifiers -- | A data/newtype declaration | DataConstructor - DeclIdent -- ^ The type name + DeclIdent -- The type name (P.ProperName 'P.TypeName) - P.Type -- ^ The "type" + P.Type -- The "type" -- | An exported module | TypeClassDeclaration (P.ProperName 'P.ClassName) | Export ModuleIdent -- The exported Modules name From 4a1a779f28e3ee2ffc5f6bf42a10d014a57ce204 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 3 Apr 2016 14:05:49 +0100 Subject: [PATCH 0358/1580] Windows CI * Add appveyor.yml for windows CI, with automatic release binary bundle publishing * Rework bundle/build-stack script to work on all OSes * Use SHA1 instead of MD5 for the Windows checksum. * Refactor the build-stack script a little * Remove all the other bundle build scripts * Include dependencies in binary bundles (resolves #1952) I haven't managed to get `strip` to work on AppVeyor, but this script has produced an identically sized bundle to the 0.8.4 one (21.3MB) so maybe that's not worth worrying about. --- appveyor.yml | 59 ++++++++++++++++++++++++++++++++++ bundle/build-stack.sh | 69 ++++++++++++++++++++++++---------------- bundle/build.sh | 50 ----------------------------- bundle/winbuild-stack.sh | 46 --------------------------- bundle/winbuild.sh | 47 --------------------------- 5 files changed, 100 insertions(+), 171 deletions(-) create mode 100644 appveyor.yml delete mode 100755 bundle/build.sh delete mode 100644 bundle/winbuild-stack.sh delete mode 100644 bundle/winbuild.sh diff --git a/appveyor.yml b/appveyor.yml new file mode 100644 index 0000000000..18439242be --- /dev/null +++ b/appveyor.yml @@ -0,0 +1,59 @@ +platform: x64 +version: '{build}' +environment: + GITHUB_TOKEN: + secure: PUrCLwiP1G73fP5hr5HVpwBQU6n6t0A7CtfQxrFRAlTC+fnkntcA+9TR58OTEy7y + # Keep the path as short as possible, just in case. + STACK_ROOT: c:\s + # Appveyor does not seem to be able to cope with the symbolic link + # stack.yaml, so this is a workaround. + STACK_YAML: stack-lts-5.yaml + RELEASE_USER: purescript + RELEASE_REPO: purescript +cache: +- c:\s +install: +- git submodule update --init +- ps: Install-Product node 5 +- npm install -g bower + +- ps: | + New-Item -ItemType Directory -Force -Path C:\tools + $env:Path += ";C:\tools" + (New-Object Net.WebClient).DownloadFile('https://www.stackage.org/stack/windows-x86_64', 'c:\tools\stack.zip') + pushd c:\tools + 7z x c:\tools\stack.zip stack.exe + popd + +- stack --no-terminal --verbosity=error setup 1>stack-setup.log 2>&1 || type stack-setup.log + +build_script: +# Override the default build script. +- echo "" +test_script: +- stack -j1 --no-terminal test --pedantic +on_success: +# this seems to be necessary; if omitted, the bash script fails to find the +# tool 'strip'. +- copy C:\MinGW\bin\strip.exe C:\tools\strip.exe +- ps: | + function UploadFile + { + github-release upload --user $env:RELEASE_USER --repo $env:RELEASE_REPO --tag $env:APPVEYOR_REPO_TAG_NAME --file $args[0] --name $args[0] + } + + if ($env:APPVEYOR_REPO_TAG_NAME) + { + bash ./bundle/build-stack.sh win64 + + (New-Object Net.WebClient).DownloadFile('https://github.com/aktau/github-release/releases/download/v0.6.2/windows-amd64-github-release.zip', 'c:\tools\github-release.zip') + pushd c:\tools + 7z x github-release.zip bin/windows/amd64/github-release.exe + Copy-Item bin/windows/amd64/github-release.exe github-release.exe + popd + + pushd bundle + UploadFile win64.tar.gz + UploadFile win64.sha + popd + } diff --git a/bundle/build-stack.sh b/bundle/build-stack.sh index b6433ef4aa..ee13b9542f 100755 --- a/bundle/build-stack.sh +++ b/bundle/build-stack.sh @@ -1,7 +1,8 @@ +## This script can be run on any supported OS to create a binary .tar.gz +## bundle. +## For Windows, msysgit contains all of the pieces needed to run this script. set -e -SCRIPTPATH=$( cd "$(dirname "$0")" ; pwd -P ) - OS=$1 if [ -z $OS ] @@ -10,39 +11,51 @@ then exit 1 fi -pushd ${SCRIPTPATH} > /dev/null +pushd $(stack path --project-root) + +LOCAL_INSTALL_ROOT=$(stack path --local-install-root) + +if [ "$OS" = "win64" ] +then + BIN_EXT=".exe" +else + BIN_EXT="" +fi # Make the staging directory -mkdir -p build/purescript/ - -# Strip the binaries -strip ~/.local/bin/psc -strip ~/.local/bin/psci -strip ~/.local/bin/psc-docs -strip ~/.local/bin/psc-publish -strip ~/.local/bin/psc-bundle -strip ~/.local/bin/psc-ide-server -strip ~/.local/bin/psc-ide-client - -# Copy files to staging directory -cp ~/.local/bin/psc build/purescript/ -cp ~/.local/bin/psci build/purescript/ -cp ~/.local/bin/psc-docs build/purescript/ -cp ~/.local/bin/psc-publish build/purescript/ -cp ~/.local/bin/psc-bundle build/purescript/ -cp ~/.local/bin/psc-ide-server build/purescript/ -cp ~/.local/bin/psc-ide-client build/purescript/ -cp README build/purescript/ -cp ../LICENSE build/purescript/ -cp ../INSTALL.md build/purescript/ +mkdir -p bundle/build/purescript + +# Strip the binaries, and copy them to the staging directory +for BIN in psc psci psc-docs psc-publish psc-bundle psc-ide-server psc-ide-client +do + FULL_BIN="$LOCAL_INSTALL_ROOT/bin/${BIN}${BIN_EXT}" + strip "$FULL_BIN" || true # not the end of the world if this fails, and + # AppVeyor can't seem to handle it for some reason + cp "$FULL_BIN" bundle/build/purescript +done + +# Copy extra files to the staging directory +cp bundle/README bundle/build/purescript/ +cp LICENSE bundle/build/purescript/ +cp INSTALL.md bundle/build/purescript/ + +stack list-dependencies >bundle/build/purescript/dependencies.txt # Make the binary bundle -pushd build > /dev/null -tar -zcvf ../$OS.tar.gz purescript +pushd bundle/build > /dev/null +tar -zcvf ../${OS}.tar.gz purescript popd > /dev/null # Calculate the SHA hash -shasum $OS.tar.gz > $OS.sha +if [ "$OS" = "win64" ] +then + # msys/mingw does not include shasum. :( + SHASUM="openssl dgst -sha1" +else + SHASUM="shasum" +fi + +$SHASUM bundle/${OS}.tar.gz > bundle/${OS}.sha # Remove the staging directory rm -rf build/ diff --git a/bundle/build.sh b/bundle/build.sh deleted file mode 100755 index 33ef75cac0..0000000000 --- a/bundle/build.sh +++ /dev/null @@ -1,50 +0,0 @@ -set -e - -SCRIPTPATH=$( cd "$(dirname "$0")" ; pwd -P ) - -OS=$1 - -if [ -z $OS ] -then - echo "Usage: build.sh osname" - exit 1 -fi - -pushd ${SCRIPTPATH} > /dev/null - -# Make the staging directory -mkdir -p build/purescript/ - -# Strip the binaries -strip ../dist/build/psc/psc -strip ../dist/build/psci/psci -strip ../dist/build/psc-docs/psc-docs -strip ../dist/build/psc-publish/psc-publish -strip ../dist/build/psc-bundle/psc-bundle -strip ../dist/build/psc-ide-server/psc-ide-server -strip ../dist/build/psc-ide-client/psc-ide-client - -# Copy files to staging directory -cp ../dist/build/psc/psc build/purescript/ -cp ../dist/build/psci/psci build/purescript/ -cp ../dist/build/psc-docs/psc-docs build/purescript/ -cp ../dist/build/psc-publish/psc-publish build/purescript/ -cp ../dist/build/psc-bundle/psc-bundle build/purescript/ -cp ../dist/build/psc-ide-server/psc-ide-server build/purescript/ -cp ../dist/build/psc-ide-client/psc-ide-client build/purescript/ -cp README build/purescript/ -cp ../LICENSE build/purescript/ -cp ../INSTALL.md build/purescript/ - -# Make the binary bundle -pushd build > /dev/null -tar -zcvf ../$OS.tar.gz purescript -popd > /dev/null - -# Calculate the SHA hash -shasum $OS.tar.gz > $OS.sha - -# Remove the staging directory -rm -rf build/ - -popd > /dev/null diff --git a/bundle/winbuild-stack.sh b/bundle/winbuild-stack.sh deleted file mode 100644 index 48e79c986e..0000000000 --- a/bundle/winbuild-stack.sh +++ /dev/null @@ -1,46 +0,0 @@ -## This Windows-specific version of build.sh can be run in an msys environment -## to create a .tar.gz bundle for Windows users. -## msysgit contains all of the pieces needed to run this script. - -set -e - -SCRIPTPATH=$( cd "$(dirname "$0")" ; pwd -P ) - -pushd ${SCRIPTPATH} > /dev/null - -# Make the staging directory -mkdir -p build/purescript/ - -# Strip the binaries -strip $APPDATA/local/bin/psc.exe -strip $APPDATA/local/bin/psci.exe -strip $APPDATA/local/bin/psc-docs.exe -strip $APPDATA/local/bin/psc-publish.exe -strip $APPDATA/local/bin/psc-bundle.exe -strip $APPDATA/local/bin/psc-ide-server.exe -strip $APPDATA/local/bin/psc-ide-client.exe - -# Copy files to staging directory -cp $APPDATA/local/bin/psc.exe build/purescript/ -cp $APPDATA/local/bin/psci.exe build/purescript/ -cp $APPDATA/local/bin/psc-docs.exe build/purescript/ -cp $APPDATA/local/bin/psc-publish.exe build/purescript/ -cp $APPDATA/local/bin/psc-bundle.exe build/purescript/ -cp $APPDATA/local/bin/psc-ide-server.exe build/purescript/ -cp $APPDATA/local/bin/psc-ide-client.exe build/purescript/ -cp README build/purescript/ -cp ../LICENSE build/purescript/ -cp ../INSTALL.md build/purescript/ - -# Make the binary bundle -pushd build > /dev/null -tar -zcvf ../win64.tar.gz purescript -popd > /dev/null - -# Calculate the MD5 hash -md5sum win64.tar.gz > win64.md5 - -# Remove the staging directory -rm -rf build/ - -popd > /dev/null diff --git a/bundle/winbuild.sh b/bundle/winbuild.sh deleted file mode 100644 index ac69ea48d8..0000000000 --- a/bundle/winbuild.sh +++ /dev/null @@ -1,47 +0,0 @@ -## This Windows-specific version of build.sh can be run in an msys environment -## to create a .tar.gz bundle for Windows users. -## msysgit contains all of the pieces needed to run this script. - -set -e - -SCRIPTPATH=$( cd "$(dirname "$0")" ; pwd -P ) - -pushd ${SCRIPTPATH} - -# Make the staging directory -mkdir -p build/purescript/ - -# Strip the binaries -strip ../dist/build/psc/psc.exe -strip ../dist/build/psci/psci.exe -strip ../dist/build/psc-docs/psc-docs.exe -strip ../dist/build/psc-publish/psc-publish.exe -strip ../dist/build/psc-bundle/psc-bundle.exe -strip ../dist/build/psc-ide-server/psc-ide-server.exe -strip ../dist/build/psc-ide-client/psc-ide-client.exe - -# Copy files to staging directory -cp ../dist/build/psc/psc.exe build/purescript/ -cp ../dist/build/psci/psci.exe build/purescript/ -cp ../dist/build/psc-docs/psc-docs.exe build/purescript/ -cp ../dist/build/psc-publish/psc-publish.exe build/purescript/ -cp ../dist/build/psc-bundle/psc-bundle.exe build/purescript/ -cp ../dist/build/psc-ide-server/psc-ide-server.exe build/purescript/ -cp ../dist/build/psc-ide-client/psc-ide-client.exe build/purescript/ -cp README build/purescript/ -cp ../LICENSE build/purescript/ -cp ../INSTALL.md build/purescript/ - -# Make the binary bundle -pushd build -tar -zcvf ../win64.tar.gz purescript -popd - -# Calculate the MD5 hash -md5sum win64.tar.gz > win64.md5 - -# Remove the staging directory -rm -rf build/ - -popd - From caf23540b31c6400a51a242dbca66f988394158a Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 9 Apr 2016 02:35:52 +0100 Subject: [PATCH 0359/1580] Remove RedundantUnqualifiedImport Also fix DuplicateSelectiveImport --- src/Language/PureScript/Errors.hs | 6 --- .../PureScript/Sugar/Names/Imports.hs | 48 +++++++++---------- 2 files changed, 23 insertions(+), 31 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 3b97919753..2e926a92df 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -139,7 +139,6 @@ data SimpleErrorMessage | DeprecatedQualifiedSyntax ModuleName ModuleName | DeprecatedClassImport ModuleName (ProperName 'ClassName) | DeprecatedClassExport (ProperName 'ClassName) - | RedundantUnqualifiedImport ModuleName ImportDeclarationType | DuplicateSelectiveImport ModuleName | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) | DuplicateImportRef String @@ -323,7 +322,6 @@ errorCode em = case unwrapErrorMessage em of DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax" DeprecatedClassImport{} -> "DeprecatedClassImport" DeprecatedClassExport{} -> "DeprecatedClassExport" - RedundantUnqualifiedImport{} -> "RedundantUnqualifiedImport" DuplicateSelectiveImport{} -> "DuplicateSelectiveImport" DuplicateImport{} -> "DuplicateImport" DuplicateImportRef{} -> "DuplicateImportRef" @@ -452,7 +450,6 @@ errorSuggestion err = case err of UnusedImport{} -> emptySuggestion RedundantEmptyHidingImport{} -> emptySuggestion DuplicateImport{} -> emptySuggestion - RedundantUnqualifiedImport{} -> emptySuggestion DeprecatedQualifiedSyntax name qualName -> suggest $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual @@ -944,9 +941,6 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , line "The deprecated syntax will be removed in PureScript 0.9." ] - renderSimpleErrorMessage (RedundantUnqualifiedImport name imp) = - line $ "Import of " ++ prettyPrintImport name imp Nothing ++ " is redundant due to a whole-module import" - renderSimpleErrorMessage (DuplicateSelectiveImport name) = line $ "There is an existing import of " ++ runModuleName name ++ ", consider merging the import lists" diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index c03517809e..60ccb19dad 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -12,9 +12,10 @@ module Language.PureScript.Sugar.Names.Imports import Prelude () import Prelude.Compat -import Data.List (find, delete, (\\)) -import Data.Maybe (fromMaybe, isJust, isNothing, fromJust) import Data.Foldable (traverse_, for_) +import Data.Function (on) +import Data.List (find, sortBy, groupBy, (\\)) +import Data.Maybe (fromMaybe, isNothing, fromJust) import Data.Traversable (for) import Control.Arrow (first) @@ -68,29 +69,23 @@ resolveImports env (Module ss coms currentModule decls exps) = for_ (M.toList imports) $ \(mn, imps) -> do - -- Better ordering for the warnings: the list is in last-import-first - -- order, but we want the first appearence of an import to be the primary, - -- and warnings to appear for later imports - let imps' = reverse imps - - warned <- foldM (checkDuplicateImports mn) [] (selfCartesianSubset imps') - - let unqual = filter (\(_, _, q) -> isJust q) (imps' \\ warned) - - warned' <- (warned ++) <$> - if (length unqual < 2) - then return [] - else case find (\(_, typ, _) -> isImplicit typ) unqual of - Just i -> - for (delete i unqual) $ \i'@(pos, typ, _) -> do - warn pos $ RedundantUnqualifiedImport mn typ - return i' - Nothing -> - for (tail unqual) $ \i@(pos, _, _) -> do - warn pos $ DuplicateSelectiveImport mn - return i - - for_ (imps' \\ warned') $ \(pos, typ, _) -> + warned <- foldM (checkDuplicateImports mn) [] (selfCartesianSubset imps) + + let unwarned = imps \\ warned + duplicates + = join + . map tail + . filter ((> 1) . length) + . groupBy ((==) `on` defQual) + . sortBy (compare `on` defQual) + $ unwarned + + warned' <- + for duplicates $ \i@(pos, _, _) -> do + warn pos $ DuplicateSelectiveImport mn + return i + + for_ (imps \\ (warned ++ warned')) $ \(pos, typ, _) -> let (dupeRefs, dupeDctors) = findDuplicateRefs $ case typ of Explicit refs -> refs Hiding refs -> refs @@ -105,6 +100,9 @@ resolveImports env (Module ss coms currentModule decls exps) = return (Module ss coms currentModule decls' exps, resolved) where + defQual :: ImportDef -> Maybe ModuleName + defQual (_, _, q) = q + selfCartesianSubset :: [a] -> [(a, a)] selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs selfCartesianSubset [] = [] From 66e3b656f0e8318eef5026ee6f3e339030c13c58 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 9 Apr 2016 12:28:53 +0100 Subject: [PATCH 0360/1580] Detect invalid newtypes in data binding groups Resolves #1895 --- src/Language/PureScript/TypeChecker.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 15b13aa3ba..e62ecba510 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -191,23 +191,19 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds go :: Declaration -> m Declaration go (DataDeclaration dtype name args dctors) = do warnAndRethrow (addHint (ErrorInTypeConstructor name)) $ do - when (dtype == Newtype) $ checkNewtype dctors + when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args ctorKind <- kindsOf True moduleName name args (concatMap snd dctors) let args' = args `withKinds` ctorKind addDataType moduleName dtype name args' dctors ctorKind return $ DataDeclaration dtype name args dctors - where - checkNewtype :: [(ProperName 'ConstructorName, [Type])] -> m () - checkNewtype [(_, [_])] = return () - checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name - checkNewtype _ = throwError . errorMessage $ InvalidNewtype name go (d@(DataBindingGroupDeclaration tys)) = do warnAndRethrow (addHint ErrorInDataBindingGroup) $ do let syns = mapMaybe toTypeSynonym tys let dataDecls = mapMaybe toDataDecl tys (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls) for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do + when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args let args' = args `withKinds` ctorKind addDataType moduleName dtype name args' dctors ctorKind @@ -327,6 +323,10 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds checkType _ = internalError "Invalid type in instance in checkOrphanInstance" checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance" + checkNewtype :: ProperName 'TypeName -> [(ProperName 'ConstructorName, [Type])] -> m () + checkNewtype _ [(_, [_])] = return () + checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name + -- | -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, -- extracted from the kind of the type constructor itself. From 41afae605566f5b22b09948516685a0004cb349b Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 9 Apr 2016 12:59:52 +0100 Subject: [PATCH 0361/1580] Remove github token from appveyor.yml --- appveyor.yml | 2 -- 1 file changed, 2 deletions(-) diff --git a/appveyor.yml b/appveyor.yml index 18439242be..efbc4d3ce7 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -1,8 +1,6 @@ platform: x64 version: '{build}' environment: - GITHUB_TOKEN: - secure: PUrCLwiP1G73fP5hr5HVpwBQU6n6t0A7CtfQxrFRAlTC+fnkntcA+9TR58OTEy7y # Keep the path as short as possible, just in case. STACK_ROOT: c:\s # Appveyor does not seem to be able to cope with the symbolic link From a704b95568eb67b059d43560d6b663a582a8ed43 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 9 Apr 2016 13:17:50 +0100 Subject: [PATCH 0362/1580] nudge appveyor From 6272bd9b5a3855931ee92054c55b24a20b63e3dc Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 9 Apr 2016 13:53:27 +0100 Subject: [PATCH 0363/1580] Fix re-exports to include intended exports only Resolves #1872 --- src/Language/PureScript/Sugar/Names/Exports.hs | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 242b5a0586..ab3c8f4106 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -119,9 +119,10 @@ resolveExports env mn imps exps refs = extract useQual name render = fmap (map (importName . head . snd)) . go . M.toList where go = filterM $ \(name', options) -> do - let isMatch = if useQual then eqQual name name' else any (eqQual name . importName) options + let isMatch = if useQual then isQualifiedWith name name' else any (checkUnqual name') options when (isMatch && length options > 1) $ void $ checkImportConflicts mn render options return isMatch + checkUnqual name' ir = isUnqualified name' && isQualifiedWith name (importName ir) -- Check whether a module name refers to a "pseudo module" that came into -- existence in an import scope due to importing one or more modules as @@ -134,21 +135,16 @@ resolveExports env mn imps exps refs = -- value being re-exported belongs to a qualified module, and we test the -- values if that fails to see whether the value has been imported at all. testQuals :: (forall a b. M.Map (Qualified a) b -> [Qualified a]) -> ModuleName -> Bool - testQuals f mn' = any (eqQual mn') (f (importedTypes imps)) - || any (eqQual mn') (f (importedDataConstructors imps)) - || any (eqQual mn') (f (importedTypeClasses imps)) - || any (eqQual mn') (f (importedValues imps)) + testQuals f mn' = any (isQualifiedWith mn') (f (importedTypes imps)) + || any (isQualifiedWith mn') (f (importedDataConstructors imps)) + || any (isQualifiedWith mn') (f (importedTypeClasses imps)) + || any (isQualifiedWith mn') (f (importedValues imps)) -- Check whether a module name refers to a module that has been imported -- without qualification into an import scope. isImportedModule :: ModuleName -> Bool isImportedModule = flip elem (importedModules imps) - -- Check whether a module name matches that of a qualified value. - eqQual :: ModuleName -> Qualified a -> Bool - eqQual mn'' (Qualified (Just mn''') _) = mn'' == mn''' - eqQual _ _ = False - -- Constructs a list of types with their data constructors and the original -- module they were defined in from a list of type and data constructor names. resolveTypeExports From c5d0584c8090ebc7d379ca809739f1be21242c94 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 9 Apr 2016 02:10:22 +0100 Subject: [PATCH 0364/1580] Fix spurious import suggestions when re-exporting --- src/Language/PureScript/Linter/Imports.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 446ede2f30..4c094fe574 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -162,10 +162,15 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do -> [(ModuleName, Name)] extractByQual k m toName = mapMaybe go (M.toList m) where - go (q@(Qualified mnq _), is) | isUnqualified q || isQualifiedWith k q = - case importName (head is) of - Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name) - _ -> internalError "unqualified name in extractByQual" + go (q@(Qualified mnq _), is) + | isUnqualified q = + case find (isQualifiedWith k) (map importName is) of + Just (Qualified _ name) -> Just (k, toName $ Qualified mnq name) + _ -> Nothing + | isQualifiedWith k q = + case importName (head is) of + Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name) + _ -> internalError "unqualified name in extractByQual" go _ = Nothing lintImportDecl From a6b346864d0544e8eaa0939ae1c2473057cd6cc1 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Wed, 13 Apr 2016 22:39:01 +0100 Subject: [PATCH 0365/1580] Qualified constructors are not valid identifiers for operator aliases. --- examples/passing/DctorOperatorAlias.purs | 5 +++++ src/Language/PureScript/Parser/Declarations.hs | 4 ++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/examples/passing/DctorOperatorAlias.purs b/examples/passing/DctorOperatorAlias.purs index 31b00271c6..863133d1f1 100644 --- a/examples/passing/DctorOperatorAlias.purs +++ b/examples/passing/DctorOperatorAlias.purs @@ -11,9 +11,14 @@ module Main where import Control.Monad.Eff.Console (CONSOLE, log) import Test.Assert (ASSERT, assert') import Data.List (List(..), (:)) + import Data.List as L + -- unqualified infixl 6 Cons as ! + -- qualified + infixl 6 L.Cons as !! + get1 ∷ ∀ a. a → List a → a get1 y xs = case xs of _ : x : _ → x diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 42d225354f..5a4b0076de 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -126,8 +126,8 @@ parseFixityDeclaration = do name <- symbol return $ FixityDeclaration fixity name alias where - aliased = (Left <$> parseQualified (Ident <$> identifier)) - <|> (Right <$> parseQualified (ProperName <$> uname)) + aliased = P.try (Left <$> parseQualified (Ident <$> identifier)) + <|> (Right <$> parseQualified properName) parseImportDeclaration :: TokenParser Declaration parseImportDeclaration = do From 23b616098885e7b3055bbff26d33b95bbb218efc Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 13 Apr 2016 23:55:10 +0100 Subject: [PATCH 0366/1580] Better error for invalid FFI identifiers, #2011 --- src/Language/PureScript/Errors.hs | 9 +++++++++ src/Language/PureScript/Make.hs | 26 ++++++++++++++++++++------ 2 files changed, 29 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 2e926a92df..2fcc4b930c 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -46,6 +46,7 @@ data SimpleErrorMessage | UnnecessaryFFIModule ModuleName FilePath | MissingFFIImplementations ModuleName [Ident] | UnusedFFIImplementations ModuleName [Ident] + | InvalidFFIIdentifier ModuleName String | CannotGetFileInfo FilePath | CannotReadFile FilePath | CannotWriteFile FilePath @@ -229,6 +230,7 @@ errorCode em = case unwrapErrorMessage em of UnnecessaryFFIModule{} -> "UnnecessaryFFIModule" MissingFFIImplementations{} -> "MissingFFIImplementations" UnusedFFIImplementations{} -> "UnusedFFIImplementations" + InvalidFFIIdentifier{} -> "InvalidFFIIdentifier" CannotGetFileInfo{} -> "CannotGetFileInfo" CannotReadFile{} -> "CannotReadFile" CannotWriteFile{} -> "CannotWriteFile" @@ -552,6 +554,13 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap paras [ line $ "The following definitions in the foreign module for module " ++ runModuleName mn ++ " are unused: " , indent . paras $ map (line . runIdent) idents ] + renderSimpleErrorMessage (InvalidFFIIdentifier mn ident) = + paras [ line $ "In the FFI module for " ++ runModuleName mn ++ ":" + , indent . paras $ + [ line $ "The identifier `" ++ ident ++ "` is not valid in PureScript." + , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers." + ] + ] renderSimpleErrorMessage (MultipleFFIModules mn paths) = paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": " , indent . paras $ map line paths diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 024bd67f5c..9ea9aac547 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -42,6 +42,7 @@ import Control.Concurrent.Lifted as C import Data.List (foldl', sort) import Data.Maybe (fromMaybe, catMaybes, isJust) +import Data.Either (partitionEithers) import Data.Time.Clock import Data.String (fromString) import Data.Foldable (for_) @@ -417,11 +418,10 @@ checkForeignDecls m path = do js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path foreignIdentsStrs <- either errorParsingModule pure $ getExps js - let foreignIdents = - either - (internalError . ("checkForeignDecls: unexpected idents: " ++) . show) - S.fromList - (traverse parseIdent foreignIdentsStrs) + foreignIdents <- either + errorInvalidForeignIdentifiers + (pure . S.fromList) + (parseIdents foreignIdentsStrs) let importedIdents = S.fromList $ map fst (CF.moduleForeign m) let unusedFFI = foreignIdents S.\\ importedIdents @@ -443,10 +443,24 @@ checkForeignDecls m path = do getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String] getExps = Bundle.getExportedIdentifiers (runModuleName mname) + errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a + errorInvalidForeignIdentifiers = + throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname) + + parseIdents :: [String] -> Either [String] [Ident] + parseIdents strs = + case partitionEithers (map parseIdent strs) of + ([], idents) -> + Right idents + (errs, _) -> + Left errs + -- TODO: Handling for parenthesised operators should be removed after 0.9. + -- We ignore the error message here, just being told it's an invalid + -- identifier should be enough. parseIdent :: String -> Either String Ident parseIdent str = try str <|> try ("(" ++ str ++ ")") where - try s = either (Left . show) Right $ do + try s = either (const (Left str)) Right $ do ts <- PSParser.lex "" s PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts From fe184787ff85f577629e1a1fd6086e68e17a216f Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 9 Apr 2016 15:14:14 +0100 Subject: [PATCH 0367/1580] Type operator aliases --- examples/passing/TypeOperators.purs | 34 +++ psci/PSCi.hs | 3 +- purescript.cabal | 1 + src/Language/PureScript/AST/Declarations.hs | 24 +- src/Language/PureScript/AST/Exported.hs | 5 +- src/Language/PureScript/CoreFn/Desugar.hs | 12 +- src/Language/PureScript/Docs/Render.hs | 18 +- src/Language/PureScript/Docs/Types.hs | 4 +- src/Language/PureScript/Errors.hs | 23 +- src/Language/PureScript/Externs.hs | 3 +- src/Language/PureScript/Linter/Imports.hs | 9 +- src/Language/PureScript/ModuleDependencies.hs | 3 +- .../PureScript/Parser/Declarations.hs | 10 +- src/Language/PureScript/Parser/Types.hs | 8 +- src/Language/PureScript/Sugar/Names.hs | 61 ++++- src/Language/PureScript/Sugar/Names/Env.hs | 25 +- .../PureScript/Sugar/Names/Exports.hs | 44 +++- .../PureScript/Sugar/Names/Imports.hs | 13 +- src/Language/PureScript/Sugar/Operators.hs | 217 ++++++++++++++---- .../PureScript/Sugar/Operators/Binders.hs | 44 ++-- .../PureScript/Sugar/Operators/Common.hs | 31 +++ .../PureScript/Sugar/Operators/Expr.hs | 58 +++-- .../PureScript/Sugar/Operators/Types.hs | 28 +++ src/Language/PureScript/TypeChecker.hs | 22 +- src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 2 +- src/Language/PureScript/Types.hs | 34 +++ tests/Main.hs | 5 + tests/TestDocs.hs | 12 +- 29 files changed, 586 insertions(+), 169 deletions(-) create mode 100644 examples/passing/TypeOperators.purs create mode 100644 src/Language/PureScript/Sugar/Operators/Types.hs diff --git a/examples/passing/TypeOperators.purs b/examples/passing/TypeOperators.purs new file mode 100644 index 0000000000..72bd70b6db --- /dev/null +++ b/examples/passing/TypeOperators.purs @@ -0,0 +1,34 @@ +module A + ( Tuple(..) + , type (/\) + , (/\) + , Natural + , type (~>) + ) where + + data Tuple a b = Tuple a b + + infixl 6 Tuple as /\ + infixl 6 type Tuple as /\ + + type Natural f g = ∀ a. f a → g a + + infixr 0 type Natural as ~> + + tup ∷ ∀ a b. a → b → b /\ a + tup a b = b /\ a + + tupX ∷ ∀ a b c. a /\ b /\ c → c + tupX (a /\ b /\ c) = c + +module Main where + + import A (type (~>), type (/\), (/\)) + + natty ∷ ∀ f. f ~> f + natty x = x + + swap ∷ ∀ a b. a /\ b → b /\ a + swap (a /\ b) = b /\ a + + main = Control.Monad.Eff.Console.log "Done" diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 756149449c..fe0502bc47 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -253,8 +253,9 @@ handleShowImportedModules = do showRef :: P.DeclarationRef -> String showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" + showRef (P.TypeOpRef ident) = "type (" ++ N.runIdent ident ++ ")" showRef (P.ValueRef ident) = N.runIdent ident - showRef (P.TypeClassRef pn) = N.runProperName pn + showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn showRef (P.ProperRef pn) = pn showRef (P.TypeInstanceRef ident) = N.runIdent ident showRef (P.ModuleRef name) = "module " ++ N.runModuleName name diff --git a/purescript.cabal b/purescript.cabal index 72446215bb..372e69bba2 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -163,6 +163,7 @@ library Language.PureScript.Sugar.Operators.Common Language.PureScript.Sugar.Operators.Expr Language.PureScript.Sugar.Operators.Binders + Language.PureScript.Sugar.Operators.Types Language.PureScript.Sugar.TypeClasses Language.PureScript.Sugar.TypeClasses.Deriving Language.PureScript.Sugar.TypeDeclarations diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index f4e999c1b8..ad2942eba5 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -62,6 +62,10 @@ data DeclarationRef -- = TypeRef (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName]) -- | + -- A type operator + -- + | TypeOpRef Ident + -- | -- A value -- | ValueRef Ident @@ -89,6 +93,7 @@ data DeclarationRef instance Eq DeclarationRef where (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors' + (TypeOpRef name) == (TypeOpRef name') = name == name' (ValueRef name) == (ValueRef name') = name == name' (TypeClassRef name) == (TypeClassRef name') = name == name' (TypeInstanceRef name) == (TypeInstanceRef name') = name == name' @@ -190,7 +195,7 @@ data Declaration -- | -- A fixity declaration (fixity data, operator name, value the operator is an alias for) -- - | FixityDeclaration Fixity String (Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName)))) + | FixityDeclaration Fixity String (Maybe (Qualified FixityAlias)) -- | -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name) -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9) @@ -211,6 +216,22 @@ data Declaration | PositionedDeclaration SourceSpan [Comment] Declaration deriving (Show, Read) +data FixityAlias + = AliasValue Ident + | AliasConstructor (ProperName 'ConstructorName) + | AliasType (ProperName 'TypeName) + deriving (Eq, Ord, Show, Read) + +foldFixityAlias + :: (Ident -> a) + -> (ProperName 'ConstructorName -> a) + -> (ProperName 'TypeName -> a) + -> FixityAlias + -> a +foldFixityAlias f _ _ (AliasValue name) = f name +foldFixityAlias _ g _ (AliasConstructor name) = g name +foldFixityAlias _ _ h (AliasType name) = h name + -- | The members of a type class instance declaration data TypeInstanceBody -- | This is a derived instance @@ -453,3 +474,4 @@ data DoNotationElement $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''FixityAlias) diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index ec04824464..dce1de96e4 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -127,7 +127,6 @@ isExported (Just exps) decl = any (matches decl) exps matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident' matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident' matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident' - matches (FixityDeclaration _ name _) (ValueRef ident') = name == runIdent ident' matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident' matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident' matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident' @@ -136,6 +135,10 @@ isExported (Just exps) decl = any (matches decl) exps matches (DataDeclaration _ ident _ _) (ProperRef ident') = runProperName ident == ident' matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = runProperName ident == ident' + matches (FixityDeclaration _ name (Just (Qualified _ (AliasValue _)))) (ValueRef ident') = name == runIdent ident' + matches (FixityDeclaration _ name (Just (Qualified _ (AliasConstructor _)))) (ValueRef ident') = name == runIdent ident' + matches (FixityDeclaration _ name (Just (Qualified _ (AliasType _)))) (TypeOpRef ident') = name == runIdent ident' + matches (PositionedDeclaration _ _ d) r = d `matches` r matches d (PositionedDeclarationRef _ _ r) = d `matches` r matches _ _ = False diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 0c86329de2..fc782e6c48 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -72,10 +72,12 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) = [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] - declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) = - let meta = either getValueMeta (Just . getConstructorMeta) alias - alias' = either id (fmap properToIdent) alias - in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) alias')] + declToCoreFn ss com (A.FixityDeclaration _ name (Just (Qualified mn' (A.AliasValue name')))) = + let meta = getValueMeta (Qualified mn' name') + in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) (Qualified mn' name'))] + declToCoreFn ss com (A.FixityDeclaration _ name (Just (Qualified mn' (A.AliasConstructor name')))) = + let meta = Just $ getConstructorMeta (Qualified mn' name') + in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) (Qualified mn' (properToIdent name')))] declToCoreFn ss _ (A.BindingGroupDeclaration ds) = [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds] declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) = @@ -208,7 +210,7 @@ findQualModules decls = where fqDecls :: A.Declaration -> [(Ann, ModuleName)] fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q - fqDecls (A.FixityDeclaration _ _ (Just eq)) = either getQual getQual eq + fqDecls (A.FixityDeclaration _ _ (Just q)) = getQual q fqDecls _ = [] fqValues :: A.Expr -> [(Ann, ModuleName)] diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index ca53c9107b..fbce4ad8c8 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -61,20 +61,22 @@ renderDeclarationWithOptions opts Declaration{..} = AliasDeclaration for (P.Fixity associativity precedence) -> [ keywordFixity associativity , syntax $ show precedence - , ident $ - either - (P.showQualified P.runIdent . dequalifyCurrentModule) - (P.showQualified P.runProperName . dequalifyCurrentModule) - for + , ident $ renderAlias for , keyword "as" , ident . tail . init $ declTitle ] where renderType' = renderTypeWithOptions opts - dequalifyCurrentModule (P.Qualified mn a) - | mn == currentModule opts = P.Qualified Nothing a - | otherwise = P.Qualified mn a + renderAlias (P.Qualified mn alias) + | mn == currentModule opts = + P.foldFixityAlias P.runIdent P.runProperName P.runProperName alias + | otherwise = + P.foldFixityAlias + (P.showQualified P.runIdent . P.Qualified mn) + (P.showQualified P.runProperName . P.Qualified mn) + (P.showQualified P.runProperName . P.Qualified mn) + alias renderChildDeclaration :: ChildDeclaration -> RenderedCode renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 28bbad45df..b244840687 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -133,7 +133,7 @@ data DeclarationInfo -- An operator alias declaration, with the member the alias is for and the -- operator's fixity. -- - | AliasDeclaration (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName))) P.Fixity + | AliasDeclaration (P.Qualified P.FixityAlias) P.Fixity deriving (Show, Eq, Ord) declInfoToString :: DeclarationInfo -> String @@ -411,7 +411,7 @@ asDeclarationInfo = do other -> throwCustomError (InvalidDeclarationType other) -asAliasFor :: Parse e (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName))) +asAliasFor :: Parse e (P.Qualified P.FixityAlias) asAliasFor = fromAesonParser asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 2fcc4b930c..eee602eb1b 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -60,12 +60,15 @@ data SimpleErrorMessage | OverlappingNamesInLet | UnknownModule ModuleName | UnknownType (Qualified (ProperName 'TypeName)) + | UnknownTypeOp (Qualified Ident) | UnknownTypeClass (Qualified (ProperName 'ClassName)) | UnknownValue (Qualified Ident) | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName))) | UnknownTypeConstructor (Qualified (ProperName 'TypeName)) | UnknownImportType ModuleName (ProperName 'TypeName) | UnknownExportType (ProperName 'TypeName) + | UnknownImportTypeOp ModuleName Ident + | UnknownExportTypeOp Ident | UnknownImportTypeClass ModuleName (ProperName 'ClassName) | UnknownExportTypeClass (ProperName 'ClassName) | UnknownImportValue ModuleName Ident @@ -84,6 +87,7 @@ data SimpleErrorMessage | DuplicateModuleName ModuleName | DuplicateClassExport (ProperName 'ClassName) | DuplicateValueExport Ident + | DuplicateTypeOpExport Ident | DuplicateTypeArgument String | InvalidDoBind | InvalidDoLet @@ -244,12 +248,15 @@ errorCode em = case unwrapErrorMessage em of OverlappingNamesInLet -> "OverlappingNamesInLet" UnknownModule{} -> "UnknownModule" UnknownType{} -> "UnknownType" + UnknownTypeOp{} -> "UnknownTypeOp" UnknownTypeClass{} -> "UnknownTypeClass" UnknownValue{} -> "UnknownValue" UnknownDataConstructor{} -> "UnknownDataConstructor" UnknownTypeConstructor{} -> "UnknownTypeConstructor" UnknownImportType{} -> "UnknownImportType" + UnknownImportTypeOp{} -> "UnknownImportTypeOp" UnknownExportType{} -> "UnknownExportType" + UnknownExportTypeOp{} -> "UnknownExportTypeOp" UnknownImportTypeClass{} -> "UnknownImportTypeClass" UnknownExportTypeClass{} -> "UnknownExportTypeClass" UnknownImportValue{} -> "UnknownImportValue" @@ -268,6 +275,7 @@ errorCode em = case unwrapErrorMessage em of DuplicateModuleName{} -> "DuplicateModuleName" DuplicateClassExport{} -> "DuplicateClassExport" DuplicateValueExport{} -> "DuplicateValueExport" + DuplicateTypeOpExport{} -> "DuplicateTypeOpExport" DuplicateTypeArgument{} -> "DuplicateTypeArgument" InvalidDoBind -> "InvalidDoBind" InvalidDoLet -> "InvalidDoLet" @@ -595,6 +603,8 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap line $ "Unknown module " ++ runModuleName mn renderSimpleErrorMessage (UnknownType name) = line $ "Unknown type " ++ showQualified runProperName name + renderSimpleErrorMessage (UnknownTypeOp name) = + line $ "Unknown type operator " ++ showQualified showIdent name renderSimpleErrorMessage (UnknownTypeClass name) = line $ "Unknown type class " ++ showQualified runProperName name renderSimpleErrorMessage (UnknownValue name) = @@ -609,6 +619,12 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap ] renderSimpleErrorMessage (UnknownExportType name) = line $ "Cannot export unknown type " ++ runProperName name + renderSimpleErrorMessage (UnknownImportTypeOp mn name) = + paras [ line $ "Cannot import type operator " ++ showIdent name ++ " from module " ++ runModuleName mn + , line "It either does not exist or the module does not export it." + ] + renderSimpleErrorMessage (UnknownExportTypeOp name) = + line $ "Cannot export unknown type operator " ++ showIdent name renderSimpleErrorMessage (UnknownImportTypeClass mn name) = paras [ line $ "Cannot import type class " ++ runProperName name ++ " from module " ++ runModuleName mn , line "It either does not exist or the module does not export it." @@ -658,6 +674,8 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap line $ "Duplicate export declaration for type class " ++ runProperName nm renderSimpleErrorMessage (DuplicateValueExport nm) = line $ "Duplicate export declaration for value " ++ showIdent nm + renderSimpleErrorMessage (DuplicateTypeOpExport nm) = + line $ "Duplicate export declaration for type operator " ++ showIdent nm renderSimpleErrorMessage (CycleInDeclaration nm) = line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = @@ -996,8 +1014,8 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap renderSimpleErrorMessage (InvalidOperatorInBinder op fn) = paras [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "." - , line "Only aliases for data constructors may be used in patterns." - ] + , line "Only aliases for data constructors may be used in patterns." + ] renderSimpleErrorMessage DeprecatedRequirePath = line "The require-path option is deprecated and will be removed in PureScript 0.9." @@ -1205,6 +1223,7 @@ prettyPrintRef :: DeclarationRef -> String prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)" prettyPrintRef (TypeRef pn (Just [])) = runProperName pn prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")" +prettyPrintRef (TypeOpRef ident) = "type " ++ showIdent ident prettyPrintRef (ValueRef ident) = showIdent ident prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn prettyPrintRef (ProperRef name) = name diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index b334a8bf5d..f9617d5e02 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -73,7 +73,7 @@ data ExternsFixity = ExternsFixity -- | The operator symbol , efOperator :: String -- | The value the operator is an alias for - , efAlias :: Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))) + , efAlias :: Maybe (Qualified FixityAlias) } deriving (Show, Read) -- | A type or value declaration appearing in an externs file @@ -159,6 +159,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} exportsOp :: DeclarationRef -> Bool exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r exportsOp (ValueRef ident') = ident' == Op op + exportsOp (TypeOpRef ident') = ident' == Op op exportsOp _ = False fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d fixityDecl _ = Nothing diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 4c094fe574..945ff27a37 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -35,6 +35,7 @@ import qualified Language.PureScript.Constants as C data Name = IdentName (Qualified Ident) | TyName (Qualified (ProperName 'TypeName)) + | TyOpName (Qualified Ident) | DctorName (Qualified (ProperName 'ConstructorName)) | TyClassName (Qualified (ProperName 'ClassName)) deriving (Eq, Show) @@ -43,6 +44,10 @@ getIdentName :: Maybe ModuleName -> Name -> Maybe Ident getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name getIdentName _ _ = Nothing +getTypeOpName :: Maybe ModuleName -> Name -> Maybe Ident +getTypeOpName q (TyOpName (Qualified q' name)) | q == q' = Just name +getTypeOpName _ _ = Nothing + getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName) getTypeName q (TyName (Qualified q' name)) | q == q' = Just name getTypeName _ _ = Nothing @@ -265,6 +270,7 @@ findUsedRefs env mni qualifierName names = let classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names + typeOpRefs = TypeOpRef <$> mapMaybe (getTypeOpName qualifierName) names types = mapMaybe (getTypeName qualifierName) names dctors = mapMaybe (matchDctor qualifierName) names typesWithDctors = reconstructTypeRefs dctors @@ -272,7 +278,7 @@ findUsedRefs env mni qualifierName names = typesRefs = map (flip TypeRef (Just [])) typesWithoutDctors ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors) - in classRefs ++ typesRefs ++ valueRefs + in classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs where @@ -309,6 +315,7 @@ matchName _ _ _ = Nothing extractQualName :: Name -> Maybe ModuleName extractQualName (IdentName (Qualified q _)) = q extractQualName (TyName (Qualified q _)) = q +extractQualName (TyOpName (Qualified q _)) = q extractQualName (TyClassName (Qualified q _)) = q extractQualName (DctorName (Qualified q _)) = q diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 93b85e8329..b1f3e845f7 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -61,8 +61,7 @@ usedModules d = where forDecls :: Declaration -> [ModuleName] forDecls (ImportDeclaration mn _ _ _) = [mn] - forDecls (FixityDeclaration _ _ (Just (Left (Qualified (Just mn) _)))) = [mn] - forDecls (FixityDeclaration _ _ (Just (Right (Qualified (Just mn) _)))) = [mn] + forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn] forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn] forDecls _ = [] diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 5a4b0076de..655e02799b 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -122,12 +122,13 @@ parseFixityDeclaration :: TokenParser Declaration parseFixityDeclaration = do fixity <- parseFixity indented - alias <- P.optionMaybe $ aliased <* reserved "as" + alias <- P.optionMaybe $ parseQualified aliased <* reserved "as" name <- symbol return $ FixityDeclaration fixity name alias where - aliased = P.try (Left <$> parseQualified (Ident <$> identifier)) - <|> (Right <$> parseQualified properName) + aliased = (AliasValue . Ident <$> identifier) + <|> (AliasConstructor <$> properName) + <|> reserved "type" *> (AliasType <$> properName) parseImportDeclaration :: TokenParser Declaration parseImportDeclaration = do @@ -164,6 +165,7 @@ parseDeclarationRef = <|> parseProperRef <|> (TypeClassRef <$> (reserved "class" *> properName)) <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName)) + <|> (TypeOpRef <$> (indented *> reserved "type" *> parens (Op <$> symbol))) where parseProperRef = do name <- properName @@ -483,7 +485,7 @@ parseConstructorBinder :: TokenParser Binder parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens) parseObjectBinder:: TokenParser Binder -parseObjectBinder= LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder) +parseObjectBinder = LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder) parseArrayBinder :: TokenParser Binder parseArrayBinder = LiteralBinder <$> parseArrayLiteral (C.indented *> parseBinder) diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index ca14aa5585..7d8905503c 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -8,6 +8,7 @@ module Language.PureScript.Parser.Types ( import Control.Applicative import Control.Monad (when, unless) +import Language.PureScript.Names import Language.PureScript.Types import Language.PureScript.Parser.Common import Language.PureScript.Parser.Kinds @@ -53,7 +54,7 @@ parseTypeAtom = indented *> P.choice , parseTypeConstructor -- This try is needed due to some unfortunate ambiguities between rows and kinded types , P.try (parens parseRow) - , parens parsePolyType + , ParensInType <$> parens parsePolyType ] parseConstrainedType :: TokenParser Type @@ -74,7 +75,10 @@ parseConstrainedType = do parseAnyType :: TokenParser Type parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P. "type" where - operators = [ [ P.Infix (return TypeApp) P.AssocLeft ] + operators = [ [ P.Infix (P.try (parseQualified (Op <$> symbol)) >>= \ident -> + return (BinaryNoParensType (TypeOp ident))) P.AssocRight + ] + , [ P.Infix (return TypeApp) P.AssocLeft ] , [ P.Infix (rarrow >> return function) P.AssocRight ] ] postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 410f905fc4..b7997ecd2b 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -85,6 +85,12 @@ desugarImportsWithEnv externs modules = do forTyCon _ = Nothing toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r toExportedType _ = Nothing + exportedTypeOps :: [(Ident, ModuleName)] + exportedTypeOps = mapMaybe toExportedTypeOp efExports + where + toExportedTypeOp (TypeOpRef ident) = Just (ident, efModuleName) + toExportedTypeOp (PositionedDeclarationRef _ _ r) = toExportedTypeOp r + toExportedTypeOp _ = Nothing exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)] exportedTypeClasses = mapMaybe toExportedTypeClass efExports where @@ -126,6 +132,7 @@ elaborateExports :: Exports -> Module -> Module elaborateExports exps (Module ss coms mn decls refs) = Module ss coms mn decls $ Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (my exportedTypes) ++ + map TypeOpRef (my exportedTypeOps) ++ map TypeClassRef (my exportedTypeClasses) ++ map ValueRef (my exportedValues) ++ maybe [] (filter isModuleRef) refs @@ -171,7 +178,15 @@ renameInModule env imports (Module ss coms mn decls exps) = updateDecl (pos, bound) (ExternDeclaration name ty) = (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty) updateDecl (pos, bound) (FixityDeclaration fx name alias) = - (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse (eitherM (`updateValueName` pos) (`updateDataConstructorName` pos)) alias) + (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse updateAlias alias) + where + updateAlias :: Qualified FixityAlias -> m (Qualified FixityAlias) + updateAlias (Qualified mn' (AliasValue ident)) = + fmap AliasValue <$> updateValueName (Qualified mn' ident) pos + updateAlias (Qualified mn' (AliasConstructor ctor)) = + fmap AliasConstructor <$> updateDataConstructorName (Qualified mn' ctor) pos + updateAlias (Qualified mn' (AliasType ty)) = + fmap AliasType <$> updateTypeName (Qualified mn' ty) pos updateDecl s d = return (s, d) updateValue @@ -231,6 +246,7 @@ renameInModule env imports (Module ss coms mn decls exps) = updateTypesEverywhere pos = everywhereOnTypesM updateType where updateType :: Type -> m Type + updateType (TypeOp name) = TypeOp <$> updateTypeOpName name pos updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t updateType t = return t @@ -242,22 +258,57 @@ renameInModule env imports (Module ss coms mn decls exps) = :: Qualified (ProperName 'TypeName) -> Maybe SourceSpan -> m (Qualified (ProperName 'TypeName)) - updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) TyName (("type " ++) . runProperName) + updateTypeName = + update UnknownType + (importedTypes imports) + (resolveType . exportedTypes) + TyName + (("type " ++) . runProperName) + + updateTypeOpName + :: Qualified Ident + -> Maybe SourceSpan + -> m (Qualified Ident) + updateTypeOpName = + update + UnknownTypeOp + (importedTypeOps imports) + (resolve . exportedTypeOps) + TyOpName + (("type operator" ++) . runIdent) updateDataConstructorName :: Qualified (ProperName 'ConstructorName) -> Maybe SourceSpan -> m (Qualified (ProperName 'ConstructorName)) - updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName (("data constructor " ++) . runProperName) + updateDataConstructorName = + update + (flip UnknownDataConstructor Nothing) + (importedDataConstructors imports) + (resolveDctor . exportedTypes) + DctorName + (("data constructor " ++) . runProperName) updateClassName :: Qualified (ProperName 'ClassName) -> Maybe SourceSpan -> m (Qualified (ProperName 'ClassName)) - updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) TyClassName (("class " ++) . runProperName) + updateClassName = + update + UnknownTypeClass + (importedTypeClasses imports) + (resolve . exportedTypeClasses) + TyClassName + (("class " ++) . runProperName) updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident) - updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName (("value " ++) . runIdent) + updateValueName = + update + UnknownValue + (importedValues imports) + (resolve . exportedValues) + IdentName + (("value " ++) . runIdent) -- Used when performing an update to qualify values and classes with their -- module of original definition. diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 5af2c7612d..4c31ceb565 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -14,6 +14,7 @@ module Language.PureScript.Sugar.Names.Env , envModuleImports , envModuleExports , exportType + , exportTypeOp , exportTypeClass , exportValue , getExports @@ -70,6 +71,10 @@ data Imports = Imports -- importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [ImportRecord (ProperName 'TypeName)] -- | + -- Local names for type operators within a module mapped to to their qualified names + -- + , importedTypeOps :: M.Map (Qualified Ident) [ImportRecord Ident] + -- | -- Local names for data constructors within a module mapped to to their qualified names -- , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [ImportRecord (ProperName 'ConstructorName)] @@ -96,7 +101,7 @@ data Imports = Imports -- An empty 'Imports' value. -- nullImports :: Imports -nullImports = Imports M.empty M.empty M.empty M.empty S.empty S.empty +nullImports = Imports M.empty M.empty M.empty M.empty M.empty S.empty S.empty -- | -- The exported declarations from a module. @@ -109,6 +114,11 @@ data Exports = Exports -- exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] -- | + -- The type operators exported from each module along with the module they + -- originally came from. + -- + , exportedTypeOps :: [(Ident, ModuleName)] + -- | -- The classes exported from each module along with the module they originally -- came from. -- @@ -124,7 +134,7 @@ data Exports = Exports -- An empty 'Exports' value. -- nullExports :: Exports -nullExports = Exports [] [] [] +nullExports = Exports [] [] [] [] -- | -- The imports and exports for a collection of modules. The 'SourceSpan' is used @@ -155,7 +165,7 @@ envModuleExports (_, _, exps) = exps -- The exported types from the @Prim@ module -- primExports :: Exports -primExports = Exports (mkTypeEntry `map` M.keys primTypes) (mkClassEntry `map` M.keys primClasses) [] +primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] (mkClassEntry `map` M.keys primClasses) [] where mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn) mkClassEntry (Qualified mn name) = (name, fromJust mn) @@ -183,6 +193,15 @@ exportType exps name dctors mn = do when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' } +-- | +-- Safely adds a type operator to some exports, returning an error if a +-- conflict occurs. +-- +exportTypeOp :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports +exportTypeOp exps name mn = do + typeOps <- addExport DuplicateTypeOpExport name mn (exportedTypeOps exps) + return $ exps { exportedTypeOps = typeOps } + -- | -- Safely adds a class to some exports, returning an error if a conflict occurs. -- diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index ab3c8f4106..8c47c9f18a 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -47,6 +47,7 @@ findExportable (Module _ _ mn ds _) = updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn + updateExports exps (FixityDeclaration _ name (Just (Qualified _ (AliasType _)))) = exportTypeOp exps (Op name) mn updateExports exps (FixityDeclaration _ name (Just _)) = exportValue exps (Op name) mn updateExports exps (ExternDeclaration name _) = exportValue exps name mn updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d @@ -70,6 +71,7 @@ resolveExports env mn imps exps refs = warnDupeRefs :: [DeclarationRef] -> m () warnDupeRefs = traverse_ $ \case TypeRef name _ -> warnDupe $ "type " ++ runProperName name + TypeOpRef name -> warnDupe $ "type operator " ++ runIdent name ValueRef name -> warnDupe $ "value " ++ runIdent name TypeClassRef name -> warnDupe $ "class " ++ runProperName name ModuleRef name -> warnDupe $ "module " ++ runModuleName name @@ -89,22 +91,28 @@ resolveExports env mn imps exps refs = rethrowWithPosition pos $ elaborateModuleExports result r elaborateModuleExports result (ModuleRef name) | name == mn = do let types' = exportedTypes result ++ exportedTypes exps + let typeOps' = exportedTypeOps result ++ exportedTypeOps exps let classes' = exportedTypeClasses result ++ exportedTypeClasses exps let values' = exportedValues result ++ exportedValues exps - return result { exportedTypes = types' - , exportedTypeClasses = classes' - , exportedValues = values' } + return result + { exportedTypes = types' + , exportedTypeOps = typeOps' + , exportedTypeClasses = classes' + , exportedValues = values' + } elaborateModuleExports result (ModuleRef name) = do let isPseudo = isPseudoModule name when (not isPseudo && not (isImportedModule name)) $ throwError . errorMessage . UnknownExportModule $ name reTypes <- extract isPseudo name (("type " ++) . runProperName) (importedTypes imps) + reTypeOps <- extract isPseudo name (("type operator " ++) . runIdent) (importedTypeOps imps) reDctors <- extract isPseudo name (("data constructor " ++) . runProperName) (importedDataConstructors imps) reClasses <- extract isPseudo name (("class " ++) . runProperName) (importedTypeClasses imps) reValues <- extract isPseudo name (("value " ++) . runIdent) (importedValues imps) result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors) - result'' <- foldM (uncurry . exportTypeClass) result' (map resolveClass reClasses) - foldM (uncurry . exportValue) result'' (map resolveValue reValues) + result'' <- foldM (uncurry . exportTypeOp) result' (map resolveTypeOp reTypeOps) + result''' <- foldM (uncurry . exportTypeClass) result'' (map resolveClass reClasses) + foldM (uncurry . exportValue) result''' (map resolveValue reValues) elaborateModuleExports result _ = return result -- Extracts a list of values for a module based on a lookup table. If the @@ -163,6 +171,11 @@ resolveExports env mn imps exps refs = return ((name, relevantDctors `intersect` dctors'), mnOrig) go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports" + -- Looks up an imported type operator and re-qualifies it with the original + -- module it came from. + resolveTypeOp :: Qualified Ident -> (Ident, ModuleName) + resolveTypeOp ident = splitQual $ fromMaybe (internalError "Missing value in resolveValue") $ + resolve exportedTypeOps ident -- Looks up an imported class and re-qualifies it with the original module it -- came from. @@ -202,9 +215,15 @@ filterModule -> m Exports filterModule mn exps refs = do types <- foldM (filterTypes $ exportedTypes exps) [] refs + typeOps <- foldM (filterTypeOps $ exportedTypeOps exps) [] refs values <- foldM (filterValues $ exportedValues exps) [] refs classes <- foldM (filterClasses $ exportedTypeClasses exps) [] refs - return exps { exportedTypes = types , exportedTypeClasses = classes , exportedValues = values } + return $ exps + { exportedTypes = types + , exportedTypeOps = typeOps + , exportedTypeClasses = classes + , exportedValues = values + } where @@ -241,6 +260,19 @@ filterModule mn exps refs = do unless (name `elem` exps') $ throwError . errorMessage $ UnknownExportDataConstructor tcon name + -- Takes a list of all the exportable type operators, the accumulated list of + -- filtered exports, and a `DeclarationRef` for an explicit export. When the + -- ref refers to a value in the list of exportable values, the value is + -- included in the result. + filterTypeOps :: [(Ident, ModuleName)] -> [(Ident, ModuleName)] -> DeclarationRef -> m [(Ident, ModuleName)] + filterTypeOps exps' result (PositionedDeclarationRef pos _ r) = + rethrowWithPosition pos $ filterTypeOps exps' result r + filterTypeOps exps' result (TypeOpRef name) = + if (name, mn) `elem` exps' + then return $ (name, mn) : result + else throwError . errorMessage . UnknownExportTypeOp $ name + filterTypeOps _ result _ = return result + -- Takes a list of all the exportable classes, the accumulated list of -- filtered exports, and a `DeclarationRef` for an explicit export. When the -- ref refers to a class in the list of exportable classes, the class is diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 60ccb19dad..783a13d7a1 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -97,6 +97,7 @@ resolveImports env (Module ss coms currentModule decls exps) = let imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports' resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope) + return (Module ss coms currentModule decls' exps, resolved) where @@ -118,6 +119,7 @@ resolveImports env (Module ss coms currentModule decls exps) = warnDupeRefs :: Maybe SourceSpan -> [DeclarationRef] -> m () warnDupeRefs pos = traverse_ $ \case TypeRef name _ -> warnDupe pos $ "type " ++ runProperName name + TypeOpRef name -> warnDupe pos $ "type operator " ++ runIdent name ValueRef name -> warnDupe pos $ "value " ++ runIdent name TypeClassRef name -> warnDupe pos $ "class " ++ runProperName name ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name @@ -203,6 +205,7 @@ resolveImport importModule exps imps impQual = resolveByType imps' <- checkRefs True refs >> importAll (importNonHidden refs) let isEmptyImport = M.null (importedTypes imps') + && M.null (importedTypeOps imps') && M.null (importedDataConstructors imps') && M.null (importedTypeClasses imps') && M.null (importedValues imps') @@ -221,6 +224,8 @@ resolveImport importModule exps imps impQual = resolveByType checkImportExists UnknownImportType ((fst . fst) `map` exportedTypes exps) name let allDctors = fst `map` allExportedDataConstructors name maybe (return ()) (traverse_ $ checkDctorExists name allDctors) dctors + check (TypeOpRef name) = + checkImportExists UnknownImportTypeOp (fst `map` exportedTypeOps exps) name check (TypeClassRef name) = checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name check (ModuleRef name) | isHiding = @@ -267,8 +272,9 @@ resolveImport importModule exps imps impQual = resolveByType importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports importAll importer = do imp' <- foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps) - imp'' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp' (exportedValues exps) - foldM (\m (name, _) -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps) + imp'' <- foldM (\m (name, _) -> importer m (TypeOpRef name)) imp' (exportedTypeOps exps) + imp''' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp'' (exportedValues exps) + foldM (\m (name, _) -> importer m (TypeClassRef name)) imp''' (exportedTypeClasses exps) importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports importRef prov imp (PositionedDeclarationRef pos _ r) = @@ -286,6 +292,9 @@ resolveImport importModule exps imps impQual = resolveByType when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name let dctors' = foldl (\m d -> updateImports m exportedDctors d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors) return $ imp { importedTypes = types', importedDataConstructors = dctors' } + importRef prov imp (TypeOpRef name) = do + let ops' = updateImports (importedTypeOps imp) (exportedTypeOps exps) name prov + return $ imp { importedTypeOps = ops' } importRef prov imp (TypeClassRef name) = do let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov return $ imp { importedTypeClasses = typeClasses' } diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 01f8522857..4fa565e94c 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} @@ -11,11 +10,11 @@ -- The value parser ignores fixity data when parsing binary operator applications, so -- it is necessary to reorder them here. -- -module Language.PureScript.Sugar.Operators ( - rebracket, - removeSignedLiterals, - desugarOperatorSections -) where +module Language.PureScript.Sugar.Operators + ( rebracket + , removeSignedLiterals + , desugarOperatorSections + ) where import Prelude () import Prelude.Compat @@ -27,30 +26,29 @@ import Language.PureScript.Externs import Language.PureScript.Names import Language.PureScript.Sugar.Operators.Binders import Language.PureScript.Sugar.Operators.Expr -import Language.PureScript.Traversals (defS) +import Language.PureScript.Sugar.Operators.Types +import Language.PureScript.Traversals (defS, sndM) +import Language.PureScript.Types +import Control.Monad ((<=<)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class import Data.Function (on) -import Data.List (groupBy, sortBy) +import Data.Functor.Identity +import Data.List (partition, groupBy, sortBy) import Data.Maybe (mapMaybe) import qualified Data.Map as M import qualified Language.PureScript.Constants as C --- TODO: in 0.9 operators names can have their own type rather than being in a sum with `Ident`, and `AliasName` no longer needs to be optional +-- TODO: in 0.9 operators names can have their own type rather than being in a sum with `Ident`, and `FixityAlias` no longer needs to be optional -- | -- An operator associated with its declaration position, fixity, and the name -- of the function or data constructor it is an alias for. -- -type FixityRecord = (Qualified Ident, SourceSpan, Fixity, Maybe AliasName) - --- | --- An operator can be an alias for a function or a data constructor. --- -type AliasName = Either (Qualified Ident) (Qualified (ProperName 'ConstructorName)) +type FixityRecord = (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified FixityAlias)) -- | -- Remove explicit parentheses and reorder binary operator applications @@ -62,23 +60,57 @@ rebracket -> [Module] -> m [Module] rebracket externs ms = do - let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms - ensureNoDuplicates $ map (\(i, pos, _, _) -> (i, pos)) fixities - let opTable = customOperatorTable $ map (\(i, _, f, _) -> (i, f)) fixities - ms' <- traverse (rebracketModule opTable) ms - let aliased = M.fromList (mapMaybe makeLookupEntry fixities) - mapM (renameAliasedOperators aliased) ms' + let (typeFixities, valueFixities) = partition isTypeFixity $ + concatMap externsFixities externs ++ concatMap collectFixities ms + + ensureNoDuplicates' $ valueFixities + ensureNoDuplicates' $ typeFixities + + let valueOpTable = customOperatorTable' valueFixities + typeOpTable = customOperatorTable' typeFixities + ms' <- traverse (rebracketModule valueOpTable typeOpTable) ms + + let valueAliased = M.fromList (mapMaybe makeLookupEntry valueFixities) + typeAliased = M.fromList (mapMaybe makeLookupEntry typeFixities) + mapM (renameAliasedOperators valueAliased typeAliased) ms' where - makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, AliasName) + isTypeFixity :: FixityRecord -> Bool + -- Nothing case for FixityAlias can only ever be a value fixity, as it's not + -- possible to define types with operator names aside through aliasing. + -- TODO: This comment is redundant after 0.9. + isTypeFixity (_, _, _, Just (Qualified _ (AliasType _))) = True + isTypeFixity _ = False + + ensureNoDuplicates' :: [FixityRecord] -> m () + ensureNoDuplicates' = + ensureNoDuplicates . map (\(i, pos, _, _) -> (i, pos)) + + customOperatorTable' :: [FixityRecord] -> [[(Qualified Ident, Associativity)]] + customOperatorTable' = + customOperatorTable . map (\(i, _, f, _) -> (i, f)) + + makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, Qualified FixityAlias) makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias - renameAliasedOperators :: M.Map (Qualified Ident) AliasName -> Module -> m Module - renameAliasedOperators aliased (Module ss coms mn ds exts) = + renameAliasedOperators + :: M.Map (Qualified Ident) (Qualified FixityAlias) + -> M.Map (Qualified Ident) (Qualified FixityAlias) + -> Module + -> m Module + renameAliasedOperators valueAliased typeAliased (Module ss coms mn ds exts) = Module ss coms mn <$> mapM f' ds <*> pure exts where - (f', _, _, _, _) = everywhereWithContextOnValuesM Nothing goDecl goExpr goBinder defS defS + (goDecl', goExpr') = updateTypes goType + (f', _, _, _, _) = + everywhereWithContextOnValuesM + Nothing + (\pos -> uncurry goDecl <=< goDecl' pos) + (\pos -> uncurry goExpr <=< goExpr' pos) + goBinder + defS + defS goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration) goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d) @@ -86,27 +118,39 @@ rebracket externs ms = do goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) - goExpr pos (Var name) = return (pos, case name `M.lookup` aliased of - Just (Left alias) -> Var alias - Just (Right alias) -> Constructor alias - Nothing -> Var name) + goExpr pos (Var name) = return (pos, case name `M.lookup` valueAliased of + Just (Qualified mn' (AliasValue alias)) -> Var (Qualified mn' alias) + Just (Qualified mn' (AliasConstructor alias)) -> Constructor (Qualified mn' alias) + _ -> Var name) goExpr pos other = return (pos, other) goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b) - goBinder pos (BinaryNoParensBinder (OpBinder name) lhs rhs) = case name `M.lookup` aliased of - Just (Left alias) -> + goBinder pos (BinaryNoParensBinder (OpBinder name) lhs rhs) = case name `M.lookup` valueAliased of + Just (Qualified _ (AliasValue alias)) -> maybe id rethrowWithPosition pos $ - throwError . errorMessage $ InvalidOperatorInBinder (disqualify name) (disqualify alias) - Just (Right alias) -> - return (pos, ConstructorBinder alias [lhs, rhs]) - Nothing -> + throwError . errorMessage $ InvalidOperatorInBinder (disqualify name) alias + Just (Qualified mn' (AliasConstructor alias)) -> + return (pos, ConstructorBinder (Qualified mn' alias) [lhs, rhs]) + _ -> maybe id rethrowWithPosition pos $ throwError . errorMessage $ UnknownValue name goBinder _ (BinaryNoParensBinder {}) = internalError "BinaryNoParensBinder has no OpBinder" goBinder pos other = return (pos, other) + goType :: Maybe SourceSpan -> Type -> m Type + goType pos = everywhereOnTypesM go + where + go :: Type -> m Type + go (BinaryNoParensType (TypeOp name) lhs rhs) = case name `M.lookup` typeAliased of + Just (Qualified mn' (AliasType alias)) -> + return $ TypeApp (TypeApp (TypeConstructor (Qualified mn' alias)) lhs) rhs + _ -> + maybe id rethrowWithPosition pos $ + throwError . errorMessage $ UnknownTypeOp name + go other = return other + removeSignedLiterals :: Module -> Module removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts where @@ -116,24 +160,64 @@ removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) go other = other rebracketModule - :: (MonadError MultipleErrors m) + :: forall m + . (MonadError MultipleErrors m) => [[(Qualified Ident, Associativity)]] + -> [[(Qualified Ident, Associativity)]] -> Module -> m Module -rebracketModule opTable (Module ss coms mn ds exts) = - let (f, _, _) = everywhereOnValuesTopDownM return (matchExprOperators opTable) (matchBinderOperators opTable) - in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts +rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) = + Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts + where + (f, _, _) = + everywhereOnValuesTopDownM + (decontextify goDecl) + (goExpr <=< decontextify goExpr') + goBinder + + (goDecl, goExpr') = updateTypes (\_ -> goType) + + goExpr :: Expr -> m Expr + goExpr = return . matchExprOperators valueOpTable + + goBinder :: Binder -> m Binder + goBinder = return . matchBinderOperators valueOpTable + + goType :: Type -> m Type + goType = return . matchTypeOperators typeOpTable + + decontextify :: (Maybe SourceSpan -> a -> m (Maybe SourceSpan, a)) -> a -> m a + decontextify ctxf = fmap snd . ctxf Nothing removeParens :: Declaration -> Declaration -removeParens = - let (f, _, _) = everywhereOnValues id goExpr goBinder - in f +removeParens = f where + (f, _, _) = + everywhereOnValues + (decontextify goDecl) + (goExpr . decontextify goExpr') + goBinder + + (goDecl, goExpr') = updateTypes (\_ -> return . goType) + + goExpr :: Expr -> Expr goExpr (Parens val) = val goExpr val = val + + goBinder :: Binder -> Binder goBinder (ParensInBinder b) = b goBinder b = b + goType :: Type -> Type + goType (ParensInType t) = t + goType t = t + + decontextify + :: (Maybe SourceSpan -> a -> Identity (Maybe SourceSpan, a)) + -> a + -> a + decontextify ctxf = snd . runIdentity . ctxf Nothing + externsFixities :: ExternsFile -> [FixityRecord] @@ -197,3 +281,52 @@ desugarOperatorSections (Module ss coms mn ds exts) = Left val -> f2 val var Right val -> f2 var val goExpr other = return other + +updateTypes + :: forall m + . Monad m + => (Maybe SourceSpan -> Type -> m Type) + -> ( Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration) + , Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) + ) +updateTypes goType = (goDecl, goExpr) + where + + goType' :: Maybe SourceSpan -> Type -> m Type + goType' = everywhereOnTypesM . goType + + goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration) + goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d) + goDecl pos (DataDeclaration ddt name args dctors) = do + dctors' <- traverse (sndM (traverse (goType' pos))) dctors + return (pos, DataDeclaration ddt name args dctors') + goDecl pos (ExternDeclaration name ty) = do + ty' <- goType' pos ty + return (pos, ExternDeclaration name ty') + goDecl pos (TypeClassDeclaration name args implies decls) = do + implies' <- traverse (sndM (traverse (goType' pos))) implies + return (pos, TypeClassDeclaration name args implies' decls) + goDecl pos (TypeInstanceDeclaration name cs className tys impls) = do + cs' <- traverse (sndM (traverse (goType' pos))) cs + tys' <- traverse (goType' pos) tys + return (pos, TypeInstanceDeclaration name cs' className tys' impls) + goDecl pos (TypeSynonymDeclaration name args ty) = do + ty' <- goType' pos ty + return (pos, TypeSynonymDeclaration name args ty') + goDecl pos (TypeDeclaration expr ty) = do + ty' <- goType' pos ty + return (pos, TypeDeclaration expr ty') + goDecl pos other = return (pos, other) + + goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) + goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) + goExpr pos (TypeClassDictionary (name, tys) dicts) = do + tys' <- traverse (goType' pos) tys + return (pos, TypeClassDictionary (name, tys') dicts) + goExpr pos (SuperClassDictionary cls tys) = do + tys' <- traverse (goType' pos) tys + return (pos, SuperClassDictionary cls tys') + goExpr pos (TypedValue check v ty) = do + ty' <- goType' pos ty + return (pos, TypedValue check v ty') + goExpr pos other = return (pos, other) diff --git a/src/Language/PureScript/Sugar/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs index fc6fbf7b64..b0955697af 100644 --- a/src/Language/PureScript/Sugar/Operators/Binders.hs +++ b/src/Language/PureScript/Sugar/Operators/Binders.hs @@ -1,43 +1,27 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Language.PureScript.Sugar.Operators.Binders where import Prelude () import Prelude.Compat -import Control.Monad.Error.Class (MonadError(..)) - -import qualified Text.Parsec as P -import qualified Text.Parsec.Expr as P - -import Language.PureScript.Crash import Language.PureScript.AST -import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Sugar.Operators.Common -matchBinderOperators - :: forall m - . MonadError MultipleErrors m - => [[(Qualified Ident, Associativity)]] - -> Binder - -> m Binder -matchBinderOperators ops = parseChains +matchBinderOperators :: [[(Qualified Ident, Associativity)]] -> Binder -> Binder +matchBinderOperators = matchOperators isBinOp extractOp fromOp reapply id where - parseChains :: Binder -> m Binder - parseChains b@BinaryNoParensBinder{} = bracketChain (extendChain b) - parseChains other = return other - extendChain :: Binder -> Chain Binder - extendChain (BinaryNoParensBinder op l r) = Left l : Right op : extendChain r - extendChain other = [Left other] - bracketChain :: Chain Binder -> m Binder - bracketChain = - either - (\_ -> internalError "matchBinderOperators: cannot reorder operators") - return - . P.parse opParser "operator expression" - opParser = P.buildExpressionParser (opTable ops fromOp reapply) parseValue <* P.eof + + isBinOp :: Binder -> Bool + isBinOp BinaryNoParensBinder{} = True + isBinOp _ = False + + extractOp :: Binder -> Maybe (Binder, Binder, Binder) + extractOp (BinaryNoParensBinder op l r) = Just (op, l, r) + extractOp _ = Nothing + + fromOp :: Binder -> Maybe (Qualified Ident) fromOp (OpBinder q@(Qualified _ (Op _))) = Just q fromOp _ = Nothing + + reapply :: Qualified Ident -> Binder -> Binder -> Binder reapply = BinaryNoParensBinder . OpBinder diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index a447ab6d9a..6e56810b13 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} module Language.PureScript.Sugar.Operators.Common where @@ -15,6 +16,7 @@ import qualified Text.Parsec.Pos as P import qualified Text.Parsec.Expr as P import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Names type Chain a = [Either a a] @@ -51,3 +53,32 @@ opTable opTable ops fromOp reapply = map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >> return (reapply name)) (toAssoc a))) ops ++ [[ P.Infix (P.try (parseOp fromOp >>= \ident -> return (reapply ident))) P.AssocLeft ]] + +matchOperators + :: forall a + . Show a + => (a -> Bool) + -> (a -> Maybe (a, a, a)) + -> (a -> Maybe (Qualified Ident)) + -> (Qualified Ident -> a -> a -> a) + -> ([[P.Operator (Chain a) () Identity a]] -> P.OperatorTable (Chain a) () Identity a) + -> [[(Qualified Ident, Associativity)]] + -> a + -> a +matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains + where + parseChains :: a -> a + parseChains ty + | True <- isBinOp ty = bracketChain (extendChain ty) + | otherwise = ty + extendChain :: a -> Chain a + extendChain ty + | Just (op, l, r) <- extractOp ty = Left l : Right op : extendChain r + | otherwise = [Left ty] + bracketChain :: Chain a -> a + bracketChain = + either + (\_ -> internalError "matchTypeOperators: cannot reorder operators") + id + . P.parse opParser "operator expression" + opParser = P.buildExpressionParser (modOpTable (opTable ops fromOp reapply)) parseValue <* P.eof diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index 7ffafdf775..71fbefdf1a 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -6,47 +6,43 @@ module Language.PureScript.Sugar.Operators.Expr where import Prelude () import Prelude.Compat -import Control.Monad.Error.Class (MonadError(..)) +import Data.Functor.Identity import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P -import Language.PureScript.Crash import Language.PureScript.AST -import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Sugar.Operators.Common -matchExprOperators - :: forall m - . MonadError MultipleErrors m - => [[(Qualified Ident, Associativity)]] - -> Expr - -> m Expr -matchExprOperators ops = parseChains +matchExprOperators :: [[(Qualified Ident, Associativity)]] -> Expr -> Expr +matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable where - parseChains :: Expr -> m Expr - parseChains b@BinaryNoParens{} = bracketChain (extendChain b) - parseChains other = return other - extendChain :: Expr -> Chain Expr - extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r - extendChain other = [Left other] - bracketChain :: Chain Expr -> m Expr - bracketChain = - either - (\_ -> internalError "matchExprOperators: cannot reorder operators") - return - . P.parse opParser "operator expression" - opParser = P.buildExpressionParser opTable' parseValue <* P.eof - opTable' = - [ P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft ] - : opTable ops fromOp reapply + + isBinOp :: Expr -> Bool + isBinOp BinaryNoParens{} = True + isBinOp _ = False + + extractOp :: Expr -> Maybe (Expr, Expr, Expr) + extractOp (BinaryNoParens op l r) = Just (op, l, r) + extractOp _ = Nothing + + fromOp :: Expr -> Maybe (Qualified Ident) fromOp (Var q@(Qualified _ (Op _))) = Just q fromOp _ = Nothing + + reapply :: Qualified Ident -> Expr -> Expr -> Expr reapply op t1 t2 = App (App (Var op) t1) t2 -parseTicks :: P.Parsec (Chain Expr) () Expr -parseTicks = token (either (const Nothing) fromOther) P. "infix function" - where - fromOther (Var (Qualified _ (Op _))) = Nothing - fromOther v = Just v + modOpTable + :: [[P.Operator (Chain Expr) () Identity Expr]] + -> [[P.Operator (Chain Expr) () Identity Expr]] + modOpTable table = + [ P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft ] + : table + + parseTicks :: P.Parsec (Chain Expr) () Expr + parseTicks = token (either (const Nothing) fromOther) P. "infix function" + where + fromOther (Var (Qualified _ (Op _))) = Nothing + fromOther v = Just v diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs new file mode 100644 index 0000000000..35b08863a4 --- /dev/null +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -0,0 +1,28 @@ +module Language.PureScript.Sugar.Operators.Types where + +import Prelude () +import Prelude.Compat + +import Language.PureScript.AST +import Language.PureScript.Names +import Language.PureScript.Sugar.Operators.Common +import Language.PureScript.Types + +matchTypeOperators :: [[(Qualified Ident, Associativity)]] -> Type -> Type +matchTypeOperators = matchOperators isBinOp extractOp fromOp reapply id + where + + isBinOp :: Type -> Bool + isBinOp BinaryNoParensType{} = True + isBinOp _ = False + + extractOp :: Type -> Maybe (Type, Type, Type) + extractOp (BinaryNoParensType op l r) = Just (op, l, r) + extractOp _ = Nothing + + fromOp :: Type -> Maybe (Qualified Ident) + fromOp (TypeOp q@(Qualified _ (Op _))) = Just q + fromOp _ = Nothing + + reapply :: Qualified Ident -> Type -> Type -> Type + reapply = BinaryNoParensType . TypeOp diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index e62ecba510..8ac2395a02 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -277,15 +277,16 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d checkFixities :: Declaration -> m () - checkFixities (FixityDeclaration _ name (Just (Left alias))) = do - ty <- lookupVariable moduleName alias + checkFixities (FixityDeclaration _ name (Just (Qualified mn' (AliasValue ident)))) = do + ty <- lookupVariable moduleName (Qualified mn' ident) addValue moduleName (Op name) ty Public - checkFixities (FixityDeclaration _ name (Just (Right alias))) = do + checkFixities (FixityDeclaration _ name (Just (Qualified mn' (AliasConstructor ctor)))) = do env <- getEnv + let alias = Qualified mn' ctor case M.lookup alias (dataConstructors env) of Nothing -> throwError . errorMessage $ UnknownDataConstructor alias Nothing Just (_, _, ty, _) -> addValue moduleName (Op name) ty Public - checkFixities (FixityDeclaration _ name _) = do + checkFixities (FixityDeclaration _ name Nothing) = do env <- getEnv guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env checkFixities (PositionedDeclaration pos _ d) = @@ -438,21 +439,18 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint checkNonAliasesAreExported :: [ProperName 'ConstructorName] -> DeclarationRef -> m () checkNonAliasesAreExported exportedDctors dr@(ValueRef (Op name)) = case listToMaybe (mapMaybe getAlias decls) of - Just (Left ident) -> + Just (AliasValue ident) -> unless (ValueRef ident `elem` exps) $ throwError . errorMessage $ TransitiveExportError dr [ValueRef ident] - Just (Right ctor) -> + Just (AliasConstructor ctor) -> unless (ctor `elem` exportedDctors) $ throwError . errorMessage $ TransitiveDctorExportError dr ctor _ -> return () where - getAlias :: Declaration -> Maybe (Either Ident (ProperName 'ConstructorName)) + getAlias :: Declaration -> Maybe FixityAlias getAlias (PositionedDeclaration _ _ d) = getAlias d - getAlias (FixityDeclaration _ name' (Just alias)) | name == name' = - case alias of - Left (Qualified (Just mn') ident) | mn == mn' -> Just (Left ident) - Right (Qualified (Just mn') ctor) | mn == mn' -> Just (Right ctor) - _ -> Nothing + getAlias (FixityDeclaration _ name' (Just (Qualified (Just mn') alias))) + | name == name' && mn == mn' = Just alias getAlias _ = Nothing checkNonAliasesAreExported _ _ = return () diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 188cf9737e..59ffa8b330 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -268,4 +268,4 @@ infer' other = (, []) <$> go other k <- go ty unifyKinds k Star return Star - go _ = internalError "Invalid argument to infer" + go ty = internalError $ "Invalid argument to infer: " ++ show ty diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index bc90c67220..8420da77c2 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -319,7 +319,7 @@ infer' (TypedValue checkType val ty) = do infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do TypedValue t v ty <- infer' val return $ TypedValue t (PositionedValue pos c v) ty -infer' _ = internalError "Invalid argument to infer" +infer' v = internalError $ "Invalid argument to infer: " ++ show v inferLetBinding :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 925095b1e3..308b6b5cd0 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -49,6 +49,11 @@ data Type -- | TypeConstructor (Qualified (ProperName 'TypeName)) -- | + -- A type operator. This will be desugared into a type constructor during the + -- "operators" phase of desugaring. + -- + | TypeOp (Qualified Ident) + -- | -- A type application -- | TypeApp Type Type @@ -89,6 +94,19 @@ data Type -- A placeholder used in pretty printing -- | PrettyPrintForAll [String] Type + -- | + -- Binary operator application. During the rebracketing phase of desugaring, + -- this data constructor will be removed. + -- + | BinaryNoParensType Type Type Type + -- | + -- Explicit parentheses. During the rebracketing phase of desugaring, this + -- data constructor will be removed. + -- + -- Note: although it seems this constructor is not used, it _is_ useful, + -- since it prevents certain traversals from matching. + -- + | ParensInType Type deriving (Show, Read, Eq, Ord) -- | @@ -154,6 +172,8 @@ replaceAllTypeVars = go [] go bs m (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs m)) cs) (go bs m t) go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r) go bs m (KindedType t k) = KindedType (go bs m t) k + go bs m (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go bs m t1) (go bs m t2) (go bs m t3) + go bs m (ParensInType t) = ParensInType (go bs m t) go _ _ ty = ty genName orig inUse = try 0 @@ -184,6 +204,8 @@ freeTypeVariables = nub . go [] go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t go bound (RCons _ t r) = go bound t ++ go bound r go bound (KindedType t _) = go bound t + go bound (BinaryNoParensType t1 t2 t3) = go bound t1 ++ go bound t2 ++ go bound t3 + go bound (ParensInType t) = go bound t go _ _ = [] -- | @@ -233,6 +255,8 @@ everywhereOnTypes f = go go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2)) go (PrettyPrintObject t) = f (PrettyPrintObject (go t)) go (PrettyPrintForAll args t) = f (PrettyPrintForAll args (go t)) + go (BinaryNoParensType t1 t2 t3) = f (BinaryNoParensType (go t1) (go t2) (go t3)) + go (ParensInType t) = f (ParensInType (go t)) go other = f other everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type @@ -246,6 +270,8 @@ everywhereOnTypesTopDown f = go . f go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2)) go (PrettyPrintObject t) = PrettyPrintObject (go (f t)) go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t)) + go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (f (go t1)) (f (go t2)) (f (go t3)) + go (ParensInType t) = ParensInType (f (go t)) go other = f other everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type @@ -259,6 +285,8 @@ everywhereOnTypesM f = go go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f + go (BinaryNoParensType t1 t2 t3) = (BinaryNoParensType <$> go t1 <*> go t2 <*> go t3) >>= f + go (ParensInType t) = (ParensInType <$> go t) >>= f go other = f other everywhereOnTypesTopDownM :: Monad m => (Type -> m Type) -> Type -> m Type @@ -272,6 +300,8 @@ everywhereOnTypesTopDownM f = go <=< f go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go) go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go) go (PrettyPrintForAll args t) = PrettyPrintForAll args <$> (f t >>= go) + go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType <$> (f t1 >>= go) <*> (f t2 >>= go) <*> (f t3 >>= go) + go (ParensInType t) = ParensInType <$> (f t >>= go) go other = f other everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r @@ -285,6 +315,8 @@ everythingOnTypes (<>) f = go go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2 go t@(PrettyPrintObject t1) = f t <> go t1 go t@(PrettyPrintForAll _ t1) = f t <> go t1 + go t@(BinaryNoParensType t1 t2 t3) = f t <> go t1 <> go t2 <> go t3 + go t@(ParensInType t1) = f t <> go t1 go other = f other everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type -> (s, r)) -> Type -> r @@ -299,4 +331,6 @@ everythingWithContextOnTypes s0 r0 (<>) f = go' s0 go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2 go s (PrettyPrintObject t1) = go' s t1 go s (PrettyPrintForAll _ t1) = go' s t1 + go s (BinaryNoParensType t1 t2 t3) = go' s t1 <> go' s t2 <> go' s t3 + go s (ParensInType t1) = go' s t1 go _ _ = r0 diff --git a/tests/Main.hs b/tests/Main.hs index 152cd44e56..06c08ac486 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -27,8 +27,13 @@ import qualified TestDocs import qualified TestPsci import qualified TestPscIde +import System.IO (hSetEncoding, stdout, stderr, utf8) + main :: IO () main = do + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + heading "Main compiler test suite" TestCompiler.main heading "Documentation test suite" diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 1af8bd4567..79c1fc48c8 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -285,12 +285,12 @@ testCases = , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==)) ]) - , ("ConstrainedArgument", - [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a" - , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a" - , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a" - , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a" - ]) + --, ("ConstrainedArgument", + -- [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a" + -- , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a" + -- , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a" + -- , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a" + -- ]) ] where From 0a67e5b88d409b890481cf6ac94da0cb364114f2 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 16 Apr 2016 16:06:20 +0100 Subject: [PATCH 0368/1580] Wildcards for case and if Resolves #1558 --- examples/passing/CaseInputWildcard.purs | 18 +++++++++++ examples/passing/IfWildcard.purs | 19 ++++++++++++ .../PureScript/Sugar/ObjectWildcards.hs | 31 ++++++++++++++----- 3 files changed, 61 insertions(+), 7 deletions(-) create mode 100644 examples/passing/CaseInputWildcard.purs create mode 100644 examples/passing/IfWildcard.purs diff --git a/examples/passing/CaseInputWildcard.purs b/examples/passing/CaseInputWildcard.purs new file mode 100644 index 0000000000..6448939b9a --- /dev/null +++ b/examples/passing/CaseInputWildcard.purs @@ -0,0 +1,18 @@ +module Main where + +import Prelude +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (log, CONSOLE) + +data Foo = X | Y + +what ∷ Foo → Int → Boolean → Foo +what x = case _, x, _ of + 0, X, true → X + 0, Y, true → X + _, _, _ → Y + +main :: forall e. Eff (console :: CONSOLE | e) Unit +main = do + let tmp = what Y 0 true + log "Done" diff --git a/examples/passing/IfWildcard.purs b/examples/passing/IfWildcard.purs new file mode 100644 index 0000000000..dd7d1546f2 --- /dev/null +++ b/examples/passing/IfWildcard.purs @@ -0,0 +1,19 @@ +module Main where + +import Prelude +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (log, CONSOLE) + +data Foo = X | Y + +cond ∷ ∀ a. Boolean → a → a → a +cond = if _ then _ else _ + +what ∷ Boolean → Foo +what = if _ then X else Y + +main :: forall e. Eff (console :: CONSOLE | e) Unit +main = do + let tmp1 = what true + tmp2 = cond true 0 1 + log "Done" diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 61a4d05347..a6677a831d 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -9,6 +9,7 @@ module Language.PureScript.Sugar.ObjectWildcards ( import Prelude () import Prelude.Compat +import Control.Monad (forM) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class @@ -45,11 +46,21 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do obj <- freshIdent' - Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps + Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps desugarExpr (Accessor prop u) | isAnonymousArgument u = do arg <- freshIdent' - return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg))) + return $ Abs (Left arg) (Accessor prop (argToExpr arg)) + desugarExpr (Case args cas) | any isAnonymousArgument args = do + argIdents <- forM args freshIfAnon + let args' = zipWith (\p -> maybe p argToExpr) args argIdents + return $ foldr (Abs . Left) (Case args' cas) (catMaybes argIdents) + desugarExpr (IfThenElse u t f) | any isAnonymousArgument [u, t, f] = do + u' <- freshIfAnon u + t' <- freshIfAnon t + f' <- freshIfAnon f + let if_ = IfThenElse (maybe u argToExpr u') (maybe t argToExpr t') (maybe f argToExpr f') + return $ foldr (Abs . Left) if_ (catMaybes [u', t', f']) desugarExpr e = return e wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr @@ -71,8 +82,14 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma isAnonymousArgument _ = False mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr)) - mkProp (name, e) - | isAnonymousArgument e = do - arg <- freshIdent' - return (Just arg, (name, Var (Qualified Nothing arg))) - | otherwise = return (Nothing, (name, e)) + mkProp (name, e) = do + arg <- freshIfAnon e + return (arg, (name, maybe e argToExpr arg)) + + freshIfAnon :: Expr -> m (Maybe Ident) + freshIfAnon u + | isAnonymousArgument u = Just <$> freshIdent' + | otherwise = return Nothing + + argToExpr :: Ident -> Expr + argToExpr = Var . Qualified Nothing From 1292c34d9969de8abf7ffec5d2a59dc3a94b7d17 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 16 Apr 2016 16:54:49 +0100 Subject: [PATCH 0369/1580] Don't warn for a single hiding import Resolves #2017 --- src/Language/PureScript/Ide/Imports.hs | 4 ++-- src/Language/PureScript/Linter/Imports.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 8fe4dcfc39..c02fb992d6 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -76,8 +76,8 @@ compImport (Import n i q) (Import n' i' q') | compImportType i i' /= EQ = compImportType i i' -- This means that for a stable sort, the first implicit import will stay -- the first implicit import - | P.isImplicit i && isNothing q = LT - | P.isImplicit i && isNothing q' = GT + | not (P.isExplicit i) && isNothing q = LT + | not (P.isExplicit i) && isNothing q' = GT | otherwise = compare n n' -- | Reads a file and returns the (lines before the imports, the imports, the diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 4c094fe574..5e36597fa8 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -190,7 +190,7 @@ lintImportDecl env mni qualifierName names declType allowImplicit = Just q -> let usedModuleNames = mapMaybe extractQualName names in unless (q `elem` usedModuleNames) unused - Hiding _ -> checkImplicit HidingImport + Hiding _ -> unless allowImplicit (checkImplicit HidingImport) Explicit [] -> unused Explicit declrefs -> checkExplicit declrefs From 9a6bcb34260bd86e005d368e8bf10ed007737640 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 16 Apr 2016 17:24:44 +0100 Subject: [PATCH 0370/1580] Fix cycles being detected with qualified imports Resolves #2018 --- examples/passing/2018.purs | 25 ++++++++ src/Language/PureScript/ModuleDependencies.hs | 61 +++++++++++-------- 2 files changed, 62 insertions(+), 24 deletions(-) create mode 100644 examples/passing/2018.purs diff --git a/examples/passing/2018.purs b/examples/passing/2018.purs new file mode 100644 index 0000000000..2a0eef6980 --- /dev/null +++ b/examples/passing/2018.purs @@ -0,0 +1,25 @@ +module B where + + data Foo = X | Y + +module A where + + import B as Main + + -- Prior to the 2018 fix this would be detected as a cycle between A and Main. + foo ∷ Main.Foo → Main.Foo + foo x = x + +module Main where + +import Prelude +import A (foo) +import B (Foo(..)) +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) + +main :: forall e. Eff (console :: CONSOLE | e) Unit +main = do + let tmp = foo X + log "Done" + diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index b1f3e845f7..39296fed21 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -1,19 +1,8 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.ModuleDependencies --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | Provides the ability to sort modules based on module dependencies --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleContexts #-} +-- | +-- Provides the ability to sort modules based on module dependencies +-- module Language.PureScript.ModuleDependencies ( sortModules, ModuleGraph @@ -40,7 +29,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])] -- sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph) sortModules ms = do - let verts = map (\m@(Module _ _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms + let verts = map goModule ms ms' <- mapM toModule $ stronglyConnComp verts let (graph, fromVertex, toVertex) = graphFromEdges verts moduleGraph = do (_, mn, _) <- verts @@ -49,29 +38,53 @@ sortModules ms = do toKey i = case fromVertex i of (_, key, _) -> key return (mn, filter (/= mn) (map toKey deps)) return (ms', moduleGraph) + where + goModule :: Module -> (Module, ModuleName, [ModuleName]) + goModule m@(Module _ _ _ ds _) = + let ams = concatMap extractQualAs ds + in (m, getModuleName m, nub (concatMap (usedModules ams) ds)) + + -- Extract module names that have been brought into scope by an `as` import. + extractQualAs :: Declaration -> [ModuleName] + extractQualAs (PositionedDeclaration _ _ d) = extractQualAs d + extractQualAs (ImportDeclaration _ _ (Just am) _) = [am] + extractQualAs _ = [] -- | --- Calculate a list of used modules based on explicit imports and qualified names +-- Calculate a list of used modules based on explicit imports and qualified +-- names. `ams` is a list of `ModuleNames` that refer to names brought into +-- scope by importing with `as` - this ensures that when building the list we +-- don't inadvertantly assume a dependency on an actual module, if there is a +-- module that has the same name as the qualified import. -- -usedModules :: Declaration -> [ModuleName] -usedModules d = +usedModules :: [ModuleName] -> Declaration -> [ModuleName] +usedModules ams d = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) (g, _, _, _, _) = accumTypes (everythingOnTypes (++) forTypes) in nub (f d ++ g d) where + forDecls :: Declaration -> [ModuleName] - forDecls (ImportDeclaration mn _ _ _) = [mn] - forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn] - forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn] + forDecls (ImportDeclaration mn _ _ _) = + -- Regardless of whether an imported module is qualified we still need to + -- take into account its import to build an accurate list of dependencies. + [mn] + forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _))) + | mn `notElem` ams = [mn] + forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) + | mn `notElem` ams = [mn] forDecls _ = [] forValues :: Expr -> [ModuleName] - forValues (Var (Qualified (Just mn) _)) = [mn] - forValues (Constructor (Qualified (Just mn) _)) = [mn] + forValues (Var (Qualified (Just mn) _)) + | mn `notElem` ams = [mn] + forValues (Constructor (Qualified (Just mn) _)) + | mn `notElem` ams = [mn] forValues _ = [] forTypes :: Type -> [ModuleName] - forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn] + forTypes (TypeConstructor (Qualified (Just mn) _)) + | mn `notElem` ams = [mn] forTypes _ = [] -- | From 8bab5090ce3559d89c10c34e240356a5b371a489 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 17 Apr 2016 00:13:06 +0200 Subject: [PATCH 0371/1580] #1712, fast recompilation in psc-ide-server (#2013) * Initial work on #1712, Fast recompilation by keeping externs files in memory, in psc-ide-server * moves rebuild into its own module * adds a parameter to specify a path for the js Also uses the configured output directory over "output" * sort externfiles before creating the initial Environment * return JSON errors in case of a build failure * fix merge conflicts with master * initial RebuildTests * return warnings in case of a successful rebuild * Refactor to reuse code from Make module * Add TODO item * report errors back in case rebuilding fails * adds the Prim import back in before rebuilding * first stab at gather transitive dependencies * recurse when finding transitive dependencies * use the graph result from sorting the modules Crazy speedups O.o * looks up foreign files adds testfiles to cabal adds tests * silence progress messages --- psc-ide-server/Main.hs | 2 +- psc-ide-server/PROTOCOL.md | 24 +++++++ psc/Main.hs | 3 +- purescript.cabal | 7 +- .../Language/PureScript/Errors}/JSON.hs | 14 ++-- src/Language/PureScript/Ide.hs | 5 +- src/Language/PureScript/Ide/Command.hs | 6 +- src/Language/PureScript/Ide/Error.hs | 18 +++-- src/Language/PureScript/Ide/Rebuild.hs | Bin 0 -> 3532 bytes src/Language/PureScript/Ide/State.hs | 4 ++ src/Language/PureScript/Ide/Types.hs | 3 + src/Language/PureScript/Make.hs | 41 +++++++----- tests/Language/PureScript/Ide/Integration.hs | 14 ++++ tests/Language/PureScript/Ide/RebuildSpec.hs | 62 ++++++++++++++++++ tests/support/pscide/src/RebuildSpecDep.purs | 3 + .../pscide/src/RebuildSpecSingleModule.fail | 3 + .../pscide/src/RebuildSpecSingleModule.purs | 4 ++ .../pscide/src/RebuildSpecWithDeps.purs | 5 ++ .../pscide/src/RebuildSpecWithForeign.js | 3 + .../pscide/src/RebuildSpecWithForeign.purs | 3 + .../src/RebuildSpecWithMissingForeign.fail | 3 + 21 files changed, 191 insertions(+), 36 deletions(-) rename {psc => src/Language/PureScript/Errors}/JSON.hs (89%) create mode 100644 src/Language/PureScript/Ide/Rebuild.hs create mode 100644 tests/Language/PureScript/Ide/RebuildSpec.hs create mode 100644 tests/support/pscide/src/RebuildSpecDep.purs create mode 100644 tests/support/pscide/src/RebuildSpecSingleModule.fail create mode 100644 tests/support/pscide/src/RebuildSpecSingleModule.purs create mode 100644 tests/support/pscide/src/RebuildSpecWithDeps.purs create mode 100644 tests/support/pscide/src/RebuildSpecWithForeign.js create mode 100644 tests/support/pscide/src/RebuildSpecWithForeign.purs create mode 100644 tests/support/pscide/src/RebuildSpecWithMissingForeign.fail diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 896b135d40..169b2396da 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -125,7 +125,7 @@ startServer port env = withSocketsDo $ do case decodeT cmd of Just cmd' -> do result <- runExceptT (handleCommand cmd') - $(logDebug) ("Answer was: " <> T.pack (show result)) + -- $(logDebug) ("Answer was: " <> T.pack (show result)) liftIO (hFlush stdout) case result of -- What function can I use to clean this up? diff --git a/psc-ide-server/PROTOCOL.md b/psc-ide-server/PROTOCOL.md index 820b125fa6..ca2bdc5d38 100644 --- a/psc-ide-server/PROTOCOL.md +++ b/psc-ide-server/PROTOCOL.md @@ -240,6 +240,30 @@ Example: } ``` +### Rebuild + +The `rebuild` command provides a fast rebuild for a single module. It doesn't +recompile the entire project though. All the modules dependencies need to be +loaded. + +Arguments: +- `file :: String` the path to the module to rebuild + +```json +{ + "command": "rebuild", + "params": { + "file": "/path/to/file.purs" + } +} +``` + +**Result** + +In the Success case you get a list of warnings in the compilers json format. + +In the Error case you get the errors in the compilers json format + ### Pursuit The `pursuit` command looks up the packages/completions for a given identifier from Pursuit. diff --git a/psc/Main.hs b/psc/Main.hs index 72e364b82a..91a6f45a0e 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -28,8 +28,7 @@ import qualified Language.PureScript as P import qualified Paths_purescript as Paths import Language.PureScript.Make - -import JSON +import Language.PureScript.Errors.JSON data PSCMakeOptions = PSCMakeOptions { pscmInput :: [FilePath] diff --git a/purescript.cabal b/purescript.cabal index 372e69bba2..6c74531600 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -37,6 +37,8 @@ extra-source-files: examples/passing/*.purs , tests/support/flattened/*.js , tests/support/psci/*.purs , tests/support/pscide/src/*.purs + , tests/support/pscide/src/*.js + , tests/support/pscide/src/*.fail , stack.yaml , stack-lts-5.yaml , stack-nightly.yaml @@ -127,6 +129,7 @@ library Language.PureScript.Comments Language.PureScript.Environment Language.PureScript.Errors + Language.PureScript.Errors.JSON Language.PureScript.Kinds Language.PureScript.Linter Language.PureScript.Linter.Exhaustive @@ -215,6 +218,7 @@ library Language.PureScript.Ide.Reexports Language.PureScript.Ide.Imports Language.PureScript.Ide.Util + Language.PureScript.Ide.Rebuild Control.Monad.Logger Control.Monad.Supply @@ -238,7 +242,7 @@ executable psc main-is: Main.hs buildable: True hs-source-dirs: psc - other-modules: JSON, Paths_purescript + other-modules: Paths_purescript ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N" executable psci @@ -370,6 +374,7 @@ test-suite tests Language.PureScript.Ide.Imports.IntegrationSpec Language.PureScript.Ide.Integration Language.PureScript.Ide.MatcherSpec + Language.PureScript.Ide.RebuildSpec Language.PureScript.Ide.ReexportsSpec Language.PureScript.IdeSpec PSCi.Completion diff --git a/psc/JSON.hs b/src/Language/PureScript/Errors/JSON.hs similarity index 89% rename from psc/JSON.hs rename to src/Language/PureScript/Errors/JSON.hs index c6fb051685..a36f8e2603 100644 --- a/psc/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- --- Module : Main +-- Module : Language.PureScript.Errors.JSON -- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess -- License : MIT (http://opensource.org/licenses/MIT) -- @@ -14,7 +14,7 @@ {-# LANGUAGE TemplateHaskell #-} -module JSON where +module Language.PureScript.Errors.JSON where import Prelude () import Prelude.Compat @@ -28,9 +28,9 @@ data ErrorPosition = ErrorPosition , startColumn :: Int , endLine :: Int , endColumn :: Int - } + } deriving (Show, Eq, Ord) -data ErrorSuggestion = ErrorSuggestion { replacement :: String } +data ErrorSuggestion = ErrorSuggestion { replacement :: String } deriving (Show, Eq) data JSONError = JSONError { position :: Maybe ErrorPosition @@ -40,12 +40,12 @@ data JSONError = JSONError , filename :: Maybe String , moduleName :: Maybe String , suggestion :: Maybe ErrorSuggestion - } + } deriving (Show, Eq) data JSONResult = JSONResult { warnings :: [JSONError] , errors :: [JSONError] - } + } deriving (Show, Eq) $(A.deriveJSON A.defaultOptions ''ErrorPosition) $(A.deriveJSON A.defaultOptions ''JSONError) @@ -64,7 +64,7 @@ toJSONError verbose level e = (P.wikiUri e) (P.spanName <$> sspan) (P.runModuleName <$> P.errorModule e) - (toSuggestion <$> (P.errorSuggestion $ P.unwrapErrorMessage e)) + (toSuggestion <$> P.errorSuggestion (P.unwrapErrorMessage e)) where sspan :: Maybe P.SourceSpan sspan = P.errorSpan e diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 21840a2080..cae4e8b6ec 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -53,11 +53,11 @@ import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import Language.PureScript.Ide.Rebuild import System.Directory import System.FilePath import System.Exit - handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => Command -> m Success handleCommand (Load [] []) = loadAllModules @@ -89,6 +89,8 @@ handleCommand (Import fp outfp filters (AddImportForIdentifier ident)) = do case rs of Right rs' -> answerRequest outfp rs' Left question -> pure $ CompletionResult (mapMaybe completionFromMatch question) +handleCommand (Rebuild file) = + rebuildFile file handleCommand Cwd = TextResult . T.pack <$> liftIO getCurrentDirectory handleCommand Quit = liftIO exitSuccess @@ -238,4 +240,3 @@ filePathFromModule moduleName = do if ex then pure path else throwError (ModuleFileNotFound moduleName) - diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index dbec3f1fe3..3fd90caba5 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -63,6 +63,7 @@ data Command -- Import InputFile OutputFile | Import FilePath (Maybe FilePath) [Filter] ImportCommand | List { listType :: ListType } + | Rebuild FilePath -- ^ Rebuild the specified file using the loaded externs | Cwd | Quit @@ -149,5 +150,8 @@ instance FromJSON Command where filters <- params .:? "filters" importCommand <- params .: "importCommand" pure $ Import fp out (fromMaybe [] filters) importCommand + "rebuild" -> do + params <- o .: "params" + filePath <- params .: "file" + return $ Rebuild filePath _ -> mzero - diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 37cccb39ee..eba509f829 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -20,6 +20,7 @@ module Language.PureScript.Ide.Error import Data.Aeson import Data.Monoid import Data.Text (Text, pack) +import Language.PureScript.Errors.JSON import Language.PureScript.Ide.Types (ModuleIdent) import qualified Text.Parsec.Error as P @@ -31,9 +32,13 @@ data PscIdeError | ModuleNotFound ModuleIdent | ModuleFileNotFound ModuleIdent | ParseError P.ParseError ErrorMsg - deriving (Show, Eq) + | RebuildError [JSONError] instance ToJSON PscIdeError where + toJSON (RebuildError errs) = object + [ "resultType" .= ("error" :: Text) + , "result" .= errs + ] toJSON err = object [ "resultType" .= ("error" :: Text) , "result" .= textError err @@ -44,8 +49,9 @@ textError (GeneralError msg) = pack msg textError (NotFound ident) = "Symbol '" <> ident <> "' not found." textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found." textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found" -textError (ParseError parseError msg) = pack $ msg <> ": " <> show (escape parseError) - where - -- escape newlines and other special chars so we can send the error over the socket as a single line - escape :: P.ParseError -> String - escape = show +textError (ParseError parseError msg) = let escape = show + -- escape newlines and other special + -- chars so we can send the error + -- over the socket as a single line + in pack $ msg <> ": " <> show (escape parseError) +textError (RebuildError err) = pack (show err) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs new file mode 100644 index 0000000000000000000000000000000000000000..007d8e92f3a599951dd190dce3eeaef2b4f5e9c8 GIT binary patch literal 3532 zcma)9+fL(15Z&i|MJa={js*PyBS1m}jF=_FBCO^Cp{21ai5K6dyFDa}=HK^Jx1E>} zVEhuhyKY@|>Qv|X;1gY*Tz&ofgN&Pw-JR;HH1^XcH%;JGh$p7Sz$$Qj~} zm#&q2B{ptym&MxX;$~Izmt0%RmR^ZXezM6copL&LCM)N`+$*tICy#p07e!r}&LzFJ zcFjp;((hTGe$nRbBiuA~&QnfYh9kG<4Aurkl{Pukr7q_U9ICi6JWWhiJ9Uw=y5@%l z*6C@%h6jVp$FsITZ|a>HQ<>ivpE~XM_r)c{c1JW)B2(pRT$MUiJ_hA0@!IrD(TmAj za>GJw9pu$~&Sof>>3O*Hs~;J^W|Z5!<=~~o8>36B&Xx(+uCx22(Rnt@IHgnVv>NML zUF!cei^!T0QV)t^XFyOjUeqtlOtT*JBOAQDB>4T)OnV3tlfel!*#9`K7(dy z(JSjTY(i^wPBVjcs?3U_v|=kJ&X$>Vqrt$0mXW0a(dW+;#Wq1NQL#@Rm;p8GPY+WH zGU2@#LGkFAy1?*ta7+bFng@c29V0ix^Z-PK){Q;n9v>>U{B0=IT0yj zJJA;5=$dSq(&64Q#j4iE^4ODsJqI2{$x@cmZ6q%CgYD5BRWn#=pG%%OScYZ@{NQ-A zN8}c!dI}qgzH-S%=izft92$0R6@vqvr%o`G-?VhDbA-1syRmtl%@>Yti#y3j4W^=E zd-EUJde8GP&RLG1@+>Qvc&QVYuc*R%;6gQ&Jb~#wdXOy(3KmERmbX*~Bk<>?z{%C%9mi%^RbIsC{9yeH4AT zqgiD*o0q{IO1=%&0EOYdb_j)5*kjW65b+YNomj95>;_MThWS`|<{#@vK4}NX)+r$U z-V=?L#ehTTILoe7MIJtJH)BrnC%v*G!Tx(sl+C)Z!|6Vdhb_0@5>I&RhN0INIXf&cl_h(YnnrYb*B)HSi zckOGiuEk)`>vLG%LEIs*T}<621bU#KvCL>Bu9qYP9vDO@AxIU3%=K39`T>Awco}$| zJOOd~r+@`;2$zE!5K*ioxyT5`?zET7^YEc!>ynZA4!z zx1{civ(2E<3+f);$W0Jgv!p3mB^WJPDIEqvt+`COOft5^&=R3GQSh=)bEE6UNHT-O%89|%Ycjj{IoYP`5SN4+ zuD24>cHUl;=vk>>bkut9>PrnyEwco(@{V}ct2)|GD$%wL&)Vz!h^{KP00DSQ>wUCU z3x`&rC@FK4{lHXN`wUyBoaFec;m1TL73QWFTn`|^<`F92W)xq(_CVB+0g$?!AB@TcuQC8mNI@P{$kap4t`m1Uu*e literal 0 HcmV?d00001 diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index b649fe8c77..12516b189a 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -51,6 +51,10 @@ getExternFiles = do stateVar <- envStateVar <$> ask liftIO (externsFiles <$> readTVarIO stateVar) +getExternFile :: (PscIde m) => + ModuleName -> m (Maybe ExternsFile) +getExternFile mn = M.lookup mn <$> getExternFiles + getAllDecls :: (PscIde m) => m [ExternDecl] getAllDecls = concat <$> getPscIdeState diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 54e2fc5d2d..1f6d02b64e 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -33,6 +33,7 @@ import Data.Maybe (maybeToList) import Data.Text (Text (), pack, unpack) import qualified Language.PureScript.AST.Declarations as D import Language.PureScript.Externs +import qualified Language.PureScript.Errors.JSON as P import qualified Language.PureScript.Names as N import qualified Language.PureScript as P @@ -144,6 +145,7 @@ data Success = | PursuitResult [PursuitResponse] | ImportList [ModuleImport] | ModuleList [ModuleIdent] + | RebuildSuccess [P.JSONError] deriving(Show, Eq) encodeSuccess :: (ToJSON a) => a -> Value @@ -157,6 +159,7 @@ instance ToJSON Success where toJSON (PursuitResult resp) = encodeSuccess resp toJSON (ImportList decls) = encodeSuccess decls toJSON (ModuleList modules) = encodeSuccess modules + toJSON (RebuildSuccess modules) = encodeSuccess modules newtype PursuitQuery = PursuitQuery Text deriving (Show, Eq) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 9ea9aac547..b0c1ccd6ac 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -14,6 +14,7 @@ module Language.PureScript.Make , ProgressMessage(..), renderProgressMessage , MakeActions(..) , Externs() + , rebuildModule , make -- * Implementation of Make API using files on disk @@ -147,6 +148,28 @@ data RebuildPolicy -- | Always rebuild this module | RebuildAlways deriving (Show, Read, Eq, Ord) +-- | Rebuild a single module +rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => MakeActions m + -> [ExternsFile] + -> Module + -> m ExternsFile +rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do + progress $ CompilingModule moduleName + let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs + lint m + ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do + [desugared] <- desugar externs [m] + runCheck' env $ typeCheckModule desugared + checkExhaustiveModule env' checked + regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated + let mod' = Module ss coms moduleName regrouped exps + corefn = CF.moduleToCoreFn env' mod' + [renamed] = renameInModules [corefn] + exts = moduleToExternsFile mod' env' + evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts + return exts + -- | -- Compiles in "make" mode, compiling each module separately to a js files and an externs file -- @@ -157,7 +180,7 @@ make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadE => MakeActions m -> [Module] -> m Environment -make MakeActions{..} ms = do +make ma@MakeActions{..} ms = do requirePath <- asks optionsRequirePath when (isJust requirePath) $ tell $ errorMessage DeprecatedRequirePath @@ -221,21 +244,7 @@ make MakeActions{..} ms = do _ -> True let rebuild = do - (exts, warnings) <- listen $ do - progress $ CompilingModule moduleName - let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs - lint m - ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do - [desugared] <- desugar externs [m] - runCheck' env $ typeCheckModule desugared - checkExhaustiveModule env' checked - regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated - let mod' = Module ss coms moduleName regrouped exps - corefn = CF.moduleToCoreFn env' mod' - [renamed] = renameInModules [corefn] - exts = moduleToExternsFile mod' env' - evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts - return exts + (exts, warnings) <- listen $ rebuildModule ma externs m markComplete (Just (warnings, exts)) Nothing if shouldRebuild diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs index 7a57662247..cea69fdf77 100644 --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -27,11 +27,13 @@ module Language.PureScript.Ide.Integration , projectDirectory , deleteFileIfExists -- sending commands + , loadModule , loadModuleWithDeps , getFlexCompletions , getType , addImport , addImplicitImport + , rebuildModule -- checking results , resultIsSuccess , parseCompletions @@ -131,6 +133,9 @@ quitServer = do loadModuleWithDeps :: String -> IO String loadModuleWithDeps m = sendCommand $ load [] [m] +loadModule :: String -> IO String +loadModule m = sendCommand $ load [m] [] + getFlexCompletions :: String -> IO [(String, String, String)] getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q))) @@ -143,6 +148,9 @@ addImport identifier fp outfp = sendCommand (addImportC identifier fp outfp) addImplicitImport :: String -> FilePath -> FilePath -> IO String addImplicitImport mn fp outfp = sendCommand (addImplicitImportC mn fp outfp) +rebuildModule :: FilePath -> IO String +rebuildModule m = sendCommand (rebuildC m Nothing) + -- Command Encoding commandWrapper :: String -> Value -> Value @@ -166,6 +174,12 @@ addImplicitImportC mn = addImportW $ , "module" .= mn ] +rebuildC :: FilePath -> Maybe FilePath -> Value +rebuildC file outFile = + commandWrapper "rebuild" (object [ "file" .= file + , "outfile" .= outFile + ]) + addImportW :: Value -> FilePath -> FilePath -> Value addImportW importCommand fp outfp = commandWrapper "import" (object [ "file" .= fp diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs new file mode 100644 index 0000000000..f7370afe3f --- /dev/null +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -0,0 +1,62 @@ +module Language.PureScript.Ide.RebuildSpec where + +import Control.Monad +import qualified Language.PureScript.Ide.Integration as Integration +import Test.Hspec + +import System.FilePath + +compile :: IO () +compile = do + Integration.deleteOutputFolder + s <- Integration.compileTestProject + unless s $ fail "Failed to compile .purs sources" + +teardown :: IO () +teardown = Integration.quitServer + +restart :: IO () +restart = Integration.quitServer *> (void Integration.startServer) + +shouldBeSuccess :: String -> IO () +shouldBeSuccess = shouldBe True . Integration.resultIsSuccess + +shouldBeFailure :: String -> IO () +shouldBeFailure = shouldBe False . Integration.resultIsSuccess + +spec :: Spec +spec = beforeAll_ compile $ afterAll_ teardown $ before_ restart $ do + describe "Rebuilding single modules" $ do + it "rebuilds a correct module without dependencies successfully" $ do + _ <- Integration.loadModuleWithDeps "RebuildSpecSingleModule" + pdir <- Integration.projectDirectory + let file = pdir "src" "RebuildSpecSingleModule.purs" + Integration.rebuildModule file >>= shouldBeSuccess + it "fails to rebuild an incorrect module without dependencies and returns the errors" $ do + pdir <- Integration.projectDirectory + let file = pdir "src" "RebuildSpecSingleModule.fail" + Integration.rebuildModule file >>= shouldBeFailure + it "rebuilds a correct module with its dependencies successfully" $ do + _ <- Integration.loadModuleWithDeps "RebuildSpecWithDeps" + pdir <- Integration.projectDirectory + let file = pdir "src" "RebuildSpecWithDeps.purs" + Integration.rebuildModule file >>= shouldBeSuccess + it "rebuilds a correct module that has reverse dependencies" $ do + _ <- Integration.loadModuleWithDeps "RebuildSpecWithDeps" + pdir <- Integration.projectDirectory + let file = pdir "src" "RebuildSpecDep.purs" + Integration.rebuildModule file >>= shouldBeSuccess + it "fails to rebuild a module if its dependencies are not loaded" $ do + _ <- Integration.loadModule "RebuildSpecWithDeps" + pdir <- Integration.projectDirectory + let file = pdir "src" "RebuildSpecWithDeps.purs" + Integration.rebuildModule file >>= shouldBeFailure + it "rebuilds a correct module with a foreign file" $ do + _ <- Integration.loadModuleWithDeps "RebuildSpecWithForeign" + pdir <- Integration.projectDirectory + let file = pdir "src" "RebuildSpecWithForeign.purs" + Integration.rebuildModule file >>= shouldBeSuccess + it "fails to rebuild a module with a foreign import but no file" $ do + pdir <- Integration.projectDirectory + let file = pdir "src" "RebuildSpecWithMissingForeign.fail" + Integration.rebuildModule file >>= shouldBeFailure diff --git a/tests/support/pscide/src/RebuildSpecDep.purs b/tests/support/pscide/src/RebuildSpecDep.purs new file mode 100644 index 0000000000..afd29a8933 --- /dev/null +++ b/tests/support/pscide/src/RebuildSpecDep.purs @@ -0,0 +1,3 @@ +module RebuildSpecDep where + +dep = 42 diff --git a/tests/support/pscide/src/RebuildSpecSingleModule.fail b/tests/support/pscide/src/RebuildSpecSingleModule.fail new file mode 100644 index 0000000000..b411eb45df --- /dev/null +++ b/tests/support/pscide/src/RebuildSpecSingleModule.fail @@ -0,0 +1,3 @@ +module RebuildSpecSingleModule where + +let anerror \ No newline at end of file diff --git a/tests/support/pscide/src/RebuildSpecSingleModule.purs b/tests/support/pscide/src/RebuildSpecSingleModule.purs new file mode 100644 index 0000000000..405962933e --- /dev/null +++ b/tests/support/pscide/src/RebuildSpecSingleModule.purs @@ -0,0 +1,4 @@ +module RebuildSpecSingleModule where + +id x = x +const x y = x diff --git a/tests/support/pscide/src/RebuildSpecWithDeps.purs b/tests/support/pscide/src/RebuildSpecWithDeps.purs new file mode 100644 index 0000000000..c095a92f2e --- /dev/null +++ b/tests/support/pscide/src/RebuildSpecWithDeps.purs @@ -0,0 +1,5 @@ +module RebuildSpecWithDeps where + +import RebuildSpecDep (dep) + +x = dep diff --git a/tests/support/pscide/src/RebuildSpecWithForeign.js b/tests/support/pscide/src/RebuildSpecWithForeign.js new file mode 100644 index 0000000000..7c82dc823c --- /dev/null +++ b/tests/support/pscide/src/RebuildSpecWithForeign.js @@ -0,0 +1,3 @@ +// module RebuildSpecWithForeign + +exports.f = 5; diff --git a/tests/support/pscide/src/RebuildSpecWithForeign.purs b/tests/support/pscide/src/RebuildSpecWithForeign.purs new file mode 100644 index 0000000000..2f425ef889 --- /dev/null +++ b/tests/support/pscide/src/RebuildSpecWithForeign.purs @@ -0,0 +1,3 @@ +module RebuildSpecWithForeign where + +foreign import f :: Int diff --git a/tests/support/pscide/src/RebuildSpecWithMissingForeign.fail b/tests/support/pscide/src/RebuildSpecWithMissingForeign.fail new file mode 100644 index 0000000000..c75fdeab6f --- /dev/null +++ b/tests/support/pscide/src/RebuildSpecWithMissingForeign.fail @@ -0,0 +1,3 @@ +module RebuildSpecWithMissingForeign where + +foreign import f :: Int From 8051524f708302de2034d6f28beba6a237b5cfa0 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 17 Apr 2016 02:42:18 +0100 Subject: [PATCH 0372/1580] Fix prettyprinter for types --- src/Language/PureScript/Docs/AsMarkdown.hs | 2 +- src/Language/PureScript/Docs/Convert.hs | 4 ++-- src/Language/PureScript/Docs/Render.hs | 4 ++-- .../PureScript/Docs/RenderedCode/Render.hs | 13 ++++++++++++- .../PureScript/Docs/RenderedCode/Types.hs | 15 ++++++++++----- src/Language/PureScript/Pretty/Types.hs | 10 ++++++++++ src/Language/PureScript/Sugar/Operators.hs | 2 +- tests/Main.hs | 13 ------------- tests/TestDocs.hs | 12 ++++++------ 9 files changed, 44 insertions(+), 31 deletions(-) diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 9843931ddf..8cd8c0b8ce 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -80,7 +80,7 @@ codeToString :: RenderedCode -> String codeToString = outputWith elemAsMarkdown where elemAsMarkdown (Syntax x) = x - elemAsMarkdown (Ident x) = x + elemAsMarkdown (Ident x _) = x elemAsMarkdown (Ctor x _) = x elemAsMarkdown (Kind x) = x elemAsMarkdown (Keyword x) = x diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 2cb83cb275..0358a70d9d 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -26,9 +26,9 @@ import Text.Parsec (eof) import qualified Language.PureScript as P import qualified Language.PureScript.Constants as C -import Language.PureScript.Docs.Types -import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks) import Language.PureScript.Docs.Convert.ReExports (updateReExports) +import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks) +import Language.PureScript.Docs.Types -- | -- Like convertModules, except that it takes a list of modules, together with diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index fbce4ad8c8..0ebdbdff80 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -70,12 +70,12 @@ renderDeclarationWithOptions opts Declaration{..} = renderType' = renderTypeWithOptions opts renderAlias (P.Qualified mn alias) | mn == currentModule opts = - P.foldFixityAlias P.runIdent P.runProperName P.runProperName alias + P.foldFixityAlias P.runIdent P.runProperName (("type " ++) . P.runProperName) alias | otherwise = P.foldFixityAlias (P.showQualified P.runIdent . P.Qualified mn) (P.showQualified P.runProperName . P.Qualified mn) - (P.showQualified P.runProperName . P.Qualified mn) + (("type " ++) . P.showQualified P.runProperName . P.Qualified mn) alias renderChildDeclaration :: ChildDeclaration -> RenderedCode diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index 6f9bbd0829..ec23588f08 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -48,6 +48,10 @@ typeLiterals = mkPattern match Just (syntax "()") match row@RCons{} = Just (syntax "(" <> renderRow row <> syntax ")") + match (BinaryNoParensType op l r) = + Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r + match (TypeOp (Qualified mn op)) = + Just (ident' (runIdent op) (maybeToContainingModule mn)) match _ = Nothing @@ -115,6 +119,12 @@ constrained = mkPattern match match (ConstrainedType deps ty) = Just (deps, ty) match _ = Nothing +explicitParens :: Pattern () Type ((), Type) +explicitParens = mkPattern match + where + match (ParensInType ty) = Just ((), ty) + match _ = Nothing + matchTypeAtom :: Pattern () Type RenderedCode matchTypeAtom = typeLiterals <+> fmap parens matchType where @@ -130,6 +140,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom , [ Wrap constrained $ \deps ty -> renderConstraints deps ty ] , [ Wrap forall_ $ \idents ty -> mconcat [syntax "forall", sp, mintersperse sp (map ident idents), syntax ".", sp, ty] ] , [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ] + , [ Wrap explicitParens $ \_ ty -> ty ] ] forall_ :: Pattern () Type ([String], Type) @@ -156,7 +167,7 @@ convert _ other = other convertForAlls :: Type -> Type convertForAlls (ForAll i ty _) = go [i] ty where - go idents (ForAll ident' ty' _) = go (ident' : idents) ty' + go idents (ForAll i' ty' _) = go (i' : idents) ty' go idents other = PrettyPrintForAll idents other convertForAlls other = other diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 307663a594..8c5289d428 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -18,6 +18,7 @@ module Language.PureScript.Docs.RenderedCode.Types , sp , syntax , ident + , ident' , ctor , kind , keyword @@ -46,7 +47,7 @@ import qualified Language.PureScript as P -- data RenderedCodeElement = Syntax String - | Ident String + | Ident String ContainingModule | Ctor String ContainingModule | Kind String | Keyword String @@ -56,8 +57,8 @@ data RenderedCodeElement instance A.ToJSON RenderedCodeElement where toJSON (Syntax str) = A.toJSON ["syntax", str] - toJSON (Ident str) = - A.toJSON ["ident", str] + toJSON (Ident str mn) = + A.toJSON ["ident", A.toJSON str, A.toJSON mn] toJSON (Ctor str mn) = A.toJSON ["ctor", A.toJSON str, A.toJSON mn ] toJSON (Kind str) = @@ -70,7 +71,7 @@ instance A.ToJSON RenderedCodeElement where asRenderedCodeElement :: Parse String RenderedCodeElement asRenderedCodeElement = a Syntax "syntax" <|> - a Ident "ident" <|> + asIdent <|> asCtor <|> a Kind "kind" <|> a Keyword "keyword" <|> @@ -80,6 +81,7 @@ asRenderedCodeElement = p <|> q = catchError p (const q) a ctor' ctorStr = ctor' <$> (nth 0 (withString (eq ctorStr)) *> nth 1 asString) + asIdent = nth 0 (withString (eq "ident")) *> (Ident <$> nth 1 asString <*> nth 2 asContainingModule) asCtor = nth 0 (withString (eq "ctor")) *> (Ctor <$> nth 1 asString <*> nth 2 asContainingModule) asSpace = nth 0 (withString (eq "space")) *> pure Space @@ -159,7 +161,10 @@ syntax :: String -> RenderedCode syntax x = RC [Syntax x] ident :: String -> RenderedCode -ident x = RC [Ident x] +ident x = RC [Ident x ThisModule] + +ident' :: String -> ContainingModule -> RenderedCode +ident' x m = RC [Ident x m] ctor :: String -> ContainingModule -> RenderedCode ctor x m = RC [Ctor x m] diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 1d14bdbc2a..093723f718 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -36,6 +36,9 @@ typeLiterals = mkPattern match match (Skolem name s _ _) = Just $ text $ name ++ show s match REmpty = Just $ text "()" match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row + match (BinaryNoParensType op l r) = + Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r + match (TypeOp op) = Just $ text $ showQualified runIdent op match _ = Nothing constraintsAsBox :: [Constraint] -> Box -> Box @@ -108,6 +111,12 @@ constrained = mkPattern match match (ConstrainedType deps ty) = Just (deps, ty) match _ = Nothing +explicitParens :: Pattern () Type ((), Type) +explicitParens = mkPattern match + where + match (ParensInType ty) = Just ((), ty) + match _ = Nothing + matchTypeAtom :: Pattern () Type Box matchTypeAtom = typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) matchType @@ -121,6 +130,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ] , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text ("forall " ++ unwords idents ++ ".")) ty ] , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ prettyPrintKind k)) ] + , [ Wrap explicitParens $ \_ ty -> ty ] ] -- If both boxes span a single line, keep them on the same line, or else diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 4fa565e94c..a86eb0f248 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -55,7 +55,7 @@ type FixityRecord = (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Fixit -- rebracket :: forall m - . (MonadError MultipleErrors m) + . MonadError MultipleErrors m => [ExternsFile] -> [Module] -> m [Module] diff --git a/tests/Main.hs b/tests/Main.hs index 06c08ac486..2a246efe97 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,16 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Main --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - {-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE TupleSections #-} diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 79c1fc48c8..1af8bd4567 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -285,12 +285,12 @@ testCases = , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==)) ]) - --, ("ConstrainedArgument", - -- [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a" - -- , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a" - -- , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a" - -- , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a" - -- ]) + , ("ConstrainedArgument", + [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a" + , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a" + , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a" + , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a" + ]) ] where From 0a92e7ff913f865c42c4e6ab67cfd39c12ac3257 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 17 Apr 2016 14:37:20 +0100 Subject: [PATCH 0373/1580] Always read UTF-8, tests --- examples/docs/src/TypeOpAliases.purs | 18 +++++++++++++ hierarchy/Main.hs | 3 ++- psc-bundle/Main.hs | 3 ++- psc-docs/Main.hs | 3 ++- psci/PSCi.hs | 7 +++--- psci/PSCi/Module.hs | 5 ++-- .../PureScript/Docs/Convert/ReExports.hs | 25 +++++++++++++++++-- .../PureScript/Docs/Convert/Single.hs | 19 +++++++------- .../PureScript/Docs/ParseAndBookmark.hs | 4 ++- src/Language/PureScript/Docs/Render.hs | 7 ++++-- src/Language/PureScript/Docs/Types.hs | 13 +++++++--- src/Language/PureScript/Ide/SourceFile.hs | 3 ++- tests/TestDocs.hs | 23 ++++++++++++----- tests/TestPsci.hs | 3 ++- 14 files changed, 103 insertions(+), 33 deletions(-) create mode 100644 examples/docs/src/TypeOpAliases.purs diff --git a/examples/docs/src/TypeOpAliases.purs b/examples/docs/src/TypeOpAliases.purs new file mode 100644 index 0000000000..be11148b22 --- /dev/null +++ b/examples/docs/src/TypeOpAliases.purs @@ -0,0 +1,18 @@ +module TypeOpAliases where + +type AltFn a b = a -> b + +infixr 6 type AltFn as ~> + +foreign import test1 :: forall a b. a ~> b +foreign import test2 :: forall a b c. a ~> b ~> c +foreign import test3 :: forall a b c d. a ~> (b ~> c) ~> d +foreign import test4 :: forall a b c d. ((a ~> b) ~> c) ~> d + +data Tuple a b = Tuple a b + +infixl 6 Tuple as × +infixl 6 type Tuple as × + +third ∷ ∀ a b c. a × b × c → c +third (a × b × c) = c diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs index dcba30919e..adc3de057a 100644 --- a/hierarchy/Main.hs +++ b/hierarchy/Main.hs @@ -30,6 +30,7 @@ import System.FilePath (()) import System.FilePath.Glob (glob) import System.Exit (exitFailure, exitSuccess) import System.IO (hPutStr, stderr) +import System.IO.UTF8 (readUTF8File) import qualified Language.PureScript as P import qualified Paths_purescript as Paths @@ -56,7 +57,7 @@ runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns) readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module]) readInput paths = do - content <- mapM (\path -> (path, ) <$> readFile path) paths + content <- mapM (\path -> (path, ) <$> readUTF8File path) paths return $ map snd <$> P.parseModulesFromFiles id content compile :: HierarchyOptions -> IO () diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index a5eee56413..a1051cac87 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -20,6 +20,7 @@ import System.FilePath (takeFileName, takeDirectory) import System.FilePath.Glob (glob) import System.Exit (exitFailure) import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8) +import System.IO.UTF8 (readUTF8File) import System.Directory (createDirectoryIfMissing) import Language.PureScript.Bundle @@ -56,7 +57,7 @@ app Options{..} = do hPutStrLn stderr "psc-bundle: No input files." exitFailure input <- for inputFiles $ \filename -> do - js <- liftIO (readFile filename) + js <- liftIO (readUTF8File filename) mid <- guessModuleIdentifier filename length js `seq` return (mid, js) -- evaluate readFile till EOF before returning, not to exhaust file handles diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index 9d4ff6dbb8..d7528e30be 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -20,6 +20,7 @@ import qualified Language.PureScript as P import qualified Paths_purescript as Paths import System.Exit (exitFailure) import System.IO (hPutStrLn, hPrint, hSetEncoding, stderr, stdout, utf8) +import System.IO.UTF8 (readUTF8File) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) import System.FilePath.Glob (glob) @@ -139,7 +140,7 @@ dumpTags input renderTags = do ldump = mapM_ putStrLn parseFile :: FilePath -> IO (FilePath, String) -parseFile input = (,) input <$> readFile input +parseFile input = (,) input <$> readUTF8File input inputFile :: Parser FilePath inputFile = strArgument $ diff --git a/psci/PSCi.hs b/psci/PSCi.hs index fe0502bc47..5e6319afdb 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -33,6 +33,7 @@ import System.FilePath (()) import System.FilePath.Glob (glob) import System.Process (readProcessWithExitCode) import System.IO.Error (tryIOError) +import System.IO.UTF8 (readUTF8File) import qualified Language.PureScript as P import qualified Language.PureScript.Names as N @@ -75,7 +76,7 @@ loop PSCiOptions{..} = do historyFilename <- getHistoryFilename let settings = defaultSettings { historyFile = Just historyFilename } foreignsOrError <- runMake $ do - foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile)) + foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readUTF8File inFile)) P.parseForeignModulesFromFiles foreignFilesContent case foreignsOrError of Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure @@ -167,7 +168,7 @@ handleCommand (LoadFile filePath) = PSCI $ whenFileExists filePath $ \absPath -> Right mods -> lift $ modify (updateModules (map (absPath,) mods)) handleCommand (LoadForeign filePath) = PSCI $ whenFileExists filePath $ \absPath -> do foreignsOrError <- lift . lift . runMake $ do - foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath) + foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readUTF8File absPath) P.parseForeignModulesFromFiles [(absPath, foreignFile)] case foreignsOrError of Left err -> outputStrLn $ P.prettyPrintMultipleErrors False err @@ -360,7 +361,7 @@ loadUserConfig = onFirstFileMatching readCommands pathGetters exists <- doesFileExist configFile if exists then do - ls <- lines <$> readFile configFile + ls <- lines <$> readUTF8File configFile case traverse parseCommand ls of Left err -> print err >> exitFailure Right cs -> return $ Just cs diff --git a/psci/PSCi/Module.hs b/psci/PSCi/Module.hs index ead2c0057a..bda5116f4c 100644 --- a/psci/PSCi/Module.hs +++ b/psci/PSCi/Module.hs @@ -6,6 +6,7 @@ import Prelude.Compat import qualified Language.PureScript as P import PSCi.Types import System.FilePath (pathSeparator) +import System.IO.UTF8 (readUTF8File) import Control.Monad -- | The name of the PSCI support module @@ -45,7 +46,7 @@ supportModule = -- loadModule :: FilePath -> IO (Either String [P.Module]) loadModule filename = do - content <- readFile filename + content <- readUTF8File filename return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)] -- | @@ -54,7 +55,7 @@ loadModule filename = do loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)]) loadAllModules files = do filesAndContent <- forM files $ \filename -> do - content <- readFile filename + content <- readUTF8File filename return (filename, content) return $ P.parseModulesFromFiles id filesAndContent diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 0c67f885ff..a6b54f1485 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -111,13 +111,14 @@ collectDeclarations imports exports = do valsAndMembers <- collect lookupValueDeclaration impVals expVals typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs types <- collect lookupTypeDeclaration impTypes expTypes + typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses let filteredTypes = filterDataConstructors expCtors types let filteredClasses = filterTypeClassMembers (map fst expVals) classes - pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals])) + pure (Map.toList (Map.unionsWith (<>) [filteredTypes, typeOps, filteredClasses, vals])) where collect lookup' imps exps = do @@ -130,6 +131,9 @@ collectDeclarations imports exports = do expTypes = map (first fst) (P.exportedTypes exports) impTypes = concat (Map.elems (P.importedTypes imports)) + expTypeOps = P.exportedTypeOps exports + impTypeOps = concat (Map.elems (P.importedTypeOps imports)) + expCtors = concatMap (snd . fst) (P.exportedTypes exports) expTCs = P.exportedTypeClasses exports @@ -180,7 +184,7 @@ lookupValueDeclaration importedFrom ident = do let rs = filter (\d -> declTitle d == P.showIdent ident - && (isValue d || isAlias d)) decls + && (isValue d || isValueAlias d)) decls errOther other = internalErrorInModule ("lookupValueDeclaration: unexpected result:\n" ++ @@ -243,6 +247,23 @@ lookupTypeDeclaration importedFrom ty = do internalErrorInModule ("lookupTypeDeclaration: unexpected result: " ++ show other) +lookupTypeOpDeclaration :: + (MonadState (Map P.ModuleName Module) m, + MonadReader P.ModuleName m) => + P.ModuleName -> + P.Ident -> + m (P.ModuleName, [Declaration]) +lookupTypeOpDeclaration importedFrom tyOp = do + decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom + let + ds = filter (\d -> declTitle d == ("type " ++ P.showIdent tyOp) && isTypeAlias d) decls + case ds of + [d] -> + pure (importedFrom, [d]) + other -> + internalErrorInModule + ("lookupTypeOpDeclaration: unexpected result: " ++ show other) + lookupTypeClassDeclaration :: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) => diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index fd9845c25c..7e60bfdff3 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -108,16 +108,17 @@ addDefaultFixity decl@Declaration{..} defaultFixity = P.Fixity P.Infixl (-1) getDeclarationTitle :: P.Declaration -> Maybe String -getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name) -getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name) -getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name) -getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name) -getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) -getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name) +getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name) +getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name) +getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name) +getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name) +getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) +getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name) -getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")") -getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d -getDeclarationTitle _ = Nothing +getDeclarationTitle (P.FixityDeclaration _ name (Just (P.Qualified _ P.AliasType{}))) = Just ("type (" ++ name ++ ")") +getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")") +getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d +getDeclarationTitle _ = Nothing -- | Create a basic Declaration value. mkDeclaration :: String -> DeclarationInfo -> Declaration diff --git a/src/Language/PureScript/Docs/ParseAndBookmark.hs b/src/Language/PureScript/Docs/ParseAndBookmark.hs index cfb32d55dd..bea862dc84 100644 --- a/src/Language/PureScript/Docs/ParseAndBookmark.hs +++ b/src/Language/PureScript/Docs/ParseAndBookmark.hs @@ -16,6 +16,8 @@ import Control.Monad.IO.Class (MonadIO(..)) import Web.Bower.PackageMeta (PackageName) +import System.IO.UTF8 (readUTF8File) + import qualified Language.PureScript as P import Language.PureScript.Docs.Types import Language.PureScript.Docs.Convert (collectBookmarks) @@ -80,7 +82,7 @@ fileInfoToString (Local fn) = fn fileInfoToString (FromDep _ fn) = fn parseFile :: FilePath -> IO (FilePath, String) -parseFile input' = (,) input' <$> readFile input' +parseFile input' = (,) input' <$> readUTF8File input' parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String) parseAs g = fmap (first g) . liftIO . parseFile diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 0ebdbdff80..9ac9a4e239 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -58,12 +58,12 @@ renderDeclarationWithOptions opts Declaration{..} = syntax "(" <> mintersperse (syntax "," <> sp) (map renderConstraint implies) <> syntax ")" <> sp <> syntax "<=" - AliasDeclaration for (P.Fixity associativity precedence) -> + AliasDeclaration for@(P.Qualified _ alias) (P.Fixity associativity precedence) -> [ keywordFixity associativity , syntax $ show precedence , ident $ renderAlias for , keyword "as" - , ident . tail . init $ declTitle + , ident $ adjustAliasName alias declTitle ] where @@ -78,6 +78,9 @@ renderDeclarationWithOptions opts Declaration{..} = (("type " ++) . P.showQualified P.runProperName . P.Qualified mn) alias + adjustAliasName (P.AliasType{}) title = drop 6 (init title) + adjustAliasName _ title = tail (init title) + renderChildDeclaration :: ChildDeclaration -> RenderedCode renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index b244840687..ea09893a5e 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -164,10 +164,17 @@ isType Declaration{..} = ExternDataDeclaration{} -> True _ -> False -isAlias :: Declaration -> Bool -isAlias Declaration{..} = +isValueAlias :: Declaration -> Bool +isValueAlias Declaration{..} = case declInfo of - AliasDeclaration{} -> True + (AliasDeclaration (P.Qualified _ P.AliasConstructor{}) _) -> True + (AliasDeclaration (P.Qualified _ P.AliasValue{}) _) -> True + _ -> False + +isTypeAlias :: Declaration -> Bool +isTypeAlias Declaration{..} = + case declInfo of + (AliasDeclaration (P.Qualified _ P.AliasType{}) _) -> True _ -> False -- | Discard any children which do not satisfy the given predicate. diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 24ce7dea08..d687285c72 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -35,6 +35,7 @@ import Language.PureScript.Ide.Types import qualified Language.PureScript.Names as N import qualified Language.PureScript.Parser as P import System.Directory +import System.IO.UTF8 (readUTF8File) parseModuleFromFile :: (MonadIO m, MonadError PscIdeError m) => FilePath -> m D.Module @@ -42,7 +43,7 @@ parseModuleFromFile fp = do exists <- liftIO (doesFileExist fp) if exists then do - content <- liftIO (readFile fp) + content <- liftIO (readUTF8File fp) let m = do tokens <- P.lex fp content P.runTokenParser "" P.parseModule tokens either (throwError . (`ParseError` "File could not be parsed.")) pure m diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 1af8bd4567..dff2da4e85 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -285,12 +285,20 @@ testCases = , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==)) ]) - , ("ConstrainedArgument", - [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a" - , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a" - , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a" - , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a" - ]) + , ("ConstrainedArgument", + [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a" + , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a" + , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a" + , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a" + ]) + + , ("TypeOpAliases", + [ ValueShouldHaveTypeSignature (n "TypeOpAliases") "test1" (renderedType "forall a b. a ~> b") + , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test2" (renderedType "forall a b c. a ~> b ~> c") + , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test3" (renderedType "forall a b c d. a ~> (b ~> c) ~> d") + , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test4" (renderedType "forall a b c d. ((a ~> b) ~> c) ~> d") + , ValueShouldHaveTypeSignature (n "TypeOpAliases") "third" (renderedType "forall a b c. a × b × c -> c") + ]) ] where @@ -301,3 +309,6 @@ testCases = isVar varName (P.TypeVar name) | varName == name = True isVar _ _ = False + + renderedType expected = + ShowFn $ \ty -> codeToString (Docs.renderType ty) == expected diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index 3d058df020..ee0a2c1533 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -17,6 +17,7 @@ import System.Exit (exitFailure) import System.Console.Haskeline import System.FilePath (()) import System.Directory (getCurrentDirectory) +import System.IO.UTF8 (readUTF8File) import qualified System.FilePath.Glob as Glob import Test.HUnit @@ -132,7 +133,7 @@ getPSCiState = do jsFiles <- supportFiles "js" modulesOrFirstError <- loadAllModules pursFiles - foreignFiles <- forM jsFiles (\f -> (f,) <$> readFile f) + foreignFiles <- forM jsFiles (\f -> (f,) <$> readUTF8File f) Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles case modulesOrFirstError of Left err -> From 235edea1676776d05b16bd9728edabc7924eb36f Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 17 Apr 2016 18:00:24 +0100 Subject: [PATCH 0374/1580] Require types to be exported if an type operator alias is --- .../failing/TypeOperatorAliasNoExport.purs | 6 +++++ src/Language/PureScript/AST/Declarations.hs | 9 +++++++ src/Language/PureScript/TypeChecker.hs | 27 +++++++++++++------ 3 files changed, 34 insertions(+), 8 deletions(-) create mode 100644 examples/failing/TypeOperatorAliasNoExport.purs diff --git a/examples/failing/TypeOperatorAliasNoExport.purs b/examples/failing/TypeOperatorAliasNoExport.purs new file mode 100644 index 0000000000..227479ab75 --- /dev/null +++ b/examples/failing/TypeOperatorAliasNoExport.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith TransitiveExportError +module Test (type (×)) where + +data Tuple a b = Tuple a b + +infixl 6 type Tuple as × diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index ad2942eba5..868c1200fc 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -232,6 +232,15 @@ foldFixityAlias f _ _ (AliasValue name) = f name foldFixityAlias _ g _ (AliasConstructor name) = g name foldFixityAlias _ _ h (AliasType name) = h name +getValueAlias :: FixityAlias -> Maybe (Either Ident (ProperName 'ConstructorName)) +getValueAlias (AliasValue name) = Just $ Left name +getValueAlias (AliasConstructor name) = Just $ Right name +getValueAlias _ = Nothing + +getTypeAlias :: FixityAlias -> Maybe (ProperName 'TypeName) +getTypeAlias (AliasType name) = Just name +getTypeAlias _ = Nothing + -- | The members of a type class instance declaration data TypeInstanceBody -- | This is a derived instance diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 8ac2395a02..8501e52c71 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternGuards #-} -- | -- The top-level type checker, which checks all declarations in a module. @@ -438,22 +439,32 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint checkNonAliasesAreExported :: [ProperName 'ConstructorName] -> DeclarationRef -> m () checkNonAliasesAreExported exportedDctors dr@(ValueRef (Op name)) = - case listToMaybe (mapMaybe getAlias decls) of - Just (AliasValue ident) -> + case listToMaybe (mapMaybe (getAlias getValueAlias name) decls) of + Just (Left ident) -> unless (ValueRef ident `elem` exps) $ throwError . errorMessage $ TransitiveExportError dr [ValueRef ident] - Just (AliasConstructor ctor) -> + Just (Right ctor) -> unless (ctor `elem` exportedDctors) $ throwError . errorMessage $ TransitiveDctorExportError dr ctor _ -> return () + checkNonAliasesAreExported _ dr@(TypeOpRef (Op name)) = + case listToMaybe (mapMaybe (getAlias getTypeAlias name) decls) of + Just ty -> + unless (any (isTypeRefFor ty) exps) $ + throwError . errorMessage $ TransitiveExportError dr [TypeRef ty Nothing] + _ -> return () where - getAlias :: Declaration -> Maybe FixityAlias - getAlias (PositionedDeclaration _ _ d) = getAlias d - getAlias (FixityDeclaration _ name' (Just (Qualified (Just mn') alias))) - | name == name' && mn == mn' = Just alias - getAlias _ = Nothing + isTypeRefFor :: ProperName 'TypeName -> DeclarationRef -> Bool + isTypeRefFor ty (TypeRef ty' _) = ty == ty' + isTypeRefFor _ _ = False checkNonAliasesAreExported _ _ = return () + getAlias :: (FixityAlias -> Maybe a) -> String -> Declaration -> Maybe a + getAlias match name (PositionedDeclaration _ _ d) = getAlias match name d + getAlias match name (FixityDeclaration _ name' (Just (Qualified (Just mn') a))) + | Just alias <- match a, name == name' && mn == mn' = Just alias + getAlias _ _ _ = Nothing + exportedDataConstructors :: [DeclarationRef] -> [ProperName 'ConstructorName] exportedDataConstructors = foldMap extractCtor where From 414372eab2399cdb63ecd09b63b8dcd416bdf6b3 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 17 Apr 2016 18:21:26 +0100 Subject: [PATCH 0375/1580] Relax rules on license files in psc-publish Instead of requiring a LICENSE file to exist, instead, just check that there is a valid SPDX license expression in bower.json. Fixes #1985. --- examples/docs/LICENSE | 1 - examples/docs/bower.json | 2 +- purescript.cabal | 3 ++- src/Language/PureScript/Publish.hs | 19 +++++++++----- .../PureScript/Publish/ErrorsWarnings.hs | 26 +++++++++++++++---- 5 files changed, 37 insertions(+), 14 deletions(-) delete mode 100644 examples/docs/LICENSE diff --git a/examples/docs/LICENSE b/examples/docs/LICENSE deleted file mode 100644 index c993dba4ab..0000000000 --- a/examples/docs/LICENSE +++ /dev/null @@ -1 +0,0 @@ -This isn't a real license, it's just here for the sake of the tests. diff --git a/examples/docs/bower.json b/examples/docs/bower.json index fea039d8c5..54f1c9767e 100644 --- a/examples/docs/bower.json +++ b/examples/docs/bower.json @@ -16,5 +16,5 @@ ], "dependencies": { }, - "license": "replaceme" + "license": "MIT" } diff --git a/purescript.cabal b/purescript.cabal index 6c74531600..86cd678a5b 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -92,7 +92,8 @@ library monad-logger >= 0.3 && < 0.4, pipes >= 4.0.0 && < 4.2.0 , pipes-http -any, - http-types -any + http-types -any, + spdx == 0.2.* exposed-modules: Language.PureScript Language.PureScript.AST diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 90a90f610c..9b3f8dbb27 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -39,6 +39,7 @@ import Data.Aeson.BetterErrors import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.SPDX as SPDX import Control.Category ((>>>)) import Control.Arrow ((***)) @@ -128,7 +129,7 @@ catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b catchLeft a f = either f pure a unlessM :: Monad m => m Bool -> m () -> m () -unlessM cond act = cond >>= flip unless act +unlessM cond act = cond >>= flip unless act preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage preparePackage' opts = do @@ -137,14 +138,12 @@ preparePackage' opts = do pkgMeta <- liftIO (Bower.decodeFile "bower.json") >>= flip catchLeft (userError . CouldntDecodeBowerJSON) - unlessM (liftIO (doesFileExist "LICENSE")) (userError LicenseNotFound) + checkLicense pkgMeta (pkgVersionTag, pkgVersion) <- publishGetVersion opts pkgGithub <- getBowerRepositoryInfo pkgMeta (pkgBookmarks, pkgModules) <- getModulesAndBookmarks - unless (bowerLicenseExists pkgMeta) (userError NoLicenseSpecified) - let declaredDeps = map fst (bowerDependencies pkgMeta ++ bowerDevDependencies pkgMeta) pkgResolvedDependencies <- getResolvedDependencies declaredDeps @@ -215,8 +214,16 @@ getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExt (Left (BadRepositoryType repositoryType)) maybe (Left NotOnGithub) Right (extractGithub repositoryUrl) -bowerLicenseExists :: PackageMeta -> Bool -bowerLicenseExists = any (not . null) . bowerLicense +checkLicense :: PackageMeta -> PrepareM () +checkLicense pkgMeta = + unless (any isValidSPDX (bowerLicense pkgMeta)) + (userError NoLicenseSpecified) + +-- | +-- Check if a string is a valid SPDX license expression. +-- +isValidSPDX :: String -> Bool +isValidSPDX = (== 1) . length . SPDX.parseExpression extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo) extractGithub = stripGitHubPrefixes diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index b669477887..6b4469beff 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -182,11 +182,27 @@ displayUserError e = case e of BadRepositoryField err -> displayRepositoryError err NoLicenseSpecified -> - para (concat - ["No license specified in bower.json. Please add one. ", - "Distributing code without a license means that nobody ", - "will be able to (legally) use it." - ]) + vcat $ + [ para (concat + [ "No license is specified in bower.json. Please add one, using the " + , "SPDX license expression format. For example, any of the " + , "following would be acceptable:" + ]) + , spacer + ] ++ + map (indented . para) + [ "* \"MIT\"" + , "* \"BSD-2-Clause\"" + , "* \"GPL-2.0+\"" + , "* \"(GPL-3.0 OR MIT)\"" + ] + ++ + [ spacer + , para (concat + [ "Note that distributing code without a license means that nobody " + , "will (legally) be able to use it." + ]) + ] MissingDependencies pkgs -> let singular = NonEmpty.length pkgs == 1 pl a b = if singular then b else a From 7355ef7d0214ac8bb4a4b2b9fe70985840891c24 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 17 Apr 2016 18:22:30 +0100 Subject: [PATCH 0376/1580] Update license-generator * Accept packages on stdin, so that it's easier to use with either cabal-dependency-licenses or stack * Just point to the script in CONTRIBUTING.md to stop it from getting out of date again * Rerun license-generator. --- CONTRIBUTING.md | 7 +- LICENSE | 1631 ++++++++++++++++++++++++++++++--- license-generator/generate.hs | 22 +- purescript.cabal | 1 - 4 files changed, 1528 insertions(+), 133 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index d47af73fd0..08dfdd7315 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -27,12 +27,7 @@ the licenses of all dependencies, including transitive ones, in the LICENSE file. Therefore, whenever the dependencies change, the LICENSE file should be updated. -You can automate this (if you have bash): - -- get a copy of [cabal-dependency-licenses][] -- run at the command line: `runhaskell license-generator/generate.hs > LICENSE` - -[cabal-dependency-licenses]: https://github.com/jaspervdj/cabal-dependency-licenses +This can be automated; see the `license-generator/generate.hs` file. ## Writing Issues diff --git a/LICENSE b/LICENSE index 1c4fc066d4..be37ddb0e2 100644 --- a/LICENSE +++ b/LICENSE @@ -23,63 +23,109 @@ CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. PureScript uses the following Haskell library packages. Their license files follow. Glob - HUnit aeson aeson-better-errors ansi-terminal ansi-wl-pprint array + asn1-encoding + asn1-parse + asn1-types + async attoparsec + auto-update base base-compat + base64-bytestring binary blaze-builder bower-json boxes + byteable bytestring + bytestring-builder + case-insensitive + cereal + conduit + conduit-extra + connection containers + cookie + cryptonite + data-default-class deepseq directory dlist + edit-distance + exceptions + fast-logger filepath + fsnotify ghc-prim hashable haskeline + hinotify + hourglass + http-client + http-client-tls + http-types integer-gmp language-javascript lifted-base + memory + mime-types + mmorph monad-control + monad-logger + monad-loops mtl - nats + network + network-uri old-locale optparse-applicative parallel parsec pattern-arrows - pretty + pem + pipes + pipes-http primitive process - rts + random + regex-base + regex-tdfa + resourcet safe scientific semigroups + socks sourcemap + spdx split stm + stm-chans + streaming-commons syb tagged template-haskell terminfo text time + tls transformers transformers-base transformers-compat unix + unix-compat unordered-containers utf8-string vector void + x509 + x509-store + x509-system + x509-validation + zlib Glob LICENSE file: @@ -112,38 +158,6 @@ Glob LICENSE file: OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -HUnit LICENSE file: - - HUnit is Copyright (c) Dean Herington, 2002, all rights reserved, - and is distributed as free software under the following license. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - - Redistributions of source code must retain the above copyright - notice, this list of conditions, and the following disclaimer. - - - Redistributions in binary form must reproduce the above copyright - notice, this list of conditions, and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - - The names of the copyright holders may not be used to endorse or - promote products derived from this software without specific prior - written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY - EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR - PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE - LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR - BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, - WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE - OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN - IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - aeson LICENSE file: Copyright (c) 2011, MailRank, Inc. @@ -339,6 +353,129 @@ array LICENSE file: ----------------------------------------------------------------------------- +asn1-encoding LICENSE file: + + Copyright (c) 2010-2013 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +asn1-parse LICENSE file: + + Copyright (c) 2010-2013 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +asn1-types LICENSE file: + + Copyright (c) 2010-2013 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +async LICENSE file: + + Copyright (c) 2012, Simon Marlow + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Simon Marlow nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + attoparsec LICENSE file: Copyright (c) Lennart Kolmodin @@ -372,6 +509,29 @@ attoparsec LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +auto-update LICENSE file: + + Copyright (c) 2014 Michael Snoyman + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be included + in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY + CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, + TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE + SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + base LICENSE file: This library (libraries/base) is derived from code from several @@ -460,7 +620,7 @@ base LICENSE file: base-compat LICENSE file: - Copyright (c) 2012-2015 Simon Hengel and Ryan Scott + Copyright (c) 2012-2016 Simon Hengel and Ryan Scott Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -480,6 +640,39 @@ base-compat LICENSE file: OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +base64-bytestring LICENSE file: + + Copyright (c) 2010 Bryan O'Sullivan + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + binary LICENSE file: Copyright (c) Lennart Kolmodin @@ -599,6 +792,36 @@ boxes LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +byteable LICENSE file: + + Copyright (c) 2013 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + bytestring LICENSE file: Copyright (c) Don Stewart 2005-2009 @@ -632,49 +855,313 @@ bytestring LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -containers LICENSE file: +bytestring-builder LICENSE file: - The Glasgow Haskell Compiler License + Copyright Jasper Van der Jeugt 2010, Simon Meier 2010-2013 - Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - - Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - - Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. - - Neither name of the University nor the names of its contributors may be - used to endorse or promote products derived from this software without - specific prior written permission. + * Neither the name of Jasper Van der Jeugt nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF - GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - DAMAGE. + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -deepseq LICENSE file: +case-insensitive LICENSE file: - This library (deepseq) is derived from code from the GHC project which - is largely (c) The University of Glasgow, and distributable under a - BSD-style license (see below). + Copyright (c) 2011-2013 Bas van Dijk - ----------------------------------------------------------------------------- + All rights reserved. - The Glasgow Haskell Compiler License + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The name of Bas van Dijk and the names of contributors may NOT + be used to endorse or promote products derived from this + software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +cereal LICENSE file: + + Copyright (c) Lennart Kolmodin, Galois, Inc. + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + +conduit LICENSE file: + + Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +conduit-extra LICENSE file: + + Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +connection LICENSE file: + + Copyright (c) 2012 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +containers LICENSE file: + + The Glasgow Haskell Compiler License + + Copyright 2004, The University Court of the University of Glasgow. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. + +cookie LICENSE file: + + The following license covers this documentation, and the source code, except + where otherwise indicated. + + Copyright 2010, Michael Snoyman. All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO + EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, + OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE + OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +cryptonite LICENSE file: + + Copyright (c) 2006-2015 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +data-default-class LICENSE file: + + Copyright (c) 2013 Lukas Mai + + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY LUKAS MAI AND CONTRIBUTORS "AS IS" AND ANY + EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY + DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +deepseq LICENSE file: + + This library (deepseq) is derived from code from the GHC project which + is largely (c) The University of Glasgow, and distributable under a + BSD-style license (see below). + + ----------------------------------------------------------------------------- + + The Glasgow Haskell Compiler License Copyright 2001-2009, The University Court of the University of Glasgow. All rights reserved. @@ -808,6 +1295,97 @@ dlist LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +edit-distance LICENSE file: + + Copyright (c) 2008-2013 Maximilian Bolingbroke + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, are permitted + provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of + conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of + conditions and the following disclaimer in the documentation and/or other materials + provided with the distribution. + * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to + endorse or promote products derived from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR + CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER + IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT + OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +exceptions LICENSE file: + + Copyright 2013-2015 Edward Kmett + Copyright 2012 Google Inc. + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + +fast-logger LICENSE file: + + Copyright (c) 2009, IIJ Innovation Institute Inc. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + filepath LICENSE file: Copyright Neil Mitchell 2005-2015. @@ -841,6 +1419,39 @@ filepath LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +fsnotify LICENSE file: + + Copyright (c) 2012, Mark Dittmer + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Mark Dittmer nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ghc-prim LICENSE file: This library (libraries/ghc-prim) is derived from code from several @@ -965,6 +1576,149 @@ haskeline LICENSE file: OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +hinotify LICENSE file: + + Copyright (c) Lennart Kolmodin + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + +hourglass LICENSE file: + + Copyright (c) 2014 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +http-client LICENSE file: + + The MIT License (MIT) + + Copyright (c) 2013 Michael Snoyman + + Permission is hereby granted, free of charge, to any person obtaining a copy of + this software and associated documentation files (the "Software"), to deal in + the Software without restriction, including without limitation the rights to + use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of + the Software, and to permit persons to whom the Software is furnished to do so, + subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS + FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR + COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER + IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +http-client-tls LICENSE file: + + The MIT License (MIT) + + Copyright (c) 2013 Michael Snoyman + + Permission is hereby granted, free of charge, to any person obtaining a copy of + this software and associated documentation files (the "Software"), to deal in + the Software without restriction, including without limitation the rights to + use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of + the Software, and to permit persons to whom the Software is furnished to do so, + subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS + FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR + COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER + IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +http-types LICENSE file: + + Copyright (c) 2011, Aristid Breitkreuz + Copyright (c) 2011, Michael Snoyman + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Aristid Breitkreuz nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + integer-gmp LICENSE file: Copyright (c) 2014, Herbert Valerio Riedel @@ -1047,21 +1801,103 @@ lifted-base LICENSE file: notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - • Neither the name of the author nor the names of other contributors - may be used to endorse or promote products derived from this - software without specific prior written permission. + • Neither the name of the author nor the names of other contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +memory LICENSE file: + + Copyright (c) 2015 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +mime-types LICENSE file: + + Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +mmorph LICENSE file: + + Copyright (c) 2013, Gabriel Gonzalez + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this + list of conditions and the following disclaimer in the documentation and/or + other materials provided with the distribution. + * Neither the name of Gabriel Gonzalez nor the names of other contributors may + be used to endorse or promote products derived from this software without + specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - “AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. monad-control LICENSE file: @@ -1095,6 +1931,33 @@ monad-control LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +monad-logger LICENSE file: + + Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +monad-loops LICENSE file: + + Page not found: Sorry, it's just not here. + mtl LICENSE file: The Glasgow Haskell Compiler License @@ -1129,38 +1992,69 @@ mtl LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -nats LICENSE file: +network LICENSE file: - Copyright 2011-2014 Edward Kmett + Copyright (c) 2002-2010, The University Court of the University of Glasgow. + Copyright (c) 2007-2010, Johan Tibell - All rights reserved. + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. + +network-uri LICENSE file: + + Copyright (c) 2002-2010, The University Court of the University of Glasgow. + Copyright (c) 2007-2010, Johan Tibell Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: + modification, are permitted provided that the following conditions are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. old-locale LICENSE file: @@ -1350,17 +2244,93 @@ pattern-arrows LICENSE file: IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -pretty LICENSE file: +pem LICENSE file: - This library (libraries/pretty) is derived from code from - the GHC project which is largely (c) The University of - Glasgow, and distributable under a BSD-style license (see below). + Copyright (c) 2010-2012 Vincent Hanquez - ----------------------------------------------------------------------------- + All rights reserved. - The Glasgow Haskell Compiler License + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. - Copyright 2004, The University Court of the University of Glasgow. + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +pipes LICENSE file: + + Copyright (c) 2012-2014 Gabriel Gonzalez + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Gabriel Gonzalez nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +pipes-http LICENSE file: + + Copyright (c) 2014 Gabriel Gonzalez + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Gabriel Gonzalez nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +primitive LICENSE file: + + Copyright (c) 2008-2009, Roman Leshchinskiy All rights reserved. Redistribution and use in source and binary forms, with or without @@ -1390,11 +2360,27 @@ pretty LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +process LICENSE file: + + This library (libraries/process) is derived from code from two + sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + + The full text of these licenses is reproduced below. Both of the + licenses are BSD-style or compatible. + ----------------------------------------------------------------------------- -primitive LICENSE file: + The Glasgow Haskell Compiler License - Copyright (c) 2008-2009, Roman Leshchinskiy + Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without @@ -1424,10 +2410,26 @@ primitive LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ----------------------------------------------------------------------------- -process LICENSE file: + Code derived from the document "Report on the Programming Language + Haskell 98", is distributed under the following license: - This library (libraries/process) is derived from code from two + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + + ----------------------------------------------------------------------------- + +random LICENSE file: + + This library (libraries/base) is derived from code from two sources: * Code from the GHC project which is largely (c) The University of @@ -1491,9 +2493,68 @@ process LICENSE file: ----------------------------------------------------------------------------- -rts LICENSE file: +regex-base LICENSE file: + + This modile is under this "3 clause" BSD license: + + Copyright (c) 2007, Christopher Kuklewicz + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + * The names of the contributors may not be used to endorse or promote products derived from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +regex-tdfa LICENSE file: - Package not found: No such package in package index + This modile is under this "3 clause" BSD license: + + Copyright (c) 2007-2009, Christopher Kuklewicz + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + * The names of the contributors may not be used to endorse or promote products derived from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +resourcet LICENSE file: + + Copyright (c)2011, Michael Snoyman + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Michael Snoyman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. safe LICENSE file: @@ -1590,6 +2651,36 @@ semigroups LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +socks LICENSE file: + + Copyright (c) 2010-2011 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + sourcemap LICENSE file: Copyright (c) 2012, Chris Done @@ -1623,6 +2714,39 @@ sourcemap LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +spdx LICENSE file: + + Copyright (c) 2015, Oleg Grenrus + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + split LICENSE file: Copyright (c) 2008 Brent Yorgey, Louis Wasserman @@ -1687,6 +2811,68 @@ stm LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +stm-chans LICENSE file: + + === stm-chans license === + + Copyright (c) 2011--2013, wren gayle romano. + ALL RIGHTS RESERVED. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holders nor the names of + other contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + + +streaming-commons LICENSE file: + + The MIT License (MIT) + + Copyright (c) 2014 FP Complete + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. + syb LICENSE file: This library (libraries/syb) is derived from code from several @@ -1910,6 +3096,36 @@ time LICENSE file: THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +tls LICENSE file: + + Copyright (c) 2010-2015 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + transformers LICENSE file: The Glasgow Haskell Compiler License @@ -1976,7 +3192,7 @@ transformers-base LICENSE file: transformers-compat LICENSE file: - Copyright 2012 Edward Kmett + Copyright 2012-2015 Edward Kmett All rights reserved. @@ -2041,6 +3257,38 @@ unix LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +unix-compat LICENSE file: + + Copyright (c) 2007-2008, Björn Bringert + Copyright (c) 2007-2009, Duncan Coutts + Copyright (c) 2010-2011, Jacob Stanley + Copyright (c) 2011, Bryan O'Sullivan + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + - Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + - Neither the names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + unordered-containers LICENSE file: Copyright (c) 2010, Johan Tibell @@ -2167,3 +3415,150 @@ void LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +x509 LICENSE file: + + Copyright (c) 2010-2013 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +x509-store LICENSE file: + + Copyright (c) 2010-2013 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +x509-system LICENSE file: + + Copyright (c) 2010-2013 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +x509-validation LICENSE file: + + Copyright (c) 2010-2013 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +zlib LICENSE file: + + Copyright (c) 2006-2015, Duncan Coutts + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. This clause is intentionally left blank. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + diff --git a/license-generator/generate.hs b/license-generator/generate.hs index 6980c3cfb6..391b9b80be 100644 --- a/license-generator/generate.hs +++ b/license-generator/generate.hs @@ -1,22 +1,28 @@ +-- | +-- A small script which regenerates the LICENSE file with all +-- dependencies' licenses, when the dependencies are provided via standard +-- input. +-- +-- It is recommended to run this as follows: +-- +-- stack list-dependencies | cut -f 1 -d ' ' | stack exec runhaskell license-generator/generate.hs > LICENSE +-- + module Main (main) where import Control.Monad (forM_) import Data.Char (isSpace) import Data.List import System.Process -import System.IO (hPutStrLn, stderr) +import System.IO (hPutStrLn, stderr, getContents) echoHeader :: IO () -echoHeader = +echoHeader = readFile "license-generator/header.txt" >>= putStr depsNames :: IO [String] -depsNames = do - i <- readProcess "cabal-dependency-licenses" [] "" - return $ sort $ map (drop 2) $ filter startsWithDash $ lines i - where - startsWithDash ('-' : _) = True - startsWithDash _ = False +depsNames = + fmap (filter (/= "purescript") . lines) getContents depsLicense :: String -> IO () depsLicense dep = do diff --git a/purescript.cabal b/purescript.cabal index 86cd678a5b..2b3ebef555 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -23,7 +23,6 @@ extra-source-files: examples/passing/*.purs , examples/failing/*.purs , examples/docs/bower_components/purescript-prelude/src/*.purs , examples/docs/bower.json - , examples/docs/LICENSE , examples/docs/src/*.purs , tests/support/setup.js , tests/support/package.json From c9963138bb47a020050955ff27bffa7aee73092f Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 17 Apr 2016 21:00:03 +0100 Subject: [PATCH 0377/1580] Add note recommending adding a license file --- src/Language/PureScript/Publish/ErrorsWarnings.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 6b4469beff..b928f385c4 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -202,6 +202,12 @@ displayUserError e = case e of [ "Note that distributing code without a license means that nobody " , "will (legally) be able to use it." ]) + , spacer + , para (concat + [ "It is also recommended to add a LICENSE file to the repository, " + , "including your name and the current year, although this is not " + , "necessary." + ]) ] MissingDependencies pkgs -> let singular = NonEmpty.length pkgs == 1 From 7eab9e742a2f50f8d38c90d7078118898fa9bd5b Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 18 Apr 2016 13:37:17 +0200 Subject: [PATCH 0378/1580] [psc-ide] create the output folder if it's missing --- psc-ide-server/Main.hs | 12 +++++++++++- src/Language/PureScript/Ide.hs | 9 ++++++--- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 169b2396da..c19c7ca829 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -82,7 +82,17 @@ main = do maybe (pure ()) setCurrentDirectory dir serverState <- newTVarIO emptyPscIdeState cwd <- getCurrentDirectory - _ <- forkFinally (watcher serverState (cwd outputPath)) print + let fullOutputPath = cwd outputPath + + doesDirectoryExist fullOutputPath + >>= flip unless + (do putStrLn ("Your output directory didn't exist. I'll create it at: " <> fullOutputPath) + createDirectory fullOutputPath + putStrLn "This usually means you didn't compile your project yet." + putStrLn "psc-ide needs you to compile your project (for example by running pulp build)" + ) + + _ <- forkFinally (watcher serverState fullOutputPath) print let conf = Configuration { diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index cae4e8b6ec..dd513256b0 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -29,6 +29,7 @@ module Language.PureScript.Ide import Prelude () import Prelude.Compat +import Control.Monad (unless) import Control.Monad.Error.Class import Control.Monad.IO.Class import "monad-logger" Control.Monad.Logger @@ -45,18 +46,18 @@ import Language.PureScript.Ide.Completion import Language.PureScript.Ide.Error import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Filter -import Language.PureScript.Ide.Imports hiding (Import) +import Language.PureScript.Ide.Imports hiding (Import) import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Pursuit +import Language.PureScript.Ide.Rebuild import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import Language.PureScript.Ide.Rebuild import System.Directory -import System.FilePath import System.Exit +import System.FilePath handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => Command -> m Success @@ -215,6 +216,8 @@ loadAllModules = do outputPath <- confOutputPath . envConfiguration <$> ask cwd <- liftIO getCurrentDirectory let outputDirectory = cwd outputPath + liftIO (doesDirectoryExist outputDirectory) + >>= flip unless (throwError (GeneralError "Couldn't locate your output directory")) liftIO (getDirectoryContents outputDirectory) >>= liftIO . traverse (getExternsPath outputDirectory) >>= traverse_ loadExtern . catMaybes From bb979a82733cbf43dc7e43cec31b3cc0c2d451c9 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 19 Apr 2016 16:29:30 +0100 Subject: [PATCH 0379/1580] Typed holes --- examples/failing/TypedHole.purs | 9 +++++++ src/Language/PureScript/AST/Declarations.hs | 4 +++ src/Language/PureScript/Errors.hs | 25 ++++++++++++++++++- .../PureScript/Parser/Declarations.hs | 4 +++ src/Language/PureScript/Parser/Lexer.hs | 10 ++++++++ src/Language/PureScript/Pretty/Values.hs | 1 + src/Language/PureScript/TypeChecker/Monad.hs | 1 + src/Language/PureScript/TypeChecker/Types.hs | 19 ++++++++++++-- 8 files changed, 70 insertions(+), 3 deletions(-) create mode 100644 examples/failing/TypedHole.purs diff --git a/examples/failing/TypedHole.purs b/examples/failing/TypedHole.purs new file mode 100644 index 0000000000..c371e67d0e --- /dev/null +++ b/examples/failing/TypedHole.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith HoleInferredType +module Main where + +import Prelude +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) + +main :: forall e. Eff (console :: CONSOLE | e) Unit +main = ?ummm diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 868c1200fc..32e217ef5a 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -440,6 +440,10 @@ data Expr -- | AnonymousArgument -- | + -- A typed hole that will be turned into a hint/error duing typechecking + -- + | Hole String + -- | -- A value with source position information -- | PositionedValue SourceSpan [Comment] Expr diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index eee602eb1b..29508b4afc 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -10,7 +10,7 @@ import Prelude.Compat import Data.Ord (comparing) import Data.Char (isSpace) import Data.Either (lefts, rights) -import Data.List (intercalate, transpose, nub, nubBy, sortBy) +import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition) import Data.Foldable (fold) import Data.Maybe (maybeToList) @@ -128,6 +128,7 @@ data SimpleErrorMessage | ShadowedTypeVar String | UnusedTypeVar String | WildcardInferredType Type + | HoleInferredType String Type | MissingTypeDeclaration Ident Type | NotExhaustivePattern [[Binder]] Bool | OverlappingPattern [[Binder]] Bool @@ -316,6 +317,7 @@ errorCode em = case unwrapErrorMessage em of ShadowedTypeVar{} -> "ShadowedTypeVar" UnusedTypeVar{} -> "UnusedTypeVar" WildcardInferredType{} -> "WildcardInferredType" + HoleInferredType{} -> "HoleInferredType" MissingTypeDeclaration{} -> "MissingTypeDeclaration" NotExhaustivePattern{} -> "NotExhaustivePattern" OverlappingPattern{} -> "OverlappingPattern" @@ -435,6 +437,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty + gSimple (HoleInferredType name ty) = HoleInferredType name <$> f ty gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty @@ -872,6 +875,10 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap paras [ line "Wildcard type definition has the inferred type " , indent $ typeAsBox ty ] + renderSimpleErrorMessage (HoleInferredType name ty) = + paras [ line $ "Hole '" ++ name ++ "' has the inferred type " + , indent $ typeAsBox ty + ] renderSimpleErrorMessage (MissingTypeDeclaration ident ty) = paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "." , line "It is good practice to provide type declarations as a form of documentation." @@ -1362,6 +1369,22 @@ warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se +-- | +-- Runs a computation listening for warnings and then escalating any warnings +-- that match the predicate to error status. +-- +escalateWarningWhen + :: (MonadWriter MultipleErrors m, MonadError MultipleErrors m) + => (ErrorMessage -> Bool) + -> m a + -> m a +escalateWarningWhen isError ma = do + (a, w) <- censor (const mempty) $ listen ma + let (errors, warnings) = partition isError (runMultipleErrors w) + tell $ MultipleErrors warnings + unless (null errors) $ throwError $ MultipleErrors errors + return a + -- | -- Collect errors in in parallel -- diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 655e02799b..d2d4febb5f 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -392,6 +392,7 @@ parseValueAtom = P.choice , parseLet , P.try $ Parens <$> parens parseValue , parseOperatorSection + , parseHole ] -- | @@ -407,6 +408,9 @@ parseOperatorSection = parens $ left <|> right right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> indexersAndAccessors) left = flip OperatorSection <$> (Left <$> indexersAndAccessors) <* indented <*> parseInfixExpr +parseHole :: TokenParser Expr +parseHole = Hole <$> holeLit + parsePropertyUpdate :: TokenParser (String, Expr) parsePropertyUpdate = do name <- lname <|> stringLiteral diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 4cabc01991..82f0e3cf1e 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -48,6 +48,7 @@ module Language.PureScript.Parser.Lexer , semi , at , underscore + , holeLit , semiSep , semiSep1 , commaSep @@ -115,6 +116,7 @@ data Token | CharLiteral Char | StringLiteral String | Number (Either Integer Double) + | HoleLit String deriving (Show, Read, Eq, Ord) prettyPrintToken :: Token -> String @@ -146,6 +148,7 @@ prettyPrintToken (Symbol s) = s prettyPrintToken (CharLiteral c) = show c prettyPrintToken (StringLiteral s) = show s prettyPrintToken (Number n) = either show show n +prettyPrintToken (HoleLit name) = "?" ++ name data PositionedToken = PositionedToken { ptSourcePos :: P.SourcePos @@ -209,6 +212,7 @@ parseToken = P.choice , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore + , HoleLit <$> P.try (P.char '?' *> P.many1 identLetter) , LName <$> parseLName , do uName <- parseUName (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName) @@ -376,6 +380,12 @@ at = match At underscore :: TokenParser () underscore = match Underscore +holeLit :: TokenParser String +holeLit = token go P. "hole literal" + where + go (HoleLit n) = Just n + go _ = Nothing + -- | -- Parse zero or more values separated by semicolons -- diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index e5a04e8804..b50ce2d2f5 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -64,6 +64,7 @@ prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val prettyPrintValue d (Literal l) = prettyPrintLiteralValue d l +prettyPrintValue _ (Hole name) = text "?" <> text name prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index e4ac9d875c..c4e9450a85 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -225,6 +225,7 @@ runCheck = runCheck' initEnvironment -- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@. runCheck' :: (Functor m) => Environment -> StateT CheckState m a -> m (a, Environment) runCheck' env check = second checkEnv <$> runStateT check (emptyCheckState env) + -- | Make an assertion, failing with an error message guardWith :: (MonadError e m) => e -> Bool -> m () guardWith _ True = return () diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 8420da77c2..715e7aaff6 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -74,7 +74,7 @@ typesOf :: [(Ident, Expr)] -> m [(Ident, (Expr, Type))] typesOf bindingGroupType moduleName vals = do - tys <- fmap tidyUp . liftUnifyWarnings replace $ do + tys <- fmap tidyUp . escalateWarningWhen isHoleError . liftUnifyWarnings replace $ do (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict @@ -109,17 +109,28 @@ typesOf bindingGroupType moduleName vals = do checkDuplicateLabels val' return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized)) where + -- | Generalize type vars using forall and add inferred constraints generalize unsolved = varIfUnknown . constrain unsolved + -- | Add any unsolved constraints constrain [] = id constrain cs = ConstrainedType (map snd cs) + -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts + -- Replace all the wildcards types with their inferred types - replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints . WildcardInferredType $ substituteType sub ty + replace sub (ErrorMessage hints (WildcardInferredType ty)) = + ErrorMessage hints . WildcardInferredType $ substituteType sub ty + replace sub (ErrorMessage hints (HoleInferredType name ty)) = + ErrorMessage hints . HoleInferredType name $ substituteType sub ty replace _ em = em + isHoleError :: ErrorMessage -> Bool + isHoleError (ErrorMessage _ HoleInferredType{}) = True + isHoleError _ = False + type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) type UntypedData = [(Ident, Type)] @@ -316,6 +327,10 @@ infer' (TypedValue checkType val ty) = do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val return $ TypedValue True val' ty' +infer' (Hole name) = do + ty <- freshType + tell . errorMessage $ HoleInferredType name ty + return $ TypedValue True (Hole name) ty infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do TypedValue t v ty <- infer' val return $ TypedValue t (PositionedValue pos c v) ty From fea78a9401af0969e4f2b82aa474fde8fa080483 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 19 Apr 2016 20:30:19 +0100 Subject: [PATCH 0380/1580] Improved UTF8 handling in IDE server * Use readUTF8 file in IDE rebuild (@garyb) * read the Externs as ByteString intead of Text (@kRITZCREEK) --- src/Language/PureScript/Ide/Externs.hs | 5 +++-- src/Language/PureScript/Ide/Rebuild.hs | Bin 3532 -> 3582 bytes 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index de64116099..a08272240c 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -33,12 +33,13 @@ import Prelude.Compat import Control.Monad.Error.Class import Control.Monad.IO.Class +import Data.Aeson (decodeStrict) import Data.List (nub) import Data.Maybe (mapMaybe) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.IO as T +import qualified Data.ByteString as BS import Language.PureScript.Ide.Error (PscIdeError (..)) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util @@ -49,7 +50,7 @@ import qualified Language.PureScript.Externs as PE readExternFile :: (MonadIO m, MonadError PscIdeError m) => FilePath -> m PE.ExternsFile readExternFile fp = do - parseResult <- liftIO (decodeT <$> T.readFile fp) + parseResult <- liftIO (decodeStrict <$> BS.readFile fp) case parseResult of Nothing -> throwError . GeneralError $ "Parsing the extern at: " ++ fp ++ " failed" Just externs -> pure externs diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 007d8e92f3a599951dd190dce3eeaef2b4f5e9c8..d65af8974e9fe691666c31cde4989481722d6d42 100644 GIT binary patch delta 51 zcmX>j{ZD#BGRtH`770;Lf4$HUHwy)gqSV9`5X&tyCv|cn%M=z6XY*GUYmUi=yt4tZ CxDb~B delta 22 ecmew-eMWjiGRx#iER!~Cuv&94GE7e9oecnFmr From a1338e5bd7a3e9aaeccaabae9aa105348257cf56 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 19 Apr 2016 20:52:19 +0100 Subject: [PATCH 0381/1580] Bump to 0.8.5 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 2b3ebef555..cf82b2e641 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.8.4.0 +version: 0.8.5.0 cabal-version: >=1.8 build-type: Simple license: MIT From ae3ce067557711cff94508e0c05a8ed7c525bc66 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Tue, 19 Apr 2016 22:59:15 +0100 Subject: [PATCH 0382/1580] Update PSCi `:show import` For #2040 * Removed deprecated `qualified` keyword * Added imported names list to qualified imports --- psci/PSCi.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 5e6319afdb..fc9f695ce0 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -243,9 +243,8 @@ handleShowImportedModules = do where showModules = return . unlines . sort . map showModule showModule (mn, declType, asQ) = - "import " ++ case asQ of - Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn' - Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType + "import " ++ N.runModuleName mn ++ showDeclType declType ++ + foldMap (\mn' -> " as " ++ N.runModuleName mn') asQ showDeclType P.Implicit = "" showDeclType (P.Explicit refs) = refsList refs From 56bbac58cc13aab7864cc9b70d8e95727ee28674 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 19 Apr 2016 20:53:37 -0700 Subject: [PATCH 0383/1580] Fix #2042, use JSON for parser errors in rebuild --- src/Language/PureScript/Ide/Rebuild.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index d65af8974e..4d56855216 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -37,7 +37,7 @@ rebuildFile path = do m <- case map snd <$> P.parseModulesFromFiles id [(path, input)] of Left parseError -> - throwError . GeneralError $ P.prettyPrintMultipleErrors False parseError + throwError . RebuildError . toJSONErrors False P.Error $ parseError Right [m] -> pure m Right _ -> throwError . GeneralError $ "Please define exactly one module." From 56df015d24d1077a816f09874f82a54f91ca69e9 Mon Sep 17 00:00:00 2001 From: Jonas Platte Date: Wed, 20 Apr 2016 15:58:35 +0200 Subject: [PATCH 0384/1580] Add --as-needed linker option to stop linking against unused shared objects --- purescript.cabal | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index cf82b2e641..18dabdd812 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -244,6 +244,7 @@ executable psc hs-source-dirs: psc other-modules: Paths_purescript ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N" + ld-options: -Wl,--as-needed executable psci build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, @@ -267,6 +268,7 @@ executable psci PSCi.Printer Paths_purescript ghc-options: -Wall -O2 + ld-options: -Wl,--as-needed executable psc-docs build-depends: base >=4 && <5, purescript -any, @@ -282,6 +284,7 @@ executable psc-docs Etags Tags ghc-options: -Wall -O2 + ld-options: -Wl,--as-needed executable psc-publish build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any @@ -290,6 +293,7 @@ executable psc-publish buildable: True hs-source-dirs: psc-publish ghc-options: -Wall -O2 + ld-options: -Wl,--as-needed executable psc-hierarchy build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.12.1, @@ -299,13 +303,12 @@ executable psc-hierarchy other-modules: Paths_purescript buildable: True hs-source-dirs: hierarchy - other-modules: ghc-options: -Wall -O2 + ld-options: -Wl,--as-needed executable psc-bundle main-is: Main.hs other-modules: Paths_purescript - other-extensions: build-depends: base >=4 && <5, purescript -any, filepath -any, @@ -315,13 +318,13 @@ executable psc-bundle transformers-compat -any, optparse-applicative >= 0.12.1, Glob -any - ghc-options: -Wall -O2 hs-source-dirs: psc-bundle + ghc-options: -Wall -O2 + ld-options: -Wl,--as-needed executable psc-ide-server main-is: Main.hs other-modules: Paths_purescript - other-extensions: build-depends: base >=4 && <5 , purescript -any , directory -any @@ -335,21 +338,22 @@ executable psc-ide-server , stm -any , text -any , base-compat >=0.6.0 - ghc-options: -Wall -O2 -threaded hs-source-dirs: psc-ide-server + ghc-options: -Wall -O2 -threaded + ld-options: -Wl,--as-needed executable psc-ide-client main-is: Main.hs other-modules: Paths_purescript - other-extensions: build-depends: base >=4 && <5 , mtl -any , text -any , optparse-applicative >= 0.12.1 , network -any , base-compat >=0.6.0 - ghc-options: -Wall -O2 hs-source-dirs: psc-ide-client + ghc-options: -Wall -O2 + ld-options: -Wl,--as-needed test-suite tests build-depends: base >=4 && <5, containers -any, directory -any, @@ -359,7 +363,6 @@ test-suite tests base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any, boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any, vector -any, utf8-string -any - ghc-options: -Wall type: exitcode-stdio-1.0 main-is: Main.hs other-modules: TestUtils @@ -383,3 +386,5 @@ test-suite tests PSCi.Types buildable: True hs-source-dirs: tests psci + ghc-options: -Wall + ld-options: -Wl,--as-needed From 6dca01fcfb8c94af43b4805ebd9c51d2767e606a Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Wed, 20 Apr 2016 00:21:12 +0100 Subject: [PATCH 0385/1580] Fix some pretty printing issues --- src/Language/PureScript/Parser/Lexer.hs | 24 +++++++++++++++++++++++- src/Language/PureScript/Pretty/Common.hs | 6 +++--- src/Language/PureScript/Pretty/Values.hs | 2 +- 3 files changed, 27 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 82f0e3cf1e..e7f14b329b 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -69,12 +69,13 @@ module Language.PureScript.Parser.Lexer , reservedPsNames , reservedTypeNames , isSymbolChar + , isUnquotedKey ) where import Prelude hiding (lex) -import Data.Char (isSpace, isAscii, isSymbol) +import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum) import Control.Monad (void, guard) import Data.Functor.Identity @@ -534,3 +535,24 @@ reservedTypeNames = [ "forall", "where" ] -- isSymbolChar :: Char -> Bool isSymbolChar c = (c `elem` ":!#$%&*+./<=>?@\\^|-~") || (not (isAscii c) && isSymbol c) + + +-- | +-- The characters allowed in the head of an unquoted record key +-- +isUnquotedKeyHeadChar :: Char -> Bool +isUnquotedKeyHeadChar c = (c == '_') || isAlphaNum c + +-- | +-- The characters allowed in the tail of an unquoted record key +-- +isUnquotedKeyTailChar :: Char -> Bool +isUnquotedKeyTailChar c = (c `elem` "_'") || isAlphaNum c + +-- | +-- Strings allowed to be left unquoted in a record key +-- +isUnquotedKey :: String -> Bool +isUnquotedKey [] = False +isUnquotedKey (hd : tl) = isUnquotedKeyHeadChar hd && + all isUnquotedKeyTailChar tl diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index c2ff4d4683..a6f0f4dff2 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -23,7 +23,7 @@ import Prelude.Compat import Control.Monad.State (StateT, modify, get) import Data.List (elemIndices, intersperse) -import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar) +import Language.PureScript.Parser.Lexer (reservedPsNames, isUnquotedKey) import Language.PureScript.AST (SourcePos(..), SourceSpan(..)) import Text.PrettyPrint.Boxes @@ -155,8 +155,8 @@ prettyPrintMany f xs = do -- prettyPrintObjectKey :: String -> String prettyPrintObjectKey s | s `elem` reservedPsNames = show s - | any isSymbolChar s = show s - | otherwise = s + | isUnquotedKey s = s + | otherwise = show s -- | Place a box before another, vertically when the first box takes up multiple lines. before :: Box -> Box -> Box diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index b50ce2d2f5..edeadfcd23 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -41,7 +41,7 @@ prettyPrintValue d (IfThenElse cond th el) = // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th , text "else " <> prettyPrintValueAtom (d - 1) el ]) -prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ show prop) +prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ prettyPrintObjectKey prop) prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) From 2fc447fad0e6b42fdb6030c6ea23d74030b1d5fb Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 20 Apr 2016 16:01:40 -0700 Subject: [PATCH 0386/1580] Revert "Add --as-needed linker option to stop linking against unused shared objects" --- purescript.cabal | 21 ++++++++------------- 1 file changed, 8 insertions(+), 13 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 18dabdd812..cf82b2e641 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -244,7 +244,6 @@ executable psc hs-source-dirs: psc other-modules: Paths_purescript ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N" - ld-options: -Wl,--as-needed executable psci build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, @@ -268,7 +267,6 @@ executable psci PSCi.Printer Paths_purescript ghc-options: -Wall -O2 - ld-options: -Wl,--as-needed executable psc-docs build-depends: base >=4 && <5, purescript -any, @@ -284,7 +282,6 @@ executable psc-docs Etags Tags ghc-options: -Wall -O2 - ld-options: -Wl,--as-needed executable psc-publish build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any @@ -293,7 +290,6 @@ executable psc-publish buildable: True hs-source-dirs: psc-publish ghc-options: -Wall -O2 - ld-options: -Wl,--as-needed executable psc-hierarchy build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.12.1, @@ -303,12 +299,13 @@ executable psc-hierarchy other-modules: Paths_purescript buildable: True hs-source-dirs: hierarchy + other-modules: ghc-options: -Wall -O2 - ld-options: -Wl,--as-needed executable psc-bundle main-is: Main.hs other-modules: Paths_purescript + other-extensions: build-depends: base >=4 && <5, purescript -any, filepath -any, @@ -318,13 +315,13 @@ executable psc-bundle transformers-compat -any, optparse-applicative >= 0.12.1, Glob -any - hs-source-dirs: psc-bundle ghc-options: -Wall -O2 - ld-options: -Wl,--as-needed + hs-source-dirs: psc-bundle executable psc-ide-server main-is: Main.hs other-modules: Paths_purescript + other-extensions: build-depends: base >=4 && <5 , purescript -any , directory -any @@ -338,22 +335,21 @@ executable psc-ide-server , stm -any , text -any , base-compat >=0.6.0 - hs-source-dirs: psc-ide-server ghc-options: -Wall -O2 -threaded - ld-options: -Wl,--as-needed + hs-source-dirs: psc-ide-server executable psc-ide-client main-is: Main.hs other-modules: Paths_purescript + other-extensions: build-depends: base >=4 && <5 , mtl -any , text -any , optparse-applicative >= 0.12.1 , network -any , base-compat >=0.6.0 - hs-source-dirs: psc-ide-client ghc-options: -Wall -O2 - ld-options: -Wl,--as-needed + hs-source-dirs: psc-ide-client test-suite tests build-depends: base >=4 && <5, containers -any, directory -any, @@ -363,6 +359,7 @@ test-suite tests base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any, boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any, vector -any, utf8-string -any + ghc-options: -Wall type: exitcode-stdio-1.0 main-is: Main.hs other-modules: TestUtils @@ -386,5 +383,3 @@ test-suite tests PSCi.Types buildable: True hs-source-dirs: tests psci - ghc-options: -Wall - ld-options: -Wl,--as-needed From b34f5f94387d21f9ee81d0ad581c5c063be2abea Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 30 Apr 2016 14:33:22 -0700 Subject: [PATCH 0387/1580] Remove --require-path completely, merge #1996 --- psc-bundle/Main.hs | 12 +---------- psc/Main.hs | 7 ------- src/Language/PureScript/Bundle.hs | 30 +++++++++++++-------------- src/Language/PureScript/CodeGen/JS.hs | 3 +-- src/Language/PureScript/Make.hs | 5 +---- src/Language/PureScript/Options.hs | 5 +---- 6 files changed, 18 insertions(+), 44 deletions(-) diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index a1051cac87..5e214847d6 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -6,7 +6,6 @@ -- | Bundles compiled PureScript modules for the browser. module Main (main) where -import Data.Maybe import Data.Traversable (for) import Data.Version (showVersion) @@ -36,7 +35,6 @@ data Options = Options , optionsEntryPoints :: [String] , optionsMainModule :: Maybe String , optionsNamespace :: String - , optionsRequirePath :: Maybe FilePath } deriving Show -- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier. @@ -63,7 +61,7 @@ app Options{..} = do let entryIds = map (`ModuleIdentifier` Regular) optionsEntryPoints - bundle input entryIds optionsMainModule optionsNamespace optionsRequirePath + bundle input entryIds optionsMainModule optionsNamespace -- | Command line options parser. options :: Parser Options @@ -72,7 +70,6 @@ options = Options <$> some inputFile <*> many entryPoint <*> optional mainModule <*> namespace - <*> optional requirePath where inputFile :: Parser FilePath inputFile = strArgument $ @@ -104,19 +101,12 @@ options = Options <$> some inputFile <> showDefault <> help "Specify the namespace that PureScript modules will be exported to when running in the browser." - requirePath :: Parser FilePath - requirePath = strOption $ - short 'r' - <> long "require-path" - <> help "The path prefix used in require() calls in the generated JavaScript [deprecated]" - -- | Make it go. main :: IO () main = do hSetEncoding stdout utf8 hSetEncoding stderr utf8 opts <- execParser (info (version <*> helper <*> options) infoModList) - when (isJust (optionsRequirePath opts)) $ hPutStrLn stderr "The require-path option is deprecated and will be removed in PureScript 0.9." output <- runExceptT (app opts) case output of Left err -> do diff --git a/psc/Main.hs b/psc/Main.hs index 91a6f45a0e..ad0be5d519 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -119,12 +119,6 @@ outputDirectory = strOption $ <> showDefault <> help "The output directory" -requirePath :: Parser (Maybe FilePath) -requirePath = optional $ strOption $ - short 'r' - <> long "require-path" - <> help "The path prefix to use for require() calls in the generated JavaScript [deprecated]" - noTco :: Parser Bool noTco = switch $ long "no-tco" @@ -175,7 +169,6 @@ options = P.Options <$> noTco <*> noOpts <*> verboseErrors <*> (not <$> comments) - <*> requirePath <*> sourceMaps pscMakeOptions :: Parser PSCMakeOptions diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 13f6605c97..60f1d8708a 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -34,7 +34,7 @@ import Prelude () import Prelude.Compat import Data.List (nub, stripPrefix) -import Data.Maybe (mapMaybe, catMaybes, fromMaybe) +import Data.Maybe (mapMaybe, catMaybes) import Data.Generics (everything, everywhere, mkQ, mkT) import Data.Graph import Data.Version (showVersion) @@ -134,13 +134,13 @@ printErrorMessage (ErrorInModule mid e) = name ++ " (" ++ showModuleType ty ++ ")" -- | Calculate the ModuleIdentifier which a require(...) statement imports. -checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier -checkImportPath _ "./foreign" m _ = +checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier +checkImportPath "./foreign" m _ = Right (ModuleIdentifier (moduleName m) Foreign) -checkImportPath requirePath name _ names - | Just name' <- stripPrefix (fromMaybe "../" requirePath) name +checkImportPath name _ names + | Just name' <- stripPrefix "../" name , name' `S.member` names = Right (ModuleIdentifier name' Regular) -checkImportPath _ name _ _ = Left name +checkImportPath name _ _ = Left name -- | Compute the dependencies of all elements in a module, and add them to the tree. -- @@ -222,8 +222,8 @@ trailingCommaList (JSCTLNone l) = commaList l -- -- Each type of module element is matched using pattern guards, and everything else is bundled into the -- Other constructor. -toModule :: forall m. (MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSAST -> m Module -toModule requirePath mids mid top +toModule :: forall m. (MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSAST -> m Module +toModule mids mid top | JSAstProgram smts _ <- top = Module mid <$> traverse toModuleElement smts | otherwise = err InvalidTopLevel where @@ -231,7 +231,7 @@ toModule requirePath mids mid top toModuleElement :: JSStatement -> m ModuleElement toModuleElement stmt - | Just (importName, importPath) <- matchRequire requirePath mids mid stmt + | Just (importName, importPath) <- matchRequire mids mid stmt = pure (Require stmt importName importPath) toModuleElement stmt | Just (exported, name, decl) <- matchMember stmt @@ -291,12 +291,11 @@ getExportedIdentifiers mname top -- Matches JS statements like this: -- var ModuleName = require("file"); -matchRequire :: Maybe FilePath - -> S.Set String +matchRequire :: S.Set String -> ModuleIdentifier -> JSStatement -> Maybe (String, Either String ModuleIdentifier) -matchRequire requirePath mids mid stmt +matchRequire mids mid stmt | JSVariable _ jsInit _ <- stmt , [JSVarInitExpression var varInit] <- commaList jsInit , JSIdentifier _ importName <- var @@ -304,7 +303,7 @@ matchRequire requirePath mids mid stmt , JSMemberExpression req _ argsE _ <- jsInitEx , JSIdentifier _ "require" <- req , [ Just importPath ] <- map fromStringLiteral (commaList argsE) - , importPath' <- checkImportPath requirePath importPath mid mids + , importPath' <- checkImportPath importPath mid mids = Just (importName, importPath') | otherwise = Nothing @@ -590,16 +589,15 @@ bundle :: (MonadError ErrorMessage m) -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination -> Maybe String -- ^ An optional main module. -> String -- ^ The namespace (e.g. PS). - -> Maybe FilePath -- ^ The require path prefix -> m String -bundle inputStrs entryPoints mainModule namespace requirePath = do +bundle inputStrs entryPoints mainModule namespace = do input <- forM inputStrs $ \(ident, js) -> do ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident) return (ident, ast) let mids = S.fromList (map (moduleName . fst) input) - modules <- traverse (fmap withDeps . uncurry (toModule requirePath mids)) input + modules <- traverse (fmap withDeps . uncurry (toModule mids)) input let compiled = compile modules entryPoints sorted = sortModules (filter (not . isModuleEmpty) compiled) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index d4a1e8fc02..1a14fc8e3c 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -109,9 +109,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS importToJs mnLookup mn' = do - path <- asks optionsRequirePath let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (fromMaybe ".." path runModuleName mn')] + let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (".." runModuleName mn')] withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody) -- | diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index b0c1ccd6ac..52239c6454 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -42,7 +42,7 @@ import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Concurrent.Lifted as C import Data.List (foldl', sort) -import Data.Maybe (fromMaybe, catMaybes, isJust) +import Data.Maybe (fromMaybe, catMaybes) import Data.Either (partitionEithers) import Data.Time.Clock import Data.String (fromString) @@ -181,9 +181,6 @@ make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadE -> [Module] -> m Environment make ma@MakeActions{..} ms = do - requirePath <- asks optionsRequirePath - when (isJust requirePath) $ tell $ errorMessage DeprecatedRequirePath - checkModuleNamesAreUnique (sorted, graph) <- sortModules ms diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index a68bb9f8a7..a207a923f5 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -38,9 +38,6 @@ data Options = Options { -- | -- Remove the comments from the generated js , optionsNoComments :: Bool - -- | - -- The path to prepend to require statements - , optionsRequirePath :: Maybe FilePath -- | -- Generate soure maps , optionsSourceMaps :: Bool @@ -49,4 +46,4 @@ data Options = Options { -- | -- Default make options defaultOptions :: Options -defaultOptions = Options False False Nothing False False False Nothing False +defaultOptions = Options False False Nothing False False False False From 7fcebc8f37f3b236958aa3ae23d78d0938901173 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 30 Apr 2016 14:34:04 -0700 Subject: [PATCH 0388/1580] Remove qualified keyword, merge #1997 --- examples/failing/OverlappingReExport.purs | 2 +- examples/passing/AutoPrelude2.purs | 2 +- examples/passing/ModuleExportQualified.purs | 2 +- examples/passing/OptionalQualified.purs | 3 +-- .../passing/QualifiedQualifiedImports.purs | 2 +- examples/passing/ReExportQualified.purs | 2 +- psci/PSCi/Completion.hs | 7 ++---- psci/PSCi/Module.hs | 2 +- psci/PSCi/Parser.hs | 2 +- src/Language/PureScript/AST/Declarations.hs | 7 +++--- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- src/Language/PureScript/Errors.hs | 11 --------- src/Language/PureScript/Externs.hs | 2 +- src/Language/PureScript/Ide/Imports.hs | 9 ++++---- src/Language/PureScript/Ide/Rebuild.hs | 2 +- src/Language/PureScript/Ide/SourceFile.hs | 6 ++--- src/Language/PureScript/Linter/Imports.hs | 4 ++-- src/Language/PureScript/ModuleDependencies.hs | 4 ++-- .../PureScript/Parser/Declarations.hs | 23 ++++++------------- .../PureScript/Sugar/Names/Imports.hs | 9 ++++---- tests/TestPsci.hs | 4 +--- 21 files changed, 39 insertions(+), 68 deletions(-) diff --git a/examples/failing/OverlappingReExport.purs b/examples/failing/OverlappingReExport.purs index af85a5a534..8c38c4561d 100644 --- a/examples/failing/OverlappingReExport.purs +++ b/examples/failing/OverlappingReExport.purs @@ -7,4 +7,4 @@ module B where module C (module A, module M2) where import A - import qualified B as M2 + import B as M2 diff --git a/examples/passing/AutoPrelude2.purs b/examples/passing/AutoPrelude2.purs index 373c38079b..4db3aaf14a 100644 --- a/examples/passing/AutoPrelude2.purs +++ b/examples/passing/AutoPrelude2.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import qualified Prelude as P +import Prelude as P import Control.Monad.Eff.Console f :: forall a. a -> a diff --git a/examples/passing/ModuleExportQualified.purs b/examples/passing/ModuleExportQualified.purs index 88fa20edf5..0c1892361c 100644 --- a/examples/passing/ModuleExportQualified.purs +++ b/examples/passing/ModuleExportQualified.purs @@ -3,7 +3,7 @@ module A (module Prelude) where module Main where import Control.Monad.Eff.Console - import qualified A as B + import A as B main = do print (B.show 1.0) diff --git a/examples/passing/OptionalQualified.purs b/examples/passing/OptionalQualified.purs index fccfd7ae4b..de5b8749cf 100644 --- a/examples/passing/OptionalQualified.purs +++ b/examples/passing/OptionalQualified.purs @@ -1,7 +1,6 @@ module Main where --- qualified import with the "qualified" keyword -import qualified Prelude as P +import Prelude as P -- qualified import without the "qualified" keyword import Control.Monad.Eff.Console as Console diff --git a/examples/passing/QualifiedQualifiedImports.purs b/examples/passing/QualifiedQualifiedImports.purs index 91c188c275..77401b205c 100644 --- a/examples/passing/QualifiedQualifiedImports.purs +++ b/examples/passing/QualifiedQualifiedImports.purs @@ -1,6 +1,6 @@ module Main where -- qualified import with qualified imported names -import qualified Control.Monad.Eff.Console (log) as Console +import Control.Monad.Eff.Console (log) as Console main = Console.log "Success!" diff --git a/examples/passing/ReExportQualified.purs b/examples/passing/ReExportQualified.purs index cf1c037cf8..e85ecee236 100644 --- a/examples/passing/ReExportQualified.purs +++ b/examples/passing/ReExportQualified.purs @@ -6,7 +6,7 @@ module B where module C (module A, module M2) where import A - import qualified B as M2 + import B as M2 module Main where diff --git a/psci/PSCi/Completion.hs b/psci/PSCi/Completion.hs index 26965e7c71..4e7f2f1bc1 100644 --- a/psci/PSCi/Completion.hs +++ b/psci/PSCi/Completion.hs @@ -7,7 +7,6 @@ import Prelude.Compat import Data.Maybe (mapMaybe) import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix) -import Data.Char (isUpper) import Data.Function (on) import Control.Arrow (second) @@ -87,10 +86,8 @@ directiveArg _ Kind = [CtxType] completeImport :: [String] -> String -> [CompletionContext] completeImport ws w' = case (ws, w') of - (["import"], w) | headSatisfies isUpper w -> [CtxModule] - (["import"], _) -> [CtxModule, CtxFixed "qualified"] - (["import", "qualified"], _) -> [CtxModule] - _ -> [] + (["import"], _) -> [CtxModule] + _ -> [] headSatisfies :: (a -> Bool) -> [a] -> Bool headSatisfies p str = diff --git a/psci/PSCi/Module.hs b/psci/PSCi/Module.hs index bda5116f4c..b97f1d52bd 100644 --- a/psci/PSCi/Module.hs +++ b/psci/PSCi/Module.hs @@ -98,7 +98,7 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} = P.Module (P.internalModuleSourceSpan "") [] moduleName (importDecl `map` imports) Nothing importDecl :: ImportedModule -> P.Declaration -importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False +importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ indexFile :: FilePath indexFile = ".psci_modules" ++ pathSeparator : "index.js" diff --git a/psci/PSCi/Parser.hs b/psci/PSCi/Parser.hs index 526f3d6eac..ec7a4e9eab 100644 --- a/psci/PSCi/Parser.hs +++ b/psci/PSCi/Parser.hs @@ -107,7 +107,7 @@ psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls) -- :show import works, for example. psciImport :: P.TokenParser Command psciImport = do - (mn, declType, asQ, _) <- P.parseImportDeclaration' + (mn, declType, asQ) <- P.parseImportDeclaration' return $ Import (mn, declType, asQ) -- | Any other declaration that we don't need a 'special case' parser for diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 32e217ef5a..1585a73dd6 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -47,9 +47,9 @@ getModuleName (Module _ _ name _ _) = name addDefaultImport :: ModuleName -> Module -> Module addDefaultImport toImport m@(Module ss coms mn decls exps) = if isExistingImport `any` decls || mn == toImport then m - else Module ss coms mn (ImportDeclaration toImport Implicit Nothing False : decls) exps + else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps where - isExistingImport (ImportDeclaration mn' _ _ _) | mn' == toImport = True + isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d isExistingImport _ = False @@ -198,9 +198,8 @@ data Declaration | FixityDeclaration Fixity String (Maybe (Qualified FixityAlias)) -- | -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name) - -- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9) -- - | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName) Bool + | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName) -- | -- A type class declaration (name, argument, implies, member declarations) -- diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index fc782e6c48..f3fdc64b33 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -230,7 +230,7 @@ findQualModules decls = -- Desugars import declarations from AST to CoreFn representation. -- importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName) -importToCoreFn (A.ImportDeclaration name _ _ _) = Just (nullAnn, name) +importToCoreFn (A.ImportDeclaration name _ _) = Just (nullAnn, name) importToCoreFn (A.PositionedDeclaration ss _ d) = ((,) (Just ss, [], Nothing, Nothing) . snd) <$> importToCoreFn d importToCoreFn _ = Nothing diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 29508b4afc..c494631949 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -142,7 +142,6 @@ data SimpleErrorMessage | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName] | DeprecatedOperatorDecl String | DeprecatedOperatorSection Expr (Either Expr Expr) - | DeprecatedQualifiedSyntax ModuleName ModuleName | DeprecatedClassImport ModuleName (ProperName 'ClassName) | DeprecatedClassExport (ProperName 'ClassName) | DuplicateSelectiveImport ModuleName @@ -331,7 +330,6 @@ errorCode em = case unwrapErrorMessage em of UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport" DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl" DeprecatedOperatorSection{} -> "DeprecatedOperatorSection" - DeprecatedQualifiedSyntax{} -> "DeprecatedQualifiedSyntax" DeprecatedClassImport{} -> "DeprecatedClassImport" DeprecatedClassExport{} -> "DeprecatedClassExport" DuplicateSelectiveImport{} -> "DuplicateSelectiveImport" @@ -463,8 +461,6 @@ errorSuggestion err = case err of UnusedImport{} -> emptySuggestion RedundantEmptyHidingImport{} -> emptySuggestion DuplicateImport{} -> emptySuggestion - DeprecatedQualifiedSyntax name qualName -> suggest $ - "import " ++ runModuleName name ++ " as " ++ runModuleName qualName UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) @@ -951,13 +947,6 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap renderOperator (PositionedValue _ _ ex) = renderOperator ex renderOperator (Var (Qualified _ (Op ident))) = line ident renderOperator other = Box.hcat Box.top [ line "`", prettyPrintValue valueDepth other, line "`" ] - renderSimpleErrorMessage (DeprecatedQualifiedSyntax name qualName) = - paras [ line "Import uses the deprecated 'qualified' syntax:" - , indent $ line $ "import qualified " ++ runModuleName name ++ " as " ++ runModuleName qualName - , line "Should instead use the form:" - , indent $ line $ "import " ++ runModuleName name ++ " as " ++ runModuleName qualName - , line "The deprecated syntax will be removed in PureScript 0.9." - ] renderSimpleErrorMessage (DeprecatedClassImport mn name) = paras [ line $ "Class import from " ++ runModuleName mn ++ " uses deprecated syntax that omits the 'class' keyword:" diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index f9617d5e02..f2de40f27c 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -165,7 +165,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} fixityDecl _ = Nothing importDecl :: Declaration -> Maybe ExternsImport - importDecl (ImportDeclaration m mt qmn _) = Just (ExternsImport m mt qmn) + importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn) importDecl (PositionedDeclaration _ _ d) = importDecl d importDecl _ = Nothing diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index c02fb992d6..000e8056b0 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -95,9 +95,9 @@ parseImportsWithModuleName ls = do (P.Module _ _ mn decls _) <- moduleParse ls pure (mn, concatMap mkImport (unwrapPositioned <$> decls)) where - mkImport (P.ImportDeclaration mn (P.Explicit refs) qual _) = + mkImport (P.ImportDeclaration mn (P.Explicit refs) qual) = [Import mn (P.Explicit (unwrapPositionedRef <$> refs)) qual] - mkImport (P.ImportDeclaration mn it qual _) = [Import mn it qual] + mkImport (P.ImportDeclaration mn it qual) = [Import mn it qual] mkImport _ = [] sliceImportSection :: [Text] -> Either String (P.ModuleName, [Text], [Import], [Text]) @@ -348,8 +348,7 @@ parseImport :: Text -> Maybe Import parseImport t = case P.lex "" (T.unpack t) >>= P.runTokenParser "" P.parseImportDeclaration' of - Right (mn, P.Explicit refs, mmn, _) -> + Right (mn, P.Explicit refs, mmn) -> Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn) - Right (mn, idt, mmn, _) -> Just (Import mn idt mmn) + Right (mn, idt, mmn) -> Just (Import mn idt mmn) Left _ -> Nothing - diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 4d56855216..78e9aa2527 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -78,7 +78,7 @@ sortExterns m ex = do mkShallowModule P.ExternsFile{..} = P.Module undefined [] efModuleName (map mkImport efImports) Nothing mkImport (P.ExternsImport mn it iq) = - P.ImportDeclaration mn it iq False + P.ImportDeclaration mn it iq getExtern mn = M.lookup mn ex -- Sort a list so its elements appear in the same order as in another list. inOrderOf :: (Ord a) => [a] -> [a] -> [a] diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index d687285c72..f142428d86 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -68,14 +68,14 @@ getImportsForFile fp = do let imports = getImports module' pure (mkModuleImport . unwrapPositionedImport <$> imports) where - mkModuleImport (D.ImportDeclaration mn importType' qualifier _) = + mkModuleImport (D.ImportDeclaration mn importType' qualifier) = ModuleImport (T.pack (N.runModuleName mn)) importType' (T.pack . N.runModuleName <$> qualifier) mkModuleImport _ = error "Shouldn't have gotten anything but Imports here" - unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier b) = - D.ImportDeclaration mn (unwrapImportType importType') qualifier b + unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier) = + D.ImportDeclaration mn (unwrapImportType importType') qualifier unwrapPositionedImport x = x unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls) unwrapImportType (D.Hiding decls) = D.Hiding (map unwrapPositionedRef decls) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index f80a2641b8..855327ef8b 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -112,8 +112,8 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do where countOpenImports :: Declaration -> Int - countOpenImports (ImportDeclaration mn' Implicit Nothing _) | not (isPrim mn') = 1 - countOpenImports (ImportDeclaration mn' (Hiding _) Nothing _) | not (isPrim mn') = 1 + countOpenImports (ImportDeclaration mn' Implicit Nothing) | not (isPrim mn') = 1 + countOpenImports (ImportDeclaration mn' (Hiding _) Nothing) | not (isPrim mn') = 1 countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d countOpenImports _ = 0 diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 39296fed21..2bff74a8a4 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -47,7 +47,7 @@ sortModules ms = do -- Extract module names that have been brought into scope by an `as` import. extractQualAs :: Declaration -> [ModuleName] extractQualAs (PositionedDeclaration _ _ d) = extractQualAs d - extractQualAs (ImportDeclaration _ _ (Just am) _) = [am] + extractQualAs (ImportDeclaration _ _ (Just am)) = [am] extractQualAs _ = [] -- | @@ -65,7 +65,7 @@ usedModules ams d = where forDecls :: Declaration -> [ModuleName] - forDecls (ImportDeclaration mn _ _ _) = + forDecls (ImportDeclaration mn _ _) = -- Regardless of whether an imported module is qualified we still need to -- take into account its import to build an accurate list of dependencies. [mn] diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index d2d4febb5f..095bd05445 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -132,28 +132,19 @@ parseFixityDeclaration = do parseImportDeclaration :: TokenParser Declaration parseImportDeclaration = do - (mn, declType, asQ, isOldSyntax) <- parseImportDeclaration' - return $ ImportDeclaration mn declType asQ isOldSyntax + (mn, declType, asQ) <- parseImportDeclaration' + return $ ImportDeclaration mn declType asQ -parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName, Bool) +parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName) parseImportDeclaration' = do reserved "import" indented - qualImport <|> stdImport + moduleName' <- moduleName + declType <- reserved "hiding" *> qualifyingList Hiding <|> qualifyingList Explicit + qName <- P.optionMaybe qualifiedName + return (moduleName', declType, qName) where - stdImport = do - moduleName' <- moduleName - declType <- reserved "hiding" *> qualifyingList Hiding <|> qualifyingList Explicit - qName <- P.optionMaybe qualifiedName - return (moduleName', declType, qName, False) qualifiedName = reserved "as" *> moduleName - qualImport = do - reserved "qualified" - indented - moduleName' <- moduleName - declType <- qualifyingList Explicit - qName <- qualifiedName - return (moduleName', declType, Just qName, True) qualifyingList expectedType = do declType <- P.optionMaybe (expectedType <$> (indented *> parens (commaSep parseDeclarationRef))) return $ fromMaybe Implicit declType diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 783a13d7a1..ff54bbb781 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -15,7 +15,7 @@ import Prelude.Compat import Data.Foldable (traverse_, for_) import Data.Function (on) import Data.List (find, sortBy, groupBy, (\\)) -import Data.Maybe (fromMaybe, isNothing, fromJust) +import Data.Maybe (fromMaybe, isNothing) import Data.Traversable (for) import Control.Arrow (first) @@ -43,8 +43,7 @@ findImports -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) findImports = foldM (go Nothing) M.empty where - go pos result (ImportDeclaration mn typ qual isOldSyntax) = do - when isOldSyntax . tell . errorMessage $ DeprecatedQualifiedSyntax mn (fromJust qual) + go pos result (ImportDeclaration mn typ qual) = do let imp = (pos, typ, qual) return $ M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result go _ result (PositionedDeclaration pos _ d) = warnAndRethrowWithPosition pos $ go (Just pos) result d @@ -137,13 +136,13 @@ resolveImports env (Module ss coms currentModule decls exps) = updateImportRef :: Declaration -> m Declaration updateImportRef (PositionedDeclaration pos com d) = warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d - updateImportRef (ImportDeclaration mn typ qual isOldSyntax) = do + updateImportRef (ImportDeclaration mn typ qual) = do modExports <- getExports env mn typ' <- case typ of Implicit -> return Implicit Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs - return $ ImportDeclaration mn typ' qual isOldSyntax + return $ ImportDeclaration mn typ' qual updateImportRef other = return other updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index ee0a2c1533..b7f1239ec2 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -60,7 +60,6 @@ completionTestData = -- import should complete module names , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"]) , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"]) - , ("import qualified Control.Monad.Eff.", map ("import qualified Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"]) -- :load, :module should complete file paths , (":l tests/support/psci/", [":l tests/support/psci/Sample.purs"]) @@ -91,8 +90,7 @@ completionTestData = -- a few other import tests , ("impor", ["import"]) - , ("import q", ["import qualified"]) - , ("import ", map ("import " ++) supportModules ++ ["import qualified"]) + , ("import ", map ("import " ++) supportModules) , ("import Prelude ", []) -- String and number literals should not be completed From 7e92e7cc1580dc6a6a787f4ab4f05f7647d9fec8 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 30 Apr 2016 14:37:58 -0700 Subject: [PATCH 0389/1580] Remove legacy operator sections, merge #2024 --- examples/failing/SuggestComposition.purs | 2 +- examples/passing/ConstraintInference.purs | 2 +- examples/passing/ContextSimplification.purs | 2 +- examples/passing/MonadState.purs | 2 +- examples/passing/OperatorSections.purs | 16 +++++----- src/Language/PureScript/AST/Declarations.hs | 4 --- src/Language/PureScript/AST/Traversals.hs | 14 --------- src/Language/PureScript/Errors.hs | 30 +------------------ src/Language/PureScript/Linter.hs | 1 - .../PureScript/Parser/Declarations.hs | 9 +----- src/Language/PureScript/Pretty/Values.hs | 3 -- src/Language/PureScript/Sugar.hs | 1 - .../PureScript/Sugar/ObjectWildcards.hs | 6 ++-- src/Language/PureScript/Sugar/Operators.hs | 24 --------------- 14 files changed, 18 insertions(+), 98 deletions(-) diff --git a/examples/failing/SuggestComposition.purs b/examples/failing/SuggestComposition.purs index b4196c2fd1..4fd84b4351 100644 --- a/examples/failing/SuggestComposition.purs +++ b/examples/failing/SuggestComposition.purs @@ -4,4 +4,4 @@ module SuggestComposition where import Prelude -f = g . g where g = (+1) +f = g . g where g = (_ + 1) diff --git a/examples/passing/ConstraintInference.purs b/examples/passing/ConstraintInference.purs index 1c97c66169..dd281e6b24 100644 --- a/examples/passing/ConstraintInference.purs +++ b/examples/passing/ConstraintInference.purs @@ -2,6 +2,6 @@ module Main where import Prelude -shout = Control.Monad.Eff.Console.log <<< (<> "!") <<< show +shout = Control.Monad.Eff.Console.log <<< (_ <> "!") <<< show main = shout "Done" diff --git a/examples/passing/ContextSimplification.purs b/examples/passing/ContextSimplification.purs index 88c5835281..cab8af50c6 100644 --- a/examples/passing/ContextSimplification.purs +++ b/examples/passing/ContextSimplification.purs @@ -3,7 +3,7 @@ module Main where import Prelude import Control.Monad.Eff.Console -shout = log <<< (<> "!") <<< show +shout = log <<< (_ <> "!") <<< show -- Here, we should simplify the context so that only one Show -- constraint is added. diff --git a/examples/passing/MonadState.purs b/examples/passing/MonadState.purs index 8d64394be1..653afaa2aa 100644 --- a/examples/passing/MonadState.purs +++ b/examples/passing/MonadState.purs @@ -58,4 +58,4 @@ modify f = same :: forall a. (a -> a) -> (a -> a) same = id -main = print $ runState 0 (modify (+ 1)) +main = print $ runState 0 (modify (_ + 1)) diff --git a/examples/passing/OperatorSections.purs b/examples/passing/OperatorSections.purs index 0143d346cd..b7237e3d10 100644 --- a/examples/passing/OperatorSections.purs +++ b/examples/passing/OperatorSections.purs @@ -4,14 +4,14 @@ import Prelude import Test.Assert main = do - assert $ (/ 2.0) 4.0 == 2.0 - assert $ (2.0 /) 4.0 == 0.5 - assert $ (`const` 1.0) 2.0 == 2.0 - assert $ (1.0 `const`) 2.0 == 1.0 + assert $ (_ / 2.0) 4.0 == 2.0 + assert $ (2.0 / _) 4.0 == 0.5 + assert $ (_ `const` 1.0) 2.0 == 2.0 + assert $ (1.0 `const` _) 2.0 == 1.0 let foo = { x: 2.0 } - assert $ (/ foo.x) 4.0 == 2.0 - assert $ (foo.x /) 4.0 == 0.5 + assert $ (_ / foo.x) 4.0 == 2.0 + assert $ (foo.x / _) 4.0 == 0.5 let (//) x y = x.x / y.x - assert $ (// foo { x = 4.0 }) { x: 4.0 } == 1.0 - assert $ (foo { x = 4.0 } //) { x: 4.0 } == 1.0 + assert $ (_ // foo { x = 4.0 }) { x: 4.0 } == 1.0 + assert $ (foo { x = 4.0 } // _) { x: 4.0 } == 1.0 Control.Monad.Eff.Console.log "Done!" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 1585a73dd6..d36aa81c97 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -360,10 +360,6 @@ data Expr -- | Parens Expr -- | - -- Operator section. This will be removed during desugaring and replaced with lambda. - -- - | OperatorSection Expr (Either Expr Expr) - -- | -- An object property getter (e.g. `_.x`). This will be removed during -- desugaring and expanded into a lambda that reads a property from an object. -- diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 4a75f9a54d..c9264845ab 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -47,8 +47,6 @@ everywhereOnValues f g h = (f', g', h') g' (UnaryMinus v) = g (UnaryMinus (g' v)) g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2)) g' (Parens v) = g (Parens (g' v)) - g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v)) - g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v)) g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v)) g' (Accessor prop v) = g (Accessor prop (g' v)) g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs)) @@ -116,8 +114,6 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g') g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g') g' (Parens v) = Parens <$> (g v >>= g') - g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g')) - g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g')) g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g') g' (Accessor prop v) = Accessor prop <$> (g v >>= g') g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs @@ -185,8 +181,6 @@ everywhereOnValuesM f g h = (f', g', h') g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g g' (Parens v) = (Parens <$> g' v) >>= g - g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g - g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g @@ -259,8 +253,6 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') g' v@(UnaryMinus v1) = g v <> g' v1 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2 g' v@(Parens v1) = g v <> g' v1 - g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1 - g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1 g' v@(Accessor _ v1) = g v <> g' v1 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs) @@ -338,8 +330,6 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' g' s (UnaryMinus v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 g' s (Parens v1) = g'' s v1 - g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v - g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs) @@ -419,8 +409,6 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g' s (UnaryMinus v) = UnaryMinus <$> g'' s v g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2 g' s (Parens v) = Parens <$> g'' s v - g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v) - g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v) g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v g' s (Accessor prop v) = Accessor prop <$> g'' s v g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs @@ -510,8 +498,6 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' s (UnaryMinus v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 g' s (Parens v1) = g'' s v1 - g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v - g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index c494631949..c37dec9da3 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -25,7 +25,6 @@ import Control.Arrow ((&&&)) import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Pretty -import Language.PureScript.Pretty.Common (before) import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds @@ -141,7 +140,6 @@ data SimpleErrorMessage | UnusedDctorImport (ProperName 'TypeName) | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName] | DeprecatedOperatorDecl String - | DeprecatedOperatorSection Expr (Either Expr Expr) | DeprecatedClassImport ModuleName (ProperName 'ClassName) | DeprecatedClassExport (ProperName 'ClassName) | DuplicateSelectiveImport ModuleName @@ -329,7 +327,6 @@ errorCode em = case unwrapErrorMessage em of UnusedDctorImport{} -> "UnusedDctorImport" UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport" DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl" - DeprecatedOperatorSection{} -> "DeprecatedOperatorSection" DeprecatedClassImport{} -> "DeprecatedClassImport" DeprecatedClassExport{} -> "DeprecatedClassExport" DuplicateSelectiveImport{} -> "DuplicateSelectiveImport" @@ -455,7 +452,7 @@ wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ error -- TODO Other possible suggestions: -- WildcardInferredType - source span not small enough -- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert --- DeprecatedClassExport, DeprecatedClassImport, DeprecatedOperatorSection, would want to replace smaller span? +-- DeprecatedClassExport, DeprecatedClassImport, would want to replace smaller span? errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion errorSuggestion err = case err of UnusedImport{} -> emptySuggestion @@ -923,31 +920,6 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , line "Support for value-declared operators will be removed in PureScript 0.9." ] - renderSimpleErrorMessage (DeprecatedOperatorSection op val) = - paras [ line "An operator section uses legacy syntax. Operator sections are now written using anonymous function syntax:" - , indent $ foldr1 before $ - case val of - Left l -> - [ line "(" - , prettyPrintValue valueDepth l - , line " " - , renderOperator op - , line " _)" - ] - Right r -> - [ line "(_ " - , renderOperator op - , line " " - , prettyPrintValue valueDepth r - , line ")" - ] - , line "Support for legacy operator sections will be removed in PureScript 0.9." - ] - where - renderOperator (PositionedValue _ _ ex) = renderOperator ex - renderOperator (Var (Qualified _ (Op ident))) = line ident - renderOperator other = Box.hcat Box.top [ line "`", prettyPrintValue valueDepth other, line "`" ] - renderSimpleErrorMessage (DeprecatedClassImport mn name) = paras [ line $ "Class import from " ++ runModuleName mn ++ " uses deprecated syntax that omits the 'class' keyword:" , indent $ line $ runProperName name diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index c5de54816c..691c1b7045 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -71,7 +71,6 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl go d | Just i <- getDeclIdent d , i `S.member` s = errorMessage (ShadowedName i) | otherwise = mempty - stepE _ (OperatorSection op val) = errorMessage $ DeprecatedOperatorSection op val stepE _ _ = mempty stepB :: S.Set Ident -> Binder -> MultipleErrors diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 095bd05445..d0bcc590ce 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -373,7 +373,7 @@ parseValueAtom = P.choice , Literal <$> parseStringLiteral , Literal <$> parseBooleanLiteral , Literal <$> parseArrayLiteral parseValue - , Literal <$> P.try (parseObjectLiteral parseIdentifierAndValue) + , Literal <$> parseObjectLiteral parseIdentifierAndValue , parseAbs , P.try parseConstructor , P.try parseVar @@ -382,7 +382,6 @@ parseValueAtom = P.choice , parseDo , parseLet , P.try $ Parens <$> parens parseValue - , parseOperatorSection , parseHole ] @@ -393,12 +392,6 @@ parseInfixExpr :: TokenParser Expr parseInfixExpr = P.between tick tick parseValue <|> Var <$> parseQualified (Op <$> symbol) -parseOperatorSection :: TokenParser Expr -parseOperatorSection = parens $ left <|> right - where - right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> indexersAndAccessors) - left = flip OperatorSection <$> (Left <$> indexersAndAccessors) <* indented <*> parseInfixExpr - parseHole :: TokenParser Expr parseHole = Hole <$> holeLit diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index edeadfcd23..6c0ba9dfc8 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -68,7 +68,6 @@ prettyPrintValue _ (Hole name) = text "?" <> text name prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@OperatorSection{} = prettyPrintValueAtom d expr prettyPrintValue d expr@BinaryNoParens{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Parens{} = prettyPrintValueAtom d expr prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr @@ -80,8 +79,6 @@ prettyPrintValueAtom d (Literal l) = prettyPrintLiteralValue d l prettyPrintValueAtom _ AnonymousArgument = text "_" prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name) prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident) -prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")" -prettyPrintValueAtom d (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue (d - 1) val) `beforeWithSpace` prettyPrintValue (d - 1) op) `before` text ")" prettyPrintValueAtom d (BinaryNoParens op lhs rhs) = prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs where diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 68388e9e6f..1f5ebefc75 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -67,7 +67,6 @@ desugar :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErro desugar externs = map removeSignedLiterals >>> traverse desugarObjectConstructors - >=> traverse desugarOperatorSections >=> traverse desugarDoModule >=> desugarCasesModule >=> desugarTypeDeclarationsModule diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index a6677a831d..f41178ad03 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -39,10 +39,12 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma desugarExpr (Parens b) | b' <- stripPositionInfo b , BinaryNoParens op val u <- b' - , isAnonymousArgument u = return $ OperatorSection op (Left val) + , isAnonymousArgument u = do arg <- freshIdent' + return $ Abs (Left arg) $ App (App op val) (Var (Qualified Nothing arg)) | b' <- stripPositionInfo b , BinaryNoParens op u val <- b' - , isAnonymousArgument u = return $ OperatorSection op (Right val) + , isAnonymousArgument u = do arg <- freshIdent' + return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do obj <- freshIdent' diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index a86eb0f248..d7607576b6 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -13,7 +13,6 @@ module Language.PureScript.Sugar.Operators ( rebracket , removeSignedLiterals - , desugarOperatorSections ) where import Prelude () @@ -32,7 +31,6 @@ import Language.PureScript.Types import Control.Monad ((<=<)) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class import Data.Function (on) import Data.Functor.Identity @@ -260,28 +258,6 @@ customOperatorTable fixities = in map (map (\(name, _, a) -> (name, a))) groups -desugarOperatorSections - :: forall m - . (MonadSupply m, MonadError MultipleErrors m) - => Module - -> m Module -desugarOperatorSections (Module ss coms mn ds exts) = - Module ss coms mn <$> traverse goDecl ds <*> pure exts - where - - goDecl :: Declaration -> m Declaration - (goDecl, _, _) = everywhereOnValuesM return goExpr return - - goExpr :: Expr -> m Expr - goExpr (OperatorSection op eVal) = do - arg <- freshIdent' - let var = Var (Qualified Nothing arg) - f2 a b = Abs (Left arg) $ App (App op a) b - return $ case eVal of - Left val -> f2 val var - Right val -> f2 var val - goExpr other = return other - updateTypes :: forall m . Monad m From 1c1d6afba6a12d674fa3170629378973cd75ee28 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 30 Apr 2016 14:59:54 -0700 Subject: [PATCH 0390/1580] Fix #2049, Pattern matching on aliases doesn't work well with as-patterns --- examples/passing/2049.purs | 13 ++++++++ .../PureScript/Parser/Declarations.hs | 30 ++++++++++--------- 2 files changed, 29 insertions(+), 14 deletions(-) create mode 100644 examples/passing/2049.purs diff --git a/examples/passing/2049.purs b/examples/passing/2049.purs new file mode 100644 index 0000000000..24186f44b1 --- /dev/null +++ b/examples/passing/2049.purs @@ -0,0 +1,13 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +data List a = Cons a (List a) | Nil + +infixr 6 Cons as : + +f :: List { x :: Int, y :: Int } -> Int +f ( r@{ x } : _) = x + r.y + +main = log "Done" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index d0bcc590ce..7799f59ec3 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -483,7 +483,7 @@ parseVarOrNamedBinder = do -- TODO: once operator aliases are finalized in 0.9, this 'try' won't be needed -- any more since identifiers in binders won't be 'Op's. name <- P.try C.parseIdent - let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinder) + let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinderAtom) parseNamedBinder <|> return (VarBinder name) parseNullBinder :: TokenParser Binder @@ -515,26 +515,28 @@ parseBinder = return (BinaryNoParensBinder op)) P.AssocRight ] ] + -- TODO: parsePolyType when adding support for polymorphic types postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType) ] - parseBinderAtom :: TokenParser Binder - parseBinderAtom = P.choice - [ parseNullBinder - , LiteralBinder <$> parseCharLiteral - , LiteralBinder <$> parseStringLiteral - , LiteralBinder <$> parseBooleanLiteral - , parseNumberLiteral - , parseVarOrNamedBinder - , parseConstructorBinder - , parseObjectBinder - , parseArrayBinder - , ParensInBinder <$> parens parseBinder - ] P. "binder" parseOpBinder :: TokenParser Binder parseOpBinder = OpBinder <$> parseQualified (Op <$> symbol) +parseBinderAtom :: TokenParser Binder +parseBinderAtom = P.choice + [ parseNullBinder + , LiteralBinder <$> parseCharLiteral + , LiteralBinder <$> parseStringLiteral + , LiteralBinder <$> parseBooleanLiteral + , parseNumberLiteral + , parseVarOrNamedBinder + , parseConstructorBinder + , parseObjectBinder + , parseArrayBinder + , ParensInBinder <$> parens parseBinder + ] P. "binder" + -- | -- Parse a binder as it would appear in a top level declaration -- From eaa0b47a332a630514c2daf28302450aa1799359 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 1 May 2016 01:16:04 +0200 Subject: [PATCH 0391/1580] Always reload Externs * The current usage of psc-ide involves loading all modules anyway, so we don't worry about loading previously unloaded modules. * Don't attempt to reload deleted files --- src/Language/PureScript/Ide/Watcher.hs | 43 +++++++++++--------------- 1 file changed, 18 insertions(+), 25 deletions(-) diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs index 184df16471..5865d3fb6b 100644 --- a/src/Language/PureScript/Ide/Watcher.hs +++ b/src/Language/PureScript/Ide/Watcher.hs @@ -12,44 +12,37 @@ -- File watcher for externs files ----------------------------------------------------------------------------- -{-# LANGUAGE RecordWildCards #-} - module Language.PureScript.Ide.Watcher where -import Prelude () -import Prelude.Compat - import Control.Concurrent (threadDelay) import Control.Concurrent.STM import Control.Monad import Control.Monad.Trans.Except -import qualified Data.Map as M -import Data.Maybe (isJust) -import Language.PureScript.Externs import Language.PureScript.Ide.Externs import Language.PureScript.Ide.State import Language.PureScript.Ide.Types +import Prelude import System.FilePath import System.FSNotify +-- | Reloads an ExternsFile from Disc. If the Event indicates the ExternsFile +-- was deleted we don't do anything. +reloadFile :: TVar PscIdeState -> Event -> IO () +reloadFile _ Removed{} = pure () +reloadFile stateVar ev = do + let fp = eventPath ev + ef' <- runExceptT (readExternFile fp) + case ef' of + Left _ -> pure () + Right ef -> do + atomically (insertModule' stateVar ef) + putStrLn ("Reloaded File at: " ++ fp) -reloadFile :: TVar PscIdeState -> FilePath -> IO () -reloadFile stateVar fp = do - (Right ef@ExternsFile{..}) <- runExceptT $ readExternFile fp - reloaded <- atomically $ do - st <- readTVar stateVar - if isLoaded efModuleName st - then - insertModule' stateVar ef *> pure True - else - pure False - when reloaded $ putStrLn $ "Reloaded File at: " ++ fp - where - isLoaded name st = isJust (M.lookup name (externsFiles st)) - +-- | Installs filewatchers for the given directory and reloads ExternsFiles when +-- they change on disc watcher :: TVar PscIdeState -> FilePath -> IO () -watcher stateVar fp = withManager $ \mgr -> do +watcher stateVar fp = withManagerConf (defaultConfig { confDebounce = NoDebounce }) $ \mgr -> do _ <- watchTree mgr fp (\ev -> takeFileName (eventPath ev) == "externs.json") - (reloadFile stateVar . eventPath) - forever (threadDelay 10000) + (reloadFile stateVar) + forever (threadDelay 100000) From 69f8b3e3657b7e6546d4c1716ac4992210edbc93 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 1 May 2016 22:45:19 +0100 Subject: [PATCH 0392/1580] New Prelude names * Update for names in new prelude * Disable psci tests that rely on re-exports * Use bower rather than git submodule for support dependencies --- .gitmodules | 3 - examples/failing/Do.purs | 4 +- examples/failing/SkolemEscape2.purs | 2 +- examples/failing/Superclasses5.purs | 3 +- examples/failing/TypeError.purs | 2 +- examples/manual/passing/Module.purs | 4 +- examples/manual/passing/TransitiveImport.purs | 4 +- examples/passing/1664.purs | 2 +- examples/passing/CaseInDo.purs | 4 +- examples/passing/CaseMultipleExpressions.purs | 4 +- examples/passing/Collatz.purs | 4 +- examples/passing/Console.purs | 2 +- examples/passing/ContextSimplification.purs | 2 +- examples/passing/DeepCase.purs | 2 +- examples/passing/Eff.purs | 4 +- examples/passing/EqOrd.purs | 2 +- examples/passing/ExtendedInfixOperators.purs | 2 +- examples/passing/Fib.purs | 2 +- examples/passing/FinalTagless.purs | 2 +- examples/passing/Generalization1.purs | 6 +- examples/passing/ImportHiding.purs | 2 +- .../InferRecFunWithConstrainedArgument.purs | 2 +- examples/passing/Let.purs | 14 +- examples/passing/Let2.purs | 2 +- examples/passing/ModuleExport.purs | 2 +- examples/passing/ModuleExportDupes.purs | 2 +- examples/passing/ModuleExportExcluded.purs | 2 +- examples/passing/ModuleExportQualified.purs | 2 +- examples/passing/ModuleExportSelf.purs | 2 +- examples/passing/MonadState.purs | 2 +- examples/passing/MultiArgFunctions.purs | 4 +- examples/passing/NestedTypeSynonyms.purs | 2 +- examples/passing/Newtype.purs | 10 +- examples/passing/ObjectGetter.purs | 2 +- examples/passing/ObjectUpdater.purs | 2 +- examples/passing/ObjectWildcards.purs | 6 +- examples/passing/OperatorInlining.purs | 41 +- examples/passing/Operators.purs | 6 +- examples/passing/OptionalQualified.purs | 2 +- examples/passing/Person.purs | 5 +- examples/passing/Rank2TypeSynonym.purs | 2 +- examples/passing/ReExportQualified.purs | 2 +- examples/passing/RowPolyInstanceContext.purs | 4 +- examples/passing/RuntimeScopeIssue.purs | 2 +- examples/passing/Superclasses1.purs | 2 +- examples/passing/Superclasses3.purs | 2 +- examples/passing/TCO.purs | 12 +- examples/passing/TailCall.purs | 2 +- examples/passing/TypeClasses.purs | 8 +- examples/passing/TypedBinders.purs | 10 +- examples/passing/UnicodeType.purs | 8 +- examples/passing/Unit.purs | 2 +- examples/passing/Where.purs | 14 +- psci/PSCi/Module.hs | 8 +- purescript.cabal | 7 - .../CodeGen/JS/Optimizer/Inliner.hs | 40 +- src/Language/PureScript/Constants.hs | 19 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 53 +- .../PureScript/Ide/Imports/IntegrationSpec.hs | 4 +- tests/Language/PureScript/Ide/Integration.hs | 2 - tests/Main.hs | 5 +- tests/TestCompiler.hs | 4 +- tests/TestPscPublish.hs | 2 +- tests/TestPsci.hs | 49 +- tests/TestUtils.hs | 18 - tests/support/bower.json | 12 +- .../flattened/Control-Monad-Eff-Class.purs | 24 - .../flattened/Control-Monad-Eff-Console.js | 18 - .../flattened/Control-Monad-Eff-Console.purs | 18 - .../flattened/Control-Monad-Eff-Unsafe.js | 8 - .../flattened/Control-Monad-Eff-Unsafe.purs | 10 - tests/support/flattened/Control-Monad-Eff.js | 62 -- .../support/flattened/Control-Monad-Eff.purs | 67 -- tests/support/flattened/Control-Monad-ST.js | 38 - tests/support/flattened/Control-Monad-ST.purs | 42 - tests/support/flattened/Data-Function.js | 233 ----- tests/support/flattened/Data-Function.purs | 113 --- tests/support/flattened/Prelude.js | 228 ----- tests/support/flattened/Prelude.purs | 872 ------------------ tests/support/flattened/Test-Assert.js | 27 - tests/support/flattened/Test-Assert.purs | 46 - tests/support/package.json | 3 +- tests/support/prelude | 1 - tests/support/setup.js | 22 - 84 files changed, 243 insertions(+), 2054 deletions(-) delete mode 100644 .gitmodules delete mode 100644 tests/support/flattened/Control-Monad-Eff-Class.purs delete mode 100644 tests/support/flattened/Control-Monad-Eff-Console.js delete mode 100644 tests/support/flattened/Control-Monad-Eff-Console.purs delete mode 100644 tests/support/flattened/Control-Monad-Eff-Unsafe.js delete mode 100644 tests/support/flattened/Control-Monad-Eff-Unsafe.purs delete mode 100644 tests/support/flattened/Control-Monad-Eff.js delete mode 100644 tests/support/flattened/Control-Monad-Eff.purs delete mode 100644 tests/support/flattened/Control-Monad-ST.js delete mode 100644 tests/support/flattened/Control-Monad-ST.purs delete mode 100644 tests/support/flattened/Data-Function.js delete mode 100644 tests/support/flattened/Data-Function.purs delete mode 100644 tests/support/flattened/Prelude.js delete mode 100644 tests/support/flattened/Prelude.purs delete mode 100644 tests/support/flattened/Test-Assert.js delete mode 100644 tests/support/flattened/Test-Assert.purs delete mode 160000 tests/support/prelude delete mode 100644 tests/support/setup.js diff --git a/.gitmodules b/.gitmodules deleted file mode 100644 index 9c44d52cc7..0000000000 --- a/.gitmodules +++ /dev/null @@ -1,3 +0,0 @@ -[submodule "tests/support/prelude"] - path = tests/support/prelude - url = https://github.com/purescript/purescript-prelude diff --git a/examples/failing/Do.purs b/examples/failing/Do.purs index 7d648c2406..a0140bc56b 100644 --- a/examples/failing/Do.purs +++ b/examples/failing/Do.purs @@ -8,5 +8,5 @@ test1 = do let x = 1 test2 y = do x <- y -test3 = do return 1 - return 2 +test3 = do pure 1 + pure 2 diff --git a/examples/failing/SkolemEscape2.purs b/examples/failing/SkolemEscape2.purs index 6df2afe3f9..38d64cc332 100644 --- a/examples/failing/SkolemEscape2.purs +++ b/examples/failing/SkolemEscape2.purs @@ -7,4 +7,4 @@ import Control.Monad.ST test _ = do r <- runST (newSTRef 0) - return 0 + pure 0 diff --git a/examples/failing/Superclasses5.purs b/examples/failing/Superclasses5.purs index b93c5f4f16..0de8d4bf8b 100644 --- a/examples/failing/Superclasses5.purs +++ b/examples/failing/Superclasses5.purs @@ -3,6 +3,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (logShow) class Su a where su :: a -> a @@ -22,4 +23,4 @@ instance clNumber :: Cl Number where test :: forall a. (Cl a) => a -> Array a test x = su [cl x x] -main = Control.Monad.Eff.Console.print $ test 10.0 +main = logShow $ test 10.0 diff --git a/examples/failing/TypeError.purs b/examples/failing/TypeError.purs index 8e028b3772..1c5c980067 100644 --- a/examples/failing/TypeError.purs +++ b/examples/failing/TypeError.purs @@ -3,4 +3,4 @@ module Main where import Prelude -test = 1 ++ "A" +test = 1 <> "A" diff --git a/examples/manual/passing/Module.purs b/examples/manual/passing/Module.purs index a5dcea8f97..6d8d748a64 100644 --- a/examples/manual/passing/Module.purs +++ b/examples/manual/passing/Module.purs @@ -5,7 +5,7 @@ module M1 where data Foo = Foo String foo :: M1.Foo -> String - foo = \f -> case f of Foo s -> s ++ "foo" + foo = \f -> case f of Foo s -> s <> "foo" bar :: Foo -> String bar = foo @@ -21,7 +21,7 @@ module M2 where baz = M1.foo match :: M1.Foo -> String - match = \f -> case f of M1.Foo s -> s ++ "foo" + match = \f -> case f of M1.Foo s -> s <> "foo" module Main where diff --git a/examples/manual/passing/TransitiveImport.purs b/examples/manual/passing/TransitiveImport.purs index 0274cbe250..524e19cf35 100644 --- a/examples/manual/passing/TransitiveImport.purs +++ b/examples/manual/passing/TransitiveImport.purs @@ -19,6 +19,6 @@ module Main where import Control.Monad.Eff.Console main = do - print (middle unit) + logShow (middle unit) trace "Done" - return unit + pure unit diff --git a/examples/passing/1664.purs b/examples/passing/1664.purs index 40260c78ca..35a17eddab 100644 --- a/examples/passing/1664.purs +++ b/examples/passing/1664.purs @@ -11,6 +11,6 @@ newtype IdentityEff e a = IdentityEff (Eff e (Identity a)) test :: forall e a. IdentityEff e a -> IdentityEff e Unit test (IdentityEff action) = IdentityEff $ do (Identity x :: Identity _) <- action - return $ Identity unit + pure $ Identity unit main = log "Done" diff --git a/examples/passing/CaseInDo.purs b/examples/passing/CaseInDo.purs index 574b69424e..9282c7a130 100644 --- a/examples/passing/CaseInDo.purs +++ b/examples/passing/CaseInDo.purs @@ -5,13 +5,13 @@ import Control.Monad.Eff.Console import Control.Monad.Eff doIt :: forall eff. Eff eff Boolean -doIt = return true +doIt = pure true set = do log "Testing..." case 0 of 0 -> doIt - _ -> return false + _ -> pure false main = do b <- set diff --git a/examples/passing/CaseMultipleExpressions.purs b/examples/passing/CaseMultipleExpressions.purs index 763a425cf6..40b0d30b87 100644 --- a/examples/passing/CaseMultipleExpressions.purs +++ b/examples/passing/CaseMultipleExpressions.purs @@ -5,13 +5,13 @@ import Control.Monad.Eff.Console import Control.Monad.Eff doIt :: forall eff. Eff eff Boolean -doIt = return true +doIt = pure true set = do log "Testing..." case 42, 10 of 42, 10 -> doIt - _ , _ -> return false + _ , _ -> pure false main = do b <- set diff --git a/examples/passing/Collatz.purs b/examples/passing/Collatz.purs index 80a3d1ecca..626d318016 100644 --- a/examples/passing/Collatz.purs +++ b/examples/passing/Collatz.purs @@ -12,7 +12,7 @@ collatz n = runPure (runST (do modifySTRef count $ (+) 1 m <- readSTRef r writeSTRef r $ if m `mod` 2 == 0 then m / 2 else 3 * m + 1 - return $ m == 1 + pure $ m == 1 readSTRef count)) -main = Control.Monad.Eff.Console.print $ collatz 1000 +main = Control.Monad.Eff.Console.logShow $ collatz 1000 diff --git a/examples/passing/Console.purs b/examples/passing/Console.purs index a828773d01..3d84ec7490 100644 --- a/examples/passing/Console.purs +++ b/examples/passing/Console.purs @@ -5,7 +5,7 @@ import Control.Monad.Eff import Control.Monad.Eff.Console replicateM_ :: forall m a. (Monad m) => Number -> m a -> m {} -replicateM_ 0.0 _ = return {} +replicateM_ 0.0 _ = pure {} replicateM_ n act = do act replicateM_ (n - 1.0) act diff --git a/examples/passing/ContextSimplification.purs b/examples/passing/ContextSimplification.purs index cab8af50c6..45dc3cc3b9 100644 --- a/examples/passing/ContextSimplification.purs +++ b/examples/passing/ContextSimplification.purs @@ -8,6 +8,6 @@ shout = log <<< (_ <> "!") <<< show -- Here, we should simplify the context so that only one Show -- constraint is added. usesShowTwice true = shout -usesShowTwice false = print +usesShowTwice false = logShow main = usesShowTwice true "Done" diff --git a/examples/passing/DeepCase.purs b/examples/passing/DeepCase.purs index dce5f23c6c..56be49c6eb 100644 --- a/examples/passing/DeepCase.purs +++ b/examples/passing/DeepCase.purs @@ -12,4 +12,4 @@ f x y = x -> 1.0 + x * x in g + x + y -main = print $ f 1.0 10.0 +main = logShow $ f 1.0 10.0 diff --git a/examples/passing/Eff.purs b/examples/passing/Eff.purs index 3d7c2cd2c0..77b9af2f3a 100644 --- a/examples/passing/Eff.purs +++ b/examples/passing/Eff.purs @@ -21,5 +21,5 @@ test3 = pureST (do main = do test1 - Control.Monad.Eff.Console.print test2 - Control.Monad.Eff.Console.print test3 + Control.Monad.Eff.Console.logShow test2 + Control.Monad.Eff.Console.logShow test3 diff --git a/examples/passing/EqOrd.purs b/examples/passing/EqOrd.purs index 9ed10b2a3e..cc2c9472f9 100644 --- a/examples/passing/EqOrd.purs +++ b/examples/passing/EqOrd.purs @@ -12,4 +12,4 @@ instance ordPair :: (Ord a, Ord b) => Ord (Pair a b) where instance eqPair :: (Eq a, Eq b) => Eq (Pair a b) where eq (Pair a1 b1) (Pair a2 b2) = a1 == a2 && b1 == b2 -main = Control.Monad.Eff.Console.print $ Pair 1.0 2.0 == Pair 1.0 2.0 +main = Control.Monad.Eff.Console.logShow $ Pair 1.0 2.0 == Pair 1.0 2.0 diff --git a/examples/passing/ExtendedInfixOperators.purs b/examples/passing/ExtendedInfixOperators.purs index 276d7d9d70..d70c40be1b 100644 --- a/examples/passing/ExtendedInfixOperators.purs +++ b/examples/passing/ExtendedInfixOperators.purs @@ -11,4 +11,4 @@ null _ = false test = [1.0, 2.0, 3.0] `comparing null` [4.0, 5.0, 6.0] main = do - Control.Monad.Eff.Console.print test + Control.Monad.Eff.Console.logShow test diff --git a/examples/passing/Fib.purs b/examples/passing/Fib.purs index bf6d5223df..6c3fcf1e95 100644 --- a/examples/passing/Fib.purs +++ b/examples/passing/Fib.purs @@ -12,4 +12,4 @@ main = runST (do n2' <- readSTRef n2 writeSTRef n2 $ n1' + n2' writeSTRef n1 n2' - Control.Monad.Eff.Console.print n2') + Control.Monad.Eff.Console.logShow n2') diff --git a/examples/passing/FinalTagless.purs b/examples/passing/FinalTagless.purs index 5347153759..3194fd1972 100644 --- a/examples/passing/FinalTagless.purs +++ b/examples/passing/FinalTagless.purs @@ -19,4 +19,4 @@ runId (Id a) = a three :: Expr Number three = add (num 1.0) (num 2.0) -main = Control.Monad.Eff.Console.print $ runId three +main = Control.Monad.Eff.Console.logShow $ runId three diff --git a/examples/passing/Generalization1.purs b/examples/passing/Generalization1.purs index a956ab6068..16c7bedfd0 100644 --- a/examples/passing/Generalization1.purs +++ b/examples/passing/Generalization1.purs @@ -1,10 +1,10 @@ module Main where import Prelude -import Control.Monad.Eff.Console (print) +import Control.Monad.Eff.Console (logShow) main = do - print (sum 1.0 2.0) - print (sum 1 2) + logShow (sum 1.0 2.0) + logShow (sum 1 2) sum x y = x + y diff --git a/examples/passing/ImportHiding.purs b/examples/passing/ImportHiding.purs index 4abac7a82e..8cc0cf8d6e 100644 --- a/examples/passing/ImportHiding.purs +++ b/examples/passing/ImportHiding.purs @@ -15,4 +15,4 @@ class Show a where data Unit = X | Y main = do - print show + logShow show diff --git a/examples/passing/InferRecFunWithConstrainedArgument.purs b/examples/passing/InferRecFunWithConstrainedArgument.purs index 2a10977698..6c8d88927f 100644 --- a/examples/passing/InferRecFunWithConstrainedArgument.purs +++ b/examples/passing/InferRecFunWithConstrainedArgument.purs @@ -5,4 +5,4 @@ import Prelude test 100.0 = 100.0 test n = test(1.0 + n) -main = Control.Monad.Eff.Console.print $ test 0.0 +main = Control.Monad.Eff.Console.logShow $ test 0.0 diff --git a/examples/passing/Let.purs b/examples/passing/Let.purs index d1aac9d023..6e15774355 100644 --- a/examples/passing/Let.purs +++ b/examples/passing/Let.purs @@ -44,10 +44,10 @@ test10 _ = in f 10.0 main = do - Control.Monad.Eff.Console.print (test1 1.0) - Control.Monad.Eff.Console.print (test2 1.0 2.0) - Control.Monad.Eff.Console.print test3 - Control.Monad.Eff.Console.print test4 - Control.Monad.Eff.Console.print test5 - Control.Monad.Eff.Console.print test7 - Control.Monad.Eff.Console.print (test8 100.0) + Control.Monad.Eff.Console.logShow (test1 1.0) + Control.Monad.Eff.Console.logShow (test2 1.0 2.0) + Control.Monad.Eff.Console.logShow test3 + Control.Monad.Eff.Console.logShow test4 + Control.Monad.Eff.Console.logShow test5 + Control.Monad.Eff.Console.logShow test7 + Control.Monad.Eff.Console.logShow (test8 100.0) diff --git a/examples/passing/Let2.purs b/examples/passing/Let2.purs index 8da1344682..e43ab43c65 100644 --- a/examples/passing/Let2.purs +++ b/examples/passing/Let2.purs @@ -14,4 +14,4 @@ test = x = f 1.0 in not x -main = Control.Monad.Eff.Console.print test +main = Control.Monad.Eff.Console.logShow test diff --git a/examples/passing/ModuleExport.purs b/examples/passing/ModuleExport.purs index 6c283e91e3..1c891fd087 100644 --- a/examples/passing/ModuleExport.purs +++ b/examples/passing/ModuleExport.purs @@ -6,4 +6,4 @@ module Main where import A main = do - print (show 1.0) + logShow (show 1.0) diff --git a/examples/passing/ModuleExportDupes.purs b/examples/passing/ModuleExportDupes.purs index 72f807bf55..baef27c328 100644 --- a/examples/passing/ModuleExportDupes.purs +++ b/examples/passing/ModuleExportDupes.purs @@ -16,4 +16,4 @@ module Main where import Prelude main = do - print (show 1.0) + logShow (show 1.0) diff --git a/examples/passing/ModuleExportExcluded.purs b/examples/passing/ModuleExportExcluded.purs index fd0130a8b5..a84878a917 100644 --- a/examples/passing/ModuleExportExcluded.purs +++ b/examples/passing/ModuleExportExcluded.purs @@ -11,4 +11,4 @@ module Main where otherwise = false main = do - print "1.0" + logShow "1.0" diff --git a/examples/passing/ModuleExportQualified.purs b/examples/passing/ModuleExportQualified.purs index 0c1892361c..e7b0a7f037 100644 --- a/examples/passing/ModuleExportQualified.purs +++ b/examples/passing/ModuleExportQualified.purs @@ -6,4 +6,4 @@ module Main where import A as B main = do - print (B.show 1.0) + logShow (B.show 1.0) diff --git a/examples/passing/ModuleExportSelf.purs b/examples/passing/ModuleExportSelf.purs index cc2a0017a2..2812eda611 100644 --- a/examples/passing/ModuleExportSelf.purs +++ b/examples/passing/ModuleExportSelf.purs @@ -11,4 +11,4 @@ module Main where bar = true main = do - print (show bar) + logShow (show bar) diff --git a/examples/passing/MonadState.purs b/examples/passing/MonadState.purs index 653afaa2aa..b2e13a36da 100644 --- a/examples/passing/MonadState.purs +++ b/examples/passing/MonadState.purs @@ -58,4 +58,4 @@ modify f = same :: forall a. (a -> a) -> (a -> a) same = id -main = print $ runState 0 (modify (_ + 1)) +main = logShow $ runState 0 (modify (_ + 1)) diff --git a/examples/passing/MultiArgFunctions.purs b/examples/passing/MultiArgFunctions.purs index 999d527776..b6b1b3208c 100644 --- a/examples/passing/MultiArgFunctions.purs +++ b/examples/passing/MultiArgFunctions.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Data.Function +import Data.Function.Uncurried import Control.Monad.Eff import Control.Monad.Eff.Console @@ -23,5 +23,5 @@ main = do runFn8 (mkFn8 $ \a b c d e f g h -> log $ show [a, b, c, d, e, f, g, h]) 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 runFn9 (mkFn9 $ \a b c d e f g h i -> log $ show [a, b, c, d, e, f, g, h, i]) 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 runFn10 (mkFn10 $ \a b c d e f g h i j-> log $ show [a, b, c, d, e, f, g, h, i, j]) 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 - print $ runFn2 g 0.0 0.0 + logShow $ runFn2 g 0.0 0.0 log "Done!" diff --git a/examples/passing/NestedTypeSynonyms.purs b/examples/passing/NestedTypeSynonyms.purs index abb9ea7a5e..b55bf04d26 100644 --- a/examples/passing/NestedTypeSynonyms.purs +++ b/examples/passing/NestedTypeSynonyms.purs @@ -8,4 +8,4 @@ type Y = X -> X fn :: Y fn a = a -main = Control.Monad.Eff.Console.print (fn "Done") +main = Control.Monad.Eff.Console.logShow (fn "Done") diff --git a/examples/passing/Newtype.purs b/examples/passing/Newtype.purs index c9edbda825..43016b2568 100644 --- a/examples/passing/Newtype.purs +++ b/examples/passing/Newtype.purs @@ -7,17 +7,17 @@ import Control.Monad.Eff.Console newtype Thing = Thing String instance showThing :: Show Thing where - show (Thing x) = "Thing " ++ show x + show (Thing x) = "Thing " <> show x newtype Box a = Box a instance showBox :: (Show a) => Show (Box a) where - show (Box x) = "Box " ++ show x + show (Box x) = "Box " <> show x apply f x = f x main = do - print $ Thing "hello" - print $ Box 42.0 - print $ apply Box 9000.0 + logShow $ Thing "hello" + logShow $ Box 42.0 + logShow $ apply Box 9000.0 log "Done" diff --git a/examples/passing/ObjectGetter.purs b/examples/passing/ObjectGetter.purs index addb57f7de..ff71b702b4 100644 --- a/examples/passing/ObjectGetter.purs +++ b/examples/passing/ObjectGetter.purs @@ -7,7 +7,7 @@ getX = _.x point = { x: 1.0, y: 0.0 } main = do - Control.Monad.Eff.Console.print $ getX point + Control.Monad.Eff.Console.logShow $ getX point Control.Monad.Eff.Console.log $ _." 123 string Prop Name " { " 123 string Prop Name ": "OK" } Control.Monad.Eff.Console.log $ (_.x >>> _.y) { x: { y: "Nested" } } Control.Monad.Eff.Console.log $ _.value { value: "Done!" } diff --git a/examples/passing/ObjectUpdater.purs b/examples/passing/ObjectUpdater.purs index 17246c603d..8070beda9c 100644 --- a/examples/passing/ObjectUpdater.purs +++ b/examples/passing/ObjectUpdater.purs @@ -6,7 +6,7 @@ import Control.Monad.Eff.Console import Test.Assert getValue :: forall e. Eff (| e) Boolean -getValue = return true +getValue = pure true main = do let record = { value: false } diff --git a/examples/passing/ObjectWildcards.purs b/examples/passing/ObjectWildcards.purs index 5a0d4c8b87..cc9f6926d6 100644 --- a/examples/passing/ObjectWildcards.purs +++ b/examples/passing/ObjectWildcards.purs @@ -8,13 +8,13 @@ import Test.Assert mkRecord = { foo: _, bar: _, baz: "baz" } getValue :: forall e. Eff (| e) Boolean -getValue = return true +getValue = pure true main = do obj <- { value: _ } <$> getValue - print obj.value + logShow obj.value let x = 1.0 - point <- { x: _, y: x } <$> return 2.0 + point <- { x: _, y: x } <$> pure 2.0 assert $ point.x == 2.0 assert $ point.y == 1.0 log (mkRecord 1.0 "Done!").bar diff --git a/examples/passing/OperatorInlining.purs b/examples/passing/OperatorInlining.purs index 172babd0e3..90386427fb 100644 --- a/examples/passing/OperatorInlining.purs +++ b/examples/passing/OperatorInlining.purs @@ -6,42 +6,41 @@ import Control.Monad.Eff.Console main = do -- semiringNumber - print (1.0 + 2.0) - print (1.0 * 2.0) + logShow (1.0 + 2.0) + logShow (1.0 * 2.0) -- ringNumber - print (1.0 - 2.0) - print (negate 1.0) + logShow (1.0 - 2.0) + logShow (negate 1.0) -- moduleSemiringNumber - print (1.0 / 2.0) + logShow (1.0 / 2.0) -- ordNumber - print (1.0 > 2.0) - print (1.0 < 2.0) - print (1.0 <= 2.0) - print (1.0 >= 2.0) - print (1.0 == 2.0) + logShow (1.0 > 2.0) + logShow (1.0 < 2.0) + logShow (1.0 <= 2.0) + logShow (1.0 >= 2.0) + logShow (1.0 == 2.0) -- eqNumber - print (1.0 == 2.0) - print (1.0 /= 2.0) + logShow (1.0 == 2.0) + logShow (1.0 /= 2.0) -- eqString - print ("foo" == "bar") - print ("foo" /= "bar") + logShow ("foo" == "bar") + logShow ("foo" /= "bar") -- eqBoolean - print (true == false) - print (true /= false) + logShow (true == false) + logShow (true /= false) -- semigroupString - print ("foo" ++ "bar") - print ("foo" <> "bar") + logShow ("foo" <> "bar") -- latticeBoolean - print (top && true) - print (bottom || false) + logShow (top && true) + logShow (bottom || false) -- complementedLatticeBoolean - print (not true) + logShow (not true) diff --git a/examples/passing/Operators.purs b/examples/passing/Operators.purs index 0d6d86ffea..3e16cbbc12 100644 --- a/examples/passing/Operators.purs +++ b/examples/passing/Operators.purs @@ -8,9 +8,9 @@ import Control.Monad.Eff.Console (?!) x _ = x bar :: String -> String -> String -bar = \s1 s2 -> s1 ++ s2 +bar = \s1 s2 -> s1 <> s2 -test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n +test1 :: forall n. (Semiring n) => n -> n -> (n -> n -> n) -> n test1 x y z = x * y + z x y test2 = (\x -> x.foo false) { foo : \_ -> 1.0 } @@ -31,7 +31,7 @@ test5 = 1.0 %% 2.0 %% 3.0 test6 = ((\x -> x) `k` 2.0) 3.0 (<+>) :: String -> String -> String -(<+>) = \s1 s2 -> s1 ++ s2 +(<+>) = \s1 s2 -> s1 <> s2 test7 = "Hello" <+> "World!" diff --git a/examples/passing/OptionalQualified.purs b/examples/passing/OptionalQualified.purs index de5b8749cf..767e973b75 100644 --- a/examples/passing/OptionalQualified.purs +++ b/examples/passing/OptionalQualified.purs @@ -8,5 +8,5 @@ import Control.Monad.Eff.Console as Console bind = P.bind main = do - message <- P.return "success!" + message <- P.pure "success!" Console.log message diff --git a/examples/passing/Person.purs b/examples/passing/Person.purs index fa3384e597..fd0e4f9806 100644 --- a/examples/passing/Person.purs +++ b/examples/passing/Person.purs @@ -1,11 +1,12 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Person = Person { name :: String, age :: Number } showPerson :: Person -> String showPerson = \p -> case p of - Person o -> o.name ++ ", aged " ++ show o.age + Person o -> o.name <> ", aged " <> show o.age -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Rank2TypeSynonym.purs b/examples/passing/Rank2TypeSynonym.purs index a1977da4b0..58b1e8c208 100644 --- a/examples/passing/Rank2TypeSynonym.purs +++ b/examples/passing/Rank2TypeSynonym.purs @@ -13,4 +13,4 @@ bar = foo 3.0 main = do x <- bar - Control.Monad.Eff.Console.print x + Control.Monad.Eff.Console.logShow x diff --git a/examples/passing/ReExportQualified.purs b/examples/passing/ReExportQualified.purs index e85ecee236..f74d4102b2 100644 --- a/examples/passing/ReExportQualified.purs +++ b/examples/passing/ReExportQualified.purs @@ -13,4 +13,4 @@ module Main where import Prelude import C - main = Control.Monad.Eff.Console.log (x ++ y) + main = Control.Monad.Eff.Console.log (x <> y) diff --git a/examples/passing/RowPolyInstanceContext.purs b/examples/passing/RowPolyInstanceContext.purs index f0543af36a..0a232f9dd4 100644 --- a/examples/passing/RowPolyInstanceContext.purs +++ b/examples/passing/RowPolyInstanceContext.purs @@ -11,10 +11,10 @@ instance st :: T s (S s) where state f = S $ \s -> { new: f s, ret: unit } test1 :: forall r . S { foo :: String | r } Unit -test1 = state $ \o -> o { foo = o.foo ++ "!" } +test1 = state $ \o -> o { foo = o.foo <> "!" } test2 :: forall m r . (T { foo :: String | r } m) => m Unit -test2 = state $ \o -> o { foo = o.foo ++ "!" } +test2 = state $ \o -> o { foo = o.foo <> "!" } main = do let t1 = test1 diff --git a/examples/passing/RuntimeScopeIssue.purs b/examples/passing/RuntimeScopeIssue.purs index f6800c81b9..b83e030517 100644 --- a/examples/passing/RuntimeScopeIssue.purs +++ b/examples/passing/RuntimeScopeIssue.purs @@ -16,4 +16,4 @@ instance bNumber :: B Number where b 0.0 = false b n = a (n - 1.0) -main = Control.Monad.Eff.Console.print $ a 10.0 +main = Control.Monad.Eff.Console.logShow $ a 10.0 diff --git a/examples/passing/Superclasses1.purs b/examples/passing/Superclasses1.purs index cdf075f0fb..915e06483b 100644 --- a/examples/passing/Superclasses1.purs +++ b/examples/passing/Superclasses1.purs @@ -17,4 +17,4 @@ instance clNumber :: Cl Number where test :: forall a. (Cl a) => a -> a test a = su (cl a a) -main = Control.Monad.Eff.Console.print $ test 10.0 +main = Control.Monad.Eff.Console.logShow $ test 10.0 diff --git a/examples/passing/Superclasses3.purs b/examples/passing/Superclasses3.purs index d1135a0bcb..14198645a5 100644 --- a/examples/passing/Superclasses3.purs +++ b/examples/passing/Superclasses3.purs @@ -28,7 +28,7 @@ instance applyMTrace :: Apply MTrace where apply = ap instance applicativeMTrace :: Applicative MTrace where - pure = MTrace <<< return + pure = MTrace <<< pure instance bindMTrace :: Bind MTrace where bind m f = MTrace (runMTrace m >>= (runMTrace <<< f)) diff --git a/examples/passing/TCO.purs b/examples/passing/TCO.purs index 85671785f3..74bd674e18 100644 --- a/examples/passing/TCO.purs +++ b/examples/passing/TCO.purs @@ -1,16 +1,16 @@ module Main where import Prelude -import Control.Monad.Eff.Console (print) +import Control.Monad.Eff.Console (logShow) main = do let f x = x + 1 let v = 0 - print (applyN 0 f v) - print (applyN 1 f v) - print (applyN 2 f v) - print (applyN 3 f v) - print (applyN 4 f v) + logShow (applyN 0 f v) + logShow (applyN 1 f v) + logShow (applyN 2 f v) + logShow (applyN 3 f v) + logShow (applyN 4 f v) applyN :: forall a. Int -> (a -> a) -> a -> a applyN = go id diff --git a/examples/passing/TailCall.purs b/examples/passing/TailCall.purs index 1fad42378b..9e65a3f930 100644 --- a/examples/passing/TailCall.purs +++ b/examples/passing/TailCall.purs @@ -14,4 +14,4 @@ loop x = loop (x + 1.0) notATailCall = \x -> (\notATailCall -> notATailCall x) (\x -> x) -main = Control.Monad.Eff.Console.print (test 0.0 (1.0 `C` (2.0 `C` (3.0 `C` N)))) +main = Control.Monad.Eff.Console.logShow (test 0.0 (1.0 `C` (2.0 `C` (3.0 `C` N)))) diff --git a/examples/passing/TypeClasses.purs b/examples/passing/TypeClasses.purs index 1dfdf51fc7..96c6351ca2 100644 --- a/examples/passing/TypeClasses.purs +++ b/examples/passing/TypeClasses.purs @@ -17,7 +17,7 @@ test8 = \_ -> show $ "testing" data Data a = Data a instance showData :: (Prelude.Show a) => Prelude.Show (Data a) where - show (Data a) = "Data (" ++ show a ++ ")" + show (Data a) = "Data (" <> show a <> ")" test3 = \_ -> show (Data "testing") @@ -53,9 +53,9 @@ instance bindMaybe :: Bind Maybe where instance monadMaybe :: Monad Maybe test4 :: forall a m. (Monad m) => a -> m Number -test4 = \_ -> return 1.0 +test4 = \_ -> pure 1.0 -test5 = \_ -> Just 1.0 >>= \n -> return (n + 1.0) +test5 = \_ -> Just 1.0 >>= \n -> pure (n + 1.0) ask r = r @@ -63,7 +63,7 @@ runReader r f = f r test9 _ = runReader 0.0 $ do n <- ask - return $ n + 1.0 + pure $ n + 1.0 main = Control.Monad.Eff.Console.log (test7 "Done") diff --git a/examples/passing/TypedBinders.purs b/examples/passing/TypedBinders.purs index 6f8ca7b6d5..ea63815dac 100644 --- a/examples/passing/TypedBinders.purs +++ b/examples/passing/TypedBinders.purs @@ -38,20 +38,20 @@ modify f = do test :: Tuple String String test = runState "" $ do - modify $ (++) "World!" - modify $ (++) "Hello, " + modify $ (<>) "World!" + modify $ (<>) "Hello, " str :: String <- get - return str + pure str test2 :: (Int -> Int) -> Int test2 = (\(f :: Int -> Int) -> f 10) -test3 :: Int -> Boolean +test3 :: Int -> Boolean test3 n = case n of (0 :: Int) -> true _ -> false -test4 :: Tuple Int Int -> Tuple Int Int +test4 :: Tuple Int Int -> Tuple Int Int test4 = (\(Tuple a b :: Tuple Int Int) -> Tuple b a) type Int1 = Int diff --git a/examples/passing/UnicodeType.purs b/examples/passing/UnicodeType.purs index 7e4ecb9ccd..a65d4a30d8 100644 --- a/examples/passing/UnicodeType.purs +++ b/examples/passing/UnicodeType.purs @@ -10,13 +10,13 @@ class (Monad m) <= Monad2 m where f ∷ ∀ m. Monad m ⇒ Int → m Int f n = do - n' ← return n - return n' + n' ← pure n + pure n' f' :: forall m. Monad m => Int -> m Int f' n = do - n' <- return n - return n' + n' <- pure n + pure n' (←→) a b = a ←→ b diff --git a/examples/passing/Unit.purs b/examples/passing/Unit.purs index 5e555283b1..808cd5ffbe 100644 --- a/examples/passing/Unit.purs +++ b/examples/passing/Unit.purs @@ -3,4 +3,4 @@ module Main where import Prelude import Control.Monad.Eff.Console -main = print (const unit $ "Hello world") +main = logShow (const unit $ "Hello world") diff --git a/examples/passing/Where.purs b/examples/passing/Where.purs index 942255fe5f..b090ed34a2 100644 --- a/examples/passing/Where.purs +++ b/examples/passing/Where.purs @@ -40,10 +40,10 @@ test7 x = go x go y = go $ (y + x / y) / 2.0 main = do - Control.Monad.Eff.Console.print (test1 1.0) - Control.Monad.Eff.Console.print (test2 1.0 2.0) - Control.Monad.Eff.Console.print test3 - Control.Monad.Eff.Console.print test4 - Control.Monad.Eff.Console.print test5 - Control.Monad.Eff.Console.print test6 - Control.Monad.Eff.Console.print (test7 100.0) + Control.Monad.Eff.Console.logShow (test1 1.0) + Control.Monad.Eff.Console.logShow (test2 1.0 2.0) + Control.Monad.Eff.Console.logShow test3 + Control.Monad.Eff.Console.logShow test4 + Control.Monad.Eff.Console.logShow test5 + Control.Monad.Eff.Console.logShow test6 + Control.Monad.Eff.Console.logShow (test7 100.0) diff --git a/psci/PSCi/Module.hs b/psci/PSCi/Module.hs index b97f1d52bd..017d0b654e 100644 --- a/psci/PSCi/Module.hs +++ b/psci/PSCi/Module.hs @@ -25,15 +25,15 @@ supportModule = [ "module S where" , "" , "import Prelude" - , "import Control.Monad.Eff" - , "import Control.Monad.Eff.Console" - , "import Control.Monad.Eff.Unsafe" + , "import Control.Monad.Eff (Eff)" + , "import Control.Monad.Eff.Console (CONSOLE, logShow)" + , "import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)" , "" , "class Eval a where" , " eval :: a -> Eff (console :: CONSOLE) Unit" , "" , "instance evalShow :: (Show a) => Eval a where" - , " eval = print" + , " eval = logShow" , "" , "instance evalEff :: (Eval a) => Eval (Eff eff a) where" , " eval x = unsafeInterleaveEff x >>= eval" diff --git a/purescript.cabal b/purescript.cabal index cf82b2e641..8911764eb4 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -24,16 +24,9 @@ extra-source-files: examples/passing/*.purs , examples/docs/bower_components/purescript-prelude/src/*.purs , examples/docs/bower.json , examples/docs/src/*.purs - , tests/support/setup.js , tests/support/package.json - , tests/support/prelude/bower.json - , tests/support/prelude/src/*.purs - , tests/support/prelude/src/*.js - , tests/support/prelude/LICENSE , tests/support/bower.json , tests/support/setup-win.cmd - , tests/support/flattened/*.purs - , tests/support/flattened/*.js , tests/support/psci/*.purs , tests/support/pscide/src/*.purs , tests/support/pscide/src/*.js diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index bcc2b395b3..b4b421bd41 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -89,16 +89,16 @@ inlineCommonValues = everywhereOnJS convert convert (JSApp ss (JSApp _ (JSApp _ fn [dict]) [x]) [y]) | isDict' semiringInt dict && isFn' fnAdd fn = intOp ss Add x y | isDict' semiringInt dict && isFn' fnMultiply fn = intOp ss Multiply x y - | isDict' moduloSemiringInt dict && isFn' fnDivide fn = intOp ss Divide x y + | isDict' euclideanRingInt dict && isFn' fnDivide fn = intOp ss Divide x y | isDict' ringInt dict && isFn' fnSubtract fn = intOp ss Subtract x y convert other = other fnZero = [(C.prelude, C.zero), (C.dataSemiring, C.zero)] fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)] fnBottom = [(C.prelude, C.bottom), (C.dataBounded, C.bottom)] fnTop = [(C.prelude, C.top), (C.dataBounded, C.top)] - fnAdd = [(C.prelude, (C.+)), (C.prelude, C.add), (C.dataSemiring, (C.+)), (C.dataSemiring, C.add)] - fnDivide = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataModuloSemiring, C.div)] - fnMultiply = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, (C.*)), (C.dataSemiring, C.mul)] + fnAdd = [(C.prelude, (C.+)), (C.prelude, (C.add)), (C.dataSemiring, (C.+)), (C.dataSemiring, (C.add))] + fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataEuclideanRing, C.div)] + fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))] fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)] intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0)) @@ -122,8 +122,8 @@ inlineCommonOperators = applyAll $ , binary ringInt opSub Subtract , unary ringInt opNegate Negate - , binary moduloSemiringNumber opDiv Divide - , binary moduloSemiringInt opMod Modulus + , binary euclideanRingNumber opDiv Divide + , binary euclideanRingInt opMod Modulus , binary eqNumber opEq EqualTo , binary eqNumber opNotEq NotEqualTo @@ -159,9 +159,9 @@ inlineCommonOperators = applyAll $ , binary semigroupString opAppend Add - , binary booleanAlgebraBoolean opConj And - , binary booleanAlgebraBoolean opDisj Or - , unary booleanAlgebraBoolean opNot Not + , binary heytingAlgebraBoolean opConj And + , binary heytingAlgebraBoolean opDisj Or + , unary heytingAlgebraBoolean opNot Not , binary' C.dataIntBits (C..|.) BitwiseOr , binary' C.dataIntBits (C..&.) BitwiseAnd @@ -271,11 +271,11 @@ ringNumber = [(C.prelude, C.ringNumber), (C.dataRing, C.ringNumber)] ringInt :: [(String, String)] ringInt = [(C.prelude, C.ringInt), (C.dataRing, C.ringInt)] -moduloSemiringNumber :: [(String, String)] -moduloSemiringNumber = [(C.prelude, C.moduloSemiringNumber), (C.dataModuloSemiring, C.moduloSemiringNumber)] +euclideanRingNumber :: [(String, String)] +euclideanRingNumber = [(C.prelude, C.moduloSemiringNumber), (C.dataEuclideanRing, C.euclideanRingNumber)] -moduloSemiringInt :: [(String, String)] -moduloSemiringInt = [(C.prelude, C.moduloSemiringInt), (C.dataModuloSemiring, C.moduloSemiringInt)] +euclideanRingInt :: [(String, String)] +euclideanRingInt = [(C.prelude, C.moduloSemiringInt), (C.dataEuclideanRing, C.euclideanRingInt)] eqNumber :: [(String, String)] eqNumber = [(C.prelude, C.eqNumber), (C.dataEq, C.eqNumber)] @@ -313,8 +313,8 @@ semigroupString = [(C.prelude, C.semigroupString), (C.dataSemigroup, C.semigroup boundedBoolean :: [(String, String)] boundedBoolean = [(C.prelude, C.boundedBoolean), (C.dataBounded, C.boundedBoolean)] -booleanAlgebraBoolean :: [(String, String)] -booleanAlgebraBoolean = [(C.prelude, C.booleanAlgebraBoolean), (C.dataBooleanAlgebra, C.booleanAlgebraBoolean)] +heytingAlgebraBoolean :: [(String, String)] +heytingAlgebraBoolean = [(C.prelude, C.booleanAlgebraBoolean), (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)] semigroupoidFn :: [(String, String)] semigroupoidFn = [(C.prelude, C.semigroupoidFn), (C.controlSemigroupoid, C.semigroupoidFn)] @@ -353,16 +353,16 @@ opNegate :: [(String, String)] opNegate = [(C.prelude, C.negate), (C.dataRing, C.negate)] opDiv :: [(String, String)] -opDiv = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataModuloSemiring, C.div)] +opDiv = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataEuclideanRing, C.div)] opMod :: [(String, String)] -opMod = [(C.prelude, C.mod), (C.dataModuloSemiring, C.mod)] +opMod = [(C.prelude, C.mod), (C.dataEuclideanRing, C.mod)] opConj :: [(String, String)] -opConj = [(C.prelude, (C.&&)), (C.prelude, C.conj), (C.dataBooleanAlgebra, C.conj)] +opConj = [(C.prelude, (C.&&)), (C.prelude, C.conj), (C.dataHeytingAlgebra, C.conj)] opDisj :: [(String, String)] -opDisj = [(C.prelude, (C.||)), (C.prelude, C.disj), (C.dataBooleanAlgebra, C.disj)] +opDisj = [(C.prelude, (C.||)), (C.prelude, C.disj), (C.dataHeytingAlgebra, C.disj)] opNot :: [(String, String)] -opNot = [(C.prelude, C.not), (C.dataBooleanAlgebra, C.not)] +opNot = [(C.prelude, C.not), (C.dataHeytingAlgebra, C.not)] diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 6a57d3f3ff..15c19c2f78 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -247,6 +247,12 @@ moduloSemiringNumber = "moduloSemiringNumber" moduloSemiringInt :: String moduloSemiringInt = "moduloSemiringInt" +euclideanRingNumber :: String +euclideanRingNumber = "euclideanRingNumber" + +euclideanRingInt :: String +euclideanRingInt = "euclideanRingInt" + ordBoolean :: String ordBoolean = "ordBoolean" @@ -283,6 +289,9 @@ boundedBoolean = "boundedBoolean" booleanAlgebraBoolean :: String booleanAlgebraBoolean = "booleanAlgebraBoolean" +heytingAlgebraBoolean :: String +heytingAlgebraBoolean = "heytingAlgebraBoolean" + semigroupString :: String semigroupString = "semigroupString" @@ -348,11 +357,8 @@ dataBounded = "Data_Bounded" dataSemigroup :: String dataSemigroup = "Data_Semigroup" -dataModuloSemiring :: String -dataModuloSemiring = "Data_ModuloSemiring" - -dataBooleanAlgebra :: String -dataBooleanAlgebra = "Data_BooleanAlgebra" +dataHeytingAlgebra :: String +dataHeytingAlgebra = "Data_HeytingAlgebra" dataEq :: String dataEq = "Data_Eq" @@ -366,6 +372,9 @@ dataSemiring = "Data_Semiring" dataRing :: String dataRing = "Data_Ring" +dataEuclideanRing :: String +dataEuclideanRing = "Data_EuclideanRing" + dataFunction :: String dataFunction = "Data_Function" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index f788d485fc..0a01733734 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -50,11 +50,11 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args - | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Eq") + | className == Qualified (Just (ModuleName [ ProperName "Data", ProperName "Eq" ])) (ProperName "Eq") , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon - | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Ord") + | className == Qualified (Just (ModuleName [ ProperName "Data", ProperName "Ord" ])) (ProperName "Ord") , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon @@ -218,8 +218,8 @@ deriveGeneric mn ds tyConNm dargs = do = App (lamCase (Ident "r") [ mkRecCase (decomposeRec rec) , CaseAlternative [NullBinder] (Right mkNothing) ]) - (App e (mkPrelVar (Ident "unit"))) - fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit"))) + (App e unitVal) + fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e unitVal) mkRecCase :: [(String, Type)] -> CaseAlternative mkRecCase rs = @@ -237,10 +237,13 @@ deriveGeneric mn ds tyConNm dargs = do -- Helpers liftApplicative :: Expr -> [Expr] -> Expr - liftApplicative = foldl' (\x e -> App (App (mkPrelVar (Ident "apply")) x) e) + liftApplicative = foldl' (\x e -> App (App applyFn x) e) - mkPrelVar :: Ident -> Expr - mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude])) + unitVal :: Expr + unitVal = mkVarMn (Just (ModuleName [ProperName "Data", ProperName "Unit"])) (Ident "unit") + + applyFn :: Expr + applyFn = mkVarMn (Just (ModuleName [ProperName "Control", ProperName "Apply"])) (Ident "apply") mkGenVar :: Ident -> Expr mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) @@ -265,10 +268,10 @@ deriveEq mn ds tyConNm = do mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration" preludeConj :: Expr -> Expr -> Expr - preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.conj))) + preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "HeytingAlgebra"])) (Ident C.conj))) preludeEq :: Expr -> Expr -> Expr - preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.eq))) + preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Eq"])) (Ident C.eq))) addCatch :: [CaseAlternative] -> [CaseAlternative] addCatch xs @@ -326,13 +329,19 @@ deriveOrd mn ds tyConNm = do | null xs = [catchAll] -- No type constructors | otherwise = xs where - catchAll = CaseAlternative [NullBinder, NullBinder] (Right (preludeCtor "EQ")) + catchAll = CaseAlternative [NullBinder, NullBinder] (Right (orderingCtor "EQ")) + + orderingName :: String -> Qualified (ProperName a) + orderingName = Qualified (Just (ModuleName [ProperName "Data", ProperName "Ordering"])) . ProperName + + orderingCtor :: String -> Expr + orderingCtor = Constructor . orderingName - preludeCtor :: String -> Expr - preludeCtor = Constructor . Qualified (Just (ModuleName [ProperName C.prelude])) . ProperName + orderingBinder :: String -> Binder + orderingBinder name = ConstructorBinder (orderingName name) [] - preludeCompare :: Expr -> Expr -> Expr - preludeCompare = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.compare))) + ordCompare :: Expr -> Expr -> Expr + ordCompare = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Ord"])) (Ident C.compare))) mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative] mkCtorClauses ((ctorName, tys), isLast) = do @@ -342,11 +351,11 @@ deriveOrd mn ds tyConNm = do extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) , NullBinder ] - (Right (preludeCtor "LT")) + (Right (orderingCtor "LT")) , CaseAlternative [ NullBinder , ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) ] - (Right (preludeCtor "GT")) + (Right (orderingCtor "GT")) ] | otherwise = [] return $ CaseAlternative [ caseBinder identsL @@ -359,12 +368,12 @@ deriveOrd mn ds tyConNm = do caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents) appendAll :: [Expr] -> Expr - appendAll [] = preludeCtor "EQ" + appendAll [] = orderingCtor "EQ" appendAll [x] = x - appendAll (x : xs) = Case [x] [ CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "LT")) [] ] - (Right (preludeCtor "LT")) - , CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "GT")) [] ] - (Right (preludeCtor "GT")) + appendAll (x : xs) = Case [x] [ CaseAlternative [orderingBinder "LT"] + (Right (orderingCtor "LT")) + , CaseAlternative [orderingBinder "GT"] + (Right (orderingCtor "GT")) , CaseAlternative [ NullBinder ] (Right (appendAll xs)) ] @@ -374,7 +383,7 @@ deriveOrd mn ds tyConNm = do appendAll . map (\(str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ) $ decomposeRec rec - toOrdering l r _ = preludeCompare l r + toOrdering l r _ = ordCompare l r findTypeDecl :: (MonadError MultipleErrors m) diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs index 999281993a..6ccccb3f30 100644 --- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs +++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs @@ -44,9 +44,9 @@ spec = beforeAll_ setup $ afterAll_ teardown $ describe "Adding imports" $ do sourceFileSkeleton importSection = [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId = id"] it "adds an implicit import" $ do - withSupportFiles (Integration.addImplicitImport "Prelude") + withSupportFiles (Integration.addImplicitImport "ImportsSpec1") outputFileShouldBe (sourceFileSkeleton - [ "import Prelude" + [ "import ImportsSpec1" , "import Main (id)" ]) it "adds an explicit unqualified import" $ do diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs index cea69fdf77..81f0be6ee7 100644 --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -111,8 +111,6 @@ fileGlob :: String fileGlob = unwords [ "\"src/**/*.purs\"" , "\"src/**/*.js\"" - , "\"bower_components/purescript-*/**/*.purs\"" - , "\"bower_components/purescript-*/**/*.js\"" ] -- Integration Testing API diff --git a/tests/Main.hs b/tests/Main.hs index 2a246efe97..61d1824e35 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -9,10 +9,11 @@ import Prelude () import Prelude.Compat import qualified TestCompiler -import qualified TestPscPublish import qualified TestDocs import qualified TestPsci import qualified TestPscIde +import qualified TestPscPublish +import qualified TestUtils import System.IO (hSetEncoding, stdout, stderr, utf8) @@ -21,6 +22,8 @@ main = do hSetEncoding stdout utf8 hSetEncoding stderr utf8 + heading "Updating support code" + TestUtils.updateSupportCode heading "Main compiler test suite" TestCompiler.main heading "Documentation test suite" diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 43b07282ee..f795036d27 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -52,8 +52,8 @@ main :: IO () main = do cwd <- getCurrentDirectory - let supportDir = cwd "tests" "support" "flattened" - let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir + let supportDir = cwd "tests" "support" "bower_components" + let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir supportPurs <- supportFiles "purs" supportJS <- supportFiles "js" diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index af84c961fd..1c55a8a50d 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -24,7 +24,7 @@ import Language.PureScript.Publish.ErrorsWarnings as Publish import TestUtils main :: IO () -main = testPackage "tests/support/prelude" +main = testPackage "tests/support/bower_components/purescript-prelude" data TestResult = ParseFailed String diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index b7f1239ec2..967c1b2a4d 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -75,13 +75,13 @@ completionTestData = , (":show a", []) -- :type should complete values and data constructors in scope - , (":type Control.Monad.Eff.Console.lo", [":type Control.Monad.Eff.Console.log"]) - , (":type uni", [":type unit"]) - , (":type E", [":type EQ"]) + , (":type Control.Monad.Eff.Console.lo", [":type Control.Monad.Eff.Console.log", ":type Control.Monad.Eff.Console.logShow"]) + --, (":type uni", [":type unit"]) + --, (":type E", [":type EQ"]) -- :kind should complete types in scope - , (":kind C", [":kind Control.Monad.Eff.Pure"]) - , (":kind O", [":kind Ordering"]) + --, (":kind C", [":kind Control.Monad.Eff.Pure"]) + --, (":kind O", [":kind Ordering"]) -- Only one argument for directives should be completed , (":show import ", []) @@ -98,10 +98,10 @@ completionTestData = , ("34", []) -- Identifiers and data constructors should be completed - , ("uni", ["unit"]) + --, ("uni", ["unit"]) , ("Control.Monad.Eff.Class.", ["Control.Monad.Eff.Class.liftEff"]) - , ("G", ["GT"]) - , ("Prelude.L", ["Prelude.LT"]) + --, ("G", ["GT"]) + , ("Data.Ordering.L", ["Data.Ordering.LT"]) -- if a module is imported qualified, values should complete under the -- qualified name, as well as the original name. @@ -125,8 +125,8 @@ runCM act = do getPSCiState :: IO PSCiState getPSCiState = do cwd <- getCurrentDirectory - let supportDir = cwd "tests" "support" "flattened" - let supportFiles ext = Glob.globDir1 (Glob.compile ("*." ++ ext)) supportDir + let supportDir = cwd "tests" "support" "bower_components" + let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir pursFiles <- supportFiles "purs" jsFiles <- supportFiles "js" @@ -147,12 +147,37 @@ controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST")) supportModules :: [String] supportModules = - [ "Control.Monad.Eff.Class" - , "Control.Monad.Eff.Console" + [ "Control.Applicative" + , "Control.Apply" + , "Control.Bind" + , "Control.Category" + , "Control.Monad" , "Control.Monad.Eff" + , "Control.Monad.Eff.Class" + , "Control.Monad.Eff.Console" , "Control.Monad.Eff.Unsafe" , "Control.Monad.ST" + , "Control.Semigroupoid" + , "Data.Boolean" + , "Data.BooleanAlgebra" + , "Data.Bounded" + , "Data.CommutativeRing" + , "Data.Eq" + , "Data.EuclideanRing" + , "Data.Field" , "Data.Function" + , "Data.Function.Uncurried" + , "Data.Functor" + , "Data.HeytingAlgebra" + , "Data.Ord" + , "Data.Ord.Unsafe" + , "Data.Ordering" + , "Data.Ring" + , "Data.Semigroup" + , "Data.Semiring" + , "Data.Show" + , "Data.Unit" + , "Data.Void" , "Prelude" , "Test.Assert" ] diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 7195db24bf..640f9f3c08 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -1,15 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Main --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ {-# LANGUAGE ScopedTypeVariables #-} module TestUtils where @@ -17,7 +5,6 @@ module TestUtils where import Prelude () import Prelude.Compat -import Data.Maybe (fromMaybe) import Control.Monad import Control.Monad.Trans.Maybe import Control.Exception @@ -26,8 +13,6 @@ import System.Process import System.Directory import System.Info -import Language.PureScript.Crash - findNodeProcess :: IO (Maybe String) findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names where @@ -43,7 +28,6 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names -- updateSupportCode :: IO () updateSupportCode = do - node <- fromMaybe (internalError "cannot find node executable") <$> findNodeProcess setCurrentDirectory "tests/support" if System.Info.os == "mingw32" then callProcess "setup-win.cmd" [] @@ -52,7 +36,6 @@ updateSupportCode = do -- Sometimes we run as a root (e.g. in simple docker containers) -- And we are non-interactive: https://github.com/bower/bower/issues/1162 callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"] - callProcess node ["setup.js"] setCurrentDirectory "../.." pushd :: forall a. FilePath -> IO a -> IO a @@ -62,4 +45,3 @@ pushd dir act = do result <- try act :: IO (Either IOException a) setCurrentDirectory original either throwIO return result - diff --git a/tests/support/bower.json b/tests/support/bower.json index c29e6e82bc..331e059b1b 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -1,11 +1,11 @@ { "name": "purescript-test-suite-support", "dependencies": { - "purescript-eff": "0.1.0", - "purescript-prelude": "0.1.3", - "purescript-assert": "0.1.1", - "purescript-st": "0.1.0", - "purescript-console": "0.1.0", - "purescript-functions": "0.1.0" + "purescript-assert": "1.0.0-rc.1", + "purescript-console": "1.0.0-rc.1", + "purescript-eff": "1.0.0-rc.1", + "purescript-functions": "1.0.0-rc.1", + "purescript-prelude": "1.0.0-rc.3", + "purescript-st": "1.0.0-rc.1" } } diff --git a/tests/support/flattened/Control-Monad-Eff-Class.purs b/tests/support/flattened/Control-Monad-Eff-Class.purs deleted file mode 100644 index dbfd58ebcf..0000000000 --- a/tests/support/flattened/Control-Monad-Eff-Class.purs +++ /dev/null @@ -1,24 +0,0 @@ -module Control.Monad.Eff.Class - ( MonadEff - , liftEff - ) where - -import Prelude - -import Control.Monad.Eff - --- | The `MonadEff` class captures those monads which support native effects. --- | --- | Instances are provided for `Eff` itself, and the standard monad transformers. --- | --- | `liftEff` can be used in any appropriate monad transformer stack to lift an action --- | of type `Eff eff a` into the monad. --- | --- | Note that `MonadEff` is parameterized by the row of effects, so type inference can be --- | tricky. It is generally recommended to either work with a polymorphic row of effects, --- | or a concrete, closed row of effects such as `(trace :: Trace)`. -class (Monad m) <= MonadEff eff m where - liftEff :: forall a. Eff eff a -> m a - -instance monadEffEff :: MonadEff eff (Eff eff) where - liftEff = id diff --git a/tests/support/flattened/Control-Monad-Eff-Console.js b/tests/support/flattened/Control-Monad-Eff-Console.js deleted file mode 100644 index 9ccfc26b45..0000000000 --- a/tests/support/flattened/Control-Monad-Eff-Console.js +++ /dev/null @@ -1,18 +0,0 @@ -/* global exports, console */ -"use strict"; - -// module Control.Monad.Eff.Console - -exports.log = function (s) { - return function () { - console.log(s); - return {}; - }; -}; - -exports.error = function (s) { - return function () { - console.error(s); - return {}; - }; -}; diff --git a/tests/support/flattened/Control-Monad-Eff-Console.purs b/tests/support/flattened/Control-Monad-Eff-Console.purs deleted file mode 100644 index 0a03ee4d3e..0000000000 --- a/tests/support/flattened/Control-Monad-Eff-Console.purs +++ /dev/null @@ -1,18 +0,0 @@ -module Control.Monad.Eff.Console where - -import Prelude - -import Control.Monad.Eff - --- | The `CONSOLE` effect represents those computations which write to the console. -foreign import data CONSOLE :: ! - --- | Write a message to the console. -foreign import log :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit - --- | Write an error to the console. -foreign import error :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit - --- | Write a value to the console, using its `Show` instance to produce a `String`. -print :: forall a eff. (Show a) => a -> Eff (console :: CONSOLE | eff) Unit -print = log <<< show diff --git a/tests/support/flattened/Control-Monad-Eff-Unsafe.js b/tests/support/flattened/Control-Monad-Eff-Unsafe.js deleted file mode 100644 index bada18a47e..0000000000 --- a/tests/support/flattened/Control-Monad-Eff-Unsafe.js +++ /dev/null @@ -1,8 +0,0 @@ -/* global exports */ -"use strict"; - -// module Control.Monad.Eff.Unsafe - -exports.unsafeInterleaveEff = function (f) { - return f; -}; diff --git a/tests/support/flattened/Control-Monad-Eff-Unsafe.purs b/tests/support/flattened/Control-Monad-Eff-Unsafe.purs deleted file mode 100644 index 5d6f104483..0000000000 --- a/tests/support/flattened/Control-Monad-Eff-Unsafe.purs +++ /dev/null @@ -1,10 +0,0 @@ -module Control.Monad.Eff.Unsafe where - -import Prelude - -import Control.Monad.Eff - --- | Change the type of an effectful computation, allowing it to be run in another context. --- | --- | Note: use of this function can result in arbitrary side-effects. -foreign import unsafeInterleaveEff :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a diff --git a/tests/support/flattened/Control-Monad-Eff.js b/tests/support/flattened/Control-Monad-Eff.js deleted file mode 100644 index 1498f2139d..0000000000 --- a/tests/support/flattened/Control-Monad-Eff.js +++ /dev/null @@ -1,62 +0,0 @@ -/* global exports */ -"use strict"; - -// module Control.Monad.Eff - -exports.returnE = function (a) { - return function () { - return a; - }; -}; - -exports.bindE = function (a) { - return function (f) { - return function () { - return f(a())(); - }; - }; -}; - -exports.runPure = function (f) { - return f(); -}; - -exports.untilE = function (f) { - return function () { - while (!f()); - return {}; - }; -}; - -exports.whileE = function (f) { - return function (a) { - return function () { - while (f()) { - a(); - } - return {}; - }; - }; -}; - -exports.forE = function (lo) { - return function (hi) { - return function (f) { - return function () { - for (var i = lo; i < hi; i++) { - f(i)(); - } - }; - }; - }; -}; - -exports.foreachE = function (as) { - return function (f) { - return function () { - for (var i = 0, l = as.length; i < l; i++) { - f(as[i])(); - } - }; - }; -}; diff --git a/tests/support/flattened/Control-Monad-Eff.purs b/tests/support/flattened/Control-Monad-Eff.purs deleted file mode 100644 index 0417c198b7..0000000000 --- a/tests/support/flattened/Control-Monad-Eff.purs +++ /dev/null @@ -1,67 +0,0 @@ -module Control.Monad.Eff - ( Eff() - , Pure() - , runPure - , untilE, whileE, forE, foreachE - ) where - -import Prelude - --- | The `Eff` type constructor is used to represent _native_ effects. --- | --- | See [Handling Native Effects with the Eff Monad](https://github.com/purescript/purescript/wiki/Handling-Native-Effects-with-the-Eff-Monad) for more details. --- | --- | The first type parameter is a row of effects which represents the contexts in which a computation can be run, and the second type parameter is the return type. -foreign import data Eff :: # ! -> * -> * - -foreign import returnE :: forall e a. a -> Eff e a - -foreign import bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b - --- | The `Pure` type synonym represents _pure_ computations, i.e. ones in which all effects have been handled. --- | --- | The `runPure` function can be used to run pure computations and obtain their result. -type Pure a = forall e. Eff e a - --- | Run a pure computation and return its result. --- | --- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach --- | is to use parentheses instead. -foreign import runPure :: forall a. Pure a -> a - -instance functorEff :: Functor (Eff e) where - map = liftA1 - -instance applyEff :: Apply (Eff e) where - apply = ap - -instance applicativeEff :: Applicative (Eff e) where - pure = returnE - -instance bindEff :: Bind (Eff e) where - bind = bindE - -instance monadEff :: Monad (Eff e) - --- | Loop until a condition becomes `true`. --- | --- | `untilE b` is an effectful computation which repeatedly runs the effectful computation `b`, --- | until its return value is `true`. -foreign import untilE :: forall e. Eff e Boolean -> Eff e Unit - --- | Loop while a condition is `true`. --- | --- | `whileE b m` is effectful computation which runs the effectful computation `b`. If its result is --- | `true`, it runs the effectful computation `m` and loops. If not, the computation ends. -foreign import whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit - --- | Loop over a consecutive collection of numbers. --- | --- | `forE lo hi f` runs the computation returned by the function `f` for each of the inputs --- | between `lo` (inclusive) and `hi` (exclusive). -foreign import forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit - --- | Loop over an array of values. --- | --- | `foreach xs f` runs the computation returned by the function `f` for each of the inputs `xs`. -foreign import foreachE :: forall e a. Array a -> (a -> Eff e Unit) -> Eff e Unit diff --git a/tests/support/flattened/Control-Monad-ST.js b/tests/support/flattened/Control-Monad-ST.js deleted file mode 100644 index 64597c12c9..0000000000 --- a/tests/support/flattened/Control-Monad-ST.js +++ /dev/null @@ -1,38 +0,0 @@ -/* global exports */ -"use strict"; - -// module Control.Monad.ST - -exports.newSTRef = function (val) { - return function () { - return { value: val }; - }; -}; - -exports.readSTRef = function (ref) { - return function () { - return ref.value; - }; -}; - -exports.modifySTRef = function (ref) { - return function (f) { - return function () { - /* jshint boss: true */ - return ref.value = f(ref.value); - }; - }; -}; - -exports.writeSTRef = function (ref) { - return function (a) { - return function () { - /* jshint boss: true */ - return ref.value = a; - }; - }; -}; - -exports.runST = function (f) { - return f; -}; diff --git a/tests/support/flattened/Control-Monad-ST.purs b/tests/support/flattened/Control-Monad-ST.purs deleted file mode 100644 index ac113e58a0..0000000000 --- a/tests/support/flattened/Control-Monad-ST.purs +++ /dev/null @@ -1,42 +0,0 @@ -module Control.Monad.ST where - -import Prelude - -import Control.Monad.Eff (Eff(), runPure) - --- | The `ST` effect represents _local mutation_, i.e. mutation which does not "escape" into the surrounding computation. --- | --- | An `ST` computation is parameterized by a phantom type which is used to restrict the set of reference cells it is allowed to access. --- | --- | The `runST` function can be used to handle the `ST` effect. -foreign import data ST :: * -> ! - --- | The type `STRef s a` represents a mutable reference holding a value of type `a`, which can be used with the `ST s` effect. -foreign import data STRef :: * -> * -> * - --- | Create a new mutable reference. -foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a) - --- | Read the current value of a mutable reference. -foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a - --- | Modify the value of a mutable reference by applying a function to the current value. -foreign import modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a - --- | Set the value of a mutable reference. -foreign import writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a - --- | Run an `ST` computation. --- | --- | Note: the type of `runST` uses a rank-2 type to constrain the phantom type `s`, such that the computation must not leak any mutable references --- | to the surrounding computation. --- | --- | It may cause problems to apply this function using the `$` operator. The recommended approach is to use parentheses instead. -foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a - --- | A convenience function which combines `runST` with `runPure`, which can be used when the only required effect is `ST`. --- | --- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach --- | is to use parentheses instead. -pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a -pureST st = runPure (runST st) diff --git a/tests/support/flattened/Data-Function.js b/tests/support/flattened/Data-Function.js deleted file mode 100644 index 0d6d0f4ede..0000000000 --- a/tests/support/flattened/Data-Function.js +++ /dev/null @@ -1,233 +0,0 @@ -/* global exports */ -"use strict"; - -// module Data.Function - -exports.mkFn0 = function (fn) { - return function () { - return fn({}); - }; -}; - -exports.mkFn1 = function (fn) { - return function (a) { - return fn(a); - }; -}; - -exports.mkFn2 = function (fn) { - /* jshint maxparams: 2 */ - return function (a, b) { - return fn(a)(b); - }; -}; - -exports.mkFn3 = function (fn) { - /* jshint maxparams: 3 */ - return function (a, b, c) { - return fn(a)(b)(c); - }; -}; - -exports.mkFn4 = function (fn) { - /* jshint maxparams: 4 */ - return function (a, b, c, d) { - return fn(a)(b)(c)(d); - }; -}; - -exports.mkFn5 = function (fn) { - /* jshint maxparams: 5 */ - return function (a, b, c, d, e) { - return fn(a)(b)(c)(d)(e); - }; -}; - -exports.mkFn6 = function (fn) { - /* jshint maxparams: 6 */ - return function (a, b, c, d, e, f) { - return fn(a)(b)(c)(d)(e)(f); - }; -}; - -exports.mkFn7 = function (fn) { - /* jshint maxparams: 7 */ - return function (a, b, c, d, e, f, g) { - return fn(a)(b)(c)(d)(e)(f)(g); - }; -}; - -exports.mkFn8 = function (fn) { - /* jshint maxparams: 8 */ - return function (a, b, c, d, e, f, g, h) { - return fn(a)(b)(c)(d)(e)(f)(g)(h); - }; -}; - -exports.mkFn9 = function (fn) { - /* jshint maxparams: 9 */ - return function (a, b, c, d, e, f, g, h, i) { - return fn(a)(b)(c)(d)(e)(f)(g)(h)(i); - }; -}; - -exports.mkFn10 = function (fn) { - /* jshint maxparams: 10 */ - return function (a, b, c, d, e, f, g, h, i, j) { - return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j); - }; -}; - -exports.runFn0 = function (fn) { - return fn(); -}; - -exports.runFn1 = function (fn) { - return function (a) { - return fn(a); - }; -}; - -exports.runFn2 = function (fn) { - return function (a) { - return function (b) { - return fn(a, b); - }; - }; -}; - -exports.runFn3 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return fn(a, b, c); - }; - }; - }; -}; - -exports.runFn4 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return function (d) { - return fn(a, b, c, d); - }; - }; - }; - }; -}; - -exports.runFn5 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return function (d) { - return function (e) { - return fn(a, b, c, d, e); - }; - }; - }; - }; - }; -}; - -exports.runFn6 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return function (d) { - return function (e) { - return function (f) { - return fn(a, b, c, d, e, f); - }; - }; - }; - }; - }; - }; -}; - -exports.runFn7 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return function (d) { - return function (e) { - return function (f) { - return function (g) { - return fn(a, b, c, d, e, f, g); - }; - }; - }; - }; - }; - }; - }; -}; - -exports.runFn8 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return function (d) { - return function (e) { - return function (f) { - return function (g) { - return function (h) { - return fn(a, b, c, d, e, f, g, h); - }; - }; - }; - }; - }; - }; - }; - }; -}; - -exports.runFn9 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return function (d) { - return function (e) { - return function (f) { - return function (g) { - return function (h) { - return function (i) { - return fn(a, b, c, d, e, f, g, h, i); - }; - }; - }; - }; - }; - }; - }; - }; - }; -}; - -exports.runFn10 = function (fn) { - return function (a) { - return function (b) { - return function (c) { - return function (d) { - return function (e) { - return function (f) { - return function (g) { - return function (h) { - return function (i) { - return function (j) { - return fn(a, b, c, d, e, f, g, h, i, j); - }; - }; - }; - }; - }; - }; - }; - }; - }; - }; -}; diff --git a/tests/support/flattened/Data-Function.purs b/tests/support/flattened/Data-Function.purs deleted file mode 100644 index 37ceca1aa0..0000000000 --- a/tests/support/flattened/Data-Function.purs +++ /dev/null @@ -1,113 +0,0 @@ -module Data.Function where - -import Prelude - --- | The `on` function is used to change the domain of a binary operator. --- | --- | For example, we can create a function which compares two records based on the values of their `x` properties: --- | --- | ```purescript --- | compareX :: forall r. { x :: Number | r } -> { x :: Number | r } -> Ordering --- | compareX = compare `on` _.x --- | ``` -on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c -on f g x y = g x `f` g y - --- | A function of zero arguments -foreign import data Fn0 :: * -> * - --- | A function of one argument -foreign import data Fn1 :: * -> * -> * - --- | A function of two arguments -foreign import data Fn2 :: * -> * -> * -> * - --- | A function of three arguments -foreign import data Fn3 :: * -> * -> * -> * -> * - --- | A function of four arguments -foreign import data Fn4 :: * -> * -> * -> * -> * -> * - --- | A function of five arguments -foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> * - --- | A function of six arguments -foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> * - --- | A function of seven arguments -foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> * - --- | A function of eight arguments -foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * - --- | A function of nine arguments -foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * - --- | A function of ten arguments -foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * - --- | Create a function of no arguments -foreign import mkFn0 :: forall a. (Unit -> a) -> Fn0 a - --- | Create a function of one argument -foreign import mkFn1 :: forall a b. (a -> b) -> Fn1 a b - --- | Create a function of two arguments from a curried function -foreign import mkFn2 :: forall a b c. (a -> b -> c) -> Fn2 a b c - --- | Create a function of three arguments from a curried function -foreign import mkFn3 :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d - --- | Create a function of four arguments from a curried function -foreign import mkFn4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e - --- | Create a function of five arguments from a curried function -foreign import mkFn5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f - --- | Create a function of six arguments from a curried function -foreign import mkFn6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g - --- | Create a function of seven arguments from a curried function -foreign import mkFn7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h - --- | Create a function of eight arguments from a curried function -foreign import mkFn8 :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i - --- | Create a function of nine arguments from a curried function -foreign import mkFn9 :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j - --- | Create a function of ten arguments from a curried function -foreign import mkFn10 :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k - --- | Apply a function of no arguments -foreign import runFn0 :: forall a. Fn0 a -> a - --- | Apply a function of one argument -foreign import runFn1 :: forall a b. Fn1 a b -> a -> b - --- | Apply a function of two arguments -foreign import runFn2 :: forall a b c. Fn2 a b c -> a -> b -> c - --- | Apply a function of three arguments -foreign import runFn3 :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d - --- | Apply a function of four arguments -foreign import runFn4 :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e - --- | Apply a function of five arguments -foreign import runFn5 :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f - --- | Apply a function of six arguments -foreign import runFn6 :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g - --- | Apply a function of seven arguments -foreign import runFn7 :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h - --- | Apply a function of eight arguments -foreign import runFn8 :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i - --- | Apply a function of nine arguments -foreign import runFn9 :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j - --- | Apply a function of ten arguments -foreign import runFn10 :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k diff --git a/tests/support/flattened/Prelude.js b/tests/support/flattened/Prelude.js deleted file mode 100644 index 72a855a76c..0000000000 --- a/tests/support/flattened/Prelude.js +++ /dev/null @@ -1,228 +0,0 @@ -/* global exports */ -"use strict"; - -// module Prelude - -//- Functor -------------------------------------------------------------------- - -exports.arrayMap = function (f) { - return function (arr) { - var l = arr.length; - var result = new Array(l); - for (var i = 0; i < l; i++) { - result[i] = f(arr[i]); - } - return result; - }; -}; - -//- Bind ----------------------------------------------------------------------- - -exports.arrayBind = function (arr) { - return function (f) { - var result = []; - for (var i = 0, l = arr.length; i < l; i++) { - Array.prototype.push.apply(result, f(arr[i])); - } - return result; - }; -}; - -//- Monoid --------------------------------------------------------------------- - -exports.concatString = function (s1) { - return function (s2) { - return s1 + s2; - }; -}; - -exports.concatArray = function (xs) { - return function (ys) { - return xs.concat(ys); - }; -}; - -//- Semiring ------------------------------------------------------------------- - -exports.intAdd = function (x) { - return function (y) { - /* jshint bitwise: false */ - return x + y | 0; - }; -}; - -exports.intMul = function (x) { - return function (y) { - /* jshint bitwise: false */ - return x * y | 0; - }; -}; - -exports.numAdd = function (n1) { - return function (n2) { - return n1 + n2; - }; -}; - -exports.numMul = function (n1) { - return function (n2) { - return n1 * n2; - }; -}; - -//- ModuloSemiring ------------------------------------------------------------- - -exports.intDiv = function (x) { - return function (y) { - /* jshint bitwise: false */ - return x / y | 0; - }; -}; - -exports.intMod = function (x) { - return function (y) { - return x % y; - }; -}; - -exports.numDiv = function (n1) { - return function (n2) { - return n1 / n2; - }; -}; - -//- Ring ----------------------------------------------------------------------- - -exports.intSub = function (x) { - return function (y) { - /* jshint bitwise: false */ - return x - y | 0; - }; -}; - -exports.numSub = function (n1) { - return function (n2) { - return n1 - n2; - }; -}; - -//- Eq ------------------------------------------------------------------------- - -exports.refEq = function (r1) { - return function (r2) { - return r1 === r2; - }; -}; - -exports.refIneq = function (r1) { - return function (r2) { - return r1 !== r2; - }; -}; - -exports.eqArrayImpl = function (f) { - return function (xs) { - return function (ys) { - if (xs.length !== ys.length) return false; - for (var i = 0; i < xs.length; i++) { - if (!f(xs[i])(ys[i])) return false; - } - return true; - }; - }; -}; - -exports.ordArrayImpl = function (f) { - return function (xs) { - return function (ys) { - var i = 0; - var xlen = xs.length; - var ylen = ys.length; - while (i < xlen && i < ylen) { - var x = xs[i]; - var y = ys[i]; - var o = f(x)(y); - if (o !== 0) { - return o; - } - i++; - } - if (xlen === ylen) { - return 0; - } else if (xlen > ylen) { - return -1; - } else { - return 1; - } - }; - }; -}; - -//- Ord ------------------------------------------------------------------------ - -exports.unsafeCompareImpl = function (lt) { - return function (eq) { - return function (gt) { - return function (x) { - return function (y) { - return x < y ? lt : x > y ? gt : eq; - }; - }; - }; - }; -}; - -//- Bounded -------------------------------------------------------------------- - -exports.topInt = 2147483647; -exports.bottomInt = -2147483648; - -exports.topChar = String.fromCharCode(65535); -exports.bottomChar = String.fromCharCode(0); - -//- BooleanAlgebra ------------------------------------------------------------- - -exports.boolOr = function (b1) { - return function (b2) { - return b1 || b2; - }; -}; - -exports.boolAnd = function (b1) { - return function (b2) { - return b1 && b2; - }; -}; - -exports.boolNot = function (b) { - return !b; -}; - -//- Show ----------------------------------------------------------------------- - -exports.showIntImpl = function (n) { - return n.toString(); -}; - -exports.showNumberImpl = function (n) { - /* jshint bitwise: false */ - return n === (n | 0) ? n + ".0" : n.toString(); -}; - -exports.showCharImpl = function (c) { - return c === "'" ? "'\\''" : "'" + c + "'"; -}; - -exports.showStringImpl = function (s) { - return JSON.stringify(s); -}; - -exports.showArrayImpl = function (f) { - return function (xs) { - var ss = []; - for (var i = 0, l = xs.length; i < l; i++) { - ss[i] = f(xs[i]); - } - return "[" + ss.join(",") + "]"; - }; -}; diff --git a/tests/support/flattened/Prelude.purs b/tests/support/flattened/Prelude.purs deleted file mode 100644 index 21ec9095fa..0000000000 --- a/tests/support/flattened/Prelude.purs +++ /dev/null @@ -1,872 +0,0 @@ -module Prelude - ( Unit(), unit - , ($), (#) - , flip - , const - , asTypeOf - , otherwise - , Semigroupoid, compose, (<<<), (>>>) - , Category, id - , Functor, map, (<$>), (<#>), void - , Apply, apply, (<*>) - , Applicative, pure, liftA1 - , Bind, bind, (>>=) - , Monad, return, liftM1, ap - , Semigroup, append, (<>), (++) - , Semiring, add, zero, mul, one, (+), (*) - , ModuloSemiring, div, mod, (/) - , Ring, sub, negate, (-) - , Num - , DivisionRing - , Eq, eq, (==), (/=) - , Ordering(..), Ord, compare, (<), (>), (<=), (>=) - , unsafeCompare - , Bounded, top, bottom - , BoundedOrd - , BooleanAlgebra, conj, disj, not, (&&), (||) - , Show, show - ) where - --- | The `Unit` type has a single inhabitant, called `unit`. It represents --- | values with no computational content. --- | --- | `Unit` is often used, wrapped in a monadic type constructor, as the --- | return type of a computation where only --- | the _effects_ are important. -newtype Unit = Unit {} - --- | `unit` is the sole inhabitant of the `Unit` type. -unit :: Unit -unit = Unit {} - -infixr 0 $ -infixl 1 # - --- | Applies a function to its argument. --- | --- | ```purescript --- | length $ groupBy productCategory $ filter isInStock $ products --- | ``` --- | --- | is equivalent to: --- | --- | ```purescript --- | length (groupBy productCategory (filter isInStock products)) --- | ``` --- | --- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of --- | left: `a $ b $ c $ d x = a $ (b $ (c $ (d $ x))) = a (b (c (d x)))` -($) :: forall a b. (a -> b) -> a -> b -($) f x = f x - --- | Applies an argument to a function. --- | --- | ```purescript --- | products # filter isInStock # groupBy productCategory # length --- | ``` --- | --- | is equivalent to: --- | --- | ```purescript --- | length (groupBy productCategory (filter isInStock products)) --- | ``` --- | --- | `(#)` is different from [`($)`](#-1) because it is left-infix instead of --- | right: `x # a # b # c # d = (((x # a) # b) # c) # d = d (c (b (a x)))` -(#) :: forall a b. a -> (a -> b) -> b -(#) x f = f x - --- | Flips the order of the arguments to a function of two arguments. --- | --- | ```purescript --- | flip const 1 2 = const 2 1 = 2 --- | ``` -flip :: forall a b c. (a -> b -> c) -> b -> a -> c -flip f b a = f a b - --- | Returns its first argument and ignores its second. --- | --- | ```purescript --- | const 1 "hello" = 1 --- | ``` -const :: forall a b. a -> b -> a -const a _ = a - --- | This function returns its first argument, and can be used to assert type --- | equalities. This can be useful when types are otherwise ambiguous. --- | --- | ```purescript --- | main = print $ [] `asTypeOf` [0] --- | ``` --- | --- | If instead, we had written `main = print []`, the type of the argument --- | `[]` would have been ambiguous, resulting in a compile-time error. -asTypeOf :: forall a. a -> a -> a -asTypeOf x _ = x - --- | An alias for `true`, which can be useful in guard clauses: --- | --- | ```purescript --- | max x y | x >= y = x --- | | otherwise = y --- | ``` -otherwise :: Boolean -otherwise = true - --- | A `Semigroupoid` is similar to a [`Category`](#category) but does not --- | require an identity element `id`, just composable morphisms. --- | --- | `Semigroupoid`s must satisfy the following law: --- | --- | - Associativity: `p <<< (q <<< r) = (p <<< q) <<< r` --- | --- | One example of a `Semigroupoid` is the function type constructor `(->)`, --- | with `(<<<)` defined as function composition. -class Semigroupoid a where - compose :: forall b c d. a c d -> a b c -> a b d - -instance semigroupoidFn :: Semigroupoid (->) where - compose f g x = f (g x) - -infixr 9 >>> -infixr 9 <<< - --- | `(<<<)` is an alias for `compose`. -(<<<) :: forall a b c d. (Semigroupoid a) => a c d -> a b c -> a b d -(<<<) = compose - --- | Forwards composition, or `(<<<)` with its arguments reversed. -(>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d -(>>>) = flip compose - --- | `Category`s consist of objects and composable morphisms between them, and --- | as such are [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids` --- | must have an identity element. --- | --- | Instances must satisfy the following law in addition to the --- | `Semigroupoid` law: --- | --- | - Identity: `id <<< p = p <<< id = p` -class (Semigroupoid a) <= Category a where - id :: forall t. a t t - -instance categoryFn :: Category (->) where - id x = x - --- | A `Functor` is a type constructor which supports a mapping operation --- | `(<$>)`. --- | --- | `(<$>)` can be used to turn functions `a -> b` into functions --- | `f a -> f b` whose argument and return types use the type constructor `f` --- | to represent some computational context. --- | --- | Instances must satisfy the following laws: --- | --- | - Identity: `(<$>) id = id` --- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)` -class Functor f where - map :: forall a b. (a -> b) -> f a -> f b - -instance functorFn :: Functor ((->) r) where - map = compose - -instance functorArray :: Functor Array where - map = arrayMap - -foreign import arrayMap :: forall a b. (a -> b) -> Array a -> Array b - -infixl 4 <$> -infixl 1 <#> - --- | `(<$>)` is an alias for `map` -(<$>) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b -(<$>) = map - --- | `(<#>)` is `(<$>)` with its arguments reversed. For example: --- | --- | ```purescript --- | [1, 2, 3] <#> \n -> n * n --- | ``` -(<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b -(<#>) fa f = f <$> fa - --- | The `void` function is used to ignore the type wrapped by a --- | [`Functor`](#functor), replacing it with `Unit` and keeping only the type --- | information provided by the type constructor itself. --- | --- | `void` is often useful when using `do` notation to change the return type --- | of a monadic computation: --- | --- | ```purescript --- | main = forE 1 10 \n -> void do --- | print n --- | print (n * n) --- | ``` -void :: forall f a. (Functor f) => f a -> f Unit -void fa = const unit <$> fa - --- | The `Apply` class provides the `(<*>)` which is used to apply a function --- | to an argument under a type constructor. --- | --- | `Apply` can be used to lift functions of two or more arguments to work on --- | values wrapped with the type constructor `f`. It might also be understood --- | in terms of the `lift2` function: --- | --- | ```purescript --- | lift2 :: forall f a b c. (Apply f) => (a -> b -> c) -> f a -> f b -> f c --- | lift2 f a b = f <$> a <*> b --- | ``` --- | --- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts --- | the function application operator `($)` to arguments wrapped with the --- | type constructor `f`. --- | --- | Instances must satisfy the following law in addition to the `Functor` --- | laws: --- | --- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)` --- | --- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor. -class (Functor f) <= Apply f where - apply :: forall a b. f (a -> b) -> f a -> f b - -instance applyFn :: Apply ((->) r) where - apply f g x = f x (g x) - -instance applyArray :: Apply Array where - apply = ap - -infixl 4 <*> - --- | `(<*>)` is an alias for `apply`. -(<*>) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b -(<*>) = apply - --- | The `Applicative` type class extends the [`Apply`](#apply) type class --- | with a `pure` function, which can be used to create values of type `f a` --- | from values of type `a`. --- | --- | Where [`Apply`](#apply) provides the ability to lift functions of two or --- | more arguments to functions whose arguments are wrapped using `f`, and --- | [`Functor`](#functor) provides the ability to lift functions of one --- | argument, `pure` can be seen as the function which lifts functions of --- | _zero_ arguments. That is, `Applicative` functors support a lifting --- | operation for any number of function arguments. --- | --- | Instances must satisfy the following laws in addition to the `Apply` --- | laws: --- | --- | - Identity: `(pure id) <*> v = v` --- | - Composition: `(pure <<<) <*> f <*> g <*> h = f <*> (g <*> h)` --- | - Homomorphism: `(pure f) <*> (pure x) = pure (f x)` --- | - Interchange: `u <*> (pure y) = (pure ($ y)) <*> u` -class (Apply f) <= Applicative f where - pure :: forall a. a -> f a - -instance applicativeFn :: Applicative ((->) r) where - pure = const - -instance applicativeArray :: Applicative Array where - pure x = [x] - --- | `return` is an alias for `pure`. -return :: forall m a. (Applicative m) => a -> m a -return = pure - --- | `liftA1` provides a default implementation of `(<$>)` for any --- | [`Applicative`](#applicative) functor, without using `(<$>)` as provided --- | by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass --- | relationship. --- | --- | `liftA1` can therefore be used to write [`Functor`](#functor) instances --- | as follows: --- | --- | ```purescript --- | instance functorF :: Functor F where --- | map = liftA1 --- | ``` -liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b -liftA1 f a = pure f <*> a - --- | The `Bind` type class extends the [`Apply`](#apply) type class with a --- | "bind" operation `(>>=)` which composes computations in sequence, using --- | the return value of one computation to determine the next computation. --- | --- | The `>>=` operator can also be expressed using `do` notation, as follows: --- | --- | ```purescript --- | x >>= f = do y <- x --- | f y --- | ``` --- | --- | where the function argument of `f` is given the name `y`. --- | --- | Instances must satisfy the following law in addition to the `Apply` --- | laws: --- | --- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)` --- | --- | Associativity tells us that we can regroup operations which use `do` --- | notation so that we can unambiguously write, for example: --- | --- | ```purescript --- | do x <- m1 --- | y <- m2 x --- | m3 x y --- | ``` -class (Apply m) <= Bind m where - bind :: forall a b. m a -> (a -> m b) -> m b - -instance bindFn :: Bind ((->) r) where - bind m f x = f (m x) x - -instance bindArray :: Bind Array where - bind = arrayBind - -foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b - -infixl 1 >>= - --- | `(>>=)` is an alias for `bind`. -(>>=) :: forall m a b. (Bind m) => m a -> (a -> m b) -> m b -(>>=) = bind - --- | The `Monad` type class combines the operations of the `Bind` and --- | `Applicative` type classes. Therefore, `Monad` instances represent type --- | constructors which support sequential composition, and also lifting of --- | functions of arbitrary arity. --- | --- | Instances must satisfy the following laws in addition to the --- | `Applicative` and `Bind` laws: --- | --- | - Left Identity: `pure x >>= f = f x` --- | - Right Identity: `x >>= pure = x` -class (Applicative m, Bind m) <= Monad m - -instance monadFn :: Monad ((->) r) -instance monadArray :: Monad Array - --- | `liftM1` provides a default implementation of `(<$>)` for any --- | [`Monad`](#monad), without using `(<$>)` as provided by the --- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship. --- | --- | `liftM1` can therefore be used to write [`Functor`](#functor) instances --- | as follows: --- | --- | ```purescript --- | instance functorF :: Functor F where --- | map = liftM1 --- | ``` -liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b -liftM1 f a = do - a' <- a - return (f a') - --- | `ap` provides a default implementation of `(<*>)` for any --- | [`Monad`](#monad), without using `(<*>)` as provided by the --- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship. --- | --- | `ap` can therefore be used to write [`Apply`](#apply) instances as --- | follows: --- | --- | ```purescript --- | instance applyF :: Apply F where --- | apply = ap --- | ``` -ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b -ap f a = do - f' <- f - a' <- a - return (f' a') - --- | The `Semigroup` type class identifies an associative operation on a type. --- | --- | Instances are required to satisfy the following law: --- | --- | - Associativity: `(x <> y) <> z = x <> (y <> z)` --- | --- | One example of a `Semigroup` is `String`, with `(<>)` defined as string --- | concatenation. -class Semigroup a where - append :: a -> a -> a - -infixr 5 <> -infixr 5 ++ - --- | `(<>)` is an alias for `append`. -(<>) :: forall s. (Semigroup s) => s -> s -> s -(<>) = append - --- | `(++)` is an alternative alias for `append`. -(++) :: forall s. (Semigroup s) => s -> s -> s -(++) = append - -instance semigroupString :: Semigroup String where - append = concatString - -instance semigroupUnit :: Semigroup Unit where - append _ _ = unit - -instance semigroupFn :: (Semigroup s') => Semigroup (s -> s') where - append f g = \x -> f x <> g x - -instance semigroupOrdering :: Semigroup Ordering where - append LT _ = LT - append GT _ = GT - append EQ y = y - -instance semigroupArray :: Semigroup (Array a) where - append = concatArray - -foreign import concatString :: String -> String -> String -foreign import concatArray :: forall a. Array a -> Array a -> Array a - --- | The `Semiring` class is for types that support an addition and --- | multiplication operation. --- | --- | Instances must satisfy the following laws: --- | --- | - Commutative monoid under addition: --- | - Associativity: `(a + b) + c = a + (b + c)` --- | - Identity: `zero + a = a + zero = a` --- | - Commutative: `a + b = b + a` --- | - Monoid under multiplication: --- | - Associativity: `(a * b) * c = a * (b * c)` --- | - Identity: `one * a = a * one = a` --- | - Multiplication distributes over addition: --- | - Left distributivity: `a * (b + c) = (a * b) + (a * c)` --- | - Right distributivity: `(a + b) * c = (a * c) + (b * c)` --- | - Annihiliation: `zero * a = a * zero = zero` -class Semiring a where - add :: a -> a -> a - zero :: a - mul :: a -> a -> a - one :: a - -instance semiringInt :: Semiring Int where - add = intAdd - zero = 0 - mul = intMul - one = 1 - -instance semiringNumber :: Semiring Number where - add = numAdd - zero = 0.0 - mul = numMul - one = 1.0 - -instance semiringUnit :: Semiring Unit where - add _ _ = unit - zero = unit - mul _ _ = unit - one = unit - -infixl 6 + -infixl 7 * - --- | `(+)` is an alias for `add`. -(+) :: forall a. (Semiring a) => a -> a -> a -(+) = add - --- | `(*)` is an alias for `mul`. -(*) :: forall a. (Semiring a) => a -> a -> a -(*) = mul - -foreign import intAdd :: Int -> Int -> Int -foreign import intMul :: Int -> Int -> Int -foreign import numAdd :: Number -> Number -> Number -foreign import numMul :: Number -> Number -> Number - --- | The `Ring` class is for types that support addition, multiplication, --- | and subtraction operations. --- | --- | Instances must satisfy the following law in addition to the `Semiring` --- | laws: --- | --- | - Additive inverse: `a - a = (zero - a) + a = zero` -class (Semiring a) <= Ring a where - sub :: a -> a -> a - -instance ringInt :: Ring Int where - sub = intSub - -instance ringNumber :: Ring Number where - sub = numSub - -instance ringUnit :: Ring Unit where - sub _ _ = unit - -infixl 6 - - --- | `(-)` is an alias for `sub`. -(-) :: forall a. (Ring a) => a -> a -> a -(-) = sub - --- | `negate x` can be used as a shorthand for `zero - x`. -negate :: forall a. (Ring a) => a -> a -negate a = zero - a - -foreign import intSub :: Int -> Int -> Int -foreign import numSub :: Number -> Number -> Number - --- | The `ModuloSemiring` class is for types that support addition, --- | multiplication, division, and modulo (division remainder) operations. --- | --- | Instances must satisfy the following law in addition to the `Semiring` --- | laws: --- | --- | - Remainder: ``a / b * b + (a `mod` b) = a`` -class (Semiring a) <= ModuloSemiring a where - div :: a -> a -> a - mod :: a -> a -> a - -instance moduloSemiringInt :: ModuloSemiring Int where - div = intDiv - mod = intMod - -instance moduloSemiringNumber :: ModuloSemiring Number where - div = numDiv - mod _ _ = 0.0 - -instance moduloSemiringUnit :: ModuloSemiring Unit where - div _ _ = unit - mod _ _ = unit - -infixl 7 / - --- | `(/)` is an alias for `div`. -(/) :: forall a. (ModuloSemiring a) => a -> a -> a -(/) = div - -foreign import intDiv :: Int -> Int -> Int -foreign import numDiv :: Number -> Number -> Number -foreign import intMod :: Int -> Int -> Int - --- | A `Ring` where every nonzero element has a multiplicative inverse. --- | --- | Instances must satisfy the following law in addition to the `Ring` and --- | `ModuloSemiring` laws: --- | --- | - Multiplicative inverse: `(one / x) * x = one` --- | --- | As a consequence of this ```a `mod` b = zero``` as no divide operation --- | will have a remainder. -class (Ring a, ModuloSemiring a) <= DivisionRing a - -instance divisionRingNumber :: DivisionRing Number -instance divisionRingUnit :: DivisionRing Unit - --- | The `Num` class is for types that are commutative fields. --- | --- | Instances must satisfy the following law in addition to the --- | `DivisionRing` laws: --- | --- | - Commutative multiplication: `a * b = b * a` -class (DivisionRing a) <= Num a - -instance numNumber :: Num Number -instance numUnit :: Num Unit - --- | The `Eq` type class represents types which support decidable equality. --- | --- | `Eq` instances should satisfy the following laws: --- | --- | - Reflexivity: `x == x = true` --- | - Symmetry: `x == y = y == x` --- | - Transitivity: if `x == y` and `y == z` then `x == z` -class Eq a where - eq :: a -> a -> Boolean - -infix 4 == -infix 4 /= - --- | `(==)` is an alias for `eq`. Tests whether one value is equal to another. -(==) :: forall a. (Eq a) => a -> a -> Boolean -(==) = eq - --- | `(/=)` tests whether one value is _not equal_ to another. Shorthand for --- | `not (x == y)`. -(/=) :: forall a. (Eq a) => a -> a -> Boolean -(/=) x y = not (x == y) - -instance eqBoolean :: Eq Boolean where - eq = refEq - -instance eqInt :: Eq Int where - eq = refEq - -instance eqNumber :: Eq Number where - eq = refEq - -instance eqChar :: Eq Char where - eq = refEq - -instance eqString :: Eq String where - eq = refEq - -instance eqUnit :: Eq Unit where - eq _ _ = true - -instance eqArray :: (Eq a) => Eq (Array a) where - eq = eqArrayImpl (==) - -instance eqOrdering :: Eq Ordering where - eq LT LT = true - eq GT GT = true - eq EQ EQ = true - eq _ _ = false - -foreign import refEq :: forall a. a -> a -> Boolean -foreign import refIneq :: forall a. a -> a -> Boolean -foreign import eqArrayImpl :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Boolean - --- | The `Ordering` data type represents the three possible outcomes of --- | comparing two values: --- | --- | `LT` - The first value is _less than_ the second. --- | `GT` - The first value is _greater than_ the second. --- | `EQ` - The first value is _equal to_ the second. -data Ordering = LT | GT | EQ - --- | The `Ord` type class represents types which support comparisons with a --- | _total order_. --- | --- | `Ord` instances should satisfy the laws of total orderings: --- | --- | - Reflexivity: `a <= a` --- | - Antisymmetry: if `a <= b` and `b <= a` then `a = b` --- | - Transitivity: if `a <= b` and `b <= c` then `a <= c` -class (Eq a) <= Ord a where - compare :: a -> a -> Ordering - -instance ordBoolean :: Ord Boolean where - compare = unsafeCompare - -instance ordInt :: Ord Int where - compare = unsafeCompare - -instance ordNumber :: Ord Number where - compare = unsafeCompare - -instance ordString :: Ord String where - compare = unsafeCompare - -instance ordChar :: Ord Char where - compare = unsafeCompare - -instance ordUnit :: Ord Unit where - compare _ _ = EQ - -instance ordArray :: (Ord a) => Ord (Array a) where - compare xs ys = compare 0 $ ordArrayImpl (\x y -> case compare x y of - EQ -> 0 - LT -> 1 - GT -> -1) xs ys - -foreign import ordArrayImpl :: forall a. (a -> a -> Int) -> Array a -> Array a -> Int - -instance ordOrdering :: Ord Ordering where - compare LT LT = EQ - compare EQ EQ = EQ - compare GT GT = EQ - compare LT _ = LT - compare EQ LT = GT - compare EQ GT = LT - compare GT _ = GT - -infixl 4 < -infixl 4 > -infixl 4 <= -infixl 4 >= - --- | Test whether one value is _strictly less than_ another. -(<) :: forall a. (Ord a) => a -> a -> Boolean -(<) a1 a2 = case a1 `compare` a2 of - LT -> true - _ -> false - --- | Test whether one value is _strictly greater than_ another. -(>) :: forall a. (Ord a) => a -> a -> Boolean -(>) a1 a2 = case a1 `compare` a2 of - GT -> true - _ -> false - --- | Test whether one value is _non-strictly less than_ another. -(<=) :: forall a. (Ord a) => a -> a -> Boolean -(<=) a1 a2 = case a1 `compare` a2 of - GT -> false - _ -> true - --- | Test whether one value is _non-strictly greater than_ another. -(>=) :: forall a. (Ord a) => a -> a -> Boolean -(>=) a1 a2 = case a1 `compare` a2 of - LT -> false - _ -> true - -unsafeCompare :: forall a. a -> a -> Ordering -unsafeCompare = unsafeCompareImpl LT EQ GT - -foreign import unsafeCompareImpl :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering - --- | The `Bounded` type class represents types that are finite. --- | --- | Although there are no "internal" laws for `Bounded`, every value of `a` --- | should be considered less than or equal to `top` by some means, and greater --- | than or equal to `bottom`. --- | --- | The lack of explicit `Ord` constraint allows flexibility in the use of --- | `Bounded` so it can apply to total and partially ordered sets, boolean --- | algebras, etc. -class Bounded a where - top :: a - bottom :: a - -instance boundedBoolean :: Bounded Boolean where - top = true - bottom = false - -instance boundedUnit :: Bounded Unit where - top = unit - bottom = unit - -instance boundedOrdering :: Bounded Ordering where - top = GT - bottom = LT - -instance boundedInt :: Bounded Int where - top = topInt - bottom = bottomInt - --- | Characters fall within the Unicode range. -instance boundedChar :: Bounded Char where - top = topChar - bottom = bottomChar - -instance boundedFn :: (Bounded b) => Bounded (a -> b) where - top _ = top - bottom _ = bottom - -foreign import topInt :: Int -foreign import bottomInt :: Int - -foreign import topChar :: Char -foreign import bottomChar :: Char - --- | The `BoundedOrd` type class represents totally ordered finite data types. --- | --- | Instances should satisfy the following law in addition to the `Ord` laws: --- | --- | - Ordering: `bottom <= a <= top` -class (Bounded a, Ord a) <= BoundedOrd a - -instance boundedOrdBoolean :: BoundedOrd Boolean where -instance boundedOrdUnit :: BoundedOrd Unit where -instance boundedOrdOrdering :: BoundedOrd Ordering where -instance boundedOrdInt :: BoundedOrd Int where -instance boundedOrdChar :: BoundedOrd Char where - --- | The `BooleanAlgebra` type class represents types that behave like boolean --- | values. --- | --- | Instances should satisfy the following laws in addition to the `Bounded` --- | laws: --- | --- | - Associativity: --- | - `a || (b || c) = (a || b) || c` --- | - `a && (b && c) = (a && b) && c` --- | - Commutativity: --- | - `a || b = b || a` --- | - `a && b = b && a` --- | - Distributivity: --- | - `a && (b || c) = (a && b) || (a && c)` --- | - `a || (b && c) = (a || b) && (a || c)` --- | - Identity: --- | - `a || bottom = a` --- | - `a && top = a` --- | - Idempotent: --- | - `a || a = a` --- | - `a && a = a` --- | - Absorption: --- | - `a || (a && b) = a` --- | - `a && (a || b) = a` --- | - Annhiliation: --- | - `a || top = top` --- | - Complementation: --- | - `a && not a = bottom` --- | - `a || not a = top` -class (Bounded a) <= BooleanAlgebra a where - conj :: a -> a -> a - disj :: a -> a -> a - not :: a -> a - -instance booleanAlgebraBoolean :: BooleanAlgebra Boolean where - conj = boolAnd - disj = boolOr - not = boolNot - -instance booleanAlgebraUnit :: BooleanAlgebra Unit where - conj _ _ = unit - disj _ _ = unit - not _ = unit - -instance booleanAlgebraFn :: (BooleanAlgebra b) => BooleanAlgebra (a -> b) where - conj fx fy a = fx a `conj` fy a - disj fx fy a = fx a `disj` fy a - not fx a = not (fx a) - -infixr 3 && -infixr 2 || - --- | `(&&)` is an alias for `conj`. -(&&) :: forall a. (BooleanAlgebra a) => a -> a -> a -(&&) = conj - --- | `(||)` is an alias for `disj`. -(||) :: forall a. (BooleanAlgebra a) => a -> a -> a -(||) = disj - -foreign import boolOr :: Boolean -> Boolean -> Boolean -foreign import boolAnd :: Boolean -> Boolean -> Boolean -foreign import boolNot :: Boolean -> Boolean - --- | The `Show` type class represents those types which can be converted into --- | a human-readable `String` representation. --- | --- | While not required, it is recommended that for any expression `x`, the --- | string `show x` be executable PureScript code which evaluates to the same --- | value as the expression `x`. -class Show a where - show :: a -> String - -instance showBoolean :: Show Boolean where - show true = "true" - show false = "false" - -instance showInt :: Show Int where - show = showIntImpl - -instance showNumber :: Show Number where - show = showNumberImpl - -instance showChar :: Show Char where - show = showCharImpl - -instance showString :: Show String where - show = showStringImpl - -instance showUnit :: Show Unit where - show _ = "unit" - -instance showArray :: (Show a) => Show (Array a) where - show = showArrayImpl show - -instance showOrdering :: Show Ordering where - show LT = "LT" - show GT = "GT" - show EQ = "EQ" - -foreign import showIntImpl :: Int -> String -foreign import showNumberImpl :: Number -> String -foreign import showCharImpl :: Char -> String -foreign import showStringImpl :: String -> String -foreign import showArrayImpl :: forall a. (a -> String) -> Array a -> String diff --git a/tests/support/flattened/Test-Assert.js b/tests/support/flattened/Test-Assert.js deleted file mode 100644 index ad1a67ca49..0000000000 --- a/tests/support/flattened/Test-Assert.js +++ /dev/null @@ -1,27 +0,0 @@ -/* global exports */ -"use strict"; - -// module Test.Assert - -exports["assert'"] = function (message) { - return function (success) { - return function () { - if (!success) throw new Error(message); - return {}; - }; - }; -}; - -exports.checkThrows = function (fn) { - return function () { - try { - fn(); - return false; - } catch (e) { - if (e instanceof Error) return true; - var err = new Error("Threw something other than an Error"); - err.something = e; - throw err; - } - }; -}; diff --git a/tests/support/flattened/Test-Assert.purs b/tests/support/flattened/Test-Assert.purs deleted file mode 100644 index 66b8622158..0000000000 --- a/tests/support/flattened/Test-Assert.purs +++ /dev/null @@ -1,46 +0,0 @@ -module Test.Assert - ( assert' - , assert - , assertThrows - , assertThrows' - , ASSERT() - ) where - -import Control.Monad.Eff (Eff()) -import Prelude - --- | Assertion effect type. -foreign import data ASSERT :: ! - --- | Throws a runtime exception with message "Assertion failed" when the boolean --- | value is false. -assert :: forall e. Boolean -> Eff (assert :: ASSERT | e) Unit -assert = assert' "Assertion failed" - --- | Throws a runtime exception with the specified message when the boolean --- | value is false. -foreign import assert' :: forall e. String -> Boolean -> Eff (assert :: ASSERT | e) Unit - --- | Throws a runtime exception with message "Assertion failed: An error should --- | have been thrown", unless the argument throws an exception when evaluated. --- | --- | This function is specifically for testing unsafe pure code; for example, --- | to make sure that an exception is thrown if a precondition is not --- | satisfied. Functions which use `Eff (err :: EXCEPTION | eff) a` can be --- | tested with `catchException` instead. -assertThrows :: forall e a. (Unit -> a) -> Eff (assert :: ASSERT | e) Unit -assertThrows = assertThrows' "Assertion failed: An error should have been thrown" - --- | Throws a runtime exception with the specified message, unless the argument --- | throws an exception when evaluated. --- | --- | This function is specifically for testing unsafe pure code; for example, --- | to make sure that an exception is thrown if a precondition is not --- | satisfied. Functions which use `Eff (err :: EXCEPTION | eff) a` can be --- | tested with `catchException` instead. -assertThrows' :: forall e a. String -> (Unit -> a) -> Eff (assert :: ASSERT | e) Unit -assertThrows' msg fn = - checkThrows fn >>= assert' msg - - -foreign import checkThrows :: forall e a. (Unit -> a) -> Eff (assert :: ASSERT | e) Boolean diff --git a/tests/support/package.json b/tests/support/package.json index fa082030a6..18aa9a7449 100644 --- a/tests/support/package.json +++ b/tests/support/package.json @@ -2,6 +2,7 @@ "private": true, "dependencies": { "bower": "^1.4.1", - "glob": "^5.0.14" + "glob": "^5.0.14", + "rimraf": "^2.5.2" } } diff --git a/tests/support/prelude b/tests/support/prelude deleted file mode 160000 index 5b8da18fd7..0000000000 --- a/tests/support/prelude +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 5b8da18fd7b8d57a85df49ec64099a81b13f42f7 diff --git a/tests/support/setup.js b/tests/support/setup.js deleted file mode 100644 index 46b87b50f1..0000000000 --- a/tests/support/setup.js +++ /dev/null @@ -1,22 +0,0 @@ -var glob = require("glob"); -var fs = require("fs"); - -try { - fs.mkdirSync("./flattened"); -} catch(e) { - // ignore the error if it already exists - if (e.code !== "EEXIST") { - throw(e); - } -} - -glob("bower_components/*/src/**/*.{js,purs}", function(err, files) { - if (err) throw err; - files.forEach(function(file) { - // We join with "-" because Cabal is weird about file extensions. - var dest = "./flattened/" + file.split("/").slice(3).join("-"); - console.log("Copying " + file + " to " + dest); - var content = fs.readFileSync(file, "utf-8"); - fs.writeFileSync(dest, content, "utf-8"); - }); -}) From 5a349845e148fc03d27c372e990b40b0eb0c4bc3 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 1 May 2016 23:05:15 +0100 Subject: [PATCH 0393/1580] Type suggestions (#2076) * Expose missing type declaration suggestion * Tighten span for type wildcard warnings --- src/Language/PureScript/Docs/Convert.hs | 7 ++++--- .../PureScript/Docs/Convert/Single.hs | 2 +- .../PureScript/Docs/RenderedCode/Render.hs | 2 +- src/Language/PureScript/Errors.hs | 14 +++++++++++++ src/Language/PureScript/Errors/JSON.hs | 20 +++++++++++++------ src/Language/PureScript/Parser/Common.hs | 8 ++++++++ .../PureScript/Parser/Declarations.hs | 11 ++++------ src/Language/PureScript/Parser/Types.hs | 8 +++++++- src/Language/PureScript/Pretty/Types.hs | 2 +- src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- src/Language/PureScript/TypeChecker/Unify.hs | 4 ++-- src/Language/PureScript/Types.hs | 4 ++-- tests/Language/PureScript/Ide/FilterSpec.hs | 2 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 7 +++++-- tests/Language/PureScript/Ide/MatcherSpec.hs | 2 +- .../Language/PureScript/Ide/ReexportsSpec.hs | 9 ++++++--- 16 files changed, 72 insertions(+), 32 deletions(-) diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 0358a70d9d..76f604d335 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -107,8 +107,9 @@ typeCheckIfNecessary modules convertedModules = else pure convertedModules where - hasWildcards = - any ((==) (ValueDeclaration P.TypeWildcard) . declInfo) . modDeclarations + hasWildcards = any (isWild . declInfo) . modDeclarations + isWild (ValueDeclaration P.TypeWildcard{}) = True + isWild _ = False go = do checkEnv <- snd <$> typeCheck modules @@ -147,7 +148,7 @@ insertValueTypes :: insertValueTypes env m = m { modDeclarations = map go (modDeclarations m) } where - go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard }) = + go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard{} }) = let ident = parseIdent (declTitle d) ty = lookupName ident diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 7e60bfdff3..8a09842d6d 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -140,7 +140,7 @@ convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) titl convertDeclaration (P.ValueDeclaration {}) title = -- If no explicit type declaration was provided, insert a wildcard, so that -- the actual type will be added during type checking. - basicDeclaration title (ValueDeclaration P.TypeWildcard) + basicDeclaration title (ValueDeclaration P.TypeWildcard{}) convertDeclaration (P.ExternDeclaration _ ty) title = basicDeclaration title (ValueDeclaration ty) convertDeclaration (P.DataDeclaration dtype _ args ctors) title = diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index ec23588f08..48d1ad81bc 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -32,7 +32,7 @@ import Language.PureScript.Docs.Utils.MonoidExtras typeLiterals :: Pattern () Type RenderedCode typeLiterals = mkPattern match where - match TypeWildcard = + match TypeWildcard{} = Just (syntax "_") match (TypeVar var) = Just (ident var) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index c37dec9da3..37903ca57d 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} module Language.PureScript.Errors where @@ -462,6 +463,8 @@ errorSuggestion err = case err of ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing + MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintType ty + WildcardInferredType ty -> suggest $ prettyPrintType ty _ -> Nothing where @@ -476,6 +479,17 @@ errorSuggestion err = case err of qstr (Just mn) = " as " ++ runModuleName mn qstr Nothing = "" +suggestionSpan :: ErrorMessage -> Maybe SourceSpan +suggestionSpan e = + getSpan (unwrapErrorMessage e) <$> errorSpan e + where + startOnly SourceSpan{spanName, spanStart} = SourceSpan {spanName, spanStart, spanEnd = spanStart} + + getSpan simple ss = + case simple of + MissingTypeDeclaration{} -> startOnly ss + _ -> ss + showSuggestion :: SimpleErrorMessage -> String showSuggestion suggestion = case errorSuggestion suggestion of Just (ErrorSuggestion x) -> x diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index a36f8e2603..8bfcd3940b 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -30,7 +30,10 @@ data ErrorPosition = ErrorPosition , endColumn :: Int } deriving (Show, Eq, Ord) -data ErrorSuggestion = ErrorSuggestion { replacement :: String } deriving (Show, Eq) +data ErrorSuggestion = ErrorSuggestion + { replacement :: String + , replaceRange :: Maybe ErrorPosition + } deriving (Show, Eq) data JSONError = JSONError { position :: Maybe ErrorPosition @@ -40,7 +43,7 @@ data JSONError = JSONError , filename :: Maybe String , moduleName :: Maybe String , suggestion :: Maybe ErrorSuggestion - } deriving (Show, Eq) + } deriving (Show, Eq) data JSONResult = JSONResult { warnings :: [JSONError] @@ -64,7 +67,7 @@ toJSONError verbose level e = (P.wikiUri e) (P.spanName <$> sspan) (P.runModuleName <$> P.errorModule e) - (toSuggestion <$> P.errorSuggestion (P.unwrapErrorMessage e)) + (toSuggestion e) where sspan :: Maybe P.SourceSpan sspan = P.errorSpan e @@ -75,6 +78,11 @@ toJSONError verbose level e = (P.sourcePosColumn (P.spanStart ss)) (P.sourcePosLine (P.spanEnd ss)) (P.sourcePosColumn (P.spanEnd ss)) - toSuggestion :: P.ErrorSuggestion -> ErrorSuggestion --- TODO: Adding a newline because source spans chomp everything up to the next character - toSuggestion (P.ErrorSuggestion s) = ErrorSuggestion $ if null s then s else s ++ "\n" + toSuggestion :: P.ErrorMessage -> Maybe ErrorSuggestion + toSuggestion em = + case P.errorSuggestion $ P.unwrapErrorMessage em of + Nothing -> Nothing + Just s -> Just $ ErrorSuggestion (suggestionText s) (toErrorPosition <$> P.suggestionSpan em) + + -- TODO: Adding a newline because source spans chomp everything up to the next character + suggestionText (P.ErrorSuggestion s) = if null s then s else s ++ "\n" diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index 1088834ae1..4a87070748 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -13,6 +13,8 @@ import Language.PureScript.Parser.Lexer import Language.PureScript.Parser.State import Language.PureScript.Names +import Language.PureScript.AST.SourcePos + import qualified Text.Parsec as P properName :: TokenParser (ProperName a) @@ -120,3 +122,9 @@ readComments = P.lookAhead $ ptComments <$> P.anyToken -- runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a runTokenParser filePath p = P.runParser p (ParseState 0) filePath + +-- | +-- Convert from Parsec sourcepos +-- +toSourcePos :: P.SourcePos -> SourcePos +toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 7799f59ec3..1a07b2bab0 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -52,7 +52,7 @@ withSourceSpan f p = do comments <- C.readComments x <- p end <- P.getPosition - let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end) + let sp = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos end) return $ f sp comments x kindedIdent :: TokenParser (String, Maybe Kind) @@ -248,7 +248,7 @@ parseModule = do reserved "where" decls <- mark (P.many (same *> parseDeclaration)) end <- P.getPosition - let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end) + let ss = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos end) return $ Module ss comments name decls exports -- | Parse a collection of modules in parallel @@ -275,13 +275,10 @@ parseModulesFromFiles toFilePath input = do toPositionedError :: P.ParseError -> ErrorMessage toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr) where - name = (P.sourceName . P.errorPos) perr - start = (toSourcePos . P.errorPos) perr + name = (P.sourceName . P.errorPos) perr + start = (C.toSourcePos . P.errorPos) perr end = start -toSourcePos :: P.SourcePos -> SourcePos -toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos) - -- | -- Parse a collection of modules -- diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 7d8905503c..8657f1e1cd 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -15,6 +15,8 @@ import Language.PureScript.Parser.Kinds import Language.PureScript.Parser.Lexer import Language.PureScript.Environment +import Language.PureScript.AST.SourcePos + import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P @@ -25,7 +27,11 @@ parseObject :: TokenParser Type parseObject = braces $ TypeApp tyObject <$> parseRow parseTypeWildcard :: TokenParser Type -parseTypeWildcard = underscore >> return TypeWildcard +parseTypeWildcard = do + start <- P.getPosition + let end = P.incSourceColumn start 1 + underscore + return $ TypeWildcard (SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)) parseTypeVariable :: TokenParser Type parseTypeVariable = do diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 093723f718..cf858ede73 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -28,7 +28,7 @@ import Text.PrettyPrint.Boxes hiding ((<+>)) typeLiterals :: Pattern () Type Box typeLiterals = mkPattern match where - match TypeWildcard = Just $ text "_" + match TypeWildcard{} = Just $ text "_" match (TypeVar var) = Just $ text var match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 59ffa8b330..da5260bd84 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -235,7 +235,7 @@ infer' other = (, []) <$> go other k' <- go ty unifyKinds k k' return k' - go TypeWildcard = freshKind + go TypeWildcard{} = freshKind go (TypeVar v) = do Just moduleName <- checkCurrentModule <$> get lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index c8ed0d7cb6..1fc584da9b 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -209,9 +209,9 @@ replaceVarWithUnknown ident ty = do replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState CheckState m) => Type -> m Type replaceTypeWildcards = everywhereOnTypesM replace where - replace TypeWildcard = do + replace (TypeWildcard ss) = do t <- freshType - tell . errorMessage $ WildcardInferredType t + warnWithPosition ss $ tell . errorMessage $ WildcardInferredType t return t replace other = return other diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 308b6b5cd0..0f71c2ff99 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -43,7 +43,7 @@ data Type -- | -- A type wildcard, as would appear in a partial type synonym -- - | TypeWildcard + | TypeWildcard (SourceSpan) -- | -- A type constructor -- @@ -237,7 +237,7 @@ containsWildcards :: Type -> Bool containsWildcards = everythingOnTypes (||) go where go :: Type -> Bool - go TypeWildcard = True + go TypeWildcard{} = True go _ = False -- diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index 700e30ea61..6415ec0824 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -8,7 +8,7 @@ import qualified Language.PureScript as P import Test.Hspec value :: Text -> ExternDecl -value s = ValueDeclaration s P.TypeWildcard +value s = ValueDeclaration s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) modules :: [Module] modules = diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 36cbe25dfe..88825aa0bc 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -36,6 +36,9 @@ listImport = testParseImport "import Data.List as List" consoleImport = testParseImport "import Control.Monad.Eff.Console (log) as Console" maybeImport = testParseImport "import Data.Maybe (Maybe(Just))" +wildcard :: P.Type +wildcard = P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) + spec :: Spec spec = do describe "determining the importsection" $ do @@ -65,9 +68,9 @@ spec = do describe "import commands" $ do let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i addValueImport i mn is = - prettyPrintImportSection (addExplicitImport' (ValueDeclaration i P.TypeWildcard) mn is) + prettyPrintImportSection (addExplicitImport' (ValueDeclaration i wildcard) mn is) addDtorImport i t mn is = - prettyPrintImportSection (addExplicitImport' (DataConstructor i t P.TypeWildcard) mn is) + prettyPrintImportSection (addExplicitImport' (DataConstructor i t wildcard) mn is) it "adds an implicit unqualified import" $ shouldBe (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map")) diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs index 13cef33b2a..1f579bed86 100644 --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -10,7 +10,7 @@ import qualified Language.PureScript as P import Test.Hspec value :: Text -> ExternDecl -value s = ValueDeclaration s P.TypeWildcard +value s = ValueDeclaration s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) completions :: [Match] completions = [ diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index 42d28f0e93..5633d6051e 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -9,12 +9,15 @@ import Language.PureScript.Ide.Types import qualified Language.PureScript as P import Test.Hspec +wildcard :: P.Type +wildcard = P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) + decl1 :: ExternDecl -decl1 = ValueDeclaration "filter" P.TypeWildcard +decl1 = ValueDeclaration "filter" wildcard decl2 :: ExternDecl -decl2 = ValueDeclaration "map" P.TypeWildcard +decl2 = ValueDeclaration "map" wildcard decl3 :: ExternDecl -decl3 = ValueDeclaration "catMaybe" P.TypeWildcard +decl3 = ValueDeclaration "catMaybe" wildcard dep1 :: ExternDecl dep1 = Dependency "Test.Foo" [] (Just "T") dep2 :: ExternDecl From d9cdd8f7038c5d4e7a66eeccc29928cdf42db58b Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sun, 1 May 2016 11:53:23 +0100 Subject: [PATCH 0394/1580] 0.9 Remove deprecated class import/export syntax --- .../docs/src/TypeClassWithoutMembers.purs | 2 +- .../failing/MissingClassMemberExport.purs | 2 +- examples/passing/ImportHiding.purs | 2 +- psci/PSCi.hs | 1 - src/Language/PureScript/AST/Declarations.hs | 5 --- src/Language/PureScript/AST/Exported.hs | 3 -- src/Language/PureScript/Errors.hs | 22 ----------- src/Language/PureScript/Ide/Imports.hs | 9 +---- .../PureScript/Parser/Declarations.hs | 6 +-- src/Language/PureScript/Sugar/Names.hs | 39 +------------------ .../PureScript/Sugar/Names/Imports.hs | 28 +------------ 11 files changed, 11 insertions(+), 108 deletions(-) diff --git a/examples/docs/src/TypeClassWithoutMembers.purs b/examples/docs/src/TypeClassWithoutMembers.purs index fb926cfa6f..d27e022802 100644 --- a/examples/docs/src/TypeClassWithoutMembers.purs +++ b/examples/docs/src/TypeClassWithoutMembers.purs @@ -8,4 +8,4 @@ module Intermediate ( module SomeTypeClass ) where -import SomeTypeClass (SomeClass) +import SomeTypeClass (class SomeClass) diff --git a/examples/failing/MissingClassMemberExport.purs b/examples/failing/MissingClassMemberExport.purs index cb6dec854e..11ae9b8877 100644 --- a/examples/failing/MissingClassMemberExport.purs +++ b/examples/failing/MissingClassMemberExport.purs @@ -1,5 +1,5 @@ -- @shouldFailWith TransitiveExportError -module Test (Foo) where +module Test (class Foo) where import Prelude diff --git a/examples/passing/ImportHiding.purs b/examples/passing/ImportHiding.purs index 8cc0cf8d6e..082b3ac429 100644 --- a/examples/passing/ImportHiding.purs +++ b/examples/passing/ImportHiding.purs @@ -3,7 +3,7 @@ module Main where import Control.Monad.Eff.Console import Prelude hiding ( show, -- a value - Show, -- a type class + class Show, -- a type class Unit(..) -- a constructor ) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index fc9f695ce0..679bbbb06f 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -256,7 +256,6 @@ handleShowImportedModules = do showRef (P.TypeOpRef ident) = "type (" ++ N.runIdent ident ++ ")" showRef (P.ValueRef ident) = N.runIdent ident showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn - showRef (P.ProperRef pn) = pn showRef (P.TypeInstanceRef ident) = N.runIdent ident showRef (P.ModuleRef name) = "module " ++ N.runModuleName name showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index d36aa81c97..10c7fa2971 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -82,10 +82,6 @@ data DeclarationRef -- | ModuleRef ModuleName -- | - -- An unspecified ProperName ref. This will be replaced with a TypeClassRef - -- or TypeRef during name desugaring. - | ProperRef String - -- | -- A declaration reference with source position information -- | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef @@ -98,7 +94,6 @@ instance Eq DeclarationRef where (TypeClassRef name) == (TypeClassRef name') = name == name' (TypeInstanceRef name) == (TypeInstanceRef name') = name == name' (ModuleRef name) == (ModuleRef name') = name == name' - (ProperRef name) == (ProperRef name') = name == name' (PositionedDeclarationRef _ _ r) == r' = r == r' r == (PositionedDeclarationRef _ _ r') = r == r' _ == _ = False diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index dce1de96e4..edb0ec3708 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -132,9 +132,6 @@ isExported (Just exps) decl = any (matches decl) exps matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident' matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident' - matches (DataDeclaration _ ident _ _) (ProperRef ident') = runProperName ident == ident' - matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = runProperName ident == ident' - matches (FixityDeclaration _ name (Just (Qualified _ (AliasValue _)))) (ValueRef ident') = name == runIdent ident' matches (FixityDeclaration _ name (Just (Qualified _ (AliasConstructor _)))) (ValueRef ident') = name == runIdent ident' matches (FixityDeclaration _ name (Just (Qualified _ (AliasType _)))) (TypeOpRef ident') = name == runIdent ident' diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 37903ca57d..521a0f3793 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -141,8 +141,6 @@ data SimpleErrorMessage | UnusedDctorImport (ProperName 'TypeName) | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName] | DeprecatedOperatorDecl String - | DeprecatedClassImport ModuleName (ProperName 'ClassName) - | DeprecatedClassExport (ProperName 'ClassName) | DuplicateSelectiveImport ModuleName | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) | DuplicateImportRef String @@ -328,8 +326,6 @@ errorCode em = case unwrapErrorMessage em of UnusedDctorImport{} -> "UnusedDctorImport" UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport" DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl" - DeprecatedClassImport{} -> "DeprecatedClassImport" - DeprecatedClassExport{} -> "DeprecatedClassExport" DuplicateSelectiveImport{} -> "DuplicateSelectiveImport" DuplicateImport{} -> "DuplicateImport" DuplicateImportRef{} -> "DuplicateImportRef" @@ -453,7 +449,6 @@ wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ error -- TODO Other possible suggestions: -- WildcardInferredType - source span not small enough -- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert --- DeprecatedClassExport, DeprecatedClassImport, would want to replace smaller span? errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion errorSuggestion err = case err of UnusedImport{} -> emptySuggestion @@ -934,22 +929,6 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , line "Support for value-declared operators will be removed in PureScript 0.9." ] - renderSimpleErrorMessage (DeprecatedClassImport mn name) = - paras [ line $ "Class import from " ++ runModuleName mn ++ " uses deprecated syntax that omits the 'class' keyword:" - , indent $ line $ runProperName name - , line "Should instead use the form:" - , indent $ line $ "class " ++ runProperName name - , line "The deprecated syntax will be removed in PureScript 0.9." - ] - - renderSimpleErrorMessage (DeprecatedClassExport name) = - paras [ line "Class export uses deprecated syntax that omits the 'class' keyword:" - , indent $ line $ runProperName name - , line "Should instead use the form:" - , indent $ line $ "class " ++ runProperName name - , line "The deprecated syntax will be removed in PureScript 0.9." - ] - renderSimpleErrorMessage (DuplicateSelectiveImport name) = line $ "There is an existing import of " ++ runModuleName name ++ ", consider merging the import lists" @@ -1208,7 +1187,6 @@ prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercala prettyPrintRef (TypeOpRef ident) = "type " ++ showIdent ident prettyPrintRef (ValueRef ident) = showIdent ident prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn -prettyPrintRef (ProperRef name) = name prettyPrintRef (TypeInstanceRef ident) = showIdent ident prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 000e8056b0..817b0d4907 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -233,10 +233,8 @@ addExplicitImport' decl moduleName imports = insertDeclIntoRefs (DataConstructor dtor tn _) refs = let dtor' = P.ProperName (T.unpack dtor) - -- TODO: Get rid of this once typeclasses can't be imported like types - refs' = properRefToTypeRef <$> refs in - updateAtFirstOrPrepend (matchType tn) (insertDtor dtor') (P.TypeRef tn (Just [dtor'])) refs' + updateAtFirstOrPrepend (matchType tn) (insertDtor dtor') (P.TypeRef tn (Just [dtor'])) refs insertDeclIntoRefs dr refs = List.nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) insertDtor dtor (P.TypeRef tn' dtors) = @@ -247,11 +245,6 @@ addExplicitImport' decl moduleName imports = Nothing -> P.TypeRef tn' Nothing insertDtor _ refs = refs - - -- TODO: Get rid of this once typeclasses can't be imported like types - properRefToTypeRef (P.ProperRef n) = P.TypeRef (P.ProperName n) (Just []) - properRefToTypeRef r = r - matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool matchType tn (P.TypeRef n _) = tn == n matchType _ _ = False diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index a3207dafc4..f3aec701ab 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -154,15 +154,15 @@ parseDeclarationRef :: TokenParser DeclarationRef parseDeclarationRef = withSourceSpan PositionedDeclarationRef $ (ValueRef <$> parseIdent) - <|> parseProperRef + <|> parseTypeRef <|> (TypeClassRef <$> (reserved "class" *> properName)) <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName)) <|> (TypeOpRef <$> (indented *> reserved "type" *> parens (Op <$> symbol))) where - parseProperRef = do + parseTypeRef = do name <- properName dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName) - return $ maybe (ProperRef (runProperName name)) (TypeRef name) dctors + return $ TypeRef name (fromMaybe (Just []) dctors) parseTypeClassDeclaration :: TokenParser Declaration parseTypeClassDeclaration = do diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index b7997ecd2b..498c16298c 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -56,9 +56,8 @@ desugarImportsWithEnv -> m (Env, [Module]) desugarImportsWithEnv externs modules = do env <- silence $ foldM externsEnv primEnv externs - modules' <- traverse updateExportRefs modules - (modules'', env') <- first reverse <$> foldM updateEnv ([], env) modules' - (env',) <$> traverse (renameInModule' env') modules'' + (modules', env') <- first reverse <$> foldM updateEnv ([], env) modules + (env',) <$> traverse (renameInModule' env') modules' where silence :: m a -> m a silence = censor (const mempty) @@ -377,37 +376,3 @@ renameInModule env imports (Module ss coms mn decls exps) = Nothing -> err Just pos' -> rethrowWithPosition pos' err throwUnknown = throwError . errorMessage $ unknown qname - --- | --- Replaces `ProperRef` export values with a `TypeRef` or `TypeClassRef` --- depending on what is availble within the module. Warns when a `ProperRef` --- desugars into a `TypeClassRef`. --- -updateExportRefs - :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => Module - -> m Module -updateExportRefs (Module ss coms mn decls exps) = - Module ss coms mn decls <$> traverse (traverse updateRef) exps - where - - updateRef :: DeclarationRef -> m DeclarationRef - updateRef (ProperRef name) - | ProperName name `elem` classNames = do - tell . errorMessage . DeprecatedClassExport $ ProperName name - return . TypeClassRef $ ProperName name - -- Fall through case here - assume it's a type if it's not a class. - -- If it's a reference to something that doesn't actually exist it will - -- be picked up elsewhere - | otherwise = return $ TypeRef (ProperName name) (Just []) - updateRef (PositionedDeclarationRef pos com ref) = - warnWithPosition pos $ PositionedDeclarationRef pos com <$> updateRef ref - updateRef other = return other - - classNames :: [ProperName 'ClassName] - classNames = mapMaybe go decls - where - go (PositionedDeclaration _ _ d) = go d - go (TypeClassDeclaration name _ _ _) = Just name - go _ = Nothing diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index ff54bbb781..c46c01c7f8 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -63,8 +63,7 @@ resolveImports resolveImports env (Module ss coms currentModule decls exps) = warnAndRethrow (addHint (ErrorInModule currentModule)) $ do - decls' <- traverse updateImportRef decls - imports <- findImports decls' + imports <- findImports decls for_ (M.toList imports) $ \(mn, imps) -> do @@ -97,7 +96,7 @@ resolveImports env (Module ss coms currentModule decls exps) = scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports' resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope) - return (Module ss coms currentModule decls' exps, resolved) + return (Module ss coms currentModule decls exps, resolved) where defQual :: ImportDef -> Maybe ModuleName @@ -133,29 +132,6 @@ resolveImports env (Module ss coms currentModule decls exps) = warn :: Maybe SourceSpan -> SimpleErrorMessage -> m () warn pos msg = maybe id warnWithPosition pos $ tell . errorMessage $ msg - updateImportRef :: Declaration -> m Declaration - updateImportRef (PositionedDeclaration pos com d) = - warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> updateImportRef d - updateImportRef (ImportDeclaration mn typ qual) = do - modExports <- getExports env mn - typ' <- case typ of - Implicit -> return Implicit - Explicit refs -> Explicit <$> updateProperRef mn modExports `traverse` refs - Hiding refs -> Hiding <$> updateProperRef mn modExports `traverse` refs - return $ ImportDeclaration mn typ' qual - updateImportRef other = return other - - updateProperRef :: ModuleName -> Exports -> DeclarationRef -> m DeclarationRef - updateProperRef importModule modExports (ProperRef name) = - if ProperName name `elem` (fst `map` exportedTypeClasses modExports) - then do - tell . errorMessage $ DeprecatedClassImport importModule (ProperName name) - return . TypeClassRef $ ProperName name - else return $ TypeRef (ProperName name) (Just []) - updateProperRef importModule modExports (PositionedDeclarationRef pos com ref) = - PositionedDeclarationRef pos com <$> updateProperRef importModule modExports ref - updateProperRef _ _ other = return other - -- | Constructs a set of imports for a single module import. resolveModuleImport :: forall m From 0100861ffe7cb2896807634b9113afe59292bce1 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 24 Apr 2016 12:21:35 +0100 Subject: [PATCH 0395/1580] Tighten source-spans to token end position (Other than string/number literals) --- .../PureScript/Parser/Declarations.hs | 7 ++++++- src/Language/PureScript/Parser/Lexer.hs | 21 +++++++++++++++---- src/Language/PureScript/Parser/State.hs | 2 -- 3 files changed, 23 insertions(+), 7 deletions(-) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index a3207dafc4..c0447711ce 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -52,7 +52,11 @@ withSourceSpan f p = do comments <- C.readComments x <- p end <- P.getPosition - let sp = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos end) + input <- P.getInput + let end' = case input of + pt:_ -> ptPrevEndPos pt + _ -> Nothing + let sp = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos $ fromMaybe end end') return $ f sp comments x kindedIdent :: TokenParser (String, Maybe Kind) @@ -273,6 +277,7 @@ parseModulesFromFiles toFilePath input = do inParallel :: [Either P.ParseError (k, [Module])] -> [Either P.ParseError (k, [Module])] inParallel = withStrategy (parList rseq) + toPositionedError :: P.ParseError -> ErrorMessage toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr) where diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index e7f14b329b..63d8bf5b31 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -152,7 +152,12 @@ prettyPrintToken (Number n) = either show show n prettyPrintToken (HoleLit name) = "?" ++ name data PositionedToken = PositionedToken - { ptSourcePos :: P.SourcePos + { -- | Start position of this token + ptSourcePos :: P.SourcePos + -- | End position of this token (not including whitespace) + , ptEndPos :: P.SourcePos + -- | End position of the previous token + , ptPrevEndPos :: Maybe P.SourcePos , ptToken :: Token , ptComments :: [Comment] } deriving (Eq) @@ -162,7 +167,13 @@ instance Show PositionedToken where show = prettyPrintToken . ptToken lex :: FilePath -> String -> Either P.ParseError [PositionedToken] -lex = P.parse parseTokens +lex f s = updatePositions <$> P.parse parseTokens f s + +updatePositions :: [PositionedToken] -> [PositionedToken] +updatePositions [] = [] +updatePositions (x:xs) = x : zipWith update (x:xs) xs + where + update PositionedToken { ptEndPos = pos } pt = pt { ptPrevEndPos = Just pos } parseTokens :: P.Parsec String u [PositionedToken] parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof @@ -184,7 +195,9 @@ parsePositionedToken = P.try $ do comments <- P.many parseComment pos <- P.getPosition tok <- parseToken - return $ PositionedToken pos tok comments + pos' <- P.getPosition + whitespace + return $ PositionedToken pos pos' Nothing tok comments parseToken :: P.Parsec String u Token parseToken = P.choice @@ -221,7 +234,7 @@ parseToken = P.choice , CharLiteral <$> parseCharLiteral , StringLiteral <$> parseStringLiteral , Number <$> parseNumber - ] <* whitespace + ] where parseLName :: P.Parsec String u String diff --git a/src/Language/PureScript/Parser/State.hs b/src/Language/PureScript/Parser/State.hs index f66516cb56..3bda23b9d3 100644 --- a/src/Language/PureScript/Parser/State.hs +++ b/src/Language/PureScript/Parser/State.hs @@ -26,5 +26,3 @@ data ParseState = ParseState { -- indentationLevel :: P.Column } deriving Show - - From 06e433255990ccb193e36113f8559b141f82f247 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 1 May 2016 23:00:26 +0100 Subject: [PATCH 0396/1580] Update the support modules list in the tests Also add comment explaining what the list actually does --- tests/TestCompiler.hs | 12 ------------ tests/TestPsci.hs | 39 ++------------------------------------- tests/TestUtils.hs | 41 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 43 insertions(+), 49 deletions(-) diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index f795036d27..4c21c661c8 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -180,15 +180,3 @@ assertDoesNotCompile inputFiles foreigns = do trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse - -supportModules :: [String] -supportModules = - [ "Control.Monad.Eff.Class" - , "Control.Monad.Eff.Console" - , "Control.Monad.Eff" - , "Control.Monad.Eff.Unsafe" - , "Control.Monad.ST" - , "Data.Function" - , "Prelude" - , "Test.Assert" - ] diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index 967c1b2a4d..eeafb9b1e6 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -28,6 +28,8 @@ import PSCi.Module (loadAllModules) import PSCi.Completion import PSCi.Types +import TestUtils (supportModules) + main :: IO () main = do Counts{..} <- runTestTT allTests @@ -144,40 +146,3 @@ controlMonadSTasST :: ImportedModule controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST")) where s = P.moduleNameFromString - -supportModules :: [String] -supportModules = - [ "Control.Applicative" - , "Control.Apply" - , "Control.Bind" - , "Control.Category" - , "Control.Monad" - , "Control.Monad.Eff" - , "Control.Monad.Eff.Class" - , "Control.Monad.Eff.Console" - , "Control.Monad.Eff.Unsafe" - , "Control.Monad.ST" - , "Control.Semigroupoid" - , "Data.Boolean" - , "Data.BooleanAlgebra" - , "Data.Bounded" - , "Data.CommutativeRing" - , "Data.Eq" - , "Data.EuclideanRing" - , "Data.Field" - , "Data.Function" - , "Data.Function.Uncurried" - , "Data.Functor" - , "Data.HeytingAlgebra" - , "Data.Ord" - , "Data.Ord.Unsafe" - , "Data.Ordering" - , "Data.Ring" - , "Data.Semigroup" - , "Data.Semiring" - , "Data.Show" - , "Data.Unit" - , "Data.Void" - , "Prelude" - , "Test.Assert" - ] diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 640f9f3c08..ce46a90d74 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -38,6 +38,47 @@ updateSupportCode = do callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"] setCurrentDirectory "../.." +-- | +-- The support modules that should be cached between test cases, to avoid +-- excessive rebuilding. +-- +supportModules :: [String] +supportModules = + [ "Control.Applicative" + , "Control.Apply" + , "Control.Bind" + , "Control.Category" + , "Control.Monad.Eff.Class" + , "Control.Monad.Eff.Console" + , "Control.Monad.Eff.Unsafe" + , "Control.Monad.Eff" + , "Control.Monad.ST" + , "Control.Monad" + , "Control.Semigroupoid" + , "Data.Boolean" + , "Data.BooleanAlgebra" + , "Data.Bounded" + , "Data.CommutativeRing" + , "Data.Eq" + , "Data.EuclideanRing" + , "Data.Field" + , "Data.Function.Uncurried" + , "Data.Function" + , "Data.Functor" + , "Data.HeytingAlgebra" + , "Data.Ord.Unsafe" + , "Data.Ord" + , "Data.Ordering" + , "Data.Ring" + , "Data.Semigroup" + , "Data.Semiring" + , "Data.Show" + , "Data.Unit" + , "Data.Void" + , "Prelude" + , "Test.Assert" + ] + pushd :: forall a. FilePath -> IO a -> IO a pushd dir act = do original <- getCurrentDirectory From 55a010986f7c4922b503c0cfb1515bf30cd38167 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 2 May 2016 14:56:51 +0100 Subject: [PATCH 0397/1580] Use HSpec for the compiler tests --- purescript.cabal | 2 +- tests/TestCompiler.hs | 119 ++++++++++++++++++++++-------------------- 2 files changed, 62 insertions(+), 59 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 8911764eb4..e53c87b1a9 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -351,7 +351,7 @@ test-suite tests Glob -any, aeson-better-errors -any, bytestring -any, aeson -any, base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any, boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any, - vector -any, utf8-string -any + vector -any, utf8-string -any, silently -any ghc-options: -Wall type: exitcode-stdio-1.0 main-is: Main.hs diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 4c21c661c8..fd56c6c53e 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -26,8 +26,8 @@ import Prelude.Compat import qualified Language.PureScript as P import Data.Char (isSpace) -import Data.Maybe (mapMaybe, fromMaybe) -import Data.List (isSuffixOf, sort, stripPrefix) +import Data.Maybe (mapMaybe) +import Data.List (isSuffixOf, sort, stripPrefix, intercalate) import Data.Time.Clock (UTCTime()) import qualified Data.Map as M @@ -44,42 +44,55 @@ import System.Process hiding (cwd) import System.FilePath import System.Directory import System.IO.UTF8 +import System.IO.Silently import qualified System.FilePath.Glob as Glob import TestUtils +import Test.Hspec main :: IO () -main = do - cwd <- getCurrentDirectory +main = hspec spec - let supportDir = cwd "tests" "support" "bower_components" - let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir +spec :: Spec +spec = do + (supportPurs, foreigns, passing, passingTestCases, failing, failingTestCases) <- runIO $ do + cwd <- getCurrentDirectory - supportPurs <- supportFiles "purs" - supportJS <- supportFiles "js" + let supportDir = cwd "tests" "support" "bower_components" + let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir - foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f) - Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles + supportPurs <- supportFiles "purs" + supportJS <- supportFiles "js" - let passing = cwd "examples" "passing" - passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing - let failing = cwd "examples" "failing" - failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing + foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f) + Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles - failures <- execWriterT $ do + let passing = cwd "examples" "passing" + passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing + + let failing = cwd "examples" "failing" + failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing + + return (supportPurs, foreigns, passing, passingTestCases, failing, failingTestCases) + + context ("Passing examples") $ do forM_ passingTestCases $ \inputFile -> - assertCompiles (supportPurs ++ [passing inputFile]) foreigns - forM_ failingTestCases $ \inputFile -> - assertDoesNotCompile (supportPurs ++ [failing inputFile]) foreigns - - if null failures - then pure () - else do - putStrLn "Failures:" - forM_ failures $ \(fp, err) -> - let fp' = fromMaybe fp $ stripPrefix (failing ++ [pathSeparator]) fp - in putStrLn $ fp' ++ ": " ++ err - exitFailure + it ("'" <> inputFile <> "' should compile and run without error") $ do + assertCompiles (supportPurs ++ [passing inputFile]) foreigns + + context ("Failing examples") $ do + forM_ failingTestCases $ \inputFile -> do + expectedFailures <- runIO $ getShouldFailWith (failing inputFile) + it ("'" <> inputFile <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do + assertDoesNotCompile (supportPurs ++ [failing inputFile]) foreigns expectedFailures + + where + + getShouldFailWith :: FilePath -> IO [String] + getShouldFailWith = fmap extractFailWiths . readUTF8File + where + extractFailWiths = lines >>> mapMaybe (stripPrefix "-- @shouldFailWith ") >>> map trim + trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse modulesDir :: FilePath modulesDir = ".test_modules" "node_modules" @@ -113,26 +126,27 @@ type TestM = WriterT [(FilePath, String)] IO runTest :: P.Make a -> IO (Either P.MultipleErrors a) runTest = fmap fst . P.runMake P.defaultOptions -compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment) -compile inputFiles foreigns = runTest $ do +compile + :: [FilePath] + -> M.Map P.ModuleName FilePath + -> IO (Either P.MultipleErrors P.Environment) +compile inputFiles foreigns = silence $ runTest $ do fs <- liftIO $ readInput inputFiles ms <- P.parseModulesFromFiles id fs P.make (makeActions foreigns) (map snd ms) -assert :: [FilePath] -> - M.Map P.ModuleName FilePath -> - (Either P.MultipleErrors P.Environment -> IO (Maybe String)) -> - TestM () +assert + :: [FilePath] + -> M.Map P.ModuleName FilePath + -> (Either P.MultipleErrors P.Environment -> IO (Maybe String)) + -> Expectation assert inputFiles foreigns f = do - e <- liftIO $ compile inputFiles foreigns - maybeErr <- liftIO $ f e - case maybeErr of - Just err -> tell [(last inputFiles, err)] - Nothing -> return () + e <- compile inputFiles foreigns + maybeErr <- f e + maybe (return ()) expectationFailure maybeErr -assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM () +assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> Expectation assertCompiles inputFiles foreigns = do - liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully" assert inputFiles foreigns $ \e -> case e of Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs @@ -142,19 +156,19 @@ assertCompiles inputFiles foreigns = do writeFile entryPoint "require('Main').main()" result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process case result of - Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing + Just (ExitSuccess, _, _) -> return Nothing Just (ExitFailure _, _, err) -> return $ Just err Nothing -> return $ Just "Couldn't find node.js executable" -assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM () -assertDoesNotCompile inputFiles foreigns = do - let testFile = last inputFiles - liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile" - shouldFailWith <- getShouldFailWith testFile +assertDoesNotCompile + :: [FilePath] + -> M.Map P.ModuleName FilePath + -> [String] + -> Expectation +assertDoesNotCompile inputFiles foreigns shouldFailWith = do assert inputFiles foreigns $ \e -> case e of Left errs -> do - putStrLn (P.prettyPrintMultipleErrors False errs) return $ if null shouldFailWith then Just $ "shouldFailWith declaration is missing (errors were: " ++ show (map P.errorCode (P.runMultipleErrors errs)) @@ -164,19 +178,8 @@ assertDoesNotCompile inputFiles foreigns = do return $ Just "Should not have compiled" where - getShouldFailWith = - readUTF8File - >>> liftIO - >>> fmap ( lines - >>> mapMaybe (stripPrefix "-- @shouldFailWith ") - >>> map trim - ) - checkShouldFailWith expected errs = let actual = map P.errorCode $ P.runMultipleErrors errs in if sort expected == sort actual then Nothing else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual - - trim = - dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse From b87b0f78f0db27df8c05446f9d99df9d1c95daba Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 2 May 2016 16:45:49 +0100 Subject: [PATCH 0398/1580] Expect 'Done' from passing tests --- examples/passing/1335.purs | 26 +++--- examples/passing/AutoPrelude.purs | 20 ++--- examples/passing/Collatz.purs | 5 +- examples/passing/Comparisons.purs | 30 +++---- examples/passing/Console.purs | 4 +- examples/passing/ConstraintInference.purs | 7 +- examples/passing/ContextSimplification.purs | 4 +- examples/passing/DeepCase.purs | 8 +- examples/passing/Deriving.purs | 7 +- examples/passing/Eff.purs | 7 +- examples/passing/EqOrd.purs | 5 +- examples/passing/ExtendedInfixOperators.purs | 7 +- examples/passing/Fib.purs | 25 +++--- examples/passing/FieldConsPuns.purs | 23 +++--- examples/passing/FieldPuns.purs | 18 +++-- examples/passing/FinalTagless.purs | 5 +- examples/passing/Generalization1.purs | 3 +- examples/passing/ImportHiding.purs | 1 + .../InferRecFunWithConstrainedArgument.purs | 5 +- examples/passing/Let.purs | 16 ++-- examples/passing/Let2.purs | 5 +- examples/passing/ModuleExport.purs | 3 +- examples/passing/ModuleExportDupes.purs | 1 + examples/passing/ModuleExportExcluded.purs | 4 +- examples/passing/ModuleExportQualified.purs | 4 +- examples/passing/ModuleExportSelf.purs | 1 + examples/passing/MonadState.purs | 4 +- examples/passing/MultiArgFunctions.purs | 2 +- examples/passing/NestedTypeSynonyms.purs | 3 +- examples/passing/ObjectGetter.purs | 9 ++- examples/passing/ObjectUpdate.purs | 43 +++++----- examples/passing/ObjectUpdater.purs | 2 + examples/passing/ObjectWildcards.purs | 2 +- examples/passing/OperatorAssociativity.purs | 50 ++++++------ examples/passing/OperatorInlining.purs | 4 +- examples/passing/OperatorSections.purs | 3 +- examples/passing/OptionalQualified.purs | 2 +- examples/passing/OverlappingInstances.purs | 30 ++++--- examples/passing/OverlappingInstances2.purs | 50 ++++++------ examples/passing/OverlappingInstances3.purs | 36 +++++---- examples/passing/PartialFunction.purs | 23 +++--- .../passing/QualifiedQualifiedImports.purs | 2 +- examples/passing/Rank2Data.purs | 59 +++++++------- examples/passing/Rank2TypeSynonym.purs | 5 +- examples/passing/RebindableSyntax.purs | 80 ++++++++++--------- examples/passing/RuntimeScopeIssue.purs | 5 +- examples/passing/ShadowedModuleName.purs | 2 +- examples/passing/ShadowedTCO.purs | 39 ++++----- examples/passing/ShadowedTCOLet.purs | 21 ++--- examples/passing/StringEscapes.purs | 32 ++++---- examples/passing/Superclasses1.purs | 5 +- examples/passing/TCO.purs | 4 +- examples/passing/TailCall.purs | 5 +- .../passing/TypeClassMemberOrderChange.purs | 29 ++++--- examples/passing/TypeClasses.purs | 6 +- examples/passing/UTF8Sourcefile.purs | 18 ++--- examples/passing/Unit.purs | 6 +- examples/passing/Where.purs | 21 +++-- tests/TestCompiler.hs | 9 ++- 59 files changed, 481 insertions(+), 374 deletions(-) diff --git a/examples/passing/1335.purs b/examples/passing/1335.purs index e2a7347923..6b31a7ff0a 100644 --- a/examples/passing/1335.purs +++ b/examples/passing/1335.purs @@ -1,12 +1,14 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console (log) - -x :: forall a. a -> String -x a = y "Done" - where - y :: forall a. (Show a) => a -> String - y a = show (a :: a) - -main = log (x 0) +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +x :: forall a. a -> String +x a = y "Test" + where + y :: forall a. (Show a) => a -> String + y a = show (a :: a) + +main = do + log (x 0) + log "Done" diff --git a/examples/passing/AutoPrelude.purs b/examples/passing/AutoPrelude.purs index a69b4853ee..27fa41c123 100644 --- a/examples/passing/AutoPrelude.purs +++ b/examples/passing/AutoPrelude.purs @@ -1,9 +1,11 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console - -f x = x * 10.0 -g y = y - 10.0 - -main = log $ show $ (f <<< g) 100.0 +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +f x = x * 10.0 +g y = y - 10.0 + +main = do + log $ show $ (f <<< g) 100.0 + log "Done" diff --git a/examples/passing/Collatz.purs b/examples/passing/Collatz.purs index 626d318016..6cdb36371a 100644 --- a/examples/passing/Collatz.purs +++ b/examples/passing/Collatz.purs @@ -3,6 +3,7 @@ module Main where import Prelude import Control.Monad.Eff import Control.Monad.ST +import Control.Monad.Eff.Console (log, logShow) collatz :: Int -> Int collatz n = runPure (runST (do @@ -15,4 +16,6 @@ collatz n = runPure (runST (do pure $ m == 1 readSTRef count)) -main = Control.Monad.Eff.Console.logShow $ collatz 1000 +main = do + logShow $ collatz 1000 + log "Done" diff --git a/examples/passing/Comparisons.purs b/examples/passing/Comparisons.purs index f98dca0505..375098d3c2 100644 --- a/examples/passing/Comparisons.purs +++ b/examples/passing/Comparisons.purs @@ -1,15 +1,15 @@ -module Main where - -import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console -import Test.Assert - -main = do - assert (1.0 < 2.0) - assert (2.0 == 2.0) - assert (3.0 > 1.0) - assert ("a" < "b") - assert ("a" == "a") - assert ("z" > "a") - log "Done!" +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console +import Test.Assert + +main = do + assert (1.0 < 2.0) + assert (2.0 == 2.0) + assert (3.0 > 1.0) + assert ("a" < "b") + assert ("a" == "a") + assert ("z" > "a") + log "Done" diff --git a/examples/passing/Console.purs b/examples/passing/Console.purs index 3d84ec7490..2f442ae4cf 100644 --- a/examples/passing/Console.purs +++ b/examples/passing/Console.purs @@ -10,4 +10,6 @@ replicateM_ n act = do act replicateM_ (n - 1.0) act -main = replicateM_ 10.0 (log "Hello World!") +main = do + replicateM_ 10.0 (log "Hello World!") + log "Done" diff --git a/examples/passing/ConstraintInference.purs b/examples/passing/ConstraintInference.purs index dd281e6b24..05f9a2178e 100644 --- a/examples/passing/ConstraintInference.purs +++ b/examples/passing/ConstraintInference.purs @@ -1,7 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) -shout = Control.Monad.Eff.Console.log <<< (_ <> "!") <<< show +shout = log <<< (_ <> "!") <<< show -main = shout "Done" +main = do + shout "Test" + log "Done" diff --git a/examples/passing/ContextSimplification.purs b/examples/passing/ContextSimplification.purs index 45dc3cc3b9..349dcfbd66 100644 --- a/examples/passing/ContextSimplification.purs +++ b/examples/passing/ContextSimplification.purs @@ -10,4 +10,6 @@ shout = log <<< (_ <> "!") <<< show usesShowTwice true = shout usesShowTwice false = logShow -main = usesShowTwice true "Done" +main = do + usesShowTwice true "Test" + log "Done" diff --git a/examples/passing/DeepCase.purs b/examples/passing/DeepCase.purs index 56be49c6eb..e19f0e8d06 100644 --- a/examples/passing/DeepCase.purs +++ b/examples/passing/DeepCase.purs @@ -1,9 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console -import Control.Monad.Eff -import Control.Monad.ST +import Control.Monad.Eff.Console (log, logShow) f x y = let @@ -12,4 +10,6 @@ f x y = x -> 1.0 + x * x in g + x + y -main = logShow $ f 1.0 10.0 +main = do + logShow $ f 1.0 10.0 + log "Done" diff --git a/examples/passing/Deriving.purs b/examples/passing/Deriving.purs index fb1b65ec99..2609cf3934 100644 --- a/examples/passing/Deriving.purs +++ b/examples/passing/Deriving.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) import Test.Assert data V @@ -27,5 +28,7 @@ main = do assert $ X 0 < X 1 assert $ X 0 < Y "Foo" assert $ Y "Bar" < Y "Baz" - assert $ z == z where - z = Z { left: X 0, right: Y "Foo" } + assert $ z == z + log "Done" + where + z = Z { left: X 0, right: Y "Foo" } diff --git a/examples/passing/Eff.purs b/examples/passing/Eff.purs index 77b9af2f3a..f0b1ea8714 100644 --- a/examples/passing/Eff.purs +++ b/examples/passing/Eff.purs @@ -3,7 +3,7 @@ module Main where import Prelude import Control.Monad.Eff import Control.Monad.ST -import Control.Monad.Eff.Console +import Control.Monad.Eff.Console (log, logShow) test1 = do log "Line 1" @@ -21,5 +21,6 @@ test3 = pureST (do main = do test1 - Control.Monad.Eff.Console.logShow test2 - Control.Monad.Eff.Console.logShow test3 + logShow test2 + logShow test3 + log "Done" diff --git a/examples/passing/EqOrd.purs b/examples/passing/EqOrd.purs index cc2c9472f9..3d214a55be 100644 --- a/examples/passing/EqOrd.purs +++ b/examples/passing/EqOrd.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) data Pair a b = Pair a b @@ -12,4 +13,6 @@ instance ordPair :: (Ord a, Ord b) => Ord (Pair a b) where instance eqPair :: (Eq a, Eq b) => Eq (Pair a b) where eq (Pair a1 b1) (Pair a2 b2) = a1 == a2 && b1 == b2 -main = Control.Monad.Eff.Console.logShow $ Pair 1.0 2.0 == Pair 1.0 2.0 +main = do + logShow $ Pair 1.0 2.0 == Pair 1.0 2.0 + log "Done" diff --git a/examples/passing/ExtendedInfixOperators.purs b/examples/passing/ExtendedInfixOperators.purs index d70c40be1b..34481c09f5 100644 --- a/examples/passing/ExtendedInfixOperators.purs +++ b/examples/passing/ExtendedInfixOperators.purs @@ -1,9 +1,11 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) +import Data.Function (on) comparing :: forall a b. (Ord b) => (a -> b) -> a -> a -> Ordering -comparing f = compare `Data.Function.on` f +comparing f = compare `on` f null [] = true null _ = false @@ -11,4 +13,5 @@ null _ = false test = [1.0, 2.0, 3.0] `comparing null` [4.0, 5.0, 6.0] main = do - Control.Monad.Eff.Console.logShow test + logShow test + log "Done" diff --git a/examples/passing/Fib.purs b/examples/passing/Fib.purs index 6c3fcf1e95..83220aa572 100644 --- a/examples/passing/Fib.purs +++ b/examples/passing/Fib.purs @@ -1,15 +1,18 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.ST +import Control.Monad.Eff (whileE) +import Control.Monad.Eff.Console (log, logShow) +import Control.Monad.ST (runST, newSTRef, readSTRef, writeSTRef) -main = runST (do - n1 <- newSTRef 1.0 - n2 <- newSTRef 1.0 - whileE ((>) 1000.0 <$> readSTRef n1) $ do - n1' <- readSTRef n1 - n2' <- readSTRef n2 - writeSTRef n2 $ n1' + n2' - writeSTRef n1 n2' - Control.Monad.Eff.Console.logShow n2') +main = do + runST do + n1 <- newSTRef 1.0 + n2 <- newSTRef 1.0 + whileE ((>) 1000.0 <$> readSTRef n1) $ do + n1' <- readSTRef n1 + n2' <- readSTRef n2 + writeSTRef n2 $ n1' + n2' + writeSTRef n1 n2' + logShow n2' + log "Done" diff --git a/examples/passing/FieldConsPuns.purs b/examples/passing/FieldConsPuns.purs index 9a775e050e..1449ad8a8d 100644 --- a/examples/passing/FieldConsPuns.purs +++ b/examples/passing/FieldConsPuns.purs @@ -1,10 +1,13 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console - -greet { greeting, name } = log $ greeting <> ", " <> name <> "." - -main = greet { greeting, name} where - greeting = "Hello" - name = "World" +module Main where + +import Prelude +import Control.Monad.Eff.Console (log, logShow) + +greet { greeting, name } = log $ greeting <> ", " <> name <> "." + +main = do + greet { greeting, name } + log "Done" + where + greeting = "Hello" + name = "World" diff --git a/examples/passing/FieldPuns.purs b/examples/passing/FieldPuns.purs index d30444aecf..5bd00fcf73 100644 --- a/examples/passing/FieldPuns.purs +++ b/examples/passing/FieldPuns.purs @@ -1,8 +1,10 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console - -greet { greeting, name } = log $ greeting <> ", " <> name <> "." - -main = greet { greeting: "Hello", name: "World" } +module Main where + +import Prelude +import Control.Monad.Eff.Console + +greet { greeting, name } = log $ greeting <> ", " <> name <> "." + +main = do + greet { greeting: "Hello", name: "World" } + log "Done" diff --git a/examples/passing/FinalTagless.purs b/examples/passing/FinalTagless.purs index 3194fd1972..be7f04b19a 100644 --- a/examples/passing/FinalTagless.purs +++ b/examples/passing/FinalTagless.purs @@ -1,6 +1,7 @@ module Main where import Prelude hiding (add) +import Control.Monad.Eff.Console (log, logShow) class E e where num :: Number -> e Number @@ -19,4 +20,6 @@ runId (Id a) = a three :: Expr Number three = add (num 1.0) (num 2.0) -main = Control.Monad.Eff.Console.logShow $ runId three +main = do + logShow $ runId three + log "Done" diff --git a/examples/passing/Generalization1.purs b/examples/passing/Generalization1.purs index 16c7bedfd0..e16826829d 100644 --- a/examples/passing/Generalization1.purs +++ b/examples/passing/Generalization1.purs @@ -1,10 +1,11 @@ module Main where import Prelude -import Control.Monad.Eff.Console (logShow) +import Control.Monad.Eff.Console (logShow, log) main = do logShow (sum 1.0 2.0) logShow (sum 1 2) + log "Done" sum x y = x + y diff --git a/examples/passing/ImportHiding.purs b/examples/passing/ImportHiding.purs index 8cc0cf8d6e..bbc163e4b2 100644 --- a/examples/passing/ImportHiding.purs +++ b/examples/passing/ImportHiding.purs @@ -16,3 +16,4 @@ data Unit = X | Y main = do logShow show + log "Done" diff --git a/examples/passing/InferRecFunWithConstrainedArgument.purs b/examples/passing/InferRecFunWithConstrainedArgument.purs index 6c8d88927f..fece520cd7 100644 --- a/examples/passing/InferRecFunWithConstrainedArgument.purs +++ b/examples/passing/InferRecFunWithConstrainedArgument.purs @@ -1,8 +1,11 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) test 100.0 = 100.0 test n = test(1.0 + n) -main = Control.Monad.Eff.Console.logShow $ test 0.0 +main = do + logShow $ test 0.0 + log "Done" diff --git a/examples/passing/Let.purs b/examples/passing/Let.purs index 6e15774355..d7a1b5bf05 100644 --- a/examples/passing/Let.purs +++ b/examples/passing/Let.purs @@ -2,6 +2,7 @@ module Main where import Prelude import Control.Monad.Eff +import Control.Monad.Eff.Console (log, logShow) import Control.Monad.ST test1 x = let @@ -44,10 +45,11 @@ test10 _ = in f 10.0 main = do - Control.Monad.Eff.Console.logShow (test1 1.0) - Control.Monad.Eff.Console.logShow (test2 1.0 2.0) - Control.Monad.Eff.Console.logShow test3 - Control.Monad.Eff.Console.logShow test4 - Control.Monad.Eff.Console.logShow test5 - Control.Monad.Eff.Console.logShow test7 - Control.Monad.Eff.Console.logShow (test8 100.0) + logShow (test1 1.0) + logShow (test2 1.0 2.0) + logShow test3 + logShow test4 + logShow test5 + logShow test7 + logShow (test8 100.0) + log "Done" diff --git a/examples/passing/Let2.purs b/examples/passing/Let2.purs index e43ab43c65..51fc2516a0 100644 --- a/examples/passing/Let2.purs +++ b/examples/passing/Let2.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) test = let f :: Number -> Boolean @@ -14,4 +15,6 @@ test = x = f 1.0 in not x -main = Control.Monad.Eff.Console.logShow test +main = do + logShow test + log "Done" diff --git a/examples/passing/ModuleExport.purs b/examples/passing/ModuleExport.purs index 1c891fd087..4e0d7f4f74 100644 --- a/examples/passing/ModuleExport.purs +++ b/examples/passing/ModuleExport.purs @@ -2,8 +2,9 @@ module A (module Prelude) where import Prelude module Main where - import Control.Monad.Eff.Console + import Control.Monad.Eff.Console (log, logShow) import A main = do logShow (show 1.0) + log "Done" diff --git a/examples/passing/ModuleExportDupes.purs b/examples/passing/ModuleExportDupes.purs index baef27c328..b2f4b4ca57 100644 --- a/examples/passing/ModuleExportDupes.purs +++ b/examples/passing/ModuleExportDupes.purs @@ -17,3 +17,4 @@ module Main where main = do logShow (show 1.0) + log "Done" diff --git a/examples/passing/ModuleExportExcluded.purs b/examples/passing/ModuleExportExcluded.purs index a84878a917..f20ebd508d 100644 --- a/examples/passing/ModuleExportExcluded.purs +++ b/examples/passing/ModuleExportExcluded.purs @@ -5,10 +5,12 @@ module A (module Prelude, foo) where foo _ = 0.0 module Main where - import Control.Monad.Eff.Console + import Prelude + import Control.Monad.Eff.Console (log, logShow) import A (foo) otherwise = false main = do logShow "1.0" + log "Done" diff --git a/examples/passing/ModuleExportQualified.purs b/examples/passing/ModuleExportQualified.purs index e7b0a7f037..28728d353c 100644 --- a/examples/passing/ModuleExportQualified.purs +++ b/examples/passing/ModuleExportQualified.purs @@ -2,8 +2,10 @@ module A (module Prelude) where import Prelude module Main where - import Control.Monad.Eff.Console + import Prelude + import Control.Monad.Eff.Console (log, logShow) import A as B main = do logShow (B.show 1.0) + log "Done" diff --git a/examples/passing/ModuleExportSelf.purs b/examples/passing/ModuleExportSelf.purs index 2812eda611..c5001c8bae 100644 --- a/examples/passing/ModuleExportSelf.purs +++ b/examples/passing/ModuleExportSelf.purs @@ -12,3 +12,4 @@ module Main where main = do logShow (show bar) + log "Done" diff --git a/examples/passing/MonadState.purs b/examples/passing/MonadState.purs index b2e13a36da..46b2aaa13e 100644 --- a/examples/passing/MonadState.purs +++ b/examples/passing/MonadState.purs @@ -58,4 +58,6 @@ modify f = same :: forall a. (a -> a) -> (a -> a) same = id -main = logShow $ runState 0 (modify (_ + 1)) +main = do + logShow $ runState 0 (modify (_ + 1)) + log "Done" diff --git a/examples/passing/MultiArgFunctions.purs b/examples/passing/MultiArgFunctions.purs index b6b1b3208c..ed9239224b 100644 --- a/examples/passing/MultiArgFunctions.purs +++ b/examples/passing/MultiArgFunctions.purs @@ -24,4 +24,4 @@ main = do runFn9 (mkFn9 $ \a b c d e f g h i -> log $ show [a, b, c, d, e, f, g, h, i]) 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 runFn10 (mkFn10 $ \a b c d e f g h i j-> log $ show [a, b, c, d, e, f, g, h, i, j]) 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 logShow $ runFn2 g 0.0 0.0 - log "Done!" + log "Done" diff --git a/examples/passing/NestedTypeSynonyms.purs b/examples/passing/NestedTypeSynonyms.purs index b55bf04d26..3ae9327d7a 100644 --- a/examples/passing/NestedTypeSynonyms.purs +++ b/examples/passing/NestedTypeSynonyms.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type X = String type Y = X -> X @@ -8,4 +9,4 @@ type Y = X -> X fn :: Y fn a = a -main = Control.Monad.Eff.Console.logShow (fn "Done") +main = log (fn "Done") diff --git a/examples/passing/ObjectGetter.purs b/examples/passing/ObjectGetter.purs index ff71b702b4..d2a50c7f75 100644 --- a/examples/passing/ObjectGetter.purs +++ b/examples/passing/ObjectGetter.purs @@ -1,13 +1,14 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) getX = _.x point = { x: 1.0, y: 0.0 } main = do - Control.Monad.Eff.Console.logShow $ getX point - Control.Monad.Eff.Console.log $ _." 123 string Prop Name " { " 123 string Prop Name ": "OK" } - Control.Monad.Eff.Console.log $ (_.x >>> _.y) { x: { y: "Nested" } } - Control.Monad.Eff.Console.log $ _.value { value: "Done!" } + logShow $ getX point + log $ _." 123 string Prop Name " { " 123 string Prop Name ": "OK" } + log $ (_.x >>> _.y) { x: { y: "Nested" } } + log $ _.value { value: "Done" } diff --git a/examples/passing/ObjectUpdate.purs b/examples/passing/ObjectUpdate.purs index de6f358f49..d9e1f82210 100644 --- a/examples/passing/ObjectUpdate.purs +++ b/examples/passing/ObjectUpdate.purs @@ -1,20 +1,23 @@ -module Main where - -import Prelude - -update1 = \o -> o { foo = "Foo" } - -update2 :: forall r. { foo :: String | r } -> { foo :: String | r } -update2 = \o -> o { foo = "Foo" } - -replace = \o -> case o of - { foo = "Foo" } -> o { foo = "Bar" } - { foo = "Bar" } -> o { bar = "Baz" } - o -> o - -polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r } -polyUpdate = \o -> o { foo = "Foo" } - -inferPolyUpdate = \o -> o { foo = "Foo" } - -main = Control.Monad.Eff.Console.log ((update1 {foo: ""}).foo) +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +update1 = \o -> o { foo = "Foo" } + +update2 :: forall r. { foo :: String | r } -> { foo :: String | r } +update2 = \o -> o { foo = "Foo" } + +replace = \o -> case o of + { foo = "Foo" } -> o { foo = "Bar" } + { foo = "Bar" } -> o { bar = "Baz" } + o -> o + +polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r } +polyUpdate = \o -> o { foo = "Foo" } + +inferPolyUpdate = \o -> o { foo = "Foo" } + +main = do + log ((update1 {foo: ""}).foo) + log "Done" diff --git a/examples/passing/ObjectUpdater.purs b/examples/passing/ObjectUpdater.purs index 8070beda9c..a09c42c56f 100644 --- a/examples/passing/ObjectUpdater.purs +++ b/examples/passing/ObjectUpdater.purs @@ -22,3 +22,5 @@ main = do let record2 = (_ { x = _ }) { x: 0.0 } 10.0 assert $ record2.x == 10.0 + + log "Done" diff --git a/examples/passing/ObjectWildcards.purs b/examples/passing/ObjectWildcards.purs index cc9f6926d6..aae90adc1d 100644 --- a/examples/passing/ObjectWildcards.purs +++ b/examples/passing/ObjectWildcards.purs @@ -17,4 +17,4 @@ main = do point <- { x: _, y: x } <$> pure 2.0 assert $ point.x == 2.0 assert $ point.y == 1.0 - log (mkRecord 1.0 "Done!").bar + log (mkRecord 1.0 "Done").bar diff --git a/examples/passing/OperatorAssociativity.purs b/examples/passing/OperatorAssociativity.purs index 7ee50e6e08..137fb4d646 100644 --- a/examples/passing/OperatorAssociativity.purs +++ b/examples/passing/OperatorAssociativity.purs @@ -1,25 +1,25 @@ -module Main where - -import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console -import Test.Assert - -bug :: Number -> Number -> Number -bug a b = 0.0 - (a - b) - -main = do - assert (bug 0.0 2.0 == 2.0) - assert (0.0 - (0.0 - 2.0) == 2.0) - assert (0.0 - (0.0 + 2.0) == -2.0) - assert (6.0 / (3.0 * 2.0) == 1.0) - assert ((6.0 / 3.0) * 2.0 == 4.0) - assert (not (1.0 < 0.0) == true) - assert (not ((negate 1.0) < 0.0) == false) - assert (negate (1.0 + 10.0) == -11.0) - assert (2.0 * 3.0 / 4.0 == 1.5) - assert (1.0 * 2.0 * 3.0 * 4.0 * 5.0 / 6.0 == 20.0) - assert (1.0 + 10.0 - 5.0 == 6.0) - assert (1.0 + 10.0 * 5.0 == 51.0) - assert (10.0 * 5.0 - 1.0 == 49.0) - log "Success!" +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console +import Test.Assert + +bug :: Number -> Number -> Number +bug a b = 0.0 - (a - b) + +main = do + assert (bug 0.0 2.0 == 2.0) + assert (0.0 - (0.0 - 2.0) == 2.0) + assert (0.0 - (0.0 + 2.0) == -2.0) + assert (6.0 / (3.0 * 2.0) == 1.0) + assert ((6.0 / 3.0) * 2.0 == 4.0) + assert (not (1.0 < 0.0) == true) + assert (not ((negate 1.0) < 0.0) == false) + assert (negate (1.0 + 10.0) == -11.0) + assert (2.0 * 3.0 / 4.0 == 1.5) + assert (1.0 * 2.0 * 3.0 * 4.0 * 5.0 / 6.0 == 20.0) + assert (1.0 + 10.0 - 5.0 == 6.0) + assert (1.0 + 10.0 * 5.0 == 51.0) + assert (10.0 * 5.0 - 1.0 == 49.0) + log "Done" diff --git a/examples/passing/OperatorInlining.purs b/examples/passing/OperatorInlining.purs index 90386427fb..d632cb1087 100644 --- a/examples/passing/OperatorInlining.purs +++ b/examples/passing/OperatorInlining.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Control.Monad.Eff.Console (logShow, log) main = do @@ -44,3 +44,5 @@ main = do -- complementedLatticeBoolean logShow (not true) + + log "Done" diff --git a/examples/passing/OperatorSections.purs b/examples/passing/OperatorSections.purs index b7237e3d10..5b68c6bf43 100644 --- a/examples/passing/OperatorSections.purs +++ b/examples/passing/OperatorSections.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) import Test.Assert main = do @@ -14,4 +15,4 @@ main = do let (//) x y = x.x / y.x assert $ (_ // foo { x = 4.0 }) { x: 4.0 } == 1.0 assert $ (foo { x = 4.0 } // _) { x: 4.0 } == 1.0 - Control.Monad.Eff.Console.log "Done!" + log "Done" diff --git a/examples/passing/OptionalQualified.purs b/examples/passing/OptionalQualified.purs index 767e973b75..76c5bea4e3 100644 --- a/examples/passing/OptionalQualified.purs +++ b/examples/passing/OptionalQualified.purs @@ -8,5 +8,5 @@ import Control.Monad.Eff.Console as Console bind = P.bind main = do - message <- P.pure "success!" + message <- P.pure "Done" Console.log message diff --git a/examples/passing/OverlappingInstances.purs b/examples/passing/OverlappingInstances.purs index 94b2aa5cce..9e981e067c 100644 --- a/examples/passing/OverlappingInstances.purs +++ b/examples/passing/OverlappingInstances.purs @@ -1,13 +1,17 @@ -module Main where - -import Prelude - -data A = A - -instance showA1 :: Show A where - show A = "Instance 1" - -instance showA2 :: Show A where - show A = "Instance 2" - -main = Test.Assert.assert $ show A == "Instance 1" +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Test.Assert (assert) + +data A = A + +instance showA1 :: Show A where + show A = "Instance 1" + +instance showA2 :: Show A where + show A = "Instance 2" + +main = do + assert $ show A == "Instance 1" + log "Done" diff --git a/examples/passing/OverlappingInstances2.purs b/examples/passing/OverlappingInstances2.purs index 76012ca138..9694cfad6a 100644 --- a/examples/passing/OverlappingInstances2.purs +++ b/examples/passing/OverlappingInstances2.purs @@ -1,23 +1,27 @@ -module Main where - -import Prelude - -data A = A | B - -instance eqA1 :: Eq A where - eq A A = true - eq B B = true - eq _ _ = false - -instance eqA2 :: Eq A where - eq _ _ = true - -instance ordA :: Ord A where - compare A B = LT - compare B A = GT - compare _ _ = EQ - -test :: forall a. (Ord a) => a -> a -> String -test x y = show $ x == y - -main = Test.Assert.assert $ test A B == "false" +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Test.Assert (assert) + +data A = A | B + +instance eqA1 :: Eq A where + eq A A = true + eq B B = true + eq _ _ = false + +instance eqA2 :: Eq A where + eq _ _ = true + +instance ordA :: Ord A where + compare A B = LT + compare B A = GT + compare _ _ = EQ + +test :: forall a. (Ord a) => a -> a -> String +test x y = show $ x == y + +main = do + assert $ test A B == "false" + log "Done" diff --git a/examples/passing/OverlappingInstances3.purs b/examples/passing/OverlappingInstances3.purs index 4c6b354f90..14d95616ed 100644 --- a/examples/passing/OverlappingInstances3.purs +++ b/examples/passing/OverlappingInstances3.purs @@ -1,16 +1,20 @@ -module Main where - -import Prelude - -class Foo a - -instance foo1 :: Foo Number - -instance foo2 :: Foo Number - -test :: forall a. (Foo a) => a -> a -test a = a - -test1 = test 0.0 - -main = Test.Assert.assert (test1 == 0.0) +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Test.Assert (assert) + +class Foo a + +instance foo1 :: Foo Number + +instance foo2 :: Foo Number + +test :: forall a. (Foo a) => a -> a +test a = a + +test1 = test 0.0 + +main = do + assert (test1 == 0.0) + log "Done" diff --git a/examples/passing/PartialFunction.purs b/examples/passing/PartialFunction.purs index f0c4fd311a..45ba7657bf 100644 --- a/examples/passing/PartialFunction.purs +++ b/examples/passing/PartialFunction.purs @@ -1,10 +1,13 @@ -module Main where - -import Prelude -import Test.Assert - -fn :: Number -> Number -fn 0.0 = 0.0 -fn 1.0 = 2.0 - -main = assertThrows $ \_ -> fn 2.0 +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Test.Assert (assertThrows) + +fn :: Number -> Number +fn 0.0 = 0.0 +fn 1.0 = 2.0 + +main = do + assertThrows $ \_ -> fn 2.0 + log "Done" diff --git a/examples/passing/QualifiedQualifiedImports.purs b/examples/passing/QualifiedQualifiedImports.purs index 77401b205c..384bb7ee97 100644 --- a/examples/passing/QualifiedQualifiedImports.purs +++ b/examples/passing/QualifiedQualifiedImports.purs @@ -3,4 +3,4 @@ module Main where -- qualified import with qualified imported names import Control.Monad.Eff.Console (log) as Console -main = Console.log "Success!" +main = Console.log "Done" diff --git a/examples/passing/Rank2Data.purs b/examples/passing/Rank2Data.purs index 0f678037fd..8833a43502 100644 --- a/examples/passing/Rank2Data.purs +++ b/examples/passing/Rank2Data.purs @@ -1,29 +1,30 @@ -module Main where - -import Prelude hiding (add) - -data Id = Id forall a. a -> a - -runId = \id a -> case id of - Id f -> f a - -data Nat = Nat forall r. r -> (r -> r) -> r - -runNat = \nat -> case nat of - Nat f -> f 0.0 (\n -> n + 1.0) - -zero' = Nat (\zero' _ -> zero') - -succ = \n -> case n of - Nat f -> Nat (\zero' succ -> succ (f zero' succ)) - -add = \n m -> case n of - Nat f -> case m of - Nat g -> Nat (\zero' succ -> g (f zero' succ) succ) - -one' = succ zero' -two = succ zero' -four = add two two -fourNumber = runNat four - -main = Control.Monad.Eff.Console.log "Done'" +module Main where + +import Prelude hiding (add) +import Control.Monad.Eff.Console (log) + +data Id = Id forall a. a -> a + +runId = \id a -> case id of + Id f -> f a + +data Nat = Nat forall r. r -> (r -> r) -> r + +runNat = \nat -> case nat of + Nat f -> f 0.0 (\n -> n + 1.0) + +zero' = Nat (\zero' _ -> zero') + +succ = \n -> case n of + Nat f -> Nat (\zero' succ -> succ (f zero' succ)) + +add = \n m -> case n of + Nat f -> case m of + Nat g -> Nat (\zero' succ -> g (f zero' succ) succ) + +one' = succ zero' +two = succ zero' +four = add two two +fourNumber = runNat four + +main = log "Done" diff --git a/examples/passing/Rank2TypeSynonym.purs b/examples/passing/Rank2TypeSynonym.purs index 58b1e8c208..e4b8ffe351 100644 --- a/examples/passing/Rank2TypeSynonym.purs +++ b/examples/passing/Rank2TypeSynonym.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff +import Control.Monad.Eff.Console (log, logShow) type Foo a = forall f. (Monad f) => f a @@ -13,4 +13,5 @@ bar = foo 3.0 main = do x <- bar - Control.Monad.Eff.Console.logShow x + logShow x + log "Done" diff --git a/examples/passing/RebindableSyntax.purs b/examples/passing/RebindableSyntax.purs index df00ce1a19..4356127b43 100644 --- a/examples/passing/RebindableSyntax.purs +++ b/examples/passing/RebindableSyntax.purs @@ -1,39 +1,41 @@ -module Main where - -import Prelude - -example1 :: String -example1 = do - "Do" - " notation" - " for" - " Semigroup" - where - bind x f = x <> f unit - -(*>) :: forall f a b. (Apply f) => f a -> f b -> f b -(*>) fa fb = const id <$> fa <*> fb - -newtype Const a b = Const a - -runConst :: forall a b. Const a b -> a -runConst (Const a) = a - -instance functorConst :: Functor (Const a) where - map _ (Const a) = Const a - -instance applyConst :: (Semigroup a) => Apply (Const a) where - apply (Const a1) (Const a2) = Const (a1 <> a2) - -example2 :: Const String Unit -example2 = do - Const "Do" - Const " notation" - Const " for" - Const " Apply" - where - bind x f = x *> f unit - -main = do - Control.Monad.Eff.Console.log example1 - Control.Monad.Eff.Console.log $ runConst example2 +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +example1 :: String +example1 = do + "Do" + " notation" + " for" + " Semigroup" + where + bind x f = x <> f unit + +(*>) :: forall f a b. (Apply f) => f a -> f b -> f b +(*>) fa fb = const id <$> fa <*> fb + +newtype Const a b = Const a + +runConst :: forall a b. Const a b -> a +runConst (Const a) = a + +instance functorConst :: Functor (Const a) where + map _ (Const a) = Const a + +instance applyConst :: (Semigroup a) => Apply (Const a) where + apply (Const a1) (Const a2) = Const (a1 <> a2) + +example2 :: Const String Unit +example2 = do + Const "Do" + Const " notation" + Const " for" + Const " Apply" + where + bind x f = x *> f unit + +main = do + log example1 + log $ runConst example2 + log "Done" diff --git a/examples/passing/RuntimeScopeIssue.purs b/examples/passing/RuntimeScopeIssue.purs index b83e030517..2b1b7f9b21 100644 --- a/examples/passing/RuntimeScopeIssue.purs +++ b/examples/passing/RuntimeScopeIssue.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) class A a where a :: a -> Boolean @@ -16,4 +17,6 @@ instance bNumber :: B Number where b 0.0 = false b n = a (n - 1.0) -main = Control.Monad.Eff.Console.logShow $ a 10.0 +main = do + logShow $ a 10.0 + log "Done" diff --git a/examples/passing/ShadowedModuleName.purs b/examples/passing/ShadowedModuleName.purs index 3b303904f9..ac19774ce3 100644 --- a/examples/passing/ShadowedModuleName.purs +++ b/examples/passing/ShadowedModuleName.purs @@ -12,4 +12,4 @@ module Main where data Test = Test - main = log (runZ (Z "done")) + main = log (runZ (Z "Done")) diff --git a/examples/passing/ShadowedTCO.purs b/examples/passing/ShadowedTCO.purs index fa7e34db2d..47d222d6a9 100644 --- a/examples/passing/ShadowedTCO.purs +++ b/examples/passing/ShadowedTCO.purs @@ -1,18 +1,21 @@ -module Main where - -import Prelude hiding (add) - -runNat f = f 0.0 (\n -> n + 1.0) - -zero' z _ = z - -succ f zero' succ = succ (f zero' succ) - -add f g zero' succ = g (f zero' succ) succ - -one' = succ zero' -two = succ one' -four = add two two -fourNumber = runNat four - -main = Control.Monad.Eff.Console.log $ show fourNumber +module Main where + +import Prelude hiding (add) +import Control.Monad.Eff.Console (log) + +runNat f = f 0.0 (\n -> n + 1.0) + +zero' z _ = z + +succ f zero' succ = succ (f zero' succ) + +add f g zero' succ = g (f zero' succ) succ + +one' = succ zero' +two = succ one' +four = add two two +fourNumber = runNat four + +main = do + log $ show fourNumber + log "Done" diff --git a/examples/passing/ShadowedTCOLet.purs b/examples/passing/ShadowedTCOLet.purs index e3c1c7e098..38eb7739eb 100644 --- a/examples/passing/ShadowedTCOLet.purs +++ b/examples/passing/ShadowedTCOLet.purs @@ -1,9 +1,12 @@ -module Main where - -import Prelude - -f x y z = - let f 1.0 2.0 3.0 = 1.0 - in f x z y - -main = Control.Monad.Eff.Console.log $ show $ f 1.0 3.0 2.0 +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +f x y z = + let f 1.0 2.0 3.0 = 1.0 + in f x z y + +main = do + log $ show $ f 1.0 3.0 2.0 + log "Done" diff --git a/examples/passing/StringEscapes.purs b/examples/passing/StringEscapes.purs index 2d9774420d..5867819ed7 100644 --- a/examples/passing/StringEscapes.purs +++ b/examples/passing/StringEscapes.purs @@ -1,15 +1,17 @@ -module Main where - -import Prelude ((==), bind) -import Test.Assert (assert) - -singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C" -hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0" -decimal = "\119558\9731\966\224\0" == "𝌆☃φà\0" -surrogatePair = "\xD834\xDF06" == "\x1D306" - -main = do - assert singleCharacter - assert hex - assert decimal - assert surrogatePair +module Main where + +import Prelude ((==), bind) +import Test.Assert (assert) +import Control.Monad.Eff.Console (log) + +singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C" +hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0" +decimal = "\119558\9731\966\224\0" == "𝌆☃φà\0" +surrogatePair = "\xD834\xDF06" == "\x1D306" + +main = do + assert singleCharacter + assert hex + assert decimal + assert surrogatePair + log "Done" diff --git a/examples/passing/Superclasses1.purs b/examples/passing/Superclasses1.purs index 915e06483b..342f9ac223 100644 --- a/examples/passing/Superclasses1.purs +++ b/examples/passing/Superclasses1.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) class Su a where su :: a -> a @@ -17,4 +18,6 @@ instance clNumber :: Cl Number where test :: forall a. (Cl a) => a -> a test a = su (cl a a) -main = Control.Monad.Eff.Console.logShow $ test 10.0 +main = do + logShow $ test 10.0 + log "Done" diff --git a/examples/passing/TCO.purs b/examples/passing/TCO.purs index 74bd674e18..dc55311bce 100644 --- a/examples/passing/TCO.purs +++ b/examples/passing/TCO.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (logShow) +import Control.Monad.Eff.Console (log, logShow) main = do let f x = x + 1 @@ -11,10 +11,10 @@ main = do logShow (applyN 2 f v) logShow (applyN 3 f v) logShow (applyN 4 f v) + log "Done" applyN :: forall a. Int -> (a -> a) -> a -> a applyN = go id where go f n _ | n <= 0 = f go f n g = go (f >>> g) (n - 1) g - diff --git a/examples/passing/TailCall.purs b/examples/passing/TailCall.purs index 9e65a3f930..83d199e1a1 100644 --- a/examples/passing/TailCall.purs +++ b/examples/passing/TailCall.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log, logShow) data L a = C a (L a) | N @@ -14,4 +15,6 @@ loop x = loop (x + 1.0) notATailCall = \x -> (\notATailCall -> notATailCall x) (\x -> x) -main = Control.Monad.Eff.Console.logShow (test 0.0 (1.0 `C` (2.0 `C` (3.0 `C` N)))) +main = do + logShow (test 0.0 (1.0 `C` (2.0 `C` (3.0 `C` N)))) + log "Done" diff --git a/examples/passing/TypeClassMemberOrderChange.purs b/examples/passing/TypeClassMemberOrderChange.purs index 2e38b7d588..5ad8dcba1a 100644 --- a/examples/passing/TypeClassMemberOrderChange.purs +++ b/examples/passing/TypeClassMemberOrderChange.purs @@ -1,13 +1,16 @@ -module Main where - -import Prelude - -class Test a where - fn :: a -> a -> a - val :: a - -instance testBoolean :: Test Boolean where - val = true - fn x y = y - -main = Control.Monad.Eff.Console.log (show (fn true val)) +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +class Test a where + fn :: a -> a -> a + val :: a + +instance testBoolean :: Test Boolean where + val = true + fn x y = y + +main = do + log (show (fn true val)) + log "Done" diff --git a/examples/passing/TypeClasses.purs b/examples/passing/TypeClasses.purs index 96c6351ca2..b6e06c7c59 100644 --- a/examples/passing/TypeClasses.purs +++ b/examples/passing/TypeClasses.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test1 = \_ -> show "testing" @@ -65,5 +66,6 @@ test9 _ = runReader 0.0 $ do n <- ask pure $ n + 1.0 -main = Control.Monad.Eff.Console.log (test7 "Done") - +main = do + log (test7 "Hello") + log "Done" diff --git a/examples/passing/UTF8Sourcefile.purs b/examples/passing/UTF8Sourcefile.purs index da102a330d..1dbc2cb2a0 100644 --- a/examples/passing/UTF8Sourcefile.purs +++ b/examples/passing/UTF8Sourcefile.purs @@ -1,10 +1,8 @@ -module Main where - -import Control.Monad.Eff.Console - --- '→' is multibyte sequence \u2192. -utf8multibyte = "Hello λ→ world!!" - -main = do - log "done" - +module Main where + +import Control.Monad.Eff.Console + +-- '→' is multibyte sequence \u2192. +utf8multibyte = "Hello λ→ world!!" + +main = log "Done" diff --git a/examples/passing/Unit.purs b/examples/passing/Unit.purs index 808cd5ffbe..1449d72c9a 100644 --- a/examples/passing/Unit.purs +++ b/examples/passing/Unit.purs @@ -1,6 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Control.Monad.Eff.Console (logShow, log) -main = logShow (const unit $ "Hello world") +main = do + logShow (const unit $ "Hello world") + log "Done" diff --git a/examples/passing/Where.purs b/examples/passing/Where.purs index b090ed34a2..7aae7fcb79 100644 --- a/examples/passing/Where.purs +++ b/examples/passing/Where.purs @@ -1,8 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.ST +import Control.Monad.Eff.Console (logShow, log) test1 x = y where @@ -14,15 +13,12 @@ test2 x y = x' + y' x' = x + 1.0 y' = y + 1.0 - test3 = f 1.0 2.0 3.0 where f x y z = x + y + z - test4 = f (+) [1.0, 2.0] where f x [y, z] = x y z - test5 = g 10.0 where f x | x > 0.0 = g (x / 2.0) + 1.0 @@ -40,10 +36,11 @@ test7 x = go x go y = go $ (y + x / y) / 2.0 main = do - Control.Monad.Eff.Console.logShow (test1 1.0) - Control.Monad.Eff.Console.logShow (test2 1.0 2.0) - Control.Monad.Eff.Console.logShow test3 - Control.Monad.Eff.Console.logShow test4 - Control.Monad.Eff.Console.logShow test5 - Control.Monad.Eff.Console.logShow test6 - Control.Monad.Eff.Console.logShow (test7 100.0) + logShow (test1 1.0) + logShow (test2 1.0 2.0) + logShow test3 + logShow test4 + logShow test5 + logShow test6 + logShow (test7 100.0) + log "Done" diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index fd56c6c53e..c5b7e60dae 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -92,7 +92,9 @@ spec = do getShouldFailWith = fmap extractFailWiths . readUTF8File where extractFailWiths = lines >>> mapMaybe (stripPrefix "-- @shouldFailWith ") >>> map trim - trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse + +trim :: String -> String +trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse modulesDir :: FilePath modulesDir = ".test_modules" "node_modules" @@ -156,7 +158,10 @@ assertCompiles inputFiles foreigns = do writeFile entryPoint "require('Main').main()" result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process case result of - Just (ExitSuccess, _, _) -> return Nothing + Just (ExitSuccess, out, err) + | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err + | trim (last (lines out)) == "Done" -> return Nothing + | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out Just (ExitFailure _, _, err) -> return $ Just err Nothing -> return $ Just "Couldn't find node.js executable" From 66107e5ca8d2a013e7ea28f3f7da6e6090d27e5a Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 2 May 2016 21:14:35 +0100 Subject: [PATCH 0399/1580] Improve license errors in psc-publish (#2082) * Improve license errors in psc-publish Currently, you get the 'no license specified' error even if you do specify a license but it's not a valid SPDX license expression. There is quite a lot of code in the wild which specifies a license but does not use the SPDX format, and in these cases the error is not very good. This commit adds a new error type to differentiate between these two cases. It also removes the (now redundant) LicenseNotFound constructor. * Add Apache-2.0 example --- src/Language/PureScript/Publish.hs | 8 +++- .../PureScript/Publish/ErrorsWarnings.hs | 37 +++++++++++-------- 2 files changed, 28 insertions(+), 17 deletions(-) diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 9b3f8dbb27..1971672d8b 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -216,8 +216,12 @@ getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExt checkLicense :: PackageMeta -> PrepareM () checkLicense pkgMeta = - unless (any isValidSPDX (bowerLicense pkgMeta)) - (userError NoLicenseSpecified) + case bowerLicense pkgMeta of + [] -> + userError NoLicenseSpecified + ls -> + unless (any isValidSPDX ls) + (userError InvalidLicense) -- | -- Check if a string is a valid SPDX license expression. diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index b928f385c4..7702d49439 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -55,13 +55,13 @@ data PackageWarning -- | An error that should be fixed by the user. data UserError = BowerJSONNotFound - | LicenseNotFound | BowerExecutableNotFound [String] -- list of executable names tried | CouldntDecodeBowerJSON (ParseError BowerError) | TagMustBeCheckedOut | AmbiguousVersions [Version] -- Invariant: should contain at least two elements | BadRepositoryField RepositoryFieldError | NoLicenseSpecified + | InvalidLicense | MissingDependencies (NonEmpty PackageName) | CompileError P.MultipleErrors | DirtyWorkingTree @@ -129,12 +129,6 @@ displayUserError e = case e of "The bower.json file was not found. Please create one, or run " ++ "`pulp init`." ) - LicenseNotFound -> - para (concat - ["No LICENSE file was found. Please create one. ", - "Distributing code without a license means that nobody ", - "will be able to (legally) use it." - ]) BowerExecutableNotFound names -> para (concat [ "The Bower executable was not found (tried: ", format names, "). Please" @@ -189,14 +183,7 @@ displayUserError e = case e of , "following would be acceptable:" ]) , spacer - ] ++ - map (indented . para) - [ "* \"MIT\"" - , "* \"BSD-2-Clause\"" - , "* \"GPL-2.0+\"" - , "* \"(GPL-3.0 OR MIT)\"" - ] - ++ + ] ++ spdxExamples ++ [ spacer , para (concat [ "Note that distributing code without a license means that nobody " @@ -209,6 +196,16 @@ displayUserError e = case e of , "necessary." ]) ] + InvalidLicense -> + vcat $ + [ para (concat + [ "The license specified in bower.json is not a valid SPDX license " + , "expression. Please use the SPDX license expression format. For " + , "example, any of the following would be acceptable:" + ]) + , spacer + ] ++ + spdxExamples MissingDependencies pkgs -> let singular = NonEmpty.length pkgs == 1 pl a b = if singular then b else a @@ -239,6 +236,16 @@ displayUserError e = case e of "your changes first." ) +spdxExamples :: [Box] +spdxExamples = + map (indented . para) + [ "* \"MIT\"" + , "* \"Apache-2.0\"" + , "* \"BSD-2-Clause\"" + , "* \"GPL-2.0+\"" + , "* \"(GPL-3.0 OR MIT)\"" + ] + displayRepositoryError :: RepositoryFieldError -> Box displayRepositoryError err = case err of RepositoryFieldMissing -> From d6ed70f735104fa486b22f9b5dca03441b6f31a0 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 3 May 2016 03:53:57 +0100 Subject: [PATCH 0400/1580] Multi-file test setup --- examples/failing/1733.purs | 7 -- examples/failing/1733/Thingy.purs | 4 + .../failing/ArgLengthMismatch.purs | 13 +-- examples/failing/ConflictingExports.purs | 10 --- examples/failing/ConflictingExports/A.purs | 4 + examples/failing/ConflictingExports/B.purs | 4 + examples/failing/ConflictingImports.purs | 20 ++--- examples/failing/ConflictingImports/A.purs | 4 + examples/failing/ConflictingImports/B.purs | 4 + examples/failing/ConflictingImports2.purs | 22 ++--- examples/failing/ConflictingImports2/A.purs | 4 + examples/failing/ConflictingImports2/B.purs | 4 + .../failing/ConflictingQualifiedImports.purs | 16 +--- .../ConflictingQualifiedImports/A.purs | 4 + .../ConflictingQualifiedImports/B.purs | 4 + .../failing/ConflictingQualifiedImports2.purs | 14 +-- .../ConflictingQualifiedImports2/A.purs | 4 + .../ConflictingQualifiedImports2/B.purs | 4 + .../{manual => }/failing/ExportExplicit.purs | 15 ++-- examples/failing/ExportExplicit1.purs | 11 +++ examples/failing/ExportExplicit1/M1.purs | 3 + .../{manual => }/failing/ExportExplicit2.purs | 15 ++-- examples/failing/ExportExplicit3.purs | 9 ++ examples/failing/ExportExplicit3/M1.purs | 4 + examples/failing/ImportExplicit.purs | 4 + examples/failing/ImportExplicit/M1.purs | 3 + examples/failing/ImportExplicit2.purs | 4 + examples/failing/ImportExplicit2/M1.purs | 3 + examples/failing/ImportHidingModule.purs | 14 +-- examples/failing/ImportHidingModule/A.purs | 2 + examples/failing/ImportHidingModule/B.purs | 3 + examples/failing/ImportModule.purs | 4 + examples/failing/ImportModule/M2.purs | 3 + examples/failing/InstanceExport.purs | 26 ++---- .../InstanceExport/InstanceExport.purs | 11 +++ examples/failing/OrphanInstance.purs | 19 ++-- examples/failing/OrphanInstance/Class.purs | 4 + .../{manual => }/failing/OrphanTypeDecl.purs | 7 +- examples/failing/OverlappingReExport.purs | 11 +-- examples/failing/OverlappingReExport/A.purs | 2 + examples/failing/OverlappingReExport/B.purs | 2 + .../{manual => }/failing/RedefinedFixity.purs | 17 ++-- .../failing/RequiredHiddenType.purs | 17 ++-- examples/manual/QualifiedNames.purs | 13 --- examples/manual/failing/ExportExplicit1.purs | 14 --- examples/manual/failing/ExportExplicit3.purs | 13 --- examples/manual/failing/ImportExplicit.purs | 7 -- examples/manual/failing/ImportExplicit2.purs | 7 -- examples/manual/failing/ImportModule.purs | 7 -- examples/manual/passing/ExportExplicit.purs | 20 ----- examples/manual/passing/ExportExplicit2.purs | 15 ---- examples/manual/passing/Import.purs | 19 ---- examples/manual/passing/ImportExplicit.purs | 14 --- examples/manual/passing/ImportQualified.purs | 12 --- examples/manual/passing/Module.purs | 28 ------ examples/manual/passing/ModuleDeps.purs | 17 ---- examples/manual/passing/RedefinedFixity.purs | 24 ----- examples/manual/passing/TransitiveImport.purs | 24 ----- examples/passing/2018.purs | 13 --- examples/passing/2018/A.purs | 7 ++ examples/passing/2018/B.purs | 3 + examples/passing/ClassRefSyntax.purs | 5 -- examples/passing/ClassRefSyntax/Lib.purs | 4 + examples/passing/DctorOperatorAlias.purs | 10 +-- examples/passing/DctorOperatorAlias/List.purs | 5 ++ examples/passing/ExplicitImportReExport.purs | 27 +++--- .../passing/ExplicitImportReExport/Bar.purs | 3 + .../passing/ExplicitImportReExport/Foo.purs | 4 + examples/passing/ExportExplicit.purs | 9 ++ examples/passing/ExportExplicit/M1.purs | 10 +++ examples/passing/ExportExplicit2.purs | 7 ++ examples/passing/ExportExplicit2/M1.purs | 7 ++ .../passing/ExportedInstanceDeclarations.purs | 87 ++++++++++--------- examples/passing/Import.purs | 5 ++ examples/passing/Import/M1.purs | 8 ++ examples/passing/Import/M2.purs | 6 ++ examples/passing/ImportExplicit.purs | 9 ++ examples/passing/ImportExplicit/M1.purs | 4 + examples/passing/ImportQualified.purs | 8 ++ examples/passing/ImportQualified/M1.purs | 3 + examples/passing/Module.purs | 6 ++ examples/passing/Module/M1.purs | 14 +++ examples/passing/Module/M2.purs | 9 ++ examples/passing/ModuleDeps.purs | 5 ++ examples/passing/ModuleDeps/M1.purs | 5 ++ examples/passing/ModuleDeps/M2.purs | 5 ++ examples/passing/ModuleDeps/M3.purs | 3 + examples/passing/ModuleExport.purs | 14 ++- examples/passing/ModuleExport/A.purs | 3 + examples/passing/ModuleExportDupes.purs | 11 +-- examples/passing/ModuleExportDupes/A.purs | 3 + examples/passing/ModuleExportDupes/B.purs | 3 + examples/passing/ModuleExportDupes/C.purs | 4 + examples/passing/ModuleExportExcluded.purs | 21 ++--- examples/passing/ModuleExportExcluded/A.purs | 6 ++ examples/passing/ModuleExportQualified.purs | 16 ++-- examples/passing/ModuleExportQualified/A.purs | 3 + examples/passing/ModuleExportSelf.purs | 20 ++--- examples/passing/ModuleExportSelf/A.purs | 5 ++ examples/passing/NonConflictingExports.purs | 5 -- examples/passing/NonConflictingExports/A.purs | 4 + examples/passing/OperatorAliasElsewhere.purs | 5 -- .../passing/OperatorAliasElsewhere/Def.purs | 4 + .../passing/PendingConflictingImports.purs | 18 +--- .../passing/PendingConflictingImports/A.purs | 4 + .../passing/PendingConflictingImports/B.purs | 4 + .../passing/PendingConflictingImports2.purs | 5 -- .../passing/PendingConflictingImports2/A.purs | 4 + examples/passing/QualifiedNames.purs | 9 ++ examples/passing/QualifiedNames/Either.purs | 5 ++ examples/passing/ReExportQualified.purs | 16 +--- examples/passing/ReExportQualified/A.purs | 3 + examples/passing/ReExportQualified/B.purs | 3 + examples/passing/ReExportQualified/C.purs | 4 + examples/passing/RedefinedFixity.purs | 5 ++ examples/passing/RedefinedFixity/M1.purs | 7 ++ examples/passing/RedefinedFixity/M2.purs | 5 ++ examples/passing/RedefinedFixity/M3.purs | 6 ++ examples/passing/ResolvableScopeConflict.purs | 29 ++----- .../passing/ResolvableScopeConflict/A.purs | 4 + .../passing/ResolvableScopeConflict/B.purs | 7 ++ .../passing/ResolvableScopeConflict2.purs | 26 ++---- .../passing/ResolvableScopeConflict2/A.purs | 7 ++ .../passing/ResolvableScopeConflict3.purs | 15 +--- .../passing/ResolvableScopeConflict3/A.purs | 4 + examples/passing/ShadowedModuleName.purs | 15 +--- examples/passing/ShadowedModuleName/Test.purs | 6 ++ .../{manual => }/passing/ShadowedName.purs | 20 ++--- examples/passing/TransitiveImport.purs | 9 ++ examples/passing/TransitiveImport/Middle.purs | 3 + examples/passing/TransitiveImport/Test.purs | 9 ++ examples/passing/TypeOperators.purs | 35 ++------ examples/passing/TypeOperators/A.purs | 22 +++++ examples/passing/TypeWithoutParens.purs | 17 ++-- examples/passing/TypeWithoutParens/Lib.purs | 4 + .../{manual => }/passing/WildcardType.purs | 26 +++--- purescript.cabal | 45 ++++++++++ tests/TestCompiler.hs | 85 +++++++++++++----- 138 files changed, 776 insertions(+), 721 deletions(-) create mode 100644 examples/failing/1733/Thingy.purs rename examples/{manual => }/failing/ArgLengthMismatch.purs (60%) create mode 100644 examples/failing/ConflictingExports/A.purs create mode 100644 examples/failing/ConflictingExports/B.purs create mode 100644 examples/failing/ConflictingImports/A.purs create mode 100644 examples/failing/ConflictingImports/B.purs create mode 100644 examples/failing/ConflictingImports2/A.purs create mode 100644 examples/failing/ConflictingImports2/B.purs create mode 100644 examples/failing/ConflictingQualifiedImports/A.purs create mode 100644 examples/failing/ConflictingQualifiedImports/B.purs create mode 100644 examples/failing/ConflictingQualifiedImports2/A.purs create mode 100644 examples/failing/ConflictingQualifiedImports2/B.purs rename examples/{manual => }/failing/ExportExplicit.purs (69%) create mode 100644 examples/failing/ExportExplicit1.purs create mode 100644 examples/failing/ExportExplicit1/M1.purs rename examples/{manual => }/failing/ExportExplicit2.purs (67%) create mode 100644 examples/failing/ExportExplicit3.purs create mode 100644 examples/failing/ExportExplicit3/M1.purs create mode 100644 examples/failing/ImportExplicit.purs create mode 100644 examples/failing/ImportExplicit/M1.purs create mode 100644 examples/failing/ImportExplicit2.purs create mode 100644 examples/failing/ImportExplicit2/M1.purs create mode 100644 examples/failing/ImportHidingModule/A.purs create mode 100644 examples/failing/ImportHidingModule/B.purs create mode 100644 examples/failing/ImportModule.purs create mode 100644 examples/failing/ImportModule/M2.purs create mode 100644 examples/failing/InstanceExport/InstanceExport.purs create mode 100644 examples/failing/OrphanInstance/Class.purs rename examples/{manual => }/failing/OrphanTypeDecl.purs (54%) create mode 100644 examples/failing/OverlappingReExport/A.purs create mode 100644 examples/failing/OverlappingReExport/B.purs rename examples/{manual => }/failing/RedefinedFixity.purs (65%) rename examples/{manual => }/failing/RequiredHiddenType.purs (69%) delete mode 100644 examples/manual/QualifiedNames.purs delete mode 100644 examples/manual/failing/ExportExplicit1.purs delete mode 100644 examples/manual/failing/ExportExplicit3.purs delete mode 100644 examples/manual/failing/ImportExplicit.purs delete mode 100644 examples/manual/failing/ImportExplicit2.purs delete mode 100644 examples/manual/failing/ImportModule.purs delete mode 100644 examples/manual/passing/ExportExplicit.purs delete mode 100644 examples/manual/passing/ExportExplicit2.purs delete mode 100644 examples/manual/passing/Import.purs delete mode 100644 examples/manual/passing/ImportExplicit.purs delete mode 100644 examples/manual/passing/ImportQualified.purs delete mode 100644 examples/manual/passing/Module.purs delete mode 100644 examples/manual/passing/ModuleDeps.purs delete mode 100644 examples/manual/passing/RedefinedFixity.purs delete mode 100644 examples/manual/passing/TransitiveImport.purs create mode 100644 examples/passing/2018/A.purs create mode 100644 examples/passing/2018/B.purs create mode 100644 examples/passing/ClassRefSyntax/Lib.purs create mode 100644 examples/passing/DctorOperatorAlias/List.purs create mode 100644 examples/passing/ExplicitImportReExport/Bar.purs create mode 100644 examples/passing/ExplicitImportReExport/Foo.purs create mode 100644 examples/passing/ExportExplicit.purs create mode 100644 examples/passing/ExportExplicit/M1.purs create mode 100644 examples/passing/ExportExplicit2.purs create mode 100644 examples/passing/ExportExplicit2/M1.purs rename examples/{manual => }/passing/ExportedInstanceDeclarations.purs (82%) create mode 100644 examples/passing/Import.purs create mode 100644 examples/passing/Import/M1.purs create mode 100644 examples/passing/Import/M2.purs create mode 100644 examples/passing/ImportExplicit.purs create mode 100644 examples/passing/ImportExplicit/M1.purs create mode 100644 examples/passing/ImportQualified.purs create mode 100644 examples/passing/ImportQualified/M1.purs create mode 100644 examples/passing/Module.purs create mode 100644 examples/passing/Module/M1.purs create mode 100644 examples/passing/Module/M2.purs create mode 100644 examples/passing/ModuleDeps.purs create mode 100644 examples/passing/ModuleDeps/M1.purs create mode 100644 examples/passing/ModuleDeps/M2.purs create mode 100644 examples/passing/ModuleDeps/M3.purs create mode 100644 examples/passing/ModuleExport/A.purs create mode 100644 examples/passing/ModuleExportDupes/A.purs create mode 100644 examples/passing/ModuleExportDupes/B.purs create mode 100644 examples/passing/ModuleExportDupes/C.purs create mode 100644 examples/passing/ModuleExportExcluded/A.purs create mode 100644 examples/passing/ModuleExportQualified/A.purs create mode 100644 examples/passing/ModuleExportSelf/A.purs create mode 100644 examples/passing/NonConflictingExports/A.purs create mode 100644 examples/passing/OperatorAliasElsewhere/Def.purs create mode 100644 examples/passing/PendingConflictingImports/A.purs create mode 100644 examples/passing/PendingConflictingImports/B.purs create mode 100644 examples/passing/PendingConflictingImports2/A.purs create mode 100644 examples/passing/QualifiedNames.purs create mode 100644 examples/passing/QualifiedNames/Either.purs create mode 100644 examples/passing/ReExportQualified/A.purs create mode 100644 examples/passing/ReExportQualified/B.purs create mode 100644 examples/passing/ReExportQualified/C.purs create mode 100644 examples/passing/RedefinedFixity.purs create mode 100644 examples/passing/RedefinedFixity/M1.purs create mode 100644 examples/passing/RedefinedFixity/M2.purs create mode 100644 examples/passing/RedefinedFixity/M3.purs create mode 100644 examples/passing/ResolvableScopeConflict/A.purs create mode 100644 examples/passing/ResolvableScopeConflict/B.purs create mode 100644 examples/passing/ResolvableScopeConflict2/A.purs create mode 100644 examples/passing/ResolvableScopeConflict3/A.purs create mode 100644 examples/passing/ShadowedModuleName/Test.purs rename examples/{manual => }/passing/ShadowedName.purs (95%) create mode 100644 examples/passing/TransitiveImport.purs create mode 100644 examples/passing/TransitiveImport/Middle.purs create mode 100644 examples/passing/TransitiveImport/Test.purs create mode 100644 examples/passing/TypeOperators/A.purs create mode 100644 examples/passing/TypeWithoutParens/Lib.purs rename examples/{manual => }/passing/WildcardType.purs (93%) diff --git a/examples/failing/1733.purs b/examples/failing/1733.purs index 8dfbf18102..389cae5dff 100644 --- a/examples/failing/1733.purs +++ b/examples/failing/1733.purs @@ -1,13 +1,6 @@ -- @shouldFailWith UnknownValue - module Main where import Thingy as Thing main = Thing.doesntExist "hi" - -module Thingy where - -foo :: Int -foo = 1 - diff --git a/examples/failing/1733/Thingy.purs b/examples/failing/1733/Thingy.purs new file mode 100644 index 0000000000..1803a5fbad --- /dev/null +++ b/examples/failing/1733/Thingy.purs @@ -0,0 +1,4 @@ +module Thingy where + +foo :: Int +foo = 1 diff --git a/examples/manual/failing/ArgLengthMismatch.purs b/examples/failing/ArgLengthMismatch.purs similarity index 60% rename from examples/manual/failing/ArgLengthMismatch.purs rename to examples/failing/ArgLengthMismatch.purs index 5061b2f853..847e293065 100644 --- a/examples/manual/failing/ArgLengthMismatch.purs +++ b/examples/failing/ArgLengthMismatch.purs @@ -1,6 +1,7 @@ -module ArgLengthMismatch where - -import Prelude - -f x y = true -f = false +-- @shouldFailWith ArgListLengthsDiffer +module ArgLengthMismatch where + +import Prelude + +f x y = true +f = false diff --git a/examples/failing/ConflictingExports.purs b/examples/failing/ConflictingExports.purs index 1aef23b3bd..9ef5d6793f 100644 --- a/examples/failing/ConflictingExports.purs +++ b/examples/failing/ConflictingExports.purs @@ -1,14 +1,4 @@ -- @shouldFailWith ScopeConflict -module A where - - thing :: Int - thing = 1 - -module B where - - thing :: Int - thing = 2 - -- Fails here because re-exporting forces any scope conflicts to be resolved module Main (module A, module B) where diff --git a/examples/failing/ConflictingExports/A.purs b/examples/failing/ConflictingExports/A.purs new file mode 100644 index 0000000000..302b0328d1 --- /dev/null +++ b/examples/failing/ConflictingExports/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/failing/ConflictingExports/B.purs b/examples/failing/ConflictingExports/B.purs new file mode 100644 index 0000000000..076bf7ea52 --- /dev/null +++ b/examples/failing/ConflictingExports/B.purs @@ -0,0 +1,4 @@ +module B where + +thing :: Int +thing = 2 diff --git a/examples/failing/ConflictingImports.purs b/examples/failing/ConflictingImports.purs index 64eb1cc1da..00b2b3c87b 100644 --- a/examples/failing/ConflictingImports.purs +++ b/examples/failing/ConflictingImports.purs @@ -1,19 +1,9 @@ -- @shouldFailWith ScopeConflict -module A where - - thing :: Int - thing = 1 - -module B where - - thing :: Int - thing = 2 - module Main where - import A - import B +import A +import B - -- Error due to referencing `thing` which is in scope as A.thing and B.thing - what :: Int - what = thing +-- Error due to referencing `thing` which is in scope as A.thing and B.thing +what :: Int +what = thing diff --git a/examples/failing/ConflictingImports/A.purs b/examples/failing/ConflictingImports/A.purs new file mode 100644 index 0000000000..302b0328d1 --- /dev/null +++ b/examples/failing/ConflictingImports/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/failing/ConflictingImports/B.purs b/examples/failing/ConflictingImports/B.purs new file mode 100644 index 0000000000..076bf7ea52 --- /dev/null +++ b/examples/failing/ConflictingImports/B.purs @@ -0,0 +1,4 @@ +module B where + +thing :: Int +thing = 2 diff --git a/examples/failing/ConflictingImports2.purs b/examples/failing/ConflictingImports2.purs index 02a21b69de..e716da187c 100644 --- a/examples/failing/ConflictingImports2.purs +++ b/examples/failing/ConflictingImports2.purs @@ -1,20 +1,10 @@ -- @shouldFailWith ScopeConflict -module A where - - thing :: Int - thing = 1 - -module B where - - thing :: Int - thing = 2 - module Main where - import A (thing) - import B (thing) +import A (thing) +import B (thing) - -- Error due to referencing `thing` which is explicitly in scope as A.thing - -- and B.thing - what :: Int - what = thing +-- Error due to referencing `thing` which is explicitly in scope as A.thing +-- and B.thing +what :: Int +what = thing diff --git a/examples/failing/ConflictingImports2/A.purs b/examples/failing/ConflictingImports2/A.purs new file mode 100644 index 0000000000..302b0328d1 --- /dev/null +++ b/examples/failing/ConflictingImports2/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/failing/ConflictingImports2/B.purs b/examples/failing/ConflictingImports2/B.purs new file mode 100644 index 0000000000..076bf7ea52 --- /dev/null +++ b/examples/failing/ConflictingImports2/B.purs @@ -0,0 +1,4 @@ +module B where + +thing :: Int +thing = 2 diff --git a/examples/failing/ConflictingQualifiedImports.purs b/examples/failing/ConflictingQualifiedImports.purs index a85aa60b46..9089caedcb 100644 --- a/examples/failing/ConflictingQualifiedImports.purs +++ b/examples/failing/ConflictingQualifiedImports.purs @@ -1,17 +1,7 @@ -- @shouldFailWith ScopeConflict -module A where - - thing :: Int - thing = 1 - -module B where - - thing :: Int - thing = 2 - module Main where - import A as X - import B as X +import A as X +import B as X - foo = X.thing +foo = X.thing diff --git a/examples/failing/ConflictingQualifiedImports/A.purs b/examples/failing/ConflictingQualifiedImports/A.purs new file mode 100644 index 0000000000..302b0328d1 --- /dev/null +++ b/examples/failing/ConflictingQualifiedImports/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/failing/ConflictingQualifiedImports/B.purs b/examples/failing/ConflictingQualifiedImports/B.purs new file mode 100644 index 0000000000..076bf7ea52 --- /dev/null +++ b/examples/failing/ConflictingQualifiedImports/B.purs @@ -0,0 +1,4 @@ +module B where + +thing :: Int +thing = 2 diff --git a/examples/failing/ConflictingQualifiedImports2.purs b/examples/failing/ConflictingQualifiedImports2.purs index fd5efa546b..11b150eca0 100644 --- a/examples/failing/ConflictingQualifiedImports2.purs +++ b/examples/failing/ConflictingQualifiedImports2.purs @@ -1,15 +1,5 @@ -- @shouldFailWith ScopeConflict -module A where - - thing :: Int - thing = 1 - -module B where - - thing :: Int - thing = 2 - module Main (module X) where - import A as X - import B as X +import A as X +import B as X diff --git a/examples/failing/ConflictingQualifiedImports2/A.purs b/examples/failing/ConflictingQualifiedImports2/A.purs new file mode 100644 index 0000000000..302b0328d1 --- /dev/null +++ b/examples/failing/ConflictingQualifiedImports2/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/failing/ConflictingQualifiedImports2/B.purs b/examples/failing/ConflictingQualifiedImports2/B.purs new file mode 100644 index 0000000000..076bf7ea52 --- /dev/null +++ b/examples/failing/ConflictingQualifiedImports2/B.purs @@ -0,0 +1,4 @@ +module B where + +thing :: Int +thing = 2 diff --git a/examples/manual/failing/ExportExplicit.purs b/examples/failing/ExportExplicit.purs similarity index 69% rename from examples/manual/failing/ExportExplicit.purs rename to examples/failing/ExportExplicit.purs index 55398ca601..e42012c351 100644 --- a/examples/manual/failing/ExportExplicit.purs +++ b/examples/failing/ExportExplicit.purs @@ -1,7 +1,8 @@ --- should fail as z does not exist in the module -module M1 (x, y, z) where - -import Prelude - -x = 1 -y = 2 +-- @shouldFailWith UnknownExportValue +-- should fail as z does not exist in the module +module M1 (x, y, z) where + +import Prelude + +x = 1 +y = 2 diff --git a/examples/failing/ExportExplicit1.purs b/examples/failing/ExportExplicit1.purs new file mode 100644 index 0000000000..0229fc415b --- /dev/null +++ b/examples/failing/ExportExplicit1.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith UnknownDataConstructor +module Main where + +import M1 + +testX = X + +-- should fail as Y constructor is not exported from M1 +testY = Y + +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/failing/ExportExplicit1/M1.purs b/examples/failing/ExportExplicit1/M1.purs new file mode 100644 index 0000000000..9bc4f162cf --- /dev/null +++ b/examples/failing/ExportExplicit1/M1.purs @@ -0,0 +1,3 @@ +module M1 (X(X)) where + +data X = X | Y diff --git a/examples/manual/failing/ExportExplicit2.purs b/examples/failing/ExportExplicit2.purs similarity index 67% rename from examples/manual/failing/ExportExplicit2.purs rename to examples/failing/ExportExplicit2.purs index 472e337e73..e105bff271 100644 --- a/examples/manual/failing/ExportExplicit2.purs +++ b/examples/failing/ExportExplicit2.purs @@ -1,7 +1,8 @@ --- should fail as Y is not a data constructor for X -module M1 (X(Y)) where - -import Prelude - -data X = X -data Y = Y +-- @shouldFailWith UnknownExportDataConstructor +-- should fail as Y is not a data constructor for X +module M1 (X(Y)) where + +import Prelude + +data X = X +data Y = Y diff --git a/examples/failing/ExportExplicit3.purs b/examples/failing/ExportExplicit3.purs new file mode 100644 index 0000000000..3695393db6 --- /dev/null +++ b/examples/failing/ExportExplicit3.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith UnknownDataConstructor +module Main where + +import M1 + +-- should fail as Z is not exported from M1 +testZ = M1.Z + +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/failing/ExportExplicit3/M1.purs b/examples/failing/ExportExplicit3/M1.purs new file mode 100644 index 0000000000..32dd66771a --- /dev/null +++ b/examples/failing/ExportExplicit3/M1.purs @@ -0,0 +1,4 @@ +module M1 (X(..)) where + +data X = X | Y +data Z = Z diff --git a/examples/failing/ImportExplicit.purs b/examples/failing/ImportExplicit.purs new file mode 100644 index 0000000000..aaea627b26 --- /dev/null +++ b/examples/failing/ImportExplicit.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith UnknownImportType +module Main where + +import M1 (X(..)) diff --git a/examples/failing/ImportExplicit/M1.purs b/examples/failing/ImportExplicit/M1.purs new file mode 100644 index 0000000000..f3155b81eb --- /dev/null +++ b/examples/failing/ImportExplicit/M1.purs @@ -0,0 +1,3 @@ +module M1 where + +foo = "foo" diff --git a/examples/failing/ImportExplicit2.purs b/examples/failing/ImportExplicit2.purs new file mode 100644 index 0000000000..e1b43c6258 --- /dev/null +++ b/examples/failing/ImportExplicit2.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith UnknownImportDataConstructor +module Main where + +import M1 (X(Z, Q)) diff --git a/examples/failing/ImportExplicit2/M1.purs b/examples/failing/ImportExplicit2/M1.purs new file mode 100644 index 0000000000..35fd17c4f0 --- /dev/null +++ b/examples/failing/ImportExplicit2/M1.purs @@ -0,0 +1,3 @@ +module M1 where + +data X = Y diff --git a/examples/failing/ImportHidingModule.purs b/examples/failing/ImportHidingModule.purs index 4d91014b34..5fa1025780 100644 --- a/examples/failing/ImportHidingModule.purs +++ b/examples/failing/ImportHidingModule.purs @@ -1,10 +1,4 @@ --- @shouldFailWith ImportHidingModule -module A where - x = 1 - -module B (module B, module A) where - import A - y = 1 - -module C where - import B hiding (module A) +-- @shouldFailWith ImportHidingModule +module Main where + +import B hiding (module A) diff --git a/examples/failing/ImportHidingModule/A.purs b/examples/failing/ImportHidingModule/A.purs new file mode 100644 index 0000000000..e741925669 --- /dev/null +++ b/examples/failing/ImportHidingModule/A.purs @@ -0,0 +1,2 @@ +module A where +x = 1 diff --git a/examples/failing/ImportHidingModule/B.purs b/examples/failing/ImportHidingModule/B.purs new file mode 100644 index 0000000000..e714878ce8 --- /dev/null +++ b/examples/failing/ImportHidingModule/B.purs @@ -0,0 +1,3 @@ +module B (module B, module A) where +import A +y = 1 diff --git a/examples/failing/ImportModule.purs b/examples/failing/ImportModule.purs new file mode 100644 index 0000000000..d355733526 --- /dev/null +++ b/examples/failing/ImportModule.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith UnknownModule +module Main where + +import M1 diff --git a/examples/failing/ImportModule/M2.purs b/examples/failing/ImportModule/M2.purs new file mode 100644 index 0000000000..c1a472fb1e --- /dev/null +++ b/examples/failing/ImportModule/M2.purs @@ -0,0 +1,3 @@ +module M2 where + +data X = X diff --git a/examples/failing/InstanceExport.purs b/examples/failing/InstanceExport.purs index f787aff2e2..a87b8819ce 100644 --- a/examples/failing/InstanceExport.purs +++ b/examples/failing/InstanceExport.purs @@ -1,19 +1,7 @@ --- @shouldFailWith TransitiveExportError -module InstanceExport (S(..), f) where - -import Prelude - -newtype S = S String - -class F a where - f :: a -> String - -instance fs :: F S where - f (S s) = s - -module Test where - -import InstanceExport -import Prelude - -test = f $ S "Test" +-- @shouldFailWith TransitiveExportError +module Test where + +import InstanceExport +import Prelude + +test = f $ S "Test" diff --git a/examples/failing/InstanceExport/InstanceExport.purs b/examples/failing/InstanceExport/InstanceExport.purs new file mode 100644 index 0000000000..477085750c --- /dev/null +++ b/examples/failing/InstanceExport/InstanceExport.purs @@ -0,0 +1,11 @@ +module InstanceExport (S(..), f) where + +import Prelude + +newtype S = S String + +class F a where + f :: a -> String + +instance fs :: F S where + f (S s) = s diff --git a/examples/failing/OrphanInstance.purs b/examples/failing/OrphanInstance.purs index 878c82a8b9..fa7703d054 100644 --- a/examples/failing/OrphanInstance.purs +++ b/examples/failing/OrphanInstance.purs @@ -1,12 +1,7 @@ --- @shouldFailWith OrphanInstance -module Class where - - class C a where - op :: a -> a - -module Test where - - import Class - - instance cBoolean :: C Boolean where - op a = a +-- @shouldFailWith OrphanInstance +module Test where + +import Class + +instance cBoolean :: C Boolean where + op a = a diff --git a/examples/failing/OrphanInstance/Class.purs b/examples/failing/OrphanInstance/Class.purs new file mode 100644 index 0000000000..6f7d61f4e0 --- /dev/null +++ b/examples/failing/OrphanInstance/Class.purs @@ -0,0 +1,4 @@ +module Class where + +class C a where + op :: a -> a diff --git a/examples/manual/failing/OrphanTypeDecl.purs b/examples/failing/OrphanTypeDecl.purs similarity index 54% rename from examples/manual/failing/OrphanTypeDecl.purs rename to examples/failing/OrphanTypeDecl.purs index 516ab6d708..b5f15310f9 100644 --- a/examples/manual/failing/OrphanTypeDecl.purs +++ b/examples/failing/OrphanTypeDecl.purs @@ -1,3 +1,4 @@ -module OrphanTypeDecl where - -fn :: Number -> Boolean +-- @shouldFailWith OrphanTypeDeclaration +module OrphanTypeDecl where + +fn :: Number -> Boolean diff --git a/examples/failing/OverlappingReExport.purs b/examples/failing/OverlappingReExport.purs index 8c38c4561d..fbcdafcf31 100644 --- a/examples/failing/OverlappingReExport.purs +++ b/examples/failing/OverlappingReExport.purs @@ -1,10 +1,5 @@ -- @shouldFailWith DuplicateValueExport -module A where - x = true - -module B where - x = false - module C (module A, module M2) where - import A - import B as M2 + +import A +import B as M2 diff --git a/examples/failing/OverlappingReExport/A.purs b/examples/failing/OverlappingReExport/A.purs new file mode 100644 index 0000000000..2204211fc8 --- /dev/null +++ b/examples/failing/OverlappingReExport/A.purs @@ -0,0 +1,2 @@ +module A where +x = true diff --git a/examples/failing/OverlappingReExport/B.purs b/examples/failing/OverlappingReExport/B.purs new file mode 100644 index 0000000000..65ebd09c51 --- /dev/null +++ b/examples/failing/OverlappingReExport/B.purs @@ -0,0 +1,2 @@ +module B where +x = false diff --git a/examples/manual/failing/RedefinedFixity.purs b/examples/failing/RedefinedFixity.purs similarity index 65% rename from examples/manual/failing/RedefinedFixity.purs rename to examples/failing/RedefinedFixity.purs index a9d316618c..04d2217dbd 100644 --- a/examples/manual/failing/RedefinedFixity.purs +++ b/examples/failing/RedefinedFixity.purs @@ -1,8 +1,9 @@ -module RedefinedFixity where - -import Prelude - -(!?) x y = x + y - -infix 2 !? -infix 2 !? +-- @shouldFailWith MultipleFixities +module RedefinedFixity where + +import Prelude + +(!?) x y = x + y + +infix 2 !? +infix 2 !? diff --git a/examples/manual/failing/RequiredHiddenType.purs b/examples/failing/RequiredHiddenType.purs similarity index 69% rename from examples/manual/failing/RequiredHiddenType.purs rename to examples/failing/RequiredHiddenType.purs index c1417ffc38..a849ab0776 100644 --- a/examples/manual/failing/RequiredHiddenType.purs +++ b/examples/failing/RequiredHiddenType.purs @@ -1,8 +1,9 @@ --- exporting `a` should fail as `A` is hidden -module Foo (B(..), a, b) where - -data A = A -data B = B - -a = A -b = B +-- @shouldFailWith TransitiveExportError +-- exporting `a` should fail as `A` is hidden +module Foo (B(..), a, b) where + +data A = A +data B = B + +a = A +b = B diff --git a/examples/manual/QualifiedNames.purs b/examples/manual/QualifiedNames.purs deleted file mode 100644 index 7db54f05d5..0000000000 --- a/examples/manual/QualifiedNames.purs +++ /dev/null @@ -1,13 +0,0 @@ -module Data.Either where - -import Prelude - -data Either a b = Left a | Right b - -module Main where - -either :: forall a b c. (a -> c) -> (b -> c) -> Data.Either.Either a b -> c -either f _ (Data.Either.Left x) = f x -either _ g (Data.Either.Right y) = g y - -main = Control.Monad.Eff.Console.log (either id id (Data.Either.Left "Done")) diff --git a/examples/manual/failing/ExportExplicit1.purs b/examples/manual/failing/ExportExplicit1.purs deleted file mode 100644 index 6fc9226fa9..0000000000 --- a/examples/manual/failing/ExportExplicit1.purs +++ /dev/null @@ -1,14 +0,0 @@ -module M1 (X(X)) where - - data X = X | Y - -module Main where - - import M1 - - testX = X - - -- should fail as Y constructor is not exported from M1 - testY = Y - - main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/manual/failing/ExportExplicit3.purs b/examples/manual/failing/ExportExplicit3.purs deleted file mode 100644 index f991d0d722..0000000000 --- a/examples/manual/failing/ExportExplicit3.purs +++ /dev/null @@ -1,13 +0,0 @@ -module M1 (X(..)) where - - data X = X | Y - data Z = Z - -module Main where - - import M1 - - -- should fail as Z is not exported from M1 - testZ = M1.Z - - main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/manual/failing/ImportExplicit.purs b/examples/manual/failing/ImportExplicit.purs deleted file mode 100644 index c3abea31e2..0000000000 --- a/examples/manual/failing/ImportExplicit.purs +++ /dev/null @@ -1,7 +0,0 @@ -module M1 where - - foo = "foo" - -module Main where - - import M1 (X(..)) diff --git a/examples/manual/failing/ImportExplicit2.purs b/examples/manual/failing/ImportExplicit2.purs deleted file mode 100644 index 17bf714721..0000000000 --- a/examples/manual/failing/ImportExplicit2.purs +++ /dev/null @@ -1,7 +0,0 @@ -module M1 where - - data X = Y - -module Main where - - import M1 (X(Z, Q)) diff --git a/examples/manual/failing/ImportModule.purs b/examples/manual/failing/ImportModule.purs deleted file mode 100644 index f193fecf34..0000000000 --- a/examples/manual/failing/ImportModule.purs +++ /dev/null @@ -1,7 +0,0 @@ -module M2 where - - data X = X - -module Main where - - import M1 diff --git a/examples/manual/passing/ExportExplicit.purs b/examples/manual/passing/ExportExplicit.purs deleted file mode 100644 index 245ab353ac..0000000000 --- a/examples/manual/passing/ExportExplicit.purs +++ /dev/null @@ -1,20 +0,0 @@ -module M1 (X(X), Z(..), foo) where - - data X = X | Y - data Z = Z - - foo :: Number - foo = 0 - - bar :: Number - bar = 1 - -module Main where - - import M1 - - testX = X - testZ = Z - testFoo = foo - - main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/manual/passing/ExportExplicit2.purs b/examples/manual/passing/ExportExplicit2.purs deleted file mode 100644 index 215f165393..0000000000 --- a/examples/manual/passing/ExportExplicit2.purs +++ /dev/null @@ -1,15 +0,0 @@ -module M1 (bar) where - - foo :: Number - foo = 0 - - bar :: Number - bar = foo - -module Main where - - import M1 - - testBar = bar - - main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/manual/passing/Import.purs b/examples/manual/passing/Import.purs deleted file mode 100644 index 6479e20654..0000000000 --- a/examples/manual/passing/Import.purs +++ /dev/null @@ -1,19 +0,0 @@ -module M1 where - - import Prelude () - - id :: forall a. a -> a - id = \x -> x - - foo = id - -module M2 where - - import Prelude () - import M1 - - main = \_ -> foo 42 - -module Main where - -main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/manual/passing/ImportExplicit.purs b/examples/manual/passing/ImportExplicit.purs deleted file mode 100644 index 4c7525ee49..0000000000 --- a/examples/manual/passing/ImportExplicit.purs +++ /dev/null @@ -1,14 +0,0 @@ -module M1 where - - data X = X | Y - data Z = Z - -module Main where - - import M1 (X(..)) - - testX :: X - testX = X - testY = Y - - main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/manual/passing/ImportQualified.purs b/examples/manual/passing/ImportQualified.purs deleted file mode 100644 index fb4e63118d..0000000000 --- a/examples/manual/passing/ImportQualified.purs +++ /dev/null @@ -1,12 +0,0 @@ -module M1 where - - log x = x - -module Main where - - import Prelude - import Control.Monad.Eff - import M1 - import qualified Control.Monad.Eff.Console as C - - main = C.log (log "Done") diff --git a/examples/manual/passing/Module.purs b/examples/manual/passing/Module.purs deleted file mode 100644 index 6d8d748a64..0000000000 --- a/examples/manual/passing/Module.purs +++ /dev/null @@ -1,28 +0,0 @@ -module M1 where - - import Prelude - - data Foo = Foo String - - foo :: M1.Foo -> String - foo = \f -> case f of Foo s -> s <> "foo" - - bar :: Foo -> String - bar = foo - - incr :: Number -> Number - incr x = x + 1 - -module M2 where - - import Prelude - - baz :: M1.Foo -> String - baz = M1.foo - - match :: M1.Foo -> String - match = \f -> case f of M1.Foo s -> s <> "foo" - -module Main where - -main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/manual/passing/ModuleDeps.purs b/examples/manual/passing/ModuleDeps.purs deleted file mode 100644 index afadc77491..0000000000 --- a/examples/manual/passing/ModuleDeps.purs +++ /dev/null @@ -1,17 +0,0 @@ -module M1 where - -import M2 - -foo = M3.baz - -module M2 where - -bar = M3.baz - -module M3 where - -baz = 1 - -module Main where - -main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/manual/passing/RedefinedFixity.purs b/examples/manual/passing/RedefinedFixity.purs deleted file mode 100644 index 9dbe701957..0000000000 --- a/examples/manual/passing/RedefinedFixity.purs +++ /dev/null @@ -1,24 +0,0 @@ -module M1 where - -import Prelude () - -($) f a = f a - -infixr 1000 $ - -module M2 where - -import Prelude () - -import M1 - -module M3 where - -import Prelude () - -import M1 -import M2 - -module Main where - -main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/manual/passing/TransitiveImport.purs b/examples/manual/passing/TransitiveImport.purs deleted file mode 100644 index 524e19cf35..0000000000 --- a/examples/manual/passing/TransitiveImport.purs +++ /dev/null @@ -1,24 +0,0 @@ -module Test where - - import Prelude - - class TestCls a where - test :: a -> a - - instance unitTestCls :: TestCls Unit where - test _ = unit - -module Middle where - - middle = Test.test - -module Main where - - import Prelude - import Middle - import Control.Monad.Eff.Console - - main = do - logShow (middle unit) - trace "Done" - pure unit diff --git a/examples/passing/2018.purs b/examples/passing/2018.purs index 2a0eef6980..e09f4825a8 100644 --- a/examples/passing/2018.purs +++ b/examples/passing/2018.purs @@ -1,15 +1,3 @@ -module B where - - data Foo = X | Y - -module A where - - import B as Main - - -- Prior to the 2018 fix this would be detected as a cycle between A and Main. - foo ∷ Main.Foo → Main.Foo - foo x = x - module Main where import Prelude @@ -22,4 +10,3 @@ main :: forall e. Eff (console :: CONSOLE | e) Unit main = do let tmp = foo X log "Done" - diff --git a/examples/passing/2018/A.purs b/examples/passing/2018/A.purs new file mode 100644 index 0000000000..bff4cd0391 --- /dev/null +++ b/examples/passing/2018/A.purs @@ -0,0 +1,7 @@ +module A where + +import B as Main + +-- Prior to the 2018 fix this would be detected as a cycle between A and Main. +foo ∷ Main.Foo → Main.Foo +foo x = x diff --git a/examples/passing/2018/B.purs b/examples/passing/2018/B.purs new file mode 100644 index 0000000000..c87647d4c9 --- /dev/null +++ b/examples/passing/2018/B.purs @@ -0,0 +1,3 @@ +module B where + +data Foo = X | Y diff --git a/examples/passing/ClassRefSyntax.purs b/examples/passing/ClassRefSyntax.purs index b4a187d778..3ffd8ea9cf 100644 --- a/examples/passing/ClassRefSyntax.purs +++ b/examples/passing/ClassRefSyntax.purs @@ -1,8 +1,3 @@ -module Lib (class X, go) where - - class X a where - go :: a -> a - module Main where import Lib (class X, go) diff --git a/examples/passing/ClassRefSyntax/Lib.purs b/examples/passing/ClassRefSyntax/Lib.purs new file mode 100644 index 0000000000..345491f909 --- /dev/null +++ b/examples/passing/ClassRefSyntax/Lib.purs @@ -0,0 +1,4 @@ +module Lib (class X, go) where + +class X a where + go :: a -> a diff --git a/examples/passing/DctorOperatorAlias.purs b/examples/passing/DctorOperatorAlias.purs index 863133d1f1..c07fe950e6 100644 --- a/examples/passing/DctorOperatorAlias.purs +++ b/examples/passing/DctorOperatorAlias.purs @@ -1,17 +1,11 @@ -module Data.List where - - data List a = Cons a (List a) | Nil - - infixr 6 Cons as : - module Main where import Prelude (Unit, bind, (==)) import Control.Monad.Eff (Eff) import Control.Monad.Eff.Console (CONSOLE, log) import Test.Assert (ASSERT, assert') - import Data.List (List(..), (:)) - import Data.List as L + import List (List(..), (:)) + import List as L -- unqualified infixl 6 Cons as ! diff --git a/examples/passing/DctorOperatorAlias/List.purs b/examples/passing/DctorOperatorAlias/List.purs new file mode 100644 index 0000000000..a428343a2c --- /dev/null +++ b/examples/passing/DctorOperatorAlias/List.purs @@ -0,0 +1,5 @@ +module List where + +data List a = Cons a (List a) | Nil + +infixr 6 Cons as : diff --git a/examples/passing/ExplicitImportReExport.purs b/examples/passing/ExplicitImportReExport.purs index 3c7dd2bf06..3c01ca8712 100644 --- a/examples/passing/ExplicitImportReExport.purs +++ b/examples/passing/ExplicitImportReExport.purs @@ -1,16 +1,11 @@ --- from #1244 -module Foo where - - foo :: Int - foo = 3 - -module Bar (module Foo) where - - import Foo - -module Baz where - - import Bar (foo) - - baz :: Int - baz = foo +-- from #1244 +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Bar (foo) + +baz :: Int +baz = foo + +main = log "Done" diff --git a/examples/passing/ExplicitImportReExport/Bar.purs b/examples/passing/ExplicitImportReExport/Bar.purs new file mode 100644 index 0000000000..4b1d3d6a36 --- /dev/null +++ b/examples/passing/ExplicitImportReExport/Bar.purs @@ -0,0 +1,3 @@ +module Bar (module Foo) where + +import Foo diff --git a/examples/passing/ExplicitImportReExport/Foo.purs b/examples/passing/ExplicitImportReExport/Foo.purs new file mode 100644 index 0000000000..69ccbb12ec --- /dev/null +++ b/examples/passing/ExplicitImportReExport/Foo.purs @@ -0,0 +1,4 @@ +module Foo where + +foo :: Int +foo = 3 diff --git a/examples/passing/ExportExplicit.purs b/examples/passing/ExportExplicit.purs new file mode 100644 index 0000000000..5be3fde87f --- /dev/null +++ b/examples/passing/ExportExplicit.purs @@ -0,0 +1,9 @@ +module Main where + +import M1 + +testX = X +testZ = Z +testFoo = foo + +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ExportExplicit/M1.purs b/examples/passing/ExportExplicit/M1.purs new file mode 100644 index 0000000000..09d8b4bef7 --- /dev/null +++ b/examples/passing/ExportExplicit/M1.purs @@ -0,0 +1,10 @@ +module M1 (X(X), Z(..), foo) where + +data X = X | Y +data Z = Z + +foo :: Int +foo = 0 + +bar :: Int +bar = 1 diff --git a/examples/passing/ExportExplicit2.purs b/examples/passing/ExportExplicit2.purs new file mode 100644 index 0000000000..99bef2625f --- /dev/null +++ b/examples/passing/ExportExplicit2.purs @@ -0,0 +1,7 @@ +module Main where + +import M1 + +testBar = bar + +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ExportExplicit2/M1.purs b/examples/passing/ExportExplicit2/M1.purs new file mode 100644 index 0000000000..16c27e1007 --- /dev/null +++ b/examples/passing/ExportExplicit2/M1.purs @@ -0,0 +1,7 @@ +module M1 (bar) where + +foo :: Int +foo = 0 + +bar :: Int +bar = foo diff --git a/examples/manual/passing/ExportedInstanceDeclarations.purs b/examples/passing/ExportedInstanceDeclarations.purs similarity index 82% rename from examples/manual/passing/ExportedInstanceDeclarations.purs rename to examples/passing/ExportedInstanceDeclarations.purs index e5c75689a3..782ecf2aa5 100644 --- a/examples/manual/passing/ExportedInstanceDeclarations.purs +++ b/examples/passing/ExportedInstanceDeclarations.purs @@ -1,43 +1,44 @@ - --- Tests that instances for non-exported classes / types do not appear in the --- result of `exportedDeclarations`. - -module ExportedInstanceDeclarations - ( Const(..) - , Foo - , foo - ) where - -import Prelude - -data Const a b = Const a - -class Foo a where - foo :: a - -data NonexportedType = NonexportedType - -class NonexportedClass a where - notExported :: a - --- There are three places that a nonexported type or type class can occur, --- leading an instance to count as non-exported: --- * Constraints --- * The type class itself --- * The instance types - --- Case 1: constraints -instance nonExportedFoo :: (NonexportedClass a) => Foo a where - foo = notExported - --- Another instance of case 1: -instance nonExportedFoo2 :: (Foo NonexportedType) => Foo (a -> a) where - foo = id - --- Case 2: type class -instance nonExportedNonexportedType :: NonexportedClass (Const Number a) where - notExported = Const 0 - --- Case 3: instance types -instance constFoo :: Foo (Const NonexportedType b) where - foo = Const NonexportedType +-- Tests that instances for non-exported classes / types do not appear in the +-- result of `exportedDeclarations`. +module ExportedInstanceDeclarations + ( Const(..) + , class Foo + , foo + ) where + +import Prelude +import Control.Monad.Eff.Console (log) + +data Const a b = Const a + +class Foo a where + foo :: a + +data NonexportedType = NonexportedType + +class NonexportedClass a where + notExported :: a + +-- There are three places that a nonexported type or type class can occur, +-- leading an instance to count as non-exported: +-- * Constraints +-- * The type class itself +-- * The instance types + +-- Case 1: constraints +instance nonExportedFoo :: (NonexportedClass a) => Foo a where + foo = notExported + +-- Another instance of case 1: +instance nonExportedFoo2 :: (Foo NonexportedType) => Foo (a -> a) where + foo = id + +-- Case 2: type class +instance nonExportedNonexportedType :: NonexportedClass (Const Int a) where + notExported = Const 0 + +-- Case 3: instance types +instance constFoo :: Foo (Const NonexportedType b) where + foo = Const NonexportedType + +main = log "Done" diff --git a/examples/passing/Import.purs b/examples/passing/Import.purs new file mode 100644 index 0000000000..3be4119115 --- /dev/null +++ b/examples/passing/Import.purs @@ -0,0 +1,5 @@ +module Main where + +import M2 + +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Import/M1.purs b/examples/passing/Import/M1.purs new file mode 100644 index 0000000000..144ecdba95 --- /dev/null +++ b/examples/passing/Import/M1.purs @@ -0,0 +1,8 @@ +module M1 where + +import Prelude () + +id :: forall a. a -> a +id = \x -> x + +foo = id diff --git a/examples/passing/Import/M2.purs b/examples/passing/Import/M2.purs new file mode 100644 index 0000000000..eba01c684d --- /dev/null +++ b/examples/passing/Import/M2.purs @@ -0,0 +1,6 @@ +module M2 where + +import Prelude () +import M1 + +main = \_ -> foo 42 diff --git a/examples/passing/ImportExplicit.purs b/examples/passing/ImportExplicit.purs new file mode 100644 index 0000000000..78115ffeaf --- /dev/null +++ b/examples/passing/ImportExplicit.purs @@ -0,0 +1,9 @@ +module Main where + +import M1 (X(..)) + +testX :: X +testX = X +testY = Y + +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ImportExplicit/M1.purs b/examples/passing/ImportExplicit/M1.purs new file mode 100644 index 0000000000..189ba7cd01 --- /dev/null +++ b/examples/passing/ImportExplicit/M1.purs @@ -0,0 +1,4 @@ +module M1 where + +data X = X | Y +data Z = Z diff --git a/examples/passing/ImportQualified.purs b/examples/passing/ImportQualified.purs new file mode 100644 index 0000000000..303f6e1055 --- /dev/null +++ b/examples/passing/ImportQualified.purs @@ -0,0 +1,8 @@ +module Main where + +import Prelude +import Control.Monad.Eff +import M1 +import Control.Monad.Eff.Console as C + +main = C.log (log "Done") diff --git a/examples/passing/ImportQualified/M1.purs b/examples/passing/ImportQualified/M1.purs new file mode 100644 index 0000000000..6c423fb3f4 --- /dev/null +++ b/examples/passing/ImportQualified/M1.purs @@ -0,0 +1,3 @@ +module M1 where + +log x = x diff --git a/examples/passing/Module.purs b/examples/passing/Module.purs new file mode 100644 index 0000000000..8d01717b2a --- /dev/null +++ b/examples/passing/Module.purs @@ -0,0 +1,6 @@ +module Main where + +import M1 +import M2 + +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/Module/M1.purs b/examples/passing/Module/M1.purs new file mode 100644 index 0000000000..1c7fbcac59 --- /dev/null +++ b/examples/passing/Module/M1.purs @@ -0,0 +1,14 @@ +module M1 where + +import Prelude + +data Foo = Foo String + +foo :: M1.Foo -> String +foo = \f -> case f of Foo s -> s <> "foo" + +bar :: Foo -> String +bar = foo + +incr :: Int -> Int +incr x = x + 1 diff --git a/examples/passing/Module/M2.purs b/examples/passing/Module/M2.purs new file mode 100644 index 0000000000..e2b14c3fad --- /dev/null +++ b/examples/passing/Module/M2.purs @@ -0,0 +1,9 @@ +module M2 where + +import Prelude + +baz :: M1.Foo -> String +baz = M1.foo + +match :: M1.Foo -> String +match = \f -> case f of M1.Foo s -> s <> "foo" diff --git a/examples/passing/ModuleDeps.purs b/examples/passing/ModuleDeps.purs new file mode 100644 index 0000000000..a2b5d3c7b2 --- /dev/null +++ b/examples/passing/ModuleDeps.purs @@ -0,0 +1,5 @@ +module Main where + +import M1 + +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ModuleDeps/M1.purs b/examples/passing/ModuleDeps/M1.purs new file mode 100644 index 0000000000..7a9a554ba4 --- /dev/null +++ b/examples/passing/ModuleDeps/M1.purs @@ -0,0 +1,5 @@ +module M1 where + +import M2 + +foo = M2.bar diff --git a/examples/passing/ModuleDeps/M2.purs b/examples/passing/ModuleDeps/M2.purs new file mode 100644 index 0000000000..660da88d3d --- /dev/null +++ b/examples/passing/ModuleDeps/M2.purs @@ -0,0 +1,5 @@ +module M2 where + +import M3 + +bar = M3.baz diff --git a/examples/passing/ModuleDeps/M3.purs b/examples/passing/ModuleDeps/M3.purs new file mode 100644 index 0000000000..d9b7633d3c --- /dev/null +++ b/examples/passing/ModuleDeps/M3.purs @@ -0,0 +1,3 @@ +module M3 where + +baz = 1 diff --git a/examples/passing/ModuleExport.purs b/examples/passing/ModuleExport.purs index 4e0d7f4f74..0ce2e51bbf 100644 --- a/examples/passing/ModuleExport.purs +++ b/examples/passing/ModuleExport.purs @@ -1,10 +1,8 @@ -module A (module Prelude) where - import Prelude - module Main where - import Control.Monad.Eff.Console (log, logShow) - import A - main = do - logShow (show 1.0) - log "Done" +import Control.Monad.Eff.Console (log, logShow) +import A + +main = do + logShow (show 1.0) + log "Done" diff --git a/examples/passing/ModuleExport/A.purs b/examples/passing/ModuleExport/A.purs new file mode 100644 index 0000000000..4c111221e7 --- /dev/null +++ b/examples/passing/ModuleExport/A.purs @@ -0,0 +1,3 @@ +module A (module Prelude) where + +import Prelude diff --git a/examples/passing/ModuleExportDupes.purs b/examples/passing/ModuleExportDupes.purs index b2f4b4ca57..6a354a7411 100644 --- a/examples/passing/ModuleExportDupes.purs +++ b/examples/passing/ModuleExportDupes.purs @@ -1,14 +1,5 @@ -module A (module Prelude) where - import Prelude - -module B (module Prelude) where - import Prelude - -module C (module Prelude, module A) where - import Prelude - import A - module Main where + import Control.Monad.Eff.Console import A import B diff --git a/examples/passing/ModuleExportDupes/A.purs b/examples/passing/ModuleExportDupes/A.purs new file mode 100644 index 0000000000..4c111221e7 --- /dev/null +++ b/examples/passing/ModuleExportDupes/A.purs @@ -0,0 +1,3 @@ +module A (module Prelude) where + +import Prelude diff --git a/examples/passing/ModuleExportDupes/B.purs b/examples/passing/ModuleExportDupes/B.purs new file mode 100644 index 0000000000..c4ed60d9e8 --- /dev/null +++ b/examples/passing/ModuleExportDupes/B.purs @@ -0,0 +1,3 @@ +module B (module Prelude) where + +import Prelude diff --git a/examples/passing/ModuleExportDupes/C.purs b/examples/passing/ModuleExportDupes/C.purs new file mode 100644 index 0000000000..b92340f91d --- /dev/null +++ b/examples/passing/ModuleExportDupes/C.purs @@ -0,0 +1,4 @@ +module C (module Prelude, module A) where + +import Prelude +import A diff --git a/examples/passing/ModuleExportExcluded.purs b/examples/passing/ModuleExportExcluded.purs index f20ebd508d..c5b425dbdd 100644 --- a/examples/passing/ModuleExportExcluded.purs +++ b/examples/passing/ModuleExportExcluded.purs @@ -1,16 +1,11 @@ -module A (module Prelude, foo) where - import Prelude - - foo :: Number -> Number - foo _ = 0.0 - module Main where - import Prelude - import Control.Monad.Eff.Console (log, logShow) - import A (foo) - otherwise = false +import Prelude +import Control.Monad.Eff.Console (log, logShow) +import A (foo) + +otherwise = false - main = do - logShow "1.0" - log "Done" +main = do + logShow "1.0" + log "Done" diff --git a/examples/passing/ModuleExportExcluded/A.purs b/examples/passing/ModuleExportExcluded/A.purs new file mode 100644 index 0000000000..fe4e91e2f5 --- /dev/null +++ b/examples/passing/ModuleExportExcluded/A.purs @@ -0,0 +1,6 @@ +module A (module Prelude, foo) where + +import Prelude + +foo :: Number -> Number +foo _ = 0.0 diff --git a/examples/passing/ModuleExportQualified.purs b/examples/passing/ModuleExportQualified.purs index 28728d353c..a8e8c6e5d0 100644 --- a/examples/passing/ModuleExportQualified.purs +++ b/examples/passing/ModuleExportQualified.purs @@ -1,11 +1,9 @@ -module A (module Prelude) where - import Prelude - module Main where - import Prelude - import Control.Monad.Eff.Console (log, logShow) - import A as B - main = do - logShow (B.show 1.0) - log "Done" +import Prelude +import Control.Monad.Eff.Console (log, logShow) +import A as B + +main = do + logShow (B.show 1.0) + log "Done" diff --git a/examples/passing/ModuleExportQualified/A.purs b/examples/passing/ModuleExportQualified/A.purs new file mode 100644 index 0000000000..4c111221e7 --- /dev/null +++ b/examples/passing/ModuleExportQualified/A.purs @@ -0,0 +1,3 @@ +module A (module Prelude) where + +import Prelude diff --git a/examples/passing/ModuleExportSelf.purs b/examples/passing/ModuleExportSelf.purs index c5001c8bae..5063d2bb04 100644 --- a/examples/passing/ModuleExportSelf.purs +++ b/examples/passing/ModuleExportSelf.purs @@ -1,15 +1,11 @@ -module A (module A, module Prelude) where - import Prelude - - type Foo = Boolean - module Main where - import Control.Monad.Eff.Console - import A - bar :: Foo - bar = true +import Control.Monad.Eff.Console +import A + +bar :: Foo +bar = true - main = do - logShow (show bar) - log "Done" +main = do + logShow (show bar) + log "Done" diff --git a/examples/passing/ModuleExportSelf/A.purs b/examples/passing/ModuleExportSelf/A.purs new file mode 100644 index 0000000000..f6c2ecf5a3 --- /dev/null +++ b/examples/passing/ModuleExportSelf/A.purs @@ -0,0 +1,5 @@ +module A (module A, module Prelude) where + +import Prelude + +type Foo = Boolean diff --git a/examples/passing/NonConflictingExports.purs b/examples/passing/NonConflictingExports.purs index 9dff502541..901e1f79c3 100644 --- a/examples/passing/NonConflictingExports.purs +++ b/examples/passing/NonConflictingExports.purs @@ -1,8 +1,3 @@ -module A where - - thing :: Int - thing = 1 - -- No failure here as the export `thing` only refers to Main.thing module Main (thing, main) where diff --git a/examples/passing/NonConflictingExports/A.purs b/examples/passing/NonConflictingExports/A.purs new file mode 100644 index 0000000000..302b0328d1 --- /dev/null +++ b/examples/passing/NonConflictingExports/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/passing/OperatorAliasElsewhere.purs b/examples/passing/OperatorAliasElsewhere.purs index 952fa83093..34d294a5bc 100644 --- a/examples/passing/OperatorAliasElsewhere.purs +++ b/examples/passing/OperatorAliasElsewhere.purs @@ -1,8 +1,3 @@ -module Def where - -what :: forall a b. a -> b -> a -what a _ = a - module Main where import Prelude diff --git a/examples/passing/OperatorAliasElsewhere/Def.purs b/examples/passing/OperatorAliasElsewhere/Def.purs new file mode 100644 index 0000000000..85194c6fee --- /dev/null +++ b/examples/passing/OperatorAliasElsewhere/Def.purs @@ -0,0 +1,4 @@ +module Def where + +what :: forall a b. a -> b -> a +what a _ = a diff --git a/examples/passing/PendingConflictingImports.purs b/examples/passing/PendingConflictingImports.purs index 942ed42342..1f6a6dadf8 100644 --- a/examples/passing/PendingConflictingImports.purs +++ b/examples/passing/PendingConflictingImports.purs @@ -1,17 +1,7 @@ -module A where - - thing :: Int - thing = 1 - -module B where - - thing :: Int - thing = 2 - module Main where - -- No error as we never force `thing` to be resolved in `Main` - import A - import B +-- No error as we never force `thing` to be resolved in `Main` +import A +import B - main = Control.Monad.Eff.Console.log "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/PendingConflictingImports/A.purs b/examples/passing/PendingConflictingImports/A.purs new file mode 100644 index 0000000000..302b0328d1 --- /dev/null +++ b/examples/passing/PendingConflictingImports/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/passing/PendingConflictingImports/B.purs b/examples/passing/PendingConflictingImports/B.purs new file mode 100644 index 0000000000..076bf7ea52 --- /dev/null +++ b/examples/passing/PendingConflictingImports/B.purs @@ -0,0 +1,4 @@ +module B where + +thing :: Int +thing = 2 diff --git a/examples/passing/PendingConflictingImports2.purs b/examples/passing/PendingConflictingImports2.purs index f578dde132..5df6426d8e 100644 --- a/examples/passing/PendingConflictingImports2.purs +++ b/examples/passing/PendingConflictingImports2.purs @@ -1,8 +1,3 @@ -module A where - - thing :: Int - thing = 1 - module Main where import A diff --git a/examples/passing/PendingConflictingImports2/A.purs b/examples/passing/PendingConflictingImports2/A.purs new file mode 100644 index 0000000000..302b0328d1 --- /dev/null +++ b/examples/passing/PendingConflictingImports2/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/passing/QualifiedNames.purs b/examples/passing/QualifiedNames.purs new file mode 100644 index 0000000000..ff27b6df2f --- /dev/null +++ b/examples/passing/QualifiedNames.purs @@ -0,0 +1,9 @@ +module Main where + +import Prelude + +either :: forall a b c. (a -> c) -> (b -> c) -> Either.Either a b -> c +either f _ (Either.Left x) = f x +either _ g (Either.Right y) = g y + +main = Control.Monad.Eff.Console.log (either id id (Either.Left "Done")) diff --git a/examples/passing/QualifiedNames/Either.purs b/examples/passing/QualifiedNames/Either.purs new file mode 100644 index 0000000000..9fc8a3b473 --- /dev/null +++ b/examples/passing/QualifiedNames/Either.purs @@ -0,0 +1,5 @@ +module Either where + +import Prelude + +data Either a b = Left a | Right b diff --git a/examples/passing/ReExportQualified.purs b/examples/passing/ReExportQualified.purs index f74d4102b2..dcab96800f 100644 --- a/examples/passing/ReExportQualified.purs +++ b/examples/passing/ReExportQualified.purs @@ -1,16 +1,6 @@ -module A where - x = "Do" - -module B where - y = "ne" - -module C (module A, module M2) where - import A - import B as M2 - module Main where - import Prelude - import C +import Prelude +import C - main = Control.Monad.Eff.Console.log (x <> y) +main = Control.Monad.Eff.Console.log (x <> y) diff --git a/examples/passing/ReExportQualified/A.purs b/examples/passing/ReExportQualified/A.purs new file mode 100644 index 0000000000..ae231283aa --- /dev/null +++ b/examples/passing/ReExportQualified/A.purs @@ -0,0 +1,3 @@ +module A where + +x = "Do" diff --git a/examples/passing/ReExportQualified/B.purs b/examples/passing/ReExportQualified/B.purs new file mode 100644 index 0000000000..2e149222f4 --- /dev/null +++ b/examples/passing/ReExportQualified/B.purs @@ -0,0 +1,3 @@ +module B where + +y = "ne" diff --git a/examples/passing/ReExportQualified/C.purs b/examples/passing/ReExportQualified/C.purs new file mode 100644 index 0000000000..589f37bc43 --- /dev/null +++ b/examples/passing/ReExportQualified/C.purs @@ -0,0 +1,4 @@ +module C (module A, module M2) where + +import A +import B as M2 diff --git a/examples/passing/RedefinedFixity.purs b/examples/passing/RedefinedFixity.purs new file mode 100644 index 0000000000..762548c3bf --- /dev/null +++ b/examples/passing/RedefinedFixity.purs @@ -0,0 +1,5 @@ +module Main where + +import M3 + +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/RedefinedFixity/M1.purs b/examples/passing/RedefinedFixity/M1.purs new file mode 100644 index 0000000000..2d6fc3da7f --- /dev/null +++ b/examples/passing/RedefinedFixity/M1.purs @@ -0,0 +1,7 @@ +module M1 where + +import Prelude () + +($) f a = f a + +infixr 1000 $ diff --git a/examples/passing/RedefinedFixity/M2.purs b/examples/passing/RedefinedFixity/M2.purs new file mode 100644 index 0000000000..cc5c1999eb --- /dev/null +++ b/examples/passing/RedefinedFixity/M2.purs @@ -0,0 +1,5 @@ +module M2 where + +import Prelude () + +import M1 diff --git a/examples/passing/RedefinedFixity/M3.purs b/examples/passing/RedefinedFixity/M3.purs new file mode 100644 index 0000000000..a7b0f39948 --- /dev/null +++ b/examples/passing/RedefinedFixity/M3.purs @@ -0,0 +1,6 @@ +module M3 where + +import Prelude () + +import M1 +import M2 diff --git a/examples/passing/ResolvableScopeConflict.purs b/examples/passing/ResolvableScopeConflict.purs index c187806772..f9772d233a 100644 --- a/examples/passing/ResolvableScopeConflict.purs +++ b/examples/passing/ResolvableScopeConflict.purs @@ -1,25 +1,12 @@ -module A where - - thing :: Int - thing = 1 - -module B where - - thing :: Int - thing = 2 - - zing :: Int - zing = 3 - module Main where - import A (thing) - import B +import A (thing) +import B - -- Not an error as although we have `thing` in scope from both A and B, it is - -- imported explicitly from A, giving it a resolvable solution. - what :: Boolean -> Int - what true = thing - what false = zing +-- Not an error as although we have `thing` in scope from both A and B, it is +-- imported explicitly from A, giving it a resolvable solution. +what :: Boolean -> Int +what true = thing +what false = zing - main = Control.Monad.Eff.Console.log "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ResolvableScopeConflict/A.purs b/examples/passing/ResolvableScopeConflict/A.purs new file mode 100644 index 0000000000..302b0328d1 --- /dev/null +++ b/examples/passing/ResolvableScopeConflict/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/passing/ResolvableScopeConflict/B.purs b/examples/passing/ResolvableScopeConflict/B.purs new file mode 100644 index 0000000000..4ad4bb6f45 --- /dev/null +++ b/examples/passing/ResolvableScopeConflict/B.purs @@ -0,0 +1,7 @@ +module B where + +thing :: Int +thing = 2 + +zing :: Int +zing = 3 diff --git a/examples/passing/ResolvableScopeConflict2.purs b/examples/passing/ResolvableScopeConflict2.purs index 971e51b045..cb714e8dc0 100644 --- a/examples/passing/ResolvableScopeConflict2.purs +++ b/examples/passing/ResolvableScopeConflict2.purs @@ -1,22 +1,14 @@ -module A where - - thing :: Int - thing = 2 - - zing :: Int - zing = 3 - module Main where - import A +import A - thing :: Int - thing = 1 +thing :: Int +thing = 1 - -- Not an error as although we have `thing` in scope from both Main and A, - -- as the local declaration takes precedence over the implicit import - what :: Boolean -> Int - what true = thing - what false = zing +-- Not an error as although we have `thing` in scope from both Main and A, +-- as the local declaration takes precedence over the implicit import +what :: Boolean -> Int +what true = thing +what false = zing - main = Control.Monad.Eff.Console.log "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ResolvableScopeConflict2/A.purs b/examples/passing/ResolvableScopeConflict2/A.purs new file mode 100644 index 0000000000..943011cd7e --- /dev/null +++ b/examples/passing/ResolvableScopeConflict2/A.purs @@ -0,0 +1,7 @@ +module A where + +thing :: Int +thing = 2 + +zing :: Int +zing = 3 diff --git a/examples/passing/ResolvableScopeConflict3.purs b/examples/passing/ResolvableScopeConflict3.purs index 86a996b829..4b4c8a727a 100644 --- a/examples/passing/ResolvableScopeConflict3.purs +++ b/examples/passing/ResolvableScopeConflict3.purs @@ -1,15 +1,8 @@ -module A where - - thing :: Int - thing = 1 - module Main (thing, main, module A) where - import A - - thing :: Int - thing = 2 - - main = Control.Monad.Eff.Console.log "Done" +import A +thing :: Int +thing = 2 +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/ResolvableScopeConflict3/A.purs b/examples/passing/ResolvableScopeConflict3/A.purs new file mode 100644 index 0000000000..302b0328d1 --- /dev/null +++ b/examples/passing/ResolvableScopeConflict3/A.purs @@ -0,0 +1,4 @@ +module A where + +thing :: Int +thing = 1 diff --git a/examples/passing/ShadowedModuleName.purs b/examples/passing/ShadowedModuleName.purs index ac19774ce3..764b8c5327 100644 --- a/examples/passing/ShadowedModuleName.purs +++ b/examples/passing/ShadowedModuleName.purs @@ -1,15 +1,8 @@ -module Test where - - data Z = Z String - - runZ :: Z -> String - runZ (Z s) = s - module Main where - import Test - import Control.Monad.Eff.Console +import Test +import Control.Monad.Eff.Console - data Test = Test +data Test = Test - main = log (runZ (Z "Done")) +main = log (runZ (Z "Done")) diff --git a/examples/passing/ShadowedModuleName/Test.purs b/examples/passing/ShadowedModuleName/Test.purs new file mode 100644 index 0000000000..b30eb2dfd2 --- /dev/null +++ b/examples/passing/ShadowedModuleName/Test.purs @@ -0,0 +1,6 @@ +module Test where + +data Z = Z String + +runZ :: Z -> String +runZ (Z s) = s diff --git a/examples/manual/passing/ShadowedName.purs b/examples/passing/ShadowedName.purs similarity index 95% rename from examples/manual/passing/ShadowedName.purs rename to examples/passing/ShadowedName.purs index b0ae4d2ed5..8238d81570 100644 --- a/examples/manual/passing/ShadowedName.purs +++ b/examples/passing/ShadowedName.purs @@ -1,10 +1,10 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console - -done :: String -done = let str = "Not yet done" in - let str = "Done" in str - -main = Control.Monad.Eff.Console.log done +module Main where + +import Prelude +import Control.Monad.Eff.Console + +done :: String +done = let str = "Not yet done" in + let str = "Done" in str + +main = Control.Monad.Eff.Console.log done diff --git a/examples/passing/TransitiveImport.purs b/examples/passing/TransitiveImport.purs new file mode 100644 index 0000000000..04e00d3116 --- /dev/null +++ b/examples/passing/TransitiveImport.purs @@ -0,0 +1,9 @@ +module Main where + + import Prelude + import Middle + import Control.Monad.Eff.Console + + main = do + logShow (middle unit) + log "Done" diff --git a/examples/passing/TransitiveImport/Middle.purs b/examples/passing/TransitiveImport/Middle.purs new file mode 100644 index 0000000000..3ad1161ac2 --- /dev/null +++ b/examples/passing/TransitiveImport/Middle.purs @@ -0,0 +1,3 @@ +module Middle where + +middle = Test.test diff --git a/examples/passing/TransitiveImport/Test.purs b/examples/passing/TransitiveImport/Test.purs new file mode 100644 index 0000000000..cd06ec2a1e --- /dev/null +++ b/examples/passing/TransitiveImport/Test.purs @@ -0,0 +1,9 @@ +module Test where + +import Prelude + +class TestCls a where + test :: a -> a + +instance unitTestCls :: TestCls Unit where + test _ = unit diff --git a/examples/passing/TypeOperators.purs b/examples/passing/TypeOperators.purs index 72bd70b6db..1df4e1d2ea 100644 --- a/examples/passing/TypeOperators.purs +++ b/examples/passing/TypeOperators.purs @@ -1,34 +1,11 @@ -module A - ( Tuple(..) - , type (/\) - , (/\) - , Natural - , type (~>) - ) where - - data Tuple a b = Tuple a b - - infixl 6 Tuple as /\ - infixl 6 type Tuple as /\ - - type Natural f g = ∀ a. f a → g a - - infixr 0 type Natural as ~> - - tup ∷ ∀ a b. a → b → b /\ a - tup a b = b /\ a - - tupX ∷ ∀ a b c. a /\ b /\ c → c - tupX (a /\ b /\ c) = c - module Main where - import A (type (~>), type (/\), (/\)) +import A (type (~>), type (/\), (/\)) - natty ∷ ∀ f. f ~> f - natty x = x +natty ∷ ∀ f. f ~> f +natty x = x - swap ∷ ∀ a b. a /\ b → b /\ a - swap (a /\ b) = b /\ a +swap ∷ ∀ a b. a /\ b → b /\ a +swap (a /\ b) = b /\ a - main = Control.Monad.Eff.Console.log "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/TypeOperators/A.purs b/examples/passing/TypeOperators/A.purs new file mode 100644 index 0000000000..1c1fe8bf30 --- /dev/null +++ b/examples/passing/TypeOperators/A.purs @@ -0,0 +1,22 @@ +module A +( Tuple(..) +, type (/\) +, (/\) +, Natural +, type (~>) +) where + +data Tuple a b = Tuple a b + +infixl 6 Tuple as /\ +infixl 6 type Tuple as /\ + +type Natural f g = ∀ a. f a → g a + +infixr 0 type Natural as ~> + +tup ∷ ∀ a b. a → b → b /\ a +tup a b = b /\ a + +tupX ∷ ∀ a b c. a /\ b /\ c → c +tupX (a /\ b /\ c) = c diff --git a/examples/passing/TypeWithoutParens.purs b/examples/passing/TypeWithoutParens.purs index 4aca41368f..7cef2b5657 100644 --- a/examples/passing/TypeWithoutParens.purs +++ b/examples/passing/TypeWithoutParens.purs @@ -1,16 +1,11 @@ -module Lib (X, Y) where - - data X = X - type Y = X - module Main where - import Lib (X, Y) +import Lib (X, Y) - idX :: X -> X - idX x = x +idX :: X -> X +idX x = x - idY :: Y -> Y - idY y = y +idY :: Y -> Y +idY y = y - main = Control.Monad.Eff.Console.log "Done" +main = Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/TypeWithoutParens/Lib.purs b/examples/passing/TypeWithoutParens/Lib.purs new file mode 100644 index 0000000000..95b9a090fe --- /dev/null +++ b/examples/passing/TypeWithoutParens/Lib.purs @@ -0,0 +1,4 @@ +module Lib (X, Y) where + +data X = X +type Y = X diff --git a/examples/manual/passing/WildcardType.purs b/examples/passing/WildcardType.purs similarity index 93% rename from examples/manual/passing/WildcardType.purs rename to examples/passing/WildcardType.purs index 557500e9de..42a4b9296a 100644 --- a/examples/manual/passing/WildcardType.purs +++ b/examples/passing/WildcardType.purs @@ -1,13 +1,13 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console - -f1 :: (_ -> _) -> _ -f1 g = g 1 - -f2 :: _ -> _ -f2 _ = "Done" - -main = Control.Monad.Eff.Console.log $ f1 f2 - +module Main where + +import Prelude +import Control.Monad.Eff.Console + +f1 :: (_ -> _) -> _ +f1 g = g 1 + +f2 :: _ -> _ +f2 _ = "Done" + +main = Control.Monad.Eff.Console.log $ f1 f2 + diff --git a/purescript.cabal b/purescript.cabal index e53c87b1a9..2b4bd4e247 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -20,7 +20,52 @@ author: Phil Freeman , tested-with: GHC==7.10.3 extra-source-files: examples/passing/*.purs + , examples/passing/2018/*.purs + , examples/passing/ClassRefSyntax/*.purs + , examples/passing/DctorOperatorAlias/*.purs + , examples/passing/ExplicitImportReExport/*.purs + , examples/passing/ExportExplicit/*.purs + , examples/passing/ExportExplicit2/*.purs + , examples/passing/Import/*.purs + , examples/passing/ImportExplicit/*.purs + , examples/passing/ImportQualified/*.purs + , examples/passing/Module/*.purs + , examples/passing/ModuleDeps/*.purs + , examples/passing/ModuleExport/*.purs + , examples/passing/ModuleExportDupes/*.purs + , examples/passing/ModuleExportExcluded/*.purs + , examples/passing/ModuleExportQualified/*.purs + , examples/passing/ModuleExportSelf/*.purs + , examples/passing/NonConflictingExports/*.purs + , examples/passing/OperatorAliasElsewhere/*.purs + , examples/passing/PendingConflictingImports/*.purs + , examples/passing/PendingConflictingImports2/*.purs + , examples/passing/QualifiedNames/*.purs + , examples/passing/RedefinedFixity/*.purs + , examples/passing/ReExportQualified/*.purs + , examples/passing/ResolvableScopeConflict/*.purs + , examples/passing/ResolvableScopeConflict2/*.purs + , examples/passing/ResolvableScopeConflict3/*.purs + , examples/passing/ShadowedModuleName/*.purs + , examples/passing/TransitiveImport/*.purs + , examples/passing/TypeOperators/*.purs + , examples/passing/TypeWithoutParens/*.purs , examples/failing/*.purs + , examples/failing/1733/*.purs + , examples/failing/ConflictingExports/*.purs + , examples/failing/ConflictingImports/*.purs + , examples/failing/ConflictingImports2/*.purs + , examples/failing/ConflictingQualifiedImports/*.purs + , examples/failing/ConflictingQualifiedImports2/*.purs + , examples/failing/ExportExplicit1/*.purs + , examples/failing/ExportExplicit3/*.purs + , examples/failing/ImportExplicit/*.purs + , examples/failing/ImportExplicit2/*.purs + , examples/failing/ImportHidingModule/*.purs + , examples/failing/ImportModule/*.purs + , examples/failing/InstanceExport/*.purs + , examples/failing/OrphanInstance/*.purs + , examples/failing/OverlappingReExport/*.purs , examples/docs/bower_components/purescript-prelude/src/*.purs , examples/docs/bower.json , examples/docs/src/*.purs diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index c5b7e60dae..85a2e63394 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -26,8 +26,9 @@ import Prelude.Compat import qualified Language.PureScript as P import Data.Char (isSpace) +import Data.Function (on) +import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, partition) import Data.Maybe (mapMaybe) -import Data.List (isSuffixOf, sort, stripPrefix, intercalate) import Data.Time.Clock (UTCTime()) import qualified Data.Map as M @@ -55,39 +56,75 @@ main = hspec spec spec :: Spec spec = do - (supportPurs, foreigns, passing, passingTestCases, failing, failingTestCases) <- runIO $ do - cwd <- getCurrentDirectory - - let supportDir = cwd "tests" "support" "bower_components" - let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir - - supportPurs <- supportFiles "purs" - supportJS <- supportFiles "js" - - foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f) - Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles + (supportPurs, supportForeigns, passingTestCases, failingTestCases) <- runIO $ do + cwd <- getCurrentDirectory let passing = cwd "examples" "passing" - passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passing - let failing = cwd "examples" "failing" - failingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents failing - - return (supportPurs, foreigns, passing, passingTestCases, failing, failingTestCases) + let supportDir = cwd "tests" "support" "bower_components" + let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir + passingFiles <- getTestFiles passing <$> testGlob passing + failingFiles <- getTestFiles failing <$> testGlob failing + supportPurs <- supportFiles "purs" + supportForeigns <- loadForeigns =<< supportFiles "js" + return (supportPurs, supportForeigns, passingFiles, failingFiles) context ("Passing examples") $ do - forM_ passingTestCases $ \inputFile -> - it ("'" <> inputFile <> "' should compile and run without error") $ do - assertCompiles (supportPurs ++ [passing inputFile]) foreigns + forM_ passingTestCases $ \(testPurs, testJS) -> + it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ do + testForeigns <- loadForeigns testJS + assertCompiles (supportPurs ++ testPurs) (supportForeigns <> testForeigns) context ("Failing examples") $ do - forM_ failingTestCases $ \inputFile -> do - expectedFailures <- runIO $ getShouldFailWith (failing inputFile) - it ("'" <> inputFile <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do - assertDoesNotCompile (supportPurs ++ [failing inputFile]) foreigns expectedFailures + forM_ failingTestCases $ \(testPurs, testJS) -> do + let mainPath = getTestMain testPurs + expectedFailures <- runIO $ getShouldFailWith mainPath + it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do + testForeigns <- loadForeigns testJS + assertDoesNotCompile (supportPurs ++ testPurs) (supportForeigns <> testForeigns) expectedFailures where + -- A glob for all purs and js files within a test directory + testGlob :: FilePath -> IO [FilePath] + testGlob dir = join . fst <$> Glob.globDir (map Glob.compile ["**/*.purs", "**/*.js"]) dir + + -- Loads foreign modules from source files + loadForeigns :: [FilePath] -> IO (M.Map P.ModuleName FilePath) + loadForeigns paths = do + files <- forM paths (\f -> (f,) <$> readUTF8File f) + Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles files + return foreigns + + -- Groups the test files so that a top-level file can have dependencies in a + -- subdirectory of the same name. The inner tuple contains a list of the + -- .purs files and the .js files for the test case. + getTestFiles :: FilePath -> [FilePath] -> [([FilePath], [FilePath])] + getTestFiles baseDir + = map (partition ((== ".purs") . takeExtensions)) + . map (map (baseDir )) + . groupBy ((==) `on` extractPrefix) + . sortBy (compare `on` extractPrefix) + . map (makeRelative baseDir) + + -- Takes the test entry point from a group of purs files - this is determined + -- by the file with the shortest path name, as everything but the main file + -- will be under a subdirectory. + getTestMain :: [FilePath] -> FilePath + getTestMain = head . sortBy (compare `on` length) + + -- Extracts the filename part of a .purs file, or if the file is in a + -- subdirectory, the first part of that directory path. + extractPrefix :: FilePath -> FilePath + extractPrefix fp = + let dir = takeDirectory fp + ext = reverse ".purs" + in if dir == "." + then maybe fp reverse $ stripPrefix ext $ reverse fp + else dir + + -- Scans a file for @shouldFailWith directives in the comments, used to + -- determine expected failures getShouldFailWith :: FilePath -> IO [String] getShouldFailWith = fmap extractFailWiths . readUTF8File where From 0e7c9369cc1ed4c4fe973e3c4f2497a019a0f751 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 5 May 2016 08:59:36 -0700 Subject: [PATCH 0401/1580] Require Partial instance on partial functions (#2072) * Error on missing Partial constraint * Fix tests * Propagate binder information in constraint * Fix compiler warning * Fix test suite * Comments, pattern synonyms * Fix tests --- examples/passing/1991.purs | 1 + examples/passing/2049.purs | 1 + examples/passing/BindersInFunctions.purs | 8 +- examples/passing/CaseInDo.purs | 2 + examples/passing/CaseMultipleExpressions.purs | 2 + examples/passing/EmptyTypeClass.purs | 11 +- examples/passing/Let.purs | 9 +- examples/passing/PartialFunction.purs | 24 ++- examples/passing/ReservedWords.purs | 3 + examples/passing/ShadowedTCOLet.purs | 5 +- examples/passing/UnderscoreIdent.purs | 1 + examples/passing/Where.purs | 5 +- hierarchy/Main.hs | 3 +- psci/PSCi/Printer.hs | 2 +- src/Language/PureScript/AST/Exported.hs | 2 +- src/Language/PureScript/AST/Traversals.hs | 6 +- src/Language/PureScript/Constants.hs | 17 +- .../PureScript/Docs/Convert/ReExports.hs | 2 +- src/Language/PureScript/Docs/Render.hs | 2 +- .../PureScript/Docs/RenderedCode/Render.hs | 2 +- src/Language/PureScript/Docs/Types.hs | 5 +- src/Language/PureScript/Errors.hs | 30 ++-- src/Language/PureScript/Linter/Exhaustive.hs | 152 ++++++++++-------- src/Language/PureScript/Make.hs | 3 +- .../PureScript/Parser/Declarations.hs | 4 +- src/Language/PureScript/Parser/Types.hs | 2 +- src/Language/PureScript/Pretty/Types.hs | 4 +- src/Language/PureScript/Pretty/Values.hs | 3 +- .../PureScript/Sugar/BindingGroups.hs | 2 +- src/Language/PureScript/Sugar/Names.hs | 5 +- src/Language/PureScript/Sugar/Operators.hs | 8 +- src/Language/PureScript/Sugar/TypeClasses.hs | 11 +- src/Language/PureScript/TypeChecker.hs | 36 +++-- .../PureScript/TypeChecker/Entailment.hs | 19 ++- src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- src/Language/PureScript/TypeChecker/Rows.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 22 +-- src/Language/PureScript/Types.hs | 49 ++++-- tests/TestCompiler.hs | 2 +- tests/TestDocs.hs | 2 +- tests/TestUtils.hs | 2 + tests/support/bower.json | 3 +- 42 files changed, 284 insertions(+), 192 deletions(-) diff --git a/examples/passing/1991.purs b/examples/passing/1991.purs index 96738faf9a..9418d539ea 100644 --- a/examples/passing/1991.purs +++ b/examples/passing/1991.purs @@ -10,6 +10,7 @@ empty = [] foldMap :: forall a m. (Semigroup m) => (a -> m) -> Array a -> m foldMap f [a, b, c, d, e] = f a <> f b <> f c <> f d <> f e +foldMap f xs = foldMap f xs -- spin, not used regression :: Array Int regression = diff --git a/examples/passing/2049.purs b/examples/passing/2049.purs index 24186f44b1..2e44907962 100644 --- a/examples/passing/2049.purs +++ b/examples/passing/2049.purs @@ -9,5 +9,6 @@ infixr 6 Cons as : f :: List { x :: Int, y :: Int } -> Int f ( r@{ x } : _) = x + r.y +f _ = 0 main = log "Done" diff --git a/examples/passing/BindersInFunctions.purs b/examples/passing/BindersInFunctions.purs index d1a504bf06..dd4320d1d4 100644 --- a/examples/passing/BindersInFunctions.purs +++ b/examples/passing/BindersInFunctions.purs @@ -1,11 +1,15 @@ module Main where import Prelude -import Test.Assert +import Partial.Unsafe (unsafePartial) +import Test.Assert (assert') +import Control.Monad.Eff (Eff) +snd :: forall a. Partial => Array a -> a snd = \[_, y] -> y +main :: Eff _ _ main = do - let ts = snd [1.0, 2.0] + let ts = unsafePartial (snd [1.0, 2.0]) assert' "Incorrect result from 'snd'." (ts == 2.0) Control.Monad.Eff.Console.log "Done" diff --git a/examples/passing/CaseInDo.purs b/examples/passing/CaseInDo.purs index 9282c7a130..48716f4854 100644 --- a/examples/passing/CaseInDo.purs +++ b/examples/passing/CaseInDo.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Partial.Unsafe (unsafeCrashWith) import Control.Monad.Eff.Console import Control.Monad.Eff @@ -17,3 +18,4 @@ main = do b <- set case b of true -> log "Done" + false -> unsafeCrashWith "Failed" diff --git a/examples/passing/CaseMultipleExpressions.purs b/examples/passing/CaseMultipleExpressions.purs index 40b0d30b87..d434e56de7 100644 --- a/examples/passing/CaseMultipleExpressions.purs +++ b/examples/passing/CaseMultipleExpressions.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Partial.Unsafe (unsafeCrashWith) import Control.Monad.Eff.Console import Control.Monad.Eff @@ -17,3 +18,4 @@ main = do b <- set case b of true -> log "Done" + false -> unsafeCrashWith "Failed" diff --git a/examples/passing/EmptyTypeClass.purs b/examples/passing/EmptyTypeClass.purs index 065a829f82..88180496c5 100644 --- a/examples/passing/EmptyTypeClass.purs +++ b/examples/passing/EmptyTypeClass.purs @@ -1,12 +1,11 @@ module Main where import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console -class PartialP - -head :: forall a. (PartialP) => Array a -> a +head :: forall a. Partial => Array a -> a head [x] = x -instance allowPartials :: PartialP - -main = Control.Monad.Eff.Console.log $ head ["Done"] +main :: Eff _ _ +main = log "Done" diff --git a/examples/passing/Let.purs b/examples/passing/Let.purs index d7a1b5bf05..793dac0e17 100644 --- a/examples/passing/Let.purs +++ b/examples/passing/Let.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Partial.Unsafe (unsafePartial) import Control.Monad.Eff import Control.Monad.Eff.Console (log, logShow) import Control.Monad.ST @@ -18,8 +19,9 @@ test2 x y = test3 = let f x y z = x + y + z in f 1.0 2.0 3.0 -test4 = let f x [y, z] = x y z in - f (+) [1.0, 2.0] +test4 = let + f x [y, z] = x y z + in f (+) [1.0, 2.0] test5 = let f x | x > 0.0 = g (x / 2.0) + 1.0 @@ -44,11 +46,12 @@ test10 _ = g x = f x / 2.0 in f 10.0 +main :: Eff _ _ main = do logShow (test1 1.0) logShow (test2 1.0 2.0) logShow test3 - logShow test4 + unsafePartial (logShow test4) logShow test5 logShow test7 logShow (test8 100.0) diff --git a/examples/passing/PartialFunction.purs b/examples/passing/PartialFunction.purs index 45ba7657bf..00a1f026de 100644 --- a/examples/passing/PartialFunction.purs +++ b/examples/passing/PartialFunction.purs @@ -1,13 +1,11 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console (log) -import Test.Assert (assertThrows) - -fn :: Number -> Number -fn 0.0 = 0.0 -fn 1.0 = 2.0 - -main = do - assertThrows $ \_ -> fn 2.0 - log "Done" +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console + +fn :: Partial => Number -> Number +fn 0.0 = 0.0 +fn 1.0 = 2.0 + +main = log "Done" diff --git a/examples/passing/ReservedWords.purs b/examples/passing/ReservedWords.purs index ff233bf2e4..b7ffdfbe33 100644 --- a/examples/passing/ReservedWords.purs +++ b/examples/passing/ReservedWords.purs @@ -2,6 +2,7 @@ module Main where import Prelude +import Control.Monad.Eff o :: { type :: String } o = { type: "o" } @@ -11,5 +12,7 @@ p = o { type = "p" } f :: forall r. { type :: String | r } -> String f { type = "p" } = "Done" +f _ = "Fail" +main :: Eff _ _ main = Control.Monad.Eff.Console.log $ f { type: p.type, foo: "bar" } diff --git a/examples/passing/ShadowedTCOLet.purs b/examples/passing/ShadowedTCOLet.purs index 38eb7739eb..3b04ec6eda 100644 --- a/examples/passing/ShadowedTCOLet.purs +++ b/examples/passing/ShadowedTCOLet.purs @@ -1,12 +1,15 @@ module Main where import Prelude +import Partial.Unsafe (unsafePartial) +import Control.Monad.Eff import Control.Monad.Eff.Console (log) f x y z = let f 1.0 2.0 3.0 = 1.0 in f x z y +main :: Eff _ _ main = do - log $ show $ f 1.0 3.0 2.0 + log $ show $ unsafePartial f 1.0 3.0 2.0 log "Done" diff --git a/examples/passing/UnderscoreIdent.purs b/examples/passing/UnderscoreIdent.purs index 318bda34c8..4d0bcb916c 100644 --- a/examples/passing/UnderscoreIdent.purs +++ b/examples/passing/UnderscoreIdent.purs @@ -7,5 +7,6 @@ data Data_type = Con_Structor | Con_2 String type Type_name = Data_type done (Con_2 s) = s +done _ = "Failed" main = Control.Monad.Eff.Console.log (done (Con_2 "Done")) diff --git a/examples/passing/Where.purs b/examples/passing/Where.purs index 7aae7fcb79..fa9169db8c 100644 --- a/examples/passing/Where.purs +++ b/examples/passing/Where.purs @@ -1,6 +1,8 @@ module Main where import Prelude +import Partial.Unsafe (unsafePartial) +import Control.Monad.Eff import Control.Monad.Eff.Console (logShow, log) test1 x = y @@ -35,11 +37,12 @@ test7 x = go x go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y go y = go $ (y + x / y) / 2.0 +main :: Eff _ _ main = do logShow (test1 1.0) logShow (test2 1.0 2.0) logShow test3 - logShow test4 + unsafePartial (logShow test4) logShow test5 logShow test6 logShow (test7 100.0) diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs index adc3de057a..2ab5919b47 100644 --- a/hierarchy/Main.hs +++ b/hierarchy/Main.hs @@ -84,7 +84,7 @@ compile (HierarchyOptions inputGlob mOutput) = do superClasses :: P.Declaration -> [SuperMap] superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) = - fmap (\(P.Qualified _ super, _) -> SuperMap (Right (super, sub))) supers + fmap (\(P.Constraint (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)] superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl superClasses _ = [] @@ -113,4 +113,3 @@ main = execParser opts >>= compile infoModList = fullDesc <> headerInfo <> footerInfo headerInfo = header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses" footerInfo = footer $ "hierarchy " ++ showVersion Paths.version - diff --git a/psci/PSCi/Printer.hs b/psci/PSCi/Printer.hs index 1d128eb5b2..2c12ac4ce5 100644 --- a/psci/PSCi/Printer.hs +++ b/psci/PSCi/Printer.hs @@ -58,7 +58,7 @@ printModuleSignatures moduleName (P.Environment {..}) = if null constrs then Box.text "" else Box.text "(" - Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs) + Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint (P.Qualified _ pn) lt _) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs) Box.<> Box.text ") <= " className = Box.text (P.runProperName name) diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index edb0ec3708..5f402dfa39 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -99,7 +99,7 @@ typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys) where - fromConstraint (name, tys') = Left name : concatMap fromType tys' + fromConstraint c = Left (constraintClass c) : concatMap fromType (constraintArgs c) fromType = everythingOnTypes (++) go -- Note that type synonyms are disallowed in instance declarations, so diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index c9264845ab..459cda1d46 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -579,13 +579,13 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con where forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors) forDecls (ExternDeclaration _ ty) = f ty - forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies) - forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys) + forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . constraintArgs) implies) + forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . constraintArgs) cs) `mappend` mconcat (map f tys) forDecls (TypeSynonymDeclaration _ _ ty) = f ty forDecls (TypeDeclaration _ ty) = f ty forDecls _ = mempty - forValues (TypeClassDictionary (_, cs) _) = mconcat (map f cs) + forValues (TypeClassDictionary c _) = mconcat (map f (constraintArgs c)) forValues (SuperClassDictionary _ tys) = mconcat (map f tys) forValues (TypedValue _ _ ty) = f ty forValues _ = mempty diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 15c19c2f78..6f4567e7c7 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -1,8 +1,11 @@ --- | --- Various constants which refer to things in the Prelude --- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Various constants which refer to things in the Prelude module Language.PureScript.Constants where +import Language.PureScript.Names + -- Operators ($) :: String @@ -317,6 +320,14 @@ toSignature = "toSignature" main :: String main = "main" +-- Prim + +partial :: String +partial = "Partial" + +pattern Partial :: Qualified (ProperName 'ClassName) +pattern Partial = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Partial") + -- Code Generation __superclass_ :: String diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index a6b54f1485..f24a45ebef 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -489,7 +489,7 @@ typeClassConstraintFor :: Declaration -> Maybe P.Constraint typeClassConstraintFor Declaration{..} = case declInfo of TypeClassDeclaration tyArgs _ -> - Just (P.Qualified Nothing (P.ProperName declTitle), mkConstraint tyArgs) + Just (P.Constraint (P.Qualified Nothing (P.ProperName declTitle)) (mkConstraint tyArgs) Nothing) _ -> Nothing where diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 9ac9a4e239..17dc3c2f4e 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -107,7 +107,7 @@ renderConstraint :: P.Constraint -> RenderedCode renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions renderConstraintWithOptions :: RenderTypeOptions -> P.Constraint -> RenderedCode -renderConstraintWithOptions opts (pn, tys) = +renderConstraintWithOptions opts (P.Constraint pn tys _) = renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName pn)) tys renderConstraints :: [P.Constraint] -> Maybe RenderedCode diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index 48d1ad81bc..55413b8cf6 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -56,7 +56,7 @@ typeLiterals = mkPattern match Nothing renderConstraint :: Constraint -> RenderedCode -renderConstraint (pn, tys) = +renderConstraint (Constraint pn tys _) = let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys in renderType instApp diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index ea09893a5e..f1e11151dc 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -465,8 +465,9 @@ asSourcePos = P.SourcePos <$> nth 0 asIntegral <*> nth 1 asIntegral asConstraint :: Parse PackageError P.Constraint -asConstraint = (,) <$> nth 0 asQualifiedProperName - <*> nth 1 (eachInArray asType) +asConstraint = P.Constraint <$> key "constraintClass" asQualifiedProperName + <*> key "constraintArgs" (eachInArray asType) + <*> pure Nothing asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a)) asQualifiedProperName = fromAesonParser diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 521a0f3793..063e6c8af7 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -29,6 +29,7 @@ import Language.PureScript.Pretty import Language.PureScript.Types import Language.PureScript.Names import Language.PureScript.Kinds +import qualified Language.PureScript.Constants as C import qualified Language.PureScript.Bundle as Bundle import qualified Text.PrettyPrint.Boxes as Box @@ -102,7 +103,7 @@ data SimpleErrorMessage | KindsDoNotUnify Kind Kind | ConstrainedTypeUnified Type Type | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident] - | NoInstanceFound (Qualified (ProperName 'ClassName)) [Type] + | NoInstanceFound Constraint | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type] | CannotDerive (Qualified (ProperName 'ClassName)) [Type] | CannotFindDerivingType (ProperName 'TypeName) @@ -130,7 +131,6 @@ data SimpleErrorMessage | WildcardInferredType Type | HoleInferredType String Type | MissingTypeDeclaration Ident Type - | NotExhaustivePattern [[Binder]] Bool | OverlappingPattern [[Binder]] Bool | IncompleteExhaustivityCheck | ClassOperator (ProperName 'ClassName) Ident @@ -315,7 +315,6 @@ errorCode em = case unwrapErrorMessage em of WildcardInferredType{} -> "WildcardInferredType" HoleInferredType{} -> "HoleInferredType" MissingTypeDeclaration{} -> "MissingTypeDeclaration" - NotExhaustivePattern{} -> "NotExhaustivePattern" OverlappingPattern{} -> "OverlappingPattern" IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck" ClassOperator{} -> "ClassOperator" @@ -422,7 +421,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t - gSimple (NoInstanceFound cl ts) = NoInstanceFound cl <$> traverse f ts + gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts @@ -755,7 +754,18 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , line "They may be disallowed completely in a future version of the compiler." ] renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list" - renderSimpleErrorMessage (NoInstanceFound nm ts) = + renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial + _ + (Just (PartialConstraintData bs b)))) = + paras [ line "A case expression could not be determined to cover all inputs." + , line "The following additional cases are required to cover all inputs:\n" + , indent $ paras $ + Box.hsep 1 Box.left + (map (paras . map line) (transpose bs)) + : [line "..." | not b] + , line "Alternatively, add a Partial constraint to the type of the enclosing value." + ] + renderSimpleErrorMessage (NoInstanceFound (Constraint nm ts _)) = paras [ line "No type class instance was found for" , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) @@ -887,16 +897,6 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , line $ "The inferred type of " ++ showIdent ident ++ " was:" , indent $ typeAsBox ty ] - renderSimpleErrorMessage (NotExhaustivePattern bs b) = - paras [ line "A case expression could not be determined to cover all inputs." - , line "The following additional cases are required to cover all inputs:\n" - , indent $ paras $ - Box.hsep 1 Box.left - (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) - : [line "..." | not b] - , line "Or alternatively, add a Partial constraint to the type of the enclosing value." - , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9." - ] renderSimpleErrorMessage (OverlappingPattern bs b) = paras $ [ line "A case expression contains unreachable cases:\n" , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index ce43a9510c..a8ed8e2362 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -7,7 +7,9 @@ -- to bottom, where in each step it has the cases already missing (uncovered), -- and it generates the new set of missing cases. -- -module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where +module Language.PureScript.Linter.Exhaustive + ( checkExhaustiveExpr + ) where import Prelude () import Prelude.Compat @@ -23,12 +25,15 @@ import Control.Arrow (first, second) import Control.Monad.Writer.Class import Language.PureScript.Crash +import qualified Language.PureScript.Constants as C import Language.PureScript.AST.Binders import Language.PureScript.AST.Literals import Language.PureScript.AST.Declarations import Language.PureScript.Environment import Language.PureScript.Names as P import Language.PureScript.Kinds +import Language.PureScript.Pretty.Values (prettyPrintBinderAtom) +import Language.PureScript.Traversals import Language.PureScript.Types as P import Language.PureScript.Errors @@ -179,12 +184,11 @@ missingCasesSingle _ _ b _ = ([b], Left Unknown) missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool) missingCasesMultiple env mn = go where - go [] [] = ([], pure True) go (x:xs) (y:ys) = (map (: xs) miss1 ++ map (x :) miss2, liftA2 (&&) pr1 pr2) where (miss1, pr1) = missingCasesSingle env mn x y (miss2, pr2) = go xs ys - go _ _ = internalError "Argument lengths did not match in missingCasesMultiple." + go _ _ = ([], pure True) -- | -- Guard handling @@ -229,8 +233,16 @@ missingAlternative env mn ca uncovered -- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses. -- Then, returns the uncovered set of case alternatives. -- -checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m () -checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas +checkExhaustive + :: forall m + . (MonadWriter MultipleErrors m) + => Environment + -> ModuleName + -> Int + -> [CaseAlternative] + -> Expr + -> m Expr +checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas where step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]])) step (uncovered, (nec, redundant)) ca = @@ -246,69 +258,83 @@ checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ fold ) ) - makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m () + makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m Expr makeResult (bss, (rr, bss')) = - do unless (hasConstraint || null bss) tellNonExhaustive - unless (null bss') tellRedundant + do unless (null bss') tellRedundant case rr of - Left Incomplete -> unless hasConstraint tellIncomplete + Left Incomplete -> tellIncomplete _ -> return () + if null bss + then return expr + else return (addPartialConstraint (second null (splitAt 5 bss)) expr) where - tellNonExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss - tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss' - tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck - --- | --- Exhaustivity checking over a list of declarations --- -checkExhaustiveDecls :: forall m. MonadWriter MultipleErrors m => Environment -> ModuleName -> [Declaration] -> m () -checkExhaustiveDecls env mn = mapM_ onDecl - where - onDecl :: Declaration -> m () - onDecl (BindingGroupDeclaration bs) = mapM_ (onDecl . convert) bs - where - convert :: (Ident, NameKind, Expr) -> Declaration - convert (name, nk, e) = ValueDeclaration name nk [] (Right e) - onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr False e) - onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec) - onDecl _ = return () - - onExpr :: Bool -> Expr -> m () - onExpr isP (UnaryMinus e) = onExpr isP e - onExpr isP (Literal (ArrayLiteral es)) = mapM_ (onExpr isP) es - onExpr isP (Literal (ObjectLiteral es)) = mapM_ (onExpr isP . snd) es - onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e - onExpr isP (Accessor _ e) = onExpr isP e - onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es - onExpr isP (Abs _ e) = onExpr isP e - onExpr isP (App e1 e2) = onExpr isP e1 >> onExpr isP e2 - onExpr isP (IfThenElse e1 e2 e3) = onExpr isP e1 >> onExpr isP e2 >> onExpr isP e3 - onExpr isP (Case es cas) = checkExhaustive isP env mn (length es) cas >> mapM_ (onExpr isP) es >> mapM_ (onCaseAlternative isP) cas - onExpr isP (TypedValue _ e ty) = onExpr (isP || hasPartialConstraint ty) e - onExpr isP (Let ds e) = mapM_ onDecl ds >> onExpr isP e - onExpr isP (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr isP e) - onExpr _ _ = return () - - onCaseAlternative :: Bool -> CaseAlternative -> m () - onCaseAlternative isP (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr isP e >> onExpr isP g) es - onCaseAlternative isP (CaseAlternative _ (Right e)) = onExpr isP e - - hasPartialConstraint :: Type -> Bool - hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs + tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss' + tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck + + -- | We add a Partial constraint by adding a call to the following identity function: + -- + -- partial :: forall a. Partial => a -> a + -- + -- The binder information is provided so that it can be embedded in the constraint, + -- and then included in the error message. + addPartialConstraint :: ([[Binder]], Bool) -> Expr -> Expr + addPartialConstraint (bss, complete) e = + Let [ partial ] (App (Var (Qualified Nothing (Ident C.__unused))) e) where - go :: Qualified (ProperName 'ClassName) -> Bool - go qname - | qname == partialClass = True - | otherwise = - case qname `M.lookup` typeClasses env of - Just ([], _, cs') -> any (go . fst) cs' - _ -> False - partialClass :: Qualified (ProperName 'ClassName) - partialClass = primName "Partial" - hasPartialConstraint _ = False + partial :: Declaration + partial = ValueDeclaration (Ident C.__unused) + Private + [] + (Right (TypedValue True (Abs (Left (Ident "x")) + (Var (Qualified Nothing (Ident "x")))) + ty)) + + ty :: Type + ty = ForAll "a" (ConstrainedType [ Constraint (Qualified (Just (ModuleName [ProperName C.prim])) + (ProperName "Partial")) + [] + (Just (PartialConstraintData (map (map prettyPrintBinderAtom) bss) complete)) + ] + (TypeApp (TypeApp tyFunction (TypeVar "a")) + (TypeVar "a"))) + Nothing -- | --- Exhaustivity checking over a single module +-- Exhaustivity checking -- -checkExhaustiveModule :: forall m. MonadWriter MultipleErrors m => Environment -> Module -> m () -checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds +checkExhaustiveExpr + :: forall m + . MonadWriter MultipleErrors m + => Environment + -> ModuleName + -> Expr + -> m Expr +checkExhaustiveExpr env mn = onExpr + where + onDecl :: Declaration -> m Declaration + onDecl (BindingGroupDeclaration bs) = BindingGroupDeclaration <$> mapM (thirdM onExpr) bs + onDecl (ValueDeclaration name x y (Right e)) = ValueDeclaration name x y . Right <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr e) + onDecl (PositionedDeclaration pos x dec) = PositionedDeclaration pos x <$> censor (addHint (PositionedError pos)) (onDecl dec) + onDecl decl = return decl + + onExpr :: Expr -> m Expr + onExpr (UnaryMinus e) = UnaryMinus <$> onExpr e + onExpr (Literal (ArrayLiteral es)) = Literal . ArrayLiteral <$> mapM onExpr es + onExpr (Literal (ObjectLiteral es)) = Literal . ObjectLiteral <$> mapM (sndM onExpr) es + onExpr (TypeClassDictionaryConstructorApp x e) = TypeClassDictionaryConstructorApp x <$> onExpr e + onExpr (Accessor x e) = Accessor x <$> onExpr e + onExpr (ObjectUpdate o es) = ObjectUpdate <$> onExpr o <*> mapM (sndM onExpr) es + onExpr (Abs x e) = Abs x <$> onExpr e + onExpr (App e1 e2) = App <$> onExpr e1 <*> onExpr e2 + onExpr (IfThenElse e1 e2 e3) = IfThenElse <$> onExpr e1 <*> onExpr e2 <*> onExpr e3 + onExpr (Case es cas) = do + case' <- Case <$> mapM onExpr es <*> mapM onCaseAlternative cas + checkExhaustive env mn (length es) cas case' + onExpr (TypedValue x e y) = TypedValue x <$> onExpr e <*> pure y + onExpr (Let ds e) = Let <$> mapM onDecl ds <*> onExpr e + onExpr (PositionedValue pos x e) = PositionedValue pos x <$> censor (addHint (PositionedError pos)) (onExpr e) + onExpr expr = return expr + + onCaseAlternative :: CaseAlternative -> m CaseAlternative + onCaseAlternative (CaseAlternative x (Left es)) = CaseAlternative x . Left <$> mapM (\(e, g) -> (,) <$> onExpr e <*> onExpr g) es + onCaseAlternative (CaseAlternative x (Right e)) = CaseAlternative x . Right <$> onExpr e diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 52239c6454..1aa1187a87 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -158,10 +158,9 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do progress $ CompilingModule moduleName let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs lint m - ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do + ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do [desugared] <- desugar externs [m] runCheck' env $ typeCheckModule desugared - checkExhaustiveModule env' checked regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated let mod' = Module ss coms moduleName regrouped exps corefn = CF.moduleToCoreFn env' mod' diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 5189e29eeb..1368e1f58f 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -184,7 +184,9 @@ parseTypeClassDeclaration = do return $ TypeClassDeclaration className idents implies members parseConstraint :: TokenParser Constraint -parseConstraint = (,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom) +parseConstraint = Constraint <$> parseQualified properName + <*> P.many (noWildcards parseTypeAtom) + <*> pure Nothing parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) parseInstanceDeclaration = do diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 8657f1e1cd..a2f4a6cd8a 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -75,7 +75,7 @@ parseConstrainedType = do className <- parseQualified properName indented ty <- P.many parseTypeAtom - return (className, ty) + return (Constraint className ty Nothing) parseAnyType :: TokenParser Type diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index cf858ede73..9124be9b9c 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -42,8 +42,8 @@ typeLiterals = mkPattern match match _ = Nothing constraintsAsBox :: [Constraint] -> Box -> Box -constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty -constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty) +constraintsAsBox [(Constraint pn tys _)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty +constraintsAsBox xs ty = vcat left (zipWith (\i (Constraint pn tys _) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty) constraintAsBox :: Qualified (ProperName a) -> [Type] -> Box constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys) diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 6c0ba9dfc8..7a63c1a8e6 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -14,6 +14,7 @@ import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Pretty.Common import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox) +import Language.PureScript.Types (Constraint(..)) import Text.PrettyPrint.Boxes @@ -57,7 +58,7 @@ prettyPrintValue d (Let ds val) = (text "in " <> prettyPrintValue (d - 1) val) prettyPrintValue d (Do els) = text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) -prettyPrintValue _ (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys +prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">" diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index d92a5cd478..131208a897 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -147,7 +147,7 @@ usedTypeNames moduleName = usedNames :: Type -> [ProperName 'TypeName] usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \case - (Qualified (Just moduleName') name, _) + (Constraint (Qualified (Just moduleName') name) _ _) | moduleName == moduleName' -> Just (coerceProperName name) _ -> Nothing usedNames (TypeConstructor (Qualified (Just moduleName') name)) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 498c16298c..1f36d5156f 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -251,7 +251,10 @@ renameInModule env imports (Module ss coms mn decls exps) = updateType t = return t updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint] - updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts) + updateConstraints pos = traverse (\(Constraint name ts info) -> + Constraint <$> updateClassName name pos + <*> traverse (updateTypesEverywhere pos) ts + <*> pure info) updateTypeName :: Qualified (ProperName 'TypeName) diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index d7607576b6..3e1522a473 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -280,10 +280,10 @@ updateTypes goType = (goDecl, goExpr) ty' <- goType' pos ty return (pos, ExternDeclaration name ty') goDecl pos (TypeClassDeclaration name args implies decls) = do - implies' <- traverse (sndM (traverse (goType' pos))) implies + implies' <- traverse (overConstraintArgs (traverse (goType' pos))) implies return (pos, TypeClassDeclaration name args implies' decls) goDecl pos (TypeInstanceDeclaration name cs className tys impls) = do - cs' <- traverse (sndM (traverse (goType' pos))) cs + cs' <- traverse (overConstraintArgs (traverse (goType' pos))) cs tys' <- traverse (goType' pos) tys return (pos, TypeInstanceDeclaration name cs' className tys' impls) goDecl pos (TypeSynonymDeclaration name args ty) = do @@ -296,9 +296,9 @@ updateTypes goType = (goDecl, goExpr) goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) - goExpr pos (TypeClassDictionary (name, tys) dicts) = do + goExpr pos (TypeClassDictionary (Constraint name tys info) dicts) = do tys' <- traverse (goType' pos) tys - return (pos, TypeClassDictionary (name, tys') dicts) + return (pos, TypeClassDictionary (Constraint name tys' info) dicts) goExpr pos (SuperClassDictionary cls tys) = do tys' <- traverse (goType' pos) tys return (pos, SuperClassDictionary cls tys') diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 1b9ab39c72..46adfa4500 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -52,7 +52,8 @@ desugarTypeClasses desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule where initialState :: MemberMap - initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) + initialState = M.singleton (ModuleName [ProperName C.prim], ProperName C.partial) ([], [], []) + `M.union` M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) fromExternsDecl :: ModuleName @@ -233,7 +234,7 @@ typeClassDictionaryDeclaration typeClassDictionaryDeclaration name args implies members = let superclassTypes = superClassDictionaryNames implies `zip` [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs) - | (superclass, tyArgs) <- implies + | (Constraint superclass tyArgs _) <- implies ] members' = map (first runIdent . memberToNameAndType) members mtys = members' ++ superclassTypes @@ -249,7 +250,7 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) = let className = Qualified (Just mn) name in ValueDeclaration ident Private [] $ Right $ TypedValue False (TypeClassDictionaryAccessor className ident) $ - moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty)) + moveQuantifiersToFront (quantify (ConstrainedType [Constraint className (map (TypeVar . fst) args) Nothing] ty)) typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) = PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" @@ -293,7 +294,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = -- The dictionary itself is an object literal. let superclasses = superClassDictionaryNames implies `zip` [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs) - | (superclass, suTyArgs) <- implies + | (Constraint superclass suTyArgs _) <- implies , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs ] @@ -330,5 +331,5 @@ typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration superClassDictionaryNames :: [Constraint] -> [String] superClassDictionaryNames supers = [ C.__superclass_ ++ showQualified runProperName pn ++ "_" ++ show (index :: Integer) - | (index, (pn, _)) <- zip [0..] supers + | (index, Constraint pn _ _) <- zip [0..] supers ] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 8501e52c71..7481a5927a 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -36,7 +36,9 @@ import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Kinds +import Language.PureScript.Linter import Language.PureScript.Names +import Language.PureScript.Traversals import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types @@ -228,26 +230,30 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds addTypeSynonym moduleName name args' ty kind return $ TypeSynonymDeclaration name args ty go TypeDeclaration{} = internalError "Type declarations should have been removed" - go (ValueDeclaration name nameKind [] (Right val)) = + go (ValueDeclaration name nameKind [] (Right val)) = do + env <- getEnv warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do + val' <- checkExhaustiveExpr env moduleName val valueIsNotDefined moduleName name - [(_, (val', ty))] <- typesOf NonRecursiveBindingGroup moduleName [(name, val)] + [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [(name, val')] addValue moduleName name ty nameKind - return $ ValueDeclaration name nameKind [] $ Right val' + return $ ValueDeclaration name nameKind [] $ Right val'' go ValueDeclaration{} = internalError "Binders were not desugared" - go (BindingGroupDeclaration vals) = + go (BindingGroupDeclaration vals) = do + env <- getEnv warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do - for_ (map (\(ident, _, _) -> ident) vals) $ \name -> - valueIsNotDefined moduleName name - tys <- typesOf RecursiveBindingGroup moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals - vals' <- forM [ (name, val, nameKind, ty) - | (name, nameKind, _) <- vals - , (name', (val, ty)) <- tys - , name == name' - ] $ \(name, val, nameKind, ty) -> do + for_ vals $ \(ident, _, _) -> + valueIsNotDefined moduleName ident + vals' <- mapM (thirdM (checkExhaustiveExpr env moduleName)) vals + tys <- typesOf RecursiveBindingGroup moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals' + vals'' <- forM [ (name, val, nameKind, ty) + | (name, nameKind, _) <- vals' + , (name', (val, ty)) <- tys + , name == name' + ] $ \(name, val, nameKind, ty) -> do addValue moduleName name ty nameKind return (name, nameKind, val) - return $ BindingGroupDeclaration vals' + return $ BindingGroupDeclaration vals'' go (d@(ExternDataDeclaration name kind)) = do env <- getEnv putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) } @@ -268,7 +274,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds return d go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do traverse_ (checkTypeClassInstance moduleName) tys - forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . snd + forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . constraintArgs checkOrphanInstance dictName className tys _ <- traverseTypeInstanceBody checkInstanceMembers body let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) @@ -415,7 +421,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint findClasses :: Type -> [DeclarationRef] findClasses = everythingOnTypes (++) go where - go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs + go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . constraintClass) cs go _ = [] extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName) extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 63f8c7384d..019c5a1a6e 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -14,7 +14,6 @@ import Data.List (minimumBy, sortBy, groupBy) import Data.Maybe (maybeToList, mapMaybe) import qualified Data.Map as M -import Control.Arrow (Arrow(..)) import Control.Monad.State import Control.Monad.Writer import Control.Monad.Error.Class (MonadError(..)) @@ -81,13 +80,13 @@ entails shouldGeneralize moduleName context = solve findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx solve :: Constraint -> StateT Context m (Expr, [(Ident, Constraint)]) - solve (className, tys) = do - (dict, unsolved) <- go 0 className tys + solve con = do + (dict, unsolved) <- go 0 con return (dictionaryValueToValue dict, unsolved) where - go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> StateT Context m (DictionaryValue, [(Ident, Constraint)]) - go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' - go work className' tys' = do + go :: Int -> Constraint -> StateT Context m (DictionaryValue, [(Ident, Constraint)]) + go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' + go work con'@(Constraint className' tys' _) = do -- Get the inferred constraint context so far, and merge it with the global context inferred <- get let instances = do @@ -104,7 +103,7 @@ entails shouldGeneralize moduleName context = solve (mkDictionary (tcdName tcd) args) (tcdPath tcd) return (match, unsolved) - Right unsolved@(unsolvedClassName@(Qualified _ pn), unsolvedTys) -> do + Right unsolved@(Constraint unsolvedClassName@(Qualified _ pn) unsolvedTys _) -> do -- Generate a fresh name for the unsolved constraint's new dictionary ident <- freshIdent ("dict" ++ runProperName pn) let qident = Qualified Nothing ident @@ -117,8 +116,8 @@ entails shouldGeneralize moduleName context = solve where unique :: [(a, TypeClassDictionaryInScope)] -> m (Either (a, TypeClassDictionaryInScope) Constraint) - unique [] | shouldGeneralize && all canBeGeneralized tys' = return $ Right (className, tys) - | otherwise = throwError . errorMessage $ NoInstanceFound className' tys' + unique [] | shouldGeneralize && all canBeGeneralized tys' = return (Right con') + | otherwise = throwError . errorMessage $ NoInstanceFound con' unique [a] = return $ Left a unique tcds | pairwise overlapping (map snd tcds) = do tell . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds) @@ -148,7 +147,7 @@ entails shouldGeneralize moduleName context = solve solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT Context m (Maybe [DictionaryValue], [(Ident, Constraint)]) solveSubgoals _ Nothing = return (Nothing, []) solveSubgoals subst (Just subgoals) = do - zipped <- traverse (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals + zipped <- traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars subst))) subgoals let (dicts, unsolved) = unzip zipped return (Just dicts, concat unsolved) diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index da5260bd84..54618864df 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -262,7 +262,7 @@ infer' other = (, []) <$> go other unifyKinds k2 (Row k1) return $ Row k1 go (ConstrainedType deps ty) = do - forM_ deps $ \(className, tys) -> do + forM_ deps $ \(Constraint className tys _) -> do k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys unifyKinds k Star k <- go ty diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs index ba07ba304b..ac3854c50a 100644 --- a/src/Language/PureScript/TypeChecker/Rows.hs +++ b/src/Language/PureScript/TypeChecker/Rows.hs @@ -54,7 +54,7 @@ checkDuplicateLabels = checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2 checkDups (ForAll _ t _) = checkDups t checkDups (ConstrainedType args t) = do - mapM_ checkDups $ concatMap snd args + mapM_ checkDups $ concatMap constraintArgs args checkDups t checkDups r@RCons{} = let (ls, _) = rowToList r in diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 715e7aaff6..cd2932665a 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -98,10 +98,10 @@ typesOf bindingGroupType moduleName vals = do $ CannotGeneralizeRecursiveFunction ident generalized -- Make sure any unsolved type constraints only use type variables which appear -- unknown in the inferred type. - forM_ unsolved $ \(_, (className, classTys)) -> do - let constraintTypeVars = nub $ foldMap unknownsInType classTys + forM_ unsolved $ \(_, con) -> do + let constraintTypeVars = nub $ foldMap unknownsInType (constraintArgs con) when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ - throwError . errorMessage $ NoInstanceFound className classTys + throwError . errorMessage $ NoInstanceFound con -- Check skolem variables did not escape their scope skolemEscapeCheck val' @@ -204,7 +204,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' where g :: Expr -> Expr g (TypedValue checkTy val t) = TypedValue checkTy val (f t) - g (TypeClassDictionary (nm, tys) sco) = TypeClassDictionary (nm, map f tys) sco + g (TypeClassDictionary c sco) = TypeClassDictionary (mapConstraintArgs (map f) c) sco g other = other -- | Check the kind of a type, failing if it is not of kind *. @@ -319,7 +319,7 @@ infer' (Let ds val) = do return $ TypedValue True (Let ds' val') valTy infer' (SuperClassDictionary className tys) = do dicts <- getTypeClassDictionaries - return $ TypeClassDictionary (className, tys) dicts + return $ TypeClassDictionary (Constraint className tys Nothing) dicts infer' (TypedValue checkType val ty) = do Just moduleName <- checkCurrentModule <$> get (kind, args) <- kindOfWithScopedVars ty @@ -527,7 +527,7 @@ check' val (ForAll ident ty _) = do val' <- check skVal sk return $ TypedValue True val' (ForAll ident ty (Just scope)) check' val t@(ConstrainedType constraints ty) = do - dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> + dictNames <- forM constraints $ \(Constraint (Qualified _ (ProperName className)) _ _) -> freshIdent ("dict" ++ className) dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty @@ -538,15 +538,15 @@ check' val t@(ConstrainedType constraints ty) = do newDictionaries :: [(Qualified (ProperName 'ClassName), Integer)] -> Qualified Ident - -> (Qualified (ProperName 'ClassName), [Type]) + -> Constraint -> m [TypeClassDictionaryInScope] - newDictionaries path name (className, instanceTy) = do + newDictionaries path name (Constraint className instanceTy _) = do tcs <- gets (typeClasses . checkEnv) let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs - supDicts <- join <$> zipWithM (\(supName, supArgs) index -> + supDicts <- join <$> zipWithM (\(Constraint supName supArgs _) index -> newDictionaries ((supName, index) : path) name - (supName, instantiateSuperclass (map fst args) supArgs instanceTy) + (Constraint supName (instantiateSuperclass (map fst args) supArgs instanceTy) Nothing) ) superclasses [0..] return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts) @@ -599,7 +599,7 @@ check' (SuperClassDictionary className tys) _ = do -- declaration gets desugared. -} dicts <- getTypeClassDictionaries - return $ TypeClassDictionary (className, tys) dicts + return $ TypeClassDictionary (Constraint className tys Nothing) dicts check' (TypedValue checkType val ty1) ty2 = do Just moduleName <- checkCurrentModule <$> get (kind, args) <- kindOfWithScopedVars ty1 diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 0f71c2ff99..f862e7d8af 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -14,12 +14,10 @@ import Data.Maybe (fromMaybe) import qualified Data.Aeson as A import qualified Data.Aeson.TH as A -import Control.Arrow (second) import Control.Monad ((<=<)) import Language.PureScript.Names import Language.PureScript.Kinds -import Language.PureScript.Traversals import Language.PureScript.AST.SourcePos -- | @@ -109,12 +107,35 @@ data Type | ParensInType Type deriving (Show, Read, Eq, Ord) --- | --- A typeclass constraint --- -type Constraint = (Qualified (ProperName 'ClassName), [Type]) +-- | Additional data relevant to type class constraints +data ConstraintData + = PartialConstraintData [[String]] Bool + -- ^ Data to accompany a Partial constraint generated by the exhaustivity checker. + -- It contains (rendered) binder information for those binders which were + -- not matched, and a flag indicating whether the list was truncated or not. + -- Note: we use 'String' here because using 'Binder' would introduce a cyclic + -- dependency in the module graph. + deriving (Show, Read, Eq, Ord) + +-- | A typeclass constraint +data Constraint = Constraint + { constraintClass :: Qualified (ProperName 'ClassName) + -- ^ constraint class name + , constraintArgs :: [Type] + -- ^ type arguments + , constraintData :: Maybe ConstraintData + -- ^ additional data relevant to this constraint + } deriving (Show, Read, Eq, Ord) + +mapConstraintArgs :: ([Type] -> [Type]) -> Constraint -> Constraint +mapConstraintArgs f c = c { constraintArgs = f (constraintArgs c) } + +overConstraintArgs :: Functor f => ([Type] -> f [Type]) -> Constraint -> f Constraint +overConstraintArgs f c = (\args -> c { constraintArgs = args }) <$> f (constraintArgs c) $(A.deriveJSON A.defaultOptions ''Type) +$(A.deriveJSON A.defaultOptions ''Constraint) +$(A.deriveJSON A.defaultOptions ''ConstraintData) -- | -- Convert a row to a list of pairs of labels and types @@ -169,7 +190,7 @@ replaceAllTypeVars = go [] where keys = map fst m usedVars = concatMap (usedTypeVariables . snd) m - go bs m (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs m)) cs) (go bs m t) + go bs m (ConstrainedType cs t) = ConstrainedType (map (mapConstraintArgs (map (go bs m))) cs) (go bs m t) go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r) go bs m (KindedType t k) = KindedType (go bs m t) k go bs m (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go bs m t1) (go bs m t2) (go bs m t3) @@ -201,7 +222,7 @@ freeTypeVariables = nub . go [] go bound (TypeVar v) | v `notElem` bound = [v] go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2 go bound (ForAll v t _) = go (v : bound) t - go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t + go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . constraintArgs) cs ++ go bound t go bound (RCons _ t r) = go bound t ++ go bound r go bound (KindedType t _) = go bound t go bound (BinaryNoParensType t1 t2 t3) = go bound t1 ++ go bound t2 ++ go bound t3 @@ -249,7 +270,7 @@ everywhereOnTypes f = go where go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2)) go (ForAll arg ty sco) = f (ForAll arg (go ty) sco) - go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty)) + go (ConstrainedType cs ty) = f (ConstrainedType (map (mapConstraintArgs (map go)) cs) (go ty)) go (RCons name ty rest) = f (RCons name (go ty) (go rest)) go (KindedType ty k) = f (KindedType (go ty) k) go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2)) @@ -264,7 +285,7 @@ everywhereOnTypesTopDown f = go . f where go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2)) go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco - go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty)) + go (ConstrainedType cs ty) = ConstrainedType (map (mapConstraintArgs (map (go . f))) cs) (go (f ty)) go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest)) go (KindedType ty k) = KindedType (go (f ty)) k go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2)) @@ -279,7 +300,7 @@ everywhereOnTypesM f = go where go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f - go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f + go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (overConstraintArgs (mapM go)) cs <*> go ty) >>= f go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f go (KindedType ty k) = (KindedType <$> go ty <*> pure k) >>= f go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f @@ -294,7 +315,7 @@ everywhereOnTypesTopDownM f = go <=< f where go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go) go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco - go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go) + go (ConstrainedType cs ty) = ConstrainedType <$> mapM (overConstraintArgs (mapM (go <=< f))) cs <*> (f ty >>= go) go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go) go (KindedType ty k) = KindedType <$> (f ty >>= go) <*> pure k go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go) @@ -309,7 +330,7 @@ everythingOnTypes (<>) f = go where go t@(TypeApp t1 t2) = f t <> go t1 <> go t2 go t@(ForAll _ ty _) = f t <> go ty - go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty + go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap constraintArgs cs) <> go ty go t@(RCons _ ty rest) = f t <> go ty <> go rest go t@(KindedType ty _) = f t <> go ty go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2 @@ -325,7 +346,7 @@ everythingWithContextOnTypes s0 r0 (<>) f = go' s0 go' s t = let (s', r) = f s t in r <> go s' t go s (TypeApp t1 t2) = go' s t1 <> go' s t2 go s (ForAll _ ty _) = go' s ty - go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap snd cs) <> go' s ty + go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap constraintArgs cs) <> go' s ty go s (RCons _ ty rest) = go' s ty <> go' s rest go s (KindedType ty _) = go' s ty go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2 diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 85a2e63394..25740b3c47 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -197,7 +197,7 @@ assertCompiles inputFiles foreigns = do case result of Just (ExitSuccess, out, err) | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err - | trim (last (lines out)) == "Done" -> return Nothing + | not (null out) && trim (last (lines out)) == "Done" -> return Nothing | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out Just (ExitFailure _, _, err) -> return $ Just err Nothing -> return $ Just "Couldn't find node.js executable" diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index dff2da4e85..c0d49317b7 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -197,7 +197,7 @@ checkConstrained ty tyClass = False where matches className = - (==) className . P.runProperName . P.disqualify . fst + (==) className . P.runProperName . P.disqualify . P.constraintClass runAssertionIO :: Assertion -> Docs.Module -> IO () runAssertionIO assertion mdl = do diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index ce46a90d74..1f01d039c1 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -75,6 +75,8 @@ supportModules = , "Data.Show" , "Data.Unit" , "Data.Void" + , "Partial" + , "Partial.Unsafe" , "Prelude" , "Test.Assert" ] diff --git a/tests/support/bower.json b/tests/support/bower.json index 331e059b1b..fa82ef3c8d 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -6,6 +6,7 @@ "purescript-eff": "1.0.0-rc.1", "purescript-functions": "1.0.0-rc.1", "purescript-prelude": "1.0.0-rc.3", - "purescript-st": "1.0.0-rc.1" + "purescript-st": "1.0.0-rc.1", + "purescript-partial": "1.1.1" } } From fac68e50b828869b5f1fe394e86b967363926aab Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 6 May 2016 18:05:00 +0100 Subject: [PATCH 0402/1580] NoImplicitPrelude, enable some global extensions (#2094) * NoImplicitPrelude, enable some global extensions --- psc-ide-server/Main.hs | 1 - psci/PSCi/Directive.hs | 13 --- psci/PSCi/IO.hs | 14 ---- psci/PSCi/Parser.hs | 12 --- psci/PSCi/Types.hs | 12 --- purescript.cabal | 17 +++- src/Control/Monad/Logger.hs | 27 ++----- src/Control/Monad/Supply.hs | 23 ++---- src/Control/Monad/Supply/Class.hs | 12 +-- src/Language/PureScript.hs | 21 +---- src/Language/PureScript/AST/Binders.hs | 2 + src/Language/PureScript/AST/Declarations.hs | 8 +- src/Language/PureScript/AST/Exported.hs | 3 + src/Language/PureScript/AST/Literals.hs | 4 +- src/Language/PureScript/AST/Operators.hs | 2 + src/Language/PureScript/AST/SourcePos.hs | 3 - src/Language/PureScript/AST/Traversals.hs | 13 ++- src/Language/PureScript/Bundle.hs | 31 ++------ src/Language/PureScript/CodeGen.hs | 28 ++----- src/Language/PureScript/CodeGen/JS.hs | 24 +++--- src/Language/PureScript/CodeGen/JS/AST.hs | 3 +- src/Language/PureScript/CodeGen/JS/Common.hs | 2 + .../PureScript/CodeGen/JS/Optimizer.hs | 14 ++-- .../PureScript/CodeGen/JS/Optimizer/Blocks.hs | 14 +--- .../PureScript/CodeGen/JS/Optimizer/Common.hs | 2 + .../CodeGen/JS/Optimizer/Inliner.hs | 4 +- .../CodeGen/JS/Optimizer/MagicDo.hs | 2 + .../PureScript/CodeGen/JS/Optimizer/TCO.hs | 14 +--- .../PureScript/CodeGen/JS/Optimizer/Unused.hs | 15 +--- src/Language/PureScript/Comments.hs | 2 + src/Language/PureScript/Constants.hs | 5 +- src/Language/PureScript/CoreFn.hs | 2 +- src/Language/PureScript/CoreFn/Ann.hs | 62 ++++++--------- src/Language/PureScript/CoreFn/Binders.hs | 4 +- src/Language/PureScript/CoreFn/Desugar.hs | 10 +-- src/Language/PureScript/CoreFn/Expr.hs | 6 +- src/Language/PureScript/CoreFn/Meta.hs | 2 + src/Language/PureScript/CoreFn/Module.hs | 19 ++--- src/Language/PureScript/CoreFn/Traversals.hs | 4 +- src/Language/PureScript/Crash.hs | 20 ++--- src/Language/PureScript/Docs.hs | 8 +- src/Language/PureScript/Docs/AsMarkdown.hs | 12 +-- src/Language/PureScript/Docs/Convert.hs | 13 ++- .../PureScript/Docs/Convert/ReExports.hs | 19 ++--- .../PureScript/Docs/Convert/Single.hs | 13 +-- .../PureScript/Docs/ParseAndBookmark.hs | 16 ++-- src/Language/PureScript/Docs/Render.hs | 11 +-- src/Language/PureScript/Docs/RenderedCode.hs | 19 ++--- .../PureScript/Docs/RenderedCode/Render.hs | 49 ++++++------ .../PureScript/Docs/RenderedCode/Types.hs | 6 +- src/Language/PureScript/Docs/Types.hs | 20 +++-- src/Language/PureScript/Environment.hs | 6 +- src/Language/PureScript/Errors.hs | 31 +++----- src/Language/PureScript/Errors/JSON.hs | 15 ---- src/Language/PureScript/Externs.hs | 17 ++-- src/Language/PureScript/Ide.hs | 4 - src/Language/PureScript/Ide/CaseSplit.hs | 6 -- src/Language/PureScript/Ide/Command.hs | 2 - src/Language/PureScript/Ide/Error.hs | 1 + src/Language/PureScript/Ide/Externs.hs | 4 - src/Language/PureScript/Ide/Filter.hs | 1 - src/Language/PureScript/Ide/Imports.hs | 5 +- src/Language/PureScript/Ide/Matcher.hs | 1 - src/Language/PureScript/Ide/Pursuit.hs | 1 - src/Language/PureScript/Ide/Rebuild.hs | 7 +- src/Language/PureScript/Ide/Reexports.hs | 2 - src/Language/PureScript/Ide/SourceFile.hs | 2 - src/Language/PureScript/Ide/State.hs | 4 - src/Language/PureScript/Ide/Types.hs | 4 - src/Language/PureScript/Ide/Util.hs | 1 + src/Language/PureScript/Kinds.hs | 1 - src/Language/PureScript/Linter.hs | 16 ++-- src/Language/PureScript/Linter/Exhaustive.hs | 26 +++--- src/Language/PureScript/Linter/Imports.hs | 8 +- src/Language/PureScript/Make.hs | 64 +++++++-------- src/Language/PureScript/ModuleDependencies.hs | 16 ++-- src/Language/PureScript/Names.hs | 7 +- src/Language/PureScript/Options.hs | 14 +--- src/Language/PureScript/Parser.hs | 60 ++++++-------- src/Language/PureScript/Parser/Common.hs | 11 ++- .../PureScript/Parser/Declarations.hs | 30 +++---- src/Language/PureScript/Parser/JS.hs | 22 +----- src/Language/PureScript/Parser/Kinds.hs | 18 +---- src/Language/PureScript/Parser/Lexer.hs | 23 +----- src/Language/PureScript/Parser/State.hs | 14 +--- src/Language/PureScript/Parser/Types.hs | 21 ++--- src/Language/PureScript/Pretty.hs | 16 +--- src/Language/PureScript/Pretty/Common.hs | 20 +---- src/Language/PureScript/Pretty/JS.hs | 35 +++----- src/Language/PureScript/Pretty/Kinds.hs | 28 +++---- src/Language/PureScript/Pretty/Types.hs | 22 ++++-- src/Language/PureScript/Pretty/Values.hs | 14 ++-- src/Language/PureScript/Publish.hs | 43 +++++----- .../PureScript/Publish/BoxesHelpers.hs | 3 + .../PureScript/Publish/ErrorsWarnings.hs | 19 ++--- src/Language/PureScript/Publish/Utils.hs | 79 ++++++++++--------- src/Language/PureScript/Renamer.hs | 6 -- src/Language/PureScript/Sugar.hs | 20 +---- .../PureScript/Sugar/BindingGroups.hs | 5 -- .../PureScript/Sugar/CaseDeclarations.hs | 18 ++--- src/Language/PureScript/Sugar/DoNotation.hs | 20 ++--- src/Language/PureScript/Sugar/Names.hs | 25 +++--- src/Language/PureScript/Sugar/Names/Env.hs | 15 ++-- .../PureScript/Sugar/Names/Exports.hs | 18 ++--- .../PureScript/Sugar/Names/Imports.hs | 21 ++--- .../PureScript/Sugar/ObjectWildcards.hs | 11 +-- src/Language/PureScript/Sugar/Operators.hs | 6 -- .../PureScript/Sugar/Operators/Binders.hs | 1 - .../PureScript/Sugar/Operators/Common.hs | 5 -- .../PureScript/Sugar/Operators/Expr.hs | 4 - .../PureScript/Sugar/Operators/Types.hs | 1 - src/Language/PureScript/Sugar/TypeClasses.hs | 5 -- .../PureScript/Sugar/TypeClasses/Deriving.hs | 18 ++--- .../PureScript/Sugar/TypeDeclarations.hs | 26 ++---- src/Language/PureScript/Traversals.hs | 69 +++++++--------- src/Language/PureScript/TypeChecker.hs | 36 ++++----- .../PureScript/TypeChecker/Entailment.hs | 21 +++-- src/Language/PureScript/TypeChecker/Kinds.hs | 12 +-- src/Language/PureScript/TypeChecker/Monad.hs | 12 +-- src/Language/PureScript/TypeChecker/Rows.hs | 29 ++----- .../PureScript/TypeChecker/Skolems.hs | 43 ++++------ .../PureScript/TypeChecker/Subsumption.hs | 30 ++----- .../PureScript/TypeChecker/Synonyms.hs | 32 ++------ src/Language/PureScript/TypeChecker/Types.hs | 19 ++--- src/Language/PureScript/TypeChecker/Unify.hs | 57 +++++-------- .../PureScript/TypeClassDictionaries.hs | 2 + src/Language/PureScript/Types.hs | 11 ++- src/System/IO/UTF8.hs | 4 +- 128 files changed, 699 insertions(+), 1309 deletions(-) diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index c19c7ca829..2d4f49cb26 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -12,7 +12,6 @@ -- The server accepting commands for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/psci/PSCi/Directive.hs b/psci/PSCi/Directive.hs index 3d0cad5a38..1156bd5a86 100644 --- a/psci/PSCi/Directive.hs +++ b/psci/PSCi/Directive.hs @@ -1,18 +1,6 @@ ------------------------------------------------------------------------------ --- --- Module : Directive --- Copyright : --- License : MIT --- --- Maintainer : --- Stability : experimental --- Portability : --- -- | -- Directives for PSCI. -- ------------------------------------------------------------------------------ - module PSCi.Directive where import Prelude () @@ -116,4 +104,3 @@ help = , (Show, "import", "Show all imported modules") , (Show, "loaded", "Show all loaded modules") ] - diff --git a/psci/PSCi/IO.hs b/psci/PSCi/IO.hs index fea644a448..5397070e46 100644 --- a/psci/PSCi/IO.hs +++ b/psci/PSCi/IO.hs @@ -1,17 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : IO --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - module PSCi.IO where import Prelude () diff --git a/psci/PSCi/Parser.hs b/psci/PSCi/Parser.hs index ec7a4e9eab..d8ebb033a2 100644 --- a/psci/PSCi/Parser.hs +++ b/psci/PSCi/Parser.hs @@ -1,18 +1,6 @@ ------------------------------------------------------------------------------ --- --- Module : Parser --- Copyright : (c) Phil Freeman 2014 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Parser for PSCI. -- ------------------------------------------------------------------------------ - module PSCi.Parser ( parseCommand ) where diff --git a/psci/PSCi/Types.hs b/psci/PSCi/Types.hs index 3627d41a20..1e0a111fe8 100644 --- a/psci/PSCi/Types.hs +++ b/psci/PSCi/Types.hs @@ -1,18 +1,6 @@ ------------------------------------------------------------------------------ --- --- Module : Types --- Copyright : (c) Phil Freeman 2014 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Type declarations and associated basic functions for PSCI. -- ------------------------------------------------------------------------------ - module PSCi.Types where import Prelude () diff --git a/purescript.cabal b/purescript.cabal index 2b4bd4e247..592f30dff4 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -264,7 +264,22 @@ library System.IO.UTF8 - extensions: DataKinds + extensions: ConstraintKinds + DataKinds + DeriveFunctor + EmptyDataDecls + FlexibleContexts + KindSignatures + LambdaCase + MultiParamTypeClasses + NoImplicitPrelude + PatternGuards + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + TupleSections + ViewPatterns exposed: True buildable: True hs-source-dirs: src diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs index f8e8e7ca1f..c4969d8572 100644 --- a/src/Control/Monad/Logger.hs +++ b/src/Control/Monad/Logger.hs @@ -1,33 +1,20 @@ ------------------------------------------------------------------------------ --- --- Module : Control.Monad.Logger --- Author : Phil Freeman --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | A replacement for WriterT IO which uses mutable references. --- ------------------------------------------------------------------------------ - {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +-- | +-- A replacement for WriterT IO which uses mutable references. +-- module Control.Monad.Logger where -import Prelude () import Prelude.Compat -import Data.IORef - import Control.Monad (ap) -import Control.Monad.IO.Class -import Control.Monad.Writer.Class import Control.Monad.Base (MonadBase(..)) +import Control.Monad.IO.Class import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Control.Monad.Writer.Class + +import Data.IORef -- | A replacement for WriterT IO which uses mutable references. newtype Logger w a = Logger { runLogger :: IORef w -> IO a } diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs index 0b002e4554..2fa7aaaf5e 100644 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -1,32 +1,19 @@ ------------------------------------------------------------------------------ --- --- Module : Control.Monad.Supply --- Copyright : (c) Phil Freeman 2014 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- | -- Fresh variable supply -- ------------------------------------------------------------------------------ - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Control.Monad.Supply where -import Prelude () import Prelude.Compat -import Data.Functor.Identity - -import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader +import Control.Monad.State import Control.Monad.Writer +import Data.Functor.Identity + newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r) diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index 8621e2e2db..524225c82d 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -1,24 +1,24 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -- | -- A class for monads supporting a supply of fresh names -- module Control.Monad.Supply.Class where +import Prelude.Compat + import Control.Monad.Supply import Control.Monad.State -class (Monad m) => MonadSupply m where +class Monad m => MonadSupply m where fresh :: m Integer -instance (Monad m) => MonadSupply (SupplyT m) where +instance Monad m => MonadSupply (SupplyT m) where fresh = SupplyT $ do n <- get put (n + 1) return n -instance (MonadSupply m) => MonadSupply (StateT s m) where +instance MonadSupply m => MonadSupply (StateT s m) where fresh = lift fresh -freshName :: (MonadSupply m) => m String +freshName :: MonadSupply m => m String freshName = fmap (('$' :) . show) fresh diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index 21ecd64ec4..311cb80ac3 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -1,31 +1,19 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- The main compiler module -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Language.PureScript ( module P , version ) where + +import Control.Monad.Supply as P + import Data.Version (Version) import Language.PureScript.AST as P -import Language.PureScript.Crash as P import Language.PureScript.Comments as P +import Language.PureScript.Crash as P import Language.PureScript.Environment as P import Language.PureScript.Errors as P hiding (indent) import Language.PureScript.Kinds as P @@ -38,7 +26,6 @@ import Language.PureScript.Parser as P import Language.PureScript.Pretty as P import Language.PureScript.Renamer as P import Language.PureScript.Sugar as P -import Control.Monad.Supply as P import Language.PureScript.TypeChecker as P import Language.PureScript.Types as P diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index 21ef3cafcb..6d52db53b5 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -3,6 +3,8 @@ -- module Language.PureScript.AST.Binders where +import Prelude.Compat + import Language.PureScript.AST.SourcePos import Language.PureScript.AST.Literals import Language.PureScript.Names diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 10c7fa2971..52e1d6253e 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -1,23 +1,19 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE LambdaCase #-} -- | -- Data types for modules and declarations -- module Language.PureScript.AST.Declarations where -import Prelude () import Prelude.Compat +import Control.Monad.Identity + import Data.Aeson.TH import Data.List (nub, (\\)) import Data.Maybe (mapMaybe) - import qualified Data.Map as M -import Control.Monad.Identity - import Language.PureScript.AST.Binders import Language.PureScript.AST.Literals import Language.PureScript.AST.Operators diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index 5f402dfa39..ee7547ff53 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -3,7 +3,10 @@ module Language.PureScript.AST.Exported , isExported ) where +import Prelude.Compat + import Control.Category ((>>>)) + import Data.Maybe (mapMaybe) import Language.PureScript.AST.Declarations diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs index d14a36bc9a..fae56ee087 100644 --- a/src/Language/PureScript/AST/Literals.hs +++ b/src/Language/PureScript/AST/Literals.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE DeriveFunctor #-} - -- | -- The core functional representation for literal values. -- module Language.PureScript.AST.Literals where +import Prelude.Compat + -- | -- Data type for literal values. Parameterised so it can be used for Exprs and -- Binders. diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs index 241f6c44e6..5ba0e157cb 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -5,6 +5,8 @@ -- module Language.PureScript.AST.Operators where +import Prelude.Compat + import Data.Aeson ((.=)) import qualified Data.Aeson as A diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 35d5903421..328c955fa9 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -7,7 +5,6 @@ -- module Language.PureScript.AST.SourcePos where -import Prelude () import Prelude.Compat import Data.Aeson ((.=), (.:)) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 459cda1d46..801883a996 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -1,21 +1,18 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -- | -- AST traversal helpers -- module Language.PureScript.AST.Traversals where -import Prelude () import Prelude.Compat -import Data.Maybe (mapMaybe) -import Data.List (mapAccumL) -import Data.Foldable (fold) -import qualified Data.Set as S - import Control.Monad import Control.Arrow ((***), (+++)) +import Data.Foldable (fold) +import Data.List (mapAccumL) +import Data.Maybe (mapMaybe) +import qualified Data.Set as S + import Language.PureScript.AST.Binders import Language.PureScript.AST.Literals import Language.PureScript.AST.Declarations diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 60f1d8708a..2cba0ae884 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -1,25 +1,9 @@ ------------------------------------------------------------------------------ --- --- Module : psc-bundle --- Copyright : (c) Phil Freeman 2015 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | Bundles compiled PureScript modules for the browser. +-- | +-- Bundles compiled PureScript modules for the browser. -- -- This module takes as input the individual generated modules from 'Language.PureScript.Make' and -- performs dead code elimination, filters empty modules, -- and generates the final Javascript bundle. ------------------------------------------------------------------------------ - -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - module Language.PureScript.Bundle ( bundle , ModuleIdentifier(..) @@ -30,19 +14,18 @@ module Language.PureScript.Bundle ( , getExportedIdentifiers ) where -import Prelude () import Prelude.Compat -import Data.List (nub, stripPrefix) -import Data.Maybe (mapMaybe, catMaybes) +import Control.Monad +import Control.Monad.Error.Class + import Data.Generics (everything, everywhere, mkQ, mkT) import Data.Graph +import Data.List (nub, stripPrefix) +import Data.Maybe (mapMaybe, catMaybes) import Data.Version (showVersion) - import qualified Data.Set as S -import Control.Monad -import Control.Monad.Error.Class import Language.JavaScript.Parser import Language.JavaScript.Parser.AST diff --git a/src/Language/PureScript/CodeGen.hs b/src/Language/PureScript/CodeGen.hs index ee305ff870..d927211bf8 100644 --- a/src/Language/PureScript/CodeGen.hs +++ b/src/Language/PureScript/CodeGen.hs @@ -1,20 +1,8 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- A collection of modules related to code generation: --- --- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript --- ------------------------------------------------------------------------------ - -module Language.PureScript.CodeGen (module C) where - -import Language.PureScript.CodeGen.JS as C +-- | +-- A collection of modules related to code generation: +-- +-- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript +-- +module Language.PureScript.CodeGen (module C) where + +import Language.PureScript.CodeGen.JS as C diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 1a14fc8e3c..3738cfc0d6 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- | -- This module generates code in the simplified Javascript intermediate representation from Purescript code -- @@ -12,29 +7,28 @@ module Language.PureScript.CodeGen.JS , moduleToJs ) where -import Prelude () import Prelude.Compat -import Data.List ((\\), delete, intersect) -import Data.Maybe (isNothing, fromMaybe) -import qualified Data.Map as M -import qualified Data.Foldable as F -import qualified Data.Traversable as T - import Control.Arrow ((&&&)) import Control.Monad (replicateM, forM, void) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class -import Language.PureScript.Crash +import Data.List ((\\), delete, intersect) +import Data.Maybe (isNothing, fromMaybe) +import qualified Data.Foldable as F +import qualified Data.Map as M +import qualified Data.Traversable as T + import Language.PureScript.AST.SourcePos import Language.PureScript.CodeGen.JS.AST as AST import Language.PureScript.CodeGen.JS.Common as Common +import Language.PureScript.CodeGen.JS.Optimizer import Language.PureScript.CoreFn -import Language.PureScript.Names +import Language.PureScript.Crash import Language.PureScript.Errors -import Language.PureScript.CodeGen.JS.Optimizer +import Language.PureScript.Names import Language.PureScript.Options import Language.PureScript.Traversals (sndM) import qualified Language.PureScript.Constants as C diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index dd9a69a4dd..abc722ea8e 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -3,14 +3,13 @@ -- module Language.PureScript.CodeGen.JS.AST where -import Prelude () import Prelude.Compat import Control.Monad.Identity +import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.Comments import Language.PureScript.Traversals -import Language.PureScript.AST (SourceSpan(..)) -- | -- Built-in unary operators diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 720d829aea..bcfb48b82d 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -3,6 +3,8 @@ -- module Language.PureScript.CodeGen.JS.Common where +import Prelude.Compat + import Data.Char import Data.List (intercalate) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs index d270949456..2ee3a82284 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} - -- | -- This module optimizes code in the simplified-Javascript intermediate representation. -- @@ -23,22 +21,20 @@ -- module Language.PureScript.CodeGen.JS.Optimizer (optimize) where -import Prelude () import Prelude.Compat import Control.Monad.Reader (MonadReader, ask, asks) import Control.Monad.Supply.Class (MonadSupply) import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.Options -import qualified Language.PureScript.Constants as C - +import Language.PureScript.CodeGen.JS.Optimizer.Blocks import Language.PureScript.CodeGen.JS.Optimizer.Common -import Language.PureScript.CodeGen.JS.Optimizer.TCO -import Language.PureScript.CodeGen.JS.Optimizer.MagicDo import Language.PureScript.CodeGen.JS.Optimizer.Inliner +import Language.PureScript.CodeGen.JS.Optimizer.MagicDo +import Language.PureScript.CodeGen.JS.Optimizer.TCO import Language.PureScript.CodeGen.JS.Optimizer.Unused -import Language.PureScript.CodeGen.JS.Optimizer.Blocks +import Language.PureScript.Options +import qualified Language.PureScript.Constants as C -- | -- Apply a series of optimizer passes to simplified Javascript code diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs index 2abd781d68..1c80799e22 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs @@ -1,23 +1,13 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen.JS.Optimizer.Blocks --- Copyright : (c) Phil Freeman 2013-14 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Optimizer steps for simplifying Javascript blocks -- ------------------------------------------------------------------------------ - module Language.PureScript.CodeGen.JS.Optimizer.Blocks ( collapseNestedBlocks , collapseNestedIfs ) where +import Prelude.Compat + import Language.PureScript.CodeGen.JS.AST -- | diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs index 25cb33145f..951b1b4ca6 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs @@ -3,6 +3,8 @@ -- module Language.PureScript.CodeGen.JS.Optimizer.Common where +import Prelude.Compat + import Data.Maybe (fromMaybe) import Language.PureScript.Crash diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index b4b421bd41..e8472e591c 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -12,16 +12,16 @@ module Language.PureScript.CodeGen.JS.Optimizer.Inliner , evaluateIifes ) where -import Prelude () import Prelude.Compat import Control.Monad.Supply.Class (MonadSupply, freshName) + import Data.Maybe (fromMaybe) import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Common -import Language.PureScript.Names import Language.PureScript.CodeGen.JS.Optimizer.Common +import Language.PureScript.Names import qualified Language.PureScript.Constants as C -- TODO: Potential bug: diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs index 30edbf0af9..3cf0096a94 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs @@ -4,6 +4,8 @@ -- module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (magicDo) where +import Prelude.Compat + import Data.List (nub) import Data.Maybe (fromJust, isJust) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs index 8cff91010c..c1b261ead9 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs @@ -1,20 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen.JS.Optimizer.TCO --- Copyright : (c) Phil Freeman 2013-14 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- This module implements tail call elimination. -- ------------------------------------------------------------------------------ - module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where +import Prelude.Compat + import Data.Monoid import Language.PureScript.Options diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs index 0f3d851519..942414b15d 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs @@ -1,27 +1,16 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CodeGen.JS.Optimizer.Unused --- Copyright : (c) Phil Freeman 2013-14 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Removes unused variables -- ------------------------------------------------------------------------------ - module Language.PureScript.CodeGen.JS.Optimizer.Unused ( removeCodeAfterReturnStatements , removeUnusedArg , removeUndefinedApp ) where +import Prelude.Compat + import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Optimizer.Common - import qualified Language.PureScript.Constants as C removeCodeAfterReturnStatements :: JS -> JS diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs index 2e72595f98..3bc00ce4f3 100644 --- a/src/Language/PureScript/Comments.hs +++ b/src/Language/PureScript/Comments.hs @@ -5,6 +5,8 @@ -- module Language.PureScript.Comments where +import Prelude.Compat + import Data.Aeson.TH data Comment diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 6f4567e7c7..61e35e8384 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PatternSynonyms #-} - -- | Various constants which refer to things in the Prelude module Language.PureScript.Constants where +import Prelude.Compat + import Language.PureScript.Names -- Operators diff --git a/src/Language/PureScript/CoreFn.hs b/src/Language/PureScript/CoreFn.hs index ffebd2efa7..7675a8791f 100644 --- a/src/Language/PureScript/CoreFn.hs +++ b/src/Language/PureScript/CoreFn.hs @@ -5,11 +5,11 @@ module Language.PureScript.CoreFn ( module C ) where +import Language.PureScript.AST.Literals as C import Language.PureScript.CoreFn.Ann as C import Language.PureScript.CoreFn.Binders as C import Language.PureScript.CoreFn.Desugar as C import Language.PureScript.CoreFn.Expr as C -import Language.PureScript.AST.Literals as C import Language.PureScript.CoreFn.Meta as C import Language.PureScript.CoreFn.Module as C import Language.PureScript.CoreFn.Traversals as C diff --git a/src/Language/PureScript/CoreFn/Ann.hs b/src/Language/PureScript/CoreFn/Ann.hs index d75c84f8e0..823a7558ff 100644 --- a/src/Language/PureScript/CoreFn/Ann.hs +++ b/src/Language/PureScript/CoreFn/Ann.hs @@ -1,37 +1,25 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CoreFn.Ann --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | Type alias for basic annotations --- ------------------------------------------------------------------------------ - -module Language.PureScript.CoreFn.Ann where - -import Language.PureScript.AST.SourcePos -import Language.PureScript.CoreFn.Meta -import Language.PureScript.Types -import Language.PureScript.Comments - --- | --- Type alias for basic annotations --- -type Ann = (Maybe SourceSpan, [Comment], Maybe Type, Maybe Meta) - --- | --- Initial annotation with no metadata --- -nullAnn :: Ann -nullAnn = (Nothing, [], Nothing, Nothing) - --- | --- Remove the comments from an annotation --- -removeComments :: Ann -> Ann -removeComments (ss, _, ty, meta) = (ss, [], ty, meta) +module Language.PureScript.CoreFn.Ann where + +import Prelude.Compat + +import Language.PureScript.AST.SourcePos +import Language.PureScript.Comments +import Language.PureScript.CoreFn.Meta +import Language.PureScript.Types + +-- | +-- Type alias for basic annotations +-- +type Ann = (Maybe SourceSpan, [Comment], Maybe Type, Maybe Meta) + +-- | +-- Initial annotation with no metadata +-- +nullAnn :: Ann +nullAnn = (Nothing, [], Nothing, Nothing) + +-- | +-- Remove the comments from an annotation +-- +removeComments :: Ann -> Ann +removeComments (ss, _, ty, meta) = (ss, [], ty, meta) diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index 7f6623bd58..5ef7061540 100644 --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE DeriveFunctor #-} - -- | -- The core functional representation for binders -- module Language.PureScript.CoreFn.Binders where +import Prelude.Compat + import Language.PureScript.AST.Literals import Language.PureScript.Names diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index f3fdc64b33..c9d1039eb8 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,30 +1,28 @@ module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where -import Prelude () import Prelude.Compat +import Control.Arrow (second, (***)) import Data.Function (on) import Data.List (sort, sortBy, nub) import Data.Maybe (mapMaybe) import qualified Data.Map as M -import Control.Arrow (second, (***)) - -import Language.PureScript.Crash +import Language.PureScript.AST.Literals import Language.PureScript.AST.SourcePos import Language.PureScript.AST.Traversals +import Language.PureScript.Comments import Language.PureScript.CoreFn.Ann import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Expr -import Language.PureScript.AST.Literals import Language.PureScript.CoreFn.Meta import Language.PureScript.CoreFn.Module +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Names import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDictionaryNames) import Language.PureScript.Types -import Language.PureScript.Comments import qualified Language.PureScript.AST as A -- | diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index 961c70b3a3..4d7ae02aeb 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE DeriveFunctor #-} - -- | -- The core functional representation -- module Language.PureScript.CoreFn.Expr where +import Prelude.Compat + import Control.Arrow ((***)) -import Language.PureScript.CoreFn.Binders import Language.PureScript.AST.Literals +import Language.PureScript.CoreFn.Binders import Language.PureScript.Names -- | diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs index da583aeed7..220d474f0e 100644 --- a/src/Language/PureScript/CoreFn/Meta.hs +++ b/src/Language/PureScript/CoreFn/Meta.hs @@ -3,6 +3,8 @@ -- module Language.PureScript.CoreFn.Meta where +import Prelude.Compat + import Language.PureScript.Names -- | diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index 383c9ca40b..52f4f90bd6 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -1,24 +1,15 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.CoreFn.Module --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | The CoreFn module representation --- ------------------------------------------------------------------------------ - module Language.PureScript.CoreFn.Module where +import Prelude.Compat + import Language.PureScript.Comments import Language.PureScript.CoreFn.Expr import Language.PureScript.Names import Language.PureScript.Types +-- | +-- The CoreFn module representation +-- data Module a = Module { moduleComments :: [Comment] , moduleName :: ModuleName diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs index 613062ef25..20b0cd320f 100644 --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -3,11 +3,13 @@ -- module Language.PureScript.CoreFn.Traversals where +import Prelude.Compat + import Control.Arrow (second, (***), (+++)) +import Language.PureScript.AST.Literals import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Expr -import Language.PureScript.AST.Literals everywhereOnValues :: (Bind a -> Bind a) -> (Expr a -> Expr a) -> diff --git a/src/Language/PureScript/Crash.hs b/src/Language/PureScript/Crash.hs index ab4cdc1b58..4acdea1e98 100644 --- a/src/Language/PureScript/Crash.hs +++ b/src/Language/PureScript/Crash.hs @@ -1,9 +1,11 @@ -module Language.PureScript.Crash where - --- | Exit with an error message and a crash report link. -internalError :: String -> a -internalError = - error - . ("An internal error ocurred during compilation: " ++) - . (++ "\nPlease report this at https://github.com/purescript/purescript/issues") - . show +module Language.PureScript.Crash where + +import Prelude.Compat + +-- | Exit with an error message and a crash report link. +internalError :: String -> a +internalError = + error + . ("An internal error ocurred during compilation: " ++) + . (++ "\nPlease report this at https://github.com/purescript/purescript/issues") + . show diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs index bd84e8b942..9297000d8d 100644 --- a/src/Language/PureScript/Docs.hs +++ b/src/Language/PureScript/Docs.hs @@ -6,9 +6,9 @@ module Language.PureScript.Docs ( module Docs ) where -import Language.PureScript.Docs.Types as Docs -import Language.PureScript.Docs.RenderedCode.Types as Docs -import Language.PureScript.Docs.RenderedCode.Render as Docs import Language.PureScript.Docs.Convert as Docs -import Language.PureScript.Docs.Render as Docs import Language.PureScript.Docs.ParseAndBookmark as Docs +import Language.PureScript.Docs.Render as Docs +import Language.PureScript.Docs.RenderedCode.Render as Docs +import Language.PureScript.Docs.RenderedCode.Types as Docs +import Language.PureScript.Docs.Types as Docs diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 8cd8c0b8ce..9b3650e73f 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} - module Language.PureScript.Docs.AsMarkdown ( renderModulesAsMarkdown , Docs @@ -9,19 +6,18 @@ module Language.PureScript.Docs.AsMarkdown , codeToString ) where -import Prelude () import Prelude.Compat import Control.Monad (unless, zipWithM_) -import Control.Monad.Writer (Writer, tell, execWriter) import Control.Monad.Error.Class (MonadError) +import Control.Monad.Writer (Writer, tell, execWriter) + import Data.Foldable (for_) import Data.List (partition) -import qualified Language.PureScript as P - -import Language.PureScript.Docs.Types import Language.PureScript.Docs.RenderedCode +import Language.PureScript.Docs.Types +import qualified Language.PureScript as P import qualified Language.PureScript.Docs.Convert as Convert import qualified Language.PureScript.Docs.Render as Render diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 76f604d335..404b488d27 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -- | Functions for converting PureScript ASTs into values of the data types -- from Language.PureScript.Docs. @@ -11,24 +9,23 @@ module Language.PureScript.Docs.Convert , collectBookmarks ) where -import Prelude () import Prelude.Compat import Control.Arrow ((&&&), second) import Control.Category ((>>>)) import Control.Monad +import Control.Monad.Error.Class (MonadError) import Control.Monad.State (runStateT) import Control.Monad.Writer.Strict (runWriterT) -import Control.Monad.Error.Class (MonadError) import qualified Data.Map as Map -import Text.Parsec (eof) -import qualified Language.PureScript as P -import qualified Language.PureScript.Constants as C - import Language.PureScript.Docs.Convert.ReExports (updateReExports) import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks) import Language.PureScript.Docs.Types +import qualified Language.PureScript as P +import qualified Language.PureScript.Constants as C + +import Text.Parsec (eof) -- | -- Like convertModules, except that it takes a list of modules, together with diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index f24a45ebef..cba223ddc1 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -1,29 +1,24 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} - module Language.PureScript.Docs.Convert.ReExports ( updateReExports ) where -import Prelude () import Prelude.Compat +import Control.Arrow ((&&&), first, second) import Control.Monad -import Control.Monad.Trans.State.Strict (execState) +import Control.Monad.Reader.Class (MonadReader, ask) import Control.Monad.State.Class (MonadState, gets, modify) import Control.Monad.Trans.Reader (runReaderT) -import Control.Monad.Reader.Class (MonadReader, ask) -import Control.Arrow ((&&&), first, second) +import Control.Monad.Trans.State.Strict (execState) + import Data.Either -import Data.Maybe (mapMaybe) import Data.Map (Map) -import qualified Data.Map as Map +import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) - -import qualified Language.PureScript as P +import qualified Data.Map as Map import Language.PureScript.Docs.Types +import qualified Language.PureScript as P -- | -- Given: diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 8a09842d6d..ac3328fd51 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -1,26 +1,21 @@ -{-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleContexts #-} module Language.PureScript.Docs.Convert.Single ( convertSingleModule , collectBookmarks ) where -import Prelude () import Prelude.Compat -import Data.Maybe (mapMaybe, isNothing) -import Control.Monad import Control.Category ((>>>)) +import Control.Monad + import Data.Either import Data.List (nub, isPrefixOf, isSuffixOf) - -import qualified Language.PureScript as P +import Data.Maybe (mapMaybe, isNothing) import Language.PureScript.Docs.Types +import qualified Language.PureScript as P -- | -- Convert a single Module, but ignore re-exports; any re-exported types or diff --git a/src/Language/PureScript/Docs/ParseAndBookmark.hs b/src/Language/PureScript/Docs/ParseAndBookmark.hs index bea862dc84..a0dc8fe699 100644 --- a/src/Language/PureScript/Docs/ParseAndBookmark.hs +++ b/src/Language/PureScript/Docs/ParseAndBookmark.hs @@ -1,26 +1,22 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} - module Language.PureScript.Docs.ParseAndBookmark ( parseAndBookmark ) where -import Prelude () import Prelude.Compat -import qualified Data.Map as M import Control.Arrow (first) - import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) -import Web.Bower.PackageMeta (PackageName) +import qualified Data.Map as M + +import Language.PureScript.Docs.Convert (collectBookmarks) +import Language.PureScript.Docs.Types +import qualified Language.PureScript as P import System.IO.UTF8 (readUTF8File) -import qualified Language.PureScript as P -import Language.PureScript.Docs.Types -import Language.PureScript.Docs.Convert (collectBookmarks) +import Web.Bower.PackageMeta (PackageName) -- | -- Given: diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 17dc3c2f4e..f65f8e7887 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE RecordWildCards #-} - --- | Functions for creating `RenderedCode` values from data types in +-- | +-- Functions for creating `RenderedCode` values from data types in -- Language.PureScript.Docs.Types. -- -- These functions are the ones that are used in markdown/html documentation @@ -10,13 +9,15 @@ module Language.PureScript.Docs.Render where +import Prelude.Compat + import Data.Maybe (maybeToList) import Data.Monoid ((<>)) -import qualified Language.PureScript as P -import Language.PureScript.Docs.Types import Language.PureScript.Docs.RenderedCode +import Language.PureScript.Docs.Types import Language.PureScript.Docs.Utils.MonoidExtras +import qualified Language.PureScript as P renderDeclaration :: Declaration -> RenderedCode renderDeclaration = renderDeclarationWithOptions defaultRenderTypeOptions diff --git a/src/Language/PureScript/Docs/RenderedCode.hs b/src/Language/PureScript/Docs/RenderedCode.hs index d9008a6d49..27de533309 100644 --- a/src/Language/PureScript/Docs/RenderedCode.hs +++ b/src/Language/PureScript/Docs/RenderedCode.hs @@ -1,11 +1,8 @@ - --- | Data types and functions for representing a simplified form of PureScript --- code, intended for use in e.g. HTML documentation. - -module Language.PureScript.Docs.RenderedCode ( - module RenderedCode -) where - -import Language.PureScript.Docs.RenderedCode.Types as RenderedCode -import Language.PureScript.Docs.RenderedCode.Render as RenderedCode - + +-- | Data types and functions for representing a simplified form of PureScript +-- code, intended for use in e.g. HTML documentation. + +module Language.PureScript.Docs.RenderedCode (module RenderedCode) where + +import Language.PureScript.Docs.RenderedCode.Types as RenderedCode +import Language.PureScript.Docs.RenderedCode.Render as RenderedCode diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index 55413b8cf6..16ff7c6910 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -1,33 +1,31 @@ -- | Functions for producing RenderedCode values from PureScript Type values. -module Language.PureScript.Docs.RenderedCode.Render ( - renderType, - renderTypeAtom, - renderRow, - renderKind, - RenderTypeOptions(..), - defaultRenderTypeOptions, - renderTypeWithOptions -) where - -import Prelude () +module Language.PureScript.Docs.RenderedCode.Render + ( renderType + , renderTypeAtom + , renderRow + , renderKind + , RenderTypeOptions(..) + , defaultRenderTypeOptions + , renderTypeWithOptions + ) where + import Prelude.Compat -import Data.Monoid ((<>)) import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) import Control.Arrow ((<+>)) -import Control.PatternArrows +import Control.PatternArrows as PA import Language.PureScript.Crash -import Language.PureScript.Names -import Language.PureScript.Types -import Language.PureScript.Kinds -import Language.PureScript.Pretty.Kinds -import Language.PureScript.Environment - import Language.PureScript.Docs.RenderedCode.Types import Language.PureScript.Docs.Utils.MonoidExtras +import Language.PureScript.Environment +import Language.PureScript.Kinds +import Language.PureScript.Names +import Language.PureScript.Pretty.Kinds +import Language.PureScript.Types typeLiterals :: Pattern () Type RenderedCode typeLiterals = mkPattern match @@ -184,9 +182,10 @@ renderKind = kind . prettyPrintKind -- Render code representing a Type, as it should appear inside parentheses -- renderTypeAtom :: Type -> RenderedCode -renderTypeAtom = - fromMaybe (internalError "Incomplete pattern") . pattern matchTypeAtom () . preprocessType defaultRenderTypeOptions - +renderTypeAtom + = fromMaybe (internalError "Incomplete pattern") + . PA.pattern matchTypeAtom () + . preprocessType defaultRenderTypeOptions -- | -- Render code representing a Type @@ -207,5 +206,7 @@ defaultRenderTypeOptions = } renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode -renderTypeWithOptions opts = - fromMaybe (internalError "Incomplete pattern") . pattern matchType () . preprocessType opts +renderTypeWithOptions opts + = fromMaybe (internalError "Incomplete pattern") + . PA.pattern matchType () + . preprocessType opts diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 8c5289d428..63f837ead2 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -32,13 +32,13 @@ module Language.PureScript.Docs.RenderedCode.Types , keywordFixity ) where -import Prelude () import Prelude.Compat -import qualified Data.Aeson as A -import Data.Aeson.BetterErrors import Control.Monad.Error.Class (MonadError(..)) +import Data.Aeson.BetterErrors +import qualified Data.Aeson as A + import qualified Language.PureScript as P -- | diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index f1e11151dc..b736eb792d 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RankNTypes #-} module Language.PureScript.Docs.Types ( module Language.PureScript.Docs.Types @@ -9,25 +6,26 @@ module Language.PureScript.Docs.Types ) where -import Prelude () import Prelude.Compat import Control.Arrow (first, (***)) import Control.Monad (when) -import Data.Maybe (mapMaybe) -import Data.Version + import Data.Aeson ((.=)) -import qualified Data.Aeson as A import Data.Aeson.BetterErrors -import Text.ParserCombinators.ReadP (readP_to_S) -import Data.Text (Text) import Data.ByteString.Lazy (ByteString) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Version +import qualified Data.Aeson as A import qualified Data.Text as T -import Web.Bower.PackageMeta hiding (Version, displayError) - import qualified Language.PureScript as P +import Text.ParserCombinators.ReadP (readP_to_S) + +import Web.Bower.PackageMeta hiding (Version, displayError) + import Language.PureScript.Docs.RenderedCode as ReExports (RenderedCode, asRenderedCode, ContainingModule(..), asContainingModule, diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 56f48f0202..fbf6a2d211 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -3,11 +3,13 @@ module Language.PureScript.Environment where -import Data.Maybe (fromMaybe) +import Prelude.Compat + import Data.Aeson.TH +import Data.Maybe (fromMaybe) +import qualified Data.Aeson as A import qualified Data.Map as M import qualified Data.Text as T -import qualified Data.Aeson as A import Language.PureScript.Crash import Language.PureScript.Kinds diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 063e6c8af7..8133a91afc 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1,41 +1,36 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} module Language.PureScript.Errors where -import Prelude () import Prelude.Compat -import Data.Ord (comparing) +import Control.Arrow ((&&&)) +import Control.Monad +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Trans.State.Lazy +import Control.Monad.Writer + import Data.Char (isSpace) import Data.Either (lefts, rights) -import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition) import Data.Foldable (fold) +import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition) import Data.Maybe (maybeToList) - +import Data.Ord (comparing) import qualified Data.Map as M -import Control.Monad -import Control.Monad.Writer -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Trans.State.Lazy -import Control.Arrow ((&&&)) - -import Language.PureScript.Crash import Language.PureScript.AST +import Language.PureScript.Crash +import Language.PureScript.Kinds +import Language.PureScript.Names import Language.PureScript.Pretty import Language.PureScript.Types -import Language.PureScript.Names -import Language.PureScript.Kinds -import qualified Language.PureScript.Constants as C import qualified Language.PureScript.Bundle as Bundle - -import qualified Text.PrettyPrint.Boxes as Box +import qualified Language.PureScript.Constants as C import qualified Text.Parsec as P import qualified Text.Parsec.Error as PE +import qualified Text.PrettyPrint.Boxes as Box import Text.Parsec.Error (Message(..)) -- | A type of error messages diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index 8bfcd3940b..9b7733b46b 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -1,22 +1,7 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Errors.JSON --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - {-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Errors.JSON where -import Prelude () import Prelude.Compat import qualified Data.Aeson.TH as A diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index f2de40f27c..21863db847 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} -- | --- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations. +-- This module generates code for \"externs\" files, i.e. files containing only +-- foreign import declarations. -- module Language.PureScript.Externs ( ExternsFile(..) @@ -14,24 +13,22 @@ module Language.PureScript.Externs , applyExternsFileToEnvironment ) where -import Prelude () import Prelude.Compat +import Data.Aeson.TH +import Data.Foldable (fold) import Data.List (find, foldl') import Data.Maybe (mapMaybe, maybeToList, fromMaybe) -import Data.Foldable (fold) import Data.Version (showVersion) -import Data.Aeson.TH - import qualified Data.Map as M -import Language.PureScript.Crash import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Environment -import Language.PureScript.Names -import Language.PureScript.Types import Language.PureScript.Kinds +import Language.PureScript.Names import Language.PureScript.TypeClassDictionaries +import Language.PureScript.Types import Paths_purescript as Paths diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index dd513256b0..65d2e083eb 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -12,13 +12,9 @@ -- Interface for the psc-ide-server ----------------------------------------------------------------------------- -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} module Language.PureScript.Ide ( handleCommand diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 450ba5f05c..53e1db02da 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -12,14 +12,8 @@ -- Casesplitting and adding function clauses ----------------------------------------------------------------------------- -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE RecordWildCards #-} module Language.PureScript.Ide.CaseSplit ( WildcardAnnotations() diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 3fd90caba5..12d65427ef 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -12,9 +12,7 @@ -- Datatypes for the commands psc-ide accepts ----------------------------------------------------------------------------- -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Ide.Command where diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index eba509f829..58b4078da4 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -17,6 +17,7 @@ module Language.PureScript.Ide.Error (ErrorMsg, PscIdeError(..), textError) where +import Prelude.Compat import Data.Aeson import Data.Monoid import Data.Text (Text, pack) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index a08272240c..788d482958 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -12,11 +12,7 @@ -- Handles externs files for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Ide.Externs ( ExternDecl(..), diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 8055e36493..c1c91cbb17 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -14,7 +14,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Ide.Filter ( Filter diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 817b0d4907..a364388776 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -12,10 +12,6 @@ -- Provides functionality to manage imports ----------------------------------------------------------------------------- -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} @@ -34,6 +30,7 @@ module Language.PureScript.Ide.Imports ) where +import Prelude.Compat import Control.Applicative ((<|>)) import Control.Monad.Error.Class import Control.Monad.IO.Class diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index d99a36ef6d..ad71ff6ab2 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -14,7 +14,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Ide.Matcher ( Matcher diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs index 7a9eb9da7f..b8a8b50139 100644 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -13,7 +13,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Ide.Pursuit where diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 78e9aa2527..e089cb8b7b 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -1,13 +1,10 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} module Language.PureScript.Ide.Rebuild where +import Prelude.Compat + import Language.PureScript.Ide.Error import Language.PureScript.Ide.State import Language.PureScript.Ide.Types diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 2ab8a851e8..4bcce8ef83 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -14,8 +14,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} module Language.PureScript.Ide.Reexports where diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index f142428d86..8297a20144 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -12,8 +12,6 @@ -- Getting declarations from PureScript sourcefiles ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.SourceFile where diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 12516b189a..d4960ad1ee 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -12,13 +12,9 @@ -- Functions to access psc-ide's state ----------------------------------------------------------------------------- -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} module Language.PureScript.Ide.State where diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 1f6d02b64e..0c80a02a87 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -12,11 +12,7 @@ -- Type definitions for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Ide.Types where diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index d963282b55..88138566cb 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -16,6 +16,7 @@ module Language.PureScript.Ide.Util where +import Prelude.Compat import Data.Aeson import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index f9876b1c66..4309e7606e 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -2,7 +2,6 @@ module Language.PureScript.Kinds where -import Prelude () import Prelude.Compat import qualified Data.Aeson.TH as A diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 691c1b7045..80a4800a36 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -1,30 +1,24 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PatternGuards #-} - -- | -- This module implements a simple linting pass on the PureScript AST. -- module Language.PureScript.Linter (lint, module L) where -import Prelude () import Prelude.Compat +import Control.Monad.Writer.Class + import Data.List (nub, (\\)) import Data.Maybe (mapMaybe) import Data.Monoid - import qualified Data.Set as S -import Control.Monad.Writer.Class - -import Language.PureScript.Crash import Language.PureScript.AST -import Language.PureScript.Names +import Language.PureScript.Crash import Language.PureScript.Errors -import Language.PureScript.Types import Language.PureScript.Linter.Exhaustive as L import Language.PureScript.Linter.Imports as L +import Language.PureScript.Names +import Language.PureScript.Types -- | Lint the PureScript AST. -- | diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index a8ed8e2362..e33b18d0ee 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- | -- Module for exhaustivity checking over pattern matching definitions -- The algorithm analyses the clauses of a definition one by one from top @@ -11,31 +8,30 @@ module Language.PureScript.Linter.Exhaustive ( checkExhaustiveExpr ) where -import Prelude () import Prelude.Compat -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.List (foldl', sortBy, nub) -import Data.Function (on) - -import Control.Monad (unless) import Control.Applicative import Control.Arrow (first, second) +import Control.Monad (unless) import Control.Monad.Writer.Class -import Language.PureScript.Crash -import qualified Language.PureScript.Constants as C +import Data.Function (on) +import Data.List (foldl', sortBy, nub) +import Data.Maybe (fromMaybe) +import qualified Data.Map as M + import Language.PureScript.AST.Binders -import Language.PureScript.AST.Literals import Language.PureScript.AST.Declarations +import Language.PureScript.AST.Literals +import Language.PureScript.Crash import Language.PureScript.Environment -import Language.PureScript.Names as P +import Language.PureScript.Errors import Language.PureScript.Kinds +import Language.PureScript.Names as P import Language.PureScript.Pretty.Values (prettyPrintBinderAtom) import Language.PureScript.Traversals import Language.PureScript.Types as P -import Language.PureScript.Errors +import qualified Language.PureScript.Constants as C -- | There are two modes of failure for the redundancy check: -- diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 855327ef8b..b265d40bb3 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -1,13 +1,9 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} - module Language.PureScript.Linter.Imports ( lintImports , Name(..) , UsedImports() ) where -import Prelude () import Prelude.Compat import Control.Monad (unless, when) @@ -23,12 +19,10 @@ import qualified Data.Map as M import Language.PureScript.AST.Declarations import Language.PureScript.AST.SourcePos import Language.PureScript.Crash -import Language.PureScript.Names as P - import Language.PureScript.Errors +import Language.PureScript.Names as P import Language.PureScript.Sugar.Names.Env import Language.PureScript.Sugar.Names.Imports - import qualified Language.PureScript.Constants as C -- | Imported name used in some type or expression. diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 1aa1187a87..4d47a208f6 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -1,10 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module Language.PureScript.Make @@ -23,56 +17,41 @@ module Language.PureScript.Make , buildMakeActions ) where -import Prelude () import Prelude.Compat import Control.Applicative ((<|>)) +import Control.Concurrent.Lifted as C import Control.Monad hiding (sequence) +import Control.Monad.Base (MonadBase(..)) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Except import Control.Monad.IO.Class -import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) import Control.Monad.Logger +import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) import Control.Monad.Supply -import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Control.Monad.Trans.Except +import Control.Monad.Writer.Class (MonadWriter(..)) -import Control.Concurrent.Lifted as C - +import Data.Aeson (encode, decode) +import Data.Either (partitionEithers) +import Data.Foldable (for_) import Data.List (foldl', sort) import Data.Maybe (fromMaybe, catMaybes) -import Data.Either (partitionEithers) -import Data.Time.Clock import Data.String (fromString) -import Data.Foldable (for_) +import Data.Time.Clock import Data.Traversable (for) import Data.Version (showVersion) -import Data.Aeson (encode, decode) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.UTF8 as BU8 -import qualified Data.Set as S import qualified Data.Map as M +import qualified Data.Set as S -import qualified Text.Parsec as Parsec - -import SourceMap.Types -import SourceMap - -import System.Directory - (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) -import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise) -import System.IO.Error (tryIOError) -import System.IO.UTF8 (readUTF8File, writeUTF8File) - -import qualified Language.JavaScript.Parser as JS - -import Language.PureScript.Crash import Language.PureScript.AST -import Language.PureScript.Externs +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors +import Language.PureScript.Externs import Language.PureScript.Linter import Language.PureScript.ModuleDependencies import Language.PureScript.Names @@ -82,14 +61,25 @@ import Language.PureScript.Pretty.Common(SMap(..)) import Language.PureScript.Renamer import Language.PureScript.Sugar import Language.PureScript.TypeChecker -import qualified Language.PureScript.Constants as C +import qualified Language.JavaScript.Parser as JS import qualified Language.PureScript.Bundle as Bundle -import qualified Language.PureScript.Parser as PSParser - import qualified Language.PureScript.CodeGen.JS as J +import qualified Language.PureScript.Constants as C import qualified Language.PureScript.CoreFn as CF +import qualified Language.PureScript.Parser as PSParser + import qualified Paths_purescript as Paths +import SourceMap +import SourceMap.Types + +import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) +import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise) +import System.IO.Error (tryIOError) +import System.IO.UTF8 (readUTF8File, writeUTF8File) + +import qualified Text.Parsec as Parsec + -- | Progress messages from the make process data ProgressMessage = CompilingModule ModuleName diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 2bff74a8a4..1c14c51254 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE FlexibleContexts #-} - -- | -- Provides the ability to sort modules based on module dependencies -- -module Language.PureScript.ModuleDependencies ( - sortModules, - ModuleGraph -) where +module Language.PureScript.ModuleDependencies + ( sortModules + , ModuleGraph + ) where + +import Prelude.Compat import Control.Monad.Error.Class (MonadError(..)) @@ -14,11 +14,11 @@ import Data.Graph import Data.List (nub) import Data.Maybe (fromMaybe) -import Language.PureScript.Crash import Language.PureScript.AST +import Language.PureScript.Crash +import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Types -import Language.PureScript.Errors -- | A list of modules with their transitive dependencies type ModuleGraph = [(ModuleName, [ModuleName])] diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 99a55c771f..1326a8c8fe 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -1,19 +1,18 @@ -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE KindSignatures #-} -- | -- Data types for names -- module Language.PureScript.Names where +import Prelude.Compat + import Control.Monad (liftM) import Control.Monad.Supply.Class -import Data.List import Data.Aeson import Data.Aeson.TH +import Data.List -- | -- Names for value identifiers diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index a207a923f5..5fb0fdc8ae 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -1,20 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Options --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- The data type of compiler options -- ------------------------------------------------------------------------------ - module Language.PureScript.Options where +import Prelude.Compat + -- | -- The data type of compiler options -- diff --git a/src/Language/PureScript/Parser.hs b/src/Language/PureScript/Parser.hs index a301ce6e34..f2172b2a94 100644 --- a/src/Language/PureScript/Parser.hs +++ b/src/Language/PureScript/Parser.hs @@ -1,36 +1,24 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Parser --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | --- A collection of parsers for core data types: --- --- [@Language.PureScript.Parser.Kinds@] Parser for kinds --- --- [@Language.PureScript.Parser.Values@] Parser for values --- --- [@Language.PureScript.Parser.Types@] Parser for types --- --- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules --- --- [@Language.PureScript.Parser.State@] Parser state, including indentation --- --- [@Language.PureScript.Parser.Common@] Common parsing utility functions --- ------------------------------------------------------------------------------ - -module Language.PureScript.Parser (module P) where - -import Language.PureScript.Parser.Common as P -import Language.PureScript.Parser.Types as P -import Language.PureScript.Parser.State as P -import Language.PureScript.Parser.Kinds as P -import Language.PureScript.Parser.Lexer as P -import Language.PureScript.Parser.Declarations as P -import Language.PureScript.Parser.JS as P +-- | +-- A collection of parsers for core data types: +-- +-- [@Language.PureScript.Parser.Kinds@] Parser for kinds +-- +-- [@Language.PureScript.Parser.Values@] Parser for values +-- +-- [@Language.PureScript.Parser.Types@] Parser for types +-- +-- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules +-- +-- [@Language.PureScript.Parser.State@] Parser state, including indentation +-- +-- [@Language.PureScript.Parser.Common@] Common parsing utility functions +-- +module Language.PureScript.Parser (module P) where + +import Language.PureScript.Parser.Common as P +import Language.PureScript.Parser.Declarations as P +import Language.PureScript.Parser.JS as P +import Language.PureScript.Parser.Kinds as P +import Language.PureScript.Parser.Lexer as P +import Language.PureScript.Parser.State as P +import Language.PureScript.Parser.Types as P diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index 4a87070748..9005252477 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -1,19 +1,18 @@ -{-# LANGUAGE FlexibleContexts #-} - -- | --- Constants, and utility functions to be used when parsing +-- Constants and utility functions to be used when parsing -- module Language.PureScript.Parser.Common where +import Prelude.Compat + import Control.Applicative import Control.Monad (guard) +import Language.PureScript.AST.SourcePos import Language.PureScript.Comments +import Language.PureScript.Names import Language.PureScript.Parser.Lexer import Language.PureScript.Parser.State -import Language.PureScript.Names - -import Language.PureScript.AST.SourcePos import qualified Text.Parsec as P diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 1368e1f58f..847fb9b058 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -1,22 +1,18 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - -- | -- Parsers for module definitions and declarations -- -module Language.PureScript.Parser.Declarations ( - parseDeclaration, - parseModule, - parseModules, - parseModulesFromFiles, - parseValue, - parseGuard, - parseBinder, - parseBinderNoParens, - parseImportDeclaration', - parseLocalDeclaration -) where +module Language.PureScript.Parser.Declarations + ( parseDeclaration + , parseModule + , parseModules + , parseModulesFromFiles + , parseValue + , parseGuard + , parseBinder + , parseBinderNoParens + , parseImportDeclaration' + , parseLocalDeclaration + ) where import Prelude hiding (lex) @@ -541,7 +537,7 @@ parseBinderAtom = P.choice , parseArrayBinder , ParensInBinder <$> parens parseBinder ] P. "binder" - + -- | -- Parse a binder as it would appear in a top level declaration -- diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs index 7043991705..dd545a8a2e 100644 --- a/src/Language/PureScript/Parser/JS.hs +++ b/src/Language/PureScript/Parser/JS.hs @@ -1,37 +1,23 @@ ------------------------------------------------------------------------------ --- --- Module : Foreign --- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors --- License : MIT --- --- Maintainer : Phil Freeman , Gary Burgess --- Stability : experimental --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} - module Language.PureScript.Parser.JS ( ForeignJS() , parseForeignModulesFromFiles ) where -import Prelude () import Prelude.Compat hiding (lex) import Control.Monad (forM_, when, msum) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) + import Data.Function (on) import Data.List (sortBy, groupBy) +import qualified Data.Map as M + import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Parser.Common import Language.PureScript.Parser.Lexer -import qualified Data.Map as M + import qualified Text.Parsec as PS type ForeignJS = String diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs index ef67827d25..f3e97c49e8 100644 --- a/src/Language/PureScript/Parser/Kinds.hs +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -1,28 +1,14 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Parser.Kinds --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- A parser for kinds -- ------------------------------------------------------------------------------ +module Language.PureScript.Parser.Kinds (parseKind) where -module Language.PureScript.Parser.Kinds ( - parseKind -) where - -import Prelude () import Prelude.Compat import Language.PureScript.Kinds import Language.PureScript.Parser.Common import Language.PureScript.Parser.Lexer + import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 63d8bf5b31..5a15ca2af0 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -1,20 +1,6 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Parser.Lexer --- Copyright : (c) Phil Freeman 2014 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- The first step in the parsing process - turns source code into a list of lexemes -- ------------------------------------------------------------------------------ - -{-# LANGUAGE TupleSections #-} - module Language.PureScript.Parser.Lexer ( PositionedToken(..) , Token() @@ -75,15 +61,14 @@ module Language.PureScript.Parser.Lexer import Prelude hiding (lex) -import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum) - +import Control.Applicative import Control.Monad (void, guard) -import Data.Functor.Identity -import Control.Applicative +import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum) +import Data.Functor.Identity -import Language.PureScript.Parser.State import Language.PureScript.Comments +import Language.PureScript.Parser.State import qualified Text.Parsec as P import qualified Text.Parsec.Token as PT diff --git a/src/Language/PureScript/Parser/State.hs b/src/Language/PureScript/Parser/State.hs index 3bda23b9d3..e72903f16d 100644 --- a/src/Language/PureScript/Parser/State.hs +++ b/src/Language/PureScript/Parser/State.hs @@ -1,20 +1,10 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Parser.State --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- State for the parser monad -- ------------------------------------------------------------------------------ - module Language.PureScript.Parser.State where +import Prelude.Compat + import qualified Text.Parsec as P -- | diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index a2f4a6cd8a..854b067248 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -1,21 +1,22 @@ -module Language.PureScript.Parser.Types ( - parseType, - parsePolyType, - noWildcards, - parseTypeAtom -) where +module Language.PureScript.Parser.Types + ( parseType + , parsePolyType + , noWildcards + , parseTypeAtom + ) where + +import Prelude.Compat import Control.Applicative import Control.Monad (when, unless) +import Language.PureScript.AST.SourcePos +import Language.PureScript.Environment import Language.PureScript.Names -import Language.PureScript.Types import Language.PureScript.Parser.Common import Language.PureScript.Parser.Kinds import Language.PureScript.Parser.Lexer -import Language.PureScript.Environment - -import Language.PureScript.AST.SourcePos +import Language.PureScript.Types import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P diff --git a/src/Language/PureScript/Pretty.hs b/src/Language/PureScript/Pretty.hs index 959fed5f29..b242a0505c 100644 --- a/src/Language/PureScript/Pretty.hs +++ b/src/Language/PureScript/Pretty.hs @@ -1,13 +1,3 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Pretty --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- A collection of pretty printers for core data types: -- @@ -19,11 +9,9 @@ -- -- [@Language.PureScript.Pretty.JS@] Pretty printer for values, used for code generation -- ------------------------------------------------------------------------------ - module Language.PureScript.Pretty (module P) where +import Language.PureScript.Pretty.JS as P import Language.PureScript.Pretty.Kinds as P -import Language.PureScript.Pretty.Values as P import Language.PureScript.Pretty.Types as P -import Language.PureScript.Pretty.JS as P +import Language.PureScript.Pretty.Values as P diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index a6f0f4dff2..3b46082121 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -1,30 +1,18 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Pretty.Common --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- | -- Common pretty-printing utility functions -- ------------------------------------------------------------------------------ - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Language.PureScript.Pretty.Common where -import Prelude () import Prelude.Compat import Control.Monad.State (StateT, modify, get) + import Data.List (elemIndices, intersperse) -import Language.PureScript.Parser.Lexer (reservedPsNames, isUnquotedKey) import Language.PureScript.AST (SourcePos(..), SourceSpan(..)) +import Language.PureScript.Parser.Lexer (reservedPsNames, isUnquotedKey) import Text.PrettyPrint.Boxes diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 5477361640..2b089ea8c5 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -1,45 +1,30 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Pretty.JS --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Pretty printer for the Javascript AST -- ------------------------------------------------------------------------------ +module Language.PureScript.Pretty.JS + ( prettyPrintJS + , prettyPrintJSWithSourceMaps + ) where -module Language.PureScript.Pretty.JS ( - prettyPrintJS, prettyPrintJSWithSourceMaps -) where - -import Prelude () import Prelude.Compat -import Data.Maybe (fromMaybe) - import Control.Arrow ((<+>)) import Control.Monad.State hiding (sequence) import Control.PatternArrows import qualified Control.Arrow as A -import Language.PureScript.Crash +import Data.Maybe (fromMaybe) +import Data.Monoid + +import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Common -import Language.PureScript.Pretty.Common import Language.PureScript.Comments - - -import Language.PureScript.AST (SourceSpan(..)) +import Language.PureScript.Crash +import Language.PureScript.Pretty.Common import Numeric -import Data.Monoid - literals :: (Emit gen) => Pattern PrinterState JS gen literals = mkPattern' match' where diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs index 3ceff6a64f..92c5e8ffc2 100644 --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -1,26 +1,16 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Pretty.Kinds --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Pretty printer for kinds -- ------------------------------------------------------------------------------ +module Language.PureScript.Pretty.Kinds + ( prettyPrintKind + ) where -module Language.PureScript.Pretty.Kinds ( - prettyPrintKind -) where - -import Data.Maybe (fromMaybe) +import Prelude.Compat import Control.Arrow (ArrowPlus(..)) -import Control.PatternArrows +import Control.PatternArrows as PA + +import Data.Maybe (fromMaybe) import Language.PureScript.Crash import Language.PureScript.Kinds @@ -48,7 +38,9 @@ funKind = mkPattern match -- | Generate a pretty-printed string representing a Kind prettyPrintKind :: Kind -> String -prettyPrintKind = fromMaybe (internalError "Incomplete pattern") . pattern matchKind () +prettyPrintKind + = fromMaybe (internalError "Incomplete pattern") + . PA.pattern matchKind () where matchKind :: Pattern () Kind String matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 9124be9b9c..fa6036e987 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -10,18 +10,20 @@ module Language.PureScript.Pretty.Types , prettyPrintRow ) where -import Data.Maybe (fromMaybe) +import Prelude.Compat import Control.Arrow ((<+>)) -import Control.PatternArrows +import Control.PatternArrows as PA + +import Data.Maybe (fromMaybe) import Language.PureScript.Crash -import Language.PureScript.Types -import Language.PureScript.Names +import Language.PureScript.Environment import Language.PureScript.Kinds +import Language.PureScript.Names import Language.PureScript.Pretty.Common import Language.PureScript.Pretty.Kinds -import Language.PureScript.Environment +import Language.PureScript.Types import Text.PrettyPrint.Boxes hiding ((<+>)) @@ -147,14 +149,20 @@ forall_ = mkPattern match match _ = Nothing typeAtomAsBox :: Type -> Box -typeAtomAsBox = fromMaybe (internalError "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders +typeAtomAsBox + = fromMaybe (internalError "Incomplete pattern") + . PA.pattern matchTypeAtom () + . insertPlaceholders -- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses prettyPrintTypeAtom :: Type -> String prettyPrintTypeAtom = render . typeAtomAsBox typeAsBox :: Type -> Box -typeAsBox = fromMaybe (internalError "Incomplete pattern") . pattern matchType () . insertPlaceholders +typeAsBox + = fromMaybe (internalError "Incomplete pattern") + . PA.pattern matchType () + . insertPlaceholders -- | Generate a pretty-printed string representing a Type prettyPrintType :: Type -> String diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 7a63c1a8e6..241a7a09f2 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -1,16 +1,18 @@ -- | -- Pretty printer for values -- -module Language.PureScript.Pretty.Values ( - prettyPrintValue, - prettyPrintBinder, - prettyPrintBinderAtom -) where +module Language.PureScript.Pretty.Values + ( prettyPrintValue + , prettyPrintBinder + , prettyPrintBinderAtom + ) where + +import Prelude.Compat import Control.Arrow (second) -import Language.PureScript.Crash import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Names import Language.PureScript.Pretty.Common import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox) diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 1971672d8b..682e85a543 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Publish ( preparePackage @@ -23,47 +21,46 @@ module Language.PureScript.Publish , getResolvedDependencies ) where -import Prelude () import Prelude.Compat hiding (userError) -import Data.Maybe +import Control.Arrow ((***)) +import Control.Category ((>>>)) +import Control.Exception (catch, try) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Control.Monad.Writer.Strict + +import Data.Aeson.BetterErrors import Data.Char (isSpace) +import Data.Foldable (traverse_) +import Data.Function (on) import Data.List (stripPrefix, isSuffixOf, (\\), nubBy) -import Data.List.Split (splitOn) import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.Split (splitOn) +import Data.Maybe import Data.Version -import Data.Function (on) -import Data.Foldable (traverse_) -import Safe (headMay) -import Data.Aeson.BetterErrors +import qualified Data.SPDX as SPDX import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.SPDX as SPDX -import Control.Category ((>>>)) -import Control.Arrow ((***)) -import Control.Exception (catch, try) -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) -import Control.Monad.Trans.Except -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Strict +import Safe (headMay) import System.Directory (doesFileExist, findExecutable) -import System.Process (readProcess) import System.Exit (exitFailure) import System.FilePath (pathSeparator) +import System.Process (readProcess) import qualified System.FilePath.Glob as Glob import qualified System.Info -import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName, - runPackageName, parsePackageName, Repository(..)) +import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName, runPackageName, parsePackageName, Repository(..)) import qualified Web.Bower.PackageMeta as Bower +import Language.PureScript.Publish.ErrorsWarnings +import Language.PureScript.Publish.Utils import qualified Language.PureScript as P (version) import qualified Language.PureScript.Docs as D -import Language.PureScript.Publish.Utils -import Language.PureScript.Publish.ErrorsWarnings data PublishOptions = PublishOptions { -- | How to obtain the version tag and version that the data being diff --git a/src/Language/PureScript/Publish/BoxesHelpers.hs b/src/Language/PureScript/Publish/BoxesHelpers.hs index 169f094fc4..9a108b65b8 100644 --- a/src/Language/PureScript/Publish/BoxesHelpers.hs +++ b/src/Language/PureScript/Publish/BoxesHelpers.hs @@ -4,7 +4,10 @@ module Language.PureScript.Publish.BoxesHelpers , module Language.PureScript.Publish.BoxesHelpers ) where +import Prelude.Compat + import System.IO (hPutStr, stderr) + import qualified Text.PrettyPrint.Boxes as Boxes width :: Int diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 7702d49439..b68d0ad23d 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Language.PureScript.Publish.ErrorsWarnings ( PackageError(..) @@ -16,26 +15,24 @@ module Language.PureScript.Publish.ErrorsWarnings , renderWarnings ) where -import Prelude () import Prelude.Compat +import Control.Exception (IOException) + import Data.Aeson.BetterErrors -import Data.Version -import Data.Maybe -import Data.Monoid import Data.List (intersperse, intercalate) import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe +import Data.Monoid +import Data.Version import qualified Data.List.NonEmpty as NonEmpty - import qualified Data.Text as T -import Control.Exception (IOException) -import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName, showBowerError) -import qualified Web.Bower.PackageMeta as Bower - +import Language.PureScript.Publish.BoxesHelpers import qualified Language.PureScript as P -import Language.PureScript.Publish.BoxesHelpers +import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName, showBowerError) +import qualified Web.Bower.PackageMeta as Bower -- | An error which meant that it was not possible to retrieve metadata for a -- package. diff --git a/src/Language/PureScript/Publish/Utils.hs b/src/Language/PureScript/Publish/Utils.hs index ddaed997e1..a7a410cef9 100644 --- a/src/Language/PureScript/Publish/Utils.hs +++ b/src/Language/PureScript/Publish/Utils.hs @@ -1,38 +1,41 @@ - -module Language.PureScript.Publish.Utils where - -import Data.List -import Data.Either (partitionEithers) -import System.Directory -import System.Exit (exitFailure) -import System.IO (hPutStrLn, stderr) -import System.FilePath (pathSeparator) -import qualified System.FilePath.Glob as Glob - --- | Glob relative to the current directory, and produce relative pathnames. -globRelative :: Glob.Pattern -> IO [FilePath] -globRelative pat = do - currentDir <- getCurrentDirectory - filesAbsolute <- Glob.globDir1 pat currentDir - let prefix = currentDir ++ [pathSeparator] - let (fails, paths) = partitionEithers . map (stripPrefix' prefix) $ filesAbsolute - if null fails - then return paths - else do - let p = hPutStrLn stderr - p "Internal error in Language.PureScript.Publish.Utils.globRelative" - p "Unmatched files:" - mapM_ p fails - exitFailure - - where - stripPrefix' prefix dir = - maybe (Left dir) Right $ stripPrefix prefix dir - --- | Glob pattern for PureScript source files. -purescriptSourceFiles :: Glob.Pattern -purescriptSourceFiles = Glob.compile "src/**/*.purs" - --- | Glob pattern for PureScript dependency files. -purescriptDepsFiles :: Glob.Pattern -purescriptDepsFiles = Glob.compile "bower_components/*/src/**/*.purs" + +module Language.PureScript.Publish.Utils where + +import Prelude.Compat + +import Data.Either (partitionEithers) +import Data.List + +import System.Directory +import System.Exit (exitFailure) +import System.FilePath (pathSeparator) +import System.IO (hPutStrLn, stderr) +import qualified System.FilePath.Glob as Glob + +-- | Glob relative to the current directory, and produce relative pathnames. +globRelative :: Glob.Pattern -> IO [FilePath] +globRelative pat = do + currentDir <- getCurrentDirectory + filesAbsolute <- Glob.globDir1 pat currentDir + let prefix = currentDir ++ [pathSeparator] + let (fails, paths) = partitionEithers . map (stripPrefix' prefix) $ filesAbsolute + if null fails + then return paths + else do + let p = hPutStrLn stderr + p "Internal error in Language.PureScript.Publish.Utils.globRelative" + p "Unmatched files:" + mapM_ p fails + exitFailure + + where + stripPrefix' prefix dir = + maybe (Left dir) Right $ stripPrefix prefix dir + +-- | Glob pattern for PureScript source files. +purescriptSourceFiles :: Glob.Pattern +purescriptSourceFiles = Glob.compile "src/**/*.purs" + +-- | Glob pattern for PureScript dependency files. +purescriptDepsFiles :: Glob.Pattern +purescriptDepsFiles = Glob.compile "bower_components/*/src/**/*.purs" diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index 3dda3d43a9..6ec0b34a78 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -1,26 +1,20 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- | -- Renaming pass that prevents shadowing of local identifiers. -- module Language.PureScript.Renamer (renameInModules) where -import Prelude () import Prelude.Compat import Control.Monad.State import Data.List (find) import Data.Maybe (fromJust, fromMaybe) - import qualified Data.Map as M import qualified Data.Set as S import Language.PureScript.CoreFn import Language.PureScript.Names import Language.PureScript.Traversals - import qualified Language.PureScript.Constants as C -- | diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 1f5ebefc75..694f0372c7 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -1,35 +1,19 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Sugar --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Desugaring passes -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} - module Language.PureScript.Sugar (desugar, module S) where -import Prelude () import Prelude.Compat -import Control.Monad import Control.Category ((>>>)) +import Control.Monad import Control.Monad.Error.Class (MonadError()) -import Control.Monad.Writer.Class (MonadWriter()) import Control.Monad.Supply.Class +import Control.Monad.Writer.Class (MonadWriter()) import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Externs - import Language.PureScript.Sugar.BindingGroups as S import Language.PureScript.Sugar.CaseDeclarations as S import Language.PureScript.Sugar.DoNotation as S diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 131208a897..ce255e7f10 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} - -- | -- This module implements the desugaring pass which creates binding groups from sets of -- mutually-recursive value declarations and mutually-recursive type declarations. @@ -13,7 +9,6 @@ module Language.PureScript.Sugar.BindingGroups , collapseBindingGroupsModule ) where -import Prelude () import Prelude.Compat import Control.Monad ((<=<)) diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 095bad3c10..23d65d7301 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -1,30 +1,26 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- | -- This module implements the desugaring pass which replaces top-level binders with -- case expressions. -- -module Language.PureScript.Sugar.CaseDeclarations ( - desugarCases, - desugarCasesModule -) where +module Language.PureScript.Sugar.CaseDeclarations + ( desugarCases + , desugarCasesModule + ) where -import Prelude () import Prelude.Compat -import Language.PureScript.Crash -import Data.Maybe (catMaybes, mapMaybe) import Data.List (nub, groupBy, foldl1') +import Data.Maybe (catMaybes, mapMaybe) import Control.Monad ((<=<), forM, replicateM, join, unless) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class -import Language.PureScript.Names import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors +import Language.PureScript.Names import Language.PureScript.Traversals import Language.PureScript.TypeChecker.Monad (guardWith) diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index ee923caa4a..8c3197846c 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -1,27 +1,21 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- | -- This module implements the desugaring pass which replaces do-notation statements with -- appropriate calls to bind from the Prelude.Monad type class. -- -module Language.PureScript.Sugar.DoNotation ( - desugarDoModule -) where +module Language.PureScript.Sugar.DoNotation (desugarDoModule) where -import Prelude () import Prelude.Compat -import Language.PureScript.Crash -import Language.PureScript.Names +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class + + import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Errors - +import Language.PureScript.Names import qualified Language.PureScript.Constants as C -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class - -- | -- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.bind function, -- and all @DoNotationLet@ constructors with let expressions. diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 1f36d5156f..cd58e67fdb 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - module Language.PureScript.Sugar.Names ( desugarImports , desugarImportsWithEnv @@ -13,32 +8,30 @@ module Language.PureScript.Sugar.Names , Exports(..) ) where -import Prelude () import Prelude.Compat -import Data.List (find, nub) -import Data.Maybe (fromMaybe, mapMaybe) - import Control.Arrow (first) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer (MonadWriter(..), censor) import Control.Monad.State.Lazy +import Control.Monad.Writer (MonadWriter(..), censor) +import Data.List (find, nub) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S -import Language.PureScript.Crash import Language.PureScript.AST -import Language.PureScript.Names -import Language.PureScript.Types +import Language.PureScript.Crash import Language.PureScript.Errors -import Language.PureScript.Traversals import Language.PureScript.Externs +import Language.PureScript.Linter.Imports +import Language.PureScript.Names import Language.PureScript.Sugar.Names.Env -import Language.PureScript.Sugar.Names.Imports import Language.PureScript.Sugar.Names.Exports -import Language.PureScript.Linter.Imports +import Language.PureScript.Sugar.Names.Imports +import Language.PureScript.Traversals +import Language.PureScript.Types -- | -- Replaces all local names with qualified names within a list of modules. The diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 4c31ceb565..c0febdd2f2 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Language.PureScript.Sugar.Names.Env ( ImportRecord(..) , ImportProvenance(..) @@ -21,21 +18,23 @@ module Language.PureScript.Sugar.Names.Env , checkImportConflicts ) where +import Prelude.Compat + +import Control.Monad +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) + import Data.Function (on) import Data.List (groupBy, sortBy, nub, delete) import Data.Maybe (fromJust) import qualified Data.Map as M import qualified Data.Set as S -import Control.Monad -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) - import Language.PureScript.AST import Language.PureScript.Crash -import Language.PureScript.Names import Language.PureScript.Environment import Language.PureScript.Errors +import Language.PureScript.Names -- | -- The details for an import: the name of the thing that is being imported diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 8c47c9f18a..c779407e6d 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -1,31 +1,23 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE LambdaCase #-} - module Language.PureScript.Sugar.Names.Exports ( findExportable , resolveExports ) where -import Prelude () import Prelude.Compat -import Data.List (find, intersect) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Foldable (traverse_) - import Control.Monad import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Error.Class (MonadError(..)) +import Data.Foldable (traverse_) +import Data.List (find, intersect) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M -import Language.PureScript.Crash import Language.PureScript.AST -import Language.PureScript.Names +import Language.PureScript.Crash import Language.PureScript.Errors +import Language.PureScript.Names import Language.PureScript.Sugar.Names.Env -- | diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index c46c01c7f8..a095ca44d0 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -1,35 +1,28 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE LambdaCase #-} - module Language.PureScript.Sugar.Names.Imports ( resolveImports , resolveModuleImport , findImports ) where -import Prelude () import Prelude.Compat -import Data.Foldable (traverse_, for_) -import Data.Function (on) -import Data.List (find, sortBy, groupBy, (\\)) -import Data.Maybe (fromMaybe, isNothing) -import Data.Traversable (for) - import Control.Arrow (first) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer (MonadWriter(..)) +import Data.Foldable (traverse_, for_) +import Data.Function (on) +import Data.List (find, sortBy, groupBy, (\\)) +import Data.Maybe (fromMaybe, isNothing) +import Data.Traversable (for) import qualified Data.Map as M import qualified Data.Set as S -import Language.PureScript.Crash import Language.PureScript.AST -import Language.PureScript.Names +import Language.PureScript.Crash import Language.PureScript.Errors +import Language.PureScript.Names import Language.PureScript.Sugar.Names.Env -- | diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index f41178ad03..23ac6b2d35 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -1,12 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} +module Language.PureScript.Sugar.ObjectWildcards + ( desugarObjectConstructors + ) where -module Language.PureScript.Sugar.ObjectWildcards ( - desugarObjectConstructors -) where - -import Prelude () import Prelude.Compat import Control.Monad (forM) diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 3e1522a473..54531ffc00 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} - -- | -- This module implements the desugaring pass which reapplies binary operators based -- on their fixity data and removes explicit parentheses. @@ -15,7 +10,6 @@ module Language.PureScript.Sugar.Operators , removeSignedLiterals ) where -import Prelude () import Prelude.Compat import Language.PureScript.AST diff --git a/src/Language/PureScript/Sugar/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs index b0955697af..5b5a0b72b0 100644 --- a/src/Language/PureScript/Sugar/Operators/Binders.hs +++ b/src/Language/PureScript/Sugar/Operators/Binders.hs @@ -1,6 +1,5 @@ module Language.PureScript.Sugar.Operators.Binders where -import Prelude () import Prelude.Compat import Language.PureScript.AST diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index 6e56810b13..1e57dff79a 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -1,10 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PatternGuards #-} - module Language.PureScript.Sugar.Operators.Common where -import Prelude () import Prelude.Compat import Control.Monad.State diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index 71fbefdf1a..32dd30da31 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -1,9 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Language.PureScript.Sugar.Operators.Expr where -import Prelude () import Prelude.Compat import Data.Functor.Identity diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs index 35b08863a4..f204b88bf9 100644 --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -1,6 +1,5 @@ module Language.PureScript.Sugar.Operators.Types where -import Prelude () import Prelude.Compat import Language.PureScript.AST diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 46adfa4500..4fc45dd640 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -- | -- This module implements the desugaring pass which creates type synonyms for type class dictionaries -- and dictionary expressions for type class instances. @@ -12,7 +8,6 @@ module Language.PureScript.Sugar.TypeClasses , superClassDictionaryNames ) where -import Prelude () import Prelude.Compat import Language.PureScript.Crash diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 0a01733734..0fbf3fb30d 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -1,29 +1,23 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | -- This module implements the generic deriving elaboration that takes place during desugaring. -- module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where -import Prelude () import Prelude.Compat -import Data.List (foldl', find, sortBy) -import Data.Maybe (fromMaybe) -import Data.Ord (comparing) - import Control.Arrow (second) import Control.Monad (replicateM) -import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class (MonadSupply) + +import Data.List (foldl', find, sortBy) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) -import Language.PureScript.Crash import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Names diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 8072ff29df..66ffc63e36 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -1,27 +1,11 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Sugar.TypeDeclarations --- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | --- This module implements the desugaring pass which replaces top-level type declarations with --- type annotations on the corresponding expression. +-- This module implements the desugaring pass which replaces top-level type +-- declarations with type annotations on the corresponding expression. -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.PureScript.Sugar.TypeDeclarations ( - desugarTypeDeclarationsModule -) where +module Language.PureScript.Sugar.TypeDeclarations + ( desugarTypeDeclarationsModule + ) where -import Prelude () import Prelude.Compat import Control.Monad (forM) diff --git a/src/Language/PureScript/Traversals.hs b/src/Language/PureScript/Traversals.hs index 74107290c0..c40f91c04e 100644 --- a/src/Language/PureScript/Traversals.hs +++ b/src/Language/PureScript/Traversals.hs @@ -1,42 +1,27 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Traversals --- Copyright : (c) 2014 Phil Freeman --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- --- | Common functions for implementing generic traversals --- ------------------------------------------------------------------------------ - -module Language.PureScript.Traversals where - -import Prelude () -import Prelude.Compat - -fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b) -fstM f (a, b) = flip (,) b <$> f a - -sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c) -sndM f (a, b) = (,) a <$> f b - -thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d) -thirdM f (a, b, c) = (,,) a b <$> f c - -pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d) -pairM f g (a, b) = (,) <$> f a <*> g b - -maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b) -maybeM _ Nothing = pure Nothing -maybeM f (Just a) = Just <$> f a - -eitherM :: (Applicative f) => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d) -eitherM f _ (Left a) = Left <$> f a -eitherM _ g (Right b) = Right <$> g b - -defS :: (Monad m) => st -> val -> m (st, val) -defS s val = return (s, val) - +-- | Common functions for implementing generic traversals +module Language.PureScript.Traversals where + +import Prelude.Compat + +fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b) +fstM f (a, b) = flip (,) b <$> f a + +sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c) +sndM f (a, b) = (,) a <$> f b + +thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d) +thirdM f (a, b, c) = (,,) a b <$> f c + +pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d) +pairM f g (a, b) = (,) <$> f a <*> g b + +maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b) +maybeM _ Nothing = pure Nothing +maybeM f (Just a) = Just <$> f a + +eitherM :: (Applicative f) => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d) +eitherM f _ (Left a) = Left <$> f a +eitherM _ g (Right b) = Right <$> g b + +defS :: (Monad m) => st -> val -> m (st, val) +defS s val = return (s, val) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 7481a5927a..8c910f280e 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -1,36 +1,26 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternGuards #-} -- | -- The top-level type checker, which checks all declarations in a module. -- -module Language.PureScript.TypeChecker ( - module T, - typeCheckModule -) where +module Language.PureScript.TypeChecker + ( module T + , typeCheckModule + ) where -import Prelude () import Prelude.Compat -import Language.PureScript.TypeChecker.Monad as T -import Language.PureScript.TypeChecker.Kinds as T -import Language.PureScript.TypeChecker.Types as T -import Language.PureScript.TypeChecker.Synonyms as T - -import Data.Maybe -import Data.List (nub, nubBy, (\\), sort, group) -import Data.Foldable (for_, traverse_) - -import qualified Data.Map as M - import Control.Monad (when, unless, void, forM, forM_) -import Control.Monad.Supply.Class (MonadSupply) -import Control.Monad.State.Class (MonadState(..), modify) import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State.Class (MonadState(..), modify) +import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Foldable (for_, traverse_) +import Data.List (nub, nubBy, (\\), sort, group) +import Data.Maybe +import qualified Data.Map as M + import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Environment @@ -39,6 +29,10 @@ import Language.PureScript.Kinds import Language.PureScript.Linter import Language.PureScript.Names import Language.PureScript.Traversals +import Language.PureScript.TypeChecker.Kinds as T +import Language.PureScript.TypeChecker.Monad as T +import Language.PureScript.TypeChecker.Synonyms as T +import Language.PureScript.TypeChecker.Types as T import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 019c5a1a6e..f1dcbf182b 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -1,26 +1,25 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} - -- | -- Type class entailment -- -module Language.PureScript.TypeChecker.Entailment (Context, replaceTypeClassDictionaries) where +module Language.PureScript.TypeChecker.Entailment + ( Context + , replaceTypeClassDictionaries + ) where -import Prelude () import Prelude.Compat +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State +import Control.Monad.Supply.Class (MonadSupply(..)) +import Control.Monad.Writer + import Data.Function (on) import Data.List (minimumBy, sortBy, groupBy) import Data.Maybe (maybeToList, mapMaybe) import qualified Data.Map as M -import Control.Monad.State -import Control.Monad.Writer -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class (MonadSupply(..)) - -import Language.PureScript.Crash import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.TypeChecker.Unify diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 54618864df..6522ff944c 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -1,9 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -- | -- This module implements the kind checker @@ -15,16 +10,15 @@ module Language.PureScript.TypeChecker.Kinds , kindsOfAll ) where -import Prelude () import Prelude.Compat -import qualified Data.Map as M - import Control.Arrow (second) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.State +import Control.Monad.Writer.Class (MonadWriter(..)) + +import qualified Data.Map as M import Language.PureScript.Crash import Language.PureScript.Environment diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index c4e9450a85..0635f0a2d7 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -1,7 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -- | @@ -9,17 +6,16 @@ -- module Language.PureScript.TypeChecker.Monad where -import Prelude () import Prelude.Compat -import Data.Maybe -import qualified Data.Map as M - import Control.Arrow (second) -import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State import Control.Monad.Writer.Class (MonadWriter(..), listen, censor) +import Data.Maybe +import qualified Data.Map as M + import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Kinds diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs index ac3854c50a..0267da990b 100644 --- a/src/Language/PureScript/TypeChecker/Rows.hs +++ b/src/Language/PureScript/TypeChecker/Rows.hs @@ -1,35 +1,18 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker.Rows --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Functions relating to type checking for rows -- ------------------------------------------------------------------------------ - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} +module Language.PureScript.TypeChecker.Rows + ( checkDuplicateLabels + ) where -module Language.PureScript.TypeChecker.Rows ( - checkDuplicateLabels -) where +import Prelude.Compat -import Data.List - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..)) +import Data.List + import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index f302cd57a2..603b902430 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -1,45 +1,30 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker.Skolems --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Functions relating to skolemization used during typechecking -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} - -module Language.PureScript.TypeChecker.Skolems ( - newSkolemConstant, - introduceSkolemScope, - newSkolemScope, - skolemize, - skolemizeTypesInValue, - skolemEscapeCheck -) where +module Language.PureScript.TypeChecker.Skolems + ( newSkolemConstant + , introduceSkolemScope + , newSkolemScope + , skolemize + , skolemizeTypesInValue + , skolemEscapeCheck + ) where -import Prelude () import Prelude.Compat -import Data.List (nub, (\\)) -import Data.Monoid -import Data.Functor.Identity (Identity(), runIdentity) - import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets, modify) -import Language.PureScript.Crash +import Data.Functor.Identity (Identity(), runIdentity) +import Data.List (nub, (\\)) +import Data.Monoid + import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Errors +import Language.PureScript.Traversals (defS) import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types -import Language.PureScript.Traversals (defS) -- | -- Generate a new skolem constant diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index fceef79822..fbb10ad89f 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -1,36 +1,20 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker.Subsumption --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- -- | -- Subsumption checking -- ------------------------------------------------------------------------------ +module Language.PureScript.TypeChecker.Subsumption + ( subsumes + ) where -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} +import Prelude.Compat -module Language.PureScript.TypeChecker.Subsumption ( - subsumes -) where +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State.Class (MonadState(..)) import Data.List (sortBy) import Data.Ord (comparing) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State.Class (MonadState(..)) - -import Language.PureScript.Crash import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index b2600cc067..829ec570f4 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -1,36 +1,20 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker.Synonyms --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE GADTs #-} + -- | -- Functions for replacing fully applied type synonyms -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE GADTs #-} +module Language.PureScript.TypeChecker.Synonyms + ( replaceAllTypeSynonyms + ) where -module Language.PureScript.TypeChecker.Synonyms ( - replaceAllTypeSynonyms -) where - -import Prelude () import Prelude.Compat -import Data.Maybe (fromMaybe) -import qualified Data.Map as M - import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State +import Data.Maybe (fromMaybe) +import qualified Data.Map as M + import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index cd2932665a..2aef2b5b49 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -- | -- This module implements the type checker @@ -28,22 +24,21 @@ module Language.PureScript.TypeChecker.Types Check a function of a given type returns a value of another type when applied to its arguments -} -import Prelude () import Prelude.Compat -import Data.Either (lefts, rights) -import Data.List (transpose, nub, (\\), partition, delete) -import Data.Maybe (fromMaybe) -import qualified Data.Map as M - import Control.Monad +import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets) import Control.Monad.Supply.Class (MonadSupply) -import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) -import Language.PureScript.Crash +import Data.Either (lefts, rights) +import Data.List (transpose, nub, (\\), partition, delete) +import Data.Maybe (fromMaybe) +import qualified Data.Map as M + import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Kinds diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 1fc584da9b..5bf1558469 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -1,47 +1,30 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.TypeChecker.Unify --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman --- Stability : experimental --- Portability : --- +{-# LANGUAGE FlexibleInstances #-} + -- | -- Functions and instances relating to unification -- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} - -module Language.PureScript.TypeChecker.Unify ( - freshType, - solveType, - substituteType, - unknownsInType, - unifyTypes, - unifyRows, - unifiesWith, - replaceVarWithUnknown, - replaceTypeWildcards, - varIfUnknown -) where +module Language.PureScript.TypeChecker.Unify + ( freshType + , solveType + , substituteType + , unknownsInType + , unifyTypes + , unifyRows + , unifiesWith + , replaceVarWithUnknown + , replaceTypeWildcards + , varIfUnknown + ) where + +import Prelude.Compat -import Data.List (nub, sort) -import qualified Data.Map as M - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.State.Class (MonadState(..), gets, modify) +import Control.Monad.Writer.Class (MonadWriter(..)) + +import Data.List (nub, sort) +import qualified Data.Map as M import Language.PureScript.Crash import Language.PureScript.Errors diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 19ac0461bb..9bc82ed20a 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -1,5 +1,7 @@ module Language.PureScript.TypeClassDictionaries where +import Prelude.Compat + import Language.PureScript.Names import Language.PureScript.Types diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index f862e7d8af..7c1e378a0c 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -6,19 +6,18 @@ -- module Language.PureScript.Types where -import Prelude () import Prelude.Compat +import Control.Monad ((<=<)) + import Data.List (nub) import Data.Maybe (fromMaybe) import qualified Data.Aeson as A import qualified Data.Aeson.TH as A -import Control.Monad ((<=<)) - -import Language.PureScript.Names -import Language.PureScript.Kinds import Language.PureScript.AST.SourcePos +import Language.PureScript.Kinds +import Language.PureScript.Names -- | -- An identifier for the scope of a skolem variable @@ -41,7 +40,7 @@ data Type -- | -- A type wildcard, as would appear in a partial type synonym -- - | TypeWildcard (SourceSpan) + | TypeWildcard SourceSpan -- | -- A type constructor -- diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs index 2352d39de9..fe2788f4d7 100644 --- a/src/System/IO/UTF8.hs +++ b/src/System/IO/UTF8.hs @@ -1,6 +1,6 @@ -module System.IO.UTF8 +module System.IO.UTF8 where -where +import Prelude.Compat import System.IO ( IOMode(..) , hGetContents From 73746d9d5035fd6dcd8cf87a22518ce2e3f02441 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 8 May 2016 11:50:18 -0700 Subject: [PATCH 0403/1580] Fix #2092, precedence of type application (#2098) * Fix #2092, precedence of type application * one more test --- examples/passing/TypeOperators.purs | 8 ++++++++ src/Language/PureScript/Parser/Types.hs | 4 ++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/examples/passing/TypeOperators.purs b/examples/passing/TypeOperators.purs index 1df4e1d2ea..deb73b1132 100644 --- a/examples/passing/TypeOperators.purs +++ b/examples/passing/TypeOperators.purs @@ -5,6 +5,14 @@ import A (type (~>), type (/\), (/\)) natty ∷ ∀ f. f ~> f natty x = x +data Compose f g a = Compose (f (g a)) + +testPrecedence1 ∷ ∀ f g. Compose f g ~> Compose f g +testPrecedence1 x = x + +testPrecedence2 ∷ ∀ f g. f ~> g → f ~> g +testPrecedence2 nat fx = nat fx + swap ∷ ∀ a b. a /\ b → b /\ a swap (a /\ b) = b /\ a diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 854b067248..bfbdf72efd 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -82,10 +82,10 @@ parseConstrainedType = do parseAnyType :: TokenParser Type parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P. "type" where - operators = [ [ P.Infix (P.try (parseQualified (Op <$> symbol)) >>= \ident -> + operators = [ [ P.Infix (return TypeApp) P.AssocLeft ] + , [ P.Infix (P.try (parseQualified (Op <$> symbol)) >>= \ident -> return (BinaryNoParensType (TypeOp ident))) P.AssocRight ] - , [ P.Infix (return TypeApp) P.AssocLeft ] , [ P.Infix (rarrow >> return function) P.AssocRight ] ] postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind) From 10f76a70dffe456ab49f3beed63da27feda149aa Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 8 May 2016 20:50:48 +0100 Subject: [PATCH 0404/1580] Switch to stack for CI, resolves #1974 (#2099) * Switch to stack for CI, resolves #1974 * Remove the stack-nightly.yaml, since it always needs updating. Instead, we pass --resolver=nightly in one of the build jobs to ensure we always have the latest nightly. As an added bonus we no longer have to set the STACK_YAML environment variable on Windows, because stack.yaml is no longer a symlink. * Remove use of cabal-install, which drastically simplifies the CI scripts :) * Use the 'compiler' key in the build matrix as a hack to ensure each build job gets a separate cache. * Add OSX tests. * Add haddock tests, on a separate build job (for speed). * Use separate build jobs for sdist tests (for speed). * Fix binary bundle uploading on Travis * Add binary bundle uploading for OSX. * Update appveyor CI * No longer need to set STACK_YAML on AppVeyor * We should not attempt to run 'strip' on Windows executables * Fix path to bundle creation script --- .travis.yml | 125 +++++++++++++++------------- appveyor.yml | 6 +- bundle/{build-stack.sh => build.sh} | 6 +- purescript.cabal | 2 - stack-lts-5.yaml | 7 -- stack-nightly.yaml | 6 -- stack.yaml | 8 +- travis/after.sh | 13 --- travis/build.sh | 59 +++++++++++++ travis/configure.sh | 17 ---- travis/convert-os-name.sh | 14 ++++ travis/test-install.sh | 18 ---- 12 files changed, 151 insertions(+), 130 deletions(-) rename bundle/{build-stack.sh => build.sh} (89%) delete mode 100644 stack-lts-5.yaml delete mode 100644 stack-nightly.yaml mode change 120000 => 100644 stack.yaml delete mode 100755 travis/after.sh create mode 100755 travis/build.sh delete mode 100755 travis/configure.sh create mode 100755 travis/convert-os-name.sh delete mode 100755 travis/test-install.sh diff --git a/.travis.yml b/.travis.yml index 2e6b496922..ac5f023a42 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,73 +1,80 @@ language: c -dist: trusty +dist: trusty # because of perf issues sudo: required matrix: include: - - env: GHCVER=7.10.3 CABALVER=1.22 STACKAGE=lts-5.4 RUNSDISTTESTS=YES - compiler: ": #GHC 7.10.3 lts-5.4" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.10.3 CABALVER=1.22 STACKAGE=nightly-2016-02-25 - compiler: ": #GHC 7.10.3 nightly-2016-02-25" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} - - env: GHCVER=7.10.3 CABALVER=1.22 DEPLOY=yes - compiler: ": #GHC 7.10.3" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}} -before_install: - - unset CC - - export PATH="/opt/ghc/$GHCVER/bin:$PATH" - - export PATH="/opt/cabal/$CABALVER/bin:$PATH" - - export PATH="$HOME/.cabal/bin:$PATH" - - export PATH="/opt/happy/1.19.5/bin:/$PATH" - - export PATH="/opt/alex/3.1.4/bin:/$PATH" - - export PATH="$HOME/build/purescript/purescript/dist/build/psc:/$PATH" - - export PATH="$HOME/build/purescript/purescript/dist/build/psc-ide-server:/$PATH" - - export PATH="$HOME/build/purescript/purescript/dist/build/psc-ide-client:/$PATH" + # The 'compiler' key is a hack to get Travis to use different caches for + # each job in a build, in order to avoid the separate jobs stomping on each + # other's caches. See https://github.com/travis-ci/travis-ci/issues/4393 + # + # We use trusty boxes because they seem to be a bit faster. + - compiler: cc-linux-lts-normal + os: linux + dist: trusty + sudo: required + env: BUILD_TYPE=normal COVERAGE=true DEPLOY=true + + - compiler: cc-linux-nightly-normal + os: linux + dist: trusty + sudo: required + env: BUILD_TYPE=normal STACKAGE_NIGHTLY=true + allow_failures: true + + - compiler: cc-linux-lts-sdist + os: linux + dist: trusty + sudo: required + env: BUILD_TYPE=sdist + + - compiler: cc-linux-lts-haddock + os: linux + dist: trusty + sudo: required + env: BUILD_TYPE=haddock + + - compiler: cc-osx-lts-normal + os: osx + env: BUILD_TYPE=normal DEPLOY=true + + - compiler: cc-osx-lts-sdist + os: osx + env: BUILD_TYPE=sdist +addons: + apt: + packages: + - libgmp-dev +cache: + directories: + - $HOME/.local/bin + - $HOME/.stack install: - - cabal --version - - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - - travis_retry cabal update - # Run sequentially - # Travis container infrastructure seems to expose all host CPUs (16?), thus - # cabal and ghc tries to use them all. Which is bad idea on a shared box. - # See also: https://ghc.haskell.org/trac/ghc/ticket/9221 - - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - # Cache sandboxes in ~/cabal-sandboxes - # Move right sandbox to .cabal-sandbox if exists - - if [ -d ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none} ]; then - mv ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none} .cabal-sandbox; - fi - - mkdir -p .cabal-sandbox - - cabal sandbox init --sandbox .cabal-sandbox - # Download stackage cabal.config. Filter this package and 'extra deps' - - if [ -n "$STACKAGE" ]; then curl https://www.stackage.org/$STACKAGE/cabal.config | egrep -v 'purescript|language-javascript|bower-json' > cabal.config; fi - - cabal install --only-dependencies --enable-tests - - cabal install hpc-coveralls - # Snapshot state of the sandbox now, so we don't need to make new one for test install - - rm -rf ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none} - - cp -r .cabal-sandbox ~/cabal-sandboxes/$GHCVER-${STACKAGE:-none} - # Install bower globally (for psc-docs/psc-publish tests) - - npm install -g bower +- | # Install stack. + if test ! -f "$HOME/.local/bin/stack" + then + URL="https://www.stackage.org/stack/$TRAVIS_OS_NAME-x86_64" + curl --location "$URL" > stack.tar.gz + gunzip stack.tar.gz + tar -x -f stack.tar --strip-components 1 + mkdir -p "$HOME/.local/bin" + mv stack "$HOME/.local/bin/" + fi +- npm install -g bower # for psc-docs / psc-publish tests +# Fix the CC environment variable, because Travis changes it +- export CC=gcc +- export OS_NAME=$(./travis/convert-os-name.sh) script: - - ./travis/configure.sh - - cabal build --ghc-options="-Werror" - - cabal test - - ./travis/test-install.sh -after_script: - - ./travis/after.sh -notifications: - email: true -before_deploy: "./bundle/build.sh linux64" +- travis/build.sh +before_deploy: +- ./bundle/build.sh $OS_NAME deploy: provider: releases api_key: $RELEASE_KEY file: - - bundle/linux64.tar.gz - - bundle/linux64.sha + - bundle/$OS_NAME.tar.gz + - bundle/$OS_NAME.sha skip_cleanup: true on: all_branches: true tags: true - condition: "$DEPLOY = yes" -cache: - directories: - - ~/cabal-sandboxes + condition: "$DEPLOY = true" diff --git a/appveyor.yml b/appveyor.yml index efbc4d3ce7..706a8d7b24 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -5,7 +5,6 @@ environment: STACK_ROOT: c:\s # Appveyor does not seem to be able to cope with the symbolic link # stack.yaml, so this is a workaround. - STACK_YAML: stack-lts-5.yaml RELEASE_USER: purescript RELEASE_REPO: purescript cache: @@ -31,9 +30,6 @@ build_script: test_script: - stack -j1 --no-terminal test --pedantic on_success: -# this seems to be necessary; if omitted, the bash script fails to find the -# tool 'strip'. -- copy C:\MinGW\bin\strip.exe C:\tools\strip.exe - ps: | function UploadFile { @@ -42,7 +38,7 @@ on_success: if ($env:APPVEYOR_REPO_TAG_NAME) { - bash ./bundle/build-stack.sh win64 + bash ./bundle/build.sh win64 (New-Object Net.WebClient).DownloadFile('https://github.com/aktau/github-release/releases/download/v0.6.2/windows-amd64-github-release.zip', 'c:\tools\github-release.zip') pushd c:\tools diff --git a/bundle/build-stack.sh b/bundle/build.sh similarity index 89% rename from bundle/build-stack.sh rename to bundle/build.sh index ee13b9542f..2acfdf417a 100755 --- a/bundle/build-stack.sh +++ b/bundle/build.sh @@ -29,8 +29,10 @@ mkdir -p bundle/build/purescript for BIN in psc psci psc-docs psc-publish psc-bundle psc-ide-server psc-ide-client do FULL_BIN="$LOCAL_INSTALL_ROOT/bin/${BIN}${BIN_EXT}" - strip "$FULL_BIN" || true # not the end of the world if this fails, and - # AppVeyor can't seem to handle it for some reason + if [ "$OS" != "win64" ] + then + strip "$FULL_BIN" + fi cp "$FULL_BIN" bundle/build/purescript done diff --git a/purescript.cabal b/purescript.cabal index 592f30dff4..f9ba55e378 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -77,8 +77,6 @@ extra-source-files: examples/passing/*.purs , tests/support/pscide/src/*.js , tests/support/pscide/src/*.fail , stack.yaml - , stack-lts-5.yaml - , stack-nightly.yaml , README.md , INSTALL.md , CONTRIBUTORS.md diff --git a/stack-lts-5.yaml b/stack-lts-5.yaml deleted file mode 100644 index 9f87d0ed7c..0000000000 --- a/stack-lts-5.yaml +++ /dev/null @@ -1,7 +0,0 @@ -resolver: lts-5.4 -packages: -- '.' -extra-deps: -- bower-json-0.8.0 -- language-javascript-0.6.0.4 -flags: {} diff --git a/stack-nightly.yaml b/stack-nightly.yaml deleted file mode 100644 index 22c2f0d0e0..0000000000 --- a/stack-nightly.yaml +++ /dev/null @@ -1,6 +0,0 @@ -flags: {} -packages: -- '.' -extra-deps: -- language-javascript-0.6.0.4 -resolver: nightly-2016-03-17 diff --git a/stack.yaml b/stack.yaml deleted file mode 120000 index 0db6065aea..0000000000 --- a/stack.yaml +++ /dev/null @@ -1 +0,0 @@ -stack-lts-5.yaml \ No newline at end of file diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000000..9f87d0ed7c --- /dev/null +++ b/stack.yaml @@ -0,0 +1,7 @@ +resolver: lts-5.4 +packages: +- '.' +extra-deps: +- bower-json-0.8.0 +- language-javascript-0.6.0.4 +flags: {} diff --git a/travis/after.sh b/travis/after.sh deleted file mode 100755 index 58511bd67f..0000000000 --- a/travis/after.sh +++ /dev/null @@ -1,13 +0,0 @@ -set -e - -pushd core-tests/ -./test-everything.sh -popd - -if ! git describe --tags --exact-match >/dev/null 2>/dev/null && [ "$COVERAGE" = "true" ] -then - ./.cabal-sandbox/bin/hpc-coveralls \ - --exclude-dir=dist/build/autogen \ - --exclude-dir=tests \ - tests -fi diff --git a/travis/build.sh b/travis/build.sh new file mode 100755 index 0000000000..ea54ba3fcd --- /dev/null +++ b/travis/build.sh @@ -0,0 +1,59 @@ +#!/bin/bash +set -e + +STACK="stack --no-terminal --jobs=1" +$STACK setup + +# Set up configuration +STACK_EXTRA_FLAGS="" +if [ -z "$TRAVIS_TAG" ] +then + # On non-release builds, disable optimizations. + STACK_EXTRA_FLAGS="--fast" +fi + +if [ "$STACKAGE_NIGHTLY" = "true" ] +then + STACK_EXTRA_FLAGS="$STACK_EXTRA_FLAGS --resolver=nightly" +fi + +if [ "$COVERAGE" = "true" ] +then + STACK_EXTRA_FLAGS="$STACK_EXTRA_FLAGS --coverage" +fi + +echo "STACK_EXTRA_FLAGS=\"$STACK_EXTRA_FLAGS\"" +BUILD_COMMAND="$STACK build --pedantic --test $STACK_EXTRA_FLAGS" + +if [ "$BUILD_TYPE" = "normal" ] +then + echo ">>> Building & testing..." + echo "> $BUILD_COMMAND" + $BUILD_COMMAND + +elif [ "$BUILD_TYPE" = "sdist" ] +then + echo ">>> Testing the source distribution..." + $STACK sdist + mkdir sdist-test + tar -xzf $(stack path --dist-dir)/purescript-*.tar.gz -C sdist-test --strip-components=1 + pushd sdist-test + echo "> $BUILD_COMMAND" + $BUILD_COMMAND + popd + +elif [ "$BUILD_TYPE" = "haddock" ] +then + echo ">>> Checking haddock documentation..." + $STACK haddock +else + echo "Unrecognised BUILD_TYPE: $BUILD_TYPE" + exit 1 +fi + +if [ "$COVERAGE" = "true" ] +then + echo ">>> Uploading test coverage report..." + which shc || $STACK install stack-hpc-coveralls + shc purescript tests || echo "Failed to upload coverage" +fi diff --git a/travis/configure.sh b/travis/configure.sh deleted file mode 100755 index d5ce1f751b..0000000000 --- a/travis/configure.sh +++ /dev/null @@ -1,17 +0,0 @@ -set -e - -configure_flags="--enable-tests -v2" - -if ! git describe --tags --exact-match >/dev/null 2>/dev/null -then - # Not a release build - configure_flags="--disable-optimization $configure_flags" -fi - -if [ "$COVERAGE" = "true" ] -then - configure_flags="--enable-coverage $configure_flags" -fi - -echo "> cabal configure $configure_flags" -cabal configure $configure_flags diff --git a/travis/convert-os-name.sh b/travis/convert-os-name.sh new file mode 100755 index 0000000000..c3abbf2970 --- /dev/null +++ b/travis/convert-os-name.sh @@ -0,0 +1,14 @@ +#!/bin/bash +# This script converts the Travis OS name into the format used for PureScript +# binary bundles. +set -e + +case "$TRAVIS_OS_NAME" in + "linux") + echo linux64;; + "osx") + echo macos;; + *) + echo "Unknown TRAVIS_OS_NAME: $TRAVIS_OS_NAME"; + exit 1;; +esac diff --git a/travis/test-install.sh b/travis/test-install.sh deleted file mode 100755 index 2206e248f9..0000000000 --- a/travis/test-install.sh +++ /dev/null @@ -1,18 +0,0 @@ -set -e - -# Check that a source distribution can be successfully generated, and that -# the generated source distribution can be installed and tested -cabal sdist -if SRC_TGZ="$PWD/dist/$(cabal info . | awk '{print $2;exit}').tar.gz" -then - if [ "$RUNSDISTTESTS" = "YES" ]; then - mkdir test-install - cd test-install - tar --strip-components=1 -xzf $SRC_TGZ - cabal sandbox init --sandbox ../.cabal-sandbox - cabal install --enable-tests --force-reinstalls - cabal test - else - cabal install "$SRC_TGZ" - fi -fi From b781f20273c70630d1fac3f7bd3112f0a954f896 Mon Sep 17 00:00:00 2001 From: Andy Arvanitis Date: Sun, 8 May 2016 18:42:02 -0700 Subject: [PATCH 0405/1580] Fix for issue #2093: Test contains an unreliable comparison --- examples/passing/InferRecFunWithConstrainedArgument.purs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/examples/passing/InferRecFunWithConstrainedArgument.purs b/examples/passing/InferRecFunWithConstrainedArgument.purs index 2a10977698..1623e426b6 100644 --- a/examples/passing/InferRecFunWithConstrainedArgument.purs +++ b/examples/passing/InferRecFunWithConstrainedArgument.purs @@ -2,7 +2,7 @@ module Main where import Prelude -test 100.0 = 100.0 -test n = test(1.0 + n) +test 100 = 100 +test n = test(1 + n) -main = Control.Monad.Eff.Console.print $ test 0.0 +main = Control.Monad.Eff.Console.print $ test 0 From e11cff57bf0f9418db673a3047fbdf89613400f8 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 10 May 2016 09:39:43 -0700 Subject: [PATCH 0406/1580] Rename Prim.Object to Prim.Record, fix #1768 (#2102) * Rename Prim.Object to Prim.Record, fix #1768 * Fix some comments --- examples/passing/LiberalTypeSynonyms.purs | 2 +- examples/passing/NewtypeWithRecordUpdate.purs | 4 +-- examples/passing/RowConstructors.purs | 2 +- src/Language/PureScript/AST/Declarations.hs | 4 +-- .../PureScript/Docs/RenderedCode/Render.hs | 2 +- src/Language/PureScript/Environment.hs | 26 +++++++++---------- src/Language/PureScript/Parser/Types.hs | 2 +- src/Language/PureScript/Pretty/Types.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 8 +++--- .../PureScript/Sugar/TypeClasses/Deriving.hs | 2 +- .../PureScript/TypeChecker/Subsumption.hs | 4 +-- src/Language/PureScript/TypeChecker/Types.hs | 20 +++++++------- 12 files changed, 39 insertions(+), 39 deletions(-) diff --git a/examples/passing/LiberalTypeSynonyms.purs b/examples/passing/LiberalTypeSynonyms.purs index 61f2ebf48e..8bf802e037 100644 --- a/examples/passing/LiberalTypeSynonyms.purs +++ b/examples/passing/LiberalTypeSynonyms.purs @@ -9,7 +9,7 @@ foo s = s type AndFoo r = (foo :: String | r) -getFoo :: forall r. Prim.Object (AndFoo r) -> String +getFoo :: forall r. Prim.Record (AndFoo r) -> String getFoo o = o.foo type F r = { | r } -> { | r } diff --git a/examples/passing/NewtypeWithRecordUpdate.purs b/examples/passing/NewtypeWithRecordUpdate.purs index 1a68534f7e..83bb139b15 100644 --- a/examples/passing/NewtypeWithRecordUpdate.purs +++ b/examples/passing/NewtypeWithRecordUpdate.purs @@ -5,9 +5,9 @@ module Main where import Prelude import Control.Monad.Eff.Console -newtype NewType a = NewType (Object a) +newtype NewType a = NewType (Record a) -rec1 :: Object (a :: Number, b :: Number, c:: Number) +rec1 :: Record (a :: Number, b :: Number, c:: Number) rec1 = { a: 0.0, b: 0.0, c: 0.0 } rec2 :: NewType (a :: Number, b :: Number, c :: Number) diff --git a/examples/passing/RowConstructors.purs b/examples/passing/RowConstructors.purs index 593d94caa0..fc6c9677b5 100644 --- a/examples/passing/RowConstructors.purs +++ b/examples/passing/RowConstructors.purs @@ -12,7 +12,7 @@ foo = { x: 0.0, y: 0.0, z: 0.0 } bar :: { | Bar } bar = { x: 0.0, y: 0.0, z: 0.0 } -id' :: Object Foo -> Object Bar +id' :: Record Foo -> Record Bar id' = id foo' :: { | Foo } diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 52e1d6253e..94df7c6670 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -351,8 +351,8 @@ data Expr -- | Parens Expr -- | - -- An object property getter (e.g. `_.x`). This will be removed during - -- desugaring and expanded into a lambda that reads a property from an object. + -- A record property getter (e.g. `_.x`). This will be removed during + -- desugaring and expanded into a lambda that reads a property from a record. -- | ObjectGetter String -- | diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index 16ff7c6910..77009efbe8 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -159,7 +159,7 @@ dePrim other = other convert :: RenderTypeOptions -> Type -> Type convert _ (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret -convert opts (TypeApp o r) | o == tyObject && prettyPrintObjects opts = PrettyPrintObject r +convert opts (TypeApp o r) | o == tyRecord && prettyPrintObjects opts = PrettyPrintObject r convert _ other = other convertForAlls :: Type -> Type diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index fbf6a2d211..ab84e86408 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -196,16 +196,16 @@ tyArray :: Type tyArray = primTy "Array" -- | --- Type constructor for objects +-- Type constructor for records -- -tyObject :: Type -tyObject = primTy "Object" +tyRecord :: Type +tyRecord = primTy "Record" -- | --- Check whether a type is an object +-- Check whether a type is a record -- isObject :: Type -> Bool -isObject = isTypeOrApplied tyObject +isObject = isTypeOrApplied tyRecord -- | -- Check whether a type is a function @@ -232,14 +232,14 @@ primTypes :: M.Map (Qualified (ProperName 'TypeName)) (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 "Char", (Star, ExternData)) - , (primName "Number", (Star, ExternData)) - , (primName "Int", (Star, ExternData)) - , (primName "Boolean", (Star, ExternData)) - , (primName "Partial", (Star, ExternData)) + , (primName "Array", (FunKind Star Star, ExternData)) + , (primName "Record", (FunKind (Row Star) Star, ExternData)) + , (primName "String", (Star, ExternData)) + , (primName "Char", (Star, ExternData)) + , (primName "Number", (Star, ExternData)) + , (primName "Int", (Star, ExternData)) + , (primName "Boolean", (Star, ExternData)) + , (primName "Partial", (Star, ExternData)) ] -- | diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index bfbdf72efd..0283db6b96 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -25,7 +25,7 @@ parseFunction :: TokenParser Type parseFunction = parens rarrow >> return tyFunction parseObject :: TokenParser Type -parseObject = braces $ TypeApp tyObject <$> parseRow +parseObject = braces $ TypeApp tyRecord <$> parseRow parseTypeWildcard :: TokenParser Type parseTypeWildcard = do diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index fa6036e987..62263d771b 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -99,7 +99,7 @@ insertPlaceholders :: Type -> Type insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert where convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret - convert (TypeApp o r) | o == tyObject = PrettyPrintObject r + convert (TypeApp o r) | o == tyRecord = PrettyPrintObject r convert other = other convertForAlls (ForAll ident ty _) = go [ident] ty where diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 4fc45dd640..c301682fc8 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -233,7 +233,7 @@ typeClassDictionaryDeclaration name args implies members = ] members' = map (first runIdent . memberToNameAndType) members mtys = members' ++ superclassTypes - in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyObject $ rowFromList (mtys, REmpty)) + in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyRecord $ rowFromList (mtys, REmpty)) typeClassMemberToDictionaryAccessor :: ModuleName @@ -251,7 +251,7 @@ typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" unit :: Type -unit = TypeApp tyObject REmpty +unit = TypeApp tyRecord REmpty typeInstanceDictionaryDeclaration :: forall m @@ -285,8 +285,8 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls -- Create the type of the dictionary - -- The type is an object type, but depending on type instance dependencies, may be constrained. - -- The dictionary itself is an object literal. + -- The type is a record type, but depending on type instance dependencies, may be constrained. + -- The dictionary itself is a record literal. let superclasses = superClassDictionaryNames implies `zip` [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs) | (Constraint superclass suTyArgs _) <- implies diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 0fbf3fb30d..eef4a8582c 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -410,7 +410,7 @@ mkVar :: Ident -> Expr mkVar = mkVarMn Nothing objectType :: Type -> Maybe Type -objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec +objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec objectType _ = Nothing decomposeRec :: Type -> [(String, Type)] diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index fbb10ad89f..b7cd9de522 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -53,7 +53,7 @@ subsumes' val ty1 (KindedType ty2 _) = subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do dicts <- getTypeClassDictionaries subsumes' (Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)) ty1 ty2 -subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do +subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do let (ts1, r1') = rowToList r1 (ts2, r2') = rowToList r2 @@ -80,7 +80,7 @@ subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject REmpty -> throwError . errorMessage $ PropertyIsMissing p2 _ -> unifyTypes r1' (RCons p2 ty2 rest) go ((p1, ty1) : ts1) ts2 rest r2' -subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1 +subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyRecord = subsumes val ty2 ty1 subsumes' val ty1 ty2 = do unifyTypes ty1 ty2 return val diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 2aef2b5b49..a676e4cfa7 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -254,7 +254,7 @@ infer' (Literal (ObjectLiteral ps)) = do ensureNoDuplicateProperties ps ts <- traverse (infer . snd) ps let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts - ty = TypeApp tyObject $ rowFromList (fields, REmpty) + ty = TypeApp tyRecord $ rowFromList (fields, REmpty) return $ TypedValue True (Literal (ObjectLiteral (zip (map fst ps) ts))) ty infer' (ObjectUpdate o ps) = do ensureNoDuplicateProperties ps @@ -262,13 +262,13 @@ infer' (ObjectUpdate o ps) = do newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals oldTys <- zip (map fst ps) <$> replicateM (length ps) freshType - let oldTy = TypeApp tyObject $ rowFromList (oldTys, row) + let oldTy = TypeApp tyRecord $ rowFromList (oldTys, row) o' <- TypedValue True <$> check o oldTy <*> pure oldTy - return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row) + return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyRecord $ rowFromList (newTys, row) infer' (Accessor prop val) = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do field <- freshType rest <- freshType - typed <- check val (TypeApp tyObject (RCons prop field rest)) + typed <- check val (TypeApp tyRecord (RCons prop field rest)) return $ TypedValue True (Accessor prop typed) field infer' (Abs (Left arg) ret) = do ty <- freshType @@ -402,7 +402,7 @@ inferBinder val (LiteralBinder (ObjectLiteral props)) = do row <- freshType rest <- freshType m1 <- inferRowProperties row rest props - unifyTypes val (TypeApp tyObject row) + unifyTypes val (TypeApp tyRecord row) return m1 where inferRowProperties :: Type -> Type -> [(String, Binder)] -> m (M.Map Ident Type) @@ -616,26 +616,26 @@ check' (IfThenElse cond th el) ty = do th' <- check th ty el' <- check el ty return $ TypedValue True (IfThenElse cond' th' el') ty -check' e@(Literal (ObjectLiteral ps)) t@(TypeApp obj row) | obj == tyObject = do +check' e@(Literal (ObjectLiteral ps)) t@(TypeApp obj row) | obj == tyRecord = do ensureNoDuplicateProperties ps ps' <- checkProperties e ps row False return $ TypedValue True (Literal (ObjectLiteral ps')) t check' (TypeClassDictionaryConstructorApp name ps) t = do ps' <- check' ps t return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t -check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do +check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyRecord = do ensureNoDuplicateProperties ps -- We need to be careful to avoid duplicate labels here. -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns. let (propsToCheck, rest) = rowToList row (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck us <- zip (map fst removedProps) <$> replicateM (length ps) freshType - obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest))) + obj' <- check obj (TypeApp tyRecord (rowFromList (us ++ remainingProps, rest))) ps' <- checkProperties e ps row True return $ TypedValue True (ObjectUpdate obj' ps') t check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do rest <- freshType - val' <- check val (TypeApp tyObject (RCons prop ty rest)) + val' <- check val (TypeApp tyRecord (RCons prop ty rest)) return $ TypedValue True (Accessor prop val') ty check' v@(Constructor c) ty = do env <- getEnv @@ -698,7 +698,7 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh v' <- check v ty ps'' <- go ps' (delete (p, ty) ts) r return $ (p, v') : ps'' - go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyObject row) + go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyRecord row) -- | Check the type of a function application, rethrowing errors to provide a better error message checkFunctionApplication :: From 102eb6a26843f650330bd22fae97c3215e6bbd70 Mon Sep 17 00:00:00 2001 From: Kirill Pertsev Date: Tue, 10 May 2016 12:53:45 -0700 Subject: [PATCH 0407/1580] Fixes #2064 (#2107) * Fixes #2064 The unnecessary forward (client) and reverse (server) name resolution was impaired on OS X when IPv6 entries for localhost were missing in /etc/hosts The proposed patch remove this name resolution and makes psc-ide operation independent from name resolution proper configuration. * Added @kika to CONTRIBUTORS.md --- CONTRIBUTORS.md | 1 + psc-ide-client/Main.hs | 2 +- psc-ide-server/Main.hs | 8 +++++--- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 0120af5496..a2bcea0af5 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -31,6 +31,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@joneshf](https://github.com/joneshf) (Hardy Jones) - My existing contributions and all future contributions until further notice are Copyright Hardy Jones, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. +- [@kika](https://github.com/kika) (Kirill Pertsev) - My existing contributions and all future contributions until further notice are Copyright Kirill Pertsev, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@kRITZCREEK](https://github.com/kRITZCREEK) (Christoph Hegemann) - My existing contributions and all future contributions until further notice are Copyright Christoph Hegemann, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@L8D](https://github.com/L8D) (Tenor Biel) My existing contributions and all future contributions until further notice are Copyright Tenor Biel, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@leighman](http://github.com/leighman) (Jack Leigh) My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs index 17c05963e5..79532e51e1 100644 --- a/psc-ide-client/Main.hs +++ b/psc-ide-client/Main.hs @@ -35,7 +35,7 @@ main = do client :: PortID -> IO () client port = do h <- - connectTo "localhost" port `catch` + connectTo "127.0.0.1" port `catch` (\(SomeException e) -> putStrLn ("Couldn't connect to psc-ide-server on port: " ++ diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index c19c7ca829..aa8085bdac 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -40,10 +40,10 @@ import Language.PureScript.Ide.Util import Language.PureScript.Ide.Error import Language.PureScript.Ide.Types import Language.PureScript.Ide.Watcher -import Network hiding (socketPort) +import Network hiding (socketPort, accept) import Network.BSD (getProtocolNumber) import Network.Socket hiding (PortNumber, Type, - accept, sClose) + sClose) import Options.Applicative import System.Directory import System.FilePath @@ -167,7 +167,9 @@ acceptCommand sock = do pure (cmd, h) where acceptConnection = liftIO $ do - (h,_,_) <- accept sock + -- Use low level accept to prevent accidental reverse name resolution + (s,_) <- accept sock + h <- socketToHandle s ReadWriteMode hSetEncoding h utf8 hSetBuffering h LineBuffering pure h From 3ad48f1e8931bd41919abe21883cb20e5ce5222f Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Wed, 11 May 2016 12:27:00 +0100 Subject: [PATCH 0408/1580] Separate the `Op` and `Ident` namespaces * Separate operator and ident namespaces, some general name-related updates * Fixes #2064 (#2107) --- CONTRIBUTORS.md | 1 + examples/docs/src/OldOperators.purs | 10 - examples/failing/1733.purs | 2 +- examples/failing/1825.purs | 8 +- examples/failing/Arrays.purs | 6 +- examples/failing/ExportExplicit.purs | 2 +- examples/failing/ExportExplicit1.purs | 2 +- examples/failing/ExportExplicit3.purs | 2 +- examples/failing/ImportExplicit.purs | 2 +- examples/failing/ImportModule.purs | 2 +- examples/failing/MultipleErrors2.purs | 4 +- examples/failing/MultipleTypeOpFixities.purs | 9 + examples/failing/MultipleValueOpFixities.purs | 9 + examples/failing/RedefinedFixity.purs | 9 - examples/failing/UnknownType.purs | 2 +- examples/passing/Dollar.purs | 6 +- examples/passing/Functions.purs | 7 +- examples/passing/OperatorSections.purs | 6 +- examples/passing/Operators.purs | 42 ++- examples/passing/RebindableSyntax.purs | 6 +- examples/passing/RedefinedFixity/M1.purs | 7 +- examples/passing/UnicodeType.purs | 9 +- psc-ide-client/Main.hs | 2 +- psc-ide-server/Main.hs | 8 +- psci/PSCi.hs | 3 +- psci/PSCi/Message.hs | 5 +- purescript.cabal | 3 +- src/Language/PureScript/AST/Binders.hs | 2 +- src/Language/PureScript/AST/Declarations.hs | 101 +++--- src/Language/PureScript/AST/Exported.hs | 19 +- src/Language/PureScript/Bundle.hs | 18 +- src/Language/PureScript/CodeGen/JS.hs | 1 - src/Language/PureScript/CodeGen/JS/Common.hs | 1 - .../PureScript/CodeGen/JS/Optimizer/Common.hs | 9 +- .../CodeGen/JS/Optimizer/Inliner.hs | 199 ++++++------ .../CodeGen/JS/Optimizer/MagicDo.hs | 4 +- src/Language/PureScript/CoreFn/Desugar.hs | 30 +- src/Language/PureScript/Docs/AsMarkdown.hs | 28 +- src/Language/PureScript/Docs/Convert.hs | 4 +- .../PureScript/Docs/Convert/ReExports.hs | 110 ++++--- .../PureScript/Docs/Convert/Single.hs | 55 +--- src/Language/PureScript/Docs/Render.hs | 32 +- .../PureScript/Docs/RenderedCode/Render.hs | 2 +- src/Language/PureScript/Docs/Types.hs | 25 +- src/Language/PureScript/Errors.hs | 175 ++++------- src/Language/PureScript/Externs.hs | 41 ++- src/Language/PureScript/Ide/Externs.hs | 14 +- src/Language/PureScript/Ide/Imports.hs | 15 +- src/Language/PureScript/Ide/Types.hs | 1 + src/Language/PureScript/Ide/Util.hs | 5 + src/Language/PureScript/Linter.hs | 12 +- src/Language/PureScript/Linter/Imports.hs | 297 ++++++++++-------- src/Language/PureScript/Make.hs | 6 +- src/Language/PureScript/ModuleDependencies.hs | 8 +- src/Language/PureScript/Names.hs | 87 ++++- src/Language/PureScript/Parser/Common.hs | 10 +- .../PureScript/Parser/Declarations.hs | 41 ++- src/Language/PureScript/Parser/Types.hs | 3 +- src/Language/PureScript/Pretty/Types.hs | 2 +- src/Language/PureScript/Pretty/Values.hs | 5 +- src/Language/PureScript/Sugar.hs | 20 +- .../PureScript/Sugar/BindingGroups.hs | 37 ++- .../PureScript/Sugar/CaseDeclarations.hs | 13 +- src/Language/PureScript/Sugar/Names.hs | 129 ++++---- src/Language/PureScript/Sugar/Names/Common.hs | 66 ++++ src/Language/PureScript/Sugar/Names/Env.hs | 146 ++++++--- .../PureScript/Sugar/Names/Exports.hs | 223 ++++++------- .../PureScript/Sugar/Names/Imports.hs | 188 ++++------- src/Language/PureScript/Sugar/Operators.hs | 277 +++++++++++----- .../PureScript/Sugar/Operators/Binders.hs | 8 +- .../PureScript/Sugar/Operators/Common.hs | 22 +- .../PureScript/Sugar/Operators/Expr.hs | 12 +- .../PureScript/Sugar/Operators/Types.hs | 8 +- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- .../PureScript/Sugar/TypeDeclarations.hs | 40 ++- src/Language/PureScript/TypeChecker.hs | 84 +---- src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 6 +- src/Language/PureScript/Types.hs | 3 +- .../PureScript/Ide/Imports/IntegrationSpec.hs | 2 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 4 +- tests/TestDocs.hs | 5 - 82 files changed, 1499 insertions(+), 1334 deletions(-) delete mode 100644 examples/docs/src/OldOperators.purs create mode 100644 examples/failing/MultipleTypeOpFixities.purs create mode 100644 examples/failing/MultipleValueOpFixities.purs delete mode 100644 examples/failing/RedefinedFixity.purs create mode 100644 src/Language/PureScript/Sugar/Names/Common.hs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 0120af5496..a2bcea0af5 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -31,6 +31,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@joneshf](https://github.com/joneshf) (Hardy Jones) - My existing contributions and all future contributions until further notice are Copyright Hardy Jones, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. +- [@kika](https://github.com/kika) (Kirill Pertsev) - My existing contributions and all future contributions until further notice are Copyright Kirill Pertsev, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@kRITZCREEK](https://github.com/kRITZCREEK) (Christoph Hegemann) - My existing contributions and all future contributions until further notice are Copyright Christoph Hegemann, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@L8D](https://github.com/L8D) (Tenor Biel) My existing contributions and all future contributions until further notice are Copyright Tenor Biel, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@leighman](http://github.com/leighman) (Jack Leigh) My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). diff --git a/examples/docs/src/OldOperators.purs b/examples/docs/src/OldOperators.purs deleted file mode 100644 index 6a69323c65..0000000000 --- a/examples/docs/src/OldOperators.purs +++ /dev/null @@ -1,10 +0,0 @@ - --- Remove this after 0.9. -module OldOperators (module OldOperators2) where - -import OldOperators2 - -module OldOperators2 where - -(>>) :: forall a. a -> a -> a -(>>) a b = b diff --git a/examples/failing/1733.purs b/examples/failing/1733.purs index 389cae5dff..683bb4b202 100644 --- a/examples/failing/1733.purs +++ b/examples/failing/1733.purs @@ -1,4 +1,4 @@ --- @shouldFailWith UnknownValue +-- @shouldFailWith UnknownName module Main where import Thingy as Thing diff --git a/examples/failing/1825.purs b/examples/failing/1825.purs index 0ffc5f240a..5641ecc8cf 100644 --- a/examples/failing/1825.purs +++ b/examples/failing/1825.purs @@ -1,9 +1,9 @@ --- @shouldFailWith UnknownValue +-- @shouldFailWith UnknownName module Main where data W = X | Y | Z -bad X a = a -bad Y _ = a -bad Z a = a +bad X a = a +bad Y _ = a +bad Z a = a diff --git a/examples/failing/Arrays.purs b/examples/failing/Arrays.purs index 479b351234..cb02616637 100644 --- a/examples/failing/Arrays.purs +++ b/examples/failing/Arrays.purs @@ -1,8 +1,6 @@ -- @shouldFailWith TypesDoNotUnify module Main where -import Prelude +foreign import ix :: forall a. Array a -> Int -> a -foreign import (!!) :: forall a. Array a -> Int -> a - -test = \arr -> arr !! (0 !! 0) +test = \arr -> arr `ix` (0 `ix` 0) diff --git a/examples/failing/ExportExplicit.purs b/examples/failing/ExportExplicit.purs index e42012c351..20bdf00269 100644 --- a/examples/failing/ExportExplicit.purs +++ b/examples/failing/ExportExplicit.purs @@ -1,4 +1,4 @@ --- @shouldFailWith UnknownExportValue +-- @shouldFailWith UnknownExport -- should fail as z does not exist in the module module M1 (x, y, z) where diff --git a/examples/failing/ExportExplicit1.purs b/examples/failing/ExportExplicit1.purs index 0229fc415b..9584e5e863 100644 --- a/examples/failing/ExportExplicit1.purs +++ b/examples/failing/ExportExplicit1.purs @@ -1,4 +1,4 @@ --- @shouldFailWith UnknownDataConstructor +-- @shouldFailWith UnknownName module Main where import M1 diff --git a/examples/failing/ExportExplicit3.purs b/examples/failing/ExportExplicit3.purs index 3695393db6..0e9fbf9de4 100644 --- a/examples/failing/ExportExplicit3.purs +++ b/examples/failing/ExportExplicit3.purs @@ -1,4 +1,4 @@ --- @shouldFailWith UnknownDataConstructor +-- @shouldFailWith UnknownName module Main where import M1 diff --git a/examples/failing/ImportExplicit.purs b/examples/failing/ImportExplicit.purs index aaea627b26..d42df77cb4 100644 --- a/examples/failing/ImportExplicit.purs +++ b/examples/failing/ImportExplicit.purs @@ -1,4 +1,4 @@ --- @shouldFailWith UnknownImportType +-- @shouldFailWith UnknownImport module Main where import M1 (X(..)) diff --git a/examples/failing/ImportModule.purs b/examples/failing/ImportModule.purs index d355733526..ba3da26ecf 100644 --- a/examples/failing/ImportModule.purs +++ b/examples/failing/ImportModule.purs @@ -1,4 +1,4 @@ --- @shouldFailWith UnknownModule +-- @shouldFailWith UnknownName module Main where import M1 diff --git a/examples/failing/MultipleErrors2.purs b/examples/failing/MultipleErrors2.purs index 31e007c515..d85439e4bb 100644 --- a/examples/failing/MultipleErrors2.purs +++ b/examples/failing/MultipleErrors2.purs @@ -1,5 +1,5 @@ --- @shouldFailWith UnknownValue --- @shouldFailWith UnknownValue +-- @shouldFailWith UnknownName +-- @shouldFailWith UnknownName module MultipleErrors2 where import Prelude diff --git a/examples/failing/MultipleTypeOpFixities.purs b/examples/failing/MultipleTypeOpFixities.purs new file mode 100644 index 0000000000..b231e5425f --- /dev/null +++ b/examples/failing/MultipleTypeOpFixities.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith MultipleTypeOpFixities +module MultipleTypeOpFixities where + +import Prelude + +type Op x y = Op x y + +infix 2 type Op as !? +infix 2 type Op as !? diff --git a/examples/failing/MultipleValueOpFixities.purs b/examples/failing/MultipleValueOpFixities.purs new file mode 100644 index 0000000000..ac8bfa95d8 --- /dev/null +++ b/examples/failing/MultipleValueOpFixities.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith MultipleValueOpFixities +module MultipleValueOpFixities where + +import Prelude + +add x y = x + y + +infix 2 add as !? +infix 2 add as !? diff --git a/examples/failing/RedefinedFixity.purs b/examples/failing/RedefinedFixity.purs deleted file mode 100644 index 04d2217dbd..0000000000 --- a/examples/failing/RedefinedFixity.purs +++ /dev/null @@ -1,9 +0,0 @@ --- @shouldFailWith MultipleFixities -module RedefinedFixity where - -import Prelude - -(!?) x y = x + y - -infix 2 !? -infix 2 !? diff --git a/examples/failing/UnknownType.purs b/examples/failing/UnknownType.purs index 0b7645d853..d77ccb658b 100644 --- a/examples/failing/UnknownType.purs +++ b/examples/failing/UnknownType.purs @@ -1,4 +1,4 @@ --- @shouldFailWith UnknownType +-- @shouldFailWith UnknownName module Main where import Prelude diff --git a/examples/passing/Dollar.purs b/examples/passing/Dollar.purs index 88be68feb6..34091264d7 100644 --- a/examples/passing/Dollar.purs +++ b/examples/passing/Dollar.purs @@ -2,10 +2,10 @@ module Main where import Prelude () -($) :: forall a b. (a -> b) -> a -> b -($) f x = f x +applyFn :: forall a b. (a -> b) -> a -> b +applyFn f x = f x -infixr 1000 $ +infixr 1000 applyFn as $ id x = x diff --git a/examples/passing/Functions.purs b/examples/passing/Functions.purs index f0e3162aa8..b6da679773 100644 --- a/examples/passing/Functions.purs +++ b/examples/passing/Functions.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test1 = \_ -> 0.0 @@ -8,8 +9,4 @@ test2 = \a b -> a + b + 1.0 test3 = \a -> a -test4 = \(%%) -> 1.0 %% 2.0 - -test5 = \(+++) (***) -> 1.0 +++ 2.0 *** 3.0 - -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/OperatorSections.purs b/examples/passing/OperatorSections.purs index 5b68c6bf43..8b032c5376 100644 --- a/examples/passing/OperatorSections.purs +++ b/examples/passing/OperatorSections.purs @@ -12,7 +12,7 @@ main = do let foo = { x: 2.0 } assert $ (_ / foo.x) 4.0 == 2.0 assert $ (foo.x / _) 4.0 == 0.5 - let (//) x y = x.x / y.x - assert $ (_ // foo { x = 4.0 }) { x: 4.0 } == 1.0 - assert $ (foo { x = 4.0 } // _) { x: 4.0 } == 1.0 + let div x y = x.x / y.x + assert $ (_ `div` foo { x = 4.0 }) { x: 4.0 } == 1.0 + assert $ (foo { x = 4.0 } `div` _) { x: 4.0 } == 1.0 log "Done" diff --git a/examples/passing/Operators.purs b/examples/passing/Operators.purs index 3e16cbbc12..831659f370 100644 --- a/examples/passing/Operators.purs +++ b/examples/passing/Operators.purs @@ -4,8 +4,10 @@ import Prelude import Control.Monad.Eff import Control.Monad.Eff.Console -(?!) :: forall a. a -> a -> a -(?!) x _ = x +op1 :: forall a. a -> a -> a +op1 x _ = x + +infix 4 op1 as ?! bar :: String -> String -> String bar = \s1 s2 -> s1 <> s2 @@ -21,22 +23,26 @@ k = \x -> \y -> x test4 = 1 `k` 2 -infixl 5 %% +op2 :: Number -> Number -> Number +op2 x y = x * y + y -(%%) :: Number -> Number -> Number -(%%) x y = x * y + y +infixl 5 op2 as %% test5 = 1.0 %% 2.0 %% 3.0 test6 = ((\x -> x) `k` 2.0) 3.0 -(<+>) :: String -> String -> String -(<+>) = \s1 s2 -> s1 <> s2 +op3 :: String -> String -> String +op3 = \s1 s2 -> s1 <> s2 + +infix 4 op3 as <+> test7 = "Hello" <+> "World!" -(@@) :: forall a b. (a -> b) -> a -> b -(@@) = \f x -> f x +op4 :: forall a b. (a -> b) -> a -> b +op4 = \f x -> f x + +infix 4 op4 as @@ foo :: String -> String foo = \s -> s @@ -47,14 +53,12 @@ test9 = Main.foo @@ "Hello World" test10 = "Hello" `Main.bar` "World" -(...) :: forall a. Array a -> Array a -> Array a -(...) = \as -> \bs -> as +op5 :: forall a. Array a -> Array a -> Array a +op5 = \as -> \bs -> as -test11 = [1.0, 2.0, 0.0] ... [4.0, 5.0, 6.0] +infix 4 op5 as ... -test12 (<%>) a b = a <%> b - -test13 = \(<%>) a b -> a <%> b +test11 = [1.0, 2.0, 0.0] ... [4.0, 5.0, 6.0] test14 :: Number -> Number -> Boolean test14 a b = a < b @@ -71,11 +75,6 @@ test18 = negate $ negate 1.0 test19 :: Number test19 = negate $ negate (-1.0) -test20 :: Number -test20 = 1.0 @ 2.0 - where - (@) x y = x + y * y - main = do let t1 = test1 1.0 2.0 (\x y -> x + y) let t2 = test2 @@ -88,12 +87,9 @@ main = do let t9 = test9 let t10 = test10 let t11 = test11 - let t12 = test12 k 1.0 2.0 - let t13 = test13 k 1.0 2.0 let t14 = test14 1.0 2.0 let t15 = test15 1.0 2.0 let t17 = test17 let t18 = test18 let t19 = test19 - let t20 = test20 log "Done" diff --git a/examples/passing/RebindableSyntax.purs b/examples/passing/RebindableSyntax.purs index 4356127b43..95303a8360 100644 --- a/examples/passing/RebindableSyntax.purs +++ b/examples/passing/RebindableSyntax.purs @@ -12,8 +12,10 @@ example1 = do where bind x f = x <> f unit -(*>) :: forall f a b. (Apply f) => f a -> f b -> f b -(*>) fa fb = const id <$> fa <*> fb +applySecond :: forall f a b. (Apply f) => f a -> f b -> f b +applySecond fa fb = const id <$> fa <*> fb + +infixl 4 applySecond as *> newtype Const a b = Const a diff --git a/examples/passing/RedefinedFixity/M1.purs b/examples/passing/RedefinedFixity/M1.purs index 2d6fc3da7f..13f7f11ca2 100644 --- a/examples/passing/RedefinedFixity/M1.purs +++ b/examples/passing/RedefinedFixity/M1.purs @@ -1,7 +1,6 @@ module M1 where -import Prelude () +applyFn :: forall a b. (forall c d. c -> d) -> a -> b +applyFn f a = f a -($) f a = f a - -infixr 1000 $ +infixr 1000 applyFn as $ diff --git a/examples/passing/UnicodeType.purs b/examples/passing/UnicodeType.purs index a65d4a30d8..59e732f8ad 100644 --- a/examples/passing/UnicodeType.purs +++ b/examples/passing/UnicodeType.purs @@ -1,11 +1,12 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) -class (Monad m) ⇐ Monad1 m where +class Monad m ⇐ Monad1 m where f1 :: Int -class (Monad m) <= Monad2 m where +class Monad m <= Monad2 m where f2 :: Int f ∷ ∀ m. Monad m ⇒ Int → m Int @@ -18,6 +19,4 @@ f' n = do n' <- pure n pure n' -(←→) a b = a ←→ b - -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs index 17c05963e5..79532e51e1 100644 --- a/psc-ide-client/Main.hs +++ b/psc-ide-client/Main.hs @@ -35,7 +35,7 @@ main = do client :: PortID -> IO () client port = do h <- - connectTo "localhost" port `catch` + connectTo "127.0.0.1" port `catch` (\(SomeException e) -> putStrLn ("Couldn't connect to psc-ide-server on port: " ++ diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 2d4f49cb26..650f25eeed 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -39,10 +39,10 @@ import Language.PureScript.Ide.Util import Language.PureScript.Ide.Error import Language.PureScript.Ide.Types import Language.PureScript.Ide.Watcher -import Network hiding (socketPort) +import Network hiding (socketPort, accept) import Network.BSD (getProtocolNumber) import Network.Socket hiding (PortNumber, Type, - accept, sClose) + sClose) import Options.Applicative import System.Directory import System.FilePath @@ -166,7 +166,9 @@ acceptCommand sock = do pure (cmd, h) where acceptConnection = liftIO $ do - (h,_,_) <- accept sock + -- Use low level accept to prevent accidental reverse name resolution + (s,_) <- accept sock + h <- socketToHandle s ReadWriteMode hSetEncoding h utf8 hSetBuffering h LineBuffering pure h diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 679bbbb06f..f77a367902 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -253,8 +253,9 @@ handleShowImportedModules = do showRef :: P.DeclarationRef -> String showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" - showRef (P.TypeOpRef ident) = "type (" ++ N.runIdent ident ++ ")" + showRef (P.TypeOpRef op) = "type " ++ N.showOp op showRef (P.ValueRef ident) = N.runIdent ident + showRef (P.ValueOpRef op) = N.showOp op showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn showRef (P.TypeInstanceRef ident) = N.runIdent ident showRef (P.ModuleRef name) = "module " ++ N.runModuleName name diff --git a/psci/PSCi/Message.hs b/psci/PSCi/Message.hs index bd20b48b4c..883ca61642 100644 --- a/psci/PSCi/Message.hs +++ b/psci/PSCi/Message.hs @@ -1,9 +1,9 @@ module PSCi.Message where - import Data.List (intercalate) -import qualified PSCi.Directive as D + import PSCi.Types +import qualified PSCi.Directive as D -- Messages @@ -50,4 +50,3 @@ prologueMessage = intercalate "\n" -- quitMessage :: String quitMessage = "See ya!" - diff --git a/purescript.cabal b/purescript.cabal index f9ba55e378..ded0c22011 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -194,9 +194,10 @@ library Language.PureScript.Sugar.CaseDeclarations Language.PureScript.Sugar.DoNotation Language.PureScript.Sugar.Names + Language.PureScript.Sugar.Names.Common Language.PureScript.Sugar.Names.Env - Language.PureScript.Sugar.Names.Imports Language.PureScript.Sugar.Names.Exports + Language.PureScript.Sugar.Names.Imports Language.PureScript.Sugar.ObjectWildcards Language.PureScript.Sugar.Operators Language.PureScript.Sugar.Operators.Common diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index 6d52db53b5..756c7269bb 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -35,7 +35,7 @@ data Binder -- A operator alias binder. During the rebracketing phase of desugaring, -- this data constructor will be removed. -- - | OpBinder (Qualified Ident) + | OpBinder (Qualified (OpName 'ValueOpName)) -- | -- Binary operator application. During the rebracketing phase of desugaring, -- this data constructor will be removed. diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 94df7c6670..0f6df99c92 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -10,8 +10,6 @@ import Prelude.Compat import Control.Monad.Identity import Data.Aeson.TH -import Data.List (nub, (\\)) -import Data.Maybe (mapMaybe) import qualified Data.Map as M import Language.PureScript.AST.Binders @@ -60,16 +58,20 @@ data DeclarationRef -- | -- A type operator -- - | TypeOpRef Ident + | TypeOpRef (OpName 'TypeOpName) -- | -- A value -- | ValueRef Ident -- | + -- A value-level operator + -- + | ValueOpRef (OpName 'ValueOpName) + -- | -- A type class -- | TypeClassRef (ProperName 'ClassName) - -- | + -- | -- A type class instance, created during typeclass desugaring (name, class name, instance types) -- | TypeInstanceRef Ident @@ -87,6 +89,7 @@ instance Eq DeclarationRef where (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors' (TypeOpRef name) == (TypeOpRef name') = name == name' (ValueRef name) == (ValueRef name') = name == name' + (ValueOpRef name) == (ValueOpRef name') = name == name' (TypeClassRef name) == (TypeClassRef name') = name == name' (TypeInstanceRef name) == (TypeInstanceRef name') = name == name' (ModuleRef name) == (ModuleRef name') = name == name' @@ -94,33 +97,36 @@ instance Eq DeclarationRef where r == (PositionedDeclarationRef _ _ r') = r == r' _ == _ = False +getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) +getTypeRef (TypeRef name dctors) = Just (name, dctors) +getTypeRef (PositionedDeclarationRef _ _ r) = getTypeRef r +getTypeRef _ = Nothing + +getTypeOpRef :: DeclarationRef -> Maybe (OpName 'TypeOpName) +getTypeOpRef (TypeOpRef op) = Just op +getTypeOpRef (PositionedDeclarationRef _ _ r) = getTypeOpRef r +getTypeOpRef _ = Nothing + +getValueRef :: DeclarationRef -> Maybe Ident +getValueRef (ValueRef name) = Just name +getValueRef (PositionedDeclarationRef _ _ r) = getValueRef r +getValueRef _ = Nothing + +getValueOpRef :: DeclarationRef -> Maybe (OpName 'ValueOpName) +getValueOpRef (ValueOpRef op) = Just op +getValueOpRef (PositionedDeclarationRef _ _ r) = getValueOpRef r +getValueOpRef _ = Nothing + +getTypeClassRef :: DeclarationRef -> Maybe (ProperName 'ClassName) +getTypeClassRef (TypeClassRef name) = Just name +getTypeClassRef (PositionedDeclarationRef _ _ r) = getTypeClassRef r +getTypeClassRef _ = Nothing + isModuleRef :: DeclarationRef -> Bool isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r isModuleRef (ModuleRef _) = True isModuleRef _ = False --- | --- Finds duplicate values in a list of declaration refs. The returned values --- are the duplicate refs with data constructors elided, and then a separate --- list of duplicate data constructors. --- -findDuplicateRefs :: [DeclarationRef] -> ([DeclarationRef], [ProperName 'ConstructorName]) -findDuplicateRefs refs = - let positionless = stripPosInfo `map` refs - simplified = simplifyTypeRefs `map` positionless - dupeRefs = nub $ simplified \\ nub simplified - dupeCtors = concat $ flip mapMaybe positionless $ \case - TypeRef _ (Just dctors) -> - let dupes = dctors \\ nub dctors - in if null dupes then Nothing else Just dupes - _ -> Nothing - in (dupeRefs, dupeCtors) - where - stripPosInfo (PositionedDeclarationRef _ _ ref) = stripPosInfo ref - stripPosInfo other = other - simplifyTypeRefs (TypeRef pn _) = TypeRef pn Nothing - simplifyTypeRefs other = other - -- | -- The data type which specifies type of import declaration -- @@ -184,9 +190,9 @@ data Declaration -- | ExternDataDeclaration (ProperName 'TypeName) Kind -- | - -- A fixity declaration (fixity data, operator name, value the operator is an alias for) + -- A fixity declaration -- - | FixityDeclaration Fixity String (Maybe (Qualified FixityAlias)) + | FixityDeclaration (Either ValueFixity TypeFixity) -- | -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name) -- @@ -206,30 +212,14 @@ data Declaration | PositionedDeclaration SourceSpan [Comment] Declaration deriving (Show, Read) -data FixityAlias - = AliasValue Ident - | AliasConstructor (ProperName 'ConstructorName) - | AliasType (ProperName 'TypeName) +data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName) deriving (Eq, Ord, Show, Read) -foldFixityAlias - :: (Ident -> a) - -> (ProperName 'ConstructorName -> a) - -> (ProperName 'TypeName -> a) - -> FixityAlias - -> a -foldFixityAlias f _ _ (AliasValue name) = f name -foldFixityAlias _ g _ (AliasConstructor name) = g name -foldFixityAlias _ _ h (AliasType name) = h name - -getValueAlias :: FixityAlias -> Maybe (Either Ident (ProperName 'ConstructorName)) -getValueAlias (AliasValue name) = Just $ Left name -getValueAlias (AliasConstructor name) = Just $ Right name -getValueAlias _ = Nothing - -getTypeAlias :: FixityAlias -> Maybe (ProperName 'TypeName) -getTypeAlias (AliasType name) = Just name -getTypeAlias _ = Nothing +data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName) + deriving (Eq, Ord, Show, Read) + +pattern ValueFixityDeclaration fixity name op = FixityDeclaration (Left (ValueFixity fixity name op)) +pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFixity fixity name op)) -- | The members of a type class instance declaration data TypeInstanceBody @@ -288,6 +278,11 @@ isFixityDecl FixityDeclaration{} = True isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d isFixityDecl _ = False +getFixityDecl :: Declaration -> Maybe (Either ValueFixity TypeFixity) +getFixityDecl (FixityDeclaration fixity) = Just fixity +getFixityDecl (PositionedDeclaration _ _ d) = getFixityDecl d +getFixityDecl _ = Nothing + -- | -- Test if a declaration is a foreign import -- @@ -376,6 +371,11 @@ data Expr -- | Var (Qualified Ident) -- | + -- An operator. This will be desugared into a function during the "operators" + -- phase of desugaring. + -- + | Op (Qualified (OpName 'ValueOpName)) + -- | -- Conditional (if-then-else expression) -- | IfThenElse Expr Expr Expr @@ -473,4 +473,3 @@ data DoNotationElement $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType) -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''FixityAlias) diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index ee7547ff53..93e9585d29 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -127,18 +127,15 @@ isExported _ TypeInstanceDeclaration{} = True isExported exps (PositionedDeclaration _ _ d) = isExported exps d isExported (Just exps) decl = any (matches decl) exps where - matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident' - matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident' - matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident' - matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident' - matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident' - matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident' + matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident' + matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident' + matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident' + matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident' + matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident' + matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident' matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident' - - matches (FixityDeclaration _ name (Just (Qualified _ (AliasValue _)))) (ValueRef ident') = name == runIdent ident' - matches (FixityDeclaration _ name (Just (Qualified _ (AliasConstructor _)))) (ValueRef ident') = name == runIdent ident' - matches (FixityDeclaration _ name (Just (Qualified _ (AliasType _)))) (TypeOpRef ident') = name == runIdent ident' - + matches (ValueFixityDeclaration _ _ op) (ValueOpRef op') = op == op' + matches (TypeFixityDeclaration _ _ op) (TypeOpRef op') = op == op' matches (PositionedDeclaration _ _ d) r = d `matches` r matches d (PositionedDeclarationRef _ _ r) = d `matches` r matches _ _ = False diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 2cba0ae884..e3fbe0851f 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -4,15 +4,15 @@ -- This module takes as input the individual generated modules from 'Language.PureScript.Make' and -- performs dead code elimination, filters empty modules, -- and generates the final Javascript bundle. -module Language.PureScript.Bundle ( - bundle - , ModuleIdentifier(..) - , moduleName - , ModuleType(..) - , ErrorMessage(..) - , printErrorMessage - , getExportedIdentifiers -) where +module Language.PureScript.Bundle + ( bundle + , ModuleIdentifier(..) + , moduleName + , ModuleType(..) + , ErrorMessage(..) + , printErrorMessage + , getExportedIdentifiers + ) where import Prelude.Compat diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 3738cfc0d6..dfc13018a2 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -173,7 +173,6 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- accessor :: Ident -> JS -> JS accessor (Ident prop) = accessorString prop - accessor (Op op) = JSIndexer Nothing (JSStringLiteral Nothing op) accessor (GenIdent _ _) = internalError "GenIdent in accessor" accessorString :: String -> JS -> JS diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index bcfb48b82d..45b5391aa0 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -29,7 +29,6 @@ identToJs :: Ident -> String identToJs (Ident name) | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name | otherwise = concatMap identCharToString name -identToJs (Op op) = concatMap identCharToString op identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" -- | diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs index 951b1b4ca6..a7ed7fb776 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs @@ -68,13 +68,12 @@ removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts) removeFromBlock _ js = js isFn :: (String, String) -> JS -> Bool -isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) = x == fnName && y == moduleName -isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = x == fnName && y == moduleName +isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) = + x == fnName && y == moduleName +isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = + x == fnName && y == moduleName isFn _ _ = False -isFn' :: [(String, String)] -> JS -> Bool -isFn' xs js = any (`isFn` js) xs - isDict :: (String, String) -> JS -> Bool isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName isDict _ _ = False diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index e8472e591c..c46bc801c5 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -19,9 +19,7 @@ import Control.Monad.Supply.Class (MonadSupply, freshName) import Data.Maybe (fromMaybe) import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.CodeGen.JS.Common import Language.PureScript.CodeGen.JS.Optimizer.Common -import Language.PureScript.Names import qualified Language.PureScript.Constants as C -- TODO: Potential bug: @@ -82,24 +80,24 @@ inlineCommonValues = everywhereOnJS convert where convert :: JS -> JS convert (JSApp ss fn [dict]) - | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral ss (Left 0) - | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral ss (Left 1) - | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral ss False - | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral ss True + | isDict' [semiringNumber, semiringInt] dict && isFn fnZero fn = JSNumericLiteral ss (Left 0) + | isDict' [semiringNumber, semiringInt] dict && isFn fnOne fn = JSNumericLiteral ss (Left 1) + | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral ss False + | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral ss True convert (JSApp ss (JSApp _ (JSApp _ fn [dict]) [x]) [y]) - | isDict' semiringInt dict && isFn' fnAdd fn = intOp ss Add x y - | isDict' semiringInt dict && isFn' fnMultiply fn = intOp ss Multiply x y - | isDict' euclideanRingInt dict && isFn' fnDivide fn = intOp ss Divide x y - | isDict' ringInt dict && isFn' fnSubtract fn = intOp ss Subtract x y + | isDict semiringInt dict && isFn fnAdd fn = intOp ss Add x y + | isDict semiringInt dict && isFn fnMultiply fn = intOp ss Multiply x y + | isDict euclideanRingInt dict && isFn fnDivide fn = intOp ss Divide x y + | isDict ringInt dict && isFn fnSubtract fn = intOp ss Subtract x y convert other = other - fnZero = [(C.prelude, C.zero), (C.dataSemiring, C.zero)] - fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)] - fnBottom = [(C.prelude, C.bottom), (C.dataBounded, C.bottom)] - fnTop = [(C.prelude, C.top), (C.dataBounded, C.top)] - fnAdd = [(C.prelude, (C.+)), (C.prelude, (C.add)), (C.dataSemiring, (C.+)), (C.dataSemiring, (C.add))] - fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataEuclideanRing, C.div)] - fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))] - fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)] + fnZero = (C.dataSemiring, C.zero) + fnOne = (C.dataSemiring, C.one) + fnBottom = (C.dataBounded, C.bottom) + fnTop = (C.dataBounded, C.top) + fnAdd = (C.dataSemiring, C.add) + fnDivide = (C.dataEuclideanRing, C.div) + fnMultiply = (C.dataSemiring, C.mul) + fnSubtract = (C.dataRing, C.sub) intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0)) inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS @@ -108,7 +106,6 @@ inlineOperator (m, op) f = everywhereOnJS convert convert :: JS -> JS convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y convert other = other - isOp (JSAccessor _ longForm (JSVar _ m')) = m == m' && longForm == identToJs (Op op) isOp (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) = m == m' && op == op' isOp _ = False @@ -173,11 +170,11 @@ inlineCommonOperators = applyAll $ ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] where - binary :: [(String, String)] -> [(String, String)] -> BinaryOperator -> JS -> JS + binary :: (String, String) -> (String, String) -> BinaryOperator -> JS -> JS binary dict fns op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary ss op x y + convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isFn fns fn = JSBinary ss op x y convert other = other binary' :: String -> String -> BinaryOperator -> JS -> JS binary' moduleName opString op = everywhereOnJS convert @@ -185,11 +182,11 @@ inlineCommonOperators = applyAll $ convert :: JS -> JS convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y convert other = other - unary :: [(String, String)] -> [(String, String)] -> UnaryOperator -> JS -> JS + unary :: (String, String) -> (String, String) -> UnaryOperator -> JS -> JS unary dicts fns op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary ss op x + convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isFn fns fn = JSUnary ss op x convert other = other unary' :: String -> String -> UnaryOperator -> JS -> JS unary' moduleName fnName op = everywhereOnJS convert @@ -251,118 +248,118 @@ inlineFnComposition = everywhereOnJSTopDownM convert return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing y [JSApp Nothing x [JSVar Nothing arg]]]) convert other = return other isFnCompose :: JS -> JS -> Bool - isFnCompose dict' fn = isDict' semigroupoidFn dict' && isFn' fnCompose fn + isFnCompose dict' fn = isDict semigroupoidFn dict' && isFn fnCompose fn isFnComposeFlipped :: JS -> JS -> Bool - isFnComposeFlipped dict' fn = isDict' semigroupoidFn dict' && isFn' fnComposeFlipped fn - fnCompose :: [(String, String)] - fnCompose = [(C.prelude, C.compose), (C.prelude, (C.<<<)), (C.controlSemigroupoid, C.compose)] - fnComposeFlipped :: [(String, String)] - fnComposeFlipped = [(C.prelude, (C.>>>)), (C.controlSemigroupoid, C.composeFlipped)] + isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isFn fnComposeFlipped fn + fnCompose :: (String, String) + fnCompose = (C.controlSemigroupoid, C.compose) + fnComposeFlipped :: (String, String) + fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped) -semiringNumber :: [(String, String)] -semiringNumber = [(C.prelude, C.semiringNumber), (C.dataSemiring, C.semiringNumber)] +semiringNumber :: (String, String) +semiringNumber = (C.dataSemiring, C.semiringNumber) -semiringInt :: [(String, String)] -semiringInt = [(C.prelude, C.semiringInt), (C.dataSemiring, C.semiringInt)] +semiringInt :: (String, String) +semiringInt = (C.dataSemiring, C.semiringInt) -ringNumber :: [(String, String)] -ringNumber = [(C.prelude, C.ringNumber), (C.dataRing, C.ringNumber)] +ringNumber :: (String, String) +ringNumber = (C.dataRing, C.ringNumber) -ringInt :: [(String, String)] -ringInt = [(C.prelude, C.ringInt), (C.dataRing, C.ringInt)] +ringInt :: (String, String) +ringInt = (C.dataRing, C.ringInt) -euclideanRingNumber :: [(String, String)] -euclideanRingNumber = [(C.prelude, C.moduloSemiringNumber), (C.dataEuclideanRing, C.euclideanRingNumber)] +euclideanRingNumber :: (String, String) +euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber) -euclideanRingInt :: [(String, String)] -euclideanRingInt = [(C.prelude, C.moduloSemiringInt), (C.dataEuclideanRing, C.euclideanRingInt)] +euclideanRingInt :: (String, String) +euclideanRingInt = (C.dataEuclideanRing, C.euclideanRingInt) -eqNumber :: [(String, String)] -eqNumber = [(C.prelude, C.eqNumber), (C.dataEq, C.eqNumber)] +eqNumber :: (String, String) +eqNumber = (C.dataEq, C.eqNumber) -eqInt :: [(String, String)] -eqInt = [(C.prelude, C.eqInt), (C.dataEq, C.eqInt)] +eqInt :: (String, String) +eqInt = (C.dataEq, C.eqInt) -eqString :: [(String, String)] -eqString = [(C.prelude, C.eqString), (C.dataEq, C.eqString)] +eqString :: (String, String) +eqString = (C.dataEq, C.eqString) -eqChar :: [(String, String)] -eqChar = [(C.prelude, C.eqChar), (C.dataEq, C.eqChar)] +eqChar :: (String, String) +eqChar = (C.dataEq, C.eqChar) -eqBoolean :: [(String, String)] -eqBoolean = [(C.prelude, C.eqBoolean), (C.dataEq, C.eqBoolean)] +eqBoolean :: (String, String) +eqBoolean = (C.dataEq, C.eqBoolean) -ordBoolean :: [(String, String)] -ordBoolean = [(C.prelude, C.ordBoolean), (C.dataOrd, C.ordBoolean)] +ordBoolean :: (String, String) +ordBoolean = (C.dataOrd, C.ordBoolean) -ordNumber :: [(String, String)] -ordNumber = [(C.prelude, C.ordNumber), (C.dataOrd, C.ordNumber)] +ordNumber :: (String, String) +ordNumber = (C.dataOrd, C.ordNumber) -ordInt :: [(String, String)] -ordInt = [(C.prelude, C.ordInt), (C.dataOrd, C.ordInt)] +ordInt :: (String, String) +ordInt = (C.dataOrd, C.ordInt) -ordString :: [(String, String)] -ordString = [(C.prelude, C.ordString), (C.dataOrd, C.ordString)] +ordString :: (String, String) +ordString = (C.dataOrd, C.ordString) -ordChar :: [(String, String)] -ordChar = [(C.prelude, C.ordChar), (C.dataOrd, C.ordChar)] +ordChar :: (String, String) +ordChar = (C.dataOrd, C.ordChar) -semigroupString :: [(String, String)] -semigroupString = [(C.prelude, C.semigroupString), (C.dataSemigroup, C.semigroupString)] +semigroupString :: (String, String) +semigroupString = (C.dataSemigroup, C.semigroupString) -boundedBoolean :: [(String, String)] -boundedBoolean = [(C.prelude, C.boundedBoolean), (C.dataBounded, C.boundedBoolean)] +boundedBoolean :: (String, String) +boundedBoolean = (C.dataBounded, C.boundedBoolean) -heytingAlgebraBoolean :: [(String, String)] -heytingAlgebraBoolean = [(C.prelude, C.booleanAlgebraBoolean), (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)] +heytingAlgebraBoolean :: (String, String) +heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean) -semigroupoidFn :: [(String, String)] -semigroupoidFn = [(C.prelude, C.semigroupoidFn), (C.controlSemigroupoid, C.semigroupoidFn)] +semigroupoidFn :: (String, String) +semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn) -opAdd :: [(String, String)] -opAdd = [(C.prelude, (C.+)), (C.prelude, C.add), (C.dataSemiring, C.add)] +opAdd :: (String, String) +opAdd = (C.dataSemiring, C.add) -opMul :: [(String, String)] -opMul = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, C.mul)] +opMul :: (String, String) +opMul = (C.dataSemiring, C.mul) -opEq :: [(String, String)] -opEq = [(C.prelude, (C.==)), (C.prelude, C.eq), (C.dataEq, C.eq)] +opEq :: (String, String) +opEq = (C.dataEq, C.eq) -opNotEq :: [(String, String)] -opNotEq = [(C.prelude, (C./=)), (C.dataEq, C.notEq)] +opNotEq :: (String, String) +opNotEq = (C.dataEq, C.notEq) -opLessThan :: [(String, String)] -opLessThan = [(C.prelude, (C.<)), (C.dataOrd, C.lessThan)] +opLessThan :: (String, String) +opLessThan = (C.dataOrd, C.lessThan) -opLessThanOrEq :: [(String, String)] -opLessThanOrEq = [(C.prelude, (C.<=)), (C.dataOrd, C.lessThanOrEq)] +opLessThanOrEq :: (String, String) +opLessThanOrEq = (C.dataOrd, C.lessThanOrEq) -opGreaterThan :: [(String, String)] -opGreaterThan = [(C.prelude, (C.>)), (C.dataOrd, C.greaterThan)] +opGreaterThan :: (String, String) +opGreaterThan = (C.dataOrd, C.greaterThan) -opGreaterThanOrEq :: [(String, String)] -opGreaterThanOrEq = [(C.prelude, (C.>=)), (C.dataOrd, C.greaterThanOrEq)] +opGreaterThanOrEq :: (String, String) +opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq) -opAppend :: [(String, String)] -opAppend = [(C.prelude, (C.<>)), (C.prelude, (C.++)), (C.prelude, C.append), (C.dataSemigroup, C.append)] +opAppend :: (String, String) +opAppend = (C.dataSemigroup, C.append) -opSub :: [(String, String)] -opSub = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)] +opSub :: (String, String) +opSub = (C.dataRing, C.sub) -opNegate :: [(String, String)] -opNegate = [(C.prelude, C.negate), (C.dataRing, C.negate)] +opNegate :: (String, String) +opNegate = (C.dataRing, C.negate) -opDiv :: [(String, String)] -opDiv = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataEuclideanRing, C.div)] +opDiv :: (String, String) +opDiv = (C.dataEuclideanRing, C.div) -opMod :: [(String, String)] -opMod = [(C.prelude, C.mod), (C.dataEuclideanRing, C.mod)] +opMod :: (String, String) +opMod = (C.dataEuclideanRing, C.mod) -opConj :: [(String, String)] -opConj = [(C.prelude, (C.&&)), (C.prelude, C.conj), (C.dataHeytingAlgebra, C.conj)] +opConj :: (String, String) +opConj = (C.dataHeytingAlgebra, C.conj) -opDisj :: [(String, String)] -opDisj = [(C.prelude, (C.||)), (C.prelude, C.disj), (C.dataHeytingAlgebra, C.disj)] +opDisj :: (String, String) +opDisj = (C.dataHeytingAlgebra, C.disj) -opNot :: [(String, String)] -opNot = [(C.prelude, C.not), (C.dataHeytingAlgebra, C.not)] +opNot :: (String, String) +opNot = (C.dataHeytingAlgebra, C.not) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs index 3cf0096a94..8fb82abb34 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs @@ -63,9 +63,9 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert isPure (JSApp _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True isPure _ = False -- Check if an expression represents the polymorphic >>= function - isBindPoly = isFn' [(C.prelude, C.bind), (C.prelude, (C.>>=)), (C.controlBind, C.bind)] + isBindPoly = isFn (C.controlBind, C.bind) -- Check if an expression represents the polymorphic pure or return function - isPurePoly = isFn' [(C.prelude, C.pure'), (C.prelude, C.return), (C.controlApplicative, C.pure')] + isPurePoly = isFn (C.controlApplicative, C.pure') -- Check if an expression represents a function in the Eff module isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name' isEffFunc _ _ = False diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index c9d1039eb8..e36d07d1ec 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -70,12 +70,6 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) = [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] - declToCoreFn ss com (A.FixityDeclaration _ name (Just (Qualified mn' (A.AliasValue name')))) = - let meta = getValueMeta (Qualified mn' name') - in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) (Qualified mn' name'))] - declToCoreFn ss com (A.FixityDeclaration _ name (Just (Qualified mn' (A.AliasConstructor name')))) = - let meta = Just $ getConstructorMeta (Qualified mn' name') - in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) (Qualified mn' (properToIdent name')))] declToCoreFn ss _ (A.BindingGroupDeclaration ds) = [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds] declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) = @@ -204,25 +198,25 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = findQualModules :: [A.Declaration] -> [(Ann, ModuleName)] findQualModules decls = let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const []) - in f `concatMap` decls + in map (nullAnn,) $ f `concatMap` decls where - fqDecls :: A.Declaration -> [(Ann, ModuleName)] - fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q - fqDecls (A.FixityDeclaration _ _ (Just q)) = getQual q + fqDecls :: A.Declaration -> [ModuleName] + fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual' q + fqDecls (A.ValueFixityDeclaration _ q _) = getQual' q + fqDecls (A.TypeFixityDeclaration _ q _) = getQual' q fqDecls _ = [] - fqValues :: A.Expr -> [(Ann, ModuleName)] - fqValues (A.Var q) = getQual q - fqValues (A.Constructor q) = getQual q + fqValues :: A.Expr -> [ModuleName] + fqValues (A.Var q) = getQual' q + fqValues (A.Constructor q) = getQual' q fqValues _ = [] - fqBinders :: A.Binder -> [(Ann, ModuleName)] - fqBinders (A.ConstructorBinder q _) = getQual q + fqBinders :: A.Binder -> [ModuleName] + fqBinders (A.ConstructorBinder q _) = getQual' q fqBinders _ = [] - getQual :: Qualified a -> [(Ann, ModuleName)] - getQual (Qualified (Just mn) _) = [(nullAnn, mn)] - getQual _ = [] + getQual' :: Qualified a -> [ModuleName] + getQual' = maybe [] return . getQual -- | -- Desugars import declarations from AST to CoreFn representation. diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 9b3650e73f..4a07663828 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -59,8 +59,6 @@ declAsMarkdown mn decl@Declaration{..} = do zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children spacer - for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer) - for_ declComments tell' unless (null instances) $ do @@ -82,19 +80,19 @@ codeToString = outputWith elemAsMarkdown elemAsMarkdown (Keyword x) = x elemAsMarkdown Space = " " -fixityAsMarkdown :: P.Fixity -> Docs -fixityAsMarkdown (P.Fixity associativity precedence) = - tell' $ concat [ "_" - , associativityStr - , " / precedence " - , show precedence - , "_" - ] - where - associativityStr = case associativity of - P.Infixl -> "left-associative" - P.Infixr -> "right-associative" - P.Infix -> "non-associative" +-- fixityAsMarkdown :: P.Fixity -> Docs +-- fixityAsMarkdown (P.Fixity associativity precedence) = +-- tell' $ concat [ "_" +-- , associativityStr +-- , " / precedence " +-- , show precedence +-- , "_" +-- ] +-- where +-- associativityStr = case associativity of +-- P.Infixl -> "left-associative" +-- P.Infixr -> "right-associative" +-- P.Infix -> "non-associative" childToString :: First -> ChildDeclaration -> String childToString f decl@ChildDeclaration{..} = diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 404b488d27..a5f9c346a5 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -185,8 +185,8 @@ partiallyDesugar = P.evalSupplyT 0 . desugar' where desugar' = traverse P.desugarDoModule - >=> P.desugarCasesModule - >=> P.desugarTypeDeclarationsModule + >=> traverse P.desugarCasesModule + >=> traverse P.desugarTypeDeclarationsModule >=> ignoreWarnings . P.desugarImportsWithEnv [] ignoreWarnings = fmap fst . runWriterT diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index cba223ddc1..9fd1b5a00c 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -35,8 +35,7 @@ updateReExports :: [P.ModuleName] -> Map P.ModuleName Module -> Map P.ModuleName Module -updateReExports env order modules = - execState action modules +updateReExports env order = execState action where action = void (traverse go order) @@ -103,17 +102,18 @@ collectDeclarations :: P.Exports -> m [(P.ModuleName, [Declaration])] collectDeclarations imports exports = do - valsAndMembers <- collect lookupValueDeclaration impVals expVals - typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs - types <- collect lookupTypeDeclaration impTypes expTypes - typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps + valsAndMembers <- collect lookupValueDeclaration impVals expVals + valOps <- collect lookupValueOpDeclaration impValOps expValOps + typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs + types <- collect lookupTypeDeclaration impTypes expTypes + typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses let filteredTypes = filterDataConstructors expCtors types let filteredClasses = filterTypeClassMembers (map fst expVals) classes - pure (Map.toList (Map.unionsWith (<>) [filteredTypes, typeOps, filteredClasses, vals])) + pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps])) where collect lookup' imps exps = do @@ -123,6 +123,9 @@ collectDeclarations imports exports = do expVals = P.exportedValues exports impVals = concat (Map.elems (P.importedValues imports)) + expValOps = P.exportedValueOps exports + impValOps = concat (Map.elems (P.importedValueOps imports)) + expTypes = map (first fst) (P.exportedTypes exports) impTypes = concat (Map.elems (P.importedTypes imports)) @@ -221,6 +224,20 @@ lookupValueDeclaration importedFrom ident = do thd :: (a, b, c) -> c thd (_, _, x) = x +lookupValueOpDeclaration + :: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) + => P.ModuleName + -> P.OpName 'P.ValueOpName + -> m (P.ModuleName, [Declaration]) +lookupValueOpDeclaration importedFrom op = do + decls <- lookupModuleDeclarations "lookupValueOpDeclaration" importedFrom + case filter (\d -> declTitle d == P.showOp op && isValueAlias d) decls of + [d] -> + pure (importedFrom, [d]) + other -> + internalErrorInModule + ("lookupValueOpDeclaration: unexpected result for: " ++ show other) + -- | -- Extract a particular type declaration. For data declarations, constructors -- are only included in the output if they are listed in the arguments. @@ -242,16 +259,15 @@ lookupTypeDeclaration importedFrom ty = do internalErrorInModule ("lookupTypeDeclaration: unexpected result: " ++ show other) -lookupTypeOpDeclaration :: - (MonadState (Map P.ModuleName Module) m, - MonadReader P.ModuleName m) => - P.ModuleName -> - P.Ident -> - m (P.ModuleName, [Declaration]) +lookupTypeOpDeclaration + :: (MonadState (Map P.ModuleName Module) m,MonadReader P.ModuleName m) + => P.ModuleName + -> P.OpName 'P.TypeOpName + -> m (P.ModuleName, [Declaration]) lookupTypeOpDeclaration importedFrom tyOp = do decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom let - ds = filter (\d -> declTitle d == ("type " ++ P.showIdent tyOp) && isTypeAlias d) decls + ds = filter (\d -> declTitle d == ("type " ++ P.showOp tyOp) && isTypeAlias d) decls case ds of [d] -> pure (importedFrom, [d]) @@ -259,12 +275,11 @@ lookupTypeOpDeclaration importedFrom tyOp = do internalErrorInModule ("lookupTypeOpDeclaration: unexpected result: " ++ show other) -lookupTypeClassDeclaration :: - (MonadState (Map P.ModuleName Module) m, - MonadReader P.ModuleName m) => - P.ModuleName -> - P.ProperName 'P.ClassName -> - m (P.ModuleName, [Declaration]) +lookupTypeClassDeclaration + :: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) + => P.ModuleName + -> P.ProperName 'P.ClassName + -> m (P.ModuleName, [Declaration]) lookupTypeClassDeclaration importedFrom tyClass = do decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom let @@ -369,10 +384,10 @@ instance Monoid TypeClassEnv where -- -- Returns a tuple of (values, type classes). -- -handleEnv :: - (MonadReader P.ModuleName m) => - TypeClassEnv -> - m ([Declaration], [Declaration]) +handleEnv + :: (MonadReader P.ModuleName m) + => TypeClassEnv + -> m ([Declaration], [Declaration]) handleEnv TypeClassEnv{..} = envUnhandledMembers |> foldM go (envValues, mkMap envTypeClasses) @@ -400,7 +415,6 @@ handleEnv TypeClassEnv{..} = , declComments = cdeclComments , declSourceSpan = cdeclSourceSpan , declChildren = [] - , declFixity = Nothing , declInfo = ValueDeclaration (addConstraint constraint typ) } _ -> @@ -421,10 +435,10 @@ splitMap = foldl go (Map.empty, Map.empty) . Map.toList -- Given a list of exported constructor names, remove any data constructor -- names in the provided Map of declarations which are not in the list. -- -filterDataConstructors :: - [P.ProperName 'P.ConstructorName] -> - Map P.ModuleName [Declaration] -> - Map P.ModuleName [Declaration] +filterDataConstructors + :: [P.ProperName 'P.ConstructorName] + -> Map P.ModuleName [Declaration] + -> Map P.ModuleName [Declaration] filterDataConstructors = filterExportedChildren isDataConstructor P.runProperName @@ -433,27 +447,25 @@ filterDataConstructors = -- type class member names in the provided Map of declarations which are not in -- the list. -- -filterTypeClassMembers :: - [P.Ident] -> - Map P.ModuleName [Declaration] -> - Map P.ModuleName [Declaration] +filterTypeClassMembers + :: [P.Ident] + -> Map P.ModuleName [Declaration] + -> Map P.ModuleName [Declaration] filterTypeClassMembers = filterExportedChildren isTypeClassMember P.showIdent -filterExportedChildren :: - (Functor f) => - (ChildDeclaration -> Bool) -> - (name -> String) -> - [name] -> - f [Declaration] -> - f [Declaration] -filterExportedChildren isTargetedKind runName expNames = - fmap filterDecls +filterExportedChildren + :: (Functor f) + => (ChildDeclaration -> Bool) + -> (name -> String) + -> [name] + -> f [Declaration] + -> f [Declaration] +filterExportedChildren isTargetedKind runName expNames = fmap filterDecls where filterDecls = - map (filterChildren (\c -> not (isTargetedKind c) || - cdeclTitle c `elem` expNames')) - + map $ filterChildren $ \c -> + not (isTargetedKind c) || cdeclTitle c `elem` expNames' expNames' = map runName expNames allDeclarations :: Module -> [Declaration] @@ -466,10 +478,10 @@ x |> f = f x internalError :: String -> a internalError = P.internalError . ("Docs.Convert.ReExports: " ++) -internalErrorInModule :: - (MonadReader P.ModuleName m) => - String -> - m a +internalErrorInModule + :: (MonadReader P.ModuleName m) + => String + -> m a internalErrorInModule msg = do mn <- ask internalError diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index ac3328fd51..ef61b37fab 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Language.PureScript.Docs.Convert.Single ( convertSingleModule , collectBookmarks @@ -11,8 +9,8 @@ import Control.Category ((>>>)) import Control.Monad import Data.Either -import Data.List (nub, isPrefixOf, isSuffixOf) -import Data.Maybe (mapMaybe, isNothing) +import Data.List (nub) +import Data.Maybe (mapMaybe) import Language.PureScript.Docs.Types import qualified Language.PureScript as P @@ -30,7 +28,6 @@ convertSingleModule m@(P.Module _ coms moduleName _ _) = P.exportedDeclarations >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d) >>> augmentDeclarations - >>> map addDefaultFixity -- | The data type for an intermediate stage which we go through during -- converting. @@ -60,12 +57,8 @@ type IntermediateDeclaration -- since they appear at the top level in the AST, and since they might need to -- appear as children in two places (for example, if a data type defined in a -- module is an instance of a type class also defined in that module). --- --- The AugmentFixity constructor allows us to augment operator definitions --- with their associativity and precedence. data DeclarationAugment = AugmentChild ChildDeclaration - | AugmentFixity P.Fixity -- | Augment top-level declarations; the second pass. See the comments under -- the type synonym IntermediateDeclaration for more information. @@ -79,28 +72,8 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) = then augmentWith a d else d) ds - augmentWith a d = - case a of - AugmentChild child -> - d { declChildren = declChildren d ++ [child] } - AugmentFixity fixity -> - d { declFixity = Just fixity } - --- | Add the default operator fixity for operators which do not have associated --- fixity declarations. --- --- TODO: This may no longer be necessary after issue 806 is resolved, hopefully --- in 0.9. -addDefaultFixity :: Declaration -> Declaration -addDefaultFixity decl@Declaration{..} - | isOp declTitle && isNothing declFixity = - decl { declFixity = Just defaultFixity } - | otherwise = - decl - where - isOp :: String -> Bool - isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str - defaultFixity = P.Fixity P.Infixl (-1) + augmentWith (AugmentChild child) d = + d { declChildren = declChildren d ++ [child] } getDeclarationTitle :: P.Declaration -> Maybe String getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name) @@ -110,8 +83,8 @@ getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName nam getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name) -getDeclarationTitle (P.FixityDeclaration _ name (Just (P.Qualified _ P.AliasType{}))) = Just ("type (" ++ name ++ ")") -getDeclarationTitle (P.FixityDeclaration _ name _) = Just ("(" ++ name ++ ")") +getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " ++ P.showOp op) +getDeclarationTitle (P.ValueFixityDeclaration _ _ op) = Just (P.showOp op) getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d getDeclarationTitle _ = Nothing @@ -122,7 +95,6 @@ mkDeclaration title info = , declComments = Nothing , declSourceSpan = Nothing , declChildren = [] - , declFixity = Nothing , declInfo = info } @@ -132,7 +104,7 @@ basicDeclaration title info = Just $ Right $ mkDeclaration title info convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title = basicDeclaration title (ValueDeclaration ty) -convertDeclaration (P.ValueDeclaration {}) title = +convertDeclaration P.ValueDeclaration{} title = -- If no explicit type declaration was provided, insert a wildcard, so that -- the actual type will be added during type checking. basicDeclaration title (ValueDeclaration P.TypeWildcard{}) @@ -172,10 +144,10 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys -convertDeclaration (P.FixityDeclaration fixity _ Nothing) title = - Just (Left ([title], AugmentFixity fixity)) -convertDeclaration (P.FixityDeclaration fixity _ (Just alias)) title = - Just $ Right $ (mkDeclaration title (AliasDeclaration alias fixity)) { declFixity = Just fixity } +convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title = + Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias))) +convertDeclaration (P.TypeFixityDeclaration fixity (P.Qualified mn alias) _) title = + Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Left alias))) convertDeclaration (P.PositionedDeclaration srcSpan com d') title = fmap (addComments . addSourceSpan) (convertDeclaration d' title) where @@ -191,10 +163,7 @@ convertDeclaration (P.PositionedDeclaration srcSpan com d') title = Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan }) augment) - withAugmentChild f (t, a) = - case a of - AugmentChild d -> (t, AugmentChild (f d)) - _ -> (t, a) + withAugmentChild f (t, AugmentChild d) = (t, AugmentChild (f d)) convertDeclaration _ _ = Nothing convertComments :: [P.Comment] -> Maybe String diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index f65f8e7887..e13e03a8ac 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -59,27 +59,33 @@ renderDeclarationWithOptions opts Declaration{..} = syntax "(" <> mintersperse (syntax "," <> sp) (map renderConstraint implies) <> syntax ")" <> sp <> syntax "<=" - AliasDeclaration for@(P.Qualified _ alias) (P.Fixity associativity precedence) -> + + AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) -> [ keywordFixity associativity , syntax $ show precedence - , ident $ renderAlias for + , ident $ renderQualAlias for , keyword "as" , ident $ adjustAliasName alias declTitle ] where + renderType' :: P.Type -> RenderedCode renderType' = renderTypeWithOptions opts - renderAlias (P.Qualified mn alias) - | mn == currentModule opts = - P.foldFixityAlias P.runIdent P.runProperName (("type " ++) . P.runProperName) alias - | otherwise = - P.foldFixityAlias - (P.showQualified P.runIdent . P.Qualified mn) - (P.showQualified P.runProperName . P.Qualified mn) - (("type " ++) . P.showQualified P.runProperName . P.Qualified mn) - alias - - adjustAliasName (P.AliasType{}) title = drop 6 (init title) + + renderQualAlias :: FixityAlias -> String + renderQualAlias (P.Qualified mn alias) + | mn == currentModule opts = renderAlias id alias + | otherwise = renderAlias (\f -> P.showQualified f . P.Qualified mn) alias + + renderAlias + :: (forall a. (a -> String) -> a -> String) + -> Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName)) + -> String + renderAlias f + = either (("type " ++) . f P.runProperName) + $ either (f P.runIdent) (f P.runProperName) + + -- adjustAliasName (P.AliasType{}) title = drop 6 (init title) adjustAliasName _ title = tail (init title) renderChildDeclaration :: ChildDeclaration -> RenderedCode diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index 77009efbe8..332530b56c 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -49,7 +49,7 @@ typeLiterals = mkPattern match match (BinaryNoParensType op l r) = Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r match (TypeOp (Qualified mn op)) = - Just (ident' (runIdent op) (maybeToContainingModule mn)) + Just (ident' (runOpName op) (maybeToContainingModule mn)) match _ = Nothing diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index b736eb792d..c5e15b2298 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -14,6 +14,7 @@ import Control.Monad (when) import Data.Aeson ((.=)) import Data.Aeson.BetterErrors import Data.ByteString.Lazy (ByteString) +import Data.Either (isLeft, isRight) import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Version @@ -84,7 +85,6 @@ data Declaration = Declaration , declComments :: Maybe String , declSourceSpan :: Maybe P.SourceSpan , declChildren :: [ChildDeclaration] - , declFixity :: Maybe P.Fixity -- TODO: remove in 0.9 , declInfo :: DeclarationInfo } deriving (Show, Eq, Ord) @@ -131,9 +131,11 @@ data DeclarationInfo -- An operator alias declaration, with the member the alias is for and the -- operator's fixity. -- - | AliasDeclaration (P.Qualified P.FixityAlias) P.Fixity + | AliasDeclaration P.Fixity FixityAlias deriving (Show, Eq, Ord) +type FixityAlias = P.Qualified (Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))) + declInfoToString :: DeclarationInfo -> String declInfoToString (ValueDeclaration _) = "value" declInfoToString (DataDeclaration _ _) = "data" @@ -165,14 +167,13 @@ isType Declaration{..} = isValueAlias :: Declaration -> Bool isValueAlias Declaration{..} = case declInfo of - (AliasDeclaration (P.Qualified _ P.AliasConstructor{}) _) -> True - (AliasDeclaration (P.Qualified _ P.AliasValue{}) _) -> True + AliasDeclaration _ (P.Qualified _ d) -> isRight d _ -> False isTypeAlias :: Declaration -> Bool isTypeAlias Declaration{..} = case declInfo of - (AliasDeclaration (P.Qualified _ P.AliasType{}) _) -> True + AliasDeclaration _ (P.Qualified _ d) -> isLeft d _ -> False -- | Discard any children which do not satisfy the given predicate. @@ -362,7 +363,6 @@ asDeclaration = <*> key "comments" (perhaps asString) <*> key "sourceSpan" (perhaps asSourceSpan) <*> key "children" (eachInArray asChildDeclaration) - <*> key "fixity" (perhaps asFixity) <*> key "info" asDeclarationInfo asReExport :: Parse PackageError (P.ModuleName, [Declaration]) @@ -383,6 +383,9 @@ asFixity = P.Fixity <$> key "associativity" asAssociativity <*> key "precedence" asIntegral +asFixityAlias :: Parse PackageError FixityAlias +asFixityAlias = fromAesonParser + parseAssociativity :: String -> Maybe P.Associativity parseAssociativity str = case str of "infix" -> Just P.Infix @@ -411,14 +414,11 @@ asDeclarationInfo = do TypeClassDeclaration <$> key "arguments" asTypeArguments <*> key "superclasses" (eachInArray asConstraint) "alias" -> - AliasDeclaration <$> key "for" asAliasFor - <*> key "fixity" asFixity + AliasDeclaration <$> key "fixity" asFixity + <*> key "alias" asFixityAlias other -> throwCustomError (InvalidDeclarationType other) -asAliasFor :: Parse e (P.Qualified P.FixityAlias) -asAliasFor = fromAesonParser - asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)] asTypeArguments = eachInArray asTypeArgument where @@ -537,7 +537,6 @@ instance A.ToJSON Declaration where , "comments" .= declComments , "sourceSpan" .= declSourceSpan , "children" .= declChildren - , "fixity" .= declFixity , "info" .= declInfo ] @@ -558,7 +557,7 @@ instance A.ToJSON DeclarationInfo where ExternDataDeclaration kind -> ["kind" .= kind] TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty] TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super] - AliasDeclaration for fixity -> ["for" .= for, "fixity" .= fixity] + AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias] instance A.ToJSON ChildDeclarationInfo where toJSON info = A.object $ "declType" .= childDeclInfoToString info : props diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8133a91afc..8cdf6ab4f5 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -48,32 +48,19 @@ data SimpleErrorMessage | CannotWriteFile FilePath | InfiniteType Type | InfiniteKind Kind - | MultipleFixities Ident + | MultipleValueOpFixities (OpName 'ValueOpName) + | MultipleTypeOpFixities (OpName 'TypeOpName) | OrphanTypeDeclaration Ident - | OrphanFixityDeclaration String | RedefinedModule ModuleName [SourceSpan] | RedefinedIdent Ident | OverlappingNamesInLet - | UnknownModule ModuleName - | UnknownType (Qualified (ProperName 'TypeName)) - | UnknownTypeOp (Qualified Ident) - | UnknownTypeClass (Qualified (ProperName 'ClassName)) - | UnknownValue (Qualified Ident) - | UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName))) - | UnknownTypeConstructor (Qualified (ProperName 'TypeName)) - | UnknownImportType ModuleName (ProperName 'TypeName) - | UnknownExportType (ProperName 'TypeName) - | UnknownImportTypeOp ModuleName Ident - | UnknownExportTypeOp Ident - | UnknownImportTypeClass ModuleName (ProperName 'ClassName) - | UnknownExportTypeClass (ProperName 'ClassName) - | UnknownImportValue ModuleName Ident - | UnknownExportValue Ident - | UnknownExportModule ModuleName + | UnknownName (Qualified Name) + | UnknownImport ModuleName Name | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName) + | UnknownExport Name | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName) - | ScopeConflict String [ModuleName] - | ScopeShadowing String (Maybe ModuleName) [ModuleName] + | ScopeConflict Name [ModuleName] + | ScopeShadowing Name (Maybe ModuleName) [ModuleName] | ConflictingTypeDecls (ProperName 'TypeName) | ConflictingCtorDecls (ProperName 'ConstructorName) | TypeConflictsWithClass (ProperName 'TypeName) @@ -83,7 +70,8 @@ data SimpleErrorMessage | DuplicateModuleName ModuleName | DuplicateClassExport (ProperName 'ClassName) | DuplicateValueExport Ident - | DuplicateTypeOpExport Ident + | DuplicateValueOpExport (OpName 'ValueOpName) + | DuplicateTypeOpExport (OpName 'TypeOpName) | DuplicateTypeArgument String | InvalidDoBind | InvalidDoLet @@ -128,18 +116,16 @@ data SimpleErrorMessage | MissingTypeDeclaration Ident Type | OverlappingPattern [[Binder]] Bool | IncompleteExhaustivityCheck - | ClassOperator (ProperName 'ClassName) Ident | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName) | ImportHidingModule ModuleName | UnusedImport ModuleName | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef] | UnusedDctorImport (ProperName 'TypeName) | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName] - | DeprecatedOperatorDecl String | DuplicateSelectiveImport ModuleName | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) - | DuplicateImportRef String - | DuplicateExportRef String + | DuplicateImportRef Name + | DuplicateExportRef Name | IntOutOfRange Integer String Integer Integer | RedundantEmptyHidingImport ModuleName | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef] @@ -147,7 +133,7 @@ data SimpleErrorMessage | HidingImport ModuleName [DeclarationRef] | CaseBinderLengthDiffers Int [Binder] | IncorrectAnonymousArgument - | InvalidOperatorInBinder Ident Ident + | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident) | DeprecatedRequirePath | CannotGeneralizeRecursiveFunction Ident Type deriving (Show) @@ -232,29 +218,16 @@ errorCode em = case unwrapErrorMessage em of CannotWriteFile{} -> "CannotWriteFile" InfiniteType{} -> "InfiniteType" InfiniteKind{} -> "InfiniteKind" - MultipleFixities{} -> "MultipleFixities" + MultipleValueOpFixities{} -> "MultipleValueOpFixities" + MultipleTypeOpFixities{} -> "MultipleTypeOpFixities" OrphanTypeDeclaration{} -> "OrphanTypeDeclaration" - OrphanFixityDeclaration{} -> "OrphanFixityDeclaration" RedefinedModule{} -> "RedefinedModule" RedefinedIdent{} -> "RedefinedIdent" OverlappingNamesInLet -> "OverlappingNamesInLet" - UnknownModule{} -> "UnknownModule" - UnknownType{} -> "UnknownType" - UnknownTypeOp{} -> "UnknownTypeOp" - UnknownTypeClass{} -> "UnknownTypeClass" - UnknownValue{} -> "UnknownValue" - UnknownDataConstructor{} -> "UnknownDataConstructor" - UnknownTypeConstructor{} -> "UnknownTypeConstructor" - UnknownImportType{} -> "UnknownImportType" - UnknownImportTypeOp{} -> "UnknownImportTypeOp" - UnknownExportType{} -> "UnknownExportType" - UnknownExportTypeOp{} -> "UnknownExportTypeOp" - UnknownImportTypeClass{} -> "UnknownImportTypeClass" - UnknownExportTypeClass{} -> "UnknownExportTypeClass" - UnknownImportValue{} -> "UnknownImportValue" - UnknownExportValue{} -> "UnknownExportValue" - UnknownExportModule{} -> "UnknownExportModule" + UnknownName{} -> "UnknownName" + UnknownImport{} -> "UnknownImport" UnknownImportDataConstructor{} -> "UnknownImportDataConstructor" + UnknownExport{} -> "UnknownExport" UnknownExportDataConstructor{} -> "UnknownExportDataConstructor" ScopeConflict{} -> "ScopeConflict" ScopeShadowing{} -> "ScopeShadowing" @@ -267,6 +240,7 @@ errorCode em = case unwrapErrorMessage em of DuplicateModuleName{} -> "DuplicateModuleName" DuplicateClassExport{} -> "DuplicateClassExport" DuplicateValueExport{} -> "DuplicateValueExport" + DuplicateValueOpExport{} -> "DuplicateValueOpExport" DuplicateTypeOpExport{} -> "DuplicateTypeOpExport" DuplicateTypeArgument{} -> "DuplicateTypeArgument" InvalidDoBind -> "InvalidDoBind" @@ -312,14 +286,12 @@ errorCode em = case unwrapErrorMessage em of MissingTypeDeclaration{} -> "MissingTypeDeclaration" OverlappingPattern{} -> "OverlappingPattern" IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck" - ClassOperator{} -> "ClassOperator" MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport" ImportHidingModule{} -> "ImportHidingModule" UnusedImport{} -> "UnusedImport" UnusedExplicitImport{} -> "UnusedExplicitImport" UnusedDctorImport{} -> "UnusedDctorImport" UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport" - DeprecatedOperatorDecl{} -> "DeprecatedOperatorDecl" DuplicateSelectiveImport{} -> "DuplicateSelectiveImport" DuplicateImport{} -> "DuplicateImport" DuplicateImportRef{} -> "DuplicateImportRef" @@ -541,7 +513,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap paras $ [ line "Unable to parse foreign module:" , indent . line $ path ] ++ - (map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra))) + map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra)) renderSimpleErrorMessage (ErrorParsingModule err) = paras [ line "Unable to parse module: " , prettyPrintParseError err @@ -586,70 +558,36 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap paras [ line "An infinite kind was inferred for a type: " , indent $ line $ prettyPrintKind ki ] - renderSimpleErrorMessage (MultipleFixities name) = - line $ "There are multiple fixity/precedence declarations for " ++ showIdent name + renderSimpleErrorMessage (MultipleValueOpFixities op) = + line $ "There are multiple fixity/precedence declarations for operator " ++ showOp op + renderSimpleErrorMessage (MultipleTypeOpFixities op) = + line $ "There are multiple fixity/precedence declarations for type operator " ++ showOp op renderSimpleErrorMessage (OrphanTypeDeclaration nm) = line $ "The type declaration for " ++ showIdent nm ++ " should be followed by its definition." - renderSimpleErrorMessage (OrphanFixityDeclaration op) = - line $ "The fixity/precedence declaration for " ++ show op ++ " should appear in the same module as its definition." renderSimpleErrorMessage (RedefinedModule name filenames) = paras [ line ("The module " ++ runModuleName name ++ " has been defined multiple times:") , indent . paras $ map (line . displaySourceSpan) filenames ] renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " ++ showIdent name ++ " has been defined multiple times" - renderSimpleErrorMessage (UnknownModule mn) = - line $ "Unknown module " ++ runModuleName mn - renderSimpleErrorMessage (UnknownType name) = - line $ "Unknown type " ++ showQualified runProperName name - renderSimpleErrorMessage (UnknownTypeOp name) = - line $ "Unknown type operator " ++ showQualified showIdent name - renderSimpleErrorMessage (UnknownTypeClass name) = - line $ "Unknown type class " ++ showQualified runProperName name - renderSimpleErrorMessage (UnknownValue name) = - line $ "Unknown value " ++ showQualified showIdent name - renderSimpleErrorMessage (UnknownTypeConstructor name) = - line $ "Unknown type constructor " ++ showQualified runProperName name - renderSimpleErrorMessage (UnknownDataConstructor dc tc) = - line $ "Unknown data constructor " ++ showQualified runProperName dc ++ foldMap ((" for type constructor " ++) . showQualified runProperName) tc - renderSimpleErrorMessage (UnknownImportType mn name) = - paras [ line $ "Cannot import type " ++ runProperName name ++ " from module " ++ runModuleName mn + renderSimpleErrorMessage (UnknownName name) = + line $ "Unknown " ++ printName name + renderSimpleErrorMessage (UnknownImport mn name) = + paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ runModuleName mn , line "It either does not exist or the module does not export it." ] - renderSimpleErrorMessage (UnknownExportType name) = - line $ "Cannot export unknown type " ++ runProperName name - renderSimpleErrorMessage (UnknownImportTypeOp mn name) = - paras [ line $ "Cannot import type operator " ++ showIdent name ++ " from module " ++ runModuleName mn - , line "It either does not exist or the module does not export it." - ] - renderSimpleErrorMessage (UnknownExportTypeOp name) = - line $ "Cannot export unknown type operator " ++ showIdent name - renderSimpleErrorMessage (UnknownImportTypeClass mn name) = - paras [ line $ "Cannot import type class " ++ runProperName name ++ " from module " ++ runModuleName mn - , line "It either does not exist or the module does not export it." - ] - renderSimpleErrorMessage (UnknownExportTypeClass name) = - line $ "Cannot export unknown type class " ++ runProperName name - renderSimpleErrorMessage (UnknownImportValue mn name) = - paras [ line $ "Cannot import value " ++ showIdent name ++ " from module " ++ runModuleName mn - , line "It either does not exist or the module does not export it." - ] - renderSimpleErrorMessage (UnknownExportValue name) = - line $ "Cannot export unknown value " ++ showIdent name - renderSimpleErrorMessage (UnknownExportModule name) = - paras [ line $ "Cannot export unknown module " ++ runModuleName name - , line "It either does not exist or has not been imported by the current module." - ] - renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) = + renderSimpleErrorMessage (UnknownImportDataConstructor mn dcon tcon) = line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon + renderSimpleErrorMessage (UnknownExport name) = + line $ "Cannot export unknown " ++ printName (Qualified Nothing name) renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) = line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared." renderSimpleErrorMessage (ScopeConflict nm ms) = - paras [ line $ "Conflicting definitions are in scope for " ++ nm ++ " from the following modules:" + paras [ line $ "Conflicting definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following modules:" , indent $ paras $ map (line . runModuleName) ms ] renderSimpleErrorMessage (ScopeShadowing nm exmn ms) = - paras [ line $ "Shadowed definitions are in scope for " ++ nm ++ " from the following open imports:" + paras [ line $ "Shadowed definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following open imports:" , indent $ paras $ map (line . ("import " ++) . runModuleName) ms , line $ "These will be ignored and the " ++ case exmn of Just exmn' -> "declaration from " ++ runModuleName exmn' ++ " will be used." @@ -673,8 +611,10 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap line $ "Duplicate export declaration for type class " ++ runProperName nm renderSimpleErrorMessage (DuplicateValueExport nm) = line $ "Duplicate export declaration for value " ++ showIdent nm - renderSimpleErrorMessage (DuplicateTypeOpExport nm) = - line $ "Duplicate export declaration for type operator " ++ showIdent nm + renderSimpleErrorMessage (DuplicateValueOpExport op) = + line $ "Duplicate export declaration for operator " ++ showOp op + renderSimpleErrorMessage (DuplicateTypeOpExport op) = + line $ "Duplicate export declaration for type operator " ++ showOp op renderSimpleErrorMessage (CycleInDeclaration nm) = line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = @@ -867,11 +807,6 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap line $ "Type variable '" ++ tv ++ "' was shadowed." renderSimpleErrorMessage (UnusedTypeVar tv) = line $ "Type variable '" ++ tv ++ "' was declared but not used." - renderSimpleErrorMessage (ClassOperator className opName) = - paras [ line $ "Type class '" ++ runProperName className ++ "' declares operator " ++ showIdent opName ++ "." - , line "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:" - , indent . line $ showIdent opName ++ " = someMember" - ] renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) = line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors." renderSimpleErrorMessage (ImportHidingModule name) = @@ -917,24 +852,17 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:" , indent $ paras $ map (line .runProperName) names ] - renderSimpleErrorMessage (DeprecatedOperatorDecl name) = - paras [ line $ "The operator (" ++ name ++ ") was declared as a value rather than an alias for a named function." - , line "Operator aliases are declared by using a fixity declaration, for example:" - , indent $ line $ "infixl 9 someFunction as " ++ name - , line "Support for value-declared operators will be removed in PureScript 0.9." - ] - renderSimpleErrorMessage (DuplicateSelectiveImport name) = line $ "There is an existing import of " ++ runModuleName name ++ ", consider merging the import lists" renderSimpleErrorMessage (DuplicateImport name imp qual) = line $ "Duplicate import of " ++ prettyPrintImport name imp qual - renderSimpleErrorMessage (DuplicateImportRef ref) = - line $ "Import list contains multiple references to " ++ ref + renderSimpleErrorMessage (DuplicateImportRef name) = + line $ "Import list contains multiple references to " ++ printName (Qualified Nothing name) - renderSimpleErrorMessage (DuplicateExportRef ref) = - line $ "Export list contains multiple references to " ++ ref + renderSimpleErrorMessage (DuplicateExportRef name) = + line $ "Export list contains multiple references to " ++ printName (Qualified Nothing name) renderSimpleErrorMessage (IntOutOfRange value backend lo hi) = paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend." @@ -969,7 +897,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap line "An anonymous function argument appears in an invalid context." renderSimpleErrorMessage (InvalidOperatorInBinder op fn) = - paras [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "." + paras [ line $ "Operator " ++ showQualified showOp op ++ " cannot be used in a pattern as it is an alias for function " ++ showQualified showIdent fn ++ "." , line "Only aliases for data constructors may be used in patterns." ] @@ -1099,6 +1027,24 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , detail ] + printName :: Qualified Name -> String + printName (Qualified mn (IdentName name)) = + "value " ++ showQualified showIdent (Qualified mn name) + printName (Qualified mn (ValOpName op)) = + "operator " ++ showQualified showOp (Qualified mn op) + printName (Qualified mn (TyName name)) = + "type " ++ showQualified runProperName (Qualified mn name) + printName (Qualified mn (TyOpName op)) = + "type operator " ++ showQualified showOp (Qualified mn op) + printName (Qualified mn (DctorName name)) = + "data constructor " ++ showQualified runProperName (Qualified mn name) + printName (Qualified mn (TyClassName name)) = + "type class " ++ showQualified runProperName (Qualified mn name) + printName (Qualified Nothing (ModName name)) = + "module " ++ runModuleName name + printName (Qualified _ ModName{}) = + internalError "qualified ModName in printName" + valueDepth :: Int valueDepth | full = 1000 | otherwise = 3 @@ -1179,8 +1125,9 @@ prettyPrintRef :: DeclarationRef -> String prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)" prettyPrintRef (TypeRef pn (Just [])) = runProperName pn prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")" -prettyPrintRef (TypeOpRef ident) = "type " ++ showIdent ident +prettyPrintRef (TypeOpRef op) = "type " ++ showOp op prettyPrintRef (ValueRef ident) = showIdent ident +prettyPrintRef (ValueOpRef op) = showOp op prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn prettyPrintRef (TypeInstanceRef ident) = showIdent ident prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 21863db847..e6a850c1c8 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -8,6 +8,7 @@ module Language.PureScript.Externs ( ExternsFile(..) , ExternsImport(..) , ExternsFixity(..) + , ExternsTypeFixity(..) , ExternsDeclaration(..) , moduleToExternsFile , applyExternsFileToEnvironment @@ -45,6 +46,8 @@ data ExternsFile = ExternsFile , efImports :: [ExternsImport] -- | List of operators and their fixities , efFixities :: [ExternsFixity] + -- | List of type operators and their fixities + , efTypeFixities :: [ExternsTypeFixity] -- | List of type and value declaration , efDeclarations :: [ExternsDeclaration] } deriving (Show, Read) @@ -68,9 +71,22 @@ data ExternsFixity = ExternsFixity -- | The precedence level of the operator , efPrecedence :: Precedence -- | The operator symbol - , efOperator :: String + , efOperator :: OpName 'ValueOpName -- | The value the operator is an alias for - , efAlias :: Maybe (Qualified FixityAlias) + , efAlias :: Qualified (Either Ident (ProperName 'ConstructorName)) + } deriving (Show, Read) + +-- | A type fixity declaration in an externs file +data ExternsTypeFixity = ExternsTypeFixity + { + -- | The associativity of the operator + efTypeAssociativity :: Associativity + -- | The precedence level of the operator + , efTypePrecedence :: Precedence + -- | The operator symbol + , efTypeOperator :: OpName 'TypeOpName + -- | The value the operator is an alias for + , efTypeAlias :: Qualified (ProperName 'TypeName) } deriving (Show, Read) -- | A type or value declaration appearing in an externs file @@ -147,20 +163,24 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} efExports = exps efImports = mapMaybe importDecl ds efFixities = mapMaybe fixityDecl ds + efTypeFixities = mapMaybe typeFixityDecl ds efDeclarations = concatMap toExternsDeclaration efExports fixityDecl :: Declaration -> Maybe ExternsFixity - fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) = - fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps) - where - exportsOp :: DeclarationRef -> Bool - exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r - exportsOp (ValueRef ident') = ident' == Op op - exportsOp (TypeOpRef ident') = ident' == Op op - exportsOp _ = False + fixityDecl (ValueFixityDeclaration (Fixity assoc prec) name op) = + fmap (const (ExternsFixity assoc prec op name)) (find (findOp getValueOpRef op) exps) fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d fixityDecl _ = Nothing + typeFixityDecl :: Declaration -> Maybe ExternsTypeFixity + typeFixityDecl (TypeFixityDeclaration (Fixity assoc prec) name op) = + fmap (const (ExternsTypeFixity assoc prec op name)) (find (findOp getTypeOpRef op) exps) + typeFixityDecl (PositionedDeclaration _ _ d) = typeFixityDecl d + typeFixityDecl _ = Nothing + + findOp :: (DeclarationRef -> Maybe (OpName a)) -> OpName a -> DeclarationRef -> Bool + findOp get op = maybe False (== op) . get + importDecl :: Declaration -> Maybe ExternsImport importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn) importDecl (PositionedDeclaration _ _ d) = importDecl d @@ -201,5 +221,6 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFixity) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsTypeFixity) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 788d482958..710606a950 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -58,13 +58,13 @@ identToText :: P.Ident -> Text identToText = T.pack . P.runIdent convertExterns :: PE.ExternsFile -> Module -convertExterns ef = (moduleName, exportDecls ++ importDecls ++ decls) +convertExterns ef = (moduleName, exportDecls ++ importDecls ++ decls ++ operatorDecls ++ tyOperatorDecls) where moduleName = moduleNameToText (PE.efModuleName ef) importDecls = convertImport <$> PE.efImports ef exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (PE.efExports ef) - -- Ignoring operator fixities for now since we're not using them - -- operatorDecls = convertOperator <$> PE.efFixities ef + operatorDecls = convertOperator <$> PE.efFixities ef + tyOperatorDecls = convertTypeOperator <$> PE.efTypeFixities ef otherDecls = mapMaybe convertDecl (PE.efDeclarations ef) typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration otherDecls) @@ -102,6 +102,14 @@ convertDecl PE.EDValue{..} = Just $ convertDecl PE.EDClass{..} = Just $ TypeClassDeclaration edClassName convertDecl PE.EDInstance{} = Nothing +convertOperator :: PE.ExternsFixity -> ExternDecl +convertOperator PE.ExternsFixity{..} = + FixityDeclaration (Left efOperator) + +convertTypeOperator :: PE.ExternsTypeFixity -> ExternDecl +convertTypeOperator PE.ExternsTypeFixity{..} = + FixityDeclaration (Right efTypeOperator) + unwrapPositioned :: P.Declaration -> P.Declaration unwrapPositioned (P.PositionedDeclaration _ _ x) = x unwrapPositioned x = x diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index a364388776..2efb8e5d07 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -209,15 +209,18 @@ addExplicitImport' decl moduleName imports = then imports else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports where - refFromDeclaration (TypeClassDeclaration n) = P.TypeClassRef n + refFromDeclaration (TypeClassDeclaration n) = + P.TypeClassRef n refFromDeclaration (DataConstructor n tn _) = P.TypeRef tn (Just [P.ProperName (T.unpack n)]) - refFromDeclaration (TypeDeclaration n _) = P.TypeRef n (Just []) + refFromDeclaration (TypeDeclaration n _) = + P.TypeRef n (Just []) + refFromDeclaration (FixityDeclaration (Left op)) = + P.ValueOpRef op + refFromDeclaration (FixityDeclaration (Right op)) = + P.TypeOpRef op refFromDeclaration d = - let - ident = T.unpack (identifierFromExternDecl d) - in - P.ValueRef ((if all P.isSymbolChar ident then P.Op else P.Ident) ident) + P.ValueRef $ P.Ident $ T.unpack (identifierFromExternDecl d) -- | Adds a declaration to an import: -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 0c80a02a87..e5fc7d93b1 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -61,6 +61,7 @@ data ExternDecl P.Type -- The "type" -- | An exported module | TypeClassDeclaration (P.ProperName 'P.ClassName) + | FixityDeclaration (Either (P.OpName 'P.ValueOpName) (P.OpName 'P.TypeOpName)) | Export ModuleIdent -- The exported Modules name deriving (Show,Eq,Ord) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 88138566cb..454b64b65d 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -31,6 +31,9 @@ runProperNameT = T.pack . P.runProperName runIdentT :: P.Ident -> Text runIdentT = T.pack . P.runIdent +runOpNameT :: P.OpName a -> Text +runOpNameT = T.pack . P.runOpName + prettyTypeT :: P.Type -> Text prettyTypeT = T.unwords . fmap T.strip . T.lines . T.pack . P.prettyPrintType @@ -41,6 +44,8 @@ identifierFromExternDecl (TypeSynonymDeclaration name _) = runProperNameT name identifierFromExternDecl (DataConstructor name _ _) = name identifierFromExternDecl (TypeClassDeclaration name) = runProperNameT name identifierFromExternDecl (ModuleDecl name _) = name +identifierFromExternDecl (FixityDeclaration (Left op)) = runOpNameT op +identifierFromExternDecl (FixityDeclaration (Right op)) = runOpNameT op identifierFromExternDecl Dependency{} = "~Dependency~" identifierFromExternDecl Export{} = "~Export~" diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 80a4800a36..14c8a205df 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -40,7 +40,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl lintDeclaration :: Declaration -> m () lintDeclaration = tell . f where - (warningsInDecl, _, _, _, _) = everythingWithScope stepD stepE stepB (\_ _ -> mempty) stepDo + (warningsInDecl, _, _, _, _) = everythingWithScope (\_ _ -> mempty) stepE stepB (\_ _ -> mempty) stepDo f :: Declaration -> MultipleErrors f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec) @@ -48,16 +48,6 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty) f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec - stepD :: S.Set Ident -> Declaration -> MultipleErrors - stepD _ (ValueDeclaration (Op name) _ _ _) = errorMessage (DeprecatedOperatorDecl name) - stepD _ (TypeClassDeclaration _ _ _ decls) = foldMap go decls - where - go :: Declaration -> MultipleErrors - go (PositionedDeclaration _ _ d') = go d' - go (TypeDeclaration (Op name) _) = errorMessage (DeprecatedOperatorDecl name) - go _ = mempty - stepD _ _ = mempty - stepE :: S.Set Ident -> Expr -> MultipleErrors stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name) stepE s (Let ds' _) = foldMap go ds' diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index b265d40bb3..540dfac4bc 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -6,52 +6,32 @@ module Language.PureScript.Linter.Imports import Prelude.Compat -import Control.Monad (unless, when) -import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad (join, unless, when, foldM, (<=<)) import Control.Monad.Writer.Class -import Data.Foldable (forM_) -import Data.List ((\\), find, intersect, nub) -import Data.Maybe (mapMaybe) +import Data.Function (on) +import Data.Foldable (for_) +import Data.List (find, intersect, nub, groupBy, sortBy, (\\)) +import Data.Maybe (mapMaybe, fromMaybe) import Data.Monoid (Sum(..)) +import Data.Traversable (forM) import qualified Data.Map as M import Language.PureScript.AST.Declarations import Language.PureScript.AST.SourcePos import Language.PureScript.Crash import Language.PureScript.Errors -import Language.PureScript.Names as P +import Language.PureScript.Names +import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) import Language.PureScript.Sugar.Names.Env import Language.PureScript.Sugar.Names.Imports import qualified Language.PureScript.Constants as C --- | Imported name used in some type or expression. -data Name - = IdentName (Qualified Ident) - | TyName (Qualified (ProperName 'TypeName)) - | TyOpName (Qualified Ident) - | DctorName (Qualified (ProperName 'ConstructorName)) - | TyClassName (Qualified (ProperName 'ClassName)) - deriving (Eq, Show) - -getIdentName :: Maybe ModuleName -> Name -> Maybe Ident -getIdentName q (IdentName (Qualified q' name)) | q == q' = Just name -getIdentName _ _ = Nothing - -getTypeOpName :: Maybe ModuleName -> Name -> Maybe Ident -getTypeOpName q (TyOpName (Qualified q' name)) | q == q' = Just name -getTypeOpName _ _ = Nothing - -getTypeName :: Maybe ModuleName -> Name -> Maybe (ProperName 'TypeName) -getTypeName q (TyName (Qualified q' name)) | q == q' = Just name -getTypeName _ _ = Nothing - -getClassName :: Maybe ModuleName -> Name -> Maybe (ProperName 'ClassName) -getClassName q (TyClassName (Qualified q' name)) | q == q' = Just name -getClassName _ _ = Nothing - --- | Map of module name to list of imported names from that module which have been used. -type UsedImports = M.Map ModuleName [Name] +-- | +-- Map of module name to list of imported names from that module which have +-- been used. +-- +type UsedImports = M.Map ModuleName [Qualified Name] -- | -- Find and warn on: @@ -69,46 +49,80 @@ type UsedImports = M.Map ModuleName [Name] -- lintImports :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . MonadWriter MultipleErrors m => Module -> Env -> UsedImports -> m () -lintImports (Module _ _ mn mdecls mexports) env usedImps = do +lintImports (Module _ _ _ _ Nothing) _ _ = return () +lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do + + -- TODO: this needs some work to be easier to understand - let scope = maybe nullImports (\(_, imps, _) -> imps) (M.lookup mn env) + let scope = maybe nullImports (\(_, imps', _) -> imps') (M.lookup mn env) usedImps' = foldr (elaborateUsed scope) usedImps exportedModules numOpenImports = getSum $ foldMap (Sum . countOpenImports) mdecls allowImplicit = numOpenImports == 1 + imports = M.toAscList (findImports mdecls) - imps <- M.toAscList <$> findImports mdecls - - forM_ imps $ \(mni, decls) -> - unless (isPrim mni) $ do - forM_ decls $ \(ss, declType, qualifierName) -> - censor (onErrorMessages $ addModuleLocError ss) $ do + for_ imports $ \(mni, decls) -> + unless (isPrim mni) $ + for_ decls $ \(ss', declType, qualifierName) -> + maybe id warnWithPosition ss' $ do let names = nub $ M.findWithDefault [] mni usedImps' lintImportDecl env mni qualifierName names declType allowImplicit - forM_ (M.toAscList (byQual imps)) $ \(mnq, entries) -> do + for_ (M.toAscList (byQual imports)) $ \(mnq, entries) -> do let mnis = nub $ map (\(_, _, mni) -> mni) entries unless (length mnis == 1) $ do let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries - forM_ implicits $ \(ss, _, mni) -> - censor (onErrorMessages $ addModuleLocError ss) $ do + for_ implicits $ \(ss', _, mni) -> + maybe id warnWithPosition ss' $ do let names = nub $ M.findWithDefault [] mni usedImps' usedRefs = findUsedRefs env mni (Just mnq) names unless (null usedRefs) $ tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs - return () + for_ imports $ \(mnq, imps) -> do + + warned <- foldM (checkDuplicateImports mnq) [] (selfCartesianSubset imps) + + let unwarned = imps \\ warned + duplicates + = join + . map tail + . filter ((> 1) . length) + . groupBy ((==) `on` defQual) + . sortBy (compare `on` defQual) + $ unwarned + + for_ duplicates $ \(pos, _, _) -> + maybe id warnWithPosition pos $ + tell $ errorMessage $ DuplicateSelectiveImport mnq + + for_ (imps \\ (warned ++ duplicates)) $ \(pos, typ, _) -> do + warnDuplicateRefs (fromMaybe ss pos) DuplicateImportRef $ case typ of + Explicit refs -> refs + Hiding refs -> refs + _ -> [] + for_ (M.lookup mn env) $ \(_, imported, _) -> + checkEmptyImport mnq imported typ where + defQual :: ImportDef -> Maybe ModuleName + defQual (_, _, q) = q + + selfCartesianSubset :: [a] -> [(a, a)] + selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs + selfCartesianSubset [] = [] + countOpenImports :: Declaration -> Int - countOpenImports (ImportDeclaration mn' Implicit Nothing) | not (isPrim mn') = 1 - countOpenImports (ImportDeclaration mn' (Hiding _) Nothing) | not (isPrim mn') = 1 countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d + countOpenImports (ImportDeclaration mn' Implicit Nothing) + | not (isPrim mn') = 1 + countOpenImports (ImportDeclaration mn' (Hiding _) Nothing) + | not (isPrim mn') = 1 countOpenImports _ = 0 -- Checks whether a module is the Prim module - used to suppress any checks @@ -125,15 +139,15 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do byQual = foldr goImp M.empty where goImp (mni, xs) acc = foldr (goDecl mni) acc xs - goDecl mni (ss, declType, Just qmn) acc = - let entry = (ss, declType, mni) + goDecl mni (ss', declType, Just qmn) acc = + let entry = (ss', declType, mni) in M.alter (Just . maybe [entry] (entry :)) qmn acc goDecl _ _ acc = acc -- The list of modules that are being re-exported by the current module. Any -- module that appears in this list is always considered to be used. exportedModules :: [ModuleName] - exportedModules = nub $ maybe [] (mapMaybe extractModule) mexports + exportedModules = nub $ mapMaybe extractModule mexports where extractModule (PositionedDeclarationRef _ _ r) = extractModule r extractModule (ModuleRef mne) = Just mne @@ -150,46 +164,44 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do values = extractByQual mne (importedValues scope) IdentName in foldr go used (classes ++ types ++ dctors ++ values) where - go :: (ModuleName, Name) -> UsedImports -> UsedImports + go :: (ModuleName, Qualified Name) -> UsedImports -> UsedImports go (q, name) = M.alter (Just . maybe [name] (name :)) q extractByQual :: (Eq a) => ModuleName -> M.Map (Qualified a) [ImportRecord a] - -> (Qualified a -> Name) - -> [(ModuleName, Name)] + -> (a -> Name) + -> [(ModuleName, Qualified Name)] extractByQual k m toName = mapMaybe go (M.toList m) where go (q@(Qualified mnq _), is) | isUnqualified q = case find (isQualifiedWith k) (map importName is) of - Just (Qualified _ name) -> Just (k, toName $ Qualified mnq name) + Just (Qualified _ name) -> Just (k, Qualified mnq (toName name)) _ -> Nothing | isQualifiedWith k q = - case importName (head is) of - Qualified (Just mn') name -> Just (mn', toName $ Qualified mnq name) - _ -> internalError "unqualified name in extractByQual" + case importName (head is) of + Qualified (Just mn') name -> Just (mn', Qualified mnq (toName name)) + _ -> internalError "unqualified name in extractByQual" go _ = Nothing lintImportDecl :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . MonadWriter MultipleErrors m => Env -> ModuleName -> Maybe ModuleName - -> [Name] + -> [Qualified Name] -> ImportDeclarationType -> Bool - -> m () + -> m Bool lintImportDecl env mni qualifierName names declType allowImplicit = case declType of Implicit -> case qualifierName of - Nothing -> unless allowImplicit (checkImplicit ImplicitImport) - Just q -> - let usedModuleNames = mapMaybe extractQualName names - in unless (q `elem` usedModuleNames) unused - Hiding _ -> unless allowImplicit (checkImplicit HidingImport) + Nothing -> unless' allowImplicit (checkImplicit ImplicitImport) + Just q -> unless' (q `elem` mapMaybe getQual names) unused + Hiding _ -> unless' allowImplicit (checkImplicit HidingImport) Explicit [] -> unused Explicit declrefs -> checkExplicit declrefs @@ -197,39 +209,48 @@ lintImportDecl env mni qualifierName names declType allowImplicit = checkImplicit :: (ModuleName -> [DeclarationRef] -> SimpleErrorMessage) - -> m () + -> m Bool checkImplicit warning = if null allRefs then unused - else tell $ errorMessage $ warning mni allRefs + else warn (warning mni allRefs) checkExplicit :: [DeclarationRef] - -> m () + -> m Bool checkExplicit declrefs = do let idents = nub (mapMaybe runDeclRef declrefs) - dctors = mapMaybe (matchDctor qualifierName) names - usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names + dctors = mapMaybe (getDctorName <=< disqualifyFor qualifierName) names + usedNames = mapMaybe (matchName (typeForDCtor mni) <=< disqualifyFor qualifierName) names diff = idents \\ usedNames - case (length diff, length idents) of - (0, _) -> return () + + didWarn <- case (length diff, length idents) of + (0, _) -> return False (n, m) | n == m -> unused - _ -> tell $ errorMessage $ UnusedExplicitImport mni diff qualifierName allRefs + _ -> warn (UnusedExplicitImport mni diff qualifierName allRefs) - -- If we've not already warned a type is unused, check its data constructors - forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do + didWarn' <- forM (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do let allCtors = dctorsForType mni tn - when (runProperName tn `elem` usedNames) $ case (c, dctors `intersect` allCtors) of - (_, []) | c /= Just [] -> - tell $ errorMessage $ UnusedDctorImport tn - (Just ctors, dctors') -> - let ddiff = ctors \\ dctors' - in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff - _ -> return () - return () - - unused :: m () - unused = tell $ errorMessage $ UnusedImport mni + -- If we've not already warned a type is unused, check its data constructors + unless' (runProperName tn `notElem` usedNames) $ + case (c, dctors `intersect` allCtors) of + (_, []) | c /= Just [] -> warn (UnusedDctorImport tn) + (Just ctors, dctors') -> + let ddiff = ctors \\ dctors' + in unless' (null ddiff) $ warn $ UnusedDctorExplicitImport tn ddiff + _ -> return False + + return (didWarn || or didWarn') + + unused :: m Bool + unused = warn (UnusedImport mni) + + warn :: SimpleErrorMessage -> m Bool + warn err = tell (errorMessage err) >> return True + + unless' :: Bool -> m Bool -> m Bool + unless' True m = m + unless' False _ = return False allRefs :: [DeclarationRef] allRefs = findUsedRefs env mni qualifierName names @@ -244,29 +265,27 @@ lintImportDecl env mni qualifierName names declType allowImplicit = -> ProperName 'TypeName -> [ProperName 'ConstructorName] dctorsForType mn tn = - maybe [] getDctors (find matches $ dtys mn) - where - matches ((ty, _),_) = ty == tn - getDctors ((_,ctors),_) = ctors + maybe [] (snd . fst) $ find ((== tn) . fst . fst) (dtys mn) typeForDCtor :: ModuleName -> ProperName 'ConstructorName -> Maybe (ProperName 'TypeName) - typeForDCtor mn pn = - getTy <$> find matches (dtys mn) - where - matches ((_, ctors), _) = pn `elem` ctors - getTy ((ty, _), _) = ty + typeForDCtor mn pn = fst . fst <$> find (elem pn . snd . fst) (dtys mn) -findUsedRefs :: Env -> ModuleName -> Maybe ModuleName -> [Name] -> [DeclarationRef] -findUsedRefs env mni qualifierName names = +findUsedRefs + :: Env + -> ModuleName + -> Maybe ModuleName + -> [Qualified Name] + -> [DeclarationRef] +findUsedRefs env mni qn names = let - classRefs = TypeClassRef <$> mapMaybe (getClassName qualifierName) names - valueRefs = ValueRef <$> mapMaybe (getIdentName qualifierName) names - typeOpRefs = TypeOpRef <$> mapMaybe (getTypeOpName qualifierName) names - types = mapMaybe (getTypeName qualifierName) names - dctors = mapMaybe (matchDctor qualifierName) names + classRefs = TypeClassRef <$> mapMaybe (getClassName <=< disqualifyFor qn) names + valueRefs = ValueRef <$> mapMaybe (getIdentName <=< disqualifyFor qn) names + typeOpRefs = TypeOpRef <$> mapMaybe (getTypeOpName <=< disqualifyFor qn) names + types = mapMaybe (getTypeName <=< disqualifyFor qn) names + dctors = mapMaybe (getDctorName <=< disqualifyFor qn) names typesWithDctors = reconstructTypeRefs dctors typesWithoutDctors = filter (`M.notMember` typesWithDctors) types typesRefs @@ -281,7 +300,8 @@ findUsedRefs env mni qualifierName names = -> M.Map (ProperName 'TypeName) [ProperName 'ConstructorName] reconstructTypeRefs = foldr accumDctors M.empty where - accumDctors dctor = M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor) + accumDctors dctor = + M.alter (Just . maybe [dctor] (dctor :)) (findTypeForDctor mni dctor) findTypeForDctor :: ModuleName @@ -297,25 +317,13 @@ findUsedRefs env mni qualifierName names = matchName :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName)) - -> Maybe ModuleName -> Name -> Maybe String -matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x -matchName _ qual (TyName (Qualified q x)) | q == qual = Just $ runProperName x -matchName _ qual (TyClassName (Qualified q x)) | q == qual = Just $ runProperName x -matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x -matchName _ _ _ = Nothing - -extractQualName :: Name -> Maybe ModuleName -extractQualName (IdentName (Qualified q _)) = q -extractQualName (TyName (Qualified q _)) = q -extractQualName (TyOpName (Qualified q _)) = q -extractQualName (TyClassName (Qualified q _)) = q -extractQualName (DctorName (Qualified q _)) = q - -matchDctor :: Maybe ModuleName -> Name -> Maybe (ProperName 'ConstructorName) -matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x -matchDctor _ _ = Nothing +matchName _ (IdentName x) = Just $ showIdent x +matchName _ (TyName x) = Just $ runProperName x +matchName _ (TyClassName x) = Just $ runProperName x +matchName lookupDc (DctorName x) = runProperName <$> lookupDc x +matchName _ _ = Nothing runDeclRef :: DeclarationRef -> Maybe String runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref @@ -324,15 +332,38 @@ runDeclRef (TypeRef pn _) = Just $ runProperName pn runDeclRef (TypeClassRef pn) = Just $ runProperName pn runDeclRef _ = Nothing -getTypeRef - :: DeclarationRef - -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) -getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref -getTypeRef (TypeRef pn x) = Just (pn, x) -getTypeRef _ = Nothing - -addModuleLocError :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage -addModuleLocError sp err = - case sp of - Just pos -> withPosition pos err - _ -> err +checkDuplicateImports + :: MonadWriter MultipleErrors m + => ModuleName + -> [ImportDef] + -> (ImportDef, ImportDef) + -> m [ImportDef] +checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) = + if t1 == t2 && q1 == q2 + then do + maybe id warnWithPosition pos $ + tell $ errorMessage $ DuplicateImport mn t2 q2 + return $ (pos, t2, q2) : xs + else return xs + +-- | +-- Checks that an import with a hiding reference is not hiding all possible +-- imports. +-- +checkEmptyImport + :: MonadWriter MultipleErrors m + => ModuleName + -> Imports + -> ImportDeclarationType + -> m () +checkEmptyImport importModule imps (Hiding _) = do + let isEmptyImport + = M.null (importedTypes imps) + && M.null (importedTypeOps imps) + && M.null (importedDataConstructors imps) + && M.null (importedTypeClasses imps) + && M.null (importedValues imps) + && M.null (importedValueOps imps) + when isEmptyImport . tell . errorMessage $ + RedundantEmptyHidingImport importModule +checkEmptyImport _ _ _ = return () diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 4d47a208f6..25e7b35870 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -19,7 +19,6 @@ module Language.PureScript.Make import Prelude.Compat -import Control.Applicative ((<|>)) import Control.Concurrent.Lifted as C import Control.Monad hiding (sequence) import Control.Monad.Base (MonadBase(..)) @@ -361,7 +360,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = genSourceMap dir mapFile extraLines mappings = do let pathToDir = iterate (".." ) ".." !! length (splitPath $ normalise outputDir) sourceFile = case mappings of - ((SMap file _ _):_) -> Just $ pathToDir makeRelative dir file + (SMap file _ _ : _) -> Just $ pathToDir makeRelative dir file _ -> Nothing let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings = map (\(SMap _ orig gen) -> Mapping { @@ -450,11 +449,10 @@ checkForeignDecls m path = do (errs, _) -> Left errs - -- TODO: Handling for parenthesised operators should be removed after 0.9. -- We ignore the error message here, just being told it's an invalid -- identifier should be enough. parseIdent :: String -> Either String Ident - parseIdent str = try str <|> try ("(" ++ str ++ ")") + parseIdent str = try str where try s = either (const (Left str)) Right $ do ts <- PSParser.lex "" s diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 1c14c51254..a8e07f93a7 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -69,8 +69,8 @@ usedModules ams d = -- Regardless of whether an imported module is qualified we still need to -- take into account its import to build an accurate list of dependencies. [mn] - forDecls (FixityDeclaration _ _ (Just (Qualified (Just mn) _))) - | mn `notElem` ams = [mn] + forDecls (FixityDeclaration fd) + | Just mn <- extractQualFixity fd, mn `notElem` ams = [mn] forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) | mn `notElem` ams = [mn] forDecls _ = [] @@ -87,6 +87,10 @@ usedModules ams d = | mn `notElem` ams = [mn] forTypes _ = [] + extractQualFixity :: Either ValueFixity TypeFixity -> Maybe ModuleName + extractQualFixity (Left (ValueFixity _ (Qualified mn _) _)) = mn + extractQualFixity (Right (TypeFixity _ (Qualified mn _) _)) = mn + -- | -- Convert a strongly connected component of the module graph to a module -- diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 1326a8c8fe..0f99ca980b 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -7,13 +7,51 @@ module Language.PureScript.Names where import Prelude.Compat -import Control.Monad (liftM) import Control.Monad.Supply.Class import Data.Aeson import Data.Aeson.TH import Data.List +-- | A sum of the possible name types, useful for error and lint messages. +data Name + = IdentName Ident + | ValOpName (OpName 'ValueOpName) + | TyName (ProperName 'TypeName) + | TyOpName (OpName 'TypeOpName) + | DctorName (ProperName 'ConstructorName) + | TyClassName (ProperName 'ClassName) + | ModName ModuleName + deriving (Eq, Show) + +getIdentName :: Name -> Maybe Ident +getIdentName (IdentName name) = Just name +getIdentName _ = Nothing + +getValOpName :: Name -> Maybe (OpName 'ValueOpName) +getValOpName (ValOpName name) = Just name +getValOpName _ = Nothing + +getTypeName :: Name -> Maybe (ProperName 'TypeName) +getTypeName (TyName name) = Just name +getTypeName _ = Nothing + +getTypeOpName :: Name -> Maybe (OpName 'TypeOpName) +getTypeOpName (TyOpName name) = Just name +getTypeOpName _ = Nothing + +getDctorName :: Name -> Maybe (ProperName 'ConstructorName) +getDctorName (DctorName name) = Just name +getDctorName _ = Nothing + +getClassName :: Name -> Maybe (ProperName 'ClassName) +getClassName (TyClassName name) = Just name +getClassName _ = Nothing + +getModName :: Name -> Maybe ModuleName +getModName (ModName name) = Just name +getModName _ = Nothing + -- | -- Names for value identifiers -- @@ -23,10 +61,6 @@ data Ident -- = Ident String -- | - -- A symbolic name for an infix operator - -- - | Op String - -- | -- A generated name for an identifier -- | GenIdent (Maybe String) Integer @@ -34,19 +68,37 @@ data Ident runIdent :: Ident -> String runIdent (Ident i) = i -runIdent (Op op) = op runIdent (GenIdent Nothing n) = "$" ++ show n runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n showIdent :: Ident -> String -showIdent (Op op) = '(' : op ++ ")" -showIdent i = runIdent i +showIdent = runIdent -freshIdent :: (MonadSupply m) => String -> m Ident -freshIdent name = liftM (GenIdent (Just name)) fresh +freshIdent :: MonadSupply m => String -> m Ident +freshIdent name = GenIdent (Just name) <$> fresh -freshIdent' :: (MonadSupply m) => m Ident -freshIdent' = liftM (GenIdent Nothing) fresh +freshIdent' :: MonadSupply m => m Ident +freshIdent' = GenIdent Nothing <$> fresh + +-- | +-- Operator alias names. +-- +newtype OpName (a :: OpNameType) = OpName { runOpName :: String } + deriving (Show, Read, Eq, Ord) + +instance ToJSON (OpName a) where + toJSON = toJSON . runOpName + +instance FromJSON (OpName a) where + parseJSON = fmap OpName . parseJSON + +showOp :: OpName a -> String +showOp op = '(' : runOpName op ++ ")" + +-- | +-- The closed set of operator alias types. +-- +data OpNameType = ValueOpName | TypeOpName -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. @@ -100,6 +152,9 @@ showQualified :: (a -> String) -> Qualified a -> String showQualified f (Qualified Nothing a) = f a showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a +getQual :: Qualified a -> Maybe ModuleName +getQual (Qualified mn _) = mn + -- | -- Provide a default module name, if a name is unqualified -- @@ -117,6 +172,14 @@ mkQualified name mn = Qualified (Just mn) name disqualify :: Qualified a -> a disqualify (Qualified _ a) = a +-- | +-- Remove the qualification from a value when it is qualified with a particular +-- module name. +-- +disqualifyFor :: Maybe ModuleName -> Qualified a -> Maybe a +disqualifyFor mn (Qualified mn' a) | mn == mn' = Just a +disqualifyFor _ _ = Nothing + -- | -- Checks whether a qualified value is actually qualified with a module reference -- diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index 9005252477..039f710ef8 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -43,10 +43,16 @@ parseQualified parser = part [] qual path = if null path then Nothing else Just $ ModuleName path -- | --- Parse an identifier or parenthesized operator +-- Parse an identifier. -- parseIdent :: TokenParser Ident -parseIdent = (Ident <$> identifier) <|> (Op <$> parens symbol) +parseIdent = Ident <$> identifier + +-- | +-- Parse an operator. +-- +parseOperator :: TokenParser (OpName a) +parseOperator = OpName <$> symbol -- | -- Run the first parser, then match the second if possible, applying the specified function on a successful match diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 847fb9b058..16b467bcb0 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -42,7 +42,10 @@ import qualified Text.Parsec.Expr as P -- | -- Read source position information -- -withSourceSpan :: (SourceSpan -> [Comment] -> a -> a) -> P.Parsec [PositionedToken] u a -> P.Parsec [PositionedToken] u a +withSourceSpan + :: (SourceSpan -> [Comment] -> a -> a) + -> P.Parsec [PositionedToken] u a + -> P.Parsec [PositionedToken] u a withSourceSpan f p = do start <- P.getPosition comments <- C.readComments @@ -123,13 +126,17 @@ parseFixityDeclaration :: TokenParser Declaration parseFixityDeclaration = do fixity <- parseFixity indented - alias <- P.optionMaybe $ parseQualified aliased <* reserved "as" - name <- symbol - return $ FixityDeclaration fixity name alias + FixityDeclaration + <$> ((Right <$> typeFixity fixity) <|> (Left <$> valueFixity fixity)) where - aliased = (AliasValue . Ident <$> identifier) - <|> (AliasConstructor <$> properName) - <|> reserved "type" *> (AliasType <$> properName) + typeFixity fixity = + TypeFixity fixity + <$> (reserved "type" *> parseQualified properName) + <*> (reserved "as" *> parseOperator) + valueFixity fixity = + ValueFixity fixity + <$> parseQualified ((Left <$> parseIdent) <|> (Right <$> properName)) + <*> (reserved "as" *> parseOperator) parseImportDeclaration :: TokenParser Declaration parseImportDeclaration = do @@ -154,10 +161,11 @@ parseDeclarationRef :: TokenParser DeclarationRef parseDeclarationRef = withSourceSpan PositionedDeclarationRef $ (ValueRef <$> parseIdent) + <|> (ValueOpRef <$> parens parseOperator) <|> parseTypeRef <|> (TypeClassRef <$> (reserved "class" *> properName)) <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName)) - <|> (TypeOpRef <$> (indented *> reserved "type" *> parens (Op <$> symbol))) + <|> (TypeOpRef <$> (indented *> reserved "type" *> parens parseOperator)) where parseTypeRef = do name <- properName @@ -323,8 +331,7 @@ parseIdentifierAndValue = parseAbs :: TokenParser Expr parseAbs = do symbol' "\\" - -- TODO: remove this 'try' after operator aliases are finished (0.9) - args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens))) + args <- P.many1 (C.indented *> (Abs <$> (Left <$> C.parseIdent <|> Right <$> parseBinderNoParens))) C.indented *> rarrow value <- parseValue return $ toFunction args value @@ -343,7 +350,7 @@ parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") ( <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative))) parseCaseAlternative :: TokenParser CaseAlternative -parseCaseAlternative = CaseAlternative <$> (commaSep1 parseBinder) +parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder <*> (Left <$> (C.indented *> P.many1 ((,) <$> parseGuard <*> (indented *> rarrow *> parseValue) @@ -383,6 +390,7 @@ parseValueAtom = P.choice , parseDo , parseLet , P.try $ Parens <$> parens parseValue + , Op <$> parseQualified (parens parseOperator) , parseHole ] @@ -390,8 +398,9 @@ parseValueAtom = P.choice -- Parse an expression in backticks or an operator -- parseInfixExpr :: TokenParser Expr -parseInfixExpr = P.between tick tick parseValue - <|> Var <$> parseQualified (Op <$> symbol) +parseInfixExpr + = P.between tick tick parseValue + <|> Op <$> parseQualified parseOperator parseHole :: TokenParser Expr parseHole = Hole <$> holeLit @@ -481,9 +490,7 @@ parseArrayBinder = LiteralBinder <$> parseArrayLiteral (C.indented *> parseBinde parseVarOrNamedBinder :: TokenParser Binder parseVarOrNamedBinder = do - -- TODO: once operator aliases are finalized in 0.9, this 'try' won't be needed - -- any more since identifiers in binders won't be 'Op's. - name <- P.try C.parseIdent + name <- C.parseIdent let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinderAtom) parseNamedBinder <|> return (VarBinder name) @@ -522,7 +529,7 @@ parseBinder = ] parseOpBinder :: TokenParser Binder - parseOpBinder = OpBinder <$> parseQualified (Op <$> symbol) + parseOpBinder = OpBinder <$> parseQualified parseOperator parseBinderAtom :: TokenParser Binder parseBinderAtom = P.choice diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 0283db6b96..ff66a6d663 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -12,7 +12,6 @@ import Control.Monad (when, unless) import Language.PureScript.AST.SourcePos import Language.PureScript.Environment -import Language.PureScript.Names import Language.PureScript.Parser.Common import Language.PureScript.Parser.Kinds import Language.PureScript.Parser.Lexer @@ -83,7 +82,7 @@ parseAnyType :: TokenParser Type parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P. "type" where operators = [ [ P.Infix (return TypeApp) P.AssocLeft ] - , [ P.Infix (P.try (parseQualified (Op <$> symbol)) >>= \ident -> + , [ P.Infix (P.try (parseQualified parseOperator) >>= \ident -> return (BinaryNoParensType (TypeOp ident))) P.AssocRight ] , [ P.Infix (rarrow >> return function) P.AssocRight ] diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 62263d771b..5f878dd2d0 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -40,7 +40,7 @@ typeLiterals = mkPattern match match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row match (BinaryNoParensType op l r) = Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r - match (TypeOp op) = Just $ text $ showQualified runIdent op + match (TypeOp op) = Just $ text $ showQualified runOpName op match _ = Nothing constraintsAsBox :: [Constraint] -> Box -> Box diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 241a7a09f2..93365cffc6 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -71,6 +71,7 @@ prettyPrintValue _ (Hole name) = text "?" <> text name prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr +prettyPrintValue d expr@Op{} = prettyPrintValueAtom d expr prettyPrintValue d expr@BinaryNoParens{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Parens{} = prettyPrintValueAtom d expr prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr @@ -85,7 +86,7 @@ prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident) prettyPrintValueAtom d (BinaryNoParens op lhs rhs) = prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs where - printOp (Var (Qualified _ (Op opName))) = text opName + printOp (Op (Qualified _ name)) = text (runOpName name) printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`" prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val @@ -154,7 +155,7 @@ prettyPrintBinderAtom b@ConstructorBinder{} = parens (prettyPrintBinder b) prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder -prettyPrintBinderAtom (OpBinder op) = showIdent (disqualify op) +prettyPrintBinderAtom (OpBinder op) = runOpName (disqualify op) prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) = prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2 prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b) diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 694f0372c7..9e343c7413 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -3,14 +3,15 @@ -- module Language.PureScript.Sugar (desugar, module S) where -import Prelude.Compat - import Control.Category ((>>>)) import Control.Monad import Control.Monad.Error.Class (MonadError()) import Control.Monad.Supply.Class import Control.Monad.Writer.Class (MonadWriter()) +import Data.List (map) +import Data.Traversable (traverse) + import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Externs @@ -47,15 +48,20 @@ import Language.PureScript.Sugar.TypeDeclarations as S -- -- * Group mutually recursive value and data declarations into binding groups. -- -desugar :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] +desugar + :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => [ExternsFile] + -> [Module] + -> m [Module] desugar externs = - map removeSignedLiterals + map desugarSignedLiterals >>> traverse desugarObjectConstructors >=> traverse desugarDoModule - >=> desugarCasesModule - >=> desugarTypeDeclarationsModule + >=> traverse desugarCasesModule + >=> traverse desugarTypeDeclarationsModule >=> desugarImports externs >=> rebracket externs + >=> traverse checkFixityExports >=> traverse deriveInstances >=> desugarTypeClasses externs - >=> createBindingGroupsModule + >=> traverse createBindingGroupsModule diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index ce255e7f10..a7cd113a67 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -31,11 +31,10 @@ import Language.PureScript.Types -- createBindingGroupsModule :: (MonadError MultipleErrors m) - => [Module] - -> m [Module] -createBindingGroupsModule = - mapM $ \(Module ss coms name ds exps) -> - Module ss coms name <$> createBindingGroups name ds <*> pure exps + => Module + -> m Module +createBindingGroupsModule (Module ss coms name ds exps) = + Module ss coms name <$> createBindingGroups name ds <*> pure exps -- | -- Collapse all binding groups in a module to individual declarations @@ -67,11 +66,11 @@ createBindingGroups moduleName = mapM f <=< handleDecls handleDecls ds = do let values = filter isValueDecl ds dataDecls = filter isDataDecl ds - allProperNames = map getTypeName dataDecls - dataVerts = map (\d -> (d, getTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls + allProperNames = map declTypeName dataDecls + dataVerts = map (\d -> (d, declTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup - let allIdents = map getIdent values - valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values + let allIdents = map declIdent values + valueVerts = map (\d -> (d, declIdent d, usedIdents moduleName d `intersect` allIdents)) values bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName) return $ filter isImportDecl ds ++ filter isExternDataDecl ds ++ @@ -149,16 +148,16 @@ usedTypeNames moduleName = | moduleName == moduleName' = [name] usedNames _ = [] -getIdent :: Declaration -> Ident -getIdent (ValueDeclaration ident _ _ _) = ident -getIdent (PositionedDeclaration _ _ d) = getIdent d -getIdent _ = internalError "Expected ValueDeclaration" +declIdent :: Declaration -> Ident +declIdent (ValueDeclaration ident _ _ _) = ident +declIdent (PositionedDeclaration _ _ d) = declIdent d +declIdent _ = internalError "Expected ValueDeclaration" -getTypeName :: Declaration -> ProperName 'TypeName -getTypeName (DataDeclaration _ pn _ _) = pn -getTypeName (TypeSynonymDeclaration pn _ _) = pn -getTypeName (PositionedDeclaration _ _ d) = getTypeName d -getTypeName _ = internalError "Expected DataDeclaration" +declTypeName :: Declaration -> ProperName 'TypeName +declTypeName (DataDeclaration _ pn _ _) = pn +declTypeName (TypeSynonymDeclaration pn _ _) = pn +declTypeName (PositionedDeclaration _ _ d) = declTypeName d +declTypeName _ = internalError "Expected DataDeclaration" -- | -- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration). @@ -187,7 +186,7 @@ toBindingGroup moduleName (CyclicSCC ds') = idents = map (\(_, i, _) -> i) valueVerts valueVerts :: [(Declaration, Ident, [Ident])] - valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds' + valueVerts = map (\d -> (d, declIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds' toBinding :: SCC Declaration -> m (Ident, NameKind, Expr) toBinding (AcyclicSCC d) = return $ fromValueDecl d diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 23d65d7301..333724739c 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -12,7 +12,7 @@ import Prelude.Compat import Data.List (nub, groupBy, foldl1') import Data.Maybe (catMaybes, mapMaybe) -import Control.Monad ((<=<), forM, replicateM, join, unless) +import Control.Monad ((<=<), replicateM, join, unless) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class @@ -32,10 +32,15 @@ isLeft (Right _) = False -- | -- Replace all top-level binders in a module with case expressions. -- -desugarCasesModule :: (MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module] -desugarCasesModule ms = forM ms $ \(Module ss coms name ds exps) -> +desugarCasesModule + :: (MonadSupply m, MonadError MultipleErrors m) + => Module + -> m Module +desugarCasesModule (Module ss coms name ds exps) = rethrow (addHint (ErrorInModule name)) $ - Module ss coms name <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps + Module ss coms name + <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) + <*> pure exps -- | -- Validates that case head and binder lengths match. diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index cd58e67fdb..fe3c9a919a 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -37,7 +37,12 @@ import Language.PureScript.Types -- Replaces all local names with qualified names within a list of modules. The -- modules should be topologically sorted beforehand. -- -desugarImports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] +desugarImports + :: forall m + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => [ExternsFile] + -> [Module] + -> m [Module] desugarImports externs modules = fmap snd (desugarImportsWithEnv externs modules) @@ -63,7 +68,7 @@ desugarImportsWithEnv externs modules = do env' = M.insert efModuleName (ss, nullImports, members) env fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)]) imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports) - exps <- resolveExports env' efModuleName imps members efExports + exps <- resolveExports env' ss efModuleName imps members efExports return $ M.insert efModuleName (ss, imps, exps) env where @@ -77,24 +82,18 @@ desugarImportsWithEnv externs modules = do forTyCon _ = Nothing toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r toExportedType _ = Nothing - exportedTypeOps :: [(Ident, ModuleName)] - exportedTypeOps = mapMaybe toExportedTypeOp efExports - where - toExportedTypeOp (TypeOpRef ident) = Just (ident, efModuleName) - toExportedTypeOp (PositionedDeclarationRef _ _ r) = toExportedTypeOp r - toExportedTypeOp _ = Nothing + + exportedTypeOps :: [(OpName 'TypeOpName, ModuleName)] + exportedTypeOps = (, efModuleName) <$> mapMaybe getTypeOpRef efExports + exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)] - exportedTypeClasses = mapMaybe toExportedTypeClass efExports - where - toExportedTypeClass (TypeClassRef className) = Just (className, efModuleName) - toExportedTypeClass (PositionedDeclarationRef _ _ r) = toExportedTypeClass r - toExportedTypeClass _ = Nothing + exportedTypeClasses = (, efModuleName) <$> mapMaybe getTypeClassRef efExports + exportedValues :: [(Ident, ModuleName)] - exportedValues = mapMaybe toExportedValue efExports - where - toExportedValue (ValueRef ident) = Just (ident, efModuleName) - toExportedValue (PositionedDeclarationRef _ _ r) = toExportedValue r - toExportedValue _ = Nothing + exportedValues = (, efModuleName) <$> mapMaybe getValueRef efExports + + exportedValueOps :: [(OpName 'ValueOpName, ModuleName)] + exportedValueOps = (, efModuleName) <$> mapMaybe getValueOpRef efExports updateEnv :: ([Module], Env) -> Module -> m ([Module], Env) updateEnv (ms, env) m@(Module ss _ mn _ refs) = @@ -104,7 +103,7 @@ desugarImportsWithEnv externs modules = do members <- findExportable m let env' = M.insert mn (ss, nullImports, members) env (m', imps) <- resolveImports env' m - exps <- maybe (return members) (resolveExports env' mn imps members) refs + exps <- maybe (return members) (resolveExports env' ss mn imps members) refs return (m' : ms, M.insert mn (ss, imps, exps) env) renameInModule' :: Env -> Module -> m Module @@ -127,6 +126,7 @@ elaborateExports exps (Module ss coms mn decls refs) = map TypeOpRef (my exportedTypeOps) ++ map TypeClassRef (my exportedTypeClasses) ++ map ValueRef (my exportedValues) ++ + map ValueOpRef (my exportedValueOps) ++ maybe [] (filter isModuleRef) refs where -- Extracts a list of values from the exports and filters out any values that @@ -169,16 +169,12 @@ renameInModule env imports (Module ss coms mn decls exps) = (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty) updateDecl (pos, bound) (ExternDeclaration name ty) = (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty) - updateDecl (pos, bound) (FixityDeclaration fx name alias) = - (,) (pos, bound) <$> (FixityDeclaration fx name <$> traverse updateAlias alias) - where - updateAlias :: Qualified FixityAlias -> m (Qualified FixityAlias) - updateAlias (Qualified mn' (AliasValue ident)) = - fmap AliasValue <$> updateValueName (Qualified mn' ident) pos - updateAlias (Qualified mn' (AliasConstructor ctor)) = - fmap AliasConstructor <$> updateDataConstructorName (Qualified mn' ctor) pos - updateAlias (Qualified mn' (AliasType ty)) = - fmap AliasType <$> updateTypeName (Qualified mn' ty) pos + updateDecl (pos, bound) (TypeFixityDeclaration fixity alias op) = + (,) (pos, bound) <$> (TypeFixityDeclaration fixity <$> updateTypeName alias pos <*> pure op) + updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Left alias)) op) = + (,) (pos, bound) <$> (ValueFixityDeclaration fixity . fmap Left <$> updateValueName (Qualified mn' alias) pos <*> pure op) + updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Right alias)) op) = + (,) (pos, bound) <$> (ValueFixityDeclaration fixity . fmap Right <$> updateDataConstructorName (Qualified mn' alias) pos <*> pure op) updateDecl s d = return (s, d) updateValue @@ -199,6 +195,8 @@ renameInModule env imports (Module ss coms mn decls exps) = (,) (pos, bound) <$> (Var <$> updateValueName name' pos) updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) = (,) (pos, bound) <$> (Var <$> updateValueName name' pos) + updateValue (pos, bound) (Op op) = + (,) (pos, bound) <$> (Op <$> updateValueOpName op pos) updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos) updateValue s@(pos, _) (TypedValue check val ty) = @@ -213,8 +211,8 @@ renameInModule env imports (Module ss coms mn decls exps) = return ((Just pos, bound), v) updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b) - updateBinder s@(pos, _) (OpBinder name) = - (,) s <$> (OpBinder <$> updateValueName name pos) + updateBinder s@(pos, _) (OpBinder op) = + (,) s <$> (OpBinder <$> updateValueOpName op pos) updateBinder s (TypedBinder t b) = do (s'@ (span', _), b') <- updateBinder s b t' <- updateTypesEverywhere span' t @@ -254,23 +252,14 @@ renameInModule env imports (Module ss coms mn decls exps) = -> Maybe SourceSpan -> m (Qualified (ProperName 'TypeName)) updateTypeName = - update UnknownType - (importedTypes imports) - (resolveType . exportedTypes) - TyName - (("type " ++) . runProperName) + update (importedTypes imports) (resolveType . exportedTypes) TyName updateTypeOpName - :: Qualified Ident + :: Qualified (OpName 'TypeOpName) -> Maybe SourceSpan - -> m (Qualified Ident) + -> m (Qualified (OpName 'TypeOpName)) updateTypeOpName = - update - UnknownTypeOp - (importedTypeOps imports) - (resolve . exportedTypeOps) - TyOpName - (("type operator" ++) . runIdent) + update (importedTypeOps imports) (resolve . exportedTypeOps) TyOpName updateDataConstructorName :: Qualified (ProperName 'ConstructorName) @@ -278,11 +267,9 @@ renameInModule env imports (Module ss coms mn decls exps) = -> m (Qualified (ProperName 'ConstructorName)) updateDataConstructorName = update - (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName - (("data constructor " ++) . runProperName) updateClassName :: Qualified (ProperName 'ClassName) @@ -290,20 +277,20 @@ renameInModule env imports (Module ss coms mn decls exps) = -> m (Qualified (ProperName 'ClassName)) updateClassName = update - UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) TyClassName - (("class " ++) . runProperName) updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident) updateValueName = - update - UnknownValue - (importedValues imports) - (resolve . exportedValues) - IdentName - (("value " ++) . runIdent) + update (importedValues imports) (resolve . exportedValues) IdentName + + updateValueOpName + :: Qualified (OpName 'ValueOpName) + -> Maybe SourceSpan + -> m (Qualified (OpName 'ValueOpName)) + updateValueOpName = + update (importedValueOps imports) (resolve . exportedValueOps) ValOpName -- Used when performing an update to qualify values and classes with their -- module of original definition. @@ -316,7 +303,8 @@ renameInModule env imports (Module ss coms mn decls exps) = :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] -> ProperName 'TypeName -> Maybe (Qualified (ProperName 'TypeName)) - resolveType tys name = mkQualified name . snd <$> find ((== name) . fst . fst) tys + resolveType tys name = + mkQualified name . snd <$> find ((== name) . fst . fst) tys -- Used when performing an update to qualify data constructors with their -- module of original definition. @@ -324,22 +312,21 @@ renameInModule env imports (Module ss coms mn decls exps) = :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] -> ProperName 'ConstructorName -> Maybe (Qualified (ProperName 'ConstructorName)) - resolveDctor tys name = mkQualified name . snd <$> find (elem name . snd . fst) tys + resolveDctor tys name = + mkQualified name . snd <$> find (elem name . snd . fst) tys -- Update names so unqualified references become qualified, and locally -- qualified references are replaced with their canoncial qualified names -- (e.g. M.Map -> Data.Map.Map). update :: (Ord a, Show a) - => (Qualified a -> SimpleErrorMessage) - -> M.Map (Qualified a) [ImportRecord a] + => M.Map (Qualified a) [ImportRecord a] -> (Exports -> a -> Maybe (Qualified a)) - -> (Qualified a -> Name) - -> (a -> String) + -> (a -> Name) -> Qualified a -> Maybe SourceSpan -> m (Qualified a) - update unknown imps getE toName render qname@(Qualified mn' name) pos = positioned $ + update imps getE toName qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imps, mn') of -- We found the name in our imports, so we return the name for it, @@ -348,19 +335,25 @@ renameInModule env imports (Module ss coms mn decls exps) = -- re-exports. If there are multiple options for the name to resolve to -- in scope, we throw an error. (Just options, _) -> do - (mnNew, mnOrig) <- checkImportConflicts mn render options - modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result + (mnNew, mnOrig) <- checkImportConflicts mn toName options + modify $ \result -> + M.insert + mnNew + (maybe [fmap toName qname] (fmap toName qname :) (mnNew `M.lookup` result)) + result return $ Qualified (Just mnOrig) name -- If the name wasn't found in our imports but was qualified then we need -- to check whether it's a failed import from a "pseudo" module (created -- by qualified importing). If that's not the case, then we just need to -- check it refers to a symbol in another module. - (Nothing, Just mn'') -> do + (Nothing, Just mn'') -> case M.lookup mn'' env of Nothing | mn'' `S.member` importedVirtualModules imports -> throwUnknown - | otherwise -> throwError . errorMessage $ UnknownModule mn'' + | otherwise -> + throwError . errorMessage . + UnknownName . Qualified Nothing $ ModName mn'' Just env' -> maybe throwUnknown return (getE (envModuleExports env') name) -- If neither of the above cases are true then it's an undefined or @@ -368,7 +361,5 @@ renameInModule env imports (Module ss coms mn decls exps) = _ -> throwUnknown where - positioned err = case pos of - Nothing -> err - Just pos' -> rethrowWithPosition pos' err - throwUnknown = throwError . errorMessage $ unknown qname + positioned err = maybe err (`rethrowWithPosition` err) pos + throwUnknown = throwError . errorMessage . UnknownName . fmap toName $ qname diff --git a/src/Language/PureScript/Sugar/Names/Common.hs b/src/Language/PureScript/Sugar/Names/Common.hs new file mode 100644 index 0000000000..2e1d0d7659 --- /dev/null +++ b/src/Language/PureScript/Sugar/Names/Common.hs @@ -0,0 +1,66 @@ +module Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) where + +import Prelude.Compat + +import Control.Monad.Writer (MonadWriter(..)) + +import Data.Foldable (for_) +import Data.Function (on) +import Data.List (nub, nubBy, (\\)) +import Data.Maybe (mapMaybe) + +import Language.PureScript.AST +import Language.PureScript.Errors +import Language.PureScript.Names + +-- | +-- Warns about duplicate values in a list of declaration refs. +-- +warnDuplicateRefs + :: MonadWriter MultipleErrors m + => SourceSpan + -> (Name -> SimpleErrorMessage) + -> [DeclarationRef] + -> m () +warnDuplicateRefs pos toError refs = do + let withoutCtors = deleteCtors `map` refs + dupeRefs = mapMaybe (refToName pos) $ withoutCtors \\ nubBy ((==) `on` withoutPosInfo) withoutCtors + dupeCtors = concat $ mapMaybe (extractCtors pos) refs + + for_ (dupeRefs ++ dupeCtors) $ \(pos', name) -> + warnWithPosition pos' . tell . errorMessage $ toError name + + where + + -- Returns a DeclarationRef unwrapped from any PositionedDeclarationRef + -- constructor(s) it may be wrapped within. Used so position info is ignored + -- when making the comparison for duplicates. + withoutPosInfo :: DeclarationRef -> DeclarationRef + withoutPosInfo (PositionedDeclarationRef _ _ ref) = withoutPosInfo ref + withoutPosInfo other = other + + -- Deletes the constructor information from TypeRefs so that only the + -- referenced type is used in the duplicate check - constructors are handled + -- separately + deleteCtors :: DeclarationRef -> DeclarationRef + deleteCtors (TypeRef pn _) = TypeRef pn Nothing + deleteCtors other = other + + -- Extracts the names of duplicate constructor references from TypeRefs. + extractCtors :: SourceSpan -> DeclarationRef -> Maybe [(SourceSpan, Name)] + extractCtors pos' (TypeRef _ (Just dctors)) = + let dupes = dctors \\ nub dctors + in if null dupes then Nothing else Just $ ((pos',) . DctorName) <$> dupes + extractCtors _ (PositionedDeclarationRef pos' _ ref) = extractCtors pos' ref + extractCtors _ _ = Nothing + + -- Converts a DeclarationRef into a name for an error message. + refToName :: SourceSpan -> DeclarationRef -> Maybe (SourceSpan, Name) + refToName pos' (TypeRef name _) = Just (pos', TyName name) + refToName pos' (TypeOpRef op) = Just (pos', TyOpName op) + refToName pos' (ValueRef name) = Just (pos', IdentName name) + refToName pos' (ValueOpRef op) = Just (pos', ValOpName op) + refToName pos' (TypeClassRef name) = Just (pos', TyClassName name) + refToName pos' (ModuleRef name) = Just (pos', ModName name) + refToName _ (PositionedDeclarationRef pos' _ ref) = refToName pos' ref + refToName _ _ = Nothing diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index c0febdd2f2..e433f909d4 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -14,6 +14,7 @@ module Language.PureScript.Sugar.Names.Env , exportTypeOp , exportTypeClass , exportValue + , exportValueOp , getExports , checkImportConflicts ) where @@ -26,12 +27,11 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Function (on) import Data.List (groupBy, sortBy, nub, delete) -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S import Language.PureScript.AST -import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Names @@ -60,6 +60,8 @@ data ImportProvenance | Local deriving (Eq, Ord, Show, Read) +type ImportMap a = M.Map (Qualified a) [ImportRecord a] + -- | -- The imported declarations for a module, including the module's own members. -- @@ -68,23 +70,27 @@ data Imports = Imports -- | -- Local names for types within a module mapped to to their qualified names -- - importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [ImportRecord (ProperName 'TypeName)] + importedTypes :: ImportMap (ProperName 'TypeName) -- | -- Local names for type operators within a module mapped to to their qualified names -- - , importedTypeOps :: M.Map (Qualified Ident) [ImportRecord Ident] + , importedTypeOps :: ImportMap (OpName 'TypeOpName) -- | -- Local names for data constructors within a module mapped to to their qualified names -- - , importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [ImportRecord (ProperName 'ConstructorName)] + , importedDataConstructors :: ImportMap (ProperName 'ConstructorName) -- | -- Local names for classes within a module mapped to to their qualified names -- - , importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [ImportRecord (ProperName 'ClassName)] + , importedTypeClasses :: ImportMap (ProperName 'ClassName) -- | -- Local names for values within a module mapped to to their qualified names -- - , importedValues :: M.Map (Qualified Ident) [ImportRecord Ident] + , importedValues :: ImportMap Ident + -- | + -- Local names for value operators within a module mapped to to their qualified names + -- + , importedValueOps :: ImportMap (OpName 'ValueOpName) -- | -- The modules that have been imported into the current scope. -- @@ -100,7 +106,7 @@ data Imports = Imports -- An empty 'Imports' value. -- nullImports :: Imports -nullImports = Imports M.empty M.empty M.empty M.empty M.empty S.empty S.empty +nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty -- | -- The exported declarations from a module. @@ -116,7 +122,7 @@ data Exports = Exports -- The type operators exported from each module along with the module they -- originally came from. -- - , exportedTypeOps :: [(Ident, ModuleName)] + , exportedTypeOps :: [(OpName 'TypeOpName, ModuleName)] -- | -- The classes exported from each module along with the module they originally -- came from. @@ -127,13 +133,18 @@ data Exports = Exports -- came from. -- , exportedValues :: [(Ident, ModuleName)] + -- | + -- The value operators exported from each module along with the module they + -- originally came from. + -- + , exportedValueOps :: [(OpName 'ValueOpName, ModuleName)] } deriving (Show, Read) -- | -- An empty 'Exports' value. -- nullExports :: Exports -nullExports = Exports [] [] [] [] +nullExports = Exports [] [] [] [] [] -- | -- The imports and exports for a collection of modules. The 'SourceSpan' is used @@ -164,7 +175,11 @@ envModuleExports (_, _, exps) = exps -- The exported types from the @Prim@ module -- primExports :: Exports -primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] (mkClassEntry `map` M.keys primClasses) [] +primExports = + nullExports + { exportedTypes = mkTypeEntry `map` M.keys primTypes + , exportedTypeClasses = mkClassEntry `map` M.keys primClasses + } where mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn) mkClassEntry (Qualified mn name) = (name, fromJust mn) @@ -179,53 +194,100 @@ primEnv = M.singleton -- Safely adds a type and its data constructors to some exports, returning an -- error if a conflict occurs. -- -exportType :: (MonadError MultipleErrors m) => Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ModuleName -> m Exports +exportType + :: MonadError MultipleErrors m + => Exports + -> ProperName 'TypeName + -> [ProperName 'ConstructorName] + -> ModuleName + -> m Exports exportType exps name dctors mn = do let exTypes' = exportedTypes exps let exTypes = filter ((/= mn) . snd) exTypes' let exDctors = (snd . fst) `concatMap` exTypes let exClasses = exportedTypeClasses exps - when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name - when (any ((== coerceProperName name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name + when (any ((== name) . fst . fst) exTypes) $ + throwConflictError ConflictingTypeDecls name + when (any ((== coerceProperName name) . fst) exClasses) $ + throwConflictError TypeConflictsWithClass name forM_ dctors $ \dctor -> do - when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor - when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor + when (dctor `elem` exDctors) $ + throwConflictError ConflictingCtorDecls dctor + when (any ((== coerceProperName dctor) . fst) exClasses) $ + throwConflictError CtorConflictsWithClass dctor return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' } -- | -- Safely adds a type operator to some exports, returning an error if a -- conflict occurs. -- -exportTypeOp :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports -exportTypeOp exps name mn = do - typeOps <- addExport DuplicateTypeOpExport name mn (exportedTypeOps exps) +exportTypeOp + :: MonadError MultipleErrors m + => Exports + -> OpName 'TypeOpName + -> ModuleName + -> m Exports +exportTypeOp exps op mn = do + typeOps <- addExport DuplicateTypeOpExport op mn (exportedTypeOps exps) return $ exps { exportedTypeOps = typeOps } -- | -- Safely adds a class to some exports, returning an error if a conflict occurs. -- -exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName 'ClassName -> ModuleName -> m Exports +exportTypeClass + :: MonadError MultipleErrors m + => Exports + -> ProperName 'ClassName + -> ModuleName + -> m Exports exportTypeClass exps name mn = do let exTypes = exportedTypes exps let exDctors = (snd . fst) `concatMap` exTypes - when (any ((== coerceProperName name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name - when (coerceProperName name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name + when (any ((== coerceProperName name) . fst . fst) exTypes) $ + throwConflictError ClassConflictsWithType name + when (coerceProperName name `elem` exDctors) $ + throwConflictError ClassConflictsWithCtor name classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps) return $ exps { exportedTypeClasses = classes } -- | -- Safely adds a value to some exports, returning an error if a conflict occurs. -- -exportValue :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports +exportValue + :: MonadError MultipleErrors m + => Exports + -> Ident + -> ModuleName + -> m Exports exportValue exps name mn = do values <- addExport DuplicateValueExport name mn (exportedValues exps) return $ exps { exportedValues = values } -- | --- Adds an entry to a list of exports unless it is already present, in which case an error is --- returned. +-- Safely adds a value operator to some exports, returning an error if a +-- conflict occurs. +-- +exportValueOp + :: MonadError MultipleErrors m + => Exports + -> OpName 'ValueOpName + -> ModuleName + -> m Exports +exportValueOp exps op mn = do + valueOps <- addExport DuplicateValueOpExport op mn (exportedValueOps exps) + return $ exps { exportedValueOps = valueOps } + +-- | +-- Adds an entry to a list of exports unless it is already present, in which +-- case an error is returned. -- -addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)] +addExport + :: (MonadError MultipleErrors m, Eq a) + => (a -> SimpleErrorMessage) + -> a + -> ModuleName + -> [(a, ModuleName)] + -> m [(a, ModuleName)] addExport what name mn exports = if any (\(name', mn') -> name == name' && mn /= mn') exports then throwConflictError what name @@ -234,12 +296,22 @@ addExport what name mn exports = -- | -- Raises an error for when there is more than one definition for something. -- -throwConflictError :: (MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> a -> m b +throwConflictError + :: MonadError MultipleErrors m + => (a -> SimpleErrorMessage) + -> a + -> m b throwConflictError conflict = throwError . errorMessage . conflict --- Gets the exports for a module, or an error message if the module doesn't exist -getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports -getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env +-- | +-- Gets the exports for a module, or raise an error if the module doesn't exist. +-- +getExports :: MonadError MultipleErrors m => Env -> ModuleName -> m Exports +getExports env mn = + maybe + (throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn) + (return . envModuleExports) + $ M.lookup mn env -- | -- When reading a value from the imports, check that there are no conflicts in @@ -249,16 +321,16 @@ checkImportConflicts :: forall m a . (Show a, MonadError MultipleErrors m, MonadWriter MultipleErrors m, Ord a) => ModuleName - -> (a -> String) + -> (a -> Name) -> [ImportRecord a] -> m (ModuleName, ModuleName) -checkImportConflicts currentModule render xs = +checkImportConflicts currentModule toName xs = let byOrig = sortBy (compare `on` importSourceModule) xs groups = groupBy ((==) `on` importSourceModule) byOrig nonImplicit = filter ((/= FromImplicit) . importProvenance) xs - name = render' (importName . head $ xs) - conflictModules = map (getQual . importName . head) groups + name = toName . disqualify . importName $ head xs + conflictModules = mapMaybe (getQual . importName . head) groups in if length groups > 1 then case nonImplicit of @@ -270,9 +342,3 @@ checkImportConflicts currentModule render xs = else let ImportRecord (Qualified (Just mnNew) _) mnOrig _ = head byOrig in return (mnNew, mnOrig) - where - getQual :: Qualified a -> ModuleName - getQual (Qualified (Just mn) _) = mn - getQual _ = internalError "unexpected unqualified name in checkImportConflicts" - render' :: Qualified a -> String - render' (Qualified _ a) = render a diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index c779407e6d..5c0f12dd4f 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -18,7 +18,8 @@ import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.Names -import Language.PureScript.Sugar.Names.Env +import Language.PureScript.Sugar.Names.Env +import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) -- | -- Finds all exportable members of a module, disregarding any explicit exports. @@ -39,8 +40,8 @@ findExportable (Module _ _ mn ds _) = updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn - updateExports exps (FixityDeclaration _ name (Just (Qualified _ (AliasType _)))) = exportTypeOp exps (Op name) mn - updateExports exps (FixityDeclaration _ name (Just _)) = exportValue exps (Op name) mn + updateExports exps (ValueFixityDeclaration _ _ op) = exportValueOp exps op mn + updateExports exps (TypeFixityDeclaration _ _ op) = exportTypeOp exps op mn updateExports exps (ExternDeclaration name _) = exportValue exps name mn updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d updateExports exps _ = return exps @@ -49,62 +50,59 @@ findExportable (Module _ _ mn ds _) = -- Resolves the exports for a module, filtering out members that have not been -- exported and elaborating re-exports of other modules. -- -resolveExports :: forall m. (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Env -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports -resolveExports env mn imps exps refs = - rethrow (addHint (ErrorInModule mn)) $ do +resolveExports + :: forall m + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Env + -> SourceSpan + -> ModuleName + -> Imports + -> Exports + -> [DeclarationRef] + -> m Exports +resolveExports env ss mn imps exps refs = + warnAndRethrow (addHint (ErrorInModule mn)) $ do filtered <- filterModule mn exps refs - let (dupeRefs, dupeDctors) = findDuplicateRefs refs - warnDupeRefs dupeRefs - warnDupeDctors dupeDctors - foldM elaborateModuleExports filtered refs - + exps' <- foldM elaborateModuleExports filtered refs + warnDuplicateRefs ss DuplicateExportRef refs + return exps' + where - warnDupeRefs :: [DeclarationRef] -> m () - warnDupeRefs = traverse_ $ \case - TypeRef name _ -> warnDupe $ "type " ++ runProperName name - TypeOpRef name -> warnDupe $ "type operator " ++ runIdent name - ValueRef name -> warnDupe $ "value " ++ runIdent name - TypeClassRef name -> warnDupe $ "class " ++ runProperName name - ModuleRef name -> warnDupe $ "module " ++ runModuleName name - _ -> return () - - warnDupeDctors :: [ProperName 'ConstructorName] -> m () - warnDupeDctors = traverse_ (warnDupe . ("data constructor " ++) . runProperName) - - warnDupe :: String -> m () - warnDupe ref = tell . errorMessage $ DuplicateExportRef ref - -- Takes the current module's imports, the accumulated list of exports, and a -- `DeclarationRef` for an explicit export. When the ref refers to another -- module, export anything from the imports that matches for that module. elaborateModuleExports :: Exports -> DeclarationRef -> m Exports elaborateModuleExports result (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ elaborateModuleExports result r + warnAndRethrowWithPosition pos $ elaborateModuleExports result r elaborateModuleExports result (ModuleRef name) | name == mn = do let types' = exportedTypes result ++ exportedTypes exps let typeOps' = exportedTypeOps result ++ exportedTypeOps exps let classes' = exportedTypeClasses result ++ exportedTypeClasses exps let values' = exportedValues result ++ exportedValues exps + let valueOps' = exportedValueOps result ++ exportedValueOps exps return result { exportedTypes = types' , exportedTypeOps = typeOps' , exportedTypeClasses = classes' , exportedValues = values' + , exportedValueOps = valueOps' } elaborateModuleExports result (ModuleRef name) = do let isPseudo = isPseudoModule name - when (not isPseudo && not (isImportedModule name)) $ - throwError . errorMessage . UnknownExportModule $ name - reTypes <- extract isPseudo name (("type " ++) . runProperName) (importedTypes imps) - reTypeOps <- extract isPseudo name (("type operator " ++) . runIdent) (importedTypeOps imps) - reDctors <- extract isPseudo name (("data constructor " ++) . runProperName) (importedDataConstructors imps) - reClasses <- extract isPseudo name (("class " ++) . runProperName) (importedTypeClasses imps) - reValues <- extract isPseudo name (("value " ++) . runIdent) (importedValues imps) - result' <- foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors) - result'' <- foldM (uncurry . exportTypeOp) result' (map resolveTypeOp reTypeOps) - result''' <- foldM (uncurry . exportTypeClass) result'' (map resolveClass reClasses) - foldM (uncurry . exportValue) result''' (map resolveValue reValues) + when (not isPseudo && not (isImportedModule name)) + . throwError . errorMessage . UnknownExport $ ModName name + reTypes <- extract isPseudo name TyName (importedTypes imps) + reTypeOps <- extract isPseudo name TyOpName (importedTypeOps imps) + reDctors <- extract isPseudo name DctorName (importedDataConstructors imps) + reClasses <- extract isPseudo name TyClassName (importedTypeClasses imps) + reValues <- extract isPseudo name IdentName (importedValues imps) + reValueOps <- extract isPseudo name ValOpName (importedValueOps imps) + foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors) + >>= flip (foldM (uncurry . exportTypeOp)) (map resolveTypeOp reTypeOps) + >>= flip (foldM (uncurry . exportTypeClass)) (map resolveClass reClasses) + >>= flip (foldM (uncurry . exportValue)) (map resolveValue reValues) + >>= flip (foldM (uncurry . exportValueOp)) (map resolveValueOp reValueOps) elaborateModuleExports result _ = return result -- Extracts a list of values for a module based on a lookup table. If the @@ -113,14 +111,14 @@ resolveExports env mn imps exps refs = :: (Show a, Ord a) => Bool -> ModuleName - -> (a -> String) + -> (a -> Name) -> M.Map (Qualified a) [ImportRecord a] -> m [Qualified a] - extract useQual name render = fmap (map (importName . head . snd)) . go . M.toList + extract useQual name toName = fmap (map (importName . head . snd)) . go . M.toList where go = filterM $ \(name', options) -> do let isMatch = if useQual then isQualifiedWith name name' else any (checkUnqual name') options - when (isMatch && length options > 1) $ void $ checkImportConflicts mn render options + when (isMatch && length options > 1) $ void $ checkImportConflicts mn toName options return isMatch checkUnqual name' ir = isUnqualified name' && isQualifiedWith name (importName ir) @@ -139,6 +137,7 @@ resolveExports env mn imps exps refs = || any (isQualifiedWith mn') (f (importedDataConstructors imps)) || any (isQualifiedWith mn') (f (importedTypeClasses imps)) || any (isQualifiedWith mn') (f (importedValues imps)) + || any (isQualifiedWith mn') (f (importedValueOps imps)) -- Check whether a module name refers to a module that has been imported -- without qualification into an import scope. @@ -165,21 +164,35 @@ resolveExports env mn imps exps refs = -- Looks up an imported type operator and re-qualifies it with the original -- module it came from. - resolveTypeOp :: Qualified Ident -> (Ident, ModuleName) - resolveTypeOp ident = splitQual $ fromMaybe (internalError "Missing value in resolveValue") $ - resolve exportedTypeOps ident + resolveTypeOp :: Qualified (OpName 'TypeOpName) -> (OpName 'TypeOpName, ModuleName) + resolveTypeOp op + = splitQual + . fromMaybe (internalError "Missing value in resolveValue") + $ resolve exportedTypeOps op -- Looks up an imported class and re-qualifies it with the original module it -- came from. resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ModuleName) - resolveClass className = splitQual $ fromMaybe (internalError "Missing value in resolveClass") $ - resolve exportedTypeClasses className + resolveClass className + = splitQual + . fromMaybe (internalError "Missing value in resolveClass") + $ resolve exportedTypeClasses className -- Looks up an imported value and re-qualifies it with the original module it -- came from. resolveValue :: Qualified Ident -> (Ident, ModuleName) - resolveValue ident = splitQual $ fromMaybe (internalError "Missing value in resolveValue") $ - resolve exportedValues ident + resolveValue ident + = splitQual + . fromMaybe (internalError "Missing value in resolveValue") + $ resolve exportedValues ident + + -- Looks up an imported operator and re-qualifies it with the original + -- module it came from. + resolveValueOp :: Qualified (OpName 'ValueOpName) -> (OpName 'ValueOpName, ModuleName) + resolveValueOp op + = splitQual + . fromMaybe (internalError "Missing value in resolveValueOp") + $ resolve exportedValueOps op resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a) resolve f (Qualified (Just mn'') a) = do @@ -200,97 +213,69 @@ resolveExports env mn imps exps refs = -- filterModule :: forall m - . (MonadError MultipleErrors m) + . MonadError MultipleErrors m => ModuleName -> Exports -> [DeclarationRef] -> m Exports filterModule mn exps refs = do - types <- foldM (filterTypes $ exportedTypes exps) [] refs - typeOps <- foldM (filterTypeOps $ exportedTypeOps exps) [] refs - values <- foldM (filterValues $ exportedValues exps) [] refs - classes <- foldM (filterClasses $ exportedTypeClasses exps) [] refs - return $ exps + types <- foldM filterTypes [] refs + typeOps <- foldM (filterExport TyOpName getTypeOpRef exportedTypeOps) [] refs + classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) [] refs + values <- foldM (filterExport IdentName getValueRef exportedValues) [] refs + valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) [] refs + return Exports { exportedTypes = types , exportedTypeOps = typeOps , exportedTypeClasses = classes , exportedValues = values + , exportedValueOps = valueOps } where - -- Takes a list of all the exportable types with their data constructors, the - -- accumulated list of filtered exports, and a `DeclarationRef` for an - -- explicit export. When the ref refers to a type in the list of exportable - -- values, the type and specified data constructors are included in the - -- result. filterTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] - -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] -> DeclarationRef -> m [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] - filterTypes exps' result (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ filterTypes exps' result r - filterTypes exps' result (TypeRef name expDcons) = - case (\((name', _), mn') -> name == name' && mn == mn') `find` exps' of - Nothing -> throwError . errorMessage . UnknownExportType $ name + filterTypes result (PositionedDeclarationRef pos _ r) = + rethrowWithPosition pos $ filterTypes result r + filterTypes result (TypeRef name expDcons) = + case matchType `find` exportedTypes exps of + Nothing -> throwError . errorMessage . UnknownExport $ TyName name Just ((_, dcons), _) -> do let expDcons' = fromMaybe dcons expDcons traverse_ (checkDcon name dcons) expDcons' return $ ((name, expDcons'), mn) : result - filterTypes _ result _ = return result - - -- Ensures a data constructor is exportable for a given type. Takes a type - -- name, a list of exportable data constructors for the type, and the name of - -- the data constructor to check. - checkDcon - :: ProperName 'TypeName - -> [ProperName 'ConstructorName] - -> ProperName 'ConstructorName - -> m () - checkDcon tcon exps' name = - unless (name `elem` exps') $ - throwError . errorMessage $ UnknownExportDataConstructor tcon name - - -- Takes a list of all the exportable type operators, the accumulated list of - -- filtered exports, and a `DeclarationRef` for an explicit export. When the - -- ref refers to a value in the list of exportable values, the value is - -- included in the result. - filterTypeOps :: [(Ident, ModuleName)] -> [(Ident, ModuleName)] -> DeclarationRef -> m [(Ident, ModuleName)] - filterTypeOps exps' result (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ filterTypeOps exps' result r - filterTypeOps exps' result (TypeOpRef name) = - if (name, mn) `elem` exps' - then return $ (name, mn) : result - else throwError . errorMessage . UnknownExportTypeOp $ name - filterTypeOps _ result _ = return result + where + -- Finds a type declaration by matching its name and defining module + matchType ((name', _), mn') = name == name' && mn == mn' + -- Ensures a data constructor is exportable for a given type. Takes a type + -- name, a list of exportable data constructors for the type, and the name of + -- the data constructor to check. + checkDcon + :: ProperName 'TypeName + -> [ProperName 'ConstructorName] + -> ProperName 'ConstructorName + -> m () + checkDcon tcon dcons dcon = + unless (dcon `elem` dcons) $ + throwError . errorMessage $ UnknownExportDataConstructor tcon dcon + filterTypes result _ = return result - -- Takes a list of all the exportable classes, the accumulated list of - -- filtered exports, and a `DeclarationRef` for an explicit export. When the - -- ref refers to a class in the list of exportable classes, the class is - -- included in the result. - filterClasses - :: [(ProperName 'ClassName, ModuleName)] - -> [(ProperName 'ClassName, ModuleName)] + filterExport + :: Eq a + => (a -> Name) + -> (DeclarationRef -> Maybe a) + -> (Exports -> [(a, ModuleName)]) + -> [(a, ModuleName)] -> DeclarationRef - -> m [(ProperName 'ClassName, ModuleName)] - filterClasses exps' result (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ filterClasses exps' result r - filterClasses exps' result (TypeClassRef name) = - if (name, mn) `elem` exps' - then return $ (name, mn) : result - else throwError . errorMessage . UnknownExportTypeClass $ name - filterClasses _ result _ = return result - - -- Takes a list of all the exportable values, the accumulated list of filtered - -- exports, and a `DeclarationRef` for an explicit export. When the ref refers - -- to a value in the list of exportable values, the value is included in the - -- result. - filterValues :: [(Ident, ModuleName)] -> [(Ident, ModuleName)] -> DeclarationRef -> m [(Ident, ModuleName)] - filterValues exps' result (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ filterValues exps' result r - filterValues exps' result (ValueRef name) = - if (name, mn) `elem` exps' - then return $ (name, mn) : result - else throwError . errorMessage . UnknownExportValue $ name - filterValues _ result _ = return result + -> m [(a, ModuleName)] + filterExport toName get fromExps result (PositionedDeclarationRef pos _ r) = + rethrowWithPosition pos $ filterExport toName get fromExps result r + filterExport toName get fromExps result ref + | Just name <- get ref = + if (name, mn) `elem` fromExps exps + then return $ (name, mn) : result + else throwError . errorMessage . UnknownExport $ toName name + filterExport _ _ _ result _ = return result diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index a095ca44d0..57d58e2b10 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -1,5 +1,6 @@ module Language.PureScript.Sugar.Names.Imports - ( resolveImports + ( ImportDef + , resolveImports , resolveModuleImport , findImports ) where @@ -9,13 +10,10 @@ import Prelude.Compat import Control.Arrow (first) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer (MonadWriter(..)) -import Data.Foldable (traverse_, for_) -import Data.Function (on) -import Data.List (find, sortBy, groupBy, (\\)) -import Data.Maybe (fromMaybe, isNothing) -import Data.Traversable (for) +import Data.Foldable (for_, traverse_) +import Data.List (find) +import Data.Maybe (fromMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -25,110 +23,44 @@ import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Sugar.Names.Env +type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) + -- | -- Finds the imports within a module, mapping the imported module name to an optional set of -- explicitly imported declarations. -- findImports - :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => [Declaration] - -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) -findImports = foldM (go Nothing) M.empty + :: [Declaration] + -> M.Map ModuleName [ImportDef] +findImports = foldl (go Nothing) M.empty where - go pos result (ImportDeclaration mn typ qual) = do + go pos result (ImportDeclaration mn typ qual) = let imp = (pos, typ, qual) - return $ M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result - go _ result (PositionedDeclaration pos _ d) = warnAndRethrowWithPosition pos $ go (Just pos) result d - go _ result _ = return result - -type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) + in M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result + go _ result (PositionedDeclaration pos _ d) = go (Just pos) result d + go _ result _ = result -- | -- Constructs a set of imports for a module. -- resolveImports :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . MonadError MultipleErrors m => Env -> Module -> m (Module, Imports) resolveImports env (Module ss coms currentModule decls exps) = - warnAndRethrow (addHint (ErrorInModule currentModule)) $ do - - imports <- findImports decls - - for_ (M.toList imports) $ \(mn, imps) -> do - - warned <- foldM (checkDuplicateImports mn) [] (selfCartesianSubset imps) - - let unwarned = imps \\ warned - duplicates - = join - . map tail - . filter ((> 1) . length) - . groupBy ((==) `on` defQual) - . sortBy (compare `on` defQual) - $ unwarned - - warned' <- - for duplicates $ \i@(pos, _, _) -> do - warn pos $ DuplicateSelectiveImport mn - return i - - for_ (imps \\ (warned ++ warned')) $ \(pos, typ, _) -> - let (dupeRefs, dupeDctors) = findDuplicateRefs $ case typ of - Explicit refs -> refs - Hiding refs -> refs - _ -> [] - in warnDupeRefs pos dupeRefs >> warnDupeDctors pos dupeDctors - - return () - - let imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports + rethrow (addHint (ErrorInModule currentModule)) $ do + let imports = findImports decls + imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports' - resolved <- foldM (resolveModuleImport env) nullImports (M.toList scope) - - return (Module ss coms currentModule decls exps, resolved) - - where - defQual :: ImportDef -> Maybe ModuleName - defQual (_, _, q) = q - - selfCartesianSubset :: [a] -> [(a, a)] - selfCartesianSubset (x : xs) = [(x, y) | y <- xs] ++ selfCartesianSubset xs - selfCartesianSubset [] = [] - - checkDuplicateImports :: ModuleName -> [ImportDef] -> (ImportDef, ImportDef) -> m [ImportDef] - checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) = - if (t1 == t2 && q1 == q2) - then do - warn pos $ DuplicateImport mn t2 q2 - return $ (pos, t2, q2) : xs - else return xs - - warnDupeRefs :: Maybe SourceSpan -> [DeclarationRef] -> m () - warnDupeRefs pos = traverse_ $ \case - TypeRef name _ -> warnDupe pos $ "type " ++ runProperName name - TypeOpRef name -> warnDupe pos $ "type operator " ++ runIdent name - ValueRef name -> warnDupe pos $ "value " ++ runIdent name - TypeClassRef name -> warnDupe pos $ "class " ++ runProperName name - ModuleRef name -> warnDupe pos $ "module " ++ runModuleName name - _ -> return () - - warnDupeDctors :: Maybe SourceSpan -> [ProperName 'ConstructorName] -> m () - warnDupeDctors pos = traverse_ (warnDupe pos . ("data constructor " ++) . runProperName) - - warnDupe :: Maybe SourceSpan -> String -> m () - warnDupe pos ref = warn pos $ DuplicateImportRef ref - - warn :: Maybe SourceSpan -> SimpleErrorMessage -> m () - warn pos msg = maybe id warnWithPosition pos $ tell . errorMessage $ msg + (Module ss coms currentModule decls exps,) <$> + foldM (resolveModuleImport env) nullImports (M.toList scope) -- | Constructs a set of imports for a single module import. resolveModuleImport :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . MonadError MultipleErrors m => Env -> Imports -> (ModuleName, [(Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)]) @@ -139,7 +71,11 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps -> (Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName) -> m Imports go ie' (pos, typ, impQual) = do - modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ mn `M.lookup` env + modExports <- + positioned $ maybe + (throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn) + (return . envModuleExports) + (mn `M.lookup` env) let virtualModules = importedVirtualModules ie' ie'' = ie' { importedModules = S.insert mn (importedModules ie') , importedVirtualModules = maybe virtualModules (`S.insert` virtualModules) impQual @@ -155,7 +91,7 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps -- resolveImport :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . MonadError MultipleErrors m => ModuleName -> Exports -> Imports @@ -166,19 +102,14 @@ resolveImport importModule exps imps impQual = resolveByType where resolveByType :: Maybe ImportDeclarationType -> m Imports - resolveByType Nothing = importAll (importRef Local) - resolveByType (Just Implicit) = importAll (importRef FromImplicit) - resolveByType (Just (Explicit refs)) = checkRefs False refs >> foldM (importRef FromExplicit) imps refs - resolveByType (Just (Hiding refs)) = do - imps' <- checkRefs True refs >> importAll (importNonHidden refs) - let isEmptyImport - = M.null (importedTypes imps') - && M.null (importedTypeOps imps') - && M.null (importedDataConstructors imps') - && M.null (importedTypeClasses imps') - && M.null (importedValues imps') - when isEmptyImport $ tell . errorMessage $ RedundantEmptyHidingImport importModule - return imps' + resolveByType Nothing = + importAll (importRef Local) + resolveByType (Just Implicit) = + importAll (importRef FromImplicit) + resolveByType (Just (Explicit refs)) = + checkRefs False refs >> foldM (importRef FromExplicit) imps refs + resolveByType (Just (Hiding refs)) = + checkRefs True refs >> importAll (importNonHidden refs) -- Check that a 'DeclarationRef' refers to an importable symbol checkRefs :: Bool -> [DeclarationRef] -> m () @@ -187,15 +118,17 @@ resolveImport importModule exps imps impQual = resolveByType check (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ check r check (ValueRef name) = - checkImportExists UnknownImportValue (fst `map` exportedValues exps) name + checkImportExists IdentName (fst `map` exportedValues exps) name + check (ValueOpRef op) = + checkImportExists ValOpName (fst `map` exportedValueOps exps) op check (TypeRef name dctors) = do - checkImportExists UnknownImportType ((fst . fst) `map` exportedTypes exps) name + checkImportExists TyName ((fst . fst) `map` exportedTypes exps) name let allDctors = fst `map` allExportedDataConstructors name - maybe (return ()) (traverse_ $ checkDctorExists name allDctors) dctors + for_ dctors $ traverse_ (checkDctorExists name allDctors) check (TypeOpRef name) = - checkImportExists UnknownImportTypeOp (fst `map` exportedTypeOps exps) name + checkImportExists TyOpName (fst `map` exportedTypeOps exps) name check (TypeClassRef name) = - checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name + checkImportExists TyClassName (fst `map` exportedTypeClasses exps) name check (ModuleRef name) | isHiding = throwError . errorMessage $ ImportHidingModule name check r = internalError $ "Invalid argument to checkRefs: " ++ show r @@ -203,12 +136,14 @@ resolveImport importModule exps imps impQual = resolveByType -- Check that an explicitly imported item exists in the module it is being imported from checkImportExists :: Eq a - => (ModuleName -> a -> SimpleErrorMessage) + => (a -> Name) -> [a] -> a -> m () - checkImportExists unknown exports item = - when (item `notElem` exports) $ throwError . errorMessage $ unknown importModule item + checkImportExists toName exports item + = when (item `notElem` exports) + . throwError . errorMessage + $ UnknownImport importModule (toName item) -- Ensure that an explicitly imported data constructor exists for the type it is being imported -- from @@ -217,7 +152,10 @@ resolveImport importModule exps imps impQual = resolveByType -> [ProperName 'ConstructorName] -> ProperName 'ConstructorName -> m () - checkDctorExists tcon = checkImportExists (flip UnknownImportDataConstructor tcon) + checkDctorExists tcon exports dctor + = when (dctor `notElem` exports) + . throwError . errorMessage + $ UnknownImportDataConstructor importModule tcon dctor importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports importNonHidden hidden m ref | isHidden ref = return m @@ -238,18 +176,22 @@ resolveImport importModule exps imps impQual = resolveByType -- Import all symbols importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports - importAll importer = do - imp' <- foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps) - imp'' <- foldM (\m (name, _) -> importer m (TypeOpRef name)) imp' (exportedTypeOps exps) - imp''' <- foldM (\m (name, _) -> importer m (ValueRef name)) imp'' (exportedValues exps) - foldM (\m (name, _) -> importer m (TypeClassRef name)) imp''' (exportedTypeClasses exps) + importAll importer = + foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps) + >>= flip (foldM (\m (name, _) -> importer m (TypeOpRef name))) (exportedTypeOps exps) + >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (exportedValues exps) + >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (exportedValueOps exps) + >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (exportedTypeClasses exps) importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports importRef prov imp (PositionedDeclarationRef pos _ r) = - warnAndRethrowWithPosition pos $ importRef prov imp r + rethrowWithPosition pos $ importRef prov imp r importRef prov imp (ValueRef name) = do let values' = updateImports (importedValues imp) (exportedValues exps) name prov return $ imp { importedValues = values' } + importRef prov imp (ValueOpRef name) = do + let valueOps' = updateImports (importedValueOps imp) (exportedValueOps exps) name prov + return $ imp { importedValueOps = valueOps' } importRef prov imp (TypeRef name dctors) = do let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name prov let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)] @@ -257,7 +199,6 @@ resolveImport importModule exps imps impQual = resolveByType dctorNames :: [ProperName 'ConstructorName] dctorNames = fst `map` exportedDctors maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors - when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name let dctors' = foldl (\m d -> updateImports m exportedDctors d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors) return $ imp { importedTypes = types', importedDataConstructors = dctors' } importRef prov imp (TypeOpRef name) = do @@ -266,10 +207,13 @@ resolveImport importModule exps imps impQual = resolveByType importRef prov imp (TypeClassRef name) = do let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov return $ imp { importedTypeClasses = typeClasses' } - importRef _ _ _ = internalError "Invalid argument to importRef" + importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef" + importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef" -- Find all exported data constructors for a given type - allExportedDataConstructors :: ProperName 'TypeName -> [(ProperName 'ConstructorName, ModuleName)] + allExportedDataConstructors + :: ProperName 'TypeName + -> [(ProperName 'ConstructorName, ModuleName)] allExportedDataConstructors name = case find ((== name) . fst . fst) (exportedTypes exps) of Nothing -> internalError "Invalid state in allExportedDataConstructors" diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 54531ffc00..312ac5844b 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -6,8 +6,9 @@ -- it is necessary to reorder them here. -- module Language.PureScript.Sugar.Operators - ( rebracket - , removeSignedLiterals + ( desugarSignedLiterals + , rebracket + , checkFixityExports ) where import Prelude.Compat @@ -23,27 +24,43 @@ import Language.PureScript.Sugar.Operators.Types import Language.PureScript.Traversals (defS, sndM) import Language.PureScript.Types -import Control.Monad ((<=<)) +import Control.Monad (unless, (<=<)) import Control.Monad.Error.Class (MonadError(..)) +import Data.Either (partitionEithers) +import Data.Foldable (for_, traverse_) import Data.Function (on) -import Data.Functor.Identity -import Data.List (partition, groupBy, sortBy) -import Data.Maybe (mapMaybe) +import Data.Functor.Identity (Identity(..), runIdentity) +import Data.List (groupBy, sortBy) +import Data.Maybe (mapMaybe, listToMaybe) +import Data.Traversable (for) import qualified Data.Map as M import qualified Language.PureScript.Constants as C --- TODO: in 0.9 operators names can have their own type rather than being in a sum with `Ident`, and `FixityAlias` no longer needs to be optional +-- | +-- Removes unary negation operators and replaces them with calls to `negate`. +-- +desugarSignedLiterals :: Module -> Module +desugarSignedLiterals (Module ss coms mn ds exts) = + Module ss coms mn (map f' ds) exts + where + (f', _, _) = everywhereOnValues id go id + go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val + go other = other -- | -- An operator associated with its declaration position, fixity, and the name -- of the function or data constructor it is an alias for. -- -type FixityRecord = (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified FixityAlias)) +type FixityRecord op alias = (Qualified op, SourceSpan, Fixity, Qualified alias) +type ValueFixityRecord = FixityRecord (OpName 'ValueOpName) (Either Ident (ProperName 'ConstructorName)) +type TypeFixityRecord = FixityRecord (OpName 'TypeOpName) (ProperName 'TypeName) -- | --- Remove explicit parentheses and reorder binary operator applications +-- Remove explicit parentheses and reorder binary operator applications. +-- +-- This pass requires name desugaring and export elaboration to have run first. -- rebracket :: forall m @@ -51,44 +68,45 @@ rebracket => [ExternsFile] -> [Module] -> m [Module] -rebracket externs ms = do - let (typeFixities, valueFixities) = partition isTypeFixity $ - concatMap externsFixities externs ++ concatMap collectFixities ms +rebracket externs modules = do + let (valueFixities, typeFixities) = + partitionEithers + $ concatMap externsFixities externs + ++ concatMap collectFixities modules - ensureNoDuplicates' $ valueFixities - ensureNoDuplicates' $ typeFixities + ensureNoDuplicates' MultipleValueOpFixities valueFixities + ensureNoDuplicates' MultipleTypeOpFixities typeFixities let valueOpTable = customOperatorTable' valueFixities - typeOpTable = customOperatorTable' typeFixities - ms' <- traverse (rebracketModule valueOpTable typeOpTable) ms + let valueAliased = M.fromList (map makeLookupEntry valueFixities) + let typeOpTable = customOperatorTable' typeFixities + let typeAliased = M.fromList (map makeLookupEntry typeFixities) - let valueAliased = M.fromList (mapMaybe makeLookupEntry valueFixities) - typeAliased = M.fromList (mapMaybe makeLookupEntry typeFixities) - mapM (renameAliasedOperators valueAliased typeAliased) ms' + for modules + $ renameAliasedOperators valueAliased typeAliased + <=< rebracketModule valueOpTable typeOpTable where - isTypeFixity :: FixityRecord -> Bool - -- Nothing case for FixityAlias can only ever be a value fixity, as it's not - -- possible to define types with operator names aside through aliasing. - -- TODO: This comment is redundant after 0.9. - isTypeFixity (_, _, _, Just (Qualified _ (AliasType _))) = True - isTypeFixity _ = False - - ensureNoDuplicates' :: [FixityRecord] -> m () - ensureNoDuplicates' = - ensureNoDuplicates . map (\(i, pos, _, _) -> (i, pos)) + ensureNoDuplicates' + :: Ord op + => (op -> SimpleErrorMessage) + -> [FixityRecord op alias] + -> m () + ensureNoDuplicates' toError = + ensureNoDuplicates toError . map (\(i, pos, _, _) -> (i, pos)) - customOperatorTable' :: [FixityRecord] -> [[(Qualified Ident, Associativity)]] - customOperatorTable' = - customOperatorTable . map (\(i, _, f, _) -> (i, f)) + customOperatorTable' + :: [FixityRecord op alias] + -> [[(Qualified op, Associativity)]] + customOperatorTable' = customOperatorTable . map (\(i, _, f, _) -> (i, f)) - makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, Qualified FixityAlias) - makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias + makeLookupEntry :: FixityRecord op alias -> (Qualified op, Qualified alias) + makeLookupEntry (qname, _, _, alias) = (qname, alias) renameAliasedOperators - :: M.Map (Qualified Ident) (Qualified FixityAlias) - -> M.Map (Qualified Ident) (Qualified FixityAlias) + :: M.Map (Qualified (OpName 'ValueOpName)) (Qualified (Either Ident (ProperName 'ConstructorName))) + -> M.Map (Qualified (OpName 'TypeOpName)) (Qualified (ProperName 'TypeName)) -> Module -> m Module renameAliasedOperators valueAliased typeAliased (Module ss coms mn ds exts) = @@ -110,52 +128,51 @@ rebracket externs ms = do goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) - goExpr pos (Var name) = return (pos, case name `M.lookup` valueAliased of - Just (Qualified mn' (AliasValue alias)) -> Var (Qualified mn' alias) - Just (Qualified mn' (AliasConstructor alias)) -> Constructor (Qualified mn' alias) - _ -> Var name) + goExpr pos (Op op) = + (pos, ) <$> case op `M.lookup` valueAliased of + Just (Qualified mn' (Left alias)) -> + return $ Var (Qualified mn' alias) + Just (Qualified mn' (Right alias)) -> + return $ Constructor (Qualified mn' alias) + Nothing -> + maybe id rethrowWithPosition pos $ + throwError . errorMessage . UnknownName $ fmap ValOpName op goExpr pos other = return (pos, other) goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b) - goBinder pos (BinaryNoParensBinder (OpBinder name) lhs rhs) = case name `M.lookup` valueAliased of - Just (Qualified _ (AliasValue alias)) -> - maybe id rethrowWithPosition pos $ - throwError . errorMessage $ InvalidOperatorInBinder (disqualify name) alias - Just (Qualified mn' (AliasConstructor alias)) -> - return (pos, ConstructorBinder (Qualified mn' alias) [lhs, rhs]) - _ -> - maybe id rethrowWithPosition pos $ - throwError . errorMessage $ UnknownValue name - goBinder _ (BinaryNoParensBinder {}) = + goBinder pos (BinaryNoParensBinder (OpBinder op) lhs rhs) = + case op `M.lookup` valueAliased of + Just (Qualified mn' (Left alias)) -> + maybe id rethrowWithPosition pos $ + throwError . errorMessage $ + InvalidOperatorInBinder op (Qualified mn' alias) + Just (Qualified mn' (Right alias)) -> + return (pos, ConstructorBinder (Qualified mn' alias) [lhs, rhs]) + Nothing -> + maybe id rethrowWithPosition pos $ + throwError . errorMessage . UnknownName $ fmap ValOpName op + goBinder _ BinaryNoParensBinder{} = internalError "BinaryNoParensBinder has no OpBinder" goBinder pos other = return (pos, other) goType :: Maybe SourceSpan -> Type -> m Type - goType pos = everywhereOnTypesM go + goType pos = maybe id rethrowWithPosition pos . everywhereOnTypesM go where go :: Type -> m Type - go (BinaryNoParensType (TypeOp name) lhs rhs) = case name `M.lookup` typeAliased of - Just (Qualified mn' (AliasType alias)) -> - return $ TypeApp (TypeApp (TypeConstructor (Qualified mn' alias)) lhs) rhs - _ -> - maybe id rethrowWithPosition pos $ - throwError . errorMessage $ UnknownTypeOp name + go (BinaryNoParensType (TypeOp op) lhs rhs) = + case op `M.lookup` typeAliased of + Just alias -> + return $ TypeApp (TypeApp (TypeConstructor alias) lhs) rhs + Nothing -> + throwError . errorMessage $ UnknownName $ fmap TyOpName op go other = return other -removeSignedLiterals :: Module -> Module -removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts - where - (f', _, _) = everywhereOnValues id go id - - go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val - go other = other - rebracketModule :: forall m . (MonadError MultipleErrors m) - => [[(Qualified Ident, Associativity)]] - -> [[(Qualified Ident, Associativity)]] + => [[(Qualified (OpName 'ValueOpName), Associativity)]] + -> [[(Qualified (OpName 'TypeOpName), Associativity)]] -> Module -> m Module rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) = @@ -167,7 +184,7 @@ rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) = (goExpr <=< decontextify goExpr') goBinder - (goDecl, goExpr') = updateTypes (\_ -> goType) + (goDecl, goExpr') = updateTypes (const goType) goExpr :: Expr -> m Expr goExpr = return . matchExprOperators valueOpTable @@ -210,40 +227,61 @@ removeParens = f -> a decontextify ctxf = snd . runIdentity . ctxf Nothing -externsFixities - :: ExternsFile - -> [FixityRecord] +externsFixities :: ExternsFile -> [Either ValueFixityRecord TypeFixityRecord] externsFixities ExternsFile{..} = - [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias) - | ExternsFixity assoc prec op alias <- efFixities - ] + map fromFixity efFixities ++ map fromTypeFixity efTypeFixities + where -collectFixities :: Module -> [FixityRecord] + fromFixity + :: ExternsFixity + -> Either ValueFixityRecord TypeFixityRecord + fromFixity (ExternsFixity assoc prec op name) = + Left + ( Qualified (Just efModuleName) op + , internalModuleSourceSpan "" + , Fixity assoc prec + , name + ) + + fromTypeFixity + :: ExternsTypeFixity + -> Either ValueFixityRecord TypeFixityRecord + fromTypeFixity (ExternsTypeFixity assoc prec op name) = + Right + ( Qualified (Just efModuleName) op + , internalModuleSourceSpan "" + , Fixity assoc prec + , name + ) + +collectFixities :: Module -> [Either ValueFixityRecord TypeFixityRecord] collectFixities (Module _ _ moduleName ds _) = concatMap collect ds where - collect :: Declaration -> [FixityRecord] - collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) = - [(Qualified (Just moduleName) (Op name), pos, fixity, alias)] + collect :: Declaration -> [Either ValueFixityRecord TypeFixityRecord] + collect (PositionedDeclaration pos _ (ValueFixityDeclaration fixity name op)) = + [Left (Qualified (Just moduleName) op, pos, fixity, name)] + collect (PositionedDeclaration pos _ (TypeFixityDeclaration fixity name op)) = + [Right (Qualified (Just moduleName) op, pos, fixity, name)] collect FixityDeclaration{} = internalError "Fixity without srcpos info" collect _ = [] ensureNoDuplicates - :: MonadError MultipleErrors m - => [(Qualified Ident, SourceSpan)] + :: (Ord a, MonadError MultipleErrors m) + => (a -> SimpleErrorMessage) + -> [(Qualified a, SourceSpan)] -> m () -ensureNoDuplicates m = go $ sortBy (compare `on` fst) m +ensureNoDuplicates toError m = go $ sortBy (compare `on` fst) m where go [] = return () go [_] = return () - go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y = + go ((x@(Qualified (Just mn) op), _) : (y, pos) : _) | x == y = rethrow (addHint (ErrorInModule mn)) $ - rethrowWithPosition pos $ - throwError . errorMessage $ MultipleFixities name + rethrowWithPosition pos $ throwError . errorMessage $ toError op go (_ : rest) = go rest customOperatorTable - :: [(Qualified Ident, Fixity)] - -> [[(Qualified Ident, Associativity)]] + :: [(Qualified op, Fixity)] + -> [[(Qualified op, Associativity)]] customOperatorTable fixities = let userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities @@ -300,3 +338,70 @@ updateTypes goType = (goDecl, goExpr) ty' <- goType' pos ty return (pos, TypedValue check v ty') goExpr pos other = return (pos, other) + +-- | +-- Checks all the fixity exports within a module to ensure that members aliased +-- by the operators are also exported from the module. +-- +-- This pass requires name desugaring and export elaboration to have run first. +-- +checkFixityExports + :: forall m + . MonadError MultipleErrors m + => Module + -> m Module +checkFixityExports (Module _ _ _ _ Nothing) = + internalError "exports should have been elaborated before checkFixityExports" +checkFixityExports m@(Module ss _ mn ds (Just exps)) = + rethrow (addHint (ErrorInModule mn)) + $ rethrowWithPosition ss (traverse_ checkRef exps) + *> return m + where + + checkRef :: DeclarationRef -> m () + checkRef (PositionedDeclarationRef pos _ d) = + rethrowWithPosition pos $ checkRef d + checkRef dr@(ValueOpRef op) = + for_ (getValueOpAlias op) $ \case + Left ident -> + unless (ValueRef ident `elem` exps) + . throwError . errorMessage + $ TransitiveExportError dr [ValueRef ident] + Right ctor -> + unless (anyTypeRef (maybe False (elem ctor) . snd)) + . throwError . errorMessage + $ TransitiveDctorExportError dr ctor + checkRef dr@(TypeOpRef op) = + for_ (getTypeOpAlias op) $ \ty -> + unless (anyTypeRef ((== ty) . fst)) + . throwError . errorMessage + $ TransitiveExportError dr [TypeRef ty Nothing] + checkRef _ = return () + + -- Finds the name associated with a type operator when that type is also + -- defined in the current module. + getTypeOpAlias :: OpName 'TypeOpName -> Maybe (ProperName 'TypeName) + getTypeOpAlias op = + listToMaybe (mapMaybe (either (const Nothing) go <=< getFixityDecl) ds) + where + go (TypeFixity _ (Qualified (Just mn') ident) op') + | mn == mn' && op == op' = Just ident + go _ = Nothing + + -- Finds the value or data constructor associated with an operator when that + -- declaration is also in the current module. + getValueOpAlias + :: OpName 'ValueOpName + -> Maybe (Either Ident (ProperName 'ConstructorName)) + getValueOpAlias op = + listToMaybe (mapMaybe (either go (const Nothing) <=< getFixityDecl) ds) + where + go (ValueFixity _ (Qualified (Just mn') ident) op') + | mn == mn' && op == op' = Just ident + go _ = Nothing + + -- Tests the exported `TypeRef` entries with a predicate. + anyTypeRef + :: ((ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) -> Bool) + -> Bool + anyTypeRef f = any (maybe False f . getTypeRef) exps diff --git a/src/Language/PureScript/Sugar/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs index 5b5a0b72b0..bdc0110d5e 100644 --- a/src/Language/PureScript/Sugar/Operators/Binders.hs +++ b/src/Language/PureScript/Sugar/Operators/Binders.hs @@ -6,7 +6,7 @@ import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Sugar.Operators.Common -matchBinderOperators :: [[(Qualified Ident, Associativity)]] -> Binder -> Binder +matchBinderOperators :: [[(Qualified (OpName 'ValueOpName), Associativity)]] -> Binder -> Binder matchBinderOperators = matchOperators isBinOp extractOp fromOp reapply id where @@ -18,9 +18,9 @@ matchBinderOperators = matchOperators isBinOp extractOp fromOp reapply id extractOp (BinaryNoParensBinder op l r) = Just (op, l, r) extractOp _ = Nothing - fromOp :: Binder -> Maybe (Qualified Ident) - fromOp (OpBinder q@(Qualified _ (Op _))) = Just q + fromOp :: Binder -> Maybe (Qualified (OpName 'ValueOpName)) + fromOp (OpBinder q@(Qualified _ (OpName _))) = Just q fromOp _ = Nothing - reapply :: Qualified Ident -> Binder -> Binder -> Binder + reapply :: Qualified (OpName 'ValueOpName) -> Binder -> Binder -> Binder reapply = BinaryNoParensBinder . OpBinder diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index 1e57dff79a..26ac5aef6b 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -28,36 +28,36 @@ parseValue :: P.Parsec (Chain a) () a parseValue = token (either Just (const Nothing)) P. "expression" parseOp - :: (a -> (Maybe (Qualified Ident))) - -> P.Parsec (Chain a) () (Qualified Ident) + :: (a -> (Maybe (Qualified (OpName nameType)))) + -> P.Parsec (Chain a) () (Qualified (OpName nameType)) parseOp fromOp = token (either (const Nothing) fromOp) P. "operator" matchOp - :: (a -> (Maybe (Qualified Ident))) - -> Qualified Ident + :: (a -> (Maybe (Qualified (OpName nameType)))) + -> Qualified (OpName nameType) -> P.Parsec (Chain a) () () matchOp fromOp op = do ident <- parseOp fromOp guard $ ident == op opTable - :: [[(Qualified Ident, Associativity)]] - -> (a -> Maybe (Qualified Ident)) - -> (Qualified Ident -> a -> a -> a) + :: [[(Qualified (OpName nameType), Associativity)]] + -> (a -> Maybe (Qualified (OpName nameType))) + -> (Qualified (OpName nameType) -> a -> a -> a) -> [[P.Operator (Chain a) () Identity a]] opTable ops fromOp reapply = map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >> return (reapply name)) (toAssoc a))) ops ++ [[ P.Infix (P.try (parseOp fromOp >>= \ident -> return (reapply ident))) P.AssocLeft ]] matchOperators - :: forall a + :: forall a nameType . Show a => (a -> Bool) -> (a -> Maybe (a, a, a)) - -> (a -> Maybe (Qualified Ident)) - -> (Qualified Ident -> a -> a -> a) + -> (a -> Maybe (Qualified (OpName nameType))) + -> (Qualified (OpName nameType) -> a -> a -> a) -> ([[P.Operator (Chain a) () Identity a]] -> P.OperatorTable (Chain a) () Identity a) - -> [[(Qualified Ident, Associativity)]] + -> [[(Qualified (OpName nameType), Associativity)]] -> a -> a matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index 32dd30da31..f938406820 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -11,7 +11,7 @@ import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Sugar.Operators.Common -matchExprOperators :: [[(Qualified Ident, Associativity)]] -> Expr -> Expr +matchExprOperators :: [[(Qualified (OpName 'ValueOpName), Associativity)]] -> Expr -> Expr matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable where @@ -23,12 +23,12 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable extractOp (BinaryNoParens op l r) = Just (op, l, r) extractOp _ = Nothing - fromOp :: Expr -> Maybe (Qualified Ident) - fromOp (Var q@(Qualified _ (Op _))) = Just q + fromOp :: Expr -> Maybe (Qualified (OpName 'ValueOpName)) + fromOp (Op q@(Qualified _ (OpName _))) = Just q fromOp _ = Nothing - reapply :: Qualified Ident -> Expr -> Expr -> Expr - reapply op t1 t2 = App (App (Var op) t1) t2 + reapply :: Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr + reapply op t1 t2 = App (App (Op op) t1) t2 modOpTable :: [[P.Operator (Chain Expr) () Identity Expr]] @@ -40,5 +40,5 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable parseTicks :: P.Parsec (Chain Expr) () Expr parseTicks = token (either (const Nothing) fromOther) P. "infix function" where - fromOther (Var (Qualified _ (Op _))) = Nothing + fromOther (Op _) = Nothing fromOther v = Just v diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs index f204b88bf9..f70ecf2d36 100644 --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -7,7 +7,7 @@ import Language.PureScript.Names import Language.PureScript.Sugar.Operators.Common import Language.PureScript.Types -matchTypeOperators :: [[(Qualified Ident, Associativity)]] -> Type -> Type +matchTypeOperators :: [[(Qualified (OpName 'TypeOpName), Associativity)]] -> Type -> Type matchTypeOperators = matchOperators isBinOp extractOp fromOp reapply id where @@ -19,9 +19,9 @@ matchTypeOperators = matchOperators isBinOp extractOp fromOp reapply id extractOp (BinaryNoParensType op l r) = Just (op, l, r) extractOp _ = Nothing - fromOp :: Type -> Maybe (Qualified Ident) - fromOp (TypeOp q@(Qualified _ (Op _))) = Just q + fromOp :: Type -> Maybe (Qualified (OpName 'TypeOpName)) + fromOp (TypeOp q@(Qualified _ (OpName _))) = Just q fromOp _ = Nothing - reapply :: Qualified Ident -> Type -> Type -> Type + reapply :: Qualified (OpName 'TypeOpName) -> Type -> Type -> Type reapply = BinaryNoParensType . TypeOp diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index c301682fc8..44ff0d10c1 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -269,7 +269,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = -- Lookup the type arguments and member types for the type class (args, implies, tyDecls) <- - maybe (throwError . errorMessage $ UnknownTypeClass className) return $ + maybe (throwError . errorMessage . UnknownName $ fmap TyClassName className) return $ M.lookup (qualify mn className) m case mapMaybe declName tyDecls \\ mapMaybe declName decls of diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 66ffc63e36..5c5e2b3117 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -8,7 +8,6 @@ module Language.PureScript.Sugar.TypeDeclarations import Prelude.Compat -import Control.Monad (forM) import Control.Monad.Error.Class (MonadError(..)) import Language.PureScript.AST @@ -20,38 +19,45 @@ import Language.PureScript.Traversals -- | -- Replace all top level type declarations in a module with type annotations -- -desugarTypeDeclarationsModule :: forall m. (MonadError MultipleErrors m) => [Module] -> m [Module] -desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) -> +desugarTypeDeclarationsModule + :: forall m + . MonadError MultipleErrors m + => Module + -> m Module +desugarTypeDeclarationsModule (Module ss coms name ds exps) = rethrow (addHint (ErrorInModule name)) $ Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps where desugarTypeDeclarations :: [Declaration] -> m [Declaration] - desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do - (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds) - return (PositionedDeclaration pos com d' : ds') - desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do + desugarTypeDeclarations (PositionedDeclaration pos com d : rest) = do + (d' : rest') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : rest) + return (PositionedDeclaration pos com d' : rest') + desugarTypeDeclarations (TypeDeclaration name' ty : d : rest) = do (_, nameKind, val) <- fromValueDeclaration d - desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest) + desugarTypeDeclarations (ValueDeclaration name' nameKind [] (Right (TypedValue True val ty)) : rest) where fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr) - fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val) + fromValueDeclaration (ValueDeclaration name'' nameKind [] (Right val)) + | name' == name'' = return (name'', nameKind, val) fromValueDeclaration (PositionedDeclaration pos com d') = do (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d' return (ident, nameKind, PositionedValue pos com val) - fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name - desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name - desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do + fromValueDeclaration _ = + throwError . errorMessage $ OrphanTypeDeclaration name' + desugarTypeDeclarations [TypeDeclaration name' _] = + throwError . errorMessage $ OrphanTypeDeclaration name' + desugarTypeDeclarations (ValueDeclaration name' nameKind bs val : rest) = do let (_, f, _) = everywhereOnValuesTopDownM return go return f' (Left gs) = Left <$> mapM (pairM return f) gs f' (Right v) = Right <$> f v - (:) <$> (ValueDeclaration name nameKind bs <$> f' val) + (:) <$> (ValueDeclaration name' nameKind bs <$> f' val) <*> desugarTypeDeclarations rest where - go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val' + go (Let ds' val') = Let <$> desugarTypeDeclarations ds' <*> pure val' go other = return other - desugarTypeDeclarations (TypeInstanceDeclaration nm deps cls args (ExplicitInstance ds) : rest) = - (:) <$> (TypeInstanceDeclaration nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds) + desugarTypeDeclarations (TypeInstanceDeclaration nm deps cls args (ExplicitInstance ds') : rest) = + (:) <$> (TypeInstanceDeclaration nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds') <*> desugarTypeDeclarations rest - desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds + desugarTypeDeclarations (d:rest) = (:) d <$> desugarTypeDeclarations rest desugarTypeDeclarations [] = return [] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 8c910f280e..57a203de01 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -183,7 +183,7 @@ typeCheckAll -> [DeclarationRef] -> [Declaration] -> m [Declaration] -typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds +typeCheckAll moduleName _ = traverse go where go :: Declaration -> m Declaration go (DataDeclaration dtype name args dctors) = do @@ -223,7 +223,8 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds let args' = args `withKinds` kind addTypeSynonym moduleName name args' ty kind return $ TypeSynonymDeclaration name args ty - go TypeDeclaration{} = internalError "Type declarations should have been removed" + go TypeDeclaration{} = + internalError "Type declarations should have been removed before typeCheckAlld" go (ValueDeclaration name nameKind [] (Right val)) = do env <- getEnv warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do @@ -261,9 +262,9 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds Just _ -> throwError . errorMessage $ RedefinedIdent name Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) }) return d - go (d@FixityDeclaration{}) = return d - go (d@ImportDeclaration{}) = return d - go (d@(TypeClassDeclaration pn args implies tys)) = do + go d@FixityDeclaration{} = return d + go d@ImportDeclaration{} = return d + go d@(TypeClassDeclaration pn args implies tys) = do addTypeClass moduleName pn args implies tys return d go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do @@ -277,23 +278,6 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds go (PositionedDeclaration pos com d) = warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d - checkFixities :: Declaration -> m () - checkFixities (FixityDeclaration _ name (Just (Qualified mn' (AliasValue ident)))) = do - ty <- lookupVariable moduleName (Qualified mn' ident) - addValue moduleName (Op name) ty Public - checkFixities (FixityDeclaration _ name (Just (Qualified mn' (AliasConstructor ctor)))) = do - env <- getEnv - let alias = Qualified mn' ctor - case M.lookup alias (dataConstructors env) of - Nothing -> throwError . errorMessage $ UnknownDataConstructor alias Nothing - Just (_, _, ty, _) -> addValue moduleName (Op name) ty Public - checkFixities (FixityDeclaration _ name Nothing) = do - env <- getEnv - guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env - checkFixities (PositionedDeclaration pos _ d) = - warnAndRethrowWithPosition pos $ checkFixities d - checkFixities _ = return () - checkInstanceMembers :: [Declaration] -> m [Declaration] checkInstanceMembers instDecls = do let idents = sort . map head . group . map memberName $ instDecls @@ -348,16 +332,17 @@ typeCheckModule . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> m Module -typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated" -typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do - modify (\s -> s { checkCurrentModule = Just mn }) - decls' <- typeCheckAll mn exps decls - for_ exps $ \e -> do - checkTypesAreExported e - checkClassMembersAreExported e - checkClassesAreExported e - checkNonAliasesAreExported (exportedDataConstructors exps) e - return $ Module ss coms mn decls' (Just exps) +typeCheckModule (Module _ _ _ _ Nothing) = + internalError "exports should have been elaborated before typeCheckModule" +typeCheckModule (Module ss coms mn decls (Just exps)) = + warnAndRethrow (addHint (ErrorInModule mn)) $ do + modify (\s -> s { checkCurrentModule = Just mn }) + decls' <- typeCheckAll mn exps decls + for_ exps $ \e -> do + checkTypesAreExported e + checkClassMembersAreExported e + checkClassesAreExported e + return $ Module ss coms mn decls' (Just exps) where checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m () @@ -436,38 +421,3 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint extractMemberName (TypeDeclaration memberName _) = memberName extractMemberName _ = internalError "Unexpected declaration in typeclass member list" checkClassMembersAreExported _ = return () - - checkNonAliasesAreExported :: [ProperName 'ConstructorName] -> DeclarationRef -> m () - checkNonAliasesAreExported exportedDctors dr@(ValueRef (Op name)) = - case listToMaybe (mapMaybe (getAlias getValueAlias name) decls) of - Just (Left ident) -> - unless (ValueRef ident `elem` exps) $ - throwError . errorMessage $ TransitiveExportError dr [ValueRef ident] - Just (Right ctor) -> - unless (ctor `elem` exportedDctors) $ - throwError . errorMessage $ TransitiveDctorExportError dr ctor - _ -> return () - checkNonAliasesAreExported _ dr@(TypeOpRef (Op name)) = - case listToMaybe (mapMaybe (getAlias getTypeAlias name) decls) of - Just ty -> - unless (any (isTypeRefFor ty) exps) $ - throwError . errorMessage $ TransitiveExportError dr [TypeRef ty Nothing] - _ -> return () - where - isTypeRefFor :: ProperName 'TypeName -> DeclarationRef -> Bool - isTypeRefFor ty (TypeRef ty' _) = ty == ty' - isTypeRefFor _ _ = False - checkNonAliasesAreExported _ _ = return () - - getAlias :: (FixityAlias -> Maybe a) -> String -> Declaration -> Maybe a - getAlias match name (PositionedDeclaration _ _ d) = getAlias match name d - getAlias match name (FixityDeclaration _ name' (Just (Qualified (Just mn') a))) - | Just alias <- match a, name == name' && mn == mn' = Just alias - getAlias _ _ _ = Nothing - - exportedDataConstructors :: [DeclarationRef] -> [ProperName 'ConstructorName] - exportedDataConstructors = foldMap extractCtor - where - extractCtor :: DeclarationRef -> [ProperName 'ConstructorName] - extractCtor (TypeRef _ (Just ctors)) = ctors - extractCtor _ = [] diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 6522ff944c..09b37468af 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -239,7 +239,7 @@ infer' other = (, []) <$> go other go (TypeConstructor v) = do env <- getEnv case M.lookup v (types env) of - Nothing -> throwError . errorMessage $ UnknownTypeConstructor v + Nothing -> throwError . errorMessage . UnknownName $ fmap TyName v Just (kind, _) -> return kind go (TypeApp t1 t2) = do k0 <- freshKind diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index a676e4cfa7..7d1a2a273b 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -293,7 +293,7 @@ infer' (Var var) = do infer' v@(Constructor c) = do env <- getEnv case M.lookup c (dataConstructors env) of - Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing + Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty return $ TypedValue True v' ty' infer' (Case vals binders) = do @@ -391,7 +391,7 @@ inferBinder val (ConstructorBinder ctor binders) = do unless (length args == length binders) . throwError . errorMessage $ IncorrectConstructorArity ctor unifyTypes ret val M.unions <$> zipWithM inferBinder (reverse args) binders - _ -> throwError . errorMessage $ UnknownDataConstructor ctor Nothing + _ -> throwError . errorMessage . UnknownName . fmap DctorName $ ctor where peelArgs :: Type -> ([Type], Type) peelArgs = go [] @@ -640,7 +640,7 @@ check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop check' v@(Constructor c) ty = do env <- getEnv case M.lookup c (dataConstructors env) of - Nothing -> throwError . errorMessage $ UnknownDataConstructor c Nothing + Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c Just (_, _, ty1, _) -> do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 mv <- subsumes (Just v) repl ty diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 7c1e378a0c..b638b882d4 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -49,7 +49,7 @@ data Type -- A type operator. This will be desugared into a type constructor during the -- "operators" phase of desugaring. -- - | TypeOp (Qualified Ident) + | TypeOp (Qualified (OpName 'TypeOpName)) -- | -- A type application -- @@ -78,7 +78,6 @@ data Type -- A type with a kind annotation -- | KindedType Type Kind - -- -- | -- A placeholder used in pretty printing -- diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs index 6ccccb3f30..4d4c75f622 100644 --- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs +++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs @@ -16,7 +16,7 @@ setup = do Integration.deleteOutputFolder s <- Integration.compileTestProject unless s $ fail "Failed to compile .purs sources" - Integration.quitServer -- kill a eventually running psc-ide-server instance + -- Integration.quitServer -- kill a eventually running psc-ide-server instance _ <- Integration.startServer mapM_ Integration.loadModuleWithDeps ["ImportsSpec", "ImportsSpec1"] diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 88825aa0bc..48033fa38c 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -69,6 +69,8 @@ spec = do let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i addValueImport i mn is = prettyPrintImportSection (addExplicitImport' (ValueDeclaration i wildcard) mn is) + addOpImport op mn is = + prettyPrintImportSection (addExplicitImport' (FixityDeclaration op) mn is) addDtorImport i t mn is = prettyPrintImportSection (addExplicitImport' (DataConstructor i t wildcard) mn is) it "adds an implicit unqualified import" $ @@ -96,7 +98,7 @@ spec = do ] it "adds an operator to an explicit import list" $ shouldBe - (addValueImport "<~>" (P.moduleNameFromString "Data.Array") explicitImports) + (addOpImport (Left (P.OpName "<~>")) (P.moduleNameFromString "Data.Array") explicitImports) [ "import Prelude" , "import Data.Array ((<~>), tail)" ] diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index c0d49317b7..df3707062a 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -270,11 +270,6 @@ testCases = , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member" ]) - -- Remove this after 0.9. - , ("OldOperators", - [ ShouldBeDocumented (n "OldOperators2") "(>>)" [] - ]) - , ("NewOperators", [ ShouldBeDocumented (n "NewOperators2") "(>>>)" [] ]) From f7114e3119c161ffa421b73badb9b752f0d2117a Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 11 May 2016 11:44:09 -0700 Subject: [PATCH 0409/1580] Speed up tests (#2110) --- psci/PSCi.hs | 16 ++++---- src/Language/PureScript.hs | 1 + src/Language/PureScript/Ide/Externs.hs | 45 +++++++++++----------- src/Language/PureScript/Ide/Rebuild.hs | 3 +- src/Language/PureScript/Make.hs | 9 +++-- tests/TestCompiler.hs | 53 +++++++++++++++++--------- 6 files changed, 73 insertions(+), 54 deletions(-) diff --git a/psci/PSCi.hs b/psci/PSCi.hs index f77a367902..7f747005d0 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -13,7 +13,7 @@ import Prelude () import Prelude.Compat import Data.Foldable (traverse_) -import Data.List (intercalate, nub, sort, find) +import Data.List (intercalate, nub, sort, find, foldl') import Data.Tuple (swap) import qualified Data.Map as M @@ -127,13 +127,15 @@ makeIO f io = do either (throwError . P.singleError . f) return e make :: PSCiState -> [P.Module] -> P.Make P.Environment -make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms) +make st@PSCiState{..} ms = do + externs <- P.make actions' (map snd loadedModules ++ ms) + return $ foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs where - filePathMap = M.fromList $ (first P.getModuleName . swap) `map` allModules - actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False - actions' = actions { P.progress = const (return ()) } - loadedModules = psciLoadedModules st - allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms + filePathMap = M.fromList $ (first P.getModuleName . swap) `map` allModules + actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False + actions' = actions { P.progress = const (return ()) } + loadedModules = psciLoadedModules st + allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms -- Commands diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index 311cb80ac3..a2c7554c2a 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -16,6 +16,7 @@ import Language.PureScript.Comments as P import Language.PureScript.Crash as P import Language.PureScript.Environment as P import Language.PureScript.Errors as P hiding (indent) +import Language.PureScript.Externs as P import Language.PureScript.Kinds as P import Language.PureScript.Linter as P import Language.PureScript.Make as P diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 710606a950..0c0edc0c61 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -41,10 +41,9 @@ import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import qualified Language.PureScript as P -import qualified Language.PureScript.Externs as PE readExternFile :: (MonadIO m, MonadError PscIdeError m) => - FilePath -> m PE.ExternsFile + FilePath -> m P.ExternsFile readExternFile fp = do parseResult <- liftIO (decodeStrict <$> BS.readFile fp) case parseResult of @@ -57,15 +56,15 @@ moduleNameToText = T.pack . P.runModuleName identToText :: P.Ident -> Text identToText = T.pack . P.runIdent -convertExterns :: PE.ExternsFile -> Module +convertExterns :: P.ExternsFile -> Module convertExterns ef = (moduleName, exportDecls ++ importDecls ++ decls ++ operatorDecls ++ tyOperatorDecls) where - moduleName = moduleNameToText (PE.efModuleName ef) - importDecls = convertImport <$> PE.efImports ef - exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (PE.efExports ef) - operatorDecls = convertOperator <$> PE.efFixities ef - tyOperatorDecls = convertTypeOperator <$> PE.efTypeFixities ef - otherDecls = mapMaybe convertDecl (PE.efDeclarations ef) + moduleName = moduleNameToText (P.efModuleName ef) + importDecls = convertImport <$> P.efImports ef + exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (P.efExports ef) + operatorDecls = convertOperator <$> P.efFixities ef + tyOperatorDecls = convertTypeOperator <$> P.efTypeFixities ef + otherDecls = mapMaybe convertDecl (P.efDeclarations ef) typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration otherDecls) decls = nub $ appEndo typeClassFilter otherDecls @@ -81,33 +80,33 @@ isTypeClassDeclaration :: ExternDecl -> Bool isTypeClassDeclaration TypeClassDeclaration{} = True isTypeClassDeclaration _ = False -convertImport :: PE.ExternsImport -> ExternDecl +convertImport :: P.ExternsImport -> ExternDecl convertImport ei = Dependency - (moduleNameToText (PE.eiModule ei)) + (moduleNameToText (P.eiModule ei)) [] - (moduleNameToText <$> PE.eiImportedAs ei) + (moduleNameToText <$> P.eiImportedAs ei) convertExport :: P.DeclarationRef -> Maybe ExternDecl convertExport (P.ModuleRef mn) = Just (Export (moduleNameToText mn)) convertExport _ = Nothing -convertDecl :: PE.ExternsDeclaration -> Maybe ExternDecl -convertDecl PE.EDType{..} = Just $ TypeDeclaration edTypeName edTypeKind -convertDecl PE.EDTypeSynonym{..} = Just $ +convertDecl :: P.ExternsDeclaration -> Maybe ExternDecl +convertDecl P.EDType{..} = Just $ TypeDeclaration edTypeName edTypeKind +convertDecl P.EDTypeSynonym{..} = Just $ TypeSynonymDeclaration edTypeSynonymName edTypeSynonymType -convertDecl PE.EDDataConstructor{..} = Just $ +convertDecl P.EDDataConstructor{..} = Just $ DataConstructor (runProperNameT edDataCtorName) edDataCtorTypeCtor edDataCtorType -convertDecl PE.EDValue{..} = Just $ +convertDecl P.EDValue{..} = Just $ ValueDeclaration (identToText edValueName) edValueType -convertDecl PE.EDClass{..} = Just $ TypeClassDeclaration edClassName -convertDecl PE.EDInstance{} = Nothing +convertDecl P.EDClass{..} = Just $ TypeClassDeclaration edClassName +convertDecl P.EDInstance{} = Nothing -convertOperator :: PE.ExternsFixity -> ExternDecl -convertOperator PE.ExternsFixity{..} = +convertOperator :: P.ExternsFixity -> ExternDecl +convertOperator P.ExternsFixity{..} = FixityDeclaration (Left efOperator) -convertTypeOperator :: PE.ExternsTypeFixity -> ExternDecl -convertTypeOperator PE.ExternsTypeFixity{..} = +convertTypeOperator :: P.ExternsTypeFixity -> ExternDecl +convertTypeOperator P.ExternsTypeFixity{..} = FixityDeclaration (Right efTypeOperator) unwrapPositioned :: P.Declaration -> P.Declaration diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index e089cb8b7b..fbe6beb910 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -19,7 +19,6 @@ import Data.Maybe (fromJust, mapMaybe) import qualified Data.Set as S import qualified Language.PureScript as P import Language.PureScript.Errors.JSON -import qualified Language.PureScript.Externs as P import System.FilePath (replaceExtension) import System.Directory (doesFileExist) import System.IO.UTF8 (readUTF8File) @@ -54,7 +53,7 @@ rebuildFile path = do (result, warnings) <- liftIO . P.runMake P.defaultOptions . P.rebuildModule (ma { P.progress = const (pure ()) }) externs - $ P.addDefaultImport (P.ModuleName [P.ProperName "Prim"]) m + $ m case result of Left errors -> throwError . RebuildError $ toJSONErrors False P.Error errors Right _ -> pure . RebuildSuccess $ toJSONErrors False P.Warning warnings diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 25e7b35870..1eef9da9ed 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -146,9 +146,10 @@ rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do progress $ CompilingModule moduleName let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs - lint m + withPrim = importPrim m + lint withPrim ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do - [desugared] <- desugar externs [m] + [desugared] <- desugar externs [withPrim] runCheck' env $ typeCheckModule desugared regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated let mod' = Module ss coms moduleName regrouped exps @@ -167,7 +168,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [Module] - -> m Environment + -> m [ExternsFile] make ma@MakeActions{..} ms = do checkModuleNamesAreUnique @@ -187,7 +188,7 @@ make ma@MakeActions{..} ms = do -- Bundle up all the externs and return them as an Environment (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd) - return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs + return externs where checkModuleNamesAreUnique :: m () diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 25740b3c47..fc82239c6e 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -57,7 +57,7 @@ main = hspec spec spec :: Spec spec = do - (supportPurs, supportForeigns, passingTestCases, failingTestCases) <- runIO $ do + (supportExterns, supportForeigns, passingTestCases, failingTestCases) <- runIO $ do cwd <- getCurrentDirectory let passing = cwd "examples" "passing" let failing = cwd "examples" "failing" @@ -67,13 +67,20 @@ spec = do failingFiles <- getTestFiles failing <$> testGlob failing supportPurs <- supportFiles "purs" supportForeigns <- loadForeigns =<< supportFiles "js" - return (supportPurs, supportForeigns, passingFiles, failingFiles) + supportPursFiles <- readInput supportPurs + supportExterns <- runExceptT $ do + modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles + externs <- ExceptT . runTest $ P.make (makeActions supportForeigns) (map snd modules) + return (zip (map snd modules) externs) + case supportExterns of + Left errs -> fail (P.prettyPrintMultipleErrors False errs) + Right externs -> return (externs, supportForeigns, passingFiles, failingFiles) context ("Passing examples") $ do forM_ passingTestCases $ \(testPurs, testJS) -> it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ do testForeigns <- loadForeigns testJS - assertCompiles (supportPurs ++ testPurs) (supportForeigns <> testForeigns) + assertCompiles supportExterns testPurs (supportForeigns <> testForeigns) context ("Failing examples") $ do forM_ failingTestCases $ \(testPurs, testJS) -> do @@ -81,7 +88,7 @@ spec = do expectedFailures <- runIO $ getShouldFailWith mainPath it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do testForeigns <- loadForeigns testJS - assertDoesNotCompile (supportPurs ++ testPurs) (supportForeigns <> testForeigns) expectedFailures + assertDoesNotCompile supportExterns testPurs (supportForeigns <> testForeigns) expectedFailures where @@ -166,27 +173,36 @@ runTest :: P.Make a -> IO (Either P.MultipleErrors a) runTest = fmap fst . P.runMake P.defaultOptions compile - :: [FilePath] + :: [(P.Module, P.ExternsFile)] + -> [FilePath] -> M.Map P.ModuleName FilePath - -> IO (Either P.MultipleErrors P.Environment) -compile inputFiles foreigns = silence $ runTest $ do + -> IO (Either P.MultipleErrors [P.ExternsFile]) +compile supportExterns inputFiles foreigns = silence $ runTest $ do fs <- liftIO $ readInput inputFiles ms <- P.parseModulesFromFiles id fs - P.make (makeActions foreigns) (map snd ms) + let actions = makeActions foreigns + case ms of + [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule) + _ -> P.make actions (map fst supportExterns ++ map snd ms) assert - :: [FilePath] + :: [(P.Module, P.ExternsFile)] + -> [FilePath] -> M.Map P.ModuleName FilePath - -> (Either P.MultipleErrors P.Environment -> IO (Maybe String)) + -> (Either P.MultipleErrors [P.ExternsFile] -> IO (Maybe String)) -> Expectation -assert inputFiles foreigns f = do - e <- compile inputFiles foreigns +assert supportExterns inputFiles foreigns f = do + e <- compile supportExterns inputFiles foreigns maybeErr <- f e maybe (return ()) expectationFailure maybeErr -assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> Expectation -assertCompiles inputFiles foreigns = do - assert inputFiles foreigns $ \e -> +assertCompiles + :: [(P.Module, P.ExternsFile)] + -> [FilePath] + -> M.Map P.ModuleName FilePath + -> Expectation +assertCompiles supportExterns inputFiles foreigns = do + assert supportExterns inputFiles foreigns $ \e -> case e of Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs Right _ -> do @@ -203,12 +219,13 @@ assertCompiles inputFiles foreigns = do Nothing -> return $ Just "Couldn't find node.js executable" assertDoesNotCompile - :: [FilePath] + :: [(P.Module, P.ExternsFile)] + -> [FilePath] -> M.Map P.ModuleName FilePath -> [String] -> Expectation -assertDoesNotCompile inputFiles foreigns shouldFailWith = do - assert inputFiles foreigns $ \e -> +assertDoesNotCompile supportExterns inputFiles foreigns shouldFailWith = do + assert supportExterns inputFiles foreigns $ \e -> case e of Left errs -> do return $ if null shouldFailWith From b5af366e027a2d0fa5d3348f476d422b7b5291a0 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Thu, 12 May 2016 21:50:36 +0200 Subject: [PATCH 0410/1580] [psc-ide] adds a reset command (#2112) * [psc-ide] adds a reset command * adds a --no-watch flag to psc-ide-server Specifying this flag will disable the file watcher * keep a single psc-ide process alive during the tests, and use the new reset command to clear loaded modules for the tests * compile the psc-ide support code once --- psc-ide-server/Main.hs | 37 ++++++++----------- psc-ide-server/PROTOCOL.md | 6 ++- psc-ide-server/README.md | 1 + src/Language/PureScript/Ide.hs | 1 + src/Language/PureScript/Ide/Command.hs | 2 + src/Language/PureScript/Ide/State.hs | 5 +++ .../PureScript/Ide/Imports/IntegrationSpec.hs | 13 ++----- tests/Language/PureScript/Ide/Integration.hs | 29 ++++++++++----- tests/Language/PureScript/Ide/MatcherSpec.hs | 24 ++++-------- tests/Language/PureScript/Ide/RebuildSpec.hs | 19 +--------- tests/TestPscIde.hs | 11 +++++- 11 files changed, 69 insertions(+), 79 deletions(-) diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 650f25eeed..e7fbdca2ec 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -72,12 +72,13 @@ data Options = Options { optionsDirectory :: Maybe FilePath , optionsOutputPath :: FilePath , optionsPort :: PortID + , optionsNoWatch :: Bool , optionsDebug :: Bool } main :: IO () main = do - Options dir outputPath port debug <- execParser opts + Options dir outputPath port noWatch debug <- execParser opts maybe (pure ()) setCurrentDirectory dir serverState <- newTVarIO emptyPscIdeState cwd <- getCurrentDirectory @@ -88,31 +89,23 @@ main = do (do putStrLn ("Your output directory didn't exist. I'll create it at: " <> fullOutputPath) createDirectory fullOutputPath putStrLn "This usually means you didn't compile your project yet." - putStrLn "psc-ide needs you to compile your project (for example by running pulp build)" - ) + putStrLn "psc-ide needs you to compile your project (for example by running pulp build)") - _ <- forkFinally (watcher serverState fullOutputPath) print - let conf = - Configuration - { - confDebug = debug - , confOutputPath = outputPath - } - let env = - PscIdeEnvironment - { - envStateVar = serverState - , envConfiguration = conf - } + unless noWatch $ + void (forkFinally (watcher serverState fullOutputPath) print) + + let conf = Configuration {confDebug = debug, confOutputPath = outputPath} + env = PscIdeEnvironment {envStateVar = serverState, envConfiguration = conf} startServer port env where parser = - Options <$> - optional (strOption (long "directory" <> short 'd')) <*> - strOption (long "output-directory" <> value "output/") <*> - (PortNumber . fromIntegral <$> - option auto (long "port" <> short 'p' <> value (4242 :: Integer))) <*> - switch (long "debug") + Options + <$> optional (strOption (long "directory" <> short 'd')) + <*> strOption (long "output-directory" <> value "output/") + <*> (PortNumber . fromIntegral <$> + option auto (long "port" <> short 'p' <> value (4242 :: Integer))) + <*> switch (long "no-watch") + <*> switch (long "debug") opts = info (version <*> helper <*> parser) mempty version = abortOption (InfoMsg (showVersion Paths.version)) diff --git a/psc-ide-server/PROTOCOL.md b/psc-ide-server/PROTOCOL.md index ca2bdc5d38..e62160f703 100644 --- a/psc-ide-server/PROTOCOL.md +++ b/psc-ide-server/PROTOCOL.md @@ -407,14 +407,16 @@ Hiding Import(`import Data.Array hiding (filter, filterM, join)`): } ] ``` -### Cwd/Quit +### Cwd/Quit/Reset `cwd` returns the working directory of the server(should be your project root). `quit` quits the server. +`reset` resets all loaded modules. + ```json { - "command": "cwd|quit" + "command": "cwd|quit|reset" } ``` diff --git a/psc-ide-server/README.md b/psc-ide-server/README.md index 4398a7c3fc..d907a17069 100644 --- a/psc-ide-server/README.md +++ b/psc-ide-server/README.md @@ -20,6 +20,7 @@ It supports the following options: project directory. Defaults to `output/`, relative to either the current directory or the directory specified by `-d`. - `--debug`: Enables some logging meant for debugging +- `--no-watch`: Disables the filewatcher - `--version`: Output psc-ide version ## Issuing queries diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 65d2e083eb..dc92ffbcc0 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -90,6 +90,7 @@ handleCommand (Rebuild file) = rebuildFile file handleCommand Cwd = TextResult . T.pack <$> liftIO getCurrentDirectory +handleCommand Reset = resetPscIdeState *> pure (TextResult "State has been reset.") handleCommand Quit = liftIO exitSuccess findCompletions :: (PscIde m, MonadLogger m) => diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 12d65427ef..4440563609 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -63,6 +63,7 @@ data Command | List { listType :: ListType } | Rebuild FilePath -- ^ Rebuild the specified file using the loaded externs | Cwd + | Reset | Quit data ImportCommand @@ -104,6 +105,7 @@ instance FromJSON Command where return $ List (fromMaybe LoadedModules listType') "cwd" -> return Cwd "quit" -> return Quit + "reset" -> pure Reset "load" -> maybe (pure (Load [] [])) (\params -> do mods <- params .:? "modules" diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index d4960ad1ee..ea63a8884c 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -35,6 +35,11 @@ import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.Types import Language.PureScript.Names +resetPscIdeState :: PscIde m => m () +resetPscIdeState = do + stateVar <- envStateVar <$> ask + liftIO $ atomically (writeTVar stateVar emptyPscIdeState) + getPscIdeState :: (PscIde m) => m (M.Map ModuleIdent [ExternDecl]) getPscIdeState = do diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs index 4d4c75f622..ef56ccb958 100644 --- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs +++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Imports.IntegrationSpec where -import Control.Monad +import Control.Monad (void) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as TIO @@ -13,16 +13,9 @@ import System.FilePath setup :: IO () setup = do - Integration.deleteOutputFolder - s <- Integration.compileTestProject - unless s $ fail "Failed to compile .purs sources" - -- Integration.quitServer -- kill a eventually running psc-ide-server instance - _ <- Integration.startServer + Integration.reset mapM_ Integration.loadModuleWithDeps ["ImportsSpec", "ImportsSpec1"] -teardown :: IO () -teardown = Integration.quitServer - withSupportFiles :: (FilePath -> FilePath -> IO a) -> IO () withSupportFiles test = do pdir <- Integration.projectDirectory @@ -38,7 +31,7 @@ outputFileShouldBe expectation = do shouldBe (T.lines outRes) expectation spec :: Spec -spec = beforeAll_ setup $ afterAll_ teardown $ describe "Adding imports" $ do +spec = beforeAll_ setup . describe "Adding imports" $ do let sourceFileSkeleton :: [Text] -> [Text] sourceFileSkeleton importSection = diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs index 81f0be6ee7..6a05a72fe3 100644 --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -27,29 +27,30 @@ module Language.PureScript.Ide.Integration , projectDirectory , deleteFileIfExists -- sending commands + , addImport + , addImplicitImport , loadModule , loadModuleWithDeps , getFlexCompletions , getType - , addImport - , addImplicitImport , rebuildModule + , reset -- checking results , resultIsSuccess , parseCompletions , parseTextResult ) where -import Control.Concurrent (threadDelay) +import Control.Concurrent (threadDelay) import Control.Exception -import Control.Monad (join, when) +import Control.Monad (join, when) import Data.Aeson import Data.Aeson.Types -import qualified Data.ByteString.Lazy.UTF8 as BSL -import Data.Either (isRight) -import Data.Maybe (fromJust) -import qualified Data.Text as T -import qualified Data.Vector as V +import qualified Data.ByteString.Lazy.UTF8 as BSL +import Data.Either (isRight) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import qualified Data.Vector as V import Language.PureScript.Ide.Util import System.Directory import System.Exit @@ -64,7 +65,9 @@ projectDirectory = do startServer :: IO ProcessHandle startServer = do pdir <- projectDirectory - (_, _, _, procHandle) <- createProcess $ (shell "psc-ide-server") {cwd=Just pdir} + -- Turn off filewatching since it creates race condition in a testing environment + (_, _, _, procHandle) <- createProcess $ + (shell "psc-ide-server --no-watch") {cwd = Just pdir} threadDelay 500000 -- give the server 500ms to start up return procHandle @@ -128,6 +131,12 @@ quitServer = do _ <- try $ sendCommand quitCommand :: IO (Either SomeException String) return () +reset :: IO () +reset = do + let resetCommand = object ["command" .= ("reset" :: String)] + _ <- try $ sendCommand resetCommand :: IO (Either SomeException String) + return () + loadModuleWithDeps :: String -> IO String loadModuleWithDeps m = sendCommand $ load [] [m] diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs index 1f579bed86..954ded1663 100644 --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -2,21 +2,22 @@ module Language.PureScript.Ide.MatcherSpec where +import Control.Monad (void) import Data.Text (Text) +import qualified Language.PureScript as P import Language.PureScript.Ide.Integration import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types -import qualified Language.PureScript as P import Test.Hspec value :: Text -> ExternDecl value s = ValueDeclaration s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) completions :: [Match] -completions = [ - Match "" $ value "firstResult", - Match "" $ value "secondResult", - Match "" $ value "fiult" +completions = + [ Match "" (value "firstResult") + , Match "" (value "secondResult") + , Match "" (value "fiult") ] mkResult :: [Int] -> [Match] @@ -26,15 +27,7 @@ runFlex :: Text -> [Match] runFlex s = runMatcher (flexMatcher s) completions setup :: IO () -setup = do - deleteOutputFolder - _ <- compileTestProject - _ <- startServer - _ <- loadModuleWithDeps "Main" - return () - -teardown :: IO () -teardown = quitServer +setup = reset *> void (loadModuleWithDeps "Main") spec :: Spec spec = do @@ -46,8 +39,7 @@ spec = do it "scores short matches higher and sorts accordingly" $ runFlex "filt" `shouldBe` mkResult [2, 0] - beforeAll_ setup $ afterAll_ teardown $ - describe "Integration Tests: Flex Matcher" $ do + beforeAll_ setup . describe "Integration Tests: Flex Matcher" $ do it "doesn't match on an empty string" $ do cs <- getFlexCompletions "" cs `shouldBe` [] diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index f7370afe3f..02cfa760bf 100644 --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -1,22 +1,8 @@ module Language.PureScript.Ide.RebuildSpec where -import Control.Monad import qualified Language.PureScript.Ide.Integration as Integration -import Test.Hspec - import System.FilePath - -compile :: IO () -compile = do - Integration.deleteOutputFolder - s <- Integration.compileTestProject - unless s $ fail "Failed to compile .purs sources" - -teardown :: IO () -teardown = Integration.quitServer - -restart :: IO () -restart = Integration.quitServer *> (void Integration.startServer) +import Test.Hspec shouldBeSuccess :: String -> IO () shouldBeSuccess = shouldBe True . Integration.resultIsSuccess @@ -25,8 +11,7 @@ shouldBeFailure :: String -> IO () shouldBeFailure = shouldBe False . Integration.resultIsSuccess spec :: Spec -spec = beforeAll_ compile $ afterAll_ teardown $ before_ restart $ do - describe "Rebuilding single modules" $ do +spec = before_ Integration.reset $ describe "Rebuilding single modules" $ do it "rebuilds a correct module without dependencies successfully" $ do _ <- Integration.loadModuleWithDeps "RebuildSpecSingleModule" pdir <- Integration.projectDirectory diff --git a/tests/TestPscIde.hs b/tests/TestPscIde.hs index 1a6e0722f5..d90b9d2642 100644 --- a/tests/TestPscIde.hs +++ b/tests/TestPscIde.hs @@ -1,7 +1,14 @@ module TestPscIde where +import Control.Monad (unless) +import Language.PureScript.Ide.Integration import qualified PscIdeSpec -import Test.Hspec +import Test.Hspec main :: IO () -main = hspec PscIdeSpec.spec +main = do + deleteOutputFolder + s <- compileTestProject + unless s $ fail "Failed to compile .purs sources" + + withServer (hspec PscIdeSpec.spec) From 50d9de01ddacc7691e87f57f8c16eae43faa084d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 12 May 2016 20:35:49 -0700 Subject: [PATCH 0411/1580] Fix #2055, desugar ParensInType inside typed binders --- examples/passing/ParensInTypedBinder.purs | 20 +++++++++++++++++ src/Language/PureScript/Sugar/Operators.hs | 26 ++++++++++++++-------- 2 files changed, 37 insertions(+), 9 deletions(-) create mode 100644 examples/passing/ParensInTypedBinder.purs diff --git a/examples/passing/ParensInTypedBinder.purs b/examples/passing/ParensInTypedBinder.purs new file mode 100644 index 0000000000..468f3ecc19 --- /dev/null +++ b/examples/passing/ParensInTypedBinder.purs @@ -0,0 +1,20 @@ +module Main where + +import Prelude +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) + +foo :: Array Int +foo = do + xss :: Array (Array Int) <- [[[1,2,3], [4, 5]], [[6]]] + xs :: Array Int <- xss + xs + +main :: + forall eff. + Eff + ( console :: CONSOLE + | eff + ) + Unit +main = log "Done" diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 312ac5844b..9f384559b4 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -112,13 +112,13 @@ rebracket externs modules = do renameAliasedOperators valueAliased typeAliased (Module ss coms mn ds exts) = Module ss coms mn <$> mapM f' ds <*> pure exts where - (goDecl', goExpr') = updateTypes goType + (goDecl', goExpr', goBinder') = updateTypes goType (f', _, _, _, _) = everywhereWithContextOnValuesM Nothing (\pos -> uncurry goDecl <=< goDecl' pos) (\pos -> uncurry goExpr <=< goExpr' pos) - goBinder + (\pos -> uncurry goBinder <=< goBinder' pos) defS defS @@ -182,9 +182,9 @@ rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) = everywhereOnValuesTopDownM (decontextify goDecl) (goExpr <=< decontextify goExpr') - goBinder + (goBinder <=< decontextify goBinder') - (goDecl, goExpr') = updateTypes (const goType) + (goDecl, goExpr', goBinder') = updateTypes (const goType) goExpr :: Expr -> m Expr goExpr = return . matchExprOperators valueOpTable @@ -205,9 +205,9 @@ removeParens = f everywhereOnValues (decontextify goDecl) (goExpr . decontextify goExpr') - goBinder + (goBinder . decontextify goBinder') - (goDecl, goExpr') = updateTypes (\_ -> return . goType) + (goDecl, goExpr', goBinder') = updateTypes (\_ -> return . goType) goExpr :: Expr -> Expr goExpr (Parens val) = val @@ -294,10 +294,11 @@ updateTypes :: forall m . Monad m => (Maybe SourceSpan -> Type -> m Type) - -> ( Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration) - , Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) + -> ( Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration) + , Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) + , Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) ) -updateTypes goType = (goDecl, goExpr) +updateTypes goType = (goDecl, goExpr, goBinder) where goType' :: Maybe SourceSpan -> Type -> m Type @@ -339,6 +340,13 @@ updateTypes goType = (goDecl, goExpr) return (pos, TypedValue check v ty') goExpr pos other = return (pos, other) + goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) + goBinder _ e@(PositionedBinder pos _ _) = return (Just pos, e) + goBinder pos (TypedBinder ty b) = do + ty' <- goType' pos ty + return (pos, TypedBinder ty' b) + goBinder pos other = return (pos, other) + -- | -- Checks all the fixity exports within a module to ensure that members aliased -- by the operators are also exported from the module. From c6d246534d9b25d82221d540da0dfa81faaec1a1 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 12 May 2016 22:42:16 +0100 Subject: [PATCH 0412/1580] Check that passing tests have a Main module --- .../passing/ExportedInstanceDeclarations.purs | 89 ++++++++++--------- tests/TestCompiler.hs | 25 ++++-- 2 files changed, 62 insertions(+), 52 deletions(-) diff --git a/examples/passing/ExportedInstanceDeclarations.purs b/examples/passing/ExportedInstanceDeclarations.purs index 782ecf2aa5..ee3dd922a9 100644 --- a/examples/passing/ExportedInstanceDeclarations.purs +++ b/examples/passing/ExportedInstanceDeclarations.purs @@ -1,44 +1,45 @@ --- Tests that instances for non-exported classes / types do not appear in the --- result of `exportedDeclarations`. -module ExportedInstanceDeclarations - ( Const(..) - , class Foo - , foo - ) where - -import Prelude -import Control.Monad.Eff.Console (log) - -data Const a b = Const a - -class Foo a where - foo :: a - -data NonexportedType = NonexportedType - -class NonexportedClass a where - notExported :: a - --- There are three places that a nonexported type or type class can occur, --- leading an instance to count as non-exported: --- * Constraints --- * The type class itself --- * The instance types - --- Case 1: constraints -instance nonExportedFoo :: (NonexportedClass a) => Foo a where - foo = notExported - --- Another instance of case 1: -instance nonExportedFoo2 :: (Foo NonexportedType) => Foo (a -> a) where - foo = id - --- Case 2: type class -instance nonExportedNonexportedType :: NonexportedClass (Const Int a) where - notExported = Const 0 - --- Case 3: instance types -instance constFoo :: Foo (Const NonexportedType b) where - foo = Const NonexportedType - -main = log "Done" +-- Tests that instances for non-exported classes / types do not appear in the +-- result of `exportedDeclarations`. +module Main + ( Const(..) + , class Foo + , foo + , main + ) where + +import Prelude +import Control.Monad.Eff.Console (log) + +data Const a b = Const a + +class Foo a where + foo :: a + +data NonexportedType = NonexportedType + +class NonexportedClass a where + notExported :: a + +-- There are three places that a nonexported type or type class can occur, +-- leading an instance to count as non-exported: +-- * Constraints +-- * The type class itself +-- * The instance types + +-- Case 1: constraints +instance nonExportedFoo :: (NonexportedClass a) => Foo a where + foo = notExported + +-- Another instance of case 1: +instance nonExportedFoo2 :: (Foo NonexportedType) => Foo (a -> a) where + foo = id + +-- Case 2: type class +instance nonExportedNonexportedType :: NonexportedClass (Const Int a) where + notExported = Const 0 + +-- Case 3: instance types +instance constFoo :: Foo (Const NonexportedType b) where + foo = Const NonexportedType + +main = log "Done" diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index fc82239c6e..3521b5866d 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -176,10 +176,12 @@ compile :: [(P.Module, P.ExternsFile)] -> [FilePath] -> M.Map P.ModuleName FilePath + -> ([P.Module] -> IO ()) -> IO (Either P.MultipleErrors [P.ExternsFile]) -compile supportExterns inputFiles foreigns = silence $ runTest $ do +compile supportExterns inputFiles foreigns check = silence $ runTest $ do fs <- liftIO $ readInput inputFiles ms <- P.parseModulesFromFiles id fs + liftIO (check (map snd ms)) let actions = makeActions foreigns case ms of [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule) @@ -189,10 +191,11 @@ assert :: [(P.Module, P.ExternsFile)] -> [FilePath] -> M.Map P.ModuleName FilePath + -> ([P.Module] -> IO ()) -> (Either P.MultipleErrors [P.ExternsFile] -> IO (Maybe String)) -> Expectation -assert supportExterns inputFiles foreigns f = do - e <- compile supportExterns inputFiles foreigns +assert supportExterns inputFiles foreigns check f = do + e <- compile supportExterns inputFiles foreigns check maybeErr <- f e maybe (return ()) expectationFailure maybeErr @@ -201,8 +204,8 @@ assertCompiles -> [FilePath] -> M.Map P.ModuleName FilePath -> Expectation -assertCompiles supportExterns inputFiles foreigns = do - assert supportExterns inputFiles foreigns $ \e -> +assertCompiles supportExterns inputFiles foreigns = + assert supportExterns inputFiles foreigns checkMain $ \e -> case e of Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs Right _ -> do @@ -217,6 +220,10 @@ assertCompiles supportExterns inputFiles foreigns = do | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out Just (ExitFailure _, _, err) -> return $ Just err Nothing -> return $ Just "Couldn't find node.js executable" + where + checkMain ms = + unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms) + (fail "Main module missing") assertDoesNotCompile :: [(P.Module, P.ExternsFile)] @@ -224,10 +231,10 @@ assertDoesNotCompile -> M.Map P.ModuleName FilePath -> [String] -> Expectation -assertDoesNotCompile supportExterns inputFiles foreigns shouldFailWith = do - assert supportExterns inputFiles foreigns $ \e -> +assertDoesNotCompile supportExterns inputFiles foreigns shouldFailWith = + assert supportExterns inputFiles foreigns noPreCheck $ \e -> case e of - Left errs -> do + Left errs -> return $ if null shouldFailWith then Just $ "shouldFailWith declaration is missing (errors were: " ++ show (map P.errorCode (P.runMultipleErrors errs)) @@ -237,6 +244,8 @@ assertDoesNotCompile supportExterns inputFiles foreigns shouldFailWith = do return $ Just "Should not have compiled" where + noPreCheck = const (return ()) + checkShouldFailWith expected errs = let actual = map P.errorCode $ P.runMultipleErrors errs in if sort expected == sort actual From 9e562663210e0bb798cf183a25fb84a142a7f17b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 13 May 2016 08:56:23 -0700 Subject: [PATCH 0413/1580] PSCi speed improvements and design changes (#2088) * WIP: faster PSCi * Make things work again. * Fix tests * tests/Main.hs -> tests/Test.hs * Speed up the test suite * Work in progress on moving PSCI modules into library * Fix tests * Use moduleNameFromString * Introduce PSCiConfig type, simplify tests slightly * PSCiOptions belongs in Main * Make the support module into its own package, fix #1441 * Fail fast when support module is missing --- psci/Main.hs | 144 +++++++ psci/PSCi.hs | 374 ------------------ psci/PSCi/Message.hs | 52 --- psci/PSCi/Option.hs | 57 --- psci/main/Main.hs | 6 - purescript.cabal | 245 +++++++----- src/Language/PureScript/Interactive.hs | 288 ++++++++++++++ .../PureScript/Interactive}/Completion.hs | 149 ++++--- .../PureScript/Interactive}/Directive.hs | 10 +- .../Language/PureScript/Interactive}/IO.hs | 21 +- .../PureScript/Interactive/Message.hs | 52 +++ .../PureScript/Interactive}/Module.hs | 48 +-- .../PureScript/Interactive}/Parser.hs | 22 +- .../PureScript/Interactive}/Printer.hs | 21 +- .../Language/PureScript/Interactive}/Types.hs | 114 ++---- src/Language/PureScript/Make.hs | 10 +- tests/TestPsci.hs | 32 +- 17 files changed, 788 insertions(+), 857 deletions(-) create mode 100644 psci/Main.hs delete mode 100644 psci/PSCi.hs delete mode 100644 psci/PSCi/Message.hs delete mode 100644 psci/PSCi/Option.hs delete mode 100644 psci/main/Main.hs create mode 100644 src/Language/PureScript/Interactive.hs rename {psci/PSCi => src/Language/PureScript/Interactive}/Completion.hs (70%) rename {psci/PSCi => src/Language/PureScript/Interactive}/Directive.hs (91%) rename {psci/PSCi => src/Language/PureScript/Interactive}/IO.hs (70%) create mode 100644 src/Language/PureScript/Interactive/Message.hs rename {psci/PSCi => src/Language/PureScript/Interactive}/Module.hs (70%) rename {psci/PSCi => src/Language/PureScript/Interactive}/Parser.hs (89%) rename {psci/PSCi => src/Language/PureScript/Interactive}/Printer.hs (91%) rename {psci/PSCi => src/Language/PureScript/Interactive}/Types.hs (52%) diff --git a/psci/Main.hs b/psci/Main.hs new file mode 100644 index 0000000000..4b48d55365 --- /dev/null +++ b/psci/Main.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Main (main) where + +import Prelude () +import Prelude.Compat + +import Data.Monoid ((<>)) +import Data.Version (showVersion) + +import Control.Applicative (many) +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) +import Control.Monad.Trans.State.Strict (StateT, evalStateT) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) + +import qualified Language.PureScript as P +import Language.PureScript.Interactive + +import qualified Options.Applicative as Opts + +import qualified Paths_purescript as Paths + +import System.Console.Haskeline +import System.Exit +import System.FilePath.Glob (glob) + +-- | Command line options +data PSCiOptions = PSCiOptions + { psciMultiLineMode :: Bool + , psciInputFile :: [FilePath] + , psciForeignInputFiles :: [FilePath] + , psciInputNodeFlags :: [String] + } + +multiLineMode :: Opts.Parser Bool +multiLineMode = Opts.switch $ + Opts.long "multi-line-mode" + <> Opts.short 'm' + <> Opts.help "Run in multi-line mode (use ^D to terminate commands)" + +inputFile :: Opts.Parser FilePath +inputFile = Opts.strArgument $ + Opts.metavar "FILE" + <> Opts.help "Optional .purs files to load on start" + +inputForeignFile :: Opts.Parser FilePath +inputForeignFile = Opts.strOption $ + Opts.short 'f' + <> Opts.long "ffi" + <> Opts.help "The input .js file(s) providing foreign import implementations" + +nodeFlagsFlag :: Opts.Parser [String] +nodeFlagsFlag = Opts.option parser $ + Opts.long "node-opts" + <> Opts.metavar "NODE_OPTS" + <> Opts.value [] + <> Opts.help "Flags to pass to node, separated by spaces" + where + parser = words <$> Opts.str + +psciOptions :: Opts.Parser PSCiOptions +psciOptions = PSCiOptions <$> multiLineMode + <*> many inputFile + <*> many inputForeignFile + <*> nodeFlagsFlag + +version :: Opts.Parser (a -> a) +version = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $ + Opts.long "version" <> + Opts.help "Show the version number" <> + Opts.hidden + +getOpt :: IO PSCiOptions +getOpt = Opts.execParser opts + where + opts = Opts.info (version <*> Opts.helper <*> psciOptions) infoModList + infoModList = Opts.fullDesc <> headerInfo <> footerInfo + headerInfo = Opts.header "psci - Interactive mode for PureScript" + footerInfo = Opts.footer $ "psci " ++ showVersion Paths.version + +-- | Parses the input and returns either a command, or an error as a 'String'. +getCommand :: forall m. MonadException m => Bool -> InputT m (Either String (Maybe Command)) +getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do + firstLine <- withInterrupt $ getInputLine "> " + case firstLine of + Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty + Just "" -> return (Right Nothing) + Just s | singleLineMode || head s == ':' -> return . fmap Just $ parseCommand s + Just s -> fmap Just . parseCommand <$> go [s] + where + go :: [String] -> InputT m String + go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " " + +-- | Get command line options and drop into the REPL +main :: IO () +main = getOpt >>= loop + where + loop :: PSCiOptions -> IO () + loop PSCiOptions{..} = do + inputFiles <- concat <$> traverse glob psciInputFile + foreignFiles <- concat <$> traverse glob psciForeignInputFiles + e <- runExceptT $ do + modules <- ExceptT (loadAllModules inputFiles) + unless (supportModuleIsDefined (map snd modules)) . liftIO $ do + putStrLn supportModuleMessage + exitFailure + foreigns <- ExceptT . runMake $ do + foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> P.readTextFile inFile) + P.parseForeignModulesFromFiles foreignFilesContent + (externs, env) <- ExceptT . runMake . make foreigns . map snd $ modules + return (modules, foreigns, externs, env) + case e of + Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure + Right (modules, foreigns, externs, env) -> do + historyFilename <- getHistoryFilename + let settings = defaultSettings { historyFile = Just historyFilename } + initialState = PSCiState [] [] (zip (map snd modules) externs) + config = PSCiConfig inputFiles foreigns psciInputNodeFlags env + runner = flip runReaderT config + . flip evalStateT initialState + . runInputT (setComplete completion settings) + putStrLn prologueMessage + runner go + where + go :: InputT (StateT PSCiState (ReaderT PSCiConfig IO)) () + go = do + c <- getCommand (not psciMultiLineMode) + case c of + Left err -> outputStrLn err >> go + Right Nothing -> go + Right (Just QuitPSCi) -> outputStrLn quitMessage + Right (Just c') -> do + handleInterrupt (outputStrLn "Interrupted.") + (withInterrupt (lift (handleCommand c'))) + go diff --git a/psci/PSCi.hs b/psci/PSCi.hs deleted file mode 100644 index 7f747005d0..0000000000 --- a/psci/PSCi.hs +++ /dev/null @@ -1,374 +0,0 @@ -{-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DataKinds #-} - --- | --- PureScript Compiler Interactive. --- -module PSCi (runPSCi) where - -import Prelude () -import Prelude.Compat - -import Data.Foldable (traverse_) -import Data.List (intercalate, nub, sort, find, foldl') -import Data.Tuple (swap) -import qualified Data.Map as M - -import Control.Arrow (first) -import Control.Monad -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except (ExceptT(), runExceptT) -import Control.Monad.Trans.State.Strict -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Writer.Strict (Writer(), runWriter) - -import System.Console.Haskeline -import System.Directory (doesFileExist, getHomeDirectory, getCurrentDirectory) -import System.Exit -import System.FilePath (()) -import System.FilePath.Glob (glob) -import System.Process (readProcessWithExitCode) -import System.IO.Error (tryIOError) -import System.IO.UTF8 (readUTF8File) - -import qualified Language.PureScript as P -import qualified Language.PureScript.Names as N - -import PSCi.Completion (completion) -import PSCi.Parser (parseCommand) -import PSCi.Option -import PSCi.Types -import PSCi.Message -import PSCi.IO -import PSCi.Printer -import PSCi.Module - --- | --- PSCI monad --- -newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad) - -psciIO :: IO a -> PSCI a -psciIO io = PSCI . lift $ lift io - --- | --- The runner --- -runPSCi :: IO () -runPSCi = getOpt >>= loop - --- | --- The PSCI main loop. --- -loop :: PSCiOptions -> IO () -loop PSCiOptions{..} = do - config <- loadUserConfig - inputFiles <- concat <$> traverse glob psciInputFile - foreignFiles <- concat <$> traverse glob psciForeignInputFiles - modulesOrFirstError <- loadAllModules inputFiles - case modulesOrFirstError of - Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure - Right modules -> do - historyFilename <- getHistoryFilename - let settings = defaultSettings { historyFile = Just historyFilename } - foreignsOrError <- runMake $ do - foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readUTF8File inFile)) - P.parseForeignModulesFromFiles foreignFilesContent - case foreignsOrError of - Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure - Right foreigns -> - flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do - outputStrLn prologueMessage - traverse_ (traverse_ (runPSCI . handleCommand)) config - modules' <- lift $ gets psciLoadedModules - unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines - [ "PSCi requires the purescript-console module to be installed." - , "For help getting started, visit http://wiki.purescript.org/PSCi" - ] - go - where - go :: InputT (StateT PSCiState IO) () - go = do - c <- getCommand (not psciMultiLineMode) - case c of - Left err -> outputStrLn err >> go - Right Nothing -> go - Right (Just QuitPSCi) -> outputStrLn quitMessage - Right (Just c') -> do - handleInterrupt (outputStrLn "Interrupted.") - (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c'))) - go - --- Compile the module - --- | --- Load all modules, updating the application state --- -loadAllImportedModules :: PSCI () -loadAllImportedModules = do - files <- PSCI . lift $ fmap psciImportedFilenames get - modulesOrFirstError <- psciIO $ loadAllModules files - case modulesOrFirstError of - Left errs -> PSCI $ printErrors errs - Right modules -> PSCI . lift . modify $ updateModules modules - --- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the --- options and ignores the warning messages. -runMake :: P.Make a -> IO (Either P.MultipleErrors a) -runMake mk = fst <$> P.runMake P.defaultOptions mk - -makeIO :: (IOError -> P.ErrorMessage) -> IO a -> P.Make a -makeIO f io = do - e <- liftIO $ tryIOError io - either (throwError . P.singleError . f) return e - -make :: PSCiState -> [P.Module] -> P.Make P.Environment -make st@PSCiState{..} ms = do - externs <- P.make actions' (map snd loadedModules ++ ms) - return $ foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs - where - filePathMap = M.fromList $ (first P.getModuleName . swap) `map` allModules - actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False - actions' = actions { P.progress = const (return ()) } - loadedModules = psciLoadedModules st - allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms - - --- Commands - --- | --- Parses the input and returns either a Metacommand, or an error as a string. --- -getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command)) -getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do - firstLine <- withInterrupt $ getInputLine "> " - case firstLine of - Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty - Just "" -> return (Right Nothing) - Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s - Just s -> fmap Just . parseCommand <$> go [s] - where - go :: [String] -> InputT (StateT PSCiState IO) String - go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " " - --- | --- Performs an action for each meta-command given, and also for expressions. --- -handleCommand :: Command -> PSCI () -handleCommand (Expression val) = handleExpression val -handleCommand ShowHelp = PSCI $ outputStrLn helpMessage -handleCommand (Import im) = handleImport im -handleCommand (Decls l) = handleDecls l -handleCommand (LoadFile filePath) = PSCI $ whenFileExists filePath $ \absPath -> do - m <- lift . lift $ loadModule absPath - case m of - Left err -> outputStrLn err - Right mods -> lift $ modify (updateModules (map (absPath,) mods)) -handleCommand (LoadForeign filePath) = PSCI $ whenFileExists filePath $ \absPath -> do - foreignsOrError <- lift . lift . runMake $ do - foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readUTF8File absPath) - P.parseForeignModulesFromFiles [(absPath, foreignFile)] - case foreignsOrError of - Left err -> outputStrLn $ P.prettyPrintMultipleErrors False err - Right foreigns -> lift $ modify (updateForeignFiles foreigns) -handleCommand ResetState = do - PSCI . lift . modify $ \st -> - st { psciImportedModules = [] - , psciLetBindings = [] - } - loadAllImportedModules -handleCommand (TypeOf val) = handleTypeOf val -handleCommand (KindOf typ) = handleKindOf typ -handleCommand (BrowseModule moduleName) = handleBrowse moduleName -handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules -handleCommand (ShowInfo QueryImport) = handleShowImportedModules -handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug." - - --- | --- Takes a value expression and evaluates it with the current state. --- -handleExpression :: P.Expr -> PSCI () -handleExpression val = do - st <- PSCI $ lift get - let m = createTemporaryModule True st val - let nodeArgs = psciNodeFlags st ++ [indexFile] - e <- psciIO . runMake $ make st [supportModule, m] - case e of - Left errs -> PSCI $ printErrors errs - Right _ -> do - psciIO $ writeFile indexFile "require('$PSCI')['$main']();" - process <- psciIO findNodeProcess - result <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process - case result of - Just (ExitSuccess, out, _) -> PSCI $ outputStrLn out - Just (ExitFailure _, _, err) -> PSCI $ outputStrLn err - Nothing -> PSCI $ outputStrLn "Couldn't find node.js" - --- | --- Takes a list of declarations and updates the environment, then run a make. If the declaration fails, --- restore the original environment. --- -handleDecls :: [P.Declaration] -> PSCI () -handleDecls ds = do - st <- PSCI $ lift get - let st' = updateLets ds st - let m = createTemporaryModule False st' (P.Literal (P.ObjectLiteral [])) - e <- psciIO . runMake $ make st' [m] - case e of - Left err -> PSCI $ printErrors err - Right _ -> PSCI $ lift (put st') - --- | --- Show actual loaded modules in psci. --- -handleShowLoadedModules :: PSCI () -handleShowLoadedModules = do - loadedModules <- PSCI $ lift $ gets psciLoadedModules - psciIO $ readModules loadedModules >>= putStrLn - return () - where readModules = return . unlines . sort . nub . map toModuleName - toModuleName = N.runModuleName . (\ (P.Module _ _ mdName _ _) -> mdName) . snd - --- | --- Show the imported modules in psci. --- -handleShowImportedModules :: PSCI () -handleShowImportedModules = do - PSCiState { psciImportedModules = importedModules } <- PSCI $ lift get - psciIO $ showModules importedModules >>= putStrLn - return () - where - showModules = return . unlines . sort . map showModule - showModule (mn, declType, asQ) = - "import " ++ N.runModuleName mn ++ showDeclType declType ++ - foldMap (\mn' -> " as " ++ N.runModuleName mn') asQ - - showDeclType P.Implicit = "" - showDeclType (P.Explicit refs) = refsList refs - showDeclType (P.Hiding refs) = " hiding " ++ refsList refs - refsList refs = " (" ++ commaList (map showRef refs) ++ ")" - - showRef :: P.DeclarationRef -> String - showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" - showRef (P.TypeOpRef op) = "type " ++ N.showOp op - showRef (P.ValueRef ident) = N.runIdent ident - showRef (P.ValueOpRef op) = N.showOp op - showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn - showRef (P.TypeInstanceRef ident) = N.runIdent ident - showRef (P.ModuleRef name) = "module " ++ N.runModuleName name - showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref - - commaList :: [String] -> String - commaList = intercalate ", " - --- | --- Imports a module, preserving the initial state on failure. --- -handleImport :: ImportedModule -> PSCI () -handleImport im = do - st <- updateImportedModules im <$> PSCI (lift get) - let m = createTemporaryModuleForImports st - e <- psciIO . runMake $ make st [m] - case e of - Left errs -> PSCI $ printErrors errs - Right _ -> do - PSCI $ lift $ put st - return () - --- | --- Takes a value and prints its type --- -handleTypeOf :: P.Expr -> PSCI () -handleTypeOf val = do - st <- PSCI $ lift get - let m = createTemporaryModule False st val - e <- psciIO . runMake $ make st [m] - case e of - Left errs -> PSCI $ printErrors errs - Right env' -> - case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of - Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty - Nothing -> PSCI $ outputStrLn "Could not find type" - --- | --- Browse a module and displays its signature (if module exists). --- -handleBrowse :: P.ModuleName -> PSCI () -handleBrowse moduleName = do - st <- PSCI $ lift get - env <- psciIO . runMake $ make st [] - case env of - Left errs -> PSCI $ printErrors errs - Right env' -> - if isModInEnv moduleName st - then PSCI $ printModuleSignatures moduleName env' - else case lookupUnQualifiedModName moduleName st of - Just unQualifiedName -> - if isModInEnv unQualifiedName st - then PSCI $ printModuleSignatures unQualifiedName env' - else failNotInEnv moduleName - Nothing -> - failNotInEnv moduleName - where - isModInEnv modName = - any ((== modName) . P.getModuleName . snd) . psciLoadedModules - failNotInEnv modName = - PSCI $ outputStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid." - lookupUnQualifiedModName quaModName st = - (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st) - --- | --- Takes a value and prints its kind --- -handleKindOf :: P.Type -> PSCI () -handleKindOf typ = do - st <- PSCI $ lift get - let m = createTemporaryModuleForKind st typ - mName = P.ModuleName [P.ProperName "$PSCI"] - e <- psciIO . runMake $ make st [m] - case e of - Left errs -> PSCI $ printErrors errs - Right env' -> - case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of - Just (_, typ') -> do - let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName } - k = check (P.kindOf typ') chk - - check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState) - check sew = fst . runWriter . runExceptT . runStateT sew - case k of - Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack - Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind - Nothing -> PSCI $ outputStrLn "Could not find kind" - --- Misc - --- | --- Attempts to read initial commands from '.psci' in the present working --- directory then the user's home --- -loadUserConfig :: IO (Maybe [Command]) -loadUserConfig = onFirstFileMatching readCommands pathGetters - where - pathGetters = [getCurrentDirectory, getHomeDirectory] - readCommands :: IO FilePath -> IO (Maybe [Command]) - readCommands path = do - configFile <- ( ".psci") <$> path - exists <- doesFileExist configFile - if exists - then do - ls <- lines <$> readUTF8File configFile - case traverse parseCommand ls of - Left err -> print err >> exitFailure - Right cs -> return $ Just cs - else - return Nothing - --- | Checks if the Console module is defined -consoleIsDefined :: [P.Module] -> Bool -consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", "Eff", "Console" ])) . P.getModuleName) diff --git a/psci/PSCi/Message.hs b/psci/PSCi/Message.hs deleted file mode 100644 index 883ca61642..0000000000 --- a/psci/PSCi/Message.hs +++ /dev/null @@ -1,52 +0,0 @@ -module PSCi.Message where - -import Data.List (intercalate) - -import PSCi.Types -import qualified PSCi.Directive as D - --- Messages - --- | --- The help message. --- -helpMessage :: String -helpMessage = "The following commands are available:\n\n " ++ - intercalate "\n " (map line D.help) ++ - "\n\n" ++ extraHelp - where - line :: (Directive, String, String) -> String - line (dir, arg, desc) = - let cmd = ':' : D.stringFor dir - in unwords [ cmd - , replicate (11 - length cmd) ' ' - , arg - , replicate (11 - length arg) ' ' - , desc - ] - - extraHelp = - "Further information is available on the PureScript wiki:\n" ++ - " --> https://github.com/purescript/purescript/wiki/psci" - - --- | --- The welcome prologue. --- -prologueMessage :: String -prologueMessage = intercalate "\n" - [ " ____ ____ _ _ " - , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ " - , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|" - , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ " - , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|" - , " |_| " - , "" - , ":? shows help" - ] - --- | --- The quit message. --- -quitMessage :: String -quitMessage = "See ya!" diff --git a/psci/PSCi/Option.hs b/psci/PSCi/Option.hs deleted file mode 100644 index 1b75001190..0000000000 --- a/psci/PSCi/Option.hs +++ /dev/null @@ -1,57 +0,0 @@ -module PSCi.Option ( - getOpt -) where - -import Prelude () -import Prelude.Compat - -import Options.Applicative as Opts -import Data.Version (showVersion) - -import PSCi.Types -import qualified Paths_purescript as Paths - --- Parse Command line option - -multiLineMode :: Parser Bool -multiLineMode = switch $ - long "multi-line-mode" - <> short 'm' - <> Opts.help "Run in multi-line mode (use ^D to terminate commands)" - -inputFile :: Parser FilePath -inputFile = strArgument $ - metavar "FILE" - <> Opts.help "Optional .purs files to load on start" - -inputForeignFile :: Parser FilePath -inputForeignFile = strOption $ - short 'f' - <> long "ffi" - <> help "The input .js file(s) providing foreign import implementations" - -nodeFlagsFlag :: Parser [String] -nodeFlagsFlag = option parser $ - long "node-opts" - <> metavar "NODE_OPTS" - <> value [] - <> Opts.help "Flags to pass to node, separated by spaces" - where - parser = words <$> str - -psciOptions :: Parser PSCiOptions -psciOptions = PSCiOptions <$> multiLineMode - <*> many inputFile - <*> many inputForeignFile - <*> nodeFlagsFlag - -version :: Parser (a -> a) -version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden - -getOpt :: IO PSCiOptions -getOpt = execParser opts - where - opts = info (version <*> helper <*> psciOptions) infoModList - infoModList = fullDesc <> headerInfo <> footerInfo - headerInfo = header "psci - Interactive mode for PureScript" - footerInfo = footer $ "psci " ++ showVersion Paths.version diff --git a/psci/main/Main.hs b/psci/main/Main.hs deleted file mode 100644 index e4306486f1..0000000000 --- a/psci/main/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import PSCi - -main :: IO () -main = runPSCi diff --git a/purescript.cabal b/purescript.cabal index ded0c22011..56f495e62e 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -88,47 +88,48 @@ source-repository head library build-depends: base >=4.8 && <5, + aeson >= 0.8 && < 0.12, + aeson-better-errors >= 0.8, base-compat >=0.6.0, - lifted-base >= 0.2.3 && < 0.2.4, - monad-control >= 1.0.0.0 && < 1.1, - transformers-base >= 0.4.0 && < 0.5, + bower-json >= 0.8, + boxes >= 0.1.4 && < 0.2.0, + bytestring -any, containers -any, - unordered-containers -any, - dlist -any, directory >= 1.2, + dlist -any, + edit-distance -any, filepath -any, + fsnotify >= 0.2.1, + Glob >= 0.7 && < 0.8, + haskeline >= 0.7.0.0, + http-types -any, + language-javascript == 0.6.*, + lifted-base >= 0.2.3 && < 0.2.4, + monad-control >= 1.0.0.0 && < 1.1, + monad-logger >= 0.3 && < 0.4, mtl >= 2.1.0 && < 2.3.0, + parallel >= 3.2 && < 3.3, parsec -any, - transformers >= 0.3.0 && < 0.6, - transformers-compat >= 0.3.0, - utf8-string >= 1 && < 2, pattern-arrows >= 0.0.2 && < 0.1, - time -any, - boxes >= 0.1.4 && < 0.2.0, - aeson >= 0.8 && < 0.12, - vector -any, - bower-json >= 0.8, - aeson-better-errors >= 0.8, - bytestring -any, - text -any, - split -any, - language-javascript == 0.6.*, - syb -any, - Glob >= 0.7 && < 0.8, + pipes >= 4.0.0 && < 4.2.0, + pipes-http -any, process >= 1.2.0 && < 1.5, + regex-tdfa -any, safe >= 0.3.9 && < 0.4, semigroups >= 0.16.2 && < 0.19, - parallel >= 3.2 && < 3.3, sourcemap >= 0.1.6, + spdx == 0.2.*, + split -any, stm >= 0.2.4.0, - regex-tdfa -any, - edit-distance -any, - fsnotify >= 0.2.1, - monad-logger >= 0.3 && < 0.4, - pipes >= 4.0.0 && < 4.2.0 , - pipes-http -any, - http-types -any, - spdx == 0.2.* + syb -any, + text -any, + time -any, + transformers >= 0.3.0 && < 0.6, + transformers-base >= 0.4.0 && < 0.5, + transformers-compat >= 0.3.0, + unordered-containers -any, + utf8-string >= 1 && < 2, + vector -any exposed-modules: Language.PureScript Language.PureScript.AST @@ -257,6 +258,16 @@ library Language.PureScript.Ide.Util Language.PureScript.Ide.Rebuild + Language.PureScript.Interactive + Language.PureScript.Interactive.Types + Language.PureScript.Interactive.Parser + Language.PureScript.Interactive.Directive + Language.PureScript.Interactive.Completion + Language.PureScript.Interactive.IO + Language.PureScript.Interactive.Message + Language.PureScript.Interactive.Module + Language.PureScript.Interactive.Printer + Control.Monad.Logger Control.Monad.Supply Control.Monad.Supply.Class @@ -286,11 +297,22 @@ library ghc-options: -Wall -O2 executable psc - build-depends: base >=4 && <5, base-compat >=0.6.0, - containers -any, directory -any, filepath -any, - mtl -any, optparse-applicative >= 0.12.1, parsec -any, purescript -any, - time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8, - aeson >= 0.8 && < 0.12, bytestring -any, utf8-string >= 1 && < 2 + build-depends: base >=4 && <5, + purescript -any, + aeson >= 0.8 && < 0.12, + base-compat >=0.6.0, + bytestring -any, + containers -any, + directory -any, + filepath -any, + Glob >= 0.7 && < 0.8, + mtl -any, + optparse-applicative >= 0.12.1, + parsec -any, + time -any, + transformers -any, + transformers-compat -any, + utf8-string >= 1 && < 2 main-is: Main.hs buildable: True hs-source-dirs: psc @@ -298,33 +320,40 @@ executable psc ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N" executable psci - build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, - mtl -any, optparse-applicative >= 0.12.1, parsec -any, - haskeline >= 0.7.0.0, purescript -any, transformers -any, - transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0, - boxes >= 0.1.4 && < 0.2.0 - + build-depends: base >=4 && <5, + purescript -any, + base-compat >=0.6.0, + boxes >= 0.1.4 && < 0.2.0, + containers -any, + directory -any, + filepath -any, + Glob -any, + haskeline >= 0.7.0.0, + mtl -any, + optparse-applicative >= 0.12.1, + parsec -any, + process -any, + time -any, + transformers -any, + transformers-compat -any main-is: Main.hs buildable: True - hs-source-dirs: psci psci/main - other-modules: PSCi - PSCi.Types - PSCi.Parser - PSCi.Directive - PSCi.Completion - PSCi.IO - PSCi.Message - PSCi.Option - PSCi.Module - PSCi.Printer - Paths_purescript + hs-source-dirs: psci + other-modules: Paths_purescript ghc-options: -Wall -O2 executable psc-docs - build-depends: base >=4 && <5, purescript -any, - optparse-applicative >= 0.12.1, process -any, mtl -any, - split -any, ansi-wl-pprint -any, directory -any, - filepath -any, Glob -any, transformers -any, + build-depends: base >=4 && <5, + purescript -any, + ansi-wl-pprint -any, + directory -any, + filepath -any, + Glob -any, + mtl -any, + optparse-applicative >= 0.12.1, + process -any, + split -any, + transformers -any, transformers-compat -any main-is: Main.hs other-modules: Paths_purescript @@ -336,7 +365,11 @@ executable psc-docs ghc-options: -Wall -O2 executable psc-publish - build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any + build-depends: base >=4 && <5, + purescript -any, + aeson -any, + bytestring -any, + optparse-applicative -any main-is: Main.hs other-modules: Paths_purescript buildable: True @@ -344,9 +377,15 @@ executable psc-publish ghc-options: -Wall -O2 executable psc-hierarchy - build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.12.1, - process -any, mtl -any, parsec -any, filepath -any, directory -any, - Glob -any + build-depends: base >=4 && <5, + purescript -any, + directory -any, + filepath -any, + Glob -any, + mtl -any, + optparse-applicative >= 0.12.1, + parsec -any, + process -any main-is: Main.hs other-modules: Paths_purescript buildable: True @@ -360,13 +399,13 @@ executable psc-bundle other-extensions: build-depends: base >=4 && <5, purescript -any, - filepath -any, directory -any, + filepath -any, + Glob -any, mtl -any, - transformers -any, - transformers-compat -any, optparse-applicative >= 0.12.1, - Glob -any + transformers -any, + transformers-compat -any ghc-options: -Wall -O2 hs-source-dirs: psc-bundle @@ -374,19 +413,19 @@ executable psc-ide-server main-is: Main.hs other-modules: Paths_purescript other-extensions: - build-depends: base >=4 && <5 - , purescript -any - , directory -any - , filepath -any - , monad-logger -any - , mtl -any - , transformers -any - , transformers-compat -any - , network -any - , optparse-applicative >= 0.12.1 - , stm -any - , text -any - , base-compat >=0.6.0 + build-depends: base >=4 && <5, + purescript -any, + base-compat >=0.6.0, + directory -any, + filepath -any, + monad-logger -any, + mtl -any, + network -any, + optparse-applicative >= 0.12.1, + stm -any, + text -any, + transformers -any, + transformers-compat -any ghc-options: -Wall -O2 -threaded hs-source-dirs: psc-ide-server @@ -394,23 +433,43 @@ executable psc-ide-client main-is: Main.hs other-modules: Paths_purescript other-extensions: - build-depends: base >=4 && <5 - , mtl -any - , text -any - , optparse-applicative >= 0.12.1 - , network -any - , base-compat >=0.6.0 + build-depends: base >=4 && <5, + base-compat >=0.6.0, + mtl -any, + network -any, + optparse-applicative >= 0.12.1, + text -any ghc-options: -Wall -O2 hs-source-dirs: psc-ide-client test-suite tests - build-depends: base >=4 && <5, containers -any, directory -any, - filepath -any, mtl -any, parsec -any, purescript -any, - transformers -any, process -any, transformers-compat -any, time -any, - Glob -any, aeson-better-errors -any, bytestring -any, aeson -any, - base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any, - boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any, - vector -any, utf8-string -any, silently -any + build-depends: base >=4 && <5, + purescript -any, + aeson -any, + aeson-better-errors -any, + base-compat -any, + boxes -any, + bytestring -any, + containers -any, + directory -any, + filepath -any, + Glob -any, + haskeline >= 0.7.0.0, + hspec -any, + hspec-discover -any, + HUnit -any, + mtl -any, + optparse-applicative -any, + parsec -any, + process -any, + silently -any, + stm -any, + text -any, + time -any, + transformers -any, + transformers-compat -any, + utf8-string -any, + vector -any ghc-options: -Wall type: exitcode-stdio-1.0 main-is: Main.hs @@ -429,9 +488,5 @@ test-suite tests Language.PureScript.Ide.RebuildSpec Language.PureScript.Ide.ReexportsSpec Language.PureScript.IdeSpec - PSCi.Completion - PSCi.Directive - PSCi.Module - PSCi.Types buildable: True - hs-source-dirs: tests psci + hs-source-dirs: tests diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs new file mode 100644 index 0000000000..bfcc037aa2 --- /dev/null +++ b/src/Language/PureScript/Interactive.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DataKinds #-} + +module Language.PureScript.Interactive + ( handleCommand + , module Interactive + + -- TODO: remove these exports + , make + , runMake + ) where + +import Prelude () +import Prelude.Compat + +import Data.List (intercalate, nub, sort, find, foldl') +import qualified Data.Map as M + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.State.Class +import Control.Monad.Reader.Class +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) +import Control.Monad.Trans.State.Strict (StateT, runStateT) +import Control.Monad.Writer.Strict (Writer(), runWriter) + +import qualified Language.PureScript as P +import qualified Language.PureScript.Names as N + +import Language.PureScript.Interactive.Completion as Interactive +import Language.PureScript.Interactive.IO as Interactive +import Language.PureScript.Interactive.Message as Interactive +import Language.PureScript.Interactive.Module as Interactive +import Language.PureScript.Interactive.Parser as Interactive +import Language.PureScript.Interactive.Printer as Interactive +import Language.PureScript.Interactive.Types as Interactive + +import System.Exit +import System.Process (readProcessWithExitCode) + +-- | Pretty-print errors +printErrors :: MonadIO m => P.MultipleErrors -> m () +printErrors = liftIO . putStrLn . P.prettyPrintMultipleErrors False + +-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the +-- options and ignores the warning messages. +runMake :: P.Make a -> IO (Either P.MultipleErrors a) +runMake mk = fst <$> P.runMake P.defaultOptions mk + +-- | Rebuild a module, using the cached externs data for dependencies. +rebuild + :: M.Map P.ModuleName FilePath + -> [P.ExternsFile] + -> P.Module + -> P.Make (P.ExternsFile, P.Environment) +rebuild foreignFiles loadedExterns m = do + externs <- P.rebuildModule buildActions loadedExterns m + return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment (loadedExterns ++ [externs])) + where + buildActions :: P.MakeActions P.Make + buildActions = (P.buildMakeActions modulesDir + filePathMap + foreignFiles + False) { P.progress = const (return ()) } + + filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath) + filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways) + +-- | Build the collection of modules from scratch. This is usually done on startup. +make + :: M.Map P.ModuleName FilePath + -> [P.Module] + -> P.Make ([P.ExternsFile], P.Environment) +make foreignFiles ms = do + externs <- P.make buildActions ms + return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs) + where + buildActions :: P.MakeActions P.Make + buildActions = (P.buildMakeActions modulesDir + filePathMap + foreignFiles + False) + + filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath) + filePathMap = M.fromList $ map (\m -> (P.getModuleName m, Left P.RebuildAlways)) ms + +-- | Performs a PSCi command +handleCommand + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => Command + -> m () +handleCommand ShowHelp = liftIO $ putStrLn helpMessage +handleCommand ResetState = handleResetState +handleCommand (Expression val) = handleExpression val +handleCommand (Import im) = handleImport im +handleCommand (Decls l) = handleDecls l +handleCommand (TypeOf val) = handleTypeOf val +handleCommand (KindOf typ) = handleKindOf typ +handleCommand (BrowseModule moduleName) = handleBrowse moduleName +handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules +handleCommand (ShowInfo QueryImport) = handleShowImportedModules +handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug." + +-- | Reset the application state +handleResetState + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => m () +handleResetState = do + modify $ updateImportedModules (const []) + . updateLets (const []) + files <- asks psciLoadedFiles + e <- runExceptT $ do + modules <- ExceptT . liftIO $ loadAllModules files + foreignFiles <- asks psciForeignFiles + (externs, _) <- ExceptT . liftIO . runMake . make foreignFiles . map snd $ modules + return (map snd modules, externs) + case e of + Left errs -> printErrors errs + Right (modules, externs) -> modify (updateLoadedExterns (const (zip modules externs))) + +-- | Takes a value expression and evaluates it with the current state. +-- +-- TODO: factor out the Node process runner, so that we can use PSCi in other settings. +handleExpression + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => P.Expr + -> m () +handleExpression val = do + st <- get + let m = createTemporaryModule True st val + foreignFiles <- asks psciForeignFiles + nodeArgs <- asks ((++ [indexFile]) . psciNodeFlags) + e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m + case e of + Left errs -> printErrors errs + Right _ -> do + liftIO $ writeFile indexFile "require('$PSCI')['$main']();" + process <- liftIO findNodeProcess + result <- liftIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process + case result of + Just (ExitSuccess, out, _) -> liftIO $ putStrLn out + Just (ExitFailure _, _, err) -> liftIO $ putStrLn err + Nothing -> liftIO $ putStrLn "Couldn't find node.js" + +-- | +-- Takes a list of declarations and updates the environment, then run a make. If the declaration fails, +-- restore the original environment. +-- +handleDecls + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => [P.Declaration] + -> m () +handleDecls ds = do + st <- gets (updateLets (++ ds)) + let m = createTemporaryModule False st (P.Literal (P.ObjectLiteral [])) + foreignFiles <- asks psciForeignFiles + e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m + case e of + Left err -> printErrors err + Right _ -> put st + +-- | Show actual loaded modules in psci. +handleShowLoadedModules + :: (MonadState PSCiState m, MonadIO m) + => m () +handleShowLoadedModules = do + loadedModules <- gets psciLoadedExterns + liftIO $ putStrLn (readModules loadedModules) + where + readModules = unlines . sort . nub . map (P.runModuleName . P.getModuleName . fst) + +-- | Show the imported modules in psci. +handleShowImportedModules + :: (MonadState PSCiState m, MonadIO m) + => m () +handleShowImportedModules = do + PSCiState { psciImportedModules = importedModules } <- get + liftIO $ showModules importedModules >>= putStrLn + return () + where + showModules = return . unlines . sort . map showModule + showModule (mn, declType, asQ) = + "import " ++ N.runModuleName mn ++ showDeclType declType ++ + foldMap (\mn' -> " as " ++ N.runModuleName mn') asQ + + showDeclType P.Implicit = "" + showDeclType (P.Explicit refs) = refsList refs + showDeclType (P.Hiding refs) = " hiding " ++ refsList refs + refsList refs = " (" ++ commaList (map showRef refs) ++ ")" + + showRef :: P.DeclarationRef -> String + showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" + showRef (P.TypeOpRef op) = "type " ++ N.showOp op + showRef (P.ValueRef ident) = N.runIdent ident + showRef (P.ValueOpRef op) = N.showOp op + showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn + showRef (P.TypeInstanceRef ident) = N.runIdent ident + showRef (P.ModuleRef name) = "module " ++ N.runModuleName name + showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref + + commaList :: [String] -> String + commaList = intercalate ", " + +-- | Imports a module, preserving the initial state on failure. +handleImport + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => ImportedModule + -> m () +handleImport im = do + st <- gets (updateImportedModules (im :)) + foreignFiles <- asks psciForeignFiles + let m = createTemporaryModuleForImports st + e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m + case e of + Left errs -> printErrors errs + Right _ -> put st + +-- | Takes a value and prints its type +handleTypeOf + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => P.Expr + -> m () +handleTypeOf val = do + st <- get + foreignFiles <- asks psciForeignFiles + let m = createTemporaryModule False st val + e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m + case e of + Left errs -> printErrors errs + Right (_, env') -> + case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of + Just (ty, _, _) -> liftIO . putStrLn . P.prettyPrintType $ ty + Nothing -> liftIO $ putStrLn "Could not find type" + +-- | Takes a type and prints its kind +handleKindOf + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => P.Type + -> m () +handleKindOf typ = do + st <- get + foreignFiles <- asks psciForeignFiles + let m = createTemporaryModuleForKind st typ + mName = P.ModuleName [P.ProperName "$PSCI"] + e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m + case e of + Left errs -> printErrors errs + Right (_, env') -> + case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of + Just (_, typ') -> do + let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName } + k = check (P.kindOf typ') chk + + check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState) + check sew = fst . runWriter . runExceptT . runStateT sew + case k of + Left err -> printErrors err + Right (kind, _) -> liftIO . putStrLn . P.prettyPrintKind $ kind + Nothing -> liftIO $ putStrLn "Could not find kind" + +-- | Browse a module and displays its signature +handleBrowse + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => P.ModuleName + -> m () +handleBrowse moduleName = do + st <- get + env <- asks psciEnvironment + if isModInEnv moduleName st + then liftIO . putStrLn $ printModuleSignatures moduleName env + else case lookupUnQualifiedModName moduleName st of + Just unQualifiedName -> + if isModInEnv unQualifiedName st + then liftIO . putStrLn $ printModuleSignatures unQualifiedName env + else failNotInEnv moduleName + Nothing -> + failNotInEnv moduleName + where + isModInEnv modName = + any ((== modName) . P.getModuleName . fst) . psciLoadedExterns + failNotInEnv modName = + liftIO $ putStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid." + lookupUnQualifiedModName quaModName st = + (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st) diff --git a/psci/PSCi/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs similarity index 70% rename from psci/PSCi/Completion.hs rename to src/Language/PureScript/Interactive/Completion.hs index 4e7f2f1bc1..135ea6b3ef 100644 --- a/psci/PSCi/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -1,35 +1,89 @@ {-# LANGUAGE DataKinds #-} -module PSCi.Completion where +module Language.PureScript.Interactive.Completion + ( CompletionM + , liftCompletionM + , completion + , completion' + ) where -import Prelude () import Prelude.Compat -import Data.Maybe (mapMaybe) -import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix) -import Data.Function (on) - -import Control.Arrow (second) -import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) -import Control.Monad.Trans.State.Strict - -import System.Console.Haskeline - +import Control.Arrow (second) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) +import Data.Function (on) +import Data.List (nub, nubBy, isPrefixOf, sortBy, stripPrefix) +import Data.Maybe (mapMaybe) import qualified Language.PureScript as P +import qualified Language.PureScript.Interactive.Directive as D +import Language.PureScript.Interactive.Types import qualified Language.PureScript.Names as N - -import qualified PSCi.Directive as D -import PSCi.Types +import System.Console.Haskeline -- Completions may read the state, but not modify it. type CompletionM = ReaderT PSCiState IO --- Lift a `CompletionM` action to a `StateT PSCiState IO` one. -liftCompletionM :: CompletionM a -> StateT PSCiState IO a -liftCompletionM act = StateT (\s -> (\a -> (a, s)) <$> runReaderT act s) +-- Lift a `CompletionM` action into a state monad. +liftCompletionM + :: (MonadState PSCiState m, MonadIO m) + => CompletionM a + -> m a +liftCompletionM act = do + st <- get + liftIO $ runReaderT act st -- Haskeline completions +-- | Loads module, function, and file completions. +completion + :: (MonadState PSCiState m, MonadIO m) + => CompletionFunc m +completion = liftCompletionM . completion' + +completion' :: CompletionFunc CompletionM +completion' = completeWordWithPrev Nothing " \t\n\r" findCompletions + +-- | Callback for Haskeline's `completeWordWithPrev`. +-- Expects: +-- * Line contents to the left of the word, reversed +-- * Word to be completed +findCompletions :: String -> String -> CompletionM [Completion] +findCompletions prev word = do + let ctx = completionContext (words (reverse prev)) word + completions <- concat <$> traverse getCompletions ctx + return $ sortBy directivesFirst completions + where + getCompletions :: CompletionContext -> CompletionM [Completion] + getCompletions = fmap (mapMaybe (either (prefixedBy word) Just)) . getCompletion + + getCompletion :: CompletionContext -> CompletionM [Either String Completion] + getCompletion ctx = + case ctx of + CtxFilePath f -> map Right <$> listFiles f + CtxModule -> map Left <$> getModuleNames + CtxIdentifier -> map Left <$> ((++) <$> getIdentNames <*> getDctorNames) + CtxType -> map Left <$> getTypeNames + CtxFixed str -> return [Left str] + CtxDirective d -> return (map Left (completeDirectives d)) + + completeDirectives :: String -> [String] + completeDirectives = map (':' :) . D.directiveStringsFor + + prefixedBy :: String -> String -> Maybe Completion + prefixedBy w cand = if w `isPrefixOf` cand + then Just (simpleCompletion cand) + else Nothing + + directivesFirst :: Completion -> Completion -> Ordering + directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2 + where + go (':' : xs) (':' : ys) = compare xs ys + go (':' : _) _ = LT + go _ (':' : _) = GT + go xs ys = compare xs ys + data CompletionContext = CtxDirective String | CtxFilePath String @@ -39,15 +93,6 @@ data CompletionContext | CtxFixed String deriving (Show, Read) --- | --- Loads module, function, and file completions. --- -completion :: CompletionFunc (StateT PSCiState IO) -completion = liftCompletionM . completion' - -completion' :: CompletionFunc CompletionM -completion' = completeWordWithPrev Nothing " \t\n\r" findCompletions - -- | -- Decide what kind of completion we need based on input. This function expects -- a list of complete words (to the left of the cursor) as the first argument, @@ -74,8 +119,6 @@ completeDirective ws w = directiveArg :: String -> Directive -> [CompletionContext] directiveArg _ Browse = [CtxModule] -directiveArg w Load = [CtxFilePath w] -directiveArg w Foreign = [CtxFilePath w] directiveArg _ Quit = [] directiveArg _ Reset = [] directiveArg _ Help = [] @@ -95,44 +138,8 @@ headSatisfies p str = (c:_) -> p c _ -> False --- | Callback for Haskeline's `completeWordWithPrev`. --- Expects: --- * Line contents to the left of the word, reversed --- * Word to be completed -findCompletions :: String -> String -> CompletionM [Completion] -findCompletions prev word = do - let ctx = completionContext (words (reverse prev)) word - completions <- concat <$> traverse getCompletions ctx - return $ sortBy directivesFirst completions - where - getCompletions :: CompletionContext -> CompletionM [Completion] - getCompletions = fmap (mapMaybe (either (prefixedBy word) Just)) . getCompletion - - prefixedBy :: String -> String -> Maybe Completion - prefixedBy w cand = if w `isPrefixOf` cand - then Just (simpleCompletion cand) - else Nothing - -getCompletion :: CompletionContext -> CompletionM [Either String Completion] -getCompletion ctx = - case ctx of - CtxFilePath f -> map Right <$> listFiles f - CtxModule -> map Left <$> getModuleNames - CtxIdentifier -> map Left <$> ((++) <$> getIdentNames <*> getDctorNames) - CtxType -> map Left <$> getTypeNames - CtxFixed str -> return [Left str] - CtxDirective d -> return (map Left (completeDirectives d)) - - where - completeDirectives :: String -> [String] - completeDirectives = map (':' :) . D.directiveStringsFor - - getLoadedModules :: CompletionM [P.Module] -getLoadedModules = asks (map snd . psciLoadedModules) - -getImportedModules :: CompletionM [ImportedModule] -getImportedModules = asks psciImportedModules +getLoadedModules = asks (map fst . psciLoadedExterns) getModuleNames :: CompletionM [String] getModuleNames = moduleNames <$> getLoadedModules @@ -212,12 +219,4 @@ dctorNames = nubOnFst . concatMap go . P.exportedDeclarations go _ = [] moduleNames :: [P.Module] -> [String] -moduleNames ms = nub [P.runModuleName moduleName | P.Module _ _ moduleName _ _ <- ms] - -directivesFirst :: Completion -> Completion -> Ordering -directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2 - where - go (':' : xs) (':' : ys) = compare xs ys - go (':' : _) _ = LT - go _ (':' : _) = GT - go xs ys = compare xs ys +moduleNames = nub . map (P.runModuleName . P.getModuleName) diff --git a/psci/PSCi/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs similarity index 91% rename from psci/PSCi/Directive.hs rename to src/Language/PureScript/Interactive/Directive.hs index 1156bd5a86..f9d7c6c99b 100644 --- a/psci/PSCi/Directive.hs +++ b/src/Language/PureScript/Interactive/Directive.hs @@ -1,17 +1,15 @@ -- | -- Directives for PSCI. -- -module PSCi.Directive where +module Language.PureScript.Interactive.Directive where -import Prelude () import Prelude.Compat - import Data.Maybe (fromJust, listToMaybe) import Data.List (isPrefixOf) import Data.Tuple (swap) -import PSCi.Types +import Language.PureScript.Interactive.Types -- | -- List of all avaliable directives. @@ -29,8 +27,6 @@ directiveStrings = , (Quit , ["quit"]) , (Reset , ["reset"]) , (Browse , ["browse"]) - , (Load , ["load", "module"]) - , (Foreign, ["foreign"]) , (Type , ["type"]) , (Kind , ["kind"]) , (Show , ["show"]) @@ -97,8 +93,6 @@ help = , (Quit, "", "Quit PSCi") , (Reset, "", "Discard all imported modules and declared bindings") , (Browse, "", "See all functions in ") - , (Load, "", "Load for importing") - , (Foreign, "", "Load foreign module ") , (Type, "", "Show the type of ") , (Kind, "", "Show the kind of ") , (Show, "import", "Show all imported modules") diff --git a/psci/PSCi/IO.hs b/src/Language/PureScript/Interactive/IO.hs similarity index 70% rename from psci/PSCi/IO.hs rename to src/Language/PureScript/Interactive/IO.hs index 5397070e46..e120ec3e85 100644 --- a/psci/PSCi/IO.hs +++ b/src/Language/PureScript/Interactive/IO.hs @@ -1,14 +1,11 @@ -module PSCi.IO where +module Language.PureScript.Interactive.IO where -import Prelude () import Prelude.Compat -import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable, doesFileExist) -import System.FilePath (takeDirectory, (), isPathSeparator) -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad (msum) -import Control.Monad.IO.Class (MonadIO, liftIO) -import System.Console.Haskeline (outputStrLn, InputT) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable) +import System.FilePath (takeDirectory, (), isPathSeparator) mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory @@ -36,19 +33,9 @@ getHistoryFilename = do mkdirp filename return filename - -- | -- Expands tilde in path. -- expandTilde :: FilePath -> IO FilePath expandTilde ('~':p:rest) | isPathSeparator p = ( rest) <$> getHomeDirectory expandTilde p = return p - - -whenFileExists :: MonadIO m => FilePath -> (FilePath -> InputT m ()) -> InputT m () -whenFileExists filePath f = do - absPath <- liftIO $ expandTilde filePath - exists <- liftIO $ doesFileExist absPath - if exists - then f absPath - else outputStrLn $ "Couldn't locate: " ++ filePath diff --git a/src/Language/PureScript/Interactive/Message.hs b/src/Language/PureScript/Interactive/Message.hs new file mode 100644 index 0000000000..196aa762b6 --- /dev/null +++ b/src/Language/PureScript/Interactive/Message.hs @@ -0,0 +1,52 @@ +module Language.PureScript.Interactive.Message where + +import Prelude.Compat + +import Data.List (intercalate) +import Data.Version (showVersion) +import qualified Paths_purescript as Paths +import qualified Language.PureScript.Interactive.Directive as D +import Language.PureScript.Interactive.Types + +-- Messages + +-- | The help message. +helpMessage :: String +helpMessage = "The following commands are available:\n\n " ++ + intercalate "\n " (map line D.help) ++ + "\n\n" ++ extraHelp + where + line :: (Directive, String, String) -> String + line (dir, arg, desc) = + let cmd = ':' : D.stringFor dir + in unwords [ cmd + , replicate (11 - length cmd) ' ' + , arg + , replicate (11 - length arg) ' ' + , desc + ] + + extraHelp = + "Further information is available on the PureScript wiki:\n" ++ + " --> https://github.com/purescript/purescript/wiki/psci" + +-- | The welcome prologue. +prologueMessage :: String +prologueMessage = unlines + [ "PSCi, version " ++ showVersion Paths.version + , "Type :? for help" + ] + +supportModuleMessage :: String +supportModuleMessage = unlines + [ "PSCi requires the purescript-psci-support package to be installed." + , "You can install it using Bower as follows:" + , "" + , " bower i purescript-psci-support --save" + , "" + , "For help getting started, visit http://wiki.purescript.org/PSCi" + ] + +-- | The quit message. +quitMessage :: String +quitMessage = "See ya!" diff --git a/psci/PSCi/Module.hs b/src/Language/PureScript/Interactive/Module.hs similarity index 70% rename from psci/PSCi/Module.hs rename to src/Language/PureScript/Interactive/Module.hs index 017d0b654e..d874e43c7b 100644 --- a/psci/PSCi/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -1,45 +1,24 @@ -module PSCi.Module where +module Language.PureScript.Interactive.Module where -import Prelude () -import Prelude.Compat +import Prelude.Compat +import Control.Monad import qualified Language.PureScript as P -import PSCi.Types -import System.FilePath (pathSeparator) -import System.IO.UTF8 (readUTF8File) -import Control.Monad +import Language.PureScript.Interactive.Types +import System.FilePath (pathSeparator) +import System.IO.UTF8 (readUTF8File) + +-- * Support Module -- | The name of the PSCI support module supportModuleName :: P.ModuleName -supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"] +supportModuleName = P.moduleNameFromString "PSCI.Support" --- | Support module, contains code to evaluate terms -supportModule :: P.Module -supportModule = - case P.parseModulesFromFiles id [("", code)] of - Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps - _ -> P.internalError "Support module could not be parsed" - where - code :: String - code = unlines - [ "module S where" - , "" - , "import Prelude" - , "import Control.Monad.Eff (Eff)" - , "import Control.Monad.Eff.Console (CONSOLE, logShow)" - , "import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)" - , "" - , "class Eval a where" - , " eval :: a -> Eff (console :: CONSOLE) Unit" - , "" - , "instance evalShow :: (Show a) => Eval a where" - , " eval = logShow" - , "" - , "instance evalEff :: (Eval a) => Eval (Eff eff a) where" - , " eval x = unsafeInterleaveEff x >>= eval" - ] +-- | Checks if the Console module is defined +supportModuleIsDefined :: [P.Module] -> Bool +supportModuleIsDefined = any ((== supportModuleName) . P.getModuleName) --- Module Management +-- * Module Management -- | -- Loads a file for use with imports. @@ -59,7 +38,6 @@ loadAllModules files = do return (filename, content) return $ P.parseModulesFromFiles id filesAndContent - -- | -- Makes a volatile module to execute the current expression. -- diff --git a/psci/PSCi/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs similarity index 89% rename from psci/PSCi/Parser.hs rename to src/Language/PureScript/Interactive/Parser.hs index d8ebb033a2..86d6606fef 100644 --- a/psci/PSCi/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -1,23 +1,19 @@ -- | -- Parser for PSCI. -- -module PSCi.Parser +module Language.PureScript.Interactive.Parser ( parseCommand ) where -import Prelude () -import Prelude.Compat hiding (lex) - -import Data.Char (isSpace) -import Data.List (intercalate) - -import Text.Parsec hiding ((<|>)) +import Prelude.Compat hiding (lex) +import Data.Char (isSpace) +import Data.List (intercalate) +import Text.Parsec hiding ((<|>)) import qualified Language.PureScript as P -import Language.PureScript.Parser.Common (mark, same) - -import qualified PSCi.Directive as D -import PSCi.Types +import qualified Language.PureScript.Interactive.Directive as D +import Language.PureScript.Interactive.Types +import Language.PureScript.Parser.Common (mark, same) -- | -- Parses PSCI metacommands or expressions input from the user. @@ -67,8 +63,6 @@ parseDirective cmd = Quit -> return QuitPSCi Reset -> return ResetState Browse -> BrowseModule <$> parseRest P.moduleName arg - Load -> return $ LoadFile (trim arg) - Foreign -> return $ LoadForeign (trim arg) Show -> ShowInfo <$> parseReplQuery' (trim arg) Type -> TypeOf <$> parseRest P.parseValue arg Kind -> KindOf <$> parseRest P.parseType arg diff --git a/psci/PSCi/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs similarity index 91% rename from psci/PSCi/Printer.hs rename to src/Language/PureScript/Interactive/Printer.hs index 2c12ac4ce5..6147405adc 100644 --- a/psci/PSCi/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -1,25 +1,22 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DataKinds #-} -module PSCi.Printer where +module Language.PureScript.Interactive.Printer where -import Prelude () -import Prelude.Compat +import Prelude.Compat +import Data.List (intersperse) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) import qualified Language.PureScript as P import qualified Text.PrettyPrint.Boxes as Box -import qualified Data.Map as M -import System.Console.Haskeline -import Data.Maybe (mapMaybe) -import Data.List (intersperse) -import Control.Monad.IO.Class (MonadIO) -- Printers -- | -- Pretty print a module's signatures -- -printModuleSignatures :: MonadIO m => P.ModuleName -> P.Environment -> InputT m () +printModuleSignatures :: P.ModuleName -> P.Environment -> String printModuleSignatures moduleName (P.Environment {..}) = -- get relevant components of a module from environment let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names @@ -28,7 +25,7 @@ printModuleSignatures moduleName (P.Environment {..}) = in -- print each component - (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left) + (unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left) [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions @@ -125,7 +122,3 @@ printModuleSignatures moduleName (P.Environment {..}) = mapFirstRest f g (x:xs) = f x : map g xs trimEnd = reverse . dropWhile (== ' ') . reverse - --- | Pretty-print errors -printErrors :: MonadIO m => P.MultipleErrors -> InputT m () -printErrors = outputStrLn . P.prettyPrintMultipleErrors False diff --git a/psci/PSCi/Types.hs b/src/Language/PureScript/Interactive/Types.hs similarity index 52% rename from psci/PSCi/Types.hs rename to src/Language/PureScript/Interactive/Types.hs index 1e0a111fe8..683ff5426b 100644 --- a/psci/PSCi/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -1,71 +1,37 @@ -- | -- Type declarations and associated basic functions for PSCI. -- -module PSCi.Types where +module Language.PureScript.Interactive.Types where -import Prelude () import Prelude.Compat -import Control.Arrow (second) -import Data.Map (Map) -import qualified Data.Map as Map +import Data.Map (Map) import qualified Language.PureScript as P -data PSCiOptions = PSCiOptions - { psciMultiLineMode :: Bool - , psciInputFile :: [FilePath] - , psciForeignInputFiles :: [FilePath] - , psciInputNodeFlags :: [String] - } +-- | The PSCI configuration. +-- +-- These configuration values do not change during execution. +-- +data PSCiConfig = PSCiConfig + { psciLoadedFiles :: [FilePath] + , psciForeignFiles :: Map P.ModuleName FilePath + , psciNodeFlags :: [String] + , psciEnvironment :: P.Environment + } deriving Show --- | --- The PSCI state. +-- | The PSCI state. +-- -- Holds a list of imported modules, loaded files, and partial let bindings. -- The let bindings are partial, -- because it makes more sense to apply the binding to the final evaluated expression. --- data PSCiState = PSCiState { psciImportedModules :: [ImportedModule] - , _psciLoadedModules :: Map FilePath [P.Module] - , psciForeignFiles :: Map P.ModuleName FilePath , psciLetBindings :: [P.Declaration] - , psciNodeFlags :: [String] - } + , psciLoadedExterns :: [(P.Module, P.ExternsFile)] + } deriving Show initialPSCiState :: PSCiState -initialPSCiState = - PSCiState [] Map.empty Map.empty [] [] - -mkPSCiState :: [ImportedModule] - -> [(FilePath, P.Module)] - -> Map P.ModuleName FilePath - -> [P.Declaration] - -> [String] - -> PSCiState -mkPSCiState imported loaded foreigns lets nodeFlags = - (initialPSCiState - |> each imported updateImportedModules - |> updateModules loaded) - { psciForeignFiles = foreigns - , psciLetBindings = lets - , psciNodeFlags = nodeFlags - } - where - x |> f = f x - each xs f st = foldl (flip f) st xs - --- Public psci state accessors - --- | Get the imported filenames as a list. -psciImportedFilenames :: PSCiState -> [FilePath] -psciImportedFilenames = Map.keys . _psciLoadedModules - --- | Get the loaded modules as a list. -psciLoadedModules :: PSCiState -> [(FilePath, P.Module)] -psciLoadedModules = collect . Map.toList . _psciLoadedModules - where - collect :: [(k, [v])] -> [(k, v)] - collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ] +initialPSCiState = PSCiState [] [] [] -- | All of the data that is contained by an ImportDeclaration in the AST. -- That is: @@ -89,35 +55,21 @@ allImportsOf m (PSCiState{psciImportedModules = is}) = name = P.getModuleName m isImportOfThis (name', _, _) = name == name' --- State helpers +-- * State helpers --- | --- Updates the state to have more imported modules. --- -updateImportedModules :: ImportedModule -> PSCiState -> PSCiState -updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st } +-- | Updates the imported modules in the state record. +updateImportedModules :: ([ImportedModule] -> [ImportedModule]) -> PSCiState -> PSCiState +updateImportedModules f st = st { psciImportedModules = f (psciImportedModules st) } --- | --- Updates the state to have more loaded modules (available for import, but --- not necessarily imported). --- -updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState -updateModules modules st = - st { _psciLoadedModules = Map.union (go modules) (_psciLoadedModules st) } - where - go = Map.fromListWith (++) . map (second (:[])) +-- | Updates the loaded externs files in the state record. +updateLoadedExterns :: ([(P.Module, P.ExternsFile)] -> [(P.Module, P.ExternsFile)]) -> PSCiState -> PSCiState +updateLoadedExterns f st = st { psciLoadedExterns = f (psciLoadedExterns st) } --- | --- Updates the state to have more let bindings. --- -updateLets :: [P.Declaration] -> PSCiState -> PSCiState -updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds } +-- | Updates the let bindings in the state record. +updateLets :: ([P.Declaration] -> [P.Declaration]) -> PSCiState -> PSCiState +updateLets f st = st { psciLetBindings = f (psciLetBindings st) } --- | --- Updates the state to have more let bindings. --- -updateForeignFiles :: Map P.ModuleName FilePath -> PSCiState -> PSCiState -updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `Map.union` fs } +-- * Commands -- | -- Valid Meta-commands for PSCI @@ -140,14 +92,6 @@ data Command -- | BrowseModule P.ModuleName -- | - -- Load a file for use with importing - -- - | LoadFile FilePath - -- | - -- Load a foreign module - -- - | LoadForeign FilePath - -- | -- Exit PSCI -- | QuitPSCi @@ -198,8 +142,6 @@ data Directive | Quit | Reset | Browse - | Load - | Foreign | Type | Kind | Show diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 1eef9da9ed..f0618f36a6 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -14,6 +14,8 @@ module Language.PureScript.Make -- * Implementation of Make API using files on disk , Make(..) , runMake + , makeIO + , readTextFile , buildMakeActions ) where @@ -290,6 +292,11 @@ makeIO f io = do e <- liftIO $ tryIOError io either (throwError . singleError . f) return e +-- | Read a text file in the 'Make' monad, capturing any errors using the +-- 'MonadError' instance. +readTextFile :: FilePath -> Make String +readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path + -- Traverse (Either e) instance (base 4.7) traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b) traverseEither _ (Left x) = pure (Left x) @@ -400,9 +407,6 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = progress :: ProgressMessage -> Make () progress = liftIO . putStrLn . renderProgressMessage -readTextFile :: FilePath -> Make String -readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path - -- | -- Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module. diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index eeafb9b1e6..1047607c36 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -6,10 +6,8 @@ module TestPsci where import Prelude () import Prelude.Compat -import Control.Monad.Trans.State.Strict (runStateT) -import Control.Monad (when, forM) -import Control.Monad.Writer.Strict (runWriterT) -import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.State.Strict (evalStateT) +import Control.Monad (when) import Data.List (sort) @@ -17,16 +15,15 @@ import System.Exit (exitFailure) import System.Console.Haskeline import System.FilePath (()) import System.Directory (getCurrentDirectory) -import System.IO.UTF8 (readUTF8File) import qualified System.FilePath.Glob as Glob import Test.HUnit import qualified Language.PureScript as P -import PSCi.Module (loadAllModules) -import PSCi.Completion -import PSCi.Types +import Language.PureScript.Interactive.Module (loadAllModules) +import Language.PureScript.Interactive.Completion +import Language.PureScript.Interactive.Types import TestUtils (supportModules) @@ -49,11 +46,10 @@ completionTests = completionTestData :: [(String, [String])] completionTestData = -- basic directives - [ (":h", [":help"]) + [ (":h", [":help"]) , (":re", [":reset"]) - , (":q", [":quit"]) - , (":mo", [":module"]) - , (":b", [":browse"]) + , (":q", [":quit"]) + , (":b", [":browse"]) -- :browse should complete module names , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"]) @@ -63,10 +59,6 @@ completionTestData = , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"]) , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"]) - -- :load, :module should complete file paths - , (":l tests/support/psci/", [":l tests/support/psci/Sample.purs"]) - , (":module tests/support/psci/", [":module tests/support/psci/Sample.purs"]) - -- :quit, :help, :reset should not complete , (":help ", []) , (":quit ", []) @@ -122,7 +114,7 @@ assertCompletedOk (line, expecteds) = do runCM :: CompletionM a -> IO a runCM act = do psciState <- getPSCiState - fmap fst (runStateT (liftCompletionM act) psciState) + evalStateT (liftCompletionM act) psciState getPSCiState :: IO PSCiState getPSCiState = do @@ -130,17 +122,15 @@ getPSCiState = do let supportDir = cwd "tests" "support" "bower_components" let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir pursFiles <- supportFiles "purs" - jsFiles <- supportFiles "js" modulesOrFirstError <- loadAllModules pursFiles - foreignFiles <- forM jsFiles (\f -> (f,) <$> readUTF8File f) - Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles case modulesOrFirstError of Left err -> print err >> exitFailure Right modules -> let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)] - in return (mkPSCiState imports modules foreigns [] []) + dummyExterns = P.internalError "TestPsci: dummyExterns should not be used" + in return (PSCiState imports [] (zip (map snd modules) (repeat dummyExterns))) controlMonadSTasST :: ImportedModule controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST")) From 7620ec3f22351b747b698b9f8ab160fc7b7357ff Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 13 May 2016 18:23:57 +0200 Subject: [PATCH 0414/1580] poll to check if the server is running (#2121) * poll to check if the server is running throw an exception after 2.5 sec * call quitServer --- tests/Language/PureScript/Ide/Integration.hs | 27 ++++++++++++++++++-- 1 file changed, 25 insertions(+), 2 deletions(-) diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs index 6a05a72fe3..f13c4b5b32 100644 --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -31,6 +31,7 @@ module Language.PureScript.Ide.Integration , addImplicitImport , loadModule , loadModuleWithDeps + , getCwd , getFlexCompletions , getType , rebuildModule @@ -48,13 +49,14 @@ import Data.Aeson import Data.Aeson.Types import qualified Data.ByteString.Lazy.UTF8 as BSL import Data.Either (isRight) -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, isNothing) import qualified Data.Text as T import qualified Data.Vector as V import Language.PureScript.Ide.Util import System.Directory import System.Exit import System.FilePath +import System.IO.Error (mkIOError, userErrorType) import System.Process projectDirectory :: IO FilePath @@ -77,9 +79,15 @@ stopServer = terminateProcess withServer :: IO a -> IO a withServer s = do _ <- startServer + started <- tryNTimes 5 (shush <$> (try getCwd :: IO (Either SomeException String))) + when (isNothing started) $ + throwIO (mkIOError userErrorType "psc-ide-server didn't start in time" Nothing Nothing) r <- s quitServer - return r + pure r + +shush :: Either a b -> Maybe b +shush = either (const Nothing) Just -- project management utils @@ -93,6 +101,16 @@ compileTestProject = do } isSuccess <$> waitForProcess procHandle +tryNTimes :: Int -> IO (Maybe a) -> IO (Maybe a) +tryNTimes 0 _ = pure Nothing +tryNTimes n action = do + r <- action + case r of + Nothing -> do + threadDelay 500000 + tryNTimes (n - 1) action + Just a -> pure (Just a) + deleteOutputFolder :: IO () deleteOutputFolder = do odir <- fmap ( "output") projectDirectory @@ -137,6 +155,11 @@ reset = do _ <- try $ sendCommand resetCommand :: IO (Either SomeException String) return () +getCwd :: IO String +getCwd = do + let cwdCommand = object ["command" .= ("cwd" :: String)] + sendCommand cwdCommand + loadModuleWithDeps :: String -> IO String loadModuleWithDeps m = sendCommand $ load [] [m] From 9f4381edefaad330dfb5e3756d4511c8675fad50 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 13 May 2016 11:46:50 +0100 Subject: [PATCH 0415/1580] Update parsec, fixes Number literal parsing #2115 --- examples/passing/NumberLiterals.purs | 39 ++++++++++++++++++++++++++++ purescript.cabal | 2 +- stack.yaml | 1 + 3 files changed, 41 insertions(+), 1 deletion(-) create mode 100644 examples/passing/NumberLiterals.purs diff --git a/examples/passing/NumberLiterals.purs b/examples/passing/NumberLiterals.purs new file mode 100644 index 0000000000..46b789d5ed --- /dev/null +++ b/examples/passing/NumberLiterals.purs @@ -0,0 +1,39 @@ +module Main where + +-- See issue #2115. + +import Prelude +import Test.Assert (assert') +import Control.Monad.Eff.Console (log) + +main = do + test "0.17" 0.17 + test "0.25996181067141905" 0.25996181067141905 + test "0.3572019862807257" 0.3572019862807257 + test "0.46817723004874223" 0.46817723004874223 + test "0.9640035681058178" 0.9640035681058178 + test "4.23808622486133" 4.23808622486133 + test "4.540362294799751" 4.540362294799751 + test "5.212384849884261" 5.212384849884261 + test "13.958257048123212" 13.958257048123212 + test "32.96176575630599" 32.96176575630599 + test "38.47735512322269" 38.47735512322269 + + test "10000000000" 1e10 + test "10000000000" 1.0e10 + test "0.00001" 1e-5 + test "0.00001" 1.0e-5 + test "1.5339794352098402e-118" 1.5339794352098402e-118 + test "2.108934760892056e-59" 2.108934760892056e-59 + test "2.250634744599241e-19" 2.250634744599241e-19 + test "5.960464477539063e-8" 5.960464477539063e-8 + test "5e-324" 5e-324 + test "5e-324" 5.0e-324 + + log "Done" + +test str num = + if (show num == str) + then pure unit + else flip assert' false $ + "Expected " <> show str <> ", got " <> show (show num) <> "." diff --git a/purescript.cabal b/purescript.cabal index 56f495e62e..8df8938b40 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -109,7 +109,7 @@ library monad-logger >= 0.3 && < 0.4, mtl >= 2.1.0 && < 2.3.0, parallel >= 3.2 && < 3.3, - parsec -any, + parsec >=3.1.10, pattern-arrows >= 0.0.2 && < 0.1, pipes >= 4.0.0 && < 4.2.0, pipes-http -any, diff --git a/stack.yaml b/stack.yaml index 9f87d0ed7c..5a35886122 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,4 +4,5 @@ packages: extra-deps: - bower-json-0.8.0 - language-javascript-0.6.0.4 +- parsec-3.1.11 flags: {} From 3fbe01d39182a28f2865cf6f8adbd160f0180b97 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 13 May 2016 19:32:15 +0200 Subject: [PATCH 0416/1580] Small fixes (#2114) * Small fixes * we dropped support for old ghc versions * removes references to Prelude.bind * remove traverseEither --- src/Language/PureScript/Make.hs | 7 +------ src/Language/PureScript/Sugar.hs | 2 +- src/Language/PureScript/Sugar/CaseDeclarations.hs | 6 +----- src/Language/PureScript/Sugar/DoNotation.hs | 10 +++++++--- 4 files changed, 10 insertions(+), 15 deletions(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index f0618f36a6..3f30a46788 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -297,11 +297,6 @@ makeIO f io = do readTextFile :: FilePath -> Make String readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path --- Traverse (Either e) instance (base 4.7) -traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b) -traverseEither _ (Left x) = pure (Left x) -traverseEither f (Right y) = Right <$> f y - -- | -- A set of make actions that read and write modules from the given directory. -- @@ -317,7 +312,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime)) getInputTimestamp mn = do let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap - e1 <- traverseEither getTimestamp path + e1 <- traverse getTimestamp path fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns return $ fmap (max fPath) e1 diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 9e343c7413..7ec61cf0f8 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -34,7 +34,7 @@ import Language.PureScript.Sugar.TypeDeclarations as S -- -- * Desugar operator sections -- --- * Desugar do-notation using the @Prelude.Monad@ type class +-- * Desugar do-notation -- -- * Desugar top-level case declarations into explicit case expressions -- diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 333724739c..d8cd5714c8 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -9,6 +9,7 @@ module Language.PureScript.Sugar.CaseDeclarations import Prelude.Compat +import Data.Either (isLeft) import Data.List (nub, groupBy, foldl1') import Data.Maybe (catMaybes, mapMaybe) @@ -24,11 +25,6 @@ import Language.PureScript.Names import Language.PureScript.Traversals import Language.PureScript.TypeChecker.Monad (guardWith) --- Data.Either.isLeft (base 4.7) -isLeft :: Either a b -> Bool -isLeft (Left _) = True -isLeft (Right _) = False - -- | -- Replace all top-level binders in a module with case expressions. -- diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 8c3197846c..452481e276 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -1,6 +1,6 @@ -- | -- This module implements the desugaring pass which replaces do-notation statements with --- appropriate calls to bind from the Prelude.Monad type class. +-- appropriate calls to bind. -- module Language.PureScript.Sugar.DoNotation (desugarDoModule) where @@ -17,12 +17,16 @@ import Language.PureScript.Names import qualified Language.PureScript.Constants as C -- | --- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.bind function, --- and all @DoNotationLet@ constructors with let expressions. +-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with +-- applications of the bind function in scope, and all @DoNotationLet@ +-- constructors with let expressions. -- desugarDoModule :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Module -> m Module desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarDo <*> pure exts +-- | +-- Desugar a single do statement +-- desugarDo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> rethrowWithPosition pos (desugarDo d) desugarDo d = From 46f1687d9409d3f1fed348e48750342bfd8efb30 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 14 May 2016 16:25:34 +0100 Subject: [PATCH 0417/1580] Add a mechanism for invalidating that AppVeyor cache --- appveyor.yml | 4 +--- appveyor/cache-buster.txt | 8 ++++++++ 2 files changed, 9 insertions(+), 3 deletions(-) create mode 100644 appveyor/cache-buster.txt diff --git a/appveyor.yml b/appveyor.yml index 706a8d7b24..0f6685bb82 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -3,12 +3,10 @@ version: '{build}' environment: # Keep the path as short as possible, just in case. STACK_ROOT: c:\s - # Appveyor does not seem to be able to cope with the symbolic link - # stack.yaml, so this is a workaround. RELEASE_USER: purescript RELEASE_REPO: purescript cache: -- c:\s +- c:\s -> appveyor/cache-buster.txt install: - git submodule update --init - ps: Install-Product node 5 diff --git a/appveyor/cache-buster.txt b/appveyor/cache-buster.txt new file mode 100644 index 0000000000..8512adaf07 --- /dev/null +++ b/appveyor/cache-buster.txt @@ -0,0 +1,8 @@ +This file acts as a cache buster for the AppVeyor (Windows CI) build +cache. In order to invalidate the AppVeyor build cache, simply make a +change to the number at the end of this file and commit. + +See http://www.appveyor.com/docs/build-cache#cache-dependencies for more +information. + +Increment me to invalidate the cache: 0 From 3a21231450b49fd44b1064caba2ac7d09a46bdfb Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 14 May 2016 12:41:20 -0700 Subject: [PATCH 0418/1580] Recommend using save-dev for psci support --- src/Language/PureScript/Interactive/Message.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Interactive/Message.hs b/src/Language/PureScript/Interactive/Message.hs index 196aa762b6..22ea272e5d 100644 --- a/src/Language/PureScript/Interactive/Message.hs +++ b/src/Language/PureScript/Interactive/Message.hs @@ -42,7 +42,7 @@ supportModuleMessage = unlines [ "PSCi requires the purescript-psci-support package to be installed." , "You can install it using Bower as follows:" , "" - , " bower i purescript-psci-support --save" + , " bower i purescript-psci-support --save-dev" , "" , "For help getting started, visit http://wiki.purescript.org/PSCi" ] From ef147686b1aa34a6a41adcb3d9877bd6e19ab65a Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 14 May 2016 19:25:24 +0100 Subject: [PATCH 0419/1580] Only allow one module per file --- examples/docs/src/Clash.purs | 28 ------------------ examples/docs/src/Clash1.purs | 3 ++ examples/docs/src/Clash1a.purs | 9 ++++++ examples/docs/src/Clash2.purs | 3 ++ examples/docs/src/Clash2a.purs | 9 ++++++ examples/docs/src/ImportedTwice.purs | 22 +++----------- examples/docs/src/ImportedTwiceA.purs | 8 +++++ examples/docs/src/ImportedTwiceB.purs | 4 +++ examples/docs/src/MultiVirtual.purs | 21 -------------- examples/docs/src/MultiVirtual1.purs | 4 +++ examples/docs/src/MultiVirtual2.purs | 9 ++++++ examples/docs/src/MultiVirtual3.purs | 4 +++ examples/docs/src/NewOperators.purs | 7 ----- examples/docs/src/NewOperators2.purs | 6 ++++ .../docs/src/TypeClassWithoutMembers.purs | 10 ++----- .../TypeClassWithoutMembersIntermediate.purs | 5 ++++ .../PureScript/Parser/Declarations.hs | 29 ++++++++----------- tests/TestDocs.hs | 4 +-- 18 files changed, 84 insertions(+), 101 deletions(-) create mode 100644 examples/docs/src/Clash1.purs create mode 100644 examples/docs/src/Clash1a.purs create mode 100644 examples/docs/src/Clash2.purs create mode 100644 examples/docs/src/Clash2a.purs create mode 100644 examples/docs/src/ImportedTwiceA.purs create mode 100644 examples/docs/src/ImportedTwiceB.purs create mode 100644 examples/docs/src/MultiVirtual1.purs create mode 100644 examples/docs/src/MultiVirtual2.purs create mode 100644 examples/docs/src/MultiVirtual3.purs create mode 100644 examples/docs/src/NewOperators2.purs create mode 100644 examples/docs/src/TypeClassWithoutMembersIntermediate.purs diff --git a/examples/docs/src/Clash.purs b/examples/docs/src/Clash.purs index 6da44eeddf..a2fef87da6 100644 --- a/examples/docs/src/Clash.purs +++ b/examples/docs/src/Clash.purs @@ -2,31 +2,3 @@ module Clash (module Clash1) where import Clash1 as Clash1 import Clash2 as Clash2 - -module Clash1 (module Clash1a) where - -import Clash1a - -module Clash1a where - -value :: Int -value = 0 - -type Type = Int - -class TypeClass a where - typeClassMember :: a - -module Clash2 (module Clash2a) where - -import Clash2a - -module Clash2a where - -value :: String -value = "hello" - -type Type = String - -class TypeClass a b where - typeClassMember :: a -> b diff --git a/examples/docs/src/Clash1.purs b/examples/docs/src/Clash1.purs new file mode 100644 index 0000000000..b3fc7710ad --- /dev/null +++ b/examples/docs/src/Clash1.purs @@ -0,0 +1,3 @@ +module Clash1 (module Clash1a) where + +import Clash1a diff --git a/examples/docs/src/Clash1a.purs b/examples/docs/src/Clash1a.purs new file mode 100644 index 0000000000..c21260f562 --- /dev/null +++ b/examples/docs/src/Clash1a.purs @@ -0,0 +1,9 @@ +module Clash1a where + +value :: Int +value = 0 + +type Type = Int + +class TypeClass a where + typeClassMember :: a diff --git a/examples/docs/src/Clash2.purs b/examples/docs/src/Clash2.purs new file mode 100644 index 0000000000..9c531ea7be --- /dev/null +++ b/examples/docs/src/Clash2.purs @@ -0,0 +1,3 @@ +module Clash2 (module Clash2a) where + +import Clash2a diff --git a/examples/docs/src/Clash2a.purs b/examples/docs/src/Clash2a.purs new file mode 100644 index 0000000000..5405daf9ed --- /dev/null +++ b/examples/docs/src/Clash2a.purs @@ -0,0 +1,9 @@ +module Clash2a where + +value :: String +value = "hello" + +type Type = String + +class TypeClass a b where + typeClassMember :: a -> b diff --git a/examples/docs/src/ImportedTwice.purs b/examples/docs/src/ImportedTwice.purs index fc135458aa..c8b297d578 100644 --- a/examples/docs/src/ImportedTwice.purs +++ b/examples/docs/src/ImportedTwice.purs @@ -4,24 +4,10 @@ -- re-exports it from Control.Monad.Trans). module ImportedTwice - ( module A - , module B + ( module ImportedTwiceA + , module ImportedTwiceB ) where -import A -import B - -module A - ( module B ) - where - -import B - -bar :: Int -bar = 1 - -module B where - -foo :: Int -foo = 0 +import ImportedTwiceA +import ImportedTwiceB diff --git a/examples/docs/src/ImportedTwiceA.purs b/examples/docs/src/ImportedTwiceA.purs new file mode 100644 index 0000000000..9acf57e903 --- /dev/null +++ b/examples/docs/src/ImportedTwiceA.purs @@ -0,0 +1,8 @@ +module ImportedTwiceA + ( module ImportedTwiceB ) + where + +import ImportedTwiceB + +bar :: Int +bar = 1 diff --git a/examples/docs/src/ImportedTwiceB.purs b/examples/docs/src/ImportedTwiceB.purs new file mode 100644 index 0000000000..6212793f58 --- /dev/null +++ b/examples/docs/src/ImportedTwiceB.purs @@ -0,0 +1,4 @@ +module ImportedTwiceB where + +foo :: Int +foo = 0 diff --git a/examples/docs/src/MultiVirtual.purs b/examples/docs/src/MultiVirtual.purs index 61ef6f8db2..19b766f69c 100644 --- a/examples/docs/src/MultiVirtual.purs +++ b/examples/docs/src/MultiVirtual.purs @@ -4,24 +4,3 @@ module MultiVirtual import MultiVirtual1 as X import MultiVirtual2 as X - - -module MultiVirtual1 where - -foo :: Int -foo = 1 - -module MultiVirtual2 - ( module MultiVirtual2 - , module MultiVirtual3 - ) where - -import MultiVirtual3 - -bar :: Int -bar = 2 - -module MultiVirtual3 where - -baz :: Int -baz = 3 diff --git a/examples/docs/src/MultiVirtual1.purs b/examples/docs/src/MultiVirtual1.purs new file mode 100644 index 0000000000..eb756c0942 --- /dev/null +++ b/examples/docs/src/MultiVirtual1.purs @@ -0,0 +1,4 @@ +module MultiVirtual1 where + +foo :: Int +foo = 1 diff --git a/examples/docs/src/MultiVirtual2.purs b/examples/docs/src/MultiVirtual2.purs new file mode 100644 index 0000000000..1d1dcd75fd --- /dev/null +++ b/examples/docs/src/MultiVirtual2.purs @@ -0,0 +1,9 @@ +module MultiVirtual2 + ( module MultiVirtual2 + , module MultiVirtual3 + ) where + +import MultiVirtual3 + +bar :: Int +bar = 2 diff --git a/examples/docs/src/MultiVirtual3.purs b/examples/docs/src/MultiVirtual3.purs new file mode 100644 index 0000000000..9da3b755f8 --- /dev/null +++ b/examples/docs/src/MultiVirtual3.purs @@ -0,0 +1,4 @@ +module MultiVirtual3 where + +baz :: Int +baz = 3 diff --git a/examples/docs/src/NewOperators.purs b/examples/docs/src/NewOperators.purs index b8c20c4781..61c0a7ba92 100644 --- a/examples/docs/src/NewOperators.purs +++ b/examples/docs/src/NewOperators.purs @@ -3,10 +3,3 @@ module NewOperators where import NewOperators2 - -module NewOperators2 where - -infixl 8 _compose as >>> - -_compose :: forall a b c. (b -> c) -> (a -> b) -> (a -> c) -_compose f g x = f (g x) diff --git a/examples/docs/src/NewOperators2.purs b/examples/docs/src/NewOperators2.purs new file mode 100644 index 0000000000..67cc46c9dc --- /dev/null +++ b/examples/docs/src/NewOperators2.purs @@ -0,0 +1,6 @@ +module NewOperators2 where + +infixl 8 _compose as >>> + +_compose :: forall a b c. (b -> c) -> (a -> b) -> (a -> c) +_compose f g x = f (g x) diff --git a/examples/docs/src/TypeClassWithoutMembers.purs b/examples/docs/src/TypeClassWithoutMembers.purs index d27e022802..fd06102c4a 100644 --- a/examples/docs/src/TypeClassWithoutMembers.purs +++ b/examples/docs/src/TypeClassWithoutMembers.purs @@ -1,11 +1,5 @@ module TypeClassWithoutMembers - ( module Intermediate ) + ( module TypeClassWithoutMembersIntermediate ) where -import Intermediate - -module Intermediate - ( module SomeTypeClass ) - where - -import SomeTypeClass (class SomeClass) +import TypeClassWithoutMembersIntermediate diff --git a/examples/docs/src/TypeClassWithoutMembersIntermediate.purs b/examples/docs/src/TypeClassWithoutMembersIntermediate.purs new file mode 100644 index 0000000000..5aefd35a15 --- /dev/null +++ b/examples/docs/src/TypeClassWithoutMembersIntermediate.purs @@ -0,0 +1,5 @@ +module TypeClassWithoutMembersIntermediate + ( module SomeTypeClass ) + where + +import SomeTypeClass (class SomeClass) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 16b467bcb0..4a074c5dea 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -4,7 +4,6 @@ module Language.PureScript.Parser.Declarations ( parseDeclaration , parseModule - , parseModules , parseModulesFromFiles , parseValue , parseGuard @@ -258,29 +257,31 @@ parseModule = do exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef reserved "where" decls <- mark (P.many (same *> parseDeclaration)) + _ <- P.eof end <- P.getPosition let ss = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos end) return $ Module ss comments name decls exports -- | Parse a collection of modules in parallel -parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m) => - (k -> FilePath) -> [(k, String)] -> m [(k, Module)] -parseModulesFromFiles toFilePath input = do - modules <- flip parU id $ map wrapError $ inParallel $ flip map input $ \(k, content) -> do +parseModulesFromFiles + :: forall m k + . MonadError MultipleErrors m + => (k -> FilePath) + -> [(k, String)] + -> m [(k, Module)] +parseModulesFromFiles toFilePath input = + flip parU wrapError . inParallel . flip map input $ \(k, content) -> do let filename = toFilePath k ts <- lex filename content - ms <- runTokenParser filename parseModules ts - return (k, ms) - return $ collect modules + m <- runTokenParser filename parseModule ts + return (k, m) where - collect :: [(k, [v])] -> [(k, v)] - collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ] wrapError :: Either P.ParseError a -> m a wrapError = either (throwError . MultipleErrors . pure . toPositionedError) return -- It is enough to force each parse result to WHNF, since success or failure can't be -- determined until the end of the file, so this effectively distributes parsing of each file -- to a different spark. - inParallel :: [Either P.ParseError (k, [Module])] -> [Either P.ParseError (k, [Module])] + inParallel :: [Either P.ParseError (k, a)] -> [Either P.ParseError (k, a)] inParallel = withStrategy (parList rseq) @@ -291,12 +292,6 @@ toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start e start = (C.toSourcePos . P.errorPos) perr end = start --- | --- Parse a collection of modules --- -parseModules :: TokenParser [Module] -parseModules = mark (P.many (same *> parseModule)) <* P.eof - booleanLiteral :: TokenParser Bool booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False) diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index df3707062a..6a645c159a 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -266,8 +266,8 @@ testCases = ]) , ("TypeClassWithoutMembers", - [ ShouldBeDocumented (n "Intermediate") "SomeClass" [] - , ChildShouldNotBeDocumented (n "Intermediate") "SomeClass" "member" + [ ShouldBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" [] + , ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member" ]) , ("NewOperators", From b7a6f2ba2994db703faf2272a7b8516ed3812258 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 15 May 2016 16:45:11 +0100 Subject: [PATCH 0420/1580] Use Map rather than list in Exports --- .../PureScript/Docs/Convert/ReExports.hs | 19 +++-- src/Language/PureScript/Linter/Imports.hs | 25 +++--- src/Language/PureScript/Sugar/Names.hs | 48 ++++++----- src/Language/PureScript/Sugar/Names/Env.hs | 80 ++++++++++--------- .../PureScript/Sugar/Names/Exports.hs | 68 ++++++++-------- .../PureScript/Sugar/Names/Imports.hs | 65 +++++++-------- 6 files changed, 160 insertions(+), 145 deletions(-) diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 9fd1b5a00c..f4bce8caeb 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -4,7 +4,7 @@ module Language.PureScript.Docs.Convert.ReExports import Prelude.Compat -import Control.Arrow ((&&&), first, second) +import Control.Arrow ((&&&), second) import Control.Monad import Control.Monad.Reader.Class (MonadReader, ask) import Control.Monad.State.Class (MonadState, gets, modify) @@ -96,7 +96,7 @@ getReExports env mn = -- * Filters type class declarations to ensure that only re-exported type -- class members are listed. -- -collectDeclarations :: +collectDeclarations :: forall m. (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) => P.Imports -> P.Exports -> @@ -111,13 +111,20 @@ collectDeclarations imports exports = do (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses let filteredTypes = filterDataConstructors expCtors types - let filteredClasses = filterTypeClassMembers (map fst expVals) classes + let filteredClasses = filterTypeClassMembers (Map.keys expVals) classes pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps])) where + + collect + :: (Eq a, Show a) + => (P.ModuleName -> a -> m (P.ModuleName, [b])) + -> [P.ImportRecord a] + -> Map a P.ModuleName + -> m (Map P.ModuleName [b]) collect lookup' imps exps = do - imps' <- traverse (findImport imps) exps + imps' <- traverse (findImport imps) $ Map.toList exps Map.fromListWith (<>) <$> traverse (uncurry lookup') imps' expVals = P.exportedValues exports @@ -126,13 +133,13 @@ collectDeclarations imports exports = do expValOps = P.exportedValueOps exports impValOps = concat (Map.elems (P.importedValueOps imports)) - expTypes = map (first fst) (P.exportedTypes exports) + expTypes = Map.map snd (P.exportedTypes exports) impTypes = concat (Map.elems (P.importedTypes imports)) expTypeOps = P.exportedTypeOps exports impTypeOps = concat (Map.elems (P.importedTypeOps imports)) - expCtors = concatMap (snd . fst) (P.exportedTypes exports) + expCtors = concatMap fst (Map.elems (P.exportedTypes exports)) expTCs = P.exportedTypeClasses exports impTCs = concat (Map.elems (P.importedTypeClasses imports)) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 540dfac4bc..1e9478d81a 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -158,17 +158,17 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do -- that are implicitly exported and then re-exported. elaborateUsed :: Imports -> ModuleName -> UsedImports -> UsedImports elaborateUsed scope mne used = - let classes = extractByQual mne (importedTypeClasses scope) TyClassName - types = extractByQual mne (importedTypes scope) TyName - dctors = extractByQual mne (importedDataConstructors scope) DctorName - values = extractByQual mne (importedValues scope) IdentName - in foldr go used (classes ++ types ++ dctors ++ values) + foldr go used + $ extractByQual mne (importedTypeClasses scope) TyClassName + ++ extractByQual mne (importedTypes scope) TyName + ++ extractByQual mne (importedDataConstructors scope) DctorName + ++ extractByQual mne (importedValues scope) IdentName where go :: (ModuleName, Qualified Name) -> UsedImports -> UsedImports go (q, name) = M.alter (Just . maybe [name] (name :)) q extractByQual - :: (Eq a) + :: Eq a => ModuleName -> M.Map (Qualified a) [ImportRecord a] -> (a -> Name) @@ -257,21 +257,20 @@ lintImportDecl env mni qualifierName names declType allowImplicit = dtys :: ModuleName - -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] - dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env + -> M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) + dtys mn = maybe M.empty exportedTypes $ envModuleExports <$> mn `M.lookup` env dctorsForType :: ModuleName -> ProperName 'TypeName -> [ProperName 'ConstructorName] - dctorsForType mn tn = - maybe [] (snd . fst) $ find ((== tn) . fst . fst) (dtys mn) + dctorsForType mn tn = maybe [] fst $ tn `M.lookup` dtys mn typeForDCtor :: ModuleName -> ProperName 'ConstructorName -> Maybe (ProperName 'TypeName) - typeForDCtor mn pn = fst . fst <$> find (elem pn . snd . fst) (dtys mn) + typeForDCtor mn pn = fst <$> find (elem pn . fst . snd) (M.toList (dtys mn)) findUsedRefs :: Env @@ -310,8 +309,8 @@ findUsedRefs env mni qn names = findTypeForDctor mn dctor = case mn `M.lookup` env of Just (_, _, exps) -> - case find (elem dctor . snd . fst) (exportedTypes exps) of - Just ((ty, _), _) -> ty + case find (elem dctor . fst . snd) (M.toList (exportedTypes exps)) of + Just (ty, _) -> ty Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor" Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor" diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index fe3c9a919a..75fb7ca376 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -10,7 +10,7 @@ module Language.PureScript.Sugar.Names import Prelude.Compat -import Control.Arrow (first) +import Control.Arrow (first, second) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Lazy @@ -72,10 +72,10 @@ desugarImportsWithEnv externs modules = do return $ M.insert efModuleName (ss, imps, exps) env where - exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] - exportedTypes = mapMaybe toExportedType efExports + exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) + exportedTypes = M.fromList $ mapMaybe toExportedType efExports where - toExportedType (TypeRef tyCon dctors) = Just ((tyCon, fromMaybe (mapMaybe forTyCon efDeclarations) dctors), efModuleName) + toExportedType (TypeRef tyCon dctors) = Just (tyCon, (fromMaybe (mapMaybe forTyCon efDeclarations) dctors, efModuleName)) where forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName) forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn @@ -83,17 +83,17 @@ desugarImportsWithEnv externs modules = do toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r toExportedType _ = Nothing - exportedTypeOps :: [(OpName 'TypeOpName, ModuleName)] - exportedTypeOps = (, efModuleName) <$> mapMaybe getTypeOpRef efExports + exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName + exportedTypeOps = M.fromList $ (, efModuleName) <$> mapMaybe getTypeOpRef efExports - exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)] - exportedTypeClasses = (, efModuleName) <$> mapMaybe getTypeClassRef efExports + exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName + exportedTypeClasses = M.fromList $ (, efModuleName) <$> mapMaybe getTypeClassRef efExports - exportedValues :: [(Ident, ModuleName)] - exportedValues = (, efModuleName) <$> mapMaybe getValueRef efExports + exportedValues :: M.Map Ident ModuleName + exportedValues = M.fromList $ (, efModuleName) <$> mapMaybe getValueRef efExports - exportedValueOps :: [(OpName 'ValueOpName, ModuleName)] - exportedValueOps = (, efModuleName) <$> mapMaybe getValueOpRef efExports + exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName + exportedValueOps = M.fromList $ (, efModuleName) <$> mapMaybe getValueOpRef efExports updateEnv :: ([Module], Env) -> Module -> m ([Module], Env) updateEnv (ms, env) m@(Module ss _ mn _ refs) = @@ -122,7 +122,7 @@ desugarImportsWithEnv externs modules = do elaborateExports :: Exports -> Module -> Module elaborateExports exps (Module ss coms mn decls refs) = Module ss coms mn decls $ - Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (my exportedTypes) ++ + Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) myTypes ++ map TypeOpRef (my exportedTypeOps) ++ map TypeClassRef (my exportedTypeClasses) ++ map ValueRef (my exportedValues) ++ @@ -131,8 +131,14 @@ elaborateExports exps (Module ss coms mn decls refs) = where -- Extracts a list of values from the exports and filters out any values that -- are re-exports from other modules. - my :: (Exports -> [(a, ModuleName)]) -> [a] - my f = fst `map` filter ((== mn) . snd) (f exps) + my :: (Exports -> M.Map a ModuleName) -> [a] + my = map fst <$> filt (== mn) + + myTypes :: [(ProperName 'TypeName, [ProperName 'ConstructorName])] + myTypes = second fst <$> filt ((== mn) . snd) exportedTypes + + filt :: (b -> Bool) -> (Exports -> M.Map a b) -> [(a, b)] + filt predicate f = M.toList $ predicate `M.filter` f exps -- | -- Replaces all local names with qualified names within a module and checks that all existing @@ -294,26 +300,26 @@ renameInModule env imports (Module ss coms mn decls exps) = -- Used when performing an update to qualify values and classes with their -- module of original definition. - resolve :: (Eq a) => [(a, ModuleName)] -> a -> Maybe (Qualified a) - resolve as name = mkQualified name <$> name `lookup` as + resolve :: Ord a => M.Map a ModuleName -> a -> Maybe (Qualified a) + resolve as name = mkQualified name <$> name `M.lookup` as -- Used when performing an update to qualify types with their module of -- original definition. resolveType - :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] + :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) -> ProperName 'TypeName -> Maybe (Qualified (ProperName 'TypeName)) resolveType tys name = - mkQualified name . snd <$> find ((== name) . fst . fst) tys + mkQualified name . snd <$> M.lookup name tys -- Used when performing an update to qualify data constructors with their -- module of original definition. resolveDctor - :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] + :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) -> ProperName 'ConstructorName -> Maybe (Qualified (ProperName 'ConstructorName)) resolveDctor tys name = - mkQualified name . snd <$> find (elem name . snd . fst) tys + mkQualified name . snd <$> find (elem name . fst) tys -- Update names so unqualified references become qualified, and locally -- qualified references are replaced with their canoncial qualified names diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index e433f909d4..1d87db545d 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -26,7 +26,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Function (on) -import Data.List (groupBy, sortBy, nub, delete) +import Data.List (groupBy, sortBy, delete) import Data.Maybe (fromJust, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -92,7 +92,9 @@ data Imports = Imports -- , importedValueOps :: ImportMap (OpName 'ValueOpName) -- | - -- The modules that have been imported into the current scope. + -- The name of modules that have been imported into the current scope that + -- can be re-exported. If a module is imported with `as` qualification, the + -- `as` name appears here, otherwise the original name. -- , importedModules :: S.Set ModuleName -- | @@ -114,37 +116,34 @@ nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S. data Exports = Exports { -- | - -- The types exported from each module along with the module they originally - -- came from. + -- The exported types along with the module they originally came from. -- - exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] + exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) -- | - -- The type operators exported from each module along with the module they - -- originally came from. + -- The exported type operators along with the module they originally came + -- from. -- - , exportedTypeOps :: [(OpName 'TypeOpName, ModuleName)] + , exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName -- | - -- The classes exported from each module along with the module they originally - -- came from. + -- The exported classes along with the module they originally came from. -- - , exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)] + , exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName -- | - -- The values exported from each module along with the module they originally - -- came from. + -- The exported values along with the module they originally came from. -- - , exportedValues :: [(Ident, ModuleName)] + , exportedValues :: M.Map Ident ModuleName -- | - -- The value operators exported from each module along with the module they - -- originally came from. + -- The exported value operators along with the module they originally came + -- from. -- - , exportedValueOps :: [(OpName 'ValueOpName, ModuleName)] + , exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName } deriving (Show, Read) -- | -- An empty 'Exports' value. -- nullExports :: Exports -nullExports = Exports [] [] [] [] [] +nullExports = Exports M.empty M.empty M.empty M.empty M.empty -- | -- The imports and exports for a collection of modules. The 'SourceSpan' is used @@ -177,11 +176,11 @@ envModuleExports (_, _, exps) = exps primExports :: Exports primExports = nullExports - { exportedTypes = mkTypeEntry `map` M.keys primTypes - , exportedTypeClasses = mkClassEntry `map` M.keys primClasses + { exportedTypes = M.fromList $ mkTypeEntry `map` M.keys primTypes + , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys primClasses } where - mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn) + mkTypeEntry (Qualified mn name) = (name, ([], fromJust mn)) mkClassEntry (Qualified mn name) = (name, fromJust mn) -- | Environment which only contains the Prim module. @@ -202,20 +201,21 @@ exportType -> ModuleName -> m Exports exportType exps name dctors mn = do - let exTypes' = exportedTypes exps - let exTypes = filter ((/= mn) . snd) exTypes' - let exDctors = (snd . fst) `concatMap` exTypes + let exTypes = exportedTypes exps let exClasses = exportedTypeClasses exps - when (any ((== name) . fst . fst) exTypes) $ - throwConflictError ConflictingTypeDecls name - when (any ((== coerceProperName name) . fst) exClasses) $ + case name `M.lookup` exTypes of + Just (_, mn') | mn /= mn' -> throwConflictError ConflictingTypeDecls name + _ -> return () + when (coerceProperName name `M.member` exClasses) $ throwConflictError TypeConflictsWithClass name forM_ dctors $ \dctor -> do - when (dctor `elem` exDctors) $ + when (dctorExists (coerceProperName dctor) `any` exTypes) $ throwConflictError ConflictingCtorDecls dctor - when (any ((== coerceProperName dctor) . fst) exClasses) $ + when (coerceProperName dctor `M.member` exClasses) $ throwConflictError CtorConflictsWithClass dctor - return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' } + return $ exps { exportedTypes = M.insert name (dctors, mn) exTypes } + where + dctorExists dctor (dctors', mn') = mn /= mn' && elem dctor dctors' -- | -- Safely adds a type operator to some exports, returning an error if a @@ -242,10 +242,9 @@ exportTypeClass -> m Exports exportTypeClass exps name mn = do let exTypes = exportedTypes exps - let exDctors = (snd . fst) `concatMap` exTypes - when (any ((== coerceProperName name) . fst . fst) exTypes) $ + when (coerceProperName name `M.member` exTypes) $ throwConflictError ClassConflictsWithType name - when (coerceProperName name `elem` exDctors) $ + when ((elem (coerceProperName name) . fst) `any` exTypes) $ throwConflictError ClassConflictsWithCtor name classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps) return $ exps { exportedTypeClasses = classes } @@ -282,16 +281,19 @@ exportValueOp exps op mn = do -- case an error is returned. -- addExport - :: (MonadError MultipleErrors m, Eq a) + :: (MonadError MultipleErrors m, Ord a) => (a -> SimpleErrorMessage) -> a -> ModuleName - -> [(a, ModuleName)] - -> m [(a, ModuleName)] + -> M.Map a ModuleName + -> m (M.Map a ModuleName) addExport what name mn exports = - if any (\(name', mn') -> name == name' && mn /= mn') exports - then throwConflictError what name - else return $ nub $ (name, mn) : exports + case M.lookup name exports of + Just mn' + | mn == mn' -> return exports + | otherwise -> throwConflictError what name + Nothing -> + return $ M.insert name mn exports -- | -- Raises an error for when there is more than one definition for something. diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 5c0f12dd4f..98e9e7d689 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -10,7 +10,7 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Error.Class (MonadError(..)) import Data.Foldable (traverse_) -import Data.List (find, intersect) +import Data.List (intersect) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M @@ -76,11 +76,11 @@ resolveExports env ss mn imps exps refs = elaborateModuleExports result (PositionedDeclarationRef pos _ r) = warnAndRethrowWithPosition pos $ elaborateModuleExports result r elaborateModuleExports result (ModuleRef name) | name == mn = do - let types' = exportedTypes result ++ exportedTypes exps - let typeOps' = exportedTypeOps result ++ exportedTypeOps exps - let classes' = exportedTypeClasses result ++ exportedTypeClasses exps - let values' = exportedValues result ++ exportedValues exps - let valueOps' = exportedValueOps result ++ exportedValueOps exps + let types' = exportedTypes result `M.union` exportedTypes exps + let typeOps' = exportedTypeOps result `M.union` exportedTypeOps exps + let classes' = exportedTypeClasses result `M.union` exportedTypeClasses exps + let values' = exportedValues result `M.union` exportedValues exps + let valueOps' = exportedValueOps result `M.union` exportedValueOps exps return result { exportedTypes = types' , exportedTypeOps = typeOps' @@ -155,11 +155,12 @@ resolveExports env ss mn imps exps refs = go :: Qualified (ProperName 'TypeName) -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName) - go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do - exps' <- envModuleExports <$> mn'' `M.lookup` env - ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps') - let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mn'' then Just dctor else Nothing) dctors - return ((name, relevantDctors `intersect` dctors'), mnOrig) + go (Qualified (Just mn'') name) = + fromMaybe (internalError "Missing value in resolveTypeExports") $ do + exps' <- envModuleExports <$> mn'' `M.lookup` env + (dctors', mnOrig) <- name `M.lookup` exportedTypes exps' + let relevantDctors = mapMaybe (disqualifyFor (Just mn'')) dctors + return ((name, relevantDctors `intersect` dctors'), mnOrig) go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports" -- Looks up an imported type operator and re-qualifies it with the original @@ -194,10 +195,14 @@ resolveExports env ss mn imps exps refs = . fromMaybe (internalError "Missing value in resolveValueOp") $ resolve exportedValueOps op - resolve :: (Eq a) => (Exports -> [(a, ModuleName)]) -> Qualified a -> Maybe (Qualified a) + resolve + :: Ord a + => (Exports -> M.Map a ModuleName) + -> Qualified a + -> Maybe (Qualified a) resolve f (Qualified (Just mn'') a) = do exps' <- envModuleExports <$> mn'' `M.lookup` env - mn''' <- snd <$> find ((== a) . fst) (f exps') + mn''' <- a `M.lookup` f exps' return $ Qualified (Just mn''') a resolve _ _ = internalError "Unqualified value in resolve" @@ -219,11 +224,11 @@ filterModule -> [DeclarationRef] -> m Exports filterModule mn exps refs = do - types <- foldM filterTypes [] refs - typeOps <- foldM (filterExport TyOpName getTypeOpRef exportedTypeOps) [] refs - classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) [] refs - values <- foldM (filterExport IdentName getValueRef exportedValues) [] refs - valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) [] refs + types <- foldM filterTypes M.empty refs + typeOps <- foldM (filterExport TyOpName getTypeOpRef exportedTypeOps) M.empty refs + classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) M.empty refs + values <- foldM (filterExport IdentName getValueRef exportedValues) M.empty refs + valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) M.empty refs return Exports { exportedTypes = types , exportedTypeOps = typeOps @@ -235,21 +240,19 @@ filterModule mn exps refs = do where filterTypes - :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] + :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) -> DeclarationRef - -> m [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] + -> m (M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)) filterTypes result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes result r filterTypes result (TypeRef name expDcons) = - case matchType `find` exportedTypes exps of + case name `M.lookup` exportedTypes exps of Nothing -> throwError . errorMessage . UnknownExport $ TyName name - Just ((_, dcons), _) -> do + Just (dcons, _) -> do let expDcons' = fromMaybe dcons expDcons traverse_ (checkDcon name dcons) expDcons' - return $ ((name, expDcons'), mn) : result + return $ M.insert name (expDcons', mn) result where - -- Finds a type declaration by matching its name and defining module - matchType ((name', _), mn') = name == name' && mn == mn' -- Ensures a data constructor is exportable for a given type. Takes a type -- name, a list of exportable data constructors for the type, and the name of -- the data constructor to check. @@ -264,18 +267,19 @@ filterModule mn exps refs = do filterTypes result _ = return result filterExport - :: Eq a + :: Ord a => (a -> Name) -> (DeclarationRef -> Maybe a) - -> (Exports -> [(a, ModuleName)]) - -> [(a, ModuleName)] + -> (Exports -> M.Map a ModuleName) + -> M.Map a ModuleName -> DeclarationRef - -> m [(a, ModuleName)] + -> m (M.Map a ModuleName) filterExport toName get fromExps result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterExport toName get fromExps result r filterExport toName get fromExps result ref | Just name <- get ref = - if (name, mn) `elem` fromExps exps - then return $ (name, mn) : result - else throwError . errorMessage . UnknownExport $ toName name + case name `M.lookup` fromExps exps of + -- TODO: I'm not sure if we actually need to check mn == mn' here -gb + Just mn' | mn == mn' -> return $ M.insert name mn result + _ -> throwError . errorMessage . UnknownExport $ toName name filterExport _ _ _ result _ = return result diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 57d58e2b10..5fff7b8b3d 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -7,12 +7,10 @@ module Language.PureScript.Sugar.Names.Imports import Prelude.Compat -import Control.Arrow (first) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Data.Foldable (for_, traverse_) -import Data.List (find) import Data.Maybe (fromMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -118,30 +116,30 @@ resolveImport importModule exps imps impQual = resolveByType check (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ check r check (ValueRef name) = - checkImportExists IdentName (fst `map` exportedValues exps) name + checkImportExists IdentName (exportedValues exps) name check (ValueOpRef op) = - checkImportExists ValOpName (fst `map` exportedValueOps exps) op + checkImportExists ValOpName (exportedValueOps exps) op check (TypeRef name dctors) = do - checkImportExists TyName ((fst . fst) `map` exportedTypes exps) name - let allDctors = fst `map` allExportedDataConstructors name + checkImportExists TyName (exportedTypes exps) name + let (allDctors, _) = allExportedDataConstructors name for_ dctors $ traverse_ (checkDctorExists name allDctors) check (TypeOpRef name) = - checkImportExists TyOpName (fst `map` exportedTypeOps exps) name + checkImportExists TyOpName (exportedTypeOps exps) name check (TypeClassRef name) = - checkImportExists TyClassName (fst `map` exportedTypeClasses exps) name + checkImportExists TyClassName (exportedTypeClasses exps) name check (ModuleRef name) | isHiding = throwError . errorMessage $ ImportHidingModule name check r = internalError $ "Invalid argument to checkRefs: " ++ show r -- Check that an explicitly imported item exists in the module it is being imported from checkImportExists - :: Eq a + :: Ord a => (a -> Name) - -> [a] + -> M.Map a b -> a -> m () checkImportExists toName exports item - = when (item `notElem` exports) + = when (item `M.notMember` exports) . throwError . errorMessage $ UnknownImport importModule (toName item) @@ -177,35 +175,34 @@ resolveImport importModule exps imps impQual = resolveByType -- Import all symbols importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports importAll importer = - foldM (\m ((name, dctors), _) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps) - >>= flip (foldM (\m (name, _) -> importer m (TypeOpRef name))) (exportedTypeOps exps) - >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (exportedValues exps) - >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (exportedValueOps exps) - >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (exportedTypeClasses exps) + foldM (\m (name, (dctors, _)) -> importer m (TypeRef name (Just dctors))) imps (M.toList (exportedTypes exps)) + >>= flip (foldM (\m (name, _) -> importer m (TypeOpRef name))) (M.toList (exportedTypeOps exps)) + >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (M.toList (exportedValues exps)) + >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (M.toList (exportedValueOps exps)) + >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (M.toList (exportedTypeClasses exps)) importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports importRef prov imp (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ importRef prov imp r importRef prov imp (ValueRef name) = do - let values' = updateImports (importedValues imp) (exportedValues exps) name prov + let values' = updateImports (importedValues imp) (exportedValues exps) id name prov return $ imp { importedValues = values' } importRef prov imp (ValueOpRef name) = do - let valueOps' = updateImports (importedValueOps imp) (exportedValueOps exps) name prov + let valueOps' = updateImports (importedValueOps imp) (exportedValueOps exps) id name prov return $ imp { importedValueOps = valueOps' } importRef prov imp (TypeRef name dctors) = do - let types' = updateImports (importedTypes imp) (first fst `map` exportedTypes exps) name prov - let exportedDctors :: [(ProperName 'ConstructorName, ModuleName)] - exportedDctors = allExportedDataConstructors name - dctorNames :: [ProperName 'ConstructorName] - dctorNames = fst `map` exportedDctors - maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors - let dctors' = foldl (\m d -> updateImports m exportedDctors d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors) + let types' = updateImports (importedTypes imp) (exportedTypes exps) snd name prov + let (dctorNames, mn) = allExportedDataConstructors name + dctorLookup :: M.Map (ProperName 'ConstructorName) ModuleName + dctorLookup = M.fromList $ map (, mn) dctorNames + traverse_ (traverse_ $ checkDctorExists name dctorNames) dctors + let dctors' = foldl (\m d -> updateImports m dctorLookup id d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors) return $ imp { importedTypes = types', importedDataConstructors = dctors' } importRef prov imp (TypeOpRef name) = do - let ops' = updateImports (importedTypeOps imp) (exportedTypeOps exps) name prov + let ops' = updateImports (importedTypeOps imp) (exportedTypeOps exps) id name prov return $ imp { importedTypeOps = ops' } importRef prov imp (TypeClassRef name) = do - let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) name prov + let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) id name prov return $ imp { importedTypeClasses = typeClasses' } importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef" importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef" @@ -213,23 +210,23 @@ resolveImport importModule exps imps impQual = resolveByType -- Find all exported data constructors for a given type allExportedDataConstructors :: ProperName 'TypeName - -> [(ProperName 'ConstructorName, ModuleName)] + -> ([ProperName 'ConstructorName], ModuleName) allExportedDataConstructors name = - case find ((== name) . fst . fst) (exportedTypes exps) of - Nothing -> internalError "Invalid state in allExportedDataConstructors" - Just ((_, dctors), mn) -> map (, mn) dctors + fromMaybe (internalError "Invalid state in allExportedDataConstructors") + $ name `M.lookup` exportedTypes exps -- Add something to an import resolution list updateImports :: (Ord a) => M.Map (Qualified a) [ImportRecord a] - -> [(a, ModuleName)] + -> M.Map a b + -> (b -> ModuleName) -> a -> ImportProvenance -> M.Map (Qualified a) [ImportRecord a] - updateImports imps' exps' name prov = + updateImports imps' exps' expName name prov = let - mnOrig = fromMaybe (internalError "Invalid state in updateImports") (name `lookup` exps') + mnOrig = maybe (internalError "Invalid state in updateImports") expName (name `M.lookup` exps') rec = ImportRecord (Qualified (Just importModule) name) mnOrig prov in M.alter From 11f4898714ddc7861bd1946fe56484275b46a0c9 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 15 May 2016 12:13:08 -0700 Subject: [PATCH 0421/1580] Version 0.9 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 8df8938b40..7fe74a939f 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.8.5.0 +version: 0.9.0 cabal-version: >=1.8 build-type: Simple license: MIT From 3ca81ccb35e48b0d49bb7b5580cf636663148068 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 15 May 2016 14:37:10 -0700 Subject: [PATCH 0422/1580] Fix #2070, typed hole errors now include environment information --- src/Language/PureScript/Errors.hs | 25 ++++++++++++++------ src/Language/PureScript/Pretty/Types.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 11 ++++++--- 3 files changed, 27 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8cdf6ab4f5..4537e97b75 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -24,6 +24,7 @@ import Language.PureScript.Crash import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Pretty +import Language.PureScript.Traversals import Language.PureScript.Types import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.Constants as C @@ -112,7 +113,7 @@ data SimpleErrorMessage | ShadowedTypeVar String | UnusedTypeVar String | WildcardInferredType Type - | HoleInferredType String Type + | HoleInferredType String Type [(Ident, Type)] | MissingTypeDeclaration Ident Type | OverlappingPattern [[Binder]] Bool | IncompleteExhaustivityCheck @@ -395,7 +396,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty - gSimple (HoleInferredType name ty) = HoleInferredType name <$> f ty + gSimple (HoleInferredType name ty env) = HoleInferredType name <$> f ty <*> traverse (sndM f) env gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty @@ -494,7 +495,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap : foldMap (return . line . (" bound at " ++) . displayStartEndPos) ss unknownInfo :: Int -> Box.Box - unknownInfo u = line $ "_" ++ show u ++ " is an unknown type" + unknownInfo u = line $ "t" ++ show u ++ " is an unknown type" renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box renderSimpleErrorMessage (CannotGetFileInfo path) = @@ -817,10 +818,20 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap paras [ line "Wildcard type definition has the inferred type " , indent $ typeAsBox ty ] - renderSimpleErrorMessage (HoleInferredType name ty) = - paras [ line $ "Hole '" ++ name ++ "' has the inferred type " - , indent $ typeAsBox ty - ] + renderSimpleErrorMessage (HoleInferredType name ty env) = + paras $ [ line $ "Hole '" ++ name ++ "' has the inferred type " + , indent $ typeAsBox ty + ] ++ if null env then [] else envInfo + where + envInfo :: [Box.Box] + envInfo = [ line "in the following context:" + , indent $ paras + [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ") + , typeAsBox ty' + ] + | (ident, ty') <- take 5 env + ] + ] renderSimpleErrorMessage (MissingTypeDeclaration ident ty) = paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "." , line "It is good practice to provide type declarations as a form of documentation." diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 5f878dd2d0..255d08aede 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -34,7 +34,7 @@ typeLiterals = mkPattern match match (TypeVar var) = Just $ text var match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor - match (TUnknown u) = Just $ text $ '_' : show u + match (TUnknown u) = Just $ text $ 't' : show u match (Skolem name s _ _) = Just $ text $ name ++ show s match REmpty = Just $ text "()" match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 7d1a2a273b..c24b62d122 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -26,6 +26,7 @@ module Language.PureScript.TypeChecker.Types import Prelude.Compat +import Control.Arrow (second) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets) @@ -118,8 +119,9 @@ typesOf bindingGroupType moduleName vals = do -- Replace all the wildcards types with their inferred types replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints . WildcardInferredType $ substituteType sub ty - replace sub (ErrorMessage hints (HoleInferredType name ty)) = - ErrorMessage hints . HoleInferredType name $ substituteType sub ty + replace sub (ErrorMessage hints (HoleInferredType name ty env)) = + ErrorMessage hints $ HoleInferredType name (substituteType sub ty) + (map (second (substituteType sub)) env) replace _ em = em isHoleError :: ErrorMessage -> Bool @@ -324,7 +326,10 @@ infer' (TypedValue checkType val ty) = do return $ TypedValue True val' ty' infer' (Hole name) = do ty <- freshType - tell . errorMessage $ HoleInferredType name ty + env <- M.toList . names <$> getEnv + Just moduleName <- checkCurrentModule <$> get + let ctx = [ (ident, ty') | ((mn, ident@Ident{}), (ty', _, Defined)) <- env, mn == moduleName ] + tell . errorMessage $ HoleInferredType name ty ctx return $ TypedValue True (Hole name) ty infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do TypedValue t v ty <- infer' val From 4852b5d408b7176aeb3fce210e2cc1337af244b9 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 15 May 2016 18:36:40 -0700 Subject: [PATCH 0423/1580] Find foreign modules by name rather than comment-search (#2118) * Find foreign modules by name rather than comment-search, see #2012 * Fix tests * Use inferForeignModules in psc-ide * Always specify filepath when inferring foreign modules --- psc/Main.hs | 65 ++++++------------- psci/Main.hs | 20 ++---- purescript.cabal | 1 - src/Language/PureScript/Ide/Rebuild.hs | 27 ++++---- src/Language/PureScript/Interactive.hs | 53 +++++++-------- src/Language/PureScript/Interactive/Types.hs | 2 - src/Language/PureScript/Make.hs | 52 +++++++++------ src/Language/PureScript/Parser.hs | 1 - src/Language/PureScript/Parser/JS.hs | 46 ------------- tests/Language/PureScript/Ide/Integration.hs | 1 - tests/TestCompiler.hs | 68 ++++++++++---------- 11 files changed, 127 insertions(+), 209 deletions(-) delete mode 100644 src/Language/PureScript/Parser/JS.hs diff --git a/psc/Main.hs b/psc/Main.hs index ad0be5d519..13051d4cb1 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -1,48 +1,42 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Main where -import Control.Applicative -import Control.Monad -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Strict +import Control.Applicative +import Control.Monad +import Control.Monad.Writer.Strict -import Data.List (isSuffixOf, partition) -import Data.Version (showVersion) -import qualified Data.Map as M import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.UTF8 as BU8 +import qualified Data.Map as M +import Data.Version (showVersion) -import Options.Applicative as Opts +import qualified Language.PureScript as P +import Language.PureScript.Errors.JSON +import Language.PureScript.Make -import System.Exit (exitSuccess, exitFailure) -import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8) -import System.IO.UTF8 -import System.FilePath.Glob (glob) +import Options.Applicative as Opts -import qualified Language.PureScript as P import qualified Paths_purescript as Paths -import Language.PureScript.Make -import Language.PureScript.Errors.JSON +import System.Exit (exitSuccess, exitFailure) +import System.FilePath.Glob (glob) +import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8) +import System.IO.UTF8 data PSCMakeOptions = PSCMakeOptions { pscmInput :: [FilePath] - , pscmForeignInput :: [FilePath] , pscmOutputDir :: FilePath , pscmOpts :: P.Options , pscmUsePrefix :: Bool , pscmJSONErrors :: Bool } -data InputOptions = InputOptions - { ioInputFiles :: [FilePath] - } - -- | Argumnets: verbose, use JSON, warnings, errors printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO () printWarningsAndErrors verbose False warnings errors = do @@ -65,14 +59,12 @@ compile PSCMakeOptions{..} = do when (null input && not pscmJSONErrors) $ do hPutStrLn stderr "psc: No input files." exitFailure - let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input - moduleFiles <- readInput (InputOptions pursFiles) - inputForeign <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmForeignInput - foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile) + moduleFiles <- readInput input (makeErrors, makeWarnings) <- runMake pscmOpts $ do - (ms, foreigns) <- parseInputs moduleFiles foreignFiles - let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms - makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix + ms <- P.parseModulesFromFiles id moduleFiles + let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, Right fp)) ms + foreigns <- inferForeignModules filePathMap + let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix P.make makeActions (map snd ms) printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors exitSuccess @@ -89,28 +81,14 @@ globWarningOnMisses warn = concatMapM globWithWarning return paths concatMapM f = liftM concat . mapM f -readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)] -readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readUTF8File inFile - -parseInputs :: (MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m) - => [(Either P.RebuildPolicy FilePath, String)] - -> [(FilePath, P.ForeignJS)] - -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName FilePath) -parseInputs modules foreigns = - (,) <$> P.parseModulesFromFiles (either (const "") id) modules - <*> P.parseForeignModulesFromFiles foreigns +readInput :: [FilePath] -> IO [(FilePath, String)] +readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8File inFile inputFile :: Parser FilePath inputFile = strArgument $ metavar "FILE" <> help "The input .purs file(s)" -inputForeignFile :: Parser FilePath -inputForeignFile = strOption $ - short 'f' - <> long "ffi" - <> help "The input .js file(s) providing foreign import implementations" - outputDirectory :: Parser FilePath outputDirectory = strOption $ short 'o' @@ -173,7 +151,6 @@ options = P.Options <$> noTco pscMakeOptions :: Parser PSCMakeOptions pscMakeOptions = PSCMakeOptions <$> many inputFile - <*> many inputForeignFile <*> outputDirectory <*> options <*> (not <$> noPrefix) diff --git a/psci/Main.hs b/psci/Main.hs index 4b48d55365..26c9ccfd6a 100644 --- a/psci/Main.hs +++ b/psci/Main.hs @@ -37,7 +37,6 @@ import System.FilePath.Glob (glob) data PSCiOptions = PSCiOptions { psciMultiLineMode :: Bool , psciInputFile :: [FilePath] - , psciForeignInputFiles :: [FilePath] , psciInputNodeFlags :: [String] } @@ -52,12 +51,6 @@ inputFile = Opts.strArgument $ Opts.metavar "FILE" <> Opts.help "Optional .purs files to load on start" -inputForeignFile :: Opts.Parser FilePath -inputForeignFile = Opts.strOption $ - Opts.short 'f' - <> Opts.long "ffi" - <> Opts.help "The input .js file(s) providing foreign import implementations" - nodeFlagsFlag :: Opts.Parser [String] nodeFlagsFlag = Opts.option parser $ Opts.long "node-opts" @@ -70,7 +63,6 @@ nodeFlagsFlag = Opts.option parser $ psciOptions :: Opts.Parser PSCiOptions psciOptions = PSCiOptions <$> multiLineMode <*> many inputFile - <*> many inputForeignFile <*> nodeFlagsFlag version :: Opts.Parser (a -> a) @@ -107,24 +99,20 @@ main = getOpt >>= loop loop :: PSCiOptions -> IO () loop PSCiOptions{..} = do inputFiles <- concat <$> traverse glob psciInputFile - foreignFiles <- concat <$> traverse glob psciForeignInputFiles e <- runExceptT $ do modules <- ExceptT (loadAllModules inputFiles) unless (supportModuleIsDefined (map snd modules)) . liftIO $ do putStrLn supportModuleMessage exitFailure - foreigns <- ExceptT . runMake $ do - foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> P.readTextFile inFile) - P.parseForeignModulesFromFiles foreignFilesContent - (externs, env) <- ExceptT . runMake . make foreigns . map snd $ modules - return (modules, foreigns, externs, env) + (externs, env) <- ExceptT . runMake . make $ modules + return (modules, externs, env) case e of Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure - Right (modules, foreigns, externs, env) -> do + Right (modules, externs, env) -> do historyFilename <- getHistoryFilename let settings = defaultSettings { historyFile = Just historyFilename } initialState = PSCiState [] [] (zip (map snd modules) externs) - config = PSCiConfig inputFiles foreigns psciInputNodeFlags env + config = PSCiConfig inputFiles psciInputNodeFlags env runner = flip runReaderT config . flip evalStateT initialState . runInputT (setComplete completion settings) diff --git a/purescript.cabal b/purescript.cabal index 7fe74a939f..c9d20b237c 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -179,7 +179,6 @@ library Language.PureScript.Parser.Lexer Language.PureScript.Parser.Common Language.PureScript.Parser.Declarations - Language.PureScript.Parser.JS Language.PureScript.Parser.Kinds Language.PureScript.Parser.State Language.PureScript.Parser.Types diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index fbe6beb910..aca59084ac 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -19,8 +19,6 @@ import Data.Maybe (fromJust, mapMaybe) import qualified Data.Set as S import qualified Language.PureScript as P import Language.PureScript.Errors.JSON -import System.FilePath (replaceExtension) -import System.Directory (doesFileExist) import System.IO.UTF8 (readUTF8File) rebuildFile @@ -37,23 +35,26 @@ rebuildFile path = do Right [m] -> pure m Right _ -> throwError . GeneralError $ "Please define exactly one module." + -- Externs files must be sorted ahead of time, so that they get applied + -- correctly to the 'Environment'. externs <- sortExterns m . M.delete (P.getModuleName m) =<< getExternFiles outputDirectory <- confOutputPath . envConfiguration <$> ask - let foreignModule = replaceExtension path "js" - foreignExists <- liftIO (doesFileExist foreignModule) + -- For rebuilding, we want to 'RebuildAlways', but for inferring foreign + -- modules using their file paths, we need to specify the path in the 'Map'. + let filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways) + foreigns <- P.inferForeignModules (M.singleton (P.getModuleName m) (Right path)) - let ma = P.buildMakeActions outputDirectory - (M.singleton (P.getModuleName m) (Left P.RebuildAlways)) - (if foreignExists - then M.singleton (P.getModuleName m) foreignModule - else M.empty) - False + -- Silence progress update messages during the build + let actions = (P.buildMakeActions outputDirectory filePathMap foreigns False) + { P.progress = const (pure ()) } + + -- Rebuild the single module using the cached externs (result, warnings) <- liftIO - . P.runMake P.defaultOptions - . P.rebuildModule (ma { P.progress = const (pure ()) }) externs - $ m + . P.runMake P.defaultOptions + . P.rebuildModule actions externs + $ m case result of Left errors -> throwError . RebuildError $ toJSONErrors False P.Error errors Right _ -> pure . RebuildSuccess $ toJSONErrors False P.Warning warnings diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index bfcc037aa2..0f84bbbad9 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -53,40 +53,41 @@ runMake mk = fst <$> P.runMake P.defaultOptions mk -- | Rebuild a module, using the cached externs data for dependencies. rebuild - :: M.Map P.ModuleName FilePath - -> [P.ExternsFile] + :: [P.ExternsFile] -> P.Module -> P.Make (P.ExternsFile, P.Environment) -rebuild foreignFiles loadedExterns m = do +rebuild loadedExterns m = do externs <- P.rebuildModule buildActions loadedExterns m return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment (loadedExterns ++ [externs])) where buildActions :: P.MakeActions P.Make - buildActions = (P.buildMakeActions modulesDir - filePathMap - foreignFiles - False) { P.progress = const (return ()) } + buildActions = + (P.buildMakeActions modulesDir + filePathMap + M.empty + False) { P.progress = const (return ()) } filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath) filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways) -- | Build the collection of modules from scratch. This is usually done on startup. make - :: M.Map P.ModuleName FilePath - -> [P.Module] + :: [(FilePath, P.Module)] -> P.Make ([P.ExternsFile], P.Environment) -make foreignFiles ms = do - externs <- P.make buildActions ms +make ms = do + foreignFiles <- P.inferForeignModules filePathMap + externs <- P.make (buildActions foreignFiles) (map snd ms) return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs) where - buildActions :: P.MakeActions P.Make - buildActions = (P.buildMakeActions modulesDir - filePathMap - foreignFiles - False) + buildActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make + buildActions foreignFiles = + P.buildMakeActions modulesDir + filePathMap + foreignFiles + False filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath) - filePathMap = M.fromList $ map (\m -> (P.getModuleName m, Left P.RebuildAlways)) ms + filePathMap = M.fromList $ map (\(fp, m) -> (P.getModuleName m, Right fp)) ms -- | Performs a PSCi command handleCommand @@ -115,8 +116,7 @@ handleResetState = do files <- asks psciLoadedFiles e <- runExceptT $ do modules <- ExceptT . liftIO $ loadAllModules files - foreignFiles <- asks psciForeignFiles - (externs, _) <- ExceptT . liftIO . runMake . make foreignFiles . map snd $ modules + (externs, _) <- ExceptT . liftIO . runMake . make $ modules return (map snd modules, externs) case e of Left errs -> printErrors errs @@ -132,9 +132,8 @@ handleExpression handleExpression val = do st <- get let m = createTemporaryModule True st val - foreignFiles <- asks psciForeignFiles nodeArgs <- asks ((++ [indexFile]) . psciNodeFlags) - e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m + e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m case e of Left errs -> printErrors errs Right _ -> do @@ -157,8 +156,7 @@ handleDecls handleDecls ds = do st <- gets (updateLets (++ ds)) let m = createTemporaryModule False st (P.Literal (P.ObjectLiteral [])) - foreignFiles <- asks psciForeignFiles - e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m + e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m case e of Left err -> printErrors err Right _ -> put st @@ -212,9 +210,8 @@ handleImport -> m () handleImport im = do st <- gets (updateImportedModules (im :)) - foreignFiles <- asks psciForeignFiles let m = createTemporaryModuleForImports st - e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m + e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m case e of Left errs -> printErrors errs Right _ -> put st @@ -226,9 +223,8 @@ handleTypeOf -> m () handleTypeOf val = do st <- get - foreignFiles <- asks psciForeignFiles let m = createTemporaryModule False st val - e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m + e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m case e of Left errs -> printErrors errs Right (_, env') -> @@ -243,10 +239,9 @@ handleKindOf -> m () handleKindOf typ = do st <- get - foreignFiles <- asks psciForeignFiles let m = createTemporaryModuleForKind st typ mName = P.ModuleName [P.ProperName "$PSCI"] - e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m + e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m case e of Left errs -> printErrors errs Right (_, env') -> diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index 683ff5426b..1c20721efe 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -5,7 +5,6 @@ module Language.PureScript.Interactive.Types where import Prelude.Compat -import Data.Map (Map) import qualified Language.PureScript as P -- | The PSCI configuration. @@ -14,7 +13,6 @@ import qualified Language.PureScript as P -- data PSCiConfig = PSCiConfig { psciLoadedFiles :: [FilePath] - , psciForeignFiles :: Map P.ModuleName FilePath , psciNodeFlags :: [String] , psciEnvironment :: P.Environment } deriving Show diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 3f30a46788..7192f749ab 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -17,6 +17,7 @@ module Language.PureScript.Make , makeIO , readTextFile , buildMakeActions + , inferForeignModules ) where import Prelude.Compat @@ -75,7 +76,7 @@ import SourceMap import SourceMap.Types import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) -import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise) +import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise, replaceExtension) import System.IO.Error (tryIOError) import System.IO.UTF8 (readUTF8File, writeUTF8File) @@ -98,31 +99,22 @@ renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn -- -- * The details of how files are read/written etc. -- -data MakeActions m = MakeActions { - -- | - -- Get the timestamp for the input file(s) for a module. If there are multiple - -- files (.purs and foreign files, for example) the timestamp should be for +data MakeActions m = MakeActions + { getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime)) + -- ^ Get the timestamp for the input file(s) for a module. If there are multiple + -- files (@.purs@ and foreign files, for example) the timestamp should be for -- the most recently modified file. - -- - getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime)) - -- | - -- Get the timestamp for the output files for a module. This should be the - -- timestamp for the oldest modified file, or Nothing if any of the required - -- output files are missing. - -- , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime) - -- | - -- Read the externs file for a module as a string and also return the actual - -- path for the file. + -- ^ Get the timestamp for the output files for a module. This should be the + -- timestamp for the oldest modified file, or 'Nothing' if any of the required + -- output files are missing. , readExterns :: ModuleName -> m (FilePath, Externs) - -- | - -- Run the code generator for the module and write any required output files. - -- + -- ^ Read the externs file for a module as a string and also return the actual + -- path for the file. , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m () - -- | - -- Respond to a progress update. - -- + -- ^ Run the code generator for the module and write any required output files. , progress :: ProgressMessage -> m () + -- ^ Respond to a progress update. } -- | @@ -297,6 +289,24 @@ makeIO f io = do readTextFile :: FilePath -> Make String readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path +-- | Infer the module name for a module by looking for the same filename with +-- a .js extension. +inferForeignModules + :: forall m + . MonadIO m + => M.Map ModuleName (Either RebuildPolicy FilePath) + -> m (M.Map ModuleName FilePath) +inferForeignModules = fmap (M.mapMaybe id) . traverse inferForeignModule + where + inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath) + inferForeignModule (Left _) = return Nothing + inferForeignModule (Right path) = do + let jsFile = replaceExtension path "js" + exists <- liftIO $ doesFileExist jsFile + if exists + then return (Just jsFile) + else return Nothing + -- | -- A set of make actions that read and write modules from the given directory. -- diff --git a/src/Language/PureScript/Parser.hs b/src/Language/PureScript/Parser.hs index f2172b2a94..69dfd67cdc 100644 --- a/src/Language/PureScript/Parser.hs +++ b/src/Language/PureScript/Parser.hs @@ -17,7 +17,6 @@ module Language.PureScript.Parser (module P) where import Language.PureScript.Parser.Common as P import Language.PureScript.Parser.Declarations as P -import Language.PureScript.Parser.JS as P import Language.PureScript.Parser.Kinds as P import Language.PureScript.Parser.Lexer as P import Language.PureScript.Parser.State as P diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs deleted file mode 100644 index dd545a8a2e..0000000000 --- a/src/Language/PureScript/Parser/JS.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Language.PureScript.Parser.JS - ( ForeignJS() - , parseForeignModulesFromFiles - ) where - -import Prelude.Compat hiding (lex) - -import Control.Monad (forM_, when, msum) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) - -import Data.Function (on) -import Data.List (sortBy, groupBy) -import qualified Data.Map as M - -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.Parser.Common -import Language.PureScript.Parser.Lexer - -import qualified Text.Parsec as PS - -type ForeignJS = String - -parseForeignModulesFromFiles :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => [(FilePath, ForeignJS)] - -> m (M.Map ModuleName FilePath) -parseForeignModulesFromFiles files = do - foreigns <- parU files $ \(path, file) -> - case findModuleName (lines file) of - Just name -> return (name, path) - Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path Nothing) - let grouped = groupBy ((==) `on` fst) $ sortBy (compare `on` fst) foreigns - forM_ grouped $ \grp -> - when (length grp > 1) $ do - let mn = fst (head grp) - paths = map snd grp - tell $ errorMessage $ MultipleFFIModules mn paths - return $ M.fromList foreigns - -findModuleName :: [String] -> Maybe ModuleName -findModuleName = msum . map parseComment - where - parseComment :: String -> Maybe ModuleName - parseComment s = either (const Nothing) Just $ - lex "" s >>= runTokenParser "" (symbol' "//" *> reserved "module" *> moduleName <* PS.eof) diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs index f13c4b5b32..ed3f640964 100644 --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -131,7 +131,6 @@ isSuccess (ExitFailure _) = False fileGlob :: String fileGlob = unwords [ "\"src/**/*.purs\"" - , "\"src/**/*.js\"" ] -- Integration Testing API diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 3521b5866d..5f0922bbef 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -27,14 +27,15 @@ import qualified Language.PureScript as P import Data.Char (isSpace) import Data.Function (on) -import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, partition) +import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy) import Data.Maybe (mapMaybe) import Data.Time.Clock (UTCTime()) +import Data.Tuple (swap) import qualified Data.Map as M import Control.Monad -import Control.Arrow ((>>>)) +import Control.Arrow ((***), (>>>)) import Control.Monad.Reader import Control.Monad.Writer.Strict @@ -57,7 +58,7 @@ main = hspec spec spec :: Spec spec = do - (supportExterns, supportForeigns, passingTestCases, failingTestCases) <- runIO $ do + (supportExterns, passingTestCases, failingTestCases) <- runIO $ do cwd <- getCurrentDirectory let passing = cwd "examples" "passing" let failing = cwd "examples" "failing" @@ -66,49 +67,40 @@ spec = do passingFiles <- getTestFiles passing <$> testGlob passing failingFiles <- getTestFiles failing <$> testGlob failing supportPurs <- supportFiles "purs" - supportForeigns <- loadForeigns =<< supportFiles "js" supportPursFiles <- readInput supportPurs supportExterns <- runExceptT $ do modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles - externs <- ExceptT . runTest $ P.make (makeActions supportForeigns) (map snd modules) + foreigns <- inferForeignModules modules + externs <- ExceptT . runTest $ P.make (makeActions foreigns) (map snd modules) return (zip (map snd modules) externs) case supportExterns of Left errs -> fail (P.prettyPrintMultipleErrors False errs) - Right externs -> return (externs, supportForeigns, passingFiles, failingFiles) + Right externs -> return (externs, passingFiles, failingFiles) context ("Passing examples") $ do - forM_ passingTestCases $ \(testPurs, testJS) -> - it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ do - testForeigns <- loadForeigns testJS - assertCompiles supportExterns testPurs (supportForeigns <> testForeigns) + forM_ passingTestCases $ \testPurs -> + it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ + assertCompiles supportExterns testPurs context ("Failing examples") $ do - forM_ failingTestCases $ \(testPurs, testJS) -> do + forM_ failingTestCases $ \testPurs -> do let mainPath = getTestMain testPurs expectedFailures <- runIO $ getShouldFailWith mainPath - it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do - testForeigns <- loadForeigns testJS - assertDoesNotCompile supportExterns testPurs (supportForeigns <> testForeigns) expectedFailures + it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ + assertDoesNotCompile supportExterns testPurs expectedFailures where -- A glob for all purs and js files within a test directory testGlob :: FilePath -> IO [FilePath] - testGlob dir = join . fst <$> Glob.globDir (map Glob.compile ["**/*.purs", "**/*.js"]) dir - - -- Loads foreign modules from source files - loadForeigns :: [FilePath] -> IO (M.Map P.ModuleName FilePath) - loadForeigns paths = do - files <- forM paths (\f -> (f,) <$> readUTF8File f) - Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles files - return foreigns + testGlob = Glob.globDir1 (Glob.compile "**/*.purs") -- Groups the test files so that a top-level file can have dependencies in a -- subdirectory of the same name. The inner tuple contains a list of the -- .purs files and the .js files for the test case. - getTestFiles :: FilePath -> [FilePath] -> [([FilePath], [FilePath])] + getTestFiles :: FilePath -> [FilePath] -> [[FilePath]] getTestFiles baseDir - = map (partition ((== ".purs") . takeExtensions)) + = map (filter ((== ".purs") . takeExtensions)) . map (map (baseDir )) . groupBy ((==) `on` extractPrefix) . sortBy (compare `on` extractPrefix) @@ -137,6 +129,15 @@ spec = do where extractFailWiths = lines >>> mapMaybe (stripPrefix "-- @shouldFailWith ") >>> map trim +inferForeignModules + :: MonadIO m + => [(FilePath, P.Module)] + -> m (M.Map P.ModuleName FilePath) +inferForeignModules = P.inferForeignModules . fromList + where + fromList :: [(FilePath, P.Module)] -> M.Map P.ModuleName (Either P.RebuildPolicy FilePath) + fromList = M.fromList . map ((P.getModuleName *** Right) . swap) + trim :: String -> String trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse @@ -175,12 +176,12 @@ runTest = fmap fst . P.runMake P.defaultOptions compile :: [(P.Module, P.ExternsFile)] -> [FilePath] - -> M.Map P.ModuleName FilePath -> ([P.Module] -> IO ()) -> IO (Either P.MultipleErrors [P.ExternsFile]) -compile supportExterns inputFiles foreigns check = silence $ runTest $ do +compile supportExterns inputFiles check = silence $ runTest $ do fs <- liftIO $ readInput inputFiles ms <- P.parseModulesFromFiles id fs + foreigns <- inferForeignModules ms liftIO (check (map snd ms)) let actions = makeActions foreigns case ms of @@ -190,22 +191,20 @@ compile supportExterns inputFiles foreigns check = silence $ runTest $ do assert :: [(P.Module, P.ExternsFile)] -> [FilePath] - -> M.Map P.ModuleName FilePath -> ([P.Module] -> IO ()) -> (Either P.MultipleErrors [P.ExternsFile] -> IO (Maybe String)) -> Expectation -assert supportExterns inputFiles foreigns check f = do - e <- compile supportExterns inputFiles foreigns check +assert supportExterns inputFiles check f = do + e <- compile supportExterns inputFiles check maybeErr <- f e maybe (return ()) expectationFailure maybeErr assertCompiles :: [(P.Module, P.ExternsFile)] -> [FilePath] - -> M.Map P.ModuleName FilePath -> Expectation -assertCompiles supportExterns inputFiles foreigns = - assert supportExterns inputFiles foreigns checkMain $ \e -> +assertCompiles supportExterns inputFiles = do + assert supportExterns inputFiles checkMain $ \e -> case e of Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs Right _ -> do @@ -228,11 +227,10 @@ assertCompiles supportExterns inputFiles foreigns = assertDoesNotCompile :: [(P.Module, P.ExternsFile)] -> [FilePath] - -> M.Map P.ModuleName FilePath -> [String] -> Expectation -assertDoesNotCompile supportExterns inputFiles foreigns shouldFailWith = - assert supportExterns inputFiles foreigns noPreCheck $ \e -> +assertDoesNotCompile supportExterns inputFiles shouldFailWith = do + assert supportExterns inputFiles noPreCheck $ \e -> case e of Left errs -> return $ if null shouldFailWith From 4569aa4664982c0f1a3c95427ca36c1d8006da46 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 16 May 2016 13:42:23 +0100 Subject: [PATCH 0424/1580] Use (..) for data constructors in suggestion --- src/Language/PureScript/Linter/Imports.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 1e9478d81a..12d248725b 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -213,7 +213,15 @@ lintImportDecl env mni qualifierName names declType allowImplicit = checkImplicit warning = if null allRefs then unused - else warn (warning mni allRefs) + else warn (warning mni (map simplifyTypeRef allRefs)) + where + -- Replace explicit type refs with data constructor lists from listing the + -- used constructors explicity `T(X, Y, [...])` to `T(..)` for suggestion + -- message. + simplifyTypeRef :: DeclarationRef -> DeclarationRef + simplifyTypeRef (TypeRef name (Just dctors)) + | not (null dctors) = TypeRef name Nothing + simplifyTypeRef other = other checkExplicit :: [DeclarationRef] From 8a6bf0168b838a30a623957f106d7023564819ce Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 17 May 2016 03:03:10 +0100 Subject: [PATCH 0425/1580] Add tests for warnings & fix some warnings --- examples/warning/DuplicateExportRef.purs | 30 ++++++ examples/warning/DuplicateImport.purs | 10 ++ examples/warning/DuplicateImportRef.purs | 18 ++++ .../warning/DuplicateSelectiveImport.purs | 10 ++ examples/warning/HidingImport.purs | 9 ++ examples/warning/ImplicitImport.purs | 9 ++ examples/warning/ImplicitQualifiedImport.purs | 11 +++ examples/warning/MissingTypeDeclaration.purs | 4 + examples/warning/OverlappingInstances.purs | 17 ++++ examples/warning/OverlappingPattern.purs | 15 +++ examples/warning/ScopeShadowing.purs | 13 +++ examples/warning/ShadowedTypeVar.purs | 5 + examples/warning/UnnecessaryFFIModule.js | 1 + examples/warning/UnnecessaryFFIModule.purs | 5 + .../warning/UnusedDctorExplicitImport.purs | 8 ++ examples/warning/UnusedDctorImportAll.purs | 7 ++ .../warning/UnusedDctorImportExplicit.purs | 7 ++ examples/warning/UnusedExplicitImport.purs | 8 ++ examples/warning/UnusedFFIImplementations.js | 2 + .../warning/UnusedFFIImplementations.purs | 4 + examples/warning/UnusedImport.purs | 14 +++ examples/warning/UnusedTypeVar.purs | 5 + examples/warning/WildcardInferredType.purs | 23 +++++ purescript.cabal | 2 + src/Language/PureScript/Errors.hs | 6 -- src/Language/PureScript/Linter/Imports.hs | 50 ++++------ src/Language/PureScript/Sugar/Names.hs | 2 +- src/Language/PureScript/Sugar/Names/Common.hs | 4 +- tests/TestCompiler.hs | 95 +++++++++++++------ 29 files changed, 324 insertions(+), 70 deletions(-) create mode 100644 examples/warning/DuplicateExportRef.purs create mode 100644 examples/warning/DuplicateImport.purs create mode 100644 examples/warning/DuplicateImportRef.purs create mode 100644 examples/warning/DuplicateSelectiveImport.purs create mode 100644 examples/warning/HidingImport.purs create mode 100644 examples/warning/ImplicitImport.purs create mode 100644 examples/warning/ImplicitQualifiedImport.purs create mode 100644 examples/warning/MissingTypeDeclaration.purs create mode 100644 examples/warning/OverlappingInstances.purs create mode 100644 examples/warning/OverlappingPattern.purs create mode 100644 examples/warning/ScopeShadowing.purs create mode 100644 examples/warning/ShadowedTypeVar.purs create mode 100644 examples/warning/UnnecessaryFFIModule.js create mode 100644 examples/warning/UnnecessaryFFIModule.purs create mode 100644 examples/warning/UnusedDctorExplicitImport.purs create mode 100644 examples/warning/UnusedDctorImportAll.purs create mode 100644 examples/warning/UnusedDctorImportExplicit.purs create mode 100644 examples/warning/UnusedExplicitImport.purs create mode 100644 examples/warning/UnusedFFIImplementations.js create mode 100644 examples/warning/UnusedFFIImplementations.purs create mode 100644 examples/warning/UnusedImport.purs create mode 100644 examples/warning/UnusedTypeVar.purs create mode 100644 examples/warning/WildcardInferredType.purs diff --git a/examples/warning/DuplicateExportRef.purs b/examples/warning/DuplicateExportRef.purs new file mode 100644 index 0000000000..aa70f7a732 --- /dev/null +++ b/examples/warning/DuplicateExportRef.purs @@ -0,0 +1,30 @@ +-- @shouldWarnWith DuplicateExportRef +-- @shouldWarnWith DuplicateExportRef +-- @shouldWarnWith DuplicateExportRef +-- @shouldWarnWith DuplicateExportRef +-- @shouldWarnWith DuplicateExportRef +-- @shouldWarnWith DuplicateExportRef +-- @shouldWarnWith DuplicateExportRef +module Main + ( X(X, X), X + , fn, fn + , (!), (!) + , class Y, class Y + , Natural, type (~>), type (~>) + , module Prelude, module Prelude + ) where + +import Prelude (Unit) + +data X = X + +fn :: X -> X -> X +fn _ _ = X + +infix 2 fn as ! + +class Y a + +type Natural f g = forall a. f a -> g a + +infixl 1 type Natural as ~> diff --git a/examples/warning/DuplicateImport.purs b/examples/warning/DuplicateImport.purs new file mode 100644 index 0000000000..ff92cbe26f --- /dev/null +++ b/examples/warning/DuplicateImport.purs @@ -0,0 +1,10 @@ +-- @shouldWarnWith DuplicateImport +module Main where + +import Prelude (Unit, unit, pure) +import Prelude (Unit, unit, pure) + +import Control.Monad.Eff (Eff) + +main :: Eff () Unit +main = pure unit diff --git a/examples/warning/DuplicateImportRef.purs b/examples/warning/DuplicateImportRef.purs new file mode 100644 index 0000000000..e082bd45ed --- /dev/null +++ b/examples/warning/DuplicateImportRef.purs @@ -0,0 +1,18 @@ +-- @shouldWarnWith DuplicateImportRef +-- @shouldWarnWith DuplicateImportRef +-- @shouldWarnWith DuplicateImportRef +-- @shouldWarnWith DuplicateImportRef +module Main where + +import Prelude + ( Unit, Unit + , unit, unit + , class Functor, class Functor + , (<>), (<>) + ) + +u :: Unit +u = unit <> unit + +fid :: forall f a. Functor f => f a -> f a +fid fa = fa diff --git a/examples/warning/DuplicateSelectiveImport.purs b/examples/warning/DuplicateSelectiveImport.purs new file mode 100644 index 0000000000..848b21d8ee --- /dev/null +++ b/examples/warning/DuplicateSelectiveImport.purs @@ -0,0 +1,10 @@ +-- @shouldWarnWith DuplicateSelectiveImport +module Main where + +import Prelude (Unit, unit) +import Prelude (pure) + +import Control.Monad.Eff (Eff) + +main :: Eff () Unit +main = pure unit diff --git a/examples/warning/HidingImport.purs b/examples/warning/HidingImport.purs new file mode 100644 index 0000000000..a45bfb9aa7 --- /dev/null +++ b/examples/warning/HidingImport.purs @@ -0,0 +1,9 @@ +-- @shouldWarnWith HidingImport +-- @shouldWarnWith HidingImport +module Main where + +import Prelude hiding (one) +import Control.Monad.Eff hiding (runPure) + +main :: Eff () Unit +main = pure unit diff --git a/examples/warning/ImplicitImport.purs b/examples/warning/ImplicitImport.purs new file mode 100644 index 0000000000..bca2996706 --- /dev/null +++ b/examples/warning/ImplicitImport.purs @@ -0,0 +1,9 @@ +-- @shouldWarnWith ImplicitImport +-- @shouldWarnWith ImplicitImport +module Main where + +import Prelude +import Control.Monad.Eff + +main :: Eff () Unit +main = pure unit diff --git a/examples/warning/ImplicitQualifiedImport.purs b/examples/warning/ImplicitQualifiedImport.purs new file mode 100644 index 0000000000..36f69d6c20 --- /dev/null +++ b/examples/warning/ImplicitQualifiedImport.purs @@ -0,0 +1,11 @@ +-- @shouldWarnWith ImplicitQualifiedImport +-- @shouldWarnWith ImplicitQualifiedImport +module Main where + +import Data.Unit + +import Control.Monad.Eff as E +import Control.Monad.Eff.Console as E + +main :: E.Eff (console :: E.CONSOLE) Unit +main = E.log "test" diff --git a/examples/warning/MissingTypeDeclaration.purs b/examples/warning/MissingTypeDeclaration.purs new file mode 100644 index 0000000000..a5b8466776 --- /dev/null +++ b/examples/warning/MissingTypeDeclaration.purs @@ -0,0 +1,4 @@ +-- @shouldWarnWith MissingTypeDeclaration +module Main where + +x = 0 diff --git a/examples/warning/OverlappingInstances.purs b/examples/warning/OverlappingInstances.purs new file mode 100644 index 0000000000..b5d932302a --- /dev/null +++ b/examples/warning/OverlappingInstances.purs @@ -0,0 +1,17 @@ +-- @shouldWarnWith OverlappingInstances +module Main where + +class Test a where + test :: a -> a + +instance testRefl :: Test a where + test x = x + +instance testInt :: Test Int where + test _ = 0 + +-- The OverlappingInstances instances warning only arises when there are two +-- choices for a dictionary, not when the instances are defined. So without +-- `value` this module would not raise a warning. +value :: Int +value = test 1 diff --git a/examples/warning/OverlappingPattern.purs b/examples/warning/OverlappingPattern.purs new file mode 100644 index 0000000000..d667eb3fac --- /dev/null +++ b/examples/warning/OverlappingPattern.purs @@ -0,0 +1,15 @@ +-- @shouldWarnWith OverlappingPattern +-- @shouldWarnWith OverlappingPattern +module Main where + +data X = A | B + +pat1 :: X -> Boolean +pat1 A = true +pat1 A = true +pat1 B = false + +pat2 :: X -> Boolean +pat2 A = true +pat2 _ = false +pat2 B = false diff --git a/examples/warning/ScopeShadowing.purs b/examples/warning/ScopeShadowing.purs new file mode 100644 index 0000000000..380a4eef03 --- /dev/null +++ b/examples/warning/ScopeShadowing.purs @@ -0,0 +1,13 @@ +-- @shouldWarnWith ScopeShadowing +module Main where + +import Prelude + +-- No warning at the definition, only when the name is later resolved +data Unit = Unit + +-- This is only a warning as the `Prelude` import is implicit. If `Unit` was +-- named explicitly in an import list, then this refernce to `Unit` +-- would be a `ScopeConflict` error instead. +test :: Unit +test = const Unit unit diff --git a/examples/warning/ShadowedTypeVar.purs b/examples/warning/ShadowedTypeVar.purs new file mode 100644 index 0000000000..89813e7ea4 --- /dev/null +++ b/examples/warning/ShadowedTypeVar.purs @@ -0,0 +1,5 @@ +-- @shouldWarnWith ShadowedTypeVar +module Main where + +f :: forall a. (forall a. a -> a) -> a -> a +f g x = g x diff --git a/examples/warning/UnnecessaryFFIModule.js b/examples/warning/UnnecessaryFFIModule.js new file mode 100644 index 0000000000..346c8e9012 --- /dev/null +++ b/examples/warning/UnnecessaryFFIModule.js @@ -0,0 +1 @@ +exports.out = null; diff --git a/examples/warning/UnnecessaryFFIModule.purs b/examples/warning/UnnecessaryFFIModule.purs new file mode 100644 index 0000000000..947aef9a32 --- /dev/null +++ b/examples/warning/UnnecessaryFFIModule.purs @@ -0,0 +1,5 @@ +-- @shouldWarnWith UnnecessaryFFIModule +module Main where + +t :: Boolean +t = true diff --git a/examples/warning/UnusedDctorExplicitImport.purs b/examples/warning/UnusedDctorExplicitImport.purs new file mode 100644 index 0000000000..35040ef3bb --- /dev/null +++ b/examples/warning/UnusedDctorExplicitImport.purs @@ -0,0 +1,8 @@ +-- @shouldWarnWith UnusedDctorExplicitImport +module Main where + +import Data.Ordering (Ordering(EQ, LT)) + +f :: Ordering -> Ordering +f EQ = EQ +f x = x diff --git a/examples/warning/UnusedDctorImportAll.purs b/examples/warning/UnusedDctorImportAll.purs new file mode 100644 index 0000000000..807302fc41 --- /dev/null +++ b/examples/warning/UnusedDctorImportAll.purs @@ -0,0 +1,7 @@ +-- @shouldWarnWith UnusedDctorImport +module Main where + +import Data.Ordering (Ordering(..)) + +f :: Ordering -> Ordering +f x = x diff --git a/examples/warning/UnusedDctorImportExplicit.purs b/examples/warning/UnusedDctorImportExplicit.purs new file mode 100644 index 0000000000..11dc2d6277 --- /dev/null +++ b/examples/warning/UnusedDctorImportExplicit.purs @@ -0,0 +1,7 @@ +-- @shouldWarnWith UnusedDctorImport +module Main where + +import Data.Ordering (Ordering(EQ)) + +f :: Ordering -> Ordering +f x = x diff --git a/examples/warning/UnusedExplicitImport.purs b/examples/warning/UnusedExplicitImport.purs new file mode 100644 index 0000000000..a6705e38d0 --- /dev/null +++ b/examples/warning/UnusedExplicitImport.purs @@ -0,0 +1,8 @@ +-- @shouldWarnWith UnusedExplicitImport +module Main where + +import Prelude (Unit, unit, pure, bind) +import Control.Monad.Eff (Eff) + +main :: Eff () Unit +main = pure unit diff --git a/examples/warning/UnusedFFIImplementations.js b/examples/warning/UnusedFFIImplementations.js new file mode 100644 index 0000000000..d50f2e60a8 --- /dev/null +++ b/examples/warning/UnusedFFIImplementations.js @@ -0,0 +1,2 @@ +exports.yes = true; +exports.no = false; diff --git a/examples/warning/UnusedFFIImplementations.purs b/examples/warning/UnusedFFIImplementations.purs new file mode 100644 index 0000000000..6e263bf988 --- /dev/null +++ b/examples/warning/UnusedFFIImplementations.purs @@ -0,0 +1,4 @@ +-- @shouldWarnWith UnusedFFIImplementations +module Main where + +foreign import yes :: Boolean diff --git a/examples/warning/UnusedImport.purs b/examples/warning/UnusedImport.purs new file mode 100644 index 0000000000..d13840bbb3 --- /dev/null +++ b/examples/warning/UnusedImport.purs @@ -0,0 +1,14 @@ +-- @shouldWarnWith UnusedImport +-- @shouldWarnWith UnusedImport +-- @shouldWarnWith UnusedImport +module Main where + +import Data.Unit (Unit, unit) + +-- All of the below are unused +import Control.Monad.Eff +import Control.Monad.Eff.Console as Console +import Test.Assert () + +main :: Unit +main = unit diff --git a/examples/warning/UnusedTypeVar.purs b/examples/warning/UnusedTypeVar.purs new file mode 100644 index 0000000000..03a6410980 --- /dev/null +++ b/examples/warning/UnusedTypeVar.purs @@ -0,0 +1,5 @@ +-- @shouldWarnWith UnusedTypeVar +module Main where + +f :: forall a b. a -> a +f x = x diff --git a/examples/warning/WildcardInferredType.purs b/examples/warning/WildcardInferredType.purs new file mode 100644 index 0000000000..3662384dea --- /dev/null +++ b/examples/warning/WildcardInferredType.purs @@ -0,0 +1,23 @@ +-- @shouldWarnWith WildcardInferredType +-- @shouldWarnWith WildcardInferredType +-- @shouldWarnWith WildcardInferredType +-- @shouldWarnWith WildcardInferredType +module Main where + +x :: Int +x = 0 :: _ + +y :: _ +y = 0 + +z :: Int +z = + let n :: _ + n = 0 + in n + +w :: Int +w = n + where + n :: _ + n = 0 diff --git a/purescript.cabal b/purescript.cabal index c9d20b237c..d9b3709a66 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -66,6 +66,8 @@ extra-source-files: examples/passing/*.purs , examples/failing/InstanceExport/*.purs , examples/failing/OrphanInstance/*.purs , examples/failing/OverlappingReExport/*.purs + , examples/warning/*.purs + , examples/warning/*.js , examples/docs/bower_components/purescript-prelude/src/*.purs , examples/docs/bower.json , examples/docs/src/*.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8cdf6ab4f5..caea404ab6 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -127,7 +127,6 @@ data SimpleErrorMessage | DuplicateImportRef Name | DuplicateExportRef Name | IntOutOfRange Integer String Integer Integer - | RedundantEmptyHidingImport ModuleName | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef] | ImplicitImport ModuleName [DeclarationRef] | HidingImport ModuleName [DeclarationRef] @@ -297,7 +296,6 @@ errorCode em = case unwrapErrorMessage em of DuplicateImportRef{} -> "DuplicateImportRef" DuplicateExportRef{} -> "DuplicateExportRef" IntOutOfRange{} -> "IntOutOfRange" - RedundantEmptyHidingImport{} -> "RedundantEmptyHidingImport" ImplicitQualifiedImport{} -> "ImplicitQualifiedImport" ImplicitImport{} -> "ImplicitImport" HidingImport{} -> "HidingImport" @@ -418,7 +416,6 @@ wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ error errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion errorSuggestion err = case err of UnusedImport{} -> emptySuggestion - RedundantEmptyHidingImport{} -> emptySuggestion DuplicateImport{} -> emptySuggestion UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing @@ -868,9 +865,6 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend." , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ] - renderSimpleErrorMessage (RedundantEmptyHidingImport mn) = - line $ "The import for module " ++ runModuleName mn ++ " is redundant as all members have been explicitly hidden." - renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) = paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports." , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:" diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 1e9478d81a..24465e0d4c 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -6,7 +6,7 @@ module Language.PureScript.Linter.Imports import Prelude.Compat -import Control.Monad (join, unless, when, foldM, (<=<)) +import Control.Monad (join, unless, foldM, (<=<)) import Control.Monad.Writer.Class import Data.Function (on) @@ -54,7 +54,8 @@ lintImports -> Env -> UsedImports -> m () -lintImports (Module _ _ _ _ Nothing) _ _ = return () +lintImports (Module _ _ _ _ Nothing) _ _ = + internalError "lintImports needs desugared exports" lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do -- TODO: this needs some work to be easier to understand @@ -100,13 +101,11 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do maybe id warnWithPosition pos $ tell $ errorMessage $ DuplicateSelectiveImport mnq - for_ (imps \\ (warned ++ duplicates)) $ \(pos, typ, _) -> do + for_ (imps \\ (warned ++ duplicates)) $ \(pos, typ, _) -> warnDuplicateRefs (fromMaybe ss pos) DuplicateImportRef $ case typ of Explicit refs -> refs Hiding refs -> refs _ -> [] - for_ (M.lookup mn env) $ \(_, imported, _) -> - checkEmptyImport mnq imported typ where @@ -120,9 +119,9 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do countOpenImports :: Declaration -> Int countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d countOpenImports (ImportDeclaration mn' Implicit Nothing) - | not (isPrim mn') = 1 + | not (isPrim mn' || mn == mn') = 1 countOpenImports (ImportDeclaration mn' (Hiding _) Nothing) - | not (isPrim mn') = 1 + | not (isPrim mn' || mn == mn') = 1 countOpenImports _ = 0 -- Checks whether a module is the Prim module - used to suppress any checks @@ -199,7 +198,10 @@ lintImportDecl lintImportDecl env mni qualifierName names declType allowImplicit = case declType of Implicit -> case qualifierName of - Nothing -> unless' allowImplicit (checkImplicit ImplicitImport) + Nothing -> + if null allRefs + then unused + else unless' allowImplicit (checkImplicit ImplicitImport) Just q -> unless' (q `elem` mapMaybe getQual names) unused Hiding _ -> unless' allowImplicit (checkImplicit HidingImport) Explicit [] -> unused @@ -248,9 +250,15 @@ lintImportDecl env mni qualifierName names declType allowImplicit = warn :: SimpleErrorMessage -> m Bool warn err = tell (errorMessage err) >> return True + -- Unless the boolean is true, run the action. Return false when the action is + -- not run, otherwise return whatever the action does. + -- + -- The return value is intended for cases where we want to track whether some + -- work was done, as there may be further conditions in the action that mean + -- it ends up doing nothing. unless' :: Bool -> m Bool -> m Bool - unless' True m = m - unless' False _ = return False + unless' False m = m + unless' True _ = return False allRefs :: [DeclarationRef] allRefs = findUsedRefs env mni qualifierName names @@ -344,25 +352,3 @@ checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) = tell $ errorMessage $ DuplicateImport mn t2 q2 return $ (pos, t2, q2) : xs else return xs - --- | --- Checks that an import with a hiding reference is not hiding all possible --- imports. --- -checkEmptyImport - :: MonadWriter MultipleErrors m - => ModuleName - -> Imports - -> ImportDeclarationType - -> m () -checkEmptyImport importModule imps (Hiding _) = do - let isEmptyImport - = M.null (importedTypes imps) - && M.null (importedTypeOps imps) - && M.null (importedDataConstructors imps) - && M.null (importedTypeClasses imps) - && M.null (importedValues imps) - && M.null (importedValueOps imps) - when isEmptyImport . tell . errorMessage $ - RedundantEmptyHidingImport importModule -checkEmptyImport _ _ _ = return () diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 75fb7ca376..9be084e22a 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -111,7 +111,7 @@ desugarImportsWithEnv externs modules = do warnAndRethrow (addHint (ErrorInModule mn)) $ do let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m) - lintImports m env used + lintImports m' env used return m' -- | diff --git a/src/Language/PureScript/Sugar/Names/Common.hs b/src/Language/PureScript/Sugar/Names/Common.hs index 2e1d0d7659..02c841bb82 100644 --- a/src/Language/PureScript/Sugar/Names/Common.hs +++ b/src/Language/PureScript/Sugar/Names/Common.hs @@ -43,15 +43,17 @@ warnDuplicateRefs pos toError refs = do -- referenced type is used in the duplicate check - constructors are handled -- separately deleteCtors :: DeclarationRef -> DeclarationRef + deleteCtors (PositionedDeclarationRef ss com ref) = + PositionedDeclarationRef ss com (deleteCtors ref) deleteCtors (TypeRef pn _) = TypeRef pn Nothing deleteCtors other = other -- Extracts the names of duplicate constructor references from TypeRefs. extractCtors :: SourceSpan -> DeclarationRef -> Maybe [(SourceSpan, Name)] + extractCtors _ (PositionedDeclarationRef pos' _ ref) = extractCtors pos' ref extractCtors pos' (TypeRef _ (Just dctors)) = let dupes = dctors \\ nub dctors in if null dupes then Nothing else Just $ ((pos',) . DctorName) <$> dupes - extractCtors _ (PositionedDeclarationRef pos' _ ref) = extractCtors pos' ref extractCtors _ _ = Nothing -- Converts a DeclarationRef into a name for an error message. diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 5f0922bbef..1d0f8e0152 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -27,7 +27,7 @@ import qualified Language.PureScript as P import Data.Char (isSpace) import Data.Function (on) -import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy) +import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy) import Data.Maybe (mapMaybe) import Data.Time.Clock (UTCTime()) import Data.Tuple (swap) @@ -58,31 +58,40 @@ main = hspec spec spec :: Spec spec = do - (supportExterns, passingTestCases, failingTestCases) <- runIO $ do + (supportExterns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do cwd <- getCurrentDirectory let passing = cwd "examples" "passing" + let warning = cwd "examples" "warning" let failing = cwd "examples" "failing" let supportDir = cwd "tests" "support" "bower_components" let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir passingFiles <- getTestFiles passing <$> testGlob passing + warningFiles <- getTestFiles warning <$> testGlob warning failingFiles <- getTestFiles failing <$> testGlob failing supportPurs <- supportFiles "purs" supportPursFiles <- readInput supportPurs supportExterns <- runExceptT $ do modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles foreigns <- inferForeignModules modules - externs <- ExceptT . runTest $ P.make (makeActions foreigns) (map snd modules) + externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules) return (zip (map snd modules) externs) case supportExterns of Left errs -> fail (P.prettyPrintMultipleErrors False errs) - Right externs -> return (externs, passingFiles, failingFiles) + Right externs -> return (externs, passingFiles, warningFiles, failingFiles) - context ("Passing examples") $ do + context "Passing examples" $ forM_ passingTestCases $ \testPurs -> it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ assertCompiles supportExterns testPurs - context ("Failing examples") $ do + context "Warning examples" $ + forM_ warningTestCases $ \testPurs -> do + let mainPath = getTestMain testPurs + expectedWarnings <- runIO $ getShouldWarnWith mainPath + it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $ + assertCompilesWithWarnings supportExterns testPurs expectedWarnings + + context "Failing examples" $ forM_ failingTestCases $ \testPurs -> do let mainPath = getTestMain testPurs expectedFailures <- runIO $ getShouldFailWith mainPath @@ -100,8 +109,7 @@ spec = do -- .purs files and the .js files for the test case. getTestFiles :: FilePath -> [FilePath] -> [[FilePath]] getTestFiles baseDir - = map (filter ((== ".purs") . takeExtensions)) - . map (map (baseDir )) + = map (filter ((== ".purs") . takeExtensions) . map (baseDir )) . groupBy ((==) `on` extractPrefix) . sortBy (compare `on` extractPrefix) . map (makeRelative baseDir) @@ -110,7 +118,7 @@ spec = do -- by the file with the shortest path name, as everything but the main file -- will be under a subdirectory. getTestMain :: [FilePath] -> FilePath - getTestMain = head . sortBy (compare `on` length) + getTestMain = minimumBy (compare `on` length) -- Extracts the filename part of a .purs file, or if the file is in a -- subdirectory, the first part of that directory path. @@ -125,9 +133,17 @@ spec = do -- Scans a file for @shouldFailWith directives in the comments, used to -- determine expected failures getShouldFailWith :: FilePath -> IO [String] - getShouldFailWith = fmap extractFailWiths . readUTF8File + getShouldFailWith = extractPragma "shouldFailWith" + + -- Scans a file for @shouldWarnWith directives in the comments, used to + -- determine expected warnings + getShouldWarnWith :: FilePath -> IO [String] + getShouldWarnWith = extractPragma "shouldWarnWith" + + extractPragma :: String -> FilePath -> IO [String] + extractPragma pragma = fmap go . readUTF8File where - extractFailWiths = lines >>> mapMaybe (stripPrefix "-- @shouldFailWith ") >>> map trim + go = lines >>> mapMaybe (stripPrefix ("-- @" ++ pragma ++ " ")) >>> map trim inferForeignModules :: MonadIO m @@ -168,16 +184,14 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do text <- readUTF8File inputFile return (inputFile, text) -type TestM = WriterT [(FilePath, String)] IO - -runTest :: P.Make a -> IO (Either P.MultipleErrors a) -runTest = fmap fst . P.runMake P.defaultOptions +runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors) +runTest = P.runMake P.defaultOptions compile :: [(P.Module, P.ExternsFile)] -> [FilePath] -> ([P.Module] -> IO ()) - -> IO (Either P.MultipleErrors [P.ExternsFile]) + -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) compile supportExterns inputFiles check = silence $ runTest $ do fs <- liftIO $ readInput inputFiles ms <- P.parseModulesFromFiles id fs @@ -192,18 +206,30 @@ assert :: [(P.Module, P.ExternsFile)] -> [FilePath] -> ([P.Module] -> IO ()) - -> (Either P.MultipleErrors [P.ExternsFile] -> IO (Maybe String)) + -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String)) -> Expectation assert supportExterns inputFiles check f = do - e <- compile supportExterns inputFiles check - maybeErr <- f e + (e, w) <- compile supportExterns inputFiles check + maybeErr <- f (const w <$> e) maybe (return ()) expectationFailure maybeErr +checkMain :: [P.Module] -> IO () +checkMain ms = + unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms) + (fail "Main module missing") + +checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String +checkShouldFailWith expected errs = + let actual = map P.errorCode $ P.runMultipleErrors errs + in if sort expected == sort actual + then Nothing + else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual + assertCompiles :: [(P.Module, P.ExternsFile)] -> [FilePath] -> Expectation -assertCompiles supportExterns inputFiles = do +assertCompiles supportExterns inputFiles = assert supportExterns inputFiles checkMain $ \e -> case e of Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs @@ -219,17 +245,32 @@ assertCompiles supportExterns inputFiles = do | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out Just (ExitFailure _, _, err) -> return $ Just err Nothing -> return $ Just "Couldn't find node.js executable" + +assertCompilesWithWarnings + :: [(P.Module, P.ExternsFile)] + -> [FilePath] + -> [String] + -> Expectation +assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith = + assert supportExterns inputFiles checkMain $ \e -> + case e of + Left errs -> + return . Just . P.prettyPrintMultipleErrors False $ errs + Right warnings -> + return + . fmap (printAllWarnings warnings) + $ checkShouldFailWith shouldWarnWith warnings + where - checkMain ms = - unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms) - (fail "Main module missing") + printAllWarnings warnings = + (<> "\n\n" <> P.prettyPrintMultipleErrors False warnings) assertDoesNotCompile :: [(P.Module, P.ExternsFile)] -> [FilePath] -> [String] -> Expectation -assertDoesNotCompile supportExterns inputFiles shouldFailWith = do +assertDoesNotCompile supportExterns inputFiles shouldFailWith = assert supportExterns inputFiles noPreCheck $ \e -> case e of Left errs -> @@ -243,9 +284,3 @@ assertDoesNotCompile supportExterns inputFiles shouldFailWith = do where noPreCheck = const (return ()) - - checkShouldFailWith expected errs = - let actual = map P.errorCode $ P.runMultipleErrors errs - in if sort expected == sort actual - then Nothing - else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual From 1194d49b9a3957fa5195820c8fe01e86a878b800 Mon Sep 17 00:00:00 2001 From: Ben James Date: Thu, 19 May 2016 21:27:46 +0000 Subject: [PATCH 0426/1580] More portable shebang line --- core-tests/test-everything.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core-tests/test-everything.sh b/core-tests/test-everything.sh index 6aa0ebf1ea..a02c81d447 100755 --- a/core-tests/test-everything.sh +++ b/core-tests/test-everything.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash set -e From 074ae849671483db0ae6def68522359bab194ea9 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 20 May 2016 12:54:27 +0100 Subject: [PATCH 0427/1580] Generate names when elaborating Partial --- src/Language/PureScript/Linter/Exhaustive.hs | 57 +++++++++++--------- 1 file changed, 33 insertions(+), 24 deletions(-) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index e33b18d0ee..782af1cda1 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -14,6 +14,7 @@ import Control.Applicative import Control.Arrow (first, second) import Control.Monad (unless) import Control.Monad.Writer.Class +import Control.Monad.Supply.Class (MonadSupply, fresh, freshName) import Data.Function (on) import Data.List (foldl', sortBy, nub) @@ -45,7 +46,7 @@ data RedundancyError = Incomplete | Unknown -- Qualifies a propername from a given qualified propername and a default module name -- qualifyName - :: (ProperName a) + :: ProperName a -> ModuleName -> Qualified (ProperName b) -> Qualified (ProperName a) @@ -231,7 +232,7 @@ missingAlternative env mn ca uncovered -- checkExhaustive :: forall m - . (MonadWriter MultipleErrors m) + . (MonadWriter MultipleErrors m, MonadSupply m) => Environment -> ModuleName -> Int @@ -262,7 +263,7 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step ( _ -> return () if null bss then return expr - else return (addPartialConstraint (second null (splitAt 5 bss)) expr) + else addPartialConstraint (second null (splitAt 5 bss)) expr where tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss' tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck @@ -273,34 +274,42 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step ( -- -- The binder information is provided so that it can be embedded in the constraint, -- and then included in the error message. - addPartialConstraint :: ([[Binder]], Bool) -> Expr -> Expr - addPartialConstraint (bss, complete) e = - Let [ partial ] (App (Var (Qualified Nothing (Ident C.__unused))) e) + addPartialConstraint :: MonadSupply m => ([[Binder]], Bool) -> Expr -> m Expr + addPartialConstraint (bss, complete) e = do + tyVar <- ("p" ++) . show <$> fresh + var <- freshName + return $ + Let + [ partial var tyVar ] + $ App (Var (Qualified Nothing (Ident C.__unused))) e where - partial :: Declaration - partial = ValueDeclaration (Ident C.__unused) - Private - [] - (Right (TypedValue True (Abs (Left (Ident "x")) - (Var (Qualified Nothing (Ident "x")))) - ty)) - - ty :: Type - ty = ForAll "a" (ConstrainedType [ Constraint (Qualified (Just (ModuleName [ProperName C.prim])) - (ProperName "Partial")) - [] - (Just (PartialConstraintData (map (map prettyPrintBinderAtom) bss) complete)) - ] - (TypeApp (TypeApp tyFunction (TypeVar "a")) - (TypeVar "a"))) - Nothing + partial :: String -> String -> Declaration + partial var tyVar = + ValueDeclaration (Ident C.__unused) Private [] $ Right $ + TypedValue + True + (Abs (Left (Ident var)) (Var (Qualified Nothing (Ident var)))) + (ty tyVar) + + ty :: String -> Type + ty tyVar = + ForAll tyVar + ( ConstrainedType + [ Constraint C.Partial [] (Just constraintData) ] + $ TypeApp (TypeApp tyFunction (TypeVar tyVar)) (TypeVar tyVar) + ) + Nothing + + constraintData :: ConstraintData + constraintData = + PartialConstraintData (map (map prettyPrintBinderAtom) bss) complete -- | -- Exhaustivity checking -- checkExhaustiveExpr :: forall m - . MonadWriter MultipleErrors m + . (MonadWriter MultipleErrors m, MonadSupply m) => Environment -> ModuleName -> Expr From 66c1f7449c2ff08986c4e50e6aba269b36c940e0 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 16 May 2016 02:05:19 +0100 Subject: [PATCH 0428/1580] Require imports for qualified names to resolve --- core-tests/tests/generic-deriving/Main.purs | 10 +- examples/failing/ExportExplicit1.purs | 3 +- examples/failing/ExportExplicit3.purs | 7 +- examples/failing/RowConstructors1.purs | 4 +- examples/failing/RowConstructors2.purs | 4 +- examples/failing/RowConstructors3.purs | 4 +- examples/failing/TypedBinders.purs | 6 +- examples/failing/TypedBinders2.purs | 6 +- examples/failing/TypedBinders3.purs | 3 +- examples/failing/UnderscoreModuleName.purs | 4 +- examples/passing/1185.purs | 4 +- examples/passing/1570.purs | 4 +- examples/passing/1697.purs | 3 +- examples/passing/1881.purs | 8 +- examples/passing/1991.purs | 5 +- examples/passing/652.purs | 3 +- examples/passing/810.purs | 3 +- examples/passing/Applicative.purs | 4 +- examples/passing/ArrayType.purs | 3 +- examples/passing/Auto.purs | 3 +- examples/passing/BindersInFunctions.purs | 3 +- examples/passing/BindingGroups.purs | 3 +- examples/passing/BlockString.purs | 3 +- examples/passing/CaseStatement.purs | 3 +- examples/passing/CheckFunction.purs | 3 +- examples/passing/CheckSynonymBug.purs | 3 +- examples/passing/CheckTypeClass.purs | 4 +- examples/passing/Church.purs | 4 +- examples/passing/ClassRefSyntax.purs | 9 +- examples/passing/Conditional.purs | 4 +- examples/passing/DataAndType.purs | 3 +- examples/passing/DeepArrayBinder.purs | 3 +- examples/passing/Do.purs | 5 +- examples/passing/Dollar.purs | 4 +- examples/passing/EmptyDataDecls.purs | 3 +- examples/passing/EmptyRow.purs | 3 +- .../passing/ExplicitOperatorSections.purs | 3 +- examples/passing/ExportExplicit.purs | 3 +- examples/passing/ExportExplicit2.purs | 3 +- examples/passing/FunctionScope.purs | 3 +- examples/passing/Functions2.purs | 3 +- examples/passing/Guards.purs | 3 +- examples/passing/IfThenElseMaybe.purs | 3 +- examples/passing/ImplicitEmptyImport.purs | 7 +- examples/passing/Import.purs | 3 +- examples/passing/ImportExplicit.purs | 3 +- examples/passing/InstanceBeforeClass.purs | 3 +- examples/passing/IntAndChar.purs | 3 +- examples/passing/JSReserved.purs | 3 +- examples/passing/KindedType.purs | 3 +- examples/passing/LargeSumType.purs | 6 +- examples/passing/LetInInstance.purs | 3 +- examples/passing/LiberalTypeSynonyms.purs | 3 +- examples/passing/MPTCs.purs | 5 +- examples/passing/Match.purs | 3 +- examples/passing/Module.purs | 3 +- examples/passing/Module/M1.purs | 2 +- examples/passing/Module/M2.purs | 1 + examples/passing/ModuleDeps.purs | 3 +- examples/passing/ModuleDeps/M1.purs | 2 +- examples/passing/ModuleDeps/M2.purs | 2 +- examples/passing/Monad.purs | 4 +- examples/passing/MutRec.purs | 3 +- examples/passing/MutRec2.purs | 3 +- examples/passing/MutRec3.purs | 3 +- examples/passing/NamedPatterns.purs | 3 +- examples/passing/NegativeBinder.purs | 3 +- examples/passing/NegativeIntInRange.purs | 3 +- examples/passing/Nested.purs | 3 +- examples/passing/NestedWhere.purs | 3 +- examples/passing/NonConflictingExports.purs | 9 +- examples/passing/ObjectSynonym.purs | 3 +- examples/passing/ObjectUpdate2.purs | 3 +- examples/passing/Objects.purs | 3 +- examples/passing/OneConstructor.purs | 3 +- examples/passing/Operators.purs | 12 +-- examples/passing/Operators/Other.purs | 7 ++ examples/passing/OptimizerBug.purs | 3 +- examples/passing/Patterns.purs | 3 +- .../passing/PendingConflictingImports.purs | 3 +- .../passing/PendingConflictingImports2.purs | 11 ++- examples/passing/QualifiedNames.purs | 4 +- examples/passing/Rank2Types.purs | 3 +- examples/passing/ReExportQualified.purs | 3 +- examples/passing/Recursion.purs | 3 +- examples/passing/RedefinedFixity.purs | 3 +- examples/passing/ReservedWords.purs | 3 +- examples/passing/ResolvableScopeConflict.purs | 3 +- .../passing/ResolvableScopeConflict2.purs | 3 +- .../passing/ResolvableScopeConflict3.purs | 3 +- examples/passing/RowConstructors.purs | 3 +- examples/passing/RowPolyInstanceContext.purs | 3 +- examples/passing/ScopedTypeVariables.purs | 3 +- examples/passing/Sequence.purs | 3 +- examples/passing/SequenceDesugared.purs | 9 +- examples/passing/ShadowedName.purs | 3 +- examples/passing/SignedNumericLiterals.purs | 3 +- examples/passing/TCOCase.purs | 3 +- examples/passing/Tick.purs | 3 +- examples/passing/TopLevelCase.purs | 3 +- examples/passing/TransitiveImport/Middle.purs | 4 +- examples/passing/TypeClasses.purs | 6 +- examples/passing/TypeClassesInOrder.purs | 3 +- ...peClassesWithOverlappingTypeVariables.purs | 5 +- examples/passing/TypeDecl.purs | 3 +- examples/passing/TypeOperators.purs | 3 +- examples/passing/TypeSynonymInData.purs | 3 +- examples/passing/TypeSynonyms.purs | 3 +- examples/passing/TypeWildcards.purs | 3 +- .../passing/TypeWildcardsRecordExtension.purs | 3 +- examples/passing/TypeWithoutParens.purs | 3 +- examples/passing/TypedBinders.purs | 5 +- examples/passing/TypedWhere.purs | 3 +- examples/passing/UnderscoreIdent.purs | 3 +- examples/passing/UnicodeIdentifier.purs | 4 +- examples/passing/UnicodeOperators.purs | 4 +- .../passing/UnknownInTypeClassLookup.purs | 3 +- examples/passing/UntupledConstraints.purs | 2 +- examples/passing/WildcardType.purs | 5 +- examples/passing/iota.purs | 4 +- examples/passing/s.purs | 3 +- purescript.cabal | 1 + src/Language/PureScript/Linter/Imports.hs | 7 +- src/Language/PureScript/Sugar/Names.hs | 96 ++++++------------- src/Language/PureScript/Sugar/Names/Env.hs | 32 +++++-- .../PureScript/Sugar/Names/Imports.hs | 9 +- tests/support/bower.json | 2 +- 127 files changed, 349 insertions(+), 255 deletions(-) create mode 100644 examples/passing/Operators/Other.purs diff --git a/core-tests/tests/generic-deriving/Main.purs b/core-tests/tests/generic-deriving/Main.purs index 868fde6e9e..c98cea4f24 100755 --- a/core-tests/tests/generic-deriving/Main.purs +++ b/core-tests/tests/generic-deriving/Main.purs @@ -2,18 +2,18 @@ module GenericDeriving where import Prelude -import Control.Monad.Eff (Eff()) -import Control.Monad.Eff.Console (CONSOLE()) +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) import Data.Generic data Void derive instance genericVoid :: Generic Void -data A a +data A a = A Number String | B Int - | C (Array (A a)) + | C (Array (A a)) | D { "asgård" :: a } | E Void @@ -24,4 +24,4 @@ newtype X b = X b derive instance genericX :: Generic (X String) main :: forall eff. Eff (console :: CONSOLE | eff) Unit -main = Control.Monad.Eff.Console.log (gShow (D { "asgård": C [ A 1.0 "test", B 42, D { "asgård": true } ] })) +main = log (gShow (D { "asgård": C [ A 1.0 "test", B 42, D { "asgård": true } ] })) diff --git a/examples/failing/ExportExplicit1.purs b/examples/failing/ExportExplicit1.purs index 9584e5e863..f99e824756 100644 --- a/examples/failing/ExportExplicit1.purs +++ b/examples/failing/ExportExplicit1.purs @@ -2,10 +2,11 @@ module Main where import M1 +import Control.Monad.Eff.Console (log) testX = X -- should fail as Y constructor is not exported from M1 testY = Y -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/failing/ExportExplicit3.purs b/examples/failing/ExportExplicit3.purs index 0e9fbf9de4..e4cbe54c45 100644 --- a/examples/failing/ExportExplicit3.purs +++ b/examples/failing/ExportExplicit3.purs @@ -1,9 +1,10 @@ -- @shouldFailWith UnknownName module Main where -import M1 +import M1 as M +import Control.Monad.Eff.Console (log) -- should fail as Z is not exported from M1 -testZ = M1.Z +testZ = M.Z -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/failing/RowConstructors1.purs b/examples/failing/RowConstructors1.purs index 64e0b650b7..533773ce84 100644 --- a/examples/failing/RowConstructors1.purs +++ b/examples/failing/RowConstructors1.purs @@ -1,9 +1,9 @@ -- @shouldFailWith KindsDoNotUnify module Main where -import Prelude +import Control.Monad.Eff.Console (log) data Foo = Bar type Baz = { | Foo } -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/failing/RowConstructors2.purs b/examples/failing/RowConstructors2.purs index dae6a445e1..1ab8236877 100644 --- a/examples/failing/RowConstructors2.purs +++ b/examples/failing/RowConstructors2.purs @@ -1,9 +1,9 @@ -- @shouldFailWith KindsDoNotUnify module Main where -import Prelude +import Control.Monad.Eff.Console (log) type Foo r = (x :: Number | r) type Bar = { | Foo } -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/failing/RowConstructors3.purs b/examples/failing/RowConstructors3.purs index 1a04e422b8..60e3950e3e 100644 --- a/examples/failing/RowConstructors3.purs +++ b/examples/failing/RowConstructors3.purs @@ -1,9 +1,9 @@ -- @shouldFailWith KindsDoNotUnify module Main where -import Prelude +import Control.Monad.Eff.Console (log) type Foo = { x :: Number } type Bar = { | Foo } -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/failing/TypedBinders.purs b/examples/failing/TypedBinders.purs index bbe1ce6702..756f27558f 100644 --- a/examples/failing/TypedBinders.purs +++ b/examples/failing/TypedBinders.purs @@ -1,10 +1,10 @@ --- @shouldFailWith ErrorParsingModule +-- @shouldFailWith ErrorParsingModule module Main where -import Prelude +import Control.Monad.Eff.Console (log) test = (\f :: Int -> Int -> f 10) id main = do let t1 = test - Control.Monad.Eff.Console.log "Done" \ No newline at end of file + log "Done" diff --git a/examples/failing/TypedBinders2.purs b/examples/failing/TypedBinders2.purs index 21b5caf470..f23c1a1b5e 100644 --- a/examples/failing/TypedBinders2.purs +++ b/examples/failing/TypedBinders2.purs @@ -2,8 +2,8 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) main = do - s :: String <- Control.Monad.Eff.Console.log "Foo" - Control.Monad.Eff.Console.log "Done" - + s :: String <- log "Foo" + log "Done" diff --git a/examples/failing/TypedBinders3.purs b/examples/failing/TypedBinders3.purs index 14987bcb63..8a25264201 100644 --- a/examples/failing/TypedBinders3.purs +++ b/examples/failing/TypedBinders3.purs @@ -2,6 +2,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test = case 1 of (0 :: String) -> true @@ -9,4 +10,4 @@ test = case 1 of main = do let t = test - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/failing/UnderscoreModuleName.purs b/examples/failing/UnderscoreModuleName.purs index 1514622f3d..a7d3f0440b 100644 --- a/examples/failing/UnderscoreModuleName.purs +++ b/examples/failing/UnderscoreModuleName.purs @@ -1,6 +1,6 @@ -- @shouldFailWith ErrorParsingModule module Bad_Module where -import Prelude +import Control.Monad.Eff.Console (log) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/1185.purs b/examples/passing/1185.purs index eddb5891d7..f4ba728f20 100644 --- a/examples/passing/1185.purs +++ b/examples/passing/1185.purs @@ -1,5 +1,7 @@ module Main where +import Control.Monad.Eff.Console (log) + data Person = Person String Boolean getName :: Person -> String @@ -10,4 +12,4 @@ getName p = case p of name :: String name = getName (Person "John Smith" true) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/1570.purs b/examples/passing/1570.purs index 258e4e5098..1bd0172918 100644 --- a/examples/passing/1570.purs +++ b/examples/passing/1570.purs @@ -1,6 +1,8 @@ module Main where +import Control.Monad.Eff.Console (log) + test :: forall a. a -> a test = \(x :: a) -> x -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/1697.purs b/examples/passing/1697.purs index 44f42894eb..4c9570b18d 100644 --- a/examples/passing/1697.purs +++ b/examples/passing/1697.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) _2 :: forall a. a -> a _2 a = a @@ -21,4 +22,4 @@ wtf = do let tmp = _2 1 pure unit -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/1881.purs b/examples/passing/1881.purs index 325e761699..b4351cb89b 100644 --- a/examples/passing/1881.purs +++ b/examples/passing/1881.purs @@ -1,9 +1,11 @@ module Main where -foo = +import Control.Monad.Eff.Console (log) + +foo = 1 -bar +bar = 2 baz @@ -14,4 +16,4 @@ qux = 3 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/1991.purs b/examples/passing/1991.purs index 9418d539ea..c0f5ff2df4 100644 --- a/examples/passing/1991.purs +++ b/examples/passing/1991.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) singleton :: forall a. a -> Array a singleton x = [x] @@ -17,5 +18,5 @@ regression = let as = [1,2,3,4,5] as' = foldMap (\x -> if 1 < x && x < 4 then singleton x else empty) as in as' - -main = Control.Monad.Eff.Console.log "Done" + +main = log "Done" diff --git a/examples/passing/652.purs b/examples/passing/652.purs index 43e49ad981..79995a706a 100644 --- a/examples/passing/652.purs +++ b/examples/passing/652.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) class Foo a b @@ -14,4 +15,4 @@ instance bar :: Bar (a -> b) b instance baz :: (Eq a) => Baz (a -> b) a b -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/810.purs b/examples/passing/810.purs index 256d2c695e..4e32d10da6 100644 --- a/examples/passing/810.purs +++ b/examples/passing/810.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Maybe a = Nothing | Just a @@ -10,4 +11,4 @@ test m = o.x o = case m of Nothing -> { x : Nothing } Just a -> { x : Just a } -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Applicative.purs b/examples/passing/Applicative.purs index fa47117c6a..d78e2aa13f 100644 --- a/examples/passing/Applicative.purs +++ b/examples/passing/Applicative.purs @@ -1,6 +1,6 @@ module Main where -import Prelude () +import Control.Monad.Eff.Console (log) class Applicative f where pure :: forall a. a -> f a @@ -13,4 +13,4 @@ instance applicativeMaybe :: Applicative Maybe where apply (Just f) (Just a) = Just (f a) apply _ _ = Nothing -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ArrayType.purs b/examples/passing/ArrayType.purs index 889fcd3443..a3530a545e 100644 --- a/examples/passing/ArrayType.purs +++ b/examples/passing/ArrayType.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) class Pointed p where point :: forall a. a -> p a @@ -8,4 +9,4 @@ class Pointed p where instance pointedArray :: Pointed Array where point a = [a] -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Auto.purs b/examples/passing/Auto.purs index c3500eb6ae..34b7858a12 100644 --- a/examples/passing/Auto.purs +++ b/examples/passing/Auto.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Auto s i o = Auto { state :: s, step :: s -> i -> o } @@ -12,4 +13,4 @@ exists = \state step f -> f (Auto { state: state, step: step }) run :: forall i o. SomeAuto i o -> i -> o run = \s i -> s (\a -> case a of Auto a -> a.step a.state i) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/BindersInFunctions.purs b/examples/passing/BindersInFunctions.purs index dd4320d1d4..ee9c5dd141 100644 --- a/examples/passing/BindersInFunctions.purs +++ b/examples/passing/BindersInFunctions.purs @@ -4,6 +4,7 @@ import Prelude import Partial.Unsafe (unsafePartial) import Test.Assert (assert') import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (log) snd :: forall a. Partial => Array a -> a snd = \[_, y] -> y @@ -12,4 +13,4 @@ main :: Eff _ _ main = do let ts = unsafePartial (snd [1.0, 2.0]) assert' "Incorrect result from 'snd'." (ts == 2.0) - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/passing/BindingGroups.purs b/examples/passing/BindingGroups.purs index fb7ceb2d2e..0e112d2091 100644 --- a/examples/passing/BindingGroups.purs +++ b/examples/passing/BindingGroups.purs @@ -1,10 +1,11 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) foo = bar where bar r = r + 1.0 r = foo 2.0 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/BlockString.purs b/examples/passing/BlockString.purs index 23f039e4f3..2ffa526001 100644 --- a/examples/passing/BlockString.purs +++ b/examples/passing/BlockString.purs @@ -1,8 +1,9 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) foo :: String foo = """foo""" -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/CaseStatement.purs b/examples/passing/CaseStatement.purs index 6ed934635e..324282d61c 100644 --- a/examples/passing/CaseStatement.purs +++ b/examples/passing/CaseStatement.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data A = A | B | C @@ -18,4 +19,4 @@ h f N a = a h f a N = a h f (J a) (J b) = J (f a b) -main = Control.Monad.Eff.Console.log $ f "Done" "Failed" A +main = log $ f "Done" "Failed" A diff --git a/examples/passing/CheckFunction.purs b/examples/passing/CheckFunction.purs index 187c5776fc..cde7d4ba15 100644 --- a/examples/passing/CheckFunction.purs +++ b/examples/passing/CheckFunction.purs @@ -1,7 +1,8 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test = ((\x -> x+1.0) >>> (\x -> x*2.0)) 4.0 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/CheckSynonymBug.purs b/examples/passing/CheckSynonymBug.purs index 3f565c2a02..cd06f63f6c 100644 --- a/examples/passing/CheckSynonymBug.purs +++ b/examples/passing/CheckSynonymBug.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) length :: forall a. Array a -> Int length _ = 0 @@ -9,4 +10,4 @@ type Foo a = Array a foo _ = length ([] :: Foo Number) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/CheckTypeClass.purs b/examples/passing/CheckTypeClass.purs index 81e86a1a85..c26b2d0211 100644 --- a/examples/passing/CheckTypeClass.purs +++ b/examples/passing/CheckTypeClass.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Bar a = Bar data Baz @@ -14,5 +15,4 @@ foo_ x = foo ((mkBar :: forall a. (Foo a) => a -> Bar a) x) mkBar :: forall a. a -> Bar a mkBar _ = Bar -main = Control.Monad.Eff.Console.log "Done" - +main = log "Done" diff --git a/examples/passing/Church.purs b/examples/passing/Church.purs index fd9cde8bf1..3745805069 100644 --- a/examples/passing/Church.purs +++ b/examples/passing/Church.purs @@ -1,6 +1,6 @@ module Main where -import Prelude () +import Control.Monad.Eff.Console (log) type List a = forall r. r -> (a -> r -> r) -> r @@ -15,4 +15,4 @@ append = \l1 l2 r f -> l2 (l1 r f) f test = append (cons 1 empty) (cons 2 empty) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ClassRefSyntax.purs b/examples/passing/ClassRefSyntax.purs index 3ffd8ea9cf..8601125e35 100644 --- a/examples/passing/ClassRefSyntax.purs +++ b/examples/passing/ClassRefSyntax.purs @@ -1,8 +1,9 @@ module Main where - import Lib (class X, go) +import Lib (class X, go) +import Control.Monad.Eff.Console (log) - go' :: forall a. (X a) => a -> a - go' = go +go' :: forall a. (X a) => a -> a +go' = go - main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Conditional.purs b/examples/passing/Conditional.purs index 303f5a6c72..a3d20520d0 100644 --- a/examples/passing/Conditional.purs +++ b/examples/passing/Conditional.purs @@ -1,9 +1,9 @@ module Main where -import Prelude () +import Control.Monad.Eff.Console (log) fns = \f -> if f true then f else \x -> x not = \x -> if x then false else true -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/DataAndType.purs b/examples/passing/DataAndType.purs index 4ce7527ad4..3d35ce1c99 100644 --- a/examples/passing/DataAndType.purs +++ b/examples/passing/DataAndType.purs @@ -1,9 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data A = A B type B = A -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/DeepArrayBinder.purs b/examples/passing/DeepArrayBinder.purs index d34bfaac02..399b2a4ab8 100644 --- a/examples/passing/DeepArrayBinder.purs +++ b/examples/passing/DeepArrayBinder.purs @@ -2,6 +2,7 @@ module Main where import Prelude import Control.Monad.Eff +import Control.Monad.Eff.Console (log) import Test.Assert data List a = Cons a (List a) | Nil @@ -13,4 +14,4 @@ match2 _ = 0.0 main = do let result = match2 (Cons 1.0 (Cons 2.0 (Cons 3.0 (Cons 4.0 (Cons 5.0 (Cons 6.0 (Cons 7.0 (Cons 8.0 (Cons 9.0 Nil))))))))) assert' "Incorrect result!" (result == 100.0) - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/passing/Do.purs b/examples/passing/Do.purs index 08c559d98e..3cfa9e4183 100644 --- a/examples/passing/Do.purs +++ b/examples/passing/Do.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Maybe a = Nothing | Just a @@ -19,7 +20,7 @@ instance bindMaybe :: Bind Maybe where bind Nothing _ = Nothing bind (Just a) f = f a -instance monadMaybe :: Prelude.Monad Maybe +instance monadMaybe :: Monad Maybe test1 = \_ -> do Just "abc" @@ -64,4 +65,4 @@ test10 _ = do g x = f x / 2.0 Just (f 10.0) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Dollar.purs b/examples/passing/Dollar.purs index 34091264d7..3c0d4d44e6 100644 --- a/examples/passing/Dollar.purs +++ b/examples/passing/Dollar.purs @@ -1,6 +1,6 @@ module Main where -import Prelude () +import Control.Monad.Eff.Console (log) applyFn :: forall a b. (a -> b) -> a -> b applyFn f x = f x @@ -13,4 +13,4 @@ test1 x = id $ id $ id $ id $ x test2 x = id id $ id x -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/EmptyDataDecls.purs b/examples/passing/EmptyDataDecls.purs index 40d77ee846..6c143cde55 100644 --- a/examples/passing/EmptyDataDecls.purs +++ b/examples/passing/EmptyDataDecls.purs @@ -2,6 +2,7 @@ module Main where import Prelude import Test.Assert +import Control.Monad.Eff.Console (log) data Z data S n @@ -15,5 +16,5 @@ cons' :: forall a n. a -> ArrayBox n a -> ArrayBox (S n) a cons' x (ArrayBox xs) = ArrayBox $ append [x] xs main = case cons' 1 $ cons' 2 $ cons' 3 nil of - ArrayBox [1, 2, 3] -> Control.Monad.Eff.Console.log "Done" + ArrayBox [1, 2, 3] -> log "Done" _ -> assert' "Failed" false diff --git a/examples/passing/EmptyRow.purs b/examples/passing/EmptyRow.purs index 9f738fb42d..b6c0fc2916 100644 --- a/examples/passing/EmptyRow.purs +++ b/examples/passing/EmptyRow.purs @@ -1,10 +1,11 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Foo r = Foo { | r } test :: Foo () test = Foo {} -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ExplicitOperatorSections.purs b/examples/passing/ExplicitOperatorSections.purs index b8e6fbfc1c..2f3f0bedc4 100644 --- a/examples/passing/ExplicitOperatorSections.purs +++ b/examples/passing/ExplicitOperatorSections.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) subtractOne :: Int -> Int subtractOne = (_ - 1) @@ -11,4 +12,4 @@ addOne = (1 + _) named :: Int -> Int named = (_ `sub` 1) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ExportExplicit.purs b/examples/passing/ExportExplicit.purs index 5be3fde87f..8443d4fc59 100644 --- a/examples/passing/ExportExplicit.purs +++ b/examples/passing/ExportExplicit.purs @@ -1,9 +1,10 @@ module Main where import M1 +import Control.Monad.Eff.Console (log) testX = X testZ = Z testFoo = foo -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ExportExplicit2.purs b/examples/passing/ExportExplicit2.purs index 99bef2625f..a8803e5a83 100644 --- a/examples/passing/ExportExplicit2.purs +++ b/examples/passing/ExportExplicit2.purs @@ -1,7 +1,8 @@ module Main where import M1 +import Control.Monad.Eff.Console (log) testBar = bar -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/FunctionScope.purs b/examples/passing/FunctionScope.purs index 3506153482..3212d44e4a 100644 --- a/examples/passing/FunctionScope.purs +++ b/examples/passing/FunctionScope.purs @@ -2,6 +2,7 @@ module Main where import Prelude import Test.Assert +import Control.Monad.Eff.Console (log) mkValue :: Number -> Number mkValue id = id @@ -9,4 +10,4 @@ mkValue id = id main = do let value = mkValue 1.0 assert $ value == 1.0 - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/passing/Functions2.purs b/examples/passing/Functions2.purs index e43d88e7ef..1a658ab0d2 100644 --- a/examples/passing/Functions2.purs +++ b/examples/passing/Functions2.purs @@ -2,6 +2,7 @@ module Main where import Prelude import Test.Assert +import Control.Monad.Eff.Console (log) test :: forall a b. a -> b -> a test = \const _ -> const @@ -9,4 +10,4 @@ test = \const _ -> const main = do let value = test "Done" {} assert' "Not done" $ value == "Done" - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/passing/Guards.purs b/examples/passing/Guards.purs index 81fdc2ec71..ddc7678cc6 100644 --- a/examples/passing/Guards.purs +++ b/examples/passing/Guards.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) collatz = \x -> case x of y | y `mod` 2.0 == 0.0 -> y / 2.0 @@ -26,4 +27,4 @@ testIndentation x y | x > 0.0 | otherwise = y - x -main = Control.Monad.Eff.Console.log $ min "Done" "ZZZZ" +main = log $ min "Done" "ZZZZ" diff --git a/examples/passing/IfThenElseMaybe.purs b/examples/passing/IfThenElseMaybe.purs index 77da0234e7..80c83ccee4 100644 --- a/examples/passing/IfThenElseMaybe.purs +++ b/examples/passing/IfThenElseMaybe.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Maybe a = Nothing | Just a @@ -8,4 +9,4 @@ test1 = if true then Just 10 else Nothing test2 = if true then Nothing else Just 10 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ImplicitEmptyImport.purs b/examples/passing/ImplicitEmptyImport.purs index 82261f704e..6265490277 100644 --- a/examples/passing/ImplicitEmptyImport.purs +++ b/examples/passing/ImplicitEmptyImport.purs @@ -1,8 +1,9 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) main = do - Control.Monad.Eff.Console.log "Hello" - Control.Monad.Eff.Console.log "Goodbye" - Control.Monad.Eff.Console.log "Done" + log "Hello" + log "Goodbye" + log "Done" diff --git a/examples/passing/Import.purs b/examples/passing/Import.purs index 3be4119115..75c2d147fa 100644 --- a/examples/passing/Import.purs +++ b/examples/passing/Import.purs @@ -1,5 +1,6 @@ module Main where import M2 +import Control.Monad.Eff.Console (log) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ImportExplicit.purs b/examples/passing/ImportExplicit.purs index 78115ffeaf..92d5ee6de0 100644 --- a/examples/passing/ImportExplicit.purs +++ b/examples/passing/ImportExplicit.purs @@ -1,9 +1,10 @@ module Main where import M1 (X(..)) +import Control.Monad.Eff.Console (log) testX :: X testX = X testY = Y -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/InstanceBeforeClass.purs b/examples/passing/InstanceBeforeClass.purs index 80690e9cd0..d187655b29 100644 --- a/examples/passing/InstanceBeforeClass.purs +++ b/examples/passing/InstanceBeforeClass.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) instance fooNumber :: Foo Number where foo = 0.0 @@ -8,4 +9,4 @@ instance fooNumber :: Foo Number where class Foo a where foo :: a -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/IntAndChar.purs b/examples/passing/IntAndChar.purs index aac7eddc36..366cfcdc63 100644 --- a/examples/passing/IntAndChar.purs +++ b/examples/passing/IntAndChar.purs @@ -2,6 +2,7 @@ module Main where import Prelude import Control.Monad.Eff +import Control.Monad.Eff.Console (log) import Test.Assert f 1 = 1 @@ -15,4 +16,4 @@ main = do assert $ f 0 == 0 assert $ g 'a' == 'a' assert $ g 'b' == 'b' - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/passing/JSReserved.purs b/examples/passing/JSReserved.purs index ee552ca48b..26bde69568 100644 --- a/examples/passing/JSReserved.purs +++ b/examples/passing/JSReserved.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) yield = 0 member = 1 @@ -9,4 +10,4 @@ public = \return -> return this catch = catch -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/KindedType.purs b/examples/passing/KindedType.purs index adff8bb4ed..2a4959bb64 100644 --- a/examples/passing/KindedType.purs +++ b/examples/passing/KindedType.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type Star2Star f = f :: * -> * @@ -30,4 +31,4 @@ class Clazz (a :: *) where instance clazzString :: Clazz String where def = "test" -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/LargeSumType.purs b/examples/passing/LargeSumType.purs index 1cc8ff0e84..d833e8a881 100644 --- a/examples/passing/LargeSumType.purs +++ b/examples/passing/LargeSumType.purs @@ -1,5 +1,7 @@ module Main where - + +import Control.Monad.Eff.Console (log) + data Large = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z explode A A = "A" @@ -30,4 +32,4 @@ explode Y Y = "Y" explode Z Z = "Z" explode _ _ = "" -main = Control.Monad.Eff.Console.log "Done" \ No newline at end of file +main = log "Done" diff --git a/examples/passing/LetInInstance.purs b/examples/passing/LetInInstance.purs index d3e71bfe13..991548528c 100644 --- a/examples/passing/LetInInstance.purs +++ b/examples/passing/LetInInstance.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) class Foo a where foo :: a -> String @@ -11,4 +12,4 @@ instance fooString :: Foo String where go :: String -> String go s = s -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/LiberalTypeSynonyms.purs b/examples/passing/LiberalTypeSynonyms.purs index 8bf802e037..d32213c6ee 100644 --- a/examples/passing/LiberalTypeSynonyms.purs +++ b/examples/passing/LiberalTypeSynonyms.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type Reader = (->) String @@ -18,4 +19,4 @@ f :: (forall r. F r) -> String f g = case g { x: "Hello" } of { x = x } -> x -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/MPTCs.purs b/examples/passing/MPTCs.purs index 8b2fef22b9..195d3dc285 100644 --- a/examples/passing/MPTCs.purs +++ b/examples/passing/MPTCs.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) class NullaryTypeClass where greeting :: String @@ -14,7 +15,7 @@ class Coerce a b where instance coerceRefl :: Coerce a a where coerce a = a -instance coerceShow :: (Prelude.Show a) => Coerce a String where +instance coerceShow :: Show a => Coerce a String where coerce = show -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Match.purs b/examples/passing/Match.purs index 6df2a182ef..50244bb8da 100644 --- a/examples/passing/Match.purs +++ b/examples/passing/Match.purs @@ -1,9 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Foo a = Foo foo = \f -> case f of Foo -> "foo" -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Module.purs b/examples/passing/Module.purs index 8d01717b2a..e8d5f06bc1 100644 --- a/examples/passing/Module.purs +++ b/examples/passing/Module.purs @@ -2,5 +2,6 @@ module Main where import M1 import M2 +import Control.Monad.Eff.Console (log) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Module/M1.purs b/examples/passing/Module/M1.purs index 1c7fbcac59..d276f7a0e7 100644 --- a/examples/passing/Module/M1.purs +++ b/examples/passing/Module/M1.purs @@ -4,7 +4,7 @@ import Prelude data Foo = Foo String -foo :: M1.Foo -> String +foo :: Foo -> String foo = \f -> case f of Foo s -> s <> "foo" bar :: Foo -> String diff --git a/examples/passing/Module/M2.purs b/examples/passing/Module/M2.purs index e2b14c3fad..b2c8b86260 100644 --- a/examples/passing/Module/M2.purs +++ b/examples/passing/Module/M2.purs @@ -1,6 +1,7 @@ module M2 where import Prelude +import M1 as M1 baz :: M1.Foo -> String baz = M1.foo diff --git a/examples/passing/ModuleDeps.purs b/examples/passing/ModuleDeps.purs index a2b5d3c7b2..5736a97c98 100644 --- a/examples/passing/ModuleDeps.purs +++ b/examples/passing/ModuleDeps.purs @@ -1,5 +1,6 @@ module Main where import M1 +import Control.Monad.Eff.Console (log) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ModuleDeps/M1.purs b/examples/passing/ModuleDeps/M1.purs index 7a9a554ba4..5618b41a48 100644 --- a/examples/passing/ModuleDeps/M1.purs +++ b/examples/passing/ModuleDeps/M1.purs @@ -1,5 +1,5 @@ module M1 where -import M2 +import M2 as M2 foo = M2.bar diff --git a/examples/passing/ModuleDeps/M2.purs b/examples/passing/ModuleDeps/M2.purs index 660da88d3d..c6cc0081a4 100644 --- a/examples/passing/ModuleDeps/M2.purs +++ b/examples/passing/ModuleDeps/M2.purs @@ -1,5 +1,5 @@ module M2 where -import M3 +import M3 as M3 bar = M3.baz diff --git a/examples/passing/Monad.purs b/examples/passing/Monad.purs index 96b2afdf83..a1f5120124 100644 --- a/examples/passing/Monad.purs +++ b/examples/passing/Monad.purs @@ -1,6 +1,6 @@ module Main where -import Prelude () +import Control.Monad.Eff.Console (log) type Monad m = { return :: forall a. a -> m a , bind :: forall a b. m a -> (a -> m b) -> m b } @@ -29,4 +29,4 @@ test1 = test id test2 = test maybe -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/MutRec.purs b/examples/passing/MutRec.purs index afee9cd881..c800b4c8a9 100644 --- a/examples/passing/MutRec.purs +++ b/examples/passing/MutRec.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) f 0.0 = 0.0 f x = g x + 0.0 @@ -16,4 +17,4 @@ evenToNumber (Even n) = oddToNumber n + 0.0 oddToNumber (Odd n) = evenToNumber n + 0.0 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/MutRec2.purs b/examples/passing/MutRec2.purs index 762c67643e..844f9fed37 100644 --- a/examples/passing/MutRec2.purs +++ b/examples/passing/MutRec2.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data A = A B @@ -16,4 +17,4 @@ g b = case b of B a -> f a showN :: A -> S showN a = f a -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/MutRec3.purs b/examples/passing/MutRec3.purs index a22ac5de1e..82a710fa18 100644 --- a/examples/passing/MutRec3.purs +++ b/examples/passing/MutRec3.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data A = A B @@ -16,4 +17,4 @@ g b = case b of B a -> f a showN :: A -> S showN a = f a -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/NamedPatterns.purs b/examples/passing/NamedPatterns.purs index 3e0d5575d0..819b354e5a 100644 --- a/examples/passing/NamedPatterns.purs +++ b/examples/passing/NamedPatterns.purs @@ -1,9 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) foo = \x -> case x of y@{ foo = "Foo" } -> y y -> y -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/NegativeBinder.purs b/examples/passing/NegativeBinder.purs index 63ba76aa78..1c73e705a6 100644 --- a/examples/passing/NegativeBinder.purs +++ b/examples/passing/NegativeBinder.purs @@ -1,9 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test :: Number -> Boolean test -1.0 = false test _ = true -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/NegativeIntInRange.purs b/examples/passing/NegativeIntInRange.purs index 734d4a167b..57a60d08ff 100644 --- a/examples/passing/NegativeIntInRange.purs +++ b/examples/passing/NegativeIntInRange.purs @@ -1,8 +1,9 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) n :: Int n = -2147483648 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Nested.purs b/examples/passing/Nested.purs index 0f19014344..b29554ab2b 100644 --- a/examples/passing/Nested.purs +++ b/examples/passing/Nested.purs @@ -1,9 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Extend r a = Extend { prev :: r a, next :: a } data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/NestedWhere.purs b/examples/passing/NestedWhere.purs index 4867ae824b..3f098a567e 100644 --- a/examples/passing/NestedWhere.purs +++ b/examples/passing/NestedWhere.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) f x = g x where @@ -9,4 +10,4 @@ f x = g x go x = go1 (x - 1.0) go1 x = go x -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/NonConflictingExports.purs b/examples/passing/NonConflictingExports.purs index 901e1f79c3..157d996ad2 100644 --- a/examples/passing/NonConflictingExports.purs +++ b/examples/passing/NonConflictingExports.purs @@ -1,9 +1,10 @@ -- No failure here as the export `thing` only refers to Main.thing module Main (thing, main) where - import A +import A +import Control.Monad.Eff.Console (log) - thing :: Int - thing = 2 +thing :: Int +thing = 2 - main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ObjectSynonym.purs b/examples/passing/ObjectSynonym.purs index 34fb7faaaf..3b82ebfaab 100644 --- a/examples/passing/ObjectSynonym.purs +++ b/examples/passing/ObjectSynonym.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type Inner = Number @@ -12,4 +13,4 @@ type Outer = { inner :: Inner } outer :: Outer outer = { inner: inner } -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ObjectUpdate2.purs b/examples/passing/ObjectUpdate2.purs index da2bf114a6..6d10409317 100644 --- a/examples/passing/ObjectUpdate2.purs +++ b/examples/passing/ObjectUpdate2.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type X r = { | r } @@ -14,4 +15,4 @@ test = blah x { baz = "blah" } -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Objects.purs b/examples/passing/Objects.purs index 810dc8033e..fe5ce5eda2 100644 --- a/examples/passing/Objects.purs +++ b/examples/passing/Objects.purs @@ -1,6 +1,7 @@ module Main where import Prelude hiding (append) +import Control.Monad.Eff.Console (log) test = \x -> x.foo + x.bar + 1.0 @@ -32,4 +33,4 @@ test6 = case { "***": 1.0 } of test7 {a: snoog , b : blah } = blah -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/OneConstructor.purs b/examples/passing/OneConstructor.purs index 149e1e2524..8f3fcf299f 100644 --- a/examples/passing/OneConstructor.purs +++ b/examples/passing/OneConstructor.purs @@ -1,9 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data One a = One a one' (One a) = a -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Operators.purs b/examples/passing/Operators.purs index 831659f370..835584ab08 100644 --- a/examples/passing/Operators.purs +++ b/examples/passing/Operators.purs @@ -1,6 +1,8 @@ module Main where import Prelude +import Other (foo) +import Other as Other import Control.Monad.Eff import Control.Monad.Eff.Console @@ -9,9 +11,6 @@ op1 x _ = x infix 4 op1 as ?! -bar :: String -> String -> String -bar = \s1 s2 -> s1 <> s2 - test1 :: forall n. (Semiring n) => n -> n -> (n -> n -> n) -> n test1 x y z = x * y + z x y @@ -44,14 +43,11 @@ op4 = \f x -> f x infix 4 op4 as @@ -foo :: String -> String -foo = \s -> s - test8 = foo @@ "Hello World" -test9 = Main.foo @@ "Hello World" +test9 = Other.foo @@ "Hello World" -test10 = "Hello" `Main.bar` "World" +test10 = "Hello" `Other.baz` "World" op5 :: forall a. Array a -> Array a -> Array a op5 = \as -> \bs -> as diff --git a/examples/passing/Operators/Other.purs b/examples/passing/Operators/Other.purs new file mode 100644 index 0000000000..052a68951c --- /dev/null +++ b/examples/passing/Operators/Other.purs @@ -0,0 +1,7 @@ +module Other where + +foo :: String -> String +foo s = s + +baz :: String -> String -> String +baz s _ = s diff --git a/examples/passing/OptimizerBug.purs b/examples/passing/OptimizerBug.purs index ea371de607..0e4c0f9d81 100644 --- a/examples/passing/OptimizerBug.purs +++ b/examples/passing/OptimizerBug.purs @@ -1,9 +1,10 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) x a = 1.0 + y a y a = x a -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Patterns.purs b/examples/passing/Patterns.purs index 9606afa84b..637396a7aa 100644 --- a/examples/passing/Patterns.purs +++ b/examples/passing/Patterns.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test = \x -> case x of { str = "Foo", bool = true } -> true @@ -19,4 +20,4 @@ isDesc :: Array Number -> Boolean isDesc [x, y] | x > y = true isDesc _ = false -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/PendingConflictingImports.purs b/examples/passing/PendingConflictingImports.purs index 1f6a6dadf8..87c1ad8372 100644 --- a/examples/passing/PendingConflictingImports.purs +++ b/examples/passing/PendingConflictingImports.purs @@ -3,5 +3,6 @@ module Main where -- No error as we never force `thing` to be resolved in `Main` import A import B +import Control.Monad.Eff.Console (log) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/PendingConflictingImports2.purs b/examples/passing/PendingConflictingImports2.purs index 5df6426d8e..0041adc30a 100644 --- a/examples/passing/PendingConflictingImports2.purs +++ b/examples/passing/PendingConflictingImports2.purs @@ -1,9 +1,10 @@ module Main where - import A +import A +import Control.Monad.Eff.Console (log) - -- No error as we never force `thing` to be resolved in `Main` - thing :: Int - thing = 2 +-- No error as we never force `thing` to be resolved in `Main` +thing :: Int +thing = 2 - main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/QualifiedNames.purs b/examples/passing/QualifiedNames.purs index ff27b6df2f..0dcda36824 100644 --- a/examples/passing/QualifiedNames.purs +++ b/examples/passing/QualifiedNames.purs @@ -1,9 +1,11 @@ module Main where import Prelude +import Either as Either +import Control.Monad.Eff.Console (log) either :: forall a b c. (a -> c) -> (b -> c) -> Either.Either a b -> c either f _ (Either.Left x) = f x either _ g (Either.Right y) = g y -main = Control.Monad.Eff.Console.log (either id id (Either.Left "Done")) +main = log (either id id (Either.Left "Done")) diff --git a/examples/passing/Rank2Types.purs b/examples/passing/Rank2Types.purs index 7af12ae7df..fccea0c0bf 100644 --- a/examples/passing/Rank2Types.purs +++ b/examples/passing/Rank2Types.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test1 :: (forall a. (a -> a)) -> Number test1 = \f -> f 0.0 @@ -8,4 +9,4 @@ test1 = \f -> f 0.0 forever :: forall m a b. (forall a b. m a -> (a -> m b) -> m b) -> m a -> m b forever = \bind action -> bind action $ \_ -> forever bind action -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ReExportQualified.purs b/examples/passing/ReExportQualified.purs index dcab96800f..98a1a579aa 100644 --- a/examples/passing/ReExportQualified.purs +++ b/examples/passing/ReExportQualified.purs @@ -2,5 +2,6 @@ module Main where import Prelude import C +import Control.Monad.Eff.Console (log) -main = Control.Monad.Eff.Console.log (x <> y) +main = log (x <> y) diff --git a/examples/passing/Recursion.purs b/examples/passing/Recursion.purs index 67d3094341..f9798f9b9b 100644 --- a/examples/passing/Recursion.purs +++ b/examples/passing/Recursion.purs @@ -1,10 +1,11 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) fib = \n -> case n of 0.0 -> 1.0 1.0 -> 1.0 n -> fib (n - 1.0) + fib (n - 2.0) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/RedefinedFixity.purs b/examples/passing/RedefinedFixity.purs index 762548c3bf..48f147b540 100644 --- a/examples/passing/RedefinedFixity.purs +++ b/examples/passing/RedefinedFixity.purs @@ -1,5 +1,6 @@ module Main where import M3 +import Control.Monad.Eff.Console (log) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ReservedWords.purs b/examples/passing/ReservedWords.purs index b7ffdfbe33..b347b69770 100644 --- a/examples/passing/ReservedWords.purs +++ b/examples/passing/ReservedWords.purs @@ -3,6 +3,7 @@ module Main where import Prelude import Control.Monad.Eff +import Control.Monad.Eff.Console (log) o :: { type :: String } o = { type: "o" } @@ -15,4 +16,4 @@ f { type = "p" } = "Done" f _ = "Fail" main :: Eff _ _ -main = Control.Monad.Eff.Console.log $ f { type: p.type, foo: "bar" } +main = log $ f { type: p.type, foo: "bar" } diff --git a/examples/passing/ResolvableScopeConflict.purs b/examples/passing/ResolvableScopeConflict.purs index f9772d233a..4f63802273 100644 --- a/examples/passing/ResolvableScopeConflict.purs +++ b/examples/passing/ResolvableScopeConflict.purs @@ -2,6 +2,7 @@ module Main where import A (thing) import B +import Control.Monad.Eff.Console (log) -- Not an error as although we have `thing` in scope from both A and B, it is -- imported explicitly from A, giving it a resolvable solution. @@ -9,4 +10,4 @@ what :: Boolean -> Int what true = thing what false = zing -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ResolvableScopeConflict2.purs b/examples/passing/ResolvableScopeConflict2.purs index cb714e8dc0..7101c959c2 100644 --- a/examples/passing/ResolvableScopeConflict2.purs +++ b/examples/passing/ResolvableScopeConflict2.purs @@ -1,6 +1,7 @@ module Main where import A +import Control.Monad.Eff.Console (log) thing :: Int thing = 1 @@ -11,4 +12,4 @@ what :: Boolean -> Int what true = thing what false = zing -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/ResolvableScopeConflict3.purs b/examples/passing/ResolvableScopeConflict3.purs index 4b4c8a727a..396b8cc9f2 100644 --- a/examples/passing/ResolvableScopeConflict3.purs +++ b/examples/passing/ResolvableScopeConflict3.purs @@ -1,8 +1,9 @@ module Main (thing, main, module A) where import A +import Control.Monad.Eff.Console (log) thing :: Int thing = 2 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/RowConstructors.purs b/examples/passing/RowConstructors.purs index fc6c9677b5..53e7b8ec67 100644 --- a/examples/passing/RowConstructors.purs +++ b/examples/passing/RowConstructors.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type Foo = (x :: Number | (y :: Number | (z :: Number))) type Bar = (x :: Number, y :: Number, z :: Number) @@ -39,4 +40,4 @@ wildcard { w: w } = { x: w, y: w, z: w, w: w } wildcard' :: { | Quux _ } -> Number wildcard' { q: q } = q -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/RowPolyInstanceContext.purs b/examples/passing/RowPolyInstanceContext.purs index 0a232f9dd4..0641de0885 100644 --- a/examples/passing/RowPolyInstanceContext.purs +++ b/examples/passing/RowPolyInstanceContext.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) class T s m where state :: (s -> s) -> m Unit @@ -19,4 +20,4 @@ test2 = state $ \o -> o { foo = o.foo <> "!" } main = do let t1 = test1 let t2 = test2 - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/passing/ScopedTypeVariables.purs b/examples/passing/ScopedTypeVariables.purs index 5526059732..862d821135 100644 --- a/examples/passing/ScopedTypeVariables.purs +++ b/examples/passing/ScopedTypeVariables.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test1 :: forall a. (a -> a) -> a -> a test1 f x = g (g x) @@ -33,4 +34,4 @@ test4 = h j x = x -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/Sequence.purs b/examples/passing/Sequence.purs index 692fbd0a73..c6ba367890 100644 --- a/examples/passing/Sequence.purs +++ b/examples/passing/Sequence.purs @@ -2,6 +2,7 @@ module Main where import Prelude import Control.Monad.Eff +import Control.Monad.Eff.Console (log) data List a = Cons a (List a) | Nil @@ -12,4 +13,4 @@ instance sequenceList :: Sequence List where sequence Nil = pure Nil sequence (Cons x xs) = Cons <$> x <*> sequence xs -main = sequence $ Cons (Control.Monad.Eff.Console.log "Done") Nil +main = sequence $ Cons (log "Done") Nil diff --git a/examples/passing/SequenceDesugared.purs b/examples/passing/SequenceDesugared.purs index 622f1c3ba4..f4ea3d1bb4 100644 --- a/examples/passing/SequenceDesugared.purs +++ b/examples/passing/SequenceDesugared.purs @@ -2,6 +2,7 @@ module Main where import Prelude import Control.Monad.Eff +import Control.Monad.Eff.Console (log) data List a = Cons a (List a) | Nil @@ -31,7 +32,7 @@ sequenceList''' = Sequence ((\val -> case val of Cons x xs -> Cons <$> x <*> sequence sequenceList''' xs) :: forall m a. (Monad m) => List (m a) -> m (List a)) main = do - sequence sequenceList $ Cons (Control.Monad.Eff.Console.log "Done") Nil - sequence sequenceList' $ Cons (Control.Monad.Eff.Console.log "Done") Nil - sequence sequenceList'' $ Cons (Control.Monad.Eff.Console.log "Done") Nil - sequence sequenceList''' $ Cons (Control.Monad.Eff.Console.log "Done") Nil + sequence sequenceList $ Cons (log "Done") Nil + sequence sequenceList' $ Cons (log "Done") Nil + sequence sequenceList'' $ Cons (log "Done") Nil + sequence sequenceList''' $ Cons (log "Done") Nil diff --git a/examples/passing/ShadowedName.purs b/examples/passing/ShadowedName.purs index 8238d81570..6098249c7e 100644 --- a/examples/passing/ShadowedName.purs +++ b/examples/passing/ShadowedName.purs @@ -2,9 +2,10 @@ module Main where import Prelude import Control.Monad.Eff.Console +import Control.Monad.Eff.Console (log) done :: String done = let str = "Not yet done" in let str = "Done" in str -main = Control.Monad.Eff.Console.log done +main = log done diff --git a/examples/passing/SignedNumericLiterals.purs b/examples/passing/SignedNumericLiterals.purs index 12937db0cc..1ebcdb4f54 100644 --- a/examples/passing/SignedNumericLiterals.purs +++ b/examples/passing/SignedNumericLiterals.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) p = 0.5 q = 1.0 @@ -14,4 +15,4 @@ f x = -x test1 = 2.0 - 1.0 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TCOCase.purs b/examples/passing/TCOCase.purs index 654aa53986..45cde9fa3d 100644 --- a/examples/passing/TCOCase.purs +++ b/examples/passing/TCOCase.purs @@ -1,10 +1,11 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Data = One | More Data -main = Control.Monad.Eff.Console.log (from (to 10000.0 One)) +main = log (from (to 10000.0 One)) where to 0.0 a = a to n a = to (n - 1.0) (More a) diff --git a/examples/passing/Tick.purs b/examples/passing/Tick.purs index 6b8f19e251..4e655e6cef 100644 --- a/examples/passing/Tick.purs +++ b/examples/passing/Tick.purs @@ -1,7 +1,8 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) test' x = x -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TopLevelCase.purs b/examples/passing/TopLevelCase.purs index 1e11b7de08..c43bc65782 100644 --- a/examples/passing/TopLevelCase.purs +++ b/examples/passing/TopLevelCase.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) gcd :: Number -> Number -> Number gcd 0.0 x = x @@ -15,4 +16,4 @@ data A = A parseTest A 0.0 = 0.0 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TransitiveImport/Middle.purs b/examples/passing/TransitiveImport/Middle.purs index 3ad1161ac2..c4b5282a75 100644 --- a/examples/passing/TransitiveImport/Middle.purs +++ b/examples/passing/TransitiveImport/Middle.purs @@ -1,3 +1,5 @@ module Middle where -middle = Test.test +import Test (test) + +middle = test diff --git a/examples/passing/TypeClasses.purs b/examples/passing/TypeClasses.purs index b6e06c7c59..b65d93d6f0 100644 --- a/examples/passing/TypeClasses.purs +++ b/examples/passing/TypeClasses.purs @@ -5,19 +5,19 @@ import Control.Monad.Eff.Console (log) test1 = \_ -> show "testing" -f :: forall a. (Prelude.Show a) => a -> String +f :: forall a. (Show a) => a -> String f x = show x test2 = \_ -> f "testing" -test7 :: forall a. (Prelude.Show a) => a -> String +test7 :: forall a. (Show a) => a -> String test7 = show test8 = \_ -> show $ "testing" data Data a = Data a -instance showData :: (Prelude.Show a) => Prelude.Show (Data a) where +instance showData :: (Show a) => Show (Data a) where show (Data a) = "Data (" <> show a <> ")" test3 = \_ -> show (Data "testing") diff --git a/examples/passing/TypeClassesInOrder.purs b/examples/passing/TypeClassesInOrder.purs index a34db925b1..f02c037070 100644 --- a/examples/passing/TypeClassesInOrder.purs +++ b/examples/passing/TypeClassesInOrder.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) class Foo a where foo :: a -> String @@ -8,4 +9,4 @@ class Foo a where instance fooString :: Foo String where foo s = s -main = Control.Monad.Eff.Console.log $ foo "Done" +main = log $ foo "Done" diff --git a/examples/passing/TypeClassesWithOverlappingTypeVariables.purs b/examples/passing/TypeClassesWithOverlappingTypeVariables.purs index 9b5c6a9596..281e7af8f3 100644 --- a/examples/passing/TypeClassesWithOverlappingTypeVariables.purs +++ b/examples/passing/TypeClassesWithOverlappingTypeVariables.purs @@ -1,11 +1,12 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Either a b = Left a | Right b -instance functorEither :: Prelude.Functor (Either a) where +instance functorEither :: Functor (Either a) where map _ (Left x) = Left x map f (Right y) = Right (f y) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeDecl.purs b/examples/passing/TypeDecl.purs index 76b32c4927..6cecb573c7 100644 --- a/examples/passing/TypeDecl.purs +++ b/examples/passing/TypeDecl.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) k :: String -> Number -> String k x y = x @@ -9,4 +10,4 @@ iterate :: forall a. Number -> (a -> a) -> a -> a iterate 0.0 f a = a iterate n f a = iterate (n - 1.0) f (f a) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeOperators.purs b/examples/passing/TypeOperators.purs index deb73b1132..fbbc723e4f 100644 --- a/examples/passing/TypeOperators.purs +++ b/examples/passing/TypeOperators.purs @@ -1,6 +1,7 @@ module Main where import A (type (~>), type (/\), (/\)) +import Control.Monad.Eff.Console (log) natty ∷ ∀ f. f ~> f natty x = x @@ -16,4 +17,4 @@ testPrecedence2 nat fx = nat fx swap ∷ ∀ a b. a /\ b → b /\ a swap (a /\ b) = b /\ a -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeSynonymInData.purs b/examples/passing/TypeSynonymInData.purs index 62da487f7c..198d6f78c3 100644 --- a/examples/passing/TypeSynonymInData.purs +++ b/examples/passing/TypeSynonymInData.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type A a = Array a @@ -8,4 +9,4 @@ data Foo a = Foo (A a) | Bar foo (Foo []) = Bar -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeSynonyms.purs b/examples/passing/TypeSynonyms.purs index 3cc4cf9631..0ca79844c7 100644 --- a/examples/passing/TypeSynonyms.purs +++ b/examples/passing/TypeSynonyms.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) type Lens a b = { get :: a -> b @@ -24,4 +25,4 @@ fst = test1 :: forall a b c. Lens (Pair (Pair a b) c) a test1 = composeLenses fst fst -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeWildcards.purs b/examples/passing/TypeWildcards.purs index f6f3da2bcf..df9e3fdeda 100644 --- a/examples/passing/TypeWildcards.purs +++ b/examples/passing/TypeWildcards.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) testTopLevel :: _ -> _ testTopLevel n = n + 1.0 @@ -12,4 +13,4 @@ test f a = go (f a) a go a1 a2 | a1 == a2 = a1 go a1 _ = go (f a1) a1 -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeWildcardsRecordExtension.purs b/examples/passing/TypeWildcardsRecordExtension.purs index 615fe9edac..fe21b47484 100644 --- a/examples/passing/TypeWildcardsRecordExtension.purs +++ b/examples/passing/TypeWildcardsRecordExtension.purs @@ -1,8 +1,9 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) foo :: forall a. {b :: Number | a} -> {b :: Number | _} foo f = f -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypeWithoutParens.purs b/examples/passing/TypeWithoutParens.purs index 7cef2b5657..729016f5eb 100644 --- a/examples/passing/TypeWithoutParens.purs +++ b/examples/passing/TypeWithoutParens.purs @@ -1,6 +1,7 @@ module Main where import Lib (X, Y) +import Control.Monad.Eff.Console (log) idX :: X -> X idX x = x @@ -8,4 +9,4 @@ idX x = x idY :: Y -> Y idY y = y -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/TypedBinders.purs b/examples/passing/TypedBinders.purs index ea63815dac..2d3da7c67d 100644 --- a/examples/passing/TypedBinders.purs +++ b/examples/passing/TypedBinders.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Tuple a b = Tuple a b @@ -31,7 +32,7 @@ instance monadStateState :: MonadState s (State s) where get = State (\s -> Tuple s s) put s = State (\_ -> Tuple s {}) -modify :: forall m s. (Prelude.Monad m, MonadState s m) => (s -> s) -> m {} +modify :: forall m s. (Monad m, MonadState s m) => (s -> s) -> m {} modify f = do s <- get put (f s) @@ -64,4 +65,4 @@ main = do t2 = test2 id t3 = test3 1 t4 = test4 (Tuple 1 0) - Control.Monad.Eff.Console.log "Done" + log "Done" diff --git a/examples/passing/TypedWhere.purs b/examples/passing/TypedWhere.purs index 177369685e..d9c489ad88 100644 --- a/examples/passing/TypedWhere.purs +++ b/examples/passing/TypedWhere.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data E a b = L a | R b @@ -14,4 +15,4 @@ lefts = go N go ls (C (L a) rest) = go (C a ls) rest go ls (C _ rest) = go ls rest -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/UnderscoreIdent.purs b/examples/passing/UnderscoreIdent.purs index 4d0bcb916c..0a02edc5bf 100644 --- a/examples/passing/UnderscoreIdent.purs +++ b/examples/passing/UnderscoreIdent.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) data Data_type = Con_Structor | Con_2 String @@ -9,4 +10,4 @@ type Type_name = Data_type done (Con_2 s) = s done _ = "Failed" -main = Control.Monad.Eff.Console.log (done (Con_2 "Done")) +main = log (done (Con_2 "Done")) diff --git a/examples/passing/UnicodeIdentifier.purs b/examples/passing/UnicodeIdentifier.purs index 0be0e3e7e0..9041a4f9e8 100644 --- a/examples/passing/UnicodeIdentifier.purs +++ b/examples/passing/UnicodeIdentifier.purs @@ -1,5 +1,7 @@ module Main where +import Control.Monad.Eff.Console (log) + f asgård = asgård -main = Control.Monad.Eff.Console.log (f "Done") +main = log (f "Done") diff --git a/examples/passing/UnicodeOperators.purs b/examples/passing/UnicodeOperators.purs index 3fa3347419..f93584fb8e 100644 --- a/examples/passing/UnicodeOperators.purs +++ b/examples/passing/UnicodeOperators.purs @@ -1,5 +1,7 @@ module Main where +import Control.Monad.Eff.Console (log) + compose :: forall a b c. (b -> c) -> (a -> b) -> a -> c compose f g a = f (g a) @@ -17,4 +19,4 @@ emptySet _ = true test2 = 1 ∈ emptySet -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/UnknownInTypeClassLookup.purs b/examples/passing/UnknownInTypeClassLookup.purs index 94f929f343..7ba68065b0 100644 --- a/examples/passing/UnknownInTypeClassLookup.purs +++ b/examples/passing/UnknownInTypeClassLookup.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) class EQ a b @@ -11,4 +12,4 @@ test _ _ = "Done" runTest a = test a a -main = Control.Monad.Eff.Console.log $ runTest 0.0 +main = log $ runTest 0.0 diff --git a/examples/passing/UntupledConstraints.purs b/examples/passing/UntupledConstraints.purs index 55cff87654..48507943ff 100644 --- a/examples/passing/UntupledConstraints.purs +++ b/examples/passing/UntupledConstraints.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Control.Monad.Eff.Console (log) class Show a <= Nonsense a where method :: a -> a diff --git a/examples/passing/WildcardType.purs b/examples/passing/WildcardType.purs index 42a4b9296a..b661acac1f 100644 --- a/examples/passing/WildcardType.purs +++ b/examples/passing/WildcardType.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Control.Monad.Eff.Console (log) f1 :: (_ -> _) -> _ f1 g = g 1 @@ -9,5 +9,4 @@ f1 g = g 1 f2 :: _ -> _ f2 _ = "Done" -main = Control.Monad.Eff.Console.log $ f1 f2 - +main = log $ f1 f2 diff --git a/examples/passing/iota.purs b/examples/passing/iota.purs index be0430ef8c..a261eb55f0 100644 --- a/examples/passing/iota.purs +++ b/examples/passing/iota.purs @@ -1,9 +1,11 @@ module Main where +import Control.Monad.Eff.Console (log) + s = \x -> \y -> \z -> x z (y z) k = \x -> \y -> x iota = \x -> x s k -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/examples/passing/s.purs b/examples/passing/s.purs index 041b125d70..a16149129e 100644 --- a/examples/passing/s.purs +++ b/examples/passing/s.purs @@ -1,7 +1,8 @@ module Main where import Prelude +import Control.Monad.Eff.Console (log) s = \x y z -> x z (y z) -main = Control.Monad.Eff.Console.log "Done" +main = log "Done" diff --git a/purescript.cabal b/purescript.cabal index d9b3709a66..234a3c2d44 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -38,6 +38,7 @@ extra-source-files: examples/passing/*.purs , examples/passing/ModuleExportSelf/*.purs , examples/passing/NonConflictingExports/*.purs , examples/passing/OperatorAliasElsewhere/*.purs + , examples/passing/Operators/*.purs , examples/passing/PendingConflictingImports/*.purs , examples/passing/PendingConflictingImports2/*.purs , examples/passing/QualifiedNames/*.purs diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 6aa1f66dd7..df4cda0a3b 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -60,7 +60,7 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do -- TODO: this needs some work to be easier to understand - let scope = maybe nullImports (\(_, imps', _) -> imps') (M.lookup mn env) + let scope = maybe primImports (\(_, imps', _) -> imps') (M.lookup mn env) usedImps' = foldr (elaborateUsed scope) usedImps exportedModules numOpenImports = getSum $ foldMap (Sum . countOpenImports) mdecls allowImplicit = numOpenImports == 1 @@ -159,9 +159,11 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do elaborateUsed scope mne used = foldr go used $ extractByQual mne (importedTypeClasses scope) TyClassName + ++ extractByQual mne (importedTypeOps scope) TyOpName ++ extractByQual mne (importedTypes scope) TyName ++ extractByQual mne (importedDataConstructors scope) DctorName ++ extractByQual mne (importedValues scope) IdentName + ++ extractByQual mne (importedValueOps scope) ValOpName where go :: (ModuleName, Qualified Name) -> UsedImports -> UsedImports go (q, name) = M.alter (Just . maybe [name] (name :)) q @@ -298,6 +300,7 @@ findUsedRefs env mni qn names = let classRefs = TypeClassRef <$> mapMaybe (getClassName <=< disqualifyFor qn) names valueRefs = ValueRef <$> mapMaybe (getIdentName <=< disqualifyFor qn) names + valueOpRefs = ValueOpRef <$> mapMaybe (getValOpName <=< disqualifyFor qn) names typeOpRefs = TypeOpRef <$> mapMaybe (getTypeOpName <=< disqualifyFor qn) names types = mapMaybe (getTypeName <=< disqualifyFor qn) names dctors = mapMaybe (getDctorName <=< disqualifyFor qn) names @@ -306,7 +309,7 @@ findUsedRefs env mni qn names = typesRefs = map (flip TypeRef (Just [])) typesWithoutDctors ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors) - in classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs + in classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs where diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 9be084e22a..d8a8a788e1 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -16,7 +16,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Lazy import Control.Monad.Writer (MonadWriter(..), censor) -import Data.List (find, nub) +import Data.List (nub) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -65,9 +65,9 @@ desugarImportsWithEnv externs modules = do externsEnv env ExternsFile{..} = do let members = Exports{..} ss = internalModuleSourceSpan "" - env' = M.insert efModuleName (ss, nullImports, members) env + env' = M.insert efModuleName (ss, primImports, members) env fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)]) - imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports) + imps <- foldM (resolveModuleImport env') primImports (map fromEFImport efImports) exps <- resolveExports env' ss efModuleName imps members efExports return $ M.insert efModuleName (ss, imps, exps) env where @@ -101,7 +101,7 @@ desugarImportsWithEnv externs modules = do Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss] Nothing -> do members <- findExportable m - let env' = M.insert mn (ss, nullImports, members) env + let env' = M.insert mn (ss, primImports, members) env (m', imps) <- resolveImports env' m exps <- maybe (return members) (resolveExports env' ss mn imps members) refs return (m' : ms, M.insert mn (ss, imps, exps) env) @@ -110,7 +110,7 @@ desugarImportsWithEnv externs modules = do renameInModule' env m@(Module _ _ mn _ _) = warnAndRethrow (addHint (ErrorInModule mn)) $ do let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env - (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m) + (m', used) <- flip runStateT M.empty $ renameInModule imps (elaborateExports exps m) lintImports m' env used return m' @@ -147,11 +147,10 @@ elaborateExports exps (Module ss coms mn decls refs) = renameInModule :: forall m . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) - => Env - -> Imports + => Imports -> Module -> m Module -renameInModule env imports (Module ss coms mn decls exps) = +renameInModule imports (Module ss coms mn decls exps) = Module ss coms mn <$> parU decls go <*> pure exps where @@ -219,10 +218,9 @@ renameInModule env imports (Module ss coms mn decls exps) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b) updateBinder s@(pos, _) (OpBinder op) = (,) s <$> (OpBinder <$> updateValueOpName op pos) - updateBinder s (TypedBinder t b) = do - (s'@ (span', _), b') <- updateBinder s b - t' <- updateTypesEverywhere span' t - return (s', TypedBinder t' b') + updateBinder s@(pos, _) (TypedBinder t b) = do + t' <- updateTypesEverywhere pos t + return (s, TypedBinder t' b) updateBinder s v = return (s, v) @@ -244,82 +242,51 @@ renameInModule env imports (Module ss coms mn decls exps) = updateType :: Type -> m Type updateType (TypeOp name) = TypeOp <$> updateTypeOpName name pos updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos - updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t + updateType (ConstrainedType cs t) = ConstrainedType <$> traverse updateInConstraint cs <*> pure t updateType t = return t + updateInConstraint :: Constraint -> m Constraint + updateInConstraint (Constraint name ts info) = + Constraint <$> updateClassName name pos <*> pure ts <*> pure info updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint] - updateConstraints pos = traverse (\(Constraint name ts info) -> - Constraint <$> updateClassName name pos - <*> traverse (updateTypesEverywhere pos) ts - <*> pure info) + updateConstraints pos = traverse $ \(Constraint name ts info) -> + Constraint + <$> updateClassName name pos + <*> traverse (updateTypesEverywhere pos) ts + <*> pure info updateTypeName :: Qualified (ProperName 'TypeName) -> Maybe SourceSpan -> m (Qualified (ProperName 'TypeName)) - updateTypeName = - update (importedTypes imports) (resolveType . exportedTypes) TyName + updateTypeName = update (importedTypes imports) TyName updateTypeOpName :: Qualified (OpName 'TypeOpName) -> Maybe SourceSpan -> m (Qualified (OpName 'TypeOpName)) - updateTypeOpName = - update (importedTypeOps imports) (resolve . exportedTypeOps) TyOpName + updateTypeOpName = update (importedTypeOps imports) TyOpName updateDataConstructorName :: Qualified (ProperName 'ConstructorName) -> Maybe SourceSpan -> m (Qualified (ProperName 'ConstructorName)) - updateDataConstructorName = - update - (importedDataConstructors imports) - (resolveDctor . exportedTypes) - DctorName + updateDataConstructorName = update (importedDataConstructors imports) DctorName updateClassName :: Qualified (ProperName 'ClassName) -> Maybe SourceSpan -> m (Qualified (ProperName 'ClassName)) - updateClassName = - update - (importedTypeClasses imports) - (resolve . exportedTypeClasses) - TyClassName + updateClassName = update (importedTypeClasses imports) TyClassName updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident) - updateValueName = - update (importedValues imports) (resolve . exportedValues) IdentName + updateValueName = update (importedValues imports) IdentName updateValueOpName :: Qualified (OpName 'ValueOpName) -> Maybe SourceSpan -> m (Qualified (OpName 'ValueOpName)) - updateValueOpName = - update (importedValueOps imports) (resolve . exportedValueOps) ValOpName - - -- Used when performing an update to qualify values and classes with their - -- module of original definition. - resolve :: Ord a => M.Map a ModuleName -> a -> Maybe (Qualified a) - resolve as name = mkQualified name <$> name `M.lookup` as - - -- Used when performing an update to qualify types with their module of - -- original definition. - resolveType - :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) - -> ProperName 'TypeName - -> Maybe (Qualified (ProperName 'TypeName)) - resolveType tys name = - mkQualified name . snd <$> M.lookup name tys - - -- Used when performing an update to qualify data constructors with their - -- module of original definition. - resolveDctor - :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) - -> ProperName 'ConstructorName - -> Maybe (Qualified (ProperName 'ConstructorName)) - resolveDctor tys name = - mkQualified name . snd <$> find (elem name . fst) tys + updateValueOpName = update (importedValueOps imports) ValOpName -- Update names so unqualified references become qualified, and locally -- qualified references are replaced with their canoncial qualified names @@ -327,12 +294,11 @@ renameInModule env imports (Module ss coms mn decls exps) = update :: (Ord a, Show a) => M.Map (Qualified a) [ImportRecord a] - -> (Exports -> a -> Maybe (Qualified a)) -> (a -> Name) -> Qualified a -> Maybe SourceSpan -> m (Qualified a) - update imps getE toName qname@(Qualified mn' name) pos = positioned $ + update imps toName qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imps, mn') of -- We found the name in our imports, so we return the name for it, @@ -354,13 +320,9 @@ renameInModule env imports (Module ss coms mn decls exps) = -- by qualified importing). If that's not the case, then we just need to -- check it refers to a symbol in another module. (Nothing, Just mn'') -> - case M.lookup mn'' env of - Nothing - | mn'' `S.member` importedVirtualModules imports -> throwUnknown - | otherwise -> - throwError . errorMessage . - UnknownName . Qualified Nothing $ ModName mn'' - Just env' -> maybe throwUnknown return (getE (envModuleExports env') name) + if mn'' `S.member` importedQualModules imports || mn'' `S.member` importedModules imports + then throwUnknown + else throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn'' -- If neither of the above cases are true then it's an undefined or -- unimported symbol. diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 1d87db545d..a1426b6769 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -2,7 +2,7 @@ module Language.PureScript.Sugar.Names.Env ( ImportRecord(..) , ImportProvenance(..) , Imports(..) - , nullImports + , primImports , Exports(..) , nullExports , Env @@ -58,6 +58,7 @@ data ImportProvenance = FromImplicit | FromExplicit | Local + | Prim deriving (Eq, Ord, Show, Read) type ImportMap a = M.Map (Qualified a) [ImportRecord a] @@ -98,18 +99,33 @@ data Imports = Imports -- , importedModules :: S.Set ModuleName -- | - -- The names of "virtual" modules that come into existence when "import as" - -- is used. + -- The "as" names of modules that have been imported qualified. -- - , importedVirtualModules :: S.Set ModuleName + , importedQualModules :: S.Set ModuleName } deriving (Show, Read) --- | --- An empty 'Imports' value. --- nullImports :: Imports nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty +-- | +-- An 'Imports' value with imports for the `Prim` module. +-- +primImports :: Imports +primImports = + nullImports + { importedTypes = M.fromList $ mkEntries `concatMap` M.keys primTypes + , importedTypeClasses = M.fromList $ mkEntries `concatMap` M.keys primClasses + } + where + mkEntries :: Qualified a -> [(Qualified a, [ImportRecord a])] + mkEntries fullName@(Qualified _ name) = + [ (fullName, [ImportRecord fullName primModuleName Prim]) + , (Qualified Nothing name, [ImportRecord fullName primModuleName Prim]) + ] + +primModuleName :: ModuleName +primModuleName = ModuleName [ProperName "Prim"] + -- | -- The exported declarations from a module. -- @@ -186,7 +202,7 @@ primExports = -- | Environment which only contains the Prim module. primEnv :: Env primEnv = M.singleton - (ModuleName [ProperName "Prim"]) + primModuleName (internalModuleSourceSpan "", nullImports, primExports) -- | diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 5fff7b8b3d..b8640a9466 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -53,7 +53,7 @@ resolveImports env (Module ss coms currentModule decls exps) = imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports' (Module ss coms currentModule decls exps,) <$> - foldM (resolveModuleImport env) nullImports (M.toList scope) + foldM (resolveModuleImport env) primImports (M.toList scope) -- | Constructs a set of imports for a single module import. resolveModuleImport @@ -74,9 +74,10 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps (throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn) (return . envModuleExports) (mn `M.lookup` env) - let virtualModules = importedVirtualModules ie' - ie'' = ie' { importedModules = S.insert mn (importedModules ie') - , importedVirtualModules = maybe virtualModules (`S.insert` virtualModules) impQual + let impModules = importedModules ie' + qualModules = importedQualModules ie' + ie'' = ie' { importedModules = maybe (S.insert mn impModules) (const impModules) impQual + , importedQualModules = maybe qualModules (`S.insert` qualModules) impQual } positioned $ resolveImport mn modExports ie'' impQual typ where diff --git a/tests/support/bower.json b/tests/support/bower.json index fa82ef3c8d..ca9d449fe4 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -7,6 +7,6 @@ "purescript-functions": "1.0.0-rc.1", "purescript-prelude": "1.0.0-rc.3", "purescript-st": "1.0.0-rc.1", - "purescript-partial": "1.1.1" + "purescript-partial": "1.1.2" } } From 630fb195f7ec5cb4e0ab825cb41a2b2657beed94 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 22 May 2016 11:01:20 -0700 Subject: [PATCH 0429/1580] Avoid overlaps during type renaming in errors --- src/Language/PureScript/Errors.hs | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 4537e97b75..32e656bad3 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -340,14 +340,17 @@ addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint -- | A map from rigid type variable name/unknown variable pairs to new variables. data TypeMap = TypeMap - { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan) - , umNextSkolem :: Int - , umUnknownMap :: M.Map Int Int - , umNextUnknown :: Int + { umSkolemMap :: M.Map Int (String, Int, Maybe SourceSpan) + -- ^ a map from skolems to their new names, including source and naming info + , umUnknownMap :: M.Map Int Int + -- ^ a map from unification variables to their new names + , umNextIndex :: Int + -- ^ unknowns and skolems share a source of names during renaming, to + -- avoid overlaps in error messages. This is the next label for either case. } deriving Show defaultUnknownMap :: TypeMap -defaultUnknownMap = TypeMap M.empty 0 M.empty 0 +defaultUnknownMap = TypeMap M.empty M.empty 0 -- | How critical the issue is data Level = Error | Warning deriving Show @@ -366,16 +369,16 @@ replaceUnknowns = everywhereOnTypesM replaceTypes m <- get case M.lookup u (umUnknownMap m) of Nothing -> do - let u' = umNextUnknown m - put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextUnknown = u' + 1 } + let u' = umNextIndex m + put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextIndex = u' + 1 } return (TUnknown u') Just u' -> return (TUnknown u') replaceTypes (Skolem name s sko ss) = do m <- get case M.lookup s (umSkolemMap m) of Nothing -> do - let s' = umNextSkolem m - put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextSkolem = s' + 1 } + let s' = umNextIndex m + put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextIndex = s' + 1 } return (Skolem name s' sko ss) Just (_, s', _) -> return (Skolem name s' sko ss) replaceTypes other = return other From 57e9201ce59dfd1674370bfa73346870f7270615 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 22 May 2016 20:22:59 +0200 Subject: [PATCH 0430/1580] Cache last rebuild (#2083) * Cache the last rebuilt module inside psc-ide state It's cached with its exports opened up, so that we can source completions from private members when we are editing a module. * Adds documentation to the functions inside ...Ide.State and breaks the functions into a pure and a stateful part to minimize time spent in STM * Cleans up json instances for Command to use Applicative style where possible * Don't add a default import for Prim rebuildModule inside ...Make already does that now * only parse a single module when rebuilding Now that multiple modules per file are forbidden, we can simplify the parsing code in Rebuild a bit. * remove the cacheSuccess flag * fix docs --- psc-ide-server/PROTOCOL.md | 36 +++-- src/Language/PureScript/Ide.hs | 27 ++-- src/Language/PureScript/Ide/Command.hs | 114 +++++++------ src/Language/PureScript/Ide/Rebuild.hs | 136 +++++++++++++--- src/Language/PureScript/Ide/State.hs | 150 +++++++++++------- src/Language/PureScript/Ide/Types.hs | 7 +- src/Language/PureScript/Ide/Util.hs | 3 + src/Language/PureScript/Ide/Watcher.hs | 13 +- .../PureScript/Parser/Declarations.hs | 21 ++- tests/Language/PureScript/Ide/Integration.hs | 26 +-- tests/Language/PureScript/Ide/RebuildSpec.hs | 8 +- tests/Language/PureScript/IdeSpec.hs | 2 +- .../src/RebuildSpecWithHiddenIdent.purs | 6 + 13 files changed, 361 insertions(+), 188 deletions(-) create mode 100644 tests/support/pscide/src/RebuildSpecWithHiddenIdent.purs diff --git a/psc-ide-server/PROTOCOL.md b/psc-ide-server/PROTOCOL.md index e62160f703..73998a3010 100644 --- a/psc-ide-server/PROTOCOL.md +++ b/psc-ide-server/PROTOCOL.md @@ -38,15 +38,17 @@ The `type` command looks up the type for a given identifier. **Params:** - `search :: String`: The identifier to look for. Only matches on equality. - - `filters :: [Filter]`: These filters will be applied before looking for the + - `filters :: (optional) [Filter]`: These filters will be applied before looking for the identifier. These filters get combined with *AND*, so a candidate must match *ALL* of them to be eligible. + - `currentModule :: (optional) String`: see *Complete* command ```json { "command": "type", "params": { "search": "filterM", - "filters": [Filter] + "filters": [{..}], + "currentModule": "Main" } } ``` @@ -58,20 +60,25 @@ The possible types are returned in the same format as completions The `complete` command looks up possible completions/corrections. **Params**: - - `filters :: [Filter]`: The same as for the `type` command. A candidate must match - all filters. - - `matcher :: (optional) Matcher`: The strategy used for matching candidates after filtering. - Results are scored internally and will be returned in the descending order where - the nth element is better then the n+1-th. - - If no matcher is given every candidate, that passes the filters, is returned in no - particular order. + - `filters :: [Filter]`: The same as for the `type` command. A candidate must + match all filters. + - `matcher :: (optional) Matcher`: The strategy used for matching candidates + after filtering. Results are scored internally and will be returned in the + descending order where the nth element is better then the n+1-th. + - `currentModule :: (optional) String`: The current modules name. If it matches + with the rebuild cache non-exported modules will also be completed. You can + fill the rebuild cache by using the "Rebuild" command. + + If no matcher is given every candidate, that passes the filters, is returned + in no particular order. + ```json { "command": "complete", "params": { - "filters": [Filter], - "matcher": (optional) Matcher + "filters": [{..}, {..}], + "matcher": {..} + "currentModule": "Main" } } ``` @@ -244,10 +251,11 @@ Example: The `rebuild` command provides a fast rebuild for a single module. It doesn't recompile the entire project though. All the modules dependencies need to be -loaded. +loaded. A successful rebuild will be stored to allow for completions of private +identifiers. Arguments: -- `file :: String` the path to the module to rebuild + - `file :: String` the path to the module to rebuild ```json { diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index dc92ffbcc0..b545a82071 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -36,6 +36,7 @@ import Data.Maybe (catMaybes, mapMaybe) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T +import qualified Language.PureScript as P import qualified Language.PureScript.Ide.CaseSplit as CS import Language.PureScript.Ide.Command import Language.PureScript.Ide.Completion @@ -60,10 +61,10 @@ handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => handleCommand (Load [] []) = loadAllModules handleCommand (Load modules deps) = loadModulesAndDeps modules deps -handleCommand (Type search filters) = - findType search filters -handleCommand (Complete filters matcher) = - findCompletions filters matcher +handleCommand (Type search filters currentModule) = + findType search filters currentModule +handleCommand (Complete filters matcher currentModule) = + findCompletions filters matcher currentModule handleCommand (Pursuit query Package) = findPursuitPackages query handleCommand (Pursuit query Identifier) = @@ -94,14 +95,16 @@ handleCommand Reset = resetPscIdeState *> pure (TextResult "State has been reset handleCommand Quit = liftIO exitSuccess findCompletions :: (PscIde m, MonadLogger m) => - [Filter] -> Matcher -> m Success -findCompletions filters matcher = - CompletionResult . mapMaybe completionFromMatch . getCompletions filters matcher <$> getAllModulesWithReexports + [Filter] -> Matcher -> Maybe P.ModuleName -> m Success +findCompletions filters matcher currentModule = do + modules <- getAllModulesWithReexportsAndCache currentModule + pure . CompletionResult . mapMaybe completionFromMatch . getCompletions filters matcher $ modules findType :: (PscIde m, MonadLogger m) => - DeclIdent -> [Filter] -> m Success -findType search filters = - CompletionResult . mapMaybe completionFromMatch . getExactMatches search filters <$> getAllModulesWithReexports + DeclIdent -> [Filter] -> Maybe P.ModuleName -> m Success +findType search filters currentModule = do + modules <- getAllModulesWithReexportsAndCache currentModule + pure . CompletionResult . mapMaybe completionFromMatch . getExactMatches search filters $ modules findPursuitCompletions :: (MonadIO m, MonadLogger m) => PursuitQuery -> m Success @@ -113,14 +116,14 @@ findPursuitPackages :: (MonadIO m, MonadLogger m) => findPursuitPackages (PursuitQuery q) = PursuitResult <$> liftIO (findPackagesForModuleIdent q) -loadExtern ::(PscIde m, MonadLogger m, MonadError PscIdeError m) => +loadExtern :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => FilePath -> m () loadExtern fp = do m <- readExternFile fp insertModule m printModules :: (PscIde m) => m Success -printModules = printModules' <$> getPscIdeState +printModules = printModules' . pscIdeStateModules <$> getPscIdeState printModules' :: M.Map ModuleIdent [ExternDecl] -> Success printModules' = ModuleList . M.keys diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 4440563609..8f405a8edc 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -21,10 +21,8 @@ import Prelude.Compat import Control.Monad import Data.Aeson -import Data.Maybe import Data.Text (Text) -import Language.PureScript (ModuleName, - moduleNameFromString) +import qualified Language.PureScript as P import Language.PureScript.Ide.CaseSplit import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher @@ -36,12 +34,14 @@ data Command , loadDependencies :: [ModuleIdent] } | Type - { typeSearch :: DeclIdent - , typeFilters :: [Filter] + { typeSearch :: DeclIdent + , typeFilters :: [Filter] + , typeCurrentModule :: Maybe P.ModuleName } | Complete - { completeFilters :: [Filter] - , completeMatcher :: Matcher + { completeFilters :: [Filter] + , completeMatcher :: Matcher + , completeCurrentModule :: Maybe P.ModuleName } | Pursuit { pursuitQuery :: PursuitQuery @@ -67,7 +67,7 @@ data Command | Quit data ImportCommand - = AddImplicitImport ModuleName + = AddImplicitImport P.ModuleName | AddImportForIdentifier DeclIdent deriving (Show, Eq) @@ -75,12 +75,10 @@ instance FromJSON ImportCommand where parseJSON = withObject "ImportCommand" $ \o -> do (command :: String) <- o .: "importCommand" case command of - "addImplicitImport" -> do - mn <- o .: "module" - pure (AddImplicitImport (moduleNameFromString mn)) - "addImport" -> do - ident <- o .: "identifier" - pure (AddImportForIdentifier ident) + "addImplicitImport" -> + AddImplicitImport <$> (P.moduleNameFromString <$> o .: "module") + "addImport" -> + AddImportForIdentifier <$> o .: "identifier" _ -> mzero data ListType = LoadedModules | Imports FilePath | AvailableModules @@ -89,69 +87,69 @@ instance FromJSON ListType where parseJSON = withObject "ListType" $ \o -> do (listType' :: String) <- o .: "type" case listType' of - "import" -> do - fp <- o .: "file" - return (Imports fp) - "loadedModules" -> return LoadedModules - "availableModules" -> return AvailableModules + "import" -> Imports <$> o .: "file" + "loadedModules" -> pure LoadedModules + "availableModules" -> pure AvailableModules _ -> mzero instance FromJSON Command where parseJSON = withObject "command" $ \o -> do (command :: String) <- o .: "command" case command of - "list" -> do - listType' <- o .:? "params" - return $ List (fromMaybe LoadedModules listType') - "cwd" -> return Cwd - "quit" -> return Quit + "list" -> List <$> o .:? "params" .!= LoadedModules + "cwd" -> pure Cwd + "quit" -> pure Quit "reset" -> pure Reset - "load" -> - maybe (pure (Load [] [])) (\params -> do - mods <- params .:? "modules" - deps <- params .:? "dependencies" - pure $ Load (fromMaybe [] mods) (fromMaybe [] deps)) =<< o .:? "params" + "load" -> do + params' <- o .:? "params" + case params' of + Nothing -> pure (Load [] []) + Just params -> + Load + <$> params .:? "modules" .!= [] + <*> params .:? "dependencies" .!= [] "type" -> do params <- o .: "params" - search <- params .: "search" - filters <- params .: "filters" - return $ Type search filters + Type + <$> params .: "search" + <*> params .: "filters" + <*> (fmap P.moduleNameFromString <$> params .:? "currentModule") "complete" -> do params <- o .: "params" - filters <- params .:? "filters" - matcher <- params .:? "matcher" - return $ Complete (fromMaybe [] filters) (fromMaybe mempty matcher) + Complete + <$> params .:? "filters" .!= [] + <*> params .:? "matcher" .!= mempty + <*> (fmap P.moduleNameFromString <$> params .:? "currentModule") "pursuit" -> do params <- o .: "params" - query <- params .: "query" - queryType <- params .: "type" - return $ Pursuit query queryType + Pursuit + <$> params .: "query" + <*> params .: "type" "caseSplit" -> do params <- o .: "params" - line <- params .: "line" - begin <- params .: "begin" - end <- params .: "end" - annotations <- params .: "annotations" - type' <- params .: "type" - return $ CaseSplit line begin end (if annotations - then explicitAnnotations - else noAnnotations) type' + CaseSplit + <$> params .: "line" + <*> params .: "begin" + <*> params .: "end" + <*> (mkAnnotations <$> params .: "annotations") + <*> params .: "type" "addClause" -> do params <- o .: "params" - line <- params .: "line" - annotations <- params .: "annotations" - return $ AddClause line (if annotations - then explicitAnnotations - else noAnnotations) + AddClause + <$> params .: "line" + <*> (mkAnnotations <$> params .: "annotations") "import" -> do params <- o .: "params" - fp <- params .: "file" - out <- params .:? "outfile" - filters <- params .:? "filters" - importCommand <- params .: "importCommand" - pure $ Import fp out (fromMaybe [] filters) importCommand + Import + <$> params .: "file" + <*> params .:? "outfile" + <*> params .:? "filters" .!= [] + <*> params .: "importCommand" "rebuild" -> do params <- o .: "params" - filePath <- params .: "file" - return $ Rebuild filePath + Rebuild + <$> params .: "file" _ -> mzero + where + mkAnnotations True = explicitAnnotations + mkAnnotations False = noAnnotations diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index aca59084ac..e03cc9d4b8 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -1,43 +1,64 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} -module Language.PureScript.Ide.Rebuild where - -import Prelude.Compat - -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Types +module Language.PureScript.Ide.Rebuild + ( rebuildFile + ) where import Control.Monad.Error.Class import Control.Monad.IO.Class import "monad-logger" Control.Monad.Logger -import Control.Monad.Reader.Class +import Control.Monad.Reader import Control.Monad.Trans.Except import qualified Data.Map.Lazy as M import Data.Maybe (fromJust, mapMaybe) +import Data.Monoid ((<>)) import qualified Data.Set as S import qualified Language.PureScript as P import Language.PureScript.Errors.JSON -import System.IO.UTF8 (readUTF8File) +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.State +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util +import Prelude.Compat +import System.IO.UTF8 (readUTF8File) +-- | Given a filepath performs the following steps: +-- +-- * Reads and parses a PureScript module from the filepath. +-- +-- * Builds a dependency graph for the parsed module from the already loaded +-- ExternsFiles. +-- +-- * Attempts to find an FFI definition file for the module by looking +-- for a file with the same filepath except for a .js extension. +-- +-- * Passes all the created artifacts to @rebuildModule@. +-- +-- * If the rebuilding succeeds, returns a @RebuildSuccess@ with the generated +-- warnings, and if rebuilding fails, returns a @RebuildError@ with the +-- generated errors. rebuildFile :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => FilePath -> m Success rebuildFile path = do - input <- liftIO $ readUTF8File path + input <- liftIO (readUTF8File path) - m <- case map snd <$> P.parseModulesFromFiles id [(path, input)] of - Left parseError -> - throwError . RebuildError . toJSONErrors False P.Error $ parseError - Right [m] -> pure m - Right _ -> throwError . GeneralError $ "Please define exactly one module." + m <- case snd <$> P.parseModuleFromFile id (path, input) of + Left parseError -> throwError + . RebuildError + . toJSONErrors False P.Error + $ P.MultipleErrors [P.toPositionedError parseError] + Right m -> pure m -- Externs files must be sorted ahead of time, so that they get applied -- correctly to the 'Environment'. - externs <- sortExterns m . M.delete (P.getModuleName m) =<< getExternFiles + externs <- sortExterns m =<< getExternFiles outputDirectory <- confOutputPath . envConfiguration <$> ask @@ -46,26 +67,85 @@ rebuildFile path = do let filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways) foreigns <- P.inferForeignModules (M.singleton (P.getModuleName m) (Right path)) - -- Silence progress update messages during the build - let actions = (P.buildMakeActions outputDirectory filePathMap foreigns False) - { P.progress = const (pure ()) } - + let makeEnv = MakeActionsEnv outputDirectory filePathMap foreigns False -- Rebuild the single module using the cached externs (result, warnings) <- liftIO - . P.runMake P.defaultOptions - . P.rebuildModule actions externs - $ m + . P.runMake P.defaultOptions + . P.rebuildModule (buildMakeActions + >>= shushProgress $ makeEnv) externs $ m case result of - Left errors -> throwError . RebuildError $ toJSONErrors False P.Error errors - Right _ -> pure . RebuildSuccess $ toJSONErrors False P.Warning warnings + Left errors -> throwError (RebuildError (toJSONErrors False P.Error errors)) + Right _ -> do + rebuildModuleOpen makeEnv externs m + pure (RebuildSuccess (toJSONErrors False P.Warning warnings)) + +-- | Rebuilds a module but opens up its export list first and stores the result +-- inside the rebuild cache +rebuildModuleOpen + :: (PscIde m, MonadLogger m, MonadError PscIdeError m) + => MakeActionsEnv + -> [P.ExternsFile] + -> P.Module + -> m () +rebuildModuleOpen makeEnv externs m = do + (openResult, _) <- liftIO + . P.runMake P.defaultOptions + . P.rebuildModule (buildMakeActions + >>= shushProgress + >>= shushCodegen + $ makeEnv) externs $ openModuleExports m + case openResult of + Left _ -> + throwError (GeneralError "Failed when rebuilding with open exports") + Right result -> do + $(logDebug) + ("Setting Rebuild cache: " <> runModuleNameT (P.efModuleName result)) + setCachedRebuild result + +-- | Parameters we can access while building our @MakeActions@ +data MakeActionsEnv = + MakeActionsEnv + { maeOutputDirectory :: FilePath + , maeFilePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath) + , maeForeignPathMap :: M.Map P.ModuleName FilePath + , maePrefixComment :: Bool + } +-- | Builds the default @MakeActions@ from a @MakeActionsEnv@ +buildMakeActions :: MakeActionsEnv -> P.MakeActions P.Make +buildMakeActions MakeActionsEnv{..} = + P.buildMakeActions + maeOutputDirectory + maeFilePathMap + maeForeignPathMap + maePrefixComment + +-- | Shuts the compiler up about progress messages +shushProgress :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make +shushProgress ma _ = + ma { P.progress = \_ -> pure () } + +-- | Stops any kind of codegen (also silences errors about missing or unused FFI +-- files though) +shushCodegen :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make +shushCodegen ma MakeActionsEnv{..} = + ma { P.codegen = \_ _ _ -> pure () } + +-- | Returns a topologically sorted list of dependent ExternsFiles for the given +-- module. Throws an error if there is a cyclic dependency within the +-- ExternsFiles sortExterns :: (PscIde m, MonadError PscIdeError m) => P.Module -> M.Map P.ModuleName P.ExternsFile -> m [P.ExternsFile] sortExterns m ex = do - sorted' <- runExceptT . P.sortModules . (:) m . map mkShallowModule . M.elems $ ex + sorted' <- runExceptT + . P.sortModules + . (:) m + . map mkShallowModule + . M.elems + . M.delete (P.getModuleName m) $ ex case sorted' of Left _ -> throwError (GeneralError "There was a cycle in the dependencies") Right (sorted, graph) -> do @@ -80,3 +160,7 @@ sortExterns m ex = do -- Sort a list so its elements appear in the same order as in another list. inOrderOf :: (Ord a) => [a] -> [a] -> [a] inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys + +-- | Removes a modules export list. +openModuleExports :: P.Module -> P.Module +openModuleExports (P.Module ss cs mn decls _) = P.Module ss cs mn decls Nothing diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index ea63a8884c..325a4b1128 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -16,7 +16,19 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} -module Language.PureScript.Ide.State where +module Language.PureScript.Ide.State + ( getPscIdeState + , getExternFiles + , getModule + , getModuleWithReexports + , getAllModulesWithReexports + , getAllModulesWithReexportsAndCache + , insertModule + , insertModuleSTM + , getCachedRebuild + , resetPscIdeState + , setCachedRebuild + ) where import Prelude () import Prelude.Compat @@ -26,74 +38,106 @@ import Control.Monad.IO.Class import "monad-logger" Control.Monad.Logger import Control.Monad.Reader.Class import qualified Data.Map.Lazy as M -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import Data.Monoid -import qualified Data.Text as T import Language.PureScript.Externs import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.Types -import Language.PureScript.Names +import Language.PureScript.Ide.Util +import qualified Language.PureScript as P +-- | Resets the PscIdeState to emptyPscIdeState resetPscIdeState :: PscIde m => m () resetPscIdeState = do stateVar <- envStateVar <$> ask liftIO $ atomically (writeTVar stateVar emptyPscIdeState) -getPscIdeState :: (PscIde m) => - m (M.Map ModuleIdent [ExternDecl]) +-- | Gets the entire PscIdeState +getPscIdeState :: PscIde m => m PscIdeState getPscIdeState = do stateVar <- envStateVar <$> ask - liftIO $ pscStateModules <$> readTVarIO stateVar + liftIO (readTVarIO stateVar) -getExternFiles :: (PscIde m) => - m (M.Map ModuleName ExternsFile) +-- | Gets all loaded ExternFiles +getExternFiles :: (PscIde m) => m (M.Map P.ModuleName ExternsFile) getExternFiles = do stateVar <- envStateVar <$> ask - liftIO (externsFiles <$> readTVarIO stateVar) - -getExternFile :: (PscIde m) => - ModuleName -> m (Maybe ExternsFile) -getExternFile mn = M.lookup mn <$> getExternFiles - -getAllDecls :: (PscIde m) => m [ExternDecl] -getAllDecls = concat <$> getPscIdeState - -getAllModules :: (PscIde m) => m [Module] -getAllModules = M.toList <$> getPscIdeState - -getAllModulesWithReexports :: (PscIde m, MonadLogger m) => - m [Module] -getAllModulesWithReexports = do - mis <- M.keys <$> getPscIdeState - ms <- traverse getModuleWithReexports mis - pure (catMaybes ms) - -getModule :: (PscIde m, MonadLogger m) => - ModuleIdent -> m (Maybe Module) -getModule m = do - modules <- getPscIdeState - pure ((m,) <$> M.lookup m modules) - -getModuleWithReexports :: (PscIde m, MonadLogger m) => - ModuleIdent -> m (Maybe Module) -getModuleWithReexports mi = do - m <- getModule mi - modules <- getPscIdeState - pure $ resolveReexports modules <$> m - -insertModule ::(PscIde m, MonadLogger m) => + liftIO (pscIdeStateExternsFiles <$> readTVarIO stateVar) + +-- | Gets all loaded Modules and resolves Reexports +getAllModulesWithReexports :: (PscIde m) => m [Module] +getAllModulesWithReexports = getAllModulesWithReexports' <$> getPscIdeState + +-- | Pure version of @getAllModulesWithReexports@ +getAllModulesWithReexports' :: PscIdeState -> [Module] +getAllModulesWithReexports' state = + mapMaybe (getModuleWithReexports' state) (M.keys (pscIdeStateModules state)) + +-- | Checks if the given ModuleName matches the last rebuild cache and if it +-- does, runs @getAllModulesWithReexports@ with the cached module replacing the +-- loaded module +getAllModulesWithReexportsAndCache + :: (PscIde m) + => Maybe P.ModuleName + -> m [Module] +getAllModulesWithReexportsAndCache Nothing = getAllModulesWithReexports +getAllModulesWithReexportsAndCache (Just mn) = do + state <- getPscIdeState + cachedRebuild <- getCachedRebuild + case cachedRebuild of + Just (cachedIdent, ef) | cachedIdent == mn -> + pure (getAllModulesWithReexports' (insertModule' ef state)) + _ -> getAllModulesWithReexports + +-- | Looks up a single Module inside the loaded Modules +getModule :: (PscIde m, MonadLogger m) => ModuleIdent -> m (Maybe Module) +getModule m = getModule' <$> getPscIdeState <*> pure m + +-- | Pure version of @getModule@ +getModule' :: PscIdeState -> ModuleIdent -> Maybe Module +getModule' ps mi = (mi,) <$> M.lookup mi (pscIdeStateModules ps) + +-- | Looks up a single Module and resolves its Reexports +getModuleWithReexports :: PscIde m => ModuleIdent -> m (Maybe Module) +getModuleWithReexports i = getModuleWithReexports' <$> getPscIdeState <*> pure i + +-- | Pure version of @getModuleWithReexports@ +getModuleWithReexports' :: PscIdeState -> ModuleIdent -> Maybe Module +getModuleWithReexports' ps mi = + resolveReexports (pscIdeStateModules ps) <$> getModule' ps mi + +-- | Inserts an @ExternsFile@ into the PscIdeState. Also converts the +-- ExternsFile into psc-ide's internal Declaration format +insertModule :: (PscIde m, MonadLogger m) => ExternsFile -> m () insertModule externsFile = do - env <- ask + stateVar <- envStateVar <$> ask let moduleName = efModuleName externsFile - $(logDebug) $ "Inserting Module: " <> T.pack (runModuleName moduleName) - liftIO . atomically $ insertModule' (envStateVar env) externsFile - -insertModule' :: TVar PscIdeState -> ExternsFile -> STM () -insertModule' st ef = - modifyTVar st $ \x -> - x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x) - , pscStateModules = let (mn, decls) = convertExterns ef - in M.insert mn decls (pscStateModules x) - } + $(logDebug) $ "Inserting Module: " <> runModuleNameT moduleName + liftIO . atomically $ insertModuleSTM stateVar externsFile + +-- | STM version of insertModule +insertModuleSTM :: TVar PscIdeState -> ExternsFile -> STM () +insertModuleSTM st ef = modifyTVar st (insertModule' ef) + +-- | Pure version of insertModule +insertModule' :: ExternsFile -> PscIdeState -> PscIdeState +insertModule' ef state = + state + { pscIdeStateExternsFiles = + M.insert (efModuleName ef) ef (pscIdeStateExternsFiles state) + , pscIdeStateModules = let (mn, decls) = convertExterns ef + in M.insert mn decls (pscIdeStateModules state) + } + +-- | Sets rebuild cache to the given ExternsFile +setCachedRebuild :: PscIde m => ExternsFile -> m () +setCachedRebuild ef = do + st <- envStateVar <$> ask + liftIO . atomically . modifyTVar st $ \x -> + x { pscIdeStateCachedRebuild = Just (efModuleName ef, ef) } + +-- | Retrieves the rebuild cache +getCachedRebuild :: PscIde m => m (Maybe (P.ModuleName, ExternsFile)) +getCachedRebuild = pscIdeStateCachedRebuild <$> getPscIdeState diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index e5fc7d93b1..f1182ef39a 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -83,12 +83,13 @@ type PscIde m = (MonadIO m, MonadReader PscIdeEnvironment m) data PscIdeState = PscIdeState - { pscStateModules :: M.Map Text [ExternDecl] - , externsFiles :: M.Map P.ModuleName ExternsFile + { pscIdeStateModules :: M.Map Text [ExternDecl] + , pscIdeStateExternsFiles :: M.Map P.ModuleName ExternsFile + , pscIdeStateCachedRebuild :: Maybe (P.ModuleName, ExternsFile) } deriving Show emptyPscIdeState :: PscIdeState -emptyPscIdeState = PscIdeState M.empty M.empty +emptyPscIdeState = PscIdeState M.empty M.empty Nothing data Match = Match ModuleIdent ExternDecl deriving (Show, Eq) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 454b64b65d..6e87d1c940 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -34,6 +34,9 @@ runIdentT = T.pack . P.runIdent runOpNameT :: P.OpName a -> Text runOpNameT = T.pack . P.runOpName +runModuleNameT :: P.ModuleName -> Text +runModuleNameT = T.pack . P.runModuleName + prettyTypeT :: P.Type -> Text prettyTypeT = T.unwords . fmap T.strip . T.lines . T.pack . P.prettyPrintType diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs index 5865d3fb6b..4ebe68e78d 100644 --- a/src/Language/PureScript/Ide/Watcher.hs +++ b/src/Language/PureScript/Ide/Watcher.hs @@ -35,14 +35,15 @@ reloadFile stateVar ev = do case ef' of Left _ -> pure () Right ef -> do - atomically (insertModule' stateVar ef) + atomically (insertModuleSTM stateVar ef) putStrLn ("Reloaded File at: " ++ fp) -- | Installs filewatchers for the given directory and reloads ExternsFiles when -- they change on disc watcher :: TVar PscIdeState -> FilePath -> IO () -watcher stateVar fp = withManagerConf (defaultConfig { confDebounce = NoDebounce }) $ \mgr -> do - _ <- watchTree mgr fp - (\ev -> takeFileName (eventPath ev) == "externs.json") - (reloadFile stateVar) - forever (threadDelay 100000) +watcher stateVar fp = + withManagerConf (defaultConfig { confDebounce = NoDebounce }) $ \mgr -> do + _ <- watchTree mgr fp + (\ev -> takeFileName (eventPath ev) == "externs.json") + (reloadFile stateVar) + forever (threadDelay 100000) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 4a074c5dea..55f930e8e2 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -5,12 +5,14 @@ module Language.PureScript.Parser.Declarations ( parseDeclaration , parseModule , parseModulesFromFiles + , parseModuleFromFile , parseValue , parseGuard , parseBinder , parseBinderNoParens , parseImportDeclaration' , parseLocalDeclaration + , toPositionedError ) where import Prelude hiding (lex) @@ -270,11 +272,7 @@ parseModulesFromFiles -> [(k, String)] -> m [(k, Module)] parseModulesFromFiles toFilePath input = - flip parU wrapError . inParallel . flip map input $ \(k, content) -> do - let filename = toFilePath k - ts <- lex filename content - m <- runTokenParser filename parseModule ts - return (k, m) + flip parU wrapError . inParallel . flip map input $ parseModuleFromFile toFilePath where wrapError :: Either P.ParseError a -> m a wrapError = either (throwError . MultipleErrors . pure . toPositionedError) return @@ -285,6 +283,18 @@ parseModulesFromFiles toFilePath input = inParallel = withStrategy (parList rseq) +-- | Parses a single module with FilePath for eventual parsing errors +parseModuleFromFile + :: (k -> FilePath) + -> (k, String) + -> Either P.ParseError (k, Module) +parseModuleFromFile toFilePath (k, content) = do + let filename = toFilePath k + ts <- lex filename content + m <- runTokenParser filename parseModule ts + pure (k, m) + +-- | Converts a @ParseError@ into a @PositionedError@ toPositionedError :: P.ParseError -> ErrorMessage toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr) where @@ -562,3 +572,4 @@ parseBinderNoParens = P.choice -- parseGuard :: TokenParser Guard parseGuard = pipe *> C.indented *> parseValue + diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs index ed3f640964..876eb21387 100644 --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -33,6 +33,7 @@ module Language.PureScript.Ide.Integration , loadModuleWithDeps , getCwd , getFlexCompletions + , getFlexCompletionsInModule , getType , rebuildModule , reset @@ -49,7 +50,7 @@ import Data.Aeson import Data.Aeson.Types import qualified Data.ByteString.Lazy.UTF8 as BSL import Data.Either (isRight) -import Data.Maybe (fromJust, isNothing) +import Data.Maybe (fromJust, isNothing, fromMaybe) import qualified Data.Text as T import qualified Data.Vector as V import Language.PureScript.Ide.Util @@ -95,11 +96,12 @@ compileTestProject :: IO Bool compileTestProject = do pdir <- projectDirectory (_, _, _, procHandle) <- createProcess $ - (shell $ "psc " ++ fileGlob) {cwd=Just pdir - ,std_out=CreatePipe - ,std_err=CreatePipe + (shell $ "psc " ++ fileGlob) { cwd = Just pdir + , std_out = CreatePipe + , std_err = CreatePipe } - isSuccess <$> waitForProcess procHandle + r <- tryNTimes 5 (getProcessExitCode procHandle) + pure (fromMaybe False (isSuccess <$> r)) tryNTimes :: Int -> IO (Maybe a) -> IO (Maybe a) tryNTimes 0 _ = pure Nothing @@ -166,7 +168,10 @@ loadModule :: String -> IO String loadModule m = sendCommand $ load [m] [] getFlexCompletions :: String -> IO [(String, String, String)] -getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q))) +getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) Nothing) + +getFlexCompletionsInModule :: String -> String -> IO [(String, String, String)] +getFlexCompletionsInModule q m = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) (Just m)) getType :: String -> IO [(String, String, String)] getType q = parseCompletions <$> sendCommand (typeC q []) @@ -217,14 +222,17 @@ addImportW importCommand fp outfp = ]) -completion :: [Value] -> Maybe Value -> Value -completion filters matcher = +completion :: [Value] -> Maybe Value -> Maybe String -> Value +completion filters matcher currentModule = let matcher' = case matcher of Nothing -> [] Just m -> ["matcher" .= m] + currentModule' = case currentModule of + Nothing -> [] + Just cm -> ["currentModule" .= cm] in - commandWrapper "complete" (object $ "filters" .= filters : matcher') + commandWrapper "complete" (object $ "filters" .= filters : matcher' ++ currentModule' ) flexMatcher :: String -> Value flexMatcher q = object [ "matcher" .= ("flex" :: String) diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index 02cfa760bf..f78cd1bda9 100644 --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -11,7 +11,7 @@ shouldBeFailure :: String -> IO () shouldBeFailure = shouldBe False . Integration.resultIsSuccess spec :: Spec -spec = before_ Integration.reset $ describe "Rebuilding single modules" $ do +spec = before_ Integration.reset . describe "Rebuilding single modules" $ do it "rebuilds a correct module without dependencies successfully" $ do _ <- Integration.loadModuleWithDeps "RebuildSpecSingleModule" pdir <- Integration.projectDirectory @@ -45,3 +45,9 @@ spec = before_ Integration.reset $ describe "Rebuilding single modules" $ do pdir <- Integration.projectDirectory let file = pdir "src" "RebuildSpecWithMissingForeign.fail" Integration.rebuildModule file >>= shouldBeFailure + it "completes a hidden identifier after rebuilding" $ do + pdir <- Integration.projectDirectory + let file = pdir "src" "RebuildSpecWithHiddenIdent.purs" + Integration.rebuildModule file >>= shouldBeSuccess + res <- Integration.getFlexCompletionsInModule "hid" "RebuildSpecWithHiddenIdent" + shouldBe False (null res) diff --git a/tests/Language/PureScript/IdeSpec.hs b/tests/Language/PureScript/IdeSpec.hs index 83533f16d5..8ceedb1ea2 100644 --- a/tests/Language/PureScript/IdeSpec.hs +++ b/tests/Language/PureScript/IdeSpec.hs @@ -11,7 +11,7 @@ import Language.PureScript.Ide.Types import Test.Hspec testState :: PscIdeState -testState = PscIdeState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])]) Map.empty +testState = PscIdeState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])]) Map.empty Nothing defaultConfig :: Configuration defaultConfig = diff --git a/tests/support/pscide/src/RebuildSpecWithHiddenIdent.purs b/tests/support/pscide/src/RebuildSpecWithHiddenIdent.purs new file mode 100644 index 0000000000..005bd15632 --- /dev/null +++ b/tests/support/pscide/src/RebuildSpecWithHiddenIdent.purs @@ -0,0 +1,6 @@ +module RebuildSpecWithHiddenIdent (exported) where + +hidden x _ = x + +exported :: forall a. a -> a +exported x = x From 957270644dca12c1090963348cd8c4fb940aa0a8 Mon Sep 17 00:00:00 2001 From: Ben James Date: Sun, 22 May 2016 22:15:28 +0000 Subject: [PATCH 0431/1580] Fix issue 2128 (#2144) * No backtracking out of class/instance body once 'where' is parsed * Remove unnecessary try * Update CONTRIBUTORS --- CONTRIBUTORS.md | 1 + examples/failing/2128-class.purs | 5 +++++ examples/failing/2128-instance.purs | 8 ++++++++ src/Language/PureScript/Parser/Declarations.hs | 4 ++-- 4 files changed, 16 insertions(+), 2 deletions(-) create mode 100644 examples/failing/2128-class.purs create mode 100644 examples/failing/2128-instance.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index a2bcea0af5..057000d092 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -71,6 +71,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@bmjames](https://github.com/bmjames) (Ben James) My existing contributions and all future contributions until further notice are Copyright Ben James, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/examples/failing/2128-class.purs b/examples/failing/2128-class.purs new file mode 100644 index 0000000000..a46135b381 --- /dev/null +++ b/examples/failing/2128-class.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +class Foo a where + foo :: a -> !!! diff --git a/examples/failing/2128-instance.purs b/examples/failing/2128-instance.purs new file mode 100644 index 0000000000..9ec9758b5d --- /dev/null +++ b/examples/failing/2128-instance.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +class Foo a where + foo :: a + +instance fooInt :: Foo Int where + foo = !!! diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index d2d4febb5f..f8e91f312c 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -182,7 +182,7 @@ parseTypeClassDeclaration = do return implies className <- indented *> properName idents <- P.many (indented *> kindedIdent) - members <- P.option [] . P.try $ do + members <- P.option [] $ do indented *> reserved "where" indented *> mark (P.many (same *> positioned parseTypeDeclaration)) return $ TypeClassDeclaration className idents implies members @@ -206,7 +206,7 @@ parseInstanceDeclaration = do parseTypeInstanceDeclaration :: TokenParser Declaration parseTypeInstanceDeclaration = do instanceDecl <- parseInstanceDeclaration - members <- P.option [] . P.try $ do + members <- P.option [] $ do indented *> reserved "where" mark (P.many (same *> positioned parseValueDeclaration)) return $ instanceDecl (ExplicitInstance members) From 3ca5543b8452f8575de4ef2f43d22e4d88389d8a Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 22 May 2016 15:34:00 -0700 Subject: [PATCH 0432/1580] Require imports to appear before other declarations --- src/Language/PureScript/Parser/Declarations.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 55f930e8e2..adde201bc8 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -234,7 +234,6 @@ parseDeclaration = positioned (P.choice , parseValueDeclaration , parseExternDeclaration , parseFixityDeclaration - , parseImportDeclaration , parseTypeClassDeclaration , parseTypeInstanceDeclaration , parseDerivingInstanceDeclaration @@ -258,7 +257,13 @@ parseModule = do name <- moduleName exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef reserved "where" - decls <- mark (P.many (same *> parseDeclaration)) + decls <- mark $ do + -- TODO: extract a module header structure here, and provide a + -- parseModuleHeader function. This should allow us to speed up rebuilds + -- by only parsing as far as the module header. See PR #2054. + imports <- P.many (same *> parseImportDeclaration) + decls <- P.many (same *> parseDeclaration) + return (imports ++ decls) _ <- P.eof end <- P.getPosition let ss = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos end) @@ -572,4 +577,3 @@ parseBinderNoParens = P.choice -- parseGuard :: TokenParser Guard parseGuard = pipe *> C.indented *> parseValue - From e7ddf82d4ef3f99f1933d77a33fc76f09d5d67af Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 22 May 2016 15:52:28 -0700 Subject: [PATCH 0433/1580] Fix #2149, remove support for = in ObjectBinder (#2152) * Fix #2149, remove support for = in ObjectBinder * Extended matches must specify a binder --- examples/passing/LiberalTypeSynonyms.purs | 2 +- examples/passing/NamedPatterns.purs | 2 +- examples/passing/ObjectUpdate.purs | 4 ++-- examples/passing/Objects.purs | 2 +- examples/passing/Patterns.purs | 6 +++--- examples/passing/Rank2Object.purs | 2 +- examples/passing/ReservedWords.purs | 2 +- src/Language/PureScript/Parser/Declarations.hs | 11 +++++------ 8 files changed, 15 insertions(+), 16 deletions(-) diff --git a/examples/passing/LiberalTypeSynonyms.purs b/examples/passing/LiberalTypeSynonyms.purs index d32213c6ee..b388af69e1 100644 --- a/examples/passing/LiberalTypeSynonyms.purs +++ b/examples/passing/LiberalTypeSynonyms.purs @@ -17,6 +17,6 @@ type F r = { | r } -> { | r } f :: (forall r. F r) -> String f g = case g { x: "Hello" } of - { x = x } -> x + { x: x } -> x main = log "Done" diff --git a/examples/passing/NamedPatterns.purs b/examples/passing/NamedPatterns.purs index 819b354e5a..d6f43778a1 100644 --- a/examples/passing/NamedPatterns.purs +++ b/examples/passing/NamedPatterns.purs @@ -4,7 +4,7 @@ import Prelude import Control.Monad.Eff.Console (log) foo = \x -> case x of - y@{ foo = "Foo" } -> y + y@{ foo: "Foo" } -> y y -> y main = log "Done" diff --git a/examples/passing/ObjectUpdate.purs b/examples/passing/ObjectUpdate.purs index d9e1f82210..f17f6589ff 100644 --- a/examples/passing/ObjectUpdate.purs +++ b/examples/passing/ObjectUpdate.purs @@ -9,8 +9,8 @@ update2 :: forall r. { foo :: String | r } -> { foo :: String | r } update2 = \o -> o { foo = "Foo" } replace = \o -> case o of - { foo = "Foo" } -> o { foo = "Bar" } - { foo = "Bar" } -> o { bar = "Baz" } + { foo: "Foo" } -> o { foo = "Bar" } + { foo: "Bar" } -> o { bar = "Baz" } o -> o polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r } diff --git a/examples/passing/Objects.purs b/examples/passing/Objects.purs index fe5ce5eda2..f320372aef 100644 --- a/examples/passing/Objects.purs +++ b/examples/passing/Objects.purs @@ -26,7 +26,7 @@ test4 = test2 weirdObj weirdObj = { "!@#": 1.0 } test5 = case { "***": 1.0 } of - { "***" = n } -> n + { "***": n } -> n test6 = case { "***": 1.0 } of { "***": n } -> n diff --git a/examples/passing/Patterns.purs b/examples/passing/Patterns.purs index 637396a7aa..b715ec9ccf 100644 --- a/examples/passing/Patterns.purs +++ b/examples/passing/Patterns.purs @@ -4,12 +4,12 @@ import Prelude import Control.Monad.Eff.Console (log) test = \x -> case x of - { str = "Foo", bool = true } -> true - { str = "Bar", bool = b } -> b + { str: "Foo", bool: true } -> true + { str: "Bar", bool: b } -> b _ -> false f = \o -> case o of - { foo = "Foo" } -> o.bar + { foo: "Foo" } -> o.bar _ -> 0 h = \o -> case o of diff --git a/examples/passing/Rank2Object.purs b/examples/passing/Rank2Object.purs index c9651e695f..2460b4fb79 100644 --- a/examples/passing/Rank2Object.purs +++ b/examples/passing/Rank2Object.purs @@ -6,6 +6,6 @@ import Control.Monad.Eff.Console data Foo = Foo { id :: forall a. a -> a } foo :: Foo -> Number -foo (Foo { id = f }) = f 0.0 +foo (Foo { id: f }) = f 0.0 main = log "Done" diff --git a/examples/passing/ReservedWords.purs b/examples/passing/ReservedWords.purs index b347b69770..e96a643a99 100644 --- a/examples/passing/ReservedWords.purs +++ b/examples/passing/ReservedWords.purs @@ -12,7 +12,7 @@ p :: { type :: String } p = o { type = "p" } f :: forall r. { type :: String | r } -> String -f { type = "p" } = "Done" +f { type: "p" } = "Done" f _ = "Fail" main :: Eff _ _ diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 55f930e8e2..626f377623 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -504,12 +504,12 @@ parseNullBinder = underscore *> return NullBinder parseIdentifierAndBinder :: TokenParser (String, Binder) parseIdentifierAndBinder = - do name <- lname - b <- P.option (VarBinder (Ident name)) rest - return (name, b) - <|> (,) <$> stringLiteral <*> rest + do name <- lname + b <- P.option (VarBinder (Ident name)) rest + return (name, b) + <|> (,) <$> stringLiteral <*> rest where - rest = C.indented *> (equals <|> colon) *> C.indented *> parseBinder + rest = C.indented *> colon *> C.indented *> parseBinder -- | -- Parse a binder @@ -572,4 +572,3 @@ parseBinderNoParens = P.choice -- parseGuard :: TokenParser Guard parseGuard = pipe *> C.indented *> parseValue - From c50718b4d67807c017d266c0d10dfc7361174f6b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 22 May 2016 19:23:51 -0700 Subject: [PATCH 0434/1580] Fix PSCi imports --- src/Language/PureScript/Interactive/Module.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index d874e43c7b..9cbbf33e1e 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -44,14 +44,15 @@ loadAllModules files = do createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val = let - moduleName = P.ModuleName [P.ProperName "$PSCI"] - trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval")) - mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))) - itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val - mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue - decls = if exec then [itDecl, mainDecl] else [itDecl] + moduleName = P.ModuleName [P.ProperName "$PSCI"] + supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"])) + eval = P.Var (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval")) + mainValue = P.App eval (P.Var (P.Qualified Nothing (P.Ident "it"))) + itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val + mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue + decls = if exec then [itDecl, mainDecl] else [itDecl] in - P.Module (P.internalModuleSourceSpan "") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing + P.Module (P.internalModuleSourceSpan "") [] moduleName ((importDecl `map` (supportImport : imports)) ++ lets ++ decls) Nothing -- | From b42f9cfda650d8964c5084c0c773cef3bd11fe70 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 24 May 2016 00:17:56 +0100 Subject: [PATCH 0435/1580] Combine multiple export refs for types --- examples/passing/2138.purs | 7 +++++++ examples/passing/2138/Lib.purs | 3 +++ purescript.cabal | 1 + src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/Sugar/Names/Env.hs | 9 +++++---- src/Language/PureScript/Sugar/Names/Exports.hs | 17 +++++++++++++++-- 6 files changed, 32 insertions(+), 7 deletions(-) create mode 100644 examples/passing/2138.purs create mode 100644 examples/passing/2138/Lib.purs diff --git a/examples/passing/2138.purs b/examples/passing/2138.purs new file mode 100644 index 0000000000..1c05373757 --- /dev/null +++ b/examples/passing/2138.purs @@ -0,0 +1,7 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +import Lib (A(B,C)) + +main = log "Done" diff --git a/examples/passing/2138/Lib.purs b/examples/passing/2138/Lib.purs new file mode 100644 index 0000000000..3c433e0b1e --- /dev/null +++ b/examples/passing/2138/Lib.purs @@ -0,0 +1,3 @@ +module Lib (A(..), A) where + +data A = B | C diff --git a/purescript.cabal b/purescript.cabal index 234a3c2d44..d9db8a4392 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -21,6 +21,7 @@ tested-with: GHC==7.10.3 extra-source-files: examples/passing/*.purs , examples/passing/2018/*.purs + , examples/passing/2138/*.purs , examples/passing/ClassRefSyntax/*.purs , examples/passing/DctorOperatorAlias/*.purs , examples/passing/ExplicitImportReExport/*.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 05a63dc9d7..a438694729 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -577,7 +577,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ runModuleName mn , line "It either does not exist or the module does not export it." ] - renderSimpleErrorMessage (UnknownImportDataConstructor mn dcon tcon) = + renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) = line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon renderSimpleErrorMessage (UnknownExport name) = line $ "Cannot export unknown " ++ printName (Qualified Nothing name) diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index a1426b6769..4b6ce1592a 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -219,9 +219,8 @@ exportType exportType exps name dctors mn = do let exTypes = exportedTypes exps let exClasses = exportedTypeClasses exps - case name `M.lookup` exTypes of - Just (_, mn') | mn /= mn' -> throwConflictError ConflictingTypeDecls name - _ -> return () + forM_ (name `M.lookup` exTypes) $ \(_, mn') -> + when (mn /= mn') $ throwConflictError ConflictingTypeDecls name when (coerceProperName name `M.member` exClasses) $ throwConflictError TypeConflictsWithClass name forM_ dctors $ \dctor -> do @@ -229,9 +228,11 @@ exportType exps name dctors mn = do throwConflictError ConflictingCtorDecls dctor when (coerceProperName dctor `M.member` exClasses) $ throwConflictError CtorConflictsWithClass dctor - return $ exps { exportedTypes = M.insert name (dctors, mn) exTypes } + return $ exps { exportedTypes = M.alter updateOrInsert name exTypes } where dctorExists dctor (dctors', mn') = mn /= mn' && elem dctor dctors' + updateOrInsert Nothing = Just (dctors, mn) + updateOrInsert (Just (dctors', _)) = Just (dctors ++ dctors', mn) -- | -- Safely adds a type operator to some exports, returning an error if a diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 98e9e7d689..5026de3c7f 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -9,8 +9,9 @@ import Control.Monad import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Error.Class (MonadError(..)) +import Data.Function (on) import Data.Foldable (traverse_) -import Data.List (intersect) +import Data.List (intersect, groupBy, sortBy) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M @@ -224,7 +225,7 @@ filterModule -> [DeclarationRef] -> m Exports filterModule mn exps refs = do - types <- foldM filterTypes M.empty refs + types <- foldM filterTypes M.empty (combineTypeRefs refs) typeOps <- foldM (filterExport TyOpName getTypeOpRef exportedTypeOps) M.empty refs classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) M.empty refs values <- foldM (filterExport IdentName getValueRef exportedValues) M.empty refs @@ -239,6 +240,18 @@ filterModule mn exps refs = do where + -- Takes the list of exported refs, filters out any non-TypeRefs, then + -- combines any duplicate type exports to ensure that all constructors + -- listed for the type are covered. Without this, only the data constructor + -- listing for the last ref would be used. + combineTypeRefs :: [DeclarationRef] -> [DeclarationRef] + combineTypeRefs + = fmap (uncurry TypeRef) + . map (foldr1 $ \(tc, dcs1) (_, dcs2) -> (tc, liftM2 (++) dcs1 dcs2)) + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + . mapMaybe getTypeRef + filterTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) -> DeclarationRef From f148735be182c5e503877776ce95309b7550fe86 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 24 May 2016 22:31:12 +0200 Subject: [PATCH 0436/1580] Return a completion for operators (#2160) * Return a completion for operators Because we can't get at the type/kind for now we just print the referenced function/type constructor * show fixity for operators as their type --- src/Language/PureScript/Ide/Externs.hs | 12 +++++-- src/Language/PureScript/Ide/Imports.hs | 4 +-- src/Language/PureScript/Ide/Types.hs | 3 +- src/Language/PureScript/Ide/Util.hs | 33 +++++++++++++------- tests/Language/PureScript/Ide/ImportsSpec.hs | 4 +-- 5 files changed, 37 insertions(+), 19 deletions(-) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 0c0edc0c61..bf3e6bd509 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -103,11 +103,19 @@ convertDecl P.EDInstance{} = Nothing convertOperator :: P.ExternsFixity -> ExternDecl convertOperator P.ExternsFixity{..} = - FixityDeclaration (Left efOperator) + ValueOperator + efOperator + (T.pack (P.showQualified (either P.runIdent P.runProperName) efAlias)) + efPrecedence + efAssociativity convertTypeOperator :: P.ExternsTypeFixity -> ExternDecl convertTypeOperator P.ExternsTypeFixity{..} = - FixityDeclaration (Right efTypeOperator) + TypeOperator + efTypeOperator + (T.pack (P.showQualified P.runProperName efTypeAlias)) + efTypePrecedence + efTypeAssociativity unwrapPositioned :: P.Declaration -> P.Declaration unwrapPositioned (P.PositionedDeclaration _ _ x) = x diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 2efb8e5d07..7d24af731b 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -215,9 +215,9 @@ addExplicitImport' decl moduleName imports = P.TypeRef tn (Just [P.ProperName (T.unpack n)]) refFromDeclaration (TypeDeclaration n _) = P.TypeRef n (Just []) - refFromDeclaration (FixityDeclaration (Left op)) = + refFromDeclaration (ValueOperator op _ _ _) = P.ValueOpRef op - refFromDeclaration (FixityDeclaration (Right op)) = + refFromDeclaration (TypeOperator op _ _ _) = P.TypeOpRef op refFromDeclaration d = P.ValueRef $ P.Ident $ T.unpack (identifierFromExternDecl d) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index f1182ef39a..49fb2de706 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -61,7 +61,8 @@ data ExternDecl P.Type -- The "type" -- | An exported module | TypeClassDeclaration (P.ProperName 'P.ClassName) - | FixityDeclaration (Either (P.OpName 'P.ValueOpName) (P.OpName 'P.TypeOpName)) + | ValueOperator (P.OpName 'P.ValueOpName) Ident P.Precedence P.Associativity + | TypeOperator (P.OpName 'P.TypeOpName) Ident P.Precedence P.Associativity | Export ModuleIdent -- The exported Modules name deriving (Show,Eq,Ord) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 6e87d1c940..839bfc2154 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -47,8 +47,8 @@ identifierFromExternDecl (TypeSynonymDeclaration name _) = runProperNameT name identifierFromExternDecl (DataConstructor name _ _) = name identifierFromExternDecl (TypeClassDeclaration name) = runProperNameT name identifierFromExternDecl (ModuleDecl name _) = name -identifierFromExternDecl (FixityDeclaration (Left op)) = runOpNameT op -identifierFromExternDecl (FixityDeclaration (Right op)) = runOpNameT op +identifierFromExternDecl (ValueOperator op _ _ _) = runOpNameT op +identifierFromExternDecl (TypeOperator op _ _ _) = runOpNameT op identifierFromExternDecl Dependency{} = "~Dependency~" identifierFromExternDecl Export{} = "~Export~" @@ -56,16 +56,25 @@ identifierFromMatch :: Match -> Text identifierFromMatch (Match _ ed) = identifierFromExternDecl ed completionFromMatch :: Match -> Maybe Completion -completionFromMatch (Match _ Dependency{}) = Nothing -completionFromMatch (Match _ Export{}) = Nothing -completionFromMatch (Match m d) = Just $ case d of - ValueDeclaration name type' -> Completion (m, name, prettyTypeT type') - TypeDeclaration name kind -> Completion (m, runProperNameT name, T.pack $ P.prettyPrintKind kind) - TypeSynonymDeclaration name kind -> Completion (m, runProperNameT name, prettyTypeT kind) - DataConstructor name _ type' -> Completion (m, name, prettyTypeT type') - TypeClassDeclaration name -> Completion (m, runProperNameT name, "class") - ModuleDecl name _ -> Completion ("module", name, "module") - _ -> error "the impossible happened in completionFromMatch" +completionFromMatch (Match m d) = case d of + ValueDeclaration name type' -> Just $ Completion (m, name, prettyTypeT type') + TypeDeclaration name kind -> Just $ Completion (m, runProperNameT name, T.pack $ P.prettyPrintKind kind) + TypeSynonymDeclaration name kind -> Just $ Completion (m, runProperNameT name, prettyTypeT kind) + DataConstructor name _ type' -> Just $ Completion (m, name, prettyTypeT type') + TypeClassDeclaration name -> Just $ Completion (m, runProperNameT name, "class") + ModuleDecl name _ -> Just $ Completion ("module", name, "module") + ValueOperator op ref precedence associativity -> Just $ Completion (m, runOpNameT op, showFixity precedence associativity ref op) + TypeOperator op ref precedence associativity -> Just $ Completion (m, runOpNameT op, showFixity precedence associativity ref op) + Dependency{} -> Nothing + Export{} -> Nothing + where + showFixity p a r o = + let asso = case a of + P.Infix -> "infix" + P.Infixl -> "infixl" + P.Infixr -> "infixr" + in T.unwords [asso, T.pack (show p), r, "as", runOpNameT o] + encodeT :: (ToJSON a) => a -> Text encodeT = toStrict . decodeUtf8 . encode diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 48033fa38c..e78fcb9859 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -70,7 +70,7 @@ spec = do addValueImport i mn is = prettyPrintImportSection (addExplicitImport' (ValueDeclaration i wildcard) mn is) addOpImport op mn is = - prettyPrintImportSection (addExplicitImport' (FixityDeclaration op) mn is) + prettyPrintImportSection (addExplicitImport' (ValueOperator op "" 2 P.Infix) mn is) addDtorImport i t mn is = prettyPrintImportSection (addExplicitImport' (DataConstructor i t wildcard) mn is) it "adds an implicit unqualified import" $ @@ -98,7 +98,7 @@ spec = do ] it "adds an operator to an explicit import list" $ shouldBe - (addOpImport (Left (P.OpName "<~>")) (P.moduleNameFromString "Data.Array") explicitImports) + (addOpImport (P.OpName "<~>") (P.moduleNameFromString "Data.Array") explicitImports) [ "import Prelude" , "import Data.Array ((<~>), tail)" ] From 83be9a528b0276743833407666b4abcc3a15274d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 25 May 2016 10:55:37 -0700 Subject: [PATCH 0437/1580] Fix core-tests (#2162) * Fix core-tests * test psc-docs --- core-tests/.gitignore | 1 + core-tests/bower.json | 60 +++++++++++++++++++++ core-tests/test-everything.sh | 60 +++------------------ core-tests/tests/GenericDeriving.purs | 30 +++++++++++ core-tests/tests/Main.purs | 9 ++++ core-tests/tests/generic-deriving/Main.purs | 27 ---------- 6 files changed, 107 insertions(+), 80 deletions(-) create mode 100644 core-tests/bower.json create mode 100755 core-tests/tests/GenericDeriving.purs create mode 100644 core-tests/tests/Main.purs delete mode 100755 core-tests/tests/generic-deriving/Main.purs diff --git a/core-tests/.gitignore b/core-tests/.gitignore index d7d596db5a..ec714d16e2 100644 --- a/core-tests/.gitignore +++ b/core-tests/.gitignore @@ -1,2 +1,3 @@ +core-docs.md bower_components/ output/ diff --git a/core-tests/bower.json b/core-tests/bower.json new file mode 100644 index 0000000000..253aaedcf2 --- /dev/null +++ b/core-tests/bower.json @@ -0,0 +1,60 @@ +{ + "name": "core-tests", + "homepage": "https://github.com/purescript/purescript", + "authors": [ + "Phil Freeman " + ], + "ignore": [ + "**/.*", + "node_modules", + "bower_components", + "test", + "tests" + ], + "dependencies": { + "purescript-arrays": "#8c9ada5762", + "purescript-bifunctors": "#9e3b2864ce", + "purescript-console": "#db29da9aca", + "purescript-const": "#cf538a65d8", + "purescript-contravariant": "#9ae6d7c99c", + "purescript-control": "#97096c7e26", + "purescript-distributive": "#ba81c64ffd", + "purescript-eff": "#dbd6c4a415", + "purescript-either": "#54f4efd423", + "purescript-enums": "#9332412e52", + "purescript-exceptions": "#522a0cea50", + "purescript-exists": "#e828c8341e", + "purescript-foldable-traversable": "#df37787855", + "purescript-foreign": "#64890cbbdb", + "purescript-free": "#f8ab7c5f05", + "purescript-functions": "#e417541936", + "purescript-functor-coproducts": "#7654d9dea4", + "purescript-generics": "#d09cb16ca3", + "purescript-globals": "#113ee398be", + "purescript-graphs": "#0b7089afa2", + "purescript-identity": "#204ac5f46a", + "purescript-inject": "#3ae4880bad", + "purescript-integers": "#58d7605dd5", + "purescript-lazy": "#bf4b34d673", + "purescript-maps": "#d9e4c6599a", + "purescript-math": "#99797b6494", + "purescript-maybe": "#1b60a07038", + "purescript-monoid": "#a8c8bb9d73", + "purescript-parallel": "#c7296ab008", + "purescript-prelude": "#318ee857bd", + "purescript-profunctor": "#a649126cea", + "purescript-proxy": "#c494b11bd7", + "purescript-quickcheck": "#4a15c93f12", + "purescript-random": "#68314c21e2", + "purescript-refs": "#f47e1059a3", + "purescript-semirings": "#c40efda15f", + "purescript-sets": "#1eaabf177f", + "purescript-st": "#077d9a2d7e", + "purescript-strings": "#87dd5f1694", + "purescript-tailrec": "#3c11db00ba", + "purescript-transformers": "#2d0a471ce4", + "purescript-tuples": "#4fe689ef93", + "purescript-unfoldable": "#e2382f30d8", + "purescript-validation": "#f43ff0fbdd" + } +} diff --git a/core-tests/test-everything.sh b/core-tests/test-everything.sh index 6aa0ebf1ea..4d0602448b 100755 --- a/core-tests/test-everything.sh +++ b/core-tests/test-everything.sh @@ -1,4 +1,4 @@ -#!/bin/bash +#!/usr/bin/env bash set -e @@ -18,62 +18,16 @@ if [ "$force_reinstall" = "true" ] && [ -d "bower_components" ]; then rm -r bower_components fi -bower i \ - purescript-prelude \ - purescript-eff \ - purescript-st \ - purescript-integers \ - purescript-functions \ - purescript-console \ - purescript-profunctor \ - purescript-contravariant \ - purescript-parallel \ - purescript-control \ - purescript-tailrec \ - purescript-maps \ - purescript-free \ - purescript-transformers \ - purescript-exists \ - purescript-monoid \ - purescript-either \ - purescript-maybe \ - purescript-inject \ - purescript-graphs \ - purescript-enums \ - purescript-unfoldable \ - purescript-coproducts \ - purescript-lazy \ - purescript-distributive \ - purescript-identity \ - purescript-bifunctors \ - purescript-const \ - purescript-sets \ - purescript-quickcheck \ - purescript-foreign \ - purescript-foldable-traversable \ - purescript-tuples \ - purescript-strings \ - purescript-arrays \ - purescript-random \ - purescript-refs \ - purescript-globals \ - purescript-exceptions \ - purescript-validation \ - purescript-parallel \ - purescript-proxy \ - purescript-semirings \ - purescript-math \ - purescript-generics +# todo : fix this once core libraries reach 1.0 +yes 1 | bower i if [ "$force_recompile" = "true" ] && [ -d "output" ]; then echo "Recompiling..." rm -r output fi -../dist/build/psc/psc tests/*/*.purs \ - 'bower_components/purescript-*/src/**/*.purs' \ - --ffi 'bower_components/purescript-*/src/**/*.js' +stack exec psc 'tests/**/*.purs' 'bower_components/purescript-*/src/**/*.purs' -../dist/build/psc-docs/psc-docs tests/*/*.purs \ - 'bower_components/purescript-*/src/**/*.purs' \ - > full-core-docs.md +stack exec psc-docs 'bower_components/purescript-*/src/**/*.purs' > core-docs.md + +NODE_PATH=output node -e "require('Test.Main').main()" diff --git a/core-tests/tests/GenericDeriving.purs b/core-tests/tests/GenericDeriving.purs new file mode 100755 index 0000000000..f8e229c70a --- /dev/null +++ b/core-tests/tests/GenericDeriving.purs @@ -0,0 +1,30 @@ +module Test.GenericDeriving where + +import Prelude + +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log, logShow) +import Data.Generic (class Generic, gShow, gEq) +import Partial.Unsafe (unsafePartial) + +data Empty + +derive instance genericEmpty :: Partial => Generic Empty + +data A a + = A Number String + | B Int + | C (Array (A a)) + | D { "asgård" :: a } + | E Empty + +derive instance genericA :: (Partial, Generic b) => Generic (A b) + +newtype X b = X b + +derive instance genericX :: Generic (X String) + +main :: forall eff. Eff (console :: CONSOLE | eff) Unit +main = unsafePartial do + log $ gShow (D { "asgård": C [ A 1.0 "test", B 42, D { "asgård": true } ] }) + logShow $ gEq (C [B 0]) (C [B 0] :: A Empty) diff --git a/core-tests/tests/Main.purs b/core-tests/tests/Main.purs new file mode 100644 index 0000000000..8cd7b682cc --- /dev/null +++ b/core-tests/tests/Main.purs @@ -0,0 +1,9 @@ +module Test.Main where + +import Prelude +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE) +import Test.GenericDeriving as GenericDeriving + +main :: forall eff. Eff (console :: CONSOLE | eff) Unit +main = GenericDeriving.main diff --git a/core-tests/tests/generic-deriving/Main.purs b/core-tests/tests/generic-deriving/Main.purs deleted file mode 100755 index c98cea4f24..0000000000 --- a/core-tests/tests/generic-deriving/Main.purs +++ /dev/null @@ -1,27 +0,0 @@ -module GenericDeriving where - -import Prelude - -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log) -import Data.Generic - -data Void - -derive instance genericVoid :: Generic Void - -data A a - = A Number String - | B Int - | C (Array (A a)) - | D { "asgård" :: a } - | E Void - -derive instance genericA :: (Generic b) => Generic (A b) - -newtype X b = X b - -derive instance genericX :: Generic (X String) - -main :: forall eff. Eff (console :: CONSOLE | eff) Unit -main = log (gShow (D { "asgård": C [ A 1.0 "test", B 42, D { "asgård": true } ] })) From 0619bd562eeebc0d9a04e50b3960bd194bbb932a Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 28 May 2016 00:18:06 +0100 Subject: [PATCH 0438/1580] Allow use of prime symbol in type names. --- examples/passing/PrimedTypeName.purs | 20 ++++++++++++++ src/Language/PureScript/Parser/Common.hs | 9 +++++++ .../PureScript/Parser/Declarations.hs | 10 +++---- src/Language/PureScript/Parser/Lexer.hs | 27 ++++++++++--------- src/Language/PureScript/Parser/Types.hs | 2 +- 5 files changed, 49 insertions(+), 19 deletions(-) create mode 100644 examples/passing/PrimedTypeName.purs diff --git a/examples/passing/PrimedTypeName.purs b/examples/passing/PrimedTypeName.purs new file mode 100644 index 0000000000..5241c168eb --- /dev/null +++ b/examples/passing/PrimedTypeName.purs @@ -0,0 +1,20 @@ +module Main (T, T', T'', T''', main) where + +import Prelude +import Control.Monad.Eff.Console (log) + +data T a = T +type T' = T Unit + +data T'' = TP + +foreign import data T''' ∷ * + +instance eqT ∷ Eq T'' where + eq _ _ = true + +type A' a b = b → a + +infixr 4 type A' as ↫ + +main = log "Done" diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index 039f710ef8..c98ce2e7bd 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -16,9 +16,18 @@ import Language.PureScript.Parser.State import qualified Text.Parsec as P +-- | +-- Parse a general proper name. +-- properName :: TokenParser (ProperName a) properName = ProperName <$> uname +-- | +-- Parse a proper name for a type. +-- +typeName :: TokenParser (ProperName 'TypeName) +typeName = ProperName <$> tyname + -- | -- Parse a module name -- diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 6762bde3aa..9c1ae7796a 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -66,7 +66,7 @@ kindedIdent = (, Nothing) <$> identifier parseDataDeclaration :: TokenParser Declaration parseDataDeclaration = do dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype) - name <- indented *> properName + name <- indented *> typeName tyArgs <- many (indented *> kindedIdent) ctors <- P.option [] $ do indented *> equals @@ -80,7 +80,7 @@ parseTypeDeclaration = parseTypeSynonymDeclaration :: TokenParser Declaration parseTypeSynonymDeclaration = - TypeSynonymDeclaration <$> (reserved "type" *> indented *> properName) + TypeSynonymDeclaration <$> (reserved "type" *> indented *> typeName) <*> many (indented *> kindedIdent) <*> (indented *> equals *> noWildcards parsePolyType) @@ -108,7 +108,7 @@ parseValueDeclaration = do parseExternDeclaration :: TokenParser Declaration parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *> - (ExternDataDeclaration <$> (reserved "data" *> indented *> properName) + (ExternDataDeclaration <$> (reserved "data" *> indented *> typeName) <*> (indented *> doubleColon *> parseKind) <|> (do ident <- parseIdent ty <- indented *> doubleColon *> noWildcards parsePolyType @@ -132,7 +132,7 @@ parseFixityDeclaration = do where typeFixity fixity = TypeFixity fixity - <$> (reserved "type" *> parseQualified properName) + <$> (reserved "type" *> parseQualified typeName) <*> (reserved "as" *> parseOperator) valueFixity fixity = ValueFixity fixity @@ -169,7 +169,7 @@ parseDeclarationRef = <|> (TypeOpRef <$> (indented *> reserved "type" *> parens parseOperator)) where parseTypeRef = do - name <- properName + name <- typeName dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName) return $ TypeRef name (fromMaybe (Just []) dctors) diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 5a15ca2af0..c7b157c20e 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -41,8 +41,8 @@ module Language.PureScript.Parser.Lexer , commaSep1 , lname , qualifier + , tyname , uname - , uname' , mname , reserved , symbol @@ -213,8 +213,9 @@ parseToken = P.choice , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore , HoleLit <$> P.try (P.char '?' *> P.many1 identLetter) , LName <$> parseLName - , do uName <- parseUName - (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName) + , parseUName >>= \uName -> + (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') + <|> pure (UName uName) , Symbol <$> parseSymbol , CharLiteral <$> parseCharLiteral , StringLiteral <$> parseStringLiteral @@ -226,7 +227,7 @@ parseToken = P.choice parseLName = (:) <$> identStart <*> P.many identLetter parseUName :: P.Parsec String u String - parseUName = (:) <$> P.upper <*> P.many uidentLetter + parseUName = (:) <$> P.upper <*> P.many identLetter parseSymbol :: P.Parsec String u String parseSymbol = P.many1 symbolChar @@ -237,9 +238,6 @@ parseToken = P.choice identLetter :: P.Parsec String u Char identLetter = P.alphaNum <|> P.oneOf "_'" - uidentLetter :: P.Parsec String u Char - uidentLetter = P.alphaNum <|> P.char '_' - symbolChar :: P.Parsec String u Char symbolChar = P.satisfy isSymbolChar @@ -430,6 +428,12 @@ reserved s = token go P. show s uname :: TokenParser String uname = token go P. "proper name" + where + go (UName s) | validUName s = Just s + go _ = Nothing + +tyname :: TokenParser String +tyname = token go P. "type name" where go (UName s) = Just s go _ = Nothing @@ -440,12 +444,6 @@ mname = token go P. "module name" go (UName s) | validModuleName s = Just s go _ = Nothing -uname' :: String -> TokenParser () -uname' s = token go P. show s - where - go (UName s') | s == s' = Just () - go _ = Nothing - symbol :: TokenParser String symbol = token go P. "symbol" where @@ -496,6 +494,9 @@ identifier = token go P. "identifier" validModuleName :: String -> Bool validModuleName s = '_' `notElem` s +validUName :: String -> Bool +validUName s = '\'' `notElem` s + -- | -- A list of purescript reserved identifiers -- diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index ff66a6d663..5f4758802d 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -40,7 +40,7 @@ parseTypeVariable = do return $ TypeVar ident parseTypeConstructor :: TokenParser Type -parseTypeConstructor = TypeConstructor <$> parseQualified properName +parseTypeConstructor = TypeConstructor <$> parseQualified typeName parseForAll :: TokenParser Type parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (indented *> identifier) <* indented <* dot) From 2ca82f87d232a33fd179c2ec081b7d9fcb7ae504 Mon Sep 17 00:00:00 2001 From: suppi Date: Sat, 28 May 2016 23:12:09 +0300 Subject: [PATCH 0439/1580] marking code in error messages with backticks (#2079) * marking code in error messages with backticks * adding 'endWith' box combinator and using it to mark code on boxes * removing backticks from multiple lines * marking code with color * refactoring prettyPrintSingleError to get an Options record. namely - PPEOptions * Checking for terminal --- hierarchy/Main.hs | 2 +- psc-docs/Main.hs | 2 +- psc/Main.hs | 8 +- psci/Main.hs | 2 +- purescript.cabal | 2 + src/Language/PureScript/Errors.hs | 402 ++++++++++-------- src/Language/PureScript/Errors/JSON.hs | 2 +- src/Language/PureScript/Interactive.hs | 2 +- src/Language/PureScript/Interactive/Module.hs | 2 +- src/Language/PureScript/Pretty/Common.hs | 4 + .../PureScript/Publish/ErrorsWarnings.hs | 2 +- tests/TestCompiler.hs | 8 +- 12 files changed, 254 insertions(+), 184 deletions(-) diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs index 2ab5919b47..a6d7b07c57 100644 --- a/hierarchy/Main.hs +++ b/hierarchy/Main.hs @@ -65,7 +65,7 @@ compile (HierarchyOptions inputGlob mOutput) = do input <- glob inputGlob modules <- readInput input case modules of - Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors False errs) >> exitFailure + Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure Right ms -> do for_ ms $ \(P.Module _ _ moduleName decls _) -> let name = runModuleName moduleName diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index d7528e30be..63d0f31180 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -95,7 +95,7 @@ docgen (PSCDocsOptions fmt inputGlob output) = do Right x -> return x Left err -> do - hPutStrLn stderr $ P.prettyPrintMultipleErrors False err + hPutStrLn stderr $ P.prettyPrintMultipleErrors P.defaultPPEOptions err exitFailure takeByName = takeModulesByName D.modName diff --git a/psc/Main.hs b/psc/Main.hs index 13051d4cb1..e99c13e141 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -11,6 +11,7 @@ import Control.Monad import Control.Monad.Writer.Strict import qualified Data.Aeson as A +import Data.Bool (bool) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.UTF8 as BU8 import qualified Data.Map as M @@ -24,6 +25,7 @@ import Options.Applicative as Opts import qualified Paths_purescript as Paths +import qualified System.Console.ANSI as ANSI import System.Exit (exitSuccess, exitFailure) import System.FilePath.Glob (glob) import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8) @@ -40,11 +42,13 @@ data PSCMakeOptions = PSCMakeOptions -- | Argumnets: verbose, use JSON, warnings, errors printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO () printWarningsAndErrors verbose False warnings errors = do + cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stderr + let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose } when (P.nonEmpty warnings) $ - hPutStrLn stderr (P.prettyPrintMultipleWarnings verbose warnings) + hPutStrLn stderr (P.prettyPrintMultipleWarnings ppeOpts warnings) case errors of Left errs -> do - hPutStrLn stderr (P.prettyPrintMultipleErrors verbose errs) + hPutStrLn stderr (P.prettyPrintMultipleErrors ppeOpts errs) exitFailure Right _ -> return () printWarningsAndErrors verbose True warnings errors = do diff --git a/psci/Main.hs b/psci/Main.hs index 26c9ccfd6a..e41723e682 100644 --- a/psci/Main.hs +++ b/psci/Main.hs @@ -107,7 +107,7 @@ main = getOpt >>= loop (externs, env) <- ExceptT . runMake . make $ modules return (modules, externs, env) case e of - Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure + Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure Right (modules, externs, env) -> do historyFilename <- getHistoryFilename let settings = defaultSettings { historyFile = Just historyFilename } diff --git a/purescript.cabal b/purescript.cabal index d9db8a4392..da0fd68477 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -94,6 +94,7 @@ library build-depends: base >=4.8 && <5, aeson >= 0.8 && < 0.12, aeson-better-errors >= 0.8, + ansi-terminal >= 0.6.2 && < 0.7, base-compat >=0.6.0, bower-json >= 0.8, boxes >= 0.1.4 && < 0.2.0, @@ -303,6 +304,7 @@ executable psc build-depends: base >=4 && <5, purescript -any, aeson >= 0.8 && < 0.12, + ansi-terminal >= 0.6.2 && < 0.7, base-compat >=0.6.0, bytestring -any, containers -any, diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index a438694729..9dc0dd19e6 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -26,9 +26,12 @@ import Language.PureScript.Names import Language.PureScript.Pretty import Language.PureScript.Traversals import Language.PureScript.Types +import Language.PureScript.Pretty.Common (endWith) import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.Constants as C +import qualified System.Console.ANSI as ANSI + import qualified Text.Parsec as P import qualified Text.Parsec.Error as PE import qualified Text.PrettyPrint.Boxes as Box @@ -457,15 +460,65 @@ showSuggestion suggestion = case errorSuggestion suggestion of Just (ErrorSuggestion x) -> x _ -> "" +ansiColor :: (ANSI.ColorIntensity, ANSI.Color) -> String +ansiColor (intesity, color) = + ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground intesity color] + +ansiColorReset :: String +ansiColorReset = + ANSI.setSGRCode [ANSI.Reset] + +colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> String -> String +colorCode codeColor code = case codeColor of + Nothing -> code + Just cc -> concat [ansiColor cc, code, ansiColorReset] + +colorCodeBox :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Box.Box -> Box.Box +colorCodeBox codeColor b = case codeColor of + Nothing -> b + Just cc + | Box.rows b == 1 -> + Box.text (ansiColor cc) Box.<> b `endWith` Box.text ansiColorReset + + | otherwise -> Box.hcat Box.left -- making two boxes, one for each side of the box so that it will set each row it's own color and will reset it afterwards + [ Box.vcat Box.top $ replicate (Box.rows b) $ Box.text $ ansiColor cc + , b + , Box.vcat Box.top $ replicate (Box.rows b) $ Box.text ansiColorReset + ] + + +-- | Default color intesity and color for code +defaultCodeColor :: (ANSI.ColorIntensity, ANSI.Color) +defaultCodeColor = (ANSI.Dull, ANSI.Yellow) + +-- | `prettyPrintSingleError` Options +data PPEOptions = PPEOptions + { ppeCodeColor :: Maybe (ANSI.ColorIntensity, ANSI.Color) -- ^ Color code with this color... or not + , ppeFull :: Bool -- ^ Should write a full error message? + , ppeLevel :: Level -- ^ Should this report an error or a warning? + , ppeShowWiki :: Bool -- ^ Should show a link to error message's wiki page? + } + +-- | Default options for PPEOptions +defaultPPEOptions :: PPEOptions +defaultPPEOptions = PPEOptions + { ppeCodeColor = Just defaultCodeColor + , ppeFull = False + , ppeLevel = Error + , ppeShowWiki = True + } + + -- | -- Pretty print a single error, simplifying if necessary -- -prettyPrintSingleError :: Bool -> Level -> Bool -> ErrorMessage -> Box.Box -prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap $ do +prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box +prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalState defaultUnknownMap $ do em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) um <- get return (prettyPrintErrorMessage um em) where + (markCode, markCodeBox) = (colorCode &&& colorCodeBox) codeColor -- Pretty print an ErrorMessage prettyPrintErrorMessage :: TypeMap -> ErrorMessage -> Box.Box @@ -474,9 +527,10 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap [ foldr renderHint (indent (renderSimpleErrorMessage simple)) hints ] ++ maybe [] (return . Box.moveDown 1) typeInformation ++ - [ Box.moveDown 1 $ paras [ line $ "See " ++ wikiUri e ++ " for more information, " - , line $ "or to contribute content related to this " ++ levelText ++ "." - ] + [ Box.moveDown 1 $ paras + [ line $ "See " ++ wikiUri e ++ " for more information, " + , line $ "or to contribute content related to this " ++ levelText ++ "." + ] | showWiki ] where @@ -491,11 +545,11 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box skolemInfo (name, s, ss) = paras $ - line (name ++ show s ++ " is a rigid type variable") + line (markCode (name ++ show s) ++ " is a rigid type variable") : foldMap (return . line . (" bound at " ++) . displayStartEndPos) ss unknownInfo :: Int -> Box.Box - unknownInfo u = line $ "t" ++ show u ++ " is an unknown type" + unknownInfo u = line $ markCode ("t" ++ show u) ++ " is an unknown type" renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box renderSimpleErrorMessage (CannotGetFileInfo path) = @@ -520,29 +574,29 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , prettyPrintParseError err ] renderSimpleErrorMessage (MissingFFIModule mn) = - line $ "The foreign module implementation for module " ++ runModuleName mn ++ " is missing." + line $ "The foreign module implementation for module " ++ markCode (runModuleName mn) ++ " is missing." renderSimpleErrorMessage (UnnecessaryFFIModule mn path) = - paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ runModuleName mn ++ ": " + paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ markCode (runModuleName mn) ++ ": " , indent . line $ path - , line $ "Module " ++ runModuleName mn ++ " does not contain any foreign import declarations, so a foreign module is not necessary." + , line $ "Module " ++ markCode (runModuleName mn) ++ " does not contain any foreign import declarations, so a foreign module is not necessary." ] renderSimpleErrorMessage (MissingFFIImplementations mn idents) = - paras [ line $ "The following values are not defined in the foreign module for module " ++ runModuleName mn ++ ": " + paras [ line $ "The following values are not defined in the foreign module for module " ++ markCode (runModuleName mn) ++ ": " , indent . paras $ map (line . runIdent) idents ] renderSimpleErrorMessage (UnusedFFIImplementations mn idents) = - paras [ line $ "The following definitions in the foreign module for module " ++ runModuleName mn ++ " are unused: " + paras [ line $ "The following definitions in the foreign module for module " ++ markCode (runModuleName mn) ++ " are unused: " , indent . paras $ map (line . runIdent) idents ] renderSimpleErrorMessage (InvalidFFIIdentifier mn ident) = - paras [ line $ "In the FFI module for " ++ runModuleName mn ++ ":" + paras [ line $ "In the FFI module for " ++ markCode (runModuleName mn) ++ ":" , indent . paras $ - [ line $ "The identifier `" ++ ident ++ "` is not valid in PureScript." + [ line $ "The identifier " ++ markCode ident ++ " is not valid in PureScript." , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers." ] ] renderSimpleErrorMessage (MultipleFFIModules mn paths) = - paras [ line $ "Multiple foreign module implementations have been provided for module " ++ runModuleName mn ++ ": " + paras [ line $ "Multiple foreign module implementations have been provided for module " ++ markCode (runModuleName mn) ++ ": " , indent . paras $ map line paths ] renderSimpleErrorMessage InvalidDoBind = @@ -553,94 +607,94 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap line "The same name was used more than once in a let binding." renderSimpleErrorMessage (InfiniteType ty) = paras [ line "An infinite type was inferred for an expression: " - , indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox ty ] renderSimpleErrorMessage (InfiniteKind ki) = paras [ line "An infinite kind was inferred for a type: " - , indent $ line $ prettyPrintKind ki + , indent $ line $ markCode $ prettyPrintKind ki ] renderSimpleErrorMessage (MultipleValueOpFixities op) = - line $ "There are multiple fixity/precedence declarations for operator " ++ showOp op + line $ "There are multiple fixity/precedence declarations for operator " ++ markCode (showOp op) renderSimpleErrorMessage (MultipleTypeOpFixities op) = - line $ "There are multiple fixity/precedence declarations for type operator " ++ showOp op + line $ "There are multiple fixity/precedence declarations for type operator " ++ markCode (showOp op) renderSimpleErrorMessage (OrphanTypeDeclaration nm) = - line $ "The type declaration for " ++ showIdent nm ++ " should be followed by its definition." + line $ "The type declaration for " ++ markCode (showIdent nm) ++ " should be followed by its definition." renderSimpleErrorMessage (RedefinedModule name filenames) = - paras [ line ("The module " ++ runModuleName name ++ " has been defined multiple times:") + paras [ line ("The module " ++ markCode (runModuleName name) ++ " has been defined multiple times:") , indent . paras $ map (line . displaySourceSpan) filenames ] renderSimpleErrorMessage (RedefinedIdent name) = - line $ "The value " ++ showIdent name ++ " has been defined multiple times" + line $ "The value " ++ markCode (showIdent name) ++ " has been defined multiple times" renderSimpleErrorMessage (UnknownName name) = line $ "Unknown " ++ printName name renderSimpleErrorMessage (UnknownImport mn name) = - paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ runModuleName mn + paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ markCode (runModuleName mn) , line "It either does not exist or the module does not export it." ] renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) = - line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon + line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ markCode (runProperName dcon) ++ " for type " ++ markCode (runProperName tcon) renderSimpleErrorMessage (UnknownExport name) = line $ "Cannot export unknown " ++ printName (Qualified Nothing name) renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) = - line $ "Cannot export data constructor " ++ runProperName dcon ++ " for type " ++ runProperName tcon ++ ", as it has not been declared." + line $ "Cannot export data constructor " ++ markCode (runProperName dcon) ++ " for type " ++ markCode (runProperName tcon) ++ ", as it has not been declared." renderSimpleErrorMessage (ScopeConflict nm ms) = paras [ line $ "Conflicting definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following modules:" - , indent $ paras $ map (line . runModuleName) ms + , indent $ paras $ map (line . markCode . runModuleName) ms ] renderSimpleErrorMessage (ScopeShadowing nm exmn ms) = paras [ line $ "Shadowed definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following open imports:" - , indent $ paras $ map (line . ("import " ++) . runModuleName) ms + , indent $ paras $ map (line . markCode . ("import " ++) . runModuleName) ms , line $ "These will be ignored and the " ++ case exmn of - Just exmn' -> "declaration from " ++ runModuleName exmn' ++ " will be used." + Just exmn' -> "declaration from " ++ markCode (runModuleName exmn') ++ " will be used." Nothing -> "local declaration will be used." ] renderSimpleErrorMessage (ConflictingTypeDecls nm) = - line $ "Conflicting type declarations for " ++ runProperName nm + line $ "Conflicting type declarations for " ++ markCode (runProperName nm) renderSimpleErrorMessage (ConflictingCtorDecls nm) = - line $ "Conflicting data constructor declarations for " ++ runProperName nm + line $ "Conflicting data constructor declarations for " ++ markCode (runProperName nm) renderSimpleErrorMessage (TypeConflictsWithClass nm) = - line $ "Type " ++ runProperName nm ++ " conflicts with a type class declaration with the same name." + line $ "Type " ++ markCode (runProperName nm) ++ " conflicts with a type class declaration with the same name." renderSimpleErrorMessage (CtorConflictsWithClass nm) = - line $ "Data constructor " ++ runProperName nm ++ " conflicts with a type class declaration with the same name." + line $ "Data constructor " ++ markCode (runProperName nm) ++ " conflicts with a type class declaration with the same name." renderSimpleErrorMessage (ClassConflictsWithType nm) = - line $ "Type class " ++ runProperName nm ++ " conflicts with a type declaration with the same name." + line $ "Type class " ++ markCode (runProperName nm) ++ " conflicts with a type declaration with the same name." renderSimpleErrorMessage (ClassConflictsWithCtor nm) = - line $ "Type class " ++ runProperName nm ++ " conflicts with a data constructor declaration with the same name." + line $ "Type class " ++ markCode (runProperName nm) ++ " conflicts with a data constructor declaration with the same name." renderSimpleErrorMessage (DuplicateModuleName mn) = - line $ "Module " ++ runModuleName mn ++ " has been defined multiple times." + line $ "Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times." renderSimpleErrorMessage (DuplicateClassExport nm) = - line $ "Duplicate export declaration for type class " ++ runProperName nm + line $ "Duplicate export declaration for type class " ++ markCode (runProperName nm) renderSimpleErrorMessage (DuplicateValueExport nm) = - line $ "Duplicate export declaration for value " ++ showIdent nm + line $ "Duplicate export declaration for value " ++ markCode (showIdent nm) renderSimpleErrorMessage (DuplicateValueOpExport op) = - line $ "Duplicate export declaration for operator " ++ showOp op + line $ "Duplicate export declaration for operator " ++ markCode (showOp op) renderSimpleErrorMessage (DuplicateTypeOpExport op) = - line $ "Duplicate export declaration for type operator " ++ showOp op + line $ "Duplicate export declaration for type operator " ++ markCode (showOp op) renderSimpleErrorMessage (CycleInDeclaration nm) = - line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed." + line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = paras [ line "There is a cycle in module dependencies in these modules: " - , indent $ paras (map (line . runModuleName) mns) + , indent $ paras (map (line . markCode . runModuleName) mns) ] renderSimpleErrorMessage (CycleInTypeSynonym name) = paras [ line $ case name of - Just pn -> "A cycle appears in the definition of type synonym " ++ runProperName pn + Just pn -> "A cycle appears in the definition of type synonym " ++ markCode (runProperName pn) Nothing -> "A cycle appears in a set of type synonym definitions." , line "Cycles are disallowed because they can lead to loops in the type checker." , line "Consider using a 'newtype' instead." ] renderSimpleErrorMessage (NameIsUndefined ident) = - line $ "Value " ++ showIdent ident ++ " is undefined." + line $ "Value " ++ markCode (showIdent ident) ++ " is undefined." renderSimpleErrorMessage (UndefinedTypeVariable name) = - line $ "Type variable " ++ runProperName name ++ " is undefined." + line $ "Type variable " ++ markCode (runProperName name) ++ " is undefined." renderSimpleErrorMessage (PartiallyAppliedSynonym name) = - paras [ line $ "Type synonym " ++ showQualified runProperName name ++ " is partially applied." + paras [ line $ "Type synonym " ++ markCode (showQualified runProperName name) ++ " is partially applied." , line "Type synonyms must be applied to all of their type arguments." ] renderSimpleErrorMessage (EscapedSkolem binding) = paras $ [ line "A type variable has escaped its scope." ] <> foldMap (\expr -> [ line "Relevant expression: " - , indent $ prettyPrintValue valueDepth expr + , markCodeBox $ indent $ prettyPrintValue valueDepth expr ]) binding renderSimpleErrorMessage (TypesDoNotUnify u1 u2) = let (sorted1, sorted2) = sortRows u1 u2 @@ -662,28 +716,29 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , rowFromList (sortBy (comparing fst) sd2 ++ map (fst &&& snd . snd) common, r2) ) in paras [ line "Could not match type" - , indent $ typeAsBox sorted1 + , markCodeBox $ indent $ typeAsBox sorted1 , line "with type" - , indent $ typeAsBox sorted2 + , markCodeBox $ indent $ typeAsBox sorted2 ] renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = paras [ line "Could not match kind" - , indent $ line $ prettyPrintKind k1 + , indent $ line $ markCode $ prettyPrintKind k1 , line "with kind" - , indent $ line $ prettyPrintKind k2 + , indent $ line $ markCode $ prettyPrintKind k2 ] renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) = paras [ line "Could not match constrained type" - , indent $ typeAsBox t1 + , markCodeBox $ indent $ typeAsBox t1 , line "with type" - , indent $ typeAsBox t2 + , markCodeBox $ indent $ typeAsBox t2 ] renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) = paras [ line "Overlapping type class instances found for" - , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) - ] + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] , line "The following instances were found:" , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds) , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended." @@ -697,15 +752,16 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , line "The following additional cases are required to cover all inputs:\n" , indent $ paras $ Box.hsep 1 Box.left - (map (paras . map line) (transpose bs)) + (map (paras . map (line . markCode)) (transpose bs)) : [line "..." | not b] , line "Alternatively, add a Partial constraint to the type of the enclosing value." ] renderSimpleErrorMessage (NoInstanceFound (Constraint nm ts _)) = paras [ line "No type class instance was found for" - , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) - ] + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation." | any containsUnknowns ts ] @@ -718,125 +774,128 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap go _ = False renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) = paras [ line "Type class instance for" - , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) - ] + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] , line "is possibly infinite." ] renderSimpleErrorMessage (CannotDerive nm ts) = paras [ line "Cannot derive a type class instance for" - , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) - ] + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] ] renderSimpleErrorMessage (CannotFindDerivingType nm) = - line $ "Cannot derive a type class instance, because the type declaration for " ++ runProperName nm ++ " could not be found." + line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found." renderSimpleErrorMessage (DuplicateLabel l expr) = - paras $ [ line $ "Label " ++ show l ++ " appears more than once in a row type." ] + paras $ [ line $ "Label " ++ markCode l ++ " appears more than once in a row type." ] <> foldMap (\expr' -> [ line "Relevant expression: " - , indent $ prettyPrintValue valueDepth expr' + , markCodeBox $ indent $ prettyPrintValue valueDepth expr' ]) expr renderSimpleErrorMessage (DuplicateTypeArgument name) = - line $ "Type argument " ++ show name ++ " appears more than once." + line $ "Type argument " ++ markCode name ++ " appears more than once." renderSimpleErrorMessage (DuplicateValueDeclaration nm) = - line $ "Multiple value declarations exist for " ++ showIdent nm ++ "." + line $ "Multiple value declarations exist for " ++ markCode (showIdent nm) ++ "." renderSimpleErrorMessage (ArgListLengthsDiffer ident) = - line $ "Argument list lengths differ in declaration " ++ showIdent ident + line $ "Argument list lengths differ in declaration " ++ markCode (showIdent ident) renderSimpleErrorMessage (OverlappingArgNames ident) = line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration " ++) . showIdent) ident renderSimpleErrorMessage (MissingClassMember ident) = - line $ "Type class member " ++ showIdent ident ++ " has not been implemented." + line $ "Type class member " ++ markCode (showIdent ident) ++ " has not been implemented." renderSimpleErrorMessage (ExtraneousClassMember ident className) = - line $ showIdent ident ++ " is not a member of type class " ++ showQualified runProperName className + line $ "" ++ markCode (showIdent ident) ++ " is not a member of type class " ++ markCode (showQualified runProperName className) renderSimpleErrorMessage (ExpectedType ty kind) = - paras [ line "In a type-annotated expression x :: t, the type t must have kind *." + paras [ line $ "In a type-annotated expression " ++ markCode "x :: t" ++ ", the type " ++ markCode "t" ++ " must have kind " ++ markCode "*" ++ "." , line "The error arises from the type" - , indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox ty , line "having the kind" - , indent $ line $ prettyPrintKind kind + , indent $ line $ markCode $ prettyPrintKind kind , line "instead." ] renderSimpleErrorMessage (IncorrectConstructorArity nm) = - line $ "Data constructor " ++ showQualified runProperName nm ++ " was given the wrong number of arguments in a case expression." + line $ "Data constructor " ++ markCode (showQualified runProperName nm) ++ " was given the wrong number of arguments in a case expression." renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) = paras [ line "Expression" - , indent $ prettyPrintValue valueDepth expr + , markCodeBox $ indent $ prettyPrintValue valueDepth expr , line "does not have type" - , indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox ty ] renderSimpleErrorMessage (PropertyIsMissing prop) = - line $ "Type of expression lacks required label " ++ show prop ++ "." + line $ "Type of expression lacks required label " ++ markCode prop ++ "." renderSimpleErrorMessage (AdditionalProperty prop) = - line $ "Type of expression contains additional label " ++ show prop ++ "." + line $ "Type of expression contains additional label " ++ markCode prop ++ "." renderSimpleErrorMessage (CannotApplyFunction fn arg) = paras [ line "A function of type" - , indent $ typeAsBox fn + , markCodeBox $ indent $ typeAsBox fn , line "can not be applied to the argument" - , indent $ prettyPrintValue valueDepth arg + , markCodeBox $ indent $ prettyPrintValue valueDepth arg ] renderSimpleErrorMessage TypeSynonymInstance = line "Type class instances for type synonyms are disallowed." renderSimpleErrorMessage (OrphanInstance nm cnm ts) = - paras [ line $ "Type class instance " ++ showIdent nm ++ " for " - , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm) - , Box.vcat Box.left (map typeAtomAsBox ts) - ] + paras [ line $ "Type class instance " ++ markCode (showIdent nm) ++ " for " + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName cnm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] , line "is an orphan instance." , line "An orphan instance is an instance which is defined in neither the class module nor the data type module." , line "Consider moving the instance, if possible, or using a newtype wrapper." ] renderSimpleErrorMessage (InvalidNewtype name) = - paras [ line $ "Newtype " ++ runProperName name ++ " is invalid." + paras [ line $ "Newtype " ++ markCode (runProperName name) ++ " is invalid." , line "Newtypes must define a single constructor with a single argument." ] renderSimpleErrorMessage (InvalidInstanceHead ty) = paras [ line "Type class instance head is invalid due to use of type" - , indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox ty , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form." ] renderSimpleErrorMessage (TransitiveExportError x ys) = - paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: " - , indent $ paras $ map (line . prettyPrintExport) ys + paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following to also be exported: " + , indent $ paras $ map (line . markCode . prettyPrintExport) ys ] renderSimpleErrorMessage (TransitiveDctorExportError x ctor) = - paras [ line $ "An export for " ++ prettyPrintExport x ++ " requires the following data constructor to also be exported: " - , indent $ line $ runProperName ctor + paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following data constructor to also be exported: " + , indent $ line $ markCode $ runProperName ctor ] renderSimpleErrorMessage (ShadowedName nm) = - line $ "Name '" ++ showIdent nm ++ "' was shadowed." + line $ "Name " ++ markCode (showIdent nm) ++ " was shadowed." renderSimpleErrorMessage (ShadowedTypeVar tv) = - line $ "Type variable '" ++ tv ++ "' was shadowed." + line $ "Type variable " ++ markCode tv ++ " was shadowed." renderSimpleErrorMessage (UnusedTypeVar tv) = - line $ "Type variable '" ++ tv ++ "' was declared but not used." + line $ "Type variable " ++ markCode tv ++ " was declared but not used." renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) = - line $ "Importing type " ++ runProperName name ++ "(..) from " ++ runModuleName mn ++ " is misleading as it has no exported data constructors." + line $ "Importing type " ++ markCode (runProperName name ++ "(..)") ++ " from " ++ markCode (runModuleName mn) ++ " is misleading as it has no exported data constructors." renderSimpleErrorMessage (ImportHidingModule name) = - paras [ line "'hiding' imports cannot be used to hide modules." - , line $ "An attempt was made to hide the import of " ++ runModuleName name + paras [ line "hiding imports cannot be used to hide modules." + , line $ "An attempt was made to hide the import of " ++ markCode (runModuleName name) ] renderSimpleErrorMessage (WildcardInferredType ty) = paras [ line "Wildcard type definition has the inferred type " - , indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox ty ] renderSimpleErrorMessage (HoleInferredType name ty env) = - paras $ [ line $ "Hole '" ++ name ++ "' has the inferred type " - , indent $ typeAsBox ty + paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type " + , markCodeBox $ indent $ typeAsBox ty ] ++ if null env then [] else envInfo where envInfo :: [Box.Box] envInfo = [ line "in the following context:" , indent $ paras [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ") - , typeAsBox ty' + , markCodeBox $ typeAsBox ty' ] | (ident, ty') <- take 5 env ] ] renderSimpleErrorMessage (MissingTypeDeclaration ident ty) = - paras [ line $ "No type declaration was provided for the top-level declaration of " ++ showIdent ident ++ "." + paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "." , line "It is good practice to provide type declarations as a form of documentation." - , line $ "The inferred type of " ++ showIdent ident ++ " was:" - , indent $ typeAsBox ty + , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:" + , markCodeBox $ indent $ typeAsBox ty ] renderSimpleErrorMessage (OverlappingPattern bs b) = paras $ [ line "A case expression contains unreachable cases:\n" @@ -848,26 +907,26 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap , line "You may want to decompose your data types into smaller types." ] renderSimpleErrorMessage (UnusedImport name) = - line $ "The import of module " ++ runModuleName name ++ " is redundant" + line $ "The import of module " ++ markCode (runModuleName name) ++ " is redundant" renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) = - paras [ line $ "The import of module " ++ runModuleName mn ++ " contains the following unused references:" + paras [ line $ "The import of module " ++ markCode (runModuleName mn) ++ " contains the following unused references:" , indent $ paras $ map line names , line "It could be replaced with:" - , indent $ line $ showSuggestion msg ] + , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage (UnusedDctorImport name) = - line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used" + line $ "The import of type " ++ markCode (runProperName name) ++ " includes data constructors but only the type is used" renderSimpleErrorMessage (UnusedDctorExplicitImport name names) = - paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:" - , indent $ paras $ map (line .runProperName) names ] + paras [ line $ "The import of type " ++ markCode (runProperName name) ++ " includes the following unused data constructors:" + , indent $ paras $ map (line . markCode . runProperName) names ] renderSimpleErrorMessage (DuplicateSelectiveImport name) = - line $ "There is an existing import of " ++ runModuleName name ++ ", consider merging the import lists" + line $ "There is an existing import of " ++ markCode (runModuleName name) ++ ", consider merging the import lists" renderSimpleErrorMessage (DuplicateImport name imp qual) = - line $ "Duplicate import of " ++ prettyPrintImport name imp qual + line $ "Duplicate import of " ++ markCode (prettyPrintImport name imp qual) renderSimpleErrorMessage (DuplicateImportRef name) = line $ "Import list contains multiple references to " ++ printName (Qualified Nothing name) @@ -876,23 +935,23 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap line $ "Export list contains multiple references to " ++ printName (Qualified Nothing name) renderSimpleErrorMessage (IntOutOfRange value backend lo hi) = - paras [ line $ "Integer value " ++ show value ++ " is out of range for the " ++ backend ++ " backend." - , line $ "Acceptable values fall within the range " ++ show lo ++ " to " ++ show hi ++ " (inclusive)." ] + paras [ line $ "Integer value " ++ markCode (show value) ++ " is out of range for the " ++ backend ++ " backend." + , line $ "Acceptable values fall within the range " ++ markCode (show lo) ++ " to " ++ markCode (show hi) ++ " (inclusive)." ] renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) = - paras [ line $ "Module " ++ runModuleName importedModule ++ " was imported as " ++ runModuleName asModule ++ " with unspecified imports." - , line $ "As there are multiple modules being imported as " ++ runModuleName asModule ++ ", consider using the explicit form:" - , indent $ line $ showSuggestion msg + paras [ line $ "Module " ++ markCode (runModuleName importedModule) ++ " was imported as " ++ markCode (runModuleName asModule) ++ " with unspecified imports." + , line $ "As there are multiple modules being imported as " ++ markCode (runModuleName asModule) ++ ", consider using the explicit form:" + , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage msg@(ImplicitImport mn _) = - paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the explicit form: " - , indent $ line $ showSuggestion msg + paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the explicit form: " + , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage msg@(HidingImport mn _) = - paras [ line $ "Module " ++ runModuleName mn ++ " has unspecified imports, consider using the inclusive form: " - , indent $ line $ showSuggestion msg + paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the inclusive form: " + , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) = @@ -905,7 +964,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap line "An anonymous function argument appears in an invalid context." renderSimpleErrorMessage (InvalidOperatorInBinder op fn) = - paras [ line $ "Operator " ++ showQualified showOp op ++ " cannot be used in a pattern as it is an alias for function " ++ showQualified showIdent fn ++ "." + paras [ line $ "Operator " ++ markCode (showQualified showOp op) ++ " cannot be used in a pattern as it is an alias for function " ++ showQualified showIdent fn ++ "." , line "Only aliases for data constructors may be used in patterns." ] @@ -913,9 +972,9 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap line "The require-path option is deprecated and will be removed in PureScript 0.9." renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) = - paras [ line $ "Unable to generalize the type of the recursive function " ++ showIdent ident ++ "." - , line $ "The inferred type of " ++ showIdent ident ++ " was:" - , indent $ typeAsBox ty + paras [ line $ "Unable to generalize the type of the recursive function " ++ markCode (showIdent ident) ++ "." + , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:" + , markCodeBox $ indent $ typeAsBox ty , line "Try adding a type signature." ] @@ -923,42 +982,43 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail , Box.hsep 1 Box.top [ line "while trying to match type" - , typeAsBox t1 + , markCodeBox $ typeAsBox t1 ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type" - , typeAsBox t2 + , markCodeBox $ typeAsBox t2 ] ] renderHint (ErrorInExpression expr) detail = paras [ detail , Box.hsep 1 Box.top [ Box.text "in the expression" - , prettyPrintValue valueDepth expr + , markCodeBox $ markCodeBox $ prettyPrintValue valueDepth expr ] ] renderHint (ErrorInModule mn) detail = - paras [ line $ "in module " ++ runModuleName mn + paras [ line $ "in module " ++ markCode (runModuleName mn) , detail ] renderHint (ErrorInSubsumption t1 t2) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking that type" - , typeAsBox t1 + , markCodeBox $ typeAsBox t1 ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "is at least as general as type" - , typeAsBox t2 + , markCodeBox $ typeAsBox t2 ] ] renderHint (ErrorInInstance nm ts) detail = paras [ detail - , Box.hsep 1 Box.top [ line "in type class instance" - , line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) - ] + , line "in type class instance" + , markCodeBox $ indent $ Box.hsep 1 Box.top + [ line $ showQualified runProperName nm + , Box.vcat Box.left (map typeAtomAsBox ts) + ] ] renderHint (ErrorCheckingKind ty) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking the kind of" - , typeAsBox ty + , markCodeBox $ typeAsBox ty ] ] renderHint ErrorCheckingGuard detail = @@ -968,43 +1028,43 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap renderHint (ErrorInferringType expr) detail = paras [ detail , Box.hsep 1 Box.top [ line "while inferring the type of" - , prettyPrintValue valueDepth expr + , markCodeBox $ prettyPrintValue valueDepth expr ] ] renderHint (ErrorCheckingType expr ty) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking that expression" - , prettyPrintValue valueDepth expr + , markCodeBox $ prettyPrintValue valueDepth expr ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type" - , typeAsBox ty + , markCodeBox $ typeAsBox ty ] ] renderHint (ErrorCheckingAccessor expr prop) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking type of property accessor" - , prettyPrintValue valueDepth (Accessor prop expr) + , markCodeBox $ prettyPrintValue valueDepth (Accessor prop expr) ] ] renderHint (ErrorInApplication f t a) detail = paras [ detail , Box.hsep 1 Box.top [ line "while applying a function" - , prettyPrintValue valueDepth f + , markCodeBox $ prettyPrintValue valueDepth f ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type" - , typeAsBox t + , markCodeBox $ typeAsBox t ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument" - , prettyPrintValue valueDepth a + , markCodeBox $ prettyPrintValue valueDepth a ] ] renderHint (ErrorInDataConstructor nm) detail = paras [ detail - , line $ "in data constructor " ++ runProperName nm + , line $ "in data constructor " ++ markCode (runProperName nm) ] renderHint (ErrorInTypeConstructor nm) detail = paras [ detail - , line $ "in type constructor " ++ runProperName nm + , line $ "in type constructor " ++ markCode (runProperName nm) ] renderHint (ErrorInBindingGroup nms) detail = paras [ detail @@ -1016,19 +1076,19 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap ] renderHint (ErrorInTypeSynonym name) detail = paras [ detail - , line $ "in type synonym " ++ runProperName name + , line $ "in type synonym " ++ markCode (runProperName name) ] renderHint (ErrorInValueDeclaration n) detail = paras [ detail - , line $ "in value declaration " ++ showIdent n + , line $ "in value declaration " ++ markCode (showIdent n) ] renderHint (ErrorInTypeDeclaration n) detail = paras [ detail - , line $ "in type declaration for " ++ showIdent n + , line $ "in type declaration for " ++ markCode (showIdent n) ] renderHint (ErrorInForeignImport nm) detail = paras [ detail - , line $ "in foreign import " ++ showIdent nm + , line $ "in foreign import " ++ markCode (showIdent nm) ] renderHint (PositionedError srcSpan) detail = paras [ line $ "at " ++ displaySourceSpan srcSpan @@ -1037,19 +1097,19 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap printName :: Qualified Name -> String printName (Qualified mn (IdentName name)) = - "value " ++ showQualified showIdent (Qualified mn name) + "value " ++ markCode (showQualified showIdent (Qualified mn name)) printName (Qualified mn (ValOpName op)) = - "operator " ++ showQualified showOp (Qualified mn op) + "operator " ++ markCode (showQualified showOp (Qualified mn op)) printName (Qualified mn (TyName name)) = - "type " ++ showQualified runProperName (Qualified mn name) + "type " ++ markCode (showQualified runProperName (Qualified mn name)) printName (Qualified mn (TyOpName op)) = - "type operator " ++ showQualified showOp (Qualified mn op) + "type operator " ++ markCode (showQualified showOp (Qualified mn op)) printName (Qualified mn (DctorName name)) = - "data constructor " ++ showQualified runProperName (Qualified mn name) + "data constructor " ++ markCode (showQualified runProperName (Qualified mn name)) printName (Qualified mn (TyClassName name)) = - "type class " ++ showQualified runProperName (Qualified mn name) + "type class " ++ markCode (showQualified runProperName (Qualified mn name)) printName (Qualified Nothing (ModName name)) = - "module " ++ runModuleName name + "module " ++ markCode (runModuleName name) printName (Qualified _ ModName{}) = internalError "qualified ModName in printName" @@ -1144,32 +1204,32 @@ prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref -- | -- Pretty print multiple errors -- -prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String -prettyPrintMultipleErrors full = unlines . map renderBox . prettyPrintMultipleErrorsBox full +prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String +prettyPrintMultipleErrors ppeOptions = unlines . map renderBox . prettyPrintMultipleErrorsBox ppeOptions -- | -- Pretty print multiple warnings -- -prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String -prettyPrintMultipleWarnings full = unlines . map renderBox . prettyPrintMultipleWarningsBox full +prettyPrintMultipleWarnings :: PPEOptions -> MultipleErrors -> String +prettyPrintMultipleWarnings ppeOptions = unlines . map renderBox . prettyPrintMultipleWarningsBox ppeOptions -- | Pretty print warnings as a Box -prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> [Box.Box] -prettyPrintMultipleWarningsBox = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" +prettyPrintMultipleWarningsBox :: PPEOptions -> MultipleErrors -> [Box.Box] +prettyPrintMultipleWarningsBox ppeOptions = prettyPrintMultipleErrorsWith (ppeOptions { ppeLevel = Warning }) "Warning found:" "Warning" -- | Pretty print errors as a Box -prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box] -prettyPrintMultipleErrorsBox = prettyPrintMultipleErrorsWith Error "Error found:" "Error" +prettyPrintMultipleErrorsBox :: PPEOptions -> MultipleErrors -> [Box.Box] +prettyPrintMultipleErrorsBox ppeOptions = prettyPrintMultipleErrorsWith (ppeOptions { ppeLevel = Error }) "Error found:" "Error" -prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box] -prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = - let result = prettyPrintSingleError full level True e +prettyPrintMultipleErrorsWith :: PPEOptions -> String -> String -> MultipleErrors -> [Box.Box] +prettyPrintMultipleErrorsWith ppeOptions intro _ (MultipleErrors [e]) = + let result = prettyPrintSingleError ppeOptions e in [ Box.vcat Box.left [ Box.text intro , result ] ] -prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = - let result = map (prettyPrintSingleError full level True) es +prettyPrintMultipleErrorsWith ppeOptions _ intro (MultipleErrors es) = + let result = map (prettyPrintSingleError ppeOptions) es in concat $ zipWith withIntro [1 :: Int ..] result where withIntro i err = [ Box.text (intro ++ " " ++ show i ++ " of " ++ show (length es) ++ ":") diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index 9b7733b46b..c6936404e8 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -47,7 +47,7 @@ toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErro toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError toJSONError verbose level e = JSONError (toErrorPosition <$> sspan) - (P.renderBox (P.prettyPrintSingleError verbose level False (P.stripModuleAndSpan e))) + (P.renderBox (P.prettyPrintSingleError (P.PPEOptions Nothing verbose level False) (P.stripModuleAndSpan e))) (P.errorCode e) (P.wikiUri e) (P.spanName <$> sspan) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 0f84bbbad9..766099f3b7 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -44,7 +44,7 @@ import System.Process (readProcessWithExitCode) -- | Pretty-print errors printErrors :: MonadIO m => P.MultipleErrors -> m () -printErrors = liftIO . putStrLn . P.prettyPrintMultipleErrors False +printErrors = liftIO . putStrLn . P.prettyPrintMultipleErrors P.defaultPPEOptions -- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the -- options and ignores the warning messages. diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 9cbbf33e1e..a8fc04b422 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -26,7 +26,7 @@ supportModuleIsDefined = any ((== supportModuleName) . P.getModuleName) loadModule :: FilePath -> IO (Either String [P.Module]) loadModule filename = do content <- readUTF8File filename - return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)] + return $ either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)] -- | -- Load all modules. diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 3b46082121..71d6b183d3 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -153,3 +153,7 @@ before b1 b2 | rows b1 > 1 = b1 // b2 beforeWithSpace :: Box -> Box -> Box beforeWithSpace b1 = before (b1 <> text " ") + +-- | Place a Box on the bottom right of another +endWith :: Box -> Box -> Box +endWith l r = l <> vcat top [emptyBox (rows l - 1) (cols r), r] diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index b68d0ad23d..be5ebe5890 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -225,7 +225,7 @@ displayUserError e = case e of CompileError err -> vcat [ para "Compile error:" - , indented (vcat (P.prettyPrintMultipleErrorsBox False err)) + , indented (vcat (P.prettyPrintMultipleErrorsBox P.defaultPPEOptions err)) ] DirtyWorkingTree -> para ( diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 1d0f8e0152..019b428b49 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -76,7 +76,7 @@ spec = do externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules) return (zip (map snd modules) externs) case supportExterns of - Left errs -> fail (P.prettyPrintMultipleErrors False errs) + Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) Right externs -> return (externs, passingFiles, warningFiles, failingFiles) context "Passing examples" $ @@ -232,7 +232,7 @@ assertCompiles assertCompiles supportExterns inputFiles = assert supportExterns inputFiles checkMain $ \e -> case e of - Left errs -> return . Just . P.prettyPrintMultipleErrors False $ errs + Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do process <- findNodeProcess let entryPoint = modulesDir "index.js" @@ -255,7 +255,7 @@ assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith = assert supportExterns inputFiles checkMain $ \e -> case e of Left errs -> - return . Just . P.prettyPrintMultipleErrors False $ errs + return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right warnings -> return . fmap (printAllWarnings warnings) @@ -263,7 +263,7 @@ assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith = where printAllWarnings warnings = - (<> "\n\n" <> P.prettyPrintMultipleErrors False warnings) + (<> "\n\n" <> P.prettyPrintMultipleErrors P.defaultPPEOptions warnings) assertDoesNotCompile :: [(P.Module, P.ExternsFile)] From 2bafbae807e9a4cac69bb3f7cbb21279f90bda3b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 28 May 2016 13:23:25 -0700 Subject: [PATCH 0440/1580] Typecheck main in PSCi (#2163) --- src/Language/PureScript/Interactive/Module.hs | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index a8fc04b422..b8a61db61a 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -45,14 +45,27 @@ createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val = let moduleName = P.ModuleName [P.ProperName "$PSCI"] + effModuleName = P.moduleNameFromString "Control.Monad.Eff" + effImport = (effModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Eff"])) supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"])) eval = P.Var (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval")) mainValue = P.App eval (P.Var (P.Qualified Nothing (P.Ident "it"))) itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val + typeDecl = P.TypeDeclaration (P.Ident "$main") + (P.TypeApp + (P.TypeApp + (P.TypeConstructor + (P.Qualified (Just (P.ModuleName [P.ProperName "$Eff"])) (P.ProperName "Eff"))) + (P.TypeWildcard internalSpan)) + (P.TypeWildcard internalSpan)) mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue - decls = if exec then [itDecl, mainDecl] else [itDecl] + decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] + internalSpan = P.internalModuleSourceSpan "" in - P.Module (P.internalModuleSourceSpan "") [] moduleName ((importDecl `map` (supportImport : imports)) ++ lets ++ decls) Nothing + P.Module internalSpan + [] moduleName + ((importDecl `map` (effImport : supportImport : imports)) ++ lets ++ decls) + Nothing -- | From d2dfad0aadaf27f9869c813f13f895c9016742fb Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 29 May 2016 00:12:30 +0100 Subject: [PATCH 0441/1580] Fix issues with multiple data/type decls --- examples/failing/DeclConflictClassCtor.purs | 6 ++ .../failing/DeclConflictClassSynonym.purs | 8 ++ examples/failing/DeclConflictClassType.purs | 6 ++ examples/failing/DeclConflictCtorClass.purs | 6 ++ examples/failing/DeclConflictCtorCtor.purs | 6 ++ .../failing/DeclConflictSynonymClass.purs | 8 ++ examples/failing/DeclConflictSynonymType.purs | 8 ++ examples/failing/DeclConflictTypeClass.purs | 6 ++ examples/failing/DeclConflictTypeSynonym.purs | 8 ++ examples/failing/DeclConflictTypeType.purs | 6 ++ examples/failing/ExportConflictClass.purs | 5 + examples/failing/ExportConflictClass/A.purs | 3 + examples/failing/ExportConflictClass/B.purs | 3 + examples/failing/ExportConflictCtor.purs | 5 + examples/failing/ExportConflictCtor/A.purs | 3 + examples/failing/ExportConflictCtor/B.purs | 3 + examples/failing/ExportConflictType.purs | 5 + examples/failing/ExportConflictType/A.purs | 3 + examples/failing/ExportConflictType/B.purs | 3 + examples/failing/ExportConflictTypeOp.purs | 5 + examples/failing/ExportConflictTypeOp/A.purs | 5 + examples/failing/ExportConflictTypeOp/B.purs | 5 + examples/failing/ExportConflictValue.purs | 5 + .../A.purs | 2 + .../B.purs | 2 + examples/failing/ExportConflictValueOp.purs | 5 + examples/failing/ExportConflictValueOp/A.purs | 6 ++ examples/failing/ExportConflictValueOp/B.purs | 6 ++ examples/failing/OverlappingReExport.purs | 5 - purescript.cabal | 7 +- src/Language/PureScript/Errors.hs | 94 +++++++----------- src/Language/PureScript/Sugar/Names/Env.hs | 97 +++++++++++++------ .../PureScript/Sugar/Names/Exports.hs | 30 +++--- 33 files changed, 271 insertions(+), 104 deletions(-) create mode 100644 examples/failing/DeclConflictClassCtor.purs create mode 100644 examples/failing/DeclConflictClassSynonym.purs create mode 100644 examples/failing/DeclConflictClassType.purs create mode 100644 examples/failing/DeclConflictCtorClass.purs create mode 100644 examples/failing/DeclConflictCtorCtor.purs create mode 100644 examples/failing/DeclConflictSynonymClass.purs create mode 100644 examples/failing/DeclConflictSynonymType.purs create mode 100644 examples/failing/DeclConflictTypeClass.purs create mode 100644 examples/failing/DeclConflictTypeSynonym.purs create mode 100644 examples/failing/DeclConflictTypeType.purs create mode 100644 examples/failing/ExportConflictClass.purs create mode 100644 examples/failing/ExportConflictClass/A.purs create mode 100644 examples/failing/ExportConflictClass/B.purs create mode 100644 examples/failing/ExportConflictCtor.purs create mode 100644 examples/failing/ExportConflictCtor/A.purs create mode 100644 examples/failing/ExportConflictCtor/B.purs create mode 100644 examples/failing/ExportConflictType.purs create mode 100644 examples/failing/ExportConflictType/A.purs create mode 100644 examples/failing/ExportConflictType/B.purs create mode 100644 examples/failing/ExportConflictTypeOp.purs create mode 100644 examples/failing/ExportConflictTypeOp/A.purs create mode 100644 examples/failing/ExportConflictTypeOp/B.purs create mode 100644 examples/failing/ExportConflictValue.purs rename examples/failing/{OverlappingReExport => ExportConflictValue}/A.purs (63%) rename examples/failing/{OverlappingReExport => ExportConflictValue}/B.purs (64%) create mode 100644 examples/failing/ExportConflictValueOp.purs create mode 100644 examples/failing/ExportConflictValueOp/A.purs create mode 100644 examples/failing/ExportConflictValueOp/B.purs delete mode 100644 examples/failing/OverlappingReExport.purs diff --git a/examples/failing/DeclConflictClassCtor.purs b/examples/failing/DeclConflictClassCtor.purs new file mode 100644 index 0000000000..28e5a6e799 --- /dev/null +++ b/examples/failing/DeclConflictClassCtor.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DeclConflict +module Main where + +data T = Fail + +class Fail diff --git a/examples/failing/DeclConflictClassSynonym.purs b/examples/failing/DeclConflictClassSynonym.purs new file mode 100644 index 0000000000..319fa44002 --- /dev/null +++ b/examples/failing/DeclConflictClassSynonym.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith DeclConflict +module Main where + +import Prelude + +type Fail = Unit + +class Fail diff --git a/examples/failing/DeclConflictClassType.purs b/examples/failing/DeclConflictClassType.purs new file mode 100644 index 0000000000..322265c5f6 --- /dev/null +++ b/examples/failing/DeclConflictClassType.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DeclConflict +module Main where + +class Fail + +data Fail diff --git a/examples/failing/DeclConflictCtorClass.purs b/examples/failing/DeclConflictCtorClass.purs new file mode 100644 index 0000000000..03c052c219 --- /dev/null +++ b/examples/failing/DeclConflictCtorClass.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DeclConflict +module Main where + +class Fail + +data T = Fail diff --git a/examples/failing/DeclConflictCtorCtor.purs b/examples/failing/DeclConflictCtorCtor.purs new file mode 100644 index 0000000000..a99d8e9c77 --- /dev/null +++ b/examples/failing/DeclConflictCtorCtor.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DeclConflict +module Main where + +data T1 = Fail + +data T2 = Fail diff --git a/examples/failing/DeclConflictSynonymClass.purs b/examples/failing/DeclConflictSynonymClass.purs new file mode 100644 index 0000000000..6524dc0988 --- /dev/null +++ b/examples/failing/DeclConflictSynonymClass.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith DeclConflict +module Main where + +import Prelude + +class Fail + +type Fail = Unit diff --git a/examples/failing/DeclConflictSynonymType.purs b/examples/failing/DeclConflictSynonymType.purs new file mode 100644 index 0000000000..f9a6f4dbae --- /dev/null +++ b/examples/failing/DeclConflictSynonymType.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith DeclConflict +module Main where + +import Prelude + +data Fail + +type Fail = Unit diff --git a/examples/failing/DeclConflictTypeClass.purs b/examples/failing/DeclConflictTypeClass.purs new file mode 100644 index 0000000000..322265c5f6 --- /dev/null +++ b/examples/failing/DeclConflictTypeClass.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DeclConflict +module Main where + +class Fail + +data Fail diff --git a/examples/failing/DeclConflictTypeSynonym.purs b/examples/failing/DeclConflictTypeSynonym.purs new file mode 100644 index 0000000000..81a7cae16d --- /dev/null +++ b/examples/failing/DeclConflictTypeSynonym.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith DeclConflict +module Main where + +import Prelude + +type Fail = Unit + +data Fail diff --git a/examples/failing/DeclConflictTypeType.purs b/examples/failing/DeclConflictTypeType.purs new file mode 100644 index 0000000000..2815e8463d --- /dev/null +++ b/examples/failing/DeclConflictTypeType.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DeclConflict +module Main where + +data Fail + +data Fail diff --git a/examples/failing/ExportConflictClass.purs b/examples/failing/ExportConflictClass.purs new file mode 100644 index 0000000000..fa6e746ade --- /dev/null +++ b/examples/failing/ExportConflictClass.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ExportConflict +module C (module A, module B) where + +import A as A +import B as B diff --git a/examples/failing/ExportConflictClass/A.purs b/examples/failing/ExportConflictClass/A.purs new file mode 100644 index 0000000000..48354f7b1b --- /dev/null +++ b/examples/failing/ExportConflictClass/A.purs @@ -0,0 +1,3 @@ +module A where + +class X diff --git a/examples/failing/ExportConflictClass/B.purs b/examples/failing/ExportConflictClass/B.purs new file mode 100644 index 0000000000..f9d4b53994 --- /dev/null +++ b/examples/failing/ExportConflictClass/B.purs @@ -0,0 +1,3 @@ +module B where + +class X diff --git a/examples/failing/ExportConflictCtor.purs b/examples/failing/ExportConflictCtor.purs new file mode 100644 index 0000000000..fa6e746ade --- /dev/null +++ b/examples/failing/ExportConflictCtor.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ExportConflict +module C (module A, module B) where + +import A as A +import B as B diff --git a/examples/failing/ExportConflictCtor/A.purs b/examples/failing/ExportConflictCtor/A.purs new file mode 100644 index 0000000000..c3fadf06af --- /dev/null +++ b/examples/failing/ExportConflictCtor/A.purs @@ -0,0 +1,3 @@ +module A where + +data T1 = X diff --git a/examples/failing/ExportConflictCtor/B.purs b/examples/failing/ExportConflictCtor/B.purs new file mode 100644 index 0000000000..092d2ae78b --- /dev/null +++ b/examples/failing/ExportConflictCtor/B.purs @@ -0,0 +1,3 @@ +module B where + +data T2 = X diff --git a/examples/failing/ExportConflictType.purs b/examples/failing/ExportConflictType.purs new file mode 100644 index 0000000000..fa6e746ade --- /dev/null +++ b/examples/failing/ExportConflictType.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ExportConflict +module C (module A, module B) where + +import A as A +import B as B diff --git a/examples/failing/ExportConflictType/A.purs b/examples/failing/ExportConflictType/A.purs new file mode 100644 index 0000000000..653083056b --- /dev/null +++ b/examples/failing/ExportConflictType/A.purs @@ -0,0 +1,3 @@ +module A where + +data T diff --git a/examples/failing/ExportConflictType/B.purs b/examples/failing/ExportConflictType/B.purs new file mode 100644 index 0000000000..9d772776aa --- /dev/null +++ b/examples/failing/ExportConflictType/B.purs @@ -0,0 +1,3 @@ +module B where + +data T diff --git a/examples/failing/ExportConflictTypeOp.purs b/examples/failing/ExportConflictTypeOp.purs new file mode 100644 index 0000000000..fa6e746ade --- /dev/null +++ b/examples/failing/ExportConflictTypeOp.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ExportConflict +module C (module A, module B) where + +import A as A +import B as B diff --git a/examples/failing/ExportConflictTypeOp/A.purs b/examples/failing/ExportConflictTypeOp/A.purs new file mode 100644 index 0000000000..b0cb6dd833 --- /dev/null +++ b/examples/failing/ExportConflictTypeOp/A.purs @@ -0,0 +1,5 @@ +module A where + +type T1 a b = a -> b + +infixr 4 type T1 as ?? diff --git a/examples/failing/ExportConflictTypeOp/B.purs b/examples/failing/ExportConflictTypeOp/B.purs new file mode 100644 index 0000000000..3e3338d048 --- /dev/null +++ b/examples/failing/ExportConflictTypeOp/B.purs @@ -0,0 +1,5 @@ +module B where + +type T2 a b = a -> b + +infixr 4 type T2 as ?? diff --git a/examples/failing/ExportConflictValue.purs b/examples/failing/ExportConflictValue.purs new file mode 100644 index 0000000000..fa6e746ade --- /dev/null +++ b/examples/failing/ExportConflictValue.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ExportConflict +module C (module A, module B) where + +import A as A +import B as B diff --git a/examples/failing/OverlappingReExport/A.purs b/examples/failing/ExportConflictValue/A.purs similarity index 63% rename from examples/failing/OverlappingReExport/A.purs rename to examples/failing/ExportConflictValue/A.purs index 2204211fc8..48a3687948 100644 --- a/examples/failing/OverlappingReExport/A.purs +++ b/examples/failing/ExportConflictValue/A.purs @@ -1,2 +1,4 @@ module A where + +x :: Boolean x = true diff --git a/examples/failing/OverlappingReExport/B.purs b/examples/failing/ExportConflictValue/B.purs similarity index 64% rename from examples/failing/OverlappingReExport/B.purs rename to examples/failing/ExportConflictValue/B.purs index 65ebd09c51..b5f75b0eaa 100644 --- a/examples/failing/OverlappingReExport/B.purs +++ b/examples/failing/ExportConflictValue/B.purs @@ -1,2 +1,4 @@ module B where + +x :: Boolean x = false diff --git a/examples/failing/ExportConflictValueOp.purs b/examples/failing/ExportConflictValueOp.purs new file mode 100644 index 0000000000..fa6e746ade --- /dev/null +++ b/examples/failing/ExportConflictValueOp.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ExportConflict +module C (module A, module B) where + +import A as A +import B as B diff --git a/examples/failing/ExportConflictValueOp/A.purs b/examples/failing/ExportConflictValueOp/A.purs new file mode 100644 index 0000000000..3c78f2a8d7 --- /dev/null +++ b/examples/failing/ExportConflictValueOp/A.purs @@ -0,0 +1,6 @@ +module A where + +f1 :: forall a b. a -> b -> a +f1 x _ = x + +infix 0 f1 as !! diff --git a/examples/failing/ExportConflictValueOp/B.purs b/examples/failing/ExportConflictValueOp/B.purs new file mode 100644 index 0000000000..8447dd3cd1 --- /dev/null +++ b/examples/failing/ExportConflictValueOp/B.purs @@ -0,0 +1,6 @@ +module B where + +f2 :: forall a b. a -> b -> a +f2 x _ = x + +infix 0 f2 as !! diff --git a/examples/failing/OverlappingReExport.purs b/examples/failing/OverlappingReExport.purs deleted file mode 100644 index fbcdafcf31..0000000000 --- a/examples/failing/OverlappingReExport.purs +++ /dev/null @@ -1,5 +0,0 @@ --- @shouldFailWith DuplicateValueExport -module C (module A, module M2) where - -import A -import B as M2 diff --git a/purescript.cabal b/purescript.cabal index da0fd68477..40dd5db687 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -59,6 +59,12 @@ extra-source-files: examples/passing/*.purs , examples/failing/ConflictingImports2/*.purs , examples/failing/ConflictingQualifiedImports/*.purs , examples/failing/ConflictingQualifiedImports2/*.purs + , examples/failing/ExportConflictClass/*.purs + , examples/failing/ExportConflictCtor/*.purs + , examples/failing/ExportConflictType/*.purs + , examples/failing/ExportConflictTypeOp/*.purs + , examples/failing/ExportConflictValue/*.purs + , examples/failing/ExportConflictValueOp/*.purs , examples/failing/ExportExplicit1/*.purs , examples/failing/ExportExplicit3/*.purs , examples/failing/ImportExplicit/*.purs @@ -67,7 +73,6 @@ extra-source-files: examples/passing/*.purs , examples/failing/ImportModule/*.purs , examples/failing/InstanceExport/*.purs , examples/failing/OrphanInstance/*.purs - , examples/failing/OverlappingReExport/*.purs , examples/warning/*.purs , examples/warning/*.js , examples/docs/bower_components/purescript-prelude/src/*.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 9dc0dd19e6..c5598f3ecf 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -65,17 +65,9 @@ data SimpleErrorMessage | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName) | ScopeConflict Name [ModuleName] | ScopeShadowing Name (Maybe ModuleName) [ModuleName] - | ConflictingTypeDecls (ProperName 'TypeName) - | ConflictingCtorDecls (ProperName 'ConstructorName) - | TypeConflictsWithClass (ProperName 'TypeName) - | CtorConflictsWithClass (ProperName 'ConstructorName) - | ClassConflictsWithType (ProperName 'ClassName) - | ClassConflictsWithCtor (ProperName 'ClassName) + | DeclConflict Name Name + | ExportConflict (Qualified Name) (Qualified Name) | DuplicateModuleName ModuleName - | DuplicateClassExport (ProperName 'ClassName) - | DuplicateValueExport Ident - | DuplicateValueOpExport (OpName 'ValueOpName) - | DuplicateTypeOpExport (OpName 'TypeOpName) | DuplicateTypeArgument String | InvalidDoBind | InvalidDoLet @@ -234,17 +226,9 @@ errorCode em = case unwrapErrorMessage em of UnknownExportDataConstructor{} -> "UnknownExportDataConstructor" ScopeConflict{} -> "ScopeConflict" ScopeShadowing{} -> "ScopeShadowing" - ConflictingTypeDecls{} -> "ConflictingTypeDecls" - ConflictingCtorDecls{} -> "ConflictingCtorDecls" - TypeConflictsWithClass{} -> "TypeConflictsWithClass" - CtorConflictsWithClass{} -> "CtorConflictsWithClass" - ClassConflictsWithType{} -> "ClassConflictsWithType" - ClassConflictsWithCtor{} -> "ClassConflictsWithCtor" + DeclConflict{} -> "DeclConflict" + ExportConflict{} -> "ExportConflict" DuplicateModuleName{} -> "DuplicateModuleName" - DuplicateClassExport{} -> "DuplicateClassExport" - DuplicateValueExport{} -> "DuplicateValueExport" - DuplicateValueOpExport{} -> "DuplicateValueOpExport" - DuplicateTypeOpExport{} -> "DuplicateTypeOpExport" DuplicateTypeArgument{} -> "DuplicateTypeArgument" InvalidDoBind -> "InvalidDoBind" InvalidDoLet -> "InvalidDoLet" @@ -479,7 +463,7 @@ colorCodeBox codeColor b = case codeColor of Just cc | Box.rows b == 1 -> Box.text (ansiColor cc) Box.<> b `endWith` Box.text ansiColorReset - + | otherwise -> Box.hcat Box.left -- making two boxes, one for each side of the box so that it will set each row it's own color and will reset it afterwards [ Box.vcat Box.top $ replicate (Box.rows b) $ Box.text $ ansiColor cc , b @@ -648,28 +632,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS Just exmn' -> "declaration from " ++ markCode (runModuleName exmn') ++ " will be used." Nothing -> "local declaration will be used." ] - renderSimpleErrorMessage (ConflictingTypeDecls nm) = - line $ "Conflicting type declarations for " ++ markCode (runProperName nm) - renderSimpleErrorMessage (ConflictingCtorDecls nm) = - line $ "Conflicting data constructor declarations for " ++ markCode (runProperName nm) - renderSimpleErrorMessage (TypeConflictsWithClass nm) = - line $ "Type " ++ markCode (runProperName nm) ++ " conflicts with a type class declaration with the same name." - renderSimpleErrorMessage (CtorConflictsWithClass nm) = - line $ "Data constructor " ++ markCode (runProperName nm) ++ " conflicts with a type class declaration with the same name." - renderSimpleErrorMessage (ClassConflictsWithType nm) = - line $ "Type class " ++ markCode (runProperName nm) ++ " conflicts with a type declaration with the same name." - renderSimpleErrorMessage (ClassConflictsWithCtor nm) = - line $ "Type class " ++ markCode (runProperName nm) ++ " conflicts with a data constructor declaration with the same name." + renderSimpleErrorMessage (DeclConflict new existing) = + line $ "Declaration for " ++ printName (Qualified Nothing new) ++ " conflicts with an existing " ++ nameType existing ++ " of the same name." + renderSimpleErrorMessage (ExportConflict new existing) = + line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing renderSimpleErrorMessage (DuplicateModuleName mn) = line $ "Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times." - renderSimpleErrorMessage (DuplicateClassExport nm) = - line $ "Duplicate export declaration for type class " ++ markCode (runProperName nm) - renderSimpleErrorMessage (DuplicateValueExport nm) = - line $ "Duplicate export declaration for value " ++ markCode (showIdent nm) - renderSimpleErrorMessage (DuplicateValueOpExport op) = - line $ "Duplicate export declaration for operator " ++ markCode (showOp op) - renderSimpleErrorMessage (DuplicateTypeOpExport op) = - line $ "Duplicate export declaration for type operator " ++ markCode (showOp op) renderSimpleErrorMessage (CycleInDeclaration nm) = line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = @@ -1096,22 +1064,34 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS ] printName :: Qualified Name -> String - printName (Qualified mn (IdentName name)) = - "value " ++ markCode (showQualified showIdent (Qualified mn name)) - printName (Qualified mn (ValOpName op)) = - "operator " ++ markCode (showQualified showOp (Qualified mn op)) - printName (Qualified mn (TyName name)) = - "type " ++ markCode (showQualified runProperName (Qualified mn name)) - printName (Qualified mn (TyOpName op)) = - "type operator " ++ markCode (showQualified showOp (Qualified mn op)) - printName (Qualified mn (DctorName name)) = - "data constructor " ++ markCode (showQualified runProperName (Qualified mn name)) - printName (Qualified mn (TyClassName name)) = - "type class " ++ markCode (showQualified runProperName (Qualified mn name)) - printName (Qualified Nothing (ModName name)) = - "module " ++ markCode (runModuleName name) - printName (Qualified _ ModName{}) = - internalError "qualified ModName in printName" + printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn) + + nameType :: Name -> String + nameType (IdentName _) = "value" + nameType (ValOpName _) = "operator" + nameType (TyName _) = "type" + nameType (TyOpName _) = "type operator" + nameType (DctorName _) = "data constructor" + nameType (TyClassName _) = "type class" + nameType (ModName _) = "module" + + runName :: Qualified Name -> String + runName (Qualified mn (IdentName name)) = + showQualified showIdent (Qualified mn name) + runName (Qualified mn (ValOpName op)) = + showQualified showOp (Qualified mn op) + runName (Qualified mn (TyName name)) = + showQualified runProperName (Qualified mn name) + runName (Qualified mn (TyOpName op)) = + showQualified showOp (Qualified mn op) + runName (Qualified mn (DctorName name)) = + showQualified runProperName (Qualified mn name) + runName (Qualified mn (TyClassName name)) = + showQualified runProperName (Qualified mn name) + runName (Qualified Nothing (ModName name)) = + runModuleName name + runName (Qualified _ ModName{}) = + internalError "qualified ModName in runName" valueDepth :: Int valueDepth | full = 1000 diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 4b6ce1592a..14a34f55f2 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -10,6 +10,7 @@ module Language.PureScript.Sugar.Names.Env , envModuleSourceSpan , envModuleImports , envModuleExports + , ExportMode(..) , exportType , exportTypeOp , exportTypeClass @@ -26,6 +27,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Function (on) +import Data.Foldable (find) import Data.List (groupBy, sortBy, delete) import Data.Maybe (fromJust, mapMaybe) import qualified Data.Map as M @@ -205,32 +207,51 @@ primEnv = M.singleton primModuleName (internalModuleSourceSpan "", nullImports, primExports) +-- | +-- When updating the `Exports` the behaviour is slightly different depending +-- on whether we are exporting values defined within the module or elaborating +-- re-exported values. This type is used to indicate which behaviour should be +-- used. +-- +data ExportMode = Internal | ReExport + deriving (Eq, Show) + -- | -- Safely adds a type and its data constructors to some exports, returning an -- error if a conflict occurs. -- exportType :: MonadError MultipleErrors m - => Exports + => ExportMode + -> Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ModuleName -> m Exports -exportType exps name dctors mn = do +exportType exportMode exps name dctors mn = do let exTypes = exportedTypes exps let exClasses = exportedTypeClasses exps - forM_ (name `M.lookup` exTypes) $ \(_, mn') -> - when (mn /= mn') $ throwConflictError ConflictingTypeDecls name - when (coerceProperName name `M.member` exClasses) $ - throwConflictError TypeConflictsWithClass name - forM_ dctors $ \dctor -> do - when (dctorExists (coerceProperName dctor) `any` exTypes) $ - throwConflictError ConflictingCtorDecls dctor - when (coerceProperName dctor `M.member` exClasses) $ - throwConflictError CtorConflictsWithClass dctor + case exportMode of + Internal -> do + when (name `M.member` exTypes) $ + throwDeclConflict (TyName name) (TyName name) + when (coerceProperName name `M.member` exClasses) $ + throwDeclConflict (TyName name) (TyClassName (coerceProperName name)) + forM_ dctors $ \dctor -> do + when ((elem dctor . fst) `any` exTypes) $ + throwDeclConflict (DctorName dctor) (DctorName dctor) + when (coerceProperName dctor `M.member` exClasses) $ + throwDeclConflict (DctorName dctor) (TyClassName (coerceProperName dctor)) + ReExport -> do + forM_ (name `M.lookup` exTypes) $ \(_, mn') -> + when (mn /= mn') $ + throwExportConflict mn mn' (TyName name) + forM_ dctors $ \dctor -> + forM_ ((elem dctor . fst) `find` exTypes) $ \(_, mn') -> + when (mn /= mn') $ + throwExportConflict mn mn' (DctorName dctor) return $ exps { exportedTypes = M.alter updateOrInsert name exTypes } where - dctorExists dctor (dctors', mn') = mn /= mn' && elem dctor dctors' updateOrInsert Nothing = Just (dctors, mn) updateOrInsert (Just (dctors', _)) = Just (dctors ++ dctors', mn) @@ -245,7 +266,7 @@ exportTypeOp -> ModuleName -> m Exports exportTypeOp exps op mn = do - typeOps <- addExport DuplicateTypeOpExport op mn (exportedTypeOps exps) + typeOps <- addExport TyOpName op mn (exportedTypeOps exps) return $ exps { exportedTypeOps = typeOps } -- | @@ -253,17 +274,19 @@ exportTypeOp exps op mn = do -- exportTypeClass :: MonadError MultipleErrors m - => Exports + => ExportMode + -> Exports -> ProperName 'ClassName -> ModuleName -> m Exports -exportTypeClass exps name mn = do +exportTypeClass exportMode exps name mn = do let exTypes = exportedTypes exps - when (coerceProperName name `M.member` exTypes) $ - throwConflictError ClassConflictsWithType name - when ((elem (coerceProperName name) . fst) `any` exTypes) $ - throwConflictError ClassConflictsWithCtor name - classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps) + when (exportMode == Internal) $ do + when (coerceProperName name `M.member` exTypes) $ + throwDeclConflict (TyClassName name) (TyName (coerceProperName name)) + when ((elem (coerceProperName name) . fst) `any` exTypes) $ + throwDeclConflict (TyClassName name) (DctorName (coerceProperName name)) + classes <- addExport TyClassName name mn (exportedTypeClasses exps) return $ exps { exportedTypeClasses = classes } -- | @@ -276,7 +299,7 @@ exportValue -> ModuleName -> m Exports exportValue exps name mn = do - values <- addExport DuplicateValueExport name mn (exportedValues exps) + values <- addExport IdentName name mn (exportedValues exps) return $ exps { exportedValues = values } -- | @@ -290,7 +313,7 @@ exportValueOp -> ModuleName -> m Exports exportValueOp exps op mn = do - valueOps <- addExport DuplicateValueOpExport op mn (exportedValueOps exps) + valueOps <- addExport ValOpName op mn (exportedValueOps exps) return $ exps { exportedValueOps = valueOps } -- | @@ -299,28 +322,42 @@ exportValueOp exps op mn = do -- addExport :: (MonadError MultipleErrors m, Ord a) - => (a -> SimpleErrorMessage) + => (a -> Name) -> a -> ModuleName -> M.Map a ModuleName -> m (M.Map a ModuleName) -addExport what name mn exports = +addExport toName name mn exports = case M.lookup name exports of Just mn' | mn == mn' -> return exports - | otherwise -> throwConflictError what name + | otherwise -> throwExportConflict mn mn' (toName name) Nothing -> return $ M.insert name mn exports -- | -- Raises an error for when there is more than one definition for something. -- -throwConflictError +throwDeclConflict :: MonadError MultipleErrors m - => (a -> SimpleErrorMessage) - -> a - -> m b -throwConflictError conflict = throwError . errorMessage . conflict + => Name + -> Name + -> m a +throwDeclConflict new existing = + throwError . errorMessage $ DeclConflict new existing + +-- | +-- Raises an error for when there are conflicting names in the exports. +-- +throwExportConflict + :: MonadError MultipleErrors m + => ModuleName + -> ModuleName + -> Name + -> m a +throwExportConflict new existing name = + throwError . errorMessage $ + ExportConflict (Qualified (Just new) name) (Qualified (Just existing) name) -- | -- Gets the exports for a module, or raise an error if the module doesn't exist. diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 5026de3c7f..cf9bcf3abb 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -31,20 +31,28 @@ findExportable (Module _ _ mn ds _) = where updateExports :: Exports -> Declaration -> m Exports updateExports exps (TypeClassDeclaration tcn _ _ ds') = do - exps' <- exportTypeClass exps tcn mn + exps' <- exportTypeClass Internal exps tcn mn foldM go exps' ds' where go exps'' (TypeDeclaration name _) = exportValue exps'' name mn go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d go _ _ = internalError "Invalid declaration in TypeClassDeclaration" - updateExports exps (DataDeclaration _ tn _ dcs) = exportType exps tn (map fst dcs) mn - updateExports exps (TypeSynonymDeclaration tn _ _) = exportType exps tn [] mn - updateExports exps (ExternDataDeclaration tn _) = exportType exps tn [] mn - updateExports exps (ValueDeclaration name _ _ _) = exportValue exps name mn - updateExports exps (ValueFixityDeclaration _ _ op) = exportValueOp exps op mn - updateExports exps (TypeFixityDeclaration _ _ op) = exportTypeOp exps op mn - updateExports exps (ExternDeclaration name _) = exportValue exps name mn - updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d + updateExports exps (DataDeclaration _ tn _ dcs) = + exportType Internal exps tn (map fst dcs) mn + updateExports exps (TypeSynonymDeclaration tn _ _) = + exportType Internal exps tn [] mn + updateExports exps (ExternDataDeclaration tn _) = + exportType Internal exps tn [] mn + updateExports exps (ValueDeclaration name _ _ _) = + exportValue exps name mn + updateExports exps (ValueFixityDeclaration _ _ op) = + exportValueOp exps op mn + updateExports exps (TypeFixityDeclaration _ _ op) = + exportTypeOp exps op mn + updateExports exps (ExternDeclaration name _) = + exportValue exps name mn + updateExports exps (PositionedDeclaration pos _ d) = + rethrowWithPosition pos $ updateExports exps d updateExports exps _ = return exps -- | @@ -99,9 +107,9 @@ resolveExports env ss mn imps exps refs = reClasses <- extract isPseudo name TyClassName (importedTypeClasses imps) reValues <- extract isPseudo name IdentName (importedValues imps) reValueOps <- extract isPseudo name ValOpName (importedValueOps imps) - foldM (\exps' ((tctor, dctors), mn') -> exportType exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors) + foldM (\exps' ((tctor, dctors), mn') -> exportType ReExport exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors) >>= flip (foldM (uncurry . exportTypeOp)) (map resolveTypeOp reTypeOps) - >>= flip (foldM (uncurry . exportTypeClass)) (map resolveClass reClasses) + >>= flip (foldM (uncurry . exportTypeClass ReExport)) (map resolveClass reClasses) >>= flip (foldM (uncurry . exportValue)) (map resolveValue reValues) >>= flip (foldM (uncurry . exportValueOp)) (map resolveValueOp reValueOps) elaborateModuleExports result _ = return result From e945175ebe22ba5aa2ab7f1767cd6690cb98a1ea Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 29 May 2016 00:45:58 +0100 Subject: [PATCH 0442/1580] Restore position info to import parser --- src/Language/PureScript/Parser/Declarations.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 9c1ae7796a..b43afec856 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -140,7 +140,7 @@ parseFixityDeclaration = do <*> (reserved "as" *> parseOperator) parseImportDeclaration :: TokenParser Declaration -parseImportDeclaration = do +parseImportDeclaration = withSourceSpan PositionedDeclaration $ do (mn, declType, asQ) <- parseImportDeclaration' return $ ImportDeclaration mn declType asQ From c9f0839625f7d410eaeecb4a4e268b6750e33c50 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 30 May 2016 10:30:01 -0700 Subject: [PATCH 0443/1580] Programmable type errors (#2155) * Programmable type errors * update unifiesWith and typeHeadsAreEqual --- src/Language/PureScript/Constants.hs | 3 + src/Language/PureScript/Environment.hs | 5 +- src/Language/PureScript/Errors.hs | 4 ++ src/Language/PureScript/Kinds.hs | 26 +++---- src/Language/PureScript/Parser/Kinds.hs | 4 ++ src/Language/PureScript/Parser/Types.hs | 4 ++ src/Language/PureScript/Pretty/Kinds.hs | 1 + src/Language/PureScript/Pretty/Types.hs | 1 + src/Language/PureScript/TypeChecker.hs | 1 + .../PureScript/TypeChecker/Entailment.hs | 1 + src/Language/PureScript/TypeChecker/Kinds.hs | 2 + src/Language/PureScript/TypeChecker/Unify.hs | 15 ++-- src/Language/PureScript/Types.hs | 70 +++++-------------- 13 files changed, 60 insertions(+), 77 deletions(-) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 61e35e8384..1713a0db3d 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -327,6 +327,9 @@ partial = "Partial" pattern Partial :: Qualified (ProperName 'ClassName) pattern Partial = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Partial") +pattern Fail :: Qualified (ProperName 'ClassName) +pattern Fail = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Fail") + -- Code Generation __superclass_ :: String diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index ab84e86408..c8c6b0a8c5 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -240,6 +240,7 @@ primTypes = , (primName "Int", (Star, ExternData)) , (primName "Boolean", (Star, ExternData)) , (primName "Partial", (Star, ExternData)) + , (primName "Fail", (FunKind Symbol Star, ExternData)) ] -- | @@ -249,7 +250,9 @@ primTypes = primClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint]) primClasses = M.fromList - [ (primName "Partial", ([], [], [])) ] + [ (primName "Partial", ([], [], [])) + , (primName "Fail", ([("message", Just Symbol)], [], [])) + ] -- | -- Finds information about data constructors from the current environment. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index c5598f3ecf..9eff7d44c5 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -713,6 +713,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , line "They may be disallowed completely in a future version of the compiler." ] renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list" + renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ TypeLevelString message ] _)) = + paras [ line "A custom type error occurred while solving type class constraints:" + , indent . paras . map line . lines $ message + ] renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial _ (Just (PartialConstraintData bs b)))) = diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 4309e7606e..139dd5816e 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -6,30 +6,20 @@ import Prelude.Compat import qualified Data.Aeson.TH as A --- | --- The data type of kinds --- +-- | The data type of kinds data Kind - -- | - -- Unification variable of type Kind - -- + -- | Unification variable of type Kind = KUnknown Int - -- | - -- The kind of types - -- + -- | The kind of types | Star - -- | - -- The kind of effects - -- + -- | The kind of effects | Bang - -- | - -- Kinds for labelled, unordered rows without duplicates - -- + -- | Kinds for labelled, unordered rows without duplicates | Row Kind - -- | - -- Function kinds - -- + -- | Function kinds | FunKind Kind Kind + -- | Type-level strings + | Symbol deriving (Show, Read, Eq, Ord) $(A.deriveJSON A.defaultOptions ''Kind) diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs index f3e97c49e8..6e0c09f980 100644 --- a/src/Language/PureScript/Parser/Kinds.hs +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -18,10 +18,14 @@ parseStar = const Star <$> symbol' "*" parseBang :: TokenParser Kind parseBang = const Bang <$> symbol' "!" +parseSymbol :: TokenParser Kind +parseSymbol = const Symbol <$> uname' "Symbol" + parseTypeAtom :: TokenParser Kind parseTypeAtom = indented *> P.choice [ parseStar , parseBang + , parseSymbol , parens parseKind ] -- | diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 5f4758802d..da155f7736 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -26,6 +26,9 @@ parseFunction = parens rarrow >> return tyFunction parseObject :: TokenParser Type parseObject = braces $ TypeApp tyRecord <$> parseRow +parseTypeLevelString :: TokenParser Type +parseTypeLevelString = TypeLevelString <$> stringLiteral + parseTypeWildcard :: TokenParser Type parseTypeWildcard = do start <- P.getPosition @@ -53,6 +56,7 @@ parseTypeAtom :: TokenParser Type parseTypeAtom = indented *> P.choice [ P.try parseConstrainedType , P.try parseFunction + , parseTypeLevelString , parseObject , parseTypeWildcard , parseForAll diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs index 92c5e8ffc2..fdcbb38a31 100644 --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -21,6 +21,7 @@ typeLiterals = mkPattern match where match Star = Just "*" match Bang = Just "!" + match Symbol = Just "Symbol" match (KUnknown u) = Just $ 'u' : show u match _ = Nothing diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 255d08aede..593f3a1c1b 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -32,6 +32,7 @@ typeLiterals = mkPattern match where match TypeWildcard{} = Just $ text "_" match (TypeVar var) = Just $ text var + match (TypeLevelString s) = Just . text $ show s match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor match (TUnknown u) = Just $ text $ 't' : show u diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 57a203de01..8b56bd9709 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -147,6 +147,7 @@ checkTypeClassInstance -> Type -> m () checkTypeClassInstance _ (TypeVar _) = return () +checkTypeClassInstance _ (TypeLevelString _) = return () checkTypeClassInstance _ (TypeConstructor ctor) = do env <- getEnv when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index f1dcbf182b..73d696efc7 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -184,6 +184,7 @@ typeHeadsAreEqual _ (TUnknown u1) (TUnknown u2) | u1 == u2 = Just typeHeadsAreEqual _ (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Just [] typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)] typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just [] +typeHeadsAreEqual _ (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = Just [] typeHeadsAreEqual m (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m h1 h2 <*> typeHeadsAreEqual m t1 t2 typeHeadsAreEqual _ REmpty REmpty = Just [] diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 09b37468af..ea5d59835e 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -87,6 +87,7 @@ unifyKinds k1 k2 = do go k (KUnknown u) = solveKind u k go Star Star = return () go Bang Bang = return () + go Symbol Symbol = return () go (Row k1') (Row k2') = go k1' k2' go (FunKind k1' k2') (FunKind k3 k4) = do go k1' k3 @@ -230,6 +231,7 @@ infer' other = (, []) <$> go other unifyKinds k k' return k' go TypeWildcard{} = freshKind + go (TypeLevelString _) = return Symbol go (TypeVar v) = do Just moduleName <- checkCurrentModule <$> get lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 5bf1558469..8716a6d948 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -153,13 +153,14 @@ unifyRows r1 r2 = -- Check that two types unify -- unifiesWith :: Type -> Type -> Bool -unifiesWith (TUnknown u1) (TUnknown u2) | u1 == u2 = True -unifiesWith (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = True -unifiesWith (TypeVar v1) (TypeVar v2) | v1 == v2 = True -unifiesWith (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True -unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2 -unifiesWith REmpty REmpty = True -unifiesWith r1@RCons{} r2@RCons{} = +unifiesWith (TUnknown u1) (TUnknown u2) = u1 == u2 +unifiesWith (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2 +unifiesWith (TypeVar v1) (TypeVar v2) = v1 == v2 +unifiesWith (TypeLevelString s1) (TypeLevelString s2) = s1 == s2 +unifiesWith (TypeConstructor c1) (TypeConstructor c2) = c1 == c2 +unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2 +unifiesWith REmpty REmpty = True +unifiesWith r1@RCons{} r2@RCons{} = let (s1, r1') = rowToList r1 (s2, r2') = rowToList r2 diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index b638b882d4..8f2edf0645 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -29,79 +29,47 @@ newtype SkolemScope = SkolemScope { runSkolemScope :: Int } -- The type of types -- data Type - -- | - -- A unification variable of type Type - -- + -- | A unification variable of type Type = TUnknown Int - -- | - -- A named type variable - -- + -- | A named type variable | TypeVar String - -- | - -- A type wildcard, as would appear in a partial type synonym - -- + -- | A type-level string + | TypeLevelString String + -- | A type wildcard, as would appear in a partial type synonym | TypeWildcard SourceSpan - -- | - -- A type constructor - -- + -- | A type constructor | TypeConstructor (Qualified (ProperName 'TypeName)) - -- | - -- A type operator. This will be desugared into a type constructor during the + -- | A type operator. This will be desugared into a type constructor during the -- "operators" phase of desugaring. - -- | TypeOp (Qualified (OpName 'TypeOpName)) - -- | - -- A type application - -- + -- | A type application | TypeApp Type Type - -- | - -- Forall quantifier - -- + -- | Forall quantifier | ForAll String Type (Maybe SkolemScope) - -- | - -- A type with a set of type class constraints - -- + -- | A type with a set of type class constraints | ConstrainedType [Constraint] Type - -- | - -- A skolem constant - -- + -- | A skolem constant | Skolem String Int SkolemScope (Maybe SourceSpan) - -- | - -- An empty row - -- + -- | An empty row | REmpty - -- | - -- A non-empty row - -- + -- | A non-empty row | RCons String Type Type - -- | - -- A type with a kind annotation - -- + -- | A type with a kind annotation | KindedType Type Kind - -- | - -- A placeholder used in pretty printing - -- + -- | A placeholder used in pretty printing | PrettyPrintFunction Type Type - -- | - -- A placeholder used in pretty printing - -- + -- | A placeholder used in pretty printing | PrettyPrintObject Type - -- | - -- A placeholder used in pretty printing - -- + -- | A placeholder used in pretty printing | PrettyPrintForAll [String] Type - -- | - -- Binary operator application. During the rebracketing phase of desugaring, + -- | Binary operator application. During the rebracketing phase of desugaring, -- this data constructor will be removed. - -- | BinaryNoParensType Type Type Type - -- | - -- Explicit parentheses. During the rebracketing phase of desugaring, this + -- | Explicit parentheses. During the rebracketing phase of desugaring, this -- data constructor will be removed. -- -- Note: although it seems this constructor is not used, it _is_ useful, -- since it prevents certain traversals from matching. - -- | ParensInType Type deriving (Show, Read, Eq, Ord) From 0ffc1f6d93d1d4eeaff7e7b7317b069731be9481 Mon Sep 17 00:00:00 2001 From: Phillip Freeman Date: Mon, 30 May 2016 10:57:12 -0700 Subject: [PATCH 0444/1580] Fix build for programmable type errors after merge --- examples/failing/ProgrammableTypeErrors.purs | 16 ++++++++++++++++ src/Language/PureScript/Parser/Lexer.hs | 7 +++++++ 2 files changed, 23 insertions(+) create mode 100644 examples/failing/ProgrammableTypeErrors.purs diff --git a/examples/failing/ProgrammableTypeErrors.purs b/examples/failing/ProgrammableTypeErrors.purs new file mode 100644 index 0000000000..72d51ef57b --- /dev/null +++ b/examples/failing/ProgrammableTypeErrors.purs @@ -0,0 +1,16 @@ +-- @shouldFailWith NoInstanceFound + +module Main where + +import Prelude +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (log) + +class MyShow a where + myShow :: a -> String + +instance cannotShowFunctions :: Fail "Cannot show functions" => MyShow (a -> b) where + myShow _ = "unreachable" + +main :: Eff _ _ +main = log (myShow (_ + 1)) diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index c7b157c20e..b76e6eb42b 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -43,6 +43,7 @@ module Language.PureScript.Parser.Lexer , qualifier , tyname , uname + , uname' , mname , reserved , symbol @@ -432,6 +433,12 @@ uname = token go P. "proper name" go (UName s) | validUName s = Just s go _ = Nothing +uname' :: String -> TokenParser () +uname' s = token go P. "proper name" + where + go (UName s') | s == s' = Just () + go _ = Nothing + tyname :: TokenParser String tyname = token go P. "type name" where From 32f852e2465c06f65b9b296e3be702b817444e5b Mon Sep 17 00:00:00 2001 From: Phillip Freeman Date: Mon, 30 May 2016 10:57:50 -0700 Subject: [PATCH 0445/1580] Bump version --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 40dd5db687..5b4c62e8fc 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.9.0 +version: 0.9.1 cabal-version: >=1.8 build-type: Simple license: MIT From 3944c6ecefcb047143efafb2e8233ebfac2bb2d1 Mon Sep 17 00:00:00 2001 From: Phillip Freeman Date: Mon, 30 May 2016 11:00:48 -0700 Subject: [PATCH 0446/1580] Disable the nightly Stackage build for now --- .travis.yml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/.travis.yml b/.travis.yml index ac5f023a42..3a05057234 100644 --- a/.travis.yml +++ b/.travis.yml @@ -14,12 +14,12 @@ matrix: sudo: required env: BUILD_TYPE=normal COVERAGE=true DEPLOY=true - - compiler: cc-linux-nightly-normal - os: linux - dist: trusty - sudo: required - env: BUILD_TYPE=normal STACKAGE_NIGHTLY=true - allow_failures: true + # - compiler: cc-linux-nightly-normal + # os: linux + # dist: trusty + # sudo: required + # env: BUILD_TYPE=normal STACKAGE_NIGHTLY=true + # allow_failures: true - compiler: cc-linux-lts-sdist os: linux From 17c486d8256edca9957a280cd55d0dc18e8b1627 Mon Sep 17 00:00:00 2001 From: Michael Ficarra Date: Mon, 30 May 2016 16:30:02 -0700 Subject: [PATCH 0447/1580] fixes #2172: allow escape seqs in JS FFI exported using strings --- examples/passing/2172.js | 5 +++++ examples/passing/2172.purs | 10 ++++++++++ purescript.cabal | 1 + src/Language/PureScript/Bundle.hs | 32 +++++++++++++++++++++++++++---- 4 files changed, 44 insertions(+), 4 deletions(-) create mode 100644 examples/passing/2172.js create mode 100644 examples/passing/2172.purs diff --git a/examples/passing/2172.js b/examples/passing/2172.js new file mode 100644 index 0000000000..34d232eef3 --- /dev/null +++ b/examples/passing/2172.js @@ -0,0 +1,5 @@ +exports['a\''] = 0; +exports["\x62\x27"] = 1; +// NOTE: I wanted to use "\c'" here, but langauge-javascript doesn't support it... +exports["c'"] = 2; +exports["\u0064\u0027"] = 3; diff --git a/examples/passing/2172.purs b/examples/passing/2172.purs new file mode 100644 index 0000000000..087301e9d2 --- /dev/null +++ b/examples/passing/2172.purs @@ -0,0 +1,10 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +foreign import a' :: Number +foreign import b' :: Number +foreign import c' :: Number +foreign import d' :: Number + +main = log "Done" diff --git a/purescript.cabal b/purescript.cabal index 40dd5db687..e3bbca147a 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -20,6 +20,7 @@ author: Phil Freeman , tested-with: GHC==7.10.3 extra-source-files: examples/passing/*.purs + , examples/passing/*.js , examples/passing/2018/*.purs , examples/passing/2138/*.purs , examples/passing/ClassRefSyntax/*.purs diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index e3fbe0851f..316652c8c1 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -19,6 +19,7 @@ import Prelude.Compat import Control.Monad import Control.Monad.Error.Class +import Data.Char (chr, digitToInt) import Data.Generics (everything, everywhere, mkQ, mkT) import Data.Graph import Data.List (nub, stripPrefix) @@ -186,11 +187,34 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es) -- String literals include the quote chars fromStringLiteral :: JSExpression -> Maybe String -fromStringLiteral (JSStringLiteral _ str) = Just $ trimStringQuotes str +fromStringLiteral (JSStringLiteral _ str) = Just $ strValue str fromStringLiteral _ = Nothing -trimStringQuotes :: String -> String -trimStringQuotes str = reverse $ drop 1 $ reverse $ drop 1 $ str +strValue :: String -> String +strValue str = go $ drop 1 str + where + go ('\\' : 'b' : xs) = '\b' : go xs + go ('\\' : 'f' : xs) = '\f' : go xs + go ('\\' : 'n' : xs) = '\n' : go xs + go ('\\' : 'r' : xs) = '\r' : go xs + go ('\\' : 't' : xs) = '\t' : go xs + go ('\\' : 'v' : xs) = '\v' : go xs + go ('\\' : '0' : xs) = '\0' : go xs + go ('\\' : 'x' : a : b : xs) = chr (a' + b') : go xs + where + a' = 16 * digitToInt a + b' = digitToInt b + go ('\\' : 'u' : a : b : c : d : xs) = chr (a' + b' + c' + d') : go xs + where + a' = 16 * 16 * 16 * digitToInt a + b' = 16 * 16 * digitToInt b + c' = 16 * digitToInt c + d' = digitToInt d + go ('\\' : x : xs) = x : go xs + go "\"" = "" + go "'" = "" + go (x : xs) = x : go xs + go "" = "" commaList :: JSCommaList a -> [a] commaList JSLNil = [] @@ -332,7 +356,7 @@ matchExportsAssignment stmt = Nothing extractLabel :: JSPropertyName -> Maybe String -extractLabel (JSPropertyString _ nm) = Just (trimStringQuotes nm) +extractLabel (JSPropertyString _ nm) = Just $ strValue nm extractLabel (JSPropertyIdent _ nm) = Just nm extractLabel _ = Nothing From 9d653a7b5376cfeda66e33ad70857dc600f4f743 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 5 Jun 2016 13:02:41 +0300 Subject: [PATCH 0448/1580] Run bower thru node(js) executable --- tests/TestUtils.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 1f01d039c1..49e9c2a434 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -12,6 +12,8 @@ import Control.Exception import System.Process import System.Directory import System.Info +import System.Exit (exitFailure) +import System.IO (stderr, hPutStrLn) findNodeProcess :: IO (Maybe String) findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names @@ -33,10 +35,17 @@ updateSupportCode = do then callProcess "setup-win.cmd" [] else do callProcess "npm" ["install"] + -- bower uses shebang "/usr/bin/env node", but we might have nodejs + node <- maybe cannotFindNode pure =<< findNodeProcess -- Sometimes we run as a root (e.g. in simple docker containers) -- And we are non-interactive: https://github.com/bower/bower/issues/1162 - callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"] + callProcess node ["node_modules/.bin/bower", "--allow-root", "install", "--config.interactive=false"] setCurrentDirectory "../.." + where + cannotFindNode :: IO a + cannotFindNode = do + hPutStrLn stderr "Cannot find node (or nodejs) executable" + exitFailure -- | -- The support modules that should be cached between test cases, to avoid From e716ea5027592b1b86a7aa766cbf525731f7bcc9 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 5 Jun 2016 21:24:02 +0300 Subject: [PATCH 0449/1580] Travis tweaks (#2178) * Build haddock --fast * Use Stackage LTS-6.1 * Add build-job for ghc 8.0 * Fix GHC-8.0 warnings --- .travis.yml | 6 ++++++ src/Language/PureScript/AST/Declarations.hs | 3 +++ src/Language/PureScript/CodeGen/JS/Optimizer.hs | 4 ++-- src/Language/PureScript/Docs/ParseAndBookmark.hs | 2 +- src/Language/PureScript/Ide.hs | 12 ++++++------ src/Language/PureScript/Ide/CaseSplit.hs | 6 ++---- src/Language/PureScript/Ide/Imports.hs | 6 ++---- src/Language/PureScript/Ide/State.hs | 2 +- src/Language/PureScript/Linter/Exhaustive.hs | 4 ++-- src/Language/PureScript/Linter/Imports.hs | 3 +-- src/Language/PureScript/Make.hs | 4 ++-- src/Language/PureScript/Parser/Common.hs | 2 +- src/Language/PureScript/Pretty/Common.hs | 2 +- .../PureScript/Sugar/CaseDeclarations.hs | 2 +- src/Language/PureScript/Sugar/Names.hs | 2 +- src/Language/PureScript/Sugar/Names/Env.hs | 2 +- src/Language/PureScript/Sugar/Names/Exports.hs | 3 +-- src/Language/PureScript/TypeChecker.hs | 16 ++++++++-------- src/Language/PureScript/TypeChecker/Rows.hs | 4 +--- src/Language/PureScript/TypeChecker/Skolems.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 4 ++-- stack-ghc-8.0.yaml | 5 +++++ stack.yaml | 7 ++----- travis/build.sh | 2 +- 24 files changed, 54 insertions(+), 51 deletions(-) create mode 100644 stack-ghc-8.0.yaml diff --git a/.travis.yml b/.travis.yml index 3a05057234..f86c1d8452 100644 --- a/.travis.yml +++ b/.travis.yml @@ -21,6 +21,12 @@ matrix: # env: BUILD_TYPE=normal STACKAGE_NIGHTLY=true # allow_failures: true + - compiler: cc-linux-ghc8.0-normal + os: linux + dist: trusty + sudo: required + env: BUILD_TYPE=normal STACK_YAML=stack-ghc-8.0.yaml + - compiler: cc-linux-lts-sdist os: linux dist: trusty diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 0f6df99c92..89c15ae9d5 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -218,7 +218,10 @@ data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'Cons data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName) deriving (Eq, Ord, Show, Read) +pattern ValueFixityDeclaration :: Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration pattern ValueFixityDeclaration fixity name op = FixityDeclaration (Left (ValueFixity fixity name op)) + +pattern TypeFixityDeclaration :: Fixity -> Qualified (ProperName 'TypeName) -> OpName 'TypeOpName -> Declaration pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFixity fixity name op)) -- | The members of a type class instance declaration diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs index 2ee3a82284..fd045b09e8 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -39,12 +39,12 @@ import qualified Language.PureScript.Constants as C -- | -- Apply a series of optimizer passes to simplified Javascript code -- -optimize :: (Monad m, MonadReader Options m, MonadSupply m) => JS -> m JS +optimize :: (MonadReader Options m, MonadSupply m) => JS -> m JS optimize js = do noOpt <- asks optionsNoOptimizations if noOpt then return js else optimize' js -optimize' :: (Monad m, MonadReader Options m, MonadSupply m) => JS -> m JS +optimize' :: (MonadReader Options m, MonadSupply m) => JS -> m JS optimize' js = do opts <- ask js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll diff --git a/src/Language/PureScript/Docs/ParseAndBookmark.hs b/src/Language/PureScript/Docs/ParseAndBookmark.hs index a0dc8fe699..b87fb411fd 100644 --- a/src/Language/PureScript/Docs/ParseAndBookmark.hs +++ b/src/Language/PureScript/Docs/ParseAndBookmark.hs @@ -44,7 +44,7 @@ parseAndBookmark inputFiles depsFiles = do addBookmarks <$> parseFiles (inputFiles' ++ depsFiles') parseFiles :: - (MonadError P.MultipleErrors m, MonadIO m) => + (MonadError P.MultipleErrors m) => [(FileInfo, FilePath)] -> m [(FileInfo, P.Module)] parseFiles = diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index b545a82071..590bdb9cf5 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -94,24 +94,24 @@ handleCommand Cwd = handleCommand Reset = resetPscIdeState *> pure (TextResult "State has been reset.") handleCommand Quit = liftIO exitSuccess -findCompletions :: (PscIde m, MonadLogger m) => +findCompletions :: (PscIde m) => [Filter] -> Matcher -> Maybe P.ModuleName -> m Success findCompletions filters matcher currentModule = do modules <- getAllModulesWithReexportsAndCache currentModule pure . CompletionResult . mapMaybe completionFromMatch . getCompletions filters matcher $ modules -findType :: (PscIde m, MonadLogger m) => +findType :: (PscIde m) => DeclIdent -> [Filter] -> Maybe P.ModuleName -> m Success findType search filters currentModule = do modules <- getAllModulesWithReexportsAndCache currentModule pure . CompletionResult . mapMaybe completionFromMatch . getExactMatches search filters $ modules -findPursuitCompletions :: (MonadIO m, MonadLogger m) => +findPursuitCompletions :: (MonadIO m) => PursuitQuery -> m Success findPursuitCompletions (PursuitQuery q) = PursuitResult <$> liftIO (searchPursuitForDeclarations q) -findPursuitPackages :: (MonadIO m, MonadLogger m) => +findPursuitPackages :: (MonadIO m) => PursuitQuery -> m Success findPursuitPackages (PursuitQuery q) = PursuitResult <$> liftIO (findPackagesForModuleIdent q) @@ -141,7 +141,7 @@ listAvailableModules' dirs = let cleanedModules = filter (`notElem` [".", ".."]) dirs in map T.pack cleanedModules -caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => +caseSplit :: (PscIde m, MonadError PscIdeError m) => Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success caseSplit l b e csa t = do patterns <- CS.makePattern l b e csa <$> CS.caseSplit t @@ -150,7 +150,7 @@ caseSplit l b e csa t = do addClause :: Text -> CS.WildcardAnnotations -> Success addClause t wca = MultilineTextResult (CS.addClause t wca) -importsForFile :: (MonadIO m, MonadLogger m, MonadError PscIdeError m) => +importsForFile :: (MonadIO m, MonadError PscIdeError m) => FilePath -> m Success importsForFile fp = do imports <- getImportsForFile fp diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 53e1db02da..4c73235e34 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -13,7 +13,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} module Language.PureScript.Ide.CaseSplit ( WildcardAnnotations() @@ -29,7 +28,6 @@ import Prelude.Compat hiding (lex) import Control.Arrow (second) import Control.Monad.Error.Class -import "monad-logger" Control.Monad.Logger import Data.List (find) import Data.Monoid import Data.Text (Text) @@ -55,7 +53,7 @@ explicitAnnotations = WildcardAnnotations True noAnnotations :: WildcardAnnotations noAnnotations = WildcardAnnotations False -caseSplit :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => +caseSplit :: (PscIde m, MonadError PscIdeError m) => Text -> m [Constructor] caseSplit q = do type' <- parseType' (T.unpack q) @@ -65,7 +63,7 @@ caseSplit q = do let appliedCtors = map (second (map applyTypeVars)) ctors pure appliedCtors -findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => +findTypeDeclaration :: (PscIde m, MonadError PscIdeError m) => P.ProperName 'P.TypeName -> m ExternsDeclaration findTypeDeclaration q = do efs <- getExternFiles diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 7d24af731b..e7cbcd9c99 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -13,7 +13,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} module Language.PureScript.Ide.Imports ( addImplicitImport @@ -34,7 +33,6 @@ import Prelude.Compat import Control.Applicative ((<|>)) import Control.Monad.Error.Class import Control.Monad.IO.Class -import "monad-logger" Control.Monad.Logger import Data.Bifunctor (first, second) import Data.Function (on) import qualified Data.List as List @@ -182,7 +180,7 @@ addImplicitImport' imports mn = -- So @addExplicitImport "/File.purs" "bind" "Prelude"@ with an already existing -- @import Prelude (bind)@ in the file File.purs returns @["import Prelude -- (bind, unit)"]@ -addExplicitImport :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) => +addExplicitImport :: (MonadIO m, MonadError PscIdeError m) => FilePath -> ExternDecl -> P.ModuleName -> m [Text] addExplicitImport fp decl moduleName = do (mn, pre, imports, post) <- parseImportsFromFile fp @@ -265,7 +263,7 @@ updateAtFirstOrPrepend p t d l = -- -- * If more than one possible imports are found, reports the possibilities as a -- list of completions. -addImportForIdentifier :: (PscIde m, MonadError PscIdeError m, MonadLogger m) +addImportForIdentifier :: (PscIde m, MonadError PscIdeError m) => FilePath -- ^ The Sourcefile to read from -> Text -- ^ The identifier to import -> [Filter] -- ^ Filters to apply before searching for diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 325a4b1128..a4009c4880 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -91,7 +91,7 @@ getAllModulesWithReexportsAndCache (Just mn) = do _ -> getAllModulesWithReexports -- | Looks up a single Module inside the loaded Modules -getModule :: (PscIde m, MonadLogger m) => ModuleIdent -> m (Maybe Module) +getModule :: (PscIde m) => ModuleIdent -> m (Maybe Module) getModule m = getModule' <$> getPscIdeState <*> pure m -- | Pure version of @getModule@ diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 782af1cda1..768bd0cd67 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -140,7 +140,7 @@ missingCasesSingle env mn (LiteralBinder (ObjectLiteral bs)) (LiteralBinder (Obj where fm = fromMaybe e - compBS :: Eq a => b -> a -> Maybe b -> Maybe b -> (a, (b, b)) + compBS :: b -> a -> Maybe b -> Maybe b -> (a, (b, b)) compBS e s b b' = (s, compB e b b') (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs' @@ -274,7 +274,7 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step ( -- -- The binder information is provided so that it can be embedded in the constraint, -- and then included in the error message. - addPartialConstraint :: MonadSupply m => ([[Binder]], Bool) -> Expr -> m Expr + addPartialConstraint :: ([[Binder]], Bool) -> Expr -> m Expr addPartialConstraint (bss, complete) e = do tyVar <- ("p" ++) . show <$> fresh var <- freshName diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index df4cda0a3b..41def96983 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -169,8 +169,7 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do go (q, name) = M.alter (Just . maybe [name] (name :)) q extractByQual - :: Eq a - => ModuleName + :: ModuleName -> M.Map (Qualified a) [ImportRecord a] -> (a -> Name) -> [(ModuleName, Qualified Name)] diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 7192f749ab..d4dc6e35d3 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -132,7 +132,7 @@ data RebuildPolicy | RebuildAlways deriving (Show, Read, Eq, Ord) -- | Rebuild a single module -rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [ExternsFile] -> Module @@ -159,7 +159,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do -- If timestamps have not changed, the externs file can be used to provide the module's types without -- having to typecheck the module again. -- -make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [Module] -> m [ExternsFile] diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index c98ce2e7bd..b7f530efcf 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -72,7 +72,7 @@ augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q -- | -- Run the first parser, then match the second zero or more times, applying the specified function for each match -- -fold :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a +fold :: P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a fold first more combine = do a <- first bs <- P.many more diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 71d6b183d3..ea526caa87 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -114,7 +114,7 @@ blockIndent = 4 -- | -- Pretty print with a new indentation level -- -withIndent :: (Emit gen) => StateT PrinterState Maybe gen -> StateT PrinterState Maybe gen +withIndent :: StateT PrinterState Maybe gen -> StateT PrinterState Maybe gen withIndent action = do modify $ \st -> st { indent = indent st + blockIndent } result <- action diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index d8cd5714c8..717b41859a 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -144,7 +144,7 @@ toTuple (ValueDeclaration _ _ bs result) = (bs, result) toTuple (PositionedDeclaration _ _ d) = toTuple d toTuple _ = internalError "Not a value declaration" -makeCaseDeclaration :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration +makeCaseDeclaration :: forall m. (MonadSupply m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration makeCaseDeclaration ident alternatives = do let namedArgs = map findName . fst <$> alternatives argNames = foldl1 resolveNames namedArgs diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index d8a8a788e1..665c51c02e 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -292,7 +292,7 @@ renameInModule imports (Module ss coms mn decls exps) = -- qualified references are replaced with their canoncial qualified names -- (e.g. M.Map -> Data.Map.Map). update - :: (Ord a, Show a) + :: (Ord a) => M.Map (Qualified a) [ImportRecord a] -> (a -> Name) -> Qualified a diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 14a34f55f2..de29d11759 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -375,7 +375,7 @@ getExports env mn = -- checkImportConflicts :: forall m a - . (Show a, MonadError MultipleErrors m, MonadWriter MultipleErrors m, Ord a) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> (a -> Name) -> [ImportRecord a] diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index cf9bcf3abb..b210b00d03 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -117,8 +117,7 @@ resolveExports env ss mn imps exps refs = -- Extracts a list of values for a module based on a lookup table. If the -- boolean is true the values are filtered by the qualification extract - :: (Show a, Ord a) - => Bool + :: Bool -> ModuleName -> (a -> Name) -> M.Map (Qualified a) [ImportRecord a] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 8b56bd9709..95ffb95c80 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -53,7 +53,7 @@ addDataType moduleName dtype name args dctors ctorKind = do addDataConstructor moduleName dtype name (map fst args) dctor tys addDataConstructor - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m) => ModuleName -> DataDeclType -> ProperName 'TypeName @@ -71,7 +71,7 @@ addDataConstructor moduleName dtype name args dctor tys = do putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } addTypeSynonym - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m) => ModuleName -> ProperName 'TypeName -> [(String, Maybe Kind)] @@ -85,7 +85,7 @@ addTypeSynonym moduleName name args ty kind = do , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) } valueIsNotDefined - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m) => ModuleName -> Ident -> m () @@ -96,7 +96,7 @@ valueIsNotDefined moduleName name = do Nothing -> return () addValue - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m) => ModuleName -> Ident -> Type @@ -107,7 +107,7 @@ addValue moduleName name ty nameKind = do putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) }) addTypeClass - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m) => ModuleName -> ProperName 'ClassName -> [(String, Maybe Kind)] @@ -123,7 +123,7 @@ addTypeClass moduleName pn args implies ds = toPair _ = internalError "Invalid declaration in TypeClassDeclaration" addTypeClassDictionaries - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m) => Maybe ModuleName -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope) -> m () @@ -132,7 +132,7 @@ addTypeClassDictionaries mn entries = where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st) checkDuplicateTypeArguments - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m) => [String] -> m () checkDuplicateTypeArguments args = for_ firstDup $ \dup -> @@ -159,7 +159,7 @@ checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty -- Check that type synonyms are fully-applied in a type -- checkTypeSynonyms - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m) => Type -> m () checkTypeSynonyms = void . replaceAllTypeSynonyms diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs index 0267da990b..850ae129ec 100644 --- a/src/Language/PureScript/TypeChecker/Rows.hs +++ b/src/Language/PureScript/TypeChecker/Rows.hs @@ -9,17 +9,15 @@ import Prelude.Compat import Control.Monad import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State.Class (MonadState(..)) import Data.List import Language.PureScript.AST import Language.PureScript.Errors -import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types -- | Ensure rows do not contain duplicate labels -checkDuplicateLabels :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m () +checkDuplicateLabels :: forall m. (MonadError MultipleErrors m) => Expr -> m () checkDuplicateLabels = let (_, f, _) = everywhereOnValuesM def go def in void . f diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 603b902430..62d61089ad 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -89,7 +89,7 @@ skolemizeTypesInValue ident sko scope ss = -- | -- Ensure skolem variables do not escape their scope -- -skolemEscapeCheck :: (MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m () +skolemEscapeCheck :: (MonadError MultipleErrors m) => Expr -> m () skolemEscapeCheck (TypedValue False _ _) = return () skolemEscapeCheck root@TypedValue{} = -- Every skolem variable is created when a ForAll type is skolemized. diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index c24b62d122..e405537293 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -133,7 +133,7 @@ type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) type UntypedData = [(Ident, Type)] typeDictionaryForBindingGroup :: - (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + (MonadState CheckState m) => ModuleName -> [(Ident, Expr)] -> m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData) @@ -206,7 +206,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' -- | Check the kind of a type, failing if it is not of kind *. checkTypeKind :: - (MonadState CheckState m, MonadError MultipleErrors m) => + (MonadError MultipleErrors m) => Type -> Kind -> m () diff --git a/stack-ghc-8.0.yaml b/stack-ghc-8.0.yaml new file mode 100644 index 0000000000..f131e996b3 --- /dev/null +++ b/stack-ghc-8.0.yaml @@ -0,0 +1,5 @@ +resolver: nightly-2016-05-29 +packages: +- '.' +extra-deps: +- pipes-http-1.0.2 diff --git a/stack.yaml b/stack.yaml index 5a35886122..304ee4c265 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,8 +1,5 @@ -resolver: lts-5.4 +resolver: lts-6.1 packages: - '.' -extra-deps: -- bower-json-0.8.0 -- language-javascript-0.6.0.4 -- parsec-3.1.11 +extra-deps: [] flags: {} diff --git a/travis/build.sh b/travis/build.sh index ea54ba3fcd..63ddb620b9 100755 --- a/travis/build.sh +++ b/travis/build.sh @@ -45,7 +45,7 @@ then elif [ "$BUILD_TYPE" = "haddock" ] then echo ">>> Checking haddock documentation..." - $STACK haddock + $STACK haddock --fast else echo "Unrecognised BUILD_TYPE: $BUILD_TYPE" exit 1 From 38885b8f9263ce2fb2e7909736336693cf2c5dd2 Mon Sep 17 00:00:00 2001 From: Felix Yan Date: Fri, 10 Jun 2016 02:42:15 -0500 Subject: [PATCH 0450/1580] Allow pipes 4.2 purescript builds fine with pipes 4.2.0 here, and appears to work correctly. --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index eceddd6f03..62ec0354b9 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -122,7 +122,7 @@ library parallel >= 3.2 && < 3.3, parsec >=3.1.10, pattern-arrows >= 0.0.2 && < 0.1, - pipes >= 4.0.0 && < 4.2.0, + pipes >= 4.0.0 && < 4.3.0, pipes-http -any, process >= 1.2.0 && < 1.5, regex-tdfa -any, From 34f5238cc4cffeae98321b2df9b13f979ff61b79 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 10 Jun 2016 14:32:44 +0100 Subject: [PATCH 0451/1580] Elaborate re-exports --- src/Language/PureScript/AST/Declarations.hs | 18 ++++--- src/Language/PureScript/Errors.hs | 47 +++++++++++------ src/Language/PureScript/Interactive.hs | 33 +++++++----- src/Language/PureScript/Sugar/Names.hs | 51 ++++++++++--------- .../PureScript/Sugar/Names/Imports.hs | 3 +- 5 files changed, 94 insertions(+), 58 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 0f6df99c92..9dee9d413d 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -80,19 +80,25 @@ data DeclarationRef -- | ModuleRef ModuleName -- | + -- A value re-exported from another module. These will be inserted during + -- elaboration in name desugaring. + -- + | ReExportRef ModuleName DeclarationRef + -- | -- A declaration reference with source position information -- | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef deriving (Show, Read) instance Eq DeclarationRef where - (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors' - (TypeOpRef name) == (TypeOpRef name') = name == name' - (ValueRef name) == (ValueRef name') = name == name' - (ValueOpRef name) == (ValueOpRef name') = name == name' - (TypeClassRef name) == (TypeClassRef name') = name == name' + (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors' + (TypeOpRef name) == (TypeOpRef name') = name == name' + (ValueRef name) == (ValueRef name') = name == name' + (ValueOpRef name) == (ValueOpRef name') = name == name' + (TypeClassRef name) == (TypeClassRef name') = name == name' (TypeInstanceRef name) == (TypeInstanceRef name') = name == name' - (ModuleRef name) == (ModuleRef name') = name == name' + (ModuleRef name) == (ModuleRef name') = name == name' + (ReExportRef mn ref) == (ReExportRef mn' ref') = mn == mn' && ref == ref' (PositionedDeclarationRef _ _ r) == r' = r == r' r == (PositionedDeclarationRef _ _ r') = r == r' _ == _ = False diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index c5598f3ecf..7b5161d84d 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -15,7 +15,7 @@ import Data.Char (isSpace) import Data.Either (lefts, rights) import Data.Foldable (fold) import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition) -import Data.Maybe (maybeToList) +import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import Data.Ord (comparing) import qualified Data.Map as M @@ -422,7 +422,7 @@ errorSuggestion err = case err of importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String importSuggestion mn refs qual = - "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" ++ qstr qual + "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")" ++ qstr qual qstr :: Maybe ModuleName -> String qstr (Just mn) = " as " ++ runModuleName mn @@ -1159,27 +1159,42 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS -- Pretty print and export declaration prettyPrintExport :: DeclarationRef -> String prettyPrintExport (TypeRef pn _) = runProperName pn -prettyPrintExport ref = prettyPrintRef ref +prettyPrintExport ref = + fromMaybe + (internalError "prettyPrintRef returned Nothing in prettyPrintExport") + (prettyPrintRef ref) prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String prettyPrintImport mn idt qual = let i = case idt of Implicit -> runModuleName mn - Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (map prettyPrintRef refs) ++ ")" - Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (map prettyPrintRef refs) ++ ")" + Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")" + Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (mapMaybe prettyPrintRef refs) ++ ")" in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual -prettyPrintRef :: DeclarationRef -> String -prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)" -prettyPrintRef (TypeRef pn (Just [])) = runProperName pn -prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")" -prettyPrintRef (TypeOpRef op) = "type " ++ showOp op -prettyPrintRef (ValueRef ident) = showIdent ident -prettyPrintRef (ValueOpRef op) = showOp op -prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn -prettyPrintRef (TypeInstanceRef ident) = showIdent ident -prettyPrintRef (ModuleRef name) = "module " ++ runModuleName name -prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref +prettyPrintRef :: DeclarationRef -> Maybe String +prettyPrintRef (TypeRef pn Nothing) = + Just $ runProperName pn ++ "(..)" +prettyPrintRef (TypeRef pn (Just [])) = + Just $ runProperName pn +prettyPrintRef (TypeRef pn (Just dctors)) = + Just $ runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")" +prettyPrintRef (TypeOpRef op) = + Just $ "type " ++ showOp op +prettyPrintRef (ValueRef ident) = + Just $ showIdent ident +prettyPrintRef (ValueOpRef op) = + Just $ showOp op +prettyPrintRef (TypeClassRef pn) = + Just $ "class " ++ runProperName pn +prettyPrintRef (TypeInstanceRef ident) = + Just $ showIdent ident +prettyPrintRef (ModuleRef name) = + Just $ "module " ++ runModuleName name +prettyPrintRef (ReExportRef _ _) = + Nothing +prettyPrintRef (PositionedDeclarationRef _ _ ref) = + prettyPrintRef ref -- | -- Pretty print multiple errors diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 766099f3b7..9c7c6dd20a 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -1,8 +1,6 @@ {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE DataKinds #-} @@ -19,6 +17,7 @@ import Prelude () import Prelude.Compat import Data.List (intercalate, nub, sort, find, foldl') +import Data.Maybe (mapMaybe) import qualified Data.Map as M import Control.Monad.IO.Class (MonadIO, liftIO) @@ -188,17 +187,27 @@ handleShowImportedModules = do showDeclType P.Implicit = "" showDeclType (P.Explicit refs) = refsList refs showDeclType (P.Hiding refs) = " hiding " ++ refsList refs - refsList refs = " (" ++ commaList (map showRef refs) ++ ")" + refsList refs = " (" ++ commaList (mapMaybe showRef refs) ++ ")" - showRef :: P.DeclarationRef -> String - showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" - showRef (P.TypeOpRef op) = "type " ++ N.showOp op - showRef (P.ValueRef ident) = N.runIdent ident - showRef (P.ValueOpRef op) = N.showOp op - showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn - showRef (P.TypeInstanceRef ident) = N.runIdent ident - showRef (P.ModuleRef name) = "module " ++ N.runModuleName name - showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref + showRef :: P.DeclarationRef -> Maybe String + showRef (P.TypeRef pn dctors) = + Just $ N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" + showRef (P.TypeOpRef op) = + Just $ "type " ++ N.showOp op + showRef (P.ValueRef ident) = + Just $ N.runIdent ident + showRef (P.ValueOpRef op) = + Just $ N.showOp op + showRef (P.TypeClassRef pn) = + Just $ "class " ++ N.runProperName pn + showRef (P.TypeInstanceRef ident) = + Just $ N.runIdent ident + showRef (P.ModuleRef name) = + Just $ "module " ++ N.runModuleName name + showRef (P.ReExportRef _ _) = + Nothing + showRef (P.PositionedDeclarationRef _ _ ref) = + showRef ref commaList :: [String] -> String commaList = intercalate ", " diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index d8a8a788e1..1f33c01f56 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -10,7 +10,7 @@ module Language.PureScript.Sugar.Names import Prelude.Compat -import Control.Arrow (first, second) +import Control.Arrow (first) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Lazy @@ -84,16 +84,19 @@ desugarImportsWithEnv externs modules = do toExportedType _ = Nothing exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName - exportedTypeOps = M.fromList $ (, efModuleName) <$> mapMaybe getTypeOpRef efExports + exportedTypeOps = exportedRefs getTypeOpRef exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName - exportedTypeClasses = M.fromList $ (, efModuleName) <$> mapMaybe getTypeClassRef efExports + exportedTypeClasses = exportedRefs getTypeClassRef exportedValues :: M.Map Ident ModuleName - exportedValues = M.fromList $ (, efModuleName) <$> mapMaybe getValueRef efExports + exportedValues = exportedRefs getValueRef exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName - exportedValueOps = M.fromList $ (, efModuleName) <$> mapMaybe getValueOpRef efExports + exportedValueOps = exportedRefs getValueOpRef + + exportedRefs :: Ord a => (DeclarationRef -> Maybe a) -> M.Map a ModuleName + exportedRefs f = M.fromList $ (, efModuleName) <$> mapMaybe f efExports updateEnv :: ([Module], Env) -> Module -> m ([Module], Env) updateEnv (ms, env) m@(Module ss _ mn _ refs) = @@ -110,9 +113,10 @@ desugarImportsWithEnv externs modules = do renameInModule' env m@(Module _ _ mn _ _) = warnAndRethrow (addHint (ErrorInModule mn)) $ do let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env - (m', used) <- flip runStateT M.empty $ renameInModule imps (elaborateExports exps m) - lintImports m' env used - return m' + (m', used) <- flip runStateT M.empty $ renameInModule imps m + let m'' = elaborateExports exps m' + lintImports m'' env used + return m'' -- | -- Make all exports for a module explicit. This may still effect modules that @@ -121,24 +125,25 @@ desugarImportsWithEnv externs modules = do -- elaborateExports :: Exports -> Module -> Module elaborateExports exps (Module ss coms mn decls refs) = - Module ss coms mn decls $ - Just $ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) myTypes ++ - map TypeOpRef (my exportedTypeOps) ++ - map TypeClassRef (my exportedTypeClasses) ++ - map ValueRef (my exportedValues) ++ - map ValueOpRef (my exportedValueOps) ++ - maybe [] (filter isModuleRef) refs + Module ss coms mn decls $ Just + $ elaboratedTypeRefs + ++ go TypeOpRef exportedTypeOps + ++ go TypeClassRef exportedTypeClasses + ++ go ValueRef exportedValues + ++ go ValueOpRef exportedValueOps + ++ maybe [] (filter isModuleRef) refs where - -- Extracts a list of values from the exports and filters out any values that - -- are re-exports from other modules. - my :: (Exports -> M.Map a ModuleName) -> [a] - my = map fst <$> filt (== mn) - myTypes :: [(ProperName 'TypeName, [ProperName 'ConstructorName])] - myTypes = second fst <$> filt ((== mn) . snd) exportedTypes + elaboratedTypeRefs :: [DeclarationRef] + elaboratedTypeRefs = + flip map (M.toList (exportedTypes exps)) $ \(tctor, (dctors, mn')) -> + let ref = TypeRef tctor (Just dctors) + in if mn == mn' then ref else ReExportRef mn' ref - filt :: (b -> Bool) -> (Exports -> M.Map a b) -> [(a, b)] - filt predicate f = M.toList $ predicate `M.filter` f exps + go :: (a -> DeclarationRef) -> (Exports -> M.Map a ModuleName) -> [DeclarationRef] + go toRef select = + flip map (M.toList (select exps)) $ \(export, mn') -> + if mn == mn' then toRef export else ReExportRef mn' (toRef export) -- | -- Replaces all local names with qualified names within a module and checks that all existing diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index b8640a9466..616921b6d3 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -207,6 +207,7 @@ resolveImport importModule exps imps impQual = resolveByType return $ imp { importedTypeClasses = typeClasses' } importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef" importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef" + importRef _ _ ReExportRef{} = internalError "ReExportRef in importRef" -- Find all exported data constructors for a given type allExportedDataConstructors @@ -218,7 +219,7 @@ resolveImport importModule exps imps impQual = resolveByType -- Add something to an import resolution list updateImports - :: (Ord a) + :: Ord a => M.Map (Qualified a) [ImportRecord a] -> M.Map a b -> (b -> ModuleName) From 65863a96061faf7f9fe0396090c40cb452c158f8 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 14 Jun 2016 09:28:30 -0600 Subject: [PATCH 0452/1580] Include position info in ScopeShadowing warning --- src/Language/PureScript/Sugar/Names.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 665c51c02e..dc200d290c 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -329,5 +329,5 @@ renameInModule imports (Module ss coms mn decls exps) = _ -> throwUnknown where - positioned err = maybe err (`rethrowWithPosition` err) pos + positioned err = maybe err (`warnAndRethrowWithPosition` err) pos throwUnknown = throwError . errorMessage . UnknownName . fmap toName $ qname From a07a71430adae0f7b3801b8ce3fea54bf5fccdbb Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 5 Jun 2016 19:02:26 +0200 Subject: [PATCH 0453/1580] [psc-ide] Multi phase load --- psc-ide-server/Main.hs | 22 +- psc-ide-server/PROTOCOL.md | 10 +- purescript.cabal | 23 +- src/Language/PureScript/Ide.hs | 206 +++++++---------- src/Language/PureScript/Ide/CaseSplit.hs | 23 +- src/Language/PureScript/Ide/Command.hs | 15 +- src/Language/PureScript/Ide/Completion.hs | 9 +- src/Language/PureScript/Ide/Conversions.hs | 36 +++ src/Language/PureScript/Ide/Externs.hs | 36 ++- src/Language/PureScript/Ide/Filter.hs | 47 +--- src/Language/PureScript/Ide/Imports.hs | 34 +-- src/Language/PureScript/Ide/Matcher.hs | 4 +- src/Language/PureScript/Ide/Rebuild.hs | 10 +- src/Language/PureScript/Ide/Reexports.hs | 29 ++- src/Language/PureScript/Ide/State.hs | 209 +++++++++++------- src/Language/PureScript/Ide/Types.hs | 84 ++++--- src/Language/PureScript/Ide/Util.hs | 77 +++---- src/Language/PureScript/Ide/Watcher.hs | 8 +- src/Language/PureScript/Publish.hs | 1 + tests/Language/PureScript/Ide/FilterSpec.hs | 31 +-- .../PureScript/Ide/Imports/IntegrationSpec.hs | 33 +-- tests/Language/PureScript/Ide/ImportsSpec.hs | 6 +- tests/Language/PureScript/Ide/Integration.hs | 18 +- tests/Language/PureScript/Ide/MatcherSpec.hs | 14 +- tests/Language/PureScript/Ide/RebuildSpec.hs | 8 +- .../Language/PureScript/Ide/ReexportsSpec.hs | 14 +- tests/Language/PureScript/IdeSpec.hs | 35 --- tests/support/pscide/src/ImportsSpec.purs | 4 +- .../src/{Main.purs => MatcherSpec.purs} | 2 +- .../pscide/src/RebuildSpecSingleModule.purs | 2 +- 30 files changed, 521 insertions(+), 529 deletions(-) create mode 100644 src/Language/PureScript/Ide/Conversions.hs delete mode 100644 tests/Language/PureScript/IdeSpec.hs rename tests/support/pscide/src/{Main.purs => MatcherSpec.purs} (76%) diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index e7fbdca2ec..25014f7ff0 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -81,21 +81,21 @@ main = do Options dir outputPath port noWatch debug <- execParser opts maybe (pure ()) setCurrentDirectory dir serverState <- newTVarIO emptyPscIdeState + ideState <- newTVarIO emptyIdeState cwd <- getCurrentDirectory let fullOutputPath = cwd outputPath - doesDirectoryExist fullOutputPath - >>= flip unless - (do putStrLn ("Your output directory didn't exist. I'll create it at: " <> fullOutputPath) - createDirectory fullOutputPath - putStrLn "This usually means you didn't compile your project yet." - putStrLn "psc-ide needs you to compile your project (for example by running pulp build)") + unlessM (doesDirectoryExist fullOutputPath) $ do + putStrLn ("Your output directory didn't exist. I'll create it at: " <> fullOutputPath) + createDirectory fullOutputPath + putStrLn "This usually means you didn't compile your project yet." + putStrLn "psc-ide needs you to compile your project (for example by running pulp build)" unless noWatch $ - void (forkFinally (watcher serverState fullOutputPath) print) + void (forkFinally (watcher ideState fullOutputPath) print) let conf = Configuration {confDebug = debug, confOutputPath = outputPath} - env = PscIdeEnvironment {envStateVar = serverState, envConfiguration = conf} + env = IdeEnvironment {envStateVar = serverState, ideStateVar = ideState, ideConfiguration = conf} startServer port env where parser = @@ -111,14 +111,14 @@ main = do (InfoMsg (showVersion Paths.version)) (long "version" <> help "Show the version number") -startServer :: PortID -> PscIdeEnvironment -> IO () +startServer :: PortID -> IdeEnvironment -> IO () startServer port env = withSocketsDo $ do sock <- listenOnLocalhost port runLogger (runReaderT (forever (loop sock)) env) where - runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (envConfiguration env)) + runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (ideConfiguration env)) - loop :: (PscIde m, MonadLogger m) => Socket -> m () + loop :: (Ide m, MonadLogger m) => Socket -> m () loop sock = do accepted <- runExceptT $ acceptCommand sock case accepted of diff --git a/psc-ide-server/PROTOCOL.md b/psc-ide-server/PROTOCOL.md index 73998a3010..03528c95f9 100644 --- a/psc-ide-server/PROTOCOL.md +++ b/psc-ide-server/PROTOCOL.md @@ -14,24 +14,20 @@ to detect all the compiled modules in your project and load them. **Params:** - `modules :: (optional) [ModuleName]`: A list of modules to load. - psc-ide-server will try to parse all the declarations in these modules - - `dependencies :: (optional) [ModuleName]`: A list of modules to load - including their dependencies. In contrast to the `module` field, all the - imports in these Modules will also be loaded. + psc-ide-server will try to parse all the declarations in these modules ```json { "command": "load", "params": (optional) { - "modules": (optional)["Module.Name1", "Module.Name2"], - "dependencies": (optional)["Module.Name3"] + "modules": (optional)["Module.Name1", "Module.Name2"] } } ``` **Result:** -The Load Command returns a string. +The Load Command returns a string with a summary about the loading process. ### Type The `type` command looks up the type for a given identifier. diff --git a/purescript.cabal b/purescript.cabal index eceddd6f03..e597b61399 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -101,6 +101,7 @@ library aeson >= 0.8 && < 0.12, aeson-better-errors >= 0.8, ansi-terminal >= 0.6.2 && < 0.7, + async, base-compat >=0.6.0, bower-json >= 0.8, boxes >= 0.1.4 && < 0.2.0, @@ -251,22 +252,23 @@ library Language.PureScript.Publish.BoxesHelpers Language.PureScript.Ide + Language.PureScript.Ide.CaseSplit Language.PureScript.Ide.Command + Language.PureScript.Ide.Completion + Language.PureScript.Ide.Conversions Language.PureScript.Ide.Externs Language.PureScript.Ide.Error - Language.PureScript.Ide.Pursuit - Language.PureScript.Ide.Completion - Language.PureScript.Ide.Matcher + Language.PureScript.Ide.Imports Language.PureScript.Ide.Filter - Language.PureScript.Ide.Types - Language.PureScript.Ide.State - Language.PureScript.Ide.CaseSplit - Language.PureScript.Ide.SourceFile - Language.PureScript.Ide.Watcher + Language.PureScript.Ide.Matcher + Language.PureScript.Ide.Pursuit + Language.PureScript.Ide.Rebuild Language.PureScript.Ide.Reexports - Language.PureScript.Ide.Imports + Language.PureScript.Ide.SourceFile + Language.PureScript.Ide.State + Language.PureScript.Ide.Types Language.PureScript.Ide.Util - Language.PureScript.Ide.Rebuild + Language.PureScript.Ide.Watcher Language.PureScript.Interactive Language.PureScript.Interactive.Types @@ -498,6 +500,5 @@ test-suite tests Language.PureScript.Ide.MatcherSpec Language.PureScript.Ide.RebuildSpec Language.PureScript.Ide.ReexportsSpec - Language.PureScript.IdeSpec buildable: True hs-source-dirs: tests diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 590bdb9cf5..e2c32aed5b 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -14,7 +14,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Ide ( handleCommand @@ -25,14 +24,13 @@ module Language.PureScript.Ide import Prelude () import Prelude.Compat -import Control.Monad (unless) +import Control.Concurrent.Async import Control.Monad.Error.Class import Control.Monad.IO.Class import "monad-logger" Control.Monad.Logger -import Control.Monad.Reader.Class +import Control.Monad.Reader import Data.Foldable -import qualified Data.Map.Lazy as M -import Data.Maybe (catMaybes, mapMaybe) +import Data.Maybe (catMaybes) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T @@ -47,7 +45,6 @@ import Language.PureScript.Ide.Imports hiding (Import) import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Pursuit import Language.PureScript.Ide.Rebuild -import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.State import Language.PureScript.Ide.Types @@ -56,11 +53,10 @@ import System.Directory import System.Exit import System.FilePath -handleCommand :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => +handleCommand :: (Ide m, MonadLogger m, MonadError PscIdeError m) => Command -> m Success -handleCommand (Load [] []) = loadAllModules -handleCommand (Load modules deps) = - loadModulesAndDeps modules deps +handleCommand (Load []) = loadAllModules +handleCommand (Load modules) = loadModules modules handleCommand (Type search filters currentModule) = findType search filters currentModule handleCommand (Complete filters matcher currentModule) = @@ -78,7 +74,7 @@ handleCommand (List (Imports fp)) = handleCommand (CaseSplit l b e wca t) = caseSplit l b e wca t handleCommand (AddClause l wca) = - pure $ addClause l wca + addClause l wca handleCommand (Import fp outfp _ (AddImplicitImport mn)) = do rs <- addImplicitImport fp mn answerRequest outfp rs @@ -86,25 +82,25 @@ handleCommand (Import fp outfp filters (AddImportForIdentifier ident)) = do rs <- addImportForIdentifier fp ident filters case rs of Right rs' -> answerRequest outfp rs' - Left question -> pure $ CompletionResult (mapMaybe completionFromMatch question) + Left question -> pure $ CompletionResult (map completionFromMatch question) handleCommand (Rebuild file) = rebuildFile file handleCommand Cwd = TextResult . T.pack <$> liftIO getCurrentDirectory -handleCommand Reset = resetPscIdeState *> pure (TextResult "State has been reset.") +handleCommand Reset = resetIdeState *> pure (TextResult "State has been reset.") handleCommand Quit = liftIO exitSuccess -findCompletions :: (PscIde m) => +findCompletions :: (Ide m) => [Filter] -> Matcher -> Maybe P.ModuleName -> m Success findCompletions filters matcher currentModule = do - modules <- getAllModulesWithReexportsAndCache currentModule - pure . CompletionResult . mapMaybe completionFromMatch . getCompletions filters matcher $ modules + modules <- getAllModules2 currentModule + pure . CompletionResult . map completionFromMatch . getCompletions filters matcher $ modules -findType :: (PscIde m) => - DeclIdent -> [Filter] -> Maybe P.ModuleName -> m Success +findType :: (Ide m) => + Text -> [Filter] -> Maybe P.ModuleName -> m Success findType search filters currentModule = do - modules <- getAllModulesWithReexportsAndCache currentModule - pure . CompletionResult . mapMaybe completionFromMatch . getExactMatches search filters $ modules + modules <- getAllModules2 currentModule + pure . CompletionResult . map completionFromMatch . getExactMatches search filters $ modules findPursuitCompletions :: (MonadIO m) => PursuitQuery -> m Success @@ -116,39 +112,35 @@ findPursuitPackages :: (MonadIO m) => findPursuitPackages (PursuitQuery q) = PursuitResult <$> liftIO (findPackagesForModuleIdent q) -loadExtern :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => - FilePath -> m () -loadExtern fp = do - m <- readExternFile fp - insertModule m +printModules :: (Ide m) => m Success +printModules = ModuleList . map runModuleNameT <$> getLoadedModulenames -printModules :: (PscIde m) => m Success -printModules = printModules' . pscIdeStateModules <$> getPscIdeState - -printModules' :: M.Map ModuleIdent [ExternDecl] -> Success -printModules' = ModuleList . M.keys +outputDirectory :: Ide m => m FilePath +outputDirectory = do + outputPath <- confOutputPath . ideConfiguration <$> ask + cwd <- liftIO getCurrentDirectory + pure (cwd outputPath) -listAvailableModules :: PscIde m => m Success +listAvailableModules :: Ide m => m Success listAvailableModules = do - outputPath <- confOutputPath . envConfiguration <$> ask + oDir <- outputDirectory liftIO $ do - cwd <- getCurrentDirectory - dirs <- getDirectoryContents (cwd outputPath) - return (ModuleList (listAvailableModules' dirs)) - -listAvailableModules' :: [FilePath] -> [Text] -listAvailableModules' dirs = - let cleanedModules = filter (`notElem` [".", ".."]) dirs - in map T.pack cleanedModules + contents <- getDirectoryContents oDir + let cleaned = filter (`notElem` [".", ".."]) contents + return (ModuleList (map T.pack cleaned)) -caseSplit :: (PscIde m, MonadError PscIdeError m) => +caseSplit :: (Ide m, MonadError PscIdeError m) => Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success caseSplit l b e csa t = do patterns <- CS.makePattern l b e csa <$> CS.caseSplit t pure (MultilineTextResult patterns) -addClause :: Text -> CS.WildcardAnnotations -> Success -addClause t wca = MultilineTextResult (CS.addClause t wca) +addClause + :: (MonadError PscIdeError m) + => Text + -> CS.WildcardAnnotations + -> m Success +addClause t wca = MultilineTextResult <$> CS.addClause t wca importsForFile :: (MonadIO m, MonadError PscIdeError m) => FilePath -> m Success @@ -156,90 +148,48 @@ importsForFile fp = do imports <- getImportsForFile fp pure (ImportList imports) --- | The first argument is a set of modules to load. The second argument --- denotes modules for which to load dependencies -loadModulesAndDeps :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => - [ModuleIdent] -> [ModuleIdent] -> m Success -loadModulesAndDeps mods deps = do - r1 <- mapM loadModule (mods ++ deps) - r2 <- mapM loadModuleDependencies deps - let moduleResults = T.concat r1 - let dependencyResults = T.concat r2 - pure (TextResult (moduleResults <> ", " <> dependencyResults)) - -loadModuleDependencies ::(PscIde m, MonadLogger m, MonadError PscIdeError m) => - ModuleIdent -> m Text -loadModuleDependencies moduleName = do - m <- getModule moduleName - case getDependenciesForModule <$> m of - Just deps -> do - mapM_ loadModule deps - -- We need to load the modules, that get reexported from the dependencies - depModules <- catMaybes <$> mapM getModule deps - -- What to do with errors here? This basically means a reexported dependency - -- doesn't exist in the output/ folder - traverse_ loadReexports depModules - pure ("Dependencies for " <> moduleName <> " loaded.") - Nothing -> throwError (ModuleNotFound moduleName) - -loadReexports :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => - Module -> m [ModuleIdent] -loadReexports m = case getReexports m of - [] -> pure [] - exportDeps -> do - -- I'm fine with this crashing on a failed pattern match. - -- If this ever fails I'll need to look at GADTs - let reexports = map (\(Export mn) -> mn) exportDeps - $(logDebug) ("Loading reexports for module: " <> fst m <> - " reexports: " <> T.intercalate ", " reexports) - traverse_ loadModule reexports - exportDepsModules <- catMaybes <$> traverse getModule reexports - exportDepDeps <- traverse loadReexports exportDepsModules - return $ concat exportDepDeps - -getDependenciesForModule :: Module -> [ModuleIdent] -getDependenciesForModule (_, decls) = mapMaybe getDependencyName decls - where getDependencyName (Dependency dependencyName _ _) = Just dependencyName - getDependencyName _ = Nothing - -loadModule :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => - ModuleIdent -> m Text -loadModule "Prim" = pure "Prim won't be loaded" -loadModule mn = do - path <- filePathFromModule mn - loadExtern path - $(logDebug) ("Loaded extern file at: " <> T.pack path) - pure ("Loaded extern file at: " <> T.pack path) - -loadAllModules :: (PscIde m, MonadLogger m, MonadError PscIdeError m) => m Success +-- | Takes the output directory and a filepath like "Monad.Control.Eff" and +-- looks up, whether that folder contains an externs.json +checkExternsPath :: FilePath -> FilePath -> IO (Maybe FilePath) +checkExternsPath oDir d + | d `elem` [".", ".."] = pure Nothing + | otherwise = do + let file = oDir d "externs.json" + ex <- doesFileExist file + if ex + then pure (Just file) + else pure Nothing + +findAllExterns :: (Ide m, MonadError PscIdeError m) => m [FilePath] +findAllExterns = do + oDir <- outputDirectory + unlessM (liftIO (doesDirectoryExist oDir)) + (throwError (GeneralError "Couldn't locate your output directory.")) + liftIO $ do + dirs <- getDirectoryContents oDir + externPaths <- traverse (checkExternsPath oDir) dirs + pure (catMaybes externPaths) + +loadModules + :: (Ide m, MonadError PscIdeError m, MonadLogger m) + => [P.ModuleName] + -> m Success +loadModules mns = do + oDir <- outputDirectory + let efPaths = map (\mn -> oDir P.runModuleName mn "externs.json") mns + efiles <- traverse readExternFile efPaths + traverse_ insertExterns efiles + --TODO Get rid of this once ModuleOld is gone + traverse_ insertModule efiles + populateStage2 + pure (TextResult ("Loaded " <> foldMap runModuleNameT mns <> ".")) + +loadAllModules :: (Ide m, MonadError PscIdeError m) => m Success loadAllModules = do - outputPath <- confOutputPath . envConfiguration <$> ask - cwd <- liftIO getCurrentDirectory - let outputDirectory = cwd outputPath - liftIO (doesDirectoryExist outputDirectory) - >>= flip unless (throwError (GeneralError "Couldn't locate your output directory")) - liftIO (getDirectoryContents outputDirectory) - >>= liftIO . traverse (getExternsPath outputDirectory) - >>= traverse_ loadExtern . catMaybes + exts <- traverse readExternFile =<< findAllExterns + traverse_ insertExterns exts + --TODO Get rid of this once ModuleOld is gone + traverse_ insertModule exts + env <- ask + _ <- liftIO $ async (runStdoutLoggingT (runReaderT populateStage2 env)) pure (TextResult "All modules loaded.") - where - getExternsPath :: FilePath -> FilePath -> IO (Maybe FilePath) - getExternsPath outputDirectory d - | d `elem` [".", ".."] = pure Nothing - | otherwise = do - let file = outputDirectory d "externs.json" - ex <- doesFileExist file - if ex - then pure (Just file) - else pure Nothing - -filePathFromModule :: (PscIde m, MonadError PscIdeError m) => - ModuleIdent -> m FilePath -filePathFromModule moduleName = do - outputPath <- confOutputPath . envConfiguration <$> ask - cwd <- liftIO getCurrentDirectory - let path = cwd outputPath T.unpack moduleName "externs.json" - ex <- liftIO $ doesFileExist path - if ex - then pure path - else throwError (ModuleFileNotFound moduleName) diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 4c73235e34..e318cdc603 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -53,7 +53,7 @@ explicitAnnotations = WildcardAnnotations True noAnnotations :: WildcardAnnotations noAnnotations = WildcardAnnotations False -caseSplit :: (PscIde m, MonadError PscIdeError m) => +caseSplit :: (Ide m, MonadError PscIdeError m) => Text -> m [Constructor] caseSplit q = do type' <- parseType' (T.unpack q) @@ -63,7 +63,7 @@ caseSplit q = do let appliedCtors = map (second (map applyTypeVars)) ctors pure appliedCtors -findTypeDeclaration :: (PscIde m, MonadError PscIdeError m) => +findTypeDeclaration :: (Ide m, MonadError PscIdeError m) => P.ProperName 'P.TypeName -> m ExternsDeclaration findTypeDeclaration q = do efs <- getExternFiles @@ -113,14 +113,14 @@ makePattern t x y wsa = makePattern' (T.take x t) (T.drop y t) where makePattern' lhs rhs = map (\ctor -> lhs <> prettyCtor wsa ctor <> rhs) -addClause :: Text -> WildcardAnnotations -> [Text] -addClause s wca = - let (fName, fType) = parseTypeDeclaration' (T.unpack s) - (args, _) = splitFunctionType fType +addClause :: (MonadError PscIdeError m) => Text -> WildcardAnnotations -> m [Text] +addClause s wca = do + (fName, fType) <- parseTypeDeclaration' (T.unpack s) + let (args, _) = splitFunctionType fType template = runIdentT fName <> " " <> T.unwords (map (prettyPrintWildcard wca) args) <> " = ?" <> (T.strip . runIdentT $ fName) - in [s, template] + pure [s, template] parseType' :: (MonadError PscIdeError m) => String -> m P.Type @@ -131,15 +131,18 @@ parseType' s = throwError (GeneralError ("Parsing the splittype failed with:" ++ show err)) -parseTypeDeclaration' :: String -> (P.Ident, P.Type) +parseTypeDeclaration' :: (MonadError PscIdeError m) => String -> m (P.Ident, P.Type) parseTypeDeclaration' s = let x = do ts <- P.lex "" s P.runTokenParser "" (P.parseDeclaration <* Parsec.eof) ts in case unwrapPositioned <$> x of - Right (P.TypeDeclaration i t) -> (i, t) - y -> error (show y) + Right (P.TypeDeclaration i t) -> pure (i, t) + Right _ -> throwError (GeneralError "Found a non-type-declaration") + Left err -> + throwError (GeneralError ("Parsing the typesignature failed with: " + ++ show err)) splitFunctionType :: P.Type -> ([P.Type], P.Type) splitFunctionType t = (arguments, returns) diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 8f405a8edc..6fb0e5cc17 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -29,12 +29,9 @@ import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types data Command - = Load - { loadModules :: [ModuleIdent] - , loadDependencies :: [ModuleIdent] - } + = Load [P.ModuleName] | Type - { typeSearch :: DeclIdent + { typeSearch :: Text , typeFilters :: [Filter] , typeCurrentModule :: Maybe P.ModuleName } @@ -68,7 +65,7 @@ data Command data ImportCommand = AddImplicitImport P.ModuleName - | AddImportForIdentifier DeclIdent + | AddImportForIdentifier Text deriving (Show, Eq) instance FromJSON ImportCommand where @@ -103,11 +100,9 @@ instance FromJSON Command where "load" -> do params' <- o .:? "params" case params' of - Nothing -> pure (Load [] []) + Nothing -> pure (Load []) Just params -> - Load - <$> params .:? "modules" .!= [] - <*> params .:? "dependencies" .!= [] + Load <$> (map P.moduleNameFromString <$> params .:? "modules" .!= []) "type" -> do params <- o .: "params" Type diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index f120c6fe30..54a04a3422 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -6,7 +6,7 @@ module Language.PureScript.Ide.Completion import Prelude () import Prelude.Compat -import Data.Maybe (mapMaybe) +import Data.Text (Text) import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types @@ -17,7 +17,7 @@ getCompletions :: [Filter] -> Matcher -> [Module] -> [Match] getCompletions filters matcher modules = runMatcher matcher $ completionsFromModules (applyFilters filters modules) -getExactMatches :: DeclIdent -> [Filter] -> [Module] -> [Match] +getExactMatches :: Text -> [Filter] -> [Module] -> [Match] getExactMatches search filters modules = completionsFromModules $ applyFilters (equalityFilter search : filters) modules @@ -26,7 +26,4 @@ completionsFromModules :: [Module] -> [Match] completionsFromModules = foldMap completionFromModule where completionFromModule :: Module -> [Match] - completionFromModule (moduleIdent, decls) = mapMaybe (matchFromDecl moduleIdent) decls - -matchFromDecl :: ModuleIdent -> ExternDecl -> Maybe Match -matchFromDecl mi = Just . Match mi + completionFromModule (moduleName, decls) = map (Match moduleName) decls diff --git a/src/Language/PureScript/Ide/Conversions.hs b/src/Language/PureScript/Ide/Conversions.hs new file mode 100644 index 0000000000..95a110836c --- /dev/null +++ b/src/Language/PureScript/Ide/Conversions.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Ide.Conversions +-- Description : Conversions to Text for PureScript types +-- Copyright : Christoph Hegemann 2016 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Christoph Hegemann +-- Stability : experimental +-- +-- | +-- Conversions to Text for PureScript types +----------------------------------------------------------------------------- + +module Language.PureScript.Ide.Conversions where + +import Prelude.Compat +import Data.Text (Text) +import qualified Data.Text as T +import qualified Language.PureScript as P + +runProperNameT :: P.ProperName a -> Text +runProperNameT = T.pack . P.runProperName + +runIdentT :: P.Ident -> Text +runIdentT = T.pack . P.runIdent + +runOpNameT :: P.OpName a -> Text +runOpNameT = T.pack . P.runOpName + +runModuleNameT :: P.ModuleName -> Text +runModuleNameT = T.pack . P.runModuleName + +prettyTypeT :: P.Type -> Text +prettyTypeT = T.unwords . fmap T.strip . T.lines . T.pack . P.prettyPrintType + diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index bf3e6bd509..5cdf718dd7 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -12,14 +12,16 @@ -- Handles externs files for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} module Language.PureScript.Ide.Externs ( ExternDecl(..), ModuleIdent, - DeclIdent, readExternFile, convertExterns, + convertModule, unwrapPositioned, unwrapPositionedRef ) where @@ -50,16 +52,13 @@ readExternFile fp = do Nothing -> throwError . GeneralError $ "Parsing the extern at: " ++ fp ++ " failed" Just externs -> pure externs -moduleNameToText :: P.ModuleName -> Text -moduleNameToText = T.pack . P.runModuleName - identToText :: P.Ident -> Text identToText = T.pack . P.runIdent -convertExterns :: P.ExternsFile -> Module -convertExterns ef = (moduleName, exportDecls ++ importDecls ++ decls ++ operatorDecls ++ tyOperatorDecls) +convertExterns :: P.ExternsFile -> ModuleOld +convertExterns ef = (runModuleNameT moduleName, exportDecls ++ importDecls ++ decls ++ operatorDecls ++ tyOperatorDecls) where - moduleName = moduleNameToText (P.efModuleName ef) + moduleName = P.efModuleName ef importDecls = convertImport <$> P.efImports ef exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (P.efExports ef) operatorDecls = convertOperator <$> P.efFixities ef @@ -82,12 +81,12 @@ isTypeClassDeclaration _ = False convertImport :: P.ExternsImport -> ExternDecl convertImport ei = Dependency - (moduleNameToText (P.eiModule ei)) + (runModuleNameT (P.eiModule ei)) [] - (moduleNameToText <$> P.eiImportedAs ei) + (runModuleNameT <$> P.eiImportedAs ei) convertExport :: P.DeclarationRef -> Maybe ExternDecl -convertExport (P.ModuleRef mn) = Just (Export (moduleNameToText mn)) +convertExport (P.ModuleRef mn) = Just (Export (runModuleNameT mn)) convertExport _ = Nothing convertDecl :: P.ExternsDeclaration -> Maybe ExternDecl @@ -124,3 +123,18 @@ unwrapPositioned x = x unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = x unwrapPositionedRef x = x + +convertModule :: ModuleOld -> Module +convertModule (mn, decls) = (P.moduleNameFromString (T.unpack mn), mapMaybe convertDeclaration decls) + where convertDeclaration :: ExternDecl -> Maybe IdeDeclaration + convertDeclaration d = case d of + ValueDeclaration i t -> Just (IdeValue i t) + TypeDeclaration i k -> Just (IdeType i k) + TypeSynonymDeclaration i t -> Just (IdeTypeSynonym i t) + DataConstructor i tn t -> Just (IdeDataConstructor i tn t) + TypeClassDeclaration i -> Just (IdeTypeClass i) + ValueOperator n i p a -> Just (IdeValueOperator n i p a) + TypeOperator n i p a -> Just (IdeTypeOperator n i p a) + Dependency{} -> Nothing + ModuleDecl _ _ -> Nothing + Export _ -> Nothing diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index c1c91cbb17..630a0039e8 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -20,7 +20,6 @@ module Language.PureScript.Ide.Filter , moduleFilter , prefixFilter , equalityFilter - , dependencyFilter , runFilter , applyFilters ) where @@ -31,11 +30,11 @@ import Prelude.Compat import Control.Monad import Data.Aeson import Data.Foldable -import Data.Maybe (listToMaybe, mapMaybe) import Data.Monoid import Data.Text (Text, isPrefixOf) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import qualified Language.PureScript as P newtype Filter = Filter (Endo [Module]) deriving(Monoid) @@ -43,53 +42,29 @@ mkFilter :: ([Module] -> [Module]) -> Filter mkFilter = Filter . Endo -- | Only keeps the given Modules -moduleFilter :: [ModuleIdent] -> Filter +moduleFilter :: [P.ModuleName] -> Filter moduleFilter = mkFilter . moduleFilter' -moduleFilter' :: [ModuleIdent] -> [Module] -> [Module] +moduleFilter' :: [P.ModuleName] -> [Module] -> [Module] moduleFilter' moduleIdents = filter (flip elem moduleIdents . fst) --- | Only keeps the given Modules and all of their dependencies -dependencyFilter :: [ModuleIdent] -> Filter -dependencyFilter = mkFilter . dependencyFilter' - -dependencyFilter' :: [ModuleIdent] -> [Module] -> [Module] -dependencyFilter' moduleIdents mods = - moduleFilter' (concatMap (getDepForModule mods) moduleIdents) mods - where - getDepForModule :: [Module] -> ModuleIdent -> [ModuleIdent] - getDepForModule ms moduleIdent = - moduleIdent : maybe [] extractDeps (findModule moduleIdent ms) - - findModule :: ModuleIdent -> [Module] -> Maybe Module - findModule i ms = listToMaybe $ filter go ms - where go (mn, _) = i == mn - - extractDeps :: Module -> [ModuleIdent] - extractDeps = mapMaybe extractDep . snd - where extractDep (Dependency n _ _) = Just n - extractDep _ = Nothing - -- | Only keeps Identifiers that start with the given prefix prefixFilter :: Text -> Filter prefixFilter "" = mkFilter id prefixFilter t = mkFilter $ identFilter prefix t where - prefix :: ExternDecl -> Text -> Bool - prefix Export{} _ = False - prefix Dependency{} _ = False - prefix ed search = search `isPrefixOf` identifierFromExternDecl ed - + prefix :: IdeDeclaration -> Text -> Bool + prefix ed search = search `isPrefixOf` identifierFromIdeDeclaration ed -- | Only keeps Identifiers that are equal to the search string equalityFilter :: Text -> Filter equalityFilter = mkFilter . identFilter equality where - equality :: ExternDecl -> Text -> Bool - equality ed search = identifierFromExternDecl ed == search + equality :: IdeDeclaration -> Text -> Bool + equality ed search = identifierFromIdeDeclaration ed == search -identFilter :: (ExternDecl -> Text -> Bool ) -> Text -> [Module] -> [Module] +identFilter :: (IdeDeclaration -> Text -> Bool) -> Text -> [Module] -> [Module] identFilter predicate search = filter (not . null . snd) . fmap filterModuleDecls where @@ -117,10 +92,6 @@ instance FromJSON Filter where return $ prefixFilter search "modules" -> do params <- o .: "params" - modules <- params .: "modules" + modules <- map P.moduleNameFromString <$> params .: "modules" return $ moduleFilter modules - "dependencies" -> do - params <- o .: "params" - deps <- params .: "modules" - return $ dependencyFilter deps _ -> mzero diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index e7cbcd9c99..5ecbae2e78 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -181,7 +181,7 @@ addImplicitImport' imports mn = -- @import Prelude (bind)@ in the file File.purs returns @["import Prelude -- (bind, unit)"]@ addExplicitImport :: (MonadIO m, MonadError PscIdeError m) => - FilePath -> ExternDecl -> P.ModuleName -> m [Text] + FilePath -> IdeDeclaration -> P.ModuleName -> m [Text] addExplicitImport fp decl moduleName = do (mn, pre, imports, post) <- parseImportsFromFile fp let newImportSection = @@ -192,7 +192,7 @@ addExplicitImport fp decl moduleName = do else addExplicitImport' decl moduleName imports pure (pre ++ prettyPrintImportSection newImportSection ++ post) -addExplicitImport' :: ExternDecl -> P.ModuleName -> [Import] -> [Import] +addExplicitImport' :: IdeDeclaration -> P.ModuleName -> [Import] -> [Import] addExplicitImport' decl moduleName imports = let isImplicitlyImported = @@ -207,28 +207,28 @@ addExplicitImport' decl moduleName imports = then imports else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports where - refFromDeclaration (TypeClassDeclaration n) = + refFromDeclaration (IdeTypeClass n) = P.TypeClassRef n - refFromDeclaration (DataConstructor n tn _) = + refFromDeclaration (IdeDataConstructor n tn _) = P.TypeRef tn (Just [P.ProperName (T.unpack n)]) - refFromDeclaration (TypeDeclaration n _) = + refFromDeclaration (IdeType n _) = P.TypeRef n (Just []) - refFromDeclaration (ValueOperator op _ _ _) = + refFromDeclaration (IdeValueOperator op _ _ _) = P.ValueOpRef op - refFromDeclaration (TypeOperator op _ _ _) = + refFromDeclaration (IdeTypeOperator op _ _ _) = P.TypeOpRef op refFromDeclaration d = - P.ValueRef $ P.Ident $ T.unpack (identifierFromExternDecl d) + P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d) -- | Adds a declaration to an import: -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) - insertDeclIntoImport :: ExternDecl -> Import -> Import + insertDeclIntoImport :: IdeDeclaration -> Import -> Import insertDeclIntoImport decl' (Import mn (P.Explicit refs) Nothing) = Import mn (P.Explicit (insertDeclIntoRefs decl' refs)) Nothing insertDeclIntoImport _ is = is - insertDeclIntoRefs :: ExternDecl -> [P.DeclarationRef] -> [P.DeclarationRef] - insertDeclIntoRefs (DataConstructor dtor tn _) refs = + insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef] + insertDeclIntoRefs (IdeDataConstructor dtor tn _) refs = let dtor' = P.ProperName (T.unpack dtor) in @@ -263,14 +263,14 @@ updateAtFirstOrPrepend p t d l = -- -- * If more than one possible imports are found, reports the possibilities as a -- list of completions. -addImportForIdentifier :: (PscIde m, MonadError PscIdeError m) +addImportForIdentifier :: (Ide m, MonadError PscIdeError m) => FilePath -- ^ The Sourcefile to read from -> Text -- ^ The identifier to import -> [Filter] -- ^ Filters to apply before searching for -- the identifier -> m (Either [Match] [Text]) addImportForIdentifier fp ident filters = do - modules <- getAllModulesWithReexports + modules <- getAllModules2 Nothing case getExactMatches ident filters modules of [] -> throwError (NotFound "Couldn't find the given identifier. \ @@ -279,7 +279,7 @@ addImportForIdentifier fp ident filters = do -- Only one match was found for the given identifier, so we can insert it -- right away [Match m decl] -> - Right <$> addExplicitImport fp decl (P.moduleNameFromString (T.unpack m)) + Right <$> addExplicitImport fp decl m -- This case comes up for newtypes and dataconstructors. Because values and -- types don't share a namespace we can get multiple matches from the same @@ -296,7 +296,7 @@ addImportForIdentifier fp ident filters = do -- dataconstructor as that will give us an unnecessary import warning at -- worst Just decl -> - Right <$> addExplicitImport fp decl (P.moduleNameFromString (T.unpack m1)) + Right <$> addExplicitImport fp decl m1 -- Here we need the user to specify whether he wanted a dataconstructor -- or a type Nothing -> @@ -307,9 +307,9 @@ addImportForIdentifier fp ident filters = do xs -> pure $ Left xs where - decideRedundantCase dtor@(DataConstructor _ t _) (TypeDeclaration t' _) = + decideRedundantCase dtor@(IdeDataConstructor _ t _) (IdeType t' _) = if t == t' then Just dtor else Nothing - decideRedundantCase TypeDeclaration{} ts@TypeSynonymDeclaration{} = + decideRedundantCase IdeType{} ts@IdeTypeSynonym{} = Just ts decideRedundantCase _ _ = Nothing diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index ad71ff6ab2..5e7575e684 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -41,7 +41,7 @@ import Text.Regex.TDFA ((=~)) type ScoredMatch = (Match, Double) -newtype Matcher = Matcher (Endo [Match]) deriving(Monoid) +newtype Matcher = Matcher (Endo [Match]) deriving (Monoid) instance FromJSON Matcher where parseJSON = withObject "matcher" $ \o -> do @@ -105,7 +105,7 @@ flexRate p c = do -- By string =~ pattern we'll get the start of the match and the length of -- the matchas a (start, length) tuple if there's a match. -- If match fails then it would be (-1,0) -flexScore :: Text -> DeclIdent -> Maybe Double +flexScore :: Text -> Text -> Maybe Double flexScore pat str = case T.uncons pat of Nothing -> Nothing diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index e03cc9d4b8..391637a005 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -42,7 +42,7 @@ import System.IO.UTF8 (readUTF8File) -- warnings, and if rebuilding fails, returns a @RebuildError@ with the -- generated errors. rebuildFile - :: (PscIde m, MonadLogger m, MonadError PscIdeError m) + :: (Ide m, MonadLogger m, MonadError PscIdeError m) => FilePath -> m Success rebuildFile path = do @@ -60,7 +60,7 @@ rebuildFile path = do -- correctly to the 'Environment'. externs <- sortExterns m =<< getExternFiles - outputDirectory <- confOutputPath . envConfiguration <$> ask + outputDirectory <- confOutputPath . ideConfiguration <$> ask -- For rebuilding, we want to 'RebuildAlways', but for inferring foreign -- modules using their file paths, we need to specify the path in the 'Map'. @@ -82,7 +82,7 @@ rebuildFile path = do -- | Rebuilds a module but opens up its export list first and stores the result -- inside the rebuild cache rebuildModuleOpen - :: (PscIde m, MonadLogger m, MonadError PscIdeError m) + :: (Ide m, MonadLogger m, MonadError PscIdeError m) => MakeActionsEnv -> [P.ExternsFile] -> P.Module @@ -100,7 +100,7 @@ rebuildModuleOpen makeEnv externs m = do Right result -> do $(logDebug) ("Setting Rebuild cache: " <> runModuleNameT (P.efModuleName result)) - setCachedRebuild result + cacheRebuild result -- | Parameters we can access while building our @MakeActions@ data MakeActionsEnv = @@ -135,7 +135,7 @@ shushCodegen ma MakeActionsEnv{..} = -- module. Throws an error if there is a cyclic dependency within the -- ExternsFiles sortExterns - :: (PscIde m, MonadError PscIdeError m) + :: (Ide m, MonadError PscIdeError m) => P.Module -> M.Map P.ModuleName P.ExternsFile -> m [P.ExternsFile] diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 4bcce8ef83..d3e7664552 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -15,7 +15,13 @@ {-# LANGUAGE OverloadedStrings #-} -module Language.PureScript.Ide.Reexports where +module Language.PureScript.Ide.Reexports + ( resolveReexports2 + -- for tests + , getReexports + , replaceReexport + , replaceReexports + ) where import Prelude () @@ -25,9 +31,11 @@ import Data.List (union) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe +import qualified Data.Text as T import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Externs -getReexports :: Module -> [ExternDecl] +getReexports :: ModuleOld -> [ExternDecl] getReexports (mn, decls)= concatMap getExport decls where getExport d | (Export mn') <- d @@ -48,32 +56,32 @@ replaceExportWithAliases decls ident = , alias == ident = True | otherwise = False -replaceReexport :: ExternDecl -> Module -> Module -> Module +replaceReexport :: ExternDecl -> ModuleOld -> ModuleOld -> ModuleOld replaceReexport e@(Export _) (m, decls) (_, newDecls) = (m, filter (/= e) decls `union` newDecls) replaceReexport _ _ _ = error "Should only get Exports here." -emptyModule :: Module +emptyModule :: ModuleOld emptyModule = ("Empty", []) isExport :: ExternDecl -> Bool isExport (Export _) = True isExport _ = False -removeExportDecls :: Module -> Module +removeExportDecls :: ModuleOld -> ModuleOld removeExportDecls = fmap (filter (not . isExport)) -replaceReexports :: Module -> Map ModuleIdent [ExternDecl] -> Module +replaceReexports :: ModuleOld -> Map ModuleIdent [ExternDecl] -> ModuleOld replaceReexports m db = result where reexports = getReexports m result = foldl go (removeExportDecls m) reexports - go :: Module -> ExternDecl -> Module + go :: ModuleOld -> ExternDecl -> ModuleOld go m' re@(Export name) = replaceReexport re m' (getModule name) go _ _ = error "partiality! woohoo" - getModule :: ModuleIdent -> Module + getModule :: ModuleIdent -> ModuleOld getModule name = clean res where res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db @@ -81,9 +89,12 @@ replaceReexports m db = result -- infinite loops clean (mn, decls) = (mn,) (filter (/= Export mn) decls) -resolveReexports :: Map ModuleIdent [ExternDecl] -> Module -> Module +resolveReexports :: Map ModuleIdent [ExternDecl] -> ModuleOld -> ModuleOld resolveReexports modules m = let replaced = replaceReexports m modules in if null (getReexports replaced) then replaced else resolveReexports modules replaced + +resolveReexports2 :: Map T.Text [ExternDecl] -> ModuleOld -> Module +resolveReexports2 decls = convertModule . resolveReexports decls diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index a4009c4880..d9b92cbb38 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -17,17 +17,20 @@ {-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Ide.State - ( getPscIdeState + ( getLoadedModulenames , getExternFiles - , getModule - , getModuleWithReexports - , getAllModulesWithReexports - , getAllModulesWithReexportsAndCache , insertModule - , insertModuleSTM - , getCachedRebuild - , resetPscIdeState - , setCachedRebuild + , resetIdeState + , cacheRebuild + , insertExterns + , insertExternsSTM + , getAllModules2 + , getStage1 + , setStage1 + , getStage2 + , setStage2 + , populateStage2 + , populateStage2STM ) where import Prelude () @@ -38,8 +41,9 @@ import Control.Monad.IO.Class import "monad-logger" Control.Monad.Logger import Control.Monad.Reader.Class import qualified Data.Map.Lazy as M -import Data.Maybe (mapMaybe) import Data.Monoid +import qualified Data.Text as T +import Data.Time (getCurrentTime, diffUTCTime) import Language.PureScript.Externs import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Reexports @@ -47,74 +51,30 @@ import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import qualified Language.PureScript as P --- | Resets the PscIdeState to emptyPscIdeState -resetPscIdeState :: PscIde m => m () -resetPscIdeState = do +-- | Resets all State inside psc-ide +resetIdeState :: Ide m => m () +resetIdeState = do stateVar <- envStateVar <$> ask - liftIO $ atomically (writeTVar stateVar emptyPscIdeState) + ideVar <- ideStateVar <$> ask + liftIO . atomically $ do + writeTVar stateVar emptyPscIdeState + writeTVar ideVar emptyIdeState + setStage2STM ideVar emptyStage2 --- | Gets the entire PscIdeState -getPscIdeState :: PscIde m => m PscIdeState -getPscIdeState = do - stateVar <- envStateVar <$> ask - liftIO (readTVarIO stateVar) +-- | Gets the loaded Modulenames +getLoadedModulenames :: Ide m => m [P.ModuleName] +getLoadedModulenames = M.keys <$> getExternFiles -- | Gets all loaded ExternFiles -getExternFiles :: (PscIde m) => m (M.Map P.ModuleName ExternsFile) -getExternFiles = do - stateVar <- envStateVar <$> ask - liftIO (pscIdeStateExternsFiles <$> readTVarIO stateVar) - --- | Gets all loaded Modules and resolves Reexports -getAllModulesWithReexports :: (PscIde m) => m [Module] -getAllModulesWithReexports = getAllModulesWithReexports' <$> getPscIdeState - --- | Pure version of @getAllModulesWithReexports@ -getAllModulesWithReexports' :: PscIdeState -> [Module] -getAllModulesWithReexports' state = - mapMaybe (getModuleWithReexports' state) (M.keys (pscIdeStateModules state)) - --- | Checks if the given ModuleName matches the last rebuild cache and if it --- does, runs @getAllModulesWithReexports@ with the cached module replacing the --- loaded module -getAllModulesWithReexportsAndCache - :: (PscIde m) - => Maybe P.ModuleName - -> m [Module] -getAllModulesWithReexportsAndCache Nothing = getAllModulesWithReexports -getAllModulesWithReexportsAndCache (Just mn) = do - state <- getPscIdeState - cachedRebuild <- getCachedRebuild - case cachedRebuild of - Just (cachedIdent, ef) | cachedIdent == mn -> - pure (getAllModulesWithReexports' (insertModule' ef state)) - _ -> getAllModulesWithReexports - --- | Looks up a single Module inside the loaded Modules -getModule :: (PscIde m) => ModuleIdent -> m (Maybe Module) -getModule m = getModule' <$> getPscIdeState <*> pure m - --- | Pure version of @getModule@ -getModule' :: PscIdeState -> ModuleIdent -> Maybe Module -getModule' ps mi = (mi,) <$> M.lookup mi (pscIdeStateModules ps) - --- | Looks up a single Module and resolves its Reexports -getModuleWithReexports :: PscIde m => ModuleIdent -> m (Maybe Module) -getModuleWithReexports i = getModuleWithReexports' <$> getPscIdeState <*> pure i - --- | Pure version of @getModuleWithReexports@ -getModuleWithReexports' :: PscIdeState -> ModuleIdent -> Maybe Module -getModuleWithReexports' ps mi = - resolveReexports (pscIdeStateModules ps) <$> getModule' ps mi +getExternFiles :: Ide m => m (M.Map P.ModuleName ExternsFile) +getExternFiles = s1Externs <$> getStage1 -- | Inserts an @ExternsFile@ into the PscIdeState. Also converts the -- ExternsFile into psc-ide's internal Declaration format -insertModule :: (PscIde m, MonadLogger m) => - ExternsFile -> m () +-- TODO: should be removed when the "old" Declaration format gets removed +insertModule :: Ide m => ExternsFile -> m () insertModule externsFile = do stateVar <- envStateVar <$> ask - let moduleName = efModuleName externsFile - $(logDebug) $ "Inserting Module: " <> runModuleNameT moduleName liftIO . atomically $ insertModuleSTM stateVar externsFile -- | STM version of insertModule @@ -125,19 +85,112 @@ insertModuleSTM st ef = modifyTVar st (insertModule' ef) insertModule' :: ExternsFile -> PscIdeState -> PscIdeState insertModule' ef state = state - { pscIdeStateExternsFiles = - M.insert (efModuleName ef) ef (pscIdeStateExternsFiles state) - , pscIdeStateModules = let (mn, decls) = convertExterns ef + { pscIdeStateModules = let (mn, decls) = convertExterns ef in M.insert mn decls (pscIdeStateModules state) } +-- | Retrieves Stage1 from the State. +-- This includes loaded Externfiles +-- (TODO: as soon as we actually parse the modules) aswell as the parsed modules +getStage1 :: Ide m => m Stage1 +getStage1 = do + st <- ideStateVar <$> ask + fmap ideStage1 . liftIO . readTVarIO $ st + +-- | STM version of getStage1 +getStage1STM :: TVar IdeState -> STM Stage1 +getStage1STM ref = ideStage1 <$> readTVar ref + +-- | Sets Stage1 inside the compiler +setStage1 :: Ide m => Stage1 -> m () +setStage1 s1 = do + st <- ideStateVar <$> ask + liftIO . atomically . modifyTVar st $ \x -> + x {ideStage1 = s1} + pure () + +-- TODO: Soon to be Stage3 +-- | Retrieves Stage2 from the State. +-- This includes the denormalized Declarations and cached rebuilds +getStage2 :: Ide m => m Stage2 +getStage2 = do + st <- ideStateVar <$> ask + fmap ideStage2 . liftIO . readTVarIO $ st + +-- | Sets Stage2 inside the compiler +setStage2 :: Ide m => Stage2 -> m () +setStage2 s2 = do + st <- ideStateVar <$> ask + liftIO . atomically $ setStage2STM st s2 + +-- | STM version of setStage2 +setStage2STM :: TVar IdeState -> Stage2 -> STM () +setStage2STM ref s2 = do + modifyTVar ref $ \x -> + x {ideStage2 = s2} + pure () + +-- | Checks if the given ModuleName matches the last rebuild cache and if it +-- does returns all loaded definitions + the definitions inside the rebuild +-- cache +getAllModules2 :: Ide m => Maybe P.ModuleName -> m [(P.ModuleName, [IdeDeclaration])] +getAllModules2 mmoduleName = do + modules <- s2Modules <$> getStage2 + rebuild <- cachedRebuild + case mmoduleName of + Nothing -> pure (M.toList modules) + Just moduleName -> + case rebuild of + Just (cachedModulename, ef) + | cachedModulename == moduleName -> + pure . M.toList $ + M.insert moduleName (snd . convertModule . convertExterns $ ef) modules + _ -> pure (M.toList modules) + +-- | Adds an ExternsFile into psc-ide's State Stage1. This does not populate the +-- following Stages, which needs to be done after all the necessary Exterms have +-- been loaded. +insertExterns :: Ide m => ExternsFile -> m () +insertExterns ef = do + st <- ideStateVar <$> ask + liftIO (atomically (insertExternsSTM st ef)) + +-- | STM version of insertExterns +insertExternsSTM :: TVar IdeState -> ExternsFile -> STM () +insertExternsSTM ref ef = + modifyTVar ref $ \x -> + x { ideStage1 = (ideStage1 x) { + s1Externs = M.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}} + -- | Sets rebuild cache to the given ExternsFile -setCachedRebuild :: PscIde m => ExternsFile -> m () -setCachedRebuild ef = do - st <- envStateVar <$> ask +cacheRebuild :: Ide m => ExternsFile -> m () +cacheRebuild ef = do + st <- ideStateVar <$> ask liftIO . atomically . modifyTVar st $ \x -> - x { pscIdeStateCachedRebuild = Just (efModuleName ef, ef) } + x { ideStage2 = (ideStage2 x) { + s2CachedRebuild = Just (efModuleName ef, ef)}} -- | Retrieves the rebuild cache -getCachedRebuild :: PscIde m => m (Maybe (P.ModuleName, ExternsFile)) -getCachedRebuild = pscIdeStateCachedRebuild <$> getPscIdeState +cachedRebuild :: Ide m => m (Maybe (P.ModuleName, ExternsFile)) +cachedRebuild = s2CachedRebuild <$> getStage2 + +-- | Resolves reexports and populates Stage2 with data to be used in queries. +populateStage2 :: (Ide m, MonadLogger m) => m () +populateStage2 = do + st <- ideStateVar <$> ask + duration <- liftIO $ do + start <- getCurrentTime + atomically (populateStage2STM st) + end <- getCurrentTime + pure (diffUTCTime end start) + $(logDebug) $ "Finished populating Stage2 in " <> T.pack (show duration) + +-- | STM version of populateStage2 +populateStage2STM :: TVar IdeState -> STM () +populateStage2STM ref = do + externs <- s1Externs <$> getStage1STM ref + -- Build the "old" ExternDecl format + let modules = M.mapKeys runModuleNameT (M.map (snd . convertExterns) externs) + -- Convert ExternDecl into IdeDeclaration + declarations = resolveReexports2 modules <$> M.toList modules + setStage2STM ref (Stage2 (M.fromList declarations) Nothing) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 49fb2de706..ec63e7dcfb 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -26,18 +26,15 @@ import Control.Monad.Trans import Data.Aeson import Data.Map.Lazy as M import Data.Maybe (maybeToList) -import Data.Text (Text (), pack, unpack) -import qualified Language.PureScript.AST.Declarations as D -import Language.PureScript.Externs +import Data.Text (Text, pack, unpack) import qualified Language.PureScript.Errors.JSON as P -import qualified Language.PureScript.Names as N import qualified Language.PureScript as P +import Language.PureScript.Ide.Conversions import Text.Parsec import Text.Parsec.Text type Ident = Text -type DeclIdent = Text type ModuleIdent = Text data ExternDecl @@ -53,10 +50,10 @@ data ExternDecl -- | A module declaration | ModuleDecl ModuleIdent -- The modules name - [DeclIdent] -- The exported identifiers + [Ident] -- The exported identifiers -- | A data/newtype declaration | DataConstructor - DeclIdent -- The type name + Ident -- The type name (P.ProperName 'P.TypeName) P.Type -- The "type" -- | An exported module @@ -66,7 +63,18 @@ data ExternDecl | Export ModuleIdent -- The exported Modules name deriving (Show,Eq,Ord) -type Module = (ModuleIdent, [ExternDecl]) +data IdeDeclaration + = IdeValue Ident P.Type + | IdeType (P.ProperName 'P.TypeName) P.Kind + | IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type + | IdeDataConstructor Ident (P.ProperName 'P.TypeName) P.Type + | IdeTypeClass (P.ProperName 'P.ClassName) + | IdeValueOperator (P.OpName 'P.ValueOpName) Ident P.Precedence P.Associativity + | IdeTypeOperator (P.OpName 'P.TypeOpName) Ident P.Precedence P.Associativity + deriving (Show, Eq, Ord) + +type Module = (P.ModuleName, [IdeDeclaration]) +type ModuleOld = (Text, [ExternDecl]) data Configuration = Configuration @@ -74,29 +82,51 @@ data Configuration = , confDebug :: Bool } -data PscIdeEnvironment = - PscIdeEnvironment +data IdeEnvironment = + IdeEnvironment { envStateVar :: TVar PscIdeState - , envConfiguration :: Configuration + , ideStateVar :: TVar IdeState + , ideConfiguration :: Configuration } -type PscIde m = (MonadIO m, MonadReader PscIdeEnvironment m) +type Ide m = (MonadIO m, MonadReader IdeEnvironment m) data PscIdeState = PscIdeState { pscIdeStateModules :: M.Map Text [ExternDecl] - , pscIdeStateExternsFiles :: M.Map P.ModuleName ExternsFile - , pscIdeStateCachedRebuild :: Maybe (P.ModuleName, ExternsFile) } deriving Show emptyPscIdeState :: PscIdeState -emptyPscIdeState = PscIdeState M.empty M.empty Nothing +emptyPscIdeState = PscIdeState M.empty + +data IdeState = IdeState + { ideStage1 :: Stage1 + , ideStage2 :: Stage2 + } + +emptyIdeState :: IdeState +emptyIdeState = IdeState emptyStage1 emptyStage2 + +emptyStage1 :: Stage1 +emptyStage1 = Stage1 M.empty + +emptyStage2 :: Stage2 +emptyStage2 = Stage2 M.empty Nothing + +data Stage1 = Stage1 + { s1Externs :: M.Map P.ModuleName P.ExternsFile + } + +data Stage2 = Stage2 + { s2Modules :: M.Map P.ModuleName [IdeDeclaration] + , s2CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile) + } -data Match = Match ModuleIdent ExternDecl - deriving (Show, Eq) +data Match = Match P.ModuleName IdeDeclaration + deriving (Show, Eq) newtype Completion = - Completion (ModuleIdent, DeclIdent, Text) + Completion (ModuleIdent, Ident, Text) deriving (Show,Eq) instance ToJSON Completion where @@ -106,7 +136,7 @@ instance ToJSON Completion where data ModuleImport = ModuleImport { importModuleName :: ModuleIdent - , importType :: D.ImportDeclarationType + , importType :: P.ImportDeclarationType , importQualifier :: Maybe Text } deriving(Show) @@ -116,25 +146,25 @@ instance Eq ModuleImport where && importQualifier mi1 == importQualifier mi2 instance ToJSON ModuleImport where - toJSON (ModuleImport mn D.Implicit qualifier) = + toJSON (ModuleImport mn P.Implicit qualifier) = object $ [ "module" .= mn , "importType" .= ("implicit" :: Text) ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier) - toJSON (ModuleImport mn (D.Explicit refs) _) = + toJSON (ModuleImport mn (P.Explicit refs) _) = object [ "module" .= mn , "importType" .= ("explicit" :: Text) , "identifiers" .= (identifierFromDeclarationRef <$> refs) ] - toJSON (ModuleImport mn (D.Hiding refs) _) = + toJSON (ModuleImport mn (P.Hiding refs) _) = object [ "module" .= mn , "importType" .= ("hiding" :: Text) , "identifiers" .= (identifierFromDeclarationRef <$> refs) ] -identifierFromDeclarationRef :: D.DeclarationRef -> String -identifierFromDeclarationRef (D.TypeRef name _) = N.runProperName name -identifierFromDeclarationRef (D.ValueRef ident) = N.runIdent ident -identifierFromDeclarationRef (D.TypeClassRef name) = N.runProperName name +identifierFromDeclarationRef :: P.DeclarationRef -> Text +identifierFromDeclarationRef (P.TypeRef name _) = runProperNameT name +identifierFromDeclarationRef (P.ValueRef ident) = runIdentT ident +identifierFromDeclarationRef (P.TypeClassRef name) = runProperNameT name identifierFromDeclarationRef _ = "" data Success = @@ -182,7 +212,7 @@ data PursuitResponse = ModuleResponse ModuleIdent Text -- | A Pursuit Response for a declaration. Consist of the declarations type, -- module, name and package - | DeclarationResponse Text ModuleIdent DeclIdent Text + | DeclarationResponse Text ModuleIdent Ident Text deriving (Show,Eq) instance FromJSON PursuitResponse where diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 839bfc2154..2d48bb4b4c 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -9,14 +9,23 @@ -- Stability : experimental -- -- | --- Generally useful functions and conversions +-- Generally useful functions ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} -module Language.PureScript.Ide.Util where +module Language.PureScript.Ide.Util + ( identifierFromIdeDeclaration + , identifierFromMatch + , completionFromMatch + , encodeT + , decodeT + , unlessM + , module Language.PureScript.Ide.Conversions + ) where import Prelude.Compat +import Control.Monad (unless) import Data.Aeson import Data.Text (Text) import qualified Data.Text as T @@ -24,50 +33,32 @@ import Data.Text.Lazy (fromStrict, toStrict) import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) import qualified Language.PureScript as P import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Conversions -runProperNameT :: P.ProperName a -> Text -runProperNameT = T.pack . P.runProperName - -runIdentT :: P.Ident -> Text -runIdentT = T.pack . P.runIdent - -runOpNameT :: P.OpName a -> Text -runOpNameT = T.pack . P.runOpName - -runModuleNameT :: P.ModuleName -> Text -runModuleNameT = T.pack . P.runModuleName - -prettyTypeT :: P.Type -> Text -prettyTypeT = T.unwords . fmap T.strip . T.lines . T.pack . P.prettyPrintType - -identifierFromExternDecl :: ExternDecl -> Text -identifierFromExternDecl (ValueDeclaration name _) = name -identifierFromExternDecl (TypeDeclaration name _) = runProperNameT name -identifierFromExternDecl (TypeSynonymDeclaration name _) = runProperNameT name -identifierFromExternDecl (DataConstructor name _ _) = name -identifierFromExternDecl (TypeClassDeclaration name) = runProperNameT name -identifierFromExternDecl (ModuleDecl name _) = name -identifierFromExternDecl (ValueOperator op _ _ _) = runOpNameT op -identifierFromExternDecl (TypeOperator op _ _ _) = runOpNameT op -identifierFromExternDecl Dependency{} = "~Dependency~" -identifierFromExternDecl Export{} = "~Export~" +identifierFromIdeDeclaration :: IdeDeclaration -> Text +identifierFromIdeDeclaration d = case d of + IdeValue name _ -> name + IdeType name _ -> runProperNameT name + IdeTypeSynonym name _ -> runProperNameT name + IdeDataConstructor name _ _ -> name + IdeTypeClass name -> runProperNameT name + IdeValueOperator op _ _ _ -> runOpNameT op + IdeTypeOperator op _ _ _ -> runOpNameT op identifierFromMatch :: Match -> Text -identifierFromMatch (Match _ ed) = identifierFromExternDecl ed +identifierFromMatch (Match _ ed) = identifierFromIdeDeclaration ed -completionFromMatch :: Match -> Maybe Completion -completionFromMatch (Match m d) = case d of - ValueDeclaration name type' -> Just $ Completion (m, name, prettyTypeT type') - TypeDeclaration name kind -> Just $ Completion (m, runProperNameT name, T.pack $ P.prettyPrintKind kind) - TypeSynonymDeclaration name kind -> Just $ Completion (m, runProperNameT name, prettyTypeT kind) - DataConstructor name _ type' -> Just $ Completion (m, name, prettyTypeT type') - TypeClassDeclaration name -> Just $ Completion (m, runProperNameT name, "class") - ModuleDecl name _ -> Just $ Completion ("module", name, "module") - ValueOperator op ref precedence associativity -> Just $ Completion (m, runOpNameT op, showFixity precedence associativity ref op) - TypeOperator op ref precedence associativity -> Just $ Completion (m, runOpNameT op, showFixity precedence associativity ref op) - Dependency{} -> Nothing - Export{} -> Nothing +completionFromMatch :: Match -> Completion +completionFromMatch (Match m' d) = case d of + IdeValue name type' -> Completion (m, name, prettyTypeT type') + IdeType name kind -> Completion (m, runProperNameT name, T.pack $ P.prettyPrintKind kind) + IdeTypeSynonym name kind -> Completion (m, runProperNameT name, prettyTypeT kind) + IdeDataConstructor name _ type' -> Completion (m, name, prettyTypeT type') + IdeTypeClass name -> Completion (m, runProperNameT name, "class") + IdeValueOperator op ref precedence associativity -> Completion (m, runOpNameT op, showFixity precedence associativity ref op) + IdeTypeOperator op ref precedence associativity -> Completion (m, runOpNameT op, showFixity precedence associativity ref op) where + m = runModuleNameT m' showFixity p a r o = let asso = case a of P.Infix -> "infix" @@ -75,9 +66,11 @@ completionFromMatch (Match m d) = case d of P.Infixr -> "infixr" in T.unwords [asso, T.pack (show p), r, "as", runOpNameT o] - encodeT :: (ToJSON a) => a -> Text encodeT = toStrict . decodeUtf8 . encode decodeT :: (FromJSON a) => Text -> Maybe a decodeT = decode . encodeUtf8 . fromStrict + +unlessM :: Monad m => m Bool -> m () -> m () +unlessM cond act = cond >>= flip unless act diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs index 4ebe68e78d..8c9b7b142b 100644 --- a/src/Language/PureScript/Ide/Watcher.hs +++ b/src/Language/PureScript/Ide/Watcher.hs @@ -27,20 +27,20 @@ import System.FSNotify -- | Reloads an ExternsFile from Disc. If the Event indicates the ExternsFile -- was deleted we don't do anything. -reloadFile :: TVar PscIdeState -> Event -> IO () +reloadFile :: TVar IdeState -> Event -> IO () reloadFile _ Removed{} = pure () -reloadFile stateVar ev = do +reloadFile ref ev = do let fp = eventPath ev ef' <- runExceptT (readExternFile fp) case ef' of Left _ -> pure () Right ef -> do - atomically (insertModuleSTM stateVar ef) + atomically (insertExternsSTM ref ef *> populateStage2STM ref) putStrLn ("Reloaded File at: " ++ fp) -- | Installs filewatchers for the given directory and reloads ExternsFiles when -- they change on disc -watcher :: TVar PscIdeState -> FilePath -> IO () +watcher :: TVar IdeState -> FilePath -> IO () watcher stateVar fp = withManagerConf (defaultConfig { confDebounce = NoDebounce }) $ \mgr -> do _ <- watchTree mgr fp diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 682e85a543..d2bfc8c566 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -21,6 +21,7 @@ module Language.PureScript.Publish , getResolvedDependencies ) where +import Prelude () import Prelude.Compat hiding (userError) import Control.Arrow ((***)) diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index 6415ec0824..461850fbbc 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -7,26 +7,23 @@ import Language.PureScript.Ide.Types import qualified Language.PureScript as P import Test.Hspec -value :: Text -> ExternDecl -value s = ValueDeclaration s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) +value :: Text -> IdeDeclaration +value s = IdeValue s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) modules :: [Module] modules = - [ - ("Module.A", [value "function1"]), - ("Module.B", [value "data1"]), - ("Module.C", [ModuleDecl "Module.C" []]), - ("Module.D", [Dependency "Module.C" [] Nothing, value "asd"]) + [ (P.moduleNameFromString "Module.A", [value "function1"]) + , (P.moduleNameFromString "Module.B", [value "data1"]) ] runEq :: Text -> [Module] runEq s = runFilter (equalityFilter s) modules + runPrefix :: Text -> [Module] runPrefix s = runFilter (prefixFilter s) modules -runModule :: [ModuleIdent] -> [Module] + +runModule :: [P.ModuleName] -> [Module] runModule ms = runFilter (moduleFilter ms) modules -runDependency :: [ModuleIdent] -> [Module] -runDependency ms = runFilter (dependencyFilter ms) modules spec :: Spec spec = do @@ -35,7 +32,6 @@ spec = do runEq "test" `shouldBe` [] it "keeps function declarations that are equal" $ runEq "function1" `shouldBe` [head modules] - -- TODO: It would be more sensible to match Constructors it "keeps data declarations that are equal" $ runEq "data1" `shouldBe` [modules !! 1] describe "prefixFilter" $ do @@ -45,19 +41,10 @@ spec = do runPrefix "fun" `shouldBe` [head modules] it "keeps data decls prefix matches" $ runPrefix "dat" `shouldBe` [modules !! 1] - it "keeps module decl prefix matches" $ - runPrefix "Mod" `shouldBe` [modules !! 2] describe "moduleFilter" $ do it "removes everything on empty input" $ runModule [] `shouldBe` [] it "only keeps the specified modules" $ - runModule ["Module.A", "Module.C"] `shouldBe` [head modules, modules !! 2] + runModule [P.moduleNameFromString "Module.A"] `shouldBe` [head modules] it "ignores modules that are not in scope" $ - runModule ["Module.A", "Module.C", "Unknown"] `shouldBe` [head modules, modules !! 2] - describe "dependencyFilter" $ do - it "removes everything on empty input" $ - runDependency [] `shouldBe` [] - it "only keeps the specified modules if they have no imports" $ - runDependency ["Module.A", "Module.B"] `shouldBe` [head modules, modules !! 1] - it "keeps the specified modules and their imports" $ - runDependency ["Module.A", "Module.D"] `shouldBe` [head modules, modules !! 2, modules !! 3] + runModule (P.moduleNameFromString <$> ["Module.A", "Unknown"]) `shouldBe` [head modules] diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs index ef56ccb958..b6365deaeb 100644 --- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs +++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs @@ -12,9 +12,7 @@ import System.Directory import System.FilePath setup :: IO () -setup = do - Integration.reset - mapM_ Integration.loadModuleWithDeps ["ImportsSpec", "ImportsSpec1"] +setup = void (Integration.reset *> Integration.loadAll) withSupportFiles :: (FilePath -> FilePath -> IO a) -> IO () withSupportFiles test = do @@ -35,52 +33,41 @@ spec = beforeAll_ setup . describe "Adding imports" $ do let sourceFileSkeleton :: [Text] -> [Text] sourceFileSkeleton importSection = - [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId = id"] + [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId x = x"] it "adds an implicit import" $ do withSupportFiles (Integration.addImplicitImport "ImportsSpec1") outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1" - , "import Main (id)" ]) it "adds an explicit unqualified import" $ do withSupportFiles (Integration.addImport "exportedFunction") outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (exportedFunction)" - , "import Main (id)" ]) it "adds an explicit unqualified import (type)" $ do withSupportFiles (Integration.addImport "MyType") - outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyType)" - , "import Main (id)" - ]) + outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyType)"]) it "adds an explicit unqualified import (parameterized type)" $ do withSupportFiles (Integration.addImport "MyParamType") - outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyParamType)" - , "import Main (id)" - ]) + outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyParamType)"]) it "adds an explicit unqualified import (typeclass)" $ do withSupportFiles (Integration.addImport "ATypeClass") - outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (class ATypeClass)" - , "import Main (id)"]) + outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (class ATypeClass)"]) it "adds an explicit unqualified import (dataconstructor)" $ do withSupportFiles (Integration.addImport "MyJust") - outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyMaybe(MyJust))" - , "import Main (id)"]) + outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyMaybe(MyJust))"]) it "adds an explicit unqualified import (newtype)" $ do withSupportFiles (Integration.addImport "MyNewtype") - outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (MyNewtype(MyNewtype))" - , "import Main (id)"]) + outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyNewtype(MyNewtype))"]) it "adds an explicit unqualified import (typeclass member function)" $ do withSupportFiles (Integration.addImport "typeClassFun") - outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (typeClassFun)" - , "import Main (id)"]) + outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (typeClassFun)"]) it "doesn't add a newtypes constructor if only the type is exported" $ do withSupportFiles (Integration.addImport "OnlyTypeExported") - outputFileShouldBe (sourceFileSkeleton [ "import ImportsSpec1 (OnlyTypeExported)" - , "import Main (id)"]) + outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (OnlyTypeExported)"]) it "doesn't add an import if the identifier is defined in the module itself" $ do withSupportFiles (Integration.addImport "myId") - outputFileShouldBe (sourceFileSkeleton [ "import Main (id)"]) + outputFileShouldBe (sourceFileSkeleton []) it "responds with an error if it's undecidable whether we want a type or constructor" $ withSupportFiles (\sourceFp outFp -> do r <- Integration.addImport "SpecialCase" sourceFp outFp diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index e78fcb9859..a87c45da0b 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -68,11 +68,11 @@ spec = do describe "import commands" $ do let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i addValueImport i mn is = - prettyPrintImportSection (addExplicitImport' (ValueDeclaration i wildcard) mn is) + prettyPrintImportSection (addExplicitImport' (IdeValue i wildcard) mn is) addOpImport op mn is = - prettyPrintImportSection (addExplicitImport' (ValueOperator op "" 2 P.Infix) mn is) + prettyPrintImportSection (addExplicitImport' (IdeValueOperator op "" 2 P.Infix) mn is) addDtorImport i t mn is = - prettyPrintImportSection (addExplicitImport' (DataConstructor i t wildcard) mn is) + prettyPrintImportSection (addExplicitImport' (IdeDataConstructor i t wildcard) mn is) it "adds an implicit unqualified import" $ shouldBe (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map")) diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs index 876eb21387..c334988670 100644 --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -29,8 +29,9 @@ module Language.PureScript.Ide.Integration -- sending commands , addImport , addImplicitImport + , loadAll , loadModule - , loadModuleWithDeps + , loadModules , getCwd , getFlexCompletions , getFlexCompletionsInModule @@ -161,11 +162,14 @@ getCwd = do let cwdCommand = object ["command" .= ("cwd" :: String)] sendCommand cwdCommand -loadModuleWithDeps :: String -> IO String -loadModuleWithDeps m = sendCommand $ load [] [m] - loadModule :: String -> IO String -loadModule m = sendCommand $ load [m] [] +loadModule m = loadModules [m] + +loadModules :: [String] -> IO String +loadModules = sendCommand . load + +loadAll :: IO String +loadAll = sendCommand (load []) getFlexCompletions :: String -> IO [(String, String, String)] getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) Nothing) @@ -190,8 +194,8 @@ rebuildModule m = sendCommand (rebuildC m Nothing) commandWrapper :: String -> Value -> Value commandWrapper c p = object ["command" .= c, "params" .= p] -load :: [String] -> [String] -> Value -load ms ds = commandWrapper "load" (object ["modules" .= ms, "dependencies" .= ds]) +load :: [String] -> Value +load ms = commandWrapper "load" (object ["modules" .= ms]) typeC :: String -> [Value] -> Value typeC q filters = commandWrapper "type" (object ["search" .= q, "filters" .= filters]) diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs index 954ded1663..24f2e32137 100644 --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -10,14 +10,14 @@ import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types import Test.Hspec -value :: Text -> ExternDecl -value s = ValueDeclaration s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) +value :: Text -> IdeDeclaration +value s = IdeValue s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) completions :: [Match] completions = - [ Match "" (value "firstResult") - , Match "" (value "secondResult") - , Match "" (value "fiult") + [ Match (P.moduleNameFromString "Match") (value "firstResult") + , Match (P.moduleNameFromString "Match") (value "secondResult") + , Match (P.moduleNameFromString "Match") (value "fiult") ] mkResult :: [Int] -> [Match] @@ -27,7 +27,7 @@ runFlex :: Text -> [Match] runFlex s = runMatcher (flexMatcher s) completions setup :: IO () -setup = reset *> void (loadModuleWithDeps "Main") +setup = reset *> void loadAll spec :: Spec spec = do @@ -45,4 +45,4 @@ spec = do cs `shouldBe` [] it "matches on equality" $ do cs <- getFlexCompletions "const" - cs `shouldBe` [("Main", "const", "forall a b. a -> b -> a")] + cs `shouldBe` [("MatcherSpec", "const", "forall a b. a -> b -> a")] diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index f78cd1bda9..0a11d8e0a6 100644 --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -13,7 +13,7 @@ shouldBeFailure = shouldBe False . Integration.resultIsSuccess spec :: Spec spec = before_ Integration.reset . describe "Rebuilding single modules" $ do it "rebuilds a correct module without dependencies successfully" $ do - _ <- Integration.loadModuleWithDeps "RebuildSpecSingleModule" + _ <- Integration.loadModule "RebuildSpecSingleModule" pdir <- Integration.projectDirectory let file = pdir "src" "RebuildSpecSingleModule.purs" Integration.rebuildModule file >>= shouldBeSuccess @@ -22,12 +22,12 @@ spec = before_ Integration.reset . describe "Rebuilding single modules" $ do let file = pdir "src" "RebuildSpecSingleModule.fail" Integration.rebuildModule file >>= shouldBeFailure it "rebuilds a correct module with its dependencies successfully" $ do - _ <- Integration.loadModuleWithDeps "RebuildSpecWithDeps" + _ <- Integration.loadModules ["RebuildSpecWithDeps", "RebuildSpecDep"] pdir <- Integration.projectDirectory let file = pdir "src" "RebuildSpecWithDeps.purs" Integration.rebuildModule file >>= shouldBeSuccess it "rebuilds a correct module that has reverse dependencies" $ do - _ <- Integration.loadModuleWithDeps "RebuildSpecWithDeps" + _ <- Integration.loadModule "RebuildSpecWithDeps" pdir <- Integration.projectDirectory let file = pdir "src" "RebuildSpecDep.purs" Integration.rebuildModule file >>= shouldBeSuccess @@ -37,7 +37,7 @@ spec = before_ Integration.reset . describe "Rebuilding single modules" $ do let file = pdir "src" "RebuildSpecWithDeps.purs" Integration.rebuildModule file >>= shouldBeFailure it "rebuilds a correct module with a foreign file" $ do - _ <- Integration.loadModuleWithDeps "RebuildSpecWithForeign" + _ <- Integration.loadModule "RebuildSpecWithForeign" pdir <- Integration.projectDirectory let file = pdir "src" "RebuildSpecWithForeign.purs" Integration.rebuildModule file >>= shouldBeSuccess diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index 5633d6051e..8a095c50fd 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -23,28 +23,28 @@ dep1 = Dependency "Test.Foo" [] (Just "T") dep2 :: ExternDecl dep2 = Dependency "Test.Bar" [] (Just "T") -circularModule :: Module +circularModule :: ModuleOld circularModule = ("Circular", [Export "Circular"]) -module1 :: Module +module1 :: ModuleOld module1 = ("Module1", [Export "Module2", Export "Module3", decl1]) -module2 :: Module +module2 :: ModuleOld module2 = ("Module2", [decl2]) -module3 :: Module +module3 :: ModuleOld module3 = ("Module3", [decl3]) -module4 :: Module +module4 :: ModuleOld module4 = ("Module4", [Export "T", decl1, dep1, dep2]) -result :: Module +result :: ModuleOld result = ("Module1", [decl1, decl2, Export "Module3"]) db :: Map.Map ModuleIdent [ExternDecl] db = Map.fromList [module1, module2, module3] -shouldBeEqualSorted :: Module -> Module -> Expectation +shouldBeEqualSorted :: ModuleOld -> ModuleOld -> Expectation shouldBeEqualSorted (n1, d1) (n2, d2) = (n1, sort d1) `shouldBe` (n2, sort d2) spec :: Spec diff --git a/tests/Language/PureScript/IdeSpec.hs b/tests/Language/PureScript/IdeSpec.hs deleted file mode 100644 index 8ceedb1ea2..0000000000 --- a/tests/Language/PureScript/IdeSpec.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.PureScript.IdeSpec where - -import Control.Concurrent.STM -import Control.Monad.Reader -import Data.List -import qualified Data.Map as Map -import Language.PureScript.Ide -import Language.PureScript.Ide.Types -import Test.Hspec - -testState :: PscIdeState -testState = PscIdeState (Map.fromList [("Data.Array", []), ("Control.Monad.Eff", [])]) Map.empty Nothing - -defaultConfig :: Configuration -defaultConfig = - Configuration - { - confOutputPath = "output/" - , confDebug = False - } - -spec :: SpecWith () -spec = - describe "list" $ - describe "loadedModules" $ do - it "returns an empty list when no modules are loaded" $ do - st <- newTVarIO emptyPscIdeState - result <- runReaderT printModules (PscIdeEnvironment st defaultConfig) - result `shouldBe` ModuleList [] - it "returns the list of loaded modules" $ do - st <- newTVarIO testState - ModuleList result <- runReaderT printModules (PscIdeEnvironment st defaultConfig) - sort result `shouldBe` sort ["Data.Array", "Control.Monad.Eff"] diff --git a/tests/support/pscide/src/ImportsSpec.purs b/tests/support/pscide/src/ImportsSpec.purs index 04a7227f43..b48e246a14 100644 --- a/tests/support/pscide/src/ImportsSpec.purs +++ b/tests/support/pscide/src/ImportsSpec.purs @@ -1,5 +1,3 @@ module ImportsSpec where -import Main (id) - -myId = id +myId x = x diff --git a/tests/support/pscide/src/Main.purs b/tests/support/pscide/src/MatcherSpec.purs similarity index 76% rename from tests/support/pscide/src/Main.purs rename to tests/support/pscide/src/MatcherSpec.purs index ca679385b0..b9fbe0e046 100644 --- a/tests/support/pscide/src/Main.purs +++ b/tests/support/pscide/src/MatcherSpec.purs @@ -1,4 +1,4 @@ -module Main where +module MatcherSpec where id :: forall a. a -> a id x = x diff --git a/tests/support/pscide/src/RebuildSpecSingleModule.purs b/tests/support/pscide/src/RebuildSpecSingleModule.purs index 405962933e..9a1fe7e21a 100644 --- a/tests/support/pscide/src/RebuildSpecSingleModule.purs +++ b/tests/support/pscide/src/RebuildSpecSingleModule.purs @@ -1,4 +1,4 @@ module RebuildSpecSingleModule where id x = x -const x y = x +lulz x y = x From 8063c4d0498c9bdca74ffe165edcdd1ea1a4f15b Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sat, 11 Jun 2016 04:09:23 +0200 Subject: [PATCH 0454/1580] [psc-ide] Switches to the Protolude An alternative Prelude, that is meant to reduce boilerplate and enforce best practices with regards to String --- psc-ide-server/Main.hs | 42 +++--- purescript.cabal | 4 +- src/Language/PureScript/Ide.hs | 17 +-- src/Language/PureScript/Ide/CaseSplit.hs | 35 ++--- src/Language/PureScript/Ide/Command.hs | 12 +- src/Language/PureScript/Ide/Completion.hs | 14 +- src/Language/PureScript/Ide/Conversions.hs | 15 +-- src/Language/PureScript/Ide/Error.hs | 21 ++- src/Language/PureScript/Ide/Externs.hs | 24 ++-- src/Language/PureScript/Ide/Filter.hs | 12 +- src/Language/PureScript/Ide/Imports.hs | 33 ++--- src/Language/PureScript/Ide/Matcher.hs | 17 +-- src/Language/PureScript/Ide/Pursuit.hs | 16 +-- src/Language/PureScript/Ide/Rebuild.hs | 24 ++-- src/Language/PureScript/Ide/Reexports.hs | 10 +- src/Language/PureScript/Ide/SourceFile.hs | 78 +++++------ src/Language/PureScript/Ide/State.hs | 6 +- src/Language/PureScript/Ide/Types.hs | 26 ++-- src/Language/PureScript/Ide/Util.hs | 17 +-- src/Language/PureScript/Ide/Watcher.hs | 6 +- tests/Language/PureScript/Ide/FilterSpec.hs | 24 ++-- .../PureScript/Ide/Imports/IntegrationSpec.hs | 6 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 12 +- tests/Language/PureScript/Ide/Integration.hs | 125 ++++++++---------- tests/Language/PureScript/Ide/MatcherSpec.hs | 23 ++-- tests/Language/PureScript/Ide/RebuildSpec.hs | 8 +- .../Language/PureScript/Ide/ReexportsSpec.hs | 10 +- 27 files changed, 263 insertions(+), 374 deletions(-) diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 25014f7ff0..8fe3ad75b7 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -17,21 +17,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} module Main where -import Prelude () -import Prelude.Compat +import Protolude -import Control.Concurrent (forkFinally) import Control.Concurrent.STM -import Control.Exception (bracketOnError, catchJust) -import Control.Monad -import Control.Monad.Error.Class import "monad-logger" Control.Monad.Logger -import Control.Monad.Reader -import Control.Monad.Trans.Except -import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Version (showVersion) import Language.PureScript.Ide @@ -43,10 +36,10 @@ import Network hiding (socketPort, accept) import Network.BSD (getProtocolNumber) import Network.Socket hiding (PortNumber, Type, sClose) -import Options.Applicative +import Options.Applicative hiding ((<>)) import System.Directory import System.FilePath -import System.IO +import System.IO hiding (putStrLn, print) import System.IO.Error (isEOFError) import qualified Paths_purescript as Paths @@ -54,8 +47,8 @@ import qualified Paths_purescript as Paths -- "Borrowed" from the Idris Compiler -- Copied from upstream impl of listenOn -- bound to localhost interface instead of iNADDR_ANY -listenOnLocalhost :: PortID -> IO Socket -listenOnLocalhost (PortNumber port) = do +listenOnLocalhost :: PortNumber -> IO Socket +listenOnLocalhost port = do proto <- getProtocolNumber "tcp" localhost <- inet_addr "127.0.0.1" bracketOnError @@ -66,12 +59,11 @@ listenOnLocalhost (PortNumber port) = do bindSocket sock (SockAddrInet port localhost) listen sock maxListenQueue pure sock) -listenOnLocalhost _ = error "Wrong Porttype" data Options = Options { optionsDirectory :: Maybe FilePath , optionsOutputPath :: FilePath - , optionsPort :: PortID + , optionsPort :: PortNumber , optionsNoWatch :: Bool , optionsDebug :: Bool } @@ -88,8 +80,8 @@ main = do unlessM (doesDirectoryExist fullOutputPath) $ do putStrLn ("Your output directory didn't exist. I'll create it at: " <> fullOutputPath) createDirectory fullOutputPath - putStrLn "This usually means you didn't compile your project yet." - putStrLn "psc-ide needs you to compile your project (for example by running pulp build)" + putText "This usually means you didn't compile your project yet." + putText "psc-ide needs you to compile your project (for example by running pulp build)" unless noWatch $ void (forkFinally (watcher ideState fullOutputPath) print) @@ -100,18 +92,18 @@ main = do where parser = Options - <$> optional (strOption (long "directory" <> short 'd')) - <*> strOption (long "output-directory" <> value "output/") - <*> (PortNumber . fromIntegral <$> - option auto (long "port" <> short 'p' <> value (4242 :: Integer))) + <$> optional (strOption (long "directory" `mappend` short 'd')) + <*> strOption (long "output-directory" `mappend` value "output/") + <*> (fromIntegral <$> + option auto (long "port" `mappend` short 'p' `mappend` value (4242 :: Integer))) <*> switch (long "no-watch") <*> switch (long "debug") opts = info (version <*> helper <*> parser) mempty version = abortOption (InfoMsg (showVersion Paths.version)) - (long "version" <> help "Show the version number") + (long "version" `mappend` help "Show the version number") -startServer :: PortID -> IdeEnvironment -> IO () +startServer :: PortNumber -> IdeEnvironment -> IO () startServer port env = withSocketsDo $ do sock <- listenOnLocalhost port runLogger (runReaderT (forever (loop sock)) env) @@ -141,8 +133,8 @@ startServer port env = withSocketsDo $ do liftIO (hClose h) -acceptCommand :: (MonadIO m, MonadLogger m, MonadError T.Text m) - => Socket -> m (T.Text, Handle) +acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m) + => Socket -> m (Text, Handle) acceptCommand sock = do h <- acceptConnection $(logDebug) "Accepted a connection" diff --git a/purescript.cabal b/purescript.cabal index e597b61399..57f7ef17ff 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -101,7 +101,6 @@ library aeson >= 0.8 && < 0.12, aeson-better-errors >= 0.8, ansi-terminal >= 0.6.2 && < 0.7, - async, base-compat >=0.6.0, bower-json >= 0.8, boxes >= 0.1.4 && < 0.2.0, @@ -126,6 +125,7 @@ library pipes >= 4.0.0 && < 4.2.0, pipes-http -any, process >= 1.2.0 && < 1.5, + protolude >= 0.1.5, regex-tdfa -any, safe >= 0.3.9 && < 0.4, semigroups >= 0.16.2 && < 0.19, @@ -435,6 +435,7 @@ executable psc-ide-server mtl -any, network -any, optparse-applicative >= 0.12.1, + protolude >= 0.1.5, stm -any, text -any, transformers -any, @@ -475,6 +476,7 @@ test-suite tests optparse-applicative -any, parsec -any, process -any, + protolude >= 0.1.5, silently -any, stm -any, text -any, diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index e2c32aed5b..27f52f5f47 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -21,19 +21,9 @@ module Language.PureScript.Ide , printModules ) where -import Prelude () -import Prelude.Compat +import Protolude -import Control.Concurrent.Async -import Control.Monad.Error.Class -import Control.Monad.IO.Class import "monad-logger" Control.Monad.Logger -import Control.Monad.Reader -import Data.Foldable -import Data.Maybe (catMaybes) -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T import qualified Language.PureScript as P import qualified Language.PureScript.Ide.CaseSplit as CS import Language.PureScript.Ide.Command @@ -50,7 +40,6 @@ import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import System.Directory -import System.Exit import System.FilePath handleCommand :: (Ide m, MonadLogger m, MonadError PscIdeError m) => @@ -86,7 +75,7 @@ handleCommand (Import fp outfp filters (AddImportForIdentifier ident)) = do handleCommand (Rebuild file) = rebuildFile file handleCommand Cwd = - TextResult . T.pack <$> liftIO getCurrentDirectory + TextResult . toS <$> liftIO getCurrentDirectory handleCommand Reset = resetIdeState *> pure (TextResult "State has been reset.") handleCommand Quit = liftIO exitSuccess @@ -127,7 +116,7 @@ listAvailableModules = do liftIO $ do contents <- getDirectoryContents oDir let cleaned = filter (`notElem` [".", ".."]) contents - return (ModuleList (map T.pack cleaned)) + return (ModuleList (map toS cleaned)) caseSplit :: (Ide m, MonadError PscIdeError m) => Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index e318cdc603..880470ea86 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -23,14 +23,8 @@ module Language.PureScript.Ide.CaseSplit , caseSplit ) where -import Prelude () -import Prelude.Compat hiding (lex) - -import Control.Arrow (second) -import Control.Monad.Error.Class -import Data.List (find) -import Data.Monoid -import Data.Text (Text) +import Protolude hiding (Constructor) + import qualified Data.Text as T import qualified Language.PureScript as P @@ -56,7 +50,7 @@ noAnnotations = WildcardAnnotations False caseSplit :: (Ide m, MonadError PscIdeError m) => Text -> m [Constructor] caseSplit q = do - type' <- parseType' (T.unpack q) + type' <- parseType' q (tc, args) <- splitTypeConstructor type' (EDType _ _ (P.DataType typeVars ctors)) <- findTypeDeclaration tc let applyTypeVars = P.everywhereOnTypes (P.replaceAllTypeVars (zip (map fst typeVars) args)) @@ -115,26 +109,26 @@ makePattern t x y wsa = makePattern' (T.take x t) (T.drop y t) addClause :: (MonadError PscIdeError m) => Text -> WildcardAnnotations -> m [Text] addClause s wca = do - (fName, fType) <- parseTypeDeclaration' (T.unpack s) - let (args, _) = splitFunctionType fType + (fName, fType) <- parseTypeDeclaration' s + let args = splitFunctionType fType template = runIdentT fName <> " " <> T.unwords (map (prettyPrintWildcard wca) args) <> " = ?" <> (T.strip . runIdentT $ fName) pure [s, template] parseType' :: (MonadError PscIdeError m) => - String -> m P.Type + Text -> m P.Type parseType' s = - case P.lex "" s >>= P.runTokenParser "" (P.parseType <* Parsec.eof) of + case P.lex "" (toS s) >>= P.runTokenParser "" (P.parseType <* Parsec.eof) of Right type' -> pure type' Left err -> throwError (GeneralError ("Parsing the splittype failed with:" - ++ show err)) + <> show err)) -parseTypeDeclaration' :: (MonadError PscIdeError m) => String -> m (P.Ident, P.Type) +parseTypeDeclaration' :: (MonadError PscIdeError m) => Text -> m (P.Ident, P.Type) parseTypeDeclaration' s = let x = do - ts <- P.lex "" s + ts <- P.lex "" (toS s) P.runTokenParser "" (P.parseDeclaration <* Parsec.eof) ts in case unwrapPositioned <$> x of @@ -142,13 +136,12 @@ parseTypeDeclaration' s = Right _ -> throwError (GeneralError "Found a non-type-declaration") Left err -> throwError (GeneralError ("Parsing the typesignature failed with: " - ++ show err)) + <> show err)) -splitFunctionType :: P.Type -> ([P.Type], P.Type) -splitFunctionType t = (arguments, returns) +splitFunctionType :: P.Type -> [P.Type] +splitFunctionType t = fromMaybe [] arguments where - returns = last splitted - arguments = init splitted + arguments = initMay splitted splitted = splitType' t splitType' (P.ForAll _ t' _) = splitType' t' splitType' (P.ConstrainedType _ t') = splitType' t' diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 6fb0e5cc17..876b21e7c6 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -16,17 +16,15 @@ module Language.PureScript.Ide.Command where -import Prelude () -import Prelude.Compat +import Protolude -import Control.Monad import Data.Aeson -import Data.Text (Text) import qualified Language.PureScript as P import Language.PureScript.Ide.CaseSplit import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types +import System.FilePath data Command = Load [P.ModuleName] @@ -70,7 +68,7 @@ data ImportCommand instance FromJSON ImportCommand where parseJSON = withObject "ImportCommand" $ \o -> do - (command :: String) <- o .: "importCommand" + (command :: Text) <- o .: "importCommand" case command of "addImplicitImport" -> AddImplicitImport <$> (P.moduleNameFromString <$> o .: "module") @@ -82,7 +80,7 @@ data ListType = LoadedModules | Imports FilePath | AvailableModules instance FromJSON ListType where parseJSON = withObject "ListType" $ \o -> do - (listType' :: String) <- o .: "type" + (listType' :: Text) <- o .: "type" case listType' of "import" -> Imports <$> o .: "file" "loadedModules" -> pure LoadedModules @@ -91,7 +89,7 @@ instance FromJSON ListType where instance FromJSON Command where parseJSON = withObject "command" $ \o -> do - (command :: String) <- o .: "command" + (command :: Text) <- o .: "command" case command of "list" -> List <$> o .:? "params" .!= LoadedModules "cwd" -> pure Cwd diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 54a04a3422..cbcf307a9f 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -1,12 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Completion - (getCompletions, getExactMatches) - where + ( getCompletions + , getExactMatches + ) where -import Prelude () -import Prelude.Compat +import Protolude -import Data.Text (Text) import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types @@ -15,12 +14,11 @@ import Language.PureScript.Ide.Types -- and sorts the found Completions according to the Matching Score getCompletions :: [Filter] -> Matcher -> [Module] -> [Match] getCompletions filters matcher modules = - runMatcher matcher $ completionsFromModules (applyFilters filters modules) + runMatcher matcher (completionsFromModules (applyFilters filters modules)) getExactMatches :: Text -> [Filter] -> [Module] -> [Match] getExactMatches search filters modules = - completionsFromModules $ - applyFilters (equalityFilter search : filters) modules + completionsFromModules (applyFilters (equalityFilter search : filters) modules) completionsFromModules :: [Module] -> [Match] completionsFromModules = foldMap completionFromModule diff --git a/src/Language/PureScript/Ide/Conversions.hs b/src/Language/PureScript/Ide/Conversions.hs index 95a110836c..d0a46ebbfb 100644 --- a/src/Language/PureScript/Ide/Conversions.hs +++ b/src/Language/PureScript/Ide/Conversions.hs @@ -14,23 +14,22 @@ module Language.PureScript.Ide.Conversions where -import Prelude.Compat -import Data.Text (Text) -import qualified Data.Text as T +import Protolude +import Data.Text (unwords, lines, strip) import qualified Language.PureScript as P runProperNameT :: P.ProperName a -> Text -runProperNameT = T.pack . P.runProperName +runProperNameT = toS . P.runProperName runIdentT :: P.Ident -> Text -runIdentT = T.pack . P.runIdent +runIdentT = toS . P.runIdent runOpNameT :: P.OpName a -> Text -runOpNameT = T.pack . P.runOpName +runOpNameT = toS . P.runOpName runModuleNameT :: P.ModuleName -> Text -runModuleNameT = T.pack . P.runModuleName +runModuleNameT = toS . P.runModuleName prettyTypeT :: P.Type -> Text -prettyTypeT = T.unwords . fmap T.strip . T.lines . T.pack . P.prettyPrintType +prettyTypeT = unwords . map strip . lines . toS . P.prettyPrintType diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 58b4078da4..5bf12b833d 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -14,25 +14,22 @@ {-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Error - (ErrorMsg, PscIdeError(..), textError) - where + ( PscIdeError(..) + , textError + ) where -import Prelude.Compat +import Protolude import Data.Aeson -import Data.Monoid -import Data.Text (Text, pack) import Language.PureScript.Errors.JSON import Language.PureScript.Ide.Types (ModuleIdent) import qualified Text.Parsec.Error as P -type ErrorMsg = String - data PscIdeError - = GeneralError ErrorMsg + = GeneralError Text | NotFound Text | ModuleNotFound ModuleIdent | ModuleFileNotFound ModuleIdent - | ParseError P.ParseError ErrorMsg + | ParseError P.ParseError Text | RebuildError [JSONError] instance ToJSON PscIdeError where @@ -46,7 +43,7 @@ instance ToJSON PscIdeError where ] textError :: PscIdeError -> Text -textError (GeneralError msg) = pack msg +textError (GeneralError msg) = msg textError (NotFound ident) = "Symbol '" <> ident <> "' not found." textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found." textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found" @@ -54,5 +51,5 @@ textError (ParseError parseError msg) = let escape = show -- escape newlines and other special -- chars so we can send the error -- over the socket as a single line - in pack $ msg <> ": " <> show (escape parseError) -textError (RebuildError err) = pack (show err) + in msg <> ": " <> escape parseError +textError (RebuildError err) = show err diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 5cdf718dd7..45a7566b0c 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -26,17 +26,10 @@ module Language.PureScript.Ide.Externs unwrapPositionedRef ) where -import Prelude () -import Prelude.Compat +import Protolude -import Control.Monad.Error.Class -import Control.Monad.IO.Class import Data.Aeson (decodeStrict) import Data.List (nub) -import Data.Maybe (mapMaybe) -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T import qualified Data.ByteString as BS import Language.PureScript.Ide.Error (PscIdeError (..)) import Language.PureScript.Ide.Types @@ -44,17 +37,16 @@ import Language.PureScript.Ide.Util import qualified Language.PureScript as P +import System.FilePath + readExternFile :: (MonadIO m, MonadError PscIdeError m) => FilePath -> m P.ExternsFile readExternFile fp = do parseResult <- liftIO (decodeStrict <$> BS.readFile fp) case parseResult of - Nothing -> throwError . GeneralError $ "Parsing the extern at: " ++ fp ++ " failed" + Nothing -> throwError . GeneralError $ "Parsing the extern at: " <> toS fp <> " failed" Just externs -> pure externs -identToText :: P.Ident -> Text -identToText = T.pack . P.runIdent - convertExterns :: P.ExternsFile -> ModuleOld convertExterns ef = (runModuleNameT moduleName, exportDecls ++ importDecls ++ decls ++ operatorDecls ++ tyOperatorDecls) where @@ -96,7 +88,7 @@ convertDecl P.EDTypeSynonym{..} = Just $ convertDecl P.EDDataConstructor{..} = Just $ DataConstructor (runProperNameT edDataCtorName) edDataCtorTypeCtor edDataCtorType convertDecl P.EDValue{..} = Just $ - ValueDeclaration (identToText edValueName) edValueType + ValueDeclaration (runIdentT edValueName) edValueType convertDecl P.EDClass{..} = Just $ TypeClassDeclaration edClassName convertDecl P.EDInstance{} = Nothing @@ -104,7 +96,7 @@ convertOperator :: P.ExternsFixity -> ExternDecl convertOperator P.ExternsFixity{..} = ValueOperator efOperator - (T.pack (P.showQualified (either P.runIdent P.runProperName) efAlias)) + (toS (P.showQualified (either P.runIdent P.runProperName) efAlias)) efPrecedence efAssociativity @@ -112,7 +104,7 @@ convertTypeOperator :: P.ExternsTypeFixity -> ExternDecl convertTypeOperator P.ExternsTypeFixity{..} = TypeOperator efTypeOperator - (T.pack (P.showQualified P.runProperName efTypeAlias)) + (toS (P.showQualified P.runProperName efTypeAlias)) efTypePrecedence efTypeAssociativity @@ -125,7 +117,7 @@ unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = x unwrapPositionedRef x = x convertModule :: ModuleOld -> Module -convertModule (mn, decls) = (P.moduleNameFromString (T.unpack mn), mapMaybe convertDeclaration decls) +convertModule (mn, decls) = (P.moduleNameFromString (toS mn), mapMaybe convertDeclaration decls) where convertDeclaration :: ExternDecl -> Maybe IdeDeclaration convertDeclaration d = case d of ValueDeclaration i t -> Just (IdeValue i t) diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 630a0039e8..5d1f67b3a1 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -24,14 +24,10 @@ module Language.PureScript.Ide.Filter , applyFilters ) where -import Prelude () -import Prelude.Compat +import Protolude hiding (isPrefixOf) -import Control.Monad import Data.Aeson -import Data.Foldable -import Data.Monoid -import Data.Text (Text, isPrefixOf) +import Data.Text (isPrefixOf) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import qualified Language.PureScript as P @@ -51,7 +47,7 @@ moduleFilter' moduleIdents = filter (flip elem moduleIdents . fst) -- | Only keeps Identifiers that start with the given prefix prefixFilter :: Text -> Filter -prefixFilter "" = mkFilter id +prefixFilter "" = mkFilter identity prefixFilter t = mkFilter $ identFilter prefix t where prefix :: IdeDeclaration -> Text -> Bool @@ -80,7 +76,7 @@ applyFilters = runFilter . fold instance FromJSON Filter where parseJSON = withObject "filter" $ \o -> do - (filter' :: String) <- o .: "filter" + (filter' :: Text) <- o .: "filter" case filter' of "exact" -> do params <- o .: "params" diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 5ecbae2e78..296dce8ffe 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -29,17 +29,9 @@ module Language.PureScript.Ide.Imports ) where -import Prelude.Compat -import Control.Applicative ((<|>)) -import Control.Monad.Error.Class -import Control.Monad.IO.Class -import Data.Bifunctor (first, second) -import Data.Function (on) -import qualified Data.List as List -import Data.Maybe (isNothing) -import Data.Monoid ((<>)) -import Data.Text (Text) +import Protolude import qualified Data.Text as T +import Data.List (nubBy, findIndex) import qualified Data.Text.IO as TIO import qualified Language.PureScript as P import Language.PureScript.Ide.Completion @@ -50,6 +42,7 @@ import Language.PureScript.Ide.Filter import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import System.FilePath data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) deriving (Eq, Show) @@ -85,7 +78,7 @@ parseImportsFromFile fp = do Right res -> pure res Left err -> throwError (GeneralError err) -parseImportsWithModuleName :: [Text] -> Either String (P.ModuleName, [Import]) +parseImportsWithModuleName :: [Text] -> Either Text (P.ModuleName, [Import]) parseImportsWithModuleName ls = do (P.Module _ _ mn decls _) <- moduleParse ls pure (mn, concatMap mkImport (unwrapPositioned <$> decls)) @@ -95,13 +88,13 @@ parseImportsWithModuleName ls = do mkImport (P.ImportDeclaration mn it qual) = [Import mn it qual] mkImport _ = [] -sliceImportSection :: [Text] -> Either String (P.ModuleName, [Text], [Import], [Text]) +sliceImportSection :: [Text] -> Either Text (P.ModuleName, [Text], [Import], [Text]) sliceImportSection ts = case foldl step (ModuleHeader 0) (zip [0..] ts) of Res start end -> let (moduleHeader, (importSection, remainingFile)) = - List.splitAt (succ (end - start)) `second` List.splitAt start ts + splitAt (succ (end - start)) `second` splitAt start ts in (\(mn, is) -> (mn, moduleHeader, is, remainingFile)) <$> parseImportsWithModuleName (moduleHeader <> importSection) @@ -109,7 +102,7 @@ sliceImportSection ts = -- If we don't find any imports, we insert a newline after the module -- declaration and begin a new importsection ModuleHeader ix -> - let (moduleHeader, remainingFile) = List.splitAt (succ ix) ts + let (moduleHeader, remainingFile) = splitAt (succ ix) ts in (\(mn, is) -> (mn, moduleHeader ++ [""], is, remainingFile)) <$> parseImportsWithModuleName moduleHeader @@ -151,7 +144,7 @@ step (ImportSection start lastImportLine) (ix, l) | otherwise = Res start lastImportLine step (Res start end) _ = Res start end -moduleParse :: [Text] -> Either String P.Module +moduleParse :: [Text] -> Either Text P.Module moduleParse t = first show $ do tokens <- (P.lex "" . T.unpack . T.unlines) t P.runTokenParser "" P.parseModule tokens @@ -233,11 +226,11 @@ addExplicitImport' decl moduleName imports = dtor' = P.ProperName (T.unpack dtor) in updateAtFirstOrPrepend (matchType tn) (insertDtor dtor') (P.TypeRef tn (Just [dtor'])) refs - insertDeclIntoRefs dr refs = List.nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) + insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) insertDtor dtor (P.TypeRef tn' dtors) = case dtors of - Just dtors' -> P.TypeRef tn' (Just (List.nub (dtor : dtors'))) + Just dtors' -> P.TypeRef tn' (Just (ordNub (dtor : dtors'))) -- This means the import was opened. We don't add anything in this case -- import Data.Maybe (Maybe(..)) -> import Data.Maybe (Maybe(Just)) Nothing -> P.TypeRef tn' Nothing @@ -249,10 +242,10 @@ addExplicitImport' decl moduleName imports = updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a] updateAtFirstOrPrepend p t d l = - case List.findIndex p l of + case findIndex p l of Nothing -> d : l Just ix -> - let (x, a : y) = List.splitAt ix l + let (x, a : y) = splitAt ix l in x ++ [t a] ++ y -- | Looks up the given identifier in the currently loaded modules. @@ -321,7 +314,7 @@ prettyPrintImport' (Import mn idt qual) = T.pack $ "import " ++ P.prettyPrintImport mn idt qual prettyPrintImportSection :: [Import] -> [Text] -prettyPrintImportSection imports = map prettyPrintImport' (List.sort imports) +prettyPrintImportSection imports = map prettyPrintImport' (sort imports) -- | Writes a list of lines to @Just filepath@ and responds with a @TextResult@, -- or returns the lines as a @MultilineTextResult@ if @Nothing@ was given as the diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index 5e7575e684..e1b11fa845 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -21,16 +21,9 @@ module Language.PureScript.Ide.Matcher , runMatcher ) where -import Prelude () -import Prelude.Compat +import Protolude -import Control.Monad import Data.Aeson -import Data.Function (on) -import Data.List (sortBy) -import Data.Maybe (mapMaybe) -import Data.Monoid -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Language.PureScript.Ide.Types @@ -45,7 +38,7 @@ newtype Matcher = Matcher (Endo [Match]) deriving (Monoid) instance FromJSON Matcher where parseJSON = withObject "matcher" $ \o -> do - (matcher :: Maybe String) <- o .:? "matcher" + (matcher :: Maybe Text) <- o .:? "matcher" case matcher of Just "flex" -> do params <- o .: "params" @@ -109,7 +102,7 @@ flexScore :: Text -> Text -> Maybe Double flexScore pat str = case T.uncons pat of Nothing -> Nothing - Just (first, p) -> + Just (first', p) -> case TE.encodeUtf8 str =~ TE.encodeUtf8 pat' :: (Int, Int) of (-1,0) -> Nothing (start,len) -> Just $ calcScore start (start + len) @@ -120,11 +113,11 @@ flexScore pat str = -- escape prepends a backslash to "regexy" characters to prevent the -- matcher from crashing when trying to build the regex escape :: Char -> Text - escape c = if c `elem` ("[\\^$.|?*+(){}" :: String) + escape c = if c `elem` T.unpack "[\\^$.|?*+(){}" then T.pack ['\\', c] else T.singleton c -- This just interleaves the search pattern with .* -- abcd[*] -> a.*b.*c.*d.*[*] - pat' = escape first <> foldMap (<> ".*") escapedPattern + pat' = escape first' <> foldMap (<> ".*") escapedPattern calcScore start end = 100.0 / fromIntegral ((1 + start) * (end - start + 1)) diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs index b8a8b50139..53e10a7db2 100644 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -16,18 +16,12 @@ module Language.PureScript.Ide.Pursuit where -import Prelude () -import Prelude.Compat +import Protolude import qualified Control.Exception as E import Data.Aeson -import Data.ByteString (ByteString) import Data.ByteString.Lazy (fromStrict) -import Data.Foldable (toList) -import Data.Maybe (mapMaybe) -import Data.Monoid ((<>)) import Data.String -import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Ide.Types import Network.HTTP.Types.Header (hAccept) @@ -41,12 +35,12 @@ queryPursuit q = do let qClean = T.dropWhileEnd (== '.') q req' <- parseUrl "http://pursuit.purescript.org/search" let req = req' - { queryString=("q=" <> (fromString . T.unpack) qClean) + { queryString= "q=" <> (fromString . T.unpack) qClean , requestHeaders=[(hAccept, "application/json")] } m <- newManager tlsManagerSettings withHTTP req m $ \resp -> - P.fold (<>) "" id $ responseBody resp + P.fold (<>) "" identity (responseBody resp) handler :: HttpException -> IO [a] @@ -59,7 +53,7 @@ searchPursuitForDeclarations query = let results' = decode (fromStrict r) :: Maybe Array case results' of Nothing -> pure [] - Just results -> pure (mapMaybe isDeclarationResponse (map fromJSON (toList results)))) `E.catch` + Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))) `E.catch` handler where isDeclarationResponse (Success a@DeclarationResponse{}) = Just a @@ -71,7 +65,7 @@ findPackagesForModuleIdent query = let results' = decode (fromStrict r) :: Maybe Array case results' of Nothing -> pure [] - Just results -> pure (mapMaybe isModuleResponse (map fromJSON (toList results)))) `E.catch` + Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))) `E.catch` handler where isModuleResponse (Success a@ModuleResponse{}) = Just a diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 391637a005..9dad7a6731 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -8,14 +8,12 @@ module Language.PureScript.Ide.Rebuild ( rebuildFile ) where -import Control.Monad.Error.Class -import Control.Monad.IO.Class +import Protolude + import "monad-logger" Control.Monad.Logger -import Control.Monad.Reader -import Control.Monad.Trans.Except +import qualified Data.List as List import qualified Data.Map.Lazy as M -import Data.Maybe (fromJust, mapMaybe) -import Data.Monoid ((<>)) +import Data.Maybe (fromJust) import qualified Data.Set as S import qualified Language.PureScript as P import Language.PureScript.Errors.JSON @@ -23,8 +21,8 @@ import Language.PureScript.Ide.Error import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import Prelude.Compat import System.IO.UTF8 (readUTF8File) +import System.FilePath -- | Given a filepath performs the following steps: -- @@ -49,7 +47,7 @@ rebuildFile path = do input <- liftIO (readUTF8File path) - m <- case snd <$> P.parseModuleFromFile id (path, input) of + m <- case snd <$> P.parseModuleFromFile identity (path, input) of Left parseError -> throwError . RebuildError . toJSONErrors False P.Error @@ -106,8 +104,8 @@ rebuildModuleOpen makeEnv externs m = do data MakeActionsEnv = MakeActionsEnv { maeOutputDirectory :: FilePath - , maeFilePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath) - , maeForeignPathMap :: M.Map P.ModuleName FilePath + , maeFilePathMap :: Map P.ModuleName (Either P.RebuildPolicy FilePath) + , maeForeignPathMap :: Map P.ModuleName FilePath , maePrefixComment :: Bool } @@ -137,7 +135,7 @@ shushCodegen ma MakeActionsEnv{..} = sortExterns :: (Ide m, MonadError PscIdeError m) => P.Module - -> M.Map P.ModuleName P.ExternsFile + -> Map P.ModuleName P.ExternsFile -> m [P.ExternsFile] sortExterns m ex = do sorted' <- runExceptT @@ -149,11 +147,11 @@ sortExterns m ex = do case sorted' of Left _ -> throwError (GeneralError "There was a cycle in the dependencies") Right (sorted, graph) -> do - let deps = fromJust (lookup (P.getModuleName m) graph) + let deps = fromJust (List.lookup (P.getModuleName m) graph) pure $ mapMaybe getExtern (deps `inOrderOf` map P.getModuleName sorted) where mkShallowModule P.ExternsFile{..} = - P.Module undefined [] efModuleName (map mkImport efImports) Nothing + P.Module (P.internalModuleSourceSpan "") [] efModuleName (map mkImport efImports) Nothing mkImport (P.ExternsImport mn it iq) = P.ImportDeclaration mn it iq getExtern mn = M.lookup mn ex diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index d3e7664552..4b9c308c80 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -24,16 +24,14 @@ module Language.PureScript.Ide.Reexports ) where -import Prelude () -import Prelude.Compat +import Protolude import Data.List (union) -import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe import qualified Data.Text as T import Language.PureScript.Ide.Types import Language.PureScript.Ide.Externs +import qualified Language.PureScript as P getReexports :: ModuleOld -> [ExternDecl] getReexports (mn, decls)= concatMap getExport decls @@ -59,7 +57,7 @@ replaceExportWithAliases decls ident = replaceReexport :: ExternDecl -> ModuleOld -> ModuleOld -> ModuleOld replaceReexport e@(Export _) (m, decls) (_, newDecls) = (m, filter (/= e) decls `union` newDecls) -replaceReexport _ _ _ = error "Should only get Exports here." +replaceReexport _ _ _ = P.internalError "Should only get Exports here" emptyModule :: ModuleOld emptyModule = ("Empty", []) @@ -79,7 +77,7 @@ replaceReexports m db = result go :: ModuleOld -> ExternDecl -> ModuleOld go m' re@(Export name) = replaceReexport re m' (getModule name) - go _ _ = error "partiality! woohoo" + go _ _ = P.internalError "Should only get Exports here" getModule :: ModuleIdent -> ModuleOld getModule name = clean res diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 8297a20144..e0583aaa9d 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -16,27 +16,20 @@ module Language.PureScript.Ide.SourceFile where -import Prelude +import Protolude -import Control.Monad.Error.Class -import Control.Monad.IO.Class -import Control.Monad.Trans.Except -import Data.Maybe (mapMaybe) -import Data.Monoid -import qualified Data.Text as T -import qualified Language.PureScript.AST.Declarations as D -import qualified Language.PureScript.AST.SourcePos as SP +import qualified Language.PureScript as P import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Util import Language.PureScript.Ide.Externs (unwrapPositioned, unwrapPositionedRef) import Language.PureScript.Ide.Types -import qualified Language.PureScript.Names as N -import qualified Language.PureScript.Parser as P import System.Directory +import System.FilePath import System.IO.UTF8 (readUTF8File) parseModuleFromFile :: (MonadIO m, MonadError PscIdeError m) => - FilePath -> m D.Module + FilePath -> m P.Module parseModuleFromFile fp = do exists <- liftIO (doesFileExist fp) if exists @@ -49,14 +42,14 @@ parseModuleFromFile fp = do -- data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) -getDeclarations :: D.Module -> [D.Declaration] -getDeclarations (D.Module _ _ _ declarations _) = declarations +getDeclarations :: P.Module -> [P.Declaration] +getDeclarations (P.Module _ _ _ declarations _) = declarations -getImports :: D.Module -> [D.Declaration] -getImports (D.Module _ _ _ declarations _) = +getImports :: P.Module -> [(P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)] +getImports (P.Module _ _ _ declarations _) = mapMaybe isImport declarations where - isImport (D.PositionedDeclaration _ _ (i@D.ImportDeclaration{})) = Just i + isImport (P.PositionedDeclaration _ _ (P.ImportDeclaration a b c)) = Just (a, b, c) isImport _ = Nothing getImportsForFile :: (MonadIO m, MonadError PscIdeError m) => @@ -66,53 +59,50 @@ getImportsForFile fp = do let imports = getImports module' pure (mkModuleImport . unwrapPositionedImport <$> imports) where - mkModuleImport (D.ImportDeclaration mn importType' qualifier) = + mkModuleImport (mn, importType', qualifier) = ModuleImport - (T.pack (N.runModuleName mn)) + (runModuleNameT mn) importType' - (T.pack . N.runModuleName <$> qualifier) - mkModuleImport _ = error "Shouldn't have gotten anything but Imports here" - unwrapPositionedImport (D.ImportDeclaration mn importType' qualifier) = - D.ImportDeclaration mn (unwrapImportType importType') qualifier - unwrapPositionedImport x = x - unwrapImportType (D.Explicit decls) = D.Explicit (map unwrapPositionedRef decls) - unwrapImportType (D.Hiding decls) = D.Hiding (map unwrapPositionedRef decls) - unwrapImportType D.Implicit = D.Implicit + (runModuleNameT <$> qualifier) + unwrapPositionedImport (mn, it, q) = (mn, unwrapImportType it, q) + unwrapImportType (P.Explicit decls) = P.Explicit (map unwrapPositionedRef decls) + unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls) + unwrapImportType P.Implicit = P.Implicit -getPositionedImports :: D.Module -> [D.Declaration] -getPositionedImports (D.Module _ _ _ declarations _) = +getPositionedImports :: P.Module -> [P.Declaration] +getPositionedImports (P.Module _ _ _ declarations _) = mapMaybe isImport declarations where - isImport i@(D.PositionedDeclaration _ _ D.ImportDeclaration{}) = Just i + isImport i@(P.PositionedDeclaration _ _ P.ImportDeclaration{}) = Just i isImport _ = Nothing -getDeclPosition :: D.Module -> String -> Maybe SP.SourceSpan +getDeclPosition :: P.Module -> Text -> Maybe P.SourceSpan getDeclPosition m ident = getFirst (foldMap (match ident) decls) where decls = getDeclarations m - match q (D.PositionedDeclaration ss _ decl) = First (if go q decl + match q (P.PositionedDeclaration ss _ decl) = First (if go q decl then Just ss else Nothing) match _ _ = First Nothing - go q (D.DataDeclaration _ name _ constructors) = + go q (P.DataDeclaration _ name _ constructors) = properEqual name q || any (\(x,_) -> properEqual x q) constructors - go q (D.DataBindingGroupDeclaration decls') = any (go q) decls' - go q (D.TypeSynonymDeclaration name _ _) = properEqual name q - go q (D.TypeDeclaration ident' _) = identEqual ident' q - go q (D.ValueDeclaration ident' _ _ _) = identEqual ident' q - go q (D.ExternDeclaration ident' _) = identEqual ident' q - go q (D.ExternDataDeclaration name _) = properEqual name q - go q (D.TypeClassDeclaration name _ _ members) = + go q (P.DataBindingGroupDeclaration decls') = any (go q) decls' + go q (P.TypeSynonymDeclaration name _ _) = properEqual name q + go q (P.TypeDeclaration ident' _) = identEqual ident' q + go q (P.ValueDeclaration ident' _ _ _) = identEqual ident' q + go q (P.ExternDeclaration ident' _) = identEqual ident' q + go q (P.ExternDataDeclaration name _) = properEqual name q + go q (P.TypeClassDeclaration name _ _ members) = properEqual name q || any (go q . unwrapPositioned) members - go q (D.TypeInstanceDeclaration ident' _ _ _ _) = + go q (P.TypeInstanceDeclaration ident' _ _ _ _) = identEqual ident' q go _ _ = False - properEqual x q = N.runProperName x == q - identEqual x q = N.runIdent x == q + properEqual x q = runProperNameT x == q + identEqual x q = runIdentT x == q -goToDefinition :: String -> FilePath -> IO (Maybe SP.SourceSpan) +goToDefinition :: Text -> FilePath -> IO (Maybe P.SourceSpan) goToDefinition q fp = do m <- runExceptT (parseModuleFromFile fp) case m of diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index d9b92cbb38..0af5d3947e 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -33,15 +33,11 @@ module Language.PureScript.Ide.State , populateStage2STM ) where -import Prelude () -import Prelude.Compat +import Protolude import Control.Concurrent.STM -import Control.Monad.IO.Class import "monad-logger" Control.Monad.Logger -import Control.Monad.Reader.Class import qualified Data.Map.Lazy as M -import Data.Monoid import qualified Data.Text as T import Data.Time (getCurrentTime, diffUTCTime) import Language.PureScript.Externs diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index ec63e7dcfb..43ec8f5e90 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -16,22 +16,16 @@ module Language.PureScript.Ide.Types where -import Prelude () -import Prelude.Compat +import Protolude import Control.Concurrent.STM -import Control.Monad -import Control.Monad.Reader.Class -import Control.Monad.Trans import Data.Aeson import Data.Map.Lazy as M -import Data.Maybe (maybeToList) -import Data.Text (Text, pack, unpack) import qualified Language.PureScript.Errors.JSON as P import qualified Language.PureScript as P import Language.PureScript.Ide.Conversions - -import Text.Parsec +import System.FilePath +import Text.Parsec as Parsec import Text.Parsec.Text type Ident = Text @@ -219,7 +213,7 @@ instance FromJSON PursuitResponse where parseJSON (Object o) = do package <- o .: "package" info <- o .: "info" - (type' :: String) <- info .: "type" + (type' :: Text) <- info .: "type" case type' of "module" -> do name <- info .: "module" @@ -234,26 +228,26 @@ instance FromJSON PursuitResponse where typeParse :: Text -> Either Text (Text, Text) typeParse t = case parse parseType "" t of - Right (x,y) -> Right (pack x, pack y) - Left err -> Left (pack (show err)) + Right (x,y) -> Right (x, y) + Left err -> Left (show err) where - parseType :: Parser (String, String) + parseType :: Parser (Text, Text) parseType = do name <- identifier _ <- string "::" spaces type' <- many1 anyChar - pure (unpack name, type') + pure (name, toS type') identifier :: Parser Text identifier = do spaces ident <- -- necessary for being able to parse the following ((++), concat) - between (char '(') (char ')') (many1 (noneOf ", )")) <|> + between (char '(') (char ')') (many1 (noneOf ", )")) Parsec.<|> many1 (noneOf ", )") spaces - pure (pack ident) + pure (toS ident) instance ToJSON PursuitResponse where toJSON (ModuleResponse name package) = diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 2d48bb4b4c..ec786e26e6 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -20,16 +20,12 @@ module Language.PureScript.Ide.Util , completionFromMatch , encodeT , decodeT - , unlessM , module Language.PureScript.Ide.Conversions ) where -import Prelude.Compat -import Control.Monad (unless) +import Protolude import Data.Aeson -import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Lazy (fromStrict, toStrict) import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) import qualified Language.PureScript as P import Language.PureScript.Ide.Types @@ -51,7 +47,7 @@ identifierFromMatch (Match _ ed) = identifierFromIdeDeclaration ed completionFromMatch :: Match -> Completion completionFromMatch (Match m' d) = case d of IdeValue name type' -> Completion (m, name, prettyTypeT type') - IdeType name kind -> Completion (m, runProperNameT name, T.pack $ P.prettyPrintKind kind) + IdeType name kind -> Completion (m, runProperNameT name, toS (P.prettyPrintKind kind)) IdeTypeSynonym name kind -> Completion (m, runProperNameT name, prettyTypeT kind) IdeDataConstructor name _ type' -> Completion (m, name, prettyTypeT type') IdeTypeClass name -> Completion (m, runProperNameT name, "class") @@ -64,13 +60,10 @@ completionFromMatch (Match m' d) = case d of P.Infix -> "infix" P.Infixl -> "infixl" P.Infixr -> "infixr" - in T.unwords [asso, T.pack (show p), r, "as", runOpNameT o] + in T.unwords [asso, show p, r, "as", runOpNameT o] encodeT :: (ToJSON a) => a -> Text -encodeT = toStrict . decodeUtf8 . encode +encodeT = toS . decodeUtf8 . encode decodeT :: (FromJSON a) => Text -> Maybe a -decodeT = decode . encodeUtf8 . fromStrict - -unlessM :: Monad m => m Bool -> m () -> m () -unlessM cond act = cond >>= flip unless act +decodeT = decode . encodeUtf8 . toS diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs index 8c9b7b142b..7990ff09ce 100644 --- a/src/Language/PureScript/Ide/Watcher.hs +++ b/src/Language/PureScript/Ide/Watcher.hs @@ -14,14 +14,12 @@ module Language.PureScript.Ide.Watcher where -import Control.Concurrent (threadDelay) +import Protolude + import Control.Concurrent.STM -import Control.Monad -import Control.Monad.Trans.Except import Language.PureScript.Ide.Externs import Language.PureScript.Ide.State import Language.PureScript.Ide.Types -import Prelude import System.FilePath import System.FSNotify diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index 461850fbbc..8b89ac7618 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.FilterSpec where -import Data.Text (Text) +import Protolude import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Types import qualified Language.PureScript as P @@ -10,11 +11,12 @@ import Test.Hspec value :: Text -> IdeDeclaration value s = IdeValue s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) +moduleA, moduleB :: Module +moduleA = (P.moduleNameFromString "Module.A", [value "function1"]) +moduleB = (P.moduleNameFromString "Module.B", [value "data1"]) + modules :: [Module] -modules = - [ (P.moduleNameFromString "Module.A", [value "function1"]) - , (P.moduleNameFromString "Module.B", [value "data1"]) - ] +modules = [moduleA, moduleB] runEq :: Text -> [Module] runEq s = runFilter (equalityFilter s) modules @@ -31,20 +33,20 @@ spec = do it "removes empty modules" $ runEq "test" `shouldBe` [] it "keeps function declarations that are equal" $ - runEq "function1" `shouldBe` [head modules] + runEq "function1" `shouldBe` [moduleA] it "keeps data declarations that are equal" $ - runEq "data1" `shouldBe` [modules !! 1] + runEq "data1" `shouldBe` [moduleB] describe "prefixFilter" $ do it "keeps everything on empty string" $ runPrefix "" `shouldBe` modules it "keeps functionname prefix matches" $ - runPrefix "fun" `shouldBe` [head modules] + runPrefix "fun" `shouldBe` [moduleA] it "keeps data decls prefix matches" $ - runPrefix "dat" `shouldBe` [modules !! 1] + runPrefix "dat" `shouldBe` [moduleB] describe "moduleFilter" $ do it "removes everything on empty input" $ runModule [] `shouldBe` [] it "only keeps the specified modules" $ - runModule [P.moduleNameFromString "Module.A"] `shouldBe` [head modules] + runModule [P.moduleNameFromString "Module.A"] `shouldBe` [moduleA] it "ignores modules that are not in scope" $ - runModule (P.moduleNameFromString <$> ["Module.A", "Unknown"]) `shouldBe` [head modules] + runModule (P.moduleNameFromString <$> ["Module.A", "Unknown"]) `shouldBe` [moduleA] diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs index b6365deaeb..1d7abbbcbb 100644 --- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs +++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs @@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.Imports.IntegrationSpec where -import Control.Monad (void) -import Data.Text (Text) + +import Protolude + import qualified Data.Text as T import qualified Data.Text.IO as TIO import qualified Language.PureScript.Ide.Integration as Integration diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index a87c45da0b..c8b2ba53a0 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.ImportsSpec where -import Data.Maybe (fromJust) -import Data.Text (Text) +import Protolude +import Unsafe (fromJust) + import qualified Language.PureScript as P import Language.PureScript.Ide.Imports import Language.PureScript.Ide.Types @@ -17,11 +19,9 @@ simpleFile = ] splitSimpleFile :: (P.ModuleName, [Text], [Import], [Text]) -splitSimpleFile = fromRight $ sliceImportSection simpleFile +splitSimpleFile = fromRight (sliceImportSection simpleFile) where - fromRight (Right r) = r - fromRight (Left _) = error "fromRight" - + fromRight = fromJust . rightToMaybe withImports :: [Text] -> [Text] withImports is = take 2 simpleFile ++ is ++ drop 2 simpleFile diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs index c334988670..21a6996808 100644 --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -14,6 +14,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.Integration ( -- managing the server process @@ -44,19 +45,15 @@ module Language.PureScript.Ide.Integration , parseTextResult ) where -import Control.Concurrent (threadDelay) -import Control.Exception -import Control.Monad (join, when) +import Protolude +import Unsafe (fromJust) + import Data.Aeson import Data.Aeson.Types -import qualified Data.ByteString.Lazy.UTF8 as BSL -import Data.Either (isRight) -import Data.Maybe (fromJust, isNothing, fromMaybe) import qualified Data.Text as T import qualified Data.Vector as V import Language.PureScript.Ide.Util import System.Directory -import System.Exit import System.FilePath import System.IO.Error (mkIOError, userErrorType) import System.Process @@ -81,26 +78,23 @@ stopServer = terminateProcess withServer :: IO a -> IO a withServer s = do _ <- startServer - started <- tryNTimes 5 (shush <$> (try getCwd :: IO (Either SomeException String))) + started <- tryNTimes 5 (rightToMaybe <$> (try getCwd :: IO (Either SomeException Text))) when (isNothing started) $ throwIO (mkIOError userErrorType "psc-ide-server didn't start in time" Nothing Nothing) r <- s quitServer pure r -shush :: Either a b -> Maybe b -shush = either (const Nothing) Just - -- project management utils compileTestProject :: IO Bool compileTestProject = do pdir <- projectDirectory (_, _, _, procHandle) <- createProcess $ - (shell $ "psc " ++ fileGlob) { cwd = Just pdir - , std_out = CreatePipe - , std_err = CreatePipe - } + (shell . toS $ "psc " <> fileGlob) { cwd = Just pdir + , std_out = CreatePipe + , std_err = CreatePipe + } r <- tryNTimes 5 (getProcessExitCode procHandle) pure (fromMaybe False (isSuccess <$> r)) @@ -122,24 +116,17 @@ deleteOutputFolder = do deleteFileIfExists :: FilePath -> IO () deleteFileIfExists fp = whenM (doesFileExist fp) (removeFile fp) -whenM :: Monad m => m Bool -> m () -> m () -whenM p f = do - x <- p - when x f - isSuccess :: ExitCode -> Bool isSuccess ExitSuccess = True isSuccess (ExitFailure _) = False -fileGlob :: String -fileGlob = unwords - [ "\"src/**/*.purs\"" - ] +fileGlob :: Text +fileGlob = "\"src/**/*.purs\"" -- Integration Testing API -sendCommand :: Value -> IO String -sendCommand v = readCreateProcess +sendCommand :: Value -> IO Text +sendCommand v = toS <$> readCreateProcess ((shell "psc-ide-client") { std_out=CreatePipe , std_err=CreatePipe }) @@ -147,68 +134,68 @@ sendCommand v = readCreateProcess quitServer :: IO () quitServer = do - let quitCommand = object ["command" .= ("quit" :: String)] - _ <- try $ sendCommand quitCommand :: IO (Either SomeException String) + let quitCommand = object ["command" .= ("quit" :: Text)] + _ <- try $ sendCommand quitCommand :: IO (Either SomeException Text) return () reset :: IO () reset = do - let resetCommand = object ["command" .= ("reset" :: String)] - _ <- try $ sendCommand resetCommand :: IO (Either SomeException String) + let resetCommand = object ["command" .= ("reset" :: Text)] + _ <- try $ sendCommand resetCommand :: IO (Either SomeException Text) return () -getCwd :: IO String +getCwd :: IO Text getCwd = do - let cwdCommand = object ["command" .= ("cwd" :: String)] + let cwdCommand = object ["command" .= ("cwd" :: Text)] sendCommand cwdCommand -loadModule :: String -> IO String +loadModule :: Text -> IO Text loadModule m = loadModules [m] -loadModules :: [String] -> IO String +loadModules :: [Text] -> IO Text loadModules = sendCommand . load -loadAll :: IO String +loadAll :: IO Text loadAll = sendCommand (load []) -getFlexCompletions :: String -> IO [(String, String, String)] +getFlexCompletions :: Text -> IO [(Text, Text, Text)] getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) Nothing) -getFlexCompletionsInModule :: String -> String -> IO [(String, String, String)] +getFlexCompletionsInModule :: Text -> Text -> IO [(Text, Text, Text)] getFlexCompletionsInModule q m = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) (Just m)) -getType :: String -> IO [(String, String, String)] +getType :: Text -> IO [(Text, Text, Text)] getType q = parseCompletions <$> sendCommand (typeC q []) -addImport :: String -> FilePath -> FilePath -> IO String +addImport :: Text -> FilePath -> FilePath -> IO Text addImport identifier fp outfp = sendCommand (addImportC identifier fp outfp) -addImplicitImport :: String -> FilePath -> FilePath -> IO String +addImplicitImport :: Text -> FilePath -> FilePath -> IO Text addImplicitImport mn fp outfp = sendCommand (addImplicitImportC mn fp outfp) -rebuildModule :: FilePath -> IO String +rebuildModule :: FilePath -> IO Text rebuildModule m = sendCommand (rebuildC m Nothing) -- Command Encoding -commandWrapper :: String -> Value -> Value +commandWrapper :: Text -> Value -> Value commandWrapper c p = object ["command" .= c, "params" .= p] -load :: [String] -> Value +load :: [Text] -> Value load ms = commandWrapper "load" (object ["modules" .= ms]) -typeC :: String -> [Value] -> Value +typeC :: Text -> [Value] -> Value typeC q filters = commandWrapper "type" (object ["search" .= q, "filters" .= filters]) -addImportC :: String -> FilePath -> FilePath -> Value +addImportC :: Text -> FilePath -> FilePath -> Value addImportC identifier = addImportW $ - object [ "importCommand" .= ("addImport" :: String) + object [ "importCommand" .= ("addImport" :: Text) , "identifier" .= identifier ] -addImplicitImportC :: String -> FilePath -> FilePath -> Value +addImplicitImportC :: Text -> FilePath -> FilePath -> Value addImplicitImportC mn = addImportW $ - object [ "importCommand" .= ("addImplicitImport" :: String) + object [ "importCommand" .= ("addImplicitImport" :: Text) , "module" .= mn ] @@ -226,7 +213,7 @@ addImportW importCommand fp outfp = ]) -completion :: [Value] -> Maybe Value -> Maybe String -> Value +completion :: [Value] -> Maybe Value -> Maybe Text -> Value completion filters matcher currentModule = let matcher' = case matcher of @@ -238,16 +225,16 @@ completion filters matcher currentModule = in commandWrapper "complete" (object $ "filters" .= filters : matcher' ++ currentModule' ) -flexMatcher :: String -> Value -flexMatcher q = object [ "matcher" .= ("flex" :: String) +flexMatcher :: Text -> Value +flexMatcher q = object [ "matcher" .= ("flex" :: Text) , "params" .= object ["search" .= q] ] -- Result parsing -unwrapResult :: Value -> Parser (Either String Value) +unwrapResult :: Value -> Parser (Either Text Value) unwrapResult = withObject "result" $ \o -> do - (rt :: String) <- o .: "resultType" + (rt :: Text) <- o .: "resultType" case rt of "error" -> do res <- o .: "result" @@ -255,16 +242,16 @@ unwrapResult = withObject "result" $ \o -> do "success" -> do res <- o .: "result" pure (Right res) - _ -> fail "lol" + _ -> mzero -withResult :: (Value -> Parser a) -> Value -> Parser (Either String a) +withResult :: (Value -> Parser a) -> Value -> Parser (Either Text a) withResult p v = do r <- unwrapResult v case r of Left err -> pure (Left err) Right res -> Right <$> p res -completionParser :: Value -> Parser [(String, String, String)] +completionParser :: Value -> Parser [(Text, Text, Text)] completionParser = withArray "res" $ \cs -> mapM (withObject "completion" $ \o -> do ident <- o .: "identifier" @@ -272,22 +259,16 @@ completionParser = withArray "res" $ \cs -> ty <- o .: "type" pure (module', ident, ty)) (V.toList cs) -valueFromString :: String -> Value -valueFromString = fromJust . decode . BSL.fromString +valueFromText :: Text -> Value +valueFromText = fromJust . decode . toS -resultIsSuccess :: String -> Bool -resultIsSuccess = isRight . join . parseEither unwrapResult . valueFromString +resultIsSuccess :: Text -> Bool +resultIsSuccess = isRight . join . first toS . parseEither unwrapResult . valueFromText -parseCompletions :: String -> [(String, String, String)] -parseCompletions s = fromJust $ do - cs <- parseMaybe (withResult completionParser) (valueFromString s) - case cs of - Left _ -> error "Failed to parse completions" - Right cs' -> pure cs' +parseCompletions :: Text -> [(Text, Text, Text)] +parseCompletions s = + fromJust $ join (rightToMaybe <$> parseMaybe (withResult completionParser) (valueFromText s)) -parseTextResult :: String -> String -parseTextResult s = fromJust $ do - r <- parseMaybe (withResult (withText "tr" pure)) (valueFromString s) - case r of - Left _ -> error "Failed to parse textResult" - Right r' -> pure (T.unpack r') +parseTextResult :: Text -> Text +parseTextResult s = + fromJust $ join (rightToMaybe <$> parseMaybe (withResult (withText "tr" pure)) (valueFromText s)) diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs index 24f2e32137..f81cbecbd1 100644 --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.MatcherSpec where -import Control.Monad (void) -import Data.Text (Text) +import Protolude + import qualified Language.PureScript as P import Language.PureScript.Ide.Integration import Language.PureScript.Ide.Matcher @@ -13,15 +14,13 @@ import Test.Hspec value :: Text -> IdeDeclaration value s = IdeValue s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) -completions :: [Match] -completions = - [ Match (P.moduleNameFromString "Match") (value "firstResult") - , Match (P.moduleNameFromString "Match") (value "secondResult") - , Match (P.moduleNameFromString "Match") (value "fiult") - ] +firstResult, secondResult, fiult :: Match +firstResult = Match (P.moduleNameFromString "Match") (value "firstResult") +secondResult = Match (P.moduleNameFromString "Match") (value "secondResult") +fiult = Match (P.moduleNameFromString "Match") (value "fiult") -mkResult :: [Int] -> [Match] -mkResult = map (completions !!) +completions :: [Match] +completions = [firstResult, secondResult, fiult] runFlex :: Text -> [Match] runFlex s = runMatcher (flexMatcher s) completions @@ -35,9 +34,9 @@ spec = do it "doesn't match on an empty string" $ runFlex "" `shouldBe` [] it "matches on equality" $ - runFlex "firstResult" `shouldBe` mkResult [0] + runFlex "firstResult" `shouldBe` [firstResult] it "scores short matches higher and sorts accordingly" $ - runFlex "filt" `shouldBe` mkResult [2, 0] + runFlex "filt" `shouldBe` [fiult, firstResult] beforeAll_ setup . describe "Integration Tests: Flex Matcher" $ do it "doesn't match on an empty string" $ do diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index 0a11d8e0a6..f924190852 100644 --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -1,13 +1,17 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.RebuildSpec where +import Protolude + import qualified Language.PureScript.Ide.Integration as Integration import System.FilePath import Test.Hspec -shouldBeSuccess :: String -> IO () +shouldBeSuccess :: Text -> IO () shouldBeSuccess = shouldBe True . Integration.resultIsSuccess -shouldBeFailure :: String -> IO () +shouldBeFailure :: Text -> IO () shouldBeFailure = shouldBe False . Integration.resultIsSuccess spec :: Spec diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index 8a095c50fd..b588b3e329 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -1,8 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.ReexportsSpec where -import Control.Exception (evaluate) -import Data.List (sort) +import Protolude + import qualified Data.Map as Map import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.Types @@ -41,7 +42,7 @@ module4 = ("Module4", [Export "T", decl1, dep1, dep2]) result :: ModuleOld result = ("Module1", [decl1, decl2, Export "Module3"]) -db :: Map.Map ModuleIdent [ExternDecl] +db :: Map ModuleIdent [ExternDecl] db = Map.fromList [module1, module2, module3] shouldBeEqualSorted :: ModuleOld -> ModuleOld -> Expectation @@ -64,9 +65,6 @@ spec = let replaced = replaceReexport (Export "Module2") module1 module2 in replaceReexport (Export "Module2") replaced module2 `shouldBeEqualSorted` result - it "should error when given a non-Export to replace" $ - evaluate (replaceReexport decl1 module1 module2) - `shouldThrow` errorCall "Should only get Exports here." it "replaces all Exports with their corresponding declarations" $ replaceReexports module1 db `shouldBe` ("Module1", [decl1, decl2, decl3]) From ee34e21acbf3fcd4888a53265ea6e0351ad2e90e Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sat, 11 Jun 2016 21:19:52 +0200 Subject: [PATCH 0455/1580] [psc-ide] Parse Modules on load * psc-ide-server now takes globs as arguments, just like the compiler --- LICENSE | 280 +++++++++++++++++++++- psc-ide-server/Main.hs | 9 +- psc-ide-server/README.md | 5 +- purescript.cabal | 1 + src/Language/PureScript/Ide.hs | 184 +++++++------- src/Language/PureScript/Ide/CaseSplit.hs | 5 +- src/Language/PureScript/Ide/Reexports.hs | 3 +- src/Language/PureScript/Ide/SourceFile.hs | 76 +++--- src/Language/PureScript/Ide/State.hs | 55 +++-- src/Language/PureScript/Ide/Types.hs | 8 +- 10 files changed, 460 insertions(+), 166 deletions(-) diff --git a/LICENSE b/LICENSE index be37ddb0e2..e6ad9e7178 100644 --- a/LICENSE +++ b/LICENSE @@ -46,6 +46,7 @@ PureScript uses the following Haskell library packages. Their license files foll bytestring-builder case-insensitive cereal + clock conduit conduit-extra connection @@ -56,8 +57,10 @@ PureScript uses the following Haskell library packages. Their license files foll deepseq directory dlist + easy-file edit-distance exceptions + fail fast-logger filepath fsnotify @@ -82,6 +85,7 @@ PureScript uses the following Haskell library packages. Their license files foll network network-uri old-locale + old-time optparse-applicative parallel parsec @@ -91,6 +95,7 @@ PureScript uses the following Haskell library packages. Their license files foll pipes-http primitive process + protolude random regex-base regex-tdfa @@ -105,6 +110,7 @@ PureScript uses the following Haskell library packages. Their license files foll stm stm-chans streaming-commons + string-conv syb tagged template-haskell @@ -117,6 +123,7 @@ PureScript uses the following Haskell library packages. Their license files foll transformers-compat unix unix-compat + unix-time unordered-containers utf8-string vector @@ -955,6 +962,41 @@ cereal LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +clock LICENSE file: + + Copyright (c) 2009-2012, Cetin Sert + Copyright (c) 2010, Eugene Kirpichov + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + conduit LICENSE file: Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ @@ -1142,16 +1184,16 @@ data-default-class LICENSE file: may be used to endorse or promote products derived from this software without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY LUKAS MAI AND CONTRIBUTORS "AS IS" AND ANY - EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY - DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, + OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. deepseq LICENSE file: @@ -1295,6 +1337,38 @@ dlist LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +easy-file LICENSE file: + + Copyright (c) 2009, IIJ Innovation Institute Inc. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + edit-distance LICENSE file: Copyright (c) 2008-2013 Maximilian Bolingbroke @@ -1354,6 +1428,39 @@ exceptions LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +fail LICENSE file: + + Copyright (c) 2015, David Luposchainsky & Herbert Valerio Riedel + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Herbert Valerio Riedel nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + fast-logger LICENSE file: Copyright (c) 2009, IIJ Innovation Institute Inc. @@ -2122,6 +2229,72 @@ old-locale LICENSE file: ----------------------------------------------------------------------------- +old-time LICENSE file: + + This library (libraries/base) is derived from code from two + sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + + The full text of these licenses is reproduced below. Both of the + licenses are BSD-style or compatible. + + ----------------------------------------------------------------------------- + + The Glasgow Haskell Compiler License + + Copyright 2004, The University Court of the University of Glasgow. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. + + ----------------------------------------------------------------------------- + + Code derived from the document "Report on the Programming Language + Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + + ----------------------------------------------------------------------------- + optparse-applicative LICENSE file: Copyright (c) 2012, Paolo Capriotti @@ -2276,7 +2449,7 @@ pem LICENSE file: pipes LICENSE file: - Copyright (c) 2012-2014 Gabriel Gonzalez + Copyright (c) 2012-2016 Gabriel Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without modification, @@ -2427,6 +2600,28 @@ process LICENSE file: ----------------------------------------------------------------------------- +protolude LICENSE file: + + Copyright (c) 2016, Stephen Diehl + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. + random LICENSE file: This library (libraries/base) is derived from code from two @@ -2873,6 +3068,39 @@ streaming-commons LICENSE file: OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +string-conv LICENSE file: + + Copyright (c) 2012, Ozgun Ataman + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ozgun Ataman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + syb LICENSE file: This library (libraries/syb) is derived from code from several @@ -3289,6 +3517,38 @@ unix-compat LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +unix-time LICENSE file: + + Copyright (c) 2009, IIJ Innovation Institute Inc. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + unordered-containers LICENSE file: Copyright (c) 2010, Johan Tibell diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 8fe3ad75b7..05b2e0c7cd 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -44,9 +44,6 @@ import System.IO.Error (isEOFError) import qualified Paths_purescript as Paths --- "Borrowed" from the Idris Compiler --- Copied from upstream impl of listenOn --- bound to localhost interface instead of iNADDR_ANY listenOnLocalhost :: PortNumber -> IO Socket listenOnLocalhost port = do proto <- getProtocolNumber "tcp" @@ -62,6 +59,7 @@ listenOnLocalhost port = do data Options = Options { optionsDirectory :: Maybe FilePath + , optionsGlobs :: [FilePath] , optionsOutputPath :: FilePath , optionsPort :: PortNumber , optionsNoWatch :: Bool @@ -70,7 +68,7 @@ data Options = Options main :: IO () main = do - Options dir outputPath port noWatch debug <- execParser opts + Options dir globs outputPath port noWatch debug <- execParser opts maybe (pure ()) setCurrentDirectory dir serverState <- newTVarIO emptyPscIdeState ideState <- newTVarIO emptyIdeState @@ -86,13 +84,14 @@ main = do unless noWatch $ void (forkFinally (watcher ideState fullOutputPath) print) - let conf = Configuration {confDebug = debug, confOutputPath = outputPath} + let conf = Configuration {confDebug = debug, confOutputPath = outputPath, confGlobs = globs} env = IdeEnvironment {envStateVar = serverState, ideStateVar = ideState, ideConfiguration = conf} startServer port env where parser = Options <$> optional (strOption (long "directory" `mappend` short 'd')) + <*> many (argument str (metavar "Source GLOBS...")) <*> strOption (long "output-directory" `mappend` value "output/") <*> (fromIntegral <$> option auto (long "port" `mappend` short 'p' `mappend` value (4242 :: Integer))) diff --git a/psc-ide-server/README.md b/psc-ide-server/README.md index d907a17069..114095a910 100644 --- a/psc-ide-server/README.md +++ b/psc-ide-server/README.md @@ -10,7 +10,10 @@ A tool which provides editor support for the PureScript programming language. * Vim integration is available here: https://github.com/FrigoEU/psc-ide-vim. ## Running the Server -Start the server by running the `psc-ide-server` executable. + +Start the server by running the `psc-ide-server [SOURCEGLOBS]` executable, where +`SOURCEGLOBS` are (optional) globs that match your PureScript sourcefiles. + It supports the following options: - `-p / --port` specify a port. Defaults to 4242 diff --git a/purescript.cabal b/purescript.cabal index 57f7ef17ff..bfb8ceed42 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -106,6 +106,7 @@ library boxes >= 0.1.4 && < 0.2.0, bytestring -any, containers -any, + clock -any, directory >= 1.2, dlist -any, edit-distance -any, diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 27f52f5f47..cf438cc72b 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -14,11 +14,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Ide ( handleCommand - -- for tests - , printModules ) where import Protolude @@ -41,67 +40,74 @@ import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import System.Directory import System.FilePath +import System.FilePath.Glob handleCommand :: (Ide m, MonadLogger m, MonadError PscIdeError m) => Command -> m Success -handleCommand (Load []) = loadAllModules -handleCommand (Load modules) = loadModules modules -handleCommand (Type search filters currentModule) = - findType search filters currentModule -handleCommand (Complete filters matcher currentModule) = - findCompletions filters matcher currentModule -handleCommand (Pursuit query Package) = - findPursuitPackages query -handleCommand (Pursuit query Identifier) = - findPursuitCompletions query -handleCommand (List LoadedModules) = - printModules -handleCommand (List AvailableModules) = - listAvailableModules -handleCommand (List (Imports fp)) = - importsForFile fp -handleCommand (CaseSplit l b e wca t) = - caseSplit l b e wca t -handleCommand (AddClause l wca) = - addClause l wca -handleCommand (Import fp outfp _ (AddImplicitImport mn)) = do - rs <- addImplicitImport fp mn - answerRequest outfp rs -handleCommand (Import fp outfp filters (AddImportForIdentifier ident)) = do - rs <- addImportForIdentifier fp ident filters - case rs of - Right rs' -> answerRequest outfp rs' - Left question -> pure $ CompletionResult (map completionFromMatch question) -handleCommand (Rebuild file) = - rebuildFile file -handleCommand Cwd = - TextResult . toS <$> liftIO getCurrentDirectory -handleCommand Reset = resetIdeState *> pure (TextResult "State has been reset.") -handleCommand Quit = liftIO exitSuccess - -findCompletions :: (Ide m) => +handleCommand c = case c of + Load [] -> + findAvailableExterns >>= loadModules + Load modules -> + loadModules modules + Type search filters currentModule -> + findType search filters currentModule + Complete filters matcher currentModule -> + findCompletions filters matcher currentModule + Pursuit query Package -> + findPursuitPackages query + Pursuit query Identifier -> + findPursuitCompletions query + List LoadedModules -> + printModules + List AvailableModules -> + listAvailableModules + List (Imports fp) -> + ImportList <$> getImportsForFile fp + CaseSplit l b e wca t -> + caseSplit l b e wca t + AddClause l wca -> + addClause l wca + Import fp outfp _ (AddImplicitImport mn) -> do + rs <- addImplicitImport fp mn + answerRequest outfp rs + Import fp outfp filters (AddImportForIdentifier ident) -> do + rs <- addImportForIdentifier fp ident filters + case rs of + Right rs' -> answerRequest outfp rs' + Left question -> + pure (CompletionResult (map completionFromMatch question)) + Rebuild file -> + rebuildFile file + Cwd -> + TextResult . toS <$> liftIO getCurrentDirectory + Reset -> + resetIdeState $> TextResult "State has been reset." + Quit -> + liftIO exitSuccess + +findCompletions :: Ide m => [Filter] -> Matcher -> Maybe P.ModuleName -> m Success findCompletions filters matcher currentModule = do modules <- getAllModules2 currentModule pure . CompletionResult . map completionFromMatch . getCompletions filters matcher $ modules -findType :: (Ide m) => +findType :: Ide m => Text -> [Filter] -> Maybe P.ModuleName -> m Success findType search filters currentModule = do modules <- getAllModules2 currentModule pure . CompletionResult . map completionFromMatch . getExactMatches search filters $ modules -findPursuitCompletions :: (MonadIO m) => +findPursuitCompletions :: MonadIO m => PursuitQuery -> m Success findPursuitCompletions (PursuitQuery q) = PursuitResult <$> liftIO (searchPursuitForDeclarations q) -findPursuitPackages :: (MonadIO m) => +findPursuitPackages :: MonadIO m => PursuitQuery -> m Success findPursuitPackages (PursuitQuery q) = PursuitResult <$> liftIO (findPackagesForModuleIdent q) -printModules :: (Ide m) => m Success +printModules :: Ide m => m Success printModules = ModuleList . map runModuleNameT <$> getLoadedModulenames outputDirectory :: Ide m => m FilePath @@ -131,54 +137,70 @@ addClause -> m Success addClause t wca = MultilineTextResult <$> CS.addClause t wca -importsForFile :: (MonadIO m, MonadError PscIdeError m) => - FilePath -> m Success -importsForFile fp = do - imports <- getImportsForFile fp - pure (ImportList imports) - --- | Takes the output directory and a filepath like "Monad.Control.Eff" and --- looks up, whether that folder contains an externs.json -checkExternsPath :: FilePath -> FilePath -> IO (Maybe FilePath) -checkExternsPath oDir d - | d `elem` [".", ".."] = pure Nothing - | otherwise = do - let file = oDir d "externs.json" - ex <- doesFileExist file - if ex - then pure (Just file) - else pure Nothing - -findAllExterns :: (Ide m, MonadError PscIdeError m) => m [FilePath] -findAllExterns = do +-- | Finds all the externs.json files inside the output folder and returns the +-- corresponding Modulenames +findAvailableExterns :: (Ide m, MonadError PscIdeError m) => m [P.ModuleName] +findAvailableExterns = do oDir <- outputDirectory unlessM (liftIO (doesDirectoryExist oDir)) (throwError (GeneralError "Couldn't locate your output directory.")) liftIO $ do - dirs <- getDirectoryContents oDir - externPaths <- traverse (checkExternsPath oDir) dirs - pure (catMaybes externPaths) - + directories <- getDirectoryContents oDir + moduleNames <- filterM (checkExternsPath oDir) directories + pure (P.moduleNameFromString <$> moduleNames) + where + -- | Takes the output directory and a filepath like "Monad.Control.Eff" and + -- looks up, whether that folder contains an externs.json + checkExternsPath :: FilePath -> FilePath -> IO Bool + checkExternsPath oDir d + | d `elem` [".", ".."] = pure False + | otherwise = do + let file = oDir d "externs.json" + doesFileExist file + +-- | Finds all matches for the globs specified at the commandline +findAllSourceFiles :: Ide m => m [FilePath] +findAllSourceFiles = do + globs <- confGlobs . ideConfiguration <$> ask + liftIO (concatMapM glob globs) + +-- | Looks up the ExternsFiles for the given Modulenames and loads them into the +-- server state. Then proceeds to parse all the specified sourcefiles and +-- inserts their ASTs into the state. Finally kicks off an async worker, which +-- populates Stage 2 and 3 of the state. loadModules :: (Ide m, MonadError PscIdeError m, MonadLogger m) => [P.ModuleName] -> m Success -loadModules mns = do +loadModules moduleNames = do + -- We resolve all the modulenames to externs files and load these into memory. oDir <- outputDirectory - let efPaths = map (\mn -> oDir P.runModuleName mn "externs.json") mns + let efPaths = + map (\mn -> oDir P.runModuleName mn "externs.json") moduleNames efiles <- traverse readExternFile efPaths traverse_ insertExterns efiles - --TODO Get rid of this once ModuleOld is gone - traverse_ insertModule efiles - populateStage2 - pure (TextResult ("Loaded " <> foldMap runModuleNameT mns <> ".")) - -loadAllModules :: (Ide m, MonadError PscIdeError m) => m Success -loadAllModules = do - exts <- traverse readExternFile =<< findAllExterns - traverse_ insertExterns exts - --TODO Get rid of this once ModuleOld is gone - traverse_ insertModule exts + + -- We parse all source files, log eventual parse failures if the debug flag + -- was set and insert the succesful parses into the state. + (failures, allModules) <- + partitionEithers <$> (traverse parseModule =<< findAllSourceFiles) + unless (null failures) $ + $(logDebug) ("Failed to parse: " <> show failures) + traverse_ insertModule allModules + + -- Because we still need the "old" module format to resolve reexports in the + -- worker thread, we insert it into the state aswell. + -- TODO Get rid of this once ModuleOld is gone + traverse_ insertModuleOld efiles + + -- Finally we kick off the worker with @async@ and return the number of + -- successfully parsed modules. env <- ask - _ <- liftIO $ async (runStdoutLoggingT (runReaderT populateStage2 env)) - pure (TextResult "All modules loaded.") + let runLogger = + runStdoutLoggingT + . filterLogger (\_ _ -> confDebug (ideConfiguration env)) + -- populateStage2 returns Unit for now, so it's fine to discard this result. + -- We might want to block on this in a benchmarking situation. + _ <- liftIO (async (runLogger (runReaderT populateStage2 env))) + pure (TextResult ("Loaded " <> show (length efiles) <> " modules and " + <> show (length allModules) <> " source files.")) diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 880470ea86..d4b4d55057 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -36,6 +36,7 @@ import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import Text.Parsec as Parsec +import qualified Text.PrettyPrint.Boxes as Box type Constructor = (P.ProperName 'P.ConstructorName, [P.Type]) @@ -135,8 +136,8 @@ parseTypeDeclaration' s = Right (P.TypeDeclaration i t) -> pure (i, t) Right _ -> throwError (GeneralError "Found a non-type-declaration") Left err -> - throwError (GeneralError ("Parsing the typesignature failed with: " - <> show err)) + throwError (GeneralError ("Parsing the type signature failed with: " + <> toS (Box.render (P.prettyPrintParseError err)))) splitFunctionType :: P.Type -> [P.Type] splitFunctionType t = fromMaybe [] arguments diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 4b9c308c80..d3b1faf8c8 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -28,7 +28,6 @@ import Protolude import Data.List (union) import qualified Data.Map as Map -import qualified Data.Text as T import Language.PureScript.Ide.Types import Language.PureScript.Ide.Externs import qualified Language.PureScript as P @@ -94,5 +93,5 @@ resolveReexports modules m = then replaced else resolveReexports modules replaced -resolveReexports2 :: Map T.Text [ExternDecl] -> ModuleOld -> Module +resolveReexports2 :: Map Text [ExternDecl] -> ModuleOld -> Module resolveReexports2 decls = convertModule . resolveReexports decls diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index e0583aaa9d..850e7b88c9 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -14,7 +14,12 @@ {-# LANGUAGE OverloadedStrings #-} -module Language.PureScript.Ide.SourceFile where +module Language.PureScript.Ide.SourceFile + ( parseModule + , getImportsForFile + -- SOON... + , getDeclPosition + ) where import Protolude @@ -24,26 +29,18 @@ import Language.PureScript.Ide.Util import Language.PureScript.Ide.Externs (unwrapPositioned, unwrapPositionedRef) import Language.PureScript.Ide.Types -import System.Directory import System.FilePath import System.IO.UTF8 (readUTF8File) -parseModuleFromFile :: (MonadIO m, MonadError PscIdeError m) => - FilePath -> m P.Module -parseModuleFromFile fp = do - exists <- liftIO (doesFileExist fp) - if exists - then do - content <- liftIO (readUTF8File fp) - let m = do tokens <- P.lex fp content - P.runTokenParser "" P.parseModule tokens - either (throwError . (`ParseError` "File could not be parsed.")) pure m - else throwError (NotFound "File does not exist.") - --- data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) - -getDeclarations :: P.Module -> [P.Declaration] -getDeclarations (P.Module _ _ _ declarations _) = declarations +parseModule + :: (MonadIO m) + => FilePath + -> m (Either FilePath (FilePath, P.Module) ) +parseModule path = do + contents <- liftIO (readUTF8File path) + case P.parseModuleFromFile identity (path, contents) of + Left _ -> pure (Left path) + Right m -> pure (Right m) getImports :: P.Module -> [(P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)] getImports (P.Module _ _ _ declarations _) = @@ -55,26 +52,21 @@ getImports (P.Module _ _ _ declarations _) = getImportsForFile :: (MonadIO m, MonadError PscIdeError m) => FilePath -> m [ModuleImport] getImportsForFile fp = do - module' <- parseModuleFromFile fp - let imports = getImports module' - pure (mkModuleImport . unwrapPositionedImport <$> imports) - where - mkModuleImport (mn, importType', qualifier) = - ModuleImport - (runModuleNameT mn) - importType' - (runModuleNameT <$> qualifier) - unwrapPositionedImport (mn, it, q) = (mn, unwrapImportType it, q) - unwrapImportType (P.Explicit decls) = P.Explicit (map unwrapPositionedRef decls) - unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls) - unwrapImportType P.Implicit = P.Implicit - -getPositionedImports :: P.Module -> [P.Declaration] -getPositionedImports (P.Module _ _ _ declarations _) = - mapMaybe isImport declarations - where - isImport i@(P.PositionedDeclaration _ _ P.ImportDeclaration{}) = Just i - isImport _ = Nothing + moduleE <- parseModule fp + case moduleE of + Left _ -> throwError (GeneralError "Failed to parse sourcefile.") + Right (_, module') -> + pure (mkModuleImport . unwrapPositionedImport <$> getImports module') + where + mkModuleImport (mn, importType', qualifier) = + ModuleImport + (runModuleNameT mn) + importType' + (runModuleNameT <$> qualifier) + unwrapPositionedImport (mn, it, q) = (mn, unwrapImportType it, q) + unwrapImportType (P.Explicit decls) = P.Explicit (map unwrapPositionedRef decls) + unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls) + unwrapImportType P.Implicit = P.Implicit getDeclPosition :: P.Module -> Text -> Maybe P.SourceSpan getDeclPosition m ident = getFirst (foldMap (match ident) decls) @@ -102,9 +94,5 @@ getDeclPosition m ident = getFirst (foldMap (match ident) decls) properEqual x q = runProperNameT x == q identEqual x q = runIdentT x == q -goToDefinition :: Text -> FilePath -> IO (Maybe P.SourceSpan) -goToDefinition q fp = do - m <- runExceptT (parseModuleFromFile fp) - case m of - Right module' -> pure (getDeclPosition module' q) - Left _ -> pure Nothing + getDeclarations :: P.Module -> [P.Declaration] + getDeclarations (P.Module _ _ _ declarations _) = declarations diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 0af5d3947e..d82aa1d065 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -19,10 +19,12 @@ module Language.PureScript.Ide.State ( getLoadedModulenames , getExternFiles - , insertModule + , insertModuleOld , resetIdeState , cacheRebuild , insertExterns + , insertModule + , insertModuleSTM , insertExternsSTM , getAllModules2 , getStage1 @@ -34,18 +36,19 @@ module Language.PureScript.Ide.State ) where import Protolude +import qualified Prelude import Control.Concurrent.STM import "monad-logger" Control.Monad.Logger import qualified Data.Map.Lazy as M -import qualified Data.Text as T -import Data.Time (getCurrentTime, diffUTCTime) import Language.PureScript.Externs import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import qualified Language.PureScript as P +import System.Clock +import System.FilePath -- | Resets all State inside psc-ide resetIdeState :: Ide m => m () @@ -68,16 +71,16 @@ getExternFiles = s1Externs <$> getStage1 -- | Inserts an @ExternsFile@ into the PscIdeState. Also converts the -- ExternsFile into psc-ide's internal Declaration format -- TODO: should be removed when the "old" Declaration format gets removed -insertModule :: Ide m => ExternsFile -> m () -insertModule externsFile = do +insertModuleOld :: Ide m => ExternsFile -> m () +insertModuleOld externsFile = do stateVar <- envStateVar <$> ask - liftIO . atomically $ insertModuleSTM stateVar externsFile + liftIO . atomically $ insertModuleOldSTM stateVar externsFile --- | STM version of insertModule -insertModuleSTM :: TVar PscIdeState -> ExternsFile -> STM () -insertModuleSTM st ef = modifyTVar st (insertModule' ef) +-- | STM version of insertModuleOld +insertModuleOldSTM :: TVar PscIdeState -> ExternsFile -> STM () +insertModuleOldSTM st ef = modifyTVar st (insertModule' ef) --- | Pure version of insertModule +-- | Pure version of insertModuleOld insertModule' :: ExternsFile -> PscIdeState -> PscIdeState insertModule' ef state = state @@ -85,6 +88,22 @@ insertModule' ef state = in M.insert mn decls (pscIdeStateModules state) } +-- | Insert a Module into Stage1 of the State +insertModule :: Ide m => (FilePath, P.Module) -> m () +insertModule module' = do + stateVar <- ideStateVar <$> ask + liftIO . atomically $ insertModuleSTM stateVar module' + +-- | STM version of insertModule +insertModuleSTM :: TVar IdeState -> (FilePath, P.Module) -> STM () +insertModuleSTM ref (fp, module') = + modifyTVar ref $ \x -> + x { ideStage1 = (ideStage1 x) { + s1Modules = M.insert + (P.getModuleName module') + (module', fp) + (s1Modules (ideStage1 x))}} + -- | Retrieves Stage1 from the State. -- This includes loaded Externfiles -- (TODO: as soon as we actually parse the modules) aswell as the parsed modules @@ -131,17 +150,17 @@ setStage2STM ref s2 = do -- cache getAllModules2 :: Ide m => Maybe P.ModuleName -> m [(P.ModuleName, [IdeDeclaration])] getAllModules2 mmoduleName = do - modules <- s2Modules <$> getStage2 + declarations <- s2Declarations <$> getStage2 rebuild <- cachedRebuild case mmoduleName of - Nothing -> pure (M.toList modules) + Nothing -> pure (M.toList declarations) Just moduleName -> case rebuild of Just (cachedModulename, ef) | cachedModulename == moduleName -> pure . M.toList $ - M.insert moduleName (snd . convertModule . convertExterns $ ef) modules - _ -> pure (M.toList modules) + M.insert moduleName (snd . convertModule . convertExterns $ ef) declarations + _ -> pure (M.toList declarations) -- | Adds an ExternsFile into psc-ide's State Stage1. This does not populate the -- following Stages, which needs to be done after all the necessary Exterms have @@ -175,11 +194,11 @@ populateStage2 :: (Ide m, MonadLogger m) => m () populateStage2 = do st <- ideStateVar <$> ask duration <- liftIO $ do - start <- getCurrentTime + start <- getTime Monotonic atomically (populateStage2STM st) - end <- getCurrentTime - pure (diffUTCTime end start) - $(logDebug) $ "Finished populating Stage2 in " <> T.pack (show duration) + end <- getTime Monotonic + pure (Prelude.show (diffTimeSpec start end)) + $(logDebug) $ "Finished populating Stage2 in " <> toS duration -- | STM version of populateStage2 populateStage2STM :: TVar IdeState -> STM () diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 43ec8f5e90..57441420a1 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -12,7 +12,7 @@ -- Type definitions for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Types where @@ -74,6 +74,7 @@ data Configuration = Configuration { confOutputPath :: FilePath , confDebug :: Bool + , confGlobs :: [FilePath] } data IdeEnvironment = @@ -102,17 +103,18 @@ emptyIdeState :: IdeState emptyIdeState = IdeState emptyStage1 emptyStage2 emptyStage1 :: Stage1 -emptyStage1 = Stage1 M.empty +emptyStage1 = Stage1 M.empty M.empty emptyStage2 :: Stage2 emptyStage2 = Stage2 M.empty Nothing data Stage1 = Stage1 { s1Externs :: M.Map P.ModuleName P.ExternsFile + , s1Modules :: M.Map P.ModuleName (P.Module, FilePath) } data Stage2 = Stage2 - { s2Modules :: M.Map P.ModuleName [IdeDeclaration] + { s2Declarations :: M.Map P.ModuleName [IdeDeclaration] , s2CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile) } From 5def0199bc0b57431ff7426ea126f8ab564e05c3 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Thu, 7 Jul 2016 12:09:29 +0200 Subject: [PATCH 0456/1580] [psc-ide] Fix unicode encoding of json responses --- psc-ide-client/Main.hs | 22 ++++++---------------- psc-ide-server/Main.hs | 7 ++++--- purescript.cabal | 3 +++ 3 files changed, 13 insertions(+), 19 deletions(-) diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs index 79532e51e1..ec4c7614ee 100644 --- a/psc-ide-client/Main.hs +++ b/psc-ide-client/Main.hs @@ -5,16 +5,15 @@ import Prelude () import Prelude.Compat import Control.Exception -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Version (showVersion) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Text.IO as T +import Data.Version (showVersion) import Network import Options.Applicative import System.Exit import System.IO -import qualified Paths_purescript as Paths +import qualified Paths_purescript as Paths data Options = Options { optionsPort :: PortID @@ -41,16 +40,7 @@ client port = do ("Couldn't connect to psc-ide-server on port: " ++ show port ++ " Error: " ++ show e) >> exitFailure) - cmd <- T.getLine - -- Temporary fix for emacs windows bug - let cleanedCmd = removeSurroundingTicks cmd - -- - T.hPutStrLn h cleanedCmd - res <- T.hGetLine h - putStrLn (T.unpack res) + T.hPutStrLn h =<< T.getLine + BS8.putStrLn =<< BS8.hGetLine h hFlush stdout hClose h - --- TODO: Fix this in the emacs plugin by using a real process over shellcommands -removeSurroundingTicks :: Text -> Text -removeSurroundingTicks = T.dropWhile (== '\'') . T.dropWhileEnd (== '\'') diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 05b2e0c7cd..bf26da4f0f 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -23,9 +23,11 @@ module Main where import Protolude +import qualified Data.Aeson as Aeson import Control.Concurrent.STM import "monad-logger" Control.Monad.Logger import qualified Data.Text.IO as T +import qualified Data.ByteString.Lazy.Char8 as BS8 import Data.Version (showVersion) import Language.PureScript.Ide import Language.PureScript.Ide.Util @@ -121,9 +123,8 @@ startServer port env = withSocketsDo $ do -- $(logDebug) ("Answer was: " <> T.pack (show result)) liftIO (hFlush stdout) case result of - -- What function can I use to clean this up? - Right r -> liftIO $ T.hPutStrLn h (encodeT r) - Left err -> liftIO $ T.hPutStrLn h (encodeT err) + Right r -> liftIO $ BS8.hPutStrLn h (Aeson.encode r) + Left err -> liftIO $ BS8.hPutStrLn h (Aeson.encode err) Nothing -> do $(logDebug) ("Parsing the command failed. Command: " <> cmd) liftIO $ do diff --git a/purescript.cabal b/purescript.cabal index f3f4bb75e7..72e21640c2 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -428,6 +428,8 @@ executable psc-ide-server other-modules: Paths_purescript other-extensions: build-depends: base >=4 && <5, + aeson >= 0.8 && < 0.12, + bytestring -any, purescript -any, base-compat >=0.6.0, directory -any, @@ -450,6 +452,7 @@ executable psc-ide-client other-extensions: build-depends: base >=4 && <5, base-compat >=0.6.0, + bytestring -any, mtl -any, network -any, optparse-applicative >= 0.12.1, From 95334c8053a160e6f2dbae8034e9ddc0b8d917a0 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sat, 9 Jul 2016 20:56:07 +0200 Subject: [PATCH 0457/1580] New reexports (#2215) * [psc-ide] Goto definition * extracts declaration positions from the parsed source files and matches them up with declarations * the definition location for an identifier can be queried by using the type command, which is planned to turn into an :info command * [psc-ide] Refactor Reexport resolving * Gets rid of the old declaration format * Uses the new ReExportRef mechanism to resolve reexports * cleans up module exports --- psc-ide-server/Main.hs | 3 +- psc-ide-server/PROTOCOL.md | 25 ++- purescript.cabal | 2 + src/Language/PureScript/Ide.hs | 38 ++--- src/Language/PureScript/Ide/CaseSplit.hs | 1 - src/Language/PureScript/Ide/Command.hs | 2 +- src/Language/PureScript/Ide/Completion.hs | 21 ++- src/Language/PureScript/Ide/Error.hs | 1 - src/Language/PureScript/Ide/Externs.hs | 117 +++++++------ src/Language/PureScript/Ide/Filter.hs | 8 +- src/Language/PureScript/Ide/Imports.hs | 19 +-- src/Language/PureScript/Ide/Matcher.hs | 39 ++--- src/Language/PureScript/Ide/Pursuit.hs | 5 +- src/Language/PureScript/Ide/Reexports.hs | 155 ++++++++++-------- src/Language/PureScript/Ide/SourceFile.hs | 69 ++++---- src/Language/PureScript/Ide/State.hs | 129 ++++++++------- src/Language/PureScript/Ide/Types.hs | 102 ++++++------ src/Language/PureScript/Ide/Util.hs | 54 ++++-- src/Language/PureScript/Ide/Watcher.hs | 6 +- tests/Language/PureScript/Ide/FilterSpec.hs | 10 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 4 +- tests/Language/PureScript/Ide/Integration.hs | 23 ++- tests/Language/PureScript/Ide/MatcherSpec.hs | 14 +- .../Language/PureScript/Ide/ReexportsSpec.hs | 117 ++++++------- .../Ide/SourceFile/IntegrationSpec.hs | 36 ++++ .../Language/PureScript/Ide/SourceFileSpec.hs | 46 ++++++ .../pscide/src/RebuildSpecWithForeign.js | 2 - tests/support/pscide/src/SourceFileSpec.purs | 10 ++ 28 files changed, 604 insertions(+), 454 deletions(-) create mode 100644 tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs create mode 100644 tests/Language/PureScript/Ide/SourceFileSpec.hs create mode 100644 tests/support/pscide/src/SourceFileSpec.purs diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index bf26da4f0f..ce513023ad 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -72,7 +72,6 @@ main :: IO () main = do Options dir globs outputPath port noWatch debug <- execParser opts maybe (pure ()) setCurrentDirectory dir - serverState <- newTVarIO emptyPscIdeState ideState <- newTVarIO emptyIdeState cwd <- getCurrentDirectory let fullOutputPath = cwd outputPath @@ -87,7 +86,7 @@ main = do void (forkFinally (watcher ideState fullOutputPath) print) let conf = Configuration {confDebug = debug, confOutputPath = outputPath, confGlobs = globs} - env = IdeEnvironment {envStateVar = serverState, ideStateVar = ideState, ideConfiguration = conf} + env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf} startServer port env where parser = diff --git a/psc-ide-server/PROTOCOL.md b/psc-ide-server/PROTOCOL.md index 03528c95f9..f581f14bab 100644 --- a/psc-ide-server/PROTOCOL.md +++ b/psc-ide-server/PROTOCOL.md @@ -30,7 +30,8 @@ to detect all the compiled modules in your project and load them. The Load Command returns a string with a summary about the loading process. ### Type -The `type` command looks up the type for a given identifier. +The `type` command looks up the type for a given identifier. It also returns the +definition position, if it can be found in the passed source files. **Params:** - `search :: String`: The identifier to look for. Only matches on equality. @@ -50,7 +51,27 @@ The `type` command looks up the type for a given identifier. ``` **Result:** -The possible types are returned in the same format as completions +The possible types are returned in the same format as completions + eventual position information +```json +[ + { + "module": "Data.Array", + "identifier": "filter", + "type": "forall a. (a -> Boolean) -> Array a -> Array a" + }, + { + "module": "Data.Array", + "identifier": "filter", + "type": "forall a. (a -> Boolean) -> Array a -> Array a", + "definedAt": + { + "name": "/path/to/file", + "start": [1, 3], + "end": [3, 1] + } + } +] +``` ### Complete The `complete` command looks up possible completions/corrections. diff --git a/purescript.cabal b/purescript.cabal index 72e21640c2..7c23a7bf7a 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -506,5 +506,7 @@ test-suite tests Language.PureScript.Ide.MatcherSpec Language.PureScript.Ide.RebuildSpec Language.PureScript.Ide.ReexportsSpec + Language.PureScript.Ide.SourceFile.IntegrationSpec + Language.PureScript.Ide.SourceFileSpec buildable: True hs-source-dirs: tests diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index cf438cc72b..697215a6f8 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -42,6 +42,8 @@ import System.Directory import System.FilePath import System.FilePath.Glob +-- | Accepts a Commmand and runs it against psc-ide's State. This is the main +-- entry point for the server. handleCommand :: (Ide m, MonadLogger m, MonadError PscIdeError m) => Command -> m Success handleCommand c = case c of @@ -66,7 +68,7 @@ handleCommand c = case c of CaseSplit l b e wca t -> caseSplit l b e wca t AddClause l wca -> - addClause l wca + MultilineTextResult <$> CS.addClause l wca Import fp outfp _ (AddImplicitImport mn) -> do rs <- addImplicitImport fp mn answerRequest outfp rs @@ -86,16 +88,16 @@ handleCommand c = case c of liftIO exitSuccess findCompletions :: Ide m => - [Filter] -> Matcher -> Maybe P.ModuleName -> m Success + [Filter] -> Matcher IdeDeclaration -> Maybe P.ModuleName -> m Success findCompletions filters matcher currentModule = do - modules <- getAllModules2 currentModule + modules <- getAllModules currentModule pure . CompletionResult . map completionFromMatch . getCompletions filters matcher $ modules findType :: Ide m => Text -> [Filter] -> Maybe P.ModuleName -> m Success findType search filters currentModule = do - modules <- getAllModules2 currentModule - pure . CompletionResult . map completionFromMatch . getExactMatches search filters $ modules + modules <- getAllModules currentModule + pure . InfoResult . map infoFromMatch . getExactMatches search filters $ modules findPursuitCompletions :: MonadIO m => PursuitQuery -> m Success @@ -130,13 +132,6 @@ caseSplit l b e csa t = do patterns <- CS.makePattern l b e csa <$> CS.caseSplit t pure (MultilineTextResult patterns) -addClause - :: (MonadError PscIdeError m) - => Text - -> CS.WildcardAnnotations - -> m Success -addClause t wca = MultilineTextResult <$> CS.addClause t wca - -- | Finds all the externs.json files inside the output folder and returns the -- corresponding Modulenames findAvailableExterns :: (Ide m, MonadError PscIdeError m) => m [P.ModuleName] @@ -146,13 +141,13 @@ findAvailableExterns = do (throwError (GeneralError "Couldn't locate your output directory.")) liftIO $ do directories <- getDirectoryContents oDir - moduleNames <- filterM (checkExternsPath oDir) directories + moduleNames <- filterM (containsExterns oDir) directories pure (P.moduleNameFromString <$> moduleNames) where - -- | Takes the output directory and a filepath like "Monad.Control.Eff" and + -- Takes the output directory and a filepath like "Monad.Control.Eff" and -- looks up, whether that folder contains an externs.json - checkExternsPath :: FilePath -> FilePath -> IO Bool - checkExternsPath oDir d + containsExterns :: FilePath -> FilePath -> IO Bool + containsExterns oDir d | d `elem` [".", ".."] = pure False | otherwise = do let file = oDir d "externs.json" @@ -188,19 +183,14 @@ loadModules moduleNames = do $(logDebug) ("Failed to parse: " <> show failures) traverse_ insertModule allModules - -- Because we still need the "old" module format to resolve reexports in the - -- worker thread, we insert it into the state aswell. - -- TODO Get rid of this once ModuleOld is gone - traverse_ insertModuleOld efiles - -- Finally we kick off the worker with @async@ and return the number of -- successfully parsed modules. env <- ask let runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (ideConfiguration env)) - -- populateStage2 returns Unit for now, so it's fine to discard this result. - -- We might want to block on this in a benchmarking situation. - _ <- liftIO (async (runLogger (runReaderT populateStage2 env))) + -- populateStage2 and 3 return Unit for now, so it's fine to discard this + -- result. We might want to block on this in a benchmarking situation. + _ <- liftIO (async (runLogger (runReaderT (populateStage2 *> populateStage3) env))) pure (TextResult ("Loaded " <> show (length efiles) <> " modules and " <> show (length allModules) <> " source files.")) diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index d4b4d55057..54f5137353 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -30,7 +30,6 @@ import qualified Language.PureScript as P import Language.PureScript.Externs import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Externs (unwrapPositioned) import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 876b21e7c6..31a20a2c16 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -35,7 +35,7 @@ data Command } | Complete { completeFilters :: [Filter] - , completeMatcher :: Matcher + , completeMatcher :: Matcher IdeDeclaration , completeCurrentModule :: Maybe P.ModuleName } | Pursuit diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index cbcf307a9f..04c0e7db27 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -9,19 +9,24 @@ import Protolude import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util -- | Applies the CompletionFilters and the Matcher to the given Modules -- and sorts the found Completions according to the Matching Score -getCompletions :: [Filter] -> Matcher -> [Module] -> [Match] +getCompletions + :: [Filter] + -> Matcher IdeDeclaration + -> [Module] + -> [Match IdeDeclaration] getCompletions filters matcher modules = - runMatcher matcher (completionsFromModules (applyFilters filters modules)) + runMatcher matcher (completionsFromModules discardAnn (applyFilters filters modules)) -getExactMatches :: Text -> [Filter] -> [Module] -> [Match] +getExactMatches :: Text -> [Filter] -> [Module] -> [Match IdeDeclarationAnn] getExactMatches search filters modules = - completionsFromModules (applyFilters (equalityFilter search : filters) modules) + completionsFromModules identity (applyFilters (equalityFilter search : filters) modules) -completionsFromModules :: [Module] -> [Match] -completionsFromModules = foldMap completionFromModule +completionsFromModules :: (IdeDeclarationAnn -> a) -> [Module] -> [Match a] +completionsFromModules f = foldMap completionFromModule where - completionFromModule :: Module -> [Match] - completionFromModule (moduleName, decls) = map (Match moduleName) decls + completionFromModule (moduleName, decls) = + map (\x -> Match (moduleName, f x)) decls diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 5bf12b833d..19c112ab92 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -15,7 +15,6 @@ {-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Error ( PscIdeError(..) - , textError ) where import Protolude diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 45a7566b0c..37f03198b6 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -17,27 +17,23 @@ {-# LANGUAGE FlexibleContexts #-} module Language.PureScript.Ide.Externs - ( ExternDecl(..), - ModuleIdent, - readExternFile, + ( readExternFile, convertExterns, - convertModule, - unwrapPositioned, - unwrapPositionedRef + annotateLocations ) where import Protolude import Data.Aeson (decodeStrict) import Data.List (nub) +import qualified Data.Map as Map import qualified Data.ByteString as BS import Language.PureScript.Ide.Error (PscIdeError (..)) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import qualified Language.PureScript as P - -import System.FilePath +import System.FilePath readExternFile :: (MonadIO m, MonadError PscIdeError m) => FilePath -> m P.ExternsFile @@ -47,86 +43,83 @@ readExternFile fp = do Nothing -> throwError . GeneralError $ "Parsing the extern at: " <> toS fp <> " failed" Just externs -> pure externs -convertExterns :: P.ExternsFile -> ModuleOld -convertExterns ef = (runModuleNameT moduleName, exportDecls ++ importDecls ++ decls ++ operatorDecls ++ tyOperatorDecls) +convertExterns :: P.ExternsFile -> (Module, [(P.ModuleName, P.DeclarationRef)]) +convertExterns ef = + ((P.efModuleName ef, decls), exportDecls) where - moduleName = P.efModuleName ef - importDecls = convertImport <$> P.efImports ef + decls = map + (IdeDeclarationAnn emptyAnn) + (cleanDeclarations ++ operatorDecls ++ tyOperatorDecls) exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (P.efExports ef) operatorDecls = convertOperator <$> P.efFixities ef tyOperatorDecls = convertTypeOperator <$> P.efTypeFixities ef - otherDecls = mapMaybe convertDecl (P.efDeclarations ef) + declarations = mapMaybe convertDecl (P.efDeclarations ef) - typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration otherDecls) - decls = nub $ appEndo typeClassFilter otherDecls + typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration declarations) + cleanDeclarations = nub $ appEndo typeClassFilter declarations -removeTypeDeclarationsForClass :: ExternDecl -> Endo [ExternDecl] -removeTypeDeclarationsForClass (TypeClassDeclaration n) = Endo (filter notDuplicate) - where notDuplicate (TypeDeclaration n' _) = runProperNameT n /= runProperNameT n' - notDuplicate (TypeSynonymDeclaration n' _) = runProperNameT n /= runProperNameT n' +removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration] +removeTypeDeclarationsForClass (IdeTypeClass n) = Endo (filter notDuplicate) + where notDuplicate (IdeType n' _) = runProperNameT n /= runProperNameT n' + notDuplicate (IdeTypeSynonym n' _) = runProperNameT n /= runProperNameT n' notDuplicate _ = True removeTypeDeclarationsForClass _ = mempty -isTypeClassDeclaration :: ExternDecl -> Bool -isTypeClassDeclaration TypeClassDeclaration{} = True +isTypeClassDeclaration :: IdeDeclaration -> Bool +isTypeClassDeclaration IdeTypeClass{} = True isTypeClassDeclaration _ = False -convertImport :: P.ExternsImport -> ExternDecl -convertImport ei = Dependency - (runModuleNameT (P.eiModule ei)) - [] - (runModuleNameT <$> P.eiImportedAs ei) - -convertExport :: P.DeclarationRef -> Maybe ExternDecl -convertExport (P.ModuleRef mn) = Just (Export (runModuleNameT mn)) +convertExport :: P.DeclarationRef -> Maybe (P.ModuleName, P.DeclarationRef) +convertExport (P.ReExportRef m r) = Just (m, r) convertExport _ = Nothing -convertDecl :: P.ExternsDeclaration -> Maybe ExternDecl -convertDecl P.EDType{..} = Just $ TypeDeclaration edTypeName edTypeKind -convertDecl P.EDTypeSynonym{..} = Just $ - TypeSynonymDeclaration edTypeSynonymName edTypeSynonymType +convertDecl :: P.ExternsDeclaration -> Maybe IdeDeclaration +convertDecl P.EDType{..} = Just (IdeType edTypeName edTypeKind) +convertDecl P.EDTypeSynonym{..} = + Just (IdeTypeSynonym edTypeSynonymName edTypeSynonymType) convertDecl P.EDDataConstructor{..} = Just $ - DataConstructor (runProperNameT edDataCtorName) edDataCtorTypeCtor edDataCtorType + IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType convertDecl P.EDValue{..} = Just $ - ValueDeclaration (runIdentT edValueName) edValueType -convertDecl P.EDClass{..} = Just $ TypeClassDeclaration edClassName + IdeValue edValueName edValueType +convertDecl P.EDClass{..} = Just (IdeTypeClass edClassName) convertDecl P.EDInstance{} = Nothing -convertOperator :: P.ExternsFixity -> ExternDecl +convertOperator :: P.ExternsFixity -> IdeDeclaration convertOperator P.ExternsFixity{..} = - ValueOperator + IdeValueOperator efOperator (toS (P.showQualified (either P.runIdent P.runProperName) efAlias)) efPrecedence efAssociativity -convertTypeOperator :: P.ExternsTypeFixity -> ExternDecl +convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration convertTypeOperator P.ExternsTypeFixity{..} = - TypeOperator + IdeTypeOperator efTypeOperator (toS (P.showQualified P.runProperName efTypeAlias)) efTypePrecedence efTypeAssociativity -unwrapPositioned :: P.Declaration -> P.Declaration -unwrapPositioned (P.PositionedDeclaration _ _ x) = x -unwrapPositioned x = x - -unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef -unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = x -unwrapPositionedRef x = x - -convertModule :: ModuleOld -> Module -convertModule (mn, decls) = (P.moduleNameFromString (toS mn), mapMaybe convertDeclaration decls) - where convertDeclaration :: ExternDecl -> Maybe IdeDeclaration - convertDeclaration d = case d of - ValueDeclaration i t -> Just (IdeValue i t) - TypeDeclaration i k -> Just (IdeType i k) - TypeSynonymDeclaration i t -> Just (IdeTypeSynonym i t) - DataConstructor i tn t -> Just (IdeDataConstructor i tn t) - TypeClassDeclaration i -> Just (IdeTypeClass i) - ValueOperator n i p a -> Just (IdeValueOperator n i p a) - TypeOperator n i p a -> Just (IdeTypeOperator n i p a) - Dependency{} -> Nothing - ModuleDecl _ _ -> Nothing - Export _ -> Nothing +annotateLocations :: Map (Either Text Text) P.SourceSpan -> Module -> Module +annotateLocations ast (moduleName, decls) = + (moduleName, map convertDeclaration decls) + where + convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn + convertDeclaration (IdeDeclarationAnn ann d) = case d of + IdeValue i t -> + annotateValue (runIdentT i) (IdeValue i t) + IdeType i k -> + annotateType (runProperNameT i) (IdeType i k) + IdeTypeSynonym i t -> + annotateType (runProperNameT i) (IdeTypeSynonym i t) + IdeDataConstructor i tn t -> + annotateValue (runProperNameT i) (IdeDataConstructor i tn t) + IdeTypeClass i -> + annotateType (runProperNameT i) (IdeTypeClass i) + IdeValueOperator n i p a -> + annotateValue i (IdeValueOperator n i p a) + IdeTypeOperator n i p a -> + annotateType i (IdeTypeOperator n i p a) + where + annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) ast}) + annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Right x) ast}) diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 5d1f67b3a1..e0b79a4cf0 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -20,7 +20,6 @@ module Language.PureScript.Ide.Filter , moduleFilter , prefixFilter , equalityFilter - , runFilter , applyFilters ) where @@ -65,11 +64,12 @@ identFilter predicate search = filter (not . null . snd) . fmap filterModuleDecls where filterModuleDecls :: Module -> Module - filterModuleDecls (moduleIdent,decls) = - (moduleIdent, filter (`predicate` search) decls) + filterModuleDecls (moduleIdent, decls) = + (moduleIdent, filter (flip predicate search . getDeclaration) decls) + getDeclaration (IdeDeclarationAnn _ d) = d runFilter :: Filter -> [Module] -> [Module] -runFilter (Filter f)= appEndo f +runFilter (Filter f) = appEndo f applyFilters :: [Filter] -> [Module] -> [Module] applyFilters = runFilter . fold diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 296dce8ffe..e26796e136 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -36,8 +36,6 @@ import qualified Data.Text.IO as TIO import qualified Language.PureScript as P import Language.PureScript.Ide.Completion import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Externs (unwrapPositioned, - unwrapPositionedRef) import Language.PureScript.Ide.Filter import Language.PureScript.Ide.State import Language.PureScript.Ide.Types @@ -203,7 +201,7 @@ addExplicitImport' decl moduleName imports = refFromDeclaration (IdeTypeClass n) = P.TypeClassRef n refFromDeclaration (IdeDataConstructor n tn _) = - P.TypeRef tn (Just [P.ProperName (T.unpack n)]) + P.TypeRef tn (Just [n]) refFromDeclaration (IdeType n _) = P.TypeRef n (Just []) refFromDeclaration (IdeValueOperator op _ _ _) = @@ -222,10 +220,7 @@ addExplicitImport' decl moduleName imports = insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef] insertDeclIntoRefs (IdeDataConstructor dtor tn _) refs = - let - dtor' = P.ProperName (T.unpack dtor) - in - updateAtFirstOrPrepend (matchType tn) (insertDtor dtor') (P.TypeRef tn (Just [dtor'])) refs + updateAtFirstOrPrepend (matchType tn) (insertDtor dtor) (P.TypeRef tn (Just [dtor])) refs insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) insertDtor dtor (P.TypeRef tn' dtors) = @@ -261,17 +256,17 @@ addImportForIdentifier :: (Ide m, MonadError PscIdeError m) -> Text -- ^ The identifier to import -> [Filter] -- ^ Filters to apply before searching for -- the identifier - -> m (Either [Match] [Text]) + -> m (Either [Match IdeDeclaration] [Text]) addImportForIdentifier fp ident filters = do - modules <- getAllModules2 Nothing - case getExactMatches ident filters modules of + modules <- getAllModules Nothing + case map (fmap discardAnn) (getExactMatches ident filters modules) of [] -> throwError (NotFound "Couldn't find the given identifier. \ \Have you loaded the corresponding module?") -- Only one match was found for the given identifier, so we can insert it -- right away - [Match m decl] -> + [Match (m, decl)] -> Right <$> addExplicitImport fp decl m -- This case comes up for newtypes and dataconstructors. Because values and @@ -279,7 +274,7 @@ addImportForIdentifier fp ident filters = do -- module. This also happens for parameterized types, as these generate both -- a type aswell as a type synonym. - ms@[Match m1 d1, Match m2 d2] -> + ms@[Match (m1, d1), Match (m2, d2)] -> if m1 /= m2 -- If the modules don't line up we just ask the user to specify the -- module diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index e1b11fa845..a2fb0dbce3 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -14,11 +14,13 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} module Language.PureScript.Ide.Matcher ( Matcher - , flexMatcher , runMatcher + -- for tests + , flexMatcher ) where import Protolude @@ -32,23 +34,22 @@ import Text.EditDistance import Text.Regex.TDFA ((=~)) -type ScoredMatch = (Match, Double) +type ScoredMatch a = (Match a, Double) -newtype Matcher = Matcher (Endo [Match]) deriving (Monoid) +newtype Matcher a = Matcher (Endo [Match a]) deriving (Monoid) -instance FromJSON Matcher where +instance FromJSON (Matcher IdeDeclaration) where parseJSON = withObject "matcher" $ \o -> do (matcher :: Maybe Text) <- o .:? "matcher" case matcher of Just "flex" -> do params <- o .: "params" - search <- params .: "search" - pure $ flexMatcher search + flexMatcher <$> params .: "search" Just "distance" -> do params <- o .: "params" - search <- params .: "search" - maxDist <- params .: "maximumDistance" - pure $ distanceMatcher search maxDist + distanceMatcher + <$> params .: "search" + <*> params .: "maximumDistance" Just _ -> mzero Nothing -> return mempty @@ -59,37 +60,37 @@ instance FromJSON Matcher where -- Examples: -- flMa matches flexMatcher. Score: 14.28 -- sons matches sortCompletions. Score: 6.25 -flexMatcher :: Text -> Matcher +flexMatcher :: Text -> Matcher IdeDeclaration flexMatcher p = mkMatcher (flexMatch p) -distanceMatcher :: Text -> Int -> Matcher +distanceMatcher :: Text -> Int -> Matcher IdeDeclaration distanceMatcher q maxDist = mkMatcher (distanceMatcher' q maxDist) -distanceMatcher' :: Text -> Int -> [Match] -> [ScoredMatch] +distanceMatcher' :: Text -> Int -> [Match IdeDeclaration] -> [ScoredMatch IdeDeclaration] distanceMatcher' q maxDist = mapMaybe go where go m = let d = dist (T.unpack y) - y = identifierFromMatch m + y = identifierFromIdeDeclaration (unwrapMatch m) in if d <= maxDist then Just (m, 1 / fromIntegral d) else Nothing dist = levenshteinDistance defaultEditCosts (T.unpack q) -mkMatcher :: ([Match] -> [ScoredMatch]) -> Matcher +mkMatcher :: ([Match a] -> [ScoredMatch a]) -> Matcher a mkMatcher matcher = Matcher . Endo $ fmap fst . sortCompletions . matcher -runMatcher :: Matcher -> [Match] -> [Match] +runMatcher :: Matcher a -> [Match a] -> [Match a] runMatcher (Matcher m)= appEndo m -sortCompletions :: [ScoredMatch] -> [ScoredMatch] +sortCompletions :: [ScoredMatch a] -> [ScoredMatch a] sortCompletions = sortBy (flip compare `on` snd) -flexMatch :: Text -> [Match] -> [ScoredMatch] +flexMatch :: Text -> [Match IdeDeclaration] -> [ScoredMatch IdeDeclaration] flexMatch = mapMaybe . flexRate -flexRate :: Text -> Match -> Maybe ScoredMatch +flexRate :: Text -> Match IdeDeclaration -> Maybe (ScoredMatch IdeDeclaration) flexRate p c = do - score <- flexScore p (identifierFromMatch c) + score <- flexScore p (identifierFromIdeDeclaration (unwrapMatch c)) return (c, score) -- FlexMatching ala Sublime. diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs index 53e10a7db2..9032a3457b 100644 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -14,7 +14,10 @@ {-# LANGUAGE OverloadedStrings #-} -module Language.PureScript.Ide.Pursuit where +module Language.PureScript.Ide.Pursuit + ( searchPursuitForDeclarations + , findPackagesForModuleIdent + ) where import Protolude diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index d3b1faf8c8..807f3d791e 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -14,84 +14,105 @@ ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} module Language.PureScript.Ide.Reexports - ( resolveReexports2 - -- for tests - , getReexports - , replaceReexport - , replaceReexports + ( resolveReexports + , prettyPrintReexportResult + , reexportHasFailures + , ReexportResult(..) ) where - import Protolude -import Data.List (union) import qualified Data.Map as Map import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Externs +import Language.PureScript.Ide.Util import qualified Language.PureScript as P -getReexports :: ModuleOld -> [ExternDecl] -getReexports (mn, decls)= concatMap getExport decls - where getExport d - | (Export mn') <- d - , mn /= mn' = replaceExportWithAliases decls mn' - | otherwise = [] - -dependencyToExport :: ExternDecl -> ExternDecl -dependencyToExport (Dependency m _ _) = Export m -dependencyToExport decl = decl - -replaceExportWithAliases :: [ExternDecl] -> ModuleIdent -> [ExternDecl] -replaceExportWithAliases decls ident = - case filter isMatch decls of - [] -> [Export ident] - aliases -> map dependencyToExport aliases - where isMatch d - | Dependency _ _ (Just alias) <- d - , alias == ident = True - | otherwise = False - -replaceReexport :: ExternDecl -> ModuleOld -> ModuleOld -> ModuleOld -replaceReexport e@(Export _) (m, decls) (_, newDecls) = - (m, filter (/= e) decls `union` newDecls) -replaceReexport _ _ _ = P.internalError "Should only get Exports here" - -emptyModule :: ModuleOld -emptyModule = ("Empty", []) - -isExport :: ExternDecl -> Bool -isExport (Export _) = True -isExport _ = False - -removeExportDecls :: ModuleOld -> ModuleOld -removeExportDecls = fmap (filter (not . isExport)) - -replaceReexports :: ModuleOld -> Map ModuleIdent [ExternDecl] -> ModuleOld -replaceReexports m db = result +-- | Contains the module with resolved reexports, and eventual failures +data ReexportResult a + = ReexportResult + { reResolved :: a + , reFailed :: [(P.ModuleName, P.DeclarationRef)] + } deriving (Show, Eq, Functor) + +-- | Uses the passed formatter to format the resolved module, and adds eventual +-- failures +prettyPrintReexportResult + :: (a -> Text) + -- ^ Formatter for the resolved result + -> ReexportResult a + -- ^ The Result to be pretty printed + -> Text +prettyPrintReexportResult f ReexportResult{..} + | null reFailed = + "Successfully resolved reexports for " <> f reResolved + | otherwise = + "Failed to resolve reexports for " + <> f reResolved + <> foldMap (\(mn, ref) -> runModuleNameT mn <> show ref) reFailed + +-- | Whether any Refs couldn't be resolved +reexportHasFailures :: ReexportResult a -> Bool +reexportHasFailures = not . null . reFailed + +-- | Resolves Reexports for a given Module, by looking up the reexported values +-- from the passed in Map +resolveReexports + :: Map P.ModuleName [IdeDeclarationAnn] + -- ^ Modules to search for the reexported declarations + -> (Module, [(P.ModuleName, P.DeclarationRef)]) + -- ^ The module to resolve reexports for, aswell as the references to resolve + -> ReexportResult Module +resolveReexports modules ((moduleName, decls), refs) = + ReexportResult (moduleName, decls <> concat resolvedRefs) failedRefs + where + (failedRefs, resolvedRefs) = partitionEithers (resolveRef' <$> refs) + resolveRef' x@(mn, r) = case Map.lookup mn modules of + Nothing -> Left x + Just decls' -> first (mn,) (resolveRef decls' r) + +resolveRef + :: [IdeDeclarationAnn] + -> P.DeclarationRef + -> Either P.DeclarationRef [IdeDeclarationAnn] +resolveRef decls ref = case ref of + P.TypeRef tn mdtors -> + case findRef (\case IdeType name _ -> name == tn; _ -> False) of + Nothing -> Left ref + Just d -> Right $ d : case mdtors of + Nothing -> + -- If the dataconstructor field inside the TypeRef is Nothing, that + -- means that all data constructors are exported, so we need to look + -- those up ourselfes + findDtors tn + Just dtors -> mapMaybe lookupDtor dtors + P.ValueRef i -> + findWrapped (\case IdeValue i' _ -> i' == i; _ -> False) + P.TypeOpRef name -> + findWrapped (\case IdeTypeOperator n _ _ _ -> n == name; _ -> False) + P.ValueOpRef name -> + findWrapped (\case IdeValueOperator n _ _ _ -> n == name; _ -> False) + P.TypeClassRef name -> + findWrapped (\case IdeTypeClass n -> n == name; _ -> False) + _ -> + Left ref where - reexports = getReexports m - result = foldl go (removeExportDecls m) reexports + findWrapped = wrapSingle . findRef + wrapSingle = maybe (Left ref) (Right . pure) + findRef f = find (f . discardAnn) decls - go :: ModuleOld -> ExternDecl -> ModuleOld - go m' re@(Export name) = replaceReexport re m' (getModule name) - go _ _ = P.internalError "Should only get Exports here" + lookupDtor name = + findRef (\case IdeDataConstructor name' _ _ -> name == name' + _ -> False) - getModule :: ModuleIdent -> ModuleOld - getModule name = clean res + findDtors tn = filter (f . discardAnn) decls where - res = fromMaybe emptyModule $ (name , ) <$> Map.lookup name db - -- we have to do this because keeping self exports in will result in - -- infinite loops - clean (mn, decls) = (mn,) (filter (/= Export mn) decls) - -resolveReexports :: Map ModuleIdent [ExternDecl] -> ModuleOld -> ModuleOld -resolveReexports modules m = - let replaced = replaceReexports m modules - in if null (getReexports replaced) - then replaced - else resolveReexports modules replaced - -resolveReexports2 :: Map Text [ExternDecl] -> ModuleOld -> Module -resolveReexports2 decls = convertModule . resolveReexports decls + f :: IdeDeclaration -> Bool + f decl + | (IdeDataConstructor _ tn' _) <- decl + , tn == tn' = True + | otherwise = False diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 850e7b88c9..6e9ba0c8a0 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -17,8 +17,7 @@ module Language.PureScript.Ide.SourceFile ( parseModule , getImportsForFile - -- SOON... - , getDeclPosition + , extractSpans ) where import Protolude @@ -26,8 +25,6 @@ import Protolude import qualified Language.PureScript as P import Language.PureScript.Ide.Error import Language.PureScript.Ide.Util -import Language.PureScript.Ide.Externs (unwrapPositioned, - unwrapPositionedRef) import Language.PureScript.Ide.Types import System.FilePath import System.IO.UTF8 (readUTF8File) @@ -68,31 +65,41 @@ getImportsForFile fp = do unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls) unwrapImportType P.Implicit = P.Implicit -getDeclPosition :: P.Module -> Text -> Maybe P.SourceSpan -getDeclPosition m ident = getFirst (foldMap (match ident) decls) +-- | Given a surrounding Sourcespan and a Declaration from the PS AST, extracts +-- definition sites inside that Declaration. +extractSpans + :: P.SourceSpan + -- ^ The surrounding span + -> P.Declaration + -- ^ The declaration to extract spans from + -> [(Either Text Text, P.SourceSpan)] + -- ^ A @Right@ corresponds to a type level declaration, and a @Left@ to a + -- value level one +extractSpans ss d = case d of + P.PositionedDeclaration ss' _ d' -> + extractSpans ss' d' + P.ValueDeclaration i _ _ _ -> + [(Left (runIdentT i), ss)] + P.TypeSynonymDeclaration name _ _ -> + [(Right (runProperNameT name), ss)] + P.TypeClassDeclaration name _ _ members -> + (Right (runProperNameT name), ss) : concatMap (extractSpans' ss) members + P.DataDeclaration _ name _ ctors -> + (Right (runProperNameT name), ss) + : map (\(cname, _) -> (Left (runProperNameT cname), ss)) ctors + P.ExternDeclaration ident _ -> + [(Left (runIdentT ident), ss)] + P.ExternDataDeclaration name _ -> + [(Right (runProperNameT name), ss)] + _ -> [] where - decls = getDeclarations m - match q (P.PositionedDeclaration ss _ decl) = First (if go q decl - then Just ss - else Nothing) - match _ _ = First Nothing - - go q (P.DataDeclaration _ name _ constructors) = - properEqual name q || any (\(x,_) -> properEqual x q) constructors - go q (P.DataBindingGroupDeclaration decls') = any (go q) decls' - go q (P.TypeSynonymDeclaration name _ _) = properEqual name q - go q (P.TypeDeclaration ident' _) = identEqual ident' q - go q (P.ValueDeclaration ident' _ _ _) = identEqual ident' q - go q (P.ExternDeclaration ident' _) = identEqual ident' q - go q (P.ExternDataDeclaration name _) = properEqual name q - go q (P.TypeClassDeclaration name _ _ members) = - properEqual name q || any (go q . unwrapPositioned) members - go q (P.TypeInstanceDeclaration ident' _ _ _ _) = - identEqual ident' q - go _ _ = False - - properEqual x q = runProperNameT x == q - identEqual x q = runIdentT x == q - - getDeclarations :: P.Module -> [P.Declaration] - getDeclarations (P.Module _ _ _ declarations _) = declarations + -- We need this special case to be able to also get the position info for + -- typeclass member functions. Typedeclaratations would clash with value + -- declarations for non-typeclass members, which is why we can't handle them + -- in extractSpans. + extractSpans' ssP dP = case dP of + P.PositionedDeclaration ssP' _ dP' -> + extractSpans' ssP' dP' + P.TypeDeclaration ident _ -> + [(Left (runIdentT ident), ssP)] + _ -> [] diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index d82aa1d065..4621d3947a 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -19,20 +19,15 @@ module Language.PureScript.Ide.State ( getLoadedModulenames , getExternFiles - , insertModuleOld , resetIdeState , cacheRebuild , insertExterns , insertModule - , insertModuleSTM , insertExternsSTM - , getAllModules2 - , getStage1 - , setStage1 - , getStage2 - , setStage2 + , getAllModules , populateStage2 - , populateStage2STM + , populateStage3 + , populateStage3STM ) where import Protolude @@ -44,6 +39,7 @@ import qualified Data.Map.Lazy as M import Language.PureScript.Externs import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Reexports +import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import qualified Language.PureScript as P @@ -53,12 +49,10 @@ import System.FilePath -- | Resets all State inside psc-ide resetIdeState :: Ide m => m () resetIdeState = do - stateVar <- envStateVar <$> ask ideVar <- ideStateVar <$> ask liftIO . atomically $ do - writeTVar stateVar emptyPscIdeState writeTVar ideVar emptyIdeState - setStage2STM ideVar emptyStage2 + setStage3STM ideVar emptyStage3 -- | Gets the loaded Modulenames getLoadedModulenames :: Ide m => m [P.ModuleName] @@ -68,26 +62,6 @@ getLoadedModulenames = M.keys <$> getExternFiles getExternFiles :: Ide m => m (M.Map P.ModuleName ExternsFile) getExternFiles = s1Externs <$> getStage1 --- | Inserts an @ExternsFile@ into the PscIdeState. Also converts the --- ExternsFile into psc-ide's internal Declaration format --- TODO: should be removed when the "old" Declaration format gets removed -insertModuleOld :: Ide m => ExternsFile -> m () -insertModuleOld externsFile = do - stateVar <- envStateVar <$> ask - liftIO . atomically $ insertModuleOldSTM stateVar externsFile - --- | STM version of insertModuleOld -insertModuleOldSTM :: TVar PscIdeState -> ExternsFile -> STM () -insertModuleOldSTM st ef = modifyTVar st (insertModule' ef) - --- | Pure version of insertModuleOld -insertModule' :: ExternsFile -> PscIdeState -> PscIdeState -insertModule' ef state = - state - { pscIdeStateModules = let (mn, decls) = convertExterns ef - in M.insert mn decls (pscIdeStateModules state) - } - -- | Insert a Module into Stage1 of the State insertModule :: Ide m => (FilePath, P.Module) -> m () insertModule module' = do @@ -106,7 +80,6 @@ insertModuleSTM ref (fp, module') = -- | Retrieves Stage1 from the State. -- This includes loaded Externfiles --- (TODO: as soon as we actually parse the modules) aswell as the parsed modules getStage1 :: Ide m => m Stage1 getStage1 = do st <- ideStateVar <$> ask @@ -116,27 +89,14 @@ getStage1 = do getStage1STM :: TVar IdeState -> STM Stage1 getStage1STM ref = ideStage1 <$> readTVar ref --- | Sets Stage1 inside the compiler -setStage1 :: Ide m => Stage1 -> m () -setStage1 s1 = do - st <- ideStateVar <$> ask - liftIO . atomically . modifyTVar st $ \x -> - x {ideStage1 = s1} - pure () - --- TODO: Soon to be Stage3 -- | Retrieves Stage2 from the State. --- This includes the denormalized Declarations and cached rebuilds getStage2 :: Ide m => m Stage2 getStage2 = do st <- ideStateVar <$> ask - fmap ideStage2 . liftIO . readTVarIO $ st + liftIO (atomically (getStage2STM st)) --- | Sets Stage2 inside the compiler -setStage2 :: Ide m => Stage2 -> m () -setStage2 s2 = do - st <- ideStateVar <$> ask - liftIO . atomically $ setStage2STM st s2 +getStage2STM :: TVar IdeState -> STM Stage2 +getStage2STM ref = ideStage2 <$> readTVar ref -- | STM version of setStage2 setStage2STM :: TVar IdeState -> Stage2 -> STM () @@ -145,21 +105,38 @@ setStage2STM ref s2 = do x {ideStage2 = s2} pure () +-- | Retrieves Stage3 from the State. +-- This includes the denormalized Declarations and cached rebuilds +getStage3 :: Ide m => m Stage3 +getStage3 = do + st <- ideStateVar <$> ask + fmap ideStage3 . liftIO . readTVarIO $ st + +-- | Sets Stage3 inside the compiler +setStage3STM :: TVar IdeState -> Stage3 -> STM () +setStage3STM ref s3 = do + modifyTVar ref $ \x -> + x {ideStage3 = s3} + pure () + -- | Checks if the given ModuleName matches the last rebuild cache and if it -- does returns all loaded definitions + the definitions inside the rebuild -- cache -getAllModules2 :: Ide m => Maybe P.ModuleName -> m [(P.ModuleName, [IdeDeclaration])] -getAllModules2 mmoduleName = do - declarations <- s2Declarations <$> getStage2 +getAllModules :: Ide m => Maybe P.ModuleName -> m [Module] +getAllModules mmoduleName = do + declarations <- s3Declarations <$> getStage3 rebuild <- cachedRebuild case mmoduleName of Nothing -> pure (M.toList declarations) Just moduleName -> case rebuild of Just (cachedModulename, ef) - | cachedModulename == moduleName -> - pure . M.toList $ - M.insert moduleName (snd . convertModule . convertExterns $ ef) declarations + | cachedModulename == moduleName -> do + (AstData asts) <- s2AstData <$> getStage2 + let ast = fromMaybe M.empty (M.lookup moduleName asts) + pure . M.toList $ + M.insert moduleName + (snd . annotateLocations ast . fst . convertExterns $ ef) declarations _ -> pure (M.toList declarations) -- | Adds an ExternsFile into psc-ide's State Stage1. This does not populate the @@ -182,14 +159,14 @@ cacheRebuild :: Ide m => ExternsFile -> m () cacheRebuild ef = do st <- ideStateVar <$> ask liftIO . atomically . modifyTVar st $ \x -> - x { ideStage2 = (ideStage2 x) { - s2CachedRebuild = Just (efModuleName ef, ef)}} + x { ideStage3 = (ideStage3 x) { + s3CachedRebuild = Just (efModuleName ef, ef)}} -- | Retrieves the rebuild cache cachedRebuild :: Ide m => m (Maybe (P.ModuleName, ExternsFile)) -cachedRebuild = s2CachedRebuild <$> getStage2 +cachedRebuild = s3CachedRebuild <$> getStage3 --- | Resolves reexports and populates Stage2 with data to be used in queries. +-- | Extracts source spans from the parsed ASTs populateStage2 :: (Ide m, MonadLogger m) => m () populateStage2 = do st <- ideStateVar <$> ask @@ -203,9 +180,35 @@ populateStage2 = do -- | STM version of populateStage2 populateStage2STM :: TVar IdeState -> STM () populateStage2STM ref = do + modules <- s1Modules <$> getStage1STM ref + let spans = map (\((P.Module ss _ _ decls _), _) -> M.fromList (concatMap (extractSpans ss) decls)) modules + setStage2STM ref (Stage2 (AstData spans)) + +-- | Resolves reexports and populates Stage3 with data to be used in queries. +populateStage3 :: (Ide m, MonadLogger m) => m () +populateStage3 = do + st <- ideStateVar <$> ask + (duration, results) <- liftIO $ do + start <- getTime Monotonic + results <- atomically (populateStage3STM st) + end <- getTime Monotonic + pure (Prelude.show (diffTimeSpec start end), results) + traverse_ + (logWarnN . prettyPrintReexportResult (runModuleNameT . fst)) + (filter reexportHasFailures results) + $(logDebug) $ "Finished populating Stage3 in " <> toS duration + +-- | STM version of populateStage3 +populateStage3STM :: TVar IdeState -> STM [ReexportResult Module] +populateStage3STM ref = do externs <- s1Externs <$> getStage1STM ref - -- Build the "old" ExternDecl format - let modules = M.mapKeys runModuleNameT (M.map (snd . convertExterns) externs) - -- Convert ExternDecl into IdeDeclaration - declarations = resolveReexports2 modules <$> M.toList modules - setStage2STM ref (Stage2 (M.fromList declarations) Nothing) + (AstData asts) <- s2AstData <$> getStage2STM ref + let modules = M.map convertExterns externs + nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)]) + nModules = M.mapWithKey + (\moduleName (m, refs) -> + (fromMaybe m $ annotateLocations <$> M.lookup moduleName asts <*> pure m, refs)) modules + -- resolves reexports and discards load failures for now + result = resolveReexports (M.map (snd . fst) nModules) <$> M.elems nModules + setStage3STM ref (Stage3 (M.fromList (map reResolved result)) Nothing) + pure result diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 57441420a1..6bcfc7e7f7 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -13,6 +13,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFoldable #-} module Language.PureScript.Ide.Types where @@ -28,47 +29,35 @@ import System.FilePath import Text.Parsec as Parsec import Text.Parsec.Text -type Ident = Text type ModuleIdent = Text -data ExternDecl - -- | A function/value declaration - = ValueDeclaration Ident P.Type - | TypeDeclaration (P.ProperName 'P.TypeName) P.Kind - | TypeSynonymDeclaration (P.ProperName 'P.TypeName) P.Type - -- | A Dependency onto another Module - | Dependency - ModuleIdent -- name of the dependency - [Text] -- explicit imports - (Maybe Text) -- An eventual qualifier - -- | A module declaration - | ModuleDecl - ModuleIdent -- The modules name - [Ident] -- The exported identifiers - -- | A data/newtype declaration - | DataConstructor - Ident -- The type name - (P.ProperName 'P.TypeName) - P.Type -- The "type" - -- | An exported module - | TypeClassDeclaration (P.ProperName 'P.ClassName) - | ValueOperator (P.OpName 'P.ValueOpName) Ident P.Precedence P.Associativity - | TypeOperator (P.OpName 'P.TypeOpName) Ident P.Precedence P.Associativity - | Export ModuleIdent -- The exported Modules name - deriving (Show,Eq,Ord) - data IdeDeclaration - = IdeValue Ident P.Type + = IdeValue P.Ident P.Type | IdeType (P.ProperName 'P.TypeName) P.Kind | IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type - | IdeDataConstructor Ident (P.ProperName 'P.TypeName) P.Type + | IdeDataConstructor (P.ProperName 'P.ConstructorName) (P.ProperName 'P.TypeName) P.Type | IdeTypeClass (P.ProperName 'P.ClassName) - | IdeValueOperator (P.OpName 'P.ValueOpName) Ident P.Precedence P.Associativity - | IdeTypeOperator (P.OpName 'P.TypeOpName) Ident P.Precedence P.Associativity + | IdeValueOperator (P.OpName 'P.ValueOpName) Text P.Precedence P.Associativity + | IdeTypeOperator (P.OpName 'P.TypeOpName) Text P.Precedence P.Associativity + deriving (Show, Eq, Ord) + +data IdeDeclarationAnn = IdeDeclarationAnn Annotation IdeDeclaration deriving (Show, Eq, Ord) -type Module = (P.ModuleName, [IdeDeclaration]) -type ModuleOld = (Text, [ExternDecl]) +data Annotation + = Annotation + { annLocation :: Maybe P.SourceSpan + , annExportedFrom :: Maybe P.ModuleName + } deriving (Show, Eq, Ord) + +emptyAnn :: Annotation +emptyAnn = Annotation Nothing Nothing + +type Module = (P.ModuleName, [IdeDeclarationAnn]) + +newtype AstData a = + AstData (Map P.ModuleName (Map (Either Text Text) a)) + deriving (Show, Eq, Ord, Functor, Foldable) data Configuration = Configuration @@ -79,34 +68,29 @@ data Configuration = data IdeEnvironment = IdeEnvironment - { envStateVar :: TVar PscIdeState - , ideStateVar :: TVar IdeState + { ideStateVar :: TVar IdeState , ideConfiguration :: Configuration } type Ide m = (MonadIO m, MonadReader IdeEnvironment m) -data PscIdeState = - PscIdeState - { pscIdeStateModules :: M.Map Text [ExternDecl] - } deriving Show - -emptyPscIdeState :: PscIdeState -emptyPscIdeState = PscIdeState M.empty - data IdeState = IdeState { ideStage1 :: Stage1 , ideStage2 :: Stage2 + , ideStage3 :: Stage3 } emptyIdeState :: IdeState -emptyIdeState = IdeState emptyStage1 emptyStage2 +emptyIdeState = IdeState emptyStage1 emptyStage2 emptyStage3 emptyStage1 :: Stage1 emptyStage1 = Stage1 M.empty M.empty emptyStage2 :: Stage2 -emptyStage2 = Stage2 M.empty Nothing +emptyStage2 = Stage2 (AstData M.empty) + +emptyStage3 :: Stage3 +emptyStage3 = Stage3 M.empty Nothing data Stage1 = Stage1 { s1Externs :: M.Map P.ModuleName P.ExternsFile @@ -114,19 +98,31 @@ data Stage1 = Stage1 } data Stage2 = Stage2 - { s2Declarations :: M.Map P.ModuleName [IdeDeclaration] - , s2CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile) + { s2AstData :: AstData P.SourceSpan + } + +data Stage3 = Stage3 + { s3Declarations :: M.Map P.ModuleName [IdeDeclarationAnn] + , s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile) } -data Match = Match P.ModuleName IdeDeclaration - deriving (Show, Eq) +newtype Match a = Match (P.ModuleName, a) + deriving (Show, Eq, Functor) newtype Completion = - Completion (ModuleIdent, Ident, Text) + Completion (Text, Text, Text) deriving (Show,Eq) +newtype Info = + Info (Text, Text, Text, Maybe P.SourceSpan) + deriving (Show,Eq) + +instance ToJSON Info where + toJSON (Info (m, d, t, sourceSpan)) = + object ["module" .= m, "identifier" .= d, "type" .= t, "definedAt" .= sourceSpan] + instance ToJSON Completion where - toJSON (Completion (m,d,t)) = + toJSON (Completion (m, d, t)) = object ["module" .= m, "identifier" .= d, "type" .= t] data ModuleImport = @@ -165,6 +161,7 @@ identifierFromDeclarationRef _ = "" data Success = CompletionResult [Completion] + | InfoResult [Info] | TextResult Text | MultilineTextResult [Text] | PursuitResult [PursuitResponse] @@ -179,6 +176,7 @@ encodeSuccess res = instance ToJSON Success where toJSON (CompletionResult cs) = encodeSuccess cs + toJSON (InfoResult i) = encodeSuccess i toJSON (TextResult t) = encodeSuccess t toJSON (MultilineTextResult ts) = encodeSuccess ts toJSON (PursuitResult resp) = encodeSuccess resp @@ -208,7 +206,7 @@ data PursuitResponse = ModuleResponse ModuleIdent Text -- | A Pursuit Response for a declaration. Consist of the declarations type, -- module, name and package - | DeclarationResponse Text ModuleIdent Ident Text + | DeclarationResponse Text ModuleIdent Text Text deriving (Show,Eq) instance FromJSON PursuitResponse where diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index ec786e26e6..4e4c235516 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -16,10 +16,14 @@ module Language.PureScript.Ide.Util ( identifierFromIdeDeclaration - , identifierFromMatch + , unwrapMatch + , unwrapPositioned + , unwrapPositionedRef , completionFromMatch + , infoFromMatch , encodeT , decodeT + , discardAnn , module Language.PureScript.Ide.Conversions ) where @@ -33,26 +37,34 @@ import Language.PureScript.Ide.Conversions identifierFromIdeDeclaration :: IdeDeclaration -> Text identifierFromIdeDeclaration d = case d of - IdeValue name _ -> name + IdeValue name _ -> runIdentT name IdeType name _ -> runProperNameT name IdeTypeSynonym name _ -> runProperNameT name - IdeDataConstructor name _ _ -> name + IdeDataConstructor name _ _ -> runProperNameT name IdeTypeClass name -> runProperNameT name IdeValueOperator op _ _ _ -> runOpNameT op IdeTypeOperator op _ _ _ -> runOpNameT op -identifierFromMatch :: Match -> Text -identifierFromMatch (Match _ ed) = identifierFromIdeDeclaration ed +discardAnn :: IdeDeclarationAnn -> IdeDeclaration +discardAnn (IdeDeclarationAnn _ d) = d -completionFromMatch :: Match -> Completion -completionFromMatch (Match m' d) = case d of - IdeValue name type' -> Completion (m, name, prettyTypeT type') - IdeType name kind -> Completion (m, runProperNameT name, toS (P.prettyPrintKind kind)) - IdeTypeSynonym name kind -> Completion (m, runProperNameT name, prettyTypeT kind) - IdeDataConstructor name _ type' -> Completion (m, name, prettyTypeT type') - IdeTypeClass name -> Completion (m, runProperNameT name, "class") - IdeValueOperator op ref precedence associativity -> Completion (m, runOpNameT op, showFixity precedence associativity ref op) - IdeTypeOperator op ref precedence associativity -> Completion (m, runOpNameT op, showFixity precedence associativity ref op) +unwrapMatch :: Match a -> a +unwrapMatch (Match (_, ed)) = ed + +completionFromMatch :: Match IdeDeclaration -> Completion +completionFromMatch = Completion . completionFromMatch' + +completionFromMatch' :: Match IdeDeclaration -> (Text, Text, Text) +completionFromMatch' (Match (m', d)) = case d of + IdeValue name type' -> (m, runIdentT name, prettyTypeT type') + IdeType name kind -> (m, runProperNameT name, toS (P.prettyPrintKind kind)) + IdeTypeSynonym name kind -> (m, runProperNameT name, prettyTypeT kind) + IdeDataConstructor name _ type' -> (m, runProperNameT name, prettyTypeT type') + IdeTypeClass name -> (m, runProperNameT name, "class") + IdeValueOperator op ref precedence associativity -> + (m, runOpNameT op, showFixity precedence associativity ref op) + IdeTypeOperator op ref precedence associativity -> + (m, runOpNameT op, showFixity precedence associativity ref op) where m = runModuleNameT m' showFixity p a r o = @@ -62,8 +74,22 @@ completionFromMatch (Match m' d) = case d of P.Infixr -> "infixr" in T.unwords [asso, show p, r, "as", runOpNameT o] +infoFromMatch :: Match IdeDeclarationAnn -> Info +infoFromMatch (Match (m, (IdeDeclarationAnn ann d))) = + Info (a, b, c, annLocation ann) + where + (a, b, c) = completionFromMatch' (Match (m, d)) + encodeT :: (ToJSON a) => a -> Text encodeT = toS . decodeUtf8 . encode decodeT :: (FromJSON a) => Text -> Maybe a decodeT = decode . encodeUtf8 . toS + +unwrapPositioned :: P.Declaration -> P.Declaration +unwrapPositioned (P.PositionedDeclaration _ _ x) = x +unwrapPositioned x = x + +unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef +unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = x +unwrapPositionedRef x = x diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs index 7990ff09ce..8ae6213100 100644 --- a/src/Language/PureScript/Ide/Watcher.hs +++ b/src/Language/PureScript/Ide/Watcher.hs @@ -12,7 +12,9 @@ -- File watcher for externs files ----------------------------------------------------------------------------- -module Language.PureScript.Ide.Watcher where +module Language.PureScript.Ide.Watcher + ( watcher + ) where import Protolude @@ -33,7 +35,7 @@ reloadFile ref ev = do case ef' of Left _ -> pure () Right ef -> do - atomically (insertExternsSTM ref ef *> populateStage2STM ref) + void $ atomically (insertExternsSTM ref ef *> populateStage3STM ref) putStrLn ("Reloaded File at: " ++ fp) -- | Installs filewatchers for the given directory and reloads ExternsFiles when diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index 8b89ac7618..cc705f82e7 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -8,8 +8,8 @@ import Language.PureScript.Ide.Types import qualified Language.PureScript as P import Test.Hspec -value :: Text -> IdeDeclaration -value s = IdeValue s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) +value :: Text -> IdeDeclarationAnn +value s = IdeDeclarationAnn emptyAnn (IdeValue (P.Ident (toS s)) P.REmpty) moduleA, moduleB :: Module moduleA = (P.moduleNameFromString "Module.A", [value "function1"]) @@ -19,13 +19,13 @@ modules :: [Module] modules = [moduleA, moduleB] runEq :: Text -> [Module] -runEq s = runFilter (equalityFilter s) modules +runEq s = applyFilters [equalityFilter s] modules runPrefix :: Text -> [Module] -runPrefix s = runFilter (prefixFilter s) modules +runPrefix s = applyFilters [prefixFilter s] modules runModule :: [P.ModuleName] -> [Module] -runModule ms = runFilter (moduleFilter ms) modules +runModule ms = applyFilters [moduleFilter ms] modules spec :: Spec spec = do diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index c8b2ba53a0..5b5ba321a8 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -68,11 +68,11 @@ spec = do describe "import commands" $ do let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i addValueImport i mn is = - prettyPrintImportSection (addExplicitImport' (IdeValue i wildcard) mn is) + prettyPrintImportSection (addExplicitImport' (IdeValue (P.Ident i) wildcard) mn is) addOpImport op mn is = prettyPrintImportSection (addExplicitImport' (IdeValueOperator op "" 2 P.Infix) mn is) addDtorImport i t mn is = - prettyPrintImportSection (addExplicitImport' (IdeDataConstructor i t wildcard) mn is) + prettyPrintImportSection (addExplicitImport' (IdeDataConstructor (P.ProperName i) t wildcard) mn is) it "adds an implicit unqualified import" $ shouldBe (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map")) diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs index 21a6996808..4f55441bd9 100644 --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -37,11 +37,13 @@ module Language.PureScript.Ide.Integration , getFlexCompletions , getFlexCompletionsInModule , getType + , getInfo , rebuildModule , reset -- checking results , resultIsSuccess , parseCompletions + , parseInfo , parseTextResult ) where @@ -53,6 +55,7 @@ import Data.Aeson.Types import qualified Data.Text as T import qualified Data.Vector as V import Language.PureScript.Ide.Util +import qualified Language.PureScript as P import System.Directory import System.FilePath import System.IO.Error (mkIOError, userErrorType) @@ -68,8 +71,8 @@ startServer = do pdir <- projectDirectory -- Turn off filewatching since it creates race condition in a testing environment (_, _, _, procHandle) <- createProcess $ - (shell "psc-ide-server --no-watch") {cwd = Just pdir} - threadDelay 500000 -- give the server 500ms to start up + (shell "psc-ide-server --no-watch src/*.purs") {cwd = Just pdir} + threadDelay 2000000 -- give the server 2s to start up return procHandle stopServer :: ProcessHandle -> IO () @@ -91,10 +94,7 @@ compileTestProject :: IO Bool compileTestProject = do pdir <- projectDirectory (_, _, _, procHandle) <- createProcess $ - (shell . toS $ "psc " <> fileGlob) { cwd = Just pdir - , std_out = CreatePipe - , std_err = CreatePipe - } + (shell . toS $ "psc " <> fileGlob) { cwd = Just pdir } r <- tryNTimes 5 (getProcessExitCode procHandle) pure (fromMaybe False (isSuccess <$> r)) @@ -167,6 +167,9 @@ getFlexCompletionsInModule q m = parseCompletions <$> sendCommand (completion [] getType :: Text -> IO [(Text, Text, Text)] getType q = parseCompletions <$> sendCommand (typeC q []) +getInfo :: Text -> IO [P.SourceSpan] +getInfo q = parseInfo <$> sendCommand (typeC q []) + addImport :: Text -> FilePath -> FilePath -> IO Text addImport identifier fp outfp = sendCommand (addImportC identifier fp outfp) @@ -259,6 +262,10 @@ completionParser = withArray "res" $ \cs -> ty <- o .: "type" pure (module', ident, ty)) (V.toList cs) +infoParser :: Value -> Parser [P.SourceSpan] +infoParser = withArray "res" $ \cs -> + mapM (withObject "info" $ \o -> o .: "definedAt") (V.toList cs) + valueFromText :: Text -> Value valueFromText = fromJust . decode . toS @@ -269,6 +276,10 @@ parseCompletions :: Text -> [(Text, Text, Text)] parseCompletions s = fromJust $ join (rightToMaybe <$> parseMaybe (withResult completionParser) (valueFromText s)) +parseInfo :: Text -> [P.SourceSpan] +parseInfo s = + fromJust $ join (rightToMaybe <$> parseMaybe (withResult infoParser) (valueFromText s)) + parseTextResult :: Text -> Text parseTextResult s = fromJust $ join (rightToMaybe <$> parseMaybe (withResult (withText "tr" pure)) (valueFromText s)) diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs index f81cbecbd1..04d0ae59a8 100644 --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -12,17 +12,17 @@ import Language.PureScript.Ide.Types import Test.Hspec value :: Text -> IdeDeclaration -value s = IdeValue s $ P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) +value s = IdeValue (P.Ident (toS s)) P.REmpty -firstResult, secondResult, fiult :: Match -firstResult = Match (P.moduleNameFromString "Match") (value "firstResult") -secondResult = Match (P.moduleNameFromString "Match") (value "secondResult") -fiult = Match (P.moduleNameFromString "Match") (value "fiult") +firstResult, secondResult, fiult :: Match IdeDeclaration +firstResult = Match (P.moduleNameFromString "Match", value "firstResult") +secondResult = Match (P.moduleNameFromString "Match", value "secondResult") +fiult = Match (P.moduleNameFromString "Match", value "fiult") -completions :: [Match] +completions :: [Match IdeDeclaration] completions = [firstResult, secondResult, fiult] -runFlex :: Text -> [Match] +runFlex :: Text -> [Match IdeDeclaration] runFlex s = runMatcher (flexMatcher s) completions setup :: IO () diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index b588b3e329..c9a59ff26f 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -2,78 +2,63 @@ {-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.ReexportsSpec where +import qualified Prelude as Prelude import Protolude -import qualified Data.Map as Map +import qualified Data.Map as Map import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.Types import qualified Language.PureScript as P import Test.Hspec -wildcard :: P.Type -wildcard = P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) - -decl1 :: ExternDecl -decl1 = ValueDeclaration "filter" wildcard -decl2 :: ExternDecl -decl2 = ValueDeclaration "map" wildcard -decl3 :: ExternDecl -decl3 = ValueDeclaration "catMaybe" wildcard -dep1 :: ExternDecl -dep1 = Dependency "Test.Foo" [] (Just "T") -dep2 :: ExternDecl -dep2 = Dependency "Test.Bar" [] (Just "T") - -circularModule :: ModuleOld -circularModule = ("Circular", [Export "Circular"]) - -module1 :: ModuleOld -module1 = ("Module1", [Export "Module2", Export "Module3", decl1]) - -module2 :: ModuleOld -module2 = ("Module2", [decl2]) - -module3 :: ModuleOld -module3 = ("Module3", [decl3]) - -module4 :: ModuleOld -module4 = ("Module4", [Export "T", decl1, dep1, dep2]) - -result :: ModuleOld -result = ("Module1", [decl1, decl2, Export "Module3"]) - -db :: Map ModuleIdent [ExternDecl] -db = Map.fromList [module1, module2, module3] - -shouldBeEqualSorted :: ModuleOld -> ModuleOld -> Expectation -shouldBeEqualSorted (n1, d1) (n2, d2) = (n1, sort d1) `shouldBe` (n2, sort d2) +m :: Prelude.String -> P.ModuleName +m = P.moduleNameFromString + +d :: IdeDeclaration -> IdeDeclarationAnn +d = IdeDeclarationAnn emptyAnn + +valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn +valueA = d (IdeValue (P.Ident "valueA") P.REmpty) +typeA = d (IdeType (P.ProperName "TypeA") P.Star) +classA = d (IdeTypeClass (P.ProperName "ClassA")) +dtorA1 = d (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty) +dtorA2 = d (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty) + +env :: Map P.ModuleName [IdeDeclarationAnn] +env = Map.fromList + [ (m "A", [valueA, typeA, classA, dtorA1, dtorA2]) + ] + +type Refs = [(P.ModuleName, P.DeclarationRef)] + +succTestCases :: [(Text, Module, Refs, Module)] +succTestCases = + [ ("resolves a value reexport", (m "C", []), [(m "A", P.ValueRef (P.Ident "valueA"))], (m "C", [valueA])) + , ("resolves a type reexport with explicit data constructors" + , (m "C", []), [(m "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], (m "C", [typeA, dtorA1])) + , ("resolves a type reexport with implicit data constructors" + , (m "C", []), [(m "A", P.TypeRef (P.ProperName "TypeA") Nothing)], (m "C", [typeA, dtorA1, dtorA2])) + , ("resolves a class reexport", (m "C", []), [(m "A", P.TypeClassRef (P.ProperName "ClassA"))], (m "C", [classA])) + ] + +failTestCases :: [(Text, Module, Refs)] +failTestCases = + [ ("fails to resolve a non existing value", (m "C", []), [(m "A", P.ValueRef (P.Ident "valueB"))]) + , ("fails to resolve a non existing type reexport" , (m "C", []), [(m "A", P.TypeRef (P.ProperName "TypeB") Nothing)]) + , ("fails to resolve a non existing class reexport", (m "C", []), [(m "A", P.TypeClassRef (P.ProperName "ClassB"))]) + ] spec :: Spec -spec = - describe "Reexports" $ do - it "finds all reexports" $ - getReexports module1 `shouldBe` [Export "Module2", Export "Module3"] - - it "replaces a reexport with another module" $ - replaceReexport (Export "Module2") module1 module2 `shouldBeEqualSorted` result - - it "adds another module even if there is no export statement" $ - replaceReexport (Export "Module2") ("Module1", [decl1, Export "Module3"]) module2 - `shouldBeEqualSorted` result - - it "only adds a declaration once" $ - let replaced = replaceReexport (Export "Module2") module1 module2 - in replaceReexport (Export "Module2") replaced module2 `shouldBeEqualSorted` result - - it "replaces all Exports with their corresponding declarations" $ - replaceReexports module1 db `shouldBe` ("Module1", [decl1, decl2, decl3]) - - it "does not list itself as a reexport" $ - getReexports circularModule `shouldBe` [] - - it "does not include circular references when replacing reexports" $ - replaceReexports circularModule (uncurry Map.singleton circularModule ) - `shouldBe` ("Circular", []) - - it "replaces exported aliases with imported module" $ - getReexports module4 `shouldBe` [Export "Test.Foo", Export "Test.Bar"] +spec = do + describe "Successful Reexports" $ + for_ succTestCases $ \(desc, initial, refs, result) -> + it (toS desc) $ do + let reResult = resolveReexports env (initial, refs) + reResolved reResult `shouldBe` result + reResult `shouldSatisfy` not . reexportHasFailures + describe "Failed Reexports" $ + for_ failTestCases $ \(desc, initial, refs) -> + it (toS desc) $ do + let reResult = resolveReexports env (initial, refs) + reFailed reResult `shouldBe` refs + reResult `shouldSatisfy` reexportHasFailures diff --git a/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs b/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs new file mode 100644 index 0000000000..a16a9b5e95 --- /dev/null +++ b/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Language.PureScript.Ide.SourceFile.IntegrationSpec where + + +import Protolude + +import qualified Data.Text as T +import qualified Language.PureScript.Ide.Integration as Integration +import qualified Language.PureScript as P +import Test.Hspec + +setup :: IO () +setup = void (Integration.reset *> Integration.loadAll) + +spec :: Spec +spec = beforeAll_ setup $ do + describe "Sourcefile Integration" $ do + it "finds a value declaration" $ do + testCase "sfValue" (3, 1) + it "finds a type declaration" $ do + testCase "SFType" (5, 1) + it "finds a data declaration" $ do + testCase "SFData" (7, 1) + it "finds a data constructor" $ do + testCase "SFOne" (7, 1) + it "finds a typeclass" $ do + testCase "SFClass" (9, 1) + it "finds a typeclass member" $ do + testCase "sfShow" (10, 3) + +testCase :: Text -> (Int, Int) -> IO () +testCase s (x, y) = do + (P.SourceSpan f (P.SourcePos l c) _):_ <- Integration.getInfo s + toS f `shouldSatisfy` T.isSuffixOf "SourceFileSpec.purs" + (l, c) `shouldBe` (x, y) diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs new file mode 100644 index 0000000000..26a2dba50b --- /dev/null +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Language.PureScript.Ide.SourceFileSpec where + +import Protolude + +import qualified Language.PureScript as P +import Language.PureScript.Ide.SourceFile +import Test.Hspec + +span0, span1, span2 :: P.SourceSpan +span0 = P.SourceSpan "ModuleLevel" (P.SourcePos 0 0) (P.SourcePos 1 1) +span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2) +span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3) + +value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, member1 :: P.Declaration +value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left []) +synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty +class1 = P.TypeClassDeclaration (P.ProperName "Class1") [] [] [] +class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] + [P.PositionedDeclaration span2 [] member1] +data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] [] +data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])] +foreign1 = P.ExternDeclaration (P.Ident "foreign1") P.REmpty +foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.Star +member1 = P.TypeDeclaration (P.Ident "member1") P.REmpty + +spec :: Spec +spec = do + describe "Extracting Spans" $ do + it "extracts a span for a value declaration" $ + extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(Left "value1", span1)] + it "extracts a span for a type synonym declaration" $ + extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(Right "Synonym1", span1)] + it "extracts a span for a typeclass declaration" $ + extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(Right "Class1", span1)] + it "extracts spans for a typeclass declaration and its members" $ + extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(Right "Class2", span1), (Left "member1", span2)] + it "extracts a span for a data declaration" $ + extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(Right "Data1", span1)] + it "extracts spans for a data declaration and its constructors" $ + extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(Right "Data2", span1), (Left "Cons1", span1)] + it "extracts a span for a foreign declaration" $ + extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(Left "foreign1", span1)] + it "extracts a span for a data foreign declaration" $ + extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(Right "Foreign2", span1)] diff --git a/tests/support/pscide/src/RebuildSpecWithForeign.js b/tests/support/pscide/src/RebuildSpecWithForeign.js index 7c82dc823c..8ea453ff71 100644 --- a/tests/support/pscide/src/RebuildSpecWithForeign.js +++ b/tests/support/pscide/src/RebuildSpecWithForeign.js @@ -1,3 +1 @@ -// module RebuildSpecWithForeign - exports.f = 5; diff --git a/tests/support/pscide/src/SourceFileSpec.purs b/tests/support/pscide/src/SourceFileSpec.purs new file mode 100644 index 0000000000..e3484faeca --- /dev/null +++ b/tests/support/pscide/src/SourceFileSpec.purs @@ -0,0 +1,10 @@ +module SourceFileSpec where + +sfValue = "sfValue" + +type SFType = String + +data SFData = SFOne | SFTwo | SFThree + +class SFClass a where + sfShow :: a -> String From 293c345edd7fc678d9775413098e8cbde6a6f7f9 Mon Sep 17 00:00:00 2001 From: Felix Schlitter Date: Sun, 10 Jul 2016 06:56:25 +1200 Subject: [PATCH 0458/1580] Update Data.Function constant for prelude 1.0 (#2213) * Update mkFnN inlining for prelude 1.0 This fixes the compiler not inlining mkFnN, since `Data.Function` has moved to `Data.Function.Uncurried` * Update CONTRIBUTORS.md --- CONTRIBUTORS.md | 1 + src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs | 2 +- src/Language/PureScript/Constants.hs | 3 +++ 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 057000d092..d6ec3ec2a7 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -72,6 +72,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@bmjames](https://github.com/bmjames) (Ben James) My existing contributions and all future contributions until further notice are Copyright Ben James, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- - [@felixSchl](https://github.com/felixSchl) (Felix Schlitter) My existing contributions and all future contributions until further notice are Copyright Felix Schlitter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index c46bc801c5..5ac11041d8 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -216,7 +216,7 @@ inlineCommonOperators = applyAll $ isNFn :: String -> Int -> JS -> Bool isNFn prefix n (JSVar _ name) = name == (prefix ++ show n) - isNFn prefix n (JSAccessor _ name (JSVar _ dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n) + isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix ++ show n) isNFn _ _ _ = False runFn :: Int -> JS -> JS diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 1713a0db3d..021d3e0240 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -391,5 +391,8 @@ dataEuclideanRing = "Data_EuclideanRing" dataFunction :: String dataFunction = "Data_Function" +dataFunctionUncurried :: String +dataFunctionUncurried = "Data_Function_Uncurried" + dataIntBits :: String dataIntBits = "Data_Int_Bits" From 54526889709db2c02128de506bb0a50621e8ebc3 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 10 Jul 2016 13:43:25 -0700 Subject: [PATCH 0459/1580] Evaluate PSCi expressions in the browser (#2199) * Initial work on evaluating PSCi expressions in the browser using websockets * Use Warp, add shutdown handler * Bundle all JS resources on startup * Refactoring before supporting multiple backends * Tidy up JavaScript component. Return output/exception stack to PSCi. * Refactor to allow different backends * Remove comments * Add port option, fork ping thread * Only allow one client * Support multiple clients, handle reloads * extra-deps * stack.yaml * Implement suggestions: use file-embed, save console.log, use case * Add static files to bundle --- psc-bundle/Main.hs | 10 +- psci/Main.hs | 286 +++++++++++++++++-- psci/static/index.html | 10 + psci/static/index.js | 63 ++++ purescript.cabal | 13 +- src/Language/PureScript/Bundle.hs | 11 + src/Language/PureScript/Interactive.hs | 53 ++-- src/Language/PureScript/Interactive/Types.hs | 1 - stack-ghc-8.0.yaml | 2 + 9 files changed, 383 insertions(+), 66 deletions(-) create mode 100644 psci/static/index.html create mode 100644 psci/static/index.js diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index 5e214847d6..92ff4f281a 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -15,7 +15,7 @@ import Control.Monad.Error.Class import Control.Monad.Trans.Except import Control.Monad.IO.Class -import System.FilePath (takeFileName, takeDirectory) +import System.FilePath (takeDirectory) import System.FilePath.Glob (glob) import System.Exit (exitFailure) import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8) @@ -37,14 +37,6 @@ data Options = Options , optionsNamespace :: String } deriving Show --- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier. -guessModuleIdentifier :: (MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier -guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> guessModuleType (takeFileName filename) - where - guessModuleType "index.js" = pure Regular - guessModuleType "foreign.js" = pure Foreign - guessModuleType name = throwError $ UnsupportedModulePath name - -- | The main application function. -- This function parses the input files, performs dead code elimination, filters empty modules -- and generates and prints the final Javascript bundle. diff --git a/psci/Main.hs b/psci/Main.hs index e41723e682..8dc6c9d5df 100644 --- a/psci/Main.hs +++ b/psci/Main.hs @@ -1,9 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Main (main) where @@ -11,10 +15,22 @@ module Main (main) where import Prelude () import Prelude.Compat +import Data.FileEmbed (embedStringFile) import Data.Monoid ((<>)) +import Data.String (IsString(..)) +import Data.Text (Text, unpack) +import Data.Traversable (for) import Data.Version (showVersion) -import Control.Applicative (many) +import Control.Applicative (many, (<|>)) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, + tryPutMVar) +import Control.Concurrent.STM (TVar, atomically, newTVarIO, writeTVar, + readTVarIO, + TChan, newBroadcastTChanIO, dupTChan, + readTChan, writeTChan) +import Control.Exception (fromException) import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class @@ -23,21 +39,33 @@ import Control.Monad.Trans.State.Strict (StateT, evalStateT) import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Language.PureScript as P +import qualified Language.PureScript.Bundle as Bundle import Language.PureScript.Interactive +import Network.HTTP.Types.Header (hContentType, hCacheControl, + hPragma, hExpires) +import Network.HTTP.Types.Status (status200, status404, status503) +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Handler.WebSockets as WS +import qualified Network.WebSockets as WS + import qualified Options.Applicative as Opts import qualified Paths_purescript as Paths import System.Console.Haskeline +import System.IO.UTF8 (readUTF8File) import System.Exit +import System.FilePath (()) import System.FilePath.Glob (glob) +import System.Process (readProcessWithExitCode) -- | Command line options data PSCiOptions = PSCiOptions { psciMultiLineMode :: Bool , psciInputFile :: [FilePath] - , psciInputNodeFlags :: [String] + , psciBackend :: Backend } multiLineMode :: Opts.Parser Bool @@ -60,10 +88,21 @@ nodeFlagsFlag = Opts.option parser $ where parser = words <$> Opts.str +port :: Opts.Parser Int +port = Opts.option Opts.auto $ + Opts.long "port" + <> Opts.short 'p' + <> Opts.help "The web server port" + +backend :: Opts.Parser Backend +backend = + (browserBackend <$> port) + <|> (nodeBackend <$> nodeFlagsFlag) + psciOptions :: Opts.Parser PSCiOptions psciOptions = PSCiOptions <$> multiLineMode <*> many inputFile - <*> nodeFlagsFlag + <*> backend version :: Opts.Parser (a -> a) version = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $ @@ -92,6 +131,195 @@ getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do go :: [String] -> InputT m String go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " " +-- | Make a JavaScript bundle for the browser. +bundle :: IO (Either Bundle.ErrorMessage String) +bundle = runExceptT $ do + inputFiles <- liftIO (glob (".psci_modules" "node_modules" "*" "*.js")) + input <- for inputFiles $ \filename -> do + js <- liftIO (readUTF8File filename) + mid <- Bundle.guessModuleIdentifier filename + length js `seq` return (mid, js) + Bundle.bundle input [] Nothing "PSCI" + +indexJS :: IsString string => string +indexJS = $(embedStringFile "psci/static/index.js") + +indexPage :: IsString string => string +indexPage = $(embedStringFile "psci/static/index.html") + +-- | All of the functions required to implement a PSCi backend +data Backend = forall state. Backend + { _backendSetup :: IO state + -- ^ Initialize, and call the continuation when the backend is ready + , _backendEval :: state -> String -> IO () + -- ^ Evaluate JavaScript code + , _backendReload :: state -> IO () + -- ^ Reload the compiled code + , _backendShutdown :: state -> IO () + -- ^ Shut down the backend + } + +-- | Commands which can be sent to the browser +data BrowserCommand + = Eval (MVar String) + -- ^ Evaluate the latest JS + | Reload + -- ^ Reload the page + +-- | State for the browser backend +data BrowserState = BrowserState + { browserCommands :: TChan BrowserCommand + -- ^ A channel which receives data when the compiled JS has + -- been updated + , browserShutdownNotice :: MVar () + -- ^ An MVar which becomes full when the server should shut down + , browserIndexJS :: TVar (Maybe String) + -- ^ A TVar holding the latest compiled JS + , browserBundleJS :: TVar (Maybe String) + -- ^ A TVar holding the latest bundled JS + } + +browserBackend :: Int -> Backend +browserBackend serverPort = Backend setup evaluate reload shutdown + where + setup :: IO BrowserState + setup = do + shutdownVar <- newEmptyMVar + cmdChan <- newBroadcastTChanIO + indexJs <- newTVarIO Nothing + bundleJs <- newTVarIO Nothing + + let + handleWebsocket :: WS.PendingConnection -> IO () + handleWebsocket pending = do + conn <- WS.acceptRequest pending + -- Fork a thread to keep the connection alive + WS.forkPingThread conn 10 + -- Clone the command channel + cmdChanCopy <- atomically $ dupTChan cmdChan + -- Listen for commands + forever $ do + cmd <- atomically $ readTChan cmdChanCopy + case cmd of + Eval resultVar -> void $ do + WS.sendTextData conn ("eval" :: Text) + result <- WS.receiveData conn + -- With many connected clients, all but one of + -- these attempts will fail. + tryPutMVar resultVar (unpack result) + Reload -> do + WS.sendTextData conn ("reload" :: Text) + + shutdownHandler :: IO () -> IO () + shutdownHandler stopServer = void . forkIO $ do + () <- takeMVar shutdownVar + stopServer + + onException :: Maybe Wai.Request -> SomeException -> IO () + onException req ex + | Just (_ :: WS.ConnectionException) <- fromException ex + = return () -- ignore websocket disconnects + | otherwise = Warp.defaultOnException req ex + + staticServer :: Wai.Application + staticServer req respond = + case Wai.pathInfo req of + [] -> + respond $ Wai.responseLBS status200 + [(hContentType, "text/html")] + indexPage + ["js", "index.js"] -> + respond $ Wai.responseLBS status200 + [(hContentType, "application/javascript")] + indexJS + ["js", "latest.js"] -> do + may <- readTVarIO indexJs + case may of + Nothing -> + respond $ Wai.responseLBS status503 [] "Service not available" + Just js -> + respond $ Wai.responseLBS status200 + [ (hContentType, "application/javascript") + , (hCacheControl, "no-cache, no-store, must-revalidate") + , (hPragma, "no-cache") + , (hExpires, "0") + ] + (fromString js) + ["js", "bundle.js"] -> do + may <- readTVarIO bundleJs + case may of + Nothing -> + respond $ Wai.responseLBS status503 [] "Service not available" + Just js -> + respond $ Wai.responseLBS status200 + [ (hContentType, "application/javascript")] + (fromString js) + _ -> respond $ Wai.responseLBS status404 [] "Not found" + + let browserState = BrowserState cmdChan shutdownVar indexJs bundleJs + createBundle browserState + + putStrLn $ "Serving http://localhost:" <> show serverPort <> "/. Waiting for connections..." + _ <- forkIO $ Warp.runSettings ( Warp.setInstallShutdownHandler shutdownHandler + . Warp.setPort serverPort + . Warp.setOnException onException + $ Warp.defaultSettings + ) $ + WS.websocketsOr WS.defaultConnectionOptions + handleWebsocket + staticServer + return browserState + + createBundle :: BrowserState -> IO () + createBundle state = do + putStrLn "Bundling Javascript..." + ejs <- bundle + case ejs of + Left err -> do + putStrLn (unlines (Bundle.printErrorMessage err)) + exitFailure + Right js -> do + atomically $ writeTVar (browserBundleJS state) (Just js) + + reload :: BrowserState -> IO () + reload state = do + createBundle state + atomically $ writeTChan (browserCommands state) Reload + + shutdown :: BrowserState -> IO () + shutdown state = putMVar (browserShutdownNotice state) () + + evaluate :: BrowserState -> String -> IO () + evaluate state js = liftIO $ do + resultVar <- newEmptyMVar + atomically $ do + writeTVar (browserIndexJS state) (Just js) + writeTChan (browserCommands state) (Eval resultVar) + result <- takeMVar resultVar + putStrLn result + +nodeBackend :: [String] -> Backend +nodeBackend nodeArgs = Backend setup eval reload shutdown + where + setup :: IO () + setup = return () + + eval :: () -> String -> IO () + eval _ _ = do + writeFile indexFile "require('$PSCI')['$main']();" + process <- findNodeProcess + result <- traverse (\node -> readProcessWithExitCode node (nodeArgs ++ [indexFile]) "") process + case result of + Just (ExitSuccess, out, _) -> putStrLn out + Just (ExitFailure _, _, err) -> putStrLn err + Nothing -> putStrLn "Couldn't find node.js" + + reload :: () -> IO () + reload _ = return () + + shutdown :: () -> IO () + shutdown _ = return () + -- | Get command line options and drop into the REPL main :: IO () main = getOpt >>= loop @@ -106,27 +334,31 @@ main = getOpt >>= loop exitFailure (externs, env) <- ExceptT . runMake . make $ modules return (modules, externs, env) - case e of - Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure - Right (modules, externs, env) -> do - historyFilename <- getHistoryFilename - let settings = defaultSettings { historyFile = Just historyFilename } - initialState = PSCiState [] [] (zip (map snd modules) externs) - config = PSCiConfig inputFiles psciInputNodeFlags env - runner = flip runReaderT config - . flip evalStateT initialState - . runInputT (setComplete completion settings) - putStrLn prologueMessage - runner go - where - go :: InputT (StateT PSCiState (ReaderT PSCiConfig IO)) () - go = do - c <- getCommand (not psciMultiLineMode) - case c of - Left err -> outputStrLn err >> go - Right Nothing -> go - Right (Just QuitPSCi) -> outputStrLn quitMessage - Right (Just c') -> do - handleInterrupt (outputStrLn "Interrupted.") - (withInterrupt (lift (handleCommand c'))) - go + case psciBackend of + Backend setup eval reload (shutdown :: state -> IO ()) -> do + case e of + Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure + Right (modules, externs, env) -> do + historyFilename <- getHistoryFilename + let settings = defaultSettings { historyFile = Just historyFilename } + initialState = PSCiState [] [] (zip (map snd modules) externs) + config = PSCiConfig inputFiles env + runner = flip runReaderT config + . flip evalStateT initialState + . runInputT (setComplete completion settings) + + go :: state -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) () + go state = do + c <- getCommand (not psciMultiLineMode) + case c of + Left err -> outputStrLn err >> go state + Right Nothing -> go state + Right (Just QuitPSCi) -> do + outputStrLn quitMessage + liftIO $ shutdown state + Right (Just c') -> do + handleInterrupt (outputStrLn "Interrupted.") + (withInterrupt (lift (handleCommand (liftIO . eval state) (liftIO (reload state)) c'))) + go state + putStrLn prologueMessage + setup >>= runner . go diff --git a/psci/static/index.html b/psci/static/index.html new file mode 100644 index 0000000000..f749b8ae22 --- /dev/null +++ b/psci/static/index.html @@ -0,0 +1,10 @@ + + + + PureScript Interactive + + + + + + diff --git a/psci/static/index.js b/psci/static/index.js new file mode 100644 index 0000000000..08b5f1ea19 --- /dev/null +++ b/psci/static/index.js @@ -0,0 +1,63 @@ +var get = function get(uri, callback, onError) { + var request = new XMLHttpRequest(); + request.addEventListener('load', function() { + callback(request.responseText); + }); + request.addEventListener('error', onError); + request.open('GET', uri); + request.send(); +}; +var evaluate = function evaluate(js) { + var buffer = []; + // Save the old console.log function + var oldLog = console.log; + console.log = function(s) { + // Push log output into a temporary buffer + // which will be returned to PSCi. + buffer.push(s); + }; + // Replace any require(...) statements with lookups on the PSCI object. + var replaced = js.replace(/require\("[^"]*"\)/g, function(s) { + return "PSCI['" + s.substring(12, s.length - 2) + "']"; + }); + // Wrap the module and evaluate it. + var wrapped = + [ 'var module = {};' + , '(function(module) {' + , replaced + , '})(module);' + , 'return module.exports["$main"] && module.exports["$main"]();' + ].join('\n'); + new Function(wrapped)(); + // Restore console.log + console.log = oldLog; + return buffer.join('\n'); +}; +window.onload = function() { + var socket = new WebSocket('ws://0.0.0.0:' + location.port); + var evalNext = function reload() { + get('js/latest.js', function(response) { + try { + var result = evaluate(response); + socket.send(result); + } catch (ex) { + socket.send(ex.stack); + } + }, function(err) { + socket.send('Error sending JavaScript'); + }); + }; + socket.onopen = function() { + console.log('Connected'); + socket.onmessage = function(event) { + switch (event.data) { + case 'eval': + evalNext(); + break; + case 'reload': + location.reload(); + break; + } + }; + }; +}; diff --git a/purescript.cabal b/purescript.cabal index 7c23a7bf7a..cad136b97e 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -79,6 +79,8 @@ extra-source-files: examples/passing/*.purs , examples/docs/bower_components/purescript-prelude/src/*.purs , examples/docs/bower.json , examples/docs/src/*.purs + , psci/static/index.html + , psci/static/index.js , tests/support/package.json , tests/support/bower.json , tests/support/setup-win.cmd @@ -338,18 +340,27 @@ executable psci purescript -any, base-compat >=0.6.0, boxes >= 0.1.4 && < 0.2.0, + bytestring -any, containers -any, directory -any, filepath -any, + file-embed -any, Glob -any, haskeline >= 0.7.0.0, + http-types == 0.9.*, mtl -any, optparse-applicative >= 0.12.1, parsec -any, process -any, + stm >= 0.2.4.0, + text -any, time -any, transformers -any, - transformers-compat -any + transformers-compat -any, + wai == 3.*, + wai-websockets == 3.*, + warp == 3.*, + websockets >= 0.9 && <0.10 main-is: Main.hs buildable: True hs-source-dirs: psci diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 316652c8c1..bdc6d9067d 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -6,6 +6,7 @@ -- and generates the final Javascript bundle. module Language.PureScript.Bundle ( bundle + , guessModuleIdentifier , ModuleIdentifier(..) , moduleName , ModuleType(..) @@ -32,6 +33,8 @@ import Language.JavaScript.Parser.AST import qualified Paths_purescript as Paths +import System.FilePath (takeFileName, takeDirectory) + -- | The type of error messages. We separate generation and rendering of errors using a data -- type, in case we need to match on error types later. data ErrorMessage @@ -58,6 +61,14 @@ data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Read, moduleName :: ModuleIdentifier -> String moduleName (ModuleIdentifier name _) = name +-- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier. +guessModuleIdentifier :: MonadError ErrorMessage m => FilePath -> m ModuleIdentifier +guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> guessModuleType (takeFileName filename) + where + guessModuleType "index.js" = pure Regular + guessModuleType "foreign.js" = pure Foreign + guessModuleType name = throwError $ UnsupportedModulePath name + -- | A piece of code is identified by its module and its name. These keys are used to label vertices -- in the dependency graph. type Key = (ModuleIdentifier, String) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 9c7c6dd20a..f39f90e4bb 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -38,8 +38,7 @@ import Language.PureScript.Interactive.Parser as Interactive import Language.PureScript.Interactive.Printer as Interactive import Language.PureScript.Interactive.Types as Interactive -import System.Exit -import System.Process (readProcessWithExitCode) +import System.FilePath (()) -- | Pretty-print errors printErrors :: MonadIO m => P.MultipleErrors -> m () @@ -91,25 +90,28 @@ make ms = do -- | Performs a PSCi command handleCommand :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) - => Command + => (String -> m ()) -> m () -handleCommand ShowHelp = liftIO $ putStrLn helpMessage -handleCommand ResetState = handleResetState -handleCommand (Expression val) = handleExpression val -handleCommand (Import im) = handleImport im -handleCommand (Decls l) = handleDecls l -handleCommand (TypeOf val) = handleTypeOf val -handleCommand (KindOf typ) = handleKindOf typ -handleCommand (BrowseModule moduleName) = handleBrowse moduleName -handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules -handleCommand (ShowInfo QueryImport) = handleShowImportedModules -handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug." + -> Command + -> m () +handleCommand _ _ ShowHelp = liftIO $ putStrLn helpMessage +handleCommand _ r ResetState = handleResetState r +handleCommand c _ (Expression val) = handleExpression c val +handleCommand _ _ (Import im) = handleImport im +handleCommand _ _ (Decls l) = handleDecls l +handleCommand _ _ (TypeOf val) = handleTypeOf val +handleCommand _ _ (KindOf typ) = handleKindOf typ +handleCommand _ _ (BrowseModule moduleName) = handleBrowse moduleName +handleCommand _ _ (ShowInfo QueryLoaded) = handleShowLoadedModules +handleCommand _ _ (ShowInfo QueryImport) = handleShowImportedModules +handleCommand _ _ QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug." -- | Reset the application state handleResetState :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) => m () -handleResetState = do + -> m () +handleResetState reload = do modify $ updateImportedModules (const []) . updateLets (const []) files <- asks psciLoadedFiles @@ -119,30 +121,25 @@ handleResetState = do return (map snd modules, externs) case e of Left errs -> printErrors errs - Right (modules, externs) -> modify (updateLoadedExterns (const (zip modules externs))) + Right (modules, externs) -> do + modify (updateLoadedExterns (const (zip modules externs))) + reload -- | Takes a value expression and evaluates it with the current state. --- --- TODO: factor out the Node process runner, so that we can use PSCi in other settings. handleExpression :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) - => P.Expr + => (String -> m ()) + -> P.Expr -> m () -handleExpression val = do +handleExpression evaluate val = do st <- get let m = createTemporaryModule True st val - nodeArgs <- asks ((++ [indexFile]) . psciNodeFlags) e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m case e of Left errs -> printErrors errs Right _ -> do - liftIO $ writeFile indexFile "require('$PSCI')['$main']();" - process <- liftIO findNodeProcess - result <- liftIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process - case result of - Just (ExitSuccess, out, _) -> liftIO $ putStrLn out - Just (ExitFailure _, _, err) -> liftIO $ putStrLn err - Nothing -> liftIO $ putStrLn "Couldn't find node.js" + js <- liftIO $ readFile (modulesDir "$PSCI" "index.js") + evaluate js -- | -- Takes a list of declarations and updates the environment, then run a make. If the declaration fails, diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index 1c20721efe..deae8c6f80 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -13,7 +13,6 @@ import qualified Language.PureScript as P -- data PSCiConfig = PSCiConfig { psciLoadedFiles :: [FilePath] - , psciNodeFlags :: [String] , psciEnvironment :: P.Environment } deriving Show diff --git a/stack-ghc-8.0.yaml b/stack-ghc-8.0.yaml index f131e996b3..d56763ecc2 100644 --- a/stack-ghc-8.0.yaml +++ b/stack-ghc-8.0.yaml @@ -3,3 +3,5 @@ packages: - '.' extra-deps: - pipes-http-1.0.2 +- wai-websockets-3.0.0.9 +- websockets-0.9.6.2 From bc0d52fbf5ed090b18272d4b5897613019e38167 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 10 Jul 2016 16:33:04 -0700 Subject: [PATCH 0460/1580] Combine the sdist and coverage builds. Avoid .tix files during deployment. --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index f86c1d8452..db6940d0ef 100644 --- a/.travis.yml +++ b/.travis.yml @@ -12,7 +12,7 @@ matrix: os: linux dist: trusty sudo: required - env: BUILD_TYPE=normal COVERAGE=true DEPLOY=true + env: BUILD_TYPE=normal DEPLOY=true # - compiler: cc-linux-nightly-normal # os: linux @@ -31,7 +31,7 @@ matrix: os: linux dist: trusty sudo: required - env: BUILD_TYPE=sdist + env: BUILD_TYPE=sdist COVERAGE=true - compiler: cc-linux-lts-haddock os: linux From f0d5256019348aec67b31108fb5209b4e2f846a0 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 10 Jul 2016 18:16:49 -0700 Subject: [PATCH 0461/1580] 0.9.2 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index cad136b97e..904a85ba78 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.9.1 +version: 0.9.2 cabal-version: >=1.8 build-type: Simple license: MIT From 0824b1f9c09ff908a19977fa4f5208e5b7b6805e Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Tue, 26 Jul 2016 03:48:24 +0100 Subject: [PATCH 0462/1580] Fix for #2244 (#2246) * Fix for #2244 * Fix record extension code gen: * Now uses accessorString for assigning keys * Now only evaluates the object once instead of `1 + (2 * num of existing keys)` --- src/Language/PureScript/CodeGen/JS.hs | 13 ++++++++----- src/Language/PureScript/CodeGen/JS/Common.hs | 2 +- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index dfc13018a2..30ad86b2d0 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -280,15 +280,18 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = extendObj obj sts = do newObj <- freshName key <- freshName + evaluatedObj <- freshName let jsKey = JSVar Nothing key jsNewObj = JSVar Nothing newObj - block = JSBlock Nothing (objAssign:copy:extend ++ [JSReturn Nothing jsNewObj]) + jsEvaluatedObj = JSVar Nothing evaluatedObj + block = JSBlock Nothing (evaluate:objAssign:copy:extend ++ [JSReturn Nothing jsNewObj]) + evaluate = JSVariableIntroduction Nothing evaluatedObj (Just obj) objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing []) - copy = JSForIn Nothing key obj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing] - cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" obj) [jsKey] - assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey obj)] - stToAssign (s, js) = JSAssignment Nothing (JSAccessor Nothing s jsNewObj) js + copy = JSForIn Nothing key jsEvaluatedObj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing] + cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" jsEvaluatedObj) [jsKey] + assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey jsEvaluatedObj)] + stToAssign (s, js) = JSAssignment Nothing (accessorString s jsNewObj) js extend = map stToAssign sts return $ JSApp Nothing (JSFunction Nothing Nothing [] block) [] diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 45b5391aa0..f0d180ce15 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -35,7 +35,7 @@ identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" -- Test if a string is a valid JS identifier without escaping. -- identNeedsEscaping :: String -> Bool -identNeedsEscaping s = s /= identToJs (Ident s) +identNeedsEscaping s = s /= identToJs (Ident s) || null s -- | -- Attempts to find a human-readable name for a symbol, if none has been specified returns the From 4828b5d3fa078361e03dd0f3dbbfa46dd4ee6b20 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 25 Jul 2016 19:50:18 -0700 Subject: [PATCH 0463/1580] Improved error messages in the constraint solver (#2230) Behold: No type class instance was found for Issue1310.Inject (Eff ( console :: CONSOLE | t0 ) ) (Eff ( oops :: Oops | eff1 ) ) The instance head contains unknown type variables. Consider adding a type annotation. while checking that expression inj (log "Oops") has type forall eff. Eff ( oops :: Oops | eff ) Unit while applying a function inj of type forall a g f. (Inject f g) => f a -> g a to argument log "Oops" in value declaration main where eff1 is a rigid type variable bound at line 18, column 1 - line 18, column 23 t0 is an unknown type --- src/Language/PureScript/AST/Binders.hs | 2 +- src/Language/PureScript/AST/Declarations.hs | 165 +++++++++++++++-- src/Language/PureScript/AST/Literals.hs | 2 +- src/Language/PureScript/AST/Operators.hs | 4 +- src/Language/PureScript/AST/SourcePos.hs | 4 +- src/Language/PureScript/AST/Traversals.hs | 2 +- src/Language/PureScript/Bundle.hs | 6 +- src/Language/PureScript/CodeGen/JS.hs | 4 +- src/Language/PureScript/CodeGen/JS/AST.hs | 6 +- src/Language/PureScript/Comments.hs | 2 +- src/Language/PureScript/CoreFn/Binders.hs | 2 +- src/Language/PureScript/CoreFn/Expr.hs | 6 +- src/Language/PureScript/CoreFn/Meta.hs | 4 +- src/Language/PureScript/CoreFn/Module.hs | 2 +- src/Language/PureScript/Docs/AsMarkdown.hs | 2 +- src/Language/PureScript/Environment.hs | 10 +- src/Language/PureScript/Errors.hs | 175 ++++-------------- src/Language/PureScript/Externs.hs | 10 +- .../PureScript/Interactive/Completion.hs | 2 +- src/Language/PureScript/Kinds.hs | 2 +- src/Language/PureScript/Make.hs | 4 +- src/Language/PureScript/Names.hs | 10 +- src/Language/PureScript/Parser/Lexer.hs | 2 +- src/Language/PureScript/Pretty/Values.hs | 2 +- src/Language/PureScript/Publish.hs | 4 +- src/Language/PureScript/Sugar/Names/Env.hs | 8 +- src/Language/PureScript/Sugar/Operators.hs | 4 +- src/Language/PureScript/Sugar/TypeClasses.hs | 3 +- .../PureScript/TypeChecker/Entailment.hs | 10 +- src/Language/PureScript/TypeChecker/Kinds.hs | 4 +- src/Language/PureScript/TypeChecker/Monad.hs | 55 +++++- .../PureScript/TypeChecker/Subsumption.hs | 7 +- src/Language/PureScript/TypeChecker/Types.hs | 37 ++-- src/Language/PureScript/TypeChecker/Unify.hs | 2 +- .../PureScript/TypeClassDictionaries.hs | 4 +- src/Language/PureScript/Types.hs | 8 +- tests/TestPscPublish.hs | 2 +- 37 files changed, 328 insertions(+), 250 deletions(-) diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index 756c7269bb..c7c7d12c1f 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -61,7 +61,7 @@ data Binder -- A binder with a type annotation -- | TypedBinder Type Binder - deriving (Show, Read, Eq) + deriving (Show, Eq) -- | -- Collect all names introduced in binders in an expression diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index a53e759a39..06d94480ec 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -22,6 +22,145 @@ import Language.PureScript.Kinds import Language.PureScript.TypeClassDictionaries import Language.PureScript.Comments import Language.PureScript.Environment +import qualified Language.PureScript.Bundle as Bundle + +import qualified Text.Parsec as P + +-- | A type of error messages +data SimpleErrorMessage + = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) + | ErrorParsingModule P.ParseError + | MissingFFIModule ModuleName + | MultipleFFIModules ModuleName [FilePath] + | UnnecessaryFFIModule ModuleName FilePath + | MissingFFIImplementations ModuleName [Ident] + | UnusedFFIImplementations ModuleName [Ident] + | InvalidFFIIdentifier ModuleName String + | CannotGetFileInfo FilePath + | CannotReadFile FilePath + | CannotWriteFile FilePath + | InfiniteType Type + | InfiniteKind Kind + | MultipleValueOpFixities (OpName 'ValueOpName) + | MultipleTypeOpFixities (OpName 'TypeOpName) + | OrphanTypeDeclaration Ident + | RedefinedModule ModuleName [SourceSpan] + | RedefinedIdent Ident + | OverlappingNamesInLet + | UnknownName (Qualified Name) + | UnknownImport ModuleName Name + | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName) + | UnknownExport Name + | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName) + | ScopeConflict Name [ModuleName] + | ScopeShadowing Name (Maybe ModuleName) [ModuleName] + | DeclConflict Name Name + | ExportConflict (Qualified Name) (Qualified Name) + | DuplicateModuleName ModuleName + | DuplicateTypeArgument String + | InvalidDoBind + | InvalidDoLet + | CycleInDeclaration Ident + | CycleInTypeSynonym (Maybe (ProperName 'TypeName)) + | CycleInModules [ModuleName] + | NameIsUndefined Ident + | UndefinedTypeVariable (ProperName 'TypeName) + | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName)) + | EscapedSkolem (Maybe Expr) + | TypesDoNotUnify Type Type + | KindsDoNotUnify Kind Kind + | ConstrainedTypeUnified Type Type + | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident] + | NoInstanceFound Constraint + | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type] + | CannotDerive (Qualified (ProperName 'ClassName)) [Type] + | CannotFindDerivingType (ProperName 'TypeName) + | DuplicateLabel String (Maybe Expr) + | DuplicateValueDeclaration Ident + | ArgListLengthsDiffer Ident + | OverlappingArgNames (Maybe Ident) + | MissingClassMember Ident + | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName)) + | ExpectedType Type Kind + | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName)) + | ExprDoesNotHaveType Expr Type + | PropertyIsMissing String + | AdditionalProperty String + | CannotApplyFunction Type Expr + | TypeSynonymInstance + | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type] + | InvalidNewtype (ProperName 'TypeName) + | InvalidInstanceHead Type + | TransitiveExportError DeclarationRef [DeclarationRef] + | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName) + | ShadowedName Ident + | ShadowedTypeVar String + | UnusedTypeVar String + | WildcardInferredType Type + | HoleInferredType String Type [(Ident, Type)] + | MissingTypeDeclaration Ident Type + | OverlappingPattern [[Binder]] Bool + | IncompleteExhaustivityCheck + | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName) + | ImportHidingModule ModuleName + | UnusedImport ModuleName + | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef] + | UnusedDctorImport (ProperName 'TypeName) + | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName] + | DuplicateSelectiveImport ModuleName + | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) + | DuplicateImportRef Name + | DuplicateExportRef Name + | IntOutOfRange Integer String Integer Integer + | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef] + | ImplicitImport ModuleName [DeclarationRef] + | HidingImport ModuleName [DeclarationRef] + | CaseBinderLengthDiffers Int [Binder] + | IncorrectAnonymousArgument + | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident) + | DeprecatedRequirePath + | CannotGeneralizeRecursiveFunction Ident Type + deriving (Show) + +-- | Error message hints, providing more detailed information about failure. +data ErrorMessageHint + = ErrorUnifyingTypes Type Type + | ErrorInExpression Expr + | ErrorInModule ModuleName + | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type] + | ErrorInSubsumption Type Type + | ErrorCheckingAccessor Expr String + | ErrorCheckingType Expr Type + | ErrorCheckingKind Type + | ErrorCheckingGuard + | ErrorInferringType Expr + | ErrorInApplication Expr Type Expr + | ErrorInDataConstructor (ProperName 'ConstructorName) + | ErrorInTypeConstructor (ProperName 'TypeName) + | ErrorInBindingGroup [Ident] + | ErrorInDataBindingGroup + | ErrorInTypeSynonym (ProperName 'TypeName) + | ErrorInValueDeclaration Ident + | ErrorInTypeDeclaration Ident + | ErrorInForeignImport Ident + | ErrorSolvingConstraint Constraint + | PositionedError SourceSpan + deriving (Show) + +-- | Categories of hints +data HintCategory + = ExprHint + | KindHint + | CheckHint + | PositionHint + | SolverHint + | OtherHint + deriving (Show, Eq) + +data ErrorMessage = ErrorMessage + [ErrorMessageHint] + SimpleErrorMessage + deriving (Show) -- | -- A module declaration, consisting of comments about the module, a module name, @@ -29,7 +168,7 @@ import Language.PureScript.Environment -- explicitly exported. If the export list is Nothing, everything is exported. -- data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) - deriving (Show, Read) + deriving (Show) -- | Return a module's name. getModuleName :: Module -> ModuleName @@ -88,7 +227,7 @@ data DeclarationRef -- A declaration reference with source position information -- | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef - deriving (Show, Read) + deriving (Show) instance Eq DeclarationRef where (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors' @@ -149,7 +288,7 @@ data ImportDeclarationType -- An import with a list of references to hide: `import M hiding (foo)` -- | Hiding [DeclarationRef] - deriving (Eq, Show, Read) + deriving (Eq, Show) isImplicit :: ImportDeclarationType -> Bool isImplicit Implicit = True @@ -216,15 +355,15 @@ data Declaration -- A declaration with source position information -- | PositionedDeclaration SourceSpan [Comment] Declaration - deriving (Show, Read) + deriving (Show) data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName) - deriving (Eq, Ord, Show, Read) + deriving (Eq, Ord, Show) data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName) - deriving (Eq, Ord, Show, Read) + deriving (Eq, Ord, Show) -pattern ValueFixityDeclaration :: Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration +pattern ValueFixityDeclaration :: Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration pattern ValueFixityDeclaration fixity name op = FixityDeclaration (Left (ValueFixity fixity name op)) pattern TypeFixityDeclaration :: Fixity -> Qualified (ProperName 'TypeName) -> OpName 'TypeOpName -> Declaration @@ -236,7 +375,7 @@ data TypeInstanceBody = DerivedInstance -- | This is a regular (explicit) instance | ExplicitInstance [Declaration] - deriving (Show, Read) + deriving (Show) mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f) @@ -421,7 +560,9 @@ data Expr -- at superclass implementations when searching for a dictionary, the type class name and -- instance type, and the type class dictionaries in scope. -- - | TypeClassDictionary Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))) + | TypeClassDictionary Constraint + (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))) + [ErrorMessageHint] -- | -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring. -- @@ -442,7 +583,7 @@ data Expr -- A value with source position information -- | PositionedValue SourceSpan [Comment] Expr - deriving (Show, Read) + deriving (Show) -- | -- An alternative in a case statement @@ -456,7 +597,7 @@ data CaseAlternative = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: Either [(Guard, Expr)] Expr - } deriving (Show, Read) + } deriving (Show) -- | -- A statement in a do-notation block @@ -478,7 +619,7 @@ data DoNotationElement -- A do notation element with source position information -- | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement - deriving (Show, Read) + deriving (Show) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType) diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs index fae56ee087..01da91dc64 100644 --- a/src/Language/PureScript/AST/Literals.hs +++ b/src/Language/PureScript/AST/Literals.hs @@ -34,4 +34,4 @@ data Literal a -- An object literal -- | ObjectLiteral [(String, a)] - deriving (Eq, Ord, Show, Read, Functor) + deriving (Eq, Ord, Show, Functor) diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs index 5ba0e157cb..0b8e53636d 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -21,7 +21,7 @@ type Precedence = Integer -- Associativity for infix operators -- data Associativity = Infixl | Infixr | Infix - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) showAssoc :: Associativity -> String showAssoc Infixl = "infixl" @@ -44,7 +44,7 @@ instance A.FromJSON Associativity where -- Fixity data for infix operators -- data Fixity = Fixity Associativity Precedence - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) instance A.ToJSON Fixity where toJSON (Fixity associativity precedence) = diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 328c955fa9..266a94e056 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -22,7 +22,7 @@ data SourcePos = SourcePos -- Column number -- , sourcePosColumn :: Int - } deriving (Show, Read, Eq, Ord) + } deriving (Show, Eq, Ord) displaySourcePos :: SourcePos -> String displaySourcePos sp = @@ -50,7 +50,7 @@ data SourceSpan = SourceSpan -- End of the span -- , spanEnd :: SourcePos - } deriving (Show, Read, Eq, Ord) + } deriving (Show, Eq, Ord) displayStartEndPos :: SourceSpan -> String displayStartEndPos sp = diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 801883a996..7a851fbf86 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -582,7 +582,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con forDecls (TypeDeclaration _ ty) = f ty forDecls _ = mempty - forValues (TypeClassDictionary c _) = mconcat (map f (constraintArgs c)) + forValues (TypeClassDictionary c _ _) = mconcat (map f (constraintArgs c)) forValues (SuperClassDictionary _ tys) = mconcat (map f tys) forValues (TypedValue _ _ ty) = f ty forValues _ = mempty diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index bdc6d9067d..1d9406650f 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -43,20 +43,20 @@ data ErrorMessage | UnableToParseModule String | UnsupportedExport | ErrorInModule ModuleIdentifier ErrorMessage - deriving (Show, Read) + deriving (Show) -- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules. data ModuleType = Regular | Foreign - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) showModuleType :: ModuleType -> String showModuleType Regular = "Regular" showModuleType Foreign = "Foreign" -- | A module is identified by its module name and its type. -data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Read, Eq, Ord) +data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord) moduleName :: ModuleIdentifier -> String moduleName (ModuleIdentifier name _) = name diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 30ad86b2d0..ba682c1af1 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -27,7 +27,9 @@ import Language.PureScript.CodeGen.JS.Common as Common import Language.PureScript.CodeGen.JS.Optimizer import Language.PureScript.CoreFn import Language.PureScript.Crash -import Language.PureScript.Errors +import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..), + MultipleErrors(..), rethrow, + errorMessage, rethrowWithPosition, addHint) import Language.PureScript.Names import Language.PureScript.Options import Language.PureScript.Traversals (sndM) diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index abc722ea8e..b6e1b8a1c5 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -35,7 +35,7 @@ data UnaryOperator -- Constructor -- | JSNew - deriving (Show, Read, Eq) + deriving (Show, Eq) -- | -- Built-in binary operators @@ -117,7 +117,7 @@ data BinaryOperator -- Bitwise right shift with zero-fill -- | ZeroFillShiftRight - deriving (Show, Read, Eq) + deriving (Show, Eq) -- | -- Data type for simplified Javascript expressions @@ -238,7 +238,7 @@ data JS -- | -- Commented Javascript -- - | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Read, Eq) + | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Eq) withSourceSpan :: SourceSpan -> JS -> JS withSourceSpan withSpan = go diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs index 3bc00ce4f3..15356eb06c 100644 --- a/src/Language/PureScript/Comments.hs +++ b/src/Language/PureScript/Comments.hs @@ -12,6 +12,6 @@ import Data.Aeson.TH data Comment = LineComment String | BlockComment String - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment) diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index 5ef7061540..acff617a41 100644 --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -31,7 +31,7 @@ data Binder a -- | -- A binder which binds its input to an identifier -- - | NamedBinder a Ident (Binder a) deriving (Show, Read, Functor) + | NamedBinder a Ident (Binder a) deriving (Show, Functor) extractBinderAnn :: Binder a -> a diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index 4d7ae02aeb..43479a725e 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -51,7 +51,7 @@ data Expr a -- A let binding -- | Let a [Bind a] (Expr a) - deriving (Show, Read, Functor) + deriving (Show, Functor) -- | -- A let or module binding. @@ -64,7 +64,7 @@ data Bind a -- | -- Mutually recursive binding group for several values -- - | Rec [((a, Ident), Expr a)] deriving (Show, Read, Functor) + | Rec [((a, Ident), Expr a)] deriving (Show, Functor) -- | -- A guard is just a boolean-valued expression that appears alongside a set of binders @@ -83,7 +83,7 @@ data CaseAlternative a = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a) - } deriving (Show, Read) + } deriving (Show) instance Functor CaseAlternative where diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs index 220d474f0e..88cbe7f84a 100644 --- a/src/Language/PureScript/CoreFn/Meta.hs +++ b/src/Language/PureScript/CoreFn/Meta.hs @@ -26,7 +26,7 @@ data Meta -- | -- The contained reference is for a foreign member -- - | IsForeign deriving (Show, Read, Eq) + | IsForeign deriving (Show, Eq) -- | -- Data constructor metadata @@ -39,4 +39,4 @@ data ConstructorType -- | -- The constructor is for a type with multiple construcors -- - | SumType deriving (Show, Read, Eq) + | SumType deriving (Show, Eq) diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index 52f4f90bd6..56fe0f7aa4 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -17,6 +17,6 @@ data Module a = Module , moduleExports :: [Ident] , moduleForeign :: [ForeignDecl] , moduleDecls :: [Bind a] - } deriving (Show, Read) + } deriving (Show) type ForeignDecl = (Ident, Type) diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 4a07663828..1022e4c20f 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -110,7 +110,7 @@ childToString f decl@ChildDeclaration{..} = data First = First | NotFirst - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) type Docs = Writer [String] () diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index c8c6b0a8c5..d94b517fda 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -46,7 +46,7 @@ data Environment = Environment { -- Type classes -- , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint]) - } deriving (Show, Read) + } deriving (Show) -- | -- The initial environment with no values and only the default javascript types defined @@ -65,7 +65,7 @@ data NameVisibility -- | -- The name is defined in the another binding group, or has been made visible by a function binder -- - | Defined deriving (Show, Read, Eq) + | Defined deriving (Show, Eq) -- | -- A flag for whether a name is for an private or public value - only public values will be @@ -85,7 +85,7 @@ data NameKind -- A name for member introduced by foreign import -- | External - deriving (Show, Read, Eq) + deriving (Show, Eq) -- | -- The kinds of a type @@ -111,7 +111,7 @@ data TypeKind -- A scoped type variable -- | ScopedTypeVar - deriving (Show, Read, Eq) + deriving (Show, Eq) -- | -- The type ('data' or 'newtype') of a data type declaration @@ -125,7 +125,7 @@ data DataDeclType -- A newtype constructor -- | Newtype - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) showDataDeclType :: DataDeclType -> String showDataDeclType Data = "data" diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index f19827f48f..af67ef27f1 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1,7 +1,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} -module Language.PureScript.Errors where +module Language.PureScript.Errors + ( module Language.PureScript.AST + , module Language.PureScript.Errors + ) where import Prelude.Compat @@ -21,7 +24,6 @@ import qualified Data.Map as M import Language.PureScript.AST import Language.PureScript.Crash -import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Pretty import Language.PureScript.Traversals @@ -37,137 +39,6 @@ import qualified Text.Parsec.Error as PE import qualified Text.PrettyPrint.Boxes as Box import Text.Parsec.Error (Message(..)) --- | A type of error messages -data SimpleErrorMessage - = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) - | ErrorParsingModule P.ParseError - | MissingFFIModule ModuleName - | MultipleFFIModules ModuleName [FilePath] - | UnnecessaryFFIModule ModuleName FilePath - | MissingFFIImplementations ModuleName [Ident] - | UnusedFFIImplementations ModuleName [Ident] - | InvalidFFIIdentifier ModuleName String - | CannotGetFileInfo FilePath - | CannotReadFile FilePath - | CannotWriteFile FilePath - | InfiniteType Type - | InfiniteKind Kind - | MultipleValueOpFixities (OpName 'ValueOpName) - | MultipleTypeOpFixities (OpName 'TypeOpName) - | OrphanTypeDeclaration Ident - | RedefinedModule ModuleName [SourceSpan] - | RedefinedIdent Ident - | OverlappingNamesInLet - | UnknownName (Qualified Name) - | UnknownImport ModuleName Name - | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName) - | UnknownExport Name - | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName) - | ScopeConflict Name [ModuleName] - | ScopeShadowing Name (Maybe ModuleName) [ModuleName] - | DeclConflict Name Name - | ExportConflict (Qualified Name) (Qualified Name) - | DuplicateModuleName ModuleName - | DuplicateTypeArgument String - | InvalidDoBind - | InvalidDoLet - | CycleInDeclaration Ident - | CycleInTypeSynonym (Maybe (ProperName 'TypeName)) - | CycleInModules [ModuleName] - | NameIsUndefined Ident - | UndefinedTypeVariable (ProperName 'TypeName) - | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName)) - | EscapedSkolem (Maybe Expr) - | TypesDoNotUnify Type Type - | KindsDoNotUnify Kind Kind - | ConstrainedTypeUnified Type Type - | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident] - | NoInstanceFound Constraint - | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type] - | CannotDerive (Qualified (ProperName 'ClassName)) [Type] - | CannotFindDerivingType (ProperName 'TypeName) - | DuplicateLabel String (Maybe Expr) - | DuplicateValueDeclaration Ident - | ArgListLengthsDiffer Ident - | OverlappingArgNames (Maybe Ident) - | MissingClassMember Ident - | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName)) - | ExpectedType Type Kind - | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName)) - | ExprDoesNotHaveType Expr Type - | PropertyIsMissing String - | AdditionalProperty String - | CannotApplyFunction Type Expr - | TypeSynonymInstance - | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type] - | InvalidNewtype (ProperName 'TypeName) - | InvalidInstanceHead Type - | TransitiveExportError DeclarationRef [DeclarationRef] - | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName) - | ShadowedName Ident - | ShadowedTypeVar String - | UnusedTypeVar String - | WildcardInferredType Type - | HoleInferredType String Type [(Ident, Type)] - | MissingTypeDeclaration Ident Type - | OverlappingPattern [[Binder]] Bool - | IncompleteExhaustivityCheck - | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName) - | ImportHidingModule ModuleName - | UnusedImport ModuleName - | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef] - | UnusedDctorImport (ProperName 'TypeName) - | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName] - | DuplicateSelectiveImport ModuleName - | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) - | DuplicateImportRef Name - | DuplicateExportRef Name - | IntOutOfRange Integer String Integer Integer - | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef] - | ImplicitImport ModuleName [DeclarationRef] - | HidingImport ModuleName [DeclarationRef] - | CaseBinderLengthDiffers Int [Binder] - | IncorrectAnonymousArgument - | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident) - | DeprecatedRequirePath - | CannotGeneralizeRecursiveFunction Ident Type - deriving (Show) - --- | Error message hints, providing more detailed information about failure. -data ErrorMessageHint - = ErrorUnifyingTypes Type Type - | ErrorInExpression Expr - | ErrorInModule ModuleName - | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type] - | ErrorInSubsumption Type Type - | ErrorCheckingAccessor Expr String - | ErrorCheckingType Expr Type - | ErrorCheckingKind Type - | ErrorCheckingGuard - | ErrorInferringType Expr - | ErrorInApplication Expr Type Expr - | ErrorInDataConstructor (ProperName 'ConstructorName) - | ErrorInTypeConstructor (ProperName 'TypeName) - | ErrorInBindingGroup [Ident] - | ErrorInDataBindingGroup - | ErrorInTypeSynonym (ProperName 'TypeName) - | ErrorInValueDeclaration Ident - | ErrorInTypeDeclaration Ident - | ErrorInForeignImport Ident - | PositionedError SourceSpan - deriving Show - --- | Categories of hints -data HintCategory - = ExprHint - | KindHint - | CheckHint - | PositionHint - | OtherHint - deriving (Show, Eq) - -data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show) - newtype ErrorSuggestion = ErrorSuggestion String -- | Get the source span for an error @@ -321,7 +192,11 @@ onErrorMessages f = MultipleErrors . map f . runMultipleErrors -- | Add a hint to an error message addHint :: ErrorMessageHint -> MultipleErrors -> MultipleErrors -addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint : hints) se +addHint hint = addHints [hint] + +-- | Add hints to an error message +addHints :: [ErrorMessageHint] -> MultipleErrors -> MultipleErrors +addHints hints = onErrorMessages $ \(ErrorMessage hints' se) -> ErrorMessage (hints ++ hints') se -- | A map from rigid type variable name/unknown variable pairs to new variables. data TypeMap = TypeMap @@ -396,6 +271,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2 gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts + gHint (ErrorSolvingConstraint con) = ErrorSolvingConstraint <$> overConstraintArgs (traverse f) con gHint other = pure other wikiUri :: ErrorMessage -> String @@ -1062,6 +938,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS paras [ detail , line $ "in foreign import " ++ markCode (showIdent nm) ] + renderHint (ErrorSolvingConstraint (Constraint nm ts _)) detail = + paras [ detail + , line "while solving type class constriant" + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] + ] renderHint (PositionedError srcSpan) detail = paras [ line $ "at " ++ displaySourceSpan srcSpan , detail @@ -1139,6 +1023,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS where isUnifyHint ErrorUnifyingTypes{} = True isUnifyHint _ = False + stripRedudantHints NoInstanceFound{} = stripFirst isSolverHint + where + isSolverHint ErrorSolvingConstraint{} = True + isSolverHint _ = False stripRedudantHints _ = id stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint] @@ -1150,15 +1038,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS stripFirst _ [] = [] hintCategory :: ErrorMessageHint -> HintCategory - hintCategory ErrorCheckingType{} = ExprHint - hintCategory ErrorInferringType{} = ExprHint - hintCategory ErrorInExpression{} = ExprHint - hintCategory ErrorUnifyingTypes{} = CheckHint - hintCategory ErrorInSubsumption{} = CheckHint - hintCategory ErrorInApplication{} = CheckHint - hintCategory ErrorCheckingKind{} = CheckHint - hintCategory PositionedError{} = PositionHint - hintCategory _ = OtherHint + hintCategory ErrorCheckingType{} = ExprHint + hintCategory ErrorInferringType{} = ExprHint + hintCategory ErrorInExpression{} = ExprHint + hintCategory ErrorUnifyingTypes{} = CheckHint + hintCategory ErrorInSubsumption{} = CheckHint + hintCategory ErrorInApplication{} = CheckHint + hintCategory ErrorCheckingKind{} = CheckHint + hintCategory ErrorSolvingConstraint{} = SolverHint + hintCategory PositionedError{} = PositionHint + hintCategory _ = OtherHint -- Pretty print and export declaration prettyPrintExport :: DeclarationRef -> String diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index e6a850c1c8..1a83621f5e 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -50,7 +50,7 @@ data ExternsFile = ExternsFile , efTypeFixities :: [ExternsTypeFixity] -- | List of type and value declaration , efDeclarations :: [ExternsDeclaration] - } deriving (Show, Read) + } deriving (Show) -- | A module import in an externs file data ExternsImport = ExternsImport @@ -61,7 +61,7 @@ data ExternsImport = ExternsImport , eiImportType :: ImportDeclarationType -- | The imported-as name, for qualified imports , eiImportedAs :: Maybe ModuleName - } deriving (Show, Read) + } deriving (Show) -- | A fixity declaration in an externs file data ExternsFixity = ExternsFixity @@ -74,7 +74,7 @@ data ExternsFixity = ExternsFixity , efOperator :: OpName 'ValueOpName -- | The value the operator is an alias for , efAlias :: Qualified (Either Ident (ProperName 'ConstructorName)) - } deriving (Show, Read) + } deriving (Show) -- | A type fixity declaration in an externs file data ExternsTypeFixity = ExternsTypeFixity @@ -87,7 +87,7 @@ data ExternsTypeFixity = ExternsTypeFixity , efTypeOperator :: OpName 'TypeOpName -- | The value the operator is an alias for , efTypeAlias :: Qualified (ProperName 'TypeName) - } deriving (Show, Read) + } deriving (Show) -- | A type or value declaration appearing in an externs file data ExternsDeclaration = @@ -130,7 +130,7 @@ data ExternsDeclaration = , edInstanceTypes :: [Type] , edInstanceConstraints :: Maybe [Constraint] } - deriving (Show, Read) + deriving (Show) -- | Convert an externs file back into a module applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index 135ea6b3ef..c332f05f7c 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -91,7 +91,7 @@ data CompletionContext | CtxIdentifier | CtxType | CtxFixed String - deriving (Show, Read) + deriving (Show) -- | -- Decide what kind of completion we need based on input. This function expects diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 139dd5816e..519584e47b 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -20,7 +20,7 @@ data Kind | FunKind Kind Kind -- | Type-level strings | Symbol - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) $(A.deriveJSON A.defaultOptions ''Kind) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index d4dc6e35d3..5dbc39f750 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -85,7 +85,7 @@ import qualified Text.Parsec as Parsec -- | Progress messages from the make process data ProgressMessage = CompilingModule ModuleName - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) -- | Render a progress message renderProgressMessage :: ProgressMessage -> String @@ -129,7 +129,7 @@ data RebuildPolicy -- | Never rebuild this module = RebuildNever -- | Always rebuild this module - | RebuildAlways deriving (Show, Read, Eq, Ord) + | RebuildAlways deriving (Show, Eq, Ord) -- | Rebuild a single module rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 0f99ca980b..6df81855fc 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -64,7 +64,7 @@ data Ident -- A generated name for an identifier -- | GenIdent (Maybe String) Integer - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) runIdent :: Ident -> String runIdent (Ident i) = i @@ -84,7 +84,7 @@ freshIdent' = GenIdent Nothing <$> fresh -- Operator alias names. -- newtype OpName (a :: OpNameType) = OpName { runOpName :: String } - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) instance ToJSON (OpName a) where toJSON = toJSON . runOpName @@ -104,7 +104,7 @@ data OpNameType = ValueOpName | TypeOpName -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. -- newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String } - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) instance ToJSON (ProperName a) where toJSON = toJSON . runProperName @@ -129,7 +129,7 @@ coerceProperName = ProperName . runProperName -- Module names -- newtype ModuleName = ModuleName [ProperName 'Namespace] - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) runModuleName :: ModuleName -> String runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns) @@ -146,7 +146,7 @@ moduleNameFromString = ModuleName . splitProperNames -- A qualified name, i.e. a name with an optional module name -- data Qualified a = Qualified (Maybe ModuleName) a - deriving (Show, Read, Eq, Ord, Functor) + deriving (Show, Eq, Ord, Functor) showQualified :: (a -> String) -> Qualified a -> String showQualified f (Qualified Nothing a) = f a diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index b76e6eb42b..49448619f2 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -104,7 +104,7 @@ data Token | StringLiteral String | Number (Either Integer Double) | HoleLit String - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) prettyPrintToken :: Token -> String prettyPrintToken LParen = "(" diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 93365cffc6..6a8ea61e75 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -60,7 +60,7 @@ prettyPrintValue d (Let ds val) = (text "in " <> prettyPrintValue (d - 1) val) prettyPrintValue d (Do els) = text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) -prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys +prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">" diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index d2bfc8c566..d1ce4b56e5 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -169,7 +169,7 @@ getModulesAndBookmarks = do Left err -> userError (CompileError err) -data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum) +data TreeStatus = Clean | Dirty deriving (Show, Eq, Ord, Enum) getGitWorkingTreeStatus :: PrepareM TreeStatus getGitWorkingTreeStatus = do @@ -273,7 +273,7 @@ data DependencyStatus | ResolvedVersion String -- ^ Resolved to a version. The String argument is the resolution tag (eg, -- "v0.1.0"). - deriving (Show, Read, Eq) + deriving (Show, Eq) -- Go through all bower dependencies which contain purescript code, and -- extract their versions. diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index de29d11759..36c5700a98 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -49,7 +49,7 @@ data ImportRecord a = , importSourceModule :: ModuleName , importProvenance :: ImportProvenance } - deriving (Eq, Ord, Show, Read) + deriving (Eq, Ord, Show) -- | -- Used to track how an import was introduced into scope. This allows us to @@ -61,7 +61,7 @@ data ImportProvenance | FromExplicit | Local | Prim - deriving (Eq, Ord, Show, Read) + deriving (Eq, Ord, Show) type ImportMap a = M.Map (Qualified a) [ImportRecord a] @@ -104,7 +104,7 @@ data Imports = Imports -- The "as" names of modules that have been imported qualified. -- , importedQualModules :: S.Set ModuleName - } deriving (Show, Read) + } deriving (Show) nullImports :: Imports nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty @@ -155,7 +155,7 @@ data Exports = Exports -- from. -- , exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName - } deriving (Show, Read) + } deriving (Show) -- | -- An empty 'Exports' value. diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 9f384559b4..10d09d2301 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -329,9 +329,9 @@ updateTypes goType = (goDecl, goExpr, goBinder) goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) - goExpr pos (TypeClassDictionary (Constraint name tys info) dicts) = do + goExpr pos (TypeClassDictionary (Constraint name tys info) dicts hints) = do tys' <- traverse (goType' pos) tys - return (pos, TypeClassDictionary (Constraint name tys' info) dicts) + return (pos, TypeClassDictionary (Constraint name tys' info) dicts hints) goExpr pos (SuperClassDictionary cls tys) = do tys' <- traverse (goType' pos) tys return (pos, SuperClassDictionary cls tys') diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 44ff0d10c1..7262224dd7 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -11,9 +11,8 @@ module Language.PureScript.Sugar.TypeClasses import Prelude.Compat import Language.PureScript.Crash -import Language.PureScript.AST hiding (isExported) import Language.PureScript.Environment -import Language.PureScript.Errors +import Language.PureScript.Errors hiding (isExported) import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Externs diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 73d696efc7..b1bf5b31e5 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -22,6 +22,7 @@ import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.Names +import Language.PureScript.TypeChecker.Monad (CheckState, withErrorMessageHint) import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types @@ -39,7 +40,7 @@ combineContexts = M.unionWith (M.unionWith M.union) -- | Replace type class dictionary placeholders with inferred type class dictionaries replaceTypeClassDictionaries - :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => Bool -> ModuleName -> Expr @@ -48,7 +49,8 @@ replaceTypeClassDictionaries shouldGeneralize mn = let (_, f, _) = everywhereOnValuesTopDownM return (WriterT . go) return in flip evalStateT M.empty . runWriterT . f where - go (TypeClassDictionary constraint dicts) = entails shouldGeneralize mn dicts constraint + go (TypeClassDictionary constraint dicts hints) = + rethrow (addHints hints) $ entails shouldGeneralize mn dicts constraint go other = return (other, []) -- | @@ -57,7 +59,7 @@ replaceTypeClassDictionaries shouldGeneralize mn = -- entails :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) + . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => Bool -> ModuleName -> Context @@ -79,7 +81,7 @@ entails shouldGeneralize moduleName context = solve findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx solve :: Constraint -> StateT Context m (Expr, [(Ident, Constraint)]) - solve con = do + solve con = StateT . (withErrorMessageHint (ErrorSolvingConstraint con) .) . runStateT $ do (dict, unsolved) <- go 0 con return (dictionaryValueToValue dict, unsolved) where diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index ea5d59835e..3d356849ca 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -107,7 +107,7 @@ kindOfWithScopedVars :: Type -> m (Kind, [(String, Kind)]) kindOfWithScopedVars ty = - rethrow (addHint (ErrorCheckingKind ty)) $ + withErrorMessageHint (ErrorCheckingKind ty) $ fmap tidyUp . liftUnify $ infer ty where tidyUp ((k, args), sub) = ( starIfUnknown (substituteKind sub k) @@ -200,7 +200,7 @@ infer :: (MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)]) -infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty +infer ty = withErrorMessageHint (ErrorCheckingKind ty) $ infer' ty infer' :: forall m diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 0635f0a2d7..ba3139e8b3 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -35,18 +35,30 @@ emptySubstitution = Substitution M.empty M.empty -- | State required for type checking data CheckState = CheckState - { checkEnv :: Environment -- ^ The current @Environment@ - , checkNextType :: Int -- ^ The next type unification variable - , checkNextKind :: Int -- ^ The next kind unification variable - , checkNextSkolem :: Int -- ^ The next skolem variable - , checkNextSkolemScope :: Int -- ^ The next skolem scope constant - , checkCurrentModule :: Maybe ModuleName -- ^ The current module - , checkSubstitution :: Substitution -- ^ The current substitution + { checkEnv :: Environment + -- ^ The current @Environment@ + , checkNextType :: Int + -- ^ The next type unification variable + , checkNextKind :: Int + -- ^ The next kind unification variable + , checkNextSkolem :: Int + -- ^ The next skolem variable + , checkNextSkolemScope :: Int + -- ^ The next skolem scope constant + , checkCurrentModule :: Maybe ModuleName + -- ^ The current module + , checkSubstitution :: Substitution + -- ^ The current substitution + , checkHints :: [ErrorMessageHint] + -- ^ The current error message hint stack. + -- This goes into state, rather than using 'rethrow', + -- since this way, we can provide good error messages + -- during instance resolution. } -- | Create an empty @CheckState@ emptyCheckState :: Environment -> CheckState -emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution +emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution [] -- | Unification variables type Unknown = Int @@ -91,6 +103,33 @@ withScopedTypeVars mn ks ma = do tell . errorMessage $ ShadowedTypeVar name bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma +withErrorMessageHint + :: (MonadState CheckState m, MonadError MultipleErrors m) + => ErrorMessageHint + -> m a + -> m a +withErrorMessageHint hint action = do + orig <- get + modify $ \st -> st { checkHints = hint : checkHints st } + -- Need to use 'rethrow' anyway, since we have to handle regular errors + a <- rethrow (addHint hint) action + modify $ \st -> st { checkHints = checkHints orig } + return a + +rethrowWithPositionTC + :: (MonadState CheckState m, MonadError MultipleErrors m) + => SourceSpan + -> m a + -> m a +rethrowWithPositionTC pos = withErrorMessageHint (PositionedError pos) + +warnAndRethrowWithPositionTC + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => SourceSpan + -> m a + -> m a +warnAndRethrowWithPositionTC pos = rethrowWithPositionTC pos . warnWithPosition pos + -- | Temporarily make a collection of type class dictionaries available withTypeClassDictionaries :: MonadState CheckState m diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index b7cd9de522..148ca45cee 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -8,7 +8,7 @@ module Language.PureScript.TypeChecker.Subsumption import Prelude.Compat import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.State.Class (MonadState(..), gets) import Data.List (sortBy) import Data.Ord (comparing) @@ -24,7 +24,7 @@ import Language.PureScript.Types -- | Check that one type subsumes another, rethrowing errors to provide a better error message subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr) -subsumes val ty1 ty2 = rethrow (addHint (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2 +subsumes val ty1 ty2 = withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ subsumes' val ty1 ty2 -- | Check tahat one type subsumes another subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) => @@ -52,7 +52,8 @@ subsumes' val ty1 (KindedType ty2 _) = subsumes val ty1 ty2 subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do dicts <- getTypeClassDictionaries - subsumes' (Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)) ty1 ty2 + hints <- gets checkHints + subsumes' (Just $ foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty1 ty2 subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do let (ts1, r1') = rowToList r1 diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index e405537293..d3e5965ef6 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -201,7 +201,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' where g :: Expr -> Expr g (TypedValue checkTy val t) = TypedValue checkTy val (f t) - g (TypeClassDictionary c sco) = TypeClassDictionary (mapConstraintArgs (map f) c) sco + g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints g other = other -- | Check the kind of a type, failing if it is not of kind *. @@ -227,7 +227,8 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do instantiatePolyTypeWithUnknowns val ty' instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do dicts <- getTypeClassDictionaries - instantiatePolyTypeWithUnknowns (foldl App val (map (flip TypeClassDictionary dicts) constraints)) ty + hints <- gets checkHints + instantiatePolyTypeWithUnknowns (foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty instantiatePolyTypeWithUnknowns val ty = return (val, ty) -- | Infer a type for a value, rethrowing any error to provide a more useful error message @@ -235,7 +236,7 @@ infer :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> m Expr -infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val +infer val = withErrorMessageHint (ErrorInferringType val) $ infer' val -- | Infer a type for a value infer' :: @@ -267,7 +268,7 @@ infer' (ObjectUpdate o ps) = do let oldTy = TypeApp tyRecord $ rowFromList (oldTys, row) o' <- TypedValue True <$> check o oldTy <*> pure oldTy return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyRecord $ rowFromList (newTys, row) -infer' (Accessor prop val) = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do +infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do field <- freshType rest <- freshType typed <- check val (TypeApp tyRecord (RCons prop field rest)) @@ -290,7 +291,8 @@ infer' (Var var) = do case ty of ConstrainedType constraints ty' -> do dicts <- getTypeClassDictionaries - return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty' + hints <- gets checkHints + return $ TypedValue True (foldl App (Var var) (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty' _ -> return $ TypedValue True (Var var) ty infer' v@(Constructor c) = do env <- getEnv @@ -316,7 +318,8 @@ infer' (Let ds val) = do return $ TypedValue True (Let ds' val') valTy infer' (SuperClassDictionary className tys) = do dicts <- getTypeClassDictionaries - return $ TypeClassDictionary (Constraint className tys Nothing) dicts + hints <- gets checkHints + return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints infer' (TypedValue checkType val ty) = do Just moduleName <- checkCurrentModule <$> get (kind, args) <- kindOfWithScopedVars ty @@ -331,7 +334,7 @@ infer' (Hole name) = do let ctx = [ (ident, ty') | ((mn, ident@Ident{}), (ty', _, Defined)) <- env, mn == moduleName ] tell . errorMessage $ HoleInferredType name ty ctx return $ TypedValue True (Hole name) ty -infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do +infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do TypedValue t v ty <- infer' val return $ TypedValue t (PositionedValue pos c v) ty infer' v = internalError $ "Invalid argument to infer: " ++ show v @@ -368,7 +371,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do bindNames dict $ do makeBindingGroupVisible inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j -inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do +inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPositionTC pos $ do (d' : ds', val') <- inferLetBinding seen (d : ds) ret j return (PositionedDeclaration pos com d' : ds', val') inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding" @@ -426,7 +429,7 @@ inferBinder val (NamedBinder name binder) = do m <- inferBinder val binder return $ M.insert name val m inferBinder val (PositionedBinder pos _ binder) = - warnAndRethrowWithPosition pos $ inferBinder val binder + warnAndRethrowWithPositionTC pos $ inferBinder val binder -- TODO: When adding support for polymorphic types, check subsumption here, -- change the definition of `binderRequiresMonotype`, -- and use `kindOfWithScopedVars`. @@ -487,7 +490,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do case result of Left gs -> do gs' <- forM gs $ \(grd, val) -> do - grd' <- rethrow (addHint ErrorCheckingGuard) $ check grd tyBoolean + grd' <- withErrorMessageHint ErrorCheckingGuard $ check grd tyBoolean val' <- TypedValue True <$> check val ret <*> pure ret return (grd', val') return $ Left gs' @@ -505,7 +508,7 @@ check :: Expr -> Type -> m Expr -check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty +check val ty = withErrorMessageHint (ErrorCheckingType val ty) $ check' val ty -- | -- Check the type of a value @@ -599,7 +602,8 @@ check' (SuperClassDictionary className tys) _ = do -- declaration gets desugared. -} dicts <- getTypeClassDictionaries - return $ TypeClassDictionary (Constraint className tys Nothing) dicts + hints <- gets checkHints + return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints check' (TypedValue checkType val ty1) ty2 = do Just moduleName <- checkCurrentModule <$> get (kind, args) <- kindOfWithScopedVars ty1 @@ -638,7 +642,7 @@ check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyRecord = do obj' <- check obj (TypeApp tyRecord (rowFromList (us ++ remainingProps, rest))) ps' <- checkProperties e ps row True return $ TypedValue True (ObjectUpdate obj' ps') t -check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do +check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do rest <- freshType val' <- check val (TypeApp tyRecord (RCons prop ty rest)) return $ TypedValue True (Accessor prop val') ty @@ -659,7 +663,7 @@ check' val kt@(KindedType ty kind) = do checkTypeKind ty kind val' <- check' val ty return $ TypedValue True val' kt -check' (PositionedValue pos c val) ty = warnAndRethrowWithPosition pos $ do +check' (PositionedValue pos c val) ty = warnAndRethrowWithPositionTC pos $ do TypedValue t v ty' <- check' val ty return $ TypedValue t (PositionedValue pos c v) ty' check' val ty = do @@ -713,7 +717,7 @@ checkFunctionApplication :: Expr -> Maybe Type -> m (Type, Expr) -checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication fn fnTy arg)) $ do +checkFunctionApplication fn fnTy arg ret = withErrorMessageHint (ErrorInApplication fn fnTy arg) $ do subst <- gets checkSubstitution checkFunctionApplication' fn (substituteType subst fnTy) arg (substituteType subst <$> ret) @@ -749,7 +753,8 @@ checkFunctionApplication' fn (KindedType ty _) arg ret = checkFunctionApplication fn ty arg ret checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do dicts <- getTypeClassDictionaries - checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg ret + hints <- gets checkHints + checkFunctionApplication' (foldl App fn (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) fnTy arg ret checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ = return (fnTy, App fn dict) checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 8716a6d948..e9fc8131dd 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -80,7 +80,7 @@ unknownsInType t = everythingOnTypes (.) go t [] unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m () unifyTypes t1 t2 = do sub <- gets checkSubstitution - rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ unifyTypes' (substituteType sub t1) (substituteType sub t2) + withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes' (substituteType sub t1) (substituteType sub t2) where unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return () unifyTypes' (TUnknown u) t = solveType u t diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 9bc82ed20a..5d2af003e5 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -21,7 +21,7 @@ data TypeClassDictionaryInScope -- | Type class dependencies which must be satisfied to construct this dictionary , tcdDependencies :: Maybe [Constraint] } - deriving (Show, Read) + deriving (Show) -- | -- A simplified representation of expressions which are used to represent type @@ -44,4 +44,4 @@ data DictionaryValue -- A subclass dictionary -- | SubclassDictionaryValue DictionaryValue (Qualified (ProperName 'ClassName)) Integer - deriving (Show, Read, Ord, Eq) + deriving (Show, Ord, Eq) diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 8f2edf0645..f9d7a60807 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -23,7 +23,7 @@ import Language.PureScript.Names -- An identifier for the scope of a skolem variable -- newtype SkolemScope = SkolemScope { runSkolemScope :: Int } - deriving (Show, Read, Eq, Ord, A.ToJSON, A.FromJSON) + deriving (Show, Eq, Ord, A.ToJSON, A.FromJSON) -- | -- The type of types @@ -71,7 +71,7 @@ data Type -- Note: although it seems this constructor is not used, it _is_ useful, -- since it prevents certain traversals from matching. | ParensInType Type - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) -- | Additional data relevant to type class constraints data ConstraintData @@ -81,7 +81,7 @@ data ConstraintData -- not matched, and a flag indicating whether the list was truncated or not. -- Note: we use 'String' here because using 'Binder' would introduce a cyclic -- dependency in the module graph. - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq, Ord) -- | A typeclass constraint data Constraint = Constraint @@ -91,7 +91,7 @@ data Constraint = Constraint -- ^ type arguments , constraintData :: Maybe ConstraintData -- ^ additional data relevant to this constraint - } deriving (Show, Read, Eq, Ord) + } deriving (Show, Eq, Ord) mapConstraintArgs :: ([Type] -> [Type]) -> Constraint -> Constraint mapConstraintArgs f c = c { constraintArgs = f (constraintArgs c) } diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 1c55a8a50d..05c082f152 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -30,7 +30,7 @@ data TestResult = ParseFailed String | Mismatch ByteString ByteString -- ^ encoding before, encoding after | Pass ByteString - deriving (Show, Read) + deriving (Show) roundTrip :: UploadedPackage -> TestResult roundTrip pkg = From 15c466f19df3bde8c617adc0502e8fa6d8a6bd2f Mon Sep 17 00:00:00 2001 From: ilovezfs Date: Tue, 26 Jul 2016 10:31:56 -0700 Subject: [PATCH 0464/1580] protolude 0.1.6: fix ambiguous occurrences (#2225) Prevent PureScript build failure with protolude 0.1.6 due to ambiguous occurrence errors arising from the following conflicts: Protolude.fromStrict vs. Data.ByteString.Lazy.fromStrict Protolude.decodeUtf8 vs. Data.Text.Lazy.Encoding.decodeUtf8 Protolude.encodeUtf8 vs. Data.Text.Lazy.Encoding.encodeUtf8 In order to preserve the ability to use "fromStrict" without qualifying it (e.g., Z.fromStrict), this fixes the ambiguous occurrences in a way that is backwards incompatible with protolude 0.1.5. In particular, using fromStrict without qualification requires hiding it, but since protolude 0.1.5 doesn't actually export fromStrict, importing 0.1.5 hiding fromStrict will trigger a dodgy imports warning. Bumping the protolude dependency to >= 0.1.6 requires bumps to PureScript's designated Stack LTS and Nightly resolvers. Switching to lts-6.7 and nightly-2016-07-19 requires a few unrelated fixes: System.FilePath: remove redundant imports (-Wunused-imports) parseURL: replace with non-deprecated parseRequest (-Wdeprecations) fromJust: import from Data.Maybe instead of Unsafe (prevents error) Also set protolude >=0.1.6 and http-client >= 0.4.30 (for parseRequest) in purescript.cabal, and update the CONTRIBUTORS file. --- CONTRIBUTORS.md | 1 + purescript.cabal | 7 ++++--- src/Language/PureScript/Ide/Command.hs | 1 - src/Language/PureScript/Ide/Externs.hs | 1 - src/Language/PureScript/Ide/Imports.hs | 1 - src/Language/PureScript/Ide/Pursuit.hs | 4 ++-- src/Language/PureScript/Ide/Rebuild.hs | 1 - src/Language/PureScript/Ide/SourceFile.hs | 1 - src/Language/PureScript/Ide/State.hs | 1 - src/Language/PureScript/Ide/Types.hs | 1 - src/Language/PureScript/Ide/Util.hs | 2 +- stack-ghc-8.0.yaml | 2 +- stack.yaml | 2 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 2 +- tests/Language/PureScript/Ide/Integration.hs | 2 +- 15 files changed, 12 insertions(+), 17 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index d6ec3ec2a7..51c350638f 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -27,6 +27,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@faineance](https://github.com/faineance) My existing contributions and all future contributions until further notice are Copyright faineance, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@ilovezfs](https://github.com/ilovezfs) - My existing contributions and all future contributions until further notice are Copyright ilovezfs, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license - [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). diff --git a/purescript.cabal b/purescript.cabal index 904a85ba78..8b6762dbcb 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -116,6 +116,7 @@ library fsnotify >= 0.2.1, Glob >= 0.7 && < 0.8, haskeline >= 0.7.0.0, + http-client >= 0.4.30, http-types -any, language-javascript == 0.6.*, lifted-base >= 0.2.3 && < 0.2.4, @@ -128,7 +129,7 @@ library pipes >= 4.0.0 && < 4.3.0, pipes-http -any, process >= 1.2.0 && < 1.5, - protolude >= 0.1.5, + protolude >= 0.1.6, regex-tdfa -any, safe >= 0.3.9 && < 0.4, semigroups >= 0.16.2 && < 0.19, @@ -449,7 +450,7 @@ executable psc-ide-server mtl -any, network -any, optparse-applicative >= 0.12.1, - protolude >= 0.1.5, + protolude >= 0.1.6, stm -any, text -any, transformers -any, @@ -491,7 +492,7 @@ test-suite tests optparse-applicative -any, parsec -any, process -any, - protolude >= 0.1.5, + protolude >= 0.1.6, silently -any, stm -any, text -any, diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 31a20a2c16..0d6e48cdda 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -24,7 +24,6 @@ import Language.PureScript.Ide.CaseSplit import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types -import System.FilePath data Command = Load [P.ModuleName] diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 37f03198b6..0e8374509f 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -33,7 +33,6 @@ import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import qualified Language.PureScript as P -import System.FilePath readExternFile :: (MonadIO m, MonadError PscIdeError m) => FilePath -> m P.ExternsFile diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index e26796e136..8c64aa126e 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -40,7 +40,6 @@ import Language.PureScript.Ide.Filter import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import System.FilePath data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) deriving (Eq, Show) diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs index 9032a3457b..962f573af9 100644 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -19,7 +19,7 @@ module Language.PureScript.Ide.Pursuit , findPackagesForModuleIdent ) where -import Protolude +import Protolude hiding (fromStrict) import qualified Control.Exception as E import Data.Aeson @@ -36,7 +36,7 @@ import qualified Pipes.Prelude as P queryPursuit :: Text -> IO ByteString queryPursuit q = do let qClean = T.dropWhileEnd (== '.') q - req' <- parseUrl "http://pursuit.purescript.org/search" + req' <- parseRequest "http://pursuit.purescript.org/search" let req = req' { queryString= "q=" <> (fromString . T.unpack) qClean , requestHeaders=[(hAccept, "application/json")] diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 9dad7a6731..f543dbb985 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -22,7 +22,6 @@ import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import System.IO.UTF8 (readUTF8File) -import System.FilePath -- | Given a filepath performs the following steps: -- diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 6e9ba0c8a0..ccca6122c6 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -26,7 +26,6 @@ import qualified Language.PureScript as P import Language.PureScript.Ide.Error import Language.PureScript.Ide.Util import Language.PureScript.Ide.Types -import System.FilePath import System.IO.UTF8 (readUTF8File) parseModule diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 4621d3947a..55b225537e 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -44,7 +44,6 @@ import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import qualified Language.PureScript as P import System.Clock -import System.FilePath -- | Resets all State inside psc-ide resetIdeState :: Ide m => m () diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 6bcfc7e7f7..c8c37583d7 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -25,7 +25,6 @@ import Data.Map.Lazy as M import qualified Language.PureScript.Errors.JSON as P import qualified Language.PureScript as P import Language.PureScript.Ide.Conversions -import System.FilePath import Text.Parsec as Parsec import Text.Parsec.Text diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 4e4c235516..548e1f419d 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -27,7 +27,7 @@ module Language.PureScript.Ide.Util , module Language.PureScript.Ide.Conversions ) where -import Protolude +import Protolude hiding (decodeUtf8, encodeUtf8) import Data.Aeson import qualified Data.Text as T import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) diff --git a/stack-ghc-8.0.yaml b/stack-ghc-8.0.yaml index d56763ecc2..0228aa7d3e 100644 --- a/stack-ghc-8.0.yaml +++ b/stack-ghc-8.0.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2016-05-29 +resolver: nightly-2016-07-19 packages: - '.' extra-deps: diff --git a/stack.yaml b/stack.yaml index 304ee4c265..1990820fc7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-6.1 +resolver: lts-6.7 packages: - '.' extra-deps: [] diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 5b5ba321a8..5680020372 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -3,7 +3,7 @@ module Language.PureScript.Ide.ImportsSpec where import Protolude -import Unsafe (fromJust) +import Data.Maybe (fromJust) import qualified Language.PureScript as P import Language.PureScript.Ide.Imports diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs index 4f55441bd9..f733959fb5 100644 --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -48,7 +48,7 @@ module Language.PureScript.Ide.Integration ) where import Protolude -import Unsafe (fromJust) +import Data.Maybe (fromJust) import Data.Aeson import Data.Aeson.Types From 6144cba087ff77933f375edd99c6bb0a140ee0a6 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 28 Jul 2016 16:42:55 -0500 Subject: [PATCH 0465/1580] Decode externs with correct encoding Externs failed to decode properly when they contained unicode, causing files to be rebuilt too often. Reference: http://stackoverflow.com/questions/27669418/aeson-does-not-decode-strings-with-unicode-characters --- src/Language/PureScript/Make.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 5dbc39f750..b4f928a6f0 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -36,6 +36,7 @@ import Control.Monad.Trans.Except import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Aeson (encode, decode) +import Data.ByteString.Builder (toLazyByteString, stringUtf8) import Data.Either (partitionEithers) import Data.Foldable (for_) import Data.List (foldl', sort) @@ -252,7 +253,7 @@ make ma@MakeActions{..} ms = do decodeExterns :: Externs -> Maybe ExternsFile decodeExterns bs = do - externs <- decode (fromString bs) + externs <- decode (toLazyByteString (stringUtf8 bs)) guard $ efVersion externs == showVersion Paths.version return externs From 3a3ac0f4f6773ea10b4ac699c957cfa79e6a3429 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 30 Jul 2016 15:07:43 -0700 Subject: [PATCH 0466/1580] Add upper bound to http-client, fix #2237 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 8b6762dbcb..c5a76d1912 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -116,7 +116,7 @@ library fsnotify >= 0.2.1, Glob >= 0.7 && < 0.8, haskeline >= 0.7.0.0, - http-client >= 0.4.30, + http-client >= 0.4.30 && <0.5, http-types -any, language-javascript == 0.6.*, lifted-base >= 0.2.3 && < 0.2.4, From efc00d9c357e6718f477a2f4ebb10dcc5bcc22d9 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 30 Jul 2016 15:49:07 -0700 Subject: [PATCH 0467/1580] Use latest LTS, fix #2241 --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 1990820fc7..e40e931d12 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-6.7 +resolver: lts-6.9 packages: - '.' extra-deps: [] From 455848a5494dc041b3c6f1ae5133528c5204ac19 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 31 Jul 2016 10:26:13 -0700 Subject: [PATCH 0468/1580] Better context information for typed hole errors (#2247) * Better context information for typed hole errors * Context information in wildcard warnings --- src/Language/PureScript/AST/Declarations.hs | 7 +- src/Language/PureScript/Docs/Convert.hs | 2 +- src/Language/PureScript/Environment.hs | 5 +- src/Language/PureScript/Errors.hs | 47 ++++++----- src/Language/PureScript/Externs.hs | 4 +- src/Language/PureScript/Interactive.hs | 2 +- .../PureScript/Interactive/Printer.hs | 13 +-- src/Language/PureScript/TypeChecker.hs | 10 +-- .../PureScript/TypeChecker/Entailment.hs | 30 +++---- src/Language/PureScript/TypeChecker/Monad.hs | 40 ++++----- src/Language/PureScript/TypeChecker/Types.hs | 82 ++++++++----------- src/Language/PureScript/TypeChecker/Unify.hs | 12 ++- 12 files changed, 128 insertions(+), 126 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 06d94480ec..a9ba39ef3f 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -26,6 +26,9 @@ import qualified Language.PureScript.Bundle as Bundle import qualified Text.Parsec as P +-- | A map of locally-bound names in scope. +type Context = [(Ident, Type)] + -- | A type of error messages data SimpleErrorMessage = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) @@ -96,8 +99,8 @@ data SimpleErrorMessage | ShadowedName Ident | ShadowedTypeVar String | UnusedTypeVar String - | WildcardInferredType Type - | HoleInferredType String Type [(Ident, Type)] + | WildcardInferredType Type Context + | HoleInferredType String Type Context | MissingTypeDeclaration Ident Type | OverlappingPattern [[Binder]] Bool | IncompleteExhaustivityCheck diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index a5f9c346a5..9eee08637f 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -158,7 +158,7 @@ insertValueTypes env m = either (err . ("failed to parse Ident: " ++)) id . runParser P.parseIdent lookupName name = - let key = (modName m, name) + let key = P.Qualified (Just (modName m)) name in case Map.lookup key (P.names env) of Just (ty, _, _) -> ty diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index d94b517fda..d67f771dfb 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -25,7 +25,7 @@ data Environment = Environment { -- | -- Value names currently in scope -- - names :: M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) + names :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility) -- | -- Type names currently in scope -- @@ -273,7 +273,6 @@ isNewtypeConstructor e ctor = case lookupConstructor e ctor of -- Finds information about values from the current environment. -- lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility) -lookupValue env (Qualified (Just mn) ident) = (mn, ident) `M.lookup` names env -lookupValue _ _ = Nothing +lookupValue env ident = ident `M.lookup` names env $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index af67ef27f1..b0c2d0fd54 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -17,6 +17,7 @@ import Control.Monad.Writer import Data.Char (isSpace) import Data.Either (lefts, rights) import Data.Foldable (fold) +import Data.Functor.Identity (Identity(..)) import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition) import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import Data.Ord (comparing) @@ -243,7 +244,10 @@ replaceUnknowns = everywhereOnTypesM replaceTypes Just (_, s', _) -> return (Skolem name s' sko ss) replaceTypes other = return other -onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage +onTypesInErrorMessage :: (Type -> Type) -> ErrorMessage -> ErrorMessage +onTypesInErrorMessage f = runIdentity . onTypesInErrorMessageM (Identity . f) + +onTypesInErrorMessageM :: Applicative m => (Type -> m Type) -> ErrorMessage -> m ErrorMessage onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple where gSimple (InfiniteType t) = InfiniteType <$> f t @@ -258,11 +262,10 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts - gSimple (WildcardInferredType ty) = WildcardInferredType <$> f ty - gSimple (HoleInferredType name ty env) = HoleInferredType name <$> f ty <*> traverse (sndM f) env + gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx + gSimple (HoleInferredType name ty ctx) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty - gSimple other = pure other gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2 @@ -289,7 +292,7 @@ errorSuggestion err = case err of ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintType ty - WildcardInferredType ty -> suggest $ prettyPrintType ty + WildcardInferredType ty _ -> suggest $ prettyPrintType ty _ -> Nothing where @@ -721,24 +724,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS paras [ line "hiding imports cannot be used to hide modules." , line $ "An attempt was made to hide the import of " ++ markCode (runModuleName name) ] - renderSimpleErrorMessage (WildcardInferredType ty) = - paras [ line "Wildcard type definition has the inferred type " - , markCodeBox $ indent $ typeAsBox ty - ] - renderSimpleErrorMessage (HoleInferredType name ty env) = + renderSimpleErrorMessage (WildcardInferredType ty ctx) = + paras $ [ line "Wildcard type definition has the inferred type " + , markCodeBox $ indent $ typeAsBox ty + ] ++ renderContext ctx + renderSimpleErrorMessage (HoleInferredType name ty ctx) = paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type " , markCodeBox $ indent $ typeAsBox ty - ] ++ if null env then [] else envInfo - where - envInfo :: [Box.Box] - envInfo = [ line "in the following context:" - , indent $ paras - [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ") - , markCodeBox $ typeAsBox ty' - ] - | (ident, ty') <- take 5 env - ] - ] + ] ++ renderContext ctx renderSimpleErrorMessage (MissingTypeDeclaration ident ty) = paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "." , line "It is good practice to provide type declarations as a form of documentation." @@ -951,6 +944,18 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , detail ] + renderContext :: Context -> [Box.Box] + renderContext [] = [] + renderContext ctx = + [ line "in the following context:" + , indent $ paras + [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ") + , markCodeBox $ typeAsBox ty' + ] + | (ident, ty') <- take 5 ctx + ] + ] + printName :: Qualified Name -> String printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 1a83621f5e..f1b2f83fb6 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -140,7 +140,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) } applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) } applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } - applyDecl env (EDValue ident ty) = env { names = M.insert (efModuleName, ident) (ty, External, Defined) (names env) } + applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } applyDecl env (EDClass pn args members cs) = env { typeClasses = M.insert (qual pn) (args, members, cs) (typeClasses env) } applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) } where @@ -201,7 +201,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} ] _ -> internalError "toExternsDeclaration: Invalid input" toExternsDeclaration (ValueRef ident) - | Just (ty, _, _) <- (mn, ident) `M.lookup` names env + | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env = [ EDValue ident ty ] toExternsDeclaration (TypeClassRef className) | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index f39f90e4bb..49f0a73c33 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -234,7 +234,7 @@ handleTypeOf val = do case e of Left errs -> printErrors errs Right (_, env') -> - case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of + case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName [P.ProperName "$PSCI"])) (P.names env') of Just (ty, _, _) -> liftIO . putStrLn . P.prettyPrintType $ ty Nothing -> liftIO $ putStrLn "Could not find type" diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index 6147405adc..9f3352294e 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -19,9 +19,10 @@ import qualified Text.PrettyPrint.Boxes as Box printModuleSignatures :: P.ModuleName -> P.Environment -> String printModuleSignatures moduleName (P.Environment {..}) = -- get relevant components of a module from environment - let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names - moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses - moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types + let moduleNamesIdent = byModuleName names + moduleTypeClasses = byModuleName typeClasses + moduleTypes = byModuleName types + byModuleName = filter ((== Just moduleName) . P.getQual) . M.keys in -- print each component @@ -33,8 +34,10 @@ printModuleSignatures moduleName (P.Environment {..}) = where printModule's showF = Box.vsep 1 Box.left . showF - findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) - findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames) + findNameType :: M.Map (P.Qualified P.Ident) (P.Type, P.NameKind, P.NameVisibility) + -> P.Qualified P.Ident + -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) + findNameType envNames m = (P.disqualify m, M.lookup m envNames) showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 95ffb95c80..bfadcdd5c5 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -91,7 +91,7 @@ valueIsNotDefined -> m () valueIsNotDefined moduleName name = do env <- getEnv - case M.lookup (moduleName, name) (names env) of + case M.lookup (Qualified (Just moduleName) name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name Nothing -> return () @@ -104,7 +104,7 @@ addValue -> m () addValue moduleName name ty nameKind = do env <- getEnv - putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) }) + putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, nameKind, Defined) (names env) }) addTypeClass :: (MonadState CheckState m) @@ -259,9 +259,9 @@ typeCheckAll moduleName _ = traverse go env <- getEnv kind <- kindOf ty guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star - case M.lookup (moduleName, name) (names env) of + case M.lookup (Qualified (Just moduleName) name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name - Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) }) + Nothing -> putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, External, Defined) (names env) }) return d go d@FixityDeclaration{} = return d go d@ImportDeclaration{} = return d @@ -360,7 +360,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = Just (_, _, ty, _) -> checkExport dr extract ty return () checkMemberExport extract dr@(ValueRef name) = do - ty <- lookupVariable mn (Qualified (Just mn) name) + ty <- lookupVariable (Qualified (Just mn) name) checkExport dr extract ty checkMemberExport _ _ = return () diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index b1bf5b31e5..c15d628037 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -2,7 +2,7 @@ -- Type class entailment -- module Language.PureScript.TypeChecker.Entailment - ( Context + ( InstanceContext , replaceTypeClassDictionaries ) where @@ -28,14 +28,14 @@ import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types import qualified Language.PureScript.Constants as C --- | The 'Context' tracks those constraints which can be satisfied. -type Context = M.Map (Maybe ModuleName) - (M.Map (Qualified (ProperName 'ClassName)) - (M.Map (Qualified Ident) - TypeClassDictionaryInScope)) +-- | The 'InstanceContext' tracks those constraints which can be satisfied. +type InstanceContext = M.Map (Maybe ModuleName) + (M.Map (Qualified (ProperName 'ClassName)) + (M.Map (Qualified Ident) + TypeClassDictionaryInScope)) -- | Merge two type class contexts -combineContexts :: Context -> Context -> Context +combineContexts :: InstanceContext -> InstanceContext -> InstanceContext combineContexts = M.unionWith (M.unionWith M.union) -- | Replace type class dictionary placeholders with inferred type class dictionaries @@ -62,12 +62,12 @@ entails . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => Bool -> ModuleName - -> Context + -> InstanceContext -> Constraint - -> StateT Context m (Expr, [(Ident, Constraint)]) + -> StateT InstanceContext m (Expr, [(Ident, Constraint)]) entails shouldGeneralize moduleName context = solve where - forClassName :: Context -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope] + forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope] forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys)) forClassName _ _ _ = internalError "forClassName: expected qualified class name" @@ -77,15 +77,15 @@ entails shouldGeneralize moduleName context = solve ctorModules (TypeApp ty _) = ctorModules ty ctorModules _ = Nothing - findDicts :: Context -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope] + findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope] findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx - solve :: Constraint -> StateT Context m (Expr, [(Ident, Constraint)]) + solve :: Constraint -> StateT InstanceContext m (Expr, [(Ident, Constraint)]) solve con = StateT . (withErrorMessageHint (ErrorSolvingConstraint con) .) . runStateT $ do (dict, unsolved) <- go 0 con return (dictionaryValueToValue dict, unsolved) where - go :: Int -> Constraint -> StateT Context m (DictionaryValue, [(Ident, Constraint)]) + go :: Int -> Constraint -> StateT InstanceContext m (DictionaryValue, [(Ident, Constraint)]) go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' go work con'@(Constraint className' tys' _) = do -- Get the inferred constraint context so far, and merge it with the global context @@ -108,7 +108,7 @@ entails shouldGeneralize moduleName context = solve -- Generate a fresh name for the unsolved constraint's new dictionary ident <- freshIdent ("dict" ++ runProperName pn) let qident = Qualified Nothing ident - -- Store the new dictionary in the Context so that we can solve this goal in + -- Store the new dictionary in the InstanceContext so that we can solve this goal in -- future. let newDict = TypeClassDictionaryInScope qident [] unsolvedClassName unsolvedTys Nothing newContext = M.singleton Nothing (M.singleton unsolvedClassName (M.singleton qident newDict)) @@ -145,7 +145,7 @@ entails shouldGeneralize moduleName context = solve -- Create dictionaries for subgoals which still need to be solved by calling go recursively -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively. - solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT Context m (Maybe [DictionaryValue], [(Ident, Constraint)]) + solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT InstanceContext m (Maybe [DictionaryValue], [(Ident, Constraint)]) solveSubgoals _ Nothing = return (Nothing, []) solveSubgoals subst (Just subgoals) = do zipped <- traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars subst))) subgoals diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index ba3139e8b3..b229ca3966 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -66,7 +66,7 @@ type Unknown = Int -- | Temporarily bind a collection of names to values bindNames :: MonadState CheckState m - => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) + => M.Map (Qualified Ident) (Type, NameKind, NameVisibility) -> m a -> m a bindNames newNames action = do @@ -160,12 +160,11 @@ lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDict -- | Temporarily bind a collection of names to local variables bindLocalVariables :: (MonadState CheckState m) - => ModuleName - -> [(Ident, Type, NameVisibility)] + => [(Ident, Type, NameVisibility)] -> m a -> m a -bindLocalVariables moduleName bindings = - bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility))) +bindLocalVariables bindings = + bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> (Qualified Nothing name, (ty, Private, visibility))) -- | Temporarily bind a collection of names to local type variables bindLocalTypeVariables @@ -196,35 +195,32 @@ preservingNames action = do -- | Lookup the type of a value by name in the @Environment@ lookupVariable :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) - => ModuleName - -> Qualified Ident + => Qualified Ident -> m Type -lookupVariable currentModule (Qualified moduleName var) = do +lookupVariable qual = do env <- getEnv - case M.lookup (fromMaybe currentModule moduleName, var) (names env) of - Nothing -> throwError . errorMessage $ NameIsUndefined var + case M.lookup qual (names env) of + Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual) Just (ty, _, _) -> return ty -- | Lookup the visibility of a value by name in the @Environment@ getVisibility :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) - => ModuleName - -> Qualified Ident + => Qualified Ident -> m NameVisibility -getVisibility currentModule (Qualified moduleName var) = do +getVisibility qual = do env <- getEnv - case M.lookup (fromMaybe currentModule moduleName, var) (names env) of - Nothing -> throwError . errorMessage $ NameIsUndefined var + case M.lookup qual (names env) of + Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual) Just (_, _, vis) -> return vis -- | Assert that a name is visible checkVisibility :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) - => ModuleName - -> Qualified Ident + => Qualified Ident -> m () -checkVisibility currentModule name@(Qualified _ var) = do - vis <- getVisibility currentModule name +checkVisibility name@(Qualified _ var) = do + vis <- getVisibility name case vis of Undefined -> throwError . errorMessage $ CycleInDeclaration var _ -> return () @@ -245,6 +241,12 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do getEnv :: (MonadState CheckState m) => m Environment getEnv = checkEnv <$> get +-- | Get locally-bound names in context, to create an error message. +getLocalContext :: MonadState CheckState m => m Context +getLocalContext = do + env <- getEnv + return [ (ident, ty') | ((Qualified Nothing ident@Ident{}), (ty', _, Defined)) <- M.toList (names env) ] + -- | Update the @Environment@ putEnv :: (MonadState CheckState m) => Environment -> m () putEnv env = modify (\s -> s { checkEnv = env }) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index d3e5965ef6..c396409320 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -26,7 +26,6 @@ module Language.PureScript.TypeChecker.Types import Prelude.Compat -import Control.Arrow (second) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets) @@ -71,7 +70,7 @@ typesOf :: m [(Ident, (Expr, Type))] typesOf bindingGroupType moduleName vals = do tys <- fmap tidyUp . escalateWarningWhen isHoleError . liftUnifyWarnings replace $ do - (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals + (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2) @@ -117,26 +116,21 @@ typesOf bindingGroupType moduleName vals = do tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts -- Replace all the wildcards types with their inferred types - replace sub (ErrorMessage hints (WildcardInferredType ty)) = - ErrorMessage hints . WildcardInferredType $ substituteType sub ty - replace sub (ErrorMessage hints (HoleInferredType name ty env)) = - ErrorMessage hints $ HoleInferredType name (substituteType sub ty) - (map (second (substituteType sub)) env) - replace _ em = em + replace sub = onTypesInErrorMessage (substituteType sub) isHoleError :: ErrorMessage -> Bool isHoleError (ErrorMessage _ HoleInferredType{}) = True isHoleError _ = False -type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) +type TypeData = M.Map (Qualified Ident) (Type, NameKind, NameVisibility) type UntypedData = [(Ident, Type)] -typeDictionaryForBindingGroup :: - (MonadState CheckState m) => - ModuleName -> - [(Ident, Expr)] -> - m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData) +typeDictionaryForBindingGroup + :: (MonadState CheckState m) + => Maybe ModuleName + -> [(Ident, Expr)] + -> m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData) typeDictionaryForBindingGroup moduleName vals = do let -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed @@ -154,15 +148,15 @@ typeDictionaryForBindingGroup moduleName vals = do -- 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, Private, Undefined))) $ typedDict ++ untypedDict) + dict = M.fromList (map (\(ident, ty) -> ((Qualified moduleName ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict) return (untyped, typed, dict, untypedDict) -checkTypedBindingGroupElement :: - (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - ModuleName -> - (Ident, (Expr, Type, Bool)) -> - TypeData -> - m (Ident, (Expr, Type)) +checkTypedBindingGroupElement + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => ModuleName + -> (Ident, (Expr, Type, Bool)) + -> TypeData + -> m (Ident, (Expr, Type)) checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do -- Replace type wildcards ty' <- replaceTypeWildcards ty @@ -176,12 +170,12 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do else return (TypedValue False val' ty'') return (ident, (val'', ty'')) -typeForBindingGroupElement :: - (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - (Ident, Expr) -> - TypeData -> - UntypedData -> - m (Ident, (Expr, Type)) +typeForBindingGroupElement + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => (Ident, Expr) + -> TypeData + -> UntypedData + -> m (Ident, (Expr, Type)) typeForBindingGroupElement (ident, val) dict untypedDict = do -- Infer the type with the new names in scope TypedValue _ val' ty <- bindNames dict $ infer val @@ -275,8 +269,7 @@ infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val pro return $ TypedValue True (Accessor prop typed) field infer' (Abs (Left arg) ret) = do ty <- freshType - Just moduleName <- checkCurrentModule <$> get - withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do + withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do body@(TypedValue _ _ bodyTy) <- infer' ret return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy infer' (Abs (Right _) _) = internalError "Binder was not desugared" @@ -285,9 +278,8 @@ infer' (App f arg) = do (ret, app) <- checkFunctionApplication f' ft arg Nothing return $ TypedValue True app ret infer' (Var var) = do - Just moduleName <- checkCurrentModule <$> get - checkVisibility moduleName var - ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable moduleName $ var + checkVisibility var + ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable $ var case ty of ConstrainedType constraints ty' -> do dicts <- getTypeClassDictionaries @@ -329,9 +321,7 @@ infer' (TypedValue checkType val ty) = do return $ TypedValue True val' ty' infer' (Hole name) = do ty <- freshType - env <- M.toList . names <$> getEnv - Just moduleName <- checkCurrentModule <$> get - let ctx = [ (ident, ty') | ((mn, ident@Ident{}), (ty', _, Defined)) <- env, mn == moduleName ] + ctx <- getLocalContext tell . errorMessage $ HoleInferredType name ty ctx return $ TypedValue True (Hole name) ty infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do @@ -351,20 +341,19 @@ inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue Just moduleName <- checkCurrentModule <$> get (kind, args) <- kindOfWithScopedVars ty checkTypeKind ty kind - let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined) + let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined) ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv - bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j + bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do valTy <- freshType - Just moduleName <- checkCurrentModule <$> get - let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined) + let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined) TypedValue _ val' valTy' <- bindNames dict $ infer val unifyTypes valTy valTy' - bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j + bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do Just moduleName <- checkCurrentModule <$> get - (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds) + (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup Nothing (map (\(i, _, v) -> (i, v)) ds) ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] @@ -483,9 +472,8 @@ checkBinders _ _ [] = return [] checkBinders nvals ret (CaseAlternative binders result : bs) = do guardWith (errorMessage $ OverlappingArgNames Nothing) $ let ns = concatMap binderNames binders in length (nub ns) == length ns - Just moduleName <- checkCurrentModule <$> get m1 <- M.unions <$> zipWithM inferBinder nvals binders - r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ + r <- bindLocalVariables [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ CaseAlternative binders <$> case result of Left gs -> do @@ -577,8 +565,7 @@ check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do return $ TypedValue True array t check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do unifyTypes t tyFunction - Just moduleName <- checkCurrentModule <$> get - ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy + ret' <- withBindingGroupVisible $ bindLocalVariables [(arg, argTy, Defined)] $ check ret retTy return $ TypedValue True (Abs (Left arg) ret') ty check' (Abs (Right _) _) _ = internalError "Binder was not desugared" check' (App f arg) ret = do @@ -586,9 +573,8 @@ check' (App f arg) ret = do (_, app) <- checkFunctionApplication f' ft arg (Just ret) return $ TypedValue True app ret check' v@(Var var) ty = do - Just moduleName <- checkCurrentModule <$> get - checkVisibility moduleName var - repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var + checkVisibility var + repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty v' <- subsumes (Just v) repl ty' case v' of diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index e9fc8131dd..86e2c0a1c2 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -112,9 +112,11 @@ unifyTypes t1 t2 = do unifyTypes' r1 r2@RCons{} = unifyRows r1 r2 unifyTypes' r1@REmpty r2 = unifyRows r1 r2 unifyTypes' r1 r2@REmpty = unifyRows r1 r2 - unifyTypes' ty1@(ConstrainedType _ _) ty2 = throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2 + unifyTypes' ty1@(ConstrainedType _ _) ty2 = + throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2 unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3 - unifyTypes' t3 t4 = throwError . errorMessage $ TypesDoNotUnify t3 t4 + unifyTypes' t3 t4 = + throwError . errorMessage $ TypesDoNotUnify t3 t4 -- | -- Unify two rows, updating the current substitution @@ -147,7 +149,8 @@ unifyRows r1 r2 = unifyRows' [] REmpty [] REmpty = return () unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return () unifyRows' [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = return () - unifyRows' _ _ _ _ = throwError . errorMessage $ TypesDoNotUnify r1 r2 + unifyRows' _ _ _ _ = + throwError . errorMessage $ TypesDoNotUnify r1 r2 -- | -- Check that two types unify @@ -195,7 +198,8 @@ replaceTypeWildcards = everywhereOnTypesM replace where replace (TypeWildcard ss) = do t <- freshType - warnWithPosition ss $ tell . errorMessage $ WildcardInferredType t + ctx <- getLocalContext + warnWithPosition ss $ tell . errorMessage $ WildcardInferredType t ctx return t replace other = return other From 2d6087d26d963d99b217ca1de1b18d827f1805b1 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 31 Jul 2016 16:15:33 -0700 Subject: [PATCH 0469/1580] Fix #2252, instantiate types in array literals before unification (#2258) * Fix #2252, instantiate types in array literals before unification * Use @garyb's test --- examples/passing/2252.purs | 15 +++++++++++++++ src/Language/PureScript/TypeChecker/Types.hs | 7 +++++-- 2 files changed, 20 insertions(+), 2 deletions(-) create mode 100644 examples/passing/2252.purs diff --git a/examples/passing/2252.purs b/examples/passing/2252.purs new file mode 100644 index 0000000000..a69c517797 --- /dev/null +++ b/examples/passing/2252.purs @@ -0,0 +1,15 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +data T a = T + +ti :: T Int +ti = T + +t :: forall a. T a +t = T + +xs = [ti, t, t] + +main = log "Done" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index c396409320..0804db3525 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -245,8 +245,11 @@ infer' v@(Literal (BooleanLiteral _)) = return $ TypedValue True v tyBoolean infer' (Literal (ArrayLiteral vals)) = do ts <- traverse infer vals els <- freshType - forM_ ts $ \(TypedValue _ _ t) -> unifyTypes els t - return $ TypedValue True (Literal (ArrayLiteral ts)) (TypeApp tyArray els) + ts' <- forM ts $ \(TypedValue ch val t) -> do + (val', t') <- instantiatePolyTypeWithUnknowns val t + unifyTypes els t' + return (TypedValue ch val' t') + return $ TypedValue True (Literal (ArrayLiteral ts')) (TypeApp tyArray els) infer' (Literal (ObjectLiteral ps)) = do ensureNoDuplicateProperties ps ts <- traverse (infer . snd) ps From 6f6e594f27e9afb2ac903001dfc42d97dfb6908f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 31 Jul 2016 16:56:28 -0700 Subject: [PATCH 0470/1580] 0.9.3 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index c5a76d1912..14c70e81a7 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.9.2 +version: 0.9.3 cabal-version: >=1.8 build-type: Simple license: MIT From 275988042a89d98b2a40329d6415e1df84d9d8af Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Thu, 11 Aug 2016 15:52:52 +0200 Subject: [PATCH 0471/1580] fixes kRITZCREEK/pscid#20 --- src/Language/PureScript/Ide/Rebuild.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index f543dbb985..f9b9d18e6c 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -144,7 +144,8 @@ sortExterns m ex = do . M.elems . M.delete (P.getModuleName m) $ ex case sorted' of - Left _ -> throwError (GeneralError "There was a cycle in the dependencies") + Left err -> + throwError (RebuildError (toJSONErrors False P.Error err)) Right (sorted, graph) -> do let deps = fromJust (List.lookup (P.getModuleName m) graph) pure $ mapMaybe getExtern (deps `inOrderOf` map P.getModuleName sorted) From 05d53b2887558a182896b63868f10c3692f527d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=A9mi=20Vion?= Date: Sun, 14 Aug 2016 05:58:44 +0200 Subject: [PATCH 0472/1580] remove legacy ObjectGetter and update doc (#2262) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * remove legacy ObjectGetter and update doc * fix typo in record property accessor AST documentation * add myself (Rémi Vion, @rvion on github) to CONTRIBUTORS.md I also took the liberty to 1. remove the extra - in front of the @felixSchl notice 2. sort lines --- CONTRIBUTORS.md | 9 +++++---- src/Language/PureScript/AST/Declarations.hs | 9 +++------ src/Language/PureScript/Pretty/Values.hs | 2 -- 3 files changed, 8 insertions(+), 12 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 51c350638f..69e47b5a9f 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -12,7 +12,9 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@bagl](https://github.com/bagl) (Petr Vapenka) My existing contributions and all future contributions until further notice are Copyright Petr Vapenka, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@balajirrao](https://github.com/balajirrao) (Balaji Rao) - My existing contributions and all future contributions until further notice are Copyright Balaji Rao, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@bergmark](https://github.com/bergmark) (Adam Bergmark) - My existing contributions and all future contributions until further notice are Copyright Adam Bergmark, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. +- [@bmjames](https://github.com/bmjames) (Ben James) My existing contributions and all future contributions until further notice are Copyright Ben James, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@Bogdanp](https://github.com/Bogdanp) (Bogdan Paul Popa) My existing contributions and all future contributions until further notice are Copyright Bogdan Paul Popa, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@cdepillabout](https://github.com/cdepillabout) (Dennis Gosnell) My existing contributions and all future contributions until further notice are Copyright Dennis Gosnell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@chrissmoak](https://github.com/chrissmoak) (Chris Smoak) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). @@ -25,6 +27,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@erdeszt](https://github.com/erdeszt) (Tibor Erdesz) My existing contributions and all future contributions until further notice are Copyright Tibor Erdesz, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@etrepum](https://github.com/etrepum) (Bob Ippolito) My existing contributions and all future contributions until further notice are Copyright Bob Ippolito, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@faineance](https://github.com/faineance) My existing contributions and all future contributions until further notice are Copyright faineance, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@felixSchl](https://github.com/felixSchl) (Felix Schlitter) My existing contributions and all future contributions until further notice are Copyright Felix Schlitter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@ilovezfs](https://github.com/ilovezfs) - My existing contributions and all future contributions until further notice are Copyright ilovezfs, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license @@ -36,6 +39,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@kRITZCREEK](https://github.com/kRITZCREEK) (Christoph Hegemann) - My existing contributions and all future contributions until further notice are Copyright Christoph Hegemann, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@L8D](https://github.com/L8D) (Tenor Biel) My existing contributions and all future contributions until further notice are Copyright Tenor Biel, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@leighman](http://github.com/leighman) (Jack Leigh) My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@lukerandall](https://github.com/lukerandall) (Luke Randall) My existing contributions and all future contributions until further notice are Copyright Luke Randall, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@mgmeier](https://github.com/mgmeier) (Michael Karg) My existing contributions and all future contributions until further notice are Copyright Michael Gilliland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@michaelficarra](https://github.com/michaelficarra) (Michael Ficarra) My existing contributions and all future contributions until further notice are Copyright Michael Ficarra, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). @@ -59,6 +63,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@puffnfresh](https://github.com/puffnfresh) (Brian McKenna) All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler. - [@robdaemon](https://github.com/robdaemon) (Robert Roland) My existing contributions and all future contributions until further notice are Copyright Robert Roland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@RossMeikleham](https://github.com/RossMeikleham) (Ross Meikleham) My existing contributions and all future contributions until further notice are Copyright Ross Meikleham, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@rvion](https://github.com/rvion) (Rémi Vion) My existing contributions and all future contributions until further notice are Copyright Rémi Vion, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@sebastiaanvisser](https://github.com/sebastiaanvisser) (Sebastiaan Visser) - My existing contributions and all future contributions until further notice are Copyright Sebastiaan Visser, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@sharkdp](https://github.com/sharkdp) (David Peter) My existing contributions and all future contributions until further notice are Copyright David Peter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). @@ -70,10 +75,6 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@bmjames](https://github.com/bmjames) (Ben James) My existing contributions and all future contributions until further notice are Copyright Ben James, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- - [@felixSchl](https://github.com/felixSchl) (Felix Schlitter) My existing contributions and all future contributions until further notice are Copyright Felix Schlitter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index a9ba39ef3f..273c232aad 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -497,12 +497,9 @@ data Expr -- | Parens Expr -- | - -- A record property getter (e.g. `_.x`). This will be removed during - -- desugaring and expanded into a lambda that reads a property from a record. - -- - | ObjectGetter String - -- | - -- An record property accessor expression + -- An record property accessor expression (e.g. `obj.x` or `_.x`). + -- Anonymous arguments will be removed during desugaring and expanded + -- into a lambda that reads a property from a record. -- | Accessor String Expr -- | diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 6a8ea61e75..549fbe9ecb 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -75,7 +75,6 @@ prettyPrintValue d expr@Op{} = prettyPrintValueAtom d expr prettyPrintValue d expr@BinaryNoParens{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Parens{} = prettyPrintValueAtom d expr prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr -prettyPrintValue d expr@ObjectGetter{} = prettyPrintValueAtom d expr -- | Pretty-print an atomic expression, adding parentheses if necessary. prettyPrintValueAtom :: Int -> Expr -> Box @@ -92,7 +91,6 @@ prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val prettyPrintValueAtom d (Parens expr) = (text "(" <> prettyPrintValue d expr) `before` text ")" prettyPrintValueAtom d (UnaryMinus expr) = text "(-" <> prettyPrintValue d expr <> text ")" -prettyPrintValueAtom _ (ObjectGetter field) = text "_." <> text field prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")" prettyPrintLiteralValue :: Int -> Literal Expr -> Box From dcf2c58b2bfeea3c2f28249c223e6233aeb552c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=A9mi=20Vion?= Date: Sun, 14 Aug 2016 05:59:52 +0200 Subject: [PATCH 0473/1580] gitignore .psc-ide-port globally (#2261) --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 0047b5c8f6..21d3d65b18 100644 --- a/.gitignore +++ b/.gitignore @@ -17,3 +17,4 @@ tmp/ output examples/docs/docs/ core-tests/full-core-docs.md +.psc-ide-port From 9b34d87d4428c2f76613ae128ec9363334cbdf63 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 14 Aug 2016 07:01:21 +0300 Subject: [PATCH 0474/1580] Support aeson-1 (#2268) --- purescript.cabal | 6 +++--- stack.yaml | 10 +++++++--- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 14c70e81a7..f8e78c92f7 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -100,7 +100,7 @@ source-repository head library build-depends: base >=4.8 && <5, - aeson >= 0.8 && < 0.12, + aeson >= 0.8 && < 1.1, aeson-better-errors >= 0.8, ansi-terminal >= 0.6.2 && < 0.7, base-compat >=0.6.0, @@ -315,7 +315,7 @@ library executable psc build-depends: base >=4 && <5, purescript -any, - aeson >= 0.8 && < 0.12, + aeson >= 0.8 && < 1.1, ansi-terminal >= 0.6.2 && < 0.7, base-compat >=0.6.0, bytestring -any, @@ -440,7 +440,7 @@ executable psc-ide-server other-modules: Paths_purescript other-extensions: build-depends: base >=4 && <5, - aeson >= 0.8 && < 0.12, + aeson >= 0.8 && < 1.1, bytestring -any, purescript -any, base-compat >=0.6.0, diff --git a/stack.yaml b/stack.yaml index e40e931d12..8ba748eba2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,9 @@ -resolver: lts-6.9 +resolver: lts-6.10 packages: - '.' -extra-deps: [] -flags: {} +extra-deps: +- aeson-1.0.0.0 +- semigroups-0.18.2 +flags: + semigroups: + bytestring-builder: false From 029c4d9d06e5316f905639dac3b853cb2364e972 Mon Sep 17 00:00:00 2001 From: "Ian D. Bollinger" Date: Mon, 15 Aug 2016 00:54:31 -0400 Subject: [PATCH 0475/1580] Fixes Language.PureScript.Types.everywhereOnTypesTopDown The function everywhereOnTypesTopDown didn't work consistently over parenthesized and binary operator types. This can be seen in the type signature here: https://pursuit.purescript.org/packages/purescript-day/6.0.0/docs/Data.Functor.Day#v:runDay --- CONTRIBUTORS.md | 1 + examples/docs/src/ExplicitTypeSignatures.purs | 2 ++ src/Language/PureScript/Types.hs | 4 ++-- tests/TestDocs.hs | 1 + 4 files changed, 6 insertions(+), 2 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 69e47b5a9f..4cf10c5dab 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -30,6 +30,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@felixSchl](https://github.com/felixSchl) (Felix Schlitter) My existing contributions and all future contributions until further notice are Copyright Felix Schlitter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@ianbollinger](https://github.com/ianbollinger) (Ian D. Bollinger) My existing contributions and all future contributions until further notice are Copyright Ian D. Bollinger, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@ilovezfs](https://github.com/ilovezfs) - My existing contributions and all future contributions until further notice are Copyright ilovezfs, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license - [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). diff --git a/examples/docs/src/ExplicitTypeSignatures.purs b/examples/docs/src/ExplicitTypeSignatures.purs index 396ca1447c..f9fa06f40a 100644 --- a/examples/docs/src/ExplicitTypeSignatures.purs +++ b/examples/docs/src/ExplicitTypeSignatures.purs @@ -14,3 +14,5 @@ anInt = 0 -- This should infer a type. aNumber = 1.0 + +foreign import nestedForAll :: forall c. (forall a b. c) diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index f9d7a60807..a38300c7bb 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -257,8 +257,8 @@ everywhereOnTypesTopDown f = go . f go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2)) go (PrettyPrintObject t) = PrettyPrintObject (go (f t)) go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t)) - go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (f (go t1)) (f (go t2)) (f (go t3)) - go (ParensInType t) = ParensInType (f (go t)) + go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go (f t1)) (go (f t2)) (go (f t3)) + go (ParensInType t) = ParensInType (go (f t)) go other = f other everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 6a645c159a..1d56293527 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -278,6 +278,7 @@ testCases = [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something")) , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==)) , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==)) + , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "nestedForAll" (renderedType "forall c. (forall a b. c)") ]) , ("ConstrainedArgument", From 8dab1e848ec97da3d0c4068507dd5e408e95cc45 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Tue, 16 Aug 2016 07:44:27 +0200 Subject: [PATCH 0476/1580] Improved error messages for record subsumption (#2271) * Improved error messages for record subsumption * Added myself to contributors * Improved efficiency of finding missing/additional properties * Tidied up implementation and added data-ordlist to deps * Improved error messages for record subsumption * Added myself to contributors * Improved efficiency of finding missing/additional properties * Tidied up implementation and added data-ordlist to deps * Added some comments and regenerated license --- CONTRIBUTORS.md | 1 + LICENSE | 910 ++++++++++++++++-- purescript.cabal | 1 + .../PureScript/TypeChecker/Subsumption.hs | 25 +- 4 files changed, 829 insertions(+), 108 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 4cf10c5dab..797c6cd321 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -28,6 +28,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@etrepum](https://github.com/etrepum) (Bob Ippolito) My existing contributions and all future contributions until further notice are Copyright Bob Ippolito, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@faineance](https://github.com/faineance) My existing contributions and all future contributions until further notice are Copyright faineance, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@felixSchl](https://github.com/felixSchl) (Felix Schlitter) My existing contributions and all future contributions until further notice are Copyright Felix Schlitter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@FrigoEU](https://github.com/FrigoEU) (Simon Van Casteren) My existing contributions and all future contributions until further notice are Copyright Simon Van Casteren, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@ianbollinger](https://github.com/ianbollinger) (Ian D. Bollinger) My existing contributions and all future contributions until further notice are Copyright Ian D. Bollinger, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). diff --git a/LICENSE b/LICENSE index e6ad9e7178..d05ff61778 100644 --- a/LICENSE +++ b/LICENSE @@ -23,10 +23,13 @@ CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. PureScript uses the following Haskell library packages. Their license files follow. Glob + SHA aeson aeson-better-errors + aeson-pretty ansi-terminal ansi-wl-pprint + appar array asn1-encoding asn1-parse @@ -39,14 +42,18 @@ PureScript uses the following Haskell library packages. Their license files foll base64-bytestring binary blaze-builder + blaze-html + blaze-markup bower-json boxes byteable + byteorder bytestring bytestring-builder case-insensitive cereal clock + cmdargs conduit conduit-extra connection @@ -54,25 +61,32 @@ PureScript uses the following Haskell library packages. Their license files foll cookie cryptonite data-default-class + data-ordlist deepseq directory dlist easy-file edit-distance + entropy exceptions fail fast-logger + file-embed filepath fsnotify ghc-prim hashable haskeline - hinotify + hex + hfsevents hourglass http-client http-client-tls + http-date http-types + http2 integer-gmp + iproute language-javascript lifted-base memory @@ -96,6 +110,7 @@ PureScript uses the following Haskell library packages. Their license files foll primitive process protolude + psqueues random regex-base regex-tdfa @@ -103,6 +118,7 @@ PureScript uses the following Haskell library packages. Their license files foll safe scientific semigroups + simple-sendfile socks sourcemap spdx @@ -110,13 +126,14 @@ PureScript uses the following Haskell library packages. Their license files foll stm stm-chans streaming-commons - string-conv + stringsearch syb tagged template-haskell terminfo text time + time-locale-compat tls transformers transformers-base @@ -126,8 +143,17 @@ PureScript uses the following Haskell library packages. Their license files foll unix-time unordered-containers utf8-string + vault vector void + wai + wai-app-static + wai-extra + wai-logger + wai-websockets + warp + websockets + word8 x509 x509-store x509-system @@ -140,7 +166,7 @@ Glob LICENSE file: the code are held by whoever wrote the code in question: see CREDITS.txt for a list of authors. - Copyright (c) 2008-2012 + Copyright (c) 2008-2016 All rights reserved. Redistribution and use in source and binary forms, with or without @@ -165,6 +191,38 @@ Glob LICENSE file: OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +SHA LICENSE file: + + Copyright (c) 2008, Galois, Inc. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the Galois, Inc. nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + aeson LICENSE file: Copyright (c) 2011, MailRank, Inc. @@ -221,6 +279,39 @@ aeson-better-errors LICENSE file: TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +aeson-pretty LICENSE file: + + Copyright (c)2011, Falko Peters + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Falko Peters nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ansi-terminal LICENSE file: Copyright (c) 2008, Maximilian Bolingbroke @@ -274,6 +365,38 @@ ansi-wl-pprint LICENSE file: or otherwise) arising in any way out of the use of this software, even if advised of the possibility of such damage. +appar LICENSE file: + + Copyright (c) 2009, IIJ Innovation Institute Inc. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + array LICENSE file: This library (libraries/base) is derived from code from several @@ -746,6 +869,72 @@ blaze-builder LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +blaze-html LICENSE file: + + Copyright Jasper Van der Jeugt 2010 + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jasper Van der Jeugt nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +blaze-markup LICENSE file: + + Copyright Jasper Van der Jeugt 2010 + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jasper Van der Jeugt nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + bower-json LICENSE file: Copyright (c) 2015 Harry Garrood @@ -829,6 +1018,39 @@ byteable LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +byteorder LICENSE file: + + Copyright 2009, Antoine Latter + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the author nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + bytestring LICENSE file: Copyright (c) Don Stewart 2005-2009 @@ -997,6 +1219,39 @@ clock LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +cmdargs LICENSE file: + + Copyright Neil Mitchell 2009-2016. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Neil Mitchell nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + conduit LICENSE file: Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ @@ -1109,31 +1364,26 @@ containers LICENSE file: cookie LICENSE file: - The following license covers this documentation, and the source code, except - where otherwise indicated. - - Copyright 2010, Michael Snoyman. All rights reserved. + Copyright (c) 2010 Michael Snoyman, http://www.yesodweb.com/ - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF - MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO - EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT - NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, - OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE - OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF - ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. cryptonite LICENSE file: @@ -1195,13 +1445,26 @@ data-default-class LICENSE file: OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -deepseq LICENSE file: +data-ordlist LICENSE file: - This library (deepseq) is derived from code from the GHC project which - is largely (c) The University of Glasgow, and distributable under a - BSD-style license (see below). + Copyright (c) 2009-2010, Melding Monads + All rights reserved. - ----------------------------------------------------------------------------- + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + * Neither the name of Melding Monads nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +deepseq LICENSE file: + + This library (deepseq) is derived from code from the GHC project which + is largely (c) The University of Glasgow, and distributable under a + BSD-style license (see below). + + ----------------------------------------------------------------------------- The Glasgow Haskell Compiler License @@ -1305,7 +1568,7 @@ directory LICENSE file: dlist LICENSE file: - Copyright (c) 2006-2009 Don Stewart, 2013-2014 Sean Leather + Copyright (c) 2006-2009 Don Stewart, 2013-2016 Sean Leather All rights reserved. @@ -1394,6 +1657,39 @@ edit-distance LICENSE file: IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +entropy LICENSE file: + + Copyright (c) Thomas DuBuisson + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + exceptions LICENSE file: Copyright 2013-2015 Edward Kmett @@ -1493,6 +1789,34 @@ fast-logger LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +file-embed LICENSE file: + + The following license covers this documentation, and the source code, except + where otherwise indicated. + + Copyright 2008, Michael Snoyman. All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO + EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, + OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE + OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + filepath LICENSE file: Copyright Neil Mitchell 2005-2015. @@ -1683,38 +2007,42 @@ haskeline LICENSE file: OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -hinotify LICENSE file: +hex LICENSE file: - Copyright (c) Lennart Kolmodin + Page not found: Sorry, it's just not here. + +hfsevents LICENSE file: + + Copyright (c) 2012, Luite Stegeman All rights reserved. Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: + modification, are permitted provided that the following conditions are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + * Neither the name of Luite Stegeman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS - OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hourglass LICENSE file: @@ -1792,6 +2120,38 @@ http-client-tls LICENSE file: IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +http-date LICENSE file: + + Copyright (c) 2009, IIJ Innovation Institute Inc. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + http-types LICENSE file: Copyright (c) 2011, Aristid Breitkreuz @@ -1826,6 +2186,38 @@ http-types LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +http2 LICENSE file: + + Copyright (c) 2013, IIJ Innovation Institute Inc. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + integer-gmp LICENSE file: Copyright (c) 2014, Herbert Valerio Riedel @@ -1859,6 +2251,38 @@ integer-gmp LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +iproute LICENSE file: + + Copyright (c) 2009, IIJ Innovation Institute Inc. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + language-javascript LICENSE file: Copyright (c)2010, Alan Zimmerman @@ -2622,6 +3046,40 @@ protolude LICENSE file: FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +psqueues LICENSE file: + + The Glasgow Haskell Compiler License + + Copyright 2004, The University Court of the University of Glasgow. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. + random LICENSE file: This library (libraries/base) is derived from code from two @@ -2846,28 +3304,60 @@ semigroups LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -socks LICENSE file: - - Copyright (c) 2010-2011 Vincent Hanquez +simple-sendfile LICENSE file: + Copyright (c) 2009, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + +socks LICENSE file: + + Copyright (c) 2010-2011 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) @@ -3068,38 +3558,9 @@ streaming-commons LICENSE file: OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -string-conv LICENSE file: - - Copyright (c) 2012, Ozgun Ataman - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Ozgun Ataman nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. +stringsearch LICENSE file: - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + Page not found: Sorry, it's just not here. syb LICENSE file: @@ -3324,6 +3785,39 @@ time LICENSE file: THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +time-locale-compat LICENSE file: + + Copyright (c) 2014, Kei Hibino + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Kei Hibino nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + tls LICENSE file: Copyright (c) 2010-2015 Vincent Hanquez @@ -3609,6 +4103,39 @@ utf8-string LICENSE file: * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +vault LICENSE file: + + Copyright (c)2011, Heinrich Apfelmus + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Heinrich Apfelmus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + vector LICENSE file: Copyright (c) 2008-2012, Roman Leshchinskiy @@ -3675,6 +4202,189 @@ void LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +wai LICENSE file: + + Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +wai-app-static LICENSE file: + + Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +wai-extra LICENSE file: + + Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +wai-logger LICENSE file: + + Copyright (c) 2009, IIJ Innovation Institute Inc. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + +wai-websockets LICENSE file: + + Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +warp LICENSE file: + + Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +websockets LICENSE file: + + Page not found: Sorry, it's just not here. + +word8 LICENSE file: + + Copyright (c) 2012, IIJ Innovation Institute Inc. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + x509 LICENSE file: Copyright (c) 2010-2013 Vincent Hanquez diff --git a/purescript.cabal b/purescript.cabal index f8e78c92f7..71fee5df61 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -109,6 +109,7 @@ library bytestring -any, containers -any, clock -any, + data-ordlist >= 0.4.7.0, directory >= 1.2, dlist -any, edit-distance -any, diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 148ca45cee..c5dfecb2a3 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -7,10 +7,13 @@ module Language.PureScript.TypeChecker.Subsumption import Prelude.Compat +import Control.Monad (when) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets) -import Data.List (sortBy) +import Data.Foldable (for_) +import Data.List (sortBy, uncons) +import Data.List.Ordered (minusBy') import Data.Ord (comparing) import Language.PureScript.AST @@ -26,7 +29,7 @@ import Language.PureScript.Types subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr) subsumes val ty1 ty2 = withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ subsumes' val ty1 ty2 --- | Check tahat one type subsumes another +-- | Check that one type subsumes another subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> @@ -60,6 +63,14 @@ subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord (ts2, r2') = rowToList r2 ts1' = sortBy (comparing fst) ts1 ts2' = sortBy (comparing fst) ts2 + -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row), + -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property. + -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has + -- an additional property which is not allowed. + when (r1' == REmpty) + (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst)) + when (r2' == REmpty) + (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst)) go ts1' ts2' r1' r2' return val where @@ -72,15 +83,13 @@ subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord -- What happens next is a bit of a hack. -- TODO: in the new type checker, object properties will probably be restricted to being monotypes -- in which case, this branch of the subsumes function should not even be necessary. - case r2' of - REmpty -> throwError . errorMessage $ AdditionalProperty p1 - _ -> unifyTypes r2' (RCons p1 ty1 rest) + unifyTypes r2' (RCons p1 ty1 rest) go ts1 ((p2, ty2) : ts2) r1' rest | otherwise = do rest <- freshType - case r1' of - REmpty -> throwError . errorMessage $ PropertyIsMissing p2 - _ -> unifyTypes r1' (RCons p2 ty2 rest) + unifyTypes r1' (RCons p2 ty2 rest) go ((p1, ty1) : ts1) ts2 rest r2' + -- Find the first property that's in the first list (of tuples) but not in the second + firstMissingProp t1 t2 = fst <$> (uncons $ minusBy' (comparing fst) t1 t2) subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyRecord = subsumes val ty2 ty1 subsumes' val ty1 ty2 = do unifyTypes ty1 ty2 From 0b07beb08d68b3ae1c77d645f85ef681cc260b9d Mon Sep 17 00:00:00 2001 From: "Ian D. Bollinger" Date: Wed, 17 Aug 2016 18:23:49 -0400 Subject: [PATCH 0477/1580] Fix most HLint warnings This leaves in place 10 warnings, mostly for reducing duplication. --- hierarchy/Main.hs | 2 +- psc/Main.hs | 8 ++++---- psci/Main.hs | 6 +++--- src/Language/PureScript/Bundle.hs | 10 +++++----- src/Language/PureScript/CodeGen/JS.hs | 2 +- src/Language/PureScript/Ide/Reexports.hs | 2 -- src/Language/PureScript/Ide/State.hs | 2 +- src/Language/PureScript/Ide/Util.hs | 2 +- .../PureScript/Interactive/Completion.hs | 2 +- src/Language/PureScript/Interactive/Printer.hs | 2 +- src/Language/PureScript/Interactive/Types.hs | 4 ++-- src/Language/PureScript/Pretty/Common.hs | 2 +- .../PureScript/Publish/ErrorsWarnings.hs | 16 ++++++++-------- src/Language/PureScript/Renamer.hs | 6 +++--- src/Language/PureScript/Sugar/ObjectWildcards.hs | 2 +- .../PureScript/Sugar/Operators/Common.hs | 4 ++-- src/Language/PureScript/Sugar/Operators/Expr.hs | 2 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 2 +- src/Language/PureScript/TypeChecker/Monad.hs | 2 +- .../PureScript/TypeChecker/Subsumption.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 2 +- tests/Language/PureScript/Ide/ReexportsSpec.hs | 2 +- .../PureScript/Ide/SourceFile/IntegrationSpec.hs | 16 ++++++++-------- tests/Language/PureScript/Ide/SourceFileSpec.hs | 2 +- tests/TestPsci.hs | 1 - 25 files changed, 50 insertions(+), 53 deletions(-) diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs index a6d7b07c57..5857dd4c07 100644 --- a/hierarchy/Main.hs +++ b/hierarchy/Main.hs @@ -40,7 +40,7 @@ data HierarchyOptions = HierarchyOptions , hierarchyOutput :: Maybe FilePath } -newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) ((P.ProperName 'P.ClassName), (P.ProperName 'P.ClassName)) } +newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) (P.ProperName 'P.ClassName, P.ProperName 'P.ClassName) } deriving Eq instance Show SuperMap where diff --git a/psc/Main.hs b/psc/Main.hs index e99c13e141..457ce59464 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -79,11 +79,11 @@ warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath] globWarningOnMisses warn = concatMapM globWithWarning where - globWithWarning pattern = do - paths <- glob pattern - when (null paths) $ warn pattern + globWithWarning pattern' = do + paths <- glob pattern' + when (null paths) $ warn pattern' return paths - concatMapM f = liftM concat . mapM f + concatMapM f = fmap concat . mapM f readInput :: [FilePath] -> IO [(FilePath, String)] readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8File inFile diff --git a/psci/Main.hs b/psci/Main.hs index 8dc6c9d5df..9bd309633a 100644 --- a/psci/Main.hs +++ b/psci/Main.hs @@ -207,7 +207,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown -- With many connected clients, all but one of -- these attempts will fail. tryPutMVar resultVar (unpack result) - Reload -> do + Reload -> WS.sendTextData conn ("reload" :: Text) shutdownHandler :: IO () -> IO () @@ -278,7 +278,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown Left err -> do putStrLn (unlines (Bundle.printErrorMessage err)) exitFailure - Right js -> do + Right js -> atomically $ writeTVar (browserBundleJS state) (Just js) reload :: BrowserState -> IO () @@ -335,7 +335,7 @@ main = getOpt >>= loop (externs, env) <- ExceptT . runMake . make $ modules return (modules, externs, env) case psciBackend of - Backend setup eval reload (shutdown :: state -> IO ()) -> do + Backend setup eval reload (shutdown :: state -> IO ()) -> case e of Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure Right (modules, externs, env) -> do diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 1d9406650f..550dbaf6b1 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -256,7 +256,7 @@ toModule mids mid top = pure (Member stmt exported name decl []) toModuleElement stmt | Just props <- matchExportsAssignment stmt - = (ExportsList <$> traverse toExport (trailingCommaList props)) + = ExportsList <$> traverse toExport (trailingCommaList props) where toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key]) toExport (JSPropertyNameandValue name _ [val]) = @@ -524,7 +524,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p indent :: [JSStatement] -> [JSStatement] indent = everywhere (mkT squash) where - squash JSNoAnnot = (JSAnnot (TokenPn 0 0 2) []) + squash JSNoAnnot = JSAnnot (TokenPn 0 0 2) [] squash (JSAnnot pos ann) = JSAnnot (keepCol pos) (map splat ann) splat (CommentA pos s) = CommentA (keepCol pos) s @@ -571,15 +571,15 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p (JSSemi JSNoAnnot) ] where - lfHead (h:t) = (addAnn (WhiteSpace tokenPosnEmpty "\n ") h) : t + lfHead (h:t) = addAnn (WhiteSpace tokenPosnEmpty "\n ") h : t lfHead x = x addAnn :: CommentAnnotation -> JSStatement -> JSStatement addAnn a (JSExpressionStatement (JSStringLiteral ann s) _) = - (JSExpressionStatement (JSStringLiteral (appendAnn a ann) s) (JSSemi JSNoAnnot)) + JSExpressionStatement (JSStringLiteral (appendAnn a ann) s) (JSSemi JSNoAnnot) addAnn _ x = x - appendAnn a JSNoAnnot = (JSAnnot tokenPosnEmpty [a]) + appendAnn a JSNoAnnot = JSAnnot tokenPosnEmpty [a] appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty " "]) runMain :: String -> [JSStatement] diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index ba682c1af1..f48d928c56 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -367,7 +367,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- binder. -- binderToJs' :: String -> [JS] -> Binder Ann -> m [JS] - binderToJs' _ done (NullBinder{}) = return done + binderToJs' _ done NullBinder{} = return done binderToJs' varName done (LiteralBinder _ l) = literalToBinderJS varName done l binderToJs' varName done (VarBinder _ ident) = diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 807f3d791e..5fa124127a 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -14,8 +14,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} module Language.PureScript.Ide.Reexports diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 55b225537e..04038d21bc 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -180,7 +180,7 @@ populateStage2 = do populateStage2STM :: TVar IdeState -> STM () populateStage2STM ref = do modules <- s1Modules <$> getStage1STM ref - let spans = map (\((P.Module ss _ _ decls _), _) -> M.fromList (concatMap (extractSpans ss) decls)) modules + let spans = map (\(P.Module ss _ _ decls _, _) -> M.fromList (concatMap (extractSpans ss) decls)) modules setStage2STM ref (Stage2 (AstData spans)) -- | Resolves reexports and populates Stage3 with data to be used in queries. diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 548e1f419d..9dd0c79f8a 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -75,7 +75,7 @@ completionFromMatch' (Match (m', d)) = case d of in T.unwords [asso, show p, r, "as", runOpNameT o] infoFromMatch :: Match IdeDeclarationAnn -> Info -infoFromMatch (Match (m, (IdeDeclarationAnn ann d))) = +infoFromMatch (Match (m, IdeDeclarationAnn ann d)) = Info (a, b, c, annLocation ann) where (a, b, c) = completionFromMatch' (Match (m, d)) diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index c332f05f7c..870501576a 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -214,7 +214,7 @@ dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)] dctorNames = nubOnFst . concatMap go . P.exportedDeclarations where go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)] - go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors) + go decl@(P.DataDeclaration _ _ _ ctors) = map ((\n -> (n, decl)) . fst) ctors go (P.PositionedDeclaration _ _ d) = go d go _ = [] diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index 9f3352294e..22990b7473 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -17,7 +17,7 @@ import qualified Text.PrettyPrint.Boxes as Box -- Pretty print a module's signatures -- printModuleSignatures :: P.ModuleName -> P.Environment -> String -printModuleSignatures moduleName (P.Environment {..}) = +printModuleSignatures moduleName P.Environment{..} = -- get relevant components of a module from environment let moduleNamesIdent = byModuleName names moduleTypeClasses = byModuleName typeClasses diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index deae8c6f80..f2449dfb89 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -42,11 +42,11 @@ initialPSCiState = PSCiState [] [] [] type ImportedModule = (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName) psciImportedModuleNames :: PSCiState -> [P.ModuleName] -psciImportedModuleNames (PSCiState{psciImportedModules = is}) = +psciImportedModuleNames PSCiState{psciImportedModules = is} = map (\(mn, _, _) -> mn) is allImportsOf :: P.Module -> PSCiState -> [ImportedModule] -allImportsOf m (PSCiState{psciImportedModules = is}) = +allImportsOf m PSCiState{psciImportedModules = is} = filter isImportOfThis is where name = P.getModuleName m diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index ea526caa87..2436a16d71 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -74,7 +74,7 @@ instance Emit StrPos where -- | -- Add a new mapping entry for given source position with initially zero generated position -- - addMapping (SourceSpan { spanName = file, spanStart = startPos }) = StrPos (zeroPos, mempty, [mapping]) + addMapping SourceSpan { spanName = file, spanStart = startPos } = StrPos (zeroPos, mempty, [mapping]) where mapping = SMap file startPos zeroPos zeroPos = SourcePos 0 0 diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index be5ebe5890..e1c8ed7b1b 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -182,10 +182,10 @@ displayUserError e = case e of , spacer ] ++ spdxExamples ++ [ spacer - , para (concat - [ "Note that distributing code without a license means that nobody " - , "will (legally) be able to use it." - ]) + , para ( + "Note that distributing code without a license means that nobody " + ++ "will (legally) be able to use it." + ) , spacer , para (concat [ "It is also recommended to add a LICENSE file to the repository, " @@ -420,10 +420,10 @@ warnUnacceptableVersions pkgs = warnDirtyWorkingTree :: Box warnDirtyWorkingTree = - para (concat - [ "Your working tree is dirty. (Note: this would be an error if it " - , "were not a dry run)" - ]) + para ( + "Your working tree is dirty. (Note: this would be an error if it " + ++ "were not a dry run)" + ) printWarnings :: [PackageWarning] -> IO () printWarnings = printToStderr . renderWarnings diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index 6ec0b34a78..7dfc873d05 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -142,7 +142,7 @@ renameInDecl isTopLevel (Rec ds) = do renameInValue :: Expr Ann -> Rename (Expr Ann) renameInValue (Literal ann l) = Literal ann <$> renameInLiteral renameInValue l -renameInValue c@(Constructor{}) = return c +renameInValue c@Constructor{} = return c renameInValue (Accessor ann prop v) = Accessor ann prop <$> renameInValue v renameInValue (ObjectUpdate ann obj vs) = @@ -154,7 +154,7 @@ renameInValue (App ann v1 v2) = App ann <$> renameInValue v1 <*> renameInValue v2 renameInValue (Var ann (Qualified Nothing name)) = Var ann . Qualified Nothing <$> lookupIdent name -renameInValue v@(Var{}) = return v +renameInValue v@Var{} = return v renameInValue (Case ann vs alts) = newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts renameInValue (Let ann ds v) = @@ -180,7 +180,7 @@ renameInCaseAlternative (CaseAlternative bs v) = newScope $ -- Renames within binders. -- renameInBinder :: Binder a -> Rename (Binder a) -renameInBinder n@(NullBinder{}) = return n +renameInBinder n@NullBinder{} = return n renameInBinder (LiteralBinder ann b) = LiteralBinder ann <$> renameInLiteral renameInBinder b renameInBinder (VarBinder ann name) = diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 23ac6b2d35..a8ad706a84 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -50,7 +50,7 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma return $ Abs (Left arg) (Accessor prop (argToExpr arg)) desugarExpr (Case args cas) | any isAnonymousArgument args = do argIdents <- forM args freshIfAnon - let args' = zipWith (\p -> maybe p argToExpr) args argIdents + let args' = zipWith (`maybe` argToExpr) args argIdents return $ foldr (Abs . Left) (Case args' cas) (catMaybes argIdents) desugarExpr (IfThenElse u t f) | any isAnonymousArgument [u, t, f] = do u' <- freshIfAnon u diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index 26ac5aef6b..dd0e43da4f 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -28,12 +28,12 @@ parseValue :: P.Parsec (Chain a) () a parseValue = token (either Just (const Nothing)) P. "expression" parseOp - :: (a -> (Maybe (Qualified (OpName nameType)))) + :: (a -> Maybe (Qualified (OpName nameType))) -> P.Parsec (Chain a) () (Qualified (OpName nameType)) parseOp fromOp = token (either (const Nothing) fromOp) P. "operator" matchOp - :: (a -> (Maybe (Qualified (OpName nameType)))) + :: (a -> Maybe (Qualified (OpName nameType))) -> Qualified (OpName nameType) -> P.Parsec (Chain a) () () matchOp fromOp op = do diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index f938406820..0c9c2b3c5a 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -28,7 +28,7 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable fromOp _ = Nothing reapply :: Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr - reapply op t1 t2 = App (App (Op op) t1) t2 + reapply op t1 = App (App (Op op) t1) modOpTable :: [[P.Operator (Chain Expr) () Identity Expr]] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index eef4a8582c..086d4ae18c 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -223,7 +223,7 @@ deriveGeneric mn ds tyConNm dargs = do $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs) mkRecFun :: [(String, Type)] -> Expr - mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs) + mkRecFun xs = mkJust $ foldr (lam . Ident . fst) recLiteral xs where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration" diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index b229ca3966..3a6e17bb96 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -245,7 +245,7 @@ getEnv = checkEnv <$> get getLocalContext :: MonadState CheckState m => m Context getLocalContext = do env <- getEnv - return [ (ident, ty') | ((Qualified Nothing ident@Ident{}), (ty', _, Defined)) <- M.toList (names env) ] + return [ (ident, ty') | (Qualified Nothing ident@Ident{}, (ty', _, Defined)) <- M.toList (names env) ] -- | Update the @Environment@ putEnv :: (MonadState CheckState m) => Environment -> m () diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index c5dfecb2a3..0db376700d 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -89,7 +89,7 @@ subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord unifyTypes r1' (RCons p2 ty2 rest) go ((p1, ty1) : ts1) ts2 rest r2' -- Find the first property that's in the first list (of tuples) but not in the second - firstMissingProp t1 t2 = fst <$> (uncons $ minusBy' (comparing fst) t1 t2) + firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing fst) t1 t2) subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyRecord = subsumes val ty2 ty1 subsumes' val ty1 ty2 = do unifyTypes ty1 ty2 diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 0804db3525..8a97bdb2c4 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -148,7 +148,7 @@ typeDictionaryForBindingGroup moduleName vals = do -- 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) -> ((Qualified moduleName ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict) + dict = M.fromList (map (\(ident, ty) -> (Qualified moduleName ident, (ty, Private, Undefined))) $ typedDict ++ untypedDict) return (untyped, typed, dict, untypedDict) checkTypedBindingGroupElement diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index c9a59ff26f..f0e03c4ae0 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.ReexportsSpec where -import qualified Prelude as Prelude +import qualified Prelude import Protolude import qualified Data.Map as Map diff --git a/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs b/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs index a16a9b5e95..66d3bb0d55 100644 --- a/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs @@ -14,23 +14,23 @@ setup :: IO () setup = void (Integration.reset *> Integration.loadAll) spec :: Spec -spec = beforeAll_ setup $ do +spec = beforeAll_ setup $ describe "Sourcefile Integration" $ do - it "finds a value declaration" $ do + it "finds a value declaration" $ testCase "sfValue" (3, 1) - it "finds a type declaration" $ do + it "finds a type declaration" $ testCase "SFType" (5, 1) - it "finds a data declaration" $ do + it "finds a data declaration" $ testCase "SFData" (7, 1) - it "finds a data constructor" $ do + it "finds a data constructor" $ testCase "SFOne" (7, 1) - it "finds a typeclass" $ do + it "finds a typeclass" $ testCase "SFClass" (9, 1) - it "finds a typeclass member" $ do + it "finds a typeclass member" $ testCase "sfShow" (10, 3) testCase :: Text -> (Int, Int) -> IO () testCase s (x, y) = do - (P.SourceSpan f (P.SourcePos l c) _):_ <- Integration.getInfo s + P.SourceSpan f (P.SourcePos l c) _ : _ <- Integration.getInfo s toS f `shouldSatisfy` T.isSuffixOf "SourceFileSpec.purs" (l, c) `shouldBe` (x, y) diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 26a2dba50b..631dcb1244 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -26,7 +26,7 @@ foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.Star member1 = P.TypeDeclaration (P.Ident "member1") P.REmpty spec :: Spec -spec = do +spec = describe "Extracting Spans" $ do it "extracts a span for a value declaration" $ extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(Left "value1", span1)] diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index 1047607c36..19eb961287 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -102,7 +102,6 @@ completionTestData = , ("ST.new", ["ST.newSTRef"]) , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"]) ] - where assertCompletedOk :: (String, [String]) -> Assertion assertCompletedOk (line, expecteds) = do From 0213e0b916454e0d66a2089c35c217ef74f665df Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sat, 20 Aug 2016 21:58:12 +0200 Subject: [PATCH 0478/1580] Import suggestions for UnusedDctorImport's (#2282) --- src/Language/PureScript/AST/Declarations.hs | 4 ++-- src/Language/PureScript/Errors.hs | 18 +++++++++++++----- src/Language/PureScript/Linter/Imports.hs | 4 ++-- 3 files changed, 17 insertions(+), 9 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 273c232aad..d0de7e674c 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -108,8 +108,8 @@ data SimpleErrorMessage | ImportHidingModule ModuleName | UnusedImport ModuleName | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef] - | UnusedDctorImport (ProperName 'TypeName) - | UnusedDctorExplicitImport (ProperName 'TypeName) [ProperName 'ConstructorName] + | UnusedDctorImport ModuleName (ProperName 'TypeName) (Maybe ModuleName) [DeclarationRef] + | UnusedDctorExplicitImport ModuleName (ProperName 'TypeName) [ProperName 'ConstructorName] (Maybe ModuleName) [DeclarationRef] | DuplicateSelectiveImport ModuleName | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) | DuplicateImportRef Name diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index b0c2d0fd54..ef08886959 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -288,6 +288,8 @@ errorSuggestion err = case err of UnusedImport{} -> emptySuggestion DuplicateImport{} -> emptySuggestion UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual + UnusedDctorImport mn _ qual refs -> suggest $ importSuggestion mn refs qual + UnusedDctorExplicitImport mn _ _ qual refs -> suggest $ importSuggestion mn refs qual ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing @@ -756,12 +758,18 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , line "It could be replaced with:" , indent $ line $ markCode $ showSuggestion msg ] - renderSimpleErrorMessage (UnusedDctorImport name) = - line $ "The import of type " ++ markCode (runProperName name) ++ " includes data constructors but only the type is used" + renderSimpleErrorMessage msg@(UnusedDctorImport mn name _ _) = + paras [line $ "The import of type " ++ markCode (runProperName name) + ++ " from module " ++ markCode (runModuleName mn) ++ " includes data constructors but only the type is used" + , line "It could be replaced with:" + , indent $ line $ markCode $ showSuggestion msg ] - renderSimpleErrorMessage (UnusedDctorExplicitImport name names) = - paras [ line $ "The import of type " ++ markCode (runProperName name) ++ " includes the following unused data constructors:" - , indent $ paras $ map (line . markCode . runProperName) names ] + renderSimpleErrorMessage msg@(UnusedDctorExplicitImport mn name names _ _) = + paras [ line $ "The import of type " ++ markCode (runProperName name) + ++ " from module " ++ markCode (runModuleName mn) ++ " includes the following unused data constructors:" + , indent $ paras $ map (line . markCode . runProperName) names + , line "It could be replaced with:" + , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage (DuplicateSelectiveImport name) = line $ "There is an existing import of " ++ markCode (runModuleName name) ++ ", consider merging the import lists" diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 41def96983..6bec467f4e 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -245,10 +245,10 @@ lintImportDecl env mni qualifierName names declType allowImplicit = -- If we've not already warned a type is unused, check its data constructors unless' (runProperName tn `notElem` usedNames) $ case (c, dctors `intersect` allCtors) of - (_, []) | c /= Just [] -> warn (UnusedDctorImport tn) + (_, []) | c /= Just [] -> warn (UnusedDctorImport mni tn qualifierName allRefs) (Just ctors, dctors') -> let ddiff = ctors \\ dctors' - in unless' (null ddiff) $ warn $ UnusedDctorExplicitImport tn ddiff + in unless' (null ddiff) $ warn $ UnusedDctorExplicitImport mni tn ddiff qualifierName allRefs _ -> return False return (didWarn || or didWarn') From bdbf4e28a3f734cf853b8a5a46d6441a4c17547b Mon Sep 17 00:00:00 2001 From: Charles O'Farrell Date: Sun, 21 Aug 2016 12:03:18 +1000 Subject: [PATCH 0479/1580] Add explicit import of Monoid <> (#2278) * Use bind instead of deprecated bindSocket * Add explicit import of Monoid <> optparse-applicative 0.13.* no longer exports this. * Add charleso to contributors file * Import Options.Applicative as qualified for future proofing --- CONTRIBUTORS.md | 1 + hierarchy/Main.hs | 33 ++++++++++++++------------ psc-bundle/Main.hs | 53 ++++++++++++++++++++++-------------------- psc-ide-client/Main.hs | 13 +++++++---- psc-ide-server/Main.hs | 25 ++++++++++---------- psc-publish/Main.hs | 23 ++++++++++-------- 6 files changed, 81 insertions(+), 67 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 797c6cd321..6677cfaba5 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -16,6 +16,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@Bogdanp](https://github.com/Bogdanp) (Bogdan Paul Popa) My existing contributions and all future contributions until further notice are Copyright Bogdan Paul Popa, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@cdepillabout](https://github.com/cdepillabout) (Dennis Gosnell) My existing contributions and all future contributions until further notice are Copyright Dennis Gosnell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@charleso](https://github.com/charleso) (Charles O'Farrell) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Charles O'Farrell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@chrissmoak](https://github.com/chrissmoak) (Chris Smoak) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@davidchambers](https://github.com/davidchambers) (David Chambers) My existing contributions and all future contributions until further notice are Copyright David Chambers, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs index 5857dd4c07..e9d17b4a22 100644 --- a/hierarchy/Main.hs +++ b/hierarchy/Main.hs @@ -18,13 +18,16 @@ module Main where +import Control.Applicative (optional) import Control.Monad (unless) import Data.List (intercalate,nub,sort) import Data.Foldable (for_) import Data.Version (showVersion) +import Data.Monoid ((<>)) -import Options.Applicative +import Options.Applicative (Parser) +import qualified Options.Applicative as Opts import System.Directory (createDirectoryIfMissing) import System.FilePath (()) import System.FilePath.Glob (glob) @@ -90,26 +93,26 @@ superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl superClasses _ = [] inputFile :: Parser FilePath -inputFile = strArgument $ - metavar "FILE" - <> value "main.purs" - <> showDefault - <> help "The input file to generate a hierarchy from" +inputFile = Opts.strArgument $ + Opts.metavar "FILE" + <> Opts.value "main.purs" + <> Opts.showDefault + <> Opts.help "The input file to generate a hierarchy from" outputFile :: Parser (Maybe FilePath) -outputFile = optional . strOption $ - short 'o' - <> long "output" - <> help "The output directory" +outputFile = optional . Opts.strOption $ + Opts.short 'o' + <> Opts.long "output" + <> Opts.help "The output directory" pscOptions :: Parser HierarchyOptions pscOptions = HierarchyOptions <$> inputFile <*> outputFile main :: IO () -main = execParser opts >>= compile +main = Opts.execParser opts >>= compile where - opts = info (helper <*> pscOptions) infoModList - infoModList = fullDesc <> headerInfo <> footerInfo - headerInfo = header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses" - footerInfo = footer $ "hierarchy " ++ showVersion Paths.version + opts = Opts.info (Opts.helper <*> pscOptions) infoModList + infoModList = Opts.fullDesc <> headerInfo <> footerInfo + headerInfo = Opts.header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses" + footerInfo = Opts.footer $ "hierarchy " ++ showVersion Paths.version diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index 92ff4f281a..7caeac3358 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -8,6 +8,7 @@ module Main (main) where import Data.Traversable (for) import Data.Version (showVersion) +import Data.Monoid ((<>)) import Control.Applicative import Control.Monad @@ -24,7 +25,8 @@ import System.Directory (createDirectoryIfMissing) import Language.PureScript.Bundle -import Options.Applicative as Opts +import Options.Applicative (Parser, ParseError (..)) +import qualified Options.Applicative as Opts import qualified Paths_purescript as Paths @@ -64,41 +66,41 @@ options = Options <$> some inputFile <*> namespace where inputFile :: Parser FilePath - inputFile = strArgument $ - metavar "FILE" - <> help "The input .js file(s)" + inputFile = Opts.strArgument $ + Opts.metavar "FILE" + <> Opts.help "The input .js file(s)" outputFile :: Parser FilePath - outputFile = strOption $ - short 'o' - <> long "output" - <> help "The output .js file" + outputFile = Opts.strOption $ + Opts.short 'o' + <> Opts.long "output" + <> Opts.help "The output .js file" entryPoint :: Parser String - entryPoint = strOption $ - short 'm' - <> long "module" - <> help "Entry point module name(s). All code which is not a transitive dependency of an entry point module will be removed." + entryPoint = Opts.strOption $ + Opts.short 'm' + <> Opts.long "module" + <> Opts.help "Entry point module name(s). All code which is not a transitive dependency of an entry point module will be removed." mainModule :: Parser String - mainModule = strOption $ - long "main" - <> help "Generate code to run the main method in the specified module." + mainModule = Opts.strOption $ + Opts.long "main" + <> Opts.help "Generate code to run the main method in the specified module." namespace :: Parser String - namespace = strOption $ - short 'n' - <> long "namespace" + namespace = Opts.strOption $ + Opts.short 'n' + <> Opts.long "namespace" <> Opts.value "PS" - <> showDefault - <> help "Specify the namespace that PureScript modules will be exported to when running in the browser." + <> Opts.showDefault + <> Opts.help "Specify the namespace that PureScript modules will be exported to when running in the browser." -- | Make it go. main :: IO () main = do hSetEncoding stdout utf8 hSetEncoding stderr utf8 - opts <- execParser (info (version <*> helper <*> options) infoModList) + opts <- Opts.execParser (Opts.info (version <*> Opts.helper <*> options) infoModList) output <- runExceptT (app opts) case output of Left err -> do @@ -111,9 +113,10 @@ main = do writeFile outputFile js Nothing -> putStrLn js where - infoModList = fullDesc <> headerInfo <> footerInfo - headerInfo = header "psc-bundle - Bundles compiled PureScript modules for the browser" - footerInfo = footer $ "psc-bundle " ++ showVersion Paths.version + infoModList = Opts.fullDesc <> headerInfo <> footerInfo + headerInfo = Opts.header "psc-bundle - Bundles compiled PureScript modules for the browser" + footerInfo = Opts.footer $ "psc-bundle " ++ showVersion Paths.version version :: Parser (a -> a) - version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden + version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $ + Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs index ec4c7614ee..85d56a6c36 100644 --- a/psc-ide-client/Main.hs +++ b/psc-ide-client/Main.hs @@ -8,8 +8,10 @@ import Control.Exception import qualified Data.ByteString.Char8 as BS8 import qualified Data.Text.IO as T import Data.Version (showVersion) +import Data.Monoid ((<>)) import Network -import Options.Applicative +import Options.Applicative (ParseError (..)) +import qualified Options.Applicative as Opts import System.Exit import System.IO @@ -21,15 +23,16 @@ data Options = Options main :: IO () main = do - Options port <- execParser opts + Options port <- Opts.execParser opts client port where parser = Options <$> (PortNumber . fromIntegral <$> - option auto (long "port" <> short 'p' <> value (4242 :: Integer))) - opts = info (version <*> helper <*> parser) mempty - version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden + Opts.option Opts.auto (Opts.long "port" <> Opts.short 'p' <> Opts.value (4242 :: Integer))) + opts = Opts.info (version <*> Opts.helper <*> parser) mempty + version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $ + Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden client :: PortID -> IO () client port = do diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index ce513023ad..675966a1da 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -38,7 +38,8 @@ import Network hiding (socketPort, accept) import Network.BSD (getProtocolNumber) import Network.Socket hiding (PortNumber, Type, sClose) -import Options.Applicative hiding ((<>)) +import Options.Applicative (ParseError (..)) +import qualified Options.Applicative as Opts import System.Directory import System.FilePath import System.IO hiding (putStrLn, print) @@ -55,7 +56,7 @@ listenOnLocalhost port = do sClose (\sock -> do setSocketOption sock ReuseAddr 1 - bindSocket sock (SockAddrInet port localhost) + bind sock (SockAddrInet port localhost) listen sock maxListenQueue pure sock) @@ -70,7 +71,7 @@ data Options = Options main :: IO () main = do - Options dir globs outputPath port noWatch debug <- execParser opts + Options dir globs outputPath port noWatch debug <- Opts.execParser opts maybe (pure ()) setCurrentDirectory dir ideState <- newTVarIO emptyIdeState cwd <- getCurrentDirectory @@ -91,17 +92,17 @@ main = do where parser = Options - <$> optional (strOption (long "directory" `mappend` short 'd')) - <*> many (argument str (metavar "Source GLOBS...")) - <*> strOption (long "output-directory" `mappend` value "output/") + <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd')) + <*> many (Opts.argument Opts.str (Opts.metavar "Source GLOBS...")) + <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/") <*> (fromIntegral <$> - option auto (long "port" `mappend` short 'p' `mappend` value (4242 :: Integer))) - <*> switch (long "no-watch") - <*> switch (long "debug") - opts = info (version <*> helper <*> parser) mempty - version = abortOption + Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer))) + <*> Opts.switch (Opts.long "no-watch") + <*> Opts.switch (Opts.long "debug") + opts = Opts.info (version <*> Opts.helper <*> parser) mempty + version = Opts.abortOption (InfoMsg (showVersion Paths.version)) - (long "version" `mappend` help "Show the version number") + (Opts.long "version" `mappend` Opts.help "Show the version number") startServer :: PortNumber -> IdeEnvironment -> IO () startServer port env = withSocketsDo $ do diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs index 7242235851..dd8f6632fb 100644 --- a/psc-publish/Main.hs +++ b/psc-publish/Main.hs @@ -4,8 +4,10 @@ module Main where import Data.Version (Version(..), showVersion) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Monoid ((<>)) -import Options.Applicative hiding (str) +import Options.Applicative (Parser, ParseError (..)) +import qualified Options.Applicative as Opts import System.IO (hSetEncoding, stderr, stdout, utf8) @@ -14,9 +16,9 @@ import Language.PureScript.Publish import Language.PureScript.Publish.ErrorsWarnings dryRun :: Parser Bool -dryRun = switch $ - long "dry-run" - <> help "Produce no output, and don't require a tagged version to be checked out." +dryRun = Opts.switch $ + Opts.long "dry-run" + <> Opts.help "Produce no output, and don't require a tagged version to be checked out." dryRunOptions :: PublishOptions dryRunOptions = defaultPublishOptions @@ -29,15 +31,16 @@ main :: IO () main = do hSetEncoding stdout utf8 hSetEncoding stderr utf8 - execParser opts >>= publish + Opts.execParser opts >>= publish where - opts = info (version <*> helper <*> dryRun) infoModList - infoModList = fullDesc <> headerInfo <> footerInfo - headerInfo = header "psc-publish - Generates documentation packages for upload to http://pursuit.purescript.org" - footerInfo = footer $ "psc-publish " ++ showVersion Paths.version + opts = Opts.info (version <*> Opts.helper <*> dryRun) infoModList + infoModList = Opts.fullDesc <> headerInfo <> footerInfo + headerInfo = Opts.header "psc-publish - Generates documentation packages for upload to http://pursuit.purescript.org" + footerInfo = Opts.footer $ "psc-publish " ++ showVersion Paths.version version :: Parser (a -> a) - version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden + version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $ + Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden publish :: Bool -> IO () publish isDryRun = From df85f5c035b622038251e9531424a07a513bd948 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 26 Aug 2016 06:06:41 +0200 Subject: [PATCH 0480/1580] [psc-bundle] Verify entry points exist (#2286) * [psc-bundle] Verify entry points exist Throws an error when an entry point could not be found in the input modules. * [psc-bundle] Also error on missing --main module * try to fix timeout on OS X instances --- src/Language/PureScript/Bundle.hs | 16 ++++++++++++++-- tests/Language/PureScript/Ide/Integration.hs | 2 +- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 550dbaf6b1..1ef4953769 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -43,6 +43,8 @@ data ErrorMessage | UnableToParseModule String | UnsupportedExport | ErrorInModule ModuleIdentifier ErrorMessage + | MissingEntryPoint String + | MissingMainModule String deriving (Show) -- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules. @@ -125,8 +127,14 @@ printErrorMessage (ErrorInModule mid e) = : "" : map (" " ++) (printErrorMessage e) where - displayIdentifier (ModuleIdentifier name ty) = - name ++ " (" ++ showModuleType ty ++ ")" + displayIdentifier (ModuleIdentifier name ty) = + name ++ " (" ++ showModuleType ty ++ ")" +printErrorMessage (MissingEntryPoint mName) = + [ "Couldn't find a CommonJS module for the specified entry point: " ++ mName + ] +printErrorMessage (MissingMainModule mName) = + [ "Couldn't find a CommonJS module for the specified main module: " ++ mName + ] -- | Calculate the ModuleIdentifier which a require(...) statement imports. checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier @@ -609,6 +617,10 @@ bundle :: (MonadError ErrorMessage m) -> String -- ^ The namespace (e.g. PS). -> m String bundle inputStrs entryPoints mainModule namespace = do + forM_ mainModule $ \mname -> + when (mname `notElem` map (moduleName . fst) inputStrs) (throwError (MissingMainModule mname)) + forM_ entryPoints $ \mIdent -> + when (mIdent `notElem` map fst inputStrs) (throwError (MissingEntryPoint (moduleName mIdent))) input <- forM inputStrs $ \(ident, js) -> do ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident) return (ident, ast) diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs index f733959fb5..ce89093c25 100644 --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -95,7 +95,7 @@ compileTestProject = do pdir <- projectDirectory (_, _, _, procHandle) <- createProcess $ (shell . toS $ "psc " <> fileGlob) { cwd = Just pdir } - r <- tryNTimes 5 (getProcessExitCode procHandle) + r <- tryNTimes 10 (getProcessExitCode procHandle) pure (fromMaybe False (isSuccess <$> r)) tryNTimes :: Int -> IO (Maybe a) -> IO (Maybe a) From 2e715758866ea45fdac65a9558d04a48ea967994 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 26 Aug 2016 19:08:49 +0300 Subject: [PATCH 0481/1580] Support http-client-0.5 (#2284) --- purescript.cabal | 2 +- src/Language/PureScript/Ide/Pursuit.hs | 44 ++++++++++++-------------- stack.yaml | 5 ++- 3 files changed, 25 insertions(+), 26 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 71fee5df61..505e441929 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -117,7 +117,7 @@ library fsnotify >= 0.2.1, Glob >= 0.7 && < 0.8, haskeline >= 0.7.0.0, - http-client >= 0.4.30 && <0.5, + http-client >= 0.4.30 && <0.6, http-types -any, language-javascript == 0.6.*, lifted-base >= 0.2.3 && < 0.2.4, diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs index 962f573af9..ae40238209 100644 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -35,41 +35,37 @@ import qualified Pipes.Prelude as P -- TODO: remove this when the issue is fixed at Pursuit queryPursuit :: Text -> IO ByteString queryPursuit q = do - let qClean = T.dropWhileEnd (== '.') q - req' <- parseRequest "http://pursuit.purescript.org/search" - let req = req' - { queryString= "q=" <> (fromString . T.unpack) qClean - , requestHeaders=[(hAccept, "application/json")] - } - m <- newManager tlsManagerSettings - withHTTP req m $ \resp -> - P.fold (<>) "" identity (responseBody resp) - + let qClean = T.dropWhileEnd (== '.') q + req' <- parseRequest "http://pursuit.purescript.org/search" + let req = req' + { queryString= "q=" <> (fromString . T.unpack) qClean + , requestHeaders=[(hAccept, "application/json")] + } + m <- newManager tlsManagerSettings + withHTTP req m $ \resp -> + P.fold (<>) "" identity (responseBody resp) handler :: HttpException -> IO [a] -handler StatusCodeException{} = pure [] handler _ = pure [] searchPursuitForDeclarations :: Text -> IO [PursuitResponse] -searchPursuitForDeclarations query = - (do r <- queryPursuit query - let results' = decode (fromStrict r) :: Maybe Array - case results' of - Nothing -> pure [] - Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))) `E.catch` - handler +searchPursuitForDeclarations query = E.handle handler $ do + r <- queryPursuit query + let results' = decode (fromStrict r) :: Maybe Array + case results' of + Nothing -> pure [] + Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results)) where isDeclarationResponse (Success a@DeclarationResponse{}) = Just a isDeclarationResponse _ = Nothing findPackagesForModuleIdent :: Text -> IO [PursuitResponse] -findPackagesForModuleIdent query = - (do r <- queryPursuit query - let results' = decode (fromStrict r) :: Maybe Array - case results' of +findPackagesForModuleIdent query = E.handle handler $ do + r <- queryPursuit query + let results' = decode (fromStrict r) :: Maybe Array + case results' of Nothing -> pure [] - Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))) `E.catch` - handler + Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results)) where isModuleResponse (Success a@ModuleResponse{}) = Just a isModuleResponse _ = Nothing diff --git a/stack.yaml b/stack.yaml index 8ba748eba2..e86fae58e1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,8 +1,11 @@ -resolver: lts-6.10 +resolver: lts-6.13 packages: - '.' extra-deps: - aeson-1.0.0.0 +- http-client-0.5.1 +- http-client-tls-0.3.0 +- pipes-http-1.0.4 - semigroups-0.18.2 flags: semigroups: From f58158cd65251f90c4a65685c49db47ade919ab9 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 30 Aug 2016 19:28:02 +0100 Subject: [PATCH 0482/1580] Update CONTRIBUTING.md to use Stack --- CONTRIBUTING.md | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 08dfdd7315..888a087684 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -11,9 +11,8 @@ If you would like to contribute, please consider the issues in the current miles Please follow the following guidelines: - Add at least a test to `examples/passing/` and possibly to `examples/failing`. -- Build the binaries and libs with `cabal build` -- Install the binaries and libs with `cabal install`. -- Run `cabal configure --enable-tests && cabal build && cabal test` to build the test suite. You will need `npm` and `node` on your PATH to run the tests. +- Build the binaries and libs with `stack build` +- Run the test suite with `stack test`. You will need `npm` and `node` on your PATH to run the tests. - Build the core libraries by running the script in `core-tests`. ## Code Review From 7fb1012a0972420ec4e82c4117cb9e6c9d7e7407 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 30 Aug 2016 19:42:59 +0100 Subject: [PATCH 0483/1580] Revert "Update CONTRIBUTING.md to use Stack" This reverts commit f58158cd65251f90c4a65685c49db47ade919ab9. --- CONTRIBUTING.md | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 888a087684..08dfdd7315 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -11,8 +11,9 @@ If you would like to contribute, please consider the issues in the current miles Please follow the following guidelines: - Add at least a test to `examples/passing/` and possibly to `examples/failing`. -- Build the binaries and libs with `stack build` -- Run the test suite with `stack test`. You will need `npm` and `node` on your PATH to run the tests. +- Build the binaries and libs with `cabal build` +- Install the binaries and libs with `cabal install`. +- Run `cabal configure --enable-tests && cabal build && cabal test` to build the test suite. You will need `npm` and `node` on your PATH to run the tests. - Build the core libraries by running the script in `core-tests`. ## Code Review From ab5f139336c7343009e88c13b29c9cdf566b1713 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 2 Sep 2016 06:05:41 +0200 Subject: [PATCH 0484/1580] Safer installation from source in INSTALL.md (#2294) * Safer installation from source in INSTALL.md This commit ensures that the stackage snapshot used when building from source following the instructions in INSTALL.md will be the same as the one used in development and in binary bundles. This is safer (because you'll end up with a set of dependencies which have been tested together) and it also means you'll always get the latest version according to Hackage. In comparison, the Stackage nightly is often behind because of waiting for purescript or other libraries to make changes to allow all packages in the nightly to build together. * Update CONTRIBUTING.md to use Stack --- CONTRIBUTING.md | 5 ++--- INSTALL.md | 9 ++++++--- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 08dfdd7315..888a087684 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -11,9 +11,8 @@ If you would like to contribute, please consider the issues in the current miles Please follow the following guidelines: - Add at least a test to `examples/passing/` and possibly to `examples/failing`. -- Build the binaries and libs with `cabal build` -- Install the binaries and libs with `cabal install`. -- Run `cabal configure --enable-tests && cabal build && cabal test` to build the test suite. You will need `npm` and `node` on your PATH to run the tests. +- Build the binaries and libs with `stack build` +- Run the test suite with `stack test`. You will need `npm` and `node` on your PATH to run the tests. - Build the core libraries by running the script in `core-tests`. ## Code Review diff --git a/INSTALL.md b/INSTALL.md index 4414a13c2e..4031f9ed65 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -27,16 +27,19 @@ GHC 7.10.1 or newer is required to compile from source. The easiest way is to use stack: ``` -$ stack install --resolver=nightly purescript +$ stack update +$ stack unpack purescript +$ cd purescript-x.y.z # (replace x.y.z with whichever version you just downloaded) +$ stack install ``` This will then copy the compiler and utilities into `~/.local/bin`. -If you don't have stack installed yet there are install instructions +If you don't have stack installed, there are install instructions [here](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md). -If you don't have ghc installed yet, stack will prompt you to run `stack setup` +If you don't have ghc installed, stack will prompt you to run `stack setup` which will install ghc for you. ## The "curses" library From 96596d5d02868b29c42df413ed0df3a54cc93a8e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 5 Sep 2016 15:12:42 -0700 Subject: [PATCH 0485/1580] Fix weird parser issue identified by @FrigoEU --- examples/passing/ConstraintParsingIssue.purs | 9 +++++++++ src/Language/PureScript/Parser/Types.hs | 6 ++---- 2 files changed, 11 insertions(+), 4 deletions(-) create mode 100644 examples/passing/ConstraintParsingIssue.purs diff --git a/examples/passing/ConstraintParsingIssue.purs b/examples/passing/ConstraintParsingIssue.purs new file mode 100644 index 0000000000..b16f684ade --- /dev/null +++ b/examples/passing/ConstraintParsingIssue.purs @@ -0,0 +1,9 @@ +module Main where + +import Control.Monad.Eff.Console + +class X a + +instance x :: X (Array (Array a)) => X (Array a) + +main = log "Done" diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index da155f7736..6bb1e14f19 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -54,8 +54,7 @@ parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (i -- parseTypeAtom :: TokenParser Type parseTypeAtom = indented *> P.choice - [ P.try parseConstrainedType - , P.try parseFunction + [ P.try parseFunction , parseTypeLevelString , parseObject , parseTypeWildcard @@ -81,9 +80,8 @@ parseConstrainedType = do ty <- P.many parseTypeAtom return (Constraint className ty Nothing) - parseAnyType :: TokenParser Type -parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P. "type" +parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable (P.try parseConstrainedType <|> parseTypeAtom)) P. "type" where operators = [ [ P.Infix (return TypeApp) P.AssocLeft ] , [ P.Infix (P.try (parseQualified parseOperator) >>= \ident -> From c6174d5797e717e0b15283fbaf10ef2267652ca5 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Wed, 7 Sep 2016 14:13:27 +0100 Subject: [PATCH 0486/1580] Fix inlining for apply operators --- src/Language/PureScript/CodeGen/JS/Optimizer.hs | 6 ------ .../PureScript/CodeGen/JS/Optimizer/Inliner.hs | 11 +++++++---- 2 files changed, 7 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs index fd045b09e8..c504a77eda 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -34,7 +34,6 @@ import Language.PureScript.CodeGen.JS.Optimizer.MagicDo import Language.PureScript.CodeGen.JS.Optimizer.TCO import Language.PureScript.CodeGen.JS.Optimizer.Unused import Language.PureScript.Options -import qualified Language.PureScript.Constants as C -- | -- Apply a series of optimizer passes to simplified Javascript code @@ -49,11 +48,6 @@ optimize' js = do opts <- ask js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll [ inlineCommonValues - , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp Nothing f [x] - , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x] - , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp Nothing f [x] - , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x] - , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing) , inlineCommonOperators ]) js untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js' diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index 5ac11041d8..7f953e9548 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -4,7 +4,6 @@ module Language.PureScript.CodeGen.JS.Optimizer.Inliner ( inlineVariables , inlineCommonValues - , inlineOperator , inlineCommonOperators , inlineFnComposition , etaConvert @@ -100,13 +99,13 @@ inlineCommonValues = everywhereOnJS convert fnSubtract = (C.dataRing, C.sub) intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0)) -inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS -inlineOperator (m, op) f = everywhereOnJS convert +inlineNonClassFunction :: (String, String) -> (JS -> JS -> JS) -> JS -> JS +inlineNonClassFunction (m, op) f = everywhereOnJS convert where convert :: JS -> JS convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y convert other = other - isOp (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) = m == m' && op == op' + isOp (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op' isOp _ = False inlineCommonOperators :: JS -> JS @@ -167,6 +166,10 @@ inlineCommonOperators = applyAll $ , binary' C.dataIntBits C.shr ShiftRight , binary' C.dataIntBits C.zshr ZeroFillShiftRight , unary' C.dataIntBits C.complement BitwiseNot + + , inlineNonClassFunction (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x] + , inlineNonClassFunction (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x] + , inlineNonClassFunction (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing) ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] where From 21460806221cbd917a3f6d649afba7446bea948e Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Fri, 9 Sep 2016 17:22:16 +0200 Subject: [PATCH 0487/1580] Added typelevel string functions (#2280) * Added typelevel string functions * Moved evaluation from Pretty to Errors * Introduced toTypelevelString in Errors * Made special parseConstraintArg * Reworked toTypelevelString to work on Box * Changed <> to before in toTypeLevelString * Went back to parseTypeAtom to parse constraints --- .../ProgrammableTypeErrorsTypeString.purs | 18 ++++++++++++++++++ src/Language/PureScript/Environment.hs | 2 ++ src/Language/PureScript/Errors.hs | 14 ++++++++++++-- src/Language/PureScript/Parser/Declarations.hs | 1 - 4 files changed, 32 insertions(+), 3 deletions(-) create mode 100644 examples/failing/ProgrammableTypeErrorsTypeString.purs diff --git a/examples/failing/ProgrammableTypeErrorsTypeString.purs b/examples/failing/ProgrammableTypeErrorsTypeString.purs new file mode 100644 index 0000000000..b0b7c0f50d --- /dev/null +++ b/examples/failing/ProgrammableTypeErrorsTypeString.purs @@ -0,0 +1,18 @@ +-- @shouldFailWith NoInstanceFound + +module Main where + +import Prelude +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (log) + +newtype MyType a = MyType a + +instance cannotShowFunctions :: Fail ("Don't want to show " <> TypeString (MyType a) <> " because.") => Show (MyType a) where + show _ = "unreachable" + +infixl 6 type TypeConcat as <> + +main :: Eff _ _ +main = do + log $ show (MyType 2) diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index d67f771dfb..6fba5e498c 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -241,6 +241,8 @@ primTypes = , (primName "Boolean", (Star, ExternData)) , (primName "Partial", (Star, ExternData)) , (primName "Fail", (FunKind Symbol Star, ExternData)) + , (primName "TypeString", (FunKind Star Symbol, ExternData)) + , (primName "TypeConcat", (FunKind Symbol (FunKind Symbol Symbol), ExternData)) ] -- | diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index ef08886959..5be9fe20a1 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -25,6 +25,7 @@ import qualified Data.Map as M import Language.PureScript.AST import Language.PureScript.Crash +import Language.PureScript.Environment import Language.PureScript.Names import Language.PureScript.Pretty import Language.PureScript.Traversals @@ -32,6 +33,7 @@ import Language.PureScript.Types import Language.PureScript.Pretty.Common (endWith) import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.Constants as C +import Language.PureScript.Pretty.Common (before) import qualified System.Console.ANSI as ANSI @@ -594,9 +596,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , line "They may be disallowed completely in a future version of the compiler." ] renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list" - renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ TypeLevelString message ] _)) = + renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ ty ] _)) | Just box <- toTypelevelString ty = paras [ line "A custom type error occurred while solving type class constraints:" - , indent . paras . map line . lines $ message + , indent box ] renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial _ @@ -1203,6 +1205,14 @@ renderBox = unlines dropWhileEnd p = reverse . dropWhile p . reverse whiteSpace = all isSpace +toTypelevelString :: Type -> Maybe Box.Box +toTypelevelString (TypeLevelString s) = Just $ Box.text s +toTypelevelString (TypeApp (TypeConstructor f) x) + | f == primName "TypeString" = Just $ typeAsBox x +toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret) + | f == primName "TypeConcat" = before <$> (toTypelevelString x) <*> (toTypelevelString ret) +toTypelevelString _ = Nothing + -- | -- Rethrow an error with a more detailed error message in the case of failure -- diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 227981d97e..c8e66e7f93 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -192,7 +192,6 @@ parseConstraint :: TokenParser Constraint parseConstraint = Constraint <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom) <*> pure Nothing - parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) parseInstanceDeclaration = do reserved "instance" From af3bca2a711087aa25f2cfd675de11e95c0d502e Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 11 Sep 2016 04:27:09 +0200 Subject: [PATCH 0488/1580] [psc-ide] Parse type annotations from source files Then use these parsed type annotations to give back the non-expanded types for functions that contain type synonyms in their annotation. --- src/Language/PureScript/Ide/Externs.hs | 22 ++++++++++++++-------- src/Language/PureScript/Ide/SourceFile.hs | 11 +++++++++++ src/Language/PureScript/Ide/State.hs | 13 ++++++++----- src/Language/PureScript/Ide/Types.hs | 10 +++++++--- src/Language/PureScript/Ide/Util.hs | 2 +- 5 files changed, 41 insertions(+), 17 deletions(-) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 0e8374509f..abc37e5e99 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -17,9 +17,9 @@ {-# LANGUAGE FlexibleContexts #-} module Language.PureScript.Ide.Externs - ( readExternFile, - convertExterns, - annotateLocations + ( readExternFile + , convertExterns + , annotateModule ) where import Protolude @@ -99,14 +99,17 @@ convertTypeOperator P.ExternsTypeFixity{..} = efTypePrecedence efTypeAssociativity -annotateLocations :: Map (Either Text Text) P.SourceSpan -> Module -> Module -annotateLocations ast (moduleName, decls) = +annotateModule + :: (DefinitionSites P.SourceSpan, TypeAnnotations) + -> Module + -> Module +annotateModule (defs, types) (moduleName, decls) = (moduleName, map convertDeclaration decls) where convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn convertDeclaration (IdeDeclarationAnn ann d) = case d of IdeValue i t -> - annotateValue (runIdentT i) (IdeValue i t) + annotateFunction i (IdeValue i t) IdeType i k -> annotateType (runProperNameT i) (IdeType i k) IdeTypeSynonym i t -> @@ -120,5 +123,8 @@ annotateLocations ast (moduleName, decls) = IdeTypeOperator n i p a -> annotateType i (IdeTypeOperator n i p a) where - annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) ast}) - annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Right x) ast}) + annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs + , annTypeAnnotation = Map.lookup x types + }) + annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) defs}) + annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Right x) defs}) diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index ccca6122c6..956fd1eceb 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -18,6 +18,7 @@ module Language.PureScript.Ide.SourceFile ( parseModule , getImportsForFile , extractSpans + , extractTypeAnnotations ) where import Protolude @@ -64,6 +65,16 @@ getImportsForFile fp = do unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls) unwrapImportType P.Implicit = P.Implicit +-- | Extracts type annotations for functions from a given Module +extractTypeAnnotations + :: [P.Declaration] + -> [(P.Ident, P.Type)] +extractTypeAnnotations = mapMaybe extract + where + extract d = case unwrapPositioned d of + P.TypeDeclaration ident ty -> Just (ident, ty) + _ -> Nothing + -- | Given a surrounding Sourcespan and a Declaration from the PS AST, extracts -- definition sites inside that Declaration. extractSpans diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 04038d21bc..01bf2bcae6 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -132,10 +132,10 @@ getAllModules mmoduleName = do Just (cachedModulename, ef) | cachedModulename == moduleName -> do (AstData asts) <- s2AstData <$> getStage2 - let ast = fromMaybe M.empty (M.lookup moduleName asts) + let ast = fromMaybe (M.empty, M.empty) (M.lookup moduleName asts) pure . M.toList $ M.insert moduleName - (snd . annotateLocations ast . fst . convertExterns $ ef) declarations + (snd . annotateModule ast . fst . convertExterns $ ef) declarations _ -> pure (M.toList declarations) -- | Adds an ExternsFile into psc-ide's State Stage1. This does not populate the @@ -180,8 +180,11 @@ populateStage2 = do populateStage2STM :: TVar IdeState -> STM () populateStage2STM ref = do modules <- s1Modules <$> getStage1STM ref - let spans = map (\(P.Module ss _ _ decls _, _) -> M.fromList (concatMap (extractSpans ss) decls)) modules - setStage2STM ref (Stage2 (AstData spans)) + let astData = map (\(P.Module ss _ _ decls _, _) -> + let definitions = M.fromList (concatMap (extractSpans ss) decls) + typeAnnotations = M.fromList (extractTypeAnnotations decls) + in (definitions, typeAnnotations)) modules + setStage2STM ref (Stage2 (AstData astData)) -- | Resolves reexports and populates Stage3 with data to be used in queries. populateStage3 :: (Ide m, MonadLogger m) => m () @@ -206,7 +209,7 @@ populateStage3STM ref = do nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)]) nModules = M.mapWithKey (\moduleName (m, refs) -> - (fromMaybe m $ annotateLocations <$> M.lookup moduleName asts <*> pure m, refs)) modules + (fromMaybe m $ annotateModule <$> M.lookup moduleName asts <*> pure m, refs)) modules -- resolves reexports and discards load failures for now result = resolveReexports (M.map (snd . fst) nModules) <$> M.elems nModules setStage3STM ref (Stage3 (M.fromList (map reResolved result)) Nothing) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index c8c37583d7..6d5a5d463a 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -47,15 +47,19 @@ data Annotation = Annotation { annLocation :: Maybe P.SourceSpan , annExportedFrom :: Maybe P.ModuleName + , annTypeAnnotation :: Maybe P.Type } deriving (Show, Eq, Ord) emptyAnn :: Annotation -emptyAnn = Annotation Nothing Nothing +emptyAnn = Annotation Nothing Nothing Nothing type Module = (P.ModuleName, [IdeDeclarationAnn]) -newtype AstData a = - AstData (Map P.ModuleName (Map (Either Text Text) a)) +type DefinitionSites a = Map (Either Text Text) a +type TypeAnnotations = Map P.Ident P.Type +newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotations)) + -- ^ SourceSpans for the definition sites of Values and Types aswell as type + -- annotations found in a module deriving (Show, Eq, Ord, Functor, Foldable) data Configuration = diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 9dd0c79f8a..c493638290 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -76,7 +76,7 @@ completionFromMatch' (Match (m', d)) = case d of infoFromMatch :: Match IdeDeclarationAnn -> Info infoFromMatch (Match (m, IdeDeclarationAnn ann d)) = - Info (a, b, c, annLocation ann) + Info (a, b, maybe c prettyTypeT (annTypeAnnotation ann), annLocation ann) where (a, b, c) = completionFromMatch' (Match (m, d)) From 8dd39654480cb4a8fa1f08b7fb2d07bb14c52396 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 11 Sep 2016 23:17:11 +0200 Subject: [PATCH 0489/1580] [psc-ide] Provides AST information on completion * Unifies response formats for the type and complete commands so go-to-definition and type annotations now also show up in completions --- psc-ide-server/PROTOCOL.md | 35 +++++-------- src/Language/PureScript/Ide.hs | 12 ++--- src/Language/PureScript/Ide/Command.hs | 2 +- src/Language/PureScript/Ide/Completion.hs | 15 +++--- src/Language/PureScript/Ide/Matcher.hs | 16 +++--- src/Language/PureScript/Ide/SourceFile.hs | 12 +++++ src/Language/PureScript/Ide/State.hs | 5 +- src/Language/PureScript/Ide/Types.hs | 34 ++++++------ src/Language/PureScript/Ide/Util.hs | 52 ++++++++++--------- tests/Language/PureScript/Ide/Integration.hs | 26 +++------- tests/Language/PureScript/Ide/MatcherSpec.hs | 16 +++--- .../Ide/SourceFile/IntegrationSpec.hs | 7 ++- .../Language/PureScript/Ide/SourceFileSpec.hs | 8 ++- 13 files changed, 122 insertions(+), 118 deletions(-) diff --git a/psc-ide-server/PROTOCOL.md b/psc-ide-server/PROTOCOL.md index f581f14bab..205650584e 100644 --- a/psc-ide-server/PROTOCOL.md +++ b/psc-ide-server/PROTOCOL.md @@ -51,27 +51,7 @@ definition position, if it can be found in the passed source files. ``` **Result:** -The possible types are returned in the same format as completions + eventual position information -```json -[ - { - "module": "Data.Array", - "identifier": "filter", - "type": "forall a. (a -> Boolean) -> Array a -> Array a" - }, - { - "module": "Data.Array", - "identifier": "filter", - "type": "forall a. (a -> Boolean) -> Array a -> Array a", - "definedAt": - { - "name": "/path/to/file", - "start": [1, 3], - "end": [3, 1] - } - } -] -``` +The possible types are returned in the same format as completions ### Complete The `complete` command looks up possible completions/corrections. @@ -104,12 +84,23 @@ The `complete` command looks up possible completions/corrections. The following format is returned as the Result: +Both the `definedAt` aswell as the `documentation` field might be `null` if they +couldn't be extracted from a source file. + ```json [ { "module": "Data.Array", "identifier": "filter", - "type": "forall a. (a -> Boolean) -> Array a -> Array a" + "type": "forall a. (a -> Boolean) -> Array a -> Array a", + "expandedType": "forall a. (a -> Boolean) -> Array a -> Array a", + "definedAt": + { + "name": "/path/to/file", + "start": [1, 3], + "end": [3, 1] + }, + "documentation": "A filtering function" } ] ``` diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 697215a6f8..0c466ca788 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -38,9 +38,9 @@ import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import System.Directory -import System.FilePath -import System.FilePath.Glob +import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist, doesFileExist) +import System.FilePath (()) +import System.FilePath.Glob (glob) -- | Accepts a Commmand and runs it against psc-ide's State. This is the main -- entry point for the server. @@ -77,7 +77,7 @@ handleCommand c = case c of case rs of Right rs' -> answerRequest outfp rs' Left question -> - pure (CompletionResult (map completionFromMatch question)) + pure (CompletionResult (map (completionFromMatch . map withEmptyAnn) question)) Rebuild file -> rebuildFile file Cwd -> @@ -88,7 +88,7 @@ handleCommand c = case c of liftIO exitSuccess findCompletions :: Ide m => - [Filter] -> Matcher IdeDeclaration -> Maybe P.ModuleName -> m Success + [Filter] -> Matcher IdeDeclarationAnn -> Maybe P.ModuleName -> m Success findCompletions filters matcher currentModule = do modules <- getAllModules currentModule pure . CompletionResult . map completionFromMatch . getCompletions filters matcher $ modules @@ -97,7 +97,7 @@ findType :: Ide m => Text -> [Filter] -> Maybe P.ModuleName -> m Success findType search filters currentModule = do modules <- getAllModules currentModule - pure . InfoResult . map infoFromMatch . getExactMatches search filters $ modules + pure . CompletionResult . map completionFromMatch . getExactMatches search filters $ modules findPursuitCompletions :: MonadIO m => PursuitQuery -> m Success diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 0d6e48cdda..966afd2576 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -34,7 +34,7 @@ data Command } | Complete { completeFilters :: [Filter] - , completeMatcher :: Matcher IdeDeclaration + , completeMatcher :: Matcher IdeDeclarationAnn , completeCurrentModule :: Maybe P.ModuleName } | Pursuit diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 04c0e7db27..acb667566b 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -9,24 +9,23 @@ import Protolude import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util -- | Applies the CompletionFilters and the Matcher to the given Modules -- and sorts the found Completions according to the Matching Score getCompletions :: [Filter] - -> Matcher IdeDeclaration + -> Matcher IdeDeclarationAnn -> [Module] - -> [Match IdeDeclaration] + -> [Match IdeDeclarationAnn] getCompletions filters matcher modules = - runMatcher matcher (completionsFromModules discardAnn (applyFilters filters modules)) + runMatcher matcher (completionsFromModules (applyFilters filters modules)) getExactMatches :: Text -> [Filter] -> [Module] -> [Match IdeDeclarationAnn] getExactMatches search filters modules = - completionsFromModules identity (applyFilters (equalityFilter search : filters) modules) + completionsFromModules (applyFilters (equalityFilter search : filters) modules) -completionsFromModules :: (IdeDeclarationAnn -> a) -> [Module] -> [Match a] -completionsFromModules f = foldMap completionFromModule +completionsFromModules :: [Module] -> [Match IdeDeclarationAnn] +completionsFromModules = foldMap completionFromModule where completionFromModule (moduleName, decls) = - map (\x -> Match (moduleName, f x)) decls + map (\x -> Match (moduleName, x)) decls diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index a2fb0dbce3..254ac55d4b 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -38,7 +38,7 @@ type ScoredMatch a = (Match a, Double) newtype Matcher a = Matcher (Endo [Match a]) deriving (Monoid) -instance FromJSON (Matcher IdeDeclaration) where +instance FromJSON (Matcher IdeDeclarationAnn) where parseJSON = withObject "matcher" $ \o -> do (matcher :: Maybe Text) <- o .:? "matcher" case matcher of @@ -60,17 +60,17 @@ instance FromJSON (Matcher IdeDeclaration) where -- Examples: -- flMa matches flexMatcher. Score: 14.28 -- sons matches sortCompletions. Score: 6.25 -flexMatcher :: Text -> Matcher IdeDeclaration +flexMatcher :: Text -> Matcher IdeDeclarationAnn flexMatcher p = mkMatcher (flexMatch p) -distanceMatcher :: Text -> Int -> Matcher IdeDeclaration +distanceMatcher :: Text -> Int -> Matcher IdeDeclarationAnn distanceMatcher q maxDist = mkMatcher (distanceMatcher' q maxDist) -distanceMatcher' :: Text -> Int -> [Match IdeDeclaration] -> [ScoredMatch IdeDeclaration] +distanceMatcher' :: Text -> Int -> [Match IdeDeclarationAnn] -> [ScoredMatch IdeDeclarationAnn] distanceMatcher' q maxDist = mapMaybe go where go m = let d = dist (T.unpack y) - y = identifierFromIdeDeclaration (unwrapMatch m) + y = identifierFromIdeDeclaration (discardAnn (unwrapMatch m)) in if d <= maxDist then Just (m, 1 / fromIntegral d) else Nothing @@ -85,12 +85,12 @@ runMatcher (Matcher m)= appEndo m sortCompletions :: [ScoredMatch a] -> [ScoredMatch a] sortCompletions = sortBy (flip compare `on` snd) -flexMatch :: Text -> [Match IdeDeclaration] -> [ScoredMatch IdeDeclaration] +flexMatch :: Text -> [Match IdeDeclarationAnn] -> [ScoredMatch IdeDeclarationAnn] flexMatch = mapMaybe . flexRate -flexRate :: Text -> Match IdeDeclaration -> Maybe (ScoredMatch IdeDeclaration) +flexRate :: Text -> Match IdeDeclarationAnn -> Maybe (ScoredMatch IdeDeclarationAnn) flexRate p c = do - score <- flexScore p (identifierFromIdeDeclaration (unwrapMatch c)) + score <- flexScore p (identifierFromIdeDeclaration (discardAnn (unwrapMatch c))) return (c, score) -- FlexMatching ala Sublime. diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 956fd1eceb..d44f25f113 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -17,12 +17,15 @@ module Language.PureScript.Ide.SourceFile ( parseModule , getImportsForFile + , extractAstInformation + -- for tests , extractSpans , extractTypeAnnotations ) where import Protolude +import qualified Data.Map as Map import qualified Language.PureScript as P import Language.PureScript.Ide.Error import Language.PureScript.Ide.Util @@ -65,6 +68,15 @@ getImportsForFile fp = do unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls) unwrapImportType P.Implicit = P.Implicit +-- | Extracts AST information from a parsed module +extractAstInformation + :: P.Module + -> (DefinitionSites P.SourceSpan, TypeAnnotations) +extractAstInformation (P.Module ss _ _ decls _) = + let definitions = Map.fromList (concatMap (extractSpans ss) decls) + typeAnnotations = Map.fromList (extractTypeAnnotations decls) + in (definitions, typeAnnotations) + -- | Extracts type annotations for functions from a given Module extractTypeAnnotations :: [P.Declaration] diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 01bf2bcae6..be9efc3d1e 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -180,10 +180,7 @@ populateStage2 = do populateStage2STM :: TVar IdeState -> STM () populateStage2STM ref = do modules <- s1Modules <$> getStage1STM ref - let astData = map (\(P.Module ss _ _ decls _, _) -> - let definitions = M.fromList (concatMap (extractSpans ss) decls) - typeAnnotations = M.fromList (extractTypeAnnotations decls) - in (definitions, typeAnnotations)) modules + let astData = map (extractAstInformation . fst) modules setStage2STM ref (Stage2 (AstData astData)) -- | Resolves reexports and populates Stage3 with data to be used in queries. diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 6d5a5d463a..9e05cd290a 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -112,21 +112,25 @@ data Stage3 = Stage3 newtype Match a = Match (P.ModuleName, a) deriving (Show, Eq, Functor) -newtype Completion = - Completion (Text, Text, Text) - deriving (Show,Eq) - -newtype Info = - Info (Text, Text, Text, Maybe P.SourceSpan) - deriving (Show,Eq) - -instance ToJSON Info where - toJSON (Info (m, d, t, sourceSpan)) = - object ["module" .= m, "identifier" .= d, "type" .= t, "definedAt" .= sourceSpan] +-- | A completion as it gets sent to the editors +data Completion = Completion + { complModule :: Text + , complIdentifier :: Text + , complType :: Text + , complExpandedType :: Text + , complLocation :: Maybe P.SourceSpan + , complDocumentation :: Maybe Text + } deriving (Show, Eq) instance ToJSON Completion where - toJSON (Completion (m, d, t)) = - object ["module" .= m, "identifier" .= d, "type" .= t] + toJSON (Completion {..}) = + object [ "module" .= complModule + , "identifier" .= complIdentifier + , "type" .= complType + , "expandedType" .= complExpandedType + , "definedAt" .= complLocation + , "documentation" .= complDocumentation + ] data ModuleImport = ModuleImport @@ -164,14 +168,13 @@ identifierFromDeclarationRef _ = "" data Success = CompletionResult [Completion] - | InfoResult [Info] | TextResult Text | MultilineTextResult [Text] | PursuitResult [PursuitResponse] | ImportList [ModuleImport] | ModuleList [ModuleIdent] | RebuildSuccess [P.JSONError] - deriving(Show, Eq) + deriving (Show, Eq) encodeSuccess :: (ToJSON a) => a -> Value encodeSuccess res = @@ -179,7 +182,6 @@ encodeSuccess res = instance ToJSON Success where toJSON (CompletionResult cs) = encodeSuccess cs - toJSON (InfoResult i) = encodeSuccess i toJSON (TextResult t) = encodeSuccess t toJSON (MultilineTextResult ts) = encodeSuccess ts toJSON (PursuitResult resp) = encodeSuccess resp diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index c493638290..ea291dcef9 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -20,10 +20,10 @@ module Language.PureScript.Ide.Util , unwrapPositioned , unwrapPositionedRef , completionFromMatch - , infoFromMatch , encodeT , decodeT , discardAnn + , withEmptyAnn , module Language.PureScript.Ide.Conversions ) where @@ -48,25 +48,35 @@ identifierFromIdeDeclaration d = case d of discardAnn :: IdeDeclarationAnn -> IdeDeclaration discardAnn (IdeDeclarationAnn _ d) = d +withEmptyAnn :: IdeDeclaration -> IdeDeclarationAnn +withEmptyAnn = IdeDeclarationAnn emptyAnn + unwrapMatch :: Match a -> a unwrapMatch (Match (_, ed)) = ed -completionFromMatch :: Match IdeDeclaration -> Completion -completionFromMatch = Completion . completionFromMatch' - -completionFromMatch' :: Match IdeDeclaration -> (Text, Text, Text) -completionFromMatch' (Match (m', d)) = case d of - IdeValue name type' -> (m, runIdentT name, prettyTypeT type') - IdeType name kind -> (m, runProperNameT name, toS (P.prettyPrintKind kind)) - IdeTypeSynonym name kind -> (m, runProperNameT name, prettyTypeT kind) - IdeDataConstructor name _ type' -> (m, runProperNameT name, prettyTypeT type') - IdeTypeClass name -> (m, runProperNameT name, "class") - IdeValueOperator op ref precedence associativity -> - (m, runOpNameT op, showFixity precedence associativity ref op) - IdeTypeOperator op ref precedence associativity -> - (m, runOpNameT op, showFixity precedence associativity ref op) +completionFromMatch :: Match IdeDeclarationAnn -> Completion +completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) = + Completion {..} where - m = runModuleNameT m' + (complIdentifier, complExpandedType) = case decl of + IdeValue name type' -> (runIdentT name, prettyTypeT type') + IdeType name kind -> (runProperNameT name, toS (P.prettyPrintKind kind)) + IdeTypeSynonym name kind -> (runProperNameT name, prettyTypeT kind) + IdeDataConstructor name _ type' -> (runProperNameT name, prettyTypeT type') + IdeTypeClass name -> (runProperNameT name, "class") + IdeValueOperator op ref precedence associativity -> + (runOpNameT op, showFixity precedence associativity ref op) + IdeTypeOperator op ref precedence associativity -> + (runOpNameT op, showFixity precedence associativity ref op) + + complModule = runModuleNameT m + + complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann) + + complLocation = annLocation ann + + complDocumentation = Nothing + showFixity p a r o = let asso = case a of P.Infix -> "infix" @@ -74,12 +84,6 @@ completionFromMatch' (Match (m', d)) = case d of P.Infixr -> "infixr" in T.unwords [asso, show p, r, "as", runOpNameT o] -infoFromMatch :: Match IdeDeclarationAnn -> Info -infoFromMatch (Match (m, IdeDeclarationAnn ann d)) = - Info (a, b, maybe c prettyTypeT (annTypeAnnotation ann), annLocation ann) - where - (a, b, c) = completionFromMatch' (Match (m, d)) - encodeT :: (ToJSON a) => a -> Text encodeT = toS . decodeUtf8 . encode @@ -87,9 +91,9 @@ decodeT :: (FromJSON a) => Text -> Maybe a decodeT = decode . encodeUtf8 . toS unwrapPositioned :: P.Declaration -> P.Declaration -unwrapPositioned (P.PositionedDeclaration _ _ x) = x +unwrapPositioned (P.PositionedDeclaration _ _ x) = unwrapPositioned x unwrapPositioned x = x unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef -unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = x +unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x unwrapPositionedRef x = x diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs index ce89093c25..92569d0fc4 100644 --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -37,13 +37,11 @@ module Language.PureScript.Ide.Integration , getFlexCompletions , getFlexCompletionsInModule , getType - , getInfo , rebuildModule , reset -- checking results , resultIsSuccess , parseCompletions - , parseInfo , parseTextResult ) where @@ -158,18 +156,15 @@ loadModules = sendCommand . load loadAll :: IO Text loadAll = sendCommand (load []) -getFlexCompletions :: Text -> IO [(Text, Text, Text)] +getFlexCompletions :: Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)] getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) Nothing) -getFlexCompletionsInModule :: Text -> Text -> IO [(Text, Text, Text)] +getFlexCompletionsInModule :: Text -> Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)] getFlexCompletionsInModule q m = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) (Just m)) -getType :: Text -> IO [(Text, Text, Text)] +getType :: Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)] getType q = parseCompletions <$> sendCommand (typeC q []) -getInfo :: Text -> IO [P.SourceSpan] -getInfo q = parseInfo <$> sendCommand (typeC q []) - addImport :: Text -> FilePath -> FilePath -> IO Text addImport identifier fp outfp = sendCommand (addImportC identifier fp outfp) @@ -254,17 +249,14 @@ withResult p v = do Left err -> pure (Left err) Right res -> Right <$> p res -completionParser :: Value -> Parser [(Text, Text, Text)] +completionParser :: Value -> Parser [(Text, Text, Text, Maybe P.SourceSpan)] completionParser = withArray "res" $ \cs -> mapM (withObject "completion" $ \o -> do ident <- o .: "identifier" module' <- o .: "module" ty <- o .: "type" - pure (module', ident, ty)) (V.toList cs) - -infoParser :: Value -> Parser [P.SourceSpan] -infoParser = withArray "res" $ \cs -> - mapM (withObject "info" $ \o -> o .: "definedAt") (V.toList cs) + ss <- o .: "definedAt" + pure (module', ident, ty, ss)) (V.toList cs) valueFromText :: Text -> Value valueFromText = fromJust . decode . toS @@ -272,14 +264,10 @@ valueFromText = fromJust . decode . toS resultIsSuccess :: Text -> Bool resultIsSuccess = isRight . join . first toS . parseEither unwrapResult . valueFromText -parseCompletions :: Text -> [(Text, Text, Text)] +parseCompletions :: Text -> [(Text, Text, Text, Maybe P.SourceSpan)] parseCompletions s = fromJust $ join (rightToMaybe <$> parseMaybe (withResult completionParser) (valueFromText s)) -parseInfo :: Text -> [P.SourceSpan] -parseInfo s = - fromJust $ join (rightToMaybe <$> parseMaybe (withResult infoParser) (valueFromText s)) - parseTextResult :: Text -> Text parseTextResult s = fromJust $ join (rightToMaybe <$> parseMaybe (withResult (withText "tr" pure)) (valueFromText s)) diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs index 04d0ae59a8..6a8b2df15e 100644 --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -9,20 +9,21 @@ import qualified Language.PureScript as P import Language.PureScript.Ide.Integration import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util import Test.Hspec -value :: Text -> IdeDeclaration -value s = IdeValue (P.Ident (toS s)) P.REmpty +value :: Text -> IdeDeclarationAnn +value s = withEmptyAnn (IdeValue (P.Ident (toS s)) P.REmpty) -firstResult, secondResult, fiult :: Match IdeDeclaration +firstResult, secondResult, fiult :: Match IdeDeclarationAnn firstResult = Match (P.moduleNameFromString "Match", value "firstResult") secondResult = Match (P.moduleNameFromString "Match", value "secondResult") fiult = Match (P.moduleNameFromString "Match", value "fiult") -completions :: [Match IdeDeclaration] +completions :: [Match IdeDeclarationAnn] completions = [firstResult, secondResult, fiult] -runFlex :: Text -> [Match IdeDeclaration] +runFlex :: Text -> [Match IdeDeclarationAnn] runFlex s = runMatcher (flexMatcher s) completions setup :: IO () @@ -43,5 +44,6 @@ spec = do cs <- getFlexCompletions "" cs `shouldBe` [] it "matches on equality" $ do - cs <- getFlexCompletions "const" - cs `shouldBe` [("MatcherSpec", "const", "forall a b. a -> b -> a")] + -- ignore any position information + (m, i, t, _) : _ <- getFlexCompletions "const" + (m, i, t) `shouldBe` ("MatcherSpec", "const", "forall a b. a -> b -> a") diff --git a/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs b/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs index 66d3bb0d55..4fd6056a60 100644 --- a/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs @@ -31,6 +31,11 @@ spec = beforeAll_ setup $ testCase :: Text -> (Int, Int) -> IO () testCase s (x, y) = do - P.SourceSpan f (P.SourcePos l c) _ : _ <- Integration.getInfo s + P.SourceSpan f (P.SourcePos l c) _ <- getLocation s toS f `shouldSatisfy` T.isSuffixOf "SourceFileSpec.purs" (l, c) `shouldBe` (x, y) + +getLocation :: Text -> IO P.SourceSpan +getLocation s = do + (_, _, _, Just location) : _ <- Integration.getType s + pure location diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 631dcb1244..6dbab40f92 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -13,7 +13,8 @@ span0 = P.SourceSpan "ModuleLevel" (P.SourcePos 0 0) (P.SourcePos 1 1) span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2) span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3) -value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, member1 :: P.Declaration +typeAnnotation1, value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, member1 :: P.Declaration +typeAnnotation1 = P.TypeDeclaration (P.Ident "value1") P.REmpty value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left []) synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty class1 = P.TypeClassDeclaration (P.ProperName "Class1") [] [] [] @@ -26,7 +27,7 @@ foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.Star member1 = P.TypeDeclaration (P.Ident "member1") P.REmpty spec :: Spec -spec = +spec = do describe "Extracting Spans" $ do it "extracts a span for a value declaration" $ extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(Left "value1", span1)] @@ -44,3 +45,6 @@ spec = extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(Left "foreign1", span1)] it "extracts a span for a data foreign declaration" $ extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(Right "Foreign2", span1)] + describe "Type annotations" $ do + it "extracts a type annotation" $ + extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.REmpty)] From ebd7c3cfb2b7ad1133c05bf5b1fd5a3f266413b4 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 15 Sep 2016 17:42:39 -0700 Subject: [PATCH 0490/1580] Newtype Deriving (#2304) * Newtype deriving * Syntax changes. Rename SuperclassDictionary to DeferredDictionary * Examples, generalize --- examples/failing/NewtypeInstance.purs | 8 +++++ examples/failing/NewtypeInstance2.purs | 8 +++++ examples/failing/NewtypeInstance3.purs | 8 +++++ examples/failing/NewtypeInstance4.purs | 8 +++++ examples/passing/NewtypeInstance.purs | 30 +++++++++++++++++++ src/Language/PureScript/AST/Declarations.hs | 14 ++++++--- src/Language/PureScript/AST/Traversals.hs | 2 +- src/Language/PureScript/Errors.hs | 10 +++++++ .../PureScript/Parser/Declarations.hs | 5 +++- src/Language/PureScript/Pretty/Values.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 4 +-- src/Language/PureScript/Sugar/TypeClasses.hs | 8 +++-- .../PureScript/Sugar/TypeClasses/Deriving.hs | 25 ++++++++++++++++ .../PureScript/TypeChecker/Skolems.hs | 6 ++-- src/Language/PureScript/TypeChecker/Types.hs | 4 +-- 15 files changed, 126 insertions(+), 16 deletions(-) create mode 100644 examples/failing/NewtypeInstance.purs create mode 100644 examples/failing/NewtypeInstance2.purs create mode 100644 examples/failing/NewtypeInstance3.purs create mode 100644 examples/failing/NewtypeInstance4.purs create mode 100644 examples/passing/NewtypeInstance.purs diff --git a/examples/failing/NewtypeInstance.purs b/examples/failing/NewtypeInstance.purs new file mode 100644 index 0000000000..3ffe08036e --- /dev/null +++ b/examples/failing/NewtypeInstance.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidNewtypeInstance +module Main where + +import Prelude + +data X = X + +derive newtype instance showX :: Show X diff --git a/examples/failing/NewtypeInstance2.purs b/examples/failing/NewtypeInstance2.purs new file mode 100644 index 0000000000..67b16fcbe3 --- /dev/null +++ b/examples/failing/NewtypeInstance2.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidNewtypeInstance +module Main where + +import Prelude + +data X a = X a a + +derive newtype instance showX :: Show a => Show (X a) diff --git a/examples/failing/NewtypeInstance3.purs b/examples/failing/NewtypeInstance3.purs new file mode 100644 index 0000000000..528eefb67f --- /dev/null +++ b/examples/failing/NewtypeInstance3.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidNewtypeInstance +module Main where + +import Prelude + +class Nullary + +derive newtype instance nullary :: Nullary diff --git a/examples/failing/NewtypeInstance4.purs b/examples/failing/NewtypeInstance4.purs new file mode 100644 index 0000000000..4004520b4f --- /dev/null +++ b/examples/failing/NewtypeInstance4.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidNewtypeInstance +module Main where + +import Prelude + +data X = X | Y + +derive newtype instance showX :: Show X diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs new file mode 100644 index 0000000000..416405a015 --- /dev/null +++ b/examples/passing/NewtypeInstance.purs @@ -0,0 +1,30 @@ +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console + +newtype X = X String + +derive newtype instance showX :: Show X + +derive newtype instance eqX :: Eq X + +derive newtype instance ordX :: Ord X + +newtype Y a = Y (Array a) + +derive newtype instance showY :: Show (Y String) + +class Singleton a b where + singleton :: a -> b + +instance singletonArray :: Singleton a (Array a) where + singleton x = [x] + +derive newtype instance singletonY :: Singleton a (Y a) + +main = do + logShow (X "test") + logShow (singleton "test" :: Y String) + log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index d0de7e674c..740bfc9eb8 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -77,6 +77,7 @@ data SimpleErrorMessage | NoInstanceFound Constraint | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type] | CannotDerive (Qualified (ProperName 'ClassName)) [Type] + | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type] | CannotFindDerivingType (ProperName 'TypeName) | DuplicateLabel String (Maybe Expr) | DuplicateValueDeclaration Ident @@ -374,10 +375,15 @@ pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFix -- | The members of a type class instance declaration data TypeInstanceBody - -- | This is a derived instance = DerivedInstance - -- | This is a regular (explicit) instance + -- ^ This is a derived instance + | NewtypeInstance + -- ^ This is an instance derived from a newtype + | NewtypeInstanceWithDictionary Expr + -- ^ This is an instance derived from a newtype, desugared to include a + -- dictionary for the type under the newtype. | ExplicitInstance [Declaration] + -- ^ This is a regular (explicit) instance deriving (Show) mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody @@ -385,8 +391,8 @@ mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f) -- | A traversal for TypeInstanceBody traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody -traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds +traverseTypeInstanceBody _ other = pure other -- | -- Test if a declaration is a value declaration @@ -570,7 +576,7 @@ data Expr -- | -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking -- - | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type] + | DeferredDictionary (Qualified (ProperName 'ClassName)) [Type] -- | -- A placeholder for an anonymous function argument -- diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 7a851fbf86..4271166326 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -583,6 +583,6 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con forDecls _ = mempty forValues (TypeClassDictionary c _ _) = mconcat (map f (constraintArgs c)) - forValues (SuperClassDictionary _ tys) = mconcat (map f tys) + forValues (DeferredDictionary _ tys) = mconcat (map f tys) forValues (TypedValue _ _ ty) = f ty forValues _ = mempty diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 5be9fe20a1..39e3e7b640 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -120,6 +120,7 @@ errorCode em = case unwrapErrorMessage em of NoInstanceFound{} -> "NoInstanceFound" PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance" CannotDerive{} -> "CannotDerive" + InvalidNewtypeInstance{} -> "InvalidNewtypeInstance" CannotFindDerivingType{} -> "CannotFindDerivingType" DuplicateLabel{} -> "DuplicateLabel" DuplicateValueDeclaration{} -> "DuplicateValueDeclaration" @@ -262,6 +263,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts + gSimple (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx @@ -642,6 +644,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , Box.vcat Box.left (map typeAtomAsBox ts) ] ] + renderSimpleErrorMessage (InvalidNewtypeInstance nm ts) = + paras [ line "Cannot derive newtype instance for" + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] + , line "Make sure this is a newtype." + ] renderSimpleErrorMessage (CannotFindDerivingType nm) = line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found." renderSimpleErrorMessage (DuplicateLabel l expr) = diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index c8e66e7f93..890a46e134 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -17,6 +17,7 @@ module Language.PureScript.Parser.Declarations import Prelude hiding (lex) +import Data.Functor (($>)) import Data.Maybe (fromMaybe) import Control.Applicative @@ -192,6 +193,7 @@ parseConstraint :: TokenParser Constraint parseConstraint = Constraint <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom) <*> pure Nothing + parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) parseInstanceDeclaration = do reserved "instance" @@ -216,8 +218,9 @@ parseTypeInstanceDeclaration = do parseDerivingInstanceDeclaration :: TokenParser Declaration parseDerivingInstanceDeclaration = do reserved "derive" + ty <- P.option DerivedInstance (reserved "newtype" $> NewtypeInstance) instanceDecl <- parseInstanceDeclaration - return $ instanceDecl DerivedInstance + return $ instanceDecl ty positioned :: TokenParser Declaration -> TokenParser Declaration positioned = withSourceSpan PositionedDeclaration diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 549fbe9ecb..bd36555911 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -61,7 +61,7 @@ prettyPrintValue d (Let ds val) = prettyPrintValue d (Do els) = text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys -prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) +prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">" prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 10d09d2301..149c5929b9 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -332,9 +332,9 @@ updateTypes goType = (goDecl, goExpr, goBinder) goExpr pos (TypeClassDictionary (Constraint name tys info) dicts hints) = do tys' <- traverse (goType' pos) tys return (pos, TypeClassDictionary (Constraint name tys' info) dicts hints) - goExpr pos (SuperClassDictionary cls tys) = do + goExpr pos (DeferredDictionary cls tys) = do tys' <- traverse (goType' pos) tys - return (pos, SuperClassDictionary cls tys') + return (pos, DeferredDictionary cls tys') goExpr pos (TypedValue check v ty) = do ty' <- goType' pos ty return (pos, TypedValue check v ty') diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 7262224dd7..eec69635e4 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -129,7 +129,7 @@ desugarModule _ = internalError "Exports should have been elaborated in name des -- -- subString :: {} -> Sub String -- subString _ = { sub: "", --- , "__superclass_Foo_0": \_ -> +-- , "__superclass_Foo_0": \_ -> -- } -- -- and finally as the generated javascript: @@ -181,6 +181,10 @@ desugarDecl mn exps = go desugared <- desugarCases members dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared return (expRef name className tys, [d, dictDecl]) + go d@(TypeInstanceDeclaration name deps className tys (NewtypeInstanceWithDictionary dict)) = do + let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys + constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy) + return (expRef name className tys, [d, ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))]) go (PositionedDeclaration pos com d) = do (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d return (dr, map (PositionedDeclaration pos com) ds) @@ -287,7 +291,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = -- The type is a record type, but depending on type instance dependencies, may be constrained. -- The dictionary itself is a record literal. let superclasses = superClassDictionaryNames implies `zip` - [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs) + [ Abs (Left (Ident C.__unused)) (DeferredDictionary superclass tyArgs) | (Constraint superclass suTyArgs _) <- implies , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs ] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 086d4ae18c..ff57c7e1f7 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -54,6 +54,12 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) = throwError . errorMessage $ CannotDerive className tys +deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance) + | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys) + , mn == fromMaybe mn mn' + = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance className ds tys tyCon args +deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance) + = throwError . errorMessage $ InvalidNewtypeInstance className tys deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d deriveInstance _ _ e = return e @@ -66,6 +72,25 @@ unwrapTypeConstructor = fmap (second reverse) . go return (tyCon, arg : args) go _ = Nothing +deriveNewtypeInstance + :: forall m + . MonadError MultipleErrors m + => Qualified (ProperName 'ClassName) + -> [Declaration] + -> [Type] + -> ProperName 'TypeName + -> [Type] + -> m Expr +deriveNewtypeInstance className ds tys tyConNm dargs = do + tyCon <- findTypeDecl tyConNm ds + go tyCon + where + go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])]) = do + let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs + return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped])) + go (PositionedDeclaration _ _ d) = go d + go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys + dataGeneric :: ModuleName dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 62d61089ad..b0ca42fdd2 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -61,7 +61,7 @@ skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss) -- | -- This function has one purpose - to skolemize type variables appearing in a --- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the +-- DeferredDictionary placeholder. These type variables are somewhat unique since they are the -- only example of scoped type variables. -- skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr @@ -71,8 +71,8 @@ skolemizeTypesInValue ident sko scope ss = in runIdentity . f where onExpr :: [String] -> Expr -> Identity ([String], Expr) - onExpr sco (SuperClassDictionary c ts) - | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope ss) ts)) + onExpr sco (DeferredDictionary c ts) + | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts)) onExpr sco (TypedValue check val ty) | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty)) onExpr sco other = return (sco, other) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 8a97bdb2c4..5b2136dc9b 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -311,7 +311,7 @@ infer' (IfThenElse cond th el) = do infer' (Let ds val) = do (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer return $ TypedValue True (Let ds' val') valTy -infer' (SuperClassDictionary className tys) = do +infer' (DeferredDictionary className tys) = do dicts <- getTypeClassDictionaries hints <- gets checkHints return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints @@ -583,7 +583,7 @@ check' v@(Var var) ty = do case v' of Nothing -> internalError "check: unable to check the subsumes relation." Just v'' -> return $ TypedValue True v'' ty' -check' (SuperClassDictionary className tys) _ = do +check' (DeferredDictionary className tys) _ = do {- -- Here, we replace a placeholder for a superclass dictionary with a regular -- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the From 9a5d4c9a1c2c8c9bf3758dd604564fcf9dee04bb Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 16 Sep 2016 16:02:50 +0200 Subject: [PATCH 0491/1580] [psc-ide] look up types/kinds for operators --- purescript.cabal | 1 + src/Language/PureScript/Ide/Externs.hs | 14 +-- src/Language/PureScript/Ide/Imports.hs | 4 +- src/Language/PureScript/Ide/Reexports.hs | 4 +- src/Language/PureScript/Ide/State.hs | 100 ++++++++++++++++--- src/Language/PureScript/Ide/Types.hs | 4 +- src/Language/PureScript/Ide/Util.hs | 24 +++-- tests/Language/PureScript/Ide/ImportsSpec.hs | 2 +- tests/Language/PureScript/Ide/StateSpec.hs | 51 ++++++++++ tests/TestPscIde.hs | 1 + 10 files changed, 170 insertions(+), 35 deletions(-) create mode 100644 tests/Language/PureScript/Ide/StateSpec.hs diff --git a/purescript.cabal b/purescript.cabal index 505e441929..aa089e1cb5 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -521,5 +521,6 @@ test-suite tests Language.PureScript.Ide.ReexportsSpec Language.PureScript.Ide.SourceFile.IntegrationSpec Language.PureScript.Ide.SourceFileSpec + Language.PureScript.Ide.StateSpec buildable: True hs-source-dirs: tests diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index abc37e5e99..4e00d8c0a9 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -87,17 +87,19 @@ convertOperator :: P.ExternsFixity -> IdeDeclaration convertOperator P.ExternsFixity{..} = IdeValueOperator efOperator - (toS (P.showQualified (either P.runIdent P.runProperName) efAlias)) + efAlias efPrecedence efAssociativity + Nothing convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration convertTypeOperator P.ExternsTypeFixity{..} = IdeTypeOperator efTypeOperator - (toS (P.showQualified P.runProperName efTypeAlias)) + efTypeAlias efTypePrecedence efTypeAssociativity + Nothing annotateModule :: (DefinitionSites P.SourceSpan, TypeAnnotations) @@ -118,10 +120,10 @@ annotateModule (defs, types) (moduleName, decls) = annotateValue (runProperNameT i) (IdeDataConstructor i tn t) IdeTypeClass i -> annotateType (runProperNameT i) (IdeTypeClass i) - IdeValueOperator n i p a -> - annotateValue i (IdeValueOperator n i p a) - IdeTypeOperator n i p a -> - annotateType i (IdeTypeOperator n i p a) + IdeValueOperator n i p a t -> + annotateValue (valueOperatorAliasT i) (IdeValueOperator n i p a t) + IdeTypeOperator n i p a k -> + annotateType (typeOperatorAliasT i) (IdeTypeOperator n i p a k) where annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs , annTypeAnnotation = Map.lookup x types diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 8c64aa126e..e9065e988c 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -203,9 +203,9 @@ addExplicitImport' decl moduleName imports = P.TypeRef tn (Just [n]) refFromDeclaration (IdeType n _) = P.TypeRef n (Just []) - refFromDeclaration (IdeValueOperator op _ _ _) = + refFromDeclaration (IdeValueOperator op _ _ _ _) = P.ValueOpRef op - refFromDeclaration (IdeTypeOperator op _ _ _) = + refFromDeclaration (IdeTypeOperator op _ _ _ _) = P.TypeOpRef op refFromDeclaration d = P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d) diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 5fa124127a..dd569944fb 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -91,9 +91,9 @@ resolveRef decls ref = case ref of P.ValueRef i -> findWrapped (\case IdeValue i' _ -> i' == i; _ -> False) P.TypeOpRef name -> - findWrapped (\case IdeTypeOperator n _ _ _ -> n == name; _ -> False) + findWrapped (\case IdeTypeOperator n _ _ _ _ -> n == name; _ -> False) P.ValueOpRef name -> - findWrapped (\case IdeValueOperator n _ _ _ -> n == name; _ -> False) + findWrapped (\case IdeValueOperator n _ _ _ _ -> n == name; _ -> False) P.TypeClassRef name -> findWrapped (\case IdeTypeClass n -> n == name; _ -> False) _ -> diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index be9efc3d1e..d20f045bbe 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -28,6 +28,8 @@ module Language.PureScript.Ide.State , populateStage2 , populateStage3 , populateStage3STM + -- for tests + , resolveOperatorsForModule ) where import Protolude @@ -35,7 +37,8 @@ import qualified Prelude import Control.Concurrent.STM import "monad-logger" Control.Monad.Logger -import qualified Data.Map.Lazy as M +import qualified Data.Map.Lazy as Map +import qualified Data.List as List import Language.PureScript.Externs import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Reexports @@ -55,10 +58,10 @@ resetIdeState = do -- | Gets the loaded Modulenames getLoadedModulenames :: Ide m => m [P.ModuleName] -getLoadedModulenames = M.keys <$> getExternFiles +getLoadedModulenames = Map.keys <$> getExternFiles -- | Gets all loaded ExternFiles -getExternFiles :: Ide m => m (M.Map P.ModuleName ExternsFile) +getExternFiles :: Ide m => m (Map P.ModuleName ExternsFile) getExternFiles = s1Externs <$> getStage1 -- | Insert a Module into Stage1 of the State @@ -72,7 +75,7 @@ insertModuleSTM :: TVar IdeState -> (FilePath, P.Module) -> STM () insertModuleSTM ref (fp, module') = modifyTVar ref $ \x -> x { ideStage1 = (ideStage1 x) { - s1Modules = M.insert + s1Modules = Map.insert (P.getModuleName module') (module', fp) (s1Modules (ideStage1 x))}} @@ -126,17 +129,24 @@ getAllModules mmoduleName = do declarations <- s3Declarations <$> getStage3 rebuild <- cachedRebuild case mmoduleName of - Nothing -> pure (M.toList declarations) + Nothing -> pure (Map.toList declarations) Just moduleName -> case rebuild of Just (cachedModulename, ef) | cachedModulename == moduleName -> do (AstData asts) <- s2AstData <$> getStage2 - let ast = fromMaybe (M.empty, M.empty) (M.lookup moduleName asts) - pure . M.toList $ - M.insert moduleName - (snd . annotateModule ast . fst . convertExterns $ ef) declarations - _ -> pure (M.toList declarations) + let + ast = + fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts) + cachedModule = + snd . annotateModule ast . fst . convertExterns $ ef + tmp = + Map.insert moduleName cachedModule declarations + resolved = + Map.adjust (resolveOperatorsForModule tmp) moduleName tmp + + pure (Map.toList resolved) + _ -> pure (Map.toList declarations) -- | Adds an ExternsFile into psc-ide's State Stage1. This does not populate the -- following Stages, which needs to be done after all the necessary Exterms have @@ -151,7 +161,7 @@ insertExternsSTM :: TVar IdeState -> ExternsFile -> STM () insertExternsSTM ref ef = modifyTVar ref $ \x -> x { ideStage1 = (ideStage1 x) { - s1Externs = M.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}} + s1Externs = Map.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}} -- | Sets rebuild cache to the given ExternsFile cacheRebuild :: Ide m => ExternsFile -> m () @@ -202,12 +212,70 @@ populateStage3STM :: TVar IdeState -> STM [ReexportResult Module] populateStage3STM ref = do externs <- s1Externs <$> getStage1STM ref (AstData asts) <- s2AstData <$> getStage2STM ref - let modules = M.map convertExterns externs + let modules = Map.map convertExterns externs nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)]) - nModules = M.mapWithKey + nModules = Map.mapWithKey (\moduleName (m, refs) -> - (fromMaybe m $ annotateModule <$> M.lookup moduleName asts <*> pure m, refs)) modules + (fromMaybe m $ annotateModule <$> Map.lookup moduleName asts <*> pure m, refs)) modules -- resolves reexports and discards load failures for now - result = resolveReexports (M.map (snd . fst) nModules) <$> M.elems nModules - setStage3STM ref (Stage3 (M.fromList (map reResolved result)) Nothing) + result = resolveReexports (map (snd . fst) nModules) <$> Map.elems nModules + resultP = resolveOperators (Map.fromList (reResolved <$> result)) + setStage3STM ref (Stage3 resultP Nothing) pure result + +resolveOperators + :: Map P.ModuleName [IdeDeclarationAnn] + -> Map P.ModuleName [IdeDeclarationAnn] +resolveOperators modules = + map (resolveOperatorsForModule modules) modules + +-- | Looks up the types and kinds for operators and assigns them to their +-- declarations +resolveOperatorsForModule + :: Map P.ModuleName [IdeDeclarationAnn] + -> [IdeDeclarationAnn] + -> [IdeDeclarationAnn] +resolveOperatorsForModule modules = map (mapIdeDeclaration resolveOperator) + where + resolveOperator (IdeValueOperator + opName + i@(P.Qualified (Just moduleName) + (Left ident)) precedence assoc _) = + let t = do + sourceModule <- Map.lookup moduleName modules + IdeValue _ tP <- + List.find (\case + IdeValue iP _ -> iP == ident + _ -> False) (discardAnn <$> sourceModule) + pure tP + + in IdeValueOperator opName i precedence assoc t + resolveOperator (IdeValueOperator + opName + i@(P.Qualified (Just moduleName) + (Right ctor)) precedence assoc _) = + let t = do + sourceModule <- Map.lookup moduleName modules + IdeDataConstructor _ _ tP <- + List.find (\case + IdeDataConstructor cname _ _ -> ctor == cname + _ -> False) (discardAnn <$> sourceModule) + pure tP + + in IdeValueOperator opName i precedence assoc t + resolveOperator (IdeTypeOperator + opName + i@(P.Qualified (Just moduleName) properName) precedence assoc _) = + let k = do + sourceModule <- Map.lookup moduleName modules + IdeType _ kP <- + List.find (\case + IdeType name _ -> name == properName + _ -> False) (discardAnn <$> sourceModule) + pure kP + + in IdeTypeOperator opName i precedence assoc k + resolveOperator x = x + +mapIdeDeclaration :: (IdeDeclaration -> IdeDeclaration) -> IdeDeclarationAnn -> IdeDeclarationAnn +mapIdeDeclaration f (IdeDeclarationAnn ann decl) = IdeDeclarationAnn ann (f decl) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 9e05cd290a..a76e96eb29 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -36,8 +36,8 @@ data IdeDeclaration | IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type | IdeDataConstructor (P.ProperName 'P.ConstructorName) (P.ProperName 'P.TypeName) P.Type | IdeTypeClass (P.ProperName 'P.ClassName) - | IdeValueOperator (P.OpName 'P.ValueOpName) Text P.Precedence P.Associativity - | IdeTypeOperator (P.OpName 'P.TypeOpName) Text P.Precedence P.Associativity + | IdeValueOperator (P.OpName 'P.ValueOpName) (P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName))) P.Precedence P.Associativity (Maybe P.Type) + | IdeTypeOperator (P.OpName 'P.TypeOpName) (P.Qualified (P.ProperName 'P.TypeName)) P.Precedence P.Associativity (Maybe P.Kind) deriving (Show, Eq, Ord) data IdeDeclarationAnn = IdeDeclarationAnn Annotation IdeDeclaration diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index ea291dcef9..b0bcc30675 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -24,6 +24,8 @@ module Language.PureScript.Ide.Util , decodeT , discardAnn , withEmptyAnn + , valueOperatorAliasT + , typeOperatorAliasT , module Language.PureScript.Ide.Conversions ) where @@ -42,8 +44,8 @@ identifierFromIdeDeclaration d = case d of IdeTypeSynonym name _ -> runProperNameT name IdeDataConstructor name _ _ -> runProperNameT name IdeTypeClass name -> runProperNameT name - IdeValueOperator op _ _ _ -> runOpNameT op - IdeTypeOperator op _ _ _ -> runOpNameT op + IdeValueOperator op _ _ _ _ -> runOpNameT op + IdeTypeOperator op _ _ _ _ -> runOpNameT op discardAnn :: IdeDeclarationAnn -> IdeDeclaration discardAnn (IdeDeclarationAnn _ d) = d @@ -64,10 +66,10 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) = IdeTypeSynonym name kind -> (runProperNameT name, prettyTypeT kind) IdeDataConstructor name _ type' -> (runProperNameT name, prettyTypeT type') IdeTypeClass name -> (runProperNameT name, "class") - IdeValueOperator op ref precedence associativity -> - (runOpNameT op, showFixity precedence associativity ref op) - IdeTypeOperator op ref precedence associativity -> - (runOpNameT op, showFixity precedence associativity ref op) + IdeValueOperator op ref precedence associativity typeP -> + (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP) + IdeTypeOperator op ref precedence associativity kind -> + (runOpNameT op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind) complModule = runModuleNameT m @@ -84,6 +86,16 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) = P.Infixr -> "infixr" in T.unwords [asso, show p, r, "as", runOpNameT o] +valueOperatorAliasT + :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text +valueOperatorAliasT i = + toS (P.showQualified (either P.runIdent P.runProperName) i) + +typeOperatorAliasT + :: P.Qualified (P.ProperName 'P.TypeName) -> Text +typeOperatorAliasT i = + toS (P.showQualified P.runProperName i) + encodeT :: (ToJSON a) => a -> Text encodeT = toS . decodeUtf8 . encode diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 5680020372..7cea546de9 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -70,7 +70,7 @@ spec = do addValueImport i mn is = prettyPrintImportSection (addExplicitImport' (IdeValue (P.Ident i) wildcard) mn is) addOpImport op mn is = - prettyPrintImportSection (addExplicitImport' (IdeValueOperator op "" 2 P.Infix) mn is) + prettyPrintImportSection (addExplicitImport' (IdeValueOperator op (P.Qualified Nothing (Left (P.Ident ""))) 2 P.Infix Nothing) mn is) addDtorImport i t mn is = prettyPrintImportSection (addExplicitImport' (IdeDataConstructor (P.ProperName i) t wildcard) mn is) it "adds an implicit unqualified import" $ diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs new file mode 100644 index 0000000000..87b50d266f --- /dev/null +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Language.PureScript.Ide.StateSpec where + +import Protolude +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.State +import qualified Language.PureScript as P +import Test.Hspec +import qualified Data.Map as Map + +valueOperator :: Maybe P.Type -> IdeDeclarationAnn +valueOperator = + d . IdeValueOperator (P.OpName "<$>") (P.Qualified (Just (mn "Test")) (Left (P.Ident "function"))) 2 P.Infix + +ctorOperator :: Maybe P.Type -> IdeDeclarationAnn +ctorOperator = + d . IdeValueOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (Right (P.ProperName "Cons"))) 2 P.Infix + +typeOperator :: Maybe P.Kind -> IdeDeclarationAnn +typeOperator = + d . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix + +testModule :: Module +testModule = (mn "Test", [ d (IdeValue (P.Ident "function") P.REmpty) + , d (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty)) + , d (IdeType (P.ProperName "List") P.Star) + , valueOperator Nothing + , ctorOperator Nothing + , typeOperator Nothing + ]) + +d :: IdeDeclaration -> IdeDeclarationAnn +d = IdeDeclarationAnn emptyAnn + +mn :: Text -> P.ModuleName +mn = P.moduleNameFromString . toS + +testState :: Map P.ModuleName [IdeDeclarationAnn] +testState = Map.fromList + [ testModule + ] + +spec :: Spec +spec = describe "resolving operators" $ do + it "resolves the type for a value operator" $ + resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (valueOperator (Just P.REmpty)) + it "resolves the type for a constructor operator" $ + resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.REmpty)) + it "resolves the kind for a type operator" $ + resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.Star)) diff --git a/tests/TestPscIde.hs b/tests/TestPscIde.hs index d90b9d2642..bf9e62c39b 100644 --- a/tests/TestPscIde.hs +++ b/tests/TestPscIde.hs @@ -11,4 +11,5 @@ main = do s <- compileTestProject unless s $ fail "Failed to compile .purs sources" + quitServer -- shuts down any left over server (primarily happens during development) withServer (hspec PscIdeSpec.spec) From fc8697a93e355f23f28222d8b0cc438a30e3abe7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=A9mi=20Vion?= Date: Mon, 19 Sep 2016 22:09:02 +0200 Subject: [PATCH 0492/1580] Allow anonymous accessor chains (_.a.b) (#2264) * export desugarDecl from Sugar.ObjectWildcards * Allow anonymous accessor chain (_.a.b) idea discussed in https://github.com/purescript/purescript/issues/1807 * extract anonymous accessor chain in one pass + use foldr --- examples/passing/1807.purs | 14 +++++++++++ .../PureScript/Sugar/ObjectWildcards.hs | 25 ++++++++++++------- 2 files changed, 30 insertions(+), 9 deletions(-) create mode 100644 examples/passing/1807.purs diff --git a/examples/passing/1807.purs b/examples/passing/1807.purs new file mode 100644 index 0000000000..7b221b3416 --- /dev/null +++ b/examples/passing/1807.purs @@ -0,0 +1,14 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +fn = _.b.c.d +a = {b:{c:{d:2}}} + +d :: Int +d = fn a + a.b.c.d + +main = if fn a + a.b.c.d == 4 + then log "Done" + else log "Fail" diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index a8ad706a84..d6d36002fa 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -1,5 +1,6 @@ module Language.PureScript.Sugar.ObjectWildcards ( desugarObjectConstructors + , desugarDecl ) where import Prelude.Compat @@ -21,13 +22,12 @@ desugarObjectConstructors => Module -> m Module desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts - where - desugarDecl :: Declaration -> m Declaration - desugarDecl (PositionedDeclaration pos com d) = rethrowWithPosition pos $ PositionedDeclaration pos com <$> desugarDecl d - desugarDecl other = f other - where - (f, _, _) = everywhereOnValuesTopDownM return desugarExpr return +desugarDecl :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration +desugarDecl (PositionedDeclaration pos com d) = rethrowWithPosition pos $ PositionedDeclaration pos com <$> desugarDecl d +desugarDecl other = fn other + where + (fn, _, _) = everywhereOnValuesTopDownM return desugarExpr return desugarExpr :: Expr -> m Expr desugarExpr AnonymousArgument = throwError . errorMessage $ IncorrectAnonymousArgument @@ -45,9 +45,10 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma obj <- freshIdent' Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps - desugarExpr (Accessor prop u) | isAnonymousArgument u = do - arg <- freshIdent' - return $ Abs (Left arg) (Accessor prop (argToExpr arg)) + desugarExpr (Accessor prop u) + | Just props <- peelAnonAccessorChain u = do + arg <- freshIdent' + return $ Abs (Left arg) $ foldr Accessor (argToExpr arg) (prop:props) desugarExpr (Case args cas) | any isAnonymousArgument args = do argIdents <- forM args freshIfAnon let args' = zipWith (`maybe` argToExpr) args argIdents @@ -73,6 +74,12 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e stripPositionInfo e = e + peelAnonAccessorChain :: Expr -> Maybe [String] + peelAnonAccessorChain (Accessor p e) = (p :) <$> peelAnonAccessorChain e + peelAnonAccessorChain (PositionedValue _ _ e) = peelAnonAccessorChain e + peelAnonAccessorChain AnonymousArgument = Just [] + peelAnonAccessorChain _ = Nothing + isAnonymousArgument :: Expr -> Bool isAnonymousArgument AnonymousArgument = True isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e From 8197c06483c3d630ac2a22829aaa9b7ebe8a4701 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 21 Sep 2016 09:57:06 -0700 Subject: [PATCH 0493/1580] Functional Dependencies (#2279) * Unify types which instance heads force to be equal * More * Strict generalization for now * Loop until fixed point * Stream example * Fix test * Remove unused function argument * Add syntax for functional dependencies * More work on fundeps: * Some refactoring * Store functional dependencies in Environment * Add a (currently breaking) test for fundeps * Coverage condition * Dunzo. More tests * Error messages * Better errors * Fix test * It is complete * Remove errors for fundeps * Fix overlapping instances issue * ... * Tidying * use Map * more tidying * Substitution should take account of types which didn't match exactly * Finally done, add @LiamGoodacre's tests * okay ... * GHC.Generics example * Improved generics example * Get rid of the InstanceContext stuff, it was causing problems with defered constraints. Add test case * Fix a warning * D'oh * Various: 1. Allow wildcards in constraints and show the right inferred type 2. Allow ambiguous types in inferred contexts if they can be solved by some functional dependency 3. Some tidying in the TypeChecker.Monad module. * Fix warning in GHC 8 * Improved constraint simplifier * Fix issue with rows in unification check * Fix a small bug in pretty printing * Only require repeated types to be equal on the solved set --- examples/failing/OverlappingVars.purs | 1 - .../failing/UnifyInTypeInstanceLookup.purs | 22 - examples/passing/FunWithFunDeps.js | 32 ++ examples/passing/FunWithFunDeps.purs | 41 ++ examples/passing/FunctionalDependencies.purs | 21 + examples/passing/GHCGenerics.purs | 140 +++++ examples/passing/NewtypeClass.purs | 39 ++ examples/passing/RowPolyInstanceContext.purs | 2 +- examples/passing/Stream.purs | 26 + .../passing/UnifyInTypeInstanceLookup.purs | 25 + examples/passing/WildcardInInstance.purs | 23 + hierarchy/Main.hs | 4 +- psc-docs/Tags.hs | 2 +- src/Control/Monad/Supply/Class.hs | 4 + src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/AST/Exported.hs | 2 +- src/Language/PureScript/AST/Traversals.hs | 16 +- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- .../PureScript/Docs/Convert/Single.hs | 4 +- src/Language/PureScript/Environment.hs | 68 ++- src/Language/PureScript/Errors.hs | 22 +- src/Language/PureScript/Externs.hs | 53 +- src/Language/PureScript/Ide/SourceFile.hs | 2 +- .../PureScript/Interactive/Completion.hs | 2 +- .../PureScript/Interactive/Printer.hs | 20 +- .../PureScript/Parser/Declarations.hs | 7 +- src/Language/PureScript/Parser/Lexer.hs | 7 + src/Language/PureScript/Pretty/Types.hs | 2 +- src/Language/PureScript/Sugar/Names.hs | 4 +- .../PureScript/Sugar/Names/Exports.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 4 +- src/Language/PureScript/Sugar/TypeClasses.hs | 35 +- src/Language/PureScript/TypeChecker.hs | 26 +- .../PureScript/TypeChecker/Entailment.hs | 503 ++++++++++++------ src/Language/PureScript/TypeChecker/Kinds.hs | 15 +- src/Language/PureScript/TypeChecker/Monad.hs | 48 +- src/Language/PureScript/TypeChecker/Types.hs | 144 +++-- src/Language/PureScript/TypeChecker/Unify.hs | 32 +- .../PureScript/TypeClassDictionaries.hs | 23 - .../Language/PureScript/Ide/SourceFileSpec.hs | 4 +- 40 files changed, 977 insertions(+), 454 deletions(-) delete mode 100644 examples/failing/UnifyInTypeInstanceLookup.purs create mode 100644 examples/passing/FunWithFunDeps.js create mode 100644 examples/passing/FunWithFunDeps.purs create mode 100644 examples/passing/FunctionalDependencies.purs create mode 100644 examples/passing/GHCGenerics.purs create mode 100644 examples/passing/NewtypeClass.purs create mode 100644 examples/passing/Stream.purs create mode 100644 examples/passing/UnifyInTypeInstanceLookup.purs create mode 100644 examples/passing/WildcardInInstance.purs diff --git a/examples/failing/OverlappingVars.purs b/examples/failing/OverlappingVars.purs index 82059acaf5..78919e816d 100644 --- a/examples/failing/OverlappingVars.purs +++ b/examples/failing/OverlappingVars.purs @@ -12,4 +12,3 @@ instance overlappingVarsFoo :: OverlappingVars (Foo a a) where f a = a test = f (Foo "" 0) - diff --git a/examples/failing/UnifyInTypeInstanceLookup.purs b/examples/failing/UnifyInTypeInstanceLookup.purs deleted file mode 100644 index 50aa41ae8c..0000000000 --- a/examples/failing/UnifyInTypeInstanceLookup.purs +++ /dev/null @@ -1,22 +0,0 @@ --- @shouldFailWith NoInstanceFound --- See issue #390. --- TODO: Improve this error. -module Main where - -import Prelude - -data Z = Z -data S n = S n - -data T -data F - -class EQ x y b -instance eqT :: EQ x x T -instance eqF :: EQ x y F - -foreign import test :: forall a b. (EQ a b T) => a -> b -> a - -foreign import anyNat :: forall a. a - -test1 = test anyNat (S Z) diff --git a/examples/passing/FunWithFunDeps.js b/examples/passing/FunWithFunDeps.js new file mode 100644 index 0000000000..dea73d18fe --- /dev/null +++ b/examples/passing/FunWithFunDeps.js @@ -0,0 +1,32 @@ + +//: forall e. FVect Z e +exports.fnil = []; + +//: forall n e. e -> FVect n e -> FVect (S n) e +exports.fcons = function (hd) { + return function (tl) { + return [hd].concat(tl); + }; +}; + +exports.fappend = function (dict) { + return function (left) { + return function (right) { + return left.concat(right); + }; + }; +}; + +exports.fflatten = function (dict) { + return function (v) { + var accRef = []; + for (var indexRef = 0; indexRef < v.length; indexRef += 1) { + accRef = accRef.concat(v[indexRef]); + } + return accRef; + }; +}; + +exports.ftoArray = function (vect) { + return vect; +}; diff --git a/examples/passing/FunWithFunDeps.purs b/examples/passing/FunWithFunDeps.purs new file mode 100644 index 0000000000..fa40b2f994 --- /dev/null +++ b/examples/passing/FunWithFunDeps.purs @@ -0,0 +1,41 @@ +-- Taken from https://github.com/LiamGoodacre/purescript-fun-with-fundeps + +module Main where + +import Control.Monad.Eff.Console (log) + +-- Nat : Type +data Z +data S n + +type S2 n = S (S n) +type S3 n = S (S2 n) +type S4 n = S (S3 n) +type S5 n = S (S4 n) +type S15 n = S5 (S5 (S5 n)) + +class NatPlus l r o | l r -> o +instance natPlusZ :: NatPlus Z r r +instance natPlusS :: (NatPlus l r o) => NatPlus (S l) r (S o) + +class NatMult l r o | l r -> o +instance natMultZ :: NatMult Z n Z +instance natMultS :: (NatMult m n r, NatPlus n r s) => NatMult (S m) n s + +-- Foreign Vect +foreign import data FVect :: * -> * -> * +foreign import fnil :: forall e. FVect Z e +foreign import fcons :: forall n e. e -> FVect n e -> FVect (S n) e +foreign import fappend :: forall l r o e. (NatPlus l r o) => FVect l e -> FVect r e -> FVect o e +foreign import fflatten :: forall f s t o. (NatMult f s o) => FVect f (FVect s t) -> FVect o t +foreign import ftoArray :: forall n e. FVect n e -> Array e + +-- should be able to figure these out +fsingleton x = fcons x fnil +fexample = fcons 1 (fsingleton 2) `fappend` fsingleton 3 `fappend` fcons 4 (fsingleton 5) +fexample2 = fexample `fappend` fexample `fappend` fexample +fexample3 = fsingleton fexample `fappend` fsingleton fexample `fappend` fsingleton fexample + +fexample4 = fflatten fexample3 + +main = log "Done" diff --git a/examples/passing/FunctionalDependencies.purs b/examples/passing/FunctionalDependencies.purs new file mode 100644 index 0000000000..cb8026e591 --- /dev/null +++ b/examples/passing/FunctionalDependencies.purs @@ -0,0 +1,21 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +data Nil +data Cons x xs + +class Append a b c | a b -> c + +instance appendNil :: Append Nil b b + +instance appendCons :: Append xs b c => Append (Cons x xs) b (Cons x c) + +data Proxy a = Proxy + +appendProxy :: forall a b c. Append a b c => Proxy a -> Proxy b -> Proxy c +appendProxy Proxy Proxy = Proxy + +test = appendProxy (Proxy :: Proxy (Cons Int Nil)) (Proxy :: Proxy (Cons String Nil)) + +main = log "Done" diff --git a/examples/passing/GHCGenerics.purs b/examples/passing/GHCGenerics.purs new file mode 100644 index 0000000000..d3f0abe34b --- /dev/null +++ b/examples/passing/GHCGenerics.purs @@ -0,0 +1,140 @@ +-- An example to show how we could implement GHC-style Generics using +-- functional dependencies. +-- +-- See https://hackage.haskell.org/package/base-4.9.0.0/docs/GHC-Generics.html + +module Main where + +import Prelude +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log, logShow) + +-- Representation for types with no constructors +data V1 + +-- Representation for constructors with no arguments +data U1 = U1 + +-- Representation for sum types +data Sum a b = Inl a | Inr b + +infixr 5 type Sum as + + +-- Representation for product types +data Product a b = Product a b + +infixr 6 type Product as * + +-- Representation for data constructors, with the data constructor name indicated +-- at the type level. +data Ctor (name :: Symbol) a = Ctor a + +-- Representation for occurrences of other types in a data type definition. +data K a = K a + +-- The Generic class asserts the existence of a type function from "real" types +-- to representation types, and an isomorphism between them. +class Generic a repr | a -> repr where + to :: a -> repr + from :: repr -> a + +-- We can write an instance for the (recursive) type of lists. Note that these +-- instances would be generated by the compiler ideally. +data List a = Nil | Cons a (List a) + +instance genericList :: Generic (List a) (Ctor "Nil" U1 + Ctor "Cons" (K a * K (List a))) where + to Nil = Inl (Ctor U1) + to (Cons x xs) = Inr (Ctor (Product (K x) (K xs))) + from (Inl (Ctor U1)) = Nil + from (Inr (Ctor (Product (K x) (K xs)))) = Cons x xs + +-- We'd like to refect type level strings (for data constructor names) at the value +-- level, so that we can "show" them. Again, these instances would ideally be derived +-- for us. +class KnownSymbol (sym :: Symbol) where + symbol :: forall proxy. proxy sym -> String + +instance knownSymbolNil :: KnownSymbol "Nil" where + symbol _ = "Nil" + +instance knownSymbolCons :: KnownSymbol "Cons" where + symbol _ = "Cons" + +-- A proxy for a type-level string. +data SProxy (sym :: Symbol) = SProxy + +-- To write generic functions, we create a corresponding type class, and use the +-- type class machinery to infer the correct function based on the representation +-- type. +class GShow a where + gShow :: a -> String + +-- Now provide instances for GShow for the appropriate representation types. +-- Note: we don't have to implement all instances here. + +instance gShowU1 :: GShow U1 where + gShow _ = "" + +instance gShowSum :: (GShow a, GShow b) => GShow (a + b) where + gShow (Inl a) = gShow a + gShow (Inr b) = gShow b + +instance gShowProduct :: (GShow a, GShow b) => GShow (a * b) where + gShow (Product a b) = gShow a <> gShow b + +instance gShowCtor :: (KnownSymbol ctor, GShow a) => GShow (Ctor ctor a) where + gShow (Ctor a) = "(" <> symbol (SProxy :: SProxy ctor) <> gShow a <> ")" + +instance gShowK :: Show a => GShow (K a) where + gShow (K a) = " " <> show a + +-- Now we can implement a generic show function which uses the GShow instance +-- on the representation type. +genericShow :: forall a repr. (Generic a repr, GShow repr) => a -> String +genericShow x = gShow (to x) + +-- Note how the required instance here is Show a, and not Generic a. +-- This allows us to use generic programming on a wider variety of types +-- (including types which contain foreign types) than we can use now. +instance showList :: Show a => Show (List a) where + show xs = genericShow xs -- (we need to eta expand here to avoid stack overflow + -- due to recursion implicit in the instance lookup) + +-- Another example: Eq + +class GEq a where + gEq :: a -> a -> Boolean + +instance gEqU1 :: GEq U1 where + gEq _ _ = true + +instance gEqSum :: (GEq a, GEq b) => GEq (a + b) where + gEq (Inl a1) (Inl a2) = gEq a1 a2 + gEq (Inr b1) (Inr b2) = gEq b1 b2 + gEq _ _ = false + +instance gEqProduct :: (GEq a, GEq b) => GEq (a * b) where + gEq (Product a1 b1) (Product a2 b2) = gEq a1 a2 && gEq b1 b2 + +instance gEqCtor :: (KnownSymbol ctor, GEq a) => GEq (Ctor ctor a) where + gEq (Ctor a1) (Ctor a2) = gEq a1 a2 + +instance gEqK :: Eq a => GEq (K a) where + gEq (K a1) (K a2) = a1 == a2 + +genericEq :: forall a repr. (Generic a repr, GEq repr) => a -> a -> Boolean +genericEq x y = gEq (to x) (to y) + +instance eqList :: Eq a => Eq (List a) where + eq xs ys = genericEq xs ys + +main :: Eff (console :: CONSOLE) Unit +main = do + logShow (Cons 1 Nil) + logShow (Cons 1 (Cons 2 Nil)) + logShow (Cons 'x' (Cons 'y' (Cons 'z' Nil))) + + logShow (Cons 1 (Cons 2 Nil) == Cons 1 (Cons 2 Nil)) + logShow (Cons 1 (Cons 2 Nil) == Cons 1 Nil) + + log "Done" diff --git a/examples/passing/NewtypeClass.purs b/examples/passing/NewtypeClass.purs new file mode 100644 index 0000000000..1352339faa --- /dev/null +++ b/examples/passing/NewtypeClass.purs @@ -0,0 +1,39 @@ +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console + +class Newtype t a | t -> a where + wrap :: a -> t + unwrap :: t -> a + +instance newtypeMultiplicative :: Newtype (Multiplicative a) a where + wrap = Multiplicative + unwrap (Multiplicative a) = a + +data Multiplicative a = Multiplicative a + +instance semiringMultiplicative :: Semiring a => Semigroup (Multiplicative a) where + append (Multiplicative a) (Multiplicative b) = Multiplicative (a * b) + +data Pair a = Pair a a + +foldPair :: forall a s. Semigroup s => (a -> s) -> Pair a -> s +foldPair f (Pair a b) = f a <> f b + +ala + :: forall f t a + . (Functor f, Newtype t a) + => (a -> t) + -> ((a -> t) -> f t) + -> f a +ala _ f = map unwrap (f wrap) + +test = ala Multiplicative foldPair + +test1 = ala Multiplicative foldPair (Pair 2 3) + +main = do + logShow (test (Pair 2 3)) + log "Done" diff --git a/examples/passing/RowPolyInstanceContext.purs b/examples/passing/RowPolyInstanceContext.purs index 0641de0885..caefb72952 100644 --- a/examples/passing/RowPolyInstanceContext.purs +++ b/examples/passing/RowPolyInstanceContext.purs @@ -3,7 +3,7 @@ module Main where import Prelude import Control.Monad.Eff.Console (log) -class T s m where +class T s m | m -> s where state :: (s -> s) -> m Unit data S s a = S (s -> { new :: s, ret :: a }) diff --git a/examples/passing/Stream.purs b/examples/passing/Stream.purs new file mode 100644 index 0000000000..cc62a39668 --- /dev/null +++ b/examples/passing/Stream.purs @@ -0,0 +1,26 @@ +module Main where + +import Prelude + +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) + +class IsStream el s | s -> el where + cons :: el -> (Unit -> s) -> s + uncons :: s -> { head :: el, tail :: s } + +data Stream a = Stream a (Unit -> Stream a) + +instance streamIsStream :: IsStream a (Stream a) where + cons x xs = Stream x xs + uncons (Stream x f) = { head: x, tail: f unit } + +test :: forall el s. IsStream el s => s -> s +test s = case uncons s of + { head, tail } -> cons head \_ -> tail + +main :: Eff (console :: CONSOLE) Unit +main = do + let dones :: Stream String + dones = cons "Done" \_ -> dones + log (uncons (test dones)).head diff --git a/examples/passing/UnifyInTypeInstanceLookup.purs b/examples/passing/UnifyInTypeInstanceLookup.purs new file mode 100644 index 0000000000..a1920b84d9 --- /dev/null +++ b/examples/passing/UnifyInTypeInstanceLookup.purs @@ -0,0 +1,25 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +data Z = Z +data S n = S n + +data T +data F + +class EQ x y b +instance eqT :: EQ x x T +instance eqF :: EQ x y F + +test :: forall a b. (EQ a b T) => a -> b -> a +test a _ = a + +spin :: forall a b. a -> b +spin a = spin a + +-- Expected type: +-- forall t. (EQ t (S Z) T) => t +test1 = test (spin 1) (S Z) + +main = log "Done" diff --git a/examples/passing/WildcardInInstance.purs b/examples/passing/WildcardInInstance.purs new file mode 100644 index 0000000000..4b2d5ab710 --- /dev/null +++ b/examples/passing/WildcardInInstance.purs @@ -0,0 +1,23 @@ +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console + +-- Until the functional dependency gets added to purescript-eff, +-- we need this here. +class Monad m <= MonadEff eff m | m -> eff where + liftEff :: forall a. Eff eff a -> m a + +instance monadEffEff :: MonadEff eff (Eff eff) where + liftEff = id + +-- This should generate a warning with the correct inferred type. +test :: forall m. MonadEff _ m => m Unit +test = liftEff $ log "Done" + +test1 :: Eff _ Unit +test1 = liftEff $ log "Done" + +main :: forall eff. Eff (console :: CONSOLE | eff) Unit +main = test diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs index e9d17b4a22..d40e661b95 100644 --- a/hierarchy/Main.hs +++ b/hierarchy/Main.hs @@ -86,9 +86,9 @@ compile (HierarchyOptions inputGlob mOutput) = do exitSuccess superClasses :: P.Declaration -> [SuperMap] -superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) = +superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _ _) = fmap (\(P.Constraint (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers -superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)] +superClasses (P.TypeClassDeclaration sub _ _ _ _) = [SuperMap (Left sub)] superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl superClasses _ = [] diff --git a/psc-docs/Tags.hs b/psc-docs/Tags.hs index d370f05d63..eb174427ab 100644 --- a/psc-docs/Tags.hs +++ b/psc-docs/Tags.hs @@ -13,6 +13,6 @@ tags = concatMap dtags . P.exportedDeclarations names (P.TypeDeclaration ident _) = [P.showIdent ident] names (P.ExternDeclaration ident _) = [P.showIdent ident] names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name] - names (P.TypeClassDeclaration name _ _ _) = [P.runProperName name] + names (P.TypeClassDeclaration name _ _ _ _) = [P.runProperName name] names (P.TypeInstanceDeclaration name _ _ _ _) = [P.showIdent name] names _ = [] diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index 524225c82d..88fc979184 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -7,6 +7,7 @@ import Prelude.Compat import Control.Monad.Supply import Control.Monad.State +import Control.Monad.Writer class Monad m => MonadSupply m where fresh :: m Integer @@ -20,5 +21,8 @@ instance Monad m => MonadSupply (SupplyT m) where instance MonadSupply m => MonadSupply (StateT s m) where fresh = lift fresh +instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m) where + fresh = lift fresh + freshName :: MonadSupply m => m String freshName = fmap (('$' :) . show) fresh diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 740bfc9eb8..b826b637de 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -349,7 +349,7 @@ data Declaration -- | -- A type class declaration (name, argument, implies, member declarations) -- - | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [Declaration] + | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration] -- | -- A type instance declaration (name, dependencies, class name, instance types, member -- declarations) diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index 93e9585d29..ab9a2f39fc 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -133,7 +133,7 @@ isExported (Just exps) decl = any (matches decl) exps matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident' matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident' matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident' - matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident' + matches (TypeClassDeclaration ident _ _ _ _) (TypeClassRef ident') = ident == ident' matches (ValueFixityDeclaration _ _ op) (ValueOpRef op') = op == op' matches (TypeFixityDeclaration _ _ op) (TypeOpRef op') = op == op' matches (PositionedDeclaration _ _ d) r = d `matches` r diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 4271166326..b1ce9fb522 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -34,7 +34,7 @@ everywhereOnValues f g h = (f', g', h') f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds)) f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val)) f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds)) - f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds)) + f' (TypeClassDeclaration name args implies deps ds) = f (TypeClassDeclaration name args implies deps (map f' ds)) f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (mapTypeInstanceBody (map f') ds)) f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d)) f' other = f other @@ -101,7 +101,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds - f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> traverse (f' <=< f) ds + f' (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f' <=< f) ds f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f') f' other = f other @@ -168,7 +168,7 @@ everywhereOnValuesM f g h = (f', g', h') f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f - f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> traverse f' ds) >>= f + f' (TypeClassDeclaration name args implies deps ds) = (TypeClassDeclaration name args implies deps <$> traverse f' ds) >>= f f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f f' other = f other @@ -240,7 +240,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs) f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds) - f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds) + f' d@(TypeClassDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds) f' d@(TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (map f' ds) f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1 f' d = f d @@ -314,7 +314,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs) f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds) - f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds) + f' s (TypeClassDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds) f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (map (f'' s) ds) f' s (PositionedDeclaration _ _ d1) = f'' s d1 f' _ _ = r0 @@ -395,7 +395,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds - f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> traverse (f'' s) ds + f' s (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f'' s) ds f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1 f' _ other = return other @@ -482,7 +482,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) f' s (BindingGroupDeclaration ds) = let s' = S.union s (S.fromList (map (\(name, _, _) -> name) ds)) in foldMap (\(_, _, val) -> g'' s' val) ds - f' s (TypeClassDeclaration _ _ _ ds) = foldMap (f'' s) ds + f' s (TypeClassDeclaration _ _ _ _ ds) = foldMap (f'' s) ds f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds f' s (PositionedDeclaration _ _ d) = f'' s d f' _ _ = mempty @@ -576,7 +576,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con where forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors) forDecls (ExternDeclaration _ ty) = f ty - forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . constraintArgs) implies) + forDecls (TypeClassDeclaration _ _ implies _ _) = mconcat (concatMap (map f . constraintArgs) implies) forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . constraintArgs) cs) `mappend` mconcat (map f tys) forDecls (TypeSynonymDeclaration _ _ ty) = f ty forDecls (TypeDeclaration _ ty) = f ty diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index e36d07d1ec..af0374434e 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -72,7 +72,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] declToCoreFn ss _ (A.BindingGroupDeclaration ds) = [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds] - declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) = + declToCoreFn ss com (A.TypeClassDeclaration name _ supers _ members) = [NonRec (ssA ss) (properToIdent name) $ mkTypeClassConstructor ss com supers members] declToCoreFn _ com (A.PositionedDeclaration ss com1 d) = declToCoreFn (Just ss) (com ++ com1) d diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index ef61b37fab..d34df2e718 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -81,7 +81,7 @@ getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name) getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name) getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name) getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) -getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (P.runProperName name) +getDeclarationTitle (P.TypeClassDeclaration name _ _ _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name) getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " ++ P.showOp op) getDeclarationTitle (P.ValueFixityDeclaration _ _ op) = Just (P.showOp op) @@ -121,7 +121,7 @@ convertDeclaration (P.ExternDataDeclaration _ kind') title = basicDeclaration title (ExternDataDeclaration kind') convertDeclaration (P.TypeSynonymDeclaration _ args ty) title = basicDeclaration title (TypeSynonymDeclaration args ty) -convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = +convertDeclaration (P.TypeClassDeclaration _ args implies _ ds) title = -- TODO: include fundep info Just (Right (mkDeclaration title info) { declChildren = children }) where info = TypeClassDeclaration args implies diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 6fba5e498c..fbd665dc75 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -18,35 +18,46 @@ import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types import qualified Language.PureScript.Constants as C --- | --- The @Environment@ defines all values and types which are currently in scope: --- -data Environment = Environment { - -- | - -- Value names currently in scope - -- - names :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility) - -- | - -- Type names currently in scope - -- +-- | The @Environment@ defines all values and types which are currently in scope: +data Environment = Environment + { names :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility) + -- ^ Values currently in scope , types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) - -- | - -- Data constructors currently in scope, along with their associated type - -- constructor name, argument types and return type. + -- ^ Type names currently in scope , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident]) - -- | - -- Type synonyms currently in scope - -- + -- ^ Data constructors currently in scope, along with their associated type + -- constructor name, argument types and return type. , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type) - -- | - -- Available type class dictionaries - -- + -- ^ Type synonyms currently in scope , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) - -- | - -- Type classes - -- - , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint]) - } deriving (Show) + -- ^ Available type class dictionaries + , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData + -- ^ Type classes + } deriving Show + +-- | Information about a type class +data TypeClassData = TypeClassData + { typeClassArguments :: [(String, Maybe Kind)] + -- ^ A list of type argument names, and their kinds, where kind annotations + -- were provided. + , typeClassMembers :: [(Ident, Type)] + -- ^ A list of type class members and their types. Type arguments listed above + -- are considered bound in these types. + , typeClassSuperclasses :: [Constraint] + -- ^ A list of superclasses of this type class. Type arguments listed above + -- are considered bound in the types appearing in these constraints. + , typeClassDependencies :: [FunctionalDependency] + -- ^ A list of functional dependencies for the type arguments of this class. + } deriving Show + +-- | A functional dependency indicates a relationship between two sets of +-- type arguments in a class declaration. +data FunctionalDependency = FunctionalDependency + { fdDeterminers :: [Int] + -- ^ the type arguments which determine the determined type arguments + , fdDetermined :: [Int] + -- ^ the determined type arguments + } deriving Show -- | -- The initial environment with no values and only the default javascript types defined @@ -249,11 +260,11 @@ primTypes = -- The primitive class map. This just contains to `Partial` class, used as a -- kind of magic constraint for partial functions. -- -primClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint]) +primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses = M.fromList - [ (primName "Partial", ([], [], [])) - , (primName "Fail", ([("message", Just Symbol)], [], [])) + [ (primName "Partial", (TypeClassData [] [] [] [])) + , (primName "Fail", (TypeClassData [("message", Just Symbol)] [] [] [])) ] -- | @@ -278,3 +289,4 @@ lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisi lookupValue env ident = ident `M.lookup` names env $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''FunctionalDependency) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 39e3e7b640..96a2b74e16 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -953,7 +953,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS ] renderHint (ErrorSolvingConstraint (Constraint nm ts _)) detail = paras [ detail - , line "while solving type class constriant" + , line "while solving type class constraint" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) @@ -1063,16 +1063,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS stripFirst _ [] = [] hintCategory :: ErrorMessageHint -> HintCategory - hintCategory ErrorCheckingType{} = ExprHint - hintCategory ErrorInferringType{} = ExprHint - hintCategory ErrorInExpression{} = ExprHint - hintCategory ErrorUnifyingTypes{} = CheckHint - hintCategory ErrorInSubsumption{} = CheckHint - hintCategory ErrorInApplication{} = CheckHint - hintCategory ErrorCheckingKind{} = CheckHint - hintCategory ErrorSolvingConstraint{} = SolverHint - hintCategory PositionedError{} = PositionHint - hintCategory _ = OtherHint + hintCategory ErrorCheckingType{} = ExprHint + hintCategory ErrorInferringType{} = ExprHint + hintCategory ErrorInExpression{} = ExprHint + hintCategory ErrorUnifyingTypes{} = CheckHint + hintCategory ErrorInSubsumption{} = CheckHint + hintCategory ErrorInApplication{} = CheckHint + hintCategory ErrorCheckingKind{} = CheckHint + hintCategory ErrorSolvingConstraint{} = SolverHint + hintCategory PositionedError{} = PositionHint + hintCategory _ = OtherHint -- Pretty print and export declaration prettyPrintExport :: DeclarationRef -> String diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index f1b2f83fb6..16a70adf30 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -93,44 +93,45 @@ data ExternsTypeFixity = ExternsTypeFixity data ExternsDeclaration = -- | A type declaration EDType - { edTypeName :: ProperName 'TypeName - , edTypeKind :: Kind - , edTypeDeclarationKind :: TypeKind + { edTypeName :: ProperName 'TypeName + , edTypeKind :: Kind + , edTypeDeclarationKind :: TypeKind } -- | A type synonym | EDTypeSynonym - { edTypeSynonymName :: ProperName 'TypeName - , edTypeSynonymArguments :: [(String, Maybe Kind)] - , edTypeSynonymType :: Type + { edTypeSynonymName :: ProperName 'TypeName + , edTypeSynonymArguments :: [(String, Maybe Kind)] + , edTypeSynonymType :: Type } -- | A data construtor | EDDataConstructor - { edDataCtorName :: ProperName 'ConstructorName - , edDataCtorOrigin :: DataDeclType - , edDataCtorTypeCtor :: ProperName 'TypeName - , edDataCtorType :: Type - , edDataCtorFields :: [Ident] + { edDataCtorName :: ProperName 'ConstructorName + , edDataCtorOrigin :: DataDeclType + , edDataCtorTypeCtor :: ProperName 'TypeName + , edDataCtorType :: Type + , edDataCtorFields :: [Ident] } -- | A value declaration | EDValue - { edValueName :: Ident - , edValueType :: Type + { edValueName :: Ident + , edValueType :: Type } -- | A type class declaration | EDClass - { edClassName :: ProperName 'ClassName - , edClassTypeArguments :: [(String, Maybe Kind)] - , edClassMembers :: [(Ident, Type)] - , edClassConstraints :: [Constraint] + { edClassName :: ProperName 'ClassName + , edClassTypeArguments :: [(String, Maybe Kind)] + , edClassMembers :: [(Ident, Type)] + , edClassConstraints :: [Constraint] + , edFunctionalDependencies :: [FunctionalDependency] } -- | An instance declaration | EDInstance - { edInstanceClassName :: Qualified (ProperName 'ClassName) - , edInstanceName :: Ident - , edInstanceTypes :: [Type] - , edInstanceConstraints :: Maybe [Constraint] + { edInstanceClassName :: Qualified (ProperName 'ClassName) + , edInstanceName :: Ident + , edInstanceTypes :: [Type] + , edInstanceConstraints :: Maybe [Constraint] } - deriving (Show) + deriving Show -- | Convert an externs file back into a module applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment @@ -141,7 +142,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) } applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } - applyDecl env (EDClass pn args members cs) = env { typeClasses = M.insert (qual pn) (args, members, cs) (typeClasses env) } + applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (TypeClassData args members cs deps) (typeClasses env) } applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) } where dict :: TypeClassDictionaryInScope @@ -204,12 +205,12 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env = [ EDValue ident ty ] toExternsDeclaration (TypeClassRef className) - | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env + | Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env = [ EDType (coerceProperName className) kind TypeSynonym - , EDTypeSynonym (coerceProperName className) args synTy - , EDClass className args members implies + , EDTypeSynonym (coerceProperName className) typeClassArguments synTy + , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies ] toExternsDeclaration (TypeInstanceRef ident) = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index d44f25f113..80bd30ec0c 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -104,7 +104,7 @@ extractSpans ss d = case d of [(Left (runIdentT i), ss)] P.TypeSynonymDeclaration name _ _ -> [(Right (runProperNameT name), ss)] - P.TypeClassDeclaration name _ _ members -> + P.TypeClassDeclaration name _ _ _ members -> (Right (runProperNameT name), ss) : concatMap (extractSpans' ss) members P.DataDeclaration _ name _ ctors -> (Right (runProperNameT name), ss) diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index 870501576a..f08f9fbd0d 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -206,7 +206,7 @@ identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations getDeclNames d@(P.ValueDeclaration ident _ _ _) = [(ident, d)] getDeclNames d@(P.TypeDeclaration ident _ ) = [(ident, d)] getDeclNames d@(P.ExternDeclaration ident _) = [(ident, d)] - getDeclNames d@(P.TypeClassDeclaration _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds + getDeclNames d@(P.TypeClassDeclaration _ _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d getDeclNames _ = [] diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index 22990b7473..14889e8b27 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -44,34 +44,34 @@ printModuleSignatures moduleName P.Environment{..} = showNameType _ = P.internalError "The impossible happened in printModuleSignatures." findTypeClass - :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) + :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData -> P.Qualified (P.ProperName 'P.ClassName) - -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) + -> (P.Qualified (P.ProperName 'P.ClassName), Maybe P.TypeClassData) findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses) showTypeClass - :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) + :: (P.Qualified (P.ProperName 'P.ClassName), Maybe P.TypeClassData) -> Maybe Box.Box showTypeClass (_, Nothing) = Nothing - showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) = + showTypeClass (P.Qualified _ name, Just P.TypeClassData{..}) = let constraints = - if null constrs + if null typeClassSuperclasses then Box.text "" else Box.text "(" - Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint (P.Qualified _ pn) lt _) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs) + Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint (P.Qualified _ pn) lt _) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) typeClassSuperclasses) Box.<> Box.text ") <= " className = Box.text (P.runProperName name) - Box.<> Box.text (concatMap ((' ':) . fst) vars) + Box.<> Box.text (concatMap ((' ':) . fst) typeClassArguments) classBody = - Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body) + Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) typeClassMembers) in Just $ (Box.text "class " Box.<> constraints Box.<> className - Box.<+> if null body then Box.text "" else Box.text "where") + Box.<+> if null typeClassMembers then Box.text "" else Box.text "where") Box.// Box.moveRight 2 classBody @@ -82,7 +82,7 @@ printModuleSignatures moduleName P.Environment{..} = findType envTypes name = (name, M.lookup name envTypes) showType - :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) + :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident]) -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type) -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind)) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 890a46e134..c04b16aa3f 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -184,10 +184,15 @@ parseTypeClassDeclaration = do return implies className <- indented *> properName idents <- P.many (indented *> kindedIdent) + let parseNamedIdent = foldl (<|>) empty (zipWith (\(name, _) index -> lname' name $> index) idents [0..]) + parseFunctionalDependency = + FunctionalDependency <$> P.many parseNamedIdent <* rarrow + <*> P.many parseNamedIdent + dependencies <- P.option [] (indented *> pipe *> commaSep1 parseFunctionalDependency) members <- P.option [] $ do indented *> reserved "where" indented *> mark (P.many (same *> positioned parseTypeDeclaration)) - return $ TypeClassDeclaration className idents implies members + return $ TypeClassDeclaration className idents implies dependencies members parseConstraint :: TokenParser Constraint parseConstraint = Constraint <$> parseQualified properName diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 49448619f2..2962fe1d72 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -40,6 +40,7 @@ module Language.PureScript.Parser.Lexer , commaSep , commaSep1 , lname + , lname' , qualifier , tyname , uname @@ -414,6 +415,12 @@ lname = token go P. "identifier" go (LName s) = Just s go _ = Nothing +lname' :: String -> TokenParser () +lname' s = token go P. show s + where + go (LName s') | s == s' = Just () + go _ = Nothing + qualifier :: TokenParser String qualifier = token go P. "qualifier" where diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 593f3a1c1b..70d231214c 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -45,7 +45,7 @@ typeLiterals = mkPattern match match _ = Nothing constraintsAsBox :: [Constraint] -> Box -> Box -constraintsAsBox [(Constraint pn tys _)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty +constraintsAsBox [(Constraint pn tys _)] ty = text "(" <> constraintAsBox pn tys `before` (text ") => " <> ty) constraintsAsBox xs ty = vcat left (zipWith (\i (Constraint pn tys _) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty) constraintAsBox :: Qualified (ProperName a) -> [Type] -> Box diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 052934a470..1ccd2837b1 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -171,8 +171,8 @@ renameInModule imports (Module ss coms mn decls exps) = (,) (pos, bound) <$> (DataDeclaration dtype name args <$> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors) updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) = (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty) - updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) = - (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds) + updateDecl (pos, bound) (TypeClassDeclaration className args implies deps ds) = + (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure deps <*> pure ds) updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) = (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> traverse (updateTypesEverywhere pos) ts <*> pure ds) updateDecl (pos, bound) (TypeDeclaration name ty) = diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index b210b00d03..51facc0b6c 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -30,7 +30,7 @@ findExportable (Module _ _ mn ds _) = rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds where updateExports :: Exports -> Declaration -> m Exports - updateExports exps (TypeClassDeclaration tcn _ _ ds') = do + updateExports exps (TypeClassDeclaration tcn _ _ _ ds') = do exps' <- exportTypeClass Internal exps tcn mn foldM go exps' ds' where diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 149c5929b9..82af60f40b 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -312,9 +312,9 @@ updateTypes goType = (goDecl, goExpr, goBinder) goDecl pos (ExternDeclaration name ty) = do ty' <- goType' pos ty return (pos, ExternDeclaration name ty') - goDecl pos (TypeClassDeclaration name args implies decls) = do + goDecl pos (TypeClassDeclaration name args implies deps decls) = do implies' <- traverse (overConstraintArgs (traverse (goType' pos))) implies - return (pos, TypeClassDeclaration name args implies' decls) + return (pos, TypeClassDeclaration name args implies' deps decls) goDecl pos (TypeInstanceDeclaration name cs className tys impls) = do cs' <- traverse (overConstraintArgs (traverse (goType' pos))) cs tys' <- traverse (goType' pos) tys diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index eec69635e4..4d91324d7f 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -30,7 +30,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust) import qualified Data.Map as M -type MemberMap = M.Map (ModuleName, ProperName 'ClassName) ([(String, Maybe Kind)], [Constraint], [Declaration]) +type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData type Desugar = StateT MemberMap @@ -46,14 +46,20 @@ desugarTypeClasses desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule where initialState :: MemberMap - initialState = M.singleton (ModuleName [ProperName C.prim], ProperName C.partial) ([], [], []) - `M.union` M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) + initialState = + M.mapKeys (qualify (ModuleName [ProperName C.prim])) primClasses + `M.union` M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) fromExternsDecl :: ModuleName -> ExternsDeclaration - -> Maybe ((ModuleName, ProperName 'ClassName), ([(String, Maybe Kind)], [Constraint], [Declaration])) - fromExternsDecl mn (EDClass name args members implies) = Just ((mn, name), (args, implies, map (uncurry TypeDeclaration) members)) + -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData) + fromExternsDecl mn (EDClass name args members implies deps) = Just ((mn, name), typeClass) where + typeClass = TypeClassData { typeClassArguments = args + , typeClassMembers = members + , typeClassSuperclasses = implies + , typeClassDependencies = deps + } fromExternsDecl _ _ = Nothing desugarModule @@ -173,8 +179,8 @@ desugarDecl -> Desugar m (Maybe DeclarationRef, [Declaration]) desugarDecl mn exps = go where - go d@(TypeClassDeclaration name args implies members) = do - modify (M.insert (mn, name) (args, implies, members)) + go d@(TypeClassDeclaration name args implies deps members) = do + modify (M.insert (mn, name) (TypeClassData args (map memberToNameAndType members) implies deps)) return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do @@ -271,18 +277,15 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = m <- get -- Lookup the type arguments and member types for the type class - (args, implies, tyDecls) <- + TypeClassData{..} <- maybe (throwError . errorMessage . UnknownName $ fmap TyClassName className) return $ M.lookup (qualify mn className) m - case mapMaybe declName tyDecls \\ mapMaybe declName decls of + case map fst typeClassMembers \\ mapMaybe declName decls of member : _ -> throwError . errorMessage $ MissingClassMember member [] -> do - - let instanceTys = map memberToNameAndType tyDecls - -- Replace the type arguments with the appropriate types in the member types - let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys + let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers -- Create values for the type instance members members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls @@ -290,10 +293,10 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = -- Create the type of the dictionary -- The type is a record type, but depending on type instance dependencies, may be constrained. -- The dictionary itself is a record literal. - let superclasses = superClassDictionaryNames implies `zip` + let superclasses = superClassDictionaryNames typeClassSuperclasses `zip` [ Abs (Left (Ident C.__unused)) (DeferredDictionary superclass tyArgs) - | (Constraint superclass suTyArgs _) <- implies - , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs + | (Constraint superclass suTyArgs _) <- typeClassSuperclasses + , let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs ] let props = Literal $ ObjectLiteral (members ++ superclasses) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index bfadcdd5c5..a621048768 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -112,15 +112,23 @@ addTypeClass -> ProperName 'ClassName -> [(String, Maybe Kind)] -> [Constraint] + -> [FunctionalDependency] -> [Declaration] -> m () -addTypeClass moduleName pn args implies ds = - let members = map toPair ds in - modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } } +addTypeClass moduleName pn args implies dependencies ds = + modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) newClass (typeClasses . checkEnv $ st) } } where - toPair (TypeDeclaration ident ty) = (ident, ty) - toPair (PositionedDeclaration _ _ d) = toPair d - toPair _ = internalError "Invalid declaration in TypeClassDeclaration" + newClass :: TypeClassData + newClass = + TypeClassData { typeClassArguments = args + , typeClassMembers = map toPair ds + , typeClassSuperclasses = implies + , typeClassDependencies = dependencies + } + + toPair (TypeDeclaration ident ty) = (ident, ty) + toPair (PositionedDeclaration _ _ d) = toPair d + toPair _ = internalError "Invalid declaration in TypeClassDeclaration" addTypeClassDictionaries :: (MonadState CheckState m) @@ -265,8 +273,8 @@ typeCheckAll moduleName _ = traverse go return d go d@FixityDeclaration{} = return d go d@ImportDeclaration{} = return d - go d@(TypeClassDeclaration pn args implies tys) = do - addTypeClass moduleName pn args implies tys + go d@(TypeClassDeclaration pn args implies deps tys) = do + addTypeClass moduleName pn args implies deps tys return d go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do traverse_ (checkTypeClassInstance moduleName) tys @@ -414,7 +422,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members where findClassMembers :: Declaration -> Maybe [Ident] - findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds + findClassMembers (TypeClassDeclaration name' _ _ _ ds) | name == name' = Just $ map extractMemberName ds findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d findClassMembers _ = Nothing extractMemberName :: Declaration -> Ident diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index c15d628037..7b03c70286 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -1,28 +1,35 @@ +{-# LANGUAGE NamedFieldPuns #-} + -- | -- Type class entailment -- module Language.PureScript.TypeChecker.Entailment ( InstanceContext , replaceTypeClassDictionaries + , newDictionaries ) where import Prelude.Compat +import Control.Arrow (second) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State import Control.Monad.Supply.Class (MonadSupply(..)) import Control.Monad.Writer +import Data.Foldable (for_) import Data.Function (on) -import Data.List (minimumBy, sortBy, groupBy) -import Data.Maybe (maybeToList, mapMaybe) +import Data.List (minimumBy, nub) +import Data.Maybe (fromMaybe, maybeToList, mapMaybe) import qualified Data.Map as M +import qualified Data.Set as S import Language.PureScript.AST import Language.PureScript.Crash +import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Names -import Language.PureScript.TypeChecker.Monad (CheckState, withErrorMessageHint) +import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types @@ -34,24 +41,57 @@ type InstanceContext = M.Map (Maybe ModuleName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) --- | Merge two type class contexts +-- | A type substitution which makes an instance head match a list of types. +-- +-- Note: we store many types per type variable name. For any name, all types +-- should unify if we are going to commit to an instance. +type Matching a = M.Map String a + combineContexts :: InstanceContext -> InstanceContext -> InstanceContext combineContexts = M.unionWith (M.unionWith M.union) -- | Replace type class dictionary placeholders with inferred type class dictionaries replaceTypeClassDictionaries - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) + :: forall m + . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => Bool - -> ModuleName -> Expr -> m (Expr, [(Ident, Constraint)]) -replaceTypeClassDictionaries shouldGeneralize mn = - let (_, f, _) = everywhereOnValuesTopDownM return (WriterT . go) return - in flip evalStateT M.empty . runWriterT . f +replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ do + -- Loop, deferring any unsolved constraints, until there are no more + -- constraints which can be solved, then make a generalization pass. + let loop e = do + (e', solved) <- deferPass e + if getAny solved + then loop e' + else return e' + loop expr >>= generalizePass where - go (TypeClassDictionary constraint dicts hints) = - rethrow (addHints hints) $ entails shouldGeneralize mn dicts constraint - go other = return (other, []) + -- This pass solves constraints where possible, deferring constraints if not. + deferPass :: Expr -> StateT InstanceContext m (Expr, Any) + deferPass = fmap (second fst) . runWriterT . f where + f :: Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr + (_, f, _) = everywhereOnValuesTopDownM return (go True) return + + -- This pass generalizes any remaining constraints + generalizePass :: Expr -> StateT InstanceContext m (Expr, [(Ident, Constraint)]) + generalizePass = fmap (second snd) . runWriterT . f where + f :: Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr + (_, f, _) = everywhereOnValuesTopDownM return (go False) return + + go :: Bool -> Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr + go deferErrors dict@(TypeClassDictionary _ _ hints) = + rethrow (addHints hints) $ entails shouldGeneralize deferErrors dict + go _ other = return other + +-- | Three options for how we can handle a constraint, depending on the mode we're in. +data EntailsResult a + = Solved a TypeClassDictionaryInScope + -- ^ We solved this constraint + | Unsolved Constraint + -- ^ We couldn't solve this constraint right now, it will be generalized + | Deferred + -- ^ We couldn't solve this constraint right now, so it has been deferred -- | -- Check that the current set of type class dictionaries entail the specified type class goal, and, if so, @@ -61,14 +101,14 @@ entails :: forall m . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => Bool - -> ModuleName - -> InstanceContext - -> Constraint - -> StateT InstanceContext m (Expr, [(Ident, Constraint)]) -entails shouldGeneralize moduleName context = solve + -> Bool + -> Expr + -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr +entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hints) = + solve constraint where forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope] - forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (Nothing : Just mn : map Just (mapMaybe ctorModules tys)) + forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (nub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) forClassName _ _ _ = internalError "forClassName: expected qualified class name" ctorModules :: Type -> Maybe ModuleName @@ -80,139 +120,306 @@ entails shouldGeneralize moduleName context = solve findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope] findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx - solve :: Constraint -> StateT InstanceContext m (Expr, [(Ident, Constraint)]) - solve con = StateT . (withErrorMessageHint (ErrorSolvingConstraint con) .) . runStateT $ do - (dict, unsolved) <- go 0 con - return (dictionaryValueToValue dict, unsolved) + valUndefined :: Expr + valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) + + solve :: Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr + solve con = go 0 con where - go :: Int -> Constraint -> StateT InstanceContext m (DictionaryValue, [(Ident, Constraint)]) - go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' - go work con'@(Constraint className' tys' _) = do - -- Get the inferred constraint context so far, and merge it with the global context - inferred <- get - let instances = do - tcd <- forClassName (combineContexts context inferred) className' tys' - -- Make sure the type unifies with the type in the type instance definition - subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName) tys' (tcdInstanceTypes tcd) - return (subst, tcd) - solution <- lift $ unique instances - case solution of - Left (subst, tcd) -> do - -- Solve any necessary subgoals - (args, unsolved) <- solveSubgoals subst (tcdDependencies tcd) - let match = foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index) - (mkDictionary (tcdName tcd) args) - (tcdPath tcd) - return (match, unsolved) - Right unsolved@(Constraint unsolvedClassName@(Qualified _ pn) unsolvedTys _) -> do - -- Generate a fresh name for the unsolved constraint's new dictionary - ident <- freshIdent ("dict" ++ runProperName pn) - let qident = Qualified Nothing ident - -- Store the new dictionary in the InstanceContext so that we can solve this goal in - -- future. - let newDict = TypeClassDictionaryInScope qident [] unsolvedClassName unsolvedTys Nothing - newContext = M.singleton Nothing (M.singleton unsolvedClassName (M.singleton qident newDict)) - modify (combineContexts newContext) - return (LocalDictionaryValue qident, [(ident, unsolved)]) - where + go :: Int -> Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr + go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' + go work con'@(Constraint className' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do + -- We might have unified types by solving other constraints, so we need to + -- apply the latest substitution. + latestSubst <- lift . lift $ gets checkSubstitution + let tys'' = map (substituteType latestSubst) tys' + -- Get the inferred constraint context so far, and merge it with the global context + inferred <- lift get + -- We need information about functional dependencies, so we have to look up the class + -- name in the environment: + let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup className' + TypeClassData{ typeClassDependencies } <- lift . lift $ gets (findClass . typeClasses . checkEnv) + let instances = + [ (substs, tcd) + | tcd <- forClassName (combineContexts context inferred) className' tys'' + -- Make sure the type unifies with the type in the type instance definition + , substs <- maybeToList (matches typeClassDependencies tcd tys'') + ] + solution <- lift . lift $ unique tys'' instances + case solution of + Solved substs tcd -> do + -- Note that we solved something. + tell (Any True, mempty) + -- Make sure the substitution is valid: + lift . lift . for_ substs $ pairwiseM unifyTypes + -- Now enforce any functional dependencies, using unification + -- Note: we need to generate fresh types for any unconstrained + -- type variables before unifying. + let subst = fmap head substs + currentSubst <- lift . lift $ gets checkSubstitution + subst' <- lift . lift $ withFreshTypes tcd (fmap (substituteType currentSubst) subst) + lift . lift $ zipWithM_ (\t1 t2 -> do + let inferredType = replaceAllTypeVars (M.toList subst') t1 + unifyTypes inferredType t2) (tcdInstanceTypes tcd) tys'' + currentSubst' <- lift . lift $ gets checkSubstitution + let subst'' = fmap (substituteType currentSubst') subst' + -- Solve any necessary subgoals + args <- solveSubgoals subst'' (tcdDependencies tcd) + let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index) + (mkDictionary (tcdName tcd) args) + (tcdPath tcd) + return match + Unsolved unsolved -> do + -- Generate a fresh name for the unsolved constraint's new dictionary + ident <- freshIdent ("dict" ++ runProperName (disqualify (constraintClass unsolved))) + let qident = Qualified Nothing ident + -- Store the new dictionary in the InstanceContext so that we can solve this goal in + -- future. + newDicts <- lift . lift $ newDictionaries [] qident unsolved + let newContext = mkContext newDicts + modify (combineContexts newContext) + -- Mark this constraint for generalization + tell (mempty, [(ident, unsolved)]) + return (Var qident) + Deferred -> + -- Constraint was deferred, just return the dictionary unchanged, + -- with no unsolved constraints. Hopefully, we can solve this later. + return (TypeClassDictionary (Constraint className' tys'' conInfo) context hints) + where + -- | When checking functional dependencies, we need to use unification to make + -- sure it is safe to use the selected instance. We will unify the solved type with + -- the type in the instance head under the substition inferred from its instantiation. + -- As an example, when solving MonadState t0 (State Int), we choose the + -- MonadState s (State s) instance, and we unify t0 with Int, since the functional + -- dependency from MonadState dictates that t0 should unify with s\[s -> Int], which is + -- Int. This is fine, but in some cases, the substitution does not remove all TypeVars + -- from the type, so we end up with a unification error. So, any type arguments which + -- appear in the instance head, but not in the substitution need to be replaced with + -- fresh type variables. This function extends a substitution with fresh type variables + -- as necessary, based on the types in the instance head. + withFreshTypes + :: TypeClassDictionaryInScope + -> Matching Type + -> m (Matching Type) + withFreshTypes TypeClassDictionaryInScope{..} subst = do + let onType = everythingOnTypes S.union fromTypeVar + typeVarsInHead = foldMap onType tcdInstanceTypes + <> foldMap (foldMap (foldMap onType . constraintArgs)) tcdDependencies + typeVarsInSubst = S.fromList (M.keys subst) + uninstantiatedTypeVars = typeVarsInHead S.\\ typeVarsInSubst + newSubst <- traverse withFreshType (S.toList uninstantiatedTypeVars) + return (subst <> M.fromList newSubst) + where + fromTypeVar (TypeVar v) = S.singleton v + fromTypeVar _ = S.empty - unique :: [(a, TypeClassDictionaryInScope)] -> m (Either (a, TypeClassDictionaryInScope) Constraint) - unique [] | shouldGeneralize && all canBeGeneralized tys' = return (Right con') - | otherwise = throwError . errorMessage $ NoInstanceFound con' - unique [a] = return $ Left a - unique tcds | pairwise overlapping (map snd tcds) = do - tell . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds) - return $ Left (head tcds) - | otherwise = return $ Left (minimumBy (compare `on` length . tcdPath . snd) tcds) - - canBeGeneralized :: Type -> Bool - canBeGeneralized TUnknown{} = True - canBeGeneralized Skolem{} = True - canBeGeneralized _ = False - - -- | - -- Check if two dictionaries are overlapping - -- - -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have - -- been caught when constructing superclass dictionaries. - overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool - overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False - overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False - overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False - overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False - overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2 - - -- Create dictionaries for subgoals which still need to be solved by calling go recursively - -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type - -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively. - solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT InstanceContext m (Maybe [DictionaryValue], [(Ident, Constraint)]) - solveSubgoals _ Nothing = return (Nothing, []) - solveSubgoals subst (Just subgoals) = do - zipped <- traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars subst))) subgoals - let (dicts, unsolved) = unzip zipped - return (Just dicts, concat unsolved) - - -- Make a dictionary from subgoal dictionaries by applying the correct function - mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue - mkDictionary fnName Nothing = LocalDictionaryValue fnName - mkDictionary fnName (Just []) = GlobalDictionaryValue fnName - mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts - - -- Turn a DictionaryValue into a Expr - dictionaryValueToValue :: DictionaryValue -> Expr - dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName - dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName - dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts) - dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) = - App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index) - (dictionaryValueToValue dict)) - valUndefined - -- Ensure that a substitution is valid - verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)] - verifySubstitution subst = do - let grps = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ subst - guard (all (pairwise unifiesWith . map snd) grps) - return $ map head grps + withFreshType s = do + t <- freshType + return (s, t) - valUndefined :: Expr - valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) + unique :: [Type] -> [(a, TypeClassDictionaryInScope)] -> m (EntailsResult a) + unique tyArgs [] + | deferErrors = return Deferred + -- We need a special case for nullary type classes, since we want + -- to generalize over Partial constraints. + | shouldGeneralize && (null tyArgs || any canBeGeneralized tyArgs) = return (Unsolved (Constraint className' tyArgs conInfo)) + | otherwise = throwError . errorMessage $ NoInstanceFound (Constraint className' tyArgs conInfo) + unique _ [(a, dict)] = return $ Solved a dict + unique tyArgs tcds + | pairwiseAny overlapping (map snd tcds) = do + tell . errorMessage $ OverlappingInstances className' tyArgs (map (tcdName . snd) tcds) + return $ uncurry Solved (head tcds) + | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds) --- | --- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup), --- and return a substitution from type variables to types which makes the type heads unify. --- -typeHeadsAreEqual :: ModuleName -> Type -> Type -> Maybe [(String, Type)] -typeHeadsAreEqual _ (TUnknown u1) (TUnknown u2) | u1 == u2 = Just [] -typeHeadsAreEqual _ (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Just [] -typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)] -typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just [] -typeHeadsAreEqual _ (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = Just [] -typeHeadsAreEqual m (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m h1 h2 - <*> typeHeadsAreEqual m t1 t2 -typeHeadsAreEqual _ REmpty REmpty = Just [] -typeHeadsAreEqual m r1@RCons{} r2@RCons{} = - let (s1, r1') = rowToList r1 - (s2, r2') = rowToList r2 - - int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] - sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] - sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] - in (++) <$> foldMap (uncurry (typeHeadsAreEqual m)) int - <*> go sd1 r1' sd2 r2' + canBeGeneralized :: Type -> Bool + canBeGeneralized TUnknown{} = True + canBeGeneralized Skolem{} = True + canBeGeneralized _ = False + + -- | + -- Check if two dictionaries are overlapping + -- + -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have + -- been caught when constructing superclass dictionaries. + overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool + overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False + overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False + overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False + overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False + overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2 + + -- Create dictionaries for subgoals which still need to be solved by calling go recursively + -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type + -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively. + solveSubgoals :: Matching Type -> Maybe [Constraint] -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) (Maybe [Expr]) + solveSubgoals _ Nothing = return Nothing + solveSubgoals subst (Just subgoals) = + Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals + + -- Make a dictionary from subgoal dictionaries by applying the correct function + mkDictionary :: Qualified Ident -> Maybe [Expr] -> Expr + mkDictionary fnName Nothing = Var fnName + mkDictionary fnName (Just []) = Var fnName + mkDictionary fnName (Just dicts) = foldl App (Var fnName) dicts + + -- Turn a DictionaryValue into a Expr + subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr + subclassDictionaryValue dict superclassName index = + App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index) + dict) + valUndefined +entails _ _ _ = internalError "entails: expected TypeClassDictionary" + +-- Check if an instance matches our list of types, allowing for types +-- to be solved via functional dependencies. If the types match, we return a +-- substitution which makes them match. If not, we return 'Nothing'. +matches :: [FunctionalDependency] -> TypeClassDictionaryInScope -> [Type] -> Maybe (Matching [Type]) +matches deps TypeClassDictionaryInScope{..} tys = do + -- First, find those types which match exactly + let matched = zipWith typeHeadsAreEqual tys tcdInstanceTypes + -- Now, use any functional dependencies to infer any remaining types + guard $ covers matched + -- Verify that any repeated type variables are unifiable + let determinedSet = foldMap (S.fromList . fdDetermined) deps + solved = map snd . filter ((`S.notMember` determinedSet) . fst) $ zipWith (\(_, ts) i -> (i, ts)) matched [0..] + verifySubstitution (M.unionsWith (++) solved) where - go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)] - go [] REmpty [] REmpty = Just [] - go [] (TUnknown _) _ _ = Just [] - go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = Just [] - go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = Just [] - go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))] - go _ _ _ _ = Nothing -typeHeadsAreEqual _ _ _ = Nothing + -- | Find the closure of a set of functional dependencies. + covers :: [(Bool, subst)] -> Bool + covers ms = finalSet == S.fromList [0..length ms - 1] + where + initialSet :: S.Set Int + initialSet = S.fromList . map snd . filter (fst . fst) $ zip ms [0..] --- | --- Check all values in a list pairwise match a predicate --- -pairwise :: (a -> a -> Bool) -> [a] -> Bool -pairwise _ [] = True -pairwise _ [_] = True -pairwise p (x : xs) = all (p x) xs && pairwise p xs + finalSet :: S.Set Int + finalSet = untilFixedPoint applyAll initialSet + + untilFixedPoint :: Eq a => (a -> a) -> a -> a + untilFixedPoint f = go + where + go a | a' == a = a' + | otherwise = go a' + where a' = f a + + applyAll :: S.Set Int -> S.Set Int + applyAll s = foldr applyDependency s deps + + applyDependency :: FunctionalDependency -> S.Set Int -> S.Set Int + applyDependency FunctionalDependency{..} xs + | S.fromList fdDeterminers `S.isSubsetOf` xs = xs <> S.fromList fdDetermined + | otherwise = xs + + -- + -- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup), + -- and return a substitution from type variables to types which makes the type heads unify. + -- + typeHeadsAreEqual :: Type -> Type -> (Bool, Matching [Type]) + typeHeadsAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = (True, M.empty) + typeHeadsAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = (True, M.empty) + typeHeadsAreEqual t (TypeVar v) = (True, M.singleton v [t]) + typeHeadsAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = (True, M.empty) + typeHeadsAreEqual (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = (True, M.empty) + typeHeadsAreEqual (TypeApp h1 t1) (TypeApp h2 t2) = + both (typeHeadsAreEqual h1 h2) (typeHeadsAreEqual t1 t2) + typeHeadsAreEqual REmpty REmpty = (True, M.empty) + typeHeadsAreEqual r1@RCons{} r2@RCons{} = + foldr both (go sd1 r1' sd2 r2') (map (uncurry typeHeadsAreEqual) int) + where + (s1, r1') = rowToList r1 + (s2, r2') = rowToList r2 + + int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] + sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] + sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] + + go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> (Bool, Matching [Type]) + go [] REmpty [] REmpty = (True, M.empty) + go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = (True, M.empty) + go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = (True, M.empty) + go [] (Skolem _ sk1 _ _) [] (Skolem _ sk2 _ _) | sk1 == sk2 = (True, M.empty) + go sd r [] (TypeVar v) = (True, M.singleton v [rowFromList (sd, r)]) + go _ _ _ _ = (False, M.empty) + typeHeadsAreEqual _ _ = (False, M.empty) + + both :: (Bool, Matching [Type]) -> (Bool, Matching [Type]) -> (Bool, Matching [Type]) + both (b1, m1) (b2, m2) = (b1 && b2, M.unionWith (++) m1 m2) + + -- Ensure that a substitution is valid + verifySubstitution :: Matching [Type] -> Maybe (Matching [Type]) + verifySubstitution = traverse meet where + meet ts | pairwiseAll typesAreEqual ts = Just ts + | otherwise = Nothing + + -- Note that unknowns are only allowed to unify if they came from a type + -- which was _not_ solved, i.e. one which was inferred by a functional + -- dependency. + typesAreEqual :: Type -> Type -> Bool + typesAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = True + typesAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2 + typesAreEqual (TypeVar v1) (TypeVar v2) = v1 == v2 + typesAreEqual (TypeLevelString s1) (TypeLevelString s2) = s1 == s2 + typesAreEqual (TypeConstructor c1) (TypeConstructor c2) = c1 == c2 + typesAreEqual (TypeApp h1 t1) (TypeApp h2 t2) = typesAreEqual h1 h2 && typesAreEqual t1 t2 + typesAreEqual REmpty REmpty = True + typesAreEqual r1 r2 | isRCons r1 || isRCons r2 = + let (s1, r1') = rowToList r1 + (s2, r2') = rowToList r2 + + int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] + sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] + sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] + in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2' + where + go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool + go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True + go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2 + go [] REmpty [] REmpty = True + go [] (TypeVar v1) [] (TypeVar v2) = v1 == v2 + go _ _ _ _ = False + typesAreEqual _ _ = False + + isRCons :: Type -> Bool + isRCons RCons{} = True + isRCons _ = False + +-- | Add a dictionary for the constraint to the scope, and dictionaries +-- for all implied superclass instances. +newDictionaries + :: MonadState CheckState m + => [(Qualified (ProperName 'ClassName), Integer)] + -> Qualified Ident + -> Constraint + -> m [TypeClassDictionaryInScope] +newDictionaries path name (Constraint className instanceTy _) = do + tcs <- gets (typeClasses . checkEnv) + let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs + supDicts <- join <$> zipWithM (\(Constraint supName supArgs _) index -> + newDictionaries ((supName, index) : path) + name + (Constraint supName (instantiateSuperclass (map fst typeClassArguments) supArgs instanceTy) Nothing) + ) typeClassSuperclasses [0..] + return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts) + where + instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type] + instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs + +mkContext :: [TypeClassDictionaryInScope] -> InstanceContext +mkContext = foldr combineContexts M.empty . map fromDict where + fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdName d) d)) + +-- | Check all pairs of values in a list match a predicate +pairwiseAll :: (a -> a -> Bool) -> [a] -> Bool +pairwiseAll _ [] = True +pairwiseAll _ [_] = True +pairwiseAll p (x : xs) = all (p x) xs && pairwiseAll p xs + +-- | Check any pair of values in a list match a predicate +pairwiseAny :: (a -> a -> Bool) -> [a] -> Bool +pairwiseAny _ [] = False +pairwiseAny _ [_] = False +pairwiseAny p (x : xs) = any (p x) xs || pairwiseAny p xs + +pairwiseM :: Applicative m => (a -> a -> m ()) -> [a] -> m () +pairwiseM _ [] = pure () +pairwiseM _ [_] = pure () +pairwiseM p (x : xs) = traverse (p x) xs *> pairwiseM p xs diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 3d356849ca..81388379a7 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -16,7 +16,6 @@ import Control.Arrow (second) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State -import Control.Monad.Writer.Class (MonadWriter(..)) import qualified Data.Map as M @@ -96,19 +95,19 @@ unifyKinds k1 k2 = do -- | Infer the kind of a single type kindOf - :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) + :: (MonadError MultipleErrors m, MonadState CheckState m) => Type -> m Kind kindOf ty = fst <$> kindOfWithScopedVars ty -- | Infer the kind of a single type, returning the kinds of any scoped type variables kindOfWithScopedVars :: - (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => + (MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)]) kindOfWithScopedVars ty = withErrorMessageHint (ErrorCheckingKind ty) $ - fmap tidyUp . liftUnify $ infer ty + fmap tidyUp . withFreshSubstitution . captureSubstitution $ infer ty where tidyUp ((k, args), sub) = ( starIfUnknown (substituteKind sub k) , map (second (starIfUnknown . substituteKind sub)) args @@ -116,14 +115,14 @@ kindOfWithScopedVars ty = -- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors kindsOf - :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) + :: (MonadError MultipleErrors m, MonadState CheckState m) => Bool -> ModuleName -> ProperName 'TypeName -> [(String, Maybe Kind)] -> [Type] -> m Kind -kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do +kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do tyCon <- freshKind kargs <- replicateM (length args) freshKind rest <- zipWithM freshKindVar args kargs @@ -145,12 +144,12 @@ freshKindVar (arg, Just kind') kind = do -- | Simultaneously infer the kinds of several mutually recursive type constructors kindsOfAll - :: (MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) + :: (MonadError MultipleErrors m, MonadState CheckState m) => ModuleName -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)] -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])] -> m ([Kind], [Kind]) -kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do +kindsOfAll moduleName syns tys = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do synVars <- replicateM (length syns) freshKind let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars bindLocalTypeVariables moduleName dict $ do diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 3a6e17bb96..554a56caf6 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -11,7 +11,7 @@ import Prelude.Compat import Control.Arrow (second) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State -import Control.Monad.Writer.Class (MonadWriter(..), listen, censor) +import Control.Monad.Writer.Class (MonadWriter(..), censor) import Data.Maybe import qualified Data.Map as M @@ -269,23 +269,35 @@ guardWith _ True = return () guardWith e False = throwError e -- | Run a computation in the substitution monad, generating a return value and the final substitution. -liftUnify :: - (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => - m a -> - m (a, Substitution) -liftUnify = liftUnifyWarnings (const id) - --- | Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values. -liftUnifyWarnings :: - (MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => - (Substitution -> ErrorMessage -> ErrorMessage) -> - m a -> - m (a, Substitution) -liftUnifyWarnings replace ma = do +captureSubstitution + :: MonadState CheckState m + => m a + -> m (a, Substitution) +captureSubstitution = capturingSubstitution (,) + +capturingSubstitution + :: MonadState CheckState m + => (a -> Substitution -> b) + -> m a + -> m b +capturingSubstitution f ma = do + a <- ma + subst <- gets checkSubstitution + return (f a subst) + +withFreshSubstitution + :: MonadState CheckState m + => m a + -> m a +withFreshSubstitution ma = do orig <- get modify $ \st -> st { checkSubstitution = emptySubstitution } - (a, w) <- reflectErrors . censor (const mempty) . reifyErrors . listen $ ma - subst <- gets checkSubstitution - tell . onErrorMessages (replace subst) $ w + a <- ma modify $ \st -> st { checkSubstitution = checkSubstitution orig } - return (a, subst) + return a + +withoutWarnings + :: MonadWriter w m + => m a + -> m (a, w) +withoutWarnings = censor (const mempty) . listen diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 5b2136dc9b..f748e3e6d5 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} -- | -- This module implements the type checker @@ -36,6 +37,7 @@ import Data.Either (lefts, rights) import Data.List (transpose, nub, (\\), partition, delete) import Data.Maybe (fromMaybe) import qualified Data.Map as M +import qualified Data.Set as S import Language.PureScript.AST import Language.PureScript.Crash @@ -52,7 +54,6 @@ import Language.PureScript.TypeChecker.Skolems import Language.PureScript.TypeChecker.Subsumption import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.TypeChecker.Unify -import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types data BindingGroupType @@ -62,65 +63,78 @@ data BindingGroupType -- | Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. -typesOf :: - (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - BindingGroupType -> - ModuleName -> - [(Ident, Expr)] -> - m [(Ident, (Expr, Type))] -typesOf bindingGroupType moduleName vals = do - tys <- fmap tidyUp . escalateWarningWhen isHoleError . liftUnifyWarnings replace $ do - (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals - ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict - ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict - return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2) - - forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do - -- Replace type class dictionary placeholders with actual dictionaries - (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize moduleName val - let unsolvedTypeVars = nub $ unknownsInType ty - -- Generalize and constrain the type - let generalized = generalize unsolved ty - - when shouldGeneralize $ do - -- Show the inferred type in a warning - tell . errorMessage $ MissingTypeDeclaration ident generalized - -- For non-recursive binding groups, can generalize over constraints. - -- For recursive binding groups, we throw an error here for now. - when (bindingGroupType == RecursiveBindingGroup && not (null unsolved)) - . throwError - . errorMessage - $ CannotGeneralizeRecursiveFunction ident generalized - -- Make sure any unsolved type constraints only use type variables which appear - -- unknown in the inferred type. - forM_ unsolved $ \(_, con) -> do - let constraintTypeVars = nub $ foldMap unknownsInType (constraintArgs con) - when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ - throwError . errorMessage $ NoInstanceFound con - - -- Check skolem variables did not escape their scope - skolemEscapeCheck val' - -- Check rows do not contain duplicate labels - checkDuplicateLabels val' - return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized)) +typesOf + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => BindingGroupType + -> ModuleName + -> [(Ident, Expr)] + -> m [(Ident, (Expr, Type))] +typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do + (tys, w) <- withoutWarnings . capturingSubstitution tidyUp $ do + (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals + ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict + ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict + return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2) + + inferred <- forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do + -- Replace type class dictionary placeholders with actual dictionaries + (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize val + -- Generalize and constrain the type + currentSubst <- gets checkSubstitution + let ty' = substituteType currentSubst ty + unsolvedTypeVars = nub $ unknownsInType ty' + generalized = generalize unsolved ty' + + when shouldGeneralize $ do + -- Show the inferred type in a warning + tell . errorMessage $ MissingTypeDeclaration ident generalized + -- For non-recursive binding groups, can generalize over constraints. + -- For recursive binding groups, we throw an error here for now. + when (bindingGroupType == RecursiveBindingGroup && not (null unsolved)) + . throwError + . errorMessage + $ CannotGeneralizeRecursiveFunction ident generalized + -- Make sure any unsolved type constraints only use type variables which appear + -- unknown in the inferred type. + forM_ unsolved $ \(_, con) -> do + -- We need information about functional dependencies, since we allow + -- ambiguous types to be inferred if they can be solved by some functional + -- dependency. + let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup (constraintClass con) + TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv) + let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies + let constraintTypeVars = nub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..] + when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ + throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ NoInstanceFound con + + -- Check skolem variables did not escape their scope + skolemEscapeCheck val' + -- Check rows do not contain duplicate labels + checkDuplicateLabels val' + return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized)) + + -- Show warnings here, since types in wildcards might have been solved during + -- instance resolution (by functional dependencies). + finalSubst <- gets checkSubstitution + escalateWarningWhen isHoleError . tell . onErrorMessages (replaceTypes finalSubst) $ w + + return inferred where + replaceTypes subst = onTypesInErrorMessage (substituteType subst) - -- | Generalize type vars using forall and add inferred constraints - generalize unsolved = varIfUnknown . constrain unsolved + -- | Generalize type vars using forall and add inferred constraints + generalize unsolved = varIfUnknown . constrain unsolved - -- | Add any unsolved constraints - constrain [] = id - constrain cs = ConstrainedType (map snd cs) + -- | Add any unsolved constraints + constrain [] = id + constrain cs = ConstrainedType (map snd cs) - -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values - tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts + -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values + tidyUp ts sub = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts - -- Replace all the wildcards types with their inferred types - replace sub = onTypesInErrorMessage (substituteType sub) - - isHoleError :: ErrorMessage -> Bool - isHoleError (ErrorMessage _ HoleInferredType{}) = True - isHoleError _ = False + isHoleError :: ErrorMessage -> Bool + isHoleError (ErrorMessage _ HoleInferredType{}) = True + isHoleError _ = False type TypeData = M.Map (Qualified Ident) (Type, NameKind, NameVisibility) @@ -526,26 +540,6 @@ check' val t@(ConstrainedType constraints ty) = do dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty return $ TypedValue True (foldr (Abs . Left) val' dictNames) t - where - -- | Add a dictionary for the constraint to the scope, and dictionaries - -- for all implied superclass instances. - newDictionaries - :: [(Qualified (ProperName 'ClassName), Integer)] - -> Qualified Ident - -> Constraint - -> m [TypeClassDictionaryInScope] - newDictionaries path name (Constraint className instanceTy _) = do - tcs <- gets (typeClasses . checkEnv) - let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs - supDicts <- join <$> zipWithM (\(Constraint supName supArgs _) index -> - newDictionaries ((supName, index) : path) - name - (Constraint supName (instantiateSuperclass (map fst args) supArgs instanceTy) Nothing) - ) superclasses [0..] - return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts) - - instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type] - instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs check' val u@(TUnknown _) = do val'@(TypedValue _ _ ty) <- infer val -- Don't unify an unknown with an inferred polytype diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 86e2c0a1c2..5d0584b191 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -10,7 +10,6 @@ module Language.PureScript.TypeChecker.Unify , unknownsInType , unifyTypes , unifyRows - , unifiesWith , replaceVarWithUnknown , replaceTypeWildcards , varIfUnknown @@ -102,6 +101,7 @@ unifyTypes t1 t2 = do unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return () unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) = guardWith (errorMessage (TypesDoNotUnify ty1 ty2)) (c1 == c2) + unifyTypes' (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = return () unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do t3 `unifyTypes` t5 t4 `unifyTypes` t6 @@ -152,36 +152,6 @@ unifyRows r1 r2 = unifyRows' _ _ _ _ = throwError . errorMessage $ TypesDoNotUnify r1 r2 --- | --- Check that two types unify --- -unifiesWith :: Type -> Type -> Bool -unifiesWith (TUnknown u1) (TUnknown u2) = u1 == u2 -unifiesWith (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2 -unifiesWith (TypeVar v1) (TypeVar v2) = v1 == v2 -unifiesWith (TypeLevelString s1) (TypeLevelString s2) = s1 == s2 -unifiesWith (TypeConstructor c1) (TypeConstructor c2) = c1 == c2 -unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2 -unifiesWith REmpty REmpty = True -unifiesWith r1@RCons{} r2@RCons{} = - let (s1, r1') = rowToList r1 - (s2, r2') = rowToList r2 - - int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] - sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] - sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] - in all (uncurry unifiesWith) int && go sd1 r1' sd2 r2' - where - go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool - go [] REmpty [] REmpty = True - go [] (TypeVar v1) [] (TypeVar v2) = v1 == v2 - go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2 - go [] (TUnknown _) _ _ = True - go _ _ [] (TUnknown _) = True - go _ (TUnknown _) _ (TUnknown _) = True - go _ _ _ _ = False -unifiesWith _ _ = False - -- | -- Replace a single type variable with a new unification variable -- diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 5d2af003e5..59becfdb1d 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -22,26 +22,3 @@ data TypeClassDictionaryInScope , tcdDependencies :: Maybe [Constraint] } deriving (Show) - --- | --- A simplified representation of expressions which are used to represent type --- class dictionaries at runtime, which can be compared for equality --- -data DictionaryValue - -- | - -- A dictionary which is brought into scope by a local constraint - -- - = LocalDictionaryValue (Qualified Ident) - -- | - -- A dictionary which is brought into scope by an instance declaration - -- - | GlobalDictionaryValue (Qualified Ident) - -- | - -- A dictionary which depends on other dictionaries - -- - | DependentDictionaryValue (Qualified Ident) [DictionaryValue] - -- | - -- A subclass dictionary - -- - | SubclassDictionaryValue DictionaryValue (Qualified (ProperName 'ClassName)) Integer - deriving (Show, Ord, Eq) diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 6dbab40f92..ac53dde327 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -17,8 +17,8 @@ typeAnnotation1, value1, synonym1, class1, class2, data1, data2, foreign1, forei typeAnnotation1 = P.TypeDeclaration (P.Ident "value1") P.REmpty value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left []) synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty -class1 = P.TypeClassDeclaration (P.ProperName "Class1") [] [] [] -class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] +class1 = P.TypeClassDeclaration (P.ProperName "Class1") [] [] [] [] +class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] [] [P.PositionedDeclaration span2 [] member1] data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] [] data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])] From 9376fdc100ada71bb9e84a76431161202a5f4d08 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 20 Sep 2016 20:08:32 -0700 Subject: [PATCH 0494/1580] Fix function application judgment --- .../failing/DoNotSuggestComposition2.purs | 2 +- examples/failing/OperatorSections.purs | 3 +- src/Language/PureScript/AST/Declarations.hs | 1 - src/Language/PureScript/Errors.hs | 12 --- src/Language/PureScript/TypeChecker/Types.hs | 94 +++++++++++-------- 5 files changed, 55 insertions(+), 57 deletions(-) diff --git a/examples/failing/DoNotSuggestComposition2.purs b/examples/failing/DoNotSuggestComposition2.purs index b6e13dcd5a..907d15b1af 100644 --- a/examples/failing/DoNotSuggestComposition2.purs +++ b/examples/failing/DoNotSuggestComposition2.purs @@ -1,4 +1,4 @@ --- @shouldFailWith CannotApplyFunction +-- @shouldFailWith TypesDoNotUnify -- TODO: Check that this does not produce a "function composition is (<<<)" -- suggestion. diff --git a/examples/failing/OperatorSections.purs b/examples/failing/OperatorSections.purs index 7be5b3f21b..14fc674121 100644 --- a/examples/failing/OperatorSections.purs +++ b/examples/failing/OperatorSections.purs @@ -1,8 +1,7 @@ --- @shouldFailWith CannotApplyFunction +-- @shouldFailWith TypesDoNotUnify module Main where import Prelude main = do (true `not` _) - diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index b826b637de..b6e638b227 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -90,7 +90,6 @@ data SimpleErrorMessage | ExprDoesNotHaveType Expr Type | PropertyIsMissing String | AdditionalProperty String - | CannotApplyFunction Type Expr | TypeSynonymInstance | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type] | InvalidNewtype (ProperName 'TypeName) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 96a2b74e16..6d0d71e781 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -133,7 +133,6 @@ errorCode em = case unwrapErrorMessage em of ExprDoesNotHaveType{} -> "ExprDoesNotHaveType" PropertyIsMissing{} -> "PropertyIsMissing" AdditionalProperty{} -> "AdditionalProperty" - CannotApplyFunction{} -> "CannotApplyFunction" TypeSynonymInstance -> "TypeSynonymInstance" OrphanInstance{} -> "OrphanInstance" InvalidNewtype{} -> "InvalidNewtype" @@ -257,7 +256,6 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2 gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t - gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts @@ -691,12 +689,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS line $ "Type of expression lacks required label " ++ markCode prop ++ "." renderSimpleErrorMessage (AdditionalProperty prop) = line $ "Type of expression contains additional label " ++ markCode prop ++ "." - renderSimpleErrorMessage (CannotApplyFunction fn arg) = - paras [ line "A function of type" - , markCodeBox $ indent $ typeAsBox fn - , line "can not be applied to the argument" - , markCodeBox $ indent $ prettyPrintValue valueDepth arg - ] renderSimpleErrorMessage TypeSynonymInstance = line "Type class instances for type synonyms are disallowed." renderSimpleErrorMessage (OrphanInstance nm cnm ts) = @@ -1036,10 +1028,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS -- | See https://github.com/purescript/purescript/issues/1802 stripRedudantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint] - stripRedudantHints CannotApplyFunction{} = stripFirst isApplicationHint - where - isApplicationHint ErrorInApplication{} = True - isApplicationHint _ = False stripRedudantHints ExprDoesNotHaveType{} = stripFirst isCheckHint where isCheckHint ErrorCheckingType{} = True diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index f748e3e6d5..3135148396 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -292,7 +292,7 @@ infer' (Abs (Left arg) ret) = do infer' (Abs (Right _) _) = internalError "Binder was not desugared" infer' (App f arg) = do f'@(TypedValue _ _ ft) <- infer f - (ret, app) <- checkFunctionApplication f' ft arg Nothing + (ret, app) <- checkFunctionApplication f' ft arg return $ TypedValue True app ret infer' (Var var) = do checkVisibility var @@ -567,8 +567,11 @@ check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do check' (Abs (Right _) _) _ = internalError "Binder was not desugared" check' (App f arg) ret = do f'@(TypedValue _ _ ft) <- infer f - (_, app) <- checkFunctionApplication f' ft arg (Just ret) - return $ TypedValue True app ret + (retTy, app) <- checkFunctionApplication f' ft arg + v' <- subsumes (Just app) retTy ret + case v' of + Nothing -> internalError "check: unable to check the subsumes relation." + Just app' -> return $ TypedValue True app' ret check' v@(Var var) ty = do checkVisibility var repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var @@ -692,55 +695,64 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh return $ (p, v') : ps'' go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyRecord row) --- | Check the type of a function application, rethrowing errors to provide a better error message -checkFunctionApplication :: - (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - Expr -> - Type -> - Expr -> - Maybe Type -> - m (Type, Expr) -checkFunctionApplication fn fnTy arg ret = withErrorMessageHint (ErrorInApplication fn fnTy arg) $ do +-- | Check the type of a function application, rethrowing errors to provide a better error message. +-- +-- This judgment takes three inputs: +-- +-- * The expression of the function we are applying +-- * The type of that function +-- * The expression we are applying it to +-- +-- and synthesizes two outputs: +-- +-- * The return type +-- * The elaborated expression for the function application (since we might need to +-- insert type class dictionaries, etc.) +checkFunctionApplication + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Expr + -- ^ The function expression + -> Type + -- ^ The type of the function + -> Expr + -- ^ The argument expression + -> m (Type, Expr) + -- ^ The result type, and the elaborated term +checkFunctionApplication fn fnTy arg = withErrorMessageHint (ErrorInApplication fn fnTy arg) $ do subst <- gets checkSubstitution - checkFunctionApplication' fn (substituteType subst fnTy) arg (substituteType subst <$> ret) + checkFunctionApplication' fn (substituteType subst fnTy) arg -- | Check the type of a function application -checkFunctionApplication' :: - (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - Expr -> - Type -> - Expr -> - Maybe Type -> - m (Type, Expr) -checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do +checkFunctionApplication' + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Expr + -> Type + -> Expr + -> m (Type, Expr) +checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg = do unifyTypes tyFunction' tyFunction arg' <- check arg argTy - case ret of - Nothing -> return (retTy, App fn arg') - Just ret' -> do - Just app' <- subsumes (Just (App fn arg')) retTy ret' - return (retTy, app') -checkFunctionApplication' fn (ForAll ident ty _) arg ret = do + return (retTy, App fn arg') +checkFunctionApplication' fn (ForAll ident ty _) arg = do replaced <- replaceVarWithUnknown ident ty - checkFunctionApplication fn replaced arg ret -checkFunctionApplication' fn u@(TUnknown _) arg ret = do + checkFunctionApplication fn replaced arg +checkFunctionApplication' fn (KindedType ty _) arg = + checkFunctionApplication fn ty arg +checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg = do + dicts <- getTypeClassDictionaries + hints <- gets checkHints + checkFunctionApplication' (foldl App fn (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) fnTy arg +checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} = + return (fnTy, App fn dict) +checkFunctionApplication' fn u arg = do arg' <- do TypedValue _ arg' t <- infer arg (arg'', t') <- instantiatePolyTypeWithUnknowns arg' t return $ TypedValue True arg'' t' let ty = (\(TypedValue _ _ t) -> t) arg' - ret' <- maybe freshType return ret - unifyTypes u (function ty ret') - return (ret', App fn arg') -checkFunctionApplication' fn (KindedType ty _) arg ret = - checkFunctionApplication fn ty arg ret -checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do - dicts <- getTypeClassDictionaries - hints <- gets checkHints - checkFunctionApplication' (foldl App fn (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) fnTy arg ret -checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ = - return (fnTy, App fn dict) -checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg + ret <- freshType + unifyTypes u (function ty ret) + return (ret, App fn arg') -- | -- Ensure a set of property names and value does not contain duplicate labels From a6de68c6ce496aa7786a9ade4d40657b9a4400bd Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 21 Sep 2016 19:33:58 -0700 Subject: [PATCH 0495/1580] Fix a small bug in the type pretty-printer --- src/Language/PureScript/Pretty/Types.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 70d231214c..8583450091 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -45,11 +45,11 @@ typeLiterals = mkPattern match match _ = Nothing constraintsAsBox :: [Constraint] -> Box -> Box -constraintsAsBox [(Constraint pn tys _)] ty = text "(" <> constraintAsBox pn tys `before` (text ") => " <> ty) -constraintsAsBox xs ty = vcat left (zipWith (\i (Constraint pn tys _) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty) +constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty) +constraintsAsBox xs ty = vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (text ") => " <> ty) -constraintAsBox :: Qualified (ProperName a) -> [Type] -> Box -constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys) +constraintAsBox :: Constraint -> Box +constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys) -- | -- Generate a pretty-printed string representing a Row From 765aeb4f7ee3ba539bf308d3a66d330ea2c79266 Mon Sep 17 00:00:00 2001 From: rightfold Date: Thu, 22 Sep 2016 04:38:33 +0200 Subject: [PATCH 0496/1580] Add --dump-corefn command line option (#2275) * Add --dump-corefn command line option * Derive ToJSON instances for CoreFn * Revert "Derive ToJSON instances for CoreFn" This reverts commit 96bbd1f24e757795103369ea273358d3945c1d8d. * Add rightfold to contributors list and license to their contributions * Implement typeToJSON * Implement kindToJSON * Implement missing JSON converters needed for typeToJSON * Implement annToJSON * License under MIT instead of BSD * Add PureScript version to JSON CoreFn dump * Use internalError instead of error * Clarify --dump-corefn option * Add Haddock comment to CoreFn.ToJSON, and export fewer functions * Remove types from CoreFn dump * Remove source spans from CoreFn dump * Simplify CoreFn dump of product types * More descriptive type tags for int and float literals * Smaller core JSON * Bits * Add back data constructor names for Var and VarBinder * Keep Rec/NoRec info in core AST --- CONTRIBUTORS.md | 1 + psc/Main.hs | 6 ++ purescript.cabal | 1 + src/Language/PureScript/CoreFn/ToJSON.hs | 116 +++++++++++++++++++++++ src/Language/PureScript/Make.hs | 9 ++ src/Language/PureScript/Options.hs | 5 +- 6 files changed, 137 insertions(+), 1 deletion(-) create mode 100644 src/Language/PureScript/CoreFn/ToJSON.hs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 6677cfaba5..702549494c 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -64,6 +64,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@philopon](https://github.com/philopon) (Hirotomo Moriwaki) - My existing contributions and all future contributions until further notice are Copyright Hirotomo Moriwaki, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@pseudonom](https://github.com/pseudonom) (Eric Easley) My existing contributions and all future contributions until further notice are Copyright Eric Easley, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@puffnfresh](https://github.com/puffnfresh) (Brian McKenna) All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler. +- [@rightfold](https://github.com/rightfold) (rightfold) My existing contributions and all future contributions until further notice are Copyright rightfold, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](https://opensource.org/licenses/MIT). - [@robdaemon](https://github.com/robdaemon) (Robert Roland) My existing contributions and all future contributions until further notice are Copyright Robert Roland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@RossMeikleham](https://github.com/RossMeikleham) (Ross Meikleham) My existing contributions and all future contributions until further notice are Copyright Ross Meikleham, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@rvion](https://github.com/rvion) (Rémi Vion) My existing contributions and all future contributions until further notice are Copyright Rémi Vion, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). diff --git a/psc/Main.hs b/psc/Main.hs index 457ce59464..47ae898fe3 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -143,6 +143,11 @@ sourceMaps = switch $ long "source-maps" <> help "Generate source maps" +dumpCoreFn :: Parser Bool +dumpCoreFn = switch $ + long "dump-corefn" + <> help "Dump the (functional) core representation of the compiled code at output/*/corefn.json" + options :: Parser P.Options options = P.Options <$> noTco @@ -152,6 +157,7 @@ options = P.Options <$> noTco <*> verboseErrors <*> (not <$> comments) <*> sourceMaps + <*> dumpCoreFn pscMakeOptions :: Parser PSCMakeOptions pscMakeOptions = PSCMakeOptions <$> many inputFile diff --git a/purescript.cabal b/purescript.cabal index aa089e1cb5..153d6107b1 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -180,6 +180,7 @@ library Language.PureScript.CoreFn.Meta Language.PureScript.CoreFn.Module Language.PureScript.CoreFn.Traversals + Language.PureScript.CoreFn.ToJSON Language.PureScript.Comments Language.PureScript.Environment Language.PureScript.Errors diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs new file mode 100644 index 0000000000..69ef3eb039 --- /dev/null +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -0,0 +1,116 @@ +-- | +-- Dump the core functional representation in JSON format for consumption +-- by third-party code generators +-- +module Language.PureScript.CoreFn.ToJSON + ( moduleToJSON + ) where + +import Prelude.Compat + +import Data.Aeson +import Data.Version (Version, showVersion) +import Data.Text (pack) + +import Language.PureScript.AST.Literals +import Language.PureScript.CoreFn +import Language.PureScript.Names + +literalToJSON :: (a -> Value) -> Literal a -> Value +literalToJSON _ (NumericLiteral (Left n)) = toJSON ("IntLiteral", n) +literalToJSON _ (NumericLiteral (Right n)) = toJSON ("NumberLiteral", n) +literalToJSON _ (StringLiteral s) = toJSON ("StringLiteral", s) +literalToJSON _ (CharLiteral c) = toJSON ("CharLiteral", c) +literalToJSON _ (BooleanLiteral b) = toJSON ("BooleanLiteral", b) +literalToJSON t (ArrayLiteral xs) = toJSON ("ArrayLiteral", map t xs) +literalToJSON t (ObjectLiteral xs) = toJSON ("ObjectLiteral", recordToJSON t xs) + +identToJSON :: Ident -> Value +identToJSON = toJSON . runIdent + +properNameToJSON :: ProperName a -> Value +properNameToJSON = toJSON . runProperName + +qualifiedToJSON :: (a -> String) -> Qualified a -> Value +qualifiedToJSON f = toJSON . showQualified f + +moduleNameToJSON :: ModuleName -> Value +moduleNameToJSON = toJSON . runModuleName + +moduleToJSON :: Version -> Module a -> Value +moduleToJSON v m = object [ pack "imports" .= map (moduleNameToJSON . snd) (moduleImports m) + , pack "exports" .= map identToJSON (moduleExports m) + , pack "foreign" .= map (identToJSON . fst) (moduleForeign m) + , pack "decls" .= map bindToJSON (moduleDecls m) + , pack "builtWith" .= toJSON (showVersion v) + ] + +bindToJSON :: Bind a -> Value +bindToJSON (NonRec _ n e) = object [ pack (runIdent n) .= exprToJSON e ] +bindToJSON (Rec bs) = object $ map (\((_, n), e) -> pack (runIdent n) .= exprToJSON e) bs + +recordToJSON :: (a -> Value) -> [(String, a)] -> Value +recordToJSON f = object . map (\(label, a) -> pack label .= f a) + +exprToJSON :: Expr a -> Value +exprToJSON (Var _ i) = toJSON ( "Var" + , qualifiedToJSON runIdent i + ) +exprToJSON (Literal _ l) = toJSON ( "Literal" + , literalToJSON (exprToJSON) l + ) +exprToJSON (Constructor _ d c is) = toJSON ( "Constructor" + , properNameToJSON d + , properNameToJSON c + , map identToJSON is + ) +exprToJSON (Accessor _ f r) = toJSON ( "Accessor" + , f + , exprToJSON r + ) +exprToJSON (ObjectUpdate _ r fs) = toJSON ( "ObjectUpdate" + , exprToJSON r + , recordToJSON exprToJSON fs + ) +exprToJSON (Abs _ p b) = toJSON ( "Abs" + , identToJSON p + , exprToJSON b + ) +exprToJSON (App _ f x) = toJSON ( "App" + , exprToJSON f + , exprToJSON x + ) +exprToJSON (Case _ ss cs) = toJSON ( "Case" + , map exprToJSON ss + , map caseAlternativeToJSON cs + ) +exprToJSON (Let _ bs e) = toJSON ( "Let" + , map bindToJSON bs + , exprToJSON e + ) + +caseAlternativeToJSON :: CaseAlternative a -> Value +caseAlternativeToJSON (CaseAlternative bs r') = + toJSON [ toJSON (map binderToJSON bs) + , case r' of + Left rs -> toJSON $ map (\(g, e) -> (exprToJSON g, exprToJSON e)) rs + Right r -> exprToJSON r + ] + +binderToJSON :: Binder a -> Value +binderToJSON (VarBinder _ v) = toJSON ( "VarBinder" + , identToJSON v + ) +binderToJSON (NullBinder _) = toJSON "NullBinder" +binderToJSON (LiteralBinder _ l) = toJSON ( "LiteralBinder" + , literalToJSON binderToJSON l + ) +binderToJSON (ConstructorBinder _ d c bs) = toJSON ( "ConstructorBinder" + , qualifiedToJSON runProperName d + , qualifiedToJSON runProperName c + , map binderToJSON bs + ) +binderToJSON (NamedBinder _ n b) = toJSON ( "NamedBinder" + , identToJSON n + , binderToJSON b + ) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index b4f928a6f0..5e68831aa0 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Make ( @@ -36,6 +37,7 @@ import Control.Monad.Trans.Except import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Aeson (encode, decode) +import qualified Data.Aeson as Aeson import Data.ByteString.Builder (toLazyByteString, stringUtf8) import Data.Either (partitionEithers) import Data.Foldable (for_) @@ -69,6 +71,7 @@ import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.CodeGen.JS as J import qualified Language.PureScript.Constants as C import qualified Language.PureScript.CoreFn as CF +import qualified Language.PureScript.CoreFn.ToJSON as CFJ import qualified Language.PureScript.Parser as PSParser import qualified Paths_purescript as Paths @@ -369,6 +372,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile) writeTextFile externsFile exts lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings + dumpCoreFn <- lift $ asks optionsDumpCoreFn + when dumpCoreFn $ do + let coreFnFile = outputDir filePath "corefn.json" + let jsonPayload = CFJ.moduleToJSON Paths.version m + let json = Aeson.object [ (fromString (runModuleName mn), jsonPayload) ] + lift $ writeTextFile coreFnFile (BU8.toString . B.toStrict . encode $ json) genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index 5fb0fdc8ae..62040a8707 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -31,9 +31,12 @@ data Options = Options { -- | -- Generate soure maps , optionsSourceMaps :: Bool + -- | + -- Dump CoreFn + , optionsDumpCoreFn :: Bool } deriving Show -- | -- Default make options defaultOptions :: Options -defaultOptions = Options False False Nothing False False False False +defaultOptions = Options False False Nothing False False False False False From 820b12b49f0334623f0672e5dff7b2014d25b5b7 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Thu, 22 Sep 2016 20:37:59 +0100 Subject: [PATCH 0497/1580] [psc-ide] Update pursuit JSON parsing Per https://github.com/purescript/pursuit/pull/246 - this was not working since JSON format changed. Now no need to parse out type, and can provide additional summary text. --- src/Language/PureScript/Ide/Types.hs | 41 ++++++---------------------- 1 file changed, 9 insertions(+), 32 deletions(-) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index a76e96eb29..7bf2869487 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -25,8 +25,6 @@ import Data.Map.Lazy as M import qualified Language.PureScript.Errors.JSON as P import qualified Language.PureScript as P import Language.PureScript.Ide.Conversions -import Text.Parsec as Parsec -import Text.Parsec.Text type ModuleIdent = Text @@ -209,9 +207,9 @@ data PursuitResponse = -- | A Pursuit Response for a module. Consists of the modules name and the -- package it belongs to ModuleResponse ModuleIdent Text - -- | A Pursuit Response for a declaration. Consist of the declarations type, - -- module, name and package - | DeclarationResponse Text ModuleIdent Text Text + -- | A Pursuit Response for a declaration. Consist of the declaration's + -- module, name, package, type summary text + | DeclarationResponse Text ModuleIdent Text (Maybe Text) Text deriving (Show,Eq) instance FromJSON PursuitResponse where @@ -225,42 +223,21 @@ instance FromJSON PursuitResponse where pure (ModuleResponse name package) "declaration" -> do moduleName <- info .: "module" - Right (ident, declType) <- typeParse <$> o .: "text" - pure (DeclarationResponse declType moduleName ident package) + ident <- info .: "title" + (text :: Text) <- o .: "text" + typ <- info .:? "typeText" + pure (DeclarationResponse moduleName ident package typ text) _ -> mzero parseJSON _ = mzero - -typeParse :: Text -> Either Text (Text, Text) -typeParse t = case parse parseType "" t of - Right (x,y) -> Right (x, y) - Left err -> Left (show err) - where - parseType :: Parser (Text, Text) - parseType = do - name <- identifier - _ <- string "::" - spaces - type' <- many1 anyChar - pure (name, toS type') - - identifier :: Parser Text - identifier = do - spaces - ident <- - -- necessary for being able to parse the following ((++), concat) - between (char '(') (char ')') (many1 (noneOf ", )")) Parsec.<|> - many1 (noneOf ", )") - spaces - pure (toS ident) - instance ToJSON PursuitResponse where toJSON (ModuleResponse name package) = object ["module" .= name, "package" .= package] - toJSON (DeclarationResponse module' ident type' package) = + toJSON (DeclarationResponse module' ident package type' text) = object [ "module" .= module' , "ident" .= ident , "type" .= type' , "package" .= package + , "text" .= text ] From 0ad1005b78f7cb1bab16d3ea985327d0518d0d3f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 22 Sep 2016 18:22:52 -0700 Subject: [PATCH 0498/1580] -> 0.10.0 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 153d6107b1..4c07045448 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.9.3 +version: 0.10.0 cabal-version: >=1.8 build-type: Simple license: MIT From a84f7f36ee321be675626db83200310ba34214e6 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Fri, 23 Sep 2016 05:21:24 +0100 Subject: [PATCH 0499/1580] [psc-ide] Return qualifier from explicit/hiding imports (#2317) --- psc-ide-server/PROTOCOL.md | 41 ++++++++++++++++++++++------ src/Language/PureScript/Ide/Types.hs | 24 ++++++++-------- 2 files changed, 45 insertions(+), 20 deletions(-) diff --git a/psc-ide-server/PROTOCOL.md b/psc-ide-server/PROTOCOL.md index 205650584e..20c5b1bfb1 100644 --- a/psc-ide-server/PROTOCOL.md +++ b/psc-ide-server/PROTOCOL.md @@ -68,7 +68,7 @@ The `complete` command looks up possible completions/corrections. If no matcher is given every candidate, that passes the filters, is returned in no particular order. - + ```json { "command": "complete", @@ -106,7 +106,7 @@ couldn't be extracted from a source file. ``` -### CaseSplit +### CaseSplit The CaseSplit command takes a line of source code, an area in that line of code and replaces it with all patterns for a given type. The parameter `annotations` @@ -250,9 +250,9 @@ Example: "importCommand": { "importCommand": "addImport", "identifier": "bind" - } + } } -} +} ``` ### Rebuild @@ -381,7 +381,7 @@ The list commmand can also list the imports for a given file. The list import command returns a list of imports where imports are of the following form: -Implicit Import(`import Data.Array`): +Implicit Import (`import Data.Array`): ```json [ { @@ -391,7 +391,7 @@ Implicit Import(`import Data.Array`): ] ``` -Implicit qualified Import(`import qualified Data.Array as A`): +Implicit qualified Import (`import Data.Array as A`): ```json [ { @@ -402,7 +402,7 @@ Implicit qualified Import(`import qualified Data.Array as A`): ] ``` -Explicit Import(`import Data.Array (filter, filterM, join)`): +Explicit Import (`import Data.Array (filter, filterM, join)`): ```json [ { @@ -413,7 +413,19 @@ Explicit Import(`import Data.Array (filter, filterM, join)`): ] ``` -Hiding Import(`import Data.Array hiding (filter, filterM, join)`): +Explicit qualified Import (`import Data.Array (filter, filterM, join) as A`): +```json +[ + { + "module": "Data.Array", + "importType": "explicit", + "identifiers": ["filter", "filterM", "join"], + "qualifier": "A" + } +] +``` + +Hiding Import (`import Data.Array hiding (filter, filterM, join)`): ```json [ { @@ -423,6 +435,19 @@ Hiding Import(`import Data.Array hiding (filter, filterM, join)`): } ] ``` + +Qualified Hiding Import (`import Data.Array hiding (filter, filterM, join) as A`): +```json +[ + { + "module": "Data.Array", + "importType": "hiding", + "identifiers": ["filter", "filterM", "join"], + "qualifier": "A" + } +] +``` + ### Cwd/Quit/Reset `cwd` returns the working directory of the server(should be your project root). diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 7bf2869487..56b7550254 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -21,7 +21,7 @@ import Protolude import Control.Concurrent.STM import Data.Aeson -import Data.Map.Lazy as M +import qualified Data.Map.Lazy as M import qualified Language.PureScript.Errors.JSON as P import qualified Language.PureScript as P import Language.PureScript.Ide.Conversions @@ -146,17 +146,17 @@ instance ToJSON ModuleImport where toJSON (ModuleImport mn P.Implicit qualifier) = object $ [ "module" .= mn , "importType" .= ("implicit" :: Text) - ] ++ fmap (\x -> "qualifier" .= x) (maybeToList qualifier) - toJSON (ModuleImport mn (P.Explicit refs) _) = - object [ "module" .= mn - , "importType" .= ("explicit" :: Text) - , "identifiers" .= (identifierFromDeclarationRef <$> refs) - ] - toJSON (ModuleImport mn (P.Hiding refs) _) = - object [ "module" .= mn - , "importType" .= ("hiding" :: Text) - , "identifiers" .= (identifierFromDeclarationRef <$> refs) - ] + ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) + toJSON (ModuleImport mn (P.Explicit refs) qualifier) = + object $ [ "module" .= mn + , "importType" .= ("explicit" :: Text) + , "identifiers" .= (identifierFromDeclarationRef <$> refs) + ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) + toJSON (ModuleImport mn (P.Hiding refs) qualifier) = + object $ [ "module" .= mn + , "importType" .= ("hiding" :: Text) + , "identifiers" .= (identifierFromDeclarationRef <$> refs) + ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) identifierFromDeclarationRef :: P.DeclarationRef -> Text identifierFromDeclarationRef (P.TypeRef name _) = runProperNameT name From e0b26554ce579c07d72b008683ca0a0c36c0165b Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 23 Sep 2016 19:26:47 +0100 Subject: [PATCH 0500/1580] Add deriving for Data.Newtype --- .../failing/CannotDeriveNewtypeForData.purs | 8 +++ .../failing/NonWildcardNewtypeInstance.purs | 8 +++ examples/failing/TypeWildcards3.purs | 3 +- examples/passing/DeriveNewtype.purs | 17 +++++ src/Language/PureScript/AST/Declarations.hs | 2 + src/Language/PureScript/Errors.hs | 10 +++ .../PureScript/Parser/Declarations.hs | 2 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 66 +++++++++++++++++-- src/Language/PureScript/TypeChecker.hs | 14 ++-- tests/TestUtils.hs | 2 + tests/support/bower.json | 5 +- 11 files changed, 124 insertions(+), 13 deletions(-) create mode 100644 examples/failing/CannotDeriveNewtypeForData.purs create mode 100644 examples/failing/NonWildcardNewtypeInstance.purs create mode 100644 examples/passing/DeriveNewtype.purs diff --git a/examples/failing/CannotDeriveNewtypeForData.purs b/examples/failing/CannotDeriveNewtypeForData.purs new file mode 100644 index 0000000000..f40568d2d0 --- /dev/null +++ b/examples/failing/CannotDeriveNewtypeForData.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith CannotDeriveNewtypeForData +module CannotDeriveNewtypeForData where + +import Data.Newtype + +data Test = Test String + +derive instance newtypeTest :: Newtype Test _ diff --git a/examples/failing/NonWildcardNewtypeInstance.purs b/examples/failing/NonWildcardNewtypeInstance.purs new file mode 100644 index 0000000000..3c8f947b96 --- /dev/null +++ b/examples/failing/NonWildcardNewtypeInstance.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith NonWildcardNewtypeInstance +module NonWildcardNewtypeInstance where + +import Data.Newtype + +data Test = Test String + +derive instance newtypeTest :: Newtype Test String diff --git a/examples/failing/TypeWildcards3.purs b/examples/failing/TypeWildcards3.purs index 5c60b30ad1..c0463faa0a 100644 --- a/examples/failing/TypeWildcards3.purs +++ b/examples/failing/TypeWildcards3.purs @@ -1,4 +1,4 @@ --- @shouldFailWith ErrorParsingModule +-- @shouldFailWith InvalidInstanceHead module TypeWildcards where import Prelude @@ -7,4 +7,3 @@ data Foo a = Foo instance showFoo :: Show (Foo _) where show Foo = "Foo" - diff --git a/examples/passing/DeriveNewtype.purs b/examples/passing/DeriveNewtype.purs new file mode 100644 index 0000000000..6b05c0ddb5 --- /dev/null +++ b/examples/passing/DeriveNewtype.purs @@ -0,0 +1,17 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +import Data.Newtype + +newtype Test = Test String + +derive instance newtypeTest :: Newtype Test _ + +t :: Test +t = wrap "hello" + +a :: String +a = unwrap t + +main = log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index b6e638b227..6a68cfab32 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -123,6 +123,8 @@ data SimpleErrorMessage | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident) | DeprecatedRequirePath | CannotGeneralizeRecursiveFunction Ident Type + | CannotDeriveNewtypeForData (ProperName 'TypeName) + | NonWildcardNewtypeInstance (ProperName 'TypeName) deriving (Show) -- | Error message hints, providing more detailed information about failure. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6d0d71e781..b176f11015 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -166,6 +166,8 @@ errorCode em = case unwrapErrorMessage em of InvalidOperatorInBinder{} -> "InvalidOperatorInBinder" DeprecatedRequirePath{} -> "DeprecatedRequirePath" CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction" + CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData" + NonWildcardNewtypeInstance{} -> "NonWildcardNewtypeInstance" -- | -- A stack trace for an error @@ -831,6 +833,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , line "Try adding a type signature." ] + renderSimpleErrorMessage (CannotDeriveNewtypeForData tyName) = + paras [ line $ "Cannot derive an instance of the " ++ markCode "Newtype" ++ " class for non-newtype " ++ markCode (runProperName tyName) ++ "." + ] + + renderSimpleErrorMessage (NonWildcardNewtypeInstance tyName) = + paras [ line $ "A type wildcard (_) should be used for the inner type when deriving the " ++ markCode "Newtype" ++ " instance for " ++ markCode (runProperName tyName) ++ "." + ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index c04b16aa3f..e192eee209 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -209,7 +209,7 @@ parseInstanceDeclaration = do rfatArrow return deps className <- indented *> parseQualified properName - ty <- P.many (indented *> noWildcards parseTypeAtom) + ty <- P.many (indented *> parseTypeAtom) return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty parseTypeInstanceDeclaration :: TokenParser Declaration diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index ff57c7e1f7..2dcceefe6c 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -22,6 +22,7 @@ import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Types +import Language.PureScript.TypeChecker (checkNewtype) import qualified Language.PureScript.Constants as C -- | Elaborates deriving instance declarations by code generation. @@ -44,14 +45,21 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args - | className == Qualified (Just (ModuleName [ ProperName "Data", ProperName "Eq" ])) (ProperName "Eq") + | className == Qualified (Just dataEq) (ProperName "Eq") , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon - | className == Qualified (Just (ModuleName [ ProperName "Data", ProperName "Ord" ])) (ProperName "Ord") + | className == Qualified (Just dataOrd) (ProperName "Ord") , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon +deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance) + | className == Qualified (Just dataNewtype) (ProperName "Newtype") + , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor wrappedTy + , mn == fromMaybe mn mn' + = do + (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon unwrappedTy + return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) = throwError . errorMessage $ CannotDerive className tys deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance) @@ -100,6 +108,15 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ] typesProxy :: ModuleName typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ] +dataEq :: ModuleName +dataEq = ModuleName [ ProperName "Data", ProperName "Eq" ] + +dataOrd :: ModuleName +dataOrd = ModuleName [ ProperName "Data", ProperName "Ord" ] + +dataNewtype :: ModuleName +dataNewtype = ModuleName [ ProperName "Data", ProperName "Newtype" ] + deriveGeneric :: forall m. (MonadError MultipleErrors m, MonadSupply m) => ModuleName @@ -290,7 +307,7 @@ deriveEq mn ds tyConNm = do preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "HeytingAlgebra"])) (Ident C.conj))) preludeEq :: Expr -> Expr -> Expr - preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Eq"])) (Ident C.eq))) + preludeEq = App . App (Var (Qualified (Just dataEq) (Ident C.eq))) addCatch :: [CaseAlternative] -> [CaseAlternative] addCatch xs @@ -360,7 +377,7 @@ deriveOrd mn ds tyConNm = do orderingBinder name = ConstructorBinder (orderingName name) [] ordCompare :: Expr -> Expr -> Expr - ordCompare = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Ord"])) (Ident C.compare))) + ordCompare = App . App (Var (Qualified (Just dataOrd) (Ident C.compare))) mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative] mkCtorClauses ((ctorName, tys), isLast) = do @@ -404,6 +421,47 @@ deriveOrd mn ds tyConNm = do $ decomposeRec rec toOrdering l r _ = ordCompare l r +deriveNewtype + :: forall m + . (MonadError MultipleErrors m, MonadSupply m) + => ModuleName + -> [Declaration] + -> ProperName 'TypeName + -> Type + -> m ([Declaration], Type) +deriveNewtype mn ds tyConNm unwrappedTy = do + checkIsWildcard unwrappedTy + go =<< findTypeDecl tyConNm ds + where + + go :: Declaration -> m ([Declaration], Type) + go (DataDeclaration Data name _ _) = + throwError . errorMessage $ CannotDeriveNewtypeForData name + go (DataDeclaration Newtype name _ dctors) = do + checkNewtype name dctors + let (ctorName, [ty]) = head dctors + wrappedIdent <- freshIdent "n" + unwrappedIdent <- freshIdent "a" + let inst = + [ ValueDeclaration (Ident "wrap") Public [] $ Right $ + Constructor (Qualified (Just mn) ctorName) + , ValueDeclaration (Ident "unwrap") Public [] $ Right $ + lamCase wrappedIdent + [ CaseAlternative + [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]] + (Right (Var (Qualified Nothing unwrappedIdent))) + ] + ] + return (inst, ty) + go (PositionedDeclaration _ _ d) = go d + go _ = internalError "deriveNewtype go: expected DataDeclaration" + + checkIsWildcard :: Type -> m () + checkIsWildcard (TypeWildcard _) = + return () + checkIsWildcard _ = + throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm + findTypeDecl :: (MonadError MultipleErrors m) => ProperName 'TypeName diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index a621048768..62e45595eb 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -6,6 +6,7 @@ module Language.PureScript.TypeChecker ( module T , typeCheckModule + , checkNewtype ) where import Prelude.Compat @@ -318,10 +319,6 @@ typeCheckAll moduleName _ = traverse go checkType _ = internalError "Invalid type in instance in checkOrphanInstance" checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance" - checkNewtype :: ProperName 'TypeName -> [(ProperName 'ConstructorName, [Type])] -> m () - checkNewtype _ [(_, [_])] = return () - checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name - -- | -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, -- extracted from the kind of the type constructor itself. @@ -332,6 +329,15 @@ typeCheckAll moduleName _ = traverse go withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2 withKinds _ _ = internalError "Invalid arguments to peelKinds" +checkNewtype + :: forall m + . MonadError MultipleErrors m + => ProperName 'TypeName + -> [(ProperName 'ConstructorName, [Type])] + -> m () +checkNewtype _ [(_, [_])] = return () +checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name + -- | -- Type check an entire module and ensure all types and classes defined within the module that are -- required by exported members are also exported. diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 49e9c2a434..f1a252215d 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -75,6 +75,8 @@ supportModules = , "Data.Function" , "Data.Functor" , "Data.HeytingAlgebra" + , "Data.NaturalTransformation" + , "Data.Newtype" , "Data.Ord.Unsafe" , "Data.Ord" , "Data.Ordering" diff --git a/tests/support/bower.json b/tests/support/bower.json index ca9d449fe4..7bbaebd6dd 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -5,8 +5,9 @@ "purescript-console": "1.0.0-rc.1", "purescript-eff": "1.0.0-rc.1", "purescript-functions": "1.0.0-rc.1", - "purescript-prelude": "1.0.0-rc.3", + "purescript-prelude": "1.1.0", "purescript-st": "1.0.0-rc.1", - "purescript-partial": "1.1.2" + "purescript-partial": "1.1.2", + "purescript-newtype": "0.1.0" } } From 07e2e9cfefc007e3fd6302124c1d6788b0db1b45 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 24 Sep 2016 00:52:19 +0100 Subject: [PATCH 0501/1580] Fix test for fixed Show instance for Number --- examples/passing/NumberLiterals.purs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/examples/passing/NumberLiterals.purs b/examples/passing/NumberLiterals.purs index 46b789d5ed..b8271790dd 100644 --- a/examples/passing/NumberLiterals.purs +++ b/examples/passing/NumberLiterals.purs @@ -19,8 +19,8 @@ main = do test "32.96176575630599" 32.96176575630599 test "38.47735512322269" 38.47735512322269 - test "10000000000" 1e10 - test "10000000000" 1.0e10 + test "10000000000.0" 1e10 + test "10000000000.0" 1.0e10 test "0.00001" 1e-5 test "0.00001" 1.0e-5 test "1.5339794352098402e-118" 1.5339794352098402e-118 From 34d072fffd6a7d3d11d5243f9630dd2dcfb0d99b Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 24 Sep 2016 12:07:18 +0100 Subject: [PATCH 0502/1580] Fix handling of duplicate module imports in JS codegen --- src/Language/PureScript/CodeGen/JS.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index f48d928c56..db1ea96f70 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -15,7 +15,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class -import Data.List ((\\), delete, intersect) +import Data.List ((\\), delete, intersect, nub) import Data.Maybe (isNothing, fromMaybe) import qualified Data.Foldable as F import qualified Data.Map as M @@ -51,7 +51,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps - jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd imps + jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ nub $ map snd imps let decls' = renameModules mnLookup decls jsDecls <- mapM bindToJs decls' optimized <- T.traverse (T.traverse optimize) jsDecls @@ -89,7 +89,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = in if mn' /= mn && mni `elem` used then let newName = freshModuleName 1 mn' used in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns' - else go (M.insert mn' (ann, mn') acc) (mni : used) mns' + else go (M.insert mn' (ann, mn') acc) used mns' go acc _ [] = acc freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName From 6fd459e61665e004f56b14403b8c5be516649f6d Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 24 Sep 2016 11:45:05 +0100 Subject: [PATCH 0503/1580] Fix the duplicate/redefined module error --- examples/failing/DuplicateModule.purs | 2 ++ examples/failing/DuplicateModule/M1.purs | 1 + purescript.cabal | 1 + src/Language/PureScript/AST/Declarations.hs | 7 ++++-- src/Language/PureScript/Errors.hs | 13 ++++------- src/Language/PureScript/Make.hs | 26 ++++++++++----------- src/Language/PureScript/Sugar/Names.hs | 15 +++++------- 7 files changed, 33 insertions(+), 32 deletions(-) create mode 100644 examples/failing/DuplicateModule.purs create mode 100644 examples/failing/DuplicateModule/M1.purs diff --git a/examples/failing/DuplicateModule.purs b/examples/failing/DuplicateModule.purs new file mode 100644 index 0000000000..5cd8a13e25 --- /dev/null +++ b/examples/failing/DuplicateModule.purs @@ -0,0 +1,2 @@ +-- @shouldFailWith DuplicateModule +module M1 where diff --git a/examples/failing/DuplicateModule/M1.purs b/examples/failing/DuplicateModule/M1.purs new file mode 100644 index 0000000000..5d99c370b0 --- /dev/null +++ b/examples/failing/DuplicateModule/M1.purs @@ -0,0 +1 @@ +module M1 where diff --git a/purescript.cabal b/purescript.cabal index 4c07045448..f2d4543228 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -60,6 +60,7 @@ extra-source-files: examples/passing/*.purs , examples/failing/ConflictingImports2/*.purs , examples/failing/ConflictingQualifiedImports/*.purs , examples/failing/ConflictingQualifiedImports2/*.purs + , examples/failing/DuplicateModule/*.purs , examples/failing/ExportConflictClass/*.purs , examples/failing/ExportConflictCtor/*.purs , examples/failing/ExportConflictType/*.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index b6e638b227..d28736e6a7 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -47,7 +47,6 @@ data SimpleErrorMessage | MultipleValueOpFixities (OpName 'ValueOpName) | MultipleTypeOpFixities (OpName 'TypeOpName) | OrphanTypeDeclaration Ident - | RedefinedModule ModuleName [SourceSpan] | RedefinedIdent Ident | OverlappingNamesInLet | UnknownName (Qualified Name) @@ -59,7 +58,7 @@ data SimpleErrorMessage | ScopeShadowing Name (Maybe ModuleName) [ModuleName] | DeclConflict Name Name | ExportConflict (Qualified Name) (Qualified Name) - | DuplicateModuleName ModuleName + | DuplicateModule ModuleName [SourceSpan] | DuplicateTypeArgument String | InvalidDoBind | InvalidDoLet @@ -177,6 +176,10 @@ data Module = Module SourceSpan [Comment] ModuleName [Declaration] (Maybe [Decla getModuleName :: Module -> ModuleName getModuleName (Module _ _ name _ _) = name +-- | Return a module's source span. +getModuleSourceSpan :: Module -> SourceSpan +getModuleSourceSpan (Module ss _ _ _ _) = ss + -- | -- Add an import declaration for a module if it does not already explicitly import it. -- diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6d0d71e781..e6266d2883 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -90,7 +90,6 @@ errorCode em = case unwrapErrorMessage em of MultipleValueOpFixities{} -> "MultipleValueOpFixities" MultipleTypeOpFixities{} -> "MultipleTypeOpFixities" OrphanTypeDeclaration{} -> "OrphanTypeDeclaration" - RedefinedModule{} -> "RedefinedModule" RedefinedIdent{} -> "RedefinedIdent" OverlappingNamesInLet -> "OverlappingNamesInLet" UnknownName{} -> "UnknownName" @@ -102,7 +101,7 @@ errorCode em = case unwrapErrorMessage em of ScopeShadowing{} -> "ScopeShadowing" DeclConflict{} -> "DeclConflict" ExportConflict{} -> "ExportConflict" - DuplicateModuleName{} -> "DuplicateModuleName" + DuplicateModule{} -> "DuplicateModule" DuplicateTypeArgument{} -> "DuplicateTypeArgument" InvalidDoBind -> "InvalidDoBind" InvalidDoLet -> "InvalidDoLet" @@ -486,10 +485,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS line $ "There are multiple fixity/precedence declarations for type operator " ++ markCode (showOp op) renderSimpleErrorMessage (OrphanTypeDeclaration nm) = line $ "The type declaration for " ++ markCode (showIdent nm) ++ " should be followed by its definition." - renderSimpleErrorMessage (RedefinedModule name filenames) = - paras [ line ("The module " ++ markCode (runModuleName name) ++ " has been defined multiple times:") - , indent . paras $ map (line . displaySourceSpan) filenames - ] renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " ++ markCode (showIdent name) ++ " has been defined multiple times" renderSimpleErrorMessage (UnknownName name) = @@ -519,8 +514,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS line $ "Declaration for " ++ printName (Qualified Nothing new) ++ " conflicts with an existing " ++ nameType existing ++ " of the same name." renderSimpleErrorMessage (ExportConflict new existing) = line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing - renderSimpleErrorMessage (DuplicateModuleName mn) = - line $ "Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times." + renderSimpleErrorMessage (DuplicateModule mn ss) = + paras [ line ("Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times:") + , indent . paras $ map (line . displaySourceSpan) ss + ] renderSimpleErrorMessage (CycleInDeclaration nm) = line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 5e68831aa0..99d46721ad 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -40,8 +40,9 @@ import Data.Aeson (encode, decode) import qualified Data.Aeson as Aeson import Data.ByteString.Builder (toLazyByteString, stringUtf8) import Data.Either (partitionEithers) +import Data.Function (on) import Data.Foldable (for_) -import Data.List (foldl', sort) +import Data.List (foldl', sortBy, groupBy) import Data.Maybe (fromMaybe, catMaybes) import Data.String (fromString) import Data.Time.Clock @@ -191,18 +192,17 @@ make ma@MakeActions{..} ms = do where checkModuleNamesAreUnique :: m () checkModuleNamesAreUnique = - case findDuplicate (map getModuleName ms) of - Nothing -> return () - Just mn -> throwError . errorMessage $ DuplicateModuleName mn - - -- Verify that a list of values has unique keys - findDuplicate :: (Ord a) => [a] -> Maybe a - findDuplicate = go . sort - where - go (x : y : xs) - | x == y = Just x - | otherwise = go (y : xs) - go _ = Nothing + for_ (findDuplicates getModuleName ms) $ \mss -> + throwError . flip foldMap mss $ \ms' -> + let mn = getModuleName (head ms') + in errorMessage $ DuplicateModule mn (map getModuleSourceSpan ms') + + -- Find all groups of duplicate values in a list based on a projection. + findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [[a]] + findDuplicates f xs = + case filter ((> 1) . length) . groupBy ((==) `on` f) . sortBy (compare `on` f) $ xs of + [] -> Nothing + xss -> Just xss -- Sort a list so its elements appear in the same order as in another list. inOrderOf :: (Ord a) => [a] -> [a] -> [a] diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 1ccd2837b1..2d2a483ad2 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -99,15 +99,12 @@ desugarImportsWithEnv externs modules = do exportedRefs f = M.fromList $ (, efModuleName) <$> mapMaybe f efExports updateEnv :: ([Module], Env) -> Module -> m ([Module], Env) - updateEnv (ms, env) m@(Module ss _ mn _ refs) = - case mn `M.lookup` env of - Just m' -> throwError . errorMessage $ RedefinedModule mn [envModuleSourceSpan m', ss] - Nothing -> do - members <- findExportable m - let env' = M.insert mn (ss, primImports, members) env - (m', imps) <- resolveImports env' m - exps <- maybe (return members) (resolveExports env' ss mn imps members) refs - return (m' : ms, M.insert mn (ss, imps, exps) env) + updateEnv (ms, env) m@(Module ss _ mn _ refs) = do + members <- findExportable m + let env' = M.insert mn (ss, primImports, members) env + (m', imps) <- resolveImports env' m + exps <- maybe (return members) (resolveExports env' ss mn imps members) refs + return (m' : ms, M.insert mn (ss, imps, exps) env) renameInModule' :: Env -> Module -> m Module renameInModule' env m@(Module _ _ mn _ _) = From 3f901d0a24be0039bad798bac6c4acf647e299c0 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 24 Sep 2016 14:50:44 +0100 Subject: [PATCH 0504/1580] Fix usage detection for operators --- .../warning/UnusedExplicitImportTypeOp.purs | 9 +++++++ .../UnusedExplicitImportTypeOp/Lib.purs | 8 +++++++ .../warning/UnusedExplicitImportValOp.purs | 8 +++++++ purescript.cabal | 1 + src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/Linter/Imports.hs | 24 +++++++++---------- 7 files changed, 40 insertions(+), 14 deletions(-) create mode 100644 examples/warning/UnusedExplicitImportTypeOp.purs create mode 100644 examples/warning/UnusedExplicitImportTypeOp/Lib.purs create mode 100644 examples/warning/UnusedExplicitImportValOp.purs diff --git a/examples/warning/UnusedExplicitImportTypeOp.purs b/examples/warning/UnusedExplicitImportTypeOp.purs new file mode 100644 index 0000000000..41caf6b0a5 --- /dev/null +++ b/examples/warning/UnusedExplicitImportTypeOp.purs @@ -0,0 +1,9 @@ +-- @shouldWarnWith UnusedExplicitImport +module Main where + +import Prelude (Unit, unit, pure) +import Control.Monad.Eff (Eff) +import Lib (type (~>), natId) + +main :: Eff () Unit +main = natId (pure unit) diff --git a/examples/warning/UnusedExplicitImportTypeOp/Lib.purs b/examples/warning/UnusedExplicitImportTypeOp/Lib.purs new file mode 100644 index 0000000000..7a2d5239d3 --- /dev/null +++ b/examples/warning/UnusedExplicitImportTypeOp/Lib.purs @@ -0,0 +1,8 @@ +module Lib where + +type Nat f g = ∀ x. f x → g x + +infixr 4 type Nat as ~> + +natId ∷ ∀ f. f ~> f +natId x = x diff --git a/examples/warning/UnusedExplicitImportValOp.purs b/examples/warning/UnusedExplicitImportValOp.purs new file mode 100644 index 0000000000..26a792856d --- /dev/null +++ b/examples/warning/UnusedExplicitImportValOp.purs @@ -0,0 +1,8 @@ +-- @shouldWarnWith UnusedExplicitImport +module Main where + +import Prelude (Unit, unit, pure, (+)) +import Control.Monad.Eff (Eff) + +main :: Eff () Unit +main = pure unit diff --git a/purescript.cabal b/purescript.cabal index 4c07045448..6ebb778a7d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -76,6 +76,7 @@ extra-source-files: examples/passing/*.purs , examples/failing/OrphanInstance/*.purs , examples/warning/*.purs , examples/warning/*.js + , examples/warning/UnusedExplicitImportTypeOp/*.purs , examples/docs/bower_components/purescript-prelude/src/*.purs , examples/docs/bower.json , examples/docs/src/*.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index b6e638b227..fed422a196 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -107,7 +107,7 @@ data SimpleErrorMessage | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName) | ImportHidingModule ModuleName | UnusedImport ModuleName - | UnusedExplicitImport ModuleName [String] (Maybe ModuleName) [DeclarationRef] + | UnusedExplicitImport ModuleName [Name] (Maybe ModuleName) [DeclarationRef] | UnusedDctorImport ModuleName (ProperName 'TypeName) (Maybe ModuleName) [DeclarationRef] | UnusedDctorExplicitImport ModuleName (ProperName 'TypeName) [ProperName 'ConstructorName] (Maybe ModuleName) [DeclarationRef] | DuplicateSelectiveImport ModuleName diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6d0d71e781..14561b8c39 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -758,7 +758,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) = paras [ line $ "The import of module " ++ markCode (runModuleName mn) ++ " contains the following unused references:" - , indent $ paras $ map line names + , indent $ paras $ map (line . markCode . runName . Qualified Nothing) names , line "It could be replaced with:" , indent $ line $ markCode $ showSuggestion msg ] diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 6bec467f4e..fceea2a2c6 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -243,7 +243,7 @@ lintImportDecl env mni qualifierName names declType allowImplicit = didWarn' <- forM (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do let allCtors = dctorsForType mni tn -- If we've not already warned a type is unused, check its data constructors - unless' (runProperName tn `notElem` usedNames) $ + unless' (TyName tn `notElem` usedNames) $ case (c, dctors `intersect` allCtors) of (_, []) | c /= Just [] -> warn (UnusedDctorImport mni tn qualifierName allRefs) (Just ctors, dctors') -> @@ -335,18 +335,18 @@ findUsedRefs env mni qn names = matchName :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName)) -> Name - -> Maybe String -matchName _ (IdentName x) = Just $ showIdent x -matchName _ (TyName x) = Just $ runProperName x -matchName _ (TyClassName x) = Just $ runProperName x -matchName lookupDc (DctorName x) = runProperName <$> lookupDc x -matchName _ _ = Nothing - -runDeclRef :: DeclarationRef -> Maybe String + -> Maybe Name +matchName lookupDc (DctorName x) = TyName <$> lookupDc x +matchName _ ModName{} = Nothing +matchName _ name = Just name + +runDeclRef :: DeclarationRef -> Maybe Name runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref -runDeclRef (ValueRef ident) = Just $ showIdent ident -runDeclRef (TypeRef pn _) = Just $ runProperName pn -runDeclRef (TypeClassRef pn) = Just $ runProperName pn +runDeclRef (ValueRef ident) = Just $ IdentName ident +runDeclRef (ValueOpRef op) = Just $ ValOpName op +runDeclRef (TypeRef pn _) = Just $ TyName pn +runDeclRef (TypeOpRef op) = Just $ TyOpName op +runDeclRef (TypeClassRef pn) = Just $ TyClassName pn runDeclRef _ = Nothing checkDuplicateImports From d22757f3eb4ec429bb2a11b20c4bf3c9df693ac0 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 24 Sep 2016 17:08:53 -0700 Subject: [PATCH 0505/1580] Add andreypopp --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 702549494c..fe5f27dc6f 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -5,6 +5,7 @@ This file lists the contributors to the PureScript compiler project, and the ter ### Individuals - [@5outh](https://github.com/5outh) (Benjamin Kovach) - My existing contributions and all future contributions until further notice are Copyright Benjamin Kovach, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. +- [@andreypopp](https://github.com/andreypopp) (Andrey Popp) My existing contributions and all future contributions until further notice are Copyright Andrey Popp, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@andyarvanitis](https://github.com/andyarvanitis) (Andy Arvanitis) My existing contributions and all future contributions until further notice are Copyright Andy Arvanitis, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@anthok88](https://github.com/anthoq88) - My existing contributions and all future contributions until further notice are Copyright anthoq88, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license - [@ardumont](https://github.com/ardumont) (Antoine R. Dumont) My existing contributions and all future contributions until further notice are Copyright Antoine R. Dumont, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). From ed39cb568b8c381f897bc43377ec6e85e2b364f5 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 28 Sep 2016 20:11:52 -0700 Subject: [PATCH 0506/1580] Fix #2332, allow newtype deriving when newtype is not fully applied --- examples/failing/NewtypeInstance5.purs | 8 ++++++ examples/failing/NewtypeInstance6.purs | 8 ++++++ examples/passing/NewtypeInstance.purs | 11 ++++++++ .../PureScript/Sugar/TypeClasses/Deriving.hs | 26 ++++++++++++++++--- 4 files changed, 50 insertions(+), 3 deletions(-) create mode 100644 examples/failing/NewtypeInstance5.purs create mode 100644 examples/failing/NewtypeInstance6.purs diff --git a/examples/failing/NewtypeInstance5.purs b/examples/failing/NewtypeInstance5.purs new file mode 100644 index 0000000000..5003ee8334 --- /dev/null +++ b/examples/failing/NewtypeInstance5.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidNewtypeInstance +module Main where + +import Prelude + +newtype X a = X a + +derive newtype instance functorX :: Functor X diff --git a/examples/failing/NewtypeInstance6.purs b/examples/failing/NewtypeInstance6.purs new file mode 100644 index 0000000000..fe7136661d --- /dev/null +++ b/examples/failing/NewtypeInstance6.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidNewtypeInstance +module Main where + +import Prelude + +newtype X a b = X (Array b) + +derive newtype instance functorX :: Functor X diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs index 416405a015..8a83399a32 100644 --- a/examples/passing/NewtypeInstance.purs +++ b/examples/passing/NewtypeInstance.purs @@ -24,7 +24,18 @@ instance singletonArray :: Singleton a (Array a) where derive newtype instance singletonY :: Singleton a (Y a) +newtype MyArray a = MyArray (Array a) + +derive newtype instance showMyArray :: Show a => Show (MyArray a) + +derive newtype instance functorMyArray :: Functor MyArray + +newtype ProxyArray x a = ProxyArray (Array a) + +derive newtype instance functorProxyArray :: Functor (ProxyArray x) + main = do logShow (X "test") logShow (singleton "test" :: Y String) + logShow (map show (MyArray [1, 2, 3])) log "Done" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 2dcceefe6c..5f1c4a9443 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} -- | -- This module implements the generic deriving elaboration that takes place during desugaring. @@ -93,12 +94,31 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do tyCon <- findTypeDecl tyConNm ds go tyCon where - go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])]) = do - let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs - return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped])) + go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])]) + -- The newtype might not be applied to all type arguments. + -- This is okay as long as the newtype wraps something which ends with + -- sufficiently many type applications to variables. + -- For example, we can derive Functor for + -- + -- newtype MyArray a = MyArray (Array a) + -- + -- since Array a is a type application which uses the last + -- type argument + | Just wrapped' <- stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped = + do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs + return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped'])) go (PositionedDeclaration _ _ d) = go d go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys + takeReverse :: Int -> [a] -> [a] + takeReverse n = take n . reverse + + stripRight :: [(String, Maybe kind)] -> Type -> Maybe Type + stripRight [] ty = Just ty + stripRight ((arg, _) : args) (TypeApp t (TypeVar arg')) + | arg == arg' = stripRight args t + stripRight _ _ = Nothing + dataGeneric :: ModuleName dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] From c59f99149503ffb17decb9671785befa113621f5 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 28 Sep 2016 20:28:06 -0700 Subject: [PATCH 0507/1580] Fix #2331, substutute types in newtype class deriving --- examples/passing/DeriveNewtype.purs | 10 +++ .../PureScript/Sugar/TypeClasses/Deriving.hs | 65 ++++++++++--------- 2 files changed, 43 insertions(+), 32 deletions(-) diff --git a/examples/passing/DeriveNewtype.purs b/examples/passing/DeriveNewtype.purs index 6b05c0ddb5..bdcdce4fe4 100644 --- a/examples/passing/DeriveNewtype.purs +++ b/examples/passing/DeriveNewtype.purs @@ -14,4 +14,14 @@ t = wrap "hello" a :: String a = unwrap t +newtype First a = First a + +derive instance newtypeFirst :: Newtype (First b) _ + +f :: First Int +f = wrap 1 + +i :: Int +i = unwrap f + main = log "Done" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 2dcceefe6c..a39db657bd 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -55,10 +55,10 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance) | className == Qualified (Just dataNewtype) (ProperName "Newtype") - , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor wrappedTy + , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy , mn == fromMaybe mn mn' = do - (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon unwrappedTy + (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) = throwError . errorMessage $ CannotDerive className tys @@ -427,40 +427,41 @@ deriveNewtype => ModuleName -> [Declaration] -> ProperName 'TypeName + -> [Type] -> Type -> m ([Declaration], Type) -deriveNewtype mn ds tyConNm unwrappedTy = do - checkIsWildcard unwrappedTy - go =<< findTypeDecl tyConNm ds +deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do + checkIsWildcard unwrappedTy + go =<< findTypeDecl tyConNm ds where + go :: Declaration -> m ([Declaration], Type) + go (DataDeclaration Data name _ _) = + throwError . errorMessage $ CannotDeriveNewtypeForData name + go (DataDeclaration Newtype name args dctors) = do + checkNewtype name dctors + wrappedIdent <- freshIdent "n" + unwrappedIdent <- freshIdent "a" + let (ctorName, [ty]) = head dctors + inst = + [ ValueDeclaration (Ident "wrap") Public [] $ Right $ + Constructor (Qualified (Just mn) ctorName) + , ValueDeclaration (Ident "unwrap") Public [] $ Right $ + lamCase wrappedIdent + [ CaseAlternative + [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]] + (Right (Var (Qualified Nothing unwrappedIdent))) + ] + ] + subst = zipWith ((,) . fst) args tyConArgs + return (inst, replaceAllTypeVars subst ty) + go (PositionedDeclaration _ _ d) = go d + go _ = internalError "deriveNewtype go: expected DataDeclaration" - go :: Declaration -> m ([Declaration], Type) - go (DataDeclaration Data name _ _) = - throwError . errorMessage $ CannotDeriveNewtypeForData name - go (DataDeclaration Newtype name _ dctors) = do - checkNewtype name dctors - let (ctorName, [ty]) = head dctors - wrappedIdent <- freshIdent "n" - unwrappedIdent <- freshIdent "a" - let inst = - [ ValueDeclaration (Ident "wrap") Public [] $ Right $ - Constructor (Qualified (Just mn) ctorName) - , ValueDeclaration (Ident "unwrap") Public [] $ Right $ - lamCase wrappedIdent - [ CaseAlternative - [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]] - (Right (Var (Qualified Nothing unwrappedIdent))) - ] - ] - return (inst, ty) - go (PositionedDeclaration _ _ d) = go d - go _ = internalError "deriveNewtype go: expected DataDeclaration" - - checkIsWildcard :: Type -> m () - checkIsWildcard (TypeWildcard _) = - return () - checkIsWildcard _ = - throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm + checkIsWildcard :: Type -> m () + checkIsWildcard (TypeWildcard _) = + return () + checkIsWildcard _ = + throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm findTypeDecl :: (MonadError MultipleErrors m) From 2cad87835dbf8c9dba2ad810b32a97579ec52af6 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Fri, 30 Sep 2016 00:45:41 +0200 Subject: [PATCH 0508/1580] Strict handling of UTF8 files (fixes fd issue) (#2338) * Strict handling of UTF8 files (fixes fd issue) * Update CONTRIBUTORS.md --- CONTRIBUTORS.md | 1 + src/System/IO/UTF8.hs | 19 ++++--------------- 2 files changed, 5 insertions(+), 15 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index fe5f27dc6f..5f0f220523 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -18,6 +18,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@cdepillabout](https://github.com/cdepillabout) (Dennis Gosnell) My existing contributions and all future contributions until further notice are Copyright Dennis Gosnell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@charleso](https://github.com/charleso) (Charles O'Farrell) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Charles O'Farrell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@chrisdone](https://github.com/chrisdone) (Chris Done) - My existing contributions and all future contributions until further notice are Copyright Chris Done, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@chrissmoak](https://github.com/chrissmoak) (Chris Smoak) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@davidchambers](https://github.com/davidchambers) (David Chambers) My existing contributions and all future contributions until further notice are Copyright David Chambers, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs index fe2788f4d7..a69dded993 100644 --- a/src/System/IO/UTF8.hs +++ b/src/System/IO/UTF8.hs @@ -2,24 +2,13 @@ module System.IO.UTF8 where import Prelude.Compat -import System.IO ( IOMode(..) - , hGetContents - , hSetEncoding - , hClose - , hPutStr - , openFile - , utf8 - ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.UTF8 as UTF8 readUTF8File :: FilePath -> IO String readUTF8File inFile = do - h <- openFile inFile ReadMode - hSetEncoding h utf8 - hGetContents h + fmap UTF8.toString (BS.readFile inFile) writeUTF8File :: FilePath -> String -> IO () writeUTF8File inFile text = do - h <- openFile inFile WriteMode - hSetEncoding h utf8 - hPutStr h text - hClose h + BS.writeFile inFile (UTF8.fromString text) From 02e53c98789c9adfc1adfe8179cc916dbfc90d34 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 2 Oct 2016 12:20:03 -0700 Subject: [PATCH 0509/1580] Use BSD 3-clause license --- LICENSE | 28 ++++++++++------------------ license-generator/header.txt | 26 +++++++++----------------- purescript.cabal | 6 +++--- 3 files changed, 22 insertions(+), 38 deletions(-) diff --git a/LICENSE b/LICENSE index d05ff61778..d392d3d51e 100644 --- a/LICENSE +++ b/LICENSE @@ -1,24 +1,16 @@ -The MIT License (MIT) - -Copyright (c) 2013-15 Phil Freeman, (c) 2014-2015 Gary Burgess, and other +Copyright (c) 2013-16 Phil Freeman, (c) 2014-2016 Gary Burgess, and other contributors +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. -Permission is hereby granted, free of charge, to any person obtaining a copy of -this software and associated documentation files (the "Software"), to deal in -the Software without restriction, including without limitation the rights to -use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of -the Software, and to permit persons to whom the Software is furnished to do so, -subject to the following conditions: +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. +3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS -FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR -COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. PureScript uses the following Haskell library packages. Their license files follow. @@ -2900,7 +2892,7 @@ pipes LICENSE file: pipes-http LICENSE file: - Copyright (c) 2014 Gabriel Gonzalez + Copyright (c) 2016 Gabriel Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without modification, diff --git a/license-generator/header.txt b/license-generator/header.txt index f7522af49f..50ba5681ec 100644 --- a/license-generator/header.txt +++ b/license-generator/header.txt @@ -1,23 +1,15 @@ -The MIT License (MIT) - -Copyright (c) 2013-15 Phil Freeman, (c) 2014-2015 Gary Burgess, and other +Copyright (c) 2013-16 Phil Freeman, (c) 2014-2016 Gary Burgess, and other contributors +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. -Permission is hereby granted, free of charge, to any person obtaining a copy of -this software and associated documentation files (the "Software"), to deal in -the Software without restriction, including without limitation the rights to -use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of -the Software, and to permit persons to whom the Software is furnished to do so, -subject to the following conditions: +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. +3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS -FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR -COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. PureScript uses the following Haskell library packages. Their license files follow. diff --git a/purescript.cabal b/purescript.cabal index 7c7d359bd8..e05582adab 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,10 +1,10 @@ name: purescript -version: 0.10.0 +version: 0.10.1 cabal-version: >=1.8 build-type: Simple -license: MIT +license: BSD3 license-file: LICENSE -copyright: (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess +copyright: (c) 2013-16 Phil Freeman, (c) 2014-16 Gary Burgess maintainer: Phil Freeman stability: experimental synopsis: PureScript Programming Language Compiler From 86e99f4bd2dfbccfa1b6ba8768c7a3ca6c0f7c9e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 2 Oct 2016 13:34:25 -0700 Subject: [PATCH 0510/1580] Use aeson 0.11.* for now, for Pursuit JSON compatibility --- purescript.cabal | 8 ++++---- stack.yaml | 10 +++++----- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 7c7d359bd8..0d5079c879 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -102,7 +102,7 @@ source-repository head library build-depends: base >=4.8 && <5, - aeson >= 0.8 && < 1.1, + aeson >= 0.8 && < 1.0, aeson-better-errors >= 0.8, ansi-terminal >= 0.6.2 && < 0.7, base-compat >=0.6.0, @@ -319,7 +319,7 @@ library executable psc build-depends: base >=4 && <5, purescript -any, - aeson >= 0.8 && < 1.1, + aeson >= 0.8 && < 1.0, ansi-terminal >= 0.6.2 && < 0.7, base-compat >=0.6.0, bytestring -any, @@ -397,7 +397,7 @@ executable psc-docs executable psc-publish build-depends: base >=4 && <5, purescript -any, - aeson -any, + aeson >= 0.8 && < 1.0, bytestring -any, optparse-applicative -any main-is: Main.hs @@ -444,7 +444,7 @@ executable psc-ide-server other-modules: Paths_purescript other-extensions: build-depends: base >=4 && <5, - aeson >= 0.8 && < 1.1, + aeson >= 0.8 && < 1.0, bytestring -any, purescript -any, base-compat >=0.6.0, diff --git a/stack.yaml b/stack.yaml index e86fae58e1..b0e1501fa9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,11 +2,11 @@ resolver: lts-6.13 packages: - '.' extra-deps: -- aeson-1.0.0.0 +# - aeson-1.0.0.0 - http-client-0.5.1 - http-client-tls-0.3.0 - pipes-http-1.0.4 -- semigroups-0.18.2 -flags: - semigroups: - bytestring-builder: false +# - semigroups-0.18.2 +# flags: +# semigroups: +# bytestring-builder: false From 2f54c857465b554da6886eafa63c7ea07dd7fa40 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 5 Oct 2016 21:05:15 -0700 Subject: [PATCH 0511/1580] Revert http-client-0.5 change --- purescript.cabal | 2 +- src/Language/PureScript/Ide/Pursuit.hs | 44 ++++++++++++++------------ stack.yaml | 11 +------ 3 files changed, 26 insertions(+), 31 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 18ce5484f8..55c4add728 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -119,7 +119,7 @@ library fsnotify >= 0.2.1, Glob >= 0.7 && < 0.8, haskeline >= 0.7.0.0, - http-client >= 0.4.30 && <0.6, + http-client >= 0.4.30 && <0.5, http-types -any, language-javascript == 0.6.*, lifted-base >= 0.2.3 && < 0.2.4, diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs index ae40238209..962f573af9 100644 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -35,37 +35,41 @@ import qualified Pipes.Prelude as P -- TODO: remove this when the issue is fixed at Pursuit queryPursuit :: Text -> IO ByteString queryPursuit q = do - let qClean = T.dropWhileEnd (== '.') q - req' <- parseRequest "http://pursuit.purescript.org/search" - let req = req' - { queryString= "q=" <> (fromString . T.unpack) qClean - , requestHeaders=[(hAccept, "application/json")] - } - m <- newManager tlsManagerSettings - withHTTP req m $ \resp -> - P.fold (<>) "" identity (responseBody resp) + let qClean = T.dropWhileEnd (== '.') q + req' <- parseRequest "http://pursuit.purescript.org/search" + let req = req' + { queryString= "q=" <> (fromString . T.unpack) qClean + , requestHeaders=[(hAccept, "application/json")] + } + m <- newManager tlsManagerSettings + withHTTP req m $ \resp -> + P.fold (<>) "" identity (responseBody resp) + handler :: HttpException -> IO [a] +handler StatusCodeException{} = pure [] handler _ = pure [] searchPursuitForDeclarations :: Text -> IO [PursuitResponse] -searchPursuitForDeclarations query = E.handle handler $ do - r <- queryPursuit query - let results' = decode (fromStrict r) :: Maybe Array - case results' of - Nothing -> pure [] - Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results)) +searchPursuitForDeclarations query = + (do r <- queryPursuit query + let results' = decode (fromStrict r) :: Maybe Array + case results' of + Nothing -> pure [] + Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))) `E.catch` + handler where isDeclarationResponse (Success a@DeclarationResponse{}) = Just a isDeclarationResponse _ = Nothing findPackagesForModuleIdent :: Text -> IO [PursuitResponse] -findPackagesForModuleIdent query = E.handle handler $ do - r <- queryPursuit query - let results' = decode (fromStrict r) :: Maybe Array - case results' of +findPackagesForModuleIdent query = + (do r <- queryPursuit query + let results' = decode (fromStrict r) :: Maybe Array + case results' of Nothing -> pure [] - Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results)) + Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))) `E.catch` + handler where isModuleResponse (Success a@ModuleResponse{}) = Just a isModuleResponse _ = Nothing diff --git a/stack.yaml b/stack.yaml index b0e1501fa9..f800d9dc3e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,12 +1,3 @@ -resolver: lts-6.13 +resolver: lts-6.10 packages: - '.' -extra-deps: -# - aeson-1.0.0.0 -- http-client-0.5.1 -- http-client-tls-0.3.0 -- pipes-http-1.0.4 -# - semigroups-0.18.2 -# flags: -# semigroups: -# bytestring-builder: false From 75239446ac1a0315ff91eb397087b6a681a381e5 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 7 Oct 2016 08:49:34 -0700 Subject: [PATCH 0512/1580] Refactor subsumes function (#2364) * Refactor subsumes function * Remove Haddocks --- .../PureScript/TypeChecker/Subsumption.hs | 168 ++++++++++++------ src/Language/PureScript/TypeChecker/Types.hs | 35 ++-- 2 files changed, 122 insertions(+), 81 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 0db376700d..2838da17d4 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -1,6 +1,8 @@ --- | --- Subsumption checking --- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Subsumption checking module Language.PureScript.TypeChecker.Subsumption ( subsumes ) where @@ -25,72 +27,120 @@ import Language.PureScript.TypeChecker.Skolems import Language.PureScript.TypeChecker.Unify import Language.PureScript.Types +-- | Subsumption can operate in two modes: +-- +-- * Elaboration mode, in which we try to insert type class dictionaries +-- * No-elaboration mode, in which we do not insert dictionaries +-- +-- Some subsumption rules apply in both modes, and others are specific to +-- certain modes. +-- +-- The subsumption algorithm follows the structure of the types in question, +-- and we can switch into no-elaboration mode when we move under a type +-- constructor where we can no longer insert dictionaries, e.g. into the fields +-- of a record. +data Mode = Elaborate | NoElaborate + +-- | Value-level proxies for the two modes +data ModeSing (mode :: Mode) where + SElaborate :: ModeSing 'Elaborate + SNoElaborate :: ModeSing 'NoElaborate + +-- | This type family tracks what evidence we return from 'subsumes' for each +-- mode. +type family Coercion (mode :: Mode) where + -- When elaborating, we generate a coercion + Coercion 'Elaborate = Expr -> Expr + -- When we're not elaborating, we don't generate coercions + Coercion 'NoElaborate = () + +-- | The default coercion for each mode. +defaultCoercion :: ModeSing mode -> Coercion mode +defaultCoercion SElaborate = id +defaultCoercion SNoElaborate = () + -- | Check that one type subsumes another, rethrowing errors to provide a better error message -subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr) -subsumes val ty1 ty2 = withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ subsumes' val ty1 ty2 +subsumes + :: (MonadError MultipleErrors m, MonadState CheckState m) + => Type + -> Type + -> m (Expr -> Expr) +subsumes ty1 ty2 = + withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ + subsumes' SElaborate ty1 ty2 -- | Check that one type subsumes another -subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) => - Maybe Expr -> - Type -> - Type -> - m (Maybe Expr) -subsumes' val (ForAll ident ty1 _) ty2 = do +subsumes' + :: (MonadError MultipleErrors m, MonadState CheckState m) + => ModeSing mode + -> Type + -> Type + -> m (Coercion mode) +subsumes' mode (ForAll ident ty1 _) ty2 = do replaced <- replaceVarWithUnknown ident ty1 - subsumes val replaced ty2 -subsumes' val ty1 (ForAll ident ty2 sco) = + subsumes' mode replaced ty2 +subsumes' mode ty1 (ForAll ident ty2 sco) = case sco of Just sco' -> do sko <- newSkolemConstant let sk = skolemize ident sko sco' Nothing ty2 - subsumes val ty1 sk + subsumes' mode ty1 sk Nothing -> internalError "subsumes: unspecified skolem scope" -subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do - _ <- subsumes Nothing arg2 arg1 - _ <- subsumes Nothing ret1 ret2 - return val -subsumes' val (KindedType ty1 _) ty2 = - subsumes val ty1 ty2 -subsumes' val ty1 (KindedType ty2 _) = - subsumes val ty1 ty2 -subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do +subsumes' mode (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do + subsumes' SNoElaborate arg2 arg1 + subsumes' SNoElaborate ret1 ret2 + -- Nothing was elaborated, return the default coercion + return (defaultCoercion mode) +subsumes' mode (KindedType ty1 _) ty2 = + subsumes' mode ty1 ty2 +subsumes' mode ty1 (KindedType ty2 _) = + subsumes' mode ty1 ty2 +-- Only check subsumption for constrained types when elaborating. +-- Otherwise fall back to unification. +subsumes' SElaborate (ConstrainedType constraints ty1) ty2 = do dicts <- getTypeClassDictionaries hints <- gets checkHints - subsumes' (Just $ foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty1 ty2 -subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do - let - (ts1, r1') = rowToList r1 - (ts2, r2') = rowToList r2 - ts1' = sortBy (comparing fst) ts1 - ts2' = sortBy (comparing fst) ts2 - -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row), - -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property. - -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has - -- an additional property which is not allowed. - when (r1' == REmpty) - (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst)) - when (r2' == REmpty) - (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst)) - go ts1' ts2' r1' r2' - return val + elaborate <- subsumes' SElaborate ty1 ty2 + let addDicts val = foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints) + return (elaborate . addDicts) +subsumes' mode (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do + let + (ts1, r1') = rowToList r1 + (ts2, r2') = rowToList r2 + ts1' = sortBy (comparing fst) ts1 + ts2' = sortBy (comparing fst) ts2 + -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row), + -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property. + -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has + -- an additional property which is not allowed. + when (r1' == REmpty) + (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst)) + when (r2' == REmpty) + (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst)) + go ts1' ts2' r1' r2' + -- Nothing was elaborated, return the default coercion + return (defaultCoercion mode) where - go [] ts2 r1' r2' = unifyTypes r1' (rowFromList (ts2, r2')) - go ts1 [] r1' r2' = unifyTypes r2' (rowFromList (ts1, r1')) - go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2' - | p1 == p2 = do _ <- subsumes Nothing ty1 ty2 - go ts1 ts2 r1' r2' - | p1 < p2 = do rest <- freshType - -- What happens next is a bit of a hack. - -- TODO: in the new type checker, object properties will probably be restricted to being monotypes - -- in which case, this branch of the subsumes function should not even be necessary. - unifyTypes r2' (RCons p1 ty1 rest) - go ts1 ((p2, ty2) : ts2) r1' rest - | otherwise = do rest <- freshType - unifyTypes r1' (RCons p2 ty2 rest) - go ((p1, ty1) : ts1) ts2 rest r2' - -- Find the first property that's in the first list (of tuples) but not in the second - firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing fst) t1 t2) -subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyRecord = subsumes val ty2 ty1 -subsumes' val ty1 ty2 = do + go [] ts2 r1' r2' = unifyTypes r1' (rowFromList (ts2, r2')) + go ts1 [] r1' r2' = unifyTypes r2' (rowFromList (ts1, r1')) + go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2' + | p1 == p2 = do subsumes' SNoElaborate ty1 ty2 + go ts1 ts2 r1' r2' + | p1 < p2 = do rest <- freshType + -- What happens next is a bit of a hack. + -- TODO: in the new type checker, object properties will probably be restricted to being monotypes + -- in which case, this branch of the subsumes function should not even be necessary. + unifyTypes r2' (RCons p1 ty1 rest) + go ts1 ((p2, ty2) : ts2) r1' rest + | otherwise = do rest <- freshType + unifyTypes r1' (RCons p2 ty2 rest) + go ((p1, ty1) : ts1) ts2 rest r2' + + -- Find the first property that's in the first list (of tuples) but not in the second + firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing fst) t1 t2) +subsumes' mode ty1 ty2@(TypeApp obj _) | obj == tyRecord = + subsumes' mode ty2 ty1 +subsumes' mode ty1 ty2 = do unifyTypes ty1 ty2 - return val + -- Nothing was elaborated, return the default coercion + return (defaultCoercion mode) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 3135148396..7cf80aaf93 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -568,18 +568,14 @@ check' (Abs (Right _) _) _ = internalError "Binder was not desugared" check' (App f arg) ret = do f'@(TypedValue _ _ ft) <- infer f (retTy, app) <- checkFunctionApplication f' ft arg - v' <- subsumes (Just app) retTy ret - case v' of - Nothing -> internalError "check: unable to check the subsumes relation." - Just app' -> return $ TypedValue True app' ret + elaborate <- subsumes retTy ret + return $ TypedValue True (elaborate app) ret check' v@(Var var) ty = do checkVisibility var repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty - v' <- subsumes (Just v) repl ty' - case v' of - Nothing -> internalError "check: unable to check the subsumes relation." - Just v'' -> return $ TypedValue True v'' ty' + elaborate <- subsumes repl ty' + return $ TypedValue True (elaborate v) ty' check' (DeferredDictionary className tys) _ = do {- -- Here, we replace a placeholder for a superclass dictionary with a regular @@ -596,12 +592,11 @@ check' (TypedValue checkType val ty1) ty2 = do checkTypeKind ty1 kind ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2 - val' <- subsumes (Just val) ty1' ty2' - case val' of - Nothing -> internalError "check: unable to check the subsumes relation." - Just _ -> do - val''' <- if checkType then withScopedTypeVars moduleName args (check val ty2') else return val - return $ TypedValue checkType val''' ty2' + _ <- subsumes ty1' ty2' + val' <- if checkType + then withScopedTypeVars moduleName args (check val ty2') + else return val + return $ TypedValue checkType val' ty2' check' (Case vals binders) ret = do (vals', ts) <- instantiateForBinders vals binders binders' <- checkBinders ts ret binders @@ -638,10 +633,8 @@ check' v@(Constructor c) ty = do Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c Just (_, _, ty1, _) -> do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 - mv <- subsumes (Just v) repl ty - case mv of - Nothing -> internalError "check: unable to check the subsumes relation." - Just v' -> return $ TypedValue True v' ty + elaborate <- subsumes repl ty + return $ TypedValue True (elaborate v) ty check' (Let ds val) ty = do (ds', val') <- inferLetBinding [] ds val (`check` ty) return $ TypedValue True (Let ds' val') ty @@ -654,10 +647,8 @@ check' (PositionedValue pos c val) ty = warnAndRethrowWithPositionTC pos $ do return $ TypedValue t (PositionedValue pos c v) ty' check' val ty = do TypedValue _ val' ty' <- infer val - mt <- subsumes (Just val') ty' ty - case mt of - Nothing -> internalError "check: unable to check the subsumes relation." - Just v' -> return $ TypedValue True v' ty + elaborate <- subsumes ty' ty + return $ TypedValue True (elaborate val') ty -- | -- Check the type of a collection of named record fields From 81a578f5484f0770ca0628c52176eb1ff0db93ee Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 8 Oct 2016 12:39:40 -0700 Subject: [PATCH 0513/1580] Fix #2370, allow rows in instance contexts --- examples/passing/RowsInInstanceContext.purs | 25 +++++++++++++++++++++ src/Language/PureScript/TypeChecker.hs | 3 +-- 2 files changed, 26 insertions(+), 2 deletions(-) create mode 100644 examples/passing/RowsInInstanceContext.purs diff --git a/examples/passing/RowsInInstanceContext.purs b/examples/passing/RowsInInstanceContext.purs new file mode 100644 index 0000000000..708d9d4a15 --- /dev/null +++ b/examples/passing/RowsInInstanceContext.purs @@ -0,0 +1,25 @@ +module Main where + +import Prelude +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) +import Data.Newtype (class Newtype, unwrap) + +class TypeEquals a b | a -> b, b -> a where + coerce :: a -> b + coerceBack :: b -> a + +instance refl :: TypeEquals a a where + coerce = id + coerceBack = id + +newtype RecordNewtype = RecordNewtype { x :: String } + +instance newtypeRecordNewtype :: + TypeEquals inner { x :: String } + => Newtype RecordNewtype inner where + wrap = RecordNewtype <<< coerce + unwrap (RecordNewtype rec) = coerceBack rec + +main :: Eff (console :: CONSOLE) Unit +main = log (unwrap (RecordNewtype { x: "Done" })).x diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 62e45595eb..1fb2cc6294 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -11,7 +11,7 @@ module Language.PureScript.TypeChecker import Prelude.Compat -import Control.Monad (when, unless, void, forM, forM_) +import Control.Monad (when, unless, void, forM) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), modify) import Control.Monad.Supply.Class (MonadSupply) @@ -279,7 +279,6 @@ typeCheckAll moduleName _ = traverse go return d go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do traverse_ (checkTypeClassInstance moduleName) tys - forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . constraintArgs checkOrphanInstance dictName className tys _ <- traverseTypeInstanceBody checkInstanceMembers body let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) From 12ec934dd6390d564886b8774e06bd5f937f2aba Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 9 Oct 2016 12:40:13 -0700 Subject: [PATCH 0514/1580] Fix #2362, treat type annotations on top-level expressions as if they were type declarations (#2366) --- src/Language/PureScript/TypeChecker/Entailment.hs | 1 - src/Language/PureScript/TypeChecker/Types.hs | 6 ++++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 7b03c70286..51eebd1844 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -233,7 +233,6 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin canBeGeneralized :: Type -> Bool canBeGeneralized TUnknown{} = True - canBeGeneralized Skolem{} = True canBeGeneralized _ = False -- | diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 7cf80aaf93..142834762e 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -27,12 +27,14 @@ module Language.PureScript.TypeChecker.Types import Prelude.Compat +import Control.Arrow (second) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Bifunctor (bimap) import Data.Either (lefts, rights) import Data.List (transpose, nub, (\\), partition, delete) import Data.Maybe (fromMaybe) @@ -199,6 +201,10 @@ typeForBindingGroupElement (ident, val) dict untypedDict = do -- | Check if a value contains a type annotation isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool)) isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType)) +isTyped (name, PositionedValue pos c value) = + bimap (second (PositionedValue pos c)) + (second (\(e, t, b) -> (PositionedValue pos c e, t, b))) + (isTyped (name, value)) isTyped (name, value) = Left (name, value) -- | From 65aee8f348130677180bc108f50f1160929624dd Mon Sep 17 00:00:00 2001 From: Brandon Hamilton Date: Sun, 9 Oct 2016 23:38:09 +0200 Subject: [PATCH 0515/1580] Move unsafeIndex to Data.Array --- src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs | 2 +- src/Language/PureScript/Constants.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index 7f953e9548..2dc42b842c 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -169,7 +169,7 @@ inlineCommonOperators = applyAll $ , inlineNonClassFunction (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x] , inlineNonClassFunction (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x] - , inlineNonClassFunction (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing) + , inlineNonClassFunction (C.dataArray, C.unsafeIndex) $ flip (JSIndexer Nothing) ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] where diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 021d3e0240..f254af5dbb 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -346,8 +346,8 @@ prim = "Prim" prelude :: String prelude = "Prelude" -dataArrayUnsafe :: String -dataArrayUnsafe = "Data_Array_Unsafe" +dataArray :: String +dataArray = "Data_Array" eff :: String eff = "Control_Monad_Eff" From 2acd6d89b2489e2146f5331466c934c01f0a76a6 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 18 Sep 2016 12:52:26 +0200 Subject: [PATCH 0516/1580] [psc-ide] Adds lenses and prisms for psc-ide's core data types --- purescript.cabal | 1 + src/Language/PureScript/Ide/CaseSplit.hs | 12 +-- src/Language/PureScript/Ide/Command.hs | 3 +- src/Language/PureScript/Ide/Conversions.hs | 12 ++- src/Language/PureScript/Ide/Error.hs | 6 +- src/Language/PureScript/Ide/Externs.hs | 57 ++++++------ src/Language/PureScript/Ide/Filter.hs | 7 +- src/Language/PureScript/Ide/Imports.hs | 36 ++++--- src/Language/PureScript/Ide/Matcher.hs | 2 +- src/Language/PureScript/Ide/Pursuit.hs | 2 +- src/Language/PureScript/Ide/Rebuild.hs | 2 +- src/Language/PureScript/Ide/Reexports.hs | 29 +++--- src/Language/PureScript/Ide/SourceFile.hs | 10 +- src/Language/PureScript/Ide/State.hs | 82 ++++++++-------- src/Language/PureScript/Ide/Types.hs | 93 ++++++++++++++----- src/Language/PureScript/Ide/Util.hs | 50 +++++----- tests/Language/PureScript/Ide/FilterSpec.hs | 2 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 6 +- tests/Language/PureScript/Ide/MatcherSpec.hs | 2 +- .../Language/PureScript/Ide/ReexportsSpec.hs | 10 +- tests/Language/PureScript/Ide/StateSpec.hs | 12 +-- 21 files changed, 246 insertions(+), 190 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 55c4add728..11cc2b922c 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -122,6 +122,7 @@ library http-client >= 0.4.30 && <0.5, http-types -any, language-javascript == 0.6.*, + lens == 4.*, lifted-base >= 0.2.3 && < 0.2.4, monad-control >= 1.0.0.0 && < 1.1, monad-logger >= 0.3 && < 0.4, diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 54f5137353..00940e47f3 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -12,7 +12,7 @@ -- Casesplitting and adding function clauses ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.CaseSplit ( WildcardAnnotations() @@ -23,10 +23,10 @@ module Language.PureScript.Ide.CaseSplit , caseSplit ) where -import Protolude hiding (Constructor) +import Protolude hiding (Constructor) -import qualified Data.Text as T -import qualified Language.PureScript as P +import qualified Data.Text as T +import qualified Language.PureScript as P import Language.PureScript.Externs import Language.PureScript.Ide.Error @@ -34,8 +34,8 @@ import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import Text.Parsec as Parsec -import qualified Text.PrettyPrint.Boxes as Box +import Text.Parsec as Parsec +import qualified Text.PrettyPrint.Boxes as Box type Constructor = (P.ProperName 'P.ConstructorName, [P.Type]) diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 966afd2576..6540db92ca 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -12,7 +12,8 @@ -- Datatypes for the commands psc-ide accepts ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} + module Language.PureScript.Ide.Command where diff --git a/src/Language/PureScript/Ide/Conversions.hs b/src/Language/PureScript/Ide/Conversions.hs index d0a46ebbfb..bb5ec88987 100644 --- a/src/Language/PureScript/Ide/Conversions.hs +++ b/src/Language/PureScript/Ide/Conversions.hs @@ -14,16 +14,23 @@ module Language.PureScript.Ide.Conversions where -import Protolude -import Data.Text (unwords, lines, strip) +import Control.Lens.Iso +import Data.Text (lines, strip, unwords) import qualified Language.PureScript as P +import Protolude runProperNameT :: P.ProperName a -> Text runProperNameT = toS . P.runProperName +properNameT :: Iso' (P.ProperName a) Text +properNameT = iso (toS . P.runProperName) (P.ProperName . toS) + runIdentT :: P.Ident -> Text runIdentT = toS . P.runIdent +identT :: Iso' P.Ident Text +identT = iso (toS . P.runIdent) (P.Ident . toS) + runOpNameT :: P.OpName a -> Text runOpNameT = toS . P.runOpName @@ -32,4 +39,3 @@ runModuleNameT = toS . P.runModuleName prettyTypeT :: P.Type -> Text prettyTypeT = unwords . map strip . lines . toS . P.prettyPrintType - diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 19c112ab92..5b56717b02 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -17,11 +17,11 @@ module Language.PureScript.Ide.Error ( PscIdeError(..) ) where -import Protolude import Data.Aeson import Language.PureScript.Errors.JSON -import Language.PureScript.Ide.Types (ModuleIdent) -import qualified Text.Parsec.Error as P +import Language.PureScript.Ide.Types (ModuleIdent) +import Protolude +import qualified Text.Parsec.Error as P data PscIdeError = GeneralError Text diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 4e00d8c0a9..1e92bd9f43 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -14,7 +14,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} module Language.PureScript.Ide.Externs ( readExternFile @@ -24,10 +23,11 @@ module Language.PureScript.Ide.Externs import Protolude +import Control.Lens ((^.)) import Data.Aeson (decodeStrict) +import qualified Data.ByteString as BS import Data.List (nub) import qualified Data.Map as Map -import qualified Data.ByteString as BS import Language.PureScript.Ide.Error (PscIdeError (..)) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util @@ -58,14 +58,14 @@ convertExterns ef = cleanDeclarations = nub $ appEndo typeClassFilter declarations removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration] -removeTypeDeclarationsForClass (IdeTypeClass n) = Endo (filter notDuplicate) - where notDuplicate (IdeType n' _) = runProperNameT n /= runProperNameT n' - notDuplicate (IdeTypeSynonym n' _) = runProperNameT n /= runProperNameT n' +removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate) + where notDuplicate (IdeDeclType t) = n ^. properNameT /= t ^. ideTypeName . properNameT + notDuplicate (IdeDeclTypeSynonym s) = n ^. properNameT /= s ^. ideSynonymName . properNameT notDuplicate _ = True removeTypeDeclarationsForClass _ = mempty isTypeClassDeclaration :: IdeDeclaration -> Bool -isTypeClassDeclaration IdeTypeClass{} = True +isTypeClassDeclaration IdeDeclTypeClass{} = True isTypeClassDeclaration _ = False convertExport :: P.DeclarationRef -> Maybe (P.ModuleName, P.DeclarationRef) @@ -73,19 +73,20 @@ convertExport (P.ReExportRef m r) = Just (m, r) convertExport _ = Nothing convertDecl :: P.ExternsDeclaration -> Maybe IdeDeclaration -convertDecl P.EDType{..} = Just (IdeType edTypeName edTypeKind) -convertDecl P.EDTypeSynonym{..} = - Just (IdeTypeSynonym edTypeSynonymName edTypeSynonymType) -convertDecl P.EDDataConstructor{..} = Just $ +convertDecl P.EDType{..} = Just $ IdeDeclType $ + IdeType edTypeName edTypeKind +convertDecl P.EDTypeSynonym{..} = Just $ IdeDeclTypeSynonym + (IdeSynonym edTypeSynonymName edTypeSynonymType) +convertDecl P.EDDataConstructor{..} = Just $ IdeDeclDataConstructor $ IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType -convertDecl P.EDValue{..} = Just $ +convertDecl P.EDValue{..} = Just $ IdeDeclValue $ IdeValue edValueName edValueType -convertDecl P.EDClass{..} = Just (IdeTypeClass edClassName) +convertDecl P.EDClass{..} = Just (IdeDeclTypeClass edClassName) convertDecl P.EDInstance{} = Nothing convertOperator :: P.ExternsFixity -> IdeDeclaration convertOperator P.ExternsFixity{..} = - IdeValueOperator + IdeDeclValueOperator $ IdeValueOperator efOperator efAlias efPrecedence @@ -94,7 +95,7 @@ convertOperator P.ExternsFixity{..} = convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration convertTypeOperator P.ExternsTypeFixity{..} = - IdeTypeOperator + IdeDeclTypeOperator $ IdeTypeOperator efTypeOperator efTypeAlias efTypePrecedence @@ -110,20 +111,20 @@ annotateModule (defs, types) (moduleName, decls) = where convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn convertDeclaration (IdeDeclarationAnn ann d) = case d of - IdeValue i t -> - annotateFunction i (IdeValue i t) - IdeType i k -> - annotateType (runProperNameT i) (IdeType i k) - IdeTypeSynonym i t -> - annotateType (runProperNameT i) (IdeTypeSynonym i t) - IdeDataConstructor i tn t -> - annotateValue (runProperNameT i) (IdeDataConstructor i tn t) - IdeTypeClass i -> - annotateType (runProperNameT i) (IdeTypeClass i) - IdeValueOperator n i p a t -> - annotateValue (valueOperatorAliasT i) (IdeValueOperator n i p a t) - IdeTypeOperator n i p a k -> - annotateType (typeOperatorAliasT i) (IdeTypeOperator n i p a k) + IdeDeclValue v -> + annotateFunction (v ^. ideValueIdent) (IdeDeclValue v) + IdeDeclType t -> + annotateType (t ^. ideTypeName . properNameT) (IdeDeclType t) + IdeDeclTypeSynonym s -> + annotateType (s ^. ideSynonymName . properNameT) (IdeDeclTypeSynonym s) + IdeDeclDataConstructor dtor -> + annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor) + IdeDeclTypeClass i -> + annotateType (runProperNameT i) (IdeDeclTypeClass i) + IdeDeclValueOperator op -> + annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op) + IdeDeclTypeOperator op -> + annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op) where annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs , annTypeAnnotation = Map.lookup x types diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index e0b79a4cf0..6c52549601 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -23,13 +23,13 @@ module Language.PureScript.Ide.Filter , applyFilters ) where -import Protolude hiding (isPrefixOf) +import Protolude hiding (isPrefixOf) import Data.Aeson import Data.Text (isPrefixOf) +import qualified Language.PureScript as P import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import qualified Language.PureScript as P newtype Filter = Filter (Endo [Module]) deriving(Monoid) @@ -65,8 +65,7 @@ identFilter predicate search = where filterModuleDecls :: Module -> Module filterModuleDecls (moduleIdent, decls) = - (moduleIdent, filter (flip predicate search . getDeclaration) decls) - getDeclaration (IdeDeclarationAnn _ d) = d + (moduleIdent, filter (flip predicate search . discardAnn) decls) runFilter :: Filter -> [Module] -> [Module] runFilter (Filter f) = appEndo f diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index e9065e988c..dae6a2649d 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -30,8 +30,10 @@ module Language.PureScript.Ide.Imports where import Protolude + +import Control.Lens ((^.)) +import Data.List (findIndex, nubBy) import qualified Data.Text as T -import Data.List (nubBy, findIndex) import qualified Data.Text.IO as TIO import qualified Language.PureScript as P import Language.PureScript.Ide.Completion @@ -197,16 +199,16 @@ addExplicitImport' decl moduleName imports = then imports else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports where - refFromDeclaration (IdeTypeClass n) = + refFromDeclaration (IdeDeclTypeClass n) = P.TypeClassRef n - refFromDeclaration (IdeDataConstructor n tn _) = - P.TypeRef tn (Just [n]) - refFromDeclaration (IdeType n _) = - P.TypeRef n (Just []) - refFromDeclaration (IdeValueOperator op _ _ _ _) = - P.ValueOpRef op - refFromDeclaration (IdeTypeOperator op _ _ _ _) = - P.TypeOpRef op + refFromDeclaration (IdeDeclDataConstructor dtor) = + P.TypeRef (dtor ^. ideDtorTypeName) (Just [dtor ^. ideDtorName]) + refFromDeclaration (IdeDeclType t) = + P.TypeRef (t ^. ideTypeName) (Just []) + refFromDeclaration (IdeDeclValueOperator op) = + P.ValueOpRef (op ^. ideValueOpName) + refFromDeclaration (IdeDeclTypeOperator op) = + P.TypeOpRef (op ^. ideTypeOpName) refFromDeclaration d = P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d) @@ -218,8 +220,12 @@ addExplicitImport' decl moduleName imports = insertDeclIntoImport _ is = is insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef] - insertDeclIntoRefs (IdeDataConstructor dtor tn _) refs = - updateAtFirstOrPrepend (matchType tn) (insertDtor dtor) (P.TypeRef tn (Just [dtor])) refs + insertDeclIntoRefs d@(IdeDeclDataConstructor dtor) refs = + updateAtFirstOrPrepend + (matchType (dtor ^. ideDtorTypeName)) + (insertDtor (dtor ^. ideDtorName)) + (refFromDeclaration d) + refs insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) insertDtor dtor (P.TypeRef tn' dtors) = @@ -294,9 +300,9 @@ addImportForIdentifier fp ident filters = do xs -> pure $ Left xs where - decideRedundantCase dtor@(IdeDataConstructor _ t _) (IdeType t' _) = - if t == t' then Just dtor else Nothing - decideRedundantCase IdeType{} ts@IdeTypeSynonym{} = + decideRedundantCase d@(IdeDeclDataConstructor dtor) (IdeDeclType t) = + if dtor ^. ideDtorTypeName == t ^. ideTypeName then Just d else Nothing + decideRedundantCase IdeDeclType{} ts@IdeDeclTypeSynonym{} = Just ts decideRedundantCase _ _ = Nothing diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index 254ac55d4b..7a495d2c0e 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -12,9 +12,9 @@ -- Matchers for psc-ide commands ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} module Language.PureScript.Ide.Matcher ( Matcher diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs index 962f573af9..90957fa2f2 100644 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -12,7 +12,7 @@ -- Pursuit client for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Pursuit ( searchPursuitForDeclarations diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index f9b9d18e6c..98422062c1 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -11,7 +11,7 @@ module Language.PureScript.Ide.Rebuild import Protolude import "monad-logger" Control.Monad.Logger -import qualified Data.List as List +import qualified Data.List as List import qualified Data.Map.Lazy as M import Data.Maybe (fromJust) import qualified Data.Set as S diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index dd569944fb..f0ac391517 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -25,16 +25,18 @@ module Language.PureScript.Ide.Reexports import Protolude +import Control.Lens hiding ((&)) + import qualified Data.Map as Map +import qualified Language.PureScript as P import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import qualified Language.PureScript as P -- | Contains the module with resolved reexports, and eventual failures data ReexportResult a = ReexportResult { reResolved :: a - , reFailed :: [(P.ModuleName, P.DeclarationRef)] + , reFailed :: [(P.ModuleName, P.DeclarationRef)] } deriving (Show, Eq, Functor) -- | Uses the passed formatter to format the resolved module, and adds eventual @@ -79,7 +81,7 @@ resolveRef -> Either P.DeclarationRef [IdeDeclarationAnn] resolveRef decls ref = case ref of P.TypeRef tn mdtors -> - case findRef (\case IdeType name _ -> name == tn; _ -> False) of + case findRef (\x -> x ^? _IdeDeclType . ideTypeName <&> (== tn) & fromMaybe False) of Nothing -> Left ref Just d -> Right $ d : case mdtors of Nothing -> @@ -89,28 +91,23 @@ resolveRef decls ref = case ref of findDtors tn Just dtors -> mapMaybe lookupDtor dtors P.ValueRef i -> - findWrapped (\case IdeValue i' _ -> i' == i; _ -> False) - P.TypeOpRef name -> - findWrapped (\case IdeTypeOperator n _ _ _ _ -> n == name; _ -> False) + findWrapped (\x -> x ^? _IdeDeclValue . ideValueIdent <&> (== i) & fromMaybe False) P.ValueOpRef name -> - findWrapped (\case IdeValueOperator n _ _ _ _ -> n == name; _ -> False) + findWrapped (\x -> x ^? _IdeDeclValueOperator . ideValueOpName <&> (== name) & fromMaybe False) + P.TypeOpRef name -> + findWrapped (\x -> x ^? _IdeDeclTypeOperator . ideTypeOpName <&> (== name) & fromMaybe False) P.TypeClassRef name -> - findWrapped (\case IdeTypeClass n -> n == name; _ -> False) + findWrapped (\case IdeDeclTypeClass n -> n == name; _ -> False) _ -> Left ref where - findWrapped = wrapSingle . findRef - wrapSingle = maybe (Left ref) (Right . pure) + findWrapped = maybe (Left ref) (Right . pure) . findRef findRef f = find (f . discardAnn) decls lookupDtor name = - findRef (\case IdeDataConstructor name' _ _ -> name == name' - _ -> False) + findRef (\x -> x ^? _IdeDeclDataConstructor . ideDtorName <&> (== name) & fromMaybe False) findDtors tn = filter (f . discardAnn) decls where f :: IdeDeclaration -> Bool - f decl - | (IdeDataConstructor _ tn' _) <- decl - , tn == tn' = True - | otherwise = False + f decl = decl ^? _IdeDeclDataConstructor . ideDtorTypeName <&> (== tn) & fromMaybe False diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 80bd30ec0c..7152b7015b 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -12,7 +12,7 @@ -- Getting declarations from PureScript sourcefiles ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.SourceFile ( parseModule @@ -25,12 +25,12 @@ module Language.PureScript.Ide.SourceFile import Protolude -import qualified Data.Map as Map -import qualified Language.PureScript as P +import qualified Data.Map as Map +import qualified Language.PureScript as P import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Util import Language.PureScript.Ide.Types -import System.IO.UTF8 (readUTF8File) +import Language.PureScript.Ide.Util +import System.IO.UTF8 (readUTF8File) parseModule :: (MonadIO m) diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index d20f045bbe..3a6ddfc3bf 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -32,20 +32,20 @@ module Language.PureScript.Ide.State , resolveOperatorsForModule ) where -import Protolude import qualified Prelude +import Protolude import Control.Concurrent.STM +import Control.Lens hiding (op, (&)) import "monad-logger" Control.Monad.Logger -import qualified Data.Map.Lazy as Map -import qualified Data.List as List +import qualified Data.Map.Lazy as Map +import qualified Language.PureScript as P import Language.PureScript.Externs import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import qualified Language.PureScript as P import System.Clock -- | Resets all State inside psc-ide @@ -235,47 +235,39 @@ resolveOperatorsForModule :: Map P.ModuleName [IdeDeclarationAnn] -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] -resolveOperatorsForModule modules = map (mapIdeDeclaration resolveOperator) +resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator) where - resolveOperator (IdeValueOperator - opName - i@(P.Qualified (Just moduleName) - (Left ident)) precedence assoc _) = - let t = do - sourceModule <- Map.lookup moduleName modules - IdeValue _ tP <- - List.find (\case - IdeValue iP _ -> iP == ident - _ -> False) (discardAnn <$> sourceModule) - pure tP - - in IdeValueOperator opName i precedence assoc t - resolveOperator (IdeValueOperator - opName - i@(P.Qualified (Just moduleName) - (Right ctor)) precedence assoc _) = - let t = do - sourceModule <- Map.lookup moduleName modules - IdeDataConstructor _ _ tP <- - List.find (\case - IdeDataConstructor cname _ _ -> ctor == cname - _ -> False) (discardAnn <$> sourceModule) - pure tP - - in IdeValueOperator opName i precedence assoc t - resolveOperator (IdeTypeOperator - opName - i@(P.Qualified (Just moduleName) properName) precedence assoc _) = - let k = do - sourceModule <- Map.lookup moduleName modules - IdeType _ kP <- - List.find (\case - IdeType name _ -> name == properName - _ -> False) (discardAnn <$> sourceModule) - pure kP - - in IdeTypeOperator opName i precedence assoc k + hasName :: Eq b => Lens' a b -> b -> a -> Bool + hasName l a x = x ^. l == a + + getDeclarations :: P.ModuleName -> [IdeDeclaration] + getDeclarations moduleName = + Map.lookup moduleName modules + & fromMaybe [] + & map discardAnn + + resolveOperator (IdeDeclValueOperator op) + | (P.Qualified (Just mn) (Left ident)) <- op ^. ideValueOpAlias = + let t = getDeclarations mn + & mapMaybe (preview _IdeDeclValue) + & filter (hasName ideValueIdent ident) + & map (view ideValueType) + & listToMaybe + in IdeDeclValueOperator (op & ideValueOpType .~ t) + | (P.Qualified (Just mn) (Right dtor)) <- op ^. ideValueOpAlias = + let t = getDeclarations mn + & mapMaybe (preview _IdeDeclDataConstructor) + & filter (hasName ideDtorName dtor) + & map (view ideDtorType) + & listToMaybe + in IdeDeclValueOperator (op & ideValueOpType .~ t) + resolveOperator (IdeDeclTypeOperator op) + | P.Qualified (Just mn) properName <- op ^. ideTypeOpAlias = + let k = getDeclarations mn + & mapMaybe (preview _IdeDeclType) + & filter (hasName ideTypeName properName) + & map (view ideTypeKind) + & listToMaybe + in IdeDeclTypeOperator (op & ideTypeOpKind .~ k) resolveOperator x = x -mapIdeDeclaration :: (IdeDeclaration -> IdeDeclaration) -> IdeDeclarationAnn -> IdeDeclarationAnn -mapIdeDeclaration f (IdeDeclarationAnn ann decl) = IdeDeclarationAnn ann (f decl) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 56b7550254..a9f98aa8a3 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -12,42 +12,93 @@ -- Type definitions for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Ide.Types where import Protolude import Control.Concurrent.STM +import Control.Lens.TH import Data.Aeson -import qualified Data.Map.Lazy as M -import qualified Language.PureScript.Errors.JSON as P -import qualified Language.PureScript as P +import qualified Data.Map.Lazy as M +import qualified Language.PureScript as P +import qualified Language.PureScript.Errors.JSON as P import Language.PureScript.Ide.Conversions type ModuleIdent = Text data IdeDeclaration - = IdeValue P.Ident P.Type - | IdeType (P.ProperName 'P.TypeName) P.Kind - | IdeTypeSynonym (P.ProperName 'P.TypeName) P.Type - | IdeDataConstructor (P.ProperName 'P.ConstructorName) (P.ProperName 'P.TypeName) P.Type - | IdeTypeClass (P.ProperName 'P.ClassName) - | IdeValueOperator (P.OpName 'P.ValueOpName) (P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName))) P.Precedence P.Associativity (Maybe P.Type) - | IdeTypeOperator (P.OpName 'P.TypeOpName) (P.Qualified (P.ProperName 'P.TypeName)) P.Precedence P.Associativity (Maybe P.Kind) + = IdeDeclValue IdeValue + | IdeDeclType IdeType + | IdeDeclTypeSynonym IdeSynonym + | IdeDeclDataConstructor IdeDataConstructor + | IdeDeclTypeClass (P.ProperName 'P.ClassName) + | IdeDeclValueOperator IdeValueOperator + | IdeDeclTypeOperator IdeTypeOperator deriving (Show, Eq, Ord) -data IdeDeclarationAnn = IdeDeclarationAnn Annotation IdeDeclaration - deriving (Show, Eq, Ord) +data IdeValue = IdeValue + { _ideValueIdent :: P.Ident + , _ideValueType :: P.Type + } deriving (Show, Eq, Ord) + +data IdeType = IdeType + { _ideTypeName :: P.ProperName 'P.TypeName + , _ideTypeKind :: P.Kind + } deriving (Show, Eq, Ord) + +data IdeSynonym = IdeSynonym + { _ideSynonymName :: P.ProperName 'P.TypeName + , _ideSynonymType :: P.Type + } deriving (Show, Eq, Ord) + +data IdeDataConstructor = IdeDataConstructor + { _ideDtorName :: P.ProperName 'P.ConstructorName + , _ideDtorTypeName :: P.ProperName 'P.TypeName + , _ideDtorType :: P.Type + } deriving (Show, Eq, Ord) + +data IdeValueOperator = IdeValueOperator + { _ideValueOpName :: P.OpName 'P.ValueOpName + , _ideValueOpAlias :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) + , _ideValueOpPrecedence :: P.Precedence + , _ideValueOpAssociativity :: P.Associativity + , _ideValueOpType :: Maybe P.Type + } deriving (Show, Eq, Ord) + +data IdeTypeOperator = IdeTypeOperator + { _ideTypeOpName :: P.OpName 'P.TypeOpName + , _ideTypeOpAlias :: P.Qualified (P.ProperName 'P.TypeName) + , _ideTypeOpPrecedence :: P.Precedence + , _ideTypeOpAssociativity :: P.Associativity + , _ideTypeOpKind :: Maybe P.Kind + } deriving (Show, Eq, Ord) + +makePrisms ''IdeDeclaration +makeLenses ''IdeValue +makeLenses ''IdeType +makeLenses ''IdeSynonym +makeLenses ''IdeDataConstructor +makeLenses ''IdeValueOperator +makeLenses ''IdeTypeOperator + +data IdeDeclarationAnn = IdeDeclarationAnn + { _idaAnnotation :: Annotation + , _idaDeclaration :: IdeDeclaration + } deriving (Show, Eq, Ord) data Annotation = Annotation - { annLocation :: Maybe P.SourceSpan - , annExportedFrom :: Maybe P.ModuleName + { annLocation :: Maybe P.SourceSpan + , annExportedFrom :: Maybe P.ModuleName , annTypeAnnotation :: Maybe P.Type } deriving (Show, Eq, Ord) +makeLenses ''IdeDeclarationAnn + emptyAnn :: Annotation emptyAnn = Annotation Nothing Nothing Nothing @@ -103,7 +154,7 @@ data Stage2 = Stage2 } data Stage3 = Stage3 - { s3Declarations :: M.Map P.ModuleName [IdeDeclarationAnn] + { s3Declarations :: M.Map P.ModuleName [IdeDeclarationAnn] , s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile) } @@ -112,11 +163,11 @@ newtype Match a = Match (P.ModuleName, a) -- | A completion as it gets sent to the editors data Completion = Completion - { complModule :: Text - , complIdentifier :: Text - , complType :: Text - , complExpandedType :: Text - , complLocation :: Maybe P.SourceSpan + { complModule :: Text + , complIdentifier :: Text + , complType :: Text + , complExpandedType :: Text + , complLocation :: Maybe P.SourceSpan , complDocumentation :: Maybe Text } deriving (Show, Eq) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index b0bcc30675..63d208ef8a 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -29,23 +29,25 @@ module Language.PureScript.Ide.Util , module Language.PureScript.Ide.Conversions ) where -import Protolude hiding (decodeUtf8, encodeUtf8) +import Control.Lens ((^.)) import Data.Aeson -import qualified Data.Text as T -import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) -import qualified Language.PureScript as P -import Language.PureScript.Ide.Types +import qualified Data.Text as T +import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) +import qualified Language.PureScript as P import Language.PureScript.Ide.Conversions +import Language.PureScript.Ide.Types +import Protolude hiding (decodeUtf8, + encodeUtf8) identifierFromIdeDeclaration :: IdeDeclaration -> Text identifierFromIdeDeclaration d = case d of - IdeValue name _ -> runIdentT name - IdeType name _ -> runProperNameT name - IdeTypeSynonym name _ -> runProperNameT name - IdeDataConstructor name _ _ -> runProperNameT name - IdeTypeClass name -> runProperNameT name - IdeValueOperator op _ _ _ _ -> runOpNameT op - IdeTypeOperator op _ _ _ _ -> runOpNameT op + IdeDeclValue v -> v ^. ideValueIdent . identT + IdeDeclType t -> t ^. ideTypeName . properNameT + IdeDeclTypeSynonym s -> s ^. ideSynonymName . properNameT + IdeDeclDataConstructor dtor -> dtor ^. ideDtorName . properNameT + IdeDeclTypeClass name -> runProperNameT name + IdeDeclValueOperator op -> op ^. ideValueOpName & runOpNameT + IdeDeclTypeOperator op -> op ^. ideTypeOpName & runOpNameT discardAnn :: IdeDeclarationAnn -> IdeDeclaration discardAnn (IdeDeclarationAnn _ d) = d @@ -61,24 +63,24 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) = Completion {..} where (complIdentifier, complExpandedType) = case decl of - IdeValue name type' -> (runIdentT name, prettyTypeT type') - IdeType name kind -> (runProperNameT name, toS (P.prettyPrintKind kind)) - IdeTypeSynonym name kind -> (runProperNameT name, prettyTypeT kind) - IdeDataConstructor name _ type' -> (runProperNameT name, prettyTypeT type') - IdeTypeClass name -> (runProperNameT name, "class") - IdeValueOperator op ref precedence associativity typeP -> - (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP) - IdeTypeOperator op ref precedence associativity kind -> + IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyTypeT) + IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind & toS ) + IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT) + IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT) + IdeDeclTypeClass name -> (runProperNameT name, "class") + IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) -> + (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP) + IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) -> (runOpNameT op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind) - + complModule = runModuleNameT m complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann) - + complLocation = annLocation ann complDocumentation = Nothing - + showFixity p a r o = let asso = case a of P.Infix -> "infix" @@ -95,7 +97,7 @@ typeOperatorAliasT :: P.Qualified (P.ProperName 'P.TypeName) -> Text typeOperatorAliasT i = toS (P.showQualified P.runProperName i) - + encodeT :: (ToJSON a) => a -> Text encodeT = toS . decodeUtf8 . encode diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index cc705f82e7..3b4cfc2d92 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -9,7 +9,7 @@ import qualified Language.PureScript as P import Test.Hspec value :: Text -> IdeDeclarationAnn -value s = IdeDeclarationAnn emptyAnn (IdeValue (P.Ident (toS s)) P.REmpty) +value s = IdeDeclarationAnn emptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.REmpty)) moduleA, moduleB :: Module moduleA = (P.moduleNameFromString "Module.A", [value "function1"]) diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 7cea546de9..e102fb7e0b 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -68,11 +68,11 @@ spec = do describe "import commands" $ do let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i addValueImport i mn is = - prettyPrintImportSection (addExplicitImport' (IdeValue (P.Ident i) wildcard) mn is) + prettyPrintImportSection (addExplicitImport' (IdeDeclValue (IdeValue (P.Ident i) wildcard)) mn is) addOpImport op mn is = - prettyPrintImportSection (addExplicitImport' (IdeValueOperator op (P.Qualified Nothing (Left (P.Ident ""))) 2 P.Infix Nothing) mn is) + prettyPrintImportSection (addExplicitImport' (IdeDeclValueOperator (IdeValueOperator op (P.Qualified Nothing (Left (P.Ident ""))) 2 P.Infix Nothing)) mn is) addDtorImport i t mn is = - prettyPrintImportSection (addExplicitImport' (IdeDataConstructor (P.ProperName i) t wildcard) mn is) + prettyPrintImportSection (addExplicitImport' (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName i) t wildcard)) mn is) it "adds an implicit unqualified import" $ shouldBe (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map")) diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs index 6a8b2df15e..f7a7f45691 100644 --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -13,7 +13,7 @@ import Language.PureScript.Ide.Util import Test.Hspec value :: Text -> IdeDeclarationAnn -value s = withEmptyAnn (IdeValue (P.Ident (toS s)) P.REmpty) +value s = withEmptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.REmpty)) firstResult, secondResult, fiult :: Match IdeDeclarationAnn firstResult = Match (P.moduleNameFromString "Match", value "firstResult") diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index f0e03c4ae0..f273938f45 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -18,11 +18,11 @@ d :: IdeDeclaration -> IdeDeclarationAnn d = IdeDeclarationAnn emptyAnn valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn -valueA = d (IdeValue (P.Ident "valueA") P.REmpty) -typeA = d (IdeType (P.ProperName "TypeA") P.Star) -classA = d (IdeTypeClass (P.ProperName "ClassA")) -dtorA1 = d (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty) -dtorA2 = d (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty) +valueA = d (IdeDeclValue (IdeValue (P.Ident "valueA") P.REmpty)) +typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.Star)) +classA = d (IdeDeclTypeClass (P.ProperName "ClassA")) +dtorA1 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty)) +dtorA2 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty)) env :: Map P.ModuleName [IdeDeclarationAnn] env = Map.fromList diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index 87b50d266f..27796629c9 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -11,20 +11,20 @@ import qualified Data.Map as Map valueOperator :: Maybe P.Type -> IdeDeclarationAnn valueOperator = - d . IdeValueOperator (P.OpName "<$>") (P.Qualified (Just (mn "Test")) (Left (P.Ident "function"))) 2 P.Infix + d . IdeDeclValueOperator . IdeValueOperator (P.OpName "<$>") (P.Qualified (Just (mn "Test")) (Left (P.Ident "function"))) 2 P.Infix ctorOperator :: Maybe P.Type -> IdeDeclarationAnn ctorOperator = - d . IdeValueOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (Right (P.ProperName "Cons"))) 2 P.Infix + d . IdeDeclValueOperator . IdeValueOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (Right (P.ProperName "Cons"))) 2 P.Infix typeOperator :: Maybe P.Kind -> IdeDeclarationAnn typeOperator = - d . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix + d . IdeDeclTypeOperator . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix testModule :: Module -testModule = (mn "Test", [ d (IdeValue (P.Ident "function") P.REmpty) - , d (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty)) - , d (IdeType (P.ProperName "List") P.Star) +testModule = (mn "Test", [ d (IdeDeclValue (IdeValue (P.Ident "function") P.REmpty)) + , d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty))) + , d (IdeDeclType (IdeType (P.ProperName "List") P.Star)) , valueOperator Nothing , ctorOperator Nothing , typeOperator Nothing From 32220eeb91ef77443a05af458eff5358318ccb65 Mon Sep 17 00:00:00 2001 From: Brandon Hamilton Date: Mon, 10 Oct 2016 22:16:17 +0200 Subject: [PATCH 0517/1580] Update CONTRIBUTORS.md (#2382) --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 5f0f220523..3e4e17d6cb 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -81,6 +81,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@brandonhamilton](https://github.com/brandonhamilton) (Brandon Hamilton) My existing contributions and all future contributions until further notice are Copyright Brandon Hamilton, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies From 56613a83ea1d31fe0407e38f7a621c8d24b22e49 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 11 Oct 2016 08:24:40 -0700 Subject: [PATCH 0518/1580] Pretty-print suggested types differently (#2369) * Pretty-print suggested types differently * Show regular types in error --- src/Language/PureScript/Errors.hs | 26 +++++----- src/Language/PureScript/Pretty/Types.hs | 69 +++++++++++++++---------- 2 files changed, 55 insertions(+), 40 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 967ccd18ca..59cb917b98 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -287,19 +287,19 @@ wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ error -- WildcardInferredType - source span not small enough -- DuplicateSelectiveImport - would require 2 ranges to remove and 1 insert errorSuggestion :: SimpleErrorMessage -> Maybe ErrorSuggestion -errorSuggestion err = case err of - UnusedImport{} -> emptySuggestion - DuplicateImport{} -> emptySuggestion - UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual - UnusedDctorImport mn _ qual refs -> suggest $ importSuggestion mn refs qual - UnusedDctorExplicitImport mn _ _ qual refs -> suggest $ importSuggestion mn refs qual - ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing - ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) - HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing - MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintType ty - WildcardInferredType ty _ -> suggest $ prettyPrintType ty - _ -> Nothing - +errorSuggestion err = + case err of + UnusedImport{} -> emptySuggestion + DuplicateImport{} -> emptySuggestion + UnusedExplicitImport mn _ qual refs -> suggest $ importSuggestion mn refs qual + UnusedDctorImport mn _ qual refs -> suggest $ importSuggestion mn refs qual + UnusedDctorExplicitImport mn _ _ qual refs -> suggest $ importSuggestion mn refs qual + ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing + ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) + HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing + MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintSuggestedType ty + WildcardInferredType ty _ -> suggest $ prettyPrintSuggestedType ty + _ -> Nothing where emptySuggestion = Just $ ErrorSuggestion "" suggest = Just . ErrorSuggestion diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 8583450091..1233dc2408 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -3,7 +3,9 @@ -- module Language.PureScript.Pretty.Types ( typeAsBox + , suggestedTypeAsBox , prettyPrintType + , prettyPrintSuggestedType , typeAtomAsBox , prettyPrintTypeAtom , prettyPrintRowWith @@ -27,23 +29,6 @@ import Language.PureScript.Types import Text.PrettyPrint.Boxes hiding ((<+>)) -typeLiterals :: Pattern () Type Box -typeLiterals = mkPattern match - where - match TypeWildcard{} = Just $ text "_" - match (TypeVar var) = Just $ text var - match (TypeLevelString s) = Just . text $ show s - match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row - match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor - match (TUnknown u) = Just $ text $ 't' : show u - match (Skolem name s _ _) = Just $ text $ name ++ show s - match REmpty = Just $ text "()" - match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row - match (BinaryNoParensType op l r) = - Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r - match (TypeOp op) = Just $ text $ showQualified runOpName op - match _ = Nothing - constraintsAsBox :: [Constraint] -> Box -> Box constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty) constraintsAsBox xs ty = vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (text ") => " <> ty) @@ -120,12 +105,32 @@ explicitParens = mkPattern match match (ParensInType ty) = Just ((), ty) match _ = Nothing -matchTypeAtom :: Pattern () Type Box -matchTypeAtom = typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) matchType - -matchType :: Pattern () Type Box -matchType = buildPrettyPrinter operators matchTypeAtom +matchTypeAtom :: Bool -> Pattern () Type Box +matchTypeAtom suggesting = + typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType suggesting) where + typeLiterals :: Pattern () Type Box + typeLiterals = mkPattern match where + match TypeWildcard{} = Just $ text "_" + match (TypeVar var) = Just $ text var + match (TypeLevelString s) = Just . text $ show s + match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row + match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor + match (TUnknown u) + | suggesting = Just $ text "_" + | otherwise = Just $ text $ 't' : show u + match (Skolem name s _ _) + | suggesting = Just $ text name + | otherwise = Just $ text $ name ++ show s + match REmpty = Just $ text "()" + match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row + match (BinaryNoParensType op l r) = + Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r + match (TypeOp op) = Just $ text $ showQualified runOpName op + match _ = Nothing + +matchType :: Bool -> Pattern () Type Box +matchType = buildPrettyPrinter operators . matchTypeAtom where operators :: OperatorTable () Type Box operators = OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ] @@ -152,7 +157,7 @@ forall_ = mkPattern match typeAtomAsBox :: Type -> Box typeAtomAsBox = fromMaybe (internalError "Incomplete pattern") - . PA.pattern matchTypeAtom () + . PA.pattern (matchTypeAtom False) () . insertPlaceholders -- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses @@ -160,11 +165,21 @@ prettyPrintTypeAtom :: Type -> String prettyPrintTypeAtom = render . typeAtomAsBox typeAsBox :: Type -> Box -typeAsBox +typeAsBox = typeAsBoxImpl False + +suggestedTypeAsBox :: Type -> Box +suggestedTypeAsBox = typeAsBoxImpl True + +typeAsBoxImpl :: Bool -> Type -> Box +typeAsBoxImpl suggesting = fromMaybe (internalError "Incomplete pattern") - . PA.pattern matchType () + . PA.pattern (matchType suggesting) () . insertPlaceholders --- | Generate a pretty-printed string representing a Type +-- | Generate a pretty-printed string representing a 'Type' prettyPrintType :: Type -> String -prettyPrintType = render . typeAsBox +prettyPrintType = render . typeAsBoxImpl False + +-- | Generate a pretty-printed string representing a suggested 'Type' +prettyPrintSuggestedType :: Type -> String +prettyPrintSuggestedType = render . typeAsBoxImpl True From eaaef21f96d0d790d2e4cd0e59e89687cbea4ae4 Mon Sep 17 00:00:00 2001 From: pete higgins Date: Tue, 11 Oct 2016 10:48:25 -0700 Subject: [PATCH 0519/1580] Small cleanup to Language.PureScript.Interactive.IO (#2381) * Only export functions used externally. * Remove dead method expandTilde. It looks like the only remaining caller of this method was removed in: 9e562663210e0bb798cf183a25fb84a142a7f17b * Add myself to contributors. * Remove an unused import. * Correctly alphabetize myself. --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Interactive/IO.hs | 11 ++--------- 2 files changed, 3 insertions(+), 9 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 3e4e17d6cb..dd6943f7db 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -63,6 +63,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@paulyoung](https://github.com/paulyoung) (Paul Young) My existing contributions and all future contributions until further notice are Copyright Paul Young, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@pelotom](https://github.com/pelotom) (Thomas Crockett) My existing contributions and all future contributions until further notice are Copyright Thomas Crockett, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@phadej](https://github.com/phadej) (Oleg Grenrus) My existing contributions and all future contributions until further notice are Copyright Oleg Grenrus, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@phiggins](https://github.com/phiggins) (Pete Higgins) My existing contributions and all future contributions until further notice are Copyright Pete Higgins, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@philopon](https://github.com/philopon) (Hirotomo Moriwaki) - My existing contributions and all future contributions until further notice are Copyright Hirotomo Moriwaki, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@pseudonom](https://github.com/pseudonom) (Eric Easley) My existing contributions and all future contributions until further notice are Copyright Eric Easley, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@puffnfresh](https://github.com/puffnfresh) (Brian McKenna) All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler. diff --git a/src/Language/PureScript/Interactive/IO.hs b/src/Language/PureScript/Interactive/IO.hs index e120ec3e85..17c4183eb4 100644 --- a/src/Language/PureScript/Interactive/IO.hs +++ b/src/Language/PureScript/Interactive/IO.hs @@ -1,11 +1,11 @@ -module Language.PureScript.Interactive.IO where +module Language.PureScript.Interactive.IO (findNodeProcess, getHistoryFilename) where import Prelude.Compat import Control.Monad (msum) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable) -import System.FilePath (takeDirectory, (), isPathSeparator) +import System.FilePath (takeDirectory, ()) mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory @@ -32,10 +32,3 @@ getHistoryFilename = do let filename = home ".purescript" "psci_history" mkdirp filename return filename - --- | --- Expands tilde in path. --- -expandTilde :: FilePath -> IO FilePath -expandTilde ('~':p:rest) | isPathSeparator p = ( rest) <$> getHomeDirectory -expandTilde p = return p From 92f91110d7be728e712a7779e0e4f79b50f63043 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Tue, 11 Oct 2016 07:49:54 +0100 Subject: [PATCH 0520/1580] Fix scope traversal for do-notation bind. --- examples/warning/2383.purs | 12 ++++++++++++ src/Language/PureScript/AST/Traversals.hs | 2 +- 2 files changed, 13 insertions(+), 1 deletion(-) create mode 100644 examples/warning/2383.purs diff --git a/examples/warning/2383.purs b/examples/warning/2383.purs new file mode 100644 index 0000000000..dfcb8ebb7a --- /dev/null +++ b/examples/warning/2383.purs @@ -0,0 +1,12 @@ +-- | This specifically shouldn't warn about `x` being shadowed in `main` +-- | See https://github.com/purescript/purescript/issues/2383 +module Main where + +import Prelude + +import Control.Monad.Eff (Eff) + +main :: Eff () Unit +main = do + x <- let x = pure unit in x + pure unit diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index b1ce9fb522..a489bfc0e7 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -551,7 +551,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) j' s (DoNotationValue v) = (s, g'' s v) j' s (DoNotationBind b v) = let s' = S.union (S.fromList (binderNames b)) s - in (s', h'' s b <> g'' s' v) + in (s', h'' s b <> g'' s v) j' s (DoNotationLet ds) = let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds)) in (s', foldMap (f'' s') ds) From 61019d0816b261261a9da6e8e76367e51a59f58b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 11 Oct 2016 15:52:45 -0700 Subject: [PATCH 0521/1580] Better error messages for bad indentation (#2368) --- src/Language/PureScript/Parser/Common.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index b7f530efcf..72a081ab4f 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -107,23 +107,26 @@ mark p = do -- | -- Check that the current identation level matches a predicate -- -checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec s ParseState () -checkIndentation rel = do +checkIndentation + :: (P.Column -> String) + -> (P.Column -> P.Column -> Bool) + -> P.Parsec s ParseState () +checkIndentation mkMsg rel = do col <- P.sourceColumn <$> P.getPosition current <- indentationLevel <$> P.getState - guard (col `rel` current) + guard (col `rel` current) P. mkMsg current -- | -- Check that the current indentation level is past the current mark -- indented :: P.Parsec s ParseState () -indented = checkIndentation (>) P. "indentation" +indented = checkIndentation (("indentation past column " ++) . show) (>) -- | -- Check that the current indentation level is at the same indentation as the current mark -- same :: P.Parsec s ParseState () -same = checkIndentation (==) P. "no indentation" +same = checkIndentation (("indentation at column " ++) . show) (==) -- | -- Read the comments from the the next token, without consuming it From 427c2a27fc17f455fff1607cac92e061498c7105 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 12 Oct 2016 05:38:03 +0200 Subject: [PATCH 0522/1580] Type directed search (#2352) * initial version of type search on holes * also display type info * apply the substitution to local definitions aswell * clean up typed hole code * don't crash on Rank-N-Types, fix warnings * fix merge conflicts * adds haddock comments for TypeSearch * improve rendering of typesearch * Infernal -> TypeChecker.TypeSearch removes eventual psc-ide code * comment on dummyExpression also don't generalize constraints when typesearching * stylish haskell * do not run type search when generalizing * run `filtering` with the captured substitution rules out correct solutions right now * Revert "run `filtering` with the captured substitution" This reverts commit 2221fe0b707b3a4a539a8cbbe3bcc5abed4256b5. * merges * cleaned up * capture current SupplyT and pass it to typesearch this is so that we don't overlap the type variables * clear up which type is coming from the Environment * only show type search suggestions if we have any limits the maximum number of suggestions to 15 --- purescript.cabal | 1 + src/Control/Monad/Supply.hs | 3 +- src/Control/Monad/Supply/Class.hs | 16 ++-- src/Language/PureScript/AST/Declarations.hs | 11 ++- src/Language/PureScript/AST/Traversals.hs | 12 +++ src/Language/PureScript/Errors.hs | 35 +++++++-- .../PureScript/TypeChecker/TypeSearch.hs | 73 +++++++++++++++++++ src/Language/PureScript/TypeChecker/Types.hs | 44 ++++++----- 8 files changed, 166 insertions(+), 29 deletions(-) create mode 100644 src/Language/PureScript/TypeChecker/TypeSearch.hs diff --git a/purescript.cabal b/purescript.cabal index 11cc2b922c..0e903d5c8e 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -238,6 +238,7 @@ library Language.PureScript.TypeChecker.Subsumption Language.PureScript.TypeChecker.Synonyms Language.PureScript.TypeChecker.Types + Language.PureScript.TypeChecker.TypeSearch Language.PureScript.TypeChecker.Unify Language.PureScript.TypeClassDictionaries Language.PureScript.Types diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs index 2fa7aaaf5e..49df7d4fb7 100644 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -7,6 +7,7 @@ module Control.Monad.Supply where import Prelude.Compat +import Control.Applicative import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader import Control.Monad.State @@ -15,7 +16,7 @@ import Control.Monad.Writer import Data.Functor.Identity newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } - deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r) + deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus) runSupplyT :: Integer -> SupplyT m a -> m (a, Integer) runSupplyT n = flip runStateT n . unSupplyT diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index 88fc979184..00d70cfb58 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -1,6 +1,9 @@ -- | -- A class for monads supporting a supply of fresh names -- + +{-# LANGUAGE DefaultSignatures #-} + module Control.Monad.Supply.Class where import Prelude.Compat @@ -11,18 +14,21 @@ import Control.Monad.Writer class Monad m => MonadSupply m where fresh :: m Integer + peek :: m Integer + default fresh :: MonadTrans t => t m Integer + fresh = lift fresh + default peek :: MonadTrans t => t m Integer + peek = lift peek instance Monad m => MonadSupply (SupplyT m) where fresh = SupplyT $ do n <- get put (n + 1) return n + peek = SupplyT get -instance MonadSupply m => MonadSupply (StateT s m) where - fresh = lift fresh - -instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m) where - fresh = lift fresh +instance MonadSupply m => MonadSupply (StateT s m) +instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m) freshName :: MonadSupply m => m String freshName = fmap (('$' :) . show) fresh diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 513d8e064a..69256c88ae 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -29,6 +29,15 @@ import qualified Text.Parsec as P -- | A map of locally-bound names in scope. type Context = [(Ident, Type)] +-- | Holds the data necessary to do type directed search for typed holes +data TypeSearch + = TSBefore Environment + -- ^ An Environment captured for later consumption by type directed search + | TSAfter [(Qualified Ident, Type)] + -- ^ Results of applying type directed search to the previously captured + -- Environment + deriving Show + -- | A type of error messages data SimpleErrorMessage = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) @@ -99,7 +108,7 @@ data SimpleErrorMessage | ShadowedTypeVar String | UnusedTypeVar String | WildcardInferredType Type Context - | HoleInferredType String Type Context + | HoleInferredType String Type Context TypeSearch | MissingTypeDeclaration Ident Type | OverlappingPattern [[Binder]] Bool | IncompleteExhaustivityCheck diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index a489bfc0e7..82feaa27e8 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -586,3 +586,15 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con forValues (DeferredDictionary _ tys) = mconcat (map f tys) forValues (TypedValue _ _ ty) = f ty forValues _ = mempty + +-- | +-- Map a function over type annotations appearing inside a value +-- +overTypes :: (Type -> Type) -> Expr -> Expr +overTypes f = let (_, f', _) = everywhereOnValues id g id in f' + where + g :: Expr -> Expr + g (TypedValue checkTy val t) = TypedValue checkTy val (f t) + g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints + g other = other + diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 59cb917b98..26139b46d8 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -40,6 +40,7 @@ import qualified System.Console.ANSI as ANSI import qualified Text.Parsec as P import qualified Text.Parsec.Error as PE import qualified Text.PrettyPrint.Boxes as Box +import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers import Text.Parsec.Error (Message(..)) newtype ErrorSuggestion = ErrorSuggestion String @@ -266,7 +267,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx - gSimple (HoleInferredType name ty ctx) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx + gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx <*> gTypeSearch env gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty gSimple other = pure other @@ -280,6 +281,9 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint (ErrorSolvingConstraint con) = ErrorSolvingConstraint <$> overConstraintArgs (traverse f) con gHint other = pure other + gTypeSearch (TSBefore env) = pure (TSBefore env) + gTypeSearch (TSAfter result) = TSAfter <$> traverse (traverse f) result + wikiUri :: ErrorMessage -> String wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e @@ -733,10 +737,31 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS paras $ [ line "Wildcard type definition has the inferred type " , markCodeBox $ indent $ typeAsBox ty ] ++ renderContext ctx - renderSimpleErrorMessage (HoleInferredType name ty ctx) = - paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type " - , markCodeBox $ indent $ typeAsBox ty - ] ++ renderContext ctx + renderSimpleErrorMessage (HoleInferredType name ty ctx ts) = + let + maxTSResults = 15 + tsResult = case ts of + (TSAfter idents) | not (null idents) -> + let + formatTS (names, types) = + let + idBoxes = Box.text . showQualified runIdent <$> names + tyBoxes = (\t -> BoxHelpers.indented + (Box.text ":: " Box.<> typeAsBox t)) <$> types + longestId = maximum (map Box.cols idBoxes) + in + Box.vcat Box.top $ + zipWith (Box.<>) + (Box.alignHoriz Box.left longestId <$> idBoxes) + tyBoxes + in [ line "You could substitute the hole with one of these values:" + , markCodeBox (indent (formatTS (unzip (take maxTSResults idents)))) + ] + _ -> [] + in + paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type " + , markCodeBox (indent (typeAsBox ty)) + ] ++ tsResult ++ renderContext ctx renderSimpleErrorMessage (MissingTypeDeclaration ident ty) = paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "." , line "It is good practice to provide type declarations as a form of documentation." diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs new file mode 100644 index 0000000000..a6702dc64a --- /dev/null +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Language.PureScript.TypeChecker.TypeSearch + ( typeSearch + ) where + +import Protolude + +import Control.Monad.Writer +import qualified Data.Map as Map +import qualified Language.PureScript.TypeChecker.Entailment as Entailment + +import qualified Language.PureScript.TypeChecker.Monad as TC +import Language.PureScript.TypeChecker.Subsumption +import Language.PureScript.TypeChecker.Unify as P + +import Control.Monad.Supply as P +import Language.PureScript.AST as P +import Language.PureScript.Environment as P +import Language.PureScript.Names as P +import Language.PureScript.TypeChecker.Skolems as Skolem +import Language.PureScript.TypeChecker.Synonyms as P +import Language.PureScript.Types as P + +checkInEnvironment + :: Environment + -> Integer + -> StateT TC.CheckState (SupplyT (WriterT b (Except e))) a + -> Maybe (a, Environment) +checkInEnvironment env nextVar = + either (const Nothing) Just + . runExcept + . evalWriterT + . P.evalSupplyT nextVar + . TC.runCheck' env + +evalWriterT :: Monad m => WriterT b m r -> m r +evalWriterT m = liftM fst (runWriterT m) + +checkSubsume + :: P.Environment + -- ^ The Environment which contains the relevant definitions and typeclasses + -> Integer + -> P.Type + -- ^ The user supplied type + -> P.Type + -- ^ The type supplied by the environment + -> Maybe ((P.Expr, [(P.Ident, P.Constraint)]), P.Environment) +checkSubsume env nextVar userT envT = checkInEnvironment env nextVar $ do + let initializeSkolems = + Skolem.introduceSkolemScope + <=< P.replaceAllTypeSynonyms + <=< P.replaceTypeWildcards + + userT' <- initializeSkolems userT + envT' <- initializeSkolems envT + + let dummyExpression = P.Var (P.Qualified Nothing (P.Ident "x")) + + elab <- subsumes envT' userT' + subst <- gets TC.checkSubstitution + let expP = P.overTypes (P.substituteType subst) (elab dummyExpression) + Entailment.replaceTypeClassDictionaries False expP + +typeSearch + :: P.Environment + -> Integer + -> P.Type + -> Map (P.Qualified P.Ident) P.Type +typeSearch env nextVar type' = + Map.mapMaybe (\(x, _, _) -> checkSubsume env nextVar type' x $> x) (P.names env) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 142834762e..63ec9c50f9 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -31,7 +31,7 @@ import Control.Arrow (second) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets) -import Control.Monad.Supply.Class (MonadSupply) +import Control.Monad.Supply.Class (MonadSupply, peek) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Bifunctor (bimap) @@ -55,9 +55,11 @@ import Language.PureScript.TypeChecker.Rows import Language.PureScript.TypeChecker.Skolems import Language.PureScript.TypeChecker.Subsumption import Language.PureScript.TypeChecker.Synonyms +import Language.PureScript.TypeChecker.TypeSearch import Language.PureScript.TypeChecker.Unify import Language.PureScript.Types + data BindingGroupType = RecursiveBindingGroup | NonRecursiveBindingGroup @@ -72,6 +74,10 @@ typesOf -> [(Ident, Expr)] -> m [(Ident, (Expr, Type))] typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do + -- TODO: If we push withoutWarnings into the do block we can differentiate + -- between ds1 and ds2 warnings and capture shouldGeneralize and the unsolved + -- dictionaries + -- Careful: We need to make sure the capturingSubstitution still does the right thing (tys, w) <- withoutWarnings . capturingSubstitution tidyUp $ do (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict @@ -106,8 +112,9 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv) let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies let constraintTypeVars = nub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..] - when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ - throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ NoInstanceFound con + when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ do + nextVar <- peek + throwError . onErrorMessages (replaceTypes (not shouldGeneralize) currentSubst nextVar) . errorMessage $ NoInstanceFound con -- Check skolem variables did not escape their scope skolemEscapeCheck val' @@ -118,11 +125,24 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -- Show warnings here, since types in wildcards might have been solved during -- instance resolution (by functional dependencies). finalSubst <- gets checkSubstitution - escalateWarningWhen isHoleError . tell . onErrorMessages (replaceTypes finalSubst) $ w + + -- TODO: We should only do type search for Typed Holes which we inferred + -- without generalizing type class constraints + -- eg. foldMap ?x [1, 2, 3] finds `negate` right now, which is wrong + + nextVar <- peek + escalateWarningWhen isHoleError . tell . onErrorMessages (replaceTypes True finalSubst nextVar) $ w return inferred where - replaceTypes subst = onTypesInErrorMessage (substituteType subst) + replaceTypes shouldRunTypeSearch subst nextVar = + (if shouldRunTypeSearch then runTypeSearch else id) + . onTypesInErrorMessage (substituteType subst) + where + runTypeSearch (ErrorMessage hints (HoleInferredType x ty y (TSBefore env))) = + ErrorMessage hints (HoleInferredType x ty y $ TSAfter $ + fmap (substituteType subst) <$> M.toList (typeSearch env nextVar (substituteType subst ty))) + runTypeSearch x = x -- | Generalize type vars using forall and add inferred constraints generalize unsolved = varIfUnknown . constrain unsolved @@ -207,17 +227,6 @@ isTyped (name, PositionedValue pos c value) = (isTyped (name, value)) isTyped (name, value) = Left (name, value) --- | --- Map a function over type annotations appearing inside a value --- -overTypes :: (Type -> Type) -> Expr -> Expr -overTypes f = let (_, f', _) = everywhereOnValues id g id in f' - where - g :: Expr -> Expr - g (TypedValue checkTy val t) = TypedValue checkTy val (f t) - g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints - g other = other - -- | Check the kind of a type, failing if it is not of kind *. checkTypeKind :: (MonadError MultipleErrors m) => @@ -345,7 +354,8 @@ infer' (TypedValue checkType val ty) = do infer' (Hole name) = do ty <- freshType ctx <- getLocalContext - tell . errorMessage $ HoleInferredType name ty ctx + env <- getEnv + tell . errorMessage $ HoleInferredType name ty ctx (TSBefore env) return $ TypedValue True (Hole name) ty infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do TypedValue t v ty <- infer' val From a70b5dd927e360bded78cd66156352b120a955db Mon Sep 17 00:00:00 2001 From: Brandon Hamilton Date: Wed, 12 Oct 2016 05:38:22 +0200 Subject: [PATCH 0523/1580] Allow symbols in data contructors (#2384) * Allow symbols in data contructors * Accept bindings with data contructors containing symbols * Refactor identifier codegen to use common code * Update data constructor example --- examples/passing/DctorName.purs | 33 +++++++++++++++++++ src/Language/PureScript/CodeGen/JS.hs | 16 ++++----- src/Language/PureScript/CodeGen/JS/Common.hs | 7 ++-- src/Language/PureScript/Parser/Common.hs | 6 ++++ .../PureScript/Parser/Declarations.hs | 8 ++--- src/Language/PureScript/Parser/Lexer.hs | 7 ++++ 6 files changed, 63 insertions(+), 14 deletions(-) create mode 100644 examples/passing/DctorName.purs diff --git a/examples/passing/DctorName.purs b/examples/passing/DctorName.purs new file mode 100644 index 0000000000..05d4f8d1bd --- /dev/null +++ b/examples/passing/DctorName.purs @@ -0,0 +1,33 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +newtype Bar' = Bar' Int + +data Foo' = Foo' Bar' + +data Baz'' = Baz'' | Baz' + +f ∷ Foo' → Boolean +f a = case a of Foo' b → true + +f' ∷ Boolean +f' = f $ Foo' $ Bar' 0 + +g ∷ Baz'' → Int +g Baz'' = 0 +g Baz' = 1 + +g' ∷ Int +g' = g Baz'' + +h ∷ Bar' → Int +h (Bar' x) + | x <= 10 = x * 2 + | otherwise = 10 + +h' ∷ Int +h' = h $ Bar' 4 + +main = log "Done" \ No newline at end of file diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index db1ea96f70..94b5c5e8c9 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -244,23 +244,23 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = ret <- valueToJs val return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (ds' ++ [JSReturn Nothing ret]))) [] valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = - return $ JSVariableIntroduction Nothing ctor (Just $ + return $ JSVariableIntroduction Nothing (properToJs ctor) (Just $ JSObjectLiteral Nothing [("create", JSFunction Nothing Nothing ["value"] (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))]) valueToJs' (Constructor _ _ (ProperName ctor) []) = - return $ iife ctor [ JSFunction Nothing (Just ctor) [] (JSBlock Nothing []) - , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing ctor)) - (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) []) ] + return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing []) + , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing (properToJs ctor))) + (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ] valueToJs' (Constructor _ _ (ProperName ctor) fields) = let constructor = let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] - in JSFunction Nothing (Just ctor) (identToJs `map` fields) (JSBlock Nothing body) + in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body) createFn = - let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) (var `map` fields) + let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields) in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields - in return $ iife ctor [ constructor - , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing ctor)) createFn + in return $ iife (properToJs ctor) [ constructor + , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing (properToJs ctor))) createFn ] iife :: String -> [JS] -> JS diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index f0d180ce15..758e23552f 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -26,10 +26,13 @@ moduleNameToJs (ModuleName pns) = -- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value. -- identToJs :: Ident -> String -identToJs (Ident name) +identToJs (Ident name) = properToJs name +identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" + +properToJs :: String -> String +properToJs name | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name | otherwise = concatMap identCharToString name -identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" -- | -- Test if a string is a valid JS identifier without escaping. diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index 72a081ab4f..e786a502aa 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -28,6 +28,12 @@ properName = ProperName <$> uname typeName :: TokenParser (ProperName 'TypeName) typeName = ProperName <$> tyname +-- | +-- Parse a proper name for a data constructor. +-- +dataConstructorName :: TokenParser (ProperName 'ConstructorName) +dataConstructorName = ProperName <$> dconsname + -- | -- Parse a module name -- diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index e192eee209..6433762bfb 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -71,7 +71,7 @@ parseDataDeclaration = do tyArgs <- many (indented *> kindedIdent) ctors <- P.option [] $ do indented *> equals - P.sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe + P.sepBy1 ((,) <$> dataConstructorName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe return $ DataDeclaration dtype name tyArgs ctors parseTypeDeclaration :: TokenParser Declaration @@ -360,7 +360,7 @@ parseVar :: TokenParser Expr parseVar = Var <$> C.parseQualified C.parseIdent parseConstructor :: TokenParser Expr -parseConstructor = Constructor <$> C.parseQualified C.properName +parseConstructor = Constructor <$> C.parseQualified C.dataConstructorName parseCase :: TokenParser Expr parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue) @@ -494,10 +494,10 @@ parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number) <|> return id parseNullaryConstructorBinder :: TokenParser Binder -parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure [] +parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> pure [] parseConstructorBinder :: TokenParser Binder -parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens) +parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> many (C.indented *> parseBinderNoParens) parseObjectBinder:: TokenParser Binder parseObjectBinder = LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder) diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 2962fe1d72..392ab70230 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -43,6 +43,7 @@ module Language.PureScript.Parser.Lexer , lname' , qualifier , tyname + , dconsname , uname , uname' , mname @@ -452,6 +453,12 @@ tyname = token go P. "type name" go (UName s) = Just s go _ = Nothing +dconsname :: TokenParser String +dconsname = token go P. "data constructor name" + where + go (UName s) = Just s + go _ = Nothing + mname :: TokenParser String mname = token go P. "module name" where From 0ab0f9af2a05bb70de2d871fe4e6f788868d4b23 Mon Sep 17 00:00:00 2001 From: rightfold Date: Wed, 12 Oct 2016 15:56:42 +0200 Subject: [PATCH 0524/1580] Update outdated comments about Prim types --- src/Language/PureScript/Environment.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index fbd665dc75..49043e282e 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -236,8 +236,8 @@ function t1 = TypeApp (TypeApp tyFunction t1) -- | -- The primitive types in the external javascript environment with their --- associated kinds. There is also a pseudo `Partial` type that corresponds to --- the class with the same name. +-- associated kinds. There are also pseudo `Fail` and `Partial` types +-- that correspond to the classes with the same names. -- primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) primTypes = @@ -257,8 +257,9 @@ primTypes = ] -- | --- The primitive class map. This just contains to `Partial` class, used as a --- kind of magic constraint for partial functions. +-- The primitive class map. This just contains the `Fail` and `Partial` +-- classes. `Partial` is used as a kind of magic constraint for partial +-- functions. `Fail` is used for user-defined type errors. -- primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses = From 4f2959aab1c81136e7b63f51e9beffe6a8052a0c Mon Sep 17 00:00:00 2001 From: rightfold Date: Sun, 16 Oct 2016 14:22:45 +0200 Subject: [PATCH 0525/1580] Support record updates on records with field named hasOwnProperty Previously this would fail. --- examples/passing/HasOwnProperty.purs | 5 +++++ src/Language/PureScript/CodeGen/JS.hs | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) create mode 100644 examples/passing/HasOwnProperty.purs diff --git a/examples/passing/HasOwnProperty.purs b/examples/passing/HasOwnProperty.purs new file mode 100644 index 0000000000..6a70fb73ec --- /dev/null +++ b/examples/passing/HasOwnProperty.purs @@ -0,0 +1,5 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +main = log ({hasOwnProperty: "Hi"} {hasOwnProperty = "Done"}).hasOwnProperty diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 94b5c5e8c9..243902e32d 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -291,7 +291,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = evaluate = JSVariableIntroduction Nothing evaluatedObj (Just obj) objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing []) copy = JSForIn Nothing key jsEvaluatedObj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing] - cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" jsEvaluatedObj) [jsKey] + cond = JSApp Nothing (JSAccessor Nothing "call" (JSAccessor Nothing "hasOwnProperty" (JSObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey] assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey jsEvaluatedObj)] stToAssign (s, js) = JSAssignment Nothing (accessorString s jsNewObj) js extend = map stToAssign sts From 26590bb02cffce314df9b12f0e38a9d2a6675ffc Mon Sep 17 00:00:00 2001 From: Brandon Hamilton Date: Sun, 16 Oct 2016 19:19:53 +0200 Subject: [PATCH 0526/1580] Fix inliner for Data.Array.unsafeIndex (#2389) * Fix inliner for Data.Array.unsafeIndex * Better naming in Inliner functions * Ignore dictionary name in Data.Array.unsafeIndex inlining --- .../CodeGen/JS/Optimizer/Inliner.hs | 30 +++++++++++-------- 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index 2dc42b842c..1c873eb6b3 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -99,15 +99,6 @@ inlineCommonValues = everywhereOnJS convert fnSubtract = (C.dataRing, C.sub) intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0)) -inlineNonClassFunction :: (String, String) -> (JS -> JS -> JS) -> JS -> JS -inlineNonClassFunction (m, op) f = everywhereOnJS convert - where - convert :: JS -> JS - convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y - convert other = other - isOp (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op' - isOp _ = False - inlineCommonOperators :: JS -> JS inlineCommonOperators = applyAll $ [ binary semiringNumber opAdd Add @@ -167,9 +158,9 @@ inlineCommonOperators = applyAll $ , binary' C.dataIntBits C.zshr ZeroFillShiftRight , unary' C.dataIntBits C.complement BitwiseNot - , inlineNonClassFunction (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x] - , inlineNonClassFunction (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x] - , inlineNonClassFunction (C.dataArray, C.unsafeIndex) $ flip (JSIndexer Nothing) + , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> JSApp Nothing f [x] + , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> JSApp Nothing f [x] + , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (JSIndexer Nothing) ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] where @@ -233,6 +224,21 @@ inlineCommonOperators = applyAll $ go m acc (JSApp _ lhs [arg]) = go (m - 1) (arg : acc) lhs go _ _ _ = Nothing + inlineNonClassFunction :: (JS -> Bool) -> (JS -> JS -> JS) -> JS -> JS + inlineNonClassFunction p f = everywhereOnJS convert + where + convert :: JS -> JS + convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y + convert other = other + + isModFn :: (String, String) -> JS -> Bool + isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op' + isModFn _ _ = False + + isModFnWithDict :: (String, String) -> JS -> Bool + isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [(JSVar _ _)]) = m == m' && op == op' + isModFnWithDict _ _ = False + -- (f <<< g $ x) = f (g x) -- (f <<< g) = \x -> f (g x) inlineFnComposition :: (MonadSupply m) => JS -> m JS From da83efb94a6a50d4d29c73fa89a3e8fa0c4c9b76 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 20 Oct 2016 09:32:17 -0700 Subject: [PATCH 0527/1580] Fix issue with typed holes in inference mode (#2386) * Fix issue with typed holes in inference mode * Fix issues arising from unification variable overlaps * remove import * Fixes after code review --- src/Language/PureScript/Make.hs | 2 +- .../PureScript/TypeChecker/Entailment.hs | 56 ++++++++------ src/Language/PureScript/TypeChecker/Monad.hs | 6 +- .../PureScript/TypeChecker/TypeSearch.hs | 49 ++++++++---- src/Language/PureScript/TypeChecker/Types.hs | 75 ++++++++++--------- 5 files changed, 114 insertions(+), 74 deletions(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 99d46721ad..668231b074 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -149,7 +149,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do lint withPrim ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do [desugared] <- desugar externs [withPrim] - runCheck' env $ typeCheckModule desugared + runCheck' (emptyCheckState env) $ typeCheckModule desugared regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated let mod' = Module ss coms moduleName regrouped exps corefn = CF.moduleToCoreFn env' mod' diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 51eebd1844..5c227b6d8a 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -5,8 +5,10 @@ -- module Language.PureScript.TypeChecker.Entailment ( InstanceContext + , SolverOptions(..) , replaceTypeClassDictionaries , newDictionaries + , entails ) where import Prelude.Compat @@ -56,7 +58,7 @@ replaceTypeClassDictionaries . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => Bool -> Expr - -> m (Expr, [(Ident, Constraint)]) + -> m (Expr, [(Ident, InstanceContext, Constraint)]) replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ do -- Loop, deferring any unsolved constraints, until there are no more -- constraints which can be solved, then make a generalization pass. @@ -70,18 +72,18 @@ replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ d -- This pass solves constraints where possible, deferring constraints if not. deferPass :: Expr -> StateT InstanceContext m (Expr, Any) deferPass = fmap (second fst) . runWriterT . f where - f :: Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr + f :: Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr (_, f, _) = everywhereOnValuesTopDownM return (go True) return -- This pass generalizes any remaining constraints - generalizePass :: Expr -> StateT InstanceContext m (Expr, [(Ident, Constraint)]) + generalizePass :: Expr -> StateT InstanceContext m (Expr, [(Ident, InstanceContext, Constraint)]) generalizePass = fmap (second snd) . runWriterT . f where - f :: Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr + f :: Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr (_, f, _) = everywhereOnValuesTopDownM return (go False) return - go :: Bool -> Expr -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr - go deferErrors dict@(TypeClassDictionary _ _ hints) = - rethrow (addHints hints) $ entails shouldGeneralize deferErrors dict + go :: Bool -> Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr + go deferErrors (TypeClassDictionary constraint context hints) = + rethrow (addHints hints) $ entails (SolverOptions shouldGeneralize deferErrors) constraint context hints go _ other = return other -- | Three options for how we can handle a constraint, depending on the mode we're in. @@ -93,18 +95,29 @@ data EntailsResult a | Deferred -- ^ We couldn't solve this constraint right now, so it has been deferred --- | --- Check that the current set of type class dictionaries entail the specified type class goal, and, if so, +-- | Options for the constraint solver +data SolverOptions = SolverOptions + { solverShouldGeneralize :: Bool + -- ^ Should the solver be allowed to generalize over unsolved constraints? + , solverDeferErrors :: Bool + -- ^ Should the solver be allowed to defer errors by skipping constraints? + } + +-- | Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. --- entails :: forall m . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) - => Bool - -> Bool - -> Expr - -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr -entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hints) = + => SolverOptions + -- ^ Solver options + -> Constraint + -- ^ The constraint to solve + -> InstanceContext + -- ^ The contexts in which to solve the constraint + -> [ErrorMessageHint] + -- ^ Error message hints to apply to any instance errors + -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr +entails SolverOptions{..} constraint context hints = solve constraint where forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope] @@ -123,10 +136,10 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin valUndefined :: Expr valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) - solve :: Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr + solve :: Constraint -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr solve con = go 0 con where - go :: Int -> Constraint -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) Expr + go :: Int -> Constraint -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' go work con'@(Constraint className' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do -- We might have unified types by solving other constraints, so we need to @@ -179,7 +192,7 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin let newContext = mkContext newDicts modify (combineContexts newContext) -- Mark this constraint for generalization - tell (mempty, [(ident, unsolved)]) + tell (mempty, [(ident, context, unsolved)]) return (Var qident) Deferred -> -- Constraint was deferred, just return the dictionary unchanged, @@ -219,10 +232,10 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin unique :: [Type] -> [(a, TypeClassDictionaryInScope)] -> m (EntailsResult a) unique tyArgs [] - | deferErrors = return Deferred + | solverDeferErrors = return Deferred -- We need a special case for nullary type classes, since we want -- to generalize over Partial constraints. - | shouldGeneralize && (null tyArgs || any canBeGeneralized tyArgs) = return (Unsolved (Constraint className' tyArgs conInfo)) + | solverShouldGeneralize && (null tyArgs || any canBeGeneralized tyArgs) = return (Unsolved (Constraint className' tyArgs conInfo)) | otherwise = throwError . errorMessage $ NoInstanceFound (Constraint className' tyArgs conInfo) unique _ [(a, dict)] = return $ Solved a dict unique tyArgs tcds @@ -250,7 +263,7 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin -- Create dictionaries for subgoals which still need to be solved by calling go recursively -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively. - solveSubgoals :: Matching Type -> Maybe [Constraint] -> WriterT (Any, [(Ident, Constraint)]) (StateT InstanceContext m) (Maybe [Expr]) + solveSubgoals :: Matching Type -> Maybe [Constraint] -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) (Maybe [Expr]) solveSubgoals _ Nothing = return Nothing solveSubgoals subst (Just subgoals) = Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals @@ -267,7 +280,6 @@ entails shouldGeneralize deferErrors (TypeClassDictionary constraint context hin App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index) dict) valUndefined -entails _ _ _ = internalError "entails: expected TypeClassDictionary" -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 554a56caf6..79e71fbcec 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -257,11 +257,11 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) }) -- | Run a computation in the typechecking monad, starting with an empty @Environment@ runCheck :: (Functor m) => StateT CheckState m a -> m (a, Environment) -runCheck = runCheck' initEnvironment +runCheck = runCheck' (emptyCheckState initEnvironment) -- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@. -runCheck' :: (Functor m) => Environment -> StateT CheckState m a -> m (a, Environment) -runCheck' env check = second checkEnv <$> runStateT check (emptyCheckState env) +runCheck' :: (Functor m) => CheckState -> StateT CheckState m a -> m (a, Environment) +runCheck' st check = second checkEnv <$> runStateT check st -- | Make an assertion, failing with an error message guardWith :: (MonadError e m) => e -> Bool -> m () diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index a6702dc64a..c84c360828 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -19,6 +19,7 @@ import Language.PureScript.TypeChecker.Unify as P import Control.Monad.Supply as P import Language.PureScript.AST as P import Language.PureScript.Environment as P +import Language.PureScript.Errors as P import Language.PureScript.Names as P import Language.PureScript.TypeChecker.Skolems as Skolem import Language.PureScript.TypeChecker.Synonyms as P @@ -26,29 +27,32 @@ import Language.PureScript.Types as P checkInEnvironment :: Environment - -> Integer - -> StateT TC.CheckState (SupplyT (WriterT b (Except e))) a + -> TC.CheckState + -> StateT TC.CheckState (SupplyT (WriterT b (Except P.MultipleErrors))) a -> Maybe (a, Environment) -checkInEnvironment env nextVar = +checkInEnvironment env st = either (const Nothing) Just . runExcept . evalWriterT - . P.evalSupplyT nextVar - . TC.runCheck' env + . P.evalSupplyT 0 + . TC.runCheck' (st { TC.checkEnv = env }) evalWriterT :: Monad m => WriterT b m r -> m r evalWriterT m = liftM fst (runWriterT m) checkSubsume - :: P.Environment + :: Maybe [(P.Ident, Entailment.InstanceContext, P.Constraint)] + -- ^ Additional constraints we need to satisfy + -> P.Environment -- ^ The Environment which contains the relevant definitions and typeclasses - -> Integer + -> TC.CheckState + -- ^ The typechecker state -> P.Type -- ^ The user supplied type -> P.Type -- ^ The type supplied by the environment - -> Maybe ((P.Expr, [(P.Ident, P.Constraint)]), P.Environment) -checkSubsume env nextVar userT envT = checkInEnvironment env nextVar $ do + -> Maybe ((P.Expr, [(P.Ident, Entailment.InstanceContext, P.Constraint)]), P.Environment) +checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do let initializeSkolems = Skolem.introduceSkolemScope <=< P.replaceAllTypeSynonyms @@ -62,12 +66,29 @@ checkSubsume env nextVar userT envT = checkInEnvironment env nextVar $ do elab <- subsumes envT' userT' subst <- gets TC.checkSubstitution let expP = P.overTypes (P.substituteType subst) (elab dummyExpression) - Entailment.replaceTypeClassDictionaries False expP + + -- Now check that any unsolved constraints have not become impossible + (traverse_ . traverse_) (\(_, context, constraint) -> do + let constraint' = P.mapConstraintArgs (map (P.substituteType subst)) constraint + flip evalStateT Map.empty . evalWriterT $ + Entailment.entails + (Entailment.SolverOptions + { solverShouldGeneralize = True + , solverDeferErrors = False + }) constraint' context []) unsolved + + -- Finally, check any constraints which were found during elaboration + Entailment.replaceTypeClassDictionaries (isJust unsolved) expP typeSearch - :: P.Environment - -> Integer + :: Maybe [(P.Ident, Entailment.InstanceContext, P.Constraint)] + -- ^ Additional constraints we need to satisfy + -> P.Environment + -- ^ The Environment which contains the relevant definitions and typeclasses + -> TC.CheckState + -- ^ The typechecker state -> P.Type + -- ^ The type we are looking for -> Map (P.Qualified P.Ident) P.Type -typeSearch env nextVar type' = - Map.mapMaybe (\(x, _, _) -> checkSubsume env nextVar type' x $> x) (P.names env) +typeSearch unsolved env st type' = + Map.mapMaybe (\(x, _, _) -> checkSubsume unsolved env st type' x $> x) (P.names env) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 63ec9c50f9..0e87db1d0e 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} @@ -27,15 +28,16 @@ module Language.PureScript.TypeChecker.Types import Prelude.Compat -import Control.Arrow (second) +import Control.Arrow (first, second, (***)) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets) -import Control.Monad.Supply.Class (MonadSupply, peek) +import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Bifunctor (bimap) import Data.Either (lefts, rights) +import Data.Functor (($>)) import Data.List (transpose, nub, (\\), partition, delete) import Data.Maybe (fromMaybe) import qualified Data.Map as M @@ -74,17 +76,13 @@ typesOf -> [(Ident, Expr)] -> m [(Ident, (Expr, Type))] typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do - -- TODO: If we push withoutWarnings into the do block we can differentiate - -- between ds1 and ds2 warnings and capture shouldGeneralize and the unsolved - -- dictionaries - -- Careful: We need to make sure the capturingSubstitution still does the right thing - (tys, w) <- withoutWarnings . capturingSubstitution tidyUp $ do + tys <- capturingSubstitution tidyUp $ do (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals - ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict - ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict - return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2) + ds1 <- parU typed $ \e -> withoutWarnings $ checkTypedBindingGroupElement moduleName e dict + ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict untypedDict + return (map (False, ) ds1 ++ map (True, ) ds2) - inferred <- forM tys $ \(shouldGeneralize, (ident, (val, ty))) -> do + inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do -- Replace type class dictionary placeholders with actual dictionaries (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize val -- Generalize and constrain the type @@ -104,7 +102,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do $ CannotGeneralizeRecursiveFunction ident generalized -- Make sure any unsolved type constraints only use type variables which appear -- unknown in the inferred type. - forM_ unsolved $ \(_, con) -> do + forM_ unsolved $ \(_, _, con) -> do -- We need information about functional dependencies, since we allow -- ambiguous types to be inferred if they can be solved by some functional -- dependency. @@ -113,46 +111,55 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies let constraintTypeVars = nub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..] when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ do - nextVar <- peek - throwError . onErrorMessages (replaceTypes (not shouldGeneralize) currentSubst nextVar) . errorMessage $ NoInstanceFound con + throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ NoInstanceFound con -- Check skolem variables did not escape their scope skolemEscapeCheck val' -- Check rows do not contain duplicate labels checkDuplicateLabels val' - return (ident, (foldr (Abs . Left . fst) val' unsolved, generalized)) + return ((ident, (foldr (Abs . Left . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved) -- Show warnings here, since types in wildcards might have been solved during -- instance resolution (by functional dependencies). - finalSubst <- gets checkSubstitution + finalState <- get + forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do + let replaceTypes' = replaceTypes (checkSubstitution finalState) + runTypeSearch' = runTypeSearch (guard shouldGeneralize $> foldMap snd inferred) finalState + (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' . replaceTypes')) w - -- TODO: We should only do type search for Typed Holes which we inferred - -- without generalizing type class constraints - -- eg. foldMap ?x [1, 2, 3] finds `negate` right now, which is wrong - - nextVar <- peek - escalateWarningWhen isHoleError . tell . onErrorMessages (replaceTypes True finalSubst nextVar) $ w - - return inferred + return (map fst inferred) where - replaceTypes shouldRunTypeSearch subst nextVar = - (if shouldRunTypeSearch then runTypeSearch else id) - . onTypesInErrorMessage (substituteType subst) - where - runTypeSearch (ErrorMessage hints (HoleInferredType x ty y (TSBefore env))) = - ErrorMessage hints (HoleInferredType x ty y $ TSAfter $ - fmap (substituteType subst) <$> M.toList (typeSearch env nextVar (substituteType subst ty))) - runTypeSearch x = x + replaceTypes + :: Substitution + -> ErrorMessage + -> ErrorMessage + replaceTypes subst = onTypesInErrorMessage (substituteType subst) + + -- | Run type search to complete any typed hole error messages + runTypeSearch + :: Maybe [(Ident, InstanceContext, Constraint)] + -- ^ Any unsolved constraints which we need to continue to satisfy + -> CheckState + -- ^ The final type checker state + -> ErrorMessage + -> ErrorMessage + runTypeSearch cons st = \case + ErrorMessage hints (HoleInferredType x ty y (TSBefore env)) -> + let subst = checkSubstitution st + searchResult = (fmap . fmap) (substituteType subst) + (M.toList (typeSearch cons env st (substituteType subst ty))) + in ErrorMessage hints (HoleInferredType x ty y (TSAfter searchResult)) + other -> other -- | Generalize type vars using forall and add inferred constraints generalize unsolved = varIfUnknown . constrain unsolved -- | Add any unsolved constraints constrain [] = id - constrain cs = ConstrainedType (map snd cs) + constrain cs = ConstrainedType (map (\(_, _, x) -> x) cs) -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values - tidyUp ts sub = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts + tidyUp ts sub = map (second (first (second (overTypes (substituteType sub) *** substituteType sub)))) ts isHoleError :: ErrorMessage -> Bool isHoleError (ErrorMessage _ HoleInferredType{}) = True From a8756f0ffe39dce9f67438f193bc93fb44f7acde Mon Sep 17 00:00:00 2001 From: Hardy Jones Date: Fri, 21 Oct 2016 19:56:58 -0700 Subject: [PATCH 0528/1580] Handle TypeLevelString when checking orphans (#2393) * Handle TypeLevelString when checking orphans A TypeLevelString by itself can never determine orphan-ness. Similar to how a TypeVar by itself cannot determine orphan-ness. * Glob for Lib.purs in extra-source-files --- examples/failing/2378.purs | 6 ++++++ examples/failing/2378/Lib.purs | 3 +++ examples/passing/2378.purs | 9 +++++++++ purescript.cabal | 1 + src/Language/PureScript/TypeChecker.hs | 1 + 5 files changed, 20 insertions(+) create mode 100644 examples/failing/2378.purs create mode 100644 examples/failing/2378/Lib.purs create mode 100644 examples/passing/2378.purs diff --git a/examples/failing/2378.purs b/examples/failing/2378.purs new file mode 100644 index 0000000000..59de79c207 --- /dev/null +++ b/examples/failing/2378.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith OrphanInstance +module Main where + +import Lib + +instance fooX :: Foo "x" diff --git a/examples/failing/2378/Lib.purs b/examples/failing/2378/Lib.purs new file mode 100644 index 0000000000..8890d660b2 --- /dev/null +++ b/examples/failing/2378/Lib.purs @@ -0,0 +1,3 @@ +module Lib (class Foo) where + +class Foo (a :: Symbol) diff --git a/examples/passing/2378.purs b/examples/passing/2378.purs new file mode 100644 index 0000000000..75ada8ce72 --- /dev/null +++ b/examples/passing/2378.purs @@ -0,0 +1,9 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +class Foo (a :: Symbol) + +instance fooX :: Foo "x" + +main = log "Done" diff --git a/purescript.cabal b/purescript.cabal index 0e903d5c8e..1221ef0546 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -55,6 +55,7 @@ extra-source-files: examples/passing/*.purs , examples/passing/TypeWithoutParens/*.purs , examples/failing/*.purs , examples/failing/1733/*.purs + , examples/failing/2378/*.purs , examples/failing/ConflictingExports/*.purs , examples/failing/ConflictingImports/*.purs , examples/failing/ConflictingImports2/*.purs diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 1fb2cc6294..6ffca1f4ef 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -312,6 +312,7 @@ typeCheckAll moduleName _ = traverse go where checkType :: Type -> Bool checkType (TypeVar _) = False + checkType (TypeLevelString _) = False checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn'' checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance" checkType (TypeApp t1 _) = checkType t1 From b8bb12b5fec663509040413ca39816bab02ddc4c Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 22 Oct 2016 12:36:05 -0700 Subject: [PATCH 0529/1580] Fix #2379, add error message for unknown classes (#2396) * Fix #2379, add error message for unknown classes * Typo, fix cabal file --- examples/failing/2379.purs | 6 ++++++ examples/failing/2379/Lib.purs | 9 +++++++++ purescript.cabal | 1 + src/Language/PureScript/AST/Declarations.hs | 1 + src/Language/PureScript/Errors.hs | 6 ++++++ src/Language/PureScript/TypeChecker/Entailment.hs | 6 ++++-- 6 files changed, 27 insertions(+), 2 deletions(-) create mode 100644 examples/failing/2379.purs create mode 100644 examples/failing/2379/Lib.purs diff --git a/examples/failing/2379.purs b/examples/failing/2379.purs new file mode 100644 index 0000000000..f124dd3a88 --- /dev/null +++ b/examples/failing/2379.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith UnknownClass +module Main where + +import Lib + +test = x [1, 2, 3] diff --git a/examples/failing/2379/Lib.purs b/examples/failing/2379/Lib.purs new file mode 100644 index 0000000000..eb69e862a3 --- /dev/null +++ b/examples/failing/2379/Lib.purs @@ -0,0 +1,9 @@ +module Lib (class X, x) where + +class X a where + x :: a -> String + +class Y a + +instance xArray :: Y a => X (Array a) where + x _ = "[]" diff --git a/purescript.cabal b/purescript.cabal index 1221ef0546..8df7a16a61 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -56,6 +56,7 @@ extra-source-files: examples/passing/*.purs , examples/failing/*.purs , examples/failing/1733/*.purs , examples/failing/2378/*.purs + , examples/failing/2379/*.purs , examples/failing/ConflictingExports/*.purs , examples/failing/ConflictingImports/*.purs , examples/failing/ConflictingImports2/*.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 69256c88ae..867f2e7841 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -83,6 +83,7 @@ data SimpleErrorMessage | ConstrainedTypeUnified Type Type | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident] | NoInstanceFound Constraint + | UnknownClass (Qualified (ProperName 'ClassName)) | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type] | CannotDerive (Qualified (ProperName 'ClassName)) [Type] | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 26139b46d8..bf37c8b1c6 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -118,6 +118,7 @@ errorCode em = case unwrapErrorMessage em of ConstrainedTypeUnified{} -> "ConstrainedTypeUnified" OverlappingInstances{} -> "OverlappingInstances" NoInstanceFound{} -> "NoInstanceFound" + UnknownClass{} -> "UnknownClass" PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance" CannotDerive{} -> "CannotDerive" InvalidNewtypeInstance{} -> "InvalidNewtypeInstance" @@ -599,6 +600,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , line "They may be disallowed completely in a future version of the compiler." ] renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list" + renderSimpleErrorMessage (UnknownClass nm) = + paras [ line "No type class instance was found for class" + , markCodeBox $ indent $ line (showQualified runProperName nm) + , line "because the class was not in scope. Perhaps it was not exported." + ] renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ ty ] _)) | Just box <- toTypelevelString ty = paras [ line "A custom type error occurred while solving type class constraints:" , indent box diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 5c227b6d8a..01f9fab194 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -150,8 +150,10 @@ entails SolverOptions{..} constraint context hints = inferred <- lift get -- We need information about functional dependencies, so we have to look up the class -- name in the environment: - let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup className' - TypeClassData{ typeClassDependencies } <- lift . lift $ gets (findClass . typeClasses . checkEnv) + classesInScope <- lift . lift $ gets (typeClasses . checkEnv) + TypeClassData{ typeClassDependencies } <- case M.lookup className' classesInScope of + Nothing -> throwError . errorMessage $ UnknownClass className' + Just tcd -> pure tcd let instances = [ (substs, tcd) | tcd <- forClassName (combineContexts context inferred) className' tys'' From 0072f2569402b938d35d6d5cbe31cbdb1640f90d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 23 Oct 2016 14:50:16 -0700 Subject: [PATCH 0530/1580] Add paste mode, remove --multi-line option, fix #934 (#2361) --- psci/Main.hs | 51 +++++++++++-------- src/Language/PureScript/Interactive.hs | 2 +- .../PureScript/Interactive/Completion.hs | 1 + .../PureScript/Interactive/Directive.hs | 3 ++ src/Language/PureScript/Interactive/Parser.hs | 1 + src/Language/PureScript/Interactive/Types.hs | 43 +++++----------- 6 files changed, 48 insertions(+), 53 deletions(-) diff --git a/psci/Main.hs b/psci/Main.hs index 9bd309633a..e86f7583c6 100644 --- a/psci/Main.hs +++ b/psci/Main.hs @@ -63,17 +63,10 @@ import System.Process (readProcessWithExitCode) -- | Command line options data PSCiOptions = PSCiOptions - { psciMultiLineMode :: Bool - , psciInputFile :: [FilePath] + { psciInputFile :: [FilePath] , psciBackend :: Backend } -multiLineMode :: Opts.Parser Bool -multiLineMode = Opts.switch $ - Opts.long "multi-line-mode" - <> Opts.short 'm' - <> Opts.help "Run in multi-line mode (use ^D to terminate commands)" - inputFile :: Opts.Parser FilePath inputFile = Opts.strArgument $ Opts.metavar "FILE" @@ -100,8 +93,7 @@ backend = <|> (nodeBackend <$> nodeFlagsFlag) psciOptions :: Opts.Parser PSCiOptions -psciOptions = PSCiOptions <$> multiLineMode - <*> many inputFile +psciOptions = PSCiOptions <$> many inputFile <*> backend version :: Opts.Parser (a -> a) @@ -119,17 +111,20 @@ getOpt = Opts.execParser opts footerInfo = Opts.footer $ "psci " ++ showVersion Paths.version -- | Parses the input and returns either a command, or an error as a 'String'. -getCommand :: forall m. MonadException m => Bool -> InputT m (Either String (Maybe Command)) -getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do - firstLine <- withInterrupt $ getInputLine "> " - case firstLine of +getCommand :: forall m. MonadException m => InputT m (Either String (Maybe Command)) +getCommand = handleInterrupt (return (Right Nothing)) $ do + line <- withInterrupt $ getInputLine "> " + case line of Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty Just "" -> return (Right Nothing) - Just s | singleLineMode || head s == ':' -> return . fmap Just $ parseCommand s - Just s -> fmap Just . parseCommand <$> go [s] + Just s -> return . fmap Just $ parseCommand s + +pasteMode :: forall m. MonadException m => InputT m (Either String Command) +pasteMode = + parseCommand <$> go [] where go :: [String] -> InputT m String - go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " " + go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine "… " -- | Make a JavaScript bundle for the browser. bundle :: IO (Either Bundle.ErrorMessage String) @@ -349,16 +344,28 @@ main = getOpt >>= loop go :: state -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) () go state = do - c <- getCommand (not psciMultiLineMode) + c <- getCommand case c of Left err -> outputStrLn err >> go state Right Nothing -> go state + Right (Just PasteLines) -> do + c' <- pasteMode + case c' of + Left err -> outputStrLn err >> go state + Right c'' -> handleCommandWithInterrupts state c'' Right (Just QuitPSCi) -> do outputStrLn quitMessage liftIO $ shutdown state - Right (Just c') -> do - handleInterrupt (outputStrLn "Interrupted.") - (withInterrupt (lift (handleCommand (liftIO . eval state) (liftIO (reload state)) c'))) - go state + Right (Just c') -> handleCommandWithInterrupts state c' + + handleCommandWithInterrupts + :: state + -> Command + -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) () + handleCommandWithInterrupts state cmd = do + handleInterrupt (outputStrLn "Interrupted.") + (withInterrupt (lift (handleCommand (liftIO . eval state) (liftIO (reload state)) cmd))) + go state + putStrLn prologueMessage setup >>= runner . go diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 49f0a73c33..e9534e3a3e 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -104,7 +104,7 @@ handleCommand _ _ (KindOf typ) = handleKindOf typ handleCommand _ _ (BrowseModule moduleName) = handleBrowse moduleName handleCommand _ _ (ShowInfo QueryLoaded) = handleShowLoadedModules handleCommand _ _ (ShowInfo QueryImport) = handleShowImportedModules -handleCommand _ _ QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug." +handleCommand _ _ _ = P.internalError "handleCommand: unexpected command" -- | Reset the application state handleResetState diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index f08f9fbd0d..5a875c7e71 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -122,6 +122,7 @@ directiveArg _ Browse = [CtxModule] directiveArg _ Quit = [] directiveArg _ Reset = [] directiveArg _ Help = [] +directiveArg _ Paste = [] directiveArg _ Show = map CtxFixed replQueryStrings directiveArg _ Type = [CtxIdentifier] directiveArg _ Kind = [CtxType] diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs index f9d7c6c99b..8f204a3346 100644 --- a/src/Language/PureScript/Interactive/Directive.hs +++ b/src/Language/PureScript/Interactive/Directive.hs @@ -30,6 +30,7 @@ directiveStrings = , (Type , ["type"]) , (Kind , ["kind"]) , (Show , ["show"]) + , (Paste , ["paste"]) ] -- | @@ -82,6 +83,7 @@ hasArgument :: Directive -> Bool hasArgument Help = False hasArgument Quit = False hasArgument Reset = False +hasArgument Paste = False hasArgument _ = True -- | @@ -97,4 +99,5 @@ help = , (Kind, "", "Show the kind of ") , (Show, "import", "Show all imported modules") , (Show, "loaded", "Show all loaded modules") + , (Paste, "paste", "Enter multiple lines, terminated by ^D") ] diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index 86d6606fef..c4397f3821 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -62,6 +62,7 @@ parseDirective cmd = Help -> return ShowHelp Quit -> return QuitPSCi Reset -> return ResetState + Paste -> return PasteLines Browse -> BrowseModule <$> parseRest P.moduleName arg Show -> ShowInfo <$> parseReplQuery' (trim arg) Type -> TypeOf <$> parseRest P.parseValue arg diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index f2449dfb89..61dfe145ea 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -72,46 +72,28 @@ updateLets f st = st { psciLetBindings = f (psciLetBindings st) } -- Valid Meta-commands for PSCI -- data Command - -- | - -- A purescript expression - -- + -- | A purescript expression = Expression P.Expr - -- | - -- Show the help (ie, list of directives) - -- + -- | Show the help (ie, list of directives) | ShowHelp - -- | - -- Import a module from a loaded file - -- + -- | Import a module from a loaded file | Import ImportedModule - -- | - -- Browse a module - -- + -- | Browse a module | BrowseModule P.ModuleName - -- | - -- Exit PSCI - -- + -- | Exit PSCI | QuitPSCi - -- | - -- Reset the state of the REPL - -- + -- | Reset the state of the REPL | ResetState - -- | - -- Add some declarations to the current evaluation context. - -- + -- | Add some declarations to the current evaluation context | Decls [P.Declaration] - -- | - -- Find the type of an expression - -- + -- | Find the type of an expression | TypeOf P.Expr - -- | - -- Find the kind of an expression - -- + -- | Find the kind of an expression | KindOf P.Type - -- | - -- Shows information about the current state of the REPL - -- + -- | Shows information about the current state of the REPL | ShowInfo ReplQuery + -- | Paste multiple lines + | PasteLines data ReplQuery = QueryLoaded @@ -142,4 +124,5 @@ data Directive | Type | Kind | Show + | Paste deriving (Eq, Show) From fe6a70948ff3ecacca82d4c6b927b1f5631f7453 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 23 Oct 2016 15:28:35 -0700 Subject: [PATCH 0531/1580] Derive Data.Generic.Rep.Generic (#2356) * Derive Data.Generic.Rep.Generic * Remove redundant case * Refactor * Fix tests * More refactoring * Basic support for records * Generate fresh names for record fields * Allow multiple record fields * Fix tests --- .../failing/NonWildcardNewtypeInstance.purs | 2 +- examples/passing/GHCGenerics.purs | 140 ------------ examples/passing/GenericsRep.purs | 53 +++++ src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Errors.hs | 6 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 205 +++++++++++++++++- tests/TestUtils.hs | 32 ++- tests/support/bower.json | 3 +- 8 files changed, 281 insertions(+), 162 deletions(-) delete mode 100644 examples/passing/GHCGenerics.purs create mode 100644 examples/passing/GenericsRep.purs diff --git a/examples/failing/NonWildcardNewtypeInstance.purs b/examples/failing/NonWildcardNewtypeInstance.purs index 3c8f947b96..3c1ac5dfce 100644 --- a/examples/failing/NonWildcardNewtypeInstance.purs +++ b/examples/failing/NonWildcardNewtypeInstance.purs @@ -1,4 +1,4 @@ --- @shouldFailWith NonWildcardNewtypeInstance +-- @shouldFailWith ExpectedWildcard module NonWildcardNewtypeInstance where import Data.Newtype diff --git a/examples/passing/GHCGenerics.purs b/examples/passing/GHCGenerics.purs deleted file mode 100644 index d3f0abe34b..0000000000 --- a/examples/passing/GHCGenerics.purs +++ /dev/null @@ -1,140 +0,0 @@ --- An example to show how we could implement GHC-style Generics using --- functional dependencies. --- --- See https://hackage.haskell.org/package/base-4.9.0.0/docs/GHC-Generics.html - -module Main where - -import Prelude -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log, logShow) - --- Representation for types with no constructors -data V1 - --- Representation for constructors with no arguments -data U1 = U1 - --- Representation for sum types -data Sum a b = Inl a | Inr b - -infixr 5 type Sum as + - --- Representation for product types -data Product a b = Product a b - -infixr 6 type Product as * - --- Representation for data constructors, with the data constructor name indicated --- at the type level. -data Ctor (name :: Symbol) a = Ctor a - --- Representation for occurrences of other types in a data type definition. -data K a = K a - --- The Generic class asserts the existence of a type function from "real" types --- to representation types, and an isomorphism between them. -class Generic a repr | a -> repr where - to :: a -> repr - from :: repr -> a - --- We can write an instance for the (recursive) type of lists. Note that these --- instances would be generated by the compiler ideally. -data List a = Nil | Cons a (List a) - -instance genericList :: Generic (List a) (Ctor "Nil" U1 + Ctor "Cons" (K a * K (List a))) where - to Nil = Inl (Ctor U1) - to (Cons x xs) = Inr (Ctor (Product (K x) (K xs))) - from (Inl (Ctor U1)) = Nil - from (Inr (Ctor (Product (K x) (K xs)))) = Cons x xs - --- We'd like to refect type level strings (for data constructor names) at the value --- level, so that we can "show" them. Again, these instances would ideally be derived --- for us. -class KnownSymbol (sym :: Symbol) where - symbol :: forall proxy. proxy sym -> String - -instance knownSymbolNil :: KnownSymbol "Nil" where - symbol _ = "Nil" - -instance knownSymbolCons :: KnownSymbol "Cons" where - symbol _ = "Cons" - --- A proxy for a type-level string. -data SProxy (sym :: Symbol) = SProxy - --- To write generic functions, we create a corresponding type class, and use the --- type class machinery to infer the correct function based on the representation --- type. -class GShow a where - gShow :: a -> String - --- Now provide instances for GShow for the appropriate representation types. --- Note: we don't have to implement all instances here. - -instance gShowU1 :: GShow U1 where - gShow _ = "" - -instance gShowSum :: (GShow a, GShow b) => GShow (a + b) where - gShow (Inl a) = gShow a - gShow (Inr b) = gShow b - -instance gShowProduct :: (GShow a, GShow b) => GShow (a * b) where - gShow (Product a b) = gShow a <> gShow b - -instance gShowCtor :: (KnownSymbol ctor, GShow a) => GShow (Ctor ctor a) where - gShow (Ctor a) = "(" <> symbol (SProxy :: SProxy ctor) <> gShow a <> ")" - -instance gShowK :: Show a => GShow (K a) where - gShow (K a) = " " <> show a - --- Now we can implement a generic show function which uses the GShow instance --- on the representation type. -genericShow :: forall a repr. (Generic a repr, GShow repr) => a -> String -genericShow x = gShow (to x) - --- Note how the required instance here is Show a, and not Generic a. --- This allows us to use generic programming on a wider variety of types --- (including types which contain foreign types) than we can use now. -instance showList :: Show a => Show (List a) where - show xs = genericShow xs -- (we need to eta expand here to avoid stack overflow - -- due to recursion implicit in the instance lookup) - --- Another example: Eq - -class GEq a where - gEq :: a -> a -> Boolean - -instance gEqU1 :: GEq U1 where - gEq _ _ = true - -instance gEqSum :: (GEq a, GEq b) => GEq (a + b) where - gEq (Inl a1) (Inl a2) = gEq a1 a2 - gEq (Inr b1) (Inr b2) = gEq b1 b2 - gEq _ _ = false - -instance gEqProduct :: (GEq a, GEq b) => GEq (a * b) where - gEq (Product a1 b1) (Product a2 b2) = gEq a1 a2 && gEq b1 b2 - -instance gEqCtor :: (KnownSymbol ctor, GEq a) => GEq (Ctor ctor a) where - gEq (Ctor a1) (Ctor a2) = gEq a1 a2 - -instance gEqK :: Eq a => GEq (K a) where - gEq (K a1) (K a2) = a1 == a2 - -genericEq :: forall a repr. (Generic a repr, GEq repr) => a -> a -> Boolean -genericEq x y = gEq (to x) (to y) - -instance eqList :: Eq a => Eq (List a) where - eq xs ys = genericEq xs ys - -main :: Eff (console :: CONSOLE) Unit -main = do - logShow (Cons 1 Nil) - logShow (Cons 1 (Cons 2 Nil)) - logShow (Cons 'x' (Cons 'y' (Cons 'z' Nil))) - - logShow (Cons 1 (Cons 2 Nil) == Cons 1 (Cons 2 Nil)) - logShow (Cons 1 (Cons 2 Nil) == Cons 1 Nil) - - log "Done" diff --git a/examples/passing/GenericsRep.purs b/examples/passing/GenericsRep.purs new file mode 100644 index 0000000000..4f60106c5c --- /dev/null +++ b/examples/passing/GenericsRep.purs @@ -0,0 +1,53 @@ +module Main where + +import Prelude +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log, logShow) +import Data.Generic.Rep (class Generic) +import Data.Generic.Rep.Eq (genericEq) + +data X a = X a + +derive instance genericX :: Generic (X a) _ + +instance eqX :: Eq a => Eq (X a) where + eq xs ys = genericEq xs ys + +data Y a = Y | Z a (Y a) + +derive instance genericY :: Generic (Y a) _ + +instance eqY :: Eq a => Eq (Y a) where + eq xs ys = genericEq xs ys + +data Z + +derive instance genericZ :: Generic Z _ + +instance eqZ :: Eq Z where + eq x y = genericEq x y + +newtype W = W { x :: Int, y :: String } + +derive instance genericW :: Generic W _ + +instance eqW :: Eq W where + eq x y = genericEq x y + +data V = V { x :: Int } { x :: Int } + +derive instance genericV :: Generic V _ + +instance eqV :: Eq V where + eq x y = genericEq x y + +main :: Eff (console :: CONSOLE) Unit +main = do + logShow (X 0 == X 1) + logShow (X 1 == X 1) + logShow (Z 1 Y == Z 1 Y) + logShow (Z 1 Y == Y) + logShow (Y == Y :: Y Z) + logShow (W { x: 0, y: "A" } == W { x: 0, y: "A" }) + logShow (V { x: 0 } { x: 0 } == V { x: 0 } { x: 0 }) + log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 867f2e7841..af43e3620b 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -133,7 +133,7 @@ data SimpleErrorMessage | DeprecatedRequirePath | CannotGeneralizeRecursiveFunction Ident Type | CannotDeriveNewtypeForData (ProperName 'TypeName) - | NonWildcardNewtypeInstance (ProperName 'TypeName) + | ExpectedWildcard (ProperName 'TypeName) deriving (Show) -- | Error message hints, providing more detailed information about failure. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index bf37c8b1c6..570569e3a4 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -168,7 +168,7 @@ errorCode em = case unwrapErrorMessage em of DeprecatedRequirePath{} -> "DeprecatedRequirePath" CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction" CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData" - NonWildcardNewtypeInstance{} -> "NonWildcardNewtypeInstance" + ExpectedWildcard{} -> "ExpectedWildcard" -- | -- A stack trace for an error @@ -865,8 +865,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS paras [ line $ "Cannot derive an instance of the " ++ markCode "Newtype" ++ " class for non-newtype " ++ markCode (runProperName tyName) ++ "." ] - renderSimpleErrorMessage (NonWildcardNewtypeInstance tyName) = - paras [ line $ "A type wildcard (_) should be used for the inner type when deriving the " ++ markCode "Newtype" ++ " instance for " ++ markCode (runProperName tyName) ++ "." + renderSimpleErrorMessage (ExpectedWildcard tyName) = + paras [ line $ "Expected a type wildcard (_) when deriving an instance for " ++ markCode (runProperName tyName) ++ "." ] renderHint :: ErrorMessageHint -> Box.Box -> Box.Box diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index a83346513a..95dab223e8 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -13,7 +13,7 @@ import Control.Monad (replicateM) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class (MonadSupply) -import Data.List (foldl', find, sortBy) +import Data.List (foldl', find, sortBy, unzip5) import Data.Maybe (fromMaybe) import Data.Ord (comparing) @@ -58,9 +58,14 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwr | className == Qualified (Just dataNewtype) (ProperName "Newtype") , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy , mn == fromMaybe mn mn' - = do - (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy - return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) + = do (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy + return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) +deriveInstance mn ds (TypeInstanceDeclaration nm deps className [actualTy, repTy] DerivedInstance) + | className == Qualified (Just dataGenericRep) (ProperName C.generic) + , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy + , mn == fromMaybe mn mn' + = do (inst, inferredRepTy) <- deriveGenericRep mn ds tyCon args repTy + return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) = throwError . errorMessage $ CannotDerive className tys deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance) @@ -122,6 +127,9 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do dataGeneric :: ModuleName dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] +dataGenericRep :: ModuleName +dataGenericRep = ModuleName [ ProperName "Data", ProperName "Generic", ProperName "Rep" ] + dataMaybe :: ModuleName dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ] @@ -304,6 +312,187 @@ deriveGeneric mn ds tyConNm dargs = do mkGenVar :: Ident -> Expr mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) +deriveGenericRep + :: forall m + . (MonadError MultipleErrors m, MonadSupply m) + => ModuleName + -> [Declaration] + -> ProperName 'TypeName + -> [Type] + -> Type + -> m ([Declaration], Type) +deriveGenericRep mn ds tyConNm tyConArgs repTy = do + checkIsWildcard tyConNm repTy + go =<< findTypeDecl tyConNm ds + where + go :: Declaration -> m ([Declaration], Type) + go (DataDeclaration _ _ args dctors) = do + x <- freshIdent "x" + (reps, to, from) <- unzip3 <$> traverse makeInst dctors + let rep = toRepTy reps + inst | null reps = + -- If there are no cases, spin + [ ValueDeclaration (Ident "to") Public [] $ Right $ + lamCase x [ CaseAlternative [NullBinder] + (Right (App toName (Var (Qualified Nothing x)))) + ] + , ValueDeclaration (Ident "from") Public [] $ Right $ + lamCase x [ CaseAlternative [NullBinder] + (Right (App fromName (Var (Qualified Nothing x)))) + ] + ] + | otherwise = + [ ValueDeclaration (Ident "to") Public [] $ Right $ + lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to) + , ValueDeclaration (Ident "from") Public [] $ Right $ + lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from) + ] + + subst = zipWith ((,) . fst) args tyConArgs + return (inst, replaceAllTypeVars subst rep) + go (PositionedDeclaration _ _ d) = go d + go _ = internalError "deriveGenericRep go: expected DataDeclaration" + + select :: (a -> a) -> (a -> a) -> Int -> [a -> a] + select _ _ 0 = [] + select _ _ 1 = [id] + select l r n = take (n - 1) (iterate (r .) l) ++ [compN (n - 1) r] + + sumBinders :: Int -> [Binder -> Binder] + sumBinders = select (ConstructorBinder inl . pure) (ConstructorBinder inr . pure) + + sumExprs :: Int -> [Expr -> Expr] + sumExprs = select (App (Constructor inl)) (App (Constructor inr)) + + compN :: Int -> (a -> a) -> a -> a + compN 0 _ = id + compN n f = f . compN (n - 1) f + + makeInst + :: (ProperName 'ConstructorName, [Type]) + -> m (Type, CaseAlternative, CaseAlternative) + makeInst (ctorName, args) = do + (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args + return ( TypeApp (TypeApp (TypeConstructor constructor) + (TypeLevelString (runProperName ctorName))) + ctorTy + , CaseAlternative [ ConstructorBinder constructor [matchProduct] ] + (Right (foldl App (Constructor (Qualified (Just mn) ctorName)) ctorArgs)) + , CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) matchCtor ] + (Right (constructor' mkProduct)) + ) + + makeProduct + :: [Type] + -> m (Type, Binder, [Expr], [Binder], Expr) + makeProduct [] = + pure (noArgs, NullBinder, [], [], noArgs') + makeProduct args = do + (tys, bs1, es1, bs2, es2) <- unzip5 <$> traverse makeArg args + pure ( foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) tys + , foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2]) bs1 + , es1 + , bs2 + , foldr1 (\e1 -> App (App (Constructor productName) e1)) es2 + ) + + makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr) + makeArg arg | Just rec <- objectType arg = do + let fields = decomposeRec rec + fieldNames <- traverse freshIdent (map fst fields) + pure ( TypeApp (TypeConstructor record) + (foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) + (map (\(name, ty) -> + TypeApp (TypeApp (TypeConstructor field) (TypeLevelString name)) ty) fields)) + , ConstructorBinder record + [ foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2]) + (map (\ident -> ConstructorBinder field [VarBinder ident]) fieldNames) + ] + , Literal . ObjectLiteral $ + zipWith (\(name, _) ident -> (name, Var (Qualified Nothing ident))) fields fieldNames + , LiteralBinder . ObjectLiteral $ + zipWith (\(name, _) ident -> (name, VarBinder ident)) fields fieldNames + , record' $ + foldr1 (\e1 -> App (App (Constructor productName) e1)) + (map (field' . Var . Qualified Nothing) fieldNames) + ) + makeArg arg = do + argName <- freshIdent "arg" + pure ( TypeApp (TypeConstructor argument) arg + , ConstructorBinder argument [ VarBinder argName ] + , Var (Qualified Nothing argName) + , VarBinder argName + , argument' (Var (Qualified Nothing argName)) + ) + + underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative + underBinder f (CaseAlternative bs e) = CaseAlternative (map f bs) e + + underExpr :: (Expr -> Expr) -> CaseAlternative -> CaseAlternative + underExpr f (CaseAlternative b (Right e)) = CaseAlternative b (Right (f e)) + underExpr _ _ = internalError "underExpr: expected Right" + + toRepTy :: [Type] -> Type + toRepTy [] = noCtors + toRepTy [only] = only + toRepTy ctors = foldr1 (\f -> TypeApp (TypeApp sumCtor f)) ctors + + toName :: Expr + toName = Var (Qualified (Just dataGenericRep) (Ident "to")) + + fromName :: Expr + fromName = Var (Qualified (Just dataGenericRep) (Ident "from")) + + noCtors :: Type + noCtors = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoConstructors")) + + noArgs :: Type + noArgs = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoArguments")) + + noArgs' :: Expr + noArgs' = Constructor (Qualified (Just dataGenericRep) (ProperName "NoArguments")) + + sumCtor :: Type + sumCtor = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "Sum")) + + inl :: Qualified (ProperName 'ConstructorName) + inl = Qualified (Just dataGenericRep) (ProperName "Inl") + + inr :: Qualified (ProperName 'ConstructorName) + inr = Qualified (Just dataGenericRep) (ProperName "Inr") + + productName :: Qualified (ProperName ty) + productName = Qualified (Just dataGenericRep) (ProperName "Product") + + constructor :: Qualified (ProperName ty) + constructor = Qualified (Just dataGenericRep) (ProperName "Constructor") + + constructor' :: Expr -> Expr + constructor' = App (Constructor constructor) + + argument :: Qualified (ProperName ty) + argument = Qualified (Just dataGenericRep) (ProperName "Argument") + + argument' :: Expr -> Expr + argument' = App (Constructor argument) + + record :: Qualified (ProperName ty) + record = Qualified (Just dataGenericRep) (ProperName "Rec") + + record' :: Expr -> Expr + record' = App (Constructor record) + + field :: Qualified (ProperName ty) + field = Qualified (Just dataGenericRep) (ProperName "Field") + + field' :: Expr -> Expr + field' = App (Constructor field) + +checkIsWildcard :: MonadError MultipleErrors m => ProperName 'TypeName -> Type -> m () +checkIsWildcard _ (TypeWildcard _) = return () +checkIsWildcard tyConNm _ = + throwError . errorMessage $ ExpectedWildcard tyConNm + deriveEq :: forall m. (MonadError MultipleErrors m, MonadSupply m) => ModuleName @@ -451,7 +640,7 @@ deriveNewtype -> Type -> m ([Declaration], Type) deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do - checkIsWildcard unwrappedTy + checkIsWildcard tyConNm unwrappedTy go =<< findTypeDecl tyConNm ds where go :: Declaration -> m ([Declaration], Type) @@ -477,12 +666,6 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do go (PositionedDeclaration _ _ d) = go d go _ = internalError "deriveNewtype go: expected DataDeclaration" - checkIsWildcard :: Type -> m () - checkIsWildcard (TypeWildcard _) = - return () - checkIsWildcard _ = - throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm - findTypeDecl :: (MonadError MultipleErrors m) => ProperName 'TypeName diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index f1a252215d..6c8e09909b 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -53,16 +53,24 @@ updateSupportCode = do -- supportModules :: [String] supportModules = - [ "Control.Applicative" + [ "Control.Alt" + , "Control.Alternative" + , "Control.Applicative" , "Control.Apply" , "Control.Bind" , "Control.Category" + , "Control.Comonad" + , "Control.Extend" + , "Control.Lazy" + , "Control.Monad" + , "Control.Monad.Eff" , "Control.Monad.Eff.Class" , "Control.Monad.Eff.Console" , "Control.Monad.Eff.Unsafe" - , "Control.Monad.Eff" , "Control.Monad.ST" - , "Control.Monad" + , "Control.MonadPlus" + , "Control.MonadZero" + , "Control.Plus" , "Control.Semigroupoid" , "Data.Boolean" , "Data.BooleanAlgebra" @@ -71,14 +79,27 @@ supportModules = , "Data.Eq" , "Data.EuclideanRing" , "Data.Field" - , "Data.Function.Uncurried" , "Data.Function" + , "Data.Function.Uncurried" , "Data.Functor" + , "Data.Functor.Invariant" + , "Data.Generic.Rep" + , "Data.Generic.Rep.Monoid" + , "Data.Generic.Rep.Eq" + , "Data.Generic.Rep.Ord" + , "Data.Generic.Rep.Semigroup" , "Data.HeytingAlgebra" + , "Data.Monoid" + , "Data.Monoid.Additive" + , "Data.Monoid.Conj" + , "Data.Monoid.Disj" + , "Data.Monoid.Dual" + , "Data.Monoid.Endo" + , "Data.Monoid.Multiplicative" , "Data.NaturalTransformation" , "Data.Newtype" - , "Data.Ord.Unsafe" , "Data.Ord" + , "Data.Ord.Unsafe" , "Data.Ordering" , "Data.Ring" , "Data.Semigroup" @@ -90,6 +111,7 @@ supportModules = , "Partial.Unsafe" , "Prelude" , "Test.Assert" + , "Test.Main" ] pushd :: forall a. FilePath -> IO a -> IO a diff --git a/tests/support/bower.json b/tests/support/bower.json index 7bbaebd6dd..d2f01dd85a 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -8,6 +8,7 @@ "purescript-prelude": "1.1.0", "purescript-st": "1.0.0-rc.1", "purescript-partial": "1.1.2", - "purescript-newtype": "0.1.0" + "purescript-newtype": "0.1.0", + "purescript-generics-rep": "2.0.0" } } From b2526f5e83edfc6b5d3d546525040cb22cd58fd3 Mon Sep 17 00:00:00 2001 From: Brandon Hamilton Date: Mon, 24 Oct 2016 23:18:10 +0200 Subject: [PATCH 0532/1580] Fix inliner for integer bitwise operators --- .../PureScript/CodeGen/JS/Optimizer/Inliner.hs | 6 +++--- src/Language/PureScript/Constants.hs | 12 ++++++------ 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index 1c873eb6b3..ff8c7c366f 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -150,9 +150,9 @@ inlineCommonOperators = applyAll $ , binary heytingAlgebraBoolean opDisj Or , unary heytingAlgebraBoolean opNot Not - , binary' C.dataIntBits (C..|.) BitwiseOr - , binary' C.dataIntBits (C..&.) BitwiseAnd - , binary' C.dataIntBits (C..^.) BitwiseXor + , binary' C.dataIntBits C.or BitwiseOr + , binary' C.dataIntBits C.and BitwiseAnd + , binary' C.dataIntBits C.xor BitwiseXor , binary' C.dataIntBits C.shl ShiftLeft , binary' C.dataIntBits C.shr ShiftRight , binary' C.dataIntBits C.zshr ZeroFillShiftRight diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index f254af5dbb..8f607b9fd2 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -118,14 +118,14 @@ disj = "disj" unsafeIndex :: String unsafeIndex = "unsafeIndex" -(.|.) :: String -(.|.) = ".|." +or :: String +or = "or" -(.&.) :: String -(.&.) = ".&." +and :: String +and = "and" -(.^.) :: String -(.^.) = ".^." +xor :: String +xor = "xor" (<<<) :: String (<<<) = "<<<" From c144a392266d1c9269306933f9b32b405581e001 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Thu, 3 Nov 2016 22:56:06 +0100 Subject: [PATCH 0533/1580] Speeds up parsing by reading files as Text This doesn't change anything inside the parsed AST, it just changes the initial file read to use Text. Also be more consistent about writing and reading files with UTF8 in psc-ide --- hierarchy/Main.hs | 4 +- psc-docs/Main.hs | 7 +-- psc/Main.hs | 7 +-- purescript.cabal | 5 +- .../PureScript/Docs/ParseAndBookmark.hs | 13 +++--- src/Language/PureScript/Ide/Imports.hs | 10 ++-- src/Language/PureScript/Ide/Rebuild.hs | 4 +- src/Language/PureScript/Ide/SourceFile.hs | 6 +-- src/Language/PureScript/Interactive/Module.hs | 6 +-- .../PureScript/Parser/Declarations.hs | 7 +-- src/Language/PureScript/Parser/Lexer.hs | 46 +++++++++++-------- src/System/IO/UTF8.hs | 14 +++++- .../PureScript/Ide/Imports/IntegrationSpec.hs | 4 +- tests/TestCompiler.hs | 5 +- 14 files changed, 81 insertions(+), 57 deletions(-) diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs index d40e661b95..291d4a3c2f 100644 --- a/hierarchy/Main.hs +++ b/hierarchy/Main.hs @@ -33,7 +33,7 @@ import System.FilePath (()) import System.FilePath.Glob (glob) import System.Exit (exitFailure, exitSuccess) import System.IO (hPutStr, stderr) -import System.IO.UTF8 (readUTF8File) +import System.IO.UTF8 (readUTF8FileT) import qualified Language.PureScript as P import qualified Paths_purescript as Paths @@ -60,7 +60,7 @@ runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns) readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module]) readInput paths = do - content <- mapM (\path -> (path, ) <$> readUTF8File path) paths + content <- mapM (\path -> (path, ) <$> readUTF8FileT path) paths return $ map snd <$> P.parseModulesFromFiles id content compile :: HierarchyOptions -> IO () diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index 63d0f31180..9daabcfb72 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -7,6 +7,7 @@ import Control.Monad.Trans.Except (runExceptT) import Control.Arrow (first, second) import Control.Category ((>>>)) import Control.Monad.Writer +import Data.Text (Text) import Data.Function (on) import Data.List import Data.Maybe (fromMaybe) @@ -20,7 +21,7 @@ import qualified Language.PureScript as P import qualified Paths_purescript as Paths import System.Exit (exitFailure) import System.IO (hPutStrLn, hPrint, hSetEncoding, stderr, stdout, utf8) -import System.IO.UTF8 (readUTF8File) +import System.IO.UTF8 (readUTF8FileT) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) import System.FilePath.Glob (glob) @@ -139,8 +140,8 @@ dumpTags input renderTags = do ldump :: [String] -> IO () ldump = mapM_ putStrLn -parseFile :: FilePath -> IO (FilePath, String) -parseFile input = (,) input <$> readUTF8File input +parseFile :: FilePath -> IO (FilePath, Text) +parseFile input = (,) input <$> readUTF8FileT input inputFile :: Parser FilePath inputFile = strArgument $ diff --git a/psc/Main.hs b/psc/Main.hs index 47ae898fe3..be42b3f8fe 100644 --- a/psc/Main.hs +++ b/psc/Main.hs @@ -15,6 +15,7 @@ import Data.Bool (bool) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.UTF8 as BU8 import qualified Data.Map as M +import Data.Text (Text) import Data.Version (showVersion) import qualified Language.PureScript as P @@ -29,7 +30,7 @@ import qualified System.Console.ANSI as ANSI import System.Exit (exitSuccess, exitFailure) import System.FilePath.Glob (glob) import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8) -import System.IO.UTF8 +import System.IO.UTF8 (readUTF8FileT) data PSCMakeOptions = PSCMakeOptions { pscmInput :: [FilePath] @@ -85,8 +86,8 @@ globWarningOnMisses warn = concatMapM globWithWarning return paths concatMapM f = fmap concat . mapM f -readInput :: [FilePath] -> IO [(FilePath, String)] -readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8File inFile +readInput :: [FilePath] -> IO [(FilePath, Text)] +readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8FileT inFile inputFile :: Parser FilePath inputFile = strArgument $ diff --git a/purescript.cabal b/purescript.cabal index 8df7a16a61..a4bf123977 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -334,6 +334,7 @@ executable psc mtl -any, optparse-applicative >= 0.12.1, parsec -any, + text -any, time -any, transformers -any, transformers-compat -any, @@ -387,6 +388,7 @@ executable psc-docs optparse-applicative >= 0.12.1, process -any, split -any, + text -any, transformers -any, transformers-compat -any main-is: Main.hs @@ -419,7 +421,8 @@ executable psc-hierarchy mtl -any, optparse-applicative >= 0.12.1, parsec -any, - process -any + process -any, + text -any main-is: Main.hs other-modules: Paths_purescript buildable: True diff --git a/src/Language/PureScript/Docs/ParseAndBookmark.hs b/src/Language/PureScript/Docs/ParseAndBookmark.hs index b87fb411fd..c45da0185b 100644 --- a/src/Language/PureScript/Docs/ParseAndBookmark.hs +++ b/src/Language/PureScript/Docs/ParseAndBookmark.hs @@ -9,13 +9,12 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import qualified Data.Map as M +import Data.Text (Text) import Language.PureScript.Docs.Convert (collectBookmarks) import Language.PureScript.Docs.Types import qualified Language.PureScript as P - -import System.IO.UTF8 (readUTF8File) - +import System.IO.UTF8 (readUTF8FileT) import Web.Bower.PackageMeta (PackageName) -- | @@ -45,7 +44,7 @@ parseAndBookmark inputFiles depsFiles = do parseFiles :: (MonadError P.MultipleErrors m) => - [(FileInfo, FilePath)] + [(FileInfo, Text)] -> m [(FileInfo, P.Module)] parseFiles = throwLeft . P.parseModulesFromFiles fileInfoToString @@ -77,10 +76,10 @@ fileInfoToString :: FileInfo -> FilePath fileInfoToString (Local fn) = fn fileInfoToString (FromDep _ fn) = fn -parseFile :: FilePath -> IO (FilePath, String) -parseFile input' = (,) input' <$> readUTF8File input' +parseFile :: FilePath -> IO (FilePath, Text) +parseFile input' = (,) input' <$> readUTF8FileT input' -parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String) +parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, Text) parseAs g = fmap (first g) . liftIO . parseFile getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index dae6a2649d..90e29097c0 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -34,7 +34,6 @@ import Protolude import Control.Lens ((^.)) import Data.List (findIndex, nubBy) import qualified Data.Text as T -import qualified Data.Text.IO as TIO import qualified Language.PureScript as P import Language.PureScript.Ide.Completion import Language.PureScript.Ide.Error @@ -42,6 +41,7 @@ import Language.PureScript.Ide.Filter import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT) data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) deriving (Eq, Show) @@ -72,7 +72,7 @@ compImport (Import n i q) (Import n' i' q') parseImportsFromFile :: (MonadIO m, MonadError PscIdeError m) => FilePath -> m (P.ModuleName, [Text], [Import], [Text]) parseImportsFromFile fp = do - file <- liftIO (TIO.readFile fp) + file <- liftIO (readUTF8FileT fp) case sliceImportSection (T.lines file) of Right res -> pure res Left err -> throwError (GeneralError err) @@ -322,10 +322,10 @@ prettyPrintImportSection imports = map prettyPrintImport' (sort imports) answerRequest :: (MonadIO m) => Maybe FilePath -> [Text] -> m Success answerRequest outfp rs = case outfp of - Nothing -> pure $ MultilineTextResult rs + Nothing -> pure (MultilineTextResult rs) Just outfp' -> do - liftIO $ TIO.writeFile outfp' (T.unlines rs) - pure $ TextResult $ "Written to " <> T.pack outfp' + liftIO (writeUTF8FileT outfp' (T.unlines rs)) + pure (TextResult ("Written to " <> T.pack outfp')) -- | Test and ghci helper parseImport :: Text -> Maybe Import diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 98422062c1..a50646c87f 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -21,7 +21,7 @@ import Language.PureScript.Ide.Error import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import System.IO.UTF8 (readUTF8File) +import System.IO.UTF8 (readUTF8FileT) -- | Given a filepath performs the following steps: -- @@ -44,7 +44,7 @@ rebuildFile -> m Success rebuildFile path = do - input <- liftIO (readUTF8File path) + input <- liftIO (readUTF8FileT path) m <- case snd <$> P.parseModuleFromFile identity (path, input) of Left parseError -> throwError diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 7152b7015b..141e0110d1 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -30,14 +30,14 @@ import qualified Language.PureScript as P import Language.PureScript.Ide.Error import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import System.IO.UTF8 (readUTF8File) +import System.IO.UTF8 (readUTF8FileT) parseModule :: (MonadIO m) => FilePath - -> m (Either FilePath (FilePath, P.Module) ) + -> m (Either FilePath (FilePath, P.Module)) parseModule path = do - contents <- liftIO (readUTF8File path) + contents <- liftIO (readUTF8FileT path) case P.parseModuleFromFile identity (path, contents) of Left _ -> pure (Left path) Right m -> pure (Right m) diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index b8a61db61a..3b53646747 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -6,7 +6,7 @@ import Control.Monad import qualified Language.PureScript as P import Language.PureScript.Interactive.Types import System.FilePath (pathSeparator) -import System.IO.UTF8 (readUTF8File) +import System.IO.UTF8 (readUTF8FileT) -- * Support Module @@ -25,7 +25,7 @@ supportModuleIsDefined = any ((== supportModuleName) . P.getModuleName) -- loadModule :: FilePath -> IO (Either String [P.Module]) loadModule filename = do - content <- readUTF8File filename + content <- readUTF8FileT filename return $ either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)] -- | @@ -34,7 +34,7 @@ loadModule filename = do loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)]) loadAllModules files = do filesAndContent <- forM files $ \filename -> do - content <- readUTF8File filename + content <- readUTF8FileT filename return (filename, content) return $ P.parseModulesFromFiles id filesAndContent diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 6433762bfb..4b505b33b8 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -19,6 +19,7 @@ import Prelude hiding (lex) import Data.Functor (($>)) import Data.Maybe (fromMaybe) +import Data.Text (Text) import Control.Applicative import Control.Arrow ((+++)) @@ -281,7 +282,7 @@ parseModulesFromFiles :: forall m k . MonadError MultipleErrors m => (k -> FilePath) - -> [(k, String)] + -> [(k, Text)] -> m [(k, Module)] parseModulesFromFiles toFilePath input = flip parU wrapError . inParallel . flip map input $ parseModuleFromFile toFilePath @@ -298,11 +299,11 @@ parseModulesFromFiles toFilePath input = -- | Parses a single module with FilePath for eventual parsing errors parseModuleFromFile :: (k -> FilePath) - -> (k, String) + -> (k, Text) -> Either P.ParseError (k, Module) parseModuleFromFile toFilePath (k, content) = do let filename = toFilePath k - ts <- lex filename content + ts <- lex' filename content m <- runTokenParser filename parseModule ts pure (k, m) diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 392ab70230..286bb73026 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -6,6 +6,7 @@ module Language.PureScript.Parser.Lexer , Token() , TokenParser() , lex + , lex' , anyToken , token , match @@ -69,6 +70,8 @@ import Control.Monad (void, guard) import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum) import Data.Functor.Identity +import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.Comments import Language.PureScript.Parser.State @@ -154,8 +157,13 @@ data PositionedToken = PositionedToken instance Show PositionedToken where show = prettyPrintToken . ptToken +type Lexer u a = P.Parsec Text u a + lex :: FilePath -> String -> Either P.ParseError [PositionedToken] -lex f s = updatePositions <$> P.parse parseTokens f s +lex fp = lex' fp . T.pack + +lex' :: FilePath -> Text -> Either P.ParseError [PositionedToken] +lex' f s = updatePositions <$> P.parse parseTokens f s updatePositions :: [PositionedToken] -> [PositionedToken] updatePositions [] = [] @@ -163,22 +171,22 @@ updatePositions (x:xs) = x : zipWith update (x:xs) xs where update PositionedToken { ptEndPos = pos } pt = pt { ptPrevEndPos = Just pos } -parseTokens :: P.Parsec String u [PositionedToken] +parseTokens :: Lexer u [PositionedToken] parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof -whitespace :: P.Parsec String u () +whitespace :: Lexer u () whitespace = P.skipMany (P.satisfy isSpace) -parseComment :: P.Parsec String u Comment +parseComment :: Lexer u Comment parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace where - blockComment :: P.Parsec String u String + blockComment :: Lexer u String blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}")) - lineComment :: P.Parsec String u String + lineComment :: Lexer u String lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof)) -parsePositionedToken :: P.Parsec String u PositionedToken +parsePositionedToken :: Lexer u PositionedToken parsePositionedToken = P.try $ do comments <- P.many parseComment pos <- P.getPosition @@ -187,7 +195,7 @@ parsePositionedToken = P.try $ do whitespace return $ PositionedToken pos pos' Nothing tok comments -parseToken :: P.Parsec String u Token +parseToken :: Lexer u Token parseToken = P.choice [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow , P.try $ P.string "←" *> P.notFollowedBy symbolChar *> pure LArrow @@ -226,34 +234,34 @@ parseToken = P.choice ] where - parseLName :: P.Parsec String u String + parseLName :: Lexer u String parseLName = (:) <$> identStart <*> P.many identLetter - parseUName :: P.Parsec String u String + parseUName :: Lexer u String parseUName = (:) <$> P.upper <*> P.many identLetter - parseSymbol :: P.Parsec String u String + parseSymbol :: Lexer u String parseSymbol = P.many1 symbolChar - identStart :: P.Parsec String u Char + identStart :: Lexer u Char identStart = P.lower <|> P.oneOf "_" - identLetter :: P.Parsec String u Char + identLetter :: Lexer u Char identLetter = P.alphaNum <|> P.oneOf "_'" - symbolChar :: P.Parsec String u Char + symbolChar :: Lexer u Char symbolChar = P.satisfy isSymbolChar - parseCharLiteral :: P.Parsec String u Char + parseCharLiteral :: Lexer u Char parseCharLiteral = PT.charLiteral tokenParser - parseStringLiteral :: P.Parsec String u String + parseStringLiteral :: Lexer u String parseStringLiteral = blockString <|> PT.stringLiteral tokenParser where delimiter = P.try (P.string "\"\"\"") blockString = delimiter >> P.manyTill P.anyChar delimiter - parseNumber :: P.Parsec String u (Either Integer Double) + parseNumber :: Lexer u (Either Integer Double) parseNumber = (consumeLeadingZero >> P.parserZero) <|> (Right <$> P.try (PT.float tokenParser) <|> Left <$> P.try (PT.natural tokenParser)) @@ -267,7 +275,7 @@ parseToken = P.choice -- | -- We use Text.Parsec.Token to implement the string and number lexemes -- -langDef :: PT.GenLanguageDef String u Identity +langDef :: PT.GenLanguageDef Text u Identity langDef = PT.LanguageDef { PT.reservedNames = [] , PT.reservedOpNames = [] @@ -285,7 +293,7 @@ langDef = PT.LanguageDef -- | -- A token parser based on the language definition -- -tokenParser :: PT.GenTokenParser String u Identity +tokenParser :: PT.GenTokenParser Text u Identity tokenParser = PT.makeTokenParser langDef type TokenParser a = P.Parsec [PositionedToken] ParseState a diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs index a69dded993..ec5088e2b9 100644 --- a/src/System/IO/UTF8.hs +++ b/src/System/IO/UTF8.hs @@ -4,11 +4,21 @@ import Prelude.Compat import qualified Data.ByteString as BS import qualified Data.ByteString.UTF8 as UTF8 +import Data.Text (Text) +import qualified Data.Text.Encoding as TE + +readUTF8FileT :: FilePath -> IO Text +readUTF8FileT inFile = + fmap TE.decodeUtf8 (BS.readFile inFile) + +writeUTF8FileT :: FilePath -> Text -> IO () +writeUTF8FileT inFile text = + BS.writeFile inFile (TE.encodeUtf8 text) readUTF8File :: FilePath -> IO String -readUTF8File inFile = do +readUTF8File inFile = fmap UTF8.toString (BS.readFile inFile) writeUTF8File :: FilePath -> String -> IO () -writeUTF8File inFile text = do +writeUTF8File inFile text = BS.writeFile inFile (UTF8.fromString text) diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs index 1d7abbbcbb..bc55786dd4 100644 --- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs +++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs @@ -6,12 +6,12 @@ module Language.PureScript.Ide.Imports.IntegrationSpec where import Protolude import qualified Data.Text as T -import qualified Data.Text.IO as TIO import qualified Language.PureScript.Ide.Integration as Integration import Test.Hspec import System.Directory import System.FilePath +import System.IO.UTF8 (readUTF8FileT) setup :: IO () setup = void (Integration.reset *> Integration.loadAll) @@ -27,7 +27,7 @@ withSupportFiles test = do outputFileShouldBe :: [Text] -> IO () outputFileShouldBe expectation = do outFp <- ( "src" "ImportsSpecOut.tmp") <$> Integration.projectDirectory - outRes <- TIO.readFile outFp + outRes <- readUTF8FileT outFp shouldBe (T.lines outRes) expectation spec :: Spec diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 019b428b49..a11babef3c 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -31,6 +31,7 @@ import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy) import Data.Maybe (mapMaybe) import Data.Time.Clock (UTCTime()) import Data.Tuple (swap) +import qualified Data.Text as T import qualified Data.Map as M @@ -71,7 +72,7 @@ spec = do supportPurs <- supportFiles "purs" supportPursFiles <- readInput supportPurs supportExterns <- runExceptT $ do - modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles + modules <- ExceptT . return $ P.parseModulesFromFiles id (map (fmap T.pack) supportPursFiles) foreigns <- inferForeignModules modules externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules) return (zip (map snd modules) externs) @@ -194,7 +195,7 @@ compile -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) compile supportExterns inputFiles check = silence $ runTest $ do fs <- liftIO $ readInput inputFiles - ms <- P.parseModulesFromFiles id fs + ms <- P.parseModulesFromFiles id (map (fmap T.pack) fs) foreigns <- inferForeignModules ms liftIO (check (map snd ms)) let actions = makeActions foreigns From 5ed9384bed7a645b500c24550b415f5499bdb0ee Mon Sep 17 00:00:00 2001 From: bbqbaron Date: Mon, 7 Nov 2016 09:52:34 -0500 Subject: [PATCH 0534/1580] 2374: Add error message for ambiguous type variables in inferred contexts (#2410) * 2374: Add error message for ambiguous type variables in inferred contexts * 2323 add contribution entry. remove Ident from AmbiguousTypeVariables since it's redundant with the enclosing compiler error's ident * 2323 update error message * 2374 multiline error message and print type, not type atom --- CONTRIBUTORS.md | 1 + examples/failing/ConstraintFailure.purs | 13 +++++++++++++ examples/failing/ConstraintInference.purs | 2 +- src/Language/PureScript/AST/Declarations.hs | 1 + src/Language/PureScript/Errors.hs | 7 +++++++ src/Language/PureScript/TypeChecker/Types.hs | 2 +- 6 files changed, 24 insertions(+), 2 deletions(-) create mode 100644 examples/failing/ConstraintFailure.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index dd6943f7db..ae69642538 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -83,6 +83,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@brandonhamilton](https://github.com/brandonhamilton) (Brandon Hamilton) My existing contributions and all future contributions until further notice are Copyright Brandon Hamilton, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@bbqbaron](https://github.com/bbqbaron) (Eric Loren) My existing contributions and all future contributions until further notice are Copyright Eric Loren, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/examples/failing/ConstraintFailure.purs b/examples/failing/ConstraintFailure.purs new file mode 100644 index 0000000000..b24cb58d36 --- /dev/null +++ b/examples/failing/ConstraintFailure.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith NoInstanceFound + +module Main where + +import Prelude + +data Foo = Bar + +spin :: forall a. a -> Foo +spin x = Bar + +main = show <<< spin + diff --git a/examples/failing/ConstraintInference.purs b/examples/failing/ConstraintInference.purs index f451fa0712..ef68dbb1a3 100644 --- a/examples/failing/ConstraintInference.purs +++ b/examples/failing/ConstraintInference.purs @@ -1,4 +1,4 @@ --- @shouldFailWith NoInstanceFound +-- @shouldFailWith AmbiguousTypeVariables module Main where diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index af43e3620b..512572c68b 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -83,6 +83,7 @@ data SimpleErrorMessage | ConstrainedTypeUnified Type Type | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident] | NoInstanceFound Constraint + | AmbiguousTypeVariables Type Constraint | UnknownClass (Qualified (ProperName 'ClassName)) | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type] | CannotDerive (Qualified (ProperName 'ClassName)) [Type] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 570569e3a4..60bba56739 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -118,6 +118,7 @@ errorCode em = case unwrapErrorMessage em of ConstrainedTypeUnified{} -> "ConstrainedTypeUnified" OverlappingInstances{} -> "OverlappingInstances" NoInstanceFound{} -> "NoInstanceFound" + AmbiguousTypeVariables{} -> "AmbiguousTypeVariables" UnknownClass{} -> "UnknownClass" PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance" CannotDerive{} -> "CannotDerive" @@ -261,6 +262,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con + gSimple (AmbiguousTypeVariables t con) = AmbiguousTypeVariables <$> (f t) <*> pure con gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts @@ -636,6 +638,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS where go TUnknown{} = True go _ = False + renderSimpleErrorMessage (AmbiguousTypeVariables t _) = + paras [ line "The inferred type" + , indent $ line $ markCode $ prettyPrintType t + , line "has type variables which are not mentioned in the body of the type. Consider adding a type annotation." + ] renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) = paras [ line "Type class instance for" , markCodeBox $ indent $ Box.hsep 1 Box.left diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 0e87db1d0e..5989c26401 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -111,7 +111,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies let constraintTypeVars = nub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..] when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ do - throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ NoInstanceFound con + throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ AmbiguousTypeVariables generalized con -- Check skolem variables did not escape their scope skolemEscapeCheck val' From 854069c5e5ebc854829007c4ef77a0065c609ec5 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 7 Nov 2016 15:53:28 +0100 Subject: [PATCH 0535/1580] Add psc-package (#2337) * Basic sketch of psc-package * Clone to depth one * Add install command * Do not use Data.Aeson.Text * Refactoring * Make repo and branch configurable * Prettify JSON * Use aeson-pretty * Add dependencies command * Only update the package file after an install completed successfully * Slightly better errors * Unused import * Update the package set repo * Add sources command to list active source directories * Update instructions * Use HTTP, various * clone quietly * Revert to pulling the package set using git * Fix imports --- psc-docs/Main.hs | 6 +- psc-package/Main.hs | 259 ++++++++++++++++++ purescript.cabal | 18 ++ .../PureScript/Interactive/Message.hs | 6 +- 4 files changed, 285 insertions(+), 4 deletions(-) create mode 100644 psc-package/Main.hs diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index 9daabcfb72..2f5abb45a0 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -236,16 +236,16 @@ examples = PP.vcat $ map PP.text [ "Examples:" , " print documentation for Data.List to stdout:" - , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\" + , " psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\" , " --docgen Data.List" , "" , " write documentation for Data.List to docs/Data.List.md:" - , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\" + , " psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\" , " --docgen Data.List:docs/Data.List.md" , "" , " write documentation for Data.List to docs/Data.List.md, and" , " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:" - , " psc-docs \"src/**/*.purs\" \"bower_components/*/src/**/*.purs\" \\" + , " psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\" , " --docgen Data.List:docs/Data.List.md \\" , " --docgen Data.List.Lazy:docs/Data.List.Lazy.md" ] diff --git a/psc-package/Main.hs b/psc-package/Main.hs new file mode 100644 index 0000000000..ef90ee1caf --- /dev/null +++ b/psc-package/Main.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Main where + +import qualified Data.Aeson as Aeson +import Data.Aeson.Encode.Pretty +import Data.Foldable (fold, for_, traverse_) +import Data.List (nub) +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) +import qualified Data.Set as Set +import Data.Text (pack) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import Data.Text.Encoding (encodeUtf8) +import Data.Traversable (for) +import Data.Version (showVersion) +import qualified Filesystem.Path.CurrentOS as Path +import GHC.Generics (Generic) +import qualified Options.Applicative as Opts +import qualified Paths_purescript as Paths +import qualified System.IO as IO +import Turtle hiding (fold) + +packageFile :: Path.FilePath +packageFile = "psc-package.json" + +data PackageConfig = PackageConfig + { name :: Text + , depends :: [Text] + , set :: Text + , source :: Text + } deriving (Show, Generic, Aeson.FromJSON, Aeson.ToJSON) + +pathToTextUnsafe :: Turtle.FilePath -> Text +pathToTextUnsafe = either (error "Path.toText failed") id . Path.toText + +defaultPackage :: Text -> PackageConfig +defaultPackage pkgName = + PackageConfig { name = pkgName + , depends = [ "prelude" ] + , set = "psc-" <> pack (showVersion Paths.version) + , source = "https://github.com/purescript/package-sets.git" + } + +readPackageFile :: IO PackageConfig +readPackageFile = do + exists <- testfile packageFile + unless exists $ do + echo "psc-package.json does not exist" + exit (ExitFailure 1) + mpkg <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile packageFile + case mpkg of + Nothing -> do + echo "Unable to parse psc-package.json" + exit (ExitFailure 1) + Just pkg -> return pkg + +encodePrettyToText :: Aeson.ToJSON json => json -> Text +encodePrettyToText = + TL.toStrict + . TB.toLazyText + . encodePrettyToTextBuilder' config + where + config = defConfig + { confCompare = + keyOrder [ "name" + , "set" + , "source" + , "depends" + ] + } + +writePackageFile :: PackageConfig -> IO () +writePackageFile = + writeTextFile packageFile + . encodePrettyToText + +data PackageInfo = PackageInfo + { repo :: Text + , version :: Text + , dependencies :: [Text] + } deriving (Show, Eq, Generic, Aeson.FromJSON, Aeson.ToJSON) + +type PackageSet = Map.Map Text PackageInfo + +cloneShallow + :: Text + -- ^ repo + -> Text + -- ^ branch/tag + -> Turtle.FilePath + -- ^ target directory + -> IO ExitCode +cloneShallow from ref into = + proc "git" + [ "clone" + , "-q" + , "-c", "advice.detachedHead=false" + , "--depth", "1" + , "-b", ref + , from + , pathToTextUnsafe into + ] empty .||. exit (ExitFailure 1) + +getPackageSet :: PackageConfig -> IO () +getPackageSet PackageConfig{ source, set } = do + let pkgDir = ".psc-package" fromText set ".set" + exists <- testdir pkgDir + unless exists . void $ cloneShallow source set pkgDir + +readPackageSet :: PackageConfig -> IO PackageSet +readPackageSet PackageConfig{ set } = do + let dbFile = ".psc-package" fromText set ".set" "packages.json" + exists <- testfile dbFile + unless exists $ do + echo "packages.json does not exist" + exit (ExitFailure 1) + mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile + case mdb of + Nothing -> do + echo "Unable to parse packages.json" + exit (ExitFailure 1) + Just db -> return db + +installOrUpdate :: PackageConfig -> Text -> PackageInfo -> IO () +installOrUpdate PackageConfig{ set } pkgName PackageInfo{ repo, version } = do + let pkgDir = ".psc-package" fromText set fromText pkgName fromText version + exists <- testdir pkgDir + unless exists . void $ cloneShallow repo version pkgDir + +getTransitiveDeps :: PackageSet -> [Text] -> IO [(Text, PackageInfo)] +getTransitiveDeps db depends = do + pkgs <- for depends $ \pkg -> + case Map.lookup pkg db of + Nothing -> do + echo ("Package " <> pkg <> " does not exist in package set") + exit (ExitFailure 1) + Just PackageInfo{ dependencies } -> return (pkg : dependencies) + let unique = Set.toList (foldMap Set.fromList pkgs) + return (mapMaybe (\name -> fmap (name, ) (Map.lookup name db)) unique) + +updateImpl :: PackageConfig -> IO () +updateImpl config@PackageConfig{ depends } = do + getPackageSet config + db <- readPackageSet config + trans <- getTransitiveDeps db depends + echo ("Updating " <> pack (show (length trans)) <> " packages...") + for_ trans $ \(pkgName, pkg) -> do + echo ("Updating " <> pkgName) + installOrUpdate config pkgName pkg + +initialize :: IO () +initialize = do + exists <- testfile "psc-package.json" + when exists $ do + echo "psc-package.json already exists" + exit (ExitFailure 1) + echo "Initializing new project in current directory" + pkgName <- pathToTextUnsafe . Path.filename <$> pwd + let pkg = defaultPackage pkgName + writePackageFile pkg + updateImpl pkg + +update :: IO () +update = do + pkg <- readPackageFile + updateImpl pkg + echo "Update complete" + +install :: String -> IO () +install pkgName = do + pkg <- readPackageFile + let pkg' = pkg { depends = nub (pack pkgName : depends pkg) } + updateImpl pkg' + writePackageFile pkg' + echo "psc-package.json file was updated" + +listDependencies :: IO () +listDependencies = do + pkg@PackageConfig{ depends } <- readPackageFile + db <- readPackageSet pkg + trans <- getTransitiveDeps db depends + traverse_ (echo . fst) trans + +getSourcePaths :: PackageConfig -> PackageSet -> [Text] -> IO [Turtle.FilePath] +getSourcePaths PackageConfig{..} db pkgNames = do + trans <- getTransitiveDeps db pkgNames + let paths = [ ".psc-package" + fromText set + fromText pkgName + fromText version + "src" "**" "*.purs" + | (pkgName, PackageInfo{ version }) <- trans + ] + return paths + +listSourcePaths :: IO () +listSourcePaths = do + pkg@PackageConfig{ depends } <- readPackageFile + db <- readPackageSet pkg + paths <- getSourcePaths pkg db depends + traverse_ (echo . pathToTextUnsafe) paths + +exec :: Text -> IO () +exec exeName = do + pkg@PackageConfig{..} <- readPackageFile + db <- readPackageSet pkg + paths <- getSourcePaths pkg db depends + procs exeName + (map pathToTextUnsafe ("src" "**" "*.purs" : paths)) + empty + +main :: IO () +main = do + IO.hSetEncoding IO.stdout IO.utf8 + IO.hSetEncoding IO.stderr IO.utf8 + cmd <- Opts.execParser opts + cmd + where + opts = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList + infoModList = Opts.fullDesc <> headerInfo <> footerInfo + headerInfo = Opts.progDesc "Manage package dependencies" + footerInfo = Opts.footer $ "psc-package " ++ showVersion Paths.version + + versionInfo :: Parser (a -> a) + versionInfo = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $ + Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden + + commands :: Parser (IO ()) + commands = (Opts.subparser . fold) + [ Opts.command "init" + (Opts.info (pure initialize) + (Opts.progDesc "Initialize a new package")) + , Opts.command "update" + (Opts.info (pure update) + (Opts.progDesc "Update dependencies")) + , Opts.command "install" + (Opts.info (install <$> pkg) + (Opts.progDesc "Install the named package")) + , Opts.command "build" + (Opts.info (pure (exec "psc")) + (Opts.progDesc "Build the current package and dependencies")) + , Opts.command "dependencies" + (Opts.info (pure listDependencies) + (Opts.progDesc "List all (transitive) dependencies for the current package")) + , Opts.command "sources" + (Opts.info (pure listSourcePaths) + (Opts.progDesc "List all (active) source paths for dependencies")) + ] + where + pkg = Opts.strArgument $ + Opts.metavar "PACKAGE" + <> Opts.help "The name of the package to install" diff --git a/purescript.cabal b/purescript.cabal index a4bf123977..f8a41be308 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -412,6 +412,24 @@ executable psc-publish hs-source-dirs: psc-publish ghc-options: -Wall -O2 +executable psc-package + build-depends: base >=4 && <5, + purescript -any, + aeson -any, + aeson-pretty -any, + bytestring -any, + containers -any, + foldl -any, + optparse-applicative -any, + system-filepath -any, + text -any, + turtle -any + main-is: Main.hs + other-modules: Paths_purescript + buildable: True + hs-source-dirs: psc-package + ghc-options: -Wall -O2 + executable psc-hierarchy build-depends: base >=4 && <5, purescript -any, diff --git a/src/Language/PureScript/Interactive/Message.hs b/src/Language/PureScript/Interactive/Message.hs index 22ea272e5d..97ef4cb2fb 100644 --- a/src/Language/PureScript/Interactive/Message.hs +++ b/src/Language/PureScript/Interactive/Message.hs @@ -39,11 +39,15 @@ prologueMessage = unlines supportModuleMessage :: String supportModuleMessage = unlines - [ "PSCi requires the purescript-psci-support package to be installed." + [ "PSCi requires the psci-support package to be installed." , "You can install it using Bower as follows:" , "" , " bower i purescript-psci-support --save-dev" , "" + , "Or using psc-package:" + , "" + , " psc-package install psci-support" + , "" , "For help getting started, visit http://wiki.purescript.org/PSCi" ] From 6675280b8633c2382845993ef81929d844273e41 Mon Sep 17 00:00:00 2001 From: bbqbaron Date: Mon, 7 Nov 2016 09:54:35 -0500 Subject: [PATCH 0536/1580] 2323: Sort IDE-generated explicit imports (#2413) * 2323 sort IDE-generated explicit imports * make basic formatting/function choice changes before restructuring * Convert Ord DeclarationRef to sort function. Change ordering to match that suggested by linter. Compare PositionedDeclarationRef with itself by the inner ref. * update test for new ordering inferred from linter * sort linter suggested imports. always collapse ide-suggested dtors * 2323 collapse even single-dtor imports in an open import --- src/Language/PureScript/AST/Declarations.hs | 25 ++++++++++ src/Language/PureScript/Ide/Imports.hs | 11 ++--- src/Language/PureScript/Linter/Imports.hs | 2 +- .../PureScript/Ide/Imports/IntegrationSpec.hs | 4 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 49 +++++++++++++++++-- 5 files changed, 77 insertions(+), 14 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 512572c68b..fde3ff5f2f 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -261,6 +261,31 @@ instance Eq DeclarationRef where r == (PositionedDeclarationRef _ _ r') = r == r' _ == _ = False +-- enable sorting lists of explicitly imported refs when suggesting imports in linting, IDE, etc. +-- not an Ord because this implementation is not consistent with its Eq instance. +-- think of it as a notion of contextual, not inherent, ordering. +compDecRef :: DeclarationRef -> DeclarationRef -> Ordering +compDecRef (TypeRef name _) (TypeRef name' _) = compare name name' +compDecRef (TypeOpRef name) (TypeOpRef name') = compare name name' +compDecRef (ValueRef ident) (ValueRef ident') = compare ident ident' +compDecRef (ValueOpRef name) (ValueOpRef name') = compare name name' +compDecRef (TypeClassRef name) (TypeClassRef name') = compare name name' +compDecRef (TypeInstanceRef ident) (TypeInstanceRef ident') = compare ident ident' +compDecRef (ModuleRef name) (ModuleRef name') = compare name name' +compDecRef (ReExportRef name _) (ReExportRef name' _) = compare name name' +compDecRef (PositionedDeclarationRef _ _ ref) ref' = compDecRef ref ref' +compDecRef ref (PositionedDeclarationRef _ _ ref') = compDecRef ref ref' +compDecRef ref ref' = compare + (orderOf ref) (orderOf ref') + where + orderOf :: DeclarationRef -> Int + orderOf (TypeClassRef _) = 0 + orderOf (TypeOpRef _) = 1 + orderOf (TypeRef _ _) = 2 + orderOf (ValueRef _) = 3 + orderOf (ValueOpRef _) = 4 + orderOf _ = 5 + getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) getTypeRef (TypeRef name dctors) = Just (name, dctors) getTypeRef (PositionedDeclarationRef _ _ r) = getTypeRef r diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 90e29097c0..b45e367b49 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -202,7 +202,7 @@ addExplicitImport' decl moduleName imports = refFromDeclaration (IdeDeclTypeClass n) = P.TypeClassRef n refFromDeclaration (IdeDeclDataConstructor dtor) = - P.TypeRef (dtor ^. ideDtorTypeName) (Just [dtor ^. ideDtorName]) + P.TypeRef (dtor ^. ideDtorTypeName) Nothing refFromDeclaration (IdeDeclType t) = P.TypeRef (t ^. ideTypeName) (Just []) refFromDeclaration (IdeDeclValueOperator op) = @@ -216,7 +216,7 @@ addExplicitImport' decl moduleName imports = -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) insertDeclIntoImport :: IdeDeclaration -> Import -> Import insertDeclIntoImport decl' (Import mn (P.Explicit refs) Nothing) = - Import mn (P.Explicit (insertDeclIntoRefs decl' refs)) Nothing + Import mn (P.Explicit (sortBy P.compDecRef (insertDeclIntoRefs decl' refs))) Nothing insertDeclIntoImport _ is = is insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef] @@ -228,12 +228,7 @@ addExplicitImport' decl moduleName imports = refs insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) - insertDtor dtor (P.TypeRef tn' dtors) = - case dtors of - Just dtors' -> P.TypeRef tn' (Just (ordNub (dtor : dtors'))) - -- This means the import was opened. We don't add anything in this case - -- import Data.Maybe (Maybe(..)) -> import Data.Maybe (Maybe(Just)) - Nothing -> P.TypeRef tn' Nothing + insertDtor _ (P.TypeRef tn' _) = P.TypeRef tn' Nothing insertDtor _ refs = refs matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index fceea2a2c6..7db7706226 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -308,7 +308,7 @@ findUsedRefs env mni qn names = typesRefs = map (flip TypeRef (Just [])) typesWithoutDctors ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors) - in classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs + in sortBy compDecRef $ classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs where diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs index bc55786dd4..61021cc8a0 100644 --- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs +++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs @@ -57,10 +57,10 @@ spec = beforeAll_ setup . describe "Adding imports" $ do outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (class ATypeClass)"]) it "adds an explicit unqualified import (dataconstructor)" $ do withSupportFiles (Integration.addImport "MyJust") - outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyMaybe(MyJust))"]) + outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyMaybe(..))"]) it "adds an explicit unqualified import (newtype)" $ do withSupportFiles (Integration.addImport "MyNewtype") - outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyNewtype(MyNewtype))"]) + outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyNewtype(..))"]) it "adds an explicit unqualified import (typeclass member function)" $ do withSupportFiles (Integration.addImport "typeClassFun") outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (typeClassFun)"]) diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index e102fb7e0b..bba7441452 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -73,6 +73,8 @@ spec = do prettyPrintImportSection (addExplicitImport' (IdeDeclValueOperator (IdeValueOperator op (P.Qualified Nothing (Left (P.Ident ""))) 2 P.Infix Nothing)) mn is) addDtorImport i t mn is = prettyPrintImportSection (addExplicitImport' (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName i) t wildcard)) mn is) + addTypeImport i mn is = + prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.Star)) mn is) it "adds an implicit unqualified import" $ shouldBe (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map")) @@ -100,20 +102,26 @@ spec = do shouldBe (addOpImport (P.OpName "<~>") (P.moduleNameFromString "Data.Array") explicitImports) [ "import Prelude" - , "import Data.Array ((<~>), tail)" + , "import Data.Array (tail, (<~>))" ] + it "adds a type with constructors without automatically adding an open import of said constructors " $ + shouldBe + (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") simpleFileImports) + [ "import Prelude" + , "import Data.Maybe (Maybe)" + ] it "adds the type for a given DataConstructor" $ shouldBe (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") simpleFileImports) [ "import Prelude" - , "import Data.Maybe (Maybe(Just))" + , "import Data.Maybe (Maybe(..))" ] it "adds a dataconstructor to an existing type import" $ do let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"]) shouldBe (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") typeImports) [ "import Prelude" - , "import Data.Maybe (Maybe(Just))" + , "import Data.Maybe (Maybe(..))" ] it "doesn't add a dataconstructor to an existing type import with open dtors" $ do let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe(..))"]) @@ -128,3 +136,38 @@ spec = do [ "import Prelude" , "import Data.Array (tail)" ] + + describe "explicit import sorting" $ do + -- given some basic import skeleton + let Right (_, _, baseImports, _) = sliceImportSection $ withImports ["import Control.Monad (ap)"] + moduleName = (P.moduleNameFromString "Control.Monad") + addImport imports import' = addExplicitImport' import' moduleName imports + valueImport ident = (IdeDeclValue (IdeValue (P.Ident ident) wildcard)) + typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.Star)) + classImport name = (IdeDeclTypeClass (P.ProperName name)) + dtorImport name typeName = (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName name) (P.ProperName typeName) wildcard)) + -- expect any list of provided identifiers, when imported, to come out as specified + expectSorted imports expected = shouldBe + (ordNub $ map + (prettyPrintImportSection . foldl addImport baseImports) + (permutations imports)) + [expected] + it "sorts class" $ + expectSorted (map classImport ["Applicative", "Bind"]) + ["import Prelude", "import Control.Monad (class Applicative, class Bind, ap)"] + it "sorts value" $ + expectSorted (map valueImport ["unless", "where"]) + ["import Prelude", "import Control.Monad (ap, unless, where)"] + it "sorts type, value" $ + expectSorted + ((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"])) + ["import Prelude", "import Control.Monad (Bar, Foo, ap, unless, where)"] + it "sorts class, type, value" $ + expectSorted + ((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"]) ++ (map classImport ["Applicative", "Bind"])) + ["import Prelude", "import Control.Monad (class Applicative, class Bind, Bar, Foo, ap, unless, where)"] + it "sorts types with constructors, using open imports for the constructors" $ + expectSorted + -- the imported names don't actually have to exist! + (map (uncurry dtorImport) [("Just", "Maybe"), ("Nothing", "Maybe"), ("SomeOtherConstructor", "SomeDataType")]) + ["import Prelude", "import Control.Monad (Maybe(..), SomeDataType(..), ap)"] From 887d4130e91a3af9ef8178f04e63d10c8ef56c19 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Mon, 7 Nov 2016 14:55:51 +0000 Subject: [PATCH 0537/1580] Traversal should pick up bindings in all value declarations. (#2412) --- examples/warning/2411.purs | 15 +++++++++++++++ src/Language/PureScript/AST/Traversals.hs | 3 ++- 2 files changed, 17 insertions(+), 1 deletion(-) create mode 100644 examples/warning/2411.purs diff --git a/examples/warning/2411.purs b/examples/warning/2411.purs new file mode 100644 index 0000000000..c53ca23573 --- /dev/null +++ b/examples/warning/2411.purs @@ -0,0 +1,15 @@ +-- @shouldWarnWith ShadowedName +module Main where + +import Prelude + +import Control.Monad.Eff (Eff) + +test :: forall m. Monad m => Int -> m Unit +test x = + let x = unit + in pure x + +main :: Eff () Unit +main = test 42 + diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 82feaa27e8..610cd7e189 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -474,7 +474,8 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) in foldMap (f'' s') ds f' s (ValueDeclaration name _ bs (Right val)) = let s' = S.insert name s - in foldMap (h'' s') bs <> g'' s' val + s'' = S.union s' (S.fromList (concatMap binderNames bs)) + in foldMap (h'' s') bs <> g'' s'' val f' s (ValueDeclaration name _ bs (Left gs)) = let s' = S.insert name s s'' = S.union s' (S.fromList (concatMap binderNames bs)) From 03bc0724a5b8e0f9af01445578bcfea68191ee3c Mon Sep 17 00:00:00 2001 From: Phillip Freeman Date: Mon, 7 Nov 2016 16:07:04 +0100 Subject: [PATCH 0538/1580] -> 0.10.2 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index f8a41be308..0c3540ad61 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.10.1 +version: 0.10.2 cabal-version: >=1.8 build-type: Simple license: BSD3 From 8de8142f66c42db1b4f940770cc00bcabca20f2f Mon Sep 17 00:00:00 2001 From: Mario Rodas Date: Mon, 7 Nov 2016 18:51:31 -0500 Subject: [PATCH 0539/1580] Add psc-package to release bundle --- bundle/README | 1 + bundle/build.sh | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/bundle/README b/bundle/README index 42596cfb6e..b5b63b475b 100644 --- a/bundle/README +++ b/bundle/README @@ -19,6 +19,7 @@ This bundle contains the following executables: - psc-ide-server Provides Editor Support in the form of type information and autocompletion - psc-ide-client Utility to query psc-ide-server +- psc-package Package manager for PureScript packages Copy these files anywhere on your PATH. diff --git a/bundle/build.sh b/bundle/build.sh index 2acfdf417a..5d99d8c388 100755 --- a/bundle/build.sh +++ b/bundle/build.sh @@ -26,7 +26,7 @@ fi mkdir -p bundle/build/purescript # Strip the binaries, and copy them to the staging directory -for BIN in psc psci psc-docs psc-publish psc-bundle psc-ide-server psc-ide-client +for BIN in psc psci psc-docs psc-publish psc-bundle psc-ide-server psc-ide-client psc-package do FULL_BIN="$LOCAL_INSTALL_ROOT/bin/${BIN}${BIN_EXT}" if [ "$OS" != "win64" ] From 46f573a1205c6483716610ec7d5041757f0588ba Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 9 Nov 2016 15:20:05 -0500 Subject: [PATCH 0540/1580] Fix GHC 8.0.2 build (and fix #2421) (#2422) * Fix GHC 8.0.2 build (and fix #2421) * Update CONTRIBUTORS.md --- CONTRIBUTORS.md | 1 + src/Control/Monad/Supply/Class.hs | 5 +++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index ae69642538..76ae54a1c3 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -84,6 +84,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@brandonhamilton](https://github.com/brandonhamilton) (Brandon Hamilton) My existing contributions and all future contributions until further notice are Copyright Brandon Hamilton, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@bbqbaron](https://github.com/bbqbaron) (Eric Loren) My existing contributions and all future contributions until further notice are Copyright Eric Loren, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@RyanGlScott](https://github.com/RyanGlScott) (Ryan Scott) My existing contributions and all future contributions until further notice are Copyright Ryan Scott, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index 00d70cfb58..c938bcfcd2 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -3,6 +3,7 @@ -- {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} module Control.Monad.Supply.Class where @@ -15,9 +16,9 @@ import Control.Monad.Writer class Monad m => MonadSupply m where fresh :: m Integer peek :: m Integer - default fresh :: MonadTrans t => t m Integer + default fresh :: (MonadTrans t, MonadSupply n, m ~ t n) => m Integer fresh = lift fresh - default peek :: MonadTrans t => t m Integer + default peek :: (MonadTrans t, MonadSupply n, m ~ t n) => m Integer peek = lift peek instance Monad m => MonadSupply (SupplyT m) where From c5432ce9964212610b1d390d9205474b48fa63e3 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 11 Nov 2016 17:53:31 +0000 Subject: [PATCH 0541/1580] Create documentation for psc-package (#2424) * Create documentation for psc-package * Tag->Ref --- psc-package/README.md | 99 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 99 insertions(+) create mode 100644 psc-package/README.md diff --git a/psc-package/README.md b/psc-package/README.md new file mode 100644 index 0000000000..8938ddec17 --- /dev/null +++ b/psc-package/README.md @@ -0,0 +1,99 @@ +# `psc-package` + +`psc-package` is an executable which helps manage PureScript dependencies via Git. It can be used directly, but it is also designed to be used by external tools. + +## Concepts + +### Package Sets + +A _package set_ is a mapping from package names to: + +- the Git repository URL for the package +- the Git ref which should be passed to `git clone` to clone the appropriate version (usually a tag name, but a SHA is also valid) +- the package's transitive dependencies + +A package set repository contains a `packages.json` file which contains all mapping information. `psc-package` uses this information to decide which repos need to be cloned. + +The default package set is [purescript/package-sets](https://github.com/purescript/package-sets), but it is possible to create custom package sets by forking an existing package set or creating a new one from scratch. One benefit of using the default package set is that it is verified by a continuous integration process. + +## The `psc-package.json` format + +Here is a simple project configuration: + +```json +{ + "name": "my-project", + "set": "psc-0.10.2", + "source": "https://github.com/purescript/package-sets.git", + "depends": [ + "prelude" + ] +} +``` + +It defines: + +- The project name +- The package set to use to resolve dependencies (this corresponds to a branch or tag of the package set source repository) +- The package set source repository Git URL (change this if you want to host your own package sets) +- Any dependencies of the project, as a list of names of packages from the package set + +## How To + +### Create a project + +A new package can be created using `psc-package init`. This will: + +- Create a simple `psc-package.json` file based on the current compiler version +- Add the Prelude as a dependency (this can be removed later) +- Sync the local package database (under the `.psc-package/` directory) by cloning any necessary repositories. + +### Add dependencies + +To add a dependency, either: + +- Use the `install` command, which will update the project configuration automatically, or +- Modify the `psc-package.json` file, and sync manually by running the `update` command. + +### Build a project + +Active project dependencies and project source files under `src` can be compiled using the `build` command. + +This command is provided as a convenience until external tools add support for `psc-package`. It _might_ be removed in future. + +### Query the local package database + +The local package database can be queried using the following commands: + +- `sources` - list source directories for active package versions. This can be useful when building a command for, say, running PSCi. +- `dependencies` - list all transitive dependencies + +### Add a package to the package set + +Adding your package to the package set means that others can easily install it as a dependency. + +Please note that your package will be removed from the set if it is not kept up to date. It can be easily re-added later if this happens. + +Adding a package is a manual process right now. We would like to add commands to make this process simpler, but for now, please follow these steps: + +- Tag a release of your library +- Run the `dependencies` command to get the list of transitive dependencies +- Make a pull request on the package set repository (against `master`) to add a new entry to `packages.json`. Use the dependency information above to fill in the fields, and the name of your new tag. + +Travis will verify your package builds correctly, and then we will try to merge your pull request. Your package will then be available in the next tagged package set. + +### Update a package in the set + +- Tag a new release +- Make a pull request on `master` to modify the tag named in the package set repository. + +Again, once Travis verifies your change, we will merge it into `master` and your change will be available in the next tag. + +## FAQ + +### Can I add a dependency which is not in the package set? + +Not right now. We might add this feature in future, but for now, consider either: + +- Adding your dependency to the package set if possible, or +- Creating your own custom package set From 6561a9f0e811eb35f4a6a086f4865131e5d6dc3c Mon Sep 17 00:00:00 2001 From: bbqbaron Date: Tue, 15 Nov 2016 12:31:41 -0500 Subject: [PATCH 0542/1580] AmbiguousTypeVariable error: prettyPrintType -> typeAsBox (#2428) * 2374: Add error message for ambiguous type variables in inferred contexts * 2323 add contribution entry. remove Ident from AmbiguousTypeVariables since it's redundant with the enclosing compiler error's ident * 2323 update error message * 2374 multiline error message and print type, not type atom * 2374 print type as box, not prettyprinted single * remove conflict line --- src/Language/PureScript/Errors.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 60bba56739..346c498b42 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -640,7 +640,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS go _ = False renderSimpleErrorMessage (AmbiguousTypeVariables t _) = paras [ line "The inferred type" - , indent $ line $ markCode $ prettyPrintType t + , markCodeBox $ indent $ typeAsBox t , line "has type variables which are not mentioned in the body of the type. Consider adding a type annotation." ] renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) = From a22bde51eec1bd2ce022cd70b05210e41e58b247 Mon Sep 17 00:00:00 2001 From: Andy Arvanitis Date: Tue, 15 Nov 2016 19:19:57 -0800 Subject: [PATCH 0543/1580] Add 'available' command to psc-package (#2430) --- psc-package/Main.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/psc-package/Main.hs b/psc-package/Main.hs index ef90ee1caf..14f6762367 100644 --- a/psc-package/Main.hs +++ b/psc-package/Main.hs @@ -188,6 +188,15 @@ listDependencies = do trans <- getTransitiveDeps db depends traverse_ (echo . fst) trans +listPackages :: IO () +listPackages = do + pkg <- readPackageFile + db <- readPackageSet pkg + traverse_ echo (fmt <$> Map.assocs db) + where + fmt :: (Text, PackageInfo) -> Text + fmt (name, PackageInfo{ version }) = name <> " (" <> version <> ")" + getSourcePaths :: PackageConfig -> PackageSet -> [Text] -> IO [Turtle.FilePath] getSourcePaths PackageConfig{..} db pkgNames = do trans <- getTransitiveDeps db pkgNames @@ -252,6 +261,9 @@ main = do , Opts.command "sources" (Opts.info (pure listSourcePaths) (Opts.progDesc "List all (active) source paths for dependencies")) + , Opts.command "available" + (Opts.info (pure listPackages) + (Opts.progDesc "List all packages available in the package set")) ] where pkg = Opts.strArgument $ From a53031bd118a16e1c88a259bc2412b4243850b42 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Wed, 16 Nov 2016 03:25:56 +0000 Subject: [PATCH 0544/1580] Add value source positions (#2427) * Add value source positions #1801 * Fix operators --- src/Language/PureScript/Parser/Declarations.hs | 4 ++-- src/Language/PureScript/Sugar/Operators/Expr.hs | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 4b505b33b8..d15679c744 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -392,7 +392,7 @@ parseLet = do return $ Let ds result parseValueAtom :: TokenParser Expr -parseValueAtom = P.choice +parseValueAtom = withSourceSpan PositionedValue $ P.choice [ parseAnonymousArgument , Literal <$> parseNumericLiteral , Literal <$> parseCharLiteral @@ -418,7 +418,7 @@ parseValueAtom = P.choice parseInfixExpr :: TokenParser Expr parseInfixExpr = P.between tick tick parseValue - <|> Op <$> parseQualified parseOperator + <|> withSourceSpan PositionedValue (Op <$> parseQualified parseOperator) parseHole :: TokenParser Expr parseHole = Hole <$> holeLit diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index 0c9c2b3c5a..84a1691ad3 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -20,7 +20,9 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable isBinOp _ = False extractOp :: Expr -> Maybe (Expr, Expr, Expr) - extractOp (BinaryNoParens op l r) = Just (op, l, r) + extractOp (BinaryNoParens op l r) + | PositionedValue _ _ op' <- op = Just (op', l, r) + | otherwise = Just (op, l, r) extractOp _ = Nothing fromOp :: Expr -> Maybe (Qualified (OpName 'ValueOpName)) From f764c39eb987702ea83d1ed612c0fbc972c616d7 Mon Sep 17 00:00:00 2001 From: joneshf Date: Sat, 19 Nov 2016 07:52:25 -0800 Subject: [PATCH 0545/1580] Add uninstall command to psc-package --- psc-package/Main.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/psc-package/Main.hs b/psc-package/Main.hs index 14f6762367..2a1e3192f3 100644 --- a/psc-package/Main.hs +++ b/psc-package/Main.hs @@ -181,6 +181,14 @@ install pkgName = do writePackageFile pkg' echo "psc-package.json file was updated" +uninstall :: String -> IO () +uninstall pkgName = do + pkg <- readPackageFile + let pkg' = pkg { depends = filter (/= pack pkgName) $ depends pkg } + updateImpl pkg' + writePackageFile pkg' + echo "psc-package.json file was updated" + listDependencies :: IO () listDependencies = do pkg@PackageConfig{ depends } <- readPackageFile @@ -249,6 +257,9 @@ main = do , Opts.command "update" (Opts.info (pure update) (Opts.progDesc "Update dependencies")) + , Opts.command "uninstall" + (Opts.info (uninstall <$> pkg) + (Opts.progDesc "Uninstall the named package")) , Opts.command "install" (Opts.info (install <$> pkg) (Opts.progDesc "Install the named package")) From 1e6fc9dd68fc199364d4865eed37b7e2fcd6b91f Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Wed, 23 Nov 2016 00:35:58 +0000 Subject: [PATCH 0546/1580] Solving IsSymbol instances (#2429) * Solve IsSymbol instances * IsSymbol dict with constructor application * IsSymbol solving with Evidence type & comments * Update IsSymbol tests to depend on implicit Data.Symbol import --- examples/passing/SolvingIsSymbol.purs | 13 ++++ examples/passing/SolvingIsSymbol/Lib.purs | 10 ++++ purescript.cabal | 1 + src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Constants.hs | 5 ++ src/Language/PureScript/CoreFn/Desugar.hs | 10 +++- src/Language/PureScript/Environment.hs | 2 +- src/Language/PureScript/Externs.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 4 +- .../PureScript/TypeChecker/Entailment.hs | 59 ++++++++++++------- src/Language/PureScript/TypeChecker/Monad.hs | 8 +-- .../PureScript/TypeClassDictionaries.hs | 13 ++-- tests/TestUtils.hs | 2 + tests/support/bower.json | 4 +- 14 files changed, 99 insertions(+), 36 deletions(-) create mode 100644 examples/passing/SolvingIsSymbol.purs create mode 100644 examples/passing/SolvingIsSymbol/Lib.purs diff --git a/examples/passing/SolvingIsSymbol.purs b/examples/passing/SolvingIsSymbol.purs new file mode 100644 index 0000000000..e14866a293 --- /dev/null +++ b/examples/passing/SolvingIsSymbol.purs @@ -0,0 +1,13 @@ +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console + +-- Here we import as alias of reflectSymbol without importing Data.Symbol. However, +-- Data.Symbol should be implicitly imported as we have an instance of IsSymbol solved. +import SolvingIsSymbol.Lib (literalSymbol, libReflectSymbol) + +main = do + let lit = libReflectSymbol literalSymbol + when (lit == "literal") (log "Done") diff --git a/examples/passing/SolvingIsSymbol/Lib.purs b/examples/passing/SolvingIsSymbol/Lib.purs new file mode 100644 index 0000000000..18ea3b2924 --- /dev/null +++ b/examples/passing/SolvingIsSymbol/Lib.purs @@ -0,0 +1,10 @@ +module SolvingIsSymbol.Lib where + +import Data.Symbol + +literalSymbol :: SProxy "literal" +literalSymbol = SProxy + +libReflectSymbol :: forall s. IsSymbol s => SProxy s -> String +libReflectSymbol = reflectSymbol + diff --git a/purescript.cabal b/purescript.cabal index 0c3540ad61..79e2814e4d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -50,6 +50,7 @@ extra-source-files: examples/passing/*.purs , examples/passing/ResolvableScopeConflict2/*.purs , examples/passing/ResolvableScopeConflict3/*.purs , examples/passing/ShadowedModuleName/*.purs + , examples/passing/SolvingIsSymbol/*.purs , examples/passing/TransitiveImport/*.purs , examples/passing/TypeOperators/*.purs , examples/passing/TypeWithoutParens/*.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index fde3ff5f2f..081b05cce3 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -607,7 +607,7 @@ data Expr -- instance type, and the type class dictionaries in scope. -- | TypeClassDictionary Constraint - (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))) + (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict))) [ErrorMessageHint] -- | -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring. diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 8f607b9fd2..c4d63ba748 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -314,6 +314,11 @@ fromSpine = "fromSpine" toSignature :: String toSignature = "toSignature" +-- IsSymbol class + +pattern IsSymbol :: Qualified (ProperName 'ClassName) +pattern IsSymbol = Qualified (Just (ModuleName [ProperName "Data", ProperName "Symbol"])) (ProperName "IsSymbol") + -- Main module main :: String diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index af0374434e..99a5fa754b 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -13,6 +13,7 @@ import Language.PureScript.AST.Literals import Language.PureScript.AST.SourcePos import Language.PureScript.AST.Traversals import Language.PureScript.Comments +import qualified Language.PureScript.Constants as C import Language.PureScript.CoreFn.Ann import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Expr @@ -110,7 +111,9 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = exprToCoreFn ss com (Just ty) v exprToCoreFn ss com ty (A.Let ds v) = Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v) - exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.Literal (A.ObjectLiteral vs)) _)) = + exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal (A.ObjectLiteral _)) _)) = + exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name lit) + exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal (A.ObjectLiteral vs))) = let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name) in foldl (App (ss, com, Nothing, Nothing)) ctor args @@ -209,6 +212,11 @@ findQualModules decls = fqValues :: A.Expr -> [ModuleName] fqValues (A.Var q) = getQual' q fqValues (A.Constructor q) = getQual' q + -- IsSymbol instances for literal symbols are automatically solved and the type + -- class dictionaries are built inline instead of having a named instance defined + -- and imported. We therefore need to import the IsSymbol constructor from + -- Data.Symbol if it hasn't already been imported. + fqValues (A.TypeClassDictionaryConstructorApp C.IsSymbol _) = getQual' C.IsSymbol fqValues _ = [] fqBinders :: A.Binder -> [ModuleName] diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 49043e282e..fbffc742a4 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -29,7 +29,7 @@ data Environment = Environment -- constructor name, argument types and return type. , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type) -- ^ Type synonyms currently in scope - , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) + , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)) -- ^ Available type class dictionaries , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData -- ^ Type classes diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 16a70adf30..06d93a82ae 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -145,7 +145,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (TypeClassData args members cs deps) (typeClasses env) } applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) } where - dict :: TypeClassDictionaryInScope + dict :: NamedDict dict = TypeClassDictionaryInScope (qual ident) [] className tys cs updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 6ffca1f4ef..852ceb123b 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -134,7 +134,7 @@ addTypeClass moduleName pn args implies dependencies ds = addTypeClassDictionaries :: (MonadState CheckState m) => Maybe ModuleName - -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope) + -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict) -> m () addTypeClassDictionaries mn entries = modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } } @@ -282,7 +282,7 @@ typeCheckAll moduleName _ = traverse go checkOrphanInstance dictName className tys _ <- traverseTypeInstanceBody checkInstanceMembers body let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) - addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict + addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict return d go (PositionedDeclaration pos com d) = warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 01f9fab194..a5177dae2f 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -19,7 +19,7 @@ import Control.Monad.State import Control.Monad.Supply.Class (MonadSupply(..)) import Control.Monad.Writer -import Data.Foldable (for_) +import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.List (minimumBy, nub) import Data.Maybe (fromMaybe, maybeToList, mapMaybe) @@ -37,11 +37,26 @@ import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types import qualified Language.PureScript.Constants as C +-- | Describes what sort of dictionary to generate for type class instances +data Evidence + = NamedInstance (Qualified Ident) + -- ^ An existing named instance + | IsSymbolInstance String + -- ^ Computed instance of the IsSymbol type class for a given Symbol literal + deriving (Eq) + +-- | Extract the identifier of a named instance +namedInstanceIdentifier :: Evidence -> Maybe (Qualified Ident) +namedInstanceIdentifier (NamedInstance i) = Just i +namedInstanceIdentifier _ = Nothing + +-- | Description of a type class dictionary with instance evidence +type TypeClassDict = TypeClassDictionaryInScope Evidence + -- | The 'InstanceContext' tracks those constraints which can be satisfied. type InstanceContext = M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) - (M.Map (Qualified Ident) - TypeClassDictionaryInScope)) + (M.Map (Qualified Ident) NamedDict)) -- | A type substitution which makes an instance head match a list of types. -- @@ -88,7 +103,7 @@ replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ d -- | Three options for how we can handle a constraint, depending on the mode we're in. data EntailsResult a - = Solved a TypeClassDictionaryInScope + = Solved a TypeClassDict -- ^ We solved this constraint | Unsolved Constraint -- ^ We couldn't solve this constraint right now, it will be generalized @@ -120,7 +135,8 @@ entails entails SolverOptions{..} constraint context hints = solve constraint where - forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDictionaryInScope] + forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict] + forClassName _ C.IsSymbol [TypeLevelString sym] = [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing] forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (nub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) forClassName _ _ _ = internalError "forClassName: expected qualified class name" @@ -130,8 +146,8 @@ entails SolverOptions{..} constraint context hints = ctorModules (TypeApp ty _) = ctorModules ty ctorModules _ = Nothing - findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDictionaryInScope] - findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx + findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDict] + findDicts ctx cn = fmap (fmap NamedInstance) . maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx valUndefined :: Expr valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) @@ -181,7 +197,7 @@ entails SolverOptions{..} constraint context hints = -- Solve any necessary subgoals args <- solveSubgoals subst'' (tcdDependencies tcd) let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index) - (mkDictionary (tcdName tcd) args) + (mkDictionary (tcdValue tcd) args) (tcdPath tcd) return match Unsolved unsolved -> do @@ -213,7 +229,7 @@ entails SolverOptions{..} constraint context hints = -- fresh type variables. This function extends a substitution with fresh type variables -- as necessary, based on the types in the instance head. withFreshTypes - :: TypeClassDictionaryInScope + :: TypeClassDict -> Matching Type -> m (Matching Type) withFreshTypes TypeClassDictionaryInScope{..} subst = do @@ -232,7 +248,7 @@ entails SolverOptions{..} constraint context hints = t <- freshType return (s, t) - unique :: [Type] -> [(a, TypeClassDictionaryInScope)] -> m (EntailsResult a) + unique :: [Type] -> [(a, TypeClassDict)] -> m (EntailsResult a) unique tyArgs [] | solverDeferErrors = return Deferred -- We need a special case for nullary type classes, since we want @@ -242,7 +258,7 @@ entails SolverOptions{..} constraint context hints = unique _ [(a, dict)] = return $ Solved a dict unique tyArgs tcds | pairwiseAny overlapping (map snd tcds) = do - tell . errorMessage $ OverlappingInstances className' tyArgs (map (tcdName . snd) tcds) + tell . errorMessage $ OverlappingInstances className' tyArgs (tcds >>= (toList . namedInstanceIdentifier . tcdValue . snd)) return $ uncurry Solved (head tcds) | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds) @@ -255,12 +271,12 @@ entails SolverOptions{..} constraint context hints = -- -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have -- been caught when constructing superclass dictionaries. - overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool + overlapping :: TypeClassDict -> TypeClassDict -> Bool overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False overlapping TypeClassDictionaryInScope{ tcdDependencies = Nothing } _ = False overlapping _ TypeClassDictionaryInScope{ tcdDependencies = Nothing } = False - overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2 + overlapping tcd1 tcd2 = tcdValue tcd1 /= tcdValue tcd2 -- Create dictionaries for subgoals which still need to be solved by calling go recursively -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type @@ -271,10 +287,11 @@ entails SolverOptions{..} constraint context hints = Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals -- Make a dictionary from subgoal dictionaries by applying the correct function - mkDictionary :: Qualified Ident -> Maybe [Expr] -> Expr - mkDictionary fnName Nothing = Var fnName - mkDictionary fnName (Just []) = Var fnName - mkDictionary fnName (Just dicts) = foldl App (Var fnName) dicts + mkDictionary :: Evidence -> Maybe [Expr] -> Expr + mkDictionary (NamedInstance n) args = foldl App (Var n) (fold args) + mkDictionary (IsSymbolInstance sym) _ = TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) where + fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) + ] -- Turn a DictionaryValue into a Expr subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr @@ -286,7 +303,7 @@ entails SolverOptions{..} constraint context hints = -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a -- substitution which makes them match. If not, we return 'Nothing'. -matches :: [FunctionalDependency] -> TypeClassDictionaryInScope -> [Type] -> Maybe (Matching [Type]) +matches :: [FunctionalDependency] -> TypeClassDict -> [Type] -> Maybe (Matching [Type]) matches deps TypeClassDictionaryInScope{..} tys = do -- First, find those types which match exactly let matched = zipWith typeHeadsAreEqual tys tcdInstanceTypes @@ -402,7 +419,7 @@ newDictionaries => [(Qualified (ProperName 'ClassName), Integer)] -> Qualified Ident -> Constraint - -> m [TypeClassDictionaryInScope] + -> m [NamedDict] newDictionaries path name (Constraint className instanceTy _) = do tcs <- gets (typeClasses . checkEnv) let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs @@ -416,9 +433,9 @@ newDictionaries path name (Constraint className instanceTy _) = do instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type] instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs -mkContext :: [TypeClassDictionaryInScope] -> InstanceContext +mkContext :: [NamedDict] -> InstanceContext mkContext = foldr combineContexts M.empty . map fromDict where - fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdName d) d)) + fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdValue d) d)) -- | Check all pairs of values in a list match a predicate pairwiseAll :: (a -> a -> Bool) -> [a] -> Bool diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 79e71fbcec..7f779e87e0 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -133,12 +133,12 @@ warnAndRethrowWithPositionTC pos = rethrowWithPositionTC pos . warnWithPosition -- | Temporarily make a collection of type class dictionaries available withTypeClassDictionaries :: MonadState CheckState m - => [TypeClassDictionaryInScope] + => [NamedDict] -> m a -> m a withTypeClassDictionaries entries action = do orig <- get - let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdName entry) entry)) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _, tcdClassName = className } <- entries ] + let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdValue entry) entry)) | entry@TypeClassDictionaryInScope{ tcdValue = Qualified mn _, tcdClassName = className } <- entries ] modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith M.union) (typeClassDictionaries . checkEnv $ st) mentries } } a <- action modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } } @@ -147,14 +147,14 @@ withTypeClassDictionaries entries action = do -- | Get the currently available map of type class dictionaries getTypeClassDictionaries :: (MonadState CheckState m) - => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope))) + => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict))) getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get -- | Lookup type class dictionaries in a module. lookupTypeClassDictionaries :: (MonadState CheckState m) => Maybe ModuleName - -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) + -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)) lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get -- | Temporarily bind a collection of names to local variables diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 59becfdb1d..13281c17c3 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} module Language.PureScript.TypeClassDictionaries where import Prelude.Compat @@ -8,10 +10,10 @@ import Language.PureScript.Types -- | -- Data representing a type class dictionary which is in scope -- -data TypeClassDictionaryInScope +data TypeClassDictionaryInScope v = TypeClassDictionaryInScope { - -- | The identifier with which the dictionary can be accessed at runtime - tcdName :: Qualified Ident + -- | The value with which the dictionary can be accessed at runtime + tcdValue :: v -- | How to obtain this instance via superclass relationships , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)] -- | The name of the type class to which this type class instance applies @@ -21,4 +23,7 @@ data TypeClassDictionaryInScope -- | Type class dependencies which must be satisfied to construct this dictionary , tcdDependencies :: Maybe [Constraint] } - deriving (Show) + deriving (Show, Functor, Foldable, Traversable) + +type NamedDict = TypeClassDictionaryInScope (Qualified Ident) + diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 6c8e09909b..cf67a38ba4 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -104,6 +104,7 @@ supportModules = , "Data.Ring" , "Data.Semigroup" , "Data.Semiring" + , "Data.Symbol" , "Data.Show" , "Data.Unit" , "Data.Void" @@ -112,6 +113,7 @@ supportModules = , "Prelude" , "Test.Assert" , "Test.Main" + , "Unsafe.Coerce" ] pushd :: forall a. FilePath -> IO a -> IO a diff --git a/tests/support/bower.json b/tests/support/bower.json index d2f01dd85a..2de10e8f7c 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -9,6 +9,8 @@ "purescript-st": "1.0.0-rc.1", "purescript-partial": "1.1.2", "purescript-newtype": "0.1.0", - "purescript-generics-rep": "2.0.0" + "purescript-generics-rep": "2.0.0", + "purescript-symbols": "^1.0.1", + "purescript-unsafe-coerce": "^1.0.0" } } From 610424443b20eb83a70fcb3e966cfe36f665866b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C3=96mer=20Sinan=20A=C4=9Facan?= Date: Fri, 25 Nov 2016 06:08:40 +0200 Subject: [PATCH 0547/1580] Update CONTRIBUTING.md --- CONTRIBUTING.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 888a087684..65443cc0e9 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -12,7 +12,7 @@ Please follow the following guidelines: - Add at least a test to `examples/passing/` and possibly to `examples/failing`. - Build the binaries and libs with `stack build` -- Run the test suite with `stack test`. You will need `npm` and `node` on your PATH to run the tests. +- Run the test suite with `stack test`. You will need `npm`, `bower` and `node` on your PATH to run the tests. - Build the core libraries by running the script in `core-tests`. ## Code Review From 32bc8cc042b5303d9a47fdc454024c2aa62bb0c0 Mon Sep 17 00:00:00 2001 From: Hardy Jones Date: Fri, 25 Nov 2016 13:38:36 -0800 Subject: [PATCH 0548/1580] Warn for shadowed type class variables (#2441) * Warn for shadowed type class variables * Fork higher when gathering errors for type classes --- examples/warning/2140.purs | 5 +++++ src/Language/PureScript/AST/Declarations.hs | 1 + src/Language/PureScript/Errors.hs | 4 ++++ src/Language/PureScript/Linter.hs | 19 ++++++++++++------- 4 files changed, 22 insertions(+), 7 deletions(-) create mode 100644 examples/warning/2140.purs diff --git a/examples/warning/2140.purs b/examples/warning/2140.purs new file mode 100644 index 0000000000..3369cbac38 --- /dev/null +++ b/examples/warning/2140.purs @@ -0,0 +1,5 @@ +-- @shouldWarnWith ShadowedTypeVar +module Main where + +class Test a where + f :: (forall a. a -> a) -> a -> a diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 081b05cce3..ce300e334e 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -157,6 +157,7 @@ data ErrorMessageHint | ErrorInTypeSynonym (ProperName 'TypeName) | ErrorInValueDeclaration Ident | ErrorInTypeDeclaration Ident + | ErrorInTypeClassDeclaration (ProperName 'ClassName) | ErrorInForeignImport Ident | ErrorSolvingConstraint Constraint | PositionedError SourceSpan diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 346c498b42..73f9bc0802 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -984,6 +984,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS paras [ detail , line $ "in type declaration for " ++ markCode (showIdent n) ] + renderHint (ErrorInTypeClassDeclaration name) detail = + paras [ detail + , line $ "in type class declaration for " ++ markCode (runProperName name) + ] renderHint (ErrorInForeignImport nm) detail = paras [ detail , line $ "in foreign import " ++ markCode (showIdent nm) diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 14c8a205df..578b1742e3 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -44,9 +44,14 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl f :: Declaration -> MultipleErrors f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec) - f dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec) - f (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars ty) - f dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl dec + f (TypeClassDeclaration name args _ _ decs) = addHint (ErrorInTypeClassDeclaration name) (foldMap (f' (S.fromList $ fst <$> args)) decs) + f dec = f' S.empty dec + + f' :: S.Set String -> Declaration -> MultipleErrors + f' s (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' s dec) + f' s dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec) + f' s (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars s ty) + f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec stepE :: S.Set Ident -> Expr -> MultipleErrors stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name) @@ -70,11 +75,11 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl | otherwise = mempty stepDo _ _ = mempty - checkTypeVarsInDecl :: Declaration -> MultipleErrors - checkTypeVarsInDecl d = let (f, _, _, _, _) = accumTypes checkTypeVars in f d + checkTypeVarsInDecl :: S.Set String -> Declaration -> MultipleErrors + checkTypeVarsInDecl s d = let (f, _, _, _, _) = accumTypes (checkTypeVars s) in f d - checkTypeVars :: Type -> MultipleErrors - checkTypeVars ty = everythingWithContextOnTypes S.empty mempty mappend step ty <> findUnused ty + checkTypeVars :: S.Set String -> Type -> MultipleErrors + checkTypeVars set ty = everythingWithContextOnTypes set mempty mappend step ty <> findUnused ty where step :: S.Set String -> Type -> (S.Set String, MultipleErrors) step s (ForAll tv _ _) = bindVar s tv From f81b9ca23554c54fe473624159251be2e9247072 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Fri, 25 Nov 2016 22:19:26 +0000 Subject: [PATCH 0549/1580] Update error message of `ErrorInDataBindingGroup` to include participating identifiers (#2447) * Update error message of `ErrorInDataBindingGroup` to include participating identifiers. * Nub `ErrorInDataBindingGroup` identifiers --- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Errors.hs | 4 ++-- src/Language/PureScript/TypeChecker.hs | 8 +++++--- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index ce300e334e..2eb7e74be9 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -153,7 +153,7 @@ data ErrorMessageHint | ErrorInDataConstructor (ProperName 'ConstructorName) | ErrorInTypeConstructor (ProperName 'TypeName) | ErrorInBindingGroup [Ident] - | ErrorInDataBindingGroup + | ErrorInDataBindingGroup [ProperName 'TypeName] | ErrorInTypeSynonym (ProperName 'TypeName) | ErrorInValueDeclaration Ident | ErrorInTypeDeclaration Ident diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 73f9bc0802..b13d777e8e 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -968,9 +968,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS paras [ detail , line $ "in binding group " ++ intercalate ", " (map showIdent nms) ] - renderHint ErrorInDataBindingGroup detail = + renderHint (ErrorInDataBindingGroup nms) detail = paras [ detail - , line "in data binding group" + , line $ "in data binding group " ++ intercalate ", " (map runProperName nms) ] renderHint (ErrorInTypeSynonym name) detail = paras [ detail diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 852ceb123b..e8a0759361 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -16,6 +16,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), modify) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Lens ((^..), _1, _2) import Data.Foldable (for_, traverse_) import Data.List (nub, nubBy, (\\), sort, group) @@ -205,9 +206,10 @@ typeCheckAll moduleName _ = traverse go addDataType moduleName dtype name args' dctors ctorKind return $ DataDeclaration dtype name args dctors go (d@(DataBindingGroupDeclaration tys)) = do - warnAndRethrow (addHint ErrorInDataBindingGroup) $ do - let syns = mapMaybe toTypeSynonym tys - let dataDecls = mapMaybe toDataDecl tys + let syns = mapMaybe toTypeSynonym tys + dataDecls = mapMaybe toDataDecl tys + bindingGroupNames = nub ((syns^..traverse._1) ++ (dataDecls^..traverse._2)) + warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames)) $ do (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls) for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do when (dtype == Newtype) $ checkNewtype name dctors From ae98dfafa9a20f93e26f1fc0e6bca813f50ea1f8 Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Sat, 26 Nov 2016 09:20:13 +1100 Subject: [PATCH 0550/1580] Exhaustive pattern match on JSAnnot. (#2432) * Exhaustive pattern match on JSAnnot. Also append to contributors file. * Bump LTS versions for stack. --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Bundle.hs | 2 ++ stack-ghc-8.0.yaml | 2 +- stack.yaml | 2 +- 4 files changed, 5 insertions(+), 2 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 76ae54a1c3..d4e6edf9fb 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -78,6 +78,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@sztupi](https://github.com/sztupi) (Attila Sztupak) My existing contributions and all future contributions until further notice are Copyright Attila Sztupak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@taku0](https://github.com/taku0) - My existing contributions and all future contributions until further notice are Copyright taku0, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@tmcgilchrist](https://github.com/tmcgilchrist) (Tim McGilchrist) My existing contributions and all future contributions until further notice are Copyright Tim McGilchrist, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@trofi](https://github.com/trofi) (Sergei Trofimovich) My existing contributions and all future contributions until further notice are Copyright Sergei Trofimovich, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 1ef4953769..2a36afe912 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -534,6 +534,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p where squash JSNoAnnot = JSAnnot (TokenPn 0 0 2) [] squash (JSAnnot pos ann) = JSAnnot (keepCol pos) (map splat ann) + squash JSAnnotSpace = JSAnnot (TokenPn 0 0 2) [] splat (CommentA pos s) = CommentA (keepCol pos) s splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w @@ -589,6 +590,7 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p appendAnn a JSNoAnnot = JSAnnot tokenPosnEmpty [a] appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty " "]) + appendAnn a JSAnnotSpace = JSAnnot tokenPosnEmpty [a] runMain :: String -> [JSStatement] runMain mn = diff --git a/stack-ghc-8.0.yaml b/stack-ghc-8.0.yaml index 0228aa7d3e..58ab0cc04b 100644 --- a/stack-ghc-8.0.yaml +++ b/stack-ghc-8.0.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2016-07-19 +resolver: lts-7.9 packages: - '.' extra-deps: diff --git a/stack.yaml b/stack.yaml index f800d9dc3e..3fbbbeb0da 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-6.10 +resolver: lts-6.25 packages: - '.' From 92c8c653f42801bc68de212b755f616c940d5b2c Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 28 Nov 2016 18:41:20 +0100 Subject: [PATCH 0551/1580] Use Text over String (#2418) * Lexer done. * Names done. * Parser.Common done. * CodeGen.JS.Common done. * Constants done. * Environment done. * Types done. * Parser.Types done. * Externs done. * Codegen.JS.AST done. * CodeGen.JS.Optimizer.Common done. * Monad.Supply.Class done. * CodeGen.JS.Optimizer.Inliner done. * CodeGen.JS.Optimizer.TCO done. * don't change inliner semantics * project specific Prelude * Pretty.Common done. * Pretty.Types done. * Pretty.Values done. * Pretty.JS done. * Pretty.Common done. * Pretty.JS now on Text bases emit. * fix warning * AST.SourcePos done. * Pretty.Kinds done. * Pretty.Common more fixes. * AST.Literals done. * CoreFn.Expr done. * Pretty.Types workaround * Pretty.Values done. * Errors done. * AST.Declarations * Parser.Declarations done. * TypChecker.Monad done. * Sugar.ObjectWildcards done. * Linter.Exhaustive done. * Linter.Imports done. * TypeChecker.Kinds done. * Sugar.TypeClasses done. * TypeChecker Skolems * TypeChecker.Unify done. * Renamer * CodeGen.JS done. * TypeChecker.Entailment done. * TypeChecker.Types done. * CoreFn.ToJSON done. * Linter done. * TypeChecker done. * Sugar.TypeClasses.Deriving done. * Make done. This needs serious review * Errors.JSON done. * Docs.RenderedCode.Types done. * Interactive.Printer done. * Interactive.Completion done. * Interactive.Parser done. * Docs.RenderedCode.Render done. * Docs.Types done. * Docs.Render done. * Docs.Convert.ReExports done. * Docs.Convert.Single done. * Docs.Convert.ReExports done. * Docs.Convert done. * Docs.AsMarkdown done. * Ide done. * Ide.Imports done. * Interactive done. * executables done. * Test Mains * ReexportsSpec * add Prelude module to cabal file * asString -> asText for module names * simpler imports for Supply.Class * fix merge conflicts * remove Language.PureScript.Prelude That's a different discussion and doesn't belong here * migrate the compiler tests to Text as well * fix merge conflicts * fix merge * comment broken surrogate test for now --- examples/passing/StringEscapes.purs | 3 +- hierarchy/Main.hs | 3 +- psc-docs/Main.hs | 9 +- psc-docs/Tags.hs | 4 +- purescript.cabal | 1 + src/Control/Monad/Supply/Class.hs | 5 +- src/Language/PureScript/AST/Declarations.hs | 33 +- src/Language/PureScript/AST/Literals.hs | 5 +- src/Language/PureScript/AST/SourcePos.hs | 17 +- src/Language/PureScript/CodeGen/JS.hs | 48 +-- src/Language/PureScript/CodeGen/JS/AST.hs | 28 +- src/Language/PureScript/CodeGen/JS/Common.hs | 90 +++--- .../PureScript/CodeGen/JS/Optimizer/Common.hs | 22 +- .../CodeGen/JS/Optimizer/Inliner.hs | 99 +++--- .../PureScript/CodeGen/JS/Optimizer/TCO.hs | 23 +- src/Language/PureScript/Comments.hs | 5 +- src/Language/PureScript/Constants.hs | 246 +++++++-------- src/Language/PureScript/CoreFn/Expr.hs | 5 +- src/Language/PureScript/CoreFn/ToJSON.hs | 24 +- src/Language/PureScript/Docs/AsMarkdown.hs | 5 +- src/Language/PureScript/Docs/Convert.hs | 3 +- .../PureScript/Docs/Convert/ReExports.hs | 29 +- .../PureScript/Docs/Convert/Single.hs | 38 ++- src/Language/PureScript/Docs/Render.hs | 22 +- .../PureScript/Docs/RenderedCode/Render.hs | 18 +- .../PureScript/Docs/RenderedCode/Types.hs | 4 +- src/Language/PureScript/Docs/Types.hs | 4 +- src/Language/PureScript/Environment.hs | 16 +- src/Language/PureScript/Errors.hs | 283 +++++++++--------- src/Language/PureScript/Errors/JSON.hs | 13 +- src/Language/PureScript/Externs.hs | 16 +- src/Language/PureScript/Ide.hs | 4 +- src/Language/PureScript/Ide/Imports.hs | 10 +- src/Language/PureScript/Interactive.hs | 35 ++- .../PureScript/Interactive/Completion.hs | 10 +- src/Language/PureScript/Interactive/Parser.hs | 3 +- .../PureScript/Interactive/Printer.hs | 25 +- src/Language/PureScript/Linter.hs | 7 +- src/Language/PureScript/Linter/Exhaustive.hs | 11 +- src/Language/PureScript/Linter/Imports.hs | 5 +- src/Language/PureScript/Make.hs | 52 ++-- src/Language/PureScript/Names.hs | 40 +-- src/Language/PureScript/Parser/Common.hs | 21 +- .../PureScript/Parser/Declarations.hs | 12 +- src/Language/PureScript/Parser/Lexer.hs | 152 +++++----- src/Language/PureScript/Parser/Types.hs | 12 +- src/Language/PureScript/Pretty/Common.hs | 48 +-- src/Language/PureScript/Pretty/JS.hs | 87 +++--- src/Language/PureScript/Pretty/Kinds.hs | 8 +- src/Language/PureScript/Pretty/Types.hs | 21 +- src/Language/PureScript/Pretty/Values.hs | 82 ++--- src/Language/PureScript/Renamer.hs | 6 +- .../PureScript/Sugar/ObjectWildcards.hs | 7 +- src/Language/PureScript/Sugar/TypeClasses.hs | 14 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 15 +- src/Language/PureScript/TypeChecker.hs | 19 +- .../PureScript/TypeChecker/Entailment.hs | 16 +- src/Language/PureScript/TypeChecker/Kinds.hs | 15 +- src/Language/PureScript/TypeChecker/Monad.hs | 3 +- .../PureScript/TypeChecker/Skolems.hs | 11 +- src/Language/PureScript/TypeChecker/Types.hs | 13 +- src/Language/PureScript/TypeChecker/Unify.hs | 8 +- src/Language/PureScript/Types.hs | 84 +++--- .../Language/PureScript/Ide/ReexportsSpec.hs | 3 +- tests/TestCompiler.hs | 17 +- tests/TestDocs.hs | 13 +- tests/TestPsci.hs | 5 +- 67 files changed, 1075 insertions(+), 940 deletions(-) diff --git a/examples/passing/StringEscapes.purs b/examples/passing/StringEscapes.purs index 5867819ed7..9c9338bbdc 100644 --- a/examples/passing/StringEscapes.purs +++ b/examples/passing/StringEscapes.purs @@ -13,5 +13,6 @@ main = do assert singleCharacter assert hex assert decimal - assert surrogatePair +-- TODO: Broken in #2418 should be fixed after #2434 is fixed +-- assert surrogatePair log "Done" diff --git a/hierarchy/Main.hs b/hierarchy/Main.hs index 291d4a3c2f..87008708dc 100644 --- a/hierarchy/Main.hs +++ b/hierarchy/Main.hs @@ -25,6 +25,7 @@ import Data.List (intercalate,nub,sort) import Data.Foldable (for_) import Data.Version (showVersion) import Data.Monoid ((<>)) +import qualified Data.Text as T import Options.Applicative (Parser) import qualified Options.Applicative as Opts @@ -56,7 +57,7 @@ instance Ord SuperMap where getCls = either id snd runModuleName :: P.ModuleName -> String -runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns) +runModuleName (P.ModuleName pns) = intercalate "_" ((T.unpack . P.runProperName) `map` pns) readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module]) readInput paths = do diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index 2f5abb45a0..ff557bc7d1 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -8,6 +8,7 @@ import Control.Arrow (first, second) import Control.Category ((>>>)) import Control.Monad.Writer import Data.Text (Text) +import qualified Data.Text as T import Data.Function (on) import Data.List import Data.Maybe (fromMaybe) @@ -82,12 +83,12 @@ docgen (PSCDocsOptions fmt inputGlob output) = do where guardMissing [] = return () guardMissing [mn] = do - hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ P.runModuleName mn ++ "\"") + hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ T.unpack (P.runModuleName mn) ++ "\"") exitFailure guardMissing mns = do hPutStrLn stderr "psc-docs: error: unknown modules:" forM_ mns $ \mn -> - hPutStrLn stderr (" * " ++ P.runModuleName mn) + hPutStrLn stderr (" * " ++ T.unpack (P.runModuleName mn)) exitFailure successOrExit :: Either P.MultipleErrors a -> IO a @@ -186,11 +187,11 @@ parseItem :: String -> DocgenOutputItem parseItem s = case elemIndex ':' s of Just i -> s # splitAt i - >>> first P.moduleNameFromString + >>> first (P.moduleNameFromString . T.pack) >>> second (drop 1) >>> IToFile Nothing -> - IToStdOut (P.moduleNameFromString s) + IToStdOut (P.moduleNameFromString (T.pack s)) where infixr 1 # diff --git a/psc-docs/Tags.hs b/psc-docs/Tags.hs index eb174427ab..8c30eb4072 100644 --- a/psc-docs/Tags.hs +++ b/psc-docs/Tags.hs @@ -1,9 +1,11 @@ module Tags where +import Control.Arrow (first) +import qualified Data.Text as T import qualified Language.PureScript as P tags :: P.Module -> [(String, Int)] -tags = concatMap dtags . P.exportedDeclarations +tags = map (first T.unpack) . concatMap dtags . P.exportedDeclarations where dtags (P.PositionedDeclaration sp _ d) = map tag $ names d where tag name = (name, line) line = P.sourcePosLine $ P.spanStart sp diff --git a/purescript.cabal b/purescript.cabal index 79e2814e4d..4f4fcabd17 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -312,6 +312,7 @@ library PatternSynonyms RankNTypes RecordWildCards + OverloadedStrings ScopedTypeVariables TupleSections ViewPatterns diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index c938bcfcd2..64038a6aac 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -12,6 +12,7 @@ import Prelude.Compat import Control.Monad.Supply import Control.Monad.State import Control.Monad.Writer +import Data.Text (Text, pack) class Monad m => MonadSupply m where fresh :: m Integer @@ -31,5 +32,5 @@ instance Monad m => MonadSupply (SupplyT m) where instance MonadSupply m => MonadSupply (StateT s m) instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m) -freshName :: MonadSupply m => m String -freshName = fmap (('$' :) . show) fresh +freshName :: MonadSupply m => m Text +freshName = fmap (("$" <> ) . pack . show) fresh diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 2eb7e74be9..9029b1a4c2 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -11,6 +11,7 @@ import Control.Monad.Identity import Data.Aeson.TH import qualified Data.Map as M +import Data.Text (Text) import Language.PureScript.AST.Binders import Language.PureScript.AST.Literals @@ -47,7 +48,7 @@ data SimpleErrorMessage | UnnecessaryFFIModule ModuleName FilePath | MissingFFIImplementations ModuleName [Ident] | UnusedFFIImplementations ModuleName [Ident] - | InvalidFFIIdentifier ModuleName String + | InvalidFFIIdentifier ModuleName Text | CannotGetFileInfo FilePath | CannotReadFile FilePath | CannotWriteFile FilePath @@ -68,7 +69,7 @@ data SimpleErrorMessage | DeclConflict Name Name | ExportConflict (Qualified Name) (Qualified Name) | DuplicateModule ModuleName [SourceSpan] - | DuplicateTypeArgument String + | DuplicateTypeArgument Text | InvalidDoBind | InvalidDoLet | CycleInDeclaration Ident @@ -89,7 +90,7 @@ data SimpleErrorMessage | CannotDerive (Qualified (ProperName 'ClassName)) [Type] | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type] | CannotFindDerivingType (ProperName 'TypeName) - | DuplicateLabel String (Maybe Expr) + | DuplicateLabel Text (Maybe Expr) | DuplicateValueDeclaration Ident | ArgListLengthsDiffer Ident | OverlappingArgNames (Maybe Ident) @@ -98,8 +99,8 @@ data SimpleErrorMessage | ExpectedType Type Kind | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName)) | ExprDoesNotHaveType Expr Type - | PropertyIsMissing String - | AdditionalProperty String + | PropertyIsMissing Text + | AdditionalProperty Text | TypeSynonymInstance | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type] | InvalidNewtype (ProperName 'TypeName) @@ -107,10 +108,10 @@ data SimpleErrorMessage | TransitiveExportError DeclarationRef [DeclarationRef] | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName) | ShadowedName Ident - | ShadowedTypeVar String - | UnusedTypeVar String + | ShadowedTypeVar Text + | UnusedTypeVar Text | WildcardInferredType Type Context - | HoleInferredType String Type Context TypeSearch + | HoleInferredType Text Type Context TypeSearch | MissingTypeDeclaration Ident Type | OverlappingPattern [[Binder]] Bool | IncompleteExhaustivityCheck @@ -124,7 +125,7 @@ data SimpleErrorMessage | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) | DuplicateImportRef Name | DuplicateExportRef Name - | IntOutOfRange Integer String Integer Integer + | IntOutOfRange Integer Text Integer Integer | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef] | ImplicitImport ModuleName [DeclarationRef] | HidingImport ModuleName [DeclarationRef] @@ -144,7 +145,7 @@ data ErrorMessageHint | ErrorInModule ModuleName | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type] | ErrorInSubsumption Type Type - | ErrorCheckingAccessor Expr String + | ErrorCheckingAccessor Expr Text | ErrorCheckingType Expr Type | ErrorCheckingKind Type | ErrorCheckingGuard @@ -350,7 +351,7 @@ data Declaration -- | -- A data type declaration (data or newtype, name, arguments, data constructors) -- - = DataDeclaration DataDeclType (ProperName 'TypeName) [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])] + = DataDeclaration DataDeclType (ProperName 'TypeName) [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])] -- | -- A minimal mutually recursive set of data type declarations -- @@ -358,7 +359,7 @@ data Declaration -- | -- A type synonym declaration (name, arguments, type) -- - | TypeSynonymDeclaration (ProperName 'TypeName) [(String, Maybe Kind)] Type + | TypeSynonymDeclaration (ProperName 'TypeName) [(Text, Maybe Kind)] Type -- | -- A type declaration for a value (name, ty) -- @@ -390,7 +391,7 @@ data Declaration -- | -- A type class declaration (name, argument, implies, member declarations) -- - | TypeClassDeclaration (ProperName 'ClassName) [(String, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration] + | TypeClassDeclaration (ProperName 'ClassName) [(Text, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration] -- | -- A type instance declaration (name, dependencies, class name, instance types, member -- declarations) @@ -548,11 +549,11 @@ data Expr -- Anonymous arguments will be removed during desugaring and expanded -- into a lambda that reads a property from a record. -- - | Accessor String Expr + | Accessor Text Expr -- | -- Partial record update -- - | ObjectUpdate Expr [(String, Expr)] + | ObjectUpdate Expr [(Text, Expr)] -- | -- Function introduction -- @@ -625,7 +626,7 @@ data Expr -- | -- A typed hole that will be turned into a hint/error duing typechecking -- - | Hole String + | Hole Text -- | -- A value with source position information -- diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs index 01da91dc64..3a456237af 100644 --- a/src/Language/PureScript/AST/Literals.hs +++ b/src/Language/PureScript/AST/Literals.hs @@ -4,6 +4,7 @@ module Language.PureScript.AST.Literals where import Prelude.Compat +import Data.Text (Text) -- | -- Data type for literal values. Parameterised so it can be used for Exprs and @@ -17,7 +18,7 @@ data Literal a -- | -- A string literal -- - | StringLiteral String + | StringLiteral Text -- | -- A character literal -- @@ -33,5 +34,5 @@ data Literal a -- | -- An object literal -- - | ObjectLiteral [(String, a)] + | ObjectLiteral [(Text, a)] deriving (Eq, Ord, Show, Functor) diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 266a94e056..2b238a1466 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -9,6 +9,9 @@ import Prelude.Compat import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A +import Data.Monoid +import qualified Data.Text as T +import Data.Text (Text) -- | -- Source position information @@ -24,10 +27,10 @@ data SourcePos = SourcePos , sourcePosColumn :: Int } deriving (Show, Eq, Ord) -displaySourcePos :: SourcePos -> String +displaySourcePos :: SourcePos -> Text displaySourcePos sp = - "line " ++ show (sourcePosLine sp) ++ - ", column " ++ show (sourcePosColumn sp) + "line " <> T.pack (show (sourcePosLine sp)) <> + ", column " <> T.pack (show (sourcePosColumn sp)) instance A.ToJSON SourcePos where toJSON SourcePos{..} = @@ -52,14 +55,14 @@ data SourceSpan = SourceSpan , spanEnd :: SourcePos } deriving (Show, Eq, Ord) -displayStartEndPos :: SourceSpan -> String +displayStartEndPos :: SourceSpan -> Text displayStartEndPos sp = - displaySourcePos (spanStart sp) ++ " - " ++ + displaySourcePos (spanStart sp) <> " - " <> displaySourcePos (spanEnd sp) -displaySourceSpan :: SourceSpan -> String +displaySourceSpan :: SourceSpan -> Text displaySourceSpan sp = - spanName sp ++ " " ++ + T.pack (spanName sp) <> " " <> displayStartEndPos sp instance A.ToJSON SourceSpan where diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 94b5c5e8c9..2625a6afd0 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -10,16 +10,18 @@ module Language.PureScript.CodeGen.JS import Prelude.Compat import Control.Arrow ((&&&)) -import Control.Monad (replicateM, forM, void) -import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad (forM, replicateM, void) +import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class import Data.List ((\\), delete, intersect, nub) -import Data.Maybe (isNothing, fromMaybe) import qualified Data.Foldable as F import qualified Data.Map as M -import qualified Data.Traversable as T +import Data.Maybe (fromMaybe, isNothing) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.AST.SourcePos import Language.PureScript.CodeGen.JS.AST as AST @@ -51,10 +53,10 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps - jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ nub $ map snd imps + jsImports <- traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ nub $ map snd imps let decls' = renameModules mnLookup decls jsDecls <- mapM bindToJs decls' - optimized <- T.traverse (T.traverse optimize) jsDecls + optimized <- traverse (traverse optimize) jsDecls F.traverse_ (F.traverse_ checkIntegers) optimized comments <- not <$> asks optionsNoComments let strict = JSStringLiteral Nothing "use strict" @@ -94,7 +96,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName freshModuleName i mn'@(ModuleName pns) used = - let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) ++ "_" ++ show i] + let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) <> "_" <> T.pack (show i)] in if Ident (runModuleName newName) `elem` used then freshModuleName (i + 1) mn' used else newName @@ -106,7 +108,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS importToJs mnLookup mn' = do let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (".." runModuleName mn')] + let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (T.pack (".." T.unpack (runModuleName mn')))] withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody) -- | @@ -177,7 +179,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = accessor (Ident prop) = accessorString prop accessor (GenIdent _ _) = internalError "GenIdent in accessor" - accessorString :: String -> JS -> JS + accessorString :: Text -> JS -> JS accessorString prop | identNeedsEscaping prop = JSIndexer Nothing (JSStringLiteral Nothing prop) | otherwise = JSAccessor Nothing prop @@ -234,7 +236,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = then foreignIdent ident else varToJs qi valueToJs' (Var (_, _, _, Just IsForeign) ident) = - error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident + internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident) valueToJs' (Var _ ident) = return $ varToJs ident valueToJs' (Case (maybeSpan, _, _, _) values binders) = do vals <- mapM valueToJs values @@ -263,14 +265,14 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing (properToJs ctor))) createFn ] - iife :: String -> [JS] -> JS + iife :: Text -> [JS] -> JS iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) [] literalToValueJS :: Literal (Expr Ann) -> m JS literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i) literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n) literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s - literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing [c] + literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing (T.singleton c) literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps @@ -278,7 +280,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- | -- Shallow copy an object. -- - extendObj :: JS -> [(String, JS)] -> m JS + extendObj :: JS -> [(Text, JS)] -> m JS extendObj obj sts = do newObj <- freshName key <- freshName @@ -331,20 +333,20 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (assignments ++ concat jss ++ [JSThrow Nothing $ failedPatternError valNames]))) [] where - go :: [String] -> [JS] -> [Binder Ann] -> m [JS] + go :: [Text] -> [JS] -> [Binder Ann] -> m [JS] go _ done [] = return done go (v:vs) done' (b:bs) = do done'' <- go vs done' bs binderToJs v done'' b go _ _ _ = internalError "Invalid arguments to bindersToJs" - failedPatternError :: [String] -> JS + failedPatternError :: [Text] -> JS failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)] - failedPatternMessage :: String - failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": " + failedPatternMessage :: Text + failedPatternMessage = "Failed pattern match" <> maybe "" (((" at " <> runModuleName mn <> " ") <>) . displayStartEndPos) maybeSpan <> ": " - valueError :: String -> JS -> JS + valueError :: Text -> JS -> JS valueError _ l@(JSNumericLiteral _ _) = l valueError _ l@(JSStringLiteral _ _) = l valueError _ l@(JSBooleanLiteral _ _) = l @@ -357,7 +359,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = return $ JSIfElse Nothing cond' (JSBlock Nothing [JSReturn Nothing done]) Nothing guardsToJs (Right v) = return . JSReturn Nothing <$> valueToJs v - binderToJs :: String -> [JS] -> Binder Ann -> m [JS] + binderToJs :: Text -> [JS] -> Binder Ann -> m [JS] binderToJs s done binder = let (ss, _, _, _) = extractBinderAnn binder in traverse (withPos ss) =<< binderToJs' s done binder @@ -366,7 +368,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- Generate code in the simplified Javascript intermediate representation for a pattern match -- binder. -- - binderToJs' :: String -> [JS] -> Binder Ann -> m [JS] + binderToJs' :: Text -> [JS] -> Binder Ann -> m [JS] binderToJs' _ done NullBinder{} = return done binderToJs' varName done (LiteralBinder _ l) = literalToBinderJS varName done l @@ -396,11 +398,11 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = js <- binderToJs varName done binder return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : js) - literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS] + literalToBinderJS :: Text -> [JS] -> Literal (Binder Ann) -> m [JS] literalToBinderJS varName done (NumericLiteral num) = return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSNumericLiteral Nothing num)) (JSBlock Nothing done) Nothing] literalToBinderJS varName done (CharLiteral c) = - return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing [c])) (JSBlock Nothing done) Nothing] + return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing (T.singleton c))) (JSBlock Nothing done) Nothing] literalToBinderJS varName done (StringLiteral str) = return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing str)) (JSBlock Nothing done) Nothing] literalToBinderJS varName done (BooleanLiteral True) = @@ -409,7 +411,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = return [JSIfElse Nothing (JSUnary Nothing Not (JSVar Nothing varName)) (JSBlock Nothing done) Nothing] literalToBinderJS varName done (ObjectLiteral bs) = go done bs where - go :: [JS] -> [(String, Binder Ann)] -> m [JS] + go :: [JS] -> [(Text, Binder Ann)] -> m [JS] go done' [] = return done' go done' ((prop, binder):bs') = do propVar <- freshName diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index b6e1b8a1c5..5f124dd201 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -5,7 +5,9 @@ module Language.PureScript.CodeGen.JS.AST where import Prelude.Compat -import Control.Monad.Identity +import Control.Monad ((>=>)) +import Control.Monad.Identity (Identity(..), runIdentity) +import Data.Text (Text) import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.Comments @@ -130,7 +132,7 @@ data JS -- | -- A string literal -- - | JSStringLiteral (Maybe SourceSpan) String + | JSStringLiteral (Maybe SourceSpan) Text -- | -- A boolean literal -- @@ -154,15 +156,15 @@ data JS -- | -- An object literal -- - | JSObjectLiteral (Maybe SourceSpan) [(String, JS)] + | JSObjectLiteral (Maybe SourceSpan) [(Text, JS)] -- | -- An object property accessor expression -- - | JSAccessor (Maybe SourceSpan) String JS + | JSAccessor (Maybe SourceSpan) Text JS -- | -- A function introduction (optional name, arguments, body) -- - | JSFunction (Maybe SourceSpan) (Maybe String) [String] JS + | JSFunction (Maybe SourceSpan) (Maybe Text) [Text] JS -- | -- Function application -- @@ -170,7 +172,7 @@ data JS -- | -- Variable -- - | JSVar (Maybe SourceSpan) String + | JSVar (Maybe SourceSpan) Text -- | -- Conditional expression -- @@ -182,7 +184,7 @@ data JS -- | -- A variable introduction and optional initialization -- - | JSVariableIntroduction (Maybe SourceSpan) String (Maybe JS) + | JSVariableIntroduction (Maybe SourceSpan) Text (Maybe JS) -- | -- A variable assignment -- @@ -194,11 +196,11 @@ data JS -- | -- For loop -- - | JSFor (Maybe SourceSpan) String JS JS JS + | JSFor (Maybe SourceSpan) Text JS JS JS -- | -- ForIn loop -- - | JSForIn (Maybe SourceSpan) String JS JS + | JSForIn (Maybe SourceSpan) Text JS JS -- | -- If-then-else statement -- @@ -222,19 +224,19 @@ data JS -- | -- Labelled statement -- - | JSLabel (Maybe SourceSpan) String JS + | JSLabel (Maybe SourceSpan) Text JS -- | -- Break statement -- - | JSBreak (Maybe SourceSpan) String + | JSBreak (Maybe SourceSpan) Text -- | -- Continue statement -- - | JSContinue (Maybe SourceSpan) String + | JSContinue (Maybe SourceSpan) Text -- | -- Raw Javascript (generated when parsing fails for an inline foreign import declaration) -- - | JSRaw (Maybe SourceSpan) String + | JSRaw (Maybe SourceSpan) Text -- | -- Commented Javascript -- diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 758e23552f..fd6cea8e63 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -6,15 +6,17 @@ module Language.PureScript.CodeGen.JS.Common where import Prelude.Compat import Data.Char -import Data.List (intercalate) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.Crash import Language.PureScript.Names -moduleNameToJs :: ModuleName -> String +moduleNameToJs :: ModuleName -> Text moduleNameToJs (ModuleName pns) = - let name = intercalate "_" (runProperName `map` pns) - in if nameIsJsBuiltIn name then "$$" ++ name else name + let name = T.intercalate "_" (runProperName `map` pns) + in if nameIsJsBuiltIn name then "$$" <> name else name -- | -- Convert an Ident into a valid Javascript identifier: @@ -25,62 +27,62 @@ moduleNameToJs (ModuleName pns) = -- -- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value. -- -identToJs :: Ident -> String +identToJs :: Ident -> Text identToJs (Ident name) = properToJs name identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" -properToJs :: String -> String +properToJs :: Text -> Text properToJs name - | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" ++ name - | otherwise = concatMap identCharToString name + | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" <> name + | otherwise = T.concatMap identCharToText name -- | -- Test if a string is a valid JS identifier without escaping. -- -identNeedsEscaping :: String -> Bool -identNeedsEscaping s = s /= identToJs (Ident s) || null s +identNeedsEscaping :: Text -> Bool +identNeedsEscaping s = s /= identToJs (Ident s) || T.null s -- | -- Attempts to find a human-readable name for a symbol, if none has been specified returns the -- ordinal value. -- -identCharToString :: Char -> String -identCharToString c | isAlphaNum c = [c] -identCharToString '_' = "_" -identCharToString '.' = "$dot" -identCharToString '$' = "$dollar" -identCharToString '~' = "$tilde" -identCharToString '=' = "$eq" -identCharToString '<' = "$less" -identCharToString '>' = "$greater" -identCharToString '!' = "$bang" -identCharToString '#' = "$hash" -identCharToString '%' = "$percent" -identCharToString '^' = "$up" -identCharToString '&' = "$amp" -identCharToString '|' = "$bar" -identCharToString '*' = "$times" -identCharToString '/' = "$div" -identCharToString '+' = "$plus" -identCharToString '-' = "$minus" -identCharToString ':' = "$colon" -identCharToString '\\' = "$bslash" -identCharToString '?' = "$qmark" -identCharToString '@' = "$at" -identCharToString '\'' = "$prime" -identCharToString c = '$' : show (ord c) +identCharToText :: Char -> Text +identCharToText c | isAlphaNum c = T.singleton c +identCharToText '_' = "_" +identCharToText '.' = "$dot" +identCharToText '$' = "$dollar" +identCharToText '~' = "$tilde" +identCharToText '=' = "$eq" +identCharToText '<' = "$less" +identCharToText '>' = "$greater" +identCharToText '!' = "$bang" +identCharToText '#' = "$hash" +identCharToText '%' = "$percent" +identCharToText '^' = "$up" +identCharToText '&' = "$amp" +identCharToText '|' = "$bar" +identCharToText '*' = "$times" +identCharToText '/' = "$div" +identCharToText '+' = "$plus" +identCharToText '-' = "$minus" +identCharToText ':' = "$colon" +identCharToText '\\' = "$bslash" +identCharToText '?' = "$qmark" +identCharToText '@' = "$at" +identCharToText '\'' = "$prime" +identCharToText c = '$' `T.cons` T.pack (show (ord c)) -- | -- Checks whether an identifier name is reserved in Javascript. -- -nameIsJsReserved :: String -> Bool +nameIsJsReserved :: Text -> Bool nameIsJsReserved name = name `elem` jsAnyReserved -- | -- Checks whether a name matches a built-in value in Javascript. -- -nameIsJsBuiltIn :: String -> Bool +nameIsJsBuiltIn :: Text -> Bool nameIsJsBuiltIn name = name `elem` [ "arguments" @@ -138,7 +140,7 @@ nameIsJsBuiltIn name = , "WeakSet" ] -jsAnyReserved :: [String] +jsAnyReserved :: [Text] jsAnyReserved = concat [ jsKeywords @@ -149,7 +151,7 @@ jsAnyReserved = , jsLiterals ] -jsKeywords :: [String] +jsKeywords :: [Text] jsKeywords = [ "break" , "case" @@ -185,7 +187,7 @@ jsKeywords = , "with" ] -jsSometimesReserved :: [String] +jsSometimesReserved :: [Text] jsSometimesReserved = [ "await" , "let" @@ -193,11 +195,11 @@ jsSometimesReserved = , "yield" ] -jsFutureReserved :: [String] +jsFutureReserved :: [Text] jsFutureReserved = [ "enum" ] -jsFutureReservedStrict :: [String] +jsFutureReservedStrict :: [Text] jsFutureReservedStrict = [ "implements" , "interface" @@ -207,7 +209,7 @@ jsFutureReservedStrict = , "public" ] -jsOldReserved :: [String] +jsOldReserved :: [Text] jsOldReserved = [ "abstract" , "boolean" @@ -227,7 +229,7 @@ jsOldReserved = , "volatile" ] -jsLiterals :: [String] +jsLiterals :: [Text] jsLiterals = [ "null" , "true" diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs index a7ed7fb776..01a41caea0 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs @@ -5,27 +5,29 @@ module Language.PureScript.CodeGen.JS.Optimizer.Common where import Prelude.Compat +import Data.Text (Text) +import Data.List (foldl') import Data.Maybe (fromMaybe) import Language.PureScript.Crash import Language.PureScript.CodeGen.JS.AST applyAll :: [a -> a] -> a -> a -applyAll = foldl1 (.) +applyAll = foldl' (.) id -replaceIdent :: String -> JS -> JS -> JS +replaceIdent :: Text -> JS -> JS -> JS replaceIdent var1 js = everywhereOnJS replace where replace (JSVar _ var2) | var1 == var2 = js replace other = other -replaceIdents :: [(String, JS)] -> JS -> JS +replaceIdents :: [(Text, JS)] -> JS -> JS replaceIdents vars = everywhereOnJS replace where replace v@(JSVar _ var) = fromMaybe v $ lookup var vars replace other = other -isReassigned :: String -> JS -> Bool +isReassigned :: Text -> JS -> Bool isReassigned var1 = everythingOnJS (||) check where check :: JS -> Bool @@ -42,7 +44,7 @@ isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS ( variablesOf (JSVar _ var) = [var] variablesOf _ = [] -isUsed :: String -> JS -> Bool +isUsed :: Text -> JS -> Bool isUsed var1 = everythingOnJS (||) check where check :: JS -> Bool @@ -50,13 +52,13 @@ isUsed var1 = everythingOnJS (||) check check (JSAssignment _ target _) | var1 == targetVariable target = True check _ = False -targetVariable :: JS -> String +targetVariable :: JS -> Text targetVariable (JSVar _ var) = var targetVariable (JSAccessor _ _ tgt) = targetVariable tgt targetVariable (JSIndexer _ _ tgt) = targetVariable tgt targetVariable _ = internalError "Invalid argument to targetVariable" -isUpdated :: String -> JS -> Bool +isUpdated :: Text -> JS -> Bool isUpdated var1 = everythingOnJS (||) check where check :: JS -> Bool @@ -67,16 +69,16 @@ removeFromBlock :: ([JS] -> [JS]) -> JS -> JS removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts) removeFromBlock _ js = js -isFn :: (String, String) -> JS -> Bool +isFn :: (Text, Text) -> JS -> Bool isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) = x == fnName && y == moduleName isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = x == fnName && y == moduleName isFn _ _ = False -isDict :: (String, String) -> JS -> Bool +isDict :: (Text, Text) -> JS -> Bool isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName isDict _ _ = False -isDict' :: [(String, String)] -> JS -> Bool +isDict' :: [(Text, Text)] -> JS -> Bool isDict' xs js = any (`isDict` js) xs diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index ff8c7c366f..fdc482a385 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -16,6 +16,9 @@ import Prelude.Compat import Control.Monad.Supply.Class (MonadSupply, freshName) import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Optimizer.Common @@ -164,25 +167,25 @@ inlineCommonOperators = applyAll $ ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] where - binary :: (String, String) -> (String, String) -> BinaryOperator -> JS -> JS + binary :: (Text, Text) -> (Text, Text) -> BinaryOperator -> JS -> JS binary dict fns op = everywhereOnJS convert where convert :: JS -> JS convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isFn fns fn = JSBinary ss op x y convert other = other - binary' :: String -> String -> BinaryOperator -> JS -> JS + binary' :: Text -> Text -> BinaryOperator -> JS -> JS binary' moduleName opString op = everywhereOnJS convert where convert :: JS -> JS convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y convert other = other - unary :: (String, String) -> (String, String) -> UnaryOperator -> JS -> JS + unary :: (Text, Text) -> (Text, Text) -> UnaryOperator -> JS -> JS unary dicts fns op = everywhereOnJS convert where convert :: JS -> JS convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isFn fns fn = JSUnary ss op x convert other = other - unary' :: String -> String -> UnaryOperator -> JS -> JS + unary' :: Text -> Text -> UnaryOperator -> JS -> JS unary' moduleName fnName op = everywhereOnJS convert where convert :: JS -> JS @@ -203,14 +206,14 @@ inlineCommonOperators = applyAll $ Just (args, js) -> JSFunction ss Nothing args (JSBlock ss js) Nothing -> orig convert other = other - collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS]) + collectArgs :: Int -> [Text] -> JS -> Maybe ([Text], [JS]) collectArgs 1 acc (JSFunction _ Nothing [oneArg] (JSBlock _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js) collectArgs m acc (JSFunction _ Nothing [oneArg] (JSBlock _ [JSReturn _ ret])) = collectArgs (m - 1) (oneArg : acc) ret collectArgs _ _ _ = Nothing - isNFn :: String -> Int -> JS -> Bool - isNFn prefix n (JSVar _ name) = name == (prefix ++ show n) - isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix ++ show n) + isNFn :: Text -> Int -> JS -> Bool + isNFn prefix n (JSVar _ name) = name == (prefix <> T.pack (show n)) + isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix <> T.pack (show n)) isNFn _ _ _ = False runFn :: Int -> JS -> JS @@ -231,11 +234,11 @@ inlineCommonOperators = applyAll $ convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y convert other = other - isModFn :: (String, String) -> JS -> Bool + isModFn :: (Text, Text) -> JS -> Bool isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op' isModFn _ _ = False - isModFnWithDict :: (String, String) -> JS -> Bool + isModFnWithDict :: (Text, Text) -> JS -> Bool isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [(JSVar _ _)]) = m == m' && op == op' isModFnWithDict _ _ = False @@ -260,115 +263,115 @@ inlineFnComposition = everywhereOnJSTopDownM convert isFnCompose dict' fn = isDict semigroupoidFn dict' && isFn fnCompose fn isFnComposeFlipped :: JS -> JS -> Bool isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isFn fnComposeFlipped fn - fnCompose :: (String, String) + fnCompose :: (Text, Text) fnCompose = (C.controlSemigroupoid, C.compose) - fnComposeFlipped :: (String, String) + fnComposeFlipped :: (Text, Text) fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped) -semiringNumber :: (String, String) +semiringNumber :: (Text, Text) semiringNumber = (C.dataSemiring, C.semiringNumber) -semiringInt :: (String, String) +semiringInt :: (Text, Text) semiringInt = (C.dataSemiring, C.semiringInt) -ringNumber :: (String, String) +ringNumber :: (Text, Text) ringNumber = (C.dataRing, C.ringNumber) -ringInt :: (String, String) +ringInt :: (Text, Text) ringInt = (C.dataRing, C.ringInt) -euclideanRingNumber :: (String, String) +euclideanRingNumber :: (Text, Text) euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber) -euclideanRingInt :: (String, String) +euclideanRingInt :: (Text, Text) euclideanRingInt = (C.dataEuclideanRing, C.euclideanRingInt) -eqNumber :: (String, String) +eqNumber :: (Text, Text) eqNumber = (C.dataEq, C.eqNumber) -eqInt :: (String, String) +eqInt :: (Text, Text) eqInt = (C.dataEq, C.eqInt) -eqString :: (String, String) +eqString :: (Text, Text) eqString = (C.dataEq, C.eqString) -eqChar :: (String, String) +eqChar :: (Text, Text) eqChar = (C.dataEq, C.eqChar) -eqBoolean :: (String, String) +eqBoolean :: (Text, Text) eqBoolean = (C.dataEq, C.eqBoolean) -ordBoolean :: (String, String) +ordBoolean :: (Text, Text) ordBoolean = (C.dataOrd, C.ordBoolean) -ordNumber :: (String, String) +ordNumber :: (Text, Text) ordNumber = (C.dataOrd, C.ordNumber) -ordInt :: (String, String) +ordInt :: (Text, Text) ordInt = (C.dataOrd, C.ordInt) -ordString :: (String, String) +ordString :: (Text, Text) ordString = (C.dataOrd, C.ordString) -ordChar :: (String, String) +ordChar :: (Text, Text) ordChar = (C.dataOrd, C.ordChar) -semigroupString :: (String, String) +semigroupString :: (Text, Text) semigroupString = (C.dataSemigroup, C.semigroupString) -boundedBoolean :: (String, String) +boundedBoolean :: (Text, Text) boundedBoolean = (C.dataBounded, C.boundedBoolean) -heytingAlgebraBoolean :: (String, String) +heytingAlgebraBoolean :: (Text, Text) heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean) -semigroupoidFn :: (String, String) +semigroupoidFn :: (Text, Text) semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn) -opAdd :: (String, String) +opAdd :: (Text, Text) opAdd = (C.dataSemiring, C.add) -opMul :: (String, String) +opMul :: (Text, Text) opMul = (C.dataSemiring, C.mul) -opEq :: (String, String) +opEq :: (Text, Text) opEq = (C.dataEq, C.eq) -opNotEq :: (String, String) +opNotEq :: (Text, Text) opNotEq = (C.dataEq, C.notEq) -opLessThan :: (String, String) +opLessThan :: (Text, Text) opLessThan = (C.dataOrd, C.lessThan) -opLessThanOrEq :: (String, String) +opLessThanOrEq :: (Text, Text) opLessThanOrEq = (C.dataOrd, C.lessThanOrEq) -opGreaterThan :: (String, String) +opGreaterThan :: (Text, Text) opGreaterThan = (C.dataOrd, C.greaterThan) -opGreaterThanOrEq :: (String, String) +opGreaterThanOrEq :: (Text, Text) opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq) -opAppend :: (String, String) +opAppend :: (Text, Text) opAppend = (C.dataSemigroup, C.append) -opSub :: (String, String) +opSub :: (Text, Text) opSub = (C.dataRing, C.sub) -opNegate :: (String, String) +opNegate :: (Text, Text) opNegate = (C.dataRing, C.negate) -opDiv :: (String, String) +opDiv :: (Text, Text) opDiv = (C.dataEuclideanRing, C.div) -opMod :: (String, String) +opMod :: (Text, Text) opMod = (C.dataEuclideanRing, C.mod) -opConj :: (String, String) +opConj :: (Text, Text) opConj = (C.dataHeytingAlgebra, C.conj) -opDisj :: (String, String) +opDisj :: (Text, Text) opDisj = (C.dataHeytingAlgebra, C.disj) -opNot :: (String, String) +opNot :: (Text, Text) opNot = (C.dataHeytingAlgebra, C.not) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs index c1b261ead9..0a3850d01e 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs @@ -5,7 +5,8 @@ module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where import Prelude.Compat -import Data.Monoid +import Data.Text (Text) +import Data.Monoid ((<>), getAny, Any(..)) import Language.PureScript.Options import Language.PureScript.CodeGen.JS.AST @@ -20,14 +21,14 @@ tco opts | optionsNoTco opts = id tco' :: JS -> JS tco' = everywhereOnJS convert where - tcoLabel :: String + tcoLabel :: Text tcoLabel = "tco" - tcoVar :: String -> String - tcoVar arg = "__tco_" ++ arg + tcoVar :: Text -> Text + tcoVar arg = "__tco_" <> arg - copyVar :: String -> String - copyVar arg = "__copy_" ++ arg + copyVar :: Text -> Text + copyVar arg = "__copy_" <> arg convert :: JS -> JS convert js@(JSVariableIntroduction ss name (Just fn@JSFunction {})) = @@ -42,7 +43,7 @@ tco' = everywhereOnJS convert | otherwise -> js convert js = js - collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS) + collectAllFunctionArgs :: [[Text]] -> (JS -> JS) -> JS -> ([[Text]], JS, JS -> JS) collectAllFunctionArgs allArgs f (JSFunction s1 ident args (JSBlock s2 (body@(JSReturn _ _):_))) = collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction s1 ident (map copyVar args) (JSBlock s2 [b]))) body collectAllFunctionArgs allArgs f (JSFunction ss ident args body@(JSBlock _ _)) = @@ -53,7 +54,7 @@ tco' = everywhereOnJS convert (args : allArgs, body, f . JSReturn s1 . JSFunction s2 ident (map copyVar args)) collectAllFunctionArgs allArgs f body = (allArgs, body, f) - isTailCall :: String -> JS -> Bool + isTailCall :: Text -> JS -> Bool isTailCall ident js = let numSelfCalls = everythingOnJS (+) countSelfCalls js @@ -81,7 +82,7 @@ tco' = everywhereOnJS convert countSelfCallsWithFnArgs :: JS -> Int countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0 - toLoop :: String -> [String] -> JS -> JS + toLoop :: Text -> [Text] -> JS -> JS toLoop ident allArgs js = JSBlock rootSS $ map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs ++ [ JSLabel rootSS tcoLabel $ JSWhile rootSS (JSBooleanLiteral rootSS True) (JSBlock rootSS [ everywhereOnJS loopify js ]) ] @@ -103,12 +104,12 @@ tco' = everywhereOnJS convert collectSelfCallArgs allArgumentValues (JSApp _ fn args') = collectSelfCallArgs (args' : allArgumentValues) fn collectSelfCallArgs allArgumentValues _ = allArgumentValues - isSelfCall :: String -> JS -> Bool + isSelfCall :: Text -> JS -> Bool isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident' isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn isSelfCall _ _ = False - isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool + isSelfCallWithFnArgs :: Text -> JS -> [JS] -> Bool isSelfCallWithFnArgs ident (JSVar _ ident') args | ident == ident' && any hasFunction args = True isSelfCallWithFnArgs ident (JSApp _ fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc) isSelfCallWithFnArgs _ _ _ = False diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs index 15356eb06c..fd8f678207 100644 --- a/src/Language/PureScript/Comments.hs +++ b/src/Language/PureScript/Comments.hs @@ -6,12 +6,13 @@ module Language.PureScript.Comments where import Prelude.Compat +import Data.Text (Text) import Data.Aeson.TH data Comment - = LineComment String - | BlockComment String + = LineComment Text + | BlockComment Text deriving (Show, Eq, Ord) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index c4d63ba748..a472387c78 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -2,316 +2,316 @@ module Language.PureScript.Constants where import Prelude.Compat - +import Data.Text (Text) import Language.PureScript.Names -- Operators -($) :: String +($) :: Text ($) = "$" -apply :: String +apply :: Text apply = "apply" -(#) :: String +(#) :: Text (#) = "#" -applyFlipped :: String +applyFlipped :: Text applyFlipped = "applyFlipped" -(<>) :: String +(<>) :: Text (<>) = "<>" -(++) :: String +(++) :: Text (++) = "++" -append :: String +append :: Text append = "append" -(>>=) :: String +(>>=) :: Text (>>=) = ">>=" -bind :: String +bind :: Text bind = "bind" -(+) :: String +(+) :: Text (+) = "+" -add :: String +add :: Text add = "add" -(-) :: String +(-) :: Text (-) = "-" -sub :: String +sub :: Text sub = "sub" -(*) :: String +(*) :: Text (*) = "*" -mul :: String +mul :: Text mul = "mul" -(/) :: String +(/) :: Text (/) = "/" -div :: String +div :: Text div = "div" -(%) :: String +(%) :: Text (%) = "%" -mod :: String +mod :: Text mod = "mod" -(<) :: String +(<) :: Text (<) = "<" -lessThan :: String +lessThan :: Text lessThan = "lessThan" -(>) :: String +(>) :: Text (>) = ">" -greaterThan :: String +greaterThan :: Text greaterThan = "greaterThan" -(<=) :: String +(<=) :: Text (<=) = "<=" -lessThanOrEq :: String +lessThanOrEq :: Text lessThanOrEq = "lessThanOrEq" -(>=) :: String +(>=) :: Text (>=) = ">=" -greaterThanOrEq :: String +greaterThanOrEq :: Text greaterThanOrEq = "greaterThanOrEq" -(==) :: String +(==) :: Text (==) = "==" -eq :: String +eq :: Text eq = "eq" -(/=) :: String +(/=) :: Text (/=) = "/=" -notEq :: String +notEq :: Text notEq = "notEq" -compare :: String +compare :: Text compare = "compare" -(&&) :: String +(&&) :: Text (&&) = "&&" -conj :: String +conj :: Text conj = "conj" -(||) :: String +(||) :: Text (||) = "||" -disj :: String +disj :: Text disj = "disj" -unsafeIndex :: String +unsafeIndex :: Text unsafeIndex = "unsafeIndex" -or :: String +or :: Text or = "or" -and :: String +and :: Text and = "and" -xor :: String +xor :: Text xor = "xor" -(<<<) :: String +(<<<) :: Text (<<<) = "<<<" -compose :: String +compose :: Text compose = "compose" -(>>>) :: String +(>>>) :: Text (>>>) = ">>>" -composeFlipped :: String +composeFlipped :: Text composeFlipped = "composeFlipped" -- Functions -negate :: String +negate :: Text negate = "negate" -not :: String +not :: Text not = "not" -shl :: String +shl :: Text shl = "shl" -shr :: String +shr :: Text shr = "shr" -zshr :: String +zshr :: Text zshr = "zshr" -complement :: String +complement :: Text complement = "complement" -- Prelude Values -zero :: String +zero :: Text zero = "zero" -one :: String +one :: Text one = "one" -bottom :: String +bottom :: Text bottom = "bottom" -top :: String +top :: Text top = "top" -return :: String +return :: Text return = "return" -pure' :: String +pure' :: Text pure' = "pure" -returnEscaped :: String +returnEscaped :: Text returnEscaped = "$return" -untilE :: String +untilE :: Text untilE = "untilE" -whileE :: String +whileE :: Text whileE = "whileE" -runST :: String +runST :: Text runST = "runST" -stRefValue :: String +stRefValue :: Text stRefValue = "value" -newSTRef :: String +newSTRef :: Text newSTRef = "newSTRef" -readSTRef :: String +readSTRef :: Text readSTRef = "readSTRef" -writeSTRef :: String +writeSTRef :: Text writeSTRef = "writeSTRef" -modifySTRef :: String +modifySTRef :: Text modifySTRef = "modifySTRef" -mkFn :: String +mkFn :: Text mkFn = "mkFn" -runFn :: String +runFn :: Text runFn = "runFn" -unit :: String +unit :: Text unit = "unit" -- Prim values -undefined :: String +undefined :: Text undefined = "undefined" -- Type Class Dictionary Names -monadEffDictionary :: String +monadEffDictionary :: Text monadEffDictionary = "monadEff" -applicativeEffDictionary :: String +applicativeEffDictionary :: Text applicativeEffDictionary = "applicativeEff" -bindEffDictionary :: String +bindEffDictionary :: Text bindEffDictionary = "bindEff" -semiringNumber :: String +semiringNumber :: Text semiringNumber = "semiringNumber" -semiringInt :: String +semiringInt :: Text semiringInt = "semiringInt" -ringNumber :: String +ringNumber :: Text ringNumber = "ringNumber" -ringInt :: String +ringInt :: Text ringInt = "ringInt" -moduloSemiringNumber :: String +moduloSemiringNumber :: Text moduloSemiringNumber = "moduloSemiringNumber" -moduloSemiringInt :: String +moduloSemiringInt :: Text moduloSemiringInt = "moduloSemiringInt" -euclideanRingNumber :: String +euclideanRingNumber :: Text euclideanRingNumber = "euclideanRingNumber" -euclideanRingInt :: String +euclideanRingInt :: Text euclideanRingInt = "euclideanRingInt" -ordBoolean :: String +ordBoolean :: Text ordBoolean = "ordBoolean" -ordNumber :: String +ordNumber :: Text ordNumber = "ordNumber" -ordInt :: String +ordInt :: Text ordInt = "ordInt" -ordString :: String +ordString :: Text ordString = "ordString" -ordChar :: String +ordChar :: Text ordChar = "ordChar" -eqNumber :: String +eqNumber :: Text eqNumber = "eqNumber" -eqInt :: String +eqInt :: Text eqInt = "eqInt" -eqString :: String +eqString :: Text eqString = "eqString" -eqChar :: String +eqChar :: Text eqChar = "eqChar" -eqBoolean :: String +eqBoolean :: Text eqBoolean = "eqBoolean" -boundedBoolean :: String +boundedBoolean :: Text boundedBoolean = "boundedBoolean" -booleanAlgebraBoolean :: String +booleanAlgebraBoolean :: Text booleanAlgebraBoolean = "booleanAlgebraBoolean" -heytingAlgebraBoolean :: String +heytingAlgebraBoolean :: Text heytingAlgebraBoolean = "heytingAlgebraBoolean" -semigroupString :: String +semigroupString :: Text semigroupString = "semigroupString" -semigroupoidFn :: String +semigroupoidFn :: Text semigroupoidFn = "semigroupoidFn" -- Generic Deriving -generic :: String +generic :: Text generic = "Generic" -toSpine :: String +toSpine :: Text toSpine = "toSpine" -fromSpine :: String +fromSpine :: Text fromSpine = "fromSpine" -toSignature :: String +toSignature :: Text toSignature = "toSignature" -- IsSymbol class @@ -321,12 +321,12 @@ pattern IsSymbol = Qualified (Just (ModuleName [ProperName "Data", ProperName "S -- Main module -main :: String +main :: Text main = "main" -- Prim -partial :: String +partial :: Text partial = "Partial" pattern Partial :: Qualified (ProperName 'ClassName) @@ -337,67 +337,67 @@ pattern Fail = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Fa -- Code Generation -__superclass_ :: String +__superclass_ :: Text __superclass_ = "__superclass_" -__unused :: String +__unused :: Text __unused = "__unused" -- Modules -prim :: String +prim :: Text prim = "Prim" -prelude :: String +prelude :: Text prelude = "Prelude" -dataArray :: String +dataArray :: Text dataArray = "Data_Array" -eff :: String +eff :: Text eff = "Control_Monad_Eff" -st :: String +st :: Text st = "Control_Monad_ST" -controlApplicative :: String +controlApplicative :: Text controlApplicative = "Control_Applicative" -controlSemigroupoid :: String +controlSemigroupoid :: Text controlSemigroupoid = "Control_Semigroupoid" -controlBind :: String +controlBind :: Text controlBind = "Control_Bind" -dataBounded :: String +dataBounded :: Text dataBounded = "Data_Bounded" -dataSemigroup :: String +dataSemigroup :: Text dataSemigroup = "Data_Semigroup" -dataHeytingAlgebra :: String +dataHeytingAlgebra :: Text dataHeytingAlgebra = "Data_HeytingAlgebra" -dataEq :: String +dataEq :: Text dataEq = "Data_Eq" -dataOrd :: String +dataOrd :: Text dataOrd = "Data_Ord" -dataSemiring :: String +dataSemiring :: Text dataSemiring = "Data_Semiring" -dataRing :: String +dataRing :: Text dataRing = "Data_Ring" -dataEuclideanRing :: String +dataEuclideanRing :: Text dataEuclideanRing = "Data_EuclideanRing" -dataFunction :: String +dataFunction :: Text dataFunction = "Data_Function" -dataFunctionUncurried :: String +dataFunctionUncurried :: Text dataFunctionUncurried = "Data_Function_Uncurried" -dataIntBits :: String +dataIntBits :: Text dataIntBits = "Data_Int_Bits" diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index 43479a725e..0d01b9e15e 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -6,6 +6,7 @@ module Language.PureScript.CoreFn.Expr where import Prelude.Compat import Control.Arrow ((***)) +import Data.Text (Text) import Language.PureScript.AST.Literals import Language.PureScript.CoreFn.Binders @@ -26,11 +27,11 @@ data Expr a -- | -- A record property accessor -- - | Accessor a String (Expr a) + | Accessor a Text (Expr a) -- | -- Partial record update -- - | ObjectUpdate a (Expr a) [(String, Expr a)] + | ObjectUpdate a (Expr a) [(Text, Expr a)] -- | -- Function introduction -- diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 69ef3eb039..8ad72423e1 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoOverloadedStrings #-} -- | -- Dump the core functional representation in JSON format for consumption -- by third-party code generators @@ -10,7 +11,8 @@ import Prelude.Compat import Data.Aeson import Data.Version (Version, showVersion) -import Data.Text (pack) +import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.AST.Literals import Language.PureScript.CoreFn @@ -31,26 +33,26 @@ identToJSON = toJSON . runIdent properNameToJSON :: ProperName a -> Value properNameToJSON = toJSON . runProperName -qualifiedToJSON :: (a -> String) -> Qualified a -> Value +qualifiedToJSON :: (a -> Text) -> Qualified a -> Value qualifiedToJSON f = toJSON . showQualified f moduleNameToJSON :: ModuleName -> Value moduleNameToJSON = toJSON . runModuleName moduleToJSON :: Version -> Module a -> Value -moduleToJSON v m = object [ pack "imports" .= map (moduleNameToJSON . snd) (moduleImports m) - , pack "exports" .= map identToJSON (moduleExports m) - , pack "foreign" .= map (identToJSON . fst) (moduleForeign m) - , pack "decls" .= map bindToJSON (moduleDecls m) - , pack "builtWith" .= toJSON (showVersion v) +moduleToJSON v m = object [ T.pack "imports" .= map (moduleNameToJSON . snd) (moduleImports m) + , T.pack "exports" .= map identToJSON (moduleExports m) + , T.pack "foreign" .= map (identToJSON . fst) (moduleForeign m) + , T.pack "decls" .= map bindToJSON (moduleDecls m) + , T.pack "builtWith" .= toJSON (showVersion v) ] bindToJSON :: Bind a -> Value -bindToJSON (NonRec _ n e) = object [ pack (runIdent n) .= exprToJSON e ] -bindToJSON (Rec bs) = object $ map (\((_, n), e) -> pack (runIdent n) .= exprToJSON e) bs +bindToJSON (NonRec _ n e) = object [ runIdent n .= exprToJSON e ] +bindToJSON (Rec bs) = object $ map (\((_, n), e) -> runIdent n .= exprToJSON e) bs -recordToJSON :: (a -> Value) -> [(String, a)] -> Value -recordToJSON f = object . map (\(label, a) -> pack label .= f a) +recordToJSON :: (a -> Value) -> [(Text, a)] -> Value +recordToJSON f = object . map (\(label, a) -> label .= f a) exprToJSON :: Expr a -> Value exprToJSON (Var _ i) = toJSON ( "Var" diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 1022e4c20f..a336030108 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -14,6 +14,7 @@ import Control.Monad.Writer (Writer, tell, execWriter) import Data.Foldable (for_) import Data.List (partition) +import qualified Data.Text as T import Language.PureScript.Docs.RenderedCode import Language.PureScript.Docs.Types @@ -37,13 +38,13 @@ modulesAsMarkdown = mapM_ moduleAsMarkdown moduleAsMarkdown :: Module -> Docs moduleAsMarkdown Module{..} = do - headerLevel 2 $ "Module " ++ P.runModuleName modName + headerLevel 2 $ "Module " ++ T.unpack (P.runModuleName modName) spacer for_ modComments tell' mapM_ (declAsMarkdown modName) modDeclarations spacer for_ modReExports $ \(mn, decls) -> do - headerLevel 3 $ "Re-exported from " ++ P.runModuleName mn ++ ":" + headerLevel 3 $ "Re-exported from " ++ T.unpack (P.runModuleName mn) ++ ":" spacer mapM_ (declAsMarkdown mn) decls diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 9eee08637f..7dede7e8d6 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -18,6 +18,7 @@ import Control.Monad.Error.Class (MonadError) import Control.Monad.State (runStateT) import Control.Monad.Writer.Strict (runWriterT) import qualified Data.Map as Map +import qualified Data.Text as T import Language.PureScript.Docs.Convert.ReExports (updateReExports) import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks) @@ -170,7 +171,7 @@ insertValueTypes env m = runParser :: P.TokenParser a -> String -> Either String a runParser p s = either (Left . show) Right $ do - ts <- P.lex "" s + ts <- P.lex "" (T.pack s) P.runTokenParser "" (p <* eof) ts -- | diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index f4bce8caeb..7980e1ef95 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -4,7 +4,7 @@ module Language.PureScript.Docs.Convert.ReExports import Prelude.Compat -import Control.Arrow ((&&&), second) +import Control.Arrow ((&&&), first, second) import Control.Monad import Control.Monad.Reader.Class (MonadReader, ask) import Control.Monad.State.Class (MonadState, gets, modify) @@ -16,6 +16,7 @@ import Data.Map (Map) import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) import qualified Data.Map as Map +import qualified Data.Text as T import Language.PureScript.Docs.Types import qualified Language.PureScript as P @@ -52,7 +53,7 @@ updateReExports env order = execState action Just v' -> pure v' Nothing -> - internalError ("Module missing: " ++ P.runModuleName mn) + internalError ("Module missing: " ++ T.unpack (P.runModuleName mn)) -- | -- Collect all of the re-exported declarations for a single module. @@ -69,7 +70,7 @@ getReExports :: getReExports env mn = case Map.lookup mn env of Nothing -> - internalError ("Module missing: " ++ P.runModuleName mn) + internalError ("Module missing: " ++ T.unpack (P.runModuleName mn)) Just (_, imports, exports) -> do allExports <- runReaderT (collectDeclarations imports exports) mn pure (filter notLocal allExports) @@ -188,7 +189,7 @@ lookupValueDeclaration importedFrom ident = do decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom let rs = - filter (\d -> declTitle d == P.showIdent ident + filter (\d -> declTitle d == T.unpack (P.showIdent ident) && (isValue d || isValueAlias d)) decls errOther other = internalErrorInModule @@ -214,7 +215,7 @@ lookupValueDeclaration importedFrom ident = do (declChildren d)) matchesIdent cdecl = - cdeclTitle cdecl == P.showIdent ident + cdeclTitle cdecl == T.unpack (P.showIdent ident) matchesAndIsTypeClassMember = uncurry (&&) . (matchesIdent &&& isTypeClassMember) @@ -238,7 +239,7 @@ lookupValueOpDeclaration -> m (P.ModuleName, [Declaration]) lookupValueOpDeclaration importedFrom op = do decls <- lookupModuleDeclarations "lookupValueOpDeclaration" importedFrom - case filter (\d -> declTitle d == P.showOp op && isValueAlias d) decls of + case filter (\d -> declTitle d == T.unpack (P.showOp op) && isValueAlias d) decls of [d] -> pure (importedFrom, [d]) other -> @@ -258,7 +259,7 @@ lookupTypeDeclaration :: lookupTypeDeclaration importedFrom ty = do decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom let - ds = filter (\d -> declTitle d == P.runProperName ty && isType d) decls + ds = filter (\d -> declTitle d == T.unpack (P.runProperName ty) && isType d) decls case ds of [d] -> pure (importedFrom, [d]) @@ -274,7 +275,7 @@ lookupTypeOpDeclaration lookupTypeOpDeclaration importedFrom tyOp = do decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom let - ds = filter (\d -> declTitle d == ("type " ++ P.showOp tyOp) && isTypeAlias d) decls + ds = filter (\d -> declTitle d == ("type " ++ T.unpack (P.showOp tyOp)) && isTypeAlias d) decls case ds of [d] -> pure (importedFrom, [d]) @@ -290,7 +291,7 @@ lookupTypeClassDeclaration lookupTypeClassDeclaration importedFrom tyClass = do decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom let - ds = filter (\d -> declTitle d == P.runProperName tyClass + ds = filter (\d -> declTitle d == T.unpack (P.runProperName tyClass) && isTypeClass d) decls case ds of @@ -317,7 +318,7 @@ lookupModuleDeclarations definedIn moduleName = do Nothing -> internalErrorInModule (definedIn ++ ": module missing: " - ++ P.runModuleName moduleName) + ++ T.unpack (P.runModuleName moduleName)) Just mdl -> pure (allDeclarations mdl) @@ -447,7 +448,7 @@ filterDataConstructors -> Map P.ModuleName [Declaration] -> Map P.ModuleName [Declaration] filterDataConstructors = - filterExportedChildren isDataConstructor P.runProperName + filterExportedChildren isDataConstructor (T.unpack . P.runProperName) -- | -- Given a list of exported type class member names, remove any data @@ -459,7 +460,7 @@ filterTypeClassMembers -> Map P.ModuleName [Declaration] -> Map P.ModuleName [Declaration] filterTypeClassMembers = - filterExportedChildren isTypeClassMember P.showIdent + filterExportedChildren isTypeClassMember (T.unpack . P.showIdent) filterExportedChildren :: (Functor f) @@ -492,7 +493,7 @@ internalErrorInModule internalErrorInModule msg = do mn <- ask internalError - ("while collecting re-exports for module: " ++ P.runModuleName mn ++ + ("while collecting re-exports for module: " ++ T.unpack (P.runModuleName mn) ++ ", " ++ msg) -- | @@ -503,7 +504,7 @@ typeClassConstraintFor :: Declaration -> Maybe P.Constraint typeClassConstraintFor Declaration{..} = case declInfo of TypeClassDeclaration tyArgs _ -> - Just (P.Constraint (P.Qualified Nothing (P.ProperName declTitle)) (mkConstraint tyArgs) Nothing) + Just (P.Constraint (P.Qualified Nothing (P.ProperName (T.pack declTitle))) (mkConstraint (map (first T.pack) tyArgs)) Nothing) _ -> Nothing where diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index d34df2e718..3c55698652 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -5,16 +5,22 @@ module Language.PureScript.Docs.Convert.Single import Prelude.Compat +import Control.Arrow (first) import Control.Category ((>>>)) import Control.Monad import Data.Either import Data.List (nub) import Data.Maybe (mapMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.Docs.Types import qualified Language.PureScript as P +-- TODO (Christoph): Get rid of the T.unpack s + -- | -- Convert a single Module, but ignore re-exports; any re-exported types or -- values will not appear in the result. @@ -75,7 +81,7 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) = augmentWith (AugmentChild child) d = d { declChildren = declChildren d ++ [child] } -getDeclarationTitle :: P.Declaration -> Maybe String +getDeclarationTitle :: P.Declaration -> Maybe Text getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name) getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name) getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name) @@ -83,25 +89,25 @@ getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName nam getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeClassDeclaration name _ _ _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name) -getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " ++ P.showOp op) +getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " <> P.showOp op) getDeclarationTitle (P.ValueFixityDeclaration _ _ op) = Just (P.showOp op) getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d getDeclarationTitle _ = Nothing -- | Create a basic Declaration value. -mkDeclaration :: String -> DeclarationInfo -> Declaration +mkDeclaration :: Text -> DeclarationInfo -> Declaration mkDeclaration title info = - Declaration { declTitle = title + Declaration { declTitle = T.unpack title , declComments = Nothing , declSourceSpan = Nothing , declChildren = [] , declInfo = info } -basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration +basicDeclaration :: Text -> DeclarationInfo -> Maybe IntermediateDeclaration basicDeclaration title info = Just $ Right $ mkDeclaration title info -convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration +convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title = basicDeclaration title (ValueDeclaration ty) convertDeclaration P.ValueDeclaration{} title = @@ -113,27 +119,27 @@ convertDeclaration (P.ExternDeclaration _ ty) title = convertDeclaration (P.DataDeclaration dtype _ args ctors) title = Just (Right (mkDeclaration title info) { declChildren = children }) where - info = DataDeclaration dtype args + info = DataDeclaration dtype (map (first T.unpack) args) children = map convertCtor ctors convertCtor (ctor', tys) = - ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys) + ChildDeclaration (T.unpack (P.runProperName ctor')) Nothing Nothing (ChildDataConstructor tys) convertDeclaration (P.ExternDataDeclaration _ kind') title = basicDeclaration title (ExternDataDeclaration kind') convertDeclaration (P.TypeSynonymDeclaration _ args ty) title = - basicDeclaration title (TypeSynonymDeclaration args ty) + basicDeclaration title (TypeSynonymDeclaration (map (first T.unpack) args) ty) convertDeclaration (P.TypeClassDeclaration _ args implies _ ds) title = -- TODO: include fundep info Just (Right (mkDeclaration title info) { declChildren = children }) where - info = TypeClassDeclaration args implies + info = TypeClassDeclaration (map (first T.unpack) args) implies children = map convertClassMember ds convertClassMember (P.PositionedDeclaration _ _ d) = convertClassMember d convertClassMember (P.TypeDeclaration ident' ty) = - ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty) + ChildDeclaration (T.unpack (P.showIdent ident')) Nothing Nothing (ChildTypeClassMember ty) convertClassMember _ = P.internalError "convertDeclaration: Invalid argument to convertClassMember." convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = - Just (Left (classNameString : typeNameStrings, AugmentChild childDecl)) + Just (Left (T.unpack classNameString : map T.unpack typeNameStrings, AugmentChild childDecl)) where classNameString = unQual className typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys) @@ -142,7 +148,7 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit extractProperNames (P.TypeConstructor n) = [unQual n] extractProperNames _ = [] - childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) + childDecl = ChildDeclaration (T.unpack title) Nothing Nothing (ChildInstance constraints classApp) classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title = Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias))) @@ -174,8 +180,8 @@ convertComments cs = do pure (unlines docs) where - toLines (P.LineComment s) = [s] - toLines (P.BlockComment s) = lines s + toLines (P.LineComment s) = [T.unpack s] + toLines (P.BlockComment s) = lines (T.unpack s) stripPipe s' = case dropWhile (== ' ') s' of @@ -196,5 +202,5 @@ collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m) collectBookmarks' :: P.Module -> [(P.ModuleName, String)] collectBookmarks' m = map (P.getModuleName m, ) - (mapMaybe getDeclarationTitle + (mapMaybe (fmap T.unpack . getDeclarationTitle) (P.exportedDeclarations m)) diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index e13e03a8ac..05add53caa 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -13,12 +13,16 @@ import Prelude.Compat import Data.Maybe (maybeToList) import Data.Monoid ((<>)) +import qualified Data.Text as T +import Data.Text (Text) import Language.PureScript.Docs.RenderedCode import Language.PureScript.Docs.Types import Language.PureScript.Docs.Utils.MonoidExtras import qualified Language.PureScript as P +-- TODO (Christoph): get rid of T.unpack's + renderDeclaration :: Declaration -> RenderedCode renderDeclaration = renderDeclarationWithOptions defaultRenderTypeOptions @@ -31,7 +35,7 @@ renderDeclarationWithOptions opts Declaration{..} = , renderType' ty ] DataDeclaration dtype args -> - [ keyword (P.showDataDeclType dtype) + [ keyword (T.unpack (P.showDataDeclType dtype)) , renderType' (typeApp declTitle args) ] ExternDataDeclaration kind' -> @@ -74,15 +78,15 @@ renderDeclarationWithOptions opts Declaration{..} = renderQualAlias :: FixityAlias -> String renderQualAlias (P.Qualified mn alias) - | mn == currentModule opts = renderAlias id alias - | otherwise = renderAlias (\f -> P.showQualified f . P.Qualified mn) alias + | mn == currentModule opts = T.unpack (renderAlias id alias) + | otherwise = T.unpack (renderAlias (\f -> P.showQualified f . P.Qualified mn) alias) renderAlias - :: (forall a. (a -> String) -> a -> String) + :: (forall a. (a -> Text) -> a -> Text) -> Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName)) - -> String + -> Text renderAlias f - = either (("type " ++) . f P.runProperName) + = either (("type " <>) . f P.runProperName) $ either (f P.runIdent) (f P.runProperName) -- adjustAliasName (P.AliasType{}) title = drop 6 (init title) @@ -133,7 +137,7 @@ renderConstraintsWithOptions opts constraints (map (renderConstraintWithOptions opts) constraints) notQualified :: String -> P.Qualified (P.ProperName a) -notQualified = P.Qualified Nothing . P.ProperName +notQualified = P.Qualified Nothing . P.ProperName . T.pack typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type typeApp title typeArgs = @@ -142,5 +146,5 @@ typeApp title typeArgs = (map toTypeVar typeArgs) toTypeVar :: (String, Maybe P.Kind) -> P.Type -toTypeVar (s, Nothing) = P.TypeVar s -toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k +toTypeVar (s, Nothing) = P.TypeVar (T.pack s) +toTypeVar (s, Just k) = P.KindedType (P.TypeVar (T.pack s)) k diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index 332530b56c..bae5544378 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -14,8 +14,10 @@ import Prelude.Compat import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) +import qualified Data.Text as T +import Data.Text (Text) -import Control.Arrow ((<+>)) +import Control.Arrow ((<+>), first) import Control.PatternArrows as PA import Language.PureScript.Crash @@ -33,7 +35,7 @@ typeLiterals = mkPattern match match TypeWildcard{} = Just (syntax "_") match (TypeVar var) = - Just (ident var) + Just (ident (T.unpack var)) match (PrettyPrintObject row) = Just $ mintersperse sp [ syntax "{" @@ -41,7 +43,7 @@ typeLiterals = mkPattern match , syntax "}" ] match (TypeConstructor (Qualified mn name)) = - Just (ctor (runProperName name) (maybeToContainingModule mn)) + Just (ctor (T.unpack (runProperName name)) (maybeToContainingModule mn)) match REmpty = Just (syntax "()") match row@RCons{} = @@ -49,7 +51,7 @@ typeLiterals = mkPattern match match (BinaryNoParensType op l r) = Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r match (TypeOp (Qualified mn op)) = - Just (ident' (runOpName op) (maybeToContainingModule mn)) + Just (ident' (T.unpack (runOpName op)) (maybeToContainingModule mn)) match _ = Nothing @@ -74,8 +76,10 @@ renderConstraints deps ty = -- Render code representing a Row -- renderRow :: Type -> RenderedCode -renderRow = uncurry renderRow' . rowToList +renderRow = uncurry renderRow' . convertString . rowToList where + convertString :: ([(Text, Type)], Type) -> ([(String, Type)], Type) + convertString = first (map (first T.unpack)) renderRow' h t = renderHead h <> renderTail t renderHead :: [(String, Type)] -> RenderedCode @@ -144,7 +148,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom forall_ :: Pattern () Type ([String], Type) forall_ = mkPattern match where - match (PrettyPrintForAll idents ty) = Just (idents, ty) + match (PrettyPrintForAll idents ty) = Just (map T.unpack idents, ty) match _ = Nothing insertPlaceholders :: RenderTypeOptions -> Type -> Type @@ -176,7 +180,7 @@ preprocessType opts = dePrim . insertPlaceholders opts -- Render code representing a Kind -- renderKind :: Kind -> RenderedCode -renderKind = kind . prettyPrintKind +renderKind = kind . T.unpack . prettyPrintKind -- | -- Render code representing a Type, as it should appear inside parentheses diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 63f837ead2..05bd8a1008 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -- | Data types and functions for representing a simplified form of PureScript -- code, intended for use in e.g. HTML documentation. @@ -38,6 +37,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Data.Aeson.BetterErrors import qualified Data.Aeson as A +import qualified Data.Text as T import qualified Language.PureScript as P @@ -103,7 +103,7 @@ instance A.ToJSON ContainingModule where asContainingModule :: Parse e ContainingModule asContainingModule = - maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asString) + maybeToContainingModule <$> perhaps (P.moduleNameFromString . T.pack <$> asString) -- | -- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index c5e15b2298..aa0a8a12b7 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -352,7 +352,7 @@ parseVersion' str = asModule :: Parse PackageError Module asModule = - Module <$> key "name" (P.moduleNameFromString <$> asString) + Module <$> key "name" (P.moduleNameFromString <$> asText) <*> key "comments" (perhaps asString) <*> key "declarations" (eachInArray asDeclaration) <*> key "reExports" (eachInArray asReExport) @@ -478,7 +478,7 @@ asBookmarks = eachInArray asBookmark asBookmark :: Parse BowerError Bookmark asBookmark = - asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asString) + asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asText) <*> nth 1 asString) asResolvedDependencies :: Parse PackageError [(PackageName, Version)] diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index fbffc742a4..4c122b2c71 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Environment where @@ -6,9 +5,10 @@ module Language.PureScript.Environment where import Prelude.Compat import Data.Aeson.TH -import Data.Maybe (fromMaybe) import qualified Data.Aeson as A import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Crash @@ -27,7 +27,7 @@ data Environment = Environment , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident]) -- ^ Data constructors currently in scope, along with their associated type -- constructor name, argument types and return type. - , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(String, Maybe Kind)], Type) + , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type) -- ^ Type synonyms currently in scope , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)) -- ^ Available type class dictionaries @@ -37,7 +37,7 @@ data Environment = Environment -- | Information about a type class data TypeClassData = TypeClassData - { typeClassArguments :: [(String, Maybe Kind)] + { typeClassArguments :: [(Text, Maybe Kind)] -- ^ A list of type argument names, and their kinds, where kind annotations -- were provided. , typeClassMembers :: [(Ident, Type)] @@ -105,7 +105,7 @@ data TypeKind -- | -- Data type -- - = DataType [(String, Maybe Kind)] [(ProperName 'ConstructorName, [Type])] + = DataType [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])] -- | -- Type synonym -- @@ -138,7 +138,7 @@ data DataDeclType | Newtype deriving (Show, Eq, Ord) -showDataDeclType :: DataDeclType -> String +showDataDeclType :: DataDeclType -> Text showDataDeclType Data = "data" showDataDeclType Newtype = "newtype" @@ -155,13 +155,13 @@ instance A.FromJSON DataDeclType where -- | -- Construct a ProperName in the Prim module -- -primName :: String -> Qualified (ProperName a) +primName :: Text -> Qualified (ProperName a) primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName -- | -- Construct a type in the Prim module -- -primTy :: String -> Type +primTy :: Text -> Type primTy = TypeConstructor . primName -- | diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index b13d777e8e..729fa83082 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -18,10 +18,12 @@ import Data.Char (isSpace) import Data.Either (lefts, rights) import Data.Foldable (fold) import Data.Functor.Identity (Identity(..)) -import Data.List (intercalate, transpose, nub, nubBy, sortBy, partition) +import Data.List (transpose, nub, nubBy, sortBy, partition) import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import Data.Ord (comparing) import qualified Data.Map as M +import qualified Data.Text as T +import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Crash @@ -43,7 +45,7 @@ import qualified Text.PrettyPrint.Boxes as Box import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers import Text.Parsec.Error (Message(..)) -newtype ErrorSuggestion = ErrorSuggestion String +newtype ErrorSuggestion = ErrorSuggestion Text -- | Get the source span for an error errorSpan :: ErrorMessage -> Maybe SourceSpan @@ -73,7 +75,7 @@ stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldSt -- | -- Get the error code for a particular error type -- -errorCode :: ErrorMessage -> String +errorCode :: ErrorMessage -> Text errorCode em = case unwrapErrorMessage em of ErrorParsingFFIModule{} -> "ErrorParsingFFIModule" ErrorParsingModule{} -> "ErrorParsingModule" @@ -245,7 +247,7 @@ replaceUnknowns = everywhereOnTypesM replaceTypes case M.lookup s (umSkolemMap m) of Nothing -> do let s' = umNextIndex m - put $ m { umSkolemMap = M.insert s (name, s', ss) (umSkolemMap m), umNextIndex = s' + 1 } + put $ m { umSkolemMap = M.insert s (T.unpack name, s', ss) (umSkolemMap m), umNextIndex = s' + 1 } return (Skolem name s' sko ss) Just (_, s', _) -> return (Skolem name s' sko ss) replaceTypes other = return other @@ -287,8 +289,8 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gTypeSearch (TSBefore env) = pure (TSBefore env) gTypeSearch (TSAfter result) = TSAfter <$> traverse (traverse f) result -wikiUri :: ErrorMessage -> String -wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e +wikiUri :: ErrorMessage -> Text +wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" <> errorCode e -- TODO Other possible suggestions: -- WildcardInferredType - source span not small enough @@ -304,19 +306,19 @@ errorSuggestion err = ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing - MissingTypeDeclaration ident ty -> suggest $ showIdent ident ++ " :: " ++ prettyPrintSuggestedType ty - WildcardInferredType ty _ -> suggest $ prettyPrintSuggestedType ty + MissingTypeDeclaration ident ty -> suggest $ showIdent ident <> " :: " <> T.pack (prettyPrintSuggestedType ty) + WildcardInferredType ty _ -> suggest $ T.pack (prettyPrintSuggestedType ty) _ -> Nothing where emptySuggestion = Just $ ErrorSuggestion "" suggest = Just . ErrorSuggestion - importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> String + importSuggestion :: ModuleName -> [ DeclarationRef ] -> Maybe ModuleName -> Text importSuggestion mn refs qual = - "import " ++ runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")" ++ qstr qual + "import " <> runModuleName mn <> " (" <> T.intercalate ", " (mapMaybe prettyPrintRef refs) <> ")" <> qstr qual - qstr :: Maybe ModuleName -> String - qstr (Just mn) = " as " ++ runModuleName mn + qstr :: Maybe ModuleName -> Text + qstr (Just mn) = " as " <> runModuleName mn qstr Nothing = "" suggestionSpan :: ErrorMessage -> Maybe SourceSpan @@ -330,7 +332,7 @@ suggestionSpan e = MissingTypeDeclaration{} -> startOnly ss _ -> ss -showSuggestion :: SimpleErrorMessage -> String +showSuggestion :: SimpleErrorMessage -> Text showSuggestion suggestion = case errorSuggestion suggestion of Just (ErrorSuggestion x) -> x _ -> "" @@ -343,10 +345,10 @@ ansiColorReset :: String ansiColorReset = ANSI.setSGRCode [ANSI.Reset] -colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> String -> String +colorCode :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Text -> Text colorCode codeColor code = case codeColor of Nothing -> code - Just cc -> concat [ansiColor cc, code, ansiColorReset] + Just cc -> T.pack (ansiColor cc) <> code <> T.pack ansiColorReset colorCodeBox :: Maybe (ANSI.ColorIntensity, ANSI.Color) -> Box.Box -> Box.Box colorCodeBox codeColor b = case codeColor of @@ -403,8 +405,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS ] ++ maybe [] (return . Box.moveDown 1) typeInformation ++ [ Box.moveDown 1 $ paras - [ line $ "See " ++ wikiUri e ++ " for more information, " - , line $ "or to contribute content related to this " ++ levelText ++ "." + [ line $ "See " <> wikiUri e <> " for more information, " + , line $ "or to contribute content related to this " <> levelText <> "." ] | showWiki ] @@ -420,59 +422,59 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS skolemInfo :: (String, Int, Maybe SourceSpan) -> Box.Box skolemInfo (name, s, ss) = paras $ - line (markCode (name ++ show s) ++ " is a rigid type variable") - : foldMap (return . line . (" bound at " ++) . displayStartEndPos) ss + line (markCode (T.pack (name <> show s)) <> " is a rigid type variable") + : foldMap (return . line . (" bound at " <>) . displayStartEndPos) ss unknownInfo :: Int -> Box.Box - unknownInfo u = line $ markCode ("t" ++ show u) ++ " is an unknown type" + unknownInfo u = line $ markCode ("t" <> T.pack (show u)) <> " is an unknown type" renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box renderSimpleErrorMessage (CannotGetFileInfo path) = paras [ line "Unable to read file info: " - , indent . line $ path + , indent . lineS $ path ] renderSimpleErrorMessage (CannotReadFile path) = paras [ line "Unable to read file: " - , indent . line $ path + , indent . lineS $ path ] renderSimpleErrorMessage (CannotWriteFile path) = paras [ line "Unable to write file: " - , indent . line $ path + , indent . lineS $ path ] renderSimpleErrorMessage (ErrorParsingFFIModule path extra) = paras $ [ line "Unable to parse foreign module:" - , indent . line $ path + , indent . lineS $ path ] ++ - map (indent . line) (concatMap Bundle.printErrorMessage (maybeToList extra)) + map (indent . lineS) (concatMap Bundle.printErrorMessage (maybeToList extra)) renderSimpleErrorMessage (ErrorParsingModule err) = paras [ line "Unable to parse module: " , prettyPrintParseError err ] renderSimpleErrorMessage (MissingFFIModule mn) = - line $ "The foreign module implementation for module " ++ markCode (runModuleName mn) ++ " is missing." + line $ "The foreign module implementation for module " <> markCode (runModuleName mn) <> " is missing." renderSimpleErrorMessage (UnnecessaryFFIModule mn path) = - paras [ line $ "An unnecessary foreign module implementation was provided for module " ++ markCode (runModuleName mn) ++ ": " - , indent . line $ path - , line $ "Module " ++ markCode (runModuleName mn) ++ " does not contain any foreign import declarations, so a foreign module is not necessary." + paras [ line $ "An unnecessary foreign module implementation was provided for module " <> markCode (runModuleName mn) <> ": " + , indent . lineS $ path + , line $ "Module " <> markCode (runModuleName mn) <> " does not contain any foreign import declarations, so a foreign module is not necessary." ] renderSimpleErrorMessage (MissingFFIImplementations mn idents) = - paras [ line $ "The following values are not defined in the foreign module for module " ++ markCode (runModuleName mn) ++ ": " + paras [ line $ "The following values are not defined in the foreign module for module " <> markCode (runModuleName mn) <> ": " , indent . paras $ map (line . runIdent) idents ] renderSimpleErrorMessage (UnusedFFIImplementations mn idents) = - paras [ line $ "The following definitions in the foreign module for module " ++ markCode (runModuleName mn) ++ " are unused: " + paras [ line $ "The following definitions in the foreign module for module " <> markCode (runModuleName mn) <> " are unused: " , indent . paras $ map (line . runIdent) idents ] renderSimpleErrorMessage (InvalidFFIIdentifier mn ident) = - paras [ line $ "In the FFI module for " ++ markCode (runModuleName mn) ++ ":" + paras [ line $ "In the FFI module for " <> markCode (runModuleName mn) <> ":" , indent . paras $ - [ line $ "The identifier " ++ markCode ident ++ " is not valid in PureScript." + [ line $ "The identifier " <> markCode ident <> " is not valid in PureScript." , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers." ] ] renderSimpleErrorMessage (MultipleFFIModules mn paths) = - paras [ line $ "Multiple foreign module implementations have been provided for module " ++ markCode (runModuleName mn) ++ ": " - , indent . paras $ map line paths + paras [ line $ "Multiple foreign module implementations have been provided for module " <> markCode (runModuleName mn) <> ": " + , indent . paras $ map lineS paths ] renderSimpleErrorMessage InvalidDoBind = line "The last statement in a 'do' block must be an expression, but this block ends with a binder." @@ -489,63 +491,63 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , indent $ line $ markCode $ prettyPrintKind ki ] renderSimpleErrorMessage (MultipleValueOpFixities op) = - line $ "There are multiple fixity/precedence declarations for operator " ++ markCode (showOp op) + line $ "There are multiple fixity/precedence declarations for operator " <> markCode (showOp op) renderSimpleErrorMessage (MultipleTypeOpFixities op) = - line $ "There are multiple fixity/precedence declarations for type operator " ++ markCode (showOp op) + line $ "There are multiple fixity/precedence declarations for type operator " <> markCode (showOp op) renderSimpleErrorMessage (OrphanTypeDeclaration nm) = - line $ "The type declaration for " ++ markCode (showIdent nm) ++ " should be followed by its definition." + line $ "The type declaration for " <> markCode (showIdent nm) <> " should be followed by its definition." renderSimpleErrorMessage (RedefinedIdent name) = - line $ "The value " ++ markCode (showIdent name) ++ " has been defined multiple times" + line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" renderSimpleErrorMessage (UnknownName name) = - line $ "Unknown " ++ printName name + line $ "Unknown " <> printName name renderSimpleErrorMessage (UnknownImport mn name) = - paras [ line $ "Cannot import " ++ printName (Qualified Nothing name) ++ " from module " ++ markCode (runModuleName mn) + paras [ line $ "Cannot import " <> printName (Qualified Nothing name) <> " from module " <> markCode (runModuleName mn) , line "It either does not exist or the module does not export it." ] renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) = - line $ "Module " ++ runModuleName mn ++ " does not export data constructor " ++ markCode (runProperName dcon) ++ " for type " ++ markCode (runProperName tcon) + line $ "Module " <> runModuleName mn <> " does not export data constructor " <> markCode (runProperName dcon) <> " for type " <> markCode (runProperName tcon) renderSimpleErrorMessage (UnknownExport name) = - line $ "Cannot export unknown " ++ printName (Qualified Nothing name) + line $ "Cannot export unknown " <> printName (Qualified Nothing name) renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) = - line $ "Cannot export data constructor " ++ markCode (runProperName dcon) ++ " for type " ++ markCode (runProperName tcon) ++ ", as it has not been declared." + line $ "Cannot export data constructor " <> markCode (runProperName dcon) <> " for type " <> markCode (runProperName tcon) <> ", as it has not been declared." renderSimpleErrorMessage (ScopeConflict nm ms) = - paras [ line $ "Conflicting definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following modules:" + paras [ line $ "Conflicting definitions are in scope for " <> printName (Qualified Nothing nm) <> " from the following modules:" , indent $ paras $ map (line . markCode . runModuleName) ms ] renderSimpleErrorMessage (ScopeShadowing nm exmn ms) = - paras [ line $ "Shadowed definitions are in scope for " ++ printName (Qualified Nothing nm) ++ " from the following open imports:" - , indent $ paras $ map (line . markCode . ("import " ++) . runModuleName) ms - , line $ "These will be ignored and the " ++ case exmn of - Just exmn' -> "declaration from " ++ markCode (runModuleName exmn') ++ " will be used." + paras [ line $ "Shadowed definitions are in scope for " <> printName (Qualified Nothing nm) <> " from the following open imports:" + , indent $ paras $ map (line . markCode . ("import " <>) . runModuleName) ms + , line $ "These will be ignored and the " <> case exmn of + Just exmn' -> "declaration from " <> markCode (runModuleName exmn') <> " will be used." Nothing -> "local declaration will be used." ] renderSimpleErrorMessage (DeclConflict new existing) = - line $ "Declaration for " ++ printName (Qualified Nothing new) ++ " conflicts with an existing " ++ nameType existing ++ " of the same name." + line $ "Declaration for " <> printName (Qualified Nothing new) <> " conflicts with an existing " <> nameType existing <> " of the same name." renderSimpleErrorMessage (ExportConflict new existing) = - line $ "Export for " ++ printName new ++ " conflicts with " ++ runName existing + line $ "Export for " <> printName new <> " conflicts with " <> runName existing renderSimpleErrorMessage (DuplicateModule mn ss) = - paras [ line ("Module " ++ markCode (runModuleName mn) ++ " has been defined multiple times:") + paras [ line ("Module " <> markCode (runModuleName mn) <> " has been defined multiple times:") , indent . paras $ map (line . displaySourceSpan) ss ] renderSimpleErrorMessage (CycleInDeclaration nm) = - line $ "The value of " ++ markCode (showIdent nm) ++ " is undefined here, so this reference is not allowed." + line $ "The value of " <> markCode (showIdent nm) <> " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = paras [ line "There is a cycle in module dependencies in these modules: " , indent $ paras (map (line . markCode . runModuleName) mns) ] renderSimpleErrorMessage (CycleInTypeSynonym name) = paras [ line $ case name of - Just pn -> "A cycle appears in the definition of type synonym " ++ markCode (runProperName pn) + Just pn -> "A cycle appears in the definition of type synonym " <> markCode (runProperName pn) Nothing -> "A cycle appears in a set of type synonym definitions." , line "Cycles are disallowed because they can lead to loops in the type checker." , line "Consider using a 'newtype' instead." ] renderSimpleErrorMessage (NameIsUndefined ident) = - line $ "Value " ++ markCode (showIdent ident) ++ " is undefined." + line $ "Value " <> markCode (showIdent ident) <> " is undefined." renderSimpleErrorMessage (UndefinedTypeVariable name) = - line $ "Type variable " ++ markCode (runProperName name) ++ " is undefined." + line $ "Type variable " <> markCode (runProperName name) <> " is undefined." renderSimpleErrorMessage (PartiallyAppliedSynonym name) = - paras [ line $ "Type synonym " ++ markCode (showQualified runProperName name) ++ " is partially applied." + paras [ line $ "Type synonym " <> markCode (showQualified runProperName name) <> " is partially applied." , line "Type synonyms must be applied to all of their type arguments." ] renderSimpleErrorMessage (EscapedSkolem binding) = @@ -561,12 +563,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS sortRows t1 t2 = (t1, t2) -- Put the common labels last - sortRows' :: ([(String, Type)], Type) -> ([(String, Type)], Type) -> (Type, Type) + sortRows' :: ([(Text, Type)], Type) -> ([(Text, Type)], Type) -> (Type, Type) sortRows' (s1, r1) (s2, r2) = - let common :: [(String, (Type, Type))] + let common :: [(Text, (Type, Type))] common = sortBy (comparing fst) [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] - sd1, sd2 :: [(String, Type)] + sd1, sd2 :: [(Text, Type)] sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] in ( rowFromList (sortBy (comparing fst) sd1 ++ map (fst &&& fst . snd) common, r1) @@ -597,7 +599,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , Box.vcat Box.left (map typeAtomAsBox ts) ] , line "The following instances were found:" - , indent $ paras (line (showQualified showIdent d ++ " (chosen)") : map (line . showQualified showIdent) ds) + , indent $ paras (line (showQualified showIdent d <> " (chosen)") : map (line . showQualified showIdent) ds) , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended." , line "They may be disallowed completely in a future version of the compiler." ] @@ -667,26 +669,26 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , line "Make sure this is a newtype." ] renderSimpleErrorMessage (CannotFindDerivingType nm) = - line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found." + line $ "Cannot derive a type class instance, because the type declaration for " <> markCode (runProperName nm) <> " could not be found." renderSimpleErrorMessage (DuplicateLabel l expr) = - paras $ [ line $ "Label " ++ markCode l ++ " appears more than once in a row type." ] + paras $ [ line $ "Label " <> markCode l <> " appears more than once in a row type." ] <> foldMap (\expr' -> [ line "Relevant expression: " , markCodeBox $ indent $ prettyPrintValue valueDepth expr' ]) expr renderSimpleErrorMessage (DuplicateTypeArgument name) = - line $ "Type argument " ++ markCode name ++ " appears more than once." + line $ "Type argument " <> markCode name <> " appears more than once." renderSimpleErrorMessage (DuplicateValueDeclaration nm) = - line $ "Multiple value declarations exist for " ++ markCode (showIdent nm) ++ "." + line $ "Multiple value declarations exist for " <> markCode (showIdent nm) <> "." renderSimpleErrorMessage (ArgListLengthsDiffer ident) = - line $ "Argument list lengths differ in declaration " ++ markCode (showIdent ident) + line $ "Argument list lengths differ in declaration " <> markCode (showIdent ident) renderSimpleErrorMessage (OverlappingArgNames ident) = - line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration " ++) . showIdent) ident + line $ "Overlapping names in function/binder" <> foldMap ((" in declaration " <>) . showIdent) ident renderSimpleErrorMessage (MissingClassMember ident) = - line $ "Type class member " ++ markCode (showIdent ident) ++ " has not been implemented." + line $ "Type class member " <> markCode (showIdent ident) <> " has not been implemented." renderSimpleErrorMessage (ExtraneousClassMember ident className) = - line $ "" ++ markCode (showIdent ident) ++ " is not a member of type class " ++ markCode (showQualified runProperName className) + line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className) renderSimpleErrorMessage (ExpectedType ty kind) = - paras [ line $ "In a type-annotated expression " ++ markCode "x :: t" ++ ", the type " ++ markCode "t" ++ " must have kind " ++ markCode "*" ++ "." + paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode "*" <> "." , line "The error arises from the type" , markCodeBox $ indent $ typeAsBox ty , line "having the kind" @@ -694,7 +696,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , line "instead." ] renderSimpleErrorMessage (IncorrectConstructorArity nm) = - line $ "Data constructor " ++ markCode (showQualified runProperName nm) ++ " was given the wrong number of arguments in a case expression." + line $ "Data constructor " <> markCode (showQualified runProperName nm) <> " was given the wrong number of arguments in a case expression." renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) = paras [ line "Expression" , markCodeBox $ indent $ prettyPrintValue valueDepth expr @@ -702,13 +704,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , markCodeBox $ indent $ typeAsBox ty ] renderSimpleErrorMessage (PropertyIsMissing prop) = - line $ "Type of expression lacks required label " ++ markCode prop ++ "." + line $ "Type of expression lacks required label " <> markCode prop <> "." renderSimpleErrorMessage (AdditionalProperty prop) = - line $ "Type of expression contains additional label " ++ markCode prop ++ "." + line $ "Type of expression contains additional label " <> markCode prop <> "." renderSimpleErrorMessage TypeSynonymInstance = line "Type class instances for type synonyms are disallowed." renderSimpleErrorMessage (OrphanInstance nm cnm ts) = - paras [ line $ "Type class instance " ++ markCode (showIdent nm) ++ " for " + paras [ line $ "Type class instance " <> markCode (showIdent nm) <> " for " , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm) , Box.vcat Box.left (map typeAtomAsBox ts) @@ -718,7 +720,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , line "Consider moving the instance, if possible, or using a newtype wrapper." ] renderSimpleErrorMessage (InvalidNewtype name) = - paras [ line $ "Newtype " ++ markCode (runProperName name) ++ " is invalid." + paras [ line $ "Newtype " <> markCode (runProperName name) <> " is invalid." , line "Newtypes must define a single constructor with a single argument." ] renderSimpleErrorMessage (InvalidInstanceHead ty) = @@ -727,29 +729,29 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form." ] renderSimpleErrorMessage (TransitiveExportError x ys) = - paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following to also be exported: " + paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " requires the following to also be exported: " , indent $ paras $ map (line . markCode . prettyPrintExport) ys ] renderSimpleErrorMessage (TransitiveDctorExportError x ctor) = - paras [ line $ "An export for " ++ markCode (prettyPrintExport x) ++ " requires the following data constructor to also be exported: " + paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " requires the following data constructor to also be exported: " , indent $ line $ markCode $ runProperName ctor ] renderSimpleErrorMessage (ShadowedName nm) = - line $ "Name " ++ markCode (showIdent nm) ++ " was shadowed." + line $ "Name " <> markCode (showIdent nm) <> " was shadowed." renderSimpleErrorMessage (ShadowedTypeVar tv) = - line $ "Type variable " ++ markCode tv ++ " was shadowed." + line $ "Type variable " <> markCode tv <> " was shadowed." renderSimpleErrorMessage (UnusedTypeVar tv) = - line $ "Type variable " ++ markCode tv ++ " was declared but not used." + line $ "Type variable " <> markCode tv <> " was declared but not used." renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) = - line $ "Importing type " ++ markCode (runProperName name ++ "(..)") ++ " from " ++ markCode (runModuleName mn) ++ " is misleading as it has no exported data constructors." + line $ "Importing type " <> markCode (runProperName name <> "(..)") <> " from " <> markCode (runModuleName mn) <> " is misleading as it has no exported data constructors." renderSimpleErrorMessage (ImportHidingModule name) = paras [ line "hiding imports cannot be used to hide modules." - , line $ "An attempt was made to hide the import of " ++ markCode (runModuleName name) + , line $ "An attempt was made to hide the import of " <> markCode (runModuleName name) ] renderSimpleErrorMessage (WildcardInferredType ty ctx) = paras $ [ line "Wildcard type definition has the inferred type " , markCodeBox $ indent $ typeAsBox ty - ] ++ renderContext ctx + ] <> renderContext ctx renderSimpleErrorMessage (HoleInferredType name ty ctx ts) = let maxTSResults = 15 @@ -758,7 +760,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS let formatTS (names, types) = let - idBoxes = Box.text . showQualified runIdent <$> names + idBoxes = Box.text . T.unpack . showQualified runIdent <$> names tyBoxes = (\t -> BoxHelpers.indented (Box.text ":: " Box.<> typeAsBox t)) <$> types longestId = maximum (map Box.cols idBoxes) @@ -772,13 +774,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS ] _ -> [] in - paras $ [ line $ "Hole '" ++ markCode name ++ "' has the inferred type " + paras $ [ line $ "Hole '" <> markCode name <> "' has the inferred type " , markCodeBox (indent (typeAsBox ty)) ] ++ tsResult ++ renderContext ctx renderSimpleErrorMessage (MissingTypeDeclaration ident ty) = - paras [ line $ "No type declaration was provided for the top-level declaration of " ++ markCode (showIdent ident) ++ "." + paras [ line $ "No type declaration was provided for the top-level declaration of " <> markCode (showIdent ident) <> "." , line "It is good practice to provide type declarations as a form of documentation." - , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:" + , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:" , markCodeBox $ indent $ typeAsBox ty ] renderSimpleErrorMessage (OverlappingPattern bs b) = @@ -791,70 +793,70 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , line "You may want to decompose your data types into smaller types." ] renderSimpleErrorMessage (UnusedImport name) = - line $ "The import of module " ++ markCode (runModuleName name) ++ " is redundant" + line $ "The import of module " <> markCode (runModuleName name) <> " is redundant" renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) = - paras [ line $ "The import of module " ++ markCode (runModuleName mn) ++ " contains the following unused references:" + paras [ line $ "The import of module " <> markCode (runModuleName mn) <> " contains the following unused references:" , indent $ paras $ map (line . markCode . runName . Qualified Nothing) names , line "It could be replaced with:" , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage msg@(UnusedDctorImport mn name _ _) = - paras [line $ "The import of type " ++ markCode (runProperName name) - ++ " from module " ++ markCode (runModuleName mn) ++ " includes data constructors but only the type is used" + paras [line $ "The import of type " <> markCode (runProperName name) + <> " from module " <> markCode (runModuleName mn) <> " includes data constructors but only the type is used" , line "It could be replaced with:" , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage msg@(UnusedDctorExplicitImport mn name names _ _) = - paras [ line $ "The import of type " ++ markCode (runProperName name) - ++ " from module " ++ markCode (runModuleName mn) ++ " includes the following unused data constructors:" + paras [ line $ "The import of type " <> markCode (runProperName name) + <> " from module " <> markCode (runModuleName mn) <> " includes the following unused data constructors:" , indent $ paras $ map (line . markCode . runProperName) names , line "It could be replaced with:" , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage (DuplicateSelectiveImport name) = - line $ "There is an existing import of " ++ markCode (runModuleName name) ++ ", consider merging the import lists" + line $ "There is an existing import of " <> markCode (runModuleName name) <> ", consider merging the import lists" renderSimpleErrorMessage (DuplicateImport name imp qual) = - line $ "Duplicate import of " ++ markCode (prettyPrintImport name imp qual) + line $ "Duplicate import of " <> markCode (prettyPrintImport name imp qual) renderSimpleErrorMessage (DuplicateImportRef name) = - line $ "Import list contains multiple references to " ++ printName (Qualified Nothing name) + line $ "Import list contains multiple references to " <> printName (Qualified Nothing name) renderSimpleErrorMessage (DuplicateExportRef name) = - line $ "Export list contains multiple references to " ++ printName (Qualified Nothing name) + line $ "Export list contains multiple references to " <> printName (Qualified Nothing name) renderSimpleErrorMessage (IntOutOfRange value backend lo hi) = - paras [ line $ "Integer value " ++ markCode (show value) ++ " is out of range for the " ++ backend ++ " backend." - , line $ "Acceptable values fall within the range " ++ markCode (show lo) ++ " to " ++ markCode (show hi) ++ " (inclusive)." ] + paras [ line $ "Integer value " <> markCode (T.pack (show value)) <> " is out of range for the " <> backend <> " backend." + , line $ "Acceptable values fall within the range " <> markCode (T.pack (show lo)) <> " to " <> markCode (T.pack (show hi)) <> " (inclusive)." ] renderSimpleErrorMessage msg@(ImplicitQualifiedImport importedModule asModule _) = - paras [ line $ "Module " ++ markCode (runModuleName importedModule) ++ " was imported as " ++ markCode (runModuleName asModule) ++ " with unspecified imports." - , line $ "As there are multiple modules being imported as " ++ markCode (runModuleName asModule) ++ ", consider using the explicit form:" + paras [ line $ "Module " <> markCode (runModuleName importedModule) <> " was imported as " <> markCode (runModuleName asModule) <> " with unspecified imports." + , line $ "As there are multiple modules being imported as " <> markCode (runModuleName asModule) <> ", consider using the explicit form:" , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage msg@(ImplicitImport mn _) = - paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the explicit form: " + paras [ line $ "Module " <> markCode (runModuleName mn) <> " has unspecified imports, consider using the explicit form: " , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage msg@(HidingImport mn _) = - paras [ line $ "Module " ++ markCode (runModuleName mn) ++ " has unspecified imports, consider using the inclusive form: " + paras [ line $ "Module " <> markCode (runModuleName mn) <> " has unspecified imports, consider using the inclusive form: " , indent $ line $ markCode $ showSuggestion msg ] renderSimpleErrorMessage (CaseBinderLengthDiffers l bs) = paras [ line "Binder list length differs in case alternative:" - , indent $ line $ intercalate ", " $ fmap prettyPrintBinderAtom bs - , line $ "Expecting " ++ show l ++ " binder" ++ (if l == 1 then "" else "s") ++ "." + , indent $ line $ T.intercalate ", " $ fmap prettyPrintBinderAtom bs + , line $ "Expecting " <> T.pack (show l) <> " binder" <> (if l == 1 then "" else "s") <> "." ] renderSimpleErrorMessage IncorrectAnonymousArgument = line "An anonymous function argument appears in an invalid context." renderSimpleErrorMessage (InvalidOperatorInBinder op fn) = - paras [ line $ "Operator " ++ markCode (showQualified showOp op) ++ " cannot be used in a pattern as it is an alias for function " ++ showQualified showIdent fn ++ "." + paras [ line $ "Operator " <> markCode (showQualified showOp op) <> " cannot be used in a pattern as it is an alias for function " <> showQualified showIdent fn <> "." , line "Only aliases for data constructors may be used in patterns." ] @@ -862,18 +864,18 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS line "The require-path option is deprecated and will be removed in PureScript 0.9." renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) = - paras [ line $ "Unable to generalize the type of the recursive function " ++ markCode (showIdent ident) ++ "." - , line $ "The inferred type of " ++ markCode (showIdent ident) ++ " was:" + paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "." + , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:" , markCodeBox $ indent $ typeAsBox ty , line "Try adding a type signature." ] renderSimpleErrorMessage (CannotDeriveNewtypeForData tyName) = - paras [ line $ "Cannot derive an instance of the " ++ markCode "Newtype" ++ " class for non-newtype " ++ markCode (runProperName tyName) ++ "." + paras [ line $ "Cannot derive an instance of the " <> markCode "Newtype" <> " class for non-newtype " <> markCode (runProperName tyName) <> "." ] renderSimpleErrorMessage (ExpectedWildcard tyName) = - paras [ line $ "Expected a type wildcard (_) when deriving an instance for " ++ markCode (runProperName tyName) ++ "." + paras [ line $ "Expected a type wildcard (_) when deriving an instance for " <> markCode (runProperName tyName) <> "." ] renderHint :: ErrorMessageHint -> Box.Box -> Box.Box @@ -893,7 +895,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS ] ] renderHint (ErrorInModule mn) detail = - paras [ line $ "in module " ++ markCode (runModuleName mn) + paras [ line $ "in module " <> markCode (runModuleName mn) , detail ] renderHint (ErrorInSubsumption t1 t2) detail = @@ -958,15 +960,15 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS ] renderHint (ErrorInDataConstructor nm) detail = paras [ detail - , line $ "in data constructor " ++ markCode (runProperName nm) + , line $ "in data constructor " <> markCode (runProperName nm) ] renderHint (ErrorInTypeConstructor nm) detail = paras [ detail - , line $ "in type constructor " ++ markCode (runProperName nm) + , line $ "in type constructor " <> markCode (runProperName nm) ] renderHint (ErrorInBindingGroup nms) detail = paras [ detail - , line $ "in binding group " ++ intercalate ", " (map showIdent nms) + , line $ "in binding group " <> T.intercalate ", " (map showIdent nms) ] renderHint (ErrorInDataBindingGroup nms) detail = paras [ detail @@ -974,15 +976,15 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS ] renderHint (ErrorInTypeSynonym name) detail = paras [ detail - , line $ "in type synonym " ++ markCode (runProperName name) + , line $ "in type synonym " <> markCode (runProperName name) ] renderHint (ErrorInValueDeclaration n) detail = paras [ detail - , line $ "in value declaration " ++ markCode (showIdent n) + , line $ "in value declaration " <> markCode (showIdent n) ] renderHint (ErrorInTypeDeclaration n) detail = paras [ detail - , line $ "in type declaration for " ++ markCode (showIdent n) + , line $ "in type declaration for " <> markCode (showIdent n) ] renderHint (ErrorInTypeClassDeclaration name) detail = paras [ detail @@ -990,7 +992,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS ] renderHint (ErrorInForeignImport nm) detail = paras [ detail - , line $ "in foreign import " ++ markCode (showIdent nm) + , line $ "in foreign import " <> markCode (showIdent nm) ] renderHint (ErrorSolvingConstraint (Constraint nm ts _)) detail = paras [ detail @@ -1001,7 +1003,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS ] ] renderHint (PositionedError srcSpan) detail = - paras [ line $ "at " ++ displaySourceSpan srcSpan + paras [ line $ "at " <> displaySourceSpan srcSpan , detail ] @@ -1010,17 +1012,17 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS renderContext ctx = [ line "in the following context:" , indent $ paras - [ Box.hcat Box.left [ Box.text (showIdent ident <> " :: ") + [ Box.hcat Box.left [ Box.text (T.unpack (showIdent ident) ++ " :: ") , markCodeBox $ typeAsBox ty' ] | (ident, ty') <- take 5 ctx ] ] - printName :: Qualified Name -> String - printName qn = nameType (disqualify qn) ++ " " ++ markCode (runName qn) + printName :: Qualified Name -> Text + printName qn = nameType (disqualify qn) <> " " <> markCode (runName qn) - nameType :: Name -> String + nameType :: Name -> Text nameType (IdentName _) = "value" nameType (ValOpName _) = "operator" nameType (TyName _) = "type" @@ -1029,7 +1031,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS nameType (TyClassName _) = "type class" nameType (ModName _) = "module" - runName :: Qualified Name -> String + runName :: Qualified Name -> Text runName (Qualified mn (IdentName name)) = showQualified showIdent (Qualified mn name) runName (Qualified mn (ValOpName op)) = @@ -1051,7 +1053,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS valueDepth | full = 1000 | otherwise = 3 - levelText :: String + levelText :: Text levelText = case level of Error -> "error" Warning -> "warning" @@ -1112,40 +1114,40 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS hintCategory _ = OtherHint -- Pretty print and export declaration -prettyPrintExport :: DeclarationRef -> String +prettyPrintExport :: DeclarationRef -> Text prettyPrintExport (TypeRef pn _) = runProperName pn prettyPrintExport ref = fromMaybe (internalError "prettyPrintRef returned Nothing in prettyPrintExport") (prettyPrintRef ref) -prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> String +prettyPrintImport :: ModuleName -> ImportDeclarationType -> Maybe ModuleName -> Text prettyPrintImport mn idt qual = let i = case idt of Implicit -> runModuleName mn - Explicit refs -> runModuleName mn ++ " (" ++ intercalate ", " (mapMaybe prettyPrintRef refs) ++ ")" - Hiding refs -> runModuleName mn ++ " hiding (" ++ intercalate "," (mapMaybe prettyPrintRef refs) ++ ")" - in i ++ maybe "" (\q -> " as " ++ runModuleName q) qual + Explicit refs -> runModuleName mn <> " (" <> T.intercalate ", " (mapMaybe prettyPrintRef refs) <> ")" + Hiding refs -> runModuleName mn <> " hiding (" <> T.intercalate "," (mapMaybe prettyPrintRef refs) <> ")" + in i <> maybe "" (\q -> " as " <> runModuleName q) qual -prettyPrintRef :: DeclarationRef -> Maybe String +prettyPrintRef :: DeclarationRef -> Maybe Text prettyPrintRef (TypeRef pn Nothing) = - Just $ runProperName pn ++ "(..)" + Just $ runProperName pn <> "(..)" prettyPrintRef (TypeRef pn (Just [])) = Just $ runProperName pn prettyPrintRef (TypeRef pn (Just dctors)) = - Just $ runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")" + Just $ runProperName pn <> "(" <> T.intercalate ", " (map runProperName dctors) <> ")" prettyPrintRef (TypeOpRef op) = - Just $ "type " ++ showOp op + Just $ "type " <> showOp op prettyPrintRef (ValueRef ident) = Just $ showIdent ident prettyPrintRef (ValueOpRef op) = Just $ showOp op prettyPrintRef (TypeClassRef pn) = - Just $ "class " ++ runProperName pn + Just $ "class " <> runProperName pn prettyPrintRef (TypeInstanceRef ident) = Just $ showIdent ident prettyPrintRef (ModuleRef name) = - Just $ "module " ++ runModuleName name + Just $ "module " <> runModuleName name prettyPrintRef (ReExportRef _ _) = Nothing prettyPrintRef (PositionedDeclarationRef _ _ ref) = @@ -1238,8 +1240,11 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd indent :: Box.Box -> Box.Box indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2 -line :: String -> Box.Box -line = Box.text +line :: Text -> Box.Box +line = Box.text . T.unpack + +lineS :: String -> Box.Box +lineS = Box.text renderBox :: Box.Box -> String renderBox = unlines @@ -1253,7 +1258,7 @@ renderBox = unlines whiteSpace = all isSpace toTypelevelString :: Type -> Maybe Box.Box -toTypelevelString (TypeLevelString s) = Just $ Box.text s +toTypelevelString (TypeLevelString s) = Just $ Box.text (T.unpack s) toTypelevelString (TypeApp (TypeConstructor f) x) | f == primName "TypeString" = Just $ typeAsBox x toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret) diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index c6936404e8..8b0eadc9fb 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -5,6 +5,9 @@ module Language.PureScript.Errors.JSON where import Prelude.Compat import qualified Data.Aeson.TH as A +import Data.Monoid ((<>)) +import qualified Data.Text as T +import Data.Text (Text) import qualified Language.PureScript as P @@ -16,17 +19,17 @@ data ErrorPosition = ErrorPosition } deriving (Show, Eq, Ord) data ErrorSuggestion = ErrorSuggestion - { replacement :: String + { replacement :: Text , replaceRange :: Maybe ErrorPosition } deriving (Show, Eq) data JSONError = JSONError { position :: Maybe ErrorPosition , message :: String - , errorCode :: String - , errorLink :: String + , errorCode :: Text + , errorLink :: Text , filename :: Maybe String - , moduleName :: Maybe String + , moduleName :: Maybe Text , suggestion :: Maybe ErrorSuggestion } deriving (Show, Eq) @@ -70,4 +73,4 @@ toJSONError verbose level e = Just s -> Just $ ErrorSuggestion (suggestionText s) (toErrorPosition <$> P.suggestionSpan em) -- TODO: Adding a newline because source spans chomp everything up to the next character - suggestionText (P.ErrorSuggestion s) = if null s then s else s ++ "\n" + suggestionText (P.ErrorSuggestion s) = if T.null s then s else s <> "\n" diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 06d93a82ae..1000ee2bf0 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -17,9 +17,11 @@ module Language.PureScript.Externs import Prelude.Compat import Data.Aeson.TH +import Data.Maybe (fromMaybe, mapMaybe, maybeToList) +import Data.List (foldl', find) import Data.Foldable (fold) -import Data.List (find, foldl') -import Data.Maybe (mapMaybe, maybeToList, fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T import Data.Version (showVersion) import qualified Data.Map as M @@ -37,7 +39,7 @@ import Paths_purescript as Paths data ExternsFile = ExternsFile { -- | The externs version - efVersion :: String + efVersion :: Text -- | Module name , efModuleName :: ModuleName -- | List of module exports @@ -100,7 +102,7 @@ data ExternsDeclaration = -- | A type synonym | EDTypeSynonym { edTypeSynonymName :: ProperName 'TypeName - , edTypeSynonymArguments :: [(String, Maybe Kind)] + , edTypeSynonymArguments :: [(Text, Maybe Kind)] , edTypeSynonymType :: Type } -- | A data construtor @@ -119,7 +121,7 @@ data ExternsDeclaration = -- | A type class declaration | EDClass { edClassName :: ProperName 'ClassName - , edClassTypeArguments :: [(String, Maybe Kind)] + , edClassTypeArguments :: [(Text, Maybe Kind)] , edClassMembers :: [(Ident, Type)] , edClassConstraints :: [Constraint] , edFunctionalDependencies :: [FunctionalDependency] @@ -159,7 +161,7 @@ moduleToExternsFile :: Module -> Environment -> ExternsFile moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated" moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} where - efVersion = showVersion Paths.version + efVersion = T.pack (showVersion Paths.version) efModuleName = mn efExports = exps efImports = mapMaybe importDecl ds @@ -180,7 +182,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} typeFixityDecl _ = Nothing findOp :: (DeclarationRef -> Maybe (OpName a)) -> OpName a -> DeclarationRef -> Bool - findOp get op = maybe False (== op) . get + findOp g op = maybe False (== op) . g importDecl :: Declaration -> Maybe ExternsImport importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 0c466ca788..25ce106ecf 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -142,7 +142,7 @@ findAvailableExterns = do liftIO $ do directories <- getDirectoryContents oDir moduleNames <- filterM (containsExterns oDir) directories - pure (P.moduleNameFromString <$> moduleNames) + pure (P.moduleNameFromString . toS <$> moduleNames) where -- Takes the output directory and a filepath like "Monad.Control.Eff" and -- looks up, whether that folder contains an externs.json @@ -171,7 +171,7 @@ loadModules moduleNames = do -- We resolve all the modulenames to externs files and load these into memory. oDir <- outputDirectory let efPaths = - map (\mn -> oDir P.runModuleName mn "externs.json") moduleNames + map (\mn -> oDir toS (P.runModuleName mn) "externs.json") moduleNames efiles <- traverse readExternFile efPaths traverse_ insertExterns efiles diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index b45e367b49..a490eb92dc 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -145,7 +145,7 @@ step (Res start end) _ = Res start end moduleParse :: [Text] -> Either Text P.Module moduleParse t = first show $ do - tokens <- (P.lex "" . T.unpack . T.unlines) t + tokens <- P.lex "" (T.unlines t) P.runTokenParser "" P.parseModule tokens -- | Adds an implicit import like @import Prelude@ to a Sourcefile. @@ -210,7 +210,7 @@ addExplicitImport' decl moduleName imports = refFromDeclaration (IdeDeclTypeOperator op) = P.TypeOpRef (op ^. ideTypeOpName) refFromDeclaration d = - P.ValueRef $ P.Ident $ T.unpack (identifierFromIdeDeclaration d) + P.ValueRef (P.Ident (identifierFromIdeDeclaration d)) -- | Adds a declaration to an import: -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) @@ -304,9 +304,9 @@ addImportForIdentifier fp ident filters = do prettyPrintImport' :: Import -> Text -- TODO: remove this clause once P.prettyPrintImport can properly handle PositionedRefs prettyPrintImport' (Import mn (P.Explicit refs) qual) = - T.pack $ "import " ++ P.prettyPrintImport mn (P.Explicit (unwrapPositionedRef <$> refs)) qual + "import " <> P.prettyPrintImport mn (P.Explicit (unwrapPositionedRef <$> refs)) qual prettyPrintImport' (Import mn idt qual) = - T.pack $ "import " ++ P.prettyPrintImport mn idt qual + "import " <> P.prettyPrintImport mn idt qual prettyPrintImportSection :: [Import] -> [Text] prettyPrintImportSection imports = map prettyPrintImport' (sort imports) @@ -325,7 +325,7 @@ answerRequest outfp rs = -- | Test and ghci helper parseImport :: Text -> Maybe Import parseImport t = - case P.lex "" (T.unpack t) + case P.lex "" t >>= P.runTokenParser "" P.parseImportDeclaration' of Right (mn, P.Explicit refs, mmn) -> Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index e9534e3a3e..f82b7d5865 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -16,9 +16,12 @@ module Language.PureScript.Interactive import Prelude () import Prelude.Compat -import Data.List (intercalate, nub, sort, find, foldl') +import Data.List (nub, sort, find, foldl') import Data.Maybe (mapMaybe) import qualified Data.Map as M +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State.Class @@ -165,7 +168,7 @@ handleShowLoadedModules = do loadedModules <- gets psciLoadedExterns liftIO $ putStrLn (readModules loadedModules) where - readModules = unlines . sort . nub . map (P.runModuleName . P.getModuleName . fst) + readModules = unlines . sort . nub . map (T.unpack . P.runModuleName . P.getModuleName . fst) -- | Show the imported modules in psci. handleShowImportedModules @@ -176,38 +179,38 @@ handleShowImportedModules = do liftIO $ showModules importedModules >>= putStrLn return () where - showModules = return . unlines . sort . map showModule + showModules = return . unlines . sort . map (T.unpack . showModule) showModule (mn, declType, asQ) = - "import " ++ N.runModuleName mn ++ showDeclType declType ++ - foldMap (\mn' -> " as " ++ N.runModuleName mn') asQ + "import " <> N.runModuleName mn <> showDeclType declType <> + foldMap (\mn' -> " as " <> N.runModuleName mn') asQ showDeclType P.Implicit = "" showDeclType (P.Explicit refs) = refsList refs - showDeclType (P.Hiding refs) = " hiding " ++ refsList refs - refsList refs = " (" ++ commaList (mapMaybe showRef refs) ++ ")" + showDeclType (P.Hiding refs) = " hiding " <> refsList refs + refsList refs = " (" <> commaList (mapMaybe showRef refs) <> ")" - showRef :: P.DeclarationRef -> Maybe String + showRef :: P.DeclarationRef -> Maybe Text showRef (P.TypeRef pn dctors) = - Just $ N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")" + Just $ N.runProperName pn <> "(" <> maybe ".." (commaList . map N.runProperName) dctors <> ")" showRef (P.TypeOpRef op) = - Just $ "type " ++ N.showOp op + Just $ "type " <> N.showOp op showRef (P.ValueRef ident) = Just $ N.runIdent ident showRef (P.ValueOpRef op) = Just $ N.showOp op showRef (P.TypeClassRef pn) = - Just $ "class " ++ N.runProperName pn + Just $ "class " <> N.runProperName pn showRef (P.TypeInstanceRef ident) = Just $ N.runIdent ident showRef (P.ModuleRef name) = - Just $ "module " ++ N.runModuleName name + Just $ "module " <> N.runModuleName name showRef (P.ReExportRef _ _) = Nothing showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref - commaList :: [String] -> String - commaList = intercalate ", " + commaList :: [Text] -> Text + commaList = T.intercalate ", " -- | Imports a module, preserving the initial state on failure. handleImport @@ -260,7 +263,7 @@ handleKindOf typ = do check sew = fst . runWriter . runExceptT . runStateT sew case k of Left err -> printErrors err - Right (kind, _) -> liftIO . putStrLn . P.prettyPrintKind $ kind + Right (kind, _) -> liftIO . putStrLn . T.unpack . P.prettyPrintKind $ kind Nothing -> liftIO $ putStrLn "Could not find kind" -- | Browse a module and displays its signature @@ -284,6 +287,6 @@ handleBrowse moduleName = do isModInEnv modName = any ((== modName) . P.getModuleName . fst) . psciLoadedExterns failNotInEnv modName = - liftIO $ putStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid." + liftIO $ putStrLn $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid." lookupUnQualifiedModName quaModName st = (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st) diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index 5a875c7e71..33aab4125d 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -16,6 +16,8 @@ import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) import Data.Function (on) import Data.List (nub, nubBy, isPrefixOf, sortBy, stripPrefix) import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T import qualified Language.PureScript as P import qualified Language.PureScript.Interactive.Directive as D import Language.PureScript.Interactive.Types @@ -145,7 +147,7 @@ getLoadedModules = asks (map fst . psciLoadedExterns) getModuleNames :: CompletionM [String] getModuleNames = moduleNames <$> getLoadedModules -mapLoadedModulesAndQualify :: (a -> String) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String] +mapLoadedModulesAndQualify :: (a -> Text) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String] mapLoadedModulesAndQualify sho f = do ms <- getLoadedModules let argPairs = do m <- ms @@ -165,14 +167,14 @@ getTypeNames = mapLoadedModulesAndQualify P.runProperName typeDecls -- | Given a module and a declaration in that module, return all possible ways -- it could have been referenced given the current PSCiState - including fully -- qualified, qualified using an alias, and unqualified. -getAllQualifications :: (a -> String) -> P.Module -> (a, P.Declaration) -> CompletionM [String] +getAllQualifications :: (a -> Text) -> P.Module -> (a, P.Declaration) -> CompletionM [String] getAllQualifications sho m (declName, decl) = do imports <- getAllImportsOf m let fullyQualified = qualifyWith (Just (P.getModuleName m)) let otherQuals = nub (concatMap qualificationsUsing imports) return $ fullyQualified : otherQuals where - qualifyWith mMod = P.showQualified sho (P.Qualified mMod declName) + qualifyWith mMod = T.unpack (P.showQualified sho (P.Qualified mMod declName)) referencedBy refs = P.isExported (Just refs) decl qualificationsUsing (_, importType, asQ') = @@ -220,4 +222,4 @@ dctorNames = nubOnFst . concatMap go . P.exportedDeclarations go _ = [] moduleNames :: [P.Module] -> [String] -moduleNames = nub . map (P.runModuleName . P.getModuleName) +moduleNames = nub . map (T.unpack . P.runModuleName . P.getModuleName) diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index c4397f3821..e310543474 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -9,6 +9,7 @@ import Prelude.Compat hiding (lex) import Data.Char (isSpace) import Data.List (intercalate) +import qualified Data.Text as T import Text.Parsec hiding ((<|>)) import qualified Language.PureScript as P import qualified Language.PureScript.Interactive.Directive as D @@ -26,7 +27,7 @@ parseCommand cmdString = parseRest :: P.TokenParser a -> String -> Either String a parseRest p s = either (Left . show) Right $ do - ts <- P.lex "" s + ts <- P.lex "" (T.pack s) P.runTokenParser "" (p <* eof) ts psciCommand :: P.TokenParser Command diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index 14889e8b27..5d47f50b85 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -8,9 +8,16 @@ import Prelude.Compat import Data.List (intersperse) import qualified Data.Map as M import Data.Maybe (mapMaybe) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import Data.Text (Text) import qualified Language.PureScript as P import qualified Text.PrettyPrint.Boxes as Box +-- TODO (Christoph): Text version of boxes +textT :: Text -> Box.Box +textT = Box.text . T.unpack + -- Printers -- | @@ -40,7 +47,7 @@ printModuleSignatures moduleName P.Environment{..} = findNameType envNames m = (P.disqualify m, M.lookup m envNames) showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box - showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType + showNameType (mIdent, Just (mType, _, _)) = textT (P.showIdent mIdent <> " :: ") Box.<> P.typeAsBox mType showNameType _ = P.internalError "The impossible happened in printModuleSignatures." findTypeClass @@ -58,13 +65,13 @@ printModuleSignatures moduleName P.Environment{..} = if null typeClassSuperclasses then Box.text "" else Box.text "(" - Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint (P.Qualified _ pn) lt _) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) typeClassSuperclasses) + Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint (P.Qualified _ pn) lt _) -> textT (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) typeClassSuperclasses) Box.<> Box.text ") <= " className = - Box.text (P.runProperName name) - Box.<> Box.text (concatMap ((' ':) . fst) typeClassArguments) + textT (P.runProperName name) + Box.<> textT (foldMap ((" " <>) . fst) typeClassArguments) classBody = - Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) typeClassMembers) + Box.vcat Box.top (map (\(i, t) -> textT (P.showIdent i <> " ::") Box.<+> P.typeAsBox t) typeClassMembers) in Just $ @@ -84,7 +91,7 @@ printModuleSignatures moduleName P.Environment{..} = showType :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident]) - -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type) + -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(Text, Maybe P.Kind)], P.Type) -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind)) -> Maybe Box.Box showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) = @@ -95,7 +102,7 @@ printModuleSignatures moduleName P.Environment{..} = Nothing else Just $ - Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) + textT ("type " <> P.runProperName name <> foldMap ((" " <>) . fst) typevars) Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType) (Just (_, P.DataType typevars pt), _) -> @@ -108,7 +115,7 @@ printModuleSignatures moduleName P.Environment{..} = _ -> "data" in - Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt + Just $ textT (prefix <> " " <> P.runProperName name <> foldMap ((" " <>) . fst) typevars) Box.// printCons pt _ -> Nothing @@ -117,7 +124,7 @@ printModuleSignatures moduleName P.Environment{..} = Box.moveRight 2 $ Box.vcat Box.left $ mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $ - map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt + map (\(cons,idents) -> (textT (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 578b1742e3..8b7d18447d 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -11,6 +11,7 @@ import Data.List (nub, (\\)) import Data.Maybe (mapMaybe) import Data.Monoid import qualified Data.Set as S +import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Crash @@ -81,10 +82,10 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl checkTypeVars :: S.Set String -> Type -> MultipleErrors checkTypeVars set ty = everythingWithContextOnTypes set mempty mappend step ty <> findUnused ty where - step :: S.Set String -> Type -> (S.Set String, MultipleErrors) + step :: S.Set Text -> Type -> (S.Set Text, MultipleErrors) step s (ForAll tv _ _) = bindVar s tv step s _ = (s, mempty) - bindVar :: S.Set String -> String -> (S.Set String, MultipleErrors) + bindVar :: S.Set Text -> Text -> (S.Set Text, MultipleErrors) bindVar = bind ShadowedTypeVar findUnused :: Type -> MultipleErrors findUnused ty' = @@ -93,7 +94,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl unused = nub declared \\ nub used in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused where - go :: Type -> [String] + go :: Type -> [Text] go (ForAll tv _ _) = [tv] go _ = [] diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 768bd0cd67..25c5bec1ee 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -19,7 +19,10 @@ import Control.Monad.Supply.Class (MonadSupply, fresh, freshName) import Data.Function (on) import Data.List (foldl', sortBy, nub) import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.AST.Binders import Language.PureScript.AST.Declarations @@ -77,7 +80,7 @@ getConstructors env defmn n = extractConstructors lnte getConsDataName :: Qualified (ProperName 'ConstructorName) -> Qualified (ProperName 'TypeName) getConsDataName con = case getConsInfo con of - Nothing -> internalError $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName." + Nothing -> internalError $ "Constructor " ++ T.unpack (showQualified runProperName con) ++ " not in the scope of the current environment in getConsDataName." Just (_, pm, _, _) -> qualifyName pm defmn con getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, Type, [Ident]) @@ -276,14 +279,14 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step ( -- and then included in the error message. addPartialConstraint :: ([[Binder]], Bool) -> Expr -> m Expr addPartialConstraint (bss, complete) e = do - tyVar <- ("p" ++) . show <$> fresh + tyVar <- ("p" <>) . T.pack . show <$> fresh var <- freshName return $ Let [ partial var tyVar ] $ App (Var (Qualified Nothing (Ident C.__unused))) e where - partial :: String -> String -> Declaration + partial :: Text -> Text -> Declaration partial var tyVar = ValueDeclaration (Ident C.__unused) Private [] $ Right $ TypedValue @@ -291,7 +294,7 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step ( (Abs (Left (Ident var)) (Var (Qualified Nothing (Ident var)))) (ty tyVar) - ty :: String -> Type + ty :: Text -> Type ty tyVar = ForAll tyVar ( ConstrainedType diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 7db7706226..1dfcede5e8 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -15,6 +15,7 @@ import Data.List (find, intersect, nub, groupBy, sortBy, (\\)) import Data.Maybe (mapMaybe, fromMaybe) import Data.Monoid (Sum(..)) import Data.Traversable (forM) +import qualified Data.Text as T import qualified Data.Map as M import Language.PureScript.AST.Declarations @@ -329,8 +330,8 @@ findUsedRefs env mni qn names = Just (_, _, exps) -> case find (elem dctor . fst . snd) (M.toList (exportedTypes exps)) of Just (ty, _) -> ty - Nothing -> internalError $ "missing type for data constructor " ++ runProperName dctor ++ " in findTypeForDctor" - Nothing -> internalError $ "missing module " ++ runModuleName mn ++ " in findTypeForDctor" + Nothing -> internalError $ "missing type for data constructor " ++ T.unpack (runProperName dctor) ++ " in findTypeForDctor" + Nothing -> internalError $ "missing module " ++ T.unpack (runModuleName mn) ++ " in findTypeForDctor" matchName :: (ProperName 'ConstructorName -> Maybe (ProperName 'TypeName)) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 668231b074..f70e6b8717 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -38,13 +38,12 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Aeson (encode, decode) import qualified Data.Aeson as Aeson -import Data.ByteString.Builder (toLazyByteString, stringUtf8) import Data.Either (partitionEithers) import Data.Function (on) import Data.Foldable (for_) import Data.List (foldl', sortBy, groupBy) import Data.Maybe (fromMaybe, catMaybes) -import Data.String (fromString) +import Data.Monoid ((<>)) import Data.Time.Clock import Data.Traversable (for) import Data.Version (showVersion) @@ -52,6 +51,8 @@ import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.UTF8 as BU8 import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import Language.PureScript.AST import Language.PureScript.Crash @@ -83,7 +84,6 @@ import SourceMap.Types import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise, replaceExtension) import System.IO.Error (tryIOError) -import System.IO.UTF8 (readUTF8File, writeUTF8File) import qualified Text.Parsec as Parsec @@ -94,7 +94,7 @@ data ProgressMessage -- | Render a progress message renderProgressMessage :: ProgressMessage -> String -renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn +renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModuleName mn) -- | Actions that require implementations when running in "make" mode. -- @@ -125,7 +125,7 @@ data MakeActions m = MakeActions -- | -- Generated code for an externs file. -- -type Externs = String +type Externs = B.ByteString -- | -- Determines when to rebuild a module @@ -155,7 +155,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do corefn = CF.moduleToCoreFn env' mod' [renamed] = renameInModules [corefn] exts = moduleToExternsFile mod' env' - evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts + evalSupplyT nextVar . codegen renamed env' . encode $ exts return exts -- | @@ -256,8 +256,8 @@ make ma@MakeActions{..} ms = do decodeExterns :: Externs -> Maybe ExternsFile decodeExterns bs = do - externs <- decode (toLazyByteString (stringUtf8 bs)) - guard $ efVersion externs == showVersion Paths.version + externs <- decode bs + guard $ T.unpack (efVersion externs) == showVersion Paths.version return externs importPrim :: Module -> Module @@ -290,8 +290,8 @@ makeIO f io = do -- | Read a text file in the 'Make' monad, capturing any errors using the -- 'MonadError' instance. -readTextFile :: FilePath -> Make String -readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path +readTextFile :: FilePath -> Make B.ByteString +readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path -- | Infer the module name for a module by looking for the same filename with -- a .js extension. @@ -332,14 +332,14 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) getOutputTimestamp mn = do - let filePath = runModuleName mn + let filePath = T.unpack (runModuleName mn) jsFile = outputDir filePath "index.js" externsFile = outputDir filePath "externs.json" min <$> getTimestamp jsFile <*> getTimestamp externsFile readExterns :: ModuleName -> Make (FilePath, Externs) readExterns mn = do - let path = outputDir runModuleName mn "externs.json" + let path = outputDir T.unpack (runModuleName mn) "externs.json" (path, ) <$> readTextFile path codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make () @@ -359,16 +359,16 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory sourceMaps <- lift $ asks optionsSourceMaps let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, []) - let filePath = runModuleName mn + let filePath = T.unpack (runModuleName mn) jsFile = outputDir filePath "index.js" mapFile = outputDir filePath "index.js.map" externsFile = outputDir filePath "externs.json" foreignFile = outputDir filePath "foreign.js" - prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix] - js = unlines $ map ("// " ++) prefix ++ [pjs] + prefix = ["Generated by psc version " <> T.pack (showVersion Paths.version) | usePrefix] + js = T.unlines $ map ("// " <>) prefix ++ [pjs] mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else "" lift $ do - writeTextFile jsFile (fromString $ js ++ mapRef) + writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef) for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile) writeTextFile externsFile exts lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings @@ -376,14 +376,14 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = when dumpCoreFn $ do let coreFnFile = outputDir filePath "corefn.json" let jsonPayload = CFJ.moduleToJSON Paths.version m - let json = Aeson.object [ (fromString (runModuleName mn), jsonPayload) ] - lift $ writeTextFile coreFnFile (BU8.toString . B.toStrict . encode $ json) + let json = Aeson.object [ (runModuleName mn, jsonPayload) ] + lift $ writeTextFile coreFnFile (encode json) genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do let pathToDir = iterate (".." ) ".." !! length (splitPath $ normalise outputDir) sourceFile = case mappings of - (SMap file _ _ : _) -> Just $ pathToDir makeRelative dir file + (SMap file _ _ : _) -> Just $ pathToDir makeRelative dir (T.unpack file) _ -> Nothing let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings = map (\(SMap _ orig gen) -> Mapping { @@ -394,7 +394,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = }) mappings } let mapping = generate rawMapping - writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping + writeTextFile mapFile (encode mapping) where add :: Int -> Int -> SourcePos -> SourcePos add n m (SourcePos n' m') = SourcePos (n+n') (m+m') @@ -411,10 +411,10 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = exists <- doesFileExist path traverse (const $ getModificationTime path) $ guard exists - writeTextFile :: FilePath -> String -> Make () + writeTextFile :: FilePath -> B.ByteString -> Make () writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do mkdirp path - writeUTF8File path text + B.writeFile path text where mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory @@ -429,7 +429,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make () checkForeignDecls m path = do jsStr <- lift $ readTextFile path - js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path + js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse (BU8.toString (B.toStrict jsStr)) path foreignIdentsStrs <- either errorParsingModule pure $ getExps js foreignIdents <- either @@ -455,11 +455,11 @@ checkForeignDecls m path = do errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String] - getExps = Bundle.getExportedIdentifiers (runModuleName mname) + getExps = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname)) errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a errorInvalidForeignIdentifiers = - throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname) + throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack) parseIdents :: [String] -> Either [String] [Ident] parseIdents strs = @@ -472,7 +472,7 @@ checkForeignDecls m path = do -- We ignore the error message here, just being told it's an invalid -- identifier should be enough. parseIdent :: String -> Either String Ident - parseIdent str = try str + parseIdent str = try (T.pack str) where try s = either (const (Left str)) Right $ do ts <- PSParser.lex "" s diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 6df81855fc..508a256f6d 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -11,7 +11,9 @@ import Control.Monad.Supply.Class import Data.Aeson import Data.Aeson.TH -import Data.List +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T -- | A sum of the possible name types, useful for error and lint messages. data Name @@ -59,22 +61,22 @@ data Ident -- | -- An alphanumeric identifier -- - = Ident String + = Ident Text -- | -- A generated name for an identifier -- - | GenIdent (Maybe String) Integer + | GenIdent (Maybe Text) Integer deriving (Show, Eq, Ord) -runIdent :: Ident -> String +runIdent :: Ident -> Text runIdent (Ident i) = i -runIdent (GenIdent Nothing n) = "$" ++ show n -runIdent (GenIdent (Just name) n) = "$" ++ name ++ show n +runIdent (GenIdent Nothing n) = "$" <> T.pack (show n) +runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n) -showIdent :: Ident -> String +showIdent :: Ident -> Text showIdent = runIdent -freshIdent :: MonadSupply m => String -> m Ident +freshIdent :: MonadSupply m => Text -> m Ident freshIdent name = GenIdent (Just name) <$> fresh freshIdent' :: MonadSupply m => m Ident @@ -83,7 +85,7 @@ freshIdent' = GenIdent Nothing <$> fresh -- | -- Operator alias names. -- -newtype OpName (a :: OpNameType) = OpName { runOpName :: String } +newtype OpName (a :: OpNameType) = OpName { runOpName :: Text } deriving (Show, Eq, Ord) instance ToJSON (OpName a) where @@ -92,8 +94,8 @@ instance ToJSON (OpName a) where instance FromJSON (OpName a) where parseJSON = fmap OpName . parseJSON -showOp :: OpName a -> String -showOp op = '(' : runOpName op ++ ")" +showOp :: OpName a -> Text +showOp op = "(" <> runOpName op <> ")" -- | -- The closed set of operator alias types. @@ -103,7 +105,7 @@ data OpNameType = ValueOpName | TypeOpName -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. -- -newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: String } +newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text } deriving (Show, Eq, Ord) instance ToJSON (ProperName a) where @@ -131,16 +133,16 @@ coerceProperName = ProperName . runProperName newtype ModuleName = ModuleName [ProperName 'Namespace] deriving (Show, Eq, Ord) -runModuleName :: ModuleName -> String -runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns) +runModuleName :: ModuleName -> Text +runModuleName (ModuleName pns) = T.intercalate "." (runProperName <$> pns) -moduleNameFromString :: String -> ModuleName +moduleNameFromString :: Text -> ModuleName moduleNameFromString = ModuleName . splitProperNames where - splitProperNames s = case dropWhile (== '.') s of + splitProperNames s = case T.dropWhile (== '.') s of "" -> [] s' -> ProperName w : splitProperNames s'' - where (w, s'') = break (== '.') s' + where (w, s'') = T.break (== '.') s' -- | -- A qualified name, i.e. a name with an optional module name @@ -148,9 +150,9 @@ moduleNameFromString = ModuleName . splitProperNames data Qualified a = Qualified (Maybe ModuleName) a deriving (Show, Eq, Ord, Functor) -showQualified :: (a -> String) -> Qualified a -> String +showQualified :: (a -> Text) -> Qualified a -> Text showQualified f (Qualified Nothing a) = f a -showQualified f (Qualified (Just name) a) = runModuleName name ++ "." ++ f a +showQualified f (Qualified (Just name) a) = runModuleName name <> "." <> f a getQual :: Qualified a -> Maybe ModuleName getQual (Qualified mn _) = mn diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index e786a502aa..67b42058e4 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -5,8 +5,11 @@ module Language.PureScript.Parser.Common where import Prelude.Compat -import Control.Applicative +import Control.Applicative ((<|>)) import Control.Monad (guard) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.AST.SourcePos import Language.PureScript.Comments @@ -79,8 +82,8 @@ augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q -- Run the first parser, then match the second zero or more times, applying the specified function for each match -- fold :: P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a -fold first more combine = do - a <- first +fold first' more combine = do + a <- first' bs <- P.many more return $ foldl combine a bs @@ -88,8 +91,8 @@ fold first more combine = do -- Build a parser from a smaller parser and a list of parsers for postfix operators -- buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a -buildPostfixParser fs first = do - a <- first +buildPostfixParser fs first' = do + a <- first' go a where go a = do @@ -114,25 +117,25 @@ mark p = do -- Check that the current identation level matches a predicate -- checkIndentation - :: (P.Column -> String) + :: (P.Column -> Text) -> (P.Column -> P.Column -> Bool) -> P.Parsec s ParseState () checkIndentation mkMsg rel = do col <- P.sourceColumn <$> P.getPosition current <- indentationLevel <$> P.getState - guard (col `rel` current) P. mkMsg current + guard (col `rel` current) P. T.unpack (mkMsg current) -- | -- Check that the current indentation level is past the current mark -- indented :: P.Parsec s ParseState () -indented = checkIndentation (("indentation past column " ++) . show) (>) +indented = checkIndentation (("indentation past column " <>) . (T.pack . show)) (>) -- | -- Check that the current indentation level is at the same indentation as the current mark -- same :: P.Parsec s ParseState () -same = checkIndentation (("indentation at column " ++) . show) (==) +same = checkIndentation (("indentation at column " <>) . (T.pack . show)) (==) -- | -- Read the comments from the the next token, without consuming it diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index d15679c744..eea6165a4c 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -61,7 +61,7 @@ withSourceSpan f p = do let sp = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos $ fromMaybe end end') return $ f sp comments x -kindedIdent :: TokenParser (String, Maybe Kind) +kindedIdent :: TokenParser (Text, Maybe Kind) kindedIdent = (, Nothing) <$> identifier <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind))) @@ -303,7 +303,7 @@ parseModuleFromFile -> Either P.ParseError (k, Module) parseModuleFromFile toFilePath (k, content) = do let filename = toFilePath k - ts <- lex' filename content + ts <- lex filename content m <- runTokenParser filename parseModule ts pure (k, m) @@ -333,10 +333,10 @@ parseBooleanLiteral = BooleanLiteral <$> booleanLiteral parseArrayLiteral :: TokenParser a -> TokenParser (Literal a) parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p) -parseObjectLiteral :: TokenParser (String, a) -> TokenParser (Literal a) +parseObjectLiteral :: TokenParser (Text, a) -> TokenParser (Literal a) parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p) -parseIdentifierAndValue :: TokenParser (String, Expr) +parseIdentifierAndValue :: TokenParser (Text, Expr) parseIdentifierAndValue = do name <- C.indented *> lname @@ -423,7 +423,7 @@ parseInfixExpr parseHole :: TokenParser Expr parseHole = Hole <$> holeLit -parsePropertyUpdate :: TokenParser (String, Expr) +parsePropertyUpdate :: TokenParser (Text, Expr) parsePropertyUpdate = do name <- lname <|> stringLiteral _ <- C.indented *> equals @@ -515,7 +515,7 @@ parseVarOrNamedBinder = do parseNullBinder :: TokenParser Binder parseNullBinder = underscore *> return NullBinder -parseIdentifierAndBinder :: TokenParser (String, Binder) +parseIdentifierAndBinder :: TokenParser (Text, Binder) parseIdentifierAndBinder = do name <- lname b <- P.option (VarBinder (Ident name)) rest diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 286bb73026..3382ea2c2c 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -6,7 +6,6 @@ module Language.PureScript.Parser.Lexer , Token() , TokenParser() , lex - , lex' , anyToken , token , match @@ -63,13 +62,13 @@ module Language.PureScript.Parser.Lexer ) where -import Prelude hiding (lex) +import Prelude.Compat hiding (lex) -import Control.Applicative +import Control.Applicative ((<|>)) import Control.Monad (void, guard) - +import Control.Monad.Identity (Identity) import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum) -import Data.Functor.Identity +import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T @@ -101,17 +100,17 @@ data Token | Semi | At | Underscore - | LName String - | UName String - | Qualifier String - | Symbol String + | LName Text + | UName Text + | Qualifier Text + | Symbol Text | CharLiteral Char - | StringLiteral String + | StringLiteral Text | Number (Either Integer Double) - | HoleLit String + | HoleLit Text deriving (Show, Eq, Ord) -prettyPrintToken :: Token -> String +prettyPrintToken :: Token -> Text prettyPrintToken LParen = "(" prettyPrintToken RParen = ")" prettyPrintToken LBrace = "{" @@ -132,15 +131,15 @@ prettyPrintToken Comma = "," prettyPrintToken Semi = ";" prettyPrintToken At = "@" prettyPrintToken Underscore = "_" -prettyPrintToken (Indent n) = "indentation at level " ++ show n -prettyPrintToken (LName s) = show s -prettyPrintToken (UName s) = show s +prettyPrintToken (Indent n) = "indentation at level " <> T.pack (show n) +prettyPrintToken (LName s) = T.pack (show s) +prettyPrintToken (UName s) = T.pack (show s) prettyPrintToken (Qualifier _) = "qualifier" prettyPrintToken (Symbol s) = s -prettyPrintToken (CharLiteral c) = show c -prettyPrintToken (StringLiteral s) = show s -prettyPrintToken (Number n) = either show show n -prettyPrintToken (HoleLit name) = "?" ++ name +prettyPrintToken (CharLiteral c) = T.pack (show c) +prettyPrintToken (StringLiteral s) = T.pack (show s) +prettyPrintToken (Number n) = T.pack (either show show n) +prettyPrintToken (HoleLit name) = "?" <> name data PositionedToken = PositionedToken { -- | Start position of this token @@ -155,15 +154,12 @@ data PositionedToken = PositionedToken -- Parsec requires this instance for various token-level combinators instance Show PositionedToken where - show = prettyPrintToken . ptToken + show = T.unpack . prettyPrintToken . ptToken type Lexer u a = P.Parsec Text u a -lex :: FilePath -> String -> Either P.ParseError [PositionedToken] -lex fp = lex' fp . T.pack - -lex' :: FilePath -> Text -> Either P.ParseError [PositionedToken] -lex' f s = updatePositions <$> P.parse parseTokens f s +lex :: FilePath -> Text -> Either P.ParseError [PositionedToken] +lex f s = updatePositions <$> P.parse parseTokens f s updatePositions :: [PositionedToken] -> [PositionedToken] updatePositions [] = [] @@ -180,11 +176,11 @@ whitespace = P.skipMany (P.satisfy isSpace) parseComment :: Lexer u Comment parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace where - blockComment :: Lexer u String - blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}")) + blockComment :: Lexer u Text + blockComment = P.try $ P.string "{-" *> (T.pack <$> P.manyTill P.anyChar (P.try (P.string "-}"))) - lineComment :: Lexer u String - lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof)) + lineComment :: Lexer u Text + lineComment = P.try $ P.string "--" *> (T.pack <$> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof))) parsePositionedToken :: Lexer u PositionedToken parsePositionedToken = P.try $ do @@ -222,11 +218,11 @@ parseToken = P.choice , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore - , HoleLit <$> P.try (P.char '?' *> P.many1 identLetter) + , HoleLit <$> P.try (P.char '?' *> (T.pack <$> P.many1 identLetter)) , LName <$> parseLName , parseUName >>= \uName -> - (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') - <|> pure (UName uName) + guard (validModuleName uName) *> (Qualifier uName <$ P.char '.') + <|> pure (UName uName) , Symbol <$> parseSymbol , CharLiteral <$> parseCharLiteral , StringLiteral <$> parseStringLiteral @@ -234,14 +230,14 @@ parseToken = P.choice ] where - parseLName :: Lexer u String - parseLName = (:) <$> identStart <*> P.many identLetter + parseLName :: Lexer u Text + parseLName = T.cons <$> identStart <*> (T.pack <$> P.many identLetter) - parseUName :: Lexer u String - parseUName = (:) <$> P.upper <*> P.many identLetter + parseUName :: Lexer u Text + parseUName = T.cons <$> P.upper <*> (T.pack <$> P.many identLetter) - parseSymbol :: Lexer u String - parseSymbol = P.many1 symbolChar + parseSymbol :: Lexer u Text + parseSymbol = T.pack <$> P.many1 symbolChar identStart :: Lexer u Char identStart = P.lower <|> P.oneOf "_" @@ -255,21 +251,21 @@ parseToken = P.choice parseCharLiteral :: Lexer u Char parseCharLiteral = PT.charLiteral tokenParser - parseStringLiteral :: Lexer u String - parseStringLiteral = blockString <|> PT.stringLiteral tokenParser + parseStringLiteral :: Lexer u Text + parseStringLiteral = blockString <|> T.pack <$> PT.stringLiteral tokenParser where delimiter = P.try (P.string "\"\"\"") - blockString = delimiter >> P.manyTill P.anyChar delimiter + blockString = delimiter *> (T.pack <$> P.manyTill P.anyChar delimiter) parseNumber :: Lexer u (Either Integer Double) - parseNumber = (consumeLeadingZero >> P.parserZero) <|> + parseNumber = (consumeLeadingZero *> P.parserZero) <|> (Right <$> P.try (PT.float tokenParser) <|> Left <$> P.try (PT.natural tokenParser)) P. "number" where -- lookAhead doesn't consume any input if its parser succeeds -- if notFollowedBy fails though, the consumed '0' will break the choice chain - consumeLeadingZero = P.lookAhead (P.char '0' >> + consumeLeadingZero = P.lookAhead (P.char '0' *> (P.notFollowedBy P.digit P. "no leading zero in number literal")) -- | @@ -283,10 +279,10 @@ langDef = PT.LanguageDef , PT.commentEnd = "" , PT.commentLine = "" , PT.nestedComments = True - , PT.identStart = fail "Identifiers not supported" - , PT.identLetter = fail "Identifiers not supported" - , PT.opStart = fail "Operators not supported" - , PT.opLetter = fail "Operators not supported" + , PT.identStart = P.parserFail "Identifiers not supported" + , PT.identLetter = P.parserFail "Identifiers not supported" + , PT.opStart = P.parserFail "Operators not supported" + , PT.opLetter = P.parserFail "Operators not supported" , PT.caseSensitive = True } @@ -299,13 +295,13 @@ tokenParser = PT.makeTokenParser langDef type TokenParser a = P.Parsec [PositionedToken] ParseState a anyToken :: TokenParser PositionedToken -anyToken = P.token (prettyPrintToken . ptToken) ptSourcePos Just +anyToken = P.token (T.unpack . prettyPrintToken . ptToken) ptSourcePos Just token :: (Token -> Maybe a) -> TokenParser a -token f = P.token (prettyPrintToken . ptToken) ptSourcePos (f . ptToken) +token f = P.token (T.unpack . prettyPrintToken . ptToken) ptSourcePos (f . ptToken) match :: Token -> TokenParser () -match tok = token (\tok' -> if tok == tok' then Just () else Nothing) P. prettyPrintToken tok +match tok = token (\tok' -> if tok == tok' then Just () else Nothing) P. T.unpack (prettyPrintToken tok) lparen :: TokenParser () lparen = match LParen @@ -388,7 +384,7 @@ at = match At underscore :: TokenParser () underscore = match Underscore -holeLit :: TokenParser String +holeLit :: TokenParser Text holeLit = token go P. "hole literal" where go (HoleLit n) = Just n @@ -418,62 +414,62 @@ commaSep = flip P.sepBy comma commaSep1 :: TokenParser a -> TokenParser [a] commaSep1 = flip P.sepBy1 comma -lname :: TokenParser String +lname :: TokenParser Text lname = token go P. "identifier" where go (LName s) = Just s go _ = Nothing -lname' :: String -> TokenParser () +lname' :: Text -> TokenParser () lname' s = token go P. show s where go (LName s') | s == s' = Just () go _ = Nothing -qualifier :: TokenParser String +qualifier :: TokenParser Text qualifier = token go P. "qualifier" where go (Qualifier s) = Just s go _ = Nothing -reserved :: String -> TokenParser () +reserved :: Text -> TokenParser () reserved s = token go P. show s where go (LName s') | s == s' = Just () go (Symbol s') | s == s' = Just () go _ = Nothing -uname :: TokenParser String +uname :: TokenParser Text uname = token go P. "proper name" where go (UName s) | validUName s = Just s go _ = Nothing -uname' :: String -> TokenParser () +uname' :: Text -> TokenParser () uname' s = token go P. "proper name" where go (UName s') | s == s' = Just () go _ = Nothing -tyname :: TokenParser String +tyname :: TokenParser Text tyname = token go P. "type name" where go (UName s) = Just s go _ = Nothing -dconsname :: TokenParser String +dconsname :: TokenParser Text dconsname = token go P. "data constructor name" where go (UName s) = Just s go _ = Nothing -mname :: TokenParser String +mname :: TokenParser Text mname = token go P. "module name" where go (UName s) | validModuleName s = Just s go _ = Nothing -symbol :: TokenParser String +symbol :: TokenParser Text symbol = token go P. "symbol" where go (Symbol s) = Just s @@ -482,7 +478,7 @@ symbol = token go P. "symbol" go At = Just "@" go _ = Nothing -symbol' :: String -> TokenParser () +symbol' :: Text -> TokenParser () symbol' s = token go P. show s where go (Symbol s') | s == s' = Just () @@ -496,7 +492,7 @@ charLiteral = token go P. "char literal" go (CharLiteral c) = Just c go _ = Nothing -stringLiteral :: TokenParser String +stringLiteral :: TokenParser Text stringLiteral = token go P. "string literal" where go (StringLiteral s) = Just s @@ -514,22 +510,25 @@ natural = token go P. "natural" go (Number (Left n)) = Just n go _ = Nothing -identifier :: TokenParser String +identifier :: TokenParser Text identifier = token go P. "identifier" where go (LName s) | s `notElem` reservedPsNames = Just s go _ = Nothing -validModuleName :: String -> Bool -validModuleName s = '_' `notElem` s +validModuleName :: Text -> Bool +validModuleName s = '_' `notElemT` s + +validUName :: Text -> Bool +validUName s = '\'' `notElemT` s -validUName :: String -> Bool -validUName s = '\'' `notElem` s +notElemT :: Char -> Text -> Bool +notElemT c = not . T.any (== c) -- | -- A list of purescript reserved identifiers -- -reservedPsNames :: [String] +reservedPsNames :: [Text] reservedPsNames = [ "data" , "newtype" , "type" @@ -555,14 +554,14 @@ reservedPsNames = [ "data" , "where" ] -reservedTypeNames :: [String] +reservedTypeNames :: [Text] reservedTypeNames = [ "forall", "where" ] -- | -- The characters allowed for use in operators -- isSymbolChar :: Char -> Bool -isSymbolChar c = (c `elem` ":!#$%&*+./<=>?@\\^|-~") || (not (isAscii c) && isSymbol c) +isSymbolChar c = (c `elem` (":!#$%&*+./<=>?@\\^|-~" :: [Char])) || (not (isAscii c) && isSymbol c) -- | @@ -575,12 +574,13 @@ isUnquotedKeyHeadChar c = (c == '_') || isAlphaNum c -- The characters allowed in the tail of an unquoted record key -- isUnquotedKeyTailChar :: Char -> Bool -isUnquotedKeyTailChar c = (c `elem` "_'") || isAlphaNum c +isUnquotedKeyTailChar c = (c `elem` ("_'" :: [Char])) || isAlphaNum c -- | -- Strings allowed to be left unquoted in a record key -- -isUnquotedKey :: String -> Bool -isUnquotedKey [] = False -isUnquotedKey (hd : tl) = isUnquotedKeyHeadChar hd && - all isUnquotedKeyTailChar tl +isUnquotedKey :: Text -> Bool +isUnquotedKey t = case T.uncons t of + Nothing -> False + Just (hd, tl) -> isUnquotedKeyHeadChar hd && + T.all isUnquotedKeyTailChar tl diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 6bb1e14f19..d218e6a9a6 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -7,8 +7,10 @@ module Language.PureScript.Parser.Types import Prelude.Compat -import Control.Applicative import Control.Monad (when, unless) +import Control.Applicative ((<|>)) +import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.AST.SourcePos import Language.PureScript.Environment @@ -21,7 +23,7 @@ import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P parseFunction :: TokenParser Type -parseFunction = parens rarrow >> return tyFunction +parseFunction = parens rarrow *> return tyFunction parseObject :: TokenParser Type parseObject = braces $ TypeApp tyRecord <$> parseRow @@ -39,7 +41,7 @@ parseTypeWildcard = do parseTypeVariable :: TokenParser Type parseTypeVariable = do ident <- identifier - when (ident `elem` reservedTypeNames) $ P.unexpected ident + when (ident `elem` reservedTypeNames) $ P.unexpected (T.unpack ident) return $ TypeVar ident parseTypeConstructor :: TokenParser Type @@ -87,7 +89,7 @@ parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTabl , [ P.Infix (P.try (parseQualified parseOperator) >>= \ident -> return (BinaryNoParensType (TypeOp ident))) P.AssocRight ] - , [ P.Infix (rarrow >> return function) P.AssocRight ] + , [ P.Infix (rarrow *> return function) P.AssocRight ] ] postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind) ] @@ -116,7 +118,7 @@ noWildcards p = do when (containsWildcards ty) $ P.unexpected "type wildcard" return ty -parseNameAndType :: TokenParser t -> TokenParser (String, t) +parseNameAndType :: TokenParser t -> TokenParser (Text, t) parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p parseRowEnding :: TokenParser Type diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 2436a16d71..f5f0e2f8ae 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -10,20 +10,27 @@ import Prelude.Compat import Control.Monad.State (StateT, modify, get) import Data.List (elemIndices, intersperse) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.AST (SourcePos(..), SourceSpan(..)) import Language.PureScript.Parser.Lexer (reservedPsNames, isUnquotedKey) -import Text.PrettyPrint.Boxes +import Text.PrettyPrint.Boxes hiding ((<>)) +import qualified Text.PrettyPrint.Boxes as Box -- | -- Wrap a string in parentheses -- parens :: String -> String -parens s = '(':s ++ ")" +parens s = "(" <> s <> ")" + +parensT :: Text -> Text +parensT s = "(" <> s <> ")" parensPos :: (Emit gen) => gen -> gen -parensPos s = emit "(" `mappend` s `mappend` emit ")" +parensPos s = emit "(" <> s <> emit ")" -- | -- Generalize intercalate slightly for monoids @@ -32,15 +39,15 @@ intercalate :: Monoid m => m -> [m] -> m intercalate x xs = mconcat (intersperse x xs) class (Monoid gen) => Emit gen where - emit :: String -> gen + emit :: Text -> gen addMapping :: SourceSpan -> gen -data SMap = SMap String SourcePos SourcePos +data SMap = SMap Text SourcePos SourcePos -- | -- String with length and source-map entries -- -newtype StrPos = StrPos (SourcePos, String, [SMap]) +newtype StrPos = StrPos (SourcePos, Text, [SMap]) -- | -- Make a monoid where append consists of concatenating the string part, adding the lengths @@ -50,10 +57,10 @@ newtype StrPos = StrPos (SourcePos, String, [SMap]) instance Monoid StrPos where mempty = StrPos (SourcePos 0 0, "", []) - StrPos (a,b,c) `mappend` StrPos (a',b',c') = StrPos (a `addPos` a', b ++ b', c ++ (bumpPos a <$> c')) + StrPos (a,b,c) `mappend` StrPos (a',b',c') = StrPos (a `addPos` a', b <> b', c ++ (bumpPos a <$> c')) mconcat ms = - let s' = concatMap (\(StrPos(_, s, _)) -> s) ms + let s' = foldMap (\(StrPos(_, s, _)) -> s) ms (p, maps) = foldl plus (SourcePos 0 0, []) ms in StrPos (p, s', concat $ reverse maps) @@ -66,22 +73,23 @@ instance Emit StrPos where -- Augment a string with its length (rows/column) -- emit str = - let newlines = elemIndices '\n' str + -- TODO(Christoph): get rid of T.unpack + let newlines = elemIndices '\n' (T.unpack str) index = if null newlines then 0 else last newlines + 1 in - StrPos (SourcePos { sourcePosLine = length newlines, sourcePosColumn = length str - index }, str, []) + StrPos (SourcePos { sourcePosLine = length newlines, sourcePosColumn = T.length str - index }, str, []) -- | -- Add a new mapping entry for given source position with initially zero generated position -- addMapping SourceSpan { spanName = file, spanStart = startPos } = StrPos (zeroPos, mempty, [mapping]) where - mapping = SMap file startPos zeroPos + mapping = SMap (T.pack file) startPos zeroPos zeroPos = SourcePos 0 0 -newtype PlainString = PlainString String deriving Monoid +newtype PlainString = PlainString Text deriving Monoid -runPlainString :: PlainString -> String +runPlainString :: PlainString -> Text runPlainString (PlainString s) = s instance Emit PlainString where @@ -127,7 +135,7 @@ withIndent action = do currentIndent :: (Emit gen) => StateT PrinterState Maybe gen currentIndent = do current <- get - return $ emit $ replicate (indent current) ' ' + return $ emit $ T.replicate (indent current) " " -- | -- Print many lines @@ -141,19 +149,19 @@ prettyPrintMany f xs = do -- | -- Prints an object key, escaping reserved names. -- -prettyPrintObjectKey :: String -> String -prettyPrintObjectKey s | s `elem` reservedPsNames = show s +prettyPrintObjectKey :: Text -> Text +prettyPrintObjectKey s | s `elem` reservedPsNames = T.pack (show s) | isUnquotedKey s = s - | otherwise = show s + | otherwise = T.pack (show s) -- | Place a box before another, vertically when the first box takes up multiple lines. before :: Box -> Box -> Box before b1 b2 | rows b1 > 1 = b1 // b2 - | otherwise = b1 <> b2 + | otherwise = b1 Box.<> b2 beforeWithSpace :: Box -> Box -> Box -beforeWithSpace b1 = before (b1 <> text " ") +beforeWithSpace b1 = before (b1 Box.<> text " ") -- | Place a Box on the bottom right of another endWith :: Box -> Box -> Box -endWith l r = l <> vcat top [emptyBox (rows l - 1) (cols r), r] +endWith l r = l Box.<> vcat top [emptyBox (rows l - 1) (cols r), r] diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 2b089ea8c5..3280b9cd8a 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -9,12 +9,15 @@ module Language.PureScript.Pretty.JS import Prelude.Compat import Control.Arrow ((<+>)) -import Control.Monad.State hiding (sequence) +import Control.Monad (forM, mzero) +import Control.Monad.State (StateT, evalStateT) import Control.PatternArrows import qualified Control.Arrow as A import Data.Maybe (fromMaybe) -import Data.Monoid +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.CodeGen.JS.AST @@ -25,6 +28,8 @@ import Language.PureScript.Pretty.Common import Numeric +-- TODO (Christoph): Get rid of T.unpack / pack + literals :: (Emit gen) => Pattern PrinterState JS gen literals = mkPattern' match' where @@ -32,7 +37,7 @@ literals = mkPattern' match' match' js = (addMapping' (getSourceSpan js) <>) <$> match js match :: (Emit gen) => JS -> StateT PrinterState Maybe gen - match (JSNumericLiteral _ n) = return $ emit $ either show show n + match (JSNumericLiteral _ n) = return $ emit $ T.pack $ either show show n match (JSStringLiteral _ s) = return $ string s match (JSBooleanLiteral _ True) = return $ emit "true" match (JSBooleanLiteral _ False) = return $ emit "false" @@ -53,8 +58,8 @@ literals = mkPattern' match' , return $ emit "}" ] where - objectPropertyToString :: (Emit gen) => String -> gen - objectPropertyToString s | identNeedsEscaping s = emit $ show s + objectPropertyToString :: (Emit gen) => Text -> gen + objectPropertyToString s | identNeedsEscaping s = emit $ T.pack $ show s | otherwise = emit s match (JSBlock _ sts) = mconcat <$> sequence [ return $ emit "{\n" @@ -65,7 +70,7 @@ literals = mkPattern' match' ] match (JSVar _ ident) = return $ emit ident match (JSVariableIntroduction _ ident value) = mconcat <$> sequence - [ return $ emit $ "var " ++ ident + [ return $ emit $ "var " <> ident , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value ] match (JSAssignment _ target value) = mconcat <$> sequence @@ -80,15 +85,15 @@ literals = mkPattern' match' , prettyPrintJS' sts ] match (JSFor _ ident start end sts) = mconcat <$> sequence - [ return $ emit $ "for (var " ++ ident ++ " = " + [ return $ emit $ "for (var " <> ident <> " = " , prettyPrintJS' start - , return $ emit $ "; " ++ ident ++ " < " + , return $ emit $ "; " <> ident <> " < " , prettyPrintJS' end - , return $ emit $ "; " ++ ident ++ "++) " + , return $ emit $ "; " <> ident <> "++) " , prettyPrintJS' sts ] match (JSForIn _ ident obj sts) = mconcat <$> sequence - [ return $ emit $ "for (var " ++ ident ++ " in " + [ return $ emit $ "for (var " <> ident <> " in " , prettyPrintJS' obj , return $ emit ") " , prettyPrintJS' sts @@ -108,10 +113,10 @@ literals = mkPattern' match' [ return $ emit "throw " , prettyPrintJS' value ] - match (JSBreak _ lbl) = return $ emit $ "break " ++ lbl - match (JSContinue _ lbl) = return $ emit $ "continue " ++ lbl + match (JSBreak _ lbl) = return $ emit $ "break " <> lbl + match (JSContinue _ lbl) = return $ emit $ "continue " <> lbl match (JSLabel _ lbl js) = mconcat <$> sequence - [ return $ emit $ lbl ++ ": " + [ return $ emit $ lbl <> ": " , prettyPrintJS' js ] match (JSComment _ com js) = fmap mconcat $ sequence $ @@ -126,27 +131,29 @@ literals = mkPattern' match' , prettyPrintJS' js ] where - commentLines :: Comment -> [String] + commentLines :: Comment -> [Text] commentLines (LineComment s) = [s] - commentLines (BlockComment s) = lines s + commentLines (BlockComment s) = T.lines s - asLine :: (Emit gen) => String -> StateT PrinterState Maybe gen + asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen asLine s = do i <- currentIndent return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n" - removeComments :: String -> String - removeComments ('*' : '/' : s) = removeComments s - removeComments (c : s) = c : removeComments s - - removeComments [] = [] + removeComments :: Text -> Text + removeComments t = + case T.stripPrefix "*/" t of + Just rest -> removeComments rest + Nothing -> case T.uncons t of + Just (x, xs) -> x `T.cons` removeComments xs + Nothing -> "" match (JSRaw _ js) = return $ emit js match _ = mzero -string :: (Emit gen) => String -> gen -string s = emit $ '"' : concatMap encodeChar s ++ "\"" +string :: (Emit gen) => Text -> gen +string s = emit $ "\"" <> T.concatMap encodeChar s <> "\"" where - encodeChar :: Char -> String + encodeChar :: Char -> Text encodeChar '\b' = "\\b" encodeChar '\t' = "\\t" encodeChar '\n' = "\\n" @@ -155,16 +162,18 @@ string s = emit $ '"' : concatMap encodeChar s ++ "\"" encodeChar '\r' = "\\r" encodeChar '"' = "\\\"" encodeChar '\\' = "\\\\" - encodeChar c | fromEnum c > 0xFFFF = "\\u" ++ showHex highSurrogate ("\\u" ++ showHex lowSurrogate "") + encodeChar c | fromEnum c > 0xFFFF = "\\u" <> showHex' highSurrogate ("\\u" ++ showHex lowSurrogate "") where (h, l) = divMod (fromEnum c - 0x10000) 0x400 highSurrogate = h + 0xD800 lowSurrogate = l + 0xDC00 - encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) "" - encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) "" - encodeChar c | fromEnum c < 0x10 = "\\x0" ++ showHex (fromEnum c) "" - encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) "" - encodeChar c = [c] + encodeChar c | fromEnum c > 0xFFF = "\\u" <> showHex' (fromEnum c) "" + encodeChar c | fromEnum c > 0xFF = "\\u0" <> showHex' (fromEnum c) "" + encodeChar c | fromEnum c < 0x10 = "\\x0" <> showHex' (fromEnum c) "" + encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" <> showHex' (fromEnum c) "" + encodeChar c = T.singleton c + + showHex' a b = T.pack (showHex a b) conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS) conditional = mkPattern match @@ -185,7 +194,7 @@ indexer = mkPattern' match match _ = mzero -lam :: Pattern PrinterState JS ((Maybe String, [String], Maybe SourceSpan), JS) +lam :: Pattern PrinterState JS ((Maybe Text, [Text], Maybe SourceSpan), JS) lam = mkPattern match where match (JSFunction ss name args ret) = Just ((name, args, ss), ret) @@ -211,7 +220,7 @@ instanceOf = mkPattern match match (JSInstanceOf _ val ty) = Just (val, ty) match _ = Nothing -unary' :: (Emit gen) => UnaryOperator -> (JS -> String) -> Operator PrinterState JS gen +unary' :: (Emit gen) => UnaryOperator -> (JS -> Text) -> Operator PrinterState JS gen unary' op mkStr = Wrap match (<>) where match :: (Emit gen) => Pattern PrinterState JS (gen, JS) @@ -220,7 +229,7 @@ unary' op mkStr = Wrap match (<>) match' (JSUnary _ op' val) | op' == op = Just (emit $ mkStr val, val) match' _ = Nothing -unary :: (Emit gen) => UnaryOperator -> String -> Operator PrinterState JS gen +unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState JS gen unary op str = unary' op (const str) negateOperator :: (Emit gen) => Operator PrinterState JS gen @@ -229,8 +238,8 @@ negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-") isNegate (JSUnary _ Negate _) = True isNegate _ = False -binary :: (Emit gen) => BinaryOperator -> String -> Operator PrinterState JS gen -binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " ++ str ++ " ") <> v2) +binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState JS gen +binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2) where match :: Pattern PrinterState JS (JS, JS) match = mkPattern match' @@ -253,12 +262,12 @@ prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalState -- | -- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level -- -prettyPrintJSWithSourceMaps :: [JS] -> (String, [SMap]) +prettyPrintJSWithSourceMaps :: [JS] -> (Text, [SMap]) prettyPrintJSWithSourceMaps js = let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js in (s, mp) -prettyPrintJS :: [JS] -> String +prettyPrintJS :: [JS] -> Text prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements -- | -- Generate an indented, pretty-printed string representing a Javascript expression @@ -276,8 +285,8 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue , [ unary JSNew "new " ] , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <> emit ("function " - ++ fromMaybe "" name - ++ "(" ++ intercalate ", " args ++ ") ") + <> fromMaybe "" name + <> "(" <> intercalate ", " args <> ") ") <> ret ] , [ Wrap typeOf $ \_ s -> emit "typeof " <> s ] , [ unary Not "!" diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs index fdcbb38a31..364ace9e47 100644 --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -11,6 +11,8 @@ import Control.Arrow (ArrowPlus(..)) import Control.PatternArrows as PA import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.Text (Text) import Language.PureScript.Crash import Language.PureScript.Kinds @@ -38,9 +40,11 @@ funKind = mkPattern match match _ = Nothing -- | Generate a pretty-printed string representing a Kind -prettyPrintKind :: Kind -> String +prettyPrintKind :: Kind -> Text prettyPrintKind - = fromMaybe (internalError "Incomplete pattern") + -- TODO(Christoph): get rid of T.pack + = T.pack + . fromMaybe (internalError "Incomplete pattern") . PA.pattern matchKind () where matchKind :: Pattern () Kind String diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 1233dc2408..3486077fa5 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -18,6 +18,7 @@ import Control.Arrow ((<+>)) import Control.PatternArrows as PA import Data.Maybe (fromMaybe) +import qualified Data.Text as T import Language.PureScript.Crash import Language.PureScript.Environment @@ -29,6 +30,8 @@ import Language.PureScript.Types import Text.PrettyPrint.Boxes hiding ((<+>)) +-- TODO(Christoph): get rid of T.unpack s + constraintsAsBox :: [Constraint] -> Box -> Box constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty) constraintsAsBox xs ty = vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (text ") => " <> ty) @@ -43,7 +46,7 @@ prettyPrintRowWith :: Char -> Char -> Type -> Box prettyPrintRowWith open close = uncurry listToBox . toList [] where nameAndTypeToPs :: Char -> String -> Type -> Box - nameAndTypeToPs start name ty = text (start : ' ' : prettyPrintObjectKey name ++ " :: ") <> typeAsBox ty + nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintObjectKey (T.pack name)) ++ " :: ") <> typeAsBox ty tailToPs :: Type -> Box tailToPs REmpty = nullBox @@ -57,7 +60,7 @@ prettyPrintRowWith open close = uncurry listToBox . toList [] [ tailToPs rest, text [close] ] toList :: [(String, Type)] -> Type -> ([(String, Type)], Type) - toList tys (RCons name ty row) = toList ((name, ty):tys) row + toList tys (RCons name ty row) = toList ((T.unpack name, ty):tys) row toList tys r = (reverse tys, r) prettyPrintRow :: Type -> String @@ -112,21 +115,21 @@ matchTypeAtom suggesting = typeLiterals :: Pattern () Type Box typeLiterals = mkPattern match where match TypeWildcard{} = Just $ text "_" - match (TypeVar var) = Just $ text var + match (TypeVar var) = Just $ text $ T.unpack var match (TypeLevelString s) = Just . text $ show s match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row - match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor + match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor match (TUnknown u) | suggesting = Just $ text "_" | otherwise = Just $ text $ 't' : show u match (Skolem name s _ _) - | suggesting = Just $ text name - | otherwise = Just $ text $ name ++ show s + | suggesting = Just $ text $ T.unpack name + | otherwise = Just $ text $ T.unpack name ++ show s match REmpty = Just $ text "()" match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row match (BinaryNoParensType op l r) = Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r - match (TypeOp op) = Just $ text $ showQualified runOpName op + match (TypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op match _ = Nothing matchType :: Bool -> Pattern () Type Box @@ -137,7 +140,7 @@ matchType = buildPrettyPrinter operators . matchTypeAtom where , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text "-> " <> ret) ] , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ] , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text ("forall " ++ unwords idents ++ ".")) ty ] - , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ prettyPrintKind k)) ] + , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ T.unpack (prettyPrintKind k))) ] , [ Wrap explicitParens $ \_ ty -> ty ] ] @@ -151,7 +154,7 @@ matchType = buildPrettyPrinter operators . matchTypeAtom where forall_ :: Pattern () Type ([String], Type) forall_ = mkPattern match where - match (PrettyPrintForAll idents ty) = Just (idents, ty) + match (PrettyPrintForAll idents ty) = Just (map T.unpack idents, ty) match _ = Nothing typeAtomAsBox :: Type -> Box diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index bd36555911..72b17343fd 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -11,6 +11,11 @@ import Prelude.Compat import Control.Arrow (second) +import qualified Data.Monoid as Monoid ((<>)) + +import qualified Data.Text as T +import Data.Text (Text) + import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Names @@ -20,6 +25,11 @@ import Language.PureScript.Types (Constraint(..)) import Text.PrettyPrint.Boxes +-- TODO(Christoph): remove T.unpack s + +textT :: Text -> Box +textT = text . T.unpack + -- | Render an aligned list of items separated with commas list :: Char -> Char -> (a -> Box) -> [a] -> Box list open close _ [] = text [open, close] @@ -30,11 +40,11 @@ list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ cl ellipsis :: Box ellipsis = text "..." -prettyPrintObject :: Int -> [(String, Maybe Expr)] -> Box +prettyPrintObject :: Int -> [(Text, Maybe Expr)] -> Box prettyPrintObject d = list '{' '}' prettyPrintObjectProperty where - prettyPrintObjectProperty :: (String, Maybe Expr) -> Box - prettyPrintObjectProperty (key, value) = text (prettyPrintObjectKey key ++ ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value + prettyPrintObjectProperty :: (Text, Maybe Expr) -> Box + prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value -- | Pretty-print an expression prettyPrintValue :: Int -> Expr -> Box @@ -44,13 +54,13 @@ prettyPrintValue d (IfThenElse cond th el) = // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th , text "else " <> prettyPrintValueAtom (d - 1) el ]) -prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ prettyPrintObjectKey prop) -prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps +prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> textT ("." Monoid.<> prettyPrintObjectKey prop) +prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> textT (key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg -prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) -prettyPrintValue d (Abs (Right arg) val) = text ('\\' : prettyPrintBinder arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) +prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) +prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) = - text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom (d - 1) ps + text (T.unpack (runProperName (disqualify className)) ++ " ") <> prettyPrintValueAtom (d - 1) ps prettyPrintValue d (Case values binders) = (text "case " <> foldl1 beforeWithSpace (map (prettyPrintValueAtom (d - 1)) values) <> text " of") // moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders)) @@ -60,14 +70,14 @@ prettyPrintValue d (Let ds val) = (text "in " <> prettyPrintValue (d - 1) val) prettyPrintValue d (Do els) = text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) -prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys -prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) +prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map typeAtomAsBox tys +prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name)) prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = - text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">" + text "#dict-accessor " <> text (T.unpack (runProperName (disqualify className))) <> text "." <> text (T.unpack (showIdent ident)) <> text ">" prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val prettyPrintValue d (Literal l) = prettyPrintLiteralValue d l -prettyPrintValue _ (Hole name) = text "?" <> text name +prettyPrintValue _ (Hole name) = text "?" <> textT name prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr @@ -80,12 +90,12 @@ prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr prettyPrintValueAtom :: Int -> Expr -> Box prettyPrintValueAtom d (Literal l) = prettyPrintLiteralValue d l prettyPrintValueAtom _ AnonymousArgument = text "_" -prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name) -prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident) +prettyPrintValueAtom _ (Constructor name) = text $ T.unpack $ runProperName (disqualify name) +prettyPrintValueAtom _ (Var ident) = text $ T.unpack $ showIdent (disqualify ident) prettyPrintValueAtom d (BinaryNoParens op lhs rhs) = prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs where - printOp (Op (Qualified _ name)) = text (runOpName name) + printOp (Op (Qualified _ name)) = text $ T.unpack $ runOpName name printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`" prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val @@ -105,9 +115,9 @@ prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ secon prettyPrintDeclaration :: Int -> Declaration -> Box prettyPrintDeclaration d _ | d < 0 = ellipsis prettyPrintDeclaration _ (TypeDeclaration ident ty) = - text (showIdent ident ++ " :: ") <> typeAsBox ty + text (T.unpack (showIdent ident) ++ " :: ") <> typeAsBox ty prettyPrintDeclaration d (ValueDeclaration ident _ [] (Right val)) = - text (showIdent ident ++ " = ") <> prettyPrintValue (d - 1) val + text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val prettyPrintDeclaration d (BindingGroupDeclaration ds) = vsep 1 left (map (prettyPrintDeclaration (d - 1) . toDecl) ds) where @@ -118,7 +128,7 @@ prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDecla prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box prettyPrintCaseAlternative d _ | d < 0 = ellipsis prettyPrintCaseAlternative d (CaseAlternative binders result) = - text (unwords (map prettyPrintBinderAtom binders)) <> prettyPrintResult result + text (T.unpack (T.unwords (map prettyPrintBinderAtom binders))) <> prettyPrintResult result where prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box prettyPrintResult (Left gs) = @@ -138,50 +148,50 @@ prettyPrintDoNotationElement d _ | d < 0 = ellipsis prettyPrintDoNotationElement d (DoNotationValue val) = prettyPrintValue d val prettyPrintDoNotationElement d (DoNotationBind binder val) = - text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue d val + textT (prettyPrintBinder binder Monoid.<> " <- ") <> prettyPrintValue d val prettyPrintDoNotationElement d (DoNotationLet ds) = text "let" // moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el -prettyPrintBinderAtom :: Binder -> String +prettyPrintBinderAtom :: Binder -> Text prettyPrintBinderAtom NullBinder = "_" prettyPrintBinderAtom (LiteralBinder l) = prettyPrintLiteralBinder l prettyPrintBinderAtom (VarBinder ident) = showIdent ident prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor) -prettyPrintBinderAtom b@ConstructorBinder{} = parens (prettyPrintBinder b) -prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder +prettyPrintBinderAtom b@ConstructorBinder{} = parensT (prettyPrintBinder b) +prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident Monoid.<> "@" Monoid.<> prettyPrintBinder binder prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder prettyPrintBinderAtom (OpBinder op) = runOpName (disqualify op) prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) = - prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2 -prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b) + prettyPrintBinderAtom b1 Monoid.<> " " Monoid.<> prettyPrintBinderAtom op Monoid.<> " " Monoid.<> prettyPrintBinderAtom b2 +prettyPrintBinderAtom (ParensInBinder b) = parensT (prettyPrintBinder b) -prettyPrintLiteralBinder :: Literal Binder -> String -prettyPrintLiteralBinder (StringLiteral str) = show str -prettyPrintLiteralBinder (CharLiteral c) = show c -prettyPrintLiteralBinder (NumericLiteral num) = either show show num +prettyPrintLiteralBinder :: Literal Binder -> Text +prettyPrintLiteralBinder (StringLiteral str) = T.pack (show str) +prettyPrintLiteralBinder (CharLiteral c) = T.pack (show c) +prettyPrintLiteralBinder (NumericLiteral num) = either (T.pack . show) (T.pack . show) num prettyPrintLiteralBinder (BooleanLiteral True) = "true" prettyPrintLiteralBinder (BooleanLiteral False) = "false" prettyPrintLiteralBinder (ObjectLiteral bs) = "{ " - ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs) - ++ " }" + Monoid.<> T.intercalate ", " (map prettyPrintObjectPropertyBinder bs) + Monoid.<> " }" where - prettyPrintObjectPropertyBinder :: (String, Binder) -> String - prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder + prettyPrintObjectPropertyBinder :: (Text, Binder) -> Text + prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key Monoid.<> ": " Monoid.<> prettyPrintBinder binder prettyPrintLiteralBinder (ArrayLiteral bs) = "[ " - ++ intercalate ", " (map prettyPrintBinder bs) - ++ " ]" + Monoid.<> T.intercalate ", " (map prettyPrintBinder bs) + Monoid.<> " ]" -- | -- Generate a pretty-printed string representing a Binder -- -prettyPrintBinder :: Binder -> String +prettyPrintBinder :: Binder -> Text prettyPrintBinder (ConstructorBinder ctor []) = runProperName (disqualify ctor) -prettyPrintBinder (ConstructorBinder ctor args) = runProperName (disqualify ctor) ++ " " ++ unwords (map prettyPrintBinderAtom args) +prettyPrintBinder (ConstructorBinder ctor args) = (runProperName (disqualify ctor)) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args) prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder prettyPrintBinder (TypedBinder _ binder) = prettyPrintBinder binder prettyPrintBinder b = prettyPrintBinderAtom b diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index 7dfc873d05..cb28d1eb29 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -10,7 +10,9 @@ import Control.Monad.State import Data.List (find) import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as M +import Data.Monoid ((<>)) import qualified Data.Set as S +import qualified Data.Text as T import Language.PureScript.CoreFn import Language.PureScript.Names @@ -80,7 +82,7 @@ updateScope ident = getNewName usedNames name = fromJust $ find (`S.notMember` usedNames) - [ Ident (runIdent name ++ show (i :: Int)) | i <- [1..] ] + [ Ident (runIdent name <> T.pack (show (i :: Int))) | i <- [1..] ] -- | -- Finds the new name to use for an ident. @@ -91,7 +93,7 @@ lookupIdent name = do name' <- gets $ M.lookup name . rsBoundNames case name' of Just name'' -> return name'' - Nothing -> error $ "Rename scope is missing ident '" ++ showIdent name ++ "'" + Nothing -> error $ "Rename scope is missing ident '" ++ T.unpack (showIdent name) ++ "'" -- | -- Finds idents introduced by declarations. diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index d6d36002fa..b92782a391 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -11,6 +11,7 @@ import Control.Monad.Supply.Class import Data.List (partition) import Data.Maybe (catMaybes) +import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Errors @@ -61,7 +62,7 @@ desugarDecl other = fn other return $ foldr (Abs . Left) if_ (catMaybes [u', t', f']) desugarExpr e = return e - wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Expr)] -> m Expr + wrapLambda :: ([(Text, Expr)] -> Expr) -> [(Text, Expr)] -> m Expr wrapLambda mkVal ps = let (args, props) = partition (isAnonymousArgument . snd) ps in if null args @@ -74,7 +75,7 @@ desugarDecl other = fn other stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e stripPositionInfo e = e - peelAnonAccessorChain :: Expr -> Maybe [String] + peelAnonAccessorChain :: Expr -> Maybe [Text] peelAnonAccessorChain (Accessor p e) = (p :) <$> peelAnonAccessorChain e peelAnonAccessorChain (PositionedValue _ _ e) = peelAnonAccessorChain e peelAnonAccessorChain AnonymousArgument = Just [] @@ -85,7 +86,7 @@ desugarDecl other = fn other isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e isAnonymousArgument _ = False - mkProp :: (String, Expr) -> m (Maybe Ident, (String, Expr)) + mkProp :: (Text, Expr) -> m (Maybe Ident, (Text, Expr)) mkProp (name, e) = do arg <- freshIfAnon e return (arg, (name, maybe e argToExpr arg)) diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 4d91324d7f..1b79a9f214 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -27,8 +27,10 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State import Data.List ((\\), find, sortBy) import Data.Maybe (catMaybes, mapMaybe, isJust) - import qualified Data.Map as M +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData @@ -231,7 +233,7 @@ memberToNameAndType _ = internalError "Invalid declaration in type class definit typeClassDictionaryDeclaration :: ProperName 'ClassName - -> [(String, Maybe Kind)] + -> [(Text, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration @@ -247,7 +249,7 @@ typeClassDictionaryDeclaration name args implies members = typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName 'ClassName - -> [(String, Maybe Kind)] + -> [(Text, Maybe Kind)] -> Declaration -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) = @@ -323,14 +325,14 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = return (PositionedValue pos com val) memberToValue _ _ = internalError "Invalid declaration in type instance definition" -typeClassMemberName :: Declaration -> String +typeClassMemberName :: Declaration -> Text typeClassMemberName (TypeDeclaration ident _) = runIdent ident typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration in type class definition" -superClassDictionaryNames :: [Constraint] -> [String] +superClassDictionaryNames :: [Constraint] -> [Text] superClassDictionaryNames supers = - [ C.__superclass_ ++ showQualified runProperName pn ++ "_" ++ show (index :: Integer) + [ C.__superclass_ <> showQualified runProperName pn <> "_" <> T.pack (show (index :: Integer)) | (index, Constraint pn _ _) <- zip [0..] supers ] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 95dab223e8..d3b7c607c3 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -16,6 +16,7 @@ import Control.Monad.Supply.Class (MonadSupply) import Data.List (foldl', find, sortBy, unzip5) import Data.Maybe (fromMaybe) import Data.Ord (comparing) +import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Crash @@ -118,7 +119,7 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do takeReverse :: Int -> [a] -> [a] takeReverse n = take n . reverse - stripRight :: [(String, Maybe kind)] -> Type -> Maybe Type + stripRight :: [(Text, Maybe kind)] -> Type -> Maybe Type stripRight [] ty = Just ty stripRight ((arg, _) : args) (TypeApp t (TypeVar arg')) | arg == arg' = stripRight args t @@ -285,14 +286,14 @@ deriveGeneric mn ds tyConNm dargs = do (App e unitVal) fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e unitVal) - mkRecCase :: [(String, Type)] -> CaseAlternative + mkRecCase :: [(Text, Type)] -> CaseAlternative mkRecCase rs = CaseAlternative [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . Ident . fst) rs)) ] ] . Right $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs) - mkRecFun :: [(String, Type)] -> Expr + mkRecFun :: [(Text, Type)] -> Expr mkRecFun xs = mkJust $ foldr (lam . Ident . fst) recLiteral xs where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d @@ -576,13 +577,13 @@ deriveOrd mn ds tyConNm = do where catchAll = CaseAlternative [NullBinder, NullBinder] (Right (orderingCtor "EQ")) - orderingName :: String -> Qualified (ProperName a) + orderingName :: Text -> Qualified (ProperName a) orderingName = Qualified (Just (ModuleName [ProperName "Data", ProperName "Ordering"])) . ProperName - orderingCtor :: String -> Expr + orderingCtor :: Text -> Expr orderingCtor = Constructor . orderingName - orderingBinder :: String -> Binder + orderingBinder :: Text -> Binder orderingBinder name = ConstructorBinder (orderingName name) [] ordCompare :: Expr -> Expr -> Expr @@ -700,7 +701,7 @@ objectType :: Type -> Maybe Type objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec objectType _ = Nothing -decomposeRec :: Type -> [(String, Type)] +decomposeRec :: Type -> [(Text, Type)] decomposeRec = sortBy (comparing fst) . go where go (RCons str typ typs) = (str, typ) : decomposeRec typs go _ = [] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index e8a0759361..fafe4626bc 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -22,6 +22,9 @@ import Data.Foldable (for_, traverse_) import Data.List (nub, nubBy, (\\), sort, group) import Data.Maybe import qualified Data.Map as M +import Data.Monoid ((<>)) +import qualified Data.Text as T +import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Crash @@ -43,7 +46,7 @@ addDataType => ModuleName -> DataDeclType -> ProperName 'TypeName - -> [(String, Maybe Kind)] + -> [(Text, Maybe Kind)] -> [(ProperName 'ConstructorName, [Type])] -> Kind -> m () @@ -59,7 +62,7 @@ addDataConstructor => ModuleName -> DataDeclType -> ProperName 'TypeName - -> [String] + -> [Text] -> ProperName 'ConstructorName -> [Type] -> m () @@ -69,14 +72,14 @@ addDataConstructor moduleName dtype name args dctor tys = do let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args) let dctorTy = foldr function retTy tys let polyType = mkForAll args dctorTy - let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]] + let fields = [Ident ("value" <> T.pack (show n)) | n <- [0..(length tys - 1)]] putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } addTypeSynonym :: (MonadState CheckState m, MonadError MultipleErrors m) => ModuleName -> ProperName 'TypeName - -> [(String, Maybe Kind)] + -> [(Text, Maybe Kind)] -> Type -> Kind -> m () @@ -112,7 +115,7 @@ addTypeClass :: (MonadState CheckState m) => ModuleName -> ProperName 'ClassName - -> [(String, Maybe Kind)] + -> [(Text, Maybe Kind)] -> [Constraint] -> [FunctionalDependency] -> [Declaration] @@ -143,12 +146,12 @@ addTypeClassDictionaries mn entries = checkDuplicateTypeArguments :: (MonadState CheckState m, MonadError MultipleErrors m) - => [String] + => [Text] -> m () checkDuplicateTypeArguments args = for_ firstDup $ \dup -> throwError . errorMessage $ DuplicateTypeArgument dup where - firstDup :: Maybe String + firstDup :: Maybe Text firstDup = listToMaybe $ args \\ nub args checkTypeClassInstance @@ -325,7 +328,7 @@ typeCheckAll moduleName _ = traverse go -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, -- extracted from the kind of the type constructor itself. -- - withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)] + withKinds :: [(Text, Maybe Kind)] -> Kind -> [(Text, Maybe Kind)] withKinds [] _ = [] withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2 diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index a5177dae2f..a857cdf723 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -25,6 +25,8 @@ import Data.List (minimumBy, nub) import Data.Maybe (fromMaybe, maybeToList, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.Text as T +import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Crash @@ -41,7 +43,7 @@ import qualified Language.PureScript.Constants as C data Evidence = NamedInstance (Qualified Ident) -- ^ An existing named instance - | IsSymbolInstance String + | IsSymbolInstance Text -- ^ Computed instance of the IsSymbol type class for a given Symbol literal deriving (Eq) @@ -62,7 +64,7 @@ type InstanceContext = M.Map (Maybe ModuleName) -- -- Note: we store many types per type variable name. For any name, all types -- should unify if we are going to commit to an instance. -type Matching a = M.Map String a +type Matching a = M.Map Text a combineContexts :: InstanceContext -> InstanceContext -> InstanceContext combineContexts = M.unionWith (M.unionWith M.union) @@ -202,7 +204,7 @@ entails SolverOptions{..} constraint context hints = return match Unsolved unsolved -> do -- Generate a fresh name for the unsolved constraint's new dictionary - ident <- freshIdent ("dict" ++ runProperName (disqualify (constraintClass unsolved))) + ident <- freshIdent ("dict" <> runProperName (disqualify (constraintClass unsolved))) let qident = Qualified Nothing ident -- Store the new dictionary in the InstanceContext so that we can solve this goal in -- future. @@ -296,7 +298,7 @@ entails SolverOptions{..} constraint context hints = -- Turn a DictionaryValue into a Expr subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr subclassDictionaryValue dict superclassName index = - App (Accessor (C.__superclass_ ++ showQualified runProperName superclassName ++ "_" ++ show index) + App (Accessor (C.__superclass_ <> showQualified runProperName superclassName <> "_" <> T.pack (show index)) dict) valUndefined @@ -362,7 +364,7 @@ matches deps TypeClassDictionaryInScope{..} tys = do sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] - go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> (Bool, Matching [Type]) + go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> (Bool, Matching [Type]) go [] REmpty [] REmpty = (True, M.empty) go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = (True, M.empty) go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = (True, M.empty) @@ -400,7 +402,7 @@ matches deps TypeClassDictionaryInScope{..} tys = do sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2' where - go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool + go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> Bool go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2 go [] REmpty [] REmpty = True @@ -430,7 +432,7 @@ newDictionaries path name (Constraint className instanceTy _) = do ) typeClassSuperclasses [0..] return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts) where - instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type] + instantiateSuperclass :: [Text] -> [Type] -> [Type] -> [Type] instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs mkContext :: [NamedDict] -> InstanceContext diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 81388379a7..fedd623916 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -18,6 +18,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State import qualified Data.Map as M +import Data.Text (Text) import Language.PureScript.Crash import Language.PureScript.Environment @@ -104,7 +105,7 @@ kindOf ty = fst <$> kindOfWithScopedVars ty kindOfWithScopedVars :: (MonadError MultipleErrors m, MonadState CheckState m) => Type -> - m (Kind, [(String, Kind)]) + m (Kind, [(Text, Kind)]) kindOfWithScopedVars ty = withErrorMessageHint (ErrorCheckingKind ty) $ fmap tidyUp . withFreshSubstitution . captureSubstitution $ infer ty @@ -119,7 +120,7 @@ kindsOf => Bool -> ModuleName -> ProperName 'TypeName - -> [(String, Maybe Kind)] + -> [(Text, Maybe Kind)] -> [Type] -> m Kind kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do @@ -134,7 +135,7 @@ kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . c freshKindVar :: (MonadError MultipleErrors m, MonadState CheckState m) - => (String, Maybe Kind) + => (Text, Maybe Kind) -> Kind -> m (ProperName 'TypeName, Kind) freshKindVar (arg, Nothing) kind = return (ProperName arg, kind) @@ -146,8 +147,8 @@ freshKindVar (arg, Just kind') kind = do kindsOfAll :: (MonadError MultipleErrors m, MonadState CheckState m) => ModuleName - -> [(ProperName 'TypeName, [(String, Maybe Kind)], Type)] - -> [(ProperName 'TypeName, [(String, Maybe Kind)], [Type])] + -> [(ProperName 'TypeName, [(Text, Maybe Kind)], Type)] + -> [(ProperName 'TypeName, [(Text, Maybe Kind)], [Type])] -> m ([Kind], [Kind]) kindsOfAll moduleName syns tys = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do synVars <- replicateM (length syns) freshKind @@ -198,14 +199,14 @@ starIfUnknown k = k infer :: (MonadError MultipleErrors m, MonadState CheckState m) => Type - -> m (Kind, [(String, Kind)]) + -> m (Kind, [(Text, Kind)]) infer ty = withErrorMessageHint (ErrorCheckingKind ty) $ infer' ty infer' :: forall m . (MonadError MultipleErrors m, MonadState CheckState m) => Type - -> m (Kind, [(String, Kind)]) + -> m (Kind, [(Text, Kind)]) infer' (ForAll ident ty _) = do k1 <- freshKind Just moduleName <- checkCurrentModule <$> get diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 7f779e87e0..909af189a3 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -15,6 +15,7 @@ import Control.Monad.Writer.Class (MonadWriter(..), censor) import Data.Maybe import qualified Data.Map as M +import Data.Text (Text) import Language.PureScript.Environment import Language.PureScript.Errors @@ -93,7 +94,7 @@ bindTypes newNames action = do withScopedTypeVars :: (MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName - -> [(String, Kind)] + -> [(Text, Kind)] -> m a -> m a withScopedTypeVars mn ks ma = do diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index b0ca42fdd2..7b0ee12a2e 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -18,6 +18,7 @@ import Control.Monad.State.Class (MonadState(..), gets, modify) import Data.Functor.Identity (Identity(), runIdentity) import Data.List (nub, (\\)) import Data.Monoid +import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Crash @@ -56,7 +57,7 @@ newSkolemScope = do -- | -- Skolemize a type variable by replacing its instances with fresh skolem constants -- -skolemize :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type +skolemize :: Text -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss) -- | @@ -64,25 +65,25 @@ skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss) -- DeferredDictionary placeholder. These type variables are somewhat unique since they are the -- only example of scoped type variables. -- -skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr +skolemizeTypesInValue :: Text -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr skolemizeTypesInValue ident sko scope ss = let (_, f, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS in runIdentity . f where - onExpr :: [String] -> Expr -> Identity ([String], Expr) + onExpr :: [Text] -> Expr -> Identity ([Text], Expr) onExpr sco (DeferredDictionary c ts) | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts)) onExpr sco (TypedValue check val ty) | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty)) onExpr sco other = return (sco, other) - onBinder :: [String] -> Binder -> Identity ([String], Binder) + onBinder :: [Text] -> Binder -> Identity ([Text], Binder) onBinder sco (TypedBinder ty b) | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ss ty) b) onBinder sco other = return (sco, other) - peelTypeVars :: Type -> [String] + peelTypeVars :: Type -> [Text] peelTypeVars (ForAll i ty _) = i : peelTypeVars ty peelTypeVars _ = [] diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 5989c26401..6e652a9a21 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} -- | @@ -40,8 +39,10 @@ import Data.Either (lefts, rights) import Data.Functor (($>)) import Data.List (transpose, nub, (\\), partition, delete) import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) import qualified Data.Map as M import qualified Data.Set as S +import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Crash @@ -442,7 +443,7 @@ inferBinder val (LiteralBinder (ObjectLiteral props)) = do unifyTypes val (TypeApp tyRecord row) return m1 where - inferRowProperties :: Type -> Type -> [(String, Binder)] -> m (M.Map Ident Type) + inferRowProperties :: Type -> Type -> [(Text, Binder)] -> m (M.Map Ident Type) inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty inferRowProperties nrow row ((name, binder):binders) = do propTy <- freshType @@ -559,7 +560,7 @@ check' val (ForAll ident ty _) = do return $ TypedValue True val' (ForAll ident ty (Just scope)) check' val t@(ConstrainedType constraints ty) = do dictNames <- forM constraints $ \(Constraint (Qualified _ (ProperName className)) _ _) -> - freshIdent ("dict" ++ className) + freshIdent ("dict" <> className) dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty return $ TypedValue True (foldr (Abs . Left) val' dictNames) t @@ -681,10 +682,10 @@ check' val ty = do checkProperties :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> - [(String, Expr)] -> + [(Text, Expr)] -> Type -> Bool -> - m [(String, Expr)] + m [(Text, Expr)] checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where go [] [] REmpty = return [] go [] [] u@(TUnknown _) @@ -771,7 +772,7 @@ checkFunctionApplication' fn u arg = do -- | -- Ensure a set of property names and value does not contain duplicate labels -- -ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(String, Expr)] -> m () +ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(Text, Expr)] -> m () ensureNoDuplicateProperties ps = let ls = map fst ps in case ls \\ nub ls of diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 5d0584b191..9625c3314f 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -24,6 +24,8 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.List (nub, sort) import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.Crash import Language.PureScript.Errors @@ -137,7 +139,7 @@ unifyRows r1 r2 = forM_ int (uncurry unifyTypes) unifyRows' sd1 r1' sd2 r2' where - unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> m () + unifyRows' :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> m () unifyRows' [] (TUnknown u) sd r = solveType u (rowFromList (sd, r)) unifyRows' sd r [] (TUnknown u) = solveType u (rowFromList (sd, r)) unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do @@ -155,7 +157,7 @@ unifyRows r1 r2 = -- | -- Replace a single type variable with a new unification variable -- -replaceVarWithUnknown :: (MonadState CheckState m) => String -> Type -> m Type +replaceVarWithUnknown :: (MonadState CheckState m) => Text -> Type -> m Type replaceVarWithUnknown ident ty = do tu <- freshType return $ replaceTypeVars ident tu ty @@ -179,7 +181,7 @@ replaceTypeWildcards = everywhereOnTypesM replace varIfUnknown :: Type -> Type varIfUnknown ty = let unks = nub $ unknownsInType ty - toName = (:) 't' . show + toName = T.cons 't' . T.pack . show ty' = everywhereOnTypes typeToVar ty typeToVar :: Type -> Type typeToVar (TUnknown u) = TypeVar (toName u) diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index a38300c7bb..147701575b 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -9,11 +9,13 @@ module Language.PureScript.Types where import Prelude.Compat import Control.Monad ((<=<)) - -import Data.List (nub) -import Data.Maybe (fromMaybe) import qualified Data.Aeson as A import qualified Data.Aeson.TH as A +import Data.List (nub) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.AST.SourcePos import Language.PureScript.Kinds @@ -32,9 +34,9 @@ data Type -- | A unification variable of type Type = TUnknown Int -- | A named type variable - | TypeVar String + | TypeVar Text -- | A type-level string - | TypeLevelString String + | TypeLevelString Text -- | A type wildcard, as would appear in a partial type synonym | TypeWildcard SourceSpan -- | A type constructor @@ -45,15 +47,15 @@ data Type -- | A type application | TypeApp Type Type -- | Forall quantifier - | ForAll String Type (Maybe SkolemScope) + | ForAll Text Type (Maybe SkolemScope) -- | A type with a set of type class constraints | ConstrainedType [Constraint] Type -- | A skolem constant - | Skolem String Int SkolemScope (Maybe SourceSpan) + | Skolem Text Int SkolemScope (Maybe SourceSpan) -- | An empty row | REmpty -- | A non-empty row - | RCons String Type Type + | RCons Text Type Type -- | A type with a kind annotation | KindedType Type Kind -- | A placeholder used in pretty printing @@ -61,7 +63,7 @@ data Type -- | A placeholder used in pretty printing | PrettyPrintObject Type -- | A placeholder used in pretty printing - | PrettyPrintForAll [String] Type + | PrettyPrintForAll [Text] Type -- | Binary operator application. During the rebracketing phase of desugaring, -- this data constructor will be removed. | BinaryNoParensType Type Type Type @@ -75,7 +77,7 @@ data Type -- | Additional data relevant to type class constraints data ConstraintData - = PartialConstraintData [[String]] Bool + = PartialConstraintData [[Text]] Bool -- ^ Data to accompany a Partial constraint generated by the exhaustivity checker. -- It contains (rendered) binder information for those binders which were -- not matched, and a flag indicating whether the list was truncated or not. @@ -106,7 +108,7 @@ $(A.deriveJSON A.defaultOptions ''ConstraintData) -- | -- Convert a row to a list of pairs of labels and types -- -rowToList :: Type -> ([(String, Type)], Type) +rowToList :: Type -> ([(Text, Type)], Type) rowToList (RCons name ty row) = let (tys, rest) = rowToList row in ((name, ty):tys, rest) rowToList r = ([], r) @@ -114,7 +116,7 @@ rowToList r = ([], r) -- | -- Convert a list of labels and types to a row -- -rowFromList :: ([(String, Type)], Type) -> Type +rowFromList :: ([(Text, Type)], Type) -> Type rowFromList ([], r) = r rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r)) @@ -128,23 +130,23 @@ isMonoType _ = True -- | -- Universally quantify a type -- -mkForAll :: [String] -> Type -> Type +mkForAll :: [Text] -> Type -> Type mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args -- | -- Replace a type variable, taking into account variable shadowing -- -replaceTypeVars :: String -> Type -> Type -> Type +replaceTypeVars :: Text -> Type -> Type -> Type replaceTypeVars v r = replaceAllTypeVars [(v, r)] -- | -- Replace named type variables with types -- -replaceAllTypeVars :: [(String, Type)] -> Type -> Type +replaceAllTypeVars :: [(Text, Type)] -> Type -> Type replaceAllTypeVars = go [] where - go :: [String] -> [(String, Type)] -> Type -> Type + go :: [Text] -> [(Text, Type)] -> Type -> Type go _ m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m) go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2) go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f @@ -163,16 +165,16 @@ replaceAllTypeVars = go [] go bs m (ParensInType t) = ParensInType (go bs m t) go _ _ ty = ty - genName orig inUse = try 0 + genName orig inUse = try' 0 where - try :: Integer -> String - try n | (orig ++ show n) `elem` inUse = try (n + 1) - | otherwise = orig ++ show n + try' :: Integer -> Text + try' n | (orig <> T.pack (show n)) `elem` inUse = try' (n + 1) + | otherwise = orig <> T.pack (show n) -- | -- Collect all type variables appearing in a type -- -usedTypeVariables :: Type -> [String] +usedTypeVariables :: Type -> [Text] usedTypeVariables = nub . everythingOnTypes (++) go where go (TypeVar v) = [v] @@ -181,10 +183,10 @@ usedTypeVariables = nub . everythingOnTypes (++) go -- | -- Collect all free type variables appearing in a type -- -freeTypeVariables :: Type -> [String] +freeTypeVariables :: Type -> [Text] freeTypeVariables = nub . go [] where - go :: [String] -> Type -> [String] + go :: [Text] -> Type -> [Text] go bound (TypeVar v) | v `notElem` bound = [v] go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2 go bound (ForAll v t _) = go (v : bound) t @@ -292,32 +294,32 @@ everywhereOnTypesTopDownM f = go <=< f go other = f other everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r -everythingOnTypes (<>) f = go +everythingOnTypes (<+>) f = go where - go t@(TypeApp t1 t2) = f t <> go t1 <> go t2 - go t@(ForAll _ ty _) = f t <> go ty - go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap constraintArgs cs) <> go ty - go t@(RCons _ ty rest) = f t <> go ty <> go rest - go t@(KindedType ty _) = f t <> go ty - go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2 - go t@(PrettyPrintObject t1) = f t <> go t1 - go t@(PrettyPrintForAll _ t1) = f t <> go t1 - go t@(BinaryNoParensType t1 t2 t3) = f t <> go t1 <> go t2 <> go t3 - go t@(ParensInType t1) = f t <> go t1 + go t@(TypeApp t1 t2) = f t <+> go t1 <+> go t2 + go t@(ForAll _ ty _) = f t <+> go ty + go t@(ConstrainedType cs ty) = foldl (<+>) (f t) (map go $ concatMap constraintArgs cs) <+> go ty + go t@(RCons _ ty rest) = f t <+> go ty <+> go rest + go t@(KindedType ty _) = f t <+> go ty + go t@(PrettyPrintFunction t1 t2) = f t <+> go t1 <+> go t2 + go t@(PrettyPrintObject t1) = f t <+> go t1 + go t@(PrettyPrintForAll _ t1) = f t <+> go t1 + go t@(BinaryNoParensType t1 t2 t3) = f t <+> go t1 <+> go t2 <+> go t3 + go t@(ParensInType t1) = f t <+> go t1 go other = f other everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type -> (s, r)) -> Type -> r -everythingWithContextOnTypes s0 r0 (<>) f = go' s0 +everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 where - go' s t = let (s', r) = f s t in r <> go s' t - go s (TypeApp t1 t2) = go' s t1 <> go' s t2 + go' s t = let (s', r) = f s t in r <+> go s' t + go s (TypeApp t1 t2) = go' s t1 <+> go' s t2 go s (ForAll _ ty _) = go' s ty - go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap constraintArgs cs) <> go' s ty - go s (RCons _ ty rest) = go' s ty <> go' s rest + go s (ConstrainedType cs ty) = foldl (<+>) r0 (map (go' s) $ concatMap constraintArgs cs) <+> go' s ty + go s (RCons _ ty rest) = go' s ty <+> go' s rest go s (KindedType ty _) = go' s ty - go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2 + go s (PrettyPrintFunction t1 t2) = go' s t1 <+> go' s t2 go s (PrettyPrintObject t1) = go' s t1 go s (PrettyPrintForAll _ t1) = go' s t1 - go s (BinaryNoParensType t1 t2 t3) = go' s t1 <> go' s t2 <> go' s t3 + go s (BinaryNoParensType t1 t2 t3) = go' s t1 <+> go' s t2 <+> go' s t3 go s (ParensInType t1) = go' s t1 go _ _ = r0 diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index f273938f45..d5d394c007 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -2,7 +2,6 @@ {-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.ReexportsSpec where -import qualified Prelude import Protolude import qualified Data.Map as Map @@ -11,7 +10,7 @@ import Language.PureScript.Ide.Types import qualified Language.PureScript as P import Test.Hspec -m :: Prelude.String -> P.ModuleName +m :: Text -> P.ModuleName m = P.moduleNameFromString d :: IdeDeclaration -> IdeDeclarationAnn diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index a11babef3c..827e33a3e3 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module TestCompiler where @@ -30,8 +31,8 @@ import Data.Function (on) import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy) import Data.Maybe (mapMaybe) import Data.Time.Clock (UTCTime()) -import Data.Tuple (swap) import qualified Data.Text as T +import Data.Tuple (swap) import qualified Data.Map as M @@ -72,7 +73,7 @@ spec = do supportPurs <- supportFiles "purs" supportPursFiles <- readInput supportPurs supportExterns <- runExceptT $ do - modules <- ExceptT . return $ P.parseModulesFromFiles id (map (fmap T.pack) supportPursFiles) + modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles foreigns <- inferForeignModules modules externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules) return (zip (map snd modules) externs) @@ -169,20 +170,20 @@ makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActi where getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime)) getInputTimestamp mn - | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever) + | isSupportModule (T.unpack (P.runModuleName mn)) = return (Left P.RebuildNever) | otherwise = return (Left P.RebuildAlways) where isSupportModule = flip elem supportModules getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime) getOutputTimestamp mn = do - let filePath = modulesDir P.runModuleName mn + let filePath = modulesDir T.unpack (P.runModuleName mn) exists <- liftIO $ doesDirectoryExist filePath return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing) -readInput :: [FilePath] -> IO [(FilePath, String)] +readInput :: [FilePath] -> IO [(FilePath, T.Text)] readInput inputFiles = forM inputFiles $ \inputFile -> do - text <- readUTF8File inputFile + text <- readUTF8FileT inputFile return (inputFile, text) runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors) @@ -195,7 +196,7 @@ compile -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) compile supportExterns inputFiles check = silence $ runTest $ do fs <- liftIO $ readInput inputFiles - ms <- P.parseModulesFromFiles id (map (fmap T.pack) fs) + ms <- P.parseModulesFromFiles id fs foreigns <- inferForeignModules ms liftIO (check (map snd ms)) let actions = makeActions foreigns @@ -222,7 +223,7 @@ checkMain ms = checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String checkShouldFailWith expected errs = let actual = map P.errorCode $ P.runMultipleErrors errs - in if sort expected == sort actual + in if sort expected == sort (map T.unpack actual) then Nothing else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 1d56293527..4c31f1eafa 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -13,6 +13,7 @@ import Data.Monoid import Data.Maybe (fromMaybe) import Data.List ((\\)) import Data.Foldable +import qualified Data.Text as T import System.Exit import qualified Language.PureScript as P @@ -36,8 +37,8 @@ main = pushd "examples/docs" $ do case res of Left e -> Publish.printErrorToStdout e >> exitFailure Right Docs.Package{..} -> - forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) -> - let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn) + forM_ testCases $ \(P.moduleNameFromString . T.pack -> mn, pragmas) -> + let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn)) (find ((==) mn . Docs.modName) pkgModules) in forM_ pragmas (`runAssertionIO` mdl) @@ -197,11 +198,11 @@ checkConstrained ty tyClass = False where matches className = - (==) className . P.runProperName . P.disqualify . P.constraintClass + (==) className . T.unpack . P.runProperName . P.disqualify . P.constraintClass runAssertionIO :: Assertion -> Docs.Module -> IO () runAssertionIO assertion mdl = do - putStrLn ("In " ++ P.runModuleName (Docs.modName mdl) ++ ": " ++ show assertion) + putStrLn ("In " ++ T.unpack (P.runModuleName (Docs.modName mdl)) ++ ": " ++ show assertion) case runAssertion assertion mdl of Pass -> pure () Fail reason -> do @@ -298,12 +299,12 @@ testCases = ] where - n = P.moduleNameFromString + n = P.moduleNameFromString . T.pack hasTypeVar varName = getAny . P.everythingOnTypes (<>) (Any . isVar varName) - isVar varName (P.TypeVar name) | varName == name = True + isVar varName (P.TypeVar name) | varName == T.unpack name = True isVar _ _ = False renderedType expected = diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index 19eb961287..f758acb21b 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -10,6 +10,7 @@ import Control.Monad.Trans.State.Strict (evalStateT) import Control.Monad (when) import Data.List (sort) +import qualified Data.Text as T import System.Exit (exitFailure) import System.Console.Haskeline @@ -127,11 +128,11 @@ getPSCiState = do Left err -> print err >> exitFailure Right modules -> - let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)] + let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName (T.pack "Prelude")], P.Implicit, Nothing)] dummyExterns = P.internalError "TestPsci: dummyExterns should not be used" in return (PSCiState imports [] (zip (map snd modules) (repeat dummyExterns))) controlMonadSTasST :: ImportedModule controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST")) where - s = P.moduleNameFromString + s = P.moduleNameFromString . T.pack From 1eb46ba8e2192907ba0a1b0af85cdd5ee4d2426e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 28 Nov 2016 10:35:16 -0800 Subject: [PATCH 0552/1580] Update Errors.hs --- src/Language/PureScript/Errors.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 729fa83082..729b03cfea 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -972,7 +972,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS ] renderHint (ErrorInDataBindingGroup nms) detail = paras [ detail - , line $ "in data binding group " ++ intercalate ", " (map runProperName nms) + , line $ "in data binding group " ++ T.intercalate ", " (map runProperName nms) ] renderHint (ErrorInTypeSynonym name) detail = paras [ detail From 8c324a0c0548ae8db3cf215fbf9bfe137994b131 Mon Sep 17 00:00:00 2001 From: Gil Mizrahi Date: Mon, 28 Nov 2016 22:49:49 +0200 Subject: [PATCH 0553/1580] Print functional dependencies in psc-docs output, fix #2439 (#2450) * print fundeps with psc-docs #2439 * adding a test for fundeps in psc-docs * Fixing errors due to change from String to Text --- examples/docs/src/TypeClassWithFunDeps.purs | 5 ++++ psc-docs/Tags.hs | 2 +- .../PureScript/Docs/Convert/ReExports.hs | 2 +- .../PureScript/Docs/Convert/Single.hs | 21 +++++++++++++++-- src/Language/PureScript/Docs/Render.hs | 12 +++++++++- src/Language/PureScript/Docs/Types.hs | 16 +++++++++---- src/Language/PureScript/Errors.hs | 4 ++-- src/Language/PureScript/Linter.hs | 6 ++--- tests/TestDocs.hs | 23 +++++++++++++++++++ 9 files changed, 76 insertions(+), 15 deletions(-) create mode 100644 examples/docs/src/TypeClassWithFunDeps.purs diff --git a/examples/docs/src/TypeClassWithFunDeps.purs b/examples/docs/src/TypeClassWithFunDeps.purs new file mode 100644 index 0000000000..3fd918a9d0 --- /dev/null +++ b/examples/docs/src/TypeClassWithFunDeps.purs @@ -0,0 +1,5 @@ + +module TypeClassWithFunDeps where + +class TypeClassWithFunDeps a b c d e | a b -> c, c -> d e where + aMember :: a diff --git a/psc-docs/Tags.hs b/psc-docs/Tags.hs index 8c30eb4072..df5d2be060 100644 --- a/psc-docs/Tags.hs +++ b/psc-docs/Tags.hs @@ -1,6 +1,6 @@ module Tags where -import Control.Arrow (first) +import Control.Arrow (first) import qualified Data.Text as T import qualified Language.PureScript as P diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 7980e1ef95..f4fcec2b3e 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -503,7 +503,7 @@ internalErrorInModule msg = do typeClassConstraintFor :: Declaration -> Maybe P.Constraint typeClassConstraintFor Declaration{..} = case declInfo of - TypeClassDeclaration tyArgs _ -> + TypeClassDeclaration tyArgs _ _ -> Just (P.Constraint (P.Qualified Nothing (P.ProperName (T.pack declTitle))) (mkConstraint (map (first T.pack) tyArgs)) Nothing) _ -> Nothing diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 3c55698652..074356001a 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -9,12 +9,14 @@ import Control.Arrow (first) import Control.Category ((>>>)) import Control.Monad +import Data.Bifunctor (bimap) import Data.Either import Data.List (nub) import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Vector as V import Language.PureScript.Docs.Types import qualified Language.PureScript as P @@ -127,10 +129,10 @@ convertDeclaration (P.ExternDataDeclaration _ kind') title = basicDeclaration title (ExternDataDeclaration kind') convertDeclaration (P.TypeSynonymDeclaration _ args ty) title = basicDeclaration title (TypeSynonymDeclaration (map (first T.unpack) args) ty) -convertDeclaration (P.TypeClassDeclaration _ args implies _ ds) title = -- TODO: include fundep info +convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title = Just (Right (mkDeclaration title info) { declChildren = children }) where - info = TypeClassDeclaration (map (first T.unpack) args) implies + info = TypeClassDeclaration (map (first T.unpack) args) implies (map (bimap (map T.unpack) (map T.unpack)) fundeps') children = map convertClassMember ds convertClassMember (P.PositionedDeclaration _ _ d) = convertClassMember d @@ -138,6 +140,21 @@ convertDeclaration (P.TypeClassDeclaration _ args implies _ ds) title = -- TODO: ChildDeclaration (T.unpack (P.showIdent ident')) Nothing Nothing (ChildTypeClassMember ty) convertClassMember _ = P.internalError "convertDeclaration: Invalid argument to convertClassMember." + fundeps' = map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps + where + argsVec = V.fromList (map fst args) + getArg i = + maybe + (P.internalError $ unlines + [ "convertDeclaration: Functional dependency index" + , show i + , "is bigger than arguments list" + , show (map fst args) + , "Functional dependencies are" + , show fundeps + ] + ) id $ argsVec V.!? i + toArgs from to = (map getArg from, map getArg to) convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = Just (Left (T.unpack classNameString : map T.unpack typeNameStrings, AugmentChild childDecl)) where diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 05add53caa..352bff910e 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -50,10 +50,11 @@ renderDeclarationWithOptions opts Declaration{..} = , syntax "=" , renderType' ty ] - TypeClassDeclaration args implies -> + TypeClassDeclaration args implies fundeps -> [ keywordClass ] ++ maybeToList superclasses ++ [renderType' (typeApp declTitle args)] + ++ fundepsList ++ [keywordWhere | any isTypeClassMember declChildren] where @@ -64,6 +65,15 @@ renderDeclarationWithOptions opts Declaration{..} = <> mintersperse (syntax "," <> sp) (map renderConstraint implies) <> syntax ")" <> sp <> syntax "<=" + fundepsList = + [syntax "|" | not (null fundeps)] + ++ [mintersperse + (syntax "," <> sp) + [idents from <> sp <> syntax "->" <> sp <> idents to | (from, to) <- fundeps ] + ] + where + idents = mintersperse sp . map ident + AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) -> [ keywordFixity associativity , syntax $ show precedence diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index aa0a8a12b7..e515cf386f 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -122,10 +122,10 @@ data DeclarationInfo | TypeSynonymDeclaration [(String, Maybe P.Kind)] P.Type -- | - -- A type class, with its type arguments and its superclasses. Instances and - -- members are represented as child declarations. + -- A type class, with its type arguments, its superclasses and functional + -- dependencies. Instances and members are represented as child declarations. -- - | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint] + | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint] [([String], [String])] -- | -- An operator alias declaration, with the member the alias is for and the @@ -141,7 +141,7 @@ declInfoToString (ValueDeclaration _) = "value" declInfoToString (DataDeclaration _ _) = "data" declInfoToString (ExternDataDeclaration _) = "externData" declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym" -declInfoToString (TypeClassDeclaration _ _) = "typeClass" +declInfoToString (TypeClassDeclaration _ _ _) = "typeClass" declInfoToString (AliasDeclaration _ _) = "alias" isTypeClass :: Declaration -> Bool @@ -413,6 +413,7 @@ asDeclarationInfo = do "typeClass" -> TypeClassDeclaration <$> key "arguments" asTypeArguments <*> key "superclasses" (eachInArray asConstraint) + <*> keyOrDefault "fundeps" [] asFunDeps "alias" -> AliasDeclaration <$> key "fixity" asFixity <*> key "alias" asFixityAlias @@ -430,6 +431,11 @@ asKind = fromAesonParser asType :: Parse e P.Type asType = fromAesonParser +asFunDeps :: Parse PackageError [([String], [String])] +asFunDeps = eachInArray asFunDep + where + asFunDep = (,) <$> nth 0 (eachInArray asString) <*> nth 1 (eachInArray asString) + asDataDeclType :: Parse PackageError P.DataDeclType asDataDeclType = withString $ \s -> case s of @@ -556,7 +562,7 @@ instance A.ToJSON DeclarationInfo where DataDeclaration ty args -> ["dataDeclType" .= ty, "typeArguments" .= args] ExternDataDeclaration kind -> ["kind" .= kind] TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty] - TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super] + TypeClassDeclaration args super fundeps -> ["arguments" .= args, "superclasses" .= super, "fundeps" .= fundeps] AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias] instance A.ToJSON ChildDeclarationInfo where diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 729b03cfea..4659a68ca4 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -972,7 +972,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS ] renderHint (ErrorInDataBindingGroup nms) detail = paras [ detail - , line $ "in data binding group " ++ T.intercalate ", " (map runProperName nms) + , line $ "in data binding group " <> T.intercalate ", " (map runProperName nms) ] renderHint (ErrorInTypeSynonym name) detail = paras [ detail @@ -988,7 +988,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS ] renderHint (ErrorInTypeClassDeclaration name) detail = paras [ detail - , line $ "in type class declaration for " ++ markCode (runProperName name) + , line $ "in type class declaration for " <> markCode (runProperName name) ] renderHint (ErrorInForeignImport nm) detail = paras [ detail diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 8b7d18447d..4918c11ff7 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -48,7 +48,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl f (TypeClassDeclaration name args _ _ decs) = addHint (ErrorInTypeClassDeclaration name) (foldMap (f' (S.fromList $ fst <$> args)) decs) f dec = f' S.empty dec - f' :: S.Set String -> Declaration -> MultipleErrors + f' :: S.Set Text -> Declaration -> MultipleErrors f' s (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' s dec) f' s dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec) f' s (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars s ty) @@ -76,10 +76,10 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl | otherwise = mempty stepDo _ _ = mempty - checkTypeVarsInDecl :: S.Set String -> Declaration -> MultipleErrors + checkTypeVarsInDecl :: S.Set Text -> Declaration -> MultipleErrors checkTypeVarsInDecl s d = let (f, _, _, _, _) = accumTypes (checkTypeVars s) in f d - checkTypeVars :: S.Set String -> Type -> MultipleErrors + checkTypeVars :: S.Set Text -> Type -> MultipleErrors checkTypeVars set ty = everythingWithContextOnTypes set mempty mappend step ty <> findUnused ty where step :: S.Set Text -> Type -> (S.Set Text, MultipleErrors) diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 4c31f1eafa..c68943750e 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -58,6 +58,9 @@ data Assertion -- | Assert that a particular declaration has a particular type class -- constraint. | ShouldBeConstrained P.ModuleName String String + -- | Assert that a particular typeclass declaration has a functional + -- dependency list. + | ShouldHaveFunDeps P.ModuleName String [([String],[String])] -- | Assert that a particular value declaration exists, and its type -- satisfies the given predicate. | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool)) @@ -83,6 +86,8 @@ data AssertionFailure | ChildDocumented P.ModuleName String String -- | A constraint was missing. | ConstraintMissing P.ModuleName String String + -- | A functional dependency was missing. + | FunDepMissing P.ModuleName String [([String], [String])] -- | A declaration had the wrong "type" (ie, value, type, type class) -- Fields: declaration title, expected "type", actual "type". | WrongDeclarationType P.ModuleName String String String @@ -143,6 +148,20 @@ runAssertion assertion Docs.Module{..} = Fail (WrongDeclarationType mn decl "value" (Docs.declInfoToString declInfo)) + ShouldHaveFunDeps mn decl fds -> + case find ((==) decl . Docs.declTitle) (declarationsFor mn) of + Nothing -> + Fail (NotDocumented mn decl) + Just Docs.Declaration{..} -> + case declInfo of + Docs.TypeClassDeclaration _ _ fundeps -> + if fundeps == fds + then Pass + else Fail (FunDepMissing mn decl fds) + _ -> + Fail (WrongDeclarationType mn decl "value" + (Docs.declInfoToString declInfo)) + ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) -> case find ((==) decl . Docs.declTitle) (declarationsFor mn) of Nothing -> @@ -271,6 +290,10 @@ testCases = , ChildShouldNotBeDocumented (n "TypeClassWithoutMembersIntermediate") "SomeClass" "member" ]) + , ("TypeClassWithFunDeps", + [ ShouldHaveFunDeps (n "TypeClassWithFunDeps") "TypeClassWithFunDeps" [(["a","b"], ["c"]), (["c"], ["d","e"])] + ]) + , ("NewOperators", [ ShouldBeDocumented (n "NewOperators2") "(>>>)" [] ]) From 3323f6381add03eba20fb5e3969c91877d77d6ba Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 30 Nov 2016 17:37:09 +0000 Subject: [PATCH 0554/1580] Update documentation link location --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index cc391f75f8..f7e5a8651f 100644 --- a/README.md +++ b/README.md @@ -17,7 +17,7 @@ A small strongly typed programming language with expressive types that compiles ## Resources - [PureScript book](https://leanpub.com/purescript/read) -- [Wiki](http://wiki.purescript.org) +- [Documentation](https://github.com/purescript/documentation) - [Try PureScript](http://try.purescript.org) - [Pursuit Package Index](http://pursuit.purescript.org/) From 6954b06d5e3316af4419b6594464c4ec2ec17aa8 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Tue, 6 Dec 2016 04:36:00 +0000 Subject: [PATCH 0555/1580] Add support for rows in instance head under fundeps (#2451) * Support rows in instance head under fundeps * Check determined class args by calculating contributing deps * Move determined arguments to TypeClassData and compute in 'smart constructor' * Update description of algorithm for computing determined type class args --- .../failing/RowInInstanceNotDetermined0.purs | 9 +++ .../failing/RowInInstanceNotDetermined1.purs | 9 +++ .../failing/RowInInstanceNotDetermined2.purs | 9 +++ .../passing/RowInInstanceHeadDetermined.purs | 40 ++++++++++++++ src/Language/PureScript/Environment.hs | 55 ++++++++++++++++++- src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/Externs.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 8 +-- src/Language/PureScript/TypeChecker.hs | 54 ++++++++++-------- 9 files changed, 156 insertions(+), 32 deletions(-) create mode 100644 examples/failing/RowInInstanceNotDetermined0.purs create mode 100644 examples/failing/RowInInstanceNotDetermined1.purs create mode 100644 examples/failing/RowInInstanceNotDetermined2.purs create mode 100644 examples/passing/RowInInstanceHeadDetermined.purs diff --git a/examples/failing/RowInInstanceNotDetermined0.purs b/examples/failing/RowInInstanceNotDetermined0.purs new file mode 100644 index 0000000000..6e2a9d8336 --- /dev/null +++ b/examples/failing/RowInInstanceNotDetermined0.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith InvalidInstanceHead +module Main where + +import Prelude + +-- no fundeps +class C a b +instance c :: C Unit {} + diff --git a/examples/failing/RowInInstanceNotDetermined1.purs b/examples/failing/RowInInstanceNotDetermined1.purs new file mode 100644 index 0000000000..39083a9cbd --- /dev/null +++ b/examples/failing/RowInInstanceNotDetermined1.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith InvalidInstanceHead +module Main where + +import Prelude + +-- `c` not mentioned in any fundeps +class C a b c | a -> b +instance c :: C Unit Unit {} + diff --git a/examples/failing/RowInInstanceNotDetermined2.purs b/examples/failing/RowInInstanceNotDetermined2.purs new file mode 100644 index 0000000000..141e9c5534 --- /dev/null +++ b/examples/failing/RowInInstanceNotDetermined2.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith InvalidInstanceHead +module Main where + +import Prelude + +-- `b` isn't determined by anything that `b` doesn't determine +class C a b | a -> b, b -> a +instance c :: C Unit {} + diff --git a/examples/passing/RowInInstanceHeadDetermined.purs b/examples/passing/RowInInstanceHeadDetermined.purs new file mode 100644 index 0000000000..73a89ba54b --- /dev/null +++ b/examples/passing/RowInInstanceHeadDetermined.purs @@ -0,0 +1,40 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +data Empty = Empty +data Cons = Cons + + +-- simple case +class Simple a b | a -> b where c :: a -> b +instance simple0 :: Simple Empty {} where c _ = {} +instance simple1 :: Simple Cons {foo :: Cons} where c cons = {foo: cons} + + +-- simple transitive example +class Transitive a b c | a -> b, b -> c where d :: a -> c +instance transitive :: Transitive Empty {} {} where d _ = {} + + +-- transitive example with cycles +class Cyclic a b c d | a -> b, b -> a + , a -> c + , c -> d, d -> c +instance cyclic :: Cyclic Empty Empty {} {} + + +-- Determined cycle +class DeterminedCycle a b c | a -> b + , b -> c, c -> b +instance determinedCycle :: DeterminedCycle Empty {} {} + + +-- multiple determiners +class MultipleDeterminers a b c d | a b -> c d +instance multipleDeterminers :: MultipleDeterminers Empty Empty {} {} + + +main = log "Done" + diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 4c122b2c71..01adeedf36 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -7,9 +7,12 @@ import Prelude.Compat import Data.Aeson.TH import qualified Data.Aeson as A import qualified Data.Map as M +import qualified Data.Set as S import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T +import Data.List (nub) +import qualified Data.Graph as G import Language.PureScript.Crash import Language.PureScript.Kinds @@ -48,6 +51,10 @@ data TypeClassData = TypeClassData -- are considered bound in the types appearing in these constraints. , typeClassDependencies :: [FunctionalDependency] -- ^ A list of functional dependencies for the type arguments of this class. + , typeClassDeterminedArguments :: S.Set Int + -- ^ A set of indexes of type argument that are fully determined by other + -- arguments via functional dependencies. This can be computed from both + -- typeClassArguments and typeClassDependencies. } deriving Show -- | A functional dependency indicates a relationship between two sets of @@ -65,6 +72,50 @@ data FunctionalDependency = FunctionalDependency initEnvironment :: Environment initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses +-- | +-- A constructor for TypeClassData that computes which type class arguments are fully determined. +-- Fully determined means that this argument cannot be used when selecting a type class instance. +-- +-- An example of the difference between determined and fully determined would be with the class: +-- ```class C a b c | a -> b, b -> a, b -> c``` +-- In this case, `a` must differ when `b` differs, and vice versa - each is determined by the other. +-- Both `a` and `b` can be used in selecting a type class instance. However, `c` cannot - it is +-- fully determined by `a` and `b`. +-- +-- Define a graph of type class arguments with edges being fundep determiners to determined. +-- An argument is fully determined if doesn't appear at the start of a path of strongly connected components. +-- An argument is not fully determined otherwise. +-- +-- The way we compute this is by saying: an argument X is fully determined if there are arguments that +-- determine X that X does not determine. This is the same thing: everything X determines includes everything +-- in its SCC, and everything determining X is either before it in an SCC path, or in the same SCC. +makeTypeClassData + :: [(Text, Maybe Kind)] + -> [(Ident, Type)] + -> [Constraint] + -> [FunctionalDependency] + -> TypeClassData +makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs + where + -- list all the edges in the graph: for each fundep an edge exists for each determiner to each determined + contributingDeps = M.fromListWith (++) $ do + fd <- deps + src <- fdDeterminers fd + (src, fdDetermined fd) : map (, []) (fdDetermined fd) + + -- here we build a graph of which arguments determine other arguments + (depGraph, _, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps) + + -- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to + isFunDepDetermined arg = case fromKey arg of + Nothing -> False -- not mentioned in fundeps + Just v -> let contributesToVar = G.reachable (G.transposeG depGraph) v + varContributesTo = G.reachable depGraph v + in any (\r -> not (r `elem` varContributesTo)) contributesToVar + + -- find all the arguments that are determined + determinedArgs = S.fromList $ filter isFunDepDetermined [0 .. length args - 1] + -- | -- The visibility of a name in scope -- @@ -264,8 +315,8 @@ primTypes = primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses = M.fromList - [ (primName "Partial", (TypeClassData [] [] [] [])) - , (primName "Fail", (TypeClassData [("message", Just Symbol)] [] [] [])) + [ (primName "Partial", (makeTypeClassData [] [] [] [])) + , (primName "Fail", (makeTypeClassData [("message", Just Symbol)] [] [] [])) ] -- | diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 4659a68ca4..40ee52100e 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -726,7 +726,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS renderSimpleErrorMessage (InvalidInstanceHead ty) = paras [ line "Type class instance head is invalid due to use of type" , markCodeBox $ indent $ typeAsBox ty - , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form." + , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form, unless the type is fully determined by other type class arguments via functional dependencies." ] renderSimpleErrorMessage (TransitiveExportError x ys) = paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " requires the following to also be exported: " diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 1000ee2bf0..12f04ad317 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -144,7 +144,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) } applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } - applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (TypeClassData args members cs deps) (typeClasses env) } + applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps) (typeClasses env) } applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) } where dict :: NamedDict diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 1b79a9f214..4b1007f3f2 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -57,11 +57,7 @@ desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModu -> ExternsDeclaration -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData) fromExternsDecl mn (EDClass name args members implies deps) = Just ((mn, name), typeClass) where - typeClass = TypeClassData { typeClassArguments = args - , typeClassMembers = members - , typeClassSuperclasses = implies - , typeClassDependencies = deps - } + typeClass = makeTypeClassData args members implies deps fromExternsDecl _ _ = Nothing desugarModule @@ -182,7 +178,7 @@ desugarDecl desugarDecl mn exps = go where go d@(TypeClassDeclaration name args implies deps members) = do - modify (M.insert (mn, name) (TypeClassData args (map memberToNameAndType members) implies deps)) + modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps)) return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index fafe4626bc..9b6e1bbdb8 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -22,6 +22,7 @@ import Data.Foldable (for_, traverse_) import Data.List (nub, nubBy, (\\), sort, group) import Data.Maybe import qualified Data.Map as M +import qualified Data.Set as S import Data.Monoid ((<>)) import qualified Data.Text as T import Data.Text (Text) @@ -124,12 +125,7 @@ addTypeClass moduleName pn args implies dependencies ds = modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) newClass (typeClasses . checkEnv $ st) } } where newClass :: TypeClassData - newClass = - TypeClassData { typeClassArguments = args - , typeClassMembers = map toPair ds - , typeClassSuperclasses = implies - , typeClassDependencies = dependencies - } + newClass = makeTypeClassData args (map toPair ds) implies dependencies toPair (TypeDeclaration ident ty) = (ident, ty) toPair (PositionedDeclaration _ _ d) = toPair d @@ -155,18 +151,28 @@ checkDuplicateTypeArguments args = for_ firstDup $ \dup -> firstDup = listToMaybe $ args \\ nub args checkTypeClassInstance - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => ModuleName + :: (MonadState CheckState m, MonadError MultipleErrors m) + => TypeClassData + -> Int -- ^ index of type class argument -> Type -> m () -checkTypeClassInstance _ (TypeVar _) = return () -checkTypeClassInstance _ (TypeLevelString _) = return () -checkTypeClassInstance _ (TypeConstructor ctor) = do - env <- getEnv - when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance - return () -checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2 -checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty +checkTypeClassInstance cls i = check where + -- If the argument is determined via fundeps then we are less restrictive in + -- what type is allowed. This is because the type cannot be used to influence + -- which instance is selected. Currently the only weakened restriction is that + -- row types are allowed in determined type class arguments. + isFunDepDetermined = S.member i (typeClassDeterminedArguments cls) + check = \case + TypeVar _ -> return () + TypeLevelString _ -> return () + TypeConstructor ctor -> do + env <- getEnv + when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance + return () + TypeApp t1 t2 -> check t1 >> check t2 + REmpty | isFunDepDetermined -> return () + RCons _ hd tl | isFunDepDetermined -> check hd >> check tl + ty -> throwError . errorMessage $ InvalidInstanceHead ty -- | -- Check that type synonyms are fully-applied in a type @@ -283,12 +289,16 @@ typeCheckAll moduleName _ = traverse go addTypeClass moduleName pn args implies deps tys return d go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do - traverse_ (checkTypeClassInstance moduleName) tys - checkOrphanInstance dictName className tys - _ <- traverseTypeInstanceBody checkInstanceMembers body - let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) - addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict - return d + env <- getEnv + case M.lookup className (typeClasses env) of + Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" + Just typeClass -> do + sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys) + checkOrphanInstance dictName className tys + _ <- traverseTypeInstanceBody checkInstanceMembers body + let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) + addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict + return d go (PositionedDeclaration pos com d) = warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d From 642f939ec08dba4b7616790d1fdcc4b84ebd0abe Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 5 Dec 2016 21:18:26 -0800 Subject: [PATCH 0556/1580] Use HTTPS to query Pursuit --- src/Language/PureScript/Ide/Pursuit.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs index 90957fa2f2..03c71bf06e 100644 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -36,7 +36,7 @@ import qualified Pipes.Prelude as P queryPursuit :: Text -> IO ByteString queryPursuit q = do let qClean = T.dropWhileEnd (== '.') q - req' <- parseRequest "http://pursuit.purescript.org/search" + req' <- parseRequest "https://pursuit.purescript.org/search" let req = req' { queryString= "q=" <> (fromString . T.unpack) qClean , requestHeaders=[(hAccept, "application/json")] From 25f58b72f8c6e9a4d5bad6d2476fc2fa1e37dd69 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 6 Dec 2016 11:27:25 +0000 Subject: [PATCH 0557/1580] Fix windows CI The stack windows binary archive at the previous URL seems to have changed from a .zip to a .tar.gz, which was confusing 7zip - it seems 7zip uses the file name to guess what kind of archive it is. Separately, it appears that stack has started providing downloads via github releases in addition to stackage.org, and the github download includes a zip archive. Since extracting zip archives is easier with 7zip, we now use this download location instead. The Stack executable itself uses this URL for self-updates, so I think it ought to be safe to use this URL: https://github.com/commercialhaskell/stack/commit/aa94dcd65c22a4fcbd4dacd5aa7064daf8e49a6b#diff-fc80843636d5c5474f236e348f03a9e8R139 --- appveyor.yml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/appveyor.yml b/appveyor.yml index 0f6685bb82..3d8803d15d 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -3,6 +3,7 @@ version: '{build}' environment: # Keep the path as short as possible, just in case. STACK_ROOT: c:\s + STACK_VER: 1.2.0 RELEASE_USER: purescript RELEASE_REPO: purescript cache: @@ -15,7 +16,9 @@ install: - ps: | New-Item -ItemType Directory -Force -Path C:\tools $env:Path += ";C:\tools" - (New-Object Net.WebClient).DownloadFile('https://www.stackage.org/stack/windows-x86_64', 'c:\tools\stack.zip') + $stackRelease = "stack-$env:STACK_VER-windows-x86_64" + $downloadUrl = "https://github.com/commercialhaskell/stack/releases/download/v$env:STACK_VER/$stackRelease.zip" + (New-Object Net.WebClient).DownloadFile($downloadUrl, 'c:\tools\stack.zip') pushd c:\tools 7z x c:\tools\stack.zip stack.exe popd From 460e8cba5087fbd16925e9b53baca32314b63a3c Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 1 Nov 2016 13:53:29 +0100 Subject: [PATCH 0558/1580] [psc-ide] Adds polling option for psc-ide-server * This uses polling instead of file system events for the file watcher * Make polling the default on Windows --- psc-ide-server/Main.hs | 14 +++++++++++--- psc-ide-server/README.md | 2 ++ src/Language/PureScript/Ide/Watcher.hs | 17 ++++++++++------- 3 files changed, 23 insertions(+), 10 deletions(-) diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 675966a1da..fa003d132b 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -41,6 +41,7 @@ import Network.Socket hiding (PortNumber, Type, import Options.Applicative (ParseError (..)) import qualified Options.Applicative as Opts import System.Directory +import System.Info as SysInfo import System.FilePath import System.IO hiding (putStrLn, print) import System.IO.Error (isEOFError) @@ -66,12 +67,14 @@ data Options = Options , optionsOutputPath :: FilePath , optionsPort :: PortNumber , optionsNoWatch :: Bool + , optionsPolling :: Bool , optionsDebug :: Bool - } + } deriving (Show) main :: IO () main = do - Options dir globs outputPath port noWatch debug <- Opts.execParser opts + opts'@(Options dir globs outputPath port noWatch polling debug) <- Opts.execParser opts + when debug (putText "Parsed Options:" *> print opts') maybe (pure ()) setCurrentDirectory dir ideState <- newTVarIO emptyIdeState cwd <- getCurrentDirectory @@ -84,7 +87,7 @@ main = do putText "psc-ide needs you to compile your project (for example by running pulp build)" unless noWatch $ - void (forkFinally (watcher ideState fullOutputPath) print) + void (forkFinally (watcher polling ideState fullOutputPath) print) let conf = Configuration {confDebug = debug, confOutputPath = outputPath, confGlobs = globs} env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf} @@ -98,12 +101,17 @@ main = do <*> (fromIntegral <$> Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer))) <*> Opts.switch (Opts.long "no-watch") + <*> flipIfWindows (Opts.switch (Opts.long "polling")) <*> Opts.switch (Opts.long "debug") opts = Opts.info (version <*> Opts.helper <*> parser) mempty version = Opts.abortOption (InfoMsg (showVersion Paths.version)) (Opts.long "version" `mappend` Opts.help "Show the version number") + -- polling is the default on Windows and the flag turns it off. See + -- #2209 and #2414 for explanations + flipIfWindows = map (if SysInfo.os == "mingw32" then not else identity) + startServer :: PortNumber -> IdeEnvironment -> IO () startServer port env = withSocketsDo $ do sock <- listenOnLocalhost port diff --git a/psc-ide-server/README.md b/psc-ide-server/README.md index 114095a910..3207c8ab76 100644 --- a/psc-ide-server/README.md +++ b/psc-ide-server/README.md @@ -23,6 +23,8 @@ It supports the following options: project directory. Defaults to `output/`, relative to either the current directory or the directory specified by `-d`. - `--debug`: Enables some logging meant for debugging +- `--polling`: Uses polling instead of file system events to watch the externs + files. This flag is reversed on Windows and polling is the default. - `--no-watch`: Disables the filewatcher - `--version`: Output psc-ide version diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs index 8ae6213100..59cda641b7 100644 --- a/src/Language/PureScript/Ide/Watcher.hs +++ b/src/Language/PureScript/Ide/Watcher.hs @@ -40,10 +40,13 @@ reloadFile ref ev = do -- | Installs filewatchers for the given directory and reloads ExternsFiles when -- they change on disc -watcher :: TVar IdeState -> FilePath -> IO () -watcher stateVar fp = - withManagerConf (defaultConfig { confDebounce = NoDebounce }) $ \mgr -> do - _ <- watchTree mgr fp - (\ev -> takeFileName (eventPath ev) == "externs.json") - (reloadFile stateVar) - forever (threadDelay 100000) +watcher :: Bool -> TVar IdeState -> FilePath -> IO () +watcher polling stateVar fp = + withManagerConf + (defaultConfig { confDebounce = NoDebounce + , confUsePolling = polling + }) $ \mgr -> do + _ <- watchTree mgr fp + (\ev -> takeFileName (eventPath ev) == "externs.json") + (reloadFile stateVar) + forever (threadDelay 100000) From 9ded0a340af796ae1ec19e4b393209459b8ce467 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 2 Dec 2016 22:11:23 +0100 Subject: [PATCH 0559/1580] [psc-ide] log handleCommand duration --- psc-ide-server/Main.hs | 7 +++++-- purescript.cabal | 1 + src/Language/PureScript/Ide/Command.hs | 15 +++++++++++++++ src/Language/PureScript/Ide/State.hs | 9 ++++----- src/Language/PureScript/Ide/Util.hs | 12 ++++++++++-- 5 files changed, 35 insertions(+), 9 deletions(-) diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index fa003d132b..d2d11a68d9 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -30,6 +30,7 @@ import qualified Data.Text.IO as T import qualified Data.ByteString.Lazy.Char8 as BS8 import Data.Version (showVersion) import Language.PureScript.Ide +import Language.PureScript.Ide.Command import Language.PureScript.Ide.Util import Language.PureScript.Ide.Error import Language.PureScript.Ide.Types @@ -40,12 +41,12 @@ import Network.Socket hiding (PortNumber, Type, sClose) import Options.Applicative (ParseError (..)) import qualified Options.Applicative as Opts +import System.Clock import System.Directory import System.Info as SysInfo import System.FilePath import System.IO hiding (putStrLn, print) import System.IO.Error (isEOFError) - import qualified Paths_purescript as Paths listenOnLocalhost :: PortNumber -> IO Socket @@ -127,7 +128,10 @@ startServer port env = withSocketsDo $ do Right (cmd, h) -> do case decodeT cmd of Just cmd' -> do + start <- liftIO (getTime Monotonic) result <- runExceptT (handleCommand cmd') + end <- liftIO (getTime Monotonic) + $(logDebug) ("Command " <> commandName cmd' <> " took " <> (displayTimeSpec (diffTimeSpec start end))) -- $(logDebug) ("Answer was: " <> T.pack (show result)) liftIO (hFlush stdout) case result of @@ -140,7 +144,6 @@ startServer port env = withSocketsDo $ do hFlush stdout liftIO (hClose h) - acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m) => Socket -> m (Text, Handle) acceptCommand sock = do diff --git a/purescript.cabal b/purescript.cabal index 4f4fcabd17..19c1fe9e87 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -473,6 +473,7 @@ executable psc-ide-server build-depends: base >=4 && <5, aeson >= 0.8 && < 1.0, bytestring -any, + clock -any, purescript -any, base-compat >=0.6.0, directory -any, diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 6540db92ca..d05ef7ec0f 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -61,6 +61,21 @@ data Command | Reset | Quit +commandName :: Command -> Text +commandName c = case c of + Load{} -> "Load" + Type{} -> "Type" + Complete{} -> "Complete" + Pursuit{} -> "Pursuit" + CaseSplit{} -> "CaseSplit" + AddClause{} -> "AddClause" + Import{} -> "Import" + List{} -> "List" + Rebuild{} -> "Rebuild" + Cwd{} -> "Cwd" + Reset{} -> "Reset" + Quit{} -> "Quit" + data ImportCommand = AddImplicitImport P.ModuleName | AddImportForIdentifier Text diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 3a6ddfc3bf..8f55733234 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -32,7 +32,6 @@ module Language.PureScript.Ide.State , resolveOperatorsForModule ) where -import qualified Prelude import Protolude import Control.Concurrent.STM @@ -183,8 +182,8 @@ populateStage2 = do start <- getTime Monotonic atomically (populateStage2STM st) end <- getTime Monotonic - pure (Prelude.show (diffTimeSpec start end)) - $(logDebug) $ "Finished populating Stage2 in " <> toS duration + pure (diffTimeSpec start end) + $(logDebug) $ "Finished populating Stage2 in " <> displayTimeSpec duration -- | STM version of populateStage2 populateStage2STM :: TVar IdeState -> STM () @@ -201,11 +200,11 @@ populateStage3 = do start <- getTime Monotonic results <- atomically (populateStage3STM st) end <- getTime Monotonic - pure (Prelude.show (diffTimeSpec start end), results) + pure (diffTimeSpec start end, results) traverse_ (logWarnN . prettyPrintReexportResult (runModuleNameT . fst)) (filter reexportHasFailures results) - $(logDebug) $ "Finished populating Stage3 in " <> toS duration + $(logDebug) $ "Finished populating Stage3 in " <> displayTimeSpec duration -- | STM version of populateStage3 populateStage3STM :: TVar IdeState -> STM [ReexportResult Module] diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 63d208ef8a..8e8adb4176 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -26,9 +26,13 @@ module Language.PureScript.Ide.Util , withEmptyAnn , valueOperatorAliasT , typeOperatorAliasT + , displayTimeSpec , module Language.PureScript.Ide.Conversions ) where +import Protolude hiding (decodeUtf8, + encodeUtf8) + import Control.Lens ((^.)) import Data.Aeson import qualified Data.Text as T @@ -36,8 +40,8 @@ import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) import qualified Language.PureScript as P import Language.PureScript.Ide.Conversions import Language.PureScript.Ide.Types -import Protolude hiding (decodeUtf8, - encodeUtf8) +import System.Clock +import Text.Printf identifierFromIdeDeclaration :: IdeDeclaration -> Text identifierFromIdeDeclaration d = case d of @@ -111,3 +115,7 @@ unwrapPositioned x = x unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x unwrapPositionedRef x = x + +displayTimeSpec :: TimeSpec -> Text +displayTimeSpec ts = + T.pack (printf "%0.2f" (fromIntegral (toNanoSecs ts) / 1000000 :: Double)) <> "ms" From a9c525c7f78351775283f14d4b2d91cfac740100 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 5 Dec 2016 23:40:36 +0100 Subject: [PATCH 0560/1580] [psc-ide] more finegrained logging --- psc-ide-server/Main.hs | 30 ++++++++++++------- purescript.cabal | 4 +-- src/Language/PureScript/Ide.hs | 6 ++-- src/Language/PureScript/Ide/Externs.hs | 3 +- src/Language/PureScript/Ide/Logging.hs | 36 +++++++++++++++++++++++ src/Language/PureScript/Ide/SourceFile.hs | 2 +- src/Language/PureScript/Ide/State.hs | 17 +++-------- src/Language/PureScript/Ide/Types.hs | 5 +++- src/Language/PureScript/Ide/Util.hs | 9 ++---- 9 files changed, 71 insertions(+), 41 deletions(-) create mode 100644 src/Language/PureScript/Ide/Logging.hs diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index d2d11a68d9..4464f94a08 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -41,7 +41,6 @@ import Network.Socket hiding (PortNumber, Type, sClose) import Options.Applicative (ParseError (..)) import qualified Options.Applicative as Opts -import System.Clock import System.Directory import System.Info as SysInfo import System.FilePath @@ -70,11 +69,12 @@ data Options = Options , optionsNoWatch :: Bool , optionsPolling :: Bool , optionsDebug :: Bool + , optionsLoglevel :: IdeLogLevel } deriving (Show) main :: IO () main = do - opts'@(Options dir globs outputPath port noWatch polling debug) <- Opts.execParser opts + opts'@(Options dir globs outputPath port noWatch debug logLevel) <- Opts.execParser opts when debug (putText "Parsed Options:" *> print opts') maybe (pure ()) setCurrentDirectory dir ideState <- newTVarIO emptyIdeState @@ -89,8 +89,8 @@ main = do unless noWatch $ void (forkFinally (watcher polling ideState fullOutputPath) print) - - let conf = Configuration {confDebug = debug, confOutputPath = outputPath, confGlobs = globs} + -- TODO: deprecate and get rid of `debug` + let conf = Configuration {confLogLevel = if debug then LogDebug else logLevel, confOutputPath = outputPath, confGlobs = globs} env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf} startServer port env where @@ -104,7 +104,16 @@ main = do <*> Opts.switch (Opts.long "no-watch") <*> flipIfWindows (Opts.switch (Opts.long "polling")) <*> Opts.switch (Opts.long "debug") + <*> (parseLogLevel <$> Opts.strOption + (Opts.long "log-level" + <> Opts.value "" + <> Opts.help "One of \"debug\", \"perf\" or \"all\"")) opts = Opts.info (version <*> Opts.helper <*> parser) mempty + parseLogLevel s = case s of + "debug" -> LogDebug + "perf" -> LogPerf + "all" -> LogAll + _ -> LogNone version = Opts.abortOption (InfoMsg (showVersion Paths.version)) (Opts.long "version" `mappend` Opts.help "Show the version number") @@ -116,10 +125,8 @@ main = do startServer :: PortNumber -> IdeEnvironment -> IO () startServer port env = withSocketsDo $ do sock <- listenOnLocalhost port - runLogger (runReaderT (forever (loop sock)) env) + runLogger (confLogLevel (ideConfiguration env)) (runReaderT (forever (loop sock)) env) where - runLogger = runStdoutLoggingT . filterLogger (\_ _ -> confDebug (ideConfiguration env)) - loop :: (Ide m, MonadLogger m) => Socket -> m () loop sock = do accepted <- runExceptT $ acceptCommand sock @@ -128,10 +135,11 @@ startServer port env = withSocketsDo $ do Right (cmd, h) -> do case decodeT cmd of Just cmd' -> do - start <- liftIO (getTime Monotonic) - result <- runExceptT (handleCommand cmd') - end <- liftIO (getTime Monotonic) - $(logDebug) ("Command " <> commandName cmd' <> " took " <> (displayTimeSpec (diffTimeSpec start end))) + let message duration = + "Command " <> commandName cmd' + <> " took " + <> displayTimeSpec duration + result <- logPerf message (runExceptT (handleCommand cmd')) -- $(logDebug) ("Answer was: " <> T.pack (show result)) liftIO (hFlush stdout) case result of diff --git a/purescript.cabal b/purescript.cabal index 19c1fe9e87..3ea8f55367 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -271,8 +271,9 @@ library Language.PureScript.Ide.Conversions Language.PureScript.Ide.Externs Language.PureScript.Ide.Error - Language.PureScript.Ide.Imports Language.PureScript.Ide.Filter + Language.PureScript.Ide.Imports + Language.PureScript.Ide.Logging Language.PureScript.Ide.Matcher Language.PureScript.Ide.Pursuit Language.PureScript.Ide.Rebuild @@ -473,7 +474,6 @@ executable psc-ide-server build-depends: base >=4 && <5, aeson >= 0.8 && < 1.0, bytestring -any, - clock -any, purescript -any, base-compat >=0.6.0, directory -any, diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 25ce106ecf..87cb0ad779 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -186,11 +186,9 @@ loadModules moduleNames = do -- Finally we kick off the worker with @async@ and return the number of -- successfully parsed modules. env <- ask - let runLogger = - runStdoutLoggingT - . filterLogger (\_ _ -> confDebug (ideConfiguration env)) + let ll = confLogLevel (ideConfiguration env) -- populateStage2 and 3 return Unit for now, so it's fine to discard this -- result. We might want to block on this in a benchmarking situation. - _ <- liftIO (async (runLogger (runReaderT (populateStage2 *> populateStage3) env))) + _ <- liftIO (async (runLogger ll (runReaderT (populateStage2 *> populateStage3) env))) pure (TextResult ("Loaded " <> show (length efiles) <> " modules and " <> show (length allModules) <> " source files.")) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 1e92bd9f43..967779d8b2 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -26,7 +26,6 @@ import Protolude import Control.Lens ((^.)) import Data.Aeson (decodeStrict) import qualified Data.ByteString as BS -import Data.List (nub) import qualified Data.Map as Map import Language.PureScript.Ide.Error (PscIdeError (..)) import Language.PureScript.Ide.Types @@ -55,7 +54,7 @@ convertExterns ef = declarations = mapMaybe convertDecl (P.efDeclarations ef) typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration declarations) - cleanDeclarations = nub $ appEndo typeClassFilter declarations + cleanDeclarations = ordNub (appEndo typeClassFilter declarations) removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration] removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate) diff --git a/src/Language/PureScript/Ide/Logging.hs b/src/Language/PureScript/Ide/Logging.hs new file mode 100644 index 0000000000..62612428d5 --- /dev/null +++ b/src/Language/PureScript/Ide/Logging.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE PackageImports #-} + +module Language.PureScript.Ide.Logging + ( runLogger + , logPerf + , displayTimeSpec + ) where + +import Protolude + +import "monad-logger" Control.Monad.Logger +import qualified Data.Text as T +import Language.PureScript.Ide.Types +import System.Clock +import Text.Printf + +runLogger :: MonadIO m => IdeLogLevel -> LoggingT m a -> m a +runLogger logLevel' = + runStdoutLoggingT . filterLogger (\_ logLevel -> + case logLevel' of + LogAll -> True + LogNone -> False + LogDebug -> not (logLevel == LevelOther "perf") + LogPerf -> logLevel == LevelOther "perf") + +logPerf :: (MonadIO m, MonadLogger m) => (TimeSpec -> Text) -> m t -> m t +logPerf format f = do + start <- liftIO (getTime Monotonic) + result <- f + end <- liftIO (getTime Monotonic) + logOtherN (LevelOther "perf") (format (diffTimeSpec start end)) + pure result + +displayTimeSpec :: TimeSpec -> Text +displayTimeSpec ts = + T.pack (printf "%0.2f" (fromIntegral (toNanoSecs ts) / 1000000 :: Double)) <> "ms" diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 141e0110d1..5c0c4072eb 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -116,7 +116,7 @@ extractSpans ss d = case d of _ -> [] where -- We need this special case to be able to also get the position info for - -- typeclass member functions. Typedeclaratations would clash with value + -- typeclass member functions. Typedeclarations would clash with value -- declarations for non-typeclass members, which is why we can't handle them -- in extractSpans. extractSpans' ssP dP = case dP of diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 8f55733234..3298cc77b5 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -45,7 +45,6 @@ import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import System.Clock -- | Resets all State inside psc-ide resetIdeState :: Ide m => m () @@ -178,12 +177,8 @@ cachedRebuild = s3CachedRebuild <$> getStage3 populateStage2 :: (Ide m, MonadLogger m) => m () populateStage2 = do st <- ideStateVar <$> ask - duration <- liftIO $ do - start <- getTime Monotonic - atomically (populateStage2STM st) - end <- getTime Monotonic - pure (diffTimeSpec start end) - $(logDebug) $ "Finished populating Stage2 in " <> displayTimeSpec duration + let message duration = "Finished populating Stage2 in " <> displayTimeSpec duration + logPerf message (liftIO (atomically (populateStage2STM st))) -- | STM version of populateStage2 populateStage2STM :: TVar IdeState -> STM () @@ -196,15 +191,11 @@ populateStage2STM ref = do populateStage3 :: (Ide m, MonadLogger m) => m () populateStage3 = do st <- ideStateVar <$> ask - (duration, results) <- liftIO $ do - start <- getTime Monotonic - results <- atomically (populateStage3STM st) - end <- getTime Monotonic - pure (diffTimeSpec start end, results) + let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration + results <- logPerf message (liftIO (atomically (populateStage3STM st))) traverse_ (logWarnN . prettyPrintReexportResult (runModuleNameT . fst)) (filter reexportHasFailures results) - $(logDebug) $ "Finished populating Stage3 in " <> displayTimeSpec duration -- | STM version of populateStage3 populateStage3STM :: TVar IdeState -> STM [ReexportResult Module] diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index a9f98aa8a3..98422dc17e 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -111,10 +111,13 @@ newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotation -- annotations found in a module deriving (Show, Eq, Ord, Functor, Foldable) +data IdeLogLevel = LogDebug | LogPerf | LogAll | LogNone + deriving (Show, Eq) + data Configuration = Configuration { confOutputPath :: FilePath - , confDebug :: Bool + , confLogLevel :: IdeLogLevel , confGlobs :: [FilePath] } diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 8e8adb4176..1e35ef03b3 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -26,8 +26,8 @@ module Language.PureScript.Ide.Util , withEmptyAnn , valueOperatorAliasT , typeOperatorAliasT - , displayTimeSpec , module Language.PureScript.Ide.Conversions + , module Language.PureScript.Ide.Logging ) where import Protolude hiding (decodeUtf8, @@ -39,9 +39,8 @@ import qualified Data.Text as T import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) import qualified Language.PureScript as P import Language.PureScript.Ide.Conversions +import Language.PureScript.Ide.Logging import Language.PureScript.Ide.Types -import System.Clock -import Text.Printf identifierFromIdeDeclaration :: IdeDeclaration -> Text identifierFromIdeDeclaration d = case d of @@ -115,7 +114,3 @@ unwrapPositioned x = x unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x unwrapPositionedRef x = x - -displayTimeSpec :: TimeSpec -> Text -displayTimeSpec ts = - T.pack (printf "%0.2f" (fromIntegral (toNanoSecs ts) / 1000000 :: Double)) <> "ms" From 7cb2c29da84bb37963a7394369af7ee3eb5690d9 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 6 Dec 2016 14:40:04 +0100 Subject: [PATCH 0561/1580] [psc-ide] log version mismatches when reading externs files --- psc-ide-server/Main.hs | 9 ++++---- psc-ide-server/README.md | 4 +++- src/Language/PureScript/Ide/Externs.hs | 32 ++++++++++++++++++-------- src/Language/PureScript/Ide/Logging.hs | 1 + src/Language/PureScript/Ide/Types.hs | 7 +++--- src/Language/PureScript/Ide/Watcher.hs | 3 ++- 6 files changed, 37 insertions(+), 19 deletions(-) diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 4464f94a08..7bdb9b6671 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -74,7 +74,7 @@ data Options = Options main :: IO () main = do - opts'@(Options dir globs outputPath port noWatch debug logLevel) <- Opts.execParser opts + opts'@(Options dir globs outputPath port noWatch polling debug logLevel) <- Opts.execParser opts when debug (putText "Parsed Options:" *> print opts') maybe (pure ()) setCurrentDirectory dir ideState <- newTVarIO emptyIdeState @@ -106,14 +106,15 @@ main = do <*> Opts.switch (Opts.long "debug") <*> (parseLogLevel <$> Opts.strOption (Opts.long "log-level" - <> Opts.value "" - <> Opts.help "One of \"debug\", \"perf\" or \"all\"")) + `mappend` Opts.value "" + `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\"")) opts = Opts.info (version <*> Opts.helper <*> parser) mempty parseLogLevel s = case s of "debug" -> LogDebug "perf" -> LogPerf "all" -> LogAll - _ -> LogNone + "none" -> LogNone + _ -> LogDefault version = Opts.abortOption (InfoMsg (showVersion Paths.version)) (Opts.long "version" `mappend` Opts.help "Show the version number") diff --git a/psc-ide-server/README.md b/psc-ide-server/README.md index 3207c8ab76..920c588263 100644 --- a/psc-ide-server/README.md +++ b/psc-ide-server/README.md @@ -22,9 +22,11 @@ It supports the following options: - `--output-directory`: Specify where to look for compiled output inside your project directory. Defaults to `output/`, relative to either the current directory or the directory specified by `-d`. -- `--debug`: Enables some logging meant for debugging +<<<<<<< HEAD - `--polling`: Uses polling instead of file system events to watch the externs files. This flag is reversed on Windows and polling is the default. +- `--debug`: DEPRECATED: use --log-level="debug" +- `--log-level`: Can be set to one of "all", "none", "debug" and "perf" - `--no-watch`: Disables the filewatcher - `--version`: Output psc-ide version diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 967779d8b2..237f9e797c 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -12,8 +12,8 @@ -- Handles externs files for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PackageImports #-} module Language.PureScript.Ide.Externs ( readExternFile @@ -23,24 +23,38 @@ module Language.PureScript.Ide.Externs import Protolude -import Control.Lens ((^.)) -import Data.Aeson (decodeStrict) -import qualified Data.ByteString as BS -import qualified Data.Map as Map +import Control.Lens ((^.)) +import "monad-logger" Control.Monad.Logger +import Data.Aeson (decodeStrict) +import qualified Data.ByteString as BS +import qualified Data.Map as Map +import Data.Version (showVersion) import Language.PureScript.Ide.Error (PscIdeError (..)) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import qualified Language.PureScript as P +import qualified Language.PureScript as P -readExternFile :: (MonadIO m, MonadError PscIdeError m) => +readExternFile :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) => FilePath -> m P.ExternsFile readExternFile fp = do parseResult <- liftIO (decodeStrict <$> BS.readFile fp) case parseResult of - Nothing -> throwError . GeneralError $ "Parsing the extern at: " <> toS fp <> " failed" + Nothing -> + throwError (GeneralError + ("Parsing the extern at: " <> toS fp <> " failed")) + Just externs + | P.efVersion externs /= version -> do + let errMsg = "Version mismatch for the externs at: " <> toS fp + <> " Expected: " <> version + <> " Found: " <> P.efVersion externs + logErrorN errMsg + throwError (GeneralError errMsg) Just externs -> pure externs + where + version = toS (showVersion P.version) + convertExterns :: P.ExternsFile -> (Module, [(P.ModuleName, P.DeclarationRef)]) convertExterns ef = ((P.efModuleName ef, decls), exportDecls) diff --git a/src/Language/PureScript/Ide/Logging.hs b/src/Language/PureScript/Ide/Logging.hs index 62612428d5..84f45d2725 100644 --- a/src/Language/PureScript/Ide/Logging.hs +++ b/src/Language/PureScript/Ide/Logging.hs @@ -19,6 +19,7 @@ runLogger logLevel' = runStdoutLoggingT . filterLogger (\_ logLevel -> case logLevel' of LogAll -> True + LogDefault -> not (logLevel == LevelOther "perf" || logLevel == LevelDebug) LogNone -> False LogDebug -> not (logLevel == LevelOther "perf") LogPerf -> logLevel == LevelOther "perf") diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 98422dc17e..effb991546 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -12,9 +12,8 @@ -- Type definitions for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Ide.Types where @@ -111,7 +110,7 @@ newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotation -- annotations found in a module deriving (Show, Eq, Ord, Functor, Foldable) -data IdeLogLevel = LogDebug | LogPerf | LogAll | LogNone +data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone deriving (Show, Eq) data Configuration = diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs index 59cda641b7..97b45b575d 100644 --- a/src/Language/PureScript/Ide/Watcher.hs +++ b/src/Language/PureScript/Ide/Watcher.hs @@ -22,6 +22,7 @@ import Control.Concurrent.STM import Language.PureScript.Ide.Externs import Language.PureScript.Ide.State import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util import System.FilePath import System.FSNotify @@ -31,7 +32,7 @@ reloadFile :: TVar IdeState -> Event -> IO () reloadFile _ Removed{} = pure () reloadFile ref ev = do let fp = eventPath ev - ef' <- runExceptT (readExternFile fp) + ef' <- runLogger LogDefault (runExceptT (readExternFile fp)) case ef' of Left _ -> pure () Right ef -> do From 260a2a3baf63522eaa492dd1f3d11f47d12e27a9 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 7 Dec 2016 17:59:43 +0100 Subject: [PATCH 0562/1580] Fix merge leftover --- psc-ide-server/README.md | 1 - 1 file changed, 1 deletion(-) diff --git a/psc-ide-server/README.md b/psc-ide-server/README.md index 920c588263..88fac0ce8b 100644 --- a/psc-ide-server/README.md +++ b/psc-ide-server/README.md @@ -22,7 +22,6 @@ It supports the following options: - `--output-directory`: Specify where to look for compiled output inside your project directory. Defaults to `output/`, relative to either the current directory or the directory specified by `-d`. -<<<<<<< HEAD - `--polling`: Uses polling instead of file system events to watch the externs files. This flag is reversed on Windows and polling is the default. - `--debug`: DEPRECATED: use --log-level="debug" From 4ffff84dce072eb7df66d1c464d1e501021ec0e2 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 7 Dec 2016 17:56:50 +0000 Subject: [PATCH 0563/1580] Use writeUTF8File in psc-bundle --- psc-bundle/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index 7caeac3358..ab4a09aa5a 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -20,7 +20,7 @@ import System.FilePath (takeDirectory) import System.FilePath.Glob (glob) import System.Exit (exitFailure) import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8) -import System.IO.UTF8 (readUTF8File) +import System.IO.UTF8 (readUTF8File, writeUTF8File) import System.Directory (createDirectoryIfMissing) import Language.PureScript.Bundle @@ -110,7 +110,7 @@ main = do case optionsOutputFile opts of Just outputFile -> do createDirectoryIfMissing True (takeDirectory outputFile) - writeFile outputFile js + writeUTF8File outputFile js Nothing -> putStrLn js where infoModList = Opts.fullDesc <> headerInfo <> footerInfo From aaa6990549ecc7c4cd91c9f32fc7486833ee4169 Mon Sep 17 00:00:00 2001 From: Andy Arvanitis Date: Wed, 7 Dec 2016 14:08:53 -0800 Subject: [PATCH 0564/1580] Issue #2453: dump output of psc tests to file --- tests/TestCompiler.hs | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 827e33a3e3..4fc855221e 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -47,6 +47,7 @@ import System.Exit import System.Process hiding (cwd) import System.FilePath import System.Directory +import System.IO import System.IO.UTF8 import System.IO.Silently import qualified System.FilePath.Glob as Glob @@ -81,10 +82,15 @@ spec = do Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) Right externs -> return (externs, passingFiles, warningFiles, failingFiles) + outputFile <- runIO $ do + tmp <- getTemporaryDirectory + createDirectoryIfMissing False (tmp logpath) + openFile (tmp logpath logfile) WriteMode + context "Passing examples" $ forM_ passingTestCases $ \testPurs -> it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ - assertCompiles supportExterns testPurs + assertCompiles supportExterns testPurs outputFile context "Warning examples" $ forM_ warningTestCases $ \testPurs -> do @@ -230,8 +236,9 @@ checkShouldFailWith expected errs = assertCompiles :: [(P.Module, P.ExternsFile)] -> [FilePath] + -> Handle -> Expectation -assertCompiles supportExterns inputFiles = +assertCompiles supportExterns inputFiles outputFile = assert supportExterns inputFiles checkMain $ \e -> case e of Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs @@ -240,10 +247,13 @@ assertCompiles supportExterns inputFiles = let entryPoint = modulesDir "index.js" writeFile entryPoint "require('Main').main()" result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process + hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" case result of Just (ExitSuccess, out, err) | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err - | not (null out) && trim (last (lines out)) == "Done" -> return Nothing + | not (null out) && trim (last (lines out)) == "Done" -> do + hPutStr outputFile out + return Nothing | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out Just (ExitFailure _, _, err) -> return $ Just err Nothing -> return $ Just "Couldn't find node.js executable" @@ -286,3 +296,9 @@ assertDoesNotCompile supportExterns inputFiles shouldFailWith = where noPreCheck = const (return ()) + +logpath :: FilePath +logpath = "purescript-output" + +logfile :: FilePath +logfile = "psc-tests.out" From 546804b6c5e87643f0fb77c9840aef46be801bae Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Thu, 8 Dec 2016 08:27:04 +0100 Subject: [PATCH 0565/1580] remove text conversion functions --- src/Language/PureScript/Ide.hs | 2 +- src/Language/PureScript/Ide/CaseSplit.hs | 8 ++++---- src/Language/PureScript/Ide/Conversions.hs | 20 ++++---------------- src/Language/PureScript/Ide/Externs.hs | 4 ++-- src/Language/PureScript/Ide/Rebuild.hs | 3 +-- src/Language/PureScript/Ide/Reexports.hs | 2 +- src/Language/PureScript/Ide/SourceFile.hs | 20 ++++++++++---------- src/Language/PureScript/Ide/State.hs | 2 +- src/Language/PureScript/Ide/Types.hs | 6 +++--- src/Language/PureScript/Ide/Util.hs | 20 ++++++++++---------- 10 files changed, 37 insertions(+), 50 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 87cb0ad779..2c666d1c8a 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -110,7 +110,7 @@ findPursuitPackages (PursuitQuery q) = PursuitResult <$> liftIO (findPackagesForModuleIdent q) printModules :: Ide m => m Success -printModules = ModuleList . map runModuleNameT <$> getLoadedModulenames +printModules = ModuleList . map P.runModuleName <$> getLoadedModulenames outputDirectory :: Ide m => m FilePath outputDirectory = do diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 00940e47f3..398506476f 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -84,9 +84,9 @@ splitTypeConstructor = go [] go _ _ = throwError (GeneralError "Failed to read TypeConstructor") prettyCtor :: WildcardAnnotations -> Constructor -> Text -prettyCtor _ (ctorName, []) = runProperNameT ctorName +prettyCtor _ (ctorName, []) = P.runProperName ctorName prettyCtor wsa (ctorName, ctorArgs) = - "("<> runProperNameT ctorName <> " " + "("<> P.runProperName ctorName <> " " <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")" prettyPrintWildcard :: WildcardAnnotations -> P.Type -> Text @@ -111,9 +111,9 @@ addClause :: (MonadError PscIdeError m) => Text -> WildcardAnnotations -> m [Tex addClause s wca = do (fName, fType) <- parseTypeDeclaration' s let args = splitFunctionType fType - template = runIdentT fName <> " " <> + template = P.runIdent fName <> " " <> T.unwords (map (prettyPrintWildcard wca) args) <> - " = ?" <> (T.strip . runIdentT $ fName) + " = ?" <> (T.strip . P.runIdent $ fName) pure [s, template] parseType' :: (MonadError PscIdeError m) => diff --git a/src/Language/PureScript/Ide/Conversions.hs b/src/Language/PureScript/Ide/Conversions.hs index bb5ec88987..1420c9d921 100644 --- a/src/Language/PureScript/Ide/Conversions.hs +++ b/src/Language/PureScript/Ide/Conversions.hs @@ -15,27 +15,15 @@ module Language.PureScript.Ide.Conversions where import Control.Lens.Iso -import Data.Text (lines, strip, unwords) +import Data.Text (lines, strip, unwords, pack) import qualified Language.PureScript as P import Protolude -runProperNameT :: P.ProperName a -> Text -runProperNameT = toS . P.runProperName - properNameT :: Iso' (P.ProperName a) Text -properNameT = iso (toS . P.runProperName) (P.ProperName . toS) - -runIdentT :: P.Ident -> Text -runIdentT = toS . P.runIdent +properNameT = iso P.runProperName P.ProperName identT :: Iso' P.Ident Text -identT = iso (toS . P.runIdent) (P.Ident . toS) - -runOpNameT :: P.OpName a -> Text -runOpNameT = toS . P.runOpName - -runModuleNameT :: P.ModuleName -> Text -runModuleNameT = toS . P.runModuleName +identT = iso P.runIdent P.Ident prettyTypeT :: P.Type -> Text -prettyTypeT = unwords . map strip . lines . toS . P.prettyPrintType +prettyTypeT = unwords . map strip . lines . pack . P.prettyPrintType diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 237f9e797c..ee402c708b 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -133,13 +133,13 @@ annotateModule (defs, types) (moduleName, decls) = IdeDeclDataConstructor dtor -> annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor) IdeDeclTypeClass i -> - annotateType (runProperNameT i) (IdeDeclTypeClass i) + annotateType (i ^. properNameT) (IdeDeclTypeClass i) IdeDeclValueOperator op -> annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op) IdeDeclTypeOperator op -> annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op) where - annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (runIdentT x)) defs + annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (P.runIdent x)) defs , annTypeAnnotation = Map.lookup x types }) annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) defs}) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index a50646c87f..03c5f3ad9f 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -20,7 +20,6 @@ import Language.PureScript.Errors.JSON import Language.PureScript.Ide.Error import Language.PureScript.Ide.State import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util import System.IO.UTF8 (readUTF8FileT) -- | Given a filepath performs the following steps: @@ -96,7 +95,7 @@ rebuildModuleOpen makeEnv externs m = do throwError (GeneralError "Failed when rebuilding with open exports") Right result -> do $(logDebug) - ("Setting Rebuild cache: " <> runModuleNameT (P.efModuleName result)) + ("Setting Rebuild cache: " <> P.runModuleName (P.efModuleName result)) cacheRebuild result -- | Parameters we can access while building our @MakeActions@ diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index f0ac391517..f18c46b7b3 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -53,7 +53,7 @@ prettyPrintReexportResult f ReexportResult{..} | otherwise = "Failed to resolve reexports for " <> f reResolved - <> foldMap (\(mn, ref) -> runModuleNameT mn <> show ref) reFailed + <> foldMap (\(mn, ref) -> P.runModuleName mn <> show ref) reFailed -- | Whether any Refs couldn't be resolved reexportHasFailures :: ReexportResult a -> Bool diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 5c0c4072eb..8462e01372 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -60,9 +60,9 @@ getImportsForFile fp = do where mkModuleImport (mn, importType', qualifier) = ModuleImport - (runModuleNameT mn) + (P.runModuleName mn) importType' - (runModuleNameT <$> qualifier) + (P.runModuleName <$> qualifier) unwrapPositionedImport (mn, it, q) = (mn, unwrapImportType it, q) unwrapImportType (P.Explicit decls) = P.Explicit (map unwrapPositionedRef decls) unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls) @@ -101,18 +101,18 @@ extractSpans ss d = case d of P.PositionedDeclaration ss' _ d' -> extractSpans ss' d' P.ValueDeclaration i _ _ _ -> - [(Left (runIdentT i), ss)] + [(Left (P.runIdent i), ss)] P.TypeSynonymDeclaration name _ _ -> - [(Right (runProperNameT name), ss)] + [(Right (P.runProperName name), ss)] P.TypeClassDeclaration name _ _ _ members -> - (Right (runProperNameT name), ss) : concatMap (extractSpans' ss) members + (Right (P.runProperName name), ss) : concatMap (extractSpans' ss) members P.DataDeclaration _ name _ ctors -> - (Right (runProperNameT name), ss) - : map (\(cname, _) -> (Left (runProperNameT cname), ss)) ctors + (Right (P.runProperName name), ss) + : map (\(cname, _) -> (Left (P.runProperName cname), ss)) ctors P.ExternDeclaration ident _ -> - [(Left (runIdentT ident), ss)] + [(Left (P.runIdent ident), ss)] P.ExternDataDeclaration name _ -> - [(Right (runProperNameT name), ss)] + [(Right (P.runProperName name), ss)] _ -> [] where -- We need this special case to be able to also get the position info for @@ -123,5 +123,5 @@ extractSpans ss d = case d of P.PositionedDeclaration ssP' _ dP' -> extractSpans' ssP' dP' P.TypeDeclaration ident _ -> - [(Left (runIdentT ident), ssP)] + [(Left (P.runIdent ident), ssP)] _ -> [] diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 3298cc77b5..d31e7093f9 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -194,7 +194,7 @@ populateStage3 = do let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration results <- logPerf message (liftIO (atomically (populateStage3STM st))) traverse_ - (logWarnN . prettyPrintReexportResult (runModuleNameT . fst)) + (logWarnN . prettyPrintReexportResult (P.runModuleName . fst)) (filter reexportHasFailures results) -- | STM version of populateStage3 diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index effb991546..26a47a0bb1 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -212,9 +212,9 @@ instance ToJSON ModuleImport where ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) identifierFromDeclarationRef :: P.DeclarationRef -> Text -identifierFromDeclarationRef (P.TypeRef name _) = runProperNameT name -identifierFromDeclarationRef (P.ValueRef ident) = runIdentT ident -identifierFromDeclarationRef (P.TypeClassRef name) = runProperNameT name +identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name +identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident +identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name identifierFromDeclarationRef _ = "" data Success = diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 1e35ef03b3..a9d531fce6 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -48,9 +48,9 @@ identifierFromIdeDeclaration d = case d of IdeDeclType t -> t ^. ideTypeName . properNameT IdeDeclTypeSynonym s -> s ^. ideSynonymName . properNameT IdeDeclDataConstructor dtor -> dtor ^. ideDtorName . properNameT - IdeDeclTypeClass name -> runProperNameT name - IdeDeclValueOperator op -> op ^. ideValueOpName & runOpNameT - IdeDeclTypeOperator op -> op ^. ideTypeOpName & runOpNameT + IdeDeclTypeClass name -> P.runProperName name + IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName + IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName discardAnn :: IdeDeclarationAnn -> IdeDeclaration discardAnn (IdeDeclarationAnn _ d) = d @@ -70,13 +70,13 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) = IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind & toS ) IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT) IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT) - IdeDeclTypeClass name -> (runProperNameT name, "class") + IdeDeclTypeClass name -> (P.runProperName name, "class") IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) -> - (runOpNameT op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP) + (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP) IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) -> - (runOpNameT op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind) + (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind) - complModule = runModuleNameT m + complModule = P.runModuleName m complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann) @@ -89,17 +89,17 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) = P.Infix -> "infix" P.Infixl -> "infixl" P.Infixr -> "infixr" - in T.unwords [asso, show p, r, "as", runOpNameT o] + in T.unwords [asso, show p, r, "as", P.runOpName o] valueOperatorAliasT :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text valueOperatorAliasT i = - toS (P.showQualified (either P.runIdent P.runProperName) i) + P.showQualified (either P.runIdent P.runProperName) i typeOperatorAliasT :: P.Qualified (P.ProperName 'P.TypeName) -> Text typeOperatorAliasT i = - toS (P.showQualified P.runProperName i) + P.showQualified P.runProperName i encodeT :: (ToJSON a) => a -> Text encodeT = toS . decodeUtf8 . encode From 22616a10c33bfe629361c4f1c083abc907a3ba30 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Thu, 8 Dec 2016 08:43:03 +0100 Subject: [PATCH 0566/1580] remove unneeded pragmas --- psc-ide-client/Main.hs | 1 - src/Language/PureScript/AST/Operators.hs | 2 -- src/Language/PureScript/AST/SourcePos.hs | 2 -- src/Language/PureScript/Docs/Convert.hs | 2 -- src/Language/PureScript/Docs/Types.hs | 2 -- src/Language/PureScript/Ide.hs | 7 +++---- src/Language/PureScript/Ide/CaseSplit.hs | 2 -- src/Language/PureScript/Ide/Command.hs | 3 --- src/Language/PureScript/Ide/Completion.hs | 1 - src/Language/PureScript/Ide/Error.hs | 1 - src/Language/PureScript/Ide/Externs.hs | 1 - src/Language/PureScript/Ide/Filter.hs | 1 - src/Language/PureScript/Ide/Imports.hs | 2 -- src/Language/PureScript/Ide/Matcher.hs | 1 - src/Language/PureScript/Ide/Pursuit.hs | 2 -- src/Language/PureScript/Ide/Rebuild.hs | 3 --- src/Language/PureScript/Ide/Reexports.hs | 3 --- src/Language/PureScript/Ide/SourceFile.hs | 2 -- src/Language/PureScript/Ide/State.hs | 1 - src/Language/PureScript/Ide/Types.hs | 1 - src/Language/PureScript/Ide/Util.hs | 2 -- src/Language/PureScript/Interactive.hs | 4 ---- src/Language/PureScript/Interactive/Completion.hs | 2 -- src/Language/PureScript/Interactive/Printer.hs | 3 --- src/Language/PureScript/Make.hs | 1 - src/Language/PureScript/Publish.hs | 1 - src/Language/PureScript/Publish/ErrorsWarnings.hs | 2 -- src/Language/PureScript/Sugar/TypeClasses/Deriving.hs | 3 --- src/Language/PureScript/TypeChecker/Subsumption.hs | 1 - src/Language/PureScript/TypeChecker/TypeSearch.hs | 4 ---- src/Language/PureScript/TypeChecker/Types.hs | 1 - 31 files changed, 3 insertions(+), 61 deletions(-) diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs index 85d56a6c36..932a4b2eec 100644 --- a/psc-ide-client/Main.hs +++ b/psc-ide-client/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module Main where import Prelude () diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs index 0b8e53636d..c562e7d39a 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | -- Operators fixity and associativity -- diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 2b238a1466..5dfb98b68d 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | -- Source position information -- diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 7dede7e8d6..5473cffb2c 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | Functions for converting PureScript ASTs into values of the data types -- from Language.PureScript.Docs. diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index e515cf386f..506d24cee7 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Language.PureScript.Docs.Types ( module Language.PureScript.Docs.Types , module ReExports diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 2c666d1c8a..77af155b29 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -12,7 +12,6 @@ -- Interface for the psc-ide-server ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} @@ -175,12 +174,12 @@ loadModules moduleNames = do efiles <- traverse readExternFile efPaths traverse_ insertExterns efiles - -- We parse all source files, log eventual parse failures if the debug flag - -- was set and insert the succesful parses into the state. + -- We parse all source files, log eventual parse failures and insert the + -- successful parses into the state. (failures, allModules) <- partitionEithers <$> (traverse parseModule =<< findAllSourceFiles) unless (null failures) $ - $(logDebug) ("Failed to parse: " <> show failures) + $(logWarn) ("Failed to parse: " <> show failures) traverse_ insertModule allModules -- Finally we kick off the worker with @async@ and return the number of diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 398506476f..c54380bb14 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -12,8 +12,6 @@ -- Casesplitting and adding function clauses ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} - module Language.PureScript.Ide.CaseSplit ( WildcardAnnotations() , explicitAnnotations diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index d05ef7ec0f..c51015fc09 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -12,9 +12,6 @@ -- Datatypes for the commands psc-ide accepts ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} - - module Language.PureScript.Ide.Command where import Protolude diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index acb667566b..181dbe0c0a 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Completion ( getCompletions , getExactMatches diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 5b56717b02..44ee78e880 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -12,7 +12,6 @@ -- Error types for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Error ( PscIdeError(..) ) where diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index ee402c708b..d02f6bfcf9 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -12,7 +12,6 @@ -- Handles externs files for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PackageImports #-} module Language.PureScript.Ide.Externs diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 6c52549601..5648028b32 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -13,7 +13,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Filter ( Filter diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index a490eb92dc..b8ad743f2f 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -12,8 +12,6 @@ -- Provides functionality to manage imports ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} - module Language.PureScript.Ide.Imports ( addImplicitImport , addImportForIdentifier diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index 7a495d2c0e..531a29e43c 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -14,7 +14,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.Matcher ( Matcher diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs index 03c71bf06e..1143a245ed 100644 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -12,8 +12,6 @@ -- Pursuit client for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} - module Language.PureScript.Ide.Pursuit ( searchPursuitForDeclarations , findPackagesForModuleIdent diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 03c5f3ad9f..b1647eed95 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} module Language.PureScript.Ide.Rebuild ( rebuildFile diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index f18c46b7b3..47f19270fa 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -13,9 +13,6 @@ -- Resolves reexports for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - module Language.PureScript.Ide.Reexports ( resolveReexports , prettyPrintReexportResult diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 8462e01372..c0b96957f8 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -12,8 +12,6 @@ -- Getting declarations from PureScript sourcefiles ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} - module Language.PureScript.Ide.SourceFile ( parseModule , getImportsForFile diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index d31e7093f9..f24ad0c4a7 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -12,7 +12,6 @@ -- Functions to access psc-ide's state ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 26a47a0bb1..3408e34bab 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -25,7 +25,6 @@ import Data.Aeson import qualified Data.Map.Lazy as M import qualified Language.PureScript as P import qualified Language.PureScript.Errors.JSON as P -import Language.PureScript.Ide.Conversions type ModuleIdent = Text diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index a9d531fce6..0a61278667 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -12,8 +12,6 @@ -- Generally useful functions ----------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} - module Language.PureScript.Ide.Util ( identifierFromIdeDeclaration , unwrapMatch diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index f82b7d5865..b926383aa9 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -1,8 +1,4 @@ {-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DataKinds #-} module Language.PureScript.Interactive ( handleCommand diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index 33aab4125d..7ab532ae99 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DataKinds #-} - module Language.PureScript.Interactive.Completion ( CompletionM , liftCompletionM diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index 5d47f50b85..38022a7dc3 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DataKinds #-} - module Language.PureScript.Interactive.Printer where import Prelude.Compat diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index f70e6b8717..9f60e06cd1 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -1,6 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Make ( diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index d1ce4b56e5..83589ba484 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Publish ( preparePackage diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index e1c8ed7b1b..db7d7de173 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Language.PureScript.Publish.ErrorsWarnings ( PackageError(..) , PackageWarning(..) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index d3b7c607c3..fbf0be83b4 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} - -- | -- This module implements the generic deriving elaboration that takes place during desugaring. -- diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 2838da17d4..82c685e241 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index c84c360828..b78ca07108 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - module Language.PureScript.TypeChecker.TypeSearch ( typeSearch ) where diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 6e652a9a21..e417a4acae 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -- | From 93a52e251809eae36943125b8fd0412a2678eeb4 Mon Sep 17 00:00:00 2001 From: Michael Ficarra Date: Sat, 10 Dec 2016 10:04:05 -0800 Subject: [PATCH 0567/1580] fixes #2434 and #2438: PureScript chars must be UTF-16 code units (#2454) * fixes #2434: fixes #2438: PureScript chars must be UTF-16 code units * add descriptions to StringEscape assertions; add one more assertion * fix regressions introduced by #2418 * disable failing Unicode replacement character test for now --- examples/failing/2434.purs | 5 +++++ examples/passing/2438.purs | 8 +++++++ examples/passing/StringEscapes.purs | 22 +++++++++++++------- src/Language/PureScript/CodeGen/JS/Common.hs | 2 +- src/Language/PureScript/Parser/Lexer.hs | 21 +++++++++++++++++-- src/Language/PureScript/Pretty/JS.hs | 10 ++++----- 6 files changed, 52 insertions(+), 16 deletions(-) create mode 100644 examples/failing/2434.purs create mode 100644 examples/passing/2438.purs diff --git a/examples/failing/2434.purs b/examples/failing/2434.purs new file mode 100644 index 0000000000..87c41ff3fa --- /dev/null +++ b/examples/failing/2434.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +x :: Char +x = '\x10000' diff --git a/examples/passing/2438.purs b/examples/passing/2438.purs new file mode 100644 index 0000000000..75bd83ca82 --- /dev/null +++ b/examples/passing/2438.purs @@ -0,0 +1,8 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +done :: String +done = {"𝌆": "Done"}."𝌆" + +main = log done diff --git a/examples/passing/StringEscapes.purs b/examples/passing/StringEscapes.purs index 9c9338bbdc..55487d125e 100644 --- a/examples/passing/StringEscapes.purs +++ b/examples/passing/StringEscapes.purs @@ -1,18 +1,26 @@ module Main where -import Prelude ((==), bind) -import Test.Assert (assert) +import Prelude ((==), (/=), (<>), bind) +import Test.Assert (assert, assert') import Control.Monad.Eff.Console (log) singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C" hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0" decimal = "\119558\9731\966\224\0" == "𝌆☃φà\0" surrogatePair = "\xD834\xDF06" == "\x1D306" +highSurrogate = "\xD834" +lowSurrogate = "\xDF06" +loneSurrogates = (highSurrogate <> lowSurrogate) == "\x1D306" +outOfOrderSurrogates = (lowSurrogate <> highSurrogate) == "\xDF06\xD834" +replacement = "\xFFFD" +notReplacing = replacement /= highSurrogate main = do - assert singleCharacter - assert hex - assert decimal --- TODO: Broken in #2418 should be fixed after #2434 is fixed --- assert surrogatePair + assert' "single-character escape sequences" singleCharacter + assert' "hex escape sequences" hex + assert' "decimal escape sequences" decimal + assert' "astral code points are represented as a UTF-16 surrogate pair" surrogatePair + assert' "lone surrogates may be combined into a surrogate pair" loneSurrogates + assert' "lone surrogates may be combined out of order to remain lone surrogates" outOfOrderSurrogates + -- assert' "lone surrogates are not replaced with the Unicode replacement character U+FFFD" notReplacing log "Done" diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index fd6cea8e63..e07b5aba74 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -40,7 +40,7 @@ properToJs name -- Test if a string is a valid JS identifier without escaping. -- identNeedsEscaping :: Text -> Bool -identNeedsEscaping s = s /= identToJs (Ident s) || T.null s +identNeedsEscaping s = s /= properToJs s || T.null s -- | -- Attempts to find a human-readable name for a symbol, if none has been specified returns the diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 3382ea2c2c..cbe90f5f41 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -248,11 +248,28 @@ parseToken = P.choice symbolChar :: Lexer u Char symbolChar = P.satisfy isSymbolChar + surrogates :: Char -> (Char, Char) + surrogates c = (high, low) + where + (h, l) = divMod (fromEnum c - 0x10000) 0x400 + high = toEnum (h + 0xD800) + low = toEnum (l + 0xDC00) + + expandAstralCodePointToUTF16Surrogates :: Char -> [Char] + expandAstralCodePointToUTF16Surrogates c | fromEnum c > 0xFFFF = [high, low] + where (high, low) = surrogates c + expandAstralCodePointToUTF16Surrogates c = [c] + parseCharLiteral :: Lexer u Char - parseCharLiteral = PT.charLiteral tokenParser + parseCharLiteral = P.try $ do { + c <- PT.charLiteral tokenParser; + if fromEnum c > 0xFFFF + then P.unexpected "astral code point in character literal; characters must be valid UTF-16 code units" + else return c + } parseStringLiteral :: Lexer u Text - parseStringLiteral = blockString <|> T.pack <$> PT.stringLiteral tokenParser + parseStringLiteral = blockString <|> T.pack <$> concatMap expandAstralCodePointToUTF16Surrogates <$> PT.stringLiteral tokenParser where delimiter = P.try (P.string "\"\"\"") blockString = delimiter *> (T.pack <$> P.manyTill P.anyChar delimiter) diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 3280b9cd8a..d142873f9a 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -59,7 +59,7 @@ literals = mkPattern' match' ] where objectPropertyToString :: (Emit gen) => Text -> gen - objectPropertyToString s | identNeedsEscaping s = emit $ T.pack $ show s + objectPropertyToString s | identNeedsEscaping s = string s | otherwise = emit s match (JSBlock _ sts) = mconcat <$> sequence [ return $ emit "{\n" @@ -162,11 +162,9 @@ string s = emit $ "\"" <> T.concatMap encodeChar s <> "\"" encodeChar '\r' = "\\r" encodeChar '"' = "\\\"" encodeChar '\\' = "\\\\" - encodeChar c | fromEnum c > 0xFFFF = "\\u" <> showHex' highSurrogate ("\\u" ++ showHex lowSurrogate "") - where - (h, l) = divMod (fromEnum c - 0x10000) 0x400 - highSurrogate = h + 0xD800 - lowSurrogate = l + 0xDC00 + -- PureScript strings are sequences of UTF-16 code units, so this case should never be hit. + -- If it is somehow hit, though, output the designated Unicode replacement character U+FFFD. + encodeChar c | fromEnum c > 0xFFFF = "\\uFFFD" encodeChar c | fromEnum c > 0xFFF = "\\u" <> showHex' (fromEnum c) "" encodeChar c | fromEnum c > 0xFF = "\\u0" <> showHex' (fromEnum c) "" encodeChar c | fromEnum c < 0x10 = "\\x0" <> showHex' (fromEnum c) "" From 599d49e8aa4fd7d9515b993ad65f81b94bf1ceb8 Mon Sep 17 00:00:00 2001 From: Andy Arvanitis Date: Sat, 10 Dec 2016 17:18:57 -0800 Subject: [PATCH 0568/1580] psc-package: display full path in 'packages.json does not exist' error message --- psc-package/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/psc-package/Main.hs b/psc-package/Main.hs index 2a1e3192f3..b6b7943851 100644 --- a/psc-package/Main.hs +++ b/psc-package/Main.hs @@ -119,7 +119,7 @@ readPackageSet PackageConfig{ set } = do let dbFile = ".psc-package" fromText set ".set" "packages.json" exists <- testfile dbFile unless exists $ do - echo "packages.json does not exist" + echo $ format (fp%" does not exist") dbFile exit (ExitFailure 1) mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile case mdb of From 4c792a12e3e624794be5a775f39434b88a51557c Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 10 Dec 2016 18:32:18 -0800 Subject: [PATCH 0569/1580] 0.10.3 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 3ea8f55367..d39f3feafe 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.10.2 +version: 0.10.3 cabal-version: >=1.8 build-type: Simple license: BSD3 From 4248ad1f29810a1772be1ab5f3c2e070ab765d5c Mon Sep 17 00:00:00 2001 From: Seungha Kim Date: Fri, 16 Dec 2016 05:49:33 +0900 Subject: [PATCH 0570/1580] Update websocket host in psci interactive (#2483) * Update websocket host in psci interactive host 0.0.0.0 do not work on Windows * Fix CONTRIBUTORS.md --- CONTRIBUTORS.md | 1 + psci/static/index.js | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index d4e6edf9fb..192f9529eb 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -86,6 +86,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@brandonhamilton](https://github.com/brandonhamilton) (Brandon Hamilton) My existing contributions and all future contributions until further notice are Copyright Brandon Hamilton, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@bbqbaron](https://github.com/bbqbaron) (Eric Loren) My existing contributions and all future contributions until further notice are Copyright Eric Loren, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@RyanGlScott](https://github.com/RyanGlScott) (Ryan Scott) My existing contributions and all future contributions until further notice are Copyright Ryan Scott, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@seungha-kim](https://github.com/seungha-kim) (Seungha Kim) My existing contributions and all future contributions until further notice are Copyright Seungha Kim, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/psci/static/index.js b/psci/static/index.js index 08b5f1ea19..e6ea3eac2b 100644 --- a/psci/static/index.js +++ b/psci/static/index.js @@ -34,7 +34,7 @@ var evaluate = function evaluate(js) { return buffer.join('\n'); }; window.onload = function() { - var socket = new WebSocket('ws://0.0.0.0:' + location.port); + var socket = new WebSocket('ws://localhost:' + location.port); var evalNext = function reload() { get('js/latest.js', function(response) { try { From 612585a161f6ee2c1af10e74899767e66fb8b5b4 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sat, 17 Dec 2016 18:30:01 +0000 Subject: [PATCH 0571/1580] Update links to wiki (#2476) --- src/Language/PureScript/Errors.hs | 14 +++++++------- src/Language/PureScript/Errors/JSON.hs | 2 +- src/Language/PureScript/Interactive/Message.hs | 6 +++--- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 40ee52100e..c4509f7dc9 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -289,8 +289,8 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gTypeSearch (TSBefore env) = pure (TSBefore env) gTypeSearch (TSAfter result) = TSAfter <$> traverse (traverse f) result -wikiUri :: ErrorMessage -> Text -wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" <> errorCode e +errorDocUri :: ErrorMessage -> Text +errorDocUri e = "https://github.com/purescript/documentation/blob/master/errors/" <> errorCode e <> ".md" -- TODO Other possible suggestions: -- WildcardInferredType - source span not small enough @@ -373,7 +373,7 @@ data PPEOptions = PPEOptions { ppeCodeColor :: Maybe (ANSI.ColorIntensity, ANSI.Color) -- ^ Color code with this color... or not , ppeFull :: Bool -- ^ Should write a full error message? , ppeLevel :: Level -- ^ Should this report an error or a warning? - , ppeShowWiki :: Bool -- ^ Should show a link to error message's wiki page? + , ppeShowDocs :: Bool -- ^ Should show a link to error message's doc page? } -- | Default options for PPEOptions @@ -382,7 +382,7 @@ defaultPPEOptions = PPEOptions { ppeCodeColor = Just defaultCodeColor , ppeFull = False , ppeLevel = Error - , ppeShowWiki = True + , ppeShowDocs = True } @@ -390,7 +390,7 @@ defaultPPEOptions = PPEOptions -- Pretty print a single error, simplifying if necessary -- prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box -prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalState defaultUnknownMap $ do +prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalState defaultUnknownMap $ do em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) um <- get return (prettyPrintErrorMessage um em) @@ -405,10 +405,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS ] ++ maybe [] (return . Box.moveDown 1) typeInformation ++ [ Box.moveDown 1 $ paras - [ line $ "See " <> wikiUri e <> " for more information, " + [ line $ "See " <> errorDocUri e <> " for more information, " , line $ "or to contribute content related to this " <> levelText <> "." ] - | showWiki + | showDocs ] where typeInformation :: Maybe Box.Box diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index 8b0eadc9fb..c7f085cef1 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -52,7 +52,7 @@ toJSONError verbose level e = JSONError (toErrorPosition <$> sspan) (P.renderBox (P.prettyPrintSingleError (P.PPEOptions Nothing verbose level False) (P.stripModuleAndSpan e))) (P.errorCode e) - (P.wikiUri e) + (P.errorDocUri e) (P.spanName <$> sspan) (P.runModuleName <$> P.errorModule e) (toSuggestion e) diff --git a/src/Language/PureScript/Interactive/Message.hs b/src/Language/PureScript/Interactive/Message.hs index 97ef4cb2fb..e340da1471 100644 --- a/src/Language/PureScript/Interactive/Message.hs +++ b/src/Language/PureScript/Interactive/Message.hs @@ -27,8 +27,8 @@ helpMessage = "The following commands are available:\n\n " ++ ] extraHelp = - "Further information is available on the PureScript wiki:\n" ++ - " --> https://github.com/purescript/purescript/wiki/psci" + "Further information is available on the PureScript documentation repository:\n" ++ + " --> https://github.com/purescript/documentation/blob/master/PSCi.md" -- | The welcome prologue. prologueMessage :: String @@ -48,7 +48,7 @@ supportModuleMessage = unlines , "" , " psc-package install psci-support" , "" - , "For help getting started, visit http://wiki.purescript.org/PSCi" + , "For help getting started, visit https://github.com/purescript/documentation/blob/master/PSCi.md" ] -- | The quit message. From 92b5f53f382b53fb7b40dcaccb84d96b1411cd9f Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Tue, 20 Dec 2016 21:11:03 +0000 Subject: [PATCH 0572/1580] Unwrap KindedType when instance solving --- examples/passing/EntailsKindedType.purs | 11 +++++++++++ src/Language/PureScript/TypeChecker/Entailment.hs | 10 ++++++++++ 2 files changed, 21 insertions(+) create mode 100644 examples/passing/EntailsKindedType.purs diff --git a/examples/passing/EntailsKindedType.purs b/examples/passing/EntailsKindedType.purs new file mode 100644 index 0000000000..cd2489a9f6 --- /dev/null +++ b/examples/passing/EntailsKindedType.purs @@ -0,0 +1,11 @@ +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console + +test x = show (x :: _ :: *) + +main = do + when (show (unit :: Unit :: *) == "unit") (log "Done") + when (test unit == "unit") (log "Done") diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index a857cdf723..85c5326dff 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -146,6 +146,7 @@ entails SolverOptions{..} constraint context hints = ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn ctorModules (TypeConstructor (Qualified Nothing _)) = internalError "ctorModules: unqualified type name" ctorModules (TypeApp ty _) = ctorModules ty + ctorModules (KindedType ty _) = ctorModules ty ctorModules _ = Nothing findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDict] @@ -266,6 +267,7 @@ entails SolverOptions{..} constraint context hints = canBeGeneralized :: Type -> Bool canBeGeneralized TUnknown{} = True + canBeGeneralized (KindedType t _) = canBeGeneralized t canBeGeneralized _ = False -- | @@ -346,6 +348,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do -- and return a substitution from type variables to types which makes the type heads unify. -- typeHeadsAreEqual :: Type -> Type -> (Bool, Matching [Type]) + typeHeadsAreEqual (KindedType t1 _) t2 = typeHeadsAreEqual t1 t2 + typeHeadsAreEqual t1 (KindedType t2 _) = typeHeadsAreEqual t1 t2 typeHeadsAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = (True, M.empty) typeHeadsAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = (True, M.empty) typeHeadsAreEqual t (TypeVar v) = (True, M.singleton v [t]) @@ -365,6 +369,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> (Bool, Matching [Type]) + go l (KindedType t1 _) r t2 = go l t1 r t2 + go l t1 r (KindedType t2 _) = go l t1 r t2 go [] REmpty [] REmpty = (True, M.empty) go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = (True, M.empty) go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = (True, M.empty) @@ -386,6 +392,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do -- which was _not_ solved, i.e. one which was inferred by a functional -- dependency. typesAreEqual :: Type -> Type -> Bool + typesAreEqual (KindedType t1 _) t2 = typesAreEqual t1 t2 + typesAreEqual t1 (KindedType t2 _) = typesAreEqual t1 t2 typesAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = True typesAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2 typesAreEqual (TypeVar v1) (TypeVar v2) = v1 == v2 @@ -403,6 +411,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2' where go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> Bool + go l (KindedType t1 _) r t2 = go l t1 r t2 + go l t1 r (KindedType t2 _) = go l t1 r t2 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2 go [] REmpty [] REmpty = True From f05dfc488f6734145168dbc703fe5612553a6d45 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 22 Dec 2016 23:25:34 +0000 Subject: [PATCH 0573/1580] Fix version bounds on language-javascript The JSAnnotSpace constructor was introduced in 0.6.0.9 and therefore this should be the lower bound. --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index d39f3feafe..4efe8837e9 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -124,7 +124,7 @@ library haskeline >= 0.7.0.0, http-client >= 0.4.30 && <0.5, http-types -any, - language-javascript == 0.6.*, + language-javascript >= 0.6.0.9 && < 0.7, lens == 4.*, lifted-base >= 0.2.3 && < 0.2.4, monad-control >= 1.0.0.0 && < 1.1, From d214e2e1d50dd64eb7e534d55d433850780c69e2 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 22 Dec 2016 20:39:01 -0800 Subject: [PATCH 0574/1580] Fix some issues with the pretty printer, fix #2039 --- src/Language/PureScript/Pretty/Values.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 72b17343fd..14838c5abf 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -54,15 +54,15 @@ prettyPrintValue d (IfThenElse cond th el) = // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th , text "else " <> prettyPrintValueAtom (d - 1) el ]) -prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> textT ("." Monoid.<> prettyPrintObjectKey prop) -prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> textT (key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps +prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop) +prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (\(key, val) -> textT (key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) = text (T.unpack (runProperName (disqualify className)) ++ " ") <> prettyPrintValueAtom (d - 1) ps prettyPrintValue d (Case values binders) = - (text "case " <> foldl1 beforeWithSpace (map (prettyPrintValueAtom (d - 1)) values) <> text " of") // + (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) // moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders)) prettyPrintValue d (Let ds val) = text "let" // @@ -96,7 +96,7 @@ prettyPrintValueAtom d (BinaryNoParens op lhs rhs) = prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs where printOp (Op (Qualified _ name)) = text $ T.unpack $ runOpName name - printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`" + printOp expr = text "`" <> prettyPrintValue (d - 1) expr `before` text "`" prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val prettyPrintValueAtom d (Parens expr) = (text "(" <> prettyPrintValue d expr) `before` text ")" From a1e22ec6d8b5e10d56237b5fcfdbcdd06b03a87c Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 24 Dec 2016 02:55:46 +0000 Subject: [PATCH 0575/1580] Add Prim docs to the library, resolves #2494 (#2498) * Add Prim docs to the library, resolves #2494 * Use 'a' in the Char example * Link to placeholder documentation page --- purescript.cabal | 2 + src/Language/PureScript/Docs.hs | 1 + .../PureScript/Docs/Convert/Single.hs | 19 +- src/Language/PureScript/Docs/Prim.hs | 205 ++++++++++++++++++ src/Language/PureScript/Docs/Types.hs | 21 ++ tests/Main.hs | 2 + tests/TestPrimDocs.hs | 27 +++ 7 files changed, 259 insertions(+), 18 deletions(-) create mode 100644 src/Language/PureScript/Docs/Prim.hs create mode 100644 tests/TestPrimDocs.hs diff --git a/purescript.cabal b/purescript.cabal index 4efe8837e9..eeeae986b3 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -250,6 +250,7 @@ library Language.PureScript.Docs.Convert Language.PureScript.Docs.Convert.Single Language.PureScript.Docs.Convert.ReExports + Language.PureScript.Docs.Prim Language.PureScript.Docs.Render Language.PureScript.Docs.Types Language.PureScript.Docs.RenderedCode @@ -539,6 +540,7 @@ test-suite tests other-modules: TestUtils TestCompiler TestDocs + TestPrimDocs TestPscPublish TestPsci TestPscIde diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs index 9297000d8d..9f368740c4 100644 --- a/src/Language/PureScript/Docs.hs +++ b/src/Language/PureScript/Docs.hs @@ -7,6 +7,7 @@ module Language.PureScript.Docs ( ) where import Language.PureScript.Docs.Convert as Docs +import Language.PureScript.Docs.Prim as Docs import Language.PureScript.Docs.ParseAndBookmark as Docs import Language.PureScript.Docs.Render as Docs import Language.PureScript.Docs.RenderedCode.Render as Docs diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 074356001a..c6d630011d 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -9,14 +9,12 @@ import Control.Arrow (first) import Control.Category ((>>>)) import Control.Monad -import Data.Bifunctor (bimap) import Data.Either import Data.List (nub) import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Vector as V import Language.PureScript.Docs.Types import qualified Language.PureScript as P @@ -132,7 +130,7 @@ convertDeclaration (P.TypeSynonymDeclaration _ args ty) title = convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title = Just (Right (mkDeclaration title info) { declChildren = children }) where - info = TypeClassDeclaration (map (first T.unpack) args) implies (map (bimap (map T.unpack) (map T.unpack)) fundeps') + info = TypeClassDeclaration (map (first T.unpack) args) implies (convertFundepsToStrings args fundeps) children = map convertClassMember ds convertClassMember (P.PositionedDeclaration _ _ d) = convertClassMember d @@ -140,21 +138,6 @@ convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title = ChildDeclaration (T.unpack (P.showIdent ident')) Nothing Nothing (ChildTypeClassMember ty) convertClassMember _ = P.internalError "convertDeclaration: Invalid argument to convertClassMember." - fundeps' = map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps - where - argsVec = V.fromList (map fst args) - getArg i = - maybe - (P.internalError $ unlines - [ "convertDeclaration: Functional dependency index" - , show i - , "is bigger than arguments list" - , show (map fst args) - , "Functional dependencies are" - , show fundeps - ] - ) id $ argsVec V.!? i - toArgs from to = (map getArg from, map getArg to) convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = Just (Left (T.unpack classNameString : map T.unpack typeNameStrings, AugmentChild childDecl)) where diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs new file mode 100644 index 0000000000..845073799a --- /dev/null +++ b/src/Language/PureScript/Docs/Prim.hs @@ -0,0 +1,205 @@ +-- | This module provides documentation for the builtin Prim module. +module Language.PureScript.Docs.Prim (primDocsModule) where + +import Prelude.Compat hiding (fail) +import Control.Arrow (first) +import qualified Data.Text as T +import qualified Data.Map as Map +import Language.PureScript.Docs.Types +import qualified Language.PureScript as P + +primDocsModule :: Module +primDocsModule = Module + { modName = P.moduleNameFromString "Prim" + , modComments = Just "The Prim module is embedded in the PureScript compiler in order to provide compiler support for certain types — for example, value literals, or syntax sugar." + , modDeclarations = + [ function + , array + , record + , number + , int + , string + , char + , boolean + , partial + , fail + , typeConcat + , typeString + ] + , modReExports = [] + } + +unsafeLookup :: forall v (a :: P.ProperNameType). + Map.Map (P.Qualified (P.ProperName a)) v -> String -> String -> v +unsafeLookup m errorMsg ty = go ty + where + go = fromJust' . flip Map.lookup m . P.primName . T.pack + + fromJust' (Just x) = x + fromJust' _ = P.internalError $ errorMsg ++ ty + +lookupPrimKind :: String -> P.Kind +lookupPrimKind = fst . unsafeLookup P.primTypes "Docs.Prim: No such Prim type: " + +primType :: String -> String -> Declaration +primType title comments = Declaration + { declTitle = title + , declComments = Just comments + , declSourceSpan = Nothing + , declChildren = [] + , declInfo = ExternDataDeclaration (lookupPrimKind title) + } + +-- | Lookup the TypeClassData of a Prim class. This function is specifically +-- not exported because it is partial. +lookupPrimClass :: String -> P.TypeClassData +lookupPrimClass = unsafeLookup P.primClasses "Docs.Prim: No such Prim class: " + +primClass :: String -> String -> Declaration +primClass title comments = Declaration + { declTitle = title + , declComments = Just comments + , declSourceSpan = Nothing + , declChildren = [] + , declInfo = + let + tcd = lookupPrimClass title + args = P.typeClassArguments tcd + superclasses = P.typeClassSuperclasses tcd + fundeps = convertFundepsToStrings args (P.typeClassDependencies tcd) + in + TypeClassDeclaration (map (first T.unpack) args) superclasses fundeps + } + +function :: Declaration +function = primType "Function" $ unlines + [ "A function, which takes values of the type specified by the first type" + , "parameter, and returns values of the type specified by the second." + , "In the JavaScript backend, this is a standard JavaScript Function." + , "" + , "The type constructor `(->)` is syntactic sugar for this type constructor." + , "It is recommended to use `(->)` rather than `Function`, where possible." + , "" + , "That is, prefer this:" + , "" + , " f :: Number -> Number" + , "" + , "to either of these:" + , "" + , " f :: Function Number Number" + , " f :: (->) Number Number" + ] + +array :: Declaration +array = primType "Array" $ unlines + [ "An Array: a data structure supporting efficient random access. In" + , "the JavaScript backend, values of this type are represented as JavaScript" + , "Arrays at runtime." + , "" + , "Construct values using literals:" + , "" + , " x = [1,2,3,4,5] :: Array Int" + ] + +record :: Declaration +record = primType "Record" $ unlines + [ "The type of records whose fields are known at compile time. In the" + , "JavaScript backend, values of this type are represented as JavaScript" + , "Objects at runtime." + , "" + , "The type signature here means that the `Record` type constructor takes" + , "a row of concrete types. For example:" + , "" + , " type Person = Record (name :: String, age :: Number)" + , "" + , "The syntactic sugar with curly braces `{ }` is generally preferred, though:" + , "" + , " type Person = { name :: String, age :: Number }" + ] + +number :: Declaration +number = primType "Number" $ unlines + [ "A double precision floating point number (IEEE 754)." + , "" + , "Construct values of this type with literals:" + , "" + , " y = 35.23 :: Number" + , " z = 1.224e6 :: Number" + ] + +int :: Declaration +int = primType "Int" $ unlines + [ "A 32-bit signed integer. See the purescript-integers package for details" + , "of how this is accomplished when compiling to JavaScript." + , "" + , "Construct values of this type with literals:" + , "" + , " x = 23 :: Int" + ] + +string :: Declaration +string = primType "String" $ unlines + [ "A String. As in JavaScript, String values represent sequences of UTF-16" + , "code units, which are not required to form a valid encoding of Unicode" + , "text (for example, lone surrogates are permitted)." + , "" + , "Construct values of this type with literals, using double quotes `\"`:" + , "" + , " x = \"hello, world\" :: String" + , "" + , "Multi-line string literals are also supported with triple quotes (`\"\"\"`)." + ] + +char :: Declaration +char = primType "Char" $ unlines + [ "A single character (UTF-16 code unit). The JavaScript representation is a" + , "normal String, which is guaranteed to contain one code unit. This means" + , "that astral plane characters (i.e. those with code point values greater" + , "than 0xFFFF) cannot be represented as Char values." + , "" + , "Construct values of this type with literals, using single quotes `'`:" + , "" + , " x = 'a' :: Char" + ] + +boolean :: Declaration +boolean = primType "Boolean" $ unlines + [ "A JavaScript Boolean value." + , "" + , "Construct values of this type with the literals `true` and `false`." + ] + +partial :: Declaration +partial = primClass "Partial" $ unlines + [ "The Partial type class is used to indicate that a function is *partial,*" + , "that is, it will throw an error for some inputs. For more information," + , "see [the Partial type class guide](https://github.com/purescript/documentation/blob/master/guides/The-Partial-type-class.md)." + ] + +fail :: Declaration +fail = primClass "Fail" $ unlines + [ "The Fail type class is part of the custom type errors feature. To provide" + , "a custom type error when someone tries to use a particular instance," + , "write that instance out with a Fail constraint." + , "" + , "For more information, see" + , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." + ] + +typeConcat :: Declaration +typeConcat = primType "TypeConcat" $ unlines + [ "The TypeConcat type constructor concatenates two Symbols in a custom type" + , "error." + , "" + , "For more information, see" + , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." + ] + +typeString :: Declaration +typeString = primType "TypeString" $ unlines + [ "The TypeString type constructor renders any concrete type into a Symbol" + , "in a custom type error." + , "" + , "For more information, see" + , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." + ] diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 506d24cee7..5de0b1a4a0 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -9,6 +9,7 @@ import Prelude.Compat import Control.Arrow (first, (***)) import Control.Monad (when) +import Data.Bifunctor (bimap) import Data.Aeson ((.=)) import Data.Aeson.BetterErrors import Data.ByteString.Lazy (ByteString) @@ -16,6 +17,7 @@ import Data.Either (isLeft, isRight) import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Version +import qualified Data.Vector as V import qualified Data.Aeson as A import qualified Data.Text as T @@ -132,6 +134,25 @@ data DeclarationInfo | AliasDeclaration P.Fixity FixityAlias deriving (Show, Eq, Ord) +convertFundepsToStrings :: [(Text, Maybe P.Kind)] -> [P.FunctionalDependency] -> [([String], [String])] +convertFundepsToStrings args fundeps = + map (bimap (map T.unpack) (map T.unpack)) fundeps' + where + fundeps' = map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps + argsVec = V.fromList (map fst args) + getArg i = + maybe + (P.internalError $ unlines + [ "convertDeclaration: Functional dependency index" + , show i + , "is bigger than arguments list" + , show (map fst args) + , "Functional dependencies are" + , show fundeps + ] + ) id $ argsVec V.!? i + toArgs from to = (map getArg from, map getArg to) + type FixityAlias = P.Qualified (Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))) declInfoToString :: DeclarationInfo -> String diff --git a/tests/Main.hs b/tests/Main.hs index 61d1824e35..acfce36647 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -13,6 +13,7 @@ import qualified TestDocs import qualified TestPsci import qualified TestPscIde import qualified TestPscPublish +import qualified TestPrimDocs import qualified TestUtils import System.IO (hSetEncoding, stdout, stderr, utf8) @@ -28,6 +29,7 @@ main = do TestCompiler.main heading "Documentation test suite" TestDocs.main + TestPrimDocs.main heading "psc-publish test suite" TestPscPublish.main heading "psci test suite" diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs new file mode 100644 index 0000000000..ba73ed7e60 --- /dev/null +++ b/tests/TestPrimDocs.hs @@ -0,0 +1,27 @@ +module TestPrimDocs where + +import Control.Monad +import Data.List ((\\)) +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Language.PureScript as P +import qualified Language.PureScript.Docs as D +import qualified Language.PureScript.Docs.AsMarkdown as D + +main :: IO () +main = do + putStrLn "Test that there are no bottoms hiding in primDocsModule" + seq (T.pack (D.runDocs (D.modulesAsMarkdown [D.primDocsModule]))) (return ()) + + putStrLn "Test that Prim is fully documented" + let actualPrimTypes = map (P.runProperName . P.disqualify . fst) $ Map.toList P.primTypes + let documentedPrimTypes = map (T.pack . D.declTitle) (D.modDeclarations D.primDocsModule) + + let undocumentedTypes = actualPrimTypes \\ documentedPrimTypes + let extraTypes = documentedPrimTypes \\ actualPrimTypes + + when (not (null undocumentedTypes)) $ + error $ "Undocumented Prim types: " ++ show undocumentedTypes + + when (not (null extraTypes)) $ + error $ "Extra Prim types: " ++ show undocumentedTypes From 062f13820e77a2bfc66183c6397fe30676689af8 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 24 Dec 2016 15:11:23 +0000 Subject: [PATCH 0576/1580] Add upper bound on turtle, fixes #2472 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index eeeae986b3..bfc7aa26f0 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -427,7 +427,7 @@ executable psc-package optparse-applicative -any, system-filepath -any, text -any, - turtle -any + turtle <1.3 main-is: Main.hs other-modules: Paths_purescript buildable: True From b3c889bde98e345552b9ddd4c756f975aaa03cc6 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 24 Dec 2016 15:44:44 +0000 Subject: [PATCH 0577/1580] Update docs for the Partial type class --- src/Language/PureScript/Docs/Prim.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 845073799a..b63c64145b 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -172,8 +172,11 @@ boolean = primType "Boolean" $ unlines partial :: Declaration partial = primClass "Partial" $ unlines [ "The Partial type class is used to indicate that a function is *partial,*" - , "that is, it will throw an error for some inputs. For more information," - , "see [the Partial type class guide](https://github.com/purescript/documentation/blob/master/guides/The-Partial-type-class.md)." + , "that is, it is not defined for all inputs. In practice, attempting to use" + , "a partial function with a bad input will usually cause an error to be" + , "thrown, although it is not safe to assume that this will happen in all" + , "cases. For more information, see" + , "[the Partial type class guide](https://github.com/purescript/documentation/blob/master/guides/The-Partial-type-class.md)." ] fail :: Declaration From 1c5a43120ba9f24c22b6aae0b0869643782c5534 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 24 Dec 2016 23:19:47 +0000 Subject: [PATCH 0578/1580] Further conversions to Text in Docs modules (#2502) * Further conversions to Text in Docs modules * Test leading whitespace is preserved in doc comments * Preserve leading whitespace in doc comments --- examples/docs/src/DocComments.purs | 11 ++ psc-docs/Main.hs | 9 +- psc-publish/Main.hs | 1 + src/Language/PureScript/Docs/AsMarkdown.hs | 34 ++-- src/Language/PureScript/Docs/Convert.hs | 6 +- .../PureScript/Docs/Convert/ReExports.hs | 35 ++-- .../PureScript/Docs/Convert/Single.hs | 57 +++---- src/Language/PureScript/Docs/Prim.hs | 44 ++--- src/Language/PureScript/Docs/Render.hs | 29 ++-- .../PureScript/Docs/RenderedCode/Render.hs | 23 ++- .../PureScript/Docs/RenderedCode/Types.hs | 42 ++--- src/Language/PureScript/Docs/Types.hs | 90 +++++------ src/Language/PureScript/Publish.hs | 46 +++--- .../PureScript/Publish/ErrorsWarnings.hs | 9 +- tests/TestDocs.hs | 153 ++++++++++-------- tests/TestPrimDocs.hs | 5 +- tests/TestPscPublish.hs | 12 +- 17 files changed, 308 insertions(+), 298 deletions(-) create mode 100644 examples/docs/src/DocComments.purs diff --git a/examples/docs/src/DocComments.purs b/examples/docs/src/DocComments.purs new file mode 100644 index 0000000000..4bc2e93953 --- /dev/null +++ b/examples/docs/src/DocComments.purs @@ -0,0 +1,11 @@ +module DocComments where + +-- | This declaration has a code block: +-- | +-- | example == 0 +-- | +-- | Here we are really testing that the leading whitespace is not stripped, as +-- | this ensures that we don't accidentally change code blocks into normal +-- | paragraphs. +example :: Int +example = 0 diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index ff557bc7d1..a1ca8ec3cd 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -9,6 +9,7 @@ import Control.Category ((>>>)) import Control.Monad.Writer import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.IO as T import Data.Function (on) import Data.List import Data.Maybe (fromMaybe) @@ -22,7 +23,7 @@ import qualified Language.PureScript as P import qualified Paths_purescript as Paths import System.Exit (exitFailure) import System.IO (hPutStrLn, hPrint, hSetEncoding, stderr, stdout, utf8) -import System.IO.UTF8 (readUTF8FileT) +import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) import System.FilePath.Glob (glob) @@ -65,11 +66,11 @@ docgen (PSCDocsOptions fmt inputGlob output) = do case output of EverythingToStdOut -> - putStrLn (D.runDocs (D.modulesAsMarkdown ms)) + T.putStrLn (D.runDocs (D.modulesAsMarkdown ms)) ToStdOut names -> do let (ms', missing) = takeByName ms names guardMissing missing - putStrLn (D.runDocs (D.modulesAsMarkdown ms')) + T.putStrLn (D.runDocs (D.modulesAsMarkdown ms')) ToFiles names -> do let (ms', missing) = takeByName' ms names guardMissing missing @@ -78,7 +79,7 @@ docgen (PSCDocsOptions fmt inputGlob output) = do forM_ ms'' $ \grp -> do let fp = fst (head grp) createDirectoryIfMissing True (takeDirectory fp) - writeFile fp (D.runDocs (D.modulesAsMarkdown (map snd grp))) + writeUTF8FileT fp (D.runDocs (D.modulesAsMarkdown (map snd grp))) where guardMissing [] = return () diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs index dd8f6632fb..5d2e902bd2 100644 --- a/psc-publish/Main.hs +++ b/psc-publish/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Main where diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index a336030108..527ca53036 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -13,7 +13,9 @@ import Control.Monad.Error.Class (MonadError) import Control.Monad.Writer (Writer, tell, execWriter) import Data.Foldable (for_) +import Data.Monoid ((<>)) import Data.List (partition) +import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Docs.RenderedCode @@ -24,12 +26,12 @@ import qualified Language.PureScript.Docs.Render as Render -- | -- Take a list of modules and render them all in order, returning a single --- Markdown-formatted String. +-- Markdown-formatted Text. -- renderModulesAsMarkdown :: (MonadError P.MultipleErrors m) => [P.Module] -> - m String + m Text renderModulesAsMarkdown = fmap (runDocs . modulesAsMarkdown) . Convert.convertModules @@ -38,13 +40,13 @@ modulesAsMarkdown = mapM_ moduleAsMarkdown moduleAsMarkdown :: Module -> Docs moduleAsMarkdown Module{..} = do - headerLevel 2 $ "Module " ++ T.unpack (P.runModuleName modName) + headerLevel 2 $ "Module " <> P.runModuleName modName spacer for_ modComments tell' mapM_ (declAsMarkdown modName) modDeclarations spacer for_ modReExports $ \(mn, decls) -> do - headerLevel 3 $ "Re-exported from " ++ T.unpack (P.runModuleName mn) ++ ":" + headerLevel 3 $ "Re-exported from " <> P.runModuleName mn <> ":" spacer mapM_ (declAsMarkdown mn) decls @@ -71,7 +73,7 @@ declAsMarkdown mn decl@Declaration{..} = do isChildInstance (ChildInstance _ _) = True isChildInstance _ = False -codeToString :: RenderedCode -> String +codeToString :: RenderedCode -> Text codeToString = outputWith elemAsMarkdown where elemAsMarkdown (Syntax x) = x @@ -95,14 +97,14 @@ codeToString = outputWith elemAsMarkdown -- P.Infixr -> "right-associative" -- P.Infix -> "non-associative" -childToString :: First -> ChildDeclaration -> String +childToString :: First -> ChildDeclaration -> Text childToString f decl@ChildDeclaration{..} = case cdeclInfo of ChildDataConstructor _ -> let c = if f == First then "=" else "|" - in " " ++ c ++ " " ++ str + in " " <> c <> " " <> str ChildTypeClassMember _ -> - " " ++ str + " " <> str ChildInstance _ _ -> str where @@ -113,19 +115,19 @@ data First | NotFirst deriving (Show, Eq, Ord) -type Docs = Writer [String] () +type Docs = Writer [Text] () -runDocs :: Docs -> String -runDocs = unlines . execWriter +runDocs :: Docs -> Text +runDocs = T.unlines . execWriter -tell' :: String -> Docs +tell' :: Text -> Docs tell' = tell . (:[]) spacer :: Docs spacer = tell' "" -headerLevel :: Int -> String -> Docs -headerLevel level hdr = tell' (replicate level '#' ++ ' ' : hdr) +headerLevel :: Int -> Text -> Docs +headerLevel level hdr = tell' (T.replicate level "#" <> " " <> hdr) fencedBlock :: Docs -> Docs fencedBlock inner = do @@ -133,5 +135,5 @@ fencedBlock inner = do inner tell' "```" -ticks :: String -> String -ticks = ("`" ++) . (++ "`") +ticks :: Text -> Text +ticks = ("`" <>) . (<> "`") diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 5473cffb2c..34920e7b8d 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -16,7 +16,7 @@ import Control.Monad.Error.Class (MonadError) import Control.Monad.State (runStateT) import Control.Monad.Writer.Strict (runWriterT) import qualified Data.Map as Map -import qualified Data.Text as T +import Data.Text (Text) import Language.PureScript.Docs.Convert.ReExports (updateReExports) import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks) @@ -167,9 +167,9 @@ insertValueTypes env m = err msg = P.internalError ("Docs.Convert.insertValueTypes: " ++ msg) -runParser :: P.TokenParser a -> String -> Either String a +runParser :: P.TokenParser a -> Text -> Either String a runParser p s = either (Left . show) Right $ do - ts <- P.lex "" (T.pack s) + ts <- P.lex "" s P.runTokenParser "" (p <* eof) ts -- | diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index f4fcec2b3e..ee6d379eb6 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -4,7 +4,7 @@ module Language.PureScript.Docs.Convert.ReExports import Prelude.Compat -import Control.Arrow ((&&&), first, second) +import Control.Arrow ((&&&), second) import Control.Monad import Control.Monad.Reader.Class (MonadReader, ask) import Control.Monad.State.Class (MonadState, gets, modify) @@ -16,6 +16,7 @@ import Data.Map (Map) import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) import qualified Data.Map as Map +import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Docs.Types @@ -184,12 +185,12 @@ lookupValueDeclaration :: MonadReader P.ModuleName m) => P.ModuleName -> P.Ident -> - m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration]) + m (P.ModuleName, [Either (Text, P.Constraint, ChildDeclaration) Declaration]) lookupValueDeclaration importedFrom ident = do decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom let rs = - filter (\d -> declTitle d == T.unpack (P.showIdent ident) + filter (\d -> declTitle d == P.showIdent ident && (isValue d || isValueAlias d)) decls errOther other = internalErrorInModule @@ -215,7 +216,7 @@ lookupValueDeclaration importedFrom ident = do (declChildren d)) matchesIdent cdecl = - cdeclTitle cdecl == T.unpack (P.showIdent ident) + cdeclTitle cdecl == P.showIdent ident matchesAndIsTypeClassMember = uncurry (&&) . (matchesIdent &&& isTypeClassMember) @@ -239,7 +240,7 @@ lookupValueOpDeclaration -> m (P.ModuleName, [Declaration]) lookupValueOpDeclaration importedFrom op = do decls <- lookupModuleDeclarations "lookupValueOpDeclaration" importedFrom - case filter (\d -> declTitle d == T.unpack (P.showOp op) && isValueAlias d) decls of + case filter (\d -> declTitle d == P.showOp op && isValueAlias d) decls of [d] -> pure (importedFrom, [d]) other -> @@ -259,7 +260,7 @@ lookupTypeDeclaration :: lookupTypeDeclaration importedFrom ty = do decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom let - ds = filter (\d -> declTitle d == T.unpack (P.runProperName ty) && isType d) decls + ds = filter (\d -> declTitle d == P.runProperName ty && isType d) decls case ds of [d] -> pure (importedFrom, [d]) @@ -275,7 +276,7 @@ lookupTypeOpDeclaration lookupTypeOpDeclaration importedFrom tyOp = do decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom let - ds = filter (\d -> declTitle d == ("type " ++ T.unpack (P.showOp tyOp)) && isTypeAlias d) decls + ds = filter (\d -> declTitle d == ("type " <> P.showOp tyOp) && isTypeAlias d) decls case ds of [d] -> pure (importedFrom, [d]) @@ -291,7 +292,7 @@ lookupTypeClassDeclaration lookupTypeClassDeclaration importedFrom tyClass = do decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom let - ds = filter (\d -> declTitle d == T.unpack (P.runProperName tyClass) + ds = filter (\d -> declTitle d == P.runProperName tyClass && isTypeClass d) decls case ds of @@ -324,7 +325,7 @@ lookupModuleDeclarations definedIn moduleName = do handleTypeClassMembers :: (MonadReader P.ModuleName m) => - Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] -> + Map P.ModuleName [Either (Text, P.Constraint, ChildDeclaration) Declaration] -> Map P.ModuleName [Declaration] -> m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration]) handleTypeClassMembers valsAndMembers typeClasses = @@ -339,7 +340,7 @@ handleTypeClassMembers valsAndMembers typeClasses = |> fmap splitMap valsAndMembersToEnv :: - [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv + [Either (Text, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv valsAndMembersToEnv xs = let (envUnhandledMembers, envValues) = partitionEithers xs envTypeClasses = [] @@ -360,11 +361,11 @@ typeClassesToEnv classes = -- data TypeClassEnv = TypeClassEnv { -- | - -- Type class members which have not yet been dealt with. The String is the + -- Type class members which have not yet been dealt with. The Text is the -- name of the type class they belong to, and the constraint is used to -- make sure that they have the correct type if they get promoted. -- - envUnhandledMembers :: [(String, P.Constraint, ChildDeclaration)] + envUnhandledMembers :: [(Text, P.Constraint, ChildDeclaration)] -- | -- A list of normal value declarations. Type class members will be added to -- this list if their parent type class is not available. @@ -428,7 +429,7 @@ handleEnv TypeClassEnv{..} = _ -> internalErrorInModule ("handleEnv: Bad child declaration passed to promoteChild: " - ++ cdeclTitle) + ++ T.unpack cdeclTitle) addConstraint constraint = P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint] @@ -448,7 +449,7 @@ filterDataConstructors -> Map P.ModuleName [Declaration] -> Map P.ModuleName [Declaration] filterDataConstructors = - filterExportedChildren isDataConstructor (T.unpack . P.runProperName) + filterExportedChildren isDataConstructor P.runProperName -- | -- Given a list of exported type class member names, remove any data @@ -460,12 +461,12 @@ filterTypeClassMembers -> Map P.ModuleName [Declaration] -> Map P.ModuleName [Declaration] filterTypeClassMembers = - filterExportedChildren isTypeClassMember (T.unpack . P.showIdent) + filterExportedChildren isTypeClassMember P.showIdent filterExportedChildren :: (Functor f) => (ChildDeclaration -> Bool) - -> (name -> String) + -> (name -> Text) -> [name] -> f [Declaration] -> f [Declaration] @@ -504,7 +505,7 @@ typeClassConstraintFor :: Declaration -> Maybe P.Constraint typeClassConstraintFor Declaration{..} = case declInfo of TypeClassDeclaration tyArgs _ _ -> - Just (P.Constraint (P.Qualified Nothing (P.ProperName (T.pack declTitle))) (mkConstraint (map (first T.pack) tyArgs)) Nothing) + Just (P.Constraint (P.Qualified Nothing (P.ProperName declTitle)) (mkConstraint tyArgs) Nothing) _ -> Nothing where diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index c6d630011d..c111c18947 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -5,13 +5,12 @@ module Language.PureScript.Docs.Convert.Single import Prelude.Compat -import Control.Arrow (first) import Control.Category ((>>>)) import Control.Monad import Data.Either import Data.List (nub) -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T @@ -19,8 +18,6 @@ import qualified Data.Text as T import Language.PureScript.Docs.Types import qualified Language.PureScript as P --- TODO (Christoph): Get rid of the T.unpack s - -- | -- Convert a single Module, but ignore re-exports; any re-exported types or -- values will not appear in the result. @@ -46,14 +43,14 @@ convertSingleModule m@(P.Module _ coms moduleName _ _) = -- In the second pass, we go over all of the Left values and augment the -- relevant declarations, leaving only the augmented Right values. -- --- Note that in the Left case, we provide a [String] as well as augment --- information. The [String] value should be a list of titles of declarations +-- Note that in the Left case, we provide a [Text] as well as augment +-- information. The [Text] value should be a list of titles of declarations -- that the augmentation should apply to. For example, for a type instance -- declaration, that would be any types or type classes mentioned in the -- instance. For a fixity declaration, it would be just the relevant operator's -- name. type IntermediateDeclaration - = Either ([String], DeclarationAugment) Declaration + = Either ([Text], DeclarationAugment) Declaration -- | Some data which will be used to augment a Declaration in the -- output. @@ -97,7 +94,7 @@ getDeclarationTitle _ = Nothing -- | Create a basic Declaration value. mkDeclaration :: Text -> DeclarationInfo -> Declaration mkDeclaration title info = - Declaration { declTitle = T.unpack title + Declaration { declTitle = title , declComments = Nothing , declSourceSpan = Nothing , declChildren = [] @@ -119,27 +116,27 @@ convertDeclaration (P.ExternDeclaration _ ty) title = convertDeclaration (P.DataDeclaration dtype _ args ctors) title = Just (Right (mkDeclaration title info) { declChildren = children }) where - info = DataDeclaration dtype (map (first T.unpack) args) + info = DataDeclaration dtype args children = map convertCtor ctors convertCtor (ctor', tys) = - ChildDeclaration (T.unpack (P.runProperName ctor')) Nothing Nothing (ChildDataConstructor tys) + ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys) convertDeclaration (P.ExternDataDeclaration _ kind') title = basicDeclaration title (ExternDataDeclaration kind') convertDeclaration (P.TypeSynonymDeclaration _ args ty) title = - basicDeclaration title (TypeSynonymDeclaration (map (first T.unpack) args) ty) + basicDeclaration title (TypeSynonymDeclaration args ty) convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title = Just (Right (mkDeclaration title info) { declChildren = children }) where - info = TypeClassDeclaration (map (first T.unpack) args) implies (convertFundepsToStrings args fundeps) + info = TypeClassDeclaration args implies (convertFundepsToStrings args fundeps) children = map convertClassMember ds convertClassMember (P.PositionedDeclaration _ _ d) = convertClassMember d convertClassMember (P.TypeDeclaration ident' ty) = - ChildDeclaration (T.unpack (P.showIdent ident')) Nothing Nothing (ChildTypeClassMember ty) + ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty) convertClassMember _ = P.internalError "convertDeclaration: Invalid argument to convertClassMember." convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = - Just (Left (T.unpack classNameString : map T.unpack typeNameStrings, AugmentChild childDecl)) + Just (Left (classNameString : typeNameStrings, AugmentChild childDecl)) where classNameString = unQual className typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys) @@ -148,7 +145,7 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit extractProperNames (P.TypeConstructor n) = [unQual n] extractProperNames _ = [] - childDecl = ChildDeclaration (T.unpack title) Nothing Nothing (ChildInstance constraints classApp) + childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title = Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias))) @@ -172,25 +169,24 @@ convertDeclaration (P.PositionedDeclaration srcSpan com d') title = withAugmentChild f (t, AugmentChild d) = (t, AugmentChild (f d)) convertDeclaration _ _ = Nothing -convertComments :: [P.Comment] -> Maybe String +convertComments :: [P.Comment] -> Maybe Text convertComments cs = do let raw = concatMap toLines cs let docs = mapMaybe stripPipe raw guard (not (null docs)) - pure (unlines docs) + pure (T.unlines docs) where - toLines (P.LineComment s) = [T.unpack s] - toLines (P.BlockComment s) = lines (T.unpack s) - - stripPipe s' = - case dropWhile (== ' ') s' of - ('|':' ':s) -> - Just s - ('|':s) -> - Just s - _ -> - Nothing + toLines (P.LineComment s) = [s] + toLines (P.BlockComment s) = T.lines s + + stripPipe = + T.dropWhile (== ' ') + >>> T.stripPrefix "|" + >>> fmap (dropPrefix " ") + + dropPrefix prefix str = + fromMaybe str (T.stripPrefix prefix str) -- | Go through a PureScript module and extract a list of Bookmarks; references -- to data types or values, to be used as a kind of index. These are used for @@ -199,8 +195,7 @@ collectBookmarks :: InPackage P.Module -> [Bookmark] collectBookmarks (Local m) = map Local (collectBookmarks' m) collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m) -collectBookmarks' :: P.Module -> [(P.ModuleName, String)] +collectBookmarks' :: P.Module -> [(P.ModuleName, Text)] collectBookmarks' m = map (P.getModuleName m, ) - (mapMaybe (fmap T.unpack . getDeclarationTitle) - (P.exportedDeclarations m)) + (mapMaybe getDeclarationTitle (P.exportedDeclarations m)) diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index b63c64145b..3724ae5355 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -2,7 +2,7 @@ module Language.PureScript.Docs.Prim (primDocsModule) where import Prelude.Compat hiding (fail) -import Control.Arrow (first) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Map as Map import Language.PureScript.Docs.Types @@ -30,18 +30,18 @@ primDocsModule = Module } unsafeLookup :: forall v (a :: P.ProperNameType). - Map.Map (P.Qualified (P.ProperName a)) v -> String -> String -> v -unsafeLookup m errorMsg ty = go ty + Map.Map (P.Qualified (P.ProperName a)) v -> String -> Text -> v +unsafeLookup m errorMsg name = go name where - go = fromJust' . flip Map.lookup m . P.primName . T.pack + go = fromJust' . flip Map.lookup m . P.primName fromJust' (Just x) = x - fromJust' _ = P.internalError $ errorMsg ++ ty + fromJust' _ = P.internalError $ errorMsg ++ show name -lookupPrimKind :: String -> P.Kind +lookupPrimKind :: Text -> P.Kind lookupPrimKind = fst . unsafeLookup P.primTypes "Docs.Prim: No such Prim type: " -primType :: String -> String -> Declaration +primType :: Text -> Text -> Declaration primType title comments = Declaration { declTitle = title , declComments = Just comments @@ -52,10 +52,10 @@ primType title comments = Declaration -- | Lookup the TypeClassData of a Prim class. This function is specifically -- not exported because it is partial. -lookupPrimClass :: String -> P.TypeClassData +lookupPrimClass :: Text -> P.TypeClassData lookupPrimClass = unsafeLookup P.primClasses "Docs.Prim: No such Prim class: " -primClass :: String -> String -> Declaration +primClass :: Text -> Text -> Declaration primClass title comments = Declaration { declTitle = title , declComments = Just comments @@ -68,11 +68,11 @@ primClass title comments = Declaration superclasses = P.typeClassSuperclasses tcd fundeps = convertFundepsToStrings args (P.typeClassDependencies tcd) in - TypeClassDeclaration (map (first T.unpack) args) superclasses fundeps + TypeClassDeclaration args superclasses fundeps } function :: Declaration -function = primType "Function" $ unlines +function = primType "Function" $ T.unlines [ "A function, which takes values of the type specified by the first type" , "parameter, and returns values of the type specified by the second." , "In the JavaScript backend, this is a standard JavaScript Function." @@ -91,7 +91,7 @@ function = primType "Function" $ unlines ] array :: Declaration -array = primType "Array" $ unlines +array = primType "Array" $ T.unlines [ "An Array: a data structure supporting efficient random access. In" , "the JavaScript backend, values of this type are represented as JavaScript" , "Arrays at runtime." @@ -102,7 +102,7 @@ array = primType "Array" $ unlines ] record :: Declaration -record = primType "Record" $ unlines +record = primType "Record" $ T.unlines [ "The type of records whose fields are known at compile time. In the" , "JavaScript backend, values of this type are represented as JavaScript" , "Objects at runtime." @@ -118,7 +118,7 @@ record = primType "Record" $ unlines ] number :: Declaration -number = primType "Number" $ unlines +number = primType "Number" $ T.unlines [ "A double precision floating point number (IEEE 754)." , "" , "Construct values of this type with literals:" @@ -128,7 +128,7 @@ number = primType "Number" $ unlines ] int :: Declaration -int = primType "Int" $ unlines +int = primType "Int" $ T.unlines [ "A 32-bit signed integer. See the purescript-integers package for details" , "of how this is accomplished when compiling to JavaScript." , "" @@ -138,7 +138,7 @@ int = primType "Int" $ unlines ] string :: Declaration -string = primType "String" $ unlines +string = primType "String" $ T.unlines [ "A String. As in JavaScript, String values represent sequences of UTF-16" , "code units, which are not required to form a valid encoding of Unicode" , "text (for example, lone surrogates are permitted)." @@ -151,7 +151,7 @@ string = primType "String" $ unlines ] char :: Declaration -char = primType "Char" $ unlines +char = primType "Char" $ T.unlines [ "A single character (UTF-16 code unit). The JavaScript representation is a" , "normal String, which is guaranteed to contain one code unit. This means" , "that astral plane characters (i.e. those with code point values greater" @@ -163,14 +163,14 @@ char = primType "Char" $ unlines ] boolean :: Declaration -boolean = primType "Boolean" $ unlines +boolean = primType "Boolean" $ T.unlines [ "A JavaScript Boolean value." , "" , "Construct values of this type with the literals `true` and `false`." ] partial :: Declaration -partial = primClass "Partial" $ unlines +partial = primClass "Partial" $ T.unlines [ "The Partial type class is used to indicate that a function is *partial,*" , "that is, it is not defined for all inputs. In practice, attempting to use" , "a partial function with a bad input will usually cause an error to be" @@ -180,7 +180,7 @@ partial = primClass "Partial" $ unlines ] fail :: Declaration -fail = primClass "Fail" $ unlines +fail = primClass "Fail" $ T.unlines [ "The Fail type class is part of the custom type errors feature. To provide" , "a custom type error when someone tries to use a particular instance," , "write that instance out with a Fail constraint." @@ -190,7 +190,7 @@ fail = primClass "Fail" $ unlines ] typeConcat :: Declaration -typeConcat = primType "TypeConcat" $ unlines +typeConcat = primType "TypeConcat" $ T.unlines [ "The TypeConcat type constructor concatenates two Symbols in a custom type" , "error." , "" @@ -199,7 +199,7 @@ typeConcat = primType "TypeConcat" $ unlines ] typeString :: Declaration -typeString = primType "TypeString" $ unlines +typeString = primType "TypeString" $ T.unlines [ "The TypeString type constructor renders any concrete type into a Symbol" , "in a custom type error." , "" diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 352bff910e..f9fa3a804d 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -13,16 +13,14 @@ import Prelude.Compat import Data.Maybe (maybeToList) import Data.Monoid ((<>)) -import qualified Data.Text as T import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.Docs.RenderedCode import Language.PureScript.Docs.Types import Language.PureScript.Docs.Utils.MonoidExtras import qualified Language.PureScript as P --- TODO (Christoph): get rid of T.unpack's - renderDeclaration :: Declaration -> RenderedCode renderDeclaration = renderDeclarationWithOptions defaultRenderTypeOptions @@ -35,7 +33,7 @@ renderDeclarationWithOptions opts Declaration{..} = , renderType' ty ] DataDeclaration dtype args -> - [ keyword (T.unpack (P.showDataDeclType dtype)) + [ keyword (P.showDataDeclType dtype) , renderType' (typeApp declTitle args) ] ExternDataDeclaration kind' -> @@ -76,7 +74,7 @@ renderDeclarationWithOptions opts Declaration{..} = AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) -> [ keywordFixity associativity - , syntax $ show precedence + , syntax $ T.pack $ show precedence , ident $ renderQualAlias for , keyword "as" , ident $ adjustAliasName alias declTitle @@ -86,10 +84,10 @@ renderDeclarationWithOptions opts Declaration{..} = renderType' :: P.Type -> RenderedCode renderType' = renderTypeWithOptions opts - renderQualAlias :: FixityAlias -> String + renderQualAlias :: FixityAlias -> Text renderQualAlias (P.Qualified mn alias) - | mn == currentModule opts = T.unpack (renderAlias id alias) - | otherwise = T.unpack (renderAlias (\f -> P.showQualified f . P.Qualified mn) alias) + | mn == currentModule opts = renderAlias id alias + | otherwise = renderAlias (\f -> P.showQualified f . P.Qualified mn) alias renderAlias :: (forall a. (a -> Text) -> a -> Text) @@ -99,8 +97,7 @@ renderDeclarationWithOptions opts Declaration{..} = = either (("type " <>) . f P.runProperName) $ either (f P.runIdent) (f P.runProperName) - -- adjustAliasName (P.AliasType{}) title = drop 6 (init title) - adjustAliasName _ title = tail (init title) + adjustAliasName _ title = T.tail (T.init title) renderChildDeclaration :: ChildDeclaration -> RenderedCode renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions @@ -146,15 +143,15 @@ renderConstraintsWithOptions opts constraints mintersperse (syntax "," <> sp) (map (renderConstraintWithOptions opts) constraints) -notQualified :: String -> P.Qualified (P.ProperName a) -notQualified = P.Qualified Nothing . P.ProperName . T.pack +notQualified :: Text -> P.Qualified (P.ProperName a) +notQualified = P.Qualified Nothing . P.ProperName -typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type +typeApp :: Text -> [(Text, Maybe P.Kind)] -> P.Type typeApp title typeArgs = foldl P.TypeApp (P.TypeConstructor (notQualified title)) (map toTypeVar typeArgs) -toTypeVar :: (String, Maybe P.Kind) -> P.Type -toTypeVar (s, Nothing) = P.TypeVar (T.pack s) -toTypeVar (s, Just k) = P.KindedType (P.TypeVar (T.pack s)) k +toTypeVar :: (Text, Maybe P.Kind) -> P.Type +toTypeVar (s, Nothing) = P.TypeVar s +toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index bae5544378..281cd6b2b1 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -14,10 +14,9 @@ import Prelude.Compat import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) -import qualified Data.Text as T import Data.Text (Text) -import Control.Arrow ((<+>), first) +import Control.Arrow ((<+>)) import Control.PatternArrows as PA import Language.PureScript.Crash @@ -35,7 +34,7 @@ typeLiterals = mkPattern match match TypeWildcard{} = Just (syntax "_") match (TypeVar var) = - Just (ident (T.unpack var)) + Just (ident var) match (PrettyPrintObject row) = Just $ mintersperse sp [ syntax "{" @@ -43,7 +42,7 @@ typeLiterals = mkPattern match , syntax "}" ] match (TypeConstructor (Qualified mn name)) = - Just (ctor (T.unpack (runProperName name)) (maybeToContainingModule mn)) + Just (ctor (runProperName name) (maybeToContainingModule mn)) match REmpty = Just (syntax "()") match row@RCons{} = @@ -51,7 +50,7 @@ typeLiterals = mkPattern match match (BinaryNoParensType op l r) = Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r match (TypeOp (Qualified mn op)) = - Just (ident' (T.unpack (runOpName op)) (maybeToContainingModule mn)) + Just (ident' (runOpName op) (maybeToContainingModule mn)) match _ = Nothing @@ -76,16 +75,14 @@ renderConstraints deps ty = -- Render code representing a Row -- renderRow :: Type -> RenderedCode -renderRow = uncurry renderRow' . convertString . rowToList +renderRow = uncurry renderRow' . rowToList where - convertString :: ([(Text, Type)], Type) -> ([(String, Type)], Type) - convertString = first (map (first T.unpack)) renderRow' h t = renderHead h <> renderTail t -renderHead :: [(String, Type)] -> RenderedCode +renderHead :: [(Text, Type)] -> RenderedCode renderHead = mintersperse (syntax "," <> sp) . map renderLabel -renderLabel :: (String, Type) -> RenderedCode +renderLabel :: (Text, Type) -> RenderedCode renderLabel (label, ty) = mintersperse sp [ ident label @@ -145,10 +142,10 @@ matchType = buildPrettyPrinter operators matchTypeAtom , [ Wrap explicitParens $ \_ ty -> ty ] ] -forall_ :: Pattern () Type ([String], Type) +forall_ :: Pattern () Type ([Text], Type) forall_ = mkPattern match where - match (PrettyPrintForAll idents ty) = Just (map T.unpack idents, ty) + match (PrettyPrintForAll idents ty) = Just (idents, ty) match _ = Nothing insertPlaceholders :: RenderTypeOptions -> Type -> Type @@ -180,7 +177,7 @@ preprocessType opts = dePrim . insertPlaceholders opts -- Render code representing a Kind -- renderKind :: Kind -> RenderedCode -renderKind = kind . T.unpack . prettyPrintKind +renderKind = kind . prettyPrintKind -- | -- Render code representing a Type, as it should appear inside parentheses diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 05bd8a1008..074a5a1bc3 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -37,7 +37,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Data.Aeson.BetterErrors import qualified Data.Aeson as A -import qualified Data.Text as T +import Data.Text (Text) import qualified Language.PureScript as P @@ -46,11 +46,11 @@ import qualified Language.PureScript as P -- multiple output formats. For example, plain text, or highlighted HTML. -- data RenderedCodeElement - = Syntax String - | Ident String ContainingModule - | Ctor String ContainingModule - | Kind String - | Keyword String + = Syntax Text + | Ident Text ContainingModule + | Ctor Text ContainingModule + | Kind Text + | Keyword Text | Space deriving (Show, Eq, Ord) @@ -66,9 +66,9 @@ instance A.ToJSON RenderedCodeElement where toJSON (Keyword str) = A.toJSON ["keyword", str] toJSON Space = - A.toJSON ["space" :: String] + A.toJSON ["space" :: Text] -asRenderedCodeElement :: Parse String RenderedCodeElement +asRenderedCodeElement :: Parse Text RenderedCodeElement asRenderedCodeElement = a Syntax "syntax" <|> asIdent <|> @@ -80,14 +80,14 @@ asRenderedCodeElement = where p <|> q = catchError p (const q) - a ctor' ctorStr = ctor' <$> (nth 0 (withString (eq ctorStr)) *> nth 1 asString) - asIdent = nth 0 (withString (eq "ident")) *> (Ident <$> nth 1 asString <*> nth 2 asContainingModule) - asCtor = nth 0 (withString (eq "ctor")) *> (Ctor <$> nth 1 asString <*> nth 2 asContainingModule) - asSpace = nth 0 (withString (eq "space")) *> pure Space + a ctor' ctorStr = ctor' <$> (nth 0 (withText (eq ctorStr)) *> nth 1 asText) + asIdent = nth 0 (withText (eq "ident")) *> (Ident <$> nth 1 asText <*> nth 2 asContainingModule) + asCtor = nth 0 (withText (eq "ctor")) *> (Ctor <$> nth 1 asText <*> nth 2 asContainingModule) + asSpace = nth 0 (withText (eq "space")) *> pure Space eq s s' = if s == s' then Right () else Left "" - unableToParse = withString (Left . show) + unableToParse = withText Left -- | -- This type is isomorphic to 'Maybe' 'P.ModuleName'. It makes code a bit easier @@ -103,7 +103,7 @@ instance A.ToJSON ContainingModule where asContainingModule :: Parse e ContainingModule asContainingModule = - maybeToContainingModule <$> perhaps (P.moduleNameFromString . T.pack <$> asString) + maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asText) -- | -- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious @@ -139,7 +139,7 @@ newtype RenderedCode instance A.ToJSON RenderedCode where toJSON (RC elems) = A.toJSON elems -asRenderedCode :: Parse String RenderedCode +asRenderedCode :: Parse Text RenderedCode asRenderedCode = RC <$> eachInArray asRenderedCodeElement -- | @@ -157,22 +157,22 @@ outputWith f = foldMap f . unRC sp :: RenderedCode sp = RC [Space] -syntax :: String -> RenderedCode +syntax :: Text -> RenderedCode syntax x = RC [Syntax x] -ident :: String -> RenderedCode +ident :: Text -> RenderedCode ident x = RC [Ident x ThisModule] -ident' :: String -> ContainingModule -> RenderedCode +ident' :: Text -> ContainingModule -> RenderedCode ident' x m = RC [Ident x m] -ctor :: String -> ContainingModule -> RenderedCode +ctor :: Text -> ContainingModule -> RenderedCode ctor x m = RC [Ctor x m] -kind :: String -> RenderedCode +kind :: Text -> RenderedCode kind x = RC [Kind x] -keyword :: String -> RenderedCode +keyword :: Text -> RenderedCode keyword kw = RC [Keyword kw] keywordForall :: RenderedCode diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 5de0b1a4a0..dd116d7818 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -9,12 +9,11 @@ import Prelude.Compat import Control.Arrow (first, (***)) import Control.Monad (when) -import Data.Bifunctor (bimap) import Data.Aeson ((.=)) import Data.Aeson.BetterErrors import Data.ByteString.Lazy (ByteString) import Data.Either (isLeft, isRight) -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, fromMaybe) import Data.Text (Text) import Data.Version import qualified Data.Vector as V @@ -38,7 +37,7 @@ import Language.PureScript.Docs.RenderedCode as ReExports data Package a = Package { pkgMeta :: PackageMeta , pkgVersion :: Version - , pkgVersionTag :: String + , pkgVersionTag :: Text , pkgModules :: [Module] , pkgBookmarks :: [Bookmark] , pkgResolvedDependencies :: [(PackageName, Version)] @@ -73,7 +72,7 @@ packageName = bowerName . pkgMeta data Module = Module { modName :: P.ModuleName - , modComments :: Maybe String + , modComments :: Maybe Text , modDeclarations :: [Declaration] -- Re-exported values from other modules , modReExports :: [(P.ModuleName, [Declaration])] @@ -81,8 +80,8 @@ data Module = Module deriving (Show, Eq, Ord) data Declaration = Declaration - { declTitle :: String - , declComments :: Maybe String + { declTitle :: Text + , declComments :: Maybe Text , declSourceSpan :: Maybe P.SourceSpan , declChildren :: [ChildDeclaration] , declInfo :: DeclarationInfo @@ -109,7 +108,7 @@ data DeclarationInfo -- newtype) and its type arguments. Constructors are represented as child -- declarations. -- - | DataDeclaration P.DataDeclType [(String, Maybe P.Kind)] + | DataDeclaration P.DataDeclType [(Text, Maybe P.Kind)] -- | -- A data type foreign import, with its kind. @@ -119,13 +118,13 @@ data DeclarationInfo -- | -- A type synonym, with its type arguments and its type. -- - | TypeSynonymDeclaration [(String, Maybe P.Kind)] P.Type + | TypeSynonymDeclaration [(Text, Maybe P.Kind)] P.Type -- | -- A type class, with its type arguments, its superclasses and functional -- dependencies. Instances and members are represented as child declarations. -- - | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint] [([String], [String])] + | TypeClassDeclaration [(Text, Maybe P.Kind)] [P.Constraint] [([Text], [Text])] -- | -- An operator alias declaration, with the member the alias is for and the @@ -134,14 +133,13 @@ data DeclarationInfo | AliasDeclaration P.Fixity FixityAlias deriving (Show, Eq, Ord) -convertFundepsToStrings :: [(Text, Maybe P.Kind)] -> [P.FunctionalDependency] -> [([String], [String])] +convertFundepsToStrings :: [(Text, Maybe P.Kind)] -> [P.FunctionalDependency] -> [([Text], [Text])] convertFundepsToStrings args fundeps = - map (bimap (map T.unpack) (map T.unpack)) fundeps' + map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps where - fundeps' = map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps argsVec = V.fromList (map fst args) getArg i = - maybe + fromMaybe (P.internalError $ unlines [ "convertDeclaration: Functional dependency index" , show i @@ -150,12 +148,12 @@ convertFundepsToStrings args fundeps = , "Functional dependencies are" , show fundeps ] - ) id $ argsVec V.!? i + ) $ argsVec V.!? i toArgs from to = (map getArg from, map getArg to) type FixityAlias = P.Qualified (Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))) -declInfoToString :: DeclarationInfo -> String +declInfoToString :: DeclarationInfo -> Text declInfoToString (ValueDeclaration _) = "value" declInfoToString (DataDeclaration _ _) = "data" declInfoToString (ExternDataDeclaration _) = "externData" @@ -201,8 +199,8 @@ filterChildren p decl = decl { declChildren = filter p (declChildren decl) } data ChildDeclaration = ChildDeclaration - { cdeclTitle :: String - , cdeclComments :: Maybe String + { cdeclTitle :: Text + , cdeclComments :: Maybe Text , cdeclSourceSpan :: Maybe P.SourceSpan , cdeclInfo :: ChildDeclarationInfo } @@ -227,7 +225,7 @@ data ChildDeclarationInfo | ChildTypeClassMember P.Type deriving (Show, Eq, Ord) -childDeclInfoToString :: ChildDeclarationInfo -> String +childDeclInfoToString :: ChildDeclarationInfo -> Text childDeclInfoToString (ChildInstance _ _) = "instance" childDeclInfoToString (ChildDataConstructor _) = "dataConstructor" childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember" @@ -245,11 +243,11 @@ isDataConstructor ChildDeclaration{..} = _ -> False newtype GithubUser - = GithubUser { runGithubUser :: String } + = GithubUser { runGithubUser :: Text } deriving (Show, Eq, Ord) newtype GithubRepo - = GithubRepo { runGithubRepo :: String } + = GithubRepo { runGithubRepo :: Text } deriving (Show, Eq, Ord) data PackageError @@ -258,14 +256,14 @@ data PackageError -- parser, and actual version used. | ErrorInPackageMeta BowerError | InvalidVersion - | InvalidDeclarationType String - | InvalidChildDeclarationType String + | InvalidDeclarationType Text + | InvalidChildDeclarationType Text | InvalidFixity - | InvalidKind String - | InvalidDataDeclType String + | InvalidKind Text + | InvalidDataDeclType Text deriving (Show, Eq, Ord) -type Bookmark = InPackage (P.ModuleName, String) +type Bookmark = InPackage (P.ModuleName, Text) data InPackage a = Local a @@ -307,7 +305,7 @@ asPackage minimumVersion uploader = do Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta <*> key "version" asVersion - <*> key "versionTag" asString + <*> key "versionTag" asText <*> key "modules" (eachInArray asModule) <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta <*> key "resolvedDependencies" asResolvedDependencies @@ -338,15 +336,15 @@ displayPackageError e = case e of InvalidVersion -> "Invalid version" InvalidDeclarationType str -> - "Invalid declaration type: \"" <> T.pack str <> "\"" + "Invalid declaration type: \"" <> str <> "\"" InvalidChildDeclarationType str -> - "Invalid child declaration type: \"" <> T.pack str <> "\"" + "Invalid child declaration type: \"" <> str <> "\"" InvalidFixity -> "Invalid fixity" InvalidKind str -> - "Invalid kind: \"" <> T.pack str <> "\"" + "Invalid kind: \"" <> str <> "\"" InvalidDataDeclType str -> - "Invalid data declaration type: \"" <> T.pack str <> "\"" + "Invalid data declaration type: \"" <> str <> "\"" where (<>) = T.append @@ -355,7 +353,7 @@ instance A.FromJSON a => A.FromJSON (Package a) where (asPackage (Version [0,0,0,0] []) fromAesonParser) asGithubUser :: Parse e GithubUser -asGithubUser = GithubUser <$> asString +asGithubUser = GithubUser <$> asText instance A.FromJSON GithubUser where parseJSON = toAesonParser' asGithubUser @@ -372,14 +370,14 @@ parseVersion' str = asModule :: Parse PackageError Module asModule = Module <$> key "name" (P.moduleNameFromString <$> asText) - <*> key "comments" (perhaps asString) + <*> key "comments" (perhaps asText) <*> key "declarations" (eachInArray asDeclaration) <*> key "reExports" (eachInArray asReExport) asDeclaration :: Parse PackageError Declaration asDeclaration = - Declaration <$> key "title" asString - <*> key "comments" (perhaps asString) + Declaration <$> key "title" asText + <*> key "comments" (perhaps asText) <*> key "sourceSpan" (perhaps asSourceSpan) <*> key "children" (eachInArray asChildDeclaration) <*> key "info" asDeclarationInfo @@ -417,7 +415,7 @@ asAssociativity = withString (maybe (Left InvalidFixity) Right . parseAssociativ asDeclarationInfo :: Parse PackageError DeclarationInfo asDeclarationInfo = do - ty <- key "declType" asString + ty <- key "declType" asText case ty of "value" -> ValueDeclaration <$> key "type" asType @@ -439,10 +437,10 @@ asDeclarationInfo = do other -> throwCustomError (InvalidDeclarationType other) -asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)] +asTypeArguments :: Parse PackageError [(Text, Maybe P.Kind)] asTypeArguments = eachInArray asTypeArgument where - asTypeArgument = (,) <$> nth 0 asString <*> nth 1 (perhaps asKind) + asTypeArgument = (,) <$> nth 0 asText <*> nth 1 (perhaps asKind) asKind :: Parse e P.Kind asKind = fromAesonParser @@ -450,28 +448,28 @@ asKind = fromAesonParser asType :: Parse e P.Type asType = fromAesonParser -asFunDeps :: Parse PackageError [([String], [String])] +asFunDeps :: Parse PackageError [([Text], [Text])] asFunDeps = eachInArray asFunDep where - asFunDep = (,) <$> nth 0 (eachInArray asString) <*> nth 1 (eachInArray asString) + asFunDep = (,) <$> nth 0 (eachInArray asText) <*> nth 1 (eachInArray asText) asDataDeclType :: Parse PackageError P.DataDeclType asDataDeclType = - withString $ \s -> case s of + withText $ \s -> case s of "data" -> Right P.Data "newtype" -> Right P.Newtype other -> Left (InvalidDataDeclType other) asChildDeclaration :: Parse PackageError ChildDeclaration asChildDeclaration = - ChildDeclaration <$> key "title" asString - <*> key "comments" (perhaps asString) + ChildDeclaration <$> key "title" asText + <*> key "comments" (perhaps asText) <*> key "sourceSpan" (perhaps asSourceSpan) <*> key "info" asChildDeclarationInfo asChildDeclarationInfo :: Parse PackageError ChildDeclarationInfo asChildDeclarationInfo = do - ty <- key "declType" asString + ty <- key "declType" asText case ty of "instance" -> ChildInstance <$> key "dependencies" (eachInArray asConstraint) @@ -504,7 +502,7 @@ asBookmarks = eachInArray asBookmark asBookmark :: Parse BowerError Bookmark asBookmark = asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asText) - <*> nth 1 asString) + <*> nth 1 asText) asResolvedDependencies :: Parse PackageError [(PackageName, Version)] asResolvedDependencies = @@ -514,8 +512,8 @@ asResolvedDependencies = mapLeft _ (Right x) = Right x asGithub :: Parse e (GithubUser, GithubRepo) -asGithub = (,) <$> nth 0 (GithubUser <$> asString) - <*> nth 1 (GithubRepo <$> asString) +asGithub = (,) <$> nth 0 (GithubUser <$> asText) + <*> nth 1 (GithubRepo <$> asText) asSourceSpan :: Parse e P.SourceSpan asSourceSpan = P.SourceSpan <$> key "name" asString diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 83589ba484..e3cecd364b 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -23,7 +23,7 @@ module Language.PureScript.Publish import Prelude () import Prelude.Compat hiding (userError) -import Control.Arrow ((***)) +import Control.Arrow ((***), first) import Control.Category ((>>>)) import Control.Exception (catch, try) import Control.Monad.Error.Class (MonadError(..)) @@ -35,12 +35,13 @@ import Data.Aeson.BetterErrors import Data.Char (isSpace) import Data.Foldable (traverse_) import Data.Function (on) -import Data.List (stripPrefix, isSuffixOf, (\\), nubBy) +import Data.List (stripPrefix, (\\), nubBy) import Data.List.NonEmpty (NonEmpty(..)) import Data.List.Split (splitOn) import Data.Maybe import Data.Version import qualified Data.SPDX as SPDX +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL @@ -65,7 +66,7 @@ import qualified Language.PureScript.Docs as D data PublishOptions = PublishOptions { -- | How to obtain the version tag and version that the data being -- generated will refer to. - publishGetVersion :: PrepareM (String, Version) + publishGetVersion :: PrepareM (Text, Version) , -- | What to do when the working tree is dirty publishWorkingTreeDirty :: PrepareM () } @@ -184,13 +185,13 @@ checkCleanWorkingTree opts = do unless (status == Clean) $ publishWorkingTreeDirty opts -getVersionFromGitTag :: PrepareM (String, Version) +getVersionFromGitTag :: PrepareM (Text, Version) getVersionFromGitTag = do out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] "" let vs = map trimWhitespace (lines out) case mapMaybe parseMay vs of [] -> userError TagMustBeCheckedOut - [x] -> return x + [x] -> return (first T.pack x) xs -> userError (AmbiguousVersions (map snd xs)) where trimWhitespace = @@ -209,7 +210,7 @@ getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExt Just Repository{..} -> do unless (repositoryType == "git") (Left (BadRepositoryType repositoryType)) - maybe (Left NotOnGithub) Right (extractGithub repositoryUrl) + maybe (Left NotOnGithub) Right (extractGithub (T.pack repositoryUrl)) checkLicense :: PackageMeta -> PrepareM () checkLicense pkgMeta = @@ -226,9 +227,9 @@ checkLicense pkgMeta = isValidSPDX :: String -> Bool isValidSPDX = (== 1) . length . SPDX.parseExpression -extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo) +extractGithub :: Text -> Maybe (D.GithubUser, D.GithubRepo) extractGithub = stripGitHubPrefixes - >>> fmap (splitOn "/") + >>> fmap (T.splitOn "/") >=> takeTwo >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit)) @@ -237,18 +238,18 @@ extractGithub = stripGitHubPrefixes takeTwo [x, y] = Just (x, y) takeTwo _ = Nothing - stripGitHubPrefixes :: String -> Maybe String + stripGitHubPrefixes :: Text -> Maybe Text stripGitHubPrefixes = stripPrefixes [ "git://github.com/" , "https://github.com/" , "git@github.com:" ] - stripPrefixes :: [String] -> String -> Maybe String - stripPrefixes prefixes str = msum $ (`stripPrefix` str) <$> prefixes + stripPrefixes :: [Text] -> Text -> Maybe Text + stripPrefixes prefixes str = msum $ (`T.stripPrefix` str) <$> prefixes - dropDotGit :: String -> String + dropDotGit :: Text -> Text dropDotGit str - | ".git" `isSuffixOf` str = take (length str - 4) str + | ".git" `T.isSuffixOf` str = T.take (T.length str - 4) str | otherwise = str readProcess' :: String -> [String] -> String -> PrepareM String @@ -265,12 +266,12 @@ data DependencyStatus -- _resolution key. This can be caused by adding the dependency using -- `bower link`, or simply copying it into bower_components instead of -- installing it normally. - | ResolvedOther String - -- ^ Resolved, but to something other than a version. The String argument + | ResolvedOther Text + -- ^ Resolved, but to something other than a version. The Text argument -- is the resolution type. The values it can take that I'm aware of are -- "commit" and "branch". - | ResolvedVersion String - -- ^ Resolved to a version. The String argument is the resolution tag (eg, + | ResolvedVersion Text + -- ^ Resolved to a version. The Text argument is the resolution tag (eg, -- "v0.1.0"). deriving (Show, Eq) @@ -341,9 +342,9 @@ asDependencyStatus = do else key "pkgMeta" $ keyOrDefault "_resolution" NoResolution $ do - type_ <- key "type" asString + type_ <- key "type" asText case type_ of - "version" -> ResolvedVersion <$> key "tag" asString + "version" -> ResolvedVersion <$> key "tag" asText other -> return (ResolvedOther other) warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM () @@ -374,15 +375,16 @@ handleDeps deps = do bowerDir pkgName = "bower_components/" ++ runPackageName pkgName -- Try to extract a version, and warn if unsuccessful. + tryExtractVersion' :: (PackageName, Text) -> PrepareM (Maybe (PackageName, Version)) tryExtractVersion' pair = maybe (warn (UnacceptableVersion pair) >> return Nothing) (return . Just) (tryExtractVersion pair) -tryExtractVersion :: (PackageName, String) -> Maybe (PackageName, Version) +tryExtractVersion :: (PackageName, Text) -> Maybe (PackageName, Version) tryExtractVersion (pkgName, tag) = - let tag' = fromMaybe tag (stripPrefix "v" tag) - in (pkgName,) <$> D.parseVersion' tag' + let tag' = fromMaybe tag (T.stripPrefix "v" tag) + in (pkgName,) <$> D.parseVersion' (T.unpack tag') -- | Returns whether it looks like there is a purescript package checked out -- in the given directory. diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index db7d7de173..3e6cf02104 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -24,6 +24,7 @@ import Data.Maybe import Data.Monoid import Data.Version import qualified Data.List.NonEmpty as NonEmpty +import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Publish.BoxesHelpers @@ -43,7 +44,7 @@ data PackageError data PackageWarning = NoResolvedVersion PackageName | UndeclaredDependency PackageName - | UnacceptableVersion (PackageName, String) + | UnacceptableVersion (PackageName, Text) | DirtyWorkingTree_Warn deriving (Show) @@ -311,7 +312,7 @@ displayOtherError e = case e of data CollectedWarnings = CollectedWarnings { noResolvedVersions :: [PackageName] , undeclaredDependencies :: [PackageName] - , unacceptableVersions :: [(PackageName, String)] + , unacceptableVersions :: [(PackageName, Text)] , dirtyWorkingTree :: Any } deriving (Show, Eq, Ord) @@ -387,7 +388,7 @@ warnUndeclaredDependencies pkgNames = ]) : bulletedList runPackageName (NonEmpty.toList pkgNames) -warnUnacceptableVersions :: NonEmpty (PackageName, String) -> Box +warnUnacceptableVersions :: NonEmpty (PackageName, Text) -> Box warnUnacceptableVersions pkgs = let singular = NonEmpty.length pkgs == 1 pl a b = if singular then b else a @@ -414,7 +415,7 @@ warnUnacceptableVersions pkgs = ]) ] where - showTuple (pkgName, tag) = runPackageName pkgName ++ "#" ++ tag + showTuple (pkgName, tag) = runPackageName pkgName ++ "#" ++ T.unpack tag warnDirtyWorkingTree :: Box warnDirtyWorkingTree = diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index c68943750e..c260935034 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} module TestDocs where @@ -13,6 +14,7 @@ import Data.Monoid import Data.Maybe (fromMaybe) import Data.List ((\\)) import Data.Foldable +import Data.Text (Text) import qualified Data.Text as T import System.Exit @@ -37,7 +39,7 @@ main = pushd "examples/docs" $ do case res of Left e -> Publish.printErrorToStdout e >> exitFailure Right Docs.Package{..} -> - forM_ testCases $ \(P.moduleNameFromString . T.pack -> mn, pragmas) -> + forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) -> let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn)) (find ((==) mn . Docs.modName) pkgModules) in forM_ pragmas (`runAssertionIO` mdl) @@ -49,25 +51,28 @@ takeJust msg = fromMaybe (error msg) data Assertion -- | Assert that a particular declaration is documented with the given -- children - = ShouldBeDocumented P.ModuleName String [String] + = ShouldBeDocumented P.ModuleName Text [Text] -- | Assert that a particular declaration is not documented - | ShouldNotBeDocumented P.ModuleName String + | ShouldNotBeDocumented P.ModuleName Text -- | Assert that a particular declaration exists, but without a particular -- child. - | ChildShouldNotBeDocumented P.ModuleName String String + | ChildShouldNotBeDocumented P.ModuleName Text Text -- | Assert that a particular declaration has a particular type class -- constraint. - | ShouldBeConstrained P.ModuleName String String + | ShouldBeConstrained P.ModuleName Text Text -- | Assert that a particular typeclass declaration has a functional -- dependency list. - | ShouldHaveFunDeps P.ModuleName String [([String],[String])] + | ShouldHaveFunDeps P.ModuleName Text [([Text],[Text])] -- | Assert that a particular value declaration exists, and its type -- satisfies the given predicate. - | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool)) + | ValueShouldHaveTypeSignature P.ModuleName Text (ShowFn (P.Type -> Bool)) -- | Assert that a particular type alias exists, and its corresponding -- type, when rendered, matches a given string exactly -- fields: module, type synonym name, expected type - | TypeSynonymShouldRenderAs P.ModuleName String String + | TypeSynonymShouldRenderAs P.ModuleName Text Text + -- | Assert that a documented declaration includes a documentation comment + -- containing a particular string + | ShouldHaveDocComment P.ModuleName Text Text deriving (Show) newtype ShowFn a = ShowFn a @@ -77,28 +82,31 @@ instance Show (ShowFn a) where data AssertionFailure -- | A declaration was not documented, but should have been - = NotDocumented P.ModuleName String + = NotDocumented P.ModuleName Text -- | A child declaration was not documented, but should have been - | ChildrenNotDocumented P.ModuleName String [String] + | ChildrenNotDocumented P.ModuleName Text [Text] -- | A declaration was documented, but should not have been - | Documented P.ModuleName String + | Documented P.ModuleName Text -- | A child declaration was documented, but should not have been - | ChildDocumented P.ModuleName String String + | ChildDocumented P.ModuleName Text Text -- | A constraint was missing. - | ConstraintMissing P.ModuleName String String + | ConstraintMissing P.ModuleName Text Text -- | A functional dependency was missing. - | FunDepMissing P.ModuleName String [([String], [String])] + | FunDepMissing P.ModuleName Text [([Text], [Text])] -- | A declaration had the wrong "type" (ie, value, type, type class) -- Fields: declaration title, expected "type", actual "type". - | WrongDeclarationType P.ModuleName String String String + | WrongDeclarationType P.ModuleName Text Text Text -- | A value declaration had the wrong type (in the sense of "type -- checking"), eg, because the inferred type was used when the explicit type -- should have been. -- Fields: module name, declaration name, actual type. - | ValueDeclarationWrongType P.ModuleName String P.Type + | ValueDeclarationWrongType P.ModuleName Text P.Type -- | A Type synonym has been rendered in an unexpected format -- Fields: module name, declaration name, expected rendering, actual rendering - | TypeSynonymMismatch P.ModuleName String String String + | TypeSynonymMismatch P.ModuleName Text Text Text + -- | A doc comment was not found or did not match what was expected + -- Fields: declaration title, expected substring, actual comments + | DocCommentMissing P.ModuleName Text (Maybe Text) deriving (Show) data AssertionResult @@ -135,62 +143,56 @@ runAssertion assertion Docs.Module{..} = Fail (NotDocumented mn decl) ShouldBeConstrained mn decl tyClass -> - case find ((==) decl . Docs.declTitle) (declarationsFor mn) of - Nothing -> - Fail (NotDocumented mn decl) - Just Docs.Declaration{..} -> - case declInfo of - Docs.ValueDeclaration ty -> - if checkConstrained ty tyClass - then Pass - else Fail (ConstraintMissing mn decl tyClass) - _ -> - Fail (WrongDeclarationType mn decl "value" - (Docs.declInfoToString declInfo)) + findDecl mn decl $ \Docs.Declaration{..} -> + case declInfo of + Docs.ValueDeclaration ty -> + if checkConstrained ty tyClass + then Pass + else Fail (ConstraintMissing mn decl tyClass) + _ -> + Fail (WrongDeclarationType mn decl "value" + (Docs.declInfoToString declInfo)) ShouldHaveFunDeps mn decl fds -> - case find ((==) decl . Docs.declTitle) (declarationsFor mn) of - Nothing -> - Fail (NotDocumented mn decl) - Just Docs.Declaration{..} -> - case declInfo of - Docs.TypeClassDeclaration _ _ fundeps -> - if fundeps == fds - then Pass - else Fail (FunDepMissing mn decl fds) - _ -> - Fail (WrongDeclarationType mn decl "value" - (Docs.declInfoToString declInfo)) + findDecl mn decl $ \Docs.Declaration{..} -> + case declInfo of + Docs.TypeClassDeclaration _ _ fundeps -> + if fundeps == fds + then Pass + else Fail (FunDepMissing mn decl fds) + _ -> + Fail (WrongDeclarationType mn decl "value" + (Docs.declInfoToString declInfo)) ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) -> - case find ((==) decl . Docs.declTitle) (declarationsFor mn) of - Nothing -> - Fail (NotDocumented mn decl) - Just Docs.Declaration{..} -> - case declInfo of - Docs.ValueDeclaration ty -> - if tyPredicate ty - then Pass - else Fail - (ValueDeclarationWrongType mn decl ty) - _ -> - Fail (WrongDeclarationType mn decl "value" - (Docs.declInfoToString declInfo)) + findDecl mn decl $ \Docs.Declaration{..} -> + case declInfo of + Docs.ValueDeclaration ty -> + if tyPredicate ty + then Pass + else Fail + (ValueDeclarationWrongType mn decl ty) + _ -> + Fail (WrongDeclarationType mn decl "value" + (Docs.declInfoToString declInfo)) TypeSynonymShouldRenderAs mn decl expected -> - case find ((==) decl . Docs.declTitle) (declarationsFor mn) of - Nothing -> - Fail (NotDocumented mn decl) - Just Docs.Declaration{..} -> - case declInfo of - Docs.TypeSynonymDeclaration [] ty -> - let actual = codeToString (Docs.renderType ty) in - if actual == expected - then Pass - else Fail (TypeSynonymMismatch mn decl expected actual) - _ -> - Fail (WrongDeclarationType mn decl "synonym" - (Docs.declInfoToString declInfo)) + findDecl mn decl $ \Docs.Declaration{..} -> + case declInfo of + Docs.TypeSynonymDeclaration [] ty -> + let actual = codeToString (Docs.renderType ty) in + if actual == expected + then Pass + else Fail (TypeSynonymMismatch mn decl expected actual) + _ -> + Fail (WrongDeclarationType mn decl "synonym" + (Docs.declInfoToString declInfo)) + + ShouldHaveDocComment mn decl expected -> + findDecl mn decl $ \Docs.Declaration{..} -> + if maybe False (expected `T.isInfixOf`) declComments + then Pass + else Fail (DocCommentMissing mn decl declComments) where declarationsFor mn = @@ -201,9 +203,16 @@ runAssertion assertion Docs.Module{..} = findChildren title = fmap childrenTitles . find ((==) title . Docs.declTitle) + findDecl mn title f = + case find ((==) title . Docs.declTitle) (declarationsFor mn) of + Nothing -> + Fail (NotDocumented mn title) + Just decl -> + f decl + childrenTitles = map Docs.cdeclTitle . Docs.declChildren -checkConstrained :: P.Type -> String -> Bool +checkConstrained :: P.Type -> Text -> Bool checkConstrained ty tyClass = -- Note that we don't recurse on ConstrainedType if none of the constraints -- match; this is by design, as constraints should be moved to the front @@ -217,7 +226,7 @@ checkConstrained ty tyClass = False where matches className = - (==) className . T.unpack . P.runProperName . P.disqualify . P.constraintClass + (==) className . P.runProperName . P.disqualify . P.constraintClass runAssertionIO :: Assertion -> Docs.Module -> IO () runAssertionIO assertion mdl = do @@ -228,7 +237,7 @@ runAssertionIO assertion mdl = do putStrLn ("Failed: " <> show reason) exitFailure -testCases :: [(String, [Assertion])] +testCases :: [(Text, [Assertion])] testCases = [ ("Example", [ -- From dependencies @@ -319,6 +328,10 @@ testCases = , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test4" (renderedType "forall a b c d. ((a ~> b) ~> c) ~> d") , ValueShouldHaveTypeSignature (n "TypeOpAliases") "third" (renderedType "forall a b c. a × b × c -> c") ]) + + , ("DocComments", + [ ShouldHaveDocComment (n "DocComments") "example" " example == 0" + ]) ] where diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index ba73ed7e60..10462b78a0 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -3,7 +3,6 @@ module TestPrimDocs where import Control.Monad import Data.List ((\\)) import qualified Data.Map as Map -import qualified Data.Text as T import qualified Language.PureScript as P import qualified Language.PureScript.Docs as D import qualified Language.PureScript.Docs.AsMarkdown as D @@ -11,11 +10,11 @@ import qualified Language.PureScript.Docs.AsMarkdown as D main :: IO () main = do putStrLn "Test that there are no bottoms hiding in primDocsModule" - seq (T.pack (D.runDocs (D.modulesAsMarkdown [D.primDocsModule]))) (return ()) + seq (D.runDocs (D.modulesAsMarkdown [D.primDocsModule])) (return ()) putStrLn "Test that Prim is fully documented" let actualPrimTypes = map (P.runProperName . P.disqualify . fst) $ Map.toList P.primTypes - let documentedPrimTypes = map (T.pack . D.declTitle) (D.modDeclarations D.primDocsModule) + let documentedPrimTypes = map D.declTitle (D.modDeclarations D.primDocsModule) let undocumentedTypes = actualPrimTypes \\ documentedPrimTypes let extraTypes = documentedPrimTypes \\ actualPrimTypes diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 05c082f152..14bd03742a 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -1,20 +1,12 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module TestPscPublish where -import Control.Monad -import Control.Applicative -import Control.Exception -import System.Process -import System.Directory -import System.IO -import System.Exit -import qualified Data.ByteString.Lazy as BL +import System.Exit (exitFailure) import Data.ByteString.Lazy (ByteString) import qualified Data.Aeson as A -import Data.Aeson.BetterErrors import Data.Version import Language.PureScript.Docs From df8b1aed4977b79498101d2f8901e92c5a693192 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 26 Dec 2016 21:40:25 +0000 Subject: [PATCH 0579/1580] Add package information to re-exports This gets us most of the way towards fixing the following issue: https://github.com/purescript/pursuit/issues/209 This change preserves backwards-compatibility in the parser by pretending that all re-exports come from local modules (i.e. in the same package) in JSON produced by older compilers. This is obviously not ideal but it's most likely going to be temporary and it's better than any alternatives I can think of. --- purescript.cabal | 1 + src/Language/PureScript/Docs/AsMarkdown.hs | 5 ++-- src/Language/PureScript/Docs/Convert.hs | 22 ++++++++++---- .../PureScript/Docs/Convert/ReExports.hs | 7 +++-- src/Language/PureScript/Docs/Types.hs | 18 ++++++++++-- tests/TestDocs.hs | 29 +++++++++++++++++-- 6 files changed, 66 insertions(+), 16 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index bfc7aa26f0..d6039f0d6b 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -511,6 +511,7 @@ test-suite tests aeson -any, aeson-better-errors -any, base-compat -any, + bower-json -any, boxes -any, bytestring -any, containers -any, diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 527ca53036..bcc258e3c4 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -33,7 +33,7 @@ renderModulesAsMarkdown :: [P.Module] -> m Text renderModulesAsMarkdown = - fmap (runDocs . modulesAsMarkdown) . Convert.convertModules + fmap (runDocs . modulesAsMarkdown) . Convert.convertModules Local modulesAsMarkdown :: [Module] -> Docs modulesAsMarkdown = mapM_ moduleAsMarkdown @@ -45,7 +45,8 @@ moduleAsMarkdown Module{..} = do for_ modComments tell' mapM_ (declAsMarkdown modName) modDeclarations spacer - for_ modReExports $ \(mn, decls) -> do + for_ modReExports $ \(mn', decls) -> do + let mn = ignorePackage mn' headerLevel 3 $ "Re-exported from " <> P.runModuleName mn <> ":" spacer mapM_ (declAsMarkdown mn) decls diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 34920e7b8d..541d80b282 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -15,6 +15,7 @@ import Control.Monad import Control.Monad.Error.Class (MonadError) import Control.Monad.State (runStateT) import Control.Monad.Writer.Strict (runWriterT) +import Data.List (find) import qualified Data.Map as Map import Data.Text (Text) @@ -42,9 +43,18 @@ convertModulesInPackage modules = map P.getModuleName (takeLocals modules) go = map ignorePackage - >>> convertModules + >>> convertModules withPackage >>> fmap (filter ((`elem` localNames) . modName)) + withPackage :: P.ModuleName -> InPackage P.ModuleName + withPackage mn = + case find ((== mn) . P.getModuleName . ignorePackage) modules of + Just m -> + fmap P.getModuleName m + Nothing -> + P.internalError $ "withPackage: missing module:" ++ + show (P.runModuleName mn) + -- | -- Convert a group of modules to the intermediate format, designed for -- producing documentation from. It is also necessary to pass an Env containing @@ -61,12 +71,13 @@ convertModulesInPackage modules = -- convertModules :: (MonadError P.MultipleErrors m) => + (P.ModuleName -> InPackage P.ModuleName) -> [P.Module] -> m [Module] -convertModules = +convertModules withPackage = P.sortModules >>> fmap (fst >>> map importPrim) - >=> convertSorted + >=> convertSorted withPackage importPrim :: P.Module -> P.Module importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim]) @@ -76,16 +87,17 @@ importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim]) -- convertSorted :: (MonadError P.MultipleErrors m) => + (P.ModuleName -> InPackage P.ModuleName) -> [P.Module] -> m [Module] -convertSorted modules = do +convertSorted withPackage modules = do (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules modulesWithTypes <- typeCheckIfNecessary modules convertedModules let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes) let traversalOrder = map P.getModuleName modules - pure (Map.elems (updateReExports env traversalOrder moduleMap)) + pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap)) -- | -- If any exported value declarations have either wildcard type signatures, or diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index ee6d379eb6..ecadd9fcb0 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -4,7 +4,7 @@ module Language.PureScript.Docs.Convert.ReExports import Prelude.Compat -import Control.Arrow ((&&&), second) +import Control.Arrow ((&&&), first, second) import Control.Monad import Control.Monad.Reader.Class (MonadReader, ask) import Control.Monad.State.Class (MonadState, gets, modify) @@ -35,9 +35,10 @@ import qualified Language.PureScript as P updateReExports :: P.Env -> [P.ModuleName] -> + (P.ModuleName -> InPackage P.ModuleName) -> Map P.ModuleName Module -> Map P.ModuleName Module -updateReExports env order = execState action +updateReExports env order withPackage = execState action where action = void (traverse go order) @@ -45,7 +46,7 @@ updateReExports env order = execState action go mn = do mdl <- lookup' mn reExports <- getReExports env mn - let mdl' = mdl { modReExports = reExports } + let mdl' = mdl { modReExports = map (first withPackage) reExports } modify (Map.insert mn mdl') lookup' mn = do diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index dd116d7818..21d068a1b2 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -8,6 +8,7 @@ import Prelude.Compat import Control.Arrow (first, (***)) import Control.Monad (when) +import Control.Monad.Error.Class (catchError) import Data.Aeson ((.=)) import Data.Aeson.BetterErrors @@ -75,7 +76,7 @@ data Module = Module , modComments :: Maybe Text , modDeclarations :: [Declaration] -- Re-exported values from other modules - , modReExports :: [(P.ModuleName, [Declaration])] + , modReExports :: [(InPackage P.ModuleName, [Declaration])] } deriving (Show, Eq, Ord) @@ -382,10 +383,21 @@ asDeclaration = <*> key "children" (eachInArray asChildDeclaration) <*> key "info" asDeclarationInfo -asReExport :: Parse PackageError (P.ModuleName, [Declaration]) +asReExport :: Parse PackageError (InPackage P.ModuleName, [Declaration]) asReExport = - (,) <$> key "moduleName" fromAesonParser + (,) <$> key "moduleName" asReExportModuleName <*> key "declarations" (eachInArray asDeclaration) + where + -- This is to preserve backwards compatibility with 0.10.3 and earlier versions + -- of the compiler, where the modReExports field had the type + -- [(P.ModuleName, [Declaration])]. This should eventually be removed, + -- possibly at the same time as the next breaking change to this JSON format. + asReExportModuleName :: Parse PackageError (InPackage P.ModuleName) + asReExportModuleName = + asInPackage fromAesonParser .! ErrorInPackageMeta + <|> fmap Local fromAesonParser + + (<|>) p q = catchError p (const q) asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a) asInPackage inner = diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index c260935034..c9953369a1 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -8,8 +8,9 @@ module TestDocs where import Prelude () import Prelude.Compat -import Data.Version (Version(..)) +import Control.Arrow (first) +import Data.Version (Version(..)) import Data.Monoid import Data.Maybe (fromMaybe) import Data.List ((\\)) @@ -24,6 +25,8 @@ import Language.PureScript.Docs.AsMarkdown (codeToString) import qualified Language.PureScript.Publish as Publish import qualified Language.PureScript.Publish.ErrorsWarnings as Publish +import Web.Bower.PackageMeta (parsePackageName) + import TestUtils publishOpts :: Publish.PublishOptions @@ -73,6 +76,9 @@ data Assertion -- | Assert that a documented declaration includes a documentation comment -- containing a particular string | ShouldHaveDocComment P.ModuleName Text Text + -- | Assert that there should be some declarations re-exported from a + -- particular module in a particular package. + | ShouldHaveReExport (Docs.InPackage P.ModuleName) deriving (Show) newtype ShowFn a = ShowFn a @@ -105,8 +111,11 @@ data AssertionFailure -- Fields: module name, declaration name, expected rendering, actual rendering | TypeSynonymMismatch P.ModuleName Text Text Text -- | A doc comment was not found or did not match what was expected - -- Fields: declaration title, expected substring, actual comments + -- Fields: module name, expected substring, actual comments | DocCommentMissing P.ModuleName Text (Maybe Text) + -- | A module was missing re-exports from a particular module. + -- Fields: module name, expected re-export, actual re-exports. + | ReExportMissing P.ModuleName (Docs.InPackage P.ModuleName) [Docs.InPackage P.ModuleName] deriving (Show) data AssertionResult @@ -194,11 +203,19 @@ runAssertion assertion Docs.Module{..} = then Pass else Fail (DocCommentMissing mn decl declComments) + ShouldHaveReExport reExp -> + let + reExps = map fst modReExports + in + if reExp `elem` reExps + then Pass + else Fail (ReExportMissing modName reExp reExps) + where declarationsFor mn = if mn == modName then modDeclarations - else fromMaybe [] (lookup mn modReExports) + else fromMaybe [] (lookup mn (map (first Docs.ignorePackage) modReExports)) findChildren title = fmap childrenTitles . find ((==) title . Docs.declTitle) @@ -247,7 +264,12 @@ testCases = -- From local files , ShouldBeDocumented (n "Example2") "one" [] , ShouldNotBeDocumented (n "Example2") "two" + + -- Re-exports + , ShouldHaveReExport (Docs.FromDep (pkg "purescript-prelude") (n "Prelude")) + , ShouldHaveReExport (Docs.Local (n "Example2")) ]) + , ("Example2", [ ShouldBeDocumented (n "Example2") "one" [] , ShouldBeDocumented (n "Example2") "two" [] @@ -336,6 +358,7 @@ testCases = where n = P.moduleNameFromString . T.pack + pkg str = let Right p = parsePackageName str in p hasTypeVar varName = getAny . P.everythingOnTypes (<>) (Any . isVar varName) From 21ca139bda157d626a34518856d6dedf06f72e83 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 27 Dec 2016 20:12:28 -0800 Subject: [PATCH 0580/1580] Fix #2459, add verify-set command to psc-package --- psc-package/Main.hs | 32 ++++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/psc-package/Main.hs b/psc-package/Main.hs index b6b7943851..0415b716b6 100644 --- a/psc-package/Main.hs +++ b/psc-package/Main.hs @@ -12,7 +12,7 @@ import Data.Aeson.Encode.Pretty import Data.Foldable (fold, for_, traverse_) import Data.List (nub) import qualified Data.Map as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import Data.Text (pack) import qualified Data.Text.Lazy as TL @@ -128,11 +128,13 @@ readPackageSet PackageConfig{ set } = do exit (ExitFailure 1) Just db -> return db -installOrUpdate :: PackageConfig -> Text -> PackageInfo -> IO () -installOrUpdate PackageConfig{ set } pkgName PackageInfo{ repo, version } = do +installOrUpdate :: Text -> Text -> PackageInfo -> IO Turtle.FilePath +installOrUpdate set pkgName PackageInfo{ repo, version } = do + echo ("Updating " <> pkgName) let pkgDir = ".psc-package" fromText set fromText pkgName fromText version exists <- testdir pkgDir unless exists . void $ cloneShallow repo version pkgDir + pure pkgDir getTransitiveDeps :: PackageSet -> [Text] -> IO [(Text, PackageInfo)] getTransitiveDeps db depends = do @@ -151,9 +153,7 @@ updateImpl config@PackageConfig{ depends } = do db <- readPackageSet config trans <- getTransitiveDeps db depends echo ("Updating " <> pack (show (length trans)) <> " packages...") - for_ trans $ \(pkgName, pkg) -> do - echo ("Updating " <> pkgName) - installOrUpdate config pkgName pkg + for_ trans $ \(pkgName, pkg) -> installOrUpdate (set config) pkgName pkg initialize :: IO () initialize = do @@ -233,6 +233,23 @@ exec exeName = do (map pathToTextUnsafe ("src" "**" "*.purs" : paths)) empty +verifyPackageSet :: IO () +verifyPackageSet = do + pkg <- readPackageFile + db <- readPackageSet pkg + + echo ("Verifying " <> pack (show (Map.size db)) <> " packages.") + echo "Warning: this could take some time!" + + let installOrUpdate' (name, pkgInfo) = (name, ) <$> installOrUpdate (set pkg) name pkgInfo + paths <- Map.fromList <$> traverse installOrUpdate' (Map.toList db) + + for_ (Map.toList db) $ \(name, PackageInfo{..}) -> do + let dirFor = fromMaybe (error "verifyPackageSet: no directory") . (`Map.lookup` paths) + echo ("Verifying package " <> name) + let srcGlobs = map (pathToTextUnsafe . ( ("src" "**" "*.purs")) . dirFor) (name : dependencies) + procs "psc" srcGlobs empty + main :: IO () main = do IO.hSetEncoding IO.stdout IO.utf8 @@ -275,6 +292,9 @@ main = do , Opts.command "available" (Opts.info (pure listPackages) (Opts.progDesc "List all packages available in the package set")) + , Opts.command "verify-set" + (Opts.info (pure verifyPackageSet) + (Opts.progDesc "Verify that the packages in the package set build correctly")) ] where pkg = Opts.strArgument $ From 9ed097452bacc512049b2003739896aa511d9454 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 28 Dec 2016 03:22:57 +0000 Subject: [PATCH 0581/1580] More robust license generator script Changes: * Ensure that all responses are 200 OK responses, i.e. avoids errors such as a 404 error page being treated as the actual license file. * Use the license-file field of the package's Cabal file -- most packages simply use LICENSE as their license-file, but not all do, and this is safer than the previous approach of maintaining a list of packages that deviate from the convention of using LICENSE. * Exits with a nonzero code if at least one dependency returned a non-200 response for its license file. * Uses the license files from the actual versions of dependencies which we are using instead of the very latest one. * Use http-client instead of curl (mainly for the response code checking but this has the nice side effect that the script should work basically anywhere now). Packages who list their 'license' field as PublicDomain (at the time of writing, this is just monad-loops) will not be treated as failures if a license-file is not found. --- LICENSE | 899 +++++++++++++++++++++++++++++++--- license-generator/generate.hs | 182 +++++-- 2 files changed, 974 insertions(+), 107 deletions(-) diff --git a/LICENSE b/LICENSE index d392d3d51e..550b1b6e17 100644 --- a/LICENSE +++ b/LICENSE @@ -16,6 +16,8 @@ PureScript uses the following Haskell library packages. Their license files foll Glob SHA + StateVar + adjunctions aeson aeson-better-errors aeson-pretty @@ -31,7 +33,9 @@ PureScript uses the following Haskell library packages. Their license files foll auto-update base base-compat + base-orphans base64-bytestring + bifunctors binary blaze-builder blaze-html @@ -46,16 +50,19 @@ PureScript uses the following Haskell library packages. Their license files foll cereal clock cmdargs + comonad conduit conduit-extra connection containers + contravariant cookie cryptonite data-default-class data-ordlist deepseq directory + distributive dlist easy-file edit-distance @@ -65,12 +72,15 @@ PureScript uses the following Haskell library packages. Their license files foll fast-logger file-embed filepath + foldl + free fsnotify ghc-prim hashable haskeline hex - hfsevents + hinotify + hostname hourglass http-client http-client-tls @@ -79,8 +89,11 @@ PureScript uses the following Haskell library packages. Their license files foll http2 integer-gmp iproute + kan-extensions language-javascript + lens lifted-base + managed memory mime-types mmorph @@ -88,10 +101,12 @@ PureScript uses the following Haskell library packages. Their license files foll monad-logger monad-loops mtl + mwc-random network network-uri old-locale old-time + optional-args optparse-applicative parallel parsec @@ -99,16 +114,20 @@ PureScript uses the following Haskell library packages. Their license files foll pem pipes pipes-http + prelude-extras primitive process + profunctors protolude psqueues random + reflection regex-base regex-tdfa resourcet safe scientific + semigroupoids semigroups simple-sendfile socks @@ -120,16 +139,19 @@ PureScript uses the following Haskell library packages. Their license files foll streaming-commons stringsearch syb + system-fileio + system-filepath tagged template-haskell + temporary terminfo text time - time-locale-compat tls transformers transformers-base transformers-compat + turtle unix unix-compat unix-time @@ -215,6 +237,67 @@ SHA LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +StateVar LICENSE file: + + Copyright (c) 2014-2015, Edward Kmett + Copyright (c) 2009-2016, Sven Panne + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + +adjunctions LICENSE file: + + Copyright 2011-2014 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + aeson LICENSE file: Copyright (c) 2011, MailRank, Inc. @@ -762,6 +845,29 @@ base-compat LICENSE file: OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +base-orphans LICENSE file: + + Copyright (c) 2015-2016 Simon Hengel , João Cristóvão , Ryan Scott + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be included + in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY + CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, + TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE + SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + base64-bytestring LICENSE file: Copyright (c) 2010 Bryan O'Sullivan @@ -795,6 +901,35 @@ base64-bytestring LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +bifunctors LICENSE file: + + Copyright 2008-2016 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + binary LICENSE file: Copyright (c) Lennart Kolmodin @@ -1244,6 +1379,36 @@ cmdargs LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +comonad LICENSE file: + + Copyright 2008-2014 Edward Kmett + Copyright 2004-2008 Dave Menendez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + conduit LICENSE file: Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ @@ -1354,6 +1519,39 @@ containers LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +contravariant LICENSE file: + + Copyright 2007-2015 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + cookie LICENSE file: Copyright (c) 2010 Michael Snoyman, http://www.yesodweb.com/ @@ -1426,16 +1624,16 @@ data-default-class LICENSE file: may be used to endorse or promote products derived from this software without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + THIS SOFTWARE IS PROVIDED BY LUKAS MAI AND CONTRIBUTORS "AS IS" AND ANY + EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY + DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. data-ordlist LICENSE file: @@ -1558,9 +1756,38 @@ directory LICENSE file: ----------------------------------------------------------------------------- +distributive LICENSE file: + + Copyright 2011-2016 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + dlist LICENSE file: - Copyright (c) 2006-2009 Don Stewart, 2013-2016 Sean Leather + Copyright (c) 2006-2009 Don Stewart, 2013-2014 Sean Leather All rights reserved. @@ -1842,6 +2069,66 @@ filepath LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +foldl LICENSE file: + + Copyright (c) 2013 Gabriel Gonzalez + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Gabriel Gonzalez nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +free LICENSE file: + + Copyright 2008-2013 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + fsnotify LICENSE file: Copyright (c) 2012, Mark Dittmer @@ -2001,40 +2288,93 @@ haskeline LICENSE file: hex LICENSE file: - Page not found: Sorry, it's just not here. + Copyright (c) 2008, Taru Karttunen + All rights reserved. -hfsevents LICENSE file: + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + Neither the name of the Taru Karttunen; nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR + CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - Copyright (c) 2012, Luite Stegeman +hinotify LICENSE file: + + Copyright (c) Lennart Kolmodin All rights reserved. Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: + modification, are permitted provided that the following conditions + are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. - * Neither the name of Luite Stegeman nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + +hostname LICENSE file: + + Copyright (c) 2008, Maximilian Bolingbroke + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, are permitted + provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of + conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of + conditions and the following disclaimer in the documentation and/or other materials + provided with the distribution. + * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to + endorse or promote products derived from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR + CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER + IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT + OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hourglass LICENSE file: @@ -2275,6 +2615,39 @@ iproute LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +kan-extensions LICENSE file: + + Copyright 2008-2013 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + language-javascript LICENSE file: Copyright (c)2010, Alan Zimmerman @@ -2308,6 +2681,39 @@ language-javascript LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +lens LICENSE file: + + Copyright 2012-2015 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + lifted-base LICENSE file: Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg @@ -2340,6 +2746,33 @@ lifted-base LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +managed LICENSE file: + + Copyright (c) 2014 Gabriel Gonzalez + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Gabriel Gonzalez nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + memory LICENSE file: Copyright (c) 2015 Vincent Hanquez @@ -2477,10 +2910,6 @@ monad-logger LICENSE file: OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -monad-loops LICENSE file: - - Page not found: Sorry, it's just not here. - mtl LICENSE file: The Glasgow Haskell Compiler License @@ -2515,6 +2944,35 @@ mtl LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +mwc-random LICENSE file: + + Copyright (c) 2009, Bryan O'Sullivan + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + network LICENSE file: Copyright (c) 2002-2010, The University Court of the University of Glasgow. @@ -2711,6 +3169,33 @@ old-time LICENSE file: ----------------------------------------------------------------------------- +optional-args LICENSE file: + + Copyright (c) 2015 Gabriel Gonzalez + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Gabriel Gonzalez nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + optparse-applicative LICENSE file: Copyright (c) 2012, Paolo Capriotti @@ -2865,7 +3350,7 @@ pem LICENSE file: pipes LICENSE file: - Copyright (c) 2012-2016 Gabriel Gonzalez + Copyright (c) 2012-2014 Gabriel Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without modification, @@ -2917,6 +3402,39 @@ pipes-http LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +prelude-extras LICENSE file: + + Copyright 2011-2016 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + primitive LICENSE file: Copyright (c) 2008-2009, Roman Leshchinskiy @@ -3016,6 +3534,39 @@ process LICENSE file: ----------------------------------------------------------------------------- +profunctors LICENSE file: + + Copyright 2011-2015 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + protolude LICENSE file: Copyright (c) 2016, Stephen Diehl @@ -3138,6 +3689,40 @@ random LICENSE file: ----------------------------------------------------------------------------- +reflection LICENSE file: + + Copyright (c) 2009-2013 Edward Kmett + Copyright (c) 2004 Oleg Kiselyov and Chung-chieh Shan + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Edward Kmett nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + regex-base LICENSE file: This modile is under this "3 clause" BSD license: @@ -3203,7 +3788,7 @@ resourcet LICENSE file: safe LICENSE file: - Copyright Neil Mitchell 2007-2015. + Copyright Neil Mitchell 2007-2016. All rights reserved. Redistribution and use in source and binary forms, with or without @@ -3267,6 +3852,35 @@ scientific LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +semigroupoids LICENSE file: + + Copyright 2011-2015 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + semigroups LICENSE file: Copyright 2011-2015 Edward Kmett @@ -3552,7 +4166,36 @@ streaming-commons LICENSE file: stringsearch LICENSE file: - Page not found: Sorry, it's just not here. + Copyright (c)2010, Daniel Fischer + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Daniel Fischer nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. syb LICENSE file: @@ -3640,6 +4283,56 @@ syb LICENSE file: ----------------------------------------------------------------------------- +system-fileio LICENSE file: + + Copyright (c) 2011 John Millikin + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation + files (the "Software"), to deal in the Software without + restriction, including without limitation the rights to use, + copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following + conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES + OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT + HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, + WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + +system-filepath LICENSE file: + + Copyright (c) 2010 John Millikin + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation + files (the "Software"), to deal in the Software without + restriction, including without limitation the rights to use, + copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following + conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES + OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT + HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, + WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + tagged LICENSE file: Copyright (c) 2009-2015 Edward Kmett @@ -3709,6 +4402,31 @@ template-haskell LICENSE file: DAMAGE. +temporary LICENSE file: + + Copyright (c) 2008, Maximilian Bolingbroke + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, are permitted + provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of + conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of + conditions and the following disclaimer in the documentation and/or other materials + provided with the distribution. + * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to + endorse or promote products derived from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR + CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER + IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT + OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + terminfo LICENSE file: Copyright 2007, Judah Jacobson. @@ -3777,39 +4495,6 @@ time LICENSE file: THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -time-locale-compat LICENSE file: - - Copyright (c) 2014, Kei Hibino - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Kei Hibino nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - tls LICENSE file: Copyright (c) 2010-2015 Vincent Hanquez @@ -3906,7 +4591,7 @@ transformers-base LICENSE file: transformers-compat LICENSE file: - Copyright 2012-2015 Edward Kmett + Copyright 2012 Edward Kmett All rights reserved. @@ -3937,6 +4622,33 @@ transformers-compat LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +turtle LICENSE file: + + Copyright (c) 2015 Gabriel Gonzalez + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Gabriel Gonzalez nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + unix LICENSE file: The Glasgow Haskell Compiler License @@ -4343,7 +5055,36 @@ warp LICENSE file: websockets LICENSE file: - Page not found: Sorry, it's just not here. + Copyright Jasper Van der Jeugt, 2011 + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Siniša Biđin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. word8 LICENSE file: @@ -4499,7 +5240,7 @@ x509-validation LICENSE file: zlib LICENSE file: - Copyright (c) 2006-2015, Duncan Coutts + Copyright (c) 2006-2016, Duncan Coutts All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/license-generator/generate.hs b/license-generator/generate.hs index 391b9b80be..ab47c7a572 100644 --- a/license-generator/generate.hs +++ b/license-generator/generate.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} -- | -- A small script which regenerates the LICENSE file with all -- dependencies' licenses, when the dependencies are provided via standard @@ -5,42 +6,167 @@ -- -- It is recommended to run this as follows: -- --- stack list-dependencies | cut -f 1 -d ' ' | stack exec runhaskell license-generator/generate.hs > LICENSE +-- stack list-dependencies | stack exec runhaskell license-generator/generate.hs > LICENSE -- module Main (main) where -import Control.Monad (forM_) -import Data.Char (isSpace) +import Control.Monad (forM_, when) +import Data.Char (isSpace, toLower) +import Data.Maybe (mapMaybe) import Data.List -import System.Process +import Data.List.Split (splitOn) +import Data.Foldable +import Data.Traversable +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import Network.HTTP.Types (ok200) +import Network.HTTP.Client (Manager, newManager, httpLbs, parseRequest, responseBody, responseStatus) +import Network.HTTP.Client.TLS (tlsManagerSettings) import System.IO (hPutStrLn, stderr, getContents) +import System.Exit (exitFailure) + +main :: IO () +main = do + deps <- depsNamesAndVersions + echoHeader + putStrLn "" + forM_ deps $ \(d, _) -> putStr " " >> putStrLn d + putStrLn "" + manager <- newManager tlsManagerSettings + results <- traverse (\d -> (d,) <$> depsLicense manager d) deps + let failures = filter (not . snd) results + if not (null failures) + then do + hPutStrLn stderr "Licenses were not found for the following packages:" + traverse_ (hPutStrLn stderr . showPair . fst) failures + exitFailure + else + hPutStrLn stderr "Everything looks ok." + + where + showPair (pkg, version) = pkg ++ " " ++ version echoHeader :: IO () echoHeader = - readFile "license-generator/header.txt" >>= putStr - -depsNames :: IO [String] -depsNames = - fmap (filter (/= "purescript") . lines) getContents - -depsLicense :: String -> IO () -depsLicense dep = do - let licenseFile = if dep == "Glob" then "LICENSE.txt" else "LICENSE" - hPutStrLn stderr dep - license <- readProcess "curl" ["--silent", "https://hackage.haskell.org/package/" ++ dep ++ "/src/" ++ licenseFile] "" - putStrLn $ dep ++ " LICENSE file:" - putStrLn "" - putStrLn $ f license + readFile "license-generator/header.txt" >>= putStr + +depsNamesAndVersions :: IO [(String, String)] +depsNamesAndVersions = do + contents <- lines <$> getContents + deps <- traverse parse contents + pure (filter ((/= "purescript") . fst) deps) + where - f = unlines . map (trimEnd . (" " ++)) . lines - trimEnd = reverse . dropWhile isSpace . reverse + parse line = + case splitOn " " line of + [pkg, vers] -> pure (pkg, vers) + _ -> fail $ "Unable to parse input line: " ++ line -main :: IO () -main = do - deps <-depsNames - echoHeader - putStrLn "" - forM_ deps $ \d -> putStr " " >> putStrLn d - putStrLn "" - forM_ deps depsLicense +-- Returns True on success, False on failure. +depsLicense :: Manager -> (String, String) -> IO Bool +depsLicense manager dep = do + hPutStrLn stderr (fst dep) + result <- downloadLicenseFromHackage manager dep + case result of + FoundLicense license -> do + putStrLn $ fst dep ++ " LICENSE file:" + putStrLn "" + putStrLn $ f license + pure True + LicenseNotNeeded -> + pure True + Failed -> + pure False + where + f = unlines . map (trimEnd . (" " ++)) . lines + trimEnd = reverse . dropWhile isSpace . reverse + +data LicenseResult + = FoundLicense String + | LicenseNotNeeded + | Failed + deriving (Show, Eq, Ord) + +downloadLicenseFromHackage :: Manager -> (String, String) -> IO LicenseResult +downloadLicenseFromHackage manager dep = do + mcabalFile <- downloadCabalFileFromHackage manager dep + case mcabalFile of + Nothing -> + pure Failed + Just cabalFile -> + let + field f = extractCabalField f cabalFile + in + case (field "license", field "license-file") of + (_, Just licenseFile) -> do + getLicense licenseFile + (Just "PublicDomain", _) -> do + pure LicenseNotNeeded + _ -> do + hPutStrLn stderr $ + "Unable to extract license information from cabal file for " ++ + fst dep + pure Failed + + where + getLicense licenseFile = do + r <- downloadFromHackage ("/src/" ++ licenseFile) manager dep + pure $ maybe Failed FoundLicense r + +-- Attempt to extract a field from a cabal file. Note that this only works for +-- fields which are at the top level, not inside subsections such as +-- 'executable' or 'test-suite'. +extractCabalField :: String -> String -> Maybe String +extractCabalField fieldName cabalFile = + case mapMaybe (stripPrefixCaseInsensitive fieldName) (lines cabalFile) of + [line] -> + Just $ + line + |> dropWhile isSpace + |> drop 1 -- colon + |> trim + _ -> + Nothing + where + x |> f = f x + + trim = + reverse . dropWhile isSpace . reverse . dropWhile isSpace + + stripPrefixCaseInsensitive prefix str = + if map toLower prefix `isPrefixOf` map toLower str + then Just (drop (length prefix) str) + else Nothing + +downloadCabalFileFromHackage :: Manager -> (String, String) -> IO (Maybe String) +downloadCabalFileFromHackage manager dep = do + downloadFromHackage ("/src/" ++ fst dep ++ ".cabal") manager dep + +downloadFromHackage :: String -> Manager -> (String, String) -> IO (Maybe String) +downloadFromHackage urlpath manager dep = do + let url = hackageBaseUrl dep ++ urlpath + req <- parseRequest url + resp <- httpLbs req manager + + let status = responseStatus resp + if (status /= ok200) + then do + hPutStrLn stderr $ "Bad status code for " ++ url + hPutStrLn stderr $ "Expected 200, got " ++ show status + pure Nothing + else + pure (Just (toString (responseBody resp))) + + where + toString = TL.unpack . TLE.decodeUtf8 + +hackageBaseUrl :: (String, String) -> String +hackageBaseUrl (dep, version) = + concat + [ "https://hackage.haskell.org/package/" + , dep + , "-" + , version + ] From 1afba5aad560ddfd1268e639e3486874c29eff82 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 27 Dec 2016 21:38:20 -0800 Subject: [PATCH 0582/1580] Add --node-path option to PSCi (#2507) * Add --node-path option to PSCi * Don't run findNodeProcess unless we need to --- psci/Main.hs | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/psci/Main.hs b/psci/Main.hs index e86f7583c6..1a8bec898a 100644 --- a/psci/Main.hs +++ b/psci/Main.hs @@ -72,10 +72,16 @@ inputFile = Opts.strArgument $ Opts.metavar "FILE" <> Opts.help "Optional .purs files to load on start" -nodeFlagsFlag :: Opts.Parser [String] -nodeFlagsFlag = Opts.option parser $ +nodePathOption :: Opts.Parser (Maybe FilePath) +nodePathOption = Opts.optional . Opts.strOption $ + Opts.metavar "FILE" + <> Opts.long "node-path" + <> Opts.help "Path to the Node executable" + +nodeFlagsOption :: Opts.Parser [String] +nodeFlagsOption = Opts.option parser $ Opts.long "node-opts" - <> Opts.metavar "NODE_OPTS" + <> Opts.metavar "OPTS" <> Opts.value [] <> Opts.help "Flags to pass to node, separated by spaces" where @@ -90,7 +96,7 @@ port = Opts.option Opts.auto $ backend :: Opts.Parser Backend backend = (browserBackend <$> port) - <|> (nodeBackend <$> nodeFlagsFlag) + <|> (nodeBackend <$> nodePathOption <*> nodeFlagsOption) psciOptions :: Opts.Parser PSCiOptions psciOptions = PSCiOptions <$> many inputFile @@ -293,8 +299,8 @@ browserBackend serverPort = Backend setup evaluate reload shutdown result <- takeMVar resultVar putStrLn result -nodeBackend :: [String] -> Backend -nodeBackend nodeArgs = Backend setup eval reload shutdown +nodeBackend :: Maybe FilePath -> [String] -> Backend +nodeBackend nodePath nodeArgs = Backend setup eval reload shutdown where setup :: IO () setup = return () @@ -302,12 +308,12 @@ nodeBackend nodeArgs = Backend setup eval reload shutdown eval :: () -> String -> IO () eval _ _ = do writeFile indexFile "require('$PSCI')['$main']();" - process <- findNodeProcess + process <- maybe findNodeProcess (pure . pure) nodePath result <- traverse (\node -> readProcessWithExitCode node (nodeArgs ++ [indexFile]) "") process case result of - Just (ExitSuccess, out, _) -> putStrLn out - Just (ExitFailure _, _, err) -> putStrLn err - Nothing -> putStrLn "Couldn't find node.js" + Just (ExitSuccess, out, _) -> putStrLn out + Just (ExitFailure _, _, err) -> putStrLn err + Nothing -> putStrLn "Couldn't find node.js" reload :: () -> IO () reload _ = return () From 5f828927072a199b0268ac9b6d46f7b98067f312 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 11 Dec 2016 11:45:38 +0000 Subject: [PATCH 0583/1580] psc-bundle: Add source map output --- psc-bundle/Main.hs | 39 +++++++-- purescript.cabal | 7 +- src/Language/PureScript/Bundle.hs | 135 +++++++++++++++++++++++------- 3 files changed, 142 insertions(+), 39 deletions(-) diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index ab4a09aa5a..2bd942835d 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -9,6 +9,8 @@ module Main (main) where import Data.Traversable (for) import Data.Version (showVersion) import Data.Monoid ((<>)) +import Data.Aeson (encode) +import Data.Maybe (isNothing) import Control.Applicative import Control.Monad @@ -16,12 +18,15 @@ import Control.Monad.Error.Class import Control.Monad.Trans.Except import Control.Monad.IO.Class -import System.FilePath (takeDirectory) +import System.FilePath (takeDirectory, (), (<.>), takeFileName) import System.FilePath.Glob (glob) import System.Exit (exitFailure) import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8) import System.IO.UTF8 (readUTF8File, writeUTF8File) -import System.Directory (createDirectoryIfMissing) +import System.Directory (createDirectoryIfMissing, getCurrentDirectory) + +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.UTF8 as BU8 import Language.PureScript.Bundle @@ -30,6 +35,9 @@ import qualified Options.Applicative as Opts import qualified Paths_purescript as Paths +import SourceMap +import SourceMap.Types + -- | Command line options. data Options = Options { optionsInputFiles :: [FilePath] @@ -37,25 +45,32 @@ data Options = Options , optionsEntryPoints :: [String] , optionsMainModule :: Maybe String , optionsNamespace :: String + , optionsSourceMaps :: Bool } deriving Show -- | The main application function. -- This function parses the input files, performs dead code elimination, filters empty modules -- and generates and prints the final Javascript bundle. -app :: (MonadError ErrorMessage m, MonadIO m) => Options -> m String +app :: (MonadError ErrorMessage m, MonadIO m) => Options -> m (Maybe SourceMapping, String) app Options{..} = do inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles when (null inputFiles) . liftIO $ do hPutStrLn stderr "psc-bundle: No input files." exitFailure + when (isNothing optionsOutputFile && optionsSourceMaps == True) . liftIO $ do + hPutStrLn stderr "psc-bundle: Source maps only supported when output file specified." + exitFailure + input <- for inputFiles $ \filename -> do js <- liftIO (readUTF8File filename) mid <- guessModuleIdentifier filename - length js `seq` return (mid, js) -- evaluate readFile till EOF before returning, not to exhaust file handles + length js `seq` return (mid, Just filename, js) -- evaluate readFile till EOF before returning, not to exhaust file handles let entryIds = map (`ModuleIdentifier` Regular) optionsEntryPoints - bundle input entryIds optionsMainModule optionsNamespace + currentDir <- liftIO getCurrentDirectory + let outFile = if optionsSourceMaps then fmap (currentDir ) optionsOutputFile else Nothing + bundleSM input entryIds optionsMainModule optionsNamespace outFile -- | Command line options parser. options :: Parser Options @@ -64,6 +79,7 @@ options = Options <$> some inputFile <*> many entryPoint <*> optional mainModule <*> namespace + <*> sourceMaps where inputFile :: Parser FilePath inputFile = Opts.strArgument $ @@ -95,6 +111,11 @@ options = Options <$> some inputFile <> Opts.showDefault <> Opts.help "Specify the namespace that PureScript modules will be exported to when running in the browser." + sourceMaps :: Parser Bool + sourceMaps = Opts.switch $ + Opts.long "source-maps" + <> Opts.help "Whether to generate source maps for the bundle (requires --output)." + -- | Make it go. main :: IO () main = do @@ -106,11 +127,15 @@ main = do Left err -> do hPutStrLn stderr (unlines (printErrorMessage err)) exitFailure - Right js -> + Right (sourcemap, js) -> case optionsOutputFile opts of Just outputFile -> do createDirectoryIfMissing True (takeDirectory outputFile) - writeUTF8File outputFile js + case sourcemap of + Just sm -> do + writeUTF8File outputFile $ js ++ "\n//# sourceMappingURL=" ++ (takeFileName outputFile <.> "map") ++ "\n" + writeUTF8File (outputFile <.> "map") $ BU8.toString . B.toStrict . encode $ generate sm + Nothing -> writeUTF8File outputFile js Nothing -> putStrLn js where infoModList = Opts.fullDesc <> headerInfo <> footerInfo diff --git a/purescript.cabal b/purescript.cabal index d6039f0d6b..9a9b28c429 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -457,14 +457,19 @@ executable psc-bundle other-modules: Paths_purescript other-extensions: build-depends: base >=4 && <5, + bytestring -any, purescript -any, directory -any, + aeson >= 0.8 && < 1.0, filepath -any, Glob -any, mtl -any, optparse-applicative >= 0.12.1, + sourcemap >= 0.1.6, transformers -any, - transformers-compat -any + transformers-compat -any, + utf8-string >= 1 && < 2 + ghc-options: -Wall -O2 hs-source-dirs: psc-bundle diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 2a36afe912..6b63d19f5a 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -6,6 +6,7 @@ -- and generates the final Javascript bundle. module Language.PureScript.Bundle ( bundle + , bundleSM , guessModuleIdentifier , ModuleIdentifier(..) , moduleName @@ -19,6 +20,7 @@ import Prelude.Compat import Control.Monad import Control.Monad.Error.Class +import Control.Arrow ((&&&)) import Data.Char (chr, digitToInt) import Data.Generics (everything, everywhere, mkQ, mkT) @@ -33,7 +35,9 @@ import Language.JavaScript.Parser.AST import qualified Paths_purescript as Paths -import System.FilePath (takeFileName, takeDirectory) +import System.FilePath (takeFileName, takeDirectory, takeDirectory, makeRelative) + +import SourceMap.Types -- | The type of error messages. We separate generation and rendering of errors using a data -- type, in case we need to match on error types later. @@ -98,10 +102,11 @@ data ModuleElement | Member JSStatement Bool String JSExpression [Key] | ExportsList [(ExportType, String, JSExpression, [Key])] | Other JSStatement + | Skip JSStatement deriving (Show) -- | A module is just a list of elements of the types listed above. -data Module = Module ModuleIdentifier [ModuleElement] deriving (Show) +data Module = Module ModuleIdentifier (Maybe FilePath) [ModuleElement] deriving (Show) -- | Prepare an error message for consumption by humans. printErrorMessage :: ErrorMessage -> [String] @@ -159,7 +164,7 @@ checkImportPath name _ _ = Left name -- -- where name is the name of a member defined in the current module. withDeps :: Module -> Module -withDeps (Module modulePath es) = Module modulePath (map expandDeps es) +withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) where -- | Collects all modules which are imported, so that we can identify dependencies of the first type. imports :: [(String, ModuleIdentifier)] @@ -248,9 +253,9 @@ trailingCommaList (JSCTLNone l) = commaList l -- -- Each type of module element is matched using pattern guards, and everything else is bundled into the -- Other constructor. -toModule :: forall m. (MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSAST -> m Module -toModule mids mid top - | JSAstProgram smts _ <- top = Module mid <$> traverse toModuleElement smts +toModule :: forall m. (MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> Maybe FilePath -> JSAST -> m Module +toModule mids mid filename top + | JSAstProgram smts _ <- top = Module mid filename <$> traverse toModuleElement smts | otherwise = err InvalidTopLevel where err = throwError . ErrorInModule mid @@ -389,7 +394,7 @@ compile modules entryPoints = filteredModules -- | The vertex set verts :: [(ModuleElement, Key, [Key])] verts = do - Module mid els <- modules + Module mid _ els <- modules concatMap (toVertices mid) els where -- | Create a set of vertices for a module element. @@ -425,14 +430,21 @@ compile modules entryPoints = filteredModules filteredModules = map filterUsed modules where filterUsed :: Module -> Module - filterUsed (Module mid ds) = Module mid (map filterExports (go ds)) + filterUsed (Module mid fn ds) = Module mid fn (map filterExports (go ds)) where go :: [ModuleElement] -> [ModuleElement] go [] = [] go (d : rest) - | not (isDeclUsed d) = go rest + | not (isDeclUsed d) = skipDecl d : go rest | otherwise = d : go rest + skipDecl :: ModuleElement -> ModuleElement + skipDecl (Require s _ _) = Skip s + skipDecl (Member s _ _ _ _) = Skip s + skipDecl (ExportsList _) = Skip (JSEmptyStatement JSNoAnnot) + skipDecl (Other s) = Skip s + skipDecl (Skip s) = Skip s + -- | Filter out the exports for members which aren't used. filterExports :: ModuleElement -> ModuleElement filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm)) exps) @@ -453,7 +465,7 @@ sortModules :: [Module] -> [Module] sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (topSort graph)) where (graph, nodeFor, _) = graphFromEdges $ do - m@(Module mid els) <- modules + m@(Module mid _ els) <- modules return (m, mid, mapMaybe getKey els) getKey :: ModuleElement -> Maybe ModuleIdentifier @@ -466,12 +478,13 @@ sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (top -- -- If a module is empty, we don't want to generate code for it. isModuleEmpty :: Module -> Bool -isModuleEmpty (Module _ els) = all isElementEmpty els +isModuleEmpty (Module _ _ els) = all isElementEmpty els where isElementEmpty :: ModuleElement -> Bool isElementEmpty (ExportsList exps) = null exps isElementEmpty Require{} = True isElementEmpty (Other _) = True + isElementEmpty (Skip _) = True isElementEmpty _ = False -- | Generate code for a set of modules, including a call to main(). @@ -490,16 +503,62 @@ isModuleEmpty (Module _ els) = all isElementEmpty els codeGen :: Maybe String -- ^ main module -> String -- ^ namespace -> [Module] -- ^ input modules - -> String -codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (prelude : concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule) JSNoAnnot) + -> Maybe String -- ^ output filename + -> (Maybe SourceMapping, String) +codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping outFileOpt, rendered) where - moduleToJS :: Module -> [JSStatement] - moduleToJS (Module mn ds) = wrap (moduleName mn) (indent (concatMap declToJS ds)) + rendered = renderToString (JSAstProgram (prelude : concatMap fst modulesJS ++ maybe [] runMain optionsMainModule) JSNoAnnot) + + sourceMapping :: String -> SourceMapping + sourceMapping outFile = SourceMapping { + smFile = outFile, + smSourceRoot = Nothing, + smMappings = concat $ + zipWith3 (\file (pos :: Int) positions -> + map (\(porig, pgen) -> Mapping { + mapOriginal = Just (Pos (fromIntegral $ porig + 1) 0) + , mapSourceFile = pathToFile <$> file + , mapGenerated = (Pos (fromIntegral $ pos + pgen) 0) + , mapName = Nothing + }) + (offsets (0,0) (Right 1 : positions))) + moduleFns + (scanl (+) (3 + moduleLength [prelude]) (map (3+) moduleLengths)) -- 3 lines between each module & at top + (map snd modulesJS) + } where - declToJS :: ModuleElement -> [JSStatement] - declToJS (Member n _ _ _ _) = [n] - declToJS (Other n) = [n] - declToJS (Require _ nm req) = + pathToFile = makeRelative (takeDirectory outFile) + + offsets (m, n) (Left d:rest) = offsets (m+d, n) rest + offsets (m, n) (Right d:rest) = map ((m+) &&& (n+)) [0 .. d - 1] ++ offsets (m+d, n+d) rest + offsets _ _ = [] + + moduleLength :: [JSStatement] -> Int + moduleLength = everything (+) (mkQ 0 countw) + where + countw :: CommentAnnotation -> Int + countw (WhiteSpace _ s) = length (filter (== '\n') s) + countw _ = 0 + + moduleLengths :: [Int] + moduleLengths = map (sum . map (either (const 0) id) . snd) modulesJS + moduleFns = map (\(Module _ fn _) -> fn) ms + + modulesJS = map moduleToJS ms + + moduleToJS :: Module -> ([JSStatement], [Either Int Int]) + moduleToJS (Module mn _ ds) = (wrap (moduleName mn) (indent (concat jsDecls)), lengths) + where + (jsDecls, lengths) = unzip $ map declToJS ds + + withLength :: [JSStatement] -> ([JSStatement], Either Int Int) + withLength n = (n, Right $ moduleLength n) + + declToJS :: ModuleElement -> ([JSStatement], Either Int Int) + declToJS (Member n _ _ _ _) = withLength [n] + declToJS (Other n) = withLength [n] + declToJS (Skip n) = ([], Left $ moduleLength [n]) + declToJS (Require _ nm req) = withLength [ JSVariable lfsp (cList [ @@ -507,9 +566,10 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p (JSVarInit sp $ either require (moduleReference sp . moduleName) req ) ]) (JSSemi JSNoAnnot) ] - declToJS (ExportsList exps) = map toExport exps + declToJS (ExportsList exps) = withLength $ map toExport exps where + toExport :: (ExportType, String, JSExpression, [Key]) -> JSStatement toExport (_, nm, val, _) = JSAssignStatement @@ -612,26 +672,39 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p -- | The bundling function. -- This function performs dead code elimination, filters empty modules -- and generates and prints the final Javascript bundle. -bundle :: (MonadError ErrorMessage m) - => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. +bundleSM :: (MonadError ErrorMessage m) + => [(ModuleIdentifier, Maybe FilePath, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination -> Maybe String -- ^ An optional main module. -> String -- ^ The namespace (e.g. PS). - -> m String -bundle inputStrs entryPoints mainModule namespace = do + -> Maybe FilePath -- ^ The output file name (if there is one - in which case generate source map) + -> m (Maybe SourceMapping, String) +bundleSM inputStrs entryPoints mainModule namespace outFilename = do + let mid (a,_,_) = a forM_ mainModule $ \mname -> - when (mname `notElem` map (moduleName . fst) inputStrs) (throwError (MissingMainModule mname)) + when (mname `notElem` map (moduleName . mid) inputStrs) (throwError (MissingMainModule mname)) forM_ entryPoints $ \mIdent -> - when (mIdent `notElem` map fst inputStrs) (throwError (MissingEntryPoint (moduleName mIdent))) - input <- forM inputStrs $ \(ident, js) -> do + when (mIdent `notElem` map mid inputStrs) (throwError (MissingEntryPoint (moduleName mIdent))) + input <- forM inputStrs $ \(ident, filename, js) -> do ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident) - return (ident, ast) + return (ident, filename, ast) - let mids = S.fromList (map (moduleName . fst) input) + let mids = S.fromList (map (moduleName . mid) input) - modules <- traverse (fmap withDeps . uncurry (toModule mids)) input + modules <- traverse (fmap withDeps . (\(a,fn,c) -> toModule mids a fn c)) input let compiled = compile modules entryPoints sorted = sortModules (filter (not . isModuleEmpty) compiled) - return (codeGen mainModule namespace sorted) + return (codeGen mainModule namespace sorted outFilename) + +-- | The bundling function. +-- This function performs dead code elimination, filters empty modules +-- and generates and prints the final Javascript bundle. +bundle :: (MonadError ErrorMessage m) + => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. + -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination + -> Maybe String -- ^ An optional main module. + -> String -- ^ The namespace (e.g. PS). + -> m String +bundle inputStrs entryPoints mainModule namespace = snd <$> bundleSM (map (\(a,b) -> (a,Nothing,b)) inputStrs) entryPoints mainModule namespace Nothing From 144dd6f020167d2a21095e315afc5e60b3c2bc2f Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Wed, 28 Dec 2016 18:11:00 +0000 Subject: [PATCH 0584/1580] Add support for user defined kinds (#2486) * Add foreign import kind * Make ForeignKind.Lib visible to example tests * Rename to NamedKind, add kind traversal, update usedModules * More kind updates * Missing type declaration * Undo change to usedModules. * Use the name IdeDeclNamespace and IdeNSValue/etc * Add extern kind filter to binding groups * Replace Symbol with use of NamedKind * Add test for shadowing kind + update foreign kind test * Desugar kind in KindedType when desugaring names + pretty NamedKind * Add fail test for unifying custom kinds across modules * Move * and ! to Type and Effect, Remove ShadowPrimKind test * Add docs for kinds in Prim --- examples/failing/DiffKindsSameName.purs | 15 +++++ examples/failing/DiffKindsSameName/LibA.purs | 4 ++ examples/failing/DiffKindsSameName/LibB.purs | 6 ++ examples/passing/ForeignKind.purs | 10 ++++ examples/passing/ForeignKind/Lib.purs | 60 +++++++++++++++++++ psc-docs/Tags.hs | 1 + purescript.cabal | 2 + src/Language/PureScript/AST/Declarations.hs | 26 +++++++- src/Language/PureScript/AST/Exported.hs | 1 + src/Language/PureScript/AST/Traversals.hs | 43 ++++++++++++- src/Language/PureScript/Constants.hs | 9 +++ .../PureScript/Docs/Convert/ReExports.hs | 24 +++++++- .../PureScript/Docs/Convert/Single.hs | 3 + src/Language/PureScript/Docs/Prim.hs | 46 ++++++++++++-- src/Language/PureScript/Docs/Render.hs | 5 ++ .../PureScript/Docs/RenderedCode/Types.hs | 4 ++ src/Language/PureScript/Docs/Types.hs | 15 +++++ src/Language/PureScript/Environment.hs | 55 ++++++++++++----- src/Language/PureScript/Errors.hs | 5 ++ src/Language/PureScript/Externs.hs | 9 +++ src/Language/PureScript/Ide/Externs.hs | 10 +++- src/Language/PureScript/Ide/SourceFile.hs | 23 +++---- src/Language/PureScript/Ide/Types.hs | 13 +++- src/Language/PureScript/Ide/Util.hs | 2 + src/Language/PureScript/Interactive.hs | 2 + src/Language/PureScript/Interactive/Parser.hs | 1 + src/Language/PureScript/Kinds.hs | 10 ++-- src/Language/PureScript/Names.hs | 8 ++- src/Language/PureScript/Parser/Common.hs | 6 ++ .../PureScript/Parser/Declarations.hs | 17 ++++-- src/Language/PureScript/Parser/Kinds.hs | 18 +++--- src/Language/PureScript/Parser/Lexer.hs | 8 +++ src/Language/PureScript/Pretty/Kinds.hs | 5 +- .../PureScript/Sugar/BindingGroups.hs | 1 + src/Language/PureScript/Sugar/Names.hs | 46 +++++++++++--- src/Language/PureScript/Sugar/Names/Env.hs | 41 ++++++++++--- .../PureScript/Sugar/Names/Exports.hs | 39 ++++++++---- .../PureScript/Sugar/Names/Imports.hs | 6 ++ src/Language/PureScript/TypeChecker.hs | 6 +- src/Language/PureScript/TypeChecker/Kinds.hs | 28 ++++----- src/Language/PureScript/TypeChecker/Types.hs | 2 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 4 +- .../Language/PureScript/Ide/ReexportsSpec.hs | 2 +- .../Language/PureScript/Ide/SourceFileSpec.hs | 24 ++++---- tests/Language/PureScript/Ide/StateSpec.hs | 4 +- tests/TestPrimDocs.hs | 20 ++++--- 46 files changed, 560 insertions(+), 129 deletions(-) create mode 100644 examples/failing/DiffKindsSameName.purs create mode 100644 examples/failing/DiffKindsSameName/LibA.purs create mode 100644 examples/failing/DiffKindsSameName/LibB.purs create mode 100644 examples/passing/ForeignKind.purs create mode 100644 examples/passing/ForeignKind/Lib.purs diff --git a/examples/failing/DiffKindsSameName.purs b/examples/failing/DiffKindsSameName.purs new file mode 100644 index 0000000000..afcf48a3dc --- /dev/null +++ b/examples/failing/DiffKindsSameName.purs @@ -0,0 +1,15 @@ +-- @shouldFailWith KindsDoNotUnify +module DiffKindsSameName where + +import DiffKindsSameName.LibA as LibA +import DiffKindsSameName.LibB as LibB + +-- both `LibA` and `LibB` define a kind locally called `DemoKind` +-- `LibB` defines `DemoData :: LibB.DemoKind` +-- if we try to use `DemoData` in a place where `LibA.DemoKind` is expected, it should fail with `KindsDoNotUnify` + +data AProxy (m :: LibA.DemoKind) = AProxy + +bProxy :: AProxy LibB.DemoData +bProxy = AProxy + diff --git a/examples/failing/DiffKindsSameName/LibA.purs b/examples/failing/DiffKindsSameName/LibA.purs new file mode 100644 index 0000000000..d36b2ec15b --- /dev/null +++ b/examples/failing/DiffKindsSameName/LibA.purs @@ -0,0 +1,4 @@ +module DiffKindsSameName.LibA where + +foreign import kind DemoKind + diff --git a/examples/failing/DiffKindsSameName/LibB.purs b/examples/failing/DiffKindsSameName/LibB.purs new file mode 100644 index 0000000000..52bcb0f42b --- /dev/null +++ b/examples/failing/DiffKindsSameName/LibB.purs @@ -0,0 +1,6 @@ +module DiffKindsSameName.LibB where + +foreign import kind DemoKind + +foreign import data DemoData :: DemoKind + diff --git a/examples/passing/ForeignKind.purs b/examples/passing/ForeignKind.purs new file mode 100644 index 0000000000..0b91f7d99c --- /dev/null +++ b/examples/passing/ForeignKind.purs @@ -0,0 +1,10 @@ +module Main where + +import Prelude +import ForeignKinds.Lib (kind Nat, Zero, Succ, N3, NatProxy, class AddNat, addNat, proxy1, proxy2) +import Control.Monad.Eff.Console (log) + +proxy1Add2Is3 :: NatProxy N3 +proxy1Add2Is3 = addNat proxy1 proxy2 + +main = log "Done" diff --git a/examples/passing/ForeignKind/Lib.purs b/examples/passing/ForeignKind/Lib.purs new file mode 100644 index 0000000000..0ca2c13638 --- /dev/null +++ b/examples/passing/ForeignKind/Lib.purs @@ -0,0 +1,60 @@ +module ForeignKinds.Lib (kind Nat, Kinded, Zero, Succ, N0, N1, N2, N3, NatProxy(..), class AddNat, addNat, proxy1, proxy2) where + +-- declaration + +foreign import kind Nat + +-- use in foreign data + +foreign import data Zero :: Nat +foreign import data Succ :: Nat -> Nat + +-- use in data + +data NatProxy (t :: Nat) = NatProxy + +-- use in type sig + +succProxy :: forall n. NatProxy n -> NatProxy (Succ n) +succProxy _ = NatProxy + +-- use in alias + +type Kinded f = f :: Nat + +type KindedZero = Kinded Zero + +type N0 = Zero +type N1 = Succ N0 +type N2 = Succ N1 +type N3 = Succ N2 + +-- use of alias + +proxy0 :: NatProxy N0 +proxy0 = NatProxy + +proxy1 :: NatProxy N1 +proxy1 = NatProxy + +proxy2 :: NatProxy N2 +proxy2 = NatProxy + +proxy3 :: NatProxy N3 +proxy3 = NatProxy + +-- use in class + +class AddNat (l :: Nat) (r :: Nat) (o :: Nat) | l -> r o + +instance addNatZero + :: AddNat Zero r r + +instance addNatSucc + :: AddNat l r o + => AddNat (Succ l) r (Succ o) + +-- use of class + +addNat :: forall l r o. AddNat l r o => NatProxy l -> NatProxy r -> NatProxy o +addNat _ _ = NatProxy diff --git a/psc-docs/Tags.hs b/psc-docs/Tags.hs index df5d2be060..5bee382868 100644 --- a/psc-docs/Tags.hs +++ b/psc-docs/Tags.hs @@ -17,4 +17,5 @@ tags = map (first T.unpack) . concatMap dtags . P.exportedDeclarations names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name] names (P.TypeClassDeclaration name _ _ _ _) = [P.runProperName name] names (P.TypeInstanceDeclaration name _ _ _ _) = [P.showIdent name] + names (P.ExternKindDeclaration name) = [P.runProperName name] names _ = [] diff --git a/purescript.cabal b/purescript.cabal index 9a9b28c429..12954a6cc9 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -28,6 +28,7 @@ extra-source-files: examples/passing/*.purs , examples/passing/ExplicitImportReExport/*.purs , examples/passing/ExportExplicit/*.purs , examples/passing/ExportExplicit2/*.purs + , examples/passing/ForeignKind/*.purs , examples/passing/Import/*.purs , examples/passing/ImportExplicit/*.purs , examples/passing/ImportQualified/*.purs @@ -63,6 +64,7 @@ extra-source-files: examples/passing/*.purs , examples/failing/ConflictingImports2/*.purs , examples/failing/ConflictingQualifiedImports/*.purs , examples/failing/ConflictingQualifiedImports2/*.purs + , examples/failing/DiffKindsSameName/*.purs , examples/failing/DuplicateModule/*.purs , examples/failing/ExportConflictClass/*.purs , examples/failing/ExportConflictCtor/*.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 9029b1a4c2..781ec09beb 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -240,6 +240,10 @@ data DeclarationRef -- | ModuleRef ModuleName -- | + -- A named kind + -- + | KindRef (ProperName 'KindName) + -- | -- A value re-exported from another module. These will be inserted during -- elaboration in name desugaring. -- @@ -258,6 +262,7 @@ instance Eq DeclarationRef where (TypeClassRef name) == (TypeClassRef name') = name == name' (TypeInstanceRef name) == (TypeInstanceRef name') = name == name' (ModuleRef name) == (ModuleRef name') = name == name' + (KindRef name) == (KindRef name') = name == name' (ReExportRef mn ref) == (ReExportRef mn' ref') = mn == mn' && ref == ref' (PositionedDeclarationRef _ _ r) == r' = r == r' r == (PositionedDeclarationRef _ _ r') = r == r' @@ -274,6 +279,7 @@ compDecRef (ValueOpRef name) (ValueOpRef name') = compare name name' compDecRef (TypeClassRef name) (TypeClassRef name') = compare name name' compDecRef (TypeInstanceRef ident) (TypeInstanceRef ident') = compare ident ident' compDecRef (ModuleRef name) (ModuleRef name') = compare name name' +compDecRef (KindRef name) (KindRef name') = compare name name' compDecRef (ReExportRef name _) (ReExportRef name' _) = compare name name' compDecRef (PositionedDeclarationRef _ _ ref) ref' = compDecRef ref ref' compDecRef ref (PositionedDeclarationRef _ _ ref') = compDecRef ref ref' @@ -286,7 +292,8 @@ compDecRef ref ref' = compare orderOf (TypeRef _ _) = 2 orderOf (ValueRef _) = 3 orderOf (ValueOpRef _) = 4 - orderOf _ = 5 + orderOf (KindRef _) = 5 + orderOf _ = 6 getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) getTypeRef (TypeRef name dctors) = Just (name, dctors) @@ -313,6 +320,11 @@ getTypeClassRef (TypeClassRef name) = Just name getTypeClassRef (PositionedDeclarationRef _ _ r) = getTypeClassRef r getTypeClassRef _ = Nothing +getKindRef :: DeclarationRef -> Maybe (ProperName 'KindName) +getKindRef (KindRef name) = Just name +getKindRef (PositionedDeclarationRef _ _ r) = getKindRef r +getKindRef _ = Nothing + isModuleRef :: DeclarationRef -> Bool isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r isModuleRef (ModuleRef _) = True @@ -381,6 +393,10 @@ data Declaration -- | ExternDataDeclaration (ProperName 'TypeName) Kind -- | + -- A foreign kind import (name) + -- + | ExternKindDeclaration (ProperName 'KindName) + -- | -- A fixity declaration -- | FixityDeclaration (Either ValueFixity TypeFixity) @@ -469,6 +485,14 @@ isExternDataDecl ExternDataDeclaration{} = True isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d isExternDataDecl _ = False +-- | +-- Test if a declaration is a foreign kind import +-- +isExternKindDecl :: Declaration -> Bool +isExternKindDecl ExternKindDeclaration{} = True +isExternKindDecl (PositionedDeclaration _ _ d) = isExternKindDecl d +isExternKindDecl _ = False + -- | -- Test if a declaration is a fixity declaration -- diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index ab9a2f39fc..8c7c720962 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -132,6 +132,7 @@ isExported (Just exps) decl = any (matches decl) exps matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident' matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident' matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident' + matches (ExternKindDeclaration ident) (KindRef ident') = ident == ident' matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident' matches (TypeClassDeclaration ident _ _ _ _) (TypeClassRef ident') = ident == ident' matches (ValueFixityDeclaration _ _ op) (ValueOpRef op') = op == op' diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 610cd7e189..e15b30d5fb 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -14,11 +14,12 @@ import Data.Maybe (mapMaybe) import qualified Data.Set as S import Language.PureScript.AST.Binders -import Language.PureScript.AST.Literals import Language.PureScript.AST.Declarations -import Language.PureScript.Types -import Language.PureScript.Traversals +import Language.PureScript.AST.Literals +import Language.PureScript.Kinds import Language.PureScript.Names +import Language.PureScript.Traversals +import Language.PureScript.Types everywhereOnValues :: (Declaration -> Declaration) @@ -588,6 +589,42 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con forValues (TypedValue _ _ ty) = f ty forValues _ = mempty +accumKinds + :: (Monoid r) + => (Kind -> r) + -> ( Declaration -> r + , Expr -> r + , Binder -> r + , CaseAlternative -> r + , DoNotationElement -> r + ) +accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) + where + forDecls (DataDeclaration _ _ args dctors) = + foldMap (foldMap f . snd) args `mappend` + foldMap (foldMap forTypes . snd) dctors + forDecls (TypeClassDeclaration _ args implies _ _) = + foldMap (foldMap f . snd) args `mappend` + foldMap (foldMap forTypes . constraintArgs) implies + forDecls (TypeInstanceDeclaration _ cs _ tys _) = + foldMap (foldMap forTypes . constraintArgs) cs `mappend` + foldMap forTypes tys + forDecls (TypeSynonymDeclaration _ args ty) = + foldMap (foldMap f . snd) args `mappend` + forTypes ty + forDecls (TypeDeclaration _ ty) = forTypes ty + forDecls (ExternDeclaration _ ty) = forTypes ty + forDecls (ExternDataDeclaration _ kn) = f kn + forDecls _ = mempty + + forValues (TypeClassDictionary c _ _) = foldMap forTypes (constraintArgs c) + forValues (DeferredDictionary _ tys) = foldMap forTypes tys + forValues (TypedValue _ _ ty) = forTypes ty + forValues _ = mempty + + forTypes (KindedType _ k) = f k + forTypes _ = mempty + -- | -- Map a function over type annotations appearing inside a value -- diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index a472387c78..d8d0bbbbff 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -335,6 +335,15 @@ pattern Partial = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName pattern Fail :: Qualified (ProperName 'ClassName) pattern Fail = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Fail") +typ :: Text +typ = "Type" + +effect :: Text +effect = "Effect" + +symbol :: Text +symbol = "Symbol" + -- Code Generation __superclass_ :: Text diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index ecadd9fcb0..044cf98a7b 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -110,13 +110,14 @@ collectDeclarations imports exports = do typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs types <- collect lookupTypeDeclaration impTypes expTypes typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps + kinds <- collect lookupKindDeclaration impKinds expKinds (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses let filteredTypes = filterDataConstructors expCtors types let filteredClasses = filterTypeClassMembers (Map.keys expVals) classes - pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps])) + pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps, kinds])) where @@ -147,6 +148,9 @@ collectDeclarations imports exports = do expTCs = P.exportedTypeClasses exports impTCs = concat (Map.elems (P.importedTypeClasses imports)) + expKinds = P.exportedKinds exports + impKinds = concat (Map.elems (P.importedKinds imports)) + -- | -- Given a list of imported declarations (of a particular kind, ie. type, data, -- class, value, etc), and the name of an exported declaration of the same @@ -304,6 +308,24 @@ lookupTypeClassDeclaration importedFrom tyClass = do ("lookupTypeClassDeclaration: unexpected result: " ++ (unlines . map show) other) +lookupKindDeclaration + :: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) + => P.ModuleName + -> P.ProperName 'P.KindName + -> m (P.ModuleName, [Declaration]) +lookupKindDeclaration importedFrom kind = do + decls <- lookupModuleDeclarations "lookupKindDeclaration" importedFrom + let + ds = filter (\d -> declTitle d == P.runProperName kind + && isKind d) + decls + case ds of + [d] -> + pure (importedFrom, [d]) + other -> + internalErrorInModule + ("lookupKindDeclaration: unexpected result: " ++ show other) + -- | -- Get the full list of declarations for a particular module out of the -- state, or raise an internal error if it is not there. diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index c111c18947..36dbc36218 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -83,6 +83,7 @@ getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name) getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name) getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name) getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name) +getDeclarationTitle (P.ExternKindDeclaration name) = Just (P.runProperName name) getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeClassDeclaration name _ _ _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name) @@ -122,6 +123,8 @@ convertDeclaration (P.DataDeclaration dtype _ args ctors) title = ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys) convertDeclaration (P.ExternDataDeclaration _ kind') title = basicDeclaration title (ExternDataDeclaration kind') +convertDeclaration (P.ExternKindDeclaration _) title = + basicDeclaration title ExternKindDeclaration convertDeclaration (P.TypeSynonymDeclaration _ args ty) title = basicDeclaration title (TypeSynonymDeclaration args ty) convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title = diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 3724ae5355..41b53dce3c 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -5,6 +5,7 @@ import Prelude.Compat hiding (fail) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Map as Map +import qualified Data.Set as Set import Language.PureScript.Docs.Types import qualified Language.PureScript as P @@ -25,6 +26,9 @@ primDocsModule = Module , fail , typeConcat , typeString + , kindType + , kindEffect + , kindSymbol ] , modReExports = [] } @@ -38,16 +42,28 @@ unsafeLookup m errorMsg name = go name fromJust' (Just x) = x fromJust' _ = P.internalError $ errorMsg ++ show name -lookupPrimKind :: Text -> P.Kind -lookupPrimKind = fst . unsafeLookup P.primTypes "Docs.Prim: No such Prim type: " - -primType :: Text -> Text -> Declaration +primKind :: Text -> Text -> Declaration +primKind title comments = + if Set.member (P.primName title) P.primKinds + then Declaration + { declTitle = title + , declComments = Just comments + , declSourceSpan = Nothing + , declChildren = [] + , declInfo = ExternKindDeclaration + } + else P.internalError $ "Docs.Prim: No such Prim kind: " ++ T.unpack title + +lookupPrimTypeKind :: Text -> P.Kind +lookupPrimTypeKind = fst . unsafeLookup P.primTypes "Docs.Prim: No such Prim type: " + +primType :: Text -> Text -> Declaration primType title comments = Declaration { declTitle = title , declComments = Just comments , declSourceSpan = Nothing , declChildren = [] - , declInfo = ExternDataDeclaration (lookupPrimKind title) + , declInfo = ExternDataDeclaration (lookupPrimTypeKind title) } -- | Lookup the TypeClassData of a Prim class. This function is specifically @@ -71,6 +87,26 @@ primClass title comments = Declaration TypeClassDeclaration args superclasses fundeps } +kindType :: Declaration +kindType = primKind "Type" $ T.unlines + [ "`Type` (also known as `*`) is the kind of all proper types: those that" + , "classify value-level terms." + , "For example the type `Boolean` has kind `Type`; denoted by `Boolean :: Type`." + ] + +kindEffect :: Declaration +kindEffect = primKind "Effect" $ T.unlines + [ "`Effect` (also known as `!`) is the kind of all effect types." + ] + +kindSymbol :: Declaration +kindSymbol = primKind "Symbol" $ T.unlines + [ "`Symbol` is the kind of type-level strings." + , "" + , "Construct types of this kind using the same literal syntax as documented" + , "for strings." + ] + function :: Declaration function = primType "Function" $ T.unlines [ "A function, which takes values of the type specified by the first type" diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index f9fa3a804d..639824c3ff 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -80,6 +80,11 @@ renderDeclarationWithOptions opts Declaration{..} = , ident $ adjustAliasName alias declTitle ] + ExternKindDeclaration -> + [ keywordKind + , renderKind (P.NamedKind (notQualified declTitle)) + ] + where renderType' :: P.Type -> RenderedCode renderType' = renderTypeWithOptions opts diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 074a5a1bc3..ea42d66eaf 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -29,6 +29,7 @@ module Language.PureScript.Docs.RenderedCode.Types , keywordInstance , keywordWhere , keywordFixity + , keywordKind ) where import Prelude.Compat @@ -200,3 +201,6 @@ keywordFixity :: P.Associativity -> RenderedCode keywordFixity P.Infixl = keyword "infixl" keywordFixity P.Infixr = keyword "infixr" keywordFixity P.Infix = keyword "infix" + +keywordKind :: RenderedCode +keywordKind = keyword "kind" diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 21d068a1b2..69edffa2b8 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -132,6 +132,11 @@ data DeclarationInfo -- operator's fixity. -- | AliasDeclaration P.Fixity FixityAlias + + -- | + -- A kind declaration + -- + | ExternKindDeclaration deriving (Show, Eq, Ord) convertFundepsToStrings :: [(Text, Maybe P.Kind)] -> [P.FunctionalDependency] -> [([Text], [Text])] @@ -161,6 +166,7 @@ declInfoToString (ExternDataDeclaration _) = "externData" declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym" declInfoToString (TypeClassDeclaration _ _ _) = "typeClass" declInfoToString (AliasDeclaration _ _) = "alias" +declInfoToString ExternKindDeclaration = "kind" isTypeClass :: Declaration -> Bool isTypeClass Declaration{..} = @@ -194,6 +200,12 @@ isTypeAlias Declaration{..} = AliasDeclaration _ (P.Qualified _ d) -> isLeft d _ -> False +isKind :: Declaration -> Bool +isKind Declaration{..} = + case declInfo of + ExternKindDeclaration{} -> True + _ -> False + -- | Discard any children which do not satisfy the given predicate. filterChildren :: (ChildDeclaration -> Bool) -> Declaration -> Declaration filterChildren p decl = @@ -446,6 +458,8 @@ asDeclarationInfo = do "alias" -> AliasDeclaration <$> key "fixity" asFixity <*> key "alias" asFixityAlias + "kind" -> + pure ExternKindDeclaration other -> throwCustomError (InvalidDeclarationType other) @@ -593,6 +607,7 @@ instance A.ToJSON DeclarationInfo where TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty] TypeClassDeclaration args super fundeps -> ["arguments" .= args, "superclasses" .= super, "fundeps" .= fundeps] AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias] + ExternKindDeclaration -> [] instance A.ToJSON ChildDeclarationInfo where toJSON info = A.object $ "declType" .= childDeclInfoToString info : props diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 01adeedf36..9db517a128 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -36,6 +36,8 @@ data Environment = Environment -- ^ Available type class dictionaries , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData -- ^ Type classes + , kinds :: S.Set (Qualified (ProperName 'KindName)) + -- ^ Kinds in scope } deriving Show -- | Information about a type class @@ -70,7 +72,7 @@ data FunctionalDependency = FunctionalDependency -- The initial environment with no values and only the default javascript types defined -- initEnvironment :: Environment -initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses +initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses primKinds -- | -- A constructor for TypeClassData that computes which type class arguments are fully determined. @@ -209,6 +211,21 @@ instance A.FromJSON DataDeclType where primName :: Text -> Qualified (ProperName a) primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName +primKind :: Text -> Kind +primKind = NamedKind . primName + +-- | +-- Kinds in prim +-- +kindType :: Kind +kindType = primKind C.typ + +kindEffect :: Kind +kindEffect = primKind C.effect + +kindSymbol :: Kind +kindSymbol = primKind C.symbol + -- | -- Construct a type in the Prim module -- @@ -285,6 +302,16 @@ isTypeOrApplied t1 t2 = t1 == t2 function :: Type -> Type -> Type function t1 = TypeApp (TypeApp tyFunction t1) +-- | +-- The primitive kinds +primKinds :: S.Set (Qualified (ProperName 'KindName)) +primKinds = + S.fromList + [ primName C.typ + , primName C.effect + , primName C.symbol + ] + -- | -- The primitive types in the external javascript environment with their -- associated kinds. There are also pseudo `Fail` and `Partial` types @@ -293,18 +320,18 @@ function t1 = TypeApp (TypeApp tyFunction t1) primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) primTypes = M.fromList - [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData)) - , (primName "Array", (FunKind Star Star, ExternData)) - , (primName "Record", (FunKind (Row Star) Star, ExternData)) - , (primName "String", (Star, ExternData)) - , (primName "Char", (Star, ExternData)) - , (primName "Number", (Star, ExternData)) - , (primName "Int", (Star, ExternData)) - , (primName "Boolean", (Star, ExternData)) - , (primName "Partial", (Star, ExternData)) - , (primName "Fail", (FunKind Symbol Star, ExternData)) - , (primName "TypeString", (FunKind Star Symbol, ExternData)) - , (primName "TypeConcat", (FunKind Symbol (FunKind Symbol Symbol), ExternData)) + [ (primName "Function", (FunKind kindType (FunKind kindType kindType), ExternData)) + , (primName "Array", (FunKind kindType kindType, ExternData)) + , (primName "Record", (FunKind (Row kindType) kindType, ExternData)) + , (primName "String", (kindType, ExternData)) + , (primName "Char", (kindType, ExternData)) + , (primName "Number", (kindType, ExternData)) + , (primName "Int", (kindType, ExternData)) + , (primName "Boolean", (kindType, ExternData)) + , (primName "Partial", (kindType, ExternData)) + , (primName "Fail", (FunKind kindSymbol kindType, ExternData)) + , (primName "TypeString", (FunKind kindType kindSymbol, ExternData)) + , (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData)) ] -- | @@ -316,7 +343,7 @@ primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses = M.fromList [ (primName "Partial", (makeTypeClassData [] [] [] [])) - , (primName "Fail", (makeTypeClassData [("message", Just Symbol)] [] [] [])) + , (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] [])) ] -- | diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index c4509f7dc9..a3f95e8ff9 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1030,6 +1030,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS nameType (DctorName _) = "data constructor" nameType (TyClassName _) = "type class" nameType (ModName _) = "module" + nameType (KiName _) = "kind" runName :: Qualified Name -> Text runName (Qualified mn (IdentName name)) = @@ -1044,6 +1045,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS showQualified runProperName (Qualified mn name) runName (Qualified mn (TyClassName name)) = showQualified runProperName (Qualified mn name) + runName (Qualified mn (KiName name)) = + showQualified runProperName (Qualified mn name) runName (Qualified Nothing (ModName name)) = runModuleName name runName (Qualified _ ModName{}) = @@ -1148,6 +1151,8 @@ prettyPrintRef (TypeInstanceRef ident) = Just $ showIdent ident prettyPrintRef (ModuleRef name) = Just $ "module " <> runModuleName name +prettyPrintRef (KindRef pn) = + Just $ "kind " <> runProperName pn prettyPrintRef (ReExportRef _ _) = Nothing prettyPrintRef (PositionedDeclarationRef _ _ ref) = diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 12f04ad317..a75d094dbf 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -24,6 +24,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Version (showVersion) import qualified Data.Map as M +import qualified Data.Set as S import Language.PureScript.AST import Language.PureScript.Crash @@ -133,6 +134,10 @@ data ExternsDeclaration = , edInstanceTypes :: [Type] , edInstanceConstraints :: Maybe [Constraint] } + -- | A kind declaration + | EDKind + { edKindName :: ProperName 'KindName + } deriving Show -- | Convert an externs file back into a module @@ -145,6 +150,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps) (typeClasses env) } + applyDecl env (EDKind pn) = env { kinds = S.insert (qual pn) (kinds env) } applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) } where dict :: NamedDict @@ -220,6 +226,9 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} , m2 <- M.elems m1 , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2) ] + toExternsDeclaration (KindRef pn) + | Qualified (Just mn) pn `S.member` kinds env + = [ EDKind pn ] toExternsDeclaration _ = [] $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index d02f6bfcf9..e50fb12fee 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -94,6 +94,7 @@ convertDecl P.EDDataConstructor{..} = Just $ IdeDeclDataConstructor $ convertDecl P.EDValue{..} = Just $ IdeDeclValue $ IdeValue edValueName edValueType convertDecl P.EDClass{..} = Just (IdeDeclTypeClass edClassName) +convertDecl P.EDKind{..} = Just (IdeDeclKind edKindName) convertDecl P.EDInstance{} = Nothing convertOperator :: P.ExternsFixity -> IdeDeclaration @@ -137,9 +138,12 @@ annotateModule (defs, types) (moduleName, decls) = annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op) IdeDeclTypeOperator op -> annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op) + IdeDeclKind i -> + annotateKind (i ^. properNameT) (IdeDeclKind i) where - annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (P.runIdent x)) defs + annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (IdeNSValue (P.runIdent x)) defs , annTypeAnnotation = Map.lookup x types }) - annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) defs}) - annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Right x) defs}) + annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSValue x) defs}) + annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSType x) defs}) + annotateKind x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSKind x) defs}) diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index c0b96957f8..21f1e0c1d7 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -92,25 +92,26 @@ extractSpans -- ^ The surrounding span -> P.Declaration -- ^ The declaration to extract spans from - -> [(Either Text Text, P.SourceSpan)] - -- ^ A @Right@ corresponds to a type level declaration, and a @Left@ to a - -- value level one + -> [(IdeDeclNamespace, P.SourceSpan)] + -- ^ Declarations and their source locations extractSpans ss d = case d of P.PositionedDeclaration ss' _ d' -> extractSpans ss' d' P.ValueDeclaration i _ _ _ -> - [(Left (P.runIdent i), ss)] + [(IdeNSValue (P.runIdent i), ss)] P.TypeSynonymDeclaration name _ _ -> - [(Right (P.runProperName name), ss)] + [(IdeNSType (P.runProperName name), ss)] P.TypeClassDeclaration name _ _ _ members -> - (Right (P.runProperName name), ss) : concatMap (extractSpans' ss) members + (IdeNSType (P.runProperName name), ss) : concatMap (extractSpans' ss) members P.DataDeclaration _ name _ ctors -> - (Right (P.runProperName name), ss) - : map (\(cname, _) -> (Left (P.runProperName cname), ss)) ctors + (IdeNSType (P.runProperName name), ss) + : map (\(cname, _) -> (IdeNSValue (P.runProperName cname), ss)) ctors P.ExternDeclaration ident _ -> - [(Left (P.runIdent ident), ss)] + [(IdeNSValue (P.runIdent ident), ss)] P.ExternDataDeclaration name _ -> - [(Right (P.runProperName name), ss)] + [(IdeNSType (P.runProperName name), ss)] + P.ExternKindDeclaration name -> + [(IdeNSKind (P.runProperName name), ss)] _ -> [] where -- We need this special case to be able to also get the position info for @@ -121,5 +122,5 @@ extractSpans ss d = case d of P.PositionedDeclaration ssP' _ dP' -> extractSpans' ssP' dP' P.TypeDeclaration ident _ -> - [(Left (P.runIdent ident), ssP)] + [(IdeNSValue (P.runIdent ident), ssP)] _ -> [] diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 3408e34bab..75e5d253ec 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -36,6 +36,7 @@ data IdeDeclaration | IdeDeclTypeClass (P.ProperName 'P.ClassName) | IdeDeclValueOperator IdeValueOperator | IdeDeclTypeOperator IdeTypeOperator + | IdeDeclKind (P.ProperName 'P.KindName) deriving (Show, Eq, Ord) data IdeValue = IdeValue @@ -102,7 +103,7 @@ emptyAnn = Annotation Nothing Nothing Nothing type Module = (P.ModuleName, [IdeDeclarationAnn]) -type DefinitionSites a = Map (Either Text Text) a +type DefinitionSites a = Map IdeDeclNamespace a type TypeAnnotations = Map P.Ident P.Type newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotations)) -- ^ SourceSpans for the definition sites of Values and Types aswell as type @@ -214,6 +215,7 @@ identifierFromDeclarationRef :: P.DeclarationRef -> Text identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name +identifierFromDeclarationRef (P.KindRef name) = P.runProperName name identifierFromDeclarationRef _ = "" data Success = @@ -293,3 +295,12 @@ instance ToJSON PursuitResponse where , "package" .= package , "text" .= text ] + +data IdeDeclNamespace = + -- | An identifier in the value namespace + IdeNSValue Text + -- | An identifier in the type namespace + | IdeNSType Text + -- | An identifier in the kind namespace + | IdeNSKind Text + deriving (Show, Eq, Ord) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 0a61278667..3345b9beea 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -49,6 +49,7 @@ identifierFromIdeDeclaration d = case d of IdeDeclTypeClass name -> P.runProperName name IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName + IdeDeclKind name -> P.runProperName name discardAnn :: IdeDeclarationAnn -> IdeDeclaration discardAnn (IdeDeclarationAnn _ d) = d @@ -73,6 +74,7 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) = (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP) IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) -> (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind) + IdeDeclKind k -> (P.runProperName k, "kind") complModule = P.runModuleName m diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index b926383aa9..db1cce724b 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -200,6 +200,8 @@ handleShowImportedModules = do Just $ N.runIdent ident showRef (P.ModuleRef name) = Just $ "module " <> N.runModuleName name + showRef (P.KindRef pn) = + Just $ "kind " <> N.runProperName pn showRef (P.ReExportRef _ _) = Nothing showRef (P.PositionedDeclarationRef _ _ ref) = diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index e310543474..160a04bc40 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -114,6 +114,7 @@ acceptable P.ExternDeclaration{} = True acceptable P.ExternDataDeclaration{} = True acceptable P.TypeClassDeclaration{} = True acceptable P.TypeInstanceDeclaration{} = True +acceptable P.ExternKindDeclaration{} = True acceptable _ = False parseReplQuery' :: String -> Either String ReplQuery diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 519584e47b..78d126b79d 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -6,20 +6,18 @@ import Prelude.Compat import qualified Data.Aeson.TH as A +import Language.PureScript.Names + -- | The data type of kinds data Kind -- | Unification variable of type Kind = KUnknown Int - -- | The kind of types - | Star - -- | The kind of effects - | Bang -- | Kinds for labelled, unordered rows without duplicates | Row Kind -- | Function kinds | FunKind Kind Kind - -- | Type-level strings - | Symbol + -- | A named kind + | NamedKind (Qualified (ProperName 'KindName)) deriving (Show, Eq, Ord) $(A.deriveJSON A.defaultOptions ''Kind) diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 508a256f6d..8ca8fcca08 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -24,6 +24,7 @@ data Name | DctorName (ProperName 'ConstructorName) | TyClassName (ProperName 'ClassName) | ModName ModuleName + | KiName (ProperName 'KindName) deriving (Eq, Show) getIdentName :: Name -> Maybe Ident @@ -117,7 +118,12 @@ instance FromJSON (ProperName a) where -- | -- The closed set of proper name types. -- -data ProperNameType = TypeName | ConstructorName | ClassName | Namespace +data ProperNameType + = TypeName + | ConstructorName + | ClassName + | KindName + | Namespace -- | -- Coerces a ProperName from one ProperNameType to another. This should be used diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index 67b42058e4..d60a394352 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -31,6 +31,12 @@ properName = ProperName <$> uname typeName :: TokenParser (ProperName 'TypeName) typeName = ProperName <$> tyname +-- | +-- Parse a proper name for a kind. +-- +kindName :: TokenParser (ProperName 'KindName) +kindName = ProperName <$> kiname + -- | -- Parse a proper name for a data constructor. -- diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index eea6165a4c..42cfdaf0a0 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -109,12 +109,16 @@ parseValueDeclaration = do return $ maybe value (`Let` value) whereClause parseExternDeclaration :: TokenParser Declaration -parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *> - (ExternDataDeclaration <$> (reserved "data" *> indented *> typeName) - <*> (indented *> doubleColon *> parseKind) - <|> (do ident <- parseIdent - ty <- indented *> doubleColon *> noWildcards parsePolyType - return $ ExternDeclaration ident ty)) +parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *> parseExternAlt where + parseExternAlt = parseExternData <|> parseExternKind <|> parseExternTerm + + parseExternData = ExternDataDeclaration <$> (reserved "data" *> indented *> typeName) + <*> (indented *> doubleColon *> parseKind) + + parseExternKind = ExternKindDeclaration <$> (reserved "kind" *> indented *> kindName) + + parseExternTerm = ExternDeclaration <$> parseIdent + <*> (indented *> doubleColon *> noWildcards parsePolyType) parseAssociativity :: TokenParser Associativity parseAssociativity = @@ -167,6 +171,7 @@ parseDeclarationRef = <|> (ValueOpRef <$> parens parseOperator) <|> parseTypeRef <|> (TypeClassRef <$> (reserved "class" *> properName)) + <|> (KindRef <$> (reserved "kind" *> kindName)) <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName)) <|> (TypeOpRef <$> (indented *> reserved "type" *> parens parseOperator)) where diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs index 6e0c09f980..a0517bfe8f 100644 --- a/src/Language/PureScript/Parser/Kinds.hs +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -5,6 +5,7 @@ module Language.PureScript.Parser.Kinds (parseKind) where import Prelude.Compat +import Language.PureScript.Environment import Language.PureScript.Kinds import Language.PureScript.Parser.Common import Language.PureScript.Parser.Lexer @@ -13,26 +14,27 @@ import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P parseStar :: TokenParser Kind -parseStar = const Star <$> symbol' "*" +parseStar = const kindType <$> symbol' "*" parseBang :: TokenParser Kind -parseBang = const Bang <$> symbol' "!" +parseBang = const kindEffect <$> symbol' "!" -parseSymbol :: TokenParser Kind -parseSymbol = const Symbol <$> uname' "Symbol" +parseNamedKind :: TokenParser Kind +parseNamedKind = NamedKind <$> parseQualified kindName -parseTypeAtom :: TokenParser Kind -parseTypeAtom = indented *> P.choice +parseKindAtom :: TokenParser Kind +parseKindAtom = indented *> P.choice [ parseStar , parseBang - , parseSymbol + , parseNamedKind , parens parseKind ] + -- | -- Parse a kind -- parseKind :: TokenParser Kind -parseKind = P.buildExpressionParser operators parseTypeAtom P. "kind" +parseKind = P.buildExpressionParser operators parseKindAtom P. "kind" where operators = [ [ P.Prefix (symbol' "#" >> return Row) ] , [ P.Infix (rarrow >> return FunKind) P.AssocRight ] ] diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index cbe90f5f41..bdac6087af 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -43,6 +43,7 @@ module Language.PureScript.Parser.Lexer , lname' , qualifier , tyname + , kiname , dconsname , uname , uname' @@ -474,6 +475,12 @@ tyname = token go P. "type name" go (UName s) = Just s go _ = Nothing +kiname :: TokenParser Text +kiname = token go P. "kind name" + where + go (UName s) = Just s + go _ = Nothing + dconsname :: TokenParser Text dconsname = token go P. "data constructor name" where @@ -549,6 +556,7 @@ reservedPsNames :: [Text] reservedPsNames = [ "data" , "newtype" , "type" + , "kind" , "foreign" , "import" , "infixl" diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs index 364ace9e47..0ec29ba446 100644 --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -16,15 +16,14 @@ import Data.Text (Text) import Language.PureScript.Crash import Language.PureScript.Kinds +import Language.PureScript.Names import Language.PureScript.Pretty.Common typeLiterals :: Pattern () Kind String typeLiterals = mkPattern match where - match Star = Just "*" - match Bang = Just "!" - match Symbol = Just "Symbol" match (KUnknown u) = Just $ 'u' : show u + match (NamedKind name) = Just $ T.unpack (showQualified runProperName name) match _ = Nothing matchRow :: Pattern () Kind ((), Kind) diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index a7cd113a67..4d0d7a5676 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -73,6 +73,7 @@ createBindingGroups moduleName = mapM f <=< handleDecls valueVerts = map (\d -> (d, declIdent d, usedIdents moduleName d `intersect` allIdents)) values bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName) return $ filter isImportDecl ds ++ + filter isExternKindDecl ds ++ filter isExternDataDecl ds ++ dataBindingGroupDecls ++ filter isTypeClassDeclaration ds ++ diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 2d2a483ad2..a0ffbfab18 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -25,6 +25,7 @@ import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.Externs +import Language.PureScript.Kinds import Language.PureScript.Linter.Imports import Language.PureScript.Names import Language.PureScript.Sugar.Names.Env @@ -98,6 +99,9 @@ desugarImportsWithEnv externs modules = do exportedRefs :: Ord a => (DeclarationRef -> Maybe a) -> M.Map a ModuleName exportedRefs f = M.fromList $ (, efModuleName) <$> mapMaybe f efExports + exportedKinds :: M.Map (ProperName 'KindName) ModuleName + exportedKinds = exportedRefs getKindRef + updateEnv :: ([Module], Env) -> Module -> m ([Module], Env) updateEnv (ms, env) m@(Module ss _ mn _ refs) = do members <- findExportable m @@ -128,6 +132,7 @@ elaborateExports exps (Module ss coms mn decls refs) = ++ go TypeClassRef exportedTypeClasses ++ go ValueRef exportedValues ++ go ValueOpRef exportedValueOps + ++ go KindRef exportedKinds ++ maybe [] (filter isModuleRef) refs where @@ -165,17 +170,24 @@ renameInModule imports (Module ss coms mn decls exps) = updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d) updateDecl (pos, bound) (DataDeclaration dtype name args dctors) = - (,) (pos, bound) <$> (DataDeclaration dtype name args <$> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors) + (,) (pos, bound) <$> (DataDeclaration dtype name <$> updateTypeArguments pos args + <*> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors) updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) = - (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty) + (,) (pos, bound) <$> (TypeSynonymDeclaration name <$> updateTypeArguments pos ps + <*> updateTypesEverywhere pos ty) updateDecl (pos, bound) (TypeClassDeclaration className args implies deps ds) = - (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure deps <*> pure ds) + (,) (pos, bound) <$> (TypeClassDeclaration className <$> updateTypeArguments pos args + <*> updateConstraints pos implies + <*> pure deps + <*> pure ds) updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) = (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> traverse (updateTypesEverywhere pos) ts <*> pure ds) updateDecl (pos, bound) (TypeDeclaration name ty) = (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty) updateDecl (pos, bound) (ExternDeclaration name ty) = (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty) + updateDecl (pos, bound) (ExternDataDeclaration name ki) = + (,) (pos, bound) <$> (ExternDataDeclaration name <$> updateKindsEverywhere pos ki) updateDecl (pos, bound) (TypeFixityDeclaration fixity alias op) = (,) (pos, bound) <$> (TypeFixityDeclaration fixity <$> updateTypeName alias pos <*> pure op) updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Left alias)) op) = @@ -238,6 +250,19 @@ renameInModule imports (Module ss coms mn decls exps) = letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d letBoundVariable _ = Nothing + updateKindsEverywhere :: Maybe SourceSpan -> Kind -> m Kind + updateKindsEverywhere pos = everywhereOnKindsM updateKind + where + updateKind :: Kind -> m Kind + updateKind (NamedKind name) = NamedKind <$> updateKindName name pos + updateKind k = return k + + updateTypeArguments + :: (Traversable f, Traversable g) + => Maybe SourceSpan + -> f (a, g Kind) -> m (f (a, g Kind)) + updateTypeArguments pos = traverse (sndM (traverse (updateKindsEverywhere pos))) + updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type updateTypesEverywhere pos = everywhereOnTypesM updateType where @@ -245,16 +270,17 @@ renameInModule imports (Module ss coms mn decls exps) = updateType (TypeOp name) = TypeOp <$> updateTypeOpName name pos updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos updateType (ConstrainedType cs t) = ConstrainedType <$> traverse updateInConstraint cs <*> pure t + updateType (KindedType t k) = KindedType t <$> updateKindsEverywhere pos k updateType t = return t updateInConstraint :: Constraint -> m Constraint updateInConstraint (Constraint name ts info) = Constraint <$> updateClassName name pos <*> pure ts <*> pure info updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint] - updateConstraints pos = traverse $ \(Constraint name ts info) -> - Constraint - <$> updateClassName name pos - <*> traverse (updateTypesEverywhere pos) ts + updateConstraints pos = traverse $ \(Constraint name ts info) -> + Constraint + <$> updateClassName name pos + <*> traverse (updateTypesEverywhere pos) ts <*> pure info updateTypeName @@ -290,6 +316,12 @@ renameInModule imports (Module ss coms mn decls exps) = -> m (Qualified (OpName 'ValueOpName)) updateValueOpName = update (importedValueOps imports) ValOpName + updateKindName + :: Qualified (ProperName 'KindName) + -> Maybe SourceSpan + -> m (Qualified (ProperName 'KindName)) + updateKindName = update (importedKinds imports) KiName + -- Update names so unqualified references become qualified, and locally -- qualified references are replaced with their canoncial qualified names -- (e.g. M.Map -> Data.Map.Map). diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 36c5700a98..7b527e4dee 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -16,6 +16,7 @@ module Language.PureScript.Sugar.Names.Env , exportTypeClass , exportValue , exportValueOp + , exportKind , getExports , checkImportConflicts ) where @@ -71,27 +72,27 @@ type ImportMap a = M.Map (Qualified a) [ImportRecord a] data Imports = Imports { -- | - -- Local names for types within a module mapped to to their qualified names + -- Local names for types within a module mapped to their qualified names -- importedTypes :: ImportMap (ProperName 'TypeName) -- | - -- Local names for type operators within a module mapped to to their qualified names + -- Local names for type operators within a module mapped to their qualified names -- , importedTypeOps :: ImportMap (OpName 'TypeOpName) -- | - -- Local names for data constructors within a module mapped to to their qualified names + -- Local names for data constructors within a module mapped to their qualified names -- , importedDataConstructors :: ImportMap (ProperName 'ConstructorName) -- | - -- Local names for classes within a module mapped to to their qualified names + -- Local names for classes within a module mapped to their qualified names -- , importedTypeClasses :: ImportMap (ProperName 'ClassName) -- | - -- Local names for values within a module mapped to to their qualified names + -- Local names for values within a module mapped to their qualified names -- , importedValues :: ImportMap Ident -- | - -- Local names for value operators within a module mapped to to their qualified names + -- Local names for value operators within a module mapped to their qualified names -- , importedValueOps :: ImportMap (OpName 'ValueOpName) -- | @@ -104,10 +105,14 @@ data Imports = Imports -- The "as" names of modules that have been imported qualified. -- , importedQualModules :: S.Set ModuleName + -- | + -- Local names for kinds within a module mapped to their qualified names + -- + , importedKinds :: ImportMap (ProperName 'KindName) } deriving (Show) nullImports :: Imports -nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty +nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty M.empty -- | -- An 'Imports' value with imports for the `Prim` module. @@ -117,6 +122,7 @@ primImports = nullImports { importedTypes = M.fromList $ mkEntries `concatMap` M.keys primTypes , importedTypeClasses = M.fromList $ mkEntries `concatMap` M.keys primClasses + , importedKinds = M.fromList $ mkEntries `concatMap` S.toList primKinds } where mkEntries :: Qualified a -> [(Qualified a, [ImportRecord a])] @@ -155,13 +161,17 @@ data Exports = Exports -- from. -- , exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName + -- | + -- The exported kinds along with the module they originally came from. + -- + , exportedKinds :: M.Map (ProperName 'KindName) ModuleName } deriving (Show) -- | -- An empty 'Exports' value. -- nullExports :: Exports -nullExports = Exports M.empty M.empty M.empty M.empty M.empty +nullExports = Exports M.empty M.empty M.empty M.empty M.empty M.empty -- | -- The imports and exports for a collection of modules. The 'SourceSpan' is used @@ -196,10 +206,12 @@ primExports = nullExports { exportedTypes = M.fromList $ mkTypeEntry `map` M.keys primTypes , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys primClasses + , exportedKinds = M.fromList $ mkKindEntry `map` S.toList primKinds } where mkTypeEntry (Qualified mn name) = (name, ([], fromJust mn)) mkClassEntry (Qualified mn name) = (name, fromJust mn) + mkKindEntry (Qualified mn name) = (name, fromJust mn) -- | Environment which only contains the Prim module. primEnv :: Env @@ -316,6 +328,19 @@ exportValueOp exps op mn = do valueOps <- addExport ValOpName op mn (exportedValueOps exps) return $ exps { exportedValueOps = valueOps } +-- | +-- Safely adds a kind to some exports, returning an error if a conflict occurs. +-- +exportKind + :: MonadError MultipleErrors m + => Exports + -> ProperName 'KindName + -> ModuleName + -> m Exports +exportKind exps name mn = do + kinds <- addExport KiName name mn (exportedKinds exps) + return $ exps { exportedKinds = kinds } + -- | -- Adds an entry to a list of exports unless it is already present, in which -- case an error is returned. diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 51facc0b6c..ac502f5877 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -19,7 +19,7 @@ import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.Names -import Language.PureScript.Sugar.Names.Env +import Language.PureScript.Sugar.Names.Env import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) -- | @@ -51,6 +51,8 @@ findExportable (Module _ _ mn ds _) = exportTypeOp exps op mn updateExports exps (ExternDeclaration name _) = exportValue exps name mn + updateExports exps (ExternKindDeclaration pn) = + exportKind exps pn mn updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d updateExports exps _ = return exps @@ -61,21 +63,21 @@ findExportable (Module _ _ mn ds _) = -- resolveExports :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => Env - -> SourceSpan + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Env + -> SourceSpan -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports -resolveExports env ss mn imps exps refs = - warnAndRethrow (addHint (ErrorInModule mn)) $ do +resolveExports env ss mn imps exps refs = + warnAndRethrow (addHint (ErrorInModule mn)) $ do filtered <- filterModule mn exps refs - exps' <- foldM elaborateModuleExports filtered refs - warnDuplicateRefs ss DuplicateExportRef refs - return exps' - + exps' <- foldM elaborateModuleExports filtered refs + warnDuplicateRefs ss DuplicateExportRef refs + return exps' + where -- Takes the current module's imports, the accumulated list of exports, and a @@ -83,19 +85,21 @@ resolveExports env ss mn imps exps refs = -- module, export anything from the imports that matches for that module. elaborateModuleExports :: Exports -> DeclarationRef -> m Exports elaborateModuleExports result (PositionedDeclarationRef pos _ r) = - warnAndRethrowWithPosition pos $ elaborateModuleExports result r + warnAndRethrowWithPosition pos $ elaborateModuleExports result r elaborateModuleExports result (ModuleRef name) | name == mn = do let types' = exportedTypes result `M.union` exportedTypes exps let typeOps' = exportedTypeOps result `M.union` exportedTypeOps exps let classes' = exportedTypeClasses result `M.union` exportedTypeClasses exps let values' = exportedValues result `M.union` exportedValues exps let valueOps' = exportedValueOps result `M.union` exportedValueOps exps + let kinds' = exportedKinds result `M.union` exportedKinds exps return result { exportedTypes = types' , exportedTypeOps = typeOps' , exportedTypeClasses = classes' , exportedValues = values' , exportedValueOps = valueOps' + , exportedKinds = kinds' } elaborateModuleExports result (ModuleRef name) = do let isPseudo = isPseudoModule name @@ -107,11 +111,13 @@ resolveExports env ss mn imps exps refs = reClasses <- extract isPseudo name TyClassName (importedTypeClasses imps) reValues <- extract isPseudo name IdentName (importedValues imps) reValueOps <- extract isPseudo name ValOpName (importedValueOps imps) + reKinds <- extract isPseudo name KiName (importedKinds imps) foldM (\exps' ((tctor, dctors), mn') -> exportType ReExport exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors) >>= flip (foldM (uncurry . exportTypeOp)) (map resolveTypeOp reTypeOps) >>= flip (foldM (uncurry . exportTypeClass ReExport)) (map resolveClass reClasses) >>= flip (foldM (uncurry . exportValue)) (map resolveValue reValues) >>= flip (foldM (uncurry . exportValueOp)) (map resolveValueOp reValueOps) + >>= flip (foldM (uncurry . exportKind)) (map resolveKind reKinds) elaborateModuleExports result _ = return result -- Extracts a list of values for a module based on a lookup table. If the @@ -146,6 +152,7 @@ resolveExports env ss mn imps exps refs = || any (isQualifiedWith mn') (f (importedTypeClasses imps)) || any (isQualifiedWith mn') (f (importedValues imps)) || any (isQualifiedWith mn') (f (importedValueOps imps)) + || any (isQualifiedWith mn') (f (importedKinds imps)) -- Check whether a module name refers to a module that has been imported -- without qualification into an import scope. @@ -203,6 +210,14 @@ resolveExports env ss mn imps exps refs = . fromMaybe (internalError "Missing value in resolveValueOp") $ resolve exportedValueOps op + -- Looks up an imported kind and re-qualifies it with the original + -- module it came from. + resolveKind :: Qualified (ProperName 'KindName) -> (ProperName 'KindName, ModuleName) + resolveKind kind + = splitQual + . fromMaybe (internalError "Missing value in resolveKind") + $ resolve exportedKinds kind + resolve :: Ord a => (Exports -> M.Map a ModuleName) @@ -237,12 +252,14 @@ filterModule mn exps refs = do classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) M.empty refs values <- foldM (filterExport IdentName getValueRef exportedValues) M.empty refs valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) M.empty refs + kinds <- foldM (filterExport KiName getKindRef exportedKinds) M.empty refs return Exports { exportedTypes = types , exportedTypeOps = typeOps , exportedTypeClasses = classes , exportedValues = values , exportedValueOps = valueOps + , exportedKinds = kinds } where diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 616921b6d3..9250038ce5 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -130,6 +130,8 @@ resolveImport importModule exps imps impQual = resolveByType checkImportExists TyClassName (exportedTypeClasses exps) name check (ModuleRef name) | isHiding = throwError . errorMessage $ ImportHidingModule name + check (KindRef name) = do + checkImportExists KiName (exportedKinds exps) name check r = internalError $ "Invalid argument to checkRefs: " ++ show r -- Check that an explicitly imported item exists in the module it is being imported from @@ -181,6 +183,7 @@ resolveImport importModule exps imps impQual = resolveByType >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (M.toList (exportedValues exps)) >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (M.toList (exportedValueOps exps)) >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (M.toList (exportedTypeClasses exps)) + >>= flip (foldM (\m (name, _) -> importer m (KindRef name))) (M.toList (exportedKinds exps)) importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports importRef prov imp (PositionedDeclarationRef pos _ r) = @@ -205,6 +208,9 @@ resolveImport importModule exps imps impQual = resolveByType importRef prov imp (TypeClassRef name) = do let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) id name prov return $ imp { importedTypeClasses = typeClasses' } + importRef prov imp (KindRef name) = do + let kinds' = updateImports (importedKinds imp) (exportedKinds exps) id name prov + return $ imp { importedKinds = kinds' } importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef" importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef" importRef _ _ ReExportRef{} = internalError "ReExportRef in importRef" diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 9b6e1bbdb8..6b6ee209f8 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -274,11 +274,15 @@ typeCheckAll moduleName _ = traverse go env <- getEnv putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) } return d + go (d@(ExternKindDeclaration name)) = do + env <- getEnv + putEnv $ env { kinds = S.insert (Qualified (Just moduleName) name) (kinds env) } + return d go (d@(ExternDeclaration name ty)) = do warnAndRethrow (addHint (ErrorInForeignImport name)) $ do env <- getEnv kind <- kindOf ty - guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star + guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType case M.lookup (Qualified (Just moduleName) name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name Nothing -> putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, External, Defined) (names env) }) diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index fedd623916..05e7a1eae1 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -85,9 +85,7 @@ unifyKinds k1 k2 = do go (KUnknown u1) (KUnknown u2) | u1 == u2 = return () go (KUnknown u) k = solveKind u k go k (KUnknown u) = solveKind u k - go Star Star = return () - go Bang Bang = return () - go Symbol Symbol = return () + go (NamedKind k1') (NamedKind k2') | k1' == k2' = return () go (Row k1') (Row k2') = go k1' k2' go (FunKind k1' k2') (FunKind k3 k4) = do go k1' k3 @@ -182,15 +180,15 @@ solveTypes solveTypes isData ts kargs tyCon = do ks <- traverse (fmap fst . infer) ts when isData $ do - unifyKinds tyCon (foldr FunKind Star kargs) - forM_ ks $ \k -> unifyKinds k Star + unifyKinds tyCon (foldr FunKind kindType kargs) + forM_ ks $ \k -> unifyKinds k kindType unless isData $ unifyKinds tyCon (foldr FunKind (head ks) kargs) return tyCon --- | Default all unknown kinds to the Star kind of types +-- | Default all unknown kinds to the kindType kind of types starIfUnknown :: Kind -> Kind -starIfUnknown (KUnknown _) = Star +starIfUnknown (KUnknown _) = kindType starIfUnknown (Row k) = Row (starIfUnknown k) starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2) starIfUnknown k = k @@ -211,8 +209,8 @@ infer' (ForAll ident ty _) = do k1 <- freshKind Just moduleName <- checkCurrentModule <$> get (k2, args) <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty - unifyKinds k2 Star - return (Star, (ident, k1) : args) + unifyKinds k2 kindType + return (kindType, (ident, k1) : args) infer' (KindedType ty k) = do (k', args) <- infer ty unifyKinds k k' @@ -224,14 +222,14 @@ infer' other = (, []) <$> go other k1 <- freshKind Just moduleName <- checkCurrentModule <$> get k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ go ty - unifyKinds k2 Star - return Star + unifyKinds k2 kindType + return kindType go (KindedType ty k) = do k' <- go ty unifyKinds k k' return k' go TypeWildcard{} = freshKind - go (TypeLevelString _) = return Symbol + go (TypeLevelString _) = return kindSymbol go (TypeVar v) = do Just moduleName <- checkCurrentModule <$> get lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) @@ -260,8 +258,8 @@ infer' other = (, []) <$> go other go (ConstrainedType deps ty) = do forM_ deps $ \(Constraint className tys _) -> do k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys - unifyKinds k Star + unifyKinds k kindType k <- go ty - unifyKinds k Star - return Star + unifyKinds k kindType + return kindType go ty = internalError $ "Invalid argument to infer: " ++ show ty diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index e417a4acae..665f569b29 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -240,7 +240,7 @@ checkTypeKind :: Type -> Kind -> m () -checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star +checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType -- | Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns -- or TypeClassDictionary values. diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index bba7441452..e830ed01c8 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -74,7 +74,7 @@ spec = do addDtorImport i t mn is = prettyPrintImportSection (addExplicitImport' (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName i) t wildcard)) mn is) addTypeImport i mn is = - prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.Star)) mn is) + prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.kindType)) mn is) it "adds an implicit unqualified import" $ shouldBe (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map")) @@ -143,7 +143,7 @@ spec = do moduleName = (P.moduleNameFromString "Control.Monad") addImport imports import' = addExplicitImport' import' moduleName imports valueImport ident = (IdeDeclValue (IdeValue (P.Ident ident) wildcard)) - typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.Star)) + typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.kindType)) classImport name = (IdeDeclTypeClass (P.ProperName name)) dtorImport name typeName = (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName name) (P.ProperName typeName) wildcard)) -- expect any list of provided identifiers, when imported, to come out as specified diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index d5d394c007..adbdc743b0 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -18,7 +18,7 @@ d = IdeDeclarationAnn emptyAnn valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn valueA = d (IdeDeclValue (IdeValue (P.Ident "valueA") P.REmpty)) -typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.Star)) +typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.kindType)) classA = d (IdeDeclTypeClass (P.ProperName "ClassA")) dtorA1 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty)) dtorA2 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty)) diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index ac53dde327..eae3de7688 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -6,6 +6,7 @@ import Protolude import qualified Language.PureScript as P import Language.PureScript.Ide.SourceFile +import Language.PureScript.Ide.Types import Test.Hspec span0, span1, span2 :: P.SourceSpan @@ -13,7 +14,7 @@ span0 = P.SourceSpan "ModuleLevel" (P.SourcePos 0 0) (P.SourcePos 1 1) span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2) span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3) -typeAnnotation1, value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, member1 :: P.Declaration +typeAnnotation1, value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, foreign3, member1 :: P.Declaration typeAnnotation1 = P.TypeDeclaration (P.Ident "value1") P.REmpty value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left []) synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty @@ -23,28 +24,31 @@ class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] [] data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] [] data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])] foreign1 = P.ExternDeclaration (P.Ident "foreign1") P.REmpty -foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.Star +foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.kindType +foreign3 = P.ExternKindDeclaration (P.ProperName "Foreign3") member1 = P.TypeDeclaration (P.Ident "member1") P.REmpty spec :: Spec spec = do describe "Extracting Spans" $ do it "extracts a span for a value declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(Left "value1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(IdeNSValue "value1", span1)] it "extracts a span for a type synonym declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(Right "Synonym1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(IdeNSType "Synonym1", span1)] it "extracts a span for a typeclass declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(Right "Class1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(IdeNSType "Class1", span1)] it "extracts spans for a typeclass declaration and its members" $ - extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(Right "Class2", span1), (Left "member1", span2)] + extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(IdeNSType "Class2", span1), (IdeNSValue "member1", span2)] it "extracts a span for a data declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(Right "Data1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(IdeNSType "Data1", span1)] it "extracts spans for a data declaration and its constructors" $ - extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(Right "Data2", span1), (Left "Cons1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(IdeNSType "Data2", span1), (IdeNSValue "Cons1", span1)] it "extracts a span for a foreign declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(Left "foreign1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(IdeNSValue "foreign1", span1)] it "extracts a span for a data foreign declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(Right "Foreign2", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(IdeNSType "Foreign2", span1)] + it "extracts a span for a foreign kind declaration" $ + extractSpans span0 (P.PositionedDeclaration span1 [] foreign3) `shouldBe` [(IdeNSKind "Foreign3", span1)] describe "Type annotations" $ do it "extracts a type annotation" $ extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.REmpty)] diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index 27796629c9..5126fe24f5 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -24,7 +24,7 @@ typeOperator = testModule :: Module testModule = (mn "Test", [ d (IdeDeclValue (IdeValue (P.Ident "function") P.REmpty)) , d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty))) - , d (IdeDeclType (IdeType (P.ProperName "List") P.Star)) + , d (IdeDeclType (IdeType (P.ProperName "List") P.kindType)) , valueOperator Nothing , ctorOperator Nothing , typeOperator Nothing @@ -48,4 +48,4 @@ spec = describe "resolving operators" $ do it "resolves the type for a constructor operator" $ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.REmpty)) it "resolves the kind for a type operator" $ - resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.Star)) + resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.kindType)) diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index 10462b78a0..9309684dcb 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -3,6 +3,7 @@ module TestPrimDocs where import Control.Monad import Data.List ((\\)) import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Language.PureScript as P import qualified Language.PureScript.Docs as D import qualified Language.PureScript.Docs.AsMarkdown as D @@ -13,14 +14,17 @@ main = do seq (D.runDocs (D.modulesAsMarkdown [D.primDocsModule])) (return ()) putStrLn "Test that Prim is fully documented" - let actualPrimTypes = map (P.runProperName . P.disqualify . fst) $ Map.toList P.primTypes - let documentedPrimTypes = map D.declTitle (D.modDeclarations D.primDocsModule) + let actualPrimNames = + -- note that prim type classes are listed in P.primTypes + (map (P.runProperName . P.disqualify . fst) $ Map.toList P.primTypes) ++ + (map (P.runProperName . P.disqualify) $ Set.toList P.primKinds) + let documentedPrimNames = map D.declTitle (D.modDeclarations D.primDocsModule) - let undocumentedTypes = actualPrimTypes \\ documentedPrimTypes - let extraTypes = documentedPrimTypes \\ actualPrimTypes + let undocumentedNames = actualPrimNames \\ documentedPrimNames + let extraNames = documentedPrimNames \\ actualPrimNames - when (not (null undocumentedTypes)) $ - error $ "Undocumented Prim types: " ++ show undocumentedTypes + when (not (null undocumentedNames)) $ + error $ "Undocumented Prim names: " ++ show undocumentedNames - when (not (null extraTypes)) $ - error $ "Extra Prim types: " ++ show undocumentedTypes + when (not (null extraNames)) $ + error $ "Extra Prim names: " ++ show undocumentedNames From 88fdceeefb01bd6a3ff28e9fc8919b50308d8924 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Fri, 30 Dec 2016 01:25:25 +0000 Subject: [PATCH 0585/1580] Solving CompareSymbol and AppendSymbol (#2511) * update test support * Solve CompareSymbol and AppendSymbol * Pass foreign support through on testing + fix solving tests --- examples/passing/SolvingAppendSymbol.purs | 32 +++++++++++++++ examples/passing/SolvingCompareSymbol.purs | 30 ++++++++++++++ src/Language/PureScript/Constants.hs | 39 +++++++++++++++++-- .../PureScript/TypeChecker/Entailment.hs | 27 +++++++++++-- tests/TestCompiler.hs | 39 +++++++++++-------- tests/TestUtils.hs | 27 ++++++++++++- tests/support/bower.json | 21 +++++----- 7 files changed, 178 insertions(+), 37 deletions(-) create mode 100644 examples/passing/SolvingAppendSymbol.purs create mode 100644 examples/passing/SolvingCompareSymbol.purs diff --git a/examples/passing/SolvingAppendSymbol.purs b/examples/passing/SolvingAppendSymbol.purs new file mode 100644 index 0000000000..41fa545829 --- /dev/null +++ b/examples/passing/SolvingAppendSymbol.purs @@ -0,0 +1,32 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Type.Data.Symbol (SProxy(..), class AppendSymbol, appendSymbol, reflectSymbol) + +sym :: SProxy "" +sym = SProxy + +symA :: SProxy "A" +symA = SProxy + +symB :: SProxy "B" +symB = SProxy + +egAB :: SProxy "AB" +egAB = appendSymbol symA symB + +egBA :: SProxy "BA" +egBA = appendSymbol symB symA + +egA' :: SProxy "A" +egA' = appendSymbol sym (appendSymbol symA sym) + +main = do + let gotAB = reflectSymbol egAB == "AB" + gotBA = reflectSymbol egBA == "BA" + gotA' = reflectSymbol egA' == "A" + when (not gotAB) $ log "Did not get AB" + when (not gotBA) $ log "Did not get BA" + when (not gotA') $ log "Did not get A" + when (gotAB && gotBA && gotA') $ log "Done" diff --git a/examples/passing/SolvingCompareSymbol.purs b/examples/passing/SolvingCompareSymbol.purs new file mode 100644 index 0000000000..24ffece8a7 --- /dev/null +++ b/examples/passing/SolvingCompareSymbol.purs @@ -0,0 +1,30 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Type.Data.Symbol (SProxy(..), class CompareSymbol, compareSymbol) +import Type.Data.Ordering (OProxy(..), kind Ordering, LT, EQ, GT, reflectOrdering) + +symA :: SProxy "A" +symA = SProxy + +symB :: SProxy "B" +symB = SProxy + +egLT :: OProxy LT +egLT = compareSymbol symA symB + +egEQ :: OProxy EQ +egEQ = compareSymbol symA symA + +egGT :: OProxy GT +egGT = compareSymbol symB symA + +main = do + let gotLT = reflectOrdering egLT == LT + gotEQ = reflectOrdering egEQ == EQ + gotGT = reflectOrdering egGT == GT + when (not gotLT) $ log "Did not get LT" + when (not gotEQ) $ log "Did not get EQ" + when (not gotGT) $ log "Did not get GT" + when (gotLT && gotEQ && gotGT) $ log "Done" diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index d8d0bbbbff..e068656b0c 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -314,10 +314,38 @@ fromSpine = "fromSpine" toSignature :: Text toSignature = "toSignature" --- IsSymbol class +-- Data.Symbol + +pattern DataSymbol :: ModuleName +pattern DataSymbol = ModuleName [ProperName "Data", ProperName "Symbol"] pattern IsSymbol :: Qualified (ProperName 'ClassName) -pattern IsSymbol = Qualified (Just (ModuleName [ProperName "Data", ProperName "Symbol"])) (ProperName "IsSymbol") +pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol") + +-- Type.Data.Symbol + +pattern TypeDataSymbol :: ModuleName +pattern TypeDataSymbol = ModuleName [ProperName "Type", ProperName "Data", ProperName "Symbol"] + +pattern CompareSymbol :: Qualified (ProperName 'ClassName) +pattern CompareSymbol = Qualified (Just TypeDataSymbol) (ProperName "CompareSymbol") + +pattern AppendSymbol :: Qualified (ProperName 'ClassName) +pattern AppendSymbol = Qualified (Just TypeDataSymbol) (ProperName "AppendSymbol") + +-- Type.Data.Ordering + +typeDataOrdering :: ModuleName +typeDataOrdering = ModuleName [ProperName "Type", ProperName "Data", ProperName "Ordering"] + +orderingLT :: Qualified (ProperName 'TypeName) +orderingLT = Qualified (Just typeDataOrdering) (ProperName "LT") + +orderingEQ :: Qualified (ProperName 'TypeName) +orderingEQ = Qualified (Just typeDataOrdering) (ProperName "EQ") + +orderingGT :: Qualified (ProperName 'TypeName) +orderingGT = Qualified (Just typeDataOrdering) (ProperName "GT") -- Main module @@ -329,11 +357,14 @@ main = "main" partial :: Text partial = "Partial" +pattern Prim :: ModuleName +pattern Prim = ModuleName [ProperName "Prim"] + pattern Partial :: Qualified (ProperName 'ClassName) -pattern Partial = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Partial") +pattern Partial = Qualified (Just Prim) (ProperName "Partial") pattern Fail :: Qualified (ProperName 'ClassName) -pattern Fail = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Fail") +pattern Fail = Qualified (Just Prim) (ProperName "Fail") typ :: Text typ = "Type" diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 85c5326dff..ae5374fbab 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -45,6 +45,10 @@ data Evidence -- ^ An existing named instance | IsSymbolInstance Text -- ^ Computed instance of the IsSymbol type class for a given Symbol literal + | CompareSymbolInstance + -- ^ Computed instance of CompareSymbol + | AppendSymbolInstance + -- ^ Computed instance of AppendSymbol deriving (Eq) -- | Extract the identifier of a named instance @@ -138,7 +142,18 @@ entails SolverOptions{..} constraint context hints = solve constraint where forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict] - forClassName _ C.IsSymbol [TypeLevelString sym] = [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing] + forClassName _ C.IsSymbol [TypeLevelString sym] = + [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing] + forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = + let ordering = case compare lhs rhs of + LT -> C.orderingLT + EQ -> C.orderingEQ + GT -> C.orderingGT + args = [arg0, arg1, TypeConstructor ordering] + in [TypeClassDictionaryInScope CompareSymbolInstance [] C.CompareSymbol args Nothing] + forClassName _ C.AppendSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = + let args = [arg0, arg1, TypeLevelString (lhs <> rhs)] + in [TypeClassDictionaryInScope AppendSymbolInstance [] C.AppendSymbol args Nothing] forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (nub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) forClassName _ _ _ = internalError "forClassName: expected qualified class name" @@ -293,9 +308,13 @@ entails SolverOptions{..} constraint context hints = -- Make a dictionary from subgoal dictionaries by applying the correct function mkDictionary :: Evidence -> Maybe [Expr] -> Expr mkDictionary (NamedInstance n) args = foldl App (Var n) (fold args) - mkDictionary (IsSymbolInstance sym) _ = TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) where - fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) - ] + mkDictionary (IsSymbolInstance sym) _ = + let fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) ] in + TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) + mkDictionary CompareSymbolInstance _ = + TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral [])) + mkDictionary AppendSymbolInstance _ = + TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral [])) -- Turn a DictionaryValue into a Expr subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 4fc855221e..86a6ef31c5 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -61,13 +61,13 @@ main = hspec spec spec :: Spec spec = do - (supportExterns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do + (supportExterns, supportForeigns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do cwd <- getCurrentDirectory let passing = cwd "examples" "passing" let warning = cwd "examples" "warning" let failing = cwd "examples" "failing" let supportDir = cwd "tests" "support" "bower_components" - let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir + let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir passingFiles <- getTestFiles passing <$> testGlob passing warningFiles <- getTestFiles warning <$> testGlob warning failingFiles <- getTestFiles failing <$> testGlob failing @@ -77,10 +77,10 @@ spec = do modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles foreigns <- inferForeignModules modules externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules) - return (zip (map snd modules) externs) + return (zip (map snd modules) externs, foreigns) case supportExterns of Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) - Right externs -> return (externs, passingFiles, warningFiles, failingFiles) + Right (externs, foreigns) -> return (externs, foreigns, passingFiles, warningFiles, failingFiles) outputFile <- runIO $ do tmp <- getTemporaryDirectory @@ -90,21 +90,21 @@ spec = do context "Passing examples" $ forM_ passingTestCases $ \testPurs -> it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ - assertCompiles supportExterns testPurs outputFile + assertCompiles supportExterns supportForeigns testPurs outputFile context "Warning examples" $ forM_ warningTestCases $ \testPurs -> do let mainPath = getTestMain testPurs expectedWarnings <- runIO $ getShouldWarnWith mainPath it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $ - assertCompilesWithWarnings supportExterns testPurs expectedWarnings + assertCompilesWithWarnings supportExterns supportForeigns testPurs expectedWarnings context "Failing examples" $ forM_ failingTestCases $ \testPurs -> do let mainPath = getTestMain testPurs expectedFailures <- runIO $ getShouldFailWith mainPath it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ - assertDoesNotCompile supportExterns testPurs expectedFailures + assertDoesNotCompile supportExterns supportForeigns testPurs expectedFailures where @@ -197,27 +197,29 @@ runTest = P.runMake P.defaultOptions compile :: [(P.Module, P.ExternsFile)] + -> M.Map P.ModuleName FilePath -> [FilePath] -> ([P.Module] -> IO ()) -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) -compile supportExterns inputFiles check = silence $ runTest $ do +compile supportExterns supportForeigns inputFiles check = silence $ runTest $ do fs <- liftIO $ readInput inputFiles ms <- P.parseModulesFromFiles id fs foreigns <- inferForeignModules ms liftIO (check (map snd ms)) - let actions = makeActions foreigns + let actions = makeActions (foreigns `M.union` supportForeigns) case ms of [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule) _ -> P.make actions (map fst supportExterns ++ map snd ms) assert :: [(P.Module, P.ExternsFile)] + -> M.Map P.ModuleName FilePath -> [FilePath] -> ([P.Module] -> IO ()) -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String)) -> Expectation -assert supportExterns inputFiles check f = do - (e, w) <- compile supportExterns inputFiles check +assert supportExterns supportForeigns inputFiles check f = do + (e, w) <- compile supportExterns supportForeigns inputFiles check maybeErr <- f (const w <$> e) maybe (return ()) expectationFailure maybeErr @@ -235,11 +237,12 @@ checkShouldFailWith expected errs = assertCompiles :: [(P.Module, P.ExternsFile)] + -> M.Map P.ModuleName FilePath -> [FilePath] -> Handle -> Expectation -assertCompiles supportExterns inputFiles outputFile = - assert supportExterns inputFiles checkMain $ \e -> +assertCompiles supportExterns supportForeigns inputFiles outputFile = + assert supportExterns supportForeigns inputFiles checkMain $ \e -> case e of Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do @@ -260,11 +263,12 @@ assertCompiles supportExterns inputFiles outputFile = assertCompilesWithWarnings :: [(P.Module, P.ExternsFile)] + -> M.Map P.ModuleName FilePath -> [FilePath] -> [String] -> Expectation -assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith = - assert supportExterns inputFiles checkMain $ \e -> +assertCompilesWithWarnings supportExterns supportForeigns inputFiles shouldWarnWith = + assert supportExterns supportForeigns inputFiles checkMain $ \e -> case e of Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs @@ -279,11 +283,12 @@ assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith = assertDoesNotCompile :: [(P.Module, P.ExternsFile)] + -> M.Map P.ModuleName FilePath -> [FilePath] -> [String] -> Expectation -assertDoesNotCompile supportExterns inputFiles shouldFailWith = - assert supportExterns inputFiles noPreCheck $ \e -> +assertDoesNotCompile supportExterns supportForeigns inputFiles shouldFailWith = + assert supportExterns supportForeigns inputFiles noPreCheck $ \e -> case e of Left errs -> return $ if null shouldFailWith diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index cf67a38ba4..67e3fbf4d8 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -57,6 +57,8 @@ supportModules = , "Control.Alternative" , "Control.Applicative" , "Control.Apply" + , "Control.Biapplicative" + , "Control.Biapply" , "Control.Bind" , "Control.Category" , "Control.Comonad" @@ -72,6 +74,15 @@ supportModules = , "Control.MonadZero" , "Control.Plus" , "Control.Semigroupoid" + , "Data.Bifoldable" + , "Data.Bifunctor" + , "Data.Bifunctor.Clown" + , "Data.Bifunctor.Flip" + , "Data.Bifunctor.Join" + , "Data.Bifunctor.Joker" + , "Data.Bifunctor.Product" + , "Data.Bifunctor.Wrap" + , "Data.Bitraversable" , "Data.Boolean" , "Data.BooleanAlgebra" , "Data.Bounded" @@ -79,18 +90,24 @@ supportModules = , "Data.Eq" , "Data.EuclideanRing" , "Data.Field" + , "Data.Foldable" , "Data.Function" , "Data.Function.Uncurried" , "Data.Functor" , "Data.Functor.Invariant" , "Data.Generic.Rep" - , "Data.Generic.Rep.Monoid" , "Data.Generic.Rep.Eq" + , "Data.Generic.Rep.Monoid" , "Data.Generic.Rep.Ord" , "Data.Generic.Rep.Semigroup" + , "Data.Generic.Rep.Show" , "Data.HeytingAlgebra" + , "Data.Maybe" + , "Data.Maybe.First" + , "Data.Maybe.Last" , "Data.Monoid" , "Data.Monoid.Additive" + , "Data.Monoid.Alternate" , "Data.Monoid.Conj" , "Data.Monoid.Disj" , "Data.Monoid.Dual" @@ -104,8 +121,9 @@ supportModules = , "Data.Ring" , "Data.Semigroup" , "Data.Semiring" - , "Data.Symbol" , "Data.Show" + , "Data.Symbol" + , "Data.Traversable" , "Data.Unit" , "Data.Void" , "Partial" @@ -113,6 +131,11 @@ supportModules = , "Prelude" , "Test.Assert" , "Test.Main" + , "Type.Data.Ordering" + , "Type.Data.Symbol" + , "Type.Equality" + , "Type.Prelude" + , "Type.Proxy" , "Unsafe.Coerce" ] diff --git a/tests/support/bower.json b/tests/support/bower.json index 2de10e8f7c..c6a717307c 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -1,16 +1,17 @@ { "name": "purescript-test-suite-support", "dependencies": { - "purescript-assert": "1.0.0-rc.1", - "purescript-console": "1.0.0-rc.1", - "purescript-eff": "1.0.0-rc.1", - "purescript-functions": "1.0.0-rc.1", - "purescript-prelude": "1.1.0", - "purescript-st": "1.0.0-rc.1", + "purescript-assert": "2.0.0", + "purescript-console": "2.0.0", + "purescript-eff": "2.0.0", + "purescript-functions": "2.0.0", + "purescript-prelude": "2.1.0", + "purescript-st": "2.0.0", "purescript-partial": "1.1.2", - "purescript-newtype": "0.1.0", - "purescript-generics-rep": "2.0.0", - "purescript-symbols": "^1.0.1", - "purescript-unsafe-coerce": "^1.0.0" + "purescript-newtype": "1.1.0", + "purescript-generics-rep": "4.0.0", + "purescript-symbols": "^2.0.0", + "purescript-typelevel-prelude": "https://github.com/purescript/purescript-typelevel-prelude.git#29a7123a0c29c85d4b923fcf4a7df8e45ebf9bac", + "purescript-unsafe-coerce": "^2.0.0" } } From 751018be04c38cc7e844298988f57389413b0b72 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 30 Dec 2016 19:11:48 -0800 Subject: [PATCH 0586/1580] Add command to apply minor package updates (#2510) * Add command to apply minor package updates * Support major updates, prettify JSON * Require tags of the form v1.2.3 * Remove bullet point --- psc-package/Main.hs | 128 +++++++++++++++++- src/Language/PureScript/Publish.hs | 7 +- .../PureScript/Publish/ErrorsWarnings.hs | 5 +- 3 files changed, 128 insertions(+), 12 deletions(-) diff --git a/psc-package/Main.hs b/psc-package/Main.hs index 0415b716b6..71d95603a2 100644 --- a/psc-package/Main.hs +++ b/psc-package/Main.hs @@ -7,6 +7,7 @@ module Main where +import qualified Control.Foldl as Foldl import qualified Data.Aeson as Aeson import Data.Aeson.Encode.Pretty import Data.Foldable (fold, for_, traverse_) @@ -15,9 +16,11 @@ import qualified Data.Map as Map import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import Data.Text (pack) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB -import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Read as TR import Data.Traversable (for) import Data.Version (showVersion) import qualified Filesystem.Path.CurrentOS as Path @@ -25,7 +28,8 @@ import GHC.Generics (Generic) import qualified Options.Applicative as Opts import qualified Paths_purescript as Paths import qualified System.IO as IO -import Turtle hiding (fold) +import Turtle hiding (fold, s, x) +import qualified Turtle packageFile :: Path.FilePath packageFile = "psc-package.json" @@ -61,8 +65,8 @@ readPackageFile = do exit (ExitFailure 1) Just pkg -> return pkg -encodePrettyToText :: Aeson.ToJSON json => json -> Text -encodePrettyToText = +packageConfigToJSON :: PackageConfig -> Text +packageConfigToJSON = TL.toStrict . TB.toLazyText . encodePrettyToTextBuilder' config @@ -76,10 +80,18 @@ encodePrettyToText = ] } +packageSetToJSON :: PackageSet -> Text +packageSetToJSON = + TL.toStrict + . TB.toLazyText + . encodePrettyToTextBuilder' config + where + config = defConfig { confCompare = compare } + writePackageFile :: PackageConfig -> IO () writePackageFile = writeTextFile packageFile - . encodePrettyToText + . packageConfigToJSON data PackageInfo = PackageInfo { repo :: Text @@ -108,6 +120,18 @@ cloneShallow from ref into = , pathToTextUnsafe into ] empty .||. exit (ExitFailure 1) +listRemoteTags + :: Text + -- ^ repo + -> Turtle.Shell Text +listRemoteTags from = + inproc "git" + [ "ls-remote" + , "-q" + , "-t" + , from + ] empty + getPackageSet :: PackageConfig -> IO () getPackageSet PackageConfig{ source, set } = do let pkgDir = ".psc-package" fromText set ".set" @@ -128,6 +152,11 @@ readPackageSet PackageConfig{ set } = do exit (ExitFailure 1) Just db -> return db +writePackageSet :: PackageConfig -> PackageSet -> IO () +writePackageSet PackageConfig{ set } = + let dbFile = ".psc-package" fromText set ".set" "packages.json" + in writeTextFile dbFile . packageSetToJSON + installOrUpdate :: Text -> Text -> PackageInfo -> IO Turtle.FilePath installOrUpdate set pkgName PackageInfo{ repo, version } = do echo ("Updating " <> pkgName) @@ -233,6 +262,84 @@ exec exeName = do (map pathToTextUnsafe ("src" "**" "*.purs" : paths)) empty +checkForUpdates :: Bool -> Bool -> IO () +checkForUpdates applyMinorUpdates applyMajorUpdates = do + pkg <- readPackageFile + db <- readPackageSet pkg + + echo ("Checking " <> pack (show (Map.size db)) <> " packages for updates.") + echo "Warning: this could take some time!" + + newDb <- Map.fromList <$> (for (Map.toList db) $ \(name, p@PackageInfo{ repo, version }) -> do + echo ("Checking package " <> name) + tagLines <- Turtle.fold (listRemoteTags repo) Foldl.list + let tags = mapMaybe parseTag tagLines + newVersion <- case parseVersion version of + Just parts -> + let applyMinor = + case filter (isMinorReleaseFrom parts) tags of + [] -> pure version + minorReleases -> do + echo ("New minor release available") + case applyMinorUpdates of + True -> do + let latestMinorRelease = maximum minorReleases + pure ("v" <> T.intercalate "." (map (pack . show) latestMinorRelease)) + False -> pure version + applyMajor = + case filter (isMajorReleaseFrom parts) tags of + [] -> applyMinor + newReleases -> do + echo ("New major release available") + case applyMajorUpdates of + True -> do + let latestRelease = maximum newReleases + pure ("v" <> T.intercalate "." (map (pack . show) latestRelease)) + False -> applyMinor + in applyMajor + _ -> do + echo "Unable to parse version string" + pure version + pure (name, p { version = newVersion })) + + when (applyMinorUpdates || applyMajorUpdates) + (writePackageSet pkg newDb) + where + parseTag :: Text -> Maybe [Int] + parseTag line = + case T.splitOn "\t" line of + [_sha, ref] -> + case T.stripPrefix "refs/tags/" ref of + Just tag -> + case parseVersion tag of + Just parts -> pure parts + _ -> Nothing + _ -> Nothing + _ -> Nothing + + parseVersion :: Text -> Maybe [Int] + parseVersion ref = + case T.stripPrefix "v" ref of + Just tag -> + traverse parseDecimal (T.splitOn "." tag) + _ -> Nothing + + parseDecimal :: Text -> Maybe Int + parseDecimal s = + case TR.decimal s of + Right (n, "") -> Just n + _ -> Nothing + + isMajorReleaseFrom :: [Int] -> [Int] -> Bool + isMajorReleaseFrom (0 : xs) (0 : ys) = isMajorReleaseFrom xs ys + isMajorReleaseFrom (x : _) (y : _) = y > x + isMajorReleaseFrom _ _ = False + + isMinorReleaseFrom :: [Int] -> [Int] -> Bool + isMinorReleaseFrom (0 : xs) (0 : ys) = isMinorReleaseFrom xs ys + isMinorReleaseFrom (x : xs) (y : ys) = y == x && ys > xs + isMinorReleaseFrom _ _ = False + verifyPackageSet :: IO () verifyPackageSet = do pkg <- readPackageFile @@ -292,6 +399,9 @@ main = do , Opts.command "available" (Opts.info (pure listPackages) (Opts.progDesc "List all packages available in the package set")) + , Opts.command "updates" + (Opts.info (checkForUpdates <$> apply <*> applyMajor) + (Opts.progDesc "Check all packages in the package set for new releases")) , Opts.command "verify-set" (Opts.info (pure verifyPackageSet) (Opts.progDesc "Verify that the packages in the package set build correctly")) @@ -300,3 +410,11 @@ main = do pkg = Opts.strArgument $ Opts.metavar "PACKAGE" <> Opts.help "The name of the package to install" + + apply = Opts.switch $ + Opts.long "apply" + <> Opts.help "Apply all minor package updates" + + applyMajor = Opts.switch $ + Opts.long "apply-breaking" + <> Opts.help "Apply all major package updates" diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index e3cecd364b..136991a8cd 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -196,10 +196,9 @@ getVersionFromGitTag = do where trimWhitespace = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse - parseMay str = - (str,) <$> D.parseVersion' (dropPrefix "v" str) - dropPrefix prefix str = - fromMaybe str (stripPrefix prefix str) + parseMay str = do + digits <- stripPrefix "v" str + (str,) <$> D.parseVersion' digits getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo) getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 3e6cf02104..597b2a4231 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -148,9 +148,8 @@ displayUserError e = case e of , "version." ]) , spacer - , para "Note: tagged versions must be in one of the following forms:" - , indented (para "* v{MAJOR}.{MINOR}.{PATCH} (example: \"v1.6.2\")") - , indented (para "* {MAJOR}.{MINOR}.{PATCH} (example: \"1.6.2\")") + , para "Note: tagged versions must be in the form" + , indented (para "v{MAJOR}.{MINOR}.{PATCH} (example: \"v1.6.2\")") , spacer , para (concat [ "If the version you are publishing is not yet tagged, you might " From 380de1662b35eb8c23343afd994dba95348530a0 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sat, 31 Dec 2016 21:50:41 +0000 Subject: [PATCH 0587/1580] Add naive functor deriving (#2515) * Add naive functor deriving * Add support for records in functor deriving --- examples/passing/DerivingFunctor.purs | 24 ++++++ src/Language/PureScript/Constants.hs | 3 + .../PureScript/Sugar/TypeClasses/Deriving.hs | 81 ++++++++++++++++++- 3 files changed, 106 insertions(+), 2 deletions(-) create mode 100644 examples/passing/DerivingFunctor.purs diff --git a/examples/passing/DerivingFunctor.purs b/examples/passing/DerivingFunctor.purs new file mode 100644 index 0000000000..12659413af --- /dev/null +++ b/examples/passing/DerivingFunctor.purs @@ -0,0 +1,24 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Test.Assert + +data M f a + = M0 a (Array a) + | M1 Int + | M2 (f a) + | M3 { foo :: Int, bar :: a, baz :: f a } + +derive instance eqM :: (Eq (f a), Eq a) => Eq (M f a) + +derive instance functorM :: Functor f => Functor (M f) + +type MA = M Array + +main = do + assert $ map show (M0 0 [1, 2] :: MA Int) == M0 "0" ["1", "2"] + assert $ map show (M1 0 :: MA Int) == M1 0 + assert $ map show (M2 [0, 1] :: MA Int) == M2 ["0", "1"] + assert $ map show (M3 {foo: 0, bar: 1, baz: [2, 3]} :: MA Int) == M3 {foo: 0, bar: "1", baz: ["2", "3"]} + log "Done" diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index e068656b0c..3d9351dace 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -139,6 +139,9 @@ compose = "compose" composeFlipped :: Text composeFlipped = "composeFlipped" +map :: Text +map = "map" + -- Functions negate :: Text diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index fbf0be83b4..2ccfa9307d 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -6,7 +6,7 @@ module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where import Prelude.Compat import Control.Arrow (second) -import Control.Monad (replicateM) +import Control.Monad (replicateM, zipWithM) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class (MonadSupply) @@ -19,9 +19,10 @@ import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors +import Language.PureScript.Kinds import Language.PureScript.Names -import Language.PureScript.Types import Language.PureScript.TypeChecker (checkNewtype) +import Language.PureScript.Types import qualified Language.PureScript.Constants as C -- | Elaborates deriving instance declarations by code generation. @@ -44,14 +45,22 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args + | className == Qualified (Just dataEq) (ProperName "Eq") , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon + | className == Qualified (Just dataOrd) (ProperName "Ord") , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon + + | className == Qualified (Just dataFunctor) (ProperName "Functor") + , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty + , mn == fromMaybe mn mn' + = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveFunctor mn ds tyCon + deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance) | className == Qualified (Just dataNewtype) (ProperName "Newtype") , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy @@ -143,6 +152,9 @@ dataOrd = ModuleName [ ProperName "Data", ProperName "Ord" ] dataNewtype :: ModuleName dataNewtype = ModuleName [ ProperName "Data", ProperName "Newtype" ] +dataFunctor :: ModuleName +dataFunctor = ModuleName [ ProperName "Data", ProperName "Functor" ] + deriveGeneric :: forall m. (MonadError MultipleErrors m, MonadSupply m) => ModuleName @@ -702,3 +714,68 @@ decomposeRec :: Type -> [(Text, Type)] decomposeRec = sortBy (comparing fst) . go where go (RCons str typ typs) = (str, typ) : decomposeRec typs go _ = [] + +deriveFunctor + :: forall m + . (MonadError MultipleErrors m, MonadSupply m) + => ModuleName + -> [Declaration] + -> ProperName 'TypeName + -> m [Declaration] +deriveFunctor mn ds tyConNm = do + tyCon <- findTypeDecl tyConNm ds + mapFun <- mkMapFunction tyCon + return [ ValueDeclaration (Ident C.map) Public [] (Right mapFun) ] + where + mkMapFunction :: Declaration -> m Expr + mkMapFunction (DataDeclaration _ _ tys ctors) = case reverse tys of + [] -> throwError . errorMessage $ KindsDoNotUnify (FunKind kindType kindType) kindType + ((iTy, _) : _) -> do + f <- freshIdent "f" + m <- freshIdent "m" + lam f . lamCase m <$> mapM (mkCtorClause iTy f) ctors + mkMapFunction (PositionedDeclaration _ _ d) = mkMapFunction d + mkMapFunction _ = internalError "mkMapFunction: expected DataDeclaration" + + mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [Type]) -> m CaseAlternative + mkCtorClause iTyName f (ctorName, ctorTys) = do + idents <- replicateM (length ctorTys) (freshIdent "v") + args <- zipWithM transformArg idents ctorTys + let ctor = Constructor (Qualified (Just mn) ctorName) + rebuilt = foldl App ctor args + caseBinder = ConstructorBinder (Qualified (Just mn) ctorName) (VarBinder <$> idents) + return $ CaseAlternative [caseBinder] (Right rebuilt) + where + fVar = mkVar f + mapVar = mkVarMn (Just dataFunctor) (Ident C.map) + + -- TODO: deal with type synonyms, ala https://github.com/purescript/purescript/pull/2516 + transformArg :: Ident -> Type -> m Expr + transformArg ident = fmap (foldr App (mkVar ident)) . goType where + + goType :: Type -> m (Maybe Expr) + -- argument matches the index type + goType (TypeVar t) | t == iTyName = return (Just fVar) + + -- records + goType recTy | Just row <- objectType recTy = + traverse buildUpdate (decomposeRec row) >>= (traverse buildRecord . justUpdates) + where + justUpdates :: [Maybe (Text, Expr)] -> Maybe [(Text, Expr)] + justUpdates = foldMap (fmap return) + + buildUpdate :: (Text, Type) -> m (Maybe (Text, Expr)) + buildUpdate (lbl, ty) = do upd <- goType ty + return ((lbl,) <$> upd) + + buildRecord :: [(Text, Expr)] -> m Expr + buildRecord updates = do arg <- freshIdent "o" + let argVar = mkVar arg + mkAssignment (l, x) = (l, App x (Accessor l argVar)) + return (lam arg (ObjectUpdate argVar (mkAssignment <$> updates))) + + -- under a `* -> *`, just assume functor for now + goType (TypeApp _ t) = fmap (App mapVar) <$> goType t + + -- otherwise do nothing - will fail type checking if type does actually contain index + goType _ = return Nothing From cd535c18945bd9bbae1194a96fb7df897f4b55bd Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 31 Dec 2016 16:42:19 -0800 Subject: [PATCH 0588/1580] Derive instances when data types use type synonyms (#2516) * Derive instances when data types use type synonyms * Handle nested synonyms --- examples/passing/DeriveNewtype.purs | 4 +- .../passing/DeriveWithNestedSynonyms.purs | 29 ++++ examples/passing/Deriving.purs | 4 +- examples/passing/DerivingFunctor.purs | 4 + examples/passing/GenericsRep.purs | 4 +- examples/passing/NewtypeInstance.purs | 4 +- src/Language/PureScript/Sugar.hs | 2 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 155 +++++++++++------- .../PureScript/TypeChecker/Synonyms.hs | 55 ++++--- 9 files changed, 173 insertions(+), 88 deletions(-) create mode 100644 examples/passing/DeriveWithNestedSynonyms.purs diff --git a/examples/passing/DeriveNewtype.purs b/examples/passing/DeriveNewtype.purs index bdcdce4fe4..3f0648c1c7 100644 --- a/examples/passing/DeriveNewtype.purs +++ b/examples/passing/DeriveNewtype.purs @@ -4,7 +4,9 @@ import Control.Monad.Eff.Console (log) import Data.Newtype -newtype Test = Test String +type MyString = String + +newtype Test = Test MyString derive instance newtypeTest :: Newtype Test _ diff --git a/examples/passing/DeriveWithNestedSynonyms.purs b/examples/passing/DeriveWithNestedSynonyms.purs new file mode 100644 index 0000000000..c23c8e3e51 --- /dev/null +++ b/examples/passing/DeriveWithNestedSynonyms.purs @@ -0,0 +1,29 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +type L = {} +data X = X L +derive instance eqX :: Eq X + +type M = {} +data Y = Y {foo :: M} +derive instance eqY :: Eq Y + +type N = {} +data Z = Z N +derive instance eqZ :: Eq Z + +type Foo = String + +type Bar = { foo :: Foo } + +type Baz = { baz :: Bar } + +newtype T = T Baz + +derive instance eqT :: Eq T +derive instance ordT :: Ord T + +main = log "Done" diff --git a/examples/passing/Deriving.purs b/examples/passing/Deriving.purs index 2609cf3934..9630699928 100644 --- a/examples/passing/Deriving.purs +++ b/examples/passing/Deriving.purs @@ -10,7 +10,9 @@ derive instance eqV :: Eq V derive instance ordV :: Ord V -data X = X Int | Y String +type MyString = String + +data X = X Int | Y MyString derive instance eqX :: Eq X diff --git a/examples/passing/DerivingFunctor.purs b/examples/passing/DerivingFunctor.purs index 12659413af..bd40cac9f2 100644 --- a/examples/passing/DerivingFunctor.purs +++ b/examples/passing/DerivingFunctor.purs @@ -4,11 +4,14 @@ import Prelude import Control.Monad.Eff.Console (log) import Test.Assert +type MyRecord a = { myField :: a } + data M f a = M0 a (Array a) | M1 Int | M2 (f a) | M3 { foo :: Int, bar :: a, baz :: f a } + | M4 (MyRecord a) derive instance eqM :: (Eq (f a), Eq a) => Eq (M f a) @@ -21,4 +24,5 @@ main = do assert $ map show (M1 0 :: MA Int) == M1 0 assert $ map show (M2 [0, 1] :: MA Int) == M2 ["0", "1"] assert $ map show (M3 {foo: 0, bar: 1, baz: [2, 3]} :: MA Int) == M3 {foo: 0, bar: "1", baz: ["2", "3"]} + assert $ map show (M4 { myField: 42 }) == M4 { myField: "42" } :: MA String log "Done" diff --git a/examples/passing/GenericsRep.purs b/examples/passing/GenericsRep.purs index 4f60106c5c..be75d86202 100644 --- a/examples/passing/GenericsRep.purs +++ b/examples/passing/GenericsRep.purs @@ -27,7 +27,9 @@ derive instance genericZ :: Generic Z _ instance eqZ :: Eq Z where eq x y = genericEq x y -newtype W = W { x :: Int, y :: String } +type MyString = String + +newtype W = W { x :: Int, y :: MyString } derive instance genericW :: Generic W _ diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs index 8a83399a32..f7b9ea862e 100644 --- a/examples/passing/NewtypeInstance.purs +++ b/examples/passing/NewtypeInstance.purs @@ -4,7 +4,9 @@ import Prelude import Control.Monad.Eff import Control.Monad.Eff.Console -newtype X = X String +type MyString = String + +newtype X = X MyString derive newtype instance showX :: Show X diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 7ec61cf0f8..0a1d27270f 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -62,6 +62,6 @@ desugar externs = >=> desugarImports externs >=> rebracket externs >=> traverse checkFixityExports - >=> traverse deriveInstances + >=> traverse (deriveInstances externs) >=> desugarTypeClasses externs >=> traverse createBindingGroupsModule diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 2ccfa9307d..8b5ad3c872 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -3,86 +3,102 @@ -- module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where -import Prelude.Compat - -import Control.Arrow (second) -import Control.Monad (replicateM, zipWithM) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class (MonadSupply) - -import Data.List (foldl', find, sortBy, unzip5) -import Data.Maybe (fromMaybe) -import Data.Ord (comparing) -import Data.Text (Text) - -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Kinds -import Language.PureScript.Names -import Language.PureScript.TypeChecker (checkNewtype) -import Language.PureScript.Types +import Prelude.Compat + +import Control.Arrow (second) +import Control.Monad (replicateM, zipWithM) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class (MonadSupply) +import Data.List (foldl', find, sortBy, unzip5) +import qualified Data.Map as M +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Ord (comparing) +import Data.Text (Text) +import Language.PureScript.AST import qualified Language.PureScript.Constants as C +import Language.PureScript.Crash +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Externs +import Language.PureScript.Kinds +import Language.PureScript.Names +import Language.PureScript.Types +import Language.PureScript.TypeChecker (checkNewtype) +import Language.PureScript.TypeChecker.Synonyms (SynonymMap, replaceAllTypeSynonymsM) -- | Elaborates deriving instance declarations by code generation. deriveInstances - :: (MonadError MultipleErrors m, MonadSupply m) - => Module + :: forall m + . (MonadError MultipleErrors m, MonadSupply m) + => [ExternsFile] + -> Module -> m Module -deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts +deriveInstances externs (Module ss coms mn ds exts) = + Module ss coms mn <$> mapM (deriveInstance mn synonyms ds) ds <*> pure exts + where + -- We need to collect type synonym information, since synonyms will not be + -- removed until later, during type checking. + synonyms :: SynonymMap + synonyms = + M.fromList $ (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) + ++ mapMaybe fromLocalDecl ds + where + fromExternsDecl mn' (EDTypeSynonym name args ty) = Just (Qualified (Just mn') name, (args, ty)) + fromExternsDecl _ _ = Nothing + + fromLocalDecl (TypeSynonymDeclaration name args ty) = do + Just (Qualified (Just mn) name, (args, ty)) + fromLocalDecl (PositionedDeclaration _ _ d) = fromLocalDecl d + fromLocalDecl _ = Nothing -- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration, -- elaborates that into an instance declaration via code generation. deriveInstance :: (MonadError MultipleErrors m, MonadSupply m) => ModuleName + -> SynonymMap -> [Declaration] -> Declaration -> m Declaration -deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance) +deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance) | className == Qualified (Just dataGeneric) (ProperName C.generic) , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args - + = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn syns ds tyCon args | className == Qualified (Just dataEq) (ProperName "Eq") , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon - + = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn syns ds tyCon | className == Qualified (Just dataOrd) (ProperName "Ord") , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon - + = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn syns ds tyCon | className == Qualified (Just dataFunctor) (ProperName "Functor") , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveFunctor mn ds tyCon - -deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance) + = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveFunctor mn syns ds tyCon +deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance) | className == Qualified (Just dataNewtype) (ProperName "Newtype") , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy , mn == fromMaybe mn mn' - = do (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy + = do (inst, actualUnwrappedTy) <- deriveNewtype mn syns ds tyCon args unwrappedTy return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) -deriveInstance mn ds (TypeInstanceDeclaration nm deps className [actualTy, repTy] DerivedInstance) +deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className [actualTy, repTy] DerivedInstance) | className == Qualified (Just dataGenericRep) (ProperName C.generic) , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy , mn == fromMaybe mn mn' - = do (inst, inferredRepTy) <- deriveGenericRep mn ds tyCon args repTy + = do (inst, inferredRepTy) <- deriveGenericRep mn syns ds tyCon args repTy return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) -deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) +deriveInstance _ _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) = throwError . errorMessage $ CannotDerive className tys -deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance) +deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance) | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys) , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance className ds tys tyCon args -deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance) + = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance syns className ds tys tyCon args +deriveInstance _ _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance) = throwError . errorMessage $ InvalidNewtypeInstance className tys -deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d -deriveInstance _ _ e = return e +deriveInstance mn syns ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn syns ds d +deriveInstance _ _ _ e = return e unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type]) unwrapTypeConstructor = fmap (second reverse) . go @@ -96,13 +112,14 @@ unwrapTypeConstructor = fmap (second reverse) . go deriveNewtypeInstance :: forall m . MonadError MultipleErrors m - => Qualified (ProperName 'ClassName) + => SynonymMap + -> Qualified (ProperName 'ClassName) -> [Declaration] -> [Type] -> ProperName 'TypeName -> [Type] -> m Expr -deriveNewtypeInstance className ds tys tyConNm dargs = do +deriveNewtypeInstance syns className ds tys tyConNm dargs = do tyCon <- findTypeDecl tyConNm ds go tyCon where @@ -118,7 +135,8 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do -- type argument | Just wrapped' <- stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped = do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs - return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped'])) + wrapped'' <- replaceAllTypeSynonymsM syns wrapped' + return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped''])) go (PositionedDeclaration _ _ d) = go d go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys @@ -158,11 +176,12 @@ dataFunctor = ModuleName [ ProperName "Data", ProperName "Functor" ] deriveGeneric :: forall m. (MonadError MultipleErrors m, MonadSupply m) => ModuleName + -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> [Type] -> m [Declaration] -deriveGeneric mn ds tyConNm dargs = do +deriveGeneric mn syns ds tyConNm dargs = do tyCon <- findTypeDecl tyConNm ds toSpine <- mkSpineFunction tyCon fromSpine <- mkFromSpineFunction tyCon @@ -186,12 +205,12 @@ deriveGeneric mn ds tyConNm dargs = do mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative mkCtorClause (ctorName, tys) = do idents <- replicateM (length tys) freshIdent' - return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents)) - where - caseResult idents = - App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName)) - . Literal . ArrayLiteral - $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys + tys' <- mapM (replaceAllTypeSynonymsM syns) tys + let caseResult = + App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName)) + . Literal . ArrayLiteral + $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys' + return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right caseResult) toSpineFun :: Expr -> Type -> Expr toSpineFun i r | Just rec <- objectType r = @@ -326,12 +345,13 @@ deriveGenericRep :: forall m . (MonadError MultipleErrors m, MonadSupply m) => ModuleName + -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> [Type] -> Type -> m ([Declaration], Type) -deriveGenericRep mn ds tyConNm tyConArgs repTy = do +deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do checkIsWildcard tyConNm repTy go =<< findTypeDecl tyConNm ds where @@ -382,7 +402,8 @@ deriveGenericRep mn ds tyConNm tyConArgs repTy = do :: (ProperName 'ConstructorName, [Type]) -> m (Type, CaseAlternative, CaseAlternative) makeInst (ctorName, args) = do - (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args + args' <- mapM (replaceAllTypeSynonymsM syns) args + (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args' return ( TypeApp (TypeApp (TypeConstructor constructor) (TypeLevelString (runProperName ctorName))) ctorTy @@ -506,10 +527,11 @@ checkIsWildcard tyConNm _ = deriveEq :: forall m. (MonadError MultipleErrors m, MonadSupply m) => ModuleName + -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> m [Declaration] -deriveEq mn ds tyConNm = do +deriveEq mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds eqFun <- mkEqFunction tyCon return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ] @@ -539,7 +561,8 @@ deriveEq mn ds tyConNm = do mkCtorClause (ctorName, tys) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") - let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys + tys' <- mapM (replaceAllTypeSynonymsM syns) tys + let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys' return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests)) where caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents) @@ -558,10 +581,11 @@ deriveEq mn ds tyConNm = do deriveOrd :: forall m. (MonadError MultipleErrors m, MonadSupply m) => ModuleName + -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> m [Declaration] -deriveOrd mn ds tyConNm = do +deriveOrd mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds compareFun <- mkCompareFunction tyCon return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ] @@ -602,7 +626,8 @@ deriveOrd mn ds tyConNm = do mkCtorClauses ((ctorName, tys), isLast) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") - let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys + tys' <- mapM (replaceAllTypeSynonymsM syns) tys + let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys' extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) , NullBinder ] @@ -644,12 +669,13 @@ deriveNewtype :: forall m . (MonadError MultipleErrors m, MonadSupply m) => ModuleName + -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> [Type] -> Type -> m ([Declaration], Type) -deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do +deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do checkIsWildcard tyConNm unwrappedTy go =<< findTypeDecl tyConNm ds where @@ -661,7 +687,8 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do wrappedIdent <- freshIdent "n" unwrappedIdent <- freshIdent "a" let (ctorName, [ty]) = head dctors - inst = + ty' <- replaceAllTypeSynonymsM syns ty + let inst = [ ValueDeclaration (Ident "wrap") Public [] $ Right $ Constructor (Qualified (Just mn) ctorName) , ValueDeclaration (Ident "unwrap") Public [] $ Right $ @@ -672,7 +699,7 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do ] ] subst = zipWith ((,) . fst) args tyConArgs - return (inst, replaceAllTypeVars subst ty) + return (inst, replaceAllTypeVars subst ty') go (PositionedDeclaration _ _ d) = go d go _ = internalError "deriveNewtype go: expected DataDeclaration" @@ -719,10 +746,11 @@ deriveFunctor :: forall m . (MonadError MultipleErrors m, MonadSupply m) => ModuleName + -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> m [Declaration] -deriveFunctor mn ds tyConNm = do +deriveFunctor mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds mapFun <- mkMapFunction tyCon return [ ValueDeclaration (Ident C.map) Public [] (Right mapFun) ] @@ -740,7 +768,8 @@ deriveFunctor mn ds tyConNm = do mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [Type]) -> m CaseAlternative mkCtorClause iTyName f (ctorName, ctorTys) = do idents <- replicateM (length ctorTys) (freshIdent "v") - args <- zipWithM transformArg idents ctorTys + ctorTys' <- mapM (replaceAllTypeSynonymsM syns) ctorTys + args <- zipWithM transformArg idents ctorTys' let ctor = Constructor (Qualified (Just mn) ctorName) rebuilt = foldl App ctor args caseBinder = ConstructorBinder (Qualified (Just mn) ctorName) (VarBinder <$> idents) diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 829ec570f4..08016b2315 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -4,44 +4,59 @@ -- Functions for replacing fully applied type synonyms -- module Language.PureScript.TypeChecker.Synonyms - ( replaceAllTypeSynonyms + ( SynonymMap + , replaceAllTypeSynonyms + , replaceAllTypeSynonymsM ) where -import Prelude.Compat +import Prelude.Compat -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State - -import Data.Maybe (fromMaybe) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State +import Data.Maybe (fromMaybe) import qualified Data.Map as M - -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.TypeChecker.Monad -import Language.PureScript.Types - --- | --- Replace fully applied type synonyms. --- -replaceAllTypeSynonyms' :: Environment -> Type -> Either MultipleErrors Type -replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try +import Data.Text (Text) +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Kinds +import Language.PureScript.Names +import Language.PureScript.TypeChecker.Monad +import Language.PureScript.Types + +-- | Type synonym information (arguments with kinds, aliased type), indexed by name +type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type) + +replaceAllTypeSynonyms' + :: SynonymMap + -> Type + -> Either MultipleErrors Type +replaceAllTypeSynonyms' syns = everywhereOnTypesTopDownM try where try :: Type -> Either MultipleErrors Type try t = fromMaybe t <$> go 0 [] t go :: Int -> [Type] -> Type -> Either MultipleErrors (Maybe Type) go c args (TypeConstructor ctor) - | Just (synArgs, body) <- M.lookup ctor (typeSynonyms env) + | Just (synArgs, body) <- M.lookup ctor syns , c == length synArgs = let repl = replaceAllTypeVars (zip (map fst synArgs) args) body in Just <$> try repl - | Just (synArgs, _) <- M.lookup ctor (typeSynonyms env) + | Just (synArgs, _) <- M.lookup ctor syns , length synArgs > c = throwError . errorMessage $ PartiallyAppliedSynonym ctor go c args (TypeApp f arg) = go (c + 1) (arg : args) f go _ _ _ = return Nothing +-- | Replace fully applied type synonyms replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => Type -> m Type replaceAllTypeSynonyms d = do env <- getEnv - either throwError return $ replaceAllTypeSynonyms' env d + either throwError return $ replaceAllTypeSynonyms' (typeSynonyms env) d + +-- | Replace fully applied type synonyms by explicitly providing a 'SynonymMap'. +replaceAllTypeSynonymsM + :: MonadError MultipleErrors m + => SynonymMap + -> Type + -> m Type +replaceAllTypeSynonymsM syns = either throwError pure . replaceAllTypeSynonyms' syns From 914481c89ca47c60dfff738b4af835b5f469504c Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 31 Dec 2016 16:42:40 -0800 Subject: [PATCH 0589/1580] 0.10.4 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 12954a6cc9..6aed2012f2 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.10.3 +version: 0.10.4 cabal-version: >=1.8 build-type: Simple license: BSD3 From fca36558d780216b0ad28ac5b9e9f579e32a562e Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 1 Jan 2017 13:50:25 +0100 Subject: [PATCH 0590/1580] Remove Stackage badges Now that we no longer are in stackage I think we should remove these. LTS 2 and 3 were horribly outdated anyway. --- README.md | 4 ---- 1 file changed, 4 deletions(-) diff --git a/README.md b/README.md index f7e5a8651f..b6c4df22a3 100644 --- a/README.md +++ b/README.md @@ -4,10 +4,6 @@ A small strongly typed programming language with expressive types that compiles [![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript) -[![Stackage LTS 2](http://stackage.org/package/purescript/badge/lts-2)](http://stackage.org/lts-2/package/purescript) -[![Stackage LTS 3](http://stackage.org/package/purescript/badge/lts-3)](http://stackage.org/lts-3/package/purescript) -[![Stackage Nightly](http://stackage.org/package/purescript/badge/nightly)](http://stackage.org/nightly/package/purescript) - ## Language info - [PureScript home](http://purescript.org) From e9176bd6b9ce9db28e324f236b43243357d89db8 Mon Sep 17 00:00:00 2001 From: kRITZCREEK Date: Sun, 1 Jan 2017 13:57:26 +0100 Subject: [PATCH 0591/1580] [psc-ide] Fixes tests on windows On my local windows machine \r characters were not removed by Text.lines --- tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs index 61021cc8a0..01f474a775 100644 --- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs +++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs @@ -28,7 +28,7 @@ outputFileShouldBe :: [Text] -> IO () outputFileShouldBe expectation = do outFp <- ( "src" "ImportsSpecOut.tmp") <$> Integration.projectDirectory outRes <- readUTF8FileT outFp - shouldBe (T.lines outRes) expectation + shouldBe (T.strip <$> T.lines outRes) expectation spec :: Spec spec = beforeAll_ setup . describe "Adding imports" $ do From 975e2807abbb00c4de0f2e962c60c64dae0d5b3f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 1 Jan 2017 13:06:25 -0800 Subject: [PATCH 0592/1580] \'kind\' is no longer a reserved word --- src/Language/PureScript/Parser/Declarations.hs | 6 +++--- src/Language/PureScript/Parser/Lexer.hs | 1 - 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 42cfdaf0a0..161a9b2e29 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -110,7 +110,7 @@ parseValueDeclaration = do parseExternDeclaration :: TokenParser Declaration parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *> parseExternAlt where - parseExternAlt = parseExternData <|> parseExternKind <|> parseExternTerm + parseExternAlt = parseExternData <|> P.try parseExternKind <|> parseExternTerm parseExternData = ExternDataDeclaration <$> (reserved "data" *> indented *> typeName) <*> (indented *> doubleColon *> parseKind) @@ -167,11 +167,11 @@ parseImportDeclaration' = do parseDeclarationRef :: TokenParser DeclarationRef parseDeclarationRef = withSourceSpan PositionedDeclarationRef - $ (ValueRef <$> parseIdent) + $ (KindRef <$> P.try (reserved "kind" *> kindName)) + <|> (ValueRef <$> parseIdent) <|> (ValueOpRef <$> parens parseOperator) <|> parseTypeRef <|> (TypeClassRef <$> (reserved "class" *> properName)) - <|> (KindRef <$> (reserved "kind" *> kindName)) <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName)) <|> (TypeOpRef <$> (indented *> reserved "type" *> parens parseOperator)) where diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index bdac6087af..59eff68052 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -556,7 +556,6 @@ reservedPsNames :: [Text] reservedPsNames = [ "data" , "newtype" , "type" - , "kind" , "foreign" , "import" , "infixl" From 26b73d679aaa2ec72dfc8aa118cc4b2b4993fd50 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Fri, 30 Dec 2016 18:18:18 +0000 Subject: [PATCH 0593/1580] Update orphan instance check to use covering sets --- .../failing/OrphanInstanceFunDepCycle.purs | 5 ++ .../OrphanInstanceFunDepCycle/Lib.purs | 4 ++ examples/failing/OrphanInstanceNullary.purs | 4 ++ .../failing/OrphanInstanceNullary/Lib.purs | 2 + .../failing/OrphanInstanceWithDetermined.purs | 5 ++ .../OrphanInstanceWithDetermined/Lib.purs | 5 ++ .../passing/NonOrphanInstanceFunDepExtra.purs | 8 +++ .../NonOrphanInstanceFunDepExtra/Lib.purs | 4 ++ examples/passing/NonOrphanInstanceMulti.purs | 7 +++ .../passing/NonOrphanInstanceMulti/Lib.purs | 4 ++ purescript.cabal | 5 ++ src/Language/PureScript/Environment.hs | 51 +++++++++++++++---- src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 42 ++++++++++----- 14 files changed, 125 insertions(+), 23 deletions(-) create mode 100644 examples/failing/OrphanInstanceFunDepCycle.purs create mode 100644 examples/failing/OrphanInstanceFunDepCycle/Lib.purs create mode 100644 examples/failing/OrphanInstanceNullary.purs create mode 100644 examples/failing/OrphanInstanceNullary/Lib.purs create mode 100644 examples/failing/OrphanInstanceWithDetermined.purs create mode 100644 examples/failing/OrphanInstanceWithDetermined/Lib.purs create mode 100644 examples/passing/NonOrphanInstanceFunDepExtra.purs create mode 100644 examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs create mode 100644 examples/passing/NonOrphanInstanceMulti.purs create mode 100644 examples/passing/NonOrphanInstanceMulti/Lib.purs diff --git a/examples/failing/OrphanInstanceFunDepCycle.purs b/examples/failing/OrphanInstanceFunDepCycle.purs new file mode 100644 index 0000000000..c11877cb88 --- /dev/null +++ b/examples/failing/OrphanInstanceFunDepCycle.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith OrphanInstance +module Main where +import Lib +data L +instance clr :: C L R diff --git a/examples/failing/OrphanInstanceFunDepCycle/Lib.purs b/examples/failing/OrphanInstanceFunDepCycle/Lib.purs new file mode 100644 index 0000000000..5c77a8d6ff --- /dev/null +++ b/examples/failing/OrphanInstanceFunDepCycle/Lib.purs @@ -0,0 +1,4 @@ +module Lib where +-- covering sets: {{l}, {r}} +class C l r | l -> r, r -> l +data R diff --git a/examples/failing/OrphanInstanceNullary.purs b/examples/failing/OrphanInstanceNullary.purs new file mode 100644 index 0000000000..cd2e6af653 --- /dev/null +++ b/examples/failing/OrphanInstanceNullary.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith OrphanInstance +module Test where +import Lib +instance c :: C diff --git a/examples/failing/OrphanInstanceNullary/Lib.purs b/examples/failing/OrphanInstanceNullary/Lib.purs new file mode 100644 index 0000000000..b96dc898c5 --- /dev/null +++ b/examples/failing/OrphanInstanceNullary/Lib.purs @@ -0,0 +1,2 @@ +module Lib where +class C diff --git a/examples/failing/OrphanInstanceWithDetermined.purs b/examples/failing/OrphanInstanceWithDetermined.purs new file mode 100644 index 0000000000..f905fd5ec3 --- /dev/null +++ b/examples/failing/OrphanInstanceWithDetermined.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith OrphanInstance +module Main where +import Lib +data R +instance cflr :: C F L R diff --git a/examples/failing/OrphanInstanceWithDetermined/Lib.purs b/examples/failing/OrphanInstanceWithDetermined/Lib.purs new file mode 100644 index 0000000000..03b701f88d --- /dev/null +++ b/examples/failing/OrphanInstanceWithDetermined/Lib.purs @@ -0,0 +1,5 @@ +module Lib where +-- covering sets: {{f, l}} +class C f l r | l -> r +data F +data L diff --git a/examples/passing/NonOrphanInstanceFunDepExtra.purs b/examples/passing/NonOrphanInstanceFunDepExtra.purs new file mode 100644 index 0000000000..eb86ead53a --- /dev/null +++ b/examples/passing/NonOrphanInstanceFunDepExtra.purs @@ -0,0 +1,8 @@ +-- Both f and l must be known, thus can be in separate modules +module Main where +import Control.Monad.Eff.Console (log) +import Lib +data F +data R +instance cflr :: C F L R +main = log "Done" diff --git a/examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs b/examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs new file mode 100644 index 0000000000..5909771090 --- /dev/null +++ b/examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs @@ -0,0 +1,4 @@ +module Lib where +-- covering sets: {{f, l}} +class C f l r | l -> r +data L diff --git a/examples/passing/NonOrphanInstanceMulti.purs b/examples/passing/NonOrphanInstanceMulti.purs new file mode 100644 index 0000000000..71d5634d75 --- /dev/null +++ b/examples/passing/NonOrphanInstanceMulti.purs @@ -0,0 +1,7 @@ +-- Both l and r must be known, thus can be in separate modules +module Main where +import Control.Monad.Eff.Console (log) +import Lib +data L +instance clr :: C L R +main = log "Done" diff --git a/examples/passing/NonOrphanInstanceMulti/Lib.purs b/examples/passing/NonOrphanInstanceMulti/Lib.purs new file mode 100644 index 0000000000..49b5b73e09 --- /dev/null +++ b/examples/passing/NonOrphanInstanceMulti/Lib.purs @@ -0,0 +1,4 @@ +module Lib where +-- covering sets: {{l, r}} +class C l r +data R diff --git a/purescript.cabal b/purescript.cabal index 6aed2012f2..bf50897af8 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -40,6 +40,8 @@ extra-source-files: examples/passing/*.purs , examples/passing/ModuleExportQualified/*.purs , examples/passing/ModuleExportSelf/*.purs , examples/passing/NonConflictingExports/*.purs + , examples/passing/NonOrphanInstanceMulti/*.purs + , examples/passing/NonOrphanInstanceFunDepExtra/*.purs , examples/passing/OperatorAliasElsewhere/*.purs , examples/passing/Operators/*.purs , examples/passing/PendingConflictingImports/*.purs @@ -80,6 +82,9 @@ extra-source-files: examples/passing/*.purs , examples/failing/ImportModule/*.purs , examples/failing/InstanceExport/*.purs , examples/failing/OrphanInstance/*.purs + , examples/failing/OrphanInstanceFunDepCycle/*.purs + , examples/failing/OrphanInstanceWithDetermined/*.purs + , examples/failing/OrphanInstanceNullary/*.purs , examples/warning/*.purs , examples/warning/*.js , examples/warning/UnusedExplicitImportTypeOp/*.purs diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 9db517a128..a62315fd5f 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -8,11 +8,13 @@ import Data.Aeson.TH import qualified Data.Aeson as A import qualified Data.Map as M import qualified Data.Set as S -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.List (nub) +import Data.Tree (Tree, rootLabel) import qualified Data.Graph as G +import Data.Foldable (toList) import Language.PureScript.Crash import Language.PureScript.Kinds @@ -57,6 +59,8 @@ data TypeClassData = TypeClassData -- ^ A set of indexes of type argument that are fully determined by other -- arguments via functional dependencies. This can be computed from both -- typeClassArguments and typeClassDependencies. + , typeClassCoveringSets :: S.Set (S.Set Int) + -- ^ A sets of arguments that can be used to infer all other arguments. } deriving Show -- | A functional dependency indicates a relationship between two sets of @@ -75,8 +79,11 @@ initEnvironment :: Environment initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses primKinds -- | --- A constructor for TypeClassData that computes which type class arguments are fully determined. +-- A constructor for TypeClassData that computes which type class arguments are fully determined +-- and argument covering sets. -- Fully determined means that this argument cannot be used when selecting a type class instance. +-- A covering set is a minimal collection of arguments that can be used to find an instance and +-- therefore determine all other type arguments. -- -- An example of the difference between determined and fully determined would be with the class: -- ```class C a b c | a -> b, b -> a, b -> c``` @@ -84,7 +91,8 @@ initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClas -- Both `a` and `b` can be used in selecting a type class instance. However, `c` cannot - it is -- fully determined by `a` and `b`. -- --- Define a graph of type class arguments with edges being fundep determiners to determined. +-- Define a graph of type class arguments with edges being fundep determiners to determined. Each +-- argument also has a self looping edge. -- An argument is fully determined if doesn't appear at the start of a path of strongly connected components. -- An argument is not fully determined otherwise. -- @@ -97,26 +105,51 @@ makeTypeClassData -> [Constraint] -> [FunctionalDependency] -> TypeClassData -makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs +makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs coveringSets where + argumentIndicies = [0 .. length args - 1] + + -- each argument determines themselves + identities = (\i -> (i, [i])) <$> argumentIndicies + -- list all the edges in the graph: for each fundep an edge exists for each determiner to each determined - contributingDeps = M.fromListWith (++) $ do + contributingDeps = M.fromListWith (++) $ identities ++ do fd <- deps src <- fdDeterminers fd (src, fdDetermined fd) : map (, []) (fdDetermined fd) - -- here we build a graph of which arguments determine other arguments - (depGraph, _, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps) + -- build a graph of which arguments determine other arguments + (depGraph, fromVertex, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps) -- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to + isFunDepDetermined :: Int -> Bool isFunDepDetermined arg = case fromKey arg of - Nothing -> False -- not mentioned in fundeps + Nothing -> internalError "Unknown argument index in makeTypeClassData" Just v -> let contributesToVar = G.reachable (G.transposeG depGraph) v varContributesTo = G.reachable depGraph v in any (\r -> not (r `elem` varContributesTo)) contributesToVar -- find all the arguments that are determined - determinedArgs = S.fromList $ filter isFunDepDetermined [0 .. length args - 1] + determinedArgs :: S.Set Int + determinedArgs = S.fromList $ filter isFunDepDetermined argumentIndicies + + argFromVertex :: G.Vertex -> Int + argFromVertex index = let (_, arg, _) = fromVertex index in arg + + isVertexDetermined :: G.Vertex -> Bool + isVertexDetermined = isFunDepDetermined . argFromVertex + + -- from an scc find the non-determined args + sccNonDetermined :: Tree G.Vertex -> Maybe [Int] + sccNonDetermined tree + -- if any arg in an scc is determined then all of them are + | isVertexDetermined (rootLabel tree) = Nothing + | otherwise = Just (argFromVertex <$> toList tree) + + -- find the covering sets + coveringSets :: S.Set (S.Set Int) + coveringSets = let funDepSets = sequence (mapMaybe sccNonDetermined (G.scc depGraph)) + in S.fromList (S.fromList <$> funDepSets) -- | -- The visibility of a name in scope diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index a3f95e8ff9..74831b4b56 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -716,7 +716,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS , Box.vcat Box.left (map typeAtomAsBox ts) ] , line "is an orphan instance." - , line "An orphan instance is an instance which is defined in neither the class module nor the data type module." + , line "An orphan instance is one which is defined in a module that is unrelated to either the class or the collection of data types that the instance is defined for." , line "Consider moving the instance, if possible, or using a newtype wrapper." ] renderSimpleErrorMessage (InvalidNewtype name) = diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 6b6ee209f8..c94e8282ff 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -18,7 +18,7 @@ import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Lens ((^..), _1, _2) -import Data.Foldable (for_, traverse_) +import Data.Foldable (for_, traverse_, toList) import Data.List (nub, nubBy, (\\), sort, group) import Data.Maybe import qualified Data.Map as M @@ -298,7 +298,7 @@ typeCheckAll moduleName _ = traverse go Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" Just typeClass -> do sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys) - checkOrphanInstance dictName className tys + checkOrphanInstance dictName className typeClass tys _ <- traverseTypeInstanceBody checkInstanceMembers body let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict @@ -324,19 +324,35 @@ typeCheckAll moduleName _ = traverse go | otherwise = firstDuplicate xs firstDuplicate _ = Nothing - checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m () - checkOrphanInstance dictName className@(Qualified (Just mn') _) tys' - | moduleName == mn' || any checkType tys' = return () + checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m () + checkOrphanInstance dictName className@(Qualified (Just mn') _) typeClass tys' + | moduleName == mn' || moduleName `S.member` nonOrphanModules = return () | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys' where - checkType :: Type -> Bool - checkType (TypeVar _) = False - checkType (TypeLevelString _) = False - checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn'' - checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance" - checkType (TypeApp t1 _) = checkType t1 - checkType _ = internalError "Invalid type in instance in checkOrphanInstance" - checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance" + typeModule :: Type -> Maybe ModuleName + typeModule (TypeVar _) = Nothing + typeModule (TypeLevelString _) = Nothing + typeModule (TypeConstructor (Qualified (Just mn'') _)) = Just mn'' + typeModule (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance" + typeModule (TypeApp t1 _) = typeModule t1 + typeModule _ = internalError "Invalid type in instance in checkOrphanInstance" + + modulesByTypeIndex :: M.Map Int (Maybe ModuleName) + modulesByTypeIndex = M.fromList (zip [0 ..] (typeModule <$> tys')) + + lookupModule :: Int -> S.Set ModuleName + lookupModule idx = case M.lookup idx modulesByTypeIndex of + Just ms -> S.fromList (toList ms) + Nothing -> internalError "Unknown type index in checkOrphanInstance" + + -- If the instance is declared in a module that wouldn't be found based on a covering set + -- then it is considered an orphan - because we'd have a situation in which we expect an + -- instance but can't find it. So a valid module must be applicable across *all* covering + -- sets - therefore we take the intersection of covering set modules. + nonOrphanModules :: S.Set ModuleName + nonOrphanModules = foldl1 S.intersection (foldMap lookupModule `S.map` typeClassCoveringSets typeClass) + + checkOrphanInstance _ _ _ _ = internalError "Unqualified class name in checkOrphanInstance" -- | -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, From 773d778a3df014d64a509abe043969d919ec9ae6 Mon Sep 17 00:00:00 2001 From: Michael Ficarra Date: Sun, 11 Dec 2016 18:20:34 -0800 Subject: [PATCH 0594/1580] fixes #2438: represent PureScript strings as sequence of Word16 --- examples/passing/RecordLabels.purs | 5 + .../passing/RecordLabels/RecordLabels.purs | 25 ++++ examples/passing/StringEscapes.purs | 2 +- purescript.cabal | 3 + src/Language/PureScript/AST/Declarations.hs | 14 ++- src/Language/PureScript/AST/Literals.hs | 6 +- src/Language/PureScript/CodeGen/JS.hs | 35 +++--- src/Language/PureScript/CodeGen/JS/AST.hs | 10 +- .../PureScript/CodeGen/JS/Optimizer/Common.hs | 7 +- .../CodeGen/JS/Optimizer/Inliner.hs | 7 +- .../CodeGen/JS/Optimizer/MagicDo.hs | 13 +- src/Language/PureScript/CoreFn/Desugar.hs | 5 +- src/Language/PureScript/CoreFn/Expr.hs | 6 +- src/Language/PureScript/CoreFn/ToJSON.hs | 5 +- .../PureScript/Docs/RenderedCode/Render.hs | 7 +- src/Language/PureScript/Errors.hs | 27 ++-- src/Language/PureScript/Label.hs | 30 +++++ src/Language/PureScript/PSString.hs | 118 ++++++++++++++++++ src/Language/PureScript/Parser/Common.hs | 7 ++ .../PureScript/Parser/Declarations.hs | 17 +-- src/Language/PureScript/Parser/Lexer.hs | 24 ++-- src/Language/PureScript/Parser/Types.hs | 6 +- src/Language/PureScript/Pretty/Common.hs | 12 +- src/Language/PureScript/Pretty/JS.hs | 39 ++---- src/Language/PureScript/Pretty/Types.hs | 14 ++- src/Language/PureScript/Pretty/Values.hs | 13 +- .../PureScript/Sugar/ObjectWildcards.hs | 8 +- src/Language/PureScript/Sugar/TypeClasses.hs | 6 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 54 ++++---- .../PureScript/TypeChecker/Entailment.hs | 10 +- src/Language/PureScript/TypeChecker/Types.hs | 35 +++--- src/Language/PureScript/TypeChecker/Unify.hs | 3 +- src/Language/PureScript/Types.hs | 12 +- tests/support/bower.json | 1 + 34 files changed, 388 insertions(+), 198 deletions(-) create mode 100644 examples/passing/RecordLabels.purs create mode 100644 examples/passing/RecordLabels/RecordLabels.purs create mode 100644 src/Language/PureScript/Label.hs create mode 100644 src/Language/PureScript/PSString.hs diff --git a/examples/passing/RecordLabels.purs b/examples/passing/RecordLabels.purs new file mode 100644 index 0000000000..b58a4bda0e --- /dev/null +++ b/examples/passing/RecordLabels.purs @@ -0,0 +1,5 @@ +module Main where + +import RecordLabels as RecordLabels + +main = RecordLabels.main diff --git a/examples/passing/RecordLabels/RecordLabels.purs b/examples/passing/RecordLabels/RecordLabels.purs new file mode 100644 index 0000000000..c3716db649 --- /dev/null +++ b/examples/passing/RecordLabels/RecordLabels.purs @@ -0,0 +1,25 @@ +module RecordLabels where + +import Prelude +import Data.Generic (class Generic, gShow) +import Control.Monad.Eff.Console (log) +import Test.Assert (assert') + +newtype AstralKeys = AstralKeys { "💡" :: Int, "💢" :: Int } +newtype LoneSurrogateKeys = LoneSurrogateKeys { "\xdf06" :: Int, "\xd834" :: Int } + +derive instance genericAstralKeys :: Generic AstralKeys +derive instance genericLoneSurrogateKeys :: Generic LoneSurrogateKeys + +loneSurrogateKeys = + gShow (LoneSurrogateKeys { "\xdf06": 0, "\xd834": 1 }) == + """LoneSurrogateKeys { "\xdf06": 0, "\xd834": 1 }""" + +astralKeys = + gShow (AstralKeys { "💡": 0, "💢": 1 }) == + """AstralKeys { "💡": 0, "💢": 1 }""" + +main = do + assert' "lone surrogate keys" loneSurrogateKeys + assert' "astral keys" astralKeys + log "Done" diff --git a/examples/passing/StringEscapes.purs b/examples/passing/StringEscapes.purs index 55487d125e..9fbcab2028 100644 --- a/examples/passing/StringEscapes.purs +++ b/examples/passing/StringEscapes.purs @@ -22,5 +22,5 @@ main = do assert' "astral code points are represented as a UTF-16 surrogate pair" surrogatePair assert' "lone surrogates may be combined into a surrogate pair" loneSurrogates assert' "lone surrogates may be combined out of order to remain lone surrogates" outOfOrderSurrogates - -- assert' "lone surrogates are not replaced with the Unicode replacement character U+FFFD" notReplacing + assert' "lone surrogates are not replaced with the Unicode replacement character U+FFFD" notReplacing log "Done" diff --git a/purescript.cabal b/purescript.cabal index 6aed2012f2..98d17c22bf 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -141,6 +141,7 @@ library protolude >= 0.1.6, regex-tdfa -any, safe >= 0.3.9 && < 0.4, + scientific >= 0.3.4.9 && < 0.4, semigroups >= 0.16.2 && < 0.19, sourcemap >= 0.1.6, spdx == 0.2.*, @@ -194,6 +195,7 @@ library Language.PureScript.Errors Language.PureScript.Errors.JSON Language.PureScript.Kinds + Language.PureScript.Label Language.PureScript.Linter Language.PureScript.Linter.Exhaustive Language.PureScript.Linter.Imports @@ -214,6 +216,7 @@ library Language.PureScript.Pretty.Kinds Language.PureScript.Pretty.Types Language.PureScript.Pretty.Values + Language.PureScript.PSString Language.PureScript.Renamer Language.PureScript.Sugar Language.PureScript.Sugar.BindingGroups diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 781ec09beb..8be41932ff 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -18,6 +18,8 @@ import Language.PureScript.AST.Literals import Language.PureScript.AST.Operators import Language.PureScript.AST.SourcePos import Language.PureScript.Types +import Language.PureScript.PSString (PSString) +import Language.PureScript.Label (Label) import Language.PureScript.Names import Language.PureScript.Kinds import Language.PureScript.TypeClassDictionaries @@ -90,7 +92,7 @@ data SimpleErrorMessage | CannotDerive (Qualified (ProperName 'ClassName)) [Type] | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type] | CannotFindDerivingType (ProperName 'TypeName) - | DuplicateLabel Text (Maybe Expr) + | DuplicateLabel Label (Maybe Expr) | DuplicateValueDeclaration Ident | ArgListLengthsDiffer Ident | OverlappingArgNames (Maybe Ident) @@ -99,8 +101,8 @@ data SimpleErrorMessage | ExpectedType Type Kind | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName)) | ExprDoesNotHaveType Expr Type - | PropertyIsMissing Text - | AdditionalProperty Text + | PropertyIsMissing Label + | AdditionalProperty Label | TypeSynonymInstance | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type] | InvalidNewtype (ProperName 'TypeName) @@ -145,7 +147,7 @@ data ErrorMessageHint | ErrorInModule ModuleName | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type] | ErrorInSubsumption Type Type - | ErrorCheckingAccessor Expr Text + | ErrorCheckingAccessor Expr PSString | ErrorCheckingType Expr Type | ErrorCheckingKind Type | ErrorCheckingGuard @@ -573,11 +575,11 @@ data Expr -- Anonymous arguments will be removed during desugaring and expanded -- into a lambda that reads a property from a record. -- - | Accessor Text Expr + | Accessor PSString Expr -- | -- Partial record update -- - | ObjectUpdate Expr [(Text, Expr)] + | ObjectUpdate Expr [(PSString, Expr)] -- | -- Function introduction -- diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs index 3a456237af..a161fd82ab 100644 --- a/src/Language/PureScript/AST/Literals.hs +++ b/src/Language/PureScript/AST/Literals.hs @@ -4,7 +4,7 @@ module Language.PureScript.AST.Literals where import Prelude.Compat -import Data.Text (Text) +import Language.PureScript.PSString (PSString) -- | -- Data type for literal values. Parameterised so it can be used for Exprs and @@ -18,7 +18,7 @@ data Literal a -- | -- A string literal -- - | StringLiteral Text + | StringLiteral PSString -- | -- A character literal -- @@ -34,5 +34,5 @@ data Literal a -- | -- An object literal -- - | ObjectLiteral [(Text, a)] + | ObjectLiteral [(PSString, a)] deriving (Eq, Ord, Show, Functor) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index c92de6bbc3..b6929952aa 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -20,6 +20,7 @@ import qualified Data.Foldable as F import qualified Data.Map as M import Data.Maybe (fromMaybe, isNothing) import Data.Monoid ((<>)) +import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T @@ -34,6 +35,7 @@ import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..), errorMessage, rethrowWithPosition, addHint) import Language.PureScript.Names import Language.PureScript.Options +import Language.PureScript.PSString (PSString, mkString, codePoints) import Language.PureScript.Traversals (sndM) import qualified Language.PureScript.Constants as C @@ -65,8 +67,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = let moduleBody = header : foreign' ++ jsImports ++ concat optimized let foreignExps = exps `intersect` (fst `map` foreigns) let standardExps = exps \\ foreignExps - let exps' = JSObjectLiteral Nothing $ map (runIdent &&& JSVar Nothing . identToJs) standardExps - ++ map (runIdent &&& foreignIdent) foreignExps + let exps' = JSObjectLiteral Nothing $ map (mkString . runIdent &&& JSVar Nothing . identToJs) standardExps + ++ map (mkString . runIdent &&& foreignIdent) foreignExps return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps'] where @@ -108,7 +110,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS importToJs mnLookup mn' = do let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (T.pack (".." T.unpack (runModuleName mn')))] + let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (fromString (".." T.unpack (runModuleName mn')))] withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody) -- | @@ -176,12 +178,13 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- indexer is returned. -- accessor :: Ident -> JS -> JS - accessor (Ident prop) = accessorString prop + accessor (Ident prop) = accessorString $ mkString prop accessor (GenIdent _ _) = internalError "GenIdent in accessor" - accessorString :: Text -> JS -> JS - accessorString prop | identNeedsEscaping prop = JSIndexer Nothing (JSStringLiteral Nothing prop) - | otherwise = JSAccessor Nothing prop + accessorString :: PSString -> JS -> JS + accessorString prop = + let quoted = JSIndexer Nothing (JSStringLiteral Nothing prop) in + either (const quoted) (\t -> if identNeedsEscaping t then quoted else JSAccessor Nothing prop) $ codePoints prop -- | -- Generate code in the simplified Javascript intermediate representation for a value or expression. @@ -212,7 +215,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = unAbs (Abs _ arg val) = arg : unAbs val unAbs _ = [] assign :: Ident -> JS - assign name = JSAssignment Nothing (accessorString (runIdent name) (JSVar Nothing "this")) + assign name = JSAssignment Nothing (accessorString (mkString $ runIdent name) (JSVar Nothing "this")) (var name) valueToJs' (Abs _ arg val) = do ret <- valueToJs val @@ -256,7 +259,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ] valueToJs' (Constructor _ _ (ProperName ctor) fields) = let constructor = - let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] + let body = [ JSAssignment Nothing (JSAccessor Nothing (mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body) createFn = let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields) @@ -272,7 +275,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i) literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n) literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s - literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing (T.singleton c) + literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing (fromString [c]) literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps @@ -280,7 +283,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- | -- Shallow copy an object. -- - extendObj :: JS -> [(Text, JS)] -> m JS + extendObj :: JS -> [(PSString, JS)] -> m JS extendObj obj sts = do newObj <- freshName key <- freshName @@ -317,7 +320,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = qualifiedToJS f (Qualified _ a) = JSVar Nothing $ identToJs (f a) foreignIdent :: Ident -> JS - foreignIdent ident = accessorString (runIdent ident) (JSVar Nothing "$foreign") + foreignIdent ident = accessorString (mkString $ runIdent ident) (JSVar Nothing "$foreign") -- | -- Generate code in the simplified Javascript intermediate representation for pattern match binders @@ -341,7 +344,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = go _ _ _ = internalError "Invalid arguments to bindersToJs" failedPatternError :: [Text] -> JS - failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)] + failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing $ mkString failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)] failedPatternMessage :: Text failedPatternMessage = "Failed pattern match" <> maybe "" (((" at " <> runModuleName mn <> " ") <>) . displayStartEndPos) maybeSpan <> ": " @@ -391,7 +394,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = argVar <- freshName done'' <- go remain done' js <- binderToJs argVar done'' binder - return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (identToJs field) (JSVar Nothing varName))) : js) + return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (mkString $ identToJs field) (JSVar Nothing varName))) : js) binderToJs' _ _ ConstructorBinder{} = internalError "binderToJs: Invalid ConstructorBinder in binderToJs" binderToJs' varName done (NamedBinder _ ident binder) = do @@ -402,7 +405,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = literalToBinderJS varName done (NumericLiteral num) = return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSNumericLiteral Nothing num)) (JSBlock Nothing done) Nothing] literalToBinderJS varName done (CharLiteral c) = - return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing (T.singleton c))) (JSBlock Nothing done) Nothing] + return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing (fromString [c]))) (JSBlock Nothing done) Nothing] literalToBinderJS varName done (StringLiteral str) = return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing str)) (JSBlock Nothing done) Nothing] literalToBinderJS varName done (BooleanLiteral True) = @@ -411,7 +414,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = return [JSIfElse Nothing (JSUnary Nothing Not (JSVar Nothing varName)) (JSBlock Nothing done) Nothing] literalToBinderJS varName done (ObjectLiteral bs) = go done bs where - go :: [JS] -> [(Text, Binder Ann)] -> m [JS] + go :: [JS] -> [(PSString, Binder Ann)] -> m [JS] go done' [] = return done' go done' ((prop, binder):bs') = do propVar <- freshName diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index 5f124dd201..1c6c5a7153 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -11,6 +11,7 @@ import Data.Text (Text) import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.Comments +import Language.PureScript.PSString (PSString) import Language.PureScript.Traversals -- | @@ -132,7 +133,7 @@ data JS -- | -- A string literal -- - | JSStringLiteral (Maybe SourceSpan) Text + | JSStringLiteral (Maybe SourceSpan) PSString -- | -- A boolean literal -- @@ -156,11 +157,11 @@ data JS -- | -- An object literal -- - | JSObjectLiteral (Maybe SourceSpan) [(Text, JS)] + | JSObjectLiteral (Maybe SourceSpan) [(PSString, JS)] -- | -- An object property accessor expression -- - | JSAccessor (Maybe SourceSpan) Text JS + | JSAccessor (Maybe SourceSpan) PSString JS -- | -- A function introduction (optional name, arguments, body) -- @@ -240,7 +241,8 @@ data JS -- | -- Commented Javascript -- - | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Eq) + | JSComment (Maybe SourceSpan) [Comment] JS + deriving (Show, Eq) withSourceSpan :: SourceSpan -> JS -> JS withSourceSpan withSpan = go diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs index 01a41caea0..ed4b8be02a 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs @@ -11,6 +11,7 @@ import Data.Maybe (fromMaybe) import Language.PureScript.Crash import Language.PureScript.CodeGen.JS.AST +import Language.PureScript.PSString (mkString) applyAll :: [a -> a] -> a -> a applyAll = foldl' (.) id @@ -71,13 +72,13 @@ removeFromBlock _ js = js isFn :: (Text, Text) -> JS -> Bool isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) = - x == fnName && y == moduleName + x == mkString fnName && y == moduleName isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = - x == fnName && y == moduleName + x == mkString fnName && y == moduleName isFn _ _ = False isDict :: (Text, Text) -> JS -> Bool -isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName +isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == mkString dictName && y == moduleName isDict _ _ = False isDict' :: [(Text, Text)] -> JS -> Bool diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index fdc482a385..dcd83b281c 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -23,6 +23,7 @@ import qualified Data.Text as T import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Optimizer.Common import qualified Language.PureScript.Constants as C +import Language.PureScript.PSString (mkString) -- TODO: Potential bug: -- Shouldn't just inline this case: { var x = 0; x.toFixed(10); } @@ -213,7 +214,7 @@ inlineCommonOperators = applyAll $ isNFn :: Text -> Int -> JS -> Bool isNFn prefix n (JSVar _ name) = name == (prefix <> T.pack (show n)) - isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix <> T.pack (show n)) + isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == mkString (prefix <> T.pack (show n)) isNFn _ _ _ = False runFn :: Int -> JS -> JS @@ -235,11 +236,11 @@ inlineCommonOperators = applyAll $ convert other = other isModFn :: (Text, Text) -> JS -> Bool - isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op' + isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && mkString op == op' isModFn _ _ = False isModFnWithDict :: (Text, Text) -> JS -> Bool - isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [(JSVar _ _)]) = m == m' && op == op' + isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [JSVar _ _]) = m == m' && mkString op == op' isModFnWithDict _ _ = False -- (f <<< g $ x) = f (g x) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs index 8fb82abb34..5be77d37dd 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs @@ -12,6 +12,7 @@ import Data.Maybe (fromJust, isJust) import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Optimizer.Common import Language.PureScript.Options +import Language.PureScript.PSString (mkString) import qualified Language.PureScript.Constants as C magicDo :: Options -> JS -> JS @@ -67,7 +68,7 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert -- Check if an expression represents the polymorphic pure or return function isPurePoly = isFn (C.controlApplicative, C.pure') -- Check if an expression represents a function in the Eff module - isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name' + isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && mkString name == name' isEffFunc _ _ = False -- Remove __do function applications which remain after desugaring @@ -104,16 +105,16 @@ inlineST = everywhereOnJS convertBlock -- or in a more aggressive way, turning wrappers into local variables depending on the -- agg(ressive) parameter. convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f = - JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(C.stRefValue, arg)]]) + JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(mkString C.stRefValue, arg)]]) convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f = - if agg then ref else JSAccessor s1 C.stRefValue ref + if agg then ref else JSAccessor s1 (mkString C.stRefValue) ref convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f = - if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) arg + if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 (mkString C.stRefValue) ref) arg convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f = - if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) (JSApp s1 func [JSAccessor s1 C.stRefValue ref]) + if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSAccessor s1 (mkString C.stRefValue) ref) (JSApp s1 func [JSAccessor s1 (mkString C.stRefValue) ref]) convert _ other = other -- Check if an expression represents a function in the ST module - isSTFunc name (JSAccessor _ name' (JSVar _ st)) = st == C.st && name == name' + isSTFunc name (JSAccessor _ name' (JSVar _ st)) = st == C.st && mkString name == name' isSTFunc _ _ = False -- Find all ST Refs initialized in this block findSTRefsIn = everythingOnJS (++) isSTRef diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 99a5fa754b..d02657cdc0 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -24,6 +24,7 @@ import Language.PureScript.Environment import Language.PureScript.Names import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDictionaryNames) import Language.PureScript.Types +import Language.PureScript.PSString (mkString) import qualified Language.PureScript.AST as A -- | @@ -119,7 +120,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = in foldl (App (ss, com, Nothing, Nothing)) ctor args exprToCoreFn ss com ty (A.TypeClassDictionaryAccessor _ ident) = Abs (ss, com, ty, Nothing) (Ident "dict") - (Accessor nullAnn (runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict"))) + (Accessor nullAnn (mkString $ runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict"))) exprToCoreFn _ com ty (A.PositionedValue ss com1 v) = exprToCoreFn (Just ss) (com ++ com1) ty v exprToCoreFn _ _ _ e = @@ -265,7 +266,7 @@ mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.De mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral []) mkTypeClassConstructor ss com supers members = let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers - props = [ (arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ] + props = [ (mkString arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ] dict = Literal nullAnn (ObjectLiteral props) in Abs (ss, com, Nothing, Just IsTypeClassConstructor) (Ident a) diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index 0d01b9e15e..981bf37c0f 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -6,11 +6,11 @@ module Language.PureScript.CoreFn.Expr where import Prelude.Compat import Control.Arrow ((***)) -import Data.Text (Text) import Language.PureScript.AST.Literals import Language.PureScript.CoreFn.Binders import Language.PureScript.Names +import Language.PureScript.PSString (PSString) -- | -- Data type for expressions and terms @@ -27,11 +27,11 @@ data Expr a -- | -- A record property accessor -- - | Accessor a Text (Expr a) + | Accessor a PSString (Expr a) -- | -- Partial record update -- - | ObjectUpdate a (Expr a) [(Text, Expr a)] + | ObjectUpdate a (Expr a) [(PSString, Expr a)] -- | -- Function introduction -- diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 8ad72423e1..62ab806f4e 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -17,6 +17,7 @@ import qualified Data.Text as T import Language.PureScript.AST.Literals import Language.PureScript.CoreFn import Language.PureScript.Names +import Language.PureScript.PSString (PSString, codePoints) literalToJSON :: (a -> Value) -> Literal a -> Value literalToJSON _ (NumericLiteral (Left n)) = toJSON ("IntLiteral", n) @@ -51,8 +52,8 @@ bindToJSON :: Bind a -> Value bindToJSON (NonRec _ n e) = object [ runIdent n .= exprToJSON e ] bindToJSON (Rec bs) = object $ map (\((_, n), e) -> runIdent n .= exprToJSON e) bs -recordToJSON :: (a -> Value) -> [(Text, a)] -> Value -recordToJSON f = object . map (\(label, a) -> label .= f a) +recordToJSON :: (a -> Value) -> [(PSString, a)] -> Value +recordToJSON f = object . map (\(key, a) -> either T.pack id (codePoints key) .= f a) exprToJSON :: Expr a -> Value exprToJSON (Var _ i) = toJSON ( "Var" diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index 281cd6b2b1..df3f50e413 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -27,6 +27,7 @@ import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Pretty.Kinds import Language.PureScript.Types +import Language.PureScript.Label (Label(..), renderPSLabel) typeLiterals :: Pattern () Type RenderedCode typeLiterals = mkPattern match @@ -79,13 +80,13 @@ renderRow = uncurry renderRow' . rowToList where renderRow' h t = renderHead h <> renderTail t -renderHead :: [(Text, Type)] -> RenderedCode +renderHead :: [(Label, Type)] -> RenderedCode renderHead = mintersperse (syntax "," <> sp) . map renderLabel -renderLabel :: (Text, Type) -> RenderedCode +renderLabel :: (Label, Type) -> RenderedCode renderLabel (label, ty) = mintersperse sp - [ ident label + [ syntax $ renderPSLabel label , syntax "::" , renderType ty ] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index a3f95e8ff9..03c86ddb6c 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -32,10 +32,11 @@ import Language.PureScript.Names import Language.PureScript.Pretty import Language.PureScript.Traversals import Language.PureScript.Types -import Language.PureScript.Pretty.Common (endWith) +import Language.PureScript.PSString (renderPSString) +import Language.PureScript.Label (Label(..)) +import Language.PureScript.Pretty.Common (before, endWith) import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.Constants as C -import Language.PureScript.Pretty.Common (before) import qualified System.Console.ANSI as ANSI @@ -264,7 +265,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con - gSimple (AmbiguousTypeVariables t con) = AmbiguousTypeVariables <$> (f t) <*> pure con + gSimple (AmbiguousTypeVariables t con) = AmbiguousTypeVariables <$> f t <*> pure con gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts @@ -563,12 +564,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS sortRows t1 t2 = (t1, t2) -- Put the common labels last - sortRows' :: ([(Text, Type)], Type) -> ([(Text, Type)], Type) -> (Type, Type) + sortRows' :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> (Type, Type) sortRows' (s1, r1) (s2, r2) = - let common :: [(Text, (Type, Type))] + let common :: [(Label, (Type, Type))] common = sortBy (comparing fst) [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] - sd1, sd2 :: [(Text, Type)] + sd1, sd2 :: [(Label, Type)] sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] in ( rowFromList (sortBy (comparing fst) sd1 ++ map (fst &&& fst . snd) common, r1) @@ -670,8 +671,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS ] renderSimpleErrorMessage (CannotFindDerivingType nm) = line $ "Cannot derive a type class instance, because the type declaration for " <> markCode (runProperName nm) <> " could not be found." - renderSimpleErrorMessage (DuplicateLabel l expr) = - paras $ [ line $ "Label " <> markCode l <> " appears more than once in a row type." ] + renderSimpleErrorMessage (DuplicateLabel (Label l) expr) = + paras $ [ line $ "Label " <> T.pack (show l) <> " appears more than once in a row type." ] <> foldMap (\expr' -> [ line "Relevant expression: " , markCodeBox $ indent $ prettyPrintValue valueDepth expr' ]) expr @@ -703,10 +704,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS , line "does not have type" , markCodeBox $ indent $ typeAsBox ty ] - renderSimpleErrorMessage (PropertyIsMissing prop) = - line $ "Type of expression lacks required label " <> markCode prop <> "." - renderSimpleErrorMessage (AdditionalProperty prop) = - line $ "Type of expression contains additional label " <> markCode prop <> "." + renderSimpleErrorMessage (PropertyIsMissing (Label prop)) = + line $ "Type of expression lacks required label " <> T.pack (show prop) <> "." + renderSimpleErrorMessage (AdditionalProperty (Label prop)) = + line $ "Type of expression contains additional label " <> T.pack (show prop) <> "." renderSimpleErrorMessage TypeSynonymInstance = line "Type class instances for type synonyms are disallowed." renderSimpleErrorMessage (OrphanInstance nm cnm ts) = @@ -1263,7 +1264,7 @@ renderBox = unlines whiteSpace = all isSpace toTypelevelString :: Type -> Maybe Box.Box -toTypelevelString (TypeLevelString s) = Just $ Box.text (T.unpack s) +toTypelevelString (TypeLevelString s) = Just $ Box.text $ T.unpack $ renderPSString s toTypelevelString (TypeApp (TypeConstructor f) x) | f == primName "TypeString" = Just $ typeAsBox x toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret) diff --git a/src/Language/PureScript/Label.hs b/src/Language/PureScript/Label.hs new file mode 100644 index 0000000000..36630ffea7 --- /dev/null +++ b/src/Language/PureScript/Label.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Language.PureScript.Label (Label(..), renderPSLabel) where + +import Prelude.Compat hiding (lex) +import Data.Monoid () +import Data.String (IsString(..)) +import Data.Text (Text) +import Text.Parsec.Combinator (eof) +import qualified Data.Aeson as A + +import Language.PureScript.Parser.Common (runTokenParser) +import Language.PureScript.Parser.Lexer (TokenParser, lname, lex) +import Language.PureScript.PSString (PSString, codePoints, renderPSString) + +-- | +-- Labels are used as record keys and row entry names. Labels newtype PSString +-- because records are indexable by PureScript strings at runtime. +-- +newtype Label = Label PSString + deriving (Show, Eq, Ord, IsString, Monoid, A.ToJSON, A.FromJSON) + +renderPSLabel :: Label -> Text +renderPSLabel (Label s) = + let quoted = const $ renderPSString s in + either quoted (\t -> either quoted (const t) $ runParser lname t) $ codePoints s + +runParser :: TokenParser a -> Text -> Either String a +runParser p s = either (Left . show) Right $ do + ts <- lex "" s + runTokenParser "" (p <* eof) ts diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs new file mode 100644 index 0000000000..0fda3c531c --- /dev/null +++ b/src/Language/PureScript/PSString.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +module Language.PureScript.PSString (PSString, mkString, renderPSString, renderJSON, toUTF16CodeUnits, codePoints, containsLoneSurrogates) where + +import Prelude.Compat +import Numeric (showHex) +import Data.List (unfoldr) +import Data.Monoid ((<>)) +import Data.Scientific (toBoundedInteger) +import Data.String (IsString(..)) +import Data.Text (Text) +import Data.Word (Word16) +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A +import qualified Data.Vector as V +import qualified Data.Text as T + +-- | +-- Strings in PureScript are sequences of UTF-16 code units, which do not +-- necessarily represent UTF-16 encoded text. For example, it is permissible +-- for a string to contain *lone surrogates,* i.e. characters in the range +-- U+D800 to U+DFFF which do not appear as a part of a surrogate pair. +-- +-- +newtype PSString = PSString [Word16] + deriving (Eq, Ord, Monoid) + +instance Show PSString where + show = either show show . codePoints + +renderPSString :: PSString -> Text +renderPSString = T.pack . either show show . codePoints + +-- NOTE: lone surrogates in the given PSString are represented in the resulting +-- String as the reserved code point with that index +codePoints :: PSString -> Either String Text +codePoints s = (if containsLoneSurrogates s then Left . unfoldr decode else Right . T.unfoldr decode) $ toUTF16CodeUnits s + where + decode :: [Word16] -> Maybe (Char, [Word16]) + decode (h:l:rest) | isLead h && isTrail l = Just (unsurrogate h l, rest) + decode (c:rest) = Just (toChar c, rest) + decode [] = Nothing + + unsurrogate :: Word16 -> Word16 -> Char + unsurrogate h l = toEnum ((toInt h - 0xD800) * 0x400 + (toInt l - 0xDC00) + 0x10000) + +containsLoneSurrogates :: PSString -> Bool +containsLoneSurrogates = or . unfoldr headIsLoneSurrogate . toUTF16CodeUnits + where + headIsLoneSurrogate :: [Word16] -> Maybe (Bool, [Word16]) + headIsLoneSurrogate (h:l:rest) | isLead h && isTrail l = Just (False, rest) + headIsLoneSurrogate (c:rest) = Just (isLead c || isTrail c, rest) + headIsLoneSurrogate [] = Nothing + +instance IsString PSString where + fromString a = PSString $ concatMap encodeUTF16 a + where + surrogates :: Char -> (Word16, Word16) + surrogates c = (toWord (h + 0xD800), toWord (l + 0xDC00)) + where (h, l) = divMod (fromEnum c - 0x10000) 0x400 + + encodeUTF16 :: Char -> [Word16] + encodeUTF16 c | fromEnum c > 0xFFFF = [high, low] + where (high, low) = surrogates c + encodeUTF16 c = [toWord $ fromEnum c] + +instance A.ToJSON PSString where + toJSON = A.toJSON . toUTF16CodeUnits + +instance A.FromJSON PSString where + parseJSON a = PSString <$> parseArrayOfCodeUnits a + where + parseArrayOfCodeUnits :: A.Value -> A.Parser [Word16] + parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" $ \b -> sequence (parseCodeUnit <$> V.toList b) + parseCodeUnit :: A.Value -> A.Parser Word16 + parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b + +renderJSON :: PSString -> Text +renderJSON s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\"" + where + encodeChar :: Word16 -> Text + encodeChar c | c > 0xFF = "\\u" <> hex 4 c + encodeChar c | c > 0x7E || c < 0x20 = "\\x" <> hex 2 c + encodeChar c | toChar c == '\b' = "\\b" + encodeChar c | toChar c == '\t' = "\\t" + encodeChar c | toChar c == '\n' = "\\n" + encodeChar c | toChar c == '\v' = "\\v" + encodeChar c | toChar c == '\f' = "\\f" + encodeChar c | toChar c == '\r' = "\\r" + encodeChar c | toChar c == '"' = "\\\"" + encodeChar c | toChar c == '\\' = "\\\\" + encodeChar c = T.singleton $ toChar c + + hex :: (Enum a) => Int -> a -> Text + hex width c = + let hs = showHex (fromEnum c) "" in + T.pack (replicate (width - length hs) '0' <> hs) + +isLead :: Word16 -> Bool +isLead h = h >= 0xD800 && h <= 0xDBFF + +isTrail :: Word16 -> Bool +isTrail l = l >= 0xDC00 && l <= 0xDFFF + +toChar :: Word16 -> Char +toChar = toEnum . fromIntegral + +toWord :: Int -> Word16 +toWord = fromIntegral + +toInt :: Word16 -> Int +toInt = fromIntegral + +mkString :: Text -> PSString +mkString = fromString . T.unpack + +toUTF16CodeUnits :: PSString -> [Word16] +toUTF16CodeUnits (PSString s) = s diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index d60a394352..0048cd9fcc 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -16,6 +16,7 @@ import Language.PureScript.Comments import Language.PureScript.Names import Language.PureScript.Parser.Lexer import Language.PureScript.Parser.State +import Language.PureScript.PSString (PSString, mkString) import qualified Text.Parsec as P @@ -72,6 +73,12 @@ parseQualified parser = part [] parseIdent :: TokenParser Ident parseIdent = Ident <$> identifier +-- | +-- Parse a label, which may look like an identifier or a string +-- +parseLabel :: TokenParser PSString +parseLabel = (mkString <$> lname) <|> stringLiteral + -- | -- Parse an operator. -- diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 42cfdaf0a0..41adc6f026 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -33,6 +33,7 @@ import Language.PureScript.Errors import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Types +import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Parser.Common import Language.PureScript.Parser.Kinds import Language.PureScript.Parser.Lexer @@ -338,15 +339,15 @@ parseBooleanLiteral = BooleanLiteral <$> booleanLiteral parseArrayLiteral :: TokenParser a -> TokenParser (Literal a) parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p) -parseObjectLiteral :: TokenParser (Text, a) -> TokenParser (Literal a) +parseObjectLiteral :: TokenParser (PSString, a) -> TokenParser (Literal a) parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p) -parseIdentifierAndValue :: TokenParser (Text, Expr) +parseIdentifierAndValue :: TokenParser (PSString, Expr) parseIdentifierAndValue = do name <- C.indented *> lname b <- P.option (Var $ Qualified Nothing (Ident name)) rest - return (name, b) + return (mkString name, b) <|> (,) <$> (C.indented *> stringLiteral) <*> rest where rest = C.indented *> colon *> C.indented *> parseValue @@ -428,16 +429,16 @@ parseInfixExpr parseHole :: TokenParser Expr parseHole = Hole <$> holeLit -parsePropertyUpdate :: TokenParser (Text, Expr) +parsePropertyUpdate :: TokenParser (PSString, Expr) parsePropertyUpdate = do - name <- lname <|> stringLiteral + name <- parseLabel _ <- C.indented *> equals value <- C.indented *> parseValue return (name, value) parseAccessor :: Expr -> TokenParser Expr parseAccessor (Constructor _) = P.unexpected "constructor" -parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) <*> pure obj +parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> parseLabel) <*> pure obj parseDo :: TokenParser Expr parseDo = do @@ -520,11 +521,11 @@ parseVarOrNamedBinder = do parseNullBinder :: TokenParser Binder parseNullBinder = underscore *> return NullBinder -parseIdentifierAndBinder :: TokenParser (Text, Binder) +parseIdentifierAndBinder :: TokenParser (PSString, Binder) parseIdentifierAndBinder = do name <- lname b <- P.option (VarBinder (Ident name)) rest - return (name, b) + return (mkString name, b) <|> (,) <$> stringLiteral <*> rest where rest = C.indented *> colon *> C.indented *> parseBinder diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index bdac6087af..f6d8c125ba 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -70,11 +70,13 @@ import Control.Monad (void, guard) import Control.Monad.Identity (Identity) import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum) import Data.Monoid ((<>)) +import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Comments import Language.PureScript.Parser.State +import Language.PureScript.PSString (PSString) import qualified Text.Parsec as P import qualified Text.Parsec.Token as PT @@ -106,7 +108,7 @@ data Token | Qualifier Text | Symbol Text | CharLiteral Char - | StringLiteral Text + | StringLiteral PSString | Number (Either Integer Double) | HoleLit Text deriving (Show, Eq, Ord) @@ -249,18 +251,6 @@ parseToken = P.choice symbolChar :: Lexer u Char symbolChar = P.satisfy isSymbolChar - surrogates :: Char -> (Char, Char) - surrogates c = (high, low) - where - (h, l) = divMod (fromEnum c - 0x10000) 0x400 - high = toEnum (h + 0xD800) - low = toEnum (l + 0xDC00) - - expandAstralCodePointToUTF16Surrogates :: Char -> [Char] - expandAstralCodePointToUTF16Surrogates c | fromEnum c > 0xFFFF = [high, low] - where (high, low) = surrogates c - expandAstralCodePointToUTF16Surrogates c = [c] - parseCharLiteral :: Lexer u Char parseCharLiteral = P.try $ do { c <- PT.charLiteral tokenParser; @@ -269,11 +259,11 @@ parseToken = P.choice else return c } - parseStringLiteral :: Lexer u Text - parseStringLiteral = blockString <|> T.pack <$> concatMap expandAstralCodePointToUTF16Surrogates <$> PT.stringLiteral tokenParser + parseStringLiteral :: Lexer u PSString + parseStringLiteral = fromString <$> (blockString <|> PT.stringLiteral tokenParser) where delimiter = P.try (P.string "\"\"\"") - blockString = delimiter *> (T.pack <$> P.manyTill P.anyChar delimiter) + blockString = delimiter *> P.manyTill P.anyChar delimiter parseNumber :: Lexer u (Either Integer Double) parseNumber = (consumeLeadingZero *> P.parserZero) <|> @@ -516,7 +506,7 @@ charLiteral = token go P. "char literal" go (CharLiteral c) = Just c go _ = Nothing -stringLiteral :: TokenParser Text +stringLiteral :: TokenParser PSString stringLiteral = token go P. "string literal" where go (StringLiteral s) = Just s diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index d218e6a9a6..403f8ff8c1 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -9,7 +9,6 @@ import Prelude.Compat import Control.Monad (when, unless) import Control.Applicative ((<|>)) -import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.AST.SourcePos @@ -18,6 +17,7 @@ import Language.PureScript.Parser.Common import Language.PureScript.Parser.Kinds import Language.PureScript.Parser.Lexer import Language.PureScript.Types +import Language.PureScript.Label (Label(..)) import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P @@ -118,8 +118,8 @@ noWildcards p = do when (containsWildcards ty) $ P.unexpected "type wildcard" return ty -parseNameAndType :: TokenParser t -> TokenParser (Text, t) -parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p +parseNameAndType :: TokenParser t -> TokenParser (Label, t) +parseNameAndType p = (,) <$> (indented *> (Label <$> parseLabel) <* indented <* doubleColon) <*> p parseRowEnding :: TokenParser Type parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> parseType diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index f5f0e2f8ae..bb61098e39 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -15,7 +15,8 @@ import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.AST (SourcePos(..), SourceSpan(..)) -import Language.PureScript.Parser.Lexer (reservedPsNames, isUnquotedKey) +import Language.PureScript.PSString (PSString) +import Language.PureScript.Label (Label(..), renderPSLabel) import Text.PrettyPrint.Boxes hiding ((<>)) import qualified Text.PrettyPrint.Boxes as Box @@ -149,10 +150,11 @@ prettyPrintMany f xs = do -- | -- Prints an object key, escaping reserved names. -- -prettyPrintObjectKey :: Text -> Text -prettyPrintObjectKey s | s `elem` reservedPsNames = T.pack (show s) - | isUnquotedKey s = s - | otherwise = T.pack (show s) +prettyPrintObjectKey :: PSString -> Text +prettyPrintObjectKey = prettyPrintLabel . Label + +prettyPrintLabel :: Label -> Text +prettyPrintLabel = renderPSLabel -- | Place a box before another, vertically when the first box takes up multiple lines. before :: Box -> Box -> Box diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index d142873f9a..b0c80262f0 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -25,8 +25,7 @@ import Language.PureScript.CodeGen.JS.Common import Language.PureScript.Comments import Language.PureScript.Crash import Language.PureScript.Pretty.Common - -import Numeric +import Language.PureScript.PSString (PSString, codePoints, renderJSON) -- TODO (Christoph): Get rid of T.unpack / pack @@ -38,7 +37,7 @@ literals = mkPattern' match' match :: (Emit gen) => JS -> StateT PrinterState Maybe gen match (JSNumericLiteral _ n) = return $ emit $ T.pack $ either show show n - match (JSStringLiteral _ s) = return $ string s + match (JSStringLiteral _ s) = return $ emit $ renderJSON s match (JSBooleanLiteral _ True) = return $ emit "true" match (JSBooleanLiteral _ False) = return $ emit "false" match (JSArrayLiteral _ xs) = mconcat <$> sequence @@ -58,9 +57,10 @@ literals = mkPattern' match' , return $ emit "}" ] where - objectPropertyToString :: (Emit gen) => Text -> gen - objectPropertyToString s | identNeedsEscaping s = string s - | otherwise = emit s + objectPropertyToString :: (Emit gen) => PSString -> gen + objectPropertyToString s = + let quoted = renderJSON s in + emit $ either (const quoted) (\t -> if identNeedsEscaping t then quoted else t) $ codePoints s match (JSBlock _ sts) = mconcat <$> sequence [ return $ emit "{\n" , withIndent $ prettyStatements sts @@ -150,29 +150,6 @@ literals = mkPattern' match' match (JSRaw _ js) = return $ emit js match _ = mzero -string :: (Emit gen) => Text -> gen -string s = emit $ "\"" <> T.concatMap encodeChar s <> "\"" - where - encodeChar :: Char -> Text - encodeChar '\b' = "\\b" - encodeChar '\t' = "\\t" - encodeChar '\n' = "\\n" - encodeChar '\v' = "\\v" - encodeChar '\f' = "\\f" - encodeChar '\r' = "\\r" - encodeChar '"' = "\\\"" - encodeChar '\\' = "\\\\" - -- PureScript strings are sequences of UTF-16 code units, so this case should never be hit. - -- If it is somehow hit, though, output the designated Unicode replacement character U+FFFD. - encodeChar c | fromEnum c > 0xFFFF = "\\uFFFD" - encodeChar c | fromEnum c > 0xFFF = "\\u" <> showHex' (fromEnum c) "" - encodeChar c | fromEnum c > 0xFF = "\\u0" <> showHex' (fromEnum c) "" - encodeChar c | fromEnum c < 0x10 = "\\x0" <> showHex' (fromEnum c) "" - encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" <> showHex' (fromEnum c) "" - encodeChar c = T.singleton c - - showHex' a b = T.pack (showHex a b) - conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS) conditional = mkPattern match where @@ -182,14 +159,14 @@ conditional = mkPattern match accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS) accessor = mkPattern match where - match (JSAccessor _ prop val) = Just (emit prop, val) + -- WARN: if `prop` does not match the `IdentifierName` grammar, this will generate invalid code; see #2513 + match (JSAccessor _ prop val) = either (const Nothing) (\t -> Just (emit t, val)) $ codePoints prop match _ = Nothing indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS) indexer = mkPattern' match where match (JSIndexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val - match _ = mzero lam :: Pattern PrinterState JS ((Maybe Text, [Text], Maybe SourceSpan), JS) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 3486077fa5..0fb73aec0b 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -27,6 +27,8 @@ import Language.PureScript.Names import Language.PureScript.Pretty.Common import Language.PureScript.Pretty.Kinds import Language.PureScript.Types +import Language.PureScript.PSString (renderPSString) +import Language.PureScript.Label (Label) import Text.PrettyPrint.Boxes hiding ((<+>)) @@ -45,22 +47,22 @@ constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructo prettyPrintRowWith :: Char -> Char -> Type -> Box prettyPrintRowWith open close = uncurry listToBox . toList [] where - nameAndTypeToPs :: Char -> String -> Type -> Box - nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintObjectKey (T.pack name)) ++ " :: ") <> typeAsBox ty + nameAndTypeToPs :: Char -> Label -> Type -> Box + nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " :: ") <> typeAsBox ty tailToPs :: Type -> Box tailToPs REmpty = nullBox tailToPs other = text "| " <> typeAsBox other - listToBox :: [(String, Type)] -> Type -> Box + listToBox :: [(Label, Type)] -> Type -> Box listToBox [] REmpty = text [open, close] listToBox [] rest = text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ] listToBox ts rest = vcat left $ zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++ [ tailToPs rest, text [close] ] - toList :: [(String, Type)] -> Type -> ([(String, Type)], Type) - toList tys (RCons name ty row) = toList ((T.unpack name, ty):tys) row + toList :: [(Label, Type)] -> Type -> ([(Label, Type)], Type) + toList tys (RCons name ty row) = toList ((name, ty):tys) row toList tys r = (reverse tys, r) prettyPrintRow :: Type -> String @@ -116,7 +118,7 @@ matchTypeAtom suggesting = typeLiterals = mkPattern match where match TypeWildcard{} = Just $ text "_" match (TypeVar var) = Just $ text $ T.unpack var - match (TypeLevelString s) = Just . text $ show s + match (TypeLevelString s) = Just . text $ T.unpack $ renderPSString s match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor match (TUnknown u) diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 14838c5abf..2d93f552e2 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -22,6 +22,7 @@ import Language.PureScript.Names import Language.PureScript.Pretty.Common import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox) import Language.PureScript.Types (Constraint(..)) +import Language.PureScript.PSString (PSString, renderPSString) import Text.PrettyPrint.Boxes @@ -40,10 +41,10 @@ list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ cl ellipsis :: Box ellipsis = text "..." -prettyPrintObject :: Int -> [(Text, Maybe Expr)] -> Box +prettyPrintObject :: Int -> [(PSString, Maybe Expr)] -> Box prettyPrintObject d = list '{' '}' prettyPrintObjectProperty where - prettyPrintObjectProperty :: (Text, Maybe Expr) -> Box + prettyPrintObjectProperty :: (PSString, Maybe Expr) -> Box prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value -- | Pretty-print an expression @@ -55,7 +56,7 @@ prettyPrintValue d (IfThenElse cond th el) = , text "else " <> prettyPrintValueAtom (d - 1) el ]) prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop) -prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (\(key, val) -> textT (key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps +prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (\(key, val) -> textT (prettyPrintObjectKey key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) @@ -105,7 +106,7 @@ prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` tex prettyPrintLiteralValue :: Int -> Literal Expr -> Box prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n -prettyPrintLiteralValue _ (StringLiteral s) = text $ show s +prettyPrintLiteralValue _ (StringLiteral s) = text $ T.unpack $ renderPSString s prettyPrintLiteralValue _ (CharLiteral c) = text $ show c prettyPrintLiteralValue _ (BooleanLiteral True) = text "true" prettyPrintLiteralValue _ (BooleanLiteral False) = text "false" @@ -169,7 +170,7 @@ prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) = prettyPrintBinderAtom (ParensInBinder b) = parensT (prettyPrintBinder b) prettyPrintLiteralBinder :: Literal Binder -> Text -prettyPrintLiteralBinder (StringLiteral str) = T.pack (show str) +prettyPrintLiteralBinder (StringLiteral str) = renderPSString str prettyPrintLiteralBinder (CharLiteral c) = T.pack (show c) prettyPrintLiteralBinder (NumericLiteral num) = either (T.pack . show) (T.pack . show) num prettyPrintLiteralBinder (BooleanLiteral True) = "true" @@ -179,7 +180,7 @@ prettyPrintLiteralBinder (ObjectLiteral bs) = Monoid.<> T.intercalate ", " (map prettyPrintObjectPropertyBinder bs) Monoid.<> " }" where - prettyPrintObjectPropertyBinder :: (Text, Binder) -> Text + prettyPrintObjectPropertyBinder :: (PSString, Binder) -> Text prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key Monoid.<> ": " Monoid.<> prettyPrintBinder binder prettyPrintLiteralBinder (ArrayLiteral bs) = "[ " diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index b92782a391..3e306d0d81 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -11,11 +11,11 @@ import Control.Monad.Supply.Class import Data.List (partition) import Data.Maybe (catMaybes) -import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Names +import Language.PureScript.PSString (PSString) desugarObjectConstructors :: forall m @@ -62,7 +62,7 @@ desugarDecl other = fn other return $ foldr (Abs . Left) if_ (catMaybes [u', t', f']) desugarExpr e = return e - wrapLambda :: ([(Text, Expr)] -> Expr) -> [(Text, Expr)] -> m Expr + wrapLambda :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr wrapLambda mkVal ps = let (args, props) = partition (isAnonymousArgument . snd) ps in if null args @@ -75,7 +75,7 @@ desugarDecl other = fn other stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e stripPositionInfo e = e - peelAnonAccessorChain :: Expr -> Maybe [Text] + peelAnonAccessorChain :: Expr -> Maybe [PSString] peelAnonAccessorChain (Accessor p e) = (p :) <$> peelAnonAccessorChain e peelAnonAccessorChain (PositionedValue _ _ e) = peelAnonAccessorChain e peelAnonAccessorChain AnonymousArgument = Just [] @@ -86,7 +86,7 @@ desugarDecl other = fn other isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e isAnonymousArgument _ = False - mkProp :: (Text, Expr) -> m (Maybe Ident, (Text, Expr)) + mkProp :: (PSString, Expr) -> m (Maybe Ident, (PSString, Expr)) mkProp (name, e) = do arg <- freshIfAnon e return (arg, (name, maybe e argToExpr arg)) diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 4b1007f3f2..b20a066583 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -19,6 +19,8 @@ import Language.PureScript.Externs import Language.PureScript.Sugar.CaseDeclarations import Control.Monad.Supply.Class import Language.PureScript.Types +import Language.PureScript.Label (Label(..)) +import Language.PureScript.PSString (mkString) import qualified Language.PureScript.Constants as C @@ -240,7 +242,7 @@ typeClassDictionaryDeclaration name args implies members = ] members' = map (first runIdent . memberToNameAndType) members mtys = members' ++ superclassTypes - in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyRecord $ rowFromList (mtys, REmpty)) + in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyRecord $ rowFromList (map (first (Label . mkString)) mtys, REmpty)) typeClassMemberToDictionaryAccessor :: ModuleName @@ -297,7 +299,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = , let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs ] - let props = Literal $ ObjectLiteral (members ++ superclasses) + let props = Literal $ ObjectLiteral $ map (first mkString) (members ++ superclasses) dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy) dict = TypeClassDictionaryConstructorApp className props diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 8b5ad3c872..69281ef87b 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -14,6 +14,7 @@ import qualified Data.Map as M import Data.Maybe (fromMaybe, mapMaybe) import Data.Ord (comparing) import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.AST import qualified Language.PureScript.Constants as C import Language.PureScript.Crash @@ -22,6 +23,8 @@ import Language.PureScript.Errors import Language.PureScript.Externs import Language.PureScript.Kinds import Language.PureScript.Names +import Language.PureScript.Label (Label(..)) +import Language.PureScript.PSString (mkString, codePoints) import Language.PureScript.Types import Language.PureScript.TypeChecker (checkNewtype) import Language.PureScript.TypeChecker.Synonyms (SynonymMap, replaceAllTypeSynonymsM) @@ -207,7 +210,7 @@ deriveGeneric mn syns ds tyConNm dargs = do idents <- replicateM (length tys) freshIdent' tys' <- mapM (replaceAllTypeSynonymsM syns) tys let caseResult = - App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName)) + App (prodConstructor (Literal . StringLiteral . mkString . showQualified runProperName $ Qualified (Just mn) ctorName)) . Literal . ArrayLiteral $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys' return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right caseResult) @@ -216,7 +219,7 @@ deriveGeneric mn syns ds tyConNm dargs = do toSpineFun i r | Just rec <- objectType r = lamNull . recordConstructor . Literal . ArrayLiteral . map - (\(str,typ) -> + (\((Label str),typ) -> Literal $ ObjectLiteral [ ("recLabel", Literal (StringLiteral str)) , ("recValue", toSpineFun (Accessor str i) typ) @@ -235,7 +238,7 @@ deriveGeneric mn syns ds tyConNm dargs = do App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) - (Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) name)))) + (Literal (StringLiteral $ mkString (showQualified runProperName (Qualified (Just mn) name)))) ) . Literal . ArrayLiteral @@ -249,7 +252,7 @@ deriveGeneric mn syns ds tyConNm dargs = do mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr mkProdClause (ctorName, tys) = Literal $ ObjectLiteral - [ ("sigConstructor", Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))) + [ ("sigConstructor", Literal (StringLiteral $ mkString (showQualified runProperName (Qualified (Just mn) ctorName)))) , ("sigValues", Literal . ArrayLiteral . map (mkProductSignature . instantiate) $ tys) ] @@ -260,7 +263,7 @@ deriveGeneric mn syns ds tyConNm dargs = do [ ("recLabel", Literal (StringLiteral str)) , ("recValue", mkProductSignature typ) ] - | (str, typ) <- decomposeRec rec + | ((Label str), typ) <- decomposeRec rec ] mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature)) (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ)) @@ -291,7 +294,7 @@ deriveGeneric mn syns ds tyConNm dargs = do return $ CaseAlternative [ prodBinder - [ LiteralBinder (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))) + [ LiteralBinder (StringLiteral $ mkString (showQualified runProperName (Qualified (Just mn) ctorName))) , LiteralBinder (ArrayLiteral (map VarBinder idents)) ] ] @@ -314,16 +317,16 @@ deriveGeneric mn syns ds tyConNm dargs = do (App e unitVal) fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e unitVal) - mkRecCase :: [(Text, Type)] -> CaseAlternative + mkRecCase :: [(Label, Type)] -> CaseAlternative mkRecCase rs = CaseAlternative - [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . Ident . fst) rs)) ] ] + [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . labelToIdent . fst) rs)) ] ] . Right - $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs) + $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar $ labelToIdent x)) y) rs) - mkRecFun :: [(Text, Type)] -> Expr - mkRecFun xs = mkJust $ foldr (lam . Ident . fst) recLiteral xs - where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs + mkRecFun :: [(Label, Type)] -> Expr + mkRecFun xs = mkJust $ foldr (lam . labelToIdent . fst) recLiteral xs + where recLiteral = Literal . ObjectLiteral $ map (\(l@(Label s), _) -> (s, mkVar $ labelToIdent l)) xs mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration" @@ -405,7 +408,7 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do args' <- mapM (replaceAllTypeSynonymsM syns) args (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args' return ( TypeApp (TypeApp (TypeConstructor constructor) - (TypeLevelString (runProperName ctorName))) + (TypeLevelString $ mkString (runProperName ctorName))) ctorTy , CaseAlternative [ ConstructorBinder constructor [matchProduct] ] (Right (foldl App (Constructor (Qualified (Just mn) ctorName)) ctorArgs)) @@ -430,19 +433,19 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr) makeArg arg | Just rec <- objectType arg = do let fields = decomposeRec rec - fieldNames <- traverse freshIdent (map fst fields) + fieldNames <- traverse freshIdent (map ((\(Label s) -> either T.pack id $ codePoints s) . fst) fields) pure ( TypeApp (TypeConstructor record) (foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) - (map (\(name, ty) -> + (map (\((Label name), ty) -> TypeApp (TypeApp (TypeConstructor field) (TypeLevelString name)) ty) fields)) , ConstructorBinder record [ foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2]) (map (\ident -> ConstructorBinder field [VarBinder ident]) fieldNames) ] , Literal . ObjectLiteral $ - zipWith (\(name, _) ident -> (name, Var (Qualified Nothing ident))) fields fieldNames + zipWith (\((Label name), _) ident -> (name, Var (Qualified Nothing ident))) fields fieldNames , LiteralBinder . ObjectLiteral $ - zipWith (\(name, _) ident -> (name, VarBinder ident)) fields fieldNames + zipWith (\((Label name), _) ident -> (name, VarBinder ident)) fields fieldNames , record' $ foldr1 (\e1 -> App (App (Constructor productName) e1)) (map (field' . Var . Qualified Nothing) fieldNames) @@ -574,7 +577,7 @@ deriveEq mn syns ds tyConNm = do toEqTest :: Expr -> Expr -> Type -> Expr toEqTest l r ty | Just rec <- objectType ty = conjAll - . map (\(str, typ) -> toEqTest (Accessor str l) (Accessor str r) typ) + . map (\((Label str), typ) -> toEqTest (Accessor str l) (Accessor str r) typ) $ decomposeRec rec toEqTest l r _ = preludeEq l r @@ -661,7 +664,7 @@ deriveOrd mn syns ds tyConNm = do toOrdering :: Expr -> Expr -> Type -> Expr toOrdering l r ty | Just rec <- objectType ty = appendAll - . map (\(str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ) + . map (\((Label str), typ) -> toOrdering (Accessor str l) (Accessor str r) typ) $ decomposeRec rec toOrdering l r _ = ordCompare l r @@ -733,11 +736,14 @@ mkVarMn mn = Var . Qualified mn mkVar :: Ident -> Expr mkVar = mkVarMn Nothing +labelToIdent :: Label -> Ident +labelToIdent (Label l) = Ident $ either T.pack id $ codePoints l + objectType :: Type -> Maybe Type objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec objectType _ = Nothing -decomposeRec :: Type -> [(Text, Type)] +decomposeRec :: Type -> [(Label, Type)] decomposeRec = sortBy (comparing fst) . go where go (RCons str typ typs) = (str, typ) : decomposeRec typs go _ = [] @@ -790,17 +796,17 @@ deriveFunctor mn syns ds tyConNm = do goType recTy | Just row <- objectType recTy = traverse buildUpdate (decomposeRec row) >>= (traverse buildRecord . justUpdates) where - justUpdates :: [Maybe (Text, Expr)] -> Maybe [(Text, Expr)] + justUpdates :: [Maybe (Label, Expr)] -> Maybe [(Label, Expr)] justUpdates = foldMap (fmap return) - buildUpdate :: (Text, Type) -> m (Maybe (Text, Expr)) + buildUpdate :: (Label, Type) -> m (Maybe (Label, Expr)) buildUpdate (lbl, ty) = do upd <- goType ty return ((lbl,) <$> upd) - buildRecord :: [(Text, Expr)] -> m Expr + buildRecord :: [(Label, Expr)] -> m Expr buildRecord updates = do arg <- freshIdent "o" let argVar = mkVar arg - mkAssignment (l, x) = (l, App x (Accessor l argVar)) + mkAssignment ((Label l), x) = (l, App x (Accessor l argVar)) return (lam arg (ObjectUpdate argVar (mkAssignment <$> updates))) -- under a `* -> *`, just assume functor for now diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index ae5374fbab..e5e33cbb9c 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -37,13 +37,15 @@ import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types +import Language.PureScript.Label (Label(..)) +import Language.PureScript.PSString (PSString, mkString) import qualified Language.PureScript.Constants as C -- | Describes what sort of dictionary to generate for type class instances data Evidence = NamedInstance (Qualified Ident) -- ^ An existing named instance - | IsSymbolInstance Text + | IsSymbolInstance PSString -- ^ Computed instance of the IsSymbol type class for a given Symbol literal | CompareSymbolInstance -- ^ Computed instance of CompareSymbol @@ -319,7 +321,7 @@ entails SolverOptions{..} constraint context hints = -- Turn a DictionaryValue into a Expr subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr subclassDictionaryValue dict superclassName index = - App (Accessor (C.__superclass_ <> showQualified runProperName superclassName <> "_" <> T.pack (show index)) + App (Accessor (mkString (C.__superclass_ <> showQualified runProperName superclassName <> "_" <> T.pack (show index))) dict) valUndefined @@ -387,7 +389,7 @@ matches deps TypeClassDictionaryInScope{..} tys = do sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] - go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> (Bool, Matching [Type]) + go :: [(Label, Type)] -> Type -> [(Label, Type)] -> Type -> (Bool, Matching [Type]) go l (KindedType t1 _) r t2 = go l t1 r t2 go l t1 r (KindedType t2 _) = go l t1 r t2 go [] REmpty [] REmpty = (True, M.empty) @@ -429,7 +431,7 @@ matches deps TypeClassDictionaryInScope{..} tys = do sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2' where - go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> Bool + go :: [(Label, Type)] -> Type -> [(Label, Type)] -> Type -> Bool go l (KindedType t1 _) r t2 = go l t1 r t2 go l t1 r (KindedType t2 _) = go l t1 r t2 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 665f569b29..e474072edf 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -41,7 +41,6 @@ import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import qualified Data.Map as M import qualified Data.Set as S -import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Crash @@ -60,6 +59,8 @@ import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.TypeChecker.TypeSearch import Language.PureScript.TypeChecker.Unify import Language.PureScript.Types +import Language.PureScript.Label (Label(..)) +import Language.PureScript.PSString (PSString) data BindingGroupType @@ -289,22 +290,22 @@ infer' (Literal (ArrayLiteral vals)) = do infer' (Literal (ObjectLiteral ps)) = do ensureNoDuplicateProperties ps ts <- traverse (infer . snd) ps - let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts + let fields = zipWith (\name (TypedValue _ _ t) -> (Label name, t)) (map fst ps) ts ty = TypeApp tyRecord $ rowFromList (fields, REmpty) return $ TypedValue True (Literal (ObjectLiteral (zip (map fst ps) ts))) ty infer' (ObjectUpdate o ps) = do ensureNoDuplicateProperties ps row <- freshType newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps - let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals - oldTys <- zip (map fst ps) <$> replicateM (length ps) freshType + let newTys = map (\(name, TypedValue _ _ ty) -> (Label name, ty)) newVals + oldTys <- zip (map (Label . fst) ps) <$> replicateM (length ps) freshType let oldTy = TypeApp tyRecord $ rowFromList (oldTys, row) o' <- TypedValue True <$> check o oldTy <*> pure oldTy return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyRecord $ rowFromList (newTys, row) infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do field <- freshType rest <- freshType - typed <- check val (TypeApp tyRecord (RCons prop field rest)) + typed <- check val (TypeApp tyRecord (RCons (Label prop) field rest)) return $ TypedValue True (Accessor prop typed) field infer' (Abs (Left arg) ret) = do ty <- freshType @@ -442,12 +443,12 @@ inferBinder val (LiteralBinder (ObjectLiteral props)) = do unifyTypes val (TypeApp tyRecord row) return m1 where - inferRowProperties :: Type -> Type -> [(Text, Binder)] -> m (M.Map Ident Type) + inferRowProperties :: Type -> Type -> [(PSString, Binder)] -> m (M.Map Ident Type) inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty inferRowProperties nrow row ((name, binder):binders) = do propTy <- freshType m1 <- inferBinder propTy binder - m2 <- inferRowProperties nrow (RCons name propTy row) binders + m2 <- inferRowProperties nrow (RCons (Label name) propTy row) binders return $ m1 `M.union` m2 inferBinder val (LiteralBinder (ArrayLiteral binders)) = do el <- freshType @@ -641,14 +642,14 @@ check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyRecord = do -- We need to be careful to avoid duplicate labels here. -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns. let (propsToCheck, rest) = rowToList row - (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck + (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map (Label . fst) ps) propsToCheck us <- zip (map fst removedProps) <$> replicateM (length ps) freshType obj' <- check obj (TypeApp tyRecord (rowFromList (us ++ remainingProps, rest))) ps' <- checkProperties e ps row True return $ TypedValue True (ObjectUpdate obj' ps') t check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do rest <- freshType - val' <- check val (TypeApp tyRecord (RCons prop ty rest)) + val' <- check val (TypeApp tyRecord (RCons (Label prop) ty rest)) return $ TypedValue True (Accessor prop val') ty check' v@(Constructor c) ty = do env <- getEnv @@ -681,10 +682,10 @@ check' val ty = do checkProperties :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> - [(Text, Expr)] -> + [(PSString, Expr)] -> Type -> Bool -> - m [(Text, Expr)] + m [(PSString, Expr)] checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where go [] [] REmpty = return [] go [] [] u@(TUnknown _) @@ -694,18 +695,18 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh go [] [] Skolem{} | lax = return [] go [] ((p, _): _) _ | lax = return [] | otherwise = throwError . errorMessage $ PropertyIsMissing p - go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty p + go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty $ Label p go ((p,v):ps') ts r = - case lookup p ts of + case lookup (Label p) ts of Nothing -> do v'@(TypedValue _ _ ty) <- infer v rest <- freshType - unifyTypes r (RCons p ty rest) + unifyTypes r (RCons (Label p) ty rest) ps'' <- go ps' ts rest return $ (p, v') : ps'' Just ty -> do v' <- check v ty - ps'' <- go ps' (delete (p, ty) ts) r + ps'' <- go ps' (delete (Label p, ty) ts) r return $ (p, v') : ps'' go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyRecord row) @@ -771,9 +772,9 @@ checkFunctionApplication' fn u arg = do -- | -- Ensure a set of property names and value does not contain duplicate labels -- -ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(Text, Expr)] -> m () +ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(PSString, Expr)] -> m () ensureNoDuplicateProperties ps = let ls = map fst ps in case ls \\ nub ls of - l : _ -> throwError . errorMessage $ DuplicateLabel l Nothing + l : _ -> throwError . errorMessage $ DuplicateLabel (Label l) Nothing _ -> return () diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 9625c3314f..a920e88613 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -31,6 +31,7 @@ import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Skolems +import Language.PureScript.Label (Label(..)) import Language.PureScript.Types -- | Generate a fresh type variable @@ -139,7 +140,7 @@ unifyRows r1 r2 = forM_ int (uncurry unifyTypes) unifyRows' sd1 r1' sd2 r2' where - unifyRows' :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> m () + unifyRows' :: [(Label, Type)] -> Type -> [(Label, Type)] -> Type -> m () unifyRows' [] (TUnknown u) sd r = solveType u (rowFromList (sd, r)) unifyRows' sd r [] (TUnknown u) = solveType u (rowFromList (sd, r)) unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 147701575b..247e0d7a31 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} -- | --- Data types for types +-- Data types for PureScript types and compile-time representation of PureScript terms -- module Language.PureScript.Types where @@ -20,6 +20,8 @@ import qualified Data.Text as T import Language.PureScript.AST.SourcePos import Language.PureScript.Kinds import Language.PureScript.Names +import Language.PureScript.Label (Label) +import Language.PureScript.PSString (PSString) -- | -- An identifier for the scope of a skolem variable @@ -36,7 +38,7 @@ data Type -- | A named type variable | TypeVar Text -- | A type-level string - | TypeLevelString Text + | TypeLevelString PSString -- | A type wildcard, as would appear in a partial type synonym | TypeWildcard SourceSpan -- | A type constructor @@ -55,7 +57,7 @@ data Type -- | An empty row | REmpty -- | A non-empty row - | RCons Text Type Type + | RCons Label Type Type -- | A type with a kind annotation | KindedType Type Kind -- | A placeholder used in pretty printing @@ -108,7 +110,7 @@ $(A.deriveJSON A.defaultOptions ''ConstraintData) -- | -- Convert a row to a list of pairs of labels and types -- -rowToList :: Type -> ([(Text, Type)], Type) +rowToList :: Type -> ([(Label, Type)], Type) rowToList (RCons name ty row) = let (tys, rest) = rowToList row in ((name, ty):tys, rest) rowToList r = ([], r) @@ -116,7 +118,7 @@ rowToList r = ([], r) -- | -- Convert a list of labels and types to a row -- -rowFromList :: ([(Text, Type)], Type) -> Type +rowFromList :: ([(Label, Type)], Type) -> Type rowFromList ([], r) = r rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r)) diff --git a/tests/support/bower.json b/tests/support/bower.json index c6a717307c..aef775143c 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -9,6 +9,7 @@ "purescript-st": "2.0.0", "purescript-partial": "1.1.2", "purescript-newtype": "1.1.0", + "purescript-generics": "3.3.0", "purescript-generics-rep": "4.0.0", "purescript-symbols": "^2.0.0", "purescript-typelevel-prelude": "https://github.com/purescript/purescript-typelevel-prelude.git#29a7123a0c29c85d4b923fcf4a7df8e45ebf9bac", From b84ef774564a14fbfb2e1c5ea5c30ba43426e876 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 2 Jan 2017 18:52:15 +0000 Subject: [PATCH 0595/1580] Update bower-json to 1.0.0.1 Fixes #2528 --- purescript.cabal | 2 +- src/Language/PureScript/Docs/Types.hs | 6 +++--- src/Language/PureScript/Publish.hs | 13 ++++++------- src/Language/PureScript/Publish/BoxesHelpers.hs | 5 +++++ src/Language/PureScript/Publish/ErrorsWarnings.hs | 14 +++++++------- stack-ghc-8.0.yaml | 1 + stack.yaml | 2 ++ 7 files changed, 25 insertions(+), 18 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index bf50897af8..d5b44c0d49 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -116,7 +116,7 @@ library aeson-better-errors >= 0.8, ansi-terminal >= 0.6.2 && < 0.7, base-compat >=0.6.0, - bower-json >= 0.8, + bower-json >= 1.0.0.1 && < 1.1, boxes >= 0.1.4 && < 0.2.0, bytestring -any, containers -any, diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 69edffa2b8..94f4cde5f9 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -413,7 +413,7 @@ asReExport = asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a) asInPackage inner = - build <$> key "package" (perhaps (withString parsePackageName)) + build <$> key "package" (perhaps (withText parsePackageName)) <*> key "item" inner where build Nothing = Local @@ -532,7 +532,7 @@ asBookmark = asResolvedDependencies :: Parse PackageError [(PackageName, Version)] asResolvedDependencies = - eachInObjectWithKey (mapLeft ErrorInPackageMeta . parsePackageName . T.unpack) asVersion + eachInObjectWithKey (mapLeft ErrorInPackageMeta . parsePackageName) asVersion where mapLeft f (Left x) = Left (f x) mapLeft _ (Right x) = Right x @@ -557,7 +557,7 @@ instance A.ToJSON a => A.ToJSON (Package a) where , "versionTag" .= pkgVersionTag , "modules" .= pkgModules , "bookmarks" .= map (fmap (first P.runModuleName)) pkgBookmarks - , "resolvedDependencies" .= assocListToJSON (T.pack . runPackageName) + , "resolvedDependencies" .= assocListToJSON runPackageName (T.pack . showVersion) pkgResolvedDependencies , "github" .= pkgGithub diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 136991a8cd..8a862df185 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -209,7 +209,7 @@ getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExt Just Repository{..} -> do unless (repositoryType == "git") (Left (BadRepositoryType repositoryType)) - maybe (Left NotOnGithub) Right (extractGithub (T.pack repositoryUrl)) + maybe (Left NotOnGithub) Right (extractGithub repositoryUrl) checkLicense :: PackageMeta -> PrepareM () checkLicense pkgMeta = @@ -217,7 +217,7 @@ checkLicense pkgMeta = [] -> userError NoLicenseSpecified ls -> - unless (any isValidSPDX ls) + unless (any (isValidSPDX . T.unpack) ls) (userError InvalidLicense) -- | @@ -320,8 +320,7 @@ asResolvedDependencies = nubBy ((==) `on` fst) <$> go go = fmap (fromMaybe []) $ keyMay "dependencies" $ - (++) <$> eachInObjectWithKey (parsePackageName . T.unpack) - asDependencyStatus + (++) <$> eachInObjectWithKey parsePackageName asDependencyStatus <*> (concatMap snd <$> eachInObject asResolvedDependencies) -- | Extracts only the top level dependency names from the output of @@ -330,7 +329,7 @@ asToplevelDependencies :: Parse BowerError [PackageName] asToplevelDependencies = fmap (map fst) $ key "dependencies" $ - eachInObjectWithKey (parsePackageName . T.unpack) (return ()) + eachInObjectWithKey parsePackageName (return ()) asDependencyStatus :: Parse e DependencyStatus asDependencyStatus = do @@ -371,7 +370,7 @@ handleDeps deps = do ResolvedOther _ -> (ms, pkgName : os, is) ResolvedVersion v -> (ms, os, (pkgName, v) : is) - bowerDir pkgName = "bower_components/" ++ runPackageName pkgName + bowerDir pkgName = T.unpack $ "bower_components/" <> runPackageName pkgName -- Try to extract a version, and warn if unsuccessful. tryExtractVersion' :: (PackageName, Text) -> PrepareM (Maybe (PackageName, Version)) @@ -406,6 +405,6 @@ getPackageName fp = do let xs = splitOn [pathSeparator] fp ys <- stripPrefix ["bower_components"] xs y <- headMay ys - case Bower.mkPackageName y of + case Bower.mkPackageName (T.pack y) of Right name -> Just name Left _ -> Nothing diff --git a/src/Language/PureScript/Publish/BoxesHelpers.hs b/src/Language/PureScript/Publish/BoxesHelpers.hs index 9a108b65b8..0fe2b0f1a7 100644 --- a/src/Language/PureScript/Publish/BoxesHelpers.hs +++ b/src/Language/PureScript/Publish/BoxesHelpers.hs @@ -6,6 +6,8 @@ module Language.PureScript.Publish.BoxesHelpers import Prelude.Compat +import Data.Text (Text) +import qualified Data.Text as T import System.IO (hPutStr, stderr) import qualified Text.PrettyPrint.Boxes as Boxes @@ -37,6 +39,9 @@ spacer = Boxes.emptyBox 1 1 bulletedList :: (a -> String) -> [a] -> [Boxes.Box] bulletedList f = map (indented . para . ("* " ++) . f) +bulletedListT :: (a -> Text) -> [a] -> [Boxes.Box] +bulletedListT f = bulletedList (T.unpack . f) + printToStderr :: Boxes.Box -> IO () printToStderr = hPutStr stderr . Boxes.render diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 597b2a4231..01935a16e8 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -65,7 +65,7 @@ data UserError data RepositoryFieldError = RepositoryFieldMissing - | BadRepositoryType String + | BadRepositoryType Text | NotOnGithub deriving (Show) @@ -213,7 +213,7 @@ displayUserError e = case e of , "installed:" ]) ] ++ - bulletedList runPackageName (NonEmpty.toList pkgs) + bulletedListT runPackageName (NonEmpty.toList pkgs) ++ [ spacer , para (concat @@ -263,7 +263,7 @@ displayRepositoryError err = case err of BadRepositoryType ty -> para (concat [ "In your bower.json file, the repository type is currently listed as " - , "\"" ++ ty ++ "\". Currently, only git repositories are supported. " + , "\"" ++ T.unpack ty ++ "\". Currently, only git repositories are supported. " , "Please publish your code in a git repository, and then update the " , "repository type in your bower.json file to \"git\"." ]) @@ -361,7 +361,7 @@ warnNoResolvedVersions pkgNames = ["The following ", packages, " did not appear to have a resolved " , "version:"]) ] ++ - bulletedList runPackageName (NonEmpty.toList pkgNames) + bulletedListT runPackageName (NonEmpty.toList pkgNames) ++ [ spacer , para (concat @@ -385,7 +385,7 @@ warnUndeclaredDependencies pkgNames = [ "The following Bower ", packages, " ", are, " installed, but not " , "declared as ", dependencies, " in your bower.json file:" ]) - : bulletedList runPackageName (NonEmpty.toList pkgNames) + : bulletedListT runPackageName (NonEmpty.toList pkgNames) warnUnacceptableVersions :: NonEmpty (PackageName, Text) -> Box warnUnacceptableVersions pkgs = @@ -403,7 +403,7 @@ warnUnacceptableVersions pkgs = , "not be parsed:" ]) ] ++ - bulletedList showTuple (NonEmpty.toList pkgs) + bulletedListT showTuple (NonEmpty.toList pkgs) ++ [ spacer , para (concat @@ -414,7 +414,7 @@ warnUnacceptableVersions pkgs = ]) ] where - showTuple (pkgName, tag) = runPackageName pkgName ++ "#" ++ T.unpack tag + showTuple (pkgName, tag) = runPackageName pkgName <> "#" <> tag warnDirtyWorkingTree :: Box warnDirtyWorkingTree = diff --git a/stack-ghc-8.0.yaml b/stack-ghc-8.0.yaml index 58ab0cc04b..bea97047b0 100644 --- a/stack-ghc-8.0.yaml +++ b/stack-ghc-8.0.yaml @@ -5,3 +5,4 @@ extra-deps: - pipes-http-1.0.2 - wai-websockets-3.0.0.9 - websockets-0.9.6.2 +- bower-json-1.0.0.1 diff --git a/stack.yaml b/stack.yaml index 3fbbbeb0da..6d5f737c8d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,5 @@ resolver: lts-6.25 packages: - '.' +extra-deps: +- bower-json-1.0.0.1 From 66be13adf8dc049a89413fe997f3751765c7170a Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 2 Jan 2017 19:12:47 +0000 Subject: [PATCH 0596/1580] Restore backwards compatibility for parsing Kinds Fixes #2530 --- src/Language/PureScript/Docs/Types.hs | 7 ++- src/Language/PureScript/Kinds.hs | 70 +++++++++++++++++++++++++-- 2 files changed, 69 insertions(+), 8 deletions(-) diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 69edffa2b8..d1224ab76d 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -10,6 +10,7 @@ import Control.Arrow (first, (***)) import Control.Monad (when) import Control.Monad.Error.Class (catchError) +import Data.Monoid ((<>)) import Data.Aeson ((.=)) import Data.Aeson.BetterErrors import Data.ByteString.Lazy (ByteString) @@ -358,8 +359,6 @@ displayPackageError e = case e of "Invalid kind: \"" <> str <> "\"" InvalidDataDeclType str -> "Invalid data declaration type: \"" <> str <> "\"" - where - (<>) = T.append instance A.FromJSON a => A.FromJSON (Package a) where parseJSON = toAesonParser displayPackageError @@ -468,8 +467,8 @@ asTypeArguments = eachInArray asTypeArgument where asTypeArgument = (,) <$> nth 0 asText <*> nth 1 (perhaps asKind) -asKind :: Parse e P.Kind -asKind = fromAesonParser +asKind :: Parse PackageError P.Kind +asKind = P.kindFromJSON .! InvalidKind asType :: Parse e P.Type asType = fromAesonParser diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 78d126b79d..c8b282fb3a 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE TemplateHaskell #-} - module Language.PureScript.Kinds where import Prelude.Compat -import qualified Data.Aeson.TH as A +import Data.Text (Text) +import qualified Data.Text as T +import Data.Aeson.BetterErrors (Parse, key, asText, asIntegral, nth, fromAesonParser, toAesonParser, throwCustomError) +import Data.Aeson ((.=)) +import qualified Data.Aeson as A import Language.PureScript.Names +import qualified Language.PureScript.Constants as C -- | The data type of kinds data Kind @@ -20,7 +23,66 @@ data Kind | NamedKind (Qualified (ProperName 'KindName)) deriving (Show, Eq, Ord) -$(A.deriveJSON A.defaultOptions ''Kind) +-- This is equivalent to the derived Aeson ToJSON instance, except that we +-- write it out manually so that we can define a parser which is +-- backwards-compatible. +instance A.ToJSON Kind where + toJSON kind = case kind of + KUnknown i -> + obj "KUnknown" i + Row k -> + obj "Row" k + FunKind k1 k2 -> + obj "FunKind" [k1, k2] + NamedKind n -> + obj "NamedKind" n + where + obj :: A.ToJSON a => Text -> a -> A.Value + obj tag contents = + A.object [ "tag" .= tag, "contents" .= contents ] + +-- This is equivalent to the derived Aeson FromJSON instance, except that it +-- also handles JSON generated by compilers up to 0.10.3 and maps them to the +-- new representations (i.e. NamedKinds which are defined in the Prim module). +kindFromJSON :: Parse Text Kind +kindFromJSON = do + t <- key "tag" asText + case t of + "KUnknown" -> do + KUnknown <$> key "contents" (nth 0 asIntegral) + "Star" -> + pure kindType + "Bang" -> + pure kindEffect + "Row" -> + Row <$> key "contents" kindFromJSON + "FunKind" -> + let + kindAt n = key "contents" (nth n kindFromJSON) + in + FunKind <$> kindAt 0 <*> kindAt 1 + "Symbol" -> + pure kindSymbol + "NamedKind" -> + NamedKind <$> key "contents" fromAesonParser + other -> + throwCustomError (T.append "Unrecognised tag: " other) + + where + -- The following are copied from Environment and reimplemented to avoid + -- circular dependencies. + primName :: Text -> Qualified (ProperName a) + primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName + + primKind :: Text -> Kind + primKind = NamedKind . primName + + kindType = primKind "Type" + kindEffect = primKind "Effect" + kindSymbol = primKind "Symbol" + +instance A.FromJSON Kind where + parseJSON = toAesonParser id kindFromJSON everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind everywhereOnKinds f = go From 5d1ef1860e3ebba72b3d4f6c3cd9a327ab770516 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 2 Jan 2017 22:11:56 +0000 Subject: [PATCH 0597/1580] Remove redundant do --- src/Language/PureScript/Kinds.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index c8b282fb3a..93cabc96b3 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -48,7 +48,7 @@ kindFromJSON :: Parse Text Kind kindFromJSON = do t <- key "tag" asText case t of - "KUnknown" -> do + "KUnknown" -> KUnknown <$> key "contents" (nth 0 asIntegral) "Star" -> pure kindType From 45478c23ccebf7ca56e7f83ace4efb4e48a7fd25 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 3 Jan 2017 02:51:35 +0000 Subject: [PATCH 0598/1580] Tidying up: represent PureScript strings as sequence of Word16 Changes: * Expand tests for string edge-cases * Remove use of `show` while printing errors * Remove `codePoints` from the export list of Language.PureScript.PSString * Fix an issue with derived Generic instances where colliding Idents were being generated * Change CoreFn/ToJSON so that invalid JSON strings (i.e. invalid UTF-16) will not be generated, since relatively few JSON parsers can cope with it (e.g. aeson) * Various function renaming and rearranging to better match existing conventions inside the compiler. Unfortunately we are forced to break the CoreFn JSON format with this change, as there is no way of generating strings that reliably parse to the value we want if strings are allowed to include invalid UTF-16. The CoreFn JSON changes in the following ways: * String literals are now generated as arrays of integers, where each integer is between 0 and 0xFFFF and represents one UTF-16 code unit (were previously generated as JSON strings). * Record literals are now generated as an array of pairs (two-element arrays), where the first element is the key, generated as an array of code units just like string literals, and the second element is the value. --- examples/passing/RecordLabels.purs | 5 - .../passing/RecordLabels/RecordLabels.purs | 25 ---- examples/passing/StringEdgeCases.purs | 9 ++ examples/passing/StringEdgeCases/Records.purs | 66 +++++++++++ examples/passing/StringEdgeCases/Symbols.purs | 30 +++++ src/Language/PureScript/CodeGen/JS.hs | 13 +- src/Language/PureScript/CodeGen/JS/AST.hs | 2 +- .../PureScript/CodeGen/JS/Optimizer/Common.hs | 4 +- .../CodeGen/JS/Optimizer/Inliner.hs | 7 +- .../CodeGen/JS/Optimizer/MagicDo.hs | 10 +- src/Language/PureScript/CoreFn/ToJSON.hs | 4 +- .../PureScript/Docs/RenderedCode/Render.hs | 9 +- src/Language/PureScript/Errors.hs | 15 ++- src/Language/PureScript/Label.hs | 20 +--- src/Language/PureScript/PSString.hs | 111 +++++++++++++----- src/Language/PureScript/Pretty.hs | 1 + src/Language/PureScript/Pretty/Common.hs | 14 +-- src/Language/PureScript/Pretty/JS.hs | 13 +- src/Language/PureScript/Pretty/Types.hs | 20 +++- src/Language/PureScript/Pretty/Values.hs | 8 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 15 ++- src/Language/PureScript/Types.hs | 2 +- 22 files changed, 271 insertions(+), 132 deletions(-) delete mode 100644 examples/passing/RecordLabels.purs delete mode 100644 examples/passing/RecordLabels/RecordLabels.purs create mode 100644 examples/passing/StringEdgeCases.purs create mode 100644 examples/passing/StringEdgeCases/Records.purs create mode 100644 examples/passing/StringEdgeCases/Symbols.purs diff --git a/examples/passing/RecordLabels.purs b/examples/passing/RecordLabels.purs deleted file mode 100644 index b58a4bda0e..0000000000 --- a/examples/passing/RecordLabels.purs +++ /dev/null @@ -1,5 +0,0 @@ -module Main where - -import RecordLabels as RecordLabels - -main = RecordLabels.main diff --git a/examples/passing/RecordLabels/RecordLabels.purs b/examples/passing/RecordLabels/RecordLabels.purs deleted file mode 100644 index c3716db649..0000000000 --- a/examples/passing/RecordLabels/RecordLabels.purs +++ /dev/null @@ -1,25 +0,0 @@ -module RecordLabels where - -import Prelude -import Data.Generic (class Generic, gShow) -import Control.Monad.Eff.Console (log) -import Test.Assert (assert') - -newtype AstralKeys = AstralKeys { "💡" :: Int, "💢" :: Int } -newtype LoneSurrogateKeys = LoneSurrogateKeys { "\xdf06" :: Int, "\xd834" :: Int } - -derive instance genericAstralKeys :: Generic AstralKeys -derive instance genericLoneSurrogateKeys :: Generic LoneSurrogateKeys - -loneSurrogateKeys = - gShow (LoneSurrogateKeys { "\xdf06": 0, "\xd834": 1 }) == - """LoneSurrogateKeys { "\xdf06": 0, "\xd834": 1 }""" - -astralKeys = - gShow (AstralKeys { "💡": 0, "💢": 1 }) == - """AstralKeys { "💡": 0, "💢": 1 }""" - -main = do - assert' "lone surrogate keys" loneSurrogateKeys - assert' "astral keys" astralKeys - log "Done" diff --git a/examples/passing/StringEdgeCases.purs b/examples/passing/StringEdgeCases.purs new file mode 100644 index 0000000000..b361eb1aa3 --- /dev/null +++ b/examples/passing/StringEdgeCases.purs @@ -0,0 +1,9 @@ +module Main where + +import Prelude +import Records as Records +import Symbols as Symbols + +main = do + Records.main + Symbols.main diff --git a/examples/passing/StringEdgeCases/Records.purs b/examples/passing/StringEdgeCases/Records.purs new file mode 100644 index 0000000000..faa58c6751 --- /dev/null +++ b/examples/passing/StringEdgeCases/Records.purs @@ -0,0 +1,66 @@ +module Records where + +import Prelude +import Data.Generic (class Generic, toSpine, GenericSpine(..)) +import Control.Monad.Eff.Console (log) +import Test.Assert (assert') + +newtype AstralKeys = AstralKeys { "💡" :: Int, "💢" :: Int } +newtype LoneSurrogateKeys = LoneSurrogateKeys { "\xdf06" :: Int, "\xd834" :: Int } + +derive instance genericAstralKeys :: Generic AstralKeys +derive instance genericLoneSurrogateKeys :: Generic LoneSurrogateKeys + +spineOf :: forall a. Generic a => a -> Unit -> GenericSpine +spineOf x _ = toSpine x + +testLoneSurrogateKeys = + let + expected = 5 + actual = (_."\xd801" <<< helper) { "\xd800": 5 } + in + assert' ("lone surrogate keys: " <> show actual) (expected == actual) + + where + helper :: { "\xd800" :: Int } -> { "\xd801" :: Int } + helper o = + case o."\xd800" of + x -> { "\xd801": x } + +testAstralKeys = + let + expected = 5 + actual = (_."💢" <<< helper) { "💡": 5 } + in + assert' ("astral keys: " <> show actual) (expected == actual) + + where + helper :: { "💡" :: Int } -> { "💢" :: Int } + helper o = + case o."💡" of + x -> { "💢": x } + +testGenericLoneSurrogateKeys = do + let expected = SProd "Records.LoneSurrogateKeys" + [ \_ -> SRecord [ {recLabel: "\xd834", recValue: spineOf 1} + , {recLabel: "\xdf06", recValue: spineOf 0} + ] + ] + actual = toSpine (LoneSurrogateKeys { "\xdf06": 0, "\xd834": 1 }) + assert' ("generic lone surrogate keys: " <> show actual) (expected == actual) + +testGenericAstralKeys = do + let expected = SProd "Records.AstralKeys" + [ \_ -> SRecord [ {recLabel: "💡", recValue: spineOf 0} + , {recLabel: "💢", recValue: spineOf 1} + ] + ] + actual = toSpine (AstralKeys { "💡": 0, "💢": 1 }) + assert' ("generic astral keys: " <> show actual) (expected == actual) + +main = do + testLoneSurrogateKeys + testAstralKeys + testGenericLoneSurrogateKeys + testGenericAstralKeys + log "Done" diff --git a/examples/passing/StringEdgeCases/Symbols.purs b/examples/passing/StringEdgeCases/Symbols.purs new file mode 100644 index 0000000000..991563adf6 --- /dev/null +++ b/examples/passing/StringEdgeCases/Symbols.purs @@ -0,0 +1,30 @@ +-- This is similar to StringEscapes except we are performing the same tests +-- with Symbols (at the type level). + +module Symbols where + +import Prelude +import Control.Monad.Eff.Console (log) +import Type.Data.Symbol (SProxy(..), class AppendSymbol, appendSymbol, reflectSymbol) +import Test.Assert (assert') + +highS :: SProxy "\xd834" +highS = SProxy + +lowS :: SProxy "\xdf06" +lowS = SProxy + +loneSurrogates :: Boolean +loneSurrogates = reflectSymbol (appendSymbol highS lowS) == "\x1d306" + +outOfOrderSurrogates :: Boolean +outOfOrderSurrogates = reflectSymbol (appendSymbol lowS highS) == "\xdf06\xd834" + +notReplacing :: Boolean +notReplacing = reflectSymbol lowS /= "\xfffd" + +main = do + assert' "lone surrogates may be combined into a surrogate pair" loneSurrogates + assert' "lone surrogates may be combined out of order to remain lone surrogates" outOfOrderSurrogates + assert' "lone surrogates are not replaced with the Unicode replacement character U+FFFD" notReplacing + log "Done" diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index b6929952aa..0abc9de05d 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -35,7 +35,7 @@ import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..), errorMessage, rethrowWithPosition, addHint) import Language.PureScript.Names import Language.PureScript.Options -import Language.PureScript.PSString (PSString, mkString, codePoints) +import Language.PureScript.PSString (PSString, mkString, decodeString) import Language.PureScript.Traversals (sndM) import qualified Language.PureScript.Constants as C @@ -183,8 +183,11 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = accessorString :: PSString -> JS -> JS accessorString prop = - let quoted = JSIndexer Nothing (JSStringLiteral Nothing prop) in - either (const quoted) (\t -> if identNeedsEscaping t then quoted else JSAccessor Nothing prop) $ codePoints prop + case decodeString prop of + Just s | not (identNeedsEscaping s) -> + JSAccessor Nothing s + _ -> + JSIndexer Nothing (JSStringLiteral Nothing prop) -- | -- Generate code in the simplified Javascript intermediate representation for a value or expression. @@ -259,7 +262,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ] valueToJs' (Constructor _ _ (ProperName ctor) fields) = let constructor = - let body = [ JSAssignment Nothing (JSAccessor Nothing (mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] + let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body) createFn = let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields) @@ -394,7 +397,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = argVar <- freshName done'' <- go remain done' js <- binderToJs argVar done'' binder - return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (mkString $ identToJs field) (JSVar Nothing varName))) : js) + return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (identToJs field) (JSVar Nothing varName))) : js) binderToJs' _ _ ConstructorBinder{} = internalError "binderToJs: Invalid ConstructorBinder in binderToJs" binderToJs' varName done (NamedBinder _ ident binder) = do diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index 1c6c5a7153..8f3583c314 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -161,7 +161,7 @@ data JS -- | -- An object property accessor expression -- - | JSAccessor (Maybe SourceSpan) PSString JS + | JSAccessor (Maybe SourceSpan) Text JS -- | -- A function introduction (optional name, arguments, body) -- diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs index ed4b8be02a..3fc9ca30a1 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs @@ -72,13 +72,13 @@ removeFromBlock _ js = js isFn :: (Text, Text) -> JS -> Bool isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) = - x == mkString fnName && y == moduleName + x == fnName && y == moduleName isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = x == mkString fnName && y == moduleName isFn _ _ = False isDict :: (Text, Text) -> JS -> Bool -isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == mkString dictName && y == moduleName +isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName isDict _ _ = False isDict' :: [(Text, Text)] -> JS -> Bool diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index dcd83b281c..753b63d79b 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -23,7 +23,6 @@ import qualified Data.Text as T import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Optimizer.Common import qualified Language.PureScript.Constants as C -import Language.PureScript.PSString (mkString) -- TODO: Potential bug: -- Shouldn't just inline this case: { var x = 0; x.toFixed(10); } @@ -214,7 +213,7 @@ inlineCommonOperators = applyAll $ isNFn :: Text -> Int -> JS -> Bool isNFn prefix n (JSVar _ name) = name == (prefix <> T.pack (show n)) - isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == mkString (prefix <> T.pack (show n)) + isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix <> T.pack (show n)) isNFn _ _ _ = False runFn :: Int -> JS -> JS @@ -236,11 +235,11 @@ inlineCommonOperators = applyAll $ convert other = other isModFn :: (Text, Text) -> JS -> Bool - isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && mkString op == op' + isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op' isModFn _ _ = False isModFnWithDict :: (Text, Text) -> JS -> Bool - isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [JSVar _ _]) = m == m' && mkString op == op' + isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [JSVar _ _]) = m == m' && op == op' isModFnWithDict _ _ = False -- (f <<< g $ x) = f (g x) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs index 5be77d37dd..bb37d2c413 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs @@ -68,7 +68,7 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert -- Check if an expression represents the polymorphic pure or return function isPurePoly = isFn (C.controlApplicative, C.pure') -- Check if an expression represents a function in the Eff module - isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && mkString name == name' + isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name' isEffFunc _ _ = False -- Remove __do function applications which remain after desugaring @@ -107,14 +107,14 @@ inlineST = everywhereOnJS convertBlock convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f = JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(mkString C.stRefValue, arg)]]) convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f = - if agg then ref else JSAccessor s1 (mkString C.stRefValue) ref + if agg then ref else JSAccessor s1 C.stRefValue ref convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f = - if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 (mkString C.stRefValue) ref) arg + if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) arg convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f = - if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSAccessor s1 (mkString C.stRefValue) ref) (JSApp s1 func [JSAccessor s1 (mkString C.stRefValue) ref]) + if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) (JSApp s1 func [JSAccessor s1 C.stRefValue ref]) convert _ other = other -- Check if an expression represents a function in the ST module - isSTFunc name (JSAccessor _ name' (JSVar _ st)) = st == C.st && mkString name == name' + isSTFunc name (JSAccessor _ name' (JSVar _ st)) = st == C.st && name == name' isSTFunc _ _ = False -- Find all ST Refs initialized in this block findSTRefsIn = everythingOnJS (++) isSTRef diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 62ab806f4e..98feba9edd 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -17,7 +17,7 @@ import qualified Data.Text as T import Language.PureScript.AST.Literals import Language.PureScript.CoreFn import Language.PureScript.Names -import Language.PureScript.PSString (PSString, codePoints) +import Language.PureScript.PSString (PSString) literalToJSON :: (a -> Value) -> Literal a -> Value literalToJSON _ (NumericLiteral (Left n)) = toJSON ("IntLiteral", n) @@ -53,7 +53,7 @@ bindToJSON (NonRec _ n e) = object [ runIdent n .= exprToJSON e ] bindToJSON (Rec bs) = object $ map (\((_, n), e) -> runIdent n .= exprToJSON e) bs recordToJSON :: (a -> Value) -> [(PSString, a)] -> Value -recordToJSON f = object . map (\(key, a) -> either T.pack id (codePoints key) .= f a) +recordToJSON f = toJSON . map (\(key, a) -> (toJSON key, f a)) exprToJSON :: Expr a -> Value exprToJSON (Var _ i) = toJSON ( "Var" diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index df3f50e413..b8d10083c6 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -26,8 +26,9 @@ import Language.PureScript.Environment import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Pretty.Kinds +import Language.PureScript.Pretty.Types import Language.PureScript.Types -import Language.PureScript.Label (Label(..), renderPSLabel) +import Language.PureScript.Label (Label) typeLiterals :: Pattern () Type RenderedCode typeLiterals = mkPattern match @@ -86,7 +87,7 @@ renderHead = mintersperse (syntax "," <> sp) . map renderLabel renderLabel :: (Label, Type) -> RenderedCode renderLabel (label, ty) = mintersperse sp - [ syntax $ renderPSLabel label + [ syntax $ prettyPrintLabel label , syntax "::" , renderType ty ] @@ -126,9 +127,9 @@ explicitParens = mkPattern match match _ = Nothing matchTypeAtom :: Pattern () Type RenderedCode -matchTypeAtom = typeLiterals <+> fmap parens matchType +matchTypeAtom = typeLiterals <+> fmap parens_ matchType where - parens x = syntax "(" <> x <> syntax ")" + parens_ x = syntax "(" <> x <> syntax ")" matchType :: Pattern () Type RenderedCode matchType = buildPrettyPrinter operators matchTypeAtom diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 03c86ddb6c..8ba9b7ca93 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -32,7 +32,6 @@ import Language.PureScript.Names import Language.PureScript.Pretty import Language.PureScript.Traversals import Language.PureScript.Types -import Language.PureScript.PSString (renderPSString) import Language.PureScript.Label (Label(..)) import Language.PureScript.Pretty.Common (before, endWith) import qualified Language.PureScript.Bundle as Bundle @@ -671,8 +670,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS ] renderSimpleErrorMessage (CannotFindDerivingType nm) = line $ "Cannot derive a type class instance, because the type declaration for " <> markCode (runProperName nm) <> " could not be found." - renderSimpleErrorMessage (DuplicateLabel (Label l) expr) = - paras $ [ line $ "Label " <> T.pack (show l) <> " appears more than once in a row type." ] + renderSimpleErrorMessage (DuplicateLabel l expr) = + paras $ [ line $ "Label " <> prettyPrintLabel l <> " appears more than once in a row type." ] <> foldMap (\expr' -> [ line "Relevant expression: " , markCodeBox $ indent $ prettyPrintValue valueDepth expr' ]) expr @@ -704,10 +703,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS , line "does not have type" , markCodeBox $ indent $ typeAsBox ty ] - renderSimpleErrorMessage (PropertyIsMissing (Label prop)) = - line $ "Type of expression lacks required label " <> T.pack (show prop) <> "." - renderSimpleErrorMessage (AdditionalProperty (Label prop)) = - line $ "Type of expression contains additional label " <> T.pack (show prop) <> "." + renderSimpleErrorMessage (PropertyIsMissing prop) = + line $ "Type of expression lacks required label " <> prettyPrintLabel prop <> "." + renderSimpleErrorMessage (AdditionalProperty prop) = + line $ "Type of expression contains additional label " <> prettyPrintLabel prop <> "." renderSimpleErrorMessage TypeSynonymInstance = line "Type class instances for type synonyms are disallowed." renderSimpleErrorMessage (OrphanInstance nm cnm ts) = @@ -1264,7 +1263,7 @@ renderBox = unlines whiteSpace = all isSpace toTypelevelString :: Type -> Maybe Box.Box -toTypelevelString (TypeLevelString s) = Just $ Box.text $ T.unpack $ renderPSString s +toTypelevelString (TypeLevelString s) = Just $ Box.text $ T.unpack $ prettyPrintString s toTypelevelString (TypeApp (TypeConstructor f) x) | f == primName "TypeString" = Just $ typeAsBox x toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret) diff --git a/src/Language/PureScript/Label.hs b/src/Language/PureScript/Label.hs index 36630ffea7..3c8123d69e 100644 --- a/src/Language/PureScript/Label.hs +++ b/src/Language/PureScript/Label.hs @@ -1,30 +1,16 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Language.PureScript.Label (Label(..), renderPSLabel) where +module Language.PureScript.Label (Label(..)) where import Prelude.Compat hiding (lex) import Data.Monoid () import Data.String (IsString(..)) -import Data.Text (Text) -import Text.Parsec.Combinator (eof) import qualified Data.Aeson as A -import Language.PureScript.Parser.Common (runTokenParser) -import Language.PureScript.Parser.Lexer (TokenParser, lname, lex) -import Language.PureScript.PSString (PSString, codePoints, renderPSString) +import Language.PureScript.PSString (PSString) -- | -- Labels are used as record keys and row entry names. Labels newtype PSString -- because records are indexable by PureScript strings at runtime. -- -newtype Label = Label PSString +newtype Label = Label { runLabel :: PSString } deriving (Show, Eq, Ord, IsString, Monoid, A.ToJSON, A.FromJSON) - -renderPSLabel :: Label -> Text -renderPSLabel (Label s) = - let quoted = const $ renderPSString s in - either quoted (\t -> either quoted (const t) $ runParser lname t) $ codePoints s - -runParser :: TokenParser a -> Text -> Either String a -runParser p s = either (Left . show) Right $ do - ts <- lex "" s - runTokenParser "" (p <* eof) ts diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index 0fda3c531c..caacb677fc 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -1,19 +1,35 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -module Language.PureScript.PSString (PSString, mkString, renderPSString, renderJSON, toUTF16CodeUnits, codePoints, containsLoneSurrogates) where +module Language.PureScript.PSString + ( PSString + , toUTF16CodeUnits + , decodeString + , decodeStringEither + , prettyPrintString + , prettyPrintStringJS + , mkString + ) where import Prelude.Compat -import Numeric (showHex) +import Control.Exception (try, evaluate) +import Data.Char (chr) +import Data.Bits (shiftR) import Data.List (unfoldr) import Data.Monoid ((<>)) import Data.Scientific (toBoundedInteger) import Data.String (IsString(..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS import Data.Text (Text) -import Data.Word (Word16) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf16BE) +import Data.Text.Encoding.Error (UnicodeException) +import qualified Data.Vector as V +import Data.Word (Word16, Word8) +import Numeric (showHex) +import System.IO.Unsafe (unsafePerformIO) import qualified Data.Aeson as A import qualified Data.Aeson.Types as A -import qualified Data.Vector as V -import qualified Data.Text as T -- | -- Strings in PureScript are sequences of UTF-16 code units, which do not @@ -21,36 +37,71 @@ import qualified Data.Text as T -- for a string to contain *lone surrogates,* i.e. characters in the range -- U+D800 to U+DFFF which do not appear as a part of a surrogate pair. -- +-- The Show instance for PSString produces a string literal which would +-- represent the same data were it inserted into a PureScript source file. -- -newtype PSString = PSString [Word16] +newtype PSString = PSString { toUTF16CodeUnits :: [Word16] } deriving (Eq, Ord, Monoid) instance Show PSString where - show = either show show . codePoints + show = show . codePoints -renderPSString :: PSString -> Text -renderPSString = T.pack . either show show . codePoints +-- Decode a PSString to a String, representing any lone surrogates as the +-- reserved code point with that index. Warning: if there are any lone +-- surrogates, converting the result to Text via Data.Text.pack will result in +-- loss of information as those lone surrogates will be replaced with U+FFFD +-- REPLACEMENT CHARACTER. Because this function requires care to use correctly, +-- we do not export it. +codePoints :: PSString -> String +codePoints = map (either (chr . fromIntegral) id) . decodeStringEither --- NOTE: lone surrogates in the given PSString are represented in the resulting --- String as the reserved code point with that index -codePoints :: PSString -> Either String Text -codePoints s = (if containsLoneSurrogates s then Left . unfoldr decode else Right . T.unfoldr decode) $ toUTF16CodeUnits s +-- | +-- Decode a PSString as UTF-16. Lone surrogates in the input are represented in +-- the output with the Left constructor; characters which were successfully +-- decoded are represented with the Right constructor. +-- +decodeStringEither :: PSString -> [Either Word16 Char] +decodeStringEither = unfoldr decode . toUTF16CodeUnits where - decode :: [Word16] -> Maybe (Char, [Word16]) - decode (h:l:rest) | isLead h && isTrail l = Just (unsurrogate h l, rest) - decode (c:rest) = Just (toChar c, rest) + decode :: [Word16] -> Maybe (Either Word16 Char, [Word16]) + decode (h:l:rest) | isLead h && isTrail l = Just (Right (unsurrogate h l), rest) + decode (c:rest) | isSurrogate c = Just (Left c, rest) + decode (c:rest) = Just (Right (toChar c), rest) decode [] = Nothing unsurrogate :: Word16 -> Word16 -> Char unsurrogate h l = toEnum ((toInt h - 0xD800) * 0x400 + (toInt l - 0xDC00) + 0x10000) -containsLoneSurrogates :: PSString -> Bool -containsLoneSurrogates = or . unfoldr headIsLoneSurrogate . toUTF16CodeUnits +-- | +-- Pretty print a PSString, using Haskell/PureScript escape sequences. +-- This is identical to the Show instance except that we get a Text out instead +-- of a String. +-- +prettyPrintString :: PSString -> Text +prettyPrintString = T.pack . show + +-- | +-- Attempt to decode a PSString as UTF-16 text. This will fail (returning +-- Nothing) if the argument contains lone surrogates. +-- +decodeString :: PSString -> Maybe Text +decodeString = hush . decodeEither . BS.pack . concatMap unpair . toUTF16CodeUnits where - headIsLoneSurrogate :: [Word16] -> Maybe (Bool, [Word16]) - headIsLoneSurrogate (h:l:rest) | isLead h && isTrail l = Just (False, rest) - headIsLoneSurrogate (c:rest) = Just (isLead c || isTrail c, rest) - headIsLoneSurrogate [] = Nothing + unpair w = [highByte w, lowByte w] + + lowByte :: Word16 -> Word8 + lowByte = fromIntegral + + highByte :: Word16 -> Word8 + highByte = fromIntegral . (`shiftR` 8) + + -- Based on a similar function from Data.Text.Encoding for utf8. This is a + -- safe usage of unsafePerformIO because there are no side effects after + -- handling any thrown UnicodeExceptions. + decodeEither :: ByteString -> Either UnicodeException Text + decodeEither = unsafePerformIO . try . evaluate . decodeUtf16BE + + hush = either (const Nothing) Just instance IsString PSString where fromString a = PSString $ concatMap encodeUTF16 a @@ -71,12 +122,16 @@ instance A.FromJSON PSString where parseJSON a = PSString <$> parseArrayOfCodeUnits a where parseArrayOfCodeUnits :: A.Value -> A.Parser [Word16] - parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" $ \b -> sequence (parseCodeUnit <$> V.toList b) + parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" (traverse parseCodeUnit . V.toList) parseCodeUnit :: A.Value -> A.Parser Word16 parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b -renderJSON :: PSString -> Text -renderJSON s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\"" +-- | +-- Pretty print a PSString, using JavaScript escape sequences. Intended for +-- use in compiled JS output. +-- +prettyPrintStringJS :: PSString -> Text +prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\"" where encodeChar :: Word16 -> Text encodeChar c | c > 0xFF = "\\u" <> hex 4 c @@ -102,6 +157,9 @@ isLead h = h >= 0xD800 && h <= 0xDBFF isTrail :: Word16 -> Bool isTrail l = l >= 0xDC00 && l <= 0xDFFF +isSurrogate :: Word16 -> Bool +isSurrogate c = isLead c || isTrail c + toChar :: Word16 -> Char toChar = toEnum . fromIntegral @@ -113,6 +171,3 @@ toInt = fromIntegral mkString :: Text -> PSString mkString = fromString . T.unpack - -toUTF16CodeUnits :: PSString -> [Word16] -toUTF16CodeUnits (PSString s) = s diff --git a/src/Language/PureScript/Pretty.hs b/src/Language/PureScript/Pretty.hs index b242a0505c..e9affc14d4 100644 --- a/src/Language/PureScript/Pretty.hs +++ b/src/Language/PureScript/Pretty.hs @@ -15,3 +15,4 @@ import Language.PureScript.Pretty.JS as P import Language.PureScript.Pretty.Kinds as P import Language.PureScript.Pretty.Types as P import Language.PureScript.Pretty.Values as P +import Language.PureScript.PSString as P (prettyPrintString) diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index bb61098e39..9b7b6a1bb4 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -15,8 +15,7 @@ import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.AST (SourcePos(..), SourceSpan(..)) -import Language.PureScript.PSString (PSString) -import Language.PureScript.Label (Label(..), renderPSLabel) +import Language.PureScript.Parser.Lexer (isUnquotedKey, reservedPsNames) import Text.PrettyPrint.Boxes hiding ((<>)) import qualified Text.PrettyPrint.Boxes as Box @@ -147,14 +146,9 @@ prettyPrintMany f xs = do indentString <- currentIndent return $ intercalate (emit "\n") $ map (mappend indentString) ss --- | --- Prints an object key, escaping reserved names. --- -prettyPrintObjectKey :: PSString -> Text -prettyPrintObjectKey = prettyPrintLabel . Label - -prettyPrintLabel :: Label -> Text -prettyPrintLabel = renderPSLabel +objectKeyRequiresQuoting :: Text -> Bool +objectKeyRequiresQuoting s = + s `elem` reservedPsNames || isUnquotedKey s -- | Place a box before another, vertically when the first box takes up multiple lines. before :: Box -> Box -> Box diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index b0c80262f0..0015933622 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -25,7 +25,7 @@ import Language.PureScript.CodeGen.JS.Common import Language.PureScript.Comments import Language.PureScript.Crash import Language.PureScript.Pretty.Common -import Language.PureScript.PSString (PSString, codePoints, renderJSON) +import Language.PureScript.PSString (PSString, decodeString, prettyPrintStringJS) -- TODO (Christoph): Get rid of T.unpack / pack @@ -37,7 +37,7 @@ literals = mkPattern' match' match :: (Emit gen) => JS -> StateT PrinterState Maybe gen match (JSNumericLiteral _ n) = return $ emit $ T.pack $ either show show n - match (JSStringLiteral _ s) = return $ emit $ renderJSON s + match (JSStringLiteral _ s) = return $ emit $ prettyPrintStringJS s match (JSBooleanLiteral _ True) = return $ emit "true" match (JSBooleanLiteral _ False) = return $ emit "false" match (JSArrayLiteral _ xs) = mconcat <$> sequence @@ -59,8 +59,11 @@ literals = mkPattern' match' where objectPropertyToString :: (Emit gen) => PSString -> gen objectPropertyToString s = - let quoted = renderJSON s in - emit $ either (const quoted) (\t -> if identNeedsEscaping t then quoted else t) $ codePoints s + emit $ case decodeString s of + Just s' | not (identNeedsEscaping s') -> + s' + _ -> + prettyPrintStringJS s match (JSBlock _ sts) = mconcat <$> sequence [ return $ emit "{\n" , withIndent $ prettyStatements sts @@ -160,7 +163,7 @@ accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS) accessor = mkPattern match where -- WARN: if `prop` does not match the `IdentifierName` grammar, this will generate invalid code; see #2513 - match (JSAccessor _ prop val) = either (const Nothing) (\t -> Just (emit t, val)) $ codePoints prop + match (JSAccessor _ prop val) = Just (emit prop, val) match _ = Nothing indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 0fb73aec0b..db92df6cf1 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -10,6 +10,8 @@ module Language.PureScript.Pretty.Types , prettyPrintTypeAtom , prettyPrintRowWith , prettyPrintRow + , prettyPrintLabel + , prettyPrintObjectKey ) where import Prelude.Compat @@ -18,6 +20,7 @@ import Control.Arrow ((<+>)) import Control.PatternArrows as PA import Data.Maybe (fromMaybe) +import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Crash @@ -27,8 +30,8 @@ import Language.PureScript.Names import Language.PureScript.Pretty.Common import Language.PureScript.Pretty.Kinds import Language.PureScript.Types -import Language.PureScript.PSString (renderPSString) -import Language.PureScript.Label (Label) +import Language.PureScript.PSString (PSString, prettyPrintString, decodeString) +import Language.PureScript.Label (Label(..)) import Text.PrettyPrint.Boxes hiding ((<+>)) @@ -118,7 +121,7 @@ matchTypeAtom suggesting = typeLiterals = mkPattern match where match TypeWildcard{} = Just $ text "_" match (TypeVar var) = Just $ text $ T.unpack var - match (TypeLevelString s) = Just . text $ T.unpack $ renderPSString s + match (TypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor match (TUnknown u) @@ -188,3 +191,14 @@ prettyPrintType = render . typeAsBoxImpl False -- | Generate a pretty-printed string representing a suggested 'Type' prettyPrintSuggestedType :: Type -> String prettyPrintSuggestedType = render . typeAsBoxImpl True + +prettyPrintLabel :: Label -> Text +prettyPrintLabel (Label s) = + case decodeString s of + Just s' | not (objectKeyRequiresQuoting s') -> + s' + _ -> + prettyPrintString s + +prettyPrintObjectKey :: PSString -> Text +prettyPrintObjectKey = prettyPrintLabel . Label diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 2d93f552e2..4b1c38ef9e 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -20,9 +20,9 @@ import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Names import Language.PureScript.Pretty.Common -import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox) +import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox, prettyPrintObjectKey) import Language.PureScript.Types (Constraint(..)) -import Language.PureScript.PSString (PSString, renderPSString) +import Language.PureScript.PSString (PSString, prettyPrintString) import Text.PrettyPrint.Boxes @@ -106,7 +106,7 @@ prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` tex prettyPrintLiteralValue :: Int -> Literal Expr -> Box prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n -prettyPrintLiteralValue _ (StringLiteral s) = text $ T.unpack $ renderPSString s +prettyPrintLiteralValue _ (StringLiteral s) = text $ T.unpack $ prettyPrintString s prettyPrintLiteralValue _ (CharLiteral c) = text $ show c prettyPrintLiteralValue _ (BooleanLiteral True) = text "true" prettyPrintLiteralValue _ (BooleanLiteral False) = text "false" @@ -170,7 +170,7 @@ prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) = prettyPrintBinderAtom (ParensInBinder b) = parensT (prettyPrintBinder b) prettyPrintLiteralBinder :: Literal Binder -> Text -prettyPrintLiteralBinder (StringLiteral str) = renderPSString str +prettyPrintLiteralBinder (StringLiteral str) = prettyPrintString str prettyPrintLiteralBinder (CharLiteral c) = T.pack (show c) prettyPrintLiteralBinder (NumericLiteral num) = either (T.pack . show) (T.pack . show) num prettyPrintLiteralBinder (BooleanLiteral True) = "true" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 69281ef87b..8dbb8ee14f 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -11,6 +11,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class (MonadSupply) import Data.List (foldl', find, sortBy, unzip5) import qualified Data.Map as M +import Data.Monoid ((<>)) import Data.Maybe (fromMaybe, mapMaybe) import Data.Ord (comparing) import Data.Text (Text) @@ -24,7 +25,7 @@ import Language.PureScript.Externs import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Label (Label(..)) -import Language.PureScript.PSString (mkString, codePoints) +import Language.PureScript.PSString (mkString, decodeStringEither) import Language.PureScript.Types import Language.PureScript.TypeChecker (checkNewtype) import Language.PureScript.TypeChecker.Synonyms (SynonymMap, replaceAllTypeSynonymsM) @@ -433,7 +434,7 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr) makeArg arg | Just rec <- objectType arg = do let fields = decomposeRec rec - fieldNames <- traverse freshIdent (map ((\(Label s) -> either T.pack id $ codePoints s) . fst) fields) + fieldNames <- traverse freshIdent (map (runIdent . labelToIdent . fst) fields) pure ( TypeApp (TypeConstructor record) (foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) (map (\((Label name), ty) -> @@ -736,8 +737,16 @@ mkVarMn mn = Var . Qualified mn mkVar :: Ident -> Expr mkVar = mkVarMn Nothing +-- This function may seem a little obtuse, but it's only this way to ensure +-- that it is injective. Injectivity is important here; without it, we can end +-- up with accidental variable shadowing in the generated code. labelToIdent :: Label -> Ident -labelToIdent (Label l) = Ident $ either T.pack id $ codePoints l +labelToIdent = + Ident . foldMap (either loneSurrogate char) . decodeStringEither . runLabel + where + char '_' = "__" + char c = T.singleton c + loneSurrogate x = "_" <> T.pack (show x) <> "_" objectType :: Type -> Maybe Type objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 247e0d7a31..e345ad9fbd 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} -- | --- Data types for PureScript types and compile-time representation of PureScript terms +-- Data types for types -- module Language.PureScript.Types where From 4b4762b7be79799756899064e11bb9179d90eaf3 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 3 Jan 2017 05:33:59 +0000 Subject: [PATCH 0599/1580] Fix psci tests * Stop accidentally including tests from support modules * Update support module list --- tests/TestPsci.hs | 2 +- tests/TestUtils.hs | 20 +++++++++++++++++++- 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index f758acb21b..65c71736ad 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -120,7 +120,7 @@ getPSCiState :: IO PSCiState getPSCiState = do cwd <- getCurrentDirectory let supportDir = cwd "tests" "support" "bower_components" - let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir + let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir pursFiles <- supportFiles "purs" modulesOrFirstError <- loadAllModules pursFiles diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 67e3fbf4d8..783f0c716d 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -69,11 +69,15 @@ supportModules = , "Control.Monad.Eff.Class" , "Control.Monad.Eff.Console" , "Control.Monad.Eff.Unsafe" + , "Control.Monad.Rec.Class" , "Control.Monad.ST" , "Control.MonadPlus" , "Control.MonadZero" , "Control.Plus" , "Control.Semigroupoid" + , "Data.Array" + , "Data.Array.Partial" + , "Data.Array.ST" , "Data.Bifoldable" , "Data.Bifunctor" , "Data.Bifunctor.Clown" @@ -86,7 +90,10 @@ supportModules = , "Data.Boolean" , "Data.BooleanAlgebra" , "Data.Bounded" + , "Data.Char" , "Data.CommutativeRing" + , "Data.Either" + , "Data.Either.Nested" , "Data.Eq" , "Data.EuclideanRing" , "Data.Field" @@ -95,6 +102,7 @@ supportModules = , "Data.Function.Uncurried" , "Data.Functor" , "Data.Functor.Invariant" + , "Data.Generic" , "Data.Generic.Rep" , "Data.Generic.Rep.Eq" , "Data.Generic.Rep.Monoid" @@ -102,6 +110,7 @@ supportModules = , "Data.Generic.Rep.Semigroup" , "Data.Generic.Rep.Show" , "Data.HeytingAlgebra" + , "Data.Identity" , "Data.Maybe" , "Data.Maybe.First" , "Data.Maybe.Last" @@ -115,6 +124,7 @@ supportModules = , "Data.Monoid.Multiplicative" , "Data.NaturalTransformation" , "Data.Newtype" + , "Data.NonEmpty" , "Data.Ord" , "Data.Ord.Unsafe" , "Data.Ordering" @@ -122,15 +132,23 @@ supportModules = , "Data.Semigroup" , "Data.Semiring" , "Data.Show" + , "Data.String" + , "Data.String.CaseInsensitive" + , "Data.String.Regex" + , "Data.String.Regex.Flags" + , "Data.String.Regex.Unsafe" + , "Data.String.Unsafe" , "Data.Symbol" , "Data.Traversable" + , "Data.Tuple" + , "Data.Tuple.Nested" + , "Data.Unfoldable" , "Data.Unit" , "Data.Void" , "Partial" , "Partial.Unsafe" , "Prelude" , "Test.Assert" - , "Test.Main" , "Type.Data.Ordering" , "Type.Data.Symbol" , "Type.Equality" From 072caddfb900201075eaaa9a1d31800963418e9a Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 3 Jan 2017 05:52:52 +0000 Subject: [PATCH 0600/1580] Update purescript.cabal --- purescript.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/purescript.cabal b/purescript.cabal index 98d17c22bf..99a840fe98 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -52,6 +52,7 @@ extra-source-files: examples/passing/*.purs , examples/passing/ResolvableScopeConflict3/*.purs , examples/passing/ShadowedModuleName/*.purs , examples/passing/SolvingIsSymbol/*.purs + , examples/passing/StringEdgeCases/*.purs , examples/passing/TransitiveImport/*.purs , examples/passing/TypeOperators/*.purs , examples/passing/TypeWithoutParens/*.purs From 45dd7d8d05ba1ba018fd5c78551917722a49c542 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Tue, 3 Jan 2017 20:51:34 +0100 Subject: [PATCH 0601/1580] Adds specific error message when failing to import bind (#2527) * Adds specific error message when failing to import bind * Adds markCode to bind mention in error message --- src/Language/PureScript/Errors.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 74831b4b56..ad0195dd25 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -498,6 +498,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS line $ "The type declaration for " <> markCode (showIdent nm) <> " should be followed by its definition." renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" + renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident "bind")))) = + line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode "bind" <> " function. Please import " <> markCode "bind" <> " from module " <> markCode "Prelude" renderSimpleErrorMessage (UnknownName name) = line $ "Unknown " <> printName name renderSimpleErrorMessage (UnknownImport mn name) = From 0539687a0e61d06d739bddfd3160bf7730916ae5 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 4 Jan 2017 00:57:56 +0000 Subject: [PATCH 0602/1580] Use 'markCode' when pretty-printing Labels --- src/Language/PureScript/Errors.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8ba9b7ca93..aec4bb8aec 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -671,7 +671,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS renderSimpleErrorMessage (CannotFindDerivingType nm) = line $ "Cannot derive a type class instance, because the type declaration for " <> markCode (runProperName nm) <> " could not be found." renderSimpleErrorMessage (DuplicateLabel l expr) = - paras $ [ line $ "Label " <> prettyPrintLabel l <> " appears more than once in a row type." ] + paras $ [ line $ "Label " <> markCode (prettyPrintLabel l) <> " appears more than once in a row type." ] <> foldMap (\expr' -> [ line "Relevant expression: " , markCodeBox $ indent $ prettyPrintValue valueDepth expr' ]) expr @@ -704,9 +704,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS , markCodeBox $ indent $ typeAsBox ty ] renderSimpleErrorMessage (PropertyIsMissing prop) = - line $ "Type of expression lacks required label " <> prettyPrintLabel prop <> "." + line $ "Type of expression lacks required label " <> markCode (prettyPrintLabel prop) <> "." renderSimpleErrorMessage (AdditionalProperty prop) = - line $ "Type of expression contains additional label " <> prettyPrintLabel prop <> "." + line $ "Type of expression contains additional label " <> markCode (prettyPrintLabel prop) <> "." renderSimpleErrorMessage TypeSynonymInstance = line "Type class instances for type synonyms are disallowed." renderSimpleErrorMessage (OrphanInstance nm cnm ts) = From 16c6aaeb6d47d1f4f4c220b28793cd2b11c7bde8 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 4 Jan 2017 22:05:32 +0000 Subject: [PATCH 0603/1580] Restore JSON backwards compatibility for PSStrings This allows the parser to deal with JSON produced by earlier versions of the compiler (which were generated as JSON strings) as well as the current generator (which produces arrays of integers). --- src/Language/PureScript/PSString.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index caacb677fc..5a524c96a6 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -12,6 +12,7 @@ module Language.PureScript.PSString import Prelude.Compat import Control.Exception (try, evaluate) +import Control.Applicative ((<|>)) import Data.Char (chr) import Data.Bits (shiftR) import Data.List (unfoldr) @@ -119,13 +120,20 @@ instance A.ToJSON PSString where toJSON = A.toJSON . toUTF16CodeUnits instance A.FromJSON PSString where - parseJSON a = PSString <$> parseArrayOfCodeUnits a + parseJSON a = currentParser <|> backwardsCompat where + currentParser = PSString <$> parseArrayOfCodeUnits a + parseArrayOfCodeUnits :: A.Value -> A.Parser [Word16] parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" (traverse parseCodeUnit . V.toList) + parseCodeUnit :: A.Value -> A.Parser Word16 parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b + -- For backwards compatibility: this allows us to parse JSON produced by + -- 0.10.4 or earlier + backwardsCompat = fromString <$> A.parseJSON a + -- | -- Pretty print a PSString, using JavaScript escape sequences. Intended for -- use in compiled JS output. From f478e2f5ae5993f3cea42644a7e3ed252f662dd0 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 5 Jan 2017 00:05:40 +0000 Subject: [PATCH 0604/1580] Generate PSString values as JSON strings where possible Also generate records as JSON objects in the corefn JSON where possible. This means although the the JSON format change in the next release is strictly a breaking change, the majority of code can still be processed without changing corefn parsers. --- src/Language/PureScript/CoreFn/ToJSON.hs | 14 ++++++++++++-- src/Language/PureScript/PSString.hs | 20 +++++++++++++------- 2 files changed, 25 insertions(+), 9 deletions(-) diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 98feba9edd..fa84d1bca8 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -9,6 +9,7 @@ module Language.PureScript.CoreFn.ToJSON import Prelude.Compat +import Data.Maybe (fromMaybe) import Data.Aeson import Data.Version (Version, showVersion) import Data.Text (Text) @@ -17,7 +18,7 @@ import qualified Data.Text as T import Language.PureScript.AST.Literals import Language.PureScript.CoreFn import Language.PureScript.Names -import Language.PureScript.PSString (PSString) +import Language.PureScript.PSString (PSString, decodeString) literalToJSON :: (a -> Value) -> Literal a -> Value literalToJSON _ (NumericLiteral (Left n)) = toJSON ("IntLiteral", n) @@ -52,8 +53,17 @@ bindToJSON :: Bind a -> Value bindToJSON (NonRec _ n e) = object [ runIdent n .= exprToJSON e ] bindToJSON (Rec bs) = object $ map (\((_, n), e) -> runIdent n .= exprToJSON e) bs +-- If all of the labels in the record can safely be converted to JSON strings, +-- we generate a JSON object. Otherwise the labels must be represented as +-- arrays of integers in the JSON, and in this case we generate the record as +-- an array of pairs. recordToJSON :: (a -> Value) -> [(PSString, a)] -> Value -recordToJSON f = toJSON . map (\(key, a) -> (toJSON key, f a)) +recordToJSON f rec = fromMaybe (asArrayOfPairs rec) (asObject rec) + where + asObject = fmap object . traverse (uncurry maybePair) + maybePair label a = fmap (\l -> l .= f a) (decodeString label) + + asArrayOfPairs = toJSON . map (\(label, a) -> (toJSON label, f a)) exprToJSON :: Expr a -> Value exprToJSON (Var _ i) = toJSON ( "Var" diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index 5a524c96a6..a841e43592 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -41,6 +41,11 @@ import qualified Data.Aeson.Types as A -- The Show instance for PSString produces a string literal which would -- represent the same data were it inserted into a PureScript source file. -- +-- Because JSON parsers vary wildly in terms of how they deal with lone +-- surrogates in JSON strings, the ToJSON instance for PSString produces JSON +-- strings where that would be safe (i.e. when there are no lone surrogates), +-- and arrays of UTF-16 code units (integers) otherwise. +-- newtype PSString = PSString { toUTF16CodeUnits :: [Word16] } deriving (Eq, Ord, Monoid) @@ -117,12 +122,17 @@ instance IsString PSString where encodeUTF16 c = [toWord $ fromEnum c] instance A.ToJSON PSString where - toJSON = A.toJSON . toUTF16CodeUnits + toJSON str = + case decodeString str of + Just t -> A.toJSON t + Nothing -> A.toJSON (toUTF16CodeUnits str) instance A.FromJSON PSString where - parseJSON a = currentParser <|> backwardsCompat + parseJSON a = jsonString <|> arrayOfCodeUnits where - currentParser = PSString <$> parseArrayOfCodeUnits a + jsonString = fromString <$> A.parseJSON a + + arrayOfCodeUnits = PSString <$> parseArrayOfCodeUnits a parseArrayOfCodeUnits :: A.Value -> A.Parser [Word16] parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" (traverse parseCodeUnit . V.toList) @@ -130,10 +140,6 @@ instance A.FromJSON PSString where parseCodeUnit :: A.Value -> A.Parser Word16 parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b - -- For backwards compatibility: this allows us to parse JSON produced by - -- 0.10.4 or earlier - backwardsCompat = fromString <$> A.parseJSON a - -- | -- Pretty print a PSString, using JavaScript escape sequences. Intended for -- use in compiled JS output. From a1f8b40064832928e8d65db44780ab5c34026351 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 5 Jan 2017 09:19:47 -0800 Subject: [PATCH 0605/1580] Replace type wildcards earlier (#2535) * Fix #2534, replace type wildcards earlier * More formatting * Fix remaining issue * Fix tests * More comments, some refactoring --- examples/failing/2534.purs | 8 + src/Language/PureScript/TypeChecker/Kinds.hs | 1 + src/Language/PureScript/TypeChecker/Types.hs | 239 ++++++++++--------- 3 files changed, 139 insertions(+), 109 deletions(-) create mode 100644 examples/failing/2534.purs diff --git a/examples/failing/2534.purs b/examples/failing/2534.purs new file mode 100644 index 0000000000..a4a4f27861 --- /dev/null +++ b/examples/failing/2534.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InfiniteType +module Main where + +foo :: Array Int -> Int +foo xs = go xs where + go :: Array _ -> Int + go [] = 0 + go xs = go [xs] diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 05e7a1eae1..b951431fcc 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -229,6 +229,7 @@ infer' other = (, []) <$> go other unifyKinds k k' return k' go TypeWildcard{} = freshKind + go TUnknown{} = freshKind go (TypeLevelString _) = return kindSymbol go (TypeVar v) = do Just moduleName <- checkCurrentModule <$> get diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index e474072edf..b9c382d1d9 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -34,13 +34,14 @@ import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Bifunctor (bimap) -import Data.Either (lefts, rights) +import Data.Either (partitionEithers) import Data.Functor (($>)) import Data.List (transpose, nub, (\\), partition, delete) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import qualified Data.Map as M import qualified Data.Set as S +import Data.Traversable (for) import Language.PureScript.AST import Language.PureScript.Crash @@ -62,7 +63,6 @@ import Language.PureScript.Types import Language.PureScript.Label (Label(..)) import Language.PureScript.PSString (PSString) - data BindingGroupType = RecursiveBindingGroup | NonRecursiveBindingGroup @@ -78,9 +78,9 @@ typesOf -> m [(Ident, (Expr, Type))] typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do tys <- capturingSubstitution tidyUp $ do - (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals + SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup (Just moduleName) vals ds1 <- parU typed $ \e -> withoutWarnings $ checkTypedBindingGroupElement moduleName e dict - ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict untypedDict + ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict return (map (False, ) ds1 ++ map (True, ) ds2) inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do @@ -166,81 +166,101 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do isHoleError (ErrorMessage _ HoleInferredType{}) = True isHoleError _ = False -type TypeData = M.Map (Qualified Ident) (Type, NameKind, NameVisibility) - -type UntypedData = [(Ident, Type)] - +-- | A binding group contains multiple value definitions, some of which are typed +-- and some which are not. +-- +-- This structure breaks down a binding group into typed and untyped parts. +data SplitBindingGroup = SplitBindingGroup + { _splitBindingGroupUntyped :: [(Ident, (Expr, Type))] + -- ^ The untyped expressions + , _splitBindingGroupTyped :: [(Ident, (Expr, Type, Bool))] + -- ^ The typed expressions, along with their type annotations + , _splitBindingGroupNames :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility) + -- ^ A map containing all expressions and their assigned types (which might be + -- fresh unification variables). These will be added to the 'Environment' after + -- the binding group is checked, so the value type of the 'Map' is chosen to be + -- compatible with the type of 'bindNames'. + } + +-- | This function breaks a binding group down into two sets of declarations: +-- those which contain type annotations, and those which don't. +-- This function also generates fresh unification variables for the types of +-- declarations without type annotations, returned in the 'UntypedData' structure. typeDictionaryForBindingGroup - :: (MonadState CheckState m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Maybe ModuleName -> [(Ident, Expr)] - -> m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData) + -> m SplitBindingGroup 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 - untyped = lefts es - typed = rights es - -- Make a map of names to typed declarations - typedDict = map (\(ident, (_, ty, _)) -> (ident, ty)) typed - - -- Create fresh unification variables for the types of untyped declarations - untypedNames <- replicateM (length untyped) freshType - - 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) -> (Qualified moduleName ident, (ty, Private, Undefined))) $ typedDict ++ untypedDict) - return (untyped, typed, dict, untypedDict) - + -- Filter the typed and untyped declarations and make a map of names to typed declarations. + -- Replace type wildcards here so that the resulting dictionary of types contains the + -- fully expanded types. + let (untyped, typed) = partitionEithers (map splitTypeAnnotation vals) + (typedDict, typed') <- fmap unzip . for typed $ \(ident, (expr, ty, checkType)) -> do + ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty + return ((ident, ty'), (ident, (expr, ty', checkType))) + -- Create fresh unification variables for the types of untyped declarations + (untypedDict, untyped') <- fmap unzip . for untyped $ \(ident, expr) -> do + ty <- freshType + return ((ident, ty), (ident, (expr, ty))) + -- Create the dictionary of all name/type pairs, which will be added to the + -- environment during type checking + let dict = M.fromList [ (Qualified moduleName ident, (ty, Private, Undefined)) + | (ident, ty) <- typedDict <> untypedDict + ] + return (SplitBindingGroup untyped' typed' dict) + where + -- | Check if a value contains a type annotation, and if so, separate it + -- from the value itself. + splitTypeAnnotation :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool)) + splitTypeAnnotation (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType)) + splitTypeAnnotation (name, PositionedValue pos c value) = + bimap (second (PositionedValue pos c)) + (second (\(e, t, b) -> (PositionedValue pos c e, t, b))) + (splitTypeAnnotation (name, value)) + splitTypeAnnotation (name, value) = Left (name, value) + +-- | Check the type annotation of a typed value in a binding group. checkTypedBindingGroupElement :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> (Ident, (Expr, Type, Bool)) - -> TypeData + -- ^ The identifier we are trying to define, along with the expression and its type annotation + -> M.Map (Qualified Ident) (Type, NameKind, NameVisibility) + -- ^ Names brought into scope in this binding group -> m (Ident, (Expr, Type)) -checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do - -- Replace type wildcards - ty' <- replaceTypeWildcards ty +checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do -- Kind check (kind, args) <- kindOfWithScopedVars ty checkTypeKind ty kind -- Check the type with the new names in scope - ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty' - val'' <- if checkType - then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val' ty'' <*> pure ty'' - else return (TypedValue False val' ty'') - return (ident, (val'', ty'')) + val' <- if checkType + then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val ty <*> pure ty + else return (TypedValue False val ty) + return (ident, (val', ty)) +-- | Infer a type for a value in a binding group which lacks an annotation. typeForBindingGroupElement :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => (Ident, Expr) - -> TypeData - -> UntypedData + => (Ident, (Expr, Type)) + -- ^ The identifier we are trying to define, along with the expression and its assigned type + -- (at this point, this should be a unification variable) + -> M.Map (Qualified Ident) (Type, NameKind, NameVisibility) + -- ^ Names brought into scope in this binding group -> m (Ident, (Expr, Type)) -typeForBindingGroupElement (ident, val) dict untypedDict = do +typeForBindingGroupElement (ident, (val, ty)) dict = do -- Infer the type with the new names in scope - TypedValue _ val' ty <- bindNames dict $ infer val - unifyTypes ty $ fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict) - return (ident, (TypedValue True val' ty, ty)) - --- | Check if a value contains a type annotation -isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool)) -isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType)) -isTyped (name, PositionedValue pos c value) = - bimap (second (PositionedValue pos c)) - (second (\(e, t, b) -> (PositionedValue pos c e, t, b))) - (isTyped (name, value)) -isTyped (name, value) = Left (name, value) + TypedValue _ val' ty' <- bindNames dict $ infer val + -- Unify the type with the unification variable we chose for this definition + unifyTypes ty ty' + return (ident, (TypedValue True val' ty', ty')) -- | Check the kind of a type, failing if it is not of kind *. -checkTypeKind :: - (MonadError MultipleErrors m) => - Type -> - Kind -> - m () +checkTypeKind + :: MonadError MultipleErrors m + => Type + -> Kind + -> m () checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType -- | Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns @@ -248,11 +268,11 @@ checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind = -- -- This is necessary during type checking to avoid unifying a polymorphic type with a -- unification variable. -instantiatePolyTypeWithUnknowns :: - (MonadState CheckState m, MonadError MultipleErrors m) => - Expr -> - Type -> - m (Expr, Type) +instantiatePolyTypeWithUnknowns + :: (MonadState CheckState m, MonadError MultipleErrors m) + => Expr + -> Type + -> m (Expr, Type) instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do ty' <- replaceVarWithUnknown ident ty instantiatePolyTypeWithUnknowns val ty' @@ -263,17 +283,17 @@ instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do instantiatePolyTypeWithUnknowns val ty = return (val, ty) -- | Infer a type for a value, rethrowing any error to provide a more useful error message -infer :: - (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - Expr -> - m Expr +infer + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Expr + -> m Expr infer val = withErrorMessageHint (ErrorInferringType val) $ infer' val -- | Infer a type for a value -infer' :: - (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - Expr -> - m Expr +infer' + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Expr + -> m Expr infer' v@(Literal (NumericLiteral (Left _))) = return $ TypedValue True v tyInt infer' v@(Literal (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber infer' v@(Literal (StringLiteral _)) = return $ TypedValue True v tyString @@ -370,13 +390,13 @@ infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do return $ TypedValue t (PositionedValue pos c v) ty infer' v = internalError $ "Invalid argument to infer: " ++ show v -inferLetBinding :: - (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - [Declaration] -> - [Declaration] -> - Expr -> - (Expr -> m Expr) -> - m ([Declaration], Expr) +inferLetBinding + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => [Declaration] + -> [Declaration] + -> Expr + -> (Expr -> m Expr) + -> m ([Declaration], Expr) inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do Just moduleName <- checkCurrentModule <$> get @@ -394,9 +414,9 @@ inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do Just moduleName <- checkCurrentModule <$> get - (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup Nothing (map (\(i, _, v) -> (i, v)) ds) + SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing (map (\(i, _, v) -> (i, v)) ds) ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict - ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict + ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] bindNames dict $ do makeBindingGroupVisible @@ -407,11 +427,12 @@ inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethr inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding" -- | Infer the types of variables brought into scope by a binder -inferBinder :: forall m. - (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - Type -> - Binder -> - m (M.Map Ident Type) +inferBinder + :: forall m + . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Type + -> Binder + -> m (M.Map Ident Type) inferBinder _ NullBinder = return M.empty inferBinder val (LiteralBinder (StringLiteral _)) = unifyTypes val tyString >> return M.empty inferBinder val (LiteralBinder (CharLiteral _)) = unifyTypes val tyChar >> return M.empty @@ -486,11 +507,11 @@ binderRequiresMonotype (PositionedBinder _ _ b) = binderRequiresMonotype b binderRequiresMonotype _ = True -- | Instantiate polytypes only when necessitated by a binder. -instantiateForBinders :: - (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - [Expr] -> - [CaseAlternative] -> - m ([Expr], [Type]) +instantiateForBinders + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => [Expr] + -> [CaseAlternative] + -> m ([Expr], [Type]) instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do TypedValue _ val' ty <- infer val if inst @@ -503,12 +524,12 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do -- | -- Check the types of the return values in a set of binders in a case statement -- -checkBinders :: - (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - [Type] -> - Type -> - [CaseAlternative] -> - m [CaseAlternative] +checkBinders + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => [Type] + -> Type + -> [CaseAlternative] + -> m [CaseAlternative] checkBinders _ _ [] = return [] checkBinders nvals ret (CaseAlternative binders result : bs) = do guardWith (errorMessage $ OverlappingArgNames Nothing) $ @@ -532,11 +553,11 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do -- | -- Check the type of a value, rethrowing errors to provide a better error message -- -check :: - (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - Expr -> - Type -> - m Expr +check + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Expr + -> Type + -> m Expr check val ty = withErrorMessageHint (ErrorCheckingType val ty) $ check' val ty -- | @@ -679,13 +700,13 @@ check' val ty = do -- -- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case. -- -checkProperties :: - (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => - Expr -> - [(PSString, Expr)] -> - Type -> - Bool -> - m [(PSString, Expr)] +checkProperties + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Expr + -> [(PSString, Expr)] + -> Type + -> Bool + -> m [(PSString, Expr)] checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where go [] [] REmpty = return [] go [] [] u@(TUnknown _) From df1ce783dfc6af4da74b15d3cdb42620ad4ff80b Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 5 Jan 2017 15:12:47 +0000 Subject: [PATCH 0606/1580] Update pretty printer for Kinds * Use a 'k' prefix for unknown kinds * Don't use the fully qualified name for Prim kinds * A couple more conversions to Text --- src/Language/PureScript/Pretty/Kinds.hs | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs index 0ec29ba446..24d4451e78 100644 --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -10,6 +10,7 @@ import Prelude.Compat import Control.Arrow (ArrowPlus(..)) import Control.PatternArrows as PA +import Data.Monoid ((<>)) import Data.Maybe (fromMaybe) import qualified Data.Text as T import Data.Text (Text) @@ -19,11 +20,15 @@ import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Pretty.Common -typeLiterals :: Pattern () Kind String +typeLiterals :: Pattern () Kind Text typeLiterals = mkPattern match where - match (KUnknown u) = Just $ 'u' : show u - match (NamedKind name) = Just $ T.unpack (showQualified runProperName name) + match (KUnknown u) = + Just $ T.cons 'k' (T.pack (show u)) + match (NamedKind name) = + Just $ if isQualifiedWith (moduleNameFromString "Prim") name + then runProperName (disqualify name) + else showQualified runProperName name match _ = Nothing matchRow :: Pattern () Kind ((), Kind) @@ -41,15 +46,13 @@ funKind = mkPattern match -- | Generate a pretty-printed string representing a Kind prettyPrintKind :: Kind -> Text prettyPrintKind - -- TODO(Christoph): get rid of T.pack - = T.pack - . fromMaybe (internalError "Incomplete pattern") + = fromMaybe (internalError "Incomplete pattern") . PA.pattern matchKind () where - matchKind :: Pattern () Kind String - matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind) + matchKind :: Pattern () Kind Text + matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parensT matchKind) - operators :: OperatorTable () Kind String + operators :: OperatorTable () Kind Text operators = - OperatorTable [ [ Wrap matchRow $ \_ k -> "# " ++ k] - , [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ] + OperatorTable [ [ Wrap matchRow $ \_ k -> "# " <> k] + , [ AssocR funKind $ \arg ret -> arg <> " -> " <> ret ] ] From a33df8ce64c1a9d8418b86aed2afc99052439e5d Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Thu, 5 Jan 2017 21:21:12 +0000 Subject: [PATCH 0607/1580] Detect conflicting data constructor names --- examples/failing/DeclConflictDuplicateCtor.purs | 5 +++++ src/Language/PureScript/Sugar/Names/Env.hs | 7 ++++++- 2 files changed, 11 insertions(+), 1 deletion(-) create mode 100644 examples/failing/DeclConflictDuplicateCtor.purs diff --git a/examples/failing/DeclConflictDuplicateCtor.purs b/examples/failing/DeclConflictDuplicateCtor.purs new file mode 100644 index 0000000000..cc2a28e91a --- /dev/null +++ b/examples/failing/DeclConflictDuplicateCtor.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith DeclConflict +module Main where + +data T = Fail | Fail + diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 7b527e4dee..0ebbcac774 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -242,7 +242,12 @@ exportType -> m Exports exportType exportMode exps name dctors mn = do let exTypes = exportedTypes exps - let exClasses = exportedTypeClasses exps + exClasses = exportedTypeClasses exps + dctorNameCounts :: [(ProperName 'ConstructorName, Int)] + dctorNameCounts = M.toList $ M.fromListWith (+) (map (,1) dctors) + forM_ dctorNameCounts $ \(dctorName, count) -> + when (count > 1) $ + throwDeclConflict (DctorName dctorName) (DctorName dctorName) case exportMode of Internal -> do when (name `M.member` exTypes) $ From 2e2b33798788398c37c91e4cc9cda0b956c8cf13 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 5 Jan 2017 19:29:22 -0800 Subject: [PATCH 0608/1580] v0.10.5 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 8775ed8263..1ba5bb299c 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.10.4 +version: 0.10.5 cabal-version: >=1.8 build-type: Simple license: BSD3 From 9d065d8f4db319af33d3b6feb2b3b91539921e3c Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 6 Jan 2017 22:18:36 +0000 Subject: [PATCH 0609/1580] Add git tag time to psc-publish JSON This is done in a backwards-compatible way by making the time in the Package time a Maybe UTCTime. Later we can change this to just a UTCTime. Prerequisite for addressing https://github.com/purescript/pursuit/issues/216 --- src/Language/PureScript/Docs/Types.hs | 49 +++++++++++++++++-- src/Language/PureScript/Publish.hs | 15 +++++- .../PureScript/Publish/ErrorsWarnings.hs | 4 ++ tests/TestDocs.hs | 11 +++-- tests/TestPscPublish.hs | 3 ++ 5 files changed, 71 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 36166352a5..3fd269b01b 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -10,17 +10,19 @@ import Control.Arrow (first, (***)) import Control.Monad (when) import Control.Monad.Error.Class (catchError) -import Data.Monoid ((<>)) import Data.Aeson ((.=)) import Data.Aeson.BetterErrors import Data.ByteString.Lazy (ByteString) import Data.Either (isLeft, isRight) -import Data.Maybe (mapMaybe, fromMaybe) +import Data.Maybe (mapMaybe, fromMaybe, maybeToList) +import Data.Monoid ((<>)) import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import qualified Data.Time.Format as TimeFormat import Data.Version -import qualified Data.Vector as V import qualified Data.Aeson as A import qualified Data.Text as T +import qualified Data.Vector as V import qualified Language.PureScript as P @@ -40,6 +42,10 @@ data Package a = Package { pkgMeta :: PackageMeta , pkgVersion :: Version , pkgVersionTag :: Text + -- TODO: When this field was introduced, it was given the Maybe type for the + -- sake of backwards compatibility, as older JSON blobs will not include the + -- field. It should eventually be changed to just UTCTime. + , pkgTagTime :: Maybe UTCTime , pkgModules :: [Module] , pkgBookmarks :: [Bookmark] , pkgResolvedDependencies :: [(PackageName, Version)] @@ -62,6 +68,7 @@ verifyPackage verifiedUser Package{..} = Package pkgMeta pkgVersion pkgVersionTag + pkgTagTime pkgModules pkgBookmarks pkgResolvedDependencies @@ -72,6 +79,29 @@ verifyPackage verifiedUser Package{..} = packageName :: Package a -> PackageName packageName = bowerName . pkgMeta +-- | +-- The time format used for serializing package tag times in the JSON format. +-- This is the ISO 8601 date format which includes a time and a timezone. +-- +jsonTimeFormat :: String +jsonTimeFormat = "%Y-%m-%dT%H:%M:%S%z" + +-- | +-- Convenience function for formatting a time in the format expected by this +-- module. +-- +formatTime :: UTCTime -> String +formatTime = + TimeFormat.formatTime TimeFormat.defaultTimeLocale jsonTimeFormat + +-- | +-- Convenience function for parsing a time in the format expected by this +-- module. +-- +parseTime :: String -> Maybe UTCTime +parseTime = + TimeFormat.parseTimeM False TimeFormat.defaultTimeLocale jsonTimeFormat + data Module = Module { modName :: P.ModuleName , modComments :: Maybe Text @@ -275,6 +305,7 @@ data PackageError | InvalidFixity | InvalidKind Text | InvalidDataDeclType Text + | InvalidTime deriving (Show, Eq, Ord) type Bookmark = InPackage (P.ModuleName, Text) @@ -320,6 +351,7 @@ asPackage minimumVersion uploader = do Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta <*> key "version" asVersion <*> key "versionTag" asText + <*> keyMay "tagTime" (withString parseTimeEither) <*> key "modules" (eachInArray asModule) <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta <*> key "resolvedDependencies" asResolvedDependencies @@ -327,6 +359,10 @@ asPackage minimumVersion uploader = do <*> key "uploader" uploader <*> pure compilerVersion +parseTimeEither :: String -> Either PackageError UTCTime +parseTimeEither = + maybe (Left InvalidTime) Right . parseTime + asUploadedPackage :: Version -> Parse PackageError UploadedPackage asUploadedPackage minVersion = asPackage minVersion asNotYetKnown @@ -359,6 +395,8 @@ displayPackageError e = case e of "Invalid kind: \"" <> str <> "\"" InvalidDataDeclType str -> "Invalid data declaration type: \"" <> str <> "\"" + InvalidTime -> + "Invalid time" instance A.FromJSON a => A.FromJSON (Package a) where parseJSON = toAesonParser displayPackageError @@ -550,7 +588,7 @@ asSourceSpan = P.SourceSpan <$> key "name" asString instance A.ToJSON a => A.ToJSON (Package a) where toJSON Package{..} = - A.object + A.object $ [ "packageMeta" .= pkgMeta , "version" .= showVersion pkgVersion , "versionTag" .= pkgVersionTag @@ -562,7 +600,8 @@ instance A.ToJSON a => A.ToJSON (Package a) where , "github" .= pkgGithub , "uploader" .= pkgUploader , "compilerVersion" .= showVersion P.version - ] + ] ++ + fmap (\t -> "tagTime" .= formatTime t) (maybeToList pkgTagTime) instance A.ToJSON NotYetKnown where toJSON _ = A.Null diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 8a862df185..8f8bec9db5 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -39,12 +39,13 @@ import Data.List (stripPrefix, (\\), nubBy) import Data.List.NonEmpty (NonEmpty(..)) import Data.List.Split (splitOn) import Data.Maybe -import Data.Version -import qualified Data.SPDX as SPDX import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL +import Data.Time.Clock (UTCTime) +import Data.Version +import qualified Data.SPDX as SPDX import Safe (headMay) @@ -67,6 +68,7 @@ data PublishOptions = PublishOptions { -- | How to obtain the version tag and version that the data being -- generated will refer to. publishGetVersion :: PrepareM (Text, Version) + , publishGetTagTime :: Text -> PrepareM UTCTime , -- | What to do when the working tree is dirty publishWorkingTreeDirty :: PrepareM () } @@ -74,6 +76,7 @@ data PublishOptions = PublishOptions defaultPublishOptions :: PublishOptions defaultPublishOptions = PublishOptions { publishGetVersion = getVersionFromGitTag + , publishGetTagTime = getTagTime , publishWorkingTreeDirty = userError DirtyWorkingTree } @@ -139,6 +142,7 @@ preparePackage' opts = do checkLicense pkgMeta (pkgVersionTag, pkgVersion) <- publishGetVersion opts + pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag pkgGithub <- getBowerRepositoryInfo pkgMeta (pkgBookmarks, pkgModules) <- getModulesAndBookmarks @@ -200,6 +204,13 @@ getVersionFromGitTag = do digits <- stripPrefix "v" str (str,) <$> D.parseVersion' digits +-- | Given a git tag, get the time it was created. +getTagTime :: Text -> PrepareM UTCTime +getTagTime tag = do + out <- readProcess' "git" ["show", T.unpack tag, "--no-patch", "--format=%aI"] "" + let time = headMay (lines out) >>= D.parseTime + maybe (internalError (CouldntParseGitTagDate tag)) pure time + getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo) getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract where diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 01935a16e8..e2507d934e 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -73,6 +73,7 @@ data RepositoryFieldError -- | An error that probably indicates a bug in this module. data InternalError = JSONError JSONSource (ParseError BowerError) + | CouldntParseGitTagDate Text deriving (Show) data JSONSource @@ -289,6 +290,9 @@ displayInternalError e = case e of [ "Error in JSON " ++ displayJSONSource src ++ ":" , T.unpack (Bower.displayError r) ] + CouldntParseGitTagDate tag -> + [ "Unable to parse the date for a git tag: " ++ T.unpack tag + ] displayJSONSource :: JSONSource -> String displayJSONSource s = case s of diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index c9953369a1..30fbcd15d8 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -9,14 +9,16 @@ import Prelude () import Prelude.Compat import Control.Arrow (first) +import Control.Monad.IO.Class (liftIO) -import Data.Version (Version(..)) -import Data.Monoid -import Data.Maybe (fromMaybe) -import Data.List ((\\)) import Data.Foldable +import Data.List ((\\)) +import Data.Maybe (fromMaybe) +import Data.Monoid import Data.Text (Text) import qualified Data.Text as T +import Data.Time.Clock (getCurrentTime) +import Data.Version (Version(..)) import System.Exit import qualified Language.PureScript as P @@ -32,6 +34,7 @@ import TestUtils publishOpts :: Publish.PublishOptions publishOpts = Publish.defaultPublishOptions { Publish.publishGetVersion = return testVersion + , Publish.publishGetTagTime = const (liftIO getCurrentTime) , Publish.publishWorkingTreeDirty = return () } where testVersion = ("v999.0.0", Version [999,0,0] []) diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 14bd03742a..88c39f7c9c 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -4,8 +4,10 @@ module TestPscPublish where +import Control.Monad.IO.Class (liftIO) import System.Exit (exitFailure) import Data.ByteString.Lazy (ByteString) +import Data.Time.Clock (getCurrentTime) import qualified Data.Aeson as A import Data.Version @@ -38,6 +40,7 @@ roundTrip pkg = testRunOptions :: PublishOptions testRunOptions = defaultPublishOptions { publishGetVersion = return testVersion + , publishGetTagTime = const (liftIO getCurrentTime) , publishWorkingTreeDirty = return () } where testVersion = ("v999.0.0", Version [999,0,0] []) From ffaa9d9060dfc08268c45f3394a0e6a1060aaa02 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 2 Jan 2017 18:01:36 +0100 Subject: [PATCH 0610/1580] [psc-ide] use unicode forall and arrows in completions * removes the conversion module. now that the compiler types have been switched to Text the conversion module is no longer needed * adds parameterized versions of prettyPrintType * fixes unicode issues in the test suite on windows --- psc-ide-client/Main.hs | 2 + purescript.cabal | 1 - src/Language/PureScript/Ide/Conversions.hs | 29 ------- src/Language/PureScript/Ide/Util.hs | 21 ++++- src/Language/PureScript/Pretty/Types.hs | 86 +++++++++++++------- tests/Language/PureScript/Ide/Integration.hs | 21 +++-- tests/Language/PureScript/Ide/MatcherSpec.hs | 2 +- 7 files changed, 93 insertions(+), 69 deletions(-) delete mode 100644 src/Language/PureScript/Ide/Conversions.hs diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs index 932a4b2eec..8d47074509 100644 --- a/psc-ide-client/Main.hs +++ b/psc-ide-client/Main.hs @@ -35,6 +35,8 @@ main = do client :: PortID -> IO () client port = do + hSetEncoding stdin utf8 + hSetEncoding stdout utf8 h <- connectTo "127.0.0.1" port `catch` (\(SomeException e) -> diff --git a/purescript.cabal b/purescript.cabal index 1ba5bb299c..7345de02b8 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -280,7 +280,6 @@ library Language.PureScript.Ide.CaseSplit Language.PureScript.Ide.Command Language.PureScript.Ide.Completion - Language.PureScript.Ide.Conversions Language.PureScript.Ide.Externs Language.PureScript.Ide.Error Language.PureScript.Ide.Filter diff --git a/src/Language/PureScript/Ide/Conversions.hs b/src/Language/PureScript/Ide/Conversions.hs deleted file mode 100644 index 1420c9d921..0000000000 --- a/src/Language/PureScript/Ide/Conversions.hs +++ /dev/null @@ -1,29 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Ide.Conversions --- Description : Conversions to Text for PureScript types --- Copyright : Christoph Hegemann 2016 --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Christoph Hegemann --- Stability : experimental --- --- | --- Conversions to Text for PureScript types ------------------------------------------------------------------------------ - -module Language.PureScript.Ide.Conversions where - -import Control.Lens.Iso -import Data.Text (lines, strip, unwords, pack) -import qualified Language.PureScript as P -import Protolude - -properNameT :: Iso' (P.ProperName a) Text -properNameT = iso P.runProperName P.ProperName - -identT :: Iso' P.Ident Text -identT = iso P.runIdent P.Ident - -prettyTypeT :: P.Type -> Text -prettyTypeT = unwords . map strip . lines . pack . P.prettyPrintType diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 3345b9beea..4edc026c5d 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -24,19 +24,20 @@ module Language.PureScript.Ide.Util , withEmptyAnn , valueOperatorAliasT , typeOperatorAliasT - , module Language.PureScript.Ide.Conversions + , prettyTypeT + , properNameT + , identT , module Language.PureScript.Ide.Logging ) where import Protolude hiding (decodeUtf8, encodeUtf8) -import Control.Lens ((^.)) +import Control.Lens ((^.), Iso', iso) import Data.Aeson import qualified Data.Text as T import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) import qualified Language.PureScript as P -import Language.PureScript.Ide.Conversions import Language.PureScript.Ide.Logging import Language.PureScript.Ide.Types @@ -114,3 +115,17 @@ unwrapPositioned x = x unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x unwrapPositionedRef x = x + +properNameT :: Iso' (P.ProperName a) Text +properNameT = iso P.runProperName P.ProperName + +identT :: Iso' P.Ident Text +identT = iso P.runIdent P.Ident + +prettyTypeT :: P.Type -> Text +prettyTypeT = + T.unwords + . map T.strip + . T.lines + . T.pack + . P.prettyPrintTypeWithUnicode diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index db92df6cf1..a2581996ef 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -5,10 +5,10 @@ module Language.PureScript.Pretty.Types ( typeAsBox , suggestedTypeAsBox , prettyPrintType + , prettyPrintTypeWithUnicode , prettyPrintSuggestedType , typeAtomAsBox , prettyPrintTypeAtom - , prettyPrintRowWith , prettyPrintRow , prettyPrintLabel , prettyPrintObjectKey @@ -37,9 +37,12 @@ import Text.PrettyPrint.Boxes hiding ((<+>)) -- TODO(Christoph): get rid of T.unpack s -constraintsAsBox :: [Constraint] -> Box -> Box -constraintsAsBox [con] ty = text "(" <> constraintAsBox con `before` (text ") => " <> ty) -constraintsAsBox xs ty = vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (text ") => " <> ty) +constraintsAsBox :: TypeRenderOptions -> [Constraint] -> Box -> Box +constraintsAsBox tro constraints ty = case constraints of + [con] -> text "(" <> constraintAsBox con `before` (") " <> text doubleRightArrow <> " " <> ty) + xs -> vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (") " <> text doubleRightArrow <> " " <> ty) + where + doubleRightArrow = if troUnicode tro then "⇒" else "=>" constraintAsBox :: Constraint -> Box constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys) @@ -47,11 +50,13 @@ constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructo -- | -- Generate a pretty-printed string representing a Row -- -prettyPrintRowWith :: Char -> Char -> Type -> Box -prettyPrintRowWith open close = uncurry listToBox . toList [] +prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> Type -> Box +prettyPrintRowWith tro open close = uncurry listToBox . toList [] where nameAndTypeToPs :: Char -> Label -> Type -> Box - nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " :: ") <> typeAsBox ty + nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " " ++ doubleColon ++ " ") <> typeAsBox ty + + doubleColon = if troUnicode tro then "∷" else "::" tailToPs :: Type -> Box tailToPs REmpty = nullBox @@ -63,13 +68,12 @@ prettyPrintRowWith open close = uncurry listToBox . toList [] listToBox ts rest = vcat left $ zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++ [ tailToPs rest, text [close] ] - toList :: [(Label, Type)] -> Type -> ([(Label, Type)], Type) toList tys (RCons name ty row) = toList ((name, ty):tys) row toList tys r = (reverse tys, r) prettyPrintRow :: Type -> String -prettyPrintRow = render . prettyPrintRowWith '(' ')' +prettyPrintRow = render . prettyPrintRowWith defaultOptions '(' ')' typeApp :: Pattern () Type (Type, Type) typeApp = mkPattern match @@ -113,16 +117,16 @@ explicitParens = mkPattern match match (ParensInType ty) = Just ((), ty) match _ = Nothing -matchTypeAtom :: Bool -> Pattern () Type Box -matchTypeAtom suggesting = - typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType suggesting) +matchTypeAtom :: TypeRenderOptions -> Pattern () Type Box +matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} = + typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType tro) where typeLiterals :: Pattern () Type Box typeLiterals = mkPattern match where match TypeWildcard{} = Just $ text "_" match (TypeVar var) = Just $ text $ T.unpack var match (TypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s - match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row + match (PrettyPrintObject row) = Just $ prettyPrintRowWith tro '{' '}' row match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor match (TUnknown u) | suggesting = Just $ text "_" @@ -131,24 +135,28 @@ matchTypeAtom suggesting = | suggesting = Just $ text $ T.unpack name | otherwise = Just $ text $ T.unpack name ++ show s match REmpty = Just $ text "()" - match row@RCons{} = Just $ prettyPrintRowWith '(' ')' row + match row@RCons{} = Just $ prettyPrintRowWith tro '(' ')' row match (BinaryNoParensType op l r) = Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r match (TypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op match _ = Nothing -matchType :: Bool -> Pattern () Type Box -matchType = buildPrettyPrinter operators . matchTypeAtom where +matchType :: TypeRenderOptions -> Pattern () Type Box +matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where operators :: OperatorTable () Type Box operators = OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ] - , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text "-> " <> ret) ] - , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ] - , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text ("forall " ++ unwords idents ++ ".")) ty ] - , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (":: " ++ T.unpack (prettyPrintKind k))) ] + , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text rightArrow <> " " <> ret) ] + , [ Wrap constrained $ \deps ty -> constraintsAsBox tro deps ty ] + , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text (forall' ++ " " ++ unwords idents ++ ".")) ty ] + , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (doubleColon ++ " " ++ T.unpack (prettyPrintKind k))) ] , [ Wrap explicitParens $ \_ ty -> ty ] ] + rightArrow = if troUnicode tro then "→" else "->" + forall' = if troUnicode tro then "∀" else "forall" + doubleColon = if troUnicode tro then "∷" else "::" + -- If both boxes span a single line, keep them on the same line, or else -- use the specified function to modify the second box, then combine vertically. keepSingleLinesOr :: (Box -> Box) -> Box -> Box -> Box @@ -165,7 +173,7 @@ forall_ = mkPattern match typeAtomAsBox :: Type -> Box typeAtomAsBox = fromMaybe (internalError "Incomplete pattern") - . PA.pattern (matchTypeAtom False) () + . PA.pattern (matchTypeAtom defaultOptions) () . insertPlaceholders -- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses @@ -173,24 +181,46 @@ prettyPrintTypeAtom :: Type -> String prettyPrintTypeAtom = render . typeAtomAsBox typeAsBox :: Type -> Box -typeAsBox = typeAsBoxImpl False +typeAsBox = typeAsBoxImpl defaultOptions suggestedTypeAsBox :: Type -> Box -suggestedTypeAsBox = typeAsBoxImpl True +suggestedTypeAsBox = typeAsBoxImpl suggestingOptions + +data TypeRenderOptions = TypeRenderOptions + { troSuggesting :: Bool + , troUnicode :: Bool + } -typeAsBoxImpl :: Bool -> Type -> Box -typeAsBoxImpl suggesting +suggestingOptions :: TypeRenderOptions +suggestingOptions = TypeRenderOptions True False + +defaultOptions :: TypeRenderOptions +defaultOptions = TypeRenderOptions False False + +unicodeOptions :: TypeRenderOptions +unicodeOptions = TypeRenderOptions False True + +typeAsBoxImpl :: TypeRenderOptions -> Type -> Box +typeAsBoxImpl tro = fromMaybe (internalError "Incomplete pattern") - . PA.pattern (matchType suggesting) () + . PA.pattern (matchType tro) () . insertPlaceholders -- | Generate a pretty-printed string representing a 'Type' prettyPrintType :: Type -> String -prettyPrintType = render . typeAsBoxImpl False +prettyPrintType = prettyPrintType' defaultOptions + +-- | Generate a pretty-printed string representing a 'Type' using unicode +-- symbols where applicable +prettyPrintTypeWithUnicode :: Type -> String +prettyPrintTypeWithUnicode = prettyPrintType' unicodeOptions -- | Generate a pretty-printed string representing a suggested 'Type' prettyPrintSuggestedType :: Type -> String -prettyPrintSuggestedType = render . typeAsBoxImpl True +prettyPrintSuggestedType = prettyPrintType' suggestingOptions + +prettyPrintType' :: TypeRenderOptions -> Type -> String +prettyPrintType' tro = render . typeAsBoxImpl tro prettyPrintLabel :: Label -> Text prettyPrintLabel (Label s) = diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs index 92569d0fc4..387829ebad 100644 --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -50,12 +50,14 @@ import Data.Maybe (fromJust) import Data.Aeson import Data.Aeson.Types -import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Data.Vector as V -import Language.PureScript.Ide.Util import qualified Language.PureScript as P import System.Directory import System.FilePath +import System.IO import System.IO.Error (mkIOError, userErrorType) import System.Process @@ -124,11 +126,16 @@ fileGlob = "\"src/**/*.purs\"" -- Integration Testing API sendCommand :: Value -> IO Text -sendCommand v = toS <$> readCreateProcess - ((shell "psc-ide-client") { std_out=CreatePipe - , std_err=CreatePipe - }) - (T.unpack (encodeT v)) +sendCommand v = do + (Just hin, Just hout, _, _) <- + createProcess ((proc "psc-ide-client" []) {std_in=CreatePipe, std_out=CreatePipe}) + + hSetEncoding hin utf8 + hSetEncoding hout utf8 + + BS8.hPutStrLn hin (BSL8.toStrict (encode v)) + hFlush hin + T.decodeUtf8 <$> BS8.hGetLine hout quitServer :: IO () quitServer = do diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs index f7a7f45691..73c4583be9 100644 --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -46,4 +46,4 @@ spec = do it "matches on equality" $ do -- ignore any position information (m, i, t, _) : _ <- getFlexCompletions "const" - (m, i, t) `shouldBe` ("MatcherSpec", "const", "forall a b. a -> b -> a") + (m, i, t) `shouldBe` ("MatcherSpec", "const", "∀ a b. a → b → a") From 40c0954e18ba17f12d1a8ec1c5f51fd8fb176a84 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 8 Jan 2017 04:25:33 +0000 Subject: [PATCH 0611/1580] Fix object key quoting --- src/Language/PureScript/Pretty/Common.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 9b7b6a1bb4..32b5ea2608 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -148,7 +148,7 @@ prettyPrintMany f xs = do objectKeyRequiresQuoting :: Text -> Bool objectKeyRequiresQuoting s = - s `elem` reservedPsNames || isUnquotedKey s + s `elem` reservedPsNames || not (isUnquotedKey s) -- | Place a box before another, vertically when the first box takes up multiple lines. before :: Box -> Box -> Box From 6e1417706c47992a506e35450f3278f7b66139c7 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 8 Jan 2017 18:02:05 +0000 Subject: [PATCH 0612/1580] Minor memory usage improvements in Language.PureScript.Docs --- src/Language/PureScript/Docs/Convert/ReExports.hs | 7 ++----- src/Language/PureScript/Docs/Convert/Single.hs | 14 ++++---------- src/Language/PureScript/Docs/ParseAndBookmark.hs | 10 +++------- 3 files changed, 9 insertions(+), 22 deletions(-) diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 044cf98a7b..5946020b8e 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -457,11 +457,8 @@ handleEnv TypeClassEnv{..} = addConstraint constraint = P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint] -splitMap :: (Ord k) => Map k (v1, v2) -> (Map k v1, Map k v2) -splitMap = foldl go (Map.empty, Map.empty) . Map.toList - where - go (m1, m2) (k, (v1, v2)) = - (Map.insert k v1 m1, Map.insert k v2 m2) +splitMap :: Map k (v1, v2) -> (Map k v1, Map k v2) +splitMap = fmap fst &&& fmap snd -- | -- Given a list of exported constructor names, remove any data constructor diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 36dbc36218..9fc84d6b0a 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -3,16 +3,10 @@ module Language.PureScript.Docs.Convert.Single , collectBookmarks ) where -import Prelude.Compat +import Protolude import Control.Category ((>>>)) -import Control.Monad -import Data.Either -import Data.List (nub) -import Data.Maybe (mapMaybe, fromMaybe) -import Data.Monoid ((<>)) -import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Docs.Types @@ -67,7 +61,7 @@ data DeclarationAugment -- the type synonym IntermediateDeclaration for more information. augmentDeclarations :: [IntermediateDeclaration] -> [Declaration] augmentDeclarations (partitionEithers -> (augments, toplevels)) = - foldl go toplevels augments + foldl' go toplevels augments where go ds (parentTitles, a) = map (\d -> @@ -142,14 +136,14 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit Just (Left (classNameString : typeNameStrings, AugmentChild childDecl)) where classNameString = unQual className - typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys) + typeNameStrings = ordNub (concatMap (P.everythingOnTypes (++) extractProperNames) tys) unQual x = let (P.Qualified _ y) = x in P.runProperName y extractProperNames (P.TypeConstructor n) = [unQual n] extractProperNames _ = [] childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) - classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys + classApp = foldl' P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title = Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias))) convertDeclaration (P.TypeFixityDeclaration fixity (P.Qualified mn alias) _) title = diff --git a/src/Language/PureScript/Docs/ParseAndBookmark.hs b/src/Language/PureScript/Docs/ParseAndBookmark.hs index c45da0185b..ce36def670 100644 --- a/src/Language/PureScript/Docs/ParseAndBookmark.hs +++ b/src/Language/PureScript/Docs/ParseAndBookmark.hs @@ -2,14 +2,10 @@ module Language.PureScript.Docs.ParseAndBookmark ( parseAndBookmark ) where -import Prelude.Compat - -import Control.Arrow (first) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.IO.Class (MonadIO(..)) +import Protolude +import Prelude (id) import qualified Data.Map as M -import Data.Text (Text) import Language.PureScript.Docs.Convert (collectBookmarks) import Language.PureScript.Docs.Types @@ -83,7 +79,7 @@ parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, Text) parseAs g = fmap (first g) . liftIO . parseFile getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName -getDepsModuleNames = foldl go M.empty +getDepsModuleNames = foldl' go M.empty where go deps p = deps # case p of Local _ -> id From 754082115291a23e066b0a1d64c65f7cdaef129f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 8 Jan 2017 10:30:50 -0800 Subject: [PATCH 0613/1580] Fail early when 'bind' is brought into scope inside 'do' (#2547) * Fix #1253, fail early when 'bind' is brought into scope inside 'do' * Add test for 'let' --- examples/failing/BindInDo-2.purs | 9 +++++++++ examples/failing/BindInDo.purs | 9 +++++++++ src/Language/PureScript/AST/Declarations.hs | 1 + src/Language/PureScript/Errors.hs | 5 +++++ src/Language/PureScript/Sugar/DoNotation.hs | 9 ++++++++- 5 files changed, 32 insertions(+), 1 deletion(-) create mode 100644 examples/failing/BindInDo-2.purs create mode 100644 examples/failing/BindInDo.purs diff --git a/examples/failing/BindInDo-2.purs b/examples/failing/BindInDo-2.purs new file mode 100644 index 0000000000..a8c0d15de7 --- /dev/null +++ b/examples/failing/BindInDo-2.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith CannotUseBindWithDo +module Main where + +import Prelude + +foo = do + let bind = 42 + x <- [4, 5, 6] + pure x diff --git a/examples/failing/BindInDo.purs b/examples/failing/BindInDo.purs new file mode 100644 index 0000000000..d4f328670d --- /dev/null +++ b/examples/failing/BindInDo.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith CannotUseBindWithDo +module Main where + +import Prelude + +foo = do + bind <- [1,2,3] + x <- [4, 5, 6] + pure x diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 8be41932ff..248c26d911 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -138,6 +138,7 @@ data SimpleErrorMessage | CannotGeneralizeRecursiveFunction Ident Type | CannotDeriveNewtypeForData (ProperName 'TypeName) | ExpectedWildcard (ProperName 'TypeName) + | CannotUseBindWithDo deriving (Show) -- | Error message hints, providing more detailed information about failure. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 50b85219cc..8ef2fb9698 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -172,6 +172,7 @@ errorCode em = case unwrapErrorMessage em of CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction" CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData" ExpectedWildcard{} -> "ExpectedWildcard" + CannotUseBindWithDo{} -> "CannotUseBindWithDo" -- | -- A stack trace for an error @@ -880,6 +881,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS paras [ line $ "Expected a type wildcard (_) when deriving an instance for " <> markCode (runProperName tyName) <> "." ] + renderSimpleErrorMessage CannotUseBindWithDo = + paras [ line $ "The name " <> markCode "bind" <> " cannot be brought into scope in a do notation block, since do notation uses the same name." + ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 452481e276..b80b8e8e60 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -9,7 +9,6 @@ import Prelude.Compat import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class - import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Errors @@ -49,6 +48,8 @@ desugarDo d = return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest') go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest) + go (DoNotationBind b _ : _) | Ident C.bind `elem` binderNames b = + throwError . errorMessage $ CannotUseBindWithDo go (DoNotationBind (VarBinder ident) val : rest) = do rest' <- go rest return $ App (App bind val) (Abs (Left ident) rest') @@ -58,6 +59,12 @@ desugarDo d = return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')])) go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet go (DoNotationLet ds : rest) = do + let checkBind :: Declaration -> m () + checkBind (ValueDeclaration (Ident name) _ _ _) + | name == C.bind = throwError . errorMessage $ CannotUseBindWithDo + checkBind (PositionedDeclaration pos _ decl) = rethrowWithPosition pos (checkBind decl) + checkBind _ = pure () + mapM_ checkBind ds rest' <- go rest return $ Let ds rest' go (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go (el : rest) From 5263800052fbfc7c9136a4686757a17112198b01 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 8 Jan 2017 20:17:35 +0000 Subject: [PATCH 0614/1580] Remove Docs.Bookmarks We don't actually need the full Bookmarks to be able to generate links between packages properly, and in fact all that Pursuit uses the pkgBookmarks field for now is to work out which package it needs to link to, given a module name. That is, all it needs is a Map ModuleName PackageName. So we can simplify and speed up the JSON generation by replacing the pkgBookmarks with such a Map. This gets us one step closer to being able to get rid of Language.PureScript.AST.Exported, refs #2130. --- psc-docs/Main.hs | 4 +- purescript.cabal | 2 +- src/Language/PureScript/Docs.hs | 2 +- src/Language/PureScript/Docs/Convert.hs | 68 ++++++++------ .../PureScript/Docs/Convert/Single.hs | 13 --- .../PureScript/Docs/ParseAndBookmark.hs | 93 ------------------- .../PureScript/Docs/ParseInPackage.hs | 73 +++++++++++++++ src/Language/PureScript/Docs/Types.hs | 76 +++++++++------ src/Language/PureScript/Publish.hs | 41 +++----- 9 files changed, 178 insertions(+), 194 deletions(-) delete mode 100644 src/Language/PureScript/Docs/ParseAndBookmark.hs create mode 100644 src/Language/PureScript/Docs/ParseInPackage.hs diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index a1ca8ec3cd..e6ffe6dd7c 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -60,8 +60,8 @@ docgen (PSCDocsOptions fmt inputGlob output) = do Etags -> dumpTags input dumpEtags Ctags -> dumpTags input dumpCtags Markdown -> do - ms <- runExceptT (D.parseAndBookmark input [] - >>= (fst >>> D.convertModulesInPackage)) + ms <- runExceptT (D.parseFilesInPackages input [] + >>= uncurry D.convertModulesInPackage) >>= successOrExit case output of diff --git a/purescript.cabal b/purescript.cabal index 7345de02b8..b0d2f5389c 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -268,7 +268,7 @@ library Language.PureScript.Docs.RenderedCode.Types Language.PureScript.Docs.RenderedCode.Render Language.PureScript.Docs.AsMarkdown - Language.PureScript.Docs.ParseAndBookmark + Language.PureScript.Docs.ParseInPackage Language.PureScript.Docs.Utils.MonoidExtras Language.PureScript.Publish diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs index 9f368740c4..c8ccf8aaf0 100644 --- a/src/Language/PureScript/Docs.hs +++ b/src/Language/PureScript/Docs.hs @@ -8,7 +8,7 @@ module Language.PureScript.Docs ( import Language.PureScript.Docs.Convert as Docs import Language.PureScript.Docs.Prim as Docs -import Language.PureScript.Docs.ParseAndBookmark as Docs +import Language.PureScript.Docs.ParseInPackage as Docs import Language.PureScript.Docs.Render as Docs import Language.PureScript.Docs.RenderedCode.Render as Docs import Language.PureScript.Docs.RenderedCode.Types as Docs diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 541d80b282..3fc345f51d 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -3,28 +3,27 @@ module Language.PureScript.Docs.Convert ( convertModules + , convertModulesWithEnv , convertModulesInPackage - , collectBookmarks + , convertModulesInPackageWithEnv ) where -import Prelude.Compat +import Prelude (id, String) +import Protolude hiding (check) -import Control.Arrow ((&&&), second) +import Control.Arrow ((&&&)) import Control.Category ((>>>)) -import Control.Monad -import Control.Monad.Error.Class (MonadError) -import Control.Monad.State (runStateT) import Control.Monad.Writer.Strict (runWriterT) -import Data.List (find) import qualified Data.Map as Map -import Data.Text (Text) import Language.PureScript.Docs.Convert.ReExports (updateReExports) -import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks) +import Language.PureScript.Docs.Convert.Single (convertSingleModule) import Language.PureScript.Docs.Types import qualified Language.PureScript as P import qualified Language.PureScript.Constants as C +import Web.Bower.PackageMeta (PackageName) + import Text.Parsec (eof) -- | @@ -34,32 +33,36 @@ import Text.Parsec (eof) -- convertModulesInPackage :: (MonadError P.MultipleErrors m) => - [InPackage P.Module] -> + [P.Module] -> + Map P.ModuleName PackageName -> m [Module] -convertModulesInPackage modules = +convertModulesInPackage modules modulesDeps = + fmap fst (convertModulesInPackageWithEnv modules modulesDeps) + +convertModulesInPackageWithEnv :: + (MonadError P.MultipleErrors m) => + [P.Module] -> + Map P.ModuleName PackageName -> + m ([Module], P.Env) +convertModulesInPackageWithEnv modules modulesDeps = go modules where - localNames = - map P.getModuleName (takeLocals modules) go = - map ignorePackage - >>> convertModules withPackage - >>> fmap (filter ((`elem` localNames) . modName)) + convertModulesWithEnv withPackage + >>> fmap (first (filter (isLocal . modName))) withPackage :: P.ModuleName -> InPackage P.ModuleName withPackage mn = - case find ((== mn) . P.getModuleName . ignorePackage) modules of - Just m -> - fmap P.getModuleName m - Nothing -> - P.internalError $ "withPackage: missing module:" ++ - show (P.runModuleName mn) + case Map.lookup mn modulesDeps of + Just pkgName -> FromDep pkgName mn + Nothing -> Local mn + + isLocal :: P.ModuleName -> Bool + isLocal = not . flip Map.member modulesDeps -- | -- Convert a group of modules to the intermediate format, designed for --- producing documentation from. It is also necessary to pass an Env containing --- imports/exports information about the list of modules, which is needed for --- documenting re-exports. +-- producing documentation from. -- -- Note that the whole module dependency graph must be included in the list; if -- some modules import things from other modules, then those modules must also @@ -75,6 +78,14 @@ convertModules :: [P.Module] -> m [Module] convertModules withPackage = + fmap fst . convertModulesWithEnv withPackage + +convertModulesWithEnv :: + (MonadError P.MultipleErrors m) => + (P.ModuleName -> InPackage P.ModuleName) -> + [P.Module] -> + m ([Module], P.Env) +convertModulesWithEnv withPackage = P.sortModules >>> fmap (fst >>> map importPrim) >=> convertSorted withPackage @@ -83,13 +94,14 @@ importPrim :: P.Module -> P.Module importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim]) -- | --- Convert a sorted list of modules. +-- Convert a sorted list of modules, returning both the list of converted +-- modules and the Env produced during desugaring. -- convertSorted :: (MonadError P.MultipleErrors m) => (P.ModuleName -> InPackage P.ModuleName) -> [P.Module] -> - m [Module] + m ([Module], P.Env) convertSorted withPackage modules = do (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules @@ -97,7 +109,7 @@ convertSorted withPackage modules = do let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes) let traversalOrder = map P.getModuleName modules - pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap)) + pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap), env) -- | -- If any exported value declarations have either wildcard type signatures, or diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 9fc84d6b0a..9e071269c9 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -1,6 +1,5 @@ module Language.PureScript.Docs.Convert.Single ( convertSingleModule - , collectBookmarks ) where import Protolude @@ -184,15 +183,3 @@ convertComments cs = do dropPrefix prefix str = fromMaybe str (T.stripPrefix prefix str) - --- | Go through a PureScript module and extract a list of Bookmarks; references --- to data types or values, to be used as a kind of index. These are used for --- generating links in the HTML documentation, for example. -collectBookmarks :: InPackage P.Module -> [Bookmark] -collectBookmarks (Local m) = map Local (collectBookmarks' m) -collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m) - -collectBookmarks' :: P.Module -> [(P.ModuleName, Text)] -collectBookmarks' m = - map (P.getModuleName m, ) - (mapMaybe getDeclarationTitle (P.exportedDeclarations m)) diff --git a/src/Language/PureScript/Docs/ParseAndBookmark.hs b/src/Language/PureScript/Docs/ParseAndBookmark.hs deleted file mode 100644 index ce36def670..0000000000 --- a/src/Language/PureScript/Docs/ParseAndBookmark.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Language.PureScript.Docs.ParseAndBookmark - ( parseAndBookmark - ) where - -import Protolude -import Prelude (id) - -import qualified Data.Map as M - -import Language.PureScript.Docs.Convert (collectBookmarks) -import Language.PureScript.Docs.Types -import qualified Language.PureScript as P -import System.IO.UTF8 (readUTF8FileT) -import Web.Bower.PackageMeta (PackageName) - --- | --- Given: --- --- * A list of local source files --- * A list of source files from external dependencies, together with their --- package names --- --- This function does the following: --- --- * Parse all of the input and dependency source files --- * Associate each dependency module with its package name, thereby --- distinguishing these from local modules --- * Collect a list of bookmarks from the whole set of source files --- * Return the parsed modules and the bookmarks -parseAndBookmark :: - (MonadError P.MultipleErrors m, MonadIO m) => - [FilePath] - -> [(PackageName, FilePath)] - -> m ([InPackage P.Module], [Bookmark]) -parseAndBookmark inputFiles depsFiles = do - inputFiles' <- traverse (parseAs Local) inputFiles - depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles - - addBookmarks <$> parseFiles (inputFiles' ++ depsFiles') - -parseFiles :: - (MonadError P.MultipleErrors m) => - [(FileInfo, Text)] - -> m [(FileInfo, P.Module)] -parseFiles = - throwLeft . P.parseModulesFromFiles fileInfoToString - -addBookmarks :: - [(FileInfo, P.Module)] - -> ([InPackage P.Module], [Bookmark]) -addBookmarks msInfo = - let - msDeps = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) msInfo) - msPackages = map (addPackage msDeps . snd) msInfo - bookmarks = concatMap collectBookmarks msPackages - in - (msPackages, bookmarks) - -throwLeft :: (MonadError l m) => Either l r -> m r -throwLeft = either throwError return - --- | Specifies whether a PureScript source file is considered as: --- --- 1) with the `Local` constructor, a target source file, i.e., we want to see --- its modules in the output --- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do --- not want its modules in the output; it is there to enable desugaring, and --- to ensure that links between modules are constructed correctly. -type FileInfo = InPackage FilePath - -fileInfoToString :: FileInfo -> FilePath -fileInfoToString (Local fn) = fn -fileInfoToString (FromDep _ fn) = fn - -parseFile :: FilePath -> IO (FilePath, Text) -parseFile input' = (,) input' <$> readUTF8FileT input' - -parseAs :: (MonadIO m) => (FilePath -> a) -> FilePath -> m (a, Text) -parseAs g = fmap (first g) . liftIO . parseFile - -getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName -getDepsModuleNames = foldl' go M.empty - where - go deps p = deps # case p of - Local _ -> id - FromDep pkgName (_, m) -> M.insert (P.getModuleName m) pkgName - (#) = flip ($) - -addPackage :: M.Map P.ModuleName PackageName -> P.Module -> InPackage P.Module -addPackage depsModules m = - case M.lookup (P.getModuleName m) depsModules of - Just pkgName -> FromDep pkgName m - Nothing -> Local m diff --git a/src/Language/PureScript/Docs/ParseInPackage.hs b/src/Language/PureScript/Docs/ParseInPackage.hs new file mode 100644 index 0000000000..311980b4ac --- /dev/null +++ b/src/Language/PureScript/Docs/ParseInPackage.hs @@ -0,0 +1,73 @@ +module Language.PureScript.Docs.ParseInPackage + ( parseFilesInPackages + ) where + +import Protolude + +import qualified Data.Map as M + +import Language.PureScript.Docs.Types +import qualified Language.PureScript as P +import System.IO.UTF8 (readUTF8FileT) +import Web.Bower.PackageMeta (PackageName) + +-- | +-- Given: +-- +-- * A list of local source files +-- * A list of source files from external dependencies, together with their +-- package names +-- +-- This function does the following: +-- +-- * Parse all of the input and dependency source files +-- * Associate each dependency module with its package name, thereby +-- distinguishing these from local modules +-- * Return the parsed modules and a Map mapping module names to package +-- names for modules which come from dependencies. If a module does not +-- exist in the map, it can safely be assumed to be local. +parseFilesInPackages :: + (MonadError P.MultipleErrors m, MonadIO m) => + [FilePath] + -> [(PackageName, FilePath)] + -> m ([P.Module], Map P.ModuleName PackageName) +parseFilesInPackages inputFiles depsFiles = do + inputFiles' <- traverse (readFileAs . Local) inputFiles + depsFiles' <- traverse (readFileAs . uncurry FromDep) depsFiles + + modules <- parse (inputFiles' ++ depsFiles') + + let mnMap = M.fromList (mapMaybe (\(inpkg, m) -> (P.getModuleName m,) <$> inPkgToMaybe inpkg) modules) + + pure (map snd modules, mnMap) + + where + parse :: + (MonadError P.MultipleErrors m) => + [(FileInfo, Text)] + -> m [(FileInfo, P.Module)] + parse = + throwLeft . P.parseModulesFromFiles fileInfoToString + + inPkgToMaybe = \case + Local _ -> Nothing + FromDep pkgName _ -> Just pkgName + +throwLeft :: (MonadError l m) => Either l r -> m r +throwLeft = either throwError return + +-- | Specifies whether a PureScript source file is considered as: +-- +-- 1) with the `Local` constructor, a target source file, i.e., we want to see +-- its modules in the output +-- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do +-- not want its modules in the output; it is there to enable desugaring, and +-- to ensure that links between modules are constructed correctly. +type FileInfo = InPackage FilePath + +fileInfoToString :: FileInfo -> FilePath +fileInfoToString (Local fn) = fn +fileInfoToString (FromDep _ fn) = fn + +readFileAs :: (MonadIO m) => FileInfo -> m (FileInfo, Text) +readFileAs fi = liftIO . fmap ((fi,)) $ readUTF8FileT (ignorePackage fi) diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 3fd269b01b..39ab917360 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -4,19 +4,14 @@ module Language.PureScript.Docs.Types ) where -import Prelude.Compat +import Protolude hiding (to, from) +import Prelude (String, unlines) -import Control.Arrow (first, (***)) -import Control.Monad (when) -import Control.Monad.Error.Class (catchError) +import Control.Arrow ((***)) import Data.Aeson ((.=)) import Data.Aeson.BetterErrors -import Data.ByteString.Lazy (ByteString) -import Data.Either (isLeft, isRight) -import Data.Maybe (mapMaybe, fromMaybe, maybeToList) -import Data.Monoid ((<>)) -import Data.Text (Text) +import qualified Data.Map as Map import Data.Time.Clock (UTCTime) import qualified Data.Time.Format as TimeFormat import Data.Version @@ -47,7 +42,7 @@ data Package a = Package -- field. It should eventually be changed to just UTCTime. , pkgTagTime :: Maybe UTCTime , pkgModules :: [Module] - , pkgBookmarks :: [Bookmark] + , pkgModuleMap :: Map P.ModuleName PackageName , pkgResolvedDependencies :: [(PackageName, Version)] , pkgGithub :: (GithubUser, GithubRepo) , pkgUploader :: a @@ -70,7 +65,7 @@ verifyPackage verifiedUser Package{..} = pkgVersionTag pkgTagTime pkgModules - pkgBookmarks + pkgModuleMap pkgResolvedDependencies pkgGithub verifiedUser @@ -308,8 +303,6 @@ data PackageError | InvalidTime deriving (Show, Eq, Ord) -type Bookmark = InPackage (P.ModuleName, Text) - data InPackage a = Local a | FromDep PackageName a @@ -333,10 +326,10 @@ ignorePackage (FromDep _ x) = x ---------------------- -- Parsing -parseUploadedPackage :: Version -> ByteString -> Either (ParseError PackageError) UploadedPackage +parseUploadedPackage :: Version -> LByteString -> Either (ParseError PackageError) UploadedPackage parseUploadedPackage minVersion = parse $ asUploadedPackage minVersion -parseVerifiedPackage :: Version -> ByteString -> Either (ParseError PackageError) VerifiedPackage +parseVerifiedPackage :: Version -> LByteString -> Either (ParseError PackageError) VerifiedPackage parseVerifiedPackage minVersion = parse $ asVerifiedPackage minVersion asPackage :: Version -> (forall e. Parse e a) -> Parse PackageError (Package a) @@ -353,11 +346,15 @@ asPackage minimumVersion uploader = do <*> key "versionTag" asText <*> keyMay "tagTime" (withString parseTimeEither) <*> key "modules" (eachInArray asModule) - <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta + <*> moduleMap <*> key "resolvedDependencies" asResolvedDependencies <*> key "github" asGithub <*> key "uploader" uploader <*> pure compilerVersion + where + moduleMap = + key "moduleMap" asModuleMap + `pOr` (key "bookmarks" bookmarksAsModuleMap .! ErrorInPackageMeta) parseTimeEither :: String -> Either PackageError UTCTime parseTimeEither = @@ -444,9 +441,10 @@ asReExport = asReExportModuleName :: Parse PackageError (InPackage P.ModuleName) asReExportModuleName = asInPackage fromAesonParser .! ErrorInPackageMeta - <|> fmap Local fromAesonParser + `pOr` fmap Local fromAesonParser - (<|>) p q = catchError p (const q) +pOr :: Parse e a -> Parse e a -> Parse e a +p `pOr` q = catchError p (const q) asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a) asInPackage inner = @@ -559,20 +557,38 @@ asQualifiedProperName = fromAesonParser asQualifiedIdent :: Parse e (P.Qualified P.Ident) asQualifiedIdent = fromAesonParser -asBookmarks :: Parse BowerError [Bookmark] -asBookmarks = eachInArray asBookmark +asModuleMap :: Parse PackageError (Map P.ModuleName PackageName) +asModuleMap = + Map.fromList <$> + eachInObjectWithKey (Right . P.moduleNameFromString) + (withText parsePackageName') + +-- This is here to preserve backwards compatibility with compilers which used +-- to generate a 'bookmarks' field in the JSON (i.e. up to 0.10.5). We should +-- remove this after the next breaking change to the JSON. +bookmarksAsModuleMap :: Parse BowerError (Map P.ModuleName PackageName) +bookmarksAsModuleMap = + convert <$> + eachInArray (asInPackage (nth 0 (P.moduleNameFromString <$> asText))) + + where + convert :: [InPackage P.ModuleName] -> Map P.ModuleName PackageName + convert = Map.fromList . mapMaybe toTuple -asBookmark :: Parse BowerError Bookmark -asBookmark = - asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asText) - <*> nth 1 asText) + toTuple (Local _) = Nothing + toTuple (FromDep pkgName mn) = Just (mn, pkgName) asResolvedDependencies :: Parse PackageError [(PackageName, Version)] asResolvedDependencies = - eachInObjectWithKey (mapLeft ErrorInPackageMeta . parsePackageName) asVersion - where - mapLeft f (Left x) = Left (f x) - mapLeft _ (Right x) = Right x + eachInObjectWithKey parsePackageName' asVersion + +parsePackageName' :: Text -> Either PackageError PackageName +parsePackageName' = + mapLeft ErrorInPackageMeta . parsePackageName + +mapLeft :: (a -> a') -> Either a b -> Either a' b +mapLeft f (Left x) = Left (f x) +mapLeft _ (Right x) = Right x asGithub :: Parse e (GithubUser, GithubRepo) asGithub = (,) <$> nth 0 (GithubUser <$> asText) @@ -593,7 +609,9 @@ instance A.ToJSON a => A.ToJSON (Package a) where , "version" .= showVersion pkgVersion , "versionTag" .= pkgVersionTag , "modules" .= pkgModules - , "bookmarks" .= map (fmap (first P.runModuleName)) pkgBookmarks + , "moduleMap" .= assocListToJSON P.runModuleName + runPackageName + (Map.toList pkgModuleMap) , "resolvedDependencies" .= assocListToJSON runPackageName (T.pack . showVersion) pkgResolvedDependencies diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 8f8bec9db5..9ab21cad5a 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -16,30 +16,23 @@ module Language.PureScript.Publish , checkCleanWorkingTree , getVersionFromGitTag , getBowerRepositoryInfo - , getModulesAndBookmarks + , getModules , getResolvedDependencies ) where -import Prelude () -import Prelude.Compat hiding (userError) +import Protolude hiding (stdin) -import Control.Arrow ((***), first) +import Control.Arrow ((***)) import Control.Category ((>>>)) -import Control.Exception (catch, try) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) -import Control.Monad.Writer.Strict +import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell) import Data.Aeson.BetterErrors import Data.Char (isSpace) -import Data.Foldable (traverse_) -import Data.Function (on) +import Data.String (String, lines) import Data.List (stripPrefix, (\\), nubBy) import Data.List.NonEmpty (NonEmpty(..)) import Data.List.Split (splitOn) -import Data.Maybe -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL @@ -47,10 +40,7 @@ import Data.Time.Clock (UTCTime) import Data.Version import qualified Data.SPDX as SPDX -import Safe (headMay) - import System.Directory (doesFileExist, findExecutable) -import System.Exit (exitFailure) import System.FilePath (pathSeparator) import System.Process (readProcess) import qualified System.FilePath.Glob as Glob @@ -61,7 +51,7 @@ import qualified Web.Bower.PackageMeta as Bower import Language.PureScript.Publish.ErrorsWarnings import Language.PureScript.Publish.Utils -import qualified Language.PureScript as P (version) +import qualified Language.PureScript as P (version, ModuleName) import qualified Language.PureScript.Docs as D data PublishOptions = PublishOptions @@ -129,9 +119,6 @@ otherError = throwError . OtherError catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b catchLeft a f = either f pure a -unlessM :: Monad m => m Bool -> m () -> m () -unlessM cond act = cond >>= flip unless act - preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage preparePackage' opts = do unlessM (liftIO (doesFileExist "bower.json")) (userError BowerJSONNotFound) @@ -144,7 +131,7 @@ preparePackage' opts = do (pkgVersionTag, pkgVersion) <- publishGetVersion opts pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag pkgGithub <- getBowerRepositoryInfo pkgMeta - (pkgBookmarks, pkgModules) <- getModulesAndBookmarks + (pkgModules, pkgModuleMap) <- getModules let declaredDeps = map fst (bowerDependencies pkgMeta ++ bowerDevDependencies pkgMeta) @@ -155,18 +142,18 @@ preparePackage' opts = do return D.Package{..} -getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module]) -getModulesAndBookmarks = do +getModules :: PrepareM ([D.Module], Map P.ModuleName PackageName) +getModules = do (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles - (modules', bookmarks) <- parseAndBookmark inputFiles depsFiles + (modules', moduleMap) <- parseFilesInPackages inputFiles depsFiles - case runExcept (D.convertModulesInPackage modules') of - Right modules -> return (bookmarks, modules) + case runExcept (D.convertModulesInPackage modules' moduleMap) of + Right modules -> return (modules, moduleMap) Left err -> userError (CompileError err) where - parseAndBookmark inputFiles depsFiles = do - r <- liftIO . runExceptT $ D.parseAndBookmark inputFiles depsFiles + parseFilesInPackages inputFiles depsFiles = do + r <- liftIO . runExceptT $ D.parseFilesInPackages inputFiles depsFiles case r of Right r' -> return r' From 523add4f143595ebe5fe3f3a9bbb1eb583b4edcf Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 9 Jan 2017 09:26:47 +0000 Subject: [PATCH 0615/1580] Use identity from Protolude --- src/Language/PureScript/Docs/Convert.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 3fc345f51d..a564e0ae97 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -8,13 +8,13 @@ module Language.PureScript.Docs.Convert , convertModulesInPackageWithEnv ) where -import Prelude (id, String) import Protolude hiding (check) import Control.Arrow ((&&&)) import Control.Category ((>>>)) import Control.Monad.Writer.Strict (runWriterT) import qualified Data.Map as Map +import Data.String (String) import Language.PureScript.Docs.Convert.ReExports (updateReExports) import Language.PureScript.Docs.Convert.Single (convertSingleModule) @@ -106,7 +106,7 @@ convertSorted withPackage modules = do (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules modulesWithTypes <- typeCheckIfNecessary modules convertedModules - let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes) + let moduleMap = Map.fromList (map (modName &&& identity) modulesWithTypes) let traversalOrder = map P.getModuleName modules pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap), env) @@ -178,7 +178,7 @@ insertValueTypes env m = other parseIdent = - either (err . ("failed to parse Ident: " ++)) id . runParser P.parseIdent + either (err . ("failed to parse Ident: " ++)) identity . runParser P.parseIdent lookupName name = let key = P.Qualified (Just (modName m)) name From 0b9265f60e5c987a9f00edc480e721eb0a8ff88f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 9 Jan 2017 20:38:00 -0800 Subject: [PATCH 0616/1580] Don't expand synonyms until after kind checking (#2546) * Fix #2542. Don't expand synonyms until after kind checking * Missed one * Remove redundant constraint * Make 2542.purs into a warning test * Comment --- examples/failing/2542.purs | 9 +++++++++ examples/warning/2542.purs | 16 ++++++++++++++++ src/Language/PureScript/TypeChecker/Types.hs | 13 ++++++++----- 3 files changed, 33 insertions(+), 5 deletions(-) create mode 100644 examples/failing/2542.purs create mode 100644 examples/warning/2542.purs diff --git a/examples/failing/2542.purs b/examples/failing/2542.purs new file mode 100644 index 0000000000..9c2b347ec5 --- /dev/null +++ b/examples/failing/2542.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith UndefinedTypeVariable +module Main where + +type T = forall a. Array a + +foo :: T +foo = bar where + bar :: Array a + bar = [] diff --git a/examples/warning/2542.purs b/examples/warning/2542.purs new file mode 100644 index 0000000000..8a1351841e --- /dev/null +++ b/examples/warning/2542.purs @@ -0,0 +1,16 @@ +-- @shouldWarnWith MissingTypeDeclaration +module Main where + +import Control.Monad.Eff.Console + +type T = forall a. Array a + +-- | Note: This should not raise a `ShadowedTypeVar` warning as the +-- | type `a` introduced in `T` should not be in scope +-- | in the definition of `bar`. +foo :: T +foo = bar where + bar :: forall a. Array a + bar = [] + +main = log "Done" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index b9c382d1d9..22917e07a7 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -187,7 +187,7 @@ data SplitBindingGroup = SplitBindingGroup -- This function also generates fresh unification variables for the types of -- declarations without type annotations, returned in the 'UntypedData' structure. typeDictionaryForBindingGroup - :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadWriter MultipleErrors m) => Maybe ModuleName -> [(Ident, Expr)] -> m SplitBindingGroup @@ -197,7 +197,7 @@ typeDictionaryForBindingGroup moduleName vals = do -- fully expanded types. let (untyped, typed) = partitionEithers (map splitTypeAnnotation vals) (typedDict, typed') <- fmap unzip . for typed $ \(ident, (expr, ty, checkType)) -> do - ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty + ty' <- replaceTypeWildcards ty return ((ident, ty'), (ident, (expr, ty', checkType))) -- Create fresh unification variables for the types of untyped declarations (untypedDict, untyped') <- fmap unzip . for untyped $ \(ident, expr) -> do @@ -233,11 +233,14 @@ checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do -- Kind check (kind, args) <- kindOfWithScopedVars ty checkTypeKind ty kind + -- We replace type synonyms _after_ kind-checking, since we don't want type + -- synonym expansion to bring type variables into scope. See #2542. + ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty -- Check the type with the new names in scope val' <- if checkType - then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val ty <*> pure ty - else return (TypedValue False val ty) - return (ident, (val', ty)) + then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val ty' <*> pure ty' + else return (TypedValue False val ty') + return (ident, (val', ty')) -- | Infer a type for a value in a binding group which lacks an annotation. typeForBindingGroupElement From 04d7668434fa0fe9e47f4ce9f27779a6dc3dfaab Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 7 Jan 2017 02:54:20 +0000 Subject: [PATCH 0617/1580] Store more information in RenderedCode / refactoring * Changes the RenderedCodeElement type to preserve more information for creating links in RenderedCode values. In particular, the namespace of a symbol is now stored. * Refactor Docs.RenderedCode.Types so that the functions for creating RenderedCode values are easier to use and more type-safe. * Include information about the module that kinds are contained in in the RenderedCode renderer. * Split Docs.RenderedCode.Render into two modules: Docs.RenderedCode.RenderType and Docs.RenderedCode.RenderKind. The JSON format has changed but in a backwards-compatible way, so the Pursuit database will not need to be regenerated. --- purescript.cabal | 4 +- src/Language/PureScript/Docs.hs | 3 +- src/Language/PureScript/Docs/AsMarkdown.hs | 10 +- src/Language/PureScript/Docs/Render.hs | 44 +-- src/Language/PureScript/Docs/RenderedCode.hs | 17 +- .../Docs/RenderedCode/RenderKind.hs | 57 +++ .../RenderedCode/{Render.hs => RenderType.hs} | 57 ++- .../PureScript/Docs/RenderedCode/Types.hs | 325 ++++++++++++++---- src/Language/PureScript/Docs/Types.hs | 36 +- 9 files changed, 400 insertions(+), 153 deletions(-) create mode 100644 src/Language/PureScript/Docs/RenderedCode/RenderKind.hs rename src/Language/PureScript/Docs/RenderedCode/{Render.hs => RenderType.hs} (85%) diff --git a/purescript.cabal b/purescript.cabal index b0d2f5389c..321532b1fc 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -123,6 +123,7 @@ library containers -any, clock -any, data-ordlist >= 0.4.7.0, + deepseq -any, directory >= 1.2, dlist -any, edit-distance -any, @@ -266,7 +267,8 @@ library Language.PureScript.Docs.Types Language.PureScript.Docs.RenderedCode Language.PureScript.Docs.RenderedCode.Types - Language.PureScript.Docs.RenderedCode.Render + Language.PureScript.Docs.RenderedCode.RenderType + Language.PureScript.Docs.RenderedCode.RenderKind Language.PureScript.Docs.AsMarkdown Language.PureScript.Docs.ParseInPackage Language.PureScript.Docs.Utils.MonoidExtras diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs index c8ccf8aaf0..7773952e78 100644 --- a/src/Language/PureScript/Docs.hs +++ b/src/Language/PureScript/Docs.hs @@ -10,6 +10,5 @@ import Language.PureScript.Docs.Convert as Docs import Language.PureScript.Docs.Prim as Docs import Language.PureScript.Docs.ParseInPackage as Docs import Language.PureScript.Docs.Render as Docs -import Language.PureScript.Docs.RenderedCode.Render as Docs -import Language.PureScript.Docs.RenderedCode.Types as Docs +import Language.PureScript.Docs.RenderedCode as Docs import Language.PureScript.Docs.Types as Docs diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index bcc258e3c4..6cb3b4e47b 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -77,12 +77,10 @@ declAsMarkdown mn decl@Declaration{..} = do codeToString :: RenderedCode -> Text codeToString = outputWith elemAsMarkdown where - elemAsMarkdown (Syntax x) = x - elemAsMarkdown (Ident x _) = x - elemAsMarkdown (Ctor x _) = x - elemAsMarkdown (Kind x) = x - elemAsMarkdown (Keyword x) = x - elemAsMarkdown Space = " " + elemAsMarkdown (Syntax x) = x + elemAsMarkdown (Keyword x) = x + elemAsMarkdown Space = " " + elemAsMarkdown (Symbol _ x _) = x -- fixityAsMarkdown :: P.Fixity -> Docs -- fixityAsMarkdown (P.Fixity associativity precedence) = diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 639824c3ff..b60cae8e0d 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -28,7 +28,7 @@ renderDeclarationWithOptions :: RenderTypeOptions -> Declaration -> RenderedCode renderDeclarationWithOptions opts Declaration{..} = mintersperse sp $ case declInfo of ValueDeclaration ty -> - [ ident declTitle + [ ident' declTitle , syntax "::" , renderType' ty ] @@ -70,40 +70,25 @@ renderDeclarationWithOptions opts Declaration{..} = [idents from <> sp <> syntax "->" <> sp <> idents to | (from, to) <- fundeps ] ] where - idents = mintersperse sp . map ident + idents = mintersperse sp . map ident' - AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) -> + AliasDeclaration (P.Fixity associativity precedence) for -> [ keywordFixity associativity , syntax $ T.pack $ show precedence - , ident $ renderQualAlias for - , keyword "as" - , ident $ adjustAliasName alias declTitle + , alias for + , keywordAs + , aliasName for declTitle ] ExternKindDeclaration -> [ keywordKind - , renderKind (P.NamedKind (notQualified declTitle)) + , kind (notQualified declTitle) ] where renderType' :: P.Type -> RenderedCode renderType' = renderTypeWithOptions opts - renderQualAlias :: FixityAlias -> Text - renderQualAlias (P.Qualified mn alias) - | mn == currentModule opts = renderAlias id alias - | otherwise = renderAlias (\f -> P.showQualified f . P.Qualified mn) alias - - renderAlias - :: (forall a. (a -> Text) -> a -> Text) - -> Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName)) - -> Text - renderAlias f - = either (("type " <>) . f P.runProperName) - $ either (f P.runIdent) (f P.runProperName) - - adjustAliasName _ title = T.tail (T.init title) - renderChildDeclaration :: ChildDeclaration -> RenderedCode renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions @@ -113,18 +98,17 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} = ChildInstance constraints ty -> maybeToList (renderConstraints constraints) ++ [ renderType' ty ] ChildDataConstructor args -> - [ renderType' typeApp' ] - where - typeApp' = foldl P.TypeApp ctor' args - ctor' = P.TypeConstructor (notQualified cdeclTitle) + [ dataCtor' cdeclTitle ] + ++ map renderTypeAtom' args ChildTypeClassMember ty -> - [ ident cdeclTitle + [ ident' cdeclTitle , syntax "::" , renderType' ty ] where renderType' = renderTypeWithOptions opts + renderTypeAtom' = renderTypeAtomWithOptions opts renderConstraint :: P.Constraint -> RenderedCode renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions @@ -151,6 +135,12 @@ renderConstraintsWithOptions opts constraints notQualified :: Text -> P.Qualified (P.ProperName a) notQualified = P.Qualified Nothing . P.ProperName +ident' :: Text -> RenderedCode +ident' = ident . P.Qualified Nothing . P.Ident + +dataCtor' :: Text -> RenderedCode +dataCtor' = dataCtor . notQualified + typeApp :: Text -> [(Text, Maybe P.Kind)] -> P.Type typeApp title typeArgs = foldl P.TypeApp diff --git a/src/Language/PureScript/Docs/RenderedCode.hs b/src/Language/PureScript/Docs/RenderedCode.hs index 27de533309..216eba39ba 100644 --- a/src/Language/PureScript/Docs/RenderedCode.hs +++ b/src/Language/PureScript/Docs/RenderedCode.hs @@ -1,8 +1,9 @@ - --- | Data types and functions for representing a simplified form of PureScript --- code, intended for use in e.g. HTML documentation. - -module Language.PureScript.Docs.RenderedCode (module RenderedCode) where - -import Language.PureScript.Docs.RenderedCode.Types as RenderedCode -import Language.PureScript.Docs.RenderedCode.Render as RenderedCode + +-- | Data types and functions for representing a simplified form of PureScript +-- code, intended for use in e.g. HTML documentation. + +module Language.PureScript.Docs.RenderedCode (module RenderedCode) where + +import Language.PureScript.Docs.RenderedCode.Types as RenderedCode +import Language.PureScript.Docs.RenderedCode.RenderType as RenderedCode +import Language.PureScript.Docs.RenderedCode.RenderKind as RenderedCode diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs b/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs new file mode 100644 index 0000000000..3539a1244f --- /dev/null +++ b/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs @@ -0,0 +1,57 @@ +-- | Functions for producing RenderedCode values from PureScript Kind values. +-- +module Language.PureScript.Docs.RenderedCode.RenderKind + ( renderKind + ) where + +-- TODO: This is pretty much copied from Language.PureScript.Pretty.Kinds. +-- Ideally we would unify the two. + +import Prelude.Compat + +import Control.Arrow (ArrowPlus(..)) +import Control.PatternArrows as PA + +import Data.Monoid ((<>)) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T + +import Language.PureScript.Crash +import Language.PureScript.Kinds + +import Language.PureScript.Docs.RenderedCode.Types + +typeLiterals :: Pattern () Kind RenderedCode +typeLiterals = mkPattern match + where + match (KUnknown u) = + Just $ typeVar $ T.cons 'k' (T.pack (show u)) + match (NamedKind n) = + Just $ kind n + match _ = Nothing + +matchRow :: Pattern () Kind ((), Kind) +matchRow = mkPattern match + where + match (Row k) = Just ((), k) + match _ = Nothing + +funKind :: Pattern () Kind (Kind, Kind) +funKind = mkPattern match + where + match (FunKind arg ret) = Just (arg, ret) + match _ = Nothing + +-- | Generate RenderedCode value representing a Kind +renderKind :: Kind -> RenderedCode +renderKind + = fromMaybe (internalError "Incomplete pattern") + . PA.pattern matchKind () + where + matchKind :: Pattern () Kind RenderedCode + matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind) + + operators :: OperatorTable () Kind RenderedCode + operators = + OperatorTable [ [ Wrap matchRow $ \_ k -> syntax "#" <> sp <> k] + , [ AssocR funKind $ \arg ret -> arg <> sp <> syntax "->" <> sp <> ret ] ] diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs similarity index 85% rename from src/Language/PureScript/Docs/RenderedCode/Render.hs rename to src/Language/PureScript/Docs/RenderedCode/RenderType.hs index b8d10083c6..0a697b8eec 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -1,13 +1,13 @@ -- | Functions for producing RenderedCode values from PureScript Type values. -module Language.PureScript.Docs.RenderedCode.Render +module Language.PureScript.Docs.RenderedCode.RenderType ( renderType , renderTypeAtom , renderRow - , renderKind , RenderTypeOptions(..) , defaultRenderTypeOptions , renderTypeWithOptions + , renderTypeAtomWithOptions ) where import Prelude.Compat @@ -20,39 +20,40 @@ import Control.Arrow ((<+>)) import Control.PatternArrows as PA import Language.PureScript.Crash -import Language.PureScript.Docs.RenderedCode.Types -import Language.PureScript.Docs.Utils.MonoidExtras import Language.PureScript.Environment import Language.PureScript.Kinds import Language.PureScript.Names -import Language.PureScript.Pretty.Kinds import Language.PureScript.Pretty.Types import Language.PureScript.Types import Language.PureScript.Label (Label) +import Language.PureScript.Docs.RenderedCode.Types +import Language.PureScript.Docs.Utils.MonoidExtras +import Language.PureScript.Docs.RenderedCode.RenderKind (renderKind) + typeLiterals :: Pattern () Type RenderedCode typeLiterals = mkPattern match where match TypeWildcard{} = Just (syntax "_") match (TypeVar var) = - Just (ident var) + Just (typeVar var) match (PrettyPrintObject row) = Just $ mintersperse sp [ syntax "{" , renderRow row , syntax "}" ] - match (TypeConstructor (Qualified mn name)) = - Just (ctor (runProperName name) (maybeToContainingModule mn)) + match (TypeConstructor n) = + Just (typeCtor n) match REmpty = Just (syntax "()") match row@RCons{} = Just (syntax "(" <> renderRow row <> syntax ")") match (BinaryNoParensType op l r) = Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r - match (TypeOp (Qualified mn op)) = - Just (ident' (runOpName op) (maybeToContainingModule mn)) + match (TypeOp n) = + Just (typeOp n) match _ = Nothing @@ -87,7 +88,7 @@ renderHead = mintersperse (syntax "," <> sp) . map renderLabel renderLabel :: (Label, Type) -> RenderedCode renderLabel (label, ty) = mintersperse sp - [ syntax $ prettyPrintLabel label + [ typeVar $ prettyPrintLabel label , syntax "::" , renderType ty ] @@ -139,7 +140,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ] , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ] , [ Wrap constrained $ \deps ty -> renderConstraints deps ty ] - , [ Wrap forall_ $ \idents ty -> mconcat [syntax "forall", sp, mintersperse sp (map ident idents), syntax ".", sp, ty] ] + , [ Wrap forall_ $ \tyVars ty -> mconcat [keywordForall, sp, mintersperse sp (map typeVar tyVars), syntax ".", sp, ty] ] , [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ] , [ Wrap explicitParens $ \_ ty -> ty ] ] @@ -154,12 +155,6 @@ insertPlaceholders :: RenderTypeOptions -> Type -> Type insertPlaceholders opts = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes (convert opts) -dePrim :: Type -> Type -dePrim ty@(TypeConstructor (Qualified _ name)) - | ty == tyBoolean || ty == tyNumber || ty == tyString = - TypeConstructor $ Qualified Nothing name -dePrim other = other - convert :: RenderTypeOptions -> Type -> Type convert _ (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret convert opts (TypeApp o r) | o == tyRecord && prettyPrintObjects opts = PrettyPrintObject r @@ -173,28 +168,20 @@ convertForAlls (ForAll i ty _) = go [i] ty convertForAlls other = other preprocessType :: RenderTypeOptions -> Type -> Type -preprocessType opts = dePrim . insertPlaceholders opts +preprocessType opts = insertPlaceholders opts + -- | --- Render code representing a Kind +-- Render code representing a Type -- -renderKind :: Kind -> RenderedCode -renderKind = kind . prettyPrintKind +renderType :: Type -> RenderedCode +renderType = renderTypeWithOptions defaultRenderTypeOptions -- | -- Render code representing a Type, as it should appear inside parentheses -- renderTypeAtom :: Type -> RenderedCode -renderTypeAtom - = fromMaybe (internalError "Incomplete pattern") - . PA.pattern matchTypeAtom () - . preprocessType defaultRenderTypeOptions - --- | --- Render code representing a Type --- -renderType :: Type -> RenderedCode -renderType = renderTypeWithOptions defaultRenderTypeOptions +renderTypeAtom = renderTypeAtomWithOptions defaultRenderTypeOptions data RenderTypeOptions = RenderTypeOptions { prettyPrintObjects :: Bool @@ -213,3 +200,9 @@ renderTypeWithOptions opts = fromMaybe (internalError "Incomplete pattern") . PA.pattern matchType () . preprocessType opts + +renderTypeAtomWithOptions :: RenderTypeOptions -> Type -> RenderedCode +renderTypeAtomWithOptions opts + = fromMaybe (internalError "Incomplete pattern") + . PA.pattern matchTypeAtom () + . preprocessType opts diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index ea42d66eaf..8a63d62d2b 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} -- | Data types and functions for representing a simplified form of PureScript -- code, intended for use in e.g. HTML documentation. @@ -11,15 +12,16 @@ module Language.PureScript.Docs.RenderedCode.Types , containingModuleToMaybe , maybeToContainingModule , fromContainingModule + , fromQualified + , Namespace(..) + , Link(..) + , FixityAlias , RenderedCode , asRenderedCode , outputWith , sp + , parens , syntax - , ident - , ident' - , ctor - , kind , keyword , keywordForall , keywordData @@ -30,105 +32,216 @@ module Language.PureScript.Docs.RenderedCode.Types , keywordWhere , keywordFixity , keywordKind + , keywordAs + , ident + , dataCtor + , typeCtor + , typeOp + , typeVar + , kind + , alias + , aliasName ) where import Prelude.Compat +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) import Control.Monad.Error.Class (MonadError(..)) +import Data.Monoid ((<>)) import Data.Aeson.BetterErrors import qualified Data.Aeson as A import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.ByteString.Lazy as BS +import qualified Data.Text.Encoding as TE -import qualified Language.PureScript as P +import Language.PureScript.Names +import Language.PureScript.AST (Associativity(..)) +import Language.PureScript.Crash (internalError) --- | --- A single element in a rendered code fragment. The intention is to support --- multiple output formats. For example, plain text, or highlighted HTML. --- -data RenderedCodeElement - = Syntax Text - | Ident Text ContainingModule - | Ctor Text ContainingModule - | Kind Text - | Keyword Text - | Space - deriving (Show, Eq, Ord) +-- | Given a list of actions, attempt them all, returning the first success. +-- If all the actions fail, 'tryAll' returns the first argument. +tryAll :: MonadError e m => m a -> [m a] -> m a +tryAll = foldr $ \x y -> catchError x (const y) -instance A.ToJSON RenderedCodeElement where - toJSON (Syntax str) = - A.toJSON ["syntax", str] - toJSON (Ident str mn) = - A.toJSON ["ident", A.toJSON str, A.toJSON mn] - toJSON (Ctor str mn) = - A.toJSON ["ctor", A.toJSON str, A.toJSON mn ] - toJSON (Kind str) = - A.toJSON ["kind", str] - toJSON (Keyword str) = - A.toJSON ["keyword", str] - toJSON Space = - A.toJSON ["space" :: Text] - -asRenderedCodeElement :: Parse Text RenderedCodeElement -asRenderedCodeElement = - a Syntax "syntax" <|> - asIdent <|> - asCtor <|> - a Kind "kind" <|> - a Keyword "keyword" <|> - asSpace <|> - unableToParse +firstEq :: Text -> Parse Text a -> Parse Text a +firstEq str p = nth 0 (withText (eq str)) *> p where - p <|> q = catchError p (const q) + eq s s' = if s == s' then Right () else Left "" - a ctor' ctorStr = ctor' <$> (nth 0 (withText (eq ctorStr)) *> nth 1 asText) - asIdent = nth 0 (withText (eq "ident")) *> (Ident <$> nth 1 asText <*> nth 2 asContainingModule) - asCtor = nth 0 (withText (eq "ctor")) *> (Ctor <$> nth 1 asText <*> nth 2 asContainingModule) - asSpace = nth 0 (withText (eq "space")) *> pure Space +-- | +-- Try the given parsers in sequence. If all fail, fail with the given message, +-- and include the JSON in the error. +-- +tryParse :: Text -> [Parse Text a] -> Parse Text a +tryParse msg = + tryAll (withValue (Left . (fullMsg <>) . showJSON)) - eq s s' = if s == s' then Right () else Left "" + where + fullMsg = "Invalid " <> msg <> ": " - unableToParse = withText Left + showJSON :: A.Value -> Text + showJSON = TE.decodeUtf8 . BS.toStrict . A.encode -- | --- This type is isomorphic to 'Maybe' 'P.ModuleName'. It makes code a bit easier --- to read, as the meaning is more explicit. +-- This type is isomorphic to 'Maybe' 'ModuleName'. It makes code a bit +-- easier to read, as the meaning is more explicit. -- data ContainingModule = ThisModule - | OtherModule P.ModuleName + | OtherModule ModuleName deriving (Show, Eq, Ord) instance A.ToJSON ContainingModule where - toJSON mn = A.toJSON (P.runModuleName <$> containingModuleToMaybe mn) + toJSON = A.toJSON . go + where + go = \case + ThisModule -> ["ThisModule"] + OtherModule mn -> ["OtherModule", runModuleName mn] -asContainingModule :: Parse e ContainingModule +instance A.FromJSON ContainingModule where + parseJSON = toAesonParser id asContainingModule + +asContainingModule :: Parse Text ContainingModule asContainingModule = - maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asText) + tryParse "containing module" $ + current ++ backwardsCompat + where + current = + [ firstEq "ThisModule" (pure ThisModule) + , firstEq "OtherModule" (OtherModule <$> nth 1 asModuleName) + ] + + -- For JSON produced by compilers up to 0.10.5. + backwardsCompat = + [ maybeToContainingModule <$> perhaps asModuleName + ] + + asModuleName = moduleNameFromString <$> asText -- | --- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious +-- Convert a 'Maybe' 'ModuleName' to a 'ContainingModule', using the obvious -- isomorphism. -- -maybeToContainingModule :: Maybe P.ModuleName -> ContainingModule +maybeToContainingModule :: Maybe ModuleName -> ContainingModule maybeToContainingModule Nothing = ThisModule maybeToContainingModule (Just mn) = OtherModule mn -- | --- Convert a 'ContainingModule' to a 'Maybe' 'P.ModuleName', using the obvious +-- Convert a 'ContainingModule' to a 'Maybe' 'ModuleName', using the obvious -- isomorphism. -- -containingModuleToMaybe :: ContainingModule -> Maybe P.ModuleName +containingModuleToMaybe :: ContainingModule -> Maybe ModuleName containingModuleToMaybe ThisModule = Nothing containingModuleToMaybe (OtherModule mn) = Just mn -- | -- A version of 'fromMaybe' for 'ContainingModule' values. -- -fromContainingModule :: P.ModuleName -> ContainingModule -> P.ModuleName +fromContainingModule :: ModuleName -> ContainingModule -> ModuleName fromContainingModule def ThisModule = def fromContainingModule _ (OtherModule mn) = mn +fromQualified :: Qualified a -> (ContainingModule, a) +fromQualified (Qualified mn x) = + (maybeToContainingModule mn, x) + +data Link + = NoLink + | Link ContainingModule + deriving (Show, Eq, Ord) + +instance A.ToJSON Link where + toJSON = \case + NoLink -> A.toJSON ["NoLink" :: Text] + Link mn -> A.toJSON ["Link", A.toJSON mn] + +asLink :: Parse Text Link +asLink = + tryParse "link" + [ firstEq "NoLink" (pure NoLink) + , firstEq "Link" (Link <$> nth 1 asContainingModule) + ] + +instance A.FromJSON Link where + parseJSON = toAesonParser id asLink + +data Namespace + = ValueLevel + | TypeLevel + | KindLevel + deriving (Show, Eq, Ord, Generic) + +instance NFData Namespace + +instance A.ToJSON Namespace where + toJSON = A.toJSON . show + +asNamespace :: Parse Text Namespace +asNamespace = + tryParse "namespace" + [ withText $ \case + "ValueLevel" -> Right ValueLevel + "TypeLevel" -> Right TypeLevel + "KindLevel" -> Right KindLevel + _ -> Left "" + ] + +instance A.FromJSON Namespace where + parseJSON = toAesonParser id asNamespace + +-- | +-- A single element in a rendered code fragment. The intention is to support +-- multiple output formats. For example, plain text, or highlighted HTML. +-- +data RenderedCodeElement + = Syntax Text + | Keyword Text + | Space + -- | Any symbol which you might or might not want to link to, in any + -- namespace (value, type, or kind). Note that this is not related to the + -- kind called Symbol for type-level strings. + | Symbol Namespace Text Link + deriving (Show, Eq, Ord) + +instance A.ToJSON RenderedCodeElement where + toJSON (Syntax str) = + A.toJSON ["syntax", str] + toJSON (Keyword str) = + A.toJSON ["keyword", str] + toJSON Space = + A.toJSON ["space" :: Text] + toJSON (Symbol ns str link) = + A.toJSON ["symbol", A.toJSON ns, A.toJSON str, A.toJSON link] + +asRenderedCodeElement :: Parse Text RenderedCodeElement +asRenderedCodeElement = + tryParse "RenderedCodeElement" $ + [ a Syntax "syntax" + , a Keyword "keyword" + , asSpace + , asSymbol + ] ++ backwardsCompat + where + a ctor' ctorStr = firstEq ctorStr (ctor' <$> nth 1 asText) + asSymbol = firstEq "symbol" (Symbol <$> nth 1 asNamespace <*> nth 2 asText <*> nth 3 asLink) + asSpace = firstEq "space" (pure Space) + + -- These will make some mistakes e.g. treating data constructors as types, + -- because the old code did not save information which is necessary to + -- distinguish these cases. This is the best we can do. + backwardsCompat = + [ oldAsIdent + , oldAsCtor + , oldAsKind + ] + + oldAsIdent = firstEq "ident" (Symbol ValueLevel <$> nth 1 asText <*> nth 2 (Link <$> asContainingModule)) + oldAsCtor = firstEq "ctor" (Symbol TypeLevel <$> nth 1 asText <*> nth 2 (Link <$> asContainingModule)) + oldAsKind = firstEq "kind" (Symbol KindLevel <$> nth 1 asText <*> pure (Link ThisModule)) + -- | -- A type representing a highly simplified version of PureScript code, intended -- for use in output formats like plain text or HTML. @@ -158,21 +271,17 @@ outputWith f = foldMap f . unRC sp :: RenderedCode sp = RC [Space] +-- | +-- Wrap a RenderedCode value in parens. +parens :: RenderedCode -> RenderedCode +parens x = syntax "(" <> x <> syntax ")" + +-- possible TODO: instead of this function, export RenderedCode values for +-- each syntax element, eg syntaxArr (== syntax "->"), syntaxLBrace, +-- syntaxRBrace, etc. syntax :: Text -> RenderedCode syntax x = RC [Syntax x] -ident :: Text -> RenderedCode -ident x = RC [Ident x ThisModule] - -ident' :: Text -> ContainingModule -> RenderedCode -ident' x m = RC [Ident x m] - -ctor :: Text -> ContainingModule -> RenderedCode -ctor x m = RC [Ctor x m] - -kind :: Text -> RenderedCode -kind x = RC [Kind x] - keyword :: Text -> RenderedCode keyword kw = RC [Keyword kw] @@ -197,10 +306,78 @@ keywordInstance = keyword "instance" keywordWhere :: RenderedCode keywordWhere = keyword "where" -keywordFixity :: P.Associativity -> RenderedCode -keywordFixity P.Infixl = keyword "infixl" -keywordFixity P.Infixr = keyword "infixr" -keywordFixity P.Infix = keyword "infix" +keywordFixity :: Associativity -> RenderedCode +keywordFixity Infixl = keyword "infixl" +keywordFixity Infixr = keyword "infixr" +keywordFixity Infix = keyword "infix" keywordKind :: RenderedCode keywordKind = keyword "kind" + +keywordAs :: RenderedCode +keywordAs = keyword "as" + +ident :: Qualified Ident -> RenderedCode +ident (fromQualified -> (mn, name)) = + RC [Symbol ValueLevel (runIdent name) (Link mn)] + +dataCtor :: Qualified (ProperName 'ConstructorName) -> RenderedCode +dataCtor (fromQualified -> (mn, name)) = + RC [Symbol ValueLevel (runProperName name) (Link mn)] + +typeCtor :: Qualified (ProperName 'TypeName) -> RenderedCode +typeCtor (fromQualified -> (mn, name)) = + RC [Symbol TypeLevel (runProperName name) (Link mn)] + +typeOp :: Qualified (OpName 'TypeOpName) -> RenderedCode +typeOp (fromQualified -> (mn, name)) = + RC [Symbol TypeLevel (runOpName name) (Link mn)] + +typeVar :: Text -> RenderedCode +typeVar x = RC [Symbol TypeLevel x NoLink] + +kind :: Qualified (ProperName 'KindName) -> RenderedCode +kind (fromQualified -> (mn, name)) = + RC [Symbol KindLevel (runProperName name) (Link mn)] + +type FixityAlias = Qualified (Either (ProperName 'TypeName) (Either Ident (ProperName 'ConstructorName))) + +alias :: FixityAlias -> RenderedCode +alias for = + prefix <> RC [Symbol ns name (Link mn)] + where + (ns, name, mn) = unpackFixityAlias for + prefix = case ns of + TypeLevel -> + keywordType <> sp + _ -> + mempty + +aliasName :: FixityAlias -> Text -> RenderedCode +aliasName for name' = + let + (ns, _, _) = unpackFixityAlias for + unParen = T.tail . T.init + name = unParen name' + in + case ns of + ValueLevel -> + ident (Qualified Nothing (Ident name)) + TypeLevel -> + typeCtor (Qualified Nothing (ProperName name)) + KindLevel -> + internalError "Kind aliases are not supported" + +-- | Converts a FixityAlias into a different representation which is more +-- useful to other functions in this module. +unpackFixityAlias :: FixityAlias -> (Namespace, Text, ContainingModule) +unpackFixityAlias (fromQualified -> (mn, x)) = + case x of + -- We add some seemingly superfluous type signatures here just to be extra + -- sure we are not mixing up our namespaces. + Left (n :: ProperName 'TypeName) -> + (TypeLevel, runProperName n, mn) + Right (Left n) -> + (ValueLevel, runIdent n, mn) + Right (Right (n :: ProperName 'ConstructorName)) -> + (ValueLevel, runProperName n, mn) diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 39ab917360..bb0449ef1c 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -28,7 +28,8 @@ import Web.Bower.PackageMeta hiding (Version, displayError) import Language.PureScript.Docs.RenderedCode as ReExports (RenderedCode, asRenderedCode, ContainingModule(..), asContainingModule, - RenderedCodeElement(..), asRenderedCodeElement) + RenderedCodeElement(..), asRenderedCodeElement, + Namespace(..), FixityAlias) -------------------- -- Types @@ -183,8 +184,6 @@ convertFundepsToStrings args fundeps = ) $ argsVec V.!? i toArgs from to = (map getArg from, map getArg to) -type FixityAlias = P.Qualified (Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))) - declInfoToString :: DeclarationInfo -> Text declInfoToString (ValueDeclaration _) = "value" declInfoToString (DataDeclaration _ _) = "data" @@ -194,6 +193,23 @@ declInfoToString (TypeClassDeclaration _ _ _) = "typeClass" declInfoToString (AliasDeclaration _ _) = "alias" declInfoToString ExternKindDeclaration = "kind" +declInfoNamespace :: DeclarationInfo -> Namespace +declInfoNamespace = \case + ValueDeclaration{} -> + ValueLevel + DataDeclaration{} -> + TypeLevel + ExternDataDeclaration{} -> + TypeLevel + TypeSynonymDeclaration{} -> + TypeLevel + TypeClassDeclaration{} -> + TypeLevel + AliasDeclaration _ alias -> + either (const TypeLevel) (const ValueLevel) (P.disqualify alias) + ExternKindDeclaration{} -> + KindLevel + isTypeClass :: Declaration -> Bool isTypeClass Declaration{..} = case declInfo of @@ -269,6 +285,20 @@ childDeclInfoToString (ChildInstance _ _) = "instance" childDeclInfoToString (ChildDataConstructor _) = "dataConstructor" childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember" +childDeclInfoNamespace :: ChildDeclarationInfo -> Namespace +childDeclInfoNamespace = + -- We could just write this as `const ValueLevel` but by doing it this way, + -- if another constructor is added, we get a warning which acts as a prompt + -- to update this, instead of having this function (possibly incorrectly) + -- just return ValueLevel for the new constructor. + \case + ChildInstance{} -> + ValueLevel + ChildDataConstructor{} -> + ValueLevel + ChildTypeClassMember{} -> + ValueLevel + isTypeClassMember :: ChildDeclaration -> Bool isTypeClassMember ChildDeclaration{..} = case cdeclInfo of From 82e609b31535843bb1f9184e23d5d2feb358c7bc Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 12 Jan 2017 19:57:30 -0800 Subject: [PATCH 0618/1580] Fix parsing for named binders. Some tidying up. --- examples/passing/ParseNamedBinder.purs | 9 + src/Language/PureScript/Parser/Common.hs | 122 +++++------ .../PureScript/Parser/Declarations.hs | 193 +++++++----------- 3 files changed, 134 insertions(+), 190 deletions(-) create mode 100644 examples/passing/ParseNamedBinder.purs diff --git a/examples/passing/ParseNamedBinder.purs b/examples/passing/ParseNamedBinder.purs new file mode 100644 index 0000000000..01a297c818 --- /dev/null +++ b/examples/passing/ParseNamedBinder.purs @@ -0,0 +1,9 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +data X = X + +f a@X X = a + +main = log "Done" diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index 0048cd9fcc..5030033ec6 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -1,52 +1,39 @@ --- | --- Constants and utility functions to be used when parsing --- +-- | Useful common functions for building parsers module Language.PureScript.Parser.Common where -import Prelude.Compat +import Prelude.Compat -import Control.Applicative ((<|>)) -import Control.Monad (guard) -import Data.Monoid ((<>)) -import Data.Text (Text) +import Control.Applicative ((<|>)) +import Control.Monad (guard) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) import qualified Data.Text as T - -import Language.PureScript.AST.SourcePos -import Language.PureScript.Comments -import Language.PureScript.Names -import Language.PureScript.Parser.Lexer -import Language.PureScript.Parser.State -import Language.PureScript.PSString (PSString, mkString) - +import Language.PureScript.AST.SourcePos +import Language.PureScript.Comments +import Language.PureScript.Names +import Language.PureScript.Parser.Lexer +import Language.PureScript.Parser.State +import Language.PureScript.PSString (PSString, mkString) import qualified Text.Parsec as P --- | --- Parse a general proper name. --- +-- | Parse a general proper name. properName :: TokenParser (ProperName a) properName = ProperName <$> uname --- | --- Parse a proper name for a type. --- +-- | Parse a proper name for a type. typeName :: TokenParser (ProperName 'TypeName) typeName = ProperName <$> tyname --- | --- Parse a proper name for a kind. --- +-- | Parse a proper name for a kind. kindName :: TokenParser (ProperName 'KindName) kindName = ProperName <$> kiname --- | --- Parse a proper name for a data constructor. --- +-- | Parse a proper name for a data constructor. dataConstructorName :: TokenParser (ProperName 'ConstructorName) dataConstructorName = ProperName <$> dconsname --- | --- Parse a module name --- +-- | Parse a module name moduleName :: TokenParser ModuleName moduleName = part [] where @@ -55,9 +42,7 @@ moduleName = part [] <|> (ModuleName . snoc path . ProperName <$> mname) snoc path name = path ++ [name] --- | --- Parse a qualified name, i.e. M.name or just name --- +-- | Parse a qualified name, i.e. M.name or just name parseQualified :: TokenParser a -> TokenParser (Qualified a) parseQualified parser = part [] where @@ -67,42 +52,30 @@ parseQualified parser = part [] updatePath path name = path ++ [name] qual path = if null path then Nothing else Just $ ModuleName path --- | --- Parse an identifier. --- +-- | Parse an identifier. parseIdent :: TokenParser Ident parseIdent = Ident <$> identifier --- | --- Parse a label, which may look like an identifier or a string --- +-- | Parse a label, which may look like an identifier or a string parseLabel :: TokenParser PSString parseLabel = (mkString <$> lname) <|> stringLiteral --- | --- Parse an operator. --- +-- | Parse an operator. parseOperator :: TokenParser (OpName a) parseOperator = OpName <$> symbol --- | --- Run the first parser, then match the second if possible, applying the specified function on a successful match --- +-- | Run the first parser, then match the second if possible, applying the specified function on a successful match augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q --- | --- Run the first parser, then match the second zero or more times, applying the specified function for each match --- +-- | Run the first parser, then match the second zero or more times, applying the specified function for each match fold :: P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a fold first' more combine = do a <- first' bs <- P.many more return $ foldl combine a bs --- | --- Build a parser from a smaller parser and a list of parsers for postfix operators --- +-- | Build a parser from a smaller parser and a list of parsers for postfix operators buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a buildPostfixParser fs first' = do a <- first' @@ -114,9 +87,7 @@ buildPostfixParser fs first' = do Nothing -> return a Just a' -> go a' --- | --- Mark the current indentation level --- +-- | Mark the current indentation level mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a mark p = do current <- indentationLevel <$> P.getState @@ -126,9 +97,7 @@ mark p = do P.modifyState $ \st -> st { indentationLevel = current } return a --- | --- Check that the current identation level matches a predicate --- +-- | Check that the current identation level matches a predicate checkIndentation :: (P.Column -> Text) -> (P.Column -> P.Column -> Bool) @@ -138,32 +107,39 @@ checkIndentation mkMsg rel = do current <- indentationLevel <$> P.getState guard (col `rel` current) P. T.unpack (mkMsg current) --- | --- Check that the current indentation level is past the current mark --- +-- | Check that the current indentation level is past the current mark indented :: P.Parsec s ParseState () indented = checkIndentation (("indentation past column " <>) . (T.pack . show)) (>) --- | --- Check that the current indentation level is at the same indentation as the current mark --- +-- | Check that the current indentation level is at the same indentation as the current mark same :: P.Parsec s ParseState () same = checkIndentation (("indentation at column " <>) . (T.pack . show)) (==) --- | --- Read the comments from the the next token, without consuming it --- +-- | Read the comments from the the next token, without consuming it readComments :: P.Parsec [PositionedToken] u [Comment] readComments = P.lookAhead $ ptComments <$> P.anyToken --- | --- Run a parser --- +-- | Run a parser runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a runTokenParser filePath p = P.runParser p (ParseState 0) filePath --- | --- Convert from Parsec sourcepos --- +-- | Convert from Parsec sourcepos toSourcePos :: P.SourcePos -> SourcePos toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos) + +-- | Read source position information and comments +withSourceSpan + :: (SourceSpan -> [Comment] -> a -> b) + -> P.Parsec [PositionedToken] u a + -> P.Parsec [PositionedToken] u b +withSourceSpan f p = do + start <- P.getPosition + comments <- readComments + x <- p + end <- P.getPosition + input <- P.getInput + let end' = case input of + pt:_ -> ptPrevEndPos pt + _ -> Nothing + let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos $ fromMaybe end end') + return $ f sp comments x diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index cd8d582380..e9375312b1 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -1,6 +1,4 @@ --- | --- Parsers for module definitions and declarations --- +-- | Parsers for module definitions and declarations module Language.PureScript.Parser.Declarations ( parseDeclaration , parseModule @@ -15,53 +13,29 @@ module Language.PureScript.Parser.Declarations , toPositionedError ) where -import Prelude hiding (lex) - -import Data.Functor (($>)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) - -import Control.Applicative -import Control.Arrow ((+++)) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Parallel.Strategies (withStrategy, parList, rseq) - -import Language.PureScript.AST -import Language.PureScript.Comments -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Kinds -import Language.PureScript.Names -import Language.PureScript.Types -import Language.PureScript.PSString (PSString, mkString) -import Language.PureScript.Parser.Common -import Language.PureScript.Parser.Kinds -import Language.PureScript.Parser.Lexer -import Language.PureScript.Parser.Types - -import qualified Language.PureScript.Parser.Common as C +import Prelude hiding (lex) + +import Control.Applicative +import Control.Arrow ((+++)) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Parallel.Strategies (withStrategy, parList, rseq) +import Data.Functor (($>)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Language.PureScript.AST +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Kinds +import Language.PureScript.Names +import Language.PureScript.Parser.Common +import Language.PureScript.Parser.Kinds +import Language.PureScript.Parser.Lexer +import Language.PureScript.Parser.Types +import Language.PureScript.PSString (PSString, mkString) +import Language.PureScript.Types import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P --- | --- Read source position information --- -withSourceSpan - :: (SourceSpan -> [Comment] -> a -> a) - -> P.Parsec [PositionedToken] u a - -> P.Parsec [PositionedToken] u a -withSourceSpan f p = do - start <- P.getPosition - comments <- C.readComments - x <- p - end <- P.getPosition - input <- P.getInput - let end' = case input of - pt:_ -> ptPrevEndPos pt - _ -> Nothing - let sp = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos $ fromMaybe end end') - return $ f sp comments x - kindedIdent :: TokenParser (Text, Maybe Kind) kindedIdent = (, Nothing) <$> identifier <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind))) @@ -91,7 +65,7 @@ parseValueDeclaration :: TokenParser Declaration parseValueDeclaration = do name <- parseIdent binders <- P.many parseBinderNoParens - value <- Left <$> (C.indented *> + value <- Left <$> (indented *> P.many1 ((,) <$> parseGuard <*> (indented *> equals *> parseValueWithWhereClause) )) @@ -100,13 +74,13 @@ parseValueDeclaration = do where parseValueWithWhereClause :: TokenParser Expr parseValueWithWhereClause = do - C.indented + indented value <- parseValue whereClause <- P.optionMaybe $ do - C.indented + indented reserved "where" - C.indented - C.mark $ P.many1 (C.same *> parseLocalDeclaration) + indented + mark $ P.many1 (same *> parseLocalDeclaration) return $ maybe value (`Let` value) whereClause parseExternDeclaration :: TokenParser Declaration @@ -237,9 +211,7 @@ parseDerivingInstanceDeclaration = do positioned :: TokenParser Declaration -> TokenParser Declaration positioned = withSourceSpan PositionedDeclaration --- | --- Parse a single declaration --- +-- | Parse a single declaration parseDeclaration :: TokenParser Declaration parseDeclaration = positioned (P.choice [ parseDataDeclaration @@ -259,12 +231,10 @@ parseLocalDeclaration = positioned (P.choice , parseValueDeclaration ] P. "local declaration") --- | --- Parse a module header and a collection of declarations --- +-- | Parse a module header and a collection of declarations parseModule :: TokenParser Module parseModule = do - comments <- C.readComments + comments <- readComments start <- P.getPosition reserved "module" indented @@ -280,7 +250,7 @@ parseModule = do return (imports ++ decls) _ <- P.eof end <- P.getPosition - let ss = SourceSpan (P.sourceName start) (C.toSourcePos start) (C.toSourcePos end) + let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end) return $ Module ss comments name decls exports -- | Parse a collection of modules in parallel @@ -301,7 +271,6 @@ parseModulesFromFiles toFilePath input = inParallel :: [Either P.ParseError (k, a)] -> [Either P.ParseError (k, a)] inParallel = withStrategy (parList rseq) - -- | Parses a single module with FilePath for eventual parsing errors parseModuleFromFile :: (k -> FilePath) @@ -313,12 +282,12 @@ parseModuleFromFile toFilePath (k, content) = do m <- runTokenParser filename parseModule ts pure (k, m) --- | Converts a @ParseError@ into a @PositionedError@ +-- | Converts a 'ParseError' into a 'PositionedError' toPositionedError :: P.ParseError -> ErrorMessage toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr) where name = (P.sourceName . P.errorPos) perr - start = (C.toSourcePos . P.errorPos) perr + start = (toSourcePos . P.errorPos) perr end = start booleanLiteral :: TokenParser Bool @@ -345,18 +314,18 @@ parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p) parseIdentifierAndValue :: TokenParser (PSString, Expr) parseIdentifierAndValue = do - name <- C.indented *> lname + name <- indented *> lname b <- P.option (Var $ Qualified Nothing (Ident name)) rest return (mkString name, b) - <|> (,) <$> (C.indented *> stringLiteral) <*> rest + <|> (,) <$> (indented *> stringLiteral) <*> rest where - rest = C.indented *> colon *> C.indented *> parseValue + rest = indented *> colon *> indented *> parseValue parseAbs :: TokenParser Expr parseAbs = do symbol' "\\" - args <- P.many1 (C.indented *> (Abs <$> (Left <$> C.parseIdent <|> Right <$> parseBinderNoParens))) - C.indented *> rarrow + args <- P.many1 (indented *> (Abs <$> (Left <$> parseIdent <|> Right <$> parseBinderNoParens))) + indented *> rarrow value <- parseValue return $ toFunction args value where @@ -364,18 +333,18 @@ parseAbs = do toFunction args value = foldr ($) value args parseVar :: TokenParser Expr -parseVar = Var <$> C.parseQualified C.parseIdent +parseVar = Var <$> parseQualified parseIdent parseConstructor :: TokenParser Expr -parseConstructor = Constructor <$> C.parseQualified C.dataConstructorName +parseConstructor = Constructor <$> parseQualified dataConstructorName parseCase :: TokenParser Expr -parseCase = Case <$> P.between (reserved "case") (C.indented *> reserved "of") (commaSep1 parseValue) - <*> (C.indented *> C.mark (P.many1 (C.same *> C.mark parseCaseAlternative))) +parseCase = Case <$> P.between (reserved "case") (indented *> reserved "of") (commaSep1 parseValue) + <*> (indented *> mark (P.many1 (same *> mark parseCaseAlternative))) parseCaseAlternative :: TokenParser CaseAlternative parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder - <*> (Left <$> (C.indented *> + <*> (Left <$> (indented *> P.many1 ((,) <$> parseGuard <*> (indented *> rarrow *> parseValue) )) @@ -383,16 +352,16 @@ parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder P. "case alternative" parseIfThenElse :: TokenParser Expr -parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> C.indented *> parseValue) - <*> (C.indented *> reserved "then" *> C.indented *> parseValue) - <*> (C.indented *> reserved "else" *> C.indented *> parseValue) +parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> indented *> parseValue) + <*> (indented *> reserved "then" *> indented *> parseValue) + <*> (indented *> reserved "else" *> indented *> parseValue) parseLet :: TokenParser Expr parseLet = do reserved "let" - C.indented - ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration) - C.indented + indented + ds <- mark $ P.many1 (same *> parseLocalDeclaration) + indented reserved "in" result <- parseValue return $ Let ds result @@ -418,9 +387,7 @@ parseValueAtom = withSourceSpan PositionedValue $ P.choice , parseHole ] --- | --- Parse an expression in backticks or an operator --- +-- | Parse an expression in backticks or an operator parseInfixExpr :: TokenParser Expr parseInfixExpr = P.between tick tick parseValue @@ -432,25 +399,25 @@ parseHole = Hole <$> holeLit parsePropertyUpdate :: TokenParser (PSString, Expr) parsePropertyUpdate = do name <- parseLabel - _ <- C.indented *> equals - value <- C.indented *> parseValue + _ <- indented *> equals + value <- indented *> parseValue return (name, value) parseAccessor :: Expr -> TokenParser Expr parseAccessor (Constructor _) = P.unexpected "constructor" -parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> parseLabel) <*> pure obj +parseAccessor obj = P.try $ Accessor <$> (indented *> dot *> indented *> parseLabel) <*> pure obj parseDo :: TokenParser Expr parseDo = do reserved "do" - C.indented - Do <$> C.mark (P.many1 (C.same *> C.mark parseDoNotationElement)) + indented + Do <$> mark (P.many1 (same *> mark parseDoNotationElement)) parseDoNotationLet :: TokenParser DoNotationElement -parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration))) +parseDoNotationLet = DoNotationLet <$> (reserved "let" *> indented *> mark (P.many1 (same *> parseLocalDeclaration))) parseDoNotationBind :: TokenParser DoNotationElement -parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* C.indented <* larrow) <*> parseValue +parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* indented <* larrow) <*> parseValue parseDoNotationElement :: TokenParser DoNotationElement parseDoNotationElement = P.choice @@ -461,33 +428,31 @@ parseDoNotationElement = P.choice -- | Expressions including indexers and record updates indexersAndAccessors :: TokenParser Expr -indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom +indexersAndAccessors = buildPostfixParser postfixTable parseValueAtom where postfixTable = [ parseAccessor , P.try . parseUpdaterBody ] --- | --- Parse a value --- +-- | Parse an expression parseValue :: TokenParser Expr parseValue = withSourceSpan PositionedValue (P.buildExpressionParser operators - . C.buildPostfixParser postfixTable + . buildPostfixParser postfixTable $ indexersAndAccessors) P. "expression" where - postfixTable = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v - , \v -> flip (TypedValue True) <$> (C.indented *> doubleColon *> parsePolyType) <*> pure v + postfixTable = [ \v -> P.try (flip App <$> (indented *> indexersAndAccessors)) <*> pure v + , \v -> flip (TypedValue True) <$> (indented *> doubleColon *> parsePolyType) <*> pure v ] - operators = [ [ P.Prefix (C.indented *> symbol' "-" *> return UnaryMinus) + operators = [ [ P.Prefix (indented *> symbol' "-" *> return UnaryMinus) ] - , [ P.Infix (P.try (C.indented *> parseInfixExpr P. "infix expression") >>= \ident -> + , [ P.Infix (P.try (indented *> parseInfixExpr P. "infix expression") >>= \ident -> return (BinaryNoParens ident)) P.AssocRight ] ] parseUpdaterBody :: Expr -> TokenParser Expr -parseUpdaterBody v = ObjectUpdate v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate))) +parseUpdaterBody v = ObjectUpdate v <$> (indented *> braces (commaSep1 (indented *> parsePropertyUpdate))) parseAnonymousArgument :: TokenParser Expr parseAnonymousArgument = underscore *> pure AnonymousArgument @@ -501,21 +466,21 @@ parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number) <|> return id parseNullaryConstructorBinder :: TokenParser Binder -parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> pure [] +parseNullaryConstructorBinder = ConstructorBinder <$> parseQualified dataConstructorName <*> pure [] parseConstructorBinder :: TokenParser Binder -parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.dataConstructorName <*> many (C.indented *> parseBinderNoParens) +parseConstructorBinder = ConstructorBinder <$> parseQualified dataConstructorName <*> many (indented *> parseBinderNoParens) parseObjectBinder:: TokenParser Binder -parseObjectBinder = LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder) +parseObjectBinder = LiteralBinder <$> parseObjectLiteral (indented *> parseIdentifierAndBinder) parseArrayBinder :: TokenParser Binder -parseArrayBinder = LiteralBinder <$> parseArrayLiteral (C.indented *> parseBinder) +parseArrayBinder = LiteralBinder <$> parseArrayLiteral (indented *> parseBinder) parseVarOrNamedBinder :: TokenParser Binder parseVarOrNamedBinder = do - name <- C.parseIdent - let parseNamedBinder = NamedBinder name <$> (at *> C.indented *> parseBinderAtom) + name <- parseIdent + let parseNamedBinder = NamedBinder name <$> (at *> indented *> parseBinderNoParens) parseNamedBinder <|> return (VarBinder name) parseNullBinder :: TokenParser Binder @@ -528,11 +493,9 @@ parseIdentifierAndBinder = return (mkString name, b) <|> (,) <$> stringLiteral <*> rest where - rest = C.indented *> colon *> C.indented *> parseBinder + rest = indented *> colon *> indented *> parseBinder --- | --- Parse a binder --- +-- | Parse a binder parseBinder :: TokenParser Binder parseBinder = withSourceSpan @@ -543,7 +506,7 @@ parseBinder = ) where operators = - [ [ P.Infix (P.try (C.indented *> parseOpBinder P. "binder operator") >>= \op -> + [ [ P.Infix (P.try (indented *> parseOpBinder P. "binder operator") >>= \op -> return (BinaryNoParensBinder op)) P.AssocRight ] ] @@ -569,9 +532,7 @@ parseBinderAtom = P.choice , ParensInBinder <$> parens parseBinder ] P. "binder" --- | --- Parse a binder as it would appear in a top level declaration --- +-- | Parse a binder as it would appear in a top level declaration parseBinderNoParens :: TokenParser Binder parseBinderNoParens = P.choice [ parseNullBinder @@ -586,8 +547,6 @@ parseBinderNoParens = P.choice , ParensInBinder <$> parens parseBinder ] P. "binder" --- | --- Parse a guard --- +-- | Parse a guard parseGuard :: TokenParser Guard -parseGuard = pipe *> C.indented *> parseValue +parseGuard = pipe *> indented *> parseValue From 85bb0f5397abf492833e9042ce4ac47b81b7c524 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 12 Jan 2017 21:09:07 -0800 Subject: [PATCH 0619/1580] Fix inlining for negateInt --- examples/passing/2136.purs | 9 +++++++++ src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs | 5 +++-- 2 files changed, 12 insertions(+), 2 deletions(-) create mode 100644 examples/passing/2136.purs diff --git a/examples/passing/2136.purs b/examples/passing/2136.purs new file mode 100644 index 0000000000..98c3972ed3 --- /dev/null +++ b/examples/passing/2136.purs @@ -0,0 +1,9 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +main = + if (negate (bottom :: Int) > top) + then log "Fail" + else log "Done" diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index 753b63d79b..fddd6b89dc 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -86,6 +86,8 @@ inlineCommonValues = everywhereOnJS convert | isDict' [semiringNumber, semiringInt] dict && isFn fnOne fn = JSNumericLiteral ss (Left 1) | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral ss False | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral ss True + convert (JSApp ss (JSApp _ fn [dict]) [x]) + | isDict ringInt dict && isFn fnNegate fn = JSBinary ss BitwiseOr (JSUnary ss Negate x) (JSNumericLiteral ss (Left 0)) convert (JSApp ss (JSApp _ (JSApp _ fn [dict]) [x]) [y]) | isDict semiringInt dict && isFn fnAdd fn = intOp ss Add x y | isDict semiringInt dict && isFn fnMultiply fn = intOp ss Multiply x y @@ -100,6 +102,7 @@ inlineCommonValues = everywhereOnJS convert fnDivide = (C.dataEuclideanRing, C.div) fnMultiply = (C.dataSemiring, C.mul) fnSubtract = (C.dataRing, C.sub) + fnNegate = (C.dataRing, C.negate) intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0)) inlineCommonOperators :: JS -> JS @@ -109,8 +112,6 @@ inlineCommonOperators = applyAll $ , binary ringNumber opSub Subtract , unary ringNumber opNegate Negate - , binary ringInt opSub Subtract - , unary ringInt opNegate Negate , binary euclideanRingNumber opDiv Divide , binary euclideanRingInt opMod Modulus From 28a3095be3144debc3396703ac173dcbf2ee7d6f Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sat, 14 Jan 2017 00:34:39 +0000 Subject: [PATCH 0620/1580] Fix 'Unknown type index' on mismatch between class and instance argument counts Error earlier on argument count mismatch Removed unused error: DeprecatedRequirePath Fix error message for ExpectedType: print Type instead of * --- examples/failing/MPTCs.purs | 2 +- examples/failing/TooFewClassInstanceArgs.purs | 8 ++++++++ src/Language/PureScript/AST/Declarations.hs | 3 ++- src/Language/PureScript/Errors.hs | 14 +++++++++----- src/Language/PureScript/TypeChecker.hs | 8 ++++++++ 5 files changed, 28 insertions(+), 7 deletions(-) create mode 100644 examples/failing/TooFewClassInstanceArgs.purs diff --git a/examples/failing/MPTCs.purs b/examples/failing/MPTCs.purs index c5917cfbe1..16a7822001 100644 --- a/examples/failing/MPTCs.purs +++ b/examples/failing/MPTCs.purs @@ -1,4 +1,4 @@ --- @shouldFailWith KindsDoNotUnify +-- @shouldFailWith ClassInstanceArityMismatch module Main where import Prelude diff --git a/examples/failing/TooFewClassInstanceArgs.purs b/examples/failing/TooFewClassInstanceArgs.purs new file mode 100644 index 0000000000..2d612c9af8 --- /dev/null +++ b/examples/failing/TooFewClassInstanceArgs.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith ClassInstanceArityMismatch +module Main where + +import Prelude + +class Foo a b + +instance fooString :: Foo String diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 248c26d911..1453385457 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -134,11 +134,12 @@ data SimpleErrorMessage | CaseBinderLengthDiffers Int [Binder] | IncorrectAnonymousArgument | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident) - | DeprecatedRequirePath | CannotGeneralizeRecursiveFunction Ident Type | CannotDeriveNewtypeForData (ProperName 'TypeName) | ExpectedWildcard (ProperName 'TypeName) | CannotUseBindWithDo + -- | instance name, type class, expected argument count, actual argument count + | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int deriving (Show) -- | Error message hints, providing more detailed information about failure. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8ef2fb9698..07d8de18a9 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -168,11 +168,11 @@ errorCode em = case unwrapErrorMessage em of CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers" IncorrectAnonymousArgument -> "IncorrectAnonymousArgument" InvalidOperatorInBinder{} -> "InvalidOperatorInBinder" - DeprecatedRequirePath{} -> "DeprecatedRequirePath" CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction" CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData" ExpectedWildcard{} -> "ExpectedWildcard" CannotUseBindWithDo{} -> "CannotUseBindWithDo" + ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch" -- | -- A stack trace for an error @@ -691,7 +691,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS renderSimpleErrorMessage (ExtraneousClassMember ident className) = line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className) renderSimpleErrorMessage (ExpectedType ty kind) = - paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode "*" <> "." + paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode (prettyPrintKind kindType) <> "." , line "The error arises from the type" , markCodeBox $ indent $ typeAsBox ty , line "having the kind" @@ -863,9 +863,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS , line "Only aliases for data constructors may be used in patterns." ] - renderSimpleErrorMessage DeprecatedRequirePath = - line "The require-path option is deprecated and will be removed in PureScript 0.9." - renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) = paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "." , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:" @@ -885,6 +882,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS paras [ line $ "The name " <> markCode "bind" <> " cannot be brought into scope in a do notation block, since do notation uses the same name." ] + renderSimpleErrorMessage (ClassInstanceArityMismatch dictName className expected actual) = + paras [ line $ "The type class " <> markCode (showQualified runProperName className) <> + " expects " <> T.pack (show expected) <> " argument(s)." + , line $ "But the instance " <> markCode (showIdent dictName) <> " only provided " <> + T.pack (show actual) <> "." + ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index c94e8282ff..c63f5f6356 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -297,6 +297,7 @@ typeCheckAll moduleName _ = traverse go case M.lookup className (typeClasses env) of Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" Just typeClass -> do + checkInstanceArity dictName className typeClass tys sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys) checkOrphanInstance dictName className typeClass tys _ <- traverseTypeInstanceBody checkInstanceMembers body @@ -306,6 +307,13 @@ typeCheckAll moduleName _ = traverse go go (PositionedDeclaration pos com d) = warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d + checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m () + checkInstanceArity dictName className typeClass tys = do + let typeClassArity = length (typeClassArguments typeClass) + instanceArity = length tys + when (typeClassArity /= instanceArity) $ + throwError . errorMessage $ ClassInstanceArityMismatch dictName className typeClassArity instanceArity + checkInstanceMembers :: [Declaration] -> m [Declaration] checkInstanceMembers instDecls = do let idents = sort . map head . group . map memberName $ instDecls From 1326949be7a2414b779e992727cdd4a3c3fe2187 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sat, 14 Jan 2017 20:56:41 +0000 Subject: [PATCH 0621/1580] Support nested record update (#2566) * Support nested record update * Comment desugaring of ObjectUpdateNested * Comment corrections on nested object update --- examples/passing/NestedRecordUpdate.purs | 23 ++++ .../passing/NestedRecordUpdateWildcards.purs | 20 +++ src/Language/PureScript/AST/Declarations.hs | 6 + src/Language/PureScript/AST/Traversals.hs | 7 ++ .../PureScript/Parser/Declarations.hs | 13 +- src/Language/PureScript/Pretty/Values.hs | 12 +- .../PureScript/Sugar/ObjectWildcards.hs | 115 +++++++++++++++--- 7 files changed, 176 insertions(+), 20 deletions(-) create mode 100644 examples/passing/NestedRecordUpdate.purs create mode 100644 examples/passing/NestedRecordUpdateWildcards.purs diff --git a/examples/passing/NestedRecordUpdate.purs b/examples/passing/NestedRecordUpdate.purs new file mode 100644 index 0000000000..72be8c0dc3 --- /dev/null +++ b/examples/passing/NestedRecordUpdate.purs @@ -0,0 +1,23 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console + +type T = { foo :: Int, bar :: { baz :: Int, qux :: Int } } + +init :: T +init = { foo: 1, bar: { baz: 2, qux: 3 } } + +updated :: T +updated = init { foo = 10, bar.baz = 20, bar.qux = 30 } + +expected :: T +expected = { foo: 10, bar: { baz: 20, qux: 30 } } + +check l r = + l.foo == r.foo && + l.bar.baz == r.bar.baz && + l.bar.qux == r.bar.qux + +main = do + when (check updated expected) $ log "Done" diff --git a/examples/passing/NestedRecordUpdateWildcards.purs b/examples/passing/NestedRecordUpdateWildcards.purs new file mode 100644 index 0000000000..e16d7c571f --- /dev/null +++ b/examples/passing/NestedRecordUpdateWildcards.purs @@ -0,0 +1,20 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console + +update = _ { foo = _, bar.baz = _, bar.qux = _ } + +init = { foo: 1, bar: { baz: 2, qux: 3 } } + +after = update init 10 20 30 + +expected = { foo: 10, bar: { baz: 20, qux: 30 } } + +check l r = + l.foo == r.foo && + l.bar.baz == r.bar.baz && + l.bar.qux == r.bar.qux + +main = do + when (check after expected) $ log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 1453385457..170bddbe9f 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -12,6 +12,7 @@ import Control.Monad.Identity import Data.Aeson.TH import qualified Data.Map as M import Data.Text (Text) +import Data.List.NonEmpty (NonEmpty(..)) import Language.PureScript.AST.Binders import Language.PureScript.AST.Literals @@ -583,6 +584,11 @@ data Expr -- | ObjectUpdate Expr [(PSString, Expr)] -- | + -- Object updates with nested support: `x { foo.bar = e }` + -- Replaced during desugaring into a `Let` and nested `ObjectUpdate`s + -- + | ObjectUpdateNested Expr [(NonEmpty PSString, Expr)] + -- | -- Function introduction -- | Abs (Either Ident Binder) Expr diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index e15b30d5fb..3e56ab7155 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -48,6 +48,7 @@ everywhereOnValues f g h = (f', g', h') g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v)) g' (Accessor prop v) = g (Accessor prop (g' v)) g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs)) + g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (map (fmap g') vs)) g' (Abs name v) = g (Abs name (g' v)) g' (App v1 v2) = g (App (g' v1) (g' v2)) g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3)) @@ -115,6 +116,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g') g' (Accessor prop v) = Accessor prop <$> (g v >>= g') g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs + g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs g' (Abs name v) = Abs name <$> (g v >>= g') g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g') g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g') @@ -182,6 +184,7 @@ everywhereOnValuesM f g h = (f', g', h') g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g + g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse (sndM g') vs) >>= g g' (Abs name v) = (Abs name <$> g' v) >>= g g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g @@ -254,6 +257,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1 g' v@(Accessor _ v1) = g v <> g' v1 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs) + g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs) g' v@(Abs _ v1) = g v <> g' v1 g' v@(App v1 v2) = g v <> g' v1 <> g' v2 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3 @@ -331,6 +335,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs) + g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs) g' s (Abs _ v1) = g'' s v1 g' s (App v1 v2) = g'' s v1 <> g'' s v2 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 @@ -410,6 +415,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v g' s (Accessor prop v) = Accessor prop <$> g'' s v g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs + g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (sndM (g'' s)) vs g' s (Abs name v) = Abs name <$> g'' s v g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3 @@ -500,6 +506,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs + g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s . snd) vs g' s (Abs (Left name) v1) = let s' = S.insert name s in g'' s' v1 diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index e9375312b1..8b64b38444 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -19,7 +19,10 @@ import Control.Applicative import Control.Arrow ((+++)) import Control.Monad.Error.Class (MonadError(..)) import Control.Parallel.Strategies (withStrategy, parList, rseq) +import Data.Bifunctor (first) import Data.Functor (($>)) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as N import Data.Maybe (fromMaybe) import Data.Text (Text) import Language.PureScript.AST @@ -396,12 +399,13 @@ parseInfixExpr parseHole :: TokenParser Expr parseHole = Hole <$> holeLit -parsePropertyUpdate :: TokenParser (PSString, Expr) +parsePropertyUpdate :: TokenParser (NonEmpty PSString, Expr) parsePropertyUpdate = do name <- parseLabel + rest <- P.many (indented *> dot *> indented *> parseLabel) _ <- indented *> equals value <- indented *> parseValue - return (name, value) + return (name :| rest, value) parseAccessor :: Expr -> TokenParser Expr parseAccessor (Constructor _) = P.unexpected "constructor" @@ -452,7 +456,10 @@ parseValue = withSourceSpan PositionedValue ] parseUpdaterBody :: Expr -> TokenParser Expr -parseUpdaterBody v = ObjectUpdate v <$> (indented *> braces (commaSep1 (indented *> parsePropertyUpdate))) +parseUpdaterBody v = objectUpdate <$> (indented *> braces (commaSep1 (indented *> parsePropertyUpdate))) + where + objectUpdate xs | all (null . N.tail . fst) xs = ObjectUpdate v (map (first N.head) xs) + | otherwise = ObjectUpdateNested v xs parseAnonymousArgument :: TokenParser Expr parseAnonymousArgument = underscore *> pure AnonymousArgument diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 4b1c38ef9e..cbabc78ebc 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -12,6 +12,7 @@ import Prelude.Compat import Control.Arrow (second) import qualified Data.Monoid as Monoid ((<>)) +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Text as T import Data.Text (Text) @@ -47,6 +48,12 @@ prettyPrintObject d = list '{' '}' prettyPrintObjectProperty prettyPrintObjectProperty :: (PSString, Maybe Expr) -> Box prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value +prettyPrintObjectUpdate :: forall k. (k -> Box) -> Int -> Expr -> [(k, Expr)] -> Box +prettyPrintObjectUpdate printKey d o ps = + prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' printEntry ps + where + printEntry (key, val) = printKey key <> text " = " <> prettyPrintValue (d - 1) val + -- | Pretty-print an expression prettyPrintValue :: Int -> Expr -> Box prettyPrintValue d _ | d < 0 = text "..." @@ -56,7 +63,10 @@ prettyPrintValue d (IfThenElse cond th el) = , text "else " <> prettyPrintValueAtom (d - 1) el ]) prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop) -prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (\(key, val) -> textT (prettyPrintObjectKey key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps +prettyPrintValue d (ObjectUpdate o ps) = prettyPrintObjectUpdate (textT . prettyPrintObjectKey) d o ps +prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintObjectUpdate printPath d o ps where + printPath (hd :| tl) = foldl combine (textT (prettyPrintObjectKey hd)) tl + combine acc key = acc <> textT ("." Monoid.<> prettyPrintObjectKey key) prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 3e306d0d81..3fb343506a 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -3,19 +3,48 @@ module Language.PureScript.Sugar.ObjectWildcards , desugarDecl ) where -import Prelude.Compat +import Prelude.Compat -import Control.Monad (forM) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class +import Control.Monad (forM, foldM) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class +import Data.List (partition) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Language.PureScript.AST +import Language.PureScript.Environment (NameKind(..)) +import Language.PureScript.Errors +import Language.PureScript.Label (Label(..)) +import Language.PureScript.Names +import Language.PureScript.PSString (PSString) -import Data.List (partition) -import Data.Maybe (catMaybes) - -import Language.PureScript.AST -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.PSString (PSString) +-- `PathNode` and `PathTree` are used as an intermediate form when desugaring a nested object update. +-- For an update such as: +-- +-- x { foo = 0 +-- , bar.baz = 1 +-- , bar.qux = 2 } +-- +-- We represent the updates as the `PathTree`: +-- +-- M.fromList [ ("foo", Leaf 3) +-- , ("bar", Branch (M.fromList [ ("baz", Leaf 1) +-- , ("qux", Leaf 2) ]) ]) +-- +-- Which we then convert to an expression representing the following: +-- +-- let x' = x +-- in x' { foo = 0 +-- , bar = x'.bar { baz = 1 +-- , qux = 2 } } +-- +-- The `let` here is required to prevent re-evaluating the object expression `x`. +-- However we don't generate this when using an anonymous argument for the object. +-- +type PathTree = Map PSString PathNode +data PathNode = Leaf Expr | Branch PathTree desugarObjectConstructors :: forall m @@ -46,6 +75,7 @@ desugarDecl other = fn other obj <- freshIdent' Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps + desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps desugarExpr (Accessor prop u) | Just props <- peelAnonAccessorChain u = do arg <- freshIdent' @@ -62,14 +92,67 @@ desugarDecl other = fn other return $ foldr (Abs . Left) if_ (catMaybes [u', t', f']) desugarExpr e = return e - wrapLambda :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr - wrapLambda mkVal ps = + transformNestedUpdate :: Expr -> [(NonEmpty PSString, Expr)] -> m Expr + transformNestedUpdate obj ps = do + -- If we don't have an anonymous argument then we need to generate a let wrapper + -- so that the object expression isn't re-evaluated for each nested update. + val <- freshIdent' + if isAnonymousArgument obj + then Abs (Left val) <$> wrapLambdaM (build val) ps + else wrapLambdaM (fmap (buildLet val) . build val) ps + where + build val xs = buildUpdates (argToExpr val) <$> foldM buildTree M.empty xs + buildLet val = Let [ValueDeclaration val Public [] (Right obj)] + + -- Here we build up the intermediate `PathTree` data structure and check that + -- the paths are valid relative to each other - for example, the update + -- `{ foo.bar = 2, foo = {bar: 3} }` is invalid because there are conflicting + -- paths. + buildTree + :: PathTree + -> (NonEmpty PSString, Expr) + -> m PathTree + buildTree pathTree (path, e) = go pathTree path where + go tree (key :| []) + -- path already exists + | key `M.member` tree = throwError . errorMessage $ DuplicateLabel (Label key) (Just (ObjectUpdateNested obj ps)) + -- create new path + | otherwise = return (M.insert key (Leaf e) tree) + go tree (key :| (x : xs)) = do + branch <- case M.lookup key tree of + -- nothing at this path yet + Nothing -> return M.empty + -- already a map at this path + Just (Branch branch) -> return branch + -- sub-path already exists + Just (Leaf _) -> throwError . errorMessage $ DuplicateLabel (Label key) (Just (ObjectUpdateNested obj ps)) + M.insert key . Branch <$> go branch (x :| xs) <*> pure tree + + -- Now we have a valid collection of updates in the form of a `PathTree` + -- we can recursively build up the nested `ObjectUpdate` expressions. + buildUpdates :: Expr -> PathTree -> Expr + buildUpdates val vs = ObjectUpdate val (goLayer [] <$> M.toList vs) where + goLayer :: [PSString] -> (PSString, PathNode) -> (PSString, Expr) + goLayer _ (key, Leaf expr) = (key, expr) + goLayer path (key, Branch branch) = + let path' = path ++ [key] + updates = goLayer path' <$> M.toList branch + accessor = foldr Accessor val path' + objectUpdate = ObjectUpdate accessor updates + in (key, objectUpdate) + + wrapLambdaM :: forall k. ([(k, Expr)] -> m Expr) -> [(k, Expr)] -> m Expr + wrapLambdaM mkVal ps = let (args, props) = partition (isAnonymousArgument . snd) ps in if null args - then return $ mkVal props + then mkVal props else do (args', ps') <- unzip <$> mapM mkProp ps - return $ foldr (Abs . Left) (mkVal ps') (catMaybes args') + val <- mkVal ps' + return $ foldr (Abs . Left) val (catMaybes args') + + wrapLambda :: forall k. ([(k, Expr)] -> Expr) -> [(k, Expr)] -> m Expr + wrapLambda mkVal = wrapLambdaM (return . mkVal) stripPositionInfo :: Expr -> Expr stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e @@ -86,7 +169,7 @@ desugarDecl other = fn other isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e isAnonymousArgument _ = False - mkProp :: (PSString, Expr) -> m (Maybe Ident, (PSString, Expr)) + mkProp :: forall k. (k, Expr) -> m (Maybe Ident, (k, Expr)) mkProp (name, e) = do arg <- freshIfAnon e return (arg, (name, maybe e argToExpr arg)) From 1bb6acd9d0867e944386c2cfd91eb9f0e6ce5576 Mon Sep 17 00:00:00 2001 From: Michael Ficarra Date: Sat, 14 Jan 2017 15:31:45 -0800 Subject: [PATCH 0622/1580] remove JSAccessor; replace with JSIndexer (#2554) * fixes #2513: remove JSAccessor; replace with JSIndexer * generate static member accesses when possible (ref #2513) * remove duplicate function isFn --- src/Language/PureScript/CodeGen/JS.hs | 29 +- src/Language/PureScript/CodeGen/JS/AST.hs | 9 - .../PureScript/CodeGen/JS/Optimizer/Common.hs | 17 +- .../CodeGen/JS/Optimizer/Inliner.hs | 130 ++++----- .../CodeGen/JS/Optimizer/MagicDo.hs | 14 +- src/Language/PureScript/Constants.hs | 254 +++++++++--------- src/Language/PureScript/Pretty/JS.hs | 6 +- 7 files changed, 222 insertions(+), 237 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 0abc9de05d..a6adeca931 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -35,7 +35,7 @@ import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..), errorMessage, rethrowWithPosition, addHint) import Language.PureScript.Names import Language.PureScript.Options -import Language.PureScript.PSString (PSString, mkString, decodeString) +import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Traversals (sndM) import qualified Language.PureScript.Constants as C @@ -69,7 +69,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = let standardExps = exps \\ foreignExps let exps' = JSObjectLiteral Nothing $ map (mkString . runIdent &&& JSVar Nothing . identToJs) standardExps ++ map (mkString . runIdent &&& foreignIdent) foreignExps - return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps'] + return $ moduleBody ++ [JSAssignment Nothing (accessorString "exports" (JSVar Nothing "module")) exps'] where @@ -182,12 +182,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = accessor (GenIdent _ _) = internalError "GenIdent in accessor" accessorString :: PSString -> JS -> JS - accessorString prop = - case decodeString prop of - Just s | not (identNeedsEscaping s) -> - JSAccessor Nothing s - _ -> - JSIndexer Nothing (JSStringLiteral Nothing prop) + accessorString prop = JSIndexer Nothing (JSStringLiteral Nothing prop) -- | -- Generate code in the simplified Javascript intermediate representation for a value or expression. @@ -201,9 +196,9 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = valueToJs' (Literal (pos, _, _, _) l) = maybe id rethrowWithPosition pos $ literalToValueJS l valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) = - return $ JSAccessor Nothing "value" $ qualifiedToJS id name + return $ accessorString "value" $ qualifiedToJS id name valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) = - return $ JSAccessor Nothing "create" $ qualifiedToJS id name + return $ accessorString "create" $ qualifiedToJS id name valueToJs' (Accessor _ prop val) = accessorString prop <$> valueToJs val valueToJs' (ObjectUpdate _ o ps) = do @@ -258,17 +253,17 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))]) valueToJs' (Constructor _ _ (ProperName ctor) []) = return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing []) - , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing (properToJs ctor))) + , JSAssignment Nothing (accessorString "value" (JSVar Nothing (properToJs ctor))) (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ] valueToJs' (Constructor _ _ (ProperName ctor) fields) = let constructor = - let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] + let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body) createFn = let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields) in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields in return $ iife (properToJs ctor) [ constructor - , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing (properToJs ctor))) createFn + , JSAssignment Nothing (accessorString "create" (JSVar Nothing (properToJs ctor))) createFn ] iife :: Text -> [JS] -> JS @@ -299,7 +294,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = evaluate = JSVariableIntroduction Nothing evaluatedObj (Just obj) objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing []) copy = JSForIn Nothing key jsEvaluatedObj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing] - cond = JSApp Nothing (JSAccessor Nothing "call" (JSAccessor Nothing "hasOwnProperty" (JSObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey] + cond = JSApp Nothing (accessorString "call" (accessorString "hasOwnProperty" (JSObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey] assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey jsEvaluatedObj)] stToAssign (s, js) = JSAssignment Nothing (accessorString s jsNewObj) js extend = map stToAssign sts @@ -356,7 +351,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = valueError _ l@(JSNumericLiteral _ _) = l valueError _ l@(JSStringLiteral _ _) = l valueError _ l@(JSBooleanLiteral _ _) = l - valueError s _ = JSAccessor Nothing "name" . JSAccessor Nothing "constructor" $ JSVar Nothing s + valueError s _ = accessorString "name" . accessorString "constructor" $ JSVar Nothing s guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS] guardsToJs (Left gs) = forM gs $ \(cond, val) -> do @@ -397,7 +392,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = argVar <- freshName done'' <- go remain done' js <- binderToJs argVar done'' binder - return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (identToJs field) (JSVar Nothing varName))) : js) + return (JSVariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToJs field) $ JSVar Nothing varName) : js) binderToJs' _ _ ConstructorBinder{} = internalError "binderToJs: Invalid ConstructorBinder in binderToJs" binderToJs' varName done (NamedBinder _ ident binder) = do @@ -426,7 +421,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = return (JSVariableIntroduction Nothing propVar (Just (accessorString prop (JSVar Nothing varName))) : js) literalToBinderJS varName done (ArrayLiteral bs) = do js <- go done 0 bs - return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSAccessor Nothing "length" (JSVar Nothing varName)) (JSNumericLiteral Nothing (Left (fromIntegral $ length bs)))) (JSBlock Nothing js) Nothing] + return [JSIfElse Nothing (JSBinary Nothing EqualTo (accessorString "length" (JSVar Nothing varName)) (JSNumericLiteral Nothing (Left (fromIntegral $ length bs)))) (JSBlock Nothing js) Nothing] where go :: [JS] -> Integer -> [Binder Ann] -> m [JS] go done' _ [] = return done' diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index 8f3583c314..a8c196fe90 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -159,10 +159,6 @@ data JS -- | JSObjectLiteral (Maybe SourceSpan) [(PSString, JS)] -- | - -- An object property accessor expression - -- - | JSAccessor (Maybe SourceSpan) Text JS - -- | -- A function introduction (optional name, arguments, body) -- | JSFunction (Maybe SourceSpan) (Maybe Text) [Text] JS @@ -259,7 +255,6 @@ withSourceSpan withSpan = go go (JSArrayLiteral _ js) = JSArrayLiteral ss js go (JSIndexer _ j1 j2) = JSIndexer ss j1 j2 go (JSObjectLiteral _ js) = JSObjectLiteral ss js - go (JSAccessor _ prop j) = JSAccessor ss prop j go (JSFunction _ name args j) = JSFunction ss name args j go (JSApp _ j js) = JSApp ss j js go (JSVar _ s) = JSVar ss s @@ -293,7 +288,6 @@ getSourceSpan = go go (JSArrayLiteral ss _) = ss go (JSIndexer ss _ _) = ss go (JSObjectLiteral ss _) = ss - go (JSAccessor ss _ _) = ss go (JSFunction ss _ _ _) = ss go (JSApp ss _ _) = ss go (JSVar ss _) = ss @@ -328,7 +322,6 @@ everywhereOnJS f = go go (JSArrayLiteral ss js) = f (JSArrayLiteral ss (map go js)) go (JSIndexer ss j1 j2) = f (JSIndexer ss (go j1) (go j2)) go (JSObjectLiteral ss js) = f (JSObjectLiteral ss (map (fmap go) js)) - go (JSAccessor ss prop j) = f (JSAccessor ss prop (go j)) go (JSFunction ss name args j) = f (JSFunction ss name args (go j)) go (JSApp ss j js) = f (JSApp ss (go j) (map go js)) go (JSConditional ss j1 j2 j3) = f (JSConditional ss (go j1) (go j2) (go j3)) @@ -359,7 +352,6 @@ everywhereOnJSTopDownM f = f >=> go go (JSArrayLiteral ss js) = JSArrayLiteral ss <$> traverse f' js go (JSIndexer ss j1 j2) = JSIndexer ss <$> f' j1 <*> f' j2 go (JSObjectLiteral ss js) = JSObjectLiteral ss <$> traverse (sndM f') js - go (JSAccessor ss prop j) = JSAccessor ss prop <$> f' j go (JSFunction ss name args j) = JSFunction ss name args <$> f' j go (JSApp ss j js) = JSApp ss <$> f' j <*> traverse f' js go (JSConditional ss j1 j2 j3) = JSConditional ss <$> f' j1 <*> f' j2 <*> f' j3 @@ -386,7 +378,6 @@ everythingOnJS (<>) f = go go j@(JSArrayLiteral _ js) = foldl (<>) (f j) (map go js) go j@(JSIndexer _ j1 j2) = f j <> go j1 <> go j2 go j@(JSObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js) - go j@(JSAccessor _ _ j1) = f j <> go j1 go j@(JSFunction _ _ _ j1) = f j <> go j1 go j@(JSApp _ j1 js) = foldl (<>) (f j <> go j1) (map go js) go j@(JSConditional _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3 diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs index 3fc9ca30a1..763626a26e 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs @@ -11,7 +11,7 @@ import Data.Maybe (fromMaybe) import Language.PureScript.Crash import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.PSString (mkString) +import Language.PureScript.PSString (PSString) applyAll :: [a -> a] -> a -> a applyAll = foldl' (.) id @@ -55,7 +55,6 @@ isUsed var1 = everythingOnJS (||) check targetVariable :: JS -> Text targetVariable (JSVar _ var) = var -targetVariable (JSAccessor _ _ tgt) = targetVariable tgt targetVariable (JSIndexer _ _ tgt) = targetVariable tgt targetVariable _ = internalError "Invalid argument to targetVariable" @@ -70,16 +69,10 @@ removeFromBlock :: ([JS] -> [JS]) -> JS -> JS removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts) removeFromBlock _ js = js -isFn :: (Text, Text) -> JS -> Bool -isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) = - x == fnName && y == moduleName -isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = - x == mkString fnName && y == moduleName -isFn _ _ = False - -isDict :: (Text, Text) -> JS -> Bool -isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName +isDict :: (Text, PSString) -> JS -> Bool +isDict (moduleName, dictName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = + x == dictName && y == moduleName isDict _ _ = False -isDict' :: [(Text, Text)] -> JS -> Bool +isDict' :: [(Text, PSString)] -> JS -> Bool isDict' xs js = any (`isDict` js) xs diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index fddd6b89dc..b9846e9b02 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -17,9 +17,11 @@ import Control.Monad.Supply.Class (MonadSupply, freshName) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) +import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as T +import Language.PureScript.PSString (PSString) import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Optimizer.Common import qualified Language.PureScript.Constants as C @@ -33,7 +35,6 @@ shouldInline (JSVar _ _) = True shouldInline (JSNumericLiteral _ _) = True shouldInline (JSStringLiteral _ _) = True shouldInline (JSBooleanLiteral _ _) = True -shouldInline (JSAccessor _ _ val) = shouldInline val shouldInline (JSIndexer _ index val) = shouldInline index && shouldInline val shouldInline _ = False @@ -82,17 +83,17 @@ inlineCommonValues = everywhereOnJS convert where convert :: JS -> JS convert (JSApp ss fn [dict]) - | isDict' [semiringNumber, semiringInt] dict && isFn fnZero fn = JSNumericLiteral ss (Left 0) - | isDict' [semiringNumber, semiringInt] dict && isFn fnOne fn = JSNumericLiteral ss (Left 1) - | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral ss False - | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral ss True + | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = JSNumericLiteral ss (Left 0) + | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = JSNumericLiteral ss (Left 1) + | isDict boundedBoolean dict && isDict fnBottom fn = JSBooleanLiteral ss False + | isDict boundedBoolean dict && isDict fnTop fn = JSBooleanLiteral ss True convert (JSApp ss (JSApp _ fn [dict]) [x]) - | isDict ringInt dict && isFn fnNegate fn = JSBinary ss BitwiseOr (JSUnary ss Negate x) (JSNumericLiteral ss (Left 0)) + | isDict ringInt dict && isDict fnNegate fn = JSBinary ss BitwiseOr (JSUnary ss Negate x) (JSNumericLiteral ss (Left 0)) convert (JSApp ss (JSApp _ (JSApp _ fn [dict]) [x]) [y]) - | isDict semiringInt dict && isFn fnAdd fn = intOp ss Add x y - | isDict semiringInt dict && isFn fnMultiply fn = intOp ss Multiply x y - | isDict euclideanRingInt dict && isFn fnDivide fn = intOp ss Divide x y - | isDict ringInt dict && isFn fnSubtract fn = intOp ss Subtract x y + | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add x y + | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply x y + | isDict euclideanRingInt dict && isDict fnDivide fn = intOp ss Divide x y + | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract x y convert other = other fnZero = (C.dataSemiring, C.zero) fnOne = (C.dataSemiring, C.one) @@ -168,29 +169,29 @@ inlineCommonOperators = applyAll $ ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] where - binary :: (Text, Text) -> (Text, Text) -> BinaryOperator -> JS -> JS + binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> JS -> JS binary dict fns op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isFn fns fn = JSBinary ss op x y + convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = JSBinary ss op x y convert other = other - binary' :: Text -> Text -> BinaryOperator -> JS -> JS + binary' :: Text -> PSString -> BinaryOperator -> JS -> JS binary' moduleName opString op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y + convert (JSApp ss (JSApp _ fn [x]) [y]) | isDict (moduleName, opString) fn = JSBinary ss op x y convert other = other - unary :: (Text, Text) -> (Text, Text) -> UnaryOperator -> JS -> JS + unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> JS -> JS unary dicts fns op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isFn fns fn = JSUnary ss op x + convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = JSUnary ss op x convert other = other - unary' :: Text -> Text -> UnaryOperator -> JS -> JS + unary' :: Text -> PSString -> UnaryOperator -> JS -> JS unary' moduleName fnName op = everywhereOnJS convert where convert :: JS -> JS - convert (JSApp ss fn [x]) | isFn (moduleName, fnName) fn = JSUnary ss op x + convert (JSApp ss fn [x]) | isDict (moduleName, fnName) fn = JSUnary ss op x convert other = other mkFn :: Int -> JS -> JS mkFn 0 = everywhereOnJS convert @@ -214,7 +215,8 @@ inlineCommonOperators = applyAll $ isNFn :: Text -> Int -> JS -> Bool isNFn prefix n (JSVar _ name) = name == (prefix <> T.pack (show n)) - isNFn prefix n (JSAccessor _ name (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == (prefix <> T.pack (show n)) + isNFn prefix n (JSIndexer _ (JSStringLiteral _ name) (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = + name == fromString (T.unpack prefix <> show n) isNFn _ _ _ = False runFn :: Int -> JS -> JS @@ -235,12 +237,14 @@ inlineCommonOperators = applyAll $ convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y convert other = other - isModFn :: (Text, Text) -> JS -> Bool - isModFn (m, op) (JSAccessor _ op' (JSVar _ m')) = m == m' && op == op' + isModFn :: (Text, PSString) -> JS -> Bool + isModFn (m, op) (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) = + m == m' && op == op' isModFn _ _ = False - isModFnWithDict :: (Text, Text) -> JS -> Bool - isModFnWithDict (m, op) (JSApp _ (JSAccessor _ op' (JSVar _ m')) [JSVar _ _]) = m == m' && op == op' + isModFnWithDict :: (Text, PSString) -> JS -> Bool + isModFnWithDict (m, op) (JSApp _ (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) [JSVar _ _]) = + m == m' && op == op' isModFnWithDict _ _ = False -- (f <<< g $ x) = f (g x) @@ -261,118 +265,118 @@ inlineFnComposition = everywhereOnJSTopDownM convert return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing y [JSApp Nothing x [JSVar Nothing arg]]]) convert other = return other isFnCompose :: JS -> JS -> Bool - isFnCompose dict' fn = isDict semigroupoidFn dict' && isFn fnCompose fn + isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn isFnComposeFlipped :: JS -> JS -> Bool - isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isFn fnComposeFlipped fn - fnCompose :: (Text, Text) + isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn + fnCompose :: forall a b. (IsString a, IsString b) => (a, b) fnCompose = (C.controlSemigroupoid, C.compose) - fnComposeFlipped :: (Text, Text) + fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b) fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped) -semiringNumber :: (Text, Text) +semiringNumber :: forall a b. (IsString a, IsString b) => (a, b) semiringNumber = (C.dataSemiring, C.semiringNumber) -semiringInt :: (Text, Text) +semiringInt :: forall a b. (IsString a, IsString b) => (a, b) semiringInt = (C.dataSemiring, C.semiringInt) -ringNumber :: (Text, Text) +ringNumber :: forall a b. (IsString a, IsString b) => (a, b) ringNumber = (C.dataRing, C.ringNumber) -ringInt :: (Text, Text) +ringInt :: forall a b. (IsString a, IsString b) => (a, b) ringInt = (C.dataRing, C.ringInt) -euclideanRingNumber :: (Text, Text) +euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b) euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber) -euclideanRingInt :: (Text, Text) +euclideanRingInt :: forall a b. (IsString a, IsString b) => (a, b) euclideanRingInt = (C.dataEuclideanRing, C.euclideanRingInt) -eqNumber :: (Text, Text) +eqNumber :: forall a b. (IsString a, IsString b) => (a, b) eqNumber = (C.dataEq, C.eqNumber) -eqInt :: (Text, Text) +eqInt :: forall a b. (IsString a, IsString b) => (a, b) eqInt = (C.dataEq, C.eqInt) -eqString :: (Text, Text) +eqString :: forall a b. (IsString a, IsString b) => (a, b) eqString = (C.dataEq, C.eqString) -eqChar :: (Text, Text) +eqChar :: forall a b. (IsString a, IsString b) => (a, b) eqChar = (C.dataEq, C.eqChar) -eqBoolean :: (Text, Text) +eqBoolean :: forall a b. (IsString a, IsString b) => (a, b) eqBoolean = (C.dataEq, C.eqBoolean) -ordBoolean :: (Text, Text) +ordBoolean :: forall a b. (IsString a, IsString b) => (a, b) ordBoolean = (C.dataOrd, C.ordBoolean) -ordNumber :: (Text, Text) +ordNumber :: forall a b. (IsString a, IsString b) => (a, b) ordNumber = (C.dataOrd, C.ordNumber) -ordInt :: (Text, Text) +ordInt :: forall a b. (IsString a, IsString b) => (a, b) ordInt = (C.dataOrd, C.ordInt) -ordString :: (Text, Text) +ordString :: forall a b. (IsString a, IsString b) => (a, b) ordString = (C.dataOrd, C.ordString) -ordChar :: (Text, Text) +ordChar :: forall a b. (IsString a, IsString b) => (a, b) ordChar = (C.dataOrd, C.ordChar) -semigroupString :: (Text, Text) +semigroupString :: forall a b. (IsString a, IsString b) => (a, b) semigroupString = (C.dataSemigroup, C.semigroupString) -boundedBoolean :: (Text, Text) +boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b) boundedBoolean = (C.dataBounded, C.boundedBoolean) -heytingAlgebraBoolean :: (Text, Text) +heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b) heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean) -semigroupoidFn :: (Text, Text) +semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b) semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn) -opAdd :: (Text, Text) +opAdd :: forall a b. (IsString a, IsString b) => (a, b) opAdd = (C.dataSemiring, C.add) -opMul :: (Text, Text) +opMul :: forall a b. (IsString a, IsString b) => (a, b) opMul = (C.dataSemiring, C.mul) -opEq :: (Text, Text) +opEq :: forall a b. (IsString a, IsString b) => (a, b) opEq = (C.dataEq, C.eq) -opNotEq :: (Text, Text) +opNotEq :: forall a b. (IsString a, IsString b) => (a, b) opNotEq = (C.dataEq, C.notEq) -opLessThan :: (Text, Text) +opLessThan :: forall a b. (IsString a, IsString b) => (a, b) opLessThan = (C.dataOrd, C.lessThan) -opLessThanOrEq :: (Text, Text) +opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b) opLessThanOrEq = (C.dataOrd, C.lessThanOrEq) -opGreaterThan :: (Text, Text) +opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b) opGreaterThan = (C.dataOrd, C.greaterThan) -opGreaterThanOrEq :: (Text, Text) +opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b) opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq) -opAppend :: (Text, Text) +opAppend :: forall a b. (IsString a, IsString b) => (a, b) opAppend = (C.dataSemigroup, C.append) -opSub :: (Text, Text) +opSub :: forall a b. (IsString a, IsString b) => (a, b) opSub = (C.dataRing, C.sub) -opNegate :: (Text, Text) +opNegate :: forall a b. (IsString a, IsString b) => (a, b) opNegate = (C.dataRing, C.negate) -opDiv :: (Text, Text) +opDiv :: forall a b. (IsString a, IsString b) => (a, b) opDiv = (C.dataEuclideanRing, C.div) -opMod :: (Text, Text) +opMod :: forall a b. (IsString a, IsString b) => (a, b) opMod = (C.dataEuclideanRing, C.mod) -opConj :: (Text, Text) +opConj :: forall a b. (IsString a, IsString b) => (a, b) opConj = (C.dataHeytingAlgebra, C.conj) -opDisj :: (Text, Text) +opDisj :: forall a b. (IsString a, IsString b) => (a, b) opDisj = (C.dataHeytingAlgebra, C.disj) -opNot :: (Text, Text) +opNot :: forall a b. (IsString a, IsString b) => (a, b) opNot = (C.dataHeytingAlgebra, C.not) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs index bb37d2c413..0d545a83c2 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs @@ -64,11 +64,11 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert isPure (JSApp _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True isPure _ = False -- Check if an expression represents the polymorphic >>= function - isBindPoly = isFn (C.controlBind, C.bind) + isBindPoly = isDict (C.controlBind, C.bind) -- Check if an expression represents the polymorphic pure or return function - isPurePoly = isFn (C.controlApplicative, C.pure') + isPurePoly = isDict (C.controlApplicative, C.pure') -- Check if an expression represents a function in the Eff module - isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name' + isEffFunc name (JSIndexer _ (JSStringLiteral _ name') (JSVar _ eff)) = eff == C.eff && name == name' isEffFunc _ _ = False -- Remove __do function applications which remain after desugaring @@ -107,14 +107,14 @@ inlineST = everywhereOnJS convertBlock convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f = JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(mkString C.stRefValue, arg)]]) convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f = - if agg then ref else JSAccessor s1 C.stRefValue ref + if agg then ref else JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f = - if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) arg + if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref) arg convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f = - if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) (JSApp s1 func [JSAccessor s1 C.stRefValue ref]) + if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref) (JSApp s1 func [JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref]) convert _ other = other -- Check if an expression represents a function in the ST module - isSTFunc name (JSAccessor _ name' (JSVar _ st)) = st == C.st && name == name' + isSTFunc name (JSIndexer _ (JSStringLiteral _ name') (JSVar _ st)) = st == C.st && name == name' isSTFunc _ _ = False -- Find all ST Refs initialized in this block findSTRefsIn = everythingOnJS (++) isSTRef diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 3d9351dace..b2d12e7409 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -2,319 +2,319 @@ module Language.PureScript.Constants where import Prelude.Compat -import Data.Text (Text) +import Data.String (IsString) import Language.PureScript.Names -- Operators -($) :: Text +($) :: forall a. (IsString a) => a ($) = "$" -apply :: Text +apply :: forall a. (IsString a) => a apply = "apply" -(#) :: Text +(#) :: forall a. (IsString a) => a (#) = "#" -applyFlipped :: Text +applyFlipped :: forall a. (IsString a) => a applyFlipped = "applyFlipped" -(<>) :: Text +(<>) :: forall a. (IsString a) => a (<>) = "<>" -(++) :: Text +(++) :: forall a. (IsString a) => a (++) = "++" -append :: Text +append :: forall a. (IsString a) => a append = "append" -(>>=) :: Text +(>>=) :: forall a. (IsString a) => a (>>=) = ">>=" -bind :: Text +bind :: forall a. (IsString a) => a bind = "bind" -(+) :: Text +(+) :: forall a. (IsString a) => a (+) = "+" -add :: Text +add :: forall a. (IsString a) => a add = "add" -(-) :: Text +(-) :: forall a. (IsString a) => a (-) = "-" -sub :: Text +sub :: forall a. (IsString a) => a sub = "sub" -(*) :: Text +(*) :: forall a. (IsString a) => a (*) = "*" -mul :: Text +mul :: forall a. (IsString a) => a mul = "mul" -(/) :: Text +(/) :: forall a. (IsString a) => a (/) = "/" -div :: Text +div :: forall a. (IsString a) => a div = "div" -(%) :: Text +(%) :: forall a. (IsString a) => a (%) = "%" -mod :: Text +mod :: forall a. (IsString a) => a mod = "mod" -(<) :: Text +(<) :: forall a. (IsString a) => a (<) = "<" -lessThan :: Text +lessThan :: forall a. (IsString a) => a lessThan = "lessThan" -(>) :: Text +(>) :: forall a. (IsString a) => a (>) = ">" -greaterThan :: Text +greaterThan :: forall a. (IsString a) => a greaterThan = "greaterThan" -(<=) :: Text +(<=) :: forall a. (IsString a) => a (<=) = "<=" -lessThanOrEq :: Text +lessThanOrEq :: forall a. (IsString a) => a lessThanOrEq = "lessThanOrEq" -(>=) :: Text +(>=) :: forall a. (IsString a) => a (>=) = ">=" -greaterThanOrEq :: Text +greaterThanOrEq :: forall a. (IsString a) => a greaterThanOrEq = "greaterThanOrEq" -(==) :: Text +(==) :: forall a. (IsString a) => a (==) = "==" -eq :: Text +eq :: forall a. (IsString a) => a eq = "eq" -(/=) :: Text +(/=) :: forall a. (IsString a) => a (/=) = "/=" -notEq :: Text +notEq :: forall a. (IsString a) => a notEq = "notEq" -compare :: Text +compare :: forall a. (IsString a) => a compare = "compare" -(&&) :: Text +(&&) :: forall a. (IsString a) => a (&&) = "&&" -conj :: Text +conj :: forall a. (IsString a) => a conj = "conj" -(||) :: Text +(||) :: forall a. (IsString a) => a (||) = "||" -disj :: Text +disj :: forall a. (IsString a) => a disj = "disj" -unsafeIndex :: Text +unsafeIndex :: forall a. (IsString a) => a unsafeIndex = "unsafeIndex" -or :: Text +or :: forall a. (IsString a) => a or = "or" -and :: Text +and :: forall a. (IsString a) => a and = "and" -xor :: Text +xor :: forall a. (IsString a) => a xor = "xor" -(<<<) :: Text +(<<<) :: forall a. (IsString a) => a (<<<) = "<<<" -compose :: Text +compose :: forall a. (IsString a) => a compose = "compose" -(>>>) :: Text +(>>>) :: forall a. (IsString a) => a (>>>) = ">>>" -composeFlipped :: Text +composeFlipped :: forall a. (IsString a) => a composeFlipped = "composeFlipped" -map :: Text +map :: forall a. (IsString a) => a map = "map" -- Functions -negate :: Text +negate :: forall a. (IsString a) => a negate = "negate" -not :: Text +not :: forall a. (IsString a) => a not = "not" -shl :: Text +shl :: forall a. (IsString a) => a shl = "shl" -shr :: Text +shr :: forall a. (IsString a) => a shr = "shr" -zshr :: Text +zshr :: forall a. (IsString a) => a zshr = "zshr" -complement :: Text +complement :: forall a. (IsString a) => a complement = "complement" -- Prelude Values -zero :: Text +zero :: forall a. (IsString a) => a zero = "zero" -one :: Text +one :: forall a. (IsString a) => a one = "one" -bottom :: Text +bottom :: forall a. (IsString a) => a bottom = "bottom" -top :: Text +top :: forall a. (IsString a) => a top = "top" -return :: Text +return :: forall a. (IsString a) => a return = "return" -pure' :: Text +pure' :: forall a. (IsString a) => a pure' = "pure" -returnEscaped :: Text +returnEscaped :: forall a. (IsString a) => a returnEscaped = "$return" -untilE :: Text +untilE :: forall a. (IsString a) => a untilE = "untilE" -whileE :: Text +whileE :: forall a. (IsString a) => a whileE = "whileE" -runST :: Text +runST :: forall a. (IsString a) => a runST = "runST" -stRefValue :: Text +stRefValue :: forall a. (IsString a) => a stRefValue = "value" -newSTRef :: Text +newSTRef :: forall a. (IsString a) => a newSTRef = "newSTRef" -readSTRef :: Text +readSTRef :: forall a. (IsString a) => a readSTRef = "readSTRef" -writeSTRef :: Text +writeSTRef :: forall a. (IsString a) => a writeSTRef = "writeSTRef" -modifySTRef :: Text +modifySTRef :: forall a. (IsString a) => a modifySTRef = "modifySTRef" -mkFn :: Text +mkFn :: forall a. (IsString a) => a mkFn = "mkFn" -runFn :: Text +runFn :: forall a. (IsString a) => a runFn = "runFn" -unit :: Text +unit :: forall a. (IsString a) => a unit = "unit" -- Prim values -undefined :: Text +undefined :: forall a. (IsString a) => a undefined = "undefined" -- Type Class Dictionary Names -monadEffDictionary :: Text +monadEffDictionary :: forall a. (IsString a) => a monadEffDictionary = "monadEff" -applicativeEffDictionary :: Text +applicativeEffDictionary :: forall a. (IsString a) => a applicativeEffDictionary = "applicativeEff" -bindEffDictionary :: Text +bindEffDictionary :: forall a. (IsString a) => a bindEffDictionary = "bindEff" -semiringNumber :: Text +semiringNumber :: forall a. (IsString a) => a semiringNumber = "semiringNumber" -semiringInt :: Text +semiringInt :: forall a. (IsString a) => a semiringInt = "semiringInt" -ringNumber :: Text +ringNumber :: forall a. (IsString a) => a ringNumber = "ringNumber" -ringInt :: Text +ringInt :: forall a. (IsString a) => a ringInt = "ringInt" -moduloSemiringNumber :: Text +moduloSemiringNumber :: forall a. (IsString a) => a moduloSemiringNumber = "moduloSemiringNumber" -moduloSemiringInt :: Text +moduloSemiringInt :: forall a. (IsString a) => a moduloSemiringInt = "moduloSemiringInt" -euclideanRingNumber :: Text +euclideanRingNumber :: forall a. (IsString a) => a euclideanRingNumber = "euclideanRingNumber" -euclideanRingInt :: Text +euclideanRingInt :: forall a. (IsString a) => a euclideanRingInt = "euclideanRingInt" -ordBoolean :: Text +ordBoolean :: forall a. (IsString a) => a ordBoolean = "ordBoolean" -ordNumber :: Text +ordNumber :: forall a. (IsString a) => a ordNumber = "ordNumber" -ordInt :: Text +ordInt :: forall a. (IsString a) => a ordInt = "ordInt" -ordString :: Text +ordString :: forall a. (IsString a) => a ordString = "ordString" -ordChar :: Text +ordChar :: forall a. (IsString a) => a ordChar = "ordChar" -eqNumber :: Text +eqNumber :: forall a. (IsString a) => a eqNumber = "eqNumber" -eqInt :: Text +eqInt :: forall a. (IsString a) => a eqInt = "eqInt" -eqString :: Text +eqString :: forall a. (IsString a) => a eqString = "eqString" -eqChar :: Text +eqChar :: forall a. (IsString a) => a eqChar = "eqChar" -eqBoolean :: Text +eqBoolean :: forall a. (IsString a) => a eqBoolean = "eqBoolean" -boundedBoolean :: Text +boundedBoolean :: forall a. (IsString a) => a boundedBoolean = "boundedBoolean" -booleanAlgebraBoolean :: Text +booleanAlgebraBoolean :: forall a. (IsString a) => a booleanAlgebraBoolean = "booleanAlgebraBoolean" -heytingAlgebraBoolean :: Text +heytingAlgebraBoolean :: forall a. (IsString a) => a heytingAlgebraBoolean = "heytingAlgebraBoolean" -semigroupString :: Text +semigroupString :: forall a. (IsString a) => a semigroupString = "semigroupString" -semigroupoidFn :: Text +semigroupoidFn :: forall a. (IsString a) => a semigroupoidFn = "semigroupoidFn" -- Generic Deriving -generic :: Text +generic :: forall a. (IsString a) => a generic = "Generic" -toSpine :: Text +toSpine :: forall a. (IsString a) => a toSpine = "toSpine" -fromSpine :: Text +fromSpine :: forall a. (IsString a) => a fromSpine = "fromSpine" -toSignature :: Text +toSignature :: forall a. (IsString a) => a toSignature = "toSignature" -- Data.Symbol @@ -352,12 +352,12 @@ orderingGT = Qualified (Just typeDataOrdering) (ProperName "GT") -- Main module -main :: Text +main :: forall a. (IsString a) => a main = "main" -- Prim -partial :: Text +partial :: forall a. (IsString a) => a partial = "Partial" pattern Prim :: ModuleName @@ -369,78 +369,78 @@ pattern Partial = Qualified (Just Prim) (ProperName "Partial") pattern Fail :: Qualified (ProperName 'ClassName) pattern Fail = Qualified (Just Prim) (ProperName "Fail") -typ :: Text +typ :: forall a. (IsString a) => a typ = "Type" -effect :: Text +effect :: forall a. (IsString a) => a effect = "Effect" -symbol :: Text +symbol :: forall a. (IsString a) => a symbol = "Symbol" -- Code Generation -__superclass_ :: Text +__superclass_ :: forall a. (IsString a) => a __superclass_ = "__superclass_" -__unused :: Text +__unused :: forall a. (IsString a) => a __unused = "__unused" -- Modules -prim :: Text +prim :: forall a. (IsString a) => a prim = "Prim" -prelude :: Text +prelude :: forall a. (IsString a) => a prelude = "Prelude" -dataArray :: Text +dataArray :: forall a. (IsString a) => a dataArray = "Data_Array" -eff :: Text +eff :: forall a. (IsString a) => a eff = "Control_Monad_Eff" -st :: Text +st :: forall a. (IsString a) => a st = "Control_Monad_ST" -controlApplicative :: Text +controlApplicative :: forall a. (IsString a) => a controlApplicative = "Control_Applicative" -controlSemigroupoid :: Text +controlSemigroupoid :: forall a. (IsString a) => a controlSemigroupoid = "Control_Semigroupoid" -controlBind :: Text +controlBind :: forall a. (IsString a) => a controlBind = "Control_Bind" -dataBounded :: Text +dataBounded :: forall a. (IsString a) => a dataBounded = "Data_Bounded" -dataSemigroup :: Text +dataSemigroup :: forall a. (IsString a) => a dataSemigroup = "Data_Semigroup" -dataHeytingAlgebra :: Text +dataHeytingAlgebra :: forall a. (IsString a) => a dataHeytingAlgebra = "Data_HeytingAlgebra" -dataEq :: Text +dataEq :: forall a. (IsString a) => a dataEq = "Data_Eq" -dataOrd :: Text +dataOrd :: forall a. (IsString a) => a dataOrd = "Data_Ord" -dataSemiring :: Text +dataSemiring :: forall a. (IsString a) => a dataSemiring = "Data_Semiring" -dataRing :: Text +dataRing :: forall a. (IsString a) => a dataRing = "Data_Ring" -dataEuclideanRing :: Text +dataEuclideanRing :: forall a. (IsString a) => a dataEuclideanRing = "Data_EuclideanRing" -dataFunction :: Text +dataFunction :: forall a. (IsString a) => a dataFunction = "Data_Function" -dataFunctionUncurried :: Text +dataFunctionUncurried :: forall a. (IsString a) => a dataFunctionUncurried = "Data_Function_Uncurried" -dataIntBits :: Text +dataIntBits :: forall a. (IsString a) => a dataIntBits = "Data_Int_Bits" diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 0015933622..1d1191dad9 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -162,8 +162,10 @@ conditional = mkPattern match accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS) accessor = mkPattern match where - -- WARN: if `prop` does not match the `IdentifierName` grammar, this will generate invalid code; see #2513 - match (JSAccessor _ prop val) = Just (emit prop, val) + match (JSIndexer _ (JSStringLiteral _ prop) val) = + case decodeString prop of + Just s | not (identNeedsEscaping s) -> Just (emit s, val) + _ -> Nothing match _ = Nothing indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS) From b70aabf1f4b75efb151ca2eabdd45d8d600db0b1 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sun, 15 Jan 2017 01:00:02 +0000 Subject: [PATCH 0623/1580] Add support for user defined warnings via the Warn type class (#2569) * Add support for user defined warnings via the Warn type class * Deal with failing to print the type string --- examples/warning/CustomWarning.purs | 9 +++++++++ src/Language/PureScript/AST/Declarations.hs | 2 ++ src/Language/PureScript/Constants.hs | 3 +++ src/Language/PureScript/Docs/Prim.hs | 9 +++++++++ src/Language/PureScript/Environment.hs | 9 ++++++--- src/Language/PureScript/Errors.hs | 7 +++++++ .../PureScript/TypeChecker/Entailment.hs | 20 +++++++++++++------ 7 files changed, 50 insertions(+), 9 deletions(-) create mode 100644 examples/warning/CustomWarning.purs diff --git a/examples/warning/CustomWarning.purs b/examples/warning/CustomWarning.purs new file mode 100644 index 0000000000..25540c66d1 --- /dev/null +++ b/examples/warning/CustomWarning.purs @@ -0,0 +1,9 @@ +-- @shouldWarnWith UserDefinedWarning +module Main where + +foo :: forall t. Warn (TypeConcat "Custom warning " (TypeString t)) => t -> t +foo x = x + +bar :: Int +bar = foo 42 + diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 170bddbe9f..af341be4d2 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -141,6 +141,8 @@ data SimpleErrorMessage | CannotUseBindWithDo -- | instance name, type class, expected argument count, actual argument count | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int + -- | a user-defined warning raised by using the Warn type class + | UserDefinedWarning Type deriving (Show) -- | Error message hints, providing more detailed information about failure. diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index b2d12e7409..4667e8d65e 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -369,6 +369,9 @@ pattern Partial = Qualified (Just Prim) (ProperName "Partial") pattern Fail :: Qualified (ProperName 'ClassName) pattern Fail = Qualified (Just Prim) (ProperName "Fail") +pattern Warn :: Qualified (ProperName 'ClassName) +pattern Warn = Qualified (Just Prim) (ProperName "Warn") + typ :: forall a. (IsString a) => a typ = "Type" diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 41b53dce3c..ba4d0e6ee4 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -24,6 +24,7 @@ primDocsModule = Module , boolean , partial , fail + , warn , typeConcat , typeString , kindType @@ -225,6 +226,14 @@ fail = primClass "Fail" $ T.unlines , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." ] +warn :: Declaration +warn = primClass "Warn" $ T.unlines + [ "The Warn type class allows a custom compiler warning to be displayed." + , "" + , "For more information, see" + , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." + ] + typeConcat :: Declaration typeConcat = primType "TypeConcat" $ T.unlines [ "The TypeConcat type constructor concatenates two Symbols in a custom type" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index a62315fd5f..86b3fec43b 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -347,7 +347,7 @@ primKinds = -- | -- The primitive types in the external javascript environment with their --- associated kinds. There are also pseudo `Fail` and `Partial` types +-- associated kinds. There are also pseudo `Fail`, `Warn`, and `Partial` types -- that correspond to the classes with the same names. -- primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) @@ -363,20 +363,23 @@ primTypes = , (primName "Boolean", (kindType, ExternData)) , (primName "Partial", (kindType, ExternData)) , (primName "Fail", (FunKind kindSymbol kindType, ExternData)) + , (primName "Warn", (FunKind kindSymbol kindType, ExternData)) , (primName "TypeString", (FunKind kindType kindSymbol, ExternData)) , (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData)) ] -- | --- The primitive class map. This just contains the `Fail` and `Partial` +-- The primitive class map. This just contains the `Fail`, `Warn`, and `Partial` -- classes. `Partial` is used as a kind of magic constraint for partial --- functions. `Fail` is used for user-defined type errors. +-- functions. `Fail` is used for user-defined type errors. `Warn` for +-- user-defined warnings. -- primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses = M.fromList [ (primName "Partial", (makeTypeClassData [] [] [] [])) , (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] [])) + , (primName "Warn", (makeTypeClassData [("message", Just kindSymbol)] [] [] [])) ] -- | diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 07d8de18a9..1e048826e4 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -173,6 +173,7 @@ errorCode em = case unwrapErrorMessage em of ExpectedWildcard{} -> "ExpectedWildcard" CannotUseBindWithDo{} -> "CannotUseBindWithDo" ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch" + UserDefinedWarning{} -> "UserDefinedWarning" -- | -- A stack trace for an error @@ -889,6 +890,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS T.pack (show actual) <> "." ] + renderSimpleErrorMessage (UserDefinedWarning msgTy) = + let msg = fromMaybe (typeAsBox msgTy) (toTypelevelString msgTy) in + paras [ line "A custom warning occurred while solving type class constraints:" + , indent msg + ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index e5e33cbb9c..8d5d177395 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -45,6 +45,8 @@ import qualified Language.PureScript.Constants as C data Evidence = NamedInstance (Qualified Ident) -- ^ An existing named instance + | WarnInstance Type + -- ^ Computed instance of the Warn type class with a user-defined warning message | IsSymbolInstance PSString -- ^ Computed instance of the IsSymbol type class for a given Symbol literal | CompareSymbolInstance @@ -144,6 +146,8 @@ entails SolverOptions{..} constraint context hints = solve constraint where forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict] + forClassName _ C.Warn [msg] = + [TypeClassDictionaryInScope (WarnInstance msg) [] C.Warn [msg] Nothing] forClassName _ C.IsSymbol [TypeLevelString sym] = [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing] forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = @@ -216,8 +220,9 @@ entails SolverOptions{..} constraint context hints = let subst'' = fmap (substituteType currentSubst') subst' -- Solve any necessary subgoals args <- solveSubgoals subst'' (tcdDependencies tcd) + initDict <- lift . lift $ mkDictionary (tcdValue tcd) args let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index) - (mkDictionary (tcdValue tcd) args) + initDict (tcdPath tcd) return match Unsolved unsolved -> do @@ -308,15 +313,18 @@ entails SolverOptions{..} constraint context hints = Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals -- Make a dictionary from subgoal dictionaries by applying the correct function - mkDictionary :: Evidence -> Maybe [Expr] -> Expr - mkDictionary (NamedInstance n) args = foldl App (Var n) (fold args) + mkDictionary :: Evidence -> Maybe [Expr] -> m Expr + mkDictionary (NamedInstance n) args = return $ foldl App (Var n) (fold args) + mkDictionary (WarnInstance msg) _ = do + tell . errorMessage $ UserDefinedWarning msg + return $ TypeClassDictionaryConstructorApp C.Warn (Literal (ObjectLiteral [])) mkDictionary (IsSymbolInstance sym) _ = let fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) ] in - TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) + return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) mkDictionary CompareSymbolInstance _ = - TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral [])) + return $ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral [])) mkDictionary AppendSymbolInstance _ = - TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral [])) + return $ TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral [])) -- Turn a DictionaryValue into a Expr subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr From 619d651431de966f8b40d4aa1311caa5e20f11fc Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 16 Jan 2017 12:01:57 -0800 Subject: [PATCH 0624/1580] Fix #2578, defer warnings from typeDictionaryForBindingGroup call. --- src/Language/PureScript/TypeChecker/Types.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 22917e07a7..a8a56df171 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -77,11 +77,11 @@ typesOf -> [(Ident, Expr)] -> m [(Ident, (Expr, Type))] typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do - tys <- capturingSubstitution tidyUp $ do - SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup (Just moduleName) vals + (tys, wInfer) <- capturingSubstitution tidyUp $ do + (SplitBindingGroup untyped typed dict, w) <- withoutWarnings $ typeDictionaryForBindingGroup (Just moduleName) vals ds1 <- parU typed $ \e -> withoutWarnings $ checkTypedBindingGroupElement moduleName e dict ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict - return (map (False, ) ds1 ++ map (True, ) ds2) + return (map (False, ) ds1 ++ map (True, ) ds2, w) inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do -- Replace type class dictionary placeholders with actual dictionaries @@ -123,10 +123,13 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -- Show warnings here, since types in wildcards might have been solved during -- instance resolution (by functional dependencies). finalState <- get + let replaceTypes' = replaceTypes (checkSubstitution finalState) + runTypeSearch' gen = runTypeSearch (guard gen $> foldMap snd inferred) finalState + raisePreviousWarnings gen w = (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceTypes')) w + + raisePreviousWarnings False wInfer forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do - let replaceTypes' = replaceTypes (checkSubstitution finalState) - runTypeSearch' = runTypeSearch (guard shouldGeneralize $> foldMap snd inferred) finalState - (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' . replaceTypes')) w + raisePreviousWarnings shouldGeneralize w return (map fst inferred) where @@ -160,7 +163,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do constrain cs = ConstrainedType (map (\(_, _, x) -> x) cs) -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values - tidyUp ts sub = map (second (first (second (overTypes (substituteType sub) *** substituteType sub)))) ts + tidyUp ts sub = first (map (second (first (second (overTypes (substituteType sub) *** substituteType sub))))) ts isHoleError :: ErrorMessage -> Bool isHoleError (ErrorMessage _ HoleInferredType{}) = True From 519216527ddb78d2b179ad7d3eeb1a743fd8c771 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 18 Jan 2017 08:21:17 +0100 Subject: [PATCH 0625/1580] [psc-ide] Log failing to accept or parse an incoming command --- psc-ide-server/Main.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 7bdb9b6671..222203d570 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -130,9 +130,9 @@ startServer port env = withSocketsDo $ do where loop :: (Ide m, MonadLogger m) => Socket -> m () loop sock = do - accepted <- runExceptT $ acceptCommand sock + accepted <- runExceptT (acceptCommand sock) case accepted of - Left err -> $(logDebug) err + Left err -> $(logError) err Right (cmd, h) -> do case decodeT cmd of Just cmd' -> do @@ -147,7 +147,7 @@ startServer port env = withSocketsDo $ do Right r -> liftIO $ BS8.hPutStrLn h (Aeson.encode r) Left err -> liftIO $ BS8.hPutStrLn h (Aeson.encode err) Nothing -> do - $(logDebug) ("Parsing the command failed. Command: " <> cmd) + $(logError) ("Parsing the command failed. Command: " <> cmd) liftIO $ do T.hPutStrLn h (encodeT (GeneralError "Error parsing Command.")) hFlush stdout @@ -167,7 +167,7 @@ acceptCommand sock = do case cmd' of Nothing -> throwError "Connection was closed before any input arrived" Just cmd -> do - $(logDebug) cmd + $(logDebug) ("Received command: " <> cmd) pure (cmd, h) where acceptConnection = liftIO $ do From 5b3b7596ea9c5ed24aab534f1331d4e57d44f492 Mon Sep 17 00:00:00 2001 From: Michael Ficarra Date: Wed, 18 Jan 2017 19:29:20 -0800 Subject: [PATCH 0626/1580] fixes #2581: generate JS static member accesses whenever possible --- src/Language/PureScript/Pretty/JS.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 1d1191dad9..175520756e 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -159,12 +159,12 @@ conditional = mkPattern match match (JSConditional ss cond th el) = Just ((ss, th, el), cond) match _ = Nothing -accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS) +accessor :: Pattern PrinterState JS (Text, JS) accessor = mkPattern match where match (JSIndexer _ (JSStringLiteral _ prop) val) = case decodeString prop of - Just s | not (identNeedsEscaping s) -> Just (emit s, val) + Just s | not (identNeedsEscaping s) -> Just (s, val) _ -> Nothing match _ = Nothing @@ -259,8 +259,8 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue) operators :: (Emit gen) => OperatorTable PrinterState JS gen operators = - OperatorTable [ [ Wrap accessor $ \prop val -> val <> emit "." <> prop ] - , [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ] + OperatorTable [ [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ] + , [ Wrap accessor $ \prop val -> val <> emit "." <> emit prop ] , [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ] , [ unary JSNew "new " ] , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <> From 94710ed1972fa9b53e8bb978095d81d831dde7c3 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 20 Jan 2017 09:40:14 -0800 Subject: [PATCH 0627/1580] Require dependencies to exist during sorting phase (#2570) * Fix #1921, require dependencies to exist during sorting phase * Fix test * Fix tests * Use ordNub --- examples/failing/ImportModule.purs | 2 +- src/Language/PureScript/AST/Declarations.hs | 3 +- src/Language/PureScript/Errors.hs | 145 +++++++-------- src/Language/PureScript/Make.hs | 167 +++++++++--------- src/Language/PureScript/ModuleDependencies.hs | 118 +++++-------- tests/Language/PureScript/Ide/Integration.hs | 2 +- 6 files changed, 188 insertions(+), 249 deletions(-) diff --git a/examples/failing/ImportModule.purs b/examples/failing/ImportModule.purs index ba3da26ecf..a996fbcf95 100644 --- a/examples/failing/ImportModule.purs +++ b/examples/failing/ImportModule.purs @@ -1,4 +1,4 @@ --- @shouldFailWith UnknownName +-- @shouldFailWith ModuleNotFound module Main where import M1 diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index af341be4d2..415d26004d 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -44,7 +44,8 @@ data TypeSearch -- | A type of error messages data SimpleErrorMessage - = ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) + = ModuleNotFound ModuleName + | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) | ErrorParsingModule P.ParseError | MissingFFIModule ModuleName | MultipleFFIModules ModuleName [FilePath] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 1e048826e4..764d5bacb9 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -6,44 +6,40 @@ module Language.PureScript.Errors , module Language.PureScript.Errors ) where -import Prelude.Compat - -import Control.Arrow ((&&&)) -import Control.Monad -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Trans.State.Lazy -import Control.Monad.Writer - -import Data.Char (isSpace) -import Data.Either (lefts, rights) -import Data.Foldable (fold) -import Data.Functor.Identity (Identity(..)) -import Data.List (transpose, nub, nubBy, sortBy, partition) -import Data.Maybe (maybeToList, fromMaybe, mapMaybe) -import Data.Ord (comparing) +import Prelude.Compat + +import Control.Arrow ((&&&)) +import Control.Monad +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Trans.State.Lazy +import Control.Monad.Writer +import Data.Char (isSpace) +import Data.Either (lefts, rights) +import Data.Foldable (fold) +import Data.Functor.Identity (Identity(..)) +import Data.List (transpose, nub, nubBy, sortBy, partition) +import Data.Maybe (maybeToList, fromMaybe, mapMaybe) +import Data.Ord (comparing) import qualified Data.Map as M import qualified Data.Text as T -import Data.Text (Text) - -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Names -import Language.PureScript.Pretty -import Language.PureScript.Traversals -import Language.PureScript.Types -import Language.PureScript.Label (Label(..)) -import Language.PureScript.Pretty.Common (before, endWith) +import Data.Text (Text) +import Language.PureScript.AST import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.Constants as C - +import Language.PureScript.Crash +import Language.PureScript.Environment +import Language.PureScript.Label (Label(..)) +import Language.PureScript.Names +import Language.PureScript.Pretty +import Language.PureScript.Pretty.Common (before, endWith) +import Language.PureScript.Traversals +import Language.PureScript.Types +import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers import qualified System.Console.ANSI as ANSI - import qualified Text.Parsec as P import qualified Text.Parsec.Error as PE +import Text.Parsec.Error (Message(..)) import qualified Text.PrettyPrint.Boxes as Box -import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers -import Text.Parsec.Error (Message(..)) newtype ErrorSuggestion = ErrorSuggestion Text @@ -72,11 +68,10 @@ stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldSt shouldStrip (PositionedError _) = True shouldStrip _ = False --- | --- Get the error code for a particular error type --- +-- | Get the error code for a particular error type errorCode :: ErrorMessage -> Text errorCode em = case unwrapErrorMessage em of + ModuleNotFound{} -> "ModuleNotFound" ErrorParsingFFIModule{} -> "ErrorParsingFFIModule" ErrorParsingModule{} -> "ErrorParsingModule" MissingFFIModule{} -> "MissingFFIModule" @@ -175,25 +170,20 @@ errorCode em = case unwrapErrorMessage em of ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch" UserDefinedWarning{} -> "UserDefinedWarning" --- | --- A stack trace for an error --- +-- | A stack trace for an error newtype MultipleErrors = MultipleErrors - { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid) + { runMultipleErrors :: [ErrorMessage] + } deriving (Show, Monoid) -- | Check whether a collection of errors is empty or not. nonEmpty :: MultipleErrors -> Bool nonEmpty = not . null . runMultipleErrors --- | --- Create an error set from a single simple error message --- +-- | Create an error set from a single simple error message errorMessage :: SimpleErrorMessage -> MultipleErrors errorMessage err = MultipleErrors [ErrorMessage [] err] --- | --- Create an error set from a single error message --- +-- | Create an error set from a single error message singleError :: ErrorMessage -> MultipleErrors singleError = MultipleErrors . pure @@ -226,15 +216,12 @@ defaultUnknownMap = TypeMap M.empty M.empty 0 -- | How critical the issue is data Level = Error | Warning deriving Show --- | --- Extract nested error messages from wrapper errors --- +-- | Extract nested error messages from wrapper errors unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage unwrapErrorMessage (ErrorMessage _ se) = se replaceUnknowns :: Type -> State TypeMap Type -replaceUnknowns = everywhereOnTypesM replaceTypes - where +replaceUnknowns = everywhereOnTypesM replaceTypes where replaceTypes :: Type -> State TypeMap Type replaceTypes (TUnknown u) = do m <- get @@ -387,10 +374,7 @@ defaultPPEOptions = PPEOptions , ppeShowDocs = True } - --- | --- Pretty print a single error, simplifying if necessary --- +-- | Pretty print a single error, simplifying if necessary prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalState defaultUnknownMap $ do em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) @@ -431,6 +415,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS unknownInfo u = line $ markCode ("t" <> T.pack (show u)) <> " is an unknown type" renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box + renderSimpleErrorMessage (ModuleNotFound mn) = + paras [ line $ "Module " <> markCode (runModuleName mn) <> " was not found." + , line "Make sure the source file exists, and that it has been provided as an input to psc." + ] renderSimpleErrorMessage (CannotGetFileInfo path) = paras [ line "Unable to read file info: " , indent . lineS $ path @@ -1176,15 +1164,11 @@ prettyPrintRef (ReExportRef _ _) = prettyPrintRef (PositionedDeclarationRef _ _ ref) = prettyPrintRef ref --- | --- Pretty print multiple errors --- +-- | Pretty print multiple errors prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String prettyPrintMultipleErrors ppeOptions = unlines . map renderBox . prettyPrintMultipleErrorsBox ppeOptions --- | --- Pretty print multiple warnings --- +-- | Pretty print multiple warnings prettyPrintMultipleWarnings :: PPEOptions -> MultipleErrors -> String prettyPrintMultipleWarnings ppeOptions = unlines . map renderBox . prettyPrintMultipleWarningsBox ppeOptions @@ -1215,11 +1199,10 @@ prettyPrintMultipleErrorsWith ppeOptions _ intro (MultipleErrors es) = prettyPrintParseError :: P.ParseError -> Box.Box prettyPrintParseError = prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . PE.errorMessages --- | --- Pretty print ParseError detail messages. --- --- Adapted from 'Text.Parsec.Error.showErrorMessages', see . +-- | Pretty print 'ParseError' detail messages. -- +-- Adapted from 'Text.Parsec.Error.showErrorMessages'. +-- See . prettyPrintParseErrorMessages :: String -> String -> String -> String -> String -> [Message] -> Box.Box prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs | null msgs = Box.text msgUnknown @@ -1288,9 +1271,7 @@ toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret) | f == primName "TypeConcat" = before <$> (toTypelevelString x) <*> (toTypelevelString ret) toTypelevelString _ = Nothing --- | --- Rethrow an error with a more detailed error message in the case of failure --- +-- | Rethrow an error with a more detailed error message in the case of failure rethrow :: (MonadError e m) => (e -> e) -> m a -> m a rethrow f = flip catchError $ \e -> throwError (f e) @@ -1303,9 +1284,7 @@ reflectErrors ma = ma >>= either throwError return warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a warnAndRethrow f = rethrow f . censor f --- | --- Rethrow an error with source position information --- +-- | Rethrow an error with source position information rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a rethrowWithPosition pos = rethrow (onErrorMessages (withPosition pos)) @@ -1318,10 +1297,8 @@ warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se --- | --- Runs a computation listening for warnings and then escalating any warnings +-- | Runs a computation listening for warnings and then escalating any warnings -- that match the predicate to error status. --- escalateWarningWhen :: (MonadWriter MultipleErrors m, MonadError MultipleErrors m) => (ErrorMessage -> Bool) @@ -1334,16 +1311,20 @@ escalateWarningWhen isError ma = do unless (null errors) $ throwError $ MultipleErrors errors return a --- | --- Collect errors in in parallel --- -parU :: (MonadError MultipleErrors m) => [a] -> (a -> m b) -> m [b] -parU xs f = forM xs (withError . f) >>= collectErrors +-- | Collect errors in in parallel +parU + :: forall m a b + . MonadError MultipleErrors m + => [a] + -> (a -> m b) + -> m [b] +parU xs f = + forM xs (withError . f) >>= collectErrors where - withError :: (MonadError MultipleErrors m) => m a -> m (Either MultipleErrors a) - withError u = catchError (Right <$> u) (return . Left) + withError :: m b -> m (Either MultipleErrors b) + withError u = catchError (Right <$> u) (return . Left) - collectErrors :: (MonadError MultipleErrors m) => [Either MultipleErrors a] -> m [a] - collectErrors es = case lefts es of - [] -> return $ rights es - errs -> throwError $ fold errs + collectErrors :: [Either MultipleErrors b] -> m [b] + collectErrors es = case lefts es of + [] -> return $ rights es + errs -> throwError $ fold errs diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 9f60e06cd1..71eeaccd9d 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -20,53 +20,51 @@ module Language.PureScript.Make , inferForeignModules ) where -import Prelude.Compat - -import Control.Concurrent.Lifted as C -import Control.Monad hiding (sequence) -import Control.Monad.Base (MonadBase(..)) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) -import Control.Monad.Supply -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Trans.Control (MonadBaseControl(..)) -import Control.Monad.Trans.Except -import Control.Monad.Writer.Class (MonadWriter(..)) - -import Data.Aeson (encode, decode) +import Prelude.Compat + +import Control.Concurrent.Lifted as C +import Control.Monad hiding (sequence) +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.IO.Class +import Control.Monad.Logger +import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) +import Control.Monad.Supply +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Control.Monad.Trans.Except +import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Aeson (encode, decode) import qualified Data.Aeson as Aeson -import Data.Either (partitionEithers) -import Data.Function (on) -import Data.Foldable (for_) -import Data.List (foldl', sortBy, groupBy) -import Data.Maybe (fromMaybe, catMaybes) -import Data.Monoid ((<>)) -import Data.Time.Clock -import Data.Traversable (for) -import Data.Version (showVersion) +import Data.Either (partitionEithers) +import Data.Function (on) +import Data.Foldable (for_) +import Data.List (foldl', sortBy, groupBy) +import Data.Maybe (fromMaybe, catMaybes) +import Data.Monoid ((<>)) +import Data.Time.Clock +import Data.Traversable (for) +import Data.Version (showVersion) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.UTF8 as BU8 import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE - -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Externs -import Language.PureScript.Linter -import Language.PureScript.ModuleDependencies -import Language.PureScript.Names -import Language.PureScript.Options -import Language.PureScript.Pretty -import Language.PureScript.Pretty.Common(SMap(..)) -import Language.PureScript.Renamer -import Language.PureScript.Sugar -import Language.PureScript.TypeChecker +import Language.PureScript.AST +import Language.PureScript.Crash +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Externs +import Language.PureScript.Linter +import Language.PureScript.ModuleDependencies +import Language.PureScript.Names +import Language.PureScript.Options +import Language.PureScript.Pretty +import Language.PureScript.Pretty.Common(SMap(..)) +import Language.PureScript.Renamer +import Language.PureScript.Sugar +import Language.PureScript.TypeChecker import qualified Language.JavaScript.Parser as JS import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.CodeGen.JS as J @@ -74,21 +72,18 @@ import qualified Language.PureScript.Constants as C import qualified Language.PureScript.CoreFn as CF import qualified Language.PureScript.CoreFn.ToJSON as CFJ import qualified Language.PureScript.Parser as PSParser - import qualified Paths_purescript as Paths - -import SourceMap -import SourceMap.Types - -import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) -import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise, replaceExtension) -import System.IO.Error (tryIOError) - +import SourceMap +import SourceMap.Types +import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) +import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise, replaceExtension) +import System.IO.Error (tryIOError) import qualified Text.Parsec as Parsec -- | Progress messages from the make process data ProgressMessage = CompilingModule ModuleName + -- ^ Compilation started for the specified module deriving (Show, Eq, Ord) -- | Render a progress message @@ -102,7 +97,6 @@ renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModule -- * The particular backend being used (Javascript, C++11, etc.) -- -- * The details of how files are read/written etc. --- data MakeActions m = MakeActions { getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime)) -- ^ Get the timestamp for the input file(s) for a module. If there are multiple @@ -121,26 +115,26 @@ data MakeActions m = MakeActions -- ^ Respond to a progress update. } --- | --- Generated code for an externs file. --- +-- | Generated code for an externs file. type Externs = B.ByteString --- | --- Determines when to rebuild a module --- +-- | Determines when to rebuild a module data RebuildPolicy -- | Never rebuild this module = RebuildNever -- | Always rebuild this module | RebuildAlways deriving (Show, Eq, Ord) --- | Rebuild a single module -rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => MakeActions m - -> [ExternsFile] - -> Module - -> m ExternsFile +-- | Rebuild a single module. +-- +-- This function is used for fast-rebuild workflows (PSCi and psc-ide are examples). +rebuildModule + :: forall m + . (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => MakeActions m + -> [ExternsFile] + -> Module + -> m ExternsFile rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do progress $ CompilingModule moduleName let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs @@ -157,12 +151,10 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do evalSupplyT nextVar . codegen renamed env' . encode $ exts return exts --- | --- Compiles in "make" mode, compiling each module separately to a js files and an externs file +-- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.json@ file. -- -- If timestamps have not changed, the externs file can be used to provide the module's types without -- having to typecheck the module again. --- make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [Module] @@ -244,7 +236,7 @@ make ma@MakeActions{..} ms = do putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors - maximumMaybe :: (Ord a) => [a] -> Maybe a + maximumMaybe :: Ord a => [a] -> Maybe a maximumMaybe [] = Nothing maximumMaybe xs = Just $ maximum xs @@ -262,11 +254,10 @@ make ma@MakeActions{..} ms = do importPrim :: Module -> Module importPrim = addDefaultImport (ModuleName [ProperName C.prim]) --- | --- A monad for running make actions --- -newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a } - deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options) +-- | A monad for running make actions +newtype Make a = Make + { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a + } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options) instance MonadBase IO Make where liftBase = liftIO @@ -276,12 +267,12 @@ instance MonadBaseControl IO Make where liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake) restoreM = Make . restoreM --- | --- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings. --- +-- | Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings. runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors) runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake +-- | Run an 'IO' action in the 'Make' monad, by specifying how IO errors should +-- be rendered as 'ErrorMessage' values. makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a makeIO f io = do e <- liftIO $ tryIOError io @@ -299,7 +290,8 @@ inferForeignModules . MonadIO m => M.Map ModuleName (Either RebuildPolicy FilePath) -> m (M.Map ModuleName FilePath) -inferForeignModules = fmap (M.mapMaybe id) . traverse inferForeignModule +inferForeignModules = + fmap (M.mapMaybe id) . traverse inferForeignModule where inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath) inferForeignModule (Left _) = return Nothing @@ -310,16 +302,19 @@ inferForeignModules = fmap (M.mapMaybe id) . traverse inferForeignModule then return (Just jsFile) else return Nothing --- | --- A set of make actions that read and write modules from the given directory. --- -buildMakeActions :: FilePath -- ^ the output directory - -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module - -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module - -> Bool -- ^ Generate a prefix comment? - -> MakeActions Make +-- | A set of make actions that read and write modules from the given directory. +buildMakeActions + :: FilePath + -- ^ the output directory + -> M.Map ModuleName (Either RebuildPolicy FilePath) + -- ^ a map between module names and paths to the file containing the PureScript module + -> M.Map ModuleName FilePath + -- ^ a map between module name and the file containing the foreign javascript for the module + -> Bool + -- ^ Generate a prefix comment? + -> MakeActions Make buildMakeActions outputDir filePathMap foreigns usePrefix = - MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress + MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress where getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime)) @@ -421,10 +416,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = progress :: ProgressMessage -> Make () progress = liftIO . putStrLn . renderProgressMessage --- | --- Check that the declarations in a given PureScript module match with those +-- | Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module. --- checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make () checkForeignDecls m path = do jsStr <- lift $ readTextFile path diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index a8e07f93a7..5766f0ff94 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -1,24 +1,18 @@ --- | --- Provides the ability to sort modules based on module dependencies --- +-- | Provides the ability to sort modules based on module dependencies module Language.PureScript.ModuleDependencies ( sortModules , ModuleGraph ) where -import Prelude.Compat - -import Control.Monad.Error.Class (MonadError(..)) - -import Data.Graph -import Data.List (nub) -import Data.Maybe (fromMaybe) +import Protolude -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.Types +import Data.Graph +import qualified Data.Set as S +import Language.PureScript.AST +import qualified Language.PureScript.Constants as C +import Language.PureScript.Crash +import Language.PureScript.Errors +import Language.PureScript.Names -- | A list of modules with their transitive dependencies type ModuleGraph = [(ModuleName, [ModuleName])] @@ -26,75 +20,45 @@ type ModuleGraph = [(ModuleName, [ModuleName])] -- | Sort a collection of modules based on module dependencies. -- -- Reports an error if the module graph contains a cycle. --- -sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph) +sortModules + :: forall m + . MonadError MultipleErrors m + => [Module] + -> m ([Module], ModuleGraph) sortModules ms = do - let verts = map goModule ms - ms' <- mapM toModule $ stronglyConnComp verts - let (graph, fromVertex, toVertex) = graphFromEdges verts - moduleGraph = do (_, mn, _) <- verts - let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn) - deps = reachable graph v - toKey i = case fromVertex i of (_, key, _) -> key - return (mn, filter (/= mn) (map toKey deps)) - return (ms', moduleGraph) + let mns = S.fromList $ map getModuleName ms + verts <- mapM (toGraphNode mns) ms + ms' <- mapM toModule $ stronglyConnComp verts + let (graph, fromVertex, toVertex) = graphFromEdges verts + moduleGraph = do (_, mn, _) <- verts + let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn) + deps = reachable graph v + toKey i = case fromVertex i of (_, key, _) -> key + return (mn, filter (/= mn) (map toKey deps)) + return (ms', moduleGraph) where - goModule :: Module -> (Module, ModuleName, [ModuleName]) - goModule m@(Module _ _ _ ds _) = - let ams = concatMap extractQualAs ds - in (m, getModuleName m, nub (concatMap (usedModules ams) ds)) + toGraphNode :: S.Set ModuleName -> Module -> m (Module, ModuleName, [ModuleName]) + toGraphNode mns m@(Module _ _ mn ds _) = do + let deps = ordNub (concatMap usedModules ds) + forM_ deps $ \dep -> + when (dep /= C.Prim && S.notMember dep mns) $ + throwError . addHint (ErrorInModule mn) . errorMessage $ ModuleNotFound dep + pure (m, getModuleName m, deps) - -- Extract module names that have been brought into scope by an `as` import. - extractQualAs :: Declaration -> [ModuleName] - extractQualAs (PositionedDeclaration _ _ d) = extractQualAs d - extractQualAs (ImportDeclaration _ _ (Just am)) = [am] - extractQualAs _ = [] - --- | --- Calculate a list of used modules based on explicit imports and qualified --- names. `ams` is a list of `ModuleNames` that refer to names brought into --- scope by importing with `as` - this ensures that when building the list we --- don't inadvertantly assume a dependency on an actual module, if there is a --- module that has the same name as the qualified import. --- -usedModules :: [ModuleName] -> Declaration -> [ModuleName] -usedModules ams d = - let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) - (g, _, _, _, _) = accumTypes (everythingOnTypes (++) forTypes) - in nub (f d ++ g d) - where +-- | Calculate a list of used modules based on explicit imports and qualified names. +usedModules :: Declaration -> [ModuleName] +usedModules d = f d where + f :: Declaration -> [ModuleName] + (f, _, _, _, _) = everythingOnValues (++) forDecls (const []) (const []) (const []) (const []) forDecls :: Declaration -> [ModuleName] - forDecls (ImportDeclaration mn _ _) = - -- Regardless of whether an imported module is qualified we still need to - -- take into account its import to build an accurate list of dependencies. - [mn] - forDecls (FixityDeclaration fd) - | Just mn <- extractQualFixity fd, mn `notElem` ams = [mn] - forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) - | mn `notElem` ams = [mn] + -- Regardless of whether an imported module is qualified we still need to + -- take into account its import to build an accurate list of dependencies. + forDecls (ImportDeclaration mn _ _) = [mn] forDecls _ = [] - forValues :: Expr -> [ModuleName] - forValues (Var (Qualified (Just mn) _)) - | mn `notElem` ams = [mn] - forValues (Constructor (Qualified (Just mn) _)) - | mn `notElem` ams = [mn] - forValues _ = [] - - forTypes :: Type -> [ModuleName] - forTypes (TypeConstructor (Qualified (Just mn) _)) - | mn `notElem` ams = [mn] - forTypes _ = [] - - extractQualFixity :: Either ValueFixity TypeFixity -> Maybe ModuleName - extractQualFixity (Left (ValueFixity _ (Qualified mn _) _)) = mn - extractQualFixity (Right (TypeFixity _ (Qualified mn _) _)) = mn - --- | --- Convert a strongly connected component of the module graph to a module --- -toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module +-- | Convert a strongly connected component of the module graph to a module +toModule :: MonadError MultipleErrors m => SCC Module -> m Module toModule (AcyclicSCC m) = return m toModule (CyclicSCC [m]) = return m toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms) diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs index 387829ebad..9133fb7d8c 100644 --- a/tests/Language/PureScript/Ide/Integration.hs +++ b/tests/Language/PureScript/Ide/Integration.hs @@ -243,7 +243,7 @@ unwrapResult = withObject "result" $ \o -> do case rt of "error" -> do res <- o .: "result" - pure (Left res) + withArray "errors" (fmap (Left . fold) . traverse (withObject "error" (.: "message"))) res "success" -> do res <- o .: "result" pure (Right res) From 3f1a50e626dd9d7f610c6094e20268e8a7fba6a9 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 20 Jan 2017 09:40:31 -0800 Subject: [PATCH 0628/1580] Inline Partial.Unsafe.unsafePartial (#2572) * Inline Partial.Unsafe.unsafePartial * Add test * Improve example, Move inlining logic into evaluateIifes --- examples/passing/2288.purs | 19 +++++++++++++++ .../PureScript/CodeGen/JS/Optimizer.hs | 2 +- .../CodeGen/JS/Optimizer/Inliner.hs | 19 +++++++++++---- .../PureScript/CodeGen/JS/Optimizer/TCO.hs | 23 +++++++++---------- src/Language/PureScript/Constants.hs | 6 +++++ 5 files changed, 52 insertions(+), 17 deletions(-) create mode 100644 examples/passing/2288.purs diff --git a/examples/passing/2288.purs b/examples/passing/2288.purs new file mode 100644 index 0000000000..78c8ab4e83 --- /dev/null +++ b/examples/passing/2288.purs @@ -0,0 +1,19 @@ +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console +import Data.Array +import Data.Array.Partial as P +import Partial.Unsafe + +length :: forall a. Array a -> Int +length = go 0 where + go acc arr = + if null arr + then acc + else go (acc + 1) (unsafePartial P.tail arr) + +main = do + logShow (length (1 .. 10000)) + log "Done" diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs index c504a77eda..69f9b5bc30 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -46,7 +46,7 @@ optimize js = do optimize' :: (MonadReader Options m, MonadSupply m) => JS -> m JS optimize' js = do opts <- ask - js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll + js' <- untilFixedPoint (inlineFnComposition . inlineUnsafePartial . tidyUp . applyAll [ inlineCommonValues , inlineCommonOperators ]) js diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index b9846e9b02..440d22d672 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -6,6 +6,7 @@ module Language.PureScript.CodeGen.JS.Optimizer.Inliner , inlineCommonValues , inlineCommonOperators , inlineFnComposition + , inlineUnsafePartial , etaConvert , unThunk , evaluateIifes @@ -66,6 +67,8 @@ evaluateIifes = everywhereOnJS convert where convert :: JS -> JS convert (JSApp _ (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ ret])) []) = ret + convert (JSApp _ (JSFunction _ Nothing idents (JSBlock _ [JSReturn ss ret])) []) + | not (any (`isReassigned` ret) idents) = replaceIdents (map (, JSVar ss C.undefined) idents) ret convert js = js inlineVariables :: JS -> JS @@ -249,10 +252,9 @@ inlineCommonOperators = applyAll $ -- (f <<< g $ x) = f (g x) -- (f <<< g) = \x -> f (g x) -inlineFnComposition :: (MonadSupply m) => JS -> m JS -inlineFnComposition = everywhereOnJSTopDownM convert - where - convert :: (MonadSupply m) => JS -> m JS +inlineFnComposition :: forall m. MonadSupply m => JS -> m JS +inlineFnComposition = everywhereOnJSTopDownM convert where + convert :: JS -> m JS convert (JSApp s1 (JSApp s2 (JSApp _ (JSApp _ fn [dict']) [x]) [y]) [z]) | isFnCompose dict' fn = return $ JSApp s1 x [JSApp s2 y [z]] | isFnComposeFlipped dict' fn = return $ JSApp s2 y [JSApp s1 x [z]] @@ -273,6 +275,15 @@ inlineFnComposition = everywhereOnJSTopDownM convert fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b) fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped) +inlineUnsafePartial :: JS -> JS +inlineUnsafePartial = everywhereOnJSTopDown convert where + convert (JSApp ss (JSIndexer _ (JSStringLiteral _ unsafePartial) (JSVar _ partialUnsafe)) [ comp ]) + | unsafePartial == C.unsafePartial && partialUnsafe == C.partialUnsafe + -- Apply to undefined here, the application should be optimized away + -- if it is safe to do so + = JSApp ss comp [ JSVar ss C.undefined ] + convert other = other + semiringNumber :: forall a b. (IsString a, IsString b) => (a, b) semiringNumber = (C.dataSemiring, C.semiringNumber) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs index 0a3850d01e..1b3f080820 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs @@ -80,7 +80,17 @@ tco' = everywhereOnJS convert countSelfCallsUnderFunctions _ = 0 countSelfCallsWithFnArgs :: JS -> Int - countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0 + countSelfCallsWithFnArgs = go [] where + go acc (JSVar _ ident') + | ident == ident' && any hasFunction acc = 1 + go acc (JSApp _ fn args) = go (args ++ acc) fn + go _ _ = 0 + + hasFunction :: JS -> Bool + hasFunction = getAny . everythingOnJS mappend (Any . isFunction) + where + isFunction JSFunction{} = True + isFunction _ = False toLoop :: Text -> [Text] -> JS -> JS toLoop ident allArgs js = JSBlock rootSS $ @@ -108,14 +118,3 @@ tco' = everywhereOnJS convert isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident' isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn isSelfCall _ _ = False - - isSelfCallWithFnArgs :: Text -> JS -> [JS] -> Bool - isSelfCallWithFnArgs ident (JSVar _ ident') args | ident == ident' && any hasFunction args = True - isSelfCallWithFnArgs ident (JSApp _ fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc) - isSelfCallWithFnArgs _ _ _ = False - - hasFunction :: JS -> Bool - hasFunction = getAny . everythingOnJS mappend (Any . isFunction) - where - isFunction JSFunction{} = True - isFunction _ = False diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 4667e8d65e..baf9c109ee 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -447,3 +447,9 @@ dataFunctionUncurried = "Data_Function_Uncurried" dataIntBits :: forall a. (IsString a) => a dataIntBits = "Data_Int_Bits" + +partialUnsafe :: forall a. (IsString a) => a +partialUnsafe = "Partial_Unsafe" + +unsafePartial :: forall a. (IsString a) => a +unsafePartial = "unsafePartial" From 93b379a241f091c0af5c66112646e7158f791177 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 20 Jan 2017 09:45:10 -0800 Subject: [PATCH 0629/1580] Fix #2584 --- src/Language/PureScript/Crash.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Crash.hs b/src/Language/PureScript/Crash.hs index 4acdea1e98..e1b6cccd63 100644 --- a/src/Language/PureScript/Crash.hs +++ b/src/Language/PureScript/Crash.hs @@ -6,6 +6,6 @@ import Prelude.Compat internalError :: String -> a internalError = error - . ("An internal error ocurred during compilation: " ++) + . ("An internal error occurred during compilation: " ++) . (++ "\nPlease report this at https://github.com/purescript/purescript/issues") . show From cda7969b64ffc01484a7d4ec5f2124df6cc2d2b2 Mon Sep 17 00:00:00 2001 From: Michael Ficarra Date: Fri, 20 Jan 2017 00:49:31 -0800 Subject: [PATCH 0630/1580] fixes #2568: TypeLevelString/TypeConcat should not be quoted --- src/Language/PureScript/Errors.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 764d5bacb9..65f6e8a76e 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -32,6 +32,7 @@ import Language.PureScript.Label (Label(..)) import Language.PureScript.Names import Language.PureScript.Pretty import Language.PureScript.Pretty.Common (before, endWith) +import Language.PureScript.PSString (decodeString) import Language.PureScript.Traversals import Language.PureScript.Types import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers @@ -1264,7 +1265,7 @@ renderBox = unlines whiteSpace = all isSpace toTypelevelString :: Type -> Maybe Box.Box -toTypelevelString (TypeLevelString s) = Just $ Box.text $ T.unpack $ prettyPrintString s +toTypelevelString (TypeLevelString s) = (Box.text . T.unpack) <$> decodeString s toTypelevelString (TypeApp (TypeConstructor f) x) | f == primName "TypeString" = Just $ typeAsBox x toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret) From 3941bd10fd6ac274c513bc8c2cf83a4327e98215 Mon Sep 17 00:00:00 2001 From: Michael Ficarra Date: Fri, 20 Jan 2017 09:13:35 -0800 Subject: [PATCH 0631/1580] UTF-16 surrogate pair and lone surrogate support in type level strings --- src/Language/PureScript/Errors.hs | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 65f6e8a76e..ae44ae746c 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -20,6 +20,7 @@ import Data.Functor.Identity (Identity(..)) import Data.List (transpose, nub, nubBy, sortBy, partition) import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import Data.Ord (comparing) +import Data.String (fromString) import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text) @@ -31,8 +32,8 @@ import Language.PureScript.Environment import Language.PureScript.Label (Label(..)) import Language.PureScript.Names import Language.PureScript.Pretty -import Language.PureScript.Pretty.Common (before, endWith) -import Language.PureScript.PSString (decodeString) +import Language.PureScript.Pretty.Common (endWith) +import Language.PureScript.PSString (PSString, decodeStringEither) import Language.PureScript.Traversals import Language.PureScript.Types import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers @@ -1265,12 +1266,15 @@ renderBox = unlines whiteSpace = all isSpace toTypelevelString :: Type -> Maybe Box.Box -toTypelevelString (TypeLevelString s) = (Box.text . T.unpack) <$> decodeString s -toTypelevelString (TypeApp (TypeConstructor f) x) - | f == primName "TypeString" = Just $ typeAsBox x -toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret) - | f == primName "TypeConcat" = before <$> (toTypelevelString x) <*> (toTypelevelString ret) -toTypelevelString _ = Nothing +toTypelevelString t = (Box.text . map (either (const '\xFFFD') id) . decodeStringEither) <$> toTypelevelString' t + where + toTypelevelString' :: Type -> Maybe PSString + toTypelevelString' (TypeLevelString s) = Just s + toTypelevelString' (TypeApp (TypeConstructor f) x) + | f == primName "TypeString" = Just $ fromString $ prettyPrintType x + toTypelevelString' (TypeApp (TypeApp (TypeConstructor f) x) ret) + | f == primName "TypeConcat" = toTypelevelString' x <> toTypelevelString' ret + toTypelevelString' _ = Nothing -- | Rethrow an error with a more detailed error message in the case of failure rethrow :: (MonadError e m) => (e -> e) -> m a -> m a From d1a88d7e3159f6a57df89d25f0e3bf4295b8270a Mon Sep 17 00:00:00 2001 From: Michael Ficarra Date: Fri, 20 Jan 2017 09:35:52 -0800 Subject: [PATCH 0632/1580] extract Unicode replacement into PSString.decodeStringWithReplacement --- src/Language/PureScript/Errors.hs | 4 ++-- src/Language/PureScript/PSString.hs | 10 ++++++++++ 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index ae44ae746c..11b9507336 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -33,7 +33,7 @@ import Language.PureScript.Label (Label(..)) import Language.PureScript.Names import Language.PureScript.Pretty import Language.PureScript.Pretty.Common (endWith) -import Language.PureScript.PSString (PSString, decodeStringEither) +import Language.PureScript.PSString (PSString, decodeStringWithReplacement) import Language.PureScript.Traversals import Language.PureScript.Types import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers @@ -1266,7 +1266,7 @@ renderBox = unlines whiteSpace = all isSpace toTypelevelString :: Type -> Maybe Box.Box -toTypelevelString t = (Box.text . map (either (const '\xFFFD') id) . decodeStringEither) <$> toTypelevelString' t +toTypelevelString t = (Box.text . decodeStringWithReplacement) <$> toTypelevelString' t where toTypelevelString' :: Type -> Maybe PSString toTypelevelString' (TypeLevelString s) = Just s diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index a841e43592..0073f0f159 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -5,6 +5,7 @@ module Language.PureScript.PSString , toUTF16CodeUnits , decodeString , decodeStringEither + , decodeStringWithReplacement , prettyPrintString , prettyPrintStringJS , mkString @@ -52,15 +53,24 @@ newtype PSString = PSString { toUTF16CodeUnits :: [Word16] } instance Show PSString where show = show . codePoints +-- | -- Decode a PSString to a String, representing any lone surrogates as the -- reserved code point with that index. Warning: if there are any lone -- surrogates, converting the result to Text via Data.Text.pack will result in -- loss of information as those lone surrogates will be replaced with U+FFFD -- REPLACEMENT CHARACTER. Because this function requires care to use correctly, -- we do not export it. +-- codePoints :: PSString -> String codePoints = map (either (chr . fromIntegral) id) . decodeStringEither +-- | +-- Decode a PSString as UTF-16 text. Lone surrogates will be replaced with +-- U+FFFD REPLACEMENT CHARACTER +-- +decodeStringWithReplacement :: PSString -> String +decodeStringWithReplacement = map (either (const '\xFFFD') id) . decodeStringEither + -- | -- Decode a PSString as UTF-16. Lone surrogates in the input are represented in -- the output with the Left constructor; characters which were successfully From 76fc5f4e722f4e2dde91b874c13a1d33e787e898 Mon Sep 17 00:00:00 2001 From: kRITZCREEK Date: Sat, 21 Jan 2017 09:53:22 +0100 Subject: [PATCH 0633/1580] fix tests Seems like a new release of purescript-arrays added a new module --- tests/TestUtils.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 783f0c716d..ef9bbb525b 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -78,6 +78,7 @@ supportModules = , "Data.Array" , "Data.Array.Partial" , "Data.Array.ST" + , "Data.Array.ST.Iterator" , "Data.Bifoldable" , "Data.Bifunctor" , "Data.Bifunctor.Clown" From b03f4cfdf59751261563dedb0ad3ee83406ceb88 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 21 Jan 2017 16:25:07 +0000 Subject: [PATCH 0634/1580] Add modules for rendering HTML documentation Refs #2520. This code is more or less copied from Pursuit, although I managed to drop the `hxt` dependency by instead using Cheapskate's provided functions for walking a rendered Markdown document. This is just a starting point towards generating HTML documentation from a given package set. Next, I plan to make psc-docs capable of producing HTML documentation as well as Markdown. --- purescript.cabal | 3 + src/Language/PureScript/Docs/AsHtml.hs | 299 +++++++++++++++++++++++++ src/Language/PureScript/Docs/Types.hs | 85 ++++++- 3 files changed, 386 insertions(+), 1 deletion(-) create mode 100644 src/Language/PureScript/Docs/AsHtml.hs diff --git a/purescript.cabal b/purescript.cabal index 321532b1fc..c81d3d2e07 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -117,9 +117,11 @@ library aeson-better-errors >= 0.8, ansi-terminal >= 0.6.2 && < 0.7, base-compat >=0.6.0, + blaze-html >= 0.8.1 && < 0.9, bower-json >= 1.0.0.1 && < 1.1, boxes >= 0.1.4 && < 0.2.0, bytestring -any, + cheapskate >= 0.1 && < 0.2, containers -any, clock -any, data-ordlist >= 0.4.7.0, @@ -270,6 +272,7 @@ library Language.PureScript.Docs.RenderedCode.RenderType Language.PureScript.Docs.RenderedCode.RenderKind Language.PureScript.Docs.AsMarkdown + Language.PureScript.Docs.AsHtml Language.PureScript.Docs.ParseInPackage Language.PureScript.Docs.Utils.MonoidExtras diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs new file mode 100644 index 0000000000..dd311e010e --- /dev/null +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -0,0 +1,299 @@ + +-- | Functions for rendering generated documentation from PureScript code as +-- HTML. + +module Language.PureScript.Docs.AsHtml ( + HtmlOutput(..), + HtmlOutputModule(..), + HtmlRenderContext(..), + nullRenderContext, + declNamespace, + packageAsHtml, + moduleAsHtml, + makeFragment, + renderMarkdown +) where + +import Prelude +import Control.Arrow (second) +import Control.Category ((>>>)) +import Control.Monad (unless) +import Data.Char (isUpper) +import Data.Monoid ((<>)) +import Data.Foldable (for_) +import Data.String (fromString) + +import Data.Text (Text) +import qualified Data.Text as T + +import Text.Blaze.Html5 as H hiding (map) +import qualified Text.Blaze.Html5.Attributes as A +import qualified Cheapskate + +import qualified Language.PureScript as P + +import Language.PureScript.Docs.Types +import Language.PureScript.Docs.RenderedCode hiding (sp) +import qualified Language.PureScript.Docs.Render as Render + +declNamespace :: Declaration -> Namespace +declNamespace = declInfoNamespace . declInfo + +data HtmlOutput a = HtmlOutput + { htmlIndex :: [(Maybe Char, a)] + , htmlModules :: [(P.ModuleName, HtmlOutputModule a)] + } + deriving (Show, Functor) + +data HtmlOutputModule a = HtmlOutputModule + { htmlOutputModuleLocals :: a + , htmlOutputModuleReExports :: [(InPackage P.ModuleName, a)] + } + deriving (Show, Functor) + +data HtmlRenderContext = HtmlRenderContext + { currentModuleName :: P.ModuleName + , buildDocLink :: Namespace -> Text -> ContainingModule -> Maybe DocLink + , renderDocLink :: DocLink -> Text + , renderSourceLink :: P.SourceSpan -> Text + } + +-- | +-- An HtmlRenderContext for when you don't want to render any links. +nullRenderContext :: P.ModuleName -> HtmlRenderContext +nullRenderContext mn = HtmlRenderContext + { currentModuleName = mn + , buildDocLink = const (const (const Nothing)) + , renderDocLink = const "" + , renderSourceLink = const "" + } + +packageAsHtml :: (P.ModuleName -> HtmlRenderContext) -> Package a -> HtmlOutput Html +packageAsHtml getHtmlCtx Package{..} = + HtmlOutput indexFile modules + where + indexFile = [] + modules = map (\m -> moduleAsHtml (getHtmlCtx (modName m)) m) pkgModules + +moduleAsHtml :: HtmlRenderContext -> Module -> (P.ModuleName, HtmlOutputModule Html) +moduleAsHtml r Module{..} = (modName, HtmlOutputModule modHtml reexports) + where + renderDecl = declAsHtml r + modHtml = do + for_ modComments renderMarkdown + for_ modDeclarations renderDecl + reexports = + map (second (foldMap renderDecl)) modReExports + +-- renderIndex :: LinksContext -> [(Maybe Char, Html)] +-- renderIndex LinksContext{..} = go ctxBookmarks +-- where +-- go = takeLocals +-- >>> groupIndex getIndex renderEntry +-- >>> map (second (ul . mconcat)) +-- +-- getIndex (_, title_) = do +-- c <- textHeadMay title_ +-- guard (toUpper c `elem` ['A'..'Z']) +-- pure c +-- +-- textHeadMay t = +-- case T.length t of +-- 0 -> Nothing +-- _ -> Just (T.index t 0) +-- +-- renderEntry (mn, title_) = +-- li $ do +-- let url = T.pack (filePathFor mn `relativeTo` "index") <> "#" <> title_ +-- code $ +-- a ! A.href (v url) $ text title_ +-- sp +-- text ("(" <> P.runModuleName mn <> ")") +-- +-- groupIndex :: Ord i => (a -> Maybe i) -> (a -> b) -> [a] -> [(Maybe i, [b])] +-- groupIndex f g = +-- map (second DList.toList) . M.toList . foldr go' M.empty . sortBy (comparing f) +-- where +-- go' x = insertOrAppend (f x) (g x) +-- insertOrAppend idx val m = +-- let cur = M.findWithDefault DList.empty idx m +-- new = DList.snoc cur val +-- in M.insert idx new m + +declAsHtml :: HtmlRenderContext -> Declaration -> Html +declAsHtml r d@Declaration{..} = do + let declFragment = makeFragment (declInfoNamespace declInfo) declTitle + H.div ! A.class_ "decl" ! A.id (v (T.drop 1 declFragment)) $ do + h3 ! A.class_ "decl__title clearfix" $ do + a ! A.class_ "decl__anchor" ! A.href (v declFragment) $ "#" + text declTitle + for_ declSourceSpan (linkToSource r) + + H.div ! A.class_ "decl__body" $ do + case declInfo of + AliasDeclaration fixity alias_ -> + renderAlias fixity alias_ + _ -> + pre ! A.class_ "decl__signature" $ code $ + codeAsHtml r (Render.renderDeclaration d) + + for_ declComments renderMarkdown + + let (instances, dctors, members) = partitionChildren declChildren + + unless (null dctors) $ do + h4 "Constructors" + renderChildren r dctors + + unless (null members) $ do + h4 "Members" + renderChildren r members + + unless (null instances) $ do + h4 "Instances" + renderChildren r instances + where + linkToSource :: HtmlRenderContext -> P.SourceSpan -> Html + linkToSource ctx srcspan = + H.span ! A.class_ "decl__source" $ + a ! A.href (v (renderSourceLink ctx srcspan)) $ text "Source" + +renderChildren :: HtmlRenderContext -> [ChildDeclaration] -> Html +renderChildren _ [] = return () +renderChildren r xs = ul $ mapM_ go xs + where + go decl = item decl . code . codeAsHtml r . Render.renderChildDeclaration $ decl + item decl = let fragment = makeFragment (childDeclInfoNamespace (cdeclInfo decl)) (cdeclTitle decl) + in li ! A.id (v (T.drop 1 fragment)) + +codeAsHtml :: HtmlRenderContext -> RenderedCode -> Html +codeAsHtml r = outputWith elemAsHtml + where + elemAsHtml e = case e of + Syntax x -> + withClass "syntax" (text x) + Keyword x -> + withClass "keyword" (text x) + Space -> + text " " + Symbol ns name link_ -> + case link_ of + Link mn -> + let + class_ = if startsWithUpper name then "ctor" else "ident" + in + linkToDecl ns name mn (withClass class_ (text name)) + NoLink -> + text name + + linkToDecl = linkToDeclaration r + + startsWithUpper :: Text -> Bool + startsWithUpper str = + if T.null str + then False + else isUpper (T.index str 0) + +renderLink :: HtmlRenderContext -> DocLink -> Html -> Html +renderLink r link_@DocLink{..} = + a ! A.href (v (renderDocLink r link_ <> fragmentFor link_)) + ! A.title (v fullyQualifiedName) + where + fullyQualifiedName = case linkLocation of + SameModule -> fq (currentModuleName r) linkTitle + LocalModule _ modName -> fq modName linkTitle + DepsModule _ _ _ modName -> fq modName linkTitle + BuiltinModule modName -> fq modName linkTitle + + fq mn str = P.runModuleName mn <> "." <> str + +makeFragment :: Namespace -> Text -> Text +makeFragment ns = (prefix <>) . escape + where + prefix = case ns of + TypeLevel -> "#t:" + ValueLevel -> "#v:" + KindLevel -> "#k:" + + -- TODO + escape = id + +fragmentFor :: DocLink -> Text +fragmentFor l = makeFragment (linkNamespace l) (linkTitle l) + +linkToDeclaration :: + HtmlRenderContext -> + Namespace -> + Text -> + ContainingModule -> + Html -> + Html +linkToDeclaration r ns target containMn = + maybe id (renderLink r) (buildDocLink r ns target containMn) + +renderAlias :: P.Fixity -> FixityAlias -> Html +renderAlias (P.Fixity associativity precedence) alias_ = + p $ do + -- TODO: Render a link + toHtml $ "Operator alias for " <> P.showQualified showAliasName alias_ <> " " + em $ + text ("(" <> associativityStr <> " / precedence " <> T.pack (show precedence) <> ")") + where + showAliasName (Left valueAlias) = P.runProperName valueAlias + showAliasName (Right typeAlias) = case typeAlias of + (Left identifier) -> P.runIdent identifier + (Right properName) -> P.runProperName properName + associativityStr = case associativity of + P.Infixl -> "left-associative" + P.Infixr -> "right-associative" + P.Infix -> "non-associative" + +-- | Render Markdown to HTML. Safe for untrusted input. Relative links are +-- | removed. +renderMarkdown :: Text -> H.Html +renderMarkdown = + H.toMarkup . removeRelativeLinks . Cheapskate.markdown opts + where + opts = Cheapskate.def { Cheapskate.allowRawHtml = False } + +removeRelativeLinks :: Cheapskate.Doc -> Cheapskate.Doc +removeRelativeLinks = Cheapskate.walk go + where + go :: Cheapskate.Inlines -> Cheapskate.Inlines + go = (>>= stripRelatives) + + stripRelatives :: Cheapskate.Inline -> Cheapskate.Inlines + stripRelatives (Cheapskate.Link contents_ href _) + | isRelativeURI href = contents_ + stripRelatives other = pure other + + -- Tests for a ':' character in the first segment of a URI. + -- + -- See Section 4.2 of RFC 3986: + -- https://tools.ietf.org/html/rfc3986#section-4.2 + -- + -- >>> isRelativeURI "http://example.com/" == False + -- >>> isRelativeURI "mailto:me@example.com" == False + -- >>> isRelativeURI "foo/bar" == True + -- >>> isRelativeURI "/bar" == True + -- >>> isRelativeURI "./bar" == True + isRelativeURI :: Text -> Bool + isRelativeURI = + T.takeWhile (/= '/') >>> T.all (/= ':') + +v :: Text -> AttributeValue +v = toValue + +withClass :: String -> Html -> Html +withClass className content = H.span ! A.class_ (fromString className) $ content + +partitionChildren :: + [ChildDeclaration] -> + ([ChildDeclaration], [ChildDeclaration], [ChildDeclaration]) +partitionChildren = foldl go ([], [], []) + where + go (instances, dctors, members) rcd = + case cdeclInfo rcd of + ChildInstance _ _ -> (rcd : instances, dctors, members) + ChildDataConstructor _ -> (instances, rcd : dctors, members) + ChildTypeClassMember _ -> (instances, dctors, rcd : members) diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index bb0449ef1c..7593dd2ca4 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -5,7 +5,7 @@ module Language.PureScript.Docs.Types where import Protolude hiding (to, from) -import Prelude (String, unlines) +import Prelude (String, unlines, lookup) import Control.Arrow ((***)) @@ -353,6 +353,89 @@ ignorePackage :: InPackage a -> a ignorePackage (Local x) = x ignorePackage (FromDep _ x) = x +---------------------------------------------------- +-- Types for links between declarations + +data LinksContext = LinksContext + { ctxGithub :: (GithubUser, GithubRepo) + , ctxModuleMap :: Map P.ModuleName PackageName + , ctxResolvedDependencies :: [(PackageName, Version)] + , ctxPackageName :: PackageName + , ctxVersion :: Version + , ctxVersionTag :: Text + } + deriving (Show, Eq, Ord) + +data DocLink = DocLink + { linkLocation :: LinkLocation + , linkTitle :: Text + , linkNamespace :: Namespace + } + deriving (Show, Eq, Ord) + +data LinkLocation + -- | A link to a declaration in the same module. + = SameModule + + -- | A link to a declaration in a different module, but still in the current + -- package; we need to store the current module and the other declaration's + -- module. + | LocalModule P.ModuleName P.ModuleName + + -- | A link to a declaration in a different package. We store: current module + -- name, name of the other package, version of the other package, and name of + -- the module in the other package that the declaration is in. + | DepsModule P.ModuleName PackageName Version P.ModuleName + + -- | A link to a declaration that is built in to the compiler, e.g. the Prim + -- module. In this case we only need to store the module that the builtin + -- comes from (at the time of writing, this will only ever be "Prim"). + | BuiltinModule P.ModuleName + deriving (Show, Eq, Ord) + +-- | Given a links context, a thing to link to (either a value or a type), and +-- its containing module, attempt to create a DocLink. +getLink :: LinksContext -> P.ModuleName -> Namespace -> Text -> ContainingModule -> Maybe DocLink +getLink LinksContext{..} curMn namespace target containingMod = do + location <- getLinkLocation + return DocLink + { linkLocation = location + , linkTitle = target + , linkNamespace = namespace + } + + where + getLinkLocation = normalLinkLocation <|> builtinLinkLocation + + normalLinkLocation = do + case containingMod of + ThisModule -> + return SameModule + OtherModule destMn -> + case Map.lookup destMn ctxModuleMap of + Nothing -> + return $ LocalModule curMn destMn + Just pkgName -> do + pkgVersion <- lookup pkgName ctxResolvedDependencies + return $ DepsModule curMn pkgName pkgVersion destMn + + builtinLinkLocation = do + let primMn = P.moduleNameFromString "Prim" + guard $ containingMod == OtherModule primMn + -- TODO: ensure the declaration exists in the builtin module too + return $ BuiltinModule primMn + +getLinksContext :: Package a -> LinksContext +getLinksContext Package{..} = + LinksContext + { ctxGithub = pkgGithub + , ctxModuleMap = pkgModuleMap + , ctxResolvedDependencies = pkgResolvedDependencies + , ctxPackageName = bowerName pkgMeta + , ctxVersion = pkgVersion + , ctxVersionTag = pkgVersionTag + } + ---------------------- -- Parsing From 5c59ba44ea71615ae6b591cf1ba227eafd5a5b99 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 22 Jan 2017 21:19:01 +0000 Subject: [PATCH 0635/1580] Update license after adding cheapskate --- LICENSE | 310 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 310 insertions(+) diff --git a/LICENSE b/LICENSE index 550b1b6e17..22727668bd 100644 --- a/LICENSE +++ b/LICENSE @@ -48,6 +48,7 @@ PureScript uses the following Haskell library packages. Their license files foll bytestring-builder case-insensitive cereal + cheapskate clock cmdargs comonad @@ -58,7 +59,13 @@ PureScript uses the following Haskell library packages. Their license files foll contravariant cookie cryptonite + css-text + data-default data-default-class + data-default-instances-base + data-default-instances-containers + data-default-instances-dlist + data-default-instances-old-locale data-ordlist deepseq directory @@ -142,6 +149,7 @@ PureScript uses the following Haskell library packages. Their license files foll system-fileio system-filepath tagged + tagsoup template-haskell temporary terminfo @@ -152,6 +160,7 @@ PureScript uses the following Haskell library packages. Their license files foll transformers-base transformers-compat turtle + uniplate unix unix-compat unix-time @@ -172,6 +181,7 @@ PureScript uses the following Haskell library packages. Their license files foll x509-store x509-system x509-validation + xss-sanitize zlib Glob LICENSE file: @@ -1311,6 +1321,39 @@ cereal LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +cheapskate LICENSE file: + + Copyright (c) 2013, John MacFarlane + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of John MacFarlane nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + clock LICENSE file: Copyright (c) 2009-2012, Cetin Sert @@ -1606,6 +1649,63 @@ cryptonite LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +css-text LICENSE file: + + The following license covers this documentation, and the source code, except + where otherwise indicated. + + Copyright 2010, Michael Snoyman. All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO + EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, + OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE + OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +data-default LICENSE file: + + Copyright (c) 2013 Lukas Mai + + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, + OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + data-default-class LICENSE file: Copyright (c) 2013 Lukas Mai @@ -1635,6 +1735,122 @@ data-default-class LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +data-default-instances-base LICENSE file: + + Copyright (c) 2013 Lukas Mai + + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, + OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +data-default-instances-containers LICENSE file: + + Copyright (c) 2013 Lukas Mai + + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY LUKAS MAI AND CONTRIBUTORS "AS IS" AND ANY + EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY + DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +data-default-instances-dlist LICENSE file: + + Copyright (c) 2013 Lukas Mai + + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY LUKAS MAI AND CONTRIBUTORS "AS IS" AND ANY + EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY + DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +data-default-instances-old-locale LICENSE file: + + Copyright (c) 2013 Lukas Mai + + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY LUKAS MAI AND CONTRIBUTORS "AS IS" AND ANY + EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY + DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + data-ordlist LICENSE file: Copyright (c) 2009-2010, Melding Monads @@ -4366,6 +4582,39 @@ tagged LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +tagsoup LICENSE file: + + Copyright Neil Mitchell 2006-2016. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Neil Mitchell nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + template-haskell LICENSE file: @@ -4649,6 +4898,39 @@ turtle LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +uniplate LICENSE file: + + Copyright Neil Mitchell 2006-2013. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Neil Mitchell nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + unix LICENSE file: The Glasgow Haskell Compiler License @@ -5238,6 +5520,34 @@ x509-validation LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +xss-sanitize LICENSE file: + + The following license covers this documentation, and the source code, except + where otherwise indicated. + + Copyright 2010, Greg Weber. All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO + EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, + OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE + OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + zlib LICENSE file: Copyright (c) 2006-2016, Duncan Coutts From a518d56189c46a6c5ec034c5f930d1630ceadb19 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 22 Jan 2017 17:16:35 +0100 Subject: [PATCH 0636/1580] [psc-ide] Speeds up rebuilding by x2 This puts the second rebuild, which is used to make private members of modules available during completion on a separate thread and thus halves the time spent rebuilding. --- src/Language/PureScript/Ide/Logging.hs | 4 ++++ src/Language/PureScript/Ide/Rebuild.hs | 14 +++++++++----- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/Ide/Logging.hs b/src/Language/PureScript/Ide/Logging.hs index 84f45d2725..33fc3c2bdd 100644 --- a/src/Language/PureScript/Ide/Logging.hs +++ b/src/Language/PureScript/Ide/Logging.hs @@ -4,6 +4,7 @@ module Language.PureScript.Ide.Logging ( runLogger , logPerf , displayTimeSpec + , labelTimespec ) where import Protolude @@ -24,6 +25,9 @@ runLogger logLevel' = LogDebug -> not (logLevel == LevelOther "perf") LogPerf -> logLevel == LevelOther "perf") +labelTimespec :: Text -> TimeSpec -> Text +labelTimespec label duration = label <> ": " <> displayTimeSpec duration + logPerf :: (MonadIO m, MonadLogger m) => (TimeSpec -> Text) -> m t -> m t logPerf format f = do start <- liftIO (getTime Monotonic) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index b1647eed95..6641582eff 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -15,6 +15,7 @@ import qualified Data.Set as S import qualified Language.PureScript as P import Language.PureScript.Errors.JSON import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Logging import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import System.IO.UTF8 (readUTF8FileT) @@ -51,7 +52,7 @@ rebuildFile path = do -- Externs files must be sorted ahead of time, so that they get applied -- correctly to the 'Environment'. - externs <- sortExterns m =<< getExternFiles + externs <- logPerf (labelTimespec "Sorting externs") (sortExterns m =<< getExternFiles) outputDirectory <- confOutputPath . ideConfiguration <$> ask @@ -62,25 +63,28 @@ rebuildFile path = do let makeEnv = MakeActionsEnv outputDirectory filePathMap foreigns False -- Rebuild the single module using the cached externs - (result, warnings) <- liftIO + (result, warnings) <- logPerf (labelTimespec "Rebuilding Module") $ + liftIO . P.runMake P.defaultOptions . P.rebuildModule (buildMakeActions >>= shushProgress $ makeEnv) externs $ m case result of Left errors -> throwError (RebuildError (toJSONErrors False P.Error errors)) Right _ -> do - rebuildModuleOpen makeEnv externs m + env <- ask + let ll = confLogLevel (ideConfiguration env) + _ <- liftIO (async (runLogger ll (runReaderT (rebuildModuleOpen makeEnv externs m) env))) pure (RebuildSuccess (toJSONErrors False P.Warning warnings)) -- | Rebuilds a module but opens up its export list first and stores the result -- inside the rebuild cache rebuildModuleOpen - :: (Ide m, MonadLogger m, MonadError PscIdeError m) + :: (Ide m, MonadLogger m) => MakeActionsEnv -> [P.ExternsFile] -> P.Module -> m () -rebuildModuleOpen makeEnv externs m = do +rebuildModuleOpen makeEnv externs m = void $ runExceptT $ do (openResult, _) <- liftIO . P.runMake P.defaultOptions . P.rebuildModule (buildMakeActions From c9446fb42c1499b264687f7c20493bfb83088754 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 22 Jan 2017 16:49:29 +0100 Subject: [PATCH 0637/1580] [psc-ide] Fix #2504 When commands started processing and the client then disconnected during the process the server crashed when trying to write to a vanished Handle. This catches the error, logs and ignores it. --- psc-ide-server/Main.hs | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/psc-ide-server/Main.hs b/psc-ide-server/Main.hs index 222203d570..8b214c88e4 100644 --- a/psc-ide-server/Main.hs +++ b/psc-ide-server/Main.hs @@ -29,6 +29,7 @@ import "monad-logger" Control.Monad.Logger import qualified Data.Text.IO as T import qualified Data.ByteString.Lazy.Char8 as BS8 import Data.Version (showVersion) +import GHC.IO.Exception (IOErrorType(..), IOException(..)) import Language.PureScript.Ide import Language.PureScript.Ide.Command import Language.PureScript.Ide.Util @@ -144,14 +145,21 @@ startServer port env = withSocketsDo $ do -- $(logDebug) ("Answer was: " <> T.pack (show result)) liftIO (hFlush stdout) case result of - Right r -> liftIO $ BS8.hPutStrLn h (Aeson.encode r) - Left err -> liftIO $ BS8.hPutStrLn h (Aeson.encode err) + Right r -> liftIO $ catchGoneHandle (BS8.hPutStrLn h (Aeson.encode r)) + Left err -> liftIO $ catchGoneHandle (BS8.hPutStrLn h (Aeson.encode err)) Nothing -> do $(logError) ("Parsing the command failed. Command: " <> cmd) liftIO $ do - T.hPutStrLn h (encodeT (GeneralError "Error parsing Command.")) + catchGoneHandle (T.hPutStrLn h (encodeT (GeneralError "Error parsing Command."))) hFlush stdout - liftIO (hClose h) + liftIO $ catchGoneHandle (hClose h) + +catchGoneHandle :: IO () -> IO () +catchGoneHandle = + handle (\e -> case e of + IOError { ioe_type = ResourceVanished } -> + putText ("[Error] psc-ide-server tried interact with the handle, but the connection was already gone.") + _ -> throwIO e) acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m) => Socket -> m (Text, Handle) From a1a37e6c3e62637514bfb0d2f376dce50cc2b303 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 23 Jan 2017 06:41:48 +0100 Subject: [PATCH 0638/1580] [psc-ide] Collect type class instances (#2592) * [psc-ide] Add instances field to IdeTypeClass declarations * introduces ModuleMap synonym * decompose instance extraction * remove Module alias. This is way too ambiguous of a Name in the context of psc-ide * cleans up resolving pipeline stops lots of redundant ModuleNames being passed around and simplifies some of the types involved * test instance resolving --- purescript.cabal | 1 + src/Language/PureScript/Ide/Completion.hs | 3 + src/Language/PureScript/Ide/Externs.hs | 25 +++-- src/Language/PureScript/Ide/Filter.hs | 2 + src/Language/PureScript/Ide/Imports.hs | 4 +- src/Language/PureScript/Ide/Rebuild.hs | 6 +- src/Language/PureScript/Ide/Reexports.hs | 55 ++++++---- src/Language/PureScript/Ide/State.hs | 101 +++++++++++++----- src/Language/PureScript/Ide/Types.hs | 27 +++-- src/Language/PureScript/Ide/Util.hs | 19 ++-- tests/Language/PureScript/Ide/FilterSpec.hs | 2 + tests/Language/PureScript/Ide/ImportsSpec.hs | 2 +- .../Language/PureScript/Ide/ReexportsSpec.hs | 28 ++--- tests/Language/PureScript/Ide/StateSpec.hs | 66 +++++++++--- 14 files changed, 235 insertions(+), 106 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index c81d3d2e07..307f242504 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -542,6 +542,7 @@ test-suite tests hspec -any, hspec-discover -any, HUnit -any, + lens -any, mtl -any, optparse-applicative -any, parsec -any, diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 181dbe0c0a..81f68d7846 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -8,6 +8,9 @@ import Protolude import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types +import qualified Language.PureScript as P + +type Module = (P.ModuleName, [IdeDeclarationAnn]) -- | Applies the CompletionFilters and the Matcher to the given Modules -- and sorts the found Completions according to the Matching Score diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index e50fb12fee..652e36f426 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -54,9 +54,9 @@ readExternFile fp = do where version = toS (showVersion P.version) -convertExterns :: P.ExternsFile -> (Module, [(P.ModuleName, P.DeclarationRef)]) +convertExterns :: P.ExternsFile -> ([IdeDeclarationAnn], [(P.ModuleName, P.DeclarationRef)]) convertExterns ef = - ((P.efModuleName ef, decls), exportDecls) + (decls, exportDecls) where decls = map (IdeDeclarationAnn emptyAnn) @@ -71,8 +71,10 @@ convertExterns ef = removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration] removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate) - where notDuplicate (IdeDeclType t) = n ^. properNameT /= t ^. ideTypeName . properNameT - notDuplicate (IdeDeclTypeSynonym s) = n ^. properNameT /= s ^. ideSynonymName . properNameT + where notDuplicate (IdeDeclType t) = + n ^. ideTCName . properNameT /= t ^. ideTypeName . properNameT + notDuplicate (IdeDeclTypeSynonym s) = + n ^. ideTCName . properNameT /= s ^. ideSynonymName . properNameT notDuplicate _ = True removeTypeDeclarationsForClass _ = mempty @@ -93,7 +95,8 @@ convertDecl P.EDDataConstructor{..} = Just $ IdeDeclDataConstructor $ IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType convertDecl P.EDValue{..} = Just $ IdeDeclValue $ IdeValue edValueName edValueType -convertDecl P.EDClass{..} = Just (IdeDeclTypeClass edClassName) +convertDecl P.EDClass{..} = Just $ IdeDeclTypeClass $ + IdeTypeClass edClassName [] convertDecl P.EDKind{..} = Just (IdeDeclKind edKindName) convertDecl P.EDInstance{} = Nothing @@ -117,10 +120,10 @@ convertTypeOperator P.ExternsTypeFixity{..} = annotateModule :: (DefinitionSites P.SourceSpan, TypeAnnotations) - -> Module - -> Module -annotateModule (defs, types) (moduleName, decls) = - (moduleName, map convertDeclaration decls) + -> [IdeDeclarationAnn] + -> [IdeDeclarationAnn] +annotateModule (defs, types) decls = + map convertDeclaration decls where convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn convertDeclaration (IdeDeclarationAnn ann d) = case d of @@ -132,8 +135,8 @@ annotateModule (defs, types) (moduleName, decls) = annotateType (s ^. ideSynonymName . properNameT) (IdeDeclTypeSynonym s) IdeDeclDataConstructor dtor -> annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor) - IdeDeclTypeClass i -> - annotateType (i ^. properNameT) (IdeDeclTypeClass i) + IdeDeclTypeClass tc -> + annotateType (tc ^. ideTCName . properNameT) (IdeDeclTypeClass tc) IdeDeclValueOperator op -> annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op) IdeDeclTypeOperator op -> diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 5648028b32..b15120c70c 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -32,6 +32,8 @@ import Language.PureScript.Ide.Util newtype Filter = Filter (Endo [Module]) deriving(Monoid) +type Module = (P.ModuleName, [IdeDeclarationAnn]) + mkFilter :: ([Module] -> [Module]) -> Filter mkFilter = Filter . Endo diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index b8ad743f2f..b12ec75d94 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -197,8 +197,8 @@ addExplicitImport' decl moduleName imports = then imports else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports where - refFromDeclaration (IdeDeclTypeClass n) = - P.TypeClassRef n + refFromDeclaration (IdeDeclTypeClass tc) = + P.TypeClassRef (tc ^. ideTCName) refFromDeclaration (IdeDeclDataConstructor dtor) = P.TypeRef (dtor ^. ideDtorTypeName) Nothing refFromDeclaration (IdeDeclType t) = diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 6641582eff..61215928f6 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -103,8 +103,8 @@ rebuildModuleOpen makeEnv externs m = void $ runExceptT $ do data MakeActionsEnv = MakeActionsEnv { maeOutputDirectory :: FilePath - , maeFilePathMap :: Map P.ModuleName (Either P.RebuildPolicy FilePath) - , maeForeignPathMap :: Map P.ModuleName FilePath + , maeFilePathMap :: ModuleMap (Either P.RebuildPolicy FilePath) + , maeForeignPathMap :: ModuleMap FilePath , maePrefixComment :: Bool } @@ -134,7 +134,7 @@ shushCodegen ma MakeActionsEnv{..} = sortExterns :: (Ide m, MonadError PscIdeError m) => P.Module - -> Map P.ModuleName P.ExternsFile + -> ModuleMap P.ExternsFile -> m [P.ExternsFile] sortExterns m ex = do sorted' <- runExceptT diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 47f19270fa..370503c81e 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -18,25 +18,25 @@ module Language.PureScript.Ide.Reexports , prettyPrintReexportResult , reexportHasFailures , ReexportResult(..) + -- for tests + , resolveReexports' ) where import Protolude -import Control.Lens hiding ((&)) - import qualified Data.Map as Map import qualified Language.PureScript as P import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util --- | Contains the module with resolved reexports, and eventual failures +-- | Contains the module with resolved reexports, and possible failures data ReexportResult a = ReexportResult { reResolved :: a , reFailed :: [(P.ModuleName, P.DeclarationRef)] } deriving (Show, Eq, Functor) --- | Uses the passed formatter to format the resolved module, and adds eventual +-- | Uses the passed formatter to format the resolved module, and adds possible -- failures prettyPrintReexportResult :: (a -> Text) @@ -56,16 +56,27 @@ prettyPrintReexportResult f ReexportResult{..} reexportHasFailures :: ReexportResult a -> Bool reexportHasFailures = not . null . reFailed --- | Resolves Reexports for a given Module, by looking up the reexported values --- from the passed in Map +-- | Resolves Reexports for the given Modules, by looking up the reexported +-- values from the passed in DeclarationRefs resolveReexports - :: Map P.ModuleName [IdeDeclarationAnn] + :: ModuleMap [(P.ModuleName, P.DeclarationRef)] + -- ^ the references to resolve + -> ModuleMap [IdeDeclarationAnn] -- ^ Modules to search for the reexported declarations - -> (Module, [(P.ModuleName, P.DeclarationRef)]) - -- ^ The module to resolve reexports for, aswell as the references to resolve - -> ReexportResult Module -resolveReexports modules ((moduleName, decls), refs) = - ReexportResult (moduleName, decls <> concat resolvedRefs) failedRefs + -> ModuleMap (ReexportResult [IdeDeclarationAnn]) +resolveReexports reexportRefs modules = + Map.mapWithKey (\moduleName decls -> + maybe (ReexportResult decls []) + (resolveReexports' modules decls) + (Map.lookup moduleName reexportRefs)) modules + +resolveReexports' + :: ModuleMap [IdeDeclarationAnn] + -> [IdeDeclarationAnn] + -> [(P.ModuleName, P.DeclarationRef)] + -> ReexportResult [IdeDeclarationAnn] +resolveReexports' modules decls refs = + ReexportResult (decls <> concat resolvedRefs) failedRefs where (failedRefs, resolvedRefs) = partitionEithers (resolveRef' <$> refs) resolveRef' x@(mn, r) = case Map.lookup mn modules of @@ -78,7 +89,7 @@ resolveRef -> Either P.DeclarationRef [IdeDeclarationAnn] resolveRef decls ref = case ref of P.TypeRef tn mdtors -> - case findRef (\x -> x ^? _IdeDeclType . ideTypeName <&> (== tn) & fromMaybe False) of + case findRef (lensSatisfies (_IdeDeclType . ideTypeName) (== tn)) of Nothing -> Left ref Just d -> Right $ d : case mdtors of Nothing -> @@ -88,13 +99,13 @@ resolveRef decls ref = case ref of findDtors tn Just dtors -> mapMaybe lookupDtor dtors P.ValueRef i -> - findWrapped (\x -> x ^? _IdeDeclValue . ideValueIdent <&> (== i) & fromMaybe False) + findWrapped (lensSatisfies (_IdeDeclValue . ideValueIdent) (== i)) P.ValueOpRef name -> - findWrapped (\x -> x ^? _IdeDeclValueOperator . ideValueOpName <&> (== name) & fromMaybe False) + findWrapped (lensSatisfies (_IdeDeclValueOperator . ideValueOpName) (== name)) P.TypeOpRef name -> - findWrapped (\x -> x ^? _IdeDeclTypeOperator . ideTypeOpName <&> (== name) & fromMaybe False) + findWrapped (lensSatisfies (_IdeDeclTypeOperator . ideTypeOpName) (== name)) P.TypeClassRef name -> - findWrapped (\case IdeDeclTypeClass n -> n == name; _ -> False) + findWrapped (lensSatisfies (_IdeDeclTypeClass . ideTCName) (== name)) _ -> Left ref where @@ -102,9 +113,9 @@ resolveRef decls ref = case ref of findRef f = find (f . discardAnn) decls lookupDtor name = - findRef (\x -> x ^? _IdeDeclDataConstructor . ideDtorName <&> (== name) & fromMaybe False) + findRef (lensSatisfies (_IdeDeclDataConstructor . ideDtorName) (== name)) - findDtors tn = filter (f . discardAnn) decls - where - f :: IdeDeclaration -> Bool - f decl = decl ^? _IdeDeclDataConstructor . ideDtorTypeName <&> (== tn) & fromMaybe False + findDtors tn = filter (lensSatisfies + (idaDeclaration + . _IdeDeclDataConstructor + . ideDtorTypeName) (== tn)) decls diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index f24ad0c4a7..bc5ac625a4 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -14,6 +14,7 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedFieldPuns #-} module Language.PureScript.Ide.State ( getLoadedModulenames @@ -29,10 +30,12 @@ module Language.PureScript.Ide.State , populateStage3STM -- for tests , resolveOperatorsForModule + , resolveInstances ) where import Protolude +import Control.Arrow import Control.Concurrent.STM import Control.Lens hiding (op, (&)) import "monad-logger" Control.Monad.Logger @@ -58,7 +61,7 @@ getLoadedModulenames :: Ide m => m [P.ModuleName] getLoadedModulenames = Map.keys <$> getExternFiles -- | Gets all loaded ExternFiles -getExternFiles :: Ide m => m (Map P.ModuleName ExternsFile) +getExternFiles :: Ide m => m (ModuleMap ExternsFile) getExternFiles = s1Externs <$> getStage1 -- | Insert a Module into Stage1 of the State @@ -121,7 +124,7 @@ setStage3STM ref s3 = do -- | Checks if the given ModuleName matches the last rebuild cache and if it -- does returns all loaded definitions + the definitions inside the rebuild -- cache -getAllModules :: Ide m => Maybe P.ModuleName -> m [Module] +getAllModules :: Ide m => Maybe P.ModuleName -> m [(P.ModuleName, [IdeDeclarationAnn])] getAllModules mmoduleName = do declarations <- s3Declarations <$> getStage3 rebuild <- cachedRebuild @@ -136,7 +139,7 @@ getAllModules mmoduleName = do ast = fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts) cachedModule = - snd . annotateModule ast . fst . convertExterns $ ef + annotateModule ast (fst (convertExterns ef)) tmp = Map.insert moduleName cachedModule declarations resolved = @@ -192,43 +195,84 @@ populateStage3 = do st <- ideStateVar <$> ask let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration results <- logPerf message (liftIO (atomically (populateStage3STM st))) - traverse_ - (logWarnN . prettyPrintReexportResult (P.runModuleName . fst)) - (filter reexportHasFailures results) + void $ Map.traverseWithKey + (\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn))) + (Map.filter reexportHasFailures results) -- | STM version of populateStage3 -populateStage3STM :: TVar IdeState -> STM [ReexportResult Module] +populateStage3STM + :: TVar IdeState + -> STM (ModuleMap (ReexportResult [IdeDeclarationAnn])) populateStage3STM ref = do externs <- s1Externs <$> getStage1STM ref (AstData asts) <- s2AstData <$> getStage2STM ref - let modules = Map.map convertExterns externs - nModules :: Map P.ModuleName (Module, [(P.ModuleName, P.DeclarationRef)]) - nModules = Map.mapWithKey - (\moduleName (m, refs) -> - (fromMaybe m $ annotateModule <$> Map.lookup moduleName asts <*> pure m, refs)) modules - -- resolves reexports and discards load failures for now - result = resolveReexports (map (snd . fst) nModules) <$> Map.elems nModules - resultP = resolveOperators (Map.fromList (reResolved <$> result)) - setStage3STM ref (Stage3 resultP Nothing) - pure result + let (modules, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs) + results = + resolveLocations asts modules + & resolveInstances externs + & resolveOperators + & resolveReexports reexportRefs + setStage3STM ref (Stage3 (map reResolved results) Nothing) + pure results + + +resolveLocations + :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations) + -> ModuleMap [IdeDeclarationAnn] + -> ModuleMap [IdeDeclarationAnn] +resolveLocations asts = + Map.mapWithKey (\mn decls -> + maybe decls (flip annotateModule decls) (Map.lookup mn asts)) + +resolveInstances + :: ModuleMap P.ExternsFile + -> ModuleMap [IdeDeclarationAnn] + -> ModuleMap [IdeDeclarationAnn] +resolveInstances externs declarations = + Map.foldr (flip (foldr go)) declarations + . Map.mapWithKey (\mn ef -> mapMaybe (extractInstances mn) (efDeclarations ef)) + $ externs + where + extractInstances mn P.EDInstance{..} = + case edInstanceClassName of + P.Qualified (Just classModule) className -> + Just (IdeInstance mn + edInstanceName + edInstanceTypes + edInstanceConstraints, classModule, className) + _ -> Nothing + extractInstances _ _ = Nothing + + go :: + (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName) + -> ModuleMap [IdeDeclarationAnn] + -> ModuleMap [IdeDeclarationAnn] + go (ideInstance, classModule, className) acc' = + let + matchTC = + lensSatisfies (idaDeclaration . _IdeDeclTypeClass . ideTCName) (== className) + updateDeclaration = + mapIf matchTC (idaDeclaration + . _IdeDeclTypeClass + . ideTCInstances + %~ cons ideInstance) + in + acc' & ix classModule %~ updateDeclaration resolveOperators - :: Map P.ModuleName [IdeDeclarationAnn] - -> Map P.ModuleName [IdeDeclarationAnn] + :: ModuleMap [IdeDeclarationAnn] + -> ModuleMap [IdeDeclarationAnn] resolveOperators modules = map (resolveOperatorsForModule modules) modules -- | Looks up the types and kinds for operators and assigns them to their -- declarations resolveOperatorsForModule - :: Map P.ModuleName [IdeDeclarationAnn] + :: ModuleMap [IdeDeclarationAnn] -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] -resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator) +resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) where - hasName :: Eq b => Lens' a b -> b -> a -> Bool - hasName l a x = x ^. l == a - getDeclarations :: P.ModuleName -> [IdeDeclaration] getDeclarations moduleName = Map.lookup moduleName modules @@ -239,14 +283,14 @@ resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator) | (P.Qualified (Just mn) (Left ident)) <- op ^. ideValueOpAlias = let t = getDeclarations mn & mapMaybe (preview _IdeDeclValue) - & filter (hasName ideValueIdent ident) + & filter (lensSatisfies ideValueIdent (== ident)) & map (view ideValueType) & listToMaybe in IdeDeclValueOperator (op & ideValueOpType .~ t) | (P.Qualified (Just mn) (Right dtor)) <- op ^. ideValueOpAlias = let t = getDeclarations mn & mapMaybe (preview _IdeDeclDataConstructor) - & filter (hasName ideDtorName dtor) + & filter (lensSatisfies ideDtorName (== dtor)) & map (view ideDtorType) & listToMaybe in IdeDeclValueOperator (op & ideValueOpType .~ t) @@ -254,9 +298,12 @@ resolveOperatorsForModule modules = map ((over idaDeclaration) resolveOperator) | P.Qualified (Just mn) properName <- op ^. ideTypeOpAlias = let k = getDeclarations mn & mapMaybe (preview _IdeDeclType) - & filter (hasName ideTypeName properName) + & filter (lensSatisfies ideTypeName (== properName)) & map (view ideTypeKind) & listToMaybe in IdeDeclTypeOperator (op & ideTypeOpKind .~ k) resolveOperator x = x + +mapIf :: Functor f => (b -> Bool) -> (b -> b) -> f b -> f b +mapIf p f = map (\x -> if p x then f x else x) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 75e5d253ec..17a3443eba 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -27,13 +27,14 @@ import qualified Language.PureScript as P import qualified Language.PureScript.Errors.JSON as P type ModuleIdent = Text +type ModuleMap a = Map P.ModuleName a data IdeDeclaration = IdeDeclValue IdeValue | IdeDeclType IdeType | IdeDeclTypeSynonym IdeSynonym | IdeDeclDataConstructor IdeDataConstructor - | IdeDeclTypeClass (P.ProperName 'P.ClassName) + | IdeDeclTypeClass IdeTypeClass | IdeDeclValueOperator IdeValueOperator | IdeDeclTypeOperator IdeTypeOperator | IdeDeclKind (P.ProperName 'P.KindName) @@ -60,6 +61,18 @@ data IdeDataConstructor = IdeDataConstructor , _ideDtorType :: P.Type } deriving (Show, Eq, Ord) +data IdeTypeClass = IdeTypeClass + { _ideTCName :: P.ProperName 'P.ClassName + , _ideTCInstances :: [IdeInstance] + } deriving (Show, Eq, Ord) + +data IdeInstance = IdeInstance + { _ideInstanceModule :: P.ModuleName + , _ideInstanceName :: P.Ident + , _ideInstanceTypes :: [P.Type] + , _ideInstanceConstraints :: Maybe [P.Constraint] + } deriving (Show, Eq, Ord) + data IdeValueOperator = IdeValueOperator { _ideValueOpName :: P.OpName 'P.ValueOpName , _ideValueOpAlias :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) @@ -81,6 +94,8 @@ makeLenses ''IdeValue makeLenses ''IdeType makeLenses ''IdeSynonym makeLenses ''IdeDataConstructor +makeLenses ''IdeTypeClass +makeLenses ''IdeInstance makeLenses ''IdeValueOperator makeLenses ''IdeTypeOperator @@ -101,11 +116,9 @@ makeLenses ''IdeDeclarationAnn emptyAnn :: Annotation emptyAnn = Annotation Nothing Nothing Nothing -type Module = (P.ModuleName, [IdeDeclarationAnn]) - type DefinitionSites a = Map IdeDeclNamespace a type TypeAnnotations = Map P.Ident P.Type -newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotations)) +newtype AstData a = AstData (ModuleMap (DefinitionSites a, TypeAnnotations)) -- ^ SourceSpans for the definition sites of Values and Types aswell as type -- annotations found in a module deriving (Show, Eq, Ord, Functor, Foldable) @@ -147,8 +160,8 @@ emptyStage3 :: Stage3 emptyStage3 = Stage3 M.empty Nothing data Stage1 = Stage1 - { s1Externs :: M.Map P.ModuleName P.ExternsFile - , s1Modules :: M.Map P.ModuleName (P.Module, FilePath) + { s1Externs :: ModuleMap P.ExternsFile + , s1Modules :: ModuleMap (P.Module, FilePath) } data Stage2 = Stage2 @@ -156,7 +169,7 @@ data Stage2 = Stage2 } data Stage3 = Stage3 - { s3Declarations :: M.Map P.ModuleName [IdeDeclarationAnn] + { s3Declarations :: ModuleMap [IdeDeclarationAnn] , s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile) } diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 4edc026c5d..21f259648f 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -27,15 +27,17 @@ module Language.PureScript.Ide.Util , prettyTypeT , properNameT , identT + , lensSatisfies , module Language.PureScript.Ide.Logging ) where import Protolude hiding (decodeUtf8, encodeUtf8) -import Control.Lens ((^.), Iso', iso) +import Control.Lens ((^.), (^?), Iso', iso, Getting, (<&>)) import Data.Aeson import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) import qualified Language.PureScript as P import Language.PureScript.Ide.Logging @@ -47,7 +49,7 @@ identifierFromIdeDeclaration d = case d of IdeDeclType t -> t ^. ideTypeName . properNameT IdeDeclTypeSynonym s -> s ^. ideSynonymName . properNameT IdeDeclDataConstructor dtor -> dtor ^. ideDtorName . properNameT - IdeDeclTypeClass name -> P.runProperName name + IdeDeclTypeClass tc -> tc ^. ideTCName . properNameT IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName IdeDeclKind name -> P.runProperName name @@ -67,14 +69,14 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) = where (complIdentifier, complExpandedType) = case decl of IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyTypeT) - IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind & toS ) + IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind) IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT) IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT) - IdeDeclTypeClass name -> (P.runProperName name, "class") + IdeDeclTypeClass d -> (d ^. ideTCName . properNameT, "type class") IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) -> (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP) IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) -> - (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind) + (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) P.prettyPrintKind kind) IdeDeclKind k -> (P.runProperName k, "kind") complModule = P.runModuleName m @@ -103,10 +105,10 @@ typeOperatorAliasT i = P.showQualified P.runProperName i encodeT :: (ToJSON a) => a -> Text -encodeT = toS . decodeUtf8 . encode +encodeT = TL.toStrict . decodeUtf8 . encode decodeT :: (FromJSON a) => Text -> Maybe a -decodeT = decode . encodeUtf8 . toS +decodeT = decode . encodeUtf8 . TL.fromStrict unwrapPositioned :: P.Declaration -> P.Declaration unwrapPositioned (P.PositionedDeclaration _ _ x) = unwrapPositioned x @@ -129,3 +131,6 @@ prettyTypeT = . T.lines . T.pack . P.prettyPrintTypeWithUnicode + +lensSatisfies :: forall a s. Getting (First a) s a -> (a -> Bool) -> s -> Bool +lensSatisfies getter predicate value = value ^? getter <&> predicate & fromMaybe False diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index 3b4cfc2d92..f129b18338 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -8,6 +8,8 @@ import Language.PureScript.Ide.Types import qualified Language.PureScript as P import Test.Hspec +type Module = (P.ModuleName, [IdeDeclarationAnn]) + value :: Text -> IdeDeclarationAnn value s = IdeDeclarationAnn emptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.REmpty)) diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index e830ed01c8..0d9ff8b538 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -144,7 +144,7 @@ spec = do addImport imports import' = addExplicitImport' import' moduleName imports valueImport ident = (IdeDeclValue (IdeValue (P.Ident ident) wildcard)) typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.kindType)) - classImport name = (IdeDeclTypeClass (P.ProperName name)) + classImport name = (IdeDeclTypeClass (IdeTypeClass (P.ProperName name) [])) dtorImport name typeName = (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName name) (P.ProperName typeName) wildcard)) -- expect any list of provided identifiers, when imported, to come out as specified expectSorted imports expected = shouldBe diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index adbdc743b0..c260c4ee1e 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -10,6 +10,8 @@ import Language.PureScript.Ide.Types import qualified Language.PureScript as P import Test.Hspec +type Module = (P.ModuleName, [IdeDeclarationAnn]) + m :: Text -> P.ModuleName m = P.moduleNameFromString @@ -19,32 +21,32 @@ d = IdeDeclarationAnn emptyAnn valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn valueA = d (IdeDeclValue (IdeValue (P.Ident "valueA") P.REmpty)) typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.kindType)) -classA = d (IdeDeclTypeClass (P.ProperName "ClassA")) +classA = d (IdeDeclTypeClass (IdeTypeClass (P.ProperName "ClassA") [])) dtorA1 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty)) dtorA2 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty)) -env :: Map P.ModuleName [IdeDeclarationAnn] +env :: ModuleMap [IdeDeclarationAnn] env = Map.fromList [ (m "A", [valueA, typeA, classA, dtorA1, dtorA2]) ] type Refs = [(P.ModuleName, P.DeclarationRef)] -succTestCases :: [(Text, Module, Refs, Module)] +succTestCases :: [(Text, [IdeDeclarationAnn], Refs, [IdeDeclarationAnn])] succTestCases = - [ ("resolves a value reexport", (m "C", []), [(m "A", P.ValueRef (P.Ident "valueA"))], (m "C", [valueA])) + [ ("resolves a value reexport", [], [(m "A", P.ValueRef (P.Ident "valueA"))], [valueA]) , ("resolves a type reexport with explicit data constructors" - , (m "C", []), [(m "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], (m "C", [typeA, dtorA1])) + , [], [(m "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], [typeA, dtorA1]) , ("resolves a type reexport with implicit data constructors" - , (m "C", []), [(m "A", P.TypeRef (P.ProperName "TypeA") Nothing)], (m "C", [typeA, dtorA1, dtorA2])) - , ("resolves a class reexport", (m "C", []), [(m "A", P.TypeClassRef (P.ProperName "ClassA"))], (m "C", [classA])) + , [], [(m "A", P.TypeRef (P.ProperName "TypeA") Nothing)], [typeA, dtorA1, dtorA2]) + , ("resolves a class reexport", [], [(m "A", P.TypeClassRef (P.ProperName "ClassA"))], [classA]) ] -failTestCases :: [(Text, Module, Refs)] +failTestCases :: [(Text, [IdeDeclarationAnn], Refs)] failTestCases = - [ ("fails to resolve a non existing value", (m "C", []), [(m "A", P.ValueRef (P.Ident "valueB"))]) - , ("fails to resolve a non existing type reexport" , (m "C", []), [(m "A", P.TypeRef (P.ProperName "TypeB") Nothing)]) - , ("fails to resolve a non existing class reexport", (m "C", []), [(m "A", P.TypeClassRef (P.ProperName "ClassB"))]) + [ ("fails to resolve a non existing value", [], [(m "A", P.ValueRef (P.Ident "valueB"))]) + , ("fails to resolve a non existing type reexport" , [], [(m "A", P.TypeRef (P.ProperName "TypeB") Nothing)]) + , ("fails to resolve a non existing class reexport", [], [(m "A", P.TypeClassRef (P.ProperName "ClassB"))]) ] spec :: Spec @@ -52,12 +54,12 @@ spec = do describe "Successful Reexports" $ for_ succTestCases $ \(desc, initial, refs, result) -> it (toS desc) $ do - let reResult = resolveReexports env (initial, refs) + let reResult = resolveReexports' env initial refs reResolved reResult `shouldBe` result reResult `shouldSatisfy` not . reexportHasFailures describe "Failed Reexports" $ for_ failTestCases $ \(desc, initial, refs) -> it (toS desc) $ do - let reResult = resolveReexports env (initial, refs) + let reResult = resolveReexports' env initial refs reFailed reResult `shouldBe` refs reResult `shouldSatisfy` reexportHasFailures diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index 5126fe24f5..a4a546a175 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -3,6 +3,7 @@ module Language.PureScript.Ide.StateSpec where import Protolude +import Control.Lens hiding ((&)) import Language.PureScript.Ide.Types import Language.PureScript.Ide.State import qualified Language.PureScript as P @@ -21,7 +22,7 @@ typeOperator :: Maybe P.Kind -> IdeDeclarationAnn typeOperator = d . IdeDeclTypeOperator . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix -testModule :: Module +testModule :: (P.ModuleName, [IdeDeclarationAnn]) testModule = (mn "Test", [ d (IdeDeclValue (IdeValue (P.Ident "function") P.REmpty)) , d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty))) , d (IdeDeclType (IdeType (P.ProperName "List") P.kindType)) @@ -34,18 +35,57 @@ d :: IdeDeclaration -> IdeDeclarationAnn d = IdeDeclarationAnn emptyAnn mn :: Text -> P.ModuleName -mn = P.moduleNameFromString . toS +mn = P.moduleNameFromString -testState :: Map P.ModuleName [IdeDeclarationAnn] -testState = Map.fromList - [ testModule - ] +testState :: ModuleMap [IdeDeclarationAnn] +testState = Map.fromList [testModule] + +-- The accessor fields for these data types are not exposed unfortunately +ef :: P.ExternsFile +ef = P.ExternsFile + -- { efVersion = + mempty + -- , efModuleName = + (mn "InstanceModule") + -- , efExports = + mempty + -- , efImports = + mempty + -- , efFixities = + mempty + -- , efTypeFixities = + mempty + --, efDeclarations = + [ P.EDInstance + -- { edInstanceClassName = + (P.Qualified (Just (mn "ClassModule")) (P.ProperName "MyClass")) + -- , edInstanceName = + (P.Ident "myClassInstance") + -- , edInstanceTypes = + mempty + -- , edInstanceConstraints = + mempty + -- } + ] + -- } + +moduleMap :: ModuleMap [IdeDeclarationAnn] +moduleMap = Map.singleton (mn "ClassModule") [d (IdeDeclTypeClass (IdeTypeClass (P.ProperName "MyClass") []))] + +ideInstance :: IdeInstance +ideInstance = IdeInstance (mn "InstanceModule") (P.Ident "myClassInstance") mempty mempty spec :: Spec -spec = describe "resolving operators" $ do - it "resolves the type for a value operator" $ - resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (valueOperator (Just P.REmpty)) - it "resolves the type for a constructor operator" $ - resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.REmpty)) - it "resolves the kind for a type operator" $ - resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.kindType)) +spec = do + describe "resolving operators" $ do + it "resolves the type for a value operator" $ + resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (valueOperator (Just P.REmpty)) + it "resolves the type for a constructor operator" $ + resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.REmpty)) + it "resolves the kind for a type operator" $ + resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.kindType)) + describe "resolving instances for type classes" $ do + it "resolves an instance for an existing type class" $ do + resolveInstances (Map.singleton (mn "InstanceModule") ef) moduleMap + `shouldSatisfy` + elemOf (ix (mn "ClassModule") . ix 0 . idaDeclaration . _IdeDeclTypeClass . ideTCInstances . folded) ideInstance From 220e6ae1797edd461dcdd31f0e851a3530fbbc91 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 24 Jan 2017 21:10:34 +0100 Subject: [PATCH 0639/1580] [psc-ide] Restructure testing to avoid running the server (#2599) * rename IdeDeclTypeSynonym * wip * get rid of integration tests for SourceFile * merge fixes * lensSatisfies is actually anyOf * ctors for operators * ports Rebuild Spec to new test suite * ports Import integration tests to new testing api * remove Integration module && don't start a psc-ide-server for tests * add synchronous versions of load and rebuild for tests * revert Synonym name change * unify Sync rebuild and load design * remove unused dependencies --- purescript.cabal | 9 +- src/Language/PureScript/Ide.hs | 44 ++- src/Language/PureScript/Ide/Command.hs | 4 + src/Language/PureScript/Ide/Error.hs | 1 + src/Language/PureScript/Ide/Externs.hs | 2 +- src/Language/PureScript/Ide/Rebuild.hs | 36 ++- src/Language/PureScript/Ide/Reexports.hs | 15 +- src/Language/PureScript/Ide/State.hs | 8 +- src/Language/PureScript/Ide/Types.hs | 6 +- src/Language/PureScript/Ide/Util.hs | 6 +- .../PureScript/Ide/Imports/IntegrationSpec.hs | 83 ------ tests/Language/PureScript/Ide/ImportsSpec.hs | 65 ++++ tests/Language/PureScript/Ide/Integration.hs | 280 ------------------ tests/Language/PureScript/Ide/MatcherSpec.hs | 13 - tests/Language/PureScript/Ide/RebuildSpec.hs | 78 ++--- .../Ide/SourceFile/IntegrationSpec.hs | 41 --- .../Language/PureScript/Ide/SourceFileSpec.hs | 42 +++ tests/Language/PureScript/Ide/Test.hs | 135 +++++++++ tests/TestPscIde.hs | 8 +- 19 files changed, 376 insertions(+), 500 deletions(-) delete mode 100644 tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs delete mode 100644 tests/Language/PureScript/Ide/Integration.hs delete mode 100644 tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs create mode 100644 tests/Language/PureScript/Ide/Test.hs diff --git a/purescript.cabal b/purescript.cabal index 307f242504..6b606a2b44 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -496,7 +496,6 @@ executable psc-ide-server aeson >= 0.8 && < 1.0, bytestring -any, purescript -any, - base-compat >=0.6.0, directory -any, filepath -any, monad-logger -any, @@ -506,8 +505,7 @@ executable psc-ide-server protolude >= 0.1.6, stm -any, text -any, - transformers -any, - transformers-compat -any + transformers -any ghc-options: -Wall -O2 -threaded hs-source-dirs: psc-ide-server @@ -543,6 +541,7 @@ test-suite tests hspec-discover -any, HUnit -any, lens -any, + monad-logger -any, mtl -any, optparse-applicative -any, parsec -any, @@ -567,14 +566,12 @@ test-suite tests TestPsci TestPscIde PscIdeSpec + Language.PureScript.Ide.Test Language.PureScript.Ide.FilterSpec Language.PureScript.Ide.ImportsSpec - Language.PureScript.Ide.Imports.IntegrationSpec - Language.PureScript.Ide.Integration Language.PureScript.Ide.MatcherSpec Language.PureScript.Ide.RebuildSpec Language.PureScript.Ide.ReexportsSpec - Language.PureScript.Ide.SourceFile.IntegrationSpec Language.PureScript.Ide.SourceFileSpec Language.PureScript.Ide.StateSpec buildable: True diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 77af155b29..1997be4259 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -47,9 +47,13 @@ handleCommand :: (Ide m, MonadLogger m, MonadError PscIdeError m) => Command -> m Success handleCommand c = case c of Load [] -> - findAvailableExterns >>= loadModules + findAvailableExterns >>= loadModulesAsync Load modules -> - loadModules modules + loadModulesAsync modules + LoadSync [] -> + findAvailableExterns >>= loadModulesSync + LoadSync modules -> + loadModulesSync modules Type search filters currentModule -> findType search filters currentModule Complete filters matcher currentModule -> @@ -78,7 +82,9 @@ handleCommand c = case c of Left question -> pure (CompletionResult (map (completionFromMatch . map withEmptyAnn) question)) Rebuild file -> - rebuildFile file + rebuildFileAsync file + RebuildSync file -> + rebuildFileSync file Cwd -> TextResult . toS <$> liftIO getCurrentDirectory Reset -> @@ -162,6 +168,31 @@ findAllSourceFiles = do -- server state. Then proceeds to parse all the specified sourcefiles and -- inserts their ASTs into the state. Finally kicks off an async worker, which -- populates Stage 2 and 3 of the state. +loadModulesAsync + :: (Ide m, MonadError PscIdeError m, MonadLogger m) + => [P.ModuleName] + -> m Success +loadModulesAsync moduleNames = do + tr <- loadModules moduleNames + + -- Finally we kick off the worker with @async@ and return the number of + -- successfully parsed modules. + env <- ask + let ll = confLogLevel (ideConfiguration env) + -- populateStage2 and 3 return Unit for now, so it's fine to discard this + -- result. We might want to block on this in a benchmarking situation. + _ <- liftIO (async (runLogger ll (runReaderT (populateStage2 *> populateStage3) env))) + pure tr + +loadModulesSync + :: (Ide m, MonadError PscIdeError m, MonadLogger m) + => [P.ModuleName] + -> m Success +loadModulesSync moduleNames = do + tr <- loadModules moduleNames + populateStage2 *> populateStage3 + pure tr + loadModules :: (Ide m, MonadError PscIdeError m, MonadLogger m) => [P.ModuleName] @@ -182,12 +213,5 @@ loadModules moduleNames = do $(logWarn) ("Failed to parse: " <> show failures) traverse_ insertModule allModules - -- Finally we kick off the worker with @async@ and return the number of - -- successfully parsed modules. - env <- ask - let ll = confLogLevel (ideConfiguration env) - -- populateStage2 and 3 return Unit for now, so it's fine to discard this - -- result. We might want to block on this in a benchmarking situation. - _ <- liftIO (async (runLogger ll (runReaderT (populateStage2 *> populateStage3) env))) pure (TextResult ("Loaded " <> show (length efiles) <> " modules and " <> show (length allModules) <> " source files.")) diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index c51015fc09..e9999a809a 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -25,6 +25,7 @@ import Language.PureScript.Ide.Types data Command = Load [P.ModuleName] + | LoadSync [P.ModuleName] -- used in tests | Type { typeSearch :: Text , typeFilters :: [Filter] @@ -54,6 +55,7 @@ data Command | Import FilePath (Maybe FilePath) [Filter] ImportCommand | List { listType :: ListType } | Rebuild FilePath -- ^ Rebuild the specified file using the loaded externs + | RebuildSync FilePath -- ^ Rebuild the specified file using the loaded externs | Cwd | Reset | Quit @@ -61,6 +63,7 @@ data Command commandName :: Command -> Text commandName c = case c of Load{} -> "Load" + LoadSync{} -> "LoadSync" Type{} -> "Type" Complete{} -> "Complete" Pursuit{} -> "Pursuit" @@ -69,6 +72,7 @@ commandName c = case c of Import{} -> "Import" List{} -> "List" Rebuild{} -> "Rebuild" + RebuildSync{} -> "RebuildSync" Cwd{} -> "Cwd" Reset{} -> "Reset" Quit{} -> "Quit" diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 44ee78e880..a72cd077b1 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -29,6 +29,7 @@ data PscIdeError | ModuleFileNotFound ModuleIdent | ParseError P.ParseError Text | RebuildError [JSONError] + deriving (Show, Eq) instance ToJSON PscIdeError where toJSON (RebuildError errs) = object diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 652e36f426..cdbf8d47c3 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -90,7 +90,7 @@ convertDecl :: P.ExternsDeclaration -> Maybe IdeDeclaration convertDecl P.EDType{..} = Just $ IdeDeclType $ IdeType edTypeName edTypeKind convertDecl P.EDTypeSynonym{..} = Just $ IdeDeclTypeSynonym - (IdeSynonym edTypeSynonymName edTypeSynonymType) + (IdeTypeSynonym edTypeSynonymName edTypeSynonymType) convertDecl P.EDDataConstructor{..} = Just $ IdeDeclDataConstructor $ IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType convertDecl P.EDValue{..} = Just $ IdeDeclValue $ diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 61215928f6..2ae6c3129a 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -2,7 +2,9 @@ {-# LANGUAGE TemplateHaskell #-} module Language.PureScript.Ide.Rebuild - ( rebuildFile + ( rebuildFileSync + , rebuildFileAsync + , rebuildFile ) where import Protolude @@ -38,8 +40,11 @@ import System.IO.UTF8 (readUTF8FileT) rebuildFile :: (Ide m, MonadLogger m, MonadError PscIdeError m) => FilePath + -- ^ The file to rebuild + -> (ReaderT IdeEnvironment (LoggingT IO) () -> m ()) + -- ^ A runner for the second build with open exports -> m Success -rebuildFile path = do +rebuildFile path runOpenBuild = do input <- liftIO (readUTF8FileT path) @@ -71,11 +76,32 @@ rebuildFile path = do case result of Left errors -> throwError (RebuildError (toJSONErrors False P.Error errors)) Right _ -> do - env <- ask - let ll = confLogLevel (ideConfiguration env) - _ <- liftIO (async (runLogger ll (runReaderT (rebuildModuleOpen makeEnv externs m) env))) + runOpenBuild (rebuildModuleOpen makeEnv externs m) pure (RebuildSuccess (toJSONErrors False P.Warning warnings)) +rebuildFileAsync + :: forall m. (Ide m, MonadLogger m, MonadError PscIdeError m) + => FilePath -> m Success +rebuildFileAsync fp = rebuildFile fp asyncRun + where + asyncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m () + asyncRun action = do + env <- ask + let ll = confLogLevel (ideConfiguration env) + void (liftIO (async (runLogger ll (runReaderT action env)))) + +rebuildFileSync + :: forall m. (Ide m, MonadLogger m, MonadError PscIdeError m) + => FilePath -> m Success +rebuildFileSync fp = rebuildFile fp syncRun + where + syncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m () + syncRun action = do + env <- ask + let ll = confLogLevel (ideConfiguration env) + void (liftIO (runLogger ll (runReaderT action env))) + + -- | Rebuilds a module but opens up its export list first and stores the result -- inside the rebuild cache rebuildModuleOpen diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 370503c81e..367fc0ac99 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -24,6 +24,7 @@ module Language.PureScript.Ide.Reexports import Protolude +import Control.Lens hiding ((&)) import qualified Data.Map as Map import qualified Language.PureScript as P import Language.PureScript.Ide.Types @@ -89,7 +90,7 @@ resolveRef -> Either P.DeclarationRef [IdeDeclarationAnn] resolveRef decls ref = case ref of P.TypeRef tn mdtors -> - case findRef (lensSatisfies (_IdeDeclType . ideTypeName) (== tn)) of + case findRef (anyOf (_IdeDeclType . ideTypeName) (== tn)) of Nothing -> Left ref Just d -> Right $ d : case mdtors of Nothing -> @@ -99,13 +100,13 @@ resolveRef decls ref = case ref of findDtors tn Just dtors -> mapMaybe lookupDtor dtors P.ValueRef i -> - findWrapped (lensSatisfies (_IdeDeclValue . ideValueIdent) (== i)) + findWrapped (anyOf (_IdeDeclValue . ideValueIdent) (== i)) P.ValueOpRef name -> - findWrapped (lensSatisfies (_IdeDeclValueOperator . ideValueOpName) (== name)) + findWrapped (anyOf (_IdeDeclValueOperator . ideValueOpName) (== name)) P.TypeOpRef name -> - findWrapped (lensSatisfies (_IdeDeclTypeOperator . ideTypeOpName) (== name)) + findWrapped (anyOf (_IdeDeclTypeOperator . ideTypeOpName) (== name)) P.TypeClassRef name -> - findWrapped (lensSatisfies (_IdeDeclTypeClass . ideTCName) (== name)) + findWrapped (anyOf (_IdeDeclTypeClass . ideTCName) (== name)) _ -> Left ref where @@ -113,9 +114,9 @@ resolveRef decls ref = case ref of findRef f = find (f . discardAnn) decls lookupDtor name = - findRef (lensSatisfies (_IdeDeclDataConstructor . ideDtorName) (== name)) + findRef (anyOf (_IdeDeclDataConstructor . ideDtorName) (== name)) - findDtors tn = filter (lensSatisfies + findDtors tn = filter (anyOf (idaDeclaration . _IdeDeclDataConstructor . ideDtorTypeName) (== tn)) decls diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index bc5ac625a4..8e58f3d8fe 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -250,7 +250,7 @@ resolveInstances externs declarations = go (ideInstance, classModule, className) acc' = let matchTC = - lensSatisfies (idaDeclaration . _IdeDeclTypeClass . ideTCName) (== className) + anyOf (idaDeclaration . _IdeDeclTypeClass . ideTCName) (== className) updateDeclaration = mapIf matchTC (idaDeclaration . _IdeDeclTypeClass @@ -283,14 +283,14 @@ resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) | (P.Qualified (Just mn) (Left ident)) <- op ^. ideValueOpAlias = let t = getDeclarations mn & mapMaybe (preview _IdeDeclValue) - & filter (lensSatisfies ideValueIdent (== ident)) + & filter (anyOf ideValueIdent (== ident)) & map (view ideValueType) & listToMaybe in IdeDeclValueOperator (op & ideValueOpType .~ t) | (P.Qualified (Just mn) (Right dtor)) <- op ^. ideValueOpAlias = let t = getDeclarations mn & mapMaybe (preview _IdeDeclDataConstructor) - & filter (lensSatisfies ideDtorName (== dtor)) + & filter (anyOf ideDtorName (== dtor)) & map (view ideDtorType) & listToMaybe in IdeDeclValueOperator (op & ideValueOpType .~ t) @@ -298,7 +298,7 @@ resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) | P.Qualified (Just mn) properName <- op ^. ideTypeOpAlias = let k = getDeclarations mn & mapMaybe (preview _IdeDeclType) - & filter (lensSatisfies ideTypeName (== properName)) + & filter (anyOf ideTypeName (== properName)) & map (view ideTypeKind) & listToMaybe in IdeDeclTypeOperator (op & ideTypeOpKind .~ k) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 17a3443eba..012cab3cc3 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -32,7 +32,7 @@ type ModuleMap a = Map P.ModuleName a data IdeDeclaration = IdeDeclValue IdeValue | IdeDeclType IdeType - | IdeDeclTypeSynonym IdeSynonym + | IdeDeclTypeSynonym IdeTypeSynonym | IdeDeclDataConstructor IdeDataConstructor | IdeDeclTypeClass IdeTypeClass | IdeDeclValueOperator IdeValueOperator @@ -50,7 +50,7 @@ data IdeType = IdeType , _ideTypeKind :: P.Kind } deriving (Show, Eq, Ord) -data IdeSynonym = IdeSynonym +data IdeTypeSynonym = IdeTypeSynonym { _ideSynonymName :: P.ProperName 'P.TypeName , _ideSynonymType :: P.Type } deriving (Show, Eq, Ord) @@ -92,7 +92,7 @@ data IdeTypeOperator = IdeTypeOperator makePrisms ''IdeDeclaration makeLenses ''IdeValue makeLenses ''IdeType -makeLenses ''IdeSynonym +makeLenses ''IdeTypeSynonym makeLenses ''IdeDataConstructor makeLenses ''IdeTypeClass makeLenses ''IdeInstance diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 21f259648f..b8b6dd4145 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -27,14 +27,13 @@ module Language.PureScript.Ide.Util , prettyTypeT , properNameT , identT - , lensSatisfies , module Language.PureScript.Ide.Logging ) where import Protolude hiding (decodeUtf8, encodeUtf8) -import Control.Lens ((^.), (^?), Iso', iso, Getting, (<&>)) +import Control.Lens hiding ((&), op) import Data.Aeson import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -131,6 +130,3 @@ prettyTypeT = . T.lines . T.pack . P.prettyPrintTypeWithUnicode - -lensSatisfies :: forall a s. Getting (First a) s a -> (a -> Bool) -> s -> Bool -lensSatisfies getter predicate value = value ^? getter <&> predicate & fromMaybe False diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs deleted file mode 100644 index 01f474a775..0000000000 --- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Language.PureScript.Ide.Imports.IntegrationSpec where - - -import Protolude - -import qualified Data.Text as T -import qualified Language.PureScript.Ide.Integration as Integration -import Test.Hspec - -import System.Directory -import System.FilePath -import System.IO.UTF8 (readUTF8FileT) - -setup :: IO () -setup = void (Integration.reset *> Integration.loadAll) - -withSupportFiles :: (FilePath -> FilePath -> IO a) -> IO () -withSupportFiles test = do - pdir <- Integration.projectDirectory - let sourceFp = pdir "src" "ImportsSpec.purs" - outFp = pdir "src" "ImportsSpecOut.tmp" - Integration.deleteFileIfExists outFp - void $ test sourceFp outFp - -outputFileShouldBe :: [Text] -> IO () -outputFileShouldBe expectation = do - outFp <- ( "src" "ImportsSpecOut.tmp") <$> Integration.projectDirectory - outRes <- readUTF8FileT outFp - shouldBe (T.strip <$> T.lines outRes) expectation - -spec :: Spec -spec = beforeAll_ setup . describe "Adding imports" $ do - let - sourceFileSkeleton :: [Text] -> [Text] - sourceFileSkeleton importSection = - [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId x = x"] - it "adds an implicit import" $ do - withSupportFiles (Integration.addImplicitImport "ImportsSpec1") - outputFileShouldBe (sourceFileSkeleton - [ "import ImportsSpec1" - ]) - it "adds an explicit unqualified import" $ do - withSupportFiles (Integration.addImport "exportedFunction") - outputFileShouldBe (sourceFileSkeleton - [ "import ImportsSpec1 (exportedFunction)" - ]) - it "adds an explicit unqualified import (type)" $ do - withSupportFiles (Integration.addImport "MyType") - outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyType)"]) - it "adds an explicit unqualified import (parameterized type)" $ do - withSupportFiles (Integration.addImport "MyParamType") - outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyParamType)"]) - it "adds an explicit unqualified import (typeclass)" $ do - withSupportFiles (Integration.addImport "ATypeClass") - outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (class ATypeClass)"]) - it "adds an explicit unqualified import (dataconstructor)" $ do - withSupportFiles (Integration.addImport "MyJust") - outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyMaybe(..))"]) - it "adds an explicit unqualified import (newtype)" $ do - withSupportFiles (Integration.addImport "MyNewtype") - outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (MyNewtype(..))"]) - it "adds an explicit unqualified import (typeclass member function)" $ do - withSupportFiles (Integration.addImport "typeClassFun") - outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (typeClassFun)"]) - it "doesn't add a newtypes constructor if only the type is exported" $ do - withSupportFiles (Integration.addImport "OnlyTypeExported") - outputFileShouldBe (sourceFileSkeleton ["import ImportsSpec1 (OnlyTypeExported)"]) - it "doesn't add an import if the identifier is defined in the module itself" $ do - withSupportFiles (Integration.addImport "myId") - outputFileShouldBe (sourceFileSkeleton []) - it "responds with an error if it's undecidable whether we want a type or constructor" $ - withSupportFiles (\sourceFp outFp -> do - r <- Integration.addImport "SpecialCase" sourceFp outFp - shouldBe False (Integration.resultIsSuccess r) - shouldBe False =<< doesFileExist outFp) - it "responds with an error if the identifier cannot be found and doesn't \ - \write to the output file" $ - withSupportFiles (\sourceFp outFp -> do - r <- Integration.addImport "doesntExist" sourceFp outFp - shouldBe False (Integration.resultIsSuccess r) - shouldBe False =<< doesFileExist outFp) diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 0d9ff8b538..e999debe9d 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -6,8 +6,12 @@ import Protolude import Data.Maybe (fromJust) import qualified Language.PureScript as P +import Language.PureScript.Ide.Command as Command +import Language.PureScript.Ide.Error import Language.PureScript.Ide.Imports +import qualified Language.PureScript.Ide.Test as Test import Language.PureScript.Ide.Types +import System.FilePath import Test.Hspec simpleFile :: [Text] @@ -22,6 +26,7 @@ splitSimpleFile :: (P.ModuleName, [Text], [Import], [Text]) splitSimpleFile = fromRight (sliceImportSection simpleFile) where fromRight = fromJust . rightToMaybe + withImports :: [Text] -> [Text] withImports is = take 2 simpleFile ++ is ++ drop 2 simpleFile @@ -171,3 +176,63 @@ spec = do -- the imported names don't actually have to exist! (map (uncurry dtorImport) [("Just", "Maybe"), ("Nothing", "Maybe"), ("SomeOtherConstructor", "SomeDataType")]) ["import Prelude", "import Control.Monad (Maybe(..), SomeDataType(..), ap)"] + describe "importing from a loaded IdeState" importFromIdeState + +implImport :: Text -> Command +implImport mn = + Command.Import ("src" "ImportsSpec.purs") Nothing [] (Command.AddImplicitImport (Test.mn mn)) + +addExplicitImport :: Text -> Command +addExplicitImport i = + Command.Import ("src" "ImportsSpec.purs") Nothing [] (Command.AddImportForIdentifier i) + +importShouldBe :: [Text] -> [Text] -> Expectation +importShouldBe res importSection = + res `shouldBe` [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId x = x"] + +runIdeLoaded :: Command -> IO (Either PscIdeError Success) +runIdeLoaded c = do + ([_, result], _) <- Test.inProject $ Test.runIde [Command.LoadSync [] , c] + pure result + +importFromIdeState :: Spec +importFromIdeState = do + it "adds an implicit import" $ do + Right (MultilineTextResult result) <- + runIdeLoaded (implImport "ImportsSpec1") + result `importShouldBe` [ "import ImportsSpec1" ] + it "adds an explicit unqualified import" $ do + Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "exportedFunction") + result `importShouldBe` [ "import ImportsSpec1 (exportedFunction)" ] + it "adds an explicit unqualified import (type)" $ do + Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "MyType") + result `importShouldBe` [ "import ImportsSpec1 (MyType)" ] + it "adds an explicit unqualified import (parameterized type)" $ do + Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "MyParamType") + result `importShouldBe` [ "import ImportsSpec1 (MyParamType)" ] + it "adds an explicit unqualified import (typeclass)" $ do + Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "ATypeClass") + result `importShouldBe` [ "import ImportsSpec1 (class ATypeClass)" ] + it "adds an explicit unqualified import (dataconstructor)" $ do + Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "MyJust") + result `importShouldBe` [ "import ImportsSpec1 (MyMaybe(..))" ] + it "adds an explicit unqualified import (newtype)" $ do + Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "MyNewtype") + result `importShouldBe` [ "import ImportsSpec1 (MyNewtype(..))" ] + it "adds an explicit unqualified import (typeclass member function)" $ do + Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "typeClassFun") + result `importShouldBe` [ "import ImportsSpec1 (typeClassFun)" ] + it "doesn't add a newtypes constructor if only the type is exported" $ do + Right (MultilineTextResult result) <- + runIdeLoaded (addExplicitImport "OnlyTypeExported") + result `importShouldBe` [ "import ImportsSpec1 (OnlyTypeExported)" ] + it "doesn't add an import if the identifier is defined in the module itself" $ do + Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "myId") + result `importShouldBe` [] + it "responds with an error if it's undecidable whether we want a type or constructor" $ do + result <- runIdeLoaded (addExplicitImport "SpecialCase") + result `shouldSatisfy` isLeft + it "responds with an error if the identifier cannot be found and doesn't \ + \write to the output file" $ do + result <- runIdeLoaded (addExplicitImport "doesnExist") + result `shouldSatisfy` isLeft diff --git a/tests/Language/PureScript/Ide/Integration.hs b/tests/Language/PureScript/Ide/Integration.hs deleted file mode 100644 index 9133fb7d8c..0000000000 --- a/tests/Language/PureScript/Ide/Integration.hs +++ /dev/null @@ -1,280 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Ide.Integration --- Description : A psc-ide client for use in integration tests --- Copyright : Christoph Hegemann 2016 --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Christoph Hegemann --- Stability : experimental --- --- | --- A psc-ide client for use in integration tests ------------------------------------------------------------------------------ - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Language.PureScript.Ide.Integration - ( - -- managing the server process - startServer - , withServer - , stopServer - , quitServer - -- util - , compileTestProject - , deleteOutputFolder - , projectDirectory - , deleteFileIfExists - -- sending commands - , addImport - , addImplicitImport - , loadAll - , loadModule - , loadModules - , getCwd - , getFlexCompletions - , getFlexCompletionsInModule - , getType - , rebuildModule - , reset - -- checking results - , resultIsSuccess - , parseCompletions - , parseTextResult - ) where - -import Protolude -import Data.Maybe (fromJust) - -import Data.Aeson -import Data.Aeson.Types -import qualified Data.Text.Encoding as T -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy.Char8 as BSL8 -import qualified Data.Vector as V -import qualified Language.PureScript as P -import System.Directory -import System.FilePath -import System.IO -import System.IO.Error (mkIOError, userErrorType) -import System.Process - -projectDirectory :: IO FilePath -projectDirectory = do - cd <- getCurrentDirectory - return $ cd "tests" "support" "pscide" - -startServer :: IO ProcessHandle -startServer = do - pdir <- projectDirectory - -- Turn off filewatching since it creates race condition in a testing environment - (_, _, _, procHandle) <- createProcess $ - (shell "psc-ide-server --no-watch src/*.purs") {cwd = Just pdir} - threadDelay 2000000 -- give the server 2s to start up - return procHandle - -stopServer :: ProcessHandle -> IO () -stopServer = terminateProcess - -withServer :: IO a -> IO a -withServer s = do - _ <- startServer - started <- tryNTimes 5 (rightToMaybe <$> (try getCwd :: IO (Either SomeException Text))) - when (isNothing started) $ - throwIO (mkIOError userErrorType "psc-ide-server didn't start in time" Nothing Nothing) - r <- s - quitServer - pure r - --- project management utils - -compileTestProject :: IO Bool -compileTestProject = do - pdir <- projectDirectory - (_, _, _, procHandle) <- createProcess $ - (shell . toS $ "psc " <> fileGlob) { cwd = Just pdir } - r <- tryNTimes 10 (getProcessExitCode procHandle) - pure (fromMaybe False (isSuccess <$> r)) - -tryNTimes :: Int -> IO (Maybe a) -> IO (Maybe a) -tryNTimes 0 _ = pure Nothing -tryNTimes n action = do - r <- action - case r of - Nothing -> do - threadDelay 500000 - tryNTimes (n - 1) action - Just a -> pure (Just a) - -deleteOutputFolder :: IO () -deleteOutputFolder = do - odir <- fmap ( "output") projectDirectory - whenM (doesDirectoryExist odir) (removeDirectoryRecursive odir) - -deleteFileIfExists :: FilePath -> IO () -deleteFileIfExists fp = whenM (doesFileExist fp) (removeFile fp) - -isSuccess :: ExitCode -> Bool -isSuccess ExitSuccess = True -isSuccess (ExitFailure _) = False - -fileGlob :: Text -fileGlob = "\"src/**/*.purs\"" - --- Integration Testing API - -sendCommand :: Value -> IO Text -sendCommand v = do - (Just hin, Just hout, _, _) <- - createProcess ((proc "psc-ide-client" []) {std_in=CreatePipe, std_out=CreatePipe}) - - hSetEncoding hin utf8 - hSetEncoding hout utf8 - - BS8.hPutStrLn hin (BSL8.toStrict (encode v)) - hFlush hin - T.decodeUtf8 <$> BS8.hGetLine hout - -quitServer :: IO () -quitServer = do - let quitCommand = object ["command" .= ("quit" :: Text)] - _ <- try $ sendCommand quitCommand :: IO (Either SomeException Text) - return () - -reset :: IO () -reset = do - let resetCommand = object ["command" .= ("reset" :: Text)] - _ <- try $ sendCommand resetCommand :: IO (Either SomeException Text) - return () - -getCwd :: IO Text -getCwd = do - let cwdCommand = object ["command" .= ("cwd" :: Text)] - sendCommand cwdCommand - -loadModule :: Text -> IO Text -loadModule m = loadModules [m] - -loadModules :: [Text] -> IO Text -loadModules = sendCommand . load - -loadAll :: IO Text -loadAll = sendCommand (load []) - -getFlexCompletions :: Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)] -getFlexCompletions q = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) Nothing) - -getFlexCompletionsInModule :: Text -> Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)] -getFlexCompletionsInModule q m = parseCompletions <$> sendCommand (completion [] (Just (flexMatcher q)) (Just m)) - -getType :: Text -> IO [(Text, Text, Text, Maybe P.SourceSpan)] -getType q = parseCompletions <$> sendCommand (typeC q []) - -addImport :: Text -> FilePath -> FilePath -> IO Text -addImport identifier fp outfp = sendCommand (addImportC identifier fp outfp) - -addImplicitImport :: Text -> FilePath -> FilePath -> IO Text -addImplicitImport mn fp outfp = sendCommand (addImplicitImportC mn fp outfp) - -rebuildModule :: FilePath -> IO Text -rebuildModule m = sendCommand (rebuildC m Nothing) - --- Command Encoding - -commandWrapper :: Text -> Value -> Value -commandWrapper c p = object ["command" .= c, "params" .= p] - -load :: [Text] -> Value -load ms = commandWrapper "load" (object ["modules" .= ms]) - -typeC :: Text -> [Value] -> Value -typeC q filters = commandWrapper "type" (object ["search" .= q, "filters" .= filters]) - -addImportC :: Text -> FilePath -> FilePath -> Value -addImportC identifier = addImportW $ - object [ "importCommand" .= ("addImport" :: Text) - , "identifier" .= identifier - ] - -addImplicitImportC :: Text -> FilePath -> FilePath -> Value -addImplicitImportC mn = addImportW $ - object [ "importCommand" .= ("addImplicitImport" :: Text) - , "module" .= mn - ] - -rebuildC :: FilePath -> Maybe FilePath -> Value -rebuildC file outFile = - commandWrapper "rebuild" (object [ "file" .= file - , "outfile" .= outFile - ]) - -addImportW :: Value -> FilePath -> FilePath -> Value -addImportW importCommand fp outfp = - commandWrapper "import" (object [ "file" .= fp - , "outfile" .= outfp - , "importCommand" .= importCommand - ]) - - -completion :: [Value] -> Maybe Value -> Maybe Text -> Value -completion filters matcher currentModule = - let - matcher' = case matcher of - Nothing -> [] - Just m -> ["matcher" .= m] - currentModule' = case currentModule of - Nothing -> [] - Just cm -> ["currentModule" .= cm] - in - commandWrapper "complete" (object $ "filters" .= filters : matcher' ++ currentModule' ) - -flexMatcher :: Text -> Value -flexMatcher q = object [ "matcher" .= ("flex" :: Text) - , "params" .= object ["search" .= q] - ] - --- Result parsing - -unwrapResult :: Value -> Parser (Either Text Value) -unwrapResult = withObject "result" $ \o -> do - (rt :: Text) <- o .: "resultType" - case rt of - "error" -> do - res <- o .: "result" - withArray "errors" (fmap (Left . fold) . traverse (withObject "error" (.: "message"))) res - "success" -> do - res <- o .: "result" - pure (Right res) - _ -> mzero - -withResult :: (Value -> Parser a) -> Value -> Parser (Either Text a) -withResult p v = do - r <- unwrapResult v - case r of - Left err -> pure (Left err) - Right res -> Right <$> p res - -completionParser :: Value -> Parser [(Text, Text, Text, Maybe P.SourceSpan)] -completionParser = withArray "res" $ \cs -> - mapM (withObject "completion" $ \o -> do - ident <- o .: "identifier" - module' <- o .: "module" - ty <- o .: "type" - ss <- o .: "definedAt" - pure (module', ident, ty, ss)) (V.toList cs) - -valueFromText :: Text -> Value -valueFromText = fromJust . decode . toS - -resultIsSuccess :: Text -> Bool -resultIsSuccess = isRight . join . first toS . parseEither unwrapResult . valueFromText - -parseCompletions :: Text -> [(Text, Text, Text, Maybe P.SourceSpan)] -parseCompletions s = - fromJust $ join (rightToMaybe <$> parseMaybe (withResult completionParser) (valueFromText s)) - -parseTextResult :: Text -> Text -parseTextResult s = - fromJust $ join (rightToMaybe <$> parseMaybe (withResult (withText "tr" pure)) (valueFromText s)) diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs index 73c4583be9..cfb71024a1 100644 --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -6,7 +6,6 @@ module Language.PureScript.Ide.MatcherSpec where import Protolude import qualified Language.PureScript as P -import Language.PureScript.Ide.Integration import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util @@ -26,9 +25,6 @@ completions = [firstResult, secondResult, fiult] runFlex :: Text -> [Match IdeDeclarationAnn] runFlex s = runMatcher (flexMatcher s) completions -setup :: IO () -setup = reset *> void loadAll - spec :: Spec spec = do describe "Flex Matcher" $ do @@ -38,12 +34,3 @@ spec = do runFlex "firstResult" `shouldBe` [firstResult] it "scores short matches higher and sorts accordingly" $ runFlex "filt" `shouldBe` [fiult, firstResult] - - beforeAll_ setup . describe "Integration Tests: Flex Matcher" $ do - it "doesn't match on an empty string" $ do - cs <- getFlexCompletions "" - cs `shouldBe` [] - it "matches on equality" $ do - -- ignore any position information - (m, i, t, _) : _ <- getFlexCompletions "const" - (m, i, t) `shouldBe` ("MatcherSpec", "const", "∀ a b. a → b → a") diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index f924190852..801c3b6c42 100644 --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -4,54 +4,58 @@ module Language.PureScript.Ide.RebuildSpec where import Protolude -import qualified Language.PureScript.Ide.Integration as Integration +import Language.PureScript.Ide.Command +import Language.PureScript.Ide.Matcher +import Language.PureScript.Ide.Types +import qualified Language.PureScript.Ide.Test as Test import System.FilePath import Test.Hspec -shouldBeSuccess :: Text -> IO () -shouldBeSuccess = shouldBe True . Integration.resultIsSuccess +load :: [Text] -> Command +load = LoadSync . map Test.mn -shouldBeFailure :: Text -> IO () -shouldBeFailure = shouldBe False . Integration.resultIsSuccess +rebuild :: FilePath -> Command +rebuild fp = Rebuild ("src" fp) + +rebuildSync :: FilePath -> Command +rebuildSync fp = RebuildSync ("src" fp) spec :: Spec -spec = before_ Integration.reset . describe "Rebuilding single modules" $ do +spec = describe "Rebuilding single modules" $ do it "rebuilds a correct module without dependencies successfully" $ do - _ <- Integration.loadModule "RebuildSpecSingleModule" - pdir <- Integration.projectDirectory - let file = pdir "src" "RebuildSpecSingleModule.purs" - Integration.rebuildModule file >>= shouldBeSuccess + ([_, result], _) <- Test.inProject $ + Test.runIde [ load ["RebuildSpecSingleModule"] + , rebuild "RebuildSpecSingleModule.purs" + ] + result `shouldSatisfy` isRight it "fails to rebuild an incorrect module without dependencies and returns the errors" $ do - pdir <- Integration.projectDirectory - let file = pdir "src" "RebuildSpecSingleModule.fail" - Integration.rebuildModule file >>= shouldBeFailure + ([result], _) <- Test.inProject $ + Test.runIde [ rebuild "RebuildSpecSingleModule.fail" ] + result `shouldSatisfy` isLeft it "rebuilds a correct module with its dependencies successfully" $ do - _ <- Integration.loadModules ["RebuildSpecWithDeps", "RebuildSpecDep"] - pdir <- Integration.projectDirectory - let file = pdir "src" "RebuildSpecWithDeps.purs" - Integration.rebuildModule file >>= shouldBeSuccess + ([_, result], _) <- Test.inProject $ + Test.runIde [ load ["RebuildSpecWithDeps", "RebuildSpecDep"] + , rebuild "RebuildSpecWithDeps.purs" + ] + result `shouldSatisfy` isRight it "rebuilds a correct module that has reverse dependencies" $ do - _ <- Integration.loadModule "RebuildSpecWithDeps" - pdir <- Integration.projectDirectory - let file = pdir "src" "RebuildSpecDep.purs" - Integration.rebuildModule file >>= shouldBeSuccess + ([_, result], _) <- Test.inProject $ + Test.runIde [ load ["RebuildSpecWithDeps"], rebuild "RebuildSpecDep.purs" ] + result `shouldSatisfy` isRight it "fails to rebuild a module if its dependencies are not loaded" $ do - _ <- Integration.loadModule "RebuildSpecWithDeps" - pdir <- Integration.projectDirectory - let file = pdir "src" "RebuildSpecWithDeps.purs" - Integration.rebuildModule file >>= shouldBeFailure + ([_, result], _) <- Test.inProject $ + Test.runIde [ load ["RebuildSpecWithDeps"], rebuild "RebuildSpecWithDeps.purs" ] + result `shouldSatisfy` isLeft it "rebuilds a correct module with a foreign file" $ do - _ <- Integration.loadModule "RebuildSpecWithForeign" - pdir <- Integration.projectDirectory - let file = pdir "src" "RebuildSpecWithForeign.purs" - Integration.rebuildModule file >>= shouldBeSuccess + ([_, result], _) <- Test.inProject $ + Test.runIde [ load ["RebuildSpecWithForeign"], rebuild "RebuildSpecWithForeign.purs" ] + result `shouldSatisfy` isRight it "fails to rebuild a module with a foreign import but no file" $ do - pdir <- Integration.projectDirectory - let file = pdir "src" "RebuildSpecWithMissingForeign.fail" - Integration.rebuildModule file >>= shouldBeFailure + ([result], _) <- Test.inProject $ + Test.runIde [ rebuild "RebuildSpecWithMissingForeign.fail" ] + result `shouldSatisfy` isLeft it "completes a hidden identifier after rebuilding" $ do - pdir <- Integration.projectDirectory - let file = pdir "src" "RebuildSpecWithHiddenIdent.purs" - Integration.rebuildModule file >>= shouldBeSuccess - res <- Integration.getFlexCompletionsInModule "hid" "RebuildSpecWithHiddenIdent" - shouldBe False (null res) + ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + Test.runIde [ rebuildSync "RebuildSpecWithHiddenIdent.purs" + , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent"))] + complIdentifier result `shouldBe` "hidden" diff --git a/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs b/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs deleted file mode 100644 index 4fd6056a60..0000000000 --- a/tests/Language/PureScript/Ide/SourceFile/IntegrationSpec.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Language.PureScript.Ide.SourceFile.IntegrationSpec where - - -import Protolude - -import qualified Data.Text as T -import qualified Language.PureScript.Ide.Integration as Integration -import qualified Language.PureScript as P -import Test.Hspec - -setup :: IO () -setup = void (Integration.reset *> Integration.loadAll) - -spec :: Spec -spec = beforeAll_ setup $ - describe "Sourcefile Integration" $ do - it "finds a value declaration" $ - testCase "sfValue" (3, 1) - it "finds a type declaration" $ - testCase "SFType" (5, 1) - it "finds a data declaration" $ - testCase "SFData" (7, 1) - it "finds a data constructor" $ - testCase "SFOne" (7, 1) - it "finds a typeclass" $ - testCase "SFClass" (9, 1) - it "finds a typeclass member" $ - testCase "sfShow" (10, 3) - -testCase :: Text -> (Int, Int) -> IO () -testCase s (x, y) = do - P.SourceSpan f (P.SourcePos l c) _ <- getLocation s - toS f `shouldSatisfy` T.isSuffixOf "SourceFileSpec.purs" - (l, c) `shouldBe` (x, y) - -getLocation :: Text -> IO P.SourceSpan -getLocation s = do - (_, _, _, Just location) : _ <- Integration.getType s - pure location diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index eae3de7688..97854f32ac 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -5,8 +5,10 @@ module Language.PureScript.Ide.SourceFileSpec where import Protolude import qualified Language.PureScript as P +import Language.PureScript.Ide.Command import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Test import Test.Hspec span0, span1, span2 :: P.SourceSpan @@ -52,3 +54,43 @@ spec = do describe "Type annotations" $ do it "extracts a type annotation" $ extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.REmpty)] + describe "Finding Source Spans for identifiers" $ do + it "finds a value declaration" $ do + Just r <- getLocation "sfValue" + r `shouldBe` valueSS + it "finds a synonym declaration" $ do + Just r <- getLocation "SFType" + r `shouldBe` synonymSS + it "finds a data declaration and its constructors" $ do + rs <- traverse getLocation ["SFData", "SFOne", "SFTwo", "SFThree"] + traverse_ (`shouldBe` (Just typeSS)) rs + it "finds a class declaration" $ do + Just r <- getLocation "SFClass" + r `shouldBe` classSS + +getLocation :: Text -> IO (Maybe P.SourceSpan) +getLocation s = do + ([Right (CompletionResult [c])], _) <- + runIde' defConfig ideState [Type s [] Nothing] + pure (complLocation c) + where + ideState = emptyIdeState `s3` + [ ("Test", + [ ideValue "sfValue" Nothing `annLoc` valueSS + , ideSynonym "SFType" P.tyString `annLoc` synonymSS + , ideType "SFData" Nothing `annLoc` typeSS + , ideDtor "SFOne" "SFData" Nothing `annLoc` typeSS + , ideDtor "SFTwo" "SFData" Nothing `annLoc` typeSS + , ideDtor "SFThree" "SFData" Nothing `annLoc` typeSS + , ideTypeClass "SFClass" [] `annLoc` classSS + ]) + ] + +valueSS, synonymSS, typeSS, classSS :: P.SourceSpan +valueSS = ss 3 1 +synonymSS = ss 5 1 +typeSS = ss 7 1 +classSS = ss 8 1 + +ss :: Int -> Int -> P.SourceSpan +ss x y = P.SourceSpan "Test.purs" (P.SourcePos x y) (P.SourcePos x y) diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs new file mode 100644 index 0000000000..652da4672a --- /dev/null +++ b/tests/Language/PureScript/Ide/Test.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +module Language.PureScript.Ide.Test where + +import Control.Concurrent.STM +import "monad-logger" Control.Monad.Logger +import qualified Data.Map as Map +import Language.PureScript.Ide +import Language.PureScript.Ide.Command +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Types +import Protolude +import System.Directory +import System.FilePath +import System.Process + +import qualified Language.PureScript as P + +defConfig :: Configuration +defConfig = + Configuration { confLogLevel = LogNone + , confOutputPath = "output/" + , confGlobs = ["src/*.purs"] + } + +runIde' :: Configuration -> IdeState -> [Command] -> IO ([Either PscIdeError Success], IdeState) +runIde' conf s cs = do + stateVar <- newTVarIO s + let env' = IdeEnvironment {ideStateVar = stateVar, ideConfiguration = conf} + r <- runNoLoggingT (runReaderT (traverse (runExceptT . handleCommand) cs) env') + newState <- readTVarIO stateVar + pure (r, newState) + +runIde :: [Command] -> IO ([Either PscIdeError Success], IdeState) +runIde = runIde' defConfig emptyIdeState + +s3 :: IdeState -> [(Text, [IdeDeclarationAnn])] -> IdeState +s3 s ds = + s {ideStage3 = stage3} + where + stage3 = Stage3 (Map.fromList decls) Nothing + decls = map (first P.moduleNameFromString) ds + +-- | Adding Annotations to IdeDeclarations +ann :: IdeDeclarationAnn -> Annotation -> IdeDeclarationAnn +ann (IdeDeclarationAnn _ d) a = IdeDeclarationAnn a d + +annLoc :: IdeDeclarationAnn -> P.SourceSpan -> IdeDeclarationAnn +annLoc (IdeDeclarationAnn a d) loc = IdeDeclarationAnn a {annLocation = Just loc} d + +annExp :: IdeDeclarationAnn -> P.ModuleName -> IdeDeclarationAnn +annExp (IdeDeclarationAnn a d) e = IdeDeclarationAnn a {annExportedFrom = Just e} d + +annTyp :: IdeDeclarationAnn -> P.Type -> IdeDeclarationAnn +annTyp (IdeDeclarationAnn a d) ta = IdeDeclarationAnn a {annTypeAnnotation = Just ta} d + + +ida :: IdeDeclaration -> IdeDeclarationAnn +ida = IdeDeclarationAnn emptyAnn + +-- | Builders for Ide declarations +ideValue :: Text -> Maybe P.Type -> IdeDeclarationAnn +ideValue i ty = ida (IdeDeclValue (IdeValue (P.Ident i) (fromMaybe P.tyString ty))) + +ideType :: Text -> Maybe P.Kind -> IdeDeclarationAnn +ideType pn ki = ida (IdeDeclType (IdeType (P.ProperName pn) (fromMaybe P.kindType ki))) + +ideSynonym :: Text -> P.Type -> IdeDeclarationAnn +ideSynonym pn ty = ida (IdeDeclTypeSynonym (IdeTypeSynonym (P.ProperName pn) ty)) + +ideTypeClass :: Text -> [IdeInstance] -> IdeDeclarationAnn +ideTypeClass pn instances = ida (IdeDeclTypeClass (IdeTypeClass (P.ProperName pn) instances)) + +ideDtor :: Text -> Text -> Maybe P.Type -> IdeDeclarationAnn +ideDtor pn tn ty = ida (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName pn) (P.ProperName tn) (fromMaybe P.tyString ty))) + +ideValueOp :: Text -> P.Qualified (Either Text Text) -> Integer -> Maybe P.Associativity -> Maybe P.Type -> IdeDeclarationAnn +ideValueOp opName ident precedence assoc t = + ida (IdeDeclValueOperator + (IdeValueOperator + (P.OpName opName) + (bimap P.Ident P.ProperName <$> ident) + (precedence) + (fromMaybe P.Infix assoc) + t)) + +ideTypeOp :: Text -> P.Qualified Text -> Integer -> Maybe P.Associativity -> Maybe P.Kind -> IdeDeclarationAnn +ideTypeOp opName ident precedence assoc k = + ida (IdeDeclTypeOperator + (IdeTypeOperator + (P.OpName opName) + (P.ProperName <$> ident) + (precedence) + (fromMaybe P.Infix assoc) + k)) + +ideKind :: Text -> IdeDeclarationAnn +ideKind pn = ida (IdeDeclKind (P.ProperName pn)) + +mn :: Text -> P.ModuleName +mn = P.moduleNameFromString + +inProject :: IO a -> IO a +inProject f = do + cwd' <- getCurrentDirectory + setCurrentDirectory ("." "tests" "support" "pscide") + a <- f + setCurrentDirectory cwd' + pure a + +compileTestProject :: IO Bool +compileTestProject = inProject $ do + (_, _, _, procHandle) <- + createProcess $ (shell $ "psc \"src/**/*.purs\"") + r <- tryNTimes 10 (getProcessExitCode procHandle) + pure (fromMaybe False (isSuccess <$> r)) + +isSuccess :: ExitCode -> Bool +isSuccess ExitSuccess = True +isSuccess (ExitFailure _) = False + +tryNTimes :: Int -> IO (Maybe a) -> IO (Maybe a) +tryNTimes 0 _ = pure Nothing +tryNTimes n action = do + r <- action + case r of + Nothing -> do + threadDelay 500000 + tryNTimes (n - 1) action + Just a -> pure (Just a) + +deleteOutputFolder :: IO () +deleteOutputFolder = inProject $ + whenM (doesDirectoryExist "output") (removeDirectoryRecursive "output") diff --git a/tests/TestPscIde.hs b/tests/TestPscIde.hs index bf9e62c39b..97ff41f4cb 100644 --- a/tests/TestPscIde.hs +++ b/tests/TestPscIde.hs @@ -1,15 +1,13 @@ module TestPscIde where import Control.Monad (unless) -import Language.PureScript.Ide.Integration import qualified PscIdeSpec +import Language.PureScript.Ide.Test import Test.Hspec main :: IO () main = do deleteOutputFolder s <- compileTestProject - unless s $ fail "Failed to compile .purs sources" - - quitServer -- shuts down any left over server (primarily happens during development) - withServer (hspec PscIdeSpec.spec) + unless s (fail "Failed to compile .purs sources") + hspec PscIdeSpec.spec From 43c133fbf00d88da67d07a6a730a4cd543921b0c Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 27 Jan 2017 18:10:21 +0100 Subject: [PATCH 0640/1580] [psc-ide] Also detect location information for operators (#2602) --- src/Language/PureScript/Ide/Externs.hs | 4 +-- src/Language/PureScript/Ide/SourceFile.hs | 4 +++ src/Language/PureScript/Ide/Types.hs | 8 ++--- src/Language/PureScript/Ide/Util.hs | 4 +++ .../Language/PureScript/Ide/SourceFileSpec.hs | 30 +++++++++++++++++-- tests/support/pscide/src/SourceFileSpec.purs | 10 ------- 6 files changed, 42 insertions(+), 18 deletions(-) delete mode 100644 tests/support/pscide/src/SourceFileSpec.purs diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index cdbf8d47c3..5a9767dd77 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -138,9 +138,9 @@ annotateModule (defs, types) decls = IdeDeclTypeClass tc -> annotateType (tc ^. ideTCName . properNameT) (IdeDeclTypeClass tc) IdeDeclValueOperator op -> - annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op) + annotateValue (op ^. ideValueOpName . opNameT) (IdeDeclValueOperator op) IdeDeclTypeOperator op -> - annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op) + annotateType (op ^. ideTypeOpName . opNameT) (IdeDeclTypeOperator op) IdeDeclKind i -> annotateKind (i ^. properNameT) (IdeDeclKind i) where diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 21f1e0c1d7..59d450094c 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -106,6 +106,10 @@ extractSpans ss d = case d of P.DataDeclaration _ name _ ctors -> (IdeNSType (P.runProperName name), ss) : map (\(cname, _) -> (IdeNSValue (P.runProperName cname), ss)) ctors + P.FixityDeclaration (Left (P.ValueFixity _ _ opName)) -> + [(IdeNSValue (P.runOpName opName), ss)] + P.FixityDeclaration (Right (P.TypeFixity _ _ opName)) -> + [(IdeNSType (P.runOpName opName), ss)] P.ExternDeclaration ident _ -> [(IdeNSValue (P.runIdent ident), ss)] P.ExternDataDeclaration name _ -> diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 012cab3cc3..c21b775b32 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -145,7 +145,7 @@ data IdeState = IdeState { ideStage1 :: Stage1 , ideStage2 :: Stage2 , ideStage3 :: Stage3 - } + } deriving (Show) emptyIdeState :: IdeState emptyIdeState = IdeState emptyStage1 emptyStage2 emptyStage3 @@ -162,16 +162,16 @@ emptyStage3 = Stage3 M.empty Nothing data Stage1 = Stage1 { s1Externs :: ModuleMap P.ExternsFile , s1Modules :: ModuleMap (P.Module, FilePath) - } + } deriving (Show) data Stage2 = Stage2 { s2AstData :: AstData P.SourceSpan - } + } deriving (Show, Eq) data Stage3 = Stage3 { s3Declarations :: ModuleMap [IdeDeclarationAnn] , s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile) - } + } deriving (Show) newtype Match a = Match (P.ModuleName, a) deriving (Show, Eq, Functor) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index b8b6dd4145..289268ff32 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -27,6 +27,7 @@ module Language.PureScript.Ide.Util , prettyTypeT , properNameT , identT + , opNameT , module Language.PureScript.Ide.Logging ) where @@ -123,6 +124,9 @@ properNameT = iso P.runProperName P.ProperName identT :: Iso' P.Ident Text identT = iso P.runIdent P.Ident +opNameT :: Iso' (P.OpName a) Text +opNameT = iso P.runOpName P.OpName + prettyTypeT :: P.Type -> Text prettyTypeT = T.unwords diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 97854f32ac..e680c9977d 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -16,7 +16,7 @@ span0 = P.SourceSpan "ModuleLevel" (P.SourcePos 0 0) (P.SourcePos 1 1) span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2) span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3) -typeAnnotation1, value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, foreign3, member1 :: P.Declaration +typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, foreign1, foreign2, foreign3, member1 :: P.Declaration typeAnnotation1 = P.TypeDeclaration (P.Ident "value1") P.REmpty value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left []) synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty @@ -25,6 +25,16 @@ class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] [] [P.PositionedDeclaration span2 [] member1] data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] [] data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])] +valueFixity = + P.ValueFixityDeclaration + (P.Fixity P.Infix 0) + (P.Qualified Nothing (Left (P.Ident ""))) + (P.OpName "<$>") +typeFixity = + P.TypeFixityDeclaration + (P.Fixity P.Infix 0) + (P.Qualified Nothing (P.ProperName "")) + (P.OpName "~>") foreign1 = P.ExternDeclaration (P.Ident "foreign1") P.REmpty foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.kindType foreign3 = P.ExternKindDeclaration (P.ProperName "Foreign3") @@ -45,6 +55,10 @@ spec = do extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(IdeNSType "Data1", span1)] it "extracts spans for a data declaration and its constructors" $ extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(IdeNSType "Data2", span1), (IdeNSValue "Cons1", span1)] + it "extracts a span for a value operator fixity declaration" $ + extractSpans span0 (P.PositionedDeclaration span1 [] valueFixity) `shouldBe` [(IdeNSValue "<$>", span1)] + it "extracts a span for a type operator fixity declaration" $ + extractSpans span0 (P.PositionedDeclaration span1 [] typeFixity) `shouldBe` [(IdeNSType "~>", span1)] it "extracts a span for a foreign declaration" $ extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(IdeNSValue "foreign1", span1)] it "extracts a span for a data foreign declaration" $ @@ -67,6 +81,12 @@ spec = do it "finds a class declaration" $ do Just r <- getLocation "SFClass" r `shouldBe` classSS + it "finds a value operator declaration" $ do + Just r <- getLocation "<$>" + r `shouldBe` valueOpSS + it "finds a type operator declaration" $ do + Just r <- getLocation "~>" + r `shouldBe` typeOpSS getLocation :: Text -> IO (Maybe P.SourceSpan) getLocation s = do @@ -83,14 +103,20 @@ getLocation s = do , ideDtor "SFTwo" "SFData" Nothing `annLoc` typeSS , ideDtor "SFThree" "SFData" Nothing `annLoc` typeSS , ideTypeClass "SFClass" [] `annLoc` classSS + , ideValueOp "<$>" (P.Qualified Nothing (Left "")) 0 Nothing Nothing + `annLoc` valueOpSS + , ideTypeOp "~>" (P.Qualified Nothing "") 0 Nothing Nothing + `annLoc` typeOpSS ]) ] -valueSS, synonymSS, typeSS, classSS :: P.SourceSpan +valueSS, synonymSS, typeSS, classSS, valueOpSS, typeOpSS :: P.SourceSpan valueSS = ss 3 1 synonymSS = ss 5 1 typeSS = ss 7 1 classSS = ss 8 1 +valueOpSS = ss 12 1 +typeOpSS = ss 13 1 ss :: Int -> Int -> P.SourceSpan ss x y = P.SourceSpan "Test.purs" (P.SourcePos x y) (P.SourcePos x y) diff --git a/tests/support/pscide/src/SourceFileSpec.purs b/tests/support/pscide/src/SourceFileSpec.purs deleted file mode 100644 index e3484faeca..0000000000 --- a/tests/support/pscide/src/SourceFileSpec.purs +++ /dev/null @@ -1,10 +0,0 @@ -module SourceFileSpec where - -sfValue = "sfValue" - -type SFType = String - -data SFData = SFOne | SFTwo | SFThree - -class SFClass a where - sfShow :: a -> String From de550a1fc85c7831e41476d48c6666fb99ae0c64 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sat, 28 Jan 2017 02:17:27 +0100 Subject: [PATCH 0641/1580] [psc-ide] fix 2537 (#2603) * [psc-ide] rename PscIdeError to IdeError * [psc-ide] Use a safer readFile to prevent crashes * try to read file and handle exception instead --- src/Language/PureScript/Ide.hs | 12 ++++++------ src/Language/PureScript/Ide/CaseSplit.hs | 12 ++++++------ src/Language/PureScript/Ide/Error.hs | 8 ++++---- src/Language/PureScript/Ide/Externs.hs | 4 ++-- src/Language/PureScript/Ide/Imports.hs | 12 ++++++------ src/Language/PureScript/Ide/Rebuild.hs | 12 ++++++------ src/Language/PureScript/Ide/SourceFile.hs | 7 +++---- src/Language/PureScript/Ide/Util.hs | 11 +++++++++++ tests/Language/PureScript/Ide/ImportsSpec.hs | 2 +- tests/Language/PureScript/Ide/Test.hs | 4 ++-- 10 files changed, 47 insertions(+), 37 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 1997be4259..aaaccbdbfe 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -43,7 +43,7 @@ import System.FilePath.Glob (glob) -- | Accepts a Commmand and runs it against psc-ide's State. This is the main -- entry point for the server. -handleCommand :: (Ide m, MonadLogger m, MonadError PscIdeError m) => +handleCommand :: (Ide m, MonadLogger m, MonadError IdeError m) => Command -> m Success handleCommand c = case c of Load [] -> @@ -131,7 +131,7 @@ listAvailableModules = do let cleaned = filter (`notElem` [".", ".."]) contents return (ModuleList (map toS cleaned)) -caseSplit :: (Ide m, MonadError PscIdeError m) => +caseSplit :: (Ide m, MonadError IdeError m) => Text -> Int -> Int -> CS.WildcardAnnotations -> Text -> m Success caseSplit l b e csa t = do patterns <- CS.makePattern l b e csa <$> CS.caseSplit t @@ -139,7 +139,7 @@ caseSplit l b e csa t = do -- | Finds all the externs.json files inside the output folder and returns the -- corresponding Modulenames -findAvailableExterns :: (Ide m, MonadError PscIdeError m) => m [P.ModuleName] +findAvailableExterns :: (Ide m, MonadError IdeError m) => m [P.ModuleName] findAvailableExterns = do oDir <- outputDirectory unlessM (liftIO (doesDirectoryExist oDir)) @@ -169,7 +169,7 @@ findAllSourceFiles = do -- inserts their ASTs into the state. Finally kicks off an async worker, which -- populates Stage 2 and 3 of the state. loadModulesAsync - :: (Ide m, MonadError PscIdeError m, MonadLogger m) + :: (Ide m, MonadError IdeError m, MonadLogger m) => [P.ModuleName] -> m Success loadModulesAsync moduleNames = do @@ -185,7 +185,7 @@ loadModulesAsync moduleNames = do pure tr loadModulesSync - :: (Ide m, MonadError PscIdeError m, MonadLogger m) + :: (Ide m, MonadError IdeError m, MonadLogger m) => [P.ModuleName] -> m Success loadModulesSync moduleNames = do @@ -194,7 +194,7 @@ loadModulesSync moduleNames = do pure tr loadModules - :: (Ide m, MonadError PscIdeError m, MonadLogger m) + :: (Ide m, MonadError IdeError m, MonadLogger m) => [P.ModuleName] -> m Success loadModules moduleNames = do diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index c54380bb14..460ea91c0a 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -45,7 +45,7 @@ explicitAnnotations = WildcardAnnotations True noAnnotations :: WildcardAnnotations noAnnotations = WildcardAnnotations False -caseSplit :: (Ide m, MonadError PscIdeError m) => +caseSplit :: (Ide m, MonadError IdeError m) => Text -> m [Constructor] caseSplit q = do type' <- parseType' q @@ -55,7 +55,7 @@ caseSplit q = do let appliedCtors = map (second (map applyTypeVars)) ctors pure appliedCtors -findTypeDeclaration :: (Ide m, MonadError PscIdeError m) => +findTypeDeclaration :: (Ide m, MonadError IdeError m) => P.ProperName 'P.TypeName -> m ExternsDeclaration findTypeDeclaration q = do efs <- getExternFiles @@ -73,7 +73,7 @@ findTypeDeclaration' t ExternsFile{..} = EDType tn _ _ -> tn == t _ -> False) efDeclarations -splitTypeConstructor :: (MonadError PscIdeError m) => +splitTypeConstructor :: (MonadError IdeError m) => P.Type -> m (P.ProperName 'P.TypeName, [P.Type]) splitTypeConstructor = go [] where @@ -105,7 +105,7 @@ makePattern t x y wsa = makePattern' (T.take x t) (T.drop y t) where makePattern' lhs rhs = map (\ctor -> lhs <> prettyCtor wsa ctor <> rhs) -addClause :: (MonadError PscIdeError m) => Text -> WildcardAnnotations -> m [Text] +addClause :: (MonadError IdeError m) => Text -> WildcardAnnotations -> m [Text] addClause s wca = do (fName, fType) <- parseTypeDeclaration' s let args = splitFunctionType fType @@ -114,7 +114,7 @@ addClause s wca = do " = ?" <> (T.strip . P.runIdent $ fName) pure [s, template] -parseType' :: (MonadError PscIdeError m) => +parseType' :: (MonadError IdeError m) => Text -> m P.Type parseType' s = case P.lex "" (toS s) >>= P.runTokenParser "" (P.parseType <* Parsec.eof) of @@ -123,7 +123,7 @@ parseType' s = throwError (GeneralError ("Parsing the splittype failed with:" <> show err)) -parseTypeDeclaration' :: (MonadError PscIdeError m) => Text -> m (P.Ident, P.Type) +parseTypeDeclaration' :: (MonadError IdeError m) => Text -> m (P.Ident, P.Type) parseTypeDeclaration' s = let x = do ts <- P.lex "" (toS s) diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index a72cd077b1..1be0f8921b 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -13,7 +13,7 @@ ----------------------------------------------------------------------------- module Language.PureScript.Ide.Error - ( PscIdeError(..) + ( IdeError(..) ) where import Data.Aeson @@ -22,7 +22,7 @@ import Language.PureScript.Ide.Types (ModuleIdent) import Protolude import qualified Text.Parsec.Error as P -data PscIdeError +data IdeError = GeneralError Text | NotFound Text | ModuleNotFound ModuleIdent @@ -31,7 +31,7 @@ data PscIdeError | RebuildError [JSONError] deriving (Show, Eq) -instance ToJSON PscIdeError where +instance ToJSON IdeError where toJSON (RebuildError errs) = object [ "resultType" .= ("error" :: Text) , "result" .= errs @@ -41,7 +41,7 @@ instance ToJSON PscIdeError where , "result" .= textError err ] -textError :: PscIdeError -> Text +textError :: IdeError -> Text textError (GeneralError msg) = msg textError (NotFound ident) = "Symbol '" <> ident <> "' not found." textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found." diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 5a9767dd77..1ffe761310 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -28,13 +28,13 @@ import Data.Aeson (decodeStrict) import qualified Data.ByteString as BS import qualified Data.Map as Map import Data.Version (showVersion) -import Language.PureScript.Ide.Error (PscIdeError (..)) +import Language.PureScript.Ide.Error (IdeError (..)) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import qualified Language.PureScript as P -readExternFile :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) => +readExternFile :: (MonadIO m, MonadError IdeError m, MonadLogger m) => FilePath -> m P.ExternsFile readExternFile fp = do parseResult <- liftIO (decodeStrict <$> BS.readFile fp) diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index b12ec75d94..21158d8c31 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -39,7 +39,7 @@ import Language.PureScript.Ide.Filter import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT) +import System.IO.UTF8 (writeUTF8FileT) data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) deriving (Eq, Show) @@ -67,10 +67,10 @@ compImport (Import n i q) (Import n' i' q') -- | Reads a file and returns the (lines before the imports, the imports, the -- lines after the imports) -parseImportsFromFile :: (MonadIO m, MonadError PscIdeError m) => +parseImportsFromFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m (P.ModuleName, [Text], [Import], [Text]) parseImportsFromFile fp = do - file <- liftIO (readUTF8FileT fp) + file <- ideReadFile fp case sliceImportSection (T.lines file) of Right res -> pure res Left err -> throwError (GeneralError err) @@ -147,7 +147,7 @@ moduleParse t = first show $ do P.runTokenParser "" P.parseModule tokens -- | Adds an implicit import like @import Prelude@ to a Sourcefile. -addImplicitImport :: (MonadIO m, MonadError PscIdeError m) +addImplicitImport :: (MonadIO m, MonadError IdeError m) => FilePath -- ^ The Sourcefile read from -> P.ModuleName -- ^ The module to import -> m [Text] @@ -170,7 +170,7 @@ addImplicitImport' imports mn = -- So @addExplicitImport "/File.purs" "bind" "Prelude"@ with an already existing -- @import Prelude (bind)@ in the file File.purs returns @["import Prelude -- (bind, unit)"]@ -addExplicitImport :: (MonadIO m, MonadError PscIdeError m) => +addExplicitImport :: (MonadIO m, MonadError IdeError m) => FilePath -> IdeDeclaration -> P.ModuleName -> m [Text] addExplicitImport fp decl moduleName = do (mn, pre, imports, post) <- parseImportsFromFile fp @@ -249,7 +249,7 @@ updateAtFirstOrPrepend p t d l = -- -- * If more than one possible imports are found, reports the possibilities as a -- list of completions. -addImportForIdentifier :: (Ide m, MonadError PscIdeError m) +addImportForIdentifier :: (Ide m, MonadError IdeError m) => FilePath -- ^ The Sourcefile to read from -> Text -- ^ The identifier to import -> [Filter] -- ^ Filters to apply before searching for diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 2ae6c3129a..b0fa8dd74f 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -20,7 +20,7 @@ import Language.PureScript.Ide.Error import Language.PureScript.Ide.Logging import Language.PureScript.Ide.State import Language.PureScript.Ide.Types -import System.IO.UTF8 (readUTF8FileT) +import Language.PureScript.Ide.Util -- | Given a filepath performs the following steps: -- @@ -38,7 +38,7 @@ import System.IO.UTF8 (readUTF8FileT) -- warnings, and if rebuilding fails, returns a @RebuildError@ with the -- generated errors. rebuildFile - :: (Ide m, MonadLogger m, MonadError PscIdeError m) + :: (Ide m, MonadLogger m, MonadError IdeError m) => FilePath -- ^ The file to rebuild -> (ReaderT IdeEnvironment (LoggingT IO) () -> m ()) @@ -46,7 +46,7 @@ rebuildFile -> m Success rebuildFile path runOpenBuild = do - input <- liftIO (readUTF8FileT path) + input <- ideReadFile path m <- case snd <$> P.parseModuleFromFile identity (path, input) of Left parseError -> throwError @@ -80,7 +80,7 @@ rebuildFile path runOpenBuild = do pure (RebuildSuccess (toJSONErrors False P.Warning warnings)) rebuildFileAsync - :: forall m. (Ide m, MonadLogger m, MonadError PscIdeError m) + :: forall m. (Ide m, MonadLogger m, MonadError IdeError m) => FilePath -> m Success rebuildFileAsync fp = rebuildFile fp asyncRun where @@ -91,7 +91,7 @@ rebuildFileAsync fp = rebuildFile fp asyncRun void (liftIO (async (runLogger ll (runReaderT action env)))) rebuildFileSync - :: forall m. (Ide m, MonadLogger m, MonadError PscIdeError m) + :: forall m. (Ide m, MonadLogger m, MonadError IdeError m) => FilePath -> m Success rebuildFileSync fp = rebuildFile fp syncRun where @@ -158,7 +158,7 @@ shushCodegen ma MakeActionsEnv{..} = -- module. Throws an error if there is a cyclic dependency within the -- ExternsFiles sortExterns - :: (Ide m, MonadError PscIdeError m) + :: (Ide m, MonadError IdeError m) => P.Module -> ModuleMap P.ExternsFile -> m [P.ExternsFile] diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 59d450094c..e452236a5d 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -28,14 +28,13 @@ import qualified Language.PureScript as P import Language.PureScript.Ide.Error import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import System.IO.UTF8 (readUTF8FileT) parseModule - :: (MonadIO m) + :: (MonadIO m, MonadError IdeError m) => FilePath -> m (Either FilePath (FilePath, P.Module)) parseModule path = do - contents <- liftIO (readUTF8FileT path) + contents <- ideReadFile path case P.parseModuleFromFile identity (path, contents) of Left _ -> pure (Left path) Right m -> pure (Right m) @@ -47,7 +46,7 @@ getImports (P.Module _ _ _ declarations _) = isImport (P.PositionedDeclaration _ _ (P.ImportDeclaration a b c)) = Just (a, b, c) isImport _ = Nothing -getImportsForFile :: (MonadIO m, MonadError PscIdeError m) => +getImportsForFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m [ModuleImport] getImportsForFile fp = do moduleE <- parseModule fp diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 289268ff32..d8e7706f8a 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -28,6 +28,7 @@ module Language.PureScript.Ide.Util , properNameT , identT , opNameT + , ideReadFile , module Language.PureScript.Ide.Logging ) where @@ -40,8 +41,10 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) import qualified Language.PureScript as P +import Language.PureScript.Ide.Error import Language.PureScript.Ide.Logging import Language.PureScript.Ide.Types +import System.IO.UTF8 (readUTF8FileT) identifierFromIdeDeclaration :: IdeDeclaration -> Text identifierFromIdeDeclaration d = case d of @@ -127,6 +130,14 @@ identT = iso P.runIdent P.Ident opNameT :: Iso' (P.OpName a) Text opNameT = iso P.runOpName P.OpName +ideReadFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text +ideReadFile fp = do + contents :: Either IOException Text <- liftIO (try (readUTF8FileT fp)) + either + (\_ -> throwError (GeneralError ("Couldn't find file at: " <> T.pack fp))) + pure + contents + prettyTypeT :: P.Type -> Text prettyTypeT = T.unwords diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index e999debe9d..ce90f9372a 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -190,7 +190,7 @@ importShouldBe :: [Text] -> [Text] -> Expectation importShouldBe res importSection = res `shouldBe` [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId x = x"] -runIdeLoaded :: Command -> IO (Either PscIdeError Success) +runIdeLoaded :: Command -> IO (Either IdeError Success) runIdeLoaded c = do ([_, result], _) <- Test.inProject $ Test.runIde [Command.LoadSync [] , c] pure result diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index 652da4672a..5d3841bf7b 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -24,7 +24,7 @@ defConfig = , confGlobs = ["src/*.purs"] } -runIde' :: Configuration -> IdeState -> [Command] -> IO ([Either PscIdeError Success], IdeState) +runIde' :: Configuration -> IdeState -> [Command] -> IO ([Either IdeError Success], IdeState) runIde' conf s cs = do stateVar <- newTVarIO s let env' = IdeEnvironment {ideStateVar = stateVar, ideConfiguration = conf} @@ -32,7 +32,7 @@ runIde' conf s cs = do newState <- readTVarIO stateVar pure (r, newState) -runIde :: [Command] -> IO ([Either PscIdeError Success], IdeState) +runIde :: [Command] -> IO ([Either IdeError Success], IdeState) runIde = runIde' defConfig emptyIdeState s3 :: IdeState -> [(Text, [IdeDeclarationAnn])] -> IdeState From bc18c54110505323ace1b08b1fd9529ff9faba58 Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Sat, 28 Jan 2017 19:05:17 +0000 Subject: [PATCH 0642/1580] comment-styles: style comment types differently (#2597) * comment-styles: style comment types differently closes #2514 In JS output, style single line and block comments differently. * comment-styles: add myself to CONTRIBUTORS.md --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Pretty/JS.hs | 24 +++++++++++++++--------- 2 files changed, 16 insertions(+), 9 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 192f9529eb..c27cca5b4c 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -87,6 +87,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@bbqbaron](https://github.com/bbqbaron) (Eric Loren) My existing contributions and all future contributions until further notice are Copyright Eric Loren, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@RyanGlScott](https://github.com/RyanGlScott) (Ryan Scott) My existing contributions and all future contributions until further notice are Copyright Ryan Scott, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@seungha-kim](https://github.com/seungha-kim) (Seungha Kim) My existing contributions and all future contributions until further notice are Copyright Seungha Kim, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@matthewleon](https://github.com/matthewleon) (Matthew Leon) My existing contributions and all future contributions until further notice are Copyright Matthew Leon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 175520756e..92de636eaf 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -122,22 +122,30 @@ literals = mkPattern' match' [ return $ emit $ lbl <> ": " , prettyPrintJS' js ] - match (JSComment _ com js) = fmap mconcat $ sequence $ + match (JSComment _ com js) = mconcat <$> sequence + [ mconcat <$> forM com comment + , prettyPrintJS' js + ] + match (JSRaw _ js) = return $ emit js + match _ = mzero + + comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen + comment (LineComment com) = fmap mconcat $ sequence $ + [ return $ emit "\n" + , currentIndent + , return $ emit "//" <> emit com <> emit "\n" + ] + comment (BlockComment com) = fmap mconcat $ sequence $ [ return $ emit "\n" , currentIndent , return $ emit "/**\n" ] ++ - map asLine (concatMap commentLines com) ++ + map asLine (T.lines com) ++ [ currentIndent , return $ emit " */\n" , currentIndent - , prettyPrintJS' js ] where - commentLines :: Comment -> [Text] - commentLines (LineComment s) = [s] - commentLines (BlockComment s) = T.lines s - asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen asLine s = do i <- currentIndent @@ -150,8 +158,6 @@ literals = mkPattern' match' Nothing -> case T.uncons t of Just (x, xs) -> x `T.cons` removeComments xs Nothing -> "" - match (JSRaw _ js) = return $ emit js - match _ = mzero conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS) conditional = mkPattern match From c05106c3d7dffbb238e297412f5366885f75de27 Mon Sep 17 00:00:00 2001 From: Remy Goldschmidt Date: Sat, 28 Jan 2017 21:07:11 -0500 Subject: [PATCH 0643/1580] Update `psc-package` to use turtle 1.3 (#2585) * Change summary * `purescript.cabal` * `turtle` constraint is now `== 1.3.*` * `optparse-applicative` constraint is now `>= 0.13.0` * `stack.yaml` and `stack-ghc-8.0.yaml` * Added `turtle-1.3.1` and `optparse-applicative-0.13.0.0` to `extra-deps`. * `psc-package/Main.hs` * Added `echoT`, which mimics the old (1.2.8) behavior and type of `Turtle.echo`. * Replaced all uses of `echo` with `echoT`. * `New.listRemoteTags = Turtle.lineToText <$> Old.listRemoteTags` * `CONTRIBUTORS.md` * Added @taktoa (Remy Goldschmidt) --- CONTRIBUTORS.md | 1 + psc-package/Main.hs | 67 +++++++++++++++++++++++---------------------- purescript.cabal | 16 +++++------ stack-ghc-8.0.yaml | 2 ++ stack.yaml | 2 ++ 5 files changed, 48 insertions(+), 40 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index c27cca5b4c..7be718bb8a 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -76,6 +76,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@sharkdp](https://github.com/sharkdp) (David Peter) My existing contributions and all future contributions until further notice are Copyright David Peter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@sztupi](https://github.com/sztupi) (Attila Sztupak) My existing contributions and all future contributions until further notice are Copyright Attila Sztupak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@taktoa](https://github.com/taktoa) (Remy Goldschmidt) My existing contributions and all future contributions until further notice are Copyright Remy Goldschmidt, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@taku0](https://github.com/taku0) - My existing contributions and all future contributions until further notice are Copyright taku0, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@tmcgilchrist](https://github.com/tmcgilchrist) (Tim McGilchrist) My existing contributions and all future contributions until further notice are Copyright Tim McGilchrist, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). diff --git a/psc-package/Main.hs b/psc-package/Main.hs index 71d95603a2..897515b153 100644 --- a/psc-package/Main.hs +++ b/psc-package/Main.hs @@ -28,9 +28,12 @@ import GHC.Generics (Generic) import qualified Options.Applicative as Opts import qualified Paths_purescript as Paths import qualified System.IO as IO -import Turtle hiding (fold, s, x) +import Turtle hiding (echo, fold, s, x) import qualified Turtle +echoT :: Text -> IO () +echoT = Turtle.printf (Turtle.s % "\n") + packageFile :: Path.FilePath packageFile = "psc-package.json" @@ -56,12 +59,12 @@ readPackageFile :: IO PackageConfig readPackageFile = do exists <- testfile packageFile unless exists $ do - echo "psc-package.json does not exist" + echoT "psc-package.json does not exist" exit (ExitFailure 1) mpkg <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile packageFile case mpkg of Nothing -> do - echo "Unable to parse psc-package.json" + echoT "Unable to parse psc-package.json" exit (ExitFailure 1) Just pkg -> return pkg @@ -124,13 +127,13 @@ listRemoteTags :: Text -- ^ repo -> Turtle.Shell Text -listRemoteTags from = - inproc "git" - [ "ls-remote" - , "-q" - , "-t" - , from - ] empty +listRemoteTags from = let gitProc = inproc "git" + [ "ls-remote" + , "-q" + , "-t" + , from + ] empty + in lineToText <$> gitProc getPackageSet :: PackageConfig -> IO () getPackageSet PackageConfig{ source, set } = do @@ -143,12 +146,12 @@ readPackageSet PackageConfig{ set } = do let dbFile = ".psc-package" fromText set ".set" "packages.json" exists <- testfile dbFile unless exists $ do - echo $ format (fp%" does not exist") dbFile + echoT $ format (fp%" does not exist") dbFile exit (ExitFailure 1) mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile case mdb of Nothing -> do - echo "Unable to parse packages.json" + echoT "Unable to parse packages.json" exit (ExitFailure 1) Just db -> return db @@ -159,7 +162,7 @@ writePackageSet PackageConfig{ set } = installOrUpdate :: Text -> Text -> PackageInfo -> IO Turtle.FilePath installOrUpdate set pkgName PackageInfo{ repo, version } = do - echo ("Updating " <> pkgName) + echoT ("Updating " <> pkgName) let pkgDir = ".psc-package" fromText set fromText pkgName fromText version exists <- testdir pkgDir unless exists . void $ cloneShallow repo version pkgDir @@ -170,7 +173,7 @@ getTransitiveDeps db depends = do pkgs <- for depends $ \pkg -> case Map.lookup pkg db of Nothing -> do - echo ("Package " <> pkg <> " does not exist in package set") + echoT ("Package " <> pkg <> " does not exist in package set") exit (ExitFailure 1) Just PackageInfo{ dependencies } -> return (pkg : dependencies) let unique = Set.toList (foldMap Set.fromList pkgs) @@ -181,16 +184,16 @@ updateImpl config@PackageConfig{ depends } = do getPackageSet config db <- readPackageSet config trans <- getTransitiveDeps db depends - echo ("Updating " <> pack (show (length trans)) <> " packages...") + echoT ("Updating " <> pack (show (length trans)) <> " packages...") for_ trans $ \(pkgName, pkg) -> installOrUpdate (set config) pkgName pkg initialize :: IO () initialize = do exists <- testfile "psc-package.json" when exists $ do - echo "psc-package.json already exists" + echoT "psc-package.json already exists" exit (ExitFailure 1) - echo "Initializing new project in current directory" + echoT "Initializing new project in current directory" pkgName <- pathToTextUnsafe . Path.filename <$> pwd let pkg = defaultPackage pkgName writePackageFile pkg @@ -200,7 +203,7 @@ update :: IO () update = do pkg <- readPackageFile updateImpl pkg - echo "Update complete" + echoT "Update complete" install :: String -> IO () install pkgName = do @@ -208,7 +211,7 @@ install pkgName = do let pkg' = pkg { depends = nub (pack pkgName : depends pkg) } updateImpl pkg' writePackageFile pkg' - echo "psc-package.json file was updated" + echoT "psc-package.json file was updated" uninstall :: String -> IO () uninstall pkgName = do @@ -216,20 +219,20 @@ uninstall pkgName = do let pkg' = pkg { depends = filter (/= pack pkgName) $ depends pkg } updateImpl pkg' writePackageFile pkg' - echo "psc-package.json file was updated" + echoT "psc-package.json file was updated" listDependencies :: IO () listDependencies = do pkg@PackageConfig{ depends } <- readPackageFile db <- readPackageSet pkg trans <- getTransitiveDeps db depends - traverse_ (echo . fst) trans + traverse_ (echoT . fst) trans listPackages :: IO () listPackages = do pkg <- readPackageFile db <- readPackageSet pkg - traverse_ echo (fmt <$> Map.assocs db) + traverse_ echoT (fmt <$> Map.assocs db) where fmt :: (Text, PackageInfo) -> Text fmt (name, PackageInfo{ version }) = name <> " (" <> version <> ")" @@ -251,7 +254,7 @@ listSourcePaths = do pkg@PackageConfig{ depends } <- readPackageFile db <- readPackageSet pkg paths <- getSourcePaths pkg db depends - traverse_ (echo . pathToTextUnsafe) paths + traverse_ (echoT . pathToTextUnsafe) paths exec :: Text -> IO () exec exeName = do @@ -267,11 +270,11 @@ checkForUpdates applyMinorUpdates applyMajorUpdates = do pkg <- readPackageFile db <- readPackageSet pkg - echo ("Checking " <> pack (show (Map.size db)) <> " packages for updates.") - echo "Warning: this could take some time!" + echoT ("Checking " <> pack (show (Map.size db)) <> " packages for updates.") + echoT "Warning: this could take some time!" newDb <- Map.fromList <$> (for (Map.toList db) $ \(name, p@PackageInfo{ repo, version }) -> do - echo ("Checking package " <> name) + echoT ("Checking package " <> name) tagLines <- Turtle.fold (listRemoteTags repo) Foldl.list let tags = mapMaybe parseTag tagLines newVersion <- case parseVersion version of @@ -280,7 +283,7 @@ checkForUpdates applyMinorUpdates applyMajorUpdates = do case filter (isMinorReleaseFrom parts) tags of [] -> pure version minorReleases -> do - echo ("New minor release available") + echoT ("New minor release available") case applyMinorUpdates of True -> do let latestMinorRelease = maximum minorReleases @@ -290,7 +293,7 @@ checkForUpdates applyMinorUpdates applyMajorUpdates = do case filter (isMajorReleaseFrom parts) tags of [] -> applyMinor newReleases -> do - echo ("New major release available") + echoT ("New major release available") case applyMajorUpdates of True -> do let latestRelease = maximum newReleases @@ -298,7 +301,7 @@ checkForUpdates applyMinorUpdates applyMajorUpdates = do False -> applyMinor in applyMajor _ -> do - echo "Unable to parse version string" + echoT "Unable to parse version string" pure version pure (name, p { version = newVersion })) @@ -345,15 +348,15 @@ verifyPackageSet = do pkg <- readPackageFile db <- readPackageSet pkg - echo ("Verifying " <> pack (show (Map.size db)) <> " packages.") - echo "Warning: this could take some time!" + echoT ("Verifying " <> pack (show (Map.size db)) <> " packages.") + echoT "Warning: this could take some time!" let installOrUpdate' (name, pkgInfo) = (name, ) <$> installOrUpdate (set pkg) name pkgInfo paths <- Map.fromList <$> traverse installOrUpdate' (Map.toList db) for_ (Map.toList db) $ \(name, PackageInfo{..}) -> do let dirFor = fromMaybe (error "verifyPackageSet: no directory") . (`Map.lookup` paths) - echo ("Verifying package " <> name) + echoT ("Verifying package " <> name) let srcGlobs = map (pathToTextUnsafe . ( ("src" "**" "*.purs")) . dirFor) (name : dependencies) procs "psc" srcGlobs empty diff --git a/purescript.cabal b/purescript.cabal index 6b606a2b44..4c934f2c81 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -351,7 +351,7 @@ executable psc filepath -any, Glob >= 0.7 && < 0.8, mtl -any, - optparse-applicative >= 0.12.1, + optparse-applicative >= 0.13.0, parsec -any, text -any, time -any, @@ -378,7 +378,7 @@ executable psci haskeline >= 0.7.0.0, http-types == 0.9.*, mtl -any, - optparse-applicative >= 0.12.1, + optparse-applicative >= 0.13.0, parsec -any, process -any, stm >= 0.2.4.0, @@ -404,7 +404,7 @@ executable psc-docs filepath -any, Glob -any, mtl -any, - optparse-applicative >= 0.12.1, + optparse-applicative >= 0.13.0, process -any, split -any, text -any, @@ -442,7 +442,7 @@ executable psc-package optparse-applicative -any, system-filepath -any, text -any, - turtle <1.3 + turtle ==1.3.* main-is: Main.hs other-modules: Paths_purescript buildable: True @@ -456,7 +456,7 @@ executable psc-hierarchy filepath -any, Glob -any, mtl -any, - optparse-applicative >= 0.12.1, + optparse-applicative >= 0.13.0, parsec -any, process -any, text -any @@ -479,7 +479,7 @@ executable psc-bundle filepath -any, Glob -any, mtl -any, - optparse-applicative >= 0.12.1, + optparse-applicative >= 0.13.0, sourcemap >= 0.1.6, transformers -any, transformers-compat -any, @@ -501,7 +501,7 @@ executable psc-ide-server monad-logger -any, mtl -any, network -any, - optparse-applicative >= 0.12.1, + optparse-applicative >= 0.13.0, protolude >= 0.1.6, stm -any, text -any, @@ -518,7 +518,7 @@ executable psc-ide-client bytestring -any, mtl -any, network -any, - optparse-applicative >= 0.12.1, + optparse-applicative >= 0.13.0, text -any ghc-options: -Wall -O2 hs-source-dirs: psc-ide-client diff --git a/stack-ghc-8.0.yaml b/stack-ghc-8.0.yaml index bea97047b0..5ebb5a40ca 100644 --- a/stack-ghc-8.0.yaml +++ b/stack-ghc-8.0.yaml @@ -6,3 +6,5 @@ extra-deps: - wai-websockets-3.0.0.9 - websockets-0.9.6.2 - bower-json-1.0.0.1 +- turtle-1.3.1 +- optparse-applicative-0.13.0.0 \ No newline at end of file diff --git a/stack.yaml b/stack.yaml index 6d5f737c8d..b5edd07db6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,3 +3,5 @@ packages: - '.' extra-deps: - bower-json-1.0.0.1 +- turtle-1.3.1 +- optparse-applicative-0.13.0.0 \ No newline at end of file From 32faa7695dc4a3f43498d8c1614e3a8e9b62fb88 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sun, 29 Jan 2017 02:20:52 +0000 Subject: [PATCH 0644/1580] Change nested record update syntax and fix bug with depth > 2 (#2580) * Change nested record update syntax and fix bug with depth > 2 * Build update tree in parser * Remove accidental pragmas --- examples/passing/NestedRecordUpdate.purs | 11 +- .../passing/NestedRecordUpdateWildcards.purs | 2 +- src/Language/PureScript/AST/Declarations.hs | 40 +++++- src/Language/PureScript/AST/Traversals.hs | 14 +-- .../PureScript/Parser/Declarations.hs | 34 ++++-- src/Language/PureScript/Pretty/Values.hs | 18 ++- .../PureScript/Sugar/ObjectWildcards.hs | 114 ++++-------------- 7 files changed, 107 insertions(+), 126 deletions(-) diff --git a/examples/passing/NestedRecordUpdate.purs b/examples/passing/NestedRecordUpdate.purs index 72be8c0dc3..60eef8f557 100644 --- a/examples/passing/NestedRecordUpdate.purs +++ b/examples/passing/NestedRecordUpdate.purs @@ -3,21 +3,22 @@ module Main where import Prelude import Control.Monad.Eff.Console -type T = { foo :: Int, bar :: { baz :: Int, qux :: Int } } +type T = { foo :: Int, bar :: { baz :: Int, qux :: { lhs :: Int, rhs :: Int } } } init :: T -init = { foo: 1, bar: { baz: 2, qux: 3 } } +init = { foo: 1, bar: { baz: 2, qux: { lhs: 3, rhs: 4 } } } updated :: T -updated = init { foo = 10, bar.baz = 20, bar.qux = 30 } +updated = init { foo = 10, bar { baz = 20, qux { lhs = 30, rhs = 40 } } } expected :: T -expected = { foo: 10, bar: { baz: 20, qux: 30 } } +expected = { foo: 10, bar: { baz: 20, qux: { lhs: 30, rhs: 40 } } } check l r = l.foo == r.foo && l.bar.baz == r.bar.baz && - l.bar.qux == r.bar.qux + l.bar.qux.lhs == r.bar.qux.lhs && + l.bar.qux.rhs == r.bar.qux.rhs main = do when (check updated expected) $ log "Done" diff --git a/examples/passing/NestedRecordUpdateWildcards.purs b/examples/passing/NestedRecordUpdateWildcards.purs index e16d7c571f..7c99276018 100644 --- a/examples/passing/NestedRecordUpdateWildcards.purs +++ b/examples/passing/NestedRecordUpdateWildcards.purs @@ -3,7 +3,7 @@ module Main where import Prelude import Control.Monad.Eff.Console -update = _ { foo = _, bar.baz = _, bar.qux = _ } +update = _ { foo = _, bar { baz = _, qux = _ } } init = { foo: 1, bar: { baz: 2, qux: 3 } } diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 415d26004d..6544cae120 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} -- | -- Data types for modules and declarations @@ -12,7 +14,6 @@ import Control.Monad.Identity import Data.Aeson.TH import qualified Data.Map as M import Data.Text (Text) -import Data.List.NonEmpty (NonEmpty(..)) import Language.PureScript.AST.Binders import Language.PureScript.AST.Literals @@ -587,10 +588,10 @@ data Expr -- | ObjectUpdate Expr [(PSString, Expr)] -- | - -- Object updates with nested support: `x { foo.bar = e }` + -- Object updates with nested support: `x { foo { bar = e } }` -- Replaced during desugaring into a `Let` and nested `ObjectUpdate`s -- - | ObjectUpdateNested Expr [(NonEmpty PSString, Expr)] + | ObjectUpdateNested Expr (PathTree Expr) -- | -- Function introduction -- @@ -706,5 +707,38 @@ data DoNotationElement | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show) + +-- For a record update such as: +-- +-- x { foo = 0 +-- , bar { baz = 1 +-- , qux = 2 } } +-- +-- We represent the updates as the `PathTree`: +-- +-- [ ("foo", Leaf 3) +-- , ("bar", Branch [ ("baz", Leaf 1) +-- , ("qux", Leaf 2) ]) ] +-- +-- Which we then convert to an expression representing the following: +-- +-- let x' = x +-- in x' { foo = 0 +-- , bar = x'.bar { baz = 1 +-- , qux = 2 } } +-- +-- The `let` here is required to prevent re-evaluating the object expression `x`. +-- However we don't generate this when using an anonymous argument for the object. +-- + +newtype PathTree t = PathTree (AssocList PSString (PathNode t)) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable) + +data PathNode t = Leaf t | Branch (PathTree t) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable) + +newtype AssocList k t = AssocList { runAssocList :: [(k, t)] } + deriving (Show, Eq, Ord, Foldable, Functor, Traversable) + $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 3e56ab7155..169bd679b4 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -48,7 +48,7 @@ everywhereOnValues f g h = (f', g', h') g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v)) g' (Accessor prop v) = g (Accessor prop (g' v)) g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs)) - g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (map (fmap g') vs)) + g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs)) g' (Abs name v) = g (Abs name (g' v)) g' (App v1 v2) = g (App (g' v1) (g' v2)) g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3)) @@ -116,7 +116,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g') g' (Accessor prop v) = Accessor prop <$> (g v >>= g') g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs - g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs + g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (g' <=< g) vs g' (Abs name v) = Abs name <$> (g v >>= g') g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g') g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g') @@ -184,7 +184,7 @@ everywhereOnValuesM f g h = (f', g', h') g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g - g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse (sndM g') vs) >>= g + g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse g' vs) >>= g g' (Abs name v) = (Abs name <$> g' v) >>= g g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g @@ -257,7 +257,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1 g' v@(Accessor _ v1) = g v <> g' v1 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs) - g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs) + g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (fmap g' vs) g' v@(Abs _ v1) = g v <> g' v1 g' v@(App v1 v2) = g v <> g' v1 <> g' v2 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3 @@ -335,7 +335,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs) - g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs) + g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s) vs) g' s (Abs _ v1) = g'' s v1 g' s (App v1 v2) = g'' s v1 <> g'' s v2 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 @@ -415,7 +415,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v g' s (Accessor prop v) = Accessor prop <$> g'' s v g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs - g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (sndM (g'' s)) vs + g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (g'' s) vs g' s (Abs name v) = Abs name <$> g'' s v g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3 @@ -506,7 +506,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs - g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s . snd) vs + g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s) vs g' s (Abs (Left name) v1) = let s' = S.insert name s in g'' s' v1 diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 8b64b38444..42bd4f3690 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -17,13 +17,12 @@ import Prelude hiding (lex) import Control.Applicative import Control.Arrow ((+++)) +import Control.Monad (foldM) import Control.Monad.Error.Class (MonadError(..)) import Control.Parallel.Strategies (withStrategy, parList, rseq) -import Data.Bifunctor (first) import Data.Functor (($>)) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as N import Data.Maybe (fromMaybe) +import qualified Data.Set as S import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Environment @@ -399,13 +398,17 @@ parseInfixExpr parseHole :: TokenParser Expr parseHole = Hole <$> holeLit -parsePropertyUpdate :: TokenParser (NonEmpty PSString, Expr) +parsePropertyUpdate :: TokenParser (PSString, PathNode Expr) parsePropertyUpdate = do name <- parseLabel - rest <- P.many (indented *> dot *> indented *> parseLabel) - _ <- indented *> equals - value <- indented *> parseValue - return (name :| rest, value) + updates <- parseShallowUpdate <|> parseNestedUpdate + return (name, updates) + where + parseShallowUpdate :: TokenParser (PathNode Expr) + parseShallowUpdate = Leaf <$> (indented *> equals *> indented *> parseValue) + + parseNestedUpdate :: TokenParser (PathNode Expr) + parseNestedUpdate = Branch <$> parseUpdaterBodyFields parseAccessor :: Expr -> TokenParser Expr parseAccessor (Constructor _) = P.unexpected "constructor" @@ -455,11 +458,18 @@ parseValue = withSourceSpan PositionedValue ] ] -parseUpdaterBody :: Expr -> TokenParser Expr -parseUpdaterBody v = objectUpdate <$> (indented *> braces (commaSep1 (indented *> parsePropertyUpdate))) +parseUpdaterBodyFields :: TokenParser (PathTree Expr) +parseUpdaterBodyFields = do + updates <- indented *> braces (commaSep1 (indented *> parsePropertyUpdate)) + (_, tree) <- foldM insertUpdate (S.empty, []) updates + return (PathTree (AssocList (reverse tree))) where - objectUpdate xs | all (null . N.tail . fst) xs = ObjectUpdate v (map (first N.head) xs) - | otherwise = ObjectUpdateNested v xs + insertUpdate (seen, xs) (key, node) + | S.member key seen = P.unexpected ("Duplicate key in record update: " ++ show key) + | otherwise = return (S.insert key seen, (key, node) : xs) + +parseUpdaterBody :: Expr -> TokenParser Expr +parseUpdaterBody v = ObjectUpdateNested v <$> parseUpdaterBodyFields parseAnonymousArgument :: TokenParser Expr parseAnonymousArgument = underscore *> pure AnonymousArgument diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index cbabc78ebc..4cff7ee16e 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -12,7 +12,6 @@ import Prelude.Compat import Control.Arrow (second) import qualified Data.Monoid as Monoid ((<>)) -import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Text as T import Data.Text (Text) @@ -48,11 +47,8 @@ prettyPrintObject d = list '{' '}' prettyPrintObjectProperty prettyPrintObjectProperty :: (PSString, Maybe Expr) -> Box prettyPrintObjectProperty (key, value) = textT (prettyPrintObjectKey key Monoid.<> ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value -prettyPrintObjectUpdate :: forall k. (k -> Box) -> Int -> Expr -> [(k, Expr)] -> Box -prettyPrintObjectUpdate printKey d o ps = - prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' printEntry ps - where - printEntry (key, val) = printKey key <> text " = " <> prettyPrintValue (d - 1) val +prettyPrintUpdateEntry :: Int -> PSString -> Expr -> Box +prettyPrintUpdateEntry d key val = textT (prettyPrintObjectKey key) <> text " = " <> prettyPrintValue (d - 1) val -- | Pretty-print an expression prettyPrintValue :: Int -> Expr -> Box @@ -63,10 +59,12 @@ prettyPrintValue d (IfThenElse cond th el) = , text "else " <> prettyPrintValueAtom (d - 1) el ]) prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop) -prettyPrintValue d (ObjectUpdate o ps) = prettyPrintObjectUpdate (textT . prettyPrintObjectKey) d o ps -prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintObjectUpdate printPath d o ps where - printPath (hd :| tl) = foldl combine (textT (prettyPrintObjectKey hd)) tl - combine acc key = acc <> textT ("." Monoid.<> prettyPrintObjectKey key) +prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (uncurry (prettyPrintUpdateEntry d)) ps +prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` prettyPrintUpdate ps + where + prettyPrintUpdate (PathTree tree) = list '{' '}' printNode (runAssocList tree) + printNode (key, Leaf val) = prettyPrintUpdateEntry d key val + printNode (key, Branch val) = textT (prettyPrintObjectKey key) `beforeWithSpace` prettyPrintUpdate val prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 3fb343506a..149939ab13 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -5,46 +5,18 @@ module Language.PureScript.Sugar.ObjectWildcards import Prelude.Compat -import Control.Monad (forM, foldM) +import Control.Monad (forM) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class -import Data.List (partition) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Map (Map) -import qualified Data.Map as M +import Data.Foldable (toList) +import Data.List (foldl') import Data.Maybe (catMaybes) import Language.PureScript.AST import Language.PureScript.Environment (NameKind(..)) import Language.PureScript.Errors -import Language.PureScript.Label (Label(..)) import Language.PureScript.Names import Language.PureScript.PSString (PSString) --- `PathNode` and `PathTree` are used as an intermediate form when desugaring a nested object update. --- For an update such as: --- --- x { foo = 0 --- , bar.baz = 1 --- , bar.qux = 2 } --- --- We represent the updates as the `PathTree`: --- --- M.fromList [ ("foo", Leaf 3) --- , ("bar", Branch (M.fromList [ ("baz", Leaf 1) --- , ("qux", Leaf 2) ]) ]) --- --- Which we then convert to an expression representing the following: --- --- let x' = x --- in x' { foo = 0 --- , bar = x'.bar { baz = 1 --- , qux = 2 } } --- --- The `let` here is required to prevent re-evaluating the object expression `x`. --- However we don't generate this when using an anonymous argument for the object. --- -type PathTree = Map PSString PathNode -data PathNode = Leaf Expr | Branch PathTree desugarObjectConstructors :: forall m @@ -70,11 +42,7 @@ desugarDecl other = fn other , BinaryNoParens op u val <- b' , isAnonymousArgument u = do arg <- freshIdent' return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val - desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps - desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do - obj <- freshIdent' - Abs (Left obj) <$> wrapLambda (ObjectUpdate (argToExpr obj)) ps - desugarExpr (ObjectUpdate obj ps) = wrapLambda (ObjectUpdate obj) ps + desugarExpr (Literal (ObjectLiteral ps)) = wrapLambdaAssoc (Literal . ObjectLiteral) ps desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps desugarExpr (Accessor prop u) | Just props <- peelAnonAccessorChain u = do @@ -92,67 +60,42 @@ desugarDecl other = fn other return $ foldr (Abs . Left) if_ (catMaybes [u', t', f']) desugarExpr e = return e - transformNestedUpdate :: Expr -> [(NonEmpty PSString, Expr)] -> m Expr + transformNestedUpdate :: Expr -> PathTree Expr -> m Expr transformNestedUpdate obj ps = do -- If we don't have an anonymous argument then we need to generate a let wrapper -- so that the object expression isn't re-evaluated for each nested update. val <- freshIdent' + let valExpr = argToExpr val if isAnonymousArgument obj - then Abs (Left val) <$> wrapLambdaM (build val) ps - else wrapLambdaM (fmap (buildLet val) . build val) ps + then Abs (Left val) <$> wrapLambda (buildUpdates valExpr) ps + else wrapLambda (buildLet val . buildUpdates valExpr) ps where - build val xs = buildUpdates (argToExpr val) <$> foldM buildTree M.empty xs buildLet val = Let [ValueDeclaration val Public [] (Right obj)] - -- Here we build up the intermediate `PathTree` data structure and check that - -- the paths are valid relative to each other - for example, the update - -- `{ foo.bar = 2, foo = {bar: 3} }` is invalid because there are conflicting - -- paths. - buildTree - :: PathTree - -> (NonEmpty PSString, Expr) - -> m PathTree - buildTree pathTree (path, e) = go pathTree path where - go tree (key :| []) - -- path already exists - | key `M.member` tree = throwError . errorMessage $ DuplicateLabel (Label key) (Just (ObjectUpdateNested obj ps)) - -- create new path - | otherwise = return (M.insert key (Leaf e) tree) - go tree (key :| (x : xs)) = do - branch <- case M.lookup key tree of - -- nothing at this path yet - Nothing -> return M.empty - -- already a map at this path - Just (Branch branch) -> return branch - -- sub-path already exists - Just (Leaf _) -> throwError . errorMessage $ DuplicateLabel (Label key) (Just (ObjectUpdateNested obj ps)) - M.insert key . Branch <$> go branch (x :| xs) <*> pure tree - - -- Now we have a valid collection of updates in the form of a `PathTree` - -- we can recursively build up the nested `ObjectUpdate` expressions. - buildUpdates :: Expr -> PathTree -> Expr - buildUpdates val vs = ObjectUpdate val (goLayer [] <$> M.toList vs) where - goLayer :: [PSString] -> (PSString, PathNode) -> (PSString, Expr) + -- recursively build up the nested `ObjectUpdate` expressions + buildUpdates :: Expr -> PathTree Expr -> Expr + buildUpdates val (PathTree vs) = ObjectUpdate val (goLayer [] <$> runAssocList vs) where + goLayer :: [PSString] -> (PSString, PathNode Expr) -> (PSString, Expr) goLayer _ (key, Leaf expr) = (key, expr) - goLayer path (key, Branch branch) = + goLayer path (key, Branch (PathTree branch)) = let path' = path ++ [key] - updates = goLayer path' <$> M.toList branch - accessor = foldr Accessor val path' + updates = goLayer path' <$> runAssocList branch + accessor = foldl' (flip Accessor) val path' objectUpdate = ObjectUpdate accessor updates in (key, objectUpdate) - wrapLambdaM :: forall k. ([(k, Expr)] -> m Expr) -> [(k, Expr)] -> m Expr - wrapLambdaM mkVal ps = - let (args, props) = partition (isAnonymousArgument . snd) ps - in if null args - then mkVal props - else do - (args', ps') <- unzip <$> mapM mkProp ps - val <- mkVal ps' - return $ foldr (Abs . Left) val (catMaybes args') + wrapLambda :: forall t. Traversable t => (t Expr -> Expr) -> t Expr -> m Expr + wrapLambda mkVal ps = do + args <- traverse processExpr ps + return $ foldr (Abs . Left) (mkVal (snd <$> args)) (catMaybes $ toList (fst <$> args)) + where + processExpr :: Expr -> m (Maybe Ident, Expr) + processExpr e = do + arg <- freshIfAnon e + return (arg, maybe e argToExpr arg) - wrapLambda :: forall k. ([(k, Expr)] -> Expr) -> [(k, Expr)] -> m Expr - wrapLambda mkVal = wrapLambdaM (return . mkVal) + wrapLambdaAssoc :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr + wrapLambdaAssoc mkVal = wrapLambda (mkVal . runAssocList) . AssocList stripPositionInfo :: Expr -> Expr stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e @@ -169,11 +112,6 @@ desugarDecl other = fn other isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e isAnonymousArgument _ = False - mkProp :: forall k. (k, Expr) -> m (Maybe Ident, (k, Expr)) - mkProp (name, e) = do - arg <- freshIfAnon e - return (arg, (name, maybe e argToExpr arg)) - freshIfAnon :: Expr -> m (Maybe Ident) freshIfAnon u | isAnonymousArgument u = Just <$> freshIdent' From fcc6c996635447b4ba46280face03180ce533c30 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 28 Jan 2017 19:33:43 -0800 Subject: [PATCH 0645/1580] Disable MacOS builds for now --- .travis.yml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.travis.yml b/.travis.yml index db6940d0ef..b6ba6c5760 100644 --- a/.travis.yml +++ b/.travis.yml @@ -39,13 +39,13 @@ matrix: sudo: required env: BUILD_TYPE=haddock - - compiler: cc-osx-lts-normal - os: osx - env: BUILD_TYPE=normal DEPLOY=true - - - compiler: cc-osx-lts-sdist - os: osx - env: BUILD_TYPE=sdist + # - compiler: cc-osx-lts-normal + # os: osx + # env: BUILD_TYPE=normal DEPLOY=true + + # - compiler: cc-osx-lts-sdist + # os: osx + # env: BUILD_TYPE=sdist addons: apt: packages: From 090f185ecec35901992381991b0266668ad0da26 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 29 Jan 2017 09:43:16 -0800 Subject: [PATCH 0646/1580] Failing example for #2601 (#2607) --- examples/failing/2601.purs | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 examples/failing/2601.purs diff --git a/examples/failing/2601.purs b/examples/failing/2601.purs new file mode 100644 index 0000000000..00dc25f606 --- /dev/null +++ b/examples/failing/2601.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +type Syn (a :: * -> *) = String + +val :: Syn Int +val = "bad" From 6277f69258418a8e5beff081daa0610fd4e4ac42 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Mon, 30 Jan 2017 17:35:24 +0100 Subject: [PATCH 0647/1580] Add HasCallStack to internalError (#2608) * Add HasCallStack to internalError * Update CONTRIBUTORS.md * Update CONTRIBUTORS.md * Update CONTRIBUTORS.md --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Crash.hs | 38 +++++++++++++++++++++++--------- 2 files changed, 28 insertions(+), 11 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 7be718bb8a..43377dd16c 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -89,6 +89,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@RyanGlScott](https://github.com/RyanGlScott) (Ryan Scott) My existing contributions and all future contributions until further notice are Copyright Ryan Scott, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@seungha-kim](https://github.com/seungha-kim) (Seungha Kim) My existing contributions and all future contributions until further notice are Copyright Seungha Kim, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@matthewleon](https://github.com/matthewleon) (Matthew Leon) My existing contributions and all future contributions until further notice are Copyright Matthew Leon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@alexbiehl](https://github.com/alexbiehl) (Alexander Biehl) My existing contributions and all future contributions until further notice are Copyright Alexander Biehl, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/src/Language/PureScript/Crash.hs b/src/Language/PureScript/Crash.hs index e1b6cccd63..1ce2f09f60 100644 --- a/src/Language/PureScript/Crash.hs +++ b/src/Language/PureScript/Crash.hs @@ -1,11 +1,27 @@ -module Language.PureScript.Crash where - -import Prelude.Compat - --- | Exit with an error message and a crash report link. -internalError :: String -> a -internalError = - error - . ("An internal error occurred during compilation: " ++) - . (++ "\nPlease report this at https://github.com/purescript/purescript/issues") - . show +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImplicitParams #-} + +module Language.PureScript.Crash where + +import Prelude.Compat + +import qualified GHC.Stack + +-- | A compatibility wrapper for the @GHC.Stack.HasCallStack@ constraint. +#if __GLASGOW_HASKELL__ >= 800 +type HasCallStack = GHC.Stack.HasCallStack +#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) +type HasCallStack = (?callStack :: GHC.Stack.CallStack) +#else +import GHC.Exts (Constraint) +-- CallStack wasn't present in GHC 7.10.1 +type HasCallStack = (() :: Constraint) +#endif + +-- | Exit with an error message and a crash report link. +internalError :: HasCallStack => String -> a +internalError = + error + . ("An internal error occurred during compilation: " ++) + . (++ "\nPlease report this at https://github.com/purescript/purescript/issues") + . show From ada063fb99a6ac1340490970267eda87c204efed Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 30 Jan 2017 09:02:28 -0800 Subject: [PATCH 0648/1580] Revert binder syntax (#2605) --- examples/passing/ParseNamedBinder.purs | 9 --------- src/Language/PureScript/Parser/Declarations.hs | 2 +- 2 files changed, 1 insertion(+), 10 deletions(-) delete mode 100644 examples/passing/ParseNamedBinder.purs diff --git a/examples/passing/ParseNamedBinder.purs b/examples/passing/ParseNamedBinder.purs deleted file mode 100644 index 01a297c818..0000000000 --- a/examples/passing/ParseNamedBinder.purs +++ /dev/null @@ -1,9 +0,0 @@ -module Main where - -import Control.Monad.Eff.Console (log) - -data X = X - -f a@X X = a - -main = log "Done" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 42bd4f3690..3ddd4fae40 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -497,7 +497,7 @@ parseArrayBinder = LiteralBinder <$> parseArrayLiteral (indented *> parseBinder) parseVarOrNamedBinder :: TokenParser Binder parseVarOrNamedBinder = do name <- parseIdent - let parseNamedBinder = NamedBinder name <$> (at *> indented *> parseBinderNoParens) + let parseNamedBinder = NamedBinder name <$> (at *> indented *> parseBinderAtom) parseNamedBinder <|> return (VarBinder name) parseNullBinder :: TokenParser Binder From 12c18ae7e146d9006cc72ad8e08595c1943c67d8 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 31 Jan 2017 16:59:25 +0000 Subject: [PATCH 0649/1580] Fix failure to parse git tag date in psc-publish (#2613) Fixes one of the problems mentioned in #2610. --- src/Language/PureScript/Publish.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 9ab21cad5a..3c4ba45c99 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -195,8 +195,9 @@ getVersionFromGitTag = do getTagTime :: Text -> PrepareM UTCTime getTagTime tag = do out <- readProcess' "git" ["show", T.unpack tag, "--no-patch", "--format=%aI"] "" - let time = headMay (lines out) >>= D.parseTime - maybe (internalError (CouldntParseGitTagDate tag)) pure time + case mapMaybe D.parseTime (lines out) of + [t] -> pure t + _ -> internalError (CouldntParseGitTagDate tag) getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo) getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract From 480d7e98f06722c63887076ec8b55c17ee02e270 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 31 Jan 2017 16:59:40 +0000 Subject: [PATCH 0650/1580] Fix psc-publish --dry-run (#2612) This fixes one of the two problems mentioned in #2610, that psc-publish --dry-run is broken. I also removed a misleading error message from the psc-publish tests (we no longer use git submodules for retrieving purescript libraries for running tests with). --- psc-publish/Main.hs | 3 +++ purescript.cabal | 4 +++- tests/TestPscPublish.hs | 9 --------- 3 files changed, 6 insertions(+), 10 deletions(-) diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs index 5d2e902bd2..fd84ec4667 100644 --- a/psc-publish/Main.hs +++ b/psc-publish/Main.hs @@ -2,10 +2,12 @@ module Main where +import Control.Monad.IO.Class (liftIO) import Data.Version (Version(..), showVersion) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy.Char8 as BL import Data.Monoid ((<>)) +import Data.Time.Clock (getCurrentTime) import Options.Applicative (Parser, ParseError (..)) import qualified Options.Applicative as Opts @@ -25,6 +27,7 @@ dryRunOptions :: PublishOptions dryRunOptions = defaultPublishOptions { publishGetVersion = return dummyVersion , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn + , publishGetTagTime = const (liftIO getCurrentTime) } where dummyVersion = ("0.0.0", Version [0,0,0] []) diff --git a/purescript.cabal b/purescript.cabal index 4c934f2c81..80c03c3eed 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -424,7 +424,9 @@ executable psc-publish purescript -any, aeson >= 0.8 && < 1.0, bytestring -any, - optparse-applicative -any + optparse-applicative -any, + time -any, + transformers -any main-is: Main.hs other-modules: Paths_purescript buildable: True diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 88c39f7c9c..a97ca1ff67 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -61,13 +61,4 @@ testPackage dir = pushd dir $ do print other exitFailure where - preparePackageError e@(UserError BowerJSONNotFound) = do - Publish.printErrorToStdout e - putStrLn "" - putStrLn "==========================================" - putStrLn "Did you forget to update the submodules?" - putStrLn "$ git submodule sync; git submodule update" - putStrLn "==========================================" - putStrLn "" - exitFailure preparePackageError e = Publish.printErrorToStdout e >> exitFailure From 5ff12867142df68c798c647216d8c0fde1ce65d1 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 4 Feb 2017 11:03:14 -0800 Subject: [PATCH 0651/1580] Combine inlining optimizations into a single pass (#2615) --- .../CodeGen/JS/Optimizer/Inliner.hs | 26 +++++++------------ 1 file changed, 9 insertions(+), 17 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index 440d22d672..deea258a2c 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -110,7 +110,7 @@ inlineCommonValues = everywhereOnJS convert intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0)) inlineCommonOperators :: JS -> JS -inlineCommonOperators = applyAll $ +inlineCommonOperators = everywhereOnJSTopDown $ applyAll $ [ binary semiringNumber opAdd Add , binary semiringNumber opMul Multiply @@ -173,38 +173,32 @@ inlineCommonOperators = applyAll $ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] where binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> JS -> JS - binary dict fns op = everywhereOnJS convert - where + binary dict fns op = convert where convert :: JS -> JS convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = JSBinary ss op x y convert other = other binary' :: Text -> PSString -> BinaryOperator -> JS -> JS - binary' moduleName opString op = everywhereOnJS convert - where + binary' moduleName opString op = convert where convert :: JS -> JS convert (JSApp ss (JSApp _ fn [x]) [y]) | isDict (moduleName, opString) fn = JSBinary ss op x y convert other = other unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> JS -> JS - unary dicts fns op = everywhereOnJS convert - where + unary dicts fns op = convert where convert :: JS -> JS convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = JSUnary ss op x convert other = other unary' :: Text -> PSString -> UnaryOperator -> JS -> JS - unary' moduleName fnName op = everywhereOnJS convert - where + unary' moduleName fnName op = convert where convert :: JS -> JS convert (JSApp ss fn [x]) | isDict (moduleName, fnName) fn = JSUnary ss op x convert other = other mkFn :: Int -> JS -> JS - mkFn 0 = everywhereOnJS convert - where + mkFn 0 = convert where convert :: JS -> JS convert (JSApp _ mkFnN [JSFunction s1 Nothing [_] (JSBlock s2 js)]) | isNFn C.mkFn 0 mkFnN = JSFunction s1 Nothing [] (JSBlock s2 js) convert other = other - mkFn n = everywhereOnJS convert - where + mkFn n = convert where convert :: JS -> JS convert orig@(JSApp ss mkFnN [fn]) | isNFn C.mkFn n mkFnN = case collectArgs n [] fn of @@ -223,8 +217,7 @@ inlineCommonOperators = applyAll $ isNFn _ _ _ = False runFn :: Int -> JS -> JS - runFn n = everywhereOnJS convert - where + runFn n = convert where convert :: JS -> JS convert js = fromMaybe js $ go n [] js @@ -234,8 +227,7 @@ inlineCommonOperators = applyAll $ go _ _ _ = Nothing inlineNonClassFunction :: (JS -> Bool) -> (JS -> JS -> JS) -> JS -> JS - inlineNonClassFunction p f = everywhereOnJS convert - where + inlineNonClassFunction p f = convert where convert :: JS -> JS convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y convert other = other From 0eb180c4f4474a5eb533ab255ffad548920ac9b6 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 5 Feb 2017 10:06:02 -0800 Subject: [PATCH 0652/1580] Disallow polymorphic types in binders, prevent internalError (#2624) * Disallow polymorphic types in binders, prevent internalError * Fix tests --- examples/docs/src/ExplicitTypeSignatures.purs | 2 -- examples/failing/2445.purs | 6 ++++++ src/Language/PureScript/TypeChecker/Types.hs | 8 +++----- src/Language/PureScript/Types.hs | 2 ++ tests/TestDocs.hs | 1 - 5 files changed, 11 insertions(+), 8 deletions(-) create mode 100644 examples/failing/2445.purs diff --git a/examples/docs/src/ExplicitTypeSignatures.purs b/examples/docs/src/ExplicitTypeSignatures.purs index f9fa06f40a..396ca1447c 100644 --- a/examples/docs/src/ExplicitTypeSignatures.purs +++ b/examples/docs/src/ExplicitTypeSignatures.purs @@ -14,5 +14,3 @@ anInt = 0 -- This should infer a type. aNumber = 1.0 - -foreign import nestedForAll :: forall c. (forall a b. c) diff --git a/examples/failing/2445.purs b/examples/failing/2445.purs new file mode 100644 index 0000000000..10ad41a910 --- /dev/null +++ b/examples/failing/2445.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +data X a = X + +eg = \(X :: (forall a. X a)) -> X diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index a8a56df171..5536253025 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -487,15 +487,12 @@ inferBinder val (NamedBinder name binder) = do return $ M.insert name val m inferBinder val (PositionedBinder pos _ binder) = warnAndRethrowWithPositionTC pos $ inferBinder val binder --- TODO: When adding support for polymorphic types, check subsumption here, --- change the definition of `binderRequiresMonotype`, --- and use `kindOfWithScopedVars`. inferBinder val (TypedBinder ty binder) = do kind <- kindOf ty checkTypeKind ty kind - ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty + ty1 <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty unifyTypes val ty1 - inferBinder val binder + inferBinder ty1 binder inferBinder _ OpBinder{} = internalError "OpBinder should have been desugared before inferBinder" inferBinder _ BinaryNoParensBinder{} = @@ -510,6 +507,7 @@ binderRequiresMonotype NullBinder = False binderRequiresMonotype (VarBinder _) = False binderRequiresMonotype (NamedBinder _ b) = binderRequiresMonotype b binderRequiresMonotype (PositionedBinder _ _ b) = binderRequiresMonotype b +binderRequiresMonotype (TypedBinder ty b) = isMonoType ty || binderRequiresMonotype b binderRequiresMonotype _ = True -- | Instantiate polytypes only when necessitated by a binder. diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index e345ad9fbd..55aa8f2d52 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -127,6 +127,8 @@ rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r)) -- isMonoType :: Type -> Bool isMonoType ForAll{} = False +isMonoType (ParensInType t) = isMonoType t +isMonoType (KindedType t _) = isMonoType t isMonoType _ = True -- | diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 30fbcd15d8..46ce23de2b 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -336,7 +336,6 @@ testCases = [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something")) , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==)) , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==)) - , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "nestedForAll" (renderedType "forall c. (forall a b. c)") ]) , ("ConstrainedArgument", From d55d7f0c83145255de11a0f08147b15478e80c72 Mon Sep 17 00:00:00 2001 From: Hyunje Jun Date: Mon, 6 Feb 2017 03:08:36 +0900 Subject: [PATCH 0653/1580] Add stack-ghc-8.0.2.yaml (#2611) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Add @noraesae to CONTRIBUTORS.md * Add stack-ghc-8.0.2.yaml It currently uses nightly-2017-01-31. It will be updated to use LTS when a new LTS using GHC 8.0.2 is coming. * Build fix for nightly-2017-01-31 'Ambiguous occurrence ‘<|>’' occurs because the new version of aeson-better-errors exports ‘<|>’ too. Also modified other stack.yaml's to use the new aeson-better-errors. * Replace stack-ghc-8.0.yaml with one of 8.0.2 * Make Data.Aeson.BetterErrors imports explicit --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Docs/RenderedCode/Types.hs | 2 +- src/Language/PureScript/Docs/Types.hs | 4 ++++ src/Language/PureScript/Publish.hs | 2 +- src/Language/PureScript/Publish/ErrorsWarnings.hs | 2 +- stack-ghc-8.0.yaml | 12 ++++++++---- stack.yaml | 3 ++- 7 files changed, 18 insertions(+), 8 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 43377dd16c..45057f1ad7 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -90,6 +90,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@seungha-kim](https://github.com/seungha-kim) (Seungha Kim) My existing contributions and all future contributions until further notice are Copyright Seungha Kim, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@matthewleon](https://github.com/matthewleon) (Matthew Leon) My existing contributions and all future contributions until further notice are Copyright Matthew Leon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@alexbiehl](https://github.com/alexbiehl) (Alexander Biehl) My existing contributions and all future contributions until further notice are Copyright Alexander Biehl, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@noraesae](https://github.com/noraesae) (Hyunje Jun) My existing contributions and all future contributions until further notice are Copyright Hyunje Jun, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 8a63d62d2b..0d64e301b1 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -50,7 +50,7 @@ import Control.DeepSeq (NFData) import Control.Monad.Error.Class (MonadError(..)) import Data.Monoid ((<>)) -import Data.Aeson.BetterErrors +import Data.Aeson.BetterErrors (Parse, nth, withText, withValue, toAesonParser, perhaps, asText, eachInArray) import qualified Data.Aeson as A import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 7593dd2ca4..f18648b96a 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -11,6 +11,10 @@ import Control.Arrow ((***)) import Data.Aeson ((.=)) import Data.Aeson.BetterErrors + (Parse, ParseError, parse, keyOrDefault, throwCustomError, key, asText, + keyMay, withString, eachInArray, asNull, (.!), toAesonParser, toAesonParser', + fromAesonParser, perhaps, withText, asIntegral, nth, eachInObjectWithKey, + asString) import qualified Data.Map as Map import Data.Time.Clock (UTCTime) import qualified Data.Time.Format as TimeFormat diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 3c4ba45c99..2af3f12ea2 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -27,7 +27,7 @@ import Control.Category ((>>>)) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell) -import Data.Aeson.BetterErrors +import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asText) import Data.Char (isSpace) import Data.String (String, lines) import Data.List (stripPrefix, (\\), nubBy) diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index e2507d934e..c2f8225352 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -17,7 +17,7 @@ import Prelude.Compat import Control.Exception (IOException) -import Data.Aeson.BetterErrors +import Data.Aeson.BetterErrors (ParseError, displayError) import Data.List (intersperse, intercalate) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe diff --git a/stack-ghc-8.0.yaml b/stack-ghc-8.0.yaml index 5ebb5a40ca..3dc2cc64f8 100644 --- a/stack-ghc-8.0.yaml +++ b/stack-ghc-8.0.yaml @@ -1,10 +1,14 @@ -resolver: lts-7.9 +resolver: nightly-2017-01-31 packages: - '.' extra-deps: +- aeson-0.11.3.0 +- bower-json-1.0.0.1 +- http-client-0.4.31.2 +- http-client-tls-0.2.4.1 +- optparse-applicative-0.13.0.0 +- pipes-4.1.9 - pipes-http-1.0.2 +- turtle-1.3.1 - wai-websockets-3.0.0.9 - websockets-0.9.6.2 -- bower-json-1.0.0.1 -- turtle-1.3.1 -- optparse-applicative-0.13.0.0 \ No newline at end of file diff --git a/stack.yaml b/stack.yaml index b5edd07db6..44b96703a5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,7 @@ resolver: lts-6.25 packages: - '.' extra-deps: +- aeson-better-errors-0.9.1.0 - bower-json-1.0.0.1 +- optparse-applicative-0.13.0.0 - turtle-1.3.1 -- optparse-applicative-0.13.0.0 \ No newline at end of file From 344f6cc711df9c838bc4d8454fc95491b1952853 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 5 Feb 2017 11:34:38 -0800 Subject: [PATCH 0654/1580] Rebuild modules if necessary when using --dump-corefn (#2623) --- src/Language/PureScript/Make.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 71eeaccd9d..a61e6dc32f 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -326,10 +326,15 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) getOutputTimestamp mn = do + dumpCoreFn <- asks optionsDumpCoreFn let filePath = T.unpack (runModuleName mn) jsFile = outputDir filePath "index.js" externsFile = outputDir filePath "externs.json" - min <$> getTimestamp jsFile <*> getTimestamp externsFile + coreFnFile = outputDir filePath "corefn.json" + min3 js exts coreFn + | dumpCoreFn = min (min js exts) coreFn + | otherwise = min js exts + min3 <$> getTimestamp jsFile <*> getTimestamp externsFile <*> getTimestamp coreFnFile readExterns :: ModuleName -> Make (FilePath, Externs) readExterns mn = do From 24073a295b6d7eba4c37fdb2ad971e0294cae99d Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 6 Feb 2017 13:09:11 +0000 Subject: [PATCH 0655/1580] Generate data constructors without IIFEs (#2619) Fixes #2206 --- src/Language/PureScript/CodeGen/JS.hs | 67 ++++++++++++++++++--------- 1 file changed, 44 insertions(+), 23 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index a6adeca931..2631d62bda 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -138,8 +138,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- Generate code in the simplified Javascript intermediate representation for a declaration -- bindToJs :: Bind Ann -> m [JS] - bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val - bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS) + bindToJs (NonRec ann ident val) = nonRecToJS ann ident val + bindToJs (Rec vals) = concat <$> forM vals (uncurry . uncurry $ nonRecToJS) -- | -- Generate code in the simplified Javascript intermediate representation for a single non-recursive @@ -147,15 +147,22 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- -- The main purpose of this function is to handle code generation for comments. -- - nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS + nonRecToJS :: Ann -> Ident -> Expr Ann -> m [JS] nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do withoutComment <- asks optionsNoComments if withoutComment then nonRecToJS a i (modifyAnn removeComments e) - else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e) + else withHead (JSComment Nothing com) <$> nonRecToJS a i (modifyAnn removeComments e) + where + withHead _ [] = [] + withHead f (x:xs) = f x : xs nonRecToJS (ss, _, _, _) ident val = do - js <- valueToJs val - withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js) + case constructorToJs ident val of + Just jss -> + traverse (withPos ss) jss + Nothing -> do + js <- valueToJs val + return <$> (withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)) withPos :: Maybe SourceSpan -> JS -> m JS withPos (Just ss) js = do @@ -251,23 +258,37 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = JSObjectLiteral Nothing [("create", JSFunction Nothing Nothing ["value"] (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))]) - valueToJs' (Constructor _ _ (ProperName ctor) []) = - return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing []) - , JSAssignment Nothing (accessorString "value" (JSVar Nothing (properToJs ctor))) - (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ] - valueToJs' (Constructor _ _ (ProperName ctor) fields) = - let constructor = - let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] - in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body) - createFn = - let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields) - in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields - in return $ iife (properToJs ctor) [ constructor - , JSAssignment Nothing (accessorString "create" (JSVar Nothing (properToJs ctor))) createFn - ] - - iife :: Text -> [JS] -> JS - iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) [] + valueToJs' (Constructor _ _ (ProperName ctor) _) = + internalError $ "Unexpected constructor definition: " ++ T.unpack ctor + + -- | + -- Attempt to generate code in the simplified JS intermediate representation for a constructor definition. + -- If the argument is not a constructor, this returns Nothing. + -- + constructorToJs :: Ident -> Expr Ann -> Maybe [JS] + constructorToJs ident (Constructor _ _ (ProperName ctor) fs) = + Just jss + where + mkAccessor name = JSAssignment Nothing (accessorString name (JSVar Nothing (identToJs ident))) + jss = case fs of + [] -> + [ JSVariableIntroduction Nothing (identToJs ident) (Just $ + JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])) + , mkAccessor "value" $ + JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (identToJs ident)) [] + ] + fields -> + let constructor = + let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] + in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body) + createFn = + let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields) + in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields + in [ constructor + , mkAccessor "create" createFn + ] + constructorToJs _ _ = + Nothing literalToValueJS :: Literal (Expr Ann) -> m JS literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i) From a2f7eb359a585dfb1d84f7f1f8b8c85886b01d9b Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Mon, 6 Feb 2017 19:09:58 +0000 Subject: [PATCH 0656/1580] Return operators in psc-ide imports list (#2617) * Return operators in psc-ide imports list * Return type-level operators in psc-ide imports list --- src/Language/PureScript/Ide/Types.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index c21b775b32..f8e75de982 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -229,6 +229,8 @@ identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name identifierFromDeclarationRef (P.KindRef name) = P.runProperName name +identifierFromDeclarationRef (P.ValueOpRef op) = P.showOp op +identifierFromDeclarationRef (P.TypeOpRef op) = P.showOp op identifierFromDeclarationRef _ = "" data Success = From 4599160fcbe48099cb4f751e7033f92624151288 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 6 Feb 2017 19:14:59 -0800 Subject: [PATCH 0657/1580] 0.10.6 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 80c03c3eed..45b2f80485 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.10.5 +version: 0.10.6 cabal-version: >=1.8 build-type: Simple license: BSD3 From 74ca00de3afc613c28473d06eca5e8c7a2f5842d Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 8 Feb 2017 09:49:49 -0800 Subject: [PATCH 0658/1580] Remove psc-package, combine remaining executables (#2632) * Remove psc-package * Single consolidated executable (#2633) * Single consolidated executable #2336 * PSCi * bundle * docs * hierarchy * publish * ide * Remove some old options, fix #2618 * Fix warning * fix test failure and cabal warning (#2634) * fix test failure and cabal warning * add missing files to cabal file * Various * Fix tests again --- psc-bundle/Main.hs => app/Command/Bundle.hs | 98 ++-- psc/Main.hs => app/Command/Compile.hs | 141 +++--- psc-docs/Main.hs => app/Command/Docs.hs | 107 ++--- {psc-docs => app/Command/Docs}/Ctags.hs | 6 +- {psc-docs => app/Command/Docs}/Etags.hs | 4 +- {psc-docs => app/Command/Docs}/Tags.hs | 4 +- hierarchy/Main.hs => app/Command/Hierarchy.hs | 46 +- psc-ide-server/Main.hs => app/Command/Ide.hs | 114 +++-- app/Command/Publish.hs | 40 ++ psci/Main.hs => app/Command/REPL.hs | 46 +- app/Main.hs | 64 +++ {psci => app}/static/index.html | 0 {psci => app}/static/index.js | 0 bundle/README | 7 +- bundle/build.sh | 17 +- psc-ide-client/Main.hs | 50 --- {psc-ide-server => psc-ide}/PROTOCOL.md | 0 {psc-ide-server => psc-ide}/README.md | 0 psc-package/Main.hs | 423 ------------------ psc-package/README.md | 99 ---- psc-publish/Main.hs | 57 --- purescript.cabal | 185 ++------ scripts/psc | 2 + scripts/psc-bundle | 2 + scripts/psc-docs | 2 + scripts/psc-hierarchy | 2 + scripts/psc-ide-server | 2 + scripts/psc-publish | 2 + scripts/psci | 2 + .../PureScript/CodeGen/JS/Optimizer.hs | 21 +- .../CodeGen/JS/Optimizer/MagicDo.hs | 21 +- .../PureScript/CodeGen/JS/Optimizer/TCO.hs | 19 +- src/Language/PureScript/Options.hs | 40 +- stack-ghc-8.0.yaml | 1 - stack.yaml | 1 - tests/Language/PureScript/Ide/Test.hs | 2 +- 36 files changed, 408 insertions(+), 1219 deletions(-) rename psc-bundle/Main.hs => app/Command/Bundle.hs (61%) rename psc/Main.hs => app/Command/Compile.hs (60%) rename psc-docs/Main.hs => app/Command/Docs.hs (72%) rename {psc-docs => app/Command/Docs}/Ctags.hs (75%) rename {psc-docs => app/Command/Docs}/Etags.hs (84%) rename {psc-docs => app/Command/Docs}/Tags.hs (93%) rename hierarchy/Main.hs => app/Command/Hierarchy.hs (74%) rename psc-ide-server/Main.hs => app/Command/Ide.hs (63%) create mode 100644 app/Command/Publish.hs rename psci/Main.hs => app/Command/REPL.hs (94%) create mode 100644 app/Main.hs rename {psci => app}/static/index.html (100%) rename {psci => app}/static/index.js (100%) delete mode 100644 psc-ide-client/Main.hs rename {psc-ide-server => psc-ide}/PROTOCOL.md (100%) rename {psc-ide-server => psc-ide}/README.md (100%) delete mode 100644 psc-package/Main.hs delete mode 100644 psc-package/README.md delete mode 100644 psc-publish/Main.hs create mode 100755 scripts/psc create mode 100755 scripts/psc-bundle create mode 100755 scripts/psc-docs create mode 100755 scripts/psc-hierarchy create mode 100755 scripts/psc-ide-server create mode 100755 scripts/psc-publish create mode 100755 scripts/psci diff --git a/psc-bundle/Main.hs b/app/Command/Bundle.hs similarity index 61% rename from psc-bundle/Main.hs rename to app/Command/Bundle.hs index 2bd942835d..3e0e8e9544 100644 --- a/psc-bundle/Main.hs +++ b/app/Command/Bundle.hs @@ -4,39 +4,30 @@ {-# LANGUAGE RecordWildCards #-} -- | Bundles compiled PureScript modules for the browser. -module Main (main) where - -import Data.Traversable (for) -import Data.Version (showVersion) -import Data.Monoid ((<>)) -import Data.Aeson (encode) -import Data.Maybe (isNothing) - -import Control.Applicative -import Control.Monad -import Control.Monad.Error.Class -import Control.Monad.Trans.Except -import Control.Monad.IO.Class - -import System.FilePath (takeDirectory, (), (<.>), takeFileName) -import System.FilePath.Glob (glob) -import System.Exit (exitFailure) -import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8) -import System.IO.UTF8 (readUTF8File, writeUTF8File) -import System.Directory (createDirectoryIfMissing, getCurrentDirectory) - +module Command.Bundle (command) where + +import Data.Traversable (for) +import Data.Monoid ((<>)) +import Data.Aeson (encode) +import Data.Maybe (isNothing) +import Control.Applicative +import Control.Monad +import Control.Monad.Error.Class +import Control.Monad.Trans.Except +import Control.Monad.IO.Class +import System.FilePath (takeDirectory, (), (<.>), takeFileName) +import System.FilePath.Glob (glob) +import System.Exit (exitFailure) +import System.IO (stderr, hPutStrLn) +import System.IO.UTF8 (readUTF8File, writeUTF8File) +import System.Directory (createDirectoryIfMissing, getCurrentDirectory) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.UTF8 as BU8 - -import Language.PureScript.Bundle - -import Options.Applicative (Parser, ParseError (..)) +import Language.PureScript.Bundle +import Options.Applicative (Parser) import qualified Options.Applicative as Opts - -import qualified Paths_purescript as Paths - -import SourceMap -import SourceMap.Types +import SourceMap +import SourceMap.Types -- | Command line options. data Options = Options @@ -117,31 +108,22 @@ options = Options <$> some inputFile <> Opts.help "Whether to generate source maps for the bundle (requires --output)." -- | Make it go. -main :: IO () -main = do - hSetEncoding stdout utf8 - hSetEncoding stderr utf8 - opts <- Opts.execParser (Opts.info (version <*> Opts.helper <*> options) infoModList) - output <- runExceptT (app opts) - case output of - Left err -> do - hPutStrLn stderr (unlines (printErrorMessage err)) - exitFailure - Right (sourcemap, js) -> - case optionsOutputFile opts of - Just outputFile -> do - createDirectoryIfMissing True (takeDirectory outputFile) - case sourcemap of - Just sm -> do - writeUTF8File outputFile $ js ++ "\n//# sourceMappingURL=" ++ (takeFileName outputFile <.> "map") ++ "\n" - writeUTF8File (outputFile <.> "map") $ BU8.toString . B.toStrict . encode $ generate sm - Nothing -> writeUTF8File outputFile js - Nothing -> putStrLn js - where - infoModList = Opts.fullDesc <> headerInfo <> footerInfo - headerInfo = Opts.header "psc-bundle - Bundles compiled PureScript modules for the browser" - footerInfo = Opts.footer $ "psc-bundle " ++ showVersion Paths.version - - version :: Parser (a -> a) - version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $ - Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden +command :: Opts.Parser (IO ()) +command = run <$> (Opts.helper <*> options) where + run :: Options -> IO () + run opts = do + output <- runExceptT (app opts) + case output of + Left err -> do + hPutStrLn stderr (unlines (printErrorMessage err)) + exitFailure + Right (sourcemap, js) -> + case optionsOutputFile opts of + Just outputFile -> do + createDirectoryIfMissing True (takeDirectory outputFile) + case sourcemap of + Just sm -> do + writeUTF8File outputFile $ js ++ "\n//# sourceMappingURL=" ++ (takeFileName outputFile <.> "map") ++ "\n" + writeUTF8File (outputFile <.> "map") $ BU8.toString . B.toStrict . encode $ generate sm + Nothing -> writeUTF8File outputFile js + Nothing -> putStrLn js diff --git a/psc/Main.hs b/app/Command/Compile.hs similarity index 60% rename from psc/Main.hs rename to app/Command/Compile.hs index be42b3f8fe..2f72e0df22 100644 --- a/psc/Main.hs +++ b/app/Command/Compile.hs @@ -4,32 +4,25 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -module Main where +module Command.Compile (command) where import Control.Applicative import Control.Monad import Control.Monad.Writer.Strict - import qualified Data.Aeson as A import Data.Bool (bool) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.UTF8 as BU8 import qualified Data.Map as M import Data.Text (Text) -import Data.Version (showVersion) - import qualified Language.PureScript as P import Language.PureScript.Errors.JSON import Language.PureScript.Make - -import Options.Applicative as Opts - -import qualified Paths_purescript as Paths - +import qualified Options.Applicative as Opts import qualified System.Console.ANSI as ANSI import System.Exit (exitSuccess, exitFailure) import System.FilePath.Glob (glob) -import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8) +import System.IO (hPutStrLn, stderr) import System.IO.UTF8 (readUTF8FileT) data PSCMakeOptions = PSCMakeOptions @@ -89,94 +82,64 @@ globWarningOnMisses warn = concatMapM globWithWarning readInput :: [FilePath] -> IO [(FilePath, Text)] readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8FileT inFile -inputFile :: Parser FilePath -inputFile = strArgument $ - metavar "FILE" - <> help "The input .purs file(s)" +inputFile :: Opts.Parser FilePath +inputFile = Opts.strArgument $ + Opts.metavar "FILE" + <> Opts.help "The input .purs file(s)" -outputDirectory :: Parser FilePath -outputDirectory = strOption $ - short 'o' - <> long "output" +outputDirectory :: Opts.Parser FilePath +outputDirectory = Opts.strOption $ + Opts.short 'o' + <> Opts.long "output" <> Opts.value "output" - <> showDefault - <> help "The output directory" - -noTco :: Parser Bool -noTco = switch $ - long "no-tco" - <> help "Disable tail call optimizations" - -noMagicDo :: Parser Bool -noMagicDo = switch $ - long "no-magic-do" - <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad" - -noOpts :: Parser Bool -noOpts = switch $ - long "no-opts" - <> help "Skip the optimization phase" - -comments :: Parser Bool -comments = switch $ - short 'c' - <> long "comments" - <> help "Include comments in the generated code" - -verboseErrors :: Parser Bool -verboseErrors = switch $ - short 'v' - <> long "verbose-errors" - <> help "Display verbose error messages" - -noPrefix :: Parser Bool -noPrefix = switch $ - short 'p' - <> long "no-prefix" - <> help "Do not include comment header" - -jsonErrors :: Parser Bool -jsonErrors = switch $ - long "json-errors" - <> help "Print errors to stderr as JSON" -sourceMaps :: Parser Bool -sourceMaps = switch $ - long "source-maps" - <> help "Generate source maps" - -dumpCoreFn :: Parser Bool -dumpCoreFn = switch $ - long "dump-corefn" - <> help "Dump the (functional) core representation of the compiled code at output/*/corefn.json" - - -options :: Parser P.Options -options = P.Options <$> noTco - <*> noMagicDo - <*> pure Nothing - <*> noOpts - <*> verboseErrors + <> Opts.showDefault + <> Opts.help "The output directory" + +comments :: Opts.Parser Bool +comments = Opts.switch $ + Opts.short 'c' + <> Opts.long "comments" + <> Opts.help "Include comments in the generated code" + +verboseErrors :: Opts.Parser Bool +verboseErrors = Opts.switch $ + Opts.short 'v' + <> Opts.long "verbose-errors" + <> Opts.help "Display verbose error messages" + +noPrefix :: Opts.Parser Bool +noPrefix = Opts.switch $ + Opts.short 'p' + <> Opts.long "no-prefix" + <> Opts.help "Do not include comment header" + +jsonErrors :: Opts.Parser Bool +jsonErrors = Opts.switch $ + Opts.long "json-errors" + <> Opts.help "Print errors to stderr as JSON" + +sourceMaps :: Opts.Parser Bool +sourceMaps = Opts.switch $ + Opts.long "source-maps" + <> Opts.help "Generate source maps" + +dumpCoreFn :: Opts.Parser Bool +dumpCoreFn = Opts.switch $ + Opts.long "dump-corefn" + <> Opts.help "Dump the (functional) core representation of the compiled code at output/*/corefn.json" + +options :: Opts.Parser P.Options +options = P.Options <$> verboseErrors <*> (not <$> comments) <*> sourceMaps <*> dumpCoreFn -pscMakeOptions :: Parser PSCMakeOptions +pscMakeOptions :: Opts.Parser PSCMakeOptions pscMakeOptions = PSCMakeOptions <$> many inputFile <*> outputDirectory <*> options <*> (not <$> noPrefix) <*> jsonErrors -main :: IO () -main = do - hSetEncoding stdout utf8 - hSetEncoding stderr utf8 - execParser opts >>= compile - where - opts = info (version <*> helper <*> pscMakeOptions) infoModList - infoModList = fullDesc <> headerInfo <> footerInfo - headerInfo = header "psc - Compiles PureScript to Javascript" - footerInfo = footer $ "psc " ++ showVersion Paths.version - - version :: Parser (a -> a) - version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden +command :: Opts.Parser (IO ()) +command = compile <$> (Opts.helper <*> pscMakeOptions) diff --git a/psc-docs/Main.hs b/app/Command/Docs.hs similarity index 72% rename from psc-docs/Main.hs rename to app/Command/Docs.hs index e6ffe6dd7c..d0890286bb 100644 --- a/psc-docs/Main.hs +++ b/app/Command/Docs.hs @@ -1,37 +1,32 @@ {-# LANGUAGE TupleSections #-} -module Main where - -import Control.Applicative -import Control.Monad.Trans.Except (runExceptT) -import Control.Arrow (first, second) -import Control.Category ((>>>)) -import Control.Monad.Writer -import Data.Text (Text) +module Command.Docs (command, infoModList) where + +import Command.Docs.Etags +import Command.Docs.Ctags +import Control.Applicative +import Control.Arrow (first, second) +import Control.Category ((>>>)) +import Control.Monad.Writer +import Control.Monad.Trans.Except (runExceptT) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T -import Data.Function (on) -import Data.List -import Data.Maybe (fromMaybe) -import Data.Tuple (swap) -import Data.Version (showVersion) - -import Options.Applicative -import qualified Text.PrettyPrint.ANSI.Leijen as PP - +import Data.Function (on) +import Data.List +import Data.Maybe (fromMaybe) +import Data.Tuple (swap) import qualified Language.PureScript as P -import qualified Paths_purescript as Paths -import System.Exit (exitFailure) -import System.IO (hPutStrLn, hPrint, hSetEncoding, stderr, stdout, utf8) -import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT) -import System.Directory (createDirectoryIfMissing) -import System.FilePath (takeDirectory) -import System.FilePath.Glob (glob) - -import Etags -import Ctags import qualified Language.PureScript.Docs as D import qualified Language.PureScript.Docs.AsMarkdown as D +import qualified Options.Applicative as Opts +import qualified Text.PrettyPrint.ANSI.Leijen as PP +import System.Directory (createDirectoryIfMissing) +import System.Exit (exitFailure) +import System.FilePath (takeDirectory) +import System.FilePath.Glob (glob) +import System.IO (hPutStrLn, hPrint, stderr) +import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT) -- Available output formats data Format = Markdown -- Output documentation in Markdown format @@ -47,9 +42,9 @@ data DocgenOutput deriving (Show) data PSCDocsOptions = PSCDocsOptions - { pscdFormat :: Format - , pscdInputFiles :: [FilePath] - , pscdDocgen :: DocgenOutput + { _pscdFormat :: Format + , _pscdInputFiles :: [FilePath] + , _pscdDocgen :: DocgenOutput } deriving (Show) @@ -145,10 +140,10 @@ dumpTags input renderTags = do parseFile :: FilePath -> IO (FilePath, Text) parseFile input = (,) input <$> readUTF8FileT input -inputFile :: Parser FilePath -inputFile = strArgument $ - metavar "FILE" - <> help "The input .purs file(s)" +inputFile :: Opts.Parser FilePath +inputFile = Opts.strArgument $ + Opts.metavar "FILE" + <> Opts.help "The input .purs file(s)" instance Read Format where readsPrec _ "etags" = [(Etags, "")] @@ -156,18 +151,18 @@ instance Read Format where readsPrec _ "markdown" = [(Markdown, "")] readsPrec _ _ = [] -format :: Parser Format -format = option auto $ value Markdown - <> long "format" - <> metavar "FORMAT" - <> help "Set output FORMAT (markdown | etags | ctags)" +format :: Opts.Parser Format +format = Opts.option Opts.auto $ Opts.value Markdown + <> Opts.long "format" + <> Opts.metavar "FORMAT" + <> Opts.help "Set output FORMAT (markdown | etags | ctags)" -docgenModule :: Parser String -docgenModule = strOption $ - long "docgen" - <> help "A list of module names which should appear in the output. This can optionally include file paths to write individual modules to, by separating with a colon ':'. For example, Prelude:docs/Prelude.md. This option may be specified multiple times." +docgenModule :: Opts.Parser String +docgenModule = Opts.strOption $ + Opts.long "docgen" + <> Opts.help "A list of module names which should appear in the output. This can optionally include file paths to write individual modules to, by separating with a colon ':'. For example, Prelude:docs/Prelude.md. This option may be specified multiple times." -pscDocsOptions :: Parser (Format, [FilePath], [String]) +pscDocsOptions :: Opts.Parser (Format, [FilePath], [String]) pscDocsOptions = (,,) <$> format <*> many inputFile <*> many docgenModule parseDocgen :: [String] -> Either String DocgenOutput @@ -218,36 +213,28 @@ buildOptions (fmt, input, mapping) = hPutStrLn stderr (" " ++ err) exitFailure -main :: IO () -main = do - hSetEncoding stdout utf8 - hSetEncoding stderr utf8 - execParser opts >>= buildOptions >>= docgen - where - opts = info (version <*> helper <*> pscDocsOptions) infoModList - infoModList = fullDesc <> headerInfo <> footerInfo - headerInfo = header "psc-docs - Generate Markdown documentation from PureScript source files" - footerInfo = footerDoc $ Just $ PP.vcat - [ examples, PP.empty, PP.text ("psc-docs " ++ showVersion Paths.version) ] +command :: Opts.Parser (IO ()) +command = (buildOptions >=> docgen) <$> (Opts.helper <*> pscDocsOptions) - version :: Parser (a -> a) - version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden +infoModList :: Opts.InfoMod a +infoModList = Opts.fullDesc <> footerInfo where + footerInfo = Opts.footerDoc $ Just examples examples :: PP.Doc examples = PP.vcat $ map PP.text [ "Examples:" , " print documentation for Data.List to stdout:" - , " psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\" + , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\" , " --docgen Data.List" , "" , " write documentation for Data.List to docs/Data.List.md:" - , " psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\" + , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\" , " --docgen Data.List:docs/Data.List.md" , "" , " write documentation for Data.List to docs/Data.List.md, and" , " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:" - , " psc-docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\" + , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\" , " --docgen Data.List:docs/Data.List.md \\" , " --docgen Data.List.Lazy:docs/Data.List.Lazy.md" ] diff --git a/psc-docs/Ctags.hs b/app/Command/Docs/Ctags.hs similarity index 75% rename from psc-docs/Ctags.hs rename to app/Command/Docs/Ctags.hs index d5018eaeb3..9cfd71442f 100644 --- a/psc-docs/Ctags.hs +++ b/app/Command/Docs/Ctags.hs @@ -1,8 +1,8 @@ -module Ctags (dumpCtags) where +module Command.Docs.Ctags (dumpCtags) where +import Command.Docs.Tags +import Data.List (sort) import qualified Language.PureScript as P -import Tags -import Data.List (sort) dumpCtags :: [(String, P.Module)] -> [String] dumpCtags = sort . concatMap renderModCtags diff --git a/psc-docs/Etags.hs b/app/Command/Docs/Etags.hs similarity index 84% rename from psc-docs/Etags.hs rename to app/Command/Docs/Etags.hs index 5aec45dd1a..c6e431916e 100644 --- a/psc-docs/Etags.hs +++ b/app/Command/Docs/Etags.hs @@ -1,7 +1,7 @@ -module Etags (dumpEtags) where +module Command.Docs.Etags (dumpEtags) where +import Command.Docs.Tags import qualified Language.PureScript as P -import Tags dumpEtags :: [(String, P.Module)] -> [String] dumpEtags = concatMap renderModEtags diff --git a/psc-docs/Tags.hs b/app/Command/Docs/Tags.hs similarity index 93% rename from psc-docs/Tags.hs rename to app/Command/Docs/Tags.hs index 5bee382868..6f15169852 100644 --- a/psc-docs/Tags.hs +++ b/app/Command/Docs/Tags.hs @@ -1,6 +1,6 @@ -module Tags where +module Command.Docs.Tags where -import Control.Arrow (first) +import Control.Arrow (first) import qualified Data.Text as T import qualified Language.PureScript as P diff --git a/hierarchy/Main.hs b/app/Command/Hierarchy.hs similarity index 74% rename from hierarchy/Main.hs rename to app/Command/Hierarchy.hs index 87008708dc..bf8a3e919e 100644 --- a/hierarchy/Main.hs +++ b/app/Command/Hierarchy.hs @@ -16,35 +16,30 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE DataKinds #-} -module Main where +module Command.Hierarchy (command) where -import Control.Applicative (optional) -import Control.Monad (unless) - -import Data.List (intercalate,nub,sort) -import Data.Foldable (for_) -import Data.Version (showVersion) -import Data.Monoid ((<>)) +import Control.Applicative (optional) +import Control.Monad (unless) +import Data.List (intercalate,nub,sort) +import Data.Foldable (for_) +import Data.Monoid ((<>)) import qualified Data.Text as T - -import Options.Applicative (Parser) +import Options.Applicative (Parser) import qualified Options.Applicative as Opts -import System.Directory (createDirectoryIfMissing) -import System.FilePath (()) -import System.FilePath.Glob (glob) -import System.Exit (exitFailure, exitSuccess) -import System.IO (hPutStr, stderr) -import System.IO.UTF8 (readUTF8FileT) - +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.FilePath.Glob (glob) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStr, stderr) +import System.IO.UTF8 (readUTF8FileT) import qualified Language.PureScript as P -import qualified Paths_purescript as Paths data HierarchyOptions = HierarchyOptions - { hierachyInput :: FilePath - , hierarchyOutput :: Maybe FilePath + { _hierachyInput :: FilePath + , _hierarchyOutput :: Maybe FilePath } -newtype SuperMap = SuperMap { unSuperMap :: Either (P.ProperName 'P.ClassName) (P.ProperName 'P.ClassName, P.ProperName 'P.ClassName) } +newtype SuperMap = SuperMap { _unSuperMap :: Either (P.ProperName 'P.ClassName) (P.ProperName 'P.ClassName, P.ProperName 'P.ClassName) } deriving Eq instance Show SuperMap where @@ -110,10 +105,5 @@ pscOptions :: Parser HierarchyOptions pscOptions = HierarchyOptions <$> inputFile <*> outputFile -main :: IO () -main = Opts.execParser opts >>= compile - where - opts = Opts.info (Opts.helper <*> pscOptions) infoModList - infoModList = Opts.fullDesc <> headerInfo <> footerInfo - headerInfo = Opts.header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses" - footerInfo = Opts.footer $ "hierarchy " ++ showVersion Paths.version +command :: Opts.Parser (IO ()) +command = compile <$> (Opts.helper <*> pscOptions) diff --git a/psc-ide-server/Main.hs b/app/Command/Ide.hs similarity index 63% rename from psc-ide-server/Main.hs rename to app/Command/Ide.hs index 8b214c88e4..b9a0f518ee 100644 --- a/psc-ide-server/Main.hs +++ b/app/Command/Ide.hs @@ -19,7 +19,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} -module Main where +module Command.Ide (command) where import Protolude @@ -28,7 +28,6 @@ import Control.Concurrent.STM import "monad-logger" Control.Monad.Logger import qualified Data.Text.IO as T import qualified Data.ByteString.Lazy.Char8 as BS8 -import Data.Version (showVersion) import GHC.IO.Exception (IOErrorType(..), IOException(..)) import Language.PureScript.Ide import Language.PureScript.Ide.Command @@ -40,14 +39,12 @@ import Network hiding (socketPort, accept) import Network.BSD (getProtocolNumber) import Network.Socket hiding (PortNumber, Type, sClose) -import Options.Applicative (ParseError (..)) import qualified Options.Applicative as Opts import System.Directory import System.Info as SysInfo import System.FilePath import System.IO hiding (putStrLn, print) import System.IO.Error (isEOFError) -import qualified Paths_purescript as Paths listenOnLocalhost :: PortNumber -> IO Socket listenOnLocalhost port = do @@ -63,66 +60,65 @@ listenOnLocalhost port = do pure sock) data Options = Options - { optionsDirectory :: Maybe FilePath - , optionsGlobs :: [FilePath] - , optionsOutputPath :: FilePath - , optionsPort :: PortNumber - , optionsNoWatch :: Bool - , optionsPolling :: Bool - , optionsDebug :: Bool - , optionsLoglevel :: IdeLogLevel + { _optionsDirectory :: Maybe FilePath + , _optionsGlobs :: [FilePath] + , _optionsOutputPath :: FilePath + , _optionsPort :: PortNumber + , _optionsNoWatch :: Bool + , _optionsPolling :: Bool + , _optionsDebug :: Bool + , _optionsLoglevel :: IdeLogLevel } deriving (Show) -main :: IO () -main = do - opts'@(Options dir globs outputPath port noWatch polling debug logLevel) <- Opts.execParser opts - when debug (putText "Parsed Options:" *> print opts') - maybe (pure ()) setCurrentDirectory dir - ideState <- newTVarIO emptyIdeState - cwd <- getCurrentDirectory - let fullOutputPath = cwd outputPath +command :: Opts.Parser (IO ()) +command = run <$> (Opts.helper <*> parser) where + run :: Options -> IO () + run opts'@(Options dir globs outputPath port noWatch polling debug logLevel) = do + when debug (putText "Parsed Options:" *> print opts') + maybe (pure ()) setCurrentDirectory dir + ideState <- newTVarIO emptyIdeState + cwd <- getCurrentDirectory + let fullOutputPath = cwd outputPath - unlessM (doesDirectoryExist fullOutputPath) $ do - putStrLn ("Your output directory didn't exist. I'll create it at: " <> fullOutputPath) - createDirectory fullOutputPath - putText "This usually means you didn't compile your project yet." - putText "psc-ide needs you to compile your project (for example by running pulp build)" + unlessM (doesDirectoryExist fullOutputPath) $ do + putStrLn ("Your output directory didn't exist. I'll create it at: " <> fullOutputPath) + createDirectory fullOutputPath + putText "This usually means you didn't compile your project yet." + putText "psc-ide needs you to compile your project (for example by running pulp build)" - unless noWatch $ - void (forkFinally (watcher polling ideState fullOutputPath) print) - -- TODO: deprecate and get rid of `debug` - let conf = Configuration {confLogLevel = if debug then LogDebug else logLevel, confOutputPath = outputPath, confGlobs = globs} - env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf} - startServer port env - where - parser = - Options - <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd')) - <*> many (Opts.argument Opts.str (Opts.metavar "Source GLOBS...")) - <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/") - <*> (fromIntegral <$> - Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer))) - <*> Opts.switch (Opts.long "no-watch") - <*> flipIfWindows (Opts.switch (Opts.long "polling")) - <*> Opts.switch (Opts.long "debug") - <*> (parseLogLevel <$> Opts.strOption - (Opts.long "log-level" - `mappend` Opts.value "" - `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\"")) - opts = Opts.info (version <*> Opts.helper <*> parser) mempty - parseLogLevel s = case s of - "debug" -> LogDebug - "perf" -> LogPerf - "all" -> LogAll - "none" -> LogNone - _ -> LogDefault - version = Opts.abortOption - (InfoMsg (showVersion Paths.version)) - (Opts.long "version" `mappend` Opts.help "Show the version number") + unless noWatch $ + void (forkFinally (watcher polling ideState fullOutputPath) print) + -- TODO: deprecate and get rid of `debug` + let conf = Configuration {confLogLevel = if debug then LogDebug else logLevel, confOutputPath = outputPath, confGlobs = globs} + env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf} + startServer port env + + parser :: Opts.Parser Options + parser = + Options + <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd')) + <*> many (Opts.argument Opts.str (Opts.metavar "Source GLOBS...")) + <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/") + <*> (fromIntegral <$> + Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer))) + <*> Opts.switch (Opts.long "no-watch") + <*> flipIfWindows (Opts.switch (Opts.long "polling")) + <*> Opts.switch (Opts.long "debug") + <*> (parseLogLevel <$> Opts.strOption + (Opts.long "log-level" + `mappend` Opts.value "" + `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\"")) + + parseLogLevel s = case s of + "debug" -> LogDebug + "perf" -> LogPerf + "all" -> LogAll + "none" -> LogNone + _ -> LogDefault - -- polling is the default on Windows and the flag turns it off. See - -- #2209 and #2414 for explanations - flipIfWindows = map (if SysInfo.os == "mingw32" then not else identity) + -- polling is the default on Windows and the flag turns it off. See + -- #2209 and #2414 for explanations + flipIfWindows = map (if SysInfo.os == "mingw32" then not else identity) startServer :: PortNumber -> IdeEnvironment -> IO () startServer port env = withSocketsDo $ do diff --git a/app/Command/Publish.hs b/app/Command/Publish.hs new file mode 100644 index 0000000000..9da0c09914 --- /dev/null +++ b/app/Command/Publish.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Command.Publish (command) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Monoid ((<>)) +import Data.Time.Clock (getCurrentTime) +import Data.Version (Version(..)) +import Language.PureScript.Publish +import Language.PureScript.Publish.ErrorsWarnings +import Options.Applicative (Parser) +import qualified Options.Applicative as Opts + +dryRun :: Parser Bool +dryRun = Opts.switch $ + Opts.long "dry-run" + <> Opts.help "Produce no output, and don't require a tagged version to be checked out." + +dryRunOptions :: PublishOptions +dryRunOptions = defaultPublishOptions + { publishGetVersion = return dummyVersion + , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn + , publishGetTagTime = const (liftIO getCurrentTime) + } + where dummyVersion = ("0.0.0", Version [0,0,0] []) + +command :: Opts.Parser (IO ()) +command = publish <$> (Opts.helper <*> dryRun) + +publish :: Bool -> IO () +publish isDryRun = + if isDryRun + then do + _ <- unsafePreparePackage dryRunOptions + putStrLn "Dry run completed, no errors." + else do + pkg <- unsafePreparePackage defaultPublishOptions + BL.putStrLn (A.encode pkg) diff --git a/psci/Main.hs b/app/Command/REPL.hs similarity index 94% rename from psci/Main.hs rename to app/Command/REPL.hs index 1a8bec898a..00d9553c15 100644 --- a/psci/Main.hs +++ b/app/Command/REPL.hs @@ -10,18 +10,10 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} -module Main (main) where +module Command.REPL (command) where import Prelude () import Prelude.Compat - -import Data.FileEmbed (embedStringFile) -import Data.Monoid ((<>)) -import Data.String (IsString(..)) -import Data.Text (Text, unpack) -import Data.Traversable (for) -import Data.Version (showVersion) - import Control.Applicative (many, (<|>)) import Control.Concurrent (forkIO) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, @@ -37,11 +29,14 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.State.Strict (StateT, evalStateT) import Control.Monad.Trans.Reader (ReaderT, runReaderT) - +import Data.FileEmbed (embedStringFile) +import Data.Monoid ((<>)) +import Data.String (IsString(..)) +import Data.Text (Text, unpack) +import Data.Traversable (for) import qualified Language.PureScript as P import qualified Language.PureScript.Bundle as Bundle import Language.PureScript.Interactive - import Network.HTTP.Types.Header (hContentType, hCacheControl, hPragma, hExpires) import Network.HTTP.Types.Status (status200, status404, status503) @@ -49,11 +44,7 @@ import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WebSockets as WS import qualified Network.WebSockets as WS - import qualified Options.Applicative as Opts - -import qualified Paths_purescript as Paths - import System.Console.Haskeline import System.IO.UTF8 (readUTF8File) import System.Exit @@ -102,20 +93,6 @@ psciOptions :: Opts.Parser PSCiOptions psciOptions = PSCiOptions <$> many inputFile <*> backend -version :: Opts.Parser (a -> a) -version = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $ - Opts.long "version" <> - Opts.help "Show the version number" <> - Opts.hidden - -getOpt :: IO PSCiOptions -getOpt = Opts.execParser opts - where - opts = Opts.info (version <*> Opts.helper <*> psciOptions) infoModList - infoModList = Opts.fullDesc <> headerInfo <> footerInfo - headerInfo = Opts.header "psci - Interactive mode for PureScript" - footerInfo = Opts.footer $ "psci " ++ showVersion Paths.version - -- | Parses the input and returns either a command, or an error as a 'String'. getCommand :: forall m. MonadException m => InputT m (Either String (Maybe Command)) getCommand = handleInterrupt (return (Right Nothing)) $ do @@ -143,10 +120,10 @@ bundle = runExceptT $ do Bundle.bundle input [] Nothing "PSCI" indexJS :: IsString string => string -indexJS = $(embedStringFile "psci/static/index.js") +indexJS = $(embedStringFile "app/static/index.js") indexPage :: IsString string => string -indexPage = $(embedStringFile "psci/static/index.html") +indexPage = $(embedStringFile "app/static/index.html") -- | All of the functions required to implement a PSCi backend data Backend = forall state. Backend @@ -321,9 +298,12 @@ nodeBackend nodePath nodeArgs = Backend setup eval reload shutdown shutdown :: () -> IO () shutdown _ = return () +options :: Opts.Parser PSCiOptions +options = Opts.helper <*> psciOptions + -- | Get command line options and drop into the REPL -main :: IO () -main = getOpt >>= loop +command :: Opts.Parser (IO ()) +command = loop <$> options where loop :: PSCiOptions -> IO () loop PSCiOptions{..} = do diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000000..32363b882a --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Main where + +import qualified Command.Bundle as Bundle +import qualified Command.Compile as Compile +import qualified Command.Docs as Docs +import qualified Command.Hierarchy as Hierarchy +import qualified Command.Ide as Ide +import qualified Command.Publish as Publish +import qualified Command.REPL as REPL +import Data.Foldable (fold) +import Data.Monoid ((<>)) +import Data.Version (showVersion) +import qualified Options.Applicative as Opts +import qualified Paths_purescript as Paths +import qualified System.IO as IO + +main :: IO () +main = do + IO.hSetEncoding IO.stdout IO.utf8 + IO.hSetEncoding IO.stderr IO.utf8 + cmd <- Opts.execParser opts + cmd + where + opts = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList + infoModList = Opts.fullDesc <> headerInfo <> footerInfo + headerInfo = Opts.progDesc "The PureScript compiler and tools" + footerInfo = Opts.footer $ "psc " ++ showVersion Paths.version + + versionInfo :: Opts.Parser (a -> a) + versionInfo = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $ + Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden + + commands :: Opts.Parser (IO ()) + commands = + (Opts.subparser . fold) + [ Opts.command "bundle" + (Opts.info Bundle.command + (Opts.progDesc "Bundle compiled PureScript modules for the browser")) + , Opts.command "compile" + (Opts.info Compile.command + (Opts.progDesc "Compile PureScript source files")) + , Opts.command "docs" + (Opts.info Docs.command + (Opts.progDesc "Generate Markdown documentation from PureScript source files" <> Docs.infoModList)) + , Opts.command "hierarchy" + (Opts.info Hierarchy.command + (Opts.progDesc "Generate a GraphViz directed graph of PureScript type classes")) + , Opts.command "ide" + (Opts.info Ide.command + (Opts.progDesc "Start an IDE server process")) + , Opts.command "publish" + (Opts.info Publish.command + (Opts.progDesc "Generates documentation packages for upload to Pursuit")) + , Opts.command "repl" + (Opts.info REPL.command + (Opts.progDesc "Enter the interactive mode (PSCi)")) + ] diff --git a/psci/static/index.html b/app/static/index.html similarity index 100% rename from psci/static/index.html rename to app/static/index.html diff --git a/psci/static/index.js b/app/static/index.js similarity index 100% rename from psci/static/index.js rename to app/static/index.js diff --git a/bundle/README b/bundle/README index b5b63b475b..481563c4b6 100644 --- a/bundle/README +++ b/bundle/README @@ -8,7 +8,7 @@ Installation Instructions ------------------------- -This bundle contains the following executables: +This bundle contains the combined purs executable, and the following scripts: - psc The PureScript compiler - psci The PureScript interactive REPL (requires NodeJS) @@ -16,10 +16,7 @@ This bundle contains the following executables: - psc-bundle Bundles together CommonJS modules produced by `psc` into a single JavaScript file; useful for running in the browser. - psc-publish Generates documentation packages for uploading to Pursuit -- psc-ide-server Provides Editor Support in the form of type information and +- psc-ide-server Provides editor support in the form of type information and autocompletion -- psc-ide-client Utility to query psc-ide-server -- psc-package Package manager for PureScript packages Copy these files anywhere on your PATH. - diff --git a/bundle/build.sh b/bundle/build.sh index 5d99d8c388..029756b093 100755 --- a/bundle/build.sh +++ b/bundle/build.sh @@ -26,17 +26,16 @@ fi mkdir -p bundle/build/purescript # Strip the binaries, and copy them to the staging directory -for BIN in psc psci psc-docs psc-publish psc-bundle psc-ide-server psc-ide-client psc-package -do - FULL_BIN="$LOCAL_INSTALL_ROOT/bin/${BIN}${BIN_EXT}" - if [ "$OS" != "win64" ] - then - strip "$FULL_BIN" - fi - cp "$FULL_BIN" bundle/build/purescript -done +BIN=purs +FULL_BIN="$LOCAL_INSTALL_ROOT/bin/${BIN}${BIN_EXT}" +if [ "$OS" != "win64" ] +then + strip "$FULL_BIN" +fi +cp "$FULL_BIN" bundle/build/purescript # Copy extra files to the staging directory +cp scripts/* bundle/build/purescript/ cp bundle/README bundle/build/purescript/ cp LICENSE bundle/build/purescript/ cp INSTALL.md bundle/build/purescript/ diff --git a/psc-ide-client/Main.hs b/psc-ide-client/Main.hs deleted file mode 100644 index 8d47074509..0000000000 --- a/psc-ide-client/Main.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Main where - -import Prelude () -import Prelude.Compat - -import Control.Exception -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Text.IO as T -import Data.Version (showVersion) -import Data.Monoid ((<>)) -import Network -import Options.Applicative (ParseError (..)) -import qualified Options.Applicative as Opts -import System.Exit -import System.IO - -import qualified Paths_purescript as Paths - -data Options = Options - { optionsPort :: PortID - } - -main :: IO () -main = do - Options port <- Opts.execParser opts - client port - where - parser = - Options <$> - (PortNumber . fromIntegral <$> - Opts.option Opts.auto (Opts.long "port" <> Opts.short 'p' <> Opts.value (4242 :: Integer))) - opts = Opts.info (version <*> Opts.helper <*> parser) mempty - version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $ - Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden - -client :: PortID -> IO () -client port = do - hSetEncoding stdin utf8 - hSetEncoding stdout utf8 - h <- - connectTo "127.0.0.1" port `catch` - (\(SomeException e) -> - putStrLn - ("Couldn't connect to psc-ide-server on port: " ++ - show port ++ " Error: " ++ show e) >> - exitFailure) - T.hPutStrLn h =<< T.getLine - BS8.putStrLn =<< BS8.hGetLine h - hFlush stdout - hClose h diff --git a/psc-ide-server/PROTOCOL.md b/psc-ide/PROTOCOL.md similarity index 100% rename from psc-ide-server/PROTOCOL.md rename to psc-ide/PROTOCOL.md diff --git a/psc-ide-server/README.md b/psc-ide/README.md similarity index 100% rename from psc-ide-server/README.md rename to psc-ide/README.md diff --git a/psc-package/Main.hs b/psc-package/Main.hs deleted file mode 100644 index 897515b153..0000000000 --- a/psc-package/Main.hs +++ /dev/null @@ -1,423 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} - -module Main where - -import qualified Control.Foldl as Foldl -import qualified Data.Aeson as Aeson -import Data.Aeson.Encode.Pretty -import Data.Foldable (fold, for_, traverse_) -import Data.List (nub) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe, mapMaybe) -import qualified Data.Set as Set -import Data.Text (pack) -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TB -import qualified Data.Text.Read as TR -import Data.Traversable (for) -import Data.Version (showVersion) -import qualified Filesystem.Path.CurrentOS as Path -import GHC.Generics (Generic) -import qualified Options.Applicative as Opts -import qualified Paths_purescript as Paths -import qualified System.IO as IO -import Turtle hiding (echo, fold, s, x) -import qualified Turtle - -echoT :: Text -> IO () -echoT = Turtle.printf (Turtle.s % "\n") - -packageFile :: Path.FilePath -packageFile = "psc-package.json" - -data PackageConfig = PackageConfig - { name :: Text - , depends :: [Text] - , set :: Text - , source :: Text - } deriving (Show, Generic, Aeson.FromJSON, Aeson.ToJSON) - -pathToTextUnsafe :: Turtle.FilePath -> Text -pathToTextUnsafe = either (error "Path.toText failed") id . Path.toText - -defaultPackage :: Text -> PackageConfig -defaultPackage pkgName = - PackageConfig { name = pkgName - , depends = [ "prelude" ] - , set = "psc-" <> pack (showVersion Paths.version) - , source = "https://github.com/purescript/package-sets.git" - } - -readPackageFile :: IO PackageConfig -readPackageFile = do - exists <- testfile packageFile - unless exists $ do - echoT "psc-package.json does not exist" - exit (ExitFailure 1) - mpkg <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile packageFile - case mpkg of - Nothing -> do - echoT "Unable to parse psc-package.json" - exit (ExitFailure 1) - Just pkg -> return pkg - -packageConfigToJSON :: PackageConfig -> Text -packageConfigToJSON = - TL.toStrict - . TB.toLazyText - . encodePrettyToTextBuilder' config - where - config = defConfig - { confCompare = - keyOrder [ "name" - , "set" - , "source" - , "depends" - ] - } - -packageSetToJSON :: PackageSet -> Text -packageSetToJSON = - TL.toStrict - . TB.toLazyText - . encodePrettyToTextBuilder' config - where - config = defConfig { confCompare = compare } - -writePackageFile :: PackageConfig -> IO () -writePackageFile = - writeTextFile packageFile - . packageConfigToJSON - -data PackageInfo = PackageInfo - { repo :: Text - , version :: Text - , dependencies :: [Text] - } deriving (Show, Eq, Generic, Aeson.FromJSON, Aeson.ToJSON) - -type PackageSet = Map.Map Text PackageInfo - -cloneShallow - :: Text - -- ^ repo - -> Text - -- ^ branch/tag - -> Turtle.FilePath - -- ^ target directory - -> IO ExitCode -cloneShallow from ref into = - proc "git" - [ "clone" - , "-q" - , "-c", "advice.detachedHead=false" - , "--depth", "1" - , "-b", ref - , from - , pathToTextUnsafe into - ] empty .||. exit (ExitFailure 1) - -listRemoteTags - :: Text - -- ^ repo - -> Turtle.Shell Text -listRemoteTags from = let gitProc = inproc "git" - [ "ls-remote" - , "-q" - , "-t" - , from - ] empty - in lineToText <$> gitProc - -getPackageSet :: PackageConfig -> IO () -getPackageSet PackageConfig{ source, set } = do - let pkgDir = ".psc-package" fromText set ".set" - exists <- testdir pkgDir - unless exists . void $ cloneShallow source set pkgDir - -readPackageSet :: PackageConfig -> IO PackageSet -readPackageSet PackageConfig{ set } = do - let dbFile = ".psc-package" fromText set ".set" "packages.json" - exists <- testfile dbFile - unless exists $ do - echoT $ format (fp%" does not exist") dbFile - exit (ExitFailure 1) - mdb <- Aeson.decodeStrict . encodeUtf8 <$> readTextFile dbFile - case mdb of - Nothing -> do - echoT "Unable to parse packages.json" - exit (ExitFailure 1) - Just db -> return db - -writePackageSet :: PackageConfig -> PackageSet -> IO () -writePackageSet PackageConfig{ set } = - let dbFile = ".psc-package" fromText set ".set" "packages.json" - in writeTextFile dbFile . packageSetToJSON - -installOrUpdate :: Text -> Text -> PackageInfo -> IO Turtle.FilePath -installOrUpdate set pkgName PackageInfo{ repo, version } = do - echoT ("Updating " <> pkgName) - let pkgDir = ".psc-package" fromText set fromText pkgName fromText version - exists <- testdir pkgDir - unless exists . void $ cloneShallow repo version pkgDir - pure pkgDir - -getTransitiveDeps :: PackageSet -> [Text] -> IO [(Text, PackageInfo)] -getTransitiveDeps db depends = do - pkgs <- for depends $ \pkg -> - case Map.lookup pkg db of - Nothing -> do - echoT ("Package " <> pkg <> " does not exist in package set") - exit (ExitFailure 1) - Just PackageInfo{ dependencies } -> return (pkg : dependencies) - let unique = Set.toList (foldMap Set.fromList pkgs) - return (mapMaybe (\name -> fmap (name, ) (Map.lookup name db)) unique) - -updateImpl :: PackageConfig -> IO () -updateImpl config@PackageConfig{ depends } = do - getPackageSet config - db <- readPackageSet config - trans <- getTransitiveDeps db depends - echoT ("Updating " <> pack (show (length trans)) <> " packages...") - for_ trans $ \(pkgName, pkg) -> installOrUpdate (set config) pkgName pkg - -initialize :: IO () -initialize = do - exists <- testfile "psc-package.json" - when exists $ do - echoT "psc-package.json already exists" - exit (ExitFailure 1) - echoT "Initializing new project in current directory" - pkgName <- pathToTextUnsafe . Path.filename <$> pwd - let pkg = defaultPackage pkgName - writePackageFile pkg - updateImpl pkg - -update :: IO () -update = do - pkg <- readPackageFile - updateImpl pkg - echoT "Update complete" - -install :: String -> IO () -install pkgName = do - pkg <- readPackageFile - let pkg' = pkg { depends = nub (pack pkgName : depends pkg) } - updateImpl pkg' - writePackageFile pkg' - echoT "psc-package.json file was updated" - -uninstall :: String -> IO () -uninstall pkgName = do - pkg <- readPackageFile - let pkg' = pkg { depends = filter (/= pack pkgName) $ depends pkg } - updateImpl pkg' - writePackageFile pkg' - echoT "psc-package.json file was updated" - -listDependencies :: IO () -listDependencies = do - pkg@PackageConfig{ depends } <- readPackageFile - db <- readPackageSet pkg - trans <- getTransitiveDeps db depends - traverse_ (echoT . fst) trans - -listPackages :: IO () -listPackages = do - pkg <- readPackageFile - db <- readPackageSet pkg - traverse_ echoT (fmt <$> Map.assocs db) - where - fmt :: (Text, PackageInfo) -> Text - fmt (name, PackageInfo{ version }) = name <> " (" <> version <> ")" - -getSourcePaths :: PackageConfig -> PackageSet -> [Text] -> IO [Turtle.FilePath] -getSourcePaths PackageConfig{..} db pkgNames = do - trans <- getTransitiveDeps db pkgNames - let paths = [ ".psc-package" - fromText set - fromText pkgName - fromText version - "src" "**" "*.purs" - | (pkgName, PackageInfo{ version }) <- trans - ] - return paths - -listSourcePaths :: IO () -listSourcePaths = do - pkg@PackageConfig{ depends } <- readPackageFile - db <- readPackageSet pkg - paths <- getSourcePaths pkg db depends - traverse_ (echoT . pathToTextUnsafe) paths - -exec :: Text -> IO () -exec exeName = do - pkg@PackageConfig{..} <- readPackageFile - db <- readPackageSet pkg - paths <- getSourcePaths pkg db depends - procs exeName - (map pathToTextUnsafe ("src" "**" "*.purs" : paths)) - empty - -checkForUpdates :: Bool -> Bool -> IO () -checkForUpdates applyMinorUpdates applyMajorUpdates = do - pkg <- readPackageFile - db <- readPackageSet pkg - - echoT ("Checking " <> pack (show (Map.size db)) <> " packages for updates.") - echoT "Warning: this could take some time!" - - newDb <- Map.fromList <$> (for (Map.toList db) $ \(name, p@PackageInfo{ repo, version }) -> do - echoT ("Checking package " <> name) - tagLines <- Turtle.fold (listRemoteTags repo) Foldl.list - let tags = mapMaybe parseTag tagLines - newVersion <- case parseVersion version of - Just parts -> - let applyMinor = - case filter (isMinorReleaseFrom parts) tags of - [] -> pure version - minorReleases -> do - echoT ("New minor release available") - case applyMinorUpdates of - True -> do - let latestMinorRelease = maximum minorReleases - pure ("v" <> T.intercalate "." (map (pack . show) latestMinorRelease)) - False -> pure version - applyMajor = - case filter (isMajorReleaseFrom parts) tags of - [] -> applyMinor - newReleases -> do - echoT ("New major release available") - case applyMajorUpdates of - True -> do - let latestRelease = maximum newReleases - pure ("v" <> T.intercalate "." (map (pack . show) latestRelease)) - False -> applyMinor - in applyMajor - _ -> do - echoT "Unable to parse version string" - pure version - pure (name, p { version = newVersion })) - - when (applyMinorUpdates || applyMajorUpdates) - (writePackageSet pkg newDb) - where - parseTag :: Text -> Maybe [Int] - parseTag line = - case T.splitOn "\t" line of - [_sha, ref] -> - case T.stripPrefix "refs/tags/" ref of - Just tag -> - case parseVersion tag of - Just parts -> pure parts - _ -> Nothing - _ -> Nothing - _ -> Nothing - - parseVersion :: Text -> Maybe [Int] - parseVersion ref = - case T.stripPrefix "v" ref of - Just tag -> - traverse parseDecimal (T.splitOn "." tag) - _ -> Nothing - - parseDecimal :: Text -> Maybe Int - parseDecimal s = - case TR.decimal s of - Right (n, "") -> Just n - _ -> Nothing - - isMajorReleaseFrom :: [Int] -> [Int] -> Bool - isMajorReleaseFrom (0 : xs) (0 : ys) = isMajorReleaseFrom xs ys - isMajorReleaseFrom (x : _) (y : _) = y > x - isMajorReleaseFrom _ _ = False - - isMinorReleaseFrom :: [Int] -> [Int] -> Bool - isMinorReleaseFrom (0 : xs) (0 : ys) = isMinorReleaseFrom xs ys - isMinorReleaseFrom (x : xs) (y : ys) = y == x && ys > xs - isMinorReleaseFrom _ _ = False - -verifyPackageSet :: IO () -verifyPackageSet = do - pkg <- readPackageFile - db <- readPackageSet pkg - - echoT ("Verifying " <> pack (show (Map.size db)) <> " packages.") - echoT "Warning: this could take some time!" - - let installOrUpdate' (name, pkgInfo) = (name, ) <$> installOrUpdate (set pkg) name pkgInfo - paths <- Map.fromList <$> traverse installOrUpdate' (Map.toList db) - - for_ (Map.toList db) $ \(name, PackageInfo{..}) -> do - let dirFor = fromMaybe (error "verifyPackageSet: no directory") . (`Map.lookup` paths) - echoT ("Verifying package " <> name) - let srcGlobs = map (pathToTextUnsafe . ( ("src" "**" "*.purs")) . dirFor) (name : dependencies) - procs "psc" srcGlobs empty - -main :: IO () -main = do - IO.hSetEncoding IO.stdout IO.utf8 - IO.hSetEncoding IO.stderr IO.utf8 - cmd <- Opts.execParser opts - cmd - where - opts = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList - infoModList = Opts.fullDesc <> headerInfo <> footerInfo - headerInfo = Opts.progDesc "Manage package dependencies" - footerInfo = Opts.footer $ "psc-package " ++ showVersion Paths.version - - versionInfo :: Parser (a -> a) - versionInfo = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $ - Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden - - commands :: Parser (IO ()) - commands = (Opts.subparser . fold) - [ Opts.command "init" - (Opts.info (pure initialize) - (Opts.progDesc "Initialize a new package")) - , Opts.command "update" - (Opts.info (pure update) - (Opts.progDesc "Update dependencies")) - , Opts.command "uninstall" - (Opts.info (uninstall <$> pkg) - (Opts.progDesc "Uninstall the named package")) - , Opts.command "install" - (Opts.info (install <$> pkg) - (Opts.progDesc "Install the named package")) - , Opts.command "build" - (Opts.info (pure (exec "psc")) - (Opts.progDesc "Build the current package and dependencies")) - , Opts.command "dependencies" - (Opts.info (pure listDependencies) - (Opts.progDesc "List all (transitive) dependencies for the current package")) - , Opts.command "sources" - (Opts.info (pure listSourcePaths) - (Opts.progDesc "List all (active) source paths for dependencies")) - , Opts.command "available" - (Opts.info (pure listPackages) - (Opts.progDesc "List all packages available in the package set")) - , Opts.command "updates" - (Opts.info (checkForUpdates <$> apply <*> applyMajor) - (Opts.progDesc "Check all packages in the package set for new releases")) - , Opts.command "verify-set" - (Opts.info (pure verifyPackageSet) - (Opts.progDesc "Verify that the packages in the package set build correctly")) - ] - where - pkg = Opts.strArgument $ - Opts.metavar "PACKAGE" - <> Opts.help "The name of the package to install" - - apply = Opts.switch $ - Opts.long "apply" - <> Opts.help "Apply all minor package updates" - - applyMajor = Opts.switch $ - Opts.long "apply-breaking" - <> Opts.help "Apply all major package updates" diff --git a/psc-package/README.md b/psc-package/README.md deleted file mode 100644 index 8938ddec17..0000000000 --- a/psc-package/README.md +++ /dev/null @@ -1,99 +0,0 @@ -# `psc-package` - -`psc-package` is an executable which helps manage PureScript dependencies via Git. It can be used directly, but it is also designed to be used by external tools. - -## Concepts - -### Package Sets - -A _package set_ is a mapping from package names to: - -- the Git repository URL for the package -- the Git ref which should be passed to `git clone` to clone the appropriate version (usually a tag name, but a SHA is also valid) -- the package's transitive dependencies - -A package set repository contains a `packages.json` file which contains all mapping information. `psc-package` uses this information to decide which repos need to be cloned. - -The default package set is [purescript/package-sets](https://github.com/purescript/package-sets), but it is possible to create custom package sets by forking an existing package set or creating a new one from scratch. One benefit of using the default package set is that it is verified by a continuous integration process. - -## The `psc-package.json` format - -Here is a simple project configuration: - -```json -{ - "name": "my-project", - "set": "psc-0.10.2", - "source": "https://github.com/purescript/package-sets.git", - "depends": [ - "prelude" - ] -} -``` - -It defines: - -- The project name -- The package set to use to resolve dependencies (this corresponds to a branch or tag of the package set source repository) -- The package set source repository Git URL (change this if you want to host your own package sets) -- Any dependencies of the project, as a list of names of packages from the package set - -## How To - -### Create a project - -A new package can be created using `psc-package init`. This will: - -- Create a simple `psc-package.json` file based on the current compiler version -- Add the Prelude as a dependency (this can be removed later) -- Sync the local package database (under the `.psc-package/` directory) by cloning any necessary repositories. - -### Add dependencies - -To add a dependency, either: - -- Use the `install` command, which will update the project configuration automatically, or -- Modify the `psc-package.json` file, and sync manually by running the `update` command. - -### Build a project - -Active project dependencies and project source files under `src` can be compiled using the `build` command. - -This command is provided as a convenience until external tools add support for `psc-package`. It _might_ be removed in future. - -### Query the local package database - -The local package database can be queried using the following commands: - -- `sources` - list source directories for active package versions. This can be useful when building a command for, say, running PSCi. -- `dependencies` - list all transitive dependencies - -### Add a package to the package set - -Adding your package to the package set means that others can easily install it as a dependency. - -Please note that your package will be removed from the set if it is not kept up to date. It can be easily re-added later if this happens. - -Adding a package is a manual process right now. We would like to add commands to make this process simpler, but for now, please follow these steps: - -- Tag a release of your library -- Run the `dependencies` command to get the list of transitive dependencies -- Make a pull request on the package set repository (against `master`) to add a new entry to `packages.json`. Use the dependency information above to fill in the fields, and the name of your new tag. - -Travis will verify your package builds correctly, and then we will try to merge your pull request. Your package will then be available in the next tagged package set. - -### Update a package in the set - -- Tag a new release -- Make a pull request on `master` to modify the tag named in the package set repository. - -Again, once Travis verifies your change, we will merge it into `master` and your change will be available in the next tag. - -## FAQ - -### Can I add a dependency which is not in the package set? - -Not right now. We might add this feature in future, but for now, consider either: - -- Adding your dependency to the package set if possible, or -- Creating your own custom package set diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs deleted file mode 100644 index fd84ec4667..0000000000 --- a/psc-publish/Main.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Control.Monad.IO.Class (liftIO) -import Data.Version (Version(..), showVersion) -import qualified Data.Aeson as A -import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Monoid ((<>)) -import Data.Time.Clock (getCurrentTime) - -import Options.Applicative (Parser, ParseError (..)) -import qualified Options.Applicative as Opts - -import System.IO (hSetEncoding, stderr, stdout, utf8) - -import qualified Paths_purescript as Paths -import Language.PureScript.Publish -import Language.PureScript.Publish.ErrorsWarnings - -dryRun :: Parser Bool -dryRun = Opts.switch $ - Opts.long "dry-run" - <> Opts.help "Produce no output, and don't require a tagged version to be checked out." - -dryRunOptions :: PublishOptions -dryRunOptions = defaultPublishOptions - { publishGetVersion = return dummyVersion - , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn - , publishGetTagTime = const (liftIO getCurrentTime) - } - where dummyVersion = ("0.0.0", Version [0,0,0] []) - -main :: IO () -main = do - hSetEncoding stdout utf8 - hSetEncoding stderr utf8 - Opts.execParser opts >>= publish - where - opts = Opts.info (version <*> Opts.helper <*> dryRun) infoModList - infoModList = Opts.fullDesc <> headerInfo <> footerInfo - headerInfo = Opts.header "psc-publish - Generates documentation packages for upload to http://pursuit.purescript.org" - footerInfo = Opts.footer $ "psc-publish " ++ showVersion Paths.version - - version :: Parser (a -> a) - version = Opts.abortOption (InfoMsg (showVersion Paths.version)) $ - Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden - -publish :: Bool -> IO () -publish isDryRun = - if isDryRun - then do - _ <- unsafePreparePackage dryRunOptions - putStrLn "Dry run completed, no errors." - else do - pkg <- unsafePreparePackage defaultPublishOptions - BL.putStrLn (A.encode pkg) diff --git a/purescript.cabal b/purescript.cabal index 45b2f80485..e95d14d565 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -92,8 +92,8 @@ extra-source-files: examples/passing/*.purs , examples/docs/bower_components/purescript-prelude/src/*.purs , examples/docs/bower.json , examples/docs/src/*.purs - , psci/static/index.html - , psci/static/index.js + , app/static/index.html + , app/static/index.js , tests/support/package.json , tests/support/bower.json , tests/support/setup-win.cmd @@ -339,191 +339,56 @@ library other-modules: Paths_purescript ghc-options: -Wall -O2 -executable psc +executable purs build-depends: base >=4 && <5, - purescript -any, aeson >= 0.8 && < 1.0, ansi-terminal >= 0.6.2 && < 0.7, - base-compat >=0.6.0, - bytestring -any, - containers -any, - directory -any, - filepath -any, - Glob >= 0.7 && < 0.8, - mtl -any, - optparse-applicative >= 0.13.0, - parsec -any, - text -any, - time -any, - transformers -any, - transformers-compat -any, - utf8-string >= 1 && < 2 - main-is: Main.hs - buildable: True - hs-source-dirs: psc - other-modules: Paths_purescript - ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N" - -executable psci - build-depends: base >=4 && <5, - purescript -any, + ansi-wl-pprint -any, base-compat >=0.6.0, boxes >= 0.1.4 && < 0.2.0, bytestring -any, containers -any, directory -any, - filepath -any, file-embed -any, - Glob -any, + filepath -any, + Glob >= 0.7 && < 0.8, haskeline >= 0.7.0.0, http-types == 0.9.*, + monad-logger -any, mtl -any, + network -any, optparse-applicative >= 0.13.0, parsec -any, process -any, + protolude >= 0.1.6, + purescript -any, + sourcemap >= 0.1.6, + split -any, stm >= 0.2.4.0, text -any, time -any, transformers -any, transformers-compat -any, + utf8-string >= 1 && < 2, wai == 3.*, wai-websockets == 3.*, warp == 3.*, websockets >= 0.9 && <0.10 main-is: Main.hs buildable: True - hs-source-dirs: psci - other-modules: Paths_purescript - ghc-options: -Wall -O2 - -executable psc-docs - build-depends: base >=4 && <5, - purescript -any, - ansi-wl-pprint -any, - directory -any, - filepath -any, - Glob -any, - mtl -any, - optparse-applicative >= 0.13.0, - process -any, - split -any, - text -any, - transformers -any, - transformers-compat -any - main-is: Main.hs - other-modules: Paths_purescript - buildable: True - hs-source-dirs: psc-docs - other-modules: Ctags - Etags - Tags - ghc-options: -Wall -O2 - -executable psc-publish - build-depends: base >=4 && <5, - purescript -any, - aeson >= 0.8 && < 1.0, - bytestring -any, - optparse-applicative -any, - time -any, - transformers -any - main-is: Main.hs - other-modules: Paths_purescript - buildable: True - hs-source-dirs: psc-publish - ghc-options: -Wall -O2 - -executable psc-package - build-depends: base >=4 && <5, - purescript -any, - aeson -any, - aeson-pretty -any, - bytestring -any, - containers -any, - foldl -any, - optparse-applicative -any, - system-filepath -any, - text -any, - turtle ==1.3.* - main-is: Main.hs - other-modules: Paths_purescript - buildable: True - hs-source-dirs: psc-package - ghc-options: -Wall -O2 - -executable psc-hierarchy - build-depends: base >=4 && <5, - purescript -any, - directory -any, - filepath -any, - Glob -any, - mtl -any, - optparse-applicative >= 0.13.0, - parsec -any, - process -any, - text -any - main-is: Main.hs + hs-source-dirs: app other-modules: Paths_purescript - buildable: True - hs-source-dirs: hierarchy - other-modules: - ghc-options: -Wall -O2 - -executable psc-bundle - main-is: Main.hs - other-modules: Paths_purescript - other-extensions: - build-depends: base >=4 && <5, - bytestring -any, - purescript -any, - directory -any, - aeson >= 0.8 && < 1.0, - filepath -any, - Glob -any, - mtl -any, - optparse-applicative >= 0.13.0, - sourcemap >= 0.1.6, - transformers -any, - transformers-compat -any, - utf8-string >= 1 && < 2 - - ghc-options: -Wall -O2 - hs-source-dirs: psc-bundle - -executable psc-ide-server - main-is: Main.hs - other-modules: Paths_purescript - other-extensions: - build-depends: base >=4 && <5, - aeson >= 0.8 && < 1.0, - bytestring -any, - purescript -any, - directory -any, - filepath -any, - monad-logger -any, - mtl -any, - network -any, - optparse-applicative >= 0.13.0, - protolude >= 0.1.6, - stm -any, - text -any, - transformers -any - ghc-options: -Wall -O2 -threaded - hs-source-dirs: psc-ide-server - -executable psc-ide-client - main-is: Main.hs - other-modules: Paths_purescript - other-extensions: - build-depends: base >=4 && <5, - base-compat >=0.6.0, - bytestring -any, - mtl -any, - network -any, - optparse-applicative >= 0.13.0, - text -any - ghc-options: -Wall -O2 - hs-source-dirs: psc-ide-client + Command.Bundle + Command.Compile + Command.Docs + Command.Docs.Ctags + Command.Docs.Etags + Command.Docs.Tags + Command.Hierarchy + Command.Ide + Command.Publish + Command.REPL + ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N" test-suite tests build-depends: base >=4 && <5, diff --git a/scripts/psc b/scripts/psc new file mode 100755 index 0000000000..d24b821201 --- /dev/null +++ b/scripts/psc @@ -0,0 +1,2 @@ +#!/bin/sh +purs compile $@ diff --git a/scripts/psc-bundle b/scripts/psc-bundle new file mode 100755 index 0000000000..72f0c7011c --- /dev/null +++ b/scripts/psc-bundle @@ -0,0 +1,2 @@ +#!/bin/sh +purs bundle $@ diff --git a/scripts/psc-docs b/scripts/psc-docs new file mode 100755 index 0000000000..27e63e4b39 --- /dev/null +++ b/scripts/psc-docs @@ -0,0 +1,2 @@ +#!/bin/sh +purs docs $@ diff --git a/scripts/psc-hierarchy b/scripts/psc-hierarchy new file mode 100755 index 0000000000..3c72d8232c --- /dev/null +++ b/scripts/psc-hierarchy @@ -0,0 +1,2 @@ +#!/bin/sh +purs hierarchy $@ diff --git a/scripts/psc-ide-server b/scripts/psc-ide-server new file mode 100755 index 0000000000..d9bc1596bf --- /dev/null +++ b/scripts/psc-ide-server @@ -0,0 +1,2 @@ +#!/bin/sh +purs ide $@ diff --git a/scripts/psc-publish b/scripts/psc-publish new file mode 100755 index 0000000000..36dd20738a --- /dev/null +++ b/scripts/psc-publish @@ -0,0 +1,2 @@ +#!/bin/sh +purs publish $@ diff --git a/scripts/psci b/scripts/psci new file mode 100755 index 0000000000..c4599e1a54 --- /dev/null +++ b/scripts/psci @@ -0,0 +1,2 @@ +#!/bin/sh +purs repl $@ diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs index 69f9b5bc30..cb38128a26 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -1,5 +1,4 @@ --- | --- This module optimizes code in the simplified-Javascript intermediate representation. +-- | This module optimizes code in the simplified-Javascript intermediate representation. -- -- The following optimizations are supported: -- @@ -18,14 +17,11 @@ -- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!) -- -- * Inlining primitive Javascript operators --- module Language.PureScript.CodeGen.JS.Optimizer (optimize) where import Prelude.Compat -import Control.Monad.Reader (MonadReader, ask, asks) import Control.Monad.Supply.Class (MonadSupply) - import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Optimizer.Blocks import Language.PureScript.CodeGen.JS.Optimizer.Common @@ -33,24 +29,15 @@ import Language.PureScript.CodeGen.JS.Optimizer.Inliner import Language.PureScript.CodeGen.JS.Optimizer.MagicDo import Language.PureScript.CodeGen.JS.Optimizer.TCO import Language.PureScript.CodeGen.JS.Optimizer.Unused -import Language.PureScript.Options --- | --- Apply a series of optimizer passes to simplified Javascript code --- -optimize :: (MonadReader Options m, MonadSupply m) => JS -> m JS +-- | Apply a series of optimizer passes to simplified Javascript code +optimize :: MonadSupply m => JS -> m JS optimize js = do - noOpt <- asks optionsNoOptimizations - if noOpt then return js else optimize' js - -optimize' :: (MonadReader Options m, MonadSupply m) => JS -> m JS -optimize' js = do - opts <- ask js' <- untilFixedPoint (inlineFnComposition . inlineUnsafePartial . tidyUp . applyAll [ inlineCommonValues , inlineCommonOperators ]) js - untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js' + untilFixedPoint (return . tidyUp) . tco . magicDo $ js' where tidyUp :: JS -> JS tidyUp = applyAll diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs index 0d545a83c2..9066276497 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs @@ -1,7 +1,5 @@ --- | --- This module implements the "Magic Do" optimization, which inlines calls to return +-- | This module implements the "Magic Do" optimization, which inlines calls to return -- and bind for the Eff monad, as well as some of its actions. --- module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (magicDo) where import Prelude.Compat @@ -11,16 +9,10 @@ import Data.Maybe (fromJust, isJust) import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Optimizer.Common -import Language.PureScript.Options import Language.PureScript.PSString (mkString) import qualified Language.PureScript.Constants as C -magicDo :: Options -> JS -> JS -magicDo opts | optionsNoMagicDo opts = id - | otherwise = inlineST . magicDo' - --- | --- Inline type class dictionaries for >>= and return for the Eff monad +-- | Inline type class dictionaries for >>= and return for the Eff monad -- -- E.g. -- @@ -34,9 +26,8 @@ magicDo opts | optionsNoMagicDo opts = id -- var x = m1(); -- ... -- } --- -magicDo' :: JS -> JS -magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert +magicDo :: JS -> JS +magicDo = inlineST . everywhereOnJS undo . everywhereOnJSTopDown convert where -- The name of the function block which is added to denote a do block fnName = "__do" @@ -85,9 +76,7 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert applyReturns (JSIfElse ss cond t f) = JSIfElse ss cond (applyReturns t) (applyReturns `fmap` f) applyReturns other = other --- | --- Inline functions in the ST module --- +-- | Inline functions in the ST module inlineST :: JS -> JS inlineST = everywhereOnJS convertBlock where diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs index 1b3f080820..47bfa7dd8a 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs @@ -1,26 +1,15 @@ --- | --- This module implements tail call elimination. --- +-- | This module implements tail call elimination. module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where import Prelude.Compat import Data.Text (Text) import Data.Monoid ((<>), getAny, Any(..)) - -import Language.PureScript.Options import Language.PureScript.CodeGen.JS.AST --- | --- Eliminate tail calls --- -tco :: Options -> JS -> JS -tco opts | optionsNoTco opts = id - | otherwise = tco' - -tco' :: JS -> JS -tco' = everywhereOnJS convert - where +-- | Eliminate tail calls +tco :: JS -> JS +tco = everywhereOnJS convert where tcoLabel :: Text tcoLabel = "tco" diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index 62040a8707..0e4e6d137c 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -1,42 +1,20 @@ --- | --- The data type of compiler options --- +-- | The data type of compiler options module Language.PureScript.Options where import Prelude.Compat --- | --- The data type of compiler options --- -data Options = Options { - -- | - -- Disable tail-call elimination - optionsNoTco :: Bool - -- | - -- Disable inlining of calls to return and bind for the Eff monad - , optionsNoMagicDo :: Bool - -- | - -- When specified, checks the type of `main` in the module, and generate a call to run main - -- after the module definitions. - , optionsMain :: Maybe String - -- | - -- Skip all optimizations - , optionsNoOptimizations :: Bool - -- | - -- Verbose error message - , optionsVerboseErrors :: Bool - -- | - -- Remove the comments from the generated js +-- | The data type of compiler options +data Options = Options + { optionsVerboseErrors :: Bool + -- ^ Verbose error message , optionsNoComments :: Bool - -- | - -- Generate soure maps + -- ^ Remove the comments from the generated js , optionsSourceMaps :: Bool - -- | - -- Dump CoreFn + -- ^ Generate source maps , optionsDumpCoreFn :: Bool + -- ^ Dump CoreFn } deriving Show --- | -- Default make options defaultOptions :: Options -defaultOptions = Options False False Nothing False False False False False +defaultOptions = Options False False False False diff --git a/stack-ghc-8.0.yaml b/stack-ghc-8.0.yaml index 3dc2cc64f8..199de644de 100644 --- a/stack-ghc-8.0.yaml +++ b/stack-ghc-8.0.yaml @@ -9,6 +9,5 @@ extra-deps: - optparse-applicative-0.13.0.0 - pipes-4.1.9 - pipes-http-1.0.2 -- turtle-1.3.1 - wai-websockets-3.0.0.9 - websockets-0.9.6.2 diff --git a/stack.yaml b/stack.yaml index 44b96703a5..4e9e34c595 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,4 +5,3 @@ extra-deps: - aeson-better-errors-0.9.1.0 - bower-json-1.0.0.1 - optparse-applicative-0.13.0.0 -- turtle-1.3.1 diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index 5d3841bf7b..4ea76d318b 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -112,7 +112,7 @@ inProject f = do compileTestProject :: IO Bool compileTestProject = inProject $ do (_, _, _, procHandle) <- - createProcess $ (shell $ "psc \"src/**/*.purs\"") + createProcess $ (shell $ "purs compile \"src/**/*.purs\"") r <- tryNTimes 10 (getProcessExitCode procHandle) pure (fromMaybe False (isSuccess <$> r)) From e336bbae159d556d2ee9148e3a1a9a2dca47adcf Mon Sep 17 00:00:00 2001 From: Hyunje Jun Date: Thu, 9 Feb 2017 04:22:41 +0900 Subject: [PATCH 0659/1580] Remove extra-deps from stack-ghc-8.0.yaml (#2636) To use the packages in the resolver, version constraints in the cabal file is loosened. Also Pursuit.hs is modified to support the higher version of http-client, without behaviour change. --- purescript.cabal | 10 +++++----- src/Language/PureScript/Ide/Pursuit.hs | 1 - stack-ghc-8.0.yaml | 10 +--------- 3 files changed, 6 insertions(+), 15 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index e95d14d565..6f07f03924 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -113,7 +113,7 @@ source-repository head library build-depends: base >=4.8 && <5, - aeson >= 0.8 && < 1.0, + aeson >= 0.8 && < 1.1, aeson-better-errors >= 0.8, ansi-terminal >= 0.6.2 && < 0.7, base-compat >=0.6.0, @@ -133,7 +133,7 @@ library fsnotify >= 0.2.1, Glob >= 0.7 && < 0.8, haskeline >= 0.7.0.0, - http-client >= 0.4.30 && <0.5, + http-client >= 0.4.30 && < 0.6.0, http-types -any, language-javascript >= 0.6.0.9 && < 0.7, lens == 4.*, @@ -144,7 +144,7 @@ library parallel >= 3.2 && < 3.3, parsec >=3.1.10, pattern-arrows >= 0.0.2 && < 0.1, - pipes >= 4.0.0 && < 4.3.0, + pipes >= 4.0.0 && < 4.4.0, pipes-http -any, process >= 1.2.0 && < 1.5, protolude >= 0.1.6, @@ -341,7 +341,7 @@ library executable purs build-depends: base >=4 && <5, - aeson >= 0.8 && < 1.0, + aeson >= 0.8 && < 1.1, ansi-terminal >= 0.6.2 && < 0.7, ansi-wl-pprint -any, base-compat >=0.6.0, @@ -373,7 +373,7 @@ executable purs wai == 3.*, wai-websockets == 3.*, warp == 3.*, - websockets >= 0.9 && <0.10 + websockets >= 0.9 && <0.11 main-is: Main.hs buildable: True hs-source-dirs: app diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs index 1143a245ed..55294989b7 100644 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -45,7 +45,6 @@ queryPursuit q = do handler :: HttpException -> IO [a] -handler StatusCodeException{} = pure [] handler _ = pure [] searchPursuitForDeclarations :: Text -> IO [PursuitResponse] diff --git a/stack-ghc-8.0.yaml b/stack-ghc-8.0.yaml index 199de644de..3db884660f 100644 --- a/stack-ghc-8.0.yaml +++ b/stack-ghc-8.0.yaml @@ -2,12 +2,4 @@ resolver: nightly-2017-01-31 packages: - '.' extra-deps: -- aeson-0.11.3.0 -- bower-json-1.0.0.1 -- http-client-0.4.31.2 -- http-client-tls-0.2.4.1 -- optparse-applicative-0.13.0.0 -- pipes-4.1.9 -- pipes-http-1.0.2 -- wai-websockets-3.0.0.9 -- websockets-0.9.6.2 +- pipes-http-1.0.5 From 97debbc537dafe0b2adebee6316c1960cc02b4e1 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 8 Feb 2017 22:36:47 +0000 Subject: [PATCH 0660/1580] Fix builtin links (#2641) * Add tests for links to Prim declarations * Fix links to Prim declarations --- src/Language/PureScript/Docs/Types.hs | 7 ++-- tests/TestDocs.hs | 60 +++++++++++++++++++++++---- 2 files changed, 56 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index f18648b96a..e69eb87621 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -397,8 +397,9 @@ data LinkLocation | BuiltinModule P.ModuleName deriving (Show, Eq, Ord) --- | Given a links context, a thing to link to (either a value or a type), and --- its containing module, attempt to create a DocLink. +-- | Given a links context, the current module name, the namespace of a thing +-- to link to, its title, and its containing module, attempt to create a +-- DocLink. getLink :: LinksContext -> P.ModuleName -> Namespace -> Text -> ContainingModule -> Maybe DocLink getLink LinksContext{..} curMn namespace target containingMod = do location <- getLinkLocation @@ -409,7 +410,7 @@ getLink LinksContext{..} curMn namespace target containingMod = do } where - getLinkLocation = normalLinkLocation <|> builtinLinkLocation + getLinkLocation = builtinLinkLocation <|> normalLinkLocation normalLinkLocation = do case containingMod of diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 46ce23de2b..8c6abaf80f 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} @@ -44,11 +45,12 @@ main = pushd "examples/docs" $ do res <- Publish.preparePackage publishOpts case res of Left e -> Publish.printErrorToStdout e >> exitFailure - Right Docs.Package{..} -> + Right pkg@Docs.Package{..} -> forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) -> let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn)) (find ((==) mn . Docs.modName) pkgModules) - in forM_ pragmas (`runAssertionIO` mdl) + linksCtx = Docs.getLinksContext pkg + in forM_ pragmas (\a -> runAssertionIO a linksCtx mdl) takeJust :: String -> Maybe a -> a @@ -82,6 +84,11 @@ data Assertion -- | Assert that there should be some declarations re-exported from a -- particular module in a particular package. | ShouldHaveReExport (Docs.InPackage P.ModuleName) + -- | Assert that a link to some specific declaration exists within the + -- rendered code for a declaration. Fields are: local module, local + -- declaration title, title of linked declaration, namespace of linked + -- declaration, destination of link. + | ShouldHaveLink P.ModuleName Text Text Docs.Namespace Docs.LinkLocation deriving (Show) newtype ShowFn a = ShowFn a @@ -119,6 +126,17 @@ data AssertionFailure -- | A module was missing re-exports from a particular module. -- Fields: module name, expected re-export, actual re-exports. | ReExportMissing P.ModuleName (Docs.InPackage P.ModuleName) [Docs.InPackage P.ModuleName] + -- | Expected to find some other declaration mentioned in this declaration's + -- rendered code, but did not find anything. + -- Fields: module name, declaration title, title of declaration which was + -- expected but not found in. + | LinkedDeclarationMissing P.ModuleName Text Text + -- | Expected one link location for a declaration mentioned in some other + -- declaration's rendered code, but found a different one. Fields: module + -- name, title of the local declaration which links to some other + -- declaration, title of the linked declaration, expected location, actual + -- location. + | BadLinkLocation P.ModuleName Text Text Docs.LinkLocation Docs.LinkLocation deriving (Show) data AssertionResult @@ -126,8 +144,8 @@ data AssertionResult | Fail AssertionFailure deriving (Show) -runAssertion :: Assertion -> Docs.Module -> AssertionResult -runAssertion assertion Docs.Module{..} = +runAssertion :: Assertion -> Docs.LinksContext -> Docs.Module -> AssertionResult +runAssertion assertion linksCtx Docs.Module{..} = case assertion of ShouldBeDocumented mn decl children -> case findChildren decl (declarationsFor mn) of @@ -214,6 +232,19 @@ runAssertion assertion Docs.Module{..} = then Pass else Fail (ReExportMissing modName reExp reExps) + ShouldHaveLink mn decl destTitle destNs expectedLoc -> + findDecl mn decl $ \decl' -> + let + rendered = Docs.renderDeclaration decl' + in + case extract rendered destNs destTitle of + Just (Docs.linkLocation -> actualLoc) -> + if expectedLoc == actualLoc + then Pass + else Fail (BadLinkLocation mn decl destTitle expectedLoc actualLoc) + Nothing -> + Fail (LinkedDeclarationMissing mn decl destTitle) + where declarationsFor mn = if mn == modName @@ -232,6 +263,17 @@ runAssertion assertion Docs.Module{..} = childrenTitles = map Docs.cdeclTitle . Docs.declChildren + extract :: Docs.RenderedCode -> Docs.Namespace -> Text -> Maybe Docs.DocLink + extract rc ns title = getFirst (Docs.outputWith (First . go) rc) >>= getLink + where + getLink = + Docs.getLink linksCtx (P.moduleNameFromString "$DocsTest") ns title + go = \case + Docs.Symbol ns' title' (Docs.Link containingMod) + | ns' == ns && title' == title -> Just containingMod + _ -> + Nothing + checkConstrained :: P.Type -> Text -> Bool checkConstrained ty tyClass = -- Note that we don't recurse on ConstrainedType if none of the constraints @@ -248,10 +290,10 @@ checkConstrained ty tyClass = matches className = (==) className . P.runProperName . P.disqualify . P.constraintClass -runAssertionIO :: Assertion -> Docs.Module -> IO () -runAssertionIO assertion mdl = do +runAssertionIO :: Assertion -> Docs.LinksContext -> Docs.Module -> IO () +runAssertionIO assertion linksCtx mdl = do putStrLn ("In " ++ T.unpack (P.runModuleName (Docs.modName mdl)) ++ ": " ++ show assertion) - case runAssertion assertion mdl of + case runAssertion assertion linksCtx mdl of Pass -> pure () Fail reason -> do putStrLn ("Failed: " <> show reason) @@ -276,6 +318,8 @@ testCases = , ("Example2", [ ShouldBeDocumented (n "Example2") "one" [] , ShouldBeDocumented (n "Example2") "two" [] + + , ShouldHaveLink (n "Example2") "one" "Int" Docs.TypeLevel (Docs.BuiltinModule (n "Prim")) ]) , ("UTF8", @@ -359,7 +403,7 @@ testCases = ] where - n = P.moduleNameFromString . T.pack + n = P.moduleNameFromString pkg str = let Right p = parsePackageName str in p hasTypeVar varName = From 52385b79baa53a2422bc730c50f4aa63e6689c51 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Wed, 8 Feb 2017 23:02:00 +0000 Subject: [PATCH 0661/1580] Add basic usability check for type class members (#2637) * Add basic usability check for type class members * Add example with conflicting var name and update error message --- examples/docs/src/TypeClassWithFunDeps.purs | 2 +- examples/failing/UnusableTypeClassMethod.purs | 7 ++++ ...usableTypeClassMethodConflictingIdent.purs | 7 ++++ .../UnusableTypeClassMethodSynonym.purs | 9 +++++ examples/passing/UnicodeType.purs | 4 +-- examples/passing/UsableTypeClassMethods.purs | 35 +++++++++++++++++++ src/Language/PureScript/AST/Declarations.hs | 3 ++ src/Language/PureScript/Errors.hs | 6 ++++ src/Language/PureScript/TypeChecker.hs | 30 +++++++++++++--- 9 files changed, 96 insertions(+), 7 deletions(-) create mode 100644 examples/failing/UnusableTypeClassMethod.purs create mode 100644 examples/failing/UnusableTypeClassMethodConflictingIdent.purs create mode 100644 examples/failing/UnusableTypeClassMethodSynonym.purs create mode 100644 examples/passing/UsableTypeClassMethods.purs diff --git a/examples/docs/src/TypeClassWithFunDeps.purs b/examples/docs/src/TypeClassWithFunDeps.purs index 3fd918a9d0..3aee885b19 100644 --- a/examples/docs/src/TypeClassWithFunDeps.purs +++ b/examples/docs/src/TypeClassWithFunDeps.purs @@ -2,4 +2,4 @@ module TypeClassWithFunDeps where class TypeClassWithFunDeps a b c d e | a b -> c, c -> d e where - aMember :: a + aMember :: a -> b diff --git a/examples/failing/UnusableTypeClassMethod.purs b/examples/failing/UnusableTypeClassMethod.purs new file mode 100644 index 0000000000..058f504338 --- /dev/null +++ b/examples/failing/UnusableTypeClassMethod.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith UnusableDeclaration +module Main where + +class C a b where + -- type doesn't contain `a`, which is also required to determine an instance + c :: b + diff --git a/examples/failing/UnusableTypeClassMethodConflictingIdent.purs b/examples/failing/UnusableTypeClassMethodConflictingIdent.purs new file mode 100644 index 0000000000..08ed602ab8 --- /dev/null +++ b/examples/failing/UnusableTypeClassMethodConflictingIdent.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith UnusableDeclaration +module Main where + +class C a where + -- type doesn't contain the type class var `a` + c :: forall a. a + diff --git a/examples/failing/UnusableTypeClassMethodSynonym.purs b/examples/failing/UnusableTypeClassMethodSynonym.purs new file mode 100644 index 0000000000..aae1e3379c --- /dev/null +++ b/examples/failing/UnusableTypeClassMethodSynonym.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith UnusableDeclaration +module Main where + +type M x = forall a. a + +class C a where + -- after synonym expansion, the type doesn't actually contain an `a` + c :: M a + diff --git a/examples/passing/UnicodeType.purs b/examples/passing/UnicodeType.purs index 59e732f8ad..ea925253c7 100644 --- a/examples/passing/UnicodeType.purs +++ b/examples/passing/UnicodeType.purs @@ -4,10 +4,10 @@ import Prelude import Control.Monad.Eff.Console (log) class Monad m ⇐ Monad1 m where - f1 :: Int + f1 :: m Int class Monad m <= Monad2 m where - f2 :: Int + f2 :: m Int f ∷ ∀ m. Monad m ⇒ Int → m Int f n = do diff --git a/examples/passing/UsableTypeClassMethods.purs b/examples/passing/UsableTypeClassMethods.purs new file mode 100644 index 0000000000..5545dedf05 --- /dev/null +++ b/examples/passing/UsableTypeClassMethods.purs @@ -0,0 +1,35 @@ +-- this is testing that we don't see an `UnusableDeclaration` error for type +-- class methods that should be valid based on various configurations of fundeps +module Main where + +import Control.Monad.Eff.Console (log) + +-- no fundeps +class C0 a b where + c0 :: a -> b + +-- simple fundep +class C1 a b | a -> b where + c1 :: a + c1' :: a -> b + +-- transitive +class C2 a b c | a -> b, b -> c where + c2 :: a + c2' :: a -> b + c2'' :: a -> c + c2''' :: a -> b -> c + +-- with cycles +class C3 a b c | a -> b, b -> a, b -> c where + c3 :: a + c3' :: b + c3'' :: a -> c + c3''' :: b -> c + c3'''' :: a -> b -> c + +-- nullary class +class C4 where + c4 :: forall a. a + +main = log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 6544cae120..2df2ea1766 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -145,6 +145,9 @@ data SimpleErrorMessage | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int -- | a user-defined warning raised by using the Warn type class | UserDefinedWarning Type + -- | a declaration couldn't be used because there wouldn't be enough information + -- | to choose an instance + | UnusableDeclaration Ident deriving (Show) -- | Error message hints, providing more detailed information about failure. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 11b9507336..7637c50f72 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -171,6 +171,7 @@ errorCode em = case unwrapErrorMessage em of CannotUseBindWithDo{} -> "CannotUseBindWithDo" ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch" UserDefinedWarning{} -> "UserDefinedWarning" + UnusableDeclaration{} -> "UnusableDeclaration" -- | A stack trace for an error newtype MultipleErrors = MultipleErrors @@ -886,6 +887,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS , indent msg ] + renderSimpleErrorMessage (UnusableDeclaration ident) = + paras [ line $ "The declaration " <> markCode (showIdent ident) <> " is unusable." + , line $ "This happens when a constraint couldn't possibly have enough information to work out which instance is required." + ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index c63f5f6356..36b03c1b3b 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -113,7 +113,8 @@ addValue moduleName name ty nameKind = do putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, nameKind, Defined) (names env) }) addTypeClass - :: (MonadState CheckState m) + :: forall m + . (MonadState CheckState m, MonadError MultipleErrors m) => ModuleName -> ProperName 'ClassName -> [(Text, Maybe Kind)] @@ -121,16 +122,37 @@ addTypeClass -> [FunctionalDependency] -> [Declaration] -> m () -addTypeClass moduleName pn args implies dependencies ds = - modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) newClass (typeClasses . checkEnv $ st) } } +addTypeClass moduleName pn args implies dependencies ds = do + env <- getEnv + traverse_ (checkMemberIsUsable (typeSynonyms env)) classMembers + modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) newClass (typeClasses . checkEnv $ st) } } where + classMembers :: [(Ident, Type)] + classMembers = map toPair ds + newClass :: TypeClassData - newClass = makeTypeClassData args (map toPair ds) implies dependencies + newClass = makeTypeClassData args classMembers implies dependencies + + coveringSets :: [S.Set Int] + coveringSets = S.toList (typeClassCoveringSets newClass) + + argToIndex :: Text -> Maybe Int + argToIndex = flip M.lookup $ M.fromList (zipWith ((,) . fst) args [0..]) toPair (TypeDeclaration ident ty) = (ident, ty) toPair (PositionedDeclaration _ _ d) = toPair d toPair _ = internalError "Invalid declaration in TypeClassDeclaration" + -- Currently we are only checking usability based on the type class currently + -- being defined. If the mentioned arguments don't include a covering set, + -- then we won't be able to find a instance. + checkMemberIsUsable :: T.SynonymMap -> (Ident, Type) -> m () + checkMemberIsUsable syns (ident, memberTy) = do + memberTy' <- T.replaceAllTypeSynonymsM syns memberTy + let mentionedArgIndexes = S.fromList (mapMaybe argToIndex (freeTypeVariables memberTy')) + unless (any (`S.isSubsetOf` mentionedArgIndexes) coveringSets) $ + throwError . errorMessage $ UnusableDeclaration ident + addTypeClassDictionaries :: (MonadState CheckState m) => Maybe ModuleName From bdd8a09abbfc3a2f96a544d053cec1ea53b574fb Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Thu, 9 Feb 2017 05:07:51 +0100 Subject: [PATCH 0662/1580] Pattern guards (#2588) * WIP Pattern guards * Introduce GuardedExpr constructor * Longer names for alternative desugaring * isIrrefutable * Consistently value binders `vb` * Introduce isIrrefutable in Purescrupt/AST/Binders * Consolidate out of line code generation * Comment on special casing ConditionalGuards * Why do we need to scrutinize again * Remove warnings from AST/Traversals * Remove trueLit constant * Remove (***) import from CoreFn/Desugar * Removed shadowing in Linter/Exhaustive * Missed a tick * Make SourceFileSpec work * Fix AST/Traversals * Desugar with less cases * Desugar remaining alternatives if there are no guards remaining ``` g n | p = ... g n | b <- f = ... ``` The pattern guard wouldn't be desugared without this patch because `p` was the only guarded expression in the first alternative which resulted in the empty list case in `desugarGuardedAlternative` so the remaining second alternative is passed as-is upwards again. * Update comment * Remove redundant Show constraint * Remove redundant Monad constraint * Remove duplication * Use short-circuiting fold in CodeGen/JS * Correct generation of pattern guards with irrefutable patterns Consider ``` f ... | i <- g = ... ``` Where i is an irrefutable pattern we would generate ``` case ... of ... -> case g of i -> ... _ -> ... ``` We generated an unreachable case alternative Which is bogus of course! A pattern match on `i` will never fail! This patch stops generating the unreachable case. * Fix everythingWithScope This lead to undetected shadowing. Fortunately the fix was to delete some wrong "duplicated" code. * Error on desugaring pattern guards to CoreFn * Use scoped type variable m to dry code * Error when trying to typecheck pattern guard These are desugared to usual cases and guards already * Make sure to not evaluate scrutinees twice * Typos * A few examples --- examples/failing/NonExhaustivePatGuard.purs | 5 + examples/passing/Guards.purs | 34 +++ .../warning/ShadowedBinderPatternGuard.purs | 7 + src/Language/PureScript/AST/Binders.hs | 8 + src/Language/PureScript/AST/Declarations.hs | 25 +- src/Language/PureScript/AST/Traversals.hs | 98 +++++-- src/Language/PureScript/CodeGen/JS.hs | 26 +- src/Language/PureScript/CoreFn/Desugar.hs | 18 +- .../PureScript/Docs/Convert/Single.hs | 2 +- src/Language/PureScript/Interactive/Module.hs | 4 +- src/Language/PureScript/Linter/Exhaustive.hs | 43 +-- src/Language/PureScript/Parser.hs | 46 ++-- .../PureScript/Parser/Declarations.hs | 33 ++- src/Language/PureScript/Pretty/Values.hs | 15 +- src/Language/PureScript/Sugar.hs | 1 + .../PureScript/Sugar/BindingGroups.hs | 9 +- .../PureScript/Sugar/CaseDeclarations.hs | 258 ++++++++++++++++-- src/Language/PureScript/Sugar/DoNotation.hs | 2 +- src/Language/PureScript/Sugar/Names.hs | 12 +- .../PureScript/Sugar/ObjectWildcards.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 14 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 71 ++--- .../PureScript/Sugar/TypeDeclarations.hs | 8 +- src/Language/PureScript/TypeChecker.hs | 4 +- src/Language/PureScript/TypeChecker/Types.hs | 34 ++- .../Language/PureScript/Ide/SourceFileSpec.hs | 2 +- 26 files changed, 584 insertions(+), 197 deletions(-) create mode 100644 examples/failing/NonExhaustivePatGuard.purs create mode 100644 examples/warning/ShadowedBinderPatternGuard.purs diff --git a/examples/failing/NonExhaustivePatGuard.purs b/examples/failing/NonExhaustivePatGuard.purs new file mode 100644 index 0000000000..cdcfc2f1e0 --- /dev/null +++ b/examples/failing/NonExhaustivePatGuard.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +f :: Int -> Int +f x | 1 <- x = x \ No newline at end of file diff --git a/examples/passing/Guards.purs b/examples/passing/Guards.purs index ddc7678cc6..9b21e976ac 100644 --- a/examples/passing/Guards.purs +++ b/examples/passing/Guards.purs @@ -27,4 +27,38 @@ testIndentation x y | x > 0.0 | otherwise = y - x +-- pattern guard example with two clauses +clunky1 :: Int -> Int -> Int +clunky1 a b | x <- max a b + , x > 5 + = x +clunky1 a _ = a + +clunky2 :: Int -> Int -> Int +clunky2 a b | x <- max a b + , x > 5 + = x + | otherwise + = a + b + +-- pattern guards on case epxressions +clunky_case1 :: Int -> Int -> Int +clunky_case1 a b = + case unit of + unit | x <- max a b + , x > 5 + -> x + | otherwise -> a + b + +-- test indentation +clunky_case2 :: Int -> Int -> Int +clunky_case2 a b = + case unit of + unit + | x <- max a b + , x > 5 + -> x + | otherwise + -> a + b + main = log $ min "Done" "ZZZZ" diff --git a/examples/warning/ShadowedBinderPatternGuard.purs b/examples/warning/ShadowedBinderPatternGuard.purs new file mode 100644 index 0000000000..f4bb85d938 --- /dev/null +++ b/examples/warning/ShadowedBinderPatternGuard.purs @@ -0,0 +1,7 @@ +-- @shouldWarnWith ShadowedName +module Main where + +f :: Int -> Int +f n | i <- true -- this i is shadowed + , i <- 1234 + = i \ No newline at end of file diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index c7c7d12c1f..a75d2a0d0c 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -81,3 +81,11 @@ binderNames = go [] lit ns (ObjectLiteral bs) = foldl go ns (map snd bs) lit ns (ArrayLiteral bs) = foldl go ns bs lit ns _ = ns + +isIrrefutable :: Binder -> Bool +isIrrefutable NullBinder = True +isIrrefutable (VarBinder _) = True +isIrrefutable (PositionedBinder _ _ b) = isIrrefutable b +isIrrefutable (TypedBinder _ b) = isIrrefutable b +isIrrefutable _ = False + diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 2df2ea1766..2c6e80de4b 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -391,7 +391,7 @@ data Declaration -- | -- A value declaration (name, top-level binders, optional guard, value) -- - | ValueDeclaration Ident NameKind [Binder] (Either [(Guard, Expr)] Expr) + | ValueDeclaration Ident NameKind [Binder] [GuardedExpr] -- | -- A minimal mutually recursive set of value declarations -- @@ -553,7 +553,18 @@ flattenDecls = concatMap flattenOne -- | -- A guard is just a boolean-valued expression that appears alongside a set of binders -- -type Guard = Expr +data Guard = ConditionGuard Expr + | PatternGuard Binder Expr + deriving (Show) + +-- | +-- The right hand side of a binder in value declarations +-- and case expressions. +data GuardedExpr = GuardedExpr [Guard] Expr + deriving (Show) + +pattern MkUnguarded :: Expr -> GuardedExpr +pattern MkUnguarded e = GuardedExpr [] e -- | -- Data type for expressions and terms @@ -685,7 +696,7 @@ data CaseAlternative = CaseAlternative -- | -- The result expression or a collect of guarded expressions -- - , caseAlternativeResult :: Either [(Guard, Expr)] Expr + , caseAlternativeResult :: [GuardedExpr] } deriving (Show) -- | @@ -745,3 +756,11 @@ newtype AssocList k t = AssocList { runAssocList :: [(k, t)] } $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType) + +isTrueExpr :: Expr -> Bool +isTrueExpr (Literal (BooleanLiteral True)) = True +isTrueExpr (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True +isTrueExpr (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True +isTrueExpr (TypedValue _ e _) = isTrueExpr e +isTrueExpr (PositionedValue _ _ e) = isTrueExpr e +isTrueExpr _ = False diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 169bd679b4..11a05f862e 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -6,7 +6,6 @@ module Language.PureScript.AST.Traversals where import Prelude.Compat import Control.Monad -import Control.Arrow ((***), (+++)) import Data.Foldable (fold) import Data.List (mapAccumL) @@ -21,6 +20,21 @@ import Language.PureScript.Names import Language.PureScript.Traversals import Language.PureScript.Types +guardedExprM :: Applicative m + => (Guard -> m Guard) + -> (Expr -> m Expr) + -> GuardedExpr + -> m GuardedExpr +guardedExprM f g (GuardedExpr guards rhs) = + GuardedExpr <$> traverse f guards <*> g rhs + +mapGuardedExpr :: (Guard -> Guard) + -> (Expr -> Expr) + -> GuardedExpr + -> GuardedExpr +mapGuardedExpr f g (GuardedExpr guards rhs) = + GuardedExpr (map f guards) (g rhs) + everywhereOnValues :: (Declaration -> Declaration) -> (Expr -> Expr) @@ -33,7 +47,7 @@ everywhereOnValues f g h = (f', g', h') where f' :: Declaration -> Declaration f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds)) - f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val)) + f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) (map (mapGuardedExpr handleGuard g') val)) f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds)) f' (TypeClassDeclaration name args implies deps ds) = f (TypeClassDeclaration name args implies deps (map f' ds)) f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (mapTypeInstanceBody (map f') ds)) @@ -77,7 +91,7 @@ everywhereOnValues f g h = (f', g', h') handleCaseAlternative :: CaseAlternative -> CaseAlternative handleCaseAlternative ca = ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca) - , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca) + , caseAlternativeResult = map (mapGuardedExpr handleGuard g') (caseAlternativeResult ca) } handleDoNotationElement :: DoNotationElement -> DoNotationElement @@ -86,6 +100,10 @@ everywhereOnValues f g h = (f', g', h') handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds) handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e) + handleGuard :: Guard -> Guard + handleGuard (ConditionGuard e) = ConditionGuard (g' e) + handleGuard (PatternGuard b e) = PatternGuard (h' b) (g' e) + everywhereOnValuesTopDownM :: forall m . (Monad m) @@ -101,7 +119,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds - f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val + f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds f' (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f' <=< f) ds f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds @@ -146,7 +164,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse (h' <=< h) bs - <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val + <*> traverse (guardedExprM handleGuard (g' <=< g)) val handleDoNotationElement :: DoNotationElement -> m DoNotationElement handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v @@ -154,6 +172,10 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e + handleGuard :: Guard -> m Guard + handleGuard (ConditionGuard e) = ConditionGuard <$> (g' <=< g) e + handleGuard (PatternGuard b e) = PatternGuard <$> (h' <=< h) b <*> (g' <=< g) e + everywhereOnValuesM :: forall m . (Monad m) @@ -169,7 +191,7 @@ everywhereOnValuesM f g h = (f', g', h') f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f - f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f + f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val) >>= f f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f f' (TypeClassDeclaration name args implies deps ds) = (TypeClassDeclaration name args implies deps <$> traverse f' ds) >>= f f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f @@ -214,7 +236,7 @@ everywhereOnValuesM f g h = (f', g', h') handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse h' bs - <*> eitherM (traverse (pairM g' g')) g' val + <*> traverse (guardedExprM handleGuard g') val handleDoNotationElement :: DoNotationElement -> m DoNotationElement handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v @@ -222,6 +244,10 @@ everywhereOnValuesM f g h = (f', g', h') handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e + handleGuard :: Guard -> m Guard + handleGuard (ConditionGuard e) = ConditionGuard <$> g' e + handleGuard (PatternGuard b e) = PatternGuard <$> h' b <*> g' e + everythingOnValues :: forall r . (r -> r -> r) @@ -241,8 +267,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') f' :: Declaration -> r f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds) - f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val - f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs) + f' d@(ValueDeclaration _ _ bs val) = foldl (<>) (f d) (map h' bs ++ concatMap (\(GuardedExpr grd v) -> map k' grd ++ [g' v]) val) f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds) f' d@(TypeClassDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds) f' d@(TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (map f' ds) @@ -284,8 +309,8 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') lit r _ _ = r i' :: CaseAlternative -> r - i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val - i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs) + i' ca@(CaseAlternative bs gs) = + foldl (<>) (i ca) (map h' bs ++ concatMap (\(GuardedExpr grd val) -> map k' grd ++ [g' val]) gs) j' :: DoNotationElement -> r j' e@(DoNotationValue v) = j e <> g' v @@ -293,6 +318,10 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds) j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1 + k' :: Guard -> r + k' (ConditionGuard e) = g' e + k' (PatternGuard b e) = h' b <> g' e + everythingWithContextOnValues :: forall s r . s @@ -316,8 +345,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' f' :: s -> Declaration -> r f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds) - f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val - f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs) + f' s (ValueDeclaration _ _ bs val) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(GuardedExpr grd v) -> map (k' s) grd ++ [g'' s v]) val) f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds) f' s (TypeClassDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds) f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (map (f'' s) ds) @@ -368,8 +396,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' i'' s ca = let (s', r) = i s ca in r <> i' s' ca i' :: s -> CaseAlternative -> r - i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val - i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs) + i' s (CaseAlternative bs gs) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(GuardedExpr grd val) -> map (k' s) grd ++ [g'' s val]) gs) j'' :: s -> DoNotationElement -> r j'' s e = let (s', r) = j s e in r <> j' s' e @@ -380,6 +407,10 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds) j' s (PositionedDoNotationElement _ _ e1) = j'' s e1 + k' :: s -> Guard -> r + k' s (ConditionGuard e) = g'' s e + k' s (PatternGuard b e) = h'' s b <> g'' s e + everywhereWithContextOnValuesM :: forall m s . (Monad m) @@ -393,13 +424,14 @@ everywhereWithContextOnValuesM , Expr -> m Expr , Binder -> m Binder , CaseAlternative -> m CaseAlternative - , DoNotationElement -> m DoNotationElement) + , DoNotationElement -> m DoNotationElement + ) everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0) where f'' s = uncurry f' <=< f s f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds - f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val + f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds f' s (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f'' s) ds f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds @@ -444,7 +476,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j i'' s = uncurry i' <=< i s - i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val + i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val j'' s = uncurry j' <=< j s @@ -453,6 +485,9 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1 + k' s (ConditionGuard e) = ConditionGuard <$> g'' s e + k' s (PatternGuard b e) = PatternGuard <$> h'' s b <*> g'' s e + everythingWithScope :: forall r . (Monoid r) @@ -479,14 +514,10 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) f' s (DataBindingGroupDeclaration ds) = let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds)) in foldMap (f'' s') ds - f' s (ValueDeclaration name _ bs (Right val)) = + f' s (ValueDeclaration name _ bs val) = let s' = S.insert name s s'' = S.union s' (S.fromList (concatMap binderNames bs)) - in foldMap (h'' s') bs <> g'' s'' val - f' s (ValueDeclaration name _ bs (Left gs)) = - let s' = S.insert name s - s'' = S.union s' (S.fromList (concatMap binderNames bs)) - in foldMap (h'' s') bs <> foldMap (\(grd, val) -> g'' s'' grd <> g'' s'' val) gs + in foldMap (h'' s') bs <> foldMap (l' s'') val f' s (BindingGroupDeclaration ds) = let s' = S.union s (S.fromList (map (\(name, _, _) -> name) ds)) in foldMap (\(_, _, val) -> g'' s' val) ds @@ -546,12 +577,9 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) i'' s a = i s a <> i' s a i' :: S.Set Ident -> CaseAlternative -> r - i' s (CaseAlternative bs (Right val)) = + i' s (CaseAlternative bs gs) = let s' = S.union s (S.fromList (concatMap binderNames bs)) - in foldMap (h'' s) bs <> g'' s' val - i' s (CaseAlternative bs (Left gs)) = - let s' = S.union s (S.fromList (concatMap binderNames bs)) - in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs + in foldMap (h'' s) bs <> foldMap (l' s') gs j'' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r) j'' s a = let (s', r) = j' s a in (s', j s a <> r) @@ -566,6 +594,17 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) in (s', foldMap (f'' s') ds) j' s (PositionedDoNotationElement _ _ e1) = j'' s e1 + k' :: S.Set Ident -> Guard -> (S.Set Ident, r) + k' s (ConditionGuard e) = (s, g'' s e) + k' s (PatternGuard b e) = + let s' = S.union (S.fromList (binderNames b)) s + in (s', h'' s b <> g'' s' e) + + l' s (GuardedExpr [] e) = g'' s e + l' s (GuardedExpr (grd:gs) e) = + let (s', r) = k' s grd + in r <> l' s' (GuardedExpr gs e) + getDeclIdent :: Declaration -> Maybe Ident getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d getDeclIdent (ValueDeclaration ident _ _ _) = Just ident @@ -642,4 +681,3 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' g (TypedValue checkTy val t) = TypedValue checkTy val (f t) g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints g other = other - diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 2631d62bda..b0ecfd10ee 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -9,7 +9,7 @@ module Language.PureScript.CodeGen.JS import Prelude.Compat -import Control.Arrow ((&&&)) +import Control.Arrow ((&&&), second) import Control.Monad (forM, replicateM, void) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, asks) @@ -375,10 +375,26 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = valueError s _ = accessorString "name" . accessorString "constructor" $ JSVar Nothing s guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS] - guardsToJs (Left gs) = forM gs $ \(cond, val) -> do - cond' <- valueToJs cond - done <- valueToJs val - return $ JSIfElse Nothing cond' (JSBlock Nothing [JSReturn Nothing done]) Nothing + guardsToJs (Left gs) = snd <$> F.foldrM genGuard (False, []) gs + where + genGuard (cond, val) (False, js) = second (: js) <$> genCondVal cond val + genGuard _ x = pure x + + genCondVal cond val + | condIsTrue cond = do + js <- JSReturn Nothing <$> valueToJs val + return (True, js) + | otherwise = do + cond' <- valueToJs cond + val' <- valueToJs val + return + (False, JSIfElse Nothing cond' + (JSBlock Nothing [JSReturn Nothing val']) Nothing) + + -- hopefully the inliner did its job and inlined `otherwise` + condIsTrue (Literal _ (BooleanLiteral True)) = True + condIsTrue _ = False + guardsToJs (Right v) = return . JSReturn Nothing <$> valueToJs v binderToJs :: Text -> [JS] -> Binder Ann -> m [JS] diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index d02657cdc0..ec0664560e 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -2,7 +2,7 @@ module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where import Prelude.Compat -import Control.Arrow (second, (***)) +import Control.Arrow (second) import Data.Function (on) import Data.List (sort, sortBy, nub) @@ -70,7 +70,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor) in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds - declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) = + declToCoreFn ss com (A.ValueDeclaration name _ _ [A.MkUnguarded e]) = [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] declToCoreFn ss _ (A.BindingGroupDeclaration ds) = [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds] @@ -132,9 +132,17 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = altToCoreFn :: Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs) where - go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann) - go (Left ges) = Left $ map (exprToCoreFn ss [] Nothing *** exprToCoreFn ss [] Nothing) ges - go (Right e) = Right (exprToCoreFn ss [] Nothing e) + go :: [A.GuardedExpr] -> Either [(Guard Ann, Expr Ann)] (Expr Ann) + go [A.MkUnguarded e] + = Right (exprToCoreFn ss [] Nothing e) + go gs + = Left [ (exprToCoreFn ss [] Nothing cond, exprToCoreFn ss [] Nothing e) + | A.GuardedExpr g e <- gs + , let cond = guardToExpr g + ] + + guardToExpr [A.ConditionGuard cond] = cond + guardToExpr _ = internalError "Guard not correctly desugared" -- | -- Desugars case binders from AST to CoreFn representation. diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 9e071269c9..84b0b62d2d 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -99,7 +99,7 @@ basicDeclaration :: Text -> DeclarationInfo -> Maybe IntermediateDeclaration basicDeclaration title info = Just $ Right $ mkDeclaration title info convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration -convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title = +convertDeclaration (P.ValueDeclaration _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title = basicDeclaration title (ValueDeclaration ty) convertDeclaration P.ValueDeclaration{} title = -- If no explicit type declaration was provided, insert a wildcard, so that diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 3b53646747..5746781922 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -50,7 +50,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"])) eval = P.Var (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval")) mainValue = P.App eval (P.Var (P.Qualified Nothing (P.Ident "it"))) - itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val + itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] [P.MkUnguarded val] typeDecl = P.TypeDeclaration (P.Ident "$main") (P.TypeApp (P.TypeApp @@ -58,7 +58,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi (P.Qualified (Just (P.ModuleName [P.ProperName "$Eff"])) (P.ProperName "Eff"))) (P.TypeWildcard internalSpan)) (P.TypeWildcard internalSpan)) - mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue + mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] internalSpan = P.internalModuleSourceSpan "" in diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 25c5bec1ee..a747996306 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -202,17 +202,17 @@ missingCasesMultiple env mn = go -- The function below say whether or not a guard has an `otherwise` expression -- It is considered that `otherwise` is defined in Prelude -- -isExhaustiveGuard :: Either [(Guard, Expr)] Expr -> Bool -isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs +isExhaustiveGuard :: [GuardedExpr] -> Bool +isExhaustiveGuard [GuardedExpr [] _] = True +isExhaustiveGuard gs = + not . null $ filter (\(GuardedExpr grd _) -> isExhaustive grd) gs where - isOtherwise :: Expr -> Bool - isOtherwise (Literal (BooleanLiteral True)) = True - isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True - isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True - isOtherwise (TypedValue _ e _) = isOtherwise e - isOtherwise (PositionedValue _ _ e) = isOtherwise e - isOtherwise _ = False -isExhaustiveGuard (Right _) = True + checkGuard :: Guard -> Bool + checkGuard (ConditionGuard cond) = isTrueExpr cond + checkGuard (PatternGuard bind _) = isIrrefutable bind + + isExhaustive :: [Guard] -> Bool + isExhaustive = all checkGuard -- | -- Returns the uncovered set of case alternatives @@ -288,11 +288,13 @@ checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step ( where partial :: Text -> Text -> Declaration partial var tyVar = - ValueDeclaration (Ident C.__unused) Private [] $ Right $ - TypedValue - True - (Abs (Left (Ident var)) (Var (Qualified Nothing (Ident var)))) - (ty tyVar) + ValueDeclaration (Ident C.__unused) Private [] $ + [MkUnguarded + (TypedValue + True + (Abs (Left (Ident var)) (Var (Qualified Nothing (Ident var)))) + (ty tyVar)) + ] ty :: Text -> Type ty tyVar = @@ -321,7 +323,7 @@ checkExhaustiveExpr env mn = onExpr where onDecl :: Declaration -> m Declaration onDecl (BindingGroupDeclaration bs) = BindingGroupDeclaration <$> mapM (thirdM onExpr) bs - onDecl (ValueDeclaration name x y (Right e)) = ValueDeclaration name x y . Right <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr e) + onDecl (ValueDeclaration name x y [MkUnguarded e]) = ValueDeclaration name x y . mkUnguardedExpr <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr e) onDecl (PositionedDeclaration pos x dec) = PositionedDeclaration pos x <$> censor (addHint (PositionedError pos)) (onDecl dec) onDecl decl = return decl @@ -344,5 +346,10 @@ checkExhaustiveExpr env mn = onExpr onExpr expr = return expr onCaseAlternative :: CaseAlternative -> m CaseAlternative - onCaseAlternative (CaseAlternative x (Left es)) = CaseAlternative x . Left <$> mapM (\(e, g) -> (,) <$> onExpr e <*> onExpr g) es - onCaseAlternative (CaseAlternative x (Right e)) = CaseAlternative x . Right <$> onExpr e + onCaseAlternative (CaseAlternative x [MkUnguarded e]) = CaseAlternative x . mkUnguardedExpr <$> onExpr e + onCaseAlternative (CaseAlternative x es) = CaseAlternative x <$> mapM onGuardedExpr es + + onGuardedExpr :: GuardedExpr -> m GuardedExpr + onGuardedExpr (GuardedExpr guard rhs) = GuardedExpr guard <$> onExpr rhs + + mkUnguardedExpr = pure . MkUnguarded diff --git a/src/Language/PureScript/Parser.hs b/src/Language/PureScript/Parser.hs index 69dfd67cdc..c7ac55a3dd 100644 --- a/src/Language/PureScript/Parser.hs +++ b/src/Language/PureScript/Parser.hs @@ -1,23 +1,23 @@ --- | --- A collection of parsers for core data types: --- --- [@Language.PureScript.Parser.Kinds@] Parser for kinds --- --- [@Language.PureScript.Parser.Values@] Parser for values --- --- [@Language.PureScript.Parser.Types@] Parser for types --- --- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules --- --- [@Language.PureScript.Parser.State@] Parser state, including indentation --- --- [@Language.PureScript.Parser.Common@] Common parsing utility functions --- -module Language.PureScript.Parser (module P) where - -import Language.PureScript.Parser.Common as P -import Language.PureScript.Parser.Declarations as P -import Language.PureScript.Parser.Kinds as P -import Language.PureScript.Parser.Lexer as P -import Language.PureScript.Parser.State as P -import Language.PureScript.Parser.Types as P +-- | +-- A collection of parsers for core data types: +-- +-- [@Language.PureScript.Parser.Kinds@] Parser for kinds +-- +-- [@Language.PureScript.Parser.Values@] Parser for values +-- +-- [@Language.PureScript.Parser.Types@] Parser for types +-- +-- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules +-- +-- [@Language.PureScript.Parser.State@] Parser state, including indentation +-- +-- [@Language.PureScript.Parser.Common@] Common parsing utility functions +-- +module Language.PureScript.Parser (module P) where + +import Language.PureScript.Parser.Common as P +import Language.PureScript.Parser.Declarations as P +import Language.PureScript.Parser.Kinds as P +import Language.PureScript.Parser.Lexer as P +import Language.PureScript.Parser.State as P +import Language.PureScript.Parser.Types as P diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 3ddd4fae40..8d3a7e3364 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -67,11 +67,12 @@ parseValueDeclaration :: TokenParser Declaration parseValueDeclaration = do name <- parseIdent binders <- P.many parseBinderNoParens - value <- Left <$> (indented *> - P.many1 ((,) <$> parseGuard - <*> (indented *> equals *> parseValueWithWhereClause) - )) - <|> Right <$> (indented *> equals *> parseValueWithWhereClause) + value <- indented *> ( + (\v -> [MkUnguarded v]) <$> (equals *> parseValueWithWhereClause) <|> + P.many1 (GuardedExpr <$> parseGuard + <*> (indented *> equals + *> parseValueWithWhereClause)) + ) return $ ValueDeclaration name Public binders value where parseValueWithWhereClause :: TokenParser Expr @@ -346,11 +347,13 @@ parseCase = Case <$> P.between (reserved "case") (indented *> reserved "of") (co parseCaseAlternative :: TokenParser CaseAlternative parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder - <*> (Left <$> (indented *> - P.many1 ((,) <$> parseGuard - <*> (indented *> rarrow *> parseValue) - )) - <|> Right <$> (indented *> rarrow *> parseValue)) + <*> (indented *> ( + (pure . MkUnguarded) <$> (rarrow *> parseValue) + <|> (P.many1 (GuardedExpr <$> parseGuard + <*> (indented + *> rarrow + *> parseValue) + )))) P. "case alternative" parseIfThenElse :: TokenParser Expr @@ -565,5 +568,11 @@ parseBinderNoParens = P.choice ] P. "binder" -- | Parse a guard -parseGuard :: TokenParser Guard -parseGuard = pipe *> indented *> parseValue +parseGuard :: TokenParser [Guard] +parseGuard = + pipe *> indented *> P.sepBy1 (parsePatternGuard <|> parseConditionGuard) comma + where + parsePatternGuard = + PatternGuard <$> P.try (parseBinder <* indented <* larrow) <*> parseValue + parseConditionGuard = + ConditionGuard <$> parseValue diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 4cff7ee16e..0f0a83cb99 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -125,12 +125,12 @@ prettyPrintDeclaration :: Int -> Declaration -> Box prettyPrintDeclaration d _ | d < 0 = ellipsis prettyPrintDeclaration _ (TypeDeclaration ident ty) = text (T.unpack (showIdent ident) ++ " :: ") <> typeAsBox ty -prettyPrintDeclaration d (ValueDeclaration ident _ [] (Right val)) = +prettyPrintDeclaration d (ValueDeclaration ident _ [] [GuardedExpr [] val]) = text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val prettyPrintDeclaration d (BindingGroupDeclaration ds) = vsep 1 left (map (prettyPrintDeclaration (d - 1) . toDecl) ds) where - toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e) + toDecl (nm, t, e) = ValueDeclaration nm t [] [GuardedExpr [] e] prettyPrintDeclaration d (PositionedDeclaration _ _ decl) = prettyPrintDeclaration d decl prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration" @@ -139,18 +139,19 @@ prettyPrintCaseAlternative d _ | d < 0 = ellipsis prettyPrintCaseAlternative d (CaseAlternative binders result) = text (T.unpack (T.unwords (map prettyPrintBinderAtom binders))) <> prettyPrintResult result where - prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box - prettyPrintResult (Left gs) = + prettyPrintResult :: [GuardedExpr] -> Box + prettyPrintResult [GuardedExpr [] v] = text " -> " <> prettyPrintValue (d - 1) v + prettyPrintResult gs = vcat left (map prettyPrintGuardedValue gs) - prettyPrintResult (Right v) = text " -> " <> prettyPrintValue (d - 1) v - prettyPrintGuardedValue :: (Guard, Expr) -> Box - prettyPrintGuardedValue (grd, val) = foldl1 before + prettyPrintGuardedValue :: GuardedExpr -> Box + prettyPrintGuardedValue (GuardedExpr [ConditionGuard grd] val) = foldl1 before [ text " | " , prettyPrintValue (d - 1) grd , text " -> " , prettyPrintValue (d - 1) val ] + prettyPrintGuardedValue _ = internalError "There should only be ConditionGuards after desugaring cases" prettyPrintDoNotationElement :: Int -> DoNotationElement -> Box prettyPrintDoNotationElement d _ | d < 0 = ellipsis diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 0a1d27270f..b110b05b8d 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -65,3 +65,4 @@ desugar externs = >=> traverse (deriveInstances externs) >=> desugarTypeClasses externs >=> traverse createBindingGroupsModule + diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 4d0d7a5676..9c77adca10 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -92,7 +92,8 @@ collapseBindingGroups = where go (DataBindingGroupDeclaration ds) = ds go (BindingGroupDeclaration ds) = - map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds + map (\(ident, nameKind, val) -> + ValueDeclaration ident nameKind [] [MkUnguarded val]) ds go (PositionedDeclaration pos com d) = map (PositionedDeclaration pos com) $ go d go other = [other] @@ -106,7 +107,7 @@ usedIdents moduleName = nub . usedIdents' S.empty . getValue where def _ _ = [] - getValue (ValueDeclaration _ _ [] (Right val)) = val + getValue (ValueDeclaration _ _ [] [MkUnguarded val]) = val getValue ValueDeclaration{} = internalError "Binders should have been desugared" getValue (PositionedDeclaration _ _ d) = getValue d getValue _ = internalError "Expected ValueDeclaration" @@ -195,7 +196,7 @@ toBindingGroup moduleName (CyclicSCC ds') = cycleError :: Declaration -> MultipleErrors cycleError (PositionedDeclaration p _ d) = onErrorMessages (withPosition p) $ cycleError d - cycleError (ValueDeclaration n _ _ (Right _)) = errorMessage $ CycleInDeclaration n + cycleError (ValueDeclaration n _ _ [MkUnguarded _]) = errorMessage $ CycleInDeclaration n cycleError _ = internalError "cycleError: Expected ValueDeclaration" toDataBindingGroup @@ -216,7 +217,7 @@ isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d isTypeSynonym _ = Nothing fromValueDecl :: Declaration -> (Ident, NameKind, Expr) -fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val) +fromValueDecl (ValueDeclaration ident nameKind [] [MkUnguarded val]) = (ident, nameKind, val) fromValueDecl ValueDeclaration{} = internalError "Binders should have been desugared" fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d fromValueDecl _ = internalError "Expected ValueDeclaration" diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 717b41859a..7c30149831 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -9,11 +9,10 @@ module Language.PureScript.Sugar.CaseDeclarations import Prelude.Compat -import Data.Either (isLeft) import Data.List (nub, groupBy, foldl1') import Data.Maybe (catMaybes, mapMaybe) -import Control.Monad ((<=<), replicateM, join, unless) +import Control.Monad ((<=<), forM, replicateM, join, unless) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class @@ -22,7 +21,6 @@ import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Names -import Language.PureScript.Traversals import Language.PureScript.TypeChecker.Monad (guardWith) -- | @@ -38,6 +36,222 @@ desugarCasesModule (Module ss coms name ds exps) = <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps +-- | +-- Desugar case with pattern guards and pattern clauses to a +-- series of nested case expressions. +-- +desugarCase :: forall m. (MonadSupply m) + => Expr + -> m Expr +desugarCase (Case scrut alternatives) + | any (not . isTrivialExpr) scrut = do + -- in case the scrutinee is non trivial (e.g. not a Var or Literal) + -- we may evaluate the scrutinee more than once when a guard occurrs. + -- We bind the scrutinee to Vars here to mitigate this case. + (scrut', scrut_decls) <- unzip <$> forM scrut (\e -> do + scrut_id <- freshIdent' + pure ( Var (Qualified Nothing scrut_id) + , ValueDeclaration scrut_id Private [] [MkUnguarded e] + ) + ) + Let scrut_decls <$> desugarCase (Case scrut' alternatives) + where + isTrivialExpr (Var _) = True + isTrivialExpr (Literal _) = True + isTrivialExpr (Accessor _ e) = isTrivialExpr e + isTrivialExpr (Parens e) = isTrivialExpr e + isTrivialExpr (PositionedValue _ _ e) = isTrivialExpr e + isTrivialExpr _ = False + +desugarCase (Case scrut alternatives) = + let + -- Alternatives which do not have guards are + -- left as-is. Alternatives which + -- + -- 1) have multiple clauses of the form + -- binder | g_1 + -- , g_2 + -- , ... + -- , g_n + -- -> expr + -- + -- 2) and/or contain pattern guards of the form + -- binder | pat_bind <- e + -- , ... + -- + -- are desugared to a sequence of nested case expressions. + -- + -- Consider an example case expression: + -- + -- case e of + -- (T s) | Just info <- Map.lookup s names + -- , is_used info + -- -> f info + -- + -- We desugar this to + -- + -- case e of + -- (T s) -> case Map.lookup s names of + -- Just info -> case is_used info of + -- True -> f info + -- (_ -> ) + -- (_ -> ) + -- + -- Note that if the original case is partial the desugared + -- case is also partial. + -- + -- Consider an exhaustive case expression: + -- + -- case e of + -- (T s) | Just info <- Map.lookup s names + -- , is_used info + -- -> f info + -- _ -> Nothing + -- + -- desugars to: + -- + -- case e of + -- _ -> let + -- v _ = Nothing + -- in + -- case e of + -- (T s) -> case Map.lookup s names of + -- Just info -> f info + -- _ -> v true + -- _ -> v true + -- + -- This might look strange but simplifies the algorithm a lot. + -- + desugarAlternatives :: [CaseAlternative] + -> m [CaseAlternative] + desugarAlternatives [] = pure [] + + -- the trivial case: no guards + desugarAlternatives (a@(CaseAlternative _ [MkUnguarded _]) : as) = + (a :) <$> desugarAlternatives as + + -- Special case: CoreFn understands single condition guards on + -- binders right hand side. + desugarAlternatives (CaseAlternative ab ge : as) + | not (null cond_guards) = + (CaseAlternative ab cond_guards :) + <$> desugarGuardedAlternative ab rest as + | otherwise = desugarGuardedAlternative ab ge as + where + (cond_guards, rest) = span isSingleCondGuard ge + + isSingleCondGuard (GuardedExpr [ConditionGuard _] _) = True + isSingleCondGuard _ = False + + desugarGuardedAlternative :: [Binder] + -> [GuardedExpr] + -> [CaseAlternative] + -> m [CaseAlternative] + desugarGuardedAlternative _vb [] rem_alts = + desugarAlternatives rem_alts + + desugarGuardedAlternative vb (GuardedExpr gs e : ge) rem_alts = do + rhs <- desugarAltOutOfLine vb ge rem_alts $ \alt_fail -> + let + -- if the binder is a var binder we must not add + -- the fail case as it results in unreachable + -- alternative + alt_fail' | all isIrrefutable vb = [] + | otherwise = alt_fail + + + -- we are here: + -- + -- case scrut of + -- ... + -- _ -> let + -- v _ = + -- in case scrut of -- we are here + -- ... + -- + in Case scrut + (CaseAlternative vb [MkUnguarded (desugarGuard gs e alt_fail)] + : alt_fail') + + return [ CaseAlternative scrut_nullbinder [MkUnguarded rhs]] + + desugarGuard :: [Guard] -> Expr -> [CaseAlternative] -> Expr + desugarGuard [] e _ = e + desugarGuard (ConditionGuard c : gs) e match_failed + | isTrueExpr c = desugarGuard gs e match_failed + | otherwise = + Case [c] + (CaseAlternative [LiteralBinder (BooleanLiteral True)] + [MkUnguarded (desugarGuard gs e match_failed)] : match_failed) + + desugarGuard (PatternGuard vb g : gs) e match_failed = + Case [g] + (CaseAlternative [vb] [MkUnguarded (desugarGuard gs e match_failed)] + : match_failed') + where + -- don't consider match_failed case if the binder is irrefutable + match_failed' | isIrrefutable vb = [] + | otherwise = match_failed + + -- we generate a let-binding for the remaining guards + -- and alternatives. A CaseAlternative is passed (or in + -- fact the original case is partial non is passed) to + -- mk_body which branches to the generated let-binding. + desugarAltOutOfLine :: [Binder] + -> [GuardedExpr] + -> [CaseAlternative] + -> ([CaseAlternative] -> Expr) + -> m Expr + desugarAltOutOfLine alt_binder rem_guarded rem_alts mk_body + | Just rem_case <- mkCaseOfRemainingGuardsAndAlts = do + + desugared <- desugarCase rem_case + rem_case_id <- freshIdent' + + let + goto_rem_case :: Expr + goto_rem_case = Var (Qualified Nothing rem_case_id) + `App` Literal (BooleanLiteral True) + alt_fail = [CaseAlternative [NullBinder] [MkUnguarded goto_rem_case]] + + pure $ Let [ + ValueDeclaration rem_case_id Private [NullBinder] + [MkUnguarded desugared] + ] (mk_body alt_fail) + + | otherwise + = pure $ mk_body [] + where + mkCaseOfRemainingGuardsAndAlts + | not (null rem_guarded) + = Just $ Case scrut (CaseAlternative alt_binder rem_guarded : rem_alts) + | not (null rem_alts) + = Just $ Case scrut rem_alts + | otherwise + = Nothing + + scrut_nullbinder :: [Binder] + scrut_nullbinder = replicate (length scrut) NullBinder + + -- case expressions with a single alternative which have + -- a NullBinder occur frequently after desugaring + -- complex guards. This function removes these superflous + -- cases. + optimize :: Expr -> Expr + optimize (Case _ [CaseAlternative vb [MkUnguarded v]]) + | all isNullBinder vb = v + where + isNullBinder NullBinder = True + isNullBinder (PositionedBinder _ _ b) = isNullBinder b + isNullBinder (TypedBinder _ b) = isNullBinder b + isNullBinder _ = False + optimize e = e + in do + alts' <- desugarAlternatives alternatives + return $ optimize (Case scrut alts') + +desugarCase v = pure v + -- | -- Validates that case head and binder lengths match. -- @@ -47,12 +261,12 @@ validateCases = flip parU f (f, _, _) = everywhereOnValuesM return validate return validate :: Expr -> m Expr - validate c@(Case vs alts) = do + validate (Case vs alts) = do let l = length vs alts' = filter ((l /=) . length . caseAlternativeBinders) alts unless (null alts') $ throwError . MultipleErrors $ fmap (altError l) (caseAlternativeBinders <$> alts') - return c + desugarCase (Case vs alts) validate other = return other altError :: Int -> [Binder] -> ErrorMessage @@ -74,7 +288,7 @@ desugarAbs = flip parU f replace :: Expr -> m Expr replace (Abs (Right binder) val) = do ident <- freshIdent' - return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)] + return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded val]] replace other = return other -- | @@ -88,8 +302,7 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro (:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest desugarRest (ValueDeclaration name nameKind bs result : rest) = let (_, f, _) = everywhereOnValuesTopDownM return go return - f' (Left gs) = Left <$> mapM (pairM return f) gs - f' (Right v) = Right <$> f v + f' = mapM (\(GuardedExpr gs e) -> GuardedExpr gs <$> f e) in (:) <$> (ValueDeclaration name nameKind bs <$> f' result) <*> desugarRest rest where go (Let ds val') = Let <$> desugarCases ds <*> pure val' @@ -107,30 +320,27 @@ inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2 inSameGroup _ _ = False toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] -toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do +toDecls [ValueDeclaration ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do args <- mapM fromVarBinder bs let body = foldr (Abs . Left) val args guardWith (errorMessage (OverlappingArgNames (Just ident))) $ length (nub args) == length args - return [ValueDeclaration ident nameKind [] (Right body)] + return [ValueDeclaration ident nameKind [] [MkUnguarded body]] where - isVarBinder :: Binder -> Bool - isVarBinder NullBinder = True - isVarBinder (VarBinder _) = True - isVarBinder (PositionedBinder _ _ b) = isVarBinder b - isVarBinder (TypedBinder _ b) = isVarBinder b - isVarBinder _ = False - fromVarBinder :: Binder -> m Ident fromVarBinder NullBinder = freshIdent' fromVarBinder (VarBinder name) = return name fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b fromVarBinder (TypedBinder _ b) = fromVarBinder b fromVarBinder _ = internalError "fromVarBinder: Invalid argument" -toDecls ds@(ValueDeclaration ident _ bs result : _) = do +toDecls ds@(ValueDeclaration ident _ bs (result : _) : _) = do let tuples = map toTuple ds + + isGuarded (MkUnguarded _) = False + isGuarded _ = True + unless (all ((== length bs) . length . fst) tuples) $ throwError . errorMessage $ ArgListLengthsDiffer ident - unless (not (null bs) || isLeft result) $ + unless (not (null bs) || isGuarded result) $ throwError . errorMessage $ DuplicateValueDeclaration ident caseDecl <- makeCaseDeclaration ident tuples return [caseDecl] @@ -139,12 +349,12 @@ toDecls (PositionedDeclaration pos com d : ds) = do return (PositionedDeclaration pos com d' : ds') toDecls ds = return ds -toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr) +toTuple :: Declaration -> ([Binder], [GuardedExpr]) toTuple (ValueDeclaration _ _ bs result) = (bs, result) toTuple (PositionedDeclaration _ _ d) = toTuple d toTuple _ = internalError "Not a value declaration" -makeCaseDeclaration :: forall m. (MonadSupply m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration +makeCaseDeclaration :: forall m. (MonadSupply m) => Ident -> [([Binder], [GuardedExpr])] -> m Declaration makeCaseDeclaration ident alternatives = do let namedArgs = map findName . fst <$> alternatives argNames = foldl1 resolveNames namedArgs @@ -153,8 +363,10 @@ makeCaseDeclaration ident alternatives = do else replicateM (length argNames) freshIdent' let vars = map (Var . Qualified Nothing) args binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] - value = foldr (Abs . Left) (Case vars binders) args - return $ ValueDeclaration ident Public [] (Right value) + case_ <- desugarCase (Case vars binders) + let value = foldr (Abs . Left) case_ args + + return $ ValueDeclaration ident Public [] [MkUnguarded value] where -- We will construct a table of potential names. -- VarBinders will become Just _ which is a potential name. diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index b80b8e8e60..ddf19112e7 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -56,7 +56,7 @@ desugarDo d = go (DoNotationBind binder val : rest) = do rest' <- go rest ident <- freshIdent' - return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')])) + return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']])) go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet go (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index a0ffbfab18..b07cf65a9a 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -242,8 +242,16 @@ renameInModule imports (Module ss coms mn decls exps) = :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative) - updateCase (pos, bound) c@(CaseAlternative bs _) = - return ((pos, concatMap binderNames bs ++ bound), c) + updateCase (pos, bound) c@(CaseAlternative bs gs) = + return ((pos, concatMap binderNames bs ++ updateGuard gs ++ bound), c) + where + updateGuard :: [GuardedExpr] -> [Ident] + updateGuard [] = [] + updateGuard (GuardedExpr g _ : xs) = + concatMap updatePatGuard g ++ updateGuard xs + where + updatePatGuard (PatternGuard b _) = binderNames b + updatePatGuard _ = [] letBoundVariable :: Declaration -> Maybe Ident letBoundVariable (ValueDeclaration ident _ _ _) = Just ident diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 149939ab13..3f37d8692f 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -70,7 +70,7 @@ desugarDecl other = fn other then Abs (Left val) <$> wrapLambda (buildUpdates valExpr) ps else wrapLambda (buildLet val . buildUpdates valExpr) ps where - buildLet val = Let [ValueDeclaration val Public [] (Right obj)] + buildLet val = Let [ValueDeclaration val Public [] [MkUnguarded obj]] -- recursively build up the nested `ObjectUpdate` expressions buildUpdates :: Expr -> PathTree Expr -> Expr diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index b20a066583..1273b4bf81 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -190,7 +190,7 @@ desugarDecl mn exps = go go d@(TypeInstanceDeclaration name deps className tys (NewtypeInstanceWithDictionary dict)) = do let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy) - return (expRef name className tys, [d, ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))]) + return (expRef name className tys, [d, ValueDeclaration name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) go (PositionedDeclaration pos com d) = do (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d return (dr, map (PositionedDeclaration pos com) ds) @@ -252,9 +252,11 @@ typeClassMemberToDictionaryAccessor -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) = let className = Qualified (Just mn) name - in ValueDeclaration ident Private [] $ Right $ - TypedValue False (TypeClassDictionaryAccessor className ident) $ - moveQuantifiersToFront (quantify (ConstrainedType [Constraint className (map (TypeVar . fst) args) Nothing] ty)) + in ValueDeclaration ident Private [] $ + [MkUnguarded ( + TypedValue False (TypeClassDictionaryAccessor className ident) $ + moveQuantifiersToFront (quantify (ConstrainedType [Constraint className (map (TypeVar . fst) args) Nothing] ty)) + )] typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) = PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" @@ -303,7 +305,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy) dict = TypeClassDictionaryConstructorApp className props - result = ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy)) + result = ValueDeclaration name Private [] [MkUnguarded (TypedValue True dict constrainedTy)] return result where @@ -315,7 +317,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = declName _ = Nothing memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr - memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do + memberToValue tys' (ValueDeclaration ident _ [] [MkUnguarded val]) = do _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys' return val memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 8dbb8ee14f..079bde62fd 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -177,6 +177,9 @@ dataNewtype = ModuleName [ ProperName "Data", ProperName "Newtype" ] dataFunctor :: ModuleName dataFunctor = ModuleName [ ProperName "Data", ProperName "Functor" ] +unguarded :: Expr -> [GuardedExpr] +unguarded e = [MkUnguarded e] + deriveGeneric :: forall m. (MonadError MultipleErrors m, MonadSupply m) => ModuleName @@ -190,9 +193,9 @@ deriveGeneric mn syns ds tyConNm dargs = do toSpine <- mkSpineFunction tyCon fromSpine <- mkFromSpineFunction tyCon let toSignature = mkSignatureFunction tyCon dargs - return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine) - , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine) - , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature) + return [ ValueDeclaration (Ident C.toSpine) Public [] (unguarded toSpine) + , ValueDeclaration (Ident C.fromSpine) Public [] (unguarded fromSpine) + , ValueDeclaration (Ident C.toSignature) Public [] (unguarded toSignature) ] where mkSpineFunction :: Declaration -> m Expr @@ -214,7 +217,7 @@ deriveGeneric mn syns ds tyConNm dargs = do App (prodConstructor (Literal . StringLiteral . mkString . showQualified runProperName $ Qualified (Just mn) ctorName)) . Literal . ArrayLiteral $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys' - return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right caseResult) + return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (unguarded caseResult) toSpineFun :: Expr -> Type -> Expr toSpineFun i r | Just rec <- objectType r = @@ -299,7 +302,7 @@ deriveGeneric mn syns ds tyConNm dargs = do , LiteralBinder (ArrayLiteral (map VarBinder idents)) ] ] - . Right + . unguarded $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName)) (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys) @@ -307,13 +310,13 @@ deriveGeneric mn syns ds tyConNm dargs = do addCatch :: [CaseAlternative] -> [CaseAlternative] addCatch = (++ [catchAll]) where - catchAll = CaseAlternative [NullBinder] (Right mkNothing) + catchAll = CaseAlternative [NullBinder] (unguarded mkNothing) fromSpineFun :: Expr -> Type -> Expr fromSpineFun e r | Just rec <- objectType r = App (lamCase (Ident "r") [ mkRecCase (decomposeRec rec) - , CaseAlternative [NullBinder] (Right mkNothing) + , CaseAlternative [NullBinder] (unguarded mkNothing) ]) (App e unitVal) fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e unitVal) @@ -322,7 +325,7 @@ deriveGeneric mn syns ds tyConNm dargs = do mkRecCase rs = CaseAlternative [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . labelToIdent . fst) rs)) ] ] - . Right + . unguarded $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar $ labelToIdent x)) y) rs) mkRecFun :: [(Label, Type)] -> Expr @@ -366,19 +369,19 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do let rep = toRepTy reps inst | null reps = -- If there are no cases, spin - [ ValueDeclaration (Ident "to") Public [] $ Right $ + [ ValueDeclaration (Ident "to") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] - (Right (App toName (Var (Qualified Nothing x)))) + (unguarded (App toName (Var (Qualified Nothing x)))) ] - , ValueDeclaration (Ident "from") Public [] $ Right $ + , ValueDeclaration (Ident "from") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] - (Right (App fromName (Var (Qualified Nothing x)))) + (unguarded (App fromName (Var (Qualified Nothing x)))) ] ] | otherwise = - [ ValueDeclaration (Ident "to") Public [] $ Right $ + [ ValueDeclaration (Ident "to") Public [] $ unguarded $ lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to) - , ValueDeclaration (Ident "from") Public [] $ Right $ + , ValueDeclaration (Ident "from") Public [] $ unguarded $ lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from) ] @@ -412,9 +415,9 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do (TypeLevelString $ mkString (runProperName ctorName))) ctorTy , CaseAlternative [ ConstructorBinder constructor [matchProduct] ] - (Right (foldl App (Constructor (Qualified (Just mn) ctorName)) ctorArgs)) + (unguarded (foldl App (Constructor (Qualified (Just mn) ctorName)) ctorArgs)) , CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) matchCtor ] - (Right (constructor' mkProduct)) + (unguarded (constructor' mkProduct)) ) makeProduct @@ -464,8 +467,8 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do underBinder f (CaseAlternative bs e) = CaseAlternative (map f bs) e underExpr :: (Expr -> Expr) -> CaseAlternative -> CaseAlternative - underExpr f (CaseAlternative b (Right e)) = CaseAlternative b (Right (f e)) - underExpr _ _ = internalError "underExpr: expected Right" + underExpr f (CaseAlternative b [MkUnguarded e]) = CaseAlternative b (unguarded (f e)) + underExpr _ _ = internalError "underExpr: expected unguarded alternative" toRepTy :: [Type] -> Type toRepTy [] = noCtors @@ -538,7 +541,7 @@ deriveEq :: deriveEq mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds eqFun <- mkEqFunction tyCon - return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ] + return [ ValueDeclaration (Ident C.eq) Public [] (unguarded eqFun) ] where mkEqFunction :: Declaration -> m Expr mkEqFunction (DataDeclaration _ _ _ args) = do @@ -559,7 +562,7 @@ deriveEq mn syns ds tyConNm = do | length xs /= 1 = xs ++ [catchAll] | otherwise = xs -- Avoid redundant case where - catchAll = CaseAlternative [NullBinder, NullBinder] (Right (Literal (BooleanLiteral False))) + catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (Literal (BooleanLiteral False))) mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative mkCtorClause (ctorName, tys) = do @@ -567,7 +570,7 @@ deriveEq mn syns ds tyConNm = do identsR <- replicateM (length tys) (freshIdent "r") tys' <- mapM (replaceAllTypeSynonymsM syns) tys let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys' - return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests)) + return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (unguarded (conjAll tests)) where caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents) @@ -592,7 +595,7 @@ deriveOrd :: deriveOrd mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds compareFun <- mkCompareFunction tyCon - return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ] + return [ ValueDeclaration (Ident C.compare) Public [] (unguarded compareFun) ] where mkCompareFunction :: Declaration -> m Expr mkCompareFunction (DataDeclaration _ _ _ args) = do @@ -612,7 +615,7 @@ deriveOrd mn syns ds tyConNm = do | null xs = [catchAll] -- No type constructors | otherwise = xs where - catchAll = CaseAlternative [NullBinder, NullBinder] (Right (orderingCtor "EQ")) + catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (orderingCtor "EQ")) orderingName :: Text -> Qualified (ProperName a) orderingName = Qualified (Just (ModuleName [ProperName "Data", ProperName "Ordering"])) . ProperName @@ -635,17 +638,17 @@ deriveOrd mn syns ds tyConNm = do extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) , NullBinder ] - (Right (orderingCtor "LT")) + (unguarded (orderingCtor "LT")) , CaseAlternative [ NullBinder , ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) ] - (Right (orderingCtor "GT")) + (unguarded (orderingCtor "GT")) ] | otherwise = [] return $ CaseAlternative [ caseBinder identsL , caseBinder identsR ] - (Right (appendAll tests)) + (unguarded (appendAll tests)) : extras where @@ -655,11 +658,11 @@ deriveOrd mn syns ds tyConNm = do appendAll [] = orderingCtor "EQ" appendAll [x] = x appendAll (x : xs) = Case [x] [ CaseAlternative [orderingBinder "LT"] - (Right (orderingCtor "LT")) + (unguarded (orderingCtor "LT")) , CaseAlternative [orderingBinder "GT"] - (Right (orderingCtor "GT")) + (unguarded (orderingCtor "GT")) , CaseAlternative [ NullBinder ] - (Right (appendAll xs)) + (unguarded (appendAll xs)) ] toOrdering :: Expr -> Expr -> Type -> Expr @@ -693,13 +696,13 @@ deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do let (ctorName, [ty]) = head dctors ty' <- replaceAllTypeSynonymsM syns ty let inst = - [ ValueDeclaration (Ident "wrap") Public [] $ Right $ + [ ValueDeclaration (Ident "wrap") Public [] $ unguarded $ Constructor (Qualified (Just mn) ctorName) - , ValueDeclaration (Ident "unwrap") Public [] $ Right $ + , ValueDeclaration (Ident "unwrap") Public [] $ unguarded $ lamCase wrappedIdent [ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]] - (Right (Var (Qualified Nothing unwrappedIdent))) + (unguarded (Var (Qualified Nothing unwrappedIdent))) ] ] subst = zipWith ((,) . fst) args tyConArgs @@ -768,7 +771,7 @@ deriveFunctor deriveFunctor mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds mapFun <- mkMapFunction tyCon - return [ ValueDeclaration (Ident C.map) Public [] (Right mapFun) ] + return [ ValueDeclaration (Ident C.map) Public [] (unguarded mapFun) ] where mkMapFunction :: Declaration -> m Expr mkMapFunction (DataDeclaration _ _ tys ctors) = case reverse tys of @@ -788,7 +791,7 @@ deriveFunctor mn syns ds tyConNm = do let ctor = Constructor (Qualified (Just mn) ctorName) rebuilt = foldl App ctor args caseBinder = ConstructorBinder (Qualified (Just mn) ctorName) (VarBinder <$> idents) - return $ CaseAlternative [caseBinder] (Right rebuilt) + return $ CaseAlternative [caseBinder] (unguarded rebuilt) where fVar = mkVar f mapVar = mkVarMn (Just dataFunctor) (Ident C.map) diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 5c5e2b3117..f9b09eff81 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -14,7 +14,6 @@ import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Environment import Language.PureScript.Errors -import Language.PureScript.Traversals -- | -- Replace all top level type declarations in a module with type annotations @@ -35,10 +34,10 @@ desugarTypeDeclarationsModule (Module ss coms name ds exps) = return (PositionedDeclaration pos com d' : rest') desugarTypeDeclarations (TypeDeclaration name' ty : d : rest) = do (_, nameKind, val) <- fromValueDeclaration d - desugarTypeDeclarations (ValueDeclaration name' nameKind [] (Right (TypedValue True val ty)) : rest) + desugarTypeDeclarations (ValueDeclaration name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest) where fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr) - fromValueDeclaration (ValueDeclaration name'' nameKind [] (Right val)) + fromValueDeclaration (ValueDeclaration name'' nameKind [] [MkUnguarded val]) | name' == name'' = return (name'', nameKind, val) fromValueDeclaration (PositionedDeclaration pos com d') = do (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d' @@ -49,8 +48,7 @@ desugarTypeDeclarationsModule (Module ss coms name ds exps) = throwError . errorMessage $ OrphanTypeDeclaration name' desugarTypeDeclarations (ValueDeclaration name' nameKind bs val : rest) = do let (_, f, _) = everywhereOnValuesTopDownM return go return - f' (Left gs) = Left <$> mapM (pairM return f) gs - f' (Right v) = Right <$> f v + f' = mapM (\(GuardedExpr g e) -> GuardedExpr g <$> f e) (:) <$> (ValueDeclaration name' nameKind bs <$> f' val) <*> desugarTypeDeclarations rest where diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 36b03c1b3b..3720461515 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -268,14 +268,14 @@ typeCheckAll moduleName _ = traverse go return $ TypeSynonymDeclaration name args ty go TypeDeclaration{} = internalError "Type declarations should have been removed before typeCheckAlld" - go (ValueDeclaration name nameKind [] (Right val)) = do + go (ValueDeclaration name nameKind [] [MkUnguarded val]) = do env <- getEnv warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do val' <- checkExhaustiveExpr env moduleName val valueIsNotDefined moduleName name [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [(name, val')] addValue moduleName name ty nameKind - return $ ValueDeclaration name nameKind [] $ Right val'' + return $ ValueDeclaration name nameKind [] [MkUnguarded val''] go ValueDeclaration{} = internalError "Binders were not desugared" go (BindingGroupDeclaration vals) = do env <- getEnv diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 5536253025..03d5a1fad0 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -404,20 +404,20 @@ inferLetBinding -> (Expr -> m Expr) -> m ([Declaration], Expr) inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) -inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do +inferLetBinding seen (ValueDeclaration ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)] : rest) ret j = do Just moduleName <- checkCurrentModule <$> get (kind, args) <- kindOfWithScopedVars ty checkTypeKind ty kind let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined) ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv - bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j -inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do + bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j +inferLetBinding seen (ValueDeclaration ident nameKind [] [MkUnguarded val] : rest) ret j = do valTy <- freshType let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined) TypedValue _ val' valTy' <- bindNames dict $ infer val unifyTypes valTy valTy' - bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j + bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] [MkUnguarded val']]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do Just moduleName <- checkCurrentModule <$> get SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing (map (\(i, _, v) -> (i, v)) ds) @@ -542,18 +542,28 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do r <- bindLocalVariables [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ CaseAlternative binders <$> case result of - Left gs -> do - gs' <- forM gs $ \(grd, val) -> do - grd' <- withErrorMessageHint ErrorCheckingGuard $ check grd tyBoolean - val' <- TypedValue True <$> check val ret <*> pure ret - return (grd', val') - return $ Left gs' - Right val -> do + [MkUnguarded val] -> do val' <- TypedValue True <$> check val ret <*> pure ret - return $ Right val' + return [MkUnguarded val'] + gs -> forM gs (\ge -> checkGuardedRhs ge ret) rs <- checkBinders nvals ret bs return $ r : rs +checkGuardedRhs + :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => GuardedExpr + -> Type + -> m GuardedExpr +checkGuardedRhs (GuardedExpr [] rhs) ret = do + rhs' <- TypedValue True <$> check rhs ret <*> pure ret + return $ GuardedExpr [] rhs' +checkGuardedRhs (GuardedExpr [ConditionGuard cond] rhs) ret = do + cond' <- withErrorMessageHint ErrorCheckingGuard $ check cond tyBoolean + rhs' <- TypedValue True <$> check rhs ret <*> pure ret + return $ GuardedExpr [ConditionGuard cond'] rhs' +checkGuardedRhs _ _ = + internalError "Pattern not desugared" + -- | -- Check the type of a value, rethrowing errors to provide a better error message -- diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index e680c9977d..6c760aa03e 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -18,7 +18,7 @@ span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3) typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, foreign1, foreign2, foreign3, member1 :: P.Declaration typeAnnotation1 = P.TypeDeclaration (P.Ident "value1") P.REmpty -value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left []) +value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] [] synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty class1 = P.TypeClassDeclaration (P.ProperName "Class1") [] [] [] [] class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] [] From 5c175aa4f155efd8ae7a413ebcf92183b659c7fb Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 9 Feb 2017 09:38:03 -0800 Subject: [PATCH 0663/1580] Compress contributors list (#2645) * Compress contributors list * company table --- CONTRIBUTORS.md | 195 ++++++++++++++++++++++++++---------------------- 1 file changed, 106 insertions(+), 89 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 45057f1ad7..673aa679ea 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -2,96 +2,113 @@ This file lists the contributors to the PureScript compiler project, and the terms under which their code is licensed. -### Individuals +### Contributors using Standard Terms -- [@5outh](https://github.com/5outh) (Benjamin Kovach) - My existing contributions and all future contributions until further notice are Copyright Benjamin Kovach, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. -- [@andreypopp](https://github.com/andreypopp) (Andrey Popp) My existing contributions and all future contributions until further notice are Copyright Andrey Popp, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. -- [@andyarvanitis](https://github.com/andyarvanitis) (Andy Arvanitis) My existing contributions and all future contributions until further notice are Copyright Andy Arvanitis, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@anthok88](https://github.com/anthoq88) - My existing contributions and all future contributions until further notice are Copyright anthoq88, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license -- [@ardumont](https://github.com/ardumont) (Antoine R. Dumont) My existing contributions and all future contributions until further notice are Copyright Antoine R. Dumont, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@aspidites](https://github.com/aspidites) (Edwin Marshall) My existing contributions and all future contributions until further notice are Copyright Edwin Marshall, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@bagl](https://github.com/bagl) (Petr Vapenka) My existing contributions and all future contributions until further notice are Copyright Petr Vapenka, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@balajirrao](https://github.com/balajirrao) (Balaji Rao) - My existing contributions and all future contributions until further notice are Copyright Balaji Rao, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. -- [@bergmark](https://github.com/bergmark) (Adam Bergmark) - My existing contributions and all future contributions until further notice are Copyright Adam Bergmark, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. -- [@bmjames](https://github.com/bmjames) (Ben James) My existing contributions and all future contributions until further notice are Copyright Ben James, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@Bogdanp](https://github.com/Bogdanp) (Bogdan Paul Popa) My existing contributions and all future contributions until further notice are Copyright Bogdan Paul Popa, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@bsermons](https://github.com/bsermons) (Brian Sermons) My existing contributions and all future contributions until further notice are Copyright Brian Sermons, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@cdepillabout](https://github.com/cdepillabout) (Dennis Gosnell) My existing contributions and all future contributions until further notice are Copyright Dennis Gosnell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@charleso](https://github.com/charleso) (Charles O'Farrell) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Charles O'Farrell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@chrisdone](https://github.com/chrisdone) (Chris Done) - My existing contributions and all future contributions until further notice are Copyright Chris Done, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. -- [@chrissmoak](https://github.com/chrissmoak) (Chris Smoak) My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@codedmart](https://github.com/codedmart) (Brandon Martin) My existing contributions and all future contributions until further notice are Copyright Brandon Martin, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@davidchambers](https://github.com/davidchambers) (David Chambers) My existing contributions and all future contributions until further notice are Copyright David Chambers, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@DavidLindbom](https://github.com/DavidLindbom) (David Lindbom) My existing contributions and all future contributions until further notice are Copyright David Lindbom, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@dckc](https://github.com/dckc) (Dan Connolly) My existing contributions and all future contributions until further notice are Copyright Dan Connolly, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@dylex](https://github.com/dylex) (Dylan Simon) My existing and all future contributions to the PureScript compiler until further notice are Copyright Dylan Simon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@eamelink](https://github.com/eamelink) (Erik Bakker) - My existing contributions and all future contributions until further notice are Copyright Erik Bakker, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. -- [@epost](https://github.com/epost) (Erik Post) - My existing contributions and all future contributions until further notice are Copyright Erik Post, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license -- [@erdeszt](https://github.com/erdeszt) (Tibor Erdesz) My existing contributions and all future contributions until further notice are Copyright Tibor Erdesz, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@etrepum](https://github.com/etrepum) (Bob Ippolito) My existing contributions and all future contributions until further notice are Copyright Bob Ippolito, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@faineance](https://github.com/faineance) My existing contributions and all future contributions until further notice are Copyright faineance, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@felixSchl](https://github.com/felixSchl) (Felix Schlitter) My existing contributions and all future contributions until further notice are Copyright Felix Schlitter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@FrigoEU](https://github.com/FrigoEU) (Simon Van Casteren) My existing contributions and all future contributions until further notice are Copyright Simon Van Casteren, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@ianbollinger](https://github.com/ianbollinger) (Ian D. Bollinger) My existing contributions and all future contributions until further notice are Copyright Ian D. Bollinger, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@ilovezfs](https://github.com/ilovezfs) - My existing contributions and all future contributions until further notice are Copyright ilovezfs, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license -- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@jacereda](https://github.com/jacereda) (Jorge Acereda) My existing contributions and all future contributions until further notice are Copyright Jorge Acereda, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@japesinator](https://github.com/japesinator) (JP Smith) My existing contributions and all future contributions until further notice are Copyright JP Smith, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@joneshf](https://github.com/joneshf) (Hardy Jones) - My existing contributions and all future contributions until further notice are Copyright Hardy Jones, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. -- [@kika](https://github.com/kika) (Kirill Pertsev) - My existing contributions and all future contributions until further notice are Copyright Kirill Pertsev, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. -- [@kRITZCREEK](https://github.com/kRITZCREEK) (Christoph Hegemann) - My existing contributions and all future contributions until further notice are Copyright Christoph Hegemann, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. -- [@L8D](https://github.com/L8D) (Tenor Biel) My existing contributions and all future contributions until further notice are Copyright Tenor Biel, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@leighman](http://github.com/leighman) (Jack Leigh) My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@LiamGoodacre](https://github.com/LiamGoodacre) (Liam Goodacre) My existing contributions and all future contributions until further notice are Copyright Liam Goodacre, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@lukerandall](https://github.com/lukerandall) (Luke Randall) My existing contributions and all future contributions until further notice are Copyright Luke Randall, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@mgmeier](https://github.com/mgmeier) (Michael Karg) My existing contributions and all future contributions until further notice are Copyright Michael Gilliland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@michaelficarra](https://github.com/michaelficarra) (Michael Ficarra) My existing contributions and all future contributions until further notice are Copyright Michael Ficarra, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@MichaelXavier](https://github.com/MichaelXavier) (Michael Xavier) - My existing contributions and all future contributions until further notice are Copyright Michael Xavier, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. -- [@mjgpy3](https://github.com/mjgpy3) (Michael Gilliland) My existing contributions and all future contributions until further notice are Copyright Michael Gilliland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@mpietrzak](https://github.com/mpietrzak) (Maciej Pietrzak) My existing contributions and all future contributions until further notice are Copyright Maciej Pietrzak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@mrhania](https://github.com/mrhania) (Łukasz Hanuszczak) - My existing contributions and all future contributions until further notice are Copyright Łukasz Hanuszczak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@nagisa](https://github.com/nagisa) I hereby release my [only contribution](https://github.com/purescript/purescript/commit/80287a5d0de619862d3b4cda9c1ee276d18fdcd8) into public domain. -- [@natefaubion](https://github.com/natefaubion) (Nathan Faubion) My existing contributions and all future contributions until further notice are Copyright Nathan Faubion, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@nicodelpiano](https://github.com/nicodelpiano) (Nicolas Del Piano) My existing contributions and all future contributions until further notice are Copyright Nicolas Del Piano, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@nullobject](https://github.com/nullobject) (Josh Bassett) My existing contributions and all future contributions until further notice are Copyright Josh Bassett, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@nwolverson](https://github.com/nwolverson) (Nicholas Wolverson) My existing contributions and all future contributions until further notice are Copyright Nicholas Wolverson, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@osa1](https://github.com/osa1) (Ömer Sinan Ağacan) - My existing contributions and all future contributions until further notice are Copyright Ömer Sinan Ağacan, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. -- [@paf31](https://github.com/paf31) (Phil Freeman) My existing contributions and all future contributions until further notice are Copyright Phil Freeman, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@passy](https://github.com/passy) (Pascal Hartig) My existing contributions and all future contributions until further notice are Copyright Pascal Hartig, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@paulyoung](https://github.com/paulyoung) (Paul Young) My existing contributions and all future contributions until further notice are Copyright Paul Young, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@pelotom](https://github.com/pelotom) (Thomas Crockett) My existing contributions and all future contributions until further notice are Copyright Thomas Crockett, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@phadej](https://github.com/phadej) (Oleg Grenrus) My existing contributions and all future contributions until further notice are Copyright Oleg Grenrus, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@phiggins](https://github.com/phiggins) (Pete Higgins) My existing contributions and all future contributions until further notice are Copyright Pete Higgins, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@philopon](https://github.com/philopon) (Hirotomo Moriwaki) - My existing contributions and all future contributions until further notice are Copyright Hirotomo Moriwaki, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@pseudonom](https://github.com/pseudonom) (Eric Easley) My existing contributions and all future contributions until further notice are Copyright Eric Easley, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@puffnfresh](https://github.com/puffnfresh) (Brian McKenna) All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler. -- [@rightfold](https://github.com/rightfold) (rightfold) My existing contributions and all future contributions until further notice are Copyright rightfold, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](https://opensource.org/licenses/MIT). -- [@robdaemon](https://github.com/robdaemon) (Robert Roland) My existing contributions and all future contributions until further notice are Copyright Robert Roland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@RossMeikleham](https://github.com/RossMeikleham) (Ross Meikleham) My existing contributions and all future contributions until further notice are Copyright Ross Meikleham, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@rvion](https://github.com/rvion) (Rémi Vion) My existing contributions and all future contributions until further notice are Copyright Rémi Vion, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@sebastiaanvisser](https://github.com/sebastiaanvisser) (Sebastiaan Visser) - My existing contributions and all future contributions until further notice are Copyright Sebastiaan Visser, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. -- [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@sharkdp](https://github.com/sharkdp) (David Peter) My existing contributions and all future contributions until further notice are Copyright David Peter, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@sztupi](https://github.com/sztupi) (Attila Sztupak) My existing contributions and all future contributions until further notice are Copyright Attila Sztupak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@taktoa](https://github.com/taktoa) (Remy Goldschmidt) My existing contributions and all future contributions until further notice are Copyright Remy Goldschmidt, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@taku0](https://github.com/taku0) - My existing contributions and all future contributions until further notice are Copyright taku0, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@tmcgilchrist](https://github.com/tmcgilchrist) (Tim McGilchrist) My existing contributions and all future contributions until further notice are Copyright Tim McGilchrist, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@trofi](https://github.com/trofi) (Sergei Trofimovich) My existing contributions and all future contributions until further notice are Copyright Sergei Trofimovich, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@utkarshkukreti](https://github.com/utkarshkukreti) (Utkarsh Kukreti) My existing contributions and all future contributions until further notice are Copyright Utkarsh Kukreti, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@vkorablin](https://github.com/vkorablin) (Vladimir Korablin) - My existing contributions and all future contributions until further notice are Copyright Vladimir Korablin, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. -- [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@brandonhamilton](https://github.com/brandonhamilton) (Brandon Hamilton) My existing contributions and all future contributions until further notice are Copyright Brandon Hamilton, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@bbqbaron](https://github.com/bbqbaron) (Eric Loren) My existing contributions and all future contributions until further notice are Copyright Eric Loren, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@RyanGlScott](https://github.com/RyanGlScott) (Ryan Scott) My existing contributions and all future contributions until further notice are Copyright Ryan Scott, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@seungha-kim](https://github.com/seungha-kim) (Seungha Kim) My existing contributions and all future contributions until further notice are Copyright Seungha Kim, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@matthewleon](https://github.com/matthewleon) (Matthew Leon) My existing contributions and all future contributions until further notice are Copyright Matthew Leon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@alexbiehl](https://github.com/alexbiehl) (Alexander Biehl) My existing contributions and all future contributions until further notice are Copyright Alexander Biehl, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). -- [@noraesae](https://github.com/noraesae) (Hyunje Jun) My existing contributions and all future contributions until further notice are Copyright Hyunje Jun, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +Contributors listed here agree to license their contributions under the following terms: + +> My existing contributions and all future contributions until further notice are Copyright {Name}, and are licensed to the owners and users of the PureScript compiler project under the terms of the {License}. + +By adding your name to the list below, you agree to license your contributions under these following terms. + +If you would prefer to use different terms, please use the section below instead. + +| Username | Name | License | +| :------- | :--- | :------ | +| [@5outh](https://github.com/5outh) | Benjamin Kovach | MIT license | +| [@alexbiehl](https://github.com/alexbiehl) | Alexander Biehl | [MIT license](http://opensource.org/licenses/MIT) | +| [@andreypopp](https://github.com/andreypopp) | Andrey Popp | MIT license | +| [@andyarvanitis](https://github.com/andyarvanitis) | Andy Arvanitis | [MIT license](http://opensource.org/licenses/MIT) | +| [@anthok88](https://github.com/anthok88) | anthoq88 | MIT license | +| [@ardumont](https://github.com/ardumont) | Antoine R. Dumont | [MIT license](http://opensource.org/licenses/MIT) | +| [@aspidites](https://github.com/aspidites) | Edwin Marshall | [MIT license](http://opensource.org/licenses/MIT) | +| [@bagl](https://github.com/bagl) | Petr Vapenka | [MIT license](http://opensource.org/licenses/MIT) | +| [@balajirrao](https://github.com/balajirrao) | Balaji Rao | MIT license | +| [@bbqbaron](https://github.com/bbqbaron) | Eric Loren | [MIT license](http://opensource.org/licenses/MIT) | +| [@bergmark](https://github.com/bergmark) | Adam Bergmark | MIT license | +| [@bmjames](https://github.com/bmjames) | Ben James | [MIT license](http://opensource.org/licenses/MIT) | +| [@Bogdanp](https://github.com/Bogdanp) | Bogdan Paul Popa | [MIT license](http://opensource.org/licenses/MIT) | +| [@brandonhamilton](https://github.com/brandonhamilton) | Brandon Hamilton | [MIT license](http://opensource.org/licenses/MIT) | +| [@bsermons](https://github.com/bsermons) | Brian Sermons | [MIT license](http://opensource.org/licenses/MIT) | +| [@cdepillabout](https://github.com/cdepillabout) | Dennis Gosnell | [MIT license](http://opensource.org/licenses/MIT) | +| [@chrisdone](https://github.com/chrisdone) | Chris Done | MIT license | +| [@codedmart](https://github.com/codedmart) | Brandon Martin | [MIT license](http://opensource.org/licenses/MIT) | +| [@davidchambers](https://github.com/davidchambers) | David Chambers | [MIT license](http://opensource.org/licenses/MIT) | +| [@DavidLindbom](https://github.com/DavidLindbom) | David Lindbom | [MIT license](http://opensource.org/licenses/MIT) | +| [@dckc](https://github.com/dckc) | Dan Connolly | [MIT license](http://opensource.org/licenses/MIT) | +| [@eamelink](https://github.com/eamelink) | Erik Bakker | MIT license | +| [@epost](https://github.com/epost) | Erik Post | MIT license | +| [@erdeszt](https://github.com/erdeszt) | Tibor Erdesz | [MIT license](http://opensource.org/licenses/MIT) | +| [@etrepum](https://github.com/etrepum) | Bob Ippolito | [MIT license](http://opensource.org/licenses/MIT) | +| [@faineance](https://github.com/faineance) | faineance | [MIT license](http://opensource.org/licenses/MIT) | +| [@felixSchl](https://github.com/felixSchl) | Felix Schlitter | [MIT license](http://opensource.org/licenses/MIT) | +| [@FrigoEU](https://github.com/FrigoEU) | Simon Van Casteren | [MIT license](http://opensource.org/licenses/MIT) | +| [@garyb](https://github.com/garyb) | Gary Burgess | [MIT license](http://opensource.org/licenses/MIT) | +| [@hdgarrood](https://github.com/hdgarrood) | Harry Garrood | [MIT license](http://opensource.org/licenses/MIT) | +| [@ianbollinger](https://github.com/ianbollinger) | Ian D. Bollinger | [MIT license](http://opensource.org/licenses/MIT) | +| [@ilovezfs](https://github.com/ilovezfs) | ilovezfs | MIT license | +| [@izgzhen](https://github.com/izgzhen) | Zhen Zhang | [MIT license](http://opensource.org/licenses/MIT) | +| [@jacereda](https://github.com/jacereda) | Jorge Acereda | [MIT license](http://opensource.org/licenses/MIT) | +| [@japesinator](https://github.com/japesinator) | JP Smith | [MIT license](http://opensource.org/licenses/MIT) | +| [@joneshf](https://github.com/joneshf) | Hardy Jones | MIT license | +| [@kika](https://github.com/kika) | Kirill Pertsev | MIT license | +| [@kRITZCREEK](https://github.com/kRITZCREEK) | Christoph Hegemann | MIT license | +| [@L8D](https://github.com/L8D) | Tenor Biel | [MIT license](http://opensource.org/licenses/MIT) | +| [@LiamGoodacre](https://github.com/LiamGoodacre) | Liam Goodacre | [MIT license](http://opensource.org/licenses/MIT) | +| [@lukerandall](https://github.com/lukerandall) | Luke Randall | [MIT license](http://opensource.org/licenses/MIT) | +| [@matthewleon](https://github.com/matthewleon) | Matthew Leon | [MIT license](http://opensource.org/licenses/MIT) | +| [@mgmeier](https://github.com/mgmeier) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) | +| [@michaelficarra](https://github.com/michaelficarra) | Michael Ficarra | [MIT license](http://opensource.org/licenses/MIT) | +| [@MichaelXavier](https://github.com/MichaelXavier) | Michael Xavier | MIT license | +| [@mjgpy3](https://github.com/mjgpy3) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) | +| [@mpietrzak](https://github.com/mpietrzak) | Maciej Pietrzak | [MIT license](http://opensource.org/licenses/MIT) | +| [@mrhania](https://github.com/mrhania) | Łukasz Hanuszczak | [MIT license](http://opensource.org/licenses/MIT) | +| [@natefaubion](https://github.com/natefaubion) | Nathan Faubion | [MIT license](http://opensource.org/licenses/MIT) | +| [@nicodelpiano](https://github.com/nicodelpiano) | Nicolas Del Piano | [MIT license](http://opensource.org/licenses/MIT) | +| [@noraesae](https://github.com/noraesae) | Hyunje Jun | [MIT license](http://opensource.org/licenses/MIT) | +| [@nullobject](https://github.com/nullobject) | Josh Bassett | [MIT license](http://opensource.org/licenses/MIT) | +| [@nwolverson](https://github.com/nwolverson) | Nicholas Wolverson | [MIT license](http://opensource.org/licenses/MIT) | +| [@osa1](https://github.com/osa1) | Ömer Sinan Ağacan | MIT license | +| [@paf31](https://github.com/paf31) | Phil Freeman | [MIT license](http://opensource.org/licenses/MIT) | +| [@passy](https://github.com/passy) | Pascal Hartig | [MIT license](http://opensource.org/licenses/MIT) | +| [@paulyoung](https://github.com/paulyoung) | Paul Young | [MIT license](http://opensource.org/licenses/MIT) | +| [@pelotom](https://github.com/pelotom) | Thomas Crockett | [MIT license](http://opensource.org/licenses/MIT) | +| [@phadej](https://github.com/phadej) | Oleg Grenrus | [MIT license](http://opensource.org/licenses/MIT) | +| [@phiggins](https://github.com/phiggins) | Pete Higgins | [MIT license](http://opensource.org/licenses/MIT) | +| [@philopon](https://github.com/philopon) | Hirotomo Moriwaki | [MIT license](http://opensource.org/licenses/MIT) | +| [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license](http://opensource.org/licenses/MIT) | +| [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) | +| [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license](http://opensource.org/licenses/MIT) | +| [@RossMeikleham](https://github.com/RossMeikleham) | Ross Meikleham | [MIT license](http://opensource.org/licenses/MIT) | +| [@rvion](https://github.com/rvion) | Rémi Vion | [MIT license](http://opensource.org/licenses/MIT) | +| [@RyanGlScott](https://github.com/RyanGlScott) | Ryan Scott | [MIT license](http://opensource.org/licenses/MIT) | +| [@sebastiaanvisser](https://github.com/sebastiaanvisser) | Sebastiaan Visser | MIT license | +| [@senju](https://github.com/senju) | senju | [MIT license](http://opensource.org/licenses/MIT) | +| [@seungha-kim](https://github.com/seungha-kim) | Seungha Kim | [MIT license](http://opensource.org/licenses/MIT) | +| [@sharkdp](https://github.com/sharkdp) | David Peter | [MIT license](http://opensource.org/licenses/MIT) | +| [@soupi](https://github.com/soupi) | Gil Mizrahi | [MIT license](http://opensource.org/licenses/MIT) | +| [@sztupi](https://github.com/sztupi) | Attila Sztupak | [MIT license](http://opensource.org/licenses/MIT) | +| [@taktoa](https://github.com/taktoa) | Remy Goldschmidt | [MIT license](http://opensource.org/licenses/MIT) | +| [@taku0](https://github.com/taku0) | taku0 | [MIT license](http://opensource.org/licenses/MIT) | +| [@tfausak](https://github.com/tfausak) | Taylor Fausak | [MIT license](http://opensource.org/licenses/MIT) | +| [@tmcgilchrist](https://github.com/tmcgilchrist) | Tim McGilchrist | [MIT license](http://opensource.org/licenses/MIT) | +| [@trofi](https://github.com/trofi) | Sergei Trofimovich | [MIT license](http://opensource.org/licenses/MIT) | +| [@utkarshkukreti](https://github.com/utkarshkukreti) | Utkarsh Kukreti | [MIT license](http://opensource.org/licenses/MIT) | +| [@vkorablin](https://github.com/vkorablin) | Vladimir Korablin | MIT license | +| [@zudov](https://github.com/zudov) | Konstantin Zudov | [MIT license](http://opensource.org/licenses/MIT) | + +### Contributors using Modified Terms + +| Username | Name | Terms | +| :------- | :--- | :------ | +| [@charleso](https://github.com/charleso) | Charles O'Farrell | My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Charles O'Farrell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | +| [@chrissmoak](https://github.com/chrissmoak) | Chris Smoak | My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | +| [@dylex](https://github.com/dylex) | Dylan Simon | My existing and all future contributions to the PureScript compiler until further notice are Copyright Dylan Simon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | +| [@leighman](http://github.com/leighman) | Jack Leigh | My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | +| [@nagisa](https://github.com/nagisa) | nagisa | I hereby release my [only contribution](https://github.com/purescript/purescript/commit/80287a5d0de619862d3b4cda9c1ee276d18fdcd8) into public domain. | +| [@puffnfresh](https://github.com/puffnfresh) | Brian McKenna | All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler. | ### Companies -- [@slamdata](https://github.com/slamdata) (SlamData, Inc.) Speaking on behalf of SlamData for SlamData employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright SlamData Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - @jdegoes +| Username | Company | Terms | +| :------- | :--- | :------ | +| [@slamdata](https://github.com/slamdata) | SlamData, Inc. | Speaking on behalf of SlamData for SlamData employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright SlamData Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - @jdegoes | From e7664bdcdc328f9ed895dda227d20522bceed213 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 9 Feb 2017 14:59:03 -0800 Subject: [PATCH 0664/1580] Revert "Generate data constructors without IIFEs" (#2648) --- src/Language/PureScript/CodeGen/JS.hs | 67 +++++++++------------------ 1 file changed, 23 insertions(+), 44 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index b0ecfd10ee..9ac6b87bd6 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -138,8 +138,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- Generate code in the simplified Javascript intermediate representation for a declaration -- bindToJs :: Bind Ann -> m [JS] - bindToJs (NonRec ann ident val) = nonRecToJS ann ident val - bindToJs (Rec vals) = concat <$> forM vals (uncurry . uncurry $ nonRecToJS) + bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val + bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS) -- | -- Generate code in the simplified Javascript intermediate representation for a single non-recursive @@ -147,22 +147,15 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- -- The main purpose of this function is to handle code generation for comments. -- - nonRecToJS :: Ann -> Ident -> Expr Ann -> m [JS] + nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do withoutComment <- asks optionsNoComments if withoutComment then nonRecToJS a i (modifyAnn removeComments e) - else withHead (JSComment Nothing com) <$> nonRecToJS a i (modifyAnn removeComments e) - where - withHead _ [] = [] - withHead f (x:xs) = f x : xs + else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e) nonRecToJS (ss, _, _, _) ident val = do - case constructorToJs ident val of - Just jss -> - traverse (withPos ss) jss - Nothing -> do - js <- valueToJs val - return <$> (withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)) + js <- valueToJs val + withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js) withPos :: Maybe SourceSpan -> JS -> m JS withPos (Just ss) js = do @@ -258,37 +251,23 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = JSObjectLiteral Nothing [("create", JSFunction Nothing Nothing ["value"] (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))]) - valueToJs' (Constructor _ _ (ProperName ctor) _) = - internalError $ "Unexpected constructor definition: " ++ T.unpack ctor - - -- | - -- Attempt to generate code in the simplified JS intermediate representation for a constructor definition. - -- If the argument is not a constructor, this returns Nothing. - -- - constructorToJs :: Ident -> Expr Ann -> Maybe [JS] - constructorToJs ident (Constructor _ _ (ProperName ctor) fs) = - Just jss - where - mkAccessor name = JSAssignment Nothing (accessorString name (JSVar Nothing (identToJs ident))) - jss = case fs of - [] -> - [ JSVariableIntroduction Nothing (identToJs ident) (Just $ - JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])) - , mkAccessor "value" $ - JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (identToJs ident)) [] - ] - fields -> - let constructor = - let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] - in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body) - createFn = - let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields) - in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields - in [ constructor - , mkAccessor "create" createFn - ] - constructorToJs _ _ = - Nothing + valueToJs' (Constructor _ _ (ProperName ctor) []) = + return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing []) + , JSAssignment Nothing (accessorString "value" (JSVar Nothing (properToJs ctor))) + (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ] + valueToJs' (Constructor _ _ (ProperName ctor) fields) = + let constructor = + let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] + in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body) + createFn = + let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields) + in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields + in return $ iife (properToJs ctor) [ constructor + , JSAssignment Nothing (accessorString "create" (JSVar Nothing (properToJs ctor))) createFn + ] + + iife :: Text -> [JS] -> JS + iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) [] literalToValueJS :: Literal (Expr Ann) -> m JS literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i) From ca359500f948219b6f89655fa86016b62a70d613 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 9 Feb 2017 22:59:50 +0000 Subject: [PATCH 0665/1580] Address travis timeout issues (#2647) These commits amend the CI scripts so that if a build does time out, the next one can continue where the previous left off. For more info see https://gist.github.com/hdgarrood/29fa8ebcd5b5acd679cf429fd0a93e3e This enables us to enable OSX builds again (which I have done). --- .travis.yml | 51 +++++++++++++++++++++++++++---------------------- travis/build.sh | 20 ++++++++++++++++++- 2 files changed, 47 insertions(+), 24 deletions(-) diff --git a/.travis.yml b/.travis.yml index b6ba6c5760..ef669f1313 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,49 +3,38 @@ dist: trusty # because of perf issues sudo: required matrix: include: - # The 'compiler' key is a hack to get Travis to use different caches for - # each job in a build, in order to avoid the separate jobs stomping on each - # other's caches. See https://github.com/travis-ci/travis-ci/issues/4393 - # # We use trusty boxes because they seem to be a bit faster. - - compiler: cc-linux-lts-normal - os: linux + - os: linux dist: trusty sudo: required env: BUILD_TYPE=normal DEPLOY=true - # - compiler: cc-linux-nightly-normal - # os: linux + # - os: linux # dist: trusty # sudo: required # env: BUILD_TYPE=normal STACKAGE_NIGHTLY=true # allow_failures: true - - compiler: cc-linux-ghc8.0-normal - os: linux + - os: linux dist: trusty sudo: required env: BUILD_TYPE=normal STACK_YAML=stack-ghc-8.0.yaml - - compiler: cc-linux-lts-sdist - os: linux + - os: linux dist: trusty sudo: required env: BUILD_TYPE=sdist COVERAGE=true - - compiler: cc-linux-lts-haddock - os: linux + - os: linux dist: trusty sudo: required env: BUILD_TYPE=haddock - # - compiler: cc-osx-lts-normal - # os: osx - # env: BUILD_TYPE=normal DEPLOY=true - - # - compiler: cc-osx-lts-sdist - # os: osx - # env: BUILD_TYPE=sdist + - os: osx + env: BUILD_TYPE=normal DEPLOY=true + + - os: osx + env: BUILD_TYPE=sdist addons: apt: packages: @@ -54,6 +43,11 @@ cache: directories: - $HOME/.local/bin - $HOME/.stack + # Maximum amount of time in seconds spent attempting to upload a new cache + # before aborting. Since our cache can get rather large, increasing this + # value helps avoid situations where caches fail to be stored. The default + # value is 180 (at the time of writing). + timeout: 1000 install: - | # Install stack. if test ! -f "$HOME/.local/bin/stack" @@ -66,9 +60,20 @@ install: mv stack "$HOME/.local/bin/" fi - npm install -g bower # for psc-docs / psc-publish tests -# Fix the CC environment variable, because Travis changes it -- export CC=gcc - export OS_NAME=$(./travis/convert-os-name.sh) +# Install 'timeout' +- | + if [ "$TRAVIS_OS_NAME" == "osx" ] + then + if ! which gtimeout >/dev/null + then + brew update + brew install coreutils + fi + export TIMEOUT=gtimeout + else + export TIMEOUT=timeout + fi script: - travis/build.sh before_deploy: diff --git a/travis/build.sh b/travis/build.sh index 63ddb620b9..284cb08596 100755 --- a/travis/build.sh +++ b/travis/build.sh @@ -2,7 +2,25 @@ set -e STACK="stack --no-terminal --jobs=1" -$STACK setup + +# Setup & install dependencies or abort +ret=0 +$TIMEOUT 40m $STACK --install-ghc build \ + --only-dependencies --test --haddock \ + || ret=$? +case "$ret" in + 0) # continue + ;; + 124) + echo "Timed out while installing dependencies." + echo "Try pushing a new commit to build again." + exit 1 + ;; + *) + echo "Failed to install dependencies." + exit 1 + ;; +esac # Set up configuration STACK_EXTRA_FLAGS="" From 5b1071eebf3fe37203af7f73acfd3d9ba758632a Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 10 Feb 2017 09:42:28 +0000 Subject: [PATCH 0666/1580] Nudge travis From 64fbcc55f61da706fc303ad4714fe8a5af6619e3 Mon Sep 17 00:00:00 2001 From: Hyunje Jun Date: Sat, 11 Feb 2017 01:36:25 +0900 Subject: [PATCH 0667/1580] Capitalise *script into *Script (#2649) Javascript -> JavaScript, Purescript -> PureScript --- README.md | 2 +- app/Command/REPL.hs | 2 +- purescript.cabal | 2 +- src/Language/PureScript/Bundle.hs | 8 +++--- src/Language/PureScript/CodeGen.hs | 2 +- src/Language/PureScript/CodeGen/JS.hs | 26 +++++++++---------- src/Language/PureScript/CodeGen/JS/AST.hs | 8 +++--- src/Language/PureScript/CodeGen/JS/Common.hs | 6 ++--- .../PureScript/CodeGen/JS/Optimizer.hs | 6 ++--- .../PureScript/CodeGen/JS/Optimizer/Blocks.hs | 2 +- src/Language/PureScript/Make.hs | 2 +- src/Language/PureScript/Pretty/JS.hs | 8 +++--- 12 files changed, 37 insertions(+), 37 deletions(-) diff --git a/README.md b/README.md index b6c4df22a3..504c5ca019 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ [![PureScript](logo.png)](http://purescript.org) -A small strongly typed programming language with expressive types that compiles to Javascript, written in and inspired by Haskell. +A small strongly typed programming language with expressive types that compiles to JavaScript, written in and inspired by Haskell. [![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript) diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 00d9553c15..8bb42fe39c 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -250,7 +250,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown createBundle :: BrowserState -> IO () createBundle state = do - putStrLn "Bundling Javascript..." + putStrLn "Bundling JavaScript..." ejs <- bundle case ejs of Left err -> do diff --git a/purescript.cabal b/purescript.cabal index 6f07f03924..1916d03f10 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -8,7 +8,7 @@ copyright: (c) 2013-16 Phil Freeman, (c) 2014-16 Gary Burgess maintainer: Phil Freeman stability: experimental synopsis: PureScript Programming Language Compiler -description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to Javascript. +description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language Homepage: http://www.purescript.org/ author: Phil Freeman , diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 6b63d19f5a..4b05551b6d 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -3,7 +3,7 @@ -- -- This module takes as input the individual generated modules from 'Language.PureScript.Make' and -- performs dead code elimination, filters empty modules, --- and generates the final Javascript bundle. +-- and generates the final JavaScript bundle. module Language.PureScript.Bundle ( bundle , bundleSM @@ -249,7 +249,7 @@ trailingCommaList :: JSCommaTrailingList a -> [a] trailingCommaList (JSCTLComma l _) = commaList l trailingCommaList (JSCTLNone l) = commaList l --- | Attempt to create a Module from a Javascript AST. +-- | Attempt to create a Module from a JavaScript AST. -- -- Each type of module element is matched using pattern guards, and everything else is bundled into the -- Other constructor. @@ -671,7 +671,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o -- | The bundling function. -- This function performs dead code elimination, filters empty modules --- and generates and prints the final Javascript bundle. +-- and generates and prints the final JavaScript bundle. bundleSM :: (MonadError ErrorMessage m) => [(ModuleIdentifier, Maybe FilePath, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination @@ -700,7 +700,7 @@ bundleSM inputStrs entryPoints mainModule namespace outFilename = do -- | The bundling function. -- This function performs dead code elimination, filters empty modules --- and generates and prints the final Javascript bundle. +-- and generates and prints the final JavaScript bundle. bundle :: (MonadError ErrorMessage m) => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination diff --git a/src/Language/PureScript/CodeGen.hs b/src/Language/PureScript/CodeGen.hs index d927211bf8..02edf9ec4e 100644 --- a/src/Language/PureScript/CodeGen.hs +++ b/src/Language/PureScript/CodeGen.hs @@ -1,7 +1,7 @@ -- | -- A collection of modules related to code generation: -- --- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript +-- [@Language.PureScript.CodeGen.JS@] Code generator for JavaScript -- module Language.PureScript.CodeGen (module C) where diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 9ac6b87bd6..ee60806bfc 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -1,5 +1,5 @@ -- | --- This module generates code in the simplified Javascript intermediate representation from Purescript code +-- This module generates code in the simplified JavaScript intermediate representation from PureScript code -- module Language.PureScript.CodeGen.JS ( module AST @@ -42,7 +42,7 @@ import qualified Language.PureScript.Constants as C import System.FilePath.Posix (()) -- | --- Generate code in the simplified Javascript intermediate representation for all declarations in a +-- Generate code in the simplified JavaScript intermediate representation for all declarations in a -- module. -- moduleToJs @@ -104,7 +104,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = else newName -- | - -- Generates Javascript code for a module import, binding the required module + -- Generates JavaScript code for a module import, binding the required module -- to the alternative -- importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS @@ -135,14 +135,14 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = renameQual q = q -- | - -- Generate code in the simplified Javascript intermediate representation for a declaration + -- Generate code in the simplified JavaScript intermediate representation for a declaration -- bindToJs :: Bind Ann -> m [JS] bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS) -- | - -- Generate code in the simplified Javascript intermediate representation for a single non-recursive + -- Generate code in the simplified JavaScript intermediate representation for a single non-recursive -- declaration. -- -- The main purpose of this function is to handle code generation for comments. @@ -166,15 +166,15 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = withPos Nothing js = return js -- | - -- Generate code in the simplified Javascript intermediate representation for a variable based on a + -- Generate code in the simplified JavaScript intermediate representation for a variable based on a -- PureScript identifier. -- var :: Ident -> JS var = JSVar Nothing . identToJs -- | - -- Generate code in the simplified Javascript intermediate representation for an accessor based on - -- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an + -- Generate code in the simplified JavaScript intermediate representation for an accessor based on + -- a PureScript identifier. If the name is not valid in JavaScript (symbol based, reserved name) an -- indexer is returned. -- accessor :: Ident -> JS -> JS @@ -185,7 +185,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = accessorString prop = JSIndexer Nothing (JSStringLiteral Nothing prop) -- | - -- Generate code in the simplified Javascript intermediate representation for a value or expression. + -- Generate code in the simplified JavaScript intermediate representation for a value or expression. -- valueToJs :: Expr Ann -> m JS valueToJs e = @@ -301,7 +301,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = return $ JSApp Nothing (JSFunction Nothing Nothing [] block) [] -- | - -- Generate code in the simplified Javascript intermediate representation for a reference to a + -- Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable. -- varToJs :: Qualified Ident -> JS @@ -309,7 +309,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = varToJs qual = qualifiedToJS id qual -- | - -- Generate code in the simplified Javascript intermediate representation for a reference to a + -- Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable that may have a qualified name. -- qualifiedToJS :: (a -> Ident) -> Qualified a -> JS @@ -321,7 +321,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = foreignIdent ident = accessorString (mkString $ runIdent ident) (JSVar Nothing "$foreign") -- | - -- Generate code in the simplified Javascript intermediate representation for pattern match binders + -- Generate code in the simplified JavaScript intermediate representation for pattern match binders -- and guards. -- bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [JS] -> m JS @@ -382,7 +382,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = traverse (withPos ss) =<< binderToJs' s done binder -- | - -- Generate code in the simplified Javascript intermediate representation for a pattern match + -- Generate code in the simplified JavaScript intermediate representation for a pattern match -- binder. -- binderToJs' :: Text -> [JS] -> Binder Ann -> m [JS] diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index a8c196fe90..58f5905239 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -1,5 +1,5 @@ -- | --- Data types for the intermediate simplified-Javascript AST +-- Data types for the intermediate simplified-JavaScript AST -- module Language.PureScript.CodeGen.JS.AST where @@ -123,7 +123,7 @@ data BinaryOperator deriving (Show, Eq) -- | --- Data type for simplified Javascript expressions +-- Data type for simplified JavaScript expressions -- data JS -- | @@ -231,11 +231,11 @@ data JS -- | JSContinue (Maybe SourceSpan) Text -- | - -- Raw Javascript (generated when parsing fails for an inline foreign import declaration) + -- Raw JavaScript (generated when parsing fails for an inline foreign import declaration) -- | JSRaw (Maybe SourceSpan) Text -- | - -- Commented Javascript + -- Commented JavaScript -- | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Eq) diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index e07b5aba74..751042873f 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -19,7 +19,7 @@ moduleNameToJs (ModuleName pns) = in if nameIsJsBuiltIn name then "$$" <> name else name -- | --- Convert an Ident into a valid Javascript identifier: +-- Convert an Ident into a valid JavaScript identifier: -- -- * Alphanumeric characters are kept unmodified. -- @@ -73,14 +73,14 @@ identCharToText '\'' = "$prime" identCharToText c = '$' `T.cons` T.pack (show (ord c)) -- | --- Checks whether an identifier name is reserved in Javascript. +-- Checks whether an identifier name is reserved in JavaScript. -- nameIsJsReserved :: Text -> Bool nameIsJsReserved name = name `elem` jsAnyReserved -- | --- Checks whether a name matches a built-in value in Javascript. +-- Checks whether a name matches a built-in value in JavaScript. -- nameIsJsBuiltIn :: Text -> Bool nameIsJsBuiltIn name = diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs index cb38128a26..ffd40a1e76 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -1,4 +1,4 @@ --- | This module optimizes code in the simplified-Javascript intermediate representation. +-- | This module optimizes code in the simplified-JavaScript intermediate representation. -- -- The following optimizations are supported: -- @@ -16,7 +16,7 @@ -- -- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!) -- --- * Inlining primitive Javascript operators +-- * Inlining primitive JavaScript operators module Language.PureScript.CodeGen.JS.Optimizer (optimize) where import Prelude.Compat @@ -30,7 +30,7 @@ import Language.PureScript.CodeGen.JS.Optimizer.MagicDo import Language.PureScript.CodeGen.JS.Optimizer.TCO import Language.PureScript.CodeGen.JS.Optimizer.Unused --- | Apply a series of optimizer passes to simplified Javascript code +-- | Apply a series of optimizer passes to simplified JavaScript code optimize :: MonadSupply m => JS -> m JS optimize js = do js' <- untilFixedPoint (inlineFnComposition . inlineUnsafePartial . tidyUp . applyAll diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs index 1c80799e22..5e40399c9f 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs @@ -1,5 +1,5 @@ -- | --- Optimizer steps for simplifying Javascript blocks +-- Optimizer steps for simplifying JavaScript blocks -- module Language.PureScript.CodeGen.JS.Optimizer.Blocks ( collapseNestedBlocks diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index a61e6dc32f..621878366e 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -94,7 +94,7 @@ renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModule -- -- This type exists to make two things abstract: -- --- * The particular backend being used (Javascript, C++11, etc.) +-- * The particular backend being used (JavaScript, C++11, etc.) -- -- * The details of how files are read/written etc. data MakeActions m = MakeActions diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 92de636eaf..0dc35fd401 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -1,5 +1,5 @@ -- | --- Pretty printer for the Javascript AST +-- Pretty printer for the JavaScript AST -- module Language.PureScript.Pretty.JS ( prettyPrintJS @@ -240,13 +240,13 @@ prettyStatements sts = do return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss -- | --- Generate a pretty-printed string representing a Javascript expression +-- Generate a pretty-printed string representing a JavaScript expression -- prettyPrintJS1 :: (Emit gen) => JS -> gen prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS' -- | --- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level +-- Generate a pretty-printed string representing a collection of JavaScript expressions at the same indentation level -- prettyPrintJSWithSourceMaps :: [JS] -> (Text, [SMap]) prettyPrintJSWithSourceMaps js = @@ -256,7 +256,7 @@ prettyPrintJSWithSourceMaps js = prettyPrintJS :: [JS] -> Text prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements -- | --- Generate an indented, pretty-printed string representing a Javascript expression +-- Generate an indented, pretty-printed string representing a JavaScript expression -- prettyPrintJS' :: (Emit gen) => JS -> StateT PrinterState Maybe gen prettyPrintJS' = A.runKleisli $ runPattern matchValue From 966cd7a331b2da6bead98ebcf72b55244756c878 Mon Sep 17 00:00:00 2001 From: Hyunje Jun Date: Sat, 11 Feb 2017 01:39:00 +0900 Subject: [PATCH 0668/1580] Desugar patterns in let-in expressions (#2627) * Update CONTRIBUTING.md Add the 'Tests' section, with how to run a specific test suite. * Implement BoundValueDeclaration parsing BoundValueDeclaration is added to parse bound patterns in let declarations. It will be desugared later, so need not to be type-checked. * Add desugaring pass for patterns in let-in expression The pass desugars BoundValueDeclaration in let-in expressions into case expressions. * Add a passing example for let-in pattern desugaring * Apply reviews Format code and remove unused type class constraint. * Remove a trailing space * Reduce backtracking in binder parsing Remove parseBoundValueDeclaration, parse binders in parseValueDeclaration. * Update examples for let pattern matching Add failing tests. Also add asserts to the passing test suite, in order to test parens around the patterns. * Update description for BoundValueDelcaration Specify it's for let-in pattern matching. * Allow n-ary constructor for the first binder in value decl The following case should be valid. let X 10 = X a * Fix error message for unexpected patterns in value decl * Add test cases for named binder * Improve desugarLetPatternModule Remove the MonadError constraint, change decl desugar order to right-fold. * Separate parseLocalValueDeclaration * Use parseBinder to parse local decl * Test infix operator pattern in let pattern matching * Build fix after resolving conflict with master --- CONTRIBUTING.md | 18 +- examples/failing/LetPatterns1.purs | 10 + examples/failing/LetPatterns2.purs | 14 ++ examples/failing/LetPatterns3.purs | 13 ++ examples/failing/LetPatterns4.purs | 6 + examples/passing/LetPattern.purs | 196 ++++++++++++++++++ purescript.cabal | 1 + src/Language/PureScript/AST/Declarations.hs | 5 +- .../PureScript/Parser/Declarations.hs | 47 +++-- src/Language/PureScript/Sugar.hs | 4 +- src/Language/PureScript/Sugar/LetPattern.hs | 47 +++++ src/Language/PureScript/TypeChecker.hs | 1 + 12 files changed, 341 insertions(+), 21 deletions(-) create mode 100644 examples/failing/LetPatterns1.purs create mode 100644 examples/failing/LetPatterns2.purs create mode 100644 examples/failing/LetPatterns3.purs create mode 100644 examples/failing/LetPatterns4.purs create mode 100644 examples/passing/LetPattern.purs create mode 100644 src/Language/PureScript/Sugar/LetPattern.hs diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 65443cc0e9..f935b7a7f7 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -10,11 +10,25 @@ If you would like to contribute, please consider the issues in the current miles Please follow the following guidelines: -- Add at least a test to `examples/passing/` and possibly to `examples/failing`. +- Add at least a test to `examples/passing/` and possibly to `examples/failing/`. - Build the binaries and libs with `stack build` -- Run the test suite with `stack test`. You will need `npm`, `bower` and `node` on your PATH to run the tests. +- Make sure that all test suites are passing. Run the test suites with `stack test`. - Build the core libraries by running the script in `core-tests`. +## Tests + +Run all test suites with `stack test`. You will need `npm`, `bower` and `node` on your PATH to run the tests. + +To build and run a specific test in `examples/passing/` or `examples/failing/`, execute the following commands. + +``` bash +# Build +stack exec psc -- 'tests/support/bower_components/purescript-*/src/**/*.purs' examples/blah/Blah.purs + +# Run +node -e "require('./output/Main/').main()" +``` + ## Code Review To prevent core libraries from getting broken, every change must be reviewed. A pull request will be merged as long as one other team member has verified the changes. diff --git a/examples/failing/LetPatterns1.purs b/examples/failing/LetPatterns1.purs new file mode 100644 index 0000000000..1531ede4cb --- /dev/null +++ b/examples/failing/LetPatterns1.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +import Prelude + +-- wrong binders for function, the first one should be VarBinder +x = + let (X a b) x y = hoge + in + a diff --git a/examples/failing/LetPatterns2.purs b/examples/failing/LetPatterns2.purs new file mode 100644 index 0000000000..ebfd7f034c --- /dev/null +++ b/examples/failing/LetPatterns2.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith UnknownName +module Main where + +import Prelude + +data X a = X a + +-- wrong dependency order +x = + let + b = a + X a = X 10 + in + b diff --git a/examples/failing/LetPatterns3.purs b/examples/failing/LetPatterns3.purs new file mode 100644 index 0000000000..58be165cfc --- /dev/null +++ b/examples/failing/LetPatterns3.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith IncorrectConstructorArity +module Main where + +import Prelude + +data X a = X a + +-- a parameter binder should be with nullary constructor, or with parens +x = + let + a X b = b + in + a $ X 10 diff --git a/examples/failing/LetPatterns4.purs b/examples/failing/LetPatterns4.purs new file mode 100644 index 0000000000..a361a43b1e --- /dev/null +++ b/examples/failing/LetPatterns4.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +data X a = X a + +X a = a diff --git a/examples/passing/LetPattern.purs b/examples/passing/LetPattern.purs new file mode 100644 index 0000000000..e8231208d8 --- /dev/null +++ b/examples/passing/LetPattern.purs @@ -0,0 +1,196 @@ +module Main where + +import Prelude +import Partial.Unsafe (unsafePartial) +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) +import Test.Assert (ASSERT, assert') + +patternSimple :: Boolean +patternSimple = + let x = 25252 + in + x == 25252 + +patternDoSimple :: forall e. Eff e Boolean +patternDoSimple = do + let x = 25252 + pure $ x == 25252 + +newtype X = X Int + +patternNewtype :: Boolean +patternNewtype = + let X a = X 123 + in + a == 123 + +patternDoNewtype :: forall e. Eff e Boolean +patternDoNewtype = do + let X a = X 123 + pure $ a == 123 + +data Y = Y Int String Boolean + +patternData :: Boolean +patternData = + let Y a b c = Y 456 "hello, world" false + in + a == 456 && b == "hello, world" && not c + +patternDataIgnored :: Boolean +patternDataIgnored = + let Y _ x _ = Y 789 "world, hello" true + in + x == "world, hello" + +patternDoData :: forall e. Eff e Boolean +patternDoData = do + let Y a b c = Y 456 "hello, world" false + pure $ a == 456 && b == "hello, world" && not c + +patternDoDataIgnored :: forall e. Eff e Boolean +patternDoDataIgnored = do + let Y _ x _ = Y 789 "world, hello" true + pure $ x == "world, hello" + +patternArray :: Boolean +patternArray = unsafePartial $ + let [a, b] = [1, 2] + in + a == 1 && b == 2 + +patternDoArray :: forall e. Eff e Boolean +patternDoArray = unsafePartial do + let [a, b] = [1, 2] + pure $ a == 1 && b == 2 + +patternMultiple :: Boolean +patternMultiple = unsafePartial $ + let + x = 25252 + X a = X x + Y b c d = Y x "hello, world" false + Y _ e _ = Y 789 "world, hello" true + [f, g] = [1, 2] + in + x == 25252 && a == 25252 && b == 25252 && c == "hello, world" && + not d && e == "world, hello" && f == 1 && g == 2 + +patternDoMultiple :: forall e. Eff e Boolean +patternDoMultiple = unsafePartial do + let + x = 25252 + X a = X x + Y b c d = Y x "hello, world" false + Y _ e _ = Y 789 "world, hello" true + [f, g] = [1, 2] + pure $ x == 25252 && a == 25252 && b == 25252 && c == "hello, world" && + not d && e == "world, hello" && f == 1 && g == 2 + +patternMultipleWithNormal :: Boolean +patternMultipleWithNormal = unsafePartial $ + let + x = 25252 + X a = X x + y = 2525 + Y b c d = Y y "hello, world" false + in + x == 25252 && y == 2525 && + a == 25252 && b == 2525 && c == "hello, world" && not d + +patternDoMultipleWithNormal :: forall e. Eff e Boolean +patternDoMultipleWithNormal = unsafePartial do + let + x = 25252 + X a = X x + y = 2525 + Y b c d = Y y "hello, world" false + pure $ x == 25252 && y == 2525 && + a == 25252 && b == 2525 && c == "hello, world" && not d + +patternWithParens :: Boolean +patternWithParens = unsafePartial $ + let + (x) = 25252 + (X a) = X x + (Y b c d) = Y x "hello, world" false + (Y _ e _) = Y 789 "world, hello" true + ([f, g]) = [1, 2] + in + x == 25252 && a == 25252 && b == 25252 && c == "hello, world" && + not d && e == "world, hello" && f == 1 && g == 2 + +patternDoWithParens :: forall e. Eff e Boolean +patternDoWithParens = unsafePartial do + let + (x) = 25252 + (X a) = X x + (Y b c d) = Y x "hello, world" false + (Y _ e _) = Y 789 "world, hello" true + ([f, g]) = [1, 2] + pure $ x == 25252 && a == 25252 && b == 25252 && c == "hello, world" && + not d && e == "world, hello" && f == 1 && g == 2 + +patternWithNamedBinder :: Boolean +patternWithNamedBinder = unsafePartial $ + let + a@{x, y} = {x: 10, y: 20} + in + a.x == 10 && x == 10 && a.y == 20 && y == 20 + +patternDoWithNamedBinder :: forall e. Eff e Boolean +patternDoWithNamedBinder = unsafePartial do + let + a@{x, y} = {x: 10, y: 20} + pure $ + a.x == 10 && x == 10 && a.y == 20 && y == 20 + +data List a = Nil | Cons a (List a) +infixr 6 Cons as : + +instance eqList :: Eq a => Eq (List a) where + eq xs ys = go xs ys true + where + go _ _ false = false + go Nil Nil acc = acc + go (x : xs') (y : ys') acc = go xs' ys' $ acc && (y == x) + go _ _ _ = false + +patternWithInfixOp :: Boolean +patternWithInfixOp = unsafePartial $ + let + x : xs = 1 : 2 : 3 : 4 : Nil + in + x == 1 && xs == 2 : 3 : 4 : Nil + +patternDoWithInfixOp :: forall e. Eff e Boolean +patternDoWithInfixOp = unsafePartial do + let + x : xs = 1 : 2 : 3 : 4 : Nil + pure $ + x == 1 && xs == 2 : 3 : 4 : Nil + +main :: Eff (assert :: ASSERT, console :: CONSOLE) Unit +main = do + assert' "simple variable pattern" patternSimple + assert' "simple variable pattern with do" =<< patternDoSimple + assert' "constructor pattern (newtype)" patternNewtype + assert' "constructor pattern (newtype) with do" =<< patternDoNewtype + assert' "constructor pattern (data)" patternData + assert' "constructor pattern with ignorances" patternDataIgnored + assert' "constructor pattern (data) with do" =<< patternDoData + assert' "constructor pattern with ignorances and do" =<< patternDoDataIgnored + assert' "array pattern" patternArray + assert' "array pattern with do" =<< patternDoArray + assert' "multiple patterns" patternMultiple + assert' "multiple patterns with do" =<< patternDoMultiple + assert' "multiple patterns with normal let's" patternMultipleWithNormal + assert' "multiple patterns with normal let's and do" =<< patternDoMultipleWithNormal + assert' "multiple patterns with parens" patternWithParens + assert' "multiple patterns with parens and do" =<< patternDoWithParens + assert' "multiple patterns with named binder" patternWithNamedBinder + assert' "multiple patterns with named binder and do" =<< patternDoWithNamedBinder + assert' "pattern with infix operator" patternWithInfixOp + assert' "pattern with infix operator and do" =<< patternDoWithInfixOp + log "Done" diff --git a/purescript.cabal b/purescript.cabal index 1916d03f10..0943155783 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -231,6 +231,7 @@ library Language.PureScript.Sugar.BindingGroups Language.PureScript.Sugar.CaseDeclarations Language.PureScript.Sugar.DoNotation + Language.PureScript.Sugar.LetPattern Language.PureScript.Sugar.Names Language.PureScript.Sugar.Names.Common Language.PureScript.Sugar.Names.Env diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 2c6e80de4b..c6ebf9ebcc 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -45,7 +45,7 @@ data TypeSearch -- | A type of error messages data SimpleErrorMessage - = ModuleNotFound ModuleName + = ModuleNotFound ModuleName | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) | ErrorParsingModule P.ParseError | MissingFFIModule ModuleName @@ -393,6 +393,9 @@ data Declaration -- | ValueDeclaration Ident NameKind [Binder] [GuardedExpr] -- | + -- A declaration paired with pattern matching in let-in expression (binder, optional guard, value) + | BoundValueDeclaration Binder Expr + -- | -- A minimal mutually recursive set of value declarations -- | BindingGroupDeclaration [(Ident, NameKind, Expr)] diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 8d3a7e3364..6178ac1a13 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -17,7 +17,7 @@ import Prelude hiding (lex) import Control.Applicative import Control.Arrow ((+++)) -import Control.Monad (foldM) +import Control.Monad (foldM, join) import Control.Monad.Error.Class (MonadError(..)) import Control.Parallel.Strategies (withStrategy, parList, rseq) import Data.Functor (($>)) @@ -63,28 +63,41 @@ parseTypeSynonymDeclaration = <*> many (indented *> kindedIdent) <*> (indented *> equals *> noWildcards parsePolyType) -parseValueDeclaration :: TokenParser Declaration -parseValueDeclaration = do - name <- parseIdent - binders <- P.many parseBinderNoParens +parseValueWithWhereClause :: TokenParser Expr +parseValueWithWhereClause = do + indented + value <- parseValue + whereClause <- P.optionMaybe $ do + indented + reserved "where" + indented + mark $ P.many1 (same *> parseLocalDeclaration) + return $ maybe value (`Let` value) whereClause + +parseValueWithIdentAndBinders :: Ident -> [Binder] -> TokenParser Declaration +parseValueWithIdentAndBinders ident bs = do value <- indented *> ( (\v -> [MkUnguarded v]) <$> (equals *> parseValueWithWhereClause) <|> P.many1 (GuardedExpr <$> parseGuard <*> (indented *> equals *> parseValueWithWhereClause)) ) - return $ ValueDeclaration name Public binders value + return $ ValueDeclaration ident Public bs value + +parseValueDeclaration :: TokenParser Declaration +parseValueDeclaration = do + ident <- parseIdent + binders <- P.many parseBinderNoParens + parseValueWithIdentAndBinders ident binders + +parseLocalValueDeclaration :: TokenParser Declaration +parseLocalValueDeclaration = join $ go <$> parseBinder <*> (P.many parseBinderNoParens) where - parseValueWithWhereClause :: TokenParser Expr - parseValueWithWhereClause = do - indented - value <- parseValue - whereClause <- P.optionMaybe $ do - indented - reserved "where" - indented - mark $ P.many1 (same *> parseLocalDeclaration) - return $ maybe value (`Let` value) whereClause + go :: Binder -> [Binder] -> TokenParser Declaration + go (VarBinder ident) bs = parseValueWithIdentAndBinders ident bs + go (PositionedBinder _ _ (VarBinder ident)) bs = parseValueWithIdentAndBinders ident bs + go binder [] = BoundValueDeclaration binder <$> (indented *> equals *> parseValueWithWhereClause) + go _ _ = P.unexpected $ "patterns in local value declaration" parseExternDeclaration :: TokenParser Declaration parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *> parseExternAlt where @@ -231,7 +244,7 @@ parseDeclaration = positioned (P.choice parseLocalDeclaration :: TokenParser Declaration parseLocalDeclaration = positioned (P.choice [ parseTypeDeclaration - , parseValueDeclaration + , parseLocalValueDeclaration ] P. "local declaration") -- | Parse a module header and a collection of declarations diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index b110b05b8d..2c7bf0d1b0 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -18,6 +18,7 @@ import Language.PureScript.Externs import Language.PureScript.Sugar.BindingGroups as S import Language.PureScript.Sugar.CaseDeclarations as S import Language.PureScript.Sugar.DoNotation as S +import Language.PureScript.Sugar.LetPattern as S import Language.PureScript.Sugar.Names as S import Language.PureScript.Sugar.ObjectWildcards as S import Language.PureScript.Sugar.Operators as S @@ -57,7 +58,8 @@ desugar externs = map desugarSignedLiterals >>> traverse desugarObjectConstructors >=> traverse desugarDoModule - >=> traverse desugarCasesModule + >=> map desugarLetPatternModule + >>> traverse desugarCasesModule >=> traverse desugarTypeDeclarationsModule >=> desugarImports externs >=> rebracket externs diff --git a/src/Language/PureScript/Sugar/LetPattern.hs b/src/Language/PureScript/Sugar/LetPattern.hs new file mode 100644 index 0000000000..901522bdc3 --- /dev/null +++ b/src/Language/PureScript/Sugar/LetPattern.hs @@ -0,0 +1,47 @@ +-- | +-- This module implements the desugaring pass which replaces patterns in let-in +-- expressions with appropriate case expressions. +-- +module Language.PureScript.Sugar.LetPattern (desugarLetPatternModule) where + +import Prelude.Compat + +import Language.PureScript.AST + +-- | +-- Replace every @BoundValueDeclaration@ in @Let@ expressions with @Case@ +-- expressions. +-- +desugarLetPatternModule :: Module -> Module +desugarLetPatternModule (Module ss coms mn ds exts) = Module ss coms mn (map desugarLetPattern ds) exts + +-- | +-- Desugar a single let expression +-- +desugarLetPattern :: Declaration -> Declaration +desugarLetPattern (PositionedDeclaration pos com d) = PositionedDeclaration pos com $ desugarLetPattern d +desugarLetPattern decl = + let (f, _, _) = everywhereOnValues id replace id + in f decl + where + replace :: Expr -> Expr + replace (Let ds e) = go ds e + replace other = other + + go :: [Declaration] + -- ^ Declarations to desugar + -> Expr + -- ^ The original let-in result expression + -> Expr + go [] e = e + go (pd@(PositionedDeclaration pos com d) : ds) e = + case d of + BoundValueDeclaration {} -> PositionedValue pos com $ go (d:ds) e + _ -> append pd $ go ds e + go (BoundValueDeclaration binder boundE : ds) e = + Case [boundE] [CaseAlternative [binder] [MkUnguarded $ go ds e]] + go (d:ds) e = append d $ go ds e + + append :: Declaration -> Expr -> Expr + append d (Let ds e) = Let (d:ds) e + append d e = Let [d] e diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 3720461515..a238daa831 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -277,6 +277,7 @@ typeCheckAll moduleName _ = traverse go addValue moduleName name ty nameKind return $ ValueDeclaration name nameKind [] [MkUnguarded val''] go ValueDeclaration{} = internalError "Binders were not desugared" + go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared" go (BindingGroupDeclaration vals) = do env <- getEnv warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do From 57828dd64a25db5d6006f58c2802fec40ab2bef7 Mon Sep 17 00:00:00 2001 From: Hyunje Jun Date: Sat, 11 Feb 2017 06:43:02 +0900 Subject: [PATCH 0669/1580] Update CLI error and helper messages (#2650) * Update CLI error and helper messages This is concerning recent changes in executables, and also #2573. * Distinguish failure cases for purs repl * Use the name PSCi instead of PureScript REPL * Remove duplicated newlines in REPL error messages * Modify supportModuleMessage to be more helpful --- app/Command/Bundle.hs | 8 +++---- app/Command/Compile.hs | 8 ++++--- app/Command/Docs.hs | 6 +++--- app/Command/REPL.hs | 5 ++++- core-tests/test-everything.sh | 4 ++-- .../PureScript/Interactive/Message.hs | 21 ++++++++++++------- 6 files changed, 32 insertions(+), 20 deletions(-) diff --git a/app/Command/Bundle.hs b/app/Command/Bundle.hs index 3e0e8e9544..4ea338a241 100644 --- a/app/Command/Bundle.hs +++ b/app/Command/Bundle.hs @@ -18,7 +18,7 @@ import Control.Monad.IO.Class import System.FilePath (takeDirectory, (), (<.>), takeFileName) import System.FilePath.Glob (glob) import System.Exit (exitFailure) -import System.IO (stderr, hPutStrLn) +import System.IO (stderr, hPutStr, hPutStrLn) import System.IO.UTF8 (readUTF8File, writeUTF8File) import System.Directory (createDirectoryIfMissing, getCurrentDirectory) import qualified Data.ByteString.Lazy as B @@ -46,10 +46,10 @@ app :: (MonadError ErrorMessage m, MonadIO m) => Options -> m (Maybe SourceMappi app Options{..} = do inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles when (null inputFiles) . liftIO $ do - hPutStrLn stderr "psc-bundle: No input files." + hPutStrLn stderr "purs bundle: No input files." exitFailure when (isNothing optionsOutputFile && optionsSourceMaps == True) . liftIO $ do - hPutStrLn stderr "psc-bundle: Source maps only supported when output file specified." + hPutStrLn stderr "purs bundle: Source maps only supported when output file specified." exitFailure input <- for inputFiles $ \filename -> do @@ -115,7 +115,7 @@ command = run <$> (Opts.helper <*> options) where output <- runExceptT (app opts) case output of Left err -> do - hPutStrLn stderr (unlines (printErrorMessage err)) + hPutStr stderr (unlines (printErrorMessage err)) exitFailure Right (sourcemap, js) -> case optionsOutputFile opts of diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 2f72e0df22..ec17dc3536 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -22,7 +22,7 @@ import qualified Options.Applicative as Opts import qualified System.Console.ANSI as ANSI import System.Exit (exitSuccess, exitFailure) import System.FilePath.Glob (glob) -import System.IO (hPutStrLn, stderr) +import System.IO (hPutStr, hPutStrLn, stderr) import System.IO.UTF8 (readUTF8FileT) data PSCMakeOptions = PSCMakeOptions @@ -55,7 +55,9 @@ compile :: PSCMakeOptions -> IO () compile PSCMakeOptions{..} = do input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput when (null input && not pscmJSONErrors) $ do - hPutStrLn stderr "psc: No input files." + hPutStr stderr $ unlines [ "purs compile: No input files." + , "Usage: For basic information, try the `--help' option." + ] exitFailure moduleFiles <- readInput input (makeErrors, makeWarnings) <- runMake pscmOpts $ do @@ -68,7 +70,7 @@ compile PSCMakeOptions{..} = do exitSuccess warnFileTypeNotFound :: String -> IO () -warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++) +warnFileTypeNotFound = hPutStrLn stderr . ("purs compile: No files found using pattern: " ++) globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath] globWarningOnMisses warn = concatMapM globWithWarning diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index d0890286bb..93a7de67a8 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -79,10 +79,10 @@ docgen (PSCDocsOptions fmt inputGlob output) = do where guardMissing [] = return () guardMissing [mn] = do - hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ T.unpack (P.runModuleName mn) ++ "\"") + hPutStrLn stderr ("purs docs: error: unknown module \"" ++ T.unpack (P.runModuleName mn) ++ "\"") exitFailure guardMissing mns = do - hPutStrLn stderr "psc-docs: error: unknown modules:" + hPutStrLn stderr "purs docs: error: unknown modules:" forM_ mns $ \mn -> hPutStrLn stderr (" * " ++ T.unpack (P.runModuleName mn)) exitFailure @@ -209,7 +209,7 @@ buildOptions (fmt, input, mapping) = case parseDocgen mapping of Right mapping' -> return (PSCDocsOptions fmt input mapping') Left err -> do - hPutStrLn stderr "psc-docs: error in --docgen option:" + hPutStrLn stderr "purs docs: error in --docgen option:" hPutStrLn stderr (" " ++ err) exitFailure diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 8bb42fe39c..7e8c42cd68 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -310,8 +310,11 @@ command = loop <$> options inputFiles <- concat <$> traverse glob psciInputFile e <- runExceptT $ do modules <- ExceptT (loadAllModules inputFiles) + when (null modules) . liftIO $ do + putStr noInputMessage + exitFailure unless (supportModuleIsDefined (map snd modules)) . liftIO $ do - putStrLn supportModuleMessage + putStr supportModuleMessage exitFailure (externs, env) <- ExceptT . runMake . make $ modules return (modules, externs, env) diff --git a/core-tests/test-everything.sh b/core-tests/test-everything.sh index 4d0602448b..48bb827619 100755 --- a/core-tests/test-everything.sh +++ b/core-tests/test-everything.sh @@ -26,8 +26,8 @@ if [ "$force_recompile" = "true" ] && [ -d "output" ]; then rm -r output fi -stack exec psc 'tests/**/*.purs' 'bower_components/purescript-*/src/**/*.purs' +stack exec purs compile 'tests/**/*.purs' 'bower_components/purescript-*/src/**/*.purs' -stack exec psc-docs 'bower_components/purescript-*/src/**/*.purs' > core-docs.md +stack exec purs docs 'bower_components/purescript-*/src/**/*.purs' > core-docs.md NODE_PATH=output node -e "require('Test.Main').main()" diff --git a/src/Language/PureScript/Interactive/Message.hs b/src/Language/PureScript/Interactive/Message.hs index e340da1471..337ce28d18 100644 --- a/src/Language/PureScript/Interactive/Message.hs +++ b/src/Language/PureScript/Interactive/Message.hs @@ -10,6 +10,10 @@ import Language.PureScript.Interactive.Types -- Messages +-- | The guide URL +guideURL :: String +guideURL = "https://github.com/purescript/documentation/blob/master/guides/PSCi.md" + -- | The help message. helpMessage :: String helpMessage = "The following commands are available:\n\n " ++ @@ -28,7 +32,7 @@ helpMessage = "The following commands are available:\n\n " ++ extraHelp = "Further information is available on the PureScript documentation repository:\n" ++ - " --> https://github.com/purescript/documentation/blob/master/PSCi.md" + " --> " ++ guideURL -- | The welcome prologue. prologueMessage :: String @@ -37,18 +41,21 @@ prologueMessage = unlines , "Type :? for help" ] +noInputMessage :: String +noInputMessage = unlines + [ "purs repl: No input files; try running `pulp psci` instead." + , "For help getting started, visit " ++ guideURL + , "Usage: For basic information, try the `--help' option." + ] + supportModuleMessage :: String supportModuleMessage = unlines - [ "PSCi requires the psci-support package to be installed." + [ "purs repl: PSCi requires the psci-support package to be installed." , "You can install it using Bower as follows:" , "" , " bower i purescript-psci-support --save-dev" , "" - , "Or using psc-package:" - , "" - , " psc-package install psci-support" - , "" - , "For help getting started, visit https://github.com/purescript/documentation/blob/master/PSCi.md" + , "For help getting started, visit " ++ guideURL ] -- | The quit message. From 563b8e2e7fed44ec42366545f4a5e6bc9c1d230a Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 11 Feb 2017 12:49:47 -0800 Subject: [PATCH 0670/1580] Misc. work on #2567 and the skolem escape check (#2643) --- examples/failing/2567.purs | 5 + src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Errors.hs | 15 +- .../PureScript/TypeChecker/Skolems.hs | 162 +++++++++--------- src/Language/PureScript/TypeChecker/Types.hs | 28 +-- 5 files changed, 114 insertions(+), 98 deletions(-) create mode 100644 examples/failing/2567.purs diff --git a/examples/failing/2567.purs b/examples/failing/2567.purs new file mode 100644 index 0000000000..00f8ea844b --- /dev/null +++ b/examples/failing/2567.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +foo :: Int +foo = (0 :: Fail "This constraint should be checked" => Int) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index c6ebf9ebcc..eb6be99b88 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -83,7 +83,7 @@ data SimpleErrorMessage | NameIsUndefined Ident | UndefinedTypeVariable (ProperName 'TypeName) | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName)) - | EscapedSkolem (Maybe Expr) + | EscapedSkolem Text (Maybe SourceSpan) Type | TypesDoNotUnify Type Type | KindsDoNotUnify Kind Kind | ConstrainedTypeUnified Type Type diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 7637c50f72..ee4e492134 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -545,11 +545,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS paras [ line $ "Type synonym " <> markCode (showQualified runProperName name) <> " is partially applied." , line "Type synonyms must be applied to all of their type arguments." ] - renderSimpleErrorMessage (EscapedSkolem binding) = - paras $ [ line "A type variable has escaped its scope." ] - <> foldMap (\expr -> [ line "Relevant expression: " - , markCodeBox $ indent $ prettyPrintValue valueDepth expr - ]) binding + renderSimpleErrorMessage (EscapedSkolem name Nothing ty) = + paras [ line $ "The type variable " <> markCode name <> " has escaped its scope, appearing in the type" + , markCodeBox $ indent $ typeAsBox ty + ] + renderSimpleErrorMessage (EscapedSkolem name (Just srcSpan) ty) = + paras [ line $ "The type variable " <> markCode name <> ", bound at" + , indent $ line $ displaySourceSpan srcSpan + , line "has escaped its scope, appearing in the type" + , markCodeBox $ indent $ typeAsBox ty + ] renderSimpleErrorMessage (TypesDoNotUnify u1 u2) = let (sorted1, sorted2) = sortRows u1 u2 diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 7b0ee12a2e..0b6ef54537 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -1,6 +1,4 @@ --- | --- Functions relating to skolemization used during typechecking --- +-- | Functions relating to skolemization used during typechecking module Language.PureScript.TypeChecker.Skolems ( newSkolemConstant , introduceSkolemScope @@ -14,12 +12,11 @@ import Prelude.Compat import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets, modify) - +import Data.Foldable (traverse_) import Data.Functor.Identity (Identity(), runIdentity) -import Data.List (nub, (\\)) import Data.Monoid +import Data.Set (Set, fromList, notMember) import Data.Text (Text) - import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Errors @@ -27,102 +24,107 @@ import Language.PureScript.Traversals (defS) import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types --- | --- Generate a new skolem constant --- -newSkolemConstant :: (MonadState CheckState m) => m Int +-- | Generate a new skolem constant +newSkolemConstant :: MonadState CheckState m => m Int newSkolemConstant = do s <- gets checkNextSkolem modify $ \st -> st { checkNextSkolem = s + 1 } return s --- | --- Introduce skolem scope at every occurence of a ForAll --- -introduceSkolemScope :: (MonadState CheckState m) => Type -> m Type +-- | Introduce skolem scope at every occurence of a ForAll +introduceSkolemScope :: MonadState CheckState m => Type -> m Type introduceSkolemScope = everywhereOnTypesM go where go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope) go other = return other --- | --- Generate a new skolem scope --- -newSkolemScope :: (MonadState CheckState m) => m SkolemScope +-- | Generate a new skolem scope +newSkolemScope :: MonadState CheckState m => m SkolemScope newSkolemScope = do s <- gets checkNextSkolemScope modify $ \st -> st { checkNextSkolemScope = s + 1 } return $ SkolemScope s --- | --- Skolemize a type variable by replacing its instances with fresh skolem constants --- +-- | Skolemize a type variable by replacing its instances with fresh skolem constants skolemize :: Text -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss) --- | --- This function has one purpose - to skolemize type variables appearing in a --- DeferredDictionary placeholder. These type variables are somewhat unique since they are the --- only example of scoped type variables. --- +-- | This function skolemizes type variables appearing in any type signatures or +-- 'DeferredDictionary' placeholders. These type variables are the only places +-- where scoped type variables can appear in expressions. skolemizeTypesInValue :: Text -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr skolemizeTypesInValue ident sko scope ss = - let - (_, f, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS - in runIdentity . f + runIdentity . onExpr' where - onExpr :: [Text] -> Expr -> Identity ([Text], Expr) - onExpr sco (DeferredDictionary c ts) - | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts)) - onExpr sco (TypedValue check val ty) - | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty)) - onExpr sco other = return (sco, other) - - onBinder :: [Text] -> Binder -> Identity ([Text], Binder) - onBinder sco (TypedBinder ty b) - | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ss ty) b) - onBinder sco other = return (sco, other) - - peelTypeVars :: Type -> [Text] - peelTypeVars (ForAll i ty _) = i : peelTypeVars ty - peelTypeVars _ = [] - --- | --- Ensure skolem variables do not escape their scope + onExpr' :: Expr -> Identity Expr + (_, onExpr', _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS + + onExpr :: [Text] -> Expr -> Identity ([Text], Expr) + onExpr sco (DeferredDictionary c ts) + | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts)) + onExpr sco (TypedValue check val ty) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty)) + onExpr sco other = return (sco, other) + + onBinder :: [Text] -> Binder -> Identity ([Text], Binder) + onBinder sco (TypedBinder ty b) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ss ty) b) + onBinder sco other = return (sco, other) + + peelTypeVars :: Type -> [Text] + peelTypeVars (ForAll i ty _) = i : peelTypeVars ty + peelTypeVars _ = [] + +-- | Ensure skolem variables do not escape their scope -- -skolemEscapeCheck :: (MonadError MultipleErrors m) => Expr -> m () +-- Every skolem variable is created when a 'ForAll' type is skolemized. +-- This determines the scope of that skolem variable, which is copied from +-- the 'SkolemScope' field of the 'ForAll' constructor. +-- +-- This function traverses the tree top-down, and collects any 'SkolemScope's +-- introduced by 'ForAll's. If a 'Skolem' is encountered whose 'SkolemScope' is +-- not in the current list, then we have found an escaped skolem variable. +skolemEscapeCheck :: MonadError MultipleErrors m => Expr -> m () skolemEscapeCheck (TypedValue False _ _) = return () -skolemEscapeCheck root@TypedValue{} = - -- Every skolem variable is created when a ForAll type is skolemized. - -- This determines the scope of that skolem variable, which is copied from the SkolemScope - -- field of the ForAll constructor. - -- We traverse the tree top-down, and collect any SkolemScopes introduced by ForAlls. - -- If a Skolem is encountered whose SkolemScope is not in the current list, we have found - -- an escaped skolem variable. - let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def - in case f root of - [] -> return () - ((binding, val) : _) -> throwError . singleError $ ErrorMessage [ ErrorInExpression val ] $ EscapedSkolem binding +skolemEscapeCheck expr@TypedValue{} = + traverse_ (throwError . singleError) (toSkolemErrors expr) where - def s _ = (s, []) - - go :: [(SkolemScope, Expr)] -> Expr -> ([(SkolemScope, Expr)], [(Maybe Expr, Expr)]) - go scos val@(TypedValue _ _ (ForAll _ _ (Just sco))) = ((sco, val) : scos, []) - go scos val@(TypedValue _ _ ty) = case collectSkolems ty \\ map fst scos of - (sco : _) -> (scos, [(findBindingScope sco, val)]) - _ -> (scos, []) - where - collectSkolems :: Type -> [SkolemScope] - collectSkolems = nub . everythingOnTypes (++) collect + toSkolemErrors :: Expr -> [ErrorMessage] + (_, toSkolemErrors, _, _, _) = everythingWithContextOnValues (mempty, Nothing) [] (<>) def go def def def + + def s _ = (s, []) + + go :: (Set SkolemScope, Maybe SourceSpan) + -> Expr + -> ((Set SkolemScope, Maybe SourceSpan), [ErrorMessage]) + go (scopes, _) (PositionedValue ss _ _) = ((scopes, Just ss), []) + go (scopes, ssUsed) val@(TypedValue _ _ ty) = + ( (allScopes, ssUsed) + , [ ErrorMessage (maybe id ((:) . PositionedError) ssUsed [ ErrorInExpression val ]) $ + EscapedSkolem name ssBound ty + | (name, scope, ssBound) <- collectSkolems ty + , notMember scope allScopes + ] + ) where - collect (Skolem _ _ scope _) = [scope] - collect _ = [] - go scos _ = (scos, []) - findBindingScope :: SkolemScope -> Maybe Expr - findBindingScope sco = - let (_, f, _, _, _) = everythingOnValues mappend (const mempty) go' (const mempty) (const mempty) (const mempty) - in getFirst $ f root - where - go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val) - go' _ = mempty -skolemEscapeCheck _ = internalError "Untyped value passed to skolemEscapeCheck" + -- Any new skolem scopes introduced by universal quantifiers + newScopes :: [SkolemScope] + newScopes = collectScopes ty + + -- All scopes, including new scopes + allScopes :: Set SkolemScope + allScopes = fromList newScopes <> scopes + + -- Collect any scopes appearing in quantifiers at the top level + collectScopes :: Type -> [SkolemScope] + collectScopes (ForAll _ t (Just sco)) = sco : collectScopes t + collectScopes ForAll{} = internalError "skolemEscapeCheck: No skolem scope" + collectScopes _ = [] + + -- Collect any skolem variables appearing in a type + collectSkolems :: Type -> [(Text, SkolemScope, Maybe SourceSpan)] + collectSkolems = everythingOnTypes (++) collect where + collect (Skolem name _ scope srcSpan) = [(name, scope, srcSpan)] + collect _ = [] + go scos _ = (scos, []) +skolemEscapeCheck _ = internalError "skolemEscapeCheck: untyped value" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 03d5a1fad0..9641defadb 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -241,7 +241,7 @@ checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty -- Check the type with the new names in scope val' <- if checkType - then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val ty' <*> pure ty' + then withScopedTypeVars mn args $ bindNames dict $ check val ty' else return (TypedValue False val ty') return (ident, (val', ty')) @@ -377,7 +377,9 @@ infer' (Let ds val) = do infer' (DeferredDictionary className tys) = do dicts <- getTypeClassDictionaries hints <- gets checkHints - return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints + return $ TypedValue False + (TypeClassDictionary (Constraint className tys Nothing) dicts hints) + (foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys) infer' (TypedValue checkType val ty) = do Just moduleName <- checkCurrentModule <$> get (kind, args) <- kindOfWithScopedVars ty @@ -635,7 +637,7 @@ check' v@(Var var) ty = do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty elaborate <- subsumes repl ty' return $ TypedValue True (elaborate v) ty' -check' (DeferredDictionary className tys) _ = do +check' (DeferredDictionary className tys) ty = do {- -- Here, we replace a placeholder for a superclass dictionary with a regular -- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the @@ -644,18 +646,19 @@ check' (DeferredDictionary className tys) _ = do -} dicts <- getTypeClassDictionaries hints <- gets checkHints - return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints + return $ TypedValue False + (TypeClassDictionary (Constraint className tys Nothing) dicts hints) + ty check' (TypedValue checkType val ty1) ty2 = do - Just moduleName <- checkCurrentModule <$> get - (kind, args) <- kindOfWithScopedVars ty1 + kind <- kindOf ty1 checkTypeKind ty1 kind ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2 - _ <- subsumes ty1' ty2' + elaborate <- subsumes ty1' ty2' val' <- if checkType - then withScopedTypeVars moduleName args (check val ty2') - else return val - return $ TypedValue checkType val' ty2' + then check val ty1' + else pure val + return $ TypedValue True (TypedValue checkType (elaborate val') ty1') ty2' check' (Case vals binders) ret = do (vals', ts) <- instantiateForBinders vals binders binders' <- checkBinders ts ret binders @@ -692,8 +695,9 @@ check' v@(Constructor c) ty = do Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c Just (_, _, ty1, _) -> do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 - elaborate <- subsumes repl ty - return $ TypedValue True (elaborate v) ty + ty' <- introduceSkolemScope ty + elaborate <- subsumes repl ty' + return $ TypedValue True (elaborate v) ty' check' (Let ds val) ty = do (ds', val') <- inferLetBinding [] ds val (`check` ty) return $ TypedValue True (Let ds' val') ty From 98aad3b4411f43a15b73017c31e9da65bb1ccb90 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 11 Feb 2017 12:49:58 -0800 Subject: [PATCH 0671/1580] Instantiate types in record literals as necessary (#2625) * Instantiate types in record literals as necessary * Fix typo * Don't instantiate if there is a type annotation --- examples/passing/1110.purs | 26 ++++++++++++++++++++ src/Language/PureScript/TypeChecker/Types.hs | 25 +++++++++++++++---- 2 files changed, 46 insertions(+), 5 deletions(-) create mode 100644 examples/passing/1110.purs diff --git a/examples/passing/1110.purs b/examples/passing/1110.purs new file mode 100644 index 0000000000..f475fc028b --- /dev/null +++ b/examples/passing/1110.purs @@ -0,0 +1,26 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +data X a = X + +x :: forall a. X a +x = X + +type Y = { x :: X Int } + +test :: forall m. Monad m => m Y +test = pure { x: x } + +type Z t = forall x. t x -> (forall a. t a) -> t x + +class C t where c :: Z t + +instance cA :: C Array where + c x _ = x + +test2 :: forall m. Monad m => m { ccc :: Z Array } +test2 = pure { ccc: (c :: Z Array) } + +main = log "Done" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 9641defadb..6a7891f973 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -297,7 +297,8 @@ infer val = withErrorMessageHint (ErrorInferringType val) $ infer' val -- | Infer a type for a value infer' - :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + :: forall m + . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> m Expr infer' v@(Literal (NumericLiteral (Left _))) = return $ TypedValue True v tyInt @@ -315,10 +316,24 @@ infer' (Literal (ArrayLiteral vals)) = do return $ TypedValue True (Literal (ArrayLiteral ts')) (TypeApp tyArray els) infer' (Literal (ObjectLiteral ps)) = do ensureNoDuplicateProperties ps - ts <- traverse (infer . snd) ps - let fields = zipWith (\name (TypedValue _ _ t) -> (Label name, t)) (map fst ps) ts - ty = TypeApp tyRecord $ rowFromList (fields, REmpty) - return $ TypedValue True (Literal (ObjectLiteral (zip (map fst ps) ts))) ty + -- We make a special case for Vars in record labels, since these are the + -- only types of expressions for which 'infer' can return a polymorphic type. + -- They need to be instantiated here. + let shouldInstantiate :: Expr -> Bool + shouldInstantiate Var{} = True + shouldInstantiate (PositionedValue _ _ e) = shouldInstantiate e + shouldInstantiate _ = False + + inferProperty :: (PSString, Expr) -> m (PSString, (Expr, Type)) + inferProperty (name, val) = do + TypedValue _ val' ty <- infer val + valAndType <- if shouldInstantiate val + then instantiatePolyTypeWithUnknowns val' ty + else pure (val', ty) + pure (name, valAndType) + fields <- forM ps inferProperty + let ty = TypeApp tyRecord $ rowFromList (map (Label *** snd) fields, REmpty) + return $ TypedValue True (Literal (ObjectLiteral (map (fmap (uncurry (TypedValue True))) fields))) ty infer' (ObjectUpdate o ps) = do ensureNoDuplicateProperties ps row <- freshType From 4e1ff0f44257ade7123bc19e454478442836bcd9 Mon Sep 17 00:00:00 2001 From: rightfold Date: Sun, 12 Feb 2017 20:40:20 +0100 Subject: [PATCH 0672/1580] Emit _ instead of false case for if-then-else (#2654) This makes for better code generation. --- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index ec0664560e..1341236415 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -102,7 +102,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1] [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True] (Right $ exprToCoreFn Nothing [] Nothing v2) - , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False] + , CaseAlternative [NullBinder nullAnn] (Right $ exprToCoreFn Nothing [] Nothing v3) ] exprToCoreFn ss com ty (A.Constructor name) = Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name From bb55f9399e9298930c7fe45a5070bac383f659a8 Mon Sep 17 00:00:00 2001 From: Hyunje Jun Date: Tue, 14 Feb 2017 02:14:24 +0900 Subject: [PATCH 0673/1580] Use Stackage LTS 8.0 (#2659) * Use Stackage LTS 8.0 * Poke Travis CI --- stack-ghc-8.0.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack-ghc-8.0.yaml b/stack-ghc-8.0.yaml index 3db884660f..8f9ec68f50 100644 --- a/stack-ghc-8.0.yaml +++ b/stack-ghc-8.0.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2017-01-31 +resolver: lts-8.0 packages: - '.' extra-deps: From 8777583168969b3c99466a3d3e163da93d6bbdda Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 14 Feb 2017 14:12:09 -0800 Subject: [PATCH 0674/1580] Use Discard class to catch values which are implicitly discarded (#2653) * Use Discard class to catch values which are implicitly discarded, fix #1803 * Bump test dependencies * Fix tests, improve error messages * Fix the optimizer * Update bower.json * Fix versions --- examples/passing/Collatz.purs | 4 +- examples/passing/Console.purs | 6 +-- examples/passing/DctorOperatorAlias.purs | 2 +- examples/passing/Do.purs | 4 +- examples/passing/Eff.purs | 4 +- examples/passing/Fib.purs | 4 +- examples/passing/RebindableSyntax.purs | 4 +- examples/passing/SequenceDesugared.purs | 8 ++-- examples/passing/StringEscapes.purs | 2 +- examples/passing/TypedBinders.purs | 6 +-- src/Language/PureScript/AST/Declarations.hs | 2 +- .../CodeGen/JS/Optimizer/MagicDo.hs | 18 +++++-- src/Language/PureScript/Constants.hs | 12 +++++ src/Language/PureScript/Errors.hs | 14 ++++-- src/Language/PureScript/Sugar/DoNotation.hs | 47 ++++++++++--------- src/Language/PureScript/Types.hs | 2 +- tests/support/bower.json | 10 ++-- 17 files changed, 90 insertions(+), 59 deletions(-) diff --git a/examples/passing/Collatz.purs b/examples/passing/Collatz.purs index 6cdb36371a..0fda815c7a 100644 --- a/examples/passing/Collatz.purs +++ b/examples/passing/Collatz.purs @@ -10,9 +10,9 @@ collatz n = runPure (runST (do r <- newSTRef n count <- newSTRef 0 untilE $ do - modifySTRef count $ (+) 1 + _ <- modifySTRef count $ (+) 1 m <- readSTRef r - writeSTRef r $ if m `mod` 2 == 0 then m / 2 else 3 * m + 1 + _ <- writeSTRef r $ if m `mod` 2 == 0 then m / 2 else 3 * m + 1 pure $ m == 1 readSTRef count)) diff --git a/examples/passing/Console.purs b/examples/passing/Console.purs index 2f442ae4cf..2009733db6 100644 --- a/examples/passing/Console.purs +++ b/examples/passing/Console.purs @@ -4,10 +4,10 @@ import Prelude import Control.Monad.Eff import Control.Monad.Eff.Console -replicateM_ :: forall m a. (Monad m) => Number -> m a -> m {} -replicateM_ 0.0 _ = pure {} +replicateM_ :: forall m a. (Monad m) => Number -> m a -> m Unit +replicateM_ 0.0 _ = pure unit replicateM_ n act = do - act + _ <- act replicateM_ (n - 1.0) act main = do diff --git a/examples/passing/DctorOperatorAlias.purs b/examples/passing/DctorOperatorAlias.purs index c07fe950e6..0a12c8f06a 100644 --- a/examples/passing/DctorOperatorAlias.purs +++ b/examples/passing/DctorOperatorAlias.purs @@ -1,6 +1,6 @@ module Main where - import Prelude (Unit, bind, (==)) + import Prelude (Unit, bind, discard, (==)) import Control.Monad.Eff (Eff) import Control.Monad.Eff.Console (CONSOLE, log) import Test.Assert (ASSERT, assert') diff --git a/examples/passing/Do.purs b/examples/passing/Do.purs index 3cfa9e4183..0dd00c68d0 100644 --- a/examples/passing/Do.purs +++ b/examples/passing/Do.purs @@ -31,8 +31,8 @@ test2 = \_ -> do Just (x + y) test3 = \_ -> do - Just 1.0 - Nothing :: Maybe Number + _ <- Just 1.0 + _ <- Nothing :: Maybe Number Just 2.0 test4 mx my = do diff --git a/examples/passing/Eff.purs b/examples/passing/Eff.purs index f0b1ea8714..4c74c2522d 100644 --- a/examples/passing/Eff.purs +++ b/examples/passing/Eff.purs @@ -11,12 +11,12 @@ test1 = do test2 = runPure (runST (do ref <- newSTRef 0.0 - modifySTRef ref $ \n -> n + 1.0 + _ <- modifySTRef ref $ \n -> n + 1.0 readSTRef ref)) test3 = pureST (do ref <- newSTRef 0.0 - modifySTRef ref $ \n -> n + 1.0 + _ <- modifySTRef ref $ \n -> n + 1.0 readSTRef ref) main = do diff --git a/examples/passing/Fib.purs b/examples/passing/Fib.purs index 83220aa572..c9729c7ae2 100644 --- a/examples/passing/Fib.purs +++ b/examples/passing/Fib.purs @@ -12,7 +12,7 @@ main = do whileE ((>) 1000.0 <$> readSTRef n1) $ do n1' <- readSTRef n1 n2' <- readSTRef n2 - writeSTRef n2 $ n1' + n2' - writeSTRef n1 n2' + _ <- writeSTRef n2 $ n1' + n2' + _ <- writeSTRef n1 n2' logShow n2' log "Done" diff --git a/examples/passing/RebindableSyntax.purs b/examples/passing/RebindableSyntax.purs index 95303a8360..0b5f7d8871 100644 --- a/examples/passing/RebindableSyntax.purs +++ b/examples/passing/RebindableSyntax.purs @@ -10,7 +10,7 @@ example1 = do " for" " Semigroup" where - bind x f = x <> f unit + discard x f = x <> f unit applySecond :: forall f a b. (Apply f) => f a -> f b -> f b applySecond fa fb = const id <$> fa <*> fb @@ -35,7 +35,7 @@ example2 = do Const " for" Const " Apply" where - bind x f = x *> f unit + discard x f = x *> f unit main = do log example1 diff --git a/examples/passing/SequenceDesugared.purs b/examples/passing/SequenceDesugared.purs index f4ea3d1bb4..f9243f6f2f 100644 --- a/examples/passing/SequenceDesugared.purs +++ b/examples/passing/SequenceDesugared.purs @@ -32,7 +32,7 @@ sequenceList''' = Sequence ((\val -> case val of Cons x xs -> Cons <$> x <*> sequence sequenceList''' xs) :: forall m a. (Monad m) => List (m a) -> m (List a)) main = do - sequence sequenceList $ Cons (log "Done") Nil - sequence sequenceList' $ Cons (log "Done") Nil - sequence sequenceList'' $ Cons (log "Done") Nil - sequence sequenceList''' $ Cons (log "Done") Nil + void $ sequence sequenceList $ Cons (log "Done") Nil + void $ sequence sequenceList' $ Cons (log "Done") Nil + void $ sequence sequenceList'' $ Cons (log "Done") Nil + void $ sequence sequenceList''' $ Cons (log "Done") Nil diff --git a/examples/passing/StringEscapes.purs b/examples/passing/StringEscapes.purs index 9fbcab2028..f9d335e202 100644 --- a/examples/passing/StringEscapes.purs +++ b/examples/passing/StringEscapes.purs @@ -1,6 +1,6 @@ module Main where -import Prelude ((==), (/=), (<>), bind) +import Prelude ((==), (/=), (<>), discard) import Test.Assert (assert, assert') import Control.Monad.Eff.Console (log) diff --git a/examples/passing/TypedBinders.purs b/examples/passing/TypedBinders.purs index 2d3da7c67d..f2e96746c2 100644 --- a/examples/passing/TypedBinders.purs +++ b/examples/passing/TypedBinders.purs @@ -7,7 +7,7 @@ data Tuple a b = Tuple a b class MonadState s m where get :: m s - put :: s -> m {} + put :: s -> m Unit data State s a = State (s -> Tuple s a) @@ -30,9 +30,9 @@ instance monadState :: Monad (State s) instance monadStateState :: MonadState s (State s) where get = State (\s -> Tuple s s) - put s = State (\_ -> Tuple s {}) + put s = State (\_ -> Tuple s unit) -modify :: forall m s. (Monad m, MonadState s m) => (s -> s) -> m {} +modify :: forall m s. (Monad m, MonadState s m) => (s -> s) -> m Unit modify f = do s <- get put (f s) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index eb6be99b88..e14a05e8d3 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -140,7 +140,7 @@ data SimpleErrorMessage | CannotGeneralizeRecursiveFunction Ident Type | CannotDeriveNewtypeForData (ProperName 'TypeName) | ExpectedWildcard (ProperName 'TypeName) - | CannotUseBindWithDo + | CannotUseBindWithDo Ident -- | instance name, type class, expected argument count, actual argument count | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int -- | a user-defined warning raised by using the Warn type class diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs index 9066276497..6b0d036d58 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs @@ -33,12 +33,12 @@ magicDo = inlineST . everywhereOnJS undo . everywhereOnJSTopDown convert fnName = "__do" -- Desugar monomorphic calls to >>= and return for the Eff monad convert :: JS -> JS - -- Desugar pure & return + -- Desugar pure convert (JSApp _ (JSApp _ pure' [val]) []) | isPure pure' = val - -- Desugar >> - convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [] (JSBlock s2 js)]) | isBind bind = + -- Desugar discard + convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [] (JSBlock s2 js)]) | isDiscard bind = JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSApp s2 m [] : map applyReturns js ) - -- Desugar >>= + -- Desugar bind convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [arg] (JSBlock s2 js)]) | isBind bind = JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSVariableIntroduction s2 arg (Just (JSApp s2 m [])) : map applyReturns js) -- Desugar untilE @@ -51,13 +51,21 @@ magicDo = inlineST . everywhereOnJS undo . everywhereOnJSTopDown convert -- Check if an expression represents a monomorphic call to >>= for the Eff monad isBind (JSApp _ fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True isBind _ = False + -- Check if an expression represents a call to @discard@ + isDiscard (JSApp _ (JSApp _ fn [dict1]) [dict2]) + | isDict (C.controlBind, C.discardUnitDictionary) dict1 && + isDict (C.eff, C.bindEffDictionary) dict2 && + isDiscardPoly fn = True + isDiscard _ = False -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative isPure (JSApp _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True isPure _ = False -- Check if an expression represents the polymorphic >>= function isBindPoly = isDict (C.controlBind, C.bind) - -- Check if an expression represents the polymorphic pure or return function + -- Check if an expression represents the polymorphic pure function isPurePoly = isDict (C.controlApplicative, C.pure') + -- Check if an expression represents the polymorphic discard function + isDiscardPoly = isDict (C.controlBind, C.discard) -- Check if an expression represents a function in the Eff module isEffFunc name (JSIndexer _ (JSStringLiteral _ name') (JSVar _ eff)) = eff == C.eff && name == name' isEffFunc _ _ = False diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index baf9c109ee..6985c0a77f 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -34,6 +34,12 @@ append = "append" bind :: forall a. (IsString a) => a bind = "bind" +discard :: forall a. (IsString a) => a +discard = "discard" + +pattern Discard :: Qualified (ProperName 'ClassName) +pattern Discard = Qualified (Just ControlBind) (ProperName "Discard") + (+) :: forall a. (IsString a) => a (+) = "+" @@ -234,6 +240,9 @@ applicativeEffDictionary = "applicativeEff" bindEffDictionary :: forall a. (IsString a) => a bindEffDictionary = "bindEff" +discardUnitDictionary :: forall a. (IsString a) => a +discardUnitDictionary = "discardUnit" + semiringNumber :: forall a. (IsString a) => a semiringNumber = "semiringNumber" @@ -412,6 +421,9 @@ controlApplicative = "Control_Applicative" controlSemigroupoid :: forall a. (IsString a) => a controlSemigroupoid = "Control_Semigroupoid" +pattern ControlBind :: ModuleName +pattern ControlBind = ModuleName [ProperName "Control", ProperName "Bind"] + controlBind :: forall a. (IsString a) => a controlBind = "Control_Bind" diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index ee4e492134..89a73c93e4 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -491,7 +491,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS line $ "The type declaration for " <> markCode (showIdent nm) <> " should be followed by its definition." renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" - renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident "bind")))) = + renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident i)))) | i `elem` [ C.bind, C.discard ] = line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode "bind" <> " function. Please import " <> markCode "bind" <> " from module " <> markCode "Prelude" renderSimpleErrorMessage (UnknownName name) = line $ "Unknown " <> printName name @@ -617,13 +617,19 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS _ (Just (PartialConstraintData bs b)))) = paras [ line "A case expression could not be determined to cover all inputs." - , line "The following additional cases are required to cover all inputs:\n" + , line "The following additional cases are required to cover all inputs:" , indent $ paras $ Box.hsep 1 Box.left (map (paras . map (line . markCode)) (transpose bs)) : [line "..." | not b] , line "Alternatively, add a Partial constraint to the type of the enclosing value." ] + renderSimpleErrorMessage (NoInstanceFound (Constraint C.Discard [ty] _)) = + paras [ line "A result of type" + , markCodeBox $ indent $ typeAsBox ty + , line "was implicitly discarded in a do notation block." + , line ("You can use " <> markCode "_ <- ..." <> " to explicitly discard the result.") + ] renderSimpleErrorMessage (NoInstanceFound (Constraint nm ts _)) = paras [ line "No type class instance was found for" , markCodeBox $ indent $ Box.hsep 1 Box.left @@ -875,8 +881,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS paras [ line $ "Expected a type wildcard (_) when deriving an instance for " <> markCode (runProperName tyName) <> "." ] - renderSimpleErrorMessage CannotUseBindWithDo = - paras [ line $ "The name " <> markCode "bind" <> " cannot be brought into scope in a do notation block, since do notation uses the same name." + renderSimpleErrorMessage (CannotUseBindWithDo name) = + paras [ line $ "The name " <> markCode (showIdent name) <> " cannot be brought into scope in a do notation block, since do notation uses the same name." ] renderSimpleErrorMessage (ClassInstanceArityMismatch dictName className expected actual) = diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index ddf19112e7..534763267a 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -1,31 +1,28 @@ --- | --- This module implements the desugaring pass which replaces do-notation statements with +-- | This module implements the desugaring pass which replaces do-notation statements with -- appropriate calls to bind. --- -module Language.PureScript.Sugar.DoNotation (desugarDoModule) where -import Prelude.Compat +{-# LANGUAGE PatternGuards #-} + +module Language.PureScript.Sugar.DoNotation (desugarDoModule) where -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class +import Prelude.Compat -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Errors -import Language.PureScript.Names +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class +import Data.Monoid (First(..)) +import Language.PureScript.AST +import Language.PureScript.Crash +import Language.PureScript.Errors +import Language.PureScript.Names import qualified Language.PureScript.Constants as C --- | --- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with +-- | Replace all @DoNotationBind@ and @DoNotationValue@ constructors with -- applications of the bind function in scope, and all @DoNotationLet@ -- constructors with let expressions. --- desugarDoModule :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Module -> m Module desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarDo <*> pure exts --- | --- Desugar a single do statement --- +-- | Desugar a single do statement desugarDo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> rethrowWithPosition pos (desugarDo d) desugarDo d = @@ -35,6 +32,9 @@ desugarDo d = bind :: Expr bind = Var (Qualified Nothing (Ident C.bind)) + discard :: Expr + discard = Var (Qualified Nothing (Ident C.discard)) + replace :: Expr -> m Expr replace (Do els) = go els replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v) @@ -45,11 +45,14 @@ desugarDo d = go [DoNotationValue val] = return val go (DoNotationValue val : rest) = do rest' <- go rest - return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest') + return $ App (App discard val) (Abs (Left (Ident C.__unused)) rest') go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest) - go (DoNotationBind b _ : _) | Ident C.bind `elem` binderNames b = - throwError . errorMessage $ CannotUseBindWithDo + go (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) = + throwError . errorMessage $ CannotUseBindWithDo (Ident ident) + where + fromIdent (Ident i) | i `elem` [ C.bind, C.discard ] = First (Just i) + fromIdent _ = mempty go (DoNotationBind (VarBinder ident) val : rest) = do rest' <- go rest return $ App (App bind val) (Abs (Left ident) rest') @@ -60,8 +63,8 @@ desugarDo d = go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet go (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () - checkBind (ValueDeclaration (Ident name) _ _ _) - | name == C.bind = throwError . errorMessage $ CannotUseBindWithDo + checkBind (ValueDeclaration i@(Ident name) _ _ _) + | name `elem` [ C.bind, C.discard ] = throwError . errorMessage $ CannotUseBindWithDo i checkBind (PositionedDeclaration pos _ decl) = rethrowWithPosition pos (checkBind decl) checkBind _ = pure () mapM_ checkBind ds diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 55aa8f2d52..c07d8263fa 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -83,7 +83,7 @@ data ConstraintData -- ^ Data to accompany a Partial constraint generated by the exhaustivity checker. -- It contains (rendered) binder information for those binders which were -- not matched, and a flag indicating whether the list was truncated or not. - -- Note: we use 'String' here because using 'Binder' would introduce a cyclic + -- Note: we use 'Text' here because using 'Binder' would introduce a cyclic -- dependency in the module graph. deriving (Show, Eq, Ord) diff --git a/tests/support/bower.json b/tests/support/bower.json index aef775143c..9726e7b465 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -2,17 +2,19 @@ "name": "purescript-test-suite-support", "dependencies": { "purescript-assert": "2.0.0", + "purescript-arrays": "3.2.1", "purescript-console": "2.0.0", "purescript-eff": "2.0.0", "purescript-functions": "2.0.0", - "purescript-prelude": "2.1.0", + "purescript-prelude": "2.4.0", "purescript-st": "2.0.0", "purescript-partial": "1.1.2", "purescript-newtype": "1.1.0", "purescript-generics": "3.3.0", "purescript-generics-rep": "4.0.0", - "purescript-symbols": "^2.0.0", - "purescript-typelevel-prelude": "https://github.com/purescript/purescript-typelevel-prelude.git#29a7123a0c29c85d4b923fcf4a7df8e45ebf9bac", - "purescript-unsafe-coerce": "^2.0.0" + "purescript-symbols": "2.0.0", + "purescript-tailrec": "2.0.2", + "purescript-typelevel-prelude": "1.0.0", + "purescript-unsafe-coerce": "2.0.0" } } From eeaaa6ae4af17d44f71d314cccece119cd027c53 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Thu, 16 Feb 2017 01:02:16 +0000 Subject: [PATCH 0675/1580] Fix for unknown Warn type class constructor (#2666) --- examples/passing/2663.purs | 9 +++++++++ src/Language/PureScript/TypeChecker/Entailment.hs | 5 ++++- 2 files changed, 13 insertions(+), 1 deletion(-) create mode 100644 examples/passing/2663.purs diff --git a/examples/passing/2663.purs b/examples/passing/2663.purs new file mode 100644 index 0000000000..1bd70dcca5 --- /dev/null +++ b/examples/passing/2663.purs @@ -0,0 +1,9 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +foo :: forall t. Warn "Example" => t -> t +foo x = x + +main = when (foo 42 == 42) $ log "Done" diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 8d5d177395..590eed2aa2 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -317,7 +317,10 @@ entails SolverOptions{..} constraint context hints = mkDictionary (NamedInstance n) args = return $ foldl App (Var n) (fold args) mkDictionary (WarnInstance msg) _ = do tell . errorMessage $ UserDefinedWarning msg - return $ TypeClassDictionaryConstructorApp C.Warn (Literal (ObjectLiteral [])) + -- We cannot call the type class constructor here because Warn is declared in Prim. + -- This means that it doesn't have a definition that we can import. + -- So pass an empty object instead. + return $ Literal (ObjectLiteral []) mkDictionary (IsSymbolInstance sym) _ = let fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) ] in return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) From 5d58bbe57601ec676f1237b9c3df99b628b256c9 Mon Sep 17 00:00:00 2001 From: Hyunje Jun Date: Thu, 16 Feb 2017 12:50:48 +0900 Subject: [PATCH 0676/1580] PSCi command changes (#2665) * Fix `let ... in` doesn't work in PSCi It's fixed with placing the `psciLet` parser after the `psciExpression` parser. The issue was reported in #2630. * Support plain value declaration in PSCi without let * Remove psciLet psciDeclaration will cover all declarations. --- src/Language/PureScript/Interactive/Parser.hs | 27 ++++++------------- 1 file changed, 8 insertions(+), 19 deletions(-) diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index 160a04bc40..8e9fb55231 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -34,9 +34,8 @@ psciCommand :: P.TokenParser Command psciCommand = choice (map try parsers) where parsers = - [ psciLet - , psciImport - , psciOtherDeclaration + [ psciImport + , psciDeclaration , psciExpression ] @@ -75,18 +74,6 @@ parseDirective cmd = psciExpression :: P.TokenParser Command psciExpression = Expression <$> P.parseValue --- | --- PSCI version of @let@. --- This is essentially let from do-notation. --- However, since we don't support the @Eff@ monad, --- we actually want the normal @let@. --- -psciLet :: P.TokenParser Command -psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls) - where - manyDecls :: P.TokenParser [P.Declaration] - manyDecls = mark (many1 (same *> P.parseLocalDeclaration)) - -- | Imports must be handled separately from other declarations, so that -- :show import works, for example. psciImport :: P.TokenParser Command @@ -94,10 +81,10 @@ psciImport = do (mn, declType, asQ) <- P.parseImportDeclaration' return $ Import (mn, declType, asQ) --- | Any other declaration that we don't need a 'special case' parser for --- (like let or import declarations). -psciOtherDeclaration :: P.TokenParser Command -psciOtherDeclaration = Decls . (:[]) <$> do +-- | Any declaration that we don't need a 'special case' parser for +-- (like import declarations). +psciDeclaration :: P.TokenParser Command +psciDeclaration = fmap Decls $ mark $ many1 $ same *> do decl <- discardPositionInfo <$> P.parseDeclaration if acceptable decl then return decl @@ -115,6 +102,8 @@ acceptable P.ExternDataDeclaration{} = True acceptable P.TypeClassDeclaration{} = True acceptable P.TypeInstanceDeclaration{} = True acceptable P.ExternKindDeclaration{} = True +acceptable P.TypeDeclaration{} = True +acceptable P.ValueDeclaration{} = True acceptable _ = False parseReplQuery' :: String -> Either String ReplQuery From a6a48946a58d95b7ff901846820c82ccf9b6d3f0 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 18 Feb 2017 18:38:53 +0000 Subject: [PATCH 0677/1580] Update LICENSE (#2674) * Update LICENSE Now that we no longer depend on `turtle`. * Update license years --- LICENSE | 248 +---------------------------------- license-generator/header.txt | 2 +- 2 files changed, 2 insertions(+), 248 deletions(-) diff --git a/LICENSE b/LICENSE index 22727668bd..b25d9b37a8 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013-16 Phil Freeman, (c) 2014-2016 Gary Burgess, and other +Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other contributors All rights reserved. @@ -79,7 +79,6 @@ PureScript uses the following Haskell library packages. Their license files foll fast-logger file-embed filepath - foldl free fsnotify ghc-prim @@ -87,7 +86,6 @@ PureScript uses the following Haskell library packages. Their license files foll haskeline hex hinotify - hostname hourglass http-client http-client-tls @@ -100,7 +98,6 @@ PureScript uses the following Haskell library packages. Their license files foll language-javascript lens lifted-base - managed memory mime-types mmorph @@ -108,12 +105,10 @@ PureScript uses the following Haskell library packages. Their license files foll monad-logger monad-loops mtl - mwc-random network network-uri old-locale old-time - optional-args optparse-applicative parallel parsec @@ -146,12 +141,9 @@ PureScript uses the following Haskell library packages. Their license files foll streaming-commons stringsearch syb - system-fileio - system-filepath tagged tagsoup template-haskell - temporary terminfo text time @@ -159,7 +151,6 @@ PureScript uses the following Haskell library packages. Their license files foll transformers transformers-base transformers-compat - turtle uniplate unix unix-compat @@ -2285,33 +2276,6 @@ filepath LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -foldl LICENSE file: - - Copyright (c) 2013 Gabriel Gonzalez - All rights reserved. - - Redistribution and use in source and binary forms, with or without modification, - are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of Gabriel Gonzalez nor the names of other contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - free LICENSE file: Copyright 2008-2013 Edward Kmett @@ -2567,31 +2531,6 @@ hinotify LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -hostname LICENSE file: - - Copyright (c) 2008, Maximilian Bolingbroke - All rights reserved. - - Redistribution and use in source and binary forms, with or without modification, are permitted - provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, this list of - conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, this list of - conditions and the following disclaimer in the documentation and/or other materials - provided with the distribution. - * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to - endorse or promote products derived from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR - CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER - IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT - OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - hourglass LICENSE file: Copyright (c) 2014 Vincent Hanquez @@ -2962,33 +2901,6 @@ lifted-base LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -managed LICENSE file: - - Copyright (c) 2014 Gabriel Gonzalez - All rights reserved. - - Redistribution and use in source and binary forms, with or without modification, - are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of Gabriel Gonzalez nor the names of other contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - memory LICENSE file: Copyright (c) 2015 Vincent Hanquez @@ -3160,35 +3072,6 @@ mtl LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -mwc-random LICENSE file: - - Copyright (c) 2009, Bryan O'Sullivan - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - network LICENSE file: Copyright (c) 2002-2010, The University Court of the University of Glasgow. @@ -3385,33 +3268,6 @@ old-time LICENSE file: ----------------------------------------------------------------------------- -optional-args LICENSE file: - - Copyright (c) 2015 Gabriel Gonzalez - All rights reserved. - - Redistribution and use in source and binary forms, with or without modification, - are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of Gabriel Gonzalez nor the names of other contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - optparse-applicative LICENSE file: Copyright (c) 2012, Paolo Capriotti @@ -4499,56 +4355,6 @@ syb LICENSE file: ----------------------------------------------------------------------------- -system-fileio LICENSE file: - - Copyright (c) 2011 John Millikin - - Permission is hereby granted, free of charge, to any person - obtaining a copy of this software and associated documentation - files (the "Software"), to deal in the Software without - restriction, including without limitation the rights to use, - copy, modify, merge, publish, distribute, sublicense, and/or sell - copies of the Software, and to permit persons to whom the - Software is furnished to do so, subject to the following - conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES - OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT - HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, - WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING - FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR - OTHER DEALINGS IN THE SOFTWARE. - -system-filepath LICENSE file: - - Copyright (c) 2010 John Millikin - - Permission is hereby granted, free of charge, to any person - obtaining a copy of this software and associated documentation - files (the "Software"), to deal in the Software without - restriction, including without limitation the rights to use, - copy, modify, merge, publish, distribute, sublicense, and/or sell - copies of the Software, and to permit persons to whom the - Software is furnished to do so, subject to the following - conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES - OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT - HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, - WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING - FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR - OTHER DEALINGS IN THE SOFTWARE. - tagged LICENSE file: Copyright (c) 2009-2015 Edward Kmett @@ -4651,31 +4457,6 @@ template-haskell LICENSE file: DAMAGE. -temporary LICENSE file: - - Copyright (c) 2008, Maximilian Bolingbroke - All rights reserved. - - Redistribution and use in source and binary forms, with or without modification, are permitted - provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, this list of - conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, this list of - conditions and the following disclaimer in the documentation and/or other materials - provided with the distribution. - * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to - endorse or promote products derived from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR - CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER - IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT - OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - terminfo LICENSE file: Copyright 2007, Judah Jacobson. @@ -4871,33 +4652,6 @@ transformers-compat LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -turtle LICENSE file: - - Copyright (c) 2015 Gabriel Gonzalez - All rights reserved. - - Redistribution and use in source and binary forms, with or without modification, - are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of Gabriel Gonzalez nor the names of other contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - uniplate LICENSE file: Copyright Neil Mitchell 2006-2013. diff --git a/license-generator/header.txt b/license-generator/header.txt index 50ba5681ec..cdebf0bb84 100644 --- a/license-generator/header.txt +++ b/license-generator/header.txt @@ -1,4 +1,4 @@ -Copyright (c) 2013-16 Phil Freeman, (c) 2014-2016 Gary Burgess, and other +Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other contributors All rights reserved. From e5e83102a9776ea340296e58185674dff790b1ff Mon Sep 17 00:00:00 2001 From: Matt Coffin Date: Sat, 18 Feb 2017 14:01:41 -0700 Subject: [PATCH 0678/1580] publish: Allow for older git versions (#2673) * publish: Allow for older git versions * Update CONTRIBUTORS Add @mcoffin (Matt Coffin) [ci skip] --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Publish.hs | 7 ++++--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 673aa679ea..0108fe6d48 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -56,6 +56,7 @@ If you would prefer to use different terms, please use the section below instead | [@LiamGoodacre](https://github.com/LiamGoodacre) | Liam Goodacre | [MIT license](http://opensource.org/licenses/MIT) | | [@lukerandall](https://github.com/lukerandall) | Luke Randall | [MIT license](http://opensource.org/licenses/MIT) | | [@matthewleon](https://github.com/matthewleon) | Matthew Leon | [MIT license](http://opensource.org/licenses/MIT) | +| [@mcoffin](https://github.com/mcoffin) | Matt Coffin | [MIT license](http://opensource.org/licenses/MIT) | | [@mgmeier](https://github.com/mgmeier) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) | | [@michaelficarra](https://github.com/michaelficarra) | Michael Ficarra | [MIT license](http://opensource.org/licenses/MIT) | | [@MichaelXavier](https://github.com/MichaelXavier) | Michael Xavier | MIT license | diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 2af3f12ea2..6be579a5b7 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -37,6 +37,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Version import qualified Data.SPDX as SPDX @@ -194,9 +195,9 @@ getVersionFromGitTag = do -- | Given a git tag, get the time it was created. getTagTime :: Text -> PrepareM UTCTime getTagTime tag = do - out <- readProcess' "git" ["show", T.unpack tag, "--no-patch", "--format=%aI"] "" - case mapMaybe D.parseTime (lines out) of - [t] -> pure t + out <- readProcess' "git" ["tag", "-l", T.unpack tag, "--format=%(taggerdate:unix)"] "" + case mapMaybe readMaybe (lines out) of + [t] -> pure . posixSecondsToUTCTime . fromInteger $ t _ -> internalError (CouldntParseGitTagDate tag) getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo) From f7749972b6873a3fc18df93e2282020ea8297361 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 19 Feb 2017 16:46:25 -0800 Subject: [PATCH 0679/1580] Add ide-client command (#2678) * Fix #2675, add ide-client command * Naming * Use subcommands --- app/Command/Ide.hs | 70 ++++++++++++++++++++++++++++++++++------------ app/Main.hs | 2 +- 2 files changed, 53 insertions(+), 19 deletions(-) diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index b9a0f518ee..a88d236b6b 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -16,6 +16,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -27,7 +28,8 @@ import qualified Data.Aeson as Aeson import Control.Concurrent.STM import "monad-logger" Control.Monad.Logger import qualified Data.Text.IO as T -import qualified Data.ByteString.Lazy.Char8 as BS8 +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy.Char8 as BSL8 import GHC.IO.Exception (IOErrorType(..), IOException(..)) import Language.PureScript.Ide import Language.PureScript.Ide.Command @@ -59,21 +61,53 @@ listenOnLocalhost port = do listen sock maxListenQueue pure sock) -data Options = Options - { _optionsDirectory :: Maybe FilePath - , _optionsGlobs :: [FilePath] - , _optionsOutputPath :: FilePath - , _optionsPort :: PortNumber - , _optionsNoWatch :: Bool - , _optionsPolling :: Bool - , _optionsDebug :: Bool - , _optionsLoglevel :: IdeLogLevel +data ServerOptions = ServerOptions + { _serverDirectory :: Maybe FilePath + , _serverGlobs :: [FilePath] + , _serverOutputPath :: FilePath + , _serverPort :: PortNumber + , _serverNoWatch :: Bool + , _serverPolling :: Bool + , _serverDebug :: Bool + , _serverLoglevel :: IdeLogLevel } deriving (Show) +data ClientOptions = ClientOptions + { clientPort :: PortID + } + command :: Opts.Parser (IO ()) -command = run <$> (Opts.helper <*> parser) where - run :: Options -> IO () - run opts'@(Options dir globs outputPath port noWatch polling debug logLevel) = do +command = Opts.helper <*> subcommands where + subcommands :: Opts.Parser (IO ()) + subcommands = (Opts.subparser . fold) + [ Opts.command "server" + (Opts.info (fmap server serverOptions) + (Opts.progDesc "Start a server process")) + , Opts.command "client" + (Opts.info (fmap client clientOptions) + (Opts.progDesc "Connect to a running server")) + ] + + client :: ClientOptions -> IO () + client ClientOptions{..} = do + hSetEncoding stdin utf8 + hSetEncoding stdout utf8 + let handler (SomeException e) = do + T.putStrLn ("Couldn't connect to purs ide server on port " <> show clientPort <> ":") + print e + exitFailure + h <- connectTo "127.0.0.1" clientPort `catch` handler + T.hPutStrLn h =<< T.getLine + BS8.putStrLn =<< BS8.hGetLine h + hFlush stdout + hClose h + + clientOptions :: Opts.Parser ClientOptions + clientOptions = ClientOptions . PortNumber . fromIntegral <$> + Opts.option Opts.auto (Opts.long "port" <> Opts.short 'p' <> Opts.value (4242 :: Integer)) + + server :: ServerOptions -> IO () + server opts'@(ServerOptions dir globs outputPath port noWatch polling debug logLevel) = do when debug (putText "Parsed Options:" *> print opts') maybe (pure ()) setCurrentDirectory dir ideState <- newTVarIO emptyIdeState @@ -93,9 +127,9 @@ command = run <$> (Opts.helper <*> parser) where env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf} startServer port env - parser :: Opts.Parser Options - parser = - Options + serverOptions :: Opts.Parser ServerOptions + serverOptions = + ServerOptions <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd')) <*> many (Opts.argument Opts.str (Opts.metavar "Source GLOBS...")) <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/") @@ -141,8 +175,8 @@ startServer port env = withSocketsDo $ do -- $(logDebug) ("Answer was: " <> T.pack (show result)) liftIO (hFlush stdout) case result of - Right r -> liftIO $ catchGoneHandle (BS8.hPutStrLn h (Aeson.encode r)) - Left err -> liftIO $ catchGoneHandle (BS8.hPutStrLn h (Aeson.encode err)) + Right r -> liftIO $ catchGoneHandle (BSL8.hPutStrLn h (Aeson.encode r)) + Left err -> liftIO $ catchGoneHandle (BSL8.hPutStrLn h (Aeson.encode err)) Nothing -> do $(logError) ("Parsing the command failed. Command: " <> cmd) liftIO $ do diff --git a/app/Main.hs b/app/Main.hs index 32363b882a..f2761623c4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -54,7 +54,7 @@ main = do (Opts.progDesc "Generate a GraphViz directed graph of PureScript type classes")) , Opts.command "ide" (Opts.info Ide.command - (Opts.progDesc "Start an IDE server process")) + (Opts.progDesc "Start or query an IDE server process")) , Opts.command "publish" (Opts.info Publish.command (Opts.progDesc "Generates documentation packages for upload to Pursuit")) From 5925302cada4956a15449dc9bf05e34f64e579ef Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 20 Feb 2017 16:42:47 +0000 Subject: [PATCH 0680/1580] Include git commit information in non-release builds (#2669) This should help avoid confusion like in #2610. The output of `purs --version` is unchanged for release builds but includes extra information like the git tag for non-release builds. By default, `stack build` will produce a non-release build, which means that `purs --version` will include information like this: $ purs --version 0.10.6 [development build; commit: b8136e312fbda48990a576e0802e0c0c7d6cda5f] To make a release build, set the "release" cabal flag. With stack: $ stack build --flag purescript:RELEASE The Travis CI and AppVeyor scripts have been modified to do this where appropriate. --- app/Main.hs | 20 +++++++++++++++++++- appveyor.yml | 7 ++++++- license-generator/generate.hs | 2 +- purescript.cabal | 10 ++++++++++ travis/build.sh | 3 +++ 5 files changed, 39 insertions(+), 3 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index f2761623c4..25e55a879d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,6 +4,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} module Main where @@ -21,6 +23,10 @@ import qualified Options.Applicative as Opts import qualified Paths_purescript as Paths import qualified System.IO as IO +#ifndef RELEASE +import qualified Development.GitRev as GitRev +#endif + main :: IO () main = do IO.hSetEncoding IO.stdout IO.utf8 @@ -34,7 +40,7 @@ main = do footerInfo = Opts.footer $ "psc " ++ showVersion Paths.version versionInfo :: Opts.Parser (a -> a) - versionInfo = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $ + versionInfo = Opts.abortOption (Opts.InfoMsg versionString) $ Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden commands :: Opts.Parser (IO ()) @@ -62,3 +68,15 @@ main = do (Opts.info REPL.command (Opts.progDesc "Enter the interactive mode (PSCi)")) ] + +versionString :: String +versionString = showVersion Paths.version ++ extra + where +#ifdef RELEASE + extra = "" +#else + extra = " [development build; commit: " ++ $(GitRev.gitHash) ++ dirty ++ "]" + dirty + | $(GitRev.gitDirty) = " DIRTY" + | otherwise = "" +#endif diff --git a/appveyor.yml b/appveyor.yml index 3d8803d15d..25fbbcf581 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -27,9 +27,14 @@ install: build_script: # Override the default build script. +# In PowerShell it seems to be necessary to redirect stderr to stdout because +# any text sent to stderr seems to cause appveyor to think the build has +# failed. - echo "" test_script: -- stack -j1 --no-terminal test --pedantic +- if defined APPVEYOR_REPO_TAG_NAME (set stack_extra_flags="--flag purescript:RELEASE") +- echo "stack_extra_flags=%stack_extra_flags%" +- stack --jobs=1 --no-terminal test --pedantic %stack_extra_flags% on_success: - ps: | function UploadFile diff --git a/license-generator/generate.hs b/license-generator/generate.hs index ab47c7a572..e9c2a29fc1 100644 --- a/license-generator/generate.hs +++ b/license-generator/generate.hs @@ -6,7 +6,7 @@ -- -- It is recommended to run this as follows: -- --- stack list-dependencies | stack exec runhaskell license-generator/generate.hs > LICENSE +-- stack list-dependencies --flag purescript:RELEASE | stack exec runhaskell license-generator/generate.hs > LICENSE -- module Main (main) where diff --git a/purescript.cabal b/purescript.cabal index 0943155783..533e7943c7 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -111,6 +111,11 @@ source-repository head type: git location: https://github.com/purescript/purescript.git +flag release + description: Mark this build as a release build: prevents inclusion of extra + info e.g. commit SHA in --version output) + default: False + library build-depends: base >=4.8 && <5, aeson >= 0.8 && < 1.1, @@ -391,6 +396,11 @@ executable purs Command.REPL ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N" + if flag(release) + cpp-options: -DRELEASE + else + build-depends: gitrev >= 1.2.0 && <1.3 + test-suite tests build-depends: base >=4 && <5, purescript -any, diff --git a/travis/build.sh b/travis/build.sh index 284cb08596..679612883b 100755 --- a/travis/build.sh +++ b/travis/build.sh @@ -28,6 +28,9 @@ if [ -z "$TRAVIS_TAG" ] then # On non-release builds, disable optimizations. STACK_EXTRA_FLAGS="--fast" +else + # On release builds, set the 'release' cabal flag. + STACK_EXTRA_FLAGS="--flag purescript:RELEASE" fi if [ "$STACKAGE_NIGHTLY" = "true" ] From 0ee5b7495fae6319ca6f33a6691cf6cae1110466 Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Mon, 20 Feb 2017 11:40:47 -0800 Subject: [PATCH 0681/1580] replace nub with ordNub (#2679) Replace pervasive uses of nub with ordNub from Protolude, which has better asymptotics. Where necessary, derive some new Ord instances to help. --- app/Command/Docs.hs | 4 +++- app/Command/Hierarchy.hs | 6 ++++-- src/Language/PureScript/AST/Binders.hs | 2 +- src/Language/PureScript/Bundle.hs | 7 ++++--- src/Language/PureScript/CodeGen/JS.hs | 5 +++-- .../PureScript/CodeGen/JS/Optimizer/MagicDo.hs | 4 ++-- src/Language/PureScript/CoreFn/Desugar.hs | 9 +++++---- src/Language/PureScript/CoreFn/Meta.hs | 4 ++-- src/Language/PureScript/Environment.hs | 4 ++-- src/Language/PureScript/Errors.hs | 5 +++-- src/Language/PureScript/Interactive.hs | 5 +++-- src/Language/PureScript/Interactive/Completion.hs | 7 ++++--- src/Language/PureScript/Linter.hs | 7 ++++--- src/Language/PureScript/Linter/Exhaustive.hs | 7 ++++--- src/Language/PureScript/Linter/Imports.hs | 13 +++++++------ src/Language/PureScript/Names.hs | 2 +- src/Language/PureScript/Sugar/BindingGroups.hs | 9 +++++---- src/Language/PureScript/Sugar/CaseDeclarations.hs | 9 +++++---- src/Language/PureScript/Sugar/Names.hs | 4 ++-- src/Language/PureScript/Sugar/Names/Common.hs | 5 +++-- src/Language/PureScript/TypeChecker.hs | 7 ++++--- src/Language/PureScript/TypeChecker/Entailment.hs | 5 +++-- src/Language/PureScript/TypeChecker/Types.hs | 11 ++++++----- src/Language/PureScript/TypeChecker/Unify.hs | 5 +++-- src/Language/PureScript/Types.hs | 6 +++--- 25 files changed, 86 insertions(+), 66 deletions(-) diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index 93a7de67a8..ca0aac7fb6 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -2,6 +2,8 @@ module Command.Docs (command, infoModList) where +import Protolude (ordNub) + import Command.Docs.Etags import Command.Docs.Ctags import Control.Applicative @@ -122,7 +124,7 @@ takeModulesByName' getModuleName modules = foldl go ([], []) dumpTags :: [FilePath] -> ([(String, P.Module)] -> [String]) -> IO () dumpTags input renderTags = do - e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input) + e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (ordNub input) case e of Left err -> do hPrint stderr err diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs index bf8a3e919e..90f322648a 100644 --- a/app/Command/Hierarchy.hs +++ b/app/Command/Hierarchy.hs @@ -18,9 +18,11 @@ module Command.Hierarchy (command) where +import Protolude (ordNub) + import Control.Applicative (optional) import Control.Monad (unless) -import Data.List (intercalate,nub,sort) +import Data.List (intercalate, sort) import Data.Foldable (for_) import Data.Monoid ((<>)) import qualified Data.Text as T @@ -69,7 +71,7 @@ compile (HierarchyOptions inputGlob mOutput) = do for_ ms $ \(P.Module _ _ moduleName decls _) -> let name = runModuleName moduleName tcs = filter P.isTypeClassDeclaration decls - supers = sort . nub . filter (not . null) $ fmap superClasses tcs + supers = sort . ordNub . filter (not . null) $ fmap superClasses tcs prologue = "digraph " ++ name ++ " {\n" body = intercalate "\n" (concatMap (fmap (\s -> " " ++ show s ++ ";")) supers) epilogue = "\n}" diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index a75d2a0d0c..834b4be9b6 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -61,7 +61,7 @@ data Binder -- A binder with a type annotation -- | TypedBinder Type Binder - deriving (Show, Eq) + deriving (Show, Eq, Ord) -- | -- Collect all names introduced in binders in an expression diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 4b05551b6d..76bc678e3d 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -17,6 +17,7 @@ module Language.PureScript.Bundle ) where import Prelude.Compat +import Protolude (ordNub) import Control.Monad import Control.Monad.Error.Class @@ -25,7 +26,7 @@ import Control.Arrow ((&&&)) import Data.Char (chr, digitToInt) import Data.Generics (everything, everywhere, mkQ, mkT) import Data.Graph -import Data.List (nub, stripPrefix) +import Data.List (stripPrefix) import Data.Maybe (mapMaybe, catMaybes) import Data.Version (showVersion) import qualified Data.Set as S @@ -184,10 +185,10 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) -- | Calculate dependencies and add them to the current element. expandDeps :: ModuleElement -> ModuleElement - expandDeps (Member n f nm decl _) = Member n f nm decl (nub $ dependencies modulePath decl) + expandDeps (Member n f nm decl _) = Member n f nm decl (ordNub $ dependencies modulePath decl) expandDeps (ExportsList exps) = ExportsList (map expand exps) where - expand (ty, nm, n1, _) = (ty, nm, n1, nub (dependencies modulePath n1)) + expand (ty, nm, n1, _) = (ty, nm, n1, ordNub (dependencies modulePath n1)) expandDeps other = other dependencies :: ModuleIdentifier -> JSExpression -> [(ModuleIdentifier, String)] diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index ee60806bfc..1f4968b642 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -8,6 +8,7 @@ module Language.PureScript.CodeGen.JS ) where import Prelude.Compat +import Protolude (ordNub) import Control.Arrow ((&&&), second) import Control.Monad (forM, replicateM, void) @@ -15,7 +16,7 @@ import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class -import Data.List ((\\), delete, intersect, nub) +import Data.List ((\\), delete, intersect) import qualified Data.Foldable as F import qualified Data.Map as M import Data.Maybe (fromMaybe, isNothing) @@ -55,7 +56,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps - jsImports <- traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ nub $ map snd imps + jsImports <- traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ ordNub $ map snd imps let decls' = renameModules mnLookup decls jsDecls <- mapM bindToJs decls' optimized <- traverse (traverse optimize) jsDecls diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs index 6b0d036d58..9ce31fef3f 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs @@ -3,8 +3,8 @@ module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (magicDo) where import Prelude.Compat +import Protolude (ordNub) -import Data.List (nub) import Data.Maybe (fromJust, isJust) import Language.PureScript.CodeGen.JS.AST @@ -92,7 +92,7 @@ inlineST = everywhereOnJS convertBlock -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then -- we can be more aggressive about inlining, and actually turn STRefs into local variables. convertBlock (JSApp _ f [arg]) | isSTFunc C.runST f = - let refs = nub . findSTRefsIn $ arg + let refs = ordNub . findSTRefsIn $ arg usages = findAllSTUsagesIn arg allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 1341236415..20873750c8 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,11 +1,12 @@ module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where import Prelude.Compat +import Protolude (ordNub) import Control.Arrow (second) import Data.Function (on) -import Data.List (sort, sortBy, nub) +import Data.List (sort, sortBy) import Data.Maybe (mapMaybe) import qualified Data.Map as M @@ -35,9 +36,9 @@ moduleToCoreFn _ (A.Module _ _ _ _ Nothing) = internalError "Module exports were not elaborated before moduleToCoreFn" moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = let imports = mapMaybe importToCoreFn decls ++ findQualModules decls - imports' = nub $ filter (keepImp imports) imports-- TODO could be more efficient - exps' = nub $ concatMap exportToCoreFn exps - externs = nub $ mapMaybe externToCoreFn decls + imports' = ordNub $ filter (keepImp imports) imports-- TODO could be more efficient + exps' = ordNub $ concatMap exportToCoreFn exps + externs = ordNub $ mapMaybe externToCoreFn decls decls' = concatMap (declToCoreFn Nothing []) decls in Module coms mn imports' exps' externs decls' diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs index 88cbe7f84a..65e5dcd69a 100644 --- a/src/Language/PureScript/CoreFn/Meta.hs +++ b/src/Language/PureScript/CoreFn/Meta.hs @@ -26,7 +26,7 @@ data Meta -- | -- The contained reference is for a foreign member -- - | IsForeign deriving (Show, Eq) + | IsForeign deriving (Show, Eq, Ord) -- | -- Data constructor metadata @@ -39,4 +39,4 @@ data ConstructorType -- | -- The constructor is for a type with multiple construcors -- - | SumType deriving (Show, Eq) + | SumType deriving (Show, Eq, Ord) diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 86b3fec43b..a0c1eafbdc 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -3,6 +3,7 @@ module Language.PureScript.Environment where import Prelude.Compat +import Protolude (ordNub) import Data.Aeson.TH import qualified Data.Aeson as A @@ -11,7 +12,6 @@ import qualified Data.Set as S import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T -import Data.List (nub) import Data.Tree (Tree, rootLabel) import qualified Data.Graph as G import Data.Foldable (toList) @@ -119,7 +119,7 @@ makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs cov (src, fdDetermined fd) : map (, []) (fdDetermined fd) -- build a graph of which arguments determine other arguments - (depGraph, fromVertex, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps) + (depGraph, fromVertex, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, ordNub v)) <$> M.toList contributingDeps) -- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to isFunDepDetermined :: Int -> Bool diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 89a73c93e4..f2870de968 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -7,6 +7,7 @@ module Language.PureScript.Errors ) where import Prelude.Compat +import Protolude (ordNub) import Control.Arrow ((&&&)) import Control.Monad @@ -17,7 +18,7 @@ import Data.Char (isSpace) import Data.Either (lefts, rights) import Data.Foldable (fold) import Data.Functor.Identity (Identity(..)) -import Data.List (transpose, nub, nubBy, sortBy, partition) +import Data.List (transpose, nubBy, sortBy, partition) import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import Data.Ord (comparing) import Data.String (fromString) @@ -1259,7 +1260,7 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd separate _ [m] = m separate sep (m:ms) = m ++ sep ++ separate sep ms - clean = nub . filter (not . null) + clean = ordNub . filter (not . null) -- | Indent to the right, and pad on top and bottom. indent :: Box.Box -> Box.Box diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index db1cce724b..213af38540 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -11,8 +11,9 @@ module Language.PureScript.Interactive import Prelude () import Prelude.Compat +import Protolude (ordNub) -import Data.List (nub, sort, find, foldl') +import Data.List (sort, find, foldl') import Data.Maybe (mapMaybe) import qualified Data.Map as M import Data.Monoid ((<>)) @@ -164,7 +165,7 @@ handleShowLoadedModules = do loadedModules <- gets psciLoadedExterns liftIO $ putStrLn (readModules loadedModules) where - readModules = unlines . sort . nub . map (T.unpack . P.runModuleName . P.getModuleName . fst) + readModules = unlines . sort . ordNub . map (T.unpack . P.runModuleName . P.getModuleName . fst) -- | Show the imported modules in psci. handleShowImportedModules diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index 7ab532ae99..d4b6f296aa 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -6,13 +6,14 @@ module Language.PureScript.Interactive.Completion ) where import Prelude.Compat +import Protolude (ordNub) import Control.Arrow (second) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) import Data.Function (on) -import Data.List (nub, nubBy, isPrefixOf, sortBy, stripPrefix) +import Data.List (nubBy, isPrefixOf, sortBy, stripPrefix) import Data.Maybe (mapMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -169,7 +170,7 @@ getAllQualifications :: (a -> Text) -> P.Module -> (a, P.Declaration) -> Complet getAllQualifications sho m (declName, decl) = do imports <- getAllImportsOf m let fullyQualified = qualifyWith (Just (P.getModuleName m)) - let otherQuals = nub (concatMap qualificationsUsing imports) + let otherQuals = ordNub (concatMap qualificationsUsing imports) return $ fullyQualified : otherQuals where qualifyWith mMod = T.unpack (P.showQualified sho (P.Qualified mMod declName)) @@ -220,4 +221,4 @@ dctorNames = nubOnFst . concatMap go . P.exportedDeclarations go _ = [] moduleNames :: [P.Module] -> [String] -moduleNames = nub . map (T.unpack . P.runModuleName . P.getModuleName) +moduleNames = ordNub . map (T.unpack . P.runModuleName . P.getModuleName) diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 4918c11ff7..8ddf1cffd2 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -4,10 +4,11 @@ module Language.PureScript.Linter (lint, module L) where import Prelude.Compat +import Protolude (ordNub) import Control.Monad.Writer.Class -import Data.List (nub, (\\)) +import Data.List ((\\)) import Data.Maybe (mapMaybe) import Data.Monoid import qualified Data.Set as S @@ -28,7 +29,7 @@ lint :: forall m. (MonadWriter MultipleErrors m) => Module -> m () lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds where moduleNames :: S.Set Ident - moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds)) + moduleNames = S.fromList (ordNub (mapMaybe getDeclIdent ds)) getDeclIdent :: Declaration -> Maybe Ident getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d @@ -91,7 +92,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl findUnused ty' = let used = usedTypeVariables ty' declared = everythingOnTypes (++) go ty' - unused = nub declared \\ nub used + unused = ordNub declared \\ ordNub used in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused where go :: Type -> [Text] diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index a747996306..82ef5d00d4 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -9,6 +9,7 @@ module Language.PureScript.Linter.Exhaustive ) where import Prelude.Compat +import Protolude (ordNub) import Control.Applicative import Control.Arrow (first, second) @@ -17,7 +18,7 @@ import Control.Monad.Writer.Class import Control.Monad.Supply.Class (MonadSupply, fresh, freshName) import Data.Function (on) -import Data.List (foldl', sortBy, nub) +import Data.List (foldl', sortBy) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import qualified Data.Map as M @@ -242,12 +243,12 @@ checkExhaustive -> [CaseAlternative] -> Expr -> m Expr -checkExhaustive env mn numArgs cas expr = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas +checkExhaustive env mn numArgs cas expr = makeResult . first ordNub $ foldl' step ([initialize numArgs], (pure True, [])) cas where step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]])) step (uncovered, (nec, redundant)) ca = let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered) - (missed', approx) = splitAt 10000 (nub (concat missed)) + (missed', approx) = splitAt 10000 (ordNub (concat missed)) cond = or <$> sequenceA pr in (missed', ( if null approx then liftA2 (&&) cond nec diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 1dfcede5e8..680ca09e8f 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -5,13 +5,14 @@ module Language.PureScript.Linter.Imports ) where import Prelude.Compat +import Protolude (ordNub) import Control.Monad (join, unless, foldM, (<=<)) import Control.Monad.Writer.Class import Data.Function (on) import Data.Foldable (for_) -import Data.List (find, intersect, nub, groupBy, sortBy, (\\)) +import Data.List (find, intersect, groupBy, sortBy, (\\)) import Data.Maybe (mapMaybe, fromMaybe) import Data.Monoid (Sum(..)) import Data.Traversable (forM) @@ -71,16 +72,16 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do unless (isPrim mni) $ for_ decls $ \(ss', declType, qualifierName) -> maybe id warnWithPosition ss' $ do - let names = nub $ M.findWithDefault [] mni usedImps' + let names = ordNub $ M.findWithDefault [] mni usedImps' lintImportDecl env mni qualifierName names declType allowImplicit for_ (M.toAscList (byQual imports)) $ \(mnq, entries) -> do - let mnis = nub $ map (\(_, _, mni) -> mni) entries + let mnis = ordNub $ map (\(_, _, mni) -> mni) entries unless (length mnis == 1) $ do let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries for_ implicits $ \(ss', _, mni) -> maybe id warnWithPosition ss' $ do - let names = nub $ M.findWithDefault [] mni usedImps' + let names = ordNub $ M.findWithDefault [] mni usedImps' usedRefs = findUsedRefs env mni (Just mnq) names unless (null usedRefs) $ tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs @@ -147,7 +148,7 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do -- The list of modules that are being re-exported by the current module. Any -- module that appears in this list is always considered to be used. exportedModules :: [ModuleName] - exportedModules = nub $ mapMaybe extractModule mexports + exportedModules = ordNub $ mapMaybe extractModule mexports where extractModule (PositionedDeclarationRef _ _ r) = extractModule r extractModule (ModuleRef mne) = Just mne @@ -231,7 +232,7 @@ lintImportDecl env mni qualifierName names declType allowImplicit = :: [DeclarationRef] -> m Bool checkExplicit declrefs = do - let idents = nub (mapMaybe runDeclRef declrefs) + let idents = ordNub (mapMaybe runDeclRef declrefs) dctors = mapMaybe (getDctorName <=< disqualifyFor qualifierName) names usedNames = mapMaybe (matchName (typeForDCtor mni) <=< disqualifyFor qualifierName) names diff = idents \\ usedNames diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 8ca8fcca08..0c506435d3 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -25,7 +25,7 @@ data Name | TyClassName (ProperName 'ClassName) | ModName ModuleName | KiName (ProperName 'KindName) - deriving (Eq, Show) + deriving (Eq, Ord, Show) getIdentName :: Name -> Maybe Ident getIdentName (IdentName name) = Just name diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 9c77adca10..b319e44095 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -10,12 +10,13 @@ module Language.PureScript.Sugar.BindingGroups ) where import Prelude.Compat +import Protolude (ordNub) import Control.Monad ((<=<)) import Control.Monad.Error.Class (MonadError(..)) import Data.Graph -import Data.List (nub, intersect) +import Data.List (intersect) import Data.Maybe (isJust, mapMaybe) import qualified Data.Set as S @@ -103,7 +104,7 @@ collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val collapseBindingGroupsForValue other = other usedIdents :: ModuleName -> Declaration -> [Ident] -usedIdents moduleName = nub . usedIdents' S.empty . getValue +usedIdents moduleName = ordNub . usedIdents' S.empty . getValue where def _ _ = [] @@ -124,7 +125,7 @@ usedIdents moduleName = nub . usedIdents' S.empty . getValue usedImmediateIdents :: ModuleName -> Declaration -> [Ident] usedImmediateIdents moduleName = let (f, _, _, _, _) = everythingWithContextOnValues True [] (++) def usedNamesE def def def - in nub . f + in ordNub . f where def s _ = (s, []) @@ -138,7 +139,7 @@ usedImmediateIdents moduleName = usedTypeNames :: ModuleName -> Declaration -> [ProperName 'TypeName] usedTypeNames moduleName = let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames) - in nub . f + in ordNub . f where usedNames :: Type -> [ProperName 'TypeName] usedNames (ConstrainedType constraints _) = diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 7c30149831..67b11b8044 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -8,8 +8,9 @@ module Language.PureScript.Sugar.CaseDeclarations ) where import Prelude.Compat +import Protolude (ordNub) -import Data.List (nub, groupBy, foldl1') +import Data.List (groupBy, foldl1') import Data.Maybe (catMaybes, mapMaybe) import Control.Monad ((<=<), forM, replicateM, join, unless) @@ -323,7 +324,7 @@ toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaratio toDecls [ValueDeclaration ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do args <- mapM fromVarBinder bs let body = foldr (Abs . Left) val args - guardWith (errorMessage (OverlappingArgNames (Just ident))) $ length (nub args) == length args + guardWith (errorMessage (OverlappingArgNames (Just ident))) $ length (ordNub args) == length args return [ValueDeclaration ident nameKind [] [MkUnguarded body]] where fromVarBinder :: Binder -> m Ident @@ -379,8 +380,8 @@ makeCaseDeclaration ident alternatives = do -- We still have to make sure the generated names are unique, or else -- we will end up constructing an invalid function. - allUnique :: (Eq a) => [a] -> Bool - allUnique xs = length xs == length (nub xs) + allUnique :: (Ord a) => [a] -> Bool + allUnique xs = length xs == length (ordNub xs) argName :: Maybe Ident -> m Ident argName (Just name) = return name diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index b07cf65a9a..63a17b9bc6 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -9,6 +9,7 @@ module Language.PureScript.Sugar.Names ) where import Prelude.Compat +import Protolude (ordNub) import Control.Arrow (first) import Control.Monad @@ -16,7 +17,6 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Lazy import Control.Monad.Writer (MonadWriter(..), censor) -import Data.List (nub) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -206,7 +206,7 @@ renameInModule imports (Module ss coms mn decls exps) = return ((pos, arg : bound), Abs (Left arg) val') updateValue (pos, bound) (Let ds val') = do let args = mapMaybe letBoundVariable ds - unless (length (nub args) == length args) $ + unless (length (ordNub args) == length args) $ maybe id rethrowWithPosition pos $ throwError . errorMessage $ OverlappingNamesInLet return ((pos, args ++ bound), Let ds val') diff --git a/src/Language/PureScript/Sugar/Names/Common.hs b/src/Language/PureScript/Sugar/Names/Common.hs index 02c841bb82..a827041419 100644 --- a/src/Language/PureScript/Sugar/Names/Common.hs +++ b/src/Language/PureScript/Sugar/Names/Common.hs @@ -1,12 +1,13 @@ module Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) where import Prelude.Compat +import Protolude (ordNub) import Control.Monad.Writer (MonadWriter(..)) import Data.Foldable (for_) import Data.Function (on) -import Data.List (nub, nubBy, (\\)) +import Data.List (nubBy, (\\)) import Data.Maybe (mapMaybe) import Language.PureScript.AST @@ -52,7 +53,7 @@ warnDuplicateRefs pos toError refs = do extractCtors :: SourceSpan -> DeclarationRef -> Maybe [(SourceSpan, Name)] extractCtors _ (PositionedDeclarationRef pos' _ ref) = extractCtors pos' ref extractCtors pos' (TypeRef _ (Just dctors)) = - let dupes = dctors \\ nub dctors + let dupes = dctors \\ ordNub dctors in if null dupes then Nothing else Just $ ((pos',) . DctorName) <$> dupes extractCtors _ _ = Nothing diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index a238daa831..22a656e332 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -10,6 +10,7 @@ module Language.PureScript.TypeChecker ) where import Prelude.Compat +import Protolude (ordNub) import Control.Monad (when, unless, void, forM) import Control.Monad.Error.Class (MonadError(..)) @@ -19,7 +20,7 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Lens ((^..), _1, _2) import Data.Foldable (for_, traverse_, toList) -import Data.List (nub, nubBy, (\\), sort, group) +import Data.List (nubBy, (\\), sort, group) import Data.Maybe import qualified Data.Map as M import qualified Data.Set as S @@ -170,7 +171,7 @@ checkDuplicateTypeArguments args = for_ firstDup $ \dup -> throwError . errorMessage $ DuplicateTypeArgument dup where firstDup :: Maybe Text - firstDup = listToMaybe $ args \\ nub args + firstDup = listToMaybe $ args \\ ordNub args checkTypeClassInstance :: (MonadState CheckState m, MonadError MultipleErrors m) @@ -239,7 +240,7 @@ typeCheckAll moduleName _ = traverse go go (d@(DataBindingGroupDeclaration tys)) = do let syns = mapMaybe toTypeSynonym tys dataDecls = mapMaybe toDataDecl tys - bindingGroupNames = nub ((syns^..traverse._1) ++ (dataDecls^..traverse._2)) + bindingGroupNames = ordNub ((syns^..traverse._1) ++ (dataDecls^..traverse._2)) warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames)) $ do (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls) for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 590eed2aa2..44dc445414 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -12,6 +12,7 @@ module Language.PureScript.TypeChecker.Entailment ) where import Prelude.Compat +import Protolude (ordNub) import Control.Arrow (second) import Control.Monad.Error.Class (MonadError(..)) @@ -21,7 +22,7 @@ import Control.Monad.Writer import Data.Foldable (for_, fold, toList) import Data.Function (on) -import Data.List (minimumBy, nub) +import Data.List (minimumBy) import Data.Maybe (fromMaybe, maybeToList, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -160,7 +161,7 @@ entails SolverOptions{..} constraint context hints = forClassName _ C.AppendSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = let args = [arg0, arg1, TypeLevelString (lhs <> rhs)] in [TypeClassDictionaryInScope AppendSymbolInstance [] C.AppendSymbol args Nothing] - forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (nub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) + forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) forClassName _ _ _ = internalError "forClassName: expected qualified class name" ctorModules :: Type -> Maybe ModuleName diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 6a7891f973..84b605ef43 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -25,6 +25,7 @@ module Language.PureScript.TypeChecker.Types -} import Prelude.Compat +import Protolude (ordNub) import Control.Arrow (first, second, (***)) import Control.Monad @@ -36,7 +37,7 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Bifunctor (bimap) import Data.Either (partitionEithers) import Data.Functor (($>)) -import Data.List (transpose, nub, (\\), partition, delete) +import Data.List (transpose, (\\), partition, delete) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import qualified Data.Map as M @@ -89,7 +90,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -- Generalize and constrain the type currentSubst <- gets checkSubstitution let ty' = substituteType currentSubst ty - unsolvedTypeVars = nub $ unknownsInType ty' + unsolvedTypeVars = ordNub $ unknownsInType ty' generalized = generalize unsolved ty' when shouldGeneralize $ do @@ -110,7 +111,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup (constraintClass con) TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv) let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies - let constraintTypeVars = nub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..] + let constraintTypeVars = ordNub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..] when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ do throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ AmbiguousTypeVariables generalized con @@ -554,7 +555,7 @@ checkBinders checkBinders _ _ [] = return [] checkBinders nvals ret (CaseAlternative binders result : bs) = do guardWith (errorMessage $ OverlappingArgNames Nothing) $ - let ns = concatMap binderNames binders in length (nub ns) == length ns + let ns = concatMap binderNames binders in length (ordNub ns) == length ns m1 <- M.unions <$> zipWithM inferBinder nvals binders r <- bindLocalVariables [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ CaseAlternative binders <$> @@ -829,6 +830,6 @@ checkFunctionApplication' fn u arg = do ensureNoDuplicateProperties :: (MonadError MultipleErrors m) => [(PSString, Expr)] -> m () ensureNoDuplicateProperties ps = let ls = map fst ps in - case ls \\ nub ls of + case ls \\ ordNub ls of l : _ -> throwError . errorMessage $ DuplicateLabel (Label l) Nothing _ -> return () diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index a920e88613..2b30f9feed 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -16,13 +16,14 @@ module Language.PureScript.TypeChecker.Unify ) where import Prelude.Compat +import Protolude (ordNub) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets, modify) import Control.Monad.Writer.Class (MonadWriter(..)) -import Data.List (nub, sort) +import Data.List (sort) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T @@ -181,7 +182,7 @@ replaceTypeWildcards = everywhereOnTypesM replace -- varIfUnknown :: Type -> Type varIfUnknown ty = - let unks = nub $ unknownsInType ty + let unks = ordNub $ unknownsInType ty toName = T.cons 't' . T.pack . show ty' = everywhereOnTypes typeToVar ty typeToVar :: Type -> Type diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index c07d8263fa..1028f01eb2 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -7,11 +7,11 @@ module Language.PureScript.Types where import Prelude.Compat +import Protolude (ordNub) import Control.Monad ((<=<)) import qualified Data.Aeson as A import qualified Data.Aeson.TH as A -import Data.List (nub) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) @@ -179,7 +179,7 @@ replaceAllTypeVars = go [] -- Collect all type variables appearing in a type -- usedTypeVariables :: Type -> [Text] -usedTypeVariables = nub . everythingOnTypes (++) go +usedTypeVariables = ordNub . everythingOnTypes (++) go where go (TypeVar v) = [v] go _ = [] @@ -188,7 +188,7 @@ usedTypeVariables = nub . everythingOnTypes (++) go -- Collect all free type variables appearing in a type -- freeTypeVariables :: Type -> [Text] -freeTypeVariables = nub . go [] +freeTypeVariables = ordNub . go [] where go :: [Text] -> Type -> [Text] go bound (TypeVar v) | v `notElem` bound = [v] From 8fb287895092fd5347729b03a67ae03a0030fa36 Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Mon, 20 Feb 2017 11:43:03 -0800 Subject: [PATCH 0682/1580] simplify a hairy use of M.insert (#2677) * simplify a hairy use of M.insert makes it a bit clearer what the code in question is doing * replace use of (++) operator * revert to using (++) see relevant discussion at https://github.com/purescript/purescript/pull/2677#issuecomment-280939376 --- src/Language/PureScript/Sugar/Names.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 63a17b9bc6..7948366f4c 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -350,11 +350,8 @@ renameInModule imports (Module ss coms mn decls exps) = -- in scope, we throw an error. (Just options, _) -> do (mnNew, mnOrig) <- checkImportConflicts mn toName options - modify $ \result -> - M.insert - mnNew - (maybe [fmap toName qname] (fmap toName qname :) (mnNew `M.lookup` result)) - result + modify $ \usedImports -> + M.insertWith (++) mnNew [fmap toName qname] usedImports return $ Qualified (Just mnOrig) name -- If the name wasn't found in our imports but was qualified then we need From bcfa867018fb53df1df8ac51b8e8a2e4fe29b25e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 20 Feb 2017 13:40:22 -0800 Subject: [PATCH 0683/1580] Support polymorphic types in typed binders (#2656) * Support polymorphic types in typed binders, fix #2626 * Formatting, remove comment * Remove failing case * Examples --- examples/failing/2445.purs | 6 ---- examples/passing/2626.purs | 13 +++++++++ .../PureScript/Parser/Declarations.hs | 28 +++++++++---------- 3 files changed, 26 insertions(+), 21 deletions(-) delete mode 100644 examples/failing/2445.purs create mode 100644 examples/passing/2626.purs diff --git a/examples/failing/2445.purs b/examples/failing/2445.purs deleted file mode 100644 index 10ad41a910..0000000000 --- a/examples/failing/2445.purs +++ /dev/null @@ -1,6 +0,0 @@ --- @shouldFailWith ErrorParsingModule -module Main where - -data X a = X - -eg = \(X :: (forall a. X a)) -> X diff --git a/examples/passing/2626.purs b/examples/passing/2626.purs new file mode 100644 index 0000000000..cee8514f8e --- /dev/null +++ b/examples/passing/2626.purs @@ -0,0 +1,13 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +f = \(x :: forall a. a -> a) -> x x + +test1 = (f \x -> x) 1 + +g = \(x :: (forall a. a -> a) -> Int) -> x (\y -> y) + +test2 = g \f -> if f true then f 0 else f 1 + +main = log "Done" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 6178ac1a13..21a471ef95 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -531,25 +531,23 @@ parseIdentifierAndBinder = -- | Parse a binder parseBinder :: TokenParser Binder parseBinder = - withSourceSpan - PositionedBinder - ( P.buildExpressionParser operators - . buildPostfixParser postfixTable - $ parseBinderAtom - ) + withSourceSpan + PositionedBinder + ( P.buildExpressionParser operators + . buildPostfixParser postfixTable + $ parseBinderAtom + ) where - operators = - [ [ P.Infix (P.try (indented *> parseOpBinder P. "binder operator") >>= \op -> - return (BinaryNoParensBinder op)) P.AssocRight + operators = + [ [ P.Infix (P.try (indented *> parseOpBinder P. "binder operator") >>= \op -> + return (BinaryNoParensBinder op)) P.AssocRight + ] ] - ] - -- TODO: parsePolyType when adding support for polymorphic types - postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parseType) - ] + postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parsePolyType) ] - parseOpBinder :: TokenParser Binder - parseOpBinder = OpBinder <$> parseQualified parseOperator + parseOpBinder :: TokenParser Binder + parseOpBinder = OpBinder <$> parseQualified parseOperator parseBinderAtom :: TokenParser Binder parseBinderAtom = P.choice From 14008684070c7dec7cfc598a3aca8e6de48cc69c Mon Sep 17 00:00:00 2001 From: Hyunje Jun Date: Tue, 21 Feb 2017 13:51:56 +0900 Subject: [PATCH 0684/1580] Better error message for removed PSCi let decl (#2667) * Better error message for removed PSCi let decl * Add 'psciDecprecatedLet' parser to show error * Derive Show instance for PSCi commands * Add 'notFollowedBy' check to 'psciDeprecatedLet' * Update fail message of 'psciDeprecatedLet' --- src/Language/PureScript/Interactive/Parser.hs | 14 +++++++++++++- src/Language/PureScript/Interactive/Types.hs | 1 + 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index 8e9fb55231..d5585807be 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -7,6 +7,7 @@ module Language.PureScript.Interactive.Parser import Prelude.Compat hiding (lex) +import Data.Bifunctor (first) import Data.Char (isSpace) import Data.List (intercalate) import qualified Data.Text as T @@ -26,7 +27,7 @@ parseCommand cmdString = _ -> parseRest psciCommand cmdString parseRest :: P.TokenParser a -> String -> Either String a -parseRest p s = either (Left . show) Right $ do +parseRest p s = first show $ do ts <- P.lex "" (T.pack s) P.runTokenParser "" (p <* eof) ts @@ -37,6 +38,7 @@ psciCommand = choice (map try parsers) [ psciImport , psciDeclaration , psciExpression + , psciDeprecatedLet ] trim :: String -> String @@ -112,3 +114,13 @@ parseReplQuery' str = Nothing -> Left ("Don't know how to show " ++ str ++ ". Try one of: " ++ intercalate ", " replQueryStrings ++ ".") Just query -> Right query + +-- | To show error message when 'let' is used for declaration in PSCI, +-- which is deprecated. +psciDeprecatedLet :: P.TokenParser Command +psciDeprecatedLet = do + P.reserved "let" + P.indented + _ <- mark (many1 (same *> P.parseLocalDeclaration)) + notFollowedBy $ P.reserved "in" + fail "Declarations in PSCi no longer require \"let\", as of version 0.11.0" diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index 61dfe145ea..a96187edb8 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -94,6 +94,7 @@ data Command | ShowInfo ReplQuery -- | Paste multiple lines | PasteLines + deriving Show data ReplQuery = QueryLoaded From d588bd1345f479c55322ed6428eead7f67f9a881 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 20 Feb 2017 20:52:23 -0800 Subject: [PATCH 0685/1580] Add psc-ide-client script (#2681) * Add psc-ide-client script * Make scripts compatible with Pulp --- scripts/psc | 2 +- scripts/psc-bundle | 2 +- scripts/psc-docs | 2 +- scripts/psc-hierarchy | 2 +- scripts/psc-ide-client | 2 ++ scripts/psc-ide-server | 2 +- scripts/psc-publish | 2 +- scripts/psci | 2 +- 8 files changed, 9 insertions(+), 7 deletions(-) create mode 100644 scripts/psc-ide-client diff --git a/scripts/psc b/scripts/psc index d24b821201..95e4b1b73d 100755 --- a/scripts/psc +++ b/scripts/psc @@ -1,2 +1,2 @@ #!/bin/sh -purs compile $@ +purs compile "$@" diff --git a/scripts/psc-bundle b/scripts/psc-bundle index 72f0c7011c..fb3814456c 100755 --- a/scripts/psc-bundle +++ b/scripts/psc-bundle @@ -1,2 +1,2 @@ #!/bin/sh -purs bundle $@ +purs bundle "$@" diff --git a/scripts/psc-docs b/scripts/psc-docs index 27e63e4b39..bf9acc6cbf 100755 --- a/scripts/psc-docs +++ b/scripts/psc-docs @@ -1,2 +1,2 @@ #!/bin/sh -purs docs $@ +purs docs "$@" diff --git a/scripts/psc-hierarchy b/scripts/psc-hierarchy index 3c72d8232c..9b0fe41891 100755 --- a/scripts/psc-hierarchy +++ b/scripts/psc-hierarchy @@ -1,2 +1,2 @@ #!/bin/sh -purs hierarchy $@ +purs hierarchy "$@" diff --git a/scripts/psc-ide-client b/scripts/psc-ide-client new file mode 100644 index 0000000000..c780e12b3f --- /dev/null +++ b/scripts/psc-ide-client @@ -0,0 +1,2 @@ +#!/bin/sh +purs ide client "$@" diff --git a/scripts/psc-ide-server b/scripts/psc-ide-server index d9bc1596bf..0ac3802ef9 100755 --- a/scripts/psc-ide-server +++ b/scripts/psc-ide-server @@ -1,2 +1,2 @@ #!/bin/sh -purs ide $@ +purs ide server "$@" diff --git a/scripts/psc-publish b/scripts/psc-publish index 36dd20738a..b571e81a69 100755 --- a/scripts/psc-publish +++ b/scripts/psc-publish @@ -1,2 +1,2 @@ #!/bin/sh -purs publish $@ +purs publish "$@" diff --git a/scripts/psci b/scripts/psci index c4599e1a54..f467eb3e72 100755 --- a/scripts/psci +++ b/scripts/psci @@ -1,2 +1,2 @@ #!/bin/sh -purs repl $@ +purs repl $@" From c48f74139e94b43c7ecec726d4b280303ae995e0 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 21 Feb 2017 08:34:15 -0800 Subject: [PATCH 0686/1580] Optimize keepImp, fix #2212 (#2684) --- src/Language/PureScript/CoreFn/Desugar.hs | 77 +++++++++-------------- 1 file changed, 28 insertions(+), 49 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 20873750c8..ecddabbd19 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -8,6 +8,7 @@ import Control.Arrow (second) import Data.Function (on) import Data.List (sort, sortBy) import Data.Maybe (mapMaybe) +import Data.Tuple (swap) import qualified Data.Map as M import Language.PureScript.AST.Literals @@ -28,15 +29,13 @@ import Language.PureScript.Types import Language.PureScript.PSString (mkString) import qualified Language.PureScript.AST as A --- | --- Desugars a module from AST to CoreFn representation. --- +-- | Desugars a module from AST to CoreFn representation. moduleToCoreFn :: Environment -> A.Module -> Module Ann moduleToCoreFn _ (A.Module _ _ _ _ Nothing) = internalError "Module exports were not elaborated before moduleToCoreFn" moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = let imports = mapMaybe importToCoreFn decls ++ findQualModules decls - imports' = ordNub $ filter (keepImp imports) imports-- TODO could be more efficient + imports' = keepPositionedImports imports exps' = ordNub $ concatMap exportToCoreFn exps externs = ordNub $ mapMaybe externToCoreFn decls decls' = concatMap (declToCoreFn Nothing []) decls @@ -44,22 +43,24 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = where - -- Remove duplicate imports favoring the one containing sourcespan info - keepImp :: [(Ann, ModuleName)] -> (Ann, ModuleName) -> Bool - keepImp imps (a, i) = hasSS a || not (any hasDup imps) + -- | Remove duplicate imports favoring the ones containing source span + -- information + keepPositionedImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)] + keepPositionedImports = + map swap . M.toList . M.fromListWith preferSSpan . map swap where - hasDup (a', i') = i == i' && hasSS a' + preferSSpan x y + | hasSS x = x + | otherwise = y - hasSS :: Ann -> Bool - hasSS (Just _, _, _, _) = True - hasSS _ = False + hasSS :: Ann -> Bool + hasSS (Just _, _, _, _) = True + hasSS _ = False ssA :: Maybe SourceSpan -> Ann ssA ss = (ss, [], Nothing, Nothing) - -- | - -- Desugars member declarations from AST to CoreFn representation. - -- + -- | Desugars member declarations from AST to CoreFn representation. declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann] declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) = [NonRec (ssA ss) (properToIdent ctor) $ @@ -81,9 +82,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = declToCoreFn (Just ss) (com ++ com1) d declToCoreFn _ _ _ = [] - -- | - -- Desugars expressions from AST to CoreFn representation. - -- + -- | Desugars expressions from AST to CoreFn representation. exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann exprToCoreFn ss com ty (A.Literal lit) = Literal (ss, com, ty, Nothing) (fmap (exprToCoreFn ss com Nothing) lit) @@ -127,9 +126,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = exprToCoreFn _ _ _ e = error $ "Unexpected value in exprToCoreFn mn: " ++ show e - -- | - -- Desugars case alternatives from AST to CoreFn representation. - -- + -- | Desugars case alternatives from AST to CoreFn representation. altToCoreFn :: Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs) where @@ -145,9 +142,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = guardToExpr [A.ConditionGuard cond] = cond guardToExpr _ = internalError "Guard not correctly desugared" - -- | - -- Desugars case binders from AST to CoreFn representation. - -- + -- | Desugars case binders from AST to CoreFn representation. binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann binderToCoreFn ss com (A.LiteralBinder lit) = LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit) @@ -171,18 +166,14 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = binderToCoreFn _ _ A.ParensInBinder{} = internalError "ParensInBinder should have been desugared before binderToCoreFn" - -- | - -- Gets metadata for values. - -- + -- | Gets metadata for values. getValueMeta :: Qualified Ident -> Maybe Meta getValueMeta name = case lookupValue env name of Just (_, External, _) -> Just IsForeign _ -> Nothing - -- | - -- Gets metadata for data constructors. - -- + -- | Gets metadata for data constructors. getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta getConstructorMeta ctor = case lookupConstructor env ctor of @@ -203,11 +194,9 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) typeConstructor _ = internalError "Invalid argument to typeConstructor" --- | --- Find module names from qualified references to values. This is used to +-- | Find module names from qualified references to values. This is used to -- ensure instances are imported from any module that is referenced by the -- current module, not just from those that are imported explicitly (#667). --- findQualModules :: [A.Declaration] -> [(Ann, ModuleName)] findQualModules decls = let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const []) @@ -222,9 +211,9 @@ findQualModules decls = fqValues :: A.Expr -> [ModuleName] fqValues (A.Var q) = getQual' q fqValues (A.Constructor q) = getQual' q - -- IsSymbol instances for literal symbols are automatically solved and the type + -- 'IsSymbol' instances for literal symbols are automatically solved and the type -- class dictionaries are built inline instead of having a named instance defined - -- and imported. We therefore need to import the IsSymbol constructor from + -- and imported. We therefore need to import the 'IsSymbol' constructor from -- Data.Symbol if it hasn't already been imported. fqValues (A.TypeClassDictionaryConstructorApp C.IsSymbol _) = getQual' C.IsSymbol fqValues _ = [] @@ -236,28 +225,22 @@ findQualModules decls = getQual' :: Qualified a -> [ModuleName] getQual' = maybe [] return . getQual --- | --- Desugars import declarations from AST to CoreFn representation. --- +-- | Desugars import declarations from AST to CoreFn representation. importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName) importToCoreFn (A.ImportDeclaration name _ _) = Just (nullAnn, name) importToCoreFn (A.PositionedDeclaration ss _ d) = ((,) (Just ss, [], Nothing, Nothing) . snd) <$> importToCoreFn d importToCoreFn _ = Nothing --- | --- Desugars foreign declarations from AST to CoreFn representation. --- +-- | Desugars foreign declarations from AST to CoreFn representation. externToCoreFn :: A.Declaration -> Maybe ForeignDecl externToCoreFn (A.ExternDeclaration name ty) = Just (name, ty) externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d externToCoreFn _ = Nothing --- | --- Desugars export declarations references from AST to CoreFn representation. +-- | Desugars export declarations references from AST to CoreFn representation. -- CoreFn modules only export values, so all data constructors, class -- constructor, instances and values are flattened into one list. --- exportToCoreFn :: A.DeclarationRef -> [Ident] exportToCoreFn (A.TypeRef _ (Just dctors)) = map properToIdent dctors exportToCoreFn (A.ValueRef name) = [name] @@ -266,11 +249,9 @@ exportToCoreFn (A.TypeInstanceRef name) = [name] exportToCoreFn (A.PositionedDeclarationRef _ _ d) = exportToCoreFn d exportToCoreFn _ = [] --- | --- Makes a typeclass dictionary constructor function. The returned expression +-- | Makes a typeclass dictionary constructor function. The returned expression -- is a function that accepts the superclass instances and member -- implementations and returns a record for the instance dictionary. --- mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.Declaration] -> Expr Ann mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral []) mkTypeClassConstructor ss com supers members = @@ -281,8 +262,6 @@ mkTypeClassConstructor ss com supers members = (Ident a) (foldr (Abs nullAnn . Ident) dict as) --- | --- Converts a ProperName to an Ident. --- +-- | Converts a ProperName to an Ident. properToIdent :: ProperName a -> Ident properToIdent = Ident . runProperName From 119ae967bc30d389c5a623239c06bc77ec1a0750 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 26 Feb 2017 16:38:22 -0800 Subject: [PATCH 0687/1580] 0.11.0 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 533e7943c7..de67a64080 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.10.6 +version: 0.11.0 cabal-version: >=1.8 build-type: Simple license: BSD3 From ee2aa3dbc25b3c15eb44bffaad60785e66847ef0 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 28 Feb 2017 08:27:07 -0800 Subject: [PATCH 0688/1580] Remove dependency on the Bower executable (#2687) * Remove dependency on the Bower executable * Extract dependency paths from resolutions file * Fix the docs and publish tests * Fix comment * Allow relative paths in resolutions file, fix tests (hopefully) * It's prelude-resolutions.json * Include resolutions.json files for sdist builds --- app/Command/Publish.hs | 22 +- examples/docs/bower.json | 1 + examples/docs/resolutions.json | 21 ++ purescript.cabal | 2 + src/Language/PureScript/Docs/Types.hs | 8 +- .../PureScript/Interactive/Message.hs | 6 +- src/Language/PureScript/Publish.hs | 188 ++++++++---------- .../PureScript/Publish/ErrorsWarnings.hs | 110 +++++----- src/Language/PureScript/Publish/Utils.hs | 43 +--- tests/TestDocs.hs | 2 +- tests/TestPscPublish.hs | 10 +- tests/support/prelude-resolutions.json | 7 + 12 files changed, 210 insertions(+), 210 deletions(-) create mode 100644 examples/docs/resolutions.json create mode 100644 tests/support/prelude-resolutions.json diff --git a/app/Command/Publish.hs b/app/Command/Publish.hs index 9da0c09914..0440bae107 100644 --- a/app/Command/Publish.hs +++ b/app/Command/Publish.hs @@ -13,6 +13,18 @@ import Language.PureScript.Publish.ErrorsWarnings import Options.Applicative (Parser) import qualified Options.Applicative as Opts +manifestPath :: Parser FilePath +manifestPath = Opts.strOption $ + Opts.long "manifest" + <> Opts.metavar "FILE" + <> Opts.help "The package manifest file" + +resolutionsPath :: Parser FilePath +resolutionsPath = Opts.strOption $ + Opts.long "resolutions" + <> Opts.metavar "FILE" + <> Opts.help "The resolutions file" + dryRun :: Parser Bool dryRun = Opts.switch $ Opts.long "dry-run" @@ -27,14 +39,14 @@ dryRunOptions = defaultPublishOptions where dummyVersion = ("0.0.0", Version [0,0,0] []) command :: Opts.Parser (IO ()) -command = publish <$> (Opts.helper <*> dryRun) +command = publish <$> manifestPath <*> resolutionsPath <*> (Opts.helper <*> dryRun) -publish :: Bool -> IO () -publish isDryRun = +publish :: FilePath -> FilePath -> Bool -> IO () +publish manifestFile resolutionsFile isDryRun = if isDryRun then do - _ <- unsafePreparePackage dryRunOptions + _ <- unsafePreparePackage manifestFile resolutionsFile dryRunOptions putStrLn "Dry run completed, no errors." else do - pkg <- unsafePreparePackage defaultPublishOptions + pkg <- unsafePreparePackage manifestFile resolutionsFile defaultPublishOptions BL.putStrLn (A.encode pkg) diff --git a/examples/docs/bower.json b/examples/docs/bower.json index 54f1c9767e..a6a0385323 100644 --- a/examples/docs/bower.json +++ b/examples/docs/bower.json @@ -15,6 +15,7 @@ "output" ], "dependencies": { + "purescript-prelude": "./bower_components/purescript-prelude" }, "license": "MIT" } diff --git a/examples/docs/resolutions.json b/examples/docs/resolutions.json new file mode 100644 index 0000000000..c3fced5666 --- /dev/null +++ b/examples/docs/resolutions.json @@ -0,0 +1,21 @@ +{ + "canonicalDir": ".", + "pkgMeta": { + "dependencies": { + "purescript-prelude": "./bower_components/purescript-prelude" + } + }, + "dependencies": { + "purescript-prelude": { + "canonicalDir": "bower_components/purescript-prelude", + "pkgMeta": { + "_resolution": { + "type": "version", + "tag": "v2.4.0", + "commit": "21067a4c782f42d08bc877214f85b92ce6769b21" + } + }, + "dependencies": {} + } + } +} diff --git a/purescript.cabal b/purescript.cabal index de67a64080..6d9c4df9da 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -92,6 +92,7 @@ extra-source-files: examples/passing/*.purs , examples/docs/bower_components/purescript-prelude/src/*.purs , examples/docs/bower.json , examples/docs/src/*.purs + , examples/docs/resolutions.json , app/static/index.html , app/static/index.js , tests/support/package.json @@ -101,6 +102,7 @@ extra-source-files: examples/passing/*.purs , tests/support/pscide/src/*.purs , tests/support/pscide/src/*.js , tests/support/pscide/src/*.fail + , tests/support/prelude-resolutions.json , stack.yaml , README.md , INSTALL.md diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index e69eb87621..8190415b06 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -63,6 +63,8 @@ data NotYetKnown = NotYetKnown type UploadedPackage = Package NotYetKnown type VerifiedPackage = Package GithubUser +type ManifestError = BowerError + verifyPackage :: GithubUser -> UploadedPackage -> VerifiedPackage verifyPackage verifiedUser Package{..} = Package pkgMeta @@ -327,7 +329,7 @@ data PackageError = CompilerTooOld Version Version -- ^ Minimum allowable version for generating data with the current -- parser, and actual version used. - | ErrorInPackageMeta BowerError + | ErrorInPackageMeta ManifestError | InvalidVersion | InvalidDeclarationType Text | InvalidChildDeclarationType Text @@ -564,7 +566,7 @@ asReExport = pOr :: Parse e a -> Parse e a -> Parse e a p `pOr` q = catchError p (const q) -asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a) +asInPackage :: Parse ManifestError a -> Parse ManifestError (InPackage a) asInPackage inner = build <$> key "package" (perhaps (withText parsePackageName)) <*> key "item" inner @@ -684,7 +686,7 @@ asModuleMap = -- This is here to preserve backwards compatibility with compilers which used -- to generate a 'bookmarks' field in the JSON (i.e. up to 0.10.5). We should -- remove this after the next breaking change to the JSON. -bookmarksAsModuleMap :: Parse BowerError (Map P.ModuleName PackageName) +bookmarksAsModuleMap :: Parse ManifestError (Map P.ModuleName PackageName) bookmarksAsModuleMap = convert <$> eachInArray (asInPackage (nth 0 (P.moduleNameFromString <$> asText))) diff --git a/src/Language/PureScript/Interactive/Message.hs b/src/Language/PureScript/Interactive/Message.hs index 337ce28d18..24a5b3737a 100644 --- a/src/Language/PureScript/Interactive/Message.hs +++ b/src/Language/PureScript/Interactive/Message.hs @@ -50,11 +50,7 @@ noInputMessage = unlines supportModuleMessage :: String supportModuleMessage = unlines - [ "purs repl: PSCi requires the psci-support package to be installed." - , "You can install it using Bower as follows:" - , "" - , " bower i purescript-psci-support --save-dev" - , "" + [ "purs repl: PSCi requires the psci-support package." , "For help getting started, visit " ++ guideURL ] diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 6be579a5b7..f89f36188b 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -15,7 +15,7 @@ module Language.PureScript.Publish , getGitWorkingTreeStatus , checkCleanWorkingTree , getVersionFromGitTag - , getBowerRepositoryInfo + , getManifestRepositoryInfo , getModules , getResolvedDependencies ) where @@ -24,30 +24,25 @@ import Protolude hiding (stdin) import Control.Arrow ((***)) import Control.Category ((>>>)) -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell) -import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asText) +import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asString, asText) +import qualified Data.ByteString.Lazy as BL import Data.Char (isSpace) import Data.String (String, lines) import Data.List (stripPrefix, (\\), nubBy) import Data.List.NonEmpty (NonEmpty(..)) -import Data.List.Split (splitOn) import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Version import qualified Data.SPDX as SPDX -import System.Directory (doesFileExist, findExecutable) -import System.FilePath (pathSeparator) +import System.Directory (doesFileExist) +import System.FilePath.Glob (globDir1) import System.Process (readProcess) -import qualified System.FilePath.Glob as Glob -import qualified System.Info -import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName, runPackageName, parsePackageName, Repository(..)) +import Web.Bower.PackageMeta (PackageMeta(..), PackageName, parsePackageName, Repository(..)) import qualified Web.Bower.PackageMeta as Bower import Language.PureScript.Publish.ErrorsWarnings @@ -73,14 +68,16 @@ defaultPublishOptions = PublishOptions -- | Attempt to retrieve package metadata from the current directory. -- Calls exitFailure if no package metadata could be retrieved. -unsafePreparePackage :: PublishOptions -> IO D.UploadedPackage -unsafePreparePackage opts = either (\e -> printError e >> exitFailure) pure =<< preparePackage opts +unsafePreparePackage :: FilePath -> FilePath -> PublishOptions -> IO D.UploadedPackage +unsafePreparePackage manifestFile resolutionsFile opts = + either (\e -> printError e >> exitFailure) pure + =<< preparePackage manifestFile resolutionsFile opts -- | Attempt to retrieve package metadata from the current directory. -- Returns a PackageError on failure -preparePackage :: PublishOptions -> IO (Either PackageError D.UploadedPackage) -preparePackage opts = - runPrepareM (preparePackage' opts) +preparePackage :: FilePath -> FilePath -> PublishOptions -> IO (Either PackageError D.UploadedPackage) +preparePackage manifestFile resolutionsFile opts = + runPrepareM (preparePackage' manifestFile resolutionsFile opts) >>= either (pure . Left) (fmap Right . handleWarnings) where @@ -120,32 +117,36 @@ otherError = throwError . OtherError catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b catchLeft a f = either f pure a -preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage -preparePackage' opts = do - unlessM (liftIO (doesFileExist "bower.json")) (userError BowerJSONNotFound) +preparePackage' :: FilePath -> FilePath -> PublishOptions -> PrepareM D.UploadedPackage +preparePackage' manifestFile resolutionsFile opts = do + unlessM (liftIO (doesFileExist manifestFile)) (userError PackageManifestNotFound) checkCleanWorkingTree opts - pkgMeta <- liftIO (Bower.decodeFile "bower.json") - >>= flip catchLeft (userError . CouldntDecodeBowerJSON) + pkgMeta <- liftIO (Bower.decodeFile manifestFile) + >>= flip catchLeft (userError . CouldntDecodePackageManifest) checkLicense pkgMeta (pkgVersionTag, pkgVersion) <- publishGetVersion opts pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag - pkgGithub <- getBowerRepositoryInfo pkgMeta - (pkgModules, pkgModuleMap) <- getModules + pkgGithub <- getManifestRepositoryInfo pkgMeta let declaredDeps = map fst (bowerDependencies pkgMeta ++ bowerDevDependencies pkgMeta) - pkgResolvedDependencies <- getResolvedDependencies declaredDeps + resolvedDeps <- getResolvedDependencies resolutionsFile declaredDeps + + (pkgModules, pkgModuleMap) <- getModules (map (second fst) resolvedDeps) let pkgUploader = D.NotYetKnown let pkgCompilerVersion = P.version + let pkgResolvedDependencies = map (second snd) resolvedDeps return D.Package{..} -getModules :: PrepareM ([D.Module], Map P.ModuleName PackageName) -getModules = do - (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles +getModules + :: [(PackageName, FilePath)] + -> PrepareM ([D.Module], Map P.ModuleName PackageName) +getModules paths = do + (inputFiles, depsFiles) <- liftIO (getInputAndDepsFiles paths) (modules', moduleMap) <- parseFilesInPackages inputFiles depsFiles case runExcept (D.convertModulesInPackage modules' moduleMap) of @@ -200,8 +201,8 @@ getTagTime tag = do [t] -> pure . posixSecondsToUTCTime . fromInteger $ t _ -> internalError (CouldntParseGitTagDate tag) -getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo) -getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract +getManifestRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo) +getManifestRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract where tryExtract pkgMeta = case bowerRepository pkgMeta of @@ -259,12 +260,9 @@ readProcess' prog args stdin = do data DependencyStatus = Missing - -- ^ Listed in bower.json, but not installed. + -- ^ Listed in package manifest, but not installed. | NoResolution - -- ^ In the output of `bower list --json --offline`, there was no - -- _resolution key. This can be caused by adding the dependency using - -- `bower link`, or simply copying it into bower_components instead of - -- installing it normally. + -- ^ In the resolutions file, there was no _resolution key. | ResolvedOther Text -- ^ Resolved, but to something other than a version. The Text argument -- is the resolution type. The values it can take that I'm aware of are @@ -274,10 +272,10 @@ data DependencyStatus -- "v0.1.0"). deriving (Show, Eq) --- Go through all bower dependencies which contain purescript code, and +-- Go through all dependencies which contain purescript code, and -- extract their versions. -- --- In the case where a bower dependency is taken from a particular version, +-- In the case where a dependency is taken from a particular version, -- that's easy; take that version. In any other case (eg, a branch, or a commit -- sha) we print a warning that documentation links will not work, and avoid -- linking to documentation for any types from that package. @@ -287,10 +285,10 @@ data DependencyStatus -- probably for a reason. However, docs are only ever available for released -- versions. Therefore there will probably be no version of the docs which is -- appropriate to link to, and we should omit links. -getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)] -getResolvedDependencies declaredDeps = do - bower <- findBowerExecutable - depsBS <- packUtf8 <$> readProcess' bower ["list", "--json", "--offline"] "" +getResolvedDependencies :: FilePath -> [PackageName] -> PrepareM [(PackageName, (FilePath, Version))] +getResolvedDependencies resolutionsFile declaredDeps = do + unlessM (liftIO (doesFileExist resolutionsFile)) (userError ResolutionsFileNotFound) + depsBS <- liftIO (BL.readFile resolutionsFile) -- Check for undeclared dependencies toplevels <- catchJSON (parse asToplevelDependencies depsBS) @@ -300,111 +298,93 @@ getResolvedDependencies declaredDeps = do handleDeps deps where - packUtf8 = TL.encodeUtf8 . TL.pack - catchJSON = flip catchLeft (internalError . JSONError FromBowerList) - -findBowerExecutable :: PrepareM String -findBowerExecutable = do - mname <- liftIO . runMaybeT . msum . map (MaybeT . findExecutable) $ names - maybe (userError (BowerExecutableNotFound names)) return mname - where - names = case System.Info.os of - "mingw32" -> ["bower", "bower.cmd"] - _ -> ["bower"] + catchJSON = flip catchLeft (internalError . JSONError FromResolutions) --- | Extracts all dependencies and their versions from --- `bower list --json --offline` -asResolvedDependencies :: Parse BowerError [(PackageName, DependencyStatus)] +-- | Extracts all dependencies and their versions from a "resolutions" file, which +-- is based on the output of `bower list --json --offline` +asResolvedDependencies :: Parse D.ManifestError [(PackageName, (Maybe FilePath, DependencyStatus))] asResolvedDependencies = nubBy ((==) `on` fst) <$> go where go = fmap (fromMaybe []) $ keyMay "dependencies" $ - (++) <$> eachInObjectWithKey parsePackageName asDependencyStatus + (++) <$> eachInObjectWithKey parsePackageName asDirectoryAndDependencyStatus <*> (concatMap snd <$> eachInObject asResolvedDependencies) --- | Extracts only the top level dependency names from the output of --- `bower list --json --offline` -asToplevelDependencies :: Parse BowerError [PackageName] +-- | Extracts only the top level dependency names from a resolutions file. +asToplevelDependencies :: Parse D.ManifestError [PackageName] asToplevelDependencies = fmap (map fst) $ key "dependencies" $ eachInObjectWithKey parsePackageName (return ()) -asDependencyStatus :: Parse e DependencyStatus -asDependencyStatus = do +asDirectoryAndDependencyStatus :: Parse e (Maybe FilePath, DependencyStatus) +asDirectoryAndDependencyStatus = do isMissing <- keyOrDefault "missing" False asBool if isMissing then - return Missing - else - key "pkgMeta" $ + return (Nothing, Missing) + else do + directory <- key "canonicalDir" asString + status <- key "pkgMeta" $ keyOrDefault "_resolution" NoResolution $ do type_ <- key "type" asText case type_ of "version" -> ResolvedVersion <$> key "tag" asText other -> return (ResolvedOther other) + return (Just directory, status) warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM () warnUndeclared declared actual = traverse_ (warn . UndeclaredDependency) (actual \\ declared) -handleDeps :: - [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)] +handleDeps + :: [(PackageName, (Maybe FilePath, DependencyStatus))] + -> PrepareM [(PackageName, (FilePath, Version))] handleDeps deps = do - let (missing, noVersion, installed) = partitionDeps deps + let (missing, noVersion, installed, missingPath) = partitionDeps deps case missing of (x:xs) -> userError (MissingDependencies (x :| xs)) [] -> do traverse_ (warn . NoResolvedVersion) noVersion - withVersions <- catMaybes <$> traverse tryExtractVersion' installed - filterM (liftIO . isPureScript . bowerDir . fst) withVersions + traverse_ (warn . MissingPath) missingPath + catMaybes <$> traverse tryExtractVersion' installed where - partitionDeps = foldr go ([], [], []) - go (pkgName, d) (ms, os, is) = + partitionDeps = foldr go ([], [], [], []) + go (pkgName, (Nothing, _)) (ms, os, is, mp) = + (ms, os, is, pkgName : mp) + go (pkgName, (Just path, d)) (ms, os, is, mp) = case d of - Missing -> (pkgName : ms, os, is) - NoResolution -> (ms, pkgName : os, is) - ResolvedOther _ -> (ms, pkgName : os, is) - ResolvedVersion v -> (ms, os, (pkgName, v) : is) - - bowerDir pkgName = T.unpack $ "bower_components/" <> runPackageName pkgName + Missing -> (pkgName : ms, os, is, mp) + NoResolution -> (ms, pkgName : os, is, mp) + ResolvedOther _ -> (ms, pkgName : os, is, mp) + ResolvedVersion v -> (ms, os, (pkgName, (path, v)) : is, mp) -- Try to extract a version, and warn if unsuccessful. - tryExtractVersion' :: (PackageName, Text) -> PrepareM (Maybe (PackageName, Version)) + tryExtractVersion' + :: (PackageName, (extra, Text)) + -> PrepareM (Maybe (PackageName, (extra, Version))) tryExtractVersion' pair = - maybe (warn (UnacceptableVersion pair) >> return Nothing) + maybe (warn (UnacceptableVersion (fmap snd pair)) >> return Nothing) (return . Just) (tryExtractVersion pair) -tryExtractVersion :: (PackageName, Text) -> Maybe (PackageName, Version) -tryExtractVersion (pkgName, tag) = +tryExtractVersion + :: (PackageName, (extra, Text)) + -> Maybe (PackageName, (extra, Version)) +tryExtractVersion (pkgName, (extra, tag)) = let tag' = fromMaybe tag (T.stripPrefix "v" tag) - in (pkgName,) <$> D.parseVersion' (T.unpack tag') - --- | Returns whether it looks like there is a purescript package checked out --- in the given directory. -isPureScript :: FilePath -> IO Bool -isPureScript dir = do - files <- Glob.globDir1 purescriptSourceFiles dir - return (not (null files)) + in (pkgName,) . (extra,) <$> D.parseVersion' (T.unpack tag') -getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)]) -getInputAndDepsFiles = do +getInputAndDepsFiles + :: [(PackageName, FilePath)] + -> IO ([FilePath], [(PackageName, FilePath)]) +getInputAndDepsFiles depPaths = do inputFiles <- globRelative purescriptSourceFiles - depsFiles' <- globRelative purescriptDepsFiles - return (inputFiles, mapMaybe withPackageName depsFiles') - -withPackageName :: FilePath -> Maybe (PackageName, FilePath) -withPackageName fp = (,fp) <$> getPackageName fp - -getPackageName :: FilePath -> Maybe PackageName -getPackageName fp = do - let xs = splitOn [pathSeparator] fp - ys <- stripPrefix ["bower_components"] xs - y <- headMay ys - case Bower.mkPackageName (T.pack y) of - Right name -> Just name - Left _ -> Nothing + let handleDep (pkgName, path) = do + depFiles <- globDir1 purescriptSourceFiles path + return (map (pkgName,) depFiles) + depFiles <- concat <$> traverse handleDep depPaths + return (inputFiles, depFiles) diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index c2f8225352..e62b0a224a 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -18,7 +18,7 @@ import Prelude.Compat import Control.Exception (IOException) import Data.Aeson.BetterErrors (ParseError, displayError) -import Data.List (intersperse, intercalate) +import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe import Data.Monoid @@ -27,10 +27,11 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) import qualified Data.Text as T +import Language.PureScript.Docs.Types (ManifestError) import Language.PureScript.Publish.BoxesHelpers import qualified Language.PureScript as P -import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName, showBowerError) +import Web.Bower.PackageMeta (PackageName, runPackageName, showBowerError) import qualified Web.Bower.PackageMeta as Bower -- | An error which meant that it was not possible to retrieve metadata for a @@ -46,13 +47,14 @@ data PackageWarning | UndeclaredDependency PackageName | UnacceptableVersion (PackageName, Text) | DirtyWorkingTree_Warn + | MissingPath PackageName deriving (Show) -- | An error that should be fixed by the user. data UserError - = BowerJSONNotFound - | BowerExecutableNotFound [String] -- list of executable names tried - | CouldntDecodeBowerJSON (ParseError BowerError) + = PackageManifestNotFound + | ResolutionsFileNotFound + | CouldntDecodePackageManifest (ParseError ManifestError) | TagMustBeCheckedOut | AmbiguousVersions [Version] -- Invariant: should contain at least two elements | BadRepositoryField RepositoryFieldError @@ -72,13 +74,13 @@ data RepositoryFieldError -- | An error that probably indicates a bug in this module. data InternalError - = JSONError JSONSource (ParseError BowerError) + = JSONError JSONSource (ParseError ManifestError) | CouldntParseGitTagDate Text deriving (Show) data JSONSource = FromFile FilePath - | FromBowerList + | FromResolutions deriving (Show) data OtherError @@ -121,24 +123,19 @@ renderError err = displayUserError :: UserError -> Box displayUserError e = case e of - BowerJSONNotFound -> + PackageManifestNotFound -> para ( - "The bower.json file was not found. Please create one, or run " ++ + "The package manifest file was not found. Please create one, or run " ++ "`pulp init`." ) - BowerExecutableNotFound names -> - para (concat - [ "The Bower executable was not found (tried: ", format names, "). Please" - , " ensure that bower is installed and on your PATH." - ]) - where - format = intercalate ", " . map show - CouldntDecodeBowerJSON err -> + ResolutionsFileNotFound -> + para "The resolutions file was not found." + CouldntDecodePackageManifest err -> vcat - [ para "There was a problem with your bower.json file:" + [ para "There was a problem with your package manifest file:" , indented (vcat (map (para . T.unpack) (displayError showBowerError err))) , spacer - , para "Please ensure that your bower.json file is valid." + , para "Please ensure that your package manifest file is valid." ] TagMustBeCheckedOut -> vcat @@ -174,7 +171,7 @@ displayUserError e = case e of NoLicenseSpecified -> vcat $ [ para (concat - [ "No license is specified in bower.json. Please add one, using the " + [ "No license is specified in package manifest. Please add one, using the " , "SPDX license expression format. For example, any of the " , "following would be acceptable:" ]) @@ -195,7 +192,7 @@ displayUserError e = case e of InvalidLicense -> vcat $ [ para (concat - [ "The license specified in bower.json is not a valid SPDX license " + [ "The license specified in package manifest is not a valid SPDX license " , "expression. Please use the SPDX license expression format. For " , "example, any of the following would be acceptable:" ]) @@ -207,20 +204,13 @@ displayUserError e = case e of pl a b = if singular then b else a do_ = pl "do" "does" dependencies = pl "dependencies" "dependency" - them = pl "them" "it" in vcat $ [ para (concat - [ "The following Bower ", dependencies, " ", do_, " not appear to be " + [ "The following ", dependencies, " ", do_, " not appear to be " , "installed:" ]) ] ++ bulletedListT runPackageName (NonEmpty.toList pkgs) - ++ - [ spacer - , para (concat - [ "Please install ", them, " first, by running `bower install`." - ]) - ] CompileError err -> vcat [ para "Compile error:" @@ -247,7 +237,7 @@ displayRepositoryError err = case err of RepositoryFieldMissing -> vcat [ para (concat - [ "The 'repository' field is not present in your bower.json file. " + [ "The 'repository' field is not present in your package manifest file. " , "Without this information, Pursuit would not be able to generate " , "source links in your package's documentation. Please add one - like " , "this, for example:" @@ -263,21 +253,21 @@ displayRepositoryError err = case err of ] BadRepositoryType ty -> para (concat - [ "In your bower.json file, the repository type is currently listed as " + [ "In your package manifest file, the repository type is currently listed as " , "\"" ++ T.unpack ty ++ "\". Currently, only git repositories are supported. " , "Please publish your code in a git repository, and then update the " - , "repository type in your bower.json file to \"git\"." + , "repository type in your package manifest file to \"git\"." ]) NotOnGithub -> vcat [ para (concat - [ "The repository url in your bower.json file does not point to a " + [ "The repository url in your package manifest file does not point to a " , "GitHub repository. Currently, Pursuit does not support packages " , "which are not hosted on GitHub." ]) , spacer , para (concat - [ "Please update your bower.json file to point to a GitHub repository. " + [ "Please update your package manifest file to point to a GitHub repository. " , "Alternatively, if you would prefer not to host your package on " , "GitHub, please open an issue:" ]) @@ -298,8 +288,8 @@ displayJSONSource :: JSONSource -> String displayJSONSource s = case s of FromFile fp -> "in file " ++ show fp - FromBowerList -> - "in the output of `bower list --json --offline`" + FromResolutions -> + "in resolutions file" displayOtherError :: OtherError -> Box displayOtherError e = case e of @@ -317,23 +307,25 @@ data CollectedWarnings = CollectedWarnings , undeclaredDependencies :: [PackageName] , unacceptableVersions :: [(PackageName, Text)] , dirtyWorkingTree :: Any + , missingPaths :: [PackageName] } deriving (Show, Eq, Ord) instance Monoid CollectedWarnings where - mempty = CollectedWarnings mempty mempty mempty mempty - mappend (CollectedWarnings as bs cs d) - (CollectedWarnings as' bs' cs' d') = - CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') (d <> d') + mempty = CollectedWarnings mempty mempty mempty mempty mempty + mappend (CollectedWarnings as bs cs d es) + (CollectedWarnings as' bs' cs' d' es') = + CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') (d <> d') (es <> es') collectWarnings :: [PackageWarning] -> CollectedWarnings collectWarnings = foldMap singular where singular w = case w of - NoResolvedVersion pn -> CollectedWarnings [pn] mempty mempty mempty - UndeclaredDependency pn -> CollectedWarnings mempty [pn] mempty mempty - UnacceptableVersion t -> CollectedWarnings mempty mempty [t] mempty - DirtyWorkingTree_Warn -> CollectedWarnings mempty mempty mempty (Any True) + NoResolvedVersion pn -> CollectedWarnings [pn] mempty mempty mempty mempty + UndeclaredDependency pn -> CollectedWarnings mempty [pn] mempty mempty mempty + UnacceptableVersion t -> CollectedWarnings mempty mempty [t] mempty mempty + DirtyWorkingTree_Warn -> CollectedWarnings mempty mempty mempty (Any True) mempty + MissingPath pn -> CollectedWarnings mempty mempty mempty mempty [pn] renderWarnings :: [PackageWarning] -> Box renderWarnings warns = @@ -345,6 +337,7 @@ renderWarnings warns = , if getAny dirtyWorkingTree then Just warnDirtyWorkingTree else Nothing + , go warnMissingPaths missingPaths ] in case catMaybes mboxes of [] -> nullBox @@ -370,9 +363,8 @@ warnNoResolvedVersions pkgNames = [ spacer , para (concat ["Links to types in ", anyOfThese, " ", packages, " will not work. In " - , "order to make links work, edit your bower.json to specify a version" - , " or a version range for ", these, " ", packages, ", and rerun " - , "`bower install`." + , "order to make links work, edit your package manifest to specify a version" + , " or a version range for ", these, " ", packages, "." ]) ] @@ -386,8 +378,8 @@ warnUndeclaredDependencies pkgNames = dependencies = pl "dependencies" "a dependency" in vcat $ para (concat - [ "The following Bower ", packages, " ", are, " installed, but not " - , "declared as ", dependencies, " in your bower.json file:" + [ "The following ", packages, " ", are, " installed, but not " + , "declared as ", dependencies, " in your package manifest file:" ]) : bulletedListT runPackageName (NonEmpty.toList pkgNames) @@ -403,7 +395,7 @@ warnUnacceptableVersions pkgs = versions = pl "versions" "version" in vcat $ [ para (concat - [ "The following installed Bower ", packages', " ", versions, " could " + [ "The following installed ", packages', " ", versions, " could " , "not be parsed:" ]) ] ++ @@ -412,9 +404,8 @@ warnUnacceptableVersions pkgs = [ spacer , para (concat ["Links to types in ", anyOfThese, " ", packages, " will not work. In " - , "order to make links work, edit your bower.json to specify an " - , "acceptable version or version range for ", these, " ", packages, ", " - , "and rerun `bower install`." + , "order to make links work, edit your package manifest to specify an " + , "acceptable version or version range for ", these, " ", packages, "." ]) ] where @@ -427,5 +418,18 @@ warnDirtyWorkingTree = ++ "were not a dry run)" ) +warnMissingPaths :: NonEmpty PackageName -> Box +warnMissingPaths pkgs = + let singular = NonEmpty.length pkgs == 1 + pl a b = if singular then b else a + + packages = pl "packages" "package" + in vcat $ + para (concat + [ "The following installed ", packages, " were " + , "missing path information in the resolutions file:" + ]) + : bulletedListT runPackageName (NonEmpty.toList pkgs) + printWarnings :: [PackageWarning] -> IO () printWarnings = printToStderr . renderWarnings diff --git a/src/Language/PureScript/Publish/Utils.hs b/src/Language/PureScript/Publish/Utils.hs index a7a410cef9..46c736d5e8 100644 --- a/src/Language/PureScript/Publish/Utils.hs +++ b/src/Language/PureScript/Publish/Utils.hs @@ -1,41 +1,14 @@ +module Language.PureScript.Publish.Utils where -module Language.PureScript.Publish.Utils where +import Prelude.Compat -import Prelude.Compat - -import Data.Either (partitionEithers) -import Data.List - -import System.Directory -import System.Exit (exitFailure) -import System.FilePath (pathSeparator) -import System.IO (hPutStrLn, stderr) -import qualified System.FilePath.Glob as Glob +import System.Directory +import System.FilePath.Glob (Pattern, compile, globDir1) -- | Glob relative to the current directory, and produce relative pathnames. -globRelative :: Glob.Pattern -> IO [FilePath] -globRelative pat = do - currentDir <- getCurrentDirectory - filesAbsolute <- Glob.globDir1 pat currentDir - let prefix = currentDir ++ [pathSeparator] - let (fails, paths) = partitionEithers . map (stripPrefix' prefix) $ filesAbsolute - if null fails - then return paths - else do - let p = hPutStrLn stderr - p "Internal error in Language.PureScript.Publish.Utils.globRelative" - p "Unmatched files:" - mapM_ p fails - exitFailure - - where - stripPrefix' prefix dir = - maybe (Left dir) Right $ stripPrefix prefix dir +globRelative :: Pattern -> IO [FilePath] +globRelative pat = getCurrentDirectory >>= globDir1 pat -- | Glob pattern for PureScript source files. -purescriptSourceFiles :: Glob.Pattern -purescriptSourceFiles = Glob.compile "src/**/*.purs" - --- | Glob pattern for PureScript dependency files. -purescriptDepsFiles :: Glob.Pattern -purescriptDepsFiles = Glob.compile "bower_components/*/src/**/*.purs" +purescriptSourceFiles :: Pattern +purescriptSourceFiles = compile "src/**/*.purs" diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 8c6abaf80f..20cf7beadb 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -42,7 +42,7 @@ publishOpts = Publish.defaultPublishOptions main :: IO () main = pushd "examples/docs" $ do - res <- Publish.preparePackage publishOpts + res <- Publish.preparePackage "bower.json" "resolutions.json" publishOpts case res of Left e -> Publish.printErrorToStdout e >> exitFailure Right pkg@Docs.Package{..} -> diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index a97ca1ff67..89c6f4cd7e 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -18,7 +18,9 @@ import Language.PureScript.Publish.ErrorsWarnings as Publish import TestUtils main :: IO () -main = testPackage "tests/support/bower_components/purescript-prelude" +main = testPackage + "tests/support/bower_components/purescript-prelude" + "../../prelude-resolutions.json" data TestResult = ParseFailed String @@ -47,9 +49,9 @@ testRunOptions = defaultPublishOptions -- | Given a directory which contains a package, produce JSON from it, and then -- | attempt to parse it again, and ensure that it doesn't change. -testPackage :: String -> IO () -testPackage dir = pushd dir $ do - res <- preparePackage testRunOptions +testPackage :: FilePath -> FilePath -> IO () +testPackage dir resolutionsFile = pushd dir $ do + res <- preparePackage "bower.json" resolutionsFile testRunOptions case res of Left e -> preparePackageError e Right package -> case roundTrip package of diff --git a/tests/support/prelude-resolutions.json b/tests/support/prelude-resolutions.json new file mode 100644 index 0000000000..a5704c44b1 --- /dev/null +++ b/tests/support/prelude-resolutions.json @@ -0,0 +1,7 @@ +{ + "canonicalDir": "bower_components/purescript-prelude", + "pkgMeta": { + "dependencies": {} + }, + "dependencies": {} +} From ee2fcf76733bc60642a7d702060463b80a88a26d Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 28 Feb 2017 19:29:36 +0100 Subject: [PATCH 0689/1580] Fix typo (#2698) * fixes a typo * more renamings --- app/Main.hs | 2 +- src/Language/PureScript/Bundle.hs | 4 ++-- src/Language/PureScript/Make.hs | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 25e55a879d..8f69c0fcb1 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -37,7 +37,7 @@ main = do opts = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList infoModList = Opts.fullDesc <> headerInfo <> footerInfo headerInfo = Opts.progDesc "The PureScript compiler and tools" - footerInfo = Opts.footer $ "psc " ++ showVersion Paths.version + footerInfo = Opts.footer $ "purs " ++ showVersion Paths.version versionInfo :: Opts.Parser (a -> a) versionInfo = Opts.abortOption (Opts.InfoMsg versionString) $ diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 76bc678e3d..af226f6db0 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -114,8 +114,8 @@ printErrorMessage :: ErrorMessage -> [String] printErrorMessage (UnsupportedModulePath s) = [ "A CommonJS module has an unsupported name (" ++ show s ++ ")." , "The following file names are supported:" - , " 1) index.js (psc native modules)" - , " 2) foreign.js (psc foreign modules)" + , " 1) index.js (PureScript native modules)" + , " 2) foreign.js (PureScript foreign modules)" ] printErrorMessage InvalidTopLevel = [ "Expected a list of source elements at the top level." ] diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 621878366e..d995c6be0a 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -363,7 +363,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = mapFile = outputDir filePath "index.js.map" externsFile = outputDir filePath "externs.json" foreignFile = outputDir filePath "foreign.js" - prefix = ["Generated by psc version " <> T.pack (showVersion Paths.version) | usePrefix] + prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix] js = T.unlines $ map ("// " <>) prefix ++ [pjs] mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else "" lift $ do From f00ade16c90fc9b4bec717d11534aaafb13ce155 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 3 Mar 2017 09:16:03 -0800 Subject: [PATCH 0690/1580] #2616, errors for open rows in derived instances (#2697) --- examples/failing/2616.purs | 9 ++++ examples/passing/2616.purs | 13 ++++++ .../PureScript/Sugar/TypeClasses/Deriving.hs | 41 ++++++++++++------- 3 files changed, 48 insertions(+), 15 deletions(-) create mode 100644 examples/failing/2616.purs create mode 100644 examples/passing/2616.purs diff --git a/examples/failing/2616.purs b/examples/failing/2616.purs new file mode 100644 index 0000000000..55ff1887bb --- /dev/null +++ b/examples/failing/2616.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Prelude + +newtype Foo r = Foo { | r } + +derive instance eqFoo :: Eq (Foo r) +derive instance ordFoo :: Ord (Foo r) diff --git a/examples/passing/2616.purs b/examples/passing/2616.purs new file mode 100644 index 0000000000..d48e99df3e --- /dev/null +++ b/examples/passing/2616.purs @@ -0,0 +1,13 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +newtype F r a = F { x :: a | r } + +unF :: forall r a. F r a -> { x :: a | r } +unF (F x) = x + +derive instance functorF :: Functor (F r) + +main = log (unF (map id (F { x: "Done", y: 42 }))).x diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 079bde62fd..e5695426ad 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -220,7 +220,8 @@ deriveGeneric mn syns ds tyConNm dargs = do return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (unguarded caseResult) toSpineFun :: Expr -> Type -> Expr - toSpineFun i r | Just rec <- objectType r = + toSpineFun i r | Just rec <- objectType r + , Just fields <- decomposeRec rec = lamNull . recordConstructor . Literal . ArrayLiteral . map (\((Label str),typ) -> @@ -229,7 +230,7 @@ deriveGeneric mn syns ds tyConNm dargs = do , ("recValue", toSpineFun (Accessor str i) typ) ] ) - $ decomposeRec rec + $ fields toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration" @@ -261,13 +262,14 @@ deriveGeneric mn syns ds tyConNm dargs = do ] mkProductSignature :: Type -> Expr - mkProductSignature r | Just rec <- objectType r = + mkProductSignature r | Just rec <- objectType r + , Just fields <- decomposeRec rec = lamNull . mkSigRec $ [ Literal $ ObjectLiteral [ ("recLabel", Literal (StringLiteral str)) , ("recValue", mkProductSignature typ) ] - | ((Label str), typ) <- decomposeRec rec + | ((Label str), typ) <- fields ] mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature)) (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ)) @@ -315,7 +317,8 @@ deriveGeneric mn syns ds tyConNm dargs = do fromSpineFun :: Expr -> Type -> Expr fromSpineFun e r | Just rec <- objectType r - = App (lamCase (Ident "r") [ mkRecCase (decomposeRec rec) + , Just fields <- decomposeRec rec + = App (lamCase (Ident "r") [ mkRecCase fields , CaseAlternative [NullBinder] (unguarded mkNothing) ]) (App e unitVal) @@ -435,8 +438,8 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do ) makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr) - makeArg arg | Just rec <- objectType arg = do - let fields = decomposeRec rec + makeArg arg | Just rec <- objectType arg + , Just fields <- decomposeRec rec = do fieldNames <- traverse freshIdent (map (runIdent . labelToIdent . fst) fields) pure ( TypeApp (TypeConstructor record) (foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) @@ -579,10 +582,11 @@ deriveEq mn syns ds tyConNm = do conjAll xs = foldl1 preludeConj xs toEqTest :: Expr -> Expr -> Type -> Expr - toEqTest l r ty | Just rec <- objectType ty = + toEqTest l r ty | Just rec <- objectType ty + , Just fields <- decomposeRec rec = conjAll . map (\((Label str), typ) -> toEqTest (Accessor str l) (Accessor str r) typ) - $ decomposeRec rec + $ fields toEqTest l r _ = preludeEq l r deriveOrd :: @@ -666,10 +670,11 @@ deriveOrd mn syns ds tyConNm = do ] toOrdering :: Expr -> Expr -> Type -> Expr - toOrdering l r ty | Just rec <- objectType ty = + toOrdering l r ty | Just rec <- objectType ty + , Just fields <- decomposeRec rec = appendAll . map (\((Label str), typ) -> toOrdering (Accessor str l) (Accessor str r) typ) - $ decomposeRec rec + $ fields toOrdering l r _ = ordCompare l r deriveNewtype @@ -755,9 +760,15 @@ objectType :: Type -> Maybe Type objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec objectType _ = Nothing -decomposeRec :: Type -> [(Label, Type)] -decomposeRec = sortBy (comparing fst) . go - where go (RCons str typ typs) = (str, typ) : decomposeRec typs +decomposeRec :: Type -> Maybe [(Label, Type)] +decomposeRec = fmap (sortBy (comparing fst)) . go + where go (RCons str typ typs) = fmap ((str, typ) :) (go typs) + go REmpty = Just [] + go _ = Nothing + +decomposeRec' :: Type -> [(Label, Type)] +decomposeRec' = sortBy (comparing fst) . go + where go (RCons str typ typs) = (str, typ) : go typs go _ = [] deriveFunctor @@ -806,7 +817,7 @@ deriveFunctor mn syns ds tyConNm = do -- records goType recTy | Just row <- objectType recTy = - traverse buildUpdate (decomposeRec row) >>= (traverse buildRecord . justUpdates) + traverse buildUpdate (decomposeRec' row) >>= (traverse buildRecord . justUpdates) where justUpdates :: [Maybe (Label, Expr)] -> Maybe [(Label, Expr)] justUpdates = foldMap (fmap return) From 14b8bff9268c7c8ce74c191a5ba5e91561487000 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 4 Mar 2017 14:01:37 -0800 Subject: [PATCH 0691/1580] Allow duplicate labels (#2696) * Allow duplicate labels #2311 * Fix unification to deal with duplicate rows * Refactor: extract alignRowsWith * Typos, test --- ...perties1.purs => DuplicateProperties.purs} | 0 examples/failing/DuplicateProperties2.purs | 12 ---- examples/passing/DuplicateProperties.purs | 27 ++++++++ purescript.cabal | 1 - .../PureScript/TypeChecker/Entailment.hs | 56 +++++++-------- src/Language/PureScript/TypeChecker/Rows.hs | 53 --------------- .../PureScript/TypeChecker/Subsumption.hs | 27 ++------ src/Language/PureScript/TypeChecker/Types.hs | 3 - src/Language/PureScript/TypeChecker/Unify.hs | 68 +++++++++++-------- src/Language/PureScript/Types.hs | 29 ++++---- tests/support/bower.json | 2 +- 11 files changed, 112 insertions(+), 166 deletions(-) rename examples/failing/{DuplicateProperties1.purs => DuplicateProperties.purs} (100%) delete mode 100644 examples/failing/DuplicateProperties2.purs create mode 100644 examples/passing/DuplicateProperties.purs delete mode 100644 src/Language/PureScript/TypeChecker/Rows.hs diff --git a/examples/failing/DuplicateProperties1.purs b/examples/failing/DuplicateProperties.purs similarity index 100% rename from examples/failing/DuplicateProperties1.purs rename to examples/failing/DuplicateProperties.purs diff --git a/examples/failing/DuplicateProperties2.purs b/examples/failing/DuplicateProperties2.purs deleted file mode 100644 index bf886909f0..0000000000 --- a/examples/failing/DuplicateProperties2.purs +++ /dev/null @@ -1,12 +0,0 @@ --- @shouldFailWith DuplicateLabel -module DuplicateProperties where - -import Prelude - -foreign import data Test :: # * -> * - -foreign import subtractX :: forall r. Test (x :: Unit | r) -> Test r - -foreign import hasX :: forall r. Test (x :: Unit, y :: Unit | r) - -baz = subtractX (subtractX hasX) diff --git a/examples/passing/DuplicateProperties.purs b/examples/passing/DuplicateProperties.purs new file mode 100644 index 0000000000..380e227487 --- /dev/null +++ b/examples/passing/DuplicateProperties.purs @@ -0,0 +1,27 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +data RProxy (r :: # *) = RProxy + +data Proxy (a :: *) = Proxy + +subtractX :: forall r a. RProxy (x :: a | r) -> RProxy r +subtractX RProxy = RProxy + +extractX :: forall r a. RProxy (x :: a | r) -> Proxy a +extractX RProxy = Proxy + +hasX :: forall r a b. RProxy (x :: a, y :: b | r) +hasX = RProxy + +test1 = subtractX (subtractX hasX) + +test2 + :: forall r a b + . RProxy (x :: a, x :: b, x :: Int | r) + -> Proxy Int +test2 x = extractX (subtractX (subtractX x)) + +main = log "Done" diff --git a/purescript.cabal b/purescript.cabal index 6d9c4df9da..e0b4b0202c 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -258,7 +258,6 @@ library Language.PureScript.TypeChecker.Entailment Language.PureScript.TypeChecker.Kinds Language.PureScript.TypeChecker.Monad - Language.PureScript.TypeChecker.Rows Language.PureScript.TypeChecker.Skolems Language.PureScript.TypeChecker.Subsumption Language.PureScript.TypeChecker.Synonyms diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 44dc445414..3c3c0cf1f8 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -392,24 +392,19 @@ matches deps TypeClassDictionaryInScope{..} tys = do both (typeHeadsAreEqual h1 h2) (typeHeadsAreEqual t1 t2) typeHeadsAreEqual REmpty REmpty = (True, M.empty) typeHeadsAreEqual r1@RCons{} r2@RCons{} = - foldr both (go sd1 r1' sd2 r2') (map (uncurry typeHeadsAreEqual) int) + foldr both (uncurry go rest) common where - (s1, r1') = rowToList r1 - (s2, r2') = rowToList r2 - - int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] - sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] - sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] - - go :: [(Label, Type)] -> Type -> [(Label, Type)] -> Type -> (Bool, Matching [Type]) - go l (KindedType t1 _) r t2 = go l t1 r t2 - go l t1 r (KindedType t2 _) = go l t1 r t2 - go [] REmpty [] REmpty = (True, M.empty) - go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = (True, M.empty) - go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = (True, M.empty) - go [] (Skolem _ sk1 _ _) [] (Skolem _ sk2 _ _) | sk1 == sk2 = (True, M.empty) - go sd r [] (TypeVar v) = (True, M.singleton v [rowFromList (sd, r)]) - go _ _ _ _ = (False, M.empty) + (common, rest) = alignRowsWith typeHeadsAreEqual r1 r2 + + go :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> (Bool, Matching [Type]) + go (l, KindedType t1 _) (r, t2) = go (l, t1) (r, t2) + go (l, t1) (r, KindedType t2 _) = go (l, t1) (r, t2) + go ([], REmpty) ([], REmpty) = (True, M.empty) + go ([], TUnknown u1) ([], TUnknown u2) | u1 == u2 = (True, M.empty) + go ([], TypeVar v1) ([], TypeVar v2) | v1 == v2 = (True, M.empty) + go ([], Skolem _ sk1 _ _) ([], Skolem _ sk2 _ _) | sk1 == sk2 = (True, M.empty) + go (sd, r) ([], TypeVar v) = (True, M.singleton v [rowFromList (sd, r)]) + go _ _ = (False, M.empty) typeHeadsAreEqual _ _ = (False, M.empty) both :: (Bool, Matching [Type]) -> (Bool, Matching [Type]) -> (Bool, Matching [Type]) @@ -435,23 +430,18 @@ matches deps TypeClassDictionaryInScope{..} tys = do typesAreEqual (TypeApp h1 t1) (TypeApp h2 t2) = typesAreEqual h1 h2 && typesAreEqual t1 t2 typesAreEqual REmpty REmpty = True typesAreEqual r1 r2 | isRCons r1 || isRCons r2 = - let (s1, r1') = rowToList r1 - (s2, r2') = rowToList r2 - - int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] - sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] - sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] - in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2' + let (common, rest) = alignRowsWith typesAreEqual r1 r2 + in and common && uncurry go rest where - go :: [(Label, Type)] -> Type -> [(Label, Type)] -> Type -> Bool - go l (KindedType t1 _) r t2 = go l t1 r t2 - go l t1 r (KindedType t2 _) = go l t1 r t2 - go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True - go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2 - go [] REmpty [] REmpty = True - go [] (TypeVar v1) [] (TypeVar v2) = v1 == v2 - go _ _ _ _ = False - typesAreEqual _ _ = False + go :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> Bool + go (l, KindedType t1 _) (r, t2) = go (l, t1) (r, t2) + go (l, t1) (r, KindedType t2 _) = go (l, t1) (r, t2) + go ([], TUnknown u1) ([], TUnknown u2) | u1 == u2 = True + go ([], Skolem _ s1 _ _) ([], Skolem _ s2 _ _) = s1 == s2 + go ([], REmpty) ([], REmpty) = True + go ([], TypeVar v1) ([], TypeVar v2) = v1 == v2 + go _ _ = False + typesAreEqual _ _ = False isRCons :: Type -> Bool isRCons RCons{} = True diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs deleted file mode 100644 index 850ae129ec..0000000000 --- a/src/Language/PureScript/TypeChecker/Rows.hs +++ /dev/null @@ -1,53 +0,0 @@ --- | --- Functions relating to type checking for rows --- -module Language.PureScript.TypeChecker.Rows - ( checkDuplicateLabels - ) where - -import Prelude.Compat - -import Control.Monad -import Control.Monad.Error.Class (MonadError(..)) - -import Data.List - -import Language.PureScript.AST -import Language.PureScript.Errors -import Language.PureScript.Types - --- | Ensure rows do not contain duplicate labels -checkDuplicateLabels :: forall m. (MonadError MultipleErrors m) => Expr -> m () -checkDuplicateLabels = - let (_, f, _) = everywhereOnValuesM def go def - in void . f - where - def :: a -> m a - def = return - - go :: Expr -> m Expr - go e@(TypedValue _ val ty) = do - checkDups ty - return e - - where - checkDups :: Type -> m () - checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2 - checkDups (ForAll _ t _) = checkDups t - checkDups (ConstrainedType args t) = do - mapM_ checkDups $ concatMap constraintArgs args - checkDups t - checkDups r@RCons{} = - let (ls, _) = rowToList r in - case firstDup . sort . map fst $ ls of - Just l -> throwError . errorMessage $ DuplicateLabel l (Just val) - Nothing -> return () - checkDups _ = return () - - firstDup :: (Eq a) => [a] -> Maybe a - firstDup (x : xs@(x' : _)) - | x == x' = Just x - | otherwise = firstDup xs - firstDup _ = Nothing - - go other = return other diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 82c685e241..87e56f0dcc 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -13,7 +13,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets) import Data.Foldable (for_) -import Data.List (sortBy, uncons) +import Data.List (uncons) import Data.List.Ordered (minusBy') import Data.Ord (comparing) @@ -103,11 +103,7 @@ subsumes' SElaborate (ConstrainedType constraints ty1) ty2 = do let addDicts val = foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints) return (elaborate . addDicts) subsumes' mode (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do - let - (ts1, r1') = rowToList r1 - (ts2, r2') = rowToList r2 - ts1' = sortBy (comparing fst) ts1 - ts2' = sortBy (comparing fst) ts2 + let (common, ((ts1', r1'), (ts2', r2'))) = alignRowsWith (subsumes' SNoElaborate) r1 r2 -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row), -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property. -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has @@ -116,25 +112,12 @@ subsumes' mode (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecor (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst)) when (r2' == REmpty) (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst)) - go ts1' ts2' r1' r2' + -- Check subsumption for common labels + sequence_ common + unifyTypes (rowFromList (ts1', r1')) (rowFromList (ts2', r2')) -- Nothing was elaborated, return the default coercion return (defaultCoercion mode) where - go [] ts2 r1' r2' = unifyTypes r1' (rowFromList (ts2, r2')) - go ts1 [] r1' r2' = unifyTypes r2' (rowFromList (ts1, r1')) - go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2' - | p1 == p2 = do subsumes' SNoElaborate ty1 ty2 - go ts1 ts2 r1' r2' - | p1 < p2 = do rest <- freshType - -- What happens next is a bit of a hack. - -- TODO: in the new type checker, object properties will probably be restricted to being monotypes - -- in which case, this branch of the subsumes function should not even be necessary. - unifyTypes r2' (RCons p1 ty1 rest) - go ts1 ((p2, ty2) : ts2) r1' rest - | otherwise = do rest <- freshType - unifyTypes r1' (RCons p2 ty2 rest) - go ((p1, ty1) : ts1) ts2 rest r2' - -- Find the first property that's in the first list (of tuples) but not in the second firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing fst) t1 t2) subsumes' mode ty1 ty2@(TypeApp obj _) | obj == tyRecord = diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 84b605ef43..4043b37088 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -54,7 +54,6 @@ import Language.PureScript.Traversals import Language.PureScript.TypeChecker.Entailment import Language.PureScript.TypeChecker.Kinds import Language.PureScript.TypeChecker.Monad -import Language.PureScript.TypeChecker.Rows import Language.PureScript.TypeChecker.Skolems import Language.PureScript.TypeChecker.Subsumption import Language.PureScript.TypeChecker.Synonyms @@ -117,8 +116,6 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -- Check skolem variables did not escape their scope skolemEscapeCheck val' - -- Check rows do not contain duplicate labels - checkDuplicateLabels val' return ((ident, (foldr (Abs . Left . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved) -- Show warnings here, since types in wildcards might have been solved during diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 2b30f9feed..804c1c4329 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -10,6 +10,7 @@ module Language.PureScript.TypeChecker.Unify , unknownsInType , unifyTypes , unifyRows + , alignRowsWith , replaceVarWithUnknown , replaceTypeWildcards , varIfUnknown @@ -18,6 +19,7 @@ module Language.PureScript.TypeChecker.Unify import Prelude.Compat import Protolude (ordNub) +import Control.Arrow (first, second) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets, modify) @@ -122,38 +124,50 @@ unifyTypes t1 t2 = do unifyTypes' t3 t4 = throwError . errorMessage $ TypesDoNotUnify t3 t4 --- | --- Unify two rows, updating the current substitution +-- | Align two rows of types, splitting them into three parts: +-- +-- * Those types which appear in both rows +-- * Those which appear only on the left +-- * Those which appear only on the right -- --- Common labels are first identified, and unified. Remaining labels and types are unified with a --- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification --- error. +-- Note: importantly, we preserve the order of the types with a given label. +alignRowsWith + :: (Type -> Type -> a) + -> Type + -> Type + -> ([a], (([(Label, Type)], Type), ([(Label, Type)], Type))) +alignRowsWith f ty1 ty2 = go s1 s2 where + (s1, tail1) = rowToSortedList ty1 + (s2, tail2) = rowToSortedList ty2 + + go [] r = ([], (([], tail1), (r, tail2))) + go r [] = ([], ((r, tail1), ([], tail2))) + go lhs@((l1, t1) : r1) rhs@((l2, t2) : r2) + | l1 < l2 = (second . first . first) ((l1, t1) :) (go r1 rhs) + | l2 < l1 = (second . second . first) ((l2, t2) :) (go lhs r2) + | otherwise = first (f t1 t2 :) (go r1 r2) + +-- | Unify two rows, updating the current substitution -- +-- Common labels are identified and unified. Remaining labels and types are unified with a +-- trailing row unification variable, if appropriate. unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m () -unifyRows r1 r2 = - let - (s1, r1') = rowToList r1 - (s2, r2') = rowToList r2 - int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] - sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] - sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] - in do - forM_ int (uncurry unifyTypes) - unifyRows' sd1 r1' sd2 r2' - where - unifyRows' :: [(Label, Type)] -> Type -> [(Label, Type)] -> Type -> m () - unifyRows' [] (TUnknown u) sd r = solveType u (rowFromList (sd, r)) - unifyRows' sd r [] (TUnknown u) = solveType u (rowFromList (sd, r)) - unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do +unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where + (matches, rest) = alignRowsWith unifyTypes r1 r2 + + unifyTails :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> m () + unifyTails ([], TUnknown u) (sd, r) = solveType u (rowFromList (sd, r)) + unifyTails (sd, r) ([], TUnknown u) = solveType u (rowFromList (sd, r)) + unifyTails ([], REmpty) ([], REmpty) = return () + unifyTails ([], TypeVar v1) ([], TypeVar v2) | v1 == v2 = return () + unifyTails ([], Skolem _ s1 _ _) ([], Skolem _ s2 _ _) | s1 == s2 = return () + unifyTails (sd1, TUnknown u1) (sd2, TUnknown u2) = do forM_ sd1 $ \(_, t) -> occursCheck u2 t forM_ sd2 $ \(_, t) -> occursCheck u1 t - rest <- freshType - solveType u1 (rowFromList (sd2, rest)) - solveType u2 (rowFromList (sd1, rest)) - unifyRows' [] REmpty [] REmpty = return () - unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return () - unifyRows' [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) | s1 == s2 = return () - unifyRows' _ _ _ _ = + rest' <- freshType + solveType u1 (rowFromList (sd2, rest')) + solveType u2 (rowFromList (sd1, rest')) + unifyTails _ _ = throwError . errorMessage $ TypesDoNotUnify r1 r2 -- | diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 1028f01eb2..cbb3e35885 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -9,9 +9,12 @@ module Language.PureScript.Types where import Prelude.Compat import Protolude (ordNub) +import Control.Arrow (first) import Control.Monad ((<=<)) import qualified Data.Aeson as A import qualified Data.Aeson.TH as A +import Data.List (sortBy) +import Data.Ord (comparing) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) @@ -107,24 +110,22 @@ $(A.deriveJSON A.defaultOptions ''Type) $(A.deriveJSON A.defaultOptions ''Constraint) $(A.deriveJSON A.defaultOptions ''ConstraintData) --- | --- Convert a row to a list of pairs of labels and types --- +-- | Convert a row to a list of pairs of labels and types rowToList :: Type -> ([(Label, Type)], Type) -rowToList (RCons name ty row) = let (tys, rest) = rowToList row - in ((name, ty):tys, rest) -rowToList r = ([], r) +rowToList = go where + go (RCons name ty row) = + first ((name, ty) :) (rowToList row) + go r = ([], r) --- | --- Convert a list of labels and types to a row --- +-- | Convert a row to a list of pairs of labels and types, sorted by the labels. +rowToSortedList :: Type -> ([(Label, Type)], Type) +rowToSortedList = first (sortBy (comparing fst)) . rowToList + +-- | Convert a list of labels and types to a row rowFromList :: ([(Label, Type)], Type) -> Type -rowFromList ([], r) = r -rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r)) +rowFromList (xs, r) = foldr (uncurry RCons) r xs --- | --- Check whether a type is a monotype --- +-- | Check whether a type is a monotype isMonoType :: Type -> Bool isMonoType ForAll{} = False isMonoType (ParensInType t) = isMonoType t diff --git a/tests/support/bower.json b/tests/support/bower.json index 9726e7b465..19bf7f0f82 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -6,7 +6,7 @@ "purescript-console": "2.0.0", "purescript-eff": "2.0.0", "purescript-functions": "2.0.0", - "purescript-prelude": "2.4.0", + "purescript-prelude": "2.5.0", "purescript-st": "2.0.0", "purescript-partial": "1.1.2", "purescript-newtype": "1.1.0", From 3ac92fad05bd0c1931c9421d0c9fcea22b45400c Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 5 Mar 2017 09:03:30 -0800 Subject: [PATCH 0692/1580] Fix tests in CI build (#2705) From 7ebd80c541585ca296efb67ca5d9247f7a6d0956 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 5 Mar 2017 09:17:30 -0800 Subject: [PATCH 0693/1580] Make superclass codegen less ugly (#2704) * Make superclass codegen less ugly, fix #1186 * Fix tests --- src/Language/PureScript/Constants.hs | 3 -- src/Language/PureScript/Sugar/TypeClasses.hs | 51 +++++++++---------- .../PureScript/TypeChecker/Entailment.hs | 11 ++-- .../PureScript/TypeClassDictionaries.hs | 7 +++ 4 files changed, 35 insertions(+), 37 deletions(-) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 6985c0a77f..21d79e5661 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -392,9 +392,6 @@ symbol = "Symbol" -- Code Generation -__superclass_ :: forall a. (IsString a) => a -__superclass_ = "__superclass_" - __unused :: forall a. (IsString a) => a __unused = "__unused" diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 1273b4bf81..aae02d33c3 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -10,29 +10,26 @@ module Language.PureScript.Sugar.TypeClasses import Prelude.Compat -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Errors hiding (isExported) -import Language.PureScript.Kinds -import Language.PureScript.Names -import Language.PureScript.Externs -import Language.PureScript.Sugar.CaseDeclarations -import Control.Monad.Supply.Class -import Language.PureScript.Types -import Language.PureScript.Label (Label(..)) -import Language.PureScript.PSString (mkString) - -import qualified Language.PureScript.Constants as C - -import Control.Arrow (first, second) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State -import Data.List ((\\), find, sortBy) -import Data.Maybe (catMaybes, mapMaybe, isJust) +import Control.Arrow (first, second) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State +import Control.Monad.Supply.Class +import Data.List ((\\), find, sortBy) import qualified Data.Map as M -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T +import Data.Maybe (catMaybes, mapMaybe, isJust) +import Data.Text (Text) +import qualified Language.PureScript.Constants as C +import Language.PureScript.Crash +import Language.PureScript.Environment +import Language.PureScript.Errors hiding (isExported) +import Language.PureScript.Externs +import Language.PureScript.Kinds +import Language.PureScript.Label (Label(..)) +import Language.PureScript.Names +import Language.PureScript.PSString (mkString) +import Language.PureScript.Sugar.CaseDeclarations +import Language.PureScript.Types +import Language.PureScript.TypeClassDictionaries (superclassName) type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData @@ -126,7 +123,7 @@ desugarModule _ = internalError "Exports should have been elaborated in name des -- -- -- type Sub a = { sub :: a --- , "__superclass_Foo_0" :: {} -> Foo a +-- , "Foo0" :: {} -> Foo a -- } -- -- -- As with `foo` above, this type is unchecked at the declaration @@ -135,7 +132,7 @@ desugarModule _ = internalError "Exports should have been elaborated in name des -- -- subString :: {} -> Sub String -- subString _ = { sub: "", --- , "__superclass_Foo_0": \_ -> +-- , "Foo0": \_ -> -- } -- -- and finally as the generated javascript: @@ -158,8 +155,8 @@ desugarModule _ = internalError "Exports should have been elaborated in name des -- return new Foo(map(foo(__dict_Foo_15))); -- }; -- --- function Sub(__superclass_Foo_0, sub) { --- this["__superclass_Foo_0"] = __superclass_Foo_0; +-- function Sub(Foo0, sub) { +-- this["Foo0"] = Foo0; -- this.sub = sub; -- }; -- @@ -333,6 +330,6 @@ typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration superClassDictionaryNames :: [Constraint] -> [Text] superClassDictionaryNames supers = - [ C.__superclass_ <> showQualified runProperName pn <> "_" <> T.pack (show (index :: Integer)) + [ superclassName pn index | (index, Constraint pn _ _) <- zip [0..] supers ] diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 3c3c0cf1f8..d1ec217bfe 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -26,7 +26,6 @@ import Data.List (minimumBy) import Data.Maybe (fromMaybe, maybeToList, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S -import qualified Data.Text as T import Data.Text (Text) import Language.PureScript.AST @@ -222,7 +221,7 @@ entails SolverOptions{..} constraint context hints = -- Solve any necessary subgoals args <- solveSubgoals subst'' (tcdDependencies tcd) initDict <- lift . lift $ mkDictionary (tcdValue tcd) args - let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index) + let match = foldr (\(className, index) dict -> subclassDictionaryValue dict className index) initDict (tcdPath tcd) return match @@ -331,11 +330,9 @@ entails SolverOptions{..} constraint context hints = return $ TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral [])) -- Turn a DictionaryValue into a Expr - subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr - subclassDictionaryValue dict superclassName index = - App (Accessor (mkString (C.__superclass_ <> showQualified runProperName superclassName <> "_" <> T.pack (show index))) - dict) - valUndefined + subclassDictionaryValue :: Expr -> Qualified (ProperName 'ClassName) -> Integer -> Expr + subclassDictionaryValue dict className index = + App (Accessor (mkString (superclassName className index)) dict) valUndefined -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 13281c17c3..3b3448a4fe 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -4,6 +4,9 @@ module Language.PureScript.TypeClassDictionaries where import Prelude.Compat +import Data.Monoid ((<>)) +import Data.Text (Text, pack) + import Language.PureScript.Names import Language.PureScript.Types @@ -27,3 +30,7 @@ data TypeClassDictionaryInScope v type NamedDict = TypeClassDictionaryInScope (Qualified Ident) +-- | Generate a name for a superclass reference which can be used in +-- generated code. +superclassName :: Qualified (ProperName 'ClassName) -> Integer -> Text +superclassName pn index = runProperName (disqualify pn) <> pack (show index) From 01017f22110813d7bb28f17a725cf3a72a6fd25c Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 5 Mar 2017 18:59:04 +0100 Subject: [PATCH 0694/1580] [psc-ide] Don't create the output/ directory if it can't be found (#2700) Leaving stray directories around isn't polite --- app/Command/Ide.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index a88d236b6b..d97101597b 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -115,9 +115,7 @@ command = Opts.helper <*> subcommands where let fullOutputPath = cwd outputPath unlessM (doesDirectoryExist fullOutputPath) $ do - putStrLn ("Your output directory didn't exist. I'll create it at: " <> fullOutputPath) - createDirectory fullOutputPath - putText "This usually means you didn't compile your project yet." + putText "Your output directory didn't exist. This usually means you didn't compile your project yet." putText "psc-ide needs you to compile your project (for example by running pulp build)" unless noWatch $ From f170a1af24676a532ec20cbb0d37ac0e1c7d709a Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 5 Mar 2017 19:17:39 +0100 Subject: [PATCH 0695/1580] [psc-ide] removes the deprecated --debug option (#2699) * [psc-ide] removes the deprecated --debug option It's subsumed by --log-level=debug * fix test failures * convert line endings to LF, for consistency --- app/Command/Ide.hs | 10 ++- examples/passing/RebindableSyntax.purs | 86 +++++++++++++------------- examples/passing/StringEscapes.purs | 52 ++++++++-------- psc-ide/README.md | 1 - 4 files changed, 73 insertions(+), 76 deletions(-) diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index d97101597b..b7d45cc4c0 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -68,7 +68,6 @@ data ServerOptions = ServerOptions , _serverPort :: PortNumber , _serverNoWatch :: Bool , _serverPolling :: Bool - , _serverDebug :: Bool , _serverLoglevel :: IdeLogLevel } deriving (Show) @@ -107,8 +106,9 @@ command = Opts.helper <*> subcommands where Opts.option Opts.auto (Opts.long "port" <> Opts.short 'p' <> Opts.value (4242 :: Integer)) server :: ServerOptions -> IO () - server opts'@(ServerOptions dir globs outputPath port noWatch polling debug logLevel) = do - when debug (putText "Parsed Options:" *> print opts') + server opts'@(ServerOptions dir globs outputPath port noWatch polling logLevel) = do + when (logLevel == LogDebug || logLevel == LogAll) + (putText "Parsed Options:" *> print opts') maybe (pure ()) setCurrentDirectory dir ideState <- newTVarIO emptyIdeState cwd <- getCurrentDirectory @@ -120,8 +120,7 @@ command = Opts.helper <*> subcommands where unless noWatch $ void (forkFinally (watcher polling ideState fullOutputPath) print) - -- TODO: deprecate and get rid of `debug` - let conf = Configuration {confLogLevel = if debug then LogDebug else logLevel, confOutputPath = outputPath, confGlobs = globs} + let conf = Configuration {confLogLevel = logLevel, confOutputPath = outputPath, confGlobs = globs} env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf} startServer port env @@ -135,7 +134,6 @@ command = Opts.helper <*> subcommands where Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer))) <*> Opts.switch (Opts.long "no-watch") <*> flipIfWindows (Opts.switch (Opts.long "polling")) - <*> Opts.switch (Opts.long "debug") <*> (parseLogLevel <$> Opts.strOption (Opts.long "log-level" `mappend` Opts.value "" diff --git a/examples/passing/RebindableSyntax.purs b/examples/passing/RebindableSyntax.purs index 0b5f7d8871..ae283f5425 100644 --- a/examples/passing/RebindableSyntax.purs +++ b/examples/passing/RebindableSyntax.purs @@ -1,43 +1,43 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console (log) - -example1 :: String -example1 = do - "Do" - " notation" - " for" - " Semigroup" - where - discard x f = x <> f unit - -applySecond :: forall f a b. (Apply f) => f a -> f b -> f b -applySecond fa fb = const id <$> fa <*> fb - -infixl 4 applySecond as *> - -newtype Const a b = Const a - -runConst :: forall a b. Const a b -> a -runConst (Const a) = a - -instance functorConst :: Functor (Const a) where - map _ (Const a) = Const a - -instance applyConst :: (Semigroup a) => Apply (Const a) where - apply (Const a1) (Const a2) = Const (a1 <> a2) - -example2 :: Const String Unit -example2 = do - Const "Do" - Const " notation" - Const " for" - Const " Apply" - where - discard x f = x *> f unit - -main = do - log example1 - log $ runConst example2 - log "Done" +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +example1 :: String +example1 = do + "Do" + " notation" + " for" + " Semigroup" + where + discard x f = x <> f unit + +applySecond :: forall f a b. (Apply f) => f a -> f b -> f b +applySecond fa fb = const id <$> fa <*> fb + +infixl 4 applySecond as *> + +newtype Const a b = Const a + +runConst :: forall a b. Const a b -> a +runConst (Const a) = a + +instance functorConst :: Functor (Const a) where + map _ (Const a) = Const a + +instance applyConst :: (Semigroup a) => Apply (Const a) where + apply (Const a1) (Const a2) = Const (a1 <> a2) + +example2 :: Const String Unit +example2 = do + Const "Do" + Const " notation" + Const " for" + Const " Apply" + where + discard x f = x *> f unit + +main = do + log example1 + log $ runConst example2 + log "Done" diff --git a/examples/passing/StringEscapes.purs b/examples/passing/StringEscapes.purs index f9d335e202..7d0732b83f 100644 --- a/examples/passing/StringEscapes.purs +++ b/examples/passing/StringEscapes.purs @@ -1,26 +1,26 @@ -module Main where - -import Prelude ((==), (/=), (<>), discard) -import Test.Assert (assert, assert') -import Control.Monad.Eff.Console (log) - -singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C" -hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0" -decimal = "\119558\9731\966\224\0" == "𝌆☃φà\0" -surrogatePair = "\xD834\xDF06" == "\x1D306" -highSurrogate = "\xD834" -lowSurrogate = "\xDF06" -loneSurrogates = (highSurrogate <> lowSurrogate) == "\x1D306" -outOfOrderSurrogates = (lowSurrogate <> highSurrogate) == "\xDF06\xD834" -replacement = "\xFFFD" -notReplacing = replacement /= highSurrogate - -main = do - assert' "single-character escape sequences" singleCharacter - assert' "hex escape sequences" hex - assert' "decimal escape sequences" decimal - assert' "astral code points are represented as a UTF-16 surrogate pair" surrogatePair - assert' "lone surrogates may be combined into a surrogate pair" loneSurrogates - assert' "lone surrogates may be combined out of order to remain lone surrogates" outOfOrderSurrogates - assert' "lone surrogates are not replaced with the Unicode replacement character U+FFFD" notReplacing - log "Done" +module Main where + +import Prelude ((==), (/=), (<>), discard) +import Test.Assert (assert, assert') +import Control.Monad.Eff.Console (log) + +singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C" +hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0" +decimal = "\119558\9731\966\224\0" == "𝌆☃φà\0" +surrogatePair = "\xD834\xDF06" == "\x1D306" +highSurrogate = "\xD834" +lowSurrogate = "\xDF06" +loneSurrogates = (highSurrogate <> lowSurrogate) == "\x1D306" +outOfOrderSurrogates = (lowSurrogate <> highSurrogate) == "\xDF06\xD834" +replacement = "\xFFFD" +notReplacing = replacement /= highSurrogate + +main = do + assert' "single-character escape sequences" singleCharacter + assert' "hex escape sequences" hex + assert' "decimal escape sequences" decimal + assert' "astral code points are represented as a UTF-16 surrogate pair" surrogatePair + assert' "lone surrogates may be combined into a surrogate pair" loneSurrogates + assert' "lone surrogates may be combined out of order to remain lone surrogates" outOfOrderSurrogates + assert' "lone surrogates are not replaced with the Unicode replacement character U+FFFD" notReplacing + log "Done" diff --git a/psc-ide/README.md b/psc-ide/README.md index 88fac0ce8b..231793520b 100644 --- a/psc-ide/README.md +++ b/psc-ide/README.md @@ -24,7 +24,6 @@ It supports the following options: directory or the directory specified by `-d`. - `--polling`: Uses polling instead of file system events to watch the externs files. This flag is reversed on Windows and polling is the default. -- `--debug`: DEPRECATED: use --log-level="debug" - `--log-level`: Can be set to one of "all", "none", "debug" and "perf" - `--no-watch`: Disables the filewatcher - `--version`: Output psc-ide version From 8ad3994ccd52d015e21bc5a282bb2327c1c04d46 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 5 Mar 2017 11:44:10 -0800 Subject: [PATCH 0696/1580] Fix Generic deriving with synonyms (#2706) --- examples/passing/2695.purs | 13 +++++++++++++ .../PureScript/Sugar/TypeClasses/Deriving.hs | 18 ++++++++++-------- 2 files changed, 23 insertions(+), 8 deletions(-) create mode 100644 examples/passing/2695.purs diff --git a/examples/passing/2695.purs b/examples/passing/2695.purs new file mode 100644 index 0000000000..1957342b48 --- /dev/null +++ b/examples/passing/2695.purs @@ -0,0 +1,13 @@ +module Main where + +import Prelude +import Data.Generic +import Control.Monad.Eff.Console (log) + +type Foo = { foo :: Int } + +newtype Foo' = Foo' Foo + +derive instance genericFoo :: Generic Foo' + +main = log "Done" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index e5695426ad..1da6d3909a 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -192,7 +192,7 @@ deriveGeneric mn syns ds tyConNm dargs = do tyCon <- findTypeDecl tyConNm ds toSpine <- mkSpineFunction tyCon fromSpine <- mkFromSpineFunction tyCon - let toSignature = mkSignatureFunction tyCon dargs + toSignature <- mkSignatureFunction tyCon dargs return [ ValueDeclaration (Ident C.toSpine) Public [] (unguarded toSpine) , ValueDeclaration (Ident C.fromSpine) Public [] (unguarded fromSpine) , ValueDeclaration (Ident C.toSignature) Public [] (unguarded toSignature) @@ -235,8 +235,8 @@ deriveGeneric mn syns ds tyConNm dargs = do mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration" - mkSignatureFunction :: Declaration -> [Type] -> Expr - mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args + mkSignatureFunction :: Declaration -> [Type] -> m Expr + mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd <$> mapM mkProdClause args where mkSigProd :: [Expr] -> Expr mkSigProd = @@ -254,11 +254,12 @@ deriveGeneric mn syns ds tyConNm dargs = do proxy :: Type -> Type proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy"))) - mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr - mkProdClause (ctorName, tys) = - Literal $ ObjectLiteral + mkProdClause :: (ProperName 'ConstructorName, [Type]) -> m Expr + mkProdClause (ctorName, tys) = do + tys' <- mapM (replaceAllTypeSynonymsM syns) tys + return $ Literal $ ObjectLiteral [ ("sigConstructor", Literal (StringLiteral $ mkString (showQualified runProperName (Qualified (Just mn) ctorName)))) - , ("sigValues", Literal . ArrayLiteral . map (mkProductSignature . instantiate) $ tys) + , ("sigValues", Literal . ArrayLiteral . map (mkProductSignature . instantiate) $ tys') ] mkProductSignature :: Type -> Expr @@ -297,6 +298,7 @@ deriveGeneric mn syns ds tyConNm dargs = do mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative mkAlternative (ctorName, tys) = do idents <- replicateM (length tys) freshIdent' + tys' <- mapM (replaceAllTypeSynonymsM syns) tys return $ CaseAlternative [ prodBinder @@ -307,7 +309,7 @@ deriveGeneric mn syns ds tyConNm dargs = do . unguarded $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName)) - (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys) + (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys') addCatch :: [CaseAlternative] -> [CaseAlternative] addCatch = (++ [catchAll]) From f84424d1212230fef0fd775f2824f56f4d3547ac Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sun, 5 Mar 2017 19:46:18 +0000 Subject: [PATCH 0697/1580] Use data ctor name parser for data ctors in imports/exports (#2660) * Use data ctor name parser for data ctors in imports/exports * Allow data ctors with primes to have fixity declarations --- examples/passing/2609.purs | 12 ++++++++++++ examples/passing/2609/Eg.purs | 6 ++++++ purescript.cabal | 1 + src/Language/PureScript/Parser/Declarations.hs | 4 ++-- 4 files changed, 21 insertions(+), 2 deletions(-) create mode 100644 examples/passing/2609.purs create mode 100644 examples/passing/2609/Eg.purs diff --git a/examples/passing/2609.purs b/examples/passing/2609.purs new file mode 100644 index 0000000000..eb54bb8a2f --- /dev/null +++ b/examples/passing/2609.purs @@ -0,0 +1,12 @@ +module Main where + +import Prelude +import Eg (Foo'(Bar'), (:->)) +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) + +bar' :: Foo' +bar' = 4 :-> 5 + +main :: forall e. Eff (console :: CONSOLE | e) Unit +main = case bar' of Bar' l r -> log "Done" diff --git a/examples/passing/2609/Eg.purs b/examples/passing/2609/Eg.purs new file mode 100644 index 0000000000..ceb6c36036 --- /dev/null +++ b/examples/passing/2609/Eg.purs @@ -0,0 +1,6 @@ +module Eg (Foo'(Bar'), (:->)) where + +data Foo' = Bar' Int Int + +infix 4 Bar' as :-> + diff --git a/purescript.cabal b/purescript.cabal index e0b4b0202c..da48121cd5 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -23,6 +23,7 @@ extra-source-files: examples/passing/*.purs , examples/passing/*.js , examples/passing/2018/*.purs , examples/passing/2138/*.purs + , examples/passing/2609/*.purs , examples/passing/ClassRefSyntax/*.purs , examples/passing/DctorOperatorAlias/*.purs , examples/passing/ExplicitImportReExport/*.purs diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 21a471ef95..ae2a09f760 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -133,7 +133,7 @@ parseFixityDeclaration = do <*> (reserved "as" *> parseOperator) valueFixity fixity = ValueFixity fixity - <$> parseQualified ((Left <$> parseIdent) <|> (Right <$> properName)) + <$> parseQualified ((Left <$> parseIdent) <|> (Right <$> dataConstructorName)) <*> (reserved "as" *> parseOperator) parseImportDeclaration :: TokenParser Declaration @@ -168,7 +168,7 @@ parseDeclarationRef = where parseTypeRef = do name <- typeName - dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName) + dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep dataConstructorName) return $ TypeRef name (fromMaybe (Just []) dctors) parseTypeClassDeclaration :: TokenParser Declaration From 8cc452b07fe77cfd904b104932e7420b1182b9af Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 5 Mar 2017 11:58:08 -0800 Subject: [PATCH 0698/1580] Make paths relative in error messages (#2707) --- app/Command/Compile.hs | 5 ++++- src/Language/PureScript/Ide/Rebuild.hs | 5 ++++- src/Language/PureScript/Ide/SourceFile.hs | 5 ++++- src/Language/PureScript/Interactive/Module.hs | 19 ++++++++++--------- 4 files changed, 22 insertions(+), 12 deletions(-) diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index ec17dc3536..04c9520a93 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -21,6 +21,8 @@ import Language.PureScript.Make import qualified Options.Applicative as Opts import qualified System.Console.ANSI as ANSI import System.Exit (exitSuccess, exitFailure) +import System.Directory (getCurrentDirectory) +import System.FilePath (makeRelative) import System.FilePath.Glob (glob) import System.IO (hPutStr, hPutStrLn, stderr) import System.IO.UTF8 (readUTF8FileT) @@ -53,6 +55,7 @@ printWarningsAndErrors verbose True warnings errors = do compile :: PSCMakeOptions -> IO () compile PSCMakeOptions{..} = do + pwd <- getCurrentDirectory input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput when (null input && not pscmJSONErrors) $ do hPutStr stderr $ unlines [ "purs compile: No input files." @@ -61,7 +64,7 @@ compile PSCMakeOptions{..} = do exitFailure moduleFiles <- readInput input (makeErrors, makeWarnings) <- runMake pscmOpts $ do - ms <- P.parseModulesFromFiles id moduleFiles + ms <- P.parseModulesFromFiles (makeRelative pwd) moduleFiles let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, Right fp)) ms foreigns <- inferForeignModules filePathMap let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index b0fa8dd74f..55dc4396d9 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -21,6 +21,8 @@ import Language.PureScript.Ide.Logging import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import System.Directory (getCurrentDirectory) +import System.FilePath (makeRelative) -- | Given a filepath performs the following steps: -- @@ -47,8 +49,9 @@ rebuildFile rebuildFile path runOpenBuild = do input <- ideReadFile path + pwd <- liftIO getCurrentDirectory - m <- case snd <$> P.parseModuleFromFile identity (path, input) of + m <- case snd <$> P.parseModuleFromFile (makeRelative pwd) (path, input) of Left parseError -> throwError . RebuildError . toJSONErrors False P.Error diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index e452236a5d..72943db55b 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -28,14 +28,17 @@ import qualified Language.PureScript as P import Language.PureScript.Ide.Error import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import System.Directory (getCurrentDirectory) +import System.FilePath (makeRelative) parseModule :: (MonadIO m, MonadError IdeError m) => FilePath -> m (Either FilePath (FilePath, P.Module)) parseModule path = do + pwd <- liftIO getCurrentDirectory contents <- ideReadFile path - case P.parseModuleFromFile identity (path, contents) of + case P.parseModuleFromFile (makeRelative pwd) (path, contents) of Left _ -> pure (Left path) Right m -> pure (Right m) diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 5746781922..34ac66cf2d 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -5,7 +5,8 @@ import Prelude.Compat import Control.Monad import qualified Language.PureScript as P import Language.PureScript.Interactive.Types -import System.FilePath (pathSeparator) +import System.Directory (getCurrentDirectory) +import System.FilePath (pathSeparator, makeRelative) import System.IO.UTF8 (readUTF8FileT) -- * Support Module @@ -20,23 +21,23 @@ supportModuleIsDefined = any ((== supportModuleName) . P.getModuleName) -- * Module Management --- | --- Loads a file for use with imports. --- +-- | Loads a file for use with imports. loadModule :: FilePath -> IO (Either String [P.Module]) loadModule filename = do + pwd <- getCurrentDirectory content <- readUTF8FileT filename - return $ either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)] + return $ + either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions) (Right . map snd) $ + P.parseModulesFromFiles (makeRelative pwd) [(filename, content)] --- | --- Load all modules. --- +-- | Load all modules. loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)]) loadAllModules files = do + pwd <- getCurrentDirectory filesAndContent <- forM files $ \filename -> do content <- readUTF8FileT filename return (filename, content) - return $ P.parseModulesFromFiles id filesAndContent + return $ P.parseModulesFromFiles (makeRelative pwd) filesAndContent -- | -- Makes a volatile module to execute the current expression. From 4958b48b957b01041859d3f90064d3101a9827dd Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 5 Mar 2017 12:23:40 -0800 Subject: [PATCH 0699/1580] Improve errors from module sorter (#2708) --- src/Language/PureScript/ModuleDependencies.hs | 32 +++++++++---------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 5766f0ff94..21885b0ead 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -27,8 +27,8 @@ sortModules -> m ([Module], ModuleGraph) sortModules ms = do let mns = S.fromList $ map getModuleName ms - verts <- mapM (toGraphNode mns) ms - ms' <- mapM toModule $ stronglyConnComp verts + verts <- parU ms (toGraphNode mns) + ms' <- parU (stronglyConnComp verts) toModule let (graph, fromVertex, toVertex) = graphFromEdges verts moduleGraph = do (_, mn, _) <- verts let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn) @@ -39,23 +39,23 @@ sortModules ms = do where toGraphNode :: S.Set ModuleName -> Module -> m (Module, ModuleName, [ModuleName]) toGraphNode mns m@(Module _ _ mn ds _) = do - let deps = ordNub (concatMap usedModules ds) - forM_ deps $ \dep -> + let deps = ordNub (mapMaybe usedModules ds) + void . parU deps $ \(dep, pos) -> when (dep /= C.Prim && S.notMember dep mns) $ - throwError . addHint (ErrorInModule mn) . errorMessage $ ModuleNotFound dep - pure (m, getModuleName m, deps) + throwError + . addHint (ErrorInModule mn) + . maybe identity (addHint . PositionedError) pos + . errorMessage + $ ModuleNotFound dep + pure (m, getModuleName m, map fst deps) -- | Calculate a list of used modules based on explicit imports and qualified names. -usedModules :: Declaration -> [ModuleName] -usedModules d = f d where - f :: Declaration -> [ModuleName] - (f, _, _, _, _) = everythingOnValues (++) forDecls (const []) (const []) (const []) (const []) - - forDecls :: Declaration -> [ModuleName] - -- Regardless of whether an imported module is qualified we still need to - -- take into account its import to build an accurate list of dependencies. - forDecls (ImportDeclaration mn _ _) = [mn] - forDecls _ = [] +usedModules :: Declaration -> Maybe (ModuleName, Maybe SourceSpan) +-- Regardless of whether an imported module is qualified we still need to +-- take into account its import to build an accurate list of dependencies. +usedModules (ImportDeclaration mn _ _) = pure (mn, Nothing) +usedModules (PositionedDeclaration ss _ d) = fmap (second (const (Just ss))) (usedModules d) +usedModules _ = Nothing -- | Convert a strongly connected component of the module graph to a module toModule :: MonadError MultipleErrors m => SCC Module -> m Module From 7e4848ebba371a1676339bbdb0e3ec9c846ee112 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 5 Mar 2017 13:34:16 -0800 Subject: [PATCH 0700/1580] Improve error for unused type variables (#2709) --- src/Language/PureScript/Errors.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index f2870de968..bd18d21ecc 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -748,7 +748,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS renderSimpleErrorMessage (ShadowedTypeVar tv) = line $ "Type variable " <> markCode tv <> " was shadowed." renderSimpleErrorMessage (UnusedTypeVar tv) = - line $ "Type variable " <> markCode tv <> " was declared but not used." + line $ "Type variable " <> markCode tv <> " is ambiguous, since it is unused in the polymorphic type which introduces it." renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) = line $ "Importing type " <> markCode (runProperName name <> "(..)") <> " from " <> markCode (runModuleName mn) <> " is misleading as it has no exported data constructors." renderSimpleErrorMessage (ImportHidingModule name) = From a6291a011bfbba50c81756b00f8d2f15bb0f5651 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 5 Mar 2017 22:21:14 -0800 Subject: [PATCH 0701/1580] Include source span in externs file for error reporting purposes (#2711) * Include source span in externs file for error reporting purposes, fix #2254 * Update StateSpec.hs * Update StateSpec.hs --- src/Language/PureScript/Externs.hs | 22 ++++++++++++---------- src/Language/PureScript/Sugar/Names.hs | 7 +++---- tests/Language/PureScript/Ide/StateSpec.hs | 2 ++ 3 files changed, 17 insertions(+), 14 deletions(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index a75d094dbf..7a72099438 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -38,21 +38,22 @@ import Paths_purescript as Paths -- | The data which will be serialized to an externs file data ExternsFile = ExternsFile - { - -- | The externs version - efVersion :: Text - -- | Module name + { efVersion :: Text + -- ^ The externs version , efModuleName :: ModuleName - -- | List of module exports + -- ^ Module name , efExports :: [DeclarationRef] - -- | List of module imports + -- ^ List of module exports , efImports :: [ExternsImport] - -- | List of operators and their fixities + -- ^ List of module imports , efFixities :: [ExternsFixity] - -- | List of type operators and their fixities + -- ^ List of operators and their fixities , efTypeFixities :: [ExternsTypeFixity] - -- | List of type and value declaration + -- ^ List of type operators and their fixities , efDeclarations :: [ExternsDeclaration] + -- ^ List of type and value declaration + , efSourceSpan :: SourceSpan + -- ^ Source span for error reporting } deriving (Show) -- | A module import in an externs file @@ -165,7 +166,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar -- | Generate an externs file for all declarations in a module moduleToExternsFile :: Module -> Environment -> ExternsFile moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated" -moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} +moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} where efVersion = T.pack (showVersion Paths.version) efModuleName = mn @@ -174,6 +175,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} efFixities = mapMaybe fixityDecl ds efTypeFixities = mapMaybe typeFixityDecl ds efDeclarations = concatMap toExternsDeclaration efExports + efSourceSpan = ss fixityDecl :: Declaration -> Maybe ExternsFixity fixityDecl (ValueFixityDeclaration (Fixity assoc prec) name op) = diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 7948366f4c..c7e07e2568 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -65,12 +65,11 @@ desugarImportsWithEnv externs modules = do externsEnv :: Env -> ExternsFile -> m Env externsEnv env ExternsFile{..} = do let members = Exports{..} - ss = internalModuleSourceSpan "" - env' = M.insert efModuleName (ss, primImports, members) env + env' = M.insert efModuleName (efSourceSpan, primImports, members) env fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)]) imps <- foldM (resolveModuleImport env') primImports (map fromEFImport efImports) - exps <- resolveExports env' ss efModuleName imps members efExports - return $ M.insert efModuleName (ss, imps, exps) env + exps <- resolveExports env' efSourceSpan efModuleName imps members efExports + return $ M.insert efModuleName (efSourceSpan, imps, exps) env where exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index a4a546a175..ac31866626 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -67,6 +67,8 @@ ef = P.ExternsFile mempty -- } ] + --, efSourceSpan = + (P.internalModuleSourceSpan "") -- } moduleMap :: ModuleMap [IdeDeclarationAnn] From 9d9b4bb875eb53324e9fde2cb6a1738f2b96a276 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 5 Mar 2017 22:22:00 -0800 Subject: [PATCH 0702/1580] Add InvalidDerivedInstance error (#2712) * Provide an additional reason with the 'cannot derive instance' error, fix #2595 * Clarify error * Include arity in errors, split out ExpectedTypeConstructor error --- examples/failing/InvalidDerivedInstance.purs | 8 ++ examples/failing/InvalidDerivedInstance2.purs | 6 ++ src/Language/PureScript/AST/Declarations.hs | 2 + src/Language/PureScript/Errors.hs | 31 +++++++ .../PureScript/Sugar/TypeClasses/Deriving.hs | 80 ++++++++++++------- 5 files changed, 96 insertions(+), 31 deletions(-) create mode 100644 examples/failing/InvalidDerivedInstance.purs create mode 100644 examples/failing/InvalidDerivedInstance2.purs diff --git a/examples/failing/InvalidDerivedInstance.purs b/examples/failing/InvalidDerivedInstance.purs new file mode 100644 index 0000000000..11b1b46613 --- /dev/null +++ b/examples/failing/InvalidDerivedInstance.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidDerivedInstance +module Main where + +import Prelude + +data X = X + +derive instance eqX :: Eq X X diff --git a/examples/failing/InvalidDerivedInstance2.purs b/examples/failing/InvalidDerivedInstance2.purs new file mode 100644 index 0000000000..ec467337a7 --- /dev/null +++ b/examples/failing/InvalidDerivedInstance2.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith ExpectedTypeConstructor +module Main where + +import Prelude + +derive instance eqRecord :: Eq {} diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index e14a05e8d3..0f71ce664c 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -93,6 +93,8 @@ data SimpleErrorMessage | UnknownClass (Qualified (ProperName 'ClassName)) | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type] | CannotDerive (Qualified (ProperName 'ClassName)) [Type] + | InvalidDerivedInstance (Qualified (ProperName 'ClassName)) [Type] Int + | ExpectedTypeConstructor (Qualified (ProperName 'ClassName)) [Type] Type | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type] | CannotFindDerivingType (ProperName 'TypeName) | DuplicateLabel Label (Maybe Expr) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index bd18d21ecc..c2775583ee 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -123,6 +123,8 @@ errorCode em = case unwrapErrorMessage em of PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance" CannotDerive{} -> "CannotDerive" InvalidNewtypeInstance{} -> "InvalidNewtypeInstance" + InvalidDerivedInstance{} -> "InvalidDerivedInstance" + ExpectedTypeConstructor{} -> "ExpectedTypeConstructor" CannotFindDerivingType{} -> "CannotFindDerivingType" DuplicateLabel{} -> "DuplicateLabel" DuplicateValueDeclaration{} -> "DuplicateValueDeclaration" @@ -262,6 +264,8 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts gSimple (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts + gSimple (InvalidDerivedInstance cl ts n) = InvalidDerivedInstance cl <$> traverse f ts <*> pure n + gSimple (ExpectedTypeConstructor cl ts ty) = ExpectedTypeConstructor cl <$> traverse f ts <*> f ty gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx @@ -666,6 +670,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) ] + , line "since instances of this type class are not derivable." ] renderSimpleErrorMessage (InvalidNewtypeInstance nm ts) = paras [ line "Cannot derive newtype instance for" @@ -675,6 +680,32 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS ] , line "Make sure this is a newtype." ] + renderSimpleErrorMessage (InvalidDerivedInstance nm ts argCount) = + paras [ line "Cannot derive the type class instance" + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] + , line $ fold $ + [ "because the " + , markCode (showQualified runProperName nm) + , " type class has " + , T.pack (show argCount) + , " type " + , if argCount == 1 then "argument" else "arguments" + , ", but the declaration specifies " <> T.pack (show (length ts)) <> "." + ] + ] + renderSimpleErrorMessage (ExpectedTypeConstructor nm ts ty) = + paras [ line "Cannot derive the type class instance" + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName nm) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] + , "because the type" + , markCodeBox $ indent $ typeAsBox ty + , line "is not of the required form T a_1 ... a_n, where T is a type constructor defined in the same module." + ] renderSimpleErrorMessage (CannotFindDerivingType nm) = line $ "Cannot derive a type class instance, because the type declaration for " <> markCode (runProperName nm) <> " could not be found." renderSimpleErrorMessage (DuplicateLabel l expr) = diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 1da6d3909a..cc8f37004f 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -64,43 +64,61 @@ deriveInstance -> [Declaration] -> Declaration -> m Declaration -deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance) +deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys DerivedInstance) | className == Qualified (Just dataGeneric) (ProperName C.generic) - , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty - , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn syns ds tyCon args + = case tys of + [ty] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty + , mn == fromMaybe mn mn' + -> TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn syns ds tyCon args + | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty + _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataEq) (ProperName "Eq") - , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty - , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn syns ds tyCon + = case tys of + [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty + , mn == fromMaybe mn mn' + -> TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn syns ds tyCon + | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty + _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataOrd) (ProperName "Ord") - , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty - , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn syns ds tyCon + = case tys of + [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty + , mn == fromMaybe mn mn' + -> TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn syns ds tyCon + | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty + _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataFunctor) (ProperName "Functor") - , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty - , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveFunctor mn syns ds tyCon -deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance) + = case tys of + [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty + , mn == fromMaybe mn mn' + -> TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveFunctor mn syns ds tyCon + | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty + _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataNewtype) (ProperName "Newtype") - , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy - , mn == fromMaybe mn mn' - = do (inst, actualUnwrappedTy) <- deriveNewtype mn syns ds tyCon args unwrappedTy - return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) -deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className [actualTy, repTy] DerivedInstance) + = case tys of + [wrappedTy, unwrappedTy] + | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy + , mn == fromMaybe mn mn' + -> do (inst, actualUnwrappedTy) <- deriveNewtype mn syns ds tyCon args unwrappedTy + return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) + | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys wrappedTy + _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 2 | className == Qualified (Just dataGenericRep) (ProperName C.generic) - , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy - , mn == fromMaybe mn mn' - = do (inst, inferredRepTy) <- deriveGenericRep mn syns ds tyCon args repTy - return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) -deriveInstance _ _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) - = throwError . errorMessage $ CannotDerive className tys -deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance) - | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys) - , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance syns className ds tys tyCon args -deriveInstance _ _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance) - = throwError . errorMessage $ InvalidNewtypeInstance className tys + = case tys of + [actualTy, repTy] + | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy + , mn == fromMaybe mn mn' + -> do (inst, inferredRepTy) <- deriveGenericRep mn syns ds tyCon args repTy + return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) + | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys actualTy + _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 2 + | otherwise = throwError . errorMessage $ CannotDerive className tys +deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys NewtypeInstance) = + case tys of + _ : _ | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys) + , mn == fromMaybe mn mn' + -> TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance syns className ds tys tyCon args + | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys (last tys) + _ -> throwError . errorMessage $ InvalidNewtypeInstance className tys deriveInstance mn syns ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn syns ds d deriveInstance _ _ _ e = return e From 574513a95e7cfd3d0deaa8ee366d40cad45ea93c Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Wed, 8 Mar 2017 00:31:35 +0000 Subject: [PATCH 0703/1580] Bring module of any used class constructor into scope (#2717) --- src/Language/PureScript/CoreFn/Desugar.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index ecddabbd19..5f8f6a4581 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -15,7 +15,6 @@ import Language.PureScript.AST.Literals import Language.PureScript.AST.SourcePos import Language.PureScript.AST.Traversals import Language.PureScript.Comments -import qualified Language.PureScript.Constants as C import Language.PureScript.CoreFn.Ann import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Expr @@ -211,11 +210,10 @@ findQualModules decls = fqValues :: A.Expr -> [ModuleName] fqValues (A.Var q) = getQual' q fqValues (A.Constructor q) = getQual' q - -- 'IsSymbol' instances for literal symbols are automatically solved and the type - -- class dictionaries are built inline instead of having a named instance defined - -- and imported. We therefore need to import the 'IsSymbol' constructor from - -- Data.Symbol if it hasn't already been imported. - fqValues (A.TypeClassDictionaryConstructorApp C.IsSymbol _) = getQual' C.IsSymbol + -- Some instances are automatically solved and have their class dictionaries + -- built inline instead of having a named instance defined and imported. + -- We therefore need to import these constructors if they aren't already. + fqValues (A.TypeClassDictionaryConstructorApp c _) = getQual' c fqValues _ = [] fqBinders :: A.Binder -> [ModuleName] From 2dbed39f176c45598955737e636702e62b031839 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 8 Mar 2017 16:32:48 +0100 Subject: [PATCH 0704/1580] Find record accessors in Type Directed Search (#2710) * extends TypeSearch with a special case for record accessors * return MultipleErrors over JSONErrors from rebuilding * move single line type pretty print around * monkey patch HoleInferred errors with typesearch results * add the hole name to the error message * fix warning * detect accessors that match the expected return type * fix ghc8 errors * apply suggestions * fix ghc8 errors --- src/Language/PureScript/AST/Declarations.hs | 15 ++++++- src/Language/PureScript/Errors.hs | 9 ++-- src/Language/PureScript/Ide/Error.hs | 44 ++++++++++++++++--- src/Language/PureScript/Ide/Rebuild.hs | 13 +++--- src/Language/PureScript/Ide/Types.hs | 8 ++-- src/Language/PureScript/Ide/Util.hs | 23 +++------- .../PureScript/TypeChecker/TypeSearch.hs | 39 ++++++++++++++-- src/Language/PureScript/TypeChecker/Types.hs | 7 +-- 8 files changed, 111 insertions(+), 47 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 0f71ce664c..ad7ef3b327 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -38,11 +38,24 @@ type Context = [(Ident, Type)] data TypeSearch = TSBefore Environment -- ^ An Environment captured for later consumption by type directed search - | TSAfter [(Qualified Ident, Type)] + | TSAfter + { tsAfterIdentifiers :: [(Qualified Text, Type)] + -- ^ The identifiers that fully satisfy the subsumption check + , tsAfterRecordFields :: Maybe [(Label, Type)] + -- ^ Record fields that are available on the first argument to the typed + -- hole + } -- ^ Results of applying type directed search to the previously captured -- Environment deriving Show +onTypeSearchTypes :: (Type -> Type) -> TypeSearch -> TypeSearch +onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f) + +onTypeSearchTypesM :: (Applicative m) => (Type -> m Type) -> TypeSearch -> m TypeSearch +onTypeSearchTypesM f (TSAfter i r) = TSAfter <$> traverse (traverse f) i <*> traverse (traverse (traverse f)) r +onTypeSearchTypesM _ (TSBefore env) = pure (TSBefore env) + -- | A type of error messages data SimpleErrorMessage = ModuleNotFound ModuleName diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index c2775583ee..f89b80ff69 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -269,7 +269,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx - gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx <*> gTypeSearch env + gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx <*> onTypeSearchTypesM f env gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty gSimple other = pure other @@ -283,9 +283,6 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint (ErrorSolvingConstraint con) = ErrorSolvingConstraint <$> overConstraintArgs (traverse f) con gHint other = pure other - gTypeSearch (TSBefore env) = pure (TSBefore env) - gTypeSearch (TSAfter result) = TSAfter <$> traverse (traverse f) result - errorDocUri :: ErrorMessage -> Text errorDocUri e = "https://github.com/purescript/documentation/blob/master/errors/" <> errorCode e <> ".md" @@ -794,11 +791,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS let maxTSResults = 15 tsResult = case ts of - (TSAfter idents) | not (null idents) -> + (TSAfter{tsAfterIdentifiers=idents}) | not (null idents) -> let formatTS (names, types) = let - idBoxes = Box.text . T.unpack . showQualified runIdent <$> names + idBoxes = Box.text . T.unpack . showQualified id <$> names tyBoxes = (\t -> BoxHelpers.indented (Box.text ":: " Box.<> typeAsBox t)) <$> types longestId = maximum (map Box.cols idBoxes) diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 1be0f8921b..7fa4133cae 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -14,33 +14,62 @@ module Language.PureScript.Ide.Error ( IdeError(..) + , prettyPrintTypeSingleLine ) where import Data.Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.HashMap.Lazy as HM +import qualified Data.Text as T +import qualified Language.PureScript as P import Language.PureScript.Errors.JSON -import Language.PureScript.Ide.Types (ModuleIdent) +import Language.PureScript.Ide.Types (ModuleIdent, Completion(..)) import Protolude -import qualified Text.Parsec.Error as P +import qualified Text.Parsec.Error as Parsec data IdeError = GeneralError Text | NotFound Text | ModuleNotFound ModuleIdent | ModuleFileNotFound ModuleIdent - | ParseError P.ParseError Text - | RebuildError [JSONError] - deriving (Show, Eq) + | ParseError Parsec.ParseError Text + | RebuildError P.MultipleErrors + deriving (Show) instance ToJSON IdeError where toJSON (RebuildError errs) = object [ "resultType" .= ("error" :: Text) - , "result" .= errs + , "result" .= encodeRebuildErrors errs ] toJSON err = object [ "resultType" .= ("error" :: Text) , "result" .= textError err ] +encodeRebuildErrors :: P.MultipleErrors -> Value +encodeRebuildErrors = toJSON . map encodeRebuildError . P.runMultipleErrors + where + encodeRebuildError err = case err of + (P.ErrorMessage _ + ((P.HoleInferredType name _ _ + (P.TSAfter{tsAfterIdentifiers=idents, tsAfterRecordFields=fields})))) -> + insertTSCompletions name idents (fromMaybe [] fields) (toJSON (toJSONError False P.Error err)) + _ -> + (toJSON . toJSONError False P.Error) err + + insertTSCompletions name idents fields (Aeson.Object value) = + Aeson.Object + (HM.insert "pursIde" + (object [ "name" .= name + , "completions" .= (ordNub (map identCompletion idents ++ map fieldCompletion fields)) + ]) value) + insertTSCompletions _ _ _ v = v + + identCompletion (P.Qualified mn i, ty) = + Completion (maybe "" P.runModuleName mn) i (prettyPrintTypeSingleLine ty) (prettyPrintTypeSingleLine ty) Nothing Nothing + fieldCompletion (label, ty) = + Completion "" ("_." <> P.prettyPrintLabel label) (prettyPrintTypeSingleLine ty) (prettyPrintTypeSingleLine ty) Nothing Nothing + textError :: IdeError -> Text textError (GeneralError msg) = msg textError (NotFound ident) = "Symbol '" <> ident <> "' not found." @@ -52,3 +81,6 @@ textError (ParseError parseError msg) = let escape = show -- over the socket as a single line in msg <> ": " <> escape parseError textError (RebuildError err) = show err + +prettyPrintTypeSingleLine :: P.Type -> Text +prettyPrintTypeSingleLine = T.unwords . map T.strip . T.lines . T.pack . P.prettyPrintTypeWithUnicode diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 55dc4396d9..2ad2cd8829 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -15,7 +15,6 @@ import qualified Data.Map.Lazy as M import Data.Maybe (fromJust) import qualified Data.Set as S import qualified Language.PureScript as P -import Language.PureScript.Errors.JSON import Language.PureScript.Ide.Error import Language.PureScript.Ide.Logging import Language.PureScript.Ide.State @@ -52,10 +51,8 @@ rebuildFile path runOpenBuild = do pwd <- liftIO getCurrentDirectory m <- case snd <$> P.parseModuleFromFile (makeRelative pwd) (path, input) of - Left parseError -> throwError - . RebuildError - . toJSONErrors False P.Error - $ P.MultipleErrors [P.toPositionedError parseError] + Left parseError -> + throwError (RebuildError (P.MultipleErrors [P.toPositionedError parseError])) Right m -> pure m -- Externs files must be sorted ahead of time, so that they get applied @@ -77,10 +74,10 @@ rebuildFile path runOpenBuild = do . P.rebuildModule (buildMakeActions >>= shushProgress $ makeEnv) externs $ m case result of - Left errors -> throwError (RebuildError (toJSONErrors False P.Error errors)) + Left errors -> throwError (RebuildError errors) Right _ -> do runOpenBuild (rebuildModuleOpen makeEnv externs m) - pure (RebuildSuccess (toJSONErrors False P.Warning warnings)) + pure (RebuildSuccess warnings) rebuildFileAsync :: forall m. (Ide m, MonadLogger m, MonadError IdeError m) @@ -174,7 +171,7 @@ sortExterns m ex = do . M.delete (P.getModuleName m) $ ex case sorted' of Left err -> - throwError (RebuildError (toJSONErrors False P.Error err)) + throwError (RebuildError err) Right (sorted, graph) -> do let deps = fromJust (List.lookup (P.getModuleName m) graph) pure $ mapMaybe getExtern (deps `inOrderOf` map P.getModuleName sorted) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index f8e75de982..96268ce3d9 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -184,7 +184,7 @@ data Completion = Completion , complExpandedType :: Text , complLocation :: Maybe P.SourceSpan , complDocumentation :: Maybe Text - } deriving (Show, Eq) + } deriving (Show, Eq, Ord) instance ToJSON Completion where toJSON (Completion {..}) = @@ -240,8 +240,8 @@ data Success = | PursuitResult [PursuitResponse] | ImportList [ModuleImport] | ModuleList [ModuleIdent] - | RebuildSuccess [P.JSONError] - deriving (Show, Eq) + | RebuildSuccess P.MultipleErrors + deriving (Show) encodeSuccess :: (ToJSON a) => a -> Value encodeSuccess res = @@ -254,7 +254,7 @@ instance ToJSON Success where toJSON (PursuitResult resp) = encodeSuccess resp toJSON (ImportList decls) = encodeSuccess decls toJSON (ModuleList modules) = encodeSuccess modules - toJSON (RebuildSuccess modules) = encodeSuccess modules + toJSON (RebuildSuccess warnings) = encodeSuccess (P.toJSONErrors False P.Warning warnings) newtype PursuitQuery = PursuitQuery Text deriving (Show, Eq) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index d8e7706f8a..a89acaac8d 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -24,7 +24,6 @@ module Language.PureScript.Ide.Util , withEmptyAnn , valueOperatorAliasT , typeOperatorAliasT - , prettyTypeT , properNameT , identT , opNameT @@ -41,10 +40,10 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) import qualified Language.PureScript as P -import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine, IdeError(..)) import Language.PureScript.Ide.Logging import Language.PureScript.Ide.Types -import System.IO.UTF8 (readUTF8FileT) +import System.IO.UTF8 (readUTF8FileT) identifierFromIdeDeclaration :: IdeDeclaration -> Text identifierFromIdeDeclaration d = case d of @@ -71,20 +70,20 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) = Completion {..} where (complIdentifier, complExpandedType) = case decl of - IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyTypeT) + IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyPrintTypeSingleLine) IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind) - IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyTypeT) - IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyTypeT) + IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyPrintTypeSingleLine) + IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyPrintTypeSingleLine) IdeDeclTypeClass d -> (d ^. ideTCName . properNameT, "type class") IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) -> - (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP) + (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyPrintTypeSingleLine typeP) IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) -> (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) P.prettyPrintKind kind) IdeDeclKind k -> (P.runProperName k, "kind") complModule = P.runModuleName m - complType = maybe complExpandedType prettyTypeT (annTypeAnnotation ann) + complType = maybe complExpandedType prettyPrintTypeSingleLine (annTypeAnnotation ann) complLocation = annLocation ann @@ -137,11 +136,3 @@ ideReadFile fp = do (\_ -> throwError (GeneralError ("Couldn't find file at: " <> T.pack fp))) pure contents - -prettyTypeT :: P.Type -> Text -prettyTypeT = - T.unwords - . map T.strip - . T.lines - . T.pack - . P.prettyPrintTypeWithUnicode diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index b78ca07108..bfb53d0435 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -4,7 +4,7 @@ module Language.PureScript.TypeChecker.TypeSearch import Protolude -import Control.Monad.Writer +import Control.Monad.Writer (WriterT, runWriterT) import qualified Data.Map as Map import qualified Language.PureScript.TypeChecker.Entailment as Entailment @@ -16,7 +16,9 @@ import Control.Monad.Supply as P import Language.PureScript.AST as P import Language.PureScript.Environment as P import Language.PureScript.Errors as P +import Language.PureScript.Label import Language.PureScript.Names as P +import Language.PureScript.Pretty.Types as P import Language.PureScript.TypeChecker.Skolems as Skolem import Language.PureScript.TypeChecker.Synonyms as P import Language.PureScript.Types as P @@ -76,6 +78,32 @@ checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do -- Finally, check any constraints which were found during elaboration Entailment.replaceTypeClassDictionaries (isJust unsolved) expP +accessorSearch + :: Maybe [(P.Ident, Entailment.InstanceContext, P.Constraint)] + -> P.Environment + -> TC.CheckState + -> P.Type + -> ([(Label, P.Type)], [(Label, P.Type)]) + -- ^ (all accessors we found, all accessors we found that match the result type) +accessorSearch unsolved env st userT = maybe ([], []) fst $ checkInEnvironment env st $ do + let initializeSkolems = + Skolem.introduceSkolemScope + <=< P.replaceAllTypeSynonyms + <=< P.replaceTypeWildcards + + userT' <- initializeSkolems userT + + rowType <- freshType + resultType <- freshType + let recordFunction = TypeApp (TypeApp tyFunction (TypeApp tyRecord rowType)) resultType + _ <- subsumes recordFunction userT' + subst <- gets TC.checkSubstitution + let solvedRow = fst (rowToList (substituteType subst rowType)) + tcS <- get + pure (solvedRow, filter (\x -> checkAccessor tcS (substituteType subst resultType) x) solvedRow) + where + checkAccessor tcs x (_, type') = isJust (checkSubsume unsolved env tcs x type') + typeSearch :: Maybe [(P.Ident, Entailment.InstanceContext, P.Constraint)] -- ^ Additional constraints we need to satisfy @@ -85,6 +113,11 @@ typeSearch -- ^ The typechecker state -> P.Type -- ^ The type we are looking for - -> Map (P.Qualified P.Ident) P.Type + -> ([(P.Qualified Text, P.Type)], Maybe [(Label, P.Type)]) typeSearch unsolved env st type' = - Map.mapMaybe (\(x, _, _) -> checkSubsume unsolved env st type' x $> x) (P.names env) + let + resultMap = Map.mapMaybe (\(x, _, _) -> checkSubsume unsolved env st type' x $> x) (P.names env) + (allLabels, solvedLabels) = accessorSearch unsolved env st type' + solvedLabels' = first (P.Qualified Nothing . ("_." <>) . P.prettyPrintLabel) <$> solvedLabels + in + (solvedLabels' <> (first (map P.runIdent) <$> Map.toList resultMap), if null allLabels then Nothing else Just allLabels) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 4043b37088..f967d2cc1f 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -148,9 +148,10 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do runTypeSearch cons st = \case ErrorMessage hints (HoleInferredType x ty y (TSBefore env)) -> let subst = checkSubstitution st - searchResult = (fmap . fmap) (substituteType subst) - (M.toList (typeSearch cons env st (substituteType subst ty))) - in ErrorMessage hints (HoleInferredType x ty y (TSAfter searchResult)) + searchResult = onTypeSearchTypes + (substituteType subst) + (uncurry TSAfter (typeSearch cons env st (substituteType subst ty))) + in ErrorMessage hints (HoleInferredType x ty y searchResult) other -> other -- | Generalize type vars using forall and add inferred constraints From 1f3517b63447e61e296cfb584ae710dd9e2a12ec Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 8 Mar 2017 11:53:39 -0800 Subject: [PATCH 0705/1580] Fix everythingWithScope traversal bug, fix #2718 (#2720) --- examples/warning/ShadowedNameParens.purs | 5 +++++ src/Language/PureScript/AST/Traversals.hs | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) create mode 100644 examples/warning/ShadowedNameParens.purs diff --git a/examples/warning/ShadowedNameParens.purs b/examples/warning/ShadowedNameParens.purs new file mode 100644 index 0000000000..9241f68840 --- /dev/null +++ b/examples/warning/ShadowedNameParens.purs @@ -0,0 +1,5 @@ +-- @shouldWarnWith ShadowedName +module Main where + +f :: Int -> Int -> Int +f n = \(n) -> 1 diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 11a05f862e..0aa1fa2728 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -543,7 +543,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) in g'' s' v1 g' s (Abs (Right b) v1) = let s' = S.union (S.fromList (binderNames b)) s - in g'' s' v1 + in h'' s b <> g'' s' v1 g' s (App v1 v2) = g'' s v1 <> g'' s v2 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts From 0af88caed88709c152ebec3c6251b973bee43407 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 9 Mar 2017 09:50:25 -0800 Subject: [PATCH 0706/1580] TCO Fixes (#2719) * Fix #2689 and #2714, updates to TCO * Tidy up isTailCall a bit * Remove unused label * Add JSReturnNoResult statement. General tidying --- examples/passing/2689.purs | 36 +++ src/Language/PureScript/CodeGen/JS/AST.hs | 239 +++--------------- .../PureScript/CodeGen/JS/Optimizer/TCO.hs | 140 +++++----- .../PureScript/CodeGen/JS/Optimizer/Unused.hs | 1 + src/Language/PureScript/Pretty/JS.hs | 34 +-- 5 files changed, 154 insertions(+), 296 deletions(-) create mode 100644 examples/passing/2689.purs diff --git a/examples/passing/2689.purs b/examples/passing/2689.purs new file mode 100644 index 0000000000..ab0afd8925 --- /dev/null +++ b/examples/passing/2689.purs @@ -0,0 +1,36 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console +import Data.Array.Partial +import Partial.Unsafe + +sumTCObug = go id where + go f 0 = f + go f n = + let + f' a = n + a + in + go f' 0 + +sumTCObug' = go id where + go f 0 = f + go f n = go (\a -> n + a) 0 + +count :: forall a. (a -> Boolean) -> Array a -> Int +count p = count' 0 where + count' acc [] = acc + count' acc xs = + let h = unsafePartial head xs + in count' (acc + if p h then 1 else 0) (unsafePartial tail xs) + +main = do + let x = sumTCObug 7 3 + y = sumTCObug' 7 3 + z = count (_ > 0) [-1, 0, 1] + logShow x + logShow y + logShow z + if x == 10 && y == 10 && z == 1 + then log "Done" + else log "Fail" diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index 58f5905239..fb71d28ab2 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -1,6 +1,4 @@ --- | --- Data types for the intermediate simplified-JavaScript AST --- +-- | Data types for the intermediate simplified-JavaScript AST module Language.PureScript.CodeGen.JS.AST where import Prelude.Compat @@ -14,235 +12,92 @@ import Language.PureScript.Comments import Language.PureScript.PSString (PSString) import Language.PureScript.Traversals --- | --- Built-in unary operators --- +-- | Built-in unary operators data UnaryOperator - -- | - -- Numeric negation - -- = Negate - -- | - -- Boolean negation - -- | Not - -- | - -- Bitwise negation - -- | BitwiseNot - -- | - -- Numeric unary \'plus\' - -- | Positive - -- | - -- Constructor - -- | JSNew deriving (Show, Eq) --- | --- Built-in binary operators --- +-- | Built-in binary operators data BinaryOperator - -- | - -- Numeric addition - -- = Add - -- | - -- Numeric subtraction - -- | Subtract - -- | - -- Numeric multiplication - -- | Multiply - -- | - -- Numeric division - -- | Divide - -- | - -- Remainder - -- | Modulus - -- | - -- Generic equality test - -- | EqualTo - -- | - -- Generic inequality test - -- | NotEqualTo - -- | - -- Numeric less-than - -- | LessThan - -- | - -- Numeric less-than-or-equal - -- | LessThanOrEqualTo - -- | - -- Numeric greater-than - -- | GreaterThan - -- | - -- Numeric greater-than-or-equal - -- | GreaterThanOrEqualTo - -- | - -- Boolean and - -- | And - -- | - -- Boolean or - -- | Or - -- | - -- Bitwise and - -- | BitwiseAnd - -- | - -- Bitwise or - -- | BitwiseOr - -- | - -- Bitwise xor - -- | BitwiseXor - -- | - -- Bitwise left shift - -- | ShiftLeft - -- | - -- Bitwise right shift - -- | ShiftRight - -- | - -- Bitwise right shift with zero-fill - -- | ZeroFillShiftRight deriving (Show, Eq) --- | --- Data type for simplified JavaScript expressions --- +-- | Data type for simplified JavaScript expressions data JS - -- | - -- A numeric literal - -- = JSNumericLiteral (Maybe SourceSpan) (Either Integer Double) - -- | - -- A string literal - -- + -- ^ A numeric literal | JSStringLiteral (Maybe SourceSpan) PSString - -- | - -- A boolean literal - -- + -- ^ A string literal | JSBooleanLiteral (Maybe SourceSpan) Bool - -- | - -- A unary operator application - -- + -- ^ A boolean literal | JSUnary (Maybe SourceSpan) UnaryOperator JS - -- | - -- A binary operator application - -- + -- ^ A unary operator application | JSBinary (Maybe SourceSpan) BinaryOperator JS JS - -- | - -- An array literal - -- + -- ^ A binary operator application | JSArrayLiteral (Maybe SourceSpan) [JS] - -- | - -- An array indexer expression - -- + -- ^ An array literal | JSIndexer (Maybe SourceSpan) JS JS - -- | - -- An object literal - -- + -- ^ An array indexer expression | JSObjectLiteral (Maybe SourceSpan) [(PSString, JS)] - -- | - -- A function introduction (optional name, arguments, body) - -- + -- ^ An object literal | JSFunction (Maybe SourceSpan) (Maybe Text) [Text] JS - -- | - -- Function application - -- + -- ^ A function introduction (optional name, arguments, body) | JSApp (Maybe SourceSpan) JS [JS] - -- | - -- Variable - -- + -- ^ Function application | JSVar (Maybe SourceSpan) Text - -- | - -- Conditional expression - -- - | JSConditional (Maybe SourceSpan) JS JS JS - -- | - -- A block of expressions in braces - -- + -- ^ Variable | JSBlock (Maybe SourceSpan) [JS] - -- | - -- A variable introduction and optional initialization - -- + -- ^ A block of expressions in braces | JSVariableIntroduction (Maybe SourceSpan) Text (Maybe JS) - -- | - -- A variable assignment - -- + -- ^ A variable introduction and optional initialization | JSAssignment (Maybe SourceSpan) JS JS - -- | - -- While loop - -- + -- ^ A variable assignment | JSWhile (Maybe SourceSpan) JS JS - -- | - -- For loop - -- + -- ^ While loop | JSFor (Maybe SourceSpan) Text JS JS JS - -- | - -- ForIn loop - -- + -- ^ For loop | JSForIn (Maybe SourceSpan) Text JS JS - -- | - -- If-then-else statement - -- + -- ^ ForIn loop | JSIfElse (Maybe SourceSpan) JS JS (Maybe JS) - -- | - -- Return statement - -- + -- ^ If-then-else statement | JSReturn (Maybe SourceSpan) JS - -- | - -- Throw statement - -- + -- ^ Return statement + | JSReturnNoResult (Maybe SourceSpan) + -- ^ Return statement with no return value | JSThrow (Maybe SourceSpan) JS - -- | - -- Type-Of operator - -- + -- ^ Throw statement | JSTypeOf (Maybe SourceSpan) JS - -- | - -- InstanceOf test - -- + -- ^ Type-Of operator | JSInstanceOf (Maybe SourceSpan) JS JS - -- | - -- Labelled statement - -- - | JSLabel (Maybe SourceSpan) Text JS - -- | - -- Break statement - -- - | JSBreak (Maybe SourceSpan) Text - -- | - -- Continue statement - -- - | JSContinue (Maybe SourceSpan) Text - -- | - -- Raw JavaScript (generated when parsing fails for an inline foreign import declaration) - -- - | JSRaw (Maybe SourceSpan) Text - -- | - -- Commented JavaScript - -- + -- ^ instanceof check | JSComment (Maybe SourceSpan) [Comment] JS + -- ^ Commented JavaScript deriving (Show, Eq) withSourceSpan :: SourceSpan -> JS -> JS -withSourceSpan withSpan = go - where +withSourceSpan withSpan = go where ss :: Maybe SourceSpan ss = Just withSpan @@ -258,7 +113,6 @@ withSourceSpan withSpan = go go (JSFunction _ name args j) = JSFunction ss name args j go (JSApp _ j js) = JSApp ss j js go (JSVar _ s) = JSVar ss s - go (JSConditional _ j1 j2 j3) = JSConditional ss j1 j2 j3 go (JSBlock _ js) = JSBlock ss js go (JSVariableIntroduction _ name j) = JSVariableIntroduction ss name j go (JSAssignment _ j1 j2) = JSAssignment ss j1 j2 @@ -267,18 +121,14 @@ withSourceSpan withSpan = go go (JSForIn _ name j1 j2) = JSForIn ss name j1 j2 go (JSIfElse _ j1 j2 j3) = JSIfElse ss j1 j2 j3 go (JSReturn _ js) = JSReturn ss js + go (JSReturnNoResult _) = JSReturnNoResult ss go (JSThrow _ js) = JSThrow ss js go (JSTypeOf _ js) = JSTypeOf ss js go (JSInstanceOf _ j1 j2) = JSInstanceOf ss j1 j2 - go (JSLabel _ name js) = JSLabel ss name js - go (JSBreak _ s) = JSBreak ss s - go (JSContinue _ s) = JSContinue ss s - go (JSRaw _ s) = JSRaw ss s go (JSComment _ com j) = JSComment ss com j getSourceSpan :: JS -> Maybe SourceSpan -getSourceSpan = go - where +getSourceSpan = go where go :: JS -> Maybe SourceSpan go (JSNumericLiteral ss _) = ss go (JSStringLiteral ss _) = ss @@ -291,7 +141,6 @@ getSourceSpan = go go (JSFunction ss _ _ _) = ss go (JSApp ss _ _) = ss go (JSVar ss _) = ss - go (JSConditional ss _ _ _) = ss go (JSBlock ss _) = ss go (JSVariableIntroduction ss _ _) = ss go (JSAssignment ss _ _) = ss @@ -300,22 +149,14 @@ getSourceSpan = go go (JSForIn ss _ _ _) = ss go (JSIfElse ss _ _ _) = ss go (JSReturn ss _) = ss + go (JSReturnNoResult ss) = ss go (JSThrow ss _) = ss go (JSTypeOf ss _) = ss go (JSInstanceOf ss _ _) = ss - go (JSLabel ss _ _) = ss - go (JSBreak ss _) = ss - go (JSContinue ss _) = ss - go (JSRaw ss _) = ss go (JSComment ss _ _) = ss --- --- Traversals --- - everywhereOnJS :: (JS -> JS) -> JS -> JS -everywhereOnJS f = go - where +everywhereOnJS f = go where go :: JS -> JS go (JSUnary ss op j) = f (JSUnary ss op (go j)) go (JSBinary ss op j1 j2) = f (JSBinary ss op (go j1) (go j2)) @@ -324,7 +165,6 @@ everywhereOnJS f = go go (JSObjectLiteral ss js) = f (JSObjectLiteral ss (map (fmap go) js)) go (JSFunction ss name args j) = f (JSFunction ss name args (go j)) go (JSApp ss j js) = f (JSApp ss (go j) (map go js)) - go (JSConditional ss j1 j2 j3) = f (JSConditional ss (go j1) (go j2) (go j3)) go (JSBlock ss js) = f (JSBlock ss (map go js)) go (JSVariableIntroduction ss name j) = f (JSVariableIntroduction ss name (fmap go j)) go (JSAssignment ss j1 j2) = f (JSAssignment ss (go j1) (go j2)) @@ -335,7 +175,6 @@ everywhereOnJS f = go go (JSReturn ss js) = f (JSReturn ss (go js)) go (JSThrow ss js) = f (JSThrow ss (go js)) go (JSTypeOf ss js) = f (JSTypeOf ss (go js)) - go (JSLabel ss name js) = f (JSLabel ss name (go js)) go (JSInstanceOf ss j1 j2) = f (JSInstanceOf ss (go j1) (go j2)) go (JSComment ss com j) = f (JSComment ss com (go j)) go other = f other @@ -344,8 +183,7 @@ everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS everywhereOnJSTopDown f = runIdentity . everywhereOnJSTopDownM (Identity . f) everywhereOnJSTopDownM :: (Monad m) => (JS -> m JS) -> JS -> m JS -everywhereOnJSTopDownM f = f >=> go - where +everywhereOnJSTopDownM f = f >=> go where f' = f >=> go go (JSUnary ss op j) = JSUnary ss op <$> f' j go (JSBinary ss op j1 j2) = JSBinary ss op <$> f' j1 <*> f' j2 @@ -354,7 +192,6 @@ everywhereOnJSTopDownM f = f >=> go go (JSObjectLiteral ss js) = JSObjectLiteral ss <$> traverse (sndM f') js go (JSFunction ss name args j) = JSFunction ss name args <$> f' j go (JSApp ss j js) = JSApp ss <$> f' j <*> traverse f' js - go (JSConditional ss j1 j2 j3) = JSConditional ss <$> f' j1 <*> f' j2 <*> f' j3 go (JSBlock ss js) = JSBlock ss <$> traverse f' js go (JSVariableIntroduction ss name j) = JSVariableIntroduction ss name <$> traverse f' j go (JSAssignment ss j1 j2) = JSAssignment ss <$> f' j1 <*> f' j2 @@ -365,14 +202,12 @@ everywhereOnJSTopDownM f = f >=> go go (JSReturn ss j) = JSReturn ss <$> f' j go (JSThrow ss j) = JSThrow ss <$> f' j go (JSTypeOf ss j) = JSTypeOf ss <$> f' j - go (JSLabel ss name j) = JSLabel ss name <$> f' j go (JSInstanceOf ss j1 j2) = JSInstanceOf ss <$> f' j1 <*> f' j2 go (JSComment ss com j) = JSComment ss com <$> f' j go other = f other everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r -everythingOnJS (<>) f = go - where +everythingOnJS (<>) f = go where go j@(JSUnary _ _ j1) = f j <> go j1 go j@(JSBinary _ _ j1 j2) = f j <> go j1 <> go j2 go j@(JSArrayLiteral _ js) = foldl (<>) (f j) (map go js) @@ -380,7 +215,6 @@ everythingOnJS (<>) f = go go j@(JSObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js) go j@(JSFunction _ _ _ j1) = f j <> go j1 go j@(JSApp _ j1 js) = foldl (<>) (f j <> go j1) (map go js) - go j@(JSConditional _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3 go j@(JSBlock _ js) = foldl (<>) (f j) (map go js) go j@(JSVariableIntroduction _ _ (Just j1)) = f j <> go j1 go j@(JSAssignment _ j1 j2) = f j <> go j1 <> go j2 @@ -392,7 +226,6 @@ everythingOnJS (<>) f = go go j@(JSReturn _ j1) = f j <> go j1 go j@(JSThrow _ j1) = f j <> go j1 go j@(JSTypeOf _ j1) = f j <> go j1 - go j@(JSLabel _ _ j1) = f j <> go j1 go j@(JSInstanceOf _ j1 j2) = f j <> go j1 <> go j2 go j@(JSComment _ _ j1) = f j <> go j1 go other = f other diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs index 47bfa7dd8a..d9b184d632 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs @@ -4,32 +4,35 @@ module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where import Prelude.Compat import Data.Text (Text) -import Data.Monoid ((<>), getAny, Any(..)) +import Data.Monoid ((<>)) import Language.PureScript.CodeGen.JS.AST +import Language.PureScript.AST.SourcePos (SourceSpan) -- | Eliminate tail calls tco :: JS -> JS tco = everywhereOnJS convert where - tcoLabel :: Text - tcoLabel = "tco" - tcoVar :: Text -> Text tcoVar arg = "__tco_" <> arg copyVar :: Text -> Text copyVar arg = "__copy_" <> arg + tcoDone :: Text + tcoDone = tcoVar "done" + + tcoLoop :: Text + tcoLoop = tcoVar "loop" + + tcoResult :: Text + tcoResult = tcoVar "result" + convert :: JS -> JS - convert js@(JSVariableIntroduction ss name (Just fn@JSFunction {})) = - let + convert (JSVariableIntroduction ss name (Just fn@JSFunction {})) + | isTailRecursive name body' + = JSVariableIntroduction ss name (Just (replace (toLoop name allArgs body'))) + where (argss, body', replace) = collectAllFunctionArgs [] id fn - in case () of - _ | isTailCall name body' -> - let - allArgs = concat $ reverse argss - in - JSVariableIntroduction ss name (Just (replace (toLoop name allArgs body'))) - | otherwise -> js + allArgs = concat $ reverse argss convert js = js collectAllFunctionArgs :: [[Text]] -> (JS -> JS) -> JS -> ([[Text]], JS, JS -> JS) @@ -43,65 +46,74 @@ tco = everywhereOnJS convert where (args : allArgs, body, f . JSReturn s1 . JSFunction s2 ident (map copyVar args)) collectAllFunctionArgs allArgs f body = (allArgs, body, f) - isTailCall :: Text -> JS -> Bool - isTailCall ident js = - let - numSelfCalls = everythingOnJS (+) countSelfCalls js - numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js - numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js - numSelfCallWithFnArgs = everythingOnJS (+) countSelfCallsWithFnArgs js - in - numSelfCalls > 0 - && numSelfCalls == numSelfCallsInTailPosition - && numSelfCallsUnderFunctions == 0 - && numSelfCallWithFnArgs == 0 - where - countSelfCalls :: JS -> Int - countSelfCalls (JSApp _ (JSVar _ ident') _) | ident == ident' = 1 - countSelfCalls _ = 0 - - countSelfCallsInTailPosition :: JS -> Int - countSelfCallsInTailPosition (JSReturn _ ret) | isSelfCall ident ret = 1 - countSelfCallsInTailPosition _ = 0 - - countSelfCallsUnderFunctions :: JS -> Int - countSelfCallsUnderFunctions (JSFunction _ _ _ js') = everythingOnJS (+) countSelfCalls js' - countSelfCallsUnderFunctions _ = 0 - - countSelfCallsWithFnArgs :: JS -> Int - countSelfCallsWithFnArgs = go [] where - go acc (JSVar _ ident') - | ident == ident' && any hasFunction acc = 1 - go acc (JSApp _ fn args) = go (args ++ acc) fn - go _ _ = 0 - - hasFunction :: JS -> Bool - hasFunction = getAny . everythingOnJS mappend (Any . isFunction) - where - isFunction JSFunction{} = True - isFunction _ = False + isTailRecursive :: Text -> JS -> Bool + isTailRecursive ident js = countSelfReferences js > 0 && allInTailPosition js where + countSelfReferences = everythingOnJS (+) match where + match :: JS -> Int + match (JSVar _ ident') | ident == ident' = 1 + match _ = 0 + + allInTailPosition (JSReturn _ expr) + | isSelfCall ident expr = countSelfReferences expr == 1 + | otherwise = countSelfReferences expr == 0 + allInTailPosition (JSWhile _ js1 body) + = countSelfReferences js1 == 0 && allInTailPosition body + allInTailPosition (JSFor _ _ js1 js2 body) + = countSelfReferences js1 == 0 && countSelfReferences js2 == 0 && allInTailPosition body + allInTailPosition (JSForIn _ _ js1 body) + = countSelfReferences js1 == 0 && allInTailPosition body + allInTailPosition (JSIfElse _ js1 body el) + = countSelfReferences js1 == 0 && allInTailPosition body && all allInTailPosition el + allInTailPosition (JSBlock _ body) + = all allInTailPosition body + allInTailPosition _ + = False toLoop :: Text -> [Text] -> JS -> JS - toLoop ident allArgs js = JSBlock rootSS $ + toLoop ident allArgs js = + JSBlock rootSS $ map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs ++ - [ JSLabel rootSS tcoLabel $ JSWhile rootSS (JSBooleanLiteral rootSS True) (JSBlock rootSS [ everywhereOnJS loopify js ]) ] + [ JSVariableIntroduction rootSS tcoDone (Just (JSBooleanLiteral rootSS False)) + , JSVariableIntroduction rootSS tcoResult Nothing + ] ++ + map (\arg -> + JSVariableIntroduction rootSS (tcoVar arg) Nothing) allArgs ++ + [ JSFunction rootSS (Just tcoLoop) allArgs (JSBlock rootSS [loopify js]) + , JSWhile rootSS (JSUnary rootSS Not (JSVar rootSS tcoDone)) + (JSBlock rootSS + (JSAssignment rootSS (JSVar rootSS tcoResult) (JSApp rootSS (JSVar rootSS tcoLoop) (map (JSVar rootSS) allArgs)) + : map (\arg -> + JSAssignment rootSS (JSVar rootSS arg) (JSVar rootSS (tcoVar arg))) allArgs)) + , JSReturn rootSS (JSVar rootSS tcoResult) + ] where rootSS = Nothing loopify :: JS -> JS - loopify (JSReturn ss ret) | isSelfCall ident ret = - let - allArgumentValues = concat $ collectSelfCallArgs [] ret - in - JSBlock ss $ zipWith (\val arg -> - JSVariableIntroduction ss (tcoVar arg) (Just val)) allArgumentValues allArgs - ++ map (\arg -> - JSAssignment ss (JSVar ss arg) (JSVar ss (tcoVar arg))) allArgs - ++ [ JSContinue ss tcoLabel ] + loopify (JSReturn ss ret) + | isSelfCall ident ret = + let + allArgumentValues = concat $ collectArgs [] ret + in + JSBlock ss $ + zipWith (\val arg -> + JSAssignment ss (JSVar ss (tcoVar arg)) val) allArgumentValues allArgs + ++ [ JSReturnNoResult ss ] + | otherwise = JSBlock ss [ markDone ss, JSReturn ss ret ] + loopify (JSReturnNoResult ss) = JSBlock ss [ markDone ss, JSReturnNoResult ss ] + loopify (JSWhile ss cond body) = JSWhile ss cond (loopify body) + loopify (JSFor ss i js1 js2 body) = JSFor ss i js1 js2 (loopify body) + loopify (JSForIn ss i js1 body) = JSForIn ss i js1 (loopify body) + loopify (JSIfElse ss cond body el) = JSIfElse ss cond (loopify body) (fmap loopify el) + loopify (JSBlock ss body) = JSBlock ss (map loopify body) loopify other = other - collectSelfCallArgs :: [[JS]] -> JS -> [[JS]] - collectSelfCallArgs allArgumentValues (JSApp _ fn args') = collectSelfCallArgs (args' : allArgumentValues) fn - collectSelfCallArgs allArgumentValues _ = allArgumentValues + + markDone :: Maybe SourceSpan -> JS + markDone ss = JSAssignment ss (JSVar ss tcoDone) (JSBooleanLiteral ss True) + + collectArgs :: [[JS]] -> JS -> [[JS]] + collectArgs acc (JSApp _ fn args') = collectArgs (args' : acc) fn + collectArgs acc _ = acc isSelfCall :: Text -> JS -> Bool isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident' diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs index 942414b15d..2ba4da02e7 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs @@ -20,6 +20,7 @@ removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go) go jss | not (any isJSReturn jss) = jss | otherwise = let (body, ret : _) = break isJSReturn jss in body ++ [ret] isJSReturn (JSReturn _ _) = True + isJSReturn (JSReturnNoResult _) = True isJSReturn _ = False removeUnusedArg :: JS -> JS diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 0dc35fd401..4d6cd2f293 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -1,6 +1,4 @@ --- | --- Pretty printer for the JavaScript AST --- +-- | Pretty printer for the JavaScript AST module Language.PureScript.Pretty.JS ( prettyPrintJS , prettyPrintJSWithSourceMaps @@ -112,21 +110,15 @@ literals = mkPattern' match' [ return $ emit "return " , prettyPrintJS' value ] + match (JSReturnNoResult _) = return $ emit "return" match (JSThrow _ value) = mconcat <$> sequence [ return $ emit "throw " , prettyPrintJS' value ] - match (JSBreak _ lbl) = return $ emit $ "break " <> lbl - match (JSContinue _ lbl) = return $ emit $ "continue " <> lbl - match (JSLabel _ lbl js) = mconcat <$> sequence - [ return $ emit $ lbl <> ": " - , prettyPrintJS' js - ] match (JSComment _ com js) = mconcat <$> sequence [ mconcat <$> forM com comment , prettyPrintJS' js ] - match (JSRaw _ js) = return $ emit js match _ = mzero comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen @@ -159,12 +151,6 @@ literals = mkPattern' match' Just (x, xs) -> x `T.cons` removeComments xs Nothing -> "" -conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS) -conditional = mkPattern match - where - match (JSConditional ss cond th el) = Just ((ss, th, el), cond) - match _ = Nothing - accessor :: Pattern PrinterState JS (Text, JS) accessor = mkPattern match where @@ -239,15 +225,7 @@ prettyStatements sts = do indentString <- currentIndent return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss --- | --- Generate a pretty-printed string representing a JavaScript expression --- -prettyPrintJS1 :: (Emit gen) => JS -> gen -prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS' - --- | --- Generate a pretty-printed string representing a collection of JavaScript expressions at the same indentation level --- +-- | Generate a pretty-printed string representing a collection of JavaScript expressions at the same indentation level prettyPrintJSWithSourceMaps :: [JS] -> (Text, [SMap]) prettyPrintJSWithSourceMaps js = let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js @@ -255,9 +233,8 @@ prettyPrintJSWithSourceMaps js = prettyPrintJS :: [JS] -> Text prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements --- | --- Generate an indented, pretty-printed string representing a JavaScript expression --- + +-- | Generate an indented, pretty-printed string representing a JavaScript expression prettyPrintJS' :: (Emit gen) => JS -> StateT PrinterState Maybe gen prettyPrintJS' = A.runKleisli $ runPattern matchValue where @@ -299,5 +276,4 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue , [ binary BitwiseOr "|" ] , [ binary And "&&" ] , [ binary Or "||" ] - , [ Wrap conditional $ \(ss, th, el) cond -> cond <> addMapping' ss <> emit " ? " <> prettyPrintJS1 th <> addMapping' ss <> emit " : " <> prettyPrintJS1 el ] ] From 52668d860406f5aa2f0a2ca538bb1c5d69f752a9 Mon Sep 17 00:00:00 2001 From: Hyunje Jun Date: Fri, 10 Mar 2017 03:32:20 +0900 Subject: [PATCH 0707/1580] New PSCi command: reload (#2721) * Prevent imported modules from being duplicated Remove duplication beforing cons'ing a module. * Rename PSCi :reset to :clear The shortcut ':r' will be used for ':reload' later. * Rename Reload browser command to Refresh To avoid naming collision. * Implement :reload command for PSCi The :reload command will keep the current list of modules, just try to rebuild them. * Add test suites to test PSCi commands Currently :clear and :reload are tested. * Allow PSCi import duplication in other forms Even though module names are the same, an import can be allowed if they have different declaration types or qualifications. * Better error message for PSCi test suites * Revert 'removing import duplication in PSCi' Moved to #2722. --- app/Command/REPL.hs | 8 +- src/Language/PureScript/Interactive.hs | 21 +++-- .../PureScript/Interactive/Completion.hs | 3 +- .../PureScript/Interactive/Directive.hs | 9 ++- src/Language/PureScript/Interactive/Parser.hs | 3 +- src/Language/PureScript/Interactive/Types.hs | 9 ++- tests/TestPsci.hs | 81 +++++++++++++++---- 7 files changed, 102 insertions(+), 32 deletions(-) diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 7e8c42cd68..afec98e24c 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -141,8 +141,8 @@ data Backend = forall state. Backend data BrowserCommand = Eval (MVar String) -- ^ Evaluate the latest JS - | Reload - -- ^ Reload the page + | Refresh + -- ^ Refresh the page -- | State for the browser backend data BrowserState = BrowserState @@ -185,7 +185,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown -- With many connected clients, all but one of -- these attempts will fail. tryPutMVar resultVar (unpack result) - Reload -> + Refresh -> WS.sendTextData conn ("reload" :: Text) shutdownHandler :: IO () -> IO () @@ -262,7 +262,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown reload :: BrowserState -> IO () reload state = do createBundle state - atomically $ writeTChan (browserCommands state) Reload + atomically $ writeTChan (browserCommands state) Refresh shutdown :: BrowserState -> IO () shutdown state = putMVar (browserShutdownNotice state) () diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 213af38540..f589536dfe 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -95,7 +95,8 @@ handleCommand -> Command -> m () handleCommand _ _ ShowHelp = liftIO $ putStrLn helpMessage -handleCommand _ r ResetState = handleResetState r +handleCommand _ r ReloadState = handleReloadState r +handleCommand _ r ClearState = handleClearState r handleCommand c _ (Expression val) = handleExpression c val handleCommand _ _ (Import im) = handleImport im handleCommand _ _ (Decls l) = handleDecls l @@ -106,14 +107,13 @@ handleCommand _ _ (ShowInfo QueryLoaded) = handleShowLoadedModules handleCommand _ _ (ShowInfo QueryImport) = handleShowImportedModules handleCommand _ _ _ = P.internalError "handleCommand: unexpected command" --- | Reset the application state -handleResetState +-- | Reload the application state +handleReloadState :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) => m () -> m () -handleResetState reload = do - modify $ updateImportedModules (const []) - . updateLets (const []) +handleReloadState reload = do + modify $ updateLets (const []) files <- asks psciLoadedFiles e <- runExceptT $ do modules <- ExceptT . liftIO $ loadAllModules files @@ -125,6 +125,15 @@ handleResetState reload = do modify (updateLoadedExterns (const (zip modules externs))) reload +-- | Clear the application state +handleClearState + :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + => m () + -> m () +handleClearState reload = do + modify $ updateImportedModules (const []) + handleReloadState reload + -- | Takes a value expression and evaluates it with the current state. handleExpression :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index d4b6f296aa..5f891aee0c 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -121,7 +121,8 @@ completeDirective ws w = directiveArg :: String -> Directive -> [CompletionContext] directiveArg _ Browse = [CtxModule] directiveArg _ Quit = [] -directiveArg _ Reset = [] +directiveArg _ Reload = [] +directiveArg _ Clear = [] directiveArg _ Help = [] directiveArg _ Paste = [] directiveArg _ Show = map CtxFixed replQueryStrings diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs index 8f204a3346..7f2f010e1c 100644 --- a/src/Language/PureScript/Interactive/Directive.hs +++ b/src/Language/PureScript/Interactive/Directive.hs @@ -25,7 +25,8 @@ directiveStrings :: [(Directive, [String])] directiveStrings = [ (Help , ["?", "help"]) , (Quit , ["quit"]) - , (Reset , ["reset"]) + , (Reload , ["reload"]) + , (Clear , ["clear"]) , (Browse , ["browse"]) , (Type , ["type"]) , (Kind , ["kind"]) @@ -82,7 +83,8 @@ parseDirective = listToMaybe . directivesFor hasArgument :: Directive -> Bool hasArgument Help = False hasArgument Quit = False -hasArgument Reset = False +hasArgument Reload = False +hasArgument Clear = False hasArgument Paste = False hasArgument _ = True @@ -93,7 +95,8 @@ help :: [(Directive, String, String)] help = [ (Help, "", "Show this help menu") , (Quit, "", "Quit PSCi") - , (Reset, "", "Discard all imported modules and declared bindings") + , (Reload, "", "Reload all imported modules while discarding bindings") + , (Clear, "", "Discard all imported modules and declared bindings") , (Browse, "", "See all functions in ") , (Type, "", "Show the type of ") , (Kind, "", "Show the kind of ") diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index d5585807be..a29c110575 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -63,7 +63,8 @@ parseDirective cmd = commandFor d = case d of Help -> return ShowHelp Quit -> return QuitPSCi - Reset -> return ResetState + Reload -> return ReloadState + Clear -> return ClearState Paste -> return PasteLines Browse -> BrowseModule <$> parseRest P.moduleName arg Show -> ShowInfo <$> parseReplQuery' (trim arg) diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index a96187edb8..f54ee375b7 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -82,8 +82,10 @@ data Command | BrowseModule P.ModuleName -- | Exit PSCI | QuitPSCi - -- | Reset the state of the REPL - | ResetState + -- | Reload all the imported modules of the REPL + | ReloadState + -- | Clear the state of the REPL + | ClearState -- | Add some declarations to the current evaluation context | Decls [P.Declaration] -- | Find the type of an expression @@ -120,7 +122,8 @@ parseReplQuery _ = Nothing data Directive = Help | Quit - | Reset + | Reload + | Clear | Browse | Type | Kind diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index 65c71736ad..4d14dee5a9 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -6,7 +6,9 @@ module TestPsci where import Prelude () import Prelude.Compat +import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.State.Strict (evalStateT) +import Control.Monad.Trans.RWS.Strict (evalRWST, RWST, get) import Control.Monad (when) import Data.List (sort) @@ -22,9 +24,7 @@ import Test.HUnit import qualified Language.PureScript as P -import Language.PureScript.Interactive.Module (loadAllModules) -import Language.PureScript.Interactive.Completion -import Language.PureScript.Interactive.Types +import Language.PureScript.Interactive import TestUtils (supportModules) @@ -34,7 +34,9 @@ main = do when (errors + failures > 0) exitFailure allTests :: Test -allTests = completionTests +allTests = TestList [ completionTests + , commandTests + ] completionTests :: Test completionTests = @@ -48,7 +50,8 @@ completionTestData :: [(String, [String])] completionTestData = -- basic directives [ (":h", [":help"]) - , (":re", [":reset"]) + , (":r", [":reload"]) + , (":c", [":clear"]) , (":q", [":quit"]) , (":b", [":browse"]) @@ -60,10 +63,11 @@ completionTestData = , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"]) , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"]) - -- :quit, :help, :reset should not complete + -- :quit, :help, :reload, :clear should not complete , (":help ", []) , (":quit ", []) - , (":reset ", []) + , (":reload ", []) + , (":clear ", []) -- :show should complete to "loaded" and "import" , (":show ", [":show import", ":show loaded"]) @@ -113,11 +117,11 @@ assertCompletedOk (line, expecteds) = do runCM :: CompletionM a -> IO a runCM act = do - psciState <- getPSCiState + psciState <- getPSCiStateForCompletion evalStateT (liftCompletionM act) psciState -getPSCiState :: IO PSCiState -getPSCiState = do +initTestPSCi :: IO (PSCiState, PSCiConfig) +initTestPSCi = do cwd <- getCurrentDirectory let supportDir = cwd "tests" "support" "bower_components" let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir @@ -127,12 +131,61 @@ getPSCiState = do case modulesOrFirstError of Left err -> print err >> exitFailure - Right modules -> - let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName (T.pack "Prelude")], P.Implicit, Nothing)] - dummyExterns = P.internalError "TestPsci: dummyExterns should not be used" - in return (PSCiState imports [] (zip (map snd modules) (repeat dummyExterns))) + Right modules -> do + resultOrErrors <- runMake . make $ modules + case resultOrErrors of + Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure + Right (externs, env) -> + return (PSCiState [] [] (zip (map snd modules) externs), PSCiConfig pursFiles env) + +getPSCiStateForCompletion :: IO PSCiState +getPSCiStateForCompletion = do + (PSCiState _ bs es, _) <- initTestPSCi + let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName (T.pack "Prelude")], P.Implicit, Nothing)] + return $ PSCiState imports bs es controlMonadSTasST :: ImportedModule controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST")) where s = P.moduleNameFromString . T.pack + +type TestPSCi a = RWST PSCiConfig () PSCiState IO a + +runTestPSCi :: TestPSCi a -> IO a +runTestPSCi i = do + (s, c) <- initTestPSCi + fst <$> evalRWST i c s + +testEval :: String -> TestPSCi () +testEval = const $ return () -- not yet actually eval expr command + +testReload :: TestPSCi () +testReload = return () + +run :: String -> TestPSCi () +run s = case parseCommand s of + Left errStr -> liftIO $ putStrLn errStr >> exitFailure + Right command -> + handleCommand testEval testReload command + +commandTests :: Test +commandTests = TestLabel "commandTests" $ TestList $ map (TestCase . runTestPSCi) + [ do + run "import Prelude" + run "import Data.Functor" + run "import Control.Monad" + before <- psciImportedModules <$> get + liftIO $ length before @?= 3 + run ":clear" + after <- psciImportedModules <$> get + liftIO $ length after @?= 0 + , do + run "import Prelude" + run "import Data.Functor" + run "import Control.Monad" + before <- psciImportedModules <$> get + liftIO $ length before @?= 3 + run ":reload" + after <- psciImportedModules <$> get + liftIO $ length after @?= 3 + ] From 1b7e1d99554ec357107a7dc07ff0cf21ec07dab6 Mon Sep 17 00:00:00 2001 From: Soham Chowdhury Date: Sun, 12 Mar 2017 02:19:29 +0530 Subject: [PATCH 0708/1580] Fix minor typo in PSCi script (#2727) --- scripts/psci | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/psci b/scripts/psci index f467eb3e72..d33d81b6ae 100755 --- a/scripts/psci +++ b/scripts/psci @@ -1,2 +1,2 @@ #!/bin/sh -purs repl $@" +purs repl "$@" From c71054c44bb7b93d766d134a4d36e417646128ef Mon Sep 17 00:00:00 2001 From: Hyunje Jun Date: Mon, 13 Mar 2017 03:18:24 +0900 Subject: [PATCH 0709/1580] Divide TestPsci into several modules (#2729) - TestPsci.TestEnv: About init'ing and running PSCi test env - TestPsci.CommandTest: About PSCi command tests - TestPsci.CompletionTest: About PSCi completion tests --- purescript.cabal | 3 + tests/TestPsci.hs | 173 +------------------------------ tests/TestPsci/CommandTest.hs | 31 ++++++ tests/TestPsci/CompletionTest.hs | 108 +++++++++++++++++++ tests/TestPsci/TestEnv.hs | 54 ++++++++++ 5 files changed, 198 insertions(+), 171 deletions(-) create mode 100644 tests/TestPsci/CommandTest.hs create mode 100644 tests/TestPsci/CompletionTest.hs create mode 100644 tests/TestPsci/TestEnv.hs diff --git a/purescript.cabal b/purescript.cabal index da48121cd5..794eff3daa 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -444,6 +444,9 @@ test-suite tests TestPrimDocs TestPscPublish TestPsci + TestPsci.CommandTest + TestPsci.CompletionTest + TestPsci.TestEnv TestPscIde PscIdeSpec Language.PureScript.Ide.Test diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index 4d14dee5a9..cf40aa501a 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -1,32 +1,15 @@ {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} module TestPsci where import Prelude () import Prelude.Compat -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.State.Strict (evalStateT) -import Control.Monad.Trans.RWS.Strict (evalRWST, RWST, get) import Control.Monad (when) - -import Data.List (sort) -import qualified Data.Text as T - import System.Exit (exitFailure) -import System.Console.Haskeline -import System.FilePath (()) -import System.Directory (getCurrentDirectory) -import qualified System.FilePath.Glob as Glob - import Test.HUnit - -import qualified Language.PureScript as P - -import Language.PureScript.Interactive - -import TestUtils (supportModules) +import TestPsci.CommandTest (commandTests) +import TestPsci.CompletionTest (completionTests) main :: IO () main = do @@ -37,155 +20,3 @@ allTests :: Test allTests = TestList [ completionTests , commandTests ] - -completionTests :: Test -completionTests = - TestLabel "completionTests" - (TestList (map (TestCase . assertCompletedOk) completionTestData)) - --- If the cursor is at the right end of the line, with the 1st element of the --- pair as the text in the line, then pressing tab should offer all the --- elements of the list (which is the 2nd element) as completions. -completionTestData :: [(String, [String])] -completionTestData = - -- basic directives - [ (":h", [":help"]) - , (":r", [":reload"]) - , (":c", [":clear"]) - , (":q", [":quit"]) - , (":b", [":browse"]) - - -- :browse should complete module names - , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"]) - , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"]) - - -- import should complete module names - , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"]) - , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"]) - - -- :quit, :help, :reload, :clear should not complete - , (":help ", []) - , (":quit ", []) - , (":reload ", []) - , (":clear ", []) - - -- :show should complete to "loaded" and "import" - , (":show ", [":show import", ":show loaded"]) - , (":show a", []) - - -- :type should complete values and data constructors in scope - , (":type Control.Monad.Eff.Console.lo", [":type Control.Monad.Eff.Console.log", ":type Control.Monad.Eff.Console.logShow"]) - --, (":type uni", [":type unit"]) - --, (":type E", [":type EQ"]) - - -- :kind should complete types in scope - --, (":kind C", [":kind Control.Monad.Eff.Pure"]) - --, (":kind O", [":kind Ordering"]) - - -- Only one argument for directives should be completed - , (":show import ", []) - , (":type EQ ", []) - , (":kind Ordering ", []) - - -- a few other import tests - , ("impor", ["import"]) - , ("import ", map ("import " ++) supportModules) - , ("import Prelude ", []) - - -- String and number literals should not be completed - , ("\"hi", []) - , ("34", []) - - -- Identifiers and data constructors should be completed - --, ("uni", ["unit"]) - , ("Control.Monad.Eff.Class.", ["Control.Monad.Eff.Class.liftEff"]) - --, ("G", ["GT"]) - , ("Data.Ordering.L", ["Data.Ordering.LT"]) - - -- if a module is imported qualified, values should complete under the - -- qualified name, as well as the original name. - , ("ST.new", ["ST.newSTRef"]) - , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"]) - ] - -assertCompletedOk :: (String, [String]) -> Assertion -assertCompletedOk (line, expecteds) = do - (unusedR, completions) <- runCM (completion' (reverse line, "")) - let unused = reverse unusedR - let actuals = map ((unused ++) . replacement) completions - sort expecteds @=? sort actuals - -runCM :: CompletionM a -> IO a -runCM act = do - psciState <- getPSCiStateForCompletion - evalStateT (liftCompletionM act) psciState - -initTestPSCi :: IO (PSCiState, PSCiConfig) -initTestPSCi = do - cwd <- getCurrentDirectory - let supportDir = cwd "tests" "support" "bower_components" - let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir - pursFiles <- supportFiles "purs" - - modulesOrFirstError <- loadAllModules pursFiles - case modulesOrFirstError of - Left err -> - print err >> exitFailure - Right modules -> do - resultOrErrors <- runMake . make $ modules - case resultOrErrors of - Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure - Right (externs, env) -> - return (PSCiState [] [] (zip (map snd modules) externs), PSCiConfig pursFiles env) - -getPSCiStateForCompletion :: IO PSCiState -getPSCiStateForCompletion = do - (PSCiState _ bs es, _) <- initTestPSCi - let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName (T.pack "Prelude")], P.Implicit, Nothing)] - return $ PSCiState imports bs es - -controlMonadSTasST :: ImportedModule -controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST")) - where - s = P.moduleNameFromString . T.pack - -type TestPSCi a = RWST PSCiConfig () PSCiState IO a - -runTestPSCi :: TestPSCi a -> IO a -runTestPSCi i = do - (s, c) <- initTestPSCi - fst <$> evalRWST i c s - -testEval :: String -> TestPSCi () -testEval = const $ return () -- not yet actually eval expr command - -testReload :: TestPSCi () -testReload = return () - -run :: String -> TestPSCi () -run s = case parseCommand s of - Left errStr -> liftIO $ putStrLn errStr >> exitFailure - Right command -> - handleCommand testEval testReload command - -commandTests :: Test -commandTests = TestLabel "commandTests" $ TestList $ map (TestCase . runTestPSCi) - [ do - run "import Prelude" - run "import Data.Functor" - run "import Control.Monad" - before <- psciImportedModules <$> get - liftIO $ length before @?= 3 - run ":clear" - after <- psciImportedModules <$> get - liftIO $ length after @?= 0 - , do - run "import Prelude" - run "import Data.Functor" - run "import Control.Monad" - before <- psciImportedModules <$> get - liftIO $ length before @?= 3 - run ":reload" - after <- psciImportedModules <$> get - liftIO $ length after @?= 3 - ] diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs new file mode 100644 index 0000000000..11ca7085ef --- /dev/null +++ b/tests/TestPsci/CommandTest.hs @@ -0,0 +1,31 @@ +module TestPsci.CommandTest where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Trans.RWS.Strict (get) +import Language.PureScript.Interactive +import Test.HUnit +import TestPsci.TestEnv + +commandTests :: Test +commandTests = TestLabel "commandTests" $ TestList $ map (TestCase . runTestPSCi) + [ do + run "import Prelude" + run "import Data.Functor" + run "import Control.Monad" + before <- psciImportedModules <$> get + length before @?== 3 + run ":clear" + after <- psciImportedModules <$> get + length after @?== 0 + , do + run "import Prelude" + run "import Data.Functor" + run "import Control.Monad" + before <- psciImportedModules <$> get + length before @?== 3 + run ":reload" + after <- psciImportedModules <$> get + length after @?== 3 + ] diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs new file mode 100644 index 0000000000..d74a481589 --- /dev/null +++ b/tests/TestPsci/CompletionTest.hs @@ -0,0 +1,108 @@ +module TestPsci.CompletionTest where + +import Prelude () +import Prelude.Compat + +import Test.HUnit + +import Control.Monad.Trans.State.Strict (evalStateT) +import Data.List (sort) +import qualified Data.Text as T +import qualified Language.PureScript as P +import Language.PureScript.Interactive +import System.Console.Haskeline +import TestPsci.TestEnv (initTestPSCi) +import TestUtils (supportModules) + +completionTests :: Test +completionTests = + TestLabel "completionTests" + (TestList (map (TestCase . assertCompletedOk) completionTestData)) + +-- If the cursor is at the right end of the line, with the 1st element of the +-- pair as the text in the line, then pressing tab should offer all the +-- elements of the list (which is the 2nd element) as completions. +completionTestData :: [(String, [String])] +completionTestData = + -- basic directives + [ (":h", [":help"]) + , (":r", [":reload"]) + , (":c", [":clear"]) + , (":q", [":quit"]) + , (":b", [":browse"]) + + -- :browse should complete module names + , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"]) + , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"]) + + -- import should complete module names + , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"]) + , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"]) + + -- :quit, :help, :reload, :clear should not complete + , (":help ", []) + , (":quit ", []) + , (":reload ", []) + , (":clear ", []) + + -- :show should complete to "loaded" and "import" + , (":show ", [":show import", ":show loaded"]) + , (":show a", []) + + -- :type should complete values and data constructors in scope + , (":type Control.Monad.Eff.Console.lo", [":type Control.Monad.Eff.Console.log", ":type Control.Monad.Eff.Console.logShow"]) + --, (":type uni", [":type unit"]) + --, (":type E", [":type EQ"]) + + -- :kind should complete types in scope + --, (":kind C", [":kind Control.Monad.Eff.Pure"]) + --, (":kind O", [":kind Ordering"]) + + -- Only one argument for directives should be completed + , (":show import ", []) + , (":type EQ ", []) + , (":kind Ordering ", []) + + -- a few other import tests + , ("impor", ["import"]) + , ("import ", map ("import " ++) supportModules) + , ("import Prelude ", []) + + -- String and number literals should not be completed + , ("\"hi", []) + , ("34", []) + + -- Identifiers and data constructors should be completed + --, ("uni", ["unit"]) + , ("Control.Monad.Eff.Class.", ["Control.Monad.Eff.Class.liftEff"]) + --, ("G", ["GT"]) + , ("Data.Ordering.L", ["Data.Ordering.LT"]) + + -- if a module is imported qualified, values should complete under the + -- qualified name, as well as the original name. + , ("ST.new", ["ST.newSTRef"]) + , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"]) + ] + +assertCompletedOk :: (String, [String]) -> Assertion +assertCompletedOk (line, expecteds) = do + (unusedR, completions) <- runCM (completion' (reverse line, "")) + let unused = reverse unusedR + let actuals = map ((unused ++) . replacement) completions + sort expecteds @=? sort actuals + +runCM :: CompletionM a -> IO a +runCM act = do + psciState <- getPSCiStateForCompletion + evalStateT (liftCompletionM act) psciState + +getPSCiStateForCompletion :: IO PSCiState +getPSCiStateForCompletion = do + (PSCiState _ bs es, _) <- initTestPSCi + let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName (T.pack "Prelude")], P.Implicit, Nothing)] + return $ PSCiState imports bs es + +controlMonadSTasST :: ImportedModule +controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST")) + where + s = P.moduleNameFromString . T.pack diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs new file mode 100644 index 0000000000..5c385e603c --- /dev/null +++ b/tests/TestPsci/TestEnv.hs @@ -0,0 +1,54 @@ +module TestPsci.TestEnv where + +import Prelude () +import Prelude.Compat + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.RWS.Strict (evalRWST, RWST) +import qualified Language.PureScript as P +import Language.PureScript.Interactive +import System.Directory (getCurrentDirectory) +import System.Exit (exitFailure) +import System.FilePath (()) +import qualified System.FilePath.Glob as Glob +import Test.HUnit ((@?=)) + +type TestPSCi a = RWST PSCiConfig () PSCiState IO a + +initTestPSCi :: IO (PSCiState, PSCiConfig) +initTestPSCi = do + cwd <- getCurrentDirectory + let supportDir = cwd "tests" "support" "bower_components" + let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir + pursFiles <- supportFiles "purs" + + modulesOrFirstError <- loadAllModules pursFiles + case modulesOrFirstError of + Left err -> + print err >> exitFailure + Right modules -> do + resultOrErrors <- runMake . make $ modules + case resultOrErrors of + Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure + Right (externs, env) -> + return (PSCiState [] [] (zip (map snd modules) externs), PSCiConfig pursFiles env) + +runTestPSCi :: TestPSCi a -> IO a +runTestPSCi i = do + (s, c) <- initTestPSCi + fst <$> evalRWST i c s + +testEval :: String -> TestPSCi () +testEval = const $ return () -- not yet actually eval expr command + +testReload :: TestPSCi () +testReload = return () + +run :: String -> TestPSCi () +run s = case parseCommand s of + Left errStr -> liftIO $ putStrLn errStr >> exitFailure + Right command -> + handleCommand testEval testReload command + +(@?==) :: (Eq a, Show a) => a -> a -> TestPSCi () +x @?== y = liftIO $ x @?= y From 0f43bb6ccb9f6ed1411f95e4fbe58801cdb21a8e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 12 Mar 2017 15:39:41 -0700 Subject: [PATCH 0710/1580] Imperative core, initial refactoring (#2723) * Extract first version of an imperative core from the JS AST * Remove redundant import * Remove TypeOf --- purescript.cabal | 19 +- src/Language/PureScript/CodeGen/JS.hs | 292 ++++++++---------- src/Language/PureScript/CodeGen/JS/AST.hs | 231 -------------- src/Language/PureScript/CodeGen/JS/Common.hs | 24 +- .../PureScript/CodeGen/JS/Optimizer.hs | 60 ---- .../PureScript/CodeGen/JS/Optimizer/Blocks.hs | 32 -- .../PureScript/CodeGen/JS/Optimizer/Common.hs | 78 ----- .../CodeGen/JS/Optimizer/MagicDo.hs | 134 -------- .../PureScript/CodeGen/JS/Optimizer/TCO.hs | 121 -------- .../PureScript/CodeGen/JS/Optimizer/Unused.hs | 36 --- .../{Pretty/JS.hs => CodeGen/JS/Printer.hs} | 107 +++---- src/Language/PureScript/CoreImp.hs | 13 + src/Language/PureScript/CoreImp/AST.hs | 224 ++++++++++++++ src/Language/PureScript/CoreImp/Optimizer.hs | 60 ++++ .../PureScript/CoreImp/Optimizer/Blocks.hs | 28 ++ .../PureScript/CoreImp/Optimizer/Common.hs | 76 +++++ .../JS => CoreImp}/Optimizer/Inliner.hs | 208 ++++++------- .../PureScript/CoreImp/Optimizer/MagicDo.hs | 134 ++++++++ .../PureScript/CoreImp/Optimizer/TCO.hs | 121 ++++++++ .../PureScript/CoreImp/Optimizer/Unused.hs | 34 ++ src/Language/PureScript/Make.hs | 7 +- src/Language/PureScript/Pretty.hs | 13 +- 22 files changed, 999 insertions(+), 1053 deletions(-) delete mode 100644 src/Language/PureScript/CodeGen/JS/AST.hs delete mode 100644 src/Language/PureScript/CodeGen/JS/Optimizer.hs delete mode 100644 src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs delete mode 100644 src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs delete mode 100644 src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs delete mode 100644 src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs delete mode 100644 src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs rename src/Language/PureScript/{Pretty/JS.hs => CodeGen/JS/Printer.hs} (71%) create mode 100644 src/Language/PureScript/CoreImp.hs create mode 100644 src/Language/PureScript/CoreImp/AST.hs create mode 100644 src/Language/PureScript/CoreImp/Optimizer.hs create mode 100644 src/Language/PureScript/CoreImp/Optimizer/Blocks.hs create mode 100644 src/Language/PureScript/CoreImp/Optimizer/Common.hs rename src/Language/PureScript/{CodeGen/JS => CoreImp}/Optimizer/Inliner.hs (63%) create mode 100644 src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs create mode 100644 src/Language/PureScript/CoreImp/Optimizer/TCO.hs create mode 100644 src/Language/PureScript/CoreImp/Optimizer/Unused.hs diff --git a/purescript.cabal b/purescript.cabal index 794eff3daa..d7df464341 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -188,15 +188,8 @@ library Language.PureScript.Externs Language.PureScript.CodeGen Language.PureScript.CodeGen.JS - Language.PureScript.CodeGen.JS.AST Language.PureScript.CodeGen.JS.Common - Language.PureScript.CodeGen.JS.Optimizer - Language.PureScript.CodeGen.JS.Optimizer.Blocks - Language.PureScript.CodeGen.JS.Optimizer.Common - Language.PureScript.CodeGen.JS.Optimizer.Inliner - Language.PureScript.CodeGen.JS.Optimizer.MagicDo - Language.PureScript.CodeGen.JS.Optimizer.TCO - Language.PureScript.CodeGen.JS.Optimizer.Unused + Language.PureScript.CodeGen.JS.Printer Language.PureScript.Constants Language.PureScript.CoreFn Language.PureScript.CoreFn.Ann @@ -207,6 +200,15 @@ library Language.PureScript.CoreFn.Module Language.PureScript.CoreFn.Traversals Language.PureScript.CoreFn.ToJSON + Language.PureScript.CoreImp + Language.PureScript.CoreImp.AST + Language.PureScript.CoreImp.Optimizer + Language.PureScript.CoreImp.Optimizer.Blocks + Language.PureScript.CoreImp.Optimizer.Common + Language.PureScript.CoreImp.Optimizer.Inliner + Language.PureScript.CoreImp.Optimizer.MagicDo + Language.PureScript.CoreImp.Optimizer.TCO + Language.PureScript.CoreImp.Optimizer.Unused Language.PureScript.Comments Language.PureScript.Environment Language.PureScript.Errors @@ -229,7 +231,6 @@ library Language.PureScript.Parser.Types Language.PureScript.Pretty Language.PureScript.Pretty.Common - Language.PureScript.Pretty.JS Language.PureScript.Pretty.Kinds Language.PureScript.Pretty.Types Language.PureScript.Pretty.Values diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 1f4968b642..991223aadc 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -1,6 +1,5 @@ --- | --- This module generates code in the simplified JavaScript intermediate representation from PureScript code --- +-- | This module generates code in the core imperative representation from +-- elaborated PureScript code. module Language.PureScript.CodeGen.JS ( module AST , module Common @@ -26,9 +25,10 @@ import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.AST.SourcePos -import Language.PureScript.CodeGen.JS.AST as AST import Language.PureScript.CodeGen.JS.Common as Common -import Language.PureScript.CodeGen.JS.Optimizer +import Language.PureScript.CoreImp.AST (AST, everywhereTopDownM, withSourceSpan) +import qualified Language.PureScript.CoreImp.AST as AST +import Language.PureScript.CoreImp.Optimizer import Language.PureScript.CoreFn import Language.PureScript.Crash import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..), @@ -42,16 +42,14 @@ import qualified Language.PureScript.Constants as C import System.FilePath.Posix (()) --- | --- Generate code in the simplified JavaScript intermediate representation for all declarations in a +-- | Generate code in the simplified JavaScript intermediate representation for all declarations in a -- module. --- moduleToJs :: forall m . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) => Module Ann - -> Maybe JS - -> m [JS] + -> Maybe AST + -> m [AST] moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls @@ -62,29 +60,25 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = optimized <- traverse (traverse optimize) jsDecls F.traverse_ (F.traverse_ checkIntegers) optimized comments <- not <$> asks optionsNoComments - let strict = JSStringLiteral Nothing "use strict" - let header = if comments && not (null coms) then JSComment Nothing coms strict else strict - let foreign' = [JSVariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_] + let strict = AST.StringLiteral Nothing "use strict" + let header = if comments && not (null coms) then AST.Comment Nothing coms strict else strict + let foreign' = [AST.VariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_] let moduleBody = header : foreign' ++ jsImports ++ concat optimized let foreignExps = exps `intersect` (fst `map` foreigns) let standardExps = exps \\ foreignExps - let exps' = JSObjectLiteral Nothing $ map (mkString . runIdent &&& JSVar Nothing . identToJs) standardExps + let exps' = AST.ObjectLiteral Nothing $ map (mkString . runIdent &&& AST.Var Nothing . identToJs) standardExps ++ map (mkString . runIdent &&& foreignIdent) foreignExps - return $ moduleBody ++ [JSAssignment Nothing (accessorString "exports" (JSVar Nothing "module")) exps'] + return $ moduleBody ++ [AST.Assignment Nothing (accessorString "exports" (AST.Var Nothing "module")) exps'] where - -- | - -- Extracts all declaration names from a binding group. - -- + -- | Extracts all declaration names from a binding group. getNames :: Bind Ann -> [Ident] getNames (NonRec _ ident _) = [ident] getNames (Rec vals) = map (snd . fst) vals - -- | - -- Creates alternative names for each module to ensure they don't collide + -- | Creates alternative names for each module to ensure they don't collide -- with declaration names. - -- renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName) renameImports = go M.empty where @@ -104,20 +98,16 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = then freshModuleName (i + 1) mn' used else newName - -- | - -- Generates JavaScript code for a module import, binding the required module + -- | Generates JavaScript code for a module import, binding the required module -- to the alternative - -- - importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS + importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m AST importToJs mnLookup mn' = do let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (fromString (".." T.unpack (runModuleName mn')))] - withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody) + let moduleBody = AST.App Nothing (AST.Var Nothing "require") [AST.StringLiteral Nothing (fromString (".." T.unpack (runModuleName mn')))] + withPos ss $ AST.VariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody) - -- | - -- Replaces the `ModuleName`s in the AST so that the generated code refers to + -- | Replaces the `ModuleName`s in the AST so that the generated code refers to -- the collision-avoiding renamed module imports. - -- renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann] renameModules mnLookup binds = let (f, _, _) = everywhereOnValues id goExpr goBinder @@ -138,27 +128,25 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- | -- Generate code in the simplified JavaScript intermediate representation for a declaration -- - bindToJs :: Bind Ann -> m [JS] + bindToJs :: Bind Ann -> m [AST] bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS) - -- | - -- Generate code in the simplified JavaScript intermediate representation for a single non-recursive + -- | Generate code in the simplified JavaScript intermediate representation for a single non-recursive -- declaration. -- -- The main purpose of this function is to handle code generation for comments. - -- - nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS + nonRecToJS :: Ann -> Ident -> Expr Ann -> m AST nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do withoutComment <- asks optionsNoComments if withoutComment then nonRecToJS a i (modifyAnn removeComments e) - else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e) + else AST.Comment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e) nonRecToJS (ss, _, _, _) ident val = do js <- valueToJs val - withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js) + withPos ss $ AST.VariableIntroduction Nothing (identToJs ident) (Just js) - withPos :: Maybe SourceSpan -> JS -> m JS + withPos :: Maybe SourceSpan -> AST -> m AST withPos (Just ss) js = do withSM <- asks optionsSourceMaps return $ if withSM @@ -166,34 +154,28 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = else js withPos Nothing js = return js - -- | - -- Generate code in the simplified JavaScript intermediate representation for a variable based on a + -- | Generate code in the simplified JavaScript intermediate representation for a variable based on a -- PureScript identifier. - -- - var :: Ident -> JS - var = JSVar Nothing . identToJs + var :: Ident -> AST + var = AST.Var Nothing . identToJs - -- | - -- Generate code in the simplified JavaScript intermediate representation for an accessor based on + -- | Generate code in the simplified JavaScript intermediate representation for an accessor based on -- a PureScript identifier. If the name is not valid in JavaScript (symbol based, reserved name) an -- indexer is returned. - -- - accessor :: Ident -> JS -> JS + accessor :: Ident -> AST -> AST accessor (Ident prop) = accessorString $ mkString prop accessor (GenIdent _ _) = internalError "GenIdent in accessor" - accessorString :: PSString -> JS -> JS - accessorString prop = JSIndexer Nothing (JSStringLiteral Nothing prop) + accessorString :: PSString -> AST -> AST + accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop) - -- | - -- Generate code in the simplified JavaScript intermediate representation for a value or expression. - -- - valueToJs :: Expr Ann -> m JS + -- | Generate code in the simplified JavaScript intermediate representation for a value or expression. + valueToJs :: Expr Ann -> m AST valueToJs e = let (ss, _, _, _) = extractAnn e in withPos ss =<< valueToJs' e - valueToJs' :: Expr Ann -> m JS + valueToJs' :: Expr Ann -> m AST valueToJs' (Literal (pos, _, _, _) l) = maybe id rethrowWithPosition pos $ literalToValueJS l valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) = @@ -208,27 +190,27 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = extendObj obj sts valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = let args = unAbs e - in return $ JSFunction Nothing Nothing (map identToJs args) (JSBlock Nothing $ map assign args) + in return $ AST.Function Nothing Nothing (map identToJs args) (AST.Block Nothing $ map assign args) where unAbs :: Expr Ann -> [Ident] unAbs (Abs _ arg val) = arg : unAbs val unAbs _ = [] - assign :: Ident -> JS - assign name = JSAssignment Nothing (accessorString (mkString $ runIdent name) (JSVar Nothing "this")) + assign :: Ident -> AST + assign name = AST.Assignment Nothing (accessorString (mkString $ runIdent name) (AST.Var Nothing "this")) (var name) valueToJs' (Abs _ arg val) = do ret <- valueToJs val - return $ JSFunction Nothing Nothing [identToJs arg] (JSBlock Nothing [JSReturn Nothing ret]) + return $ AST.Function Nothing Nothing [identToJs arg] (AST.Block Nothing [AST.Return Nothing ret]) valueToJs' e@App{} = do let (f, args) = unApp e [] args' <- mapM valueToJs args case f of Var (_, _, _, Just IsNewtype) _ -> return (head args') Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields -> - return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args' + return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args' Var (_, _, _, Just IsTypeClassConstructor) name -> - return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args' - _ -> flip (foldl (\fn a -> JSApp Nothing fn [a])) args' <$> valueToJs f + return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args' + _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToJs f where unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann]) unApp (App _ val arg) args = unApp val (arg : args) @@ -246,115 +228,107 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = valueToJs' (Let _ ds val) = do ds' <- concat <$> mapM bindToJs ds ret <- valueToJs val - return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (ds' ++ [JSReturn Nothing ret]))) [] + return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (ds' ++ [AST.Return Nothing ret]))) [] valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = - return $ JSVariableIntroduction Nothing (properToJs ctor) (Just $ - JSObjectLiteral Nothing [("create", - JSFunction Nothing Nothing ["value"] - (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))]) + return $ AST.VariableIntroduction Nothing (properToJs ctor) (Just $ + AST.ObjectLiteral Nothing [("create", + AST.Function Nothing Nothing ["value"] + (AST.Block Nothing [AST.Return Nothing $ AST.Var Nothing "value"]))]) valueToJs' (Constructor _ _ (ProperName ctor) []) = - return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing []) - , JSAssignment Nothing (accessorString "value" (JSVar Nothing (properToJs ctor))) - (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ] + return $ iife (properToJs ctor) [ AST.Function Nothing (Just (properToJs ctor)) [] (AST.Block Nothing []) + , AST.Assignment Nothing (accessorString "value" (AST.Var Nothing (properToJs ctor))) + (AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) []) ] valueToJs' (Constructor _ _ (ProperName ctor) fields) = let constructor = - let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ] - in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body) + let body = [ AST.Assignment Nothing ((accessorString $ mkString $ identToJs f) (AST.Var Nothing "this")) (var f) | f <- fields ] + in AST.Function Nothing (Just (properToJs ctor)) (identToJs `map` fields) (AST.Block Nothing body) createFn = - let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields) - in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields + let body = AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) (var `map` fields) + in foldr (\f inner -> AST.Function Nothing Nothing [identToJs f] (AST.Block Nothing [AST.Return Nothing inner])) body fields in return $ iife (properToJs ctor) [ constructor - , JSAssignment Nothing (accessorString "create" (JSVar Nothing (properToJs ctor))) createFn + , AST.Assignment Nothing (accessorString "create" (AST.Var Nothing (properToJs ctor))) createFn ] - iife :: Text -> [JS] -> JS - iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) [] + iife :: Text -> [AST] -> AST + iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) [] - literalToValueJS :: Literal (Expr Ann) -> m JS - literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i) - literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n) - literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s - literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing (fromString [c]) - literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b - literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs - literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps + literalToValueJS :: Literal (Expr Ann) -> m AST + literalToValueJS (NumericLiteral (Left i)) = return $ AST.NumericLiteral Nothing (Left i) + literalToValueJS (NumericLiteral (Right n)) = return $ AST.NumericLiteral Nothing (Right n) + literalToValueJS (StringLiteral s) = return $ AST.StringLiteral Nothing s + literalToValueJS (CharLiteral c) = return $ AST.StringLiteral Nothing (fromString [c]) + literalToValueJS (BooleanLiteral b) = return $ AST.BooleanLiteral Nothing b + literalToValueJS (ArrayLiteral xs) = AST.ArrayLiteral Nothing <$> mapM valueToJs xs + literalToValueJS (ObjectLiteral ps) = AST.ObjectLiteral Nothing <$> mapM (sndM valueToJs) ps - -- | - -- Shallow copy an object. - -- - extendObj :: JS -> [(PSString, JS)] -> m JS + -- | Shallow copy an object. + extendObj :: AST -> [(PSString, AST)] -> m AST extendObj obj sts = do newObj <- freshName key <- freshName evaluatedObj <- freshName let - jsKey = JSVar Nothing key - jsNewObj = JSVar Nothing newObj - jsEvaluatedObj = JSVar Nothing evaluatedObj - block = JSBlock Nothing (evaluate:objAssign:copy:extend ++ [JSReturn Nothing jsNewObj]) - evaluate = JSVariableIntroduction Nothing evaluatedObj (Just obj) - objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing []) - copy = JSForIn Nothing key jsEvaluatedObj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing] - cond = JSApp Nothing (accessorString "call" (accessorString "hasOwnProperty" (JSObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey] - assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey jsEvaluatedObj)] - stToAssign (s, js) = JSAssignment Nothing (accessorString s jsNewObj) js + jsKey = AST.Var Nothing key + jsNewObj = AST.Var Nothing newObj + jsEvaluatedObj = AST.Var Nothing evaluatedObj + block = AST.Block Nothing (evaluate:objAssign:copy:extend ++ [AST.Return Nothing jsNewObj]) + evaluate = AST.VariableIntroduction Nothing evaluatedObj (Just obj) + objAssign = AST.VariableIntroduction Nothing newObj (Just $ AST.ObjectLiteral Nothing []) + copy = AST.ForIn Nothing key jsEvaluatedObj $ AST.Block Nothing [AST.IfElse Nothing cond assign Nothing] + cond = AST.App Nothing (accessorString "call" (accessorString "hasOwnProperty" (AST.ObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey] + assign = AST.Block Nothing [AST.Assignment Nothing (AST.Indexer Nothing jsKey jsNewObj) (AST.Indexer Nothing jsKey jsEvaluatedObj)] + stToAssign (s, js) = AST.Assignment Nothing (accessorString s jsNewObj) js extend = map stToAssign sts - return $ JSApp Nothing (JSFunction Nothing Nothing [] block) [] + return $ AST.App Nothing (AST.Function Nothing Nothing [] block) [] - -- | - -- Generate code in the simplified JavaScript intermediate representation for a reference to a + -- | Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable. - -- - varToJs :: Qualified Ident -> JS + varToJs :: Qualified Ident -> AST varToJs (Qualified Nothing ident) = var ident varToJs qual = qualifiedToJS id qual - -- | - -- Generate code in the simplified JavaScript intermediate representation for a reference to a + -- | Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable that may have a qualified name. - -- - qualifiedToJS :: (a -> Ident) -> Qualified a -> JS - qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar Nothing . runIdent $ f a - qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar Nothing (moduleNameToJs mn')) - qualifiedToJS f (Qualified _ a) = JSVar Nothing $ identToJs (f a) + qualifiedToJS :: (a -> Ident) -> Qualified a -> AST + qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = AST.Var Nothing . runIdent $ f a + qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (AST.Var Nothing (moduleNameToJs mn')) + qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToJs (f a) - foreignIdent :: Ident -> JS - foreignIdent ident = accessorString (mkString $ runIdent ident) (JSVar Nothing "$foreign") + foreignIdent :: Ident -> AST + foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign") - -- | - -- Generate code in the simplified JavaScript intermediate representation for pattern match binders + -- | Generate code in the simplified JavaScript intermediate representation for pattern match binders -- and guards. - -- - bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [JS] -> m JS + bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST bindersToJs maybeSpan binders vals = do valNames <- replicateM (length vals) freshName - let assignments = zipWith (JSVariableIntroduction Nothing) valNames (map Just vals) + let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals) jss <- forM binders $ \(CaseAlternative bs result) -> do ret <- guardsToJs result go valNames ret bs - return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (assignments ++ concat jss ++ [JSThrow Nothing $ failedPatternError valNames]))) + return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat jss ++ [AST.Throw Nothing $ failedPatternError valNames]))) [] where - go :: [Text] -> [JS] -> [Binder Ann] -> m [JS] + go :: [Text] -> [AST] -> [Binder Ann] -> m [AST] go _ done [] = return done go (v:vs) done' (b:bs) = do done'' <- go vs done' bs binderToJs v done'' b go _ _ _ = internalError "Invalid arguments to bindersToJs" - failedPatternError :: [Text] -> JS - failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing $ mkString failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)] + failedPatternError :: [Text] -> AST + failedPatternError names = AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing "Error") [AST.Binary Nothing AST.Add (AST.StringLiteral Nothing $ mkString failedPatternMessage) (AST.ArrayLiteral Nothing $ zipWith valueError names vals)] failedPatternMessage :: Text failedPatternMessage = "Failed pattern match" <> maybe "" (((" at " <> runModuleName mn <> " ") <>) . displayStartEndPos) maybeSpan <> ": " - valueError :: Text -> JS -> JS - valueError _ l@(JSNumericLiteral _ _) = l - valueError _ l@(JSStringLiteral _ _) = l - valueError _ l@(JSBooleanLiteral _ _) = l - valueError s _ = accessorString "name" . accessorString "constructor" $ JSVar Nothing s + valueError :: Text -> AST -> AST + valueError _ l@(AST.NumericLiteral _ _) = l + valueError _ l@(AST.StringLiteral _ _) = l + valueError _ l@(AST.BooleanLiteral _ _) = l + valueError s _ = accessorString "name" . accessorString "constructor" $ AST.Var Nothing s - guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS] + guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST] guardsToJs (Left gs) = snd <$> F.foldrM genGuard (False, []) gs where genGuard (cond, val) (False, js) = second (: js) <$> genCondVal cond val @@ -362,36 +336,34 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = genCondVal cond val | condIsTrue cond = do - js <- JSReturn Nothing <$> valueToJs val + js <- AST.Return Nothing <$> valueToJs val return (True, js) | otherwise = do cond' <- valueToJs cond val' <- valueToJs val return - (False, JSIfElse Nothing cond' - (JSBlock Nothing [JSReturn Nothing val']) Nothing) + (False, AST.IfElse Nothing cond' + (AST.Block Nothing [AST.Return Nothing val']) Nothing) -- hopefully the inliner did its job and inlined `otherwise` condIsTrue (Literal _ (BooleanLiteral True)) = True condIsTrue _ = False - guardsToJs (Right v) = return . JSReturn Nothing <$> valueToJs v + guardsToJs (Right v) = return . AST.Return Nothing <$> valueToJs v - binderToJs :: Text -> [JS] -> Binder Ann -> m [JS] + binderToJs :: Text -> [AST] -> Binder Ann -> m [AST] binderToJs s done binder = let (ss, _, _, _) = extractBinderAnn binder in traverse (withPos ss) =<< binderToJs' s done binder - -- | - -- Generate code in the simplified JavaScript intermediate representation for a pattern match + -- | Generate code in the simplified JavaScript intermediate representation for a pattern match -- binder. - -- - binderToJs' :: Text -> [JS] -> Binder Ann -> m [JS] + binderToJs' :: Text -> [AST] -> Binder Ann -> m [AST] binderToJs' _ done NullBinder{} = return done binderToJs' varName done (LiteralBinder _ l) = literalToBinderJS varName done l binderToJs' varName done (VarBinder _ ident) = - return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : done) + return (AST.VariableIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : done) binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) = binderToJs varName done b binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do @@ -399,68 +371,68 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = return $ case ctorType of ProductType -> js SumType -> - [JSIfElse Nothing (JSInstanceOf Nothing (JSVar Nothing varName) (qualifiedToJS (Ident . runProperName) ctor)) - (JSBlock Nothing js) + [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (qualifiedToJS (Ident . runProperName) ctor)) + (AST.Block Nothing js) Nothing] where - go :: [(Ident, Binder Ann)] -> [JS] -> m [JS] + go :: [(Ident, Binder Ann)] -> [AST] -> m [AST] go [] done' = return done' go ((field, binder) : remain) done' = do argVar <- freshName done'' <- go remain done' js <- binderToJs argVar done'' binder - return (JSVariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToJs field) $ JSVar Nothing varName) : js) + return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToJs field) $ AST.Var Nothing varName) : js) binderToJs' _ _ ConstructorBinder{} = internalError "binderToJs: Invalid ConstructorBinder in binderToJs" binderToJs' varName done (NamedBinder _ ident binder) = do js <- binderToJs varName done binder - return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : js) + return (AST.VariableIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : js) - literalToBinderJS :: Text -> [JS] -> Literal (Binder Ann) -> m [JS] + literalToBinderJS :: Text -> [AST] -> Literal (Binder Ann) -> m [AST] literalToBinderJS varName done (NumericLiteral num) = - return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSNumericLiteral Nothing num)) (JSBlock Nothing done) Nothing] + return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing] literalToBinderJS varName done (CharLiteral c) = - return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing (fromString [c]))) (JSBlock Nothing done) Nothing] + return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing] literalToBinderJS varName done (StringLiteral str) = - return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing str)) (JSBlock Nothing done) Nothing] + return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing] literalToBinderJS varName done (BooleanLiteral True) = - return [JSIfElse Nothing (JSVar Nothing varName) (JSBlock Nothing done) Nothing] + return [AST.IfElse Nothing (AST.Var Nothing varName) (AST.Block Nothing done) Nothing] literalToBinderJS varName done (BooleanLiteral False) = - return [JSIfElse Nothing (JSUnary Nothing Not (JSVar Nothing varName)) (JSBlock Nothing done) Nothing] + return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing] literalToBinderJS varName done (ObjectLiteral bs) = go done bs where - go :: [JS] -> [(PSString, Binder Ann)] -> m [JS] + go :: [AST] -> [(PSString, Binder Ann)] -> m [AST] go done' [] = return done' go done' ((prop, binder):bs') = do propVar <- freshName done'' <- go done' bs' js <- binderToJs propVar done'' binder - return (JSVariableIntroduction Nothing propVar (Just (accessorString prop (JSVar Nothing varName))) : js) + return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : js) literalToBinderJS varName done (ArrayLiteral bs) = do js <- go done 0 bs - return [JSIfElse Nothing (JSBinary Nothing EqualTo (accessorString "length" (JSVar Nothing varName)) (JSNumericLiteral Nothing (Left (fromIntegral $ length bs)))) (JSBlock Nothing js) Nothing] + return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (accessorString "length" (AST.Var Nothing varName)) (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs)))) (AST.Block Nothing js) Nothing] where - go :: [JS] -> Integer -> [Binder Ann] -> m [JS] + go :: [AST] -> Integer -> [Binder Ann] -> m [AST] go done' _ [] = return done' go done' index (binder:bs') = do elVar <- freshName done'' <- go done' (index + 1) bs' js <- binderToJs elVar done'' binder - return (JSVariableIntroduction Nothing elVar (Just (JSIndexer Nothing (JSNumericLiteral Nothing (Left index)) (JSVar Nothing varName))) : js) + return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js) -- Check that all integers fall within the valid int range for JavaScript. - checkIntegers :: JS -> m () - checkIntegers = void . everywhereOnJSTopDownM go + checkIntegers :: AST -> m () + checkIntegers = void . everywhereTopDownM go where - go :: JS -> m JS - go (JSUnary _ Negate (JSNumericLiteral ss (Left i))) = + go :: AST -> m AST + go (AST.Unary _ AST.Negate (AST.NumericLiteral ss (Left i))) = -- Move the negation inside the literal; since this is a top-down -- traversal doing this replacement will stop the next case from raising -- the error when attempting to use -2147483648, as if left unrewritten - -- the value is `JSUnary Negate (JSNumericLiteral (Left 2147483648))`, and + -- the value is `Unary Negate (NumericLiteral (Left 2147483648))`, and -- 2147483648 is larger than the maximum allowed int. - return $ JSNumericLiteral ss (Left (-i)) - go js@(JSNumericLiteral _ (Left i)) = + return $ AST.NumericLiteral ss (Left (-i)) + go js@(AST.NumericLiteral _ (Left i)) = let minInt = -2147483648 maxInt = 2147483647 in if i < minInt || i > maxInt diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs deleted file mode 100644 index fb71d28ab2..0000000000 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ /dev/null @@ -1,231 +0,0 @@ --- | Data types for the intermediate simplified-JavaScript AST -module Language.PureScript.CodeGen.JS.AST where - -import Prelude.Compat - -import Control.Monad ((>=>)) -import Control.Monad.Identity (Identity(..), runIdentity) -import Data.Text (Text) - -import Language.PureScript.AST (SourceSpan(..)) -import Language.PureScript.Comments -import Language.PureScript.PSString (PSString) -import Language.PureScript.Traversals - --- | Built-in unary operators -data UnaryOperator - = Negate - | Not - | BitwiseNot - | Positive - | JSNew - deriving (Show, Eq) - --- | Built-in binary operators -data BinaryOperator - = Add - | Subtract - | Multiply - | Divide - | Modulus - | EqualTo - | NotEqualTo - | LessThan - | LessThanOrEqualTo - | GreaterThan - | GreaterThanOrEqualTo - | And - | Or - | BitwiseAnd - | BitwiseOr - | BitwiseXor - | ShiftLeft - | ShiftRight - | ZeroFillShiftRight - deriving (Show, Eq) - --- | Data type for simplified JavaScript expressions -data JS - = JSNumericLiteral (Maybe SourceSpan) (Either Integer Double) - -- ^ A numeric literal - | JSStringLiteral (Maybe SourceSpan) PSString - -- ^ A string literal - | JSBooleanLiteral (Maybe SourceSpan) Bool - -- ^ A boolean literal - | JSUnary (Maybe SourceSpan) UnaryOperator JS - -- ^ A unary operator application - | JSBinary (Maybe SourceSpan) BinaryOperator JS JS - -- ^ A binary operator application - | JSArrayLiteral (Maybe SourceSpan) [JS] - -- ^ An array literal - | JSIndexer (Maybe SourceSpan) JS JS - -- ^ An array indexer expression - | JSObjectLiteral (Maybe SourceSpan) [(PSString, JS)] - -- ^ An object literal - | JSFunction (Maybe SourceSpan) (Maybe Text) [Text] JS - -- ^ A function introduction (optional name, arguments, body) - | JSApp (Maybe SourceSpan) JS [JS] - -- ^ Function application - | JSVar (Maybe SourceSpan) Text - -- ^ Variable - | JSBlock (Maybe SourceSpan) [JS] - -- ^ A block of expressions in braces - | JSVariableIntroduction (Maybe SourceSpan) Text (Maybe JS) - -- ^ A variable introduction and optional initialization - | JSAssignment (Maybe SourceSpan) JS JS - -- ^ A variable assignment - | JSWhile (Maybe SourceSpan) JS JS - -- ^ While loop - | JSFor (Maybe SourceSpan) Text JS JS JS - -- ^ For loop - | JSForIn (Maybe SourceSpan) Text JS JS - -- ^ ForIn loop - | JSIfElse (Maybe SourceSpan) JS JS (Maybe JS) - -- ^ If-then-else statement - | JSReturn (Maybe SourceSpan) JS - -- ^ Return statement - | JSReturnNoResult (Maybe SourceSpan) - -- ^ Return statement with no return value - | JSThrow (Maybe SourceSpan) JS - -- ^ Throw statement - | JSTypeOf (Maybe SourceSpan) JS - -- ^ Type-Of operator - | JSInstanceOf (Maybe SourceSpan) JS JS - -- ^ instanceof check - | JSComment (Maybe SourceSpan) [Comment] JS - -- ^ Commented JavaScript - deriving (Show, Eq) - -withSourceSpan :: SourceSpan -> JS -> JS -withSourceSpan withSpan = go where - ss :: Maybe SourceSpan - ss = Just withSpan - - go :: JS -> JS - go (JSNumericLiteral _ n) = JSNumericLiteral ss n - go (JSStringLiteral _ s) = JSStringLiteral ss s - go (JSBooleanLiteral _ b) = JSBooleanLiteral ss b - go (JSUnary _ op j) = JSUnary ss op j - go (JSBinary _ op j1 j2) = JSBinary ss op j1 j2 - go (JSArrayLiteral _ js) = JSArrayLiteral ss js - go (JSIndexer _ j1 j2) = JSIndexer ss j1 j2 - go (JSObjectLiteral _ js) = JSObjectLiteral ss js - go (JSFunction _ name args j) = JSFunction ss name args j - go (JSApp _ j js) = JSApp ss j js - go (JSVar _ s) = JSVar ss s - go (JSBlock _ js) = JSBlock ss js - go (JSVariableIntroduction _ name j) = JSVariableIntroduction ss name j - go (JSAssignment _ j1 j2) = JSAssignment ss j1 j2 - go (JSWhile _ j1 j2) = JSWhile ss j1 j2 - go (JSFor _ name j1 j2 j3) = JSFor ss name j1 j2 j3 - go (JSForIn _ name j1 j2) = JSForIn ss name j1 j2 - go (JSIfElse _ j1 j2 j3) = JSIfElse ss j1 j2 j3 - go (JSReturn _ js) = JSReturn ss js - go (JSReturnNoResult _) = JSReturnNoResult ss - go (JSThrow _ js) = JSThrow ss js - go (JSTypeOf _ js) = JSTypeOf ss js - go (JSInstanceOf _ j1 j2) = JSInstanceOf ss j1 j2 - go (JSComment _ com j) = JSComment ss com j - -getSourceSpan :: JS -> Maybe SourceSpan -getSourceSpan = go where - go :: JS -> Maybe SourceSpan - go (JSNumericLiteral ss _) = ss - go (JSStringLiteral ss _) = ss - go (JSBooleanLiteral ss _) = ss - go (JSUnary ss _ _) = ss - go (JSBinary ss _ _ _) = ss - go (JSArrayLiteral ss _) = ss - go (JSIndexer ss _ _) = ss - go (JSObjectLiteral ss _) = ss - go (JSFunction ss _ _ _) = ss - go (JSApp ss _ _) = ss - go (JSVar ss _) = ss - go (JSBlock ss _) = ss - go (JSVariableIntroduction ss _ _) = ss - go (JSAssignment ss _ _) = ss - go (JSWhile ss _ _) = ss - go (JSFor ss _ _ _ _) = ss - go (JSForIn ss _ _ _) = ss - go (JSIfElse ss _ _ _) = ss - go (JSReturn ss _) = ss - go (JSReturnNoResult ss) = ss - go (JSThrow ss _) = ss - go (JSTypeOf ss _) = ss - go (JSInstanceOf ss _ _) = ss - go (JSComment ss _ _) = ss - -everywhereOnJS :: (JS -> JS) -> JS -> JS -everywhereOnJS f = go where - go :: JS -> JS - go (JSUnary ss op j) = f (JSUnary ss op (go j)) - go (JSBinary ss op j1 j2) = f (JSBinary ss op (go j1) (go j2)) - go (JSArrayLiteral ss js) = f (JSArrayLiteral ss (map go js)) - go (JSIndexer ss j1 j2) = f (JSIndexer ss (go j1) (go j2)) - go (JSObjectLiteral ss js) = f (JSObjectLiteral ss (map (fmap go) js)) - go (JSFunction ss name args j) = f (JSFunction ss name args (go j)) - go (JSApp ss j js) = f (JSApp ss (go j) (map go js)) - go (JSBlock ss js) = f (JSBlock ss (map go js)) - go (JSVariableIntroduction ss name j) = f (JSVariableIntroduction ss name (fmap go j)) - go (JSAssignment ss j1 j2) = f (JSAssignment ss (go j1) (go j2)) - go (JSWhile ss j1 j2) = f (JSWhile ss (go j1) (go j2)) - go (JSFor ss name j1 j2 j3) = f (JSFor ss name (go j1) (go j2) (go j3)) - go (JSForIn ss name j1 j2) = f (JSForIn ss name (go j1) (go j2)) - go (JSIfElse ss j1 j2 j3) = f (JSIfElse ss (go j1) (go j2) (fmap go j3)) - go (JSReturn ss js) = f (JSReturn ss (go js)) - go (JSThrow ss js) = f (JSThrow ss (go js)) - go (JSTypeOf ss js) = f (JSTypeOf ss (go js)) - go (JSInstanceOf ss j1 j2) = f (JSInstanceOf ss (go j1) (go j2)) - go (JSComment ss com j) = f (JSComment ss com (go j)) - go other = f other - -everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS -everywhereOnJSTopDown f = runIdentity . everywhereOnJSTopDownM (Identity . f) - -everywhereOnJSTopDownM :: (Monad m) => (JS -> m JS) -> JS -> m JS -everywhereOnJSTopDownM f = f >=> go where - f' = f >=> go - go (JSUnary ss op j) = JSUnary ss op <$> f' j - go (JSBinary ss op j1 j2) = JSBinary ss op <$> f' j1 <*> f' j2 - go (JSArrayLiteral ss js) = JSArrayLiteral ss <$> traverse f' js - go (JSIndexer ss j1 j2) = JSIndexer ss <$> f' j1 <*> f' j2 - go (JSObjectLiteral ss js) = JSObjectLiteral ss <$> traverse (sndM f') js - go (JSFunction ss name args j) = JSFunction ss name args <$> f' j - go (JSApp ss j js) = JSApp ss <$> f' j <*> traverse f' js - go (JSBlock ss js) = JSBlock ss <$> traverse f' js - go (JSVariableIntroduction ss name j) = JSVariableIntroduction ss name <$> traverse f' j - go (JSAssignment ss j1 j2) = JSAssignment ss <$> f' j1 <*> f' j2 - go (JSWhile ss j1 j2) = JSWhile ss <$> f' j1 <*> f' j2 - go (JSFor ss name j1 j2 j3) = JSFor ss name <$> f' j1 <*> f' j2 <*> f' j3 - go (JSForIn ss name j1 j2) = JSForIn ss name <$> f' j1 <*> f' j2 - go (JSIfElse ss j1 j2 j3) = JSIfElse ss <$> f' j1 <*> f' j2 <*> traverse f' j3 - go (JSReturn ss j) = JSReturn ss <$> f' j - go (JSThrow ss j) = JSThrow ss <$> f' j - go (JSTypeOf ss j) = JSTypeOf ss <$> f' j - go (JSInstanceOf ss j1 j2) = JSInstanceOf ss <$> f' j1 <*> f' j2 - go (JSComment ss com j) = JSComment ss com <$> f' j - go other = f other - -everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r -everythingOnJS (<>) f = go where - go j@(JSUnary _ _ j1) = f j <> go j1 - go j@(JSBinary _ _ j1 j2) = f j <> go j1 <> go j2 - go j@(JSArrayLiteral _ js) = foldl (<>) (f j) (map go js) - go j@(JSIndexer _ j1 j2) = f j <> go j1 <> go j2 - go j@(JSObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js) - go j@(JSFunction _ _ _ j1) = f j <> go j1 - go j@(JSApp _ j1 js) = foldl (<>) (f j <> go j1) (map go js) - go j@(JSBlock _ js) = foldl (<>) (f j) (map go js) - go j@(JSVariableIntroduction _ _ (Just j1)) = f j <> go j1 - go j@(JSAssignment _ j1 j2) = f j <> go j1 <> go j2 - go j@(JSWhile _ j1 j2) = f j <> go j1 <> go j2 - go j@(JSFor _ _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3 - go j@(JSForIn _ _ j1 j2) = f j <> go j1 <> go j2 - go j@(JSIfElse _ j1 j2 Nothing) = f j <> go j1 <> go j2 - go j@(JSIfElse _ j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3 - go j@(JSReturn _ j1) = f j <> go j1 - go j@(JSThrow _ j1) = f j <> go j1 - go j@(JSTypeOf _ j1) = f j <> go j1 - go j@(JSInstanceOf _ j1 j2) = f j <> go j1 <> go j2 - go j@(JSComment _ _ j1) = f j <> go j1 - go other = f other diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 751042873f..0060b56d97 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -1,6 +1,4 @@ --- | --- Common code generation utility functions --- +-- | Common code generation utility functions module Language.PureScript.CodeGen.JS.Common where import Prelude.Compat @@ -18,15 +16,13 @@ moduleNameToJs (ModuleName pns) = let name = T.intercalate "_" (runProperName `map` pns) in if nameIsJsBuiltIn name then "$$" <> name else name --- | --- Convert an Ident into a valid JavaScript identifier: +-- | Convert an 'Ident' into a valid JavaScript identifier: -- -- * Alphanumeric characters are kept unmodified. -- -- * Reserved javascript identifiers are prefixed with '$$'. -- -- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value. --- identToJs :: Ident -> Text identToJs (Ident name) = properToJs name identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" @@ -36,16 +32,12 @@ properToJs name | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" <> name | otherwise = T.concatMap identCharToText name --- | --- Test if a string is a valid JS identifier without escaping. --- +-- | Test if a string is a valid AST identifier without escaping. identNeedsEscaping :: Text -> Bool identNeedsEscaping s = s /= properToJs s || T.null s --- | --- Attempts to find a human-readable name for a symbol, if none has been specified returns the +-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the -- ordinal value. --- identCharToText :: Char -> Text identCharToText c | isAlphaNum c = T.singleton c identCharToText '_' = "_" @@ -72,16 +64,12 @@ identCharToText '@' = "$at" identCharToText '\'' = "$prime" identCharToText c = '$' `T.cons` T.pack (show (ord c)) --- | --- Checks whether an identifier name is reserved in JavaScript. --- +-- | Checks whether an identifier name is reserved in JavaScript. nameIsJsReserved :: Text -> Bool nameIsJsReserved name = name `elem` jsAnyReserved --- | --- Checks whether a name matches a built-in value in JavaScript. --- +-- | Checks whether a name matches a built-in value in JavaScript. nameIsJsBuiltIn :: Text -> Bool nameIsJsBuiltIn name = name `elem` diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs deleted file mode 100644 index ffd40a1e76..0000000000 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ /dev/null @@ -1,60 +0,0 @@ --- | This module optimizes code in the simplified-JavaScript intermediate representation. --- --- The following optimizations are supported: --- --- * Collapsing nested blocks --- --- * Tail call elimination --- --- * Inlining of (>>=) and ret for the Eff monad --- --- * Removal of unnecessary thunks --- --- * Eta conversion --- --- * Inlining variables --- --- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!) --- --- * Inlining primitive JavaScript operators -module Language.PureScript.CodeGen.JS.Optimizer (optimize) where - -import Prelude.Compat - -import Control.Monad.Supply.Class (MonadSupply) -import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.CodeGen.JS.Optimizer.Blocks -import Language.PureScript.CodeGen.JS.Optimizer.Common -import Language.PureScript.CodeGen.JS.Optimizer.Inliner -import Language.PureScript.CodeGen.JS.Optimizer.MagicDo -import Language.PureScript.CodeGen.JS.Optimizer.TCO -import Language.PureScript.CodeGen.JS.Optimizer.Unused - --- | Apply a series of optimizer passes to simplified JavaScript code -optimize :: MonadSupply m => JS -> m JS -optimize js = do - js' <- untilFixedPoint (inlineFnComposition . inlineUnsafePartial . tidyUp . applyAll - [ inlineCommonValues - , inlineCommonOperators - ]) js - untilFixedPoint (return . tidyUp) . tco . magicDo $ js' - where - tidyUp :: JS -> JS - tidyUp = applyAll - [ collapseNestedBlocks - , collapseNestedIfs - , removeCodeAfterReturnStatements - , removeUnusedArg - , removeUndefinedApp - , unThunk - , etaConvert - , evaluateIifes - , inlineVariables - ] - -untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a -untilFixedPoint f = go - where - go a = do - a' <- f a - if a' == a then return a' else go a' diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs deleted file mode 100644 index 5e40399c9f..0000000000 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | --- Optimizer steps for simplifying JavaScript blocks --- -module Language.PureScript.CodeGen.JS.Optimizer.Blocks - ( collapseNestedBlocks - , collapseNestedIfs - ) where - -import Prelude.Compat - -import Language.PureScript.CodeGen.JS.AST - --- | --- Collapse blocks which appear nested directly below another block --- -collapseNestedBlocks :: JS -> JS -collapseNestedBlocks = everywhereOnJS collapse - where - collapse :: JS -> JS - collapse (JSBlock ss sts) = JSBlock ss (concatMap go sts) - collapse js = js - go :: JS -> [JS] - go (JSBlock _ sts) = sts - go s = [s] - -collapseNestedIfs :: JS -> JS -collapseNestedIfs = everywhereOnJS collapse - where - collapse :: JS -> JS - collapse (JSIfElse s1 cond1 (JSBlock _ [JSIfElse s2 cond2 body Nothing]) Nothing) = - JSIfElse s1 (JSBinary s2 And cond1 cond2) body Nothing - collapse js = js diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs deleted file mode 100644 index 763626a26e..0000000000 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs +++ /dev/null @@ -1,78 +0,0 @@ --- | --- Common functions used by the various optimizer phases --- -module Language.PureScript.CodeGen.JS.Optimizer.Common where - -import Prelude.Compat - -import Data.Text (Text) -import Data.List (foldl') -import Data.Maybe (fromMaybe) - -import Language.PureScript.Crash -import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.PSString (PSString) - -applyAll :: [a -> a] -> a -> a -applyAll = foldl' (.) id - -replaceIdent :: Text -> JS -> JS -> JS -replaceIdent var1 js = everywhereOnJS replace - where - replace (JSVar _ var2) | var1 == var2 = js - replace other = other - -replaceIdents :: [(Text, JS)] -> JS -> JS -replaceIdents vars = everywhereOnJS replace - where - replace v@(JSVar _ var) = fromMaybe v $ lookup var vars - replace other = other - -isReassigned :: Text -> JS -> Bool -isReassigned var1 = everythingOnJS (||) check - where - check :: JS -> Bool - check (JSFunction _ _ args _) | var1 `elem` args = True - check (JSVariableIntroduction _ arg _) | var1 == arg = True - check (JSAssignment _ (JSVar _ arg) _) | var1 == arg = True - check (JSFor _ arg _ _ _) | var1 == arg = True - check (JSForIn _ arg _ _) | var1 == arg = True - check _ = False - -isRebound :: JS -> JS -> Bool -isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js) - where - variablesOf (JSVar _ var) = [var] - variablesOf _ = [] - -isUsed :: Text -> JS -> Bool -isUsed var1 = everythingOnJS (||) check - where - check :: JS -> Bool - check (JSVar _ var2) | var1 == var2 = True - check (JSAssignment _ target _) | var1 == targetVariable target = True - check _ = False - -targetVariable :: JS -> Text -targetVariable (JSVar _ var) = var -targetVariable (JSIndexer _ _ tgt) = targetVariable tgt -targetVariable _ = internalError "Invalid argument to targetVariable" - -isUpdated :: Text -> JS -> Bool -isUpdated var1 = everythingOnJS (||) check - where - check :: JS -> Bool - check (JSAssignment _ target _) | var1 == targetVariable target = True - check _ = False - -removeFromBlock :: ([JS] -> [JS]) -> JS -> JS -removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts) -removeFromBlock _ js = js - -isDict :: (Text, PSString) -> JS -> Bool -isDict (moduleName, dictName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = - x == dictName && y == moduleName -isDict _ _ = False - -isDict' :: [(Text, PSString)] -> JS -> Bool -isDict' xs js = any (`isDict` js) xs diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs deleted file mode 100644 index 9ce31fef3f..0000000000 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs +++ /dev/null @@ -1,134 +0,0 @@ --- | This module implements the "Magic Do" optimization, which inlines calls to return --- and bind for the Eff monad, as well as some of its actions. -module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (magicDo) where - -import Prelude.Compat -import Protolude (ordNub) - -import Data.Maybe (fromJust, isJust) - -import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.CodeGen.JS.Optimizer.Common -import Language.PureScript.PSString (mkString) -import qualified Language.PureScript.Constants as C - --- | Inline type class dictionaries for >>= and return for the Eff monad --- --- E.g. --- --- Prelude[">>="](dict)(m1)(function(x) { --- return ...; --- }) --- --- becomes --- --- function __do { --- var x = m1(); --- ... --- } -magicDo :: JS -> JS -magicDo = inlineST . everywhereOnJS undo . everywhereOnJSTopDown convert - where - -- The name of the function block which is added to denote a do block - fnName = "__do" - -- Desugar monomorphic calls to >>= and return for the Eff monad - convert :: JS -> JS - -- Desugar pure - convert (JSApp _ (JSApp _ pure' [val]) []) | isPure pure' = val - -- Desugar discard - convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [] (JSBlock s2 js)]) | isDiscard bind = - JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSApp s2 m [] : map applyReturns js ) - -- Desugar bind - convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [arg] (JSBlock s2 js)]) | isBind bind = - JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSVariableIntroduction s2 arg (Just (JSApp s2 m [])) : map applyReturns js) - -- Desugar untilE - convert (JSApp s1 (JSApp _ f [arg]) []) | isEffFunc C.untilE f = - JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSUnary s1 Not (JSApp s1 arg [])) (JSBlock s1 []), JSReturn s1 $ JSObjectLiteral s1 []])) [] - -- Desugar whileE - convert (JSApp _ (JSApp _ (JSApp s1 f [arg1]) [arg2]) []) | isEffFunc C.whileE f = - JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSApp s1 arg1 []) (JSBlock s1 [ JSApp s1 arg2 [] ]), JSReturn s1 $ JSObjectLiteral s1 []])) [] - convert other = other - -- Check if an expression represents a monomorphic call to >>= for the Eff monad - isBind (JSApp _ fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True - isBind _ = False - -- Check if an expression represents a call to @discard@ - isDiscard (JSApp _ (JSApp _ fn [dict1]) [dict2]) - | isDict (C.controlBind, C.discardUnitDictionary) dict1 && - isDict (C.eff, C.bindEffDictionary) dict2 && - isDiscardPoly fn = True - isDiscard _ = False - -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative - isPure (JSApp _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True - isPure _ = False - -- Check if an expression represents the polymorphic >>= function - isBindPoly = isDict (C.controlBind, C.bind) - -- Check if an expression represents the polymorphic pure function - isPurePoly = isDict (C.controlApplicative, C.pure') - -- Check if an expression represents the polymorphic discard function - isDiscardPoly = isDict (C.controlBind, C.discard) - -- Check if an expression represents a function in the Eff module - isEffFunc name (JSIndexer _ (JSStringLiteral _ name') (JSVar _ eff)) = eff == C.eff && name == name' - isEffFunc _ _ = False - - -- Remove __do function applications which remain after desugaring - undo :: JS -> JS - undo (JSReturn _ (JSApp _ (JSFunction _ (Just ident) [] body) [])) | ident == fnName = body - undo other = other - - applyReturns :: JS -> JS - applyReturns (JSReturn ss ret) = JSReturn ss (JSApp ss ret []) - applyReturns (JSBlock ss jss) = JSBlock ss (map applyReturns jss) - applyReturns (JSWhile ss cond js) = JSWhile ss cond (applyReturns js) - applyReturns (JSFor ss v lo hi js) = JSFor ss v lo hi (applyReturns js) - applyReturns (JSForIn ss v xs js) = JSForIn ss v xs (applyReturns js) - applyReturns (JSIfElse ss cond t f) = JSIfElse ss cond (applyReturns t) (applyReturns `fmap` f) - applyReturns other = other - --- | Inline functions in the ST module -inlineST :: JS -> JS -inlineST = everywhereOnJS convertBlock - where - -- Look for runST blocks and inline the STRefs there. - -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then - -- we can be more aggressive about inlining, and actually turn STRefs into local variables. - convertBlock (JSApp _ f [arg]) | isSTFunc C.runST f = - let refs = ordNub . findSTRefsIn $ arg - usages = findAllSTUsagesIn arg - allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages - localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs - in everywhereOnJS (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg - convertBlock other = other - -- 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 s1 f [arg]) | isSTFunc C.newSTRef f = - JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(mkString C.stRefValue, arg)]]) - convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f = - if agg then ref else JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref - convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f = - if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref) arg - convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f = - if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref) (JSApp s1 func [JSIndexer s1 (JSStringLiteral s1 C.stRefValue) ref]) - convert _ other = other - -- Check if an expression represents a function in the ST module - isSTFunc name (JSIndexer _ (JSStringLiteral _ name') (JSVar _ st)) = st == C.st && name == name' - isSTFunc _ _ = False - -- Find all ST Refs initialized in this block - findSTRefsIn = everythingOnJS (++) isSTRef - where - isSTRef (JSVariableIntroduction _ ident (Just (JSApp _ (JSApp _ f [_]) []))) | isSTFunc C.newSTRef f = [ident] - isSTRef _ = [] - -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef - findAllSTUsagesIn = everythingOnJS (++) isSTUsage - where - isSTUsage (JSApp _ (JSApp _ f [ref]) []) | isSTFunc C.readSTRef f = [ref] - isSTUsage (JSApp _ (JSApp _ (JSApp _ f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref] - isSTUsage _ = [] - -- Find all uses of a variable - appearingIn ref = everythingOnJS (++) isVar - where - isVar e@(JSVar _ v) | v == ref = [e] - isVar _ = [] - -- Convert a JS value to a String if it is a JSVar - toVar (JSVar _ v) = Just v - toVar _ = Nothing diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs deleted file mode 100644 index d9b184d632..0000000000 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs +++ /dev/null @@ -1,121 +0,0 @@ --- | This module implements tail call elimination. -module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where - -import Prelude.Compat - -import Data.Text (Text) -import Data.Monoid ((<>)) -import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.AST.SourcePos (SourceSpan) - --- | Eliminate tail calls -tco :: JS -> JS -tco = everywhereOnJS convert where - tcoVar :: Text -> Text - tcoVar arg = "__tco_" <> arg - - copyVar :: Text -> Text - copyVar arg = "__copy_" <> arg - - tcoDone :: Text - tcoDone = tcoVar "done" - - tcoLoop :: Text - tcoLoop = tcoVar "loop" - - tcoResult :: Text - tcoResult = tcoVar "result" - - convert :: JS -> JS - convert (JSVariableIntroduction ss name (Just fn@JSFunction {})) - | isTailRecursive name body' - = JSVariableIntroduction ss name (Just (replace (toLoop name allArgs body'))) - where - (argss, body', replace) = collectAllFunctionArgs [] id fn - allArgs = concat $ reverse argss - convert js = js - - collectAllFunctionArgs :: [[Text]] -> (JS -> JS) -> JS -> ([[Text]], JS, JS -> JS) - collectAllFunctionArgs allArgs f (JSFunction s1 ident args (JSBlock s2 (body@(JSReturn _ _):_))) = - collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction s1 ident (map copyVar args) (JSBlock s2 [b]))) body - collectAllFunctionArgs allArgs f (JSFunction ss ident args body@(JSBlock _ _)) = - (args : allArgs, body, f . JSFunction ss ident (map copyVar args)) - collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args (JSBlock s3 [body]))) = - collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn s1 (JSFunction s2 ident (map copyVar args) (JSBlock s3 [b])))) body - collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args body@(JSBlock _ _))) = - (args : allArgs, body, f . JSReturn s1 . JSFunction s2 ident (map copyVar args)) - collectAllFunctionArgs allArgs f body = (allArgs, body, f) - - isTailRecursive :: Text -> JS -> Bool - isTailRecursive ident js = countSelfReferences js > 0 && allInTailPosition js where - countSelfReferences = everythingOnJS (+) match where - match :: JS -> Int - match (JSVar _ ident') | ident == ident' = 1 - match _ = 0 - - allInTailPosition (JSReturn _ expr) - | isSelfCall ident expr = countSelfReferences expr == 1 - | otherwise = countSelfReferences expr == 0 - allInTailPosition (JSWhile _ js1 body) - = countSelfReferences js1 == 0 && allInTailPosition body - allInTailPosition (JSFor _ _ js1 js2 body) - = countSelfReferences js1 == 0 && countSelfReferences js2 == 0 && allInTailPosition body - allInTailPosition (JSForIn _ _ js1 body) - = countSelfReferences js1 == 0 && allInTailPosition body - allInTailPosition (JSIfElse _ js1 body el) - = countSelfReferences js1 == 0 && allInTailPosition body && all allInTailPosition el - allInTailPosition (JSBlock _ body) - = all allInTailPosition body - allInTailPosition _ - = False - - toLoop :: Text -> [Text] -> JS -> JS - toLoop ident allArgs js = - JSBlock rootSS $ - map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs ++ - [ JSVariableIntroduction rootSS tcoDone (Just (JSBooleanLiteral rootSS False)) - , JSVariableIntroduction rootSS tcoResult Nothing - ] ++ - map (\arg -> - JSVariableIntroduction rootSS (tcoVar arg) Nothing) allArgs ++ - [ JSFunction rootSS (Just tcoLoop) allArgs (JSBlock rootSS [loopify js]) - , JSWhile rootSS (JSUnary rootSS Not (JSVar rootSS tcoDone)) - (JSBlock rootSS - (JSAssignment rootSS (JSVar rootSS tcoResult) (JSApp rootSS (JSVar rootSS tcoLoop) (map (JSVar rootSS) allArgs)) - : map (\arg -> - JSAssignment rootSS (JSVar rootSS arg) (JSVar rootSS (tcoVar arg))) allArgs)) - , JSReturn rootSS (JSVar rootSS tcoResult) - ] - where - rootSS = Nothing - - loopify :: JS -> JS - loopify (JSReturn ss ret) - | isSelfCall ident ret = - let - allArgumentValues = concat $ collectArgs [] ret - in - JSBlock ss $ - zipWith (\val arg -> - JSAssignment ss (JSVar ss (tcoVar arg)) val) allArgumentValues allArgs - ++ [ JSReturnNoResult ss ] - | otherwise = JSBlock ss [ markDone ss, JSReturn ss ret ] - loopify (JSReturnNoResult ss) = JSBlock ss [ markDone ss, JSReturnNoResult ss ] - loopify (JSWhile ss cond body) = JSWhile ss cond (loopify body) - loopify (JSFor ss i js1 js2 body) = JSFor ss i js1 js2 (loopify body) - loopify (JSForIn ss i js1 body) = JSForIn ss i js1 (loopify body) - loopify (JSIfElse ss cond body el) = JSIfElse ss cond (loopify body) (fmap loopify el) - loopify (JSBlock ss body) = JSBlock ss (map loopify body) - loopify other = other - - markDone :: Maybe SourceSpan -> JS - markDone ss = JSAssignment ss (JSVar ss tcoDone) (JSBooleanLiteral ss True) - - collectArgs :: [[JS]] -> JS -> [[JS]] - collectArgs acc (JSApp _ fn args') = collectArgs (args' : acc) fn - collectArgs acc _ = acc - - isSelfCall :: Text -> JS -> Bool - isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident' - isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn - isSelfCall _ _ = False diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs deleted file mode 100644 index 2ba4da02e7..0000000000 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs +++ /dev/null @@ -1,36 +0,0 @@ --- | --- Removes unused variables --- -module Language.PureScript.CodeGen.JS.Optimizer.Unused - ( removeCodeAfterReturnStatements - , removeUnusedArg - , removeUndefinedApp - ) where - -import Prelude.Compat - -import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.CodeGen.JS.Optimizer.Common -import qualified Language.PureScript.Constants as C - -removeCodeAfterReturnStatements :: JS -> JS -removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go) - where - go :: [JS] -> [JS] - go jss | not (any isJSReturn jss) = jss - | otherwise = let (body, ret : _) = break isJSReturn jss in body ++ [ret] - isJSReturn (JSReturn _ _) = True - isJSReturn (JSReturnNoResult _) = True - isJSReturn _ = False - -removeUnusedArg :: JS -> JS -removeUnusedArg = everywhereOnJS convert - where - convert (JSFunction ss name [arg] body) | arg == C.__unused = JSFunction ss name [] body - convert js = js - -removeUndefinedApp :: JS -> JS -removeUndefinedApp = everywhereOnJS convert - where - convert (JSApp ss fn [JSVar _ arg]) | arg == C.undefined = JSApp ss fn [] - convert js = js diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs similarity index 71% rename from src/Language/PureScript/Pretty/JS.hs rename to src/Language/PureScript/CodeGen/JS/Printer.hs index 4d6cd2f293..8c72e08397 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -1,5 +1,5 @@ -- | Pretty printer for the JavaScript AST -module Language.PureScript.Pretty.JS +module Language.PureScript.CodeGen.JS.Printer ( prettyPrintJS , prettyPrintJSWithSourceMaps ) where @@ -18,8 +18,8 @@ import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.AST (SourceSpan(..)) -import Language.PureScript.CodeGen.JS.AST import Language.PureScript.CodeGen.JS.Common +import Language.PureScript.CoreImp.AST import Language.PureScript.Comments import Language.PureScript.Crash import Language.PureScript.Pretty.Common @@ -27,24 +27,24 @@ import Language.PureScript.PSString (PSString, decodeString, prettyPrintStringJS -- TODO (Christoph): Get rid of T.unpack / pack -literals :: (Emit gen) => Pattern PrinterState JS gen +literals :: (Emit gen) => Pattern PrinterState AST gen literals = mkPattern' match' where - match' :: (Emit gen) => JS -> StateT PrinterState Maybe gen + match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen match' js = (addMapping' (getSourceSpan js) <>) <$> match js - match :: (Emit gen) => JS -> StateT PrinterState Maybe gen - match (JSNumericLiteral _ n) = return $ emit $ T.pack $ either show show n - match (JSStringLiteral _ s) = return $ emit $ prettyPrintStringJS s - match (JSBooleanLiteral _ True) = return $ emit "true" - match (JSBooleanLiteral _ False) = return $ emit "false" - match (JSArrayLiteral _ xs) = mconcat <$> sequence + match :: (Emit gen) => AST -> StateT PrinterState Maybe gen + match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n + match (StringLiteral _ s) = return $ emit $ prettyPrintStringJS s + match (BooleanLiteral _ True) = return $ emit "true" + match (BooleanLiteral _ False) = return $ emit "false" + match (ArrayLiteral _ xs) = mconcat <$> sequence [ return $ emit "[ " , intercalate (emit ", ") <$> forM xs prettyPrintJS' , return $ emit " ]" ] - match (JSObjectLiteral _ []) = return $ emit "{}" - match (JSObjectLiteral _ ps) = mconcat <$> sequence + match (ObjectLiteral _ []) = return $ emit "{}" + match (ObjectLiteral _ ps) = mconcat <$> sequence [ return $ emit "{\n" , withIndent $ do jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key <> emit ": ") <>) . prettyPrintJS' $ value @@ -62,30 +62,30 @@ literals = mkPattern' match' s' _ -> prettyPrintStringJS s - match (JSBlock _ sts) = mconcat <$> sequence + match (Block _ sts) = mconcat <$> sequence [ return $ emit "{\n" , withIndent $ prettyStatements sts , return $ emit "\n" , currentIndent , return $ emit "}" ] - match (JSVar _ ident) = return $ emit ident - match (JSVariableIntroduction _ ident value) = mconcat <$> sequence + match (Var _ ident) = return $ emit ident + match (VariableIntroduction _ ident value) = mconcat <$> sequence [ return $ emit $ "var " <> ident , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value ] - match (JSAssignment _ target value) = mconcat <$> sequence + match (Assignment _ target value) = mconcat <$> sequence [ prettyPrintJS' target , return $ emit " = " , prettyPrintJS' value ] - match (JSWhile _ cond sts) = mconcat <$> sequence + match (While _ cond sts) = mconcat <$> sequence [ return $ emit "while (" , prettyPrintJS' cond , return $ emit ") " , prettyPrintJS' sts ] - match (JSFor _ ident start end sts) = mconcat <$> sequence + match (For _ ident start end sts) = mconcat <$> sequence [ return $ emit $ "for (var " <> ident <> " = " , prettyPrintJS' start , return $ emit $ "; " <> ident <> " < " @@ -93,29 +93,29 @@ literals = mkPattern' match' , return $ emit $ "; " <> ident <> "++) " , prettyPrintJS' sts ] - match (JSForIn _ ident obj sts) = mconcat <$> sequence + match (ForIn _ ident obj sts) = mconcat <$> sequence [ return $ emit $ "for (var " <> ident <> " in " , prettyPrintJS' obj , return $ emit ") " , prettyPrintJS' sts ] - match (JSIfElse _ cond thens elses) = mconcat <$> sequence + match (IfElse _ cond thens elses) = mconcat <$> sequence [ return $ emit "if (" , prettyPrintJS' cond , return $ emit ") " , prettyPrintJS' thens , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintJS') elses ] - match (JSReturn _ value) = mconcat <$> sequence + match (Return _ value) = mconcat <$> sequence [ return $ emit "return " , prettyPrintJS' value ] - match (JSReturnNoResult _) = return $ emit "return" - match (JSThrow _ value) = mconcat <$> sequence + match (ReturnNoResult _) = return $ emit "return" + match (Throw _ value) = mconcat <$> sequence [ return $ emit "throw " , prettyPrintJS' value ] - match (JSComment _ com js) = mconcat <$> sequence + match (Comment _ com js) = mconcat <$> sequence [ mconcat <$> forM com comment , prettyPrintJS' js ] @@ -151,107 +151,100 @@ literals = mkPattern' match' Just (x, xs) -> x `T.cons` removeComments xs Nothing -> "" -accessor :: Pattern PrinterState JS (Text, JS) +accessor :: Pattern PrinterState AST (Text, AST) accessor = mkPattern match where - match (JSIndexer _ (JSStringLiteral _ prop) val) = + match (Indexer _ (StringLiteral _ prop) val) = case decodeString prop of Just s | not (identNeedsEscaping s) -> Just (s, val) _ -> Nothing match _ = Nothing -indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS) +indexer :: (Emit gen) => Pattern PrinterState AST (gen, AST) indexer = mkPattern' match where - match (JSIndexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val + match (Indexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val match _ = mzero -lam :: Pattern PrinterState JS ((Maybe Text, [Text], Maybe SourceSpan), JS) +lam :: Pattern PrinterState AST ((Maybe Text, [Text], Maybe SourceSpan), AST) lam = mkPattern match where - match (JSFunction ss name args ret) = Just ((name, args, ss), ret) + match (Function ss name args ret) = Just ((name, args, ss), ret) match _ = Nothing -app :: (Emit gen) => Pattern PrinterState JS (gen, JS) +app :: (Emit gen) => Pattern PrinterState AST (gen, AST) app = mkPattern' match where - match (JSApp _ val args) = do + match (App _ val args) = do jss <- traverse prettyPrintJS' args return (intercalate (emit ", ") jss, val) match _ = mzero -typeOf :: Pattern PrinterState JS ((), JS) -typeOf = mkPattern match - where - match (JSTypeOf _ val) = Just ((), val) - match _ = Nothing - -instanceOf :: Pattern PrinterState JS (JS, JS) +instanceOf :: Pattern PrinterState AST (AST, AST) instanceOf = mkPattern match where - match (JSInstanceOf _ val ty) = Just (val, ty) + match (InstanceOf _ val ty) = Just (val, ty) match _ = Nothing -unary' :: (Emit gen) => UnaryOperator -> (JS -> Text) -> Operator PrinterState JS gen +unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen unary' op mkStr = Wrap match (<>) where - match :: (Emit gen) => Pattern PrinterState JS (gen, JS) + match :: (Emit gen) => Pattern PrinterState AST (gen, AST) match = mkPattern match' where - match' (JSUnary _ op' val) | op' == op = Just (emit $ mkStr val, val) + match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val) match' _ = Nothing -unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState JS gen +unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen unary op str = unary' op (const str) -negateOperator :: (Emit gen) => Operator PrinterState JS gen +negateOperator :: (Emit gen) => Operator PrinterState AST gen negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-") where - isNegate (JSUnary _ Negate _) = True + isNegate (Unary _ Negate _) = True isNegate _ = False -binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState JS gen +binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2) where - match :: Pattern PrinterState JS (JS, JS) + match :: Pattern PrinterState AST (AST, AST) match = mkPattern match' where - match' (JSBinary _ op' v1 v2) | op' == op = Just (v1, v2) + match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2) match' _ = Nothing -prettyStatements :: (Emit gen) => [JS] -> StateT PrinterState Maybe gen +prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen prettyStatements sts = do jss <- forM sts prettyPrintJS' indentString <- currentIndent return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss -- | Generate a pretty-printed string representing a collection of JavaScript expressions at the same indentation level -prettyPrintJSWithSourceMaps :: [JS] -> (Text, [SMap]) +prettyPrintJSWithSourceMaps :: [AST] -> (Text, [SMap]) prettyPrintJSWithSourceMaps js = let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js in (s, mp) -prettyPrintJS :: [JS] -> Text +prettyPrintJS :: [AST] -> Text prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements -- | Generate an indented, pretty-printed string representing a JavaScript expression -prettyPrintJS' :: (Emit gen) => JS -> StateT PrinterState Maybe gen +prettyPrintJS' :: (Emit gen) => AST -> StateT PrinterState Maybe gen prettyPrintJS' = A.runKleisli $ runPattern matchValue where - matchValue :: (Emit gen) => Pattern PrinterState JS gen + matchValue :: (Emit gen) => Pattern PrinterState AST gen matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue) - operators :: (Emit gen) => OperatorTable PrinterState JS gen + operators :: (Emit gen) => OperatorTable PrinterState AST gen operators = OperatorTable [ [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ] , [ Wrap accessor $ \prop val -> val <> emit "." <> emit prop ] , [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ] - , [ unary JSNew "new " ] + , [ unary New "new " ] , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <> emit ("function " <> fromMaybe "" name <> "(" <> intercalate ", " args <> ") ") <> ret ] - , [ Wrap typeOf $ \_ s -> emit "typeof " <> s ] , [ unary Not "!" , unary BitwiseNot "~" , unary Positive "+" diff --git a/src/Language/PureScript/CoreImp.hs b/src/Language/PureScript/CoreImp.hs new file mode 100644 index 0000000000..5029aff96b --- /dev/null +++ b/src/Language/PureScript/CoreImp.hs @@ -0,0 +1,13 @@ +-- | The imperative core language +module Language.PureScript.CoreImp ( + module C +) where + +import Language.PureScript.CoreImp.AST as C +import Language.PureScript.CoreImp.Optimizer as C +import Language.PureScript.CoreImp.Optimizer.Blocks as C +import Language.PureScript.CoreImp.Optimizer.Common as C +import Language.PureScript.CoreImp.Optimizer.Inliner as C +import Language.PureScript.CoreImp.Optimizer.MagicDo as C +import Language.PureScript.CoreImp.Optimizer.TCO as C +import Language.PureScript.CoreImp.Optimizer.Unused as C diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs new file mode 100644 index 0000000000..36062336ae --- /dev/null +++ b/src/Language/PureScript/CoreImp/AST.hs @@ -0,0 +1,224 @@ +-- | Data types for the imperative core AST +module Language.PureScript.CoreImp.AST where + +import Prelude.Compat + +import Control.Monad ((>=>)) +import Control.Monad.Identity (Identity(..), runIdentity) +import Data.Text (Text) + +import Language.PureScript.AST (SourceSpan(..)) +import Language.PureScript.Comments +import Language.PureScript.PSString (PSString) +import Language.PureScript.Traversals + +-- | Built-in unary operators +data UnaryOperator + = Negate + | Not + | BitwiseNot + | Positive + | New + deriving (Show, Eq) + +-- | Built-in binary operators +data BinaryOperator + = Add + | Subtract + | Multiply + | Divide + | Modulus + | EqualTo + | NotEqualTo + | LessThan + | LessThanOrEqualTo + | GreaterThan + | GreaterThanOrEqualTo + | And + | Or + | BitwiseAnd + | BitwiseOr + | BitwiseXor + | ShiftLeft + | ShiftRight + | ZeroFillShiftRight + deriving (Show, Eq) + +-- | Data type for simplified JavaScript expressions +data AST + = NumericLiteral (Maybe SourceSpan) (Either Integer Double) + -- ^ A numeric literal + | StringLiteral (Maybe SourceSpan) PSString + -- ^ A string literal + | BooleanLiteral (Maybe SourceSpan) Bool + -- ^ A boolean literal + | Unary (Maybe SourceSpan) UnaryOperator AST + -- ^ A unary operator application + | Binary (Maybe SourceSpan) BinaryOperator AST AST + -- ^ A binary operator application + | ArrayLiteral (Maybe SourceSpan) [AST] + -- ^ An array literal + | Indexer (Maybe SourceSpan) AST AST + -- ^ An array indexer expression + | ObjectLiteral (Maybe SourceSpan) [(PSString, AST)] + -- ^ An object literal + | Function (Maybe SourceSpan) (Maybe Text) [Text] AST + -- ^ A function introduction (optional name, arguments, body) + | App (Maybe SourceSpan) AST [AST] + -- ^ Function application + | Var (Maybe SourceSpan) Text + -- ^ Variable + | Block (Maybe SourceSpan) [AST] + -- ^ A block of expressions in braces + | VariableIntroduction (Maybe SourceSpan) Text (Maybe AST) + -- ^ A variable introduction and optional initialization + | Assignment (Maybe SourceSpan) AST AST + -- ^ A variable assignment + | While (Maybe SourceSpan) AST AST + -- ^ While loop + | For (Maybe SourceSpan) Text AST AST AST + -- ^ For loop + | ForIn (Maybe SourceSpan) Text AST AST + -- ^ ForIn loop + | IfElse (Maybe SourceSpan) AST AST (Maybe AST) + -- ^ If-then-else statement + | Return (Maybe SourceSpan) AST + -- ^ Return statement + | ReturnNoResult (Maybe SourceSpan) + -- ^ Return statement with no return value + | Throw (Maybe SourceSpan) AST + -- ^ Throw statement + | InstanceOf (Maybe SourceSpan) AST AST + -- ^ instanceof check + | Comment (Maybe SourceSpan) [Comment] AST + -- ^ Commented JavaScript + deriving (Show, Eq) + +withSourceSpan :: SourceSpan -> AST -> AST +withSourceSpan withSpan = go where + ss :: Maybe SourceSpan + ss = Just withSpan + + go :: AST -> AST + go (NumericLiteral _ n) = NumericLiteral ss n + go (StringLiteral _ s) = StringLiteral ss s + go (BooleanLiteral _ b) = BooleanLiteral ss b + go (Unary _ op j) = Unary ss op j + go (Binary _ op j1 j2) = Binary ss op j1 j2 + go (ArrayLiteral _ js) = ArrayLiteral ss js + go (Indexer _ j1 j2) = Indexer ss j1 j2 + go (ObjectLiteral _ js) = ObjectLiteral ss js + go (Function _ name args j) = Function ss name args j + go (App _ j js) = App ss j js + go (Var _ s) = Var ss s + go (Block _ js) = Block ss js + go (VariableIntroduction _ name j) = VariableIntroduction ss name j + go (Assignment _ j1 j2) = Assignment ss j1 j2 + go (While _ j1 j2) = While ss j1 j2 + go (For _ name j1 j2 j3) = For ss name j1 j2 j3 + go (ForIn _ name j1 j2) = ForIn ss name j1 j2 + go (IfElse _ j1 j2 j3) = IfElse ss j1 j2 j3 + go (Return _ js) = Return ss js + go (ReturnNoResult _) = ReturnNoResult ss + go (Throw _ js) = Throw ss js + go (InstanceOf _ j1 j2) = InstanceOf ss j1 j2 + go (Comment _ com j) = Comment ss com j + +getSourceSpan :: AST -> Maybe SourceSpan +getSourceSpan = go where + go :: AST -> Maybe SourceSpan + go (NumericLiteral ss _) = ss + go (StringLiteral ss _) = ss + go (BooleanLiteral ss _) = ss + go (Unary ss _ _) = ss + go (Binary ss _ _ _) = ss + go (ArrayLiteral ss _) = ss + go (Indexer ss _ _) = ss + go (ObjectLiteral ss _) = ss + go (Function ss _ _ _) = ss + go (App ss _ _) = ss + go (Var ss _) = ss + go (Block ss _) = ss + go (VariableIntroduction ss _ _) = ss + go (Assignment ss _ _) = ss + go (While ss _ _) = ss + go (For ss _ _ _ _) = ss + go (ForIn ss _ _ _) = ss + go (IfElse ss _ _ _) = ss + go (Return ss _) = ss + go (ReturnNoResult ss) = ss + go (Throw ss _) = ss + go (InstanceOf ss _ _) = ss + go (Comment ss _ _) = ss + +everywhere :: (AST -> AST) -> AST -> AST +everywhere f = go where + go :: AST -> AST + go (Unary ss op j) = f (Unary ss op (go j)) + go (Binary ss op j1 j2) = f (Binary ss op (go j1) (go j2)) + go (ArrayLiteral ss js) = f (ArrayLiteral ss (map go js)) + go (Indexer ss j1 j2) = f (Indexer ss (go j1) (go j2)) + go (ObjectLiteral ss js) = f (ObjectLiteral ss (map (fmap go) js)) + go (Function ss name args j) = f (Function ss name args (go j)) + go (App ss j js) = f (App ss (go j) (map go js)) + go (Block ss js) = f (Block ss (map go js)) + go (VariableIntroduction ss name j) = f (VariableIntroduction ss name (fmap go j)) + go (Assignment ss j1 j2) = f (Assignment ss (go j1) (go j2)) + go (While ss j1 j2) = f (While ss (go j1) (go j2)) + go (For ss name j1 j2 j3) = f (For ss name (go j1) (go j2) (go j3)) + go (ForIn ss name j1 j2) = f (ForIn ss name (go j1) (go j2)) + go (IfElse ss j1 j2 j3) = f (IfElse ss (go j1) (go j2) (fmap go j3)) + go (Return ss js) = f (Return ss (go js)) + go (Throw ss js) = f (Throw ss (go js)) + go (InstanceOf ss j1 j2) = f (InstanceOf ss (go j1) (go j2)) + go (Comment ss com j) = f (Comment ss com (go j)) + go other = f other + +everywhereTopDown :: (AST -> AST) -> AST -> AST +everywhereTopDown f = runIdentity . everywhereTopDownM (Identity . f) + +everywhereTopDownM :: (Monad m) => (AST -> m AST) -> AST -> m AST +everywhereTopDownM f = f >=> go where + f' = f >=> go + go (Unary ss op j) = Unary ss op <$> f' j + go (Binary ss op j1 j2) = Binary ss op <$> f' j1 <*> f' j2 + go (ArrayLiteral ss js) = ArrayLiteral ss <$> traverse f' js + go (Indexer ss j1 j2) = Indexer ss <$> f' j1 <*> f' j2 + go (ObjectLiteral ss js) = ObjectLiteral ss <$> traverse (sndM f') js + go (Function ss name args j) = Function ss name args <$> f' j + go (App ss j js) = App ss <$> f' j <*> traverse f' js + go (Block ss js) = Block ss <$> traverse f' js + go (VariableIntroduction ss name j) = VariableIntroduction ss name <$> traverse f' j + go (Assignment ss j1 j2) = Assignment ss <$> f' j1 <*> f' j2 + go (While ss j1 j2) = While ss <$> f' j1 <*> f' j2 + go (For ss name j1 j2 j3) = For ss name <$> f' j1 <*> f' j2 <*> f' j3 + go (ForIn ss name j1 j2) = ForIn ss name <$> f' j1 <*> f' j2 + go (IfElse ss j1 j2 j3) = IfElse ss <$> f' j1 <*> f' j2 <*> traverse f' j3 + go (Return ss j) = Return ss <$> f' j + go (Throw ss j) = Throw ss <$> f' j + go (InstanceOf ss j1 j2) = InstanceOf ss <$> f' j1 <*> f' j2 + go (Comment ss com j) = Comment ss com <$> f' j + go other = f other + +everything :: (r -> r -> r) -> (AST -> r) -> AST -> r +everything (<>) f = go where + go j@(Unary _ _ j1) = f j <> go j1 + go j@(Binary _ _ j1 j2) = f j <> go j1 <> go j2 + go j@(ArrayLiteral _ js) = foldl (<>) (f j) (map go js) + go j@(Indexer _ j1 j2) = f j <> go j1 <> go j2 + go j@(ObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js) + go j@(Function _ _ _ j1) = f j <> go j1 + go j@(App _ j1 js) = foldl (<>) (f j <> go j1) (map go js) + go j@(Block _ js) = foldl (<>) (f j) (map go js) + go j@(VariableIntroduction _ _ (Just j1)) = f j <> go j1 + go j@(Assignment _ j1 j2) = f j <> go j1 <> go j2 + go j@(While _ j1 j2) = f j <> go j1 <> go j2 + go j@(For _ _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3 + go j@(ForIn _ _ j1 j2) = f j <> go j1 <> go j2 + go j@(IfElse _ j1 j2 Nothing) = f j <> go j1 <> go j2 + go j@(IfElse _ j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3 + go j@(Return _ j1) = f j <> go j1 + go j@(Throw _ j1) = f j <> go j1 + go j@(InstanceOf _ j1 j2) = f j <> go j1 <> go j2 + go j@(Comment _ _ j1) = f j <> go j1 + go other = f other diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs new file mode 100644 index 0000000000..cfdee15ca9 --- /dev/null +++ b/src/Language/PureScript/CoreImp/Optimizer.hs @@ -0,0 +1,60 @@ +-- | This module optimizes code in the simplified-JavaScript intermediate representation. +-- +-- The following optimizations are supported: +-- +-- * Collapsing nested blocks +-- +-- * Tail call elimination +-- +-- * Inlining of (>>=) and ret for the Eff monad +-- +-- * Removal of unnecessary thunks +-- +-- * Eta conversion +-- +-- * Inlining variables +-- +-- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!) +-- +-- * Inlining primitive JavaScript operators +module Language.PureScript.CoreImp.Optimizer (optimize) where + +import Prelude.Compat + +import Control.Monad.Supply.Class (MonadSupply) +import Language.PureScript.CoreImp.AST +import Language.PureScript.CoreImp.Optimizer.Blocks +import Language.PureScript.CoreImp.Optimizer.Common +import Language.PureScript.CoreImp.Optimizer.Inliner +import Language.PureScript.CoreImp.Optimizer.MagicDo +import Language.PureScript.CoreImp.Optimizer.TCO +import Language.PureScript.CoreImp.Optimizer.Unused + +-- | Apply a series of optimizer passes to simplified JavaScript code +optimize :: MonadSupply m => AST -> m AST +optimize js = do + js' <- untilFixedPoint (inlineFnComposition . inlineUnsafePartial . tidyUp . applyAll + [ inlineCommonValues + , inlineCommonOperators + ]) js + untilFixedPoint (return . tidyUp) . tco . magicDo $ js' + where + tidyUp :: AST -> AST + tidyUp = applyAll + [ collapseNestedBlocks + , collapseNestedIfs + , removeCodeAfterReturnStatements + , removeUnusedArg + , removeUndefinedApp + , unThunk + , etaConvert + , evaluateIifes + , inlineVariables + ] + +untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a +untilFixedPoint f = go + where + go a = do + a' <- f a + if a' == a then return a' else go a' diff --git a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs new file mode 100644 index 0000000000..47b2373aaa --- /dev/null +++ b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs @@ -0,0 +1,28 @@ +-- | Optimizer steps for simplifying JavaScript blocks +module Language.PureScript.CoreImp.Optimizer.Blocks + ( collapseNestedBlocks + , collapseNestedIfs + ) where + +import Prelude.Compat + +import Language.PureScript.CoreImp.AST + +-- | Collapse blocks which appear nested directly below another block +collapseNestedBlocks :: AST -> AST +collapseNestedBlocks = everywhere collapse + where + collapse :: AST -> AST + collapse (Block ss sts) = Block ss (concatMap go sts) + collapse js = js + go :: AST -> [AST] + go (Block _ sts) = sts + go s = [s] + +collapseNestedIfs :: AST -> AST +collapseNestedIfs = everywhere collapse + where + collapse :: AST -> AST + collapse (IfElse s1 cond1 (Block _ [IfElse s2 cond2 body Nothing]) Nothing) = + IfElse s1 (Binary s2 And cond1 cond2) body Nothing + collapse js = js diff --git a/src/Language/PureScript/CoreImp/Optimizer/Common.hs b/src/Language/PureScript/CoreImp/Optimizer/Common.hs new file mode 100644 index 0000000000..040995cb36 --- /dev/null +++ b/src/Language/PureScript/CoreImp/Optimizer/Common.hs @@ -0,0 +1,76 @@ +-- | Common functions used by the various optimizer phases +module Language.PureScript.CoreImp.Optimizer.Common where + +import Prelude.Compat + +import Data.Text (Text) +import Data.List (foldl') +import Data.Maybe (fromMaybe) + +import Language.PureScript.Crash +import Language.PureScript.CoreImp.AST +import Language.PureScript.PSString (PSString) + +applyAll :: [a -> a] -> a -> a +applyAll = foldl' (.) id + +replaceIdent :: Text -> AST -> AST -> AST +replaceIdent var1 js = everywhere replace + where + replace (Var _ var2) | var1 == var2 = js + replace other = other + +replaceIdents :: [(Text, AST)] -> AST -> AST +replaceIdents vars = everywhere replace + where + replace v@(Var _ var) = fromMaybe v $ lookup var vars + replace other = other + +isReassigned :: Text -> AST -> Bool +isReassigned var1 = everything (||) check + where + check :: AST -> Bool + check (Function _ _ args _) | var1 `elem` args = True + check (VariableIntroduction _ arg _) | var1 == arg = True + check (Assignment _ (Var _ arg) _) | var1 == arg = True + check (For _ arg _ _ _) | var1 == arg = True + check (ForIn _ arg _ _) | var1 == arg = True + check _ = False + +isRebound :: AST -> AST -> Bool +isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everything (++) variablesOf js) + where + variablesOf (Var _ var) = [var] + variablesOf _ = [] + +isUsed :: Text -> AST -> Bool +isUsed var1 = everything (||) check + where + check :: AST -> Bool + check (Var _ var2) | var1 == var2 = True + check (Assignment _ target _) | var1 == targetVariable target = True + check _ = False + +targetVariable :: AST -> Text +targetVariable (Var _ var) = var +targetVariable (Indexer _ _ tgt) = targetVariable tgt +targetVariable _ = internalError "Invalid argument to targetVariable" + +isUpdated :: Text -> AST -> Bool +isUpdated var1 = everything (||) check + where + check :: AST -> Bool + check (Assignment _ target _) | var1 == targetVariable target = True + check _ = False + +removeFromBlock :: ([AST] -> [AST]) -> AST -> AST +removeFromBlock go (Block ss sts) = Block ss (go sts) +removeFromBlock _ js = js + +isDict :: (Text, PSString) -> AST -> Bool +isDict (moduleName, dictName) (Indexer _ (StringLiteral _ x) (Var _ y)) = + x == dictName && y == moduleName +isDict _ _ = False + +isDict' :: [(Text, PSString)] -> AST -> Bool +isDict' xs js = any (`isDict` js) xs diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs similarity index 63% rename from src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs rename to src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index deea258a2c..0c091e6497 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -1,7 +1,5 @@ --- | --- This module provides basic inlining capabilities --- -module Language.PureScript.CodeGen.JS.Optimizer.Inliner +-- | This module performs basic inlining of known functions +module Language.PureScript.CoreImp.Optimizer.Inliner ( inlineVariables , inlineCommonValues , inlineCommonOperators @@ -23,76 +21,76 @@ import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.PSString (PSString) -import Language.PureScript.CodeGen.JS.AST -import Language.PureScript.CodeGen.JS.Optimizer.Common +import Language.PureScript.CoreImp.AST +import Language.PureScript.CoreImp.Optimizer.Common import qualified Language.PureScript.Constants as C -- TODO: Potential bug: -- Shouldn't just inline this case: { var x = 0; x.toFixed(10); } -- Needs to be: { 0..toFixed(10); } -- Probably needs to be fixed in pretty-printer instead. -shouldInline :: JS -> Bool -shouldInline (JSVar _ _) = True -shouldInline (JSNumericLiteral _ _) = True -shouldInline (JSStringLiteral _ _) = True -shouldInline (JSBooleanLiteral _ _) = True -shouldInline (JSIndexer _ index val) = shouldInline index && shouldInline val +shouldInline :: AST -> Bool +shouldInline (Var _ _) = True +shouldInline (NumericLiteral _ _) = True +shouldInline (StringLiteral _ _) = True +shouldInline (BooleanLiteral _ _) = True +shouldInline (Indexer _ index val) = shouldInline index && shouldInline val shouldInline _ = False -etaConvert :: JS -> JS -etaConvert = everywhereOnJS convert +etaConvert :: AST -> AST +etaConvert = everywhere convert where - convert :: JS -> JS - convert (JSBlock ss [JSReturn _ (JSApp _ (JSFunction _ Nothing idents block@(JSBlock _ body)) args)]) + convert :: AST -> AST + convert (Block ss [Return _ (App _ (Function _ Nothing idents block@(Block _ body)) args)]) | all shouldInline args && - not (any (`isRebound` block) (map (JSVar Nothing) idents)) && + not (any (`isRebound` block) (map (Var Nothing) idents)) && not (any (`isRebound` block) args) - = JSBlock ss (map (replaceIdents (zip idents args)) body) - convert (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ (JSApp _ fn [])])) = fn + = Block ss (map (replaceIdents (zip idents args)) body) + convert (Function _ Nothing [] (Block _ [Return _ (App _ fn [])])) = fn convert js = js -unThunk :: JS -> JS -unThunk = everywhereOnJS convert +unThunk :: AST -> AST +unThunk = everywhere convert where - convert :: JS -> JS - convert (JSBlock ss []) = JSBlock ss [] - convert (JSBlock ss jss) = + convert :: AST -> AST + convert (Block ss []) = Block ss [] + convert (Block ss jss) = case last jss of - JSReturn _ (JSApp _ (JSFunction _ Nothing [] (JSBlock _ body)) []) -> JSBlock ss $ init jss ++ body - _ -> JSBlock ss jss + Return _ (App _ (Function _ Nothing [] (Block _ body)) []) -> Block ss $ init jss ++ body + _ -> Block ss jss convert js = js -evaluateIifes :: JS -> JS -evaluateIifes = everywhereOnJS convert +evaluateIifes :: AST -> AST +evaluateIifes = everywhere convert where - convert :: JS -> JS - convert (JSApp _ (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ ret])) []) = ret - convert (JSApp _ (JSFunction _ Nothing idents (JSBlock _ [JSReturn ss ret])) []) - | not (any (`isReassigned` ret) idents) = replaceIdents (map (, JSVar ss C.undefined) idents) ret + convert :: AST -> AST + convert (App _ (Function _ Nothing [] (Block _ [Return _ ret])) []) = ret + convert (App _ (Function _ Nothing idents (Block _ [Return ss ret])) []) + | not (any (`isReassigned` ret) idents) = replaceIdents (map (, Var ss C.undefined) idents) ret convert js = js -inlineVariables :: JS -> JS -inlineVariables = everywhereOnJS $ removeFromBlock go +inlineVariables :: AST -> AST +inlineVariables = everywhere $ removeFromBlock go where - go :: [JS] -> [JS] + go :: [AST] -> [AST] go [] = [] - go (JSVariableIntroduction _ var (Just js) : sts) + go (VariableIntroduction _ var (Just js) : sts) | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) = go (map (replaceIdent var js) sts) go (s:sts) = s : go sts -inlineCommonValues :: JS -> JS -inlineCommonValues = everywhereOnJS convert +inlineCommonValues :: AST -> AST +inlineCommonValues = everywhere convert where - convert :: JS -> JS - convert (JSApp ss fn [dict]) - | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = JSNumericLiteral ss (Left 0) - | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = JSNumericLiteral ss (Left 1) - | isDict boundedBoolean dict && isDict fnBottom fn = JSBooleanLiteral ss False - | isDict boundedBoolean dict && isDict fnTop fn = JSBooleanLiteral ss True - convert (JSApp ss (JSApp _ fn [dict]) [x]) - | isDict ringInt dict && isDict fnNegate fn = JSBinary ss BitwiseOr (JSUnary ss Negate x) (JSNumericLiteral ss (Left 0)) - convert (JSApp ss (JSApp _ (JSApp _ fn [dict]) [x]) [y]) + convert :: AST -> AST + convert (App ss fn [dict]) + | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0) + | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1) + | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False + | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True + convert (App ss (App _ fn [dict]) [x]) + | isDict ringInt dict && isDict fnNegate fn = Binary ss BitwiseOr (Unary ss Negate x) (NumericLiteral ss (Left 0)) + convert (App ss (App _ (App _ fn [dict]) [x]) [y]) | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add x y | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply x y | isDict euclideanRingInt dict && isDict fnDivide fn = intOp ss Divide x y @@ -107,10 +105,10 @@ inlineCommonValues = everywhereOnJS convert fnMultiply = (C.dataSemiring, C.mul) fnSubtract = (C.dataRing, C.sub) fnNegate = (C.dataRing, C.negate) - intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0)) + intOp ss op x y = Binary ss BitwiseOr (Binary ss op x y) (NumericLiteral ss (Left 0)) -inlineCommonOperators :: JS -> JS -inlineCommonOperators = everywhereOnJSTopDown $ applyAll $ +inlineCommonOperators :: AST -> AST +inlineCommonOperators = everywhereTopDown $ applyAll $ [ binary semiringNumber opAdd Add , binary semiringNumber opMul Multiply @@ -166,114 +164,114 @@ inlineCommonOperators = everywhereOnJSTopDown $ applyAll $ , binary' C.dataIntBits C.zshr ZeroFillShiftRight , unary' C.dataIntBits C.complement BitwiseNot - , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> JSApp Nothing f [x] - , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> JSApp Nothing f [x] - , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (JSIndexer Nothing) + , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x] + , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x] + , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing) ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] where - binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> JS -> JS + binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST binary dict fns op = convert where - convert :: JS -> JS - convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = JSBinary ss op x y + convert :: AST -> AST + convert (App ss (App _ (App _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = Binary ss op x y convert other = other - binary' :: Text -> PSString -> BinaryOperator -> JS -> JS + binary' :: Text -> PSString -> BinaryOperator -> AST -> AST binary' moduleName opString op = convert where - convert :: JS -> JS - convert (JSApp ss (JSApp _ fn [x]) [y]) | isDict (moduleName, opString) fn = JSBinary ss op x y + convert :: AST -> AST + convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op x y convert other = other - unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> JS -> JS + unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST unary dicts fns op = convert where - convert :: JS -> JS - convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = JSUnary ss op x + convert :: AST -> AST + convert (App ss (App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op x convert other = other - unary' :: Text -> PSString -> UnaryOperator -> JS -> JS + unary' :: Text -> PSString -> UnaryOperator -> AST -> AST unary' moduleName fnName op = convert where - convert :: JS -> JS - convert (JSApp ss fn [x]) | isDict (moduleName, fnName) fn = JSUnary ss op x + convert :: AST -> AST + convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op x convert other = other - mkFn :: Int -> JS -> JS + mkFn :: Int -> AST -> AST mkFn 0 = convert where - convert :: JS -> JS - convert (JSApp _ mkFnN [JSFunction s1 Nothing [_] (JSBlock s2 js)]) | isNFn C.mkFn 0 mkFnN = - JSFunction s1 Nothing [] (JSBlock s2 js) + convert :: AST -> AST + convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 js)]) | isNFn C.mkFn 0 mkFnN = + Function s1 Nothing [] (Block s2 js) convert other = other mkFn n = convert where - convert :: JS -> JS - convert orig@(JSApp ss mkFnN [fn]) | isNFn C.mkFn n mkFnN = + convert :: AST -> AST + convert orig@(App ss mkFnN [fn]) | isNFn C.mkFn n mkFnN = case collectArgs n [] fn of - Just (args, js) -> JSFunction ss Nothing args (JSBlock ss js) + Just (args, js) -> Function ss Nothing args (Block ss js) Nothing -> orig convert other = other - collectArgs :: Int -> [Text] -> JS -> Maybe ([Text], [JS]) - collectArgs 1 acc (JSFunction _ Nothing [oneArg] (JSBlock _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js) - collectArgs m acc (JSFunction _ Nothing [oneArg] (JSBlock _ [JSReturn _ ret])) = collectArgs (m - 1) (oneArg : acc) ret + collectArgs :: Int -> [Text] -> AST -> Maybe ([Text], [AST]) + collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js) + collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret collectArgs _ _ _ = Nothing - isNFn :: Text -> Int -> JS -> Bool - isNFn prefix n (JSVar _ name) = name == (prefix <> T.pack (show n)) - isNFn prefix n (JSIndexer _ (JSStringLiteral _ name) (JSVar _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = + isNFn :: Text -> Int -> AST -> Bool + isNFn prefix n (Var _ name) = name == (prefix <> T.pack (show n)) + isNFn prefix n (Indexer _ (StringLiteral _ name) (Var _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = name == fromString (T.unpack prefix <> show n) isNFn _ _ _ = False - runFn :: Int -> JS -> JS + runFn :: Int -> AST -> AST runFn n = convert where - convert :: JS -> JS + convert :: AST -> AST convert js = fromMaybe js $ go n [] js - go :: Int -> [JS] -> JS -> Maybe JS - go 0 acc (JSApp ss runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp ss fn acc) - go m acc (JSApp _ lhs [arg]) = go (m - 1) (arg : acc) lhs + go :: Int -> [AST] -> AST -> Maybe AST + go 0 acc (App ss runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (App ss fn acc) + go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs go _ _ _ = Nothing - inlineNonClassFunction :: (JS -> Bool) -> (JS -> JS -> JS) -> JS -> JS + inlineNonClassFunction :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST inlineNonClassFunction p f = convert where - convert :: JS -> JS - convert (JSApp _ (JSApp _ op' [x]) [y]) | p op' = f x y + convert :: AST -> AST + convert (App _ (App _ op' [x]) [y]) | p op' = f x y convert other = other - isModFn :: (Text, PSString) -> JS -> Bool - isModFn (m, op) (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) = + isModFn :: (Text, PSString) -> AST -> Bool + isModFn (m, op) (Indexer _ (StringLiteral _ op') (Var _ m')) = m == m' && op == op' isModFn _ _ = False - isModFnWithDict :: (Text, PSString) -> JS -> Bool - isModFnWithDict (m, op) (JSApp _ (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) [JSVar _ _]) = + isModFnWithDict :: (Text, PSString) -> AST -> Bool + isModFnWithDict (m, op) (App _ (Indexer _ (StringLiteral _ op') (Var _ m')) [Var _ _]) = m == m' && op == op' isModFnWithDict _ _ = False -- (f <<< g $ x) = f (g x) -- (f <<< g) = \x -> f (g x) -inlineFnComposition :: forall m. MonadSupply m => JS -> m JS -inlineFnComposition = everywhereOnJSTopDownM convert where - convert :: JS -> m JS - convert (JSApp s1 (JSApp s2 (JSApp _ (JSApp _ fn [dict']) [x]) [y]) [z]) - | isFnCompose dict' fn = return $ JSApp s1 x [JSApp s2 y [z]] - | isFnComposeFlipped dict' fn = return $ JSApp s2 y [JSApp s1 x [z]] - convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) +inlineFnComposition :: forall m. MonadSupply m => AST -> m AST +inlineFnComposition = everywhereTopDownM convert where + convert :: AST -> m AST + convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z]) + | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]] + | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]] + convert (App ss (App _ (App _ fn [dict']) [x]) [y]) | isFnCompose dict' fn = do arg <- freshName - return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing x [JSApp Nothing y [JSVar Nothing arg]]]) + return $ Function ss Nothing [arg] (Block ss [Return Nothing $ App Nothing x [App Nothing y [Var Nothing arg]]]) | isFnComposeFlipped dict' fn = do arg <- freshName - return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing y [JSApp Nothing x [JSVar Nothing arg]]]) + return $ Function ss Nothing [arg] (Block ss [Return Nothing $ App Nothing y [App Nothing x [Var Nothing arg]]]) convert other = return other - isFnCompose :: JS -> JS -> Bool + isFnCompose :: AST -> AST -> Bool isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn - isFnComposeFlipped :: JS -> JS -> Bool + isFnComposeFlipped :: AST -> AST -> Bool isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn fnCompose :: forall a b. (IsString a, IsString b) => (a, b) fnCompose = (C.controlSemigroupoid, C.compose) fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b) fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped) -inlineUnsafePartial :: JS -> JS -inlineUnsafePartial = everywhereOnJSTopDown convert where - convert (JSApp ss (JSIndexer _ (JSStringLiteral _ unsafePartial) (JSVar _ partialUnsafe)) [ comp ]) +inlineUnsafePartial :: AST -> AST +inlineUnsafePartial = everywhereTopDown convert where + convert (App ss (Indexer _ (StringLiteral _ unsafePartial) (Var _ partialUnsafe)) [ comp ]) | unsafePartial == C.unsafePartial && partialUnsafe == C.partialUnsafe -- Apply to undefined here, the application should be optimized away -- if it is safe to do so - = JSApp ss comp [ JSVar ss C.undefined ] + = App ss comp [ Var ss C.undefined ] convert other = other semiringNumber :: forall a b. (IsString a, IsString b) => (a, b) diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs new file mode 100644 index 0000000000..cf03f41056 --- /dev/null +++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs @@ -0,0 +1,134 @@ +-- | This module implements the "Magic Do" optimization, which inlines calls to return +-- and bind for the Eff monad, as well as some of its actions. +module Language.PureScript.CoreImp.Optimizer.MagicDo (magicDo) where + +import Prelude.Compat +import Protolude (ordNub) + +import Data.Maybe (fromJust, isJust) + +import Language.PureScript.CoreImp.AST +import Language.PureScript.CoreImp.Optimizer.Common +import Language.PureScript.PSString (mkString) +import qualified Language.PureScript.Constants as C + +-- | Inline type class dictionaries for >>= and return for the Eff monad +-- +-- E.g. +-- +-- Prelude[">>="](dict)(m1)(function(x) { +-- return ...; +-- }) +-- +-- becomes +-- +-- function __do { +-- var x = m1(); +-- ... +-- } +magicDo :: AST -> AST +magicDo = inlineST . everywhere undo . everywhereTopDown convert + where + -- The name of the function block which is added to denote a do block + fnName = "__do" + -- Desugar monomorphic calls to >>= and return for the Eff monad + convert :: AST -> AST + -- Desugar pure + convert (App _ (App _ pure' [val]) []) | isPure pure' = val + -- Desugar discard + convert (App _ (App _ bind [m]) [Function s1 Nothing [] (Block s2 js)]) | isDiscard bind = + Function s1 (Just fnName) [] $ Block s2 (App s2 m [] : map applyReturns js ) + -- Desugar bind + convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 js)]) | isBind bind = + Function s1 (Just fnName) [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns js) + -- Desugar untilE + convert (App s1 (App _ f [arg]) []) | isEffFunc C.untilE f = + App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) [] + -- Desugar whileE + convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc C.whileE f = + App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) [] + convert other = other + -- Check if an expression represents a monomorphic call to >>= for the Eff monad + isBind (App _ fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True + isBind _ = False + -- Check if an expression represents a call to @discard@ + isDiscard (App _ (App _ fn [dict1]) [dict2]) + | isDict (C.controlBind, C.discardUnitDictionary) dict1 && + isDict (C.eff, C.bindEffDictionary) dict2 && + isDiscardPoly fn = True + isDiscard _ = False + -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative + isPure (App _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True + isPure _ = False + -- Check if an expression represents the polymorphic >>= function + isBindPoly = isDict (C.controlBind, C.bind) + -- Check if an expression represents the polymorphic pure function + isPurePoly = isDict (C.controlApplicative, C.pure') + -- Check if an expression represents the polymorphic discard function + isDiscardPoly = isDict (C.controlBind, C.discard) + -- Check if an expression represents a function in the Eff module + isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == C.eff && name == name' + isEffFunc _ _ = False + + -- Remove __do function applications which remain after desugaring + undo :: AST -> AST + undo (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body + undo other = other + + applyReturns :: AST -> AST + applyReturns (Return ss ret) = Return ss (App ss ret []) + applyReturns (Block ss jss) = Block ss (map applyReturns jss) + applyReturns (While ss cond js) = While ss cond (applyReturns js) + applyReturns (For ss v lo hi js) = For ss v lo hi (applyReturns js) + applyReturns (ForIn ss v xs js) = ForIn ss v xs (applyReturns js) + applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f) + applyReturns other = other + +-- | Inline functions in the ST module +inlineST :: AST -> AST +inlineST = everywhere convertBlock + where + -- Look for runST blocks and inline the STRefs there. + -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then + -- we can be more aggressive about inlining, and actually turn STRefs into local variables. + convertBlock (App _ f [arg]) | isSTFunc C.runST f = + let refs = ordNub . findSTRefsIn $ arg + usages = findAllSTUsagesIn arg + allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages + localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs + in everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg + convertBlock other = other + -- 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 (App s1 f [arg]) | isSTFunc C.newSTRef f = + Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]]) + convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f = + if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref + convert agg (App _ (App _ (App s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f = + if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg + convert agg (App _ (App _ (App s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f = + if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref]) + convert _ other = other + -- Check if an expression represents a function in the ST module + isSTFunc name (Indexer _ (StringLiteral _ name') (Var _ st)) = st == C.st && name == name' + isSTFunc _ _ = False + -- Find all ST Refs initialized in this block + findSTRefsIn = everything (++) isSTRef + where + isSTRef (VariableIntroduction _ ident (Just (App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident] + isSTRef _ = [] + -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef + findAllSTUsagesIn = everything (++) isSTUsage + where + isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref] + isSTUsage (App _ (App _ (App _ f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref] + isSTUsage _ = [] + -- Find all uses of a variable + appearingIn ref = everything (++) isVar + where + isVar e@(Var _ v) | v == ref = [e] + isVar _ = [] + -- Convert a AST value to a String if it is a Var + toVar (Var _ v) = Just v + toVar _ = Nothing diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs new file mode 100644 index 0000000000..25b6a5d12d --- /dev/null +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -0,0 +1,121 @@ +-- | This module implements tail call elimination. +module Language.PureScript.CoreImp.Optimizer.TCO (tco) where + +import Prelude.Compat + +import Data.Text (Text) +import Data.Monoid ((<>)) +import Language.PureScript.CoreImp.AST +import Language.PureScript.AST.SourcePos (SourceSpan) + +-- | Eliminate tail calls +tco :: AST -> AST +tco = everywhere convert where + tcoVar :: Text -> Text + tcoVar arg = "__tco_" <> arg + + copyVar :: Text -> Text + copyVar arg = "__copy_" <> arg + + tcoDone :: Text + tcoDone = tcoVar "done" + + tcoLoop :: Text + tcoLoop = tcoVar "loop" + + tcoResult :: Text + tcoResult = tcoVar "result" + + convert :: AST -> AST + convert (VariableIntroduction ss name (Just fn@Function {})) + | isTailRecursive name body' + = VariableIntroduction ss name (Just (replace (toLoop name allArgs body'))) + where + (argss, body', replace) = collectAllFunctionArgs [] id fn + allArgs = concat $ reverse argss + convert js = js + + collectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST) + collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 (body@(Return _ _):_))) = + collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (map copyVar args) (Block s2 [b]))) body + collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _)) = + (args : allArgs, body, f . Function ss ident (map copyVar args)) + collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 [body]))) = + collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (map copyVar args) (Block s3 [b])))) body + collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _))) = + (args : allArgs, body, f . Return s1 . Function s2 ident (map copyVar args)) + collectAllFunctionArgs allArgs f body = (allArgs, body, f) + + isTailRecursive :: Text -> AST -> Bool + isTailRecursive ident js = countSelfReferences js > 0 && allInTailPosition js where + countSelfReferences = everything (+) match where + match :: AST -> Int + match (Var _ ident') | ident == ident' = 1 + match _ = 0 + + allInTailPosition (Return _ expr) + | isSelfCall ident expr = countSelfReferences expr == 1 + | otherwise = countSelfReferences expr == 0 + allInTailPosition (While _ js1 body) + = countSelfReferences js1 == 0 && allInTailPosition body + allInTailPosition (For _ _ js1 js2 body) + = countSelfReferences js1 == 0 && countSelfReferences js2 == 0 && allInTailPosition body + allInTailPosition (ForIn _ _ js1 body) + = countSelfReferences js1 == 0 && allInTailPosition body + allInTailPosition (IfElse _ js1 body el) + = countSelfReferences js1 == 0 && allInTailPosition body && all allInTailPosition el + allInTailPosition (Block _ body) + = all allInTailPosition body + allInTailPosition _ + = False + + toLoop :: Text -> [Text] -> AST -> AST + toLoop ident allArgs js = + Block rootSS $ + map (\arg -> VariableIntroduction rootSS arg (Just (Var rootSS (copyVar arg)))) allArgs ++ + [ VariableIntroduction rootSS tcoDone (Just (BooleanLiteral rootSS False)) + , VariableIntroduction rootSS tcoResult Nothing + ] ++ + map (\arg -> + VariableIntroduction rootSS (tcoVar arg) Nothing) allArgs ++ + [ Function rootSS (Just tcoLoop) allArgs (Block rootSS [loopify js]) + , While rootSS (Unary rootSS Not (Var rootSS tcoDone)) + (Block rootSS + (Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) (map (Var rootSS) allArgs)) + : map (\arg -> + Assignment rootSS (Var rootSS arg) (Var rootSS (tcoVar arg))) allArgs)) + , Return rootSS (Var rootSS tcoResult) + ] + where + rootSS = Nothing + + loopify :: AST -> AST + loopify (Return ss ret) + | isSelfCall ident ret = + let + allArgumentValues = concat $ collectArgs [] ret + in + Block ss $ + zipWith (\val arg -> + Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues allArgs + ++ [ ReturnNoResult ss ] + | otherwise = Block ss [ markDone ss, Return ss ret ] + loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ] + loopify (While ss cond body) = While ss cond (loopify body) + loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body) + loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body) + loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el) + loopify (Block ss body) = Block ss (map loopify body) + loopify other = other + + markDone :: Maybe SourceSpan -> AST + markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True) + + collectArgs :: [[AST]] -> AST -> [[AST]] + collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn + collectArgs acc _ = acc + + isSelfCall :: Text -> AST -> Bool + isSelfCall ident (App _ (Var _ ident') _) = ident == ident' + isSelfCall ident (App _ fn _) = isSelfCall ident fn + isSelfCall _ _ = False diff --git a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs new file mode 100644 index 0000000000..ff05c64677 --- /dev/null +++ b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs @@ -0,0 +1,34 @@ +-- | Removes unused variables +module Language.PureScript.CoreImp.Optimizer.Unused + ( removeCodeAfterReturnStatements + , removeUnusedArg + , removeUndefinedApp + ) where + +import Prelude.Compat + +import Language.PureScript.CoreImp.AST +import Language.PureScript.CoreImp.Optimizer.Common +import qualified Language.PureScript.Constants as C + +removeCodeAfterReturnStatements :: AST -> AST +removeCodeAfterReturnStatements = everywhere (removeFromBlock go) + where + go :: [AST] -> [AST] + go jss | not (any isReturn jss) = jss + | otherwise = let (body, ret : _) = break isReturn jss in body ++ [ret] + isReturn (Return _ _) = True + isReturn (ReturnNoResult _) = True + isReturn _ = False + +removeUnusedArg :: AST -> AST +removeUnusedArg = everywhere convert + where + convert (Function ss name [arg] body) | arg == C.__unused = Function ss name [] body + convert js = js + +removeUndefinedApp :: AST -> AST +removeUndefinedApp = everywhere convert + where + convert (App ss fn [Var _ arg]) | arg == C.undefined = App ss fn [] + convert js = js diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index d995c6be0a..b385f7a002 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -60,17 +60,18 @@ import Language.PureScript.Linter import Language.PureScript.ModuleDependencies import Language.PureScript.Names import Language.PureScript.Options -import Language.PureScript.Pretty -import Language.PureScript.Pretty.Common(SMap(..)) +import Language.PureScript.Pretty.Common (SMap(..)) import Language.PureScript.Renamer import Language.PureScript.Sugar import Language.PureScript.TypeChecker import qualified Language.JavaScript.Parser as JS import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.CodeGen.JS as J +import Language.PureScript.CodeGen.JS.Printer import qualified Language.PureScript.Constants as C import qualified Language.PureScript.CoreFn as CF import qualified Language.PureScript.CoreFn.ToJSON as CFJ +import qualified Language.PureScript.CoreImp.AST as Imp import qualified Language.PureScript.Parser as PSParser import qualified Paths_purescript as Paths import SourceMap @@ -351,7 +352,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = return Nothing | otherwise -> do checkForeignDecls m path - return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"] + return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign"] Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn | otherwise -> return Nothing rawJs <- J.moduleToJs m foreignInclude diff --git a/src/Language/PureScript/Pretty.hs b/src/Language/PureScript/Pretty.hs index e9affc14d4..b993595121 100644 --- a/src/Language/PureScript/Pretty.hs +++ b/src/Language/PureScript/Pretty.hs @@ -1,17 +1,12 @@ --- | --- A collection of pretty printers for core data types: +-- | A collection of pretty printers for core data types: -- --- [@Language.PureScript.Pretty.Kinds@] Pretty printer for kinds +-- * [@Language.PureScript.Pretty.Kinds@] Pretty printer for kinds -- --- [@Language.PureScript.Pretty.Values@] Pretty printer for values --- --- [@Language.PureScript.Pretty.Types@] Pretty printer for types --- --- [@Language.PureScript.Pretty.JS@] Pretty printer for values, used for code generation +-- * [@Language.PureScript.Pretty.Values@] Pretty printer for values -- +-- * [@Language.PureScript.Pretty.Types@] Pretty printer for types module Language.PureScript.Pretty (module P) where -import Language.PureScript.Pretty.JS as P import Language.PureScript.Pretty.Kinds as P import Language.PureScript.Pretty.Types as P import Language.PureScript.Pretty.Values as P From 3a02726618c5390cc967a5533067ce5a7e6304d8 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 12 Mar 2017 17:14:44 -0700 Subject: [PATCH 0711/1580] Add back .psci file support (#2735) * Add back .psci file support * Restrict .psci to import statements * Only warn * Use .purs-repl --- app/Command/REPL.hs | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index afec98e24c..86986070a7 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -30,6 +30,7 @@ import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.State.Strict (StateT, evalStateT) import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Data.FileEmbed (embedStringFile) +import Data.Foldable (for_) import Data.Monoid ((<>)) import Data.String (IsString(..)) import Data.Text (Text, unpack) @@ -48,6 +49,7 @@ import qualified Options.Applicative as Opts import System.Console.Haskeline import System.IO.UTF8 (readUTF8File) import System.Exit +import System.Directory (doesFileExist, getCurrentDirectory) import System.FilePath (()) import System.FilePath.Glob (glob) import System.Process (readProcessWithExitCode) @@ -331,6 +333,9 @@ command = loop <$> options . flip evalStateT initialState . runInputT (setComplete completion settings) + handleCommand' :: state -> Command -> StateT PSCiState (ReaderT PSCiConfig IO) () + handleCommand' state = handleCommand (liftIO . eval state) (liftIO (reload state)) + go :: state -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) () go state = do c <- getCommand @@ -347,14 +352,28 @@ command = loop <$> options liftIO $ shutdown state Right (Just c') -> handleCommandWithInterrupts state c' + loadUserConfig :: state -> StateT PSCiState (ReaderT PSCiConfig IO) () + loadUserConfig state = do + configFile <- ( ".purs-repl") <$> liftIO getCurrentDirectory + exists <- liftIO $ doesFileExist configFile + when exists $ do + ls <- lines <$> liftIO (readUTF8File configFile) + for_ ls $ \l -> do + liftIO (putStrLn l) + case parseCommand l of + Left err -> liftIO (putStrLn err >> exitFailure) + Right cmd@Import{} -> handleCommand' state cmd + Right _ -> liftIO (putStrLn "The .purs-repl file only supports import declarations") + handleCommandWithInterrupts :: state -> Command -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) () handleCommandWithInterrupts state cmd = do handleInterrupt (outputStrLn "Interrupted.") - (withInterrupt (lift (handleCommand (liftIO . eval state) (liftIO (reload state)) cmd))) + (withInterrupt (lift (handleCommand' state cmd))) go state putStrLn prologueMessage - setup >>= runner . go + backendState <- setup + runner (lift (loadUserConfig backendState) >> go backendState) From 0b14d24166fb48d23a9cd1fd96ee0db59e3c5263 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 13 Mar 2017 15:52:05 +0100 Subject: [PATCH 0712/1580] [purs ide] improve import parsing (#2725) * [psc-ide] Uses the actual parser to find the import section --- src/Language/PureScript/Ide/Imports.hs | 124 ++++++++---------- .../PureScript/Parser/Declarations.hs | 18 ++- src/Language/PureScript/Parser/Lexer.hs | 9 ++ tests/Language/PureScript/Ide/ImportsSpec.hs | 39 ++++++ 4 files changed, 114 insertions(+), 76 deletions(-) diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 21158d8c31..f91f865b00 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -29,7 +29,7 @@ module Language.PureScript.Ide.Imports import Protolude -import Control.Lens ((^.)) +import Control.Lens ((^.), (%~), ix) import Data.List (findIndex, nubBy) import qualified Data.Text as T import qualified Language.PureScript as P @@ -40,6 +40,7 @@ import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import System.IO.UTF8 (writeUTF8FileT) +import qualified Text.Parsec as Parsec data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) deriving (Eq, Show) @@ -75,76 +76,57 @@ parseImportsFromFile fp = do Right res -> pure res Left err -> throwError (GeneralError err) -parseImportsWithModuleName :: [Text] -> Either Text (P.ModuleName, [Import]) -parseImportsWithModuleName ls = do - (P.Module _ _ mn decls _) <- moduleParse ls - pure (mn, concatMap mkImport (unwrapPositioned <$> decls)) +-- | @ImportParse@ holds the data we extract out of a partial parse of the +-- sourcefile +data ImportParse = ImportParse + { ipModuleName :: P.ModuleName + -- ^ the module name we parse + , ipStart :: P.SourcePos + -- ^ the beginning of the import section. If `import Prelude` was the first + -- import, this would point at `i` + , ipEnd :: P.SourcePos + -- ^ the end of the import section + , ipImports :: [Import] + -- ^ the extracted import declarations + } + +parseModuleHeader :: P.TokenParser ImportParse +parseModuleHeader = do + _ <- P.readComments + (mn, _) <- P.parseModuleDeclaration + (ipStart, ipEnd, decls) <- P.withSourceSpan (\(P.SourceSpan _ start end) _ -> (start, end,)) + (P.mark (Parsec.many (P.same *> P.parseImportDeclaration'))) + pure (ImportParse mn ipStart ipEnd (map mkImport decls)) where - mkImport (P.ImportDeclaration mn (P.Explicit refs) qual) = - [Import mn (P.Explicit (unwrapPositionedRef <$> refs)) qual] - mkImport (P.ImportDeclaration mn it qual) = [Import mn it qual] - mkImport _ = [] + mkImport (mn, (P.Explicit refs), qual) = Import mn (P.Explicit (unwrapPositionedRef <$> refs)) qual + mkImport (mn, it, qual) = Import mn it qual sliceImportSection :: [Text] -> Either Text (P.ModuleName, [Text], [Import], [Text]) -sliceImportSection ts = - case foldl step (ModuleHeader 0) (zip [0..] ts) of - Res start end -> - let - (moduleHeader, (importSection, remainingFile)) = - splitAt (succ (end - start)) `second` splitAt start ts - in - (\(mn, is) -> (mn, moduleHeader, is, remainingFile)) <$> - parseImportsWithModuleName (moduleHeader <> importSection) - - -- If we don't find any imports, we insert a newline after the module - -- declaration and begin a new importsection - ModuleHeader ix -> - let (moduleHeader, remainingFile) = splitAt (succ ix) ts - in - (\(mn, is) -> (mn, moduleHeader ++ [""], is, remainingFile)) <$> - parseImportsWithModuleName moduleHeader - _ -> Left "Failed to detect the import section" - -data ImportStateMachine = ModuleHeader Int | ImportSection Int Int | Res Int Int - --- | We start in the --- --- * ModuleHeader state. --- --- We skip every line we encounter, that doesn't start with "import". If we find --- a line that starts with module we store that linenumber. Once we find a line --- with "import" we store its linenumber as the start of the import section and --- change into the --- --- * ImportSection state --- --- For any line that starts with import or whitespace(is thus indented) we --- expand the end of the import section to that line and continue. If we --- encounter a commented or empty line, we continue moving forward in the --- ImportSection state but don't expand the import section end yet. This allows --- us to exclude newlines or comments that directly follow the import section. --- Once we encounter a line that is not a comment, newline, indentation or --- import we switch into the --- --- * Res state --- --- , which just shortcuts to the end of the file and carries the detected import --- section boundaries -step :: ImportStateMachine -> (Int, Text) -> ImportStateMachine -step (ModuleHeader mi) (ix, l) - | T.isPrefixOf "module " l = ModuleHeader ix - | T.isPrefixOf "import " l = ImportSection ix ix - | otherwise = ModuleHeader mi -step (ImportSection start lastImportLine) (ix, l) - | any (`T.isPrefixOf` l) ["import", " "] = ImportSection start ix - | T.isPrefixOf "--" l || l == "" = ImportSection start lastImportLine - | otherwise = Res start lastImportLine -step (Res start end) _ = Res start end - -moduleParse :: [Text] -> Either Text P.Module -moduleParse t = first show $ do - tokens <- P.lex "" (T.unlines t) - P.runTokenParser "" P.parseModule tokens +sliceImportSection fileLines = first show $ do + tokens <- P.lexLenient "" file + ImportParse{..} <- P.runTokenParser "" parseModuleHeader tokens + pure ( ipModuleName + , sliceFile (P.SourcePos 1 1) (prevPos ipStart) + , ipImports + -- Not sure why I need to drop 1 here, but it makes the tests pass + , drop 1 (sliceFile (nextPos ipEnd) (P.SourcePos (length fileLines) (lineLength (length fileLines)))) + ) + where + prevPos (P.SourcePos l c) + | l == 1 && c == 1 = P.SourcePos l c + | c == 1 = P.SourcePos (l - 1) (lineLength (l - 1)) + | otherwise = P.SourcePos l (c - 1) + nextPos (P.SourcePos l c) + | c == lineLength l = P.SourcePos (l + 1) 1 + | otherwise = P.SourcePos l (c + 1) + file = T.unlines fileLines + lineLength l = T.length (fileLines ^. ix (l - 1)) + sliceFile (P.SourcePos l1 c1) (P.SourcePos l2 c2) = + fileLines + & drop (l1 - 1) + & take (l2 - l1 + 1) + & ix 0 %~ T.drop (c1 - 1) + & ix (l2 - l1) %~ T.take c2 -- | Adds an implicit import like @import Prelude@ to a Sourcefile. addImplicitImport :: (MonadIO m, MonadError IdeError m) @@ -154,7 +136,7 @@ addImplicitImport :: (MonadIO m, MonadError IdeError m) addImplicitImport fp mn = do (_, pre, imports, post) <- parseImportsFromFile fp let newImportSection = addImplicitImport' imports mn - pure $ pre ++ newImportSection ++ post + pure (pre ++ newImportSection ++ post) addImplicitImport' :: [Import] -> P.ModuleName -> [Text] addImplicitImport' imports mn = @@ -237,8 +219,8 @@ updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a] updateAtFirstOrPrepend p t d l = case findIndex p l of Nothing -> d : l - Just ix -> - let (x, a : y) = splitAt ix l + Just i -> + let (x, a : y) = splitAt i l in x ++ [t a] ++ y -- | Looks up the given identifier in the currently loaded modules. diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index ae2a09f760..96178af114 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -1,7 +1,9 @@ -- | Parsers for module definitions and declarations module Language.PureScript.Parser.Declarations ( parseDeclaration + , parseDeclarationRef , parseModule + , parseModuleDeclaration , parseModulesFromFiles , parseModuleFromFile , parseValue @@ -247,16 +249,22 @@ parseLocalDeclaration = positioned (P.choice , parseLocalValueDeclaration ] P. "local declaration") --- | Parse a module header and a collection of declarations -parseModule :: TokenParser Module -parseModule = do - comments <- readComments - start <- P.getPosition +-- | Parse a module declaration and its export declarations +parseModuleDeclaration :: TokenParser (ModuleName, Maybe [DeclarationRef]) +parseModuleDeclaration = do reserved "module" indented name <- moduleName exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef reserved "where" + pure (name, exports) + +-- | Parse a module header and a collection of declarations +parseModule :: TokenParser Module +parseModule = do + comments <- readComments + start <- P.getPosition + (name, exports) <- parseModuleDeclaration decls <- mark $ do -- TODO: extract a module header structure here, and provide a -- parseModuleHeader function. This should allow us to speed up rebuilds diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 744519cb39..9b62cc2c0e 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -6,6 +6,7 @@ module Language.PureScript.Parser.Lexer , Token() , TokenParser() , lex + , lexLenient , anyToken , token , match @@ -173,6 +174,14 @@ updatePositions (x:xs) = x : zipWith update (x:xs) xs parseTokens :: Lexer u [PositionedToken] parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof +-- | Lexes the given file, and on encountering a parse error, returns the +-- progress made up to that point, instead of returning an error +lexLenient :: FilePath -> Text -> Either P.ParseError [PositionedToken] +lexLenient f s = updatePositions <$> P.parse parseTokensLenient f s + +parseTokensLenient :: Lexer u [PositionedToken] +parseTokensLenient = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment + whitespace :: Lexer u () whitespace = P.skipMany (P.satisfy isSpace) diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index ce90f9372a..b4aabeb857 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -14,6 +14,13 @@ import Language.PureScript.Ide.Types import System.FilePath import Test.Hspec +noImportsFile :: [Text] +noImportsFile = + [ "module Main where" + , "" + , "myFunc x y = x + y" + ] + simpleFile :: [Text] simpleFile = [ "module Main where" @@ -22,6 +29,14 @@ simpleFile = , "myFunc x y = x + y" ] +syntaxErrorFile :: [Text] +syntaxErrorFile = + [ "module Main where" + , "import Prelude" + , "" + , "myFunc =" + ] + splitSimpleFile :: (P.ModuleName, [Text], [Import], [Text]) splitSimpleFile = fromRight (sliceImportSection simpleFile) where @@ -49,6 +64,14 @@ spec = do describe "determining the importsection" $ do let moduleSkeleton imports = Right (P.moduleNameFromString "Main", take 1 simpleFile, imports, drop 2 simpleFile) + it "slices a file without imports and adds a newline after the module declaration" $ + shouldBe (sliceImportSection noImportsFile) + (Right (P.moduleNameFromString "Main", take 1 noImportsFile ++ [""], [], drop 1 noImportsFile)) + + it "handles a file with syntax errors just fine" $ + shouldBe (sliceImportSection syntaxErrorFile) + (Right (P.moduleNameFromString "Main", take 1 syntaxErrorFile, [preludeImport], drop 2 syntaxErrorFile)) + it "finds a simple import" $ shouldBe (sliceImportSection simpleFile) (moduleSkeleton [preludeImport]) @@ -58,6 +81,14 @@ spec = do , " cons)" ])) (moduleSkeleton [preludeImport, arrayImport]) + it "allows multiline import statements with hanging parens" $ + shouldBe + (sliceImportSection (withImports [ "import Data.Array (" + , " head," + , " cons" + , ")" + ])) + (moduleSkeleton [preludeImport, arrayImport]) describe "pretty printing imports" $ do it "pretty prints a simple import" $ shouldBe (prettyPrintImport' preludeImport) "import Prelude" @@ -80,12 +111,20 @@ spec = do prettyPrintImportSection (addExplicitImport' (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName i) t wildcard)) mn is) addTypeImport i mn is = prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.kindType)) mn is) + it "adds an implicit unqualified import to a file without any imports" $ + shouldBe + (addImplicitImport' [] (P.moduleNameFromString "Data.Map")) + ["import Data.Map"] it "adds an implicit unqualified import" $ shouldBe (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map")) [ "import Prelude" , "import Data.Map" ] + it "adds an explicit unqualified import to a file without any imports" $ + shouldBe + (addValueImport "head" (P.moduleNameFromString "Data.Array") []) + ["import Data.Array (head)"] it "adds an explicit unqualified import" $ shouldBe (addValueImport "head" (P.moduleNameFromString "Data.Array") simpleFileImports) From f04a079eb7bddbd6a0855a83f8f4d7471decd164 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 13 Mar 2017 09:19:56 -0700 Subject: [PATCH 0713/1580] Improve errors for bind/discard (#2736) * Improve errors for bind/discard #2732 * Add PositionedDoNotationElement and fix a type checker error bug * Remove debugging code --- src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/Parser/Declarations.hs | 2 +- src/Language/PureScript/Sugar/DoNotation.hs | 1 - src/Language/PureScript/TypeChecker/Monad.hs | 5 +++++ src/Language/PureScript/TypeChecker/Subsumption.hs | 4 ++-- src/Language/PureScript/TypeChecker/Types.hs | 10 +++++----- 6 files changed, 14 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index f89b80ff69..063bd963cf 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -494,7 +494,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident i)))) | i `elem` [ C.bind, C.discard ] = - line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode "bind" <> " function. Please import " <> markCode "bind" <> " from module " <> markCode "Prelude" + line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode i <> " function. Please import " <> markCode i <> " from module " <> markCode "Prelude" renderSimpleErrorMessage (UnknownName name) = line $ "Unknown " <> printName name renderSimpleErrorMessage (UnknownImport mn name) = diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 96178af114..b3b4fa4ef0 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -451,7 +451,7 @@ parseDoNotationBind :: TokenParser DoNotationElement parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* indented <* larrow) <*> parseValue parseDoNotationElement :: TokenParser DoNotationElement -parseDoNotationElement = P.choice +parseDoNotationElement = withSourceSpan PositionedDoNotationElement $ P.choice [ parseDoNotationBind , parseDoNotationLet , DoNotationValue <$> parseValue diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 534763267a..57796bcbf4 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -47,7 +47,6 @@ desugarDo d = rest' <- go rest return $ App (App discard val) (Abs (Left (Ident C.__unused)) rest') go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind - go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest) go (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) = throwError . errorMessage $ CannotUseBindWithDo (Ident ident) where diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 909af189a3..4fee1b8586 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -117,6 +117,11 @@ withErrorMessageHint hint action = do modify $ \st -> st { checkHints = checkHints orig } return a +-- | These hints are added at the front, so the most nested hint occurs +-- at the front, but the simplifier assumes the reverse order. +getHints :: MonadState CheckState m => m [ErrorMessageHint] +getHints = gets (reverse . checkHints) + rethrowWithPositionTC :: (MonadState CheckState m, MonadError MultipleErrors m) => SourceSpan diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 87e56f0dcc..038ce80a5b 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -10,7 +10,7 @@ import Prelude.Compat import Control.Monad (when) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State.Class (MonadState(..), gets) +import Control.Monad.State.Class (MonadState(..)) import Data.Foldable (for_) import Data.List (uncons) @@ -98,7 +98,7 @@ subsumes' mode ty1 (KindedType ty2 _) = -- Otherwise fall back to unification. subsumes' SElaborate (ConstrainedType constraints ty1) ty2 = do dicts <- getTypeClassDictionaries - hints <- gets checkHints + hints <- getHints elaborate <- subsumes' SElaborate ty1 ty2 let addDicts val = foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints) return (elaborate . addDicts) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index f967d2cc1f..030e050b74 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -283,7 +283,7 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do instantiatePolyTypeWithUnknowns val ty' instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do dicts <- getTypeClassDictionaries - hints <- gets checkHints + hints <- getHints instantiatePolyTypeWithUnknowns (foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty instantiatePolyTypeWithUnknowns val ty = return (val, ty) @@ -363,7 +363,7 @@ infer' (Var var) = do case ty of ConstrainedType constraints ty' -> do dicts <- getTypeClassDictionaries - hints <- gets checkHints + hints <- getHints return $ TypedValue True (foldl App (Var var) (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty' _ -> return $ TypedValue True (Var var) ty infer' v@(Constructor c) = do @@ -390,7 +390,7 @@ infer' (Let ds val) = do return $ TypedValue True (Let ds' val') valTy infer' (DeferredDictionary className tys) = do dicts <- getTypeClassDictionaries - hints <- gets checkHints + hints <- getHints return $ TypedValue False (TypeClassDictionary (Constraint className tys Nothing) dicts hints) (foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys) @@ -659,7 +659,7 @@ check' (DeferredDictionary className tys) ty = do -- declaration gets desugared. -} dicts <- getTypeClassDictionaries - hints <- gets checkHints + hints <- getHints return $ TypedValue False (TypeClassDictionary (Constraint className tys Nothing) dicts hints) ty @@ -808,7 +808,7 @@ checkFunctionApplication' fn (KindedType ty _) arg = checkFunctionApplication fn ty arg checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg = do dicts <- getTypeClassDictionaries - hints <- gets checkHints + hints <- getHints checkFunctionApplication' (foldl App fn (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) fnTy arg checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} = return (fnTy, App fn dict) From 039c45919c21af3c08ea3c9e99ea60e83259a75f Mon Sep 17 00:00:00 2001 From: Soham Chowdhury Date: Mon, 13 Mar 2017 23:05:16 +0530 Subject: [PATCH 0714/1580] Improve instance arity errors (#2740) * (Minor) improvement for instance arity mismatch error * Register as a contributor --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Errors.hs | 8 +++++--- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 0108fe6d48..69999df6c4 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -57,6 +57,7 @@ If you would prefer to use different terms, please use the section below instead | [@lukerandall](https://github.com/lukerandall) | Luke Randall | [MIT license](http://opensource.org/licenses/MIT) | | [@matthewleon](https://github.com/matthewleon) | Matthew Leon | [MIT license](http://opensource.org/licenses/MIT) | | [@mcoffin](https://github.com/mcoffin) | Matt Coffin | [MIT license](http://opensource.org/licenses/MIT) | +| [@mrkgnao](https://github.com/mrkgnao) | Soham Chowdhury | [MIT license](http://opensource.org/licenses/MIT) | | [@mgmeier](https://github.com/mgmeier) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) | | [@michaelficarra](https://github.com/michaelficarra) | Michael Ficarra | [MIT license](http://opensource.org/licenses/MIT) | | [@MichaelXavier](https://github.com/MichaelXavier) | Michael Xavier | MIT license | diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 063bd963cf..cfa661516c 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -916,10 +916,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS renderSimpleErrorMessage (ClassInstanceArityMismatch dictName className expected actual) = paras [ line $ "The type class " <> markCode (showQualified runProperName className) <> - " expects " <> T.pack (show expected) <> " argument(s)." - , line $ "But the instance " <> markCode (showIdent dictName) <> " only provided " <> - T.pack (show actual) <> "." + " expects " <> T.pack (show expected) <> " " <> argsMsg <> "." + , line $ "But the instance " <> markCode (showIdent dictName) <> mismatchMsg <> T.pack (show actual) <> "." ] + where + mismatchMsg = if actual > expected then " provided " else " only provided " + argsMsg = if expected > 1 then "arguments" else "argument" renderSimpleErrorMessage (UserDefinedWarning msgTy) = let msg = fromMaybe (typeAsBox msgTy) (toTypelevelString msgTy) in From a5c3a0140c78b2b1d386b9309ff2e4d4cc418b40 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 13 Mar 2017 21:03:33 +0100 Subject: [PATCH 0715/1580] Tracks more positions during parsing (#2662) * Extends Traversals to also traverse BoundValueDeclarations * Simplifies the Abs node: Abs (Either Ident Binder) -> Abs Binder by using VarBinder in places where previously (Left Ident) was used * Records position information for guarded expressions * Adds position information to binder parsers --- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/AST/Traversals.hs | 21 +++---- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- src/Language/PureScript/Linter.hs | 2 +- src/Language/PureScript/Linter/Exhaustive.hs | 2 +- .../PureScript/Parser/Declarations.hs | 58 ++++++++++--------- src/Language/PureScript/Pretty/Values.hs | 3 +- .../PureScript/Sugar/CaseDeclarations.hs | 14 +++-- src/Language/PureScript/Sugar/DoNotation.hs | 6 +- src/Language/PureScript/Sugar/Names.hs | 4 +- .../PureScript/Sugar/ObjectWildcards.hs | 14 ++--- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 2 +- .../PureScript/TypeChecker/Entailment.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 28 ++++----- 15 files changed, 86 insertions(+), 76 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index ad7ef3b327..97a684390d 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -627,7 +627,7 @@ data Expr -- | -- Function introduction -- - | Abs (Either Ident Binder) Expr + | Abs Binder Expr -- | -- Function application -- diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 0aa1fa2728..d1a8ce59c8 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -48,6 +48,7 @@ everywhereOnValues f g h = (f', g', h') f' :: Declaration -> Declaration f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds)) f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) (map (mapGuardedExpr handleGuard g') val)) + f' (BoundValueDeclaration b expr) = f (BoundValueDeclaration (h' b) (g' expr)) f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds)) f' (TypeClassDeclaration name args implies deps ds) = f (TypeClassDeclaration name args implies deps (map f' ds)) f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (mapTypeInstanceBody (map f') ds)) @@ -63,7 +64,7 @@ everywhereOnValues f g h = (f', g', h') g' (Accessor prop v) = g (Accessor prop (g' v)) g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs)) g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs)) - g' (Abs name v) = g (Abs name (g' v)) + g' (Abs binder v) = g (Abs (h' binder) (g' v)) g' (App v1 v2) = g (App (g' v1) (g' v2)) g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3)) g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts)) @@ -123,6 +124,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds f' (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f' <=< f) ds f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds + f' (BoundValueDeclaration b expr) = BoundValueDeclaration <$> h' b <*> g' expr f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f') f' other = f other @@ -135,7 +137,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (Accessor prop v) = Accessor prop <$> (g v >>= g') g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (g' <=< g) vs - g' (Abs name v) = Abs name <$> (g v >>= g') + g' (Abs binder v) = Abs <$> (h binder >>= h') <*> (g v >>= g') g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g') g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g') g' (Case vs alts) = Case <$> traverse (g' <=< g) vs <*> traverse handleCaseAlternative alts @@ -193,6 +195,7 @@ everywhereOnValuesM f g h = (f', g', h') f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val) >>= f f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f + f' (BoundValueDeclaration b expr) = (BoundValueDeclaration <$> h' b <*> g' expr) >>= f f' (TypeClassDeclaration name args implies deps ds) = (TypeClassDeclaration name args implies deps <$> traverse f' ds) >>= f f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f @@ -207,7 +210,7 @@ everywhereOnValuesM f g h = (f', g', h') g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse g' vs) >>= g - g' (Abs name v) = (Abs name <$> g' v) >>= g + g' (Abs binder v) = (Abs <$> h' binder <*> g' v) >>= g g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g g' (Case vs alts) = (Case <$> traverse g' vs <*> traverse handleCaseAlternative alts) >>= g @@ -271,6 +274,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds) f' d@(TypeClassDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds) f' d@(TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (map f' ds) + f' d@(BoundValueDeclaration b expr) = f d <> h' b <> g' expr f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1 f' d = f d @@ -283,7 +287,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') g' v@(Accessor _ v1) = g v <> g' v1 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs) g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (fmap g' vs) - g' v@(Abs _ v1) = g v <> g' v1 + g' v@(Abs b v1) = g v <> h' b <> g' v1 g' v@(App v1 v2) = g v <> g' v1 <> g' v2 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3 g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts) @@ -364,7 +368,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs) g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s) vs) - g' s (Abs _ v1) = g'' s v1 + g' s (Abs binder v1) = h'' s binder <> g'' s v1 g' s (App v1 v2) = g'' s v1 <> g'' s v2 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts) @@ -448,7 +452,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g' s (Accessor prop v) = Accessor prop <$> g'' s v g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (g'' s) vs - g' s (Abs name v) = Abs name <$> g'' s v + g' s (Abs binder v) = Abs <$> h' s binder <*> g'' s v g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3 g' s (Case vs alts) = Case <$> traverse (g'' s) vs <*> traverse (i'' s) alts @@ -538,10 +542,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s) vs - g' s (Abs (Left name) v1) = - let s' = S.insert name s - in g'' s' v1 - g' s (Abs (Right b) v1) = + g' s (Abs b v1) = let s' = S.union (S.fromList (binderNames b)) s in h'' s b <> g'' s' v1 g' s (App v1 v2) = g'' s v1 <> g'' s v2 diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 5f8f6a4581..800c63084b 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -89,7 +89,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) exprToCoreFn ss com ty (A.ObjectUpdate obj vs) = ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ map (second (exprToCoreFn ss [] Nothing)) vs - exprToCoreFn ss com ty (A.Abs (Left name) v) = + exprToCoreFn ss com ty (A.Abs (A.VarBinder name) v) = Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) exprToCoreFn _ _ _ (A.Abs _ _) = internalError "Abs with Binder argument was not desugared before exprToCoreFn mn" diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 8ddf1cffd2..d26f361141 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -56,7 +56,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec stepE :: S.Set Ident -> Expr -> MultipleErrors - stepE s (Abs (Left name) _) | name `S.member` s = errorMessage (ShadowedName name) + stepE s (Abs (VarBinder name) _) | name `S.member` s = errorMessage (ShadowedName name) stepE s (Let ds' _) = foldMap go ds' where go d | Just i <- getDeclIdent d diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 82ef5d00d4..e54b0751e2 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -293,7 +293,7 @@ checkExhaustive env mn numArgs cas expr = makeResult . first ordNub $ foldl' ste [MkUnguarded (TypedValue True - (Abs (Left (Ident var)) (Var (Qualified Nothing (Ident var)))) + (Abs (VarBinder (Ident var)) (Var (Qualified Nothing (Ident var)))) (ty tyVar)) ] diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index b3b4fa4ef0..a66370c8b8 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -79,10 +79,10 @@ parseValueWithWhereClause = do parseValueWithIdentAndBinders :: Ident -> [Binder] -> TokenParser Declaration parseValueWithIdentAndBinders ident bs = do value <- indented *> ( - (\v -> [MkUnguarded v]) <$> (equals *> parseValueWithWhereClause) <|> + (\v -> [MkUnguarded v]) <$> (equals *> withSourceSpan PositionedValue parseValueWithWhereClause) <|> P.many1 (GuardedExpr <$> parseGuard <*> (indented *> equals - *> parseValueWithWhereClause)) + *> withSourceSpan PositionedValue parseValueWithWhereClause)) ) return $ ValueDeclaration ident Public bs value @@ -97,7 +97,7 @@ parseLocalValueDeclaration = join $ go <$> parseBinder <*> (P.many parseBinderNo where go :: Binder -> [Binder] -> TokenParser Declaration go (VarBinder ident) bs = parseValueWithIdentAndBinders ident bs - go (PositionedBinder _ _ (VarBinder ident)) bs = parseValueWithIdentAndBinders ident bs + go (PositionedBinder _ _ b) bs = go b bs go binder [] = BoundValueDeclaration binder <$> (indented *> equals *> parseValueWithWhereClause) go _ _ = P.unexpected $ "patterns in local value declaration" @@ -348,7 +348,7 @@ parseIdentifierAndValue = parseAbs :: TokenParser Expr parseAbs = do symbol' "\\" - args <- P.many1 (indented *> (Abs <$> (Left <$> parseIdent <|> Right <$> parseBinderNoParens))) + args <- P.many1 (indented *> (Abs <$> parseBinderNoParens)) indented *> rarrow value <- parseValue return $ toFunction args value @@ -558,33 +558,35 @@ parseBinder = parseOpBinder = OpBinder <$> parseQualified parseOperator parseBinderAtom :: TokenParser Binder -parseBinderAtom = P.choice - [ parseNullBinder - , LiteralBinder <$> parseCharLiteral - , LiteralBinder <$> parseStringLiteral - , LiteralBinder <$> parseBooleanLiteral - , parseNumberLiteral - , parseVarOrNamedBinder - , parseConstructorBinder - , parseObjectBinder - , parseArrayBinder - , ParensInBinder <$> parens parseBinder - ] P. "binder" +parseBinderAtom = withSourceSpan PositionedBinder + (P.choice + [ parseNullBinder + , LiteralBinder <$> parseCharLiteral + , LiteralBinder <$> parseStringLiteral + , LiteralBinder <$> parseBooleanLiteral + , parseNumberLiteral + , parseVarOrNamedBinder + , parseConstructorBinder + , parseObjectBinder + , parseArrayBinder + , ParensInBinder <$> parens parseBinder + ] P. "binder") -- | Parse a binder as it would appear in a top level declaration parseBinderNoParens :: TokenParser Binder -parseBinderNoParens = P.choice - [ parseNullBinder - , LiteralBinder <$> parseCharLiteral - , LiteralBinder <$> parseStringLiteral - , LiteralBinder <$> parseBooleanLiteral - , parseNumberLiteral - , parseVarOrNamedBinder - , parseNullaryConstructorBinder - , parseObjectBinder - , parseArrayBinder - , ParensInBinder <$> parens parseBinder - ] P. "binder" +parseBinderNoParens = withSourceSpan PositionedBinder + (P.choice + [ parseNullBinder + , LiteralBinder <$> parseCharLiteral + , LiteralBinder <$> parseStringLiteral + , LiteralBinder <$> parseBooleanLiteral + , parseNumberLiteral + , parseVarOrNamedBinder + , parseNullaryConstructorBinder + , parseObjectBinder + , parseArrayBinder + , ParensInBinder <$> parens parseBinder + ] P. "binder") -- | Parse a guard parseGuard :: TokenParser [Guard] diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 0f0a83cb99..f48a83fadc 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -66,8 +66,7 @@ prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintValueAtom (d - 1) o `b printNode (key, Leaf val) = prettyPrintUpdateEntry d key val printNode (key, Branch val) = textT (prettyPrintObjectKey key) `beforeWithSpace` prettyPrintUpdate val prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg -prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) -prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) +prettyPrintValue d (Abs arg val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) = text (T.unpack (runProperName (disqualify className)) ++ " ") <> prettyPrintValueAtom (d - 1) ps prettyPrintValue d (Case values binders) = diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 67b11b8044..781f1eeee1 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -287,11 +287,17 @@ desugarAbs = flip parU f (f, _, _) = everywhereOnValuesM return replace return replace :: Expr -> m Expr - replace (Abs (Right binder) val) = do + replace (Abs (stripPositioned -> (VarBinder i)) val) = + pure (Abs (VarBinder i) val) + replace (Abs binder val) = do ident <- freshIdent' - return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded val]] + return $ Abs (VarBinder ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded val]] replace other = return other +stripPositioned :: Binder -> Binder +stripPositioned (PositionedBinder _ _ binder) = stripPositioned binder +stripPositioned binder = binder + -- | -- Replace all top-level binders with case expressions. -- @@ -323,7 +329,7 @@ inSameGroup _ _ = False toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] toDecls [ValueDeclaration ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do args <- mapM fromVarBinder bs - let body = foldr (Abs . Left) val args + let body = foldr (Abs . VarBinder) val args guardWith (errorMessage (OverlappingArgNames (Just ident))) $ length (ordNub args) == length args return [ValueDeclaration ident nameKind [] [MkUnguarded body]] where @@ -365,7 +371,7 @@ makeCaseDeclaration ident alternatives = do let vars = map (Var . Qualified Nothing) args binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] case_ <- desugarCase (Case vars binders) - let value = foldr (Abs . Left) case_ args + let value = foldr (Abs . VarBinder) case_ args return $ ValueDeclaration ident Public [] [MkUnguarded value] where diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 57796bcbf4..4acd0ba2b8 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -45,7 +45,7 @@ desugarDo d = go [DoNotationValue val] = return val go (DoNotationValue val : rest) = do rest' <- go rest - return $ App (App discard val) (Abs (Left (Ident C.__unused)) rest') + return $ App (App discard val) (Abs (VarBinder (Ident C.__unused)) rest') go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind go (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) = throwError . errorMessage $ CannotUseBindWithDo (Ident ident) @@ -54,11 +54,11 @@ desugarDo d = fromIdent _ = mempty go (DoNotationBind (VarBinder ident) val : rest) = do rest' <- go rest - return $ App (App bind val) (Abs (Left ident) rest') + return $ App (App bind val) (Abs (VarBinder ident) rest') go (DoNotationBind binder val : rest) = do rest' <- go rest ident <- freshIdent' - return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']])) + return $ App (App bind val) (Abs (VarBinder ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']])) go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet go (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index c7e07e2568..39cc2ed6dc 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -201,8 +201,8 @@ renameInModule imports (Module ss coms mn decls exps) = -> m ((Maybe SourceSpan, [Ident]), Expr) updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v) - updateValue (pos, bound) (Abs (Left arg) val') = - return ((pos, arg : bound), Abs (Left arg) val') + updateValue (pos, bound) (Abs (VarBinder arg) val') = + return ((pos, arg : bound), Abs (VarBinder arg) val') updateValue (pos, bound) (Let ds val') = do let args = mapMaybe letBoundVariable ds unless (length (ordNub args) == length args) $ diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 3f37d8692f..a46d6cc55e 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -37,27 +37,27 @@ desugarDecl other = fn other | b' <- stripPositionInfo b , BinaryNoParens op val u <- b' , isAnonymousArgument u = do arg <- freshIdent' - return $ Abs (Left arg) $ App (App op val) (Var (Qualified Nothing arg)) + return $ Abs (VarBinder arg) $ App (App op val) (Var (Qualified Nothing arg)) | b' <- stripPositionInfo b , BinaryNoParens op u val <- b' , isAnonymousArgument u = do arg <- freshIdent' - return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val + return $ Abs (VarBinder arg) $ App (App op (Var (Qualified Nothing arg))) val desugarExpr (Literal (ObjectLiteral ps)) = wrapLambdaAssoc (Literal . ObjectLiteral) ps desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps desugarExpr (Accessor prop u) | Just props <- peelAnonAccessorChain u = do arg <- freshIdent' - return $ Abs (Left arg) $ foldr Accessor (argToExpr arg) (prop:props) + return $ Abs (VarBinder arg) $ foldr Accessor (argToExpr arg) (prop:props) desugarExpr (Case args cas) | any isAnonymousArgument args = do argIdents <- forM args freshIfAnon let args' = zipWith (`maybe` argToExpr) args argIdents - return $ foldr (Abs . Left) (Case args' cas) (catMaybes argIdents) + return $ foldr (Abs . VarBinder) (Case args' cas) (catMaybes argIdents) desugarExpr (IfThenElse u t f) | any isAnonymousArgument [u, t, f] = do u' <- freshIfAnon u t' <- freshIfAnon t f' <- freshIfAnon f let if_ = IfThenElse (maybe u argToExpr u') (maybe t argToExpr t') (maybe f argToExpr f') - return $ foldr (Abs . Left) if_ (catMaybes [u', t', f']) + return $ foldr (Abs . VarBinder) if_ (catMaybes [u', t', f']) desugarExpr e = return e transformNestedUpdate :: Expr -> PathTree Expr -> m Expr @@ -67,7 +67,7 @@ desugarDecl other = fn other val <- freshIdent' let valExpr = argToExpr val if isAnonymousArgument obj - then Abs (Left val) <$> wrapLambda (buildUpdates valExpr) ps + then Abs (VarBinder val) <$> wrapLambda (buildUpdates valExpr) ps else wrapLambda (buildLet val . buildUpdates valExpr) ps where buildLet val = Let [ValueDeclaration val Public [] [MkUnguarded obj]] @@ -87,7 +87,7 @@ desugarDecl other = fn other wrapLambda :: forall t. Traversable t => (t Expr -> Expr) -> t Expr -> m Expr wrapLambda mkVal ps = do args <- traverse processExpr ps - return $ foldr (Abs . Left) (mkVal (snd <$> args)) (catMaybes $ toList (fst <$> args)) + return $ foldr (Abs . VarBinder) (mkVal (snd <$> args)) (catMaybes $ toList (fst <$> args)) where processExpr :: Expr -> m (Maybe Ident, Expr) processExpr e = do diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index aae02d33c3..6763ef01e9 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -293,7 +293,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = -- The type is a record type, but depending on type instance dependencies, may be constrained. -- The dictionary itself is a record literal. let superclasses = superClassDictionaryNames typeClassSuperclasses `zip` - [ Abs (Left (Ident C.__unused)) (DeferredDictionary superclass tyArgs) + [ Abs (VarBinder (Ident C.__unused)) (DeferredDictionary superclass tyArgs) | (Constraint superclass suTyArgs _) <- typeClassSuperclasses , let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs ] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index cc8f37004f..bc353232c9 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -748,7 +748,7 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType isTypeDecl _ = False lam :: Ident -> Expr -> Expr -lam = Abs . Left +lam = Abs . VarBinder lamNull :: Expr -> Expr lamNull = lam (Ident "$q") -- TODO: use GenIdent diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index d1ec217bfe..534486b7a0 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -322,7 +322,7 @@ entails SolverOptions{..} constraint context hints = -- So pass an empty object instead. return $ Literal (ObjectLiteral []) mkDictionary (IsSymbolInstance sym) _ = - let fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) ] in + let fields = [ ("reflectSymbol", Abs (VarBinder (Ident C.__unused)) (Literal (StringLiteral sym))) ] in return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) mkDictionary CompareSymbolInstance _ = return $ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral [])) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 030e050b74..a82bed1844 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -116,7 +116,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -- Check skolem variables did not escape their scope skolemEscapeCheck val' - return ((ident, (foldr (Abs . Left . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved) + return ((ident, (foldr (Abs . VarBinder . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved) -- Show warnings here, since types in wildcards might have been solved during -- instance resolution (by functional dependencies). @@ -347,12 +347,13 @@ infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val pro rest <- freshType typed <- check val (TypeApp tyRecord (RCons (Label prop) field rest)) return $ TypedValue True (Accessor prop typed) field -infer' (Abs (Left arg) ret) = do - ty <- freshType - withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do - body@(TypedValue _ _ bodyTy) <- infer' ret - return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy -infer' (Abs (Right _) _) = internalError "Binder was not desugared" +infer' (Abs binder ret) + | VarBinder arg <- binder = do + ty <- freshType + withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do + body@(TypedValue _ _ bodyTy) <- infer' ret + return $ TypedValue True (Abs (VarBinder arg) body) $ function ty bodyTy + | otherwise = internalError "Binder was not desugared" infer' (App f arg) = do f'@(TypedValue _ _ ft) <- infer f (ret, app) <- checkFunctionApplication f' ft arg @@ -614,7 +615,7 @@ check' val t@(ConstrainedType constraints ty) = do freshIdent ("dict" <> className) dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty - return $ TypedValue True (foldr (Abs . Left) val' dictNames) t + return $ TypedValue True (foldr (Abs . VarBinder) val' dictNames) t check' val u@(TUnknown _) = do val'@(TypedValue _ _ ty) <- infer val -- Don't unify an unknown with an inferred polytype @@ -635,11 +636,12 @@ check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do unifyTypes a tyArray array <- Literal . ArrayLiteral <$> forM vals (`check` ty) return $ TypedValue True array t -check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do - unifyTypes t tyFunction - ret' <- withBindingGroupVisible $ bindLocalVariables [(arg, argTy, Defined)] $ check ret retTy - return $ TypedValue True (Abs (Left arg) ret') ty -check' (Abs (Right _) _) _ = internalError "Binder was not desugared" +check' (Abs binder ret) ty@(TypeApp (TypeApp t argTy) retTy) + | VarBinder arg <- binder = do + unifyTypes t tyFunction + ret' <- withBindingGroupVisible $ bindLocalVariables [(arg, argTy, Defined)] $ check ret retTy + return $ TypedValue True (Abs (VarBinder arg) ret') ty + | otherwise = internalError "Binder was not desugared" check' (App f arg) ret = do f'@(TypedValue _ _ ft) <- infer f (retTy, app) <- checkFunctionApplication f' ft arg From 2e61f1458b3db43ba28f6f1eacfc25a5c494cf60 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 14 Mar 2017 17:33:45 +0100 Subject: [PATCH 0716/1580] [purs ide] Removes unnecessary clause in import pretty printing (#2742) The compilers prettyPrinter can now handle PositionedRefs properly --- src/Language/PureScript/Ide/Imports.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index f91f865b00..c5b1b59dfb 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -282,9 +282,6 @@ addImportForIdentifier fp ident filters = do decideRedundantCase _ _ = Nothing prettyPrintImport' :: Import -> Text --- TODO: remove this clause once P.prettyPrintImport can properly handle PositionedRefs -prettyPrintImport' (Import mn (P.Explicit refs) qual) = - "import " <> P.prettyPrintImport mn (P.Explicit (unwrapPositionedRef <$> refs)) qual prettyPrintImport' (Import mn idt qual) = "import " <> P.prettyPrintImport mn idt qual From 603b968431e7de8c1cf173bbbbc7de7f90a47db8 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 14 Mar 2017 17:33:59 +0100 Subject: [PATCH 0717/1580] Just a few minor refactorings (#2743) * dropWhileEnd is exposed from Data.List already * pointfree rethrow is more in line with the surrounding code * collectErrors with partitionEithers only needs a single traversals of the results --- src/Language/PureScript/Errors.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index cfa661516c..d0ca60dd60 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -15,10 +15,10 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.State.Lazy import Control.Monad.Writer import Data.Char (isSpace) -import Data.Either (lefts, rights) +import Data.Either (partitionEithers) import Data.Foldable (fold) import Data.Functor.Identity (Identity(..)) -import Data.List (transpose, nubBy, sortBy, partition) +import Data.List (transpose, nubBy, sortBy, partition, dropWhileEnd) import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import Data.Ord (comparing) import Data.String (fromString) @@ -1310,7 +1310,6 @@ renderBox = unlines . lines . Box.render where - dropWhileEnd p = reverse . dropWhile p . reverse whiteSpace = all isSpace toTypelevelString :: Type -> Maybe Box.Box @@ -1326,7 +1325,7 @@ toTypelevelString t = (Box.text . decodeStringWithReplacement) <$> toTypelevelSt -- | Rethrow an error with a more detailed error message in the case of failure rethrow :: (MonadError e m) => (e -> e) -> m a -> m a -rethrow f = flip catchError $ \e -> throwError (f e) +rethrow f = flip catchError (throwError . f) reifyErrors :: (MonadError e m) => m a -> m (Either e a) reifyErrors ma = catchError (fmap Right ma) (return . Left) @@ -1378,6 +1377,6 @@ parU xs f = withError u = catchError (Right <$> u) (return . Left) collectErrors :: [Either MultipleErrors b] -> m [b] - collectErrors es = case lefts es of - [] -> return $ rights es - errs -> throwError $ fold errs + collectErrors es = case partitionEithers es of + ([], rs) -> return rs + (errs, _) -> throwError $ fold errs From 2a163219543dae0a245b217c8b58031d2caad3ad Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 14 Mar 2017 17:34:19 +0100 Subject: [PATCH 0718/1580] [purs ide] No longer strip trailing dots for Pursuit queries (#2744) The issue has been fixed upstream --- src/Language/PureScript/Ide/Pursuit.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs index 55294989b7..fd828b8c38 100644 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ b/src/Language/PureScript/Ide/Pursuit.hs @@ -29,14 +29,11 @@ import Network.HTTP.Types.Header (hAccept) import Pipes.HTTP import qualified Pipes.Prelude as P --- We need to remove trailing dots because Pursuit will return a 400 otherwise --- TODO: remove this when the issue is fixed at Pursuit queryPursuit :: Text -> IO ByteString queryPursuit q = do - let qClean = T.dropWhileEnd (== '.') q req' <- parseRequest "https://pursuit.purescript.org/search" let req = req' - { queryString= "q=" <> (fromString . T.unpack) qClean + { queryString= "q=" <> (fromString . T.unpack) q , requestHeaders=[(hAccept, "application/json")] } m <- newManager tlsManagerSettings From 1e673099cc8208c0d5648b6f9e2d26caad253f0a Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Wed, 15 Mar 2017 02:30:09 +0000 Subject: [PATCH 0719/1580] PS 0.11 breaking changes (#2730) * Only parse constraints on functions individually * Remove effect kind from prim, only parse named kinds * Update test dependencies * Update tests --- examples/docs/src/ConstrainedArgument.purs | 5 ++-- examples/failing/1071.purs | 2 +- examples/failing/1310.purs | 2 +- examples/failing/2601.purs | 2 +- examples/failing/DuplicateProperties.purs | 2 +- examples/failing/Superclasses5.purs | 6 ++-- examples/passing/1335.purs | 2 +- examples/passing/1697.purs | 6 ++-- examples/passing/1991.purs | 2 +- examples/passing/CheckTypeClass.purs | 4 +-- examples/passing/ClassRefSyntax.purs | 2 +- examples/passing/Console.purs | 2 +- examples/passing/DuplicateProperties.purs | 4 +-- examples/passing/EntailsKindedType.purs | 4 +-- examples/passing/ExtendedInfixOperators.purs | 2 +- examples/passing/FinalTagless.purs | 2 +- examples/passing/FunWithFunDeps.purs | 8 ++--- examples/passing/Guards.purs | 4 +-- examples/passing/KindedType.purs | 10 +++---- examples/passing/MutRec2.purs | 2 +- examples/passing/MutRec3.purs | 2 +- examples/passing/NakedConstraint.purs | 2 +- examples/passing/NewtypeClass.purs | 3 +- examples/passing/Operators.purs | 2 +- examples/passing/OverlappingInstances2.purs | 2 +- examples/passing/OverlappingInstances3.purs | 2 +- examples/passing/PrimedTypeName.purs | 2 +- examples/passing/Rank2TypeSynonym.purs | 2 +- examples/passing/RebindableSyntax.purs | 4 +-- examples/passing/RowPolyInstanceContext.purs | 2 +- examples/passing/Sequence.purs | 2 +- examples/passing/SequenceDesugared.purs | 10 +++---- examples/passing/Superclasses1.purs | 2 +- examples/passing/Superclasses3.purs | 6 ++-- examples/passing/TypeClasses.purs | 8 ++--- examples/passing/TypeWildcards.purs | 2 +- examples/passing/TypedBinders.purs | 2 +- .../passing/UnifyInTypeInstanceLookup.purs | 4 +-- .../passing/UnknownInTypeClassLookup.purs | 2 +- src/Language/PureScript/Constants.hs | 3 -- src/Language/PureScript/Docs/Prim.hs | 6 ---- src/Language/PureScript/Environment.hs | 4 --- src/Language/PureScript/Kinds.hs | 3 -- src/Language/PureScript/Parser/Kinds.hs | 11 +------ src/Language/PureScript/Parser/Types.hs | 2 +- tests/TestDocs.hs | 4 +-- tests/TestUtils.hs | 1 + tests/support/bower.json | 30 +++++++++---------- 48 files changed, 87 insertions(+), 111 deletions(-) diff --git a/examples/docs/src/ConstrainedArgument.purs b/examples/docs/src/ConstrainedArgument.purs index 65156a59c6..00bc5be0bc 100644 --- a/examples/docs/src/ConstrainedArgument.purs +++ b/examples/docs/src/ConstrainedArgument.purs @@ -4,6 +4,5 @@ class Foo t type WithoutArgs = forall a. (Partial => a) -> a type WithArgs = forall a. (Foo a => a) -> a -type MultiWithoutArgs = forall a. ((Partial, Partial) => a) -> a -type MultiWithArgs = forall a b. ((Foo a, Foo b) => a) -> a - +type MultiWithoutArgs = forall a. (Partial => Partial => a) -> a +type MultiWithArgs = forall a b. (Foo a => Foo b => a) -> a diff --git a/examples/failing/1071.purs b/examples/failing/1071.purs index 806f51a8f0..1f560d1806 100644 --- a/examples/failing/1071.purs +++ b/examples/failing/1071.purs @@ -4,5 +4,5 @@ module Main where class Foo a b where foo :: a -> b -bar :: forall a. (Foo a) => a -> a +bar :: forall a. Foo a => a -> a bar a = a diff --git a/examples/failing/1310.purs b/examples/failing/1310.purs index 5bc04429a8..02fde55f9f 100644 --- a/examples/failing/1310.purs +++ b/examples/failing/1310.purs @@ -12,7 +12,7 @@ class Inject f g where instance inject :: Inject f f where inj x = x -foreign import data Oops :: ! +foreign import data Oops :: Effect main :: forall eff. Eff (oops :: Oops | eff) Unit main = inj (log "Oops") diff --git a/examples/failing/2601.purs b/examples/failing/2601.purs index 00dc25f606..988e3d8799 100644 --- a/examples/failing/2601.purs +++ b/examples/failing/2601.purs @@ -1,7 +1,7 @@ -- @shouldFailWith KindsDoNotUnify module Main where -type Syn (a :: * -> *) = String +type Syn (a :: Type -> Type) = String val :: Syn Int val = "bad" diff --git a/examples/failing/DuplicateProperties.purs b/examples/failing/DuplicateProperties.purs index d8bba9d6ea..6349b30356 100644 --- a/examples/failing/DuplicateProperties.purs +++ b/examples/failing/DuplicateProperties.purs @@ -3,7 +3,7 @@ module DuplicateProperties where import Prelude -foreign import data Test :: # * -> * +foreign import data Test :: # Type -> Type foreign import subtractX :: forall r. Test (x :: Unit | r) -> Test r diff --git a/examples/failing/Superclasses5.purs b/examples/failing/Superclasses5.purs index 0de8d4bf8b..486f4e8cb9 100644 --- a/examples/failing/Superclasses5.purs +++ b/examples/failing/Superclasses5.purs @@ -8,19 +8,19 @@ import Control.Monad.Eff.Console (logShow) class Su a where su :: a -> a -class (Su (Array a)) <= Cl a where +class Su (Array a) <= Cl a where cl :: a -> a -> a instance suNumber :: Su Number where su n = n + 1.0 -instance suArray :: (Su a) => Su (Array a) where +instance suArray :: Su a => Su (Array a) where su [x] = [su x] instance clNumber :: Cl Number where cl n m = n + m -test :: forall a. (Cl a) => a -> Array a +test :: forall a. Cl a => a -> Array a test x = su [cl x x] main = logShow $ test 10.0 diff --git a/examples/passing/1335.purs b/examples/passing/1335.purs index 6b31a7ff0a..da59ed01e2 100644 --- a/examples/passing/1335.purs +++ b/examples/passing/1335.purs @@ -6,7 +6,7 @@ import Control.Monad.Eff.Console (log) x :: forall a. a -> String x a = y "Test" where - y :: forall a. (Show a) => a -> String + y :: forall a. Show a => a -> String y a = show (a :: a) main = do diff --git a/examples/passing/1697.purs b/examples/passing/1697.purs index 4c9570b18d..83e87eb0de 100644 --- a/examples/passing/1697.purs +++ b/examples/passing/1697.purs @@ -6,17 +6,17 @@ import Control.Monad.Eff.Console (log) _2 :: forall a. a -> a _2 a = a -x :: forall m. (Monad m) => m Unit +x :: forall m. Monad m => m Unit x = do _ <- pure unit pure unit -y :: forall m. (Monad m) => m Unit +y :: forall m. Monad m => m Unit y = do _ <- pure unit pure unit -wtf :: forall m. (Monad m) => m Unit +wtf :: forall m. Monad m => m Unit wtf = do _ <- pure unit let tmp = _2 1 diff --git a/examples/passing/1991.purs b/examples/passing/1991.purs index c0f5ff2df4..f7d10b674f 100644 --- a/examples/passing/1991.purs +++ b/examples/passing/1991.purs @@ -9,7 +9,7 @@ singleton x = [x] empty :: forall a. Array a empty = [] -foldMap :: forall a m. (Semigroup m) => (a -> m) -> Array a -> m +foldMap :: forall a m. Semigroup m => (a -> m) -> Array a -> m foldMap f [a, b, c, d, e] = f a <> f b <> f c <> f d <> f e foldMap f xs = foldMap f xs -- spin, not used diff --git a/examples/passing/CheckTypeClass.purs b/examples/passing/CheckTypeClass.purs index c26b2d0211..50f2d3e823 100644 --- a/examples/passing/CheckTypeClass.purs +++ b/examples/passing/CheckTypeClass.purs @@ -9,8 +9,8 @@ data Baz class Foo a where foo :: Bar a -> Baz -foo_ :: forall a. (Foo a) => a -> Baz -foo_ x = foo ((mkBar :: forall a. (Foo a) => a -> Bar a) x) +foo_ :: forall a. Foo a => a -> Baz +foo_ x = foo ((mkBar :: forall a. Foo a => a -> Bar a) x) mkBar :: forall a. a -> Bar a mkBar _ = Bar diff --git a/examples/passing/ClassRefSyntax.purs b/examples/passing/ClassRefSyntax.purs index 8601125e35..13e4e649bb 100644 --- a/examples/passing/ClassRefSyntax.purs +++ b/examples/passing/ClassRefSyntax.purs @@ -3,7 +3,7 @@ module Main where import Lib (class X, go) import Control.Monad.Eff.Console (log) -go' :: forall a. (X a) => a -> a +go' :: forall a. X a => a -> a go' = go main = log "Done" diff --git a/examples/passing/Console.purs b/examples/passing/Console.purs index 2009733db6..a12d699b69 100644 --- a/examples/passing/Console.purs +++ b/examples/passing/Console.purs @@ -4,7 +4,7 @@ import Prelude import Control.Monad.Eff import Control.Monad.Eff.Console -replicateM_ :: forall m a. (Monad m) => Number -> m a -> m Unit +replicateM_ :: forall m a. Monad m => Number -> m a -> m Unit replicateM_ 0.0 _ = pure unit replicateM_ n act = do _ <- act diff --git a/examples/passing/DuplicateProperties.purs b/examples/passing/DuplicateProperties.purs index 380e227487..d91f6bd317 100644 --- a/examples/passing/DuplicateProperties.purs +++ b/examples/passing/DuplicateProperties.purs @@ -3,9 +3,9 @@ module Main where import Prelude import Control.Monad.Eff.Console (log) -data RProxy (r :: # *) = RProxy +data RProxy (r :: # Type) = RProxy -data Proxy (a :: *) = Proxy +data Proxy (a :: Type) = Proxy subtractX :: forall r a. RProxy (x :: a | r) -> RProxy r subtractX RProxy = RProxy diff --git a/examples/passing/EntailsKindedType.purs b/examples/passing/EntailsKindedType.purs index cd2489a9f6..5d345b5553 100644 --- a/examples/passing/EntailsKindedType.purs +++ b/examples/passing/EntailsKindedType.purs @@ -4,8 +4,8 @@ import Prelude import Control.Monad.Eff import Control.Monad.Eff.Console -test x = show (x :: _ :: *) +test x = show (x :: _ :: Type) main = do - when (show (unit :: Unit :: *) == "unit") (log "Done") + when (show (unit :: Unit :: Type) == "unit") (log "Done") when (test unit == "unit") (log "Done") diff --git a/examples/passing/ExtendedInfixOperators.purs b/examples/passing/ExtendedInfixOperators.purs index 34481c09f5..5e12f6029f 100644 --- a/examples/passing/ExtendedInfixOperators.purs +++ b/examples/passing/ExtendedInfixOperators.purs @@ -4,7 +4,7 @@ import Prelude import Control.Monad.Eff.Console (log, logShow) import Data.Function (on) -comparing :: forall a b. (Ord b) => (a -> b) -> a -> a -> Ordering +comparing :: forall a b. Ord b => (a -> b) -> a -> a -> Ordering comparing f = compare `on` f null [] = true diff --git a/examples/passing/FinalTagless.purs b/examples/passing/FinalTagless.purs index be7f04b19a..b7cd4d8441 100644 --- a/examples/passing/FinalTagless.purs +++ b/examples/passing/FinalTagless.purs @@ -7,7 +7,7 @@ class E e where num :: Number -> e Number add :: e Number -> e Number -> e Number -type Expr a = forall e. (E e) => e a +type Expr a = forall e. E e => e a data Id a = Id a diff --git a/examples/passing/FunWithFunDeps.purs b/examples/passing/FunWithFunDeps.purs index fa40b2f994..d69aa33ee4 100644 --- a/examples/passing/FunWithFunDeps.purs +++ b/examples/passing/FunWithFunDeps.purs @@ -23,11 +23,11 @@ instance natMultZ :: NatMult Z n Z instance natMultS :: (NatMult m n r, NatPlus n r s) => NatMult (S m) n s -- Foreign Vect -foreign import data FVect :: * -> * -> * +foreign import data FVect :: Type -> Type -> Type foreign import fnil :: forall e. FVect Z e foreign import fcons :: forall n e. e -> FVect n e -> FVect (S n) e -foreign import fappend :: forall l r o e. (NatPlus l r o) => FVect l e -> FVect r e -> FVect o e -foreign import fflatten :: forall f s t o. (NatMult f s o) => FVect f (FVect s t) -> FVect o t +foreign import fappend :: forall l r o e. NatPlus l r o => FVect l e -> FVect r e -> FVect o e +foreign import fflatten :: forall f s t o. NatMult f s o => FVect f (FVect s t) -> FVect o t foreign import ftoArray :: forall n e. FVect n e -> Array e -- should be able to figure these out @@ -37,5 +37,5 @@ fexample2 = fexample `fappend` fexample `fappend` fexample fexample3 = fsingleton fexample `fappend` fsingleton fexample `fappend` fsingleton fexample fexample4 = fflatten fexample3 - + main = log "Done" diff --git a/examples/passing/Guards.purs b/examples/passing/Guards.purs index 9b21e976ac..6f86d590c2 100644 --- a/examples/passing/Guards.purs +++ b/examples/passing/Guards.purs @@ -12,11 +12,11 @@ collatz2 = \x y -> case x of z | y > 0.0 -> z / 2.0 z -> z * 3.0 + 1.0 -min :: forall a. (Ord a) => a -> a -> a +min :: forall a. Ord a => a -> a -> a min n m | n < m = n | otherwise = m -max :: forall a. (Ord a) => a -> a -> a +max :: forall a. Ord a => a -> a -> a max n m = case unit of _ | m < n -> n | otherwise -> m diff --git a/examples/passing/KindedType.purs b/examples/passing/KindedType.purs index 2a4959bb64..3abe5128a8 100644 --- a/examples/passing/KindedType.purs +++ b/examples/passing/KindedType.purs @@ -3,9 +3,9 @@ module Main where import Prelude import Control.Monad.Eff.Console (log) -type Star2Star f = f :: * -> * +type Star2Star f = f :: Type -> Type -type Star t = t :: * +type Star t = t :: Type test1 :: Star2Star Array String test1 = ["test"] @@ -15,17 +15,17 @@ f s = s test2 = f "test" -data Proxy (f :: * -> *) = Proxy +data Proxy (f :: Type -> Type) = Proxy test3 :: Proxy Array test3 = Proxy -type Test (f :: * -> *) = f String +type Test (f :: Type -> Type) = f String test4 :: Test Array test4 = ["test"] -class Clazz (a :: *) where +class Clazz (a :: Type) where def :: a instance clazzString :: Clazz String where diff --git a/examples/passing/MutRec2.purs b/examples/passing/MutRec2.purs index 844f9fed37..bac123773d 100644 --- a/examples/passing/MutRec2.purs +++ b/examples/passing/MutRec2.purs @@ -7,7 +7,7 @@ data A = A B data B = B A -foreign import data S :: * +foreign import data S :: Type f :: A -> S f a = case a of A b -> g b diff --git a/examples/passing/MutRec3.purs b/examples/passing/MutRec3.purs index 82a710fa18..ac22c69aca 100644 --- a/examples/passing/MutRec3.purs +++ b/examples/passing/MutRec3.purs @@ -7,7 +7,7 @@ data A = A B data B = B A -foreign import data S :: * +foreign import data S :: Type f a = case a of A b -> g b diff --git a/examples/passing/NakedConstraint.purs b/examples/passing/NakedConstraint.purs index f4b3a551a5..8ec2099a7c 100644 --- a/examples/passing/NakedConstraint.purs +++ b/examples/passing/NakedConstraint.purs @@ -4,7 +4,7 @@ import Control.Monad.Eff.Console data List a = Nil | Cons a (List a) -head :: (Partial) => List Int -> Int +head :: Partial => List Int -> Int head (Cons x _) = x main = log "Done" diff --git a/examples/passing/NewtypeClass.purs b/examples/passing/NewtypeClass.purs index 1352339faa..0e7c8a8494 100644 --- a/examples/passing/NewtypeClass.purs +++ b/examples/passing/NewtypeClass.purs @@ -24,7 +24,8 @@ foldPair f (Pair a b) = f a <> f b ala :: forall f t a - . (Functor f, Newtype t a) + . Functor f + => Newtype t a => (a -> t) -> ((a -> t) -> f t) -> f a diff --git a/examples/passing/Operators.purs b/examples/passing/Operators.purs index 835584ab08..aa6f24f558 100644 --- a/examples/passing/Operators.purs +++ b/examples/passing/Operators.purs @@ -11,7 +11,7 @@ op1 x _ = x infix 4 op1 as ?! -test1 :: forall n. (Semiring n) => n -> n -> (n -> n -> n) -> n +test1 :: forall n. Semiring n => n -> n -> (n -> n -> n) -> n test1 x y z = x * y + z x y test2 = (\x -> x.foo false) { foo : \_ -> 1.0 } diff --git a/examples/passing/OverlappingInstances2.purs b/examples/passing/OverlappingInstances2.purs index 9694cfad6a..4e277f04dd 100644 --- a/examples/passing/OverlappingInstances2.purs +++ b/examples/passing/OverlappingInstances2.purs @@ -19,7 +19,7 @@ instance ordA :: Ord A where compare B A = GT compare _ _ = EQ -test :: forall a. (Ord a) => a -> a -> String +test :: forall a. Ord a => a -> a -> String test x y = show $ x == y main = do diff --git a/examples/passing/OverlappingInstances3.purs b/examples/passing/OverlappingInstances3.purs index 14d95616ed..4ddc999232 100644 --- a/examples/passing/OverlappingInstances3.purs +++ b/examples/passing/OverlappingInstances3.purs @@ -10,7 +10,7 @@ instance foo1 :: Foo Number instance foo2 :: Foo Number -test :: forall a. (Foo a) => a -> a +test :: forall a. Foo a => a -> a test a = a test1 = test 0.0 diff --git a/examples/passing/PrimedTypeName.purs b/examples/passing/PrimedTypeName.purs index 5241c168eb..be4d96b642 100644 --- a/examples/passing/PrimedTypeName.purs +++ b/examples/passing/PrimedTypeName.purs @@ -8,7 +8,7 @@ type T' = T Unit data T'' = TP -foreign import data T''' ∷ * +foreign import data T''' ∷ Type instance eqT ∷ Eq T'' where eq _ _ = true diff --git a/examples/passing/Rank2TypeSynonym.purs b/examples/passing/Rank2TypeSynonym.purs index e4b8ffe351..3db194d5af 100644 --- a/examples/passing/Rank2TypeSynonym.purs +++ b/examples/passing/Rank2TypeSynonym.purs @@ -3,7 +3,7 @@ module Main where import Prelude import Control.Monad.Eff.Console (log, logShow) -type Foo a = forall f. (Monad f) => f a +type Foo a = forall f. Monad f => f a foo :: forall a. a -> Foo a foo x = pure x diff --git a/examples/passing/RebindableSyntax.purs b/examples/passing/RebindableSyntax.purs index ae283f5425..b0a7cc3e0c 100644 --- a/examples/passing/RebindableSyntax.purs +++ b/examples/passing/RebindableSyntax.purs @@ -12,7 +12,7 @@ example1 = do where discard x f = x <> f unit -applySecond :: forall f a b. (Apply f) => f a -> f b -> f b +applySecond :: forall f a b. Apply f => f a -> f b -> f b applySecond fa fb = const id <$> fa <*> fb infixl 4 applySecond as *> @@ -25,7 +25,7 @@ runConst (Const a) = a instance functorConst :: Functor (Const a) where map _ (Const a) = Const a -instance applyConst :: (Semigroup a) => Apply (Const a) where +instance applyConst :: Semigroup a => Apply (Const a) where apply (Const a1) (Const a2) = Const (a1 <> a2) example2 :: Const String Unit diff --git a/examples/passing/RowPolyInstanceContext.purs b/examples/passing/RowPolyInstanceContext.purs index caefb72952..796adef766 100644 --- a/examples/passing/RowPolyInstanceContext.purs +++ b/examples/passing/RowPolyInstanceContext.purs @@ -14,7 +14,7 @@ instance st :: T s (S s) where test1 :: forall r . S { foo :: String | r } Unit test1 = state $ \o -> o { foo = o.foo <> "!" } -test2 :: forall m r . (T { foo :: String | r } m) => m Unit +test2 :: forall m r . T { foo :: String | r } m => m Unit test2 = state $ \o -> o { foo = o.foo <> "!" } main = do diff --git a/examples/passing/Sequence.purs b/examples/passing/Sequence.purs index c6ba367890..37febf1ad7 100644 --- a/examples/passing/Sequence.purs +++ b/examples/passing/Sequence.purs @@ -7,7 +7,7 @@ import Control.Monad.Eff.Console (log) data List a = Cons a (List a) | Nil class Sequence t where - sequence :: forall m a. (Monad m) => t (m a) -> m (t a) + sequence :: forall m a. Monad m => t (m a) -> m (t a) instance sequenceList :: Sequence List where sequence Nil = pure Nil diff --git a/examples/passing/SequenceDesugared.purs b/examples/passing/SequenceDesugared.purs index f9243f6f2f..9268a276ce 100644 --- a/examples/passing/SequenceDesugared.purs +++ b/examples/passing/SequenceDesugared.purs @@ -6,12 +6,12 @@ import Control.Monad.Eff.Console (log) data List a = Cons a (List a) | Nil -data Sequence t = Sequence (forall m a. (Monad m) => t (m a) -> m (t a)) +data Sequence t = Sequence (forall m a. Monad m => t (m a) -> m (t a)) -sequence :: forall t. Sequence t -> (forall m a. (Monad m) => t (m a) -> m (t a)) +sequence :: forall t. Sequence t -> (forall m a. Monad m => t (m a) -> m (t a)) sequence (Sequence s) = s -sequenceListSeq :: forall m a. (Monad m) => List (m a) -> m (List a) +sequenceListSeq :: forall m a. Monad m => List (m a) -> m (List a) sequenceListSeq Nil = pure Nil sequenceListSeq (Cons x xs) = Cons <$> x <*> sequenceListSeq xs @@ -24,12 +24,12 @@ sequenceList' = Sequence ((\val -> case val of Cons x xs -> Cons <$> x <*> sequence sequenceList' xs)) sequenceList'' :: Sequence List -sequenceList'' = Sequence (sequenceListSeq :: forall m a. (Monad m) => List (m a) -> m (List a)) +sequenceList'' = Sequence (sequenceListSeq :: forall m a. Monad m => List (m a) -> m (List a)) sequenceList''' :: Sequence List sequenceList''' = Sequence ((\val -> case val of Nil -> pure Nil - Cons x xs -> Cons <$> x <*> sequence sequenceList''' xs) :: forall m a. (Monad m) => List (m a) -> m (List a)) + Cons x xs -> Cons <$> x <*> sequence sequenceList''' xs) :: forall m a. Monad m => List (m a) -> m (List a)) main = do void $ sequence sequenceList $ Cons (log "Done") Nil diff --git a/examples/passing/Superclasses1.purs b/examples/passing/Superclasses1.purs index 342f9ac223..4f00c1f7c5 100644 --- a/examples/passing/Superclasses1.purs +++ b/examples/passing/Superclasses1.purs @@ -15,7 +15,7 @@ instance suNumber :: Su Number where instance clNumber :: Cl Number where cl n m = n + m -test :: forall a. (Cl a) => a -> a +test :: forall a. Cl a => a -> a test a = su (cl a a) main = do diff --git a/examples/passing/Superclasses3.purs b/examples/passing/Superclasses3.purs index 14198645a5..8115fb2a26 100644 --- a/examples/passing/Superclasses3.purs +++ b/examples/passing/Superclasses3.purs @@ -4,13 +4,13 @@ import Prelude import Control.Monad.Eff.Console import Control.Monad.Eff -class (Monad m) <= MonadWriter w m where +class Monad m <= MonadWriter w m where tell :: w -> m Unit -testFunctor :: forall m. (Monad m) => m Number -> m Number +testFunctor :: forall m. Monad m => m Number -> m Number testFunctor n = (+) 1.0 <$> n -test :: forall w m. (Monad m, MonadWriter w m) => w -> m Unit +test :: forall w m. Monad m => MonadWriter w m => w -> m Unit test w = do tell w tell w diff --git a/examples/passing/TypeClasses.purs b/examples/passing/TypeClasses.purs index b65d93d6f0..2a52bac122 100644 --- a/examples/passing/TypeClasses.purs +++ b/examples/passing/TypeClasses.purs @@ -5,19 +5,19 @@ import Control.Monad.Eff.Console (log) test1 = \_ -> show "testing" -f :: forall a. (Show a) => a -> String +f :: forall a. Show a => a -> String f x = show x test2 = \_ -> f "testing" -test7 :: forall a. (Show a) => a -> String +test7 :: forall a. Show a => a -> String test7 = show test8 = \_ -> show $ "testing" data Data a = Data a -instance showData :: (Show a) => Show (Data a) where +instance showData :: Show a => Show (Data a) where show (Data a) = "Data (" <> show a <> ")" test3 = \_ -> show (Data "testing") @@ -53,7 +53,7 @@ instance bindMaybe :: Bind Maybe where instance monadMaybe :: Monad Maybe -test4 :: forall a m. (Monad m) => a -> m Number +test4 :: forall a m. Monad m => a -> m Number test4 = \_ -> pure 1.0 test5 = \_ -> Just 1.0 >>= \n -> pure (n + 1.0) diff --git a/examples/passing/TypeWildcards.purs b/examples/passing/TypeWildcards.purs index df9e3fdeda..262cf2c2c5 100644 --- a/examples/passing/TypeWildcards.purs +++ b/examples/passing/TypeWildcards.purs @@ -6,7 +6,7 @@ import Control.Monad.Eff.Console (log) testTopLevel :: _ -> _ testTopLevel n = n + 1.0 -test :: forall a. (Eq a) => (a -> a) -> a -> a +test :: forall a. Eq a => (a -> a) -> a -> a test f a = go (f a) a where go :: _ -> _ -> _ diff --git a/examples/passing/TypedBinders.purs b/examples/passing/TypedBinders.purs index f2e96746c2..92e50b672a 100644 --- a/examples/passing/TypedBinders.purs +++ b/examples/passing/TypedBinders.purs @@ -32,7 +32,7 @@ instance monadStateState :: MonadState s (State s) where get = State (\s -> Tuple s s) put s = State (\_ -> Tuple s unit) -modify :: forall m s. (Monad m, MonadState s m) => (s -> s) -> m Unit +modify :: forall m s. Monad m => MonadState s m => (s -> s) -> m Unit modify f = do s <- get put (f s) diff --git a/examples/passing/UnifyInTypeInstanceLookup.purs b/examples/passing/UnifyInTypeInstanceLookup.purs index a1920b84d9..b235a83d5f 100644 --- a/examples/passing/UnifyInTypeInstanceLookup.purs +++ b/examples/passing/UnifyInTypeInstanceLookup.purs @@ -12,13 +12,13 @@ class EQ x y b instance eqT :: EQ x x T instance eqF :: EQ x y F -test :: forall a b. (EQ a b T) => a -> b -> a +test :: forall a b. EQ a b T => a -> b -> a test a _ = a spin :: forall a b. a -> b spin a = spin a --- Expected type: +-- Expected type: -- forall t. (EQ t (S Z) T) => t test1 = test (spin 1) (S Z) diff --git a/examples/passing/UnknownInTypeClassLookup.purs b/examples/passing/UnknownInTypeClassLookup.purs index 7ba68065b0..8b90b1fe74 100644 --- a/examples/passing/UnknownInTypeClassLookup.purs +++ b/examples/passing/UnknownInTypeClassLookup.purs @@ -7,7 +7,7 @@ class EQ a b instance eqAA :: EQ a a -test :: forall a b. (EQ a b) => a -> b -> String +test :: forall a b. EQ a b => a -> b -> String test _ _ = "Done" runTest a = test a a diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 21d79e5661..1b37a84fe8 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -384,9 +384,6 @@ pattern Warn = Qualified (Just Prim) (ProperName "Warn") typ :: forall a. (IsString a) => a typ = "Type" -effect :: forall a. (IsString a) => a -effect = "Effect" - symbol :: forall a. (IsString a) => a symbol = "Symbol" diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index ba4d0e6ee4..7566bed4bf 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -28,7 +28,6 @@ primDocsModule = Module , typeConcat , typeString , kindType - , kindEffect , kindSymbol ] , modReExports = [] @@ -95,11 +94,6 @@ kindType = primKind "Type" $ T.unlines , "For example the type `Boolean` has kind `Type`; denoted by `Boolean :: Type`." ] -kindEffect :: Declaration -kindEffect = primKind "Effect" $ T.unlines - [ "`Effect` (also known as `!`) is the kind of all effect types." - ] - kindSymbol :: Declaration kindSymbol = primKind "Symbol" $ T.unlines [ "`Symbol` is the kind of type-level strings." diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index a0c1eafbdc..271445ea71 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -253,9 +253,6 @@ primKind = NamedKind . primName kindType :: Kind kindType = primKind C.typ -kindEffect :: Kind -kindEffect = primKind C.effect - kindSymbol :: Kind kindSymbol = primKind C.symbol @@ -341,7 +338,6 @@ primKinds :: S.Set (Qualified (ProperName 'KindName)) primKinds = S.fromList [ primName C.typ - , primName C.effect , primName C.symbol ] diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 93cabc96b3..696dd36fa6 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -52,8 +52,6 @@ kindFromJSON = do KUnknown <$> key "contents" (nth 0 asIntegral) "Star" -> pure kindType - "Bang" -> - pure kindEffect "Row" -> Row <$> key "contents" kindFromJSON "FunKind" -> @@ -78,7 +76,6 @@ kindFromJSON = do primKind = NamedKind . primName kindType = primKind "Type" - kindEffect = primKind "Effect" kindSymbol = primKind "Symbol" instance A.FromJSON Kind where diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs index a0517bfe8f..f1918ce259 100644 --- a/src/Language/PureScript/Parser/Kinds.hs +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -5,7 +5,6 @@ module Language.PureScript.Parser.Kinds (parseKind) where import Prelude.Compat -import Language.PureScript.Environment import Language.PureScript.Kinds import Language.PureScript.Parser.Common import Language.PureScript.Parser.Lexer @@ -13,20 +12,12 @@ import Language.PureScript.Parser.Lexer import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P -parseStar :: TokenParser Kind -parseStar = const kindType <$> symbol' "*" - -parseBang :: TokenParser Kind -parseBang = const kindEffect <$> symbol' "!" - parseNamedKind :: TokenParser Kind parseNamedKind = NamedKind <$> parseQualified kindName parseKindAtom :: TokenParser Kind parseKindAtom = indented *> P.choice - [ parseStar - , parseBang - , parseNamedKind + [ parseNamedKind , parens parseKind ] diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 403f8ff8c1..1953976f2b 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -70,7 +70,7 @@ parseTypeAtom = indented *> P.choice parseConstrainedType :: TokenParser Type parseConstrainedType = do - constraints <- P.try (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint) + constraints <- return <$> parseConstraint _ <- rfatArrow indented ty <- parseType diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 20cf7beadb..48bf04c57c 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -385,8 +385,8 @@ testCases = , ("ConstrainedArgument", [ TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithoutArgs" "forall a. (Partial => a) -> a" , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "WithArgs" "forall a. (Foo a => a) -> a" - , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. ((Partial, Partial) => a) -> a" - , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. ((Foo a, Foo b) => a) -> a" + , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithoutArgs" "forall a. (Partial => Partial => a) -> a" + , TypeSynonymShouldRenderAs (n "ConstrainedArgument") "MultiWithArgs" "forall a b. (Foo a => Foo b => a) -> a" ]) , ("TypeOpAliases", diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index ef9bbb525b..1fe916baa2 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -105,6 +105,7 @@ supportModules = , "Data.Functor.Invariant" , "Data.Generic" , "Data.Generic.Rep" + , "Data.Generic.Rep.Bounded" , "Data.Generic.Rep.Eq" , "Data.Generic.Rep.Monoid" , "Data.Generic.Rep.Ord" diff --git a/tests/support/bower.json b/tests/support/bower.json index 19bf7f0f82..eb1f395ba7 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -1,20 +1,20 @@ { "name": "purescript-test-suite-support", "dependencies": { - "purescript-assert": "2.0.0", - "purescript-arrays": "3.2.1", - "purescript-console": "2.0.0", - "purescript-eff": "2.0.0", - "purescript-functions": "2.0.0", - "purescript-prelude": "2.5.0", - "purescript-st": "2.0.0", - "purescript-partial": "1.1.2", - "purescript-newtype": "1.1.0", - "purescript-generics": "3.3.0", - "purescript-generics-rep": "4.0.0", - "purescript-symbols": "2.0.0", - "purescript-tailrec": "2.0.2", - "purescript-typelevel-prelude": "1.0.0", - "purescript-unsafe-coerce": "2.0.0" + "purescript-arrays": "ps-0.11", + "purescript-assert": "ps-0.11", + "purescript-console": "ps-0.11", + "purescript-eff": "ps-0.11", + "purescript-functions": "ps-0.11", + "purescript-generics": "ps-0.11", + "purescript-generics-rep": "ps-0.11", + "purescript-newtype": "ps-0.11", + "purescript-partial": "1.2.0", + "purescript-prelude": "ps-0.11", + "purescript-st": "ps-0.11", + "purescript-symbols": "ps-0.11", + "purescript-tailrec": "ps-0.11", + "purescript-typelevel-prelude": "ps-0.11", + "purescript-unsafe-coerce": "ps-0.11" } } From 08ebd7b5e0b280d97139031cddf6a09cdd8f6484 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 14 Mar 2017 19:36:33 -0700 Subject: [PATCH 0720/1580] Fix TCO issue when pattern matches can fail (#2739) --- src/Language/PureScript/CoreImp/Optimizer/TCO.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index 25b6a5d12d..7d8518ab9c 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -66,6 +66,8 @@ tco = everywhere convert where = countSelfReferences js1 == 0 && allInTailPosition body && all allInTailPosition el allInTailPosition (Block _ body) = all allInTailPosition body + allInTailPosition (Throw _ js1) + = countSelfReferences js1 == 0 allInTailPosition _ = False From be472271dd4b9301bc24e94f673ce0027716422a Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 15 Mar 2017 07:28:01 +0100 Subject: [PATCH 0721/1580] [purs ide] Reuses lenient import parsing for the list import command (#2741) Also changes the list import commands result to return imports as well as the parse module name, for convience for the editors --- psc-ide/PROTOCOL.md | 50 +++++++++++----------- src/Language/PureScript/Ide.hs | 2 +- src/Language/PureScript/Ide/Imports.hs | 24 ++++++++--- src/Language/PureScript/Ide/SourceFile.hs | 27 ------------ src/Language/PureScript/Ide/Types.hs | 51 ++++++++++------------- 5 files changed, 66 insertions(+), 88 deletions(-) diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index 20c5b1bfb1..0d009a777a 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -379,73 +379,73 @@ The list commmand can also list the imports for a given file. #### Response: -The list import command returns a list of imports where imports are of the following form: +The list import command returns the parse module name as well as a list of +imports like so: + +```json + +{ + "moduleName": "MyModule", + "imports": [Import] +} + +The different kind of imports are returned like so: + +``` Implicit Import (`import Data.Array`): ```json -[ - { +{ "module": "Data.Array", "importType": "implicit" - } -] +} ``` Implicit qualified Import (`import Data.Array as A`): ```json -[ - { +{ "module": "Data.Array", "importType": "implicit", "qualifier": "A" - } -] +} ``` Explicit Import (`import Data.Array (filter, filterM, join)`): ```json -[ - { +{ "module": "Data.Array", "importType": "explicit", "identifiers": ["filter", "filterM", "join"] - } -] +} ``` Explicit qualified Import (`import Data.Array (filter, filterM, join) as A`): ```json -[ - { +{ "module": "Data.Array", "importType": "explicit", "identifiers": ["filter", "filterM", "join"], "qualifier": "A" - } -] +} ``` Hiding Import (`import Data.Array hiding (filter, filterM, join)`): ```json -[ - { +{ "module": "Data.Array", "importType": "hiding", "identifiers": ["filter", "filterM", "join"] - } -] +} ``` Qualified Hiding Import (`import Data.Array hiding (filter, filterM, join) as A`): ```json -[ - { +{ "module": "Data.Array", "importType": "hiding", "identifiers": ["filter", "filterM", "join"], "qualifier": "A" - } -] +} ``` ### Cwd/Quit/Reset diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index aaaccbdbfe..020208e91e 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -67,7 +67,7 @@ handleCommand c = case c of List AvailableModules -> listAvailableModules List (Imports fp) -> - ImportList <$> getImportsForFile fp + ImportList <$> parseImportsFromFile fp CaseSplit l b e wca t -> caseSplit l b e wca t AddClause l wca -> diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index c5b1b59dfb..ba183152fb 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -16,6 +16,7 @@ module Language.PureScript.Ide.Imports ( addImplicitImport , addImportForIdentifier , answerRequest + , parseImportsFromFile -- for tests , parseImport , prettyPrintImportSection @@ -42,7 +43,7 @@ import Language.PureScript.Ide.Util import System.IO.UTF8 (writeUTF8FileT) import qualified Text.Parsec as Parsec -data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) +data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) deriving (Eq, Show) instance Ord Import where @@ -66,11 +67,24 @@ compImport (Import n i q) (Import n' i' q') | not (P.isExplicit i) && isNothing q' = GT | otherwise = compare n n' +-- | Reads a file and returns the parsed modulename as well as the parsed +-- imports, while ignoring eventual parse errors that aren't relevant to the +-- import section +parseImportsFromFile + :: (MonadIO m, MonadError IdeError m) + => FilePath + -> m (P.ModuleName, [(P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)]) +parseImportsFromFile file = do + (mn, _, imports, _) <- parseImportsFromFile' file + pure (mn, unwrapImport <$> imports) + where + unwrapImport (Import a b c) = (a, b, c) + -- | Reads a file and returns the (lines before the imports, the imports, the -- lines after the imports) -parseImportsFromFile :: (MonadIO m, MonadError IdeError m) => +parseImportsFromFile' :: (MonadIO m, MonadError IdeError m) => FilePath -> m (P.ModuleName, [Text], [Import], [Text]) -parseImportsFromFile fp = do +parseImportsFromFile' fp = do file <- ideReadFile fp case sliceImportSection (T.lines file) of Right res -> pure res @@ -134,7 +148,7 @@ addImplicitImport :: (MonadIO m, MonadError IdeError m) -> P.ModuleName -- ^ The module to import -> m [Text] addImplicitImport fp mn = do - (_, pre, imports, post) <- parseImportsFromFile fp + (_, pre, imports, post) <- parseImportsFromFile' fp let newImportSection = addImplicitImport' imports mn pure (pre ++ newImportSection ++ post) @@ -155,7 +169,7 @@ addImplicitImport' imports mn = addExplicitImport :: (MonadIO m, MonadError IdeError m) => FilePath -> IdeDeclaration -> P.ModuleName -> m [Text] addExplicitImport fp decl moduleName = do - (mn, pre, imports, post) <- parseImportsFromFile fp + (mn, pre, imports, post) <- parseImportsFromFile' fp let newImportSection = -- TODO: Open an issue when this PR is merged, we should optimise this -- so that this case does not write to disc diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 72943db55b..bad912f475 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -14,7 +14,6 @@ module Language.PureScript.Ide.SourceFile ( parseModule - , getImportsForFile , extractAstInformation -- for tests , extractSpans @@ -42,32 +41,6 @@ parseModule path = do Left _ -> pure (Left path) Right m -> pure (Right m) -getImports :: P.Module -> [(P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)] -getImports (P.Module _ _ _ declarations _) = - mapMaybe isImport declarations - where - isImport (P.PositionedDeclaration _ _ (P.ImportDeclaration a b c)) = Just (a, b, c) - isImport _ = Nothing - -getImportsForFile :: (MonadIO m, MonadError IdeError m) => - FilePath -> m [ModuleImport] -getImportsForFile fp = do - moduleE <- parseModule fp - case moduleE of - Left _ -> throwError (GeneralError "Failed to parse sourcefile.") - Right (_, module') -> - pure (mkModuleImport . unwrapPositionedImport <$> getImports module') - where - mkModuleImport (mn, importType', qualifier) = - ModuleImport - (P.runModuleName mn) - importType' - (P.runModuleName <$> qualifier) - unwrapPositionedImport (mn, it, q) = (mn, unwrapImportType it, q) - unwrapImportType (P.Explicit decls) = P.Explicit (map unwrapPositionedRef decls) - unwrapImportType (P.Hiding decls) = P.Hiding (map unwrapPositionedRef decls) - unwrapImportType P.Implicit = P.Implicit - -- | Extracts AST information from a parsed module extractAstInformation :: P.Module diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 96268ce3d9..a9271531a4 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -196,34 +196,6 @@ instance ToJSON Completion where , "documentation" .= complDocumentation ] -data ModuleImport = - ModuleImport - { importModuleName :: ModuleIdent - , importType :: P.ImportDeclarationType - , importQualifier :: Maybe Text - } deriving(Show) - -instance Eq ModuleImport where - mi1 == mi2 = - importModuleName mi1 == importModuleName mi2 - && importQualifier mi1 == importQualifier mi2 - -instance ToJSON ModuleImport where - toJSON (ModuleImport mn P.Implicit qualifier) = - object $ [ "module" .= mn - , "importType" .= ("implicit" :: Text) - ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) - toJSON (ModuleImport mn (P.Explicit refs) qualifier) = - object $ [ "module" .= mn - , "importType" .= ("explicit" :: Text) - , "identifiers" .= (identifierFromDeclarationRef <$> refs) - ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) - toJSON (ModuleImport mn (P.Hiding refs) qualifier) = - object $ [ "module" .= mn - , "importType" .= ("hiding" :: Text) - , "identifiers" .= (identifierFromDeclarationRef <$> refs) - ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) - identifierFromDeclarationRef :: P.DeclarationRef -> Text identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident @@ -238,7 +210,7 @@ data Success = | TextResult Text | MultilineTextResult [Text] | PursuitResult [PursuitResponse] - | ImportList [ModuleImport] + | ImportList (P.ModuleName, [(P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)]) | ModuleList [ModuleIdent] | RebuildSuccess P.MultipleErrors deriving (Show) @@ -252,10 +224,29 @@ instance ToJSON Success where toJSON (TextResult t) = encodeSuccess t toJSON (MultilineTextResult ts) = encodeSuccess ts toJSON (PursuitResult resp) = encodeSuccess resp - toJSON (ImportList decls) = encodeSuccess decls + toJSON (ImportList (moduleName, imports)) = object [ "resultType" .= ("success" :: Text) + , "result" .= object [ "imports" .= map encodeImport imports + , "moduleName" .= moduleName]] toJSON (ModuleList modules) = encodeSuccess modules toJSON (RebuildSuccess warnings) = encodeSuccess (P.toJSONErrors False P.Warning warnings) +encodeImport :: (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName) -> Value +encodeImport (P.runModuleName -> mn, importType, map P.runModuleName -> qualifier) = case importType of + P.Implicit -> + object $ [ "module" .= mn + , "importType" .= ("implicit" :: Text) + ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) + P.Explicit refs -> + object $ [ "module" .= mn + , "importType" .= ("explicit" :: Text) + , "identifiers" .= (identifierFromDeclarationRef <$> refs) + ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) + P.Hiding refs -> + object $ [ "module" .= mn + , "importType" .= ("hiding" :: Text) + , "identifiers" .= (identifierFromDeclarationRef <$> refs) + ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) + newtype PursuitQuery = PursuitQuery Text deriving (Show, Eq) From df9a1d3142f0bad25a025cb7f07d88af164df2c2 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 15 Mar 2017 08:54:33 -0700 Subject: [PATCH 0722/1580] ConstrainedType only takes a single Constraint (#2746) * ConstrainedType only takes a single Constraint * Tests --- src/Language/PureScript/AST/Exported.hs | 2 +- .../PureScript/Docs/Convert/ReExports.hs | 2 +- .../Docs/RenderedCode/RenderType.hs | 14 +-- src/Language/PureScript/Linter/Exhaustive.hs | 2 +- src/Language/PureScript/Parser/Types.hs | 4 +- src/Language/PureScript/Pretty/Types.hs | 9 +- .../PureScript/Sugar/BindingGroups.hs | 10 +- src/Language/PureScript/Sugar/Names.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 6 +- src/Language/PureScript/TypeChecker.hs | 8 +- src/Language/PureScript/TypeChecker/Kinds.hs | 11 +- .../PureScript/TypeChecker/Subsumption.hs | 4 +- src/Language/PureScript/TypeChecker/Types.hs | 24 ++-- src/Language/PureScript/TypeChecker/Unify.hs | 4 +- src/Language/PureScript/Types.hs | 105 ++++++------------ tests/TestDocs.hs | 8 +- 16 files changed, 83 insertions(+), 132 deletions(-) diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index 8c7c720962..759b9a3be4 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -108,7 +108,7 @@ typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) -- Note that type synonyms are disallowed in instance declarations, so -- we don't need to handle them here. go (TypeConstructor n) = [Right n] - go (ConstrainedType cs _) = concatMap fromConstraint cs + go (ConstrainedType c _) = fromConstraint c go _ = [] typeInstanceConstituents (PositionedDeclaration _ _ d) = typeInstanceConstituents d diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 5946020b8e..481fc60385 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -455,7 +455,7 @@ handleEnv TypeClassEnv{..} = ++ T.unpack cdeclTitle) addConstraint constraint = - P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint] + P.quantify . P.moveQuantifiersToFront . P.ConstrainedType constraint splitMap :: Map k (v1, v2) -> (Map k v1, Map k v2) splitMap = fmap fst &&& fmap snd diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index 0a697b8eec..e8dae4625f 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -62,17 +62,13 @@ renderConstraint (Constraint pn tys _) = let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys in renderType instApp -renderConstraints :: [Constraint] -> RenderedCode -> RenderedCode -renderConstraints deps ty = +renderConstraints :: Constraint -> RenderedCode -> RenderedCode +renderConstraints con ty = mintersperse sp - [ if length deps == 1 - then constraints - else syntax "(" <> constraints <> syntax ")" + [ renderConstraint con , syntax "=>" , ty ] - where - constraints = mintersperse (syntax "," <> sp) (map renderConstraint deps) -- | -- Render code representing a Row @@ -115,10 +111,10 @@ kinded = mkPattern match match (KindedType t k) = Just (k, t) match _ = Nothing -constrained :: Pattern () Type ([Constraint], Type) +constrained :: Pattern () Type (Constraint, Type) constrained = mkPattern match where - match (ConstrainedType deps ty) = Just (deps, ty) + match (ConstrainedType con ty) = Just (con, ty) match _ = Nothing explicitParens :: Pattern () Type ((), Type) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index e54b0751e2..64db3b13bd 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -301,7 +301,7 @@ checkExhaustive env mn numArgs cas expr = makeResult . first ordNub $ foldl' ste ty tyVar = ForAll tyVar ( ConstrainedType - [ Constraint C.Partial [] (Just constraintData) ] + (Constraint C.Partial [] (Just constraintData)) $ TypeApp (TypeApp tyFunction (TypeVar tyVar)) (TypeVar tyVar) ) Nothing diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 1953976f2b..4c29e497b7 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -70,11 +70,11 @@ parseTypeAtom = indented *> P.choice parseConstrainedType :: TokenParser Type parseConstrainedType = do - constraints <- return <$> parseConstraint + constraint <- parseConstraint _ <- rfatArrow indented ty <- parseType - return $ ConstrainedType constraints ty + return $ ConstrainedType constraint ty where parseConstraint = do className <- parseQualified properName diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index a2581996ef..bee62db14c 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -37,10 +37,9 @@ import Text.PrettyPrint.Boxes hiding ((<+>)) -- TODO(Christoph): get rid of T.unpack s -constraintsAsBox :: TypeRenderOptions -> [Constraint] -> Box -> Box -constraintsAsBox tro constraints ty = case constraints of - [con] -> text "(" <> constraintAsBox con `before` (") " <> text doubleRightArrow <> " " <> ty) - xs -> vcat left (zipWith (\i con -> text (if i == 0 then "( " else ", ") <> constraintAsBox con) [0 :: Int ..] xs) `before` (") " <> text doubleRightArrow <> " " <> ty) +constraintsAsBox :: TypeRenderOptions -> Constraint -> Box -> Box +constraintsAsBox tro con ty = + constraintAsBox con `before` (" " <> text doubleRightArrow <> " " <> ty) where doubleRightArrow = if troUnicode tro then "⇒" else "=>" @@ -105,7 +104,7 @@ insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes go idents other = PrettyPrintForAll idents other convertForAlls other = other -constrained :: Pattern () Type ([Constraint], Type) +constrained :: Pattern () Type (Constraint, Type) constrained = mkPattern match where match (ConstrainedType deps ty) = Just (deps, ty) diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index b319e44095..df391fb2ff 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -17,7 +17,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Data.Graph import Data.List (intersect) -import Data.Maybe (isJust, mapMaybe) +import Data.Maybe (isJust) import qualified Data.Set as S import Language.PureScript.AST @@ -142,11 +142,11 @@ usedTypeNames moduleName = in ordNub . f where usedNames :: Type -> [ProperName 'TypeName] - usedNames (ConstrainedType constraints _) = - flip mapMaybe constraints $ \case + usedNames (ConstrainedType con _) = + case con of (Constraint (Qualified (Just moduleName') name) _ _) - | moduleName == moduleName' -> Just (coerceProperName name) - _ -> Nothing + | moduleName == moduleName' -> [coerceProperName name] + _ -> [] usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name] usedNames _ = [] diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 39cc2ed6dc..0fb49ed2ff 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -276,7 +276,7 @@ renameInModule imports (Module ss coms mn decls exps) = updateType :: Type -> m Type updateType (TypeOp name) = TypeOp <$> updateTypeOpName name pos updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos - updateType (ConstrainedType cs t) = ConstrainedType <$> traverse updateInConstraint cs <*> pure t + updateType (ConstrainedType c t) = ConstrainedType <$> updateInConstraint c <*> pure t updateType (KindedType t k) = KindedType t <$> updateKindsEverywhere pos k updateType t = return t updateInConstraint :: Constraint -> m Constraint diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 6763ef01e9..73fe3d623b 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -186,7 +186,7 @@ desugarDecl mn exps = go return (expRef name className tys, [d, dictDecl]) go d@(TypeInstanceDeclaration name deps className tys (NewtypeInstanceWithDictionary dict)) = do let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys - constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy) + constrainedTy = quantify (foldr ConstrainedType dictTy deps) return (expRef name className tys, [d, ValueDeclaration name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) go (PositionedDeclaration pos com d) = do (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d @@ -252,7 +252,7 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) = in ValueDeclaration ident Private [] $ [MkUnguarded ( TypedValue False (TypeClassDictionaryAccessor className ident) $ - moveQuantifiersToFront (quantify (ConstrainedType [Constraint className (map (TypeVar . fst) args) Nothing] ty)) + moveQuantifiersToFront (quantify (ConstrainedType (Constraint className (map (TypeVar . fst) args) Nothing) ty)) )] typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) = PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d @@ -300,7 +300,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = let props = Literal $ ObjectLiteral $ map (first mkString) (members ++ superclasses) dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys - constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy) + constrainedTy = quantify (foldr ConstrainedType dictTy deps) dict = TypeClassDictionaryConstructorApp className props result = ValueDeclaration name Private [] [MkUnguarded (TypedValue True dict constrainedTy)] return result diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 22a656e332..1323b575ed 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -482,11 +482,11 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = findClasses :: Type -> [DeclarationRef] findClasses = everythingOnTypes (++) go where - go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . constraintClass) cs + go (ConstrainedType c _) = (fmap TypeClassRef . extractCurrentModuleClass . constraintClass) c go _ = [] - extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName) - extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name - extractCurrentModuleClass _ = Nothing + extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> [ProperName 'ClassName] + extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = [name] + extractCurrentModuleClass _ = [] checkClassMembersAreExported :: DeclarationRef -> m () checkClassMembersAreExported dr@(TypeClassRef name) = do diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index b951431fcc..4ca12487a5 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -256,11 +256,10 @@ infer' other = (, []) <$> go other k2 <- go row unifyKinds k2 (Row k1) return $ Row k1 - go (ConstrainedType deps ty) = do - forM_ deps $ \(Constraint className tys _) -> do - k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys - unifyKinds k kindType - k <- go ty - unifyKinds k kindType + go (ConstrainedType (Constraint className tys _) ty) = do + k1 <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys + unifyKinds k1 kindType + k2 <- go ty + unifyKinds k2 kindType return kindType go ty = internalError $ "Invalid argument to infer: " ++ show ty diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 038ce80a5b..65d6a91ba3 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -96,11 +96,11 @@ subsumes' mode ty1 (KindedType ty2 _) = subsumes' mode ty1 ty2 -- Only check subsumption for constrained types when elaborating. -- Otherwise fall back to unification. -subsumes' SElaborate (ConstrainedType constraints ty1) ty2 = do +subsumes' SElaborate (ConstrainedType con ty1) ty2 = do dicts <- getTypeClassDictionaries hints <- getHints elaborate <- subsumes' SElaborate ty1 ty2 - let addDicts val = foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints) + let addDicts val = App val (TypeClassDictionary con dicts hints) return (elaborate . addDicts) subsumes' mode (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do let (common, ((ts1', r1'), (ts2', r2'))) = alignRowsWith (subsumes' SNoElaborate) r1 r2 diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index a82bed1844..be27c4db2b 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -158,8 +158,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do generalize unsolved = varIfUnknown . constrain unsolved -- | Add any unsolved constraints - constrain [] = id - constrain cs = ConstrainedType (map (\(_, _, x) -> x) cs) + constrain cs ty = foldr ConstrainedType ty (map (\(_, _, x) -> x) cs) -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values tidyUp ts sub = first (map (second (first (second (overTypes (substituteType sub) *** substituteType sub))))) ts @@ -281,10 +280,10 @@ instantiatePolyTypeWithUnknowns instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do ty' <- replaceVarWithUnknown ident ty instantiatePolyTypeWithUnknowns val ty' -instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do +instantiatePolyTypeWithUnknowns val (ConstrainedType con ty) = do dicts <- getTypeClassDictionaries hints <- getHints - instantiatePolyTypeWithUnknowns (foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty + instantiatePolyTypeWithUnknowns (App val (TypeClassDictionary con dicts hints)) ty instantiatePolyTypeWithUnknowns val ty = return (val, ty) -- | Infer a type for a value, rethrowing any error to provide a more useful error message @@ -362,10 +361,10 @@ infer' (Var var) = do checkVisibility var ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable $ var case ty of - ConstrainedType constraints ty' -> do + ConstrainedType con ty' -> do dicts <- getTypeClassDictionaries hints <- getHints - return $ TypedValue True (foldl App (Var var) (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty' + return $ TypedValue True (App (Var var) (TypeClassDictionary con dicts hints)) ty' _ -> return $ TypedValue True (Var var) ty infer' v@(Constructor c) = do env <- getEnv @@ -610,12 +609,11 @@ check' val (ForAll ident ty _) = do skVal = skolemizeTypesInValue ident sko scope ss val val' <- check skVal sk return $ TypedValue True val' (ForAll ident ty (Just scope)) -check' val t@(ConstrainedType constraints ty) = do - dictNames <- forM constraints $ \(Constraint (Qualified _ (ProperName className)) _ _) -> - freshIdent ("dict" <> className) - dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints +check' val t@(ConstrainedType con@(Constraint (Qualified _ (ProperName className)) _ _) ty) = do + dictName <- freshIdent ("dict" <> className) + dicts <- newDictionaries [] (Qualified Nothing dictName) con val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty - return $ TypedValue True (foldr (Abs . VarBinder) val' dictNames) t + return $ TypedValue True (Abs (VarBinder dictName) val') t check' val u@(TUnknown _) = do val'@(TypedValue _ _ ty) <- infer val -- Don't unify an unknown with an inferred polytype @@ -808,10 +806,10 @@ checkFunctionApplication' fn (ForAll ident ty _) arg = do checkFunctionApplication fn replaced arg checkFunctionApplication' fn (KindedType ty _) arg = checkFunctionApplication fn ty arg -checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg = do +checkFunctionApplication' fn (ConstrainedType con fnTy) arg = do dicts <- getTypeClassDictionaries hints <- getHints - checkFunctionApplication' (foldl App fn (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) fnTy arg + checkFunctionApplication' (App fn (TypeClassDictionary con dicts hints)) fnTy arg checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} = return (fnTy, App fn dict) checkFunctionApplication' fn u arg = do diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 804c1c4329..04186dbc93 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -118,9 +118,9 @@ unifyTypes t1 t2 = do unifyTypes' r1 r2@RCons{} = unifyRows r1 r2 unifyTypes' r1@REmpty r2 = unifyRows r1 r2 unifyTypes' r1 r2@REmpty = unifyRows r1 r2 - unifyTypes' ty1@(ConstrainedType _ _) ty2 = + unifyTypes' ty1@ConstrainedType{} ty2 = throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2 - unifyTypes' t3 t4@(ConstrainedType _ _) = unifyTypes' t4 t3 + unifyTypes' t3 t4@ConstrainedType{} = unifyTypes' t4 t3 unifyTypes' t3 t4 = throwError . errorMessage $ TypesDoNotUnify t3 t4 diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index cbb3e35885..f68a5aa827 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -54,7 +54,7 @@ data Type -- | Forall quantifier | ForAll Text Type (Maybe SkolemScope) -- | A type with a set of type class constraints - | ConstrainedType [Constraint] Type + | ConstrainedType Constraint Type -- | A skolem constant | Skolem Text Int SkolemScope (Maybe SourceSpan) -- | An empty row @@ -132,25 +132,17 @@ isMonoType (ParensInType t) = isMonoType t isMonoType (KindedType t _) = isMonoType t isMonoType _ = True --- | --- Universally quantify a type --- +-- | Universally quantify a type mkForAll :: [Text] -> Type -> Type mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args --- | --- Replace a type variable, taking into account variable shadowing --- +-- | Replace a type variable, taking into account variable shadowing replaceTypeVars :: Text -> Type -> Type -> Type replaceTypeVars v r = replaceAllTypeVars [(v, r)] --- | --- Replace named type variables with types --- +-- | Replace named type variables with types replaceAllTypeVars :: [(Text, Type)] -> Type -> Type -replaceAllTypeVars = go [] - where - +replaceAllTypeVars = go [] where go :: [Text] -> [(Text, Type)] -> Type -> Type go _ m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m) go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2) @@ -161,89 +153,63 @@ replaceAllTypeVars = go [] in ForAll v' (go (v' : bs) m t') sco | otherwise = ForAll v (go (v : bs) m t) sco where - keys = map fst m - usedVars = concatMap (usedTypeVariables . snd) m - go bs m (ConstrainedType cs t) = ConstrainedType (map (mapConstraintArgs (map (go bs m))) cs) (go bs m t) + keys = map fst m + usedVars = concatMap (usedTypeVariables . snd) m + go bs m (ConstrainedType c t) = ConstrainedType (mapConstraintArgs (map (go bs m)) c) (go bs m t) go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r) go bs m (KindedType t k) = KindedType (go bs m t) k go bs m (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go bs m t1) (go bs m t2) (go bs m t3) go bs m (ParensInType t) = ParensInType (go bs m t) go _ _ ty = ty - genName orig inUse = try' 0 - where + genName orig inUse = try' 0 where try' :: Integer -> Text try' n | (orig <> T.pack (show n)) `elem` inUse = try' (n + 1) | otherwise = orig <> T.pack (show n) --- | --- Collect all type variables appearing in a type --- +-- | Collect all type variables appearing in a type usedTypeVariables :: Type -> [Text] -usedTypeVariables = ordNub . everythingOnTypes (++) go - where +usedTypeVariables = ordNub . everythingOnTypes (++) go where go (TypeVar v) = [v] go _ = [] --- | --- Collect all free type variables appearing in a type --- +-- | Collect all free type variables appearing in a type freeTypeVariables :: Type -> [Text] -freeTypeVariables = ordNub . go [] - where +freeTypeVariables = ordNub . go [] where go :: [Text] -> Type -> [Text] go bound (TypeVar v) | v `notElem` bound = [v] go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2 go bound (ForAll v t _) = go (v : bound) t - go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . constraintArgs) cs ++ go bound t + go bound (ConstrainedType c t) = concatMap (go bound) (constraintArgs c) ++ go bound t go bound (RCons _ t r) = go bound t ++ go bound r go bound (KindedType t _) = go bound t go bound (BinaryNoParensType t1 t2 t3) = go bound t1 ++ go bound t2 ++ go bound t3 go bound (ParensInType t) = go bound t go _ _ = [] --- | --- Universally quantify over all type variables appearing free in a type --- +-- | Universally quantify over all type variables appearing free in a type quantify :: Type -> Type quantify ty = foldr (\arg t -> ForAll arg t Nothing) ty $ freeTypeVariables ty --- | --- Move all universal quantifiers to the front of a type --- +-- | Move all universal quantifiers to the front of a type moveQuantifiersToFront :: Type -> Type -moveQuantifiersToFront = go [] [] - where +moveQuantifiersToFront = go [] [] where go qs cs (ForAll q ty sco) = go ((q, sco) : qs) cs ty - go qs cs (ConstrainedType cs' ty) = go qs (cs ++ cs') ty - go qs cs ty = - let constrained = case cs of - [] -> ty - cs' -> ConstrainedType cs' ty - in case qs of - [] -> constrained - qs' -> foldl (\ty' (q, sco) -> ForAll q ty' sco) constrained qs' + go qs cs (ConstrainedType c ty) = go qs (c : cs) ty + go qs cs ty = foldl (\ty' (q, sco) -> ForAll q ty' sco) (foldl (flip ConstrainedType) ty cs) qs --- | --- Check if a type contains wildcards --- +-- | Check if a type contains wildcards containsWildcards :: Type -> Bool -containsWildcards = everythingOnTypes (||) go - where +containsWildcards = everythingOnTypes (||) go where go :: Type -> Bool go TypeWildcard{} = True go _ = False --- --- Traversals --- - everywhereOnTypes :: (Type -> Type) -> Type -> Type -everywhereOnTypes f = go - where +everywhereOnTypes f = go where go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2)) go (ForAll arg ty sco) = f (ForAll arg (go ty) sco) - go (ConstrainedType cs ty) = f (ConstrainedType (map (mapConstraintArgs (map go)) cs) (go ty)) + go (ConstrainedType c ty) = f (ConstrainedType (mapConstraintArgs (map go) c) (go ty)) go (RCons name ty rest) = f (RCons name (go ty) (go rest)) go (KindedType ty k) = f (KindedType (go ty) k) go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2)) @@ -254,11 +220,10 @@ everywhereOnTypes f = go go other = f other everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type -everywhereOnTypesTopDown f = go . f - where +everywhereOnTypesTopDown f = go . f where go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2)) go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco - go (ConstrainedType cs ty) = ConstrainedType (map (mapConstraintArgs (map (go . f))) cs) (go (f ty)) + go (ConstrainedType c ty) = ConstrainedType (mapConstraintArgs (map (go . f)) c) (go (f ty)) go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest)) go (KindedType ty k) = KindedType (go (f ty)) k go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2)) @@ -269,11 +234,10 @@ everywhereOnTypesTopDown f = go . f go other = f other everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type -everywhereOnTypesM f = go - where +everywhereOnTypesM f = go where go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f - go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (overConstraintArgs (mapM go)) cs <*> go ty) >>= f + go (ConstrainedType c ty) = (ConstrainedType <$> overConstraintArgs (mapM go) c <*> go ty) >>= f go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f go (KindedType ty k) = (KindedType <$> go ty <*> pure k) >>= f go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f @@ -284,11 +248,10 @@ everywhereOnTypesM f = go go other = f other everywhereOnTypesTopDownM :: Monad m => (Type -> m Type) -> Type -> m Type -everywhereOnTypesTopDownM f = go <=< f - where +everywhereOnTypesTopDownM f = go <=< f where go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go) go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco - go (ConstrainedType cs ty) = ConstrainedType <$> mapM (overConstraintArgs (mapM (go <=< f))) cs <*> (f ty >>= go) + go (ConstrainedType c ty) = ConstrainedType <$> overConstraintArgs (mapM (go <=< f)) c <*> (f ty >>= go) go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go) go (KindedType ty k) = KindedType <$> (f ty >>= go) <*> pure k go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go) @@ -299,11 +262,10 @@ everywhereOnTypesTopDownM f = go <=< f go other = f other everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r -everythingOnTypes (<+>) f = go - where +everythingOnTypes (<+>) f = go where go t@(TypeApp t1 t2) = f t <+> go t1 <+> go t2 go t@(ForAll _ ty _) = f t <+> go ty - go t@(ConstrainedType cs ty) = foldl (<+>) (f t) (map go $ concatMap constraintArgs cs) <+> go ty + go t@(ConstrainedType c ty) = foldl (<+>) (f t) (map go (constraintArgs c)) <+> go ty go t@(RCons _ ty rest) = f t <+> go ty <+> go rest go t@(KindedType ty _) = f t <+> go ty go t@(PrettyPrintFunction t1 t2) = f t <+> go t1 <+> go t2 @@ -314,12 +276,11 @@ everythingOnTypes (<+>) f = go go other = f other everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type -> (s, r)) -> Type -> r -everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 - where +everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 where go' s t = let (s', r) = f s t in r <+> go s' t go s (TypeApp t1 t2) = go' s t1 <+> go' s t2 go s (ForAll _ ty _) = go' s ty - go s (ConstrainedType cs ty) = foldl (<+>) r0 (map (go' s) $ concatMap constraintArgs cs) <+> go' s ty + go s (ConstrainedType c ty) = foldl (<+>) r0 (map (go' s) (constraintArgs c)) <+> go' s ty go s (RCons _ ty rest) = go' s ty <+> go' s rest go s (KindedType ty _) = go' s ty go s (PrettyPrintFunction t1 t2) = go' s t1 <+> go' s t2 diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 48bf04c57c..34863ea339 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -276,12 +276,10 @@ runAssertion assertion linksCtx Docs.Module{..} = checkConstrained :: P.Type -> Text -> Bool checkConstrained ty tyClass = - -- Note that we don't recurse on ConstrainedType if none of the constraints - -- match; this is by design, as constraints should be moved to the front - -- anyway. case ty of - P.ConstrainedType cs _ | any (matches tyClass) cs -> - True + P.ConstrainedType c ty' + | matches tyClass c -> True + | otherwise -> checkConstrained ty' tyClass P.ForAll _ ty' _ -> checkConstrained ty' tyClass _ -> From 42d9ee9f67748809802289617abc50e4f618f30c Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Sun, 19 Mar 2017 19:45:03 +0300 Subject: [PATCH 0723/1580] Add test for #2756 (#2758) --- examples/passing/2756.purs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 examples/passing/2756.purs diff --git a/examples/passing/2756.purs b/examples/passing/2756.purs new file mode 100644 index 0000000000..81e5660f60 --- /dev/null +++ b/examples/passing/2756.purs @@ -0,0 +1,20 @@ +module Main where + +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (log) +import Prelude + +pu :: forall eff. Eff eff Unit +pu = pure unit + +type C eff = { pu :: Eff eff Unit } + +sampleC :: C () +sampleC = { pu: pu } + +newtype Identity a = Id a + +sampleIdC :: Identity (C ()) +sampleIdC = Id { pu : pu } + +main = log "Done" From 2ffa71d8eccfa911bc7d8a960ced24bb74ddd9ad Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 19 Mar 2017 21:10:10 +0000 Subject: [PATCH 0724/1580] Add "--format html" to psc-docs (#2733) Following on from #2520. This commit adds a --format html option to psc-docs which produces HTML documentation in a given directory. All HTML pages are self-contained (in particular, the CSS is duplicated in every page; it's not very large though, so I don't think this is a problem), and all links are relative, so it should be easy to just stick these HTML files pretty much anywhere and have them 'just work'. The CSS is copied from Pursuit's CSS, with a minor change made via inline styles where we want to differ slightly from what Pursuit does in the header. We also generate an 'index.html' file with a list of all the modules in the documentation bundle. --- app/Command/Docs.hs | 36 +- app/Command/Docs/Html.hs | 181 +++++++ app/Main.hs | 22 +- app/Version.hs | 23 + app/static/normalize.css | 427 +++++++++++++++ app/static/pursuit.css | 703 +++++++++++++++++++++++++ purescript.cabal | 4 + src/Language/PureScript/Docs/AsHtml.hs | 11 +- 8 files changed, 1374 insertions(+), 33 deletions(-) create mode 100644 app/Command/Docs/Html.hs create mode 100644 app/Version.hs create mode 100644 app/static/normalize.css create mode 100644 app/static/pursuit.css diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index ca0aac7fb6..8e728eb19c 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -6,6 +6,7 @@ import Protolude (ordNub) import Command.Docs.Etags import Command.Docs.Ctags +import Command.Docs.Html import Control.Applicative import Control.Arrow (first, second) import Control.Category ((>>>)) @@ -30,11 +31,13 @@ import System.FilePath.Glob (glob) import System.IO (hPutStrLn, hPrint, stderr) import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT) --- Available output formats -data Format = Markdown -- Output documentation in Markdown format - | Ctags -- Output ctags symbol index suitable for use with vi - | Etags -- Output etags symbol index suitable for use with emacs - deriving (Show, Eq, Ord) +-- | Available output formats +data Format + = Markdown + | Html + | Ctags -- Output ctags symbol index suitable for use with vi + | Etags -- Output etags symbol index suitable for use with emacs + deriving (Show, Eq, Ord) -- | Available methods of outputting Markdown documentation data DocgenOutput @@ -53,13 +56,22 @@ data PSCDocsOptions = PSCDocsOptions docgen :: PSCDocsOptions -> IO () docgen (PSCDocsOptions fmt inputGlob output) = do input <- concat <$> mapM glob inputGlob + when (null input) $ do + hPutStrLn stderr "purs docs: no input files." + exitFailure + case fmt of Etags -> dumpTags input dumpEtags Ctags -> dumpTags input dumpCtags + Html -> do + let outputDir = "./generated-docs" -- TODO: make this configurable + ms <- parseAndConvert input + let msHtml = map asHtml (D.primDocsModule : ms) + createDirectoryIfMissing False outputDir + writeHtmlModules outputDir msHtml + Markdown -> do - ms <- runExceptT (D.parseFilesInPackages input [] - >>= uncurry D.convertModulesInPackage) - >>= successOrExit + ms <- parseAndConvert input case output of EverythingToStdOut -> @@ -101,6 +113,11 @@ docgen (PSCDocsOptions fmt inputGlob output) = do takeByName = takeModulesByName D.modName takeByName' = takeModulesByName' D.modName + parseAndConvert input = + runExceptT (D.parseFilesInPackages input [] + >>= uncurry D.convertModulesInPackage) + >>= successOrExit + -- | -- Given a list of module names and a list of modules, return a list of modules -- whose names appeared in the given name list, together with a list of names @@ -151,13 +168,14 @@ instance Read Format where readsPrec _ "etags" = [(Etags, "")] readsPrec _ "ctags" = [(Ctags, "")] readsPrec _ "markdown" = [(Markdown, "")] + readsPrec _ "html" = [(Html, "")] readsPrec _ _ = [] format :: Opts.Parser Format format = Opts.option Opts.auto $ Opts.value Markdown <> Opts.long "format" <> Opts.metavar "FORMAT" - <> Opts.help "Set output FORMAT (markdown | etags | ctags)" + <> Opts.help "Set output FORMAT (markdown | html | etags | ctags)" docgenModule :: Opts.Parser String docgenModule = Opts.strOption $ diff --git a/app/Command/Docs/Html.hs b/app/Command/Docs/Html.hs new file mode 100644 index 0000000000..507917e98a --- /dev/null +++ b/app/Command/Docs/Html.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module Command.Docs.Html + ( asHtml + , layout + , writeHtmlModule + , writeHtmlModules + ) where + +import Control.Applicative +import Control.Arrow ((&&&)) +import Control.Monad.Writer +import Data.List (sort) +import Data.Text (Text) +import Data.Text.Lazy (toStrict) +import qualified Data.Text as T +import Data.FileEmbed (embedStringFile) +import qualified Language.PureScript as P +import qualified Language.PureScript.Docs as D +import qualified Language.PureScript.Docs.AsHtml as D +import Text.Blaze.Html5 (Html, (!), toMarkup) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import qualified Text.Blaze.Html.Renderer.Text as Blaze +import System.IO.UTF8 (writeUTF8FileT) +import System.FilePath.Glob (glob) +import System.Directory (removeFile) +import Version (versionString) + +writeHtmlModules :: FilePath -> [(P.ModuleName, D.HtmlOutputModule Html)] -> IO () +writeHtmlModules outputDir modules = do + glob (outputDir <> "/*.html") >>= mapM_ removeFile + let moduleList = sort $ map fst modules + writeHtmlFile (outputDir ++ "/index.html") (renderIndexModule moduleList) + mapM_ (writeHtmlModule outputDir . (fst &&& layout moduleList)) modules + +asHtml :: D.Module -> (P.ModuleName, D.HtmlOutputModule Html) +asHtml m = D.moduleAsHtml (getHtmlRenderContext (D.modName m)) m + +writeHtmlModule :: FilePath -> (P.ModuleName, Html) -> IO () +writeHtmlModule outputDir (mn, html) = do + let filepath = outputDir ++ "/" ++ T.unpack (P.runModuleName mn) ++ ".html" + writeHtmlFile filepath html + +writeHtmlFile :: FilePath -> Html -> IO () +writeHtmlFile filepath = + writeUTF8FileT filepath . toStrict . Blaze.renderHtml + +getHtmlRenderContext :: P.ModuleName -> D.HtmlRenderContext +getHtmlRenderContext mn = D.HtmlRenderContext + { D.currentModuleName = mn + , D.buildDocLink = getLink mn + , D.renderDocLink = renderLink + , D.renderSourceLink = const Nothing + } + +-- TODO: try to combine this with the one in Docs.Types? +getLink :: P.ModuleName -> D.Namespace -> Text -> D.ContainingModule -> Maybe D.DocLink +getLink curMn namespace target containingMod = do + location <- getLinkLocation + return D.DocLink + { D.linkLocation = location + , D.linkTitle = target + , D.linkNamespace = namespace + } + + where + getLinkLocation = builtinLinkLocation <|> normalLinkLocation + + normalLinkLocation = do + case containingMod of + D.ThisModule -> + return D.SameModule + D.OtherModule destMn -> + -- This is OK because all modules count as 'local' for purs docs in + -- html mode + return $ D.LocalModule curMn destMn + + builtinLinkLocation = do + let primMn = P.moduleNameFromString "Prim" + guard $ containingMod == D.OtherModule primMn + return $ D.BuiltinModule primMn + +renderLink :: D.DocLink -> Text +renderLink l = + case D.linkLocation l of + D.SameModule -> + "" + D.LocalModule _ dest -> + P.runModuleName dest <> ".html" + D.DepsModule{} -> + P.internalError "DepsModule: not implemented" + D.BuiltinModule dest -> + P.runModuleName dest <> ".html" + +layout :: [P.ModuleName] -> (P.ModuleName, D.HtmlOutputModule Html) -> Html +layout moduleList (mn, htmlDocs) = + basicLayout ("PureScript: " <> modName) $ do + H.div ! A.class_ "page-title clearfix" $ do + H.div ! A.class_ "page-title__label" $ "Module" + H.h1 ! A.class_ "page-title__title" $ toMarkup modName + + H.div ! A.class_ "col col--main" $ do + D.htmlOutputModuleLocals htmlDocs + mapM_ renderReExports (D.htmlOutputModuleReExports htmlDocs) + + H.div ! A.class_ "col col--aside" $ do + H.h3 "Modules" + renderModuleList moduleList + where + modName = P.runModuleName mn + + renderReExports :: (D.InPackage P.ModuleName, Html) -> Html + renderReExports (reExpFrom, html) = do + H.h2 ! A.class_ "re-exports" $ do + toMarkup ("Re-exports from " :: Text) + H.a ! A.href (H.toValue (toText reExpFrom <> ".html")) $ + toMarkup (toText reExpFrom) + html + + toText = P.runModuleName . D.ignorePackage + +basicLayout :: Text -> Html -> Html +basicLayout title inner = + H.docTypeHtml $ do + H.head $ do + H.meta ! A.charset "utf-8" + H.meta ! A.httpEquiv "X-UA-Compatible" ! A.content "IE=edge" + H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1" + H.title (toMarkup title) + + H.link ! A.href "https://fonts.googleapis.com/css?family=Roboto+Mono|Roboto:300,400,400i,700,700i" + ! A.type_ "text/css" ! A.rel "stylesheet" + H.style ! A.type_ "text/css" $ + toMarkup normalize_css + H.style ! A.type_ "text/css" $ + toMarkup pursuit_css + H.body $ do + H.div ! A.class_ "everything-except-footer" $ do + H.div ! A.class_ "top-banner clearfix" $ do + H.div ! A.class_ "container clearfix" $ do + H.div ! A.style inlineHeaderStyles $ do + "PureScript API documentation" + + H.div ! A.class_ "top-banner__actions" $ do + H.div ! A.class_ "top-banner__actions__item" $ do + H.a ! A.href "index.html" $ "Index" + + H.main ! A.class_ "container clearfix" ! H.customAttribute "role" "main" $ do + inner + + H.div ! A.class_ "footer clearfix" $ + H.p $ toMarkup $ "Generated by purs " <> versionString + + where + -- Like Pursuit's .top-banner__logo except without the 'hover' styles + inlineHeaderStyles = "float: left; font-size: 2.44em; font-weight: 300; line-height: 90px; margin: 0" + +renderIndexModule :: [P.ModuleName] -> Html +renderIndexModule moduleList = + basicLayout "PureScript API documentation" $ do + H.div ! A.class_ "page-title clearfix" $ do + H.h1 ! A.class_ "page-title__title" $ "Index" + H.div ! A.class_ "col col--main" $ do + renderModuleList moduleList + +renderModuleList :: [P.ModuleName] -> Html +renderModuleList moduleList = + H.ul $ mapM_ listItem moduleList + + where + listItem mn = H.li $ + H.a ! A.href (H.toValue (P.runModuleName mn <> ".html")) $ + toMarkup (P.runModuleName mn) + +normalize_css :: Text +normalize_css = $(embedStringFile "app/static/normalize.css") + +pursuit_css :: Text +pursuit_css = $(embedStringFile "app/static/pursuit.css") diff --git a/app/Main.hs b/app/Main.hs index 8f69c0fcb1..6e4b60d7f4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,8 +4,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} module Main where @@ -18,14 +16,10 @@ import qualified Command.Publish as Publish import qualified Command.REPL as REPL import Data.Foldable (fold) import Data.Monoid ((<>)) -import Data.Version (showVersion) import qualified Options.Applicative as Opts -import qualified Paths_purescript as Paths import qualified System.IO as IO +import Version (versionString) -#ifndef RELEASE -import qualified Development.GitRev as GitRev -#endif main :: IO () main = do @@ -37,7 +31,7 @@ main = do opts = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList infoModList = Opts.fullDesc <> headerInfo <> footerInfo headerInfo = Opts.progDesc "The PureScript compiler and tools" - footerInfo = Opts.footer $ "purs " ++ showVersion Paths.version + footerInfo = Opts.footer $ "purs " ++ versionString versionInfo :: Opts.Parser (a -> a) versionInfo = Opts.abortOption (Opts.InfoMsg versionString) $ @@ -68,15 +62,3 @@ main = do (Opts.info REPL.command (Opts.progDesc "Enter the interactive mode (PSCi)")) ] - -versionString :: String -versionString = showVersion Paths.version ++ extra - where -#ifdef RELEASE - extra = "" -#else - extra = " [development build; commit: " ++ $(GitRev.gitHash) ++ dirty ++ "]" - dirty - | $(GitRev.gitDirty) = " DIRTY" - | otherwise = "" -#endif diff --git a/app/Version.hs b/app/Version.hs new file mode 100644 index 0000000000..dcf385041a --- /dev/null +++ b/app/Version.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module Version where + +import Data.Version (showVersion) +import Paths_purescript as Paths + +#ifndef RELEASE +import qualified Development.GitRev as GitRev +#endif + +versionString :: String +versionString = showVersion Paths.version ++ extra + where +#ifdef RELEASE + extra = "" +#else + extra = " [development build; commit: " ++ $(GitRev.gitHash) ++ dirty ++ "]" + dirty + | $(GitRev.gitDirty) = " DIRTY" + | otherwise = "" +#endif diff --git a/app/static/normalize.css b/app/static/normalize.css new file mode 100644 index 0000000000..458eea1ea3 --- /dev/null +++ b/app/static/normalize.css @@ -0,0 +1,427 @@ +/*! normalize.css v3.0.2 | MIT License | git.io/normalize */ + +/** + * 1. Set default font family to sans-serif. + * 2. Prevent iOS text size adjust after orientation change, without disabling + * user zoom. + */ + +html { + font-family: sans-serif; /* 1 */ + -ms-text-size-adjust: 100%; /* 2 */ + -webkit-text-size-adjust: 100%; /* 2 */ +} + +/** + * Remove default margin. + */ + +body { + margin: 0; +} + +/* HTML5 display definitions + ========================================================================== */ + +/** + * Correct `block` display not defined for any HTML5 element in IE 8/9. + * Correct `block` display not defined for `details` or `summary` in IE 10/11 + * and Firefox. + * Correct `block` display not defined for `main` in IE 11. + */ + +article, +aside, +details, +figcaption, +figure, +footer, +header, +hgroup, +main, +menu, +nav, +section, +summary { + display: block; +} + +/** + * 1. Correct `inline-block` display not defined in IE 8/9. + * 2. Normalize vertical alignment of `progress` in Chrome, Firefox, and Opera. + */ + +audio, +canvas, +progress, +video { + display: inline-block; /* 1 */ + vertical-align: baseline; /* 2 */ +} + +/** + * Prevent modern browsers from displaying `audio` without controls. + * Remove excess height in iOS 5 devices. + */ + +audio:not([controls]) { + display: none; + height: 0; +} + +/** + * Address `[hidden]` styling not present in IE 8/9/10. + * Hide the `template` element in IE 8/9/11, Safari, and Firefox < 22. + */ + +[hidden], +template { + display: none; +} + +/* Links + ========================================================================== */ + +/** + * Remove the gray background color from active links in IE 10. + */ + +a { + background-color: transparent; +} + +/** + * Improve readability when focused and also mouse hovered in all browsers. + */ + +a:active, +a:hover { + outline: 0; +} + +/* Text-level semantics + ========================================================================== */ + +/** + * Address styling not present in IE 8/9/10/11, Safari, and Chrome. + */ + +abbr[title] { + border-bottom: 1px dotted; +} + +/** + * Address style set to `bolder` in Firefox 4+, Safari, and Chrome. + */ + +b, +strong { + font-weight: bold; +} + +/** + * Address styling not present in Safari and Chrome. + */ + +dfn { + font-style: italic; +} + +/** + * Address variable `h1` font-size and margin within `section` and `article` + * contexts in Firefox 4+, Safari, and Chrome. + */ + +h1 { + font-size: 2em; + margin: 0.67em 0; +} + +/** + * Address styling not present in IE 8/9. + */ + +mark { + background: #ff0; + color: #000; +} + +/** + * Address inconsistent and variable font size in all browsers. + */ + +small { + font-size: 80%; +} + +/** + * Prevent `sub` and `sup` affecting `line-height` in all browsers. + */ + +sub, +sup { + font-size: 75%; + line-height: 0; + position: relative; + vertical-align: baseline; +} + +sup { + top: -0.5em; +} + +sub { + bottom: -0.25em; +} + +/* Embedded content + ========================================================================== */ + +/** + * Remove border when inside `a` element in IE 8/9/10. + */ + +img { + border: 0; +} + +/** + * Correct overflow not hidden in IE 9/10/11. + */ + +svg:not(:root) { + overflow: hidden; +} + +/* Grouping content + ========================================================================== */ + +/** + * Address margin not present in IE 8/9 and Safari. + */ + +figure { + margin: 1em 40px; +} + +/** + * Address differences between Firefox and other browsers. + */ + +hr { + -moz-box-sizing: content-box; + box-sizing: content-box; + height: 0; +} + +/** + * Contain overflow in all browsers. + */ + +pre { + overflow: auto; +} + +/** + * Address odd `em`-unit font size rendering in all browsers. + */ + +code, +kbd, +pre, +samp { + font-family: monospace, monospace; + font-size: 1em; +} + +/* Forms + ========================================================================== */ + +/** + * Known limitation: by default, Chrome and Safari on OS X allow very limited + * styling of `select`, unless a `border` property is set. + */ + +/** + * 1. Correct color not being inherited. + * Known issue: affects color of disabled elements. + * 2. Correct font properties not being inherited. + * 3. Address margins set differently in Firefox 4+, Safari, and Chrome. + */ + +button, +input, +optgroup, +select, +textarea { + color: inherit; /* 1 */ + font: inherit; /* 2 */ + margin: 0; /* 3 */ +} + +/** + * Address `overflow` set to `hidden` in IE 8/9/10/11. + */ + +button { + overflow: visible; +} + +/** + * Address inconsistent `text-transform` inheritance for `button` and `select`. + * All other form control elements do not inherit `text-transform` values. + * Correct `button` style inheritance in Firefox, IE 8/9/10/11, and Opera. + * Correct `select` style inheritance in Firefox. + */ + +button, +select { + text-transform: none; +} + +/** + * 1. Avoid the WebKit bug in Android 4.0.* where (2) destroys native `audio` + * and `video` controls. + * 2. Correct inability to style clickable `input` types in iOS. + * 3. Improve usability and consistency of cursor style between image-type + * `input` and others. + */ + +button, +html input[type="button"], /* 1 */ +input[type="reset"], +input[type="submit"] { + -webkit-appearance: button; /* 2 */ + cursor: pointer; /* 3 */ +} + +/** + * Re-set default cursor for disabled elements. + */ + +button[disabled], +html input[disabled] { + cursor: default; +} + +/** + * Remove inner padding and border in Firefox 4+. + */ + +button::-moz-focus-inner, +input::-moz-focus-inner { + border: 0; + padding: 0; +} + +/** + * Address Firefox 4+ setting `line-height` on `input` using `!important` in + * the UA stylesheet. + */ + +input { + line-height: normal; +} + +/** + * It's recommended that you don't attempt to style these elements. + * Firefox's implementation doesn't respect box-sizing, padding, or width. + * + * 1. Address box sizing set to `content-box` in IE 8/9/10. + * 2. Remove excess padding in IE 8/9/10. + */ + +input[type="checkbox"], +input[type="radio"] { + box-sizing: border-box; /* 1 */ + padding: 0; /* 2 */ +} + +/** + * Fix the cursor style for Chrome's increment/decrement buttons. For certain + * `font-size` values of the `input`, it causes the cursor style of the + * decrement button to change from `default` to `text`. + */ + +input[type="number"]::-webkit-inner-spin-button, +input[type="number"]::-webkit-outer-spin-button { + height: auto; +} + +/** + * 1. Address `appearance` set to `searchfield` in Safari and Chrome. + * 2. Address `box-sizing` set to `border-box` in Safari and Chrome + * (include `-moz` to future-proof). + */ + +input[type="search"] { + -webkit-appearance: textfield; /* 1 */ + -moz-box-sizing: content-box; + -webkit-box-sizing: content-box; /* 2 */ + box-sizing: content-box; +} + +/** + * Remove inner padding and search cancel button in Safari and Chrome on OS X. + * Safari (but not Chrome) clips the cancel button when the search input has + * padding (and `textfield` appearance). + */ + +input[type="search"]::-webkit-search-cancel-button, +input[type="search"]::-webkit-search-decoration { + -webkit-appearance: none; +} + +/** + * Define consistent border, margin, and padding. + */ + +fieldset { + border: 1px solid #c0c0c0; + margin: 0 2px; + padding: 0.35em 0.625em 0.75em; +} + +/** + * 1. Correct `color` not being inherited in IE 8/9/10/11. + * 2. Remove padding so people aren't caught out if they zero out fieldsets. + */ + +legend { + border: 0; /* 1 */ + padding: 0; /* 2 */ +} + +/** + * Remove default vertical scrollbar in IE 8/9/10/11. + */ + +textarea { + overflow: auto; +} + +/** + * Don't inherit the `font-weight` (applied by a rule above). + * NOTE: the default cannot safely be changed in Chrome and Safari on OS X. + */ + +optgroup { + font-weight: bold; +} + +/* Tables + ========================================================================== */ + +/** + * Remove most spacing between table cells. + */ + +table { + border-collapse: collapse; + border-spacing: 0; +} + +td, +th { + padding: 0; +} diff --git a/app/static/pursuit.css b/app/static/pursuit.css new file mode 100644 index 0000000000..e0c7f6ec9f --- /dev/null +++ b/app/static/pursuit.css @@ -0,0 +1,703 @@ +/** ************************************************************************* * + ** Pursuit CSS + ** + ** STRUCTURE + ** + ** This CSS file is structured into several sections, from general to + ** specific, and (mostly) alphabetically within the sections. + ** + ** Several global element styles are used. This is not encouraged and should + ** be kept to a minimum. If you want to add new styles you'll most likely + ** want to add a new CSS component. See the Components section for examples. + ** + ** CSS components use three simple naming ideas from the BEM system: + ** - Block: `.my-component` + ** - Element: `.my-component__item` + ** - Modifier: `.my-component.my-component--highlighted` + ** + ** Example: + **
+ **
+ **
+ ** ... + **
+ **
+ **
+ ** + ** Components can be nested. + ** + ** + ** TYPOGRAPHY + ** + ** Typographic choices for sizes, line-heights and margins are based on a + ** musical major third scale (4:5). This gives us a way to find numbers + ** and relationships between them that are perceived as harmonic. + ** + ** To make use of this modular scale, use a ratio of the form + ** (5/4)^n + ** where n ∈ ℤ, -6 ≤ n ≤ 8. + ** ************************************************************************* */ +/* Section: Variables + * ========================================================================== */ +/* Section: Document Styles + * ========================================================================== */ +html { + box-sizing: border-box; + /* This overflow rule prevents everything from shifting slightly to the side + when moving from a page which isn't large enough to generate a scrollbar + to one that is. */ + overflow-y: scroll; +} +*, +*::before, +*::after { + box-sizing: inherit; +} +body { + background-color: #ffffff; + color: #000; + font-family: "Roboto", sans-serif; + font-size: 87.5%; + line-height: 1.563; +} +@media (min-width: 38em) { + body { + font-size: 100%; + } +} +/* Section: Utility Classes + * ========================================================================== */ +.clear-floats { + clear: both; +} +.clearfix::before, +.clearfix::after { + content: " "; + display: table; +} +.clearfix::after { + clear: both; +} +/* Content hidden like this will still be read by a screen reader */ +.hide-visually { + position: absolute; + left: -10000px; + top: auto; + width: 1px; + height: 1px; + overflow: hidden; +} +/* Section: Layout + * ========================================================================== */ +.container { + display: block; + max-width: 66em; + margin-left: auto; + margin-right: auto; + padding-left: 20px; + padding-right: 20px; +} +.col { + display: block; + position: relative; + width: 100%; +} +.col.col--main { + margin-bottom: 3.08em; +} +.col.col--aside { + margin-bottom: 2.44em; +} +@media (min-width: 52em) { + .container { + padding-left: 30px; + padding-right: 30px; + } + .col.col--main { + float: left; + width: 63.655%; + /* 66.6…% - 30px */ + } + .col.col--aside { + float: right; + font-size: 87.5%; + width: 33.333333%; + } +} +@media (min-width: 66em) { + .col.col--aside { + font-size: inherit; + } +} +/* Footer + * Based on http://www.lwis.net/journal/2008/02/08/pure-css-sticky-footer/ + * Except we don't support IE6 + * -------------------------------------------------------------------------- */ +html, +body { + height: 100%; +} +.everything-except-footer { + min-height: 100%; + padding-bottom: 3em; +} +.footer { + position: relative; + height: 3em; + margin-top: -3em; + width: 100%; + text-align: center; + background-color: #1d222d; + color: #f0f0f0; +} +.footer * { + margin-bottom: 0; +} +/* Section: Element Styles + * + * Have as few of these as possible and keep them general, because they will + * influence every component hereafter. + * ========================================================================== */ +:target { + background-color: #f1f5f9; +} +a, +a:visited { + color: #c4953a; + text-decoration: none; + font-weight: bold; +} +a:hover { + color: #7b5904; + text-decoration: none; +} +code, +pre { + background-color: #f1f5f9; + border-radius: 3px; + color: #194a5b; + font-family: "Roboto Mono", monospace; + font-size: 87.5%; +} +:target code, +:target pre { + background-color: #dfe8f1; +} +code { + padding: 0.2em 0; + margin: 0; + white-space: pre-wrap; + word-wrap: break-word; +} +code::before, +code::after { + letter-spacing: -0.2em; + content: "\00a0"; +} +a > code { + font-weight: normal; +} +a > code::before { + content: "🡒"; + letter-spacing: 0.33em; +} +a:hover > code { + color: #c4953a; +} +pre { + margin-top: 0; + margin-bottom: 0; + padding: 1em 1.25rem; + /* Using rem here to align with lists etc. */ + overflow: auto; + white-space: pre; + word-wrap: normal; +} +pre code { + background-color: transparent; + border: 0; + font-size: 100%; + max-width: auto; + padding: 0; + margin: 0; + overflow: visible; + line-height: inherit; + white-space: pre; + word-break: normal; + word-wrap: normal; +} +pre code::before, +pre code::after { + content: normal; +} +h1 { + font-size: 3.052em; + font-weight: 300; + letter-spacing: -0.5px; + line-height: 1.125; + margin-top: 1.563rem; + margin-bottom: 1.25rem; +} +@media (min-width: 52em) { + h1 { + font-size: 3.814em; + margin-top: 5.96rem; + } +} +h2 { + font-size: 1.953em; + font-weight: normal; + line-height: 1.250; + margin-top: 3.052rem; + margin-bottom: 1rem; +} +h3 { + font-size: 1.563em; + font-weight: normal; + line-height: 1.250; + margin-top: 2.441rem; + margin-bottom: 1rem; +} +h4 { + font-size: 1.25em; + font-weight: normal; + margin-top: 2.441rem; + margin-bottom: 1rem; +} +h1 + h2, +h1 + h3, +h1 + h4, +h2 + h3, +h2 + h4, +h3 + h4 { + margin-top: 1rem; +} +hr { + border: none; + height: 1px; + background-color: #cccccc; +} +img { + border-style: none; + max-width: 100%; +} +p { + font-size: 1em; + margin-top: 1rem; + margin-bottom: 1rem; +} +table { + border-bottom: 1px solid #cccccc; + border-collapse: collapse; + border-spacing: 0; + margin-top: 1rem; + margin-bottom: 1rem; + width: 100%; +} +td, +th { + text-align: left; + padding: 0.41em 0.51em; +} +td { + border-top: 1px solid #cccccc; +} +td:first-child, +th:first-child { + padding-left: 0; +} +td:last-child, +th:last-child { + padding-right: 0; +} +ul { + list-style-type: none; + margin-top: 1rem; + margin-bottom: 1rem; + padding-left: 0; +} +ul li { + position: relative; + padding-left: 1.250em; +} +ul li::before { + position: absolute; + color: #a0a0a0; + content: "–"; + display: inline-block; + margin-left: -1.25em; + width: 1.250em; +} +/* Tying this tightly to ul at the moment because it's a slight variation thereof */ +ul.ul--search li::before { + content: "⚲"; + top: -0.2em; + transform: rotate(-45deg); +} +ol { + margin-top: 1rem; + margin-bottom: 1rem; + padding-left: 1.250em; +} +ol li { + position: relative; + padding-left: 0; +} +/* Section: Components + * ========================================================================== */ +/* Component: Badge + * -------------------------------------------------------------------------- */ +.badge { + position: relative; + top: -0.1em; + display: inline-block; + background-color: #000; + border-radius: 1.3em; + color: #fff; + font-size: 77%; + font-weight: bold; + line-height: 1.563; + text-align: center; + height: 1.5em; + width: 1.5em; +} +.badge.badge--package { + background-color: #c4953a; + letter-spacing: -0.1em; +} +.badge.badge--module { + background-color: #75B134; +} +/* Component: Declarations + * -------------------------------------------------------------------------- */ +.decl__title { + position: relative; + padding-bottom: 0.328em; + margin-bottom: 0.262em; +} +.decl__source { + display: block; + float: right; + font-size: 64%; + position: relative; + top: 0.57em; +} +.decl__anchor, +.decl__anchor:visited { + position: absolute; + left: -0.8em; + color: #bababa; +} +.decl__anchor:hover { + color: #c4953a; +} +.decl__signature { + background-color: transparent; + border-radius: 0; + border-top: 1px solid #cccccc; + border-bottom: 1px solid #cccccc; + padding: 0.328em 0; +} +.decl__signature code { + display: block; + padding-left: 2.441em; + text-indent: -2.441em; + white-space: normal; +} +:target .decl__signature, +:target .decl__signature code { + /* We want the background to be transparent, even when the parent is a target */ + background-color: transparent; +} +.decl__body .keyword, +.decl__body .syntax { + color: #0B71B4; +} +/* Component: Dependency Link + * -------------------------------------------------------------------------- */ +.deplink { + /* Currently no root styles, but keep the class as a namespace */ +} +.deplink__link { + display: inline-block; + margin-right: 0.41em; +} +.deplink__version { + color: #666666; + display: inline-block; + font-size: 0.8em; + line-height: 1; +} +/* Component: Grouped List + * -------------------------------------------------------------------------- */ +.grouped-list { + border-top: 1px solid #cccccc; + margin: 0 0 2.44em 0; +} +.grouped-list__title { + color: #666666; + font-size: 0.8em; + font-weight: 300; + letter-spacing: 1px; + margin: 0.8em 0 -0.1em 0; + text-transform: uppercase; +} +.grouped-list__item { + margin: 0; +} +/* Component: Message + * -------------------------------------------------------------------------- */ +.message { + border: 5px solid; + border-radius: 5px; + padding: 1em !important; +} +.message.message--error { + background-color: #fff0f0; + border-color: #c85050; +} +.message.message--not-available { + background-color: #f0f096; + border-color: #e3e33d; +} +/* Component: Multi Col + * Multiple columns side by side + * -------------------------------------------------------------------------- */ +.multi-col { + margin-bottom: 2.44em; +} +.multi-col__col { + display: block; + padding-right: 1em; + position: relative; + width: 100%; +} +@media (min-width: 38em) and (max-width: 51.999999em) { + .multi-col__col { + float: left; + width: 50%; + } + .multi-col__col:nth-child(2n+3) { + clear: both; + } +} +@media (min-width: 52em) { + .multi-col__col { + float: left; + width: 33.333333%; + } + .multi-col__col:nth-child(3n+4) { + clear: both; + } +} +/* Component: Page Title + * -------------------------------------------------------------------------- */ +.page-title { + margin: 4.77em 0 1.56em; + padding-bottom: 1.25em; + position: relative; +} +.page-title__title { + margin: 0 0 0 -0.05em; + /* Visually align on left edge */ +} +.page-title__label { + position: relative; + color: #666666; + font-size: 0.8rem; + font-weight: 300; + letter-spacing: 1px; + margin-bottom: -0.8em; + text-transform: uppercase; + z-index: 1; +} +/* Component: Top Banner + * -------------------------------------------------------------------------- */ +.top-banner { + background-color: #1d222d; + color: #f0f0f0; + font-weight: normal; +} +.top-banner__logo, +.top-banner__logo:visited { + float: left; + color: #f0f0f0; + font-size: 2.44em; + font-weight: 300; + line-height: 90px; + margin: 0; +} +.top-banner__logo:hover { + color: #c4953a; + text-decoration: none; +} +.top-banner__form { + margin-bottom: 1.25em; +} +.top-banner__form input { + border: 1px solid #1d222d; + border-radius: 3px; + color: #1d222d; + font-weight: 300; + line-height: 2; + padding: 0.21em 0.512em; + width: 100%; +} +.top-banner__actions { + float: right; + text-align: right; +} +.top-banner__actions__item { + display: inline-block; + line-height: 90px; + margin: 0; + padding-left: 1.25em; +} +.top-banner__actions__item:first-child { + padding-left: 0; +} +.top-banner__actions__item a, +.top-banner__actions__item a:visited { + color: #f0f0f0; +} +.top-banner__actions__item a:hover { + color: #c4953a; +} +@media (min-width: 38em) { + .top-banner__logo { + float: left; + width: 25%; + } + .top-banner__form { + float: left; + line-height: 90px; + margin-bottom: 0; + width: 50%; + } + .top-banner__actions { + float: right; + width: 25%; + } +} +/* Component: Search Results + * -------------------------------------------------------------------------- */ +.result.result--empty { + font-size: 1.25em; +} +.result__title { + font-size: 1.25em; + margin-bottom: 0.2rem; +} +.result__badge { + margin-left: -0.1em; +} +.result__body > *:first-child { + margin-top: 0!important; +} +.result__body > *:last-child { + margin-bottom: 0!important; +} +.result__signature { + background-color: transparent; + border-radius: 0; + border-top: 1px solid #cccccc; + border-bottom: 1px solid #cccccc; + padding: 0.328em 0; +} +.result__signature code { + display: block; + padding-left: 2.441em; + text-indent: -2.441em; + white-space: normal; +} +.result__actions { + margin-top: 0.2rem; +} +.result__actions__item { + font-size: 80%; +} +.result__actions__item + .result__actions__item { + margin-left: 0.65em; +} +/* Component: Version Selector + * -------------------------------------------------------------------------- */ +.version-selector { + margin-bottom: 0.8em; +} +@media (min-width: 38em) { + .version-selector { + position: absolute; + top: 0.8em; + right: 0; + margin-bottom: 0; + } +} +/* Section: FIXME + * These styles should be cleaned up + * ========================================================================== */ +/* Help paragraphs */ +.help { + padding: 5px 0; +} +.help h3 { + /* FIXME: target with class */ + margin-top: 16px; +} +/* Section: Markdown + * Github rendered README + * ========================================================================== */ +.markdown-body { + /* + Useful for narrow screens, such as mobiles. Documentation often contains URLs + which would otherwise force the page to become wider, and force creation of + horizontal scrollbars. Yuck. + */ + word-wrap: break-word; +} +.markdown-body > *:first-child { + margin-top: 0 !important; +} +.markdown-body > *:last-child { + margin-bottom: 0 !important; +} +.markdown-body a:not([href]) { + color: inherit; + text-decoration: none; +} +.markdown-body blockquote { + margin: 0; + padding: 0 1em; + color: #777; + border-left: 0.25em solid #ddd; +} +.markdown-body blockquote > :first-child { + margin-top: 0; +} +.markdown-body blockquote > :last-child { + margin-bottom: 0; +} +.markdown-body .anchor { + /* We hide the anchor because the link doesn't point to a valid location */ + display: none; +} +.markdown-body .pl-k { + /* Keyword */ + color: #a0a0a0; +} +.markdown-body .pl-c1, +.markdown-body .pl-en { + /* Not really sure what this is */ + color: #39d; +} +.markdown-body .pl-s { + /* String literals */ + color: #1a1; +} +.markdown-body .pl-cce { + /* String literal escape sequences */ + color: #921; +} +.markdown-body .pl-smi { + /* type variables? */ + color: #62b; +} diff --git a/purescript.cabal b/purescript.cabal index d7df464341..0df22a167b 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -96,6 +96,7 @@ extra-source-files: examples/passing/*.purs , examples/docs/resolutions.json , app/static/index.html , app/static/index.js + , app/static/*.css , tests/support/package.json , tests/support/bower.json , tests/support/setup-win.cmd @@ -354,6 +355,7 @@ executable purs ansi-terminal >= 0.6.2 && < 0.7, ansi-wl-pprint -any, base-compat >=0.6.0, + blaze-html -any, boxes >= 0.1.4 && < 0.2.0, bytestring -any, containers -any, @@ -393,10 +395,12 @@ executable purs Command.Docs.Ctags Command.Docs.Etags Command.Docs.Tags + Command.Docs.Html Command.Hierarchy Command.Ide Command.Publish Command.REPL + Version ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N" if flag(release) diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index dd311e010e..e99c5b6a03 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -55,7 +55,7 @@ data HtmlRenderContext = HtmlRenderContext { currentModuleName :: P.ModuleName , buildDocLink :: Namespace -> Text -> ContainingModule -> Maybe DocLink , renderDocLink :: DocLink -> Text - , renderSourceLink :: P.SourceSpan -> Text + , renderSourceLink :: P.SourceSpan -> Maybe Text } -- | @@ -65,7 +65,7 @@ nullRenderContext mn = HtmlRenderContext { currentModuleName = mn , buildDocLink = const (const (const Nothing)) , renderDocLink = const "" - , renderSourceLink = const "" + , renderSourceLink = const Nothing } packageAsHtml :: (P.ModuleName -> HtmlRenderContext) -> Package a -> HtmlOutput Html @@ -155,8 +155,11 @@ declAsHtml r d@Declaration{..} = do where linkToSource :: HtmlRenderContext -> P.SourceSpan -> Html linkToSource ctx srcspan = - H.span ! A.class_ "decl__source" $ - a ! A.href (v (renderSourceLink ctx srcspan)) $ text "Source" + maybe (return ()) go (renderSourceLink ctx srcspan) + where + go href = + H.span ! A.class_ "decl__source" $ + a ! A.href (v href) $ text "Source" renderChildren :: HtmlRenderContext -> [ChildDeclaration] -> Html renderChildren _ [] = return () From c587a308162748f873aa50349b55e458b04d5933 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 19 Mar 2017 21:19:29 +0000 Subject: [PATCH 0725/1580] Allow parens wrapping constraints again (#2759) --- examples/passing/ConstraintParens.purs | 12 ++++++++++++ src/Language/PureScript/Parser/Types.hs | 2 +- 2 files changed, 13 insertions(+), 1 deletion(-) create mode 100644 examples/passing/ConstraintParens.purs diff --git a/examples/passing/ConstraintParens.purs b/examples/passing/ConstraintParens.purs new file mode 100644 index 0000000000..5545332f3a --- /dev/null +++ b/examples/passing/ConstraintParens.purs @@ -0,0 +1,12 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +class Foo a where + foo ∷ a → a + +test ∷ ∀ a. (Foo a) ⇒ a → a +test = foo + +main = log "Done" diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 4c29e497b7..7c8f03041b 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -70,7 +70,7 @@ parseTypeAtom = indented *> P.choice parseConstrainedType :: TokenParser Type parseConstrainedType = do - constraint <- parseConstraint + constraint <- parens parseConstraint <|> parseConstraint _ <- rfatArrow indented ty <- parseType From 23fa5dba801e420a0b91a4e46ce15524328e9c30 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 19 Mar 2017 23:00:15 +0000 Subject: [PATCH 0726/1580] Add useful errors for removed kind syntax (#2760) * Add useful errors for removed kind syntax * Use parserFail for kind syntax hints * Tweak kind syntax hint wording --- src/Language/PureScript/Parser/Kinds.hs | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs index f1918ce259..06c29f5c3f 100644 --- a/src/Language/PureScript/Parser/Kinds.hs +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -12,14 +12,25 @@ import Language.PureScript.Parser.Lexer import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P +parseStar :: TokenParser Kind +parseStar = symbol' "*" *> + P.parserFail "The `*` symbol is no longer used for the kind of types.\n The new equivalent is the named kind `Type`." + +parseBang :: TokenParser Kind +parseBang = symbol' "!" *> + P.parserFail "The `!` symbol is no longer used for the kind of effects.\n The new equivalent is the named kind `Effect`, defined in `Control.Monad.Eff` in the `purescript-eff` library." + parseNamedKind :: TokenParser Kind parseNamedKind = NamedKind <$> parseQualified kindName parseKindAtom :: TokenParser Kind -parseKindAtom = indented *> P.choice - [ parseNamedKind - , parens parseKind - ] +parseKindAtom = + indented *> P.choice + [ parseStar + , parseBang + , parseNamedKind + , parens parseKind + ] -- | -- Parse a kind From cb405707ff4ce4343bd066e4453f14b243652f3d Mon Sep 17 00:00:00 2001 From: Hyunje Jun Date: Tue, 21 Mar 2017 12:59:13 +0900 Subject: [PATCH 0727/1580] Implement evaluation test for PSCi (#2747) * Add psci-suport to test support deps * Implement evaluation test for PSCi Resolve #2664. * Rename operators in PSCi test environment Using 'equalsTo' and 'evaluatesTo' is easier to understand. * Do not evaluate the right part of `evaluatesTo` The right part just means an expected string output. * Refactor TestPsci functions Add comments and rename functions. * Nudge Travis CI tests --- tests/TestPsci/CommandTest.hs | 14 ++++--- tests/TestPsci/CompletionTest.hs | 4 +- tests/TestPsci/TestEnv.hs | 69 ++++++++++++++++++++++---------- tests/TestUtils.hs | 1 + tests/support/bower.json | 1 + 5 files changed, 61 insertions(+), 28 deletions(-) diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs index 11ca7085ef..543a844251 100644 --- a/tests/TestPsci/CommandTest.hs +++ b/tests/TestPsci/CommandTest.hs @@ -9,23 +9,27 @@ import Test.HUnit import TestPsci.TestEnv commandTests :: Test -commandTests = TestLabel "commandTests" $ TestList $ map (TestCase . runTestPSCi) +commandTests = TestLabel "commandTests" $ TestList $ map (TestCase . execTestPSCi) [ do run "import Prelude" run "import Data.Functor" run "import Control.Monad" before <- psciImportedModules <$> get - length before @?== 3 + length before `equalsTo` 3 run ":clear" after <- psciImportedModules <$> get - length after @?== 0 + length after `equalsTo` 0 , do run "import Prelude" run "import Data.Functor" run "import Control.Monad" before <- psciImportedModules <$> get - length before @?== 3 + length before `equalsTo` 3 run ":reload" after <- psciImportedModules <$> get - length after @?== 3 + length after `equalsTo` 3 + , do + run "import Prelude" + run "import Data.Array" + "let fac n = foldl mul 1 (1..n) in fac 10" `evaluatesTo` "3628800" ] diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index d74a481589..6ffb4869f4 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -11,7 +11,7 @@ import qualified Data.Text as T import qualified Language.PureScript as P import Language.PureScript.Interactive import System.Console.Haskeline -import TestPsci.TestEnv (initTestPSCi) +import TestPsci.TestEnv (initTestPSCiEnv) import TestUtils (supportModules) completionTests :: Test @@ -98,7 +98,7 @@ runCM act = do getPSCiStateForCompletion :: IO PSCiState getPSCiStateForCompletion = do - (PSCiState _ bs es, _) <- initTestPSCi + (PSCiState _ bs es, _) <- initTestPSCiEnv let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName (T.pack "Prelude")], P.Implicit, Nothing)] return $ PSCiState imports bs es diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 5c385e603c..35ae45d96e 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -8,47 +8,74 @@ import Control.Monad.Trans.RWS.Strict (evalRWST, RWST) import qualified Language.PureScript as P import Language.PureScript.Interactive import System.Directory (getCurrentDirectory) -import System.Exit (exitFailure) +import System.Exit import System.FilePath (()) import qualified System.FilePath.Glob as Glob +import System.Process (readProcessWithExitCode) import Test.HUnit ((@?=)) +-- | A monad transformer for handle PSCi actions in tests type TestPSCi a = RWST PSCiConfig () PSCiState IO a -initTestPSCi :: IO (PSCiState, PSCiConfig) -initTestPSCi = do +-- | Initialise PSCi state and config for tests +initTestPSCiEnv :: IO (PSCiState, PSCiConfig) +initTestPSCiEnv = do + -- Load test support packages cwd <- getCurrentDirectory let supportDir = cwd "tests" "support" "bower_components" let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir pursFiles <- supportFiles "purs" - - modulesOrFirstError <- loadAllModules pursFiles - case modulesOrFirstError of + modulesOrError <- loadAllModules pursFiles + case modulesOrError of Left err -> print err >> exitFailure Right modules -> do - resultOrErrors <- runMake . make $ modules - case resultOrErrors of + -- Make modules + makeResultOrError <- runMake . make $ modules + case makeResultOrError of Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure Right (externs, env) -> return (PSCiState [] [] (zip (map snd modules) externs), PSCiConfig pursFiles env) -runTestPSCi :: TestPSCi a -> IO a -runTestPSCi i = do - (s, c) <- initTestPSCi +-- | Execute a TestPSCi, returning IO +execTestPSCi :: TestPSCi a -> IO a +execTestPSCi i = do + (s, c) <- initTestPSCiEnv -- init state and config fst <$> evalRWST i c s -testEval :: String -> TestPSCi () -testEval = const $ return () -- not yet actually eval expr command +-- | Evaluate JS to which a PSCi input is compiled. The actual JS input is not +-- needed as an argument, as it is already written in the file during the +-- command evaluation. +jsEval :: TestPSCi String +jsEval = liftIO $ do + writeFile indexFile "require('$PSCI')['$main']();" + process <- findNodeProcess + result <- traverse (\node -> readProcessWithExitCode node [indexFile] "") process + case result of + Just (ExitSuccess, out, _) -> return out + Just (ExitFailure _, _, err) -> putStrLn err >> exitFailure + Nothing -> putStrLn "Couldn't find node.js" >> exitFailure -testReload :: TestPSCi () -testReload = return () +-- | Run a PSCi command and evaluate the output with 'eval'. +runAndEval :: String -> TestPSCi () -> TestPSCi () +runAndEval comm eval = + case parseCommand comm of + Left errStr -> liftIO $ putStrLn errStr >> exitFailure + Right command -> + -- the JS result can be ignored, as it's already written in a source file + -- for the detail, please refer to Interactive.hs + handleCommand (\_ -> eval) (return ()) command +-- | Run a PSCi command and ignore the output run :: String -> TestPSCi () -run s = case parseCommand s of - Left errStr -> liftIO $ putStrLn errStr >> exitFailure - Right command -> - handleCommand testEval testReload command +run comm = runAndEval comm $ jsEval *> return () + +-- | A lifted evaluation of HUnit '@?=' for the TestPSCi +equalsTo :: (Eq a, Show a) => a -> a -> TestPSCi () +equalsTo x y = liftIO $ x @?= y -(@?==) :: (Eq a, Show a) => a -> a -> TestPSCi () -x @?== y = liftIO $ x @?= y +-- | An assertion to check if a command evaluates to a string +evaluatesTo :: String -> String -> TestPSCi () +evaluatesTo command expected = runAndEval command $ do + actual <- jsEval + actual `equalsTo` (expected ++ "\n") diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 1fe916baa2..3e04f69168 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -147,6 +147,7 @@ supportModules = , "Data.Unfoldable" , "Data.Unit" , "Data.Void" + , "PSCI.Support" , "Partial" , "Partial.Unsafe" , "Prelude" diff --git a/tests/support/bower.json b/tests/support/bower.json index eb1f395ba7..bae32d6f7f 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -11,6 +11,7 @@ "purescript-newtype": "ps-0.11", "purescript-partial": "1.2.0", "purescript-prelude": "ps-0.11", + "purescript-psci-support": "ps-0.11", "purescript-st": "ps-0.11", "purescript-symbols": "ps-0.11", "purescript-tailrec": "ps-0.11", From 98a7728d0d11ff1a12927657ea24385733c2abbd Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 22 Mar 2017 20:30:39 -0700 Subject: [PATCH 0728/1580] Make psc-ide-client executable --- scripts/psc-ide-client | 0 1 file changed, 0 insertions(+), 0 deletions(-) mode change 100644 => 100755 scripts/psc-ide-client diff --git a/scripts/psc-ide-client b/scripts/psc-ide-client old mode 100644 new mode 100755 From 87b431ea71ae7f0c6246722cd44ac3d93258ffcc Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 23 Mar 2017 08:26:06 -0700 Subject: [PATCH 0729/1580] Derive Generic.Rep for empty records (#2767) --- examples/passing/GenericsRep.purs | 8 ++++ .../PureScript/Sugar/TypeClasses/Deriving.hs | 41 +++++++++++-------- 2 files changed, 33 insertions(+), 16 deletions(-) diff --git a/examples/passing/GenericsRep.purs b/examples/passing/GenericsRep.purs index be75d86202..b83537ef30 100644 --- a/examples/passing/GenericsRep.purs +++ b/examples/passing/GenericsRep.purs @@ -43,6 +43,13 @@ derive instance genericV :: Generic V _ instance eqV :: Eq V where eq x y = genericEq x y +newtype U = U {} + +derive instance genericU :: Generic U _ + +instance eqU :: Eq U where + eq x y = genericEq x y + main :: Eff (console :: CONSOLE) Unit main = do logShow (X 0 == X 1) @@ -52,4 +59,5 @@ main = do logShow (Y == Y :: Y Z) logShow (W { x: 0, y: "A" } == W { x: 0, y: "A" }) logShow (V { x: 0 } { x: 0 } == V { x: 0 } { x: 0 }) + logShow (U {} == U {}) log "Done" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index bc353232c9..68f48df920 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -461,22 +461,31 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do makeArg arg | Just rec <- objectType arg , Just fields <- decomposeRec rec = do fieldNames <- traverse freshIdent (map (runIdent . labelToIdent . fst) fields) - pure ( TypeApp (TypeConstructor record) - (foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) - (map (\((Label name), ty) -> - TypeApp (TypeApp (TypeConstructor field) (TypeLevelString name)) ty) fields)) - , ConstructorBinder record - [ foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2]) - (map (\ident -> ConstructorBinder field [VarBinder ident]) fieldNames) - ] - , Literal . ObjectLiteral $ - zipWith (\((Label name), _) ident -> (name, Var (Qualified Nothing ident))) fields fieldNames - , LiteralBinder . ObjectLiteral $ - zipWith (\((Label name), _) ident -> (name, VarBinder ident)) fields fieldNames - , record' $ - foldr1 (\e1 -> App (App (Constructor productName) e1)) - (map (field' . Var . Qualified Nothing) fieldNames) - ) + case fieldNames of + [] -> + pure ( TypeApp (TypeConstructor record) noArgs + , ConstructorBinder record [ NullBinder ] + , Literal (ObjectLiteral []) + , LiteralBinder (ObjectLiteral []) + , record' noArgs' + ) + _ -> + pure ( TypeApp (TypeConstructor record) + (foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) + (map (\((Label name), ty) -> + TypeApp (TypeApp (TypeConstructor field) (TypeLevelString name)) ty) fields)) + , ConstructorBinder record + [ foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2]) + (map (\ident -> ConstructorBinder field [VarBinder ident]) fieldNames) + ] + , Literal . ObjectLiteral $ + zipWith (\((Label name), _) ident -> (name, Var (Qualified Nothing ident))) fields fieldNames + , LiteralBinder . ObjectLiteral $ + zipWith (\((Label name), _) ident -> (name, VarBinder ident)) fields fieldNames + , record' $ + foldr1 (\e1 -> App (App (Constructor productName) e1)) + (map (field' . Var . Qualified Nothing) fieldNames) + ) makeArg arg = do argName <- freshIdent "arg" pure ( TypeApp (TypeConstructor argument) arg From 633c8c50e9aa0b4b39a4e7f34195a23558e4e275 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 23 Mar 2017 20:24:14 -0700 Subject: [PATCH 0730/1580] Row union constraints (#2761) * Add Union class to Prim * Docs * Safer solver for Union constraints * Add back the mergeWithExtras example * Simplify Union solver * Additional fundeps, Subrow example * Use undefined for Union dictionaries * Comments, tidying * Haddock fix --- examples/passing/RowUnion.js | 10 ++ examples/passing/RowUnion.purs | 68 +++++++ src/Language/PureScript/Constants.hs | 3 + src/Language/PureScript/Docs/Prim.hs | 9 + src/Language/PureScript/Environment.hs | 169 ++++++------------ .../PureScript/TypeChecker/Entailment.hs | 39 +++- 6 files changed, 180 insertions(+), 118 deletions(-) create mode 100644 examples/passing/RowUnion.js create mode 100644 examples/passing/RowUnion.purs diff --git a/examples/passing/RowUnion.js b/examples/passing/RowUnion.js new file mode 100644 index 0000000000..c002b18f57 --- /dev/null +++ b/examples/passing/RowUnion.js @@ -0,0 +1,10 @@ +"use strict"; + +exports.merge = function (dict) { + return function (l) { + return function (r) { + var o = {}; + return Object.assign(o, r, l); + }; + }; +}; diff --git a/examples/passing/RowUnion.purs b/examples/passing/RowUnion.purs new file mode 100644 index 0000000000..57a47e6c95 --- /dev/null +++ b/examples/passing/RowUnion.purs @@ -0,0 +1,68 @@ +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console + +foreign import merge + :: forall r1 r2 r3 + . Union r1 r2 r3 + => Record r1 + -> Record r2 + -> Record r3 + +test1 = merge { x: 1 } { y: true } + +test2 = merge { x: 1 } { x: true } + +mergeWithExtras + :: forall r1 r2 r3 + . Union r1 (y :: Boolean | r2) (y :: Boolean | r3) + => { x :: Int | r1 } + -> { y :: Boolean | r2 } + -> { x :: Int, y :: Boolean | r3} +mergeWithExtras = merge + +test3 x = merge { x: 1 } x +test3' x = merge x { x: 1 } + +type Mandatory r = (x :: Int | r) +type Optional r = (x :: Int, y :: Int, z :: Int | r) + +withDefaults + :: forall r s + . Union r (y :: Int, z :: Int) (y :: Int, z :: Int | s) + => Record (Mandatory r) + -> Record (Optional s) +withDefaults p = merge p { y: 1, z: 1 } + +withDefaultsClosed + :: forall r s + . Union r (y :: Int, z :: Int) (y :: Int, z :: Int | s) + => Subrow s (y :: Int, z :: Int) + => Record (Mandatory r) + -> Record (Optional s) +withDefaultsClosed p = merge p { y: 1, z: 1 } + +test4 = withDefaults { x: 1, y: 2 } + +-- r is a subrow of s if Union r t s for some t. +class Subrow (r :: # Type) (s :: # Type) +instance subrow :: Union r t s => Subrow r s + +main :: Eff (console :: CONSOLE) Unit +main = do + logShow test1.x + logShow test1.y + logShow (test1.x == 1) + logShow (mergeWithExtras { x: 1 } { x: 0, y: true, z: 42.0 }).x + logShow (withDefaults { x: 1 }).x + logShow (withDefaults { x: 1 }).y + logShow (withDefaults { x: 1 }).z + logShow (withDefaults { x: 1, y: 2 }).x + logShow (withDefaults { x: 1, y: 2 }).y + logShow (withDefaults { x: 1, y: 2 }).z + logShow (withDefaultsClosed { x: 1, y: 2 }).x + logShow (withDefaultsClosed { x: 1, y: 2 }).y + logShow (withDefaultsClosed { x: 1, y: 2 }).z + log "Done" diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 1b37a84fe8..81bca24af0 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -381,6 +381,9 @@ pattern Fail = Qualified (Just Prim) (ProperName "Fail") pattern Warn :: Qualified (ProperName 'ClassName) pattern Warn = Qualified (Just Prim) (ProperName "Warn") +pattern Union :: Qualified (ProperName 'ClassName) +pattern Union = Qualified (Just Prim) (ProperName "Union") + typ :: forall a. (IsString a) => a typ = "Type" diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 7566bed4bf..c2070b1e78 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -25,6 +25,7 @@ primDocsModule = Module , partial , fail , warn + , union , typeConcat , typeString , kindType @@ -228,6 +229,14 @@ warn = primClass "Warn" $ T.unlines , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." ] +union :: Declaration +union = primClass "Union" $ T.unlines + [ "The Union type class is used to compute the union of two rows of types" + , "(left-biased, including duplicates)." + , "" + , "The third type argument represents the union of the first two." + ] + typeConcat :: Declaration typeConcat = primType "TypeConcat" $ T.unlines [ "The TypeConcat type constructor concatenates two Symbols in a custom type" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 271445ea71..43c9865cab 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -72,14 +72,11 @@ data FunctionalDependency = FunctionalDependency -- ^ the determined type arguments } deriving Show --- | --- The initial environment with no values and only the default javascript types defined --- +-- | The initial environment with no values and only the default javascript types defined initEnvironment :: Environment initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses primKinds --- | --- A constructor for TypeClassData that computes which type class arguments are fully determined +-- | A constructor for TypeClassData that computes which type class arguments are fully determined -- and argument covering sets. -- Fully determined means that this argument cannot be used when selecting a type class instance. -- A covering set is a minimal collection of arguments that can be used to find an instance and @@ -151,77 +148,45 @@ makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs cov coveringSets = let funDepSets = sequence (mapMaybe sccNonDetermined (G.scc depGraph)) in S.fromList (S.fromList <$> funDepSets) --- | --- The visibility of a name in scope --- +-- | The visibility of a name in scope data NameVisibility - -- | - -- The name is defined in the current binding group, but is not visible - -- = Undefined - -- | - -- The name is defined in the another binding group, or has been made visible by a function binder - -- - | Defined deriving (Show, Eq) - --- | --- A flag for whether a name is for an private or public value - only public values will be + -- ^ The name is defined in the current binding group, but is not visible + | Defined + -- ^ The name is defined in the another binding group, or has been made visible by a function binder + deriving (Show, Eq) +-- | A flag for whether a name is for an private or public value - only public values will be -- included in a generated externs file. --- data NameKind - -- | - -- A private value introduced as an artifact of code generation (class instances, class member - -- accessors, etc.) - -- = Private - -- | - -- A public value for a module member or foreing import declaration - -- + -- ^ A private value introduced as an artifact of code generation (class instances, class member + -- accessors, etc.) | Public - -- | - -- A name for member introduced by foreign import - -- + -- ^ A public value for a module member or foreing import declaration | External + -- ^ A name for member introduced by foreign import deriving (Show, Eq) --- | --- The kinds of a type --- +-- | The kinds of a type data TypeKind - -- | - -- Data type - -- = DataType [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])] - -- | - -- Type synonym - -- + -- ^ Data type | TypeSynonym - -- | - -- Foreign data - -- + -- ^ Type synonym | ExternData - -- | - -- A local type variable - -- + -- ^ Foreign data | LocalTypeVariable - -- | - -- A scoped type variable - -- + -- ^ A local type variable | ScopedTypeVar + -- ^ A scoped type variable deriving (Show, Eq) --- | --- The type ('data' or 'newtype') of a data type declaration --- +-- | The type ('data' or 'newtype') of a data type declaration data DataDeclType - -- | - -- A standard data constructor - -- = Data - -- | - -- A newtype constructor - -- + -- ^ A standard data constructor | Newtype + -- ^ A newtype constructor deriving (Show, Eq, Ord) showDataDeclType :: DataDeclType -> Text @@ -238,87 +203,61 @@ instance A.FromJSON DataDeclType where "newtype" -> return Newtype other -> fail $ "invalid type: '" ++ T.unpack other ++ "'" --- | --- Construct a ProperName in the Prim module --- +-- | Construct a ProperName in the Prim module primName :: Text -> Qualified (ProperName a) primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName primKind :: Text -> Kind primKind = NamedKind . primName --- | --- Kinds in prim --- +-- | Kind of ground types kindType :: Kind kindType = primKind C.typ kindSymbol :: Kind kindSymbol = primKind C.symbol --- | --- Construct a type in the Prim module --- +-- | Construct a type in the Prim module primTy :: Text -> Type primTy = TypeConstructor . primName --- | --- Type constructor for functions --- +-- | Type constructor for functions tyFunction :: Type tyFunction = primTy "Function" --- | --- Type constructor for strings --- +-- | Type constructor for strings tyString :: Type tyString = primTy "String" --- | --- Type constructor for strings --- +-- | Type constructor for strings tyChar :: Type tyChar = primTy "Char" --- | --- Type constructor for numbers --- +-- | Type constructor for numbers tyNumber :: Type tyNumber = primTy "Number" --- | --- Type constructor for integers --- +-- | Type constructor for integers tyInt :: Type tyInt = primTy "Int" --- | --- Type constructor for booleans --- +-- | Type constructor for booleans tyBoolean :: Type tyBoolean = primTy "Boolean" --- | --- Type constructor for arrays --- +-- | Type constructor for arrays tyArray :: Type tyArray = primTy "Array" --- | --- Type constructor for records --- +-- | Type constructor for records tyRecord :: Type tyRecord = primTy "Record" --- | --- Check whether a type is a record --- +-- | Check whether a type is a record isObject :: Type -> Bool isObject = isTypeOrApplied tyRecord --- | --- Check whether a type is a function --- +-- | Check whether a type is a function isFunction :: Type -> Bool isFunction = isTypeOrApplied tyFunction @@ -326,14 +265,11 @@ isTypeOrApplied :: Type -> Type -> Bool isTypeOrApplied t1 (TypeApp t2 _) = t1 == t2 isTypeOrApplied t1 t2 = t1 == t2 --- | --- Smart constructor for function types --- +-- | Smart constructor for function types function :: Type -> Type -> Type function t1 = TypeApp (TypeApp tyFunction t1) --- | --- The primitive kinds +-- | The primitive kinds primKinds :: S.Set (Qualified (ProperName 'KindName)) primKinds = S.fromList @@ -341,11 +277,9 @@ primKinds = , primName C.symbol ] --- | --- The primitive types in the external javascript environment with their +-- | The primitive types in the external javascript environment with their -- associated kinds. There are also pseudo `Fail`, `Warn`, and `Partial` types -- that correspond to the classes with the same names. --- primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) primTypes = M.fromList @@ -358,44 +292,49 @@ primTypes = , (primName "Int", (kindType, ExternData)) , (primName "Boolean", (kindType, ExternData)) , (primName "Partial", (kindType, ExternData)) + , (primName "Union", (FunKind (Row kindType) (FunKind (Row kindType) (FunKind (Row kindType) kindType)), ExternData)) , (primName "Fail", (FunKind kindSymbol kindType, ExternData)) , (primName "Warn", (FunKind kindSymbol kindType, ExternData)) , (primName "TypeString", (FunKind kindType kindSymbol, ExternData)) , (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData)) ] --- | --- The primitive class map. This just contains the `Fail`, `Warn`, and `Partial` +-- | The primitive class map. This just contains the `Fail`, `Warn`, and `Partial` -- classes. `Partial` is used as a kind of magic constraint for partial -- functions. `Fail` is used for user-defined type errors. `Warn` for -- user-defined warnings. --- primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses = M.fromList [ (primName "Partial", (makeTypeClassData [] [] [] [])) + -- class Fail (message :: Symbol) , (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] [])) + -- class Warn (message :: Symbol) , (primName "Warn", (makeTypeClassData [("message", Just kindSymbol)] [] [] [])) + -- class Union (l :: # Type) (r :: # Type) (u :: # Type) | l r -> u, r u -> l, u l -> r + , (primName "Union", (makeTypeClassData + [ ("l", Just (Row kindType)) + , ("r", Just (Row kindType)) + , ("u", Just (Row kindType)) + ] [] [] + [ FunctionalDependency [0, 1] [2] + , FunctionalDependency [1, 2] [0] + , FunctionalDependency [2, 0] [1] + ])) ] --- | --- Finds information about data constructors from the current environment. --- +-- | Finds information about data constructors from the current environment. lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, Type, [Ident]) lookupConstructor env ctor = fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env --- | --- Checks whether a data constructor is for a newtype. --- +-- | Checks whether a data constructor is for a newtype. isNewtypeConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> Bool isNewtypeConstructor e ctor = case lookupConstructor e ctor of (Newtype, _, _, _) -> True (Data, _, _, _) -> False --- | --- Finds information about values from the current environment. --- +-- | Finds information about values from the current environment. lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility) lookupValue env ident = ident `M.lookup` names env diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 534486b7a0..52b53a7ae3 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -22,6 +22,7 @@ import Control.Monad.Writer import Data.Foldable (for_, fold, toList) import Data.Function (on) +import Data.Functor (($>)) import Data.List (minimumBy) import Data.Maybe (fromMaybe, maybeToList, mapMaybe) import qualified Data.Map as M @@ -53,7 +54,9 @@ data Evidence -- ^ Computed instance of CompareSymbol | AppendSymbolInstance -- ^ Computed instance of AppendSymbol - deriving (Eq) + | UnionInstance + -- ^ Computed instance of RowUnion + deriving (Show, Eq) -- | Extract the identifier of a named instance namedInstanceIdentifier :: Evidence -> Maybe (Qualified Ident) @@ -119,6 +122,7 @@ data EntailsResult a -- ^ We couldn't solve this constraint right now, it will be generalized | Deferred -- ^ We couldn't solve this constraint right now, so it has been deferred + deriving Show -- | Options for the constraint solver data SolverOptions = SolverOptions @@ -160,6 +164,9 @@ entails SolverOptions{..} constraint context hints = forClassName _ C.AppendSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = let args = [arg0, arg1, TypeLevelString (lhs <> rhs)] in [TypeClassDictionaryInScope AppendSymbolInstance [] C.AppendSymbol args Nothing] + forClassName _ C.Union [l, r, u] + | Just (lOut, rOut, uOut, cst) <- unionRows l r u + = [ TypeClassDictionaryInScope UnionInstance [] C.Union [lOut, rOut, uOut] cst ] forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) forClassName _ _ _ = internalError "forClassName: expected qualified class name" @@ -315,12 +322,16 @@ entails SolverOptions{..} constraint context hints = -- Make a dictionary from subgoal dictionaries by applying the correct function mkDictionary :: Evidence -> Maybe [Expr] -> m Expr mkDictionary (NamedInstance n) args = return $ foldl App (Var n) (fold args) + mkDictionary UnionInstance (Just [e]) = + -- We need the subgoal dictionary to appear in the term somewhere + return $ App (Abs (VarBinder (Ident C.__unused)) valUndefined) e + mkDictionary UnionInstance _ = return valUndefined mkDictionary (WarnInstance msg) _ = do tell . errorMessage $ UserDefinedWarning msg -- We cannot call the type class constructor here because Warn is declared in Prim. -- This means that it doesn't have a definition that we can import. - -- So pass an empty object instead. - return $ Literal (ObjectLiteral []) + -- So pass an empty placeholder (undefined) instead. + return valUndefined mkDictionary (IsSymbolInstance sym) _ = let fields = [ ("reflectSymbol", Abs (VarBinder (Ident C.__unused)) (Literal (StringLiteral sym))) ] in return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) @@ -334,6 +345,28 @@ entails SolverOptions{..} constraint context hints = subclassDictionaryValue dict className index = App (Accessor (mkString (superclassName className index)) dict) valUndefined + -- | Left biased union of two row types + unionRows :: Type -> Type -> Type -> Maybe (Type, Type, Type, Maybe [Constraint]) + unionRows l r _ = + guard canMakeProgress $> (l, r, rowFromList out, cons) + where + (fixed, rest) = rowToList l + + rowVar = TypeVar "r" + + (canMakeProgress, out, cons) = + case rest of + -- If the left hand side is a closed row, then we can merge + -- its labels into the right hand side. + REmpty -> (True, (fixed, r), Nothing) + -- If the left hand side is not definitely closed, then the only way we + -- can safely make progress is to move any known labels from the left + -- input into the output, and add a constraint for any remaining labels. + -- Otherwise, the left hand tail might contain the same labels as on + -- the right hand side, and we can't be certain we won't reorder the + -- types for such labels. + _ -> (not (null fixed), (fixed, rowVar), Just [ Constraint C.Union [rest, r, rowVar] Nothing ]) + -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a -- substitution which makes them match. If not, we return 'Nothing'. From c82defc6f1ded53f42a49c7507561ef1feb6a359 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Fri, 24 Mar 2017 09:25:21 -0700 Subject: [PATCH 0731/1580] Remove TH from Environment.hs (#2770) --- src/Language/PureScript/Environment.hs | 65 +++++++++++++++++++------- 1 file changed, 48 insertions(+), 17 deletions(-) diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 43c9865cab..1366a7bd33 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -1,26 +1,24 @@ -{-# LANGUAGE TemplateHaskell #-} - module Language.PureScript.Environment where -import Prelude.Compat -import Protolude (ordNub) +import Prelude.Compat +import Protolude (ordNub) -import Data.Aeson.TH +import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A import qualified Data.Map as M import qualified Data.Set as S -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Text (Text) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) import qualified Data.Text as T -import Data.Tree (Tree, rootLabel) +import Data.Tree (Tree, rootLabel) import qualified Data.Graph as G -import Data.Foldable (toList) +import Data.Foldable (toList) -import Language.PureScript.Crash -import Language.PureScript.Kinds -import Language.PureScript.Names -import Language.PureScript.TypeClassDictionaries -import Language.PureScript.Types +import Language.PureScript.Crash +import Language.PureScript.Kinds +import Language.PureScript.Names +import Language.PureScript.TypeClassDictionaries +import Language.PureScript.Types import qualified Language.PureScript.Constants as C -- | The @Environment@ defines all values and types which are currently in scope: @@ -72,6 +70,18 @@ data FunctionalDependency = FunctionalDependency -- ^ the determined type arguments } deriving Show +instance A.FromJSON FunctionalDependency where + parseJSON = A.withObject "FunctionalDependency" $ \o -> + FunctionalDependency + <$> o .: "determiners" + <*> o .: "determined" + +instance A.ToJSON FunctionalDependency where + toJSON FunctionalDependency{..} = + A.object [ "determiners" .= fdDeterminers + , "determined" .= fdDetermined + ] + -- | The initial environment with no values and only the default javascript types defined initEnvironment :: Environment initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses primKinds @@ -155,6 +165,7 @@ data NameVisibility | Defined -- ^ The name is defined in the another binding group, or has been made visible by a function binder deriving (Show, Eq) + -- | A flag for whether a name is for an private or public value - only public values will be -- included in a generated externs file. data NameKind @@ -181,6 +192,29 @@ data TypeKind -- ^ A scoped type variable deriving (Show, Eq) +instance A.ToJSON TypeKind where + toJSON (DataType args ctors) = + A.object [ T.pack "DataType" .= A.object ["args" .= args, "ctors" .= ctors] ] + toJSON TypeSynonym = A.toJSON (T.pack "TypeSynonym") + toJSON ExternData = A.toJSON (T.pack "ExternData") + toJSON LocalTypeVariable = A.toJSON (T.pack "LocalTypeVariable") + toJSON ScopedTypeVar = A.toJSON (T.pack "ScopedTypeVar") + +instance A.FromJSON TypeKind where + parseJSON (A.Object o) = do + args <- o .: "DataType" + A.withObject "args" (\o1 -> + DataType <$> o1 .: "args" + <*> o1 .: "ctors") args + parseJSON (A.String s) = + case s of + "TypeSynonym" -> pure TypeSynonym + "ExternData" -> pure ExternData + "LocalTypeVariable" -> pure LocalTypeVariable + "ScopedTypeVar" -> pure ScopedTypeVar + _ -> fail "Unknown TypeKind" + parseJSON _ = fail "Invalid TypeKind" + -- | The type ('data' or 'newtype') of a data type declaration data DataDeclType = Data @@ -337,6 +371,3 @@ isNewtypeConstructor e ctor = case lookupConstructor e ctor of -- | Finds information about values from the current environment. lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility) lookupValue env ident = ident `M.lookup` names env - -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind) -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''FunctionalDependency) From 32bc73e20ebe8058b322d349680013911a5d0333 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sat, 25 Mar 2017 19:51:06 +0100 Subject: [PATCH 0732/1580] [purs ide] Track where a Reexport was resolved from (#2751) This is in preparation to group reexports of the same value in the completion results Also turns line endings for some test files from crlf to lf <- this causes trouble on windows otherwise --- examples/passing/1335.purs | 28 +++++----- examples/passing/OverlappingInstances2.purs | 54 +++++++++---------- examples/passing/OverlappingInstances3.purs | 40 +++++++------- examples/passing/PrimedTypeName.purs | 40 +++++++------- src/Language/PureScript/Ide/Externs.hs | 10 ++-- src/Language/PureScript/Ide/Reexports.hs | 13 +++-- src/Language/PureScript/Ide/Types.hs | 7 +-- src/Language/PureScript/Ide/Util.hs | 4 +- .../Language/PureScript/Ide/ReexportsSpec.hs | 29 +++++----- tests/Language/PureScript/Ide/Test.hs | 6 +-- 10 files changed, 119 insertions(+), 112 deletions(-) diff --git a/examples/passing/1335.purs b/examples/passing/1335.purs index da59ed01e2..3a0bb6b34f 100644 --- a/examples/passing/1335.purs +++ b/examples/passing/1335.purs @@ -1,14 +1,14 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console (log) - -x :: forall a. a -> String -x a = y "Test" - where - y :: forall a. Show a => a -> String - y a = show (a :: a) - -main = do - log (x 0) - log "Done" +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +x :: forall a. a -> String +x a = y "Test" + where + y :: forall a. Show a => a -> String + y a = show (a :: a) + +main = do + log (x 0) + log "Done" diff --git a/examples/passing/OverlappingInstances2.purs b/examples/passing/OverlappingInstances2.purs index 4e277f04dd..6b6fb0a56b 100644 --- a/examples/passing/OverlappingInstances2.purs +++ b/examples/passing/OverlappingInstances2.purs @@ -1,27 +1,27 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console (log) -import Test.Assert (assert) - -data A = A | B - -instance eqA1 :: Eq A where - eq A A = true - eq B B = true - eq _ _ = false - -instance eqA2 :: Eq A where - eq _ _ = true - -instance ordA :: Ord A where - compare A B = LT - compare B A = GT - compare _ _ = EQ - -test :: forall a. Ord a => a -> a -> String -test x y = show $ x == y - -main = do - assert $ test A B == "false" - log "Done" +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Test.Assert (assert) + +data A = A | B + +instance eqA1 :: Eq A where + eq A A = true + eq B B = true + eq _ _ = false + +instance eqA2 :: Eq A where + eq _ _ = true + +instance ordA :: Ord A where + compare A B = LT + compare B A = GT + compare _ _ = EQ + +test :: forall a. Ord a => a -> a -> String +test x y = show $ x == y + +main = do + assert $ test A B == "false" + log "Done" diff --git a/examples/passing/OverlappingInstances3.purs b/examples/passing/OverlappingInstances3.purs index 4ddc999232..011c1f991d 100644 --- a/examples/passing/OverlappingInstances3.purs +++ b/examples/passing/OverlappingInstances3.purs @@ -1,20 +1,20 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console (log) -import Test.Assert (assert) - -class Foo a - -instance foo1 :: Foo Number - -instance foo2 :: Foo Number - -test :: forall a. Foo a => a -> a -test a = a - -test1 = test 0.0 - -main = do - assert (test1 == 0.0) - log "Done" +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Test.Assert (assert) + +class Foo a + +instance foo1 :: Foo Number + +instance foo2 :: Foo Number + +test :: forall a. Foo a => a -> a +test a = a + +test1 = test 0.0 + +main = do + assert (test1 == 0.0) + log "Done" diff --git a/examples/passing/PrimedTypeName.purs b/examples/passing/PrimedTypeName.purs index be4d96b642..7b59c0be1a 100644 --- a/examples/passing/PrimedTypeName.purs +++ b/examples/passing/PrimedTypeName.purs @@ -1,20 +1,20 @@ -module Main (T, T', T'', T''', main) where - -import Prelude -import Control.Monad.Eff.Console (log) - -data T a = T -type T' = T Unit - -data T'' = TP - -foreign import data T''' ∷ Type - -instance eqT ∷ Eq T'' where - eq _ _ = true - -type A' a b = b → a - -infixr 4 type A' as ↫ - -main = log "Done" +module Main (T, T', T'', T''', main) where + +import Prelude +import Control.Monad.Eff.Console (log) + +data T a = T +type T' = T Unit + +data T'' = TP + +foreign import data T''' ∷ Type + +instance eqT ∷ Eq T'' where + eq _ _ = true + +type A' a b = b → a + +infixr 4 type A' as ↫ + +main = log "Done" diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 1ffe761310..7797b61f18 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -144,9 +144,9 @@ annotateModule (defs, types) decls = IdeDeclKind i -> annotateKind (i ^. properNameT) (IdeDeclKind i) where - annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (IdeNSValue (P.runIdent x)) defs - , annTypeAnnotation = Map.lookup x types + annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNSValue (P.runIdent x)) defs + , _annTypeAnnotation = Map.lookup x types }) - annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSValue x) defs}) - annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSType x) defs}) - annotateKind x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSKind x) defs}) + annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSValue x) defs}) + annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSType x) defs}) + annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSKind x) defs}) diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 367fc0ac99..e26ee48abe 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -68,21 +68,24 @@ resolveReexports resolveReexports reexportRefs modules = Map.mapWithKey (\moduleName decls -> maybe (ReexportResult decls []) - (resolveReexports' modules decls) + (map (decls <>) . resolveReexports' modules) (Map.lookup moduleName reexportRefs)) modules resolveReexports' :: ModuleMap [IdeDeclarationAnn] - -> [IdeDeclarationAnn] -> [(P.ModuleName, P.DeclarationRef)] -> ReexportResult [IdeDeclarationAnn] -resolveReexports' modules decls refs = - ReexportResult (decls <> concat resolvedRefs) failedRefs +resolveReexports' modules refs = + ReexportResult (concat resolvedRefs) failedRefs where (failedRefs, resolvedRefs) = partitionEithers (resolveRef' <$> refs) resolveRef' x@(mn, r) = case Map.lookup mn modules of Nothing -> Left x - Just decls' -> first (mn,) (resolveRef decls' r) + Just decls' -> + let + setExportedFrom = set (idaAnnotation.annExportedFrom) . Just + in + bimap (mn,) (map (setExportedFrom mn)) (resolveRef decls' r) resolveRef :: [IdeDeclarationAnn] diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index a9271531a4..352b681589 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -106,11 +106,12 @@ data IdeDeclarationAnn = IdeDeclarationAnn data Annotation = Annotation - { annLocation :: Maybe P.SourceSpan - , annExportedFrom :: Maybe P.ModuleName - , annTypeAnnotation :: Maybe P.Type + { _annLocation :: Maybe P.SourceSpan + , _annExportedFrom :: Maybe P.ModuleName + , _annTypeAnnotation :: Maybe P.Type } deriving (Show, Eq, Ord) +makeLenses ''Annotation makeLenses ''IdeDeclarationAnn emptyAnn :: Annotation diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index a89acaac8d..e6bbaddbea 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -83,9 +83,9 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) = complModule = P.runModuleName m - complType = maybe complExpandedType prettyPrintTypeSingleLine (annTypeAnnotation ann) + complType = maybe complExpandedType prettyPrintTypeSingleLine (_annTypeAnnotation ann) - complLocation = annLocation ann + complLocation = _annLocation ann complDocumentation = Nothing diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index c260c4ee1e..c810af8628 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -18,6 +18,9 @@ m = P.moduleNameFromString d :: IdeDeclaration -> IdeDeclarationAnn d = IdeDeclarationAnn emptyAnn +exportedFrom :: Text -> IdeDeclarationAnn -> IdeDeclarationAnn +exportedFrom mn (IdeDeclarationAnn ann decl) = IdeDeclarationAnn (ann {_annExportedFrom = Just (m mn)}) decl + valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn valueA = d (IdeDeclValue (IdeValue (P.Ident "valueA") P.REmpty)) typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.kindType)) @@ -32,34 +35,34 @@ env = Map.fromList type Refs = [(P.ModuleName, P.DeclarationRef)] -succTestCases :: [(Text, [IdeDeclarationAnn], Refs, [IdeDeclarationAnn])] +succTestCases :: [(Text, Refs, [IdeDeclarationAnn])] succTestCases = - [ ("resolves a value reexport", [], [(m "A", P.ValueRef (P.Ident "valueA"))], [valueA]) + [ ("resolves a value reexport", [(m "A", P.ValueRef (P.Ident "valueA"))], [exportedFrom "A" valueA]) , ("resolves a type reexport with explicit data constructors" - , [], [(m "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], [typeA, dtorA1]) + , [(m "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], [exportedFrom "A" typeA, exportedFrom "A" dtorA1]) , ("resolves a type reexport with implicit data constructors" - , [], [(m "A", P.TypeRef (P.ProperName "TypeA") Nothing)], [typeA, dtorA1, dtorA2]) - , ("resolves a class reexport", [], [(m "A", P.TypeClassRef (P.ProperName "ClassA"))], [classA]) + , [(m "A", P.TypeRef (P.ProperName "TypeA") Nothing)], map (exportedFrom "A") [typeA, dtorA1, dtorA2]) + , ("resolves a class reexport", [(m "A", P.TypeClassRef (P.ProperName "ClassA"))], [exportedFrom "A" classA]) ] -failTestCases :: [(Text, [IdeDeclarationAnn], Refs)] +failTestCases :: [(Text, Refs)] failTestCases = - [ ("fails to resolve a non existing value", [], [(m "A", P.ValueRef (P.Ident "valueB"))]) - , ("fails to resolve a non existing type reexport" , [], [(m "A", P.TypeRef (P.ProperName "TypeB") Nothing)]) - , ("fails to resolve a non existing class reexport", [], [(m "A", P.TypeClassRef (P.ProperName "ClassB"))]) + [ ("fails to resolve a non existing value", [(m "A", P.ValueRef (P.Ident "valueB"))]) + , ("fails to resolve a non existing type reexport" , [(m "A", P.TypeRef (P.ProperName "TypeB") Nothing)]) + , ("fails to resolve a non existing class reexport", [(m "A", P.TypeClassRef (P.ProperName "ClassB"))]) ] spec :: Spec spec = do describe "Successful Reexports" $ - for_ succTestCases $ \(desc, initial, refs, result) -> + for_ succTestCases $ \(desc, refs, result) -> it (toS desc) $ do - let reResult = resolveReexports' env initial refs + let reResult = resolveReexports' env refs reResolved reResult `shouldBe` result reResult `shouldSatisfy` not . reexportHasFailures describe "Failed Reexports" $ - for_ failTestCases $ \(desc, initial, refs) -> + for_ failTestCases $ \(desc, refs) -> it (toS desc) $ do - let reResult = resolveReexports' env initial refs + let reResult = resolveReexports' env refs reFailed reResult `shouldBe` refs reResult `shouldSatisfy` reexportHasFailures diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index 4ea76d318b..8feb9e26cd 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -47,13 +47,13 @@ ann :: IdeDeclarationAnn -> Annotation -> IdeDeclarationAnn ann (IdeDeclarationAnn _ d) a = IdeDeclarationAnn a d annLoc :: IdeDeclarationAnn -> P.SourceSpan -> IdeDeclarationAnn -annLoc (IdeDeclarationAnn a d) loc = IdeDeclarationAnn a {annLocation = Just loc} d +annLoc (IdeDeclarationAnn a d) loc = IdeDeclarationAnn a {_annLocation = Just loc} d annExp :: IdeDeclarationAnn -> P.ModuleName -> IdeDeclarationAnn -annExp (IdeDeclarationAnn a d) e = IdeDeclarationAnn a {annExportedFrom = Just e} d +annExp (IdeDeclarationAnn a d) e = IdeDeclarationAnn a {_annExportedFrom = Just e} d annTyp :: IdeDeclarationAnn -> P.Type -> IdeDeclarationAnn -annTyp (IdeDeclarationAnn a d) ta = IdeDeclarationAnn a {annTypeAnnotation = Just ta} d +annTyp (IdeDeclarationAnn a d) ta = IdeDeclarationAnn a {_annTypeAnnotation = Just ta} d ida :: IdeDeclaration -> IdeDeclarationAnn From c5cbdcef6f730c7372dda728dab803ade7861ee9 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 25 Mar 2017 13:20:57 -0700 Subject: [PATCH 0733/1580] Use git log to get tag versions (#2771) * Use git show to get tag date * Use git log --- src/Language/PureScript/Publish.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index f89f36188b..a1ec6867a0 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -196,7 +196,7 @@ getVersionFromGitTag = do -- | Given a git tag, get the time it was created. getTagTime :: Text -> PrepareM UTCTime getTagTime tag = do - out <- readProcess' "git" ["tag", "-l", T.unpack tag, "--format=%(taggerdate:unix)"] "" + out <- readProcess' "git" ["log", "-1", "--format=%ct", T.unpack tag] "" case mapMaybe readMaybe (lines out) of [t] -> pure . posixSecondsToUTCTime . fromInteger $ t _ -> internalError (CouldntParseGitTagDate tag) From d752d9c07a4231ecf98ba845d1c5f5d8d5cd756b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 25 Mar 2017 13:51:44 -0700 Subject: [PATCH 0734/1580] Improve error when using old-style context (#2773) --- src/Language/PureScript/Parser/Types.hs | 31 +++++++++++++++++++++---- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 7c8f03041b..2cf90da892 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -9,6 +9,7 @@ import Prelude.Compat import Control.Monad (when, unless) import Control.Applicative ((<|>)) +import Data.Functor (($>)) import qualified Data.Text as T import Language.PureScript.AST.SourcePos @@ -68,13 +69,13 @@ parseTypeAtom = indented *> P.choice , ParensInType <$> parens parsePolyType ] -parseConstrainedType :: TokenParser Type +parseConstrainedType :: TokenParser ([Constraint], Type) parseConstrainedType = do - constraint <- parens parseConstraint <|> parseConstraint + constraints <- parens (commaSep1 parseConstraint) <|> pure <$> parseConstraint _ <- rfatArrow indented ty <- parseType - return $ ConstrainedType constraint ty + return (constraints, ty) where parseConstraint = do className <- parseQualified properName @@ -82,14 +83,34 @@ parseConstrainedType = do ty <- P.many parseTypeAtom return (Constraint className ty Nothing) +-- This is here to improve the error message when the user +-- tries to use the old style constraint contexts. +-- TODO: Remove this before 1.0 +typeOrConstrainedType :: TokenParser Type +typeOrConstrainedType = do + e <- P.try (Left <$> parseConstrainedType) <|> Right <$> parseTypeAtom + case e of + Left ([c], ty) -> pure (ConstrainedType c ty) + Left _ -> + P.unexpected $ + unlines [ "comma in constraints." + , "" + , "Class constraints in type annotations can no longer be grouped in parentheses." + , "Each constraint should now be separated by `=>`, for example:" + , " `(Applicative f, Semigroup a) => a -> f a -> f a`" + , " would now be written as:" + , " `Applicative f => Semigroup a => a -> f a -> f a`." + ] + Right ty -> pure ty + parseAnyType :: TokenParser Type -parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable (P.try parseConstrainedType <|> parseTypeAtom)) P. "type" +parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable typeOrConstrainedType) P. "type" where operators = [ [ P.Infix (return TypeApp) P.AssocLeft ] , [ P.Infix (P.try (parseQualified parseOperator) >>= \ident -> return (BinaryNoParensType (TypeOp ident))) P.AssocRight ] - , [ P.Infix (rarrow *> return function) P.AssocRight ] + , [ P.Infix (rarrow $> function) P.AssocRight ] ] postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind) ] From 1b965e806146764e2eb74ffe90485f7dcf1b9426 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 27 Mar 2017 10:44:24 -0700 Subject: [PATCH 0735/1580] Use latest 0.11-compatible libraries for tests (#2785) * use latest 0.11-compatible libraries for tests * New support modules --- tests/TestUtils.hs | 9 +++++++++ tests/support/bower.json | 30 +++++++++++++++--------------- 2 files changed, 24 insertions(+), 15 deletions(-) diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 3e04f69168..86a99f6d4e 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -113,6 +113,15 @@ supportModules = , "Data.Generic.Rep.Show" , "Data.HeytingAlgebra" , "Data.Identity" + , "Data.Lazy" + , "Data.List" + , "Data.List.Lazy" + , "Data.List.Lazy.NonEmpty" + , "Data.List.Lazy.Types" + , "Data.List.NonEmpty" + , "Data.List.Partial" + , "Data.List.Types" + , "Data.List.ZipList" , "Data.Maybe" , "Data.Maybe.First" , "Data.Maybe.Last" diff --git a/tests/support/bower.json b/tests/support/bower.json index bae32d6f7f..bdee017fc7 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -1,21 +1,21 @@ { "name": "purescript-test-suite-support", "dependencies": { - "purescript-arrays": "ps-0.11", - "purescript-assert": "ps-0.11", - "purescript-console": "ps-0.11", - "purescript-eff": "ps-0.11", - "purescript-functions": "ps-0.11", - "purescript-generics": "ps-0.11", - "purescript-generics-rep": "ps-0.11", - "purescript-newtype": "ps-0.11", + "purescript-arrays": "4.0.0", + "purescript-assert": "3.0.0", + "purescript-console": "3.0.0", + "purescript-eff": "3.0.0", + "purescript-functions": "3.0.0", + "purescript-generics": "4.0.0", + "purescript-generics-rep": "5.0.0", + "purescript-newtype": "2.0.0", "purescript-partial": "1.2.0", - "purescript-prelude": "ps-0.11", - "purescript-psci-support": "ps-0.11", - "purescript-st": "ps-0.11", - "purescript-symbols": "ps-0.11", - "purescript-tailrec": "ps-0.11", - "purescript-typelevel-prelude": "ps-0.11", - "purescript-unsafe-coerce": "ps-0.11" + "purescript-prelude": "3.0.0", + "purescript-psci-support": "3.0.0", + "purescript-st": "3.0.0", + "purescript-symbols": "3.0.0", + "purescript-tailrec": "3.0.0", + "purescript-typelevel-prelude": "2.0.0", + "purescript-unsafe-coerce": "3.0.0" } } From a93d8499d915df48c15e0c1a4e24dab3302c3f98 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 27 Mar 2017 17:16:22 -0700 Subject: [PATCH 0736/1580] Enable TCO for variable intros and assignments (#2782) * Enable TCO for variable intros and assignments * A little more care * A couple more TCO tests --- examples/passing/TCO.purs | 8 ++++++++ src/Language/PureScript/CoreImp/Optimizer/TCO.hs | 8 ++++++++ 2 files changed, 16 insertions(+) diff --git a/examples/passing/TCO.purs b/examples/passing/TCO.purs index dc55311bce..fbd9951886 100644 --- a/examples/passing/TCO.purs +++ b/examples/passing/TCO.purs @@ -2,6 +2,8 @@ module Main where import Prelude import Control.Monad.Eff.Console (log, logShow) +import Control.Monad.Rec.Class +import Data.Array ((..), span, length) main = do let f x = x + 1 @@ -11,6 +13,12 @@ main = do logShow (applyN 2 f v) logShow (applyN 3 f v) logShow (applyN 4 f v) + + let largeArray = 1..10000 + logShow (length (span (\_ -> true) largeArray).init) + + logShow (tailRec (\n -> if n < 10000 then Loop (n + 1) else Done 42) 0) + log "Done" applyN :: forall a. Int -> (a -> a) -> a -> a diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index 7d8518ab9c..f27a843c2b 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -68,6 +68,14 @@ tco = everywhere convert where = all allInTailPosition body allInTailPosition (Throw _ js1) = countSelfReferences js1 == 0 + allInTailPosition (ReturnNoResult _) + = True + allInTailPosition (VariableIntroduction _ _ js1) + = all ((== 0) . countSelfReferences) js1 + allInTailPosition (Assignment _ _ js1) + = countSelfReferences js1 == 0 + allInTailPosition (Comment _ _ js1) + = allInTailPosition js1 allInTailPosition _ = False From 538e8a699bf79f554039475aa8253e699ea64d5e Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 28 Mar 2017 02:28:10 +0100 Subject: [PATCH 0737/1580] Use GHC 8 with stack by default (#2778) * Use GHC 8 with stack by default * Update travis script for GHC 8 default stack file * Use latest stackage snapshot --- .travis.yml | 2 +- stack-ghc-7.10.yaml | 7 +++++++ stack-ghc-8.0.yaml | 5 ----- stack.yaml | 6 ++---- 4 files changed, 10 insertions(+), 10 deletions(-) create mode 100644 stack-ghc-7.10.yaml delete mode 100644 stack-ghc-8.0.yaml diff --git a/.travis.yml b/.travis.yml index ef669f1313..4f00ebe210 100644 --- a/.travis.yml +++ b/.travis.yml @@ -18,7 +18,7 @@ matrix: - os: linux dist: trusty sudo: required - env: BUILD_TYPE=normal STACK_YAML=stack-ghc-8.0.yaml + env: BUILD_TYPE=normal - os: linux dist: trusty diff --git a/stack-ghc-7.10.yaml b/stack-ghc-7.10.yaml new file mode 100644 index 0000000000..4e9e34c595 --- /dev/null +++ b/stack-ghc-7.10.yaml @@ -0,0 +1,7 @@ +resolver: lts-6.25 +packages: +- '.' +extra-deps: +- aeson-better-errors-0.9.1.0 +- bower-json-1.0.0.1 +- optparse-applicative-0.13.0.0 diff --git a/stack-ghc-8.0.yaml b/stack-ghc-8.0.yaml deleted file mode 100644 index 8f9ec68f50..0000000000 --- a/stack-ghc-8.0.yaml +++ /dev/null @@ -1,5 +0,0 @@ -resolver: lts-8.0 -packages: -- '.' -extra-deps: -- pipes-http-1.0.5 diff --git a/stack.yaml b/stack.yaml index 4e9e34c595..c04a09eede 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,5 @@ -resolver: lts-6.25 +resolver: lts-8.5 packages: - '.' extra-deps: -- aeson-better-errors-0.9.1.0 -- bower-json-1.0.0.1 -- optparse-applicative-0.13.0.0 +- pipes-http-1.0.5 From 6d0e6b74a39c1a8cd66e48b06d2ffad009329912 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 27 Mar 2017 20:25:32 -0700 Subject: [PATCH 0738/1580] Upgrade Stack (#2788) --- appveyor.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/appveyor.yml b/appveyor.yml index 25fbbcf581..6d2b979717 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -3,7 +3,7 @@ version: '{build}' environment: # Keep the path as short as possible, just in case. STACK_ROOT: c:\s - STACK_VER: 1.2.0 + STACK_VER: 1.3.2 RELEASE_USER: purescript RELEASE_REPO: purescript cache: From acaa039712fddabf1ea2ed2c65db766bad825cb8 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 28 Mar 2017 09:05:23 -0700 Subject: [PATCH 0739/1580] #2787 Fix special case in guard codegen (#2789) * Fix special case in guard codegen, fix #2787 * Add a test --- examples/passing/2787.purs | 8 ++++++ src/Language/PureScript/CodeGen/JS.hs | 28 ++++++------------- .../PureScript/CoreImp/Optimizer/Blocks.hs | 8 +++--- 3 files changed, 20 insertions(+), 24 deletions(-) create mode 100644 examples/passing/2787.purs diff --git a/examples/passing/2787.purs b/examples/passing/2787.purs new file mode 100644 index 0000000000..d7e957a5bd --- /dev/null +++ b/examples/passing/2787.purs @@ -0,0 +1,8 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console + +main + | between 0 1 2 = log "Fail" + | otherwise = log "Done" diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 991223aadc..4a67550540 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -9,7 +9,7 @@ module Language.PureScript.CodeGen.JS import Prelude.Compat import Protolude (ordNub) -import Control.Arrow ((&&&), second) +import Control.Arrow ((&&&)) import Control.Monad (forM, replicateM, void) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, asks) @@ -329,25 +329,13 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = valueError s _ = accessorString "name" . accessorString "constructor" $ AST.Var Nothing s guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST] - guardsToJs (Left gs) = snd <$> F.foldrM genGuard (False, []) gs - where - genGuard (cond, val) (False, js) = second (: js) <$> genCondVal cond val - genGuard _ x = pure x - - genCondVal cond val - | condIsTrue cond = do - js <- AST.Return Nothing <$> valueToJs val - return (True, js) - | otherwise = do - cond' <- valueToJs cond - val' <- valueToJs val - return - (False, AST.IfElse Nothing cond' - (AST.Block Nothing [AST.Return Nothing val']) Nothing) - - -- hopefully the inliner did its job and inlined `otherwise` - condIsTrue (Literal _ (BooleanLiteral True)) = True - condIsTrue _ = False + guardsToJs (Left gs) = traverse genGuard gs where + genGuard (cond, val) = do + cond' <- valueToJs cond + val' <- valueToJs val + return + (AST.IfElse Nothing cond' + (AST.Block Nothing [AST.Return Nothing val']) Nothing) guardsToJs (Right v) = return . AST.Return Nothing <$> valueToJs v diff --git a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs index 47b2373aaa..04febf2039 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs @@ -10,19 +10,19 @@ import Language.PureScript.CoreImp.AST -- | Collapse blocks which appear nested directly below another block collapseNestedBlocks :: AST -> AST -collapseNestedBlocks = everywhere collapse - where +collapseNestedBlocks = everywhere collapse where collapse :: AST -> AST collapse (Block ss sts) = Block ss (concatMap go sts) collapse js = js + go :: AST -> [AST] go (Block _ sts) = sts go s = [s] collapseNestedIfs :: AST -> AST -collapseNestedIfs = everywhere collapse - where +collapseNestedIfs = everywhere collapse where collapse :: AST -> AST + collapse (IfElse _ (BooleanLiteral _ True) (Block _ [js]) _) = js collapse (IfElse s1 cond1 (Block _ [IfElse s2 cond2 body Nothing]) Nothing) = IfElse s1 (Binary s2 And cond1 cond2) body Nothing collapse js = js From b1dc5c6610f1c732faf0d4cdec6190baa131279a Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 28 Mar 2017 09:07:23 -0700 Subject: [PATCH 0740/1580] List instance info under correct sections, fix #2780 (#2790) --- src/Language/PureScript/Docs/Convert/Single.hs | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 84b0b62d2d..0c4ce0918b 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -25,6 +25,13 @@ convertSingleModule m@(P.Module _ coms moduleName _ _) = >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d) >>> augmentDeclarations +-- | Different declarations we can augment +data AugmentType + = AugmentClass + -- ^ Augment documentation for a type class + | AugmentType + -- ^ Augment documentation for a type constructor + -- | The data type for an intermediate stage which we go through during -- converting. -- @@ -43,7 +50,7 @@ convertSingleModule m@(P.Module _ coms moduleName _ _) = -- instance. For a fixity declaration, it would be just the relevant operator's -- name. type IntermediateDeclaration - = Either ([Text], DeclarationAugment) Declaration + = Either ([(Text, AugmentType)], DeclarationAugment) Declaration -- | Some data which will be used to augment a Declaration in the -- output. @@ -64,10 +71,13 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) = where go ds (parentTitles, a) = map (\d -> - if declTitle d `elem` parentTitles + if any (matches d) parentTitles then augmentWith a d else d) ds + matches d (name, AugmentType) = isType d && declTitle d == name + matches d (name, AugmentClass) = isTypeClass d && declTitle d == name + augmentWith (AugmentChild child) d = d { declChildren = declChildren d ++ [child] } @@ -132,7 +142,7 @@ convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title = convertClassMember _ = P.internalError "convertDeclaration: Invalid argument to convertClassMember." convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = - Just (Left (classNameString : typeNameStrings, AugmentChild childDecl)) + Just (Left ((classNameString, AugmentClass) : map (, AugmentType) typeNameStrings, AugmentChild childDecl)) where classNameString = unQual className typeNameStrings = ordNub (concatMap (P.everythingOnTypes (++) extractProperNames) tys) From 422f927d59742e58102f87a3048032d71d52aaf0 Mon Sep 17 00:00:00 2001 From: rightfold Date: Tue, 28 Mar 2017 18:16:42 +0200 Subject: [PATCH 0741/1580] Wrap decl title in span for better double-click selection (#2786) * Wrap decl title in span for better double-click selection * Fix ambiguity error * Convert text to HTML --- src/Language/PureScript/Docs/AsHtml.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index e99c5b6a03..c3eec5bd36 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -126,7 +126,7 @@ declAsHtml r d@Declaration{..} = do H.div ! A.class_ "decl" ! A.id (v (T.drop 1 declFragment)) $ do h3 ! A.class_ "decl__title clearfix" $ do a ! A.class_ "decl__anchor" ! A.href (v declFragment) $ "#" - text declTitle + H.span $ text declTitle for_ declSourceSpan (linkToSource r) H.div ! A.class_ "decl__body" $ do From fa0291dae650b8665f609a193c0e02c8dce5b31a Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 28 Mar 2017 12:48:35 -0700 Subject: [PATCH 0742/1580] 0.11.1 --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index 0df22a167b..f9dc2d87b7 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.11.0 +version: 0.11.1 cabal-version: >=1.8 build-type: Simple license: BSD3 From 838fd3fa38d2e4881cbd02e721c2aa39fb492fd8 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 29 Mar 2017 13:38:17 -0700 Subject: [PATCH 0743/1580] Polymorphic Labels (#2784) * Polymorphic Labels * Docs for Prim * Simplify things - switch to a 4-way relation --- examples/passing/PolyLabels.js | 17 +++++ examples/passing/PolyLabels.purs | 65 +++++++++++++++++++ src/Language/PureScript/Constants.hs | 3 + src/Language/PureScript/Docs/Prim.hs | 8 +++ src/Language/PureScript/Environment.hs | 11 ++++ .../PureScript/TypeChecker/Entailment.hs | 7 +- 6 files changed, 110 insertions(+), 1 deletion(-) create mode 100644 examples/passing/PolyLabels.js create mode 100644 examples/passing/PolyLabels.purs diff --git a/examples/passing/PolyLabels.js b/examples/passing/PolyLabels.js new file mode 100644 index 0000000000..b9900e4d3b --- /dev/null +++ b/examples/passing/PolyLabels.js @@ -0,0 +1,17 @@ +"use strict"; + +exports.unsafeGet = function (s) { + return function (o) { + return o[s]; + }; +}; + +exports.unsafeSet = function(s) { + return function(a) { + return function (o) { + var o1 = {}; + o1[s] = a; + return Object.assign({}, o, o1); + }; + }; +}; diff --git a/examples/passing/PolyLabels.purs b/examples/passing/PolyLabels.purs new file mode 100644 index 0000000000..c5a50cd43a --- /dev/null +++ b/examples/passing/PolyLabels.purs @@ -0,0 +1,65 @@ +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console +import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) + +foreign import unsafeGet + :: forall r a + . String + -> Record r + -> a + +foreign import unsafeSet + :: forall r1 r2 a + . String + -> a + -> Record r1 + -> Record r2 + +get + :: forall r r' l a + . IsSymbol l + => RowCons l a r' r + => SProxy l + -> Record r + -> a +get l = unsafeGet (reflectSymbol l) + +set + :: forall r1 r2 r l a b + . IsSymbol l + => RowCons l a r r1 + => RowCons l b r r2 + => SProxy l + -> b + -> Record r1 + -> Record r2 +set l = unsafeSet (reflectSymbol l) + +lens + :: forall l f r1 r2 r a b + . IsSymbol l + => RowCons l a r r1 + => RowCons l b r r2 + => Functor f + => SProxy l + -> (a -> f b) + -> Record r1 + -> f (Record r2) +lens l f r = flip (set l) r <$> f (get l r) + +getFoo :: forall a r. { foo :: a | r } -> a +getFoo = get (SProxy :: SProxy "foo") + +setFoo :: forall a b r. b -> { foo :: a | r } -> { foo :: b | r } +setFoo = set (SProxy :: SProxy "foo") + +fooLens :: forall f a b r. Functor f => (a -> f b) -> { foo :: a | r } -> f { foo :: b | r } +fooLens = lens (SProxy :: SProxy "foo") + +main :: Eff (console :: CONSOLE) Unit +main = do + _ <- fooLens logShow { foo: 1 } + log (getFoo (setFoo "Done" { foo: 1 })) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 81bca24af0..0f2fd0050e 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -384,6 +384,9 @@ pattern Warn = Qualified (Just Prim) (ProperName "Warn") pattern Union :: Qualified (ProperName 'ClassName) pattern Union = Qualified (Just Prim) (ProperName "Union") +pattern RowCons :: Qualified (ProperName 'ClassName) +pattern RowCons = Qualified (Just Prim) (ProperName "RowCons") + typ :: forall a. (IsString a) => a typ = "Type" diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index c2070b1e78..2a5e62c641 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -26,6 +26,7 @@ primDocsModule = Module , fail , warn , union + , rowCons , typeConcat , typeString , kindType @@ -237,6 +238,13 @@ union = primClass "Union" $ T.unlines , "The third type argument represents the union of the first two." ] +rowCons :: Declaration +rowCons = primClass "RowCons" $ T.unlines + [ "The RowCons type class is a 4-way relation which asserts that one row of" + , "types can be obtained from another by inserting a new label/type pair on" + , "the left." + ] + typeConcat :: Declaration typeConcat = primType "TypeConcat" $ T.unlines [ "The TypeConcat type constructor concatenates two Symbols in a custom type" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 1366a7bd33..b0f0c7b8b3 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -327,6 +327,7 @@ primTypes = , (primName "Boolean", (kindType, ExternData)) , (primName "Partial", (kindType, ExternData)) , (primName "Union", (FunKind (Row kindType) (FunKind (Row kindType) (FunKind (Row kindType) kindType)), ExternData)) + , (primName "RowCons", (FunKind kindSymbol (FunKind kindType (FunKind (Row kindType) (FunKind (Row kindType) kindType))), ExternData)) , (primName "Fail", (FunKind kindSymbol kindType, ExternData)) , (primName "Warn", (FunKind kindSymbol kindType, ExternData)) , (primName "TypeString", (FunKind kindType kindSymbol, ExternData)) @@ -355,6 +356,16 @@ primClasses = , FunctionalDependency [1, 2] [0] , FunctionalDependency [2, 0] [1] ])) + -- class RowCons (l :: Symbol) (a :: Type) (i :: # Type) (o :: # Type) | l i a -> o, l o -> a i + , (primName "RowCons", (makeTypeClassData + [ ("l", Just kindSymbol) + , ("a", Just (Row kindType)) + , ("i", Just kindType) + , ("o", Just kindType) + ] [] [] + [ FunctionalDependency [0, 1, 2] [3] + , FunctionalDependency [0, 3] [1, 2] + ])) ] -- | Finds information about data constructors from the current environment. diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 52b53a7ae3..eeabfd711c 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -55,7 +55,9 @@ data Evidence | AppendSymbolInstance -- ^ Computed instance of AppendSymbol | UnionInstance - -- ^ Computed instance of RowUnion + -- ^ Computed instance of Union + | ConsInstance + -- ^ Computed instance of RowCons deriving (Show, Eq) -- | Extract the identifier of a named instance @@ -167,6 +169,8 @@ entails SolverOptions{..} constraint context hints = forClassName _ C.Union [l, r, u] | Just (lOut, rOut, uOut, cst) <- unionRows l r u = [ TypeClassDictionaryInScope UnionInstance [] C.Union [lOut, rOut, uOut] cst ] + forClassName _ C.RowCons [TypeLevelString sym, ty, r, _] + = [ TypeClassDictionaryInScope ConsInstance [] C.RowCons [TypeLevelString sym, ty, r, RCons (Label sym) ty r] Nothing ] forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) forClassName _ _ _ = internalError "forClassName: expected qualified class name" @@ -326,6 +330,7 @@ entails SolverOptions{..} constraint context hints = -- We need the subgoal dictionary to appear in the term somewhere return $ App (Abs (VarBinder (Ident C.__unused)) valUndefined) e mkDictionary UnionInstance _ = return valUndefined + mkDictionary ConsInstance _ = return valUndefined mkDictionary (WarnInstance msg) _ = do tell . errorMessage $ UserDefinedWarning msg -- We cannot call the type class constructor here because Warn is declared in Prim. From 671ff58a02bbceea4e94f73b00742299240ed061 Mon Sep 17 00:00:00 2001 From: Hyunje Jun Date: Sat, 1 Apr 2017 02:57:46 +0900 Subject: [PATCH 0744/1580] PSCi eval test suite (#2791) * Separate PSCi eval test suite from command test * Make trim function easier to read * Sort test build dependencies * Use '-- @shouldEvaluateTo' instead of '--' * Refactor EvalTest.hs * Add multiline support for PSCi eval test suites * Use Hspec instead of HUnit in PSCi tests * Use stripPrefix for command prefix of PSCi eval test --- examples/psci/BasicEval.purs | 10 +++++ examples/psci/Multiline.purs | 10 +++++ purescript.cabal | 2 + tests/TestPsci.hs | 19 +++------ tests/TestPsci/CommandTest.hs | 51 ++++++++++++------------ tests/TestPsci/CompletionTest.hs | 16 ++++---- tests/TestPsci/EvalTest.hs | 66 ++++++++++++++++++++++++++++++++ tests/TestPsci/TestEnv.hs | 6 +-- 8 files changed, 130 insertions(+), 50 deletions(-) create mode 100644 examples/psci/BasicEval.purs create mode 100644 examples/psci/Multiline.purs create mode 100644 tests/TestPsci/EvalTest.hs diff --git a/examples/psci/BasicEval.purs b/examples/psci/BasicEval.purs new file mode 100644 index 0000000000..2722a71081 --- /dev/null +++ b/examples/psci/BasicEval.purs @@ -0,0 +1,10 @@ +import Prelude +import Data.Array + +-- @shouldEvaluateTo 3628800 +let fac n = foldl mul 1 (1..n) in fac 10 + +fac n = foldl mul 1 (1..n) + +-- @shouldEvaluateTo 3628800 +fac 10 diff --git a/examples/psci/Multiline.purs b/examples/psci/Multiline.purs new file mode 100644 index 0000000000..86f0dcf420 --- /dev/null +++ b/examples/psci/Multiline.purs @@ -0,0 +1,10 @@ +import Prelude +import Data.Array + +-- @paste +fac :: Int -> Int +fac n = foldl mul 1 (1..n) +-- @paste + +-- @shouldEvaluateTo 3628800 +fac 10 diff --git a/purescript.cabal b/purescript.cabal index f9dc2d87b7..6521fdbf74 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -433,6 +433,7 @@ test-suite tests process -any, protolude >= 0.1.6, silently -any, + split -any, stm -any, text -any, time -any, @@ -451,6 +452,7 @@ test-suite tests TestPsci TestPsci.CommandTest TestPsci.CompletionTest + TestPsci.EvalTest TestPsci.TestEnv TestPscIde PscIdeSpec diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index cf40aa501a..c5017f11d6 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -1,22 +1,15 @@ -{-# LANGUAGE RecordWildCards #-} - module TestPsci where import Prelude () import Prelude.Compat -import Control.Monad (when) -import System.Exit (exitFailure) -import Test.HUnit +import Test.Hspec import TestPsci.CommandTest (commandTests) import TestPsci.CompletionTest (completionTests) +import TestPsci.EvalTest (evalTests) main :: IO () -main = do - Counts{..} <- runTestTT allTests - when (errors + failures > 0) exitFailure - -allTests :: Test -allTests = TestList [ completionTests - , commandTests - ] +main = hspec $ do + completionTests + commandTests + evalTests diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs index 543a844251..f1e36b2536 100644 --- a/tests/TestPsci/CommandTest.hs +++ b/tests/TestPsci/CommandTest.hs @@ -5,31 +5,30 @@ import Prelude.Compat import Control.Monad.Trans.RWS.Strict (get) import Language.PureScript.Interactive -import Test.HUnit +import Test.Hspec import TestPsci.TestEnv -commandTests :: Test -commandTests = TestLabel "commandTests" $ TestList $ map (TestCase . execTestPSCi) - [ do - run "import Prelude" - run "import Data.Functor" - run "import Control.Monad" - before <- psciImportedModules <$> get - length before `equalsTo` 3 - run ":clear" - after <- psciImportedModules <$> get - length after `equalsTo` 0 - , do - run "import Prelude" - run "import Data.Functor" - run "import Control.Monad" - before <- psciImportedModules <$> get - length before `equalsTo` 3 - run ":reload" - after <- psciImportedModules <$> get - length after `equalsTo` 3 - , do - run "import Prelude" - run "import Data.Array" - "let fac n = foldl mul 1 (1..n) in fac 10" `evaluatesTo` "3628800" - ] +specPSCi :: String -> TestPSCi () -> Spec +specPSCi label = specify label . execTestPSCi + +commandTests :: Spec +commandTests = context "commandTests" $ do + specPSCi ":clear" $ do + run "import Prelude" + run "import Data.Functor" + run "import Control.Monad" + ms <- psciImportedModules <$> get + length ms `equalsTo` 3 + run ":clear" + ms' <- psciImportedModules <$> get + length ms' `equalsTo` 0 + + specPSCi ":reload" $ do + run "import Prelude" + run "import Data.Functor" + run "import Control.Monad" + ms <- psciImportedModules <$> get + length ms `equalsTo` 3 + run ":reload" + ms' <- psciImportedModules <$> get + length ms' `equalsTo` 3 diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index 6ffb4869f4..47f57cad30 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -3,8 +3,9 @@ module TestPsci.CompletionTest where import Prelude () import Prelude.Compat -import Test.HUnit +import Test.Hspec +import Control.Monad (mapM_) import Control.Monad.Trans.State.Strict (evalStateT) import Data.List (sort) import qualified Data.Text as T @@ -14,10 +15,9 @@ import System.Console.Haskeline import TestPsci.TestEnv (initTestPSCiEnv) import TestUtils (supportModules) -completionTests :: Test -completionTests = - TestLabel "completionTests" - (TestList (map (TestCase . assertCompletedOk) completionTestData)) +completionTests :: Spec +completionTests = context "completionTests" $ + mapM_ assertCompletedOk completionTestData -- If the cursor is at the right end of the line, with the 1st element of the -- pair as the text in the line, then pressing tab should offer all the @@ -84,12 +84,12 @@ completionTestData = , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"]) ] -assertCompletedOk :: (String, [String]) -> Assertion -assertCompletedOk (line, expecteds) = do +assertCompletedOk :: (String, [String]) -> Spec +assertCompletedOk (line, expecteds) = specify line $ do (unusedR, completions) <- runCM (completion' (reverse line, "")) let unused = reverse unusedR let actuals = map ((unused ++) . replacement) completions - sort expecteds @=? sort actuals + sort expecteds `shouldBe` sort actuals runCM :: CompletionM a -> IO a runCM act = do diff --git a/tests/TestPsci/EvalTest.hs b/tests/TestPsci/EvalTest.hs new file mode 100644 index 0000000000..82b566f02e --- /dev/null +++ b/tests/TestPsci/EvalTest.hs @@ -0,0 +1,66 @@ +module TestPsci.EvalTest where + +import Prelude () +import Prelude.Compat + +import Control.Monad (forM_, foldM_) +import Control.Monad.IO.Class (liftIO) +import Data.List (stripPrefix, intercalate) +import Data.List.Split (splitOn) +import System.Directory (getCurrentDirectory) +import System.Exit (exitFailure) +import System.FilePath ((), takeFileName) +import qualified System.FilePath.Glob as Glob +import System.IO.UTF8 (readUTF8File) +import Test.Hspec +import TestPsci.TestEnv + +evalTests :: Spec +evalTests = context "evalTests" $ do + testFiles <- runIO evalTestFiles + forM_ testFiles evalTest + +evalTestFiles :: IO [FilePath] +evalTestFiles = do + cwd <- getCurrentDirectory + let psciExamples = cwd "examples" "psci" + Glob.globDir1 (Glob.compile "**/*.purs") psciExamples + +data EvalLine = Line String + | Comment EvalContext + | Empty + | Invalid String + deriving (Show) + +data EvalContext = ShouldEvaluateTo String + | Paste [String] + | None + deriving (Show) + +evalCommentPrefix :: String +evalCommentPrefix = "-- @" + +parseEvalLine :: String -> EvalLine +parseEvalLine "" = Empty +parseEvalLine line = + case stripPrefix evalCommentPrefix line of + Just rest -> + case splitOn " " rest of + "shouldEvaluateTo" : args -> Comment (ShouldEvaluateTo $ intercalate " " args) + "paste" : [] -> Comment (Paste []) + _ -> Invalid line + Nothing -> Line line + +evalTest :: FilePath -> Spec +evalTest f = specify (takeFileName f) $ do + evalLines <- map parseEvalLine . lines <$> readUTF8File f + execTestPSCi $ foldM_ handleLine None evalLines + +handleLine :: EvalContext -> EvalLine -> TestPSCi EvalContext +handleLine ctx Empty = pure ctx +handleLine None (Line stmt) = run stmt >> pure None +handleLine None (Comment ctx) = pure ctx +handleLine (ShouldEvaluateTo expected) (Line expr) = expr `evaluatesTo` expected >> pure None +handleLine (Paste ls) (Line l) = pure . Paste $ ls ++ [l] +handleLine (Paste ls) (Comment (Paste _)) = run (intercalate "\n" ls) >> pure None +handleLine _ line = liftIO $ putStrLn ("unexpected: " ++ show line) >> exitFailure diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 35ae45d96e..519f8fb3a6 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -12,7 +12,7 @@ import System.Exit import System.FilePath (()) import qualified System.FilePath.Glob as Glob import System.Process (readProcessWithExitCode) -import Test.HUnit ((@?=)) +import Test.Hspec (shouldBe) -- | A monad transformer for handle PSCi actions in tests type TestPSCi a = RWST PSCiConfig () PSCiState IO a @@ -70,9 +70,9 @@ runAndEval comm eval = run :: String -> TestPSCi () run comm = runAndEval comm $ jsEval *> return () --- | A lifted evaluation of HUnit '@?=' for the TestPSCi +-- | A lifted evaluation of Hspec 'shouldBe' for the TestPSCi equalsTo :: (Eq a, Show a) => a -> a -> TestPSCi () -equalsTo x y = liftIO $ x @?= y +equalsTo x y = liftIO $ x `shouldBe` y -- | An assertion to check if a command evaluates to a string evaluatesTo :: String -> String -> TestPSCi () From 063d873cb733da7947b42be49e80a266655680f0 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 2 Apr 2017 09:19:34 +0200 Subject: [PATCH 0745/1580] [purs ide] Collect more information for classes and synonyms (#2798) When serializing to the Externs format, the compiler decomposes and duplicates some information about type classes and synonyms. This PR reconstructs that information and stores it in the respective IdeDeclaration --- src/Language/PureScript/Ide/Externs.hs | 124 +++++++++--------- src/Language/PureScript/Ide/State.hs | 37 +++++- src/Language/PureScript/Ide/Types.hs | 2 + src/Language/PureScript/Ide/Util.hs | 2 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 27 ++-- .../Language/PureScript/Ide/ReexportsSpec.hs | 38 ++---- .../Language/PureScript/Ide/SourceFileSpec.hs | 4 +- tests/Language/PureScript/Ide/StateSpec.hs | 6 +- tests/Language/PureScript/Ide/Test.hs | 12 +- 9 files changed, 134 insertions(+), 118 deletions(-) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 7797b61f18..b6315a8f92 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -17,16 +17,14 @@ module Language.PureScript.Ide.Externs ( readExternFile , convertExterns - , annotateModule ) where -import Protolude +import Protolude hiding (to, from, (&)) -import Control.Lens ((^.)) +import Control.Lens import "monad-logger" Control.Monad.Logger import Data.Aeson (decodeStrict) import qualified Data.ByteString as BS -import qualified Data.Map as Map import Data.Version (showVersion) import Language.PureScript.Ide.Error (IdeError (..)) import Language.PureScript.Ide.Types @@ -60,45 +58,76 @@ convertExterns ef = where decls = map (IdeDeclarationAnn emptyAnn) - (cleanDeclarations ++ operatorDecls ++ tyOperatorDecls) + (resolvedDeclarations ++ operatorDecls ++ tyOperatorDecls) exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (P.efExports ef) operatorDecls = convertOperator <$> P.efFixities ef tyOperatorDecls = convertTypeOperator <$> P.efTypeFixities ef - declarations = mapMaybe convertDecl (P.efDeclarations ef) - - typeClassFilter = foldMap removeTypeDeclarationsForClass (filter isTypeClassDeclaration declarations) - cleanDeclarations = ordNub (appEndo typeClassFilter declarations) - -removeTypeDeclarationsForClass :: IdeDeclaration -> Endo [IdeDeclaration] -removeTypeDeclarationsForClass (IdeDeclTypeClass n) = Endo (filter notDuplicate) - where notDuplicate (IdeDeclType t) = - n ^. ideTCName . properNameT /= t ^. ideTypeName . properNameT - notDuplicate (IdeDeclTypeSynonym s) = - n ^. ideTCName . properNameT /= s ^. ideSynonymName . properNameT - notDuplicate _ = True -removeTypeDeclarationsForClass _ = mempty + (toResolve, declarations) = + second catMaybes (partitionEithers (map convertDecl (P.efDeclarations ef))) + + -- It's important that we resolve synonyms first, because that resolving + -- process removes the corresponding type declarations. This way we don't + -- leave any stray type declarations for type classes around since they have + -- already been cleaned up in the type synonym pass. + resolver = resolveTypeClasses toResolve <> resolveSynonyms toResolve + resolvedDeclarations = appEndo resolver declarations + +resolveSynonyms :: [ToResolve] -> Endo [IdeDeclaration] +resolveSynonyms = foldMap resolveSynonym + where + resolveSynonym tr = case tr of + TypeClassToResolve _ -> mempty + SynonymToResolve tn ty -> Endo $ \decls -> + case findType tn decls of + Nothing -> decls + Just tyDecl -> + IdeDeclTypeSynonym (IdeTypeSynonym tn ty (tyDecl^.ideTypeKind)) + : filter (not . anyOf (_IdeDeclType.ideTypeName) (== tn)) decls + +resolveTypeClasses :: [ToResolve] -> Endo [IdeDeclaration] +resolveTypeClasses = foldMap resolveTypeClass + where + resolveTypeClass tr = case tr of + SynonymToResolve _ _ -> mempty + TypeClassToResolve tcn -> Endo $ \decls -> + case findSynonym (P.coerceProperName tcn) decls of + Nothing -> decls + Just tySyn -> IdeDeclTypeClass + (IdeTypeClass tcn (tySyn^.ideSynonymKind) []) + : filter (not . anyOf (_IdeDeclTypeSynonym.ideSynonymName) (== P.coerceProperName tcn)) decls + +findType :: P.ProperName 'P.TypeName -> [IdeDeclaration] -> Maybe IdeType +findSynonym :: P.ProperName 'P.TypeName -> [IdeDeclaration] -> Maybe IdeTypeSynonym +(findType, findSynonym) = ( findDecl _IdeDeclType ideTypeName + , findDecl _IdeDeclTypeSynonym ideSynonymName + ) + where + findDecl p l tn decls = decls + & mapMaybe (preview p) + & find ((==) tn . view l) -isTypeClassDeclaration :: IdeDeclaration -> Bool -isTypeClassDeclaration IdeDeclTypeClass{} = True -isTypeClassDeclaration _ = False +-- The Externs format splits information about synonyms across EDType and +-- EDTypeSynonym declarations. For type classes there are three declarations +-- involved. We collect these and resolve them at the end of the conversion process. +data ToResolve + = TypeClassToResolve (P.ProperName 'P.ClassName) + | SynonymToResolve (P.ProperName 'P.TypeName) P.Type convertExport :: P.DeclarationRef -> Maybe (P.ModuleName, P.DeclarationRef) convertExport (P.ReExportRef m r) = Just (m, r) convertExport _ = Nothing -convertDecl :: P.ExternsDeclaration -> Maybe IdeDeclaration -convertDecl P.EDType{..} = Just $ IdeDeclType $ +convertDecl :: P.ExternsDeclaration -> Either ToResolve (Maybe IdeDeclaration) +convertDecl P.EDType{..} = Right $ Just $ IdeDeclType $ IdeType edTypeName edTypeKind -convertDecl P.EDTypeSynonym{..} = Just $ IdeDeclTypeSynonym - (IdeTypeSynonym edTypeSynonymName edTypeSynonymType) -convertDecl P.EDDataConstructor{..} = Just $ IdeDeclDataConstructor $ +convertDecl P.EDTypeSynonym{..} = Left (SynonymToResolve edTypeSynonymName edTypeSynonymType) +convertDecl P.EDDataConstructor{..} = Right $ Just $ IdeDeclDataConstructor $ IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType -convertDecl P.EDValue{..} = Just $ IdeDeclValue $ +convertDecl P.EDValue{..} = Right $ Just $ IdeDeclValue $ IdeValue edValueName edValueType -convertDecl P.EDClass{..} = Just $ IdeDeclTypeClass $ - IdeTypeClass edClassName [] -convertDecl P.EDKind{..} = Just (IdeDeclKind edKindName) -convertDecl P.EDInstance{} = Nothing +convertDecl P.EDClass{..} = Left (TypeClassToResolve edClassName) +convertDecl P.EDKind{..} = Right (Just (IdeDeclKind edKindName)) +convertDecl P.EDInstance{} = Right Nothing convertOperator :: P.ExternsFixity -> IdeDeclaration convertOperator P.ExternsFixity{..} = @@ -117,36 +146,3 @@ convertTypeOperator P.ExternsTypeFixity{..} = efTypePrecedence efTypeAssociativity Nothing - -annotateModule - :: (DefinitionSites P.SourceSpan, TypeAnnotations) - -> [IdeDeclarationAnn] - -> [IdeDeclarationAnn] -annotateModule (defs, types) decls = - map convertDeclaration decls - where - convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn - convertDeclaration (IdeDeclarationAnn ann d) = case d of - IdeDeclValue v -> - annotateFunction (v ^. ideValueIdent) (IdeDeclValue v) - IdeDeclType t -> - annotateType (t ^. ideTypeName . properNameT) (IdeDeclType t) - IdeDeclTypeSynonym s -> - annotateType (s ^. ideSynonymName . properNameT) (IdeDeclTypeSynonym s) - IdeDeclDataConstructor dtor -> - annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor) - IdeDeclTypeClass tc -> - annotateType (tc ^. ideTCName . properNameT) (IdeDeclTypeClass tc) - IdeDeclValueOperator op -> - annotateValue (op ^. ideValueOpName . opNameT) (IdeDeclValueOperator op) - IdeDeclTypeOperator op -> - annotateType (op ^. ideTypeOpName . opNameT) (IdeDeclTypeOperator op) - IdeDeclKind i -> - annotateKind (i ^. properNameT) (IdeDeclKind i) - where - annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNSValue (P.runIdent x)) defs - , _annTypeAnnotation = Map.lookup x types - }) - annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSValue x) defs}) - annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSType x) defs}) - annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSKind x) defs}) diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 8e58f3d8fe..4f6df708f4 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -139,7 +139,7 @@ getAllModules mmoduleName = do ast = fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts) cachedModule = - annotateModule ast (fst (convertExterns ef)) + resolveLocationsForModule ast (fst (convertExterns ef)) tmp = Map.insert moduleName cachedModule declarations resolved = @@ -222,7 +222,40 @@ resolveLocations -> ModuleMap [IdeDeclarationAnn] resolveLocations asts = Map.mapWithKey (\mn decls -> - maybe decls (flip annotateModule decls) (Map.lookup mn asts)) + maybe decls (flip resolveLocationsForModule decls) (Map.lookup mn asts)) + +resolveLocationsForModule + :: (DefinitionSites P.SourceSpan, TypeAnnotations) + -> [IdeDeclarationAnn] + -> [IdeDeclarationAnn] +resolveLocationsForModule (defs, types) decls = + map convertDeclaration decls + where + convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn + convertDeclaration (IdeDeclarationAnn ann d) = case d of + IdeDeclValue v -> + annotateFunction (v ^. ideValueIdent) (IdeDeclValue v) + IdeDeclType t -> + annotateType (t ^. ideTypeName . properNameT) (IdeDeclType t) + IdeDeclTypeSynonym s -> + annotateType (s ^. ideSynonymName . properNameT) (IdeDeclTypeSynonym s) + IdeDeclDataConstructor dtor -> + annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor) + IdeDeclTypeClass tc -> + annotateType (tc ^. ideTCName . properNameT) (IdeDeclTypeClass tc) + IdeDeclValueOperator operator -> + annotateValue (operator ^. ideValueOpName . opNameT) (IdeDeclValueOperator operator) + IdeDeclTypeOperator operator -> + annotateType (operator ^. ideTypeOpName . opNameT) (IdeDeclTypeOperator operator) + IdeDeclKind i -> + annotateKind (i ^. properNameT) (IdeDeclKind i) + where + annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNSValue (P.runIdent x)) defs + , _annTypeAnnotation = Map.lookup x types + }) + annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSValue x) defs}) + annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSType x) defs}) + annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSKind x) defs}) resolveInstances :: ModuleMap P.ExternsFile diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 352b681589..5abd68b752 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -53,6 +53,7 @@ data IdeType = IdeType data IdeTypeSynonym = IdeTypeSynonym { _ideSynonymName :: P.ProperName 'P.TypeName , _ideSynonymType :: P.Type + , _ideSynonymKind :: P.Kind } deriving (Show, Eq, Ord) data IdeDataConstructor = IdeDataConstructor @@ -63,6 +64,7 @@ data IdeDataConstructor = IdeDataConstructor data IdeTypeClass = IdeTypeClass { _ideTCName :: P.ProperName 'P.ClassName + , _ideTCKind :: P.Kind , _ideTCInstances :: [IdeInstance] } deriving (Show, Eq, Ord) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index e6bbaddbea..c96b7452b6 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -74,7 +74,7 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) = IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind) IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyPrintTypeSingleLine) IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyPrintTypeSingleLine) - IdeDeclTypeClass d -> (d ^. ideTCName . properNameT, "type class") + IdeDeclTypeClass d -> (d ^. ideTCName . properNameT, d ^. ideTCKind & P.prettyPrintKind) IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) -> (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyPrintTypeSingleLine typeP) IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) -> diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index b4aabeb857..bb67e7db12 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -56,9 +56,6 @@ listImport = testParseImport "import Data.List as List" consoleImport = testParseImport "import Control.Monad.Eff.Console (log) as Console" maybeImport = testParseImport "import Data.Maybe (Maybe(Just))" -wildcard :: P.Type -wildcard = P.TypeWildcard $ P.SourceSpan "" (P.SourcePos 0 0) (P.SourcePos 0 0) - spec :: Spec spec = do describe "determining the importsection" $ do @@ -104,13 +101,13 @@ spec = do describe "import commands" $ do let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i addValueImport i mn is = - prettyPrintImportSection (addExplicitImport' (IdeDeclValue (IdeValue (P.Ident i) wildcard)) mn is) + prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValue i Nothing)) mn is) addOpImport op mn is = - prettyPrintImportSection (addExplicitImport' (IdeDeclValueOperator (IdeValueOperator op (P.Qualified Nothing (Left (P.Ident ""))) 2 P.Infix Nothing)) mn is) + prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValueOp op (P.Qualified Nothing (Left "")) 2 Nothing Nothing)) mn is) addDtorImport i t mn is = - prettyPrintImportSection (addExplicitImport' (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName i) t wildcard)) mn is) + prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideDtor i t Nothing)) mn is) addTypeImport i mn is = - prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.kindType)) mn is) + prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideType i Nothing)) mn is) it "adds an implicit unqualified import to a file without any imports" $ shouldBe (addImplicitImport' [] (P.moduleNameFromString "Data.Map")) @@ -144,7 +141,7 @@ spec = do ] it "adds an operator to an explicit import list" $ shouldBe - (addOpImport (P.OpName "<~>") (P.moduleNameFromString "Data.Array") explicitImports) + (addOpImport "<~>" (P.moduleNameFromString "Data.Array") explicitImports) [ "import Prelude" , "import Data.Array (tail, (<~>))" ] @@ -156,21 +153,21 @@ spec = do ] it "adds the type for a given DataConstructor" $ shouldBe - (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") simpleFileImports) + (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") simpleFileImports) [ "import Prelude" , "import Data.Maybe (Maybe(..))" ] it "adds a dataconstructor to an existing type import" $ do let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"]) shouldBe - (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") typeImports) + (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") typeImports) [ "import Prelude" , "import Data.Maybe (Maybe(..))" ] it "doesn't add a dataconstructor to an existing type import with open dtors" $ do let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe(..))"]) shouldBe - (addDtorImport "Just" (P.ProperName "Maybe") (P.moduleNameFromString "Data.Maybe") typeImports) + (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") typeImports) [ "import Prelude" , "import Data.Maybe (Maybe(..))" ] @@ -186,10 +183,10 @@ spec = do let Right (_, _, baseImports, _) = sliceImportSection $ withImports ["import Control.Monad (ap)"] moduleName = (P.moduleNameFromString "Control.Monad") addImport imports import' = addExplicitImport' import' moduleName imports - valueImport ident = (IdeDeclValue (IdeValue (P.Ident ident) wildcard)) - typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.kindType)) - classImport name = (IdeDeclTypeClass (IdeTypeClass (P.ProperName name) [])) - dtorImport name typeName = (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName name) (P.ProperName typeName) wildcard)) + valueImport ident = _idaDeclaration (Test.ideValue ident Nothing) + typeImport name = _idaDeclaration (Test.ideType name Nothing) + classImport name = _idaDeclaration (Test.ideTypeClass name P.kindType []) + dtorImport name typeName = _idaDeclaration (Test.ideDtor name typeName Nothing) -- expect any list of provided identifiers, when imported, to come out as specified expectSorted imports expected = shouldBe (ordNub $ map diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index c810af8628..198a08f2a3 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -7,49 +7,39 @@ import Protolude import qualified Data.Map as Map import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Test import qualified Language.PureScript as P import Test.Hspec -type Module = (P.ModuleName, [IdeDeclarationAnn]) - -m :: Text -> P.ModuleName -m = P.moduleNameFromString - -d :: IdeDeclaration -> IdeDeclarationAnn -d = IdeDeclarationAnn emptyAnn - -exportedFrom :: Text -> IdeDeclarationAnn -> IdeDeclarationAnn -exportedFrom mn (IdeDeclarationAnn ann decl) = IdeDeclarationAnn (ann {_annExportedFrom = Just (m mn)}) decl - valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn -valueA = d (IdeDeclValue (IdeValue (P.Ident "valueA") P.REmpty)) -typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.kindType)) -classA = d (IdeDeclTypeClass (IdeTypeClass (P.ProperName "ClassA") [])) -dtorA1 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty)) -dtorA2 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty)) +valueA = ideValue "valueA" Nothing +typeA = ideType "TypeA" Nothing +classA = ideTypeClass "ClassA" P.kindType [] +dtorA1 = ideDtor "DtorA1" "TypeA" Nothing +dtorA2 = ideDtor "DtorA2" "TypeA" Nothing env :: ModuleMap [IdeDeclarationAnn] env = Map.fromList - [ (m "A", [valueA, typeA, classA, dtorA1, dtorA2]) + [ (mn "A", [valueA, typeA, classA, dtorA1, dtorA2]) ] type Refs = [(P.ModuleName, P.DeclarationRef)] succTestCases :: [(Text, Refs, [IdeDeclarationAnn])] succTestCases = - [ ("resolves a value reexport", [(m "A", P.ValueRef (P.Ident "valueA"))], [exportedFrom "A" valueA]) + [ ("resolves a value reexport", [(mn "A", P.ValueRef (P.Ident "valueA"))], [valueA `annExp` "A"]) , ("resolves a type reexport with explicit data constructors" - , [(m "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], [exportedFrom "A" typeA, exportedFrom "A" dtorA1]) + , [(mn "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], [typeA `annExp` "A", dtorA1 `annExp` "A"]) , ("resolves a type reexport with implicit data constructors" - , [(m "A", P.TypeRef (P.ProperName "TypeA") Nothing)], map (exportedFrom "A") [typeA, dtorA1, dtorA2]) - , ("resolves a class reexport", [(m "A", P.TypeClassRef (P.ProperName "ClassA"))], [exportedFrom "A" classA]) + , [(mn "A", P.TypeRef (P.ProperName "TypeA") Nothing)], map (`annExp` "A") [typeA, dtorA1, dtorA2]) + , ("resolves a class reexport", [(mn "A", P.TypeClassRef (P.ProperName "ClassA"))], [classA `annExp` "A"]) ] failTestCases :: [(Text, Refs)] failTestCases = - [ ("fails to resolve a non existing value", [(m "A", P.ValueRef (P.Ident "valueB"))]) - , ("fails to resolve a non existing type reexport" , [(m "A", P.TypeRef (P.ProperName "TypeB") Nothing)]) - , ("fails to resolve a non existing class reexport", [(m "A", P.TypeClassRef (P.ProperName "ClassB"))]) + [ ("fails to resolve a non existing value", [(mn "A", P.ValueRef (P.Ident "valueB"))]) + , ("fails to resolve a non existing type reexport" , [(mn "A", P.TypeRef (P.ProperName "TypeB") Nothing)]) + , ("fails to resolve a non existing class reexport", [(mn "A", P.TypeClassRef (P.ProperName "ClassB"))]) ] spec :: Spec diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 6c760aa03e..50db451428 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -97,12 +97,12 @@ getLocation s = do ideState = emptyIdeState `s3` [ ("Test", [ ideValue "sfValue" Nothing `annLoc` valueSS - , ideSynonym "SFType" P.tyString `annLoc` synonymSS + , ideSynonym "SFType" P.tyString P.kindType `annLoc` synonymSS , ideType "SFData" Nothing `annLoc` typeSS , ideDtor "SFOne" "SFData" Nothing `annLoc` typeSS , ideDtor "SFTwo" "SFData" Nothing `annLoc` typeSS , ideDtor "SFThree" "SFData" Nothing `annLoc` typeSS - , ideTypeClass "SFClass" [] `annLoc` classSS + , ideTypeClass "SFClass" P.kindType [] `annLoc` classSS , ideValueOp "<$>" (P.Qualified Nothing (Left "")) 0 Nothing Nothing `annLoc` valueOpSS , ideTypeOp "~>" (P.Qualified Nothing "") 0 Nothing Nothing diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index ac31866626..78f8cea7b0 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -6,6 +6,7 @@ import Protolude import Control.Lens hiding ((&)) import Language.PureScript.Ide.Types import Language.PureScript.Ide.State +import Language.PureScript.Ide.Test import qualified Language.PureScript as P import Test.Hspec import qualified Data.Map as Map @@ -34,9 +35,6 @@ testModule = (mn "Test", [ d (IdeDeclValue (IdeValue (P.Ident "function") P.REmp d :: IdeDeclaration -> IdeDeclarationAnn d = IdeDeclarationAnn emptyAnn -mn :: Text -> P.ModuleName -mn = P.moduleNameFromString - testState :: ModuleMap [IdeDeclarationAnn] testState = Map.fromList [testModule] @@ -72,7 +70,7 @@ ef = P.ExternsFile -- } moduleMap :: ModuleMap [IdeDeclarationAnn] -moduleMap = Map.singleton (mn "ClassModule") [d (IdeDeclTypeClass (IdeTypeClass (P.ProperName "MyClass") []))] +moduleMap = Map.singleton (mn "ClassModule") [ideTypeClass "MyClass" P.kindType []] ideInstance :: IdeInstance ideInstance = IdeInstance (mn "InstanceModule") (P.Ident "myClassInstance") mempty mempty diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index 8feb9e26cd..ba5908f928 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -49,8 +49,8 @@ ann (IdeDeclarationAnn _ d) a = IdeDeclarationAnn a d annLoc :: IdeDeclarationAnn -> P.SourceSpan -> IdeDeclarationAnn annLoc (IdeDeclarationAnn a d) loc = IdeDeclarationAnn a {_annLocation = Just loc} d -annExp :: IdeDeclarationAnn -> P.ModuleName -> IdeDeclarationAnn -annExp (IdeDeclarationAnn a d) e = IdeDeclarationAnn a {_annExportedFrom = Just e} d +annExp :: IdeDeclarationAnn -> Text -> IdeDeclarationAnn +annExp (IdeDeclarationAnn a d) e = IdeDeclarationAnn a {_annExportedFrom = Just (mn e)} d annTyp :: IdeDeclarationAnn -> P.Type -> IdeDeclarationAnn annTyp (IdeDeclarationAnn a d) ta = IdeDeclarationAnn a {_annTypeAnnotation = Just ta} d @@ -66,11 +66,11 @@ ideValue i ty = ida (IdeDeclValue (IdeValue (P.Ident i) (fromMaybe P.tyString ty ideType :: Text -> Maybe P.Kind -> IdeDeclarationAnn ideType pn ki = ida (IdeDeclType (IdeType (P.ProperName pn) (fromMaybe P.kindType ki))) -ideSynonym :: Text -> P.Type -> IdeDeclarationAnn -ideSynonym pn ty = ida (IdeDeclTypeSynonym (IdeTypeSynonym (P.ProperName pn) ty)) +ideSynonym :: Text -> P.Type -> P.Kind -> IdeDeclarationAnn +ideSynonym pn ty kind = ida (IdeDeclTypeSynonym (IdeTypeSynonym (P.ProperName pn) ty kind)) -ideTypeClass :: Text -> [IdeInstance] -> IdeDeclarationAnn -ideTypeClass pn instances = ida (IdeDeclTypeClass (IdeTypeClass (P.ProperName pn) instances)) +ideTypeClass :: Text -> P.Kind -> [IdeInstance] -> IdeDeclarationAnn +ideTypeClass pn kind instances = ida (IdeDeclTypeClass (IdeTypeClass (P.ProperName pn) kind instances)) ideDtor :: Text -> Text -> Maybe P.Type -> IdeDeclarationAnn ideDtor pn tn ty = ida (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName pn) (P.ProperName tn) (fromMaybe P.tyString ty))) From 2b0a5d3d84a13e1d066fe5c2d07177722b931a24 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 2 Apr 2017 09:20:16 +0200 Subject: [PATCH 0746/1580] adds a package.yaml manifest file for hpack (#2802) --- package.yaml | 155 +++++ purescript.cabal | 1453 ++++++++++++++++++++++++++++++++-------------- 2 files changed, 1160 insertions(+), 448 deletions(-) create mode 100644 package.yaml diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000000..252c7376a9 --- /dev/null +++ b/package.yaml @@ -0,0 +1,155 @@ +name: purescript +version: '0.11.1' +synopsis: PureScript Programming Language Compiler +description: A small strongly, statically typed programming language with expressive + types, inspired by Haskell and compiling to JavaScript. +category: Language +author: > + Phil Freeman , + Gary Burgess , + Hardy Jones , + Harry Garrood , + Christoph Hegemann +maintainer: Phil Freeman +copyright: (c) 2013-16 Phil Freeman, (c) 2014-16 Gary Burgess +license: BSD3 +github: purescript/purescript.git +homepage: http://www.purescript.org/ +extra-source-files: + - examples/**/*.js + - examples/**/*.purs + - examples/**/*.json + - app/static/* + - tests/support/*.json + - tests/support/setup-win.cmd + - tests/support/psci/*.purs + - tests/support/pscide/src/*.purs + - tests/support/pscide/src/*.js + - tests/support/pscide/src/*.fail + - stack.yaml + - README.md + - INSTALL.md + - CONTRIBUTORS.md + - CONTRIBUTING.md +dependencies: + - aeson >=0.8 && <1.1 + - aeson-better-errors >=0.8 + - ansi-terminal >=0.6.2 && <0.7 + - base >=4.8 && <5 + - base-compat >=0.6.0 + - blaze-html >=0.8.1 && <0.9 + - bower-json >=1.0.0.1 && <1.1 + - boxes >=0.1.4 && <0.2.0 + - bytestring + - cheapskate >=0.1 && <0.2 + - clock + - containers + - data-ordlist >=0.4.7.0 + - deepseq + - directory >=1.2 + - dlist + - edit-distance + - filepath + - fsnotify >=0.2.1 + - Glob >=0.7 && <0.8 + - haskeline >=0.7.0.0 + - http-client >=0.4.30 && <0.6.0 + - http-types + - language-javascript >=0.6.0.9 && <0.7 + - lens ==4.* + - lifted-base >=0.2.3 && <0.2.4 + - monad-control >=1.0.0.0 && <1.1 + - monad-logger >=0.3 && <0.4 + - mtl >=2.1.0 && <2.3.0 + - parallel >=3.2 && <3.3 + - parsec >=3.1.10 + - pattern-arrows >=0.0.2 && <0.1 + - pipes >=4.0.0 && <4.4.0 + - pipes-http + - process >=1.2.0 && <1.5 + - protolude >=0.1.6 + - regex-tdfa + - safe >=0.3.9 && <0.4 + - scientific >=0.3.4.9 && <0.4 + - semigroups >=0.16.2 && <0.19 + - sourcemap >=0.1.6 + - spdx ==0.2.* + - split + - stm >=0.2.4.0 + - syb + - text + - time + - transformers >=0.3.0 && <0.6 + - transformers-base >=0.4.0 && <0.5 + - transformers-compat >=0.3.0 + - unordered-containers + - utf8-string >=1 && <2 + - vector + +library: + source-dirs: src + ghc-options: -Wall -O2 + other-modules: Paths_purescript + default-extensions: + - ConstraintKinds + - DataKinds + - DeriveFunctor + - EmptyDataDecls + - FlexibleContexts + - KindSignatures + - LambdaCase + - MultiParamTypeClasses + - NoImplicitPrelude + - PatternGuards + - PatternSynonyms + - RankNTypes + - RecordWildCards + - OverloadedStrings + - ScopedTypeVariables + - TupleSections + - ViewPatterns + +executables: + purs: + main: Main.hs + source-dirs: app + ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N + dependencies: + - ansi-wl-pprint + - file-embed + - network + - optparse-applicative >=0.13.0 + - purescript + - wai ==3.* + - wai-websockets ==3.* + - warp ==3.* + - websockets >=0.9 && <0.11 + when: + - condition: flag(release) + then: + cpp-options: -DRELEASE + else: + dependencies: + - gitrev >=1.2.0 && <1.3 + +tests: + tests: + main: Main.hs + source-dirs: tests + ghc-options: -Wall + dependencies: + - purescript + - hspec + - hspec-discover + - HUnit + - silently + +flags: + release: + description: > + Mark this build as a release build: prevents inclusion of extra + info e.g. commit SHA in --version output) + manual: false + default: false + +stability: experimental diff --git a/purescript.cabal b/purescript.cabal index 6521fdbf74..05619582e4 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,468 +1,1025 @@ -name: purescript -version: 0.11.1 -cabal-version: >=1.8 -build-type: Simple -license: BSD3 -license-file: LICENSE -copyright: (c) 2013-16 Phil Freeman, (c) 2014-16 Gary Burgess -maintainer: Phil Freeman -stability: experimental -synopsis: PureScript Programming Language Compiler -description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. -category: Language -Homepage: http://www.purescript.org/ -author: Phil Freeman , - Gary Burgess , - Hardy Jones , - Harry Garrood , - Christoph Hegemann +-- This file has been generated from package.yaml by hpack version 0.15.0. +-- +-- see: https://github.com/sol/hpack -tested-with: GHC==7.10.3 +name: purescript +version: 0.11.1 +cabal-version: >= 1.10 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: (c) 2013-16 Phil Freeman, (c) 2014-16 Gary Burgess +maintainer: Phil Freeman +stability: experimental +homepage: http://www.purescript.org/ +bug-reports: https://github.com/purescript/purescript.git/issues +synopsis: PureScript Programming Language Compiler +description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. +category: Language +author: Phil Freeman , Gary Burgess , Hardy Jones , Harry Garrood , Christoph Hegemann -extra-source-files: examples/passing/*.purs - , examples/passing/*.js - , examples/passing/2018/*.purs - , examples/passing/2138/*.purs - , examples/passing/2609/*.purs - , examples/passing/ClassRefSyntax/*.purs - , examples/passing/DctorOperatorAlias/*.purs - , examples/passing/ExplicitImportReExport/*.purs - , examples/passing/ExportExplicit/*.purs - , examples/passing/ExportExplicit2/*.purs - , examples/passing/ForeignKind/*.purs - , examples/passing/Import/*.purs - , examples/passing/ImportExplicit/*.purs - , examples/passing/ImportQualified/*.purs - , examples/passing/Module/*.purs - , examples/passing/ModuleDeps/*.purs - , examples/passing/ModuleExport/*.purs - , examples/passing/ModuleExportDupes/*.purs - , examples/passing/ModuleExportExcluded/*.purs - , examples/passing/ModuleExportQualified/*.purs - , examples/passing/ModuleExportSelf/*.purs - , examples/passing/NonConflictingExports/*.purs - , examples/passing/NonOrphanInstanceMulti/*.purs - , examples/passing/NonOrphanInstanceFunDepExtra/*.purs - , examples/passing/OperatorAliasElsewhere/*.purs - , examples/passing/Operators/*.purs - , examples/passing/PendingConflictingImports/*.purs - , examples/passing/PendingConflictingImports2/*.purs - , examples/passing/QualifiedNames/*.purs - , examples/passing/RedefinedFixity/*.purs - , examples/passing/ReExportQualified/*.purs - , examples/passing/ResolvableScopeConflict/*.purs - , examples/passing/ResolvableScopeConflict2/*.purs - , examples/passing/ResolvableScopeConflict3/*.purs - , examples/passing/ShadowedModuleName/*.purs - , examples/passing/SolvingIsSymbol/*.purs - , examples/passing/StringEdgeCases/*.purs - , examples/passing/TransitiveImport/*.purs - , examples/passing/TypeOperators/*.purs - , examples/passing/TypeWithoutParens/*.purs - , examples/failing/*.purs - , examples/failing/1733/*.purs - , examples/failing/2378/*.purs - , examples/failing/2379/*.purs - , examples/failing/ConflictingExports/*.purs - , examples/failing/ConflictingImports/*.purs - , examples/failing/ConflictingImports2/*.purs - , examples/failing/ConflictingQualifiedImports/*.purs - , examples/failing/ConflictingQualifiedImports2/*.purs - , examples/failing/DiffKindsSameName/*.purs - , examples/failing/DuplicateModule/*.purs - , examples/failing/ExportConflictClass/*.purs - , examples/failing/ExportConflictCtor/*.purs - , examples/failing/ExportConflictType/*.purs - , examples/failing/ExportConflictTypeOp/*.purs - , examples/failing/ExportConflictValue/*.purs - , examples/failing/ExportConflictValueOp/*.purs - , examples/failing/ExportExplicit1/*.purs - , examples/failing/ExportExplicit3/*.purs - , examples/failing/ImportExplicit/*.purs - , examples/failing/ImportExplicit2/*.purs - , examples/failing/ImportHidingModule/*.purs - , examples/failing/ImportModule/*.purs - , examples/failing/InstanceExport/*.purs - , examples/failing/OrphanInstance/*.purs - , examples/failing/OrphanInstanceFunDepCycle/*.purs - , examples/failing/OrphanInstanceWithDetermined/*.purs - , examples/failing/OrphanInstanceNullary/*.purs - , examples/warning/*.purs - , examples/warning/*.js - , examples/warning/UnusedExplicitImportTypeOp/*.purs - , examples/docs/bower_components/purescript-prelude/src/*.purs - , examples/docs/bower.json - , examples/docs/src/*.purs - , examples/docs/resolutions.json - , app/static/index.html - , app/static/index.js - , app/static/*.css - , tests/support/package.json - , tests/support/bower.json - , tests/support/setup-win.cmd - , tests/support/psci/*.purs - , tests/support/pscide/src/*.purs - , tests/support/pscide/src/*.js - , tests/support/pscide/src/*.fail - , tests/support/prelude-resolutions.json - , stack.yaml - , README.md - , INSTALL.md - , CONTRIBUTORS.md - , CONTRIBUTING.md + +extra-source-files: + app/static/index.html + app/static/index.js + app/static/normalize.css + app/static/pursuit.css + CONTRIBUTING.md + CONTRIBUTORS.md + examples/docs/bower.json + examples/docs/bower_components/purescript-prelude/src/Prelude.purs + examples/docs/resolutions.json + examples/docs/src/Clash.purs + examples/docs/src/Clash1.purs + examples/docs/src/Clash1a.purs + examples/docs/src/Clash2.purs + examples/docs/src/Clash2a.purs + examples/docs/src/ConstrainedArgument.purs + examples/docs/src/DocComments.purs + examples/docs/src/DuplicateNames.purs + examples/docs/src/Example.purs + examples/docs/src/Example2.purs + examples/docs/src/ExplicitTypeSignatures.purs + examples/docs/src/ImportedTwice.purs + examples/docs/src/ImportedTwiceA.purs + examples/docs/src/ImportedTwiceB.purs + examples/docs/src/MultiVirtual.purs + examples/docs/src/MultiVirtual1.purs + examples/docs/src/MultiVirtual2.purs + examples/docs/src/MultiVirtual3.purs + examples/docs/src/NewOperators.purs + examples/docs/src/NewOperators2.purs + examples/docs/src/NotAllCtors.purs + examples/docs/src/ReExportedTypeClass.purs + examples/docs/src/SolitaryTypeClassMember.purs + examples/docs/src/SomeTypeClass.purs + examples/docs/src/Transitive1.purs + examples/docs/src/Transitive2.purs + examples/docs/src/Transitive3.purs + examples/docs/src/TypeClassWithFunDeps.purs + examples/docs/src/TypeClassWithoutMembers.purs + examples/docs/src/TypeClassWithoutMembersIntermediate.purs + examples/docs/src/TypeOpAliases.purs + examples/docs/src/UTF8.purs + examples/docs/src/Virtual.purs + examples/failing/1071.purs + examples/failing/1169.purs + examples/failing/1175.purs + examples/failing/1310.purs + examples/failing/1570.purs + examples/failing/1733.purs + examples/failing/1733/Thingy.purs + examples/failing/1825.purs + examples/failing/1881.purs + examples/failing/2128-class.purs + examples/failing/2128-instance.purs + examples/failing/2378.purs + examples/failing/2378/Lib.purs + examples/failing/2379.purs + examples/failing/2379/Lib.purs + examples/failing/2434.purs + examples/failing/2534.purs + examples/failing/2542.purs + examples/failing/2567.purs + examples/failing/2601.purs + examples/failing/2616.purs + examples/failing/365.purs + examples/failing/438.purs + examples/failing/881.purs + examples/failing/AnonArgument1.purs + examples/failing/AnonArgument2.purs + examples/failing/AnonArgument3.purs + examples/failing/ArgLengthMismatch.purs + examples/failing/Arrays.purs + examples/failing/ArrayType.purs + examples/failing/BindInDo-2.purs + examples/failing/BindInDo.purs + examples/failing/CannotDeriveNewtypeForData.purs + examples/failing/CaseBinderLengthsDiffer.purs + examples/failing/CaseDoesNotMatchAllConstructorArgs.purs + examples/failing/ConflictingExports.purs + examples/failing/ConflictingExports/A.purs + examples/failing/ConflictingExports/B.purs + examples/failing/ConflictingImports.purs + examples/failing/ConflictingImports/A.purs + examples/failing/ConflictingImports/B.purs + examples/failing/ConflictingImports2.purs + examples/failing/ConflictingImports2/A.purs + examples/failing/ConflictingImports2/B.purs + examples/failing/ConflictingQualifiedImports.purs + examples/failing/ConflictingQualifiedImports/A.purs + examples/failing/ConflictingQualifiedImports/B.purs + examples/failing/ConflictingQualifiedImports2.purs + examples/failing/ConflictingQualifiedImports2/A.purs + examples/failing/ConflictingQualifiedImports2/B.purs + examples/failing/ConstraintFailure.purs + examples/failing/ConstraintInference.purs + examples/failing/DctorOperatorAliasExport.purs + examples/failing/DeclConflictClassCtor.purs + examples/failing/DeclConflictClassSynonym.purs + examples/failing/DeclConflictClassType.purs + examples/failing/DeclConflictCtorClass.purs + examples/failing/DeclConflictCtorCtor.purs + examples/failing/DeclConflictDuplicateCtor.purs + examples/failing/DeclConflictSynonymClass.purs + examples/failing/DeclConflictSynonymType.purs + examples/failing/DeclConflictTypeClass.purs + examples/failing/DeclConflictTypeSynonym.purs + examples/failing/DeclConflictTypeType.purs + examples/failing/DiffKindsSameName.purs + examples/failing/DiffKindsSameName/LibA.purs + examples/failing/DiffKindsSameName/LibB.purs + examples/failing/Do.purs + examples/failing/DoNotSuggestComposition.purs + examples/failing/DoNotSuggestComposition2.purs + examples/failing/DuplicateDeclarationsInLet.purs + examples/failing/DuplicateModule.purs + examples/failing/DuplicateModule/M1.purs + examples/failing/DuplicateProperties.purs + examples/failing/DuplicateTypeVars.purs + examples/failing/Eff.purs + examples/failing/EmptyCase.purs + examples/failing/EmptyClass.purs + examples/failing/EmptyDo.purs + examples/failing/ExportConflictClass.purs + examples/failing/ExportConflictClass/A.purs + examples/failing/ExportConflictClass/B.purs + examples/failing/ExportConflictCtor.purs + examples/failing/ExportConflictCtor/A.purs + examples/failing/ExportConflictCtor/B.purs + examples/failing/ExportConflictType.purs + examples/failing/ExportConflictType/A.purs + examples/failing/ExportConflictType/B.purs + examples/failing/ExportConflictTypeOp.purs + examples/failing/ExportConflictTypeOp/A.purs + examples/failing/ExportConflictTypeOp/B.purs + examples/failing/ExportConflictValue.purs + examples/failing/ExportConflictValue/A.purs + examples/failing/ExportConflictValue/B.purs + examples/failing/ExportConflictValueOp.purs + examples/failing/ExportConflictValueOp/A.purs + examples/failing/ExportConflictValueOp/B.purs + examples/failing/ExportExplicit.purs + examples/failing/ExportExplicit1.purs + examples/failing/ExportExplicit1/M1.purs + examples/failing/ExportExplicit2.purs + examples/failing/ExportExplicit3.purs + examples/failing/ExportExplicit3/M1.purs + examples/failing/ExtraRecordField.purs + examples/failing/Foldable.purs + examples/failing/Generalization1.purs + examples/failing/Generalization2.purs + examples/failing/ImportExplicit.purs + examples/failing/ImportExplicit/M1.purs + examples/failing/ImportExplicit2.purs + examples/failing/ImportExplicit2/M1.purs + examples/failing/ImportHidingModule.purs + examples/failing/ImportHidingModule/A.purs + examples/failing/ImportHidingModule/B.purs + examples/failing/ImportModule.purs + examples/failing/ImportModule/M2.purs + examples/failing/InfiniteKind.purs + examples/failing/InfiniteType.purs + examples/failing/InstanceExport.purs + examples/failing/InstanceExport/InstanceExport.purs + examples/failing/IntOutOfRange.purs + examples/failing/InvalidDerivedInstance.purs + examples/failing/InvalidDerivedInstance2.purs + examples/failing/InvalidOperatorInBinder.purs + examples/failing/KindError.purs + examples/failing/KindStar.purs + examples/failing/LeadingZeros1.purs + examples/failing/LeadingZeros2.purs + examples/failing/Let.purs + examples/failing/LetPatterns1.purs + examples/failing/LetPatterns2.purs + examples/failing/LetPatterns3.purs + examples/failing/LetPatterns4.purs + examples/failing/MissingClassExport.purs + examples/failing/MissingClassMemberExport.purs + examples/failing/MissingRecordField.purs + examples/failing/MPTCs.purs + examples/failing/MultipleErrors.purs + examples/failing/MultipleErrors2.purs + examples/failing/MultipleTypeOpFixities.purs + examples/failing/MultipleValueOpFixities.purs + examples/failing/MutRec.purs + examples/failing/MutRec2.purs + examples/failing/NewtypeInstance.purs + examples/failing/NewtypeInstance2.purs + examples/failing/NewtypeInstance3.purs + examples/failing/NewtypeInstance4.purs + examples/failing/NewtypeInstance5.purs + examples/failing/NewtypeInstance6.purs + examples/failing/NewtypeMultiArgs.purs + examples/failing/NewtypeMultiCtor.purs + examples/failing/NonExhaustivePatGuard.purs + examples/failing/NonWildcardNewtypeInstance.purs + examples/failing/NullaryAbs.purs + examples/failing/Object.purs + examples/failing/OperatorAliasNoExport.purs + examples/failing/OperatorSections.purs + examples/failing/OrphanInstance.purs + examples/failing/OrphanInstance/Class.purs + examples/failing/OrphanInstanceFunDepCycle.purs + examples/failing/OrphanInstanceFunDepCycle/Lib.purs + examples/failing/OrphanInstanceNullary.purs + examples/failing/OrphanInstanceNullary/Lib.purs + examples/failing/OrphanInstanceWithDetermined.purs + examples/failing/OrphanInstanceWithDetermined/Lib.purs + examples/failing/OrphanTypeDecl.purs + examples/failing/OverlappingArguments.purs + examples/failing/OverlappingBinders.purs + examples/failing/OverlappingVars.purs + examples/failing/ProgrammableTypeErrors.purs + examples/failing/ProgrammableTypeErrorsTypeString.purs + examples/failing/Rank2Types.purs + examples/failing/RequiredHiddenType.purs + examples/failing/Reserved.purs + examples/failing/RowConstructors1.purs + examples/failing/RowConstructors2.purs + examples/failing/RowConstructors3.purs + examples/failing/RowInInstanceNotDetermined0.purs + examples/failing/RowInInstanceNotDetermined1.purs + examples/failing/RowInInstanceNotDetermined2.purs + examples/failing/SkolemEscape.purs + examples/failing/SkolemEscape2.purs + examples/failing/SuggestComposition.purs + examples/failing/Superclasses1.purs + examples/failing/Superclasses2.purs + examples/failing/Superclasses3.purs + examples/failing/Superclasses5.purs + examples/failing/TooFewClassInstanceArgs.purs + examples/failing/TopLevelCaseNoArgs.purs + examples/failing/TransitiveDctorExport.purs + examples/failing/TransitiveSynonymExport.purs + examples/failing/TypeClasses2.purs + examples/failing/TypeClassInstances.purs + examples/failing/TypedBinders.purs + examples/failing/TypedBinders2.purs + examples/failing/TypedBinders3.purs + examples/failing/TypedHole.purs + examples/failing/TypeError.purs + examples/failing/TypeOperatorAliasNoExport.purs + examples/failing/TypeSynonyms.purs + examples/failing/TypeSynonyms2.purs + examples/failing/TypeSynonyms3.purs + examples/failing/TypeSynonyms4.purs + examples/failing/TypeSynonyms5.purs + examples/failing/TypeWildcards1.purs + examples/failing/TypeWildcards2.purs + examples/failing/TypeWildcards3.purs + examples/failing/UnderscoreModuleName.purs + examples/failing/UnknownType.purs + examples/failing/UnusableTypeClassMethod.purs + examples/failing/UnusableTypeClassMethodConflictingIdent.purs + examples/failing/UnusableTypeClassMethodSynonym.purs + examples/passing/1110.purs + examples/passing/1185.purs + examples/passing/1335.purs + examples/passing/1570.purs + examples/passing/1664.purs + examples/passing/1697.purs + examples/passing/1807.purs + examples/passing/1881.purs + examples/passing/1991.purs + examples/passing/2018.purs + examples/passing/2018/A.purs + examples/passing/2018/B.purs + examples/passing/2049.purs + examples/passing/2136.purs + examples/passing/2138.purs + examples/passing/2138/Lib.purs + examples/passing/2172.js + examples/passing/2172.purs + examples/passing/2252.purs + examples/passing/2288.purs + examples/passing/2378.purs + examples/passing/2438.purs + examples/passing/2609.purs + examples/passing/2609/Eg.purs + examples/passing/2616.purs + examples/passing/2626.purs + examples/passing/2663.purs + examples/passing/2689.purs + examples/passing/2695.purs + examples/passing/2756.purs + examples/passing/2787.purs + examples/passing/652.purs + examples/passing/810.purs + examples/passing/862.purs + examples/passing/922.purs + examples/passing/Applicative.purs + examples/passing/ArrayType.purs + examples/passing/Auto.purs + examples/passing/AutoPrelude.purs + examples/passing/AutoPrelude2.purs + examples/passing/BindersInFunctions.purs + examples/passing/BindingGroups.purs + examples/passing/BlockString.purs + examples/passing/CaseInDo.purs + examples/passing/CaseInputWildcard.purs + examples/passing/CaseMultipleExpressions.purs + examples/passing/CaseStatement.purs + examples/passing/CheckFunction.purs + examples/passing/CheckSynonymBug.purs + examples/passing/CheckTypeClass.purs + examples/passing/Church.purs + examples/passing/ClassRefSyntax.purs + examples/passing/ClassRefSyntax/Lib.purs + examples/passing/Collatz.purs + examples/passing/Comparisons.purs + examples/passing/Conditional.purs + examples/passing/Console.purs + examples/passing/ConstraintInference.purs + examples/passing/ConstraintParens.purs + examples/passing/ConstraintParsingIssue.purs + examples/passing/ContextSimplification.purs + examples/passing/DataAndType.purs + examples/passing/DctorName.purs + examples/passing/DctorOperatorAlias.purs + examples/passing/DctorOperatorAlias/List.purs + examples/passing/DeepArrayBinder.purs + examples/passing/DeepCase.purs + examples/passing/DeriveNewtype.purs + examples/passing/DeriveWithNestedSynonyms.purs + examples/passing/Deriving.purs + examples/passing/DerivingFunctor.purs + examples/passing/Do.purs + examples/passing/Dollar.purs + examples/passing/DuplicateProperties.purs + examples/passing/Eff.purs + examples/passing/EmptyDataDecls.purs + examples/passing/EmptyRow.purs + examples/passing/EmptyTypeClass.purs + examples/passing/EntailsKindedType.purs + examples/passing/EqOrd.purs + examples/passing/ExplicitImportReExport.purs + examples/passing/ExplicitImportReExport/Bar.purs + examples/passing/ExplicitImportReExport/Foo.purs + examples/passing/ExplicitOperatorSections.purs + examples/passing/ExportedInstanceDeclarations.purs + examples/passing/ExportExplicit.purs + examples/passing/ExportExplicit/M1.purs + examples/passing/ExportExplicit2.purs + examples/passing/ExportExplicit2/M1.purs + examples/passing/ExtendedInfixOperators.purs + examples/passing/Fib.purs + examples/passing/FieldConsPuns.purs + examples/passing/FieldPuns.purs + examples/passing/FinalTagless.purs + examples/passing/ForeignKind.purs + examples/passing/ForeignKind/Lib.purs + examples/passing/FunctionalDependencies.purs + examples/passing/Functions.purs + examples/passing/Functions2.purs + examples/passing/FunctionScope.purs + examples/passing/FunWithFunDeps.js + examples/passing/FunWithFunDeps.purs + examples/passing/Generalization1.purs + examples/passing/GenericsRep.purs + examples/passing/Guards.purs + examples/passing/HasOwnProperty.purs + examples/passing/HoistError.purs + examples/passing/IfThenElseMaybe.purs + examples/passing/IfWildcard.purs + examples/passing/ImplicitEmptyImport.purs + examples/passing/Import.purs + examples/passing/Import/M1.purs + examples/passing/Import/M2.purs + examples/passing/ImportExplicit.purs + examples/passing/ImportExplicit/M1.purs + examples/passing/ImportHiding.purs + examples/passing/ImportQualified.purs + examples/passing/ImportQualified/M1.purs + examples/passing/InferRecFunWithConstrainedArgument.purs + examples/passing/InstanceBeforeClass.purs + examples/passing/IntAndChar.purs + examples/passing/iota.purs + examples/passing/JSReserved.purs + examples/passing/KindedType.purs + examples/passing/LargeSumType.purs + examples/passing/Let.purs + examples/passing/Let2.purs + examples/passing/LetInInstance.purs + examples/passing/LetPattern.purs + examples/passing/LiberalTypeSynonyms.purs + examples/passing/Match.purs + examples/passing/Module.purs + examples/passing/Module/M1.purs + examples/passing/Module/M2.purs + examples/passing/ModuleDeps.purs + examples/passing/ModuleDeps/M1.purs + examples/passing/ModuleDeps/M2.purs + examples/passing/ModuleDeps/M3.purs + examples/passing/ModuleExport.purs + examples/passing/ModuleExport/A.purs + examples/passing/ModuleExportDupes.purs + examples/passing/ModuleExportDupes/A.purs + examples/passing/ModuleExportDupes/B.purs + examples/passing/ModuleExportDupes/C.purs + examples/passing/ModuleExportExcluded.purs + examples/passing/ModuleExportExcluded/A.purs + examples/passing/ModuleExportQualified.purs + examples/passing/ModuleExportQualified/A.purs + examples/passing/ModuleExportSelf.purs + examples/passing/ModuleExportSelf/A.purs + examples/passing/Monad.purs + examples/passing/MonadState.purs + examples/passing/MPTCs.purs + examples/passing/MultiArgFunctions.purs + examples/passing/MutRec.purs + examples/passing/MutRec2.purs + examples/passing/MutRec3.purs + examples/passing/NakedConstraint.purs + examples/passing/NamedPatterns.purs + examples/passing/NegativeBinder.purs + examples/passing/NegativeIntInRange.purs + examples/passing/Nested.purs + examples/passing/NestedRecordUpdate.purs + examples/passing/NestedRecordUpdateWildcards.purs + examples/passing/NestedTypeSynonyms.purs + examples/passing/NestedWhere.purs + examples/passing/Newtype.purs + examples/passing/NewtypeClass.purs + examples/passing/NewtypeEff.purs + examples/passing/NewtypeInstance.purs + examples/passing/NewtypeWithRecordUpdate.purs + examples/passing/NonConflictingExports.purs + examples/passing/NonConflictingExports/A.purs + examples/passing/NonOrphanInstanceFunDepExtra.purs + examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs + examples/passing/NonOrphanInstanceMulti.purs + examples/passing/NonOrphanInstanceMulti/Lib.purs + examples/passing/NumberLiterals.purs + examples/passing/ObjectGetter.purs + examples/passing/Objects.purs + examples/passing/ObjectSynonym.purs + examples/passing/ObjectUpdate.purs + examples/passing/ObjectUpdate2.purs + examples/passing/ObjectUpdater.purs + examples/passing/ObjectWildcards.purs + examples/passing/OneConstructor.purs + examples/passing/OperatorAlias.purs + examples/passing/OperatorAliasElsewhere.purs + examples/passing/OperatorAliasElsewhere/Def.purs + examples/passing/OperatorAssociativity.purs + examples/passing/OperatorInlining.purs + examples/passing/Operators.purs + examples/passing/Operators/Other.purs + examples/passing/OperatorSections.purs + examples/passing/OptimizerBug.purs + examples/passing/OptionalQualified.purs + examples/passing/OverlappingInstances.purs + examples/passing/OverlappingInstances2.purs + examples/passing/OverlappingInstances3.purs + examples/passing/ParensInTypedBinder.purs + examples/passing/PartialFunction.purs + examples/passing/Patterns.purs + examples/passing/PendingConflictingImports.purs + examples/passing/PendingConflictingImports/A.purs + examples/passing/PendingConflictingImports/B.purs + examples/passing/PendingConflictingImports2.purs + examples/passing/PendingConflictingImports2/A.purs + examples/passing/Person.purs + examples/passing/PolyLabels.js + examples/passing/PolyLabels.purs + examples/passing/PrimedTypeName.purs + examples/passing/QualifiedNames.purs + examples/passing/QualifiedNames/Either.purs + examples/passing/QualifiedQualifiedImports.purs + examples/passing/Rank2Data.purs + examples/passing/Rank2Object.purs + examples/passing/Rank2Types.purs + examples/passing/Rank2TypeSynonym.purs + examples/passing/RebindableSyntax.purs + examples/passing/Recursion.purs + examples/passing/RedefinedFixity.purs + examples/passing/RedefinedFixity/M1.purs + examples/passing/RedefinedFixity/M2.purs + examples/passing/RedefinedFixity/M3.purs + examples/passing/ReExportQualified.purs + examples/passing/ReExportQualified/A.purs + examples/passing/ReExportQualified/B.purs + examples/passing/ReExportQualified/C.purs + examples/passing/ReservedWords.purs + examples/passing/ResolvableScopeConflict.purs + examples/passing/ResolvableScopeConflict/A.purs + examples/passing/ResolvableScopeConflict/B.purs + examples/passing/ResolvableScopeConflict2.purs + examples/passing/ResolvableScopeConflict2/A.purs + examples/passing/ResolvableScopeConflict3.purs + examples/passing/ResolvableScopeConflict3/A.purs + examples/passing/RowConstructors.purs + examples/passing/RowInInstanceHeadDetermined.purs + examples/passing/RowPolyInstanceContext.purs + examples/passing/RowsInInstanceContext.purs + examples/passing/RowUnion.js + examples/passing/RowUnion.purs + examples/passing/RuntimeScopeIssue.purs + examples/passing/s.purs + examples/passing/ScopedTypeVariables.purs + examples/passing/Sequence.purs + examples/passing/SequenceDesugared.purs + examples/passing/ShadowedModuleName.purs + examples/passing/ShadowedModuleName/Test.purs + examples/passing/ShadowedName.purs + examples/passing/ShadowedRename.purs + examples/passing/ShadowedTCO.purs + examples/passing/ShadowedTCOLet.purs + examples/passing/SignedNumericLiterals.purs + examples/passing/SolvingAppendSymbol.purs + examples/passing/SolvingCompareSymbol.purs + examples/passing/SolvingIsSymbol.purs + examples/passing/SolvingIsSymbol/Lib.purs + examples/passing/Stream.purs + examples/passing/StringEdgeCases.purs + examples/passing/StringEdgeCases/Records.purs + examples/passing/StringEdgeCases/Symbols.purs + examples/passing/StringEscapes.purs + examples/passing/Superclasses1.purs + examples/passing/Superclasses3.purs + examples/passing/TailCall.purs + examples/passing/TCO.purs + examples/passing/TCOCase.purs + examples/passing/Tick.purs + examples/passing/TopLevelCase.purs + examples/passing/TransitiveImport.purs + examples/passing/TransitiveImport/Middle.purs + examples/passing/TransitiveImport/Test.purs + examples/passing/TypeClasses.purs + examples/passing/TypeClassesInOrder.purs + examples/passing/TypeClassesWithOverlappingTypeVariables.purs + examples/passing/TypeClassMemberOrderChange.purs + examples/passing/TypedBinders.purs + examples/passing/TypeDecl.purs + examples/passing/TypedWhere.purs + examples/passing/TypeOperators.purs + examples/passing/TypeOperators/A.purs + examples/passing/TypeSynonymInData.purs + examples/passing/TypeSynonyms.purs + examples/passing/TypeWildcards.purs + examples/passing/TypeWildcardsRecordExtension.purs + examples/passing/TypeWithoutParens.purs + examples/passing/TypeWithoutParens/Lib.purs + examples/passing/UnderscoreIdent.purs + examples/passing/UnicodeIdentifier.purs + examples/passing/UnicodeOperators.purs + examples/passing/UnicodeType.purs + examples/passing/UnifyInTypeInstanceLookup.purs + examples/passing/Unit.purs + examples/passing/UnknownInTypeClassLookup.purs + examples/passing/UntupledConstraints.purs + examples/passing/UsableTypeClassMethods.purs + examples/passing/UTF8Sourcefile.purs + examples/passing/Where.purs + examples/passing/WildcardInInstance.purs + examples/passing/WildcardType.purs + examples/psci/BasicEval.purs + examples/psci/Multiline.purs + examples/warning/2140.purs + examples/warning/2383.purs + examples/warning/2411.purs + examples/warning/2542.purs + examples/warning/CustomWarning.purs + examples/warning/DuplicateExportRef.purs + examples/warning/DuplicateImport.purs + examples/warning/DuplicateImportRef.purs + examples/warning/DuplicateSelectiveImport.purs + examples/warning/HidingImport.purs + examples/warning/ImplicitImport.purs + examples/warning/ImplicitQualifiedImport.purs + examples/warning/MissingTypeDeclaration.purs + examples/warning/OverlappingInstances.purs + examples/warning/OverlappingPattern.purs + examples/warning/ScopeShadowing.purs + examples/warning/ShadowedBinderPatternGuard.purs + examples/warning/ShadowedNameParens.purs + examples/warning/ShadowedTypeVar.purs + examples/warning/UnnecessaryFFIModule.js + examples/warning/UnnecessaryFFIModule.purs + examples/warning/UnusedDctorExplicitImport.purs + examples/warning/UnusedDctorImportAll.purs + examples/warning/UnusedDctorImportExplicit.purs + examples/warning/UnusedExplicitImport.purs + examples/warning/UnusedExplicitImportTypeOp.purs + examples/warning/UnusedExplicitImportTypeOp/Lib.purs + examples/warning/UnusedExplicitImportValOp.purs + examples/warning/UnusedFFIImplementations.js + examples/warning/UnusedFFIImplementations.purs + examples/warning/UnusedImport.purs + examples/warning/UnusedTypeVar.purs + examples/warning/WildcardInferredType.purs + INSTALL.md + README.md + stack.yaml + tests/support/bower.json + tests/support/package.json + tests/support/prelude-resolutions.json + tests/support/psci/Sample.purs + tests/support/pscide/src/ImportsSpec.purs + tests/support/pscide/src/ImportsSpec1.purs + tests/support/pscide/src/MatcherSpec.purs + tests/support/pscide/src/RebuildSpecDep.purs + tests/support/pscide/src/RebuildSpecSingleModule.fail + tests/support/pscide/src/RebuildSpecSingleModule.purs + tests/support/pscide/src/RebuildSpecWithDeps.purs + tests/support/pscide/src/RebuildSpecWithForeign.js + tests/support/pscide/src/RebuildSpecWithForeign.purs + tests/support/pscide/src/RebuildSpecWithHiddenIdent.purs + tests/support/pscide/src/RebuildSpecWithMissingForeign.fail + tests/support/setup-win.cmd source-repository head type: git location: https://github.com/purescript/purescript.git flag release - description: Mark this build as a release build: prevents inclusion of extra - info e.g. commit SHA in --version output) - default: False - -library - build-depends: base >=4.8 && <5, - aeson >= 0.8 && < 1.1, - aeson-better-errors >= 0.8, - ansi-terminal >= 0.6.2 && < 0.7, - base-compat >=0.6.0, - blaze-html >= 0.8.1 && < 0.9, - bower-json >= 1.0.0.1 && < 1.1, - boxes >= 0.1.4 && < 0.2.0, - bytestring -any, - cheapskate >= 0.1 && < 0.2, - containers -any, - clock -any, - data-ordlist >= 0.4.7.0, - deepseq -any, - directory >= 1.2, - dlist -any, - edit-distance -any, - filepath -any, - fsnotify >= 0.2.1, - Glob >= 0.7 && < 0.8, - haskeline >= 0.7.0.0, - http-client >= 0.4.30 && < 0.6.0, - http-types -any, - language-javascript >= 0.6.0.9 && < 0.7, - lens == 4.*, - lifted-base >= 0.2.3 && < 0.2.4, - monad-control >= 1.0.0.0 && < 1.1, - monad-logger >= 0.3 && < 0.4, - mtl >= 2.1.0 && < 2.3.0, - parallel >= 3.2 && < 3.3, - parsec >=3.1.10, - pattern-arrows >= 0.0.2 && < 0.1, - pipes >= 4.0.0 && < 4.4.0, - pipes-http -any, - process >= 1.2.0 && < 1.5, - protolude >= 0.1.6, - regex-tdfa -any, - safe >= 0.3.9 && < 0.4, - scientific >= 0.3.4.9 && < 0.4, - semigroups >= 0.16.2 && < 0.19, - sourcemap >= 0.1.6, - spdx == 0.2.*, - split -any, - stm >= 0.2.4.0, - syb -any, - text -any, - time -any, - transformers >= 0.3.0 && < 0.6, - transformers-base >= 0.4.0 && < 0.5, - transformers-compat >= 0.3.0, - unordered-containers -any, - utf8-string >= 1 && < 2, - vector -any - - exposed-modules: Language.PureScript - Language.PureScript.AST - Language.PureScript.AST.Binders - Language.PureScript.AST.Declarations - Language.PureScript.AST.Operators - Language.PureScript.AST.Literals - Language.PureScript.AST.SourcePos - Language.PureScript.AST.Traversals - Language.PureScript.AST.Exported - Language.PureScript.Bundle - Language.PureScript.Crash - Language.PureScript.Externs - Language.PureScript.CodeGen - Language.PureScript.CodeGen.JS - Language.PureScript.CodeGen.JS.Common - Language.PureScript.CodeGen.JS.Printer - Language.PureScript.Constants - Language.PureScript.CoreFn - Language.PureScript.CoreFn.Ann - Language.PureScript.CoreFn.Binders - Language.PureScript.CoreFn.Desugar - Language.PureScript.CoreFn.Expr - Language.PureScript.CoreFn.Meta - Language.PureScript.CoreFn.Module - Language.PureScript.CoreFn.Traversals - Language.PureScript.CoreFn.ToJSON - Language.PureScript.CoreImp - Language.PureScript.CoreImp.AST - Language.PureScript.CoreImp.Optimizer - Language.PureScript.CoreImp.Optimizer.Blocks - Language.PureScript.CoreImp.Optimizer.Common - Language.PureScript.CoreImp.Optimizer.Inliner - Language.PureScript.CoreImp.Optimizer.MagicDo - Language.PureScript.CoreImp.Optimizer.TCO - Language.PureScript.CoreImp.Optimizer.Unused - Language.PureScript.Comments - Language.PureScript.Environment - Language.PureScript.Errors - Language.PureScript.Errors.JSON - Language.PureScript.Kinds - Language.PureScript.Label - Language.PureScript.Linter - Language.PureScript.Linter.Exhaustive - Language.PureScript.Linter.Imports - Language.PureScript.Make - Language.PureScript.ModuleDependencies - Language.PureScript.Names - Language.PureScript.Options - Language.PureScript.Parser - Language.PureScript.Parser.Lexer - Language.PureScript.Parser.Common - Language.PureScript.Parser.Declarations - Language.PureScript.Parser.Kinds - Language.PureScript.Parser.State - Language.PureScript.Parser.Types - Language.PureScript.Pretty - Language.PureScript.Pretty.Common - Language.PureScript.Pretty.Kinds - Language.PureScript.Pretty.Types - Language.PureScript.Pretty.Values - Language.PureScript.PSString - Language.PureScript.Renamer - Language.PureScript.Sugar - Language.PureScript.Sugar.BindingGroups - Language.PureScript.Sugar.CaseDeclarations - Language.PureScript.Sugar.DoNotation - Language.PureScript.Sugar.LetPattern - Language.PureScript.Sugar.Names - Language.PureScript.Sugar.Names.Common - Language.PureScript.Sugar.Names.Env - Language.PureScript.Sugar.Names.Exports - Language.PureScript.Sugar.Names.Imports - Language.PureScript.Sugar.ObjectWildcards - Language.PureScript.Sugar.Operators - Language.PureScript.Sugar.Operators.Common - Language.PureScript.Sugar.Operators.Expr - Language.PureScript.Sugar.Operators.Binders - Language.PureScript.Sugar.Operators.Types - Language.PureScript.Sugar.TypeClasses - Language.PureScript.Sugar.TypeClasses.Deriving - Language.PureScript.Sugar.TypeDeclarations - Language.PureScript.Traversals - Language.PureScript.TypeChecker - Language.PureScript.TypeChecker.Entailment - Language.PureScript.TypeChecker.Kinds - Language.PureScript.TypeChecker.Monad - Language.PureScript.TypeChecker.Skolems - Language.PureScript.TypeChecker.Subsumption - Language.PureScript.TypeChecker.Synonyms - Language.PureScript.TypeChecker.Types - Language.PureScript.TypeChecker.TypeSearch - Language.PureScript.TypeChecker.Unify - Language.PureScript.TypeClassDictionaries - Language.PureScript.Types - - Language.PureScript.Docs - Language.PureScript.Docs.Convert - Language.PureScript.Docs.Convert.Single - Language.PureScript.Docs.Convert.ReExports - Language.PureScript.Docs.Prim - Language.PureScript.Docs.Render - Language.PureScript.Docs.Types - Language.PureScript.Docs.RenderedCode - Language.PureScript.Docs.RenderedCode.Types - Language.PureScript.Docs.RenderedCode.RenderType - Language.PureScript.Docs.RenderedCode.RenderKind - Language.PureScript.Docs.AsMarkdown - Language.PureScript.Docs.AsHtml - Language.PureScript.Docs.ParseInPackage - Language.PureScript.Docs.Utils.MonoidExtras - - Language.PureScript.Publish - Language.PureScript.Publish.Utils - Language.PureScript.Publish.ErrorsWarnings - Language.PureScript.Publish.BoxesHelpers - - Language.PureScript.Ide - Language.PureScript.Ide.CaseSplit - Language.PureScript.Ide.Command - Language.PureScript.Ide.Completion - Language.PureScript.Ide.Externs - Language.PureScript.Ide.Error - Language.PureScript.Ide.Filter - Language.PureScript.Ide.Imports - Language.PureScript.Ide.Logging - Language.PureScript.Ide.Matcher - Language.PureScript.Ide.Pursuit - Language.PureScript.Ide.Rebuild - Language.PureScript.Ide.Reexports - Language.PureScript.Ide.SourceFile - Language.PureScript.Ide.State - Language.PureScript.Ide.Types - Language.PureScript.Ide.Util - Language.PureScript.Ide.Watcher + description: Mark this build as a release build: prevents inclusion of extra info e.g. commit SHA in --version output) - Language.PureScript.Interactive - Language.PureScript.Interactive.Types - Language.PureScript.Interactive.Parser - Language.PureScript.Interactive.Directive - Language.PureScript.Interactive.Completion - Language.PureScript.Interactive.IO - Language.PureScript.Interactive.Message - Language.PureScript.Interactive.Module - Language.PureScript.Interactive.Printer + manual: False + default: False - Control.Monad.Logger - Control.Monad.Supply - Control.Monad.Supply.Class - - System.IO.UTF8 - - extensions: ConstraintKinds - DataKinds - DeriveFunctor - EmptyDataDecls - FlexibleContexts - KindSignatures - LambdaCase - MultiParamTypeClasses - NoImplicitPrelude - PatternGuards - PatternSynonyms - RankNTypes - RecordWildCards - OverloadedStrings - ScopedTypeVariables - TupleSections - ViewPatterns - exposed: True - buildable: True - hs-source-dirs: src - other-modules: Paths_purescript +library + build-depends: + aeson >=0.8 && <1.1 + , aeson-better-errors >=0.8 + , ansi-terminal >=0.6.2 && <0.7 + , base >=4.8 && <5 + , base-compat >=0.6.0 + , blaze-html >=0.8.1 && <0.9 + , bower-json >=1.0.0.1 && <1.1 + , boxes >=0.1.4 && <0.2.0 + , bytestring + , cheapskate >=0.1 && <0.2 + , clock + , containers + , data-ordlist >=0.4.7.0 + , deepseq + , directory >=1.2 + , dlist + , edit-distance + , filepath + , fsnotify >=0.2.1 + , Glob >=0.7 && <0.8 + , haskeline >=0.7.0.0 + , http-client >=0.4.30 && <0.6.0 + , http-types + , language-javascript >=0.6.0.9 && <0.7 + , lens ==4.* + , lifted-base >=0.2.3 && <0.2.4 + , monad-control >=1.0.0.0 && <1.1 + , monad-logger >=0.3 && <0.4 + , mtl >=2.1.0 && <2.3.0 + , parallel >=3.2 && <3.3 + , parsec >=3.1.10 + , pattern-arrows >=0.0.2 && <0.1 + , pipes >=4.0.0 && <4.4.0 + , pipes-http + , process >=1.2.0 && <1.5 + , protolude >=0.1.6 + , regex-tdfa + , safe >=0.3.9 && <0.4 + , scientific >=0.3.4.9 && <0.4 + , semigroups >=0.16.2 && <0.19 + , sourcemap >=0.1.6 + , spdx ==0.2.* + , split + , stm >=0.2.4.0 + , syb + , text + , time + , transformers >=0.3.0 && <0.6 + , transformers-base >=0.4.0 && <0.5 + , transformers-compat >=0.3.0 + , unordered-containers + , utf8-string >=1 && <2 + , vector + exposed-modules: + Control.Monad.Logger + Control.Monad.Supply + Control.Monad.Supply.Class + Language.PureScript + Language.PureScript.AST + Language.PureScript.AST.Binders + Language.PureScript.AST.Declarations + Language.PureScript.AST.Exported + Language.PureScript.AST.Literals + Language.PureScript.AST.Operators + Language.PureScript.AST.SourcePos + Language.PureScript.AST.Traversals + Language.PureScript.Bundle + Language.PureScript.CodeGen + Language.PureScript.CodeGen.JS + Language.PureScript.CodeGen.JS.Common + Language.PureScript.CodeGen.JS.Printer + Language.PureScript.Comments + Language.PureScript.Constants + Language.PureScript.CoreFn + Language.PureScript.CoreFn.Ann + Language.PureScript.CoreFn.Binders + Language.PureScript.CoreFn.Desugar + Language.PureScript.CoreFn.Expr + Language.PureScript.CoreFn.Meta + Language.PureScript.CoreFn.Module + Language.PureScript.CoreFn.ToJSON + Language.PureScript.CoreFn.Traversals + Language.PureScript.CoreImp + Language.PureScript.CoreImp.AST + Language.PureScript.CoreImp.Optimizer + Language.PureScript.CoreImp.Optimizer.Blocks + Language.PureScript.CoreImp.Optimizer.Common + Language.PureScript.CoreImp.Optimizer.Inliner + Language.PureScript.CoreImp.Optimizer.MagicDo + Language.PureScript.CoreImp.Optimizer.TCO + Language.PureScript.CoreImp.Optimizer.Unused + Language.PureScript.Crash + Language.PureScript.Docs + Language.PureScript.Docs.AsHtml + Language.PureScript.Docs.AsMarkdown + Language.PureScript.Docs.Convert + Language.PureScript.Docs.Convert.ReExports + Language.PureScript.Docs.Convert.Single + Language.PureScript.Docs.ParseInPackage + Language.PureScript.Docs.Prim + Language.PureScript.Docs.Render + Language.PureScript.Docs.RenderedCode + Language.PureScript.Docs.RenderedCode.RenderKind + Language.PureScript.Docs.RenderedCode.RenderType + Language.PureScript.Docs.RenderedCode.Types + Language.PureScript.Docs.Types + Language.PureScript.Docs.Utils.MonoidExtras + Language.PureScript.Environment + Language.PureScript.Errors + Language.PureScript.Errors.JSON + Language.PureScript.Externs + Language.PureScript.Ide + Language.PureScript.Ide.CaseSplit + Language.PureScript.Ide.Command + Language.PureScript.Ide.Completion + Language.PureScript.Ide.Error + Language.PureScript.Ide.Externs + Language.PureScript.Ide.Filter + Language.PureScript.Ide.Imports + Language.PureScript.Ide.Logging + Language.PureScript.Ide.Matcher + Language.PureScript.Ide.Pursuit + Language.PureScript.Ide.Rebuild + Language.PureScript.Ide.Reexports + Language.PureScript.Ide.SourceFile + Language.PureScript.Ide.State + Language.PureScript.Ide.Types + Language.PureScript.Ide.Util + Language.PureScript.Ide.Watcher + Language.PureScript.Interactive + Language.PureScript.Interactive.Completion + Language.PureScript.Interactive.Directive + Language.PureScript.Interactive.IO + Language.PureScript.Interactive.Message + Language.PureScript.Interactive.Module + Language.PureScript.Interactive.Parser + Language.PureScript.Interactive.Printer + Language.PureScript.Interactive.Types + Language.PureScript.Kinds + Language.PureScript.Label + Language.PureScript.Linter + Language.PureScript.Linter.Exhaustive + Language.PureScript.Linter.Imports + Language.PureScript.Make + Language.PureScript.ModuleDependencies + Language.PureScript.Names + Language.PureScript.Options + Language.PureScript.Parser + Language.PureScript.Parser.Common + Language.PureScript.Parser.Declarations + Language.PureScript.Parser.Kinds + Language.PureScript.Parser.Lexer + Language.PureScript.Parser.State + Language.PureScript.Parser.Types + Language.PureScript.Pretty + Language.PureScript.Pretty.Common + Language.PureScript.Pretty.Kinds + Language.PureScript.Pretty.Types + Language.PureScript.Pretty.Values + Language.PureScript.PSString + Language.PureScript.Publish + Language.PureScript.Publish.BoxesHelpers + Language.PureScript.Publish.ErrorsWarnings + Language.PureScript.Publish.Utils + Language.PureScript.Renamer + Language.PureScript.Sugar + Language.PureScript.Sugar.BindingGroups + Language.PureScript.Sugar.CaseDeclarations + Language.PureScript.Sugar.DoNotation + Language.PureScript.Sugar.LetPattern + Language.PureScript.Sugar.Names + Language.PureScript.Sugar.Names.Common + Language.PureScript.Sugar.Names.Env + Language.PureScript.Sugar.Names.Exports + Language.PureScript.Sugar.Names.Imports + Language.PureScript.Sugar.ObjectWildcards + Language.PureScript.Sugar.Operators + Language.PureScript.Sugar.Operators.Binders + Language.PureScript.Sugar.Operators.Common + Language.PureScript.Sugar.Operators.Expr + Language.PureScript.Sugar.Operators.Types + Language.PureScript.Sugar.TypeClasses + Language.PureScript.Sugar.TypeClasses.Deriving + Language.PureScript.Sugar.TypeDeclarations + Language.PureScript.Traversals + Language.PureScript.TypeChecker + Language.PureScript.TypeChecker.Entailment + Language.PureScript.TypeChecker.Kinds + Language.PureScript.TypeChecker.Monad + Language.PureScript.TypeChecker.Skolems + Language.PureScript.TypeChecker.Subsumption + Language.PureScript.TypeChecker.Synonyms + Language.PureScript.TypeChecker.Types + Language.PureScript.TypeChecker.TypeSearch + Language.PureScript.TypeChecker.Unify + Language.PureScript.TypeClassDictionaries + Language.PureScript.Types + System.IO.UTF8 + other-modules: + Paths_purescript + hs-source-dirs: + src + default-extensions: ConstraintKinds DataKinds DeriveFunctor EmptyDataDecls FlexibleContexts KindSignatures LambdaCase MultiParamTypeClasses NoImplicitPrelude PatternGuards PatternSynonyms RankNTypes RecordWildCards OverloadedStrings ScopedTypeVariables TupleSections ViewPatterns + default-language: Haskell2010 ghc-options: -Wall -O2 executable purs - build-depends: base >=4 && <5, - aeson >= 0.8 && < 1.1, - ansi-terminal >= 0.6.2 && < 0.7, - ansi-wl-pprint -any, - base-compat >=0.6.0, - blaze-html -any, - boxes >= 0.1.4 && < 0.2.0, - bytestring -any, - containers -any, - directory -any, - file-embed -any, - filepath -any, - Glob >= 0.7 && < 0.8, - haskeline >= 0.7.0.0, - http-types == 0.9.*, - monad-logger -any, - mtl -any, - network -any, - optparse-applicative >= 0.13.0, - parsec -any, - process -any, - protolude >= 0.1.6, - purescript -any, - sourcemap >= 0.1.6, - split -any, - stm >= 0.2.4.0, - text -any, - time -any, - transformers -any, - transformers-compat -any, - utf8-string >= 1 && < 2, - wai == 3.*, - wai-websockets == 3.*, - warp == 3.*, - websockets >= 0.9 && <0.11 - main-is: Main.hs - buildable: True - hs-source-dirs: app - other-modules: Paths_purescript - Command.Bundle - Command.Compile - Command.Docs - Command.Docs.Ctags - Command.Docs.Etags - Command.Docs.Tags - Command.Docs.Html - Command.Hierarchy - Command.Ide - Command.Publish - Command.REPL - Version - ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N" - + build-depends: + aeson >=0.8 && <1.1 + , aeson-better-errors >=0.8 + , ansi-terminal >=0.6.2 && <0.7 + , base >=4.8 && <5 + , base-compat >=0.6.0 + , blaze-html >=0.8.1 && <0.9 + , bower-json >=1.0.0.1 && <1.1 + , boxes >=0.1.4 && <0.2.0 + , bytestring + , cheapskate >=0.1 && <0.2 + , clock + , containers + , data-ordlist >=0.4.7.0 + , deepseq + , directory >=1.2 + , dlist + , edit-distance + , filepath + , fsnotify >=0.2.1 + , Glob >=0.7 && <0.8 + , haskeline >=0.7.0.0 + , http-client >=0.4.30 && <0.6.0 + , http-types + , language-javascript >=0.6.0.9 && <0.7 + , lens ==4.* + , lifted-base >=0.2.3 && <0.2.4 + , monad-control >=1.0.0.0 && <1.1 + , monad-logger >=0.3 && <0.4 + , mtl >=2.1.0 && <2.3.0 + , parallel >=3.2 && <3.3 + , parsec >=3.1.10 + , pattern-arrows >=0.0.2 && <0.1 + , pipes >=4.0.0 && <4.4.0 + , pipes-http + , process >=1.2.0 && <1.5 + , protolude >=0.1.6 + , regex-tdfa + , safe >=0.3.9 && <0.4 + , scientific >=0.3.4.9 && <0.4 + , semigroups >=0.16.2 && <0.19 + , sourcemap >=0.1.6 + , spdx ==0.2.* + , split + , stm >=0.2.4.0 + , syb + , text + , time + , transformers >=0.3.0 && <0.6 + , transformers-base >=0.4.0 && <0.5 + , transformers-compat >=0.3.0 + , unordered-containers + , utf8-string >=1 && <2 + , vector + , ansi-wl-pprint + , file-embed + , network + , optparse-applicative >=0.13.0 + , purescript + , wai ==3.* + , wai-websockets ==3.* + , warp ==3.* + , websockets >=0.9 && <0.11 if flag(release) - cpp-options: -DRELEASE + cpp-options: -DRELEASE else - build-depends: gitrev >= 1.2.0 && <1.3 + build-depends: + gitrev >=1.2.0 && <1.3 + main-is: Main.hs + hs-source-dirs: + app + other-modules: + Command.Bundle + Command.Compile + Command.Docs + Command.Docs.Ctags + Command.Docs.Etags + Command.Docs.Html + Command.Docs.Tags + Command.Hierarchy + Command.Ide + Command.Publish + Command.REPL + Version + default-language: Haskell2010 + ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N test-suite tests - build-depends: base >=4 && <5, - purescript -any, - aeson -any, - aeson-better-errors -any, - base-compat -any, - bower-json -any, - boxes -any, - bytestring -any, - containers -any, - directory -any, - filepath -any, - Glob -any, - haskeline >= 0.7.0.0, - hspec -any, - hspec-discover -any, - HUnit -any, - lens -any, - monad-logger -any, - mtl -any, - optparse-applicative -any, - parsec -any, - process -any, - protolude >= 0.1.6, - silently -any, - split -any, - stm -any, - text -any, - time -any, - transformers -any, - transformers-compat -any, - utf8-string -any, - vector -any + build-depends: + aeson >=0.8 && <1.1 + , aeson-better-errors >=0.8 + , ansi-terminal >=0.6.2 && <0.7 + , base >=4.8 && <5 + , base-compat >=0.6.0 + , blaze-html >=0.8.1 && <0.9 + , bower-json >=1.0.0.1 && <1.1 + , boxes >=0.1.4 && <0.2.0 + , bytestring + , cheapskate >=0.1 && <0.2 + , clock + , containers + , data-ordlist >=0.4.7.0 + , deepseq + , directory >=1.2 + , dlist + , edit-distance + , filepath + , fsnotify >=0.2.1 + , Glob >=0.7 && <0.8 + , haskeline >=0.7.0.0 + , http-client >=0.4.30 && <0.6.0 + , http-types + , language-javascript >=0.6.0.9 && <0.7 + , lens ==4.* + , lifted-base >=0.2.3 && <0.2.4 + , monad-control >=1.0.0.0 && <1.1 + , monad-logger >=0.3 && <0.4 + , mtl >=2.1.0 && <2.3.0 + , parallel >=3.2 && <3.3 + , parsec >=3.1.10 + , pattern-arrows >=0.0.2 && <0.1 + , pipes >=4.0.0 && <4.4.0 + , pipes-http + , process >=1.2.0 && <1.5 + , protolude >=0.1.6 + , regex-tdfa + , safe >=0.3.9 && <0.4 + , scientific >=0.3.4.9 && <0.4 + , semigroups >=0.16.2 && <0.19 + , sourcemap >=0.1.6 + , spdx ==0.2.* + , split + , stm >=0.2.4.0 + , syb + , text + , time + , transformers >=0.3.0 && <0.6 + , transformers-base >=0.4.0 && <0.5 + , transformers-compat >=0.3.0 + , unordered-containers + , utf8-string >=1 && <2 + , vector + , purescript + , hspec + , hspec-discover + , HUnit + , silently ghc-options: -Wall type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: TestUtils - TestCompiler - TestDocs - TestPrimDocs - TestPscPublish - TestPsci - TestPsci.CommandTest - TestPsci.CompletionTest - TestPsci.EvalTest - TestPsci.TestEnv - TestPscIde - PscIdeSpec - Language.PureScript.Ide.Test - Language.PureScript.Ide.FilterSpec - Language.PureScript.Ide.ImportsSpec - Language.PureScript.Ide.MatcherSpec - Language.PureScript.Ide.RebuildSpec - Language.PureScript.Ide.ReexportsSpec - Language.PureScript.Ide.SourceFileSpec - Language.PureScript.Ide.StateSpec - buildable: True - hs-source-dirs: tests + other-modules: + Language.PureScript.Ide.FilterSpec + Language.PureScript.Ide.ImportsSpec + Language.PureScript.Ide.MatcherSpec + Language.PureScript.Ide.RebuildSpec + Language.PureScript.Ide.ReexportsSpec + Language.PureScript.Ide.SourceFileSpec + Language.PureScript.Ide.StateSpec + Language.PureScript.Ide.Test + PscIdeSpec + TestCompiler + TestDocs + TestPrimDocs + TestPsci + TestPsci.CommandTest + TestPsci.CompletionTest + TestPsci.EvalTest + TestPsci.TestEnv + TestPscIde + TestPscPublish + TestUtils + default-language: Haskell2010 + hs-source-dirs: + tests From 485e7894bb88660317155edd1a2259d79783346c Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Sun, 2 Apr 2017 18:51:52 +0200 Subject: [PATCH 0747/1580] Desugar pattern guards *after* type checking (#2801) * Desugar pattern guards *after* type checking * Add test --- examples/passing/2795.purs | 14 ++++++ src/Language/PureScript/Make.hs | 11 ++++- src/Language/PureScript/Pretty/Values.hs | 34 ++++++++++---- .../PureScript/Sugar/CaseDeclarations.hs | 47 +++++++++++++------ src/Language/PureScript/TypeChecker/Types.hs | 23 ++++----- 5 files changed, 93 insertions(+), 36 deletions(-) create mode 100644 examples/passing/2795.purs diff --git a/examples/passing/2795.purs b/examples/passing/2795.purs new file mode 100644 index 0000000000..a291a7d343 --- /dev/null +++ b/examples/passing/2795.purs @@ -0,0 +1,14 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +data X = X Int | Y + +x :: X -> Int +x = case _ of + Y -> 0 + X n | 1 <- n -> 1 + | otherwise -> 2 + +main = log "Done" diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index b385f7a002..18a7b4fa88 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -144,12 +144,19 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do [desugared] <- desugar externs [withPrim] runCheck' (emptyCheckState env) $ typeCheckModule desugared - regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated + + -- desugar case declarations *after* type- and exhaustiveness checking + -- since pattern guards introduces cases which the exhaustiveness checker + -- reports as not-exhaustive. + (deguarded, nextVar') <- runSupplyT nextVar $ do + desugarCaseGuards elaborated + + regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded let mod' = Module ss coms moduleName regrouped exps corefn = CF.moduleToCoreFn env' mod' [renamed] = renameInModules [corefn] exts = moduleToExternsFile mod' env' - evalSupplyT nextVar . codegen renamed env' . encode $ exts + evalSupplyT nextVar' . codegen renamed env' . encode $ exts return exts -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.json@ file. diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index f48a83fadc..4182f42606 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -141,16 +141,34 @@ prettyPrintCaseAlternative d (CaseAlternative binders result) = prettyPrintResult :: [GuardedExpr] -> Box prettyPrintResult [GuardedExpr [] v] = text " -> " <> prettyPrintValue (d - 1) v prettyPrintResult gs = - vcat left (map prettyPrintGuardedValue gs) - - prettyPrintGuardedValue :: GuardedExpr -> Box - prettyPrintGuardedValue (GuardedExpr [ConditionGuard grd] val) = foldl1 before - [ text " | " - , prettyPrintValue (d - 1) grd - , text " -> " + vcat left (map (prettyPrintGuardedValueSep (text " | ")) gs) + + prettyPrintGuardedValueSep :: Box -> GuardedExpr -> Box + prettyPrintGuardedValueSep _ (GuardedExpr [] val) = + text " -> " <> prettyPrintValue (d - 1) val + + prettyPrintGuardedValueSep sep (GuardedExpr [guard] val) = + foldl1 before [ sep + , prettyPrintGuard guard + , prettyPrintGuardedValueSep sep (GuardedExpr [] val) + ] + + prettyPrintGuardedValueSep sep (GuardedExpr (guard : guards) val) = + vcat left [ foldl1 before + [ sep + , prettyPrintGuard guard + ] + , prettyPrintGuardedValueSep (text " , ") (GuardedExpr guards val) + ] + + prettyPrintGuard (ConditionGuard cond) = + prettyPrintValue (d - 1) cond + prettyPrintGuard (PatternGuard binder val) = + foldl1 before + [ text (T.unpack (prettyPrintBinder binder)) + , text " <- " , prettyPrintValue (d - 1) val ] - prettyPrintGuardedValue _ = internalError "There should only be ConditionGuards after desugaring cases" prettyPrintDoNotationElement :: Int -> DoNotationElement -> Box prettyPrintDoNotationElement d _ | d < 0 = ellipsis diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 781f1eeee1..3d630118f3 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -5,6 +5,7 @@ module Language.PureScript.Sugar.CaseDeclarations ( desugarCases , desugarCasesModule + , desugarCaseGuards ) where import Prelude.Compat @@ -37,14 +38,23 @@ desugarCasesModule (Module ss coms name ds exps) = <$> (desugarCases <=< desugarAbs <=< validateCases $ ds) <*> pure exps +desugarCaseGuards + :: forall m. (MonadSupply m, MonadError MultipleErrors m) + => [Declaration] + -> m [Declaration] +desugarCaseGuards declarations = parU declarations f + where + (f, _, _) = everywhereOnValuesM return desugarGuardedExprs return + -- | -- Desugar case with pattern guards and pattern clauses to a -- series of nested case expressions. -- -desugarCase :: forall m. (MonadSupply m) - => Expr - -> m Expr -desugarCase (Case scrut alternatives) +desugarGuardedExprs + :: forall m. (MonadSupply m) + => Expr + -> m Expr +desugarGuardedExprs (Case scrut alternatives) | any (not . isTrivialExpr) scrut = do -- in case the scrutinee is non trivial (e.g. not a Var or Literal) -- we may evaluate the scrutinee more than once when a guard occurrs. @@ -55,16 +65,17 @@ desugarCase (Case scrut alternatives) , ValueDeclaration scrut_id Private [] [MkUnguarded e] ) ) - Let scrut_decls <$> desugarCase (Case scrut' alternatives) + Let scrut_decls <$> desugarGuardedExprs (Case scrut' alternatives) where isTrivialExpr (Var _) = True isTrivialExpr (Literal _) = True isTrivialExpr (Accessor _ e) = isTrivialExpr e isTrivialExpr (Parens e) = isTrivialExpr e isTrivialExpr (PositionedValue _ _ e) = isTrivialExpr e + isTrivialExpr (TypedValue _ e _) = isTrivialExpr e isTrivialExpr _ = False -desugarCase (Case scrut alternatives) = +desugarGuardedExprs (Case scrut alternatives) = let -- Alternatives which do not have guards are -- left as-is. Alternatives which @@ -206,8 +217,9 @@ desugarCase (Case scrut alternatives) = desugarAltOutOfLine alt_binder rem_guarded rem_alts mk_body | Just rem_case <- mkCaseOfRemainingGuardsAndAlts = do - desugared <- desugarCase rem_case - rem_case_id <- freshIdent' + desugared <- desugarGuardedExprs rem_case + rem_case_id <- freshIdent' + unused_binder <- freshIdent' let goto_rem_case :: Expr @@ -216,8 +228,8 @@ desugarCase (Case scrut alternatives) = alt_fail = [CaseAlternative [NullBinder] [MkUnguarded goto_rem_case]] pure $ Let [ - ValueDeclaration rem_case_id Private [NullBinder] - [MkUnguarded desugared] + ValueDeclaration rem_case_id Private [] + [MkUnguarded (Abs (VarBinder unused_binder) desugared)] ] (mk_body alt_fail) | otherwise @@ -251,7 +263,13 @@ desugarCase (Case scrut alternatives) = alts' <- desugarAlternatives alternatives return $ optimize (Case scrut alts') -desugarCase v = pure v +desugarGuardedExprs (TypedValue infered e ty) = + TypedValue infered <$> desugarGuardedExprs e <*> pure ty + +desugarGuardedExprs (PositionedValue ss comms e) = + PositionedValue ss comms <$> desugarGuardedExprs e + +desugarGuardedExprs v = pure v -- | -- Validates that case head and binder lengths match. @@ -262,12 +280,12 @@ validateCases = flip parU f (f, _, _) = everywhereOnValuesM return validate return validate :: Expr -> m Expr - validate (Case vs alts) = do + validate c@(Case vs alts) = do let l = length vs alts' = filter ((l /=) . length . caseAlternativeBinders) alts unless (null alts') $ throwError . MultipleErrors $ fmap (altError l) (caseAlternativeBinders <$> alts') - desugarCase (Case vs alts) + return c validate other = return other altError :: Int -> [Binder] -> ErrorMessage @@ -370,8 +388,7 @@ makeCaseDeclaration ident alternatives = do else replicateM (length argNames) freshIdent' let vars = map (Var . Qualified Nothing) args binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] - case_ <- desugarCase (Case vars binders) - let value = foldr (Abs . VarBinder) case_ args + let value = foldr (Abs . VarBinder) (Case vars binders) args return $ ValueDeclaration ident Public [] [MkUnguarded value] where diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index be27c4db2b..1d519ffdca 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -556,12 +556,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do let ns = concatMap binderNames binders in length (ordNub ns) == length ns m1 <- M.unions <$> zipWithM inferBinder nvals binders r <- bindLocalVariables [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ - CaseAlternative binders <$> - case result of - [MkUnguarded val] -> do - val' <- TypedValue True <$> check val ret <*> pure ret - return [MkUnguarded val'] - gs -> forM gs (\ge -> checkGuardedRhs ge ret) + CaseAlternative binders <$> forM result (\ge -> checkGuardedRhs ge ret) rs <- checkBinders nvals ret bs return $ r : rs @@ -573,12 +568,18 @@ checkGuardedRhs checkGuardedRhs (GuardedExpr [] rhs) ret = do rhs' <- TypedValue True <$> check rhs ret <*> pure ret return $ GuardedExpr [] rhs' -checkGuardedRhs (GuardedExpr [ConditionGuard cond] rhs) ret = do +checkGuardedRhs (GuardedExpr (ConditionGuard cond : guards) rhs) ret = do cond' <- withErrorMessageHint ErrorCheckingGuard $ check cond tyBoolean - rhs' <- TypedValue True <$> check rhs ret <*> pure ret - return $ GuardedExpr [ConditionGuard cond'] rhs' -checkGuardedRhs _ _ = - internalError "Pattern not desugared" + GuardedExpr guards' rhs' <- checkGuardedRhs (GuardedExpr guards rhs) ret + return $ GuardedExpr (ConditionGuard cond' : guards') rhs' +checkGuardedRhs (GuardedExpr (PatternGuard binder expr : guards) rhs) ret = do + expr'@(TypedValue _ _ ty) <- infer expr + variables <- inferBinder ty binder + GuardedExpr guards' rhs' <- bindLocalVariables [ (name, bty, Defined) + | (name, bty) <- M.toList variables + ] $ + checkGuardedRhs (GuardedExpr guards rhs) ret + return $ GuardedExpr (PatternGuard binder expr' : guards') rhs' -- | -- Check the type of a value, rethrowing errors to provide a better error message From 82e2d03cc7385e3bb7f2388d903592a6ac958e73 Mon Sep 17 00:00:00 2001 From: legrostdg Date: Sun, 2 Apr 2017 20:29:36 +0200 Subject: [PATCH 0748/1580] Use XDG Base Directory Specification for psci_history (#2799) * Use XDG Base Directory Specification for psci_history * Add myself to CONTRIBUTORS.md --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Interactive/IO.hs | 17 ++++++++++++----- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 69999df6c4..77f2af8c58 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -53,6 +53,7 @@ If you would prefer to use different terms, please use the section below instead | [@kika](https://github.com/kika) | Kirill Pertsev | MIT license | | [@kRITZCREEK](https://github.com/kRITZCREEK) | Christoph Hegemann | MIT license | | [@L8D](https://github.com/L8D) | Tenor Biel | [MIT license](http://opensource.org/licenses/MIT) | +| [@legrostdg](https://github.com/legrostdg) | Félix Sipma | [MIT license](http://opensource.org/licenses/MIT) | | [@LiamGoodacre](https://github.com/LiamGoodacre) | Liam Goodacre | [MIT license](http://opensource.org/licenses/MIT) | | [@lukerandall](https://github.com/lukerandall) | Luke Randall | [MIT license](http://opensource.org/licenses/MIT) | | [@matthewleon](https://github.com/matthewleon) | Matthew Leon | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/Interactive/IO.hs b/src/Language/PureScript/Interactive/IO.hs index 17c4183eb4..92a2e8dc64 100644 --- a/src/Language/PureScript/Interactive/IO.hs +++ b/src/Language/PureScript/Interactive/IO.hs @@ -4,7 +4,9 @@ import Prelude.Compat import Control.Monad (msum) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) -import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable) +import System.Directory (XdgDirectory (..), createDirectoryIfMissing, + getAppUserDataDirectory, getXdgDirectory, + findExecutable, doesFileExist) import System.FilePath (takeDirectory, ()) mkdirp :: FilePath -> IO () @@ -28,7 +30,12 @@ findNodeProcess = onFirstFileMatching findExecutable names -- getHistoryFilename :: IO FilePath getHistoryFilename = do - home <- getHomeDirectory - let filename = home ".purescript" "psci_history" - mkdirp filename - return filename + appuserdata <- getAppUserDataDirectory "purescript" + olddirbool <- doesFileExist (appuserdata "psci_history") + if olddirbool + then return (appuserdata "psci_history") + else do + datadir <- getXdgDirectory XdgData "purescript" + let filename = datadir "psci_history" + mkdirp filename + return filename From e4ff177017f1411ad4cbeade129cfe1bb52d6e99 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 2 Apr 2017 11:33:01 -0700 Subject: [PATCH 0749/1580] 0.11.2 --- package.yaml | 2 +- purescript.cabal | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index 252c7376a9..60da523738 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.11.1' +version: '0.11.2' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. diff --git a/purescript.cabal b/purescript.cabal index 05619582e4..d8b37ebab3 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: purescript -version: 0.11.1 +version: 0.11.2 cabal-version: >= 1.10 build-type: Simple license: BSD3 @@ -305,6 +305,7 @@ extra-source-files: examples/passing/2695.purs examples/passing/2756.purs examples/passing/2787.purs + examples/passing/2795.purs examples/passing/652.purs examples/passing/810.purs examples/passing/862.purs From e9c0d47c0097c1074be412f9cc95c2fd3c006481 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Tue, 4 Apr 2017 05:38:53 +0200 Subject: [PATCH 0750/1580] Exhaustivity check for pattern guards (#2807) --- examples/failing/2806.purs | 7 +++++++ examples/passing/2806.purs | 14 +++++++++++++ src/Language/PureScript/Linter/Exhaustive.hs | 21 ++++++++++++-------- 3 files changed, 34 insertions(+), 8 deletions(-) create mode 100644 examples/failing/2806.purs create mode 100644 examples/passing/2806.purs diff --git a/examples/failing/2806.purs b/examples/failing/2806.purs new file mode 100644 index 0000000000..52103e12c1 --- /dev/null +++ b/examples/failing/2806.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith NoInstanceFound +module X where + +data E a b = L a | R b + +g :: forall a b . E a b -> a +g e | L x <- e = x diff --git a/examples/passing/2806.purs b/examples/passing/2806.purs new file mode 100644 index 0000000000..848b3a3b24 --- /dev/null +++ b/examples/passing/2806.purs @@ -0,0 +1,14 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +data Stream a = Cons a (Stream a) + +step :: forall a. Stream a -> Stream a +step (Cons _ xs) = xs + +head :: forall a. Stream a -> a +head xs | Cons x _ <- step xs = x + +main = log "Done" diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 64db3b13bd..af9db13b1b 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -200,21 +200,26 @@ missingCasesMultiple env mn = go -- | otherwise = 1 -- is exhaustive, whereas `f x | x < 0` is not -- +-- or in case of a pattern guard if the pattern is exhaustive. +-- -- The function below say whether or not a guard has an `otherwise` expression -- It is considered that `otherwise` is defined in Prelude -- -isExhaustiveGuard :: [GuardedExpr] -> Bool -isExhaustiveGuard [GuardedExpr [] _] = True -isExhaustiveGuard gs = +isExhaustiveGuard :: Environment -> ModuleName -> [GuardedExpr] -> Bool +isExhaustiveGuard _ _ [MkUnguarded _] = True +isExhaustiveGuard env moduleName gs = not . null $ filter (\(GuardedExpr grd _) -> isExhaustive grd) gs where - checkGuard :: Guard -> Bool - checkGuard (ConditionGuard cond) = isTrueExpr cond - checkGuard (PatternGuard bind _) = isIrrefutable bind - isExhaustive :: [Guard] -> Bool isExhaustive = all checkGuard + checkGuard :: Guard -> Bool + checkGuard (ConditionGuard cond) = isTrueExpr cond + checkGuard (PatternGuard binder _) = + case missingCasesMultiple env moduleName [NullBinder] [binder] of + ([], _) -> True -- there are no missing pattern for this guard + _ -> False + -- | -- Returns the uncovered set of case alternatives -- @@ -223,7 +228,7 @@ missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAl missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedundancyError Bool) missingAlternative env mn ca uncovered - | isExhaustiveGuard (caseAlternativeResult ca) = mcases + | isExhaustiveGuard env mn (caseAlternativeResult ca) = mcases | otherwise = ([uncovered], snd mcases) where mcases = missingCases env mn uncovered ca From 5980159aa5d61800830245b5f982f70bb4157e7b Mon Sep 17 00:00:00 2001 From: Adam Bergmark Date: Sat, 8 Apr 2017 03:11:19 +0200 Subject: [PATCH 0751/1580] Require directory > 1.2.3.0 for Xdg support (#2816) --- purescript.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/purescript.cabal b/purescript.cabal index d8b37ebab3..05ce73c9a1 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -657,7 +657,7 @@ library , containers , data-ordlist >=0.4.7.0 , deepseq - , directory >=1.2 + , directory >=1.2.3.0 , dlist , edit-distance , filepath From 3b7d9fa5f5b8f6b67a00287c685cf4fbc5efb466 Mon Sep 17 00:00:00 2001 From: Hyunje Jun Date: Sun, 9 Apr 2017 05:10:08 +0900 Subject: [PATCH 0752/1580] Accept print function as handleCommand argument (#2808) * Accept print function as a PSCi argument It's to enable checking output of PSCi commands and adding test suites for them. * Make handleCommand work with PSCiT It removes wildcard binders for PSCi functions used in command handling. * Revert "Make handleCommand work with PSCiT" This reverts commit 6b8a9319feeb30250c55fea0c02292273b4596db. --- app/Command/REPL.hs | 2 +- src/Language/PureScript/Interactive.hs | 74 ++++++++++++++------------ tests/TestPsci/TestEnv.hs | 2 +- 3 files changed, 42 insertions(+), 36 deletions(-) diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 86986070a7..24132b7278 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -334,7 +334,7 @@ command = loop <$> options . runInputT (setComplete completion settings) handleCommand' :: state -> Command -> StateT PSCiState (ReaderT PSCiConfig IO) () - handleCommand' state = handleCommand (liftIO . eval state) (liftIO (reload state)) + handleCommand' state = handleCommand (liftIO . eval state) (liftIO (reload state)) (liftIO . putStrLn) go :: state -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) () go state = do diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index f589536dfe..ce075fc9fb 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -90,22 +90,23 @@ make ms = do -- | Performs a PSCi command handleCommand :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) - => (String -> m ()) - -> m () + => (String -> m ()) -- ^ evaluate JS + -> m () -- ^ reload + -> (String -> m ()) -- ^ print into console -> Command -> m () -handleCommand _ _ ShowHelp = liftIO $ putStrLn helpMessage -handleCommand _ r ReloadState = handleReloadState r -handleCommand _ r ClearState = handleClearState r -handleCommand c _ (Expression val) = handleExpression c val -handleCommand _ _ (Import im) = handleImport im -handleCommand _ _ (Decls l) = handleDecls l -handleCommand _ _ (TypeOf val) = handleTypeOf val -handleCommand _ _ (KindOf typ) = handleKindOf typ -handleCommand _ _ (BrowseModule moduleName) = handleBrowse moduleName -handleCommand _ _ (ShowInfo QueryLoaded) = handleShowLoadedModules -handleCommand _ _ (ShowInfo QueryImport) = handleShowImportedModules -handleCommand _ _ _ = P.internalError "handleCommand: unexpected command" +handleCommand _ _ p ShowHelp = p helpMessage +handleCommand _ r _ ReloadState = handleReloadState r +handleCommand _ r _ ClearState = handleClearState r +handleCommand e _ _ (Expression val) = handleExpression e val +handleCommand _ _ _ (Import im) = handleImport im +handleCommand _ _ _ (Decls l) = handleDecls l +handleCommand _ _ p (TypeOf val) = handleTypeOf p val +handleCommand _ _ p (KindOf typ) = handleKindOf p typ +handleCommand _ _ p (BrowseModule moduleName) = handleBrowse p moduleName +handleCommand _ _ p (ShowInfo QueryLoaded) = handleShowLoadedModules p +handleCommand _ _ p (ShowInfo QueryImport) = handleShowImportedModules p +handleCommand _ _ _ _ = P.internalError "handleCommand: unexpected command" -- | Reload the application state handleReloadState @@ -169,23 +170,25 @@ handleDecls ds = do -- | Show actual loaded modules in psci. handleShowLoadedModules :: (MonadState PSCiState m, MonadIO m) - => m () -handleShowLoadedModules = do + => (String -> m ()) + -> m () +handleShowLoadedModules print' = do loadedModules <- gets psciLoadedExterns - liftIO $ putStrLn (readModules loadedModules) + print' $ readModules loadedModules where readModules = unlines . sort . ordNub . map (T.unpack . P.runModuleName . P.getModuleName . fst) -- | Show the imported modules in psci. handleShowImportedModules :: (MonadState PSCiState m, MonadIO m) - => m () -handleShowImportedModules = do + => (String -> m ()) + -> m () +handleShowImportedModules print' = do PSCiState { psciImportedModules = importedModules } <- get - liftIO $ showModules importedModules >>= putStrLn + print' $ showModules importedModules return () where - showModules = return . unlines . sort . map (T.unpack . showModule) + showModules = unlines . sort . map (T.unpack . showModule) showModule (mn, declType, asQ) = "import " <> N.runModuleName mn <> showDeclType declType <> foldMap (\mn' -> " as " <> N.runModuleName mn') asQ @@ -236,9 +239,10 @@ handleImport im = do -- | Takes a value and prints its type handleTypeOf :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) - => P.Expr + => (String -> m ()) + -> P.Expr -> m () -handleTypeOf val = do +handleTypeOf print' val = do st <- get let m = createTemporaryModule False st val e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m @@ -246,15 +250,16 @@ handleTypeOf val = do Left errs -> printErrors errs Right (_, env') -> case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName [P.ProperName "$PSCI"])) (P.names env') of - Just (ty, _, _) -> liftIO . putStrLn . P.prettyPrintType $ ty - Nothing -> liftIO $ putStrLn "Could not find type" + Just (ty, _, _) -> print' . P.prettyPrintType $ ty + Nothing -> print' "Could not find type" -- | Takes a type and prints its kind handleKindOf :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) - => P.Type + => (String -> m ()) + -> P.Type -> m () -handleKindOf typ = do +handleKindOf print' typ = do st <- get let m = createTemporaryModuleForKind st typ mName = P.ModuleName [P.ProperName "$PSCI"] @@ -271,23 +276,24 @@ handleKindOf typ = do check sew = fst . runWriter . runExceptT . runStateT sew case k of Left err -> printErrors err - Right (kind, _) -> liftIO . putStrLn . T.unpack . P.prettyPrintKind $ kind - Nothing -> liftIO $ putStrLn "Could not find kind" + Right (kind, _) -> print' . T.unpack . P.prettyPrintKind $ kind + Nothing -> print' "Could not find kind" -- | Browse a module and displays its signature handleBrowse :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) - => P.ModuleName + => (String -> m ()) + -> P.ModuleName -> m () -handleBrowse moduleName = do +handleBrowse print' moduleName = do st <- get env <- asks psciEnvironment if isModInEnv moduleName st - then liftIO . putStrLn $ printModuleSignatures moduleName env + then print' $ printModuleSignatures moduleName env else case lookupUnQualifiedModName moduleName st of Just unQualifiedName -> if isModInEnv unQualifiedName st - then liftIO . putStrLn $ printModuleSignatures unQualifiedName env + then print' $ printModuleSignatures unQualifiedName env else failNotInEnv moduleName Nothing -> failNotInEnv moduleName @@ -295,6 +301,6 @@ handleBrowse moduleName = do isModInEnv modName = any ((== modName) . P.getModuleName . fst) . psciLoadedExterns failNotInEnv modName = - liftIO $ putStrLn $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid." + print' $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid." lookupUnQualifiedModName quaModName st = (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st) diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 519f8fb3a6..8f71d9ad01 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -64,7 +64,7 @@ runAndEval comm eval = Right command -> -- the JS result can be ignored, as it's already written in a source file -- for the detail, please refer to Interactive.hs - handleCommand (\_ -> eval) (return ()) command + handleCommand (\_ -> eval) (return ()) (\_ -> return ()) command -- | Run a PSCi command and ignore the output run :: String -> TestPSCi () From a5a7bd5db52309a72515eed8a35406bdbb38086e Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 8 Apr 2017 13:22:49 -0700 Subject: [PATCH 0753/1580] 0.11.3 --- package.yaml | 2 +- purescript.cabal | 6 ++++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/package.yaml b/package.yaml index 60da523738..57064971a3 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.11.2' +version: '0.11.3' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. diff --git a/purescript.cabal b/purescript.cabal index 05ce73c9a1..4932d25aa2 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: purescript -version: 0.11.2 +version: 0.11.3 cabal-version: >= 1.10 build-type: Simple license: BSD3 @@ -83,6 +83,7 @@ extra-source-files: examples/failing/2567.purs examples/failing/2601.purs examples/failing/2616.purs + examples/failing/2806.purs examples/failing/365.purs examples/failing/438.purs examples/failing/881.purs @@ -306,6 +307,7 @@ extra-source-files: examples/passing/2756.purs examples/passing/2787.purs examples/passing/2795.purs + examples/passing/2806.purs examples/passing/652.purs examples/passing/810.purs examples/passing/862.purs @@ -657,7 +659,7 @@ library , containers , data-ordlist >=0.4.7.0 , deepseq - , directory >=1.2.3.0 + , directory >=1.2 , dlist , edit-distance , filepath From 20d4a2dc44f492d773929d1bd2b3b4750cbdd683 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sat, 8 Apr 2017 22:28:05 +0200 Subject: [PATCH 0754/1580] [purs ide] Use the user-specified log level for file-watcher logs (#2814) * [purs ide] Use the user-specified log level for file-watcher logs * [purs ide] log failed reload attempts by the filewatcher * updates .cabal file to contain new test files --- app/Command/Ide.hs | 2 +- src/Language/PureScript/Ide/Watcher.hs | 39 ++++++++++++++------------ 2 files changed, 22 insertions(+), 19 deletions(-) diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index b7d45cc4c0..70fbb7d730 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -119,7 +119,7 @@ command = Opts.helper <*> subcommands where putText "psc-ide needs you to compile your project (for example by running pulp build)" unless noWatch $ - void (forkFinally (watcher polling ideState fullOutputPath) print) + void (forkFinally (watcher polling logLevel ideState fullOutputPath) print) let conf = Configuration {confLogLevel = logLevel, confOutputPath = outputPath, confGlobs = globs} env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf} startServer port env diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs index 97b45b575d..a966679b06 100644 --- a/src/Language/PureScript/Ide/Watcher.hs +++ b/src/Language/PureScript/Ide/Watcher.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PackageImports #-} ----------------------------------------------------------------------------- -- -- Module : Language.PureScript.Ide.Watcher @@ -16,38 +17,40 @@ module Language.PureScript.Ide.Watcher ( watcher ) where -import Protolude +import Protolude -import Control.Concurrent.STM -import Language.PureScript.Ide.Externs -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util -import System.FilePath -import System.FSNotify +import Control.Concurrent.STM +import "monad-logger" Control.Monad.Logger +import Language.PureScript.Ide.Externs +import Language.PureScript.Ide.State +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util +import System.FSNotify +import System.FilePath -- | Reloads an ExternsFile from Disc. If the Event indicates the ExternsFile -- was deleted we don't do anything. -reloadFile :: TVar IdeState -> Event -> IO () -reloadFile _ Removed{} = pure () -reloadFile ref ev = do +reloadFile :: IdeLogLevel -> TVar IdeState -> Event -> IO () +reloadFile _ _ Removed{} = pure () +reloadFile logLevel ref ev = runLogger logLevel $ do let fp = eventPath ev - ef' <- runLogger LogDefault (runExceptT (readExternFile fp)) + ef' <- runExceptT (readExternFile fp) case ef' of - Left _ -> pure () + Left err -> + logErrorN ("Failed to reload file at: " <> toS fp <> " with error: " <> show err) Right ef -> do - void $ atomically (insertExternsSTM ref ef *> populateStage3STM ref) - putStrLn ("Reloaded File at: " ++ fp) + lift $ void $ atomically (insertExternsSTM ref ef *> populateStage3STM ref) + logDebugN ("Reloaded File at: " <> toS fp) -- | Installs filewatchers for the given directory and reloads ExternsFiles when -- they change on disc -watcher :: Bool -> TVar IdeState -> FilePath -> IO () -watcher polling stateVar fp = +watcher :: Bool -> IdeLogLevel -> TVar IdeState -> FilePath -> IO () +watcher polling logLevel stateVar fp = withManagerConf (defaultConfig { confDebounce = NoDebounce , confUsePolling = polling }) $ \mgr -> do _ <- watchTree mgr fp (\ev -> takeFileName (eventPath ev) == "externs.json") - (reloadFile stateVar) + (reloadFile logLevel stateVar) forever (threadDelay 100000) From 6dc0e2ec2fdf30ab815af0151d6f9c6e3fbc1155 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 8 Apr 2017 23:51:37 +0100 Subject: [PATCH 0755/1580] Add a bunch of NFData instances (#2817) I also added derived Generic instances in order to be able to define the NFData instances without having to write the necessary code by hand; I expect I'll do it incorrectly if I try to do it by hand. I am mainly doing this because I want to use it to help diagnose bugs like #2772 but I also think it might come in handy in real code at some point too; e.g. if we ever want to store these types in Pursuit's database. --- src/Language/PureScript/AST/Operators.hs | 11 +++- src/Language/PureScript/AST/SourcePos.hs | 11 +++- src/Language/PureScript/Docs/Types.hs | 60 ++++++++++++++----- src/Language/PureScript/Environment.hs | 32 +++++++--- src/Language/PureScript/Kinds.hs | 8 ++- src/Language/PureScript/Label.hs | 8 ++- src/Language/PureScript/Names.hs | 27 +++++++-- src/Language/PureScript/PSString.hs | 8 ++- .../PureScript/TypeClassDictionaries.hs | 7 ++- src/Language/PureScript/Types.hs | 19 ++++-- 10 files changed, 152 insertions(+), 39 deletions(-) diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs index c562e7d39a..ffe53771d0 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} -- | -- Operators fixity and associativity -- @@ -5,6 +6,8 @@ module Language.PureScript.AST.Operators where import Prelude.Compat +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) import Data.Aeson ((.=)) import qualified Data.Aeson as A @@ -19,7 +22,9 @@ type Precedence = Integer -- Associativity for infix operators -- data Associativity = Infixl | Infixr | Infix - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData Associativity showAssoc :: Associativity -> String showAssoc Infixl = "infixl" @@ -42,7 +47,9 @@ instance A.FromJSON Associativity where -- Fixity data for infix operators -- data Fixity = Fixity Associativity Precedence - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData Fixity instance A.ToJSON Fixity where toJSON (Fixity associativity precedence) = diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 5dfb98b68d..4c6d571556 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} -- | -- Source position information -- @@ -5,6 +6,8 @@ module Language.PureScript.AST.SourcePos where import Prelude.Compat +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A import Data.Monoid @@ -23,7 +26,9 @@ data SourcePos = SourcePos -- Column number -- , sourcePosColumn :: Int - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic) + +instance NFData SourcePos displaySourcePos :: SourcePos -> Text displaySourcePos sp = @@ -51,7 +56,9 @@ data SourceSpan = SourceSpan -- End of the span -- , spanEnd :: SourcePos - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic) + +instance NFData SourceSpan displayStartEndPos :: SourceSpan -> Text displayStartEndPos sp = diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 8190415b06..f97a25d2bd 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveGeneric #-} + module Language.PureScript.Docs.Types ( module Language.PureScript.Docs.Types , module ReExports @@ -7,6 +9,8 @@ module Language.PureScript.Docs.Types import Protolude hiding (to, from) import Prelude (String, unlines, lookup) +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) import Control.Arrow ((***)) import Data.Aeson ((.=)) @@ -55,10 +59,14 @@ data Package a = Package -- ^ The version of the PureScript compiler which was used to generate -- this data. We store this in order to reject packages which are too old. } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData a => NFData (Package a) data NotYetKnown = NotYetKnown - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData NotYetKnown type UploadedPackage = Package NotYetKnown type VerifiedPackage = Package GithubUser @@ -111,7 +119,9 @@ data Module = Module -- Re-exported values from other modules , modReExports :: [(InPackage P.ModuleName, [Declaration])] } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData Module data Declaration = Declaration { declTitle :: Text @@ -120,7 +130,9 @@ data Declaration = Declaration , declChildren :: [ChildDeclaration] , declInfo :: DeclarationInfo } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData Declaration -- | -- A value of this type contains information that is specific to a particular @@ -170,7 +182,9 @@ data DeclarationInfo -- A kind declaration -- | ExternKindDeclaration - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData DeclarationInfo convertFundepsToStrings :: [(Text, Maybe P.Kind)] -> [P.FunctionalDependency] -> [([Text], [Text])] convertFundepsToStrings args fundeps = @@ -265,7 +279,9 @@ data ChildDeclaration = ChildDeclaration , cdeclSourceSpan :: Maybe P.SourceSpan , cdeclInfo :: ChildDeclarationInfo } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData ChildDeclaration data ChildDeclarationInfo -- | @@ -284,7 +300,9 @@ data ChildDeclarationInfo -- example, `pure` from `Applicative` would be `forall a. a -> f a`. -- | ChildTypeClassMember P.Type - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData ChildDeclarationInfo childDeclInfoToString :: ChildDeclarationInfo -> Text childDeclInfoToString (ChildInstance _ _) = "instance" @@ -319,11 +337,15 @@ isDataConstructor ChildDeclaration{..} = newtype GithubUser = GithubUser { runGithubUser :: Text } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData GithubUser newtype GithubRepo = GithubRepo { runGithubRepo :: Text } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData GithubRepo data PackageError = CompilerTooOld Version Version @@ -337,12 +359,16 @@ data PackageError | InvalidKind Text | InvalidDataDeclType Text | InvalidTime - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData PackageError data InPackage a = Local a | FromDep PackageName a - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData a => NFData (InPackage a) instance Functor InPackage where fmap f (Local x) = Local (f x) @@ -370,14 +396,18 @@ data LinksContext = LinksContext , ctxVersion :: Version , ctxVersionTag :: Text } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData LinksContext data DocLink = DocLink { linkLocation :: LinkLocation , linkTitle :: Text , linkNamespace :: Namespace } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData DocLink data LinkLocation -- | A link to a declaration in the same module. @@ -397,7 +427,9 @@ data LinkLocation -- module. In this case we only need to store the module that the builtin -- comes from (at the time of writing, this will only ever be "Prim"). | BuiltinModule P.ModuleName - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData LinkLocation -- | Given a links context, the current module name, the namespace of a thing -- to link to, its title, and its containing module, attempt to create a diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index b0f0c7b8b3..7d114435be 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -1,8 +1,12 @@ +{-# LANGUAGE DeriveGeneric #-} + module Language.PureScript.Environment where import Prelude.Compat import Protolude (ordNub) +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A import qualified Data.Map as M @@ -38,7 +42,9 @@ data Environment = Environment -- ^ Type classes , kinds :: S.Set (Qualified (ProperName 'KindName)) -- ^ Kinds in scope - } deriving Show + } deriving (Show, Generic) + +instance NFData Environment -- | Information about a type class data TypeClassData = TypeClassData @@ -59,7 +65,9 @@ data TypeClassData = TypeClassData -- typeClassArguments and typeClassDependencies. , typeClassCoveringSets :: S.Set (S.Set Int) -- ^ A sets of arguments that can be used to infer all other arguments. - } deriving Show + } deriving (Show, Generic) + +instance NFData TypeClassData -- | A functional dependency indicates a relationship between two sets of -- type arguments in a class declaration. @@ -68,7 +76,9 @@ data FunctionalDependency = FunctionalDependency -- ^ the type arguments which determine the determined type arguments , fdDetermined :: [Int] -- ^ the determined type arguments - } deriving Show + } deriving (Show, Generic) + +instance NFData FunctionalDependency instance A.FromJSON FunctionalDependency where parseJSON = A.withObject "FunctionalDependency" $ \o -> @@ -164,7 +174,9 @@ data NameVisibility -- ^ The name is defined in the current binding group, but is not visible | Defined -- ^ The name is defined in the another binding group, or has been made visible by a function binder - deriving (Show, Eq) + deriving (Show, Eq, Generic) + +instance NFData NameVisibility -- | A flag for whether a name is for an private or public value - only public values will be -- included in a generated externs file. @@ -176,7 +188,9 @@ data NameKind -- ^ A public value for a module member or foreing import declaration | External -- ^ A name for member introduced by foreign import - deriving (Show, Eq) + deriving (Show, Eq, Generic) + +instance NFData NameKind -- | The kinds of a type data TypeKind @@ -190,7 +204,9 @@ data TypeKind -- ^ A local type variable | ScopedTypeVar -- ^ A scoped type variable - deriving (Show, Eq) + deriving (Show, Eq, Generic) + +instance NFData TypeKind instance A.ToJSON TypeKind where toJSON (DataType args ctors) = @@ -221,7 +237,9 @@ data DataDeclType -- ^ A standard data constructor | Newtype -- ^ A newtype constructor - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData DataDeclType showDataDeclType :: DataDeclType -> Text showDataDeclType Data = "data" diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 696dd36fa6..8de3b29daa 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE DeriveGeneric #-} + module Language.PureScript.Kinds where import Prelude.Compat +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) import Data.Text (Text) import qualified Data.Text as T import Data.Aeson.BetterErrors (Parse, key, asText, asIntegral, nth, fromAesonParser, toAesonParser, throwCustomError) @@ -21,7 +25,9 @@ data Kind | FunKind Kind Kind -- | A named kind | NamedKind (Qualified (ProperName 'KindName)) - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData Kind -- This is equivalent to the derived Aeson ToJSON instance, except that we -- write it out manually so that we can define a parser which is diff --git a/src/Language/PureScript/Label.hs b/src/Language/PureScript/Label.hs index 3c8123d69e..b00db4fe9b 100644 --- a/src/Language/PureScript/Label.hs +++ b/src/Language/PureScript/Label.hs @@ -1,7 +1,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} + module Language.PureScript.Label (Label(..)) where import Prelude.Compat hiding (lex) +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) import Data.Monoid () import Data.String (IsString(..)) import qualified Data.Aeson as A @@ -13,4 +17,6 @@ import Language.PureScript.PSString (PSString) -- because records are indexable by PureScript strings at runtime. -- newtype Label = Label { runLabel :: PSString } - deriving (Show, Eq, Ord, IsString, Monoid, A.ToJSON, A.FromJSON) + deriving (Show, Eq, Ord, IsString, Monoid, A.ToJSON, A.FromJSON, Generic) + +instance NFData Label diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 0c506435d3..c804b20940 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} -- | -- Data types for names @@ -8,7 +9,9 @@ module Language.PureScript.Names where import Prelude.Compat import Control.Monad.Supply.Class +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) import Data.Aeson import Data.Aeson.TH import Data.Monoid ((<>)) @@ -25,7 +28,9 @@ data Name | TyClassName (ProperName 'ClassName) | ModName ModuleName | KiName (ProperName 'KindName) - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance NFData Name getIdentName :: Name -> Maybe Ident getIdentName (IdentName name) = Just name @@ -67,7 +72,9 @@ data Ident -- A generated name for an identifier -- | GenIdent (Maybe Text) Integer - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData Ident runIdent :: Ident -> Text runIdent (Ident i) = i @@ -87,7 +94,9 @@ freshIdent' = GenIdent Nothing <$> fresh -- Operator alias names. -- newtype OpName (a :: OpNameType) = OpName { runOpName :: Text } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData (OpName a) instance ToJSON (OpName a) where toJSON = toJSON . runOpName @@ -107,7 +116,9 @@ data OpNameType = ValueOpName | TypeOpName -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. -- newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text } - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData (ProperName a) instance ToJSON (ProperName a) where toJSON = toJSON . runProperName @@ -137,7 +148,9 @@ coerceProperName = ProperName . runProperName -- Module names -- newtype ModuleName = ModuleName [ProperName 'Namespace] - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData ModuleName runModuleName :: ModuleName -> Text runModuleName (ModuleName pns) = T.intercalate "." (runProperName <$> pns) @@ -154,7 +167,9 @@ moduleNameFromString = ModuleName . splitProperNames -- A qualified name, i.e. a name with an optional module name -- data Qualified a = Qualified (Maybe ModuleName) a - deriving (Show, Eq, Ord, Functor) + deriving (Show, Eq, Ord, Functor, Generic) + +instance NFData a => NFData (Qualified a) showQualified :: (a -> Text) -> Qualified a -> Text showQualified f (Qualified Nothing a) = f a diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index 0073f0f159..0dcb3b40cc 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -1,5 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + module Language.PureScript.PSString ( PSString , toUTF16CodeUnits @@ -12,6 +14,8 @@ module Language.PureScript.PSString ) where import Prelude.Compat +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) import Control.Exception (try, evaluate) import Control.Applicative ((<|>)) import Data.Char (chr) @@ -48,7 +52,9 @@ import qualified Data.Aeson.Types as A -- and arrays of UTF-16 code units (integers) otherwise. -- newtype PSString = PSString { toUTF16CodeUnits :: [Word16] } - deriving (Eq, Ord, Monoid) + deriving (Eq, Ord, Monoid, Generic) + +instance NFData PSString instance Show PSString where show = show . codePoints diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 3b3448a4fe..70d138b56e 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -1,9 +1,12 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveGeneric #-} module Language.PureScript.TypeClassDictionaries where import Prelude.Compat +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) import Data.Monoid ((<>)) import Data.Text (Text, pack) @@ -26,7 +29,9 @@ data TypeClassDictionaryInScope v -- | Type class dependencies which must be satisfied to construct this dictionary , tcdDependencies :: Maybe [Constraint] } - deriving (Show, Functor, Foldable, Traversable) + deriving (Show, Functor, Foldable, Traversable, Generic) + +instance NFData v => NFData (TypeClassDictionaryInScope v) type NamedDict = TypeClassDictionaryInScope (Qualified Ident) diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index f68a5aa827..3bc2899b0f 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} -- | -- Data types for types @@ -10,6 +11,7 @@ import Prelude.Compat import Protolude (ordNub) import Control.Arrow (first) +import Control.DeepSeq (NFData) import Control.Monad ((<=<)) import qualified Data.Aeson as A import qualified Data.Aeson.TH as A @@ -19,6 +21,7 @@ import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T +import GHC.Generics (Generic) import Language.PureScript.AST.SourcePos import Language.PureScript.Kinds @@ -30,7 +33,9 @@ import Language.PureScript.PSString (PSString) -- An identifier for the scope of a skolem variable -- newtype SkolemScope = SkolemScope { runSkolemScope :: Int } - deriving (Show, Eq, Ord, A.ToJSON, A.FromJSON) + deriving (Show, Eq, Ord, A.ToJSON, A.FromJSON, Generic) + +instance NFData SkolemScope -- | -- The type of types @@ -78,7 +83,9 @@ data Type -- Note: although it seems this constructor is not used, it _is_ useful, -- since it prevents certain traversals from matching. | ParensInType Type - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData Type -- | Additional data relevant to type class constraints data ConstraintData @@ -88,7 +95,9 @@ data ConstraintData -- not matched, and a flag indicating whether the list was truncated or not. -- Note: we use 'Text' here because using 'Binder' would introduce a cyclic -- dependency in the module graph. - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData ConstraintData -- | A typeclass constraint data Constraint = Constraint @@ -98,7 +107,9 @@ data Constraint = Constraint -- ^ type arguments , constraintData :: Maybe ConstraintData -- ^ additional data relevant to this constraint - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic) + +instance NFData Constraint mapConstraintArgs :: ([Type] -> [Type]) -> Constraint -> Constraint mapConstraintArgs f c = c { constraintArgs = f (constraintArgs c) } From 056dfe6ad1b3383a447d662eea0a2c7854ad08b3 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 10 Apr 2017 05:07:30 +0200 Subject: [PATCH 0756/1580] [purs ide] Fix encoding bug in list import command (#2818) Instead of returning `"Data.Array"` we returned `["Data", "Array"]` here, because the code fell back to the ToJSON instance for `ModuleName` --- src/Language/PureScript/Ide/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 5abd68b752..332da88361 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -229,7 +229,7 @@ instance ToJSON Success where toJSON (PursuitResult resp) = encodeSuccess resp toJSON (ImportList (moduleName, imports)) = object [ "resultType" .= ("success" :: Text) , "result" .= object [ "imports" .= map encodeImport imports - , "moduleName" .= moduleName]] + , "moduleName" .= P.runModuleName moduleName]] toJSON (ModuleList modules) = encodeSuccess modules toJSON (RebuildSuccess warnings) = encodeSuccess (P.toJSONErrors False P.Warning warnings) From a60f84e29b63f0dce9edb0185ead069094869190 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 11 Apr 2017 01:07:57 +0100 Subject: [PATCH 0757/1580] Fix #2772, match type level strings in docs renderer (#2824) Also fixes #2448 --- examples/docs/src/TypeLevelString.purs | 7 +++++++ purescript.cabal | 3 ++- src/Language/PureScript/Docs/RenderedCode/RenderType.hs | 3 +++ tests/TestDocs.hs | 4 ++++ 4 files changed, 16 insertions(+), 1 deletion(-) create mode 100644 examples/docs/src/TypeLevelString.purs diff --git a/examples/docs/src/TypeLevelString.purs b/examples/docs/src/TypeLevelString.purs new file mode 100644 index 0000000000..34d4f038bc --- /dev/null +++ b/examples/docs/src/TypeLevelString.purs @@ -0,0 +1,7 @@ +module TypeLevelString where + +data Foo + +class Bar a + +instance fooBar :: Fail "oops" => Bar Foo diff --git a/purescript.cabal b/purescript.cabal index 4932d25aa2..e8de8acd72 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,4 +1,4 @@ --- This file has been generated from package.yaml by hpack version 0.15.0. +-- This file has been generated from package.yaml by hpack version 0.17.0. -- -- see: https://github.com/sol/hpack @@ -59,6 +59,7 @@ extra-source-files: examples/docs/src/TypeClassWithFunDeps.purs examples/docs/src/TypeClassWithoutMembers.purs examples/docs/src/TypeClassWithoutMembersIntermediate.purs + examples/docs/src/TypeLevelString.purs examples/docs/src/TypeOpAliases.purs examples/docs/src/UTF8.purs examples/docs/src/Virtual.purs diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index e8dae4625f..15f51dc94c 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -26,6 +26,7 @@ import Language.PureScript.Names import Language.PureScript.Pretty.Types import Language.PureScript.Types import Language.PureScript.Label (Label) +import Language.PureScript.PSString (prettyPrintString) import Language.PureScript.Docs.RenderedCode.Types import Language.PureScript.Docs.Utils.MonoidExtras @@ -54,6 +55,8 @@ typeLiterals = mkPattern match Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r match (TypeOp n) = Just (typeOp n) + match (TypeLevelString str) = + Just (syntax (prettyPrintString str)) match _ = Nothing diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 34863ea339..788ef881eb 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -398,6 +398,10 @@ testCases = , ("DocComments", [ ShouldHaveDocComment (n "DocComments") "example" " example == 0" ]) + + , ("TypeLevelString", + [ ShouldBeDocumented (n "TypeLevelString") "Foo" ["fooBar"] + ]) ] where From 68d3cb5cea4856aaf1a57656b52c5fd7d42b759b Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 11 Apr 2017 17:22:14 +0100 Subject: [PATCH 0758/1580] Bump aeson lower bound to 1.0 (#2825) We do actually rely on aeson being at least 1.0 for our JSON formats. --- package.yaml | 2 +- purescript.cabal | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/package.yaml b/package.yaml index 57064971a3..3639ad3431 100644 --- a/package.yaml +++ b/package.yaml @@ -32,7 +32,7 @@ extra-source-files: - CONTRIBUTORS.md - CONTRIBUTING.md dependencies: - - aeson >=0.8 && <1.1 + - aeson >=1.0 && <1.1 - aeson-better-errors >=0.8 - ansi-terminal >=0.6.2 && <0.7 - base >=4.8 && <5 diff --git a/purescript.cabal b/purescript.cabal index e8de8acd72..8550355543 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -646,7 +646,7 @@ flag release library build-depends: - aeson >=0.8 && <1.1 + aeson >=1.0 && <1.1 , aeson-better-errors >=0.8 , ansi-terminal >=0.6.2 && <0.7 , base >=4.8 && <5 @@ -854,7 +854,7 @@ library executable purs build-depends: - aeson >=0.8 && <1.1 + aeson >=1.0 && <1.1 , aeson-better-errors >=0.8 , ansi-terminal >=0.6.2 && <0.7 , base >=4.8 && <5 @@ -942,7 +942,7 @@ executable purs test-suite tests build-depends: - aeson >=0.8 && <1.1 + aeson >=1.0 && <1.1 , aeson-better-errors >=0.8 , ansi-terminal >=0.6.2 && <0.7 , base >=4.8 && <5 From f8d4530bfacd339cdd37024b9e7fbe1e8a1412ff Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 13 Apr 2017 09:20:14 -0700 Subject: [PATCH 0759/1580] Allow user to propagate Warn constraints (#2828) * Allow user to propagate Warn constraints, fix #2813 * Fix the double warning issue, add an example * Fix the tests --- examples/warning/CustomWarning2.purs | 11 +++++++++++ examples/warning/CustomWarning3.purs | 13 +++++++++++++ src/Language/PureScript/TypeChecker/Entailment.hs | 6 ++++-- 3 files changed, 28 insertions(+), 2 deletions(-) create mode 100644 examples/warning/CustomWarning2.purs create mode 100644 examples/warning/CustomWarning3.purs diff --git a/examples/warning/CustomWarning2.purs b/examples/warning/CustomWarning2.purs new file mode 100644 index 0000000000..72afec3db1 --- /dev/null +++ b/examples/warning/CustomWarning2.purs @@ -0,0 +1,11 @@ +-- @shouldWarnWith UserDefinedWarning +module Main where + +foo :: Warn "foo" => Int -> Int +foo x = x + +bar :: Warn "foo" => Int +bar = foo 42 + +baz :: Int +baz = bar diff --git a/examples/warning/CustomWarning3.purs b/examples/warning/CustomWarning3.purs new file mode 100644 index 0000000000..e06f7f12fa --- /dev/null +++ b/examples/warning/CustomWarning3.purs @@ -0,0 +1,13 @@ +-- @shouldWarnWith UserDefinedWarning +-- @shouldWarnWith UserDefinedWarning +module Main where + +foo :: Warn "foo" => Int -> Int +foo x = x + +-- Defer the "foo" warning and warn with "bar" as well +bar :: Warn "foo" => Warn "bar" => Int +bar = foo 42 + +baz :: Int +baz = bar diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index eeabfd711c..e9f3d84ebd 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -152,8 +152,10 @@ entails SolverOptions{..} constraint context hints = solve constraint where forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict] - forClassName _ C.Warn [msg] = - [TypeClassDictionaryInScope (WarnInstance msg) [] C.Warn [msg] Nothing] + forClassName ctx cn@C.Warn [msg] = + -- Prefer a warning dictionary in scope if there is one available. + -- This allows us to defer a warning by propagating the constraint. + findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope (WarnInstance msg) [] C.Warn [msg] Nothing] forClassName _ C.IsSymbol [TypeLevelString sym] = [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing] forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = From 5c0413569d75a7e0ab623777d71aad350525fe0b Mon Sep 17 00:00:00 2001 From: Vincent Orr Date: Fri, 14 Apr 2017 21:38:59 +0100 Subject: [PATCH 0760/1580] purs cmd-line help messages plualized module path (#2840) --- CONTRIBUTORS.md | 1 + app/Command/REPL.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 77f2af8c58..62d2cd2ce4 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -31,6 +31,7 @@ If you would prefer to use different terms, please use the section below instead | [@bsermons](https://github.com/bsermons) | Brian Sermons | [MIT license](http://opensource.org/licenses/MIT) | | [@cdepillabout](https://github.com/cdepillabout) | Dennis Gosnell | [MIT license](http://opensource.org/licenses/MIT) | | [@chrisdone](https://github.com/chrisdone) | Chris Done | MIT license | +| [@cmdv](https://github.com/cmdv) | Vincent Orr | MIT license | | [@codedmart](https://github.com/codedmart) | Brandon Martin | [MIT license](http://opensource.org/licenses/MIT) | | [@davidchambers](https://github.com/davidchambers) | David Chambers | [MIT license](http://opensource.org/licenses/MIT) | | [@DavidLindbom](https://github.com/DavidLindbom) | David Lindbom | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 24132b7278..bb2e49318f 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -62,7 +62,7 @@ data PSCiOptions = PSCiOptions inputFile :: Opts.Parser FilePath inputFile = Opts.strArgument $ - Opts.metavar "FILE" + Opts.metavar "FILES" <> Opts.help "Optional .purs files to load on start" nodePathOption :: Opts.Parser (Maybe FilePath) From 1a157f85693dee37df7dbd26d6ad8ffd66305e14 Mon Sep 17 00:00:00 2001 From: Thor Adam Date: Sat, 15 Apr 2017 20:01:59 +0200 Subject: [PATCH 0761/1580] Update CONTRIBUTING.md for "new contributor" label (#2844) --- CONTRIBUTING.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index f935b7a7f7..c76781e699 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -4,7 +4,7 @@ Pull requests are encouraged. ## Finding Issues to Work On -If you would like to contribute, please consider the issues in the current milestone first. If you are a new contributor, you may want to have a go at the ["easy" issues](https://github.com/purescript/purescript/labels/easy) to get started. +If you would like to contribute, please consider the issues in the current milestone first. If you are a new contributor, you may want to have a go at the ["new contributor" issues](https://github.com/purescript/purescript/labels/new%20contributor) to get started. ## Pull Requests From d96a14d2ae95c38bd705c18484d8830b4ceb0c44 Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Sat, 15 Apr 2017 19:12:39 +0100 Subject: [PATCH 0762/1580] remove newline from printed custom type errors (#2836) * remove newline from printed custom type errors fixes #2827 * simplify custom type error rendering --- src/Language/PureScript/Errors.hs | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index d0ca60dd60..8d94d1db56 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -21,7 +21,6 @@ import Data.Functor.Identity (Identity(..)) import Data.List (transpose, nubBy, sortBy, partition, dropWhileEnd) import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import Data.Ord (comparing) -import Data.String (fromString) import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text) @@ -34,7 +33,7 @@ import Language.PureScript.Label (Label(..)) import Language.PureScript.Names import Language.PureScript.Pretty import Language.PureScript.Pretty.Common (endWith) -import Language.PureScript.PSString (PSString, decodeStringWithReplacement) +import Language.PureScript.PSString (decodeStringWithReplacement) import Language.PureScript.Traversals import Language.PureScript.Types import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers @@ -1313,15 +1312,14 @@ renderBox = unlines whiteSpace = all isSpace toTypelevelString :: Type -> Maybe Box.Box -toTypelevelString t = (Box.text . decodeStringWithReplacement) <$> toTypelevelString' t - where - toTypelevelString' :: Type -> Maybe PSString - toTypelevelString' (TypeLevelString s) = Just s - toTypelevelString' (TypeApp (TypeConstructor f) x) - | f == primName "TypeString" = Just $ fromString $ prettyPrintType x - toTypelevelString' (TypeApp (TypeApp (TypeConstructor f) x) ret) - | f == primName "TypeConcat" = toTypelevelString' x <> toTypelevelString' ret - toTypelevelString' _ = Nothing +toTypelevelString (TypeLevelString s) = + Just . Box.text $ decodeStringWithReplacement s +toTypelevelString (TypeApp (TypeConstructor f) x) + | f == primName "TypeString" = Just (typeAsBox x) +toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret) + | f == primName "TypeConcat" = + (Box.<>) <$> toTypelevelString x <*> toTypelevelString ret +toTypelevelString _ = Nothing -- | Rethrow an error with a more detailed error message in the case of failure rethrow :: (MonadError e m) => (e -> e) -> m a -> m a From d3b1e0e4a6f9601dfe572cf41d01f1d7275e0cad Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Sat, 15 Apr 2017 19:23:06 +0100 Subject: [PATCH 0763/1580] TCO simplification (#2831) * TCO simplification part 1 Merge use of redundant `x` and `__tco_x` variables. * TCO simplification part 2 Rewrite references to inner function parameters. --- .../PureScript/CoreImp/Optimizer/TCO.hs | 25 +++++++++---------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index f27a843c2b..ab7a69decc 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -7,6 +7,7 @@ import Data.Text (Text) import Data.Monoid ((<>)) import Language.PureScript.CoreImp.AST import Language.PureScript.AST.SourcePos (SourceSpan) +import Safe (headDef, tailSafe) -- | Eliminate tail calls tco :: AST -> AST @@ -29,10 +30,11 @@ tco = everywhere convert where convert :: AST -> AST convert (VariableIntroduction ss name (Just fn@Function {})) | isTailRecursive name body' - = VariableIntroduction ss name (Just (replace (toLoop name allArgs body'))) + = VariableIntroduction ss name (Just (replace (toLoop name outerArgs innerArgs body'))) where + innerArgs = headDef [] argss + outerArgs = concat . reverse $ tailSafe argss (argss, body', replace) = collectAllFunctionArgs [] id fn - allArgs = concat $ reverse argss convert js = js collectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST) @@ -79,21 +81,16 @@ tco = everywhere convert where allInTailPosition _ = False - toLoop :: Text -> [Text] -> AST -> AST - toLoop ident allArgs js = + toLoop :: Text -> [Text] -> [Text] -> AST -> AST + toLoop ident outerArgs innerArgs js = Block rootSS $ - map (\arg -> VariableIntroduction rootSS arg (Just (Var rootSS (copyVar arg)))) allArgs ++ + map (\arg -> VariableIntroduction rootSS (tcoVar arg) (Just (Var rootSS (copyVar arg)))) outerArgs ++ [ VariableIntroduction rootSS tcoDone (Just (BooleanLiteral rootSS False)) , VariableIntroduction rootSS tcoResult Nothing - ] ++ - map (\arg -> - VariableIntroduction rootSS (tcoVar arg) Nothing) allArgs ++ - [ Function rootSS (Just tcoLoop) allArgs (Block rootSS [loopify js]) + , Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]) , While rootSS (Unary rootSS Not (Var rootSS tcoDone)) (Block rootSS - (Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) (map (Var rootSS) allArgs)) - : map (\arg -> - Assignment rootSS (Var rootSS arg) (Var rootSS (tcoVar arg))) allArgs)) + [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))]) , Return rootSS (Var rootSS tcoResult) ] where @@ -107,7 +104,9 @@ tco = everywhere convert where in Block ss $ zipWith (\val arg -> - Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues allArgs + Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs + ++ zipWith (\val arg -> + Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs ++ [ ReturnNoResult ss ] | otherwise = Block ss [ markDone ss, Return ss ret ] loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ] From a6cba7bc68e3f9f550a0e9624405bccb4168bb4d Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Sat, 15 Apr 2017 19:52:52 +0100 Subject: [PATCH 0764/1580] switch core-tests to psc-package. fixes #2830 (#2845) --- .gitignore | 1 + core-tests/bower.json | 60 -------------------------------- core-tests/psc-package.json | 65 +++++++++++++++++++++++++++++++++++ core-tests/test-everything.sh | 16 +++++---- 4 files changed, 75 insertions(+), 67 deletions(-) delete mode 100644 core-tests/bower.json create mode 100644 core-tests/psc-package.json diff --git a/.gitignore b/.gitignore index 21d3d65b18..31f2849c06 100644 --- a/.gitignore +++ b/.gitignore @@ -18,3 +18,4 @@ output examples/docs/docs/ core-tests/full-core-docs.md .psc-ide-port +.psc-package/ diff --git a/core-tests/bower.json b/core-tests/bower.json deleted file mode 100644 index 253aaedcf2..0000000000 --- a/core-tests/bower.json +++ /dev/null @@ -1,60 +0,0 @@ -{ - "name": "core-tests", - "homepage": "https://github.com/purescript/purescript", - "authors": [ - "Phil Freeman " - ], - "ignore": [ - "**/.*", - "node_modules", - "bower_components", - "test", - "tests" - ], - "dependencies": { - "purescript-arrays": "#8c9ada5762", - "purescript-bifunctors": "#9e3b2864ce", - "purescript-console": "#db29da9aca", - "purescript-const": "#cf538a65d8", - "purescript-contravariant": "#9ae6d7c99c", - "purescript-control": "#97096c7e26", - "purescript-distributive": "#ba81c64ffd", - "purescript-eff": "#dbd6c4a415", - "purescript-either": "#54f4efd423", - "purescript-enums": "#9332412e52", - "purescript-exceptions": "#522a0cea50", - "purescript-exists": "#e828c8341e", - "purescript-foldable-traversable": "#df37787855", - "purescript-foreign": "#64890cbbdb", - "purescript-free": "#f8ab7c5f05", - "purescript-functions": "#e417541936", - "purescript-functor-coproducts": "#7654d9dea4", - "purescript-generics": "#d09cb16ca3", - "purescript-globals": "#113ee398be", - "purescript-graphs": "#0b7089afa2", - "purescript-identity": "#204ac5f46a", - "purescript-inject": "#3ae4880bad", - "purescript-integers": "#58d7605dd5", - "purescript-lazy": "#bf4b34d673", - "purescript-maps": "#d9e4c6599a", - "purescript-math": "#99797b6494", - "purescript-maybe": "#1b60a07038", - "purescript-monoid": "#a8c8bb9d73", - "purescript-parallel": "#c7296ab008", - "purescript-prelude": "#318ee857bd", - "purescript-profunctor": "#a649126cea", - "purescript-proxy": "#c494b11bd7", - "purescript-quickcheck": "#4a15c93f12", - "purescript-random": "#68314c21e2", - "purescript-refs": "#f47e1059a3", - "purescript-semirings": "#c40efda15f", - "purescript-sets": "#1eaabf177f", - "purescript-st": "#077d9a2d7e", - "purescript-strings": "#87dd5f1694", - "purescript-tailrec": "#3c11db00ba", - "purescript-transformers": "#2d0a471ce4", - "purescript-tuples": "#4fe689ef93", - "purescript-unfoldable": "#e2382f30d8", - "purescript-validation": "#f43ff0fbdd" - } -} diff --git a/core-tests/psc-package.json b/core-tests/psc-package.json new file mode 100644 index 0000000000..296a7aac3e --- /dev/null +++ b/core-tests/psc-package.json @@ -0,0 +1,65 @@ +{ + "name": "core-tests", + "set": "psc-0.11.3", + "source": "https://github.com/purescript/package-sets.git", + "depends": [ + "arrays", + "assert", + "bifunctors", + "catenable-lists", + "console", + "const", + "contravariant", + "control", + "datetime", + "distributive", + "eff", + "either", + "enums", + "exceptions", + "exists", + "foldable-traversable", + "foreign", + "free", + "functions", + "functors", + "gen", + "generics", + "generics-rep", + "globals", + "graphs", + "identity", + "inject", + "integers", + "invariant", + "lazy", + "maps", + "math", + "maybe", + "monoid", + "newtype", + "nonempty", + "orders", + "partial", + "parallel", + "prelude", + "profunctor", + "proxy", + "psci-support", + "quickcheck", + "random", + "refs", + "semirings", + "sets", + "st", + "strings", + "tailrec", + "transformers", + "tuples", + "typelevel-prelude", + "type-equality", + "unfoldable", + "unsafe-coerce", + "validation" + ] +} diff --git a/core-tests/test-everything.sh b/core-tests/test-everything.sh index 48bb827619..848a41c7bd 100755 --- a/core-tests/test-everything.sh +++ b/core-tests/test-everything.sh @@ -1,6 +1,9 @@ #!/usr/bin/env bash -set -e +# exit on error +set -o errexit +# needed for using $(psc-package sources) +set -o noglob force_recompile='false' force_reinstall='false' @@ -13,21 +16,20 @@ while getopts 'ci' flag; do esac done -if [ "$force_reinstall" = "true" ] && [ -d "bower_components" ]; then +if [ "$force_reinstall" = "true" ] && [ -d ".psc-package" ]; then echo "Reinstalling core packages..." - rm -r bower_components + rm -rf .psc-package fi -# todo : fix this once core libraries reach 1.0 -yes 1 | bower i +psc-package update if [ "$force_recompile" = "true" ] && [ -d "output" ]; then echo "Recompiling..." rm -r output fi -stack exec purs compile 'tests/**/*.purs' 'bower_components/purescript-*/src/**/*.purs' +stack exec purs compile tests/**/*.purs $(psc-package sources) -stack exec purs docs 'bower_components/purescript-*/src/**/*.purs' > core-docs.md +stack exec purs docs $(psc-package sources) > core-docs.md NODE_PATH=output node -e "require('Test.Main').main()" From 6d9fc1331e79af3ad83d4736ea01697b43a809e6 Mon Sep 17 00:00:00 2001 From: Simon Yang Date: Mon, 17 Apr 2017 01:58:38 +0900 Subject: [PATCH 0765/1580] Adding -h/--help to `ide` subcommands (#2841) * Adding -h/--help to ide subcommands * Adding to CONTRIBUTORS.md --- CONTRIBUTORS.md | 1 + app/Command/Ide.hs | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 62d2cd2ce4..ee59195b5b 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -88,6 +88,7 @@ If you would prefer to use different terms, please use the section below instead | [@sebastiaanvisser](https://github.com/sebastiaanvisser) | Sebastiaan Visser | MIT license | | [@senju](https://github.com/senju) | senju | [MIT license](http://opensource.org/licenses/MIT) | | [@seungha-kim](https://github.com/seungha-kim) | Seungha Kim | [MIT license](http://opensource.org/licenses/MIT) | +| [@simonyangme](https://github.com/simonyangme) | Simon Yang | [MIT license](http://opensource.org/licenses/MIT) | | [@sharkdp](https://github.com/sharkdp) | David Peter | [MIT license](http://opensource.org/licenses/MIT) | | [@soupi](https://github.com/soupi) | Gil Mizrahi | [MIT license](http://opensource.org/licenses/MIT) | | [@sztupi](https://github.com/sztupi) | Attila Sztupak | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index 70fbb7d730..59780de293 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -80,10 +80,10 @@ command = Opts.helper <*> subcommands where subcommands :: Opts.Parser (IO ()) subcommands = (Opts.subparser . fold) [ Opts.command "server" - (Opts.info (fmap server serverOptions) + (Opts.info (fmap server serverOptions <**> Opts.helper) (Opts.progDesc "Start a server process")) , Opts.command "client" - (Opts.info (fmap client clientOptions) + (Opts.info (fmap client clientOptions <**> Opts.helper) (Opts.progDesc "Connect to a running server")) ] From ee16457b78d960f54057a9e23089364ef8de09fe Mon Sep 17 00:00:00 2001 From: Thor Adam Date: Mon, 17 Apr 2017 19:28:35 +0200 Subject: [PATCH 0766/1580] Row TypesDoNotUnify, don't assume unique labels, fix #2820 (#2843) * Row TypesDoNotUnify, don't assume unique labels, fix #2820 * Update CONTRIBUTORS.md --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Errors.hs | 17 ++++++----------- 2 files changed, 7 insertions(+), 11 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index ee59195b5b..b81f07fa4e 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -95,6 +95,7 @@ If you would prefer to use different terms, please use the section below instead | [@taktoa](https://github.com/taktoa) | Remy Goldschmidt | [MIT license](http://opensource.org/licenses/MIT) | | [@taku0](https://github.com/taku0) | taku0 | [MIT license](http://opensource.org/licenses/MIT) | | [@tfausak](https://github.com/tfausak) | Taylor Fausak | [MIT license](http://opensource.org/licenses/MIT) | +| [@thoradam](https://github.com/thoradam) | Thor Adam | [MIT license](http://opensource.org/licenses/MIT) | | [@tmcgilchrist](https://github.com/tmcgilchrist) | Tim McGilchrist | [MIT license](http://opensource.org/licenses/MIT) | | [@trofi](https://github.com/trofi) | Sergei Trofimovich | [MIT license](http://opensource.org/licenses/MIT) | | [@utkarshkukreti](https://github.com/utkarshkukreti) | Utkarsh Kukreti | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8d94d1db56..1314b7a7fb 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -18,9 +18,8 @@ import Data.Char (isSpace) import Data.Either (partitionEithers) import Data.Foldable (fold) import Data.Functor.Identity (Identity(..)) -import Data.List (transpose, nubBy, sortBy, partition, dropWhileEnd) +import Data.List (transpose, nubBy, sort, partition, dropWhileEnd) import Data.Maybe (maybeToList, fromMaybe, mapMaybe) -import Data.Ord (comparing) import qualified Data.Map as M import qualified Data.Text as T import Data.Text (Text) @@ -566,15 +565,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS -- Put the common labels last sortRows' :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> (Type, Type) sortRows' (s1, r1) (s2, r2) = - let common :: [(Label, (Type, Type))] - common = sortBy (comparing fst) [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ] - - sd1, sd2 :: [(Label, Type)] - sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] - sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] - in ( rowFromList (sortBy (comparing fst) sd1 ++ map (fst &&& fst . snd) common, r1) - , rowFromList (sortBy (comparing fst) sd2 ++ map (fst &&& snd . snd) common, r2) - ) + let (common1, unique1) = partition (flip elem s2) s1 + (common2, unique2) = partition (flip elem s1) s2 + in ( rowFromList (sort unique1 ++ sort common1, r1) + , rowFromList (sort unique2 ++ sort common2, r2) + ) in paras [ line "Could not match type" , markCodeBox $ indent $ typeAsBox sorted1 , line "with type" From ee347b9a528e14490f3d03dd8be3d6781ae078fd Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Mon, 17 Apr 2017 18:57:13 +0100 Subject: [PATCH 0767/1580] display help text by default (#2851) When `purs` is invoked with no command line arguments, this change shows the help text. --- app/Main.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 6e4b60d7f4..dcc4a5e578 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -17,6 +17,7 @@ import qualified Command.REPL as REPL import Data.Foldable (fold) import Data.Monoid ((<>)) import qualified Options.Applicative as Opts +import System.Environment (getArgs) import qualified System.IO as IO import Version (versionString) @@ -25,7 +26,7 @@ main :: IO () main = do IO.hSetEncoding IO.stdout IO.utf8 IO.hSetEncoding IO.stderr IO.utf8 - cmd <- Opts.execParser opts + cmd <- Opts.handleParseResult . execParserPure opts =<< getArgs cmd where opts = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList @@ -33,6 +34,12 @@ main = do headerInfo = Opts.progDesc "The PureScript compiler and tools" footerInfo = Opts.footer $ "purs " ++ versionString + -- | Displays full command help when invoked with no arguments. + execParserPure :: Opts.ParserInfo a -> [String] -> Opts.ParserResult a + execParserPure pinfo [] = Opts.Failure $ + Opts.parserFailure Opts.defaultPrefs pinfo Opts.ShowHelpText mempty + execParserPure pinfo args = Opts.execParserPure Opts.defaultPrefs pinfo args + versionInfo :: Opts.Parser (a -> a) versionInfo = Opts.abortOption (Opts.InfoMsg versionString) $ Opts.long "version" <> Opts.help "Show the version number" <> Opts.hidden From 7202173fd51471ac12cafd1eb2aba40095837523 Mon Sep 17 00:00:00 2001 From: Phillip Freeman Date: Mon, 17 Apr 2017 11:02:19 -0700 Subject: [PATCH 0768/1580] 0.11.4 --- package.yaml | 2 +- purescript.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index 3639ad3431..75eabe2370 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.11.3' +version: '0.11.4' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. diff --git a/purescript.cabal b/purescript.cabal index 8550355543..067cc28b9a 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: purescript -version: 0.11.3 +version: 0.11.4 cabal-version: >= 1.10 build-type: Simple license: BSD3 From 82f11440e5946c27aadc5b01b8a241803cce9e3b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 17 Apr 2017 11:03:19 -0700 Subject: [PATCH 0769/1580] Turn off coveralls upload for now (#2852) --- .travis.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index 4f00ebe210..6280647644 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,10 +20,10 @@ matrix: sudo: required env: BUILD_TYPE=normal - - os: linux - dist: trusty - sudo: required - env: BUILD_TYPE=sdist COVERAGE=true + # - os: linux + # dist: trusty + # sudo: required + # env: BUILD_TYPE=sdist COVERAGE=true - os: linux dist: trusty From d5732af2a261e89424e8abada494b3ff54597f9a Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 17 Apr 2017 19:04:19 +0100 Subject: [PATCH 0770/1580] [purs ide] Reads files in TextMode for adding imports (#2850) The functions provided in System.IO.UTF8 use ByteString's readFile, which uses https://hackage.haskell.org/package/base-4.9.1.0/docs/System-IO.html#v:openBinaryFile under the hood, which in turn causes trouble when we treat source files as text on Windows. --- purescript.cabal | 2 ++ src/Language/PureScript/Ide/Imports.hs | 2 +- src/Language/PureScript/Ide/Util.hs | 23 ++++++++++++++++++++--- 3 files changed, 23 insertions(+), 4 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index 067cc28b9a..b11f327975 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -586,6 +586,8 @@ extra-source-files: examples/warning/2411.purs examples/warning/2542.purs examples/warning/CustomWarning.purs + examples/warning/CustomWarning2.purs + examples/warning/CustomWarning3.purs examples/warning/DuplicateExportRef.purs examples/warning/DuplicateImport.purs examples/warning/DuplicateImportRef.purs diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index ba183152fb..fd1494672a 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -85,7 +85,7 @@ parseImportsFromFile file = do parseImportsFromFile' :: (MonadIO m, MonadError IdeError m) => FilePath -> m (P.ModuleName, [Text], [Import], [Text]) parseImportsFromFile' fp = do - file <- ideReadFile fp + file <- ideReadTextFile fp case sliceImportSection (T.lines file) of Right res -> pure res Left err -> throwError (GeneralError err) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index c96b7452b6..0d8bee97b8 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -28,6 +28,7 @@ module Language.PureScript.Ide.Util , identT , opNameT , ideReadFile + , ideReadTextFile , module Language.PureScript.Ide.Logging ) where @@ -37,6 +38,7 @@ import Protolude hiding (decodeUtf8, import Control.Lens hiding ((&), op) import Data.Aeson import qualified Data.Text as T +import qualified Data.Text.IO as TIO import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) import qualified Language.PureScript as P @@ -129,10 +131,25 @@ identT = iso P.runIdent P.Ident opNameT :: Iso' (P.OpName a) Text opNameT = iso P.runOpName P.OpName -ideReadFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text -ideReadFile fp = do - contents :: Either IOException Text <- liftIO (try (readUTF8FileT fp)) +ideReadFile' + :: (MonadIO m, MonadError IdeError m) + => (FilePath -> IO Text) + -> FilePath + -> m Text +ideReadFile' fileReader fp = do + contents :: Either IOException Text <- liftIO (try (fileReader fp)) either (\_ -> throwError (GeneralError ("Couldn't find file at: " <> T.pack fp))) pure contents + +ideReadFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text +ideReadFile = ideReadFile' readUTF8FileT + +-- | This function is to be used over @ideReadFile@ when the result is not just +-- passed on to the PureScript parser, but also needs to be treated as lines of +-- text. Because @ideReadFile@ reads the file as ByteString in @BinaryMode@ +-- rather than @TextMode@ line endings get mangled on Windows otherwise. This is +-- irrelevant for parsing, because the Lexer strips these additional @\r@'s. +ideReadTextFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text +ideReadTextFile = ideReadFile' TIO.readFile From a6aabb8bff22238e14f2daff95502c9c533e1d60 Mon Sep 17 00:00:00 2001 From: Sean Westfall Date: Tue, 18 Apr 2017 22:38:45 -0700 Subject: [PATCH 0771/1580] small fix for the copyright dates (#2849) --- package.yaml | 2 +- purescript.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index 75eabe2370..a260b2d149 100644 --- a/package.yaml +++ b/package.yaml @@ -11,7 +11,7 @@ author: > Harry Garrood , Christoph Hegemann maintainer: Phil Freeman -copyright: (c) 2013-16 Phil Freeman, (c) 2014-16 Gary Burgess +copyright: (c) 2013-17 Phil Freeman, (c) 2014-17 Gary Burgess license: BSD3 github: purescript/purescript.git homepage: http://www.purescript.org/ diff --git a/purescript.cabal b/purescript.cabal index b11f327975..bf1efd6fa6 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -8,7 +8,7 @@ cabal-version: >= 1.10 build-type: Simple license: BSD3 license-file: LICENSE -copyright: (c) 2013-16 Phil Freeman, (c) 2014-16 Gary Burgess +copyright: (c) 2013-17 Phil Freeman, (c) 2014-17 Gary Burgess maintainer: Phil Freeman stability: experimental homepage: http://www.purescript.org/ From d1272d51d20ba404a76a292b51b71c807a4a98e9 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 19 Apr 2017 16:32:49 +0800 Subject: [PATCH 0772/1580] Update package.yaml (#2854) Currently the bug tracker URL is broken on Hackage. This change fixes this. --- package.yaml | 2 +- purescript.cabal | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/package.yaml b/package.yaml index a260b2d149..6c4a8905d4 100644 --- a/package.yaml +++ b/package.yaml @@ -13,7 +13,7 @@ author: > maintainer: Phil Freeman copyright: (c) 2013-17 Phil Freeman, (c) 2014-17 Gary Burgess license: BSD3 -github: purescript/purescript.git +github: purescript/purescript homepage: http://www.purescript.org/ extra-source-files: - examples/**/*.js diff --git a/purescript.cabal b/purescript.cabal index bf1efd6fa6..fc52b0c1df 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -12,7 +12,7 @@ copyright: (c) 2013-17 Phil Freeman, (c) 2014-17 Gary Burgess maintainer: Phil Freeman stability: experimental homepage: http://www.purescript.org/ -bug-reports: https://github.com/purescript/purescript.git/issues +bug-reports: https://github.com/purescript/purescript/issues synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language @@ -638,7 +638,7 @@ extra-source-files: source-repository head type: git - location: https://github.com/purescript/purescript.git + location: https://github.com/purescript/purescript flag release description: Mark this build as a release build: prevents inclusion of extra info e.g. commit SHA in --version output) From 2ffb4c8466e025f54699755dd7fbc21872bafdbb Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 19 Apr 2017 20:31:55 +0200 Subject: [PATCH 0773/1580] [purs ide] Fixes the import command for kinds (#2858) They were mistakenly generated as value references. --- src/Language/PureScript/Ide/Imports.hs | 2 ++ tests/Language/PureScript/Ide/ImportsSpec.hs | 8 ++++++++ 2 files changed, 10 insertions(+) diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index fd1494672a..84beedd07e 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -203,6 +203,8 @@ addExplicitImport' decl moduleName imports = P.ValueOpRef (op ^. ideValueOpName) refFromDeclaration (IdeDeclTypeOperator op) = P.TypeOpRef (op ^. ideTypeOpName) + refFromDeclaration (IdeDeclKind kn) = + P.KindRef kn refFromDeclaration d = P.ValueRef (P.Ident (identifierFromIdeDeclaration d)) diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index bb67e7db12..0cedd51b5d 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -108,6 +108,8 @@ spec = do prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideDtor i t Nothing)) mn is) addTypeImport i mn is = prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideType i Nothing)) mn is) + addKindImport i mn is = + prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideKind i)) mn is) it "adds an implicit unqualified import to a file without any imports" $ shouldBe (addImplicitImport' [] (P.moduleNameFromString "Data.Map")) @@ -139,6 +141,12 @@ spec = do [ "import Prelude" , "import Data.Array (head, tail)" ] + it "adds a kind to an explicit import list" $ + shouldBe + (addKindImport "Effect" (P.moduleNameFromString "Control.Monad.Eff") simpleFileImports) + [ "import Prelude" + , "import Control.Monad.Eff (kind Effect)" + ] it "adds an operator to an explicit import list" $ shouldBe (addOpImport "<~>" (P.moduleNameFromString "Data.Array") explicitImports) From 0243721f5692d0f58ee9fdbb2616f820a1c65171 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Thu, 20 Apr 2017 04:43:33 +0200 Subject: [PATCH 0774/1580] Bumps lower bound for directory (#2857) fixes #2856 --- package.yaml | 2 +- purescript.cabal | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/package.yaml b/package.yaml index 6c4a8905d4..d072331c35 100644 --- a/package.yaml +++ b/package.yaml @@ -46,7 +46,7 @@ dependencies: - containers - data-ordlist >=0.4.7.0 - deepseq - - directory >=1.2 + - directory >=1.2.3 - dlist - edit-distance - filepath diff --git a/purescript.cabal b/purescript.cabal index fc52b0c1df..f97f0ae03c 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -662,7 +662,7 @@ library , containers , data-ordlist >=0.4.7.0 , deepseq - , directory >=1.2 + , directory >=1.2.3 , dlist , edit-distance , filepath @@ -870,7 +870,7 @@ executable purs , containers , data-ordlist >=0.4.7.0 , deepseq - , directory >=1.2 + , directory >=1.2.3 , dlist , edit-distance , filepath @@ -958,7 +958,7 @@ test-suite tests , containers , data-ordlist >=0.4.7.0 , deepseq - , directory >=1.2 + , directory >=1.2.3 , dlist , edit-distance , filepath From aafab7f027b4fde81dfc04da63978b14f6c6754d Mon Sep 17 00:00:00 2001 From: tslawler Date: Sat, 22 Apr 2017 18:09:32 -0400 Subject: [PATCH 0775/1580] Fix kind signature for RowCons typeClassData (#2859) I haven't looked too deeply into the compiler, but decided to take a peek at the new RowCons and Union stuff -- noticed this seemed a bit off. --- src/Language/PureScript/Environment.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 7d114435be..2a22a1b7fd 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -377,9 +377,9 @@ primClasses = -- class RowCons (l :: Symbol) (a :: Type) (i :: # Type) (o :: # Type) | l i a -> o, l o -> a i , (primName "RowCons", (makeTypeClassData [ ("l", Just kindSymbol) - , ("a", Just (Row kindType)) - , ("i", Just kindType) - , ("o", Just kindType) + , ("a", Just kindType) + , ("i", Just (Row kindType)) + , ("o", Just (Row kindType)) ] [] [] [ FunctionalDependency [0, 1, 2] [3] , FunctionalDependency [0, 3] [1, 2] From ac57b5d74a0086c48d377c28a6912c2cb6359f6a Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 23 Apr 2017 15:19:36 -0700 Subject: [PATCH 0776/1580] Desugar let properly when generating docs, fix #2861 (#2863) --- examples/docs/src/Desugar.purs | 8 ++++++++ purescript.cabal | 1 + src/Language/PureScript/Docs/Convert.hs | 5 +++-- tests/TestDocs.hs | 4 ++++ 4 files changed, 16 insertions(+), 2 deletions(-) create mode 100644 examples/docs/src/Desugar.purs diff --git a/examples/docs/src/Desugar.purs b/examples/docs/src/Desugar.purs new file mode 100644 index 0000000000..cc6061ae76 --- /dev/null +++ b/examples/docs/src/Desugar.purs @@ -0,0 +1,8 @@ +module Desugar where + +data X a b = X a b + +test :: forall a b. X (a -> b) a -> b +test x = + let X a b = x + in a b diff --git a/purescript.cabal b/purescript.cabal index f97f0ae03c..87a942f2f0 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -35,6 +35,7 @@ extra-source-files: examples/docs/src/Clash2.purs examples/docs/src/Clash2a.purs examples/docs/src/ConstrainedArgument.purs + examples/docs/src/DesugarLet.purs examples/docs/src/DocComments.purs examples/docs/src/DuplicateNames.purs examples/docs/src/Example.purs diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index a564e0ae97..8aaf43ce6b 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -58,7 +58,7 @@ convertModulesInPackageWithEnv modules modulesDeps = Nothing -> Local mn isLocal :: P.ModuleName -> Bool - isLocal = not . flip Map.member modulesDeps + isLocal = not . flip Map.member modulesDeps -- | -- Convert a group of modules to the intermediate format, designed for @@ -208,7 +208,8 @@ partiallyDesugar = P.evalSupplyT 0 . desugar' where desugar' = traverse P.desugarDoModule - >=> traverse P.desugarCasesModule + >=> map P.desugarLetPatternModule + >>> traverse P.desugarCasesModule >=> traverse P.desugarTypeDeclarationsModule >=> ignoreWarnings . P.desugarImportsWithEnv [] diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 788ef881eb..0237bfee8f 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -402,6 +402,10 @@ testCases = , ("TypeLevelString", [ ShouldBeDocumented (n "TypeLevelString") "Foo" ["fooBar"] ]) + + , ("Desugar", + [ ValueShouldHaveTypeSignature (n "Desugar") "test" (renderedType "forall a b. X (a -> b) a -> b") + ]) ] where From 6523d1c40c152af29a27de6447e47a48215ed3cd Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 1 May 2017 00:43:51 +0200 Subject: [PATCH 0777/1580] Apply relative paths during pretty printing of errors (#2867) * apply relative paths during pretty printing of errors * bumps test dependency and fixes psci tests --- app/Command/Compile.hs | 7 +++-- app/Command/REPL.hs | 4 ++- src/Language/PureScript/AST/SourcePos.hs | 7 ++--- src/Language/PureScript/Errors.hs | 26 ++++++++++--------- src/Language/PureScript/Errors/JSON.hs | 2 +- src/Language/PureScript/Ide/Rebuild.hs | 5 +--- src/Language/PureScript/Ide/SourceFile.hs | 5 +--- src/Language/PureScript/Interactive.hs | 5 +++- src/Language/PureScript/Interactive/Module.hs | 4 +-- tests/TestPsci/CompletionTest.hs | 8 +++--- tests/TestUtils.hs | 12 +++++++++ tests/support/bower.json | 2 +- 12 files changed, 50 insertions(+), 37 deletions(-) diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 04c9520a93..b5baa59961 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -22,7 +22,6 @@ import qualified Options.Applicative as Opts import qualified System.Console.ANSI as ANSI import System.Exit (exitSuccess, exitFailure) import System.Directory (getCurrentDirectory) -import System.FilePath (makeRelative) import System.FilePath.Glob (glob) import System.IO (hPutStr, hPutStrLn, stderr) import System.IO.UTF8 (readUTF8FileT) @@ -38,8 +37,9 @@ data PSCMakeOptions = PSCMakeOptions -- | Argumnets: verbose, use JSON, warnings, errors printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO () printWarningsAndErrors verbose False warnings errors = do + pwd <- getCurrentDirectory cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stderr - let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose } + let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose, P.ppeRelativeDirectory = pwd } when (P.nonEmpty warnings) $ hPutStrLn stderr (P.prettyPrintMultipleWarnings ppeOpts warnings) case errors of @@ -55,7 +55,6 @@ printWarningsAndErrors verbose True warnings errors = do compile :: PSCMakeOptions -> IO () compile PSCMakeOptions{..} = do - pwd <- getCurrentDirectory input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput when (null input && not pscmJSONErrors) $ do hPutStr stderr $ unlines [ "purs compile: No input files." @@ -64,7 +63,7 @@ compile PSCMakeOptions{..} = do exitFailure moduleFiles <- readInput input (makeErrors, makeWarnings) <- runMake pscmOpts $ do - ms <- P.parseModulesFromFiles (makeRelative pwd) moduleFiles + ms <- P.parseModulesFromFiles id moduleFiles let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, Right fp)) ms foreigns <- inferForeignModules filePathMap let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index bb2e49318f..5e29a1af5f 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -323,7 +323,9 @@ command = loop <$> options case psciBackend of Backend setup eval reload (shutdown :: state -> IO ()) -> case e of - Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure + Left errs -> do + pwd <- getCurrentDirectory + putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd} errs) >> exitFailure Right (modules, externs, env) -> do historyFilename <- getHistoryFilename let settings = defaultSettings { historyFile = Just historyFilename } diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 4c6d571556..55bcc23985 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -13,6 +13,7 @@ import qualified Data.Aeson as A import Data.Monoid import qualified Data.Text as T import Data.Text (Text) +import System.FilePath (makeRelative) -- | -- Source position information @@ -65,9 +66,9 @@ displayStartEndPos sp = displaySourcePos (spanStart sp) <> " - " <> displaySourcePos (spanEnd sp) -displaySourceSpan :: SourceSpan -> Text -displaySourceSpan sp = - T.pack (spanName sp) <> " " <> +displaySourceSpan :: FilePath -> SourceSpan -> Text +displaySourceSpan relPath sp = + T.pack (makeRelative relPath (spanName sp)) <> " " <> displayStartEndPos sp instance A.ToJSON SourceSpan where diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 1314b7a7fb..3ff4bd5014 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -362,24 +362,26 @@ defaultCodeColor = (ANSI.Dull, ANSI.Yellow) -- | `prettyPrintSingleError` Options data PPEOptions = PPEOptions - { ppeCodeColor :: Maybe (ANSI.ColorIntensity, ANSI.Color) -- ^ Color code with this color... or not - , ppeFull :: Bool -- ^ Should write a full error message? - , ppeLevel :: Level -- ^ Should this report an error or a warning? - , ppeShowDocs :: Bool -- ^ Should show a link to error message's doc page? + { ppeCodeColor :: Maybe (ANSI.ColorIntensity, ANSI.Color) -- ^ Color code with this color... or not + , ppeFull :: Bool -- ^ Should write a full error message? + , ppeLevel :: Level -- ^ Should this report an error or a warning? + , ppeShowDocs :: Bool -- ^ Should show a link to error message's doc page? + , ppeRelativeDirectory :: FilePath -- ^ FilePath to which the errors are relative } -- | Default options for PPEOptions defaultPPEOptions :: PPEOptions defaultPPEOptions = PPEOptions - { ppeCodeColor = Just defaultCodeColor - , ppeFull = False - , ppeLevel = Error - , ppeShowDocs = True + { ppeCodeColor = Just defaultCodeColor + , ppeFull = False + , ppeLevel = Error + , ppeShowDocs = True + , ppeRelativeDirectory = mempty } -- | Pretty print a single error, simplifying if necessary prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box -prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalState defaultUnknownMap $ do +prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = flip evalState defaultUnknownMap $ do em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) um <- get return (prettyPrintErrorMessage um em) @@ -522,7 +524,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS line $ "Export for " <> printName new <> " conflicts with " <> runName existing renderSimpleErrorMessage (DuplicateModule mn ss) = paras [ line ("Module " <> markCode (runModuleName mn) <> " has been defined multiple times:") - , indent . paras $ map (line . displaySourceSpan) ss + , indent . paras $ map (line . displaySourceSpan relPath) ss ] renderSimpleErrorMessage (CycleInDeclaration nm) = line $ "The value of " <> markCode (showIdent nm) <> " is undefined here, so this reference is not allowed." @@ -551,7 +553,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS ] renderSimpleErrorMessage (EscapedSkolem name (Just srcSpan) ty) = paras [ line $ "The type variable " <> markCode name <> ", bound at" - , indent $ line $ displaySourceSpan srcSpan + , indent $ line $ displaySourceSpan relPath srcSpan , line "has escaped its scope, appearing in the type" , markCodeBox $ indent $ typeAsBox ty ] @@ -1053,7 +1055,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS ] ] renderHint (PositionedError srcSpan) detail = - paras [ line $ "at " <> displaySourceSpan srcSpan + paras [ line $ "at " <> displaySourceSpan relPath srcSpan , detail ] diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index c7f085cef1..d013235011 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -50,7 +50,7 @@ toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErro toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError toJSONError verbose level e = JSONError (toErrorPosition <$> sspan) - (P.renderBox (P.prettyPrintSingleError (P.PPEOptions Nothing verbose level False) (P.stripModuleAndSpan e))) + (P.renderBox (P.prettyPrintSingleError (P.PPEOptions Nothing verbose level False mempty) (P.stripModuleAndSpan e))) (P.errorCode e) (P.errorDocUri e) (P.spanName <$> sspan) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 2ad2cd8829..fb5b8ba73b 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -20,8 +20,6 @@ import Language.PureScript.Ide.Logging import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import System.Directory (getCurrentDirectory) -import System.FilePath (makeRelative) -- | Given a filepath performs the following steps: -- @@ -48,9 +46,8 @@ rebuildFile rebuildFile path runOpenBuild = do input <- ideReadFile path - pwd <- liftIO getCurrentDirectory - m <- case snd <$> P.parseModuleFromFile (makeRelative pwd) (path, input) of + m <- case snd <$> P.parseModuleFromFile identity (path, input) of Left parseError -> throwError (RebuildError (P.MultipleErrors [P.toPositionedError parseError])) Right m -> pure m diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index bad912f475..771598221b 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -27,17 +27,14 @@ import qualified Language.PureScript as P import Language.PureScript.Ide.Error import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import System.Directory (getCurrentDirectory) -import System.FilePath (makeRelative) parseModule :: (MonadIO m, MonadError IdeError m) => FilePath -> m (Either FilePath (FilePath, P.Module)) parseModule path = do - pwd <- liftIO getCurrentDirectory contents <- ideReadFile path - case P.parseModuleFromFile (makeRelative pwd) (path, contents) of + case P.parseModuleFromFile identity (path, contents) of Left _ -> pure (Left path) Right m -> pure (Right m) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index ce075fc9fb..9d91c24c5e 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -38,11 +38,14 @@ import Language.PureScript.Interactive.Parser as Interactive import Language.PureScript.Interactive.Printer as Interactive import Language.PureScript.Interactive.Types as Interactive +import System.Directory (getCurrentDirectory) import System.FilePath (()) -- | Pretty-print errors printErrors :: MonadIO m => P.MultipleErrors -> m () -printErrors = liftIO . putStrLn . P.prettyPrintMultipleErrors P.defaultPPEOptions +printErrors errs = liftIO $ do + pwd <- getCurrentDirectory + putStrLn $ P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd} errs -- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the -- options and ignores the warning messages. diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 34ac66cf2d..a69448af71 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -27,8 +27,8 @@ loadModule filename = do pwd <- getCurrentDirectory content <- readUTF8FileT filename return $ - either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions) (Right . map snd) $ - P.parseModulesFromFiles (makeRelative pwd) [(filename, content)] + either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd}) (Right . map snd) $ + P.parseModulesFromFiles id [(filename, content)] -- | Load all modules. loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)]) diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index 47f57cad30..35b05e6e15 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -32,12 +32,12 @@ completionTestData = , (":b", [":browse"]) -- :browse should complete module names - , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"]) - , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"]) + , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried"]) + , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console", ".Uncurried"]) -- import should complete module names - , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"]) - , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"]) + , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried"]) + , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console", ".Uncurried"]) -- :quit, :help, :reload, :clear should not complete , (":help ", []) diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 86a99f6d4e..cd1847e0ac 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -68,7 +68,11 @@ supportModules = , "Control.Monad.Eff" , "Control.Monad.Eff.Class" , "Control.Monad.Eff.Console" + , "Control.Monad.Eff.Uncurried" , "Control.Monad.Eff.Unsafe" + , "Control.Monad.Gen" + , "Control.Monad.Gen.Class" + , "Control.Monad.Gen.Common" , "Control.Monad.Rec.Class" , "Control.Monad.ST" , "Control.MonadPlus" @@ -92,6 +96,7 @@ supportModules = , "Data.BooleanAlgebra" , "Data.Bounded" , "Data.Char" + , "Data.Char.Gen" , "Data.CommutativeRing" , "Data.Either" , "Data.Either.Nested" @@ -113,6 +118,8 @@ supportModules = , "Data.Generic.Rep.Show" , "Data.HeytingAlgebra" , "Data.Identity" + , "Data.Int" + , "Data.Int.Bits" , "Data.Lazy" , "Data.List" , "Data.List.Lazy" @@ -145,6 +152,7 @@ supportModules = , "Data.Show" , "Data.String" , "Data.String.CaseInsensitive" + , "Data.String.Gen" , "Data.String.Regex" , "Data.String.Regex.Flags" , "Data.String.Regex.Unsafe" @@ -156,6 +164,9 @@ supportModules = , "Data.Unfoldable" , "Data.Unit" , "Data.Void" + , "Global" + , "Global.Unsafe" + , "Math" , "PSCI.Support" , "Partial" , "Partial.Unsafe" @@ -164,6 +175,7 @@ supportModules = , "Type.Data.Ordering" , "Type.Data.Symbol" , "Type.Equality" + , "Type.Row.Effect.Equality" , "Type.Prelude" , "Type.Proxy" , "Unsafe.Coerce" diff --git a/tests/support/bower.json b/tests/support/bower.json index bdee017fc7..6b67afd06a 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -4,7 +4,7 @@ "purescript-arrays": "4.0.0", "purescript-assert": "3.0.0", "purescript-console": "3.0.0", - "purescript-eff": "3.0.0", + "purescript-eff": "3.1.0", "purescript-functions": "3.0.0", "purescript-generics": "4.0.0", "purescript-generics-rep": "5.0.0", From 6f80816a3b80a6e9e3b7eec2b988598000f8bb6e Mon Sep 17 00:00:00 2001 From: Eoin Houlihan Date: Sat, 6 May 2017 21:45:35 +0100 Subject: [PATCH 0778/1580] Better variable naming hygiene in TCO. Fixes #2868 (#2875) --- CONTRIBUTORS.md | 1 + purescript.cabal | 2 +- src/Language/PureScript/CoreImp/Optimizer/TCO.hs | 10 +++++----- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index b81f07fa4e..1be6da569e 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -45,6 +45,7 @@ If you would prefer to use different terms, please use the section below instead | [@FrigoEU](https://github.com/FrigoEU) | Simon Van Casteren | [MIT license](http://opensource.org/licenses/MIT) | | [@garyb](https://github.com/garyb) | Gary Burgess | [MIT license](http://opensource.org/licenses/MIT) | | [@hdgarrood](https://github.com/hdgarrood) | Harry Garrood | [MIT license](http://opensource.org/licenses/MIT) | +| [@houli](https://github.com/houli) | Eoin Houlihan | [MIT license](http://opensource.org/licenses/MIT) | | [@ianbollinger](https://github.com/ianbollinger) | Ian D. Bollinger | [MIT license](http://opensource.org/licenses/MIT) | | [@ilovezfs](https://github.com/ilovezfs) | ilovezfs | MIT license | | [@izgzhen](https://github.com/izgzhen) | Zhen Zhang | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/purescript.cabal b/purescript.cabal index 87a942f2f0..49d2cd1f71 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -35,7 +35,7 @@ extra-source-files: examples/docs/src/Clash2.purs examples/docs/src/Clash2a.purs examples/docs/src/ConstrainedArgument.purs - examples/docs/src/DesugarLet.purs + examples/docs/src/Desugar.purs examples/docs/src/DocComments.purs examples/docs/src/DuplicateNames.purs examples/docs/src/Example.purs diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index ab7a69decc..0a5d949668 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -13,19 +13,19 @@ import Safe (headDef, tailSafe) tco :: AST -> AST tco = everywhere convert where tcoVar :: Text -> Text - tcoVar arg = "__tco_" <> arg + tcoVar arg = "$tco_var_" <> arg copyVar :: Text -> Text - copyVar arg = "__copy_" <> arg + copyVar arg = "$copy_" <> arg tcoDone :: Text - tcoDone = tcoVar "done" + tcoDone = "$tco_done" tcoLoop :: Text - tcoLoop = tcoVar "loop" + tcoLoop = "$tco_loop" tcoResult :: Text - tcoResult = tcoVar "result" + tcoResult = "$tco_result" convert :: AST -> AST convert (VariableIntroduction ss name (Just fn@Function {})) From 04a1e753a2dea4360a692a867b3111b2876b4e6f Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 8 May 2017 13:41:53 +0200 Subject: [PATCH 0779/1580] [purs ide] Decodes source files as UTF8 when parsing out the imports (#2876) The previous change to this used the default Text's readFile, which decodes as UTF16 and thus messed up unicode symbols when adding imports. Because reading files as ByteString doesn't convert \r\n into a single line feed, we need to do the conversion manually. --- src/Language/PureScript/Ide/Util.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 0d8bee97b8..a56471b02b 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -38,9 +38,8 @@ import Protolude hiding (decodeUtf8, import Control.Lens hiding ((&), op) import Data.Aeson import qualified Data.Text as T -import qualified Data.Text.IO as TIO import qualified Data.Text.Lazy as TL -import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) +import Data.Text.Lazy.Encoding as TLE import qualified Language.PureScript as P import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine, IdeError(..)) import Language.PureScript.Ide.Logging @@ -109,10 +108,10 @@ typeOperatorAliasT i = P.showQualified P.runProperName i encodeT :: (ToJSON a) => a -> Text -encodeT = TL.toStrict . decodeUtf8 . encode +encodeT = TL.toStrict . TLE.decodeUtf8 . encode decodeT :: (FromJSON a) => Text -> Maybe a -decodeT = decode . encodeUtf8 . TL.fromStrict +decodeT = decode . TLE.encodeUtf8 . TL.fromStrict unwrapPositioned :: P.Declaration -> P.Declaration unwrapPositioned (P.PositionedDeclaration _ _ x) = unwrapPositioned x @@ -148,8 +147,8 @@ ideReadFile = ideReadFile' readUTF8FileT -- | This function is to be used over @ideReadFile@ when the result is not just -- passed on to the PureScript parser, but also needs to be treated as lines of --- text. Because @ideReadFile@ reads the file as ByteString in @BinaryMode@ --- rather than @TextMode@ line endings get mangled on Windows otherwise. This is --- irrelevant for parsing, because the Lexer strips these additional @\r@'s. +-- Text. Because @ideReadFile@ reads the file as ByteString line endings get +-- mangled on Windows otherwise. This is irrelevant for parsing, because the +-- Lexer strips the additional @\r@s as whitespace. ideReadTextFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text -ideReadTextFile = ideReadFile' TIO.readFile +ideReadTextFile fp = T.replace "\r\n" "\n" <$> ideReadFile fp From 21bd77fb6bb42e3b8732d28b9aca2c25626a8307 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 10 May 2017 23:37:45 +0200 Subject: [PATCH 0780/1580] [purs ide] extract namespace adt (#2878) * consistent formatting * minor refactoring: Extracts an ADT for PS's different namespaces --- src/Language/PureScript/Ide/Filter.hs | 13 ++++++---- src/Language/PureScript/Ide/SourceFile.hs | 24 +++++++++---------- src/Language/PureScript/Ide/State.hs | 8 +++---- src/Language/PureScript/Ide/Types.hs | 15 ++++++------ .../Language/PureScript/Ide/SourceFileSpec.hs | 22 ++++++++--------- 5 files changed, 42 insertions(+), 40 deletions(-) diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index b15120c70c..28ed8c0d5f 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -26,11 +26,12 @@ import Protolude hiding (isPrefixOf) import Data.Aeson import Data.Text (isPrefixOf) -import qualified Language.PureScript as P import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import qualified Language.PureScript as P -newtype Filter = Filter (Endo [Module]) deriving(Monoid) +newtype Filter = Filter (Endo [Module]) + deriving (Monoid) type Module = (P.ModuleName, [IdeDeclarationAnn]) @@ -48,21 +49,23 @@ moduleFilter' moduleIdents = filter (flip elem moduleIdents . fst) -- | Only keeps Identifiers that start with the given prefix prefixFilter :: Text -> Filter prefixFilter "" = mkFilter identity -prefixFilter t = mkFilter $ identFilter prefix t +prefixFilter t = + mkFilter $ identFilter prefix t where prefix :: IdeDeclaration -> Text -> Bool prefix ed search = search `isPrefixOf` identifierFromIdeDeclaration ed -- | Only keeps Identifiers that are equal to the search string equalityFilter :: Text -> Filter -equalityFilter = mkFilter . identFilter equality +equalityFilter = + mkFilter . identFilter equality where equality :: IdeDeclaration -> Text -> Bool equality ed search = identifierFromIdeDeclaration ed == search identFilter :: (IdeDeclaration -> Text -> Bool) -> Text -> [Module] -> [Module] identFilter predicate search = - filter (not . null . snd) . fmap filterModuleDecls + filter (not . null . snd) . fmap filterModuleDecls where filterModuleDecls :: Module -> Module filterModuleDecls (moduleIdent, decls) = diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 771598221b..33b5dc90c4 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -64,30 +64,30 @@ extractSpans -- ^ The surrounding span -> P.Declaration -- ^ The declaration to extract spans from - -> [(IdeDeclNamespace, P.SourceSpan)] + -> [(IdeNamespaced, P.SourceSpan)] -- ^ Declarations and their source locations extractSpans ss d = case d of P.PositionedDeclaration ss' _ d' -> extractSpans ss' d' P.ValueDeclaration i _ _ _ -> - [(IdeNSValue (P.runIdent i), ss)] + [(IdeNamespaced IdeNSValue (P.runIdent i), ss)] P.TypeSynonymDeclaration name _ _ -> - [(IdeNSType (P.runProperName name), ss)] + [(IdeNamespaced IdeNSType (P.runProperName name), ss)] P.TypeClassDeclaration name _ _ _ members -> - (IdeNSType (P.runProperName name), ss) : concatMap (extractSpans' ss) members + (IdeNamespaced IdeNSType (P.runProperName name), ss) : concatMap (extractSpans' ss) members P.DataDeclaration _ name _ ctors -> - (IdeNSType (P.runProperName name), ss) - : map (\(cname, _) -> (IdeNSValue (P.runProperName cname), ss)) ctors + (IdeNamespaced IdeNSType (P.runProperName name), ss) + : map (\(cname, _) -> (IdeNamespaced IdeNSValue (P.runProperName cname), ss)) ctors P.FixityDeclaration (Left (P.ValueFixity _ _ opName)) -> - [(IdeNSValue (P.runOpName opName), ss)] + [(IdeNamespaced IdeNSValue (P.runOpName opName), ss)] P.FixityDeclaration (Right (P.TypeFixity _ _ opName)) -> - [(IdeNSType (P.runOpName opName), ss)] + [(IdeNamespaced IdeNSType (P.runOpName opName), ss)] P.ExternDeclaration ident _ -> - [(IdeNSValue (P.runIdent ident), ss)] + [(IdeNamespaced IdeNSValue (P.runIdent ident), ss)] P.ExternDataDeclaration name _ -> - [(IdeNSType (P.runProperName name), ss)] + [(IdeNamespaced IdeNSType (P.runProperName name), ss)] P.ExternKindDeclaration name -> - [(IdeNSKind (P.runProperName name), ss)] + [(IdeNamespaced IdeNSKind (P.runProperName name), ss)] _ -> [] where -- We need this special case to be able to also get the position info for @@ -98,5 +98,5 @@ extractSpans ss d = case d of P.PositionedDeclaration ssP' _ dP' -> extractSpans' ssP' dP' P.TypeDeclaration ident _ -> - [(IdeNSValue (P.runIdent ident), ssP)] + [(IdeNamespaced IdeNSValue (P.runIdent ident), ssP)] _ -> [] diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 4f6df708f4..19a47fc2f8 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -250,12 +250,12 @@ resolveLocationsForModule (defs, types) decls = IdeDeclKind i -> annotateKind (i ^. properNameT) (IdeDeclKind i) where - annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNSValue (P.runIdent x)) defs + annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs , _annTypeAnnotation = Map.lookup x types }) - annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSValue x) defs}) - annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSType x) defs}) - annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNSKind x) defs}) + annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) + annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs}) + annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSKind x) defs}) resolveInstances :: ModuleMap P.ExternsFile diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 332da88361..156bc68e21 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -119,7 +119,7 @@ makeLenses ''IdeDeclarationAnn emptyAnn :: Annotation emptyAnn = Annotation Nothing Nothing Nothing -type DefinitionSites a = Map IdeDeclNamespace a +type DefinitionSites a = Map IdeNamespaced a type TypeAnnotations = Map P.Ident P.Type newtype AstData a = AstData (ModuleMap (DefinitionSites a, TypeAnnotations)) -- ^ SourceSpans for the definition sites of Values and Types aswell as type @@ -305,11 +305,10 @@ instance ToJSON PursuitResponse where , "text" .= text ] -data IdeDeclNamespace = - -- | An identifier in the value namespace - IdeNSValue Text - -- | An identifier in the type namespace - | IdeNSType Text - -- | An identifier in the kind namespace - | IdeNSKind Text +-- | Denotes the different namespaces a name in PureScript can reside in. +data IdeNamespace = IdeNSValue | IdeNSType | IdeNSKind + deriving (Show, Eq, Ord) + +-- | A name tagged with a namespace +data IdeNamespaced = IdeNamespaced IdeNamespace Text deriving (Show, Eq, Ord) diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 50db451428..1b7c7014f2 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -44,27 +44,27 @@ spec :: Spec spec = do describe "Extracting Spans" $ do it "extracts a span for a value declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(IdeNSValue "value1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(IdeNamespaced IdeNSValue "value1", span1)] it "extracts a span for a type synonym declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(IdeNSType "Synonym1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(IdeNamespaced IdeNSType "Synonym1", span1)] it "extracts a span for a typeclass declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(IdeNSType "Class1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(IdeNamespaced IdeNSType "Class1", span1)] it "extracts spans for a typeclass declaration and its members" $ - extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(IdeNSType "Class2", span1), (IdeNSValue "member1", span2)] + extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(IdeNamespaced IdeNSType "Class2", span1), (IdeNamespaced IdeNSValue "member1", span2)] it "extracts a span for a data declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(IdeNSType "Data1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(IdeNamespaced IdeNSType "Data1", span1)] it "extracts spans for a data declaration and its constructors" $ - extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(IdeNSType "Data2", span1), (IdeNSValue "Cons1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(IdeNamespaced IdeNSType "Data2", span1), (IdeNamespaced IdeNSValue "Cons1", span1)] it "extracts a span for a value operator fixity declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] valueFixity) `shouldBe` [(IdeNSValue "<$>", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] valueFixity) `shouldBe` [(IdeNamespaced IdeNSValue "<$>", span1)] it "extracts a span for a type operator fixity declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] typeFixity) `shouldBe` [(IdeNSType "~>", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] typeFixity) `shouldBe` [(IdeNamespaced IdeNSType "~>", span1)] it "extracts a span for a foreign declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(IdeNSValue "foreign1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(IdeNamespaced IdeNSValue "foreign1", span1)] it "extracts a span for a data foreign declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(IdeNSType "Foreign2", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(IdeNamespaced IdeNSType "Foreign2", span1)] it "extracts a span for a foreign kind declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] foreign3) `shouldBe` [(IdeNSKind "Foreign3", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] foreign3) `shouldBe` [(IdeNamespaced IdeNSKind "Foreign3", span1)] describe "Type annotations" $ do it "extracts a type annotation" $ extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.REmpty)] From b9b45e7239d6a7f4513e1e02c7acae619bdc876f Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 12 May 2017 02:10:12 +0200 Subject: [PATCH 0781/1580] converts \r\n into \n after reading files as ByteStrings (#2884) --- package.yaml | 1 + purescript.cabal | 3 +++ src/Language/PureScript/Ide/Imports.hs | 2 +- src/Language/PureScript/Ide/Util.hs | 9 --------- src/System/IO/UTF8.hs | 11 +++++++++-- 5 files changed, 14 insertions(+), 12 deletions(-) diff --git a/package.yaml b/package.yaml index d072331c35..7a267259e4 100644 --- a/package.yaml +++ b/package.yaml @@ -76,6 +76,7 @@ dependencies: - spdx ==0.2.* - split - stm >=0.2.4.0 + - stringsearch - syb - text - time diff --git a/purescript.cabal b/purescript.cabal index 49d2cd1f71..36536dcb22 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -693,6 +693,7 @@ library , spdx ==0.2.* , split , stm >=0.2.4.0 + , stringsearch , syb , text , time @@ -901,6 +902,7 @@ executable purs , spdx ==0.2.* , split , stm >=0.2.4.0 + , stringsearch , syb , text , time @@ -989,6 +991,7 @@ test-suite tests , spdx ==0.2.* , split , stm >=0.2.4.0 + , stringsearch , syb , text , time diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 84beedd07e..99801ec463 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -85,7 +85,7 @@ parseImportsFromFile file = do parseImportsFromFile' :: (MonadIO m, MonadError IdeError m) => FilePath -> m (P.ModuleName, [Text], [Import], [Text]) parseImportsFromFile' fp = do - file <- ideReadTextFile fp + file <- ideReadFile fp case sliceImportSection (T.lines file) of Right res -> pure res Left err -> throwError (GeneralError err) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index a56471b02b..6154e21df9 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -28,7 +28,6 @@ module Language.PureScript.Ide.Util , identT , opNameT , ideReadFile - , ideReadTextFile , module Language.PureScript.Ide.Logging ) where @@ -144,11 +143,3 @@ ideReadFile' fileReader fp = do ideReadFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text ideReadFile = ideReadFile' readUTF8FileT - --- | This function is to be used over @ideReadFile@ when the result is not just --- passed on to the PureScript parser, but also needs to be treated as lines of --- Text. Because @ideReadFile@ reads the file as ByteString line endings get --- mangled on Windows otherwise. This is irrelevant for parsing, because the --- Lexer strips the additional @\r@s as whitespace. -ideReadTextFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text -ideReadTextFile fp = T.replace "\r\n" "\n" <$> ideReadFile fp diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs index ec5088e2b9..f3c1838d43 100644 --- a/src/System/IO/UTF8.hs +++ b/src/System/IO/UTF8.hs @@ -3,13 +3,20 @@ module System.IO.UTF8 where import Prelude.Compat import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Search as BSS import qualified Data.ByteString.UTF8 as UTF8 import Data.Text (Text) import qualified Data.Text.Encoding as TE +-- | Unfortunately ByteString's readFile does not convert line endings on +-- Windows, so we have to do it ourselves +fixCRLF :: BS.ByteString -> BS.ByteString +fixCRLF = BSL.toStrict . BSS.replace "\r\n" ("\n" :: BS.ByteString) + readUTF8FileT :: FilePath -> IO Text readUTF8FileT inFile = - fmap TE.decodeUtf8 (BS.readFile inFile) + fmap (TE.decodeUtf8 . fixCRLF) (BS.readFile inFile) writeUTF8FileT :: FilePath -> Text -> IO () writeUTF8FileT inFile text = @@ -17,7 +24,7 @@ writeUTF8FileT inFile text = readUTF8File :: FilePath -> IO String readUTF8File inFile = - fmap UTF8.toString (BS.readFile inFile) + fmap (UTF8.toString . fixCRLF) (BS.readFile inFile) writeUTF8File :: FilePath -> String -> IO () writeUTF8File inFile text = From dac43102a5ff0984d1266981974270d7f23e96a6 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 15 May 2017 00:41:00 +0200 Subject: [PATCH 0782/1580] [purs ide] parses modules in parallel (#2891) --- src/Language/PureScript/Ide.hs | 2 +- src/Language/PureScript/Ide/SourceFile.hs | 23 ++++++++++++++++++++--- 2 files changed, 21 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 020208e91e..142e38a00b 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -208,7 +208,7 @@ loadModules moduleNames = do -- We parse all source files, log eventual parse failures and insert the -- successful parses into the state. (failures, allModules) <- - partitionEithers <$> (traverse parseModule =<< findAllSourceFiles) + partitionEithers <$> (parseModulesFromFiles =<< findAllSourceFiles) unless (null failures) $ $(logWarn) ("Failed to parse: " <> show failures) traverse_ insertModule allModules diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 33b5dc90c4..23ec01436f 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -14,6 +14,7 @@ module Language.PureScript.Ide.SourceFile ( parseModule + , parseModulesFromFiles , extractAstInformation -- for tests , extractSpans @@ -22,6 +23,7 @@ module Language.PureScript.Ide.SourceFile import Protolude +import Control.Parallel.Strategies (withStrategy, parList, rseq) import qualified Data.Map as Map import qualified Language.PureScript as P import Language.PureScript.Ide.Error @@ -34,9 +36,24 @@ parseModule -> m (Either FilePath (FilePath, P.Module)) parseModule path = do contents <- ideReadFile path - case P.parseModuleFromFile identity (path, contents) of - Left _ -> pure (Left path) - Right m -> pure (Right m) + pure (parseModule' path contents) + +parseModule' :: FilePath -> Text -> Either FilePath (FilePath, P.Module) +parseModule' path file = + case P.parseModuleFromFile identity (path, file) of + Left _ -> Left path + Right m -> Right m + +parseModulesFromFiles + :: (MonadIO m, MonadError IdeError m) + => [FilePath] + -> m [Either FilePath (FilePath, P.Module)] +parseModulesFromFiles paths = do + files <- traverse (\p -> (p,) <$> ideReadFile p) paths + pure (inParallel (map (uncurry parseModule') files)) + where + inParallel :: [Either e (k, a)] -> [Either e (k, a)] + inParallel = withStrategy (parList rseq) -- | Extracts AST information from a parsed module extractAstInformation From 65e4b74f9308926980f3350d273df309ddc40447 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Stefan=20Holzm=C3=BCller?= Date: Tue, 16 May 2017 12:01:28 +0200 Subject: [PATCH 0783/1580] [purs ide] Add a new namespace filter (#2792) (#2893) * [purs ide] Add a new namespace filter (#2792) * Pick content from PR #2892 - Add more tests - Update `PROTOCOL.md` - Update `CONTRIBUTORS.ms` --- CONTRIBUTORS.md | 2 + psc-ide/PROTOCOL.md | 13 ++++++ src/Language/PureScript/Ide/Filter.hs | 41 +++++++++++++---- src/Language/PureScript/Ide/Types.hs | 8 ++++ tests/Language/PureScript/Ide/FilterSpec.hs | 51 ++++++++++++++++++--- 5 files changed, 101 insertions(+), 14 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 1be6da569e..4849f2df78 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -87,11 +87,13 @@ If you would prefer to use different terms, please use the section below instead | [@rvion](https://github.com/rvion) | Rémi Vion | [MIT license](http://opensource.org/licenses/MIT) | | [@RyanGlScott](https://github.com/RyanGlScott) | Ryan Scott | [MIT license](http://opensource.org/licenses/MIT) | | [@sebastiaanvisser](https://github.com/sebastiaanvisser) | Sebastiaan Visser | MIT license | +| [@sectore](https://github.com/sectore) | Jens Krause | [MIT license](http://opensource.org/licenses/MIT) | | [@senju](https://github.com/senju) | senju | [MIT license](http://opensource.org/licenses/MIT) | | [@seungha-kim](https://github.com/seungha-kim) | Seungha Kim | [MIT license](http://opensource.org/licenses/MIT) | | [@simonyangme](https://github.com/simonyangme) | Simon Yang | [MIT license](http://opensource.org/licenses/MIT) | | [@sharkdp](https://github.com/sharkdp) | David Peter | [MIT license](http://opensource.org/licenses/MIT) | | [@soupi](https://github.com/soupi) | Gil Mizrahi | [MIT license](http://opensource.org/licenses/MIT) | +| [@stefanholzmueller](https://github.com/stefanholzmueller) | Stefan Holzmüller | [MIT license](http://opensource.org/licenses/MIT) | | [@sztupi](https://github.com/sztupi) | Attila Sztupak | [MIT license](http://opensource.org/licenses/MIT) | | [@taktoa](https://github.com/taktoa) | Remy Goldschmidt | [MIT license](http://opensource.org/licenses/MIT) | | [@taku0](https://github.com/taku0) | taku0 | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index 0d009a777a..556491bb3e 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -515,6 +515,19 @@ and in any of their dependencies/imports. } ``` +### Namespace filter +The Namespace filter only keeps identifiers that appear in the listed namespaces. +Valid namespaces are `value`, `type` and `kind`. + +```json +{ + "filter": "namespace", + "params": { + "namespaces": ["value", "type", "kind"] + } +} +``` + ## Matcher: ### Flex matcher diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 28ed8c0d5f..ec9d428885 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -16,6 +16,7 @@ module Language.PureScript.Ide.Filter ( Filter + , namespaceFilter , moduleFilter , prefixFilter , equalityFilter @@ -25,6 +26,7 @@ module Language.PureScript.Ide.Filter import Protolude hiding (isPrefixOf) import Data.Aeson +import Data.List.NonEmpty (NonEmpty) import Data.Text (isPrefixOf) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util @@ -38,6 +40,23 @@ type Module = (P.ModuleName, [IdeDeclarationAnn]) mkFilter :: ([Module] -> [Module]) -> Filter mkFilter = Filter . Endo +-- | Only keeps Identifiers in the given Namespaces +namespaceFilter :: NonEmpty IdeNamespace -> Filter +namespaceFilter namespaces = + mkFilter (filterModuleDecls filterNamespaces) + where + filterNamespaces :: IdeDeclaration -> Bool + filterNamespaces decl = elem (namespace decl) namespaces + namespace :: IdeDeclaration -> IdeNamespace + namespace (IdeDeclValue _) = IdeNSValue + namespace (IdeDeclType _) = IdeNSType + namespace (IdeDeclTypeSynonym _) = IdeNSType + namespace (IdeDeclDataConstructor _) = IdeNSValue + namespace (IdeDeclTypeClass _) = IdeNSType + namespace (IdeDeclValueOperator _) = IdeNSValue + namespace (IdeDeclTypeOperator _) = IdeNSType + namespace (IdeDeclKind _) = IdeNSKind + -- | Only keeps the given Modules moduleFilter :: [P.ModuleName] -> Filter moduleFilter = @@ -50,7 +69,7 @@ moduleFilter' moduleIdents = filter (flip elem moduleIdents . fst) prefixFilter :: Text -> Filter prefixFilter "" = mkFilter identity prefixFilter t = - mkFilter $ identFilter prefix t + mkFilter $ declarationFilter prefix t where prefix :: IdeDeclaration -> Text -> Bool prefix ed search = search `isPrefixOf` identifierFromIdeDeclaration ed @@ -58,18 +77,20 @@ prefixFilter t = -- | Only keeps Identifiers that are equal to the search string equalityFilter :: Text -> Filter equalityFilter = - mkFilter . identFilter equality + mkFilter . declarationFilter equality where equality :: IdeDeclaration -> Text -> Bool equality ed search = identifierFromIdeDeclaration ed == search -identFilter :: (IdeDeclaration -> Text -> Bool) -> Text -> [Module] -> [Module] -identFilter predicate search = - filter (not . null . snd) . fmap filterModuleDecls +declarationFilter :: (IdeDeclaration -> Text -> Bool) -> Text -> [Module] -> [Module] +declarationFilter predicate search = + filterModuleDecls (flip predicate search) + +filterModuleDecls :: (IdeDeclaration -> Bool) -> [Module] -> [Module] +filterModuleDecls predicate = + filter (not . null . snd) . fmap filterDecls where - filterModuleDecls :: Module -> Module - filterModuleDecls (moduleIdent, decls) = - (moduleIdent, filter (flip predicate search . discardAnn) decls) + filterDecls (moduleIdent, decls) = (moduleIdent, filter (predicate . discardAnn) decls) runFilter :: Filter -> [Module] -> [Module] runFilter (Filter f) = appEndo f @@ -93,4 +114,8 @@ instance FromJSON Filter where params <- o .: "params" modules <- map P.moduleNameFromString <$> params .: "modules" return $ moduleFilter modules + "namespace" -> do + params <- o .: "params" + namespaces <- params .: "namespaces" + return $ namespaceFilter namespaces _ -> mzero diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 156bc68e21..4797d3f288 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -309,6 +309,14 @@ instance ToJSON PursuitResponse where data IdeNamespace = IdeNSValue | IdeNSType | IdeNSKind deriving (Show, Eq, Ord) +instance FromJSON IdeNamespace where + parseJSON (String s) = case s of + "value" -> pure IdeNSValue + "type" -> pure IdeNSType + "kind" -> pure IdeNSKind + _ -> mzero + parseJSON _ = mzero + -- | A name tagged with a namespace data IdeNamespaced = IdeNamespaced IdeNamespace Text deriving (Show, Eq, Ord) diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index f129b18338..2e1c8f97cd 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -3,19 +3,20 @@ module Language.PureScript.Ide.FilterSpec where import Protolude +import Data.List.NonEmpty import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Test as T import qualified Language.PureScript as P import Test.Hspec type Module = (P.ModuleName, [IdeDeclarationAnn]) -value :: Text -> IdeDeclarationAnn -value s = IdeDeclarationAnn emptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.REmpty)) - -moduleA, moduleB :: Module -moduleA = (P.moduleNameFromString "Module.A", [value "function1"]) -moduleB = (P.moduleNameFromString "Module.B", [value "data1"]) +moduleA, moduleB, moduleC, moduleD :: Module +moduleA = (P.moduleNameFromString "Module.A", [T.ideValue "function1" Nothing]) +moduleB = (P.moduleNameFromString "Module.B", [T.ideValue "data1" Nothing]) +moduleC = (P.moduleNameFromString "Module.C", [T.ideType "List" Nothing]) +moduleD = (P.moduleNameFromString "Module.D", [T.ideKind "kind1"]) modules :: [Module] modules = [moduleA, moduleB] @@ -29,6 +30,9 @@ runPrefix s = applyFilters [prefixFilter s] modules runModule :: [P.ModuleName] -> [Module] runModule ms = applyFilters [moduleFilter ms] modules +runNamespace :: NonEmpty IdeNamespace -> [Module] -> [Module] +runNamespace namespaces = applyFilters [namespaceFilter namespaces] + spec :: Spec spec = do describe "equality Filter" $ do @@ -52,3 +56,38 @@ spec = do runModule [P.moduleNameFromString "Module.A"] `shouldBe` [moduleA] it "ignores modules that are not in scope" $ runModule (P.moduleNameFromString <$> ["Module.A", "Unknown"]) `shouldBe` [moduleA] + describe "namespaceFilter" $ do + it "extracts modules by filtering `value` namespaces" $ + runNamespace (fromList [IdeNSValue]) + [moduleA, moduleB, moduleD] `shouldBe` [moduleA, moduleB] + it "extracts no modules by filtering `value` namespaces" $ + runNamespace (fromList [IdeNSValue]) + [moduleD] `shouldBe` [] + it "extracts modules by filtering `type` namespaces" $ + runNamespace (fromList [IdeNSType]) + [moduleA, moduleB, moduleC] `shouldBe` [moduleC] + it "extracts no modules by filtering `type` namespaces" $ + runNamespace (fromList [IdeNSType]) + [moduleA, moduleB] `shouldBe` [] + it "extracts modules by filtering `kind` namespaces" $ + runNamespace (fromList [IdeNSKind]) + [moduleA, moduleB, moduleD] `shouldBe` [moduleD] + it "extracts no modules by filtering `kind` namespaces" $ + runNamespace (fromList [IdeNSKind]) + [moduleA, moduleB] `shouldBe` [] + it "extracts modules by filtering `value` and `type` namespaces" $ + runNamespace (fromList [ IdeNSValue, IdeNSType]) + [moduleA, moduleB, moduleC, moduleD] + `shouldBe` [moduleA, moduleB, moduleC] + it "extracts modules by filtering `value` and `kind` namespaces" $ + runNamespace (fromList [ IdeNSValue, IdeNSKind]) + [moduleA, moduleB, moduleC, moduleD] + `shouldBe` [moduleA, moduleB, moduleD] + it "extracts modules by filtering `type` and `kind` namespaces" $ + runNamespace (fromList [ IdeNSType, IdeNSKind]) + [moduleA, moduleB, moduleC, moduleD] + `shouldBe` [moduleC, moduleD] + it "extracts modules by filtering `value`, `type` and `kind` namespaces" $ + runNamespace (fromList [ IdeNSValue, IdeNSType, IdeNSKind]) + [moduleA, moduleB, moduleC, moduleD] + `shouldBe` [moduleA, moduleB, moduleC, moduleD] From a63d1dd15790603782739e43be3ae2fa9793aad2 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 17 May 2017 18:28:13 +0200 Subject: [PATCH 0784/1580] [purs ide] Introduce completion options (#2896) these just allow to specify maxResults for now --- psc-ide/PROTOCOL.md | 24 ++++++++++++--- purescript.cabal | 1 + src/Language/PureScript/Ide.hs | 17 +++++++---- src/Language/PureScript/Ide/Command.hs | 3 ++ src/Language/PureScript/Ide/Completion.hs | 30 +++++++++++++++++-- src/Language/PureScript/Ide/Rebuild.hs | 2 +- .../Language/PureScript/Ide/CompletionSpec.hs | 24 +++++++++++++++ tests/Language/PureScript/Ide/RebuildSpec.hs | 3 +- 8 files changed, 90 insertions(+), 14 deletions(-) create mode 100644 tests/Language/PureScript/Ide/CompletionSpec.hs diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index 556491bb3e..99ba1fc2bb 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -59,23 +59,30 @@ The `complete` command looks up possible completions/corrections. **Params**: - `filters :: [Filter]`: The same as for the `type` command. A candidate must match all filters. + - `matcher :: (optional) Matcher`: The strategy used for matching candidates after filtering. Results are scored internally and will be returned in the descending order where the nth element is better then the n+1-th. + If no matcher is given every candidate, that passes the filters, is returned + in no particular order. + - `currentModule :: (optional) String`: The current modules name. If it matches with the rebuild cache non-exported modules will also be completed. You can fill the rebuild cache by using the "Rebuild" command. - If no matcher is given every candidate, that passes the filters, is returned - in no particular order. + - `options :: (optional) CompletionOptions`: The CompletionOptions to apply to + the completion results ```json { "command": "complete", "params": { "filters": [{..}, {..}], - "matcher": {..} - "currentModule": "Main" + "matcher": {..}, + "currentModule": "Main", + "options": { + "maxResults": 50 + } } } ``` @@ -575,6 +582,15 @@ All Responses are wrapped in the following format: } ``` +## CompletionOptions + +Completion options allow to configure the number of returned completion results. + +- maxResults :: Maybe Int + +If specified limits the number of completion results, otherwise return all +results. + ### Error Errors at this point are merely Error strings. Newlines are escaped like `\n` diff --git a/purescript.cabal b/purescript.cabal index 36536dcb22..aa1c136a15 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1010,6 +1010,7 @@ test-suite tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: + Language.PureScript.Ide.CompletionSpec Language.PureScript.Ide.FilterSpec Language.PureScript.Ide.ImportsSpec Language.PureScript.Ide.MatcherSpec diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 142e38a00b..786e2bd099 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -56,8 +56,8 @@ handleCommand c = case c of loadModulesSync modules Type search filters currentModule -> findType search filters currentModule - Complete filters matcher currentModule -> - findCompletions filters matcher currentModule + Complete filters matcher currentModule complOptions -> + findCompletions filters matcher currentModule complOptions Pursuit query Package -> findPursuitPackages query Pursuit query Identifier -> @@ -92,11 +92,16 @@ handleCommand c = case c of Quit -> liftIO exitSuccess -findCompletions :: Ide m => - [Filter] -> Matcher IdeDeclarationAnn -> Maybe P.ModuleName -> m Success -findCompletions filters matcher currentModule = do +findCompletions + :: Ide m + => [Filter] + -> Matcher IdeDeclarationAnn + -> Maybe P.ModuleName + -> CompletionOptions + -> m Success +findCompletions filters matcher currentModule complOptions = do modules <- getAllModules currentModule - pure . CompletionResult . map completionFromMatch . getCompletions filters matcher $ modules + pure . CompletionResult . map completionFromMatch . getCompletions filters matcher complOptions $ modules findType :: Ide m => Text -> [Filter] -> Maybe P.ModuleName -> m Success diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index e9999a809a..9c55059b5f 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -19,6 +19,7 @@ import Protolude import Data.Aeson import qualified Language.PureScript as P import Language.PureScript.Ide.CaseSplit +import Language.PureScript.Ide.Completion import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types @@ -35,6 +36,7 @@ data Command { completeFilters :: [Filter] , completeMatcher :: Matcher IdeDeclarationAnn , completeCurrentModule :: Maybe P.ModuleName + , completeOptions :: CompletionOptions } | Pursuit { pursuitQuery :: PursuitQuery @@ -129,6 +131,7 @@ instance FromJSON Command where <$> params .:? "filters" .!= [] <*> params .:? "matcher" .!= mempty <*> (fmap P.moduleNameFromString <$> params .:? "currentModule") + <*> params .:? "options" .!= defaultCompletionOptions "pursuit" -> do params <- o .: "params" Pursuit diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 81f68d7846..10268f0f5c 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -1,10 +1,14 @@ module Language.PureScript.Ide.Completion ( getCompletions , getExactMatches + , CompletionOptions(..) + , defaultCompletionOptions + , applyCompletionOptions ) where import Protolude +import Data.Aeson import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types @@ -17,10 +21,15 @@ type Module = (P.ModuleName, [IdeDeclarationAnn]) getCompletions :: [Filter] -> Matcher IdeDeclarationAnn + -> CompletionOptions -> [Module] -> [Match IdeDeclarationAnn] -getCompletions filters matcher modules = - runMatcher matcher (completionsFromModules (applyFilters filters modules)) +getCompletions filters matcher options modules = + modules + & applyFilters filters + & completionsFromModules + & runMatcher matcher + & applyCompletionOptions options getExactMatches :: Text -> [Filter] -> [Module] -> [Match IdeDeclarationAnn] getExactMatches search filters modules = @@ -31,3 +40,20 @@ completionsFromModules = foldMap completionFromModule where completionFromModule (moduleName, decls) = map (\x -> Match (moduleName, x)) decls + +data CompletionOptions = CompletionOptions + { coMaxResults :: Maybe Int + } + +defaultCompletionOptions :: CompletionOptions +defaultCompletionOptions = CompletionOptions { coMaxResults = Nothing } + +applyCompletionOptions :: CompletionOptions -> [a] -> [a] +applyCompletionOptions co = + maybe identity take (coMaxResults co) + +instance FromJSON CompletionOptions where + parseJSON = withObject "CompletionOptions" $ \o -> do + maxResults <- o .:? "maxResults" + pure (CompletionOptions { coMaxResults = maxResults }) + diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index fb5b8ba73b..a26f4e521c 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -53,7 +53,7 @@ rebuildFile path runOpenBuild = do Right m -> pure m -- Externs files must be sorted ahead of time, so that they get applied - -- correctly to the 'Environment'. + -- in the right order (bottom up) to the 'Environment'. externs <- logPerf (labelTimespec "Sorting externs") (sortExterns m =<< getExternFiles) outputDirectory <- confOutputPath . ideConfiguration <$> ask diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs new file mode 100644 index 0000000000..a226706cb8 --- /dev/null +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Language.PureScript.Ide.CompletionSpec where + +import Protolude + +import Language.PureScript.Ide.Completion +import Language.PureScript.Ide.Test +import Language.PureScript.Ide.Types +import Test.Hspec + +matches :: [Match IdeDeclarationAnn] +matches = map (\d -> Match (mn "Main", d)) [ ideKind "Kind", ideType "Type" Nothing ] + +spec :: Spec +spec = describe "Applying completion options" $ do + it "keeps all matches if maxResults is not specified" $ do + applyCompletionOptions (defaultCompletionOptions { coMaxResults = Nothing }) matches + `shouldBe` + matches + it "keeps only the specified amount of maxResults" $ do + applyCompletionOptions (defaultCompletionOptions { coMaxResults = Just 1 }) matches + `shouldBe` + take 1 matches diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index 801c3b6c42..9c00312598 100644 --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -5,6 +5,7 @@ module Language.PureScript.Ide.RebuildSpec where import Protolude import Language.PureScript.Ide.Command +import Language.PureScript.Ide.Completion import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types import qualified Language.PureScript.Ide.Test as Test @@ -57,5 +58,5 @@ spec = describe "Rebuilding single modules" $ do it "completes a hidden identifier after rebuilding" $ do ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ Test.runIde [ rebuildSync "RebuildSpecWithHiddenIdent.purs" - , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent"))] + , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent")) defaultCompletionOptions] complIdentifier result `shouldBe` "hidden" From 98ca6bc445b0b16bb37b2661535670f33eb43fa6 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 17 May 2017 18:28:48 +0200 Subject: [PATCH 0785/1580] [purs ide] Implements new import formatting (#2897) Fixes #2888 --- src/Language/PureScript/Ide/Imports.hs | 51 +++++++++----------- tests/Language/PureScript/Ide/ImportsSpec.hs | 25 +++++++--- 2 files changed, 39 insertions(+), 37 deletions(-) diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 99801ec463..f1d70e5c8d 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -31,7 +31,7 @@ module Language.PureScript.Ide.Imports import Protolude import Control.Lens ((^.), (%~), ix) -import Data.List (findIndex, nubBy) +import Data.List (findIndex, nubBy, partition) import qualified Data.Text as T import qualified Language.PureScript as P import Language.PureScript.Ide.Completion @@ -46,27 +46,6 @@ import qualified Text.Parsec as Parsec data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) deriving (Eq, Show) -instance Ord Import where - compare = compImport - -compImportType :: P.ImportDeclarationType -> P.ImportDeclarationType -> Ordering -compImportType P.Implicit P.Implicit = EQ -compImportType P.Implicit _ = LT -compImportType (P.Explicit _) (P.Hiding _) = LT -compImportType (P.Explicit _) (P.Explicit _) = EQ -compImportType (P.Explicit _) P.Implicit = GT -compImportType (P.Hiding _) (P.Hiding _) = EQ -compImportType (P.Hiding _) _ = GT - -compImport :: Import -> Import -> Ordering -compImport (Import n i q) (Import n' i' q') - | compImportType i i' /= EQ = compImportType i i' - -- This means that for a stable sort, the first implicit import will stay - -- the first implicit import - | not (P.isExplicit i) && isNothing q = LT - | not (P.isExplicit i) && isNothing q' = GT - | otherwise = compare n n' - -- | Reads a file and returns the parsed modulename as well as the parsed -- imports, while ignoring eventual parse errors that aren't relevant to the -- import section @@ -154,10 +133,7 @@ addImplicitImport fp mn = do addImplicitImport' :: [Import] -> P.ModuleName -> [Text] addImplicitImport' imports mn = - -- We need to append the new import, because there could already be implicit - -- imports and we need to preserve the order on these, as the first implicit - -- import is the one that doesn't generate warnings. - prettyPrintImportSection ( imports ++ [Import mn P.Implicit Nothing]) + prettyPrintImportSection (Import mn P.Implicit Nothing : imports) -- | Adds an explicit import like @import Prelude (unit)@ to a Sourcefile. If an -- explicit import already exists for the given module, it adds the identifier @@ -274,7 +250,7 @@ addImportForIdentifier fp ident filters = do if m1 /= m2 -- If the modules don't line up we just ask the user to specify the -- module - then pure $ Left ms + then pure (Left ms) else case decideRedundantCase d1 d2 <|> decideRedundantCase d2 d1 of -- If dataconstructor and type line up we just import the -- dataconstructor as that will give us an unnecessary import warning at @@ -283,13 +259,16 @@ addImportForIdentifier fp ident filters = do Right <$> addExplicitImport fp decl m1 -- Here we need the user to specify whether he wanted a dataconstructor -- or a type + + -- TODO: With the new namespace filter, this can actually be a + -- request for the user to specify which of the two was wanted. Nothing -> throwError (GeneralError "Undecidable between type and dataconstructor") -- Multiple matches were found so we need to ask the user to clarify which -- module he meant xs -> - pure $ Left xs + pure (Left xs) where decideRedundantCase d@(IdeDeclDataConstructor dtor) (IdeDeclType t) = if dtor ^. ideDtorTypeName == t ^. ideTypeName then Just d else Nothing @@ -302,7 +281,21 @@ prettyPrintImport' (Import mn idt qual) = "import " <> P.prettyPrintImport mn idt qual prettyPrintImportSection :: [Import] -> [Text] -prettyPrintImportSection imports = map prettyPrintImport' (sort imports) +prettyPrintImportSection imports = + let + (implicitImports, explicitImports) = partition isImplicitImport imports + in + sort (map prettyPrintImport' implicitImports) + -- Only add the extra spacing if both implicit as well as + -- explicit/qualified imports exist + <> (guard (not (null explicitImports || null implicitImports)) $> "") + <> sort (map prettyPrintImport' explicitImports) + where + isImplicitImport :: Import -> Bool + isImplicitImport i = case i of + Import _ P.Implicit Nothing -> True + _ -> False + -- | Writes a list of lines to @Just filepath@ and responds with a @TextResult@, -- or returns the lines as a @MultilineTextResult@ if @Nothing@ was given as the diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 0cedd51b5d..33f8ccd419 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -44,7 +44,7 @@ splitSimpleFile = fromRight (sliceImportSection simpleFile) withImports :: [Text] -> [Text] withImports is = - take 2 simpleFile ++ is ++ drop 2 simpleFile + take 2 simpleFile ++ [""] ++ is ++ drop 2 simpleFile testParseImport :: Text -> Import testParseImport = fromJust . parseImport @@ -117,8 +117,8 @@ spec = do it "adds an implicit unqualified import" $ shouldBe (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map")) - [ "import Prelude" - , "import Data.Map" + [ "import Data.Map" + , "import Prelude" ] it "adds an explicit unqualified import to a file without any imports" $ shouldBe @@ -128,6 +128,7 @@ spec = do shouldBe (addValueImport "head" (P.moduleNameFromString "Data.Array") simpleFileImports) [ "import Prelude" + , "" , "import Data.Array (head)" ] it "doesn't add an import if the containing module is imported implicitly" $ @@ -139,30 +140,35 @@ spec = do shouldBe (addValueImport "head" (P.moduleNameFromString "Data.Array") explicitImports) [ "import Prelude" + , "" , "import Data.Array (head, tail)" ] it "adds a kind to an explicit import list" $ shouldBe (addKindImport "Effect" (P.moduleNameFromString "Control.Monad.Eff") simpleFileImports) [ "import Prelude" + , "" , "import Control.Monad.Eff (kind Effect)" ] it "adds an operator to an explicit import list" $ shouldBe (addOpImport "<~>" (P.moduleNameFromString "Data.Array") explicitImports) [ "import Prelude" + , "" , "import Data.Array (tail, (<~>))" ] it "adds a type with constructors without automatically adding an open import of said constructors " $ shouldBe (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") simpleFileImports) [ "import Prelude" + , "" , "import Data.Maybe (Maybe)" ] it "adds the type for a given DataConstructor" $ shouldBe (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") simpleFileImports) [ "import Prelude" + , "" , "import Data.Maybe (Maybe(..))" ] it "adds a dataconstructor to an existing type import" $ do @@ -170,6 +176,7 @@ spec = do shouldBe (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") typeImports) [ "import Prelude" + , "" , "import Data.Maybe (Maybe(..))" ] it "doesn't add a dataconstructor to an existing type import with open dtors" $ do @@ -177,12 +184,14 @@ spec = do shouldBe (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") typeImports) [ "import Prelude" + , "" , "import Data.Maybe (Maybe(..))" ] it "doesn't add an identifier to an explicit import list if it's already imported" $ shouldBe (addValueImport "tail" (P.moduleNameFromString "Data.Array") explicitImports) [ "import Prelude" + , "" , "import Data.Array (tail)" ] @@ -203,23 +212,23 @@ spec = do [expected] it "sorts class" $ expectSorted (map classImport ["Applicative", "Bind"]) - ["import Prelude", "import Control.Monad (class Applicative, class Bind, ap)"] + ["import Prelude", "", "import Control.Monad (class Applicative, class Bind, ap)"] it "sorts value" $ expectSorted (map valueImport ["unless", "where"]) - ["import Prelude", "import Control.Monad (ap, unless, where)"] + ["import Prelude", "", "import Control.Monad (ap, unless, where)"] it "sorts type, value" $ expectSorted ((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"])) - ["import Prelude", "import Control.Monad (Bar, Foo, ap, unless, where)"] + ["import Prelude", "", "import Control.Monad (Bar, Foo, ap, unless, where)"] it "sorts class, type, value" $ expectSorted ((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"]) ++ (map classImport ["Applicative", "Bind"])) - ["import Prelude", "import Control.Monad (class Applicative, class Bind, Bar, Foo, ap, unless, where)"] + ["import Prelude", "", "import Control.Monad (class Applicative, class Bind, Bar, Foo, ap, unless, where)"] it "sorts types with constructors, using open imports for the constructors" $ expectSorted -- the imported names don't actually have to exist! (map (uncurry dtorImport) [("Just", "Maybe"), ("Nothing", "Maybe"), ("SomeOtherConstructor", "SomeDataType")]) - ["import Prelude", "import Control.Monad (Maybe(..), SomeDataType(..), ap)"] + ["import Prelude", "", "import Control.Monad (Maybe(..), SomeDataType(..), ap)"] describe "importing from a loaded IdeState" importFromIdeState implImport :: Text -> Command From 24069dfb40efa373843de9807745de2a54dcbc51 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Thu, 18 May 2017 13:43:59 -0600 Subject: [PATCH 0786/1580] [purs ide] Adds a command to add qualified imports (#2898) --- psc-ide/PROTOCOL.md | 23 +++++++++++++++ src/Language/PureScript/Ide.hs | 3 ++ src/Language/PureScript/Ide/Command.hs | 5 ++++ src/Language/PureScript/Ide/Imports.hs | 30 +++++++++++++++++--- tests/Language/PureScript/Ide/ImportsSpec.hs | 7 +++++ 5 files changed, 64 insertions(+), 4 deletions(-) diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index 99ba1fc2bb..c508317602 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -231,6 +231,29 @@ Example: } } ``` + +#### Subcommand `addQualifiedImport` + +This command adds an import for the given modulename and qualifier. + +Arguments: +- `moduleName :: String` + +Example: +```json +{ + "command": "import", + "params": { + "file": "/home/creek/Documents/chromacannon/src/Main.purs", + "importCommand": { + "importCommand": "addQualifiedImport", + "module": "Data.Array", + "qualifier": "Array" + } + } +} +``` + #### Subcommand `addImport` This command takes an identifier and searches the currently loaded modules for diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 786e2bd099..b005c2b147 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -75,6 +75,9 @@ handleCommand c = case c of Import fp outfp _ (AddImplicitImport mn) -> do rs <- addImplicitImport fp mn answerRequest outfp rs + Import fp outfp _ (AddQualifiedImport mn qual) -> do + rs <- addQualifiedImport fp mn qual + answerRequest outfp rs Import fp outfp filters (AddImportForIdentifier ident) -> do rs <- addImportForIdentifier fp ident filters case rs of diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 9c55059b5f..5763fcb5a2 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -81,6 +81,7 @@ commandName c = case c of data ImportCommand = AddImplicitImport P.ModuleName + | AddQualifiedImport P.ModuleName P.ModuleName | AddImportForIdentifier Text deriving (Show, Eq) @@ -90,6 +91,10 @@ instance FromJSON ImportCommand where case command of "addImplicitImport" -> AddImplicitImport <$> (P.moduleNameFromString <$> o .: "module") + "addQualifiedImport" -> + AddQualifiedImport + <$> (P.moduleNameFromString <$> o .: "module") + <*> (P.moduleNameFromString <$> o .: "qualifier") "addImport" -> AddImportForIdentifier <$> o .: "identifier" _ -> mzero diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index f1d70e5c8d..a38f56d47f 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -14,6 +14,7 @@ module Language.PureScript.Ide.Imports ( addImplicitImport + , addQualifiedImport , addImportForIdentifier , answerRequest , parseImportsFromFile @@ -21,6 +22,7 @@ module Language.PureScript.Ide.Imports , parseImport , prettyPrintImportSection , addImplicitImport' + , addQualifiedImport' , addExplicitImport' , sliceImportSection , prettyPrintImport' @@ -122,10 +124,11 @@ sliceImportSection fileLines = first show $ do & ix (l2 - l1) %~ T.take c2 -- | Adds an implicit import like @import Prelude@ to a Sourcefile. -addImplicitImport :: (MonadIO m, MonadError IdeError m) - => FilePath -- ^ The Sourcefile read from - -> P.ModuleName -- ^ The module to import - -> m [Text] +addImplicitImport + :: (MonadIO m, MonadError IdeError m) + => FilePath -- ^ The source file read from + -> P.ModuleName -- ^ The module to import + -> m [Text] addImplicitImport fp mn = do (_, pre, imports, post) <- parseImportsFromFile' fp let newImportSection = addImplicitImport' imports mn @@ -135,6 +138,25 @@ addImplicitImport' :: [Import] -> P.ModuleName -> [Text] addImplicitImport' imports mn = prettyPrintImportSection (Import mn P.Implicit Nothing : imports) +-- | Adds a qualified import like @import Data.Map as Map@ to a source file. +addQualifiedImport + :: (MonadIO m, MonadError IdeError m) + => FilePath + -- ^ The sourcefile read from + -> P.ModuleName + -- ^ The module to import + -> P.ModuleName + -- ^ The qualifier under which to import + -> m [Text] +addQualifiedImport fp mn qualifier = do + (_, pre, imports, post) <- parseImportsFromFile' fp + let newImportSection = addQualifiedImport' imports mn qualifier + pure (pre ++ newImportSection ++ post) + +addQualifiedImport' :: [Import] -> P.ModuleName -> P.ModuleName -> [Text] +addQualifiedImport' imports mn qualifier = + prettyPrintImportSection (Import mn P.Implicit (Just qualifier) : imports) + -- | Adds an explicit import like @import Prelude (unit)@ to a Sourcefile. If an -- explicit import already exists for the given module, it adds the identifier -- to that imports list. diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 33f8ccd419..908531b995 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -120,6 +120,13 @@ spec = do [ "import Data.Map" , "import Prelude" ] + it "adds a qualified import" $ + shouldBe + (addQualifiedImport' simpleFileImports (Test.mn "Data.Map") (Test.mn "Map")) + [ "import Prelude" + , "" + , "import Data.Map as Map" + ] it "adds an explicit unqualified import to a file without any imports" $ shouldBe (addValueImport "head" (P.moduleNameFromString "Data.Array") []) From 3b766c2fe69c98b364b3045d0710f5ae29311269 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 21 May 2017 10:05:52 -0600 Subject: [PATCH 0787/1580] [purs ide] Simplify state type (#2882) * rename Configuration to IdeConfiguration * [purs ide] Simplify the Ide State type into two stages Also renames Stage1 and Stage3 into IdeFileState and IdeVolatileState --- app/Command/Ide.hs | 2 +- src/Language/PureScript/Ide.hs | 8 +- src/Language/PureScript/Ide/State.hs | 128 +++++++----------- src/Language/PureScript/Ide/Types.hs | 54 ++++---- src/Language/PureScript/Ide/Watcher.hs | 2 +- .../Language/PureScript/Ide/SourceFileSpec.hs | 2 +- tests/Language/PureScript/Ide/Test.hs | 14 +- 7 files changed, 91 insertions(+), 119 deletions(-) diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index 59780de293..8b3dcf1430 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -120,7 +120,7 @@ command = Opts.helper <*> subcommands where unless noWatch $ void (forkFinally (watcher polling logLevel ideState fullOutputPath) print) - let conf = Configuration {confLogLevel = logLevel, confOutputPath = outputPath, confGlobs = globs} + let conf = IdeConfiguration {confLogLevel = logLevel, confOutputPath = outputPath, confGlobs = globs} env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf} startServer port env diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index b005c2b147..7262422202 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -175,7 +175,7 @@ findAllSourceFiles = do -- | Looks up the ExternsFiles for the given Modulenames and loads them into the -- server state. Then proceeds to parse all the specified sourcefiles and -- inserts their ASTs into the state. Finally kicks off an async worker, which --- populates Stage 2 and 3 of the state. +-- populates the VolatileState. loadModulesAsync :: (Ide m, MonadError IdeError m, MonadLogger m) => [P.ModuleName] @@ -187,9 +187,9 @@ loadModulesAsync moduleNames = do -- successfully parsed modules. env <- ask let ll = confLogLevel (ideConfiguration env) - -- populateStage2 and 3 return Unit for now, so it's fine to discard this + -- populateVolatileState return Unit for now, so it's fine to discard this -- result. We might want to block on this in a benchmarking situation. - _ <- liftIO (async (runLogger ll (runReaderT (populateStage2 *> populateStage3) env))) + _ <- liftIO (async (runLogger ll (runReaderT populateVolatileState env))) pure tr loadModulesSync @@ -198,7 +198,7 @@ loadModulesSync -> m Success loadModulesSync moduleNames = do tr <- loadModules moduleNames - populateStage2 *> populateStage3 + populateVolatileState pure tr loadModules diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 19a47fc2f8..86d30faca5 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -25,9 +25,8 @@ module Language.PureScript.Ide.State , insertModule , insertExternsSTM , getAllModules - , populateStage2 - , populateStage3 - , populateStage3STM + , populateVolatileState + , populateVolatileStateSTM -- for tests , resolveOperatorsForModule , resolveInstances @@ -52,9 +51,7 @@ import Language.PureScript.Ide.Util resetIdeState :: Ide m => m () resetIdeState = do ideVar <- ideStateVar <$> ask - liftIO . atomically $ do - writeTVar ideVar emptyIdeState - setStage3STM ideVar emptyStage3 + liftIO (atomically (writeTVar ideVar emptyIdeState)) -- | Gets the loaded Modulenames getLoadedModulenames :: Ide m => m [P.ModuleName] @@ -62,7 +59,7 @@ getLoadedModulenames = Map.keys <$> getExternFiles -- | Gets all loaded ExternFiles getExternFiles :: Ide m => m (ModuleMap ExternsFile) -getExternFiles = s1Externs <$> getStage1 +getExternFiles = fsExterns <$> getFileState -- | Insert a Module into Stage1 of the State insertModule :: Ide m => (FilePath, P.Module) -> m () @@ -74,51 +71,35 @@ insertModule module' = do insertModuleSTM :: TVar IdeState -> (FilePath, P.Module) -> STM () insertModuleSTM ref (fp, module') = modifyTVar ref $ \x -> - x { ideStage1 = (ideStage1 x) { - s1Modules = Map.insert + x { ideFileState = (ideFileState x) { + fsModules = Map.insert (P.getModuleName module') (module', fp) - (s1Modules (ideStage1 x))}} + (fsModules (ideFileState x))}} --- | Retrieves Stage1 from the State. --- This includes loaded Externfiles -getStage1 :: Ide m => m Stage1 -getStage1 = do +-- | Retrieves the FileState from the State. This includes loaded Externfiles +-- and parsed Modules +getFileState :: Ide m => m IdeFileState +getFileState = do st <- ideStateVar <$> ask - fmap ideStage1 . liftIO . readTVarIO $ st + fmap ideFileState . liftIO . readTVarIO $ st --- | STM version of getStage1 -getStage1STM :: TVar IdeState -> STM Stage1 -getStage1STM ref = ideStage1 <$> readTVar ref +-- | STM version of getFileState +getFileStateSTM :: TVar IdeState -> STM IdeFileState +getFileStateSTM ref = ideFileState <$> readTVar ref --- | Retrieves Stage2 from the State. -getStage2 :: Ide m => m Stage2 -getStage2 = do - st <- ideStateVar <$> ask - liftIO (atomically (getStage2STM st)) - -getStage2STM :: TVar IdeState -> STM Stage2 -getStage2STM ref = ideStage2 <$> readTVar ref - --- | STM version of setStage2 -setStage2STM :: TVar IdeState -> Stage2 -> STM () -setStage2STM ref s2 = do - modifyTVar ref $ \x -> - x {ideStage2 = s2} - pure () - --- | Retrieves Stage3 from the State. +-- | Retrieves VolatileState from the State. -- This includes the denormalized Declarations and cached rebuilds -getStage3 :: Ide m => m Stage3 -getStage3 = do +getVolatileState :: Ide m => m IdeVolatileState +getVolatileState = do st <- ideStateVar <$> ask - fmap ideStage3 . liftIO . readTVarIO $ st + fmap ideVolatileState . liftIO . readTVarIO $ st --- | Sets Stage3 inside the compiler -setStage3STM :: TVar IdeState -> Stage3 -> STM () -setStage3STM ref s3 = do +-- | Sets the VolatileState inside Ide's state +setVolatileStateSTM :: TVar IdeState -> IdeVolatileState -> STM () +setVolatileStateSTM ref vs = do modifyTVar ref $ \x -> - x {ideStage3 = s3} + x {ideVolatileState = vs} pure () -- | Checks if the given ModuleName matches the last rebuild cache and if it @@ -126,7 +107,7 @@ setStage3STM ref s3 = do -- cache getAllModules :: Ide m => Maybe P.ModuleName -> m [(P.ModuleName, [IdeDeclarationAnn])] getAllModules mmoduleName = do - declarations <- s3Declarations <$> getStage3 + declarations <- vsDeclarations <$> getVolatileState rebuild <- cachedRebuild case mmoduleName of Nothing -> pure (Map.toList declarations) @@ -134,7 +115,7 @@ getAllModules mmoduleName = do case rebuild of Just (cachedModulename, ef) | cachedModulename == moduleName -> do - (AstData asts) <- s2AstData <$> getStage2 + AstData asts <- vsAstData <$> getVolatileState let ast = fromMaybe (Map.empty, Map.empty) (Map.lookup moduleName asts) @@ -148,9 +129,9 @@ getAllModules mmoduleName = do pure (Map.toList resolved) _ -> pure (Map.toList declarations) --- | Adds an ExternsFile into psc-ide's State Stage1. This does not populate the --- following Stages, which needs to be done after all the necessary Exterms have --- been loaded. +-- | Adds an ExternsFile into psc-ide's FileState. This does not populate the +-- VolatileState, which needs to be done after all the necessary Externs and +-- SourceFiles have been loaded. insertExterns :: Ide m => ExternsFile -> m () insertExterns ef = do st <- ideStateVar <$> ask @@ -160,62 +141,47 @@ insertExterns ef = do insertExternsSTM :: TVar IdeState -> ExternsFile -> STM () insertExternsSTM ref ef = modifyTVar ref $ \x -> - x { ideStage1 = (ideStage1 x) { - s1Externs = Map.insert (efModuleName ef) ef (s1Externs (ideStage1 x))}} + x { ideFileState = (ideFileState x) { + fsExterns = Map.insert (efModuleName ef) ef (fsExterns (ideFileState x))}} -- | Sets rebuild cache to the given ExternsFile cacheRebuild :: Ide m => ExternsFile -> m () cacheRebuild ef = do st <- ideStateVar <$> ask liftIO . atomically . modifyTVar st $ \x -> - x { ideStage3 = (ideStage3 x) { - s3CachedRebuild = Just (efModuleName ef, ef)}} + x { ideVolatileState = (ideVolatileState x) { + vsCachedRebuild = Just (efModuleName ef, ef)}} -- | Retrieves the rebuild cache cachedRebuild :: Ide m => m (Maybe (P.ModuleName, ExternsFile)) -cachedRebuild = s3CachedRebuild <$> getStage3 +cachedRebuild = vsCachedRebuild <$> getVolatileState --- | Extracts source spans from the parsed ASTs -populateStage2 :: (Ide m, MonadLogger m) => m () -populateStage2 = do - st <- ideStateVar <$> ask - let message duration = "Finished populating Stage2 in " <> displayTimeSpec duration - logPerf message (liftIO (atomically (populateStage2STM st))) - --- | STM version of populateStage2 -populateStage2STM :: TVar IdeState -> STM () -populateStage2STM ref = do - modules <- s1Modules <$> getStage1STM ref - let astData = map (extractAstInformation . fst) modules - setStage2STM ref (Stage2 (AstData astData)) - --- | Resolves reexports and populates Stage3 with data to be used in queries. -populateStage3 :: (Ide m, MonadLogger m) => m () -populateStage3 = do +-- | Resolves reexports and populates VolatileState with data to be used in queries. +populateVolatileState :: (Ide m, MonadLogger m) => m () +populateVolatileState = do st <- ideStateVar <$> ask let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration - results <- logPerf message (liftIO (atomically (populateStage3STM st))) + results <- logPerf message (liftIO (atomically (populateVolatileStateSTM st))) void $ Map.traverseWithKey (\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn))) (Map.filter reexportHasFailures results) --- | STM version of populateStage3 -populateStage3STM +-- | STM version of populateVolatileState +populateVolatileStateSTM :: TVar IdeState -> STM (ModuleMap (ReexportResult [IdeDeclarationAnn])) -populateStage3STM ref = do - externs <- s1Externs <$> getStage1STM ref - (AstData asts) <- s2AstData <$> getStage2STM ref - let (modules, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs) +populateVolatileStateSTM ref = do + IdeFileState{fsExterns = externs, fsModules = modules} <- getFileStateSTM ref + let asts = map (extractAstInformation . fst) modules + let (moduleDeclarations, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs) results = - resolveLocations asts modules + resolveLocations asts moduleDeclarations & resolveInstances externs & resolveOperators & resolveReexports reexportRefs - setStage3STM ref (Stage3 (map reResolved results) Nothing) + setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) Nothing) pure results - resolveLocations :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations) -> ModuleMap [IdeDeclarationAnn] @@ -276,8 +242,8 @@ resolveInstances externs declarations = _ -> Nothing extractInstances _ _ = Nothing - go :: - (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName) + go + :: (IdeInstance, P.ModuleName, P.ProperName 'P.ClassName) -> ModuleMap [IdeDeclarationAnn] -> ModuleMap [IdeDeclarationAnn] go (ideInstance, classModule, className) acc' = diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 4797d3f288..8c9990df03 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -122,15 +122,15 @@ emptyAnn = Annotation Nothing Nothing Nothing type DefinitionSites a = Map IdeNamespaced a type TypeAnnotations = Map P.Ident P.Type newtype AstData a = AstData (ModuleMap (DefinitionSites a, TypeAnnotations)) - -- ^ SourceSpans for the definition sites of Values and Types aswell as type + -- ^ SourceSpans for the definition sites of values and types as well as type -- annotations found in a module deriving (Show, Eq, Ord, Functor, Foldable) data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone deriving (Show, Eq) -data Configuration = - Configuration +data IdeConfiguration = + IdeConfiguration { confOutputPath :: FilePath , confLogLevel :: IdeLogLevel , confGlobs :: [FilePath] @@ -139,41 +139,47 @@ data Configuration = data IdeEnvironment = IdeEnvironment { ideStateVar :: TVar IdeState - , ideConfiguration :: Configuration + , ideConfiguration :: IdeConfiguration } type Ide m = (MonadIO m, MonadReader IdeEnvironment m) data IdeState = IdeState - { ideStage1 :: Stage1 - , ideStage2 :: Stage2 - , ideStage3 :: Stage3 + { ideFileState :: IdeFileState + , ideVolatileState :: IdeVolatileState } deriving (Show) emptyIdeState :: IdeState -emptyIdeState = IdeState emptyStage1 emptyStage2 emptyStage3 +emptyIdeState = IdeState emptyFileState emptyVolatileState -emptyStage1 :: Stage1 -emptyStage1 = Stage1 M.empty M.empty +emptyFileState :: IdeFileState +emptyFileState = IdeFileState M.empty M.empty -emptyStage2 :: Stage2 -emptyStage2 = Stage2 (AstData M.empty) +emptyVolatileState :: IdeVolatileState +emptyVolatileState = IdeVolatileState (AstData M.empty) M.empty Nothing -emptyStage3 :: Stage3 -emptyStage3 = Stage3 M.empty Nothing -data Stage1 = Stage1 - { s1Externs :: ModuleMap P.ExternsFile - , s1Modules :: ModuleMap (P.Module, FilePath) +-- | @IdeFileState@ holds data that corresponds 1-to-1 to an entity on the +-- filesystem. Externs correspond to the ExternsFiles the compiler emits into +-- the output folder, and modules are parsed ASTs from source files. This means, +-- that we can update single modules or ExternsFiles inside this state whenever +-- the corresponding entity changes on the file system. +data IdeFileState = IdeFileState + { fsExterns :: ModuleMap P.ExternsFile + , fsModules :: ModuleMap (P.Module, FilePath) } deriving (Show) -data Stage2 = Stage2 - { s2AstData :: AstData P.SourceSpan - } deriving (Show, Eq) - -data Stage3 = Stage3 - { s3Declarations :: ModuleMap [IdeDeclarationAnn] - , s3CachedRebuild :: Maybe (P.ModuleName, P.ExternsFile) +-- | @IdeVolatileState@ is derived from the @IdeFileState@ and needs to be +-- invalidated and refreshed carefully. It holds @AstData@, which is the data we +-- extract from the parsed ASTs, as well as the IdeDeclarations, which contain +-- lots of denormalized data, so they need to fully rebuilt whenever +-- @IdeFileState@ changes. The vsCachedRebuild field can hold a rebuild result +-- with open imports which is used to provide completions for module private +-- declarations +data IdeVolatileState = IdeVolatileState + { vsAstData :: AstData P.SourceSpan + , vsDeclarations :: ModuleMap [IdeDeclarationAnn] + , vsCachedRebuild :: Maybe (P.ModuleName, P.ExternsFile) } deriving (Show) newtype Match a = Match (P.ModuleName, a) diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs index a966679b06..9d42ef9e38 100644 --- a/src/Language/PureScript/Ide/Watcher.hs +++ b/src/Language/PureScript/Ide/Watcher.hs @@ -39,7 +39,7 @@ reloadFile logLevel ref ev = runLogger logLevel $ do Left err -> logErrorN ("Failed to reload file at: " <> toS fp <> " with error: " <> show err) Right ef -> do - lift $ void $ atomically (insertExternsSTM ref ef *> populateStage3STM ref) + lift $ void $ atomically (insertExternsSTM ref ef *> populateVolatileStateSTM ref) logDebugN ("Reloaded File at: " <> toS fp) -- | Installs filewatchers for the given directory and reloads ExternsFiles when diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 1b7c7014f2..14256d9a4e 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -94,7 +94,7 @@ getLocation s = do runIde' defConfig ideState [Type s [] Nothing] pure (complLocation c) where - ideState = emptyIdeState `s3` + ideState = emptyIdeState `volatileState` [ ("Test", [ ideValue "sfValue" Nothing `annLoc` valueSS , ideSynonym "SFType" P.tyString P.kindType `annLoc` synonymSS diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index ba5908f928..afe734bbdb 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -17,14 +17,14 @@ import System.Process import qualified Language.PureScript as P -defConfig :: Configuration +defConfig :: IdeConfiguration defConfig = - Configuration { confLogLevel = LogNone + IdeConfiguration { confLogLevel = LogNone , confOutputPath = "output/" , confGlobs = ["src/*.purs"] } -runIde' :: Configuration -> IdeState -> [Command] -> IO ([Either IdeError Success], IdeState) +runIde' :: IdeConfiguration -> IdeState -> [Command] -> IO ([Either IdeError Success], IdeState) runIde' conf s cs = do stateVar <- newTVarIO s let env' = IdeEnvironment {ideStateVar = stateVar, ideConfiguration = conf} @@ -35,11 +35,11 @@ runIde' conf s cs = do runIde :: [Command] -> IO ([Either IdeError Success], IdeState) runIde = runIde' defConfig emptyIdeState -s3 :: IdeState -> [(Text, [IdeDeclarationAnn])] -> IdeState -s3 s ds = - s {ideStage3 = stage3} +volatileState :: IdeState -> [(Text, [IdeDeclarationAnn])] -> IdeState +volatileState s ds = + s {ideVolatileState = vs} where - stage3 = Stage3 (Map.fromList decls) Nothing + vs = IdeVolatileState (AstData Map.empty) (Map.fromList decls) Nothing decls = map (first P.moduleNameFromString) ds -- | Adding Annotations to IdeDeclarations From 8effb1402be50460ba0d7d0cea90613a2b7fb237 Mon Sep 17 00:00:00 2001 From: Jens Krause Date: Sun, 21 May 2017 21:16:32 +0200 Subject: [PATCH 0788/1580] Update `build` command to run test (#2901) * Update `build` command to run test of example test files * Pass flags for `purs` to `stack` by using `--` See https://github.com/commercialhaskell/stack/blob/master/doc/GUIDE.md#exec --- CONTRIBUTING.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index c76781e699..da40134ebf 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -23,7 +23,7 @@ To build and run a specific test in `examples/passing/` or `examples/failing/`, ``` bash # Build -stack exec psc -- 'tests/support/bower_components/purescript-*/src/**/*.purs' examples/blah/Blah.purs +stack exec purs -- compile 'tests/support/bower_components/purescript-*/src/**/*.purs' examples/blah/Blah.purs # Run node -e "require('./output/Main/').main()" From 0a6de6ec9431df0b01d00e9dd10aaade0aee043a Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 22 May 2017 19:31:25 -0600 Subject: [PATCH 0789/1580] [purs ide] Work around laziness when measuring command perf (#2905) * [purs ide] Work around laziness when measuring command perf * reduce duplication --- app/Command/Ide.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index 8b3dcf1430..76ad796d9d 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -164,15 +164,16 @@ startServer port env = withSocketsDo $ do case decodeT cmd of Just cmd' -> do let message duration = - "Command " <> commandName cmd' - <> " took " - <> displayTimeSpec duration - result <- logPerf message (runExceptT (handleCommand cmd')) - -- $(logDebug) ("Answer was: " <> T.pack (show result)) + "Command " + <> commandName cmd' + <> " took " + <> displayTimeSpec duration + logPerf message $ do + result <- runExceptT (handleCommand cmd') + liftIO $ catchGoneHandle $ BSL8.hPutStrLn h $ case result of + Right r -> Aeson.encode r + Left err -> Aeson.encode err liftIO (hFlush stdout) - case result of - Right r -> liftIO $ catchGoneHandle (BSL8.hPutStrLn h (Aeson.encode r)) - Left err -> liftIO $ catchGoneHandle (BSL8.hPutStrLn h (Aeson.encode err)) Nothing -> do $(logError) ("Parsing the command failed. Command: " <> cmd) liftIO $ do From ca349dd468e0eb724cb8512939f8de393d48909f Mon Sep 17 00:00:00 2001 From: Jens Krause Date: Sat, 27 May 2017 21:49:39 +0200 Subject: [PATCH 0790/1580] Disallow `forall` within constraints (#2874) (#2900) * Disallow `forall` within constraints (#2874) Fix crashes by defining `forall` within class's or instance's constraint as reported in #2874 * Fix tests (#2874) * Update `purscript.cabal` with latest example files of failing tests (#2874) --- examples/failing/2874-forall.purs | 8 ++++++++ examples/failing/2874-forall2.purs | 10 ++++++++++ examples/failing/2874-wildcard.purs | 11 +++++++++++ purescript.cabal | 3 +++ src/Language/PureScript/Parser/Declarations.hs | 2 +- src/Language/PureScript/Parser/Types.hs | 11 +++++++++++ src/Language/PureScript/Types.hs | 7 +++++++ 7 files changed, 51 insertions(+), 1 deletion(-) create mode 100644 examples/failing/2874-forall.purs create mode 100644 examples/failing/2874-forall2.purs create mode 100644 examples/failing/2874-wildcard.purs diff --git a/examples/failing/2874-forall.purs b/examples/failing/2874-forall.purs new file mode 100644 index 0000000000..0bb935e500 --- /dev/null +++ b/examples/failing/2874-forall.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +class T a b | a -> b +instance tT :: (T Int (forall a. a)) => T Int String + +ddd :: Int +ddd = 0 :: forall t. T Int t => Int diff --git a/examples/failing/2874-forall2.purs b/examples/failing/2874-forall2.purs new file mode 100644 index 0000000000..704aca29f5 --- /dev/null +++ b/examples/failing/2874-forall2.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +class X a b | a -> b +class X a (forall t. t) <= Y a b | a -> b +instance tX :: X Int String +instance tY :: Y Int Boolean + +ggg :: Int +ggg = 0 :: forall t. Y Int t => Int diff --git a/examples/failing/2874-wildcard.purs b/examples/failing/2874-wildcard.purs new file mode 100644 index 0000000000..d5f001e086 --- /dev/null +++ b/examples/failing/2874-wildcard.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +class Foo a where + foo :: a + +class Baz b where + baz :: b + +instance bazFoo :: (Baz _) => Foo b where + foo = baz diff --git a/purescript.cabal b/purescript.cabal index aa1c136a15..f1d3bfe020 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -86,6 +86,9 @@ extra-source-files: examples/failing/2601.purs examples/failing/2616.purs examples/failing/2806.purs + examples/failing/2874-forall.purs + examples/failing/2874-forall2.purs + examples/failing/2874-wildcard.purs examples/failing/365.purs examples/failing/438.purs examples/failing/881.purs diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index a66370c8b8..0857d578c4 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -195,7 +195,7 @@ parseTypeClassDeclaration = do parseConstraint :: TokenParser Constraint parseConstraint = Constraint <$> parseQualified properName - <*> P.many (noWildcards parseTypeAtom) + <*> P.many (noWildcards $ noForAll parseTypeAtom) <*> pure Nothing parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 2cf90da892..3a9803c7bd 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -1,6 +1,7 @@ module Language.PureScript.Parser.Types ( parseType , parsePolyType + , noForAll , noWildcards , parseTypeAtom ) where @@ -52,6 +53,16 @@ parseForAll :: TokenParser Type parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (indented *> identifier) <* indented <* dot) <*> parseType + +-- | +-- Parse an atomic type with no `forall` +-- +noForAll :: TokenParser Type -> TokenParser Type +noForAll p = do + ty <- p + when (containsForAll ty) $ P.unexpected "forall" + return ty + -- | -- Parse a type as it appears in e.g. a data constructor -- diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 3bc2899b0f..d600bf47f7 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -216,6 +216,13 @@ containsWildcards = everythingOnTypes (||) go where go TypeWildcard{} = True go _ = False +-- | Check if a type contains `forall` +containsForAll :: Type -> Bool +containsForAll = everythingOnTypes (||) go where + go :: Type -> Bool + go ForAll{} = True + go _ = False + everywhereOnTypes :: (Type -> Type) -> Type -> Type everywhereOnTypes f = go where go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2)) From 3a9fec56d1fdbeaad2a98f78eb1a22b361404a3b Mon Sep 17 00:00:00 2001 From: Hyunje Jun Date: Tue, 30 May 2017 15:02:37 +0900 Subject: [PATCH 0791/1580] Parse support modules from actual test support purs (#2916) * Parse support modules from actual test support purs * Use [Text] for supportModules instead of [String] * Get rid of unsafePerformIO Separate supportModules into getSupportModuleTuples and getSupportModuleNames, and make them IO actions. --- tests/TestCompiler.hs | 81 ++++++++-------- tests/TestPsci/CompletionTest.hs | 18 ++-- tests/TestUtils.hs | 156 ++++++------------------------- 3 files changed, 75 insertions(+), 180 deletions(-) diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 86a6ef31c5..de8f19f854 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -61,26 +61,23 @@ main = hspec spec spec :: Spec spec = do - (supportExterns, supportForeigns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do + (supportModules, supportExterns, supportForeigns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do cwd <- getCurrentDirectory let passing = cwd "examples" "passing" let warning = cwd "examples" "warning" let failing = cwd "examples" "failing" - let supportDir = cwd "tests" "support" "bower_components" - let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir passingFiles <- getTestFiles passing <$> testGlob passing warningFiles <- getTestFiles warning <$> testGlob warning failingFiles <- getTestFiles failing <$> testGlob failing - supportPurs <- supportFiles "purs" - supportPursFiles <- readInput supportPurs + ms <- getSupportModuleTuples + let modules = map snd ms supportExterns <- runExceptT $ do - modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles - foreigns <- inferForeignModules modules - externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules) - return (zip (map snd modules) externs, foreigns) + foreigns <- inferForeignModules ms + externs <- ExceptT . fmap fst . runTest $ P.make (makeActions modules foreigns) modules + return (externs, foreigns) case supportExterns of Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) - Right (externs, foreigns) -> return (externs, foreigns, passingFiles, warningFiles, failingFiles) + Right (externs, foreigns) -> return (modules, externs, foreigns, passingFiles, warningFiles, failingFiles) outputFile <- runIO $ do tmp <- getTemporaryDirectory @@ -90,21 +87,21 @@ spec = do context "Passing examples" $ forM_ passingTestCases $ \testPurs -> it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ - assertCompiles supportExterns supportForeigns testPurs outputFile + assertCompiles supportModules supportExterns supportForeigns testPurs outputFile context "Warning examples" $ forM_ warningTestCases $ \testPurs -> do let mainPath = getTestMain testPurs expectedWarnings <- runIO $ getShouldWarnWith mainPath it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $ - assertCompilesWithWarnings supportExterns supportForeigns testPurs expectedWarnings + assertCompilesWithWarnings supportModules supportExterns supportForeigns testPurs expectedWarnings context "Failing examples" $ forM_ failingTestCases $ \testPurs -> do let mainPath = getTestMain testPurs expectedFailures <- runIO $ getShouldFailWith mainPath it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ - assertDoesNotCompile supportExterns supportForeigns testPurs expectedFailures + assertDoesNotCompile supportModules supportExterns supportForeigns testPurs expectedFailures where @@ -168,18 +165,18 @@ trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse modulesDir :: FilePath modulesDir = ".test_modules" "node_modules" -makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make -makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False) - { P.getInputTimestamp = getInputTimestamp - , P.getOutputTimestamp = getOutputTimestamp - } +makeActions :: [P.Module] -> M.Map P.ModuleName FilePath -> P.MakeActions P.Make +makeActions modules foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False) + { P.getInputTimestamp = getInputTimestamp + , P.getOutputTimestamp = getOutputTimestamp + } where getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime)) getInputTimestamp mn - | isSupportModule (T.unpack (P.runModuleName mn)) = return (Left P.RebuildNever) + | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever) | otherwise = return (Left P.RebuildAlways) where - isSupportModule = flip elem supportModules + isSupportModule = flip elem (map (P.runModuleName . P.getModuleName) modules) getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime) getOutputTimestamp mn = do @@ -187,39 +184,36 @@ makeActions foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActi exists <- liftIO $ doesDirectoryExist filePath return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing) -readInput :: [FilePath] -> IO [(FilePath, T.Text)] -readInput inputFiles = forM inputFiles $ \inputFile -> do - text <- readUTF8FileT inputFile - return (inputFile, text) - runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors) runTest = P.runMake P.defaultOptions compile - :: [(P.Module, P.ExternsFile)] + :: [P.Module] + -> [P.ExternsFile] -> M.Map P.ModuleName FilePath -> [FilePath] -> ([P.Module] -> IO ()) -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) -compile supportExterns supportForeigns inputFiles check = silence $ runTest $ do +compile supportModules supportExterns supportForeigns inputFiles check = silence $ runTest $ do fs <- liftIO $ readInput inputFiles ms <- P.parseModulesFromFiles id fs foreigns <- inferForeignModules ms liftIO (check (map snd ms)) - let actions = makeActions (foreigns `M.union` supportForeigns) + let actions = makeActions supportModules (foreigns `M.union` supportForeigns) case ms of - [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule) - _ -> P.make actions (map fst supportExterns ++ map snd ms) + [singleModule] -> pure <$> P.rebuildModule actions supportExterns (snd singleModule) + _ -> P.make actions (supportModules ++ map snd ms) assert - :: [(P.Module, P.ExternsFile)] + :: [P.Module] + -> [P.ExternsFile] -> M.Map P.ModuleName FilePath -> [FilePath] -> ([P.Module] -> IO ()) -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String)) -> Expectation -assert supportExterns supportForeigns inputFiles check f = do - (e, w) <- compile supportExterns supportForeigns inputFiles check +assert supportModules supportExterns supportForeigns inputFiles check f = do + (e, w) <- compile supportModules supportExterns supportForeigns inputFiles check maybeErr <- f (const w <$> e) maybe (return ()) expectationFailure maybeErr @@ -236,13 +230,14 @@ checkShouldFailWith expected errs = else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual assertCompiles - :: [(P.Module, P.ExternsFile)] + :: [P.Module] + -> [P.ExternsFile] -> M.Map P.ModuleName FilePath -> [FilePath] -> Handle -> Expectation -assertCompiles supportExterns supportForeigns inputFiles outputFile = - assert supportExterns supportForeigns inputFiles checkMain $ \e -> +assertCompiles supportModules supportExterns supportForeigns inputFiles outputFile = + assert supportModules supportExterns supportForeigns inputFiles checkMain $ \e -> case e of Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do @@ -262,13 +257,14 @@ assertCompiles supportExterns supportForeigns inputFiles outputFile = Nothing -> return $ Just "Couldn't find node.js executable" assertCompilesWithWarnings - :: [(P.Module, P.ExternsFile)] + :: [P.Module] + -> [P.ExternsFile] -> M.Map P.ModuleName FilePath -> [FilePath] -> [String] -> Expectation -assertCompilesWithWarnings supportExterns supportForeigns inputFiles shouldWarnWith = - assert supportExterns supportForeigns inputFiles checkMain $ \e -> +assertCompilesWithWarnings supportModules supportExterns supportForeigns inputFiles shouldWarnWith = + assert supportModules supportExterns supportForeigns inputFiles checkMain $ \e -> case e of Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs @@ -282,13 +278,14 @@ assertCompilesWithWarnings supportExterns supportForeigns inputFiles shouldWarnW (<> "\n\n" <> P.prettyPrintMultipleErrors P.defaultPPEOptions warnings) assertDoesNotCompile - :: [(P.Module, P.ExternsFile)] + :: [P.Module] + -> [P.ExternsFile] -> M.Map P.ModuleName FilePath -> [FilePath] -> [String] -> Expectation -assertDoesNotCompile supportExterns supportForeigns inputFiles shouldFailWith = - assert supportExterns supportForeigns inputFiles noPreCheck $ \e -> +assertDoesNotCompile supportModules supportExterns supportForeigns inputFiles shouldFailWith = + assert supportModules supportExterns supportForeigns inputFiles noPreCheck $ \e -> case e of Left errs -> return $ if null shouldFailWith diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index 35b05e6e15..fef5f7b11c 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module TestPsci.CompletionTest where import Prelude () @@ -13,17 +14,18 @@ import qualified Language.PureScript as P import Language.PureScript.Interactive import System.Console.Haskeline import TestPsci.TestEnv (initTestPSCiEnv) -import TestUtils (supportModules) +import TestUtils (getSupportModuleNames) completionTests :: Spec -completionTests = context "completionTests" $ - mapM_ assertCompletedOk completionTestData +completionTests = context "completionTests" $ do + mns <- runIO $ getSupportModuleNames + mapM_ assertCompletedOk (completionTestData mns) -- If the cursor is at the right end of the line, with the 1st element of the -- pair as the text in the line, then pressing tab should offer all the -- elements of the list (which is the 2nd element) as completions. -completionTestData :: [(String, [String])] -completionTestData = +completionTestData :: [T.Text] -> [(String, [String])] +completionTestData supportModuleNames = -- basic directives [ (":h", [":help"]) , (":r", [":reload"]) @@ -65,7 +67,7 @@ completionTestData = -- a few other import tests , ("impor", ["import"]) - , ("import ", map ("import " ++) supportModules) + , ("import ", map (T.unpack . mappend "import ") supportModuleNames) , ("import Prelude ", []) -- String and number literals should not be completed @@ -99,10 +101,10 @@ runCM act = do getPSCiStateForCompletion :: IO PSCiState getPSCiStateForCompletion = do (PSCiState _ bs es, _) <- initTestPSCiEnv - let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName (T.pack "Prelude")], P.Implicit, Nothing)] + let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)] return $ PSCiState imports bs es controlMonadSTasST :: ImportedModule controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST")) where - s = P.moduleNameFromString . T.pack + s = P.moduleNameFromString diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index cd1847e0ac..9c3a69278f 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -5,14 +5,21 @@ module TestUtils where import Prelude () import Prelude.Compat +import qualified Language.PureScript as P + import Control.Monad +import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Exception - +import Data.List (sort) +import qualified Data.Text as T import System.Process import System.Directory import System.Info +import System.IO.UTF8 (readUTF8FileT) import System.Exit (exitFailure) +import System.FilePath (()) +import qualified System.FilePath.Glob as Glob import System.IO (stderr, hPutStrLn) findNodeProcess :: IO (Maybe String) @@ -47,139 +54,28 @@ updateSupportCode = do hPutStrLn stderr "Cannot find node (or nodejs) executable" exitFailure +readInput :: [FilePath] -> IO [(FilePath, T.Text)] +readInput inputFiles = forM inputFiles $ \inputFile -> do + text <- readUTF8FileT inputFile + return (inputFile, text) + -- | -- The support modules that should be cached between test cases, to avoid -- excessive rebuilding. -- -supportModules :: [String] -supportModules = - [ "Control.Alt" - , "Control.Alternative" - , "Control.Applicative" - , "Control.Apply" - , "Control.Biapplicative" - , "Control.Biapply" - , "Control.Bind" - , "Control.Category" - , "Control.Comonad" - , "Control.Extend" - , "Control.Lazy" - , "Control.Monad" - , "Control.Monad.Eff" - , "Control.Monad.Eff.Class" - , "Control.Monad.Eff.Console" - , "Control.Monad.Eff.Uncurried" - , "Control.Monad.Eff.Unsafe" - , "Control.Monad.Gen" - , "Control.Monad.Gen.Class" - , "Control.Monad.Gen.Common" - , "Control.Monad.Rec.Class" - , "Control.Monad.ST" - , "Control.MonadPlus" - , "Control.MonadZero" - , "Control.Plus" - , "Control.Semigroupoid" - , "Data.Array" - , "Data.Array.Partial" - , "Data.Array.ST" - , "Data.Array.ST.Iterator" - , "Data.Bifoldable" - , "Data.Bifunctor" - , "Data.Bifunctor.Clown" - , "Data.Bifunctor.Flip" - , "Data.Bifunctor.Join" - , "Data.Bifunctor.Joker" - , "Data.Bifunctor.Product" - , "Data.Bifunctor.Wrap" - , "Data.Bitraversable" - , "Data.Boolean" - , "Data.BooleanAlgebra" - , "Data.Bounded" - , "Data.Char" - , "Data.Char.Gen" - , "Data.CommutativeRing" - , "Data.Either" - , "Data.Either.Nested" - , "Data.Eq" - , "Data.EuclideanRing" - , "Data.Field" - , "Data.Foldable" - , "Data.Function" - , "Data.Function.Uncurried" - , "Data.Functor" - , "Data.Functor.Invariant" - , "Data.Generic" - , "Data.Generic.Rep" - , "Data.Generic.Rep.Bounded" - , "Data.Generic.Rep.Eq" - , "Data.Generic.Rep.Monoid" - , "Data.Generic.Rep.Ord" - , "Data.Generic.Rep.Semigroup" - , "Data.Generic.Rep.Show" - , "Data.HeytingAlgebra" - , "Data.Identity" - , "Data.Int" - , "Data.Int.Bits" - , "Data.Lazy" - , "Data.List" - , "Data.List.Lazy" - , "Data.List.Lazy.NonEmpty" - , "Data.List.Lazy.Types" - , "Data.List.NonEmpty" - , "Data.List.Partial" - , "Data.List.Types" - , "Data.List.ZipList" - , "Data.Maybe" - , "Data.Maybe.First" - , "Data.Maybe.Last" - , "Data.Monoid" - , "Data.Monoid.Additive" - , "Data.Monoid.Alternate" - , "Data.Monoid.Conj" - , "Data.Monoid.Disj" - , "Data.Monoid.Dual" - , "Data.Monoid.Endo" - , "Data.Monoid.Multiplicative" - , "Data.NaturalTransformation" - , "Data.Newtype" - , "Data.NonEmpty" - , "Data.Ord" - , "Data.Ord.Unsafe" - , "Data.Ordering" - , "Data.Ring" - , "Data.Semigroup" - , "Data.Semiring" - , "Data.Show" - , "Data.String" - , "Data.String.CaseInsensitive" - , "Data.String.Gen" - , "Data.String.Regex" - , "Data.String.Regex.Flags" - , "Data.String.Regex.Unsafe" - , "Data.String.Unsafe" - , "Data.Symbol" - , "Data.Traversable" - , "Data.Tuple" - , "Data.Tuple.Nested" - , "Data.Unfoldable" - , "Data.Unit" - , "Data.Void" - , "Global" - , "Global.Unsafe" - , "Math" - , "PSCI.Support" - , "Partial" - , "Partial.Unsafe" - , "Prelude" - , "Test.Assert" - , "Type.Data.Ordering" - , "Type.Data.Symbol" - , "Type.Equality" - , "Type.Row.Effect.Equality" - , "Type.Prelude" - , "Type.Proxy" - , "Unsafe.Coerce" - ] +getSupportModuleTuples :: IO [(FilePath, P.Module)] +getSupportModuleTuples = do + cd <- getCurrentDirectory + let supportDir = cd "tests" "support" "bower_components" + supportPurs <- Glob.globDir1 (Glob.compile "purescript-*/src/**/*.purs") supportDir + supportPursFiles <- readInput supportPurs + modules <- runExceptT $ ExceptT . return $ P.parseModulesFromFiles id supportPursFiles + case modules of + Right ms -> return ms + Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) + +getSupportModuleNames :: IO [T.Text] +getSupportModuleNames = sort . map (P.runModuleName . P.getModuleName . snd) <$> getSupportModuleTuples pushd :: forall a. FilePath -> IO a -> IO a pushd dir act = do From ee636e2e091464535756f09b4d2caa3548165bea Mon Sep 17 00:00:00 2001 From: Dominick Gendill Date: Tue, 30 May 2017 11:53:46 -0600 Subject: [PATCH 0792/1580] Encode PSCI's server content as utf-8 string (#2918) * Encode server content as UTF8 when serving * Added name to CONTRIBUTORS * Removed unneeded semicolon in content type. --- CONTRIBUTORS.md | 1 + app/Command/REPL.hs | 11 ++++++----- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 4849f2df78..e653c77107 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -36,6 +36,7 @@ If you would prefer to use different terms, please use the section below instead | [@davidchambers](https://github.com/davidchambers) | David Chambers | [MIT license](http://opensource.org/licenses/MIT) | | [@DavidLindbom](https://github.com/DavidLindbom) | David Lindbom | [MIT license](http://opensource.org/licenses/MIT) | | [@dckc](https://github.com/dckc) | Dan Connolly | [MIT license](http://opensource.org/licenses/MIT) | +| [@kleeneplus](https://github.com/dgendill) | Dominick Gendill | [MIT license](http://opensource.org/licenses/MIT) | | [@eamelink](https://github.com/eamelink) | Erik Bakker | MIT license | | [@epost](https://github.com/epost) | Erik Post | MIT license | | [@erdeszt](https://github.com/erdeszt) | Tibor Erdesz | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 5e29a1af5f..9b8ad1269e 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -53,6 +53,7 @@ import System.Directory (doesFileExist, getCurrentDirectory) import System.FilePath (()) import System.FilePath.Glob (glob) import System.Process (readProcessWithExitCode) +import qualified Data.ByteString.Lazy.UTF8 as U -- | Command line options data PSCiOptions = PSCiOptions @@ -206,12 +207,12 @@ browserBackend serverPort = Backend setup evaluate reload shutdown case Wai.pathInfo req of [] -> respond $ Wai.responseLBS status200 - [(hContentType, "text/html")] - indexPage + [(hContentType, "text/html; charset=UTF-8")] + (U.fromString indexPage) ["js", "index.js"] -> respond $ Wai.responseLBS status200 [(hContentType, "application/javascript")] - indexJS + (U.fromString indexJS) ["js", "latest.js"] -> do may <- readTVarIO indexJs case may of @@ -224,7 +225,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown , (hPragma, "no-cache") , (hExpires, "0") ] - (fromString js) + (U.fromString js) ["js", "bundle.js"] -> do may <- readTVarIO bundleJs case may of @@ -233,7 +234,7 @@ browserBackend serverPort = Backend setup evaluate reload shutdown Just js -> respond $ Wai.responseLBS status200 [ (hContentType, "application/javascript")] - (fromString js) + (U.fromString js) _ -> respond $ Wai.responseLBS status404 [] "Not found" let browserState = BrowserState cmdChan shutdownVar indexJs bundleJs From c9156b47e28b99a4291c72ee5635982ad3df4666 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 30 May 2017 20:28:57 +0200 Subject: [PATCH 0793/1580] [purs-ide] Resolve synonyms and kinds (#2917) * [purs ide] Resolves kinds and synonym reexports Fixes #2909 * [purs ide] Adds tests for synonym and kind reexports --- src/Language/PureScript/Ide/Reexports.hs | 8 ++++++-- tests/Language/PureScript/Ide/ReexportsSpec.hs | 9 +++++++-- tests/Language/PureScript/Ide/SourceFileSpec.hs | 2 +- tests/Language/PureScript/Ide/Test.hs | 4 ++-- 4 files changed, 16 insertions(+), 7 deletions(-) diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index e26ee48abe..f36f04e596 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -93,8 +93,10 @@ resolveRef -> Either P.DeclarationRef [IdeDeclarationAnn] resolveRef decls ref = case ref of P.TypeRef tn mdtors -> - case findRef (anyOf (_IdeDeclType . ideTypeName) (== tn)) of - Nothing -> Left ref + case findRef (anyOf (_IdeDeclType . ideTypeName) (== tn)) + <|> findRef (anyOf (_IdeDeclTypeSynonym . ideSynonymName) (== tn)) of + Nothing -> + Left ref Just d -> Right $ d : case mdtors of Nothing -> -- If the dataconstructor field inside the TypeRef is Nothing, that @@ -110,6 +112,8 @@ resolveRef decls ref = case ref of findWrapped (anyOf (_IdeDeclTypeOperator . ideTypeOpName) (== name)) P.TypeClassRef name -> findWrapped (anyOf (_IdeDeclTypeClass . ideTCName) (== name)) + P.KindRef name -> + findWrapped (anyOf _IdeDeclKind (== name)) _ -> Left ref where diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index 198a08f2a3..2a6952e46e 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -11,16 +11,18 @@ import Language.PureScript.Ide.Test import qualified Language.PureScript as P import Test.Hspec -valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn +valueA, typeA, synonymA, classA, dtorA1, dtorA2, kindA :: IdeDeclarationAnn valueA = ideValue "valueA" Nothing typeA = ideType "TypeA" Nothing +synonymA = ideSynonym "SynonymA" Nothing Nothing classA = ideTypeClass "ClassA" P.kindType [] dtorA1 = ideDtor "DtorA1" "TypeA" Nothing dtorA2 = ideDtor "DtorA2" "TypeA" Nothing +kindA = ideKind "KindA" env :: ModuleMap [IdeDeclarationAnn] env = Map.fromList - [ (mn "A", [valueA, typeA, classA, dtorA1, dtorA2]) + [ (mn "A", [valueA, typeA, synonymA, classA, dtorA1, dtorA2, kindA]) ] type Refs = [(P.ModuleName, P.DeclarationRef)] @@ -32,7 +34,10 @@ succTestCases = , [(mn "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], [typeA `annExp` "A", dtorA1 `annExp` "A"]) , ("resolves a type reexport with implicit data constructors" , [(mn "A", P.TypeRef (P.ProperName "TypeA") Nothing)], map (`annExp` "A") [typeA, dtorA1, dtorA2]) + , ("resolves a synonym reexport" + , [(mn "A", P.TypeRef (P.ProperName "SynonymA") Nothing)], [synonymA `annExp` "A"]) , ("resolves a class reexport", [(mn "A", P.TypeClassRef (P.ProperName "ClassA"))], [classA `annExp` "A"]) + , ("resolves a kind reexport", [(mn "A", P.KindRef (P.ProperName "KindA"))], [kindA `annExp` "A"]) ] failTestCases :: [(Text, Refs)] diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 14256d9a4e..7937c0f595 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -97,7 +97,7 @@ getLocation s = do ideState = emptyIdeState `volatileState` [ ("Test", [ ideValue "sfValue" Nothing `annLoc` valueSS - , ideSynonym "SFType" P.tyString P.kindType `annLoc` synonymSS + , ideSynonym "SFType" Nothing Nothing `annLoc` synonymSS , ideType "SFData" Nothing `annLoc` typeSS , ideDtor "SFOne" "SFData" Nothing `annLoc` typeSS , ideDtor "SFTwo" "SFData" Nothing `annLoc` typeSS diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index afe734bbdb..8cb8d3eda9 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -66,8 +66,8 @@ ideValue i ty = ida (IdeDeclValue (IdeValue (P.Ident i) (fromMaybe P.tyString ty ideType :: Text -> Maybe P.Kind -> IdeDeclarationAnn ideType pn ki = ida (IdeDeclType (IdeType (P.ProperName pn) (fromMaybe P.kindType ki))) -ideSynonym :: Text -> P.Type -> P.Kind -> IdeDeclarationAnn -ideSynonym pn ty kind = ida (IdeDeclTypeSynonym (IdeTypeSynonym (P.ProperName pn) ty kind)) +ideSynonym :: Text -> Maybe P.Type -> Maybe P.Kind -> IdeDeclarationAnn +ideSynonym pn ty kind = ida (IdeDeclTypeSynonym (IdeTypeSynonym (P.ProperName pn) (fromMaybe P.tyString ty) (fromMaybe P.kindType kind))) ideTypeClass :: Text -> P.Kind -> [IdeInstance] -> IdeDeclarationAnn ideTypeClass pn kind instances = ida (IdeDeclTypeClass (IdeTypeClass (P.ProperName pn) kind instances)) From e1faee69263da34706db4d914c8dac0256bc4f23 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 31 May 2017 11:32:19 -0700 Subject: [PATCH 0794/1580] Disallow invalid newtype-derived instances (#2864) * Fix #2339, disallow invalid newtype-derived instances * Simplify things a bit. Use a warning, not an error. * Implement the check described in my comment * Make the test more complete using fundep info --- examples/passing/NewtypeInstance.purs | 20 +++- examples/warning/NewtypeInstance.purs | 8 ++ examples/warning/NewtypeInstance2.purs | 16 +++ examples/warning/NewtypeInstance3.purs | 22 ++++ examples/warning/NewtypeInstance4.purs | 24 ++++ src/Language/PureScript/AST/Declarations.hs | 2 + src/Language/PureScript/Errors.hs | 20 ++++ .../PureScript/Sugar/TypeClasses/Deriving.hs | 110 +++++++++++++++--- 8 files changed, 204 insertions(+), 18 deletions(-) create mode 100644 examples/warning/NewtypeInstance.purs create mode 100644 examples/warning/NewtypeInstance2.purs create mode 100644 examples/warning/NewtypeInstance3.purs create mode 100644 examples/warning/NewtypeInstance4.purs diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs index f7b9ea862e..1e01f710f9 100644 --- a/examples/passing/NewtypeInstance.purs +++ b/examples/passing/NewtypeInstance.purs @@ -3,15 +3,15 @@ module Main where import Prelude import Control.Monad.Eff import Control.Monad.Eff.Console +import Data.Monoid +import Data.Tuple type MyString = String newtype X = X MyString derive newtype instance showX :: Show X - derive newtype instance eqX :: Eq X - derive newtype instance ordX :: Ord X newtype Y a = Y (Array a) @@ -29,13 +29,27 @@ derive newtype instance singletonY :: Singleton a (Y a) newtype MyArray a = MyArray (Array a) derive newtype instance showMyArray :: Show a => Show (MyArray a) - derive newtype instance functorMyArray :: Functor MyArray newtype ProxyArray x a = ProxyArray (Array a) derive newtype instance functorProxyArray :: Functor (ProxyArray x) +class (Monad m, Monoid w) <= MonadWriter w m | m -> w where + tell :: w -> m Unit + +instance monadWriterTuple :: Monoid w => MonadWriter w (Tuple w) where + tell w = Tuple w unit + +newtype MyWriter w a = MyWriter (Tuple w a) + +derive newtype instance functorMyWriter :: Functor (MyWriter w) +derive newtype instance applyMyWriter :: Semigroup w => Apply (MyWriter w) +derive newtype instance applicativeMyWriter :: Monoid w => Applicative (MyWriter w) +derive newtype instance bindMyWriter :: Semigroup w => Bind (MyWriter w) +derive newtype instance monadMyWriter :: Monoid w => Monad (MyWriter w) +derive newtype instance monadWriterMyWriter :: Monoid w => MonadWriter w (MyWriter w) + main = do logShow (X "test") logShow (singleton "test" :: Y String) diff --git a/examples/warning/NewtypeInstance.purs b/examples/warning/NewtypeInstance.purs new file mode 100644 index 0000000000..944ee45415 --- /dev/null +++ b/examples/warning/NewtypeInstance.purs @@ -0,0 +1,8 @@ +-- @shouldWarnWith MissingNewtypeSuperclassInstance +module Main where + +import Prelude + +newtype X = X String + +derive newtype instance ordX :: Ord X diff --git a/examples/warning/NewtypeInstance2.purs b/examples/warning/NewtypeInstance2.purs new file mode 100644 index 0000000000..de5f56bb0a --- /dev/null +++ b/examples/warning/NewtypeInstance2.purs @@ -0,0 +1,16 @@ +-- @shouldWarnWith MissingNewtypeSuperclassInstance +module Main where + +import Prelude +import Data.Monoid (class Monoid) +import Data.Tuple (Tuple(..)) + +class (Monad m, Monoid w) <= MonadWriter w m | m -> w where + tell :: w -> m Unit + +instance monadWriterTuple :: Monoid w => MonadWriter w (Tuple w) where + tell w = Tuple w unit + +newtype MyWriter w a = MyWriter (Tuple w a) + +derive newtype instance monadWriterMyWriter :: Monoid w => MonadWriter w (MyWriter w) diff --git a/examples/warning/NewtypeInstance3.purs b/examples/warning/NewtypeInstance3.purs new file mode 100644 index 0000000000..7357d5b8c1 --- /dev/null +++ b/examples/warning/NewtypeInstance3.purs @@ -0,0 +1,22 @@ +-- @shouldWarnWith MissingNewtypeSuperclassInstance +module Main where + +import Prelude +import Data.Monoid (class Monoid) +import Data.Tuple (Tuple(..)) + +class (Monad m, Monoid w) <= MonadTell w m | m -> w where + tell :: w -> m Unit + +class (MonadTell w m) <= MonadWriter w m | m -> w where + listen :: forall a. m a -> m (Tuple w a) + +instance monadTellTuple :: Monoid w => MonadTell w (Tuple w) where + tell w = Tuple w unit + +instance monadWriterTuple :: Monoid w => MonadWriter w (Tuple w) where + listen (Tuple w a) = Tuple w (Tuple w a) + +newtype MyWriter w a = MyWriter (Tuple w a) + +derive newtype instance monadWriterMyWriter :: Monoid w => MonadWriter w (MyWriter w) diff --git a/examples/warning/NewtypeInstance4.purs b/examples/warning/NewtypeInstance4.purs new file mode 100644 index 0000000000..625d1d3ee1 --- /dev/null +++ b/examples/warning/NewtypeInstance4.purs @@ -0,0 +1,24 @@ +-- @shouldWarnWith UnverifiableSuperclassInstance +module Main where + +import Prelude +import Data.Monoid (class Monoid) +import Data.Tuple (Tuple(..)) + +class Monoid w <= MonadTell w m where + tell :: w -> m Unit + +class (MonadTell w m) <= MonadWriter w m where + listen :: forall a. m a -> m (Tuple w a) + +instance monadTellTuple :: Monoid w => MonadTell w (Tuple w) where + tell w = Tuple w unit + +instance monadWriterTuple :: Monoid w => MonadWriter w (Tuple w) where + listen (Tuple w a) = Tuple w (Tuple w a) + +newtype MyWriter w a = MyWriter (Tuple w a) + +-- No fundep means this is unverifiable +derive newtype instance monadTellMyWriter :: Monoid w => MonadTell w (MyWriter w) +derive newtype instance monadWriterMyWriter :: Monoid w => MonadWriter w (MyWriter w) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 97a684390d..c067e5afc9 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -109,6 +109,8 @@ data SimpleErrorMessage | InvalidDerivedInstance (Qualified (ProperName 'ClassName)) [Type] Int | ExpectedTypeConstructor (Qualified (ProperName 'ClassName)) [Type] Type | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type] + | MissingNewtypeSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [Type] + | UnverifiableSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [Type] | CannotFindDerivingType (ProperName 'TypeName) | DuplicateLabel Label (Maybe Expr) | DuplicateValueDeclaration Ident diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 3ff4bd5014..742640a0c3 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -121,6 +121,8 @@ errorCode em = case unwrapErrorMessage em of PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance" CannotDerive{} -> "CannotDerive" InvalidNewtypeInstance{} -> "InvalidNewtypeInstance" + MissingNewtypeSuperclassInstance{} -> "MissingNewtypeSuperclassInstance" + UnverifiableSuperclassInstance{} -> "UnverifiableSuperclassInstance" InvalidDerivedInstance{} -> "InvalidDerivedInstance" ExpectedTypeConstructor{} -> "ExpectedTypeConstructor" CannotFindDerivingType{} -> "CannotFindDerivingType" @@ -262,6 +264,8 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts gSimple (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts + gSimple (MissingNewtypeSuperclassInstance cl1 cl2 ts) = MissingNewtypeSuperclassInstance cl1 cl2 <$> traverse f ts + gSimple (UnverifiableSuperclassInstance cl1 cl2 ts) = UnverifiableSuperclassInstance cl1 cl2 <$> traverse f ts gSimple (InvalidDerivedInstance cl ts n) = InvalidDerivedInstance cl <$> traverse f ts <*> pure n gSimple (ExpectedTypeConstructor cl ts ty) = ExpectedTypeConstructor cl <$> traverse f ts <*> f ty gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k @@ -673,6 +677,22 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] , line "Make sure this is a newtype." ] + renderSimpleErrorMessage (MissingNewtypeSuperclassInstance su cl ts) = + paras [ line "The derived newtype instance for" + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName cl) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] + , line $ "does not include a derived superclass instance for " <> markCode (showQualified runProperName su) <> "." + ] + renderSimpleErrorMessage (UnverifiableSuperclassInstance su cl ts) = + paras [ line "The derived newtype instance for" + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName cl) + , Box.vcat Box.left (map typeAtomAsBox ts) + ] + , line $ "implies an superclass instance for " <> markCode (showQualified runProperName su) <> " which could not be verified." + ] renderSimpleErrorMessage (InvalidDerivedInstance nm ts argCount) = paras [ line "Cannot derive the type class instance" , markCodeBox $ indent $ Box.hsep 1 Box.left diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 68f48df920..7bfe373cb1 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -1,19 +1,21 @@ --- | --- This module implements the generic deriving elaboration that takes place during desugaring. --- +-- | This module implements the generic deriving elaboration that takes place during desugaring. module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where import Prelude.Compat +import Protolude (ordNub) import Control.Arrow (second) -import Control.Monad (replicateM, zipWithM) +import Control.Monad (replicateM, zipWithM, unless, when) import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Supply.Class (MonadSupply) +import Data.Foldable (for_) import Data.List (foldl', find, sortBy, unzip5) import qualified Data.Map as M import Data.Monoid ((<>)) import Data.Maybe (fromMaybe, mapMaybe) import Data.Ord (comparing) +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.AST @@ -30,15 +32,47 @@ import Language.PureScript.Types import Language.PureScript.TypeChecker (checkNewtype) import Language.PureScript.TypeChecker.Synonyms (SynonymMap, replaceAllTypeSynonymsM) +-- | When deriving an instance for a newtype, we must ensure that all superclass +-- instances were derived in the same way. This data structure is used to ensure +-- this property. +data NewtypeDerivedInstances = NewtypeDerivedInstances + { ndiClasses :: M.Map (ModuleName, ProperName 'ClassName) ([Text], [Constraint], [FunctionalDependency]) + -- ^ A list of superclass constraints for each type class. Since type classes + -- have not been desugared here, we need to track this. + , ndiDerivedInstances :: S.Set ((ModuleName, ProperName 'ClassName), (ModuleName, ProperName 'TypeName)) + -- ^ A list of newtype instances which were derived in this module. + } deriving Show + +instance Monoid NewtypeDerivedInstances where + mempty = NewtypeDerivedInstances mempty mempty + mappend x y = + NewtypeDerivedInstances { ndiClasses = ndiClasses x <> ndiClasses y + , ndiDerivedInstances = ndiDerivedInstances x <> ndiDerivedInstances y + } + +-- | Extract the name of the newtype appearing in the last type argument of +-- a derived newtype instance. +-- +-- Note: since newtypes in newtype instances can only be applied to type arguments +-- (no flexible instances allowed), we don't need to bother with unification when +-- looking for matching superclass instances, which saves us a lot of work. Instead, +-- we just match the newtype name. +extractNewtypeName :: ModuleName -> [Type] -> Maybe (ModuleName, ProperName 'TypeName) +extractNewtypeName _ [] = Nothing +extractNewtypeName mn xs = go (last xs) where + go (TypeApp ty (TypeVar _)) = go ty + go (TypeConstructor name) = Just (qualify mn name) + go _ = Nothing + -- | Elaborates deriving instance declarations by code generation. deriveInstances :: forall m - . (MonadError MultipleErrors m, MonadSupply m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => [ExternsFile] -> Module -> m Module deriveInstances externs (Module ss coms mn ds exts) = - Module ss coms mn <$> mapM (deriveInstance mn synonyms ds) ds <*> pure exts + Module ss coms mn <$> mapM (deriveInstance mn synonyms instanceData ds) ds <*> pure exts where -- We need to collect type synonym information, since synonyms will not be -- removed until later, during type checking. @@ -55,16 +89,34 @@ deriveInstances externs (Module ss coms mn ds exts) = fromLocalDecl (PositionedDeclaration _ _ d) = fromLocalDecl d fromLocalDecl _ = Nothing + instanceData :: NewtypeDerivedInstances + instanceData = + foldMap (\ExternsFile{..} -> foldMap (fromExternsDecl efModuleName) efDeclarations) externs <> foldMap fromLocalDecl ds + where + fromExternsDecl mn' EDClass{..} = + NewtypeDerivedInstances (M.singleton (mn', edClassName) (map fst edClassTypeArguments, edClassConstraints, edFunctionalDependencies)) mempty + fromExternsDecl mn' EDInstance{..} = + foldMap (\nm -> NewtypeDerivedInstances mempty (S.singleton (qualify mn' edInstanceClassName, nm))) (extractNewtypeName mn' edInstanceTypes) + fromExternsDecl _ _ = mempty + + fromLocalDecl (TypeClassDeclaration cl args cons deps _) = + NewtypeDerivedInstances (M.singleton (mn, cl) (map fst args, cons, deps)) mempty + fromLocalDecl (TypeInstanceDeclaration _ _ cl tys _) = + foldMap (\nm -> NewtypeDerivedInstances mempty (S.singleton (qualify mn cl, nm))) (extractNewtypeName mn tys) + fromLocalDecl (PositionedDeclaration _ _ d) = fromLocalDecl d + fromLocalDecl _ = mempty + -- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration, -- elaborates that into an instance declaration via code generation. deriveInstance - :: (MonadError MultipleErrors m, MonadSupply m) + :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => ModuleName -> SynonymMap + -> NewtypeDerivedInstances -> [Declaration] -> Declaration -> m Declaration -deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys DerivedInstance) +deriveInstance mn syns _ ds (TypeInstanceDeclaration nm deps className tys DerivedInstance) | className == Qualified (Just dataGeneric) (ProperName C.generic) = case tys of [ty] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty @@ -112,15 +164,15 @@ deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys Derived | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys actualTy _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 2 | otherwise = throwError . errorMessage $ CannotDerive className tys -deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys NewtypeInstance) = +deriveInstance mn syns ndis ds (TypeInstanceDeclaration nm deps className tys NewtypeInstance) = case tys of _ : _ | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys) , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance syns className ds tys tyCon args + -> TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance mn syns ndis className ds tys tyCon args | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys (last tys) _ -> throwError . errorMessage $ InvalidNewtypeInstance className tys -deriveInstance mn syns ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn syns ds d -deriveInstance _ _ _ e = return e +deriveInstance mn syns ndis ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn syns ndis ds d +deriveInstance _ _ _ _ e = return e unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type]) unwrapTypeConstructor = fmap (second reverse) . go @@ -133,15 +185,18 @@ unwrapTypeConstructor = fmap (second reverse) . go deriveNewtypeInstance :: forall m - . MonadError MultipleErrors m - => SynonymMap + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => ModuleName + -> SynonymMap + -> NewtypeDerivedInstances -> Qualified (ProperName 'ClassName) -> [Declaration] -> [Type] -> ProperName 'TypeName -> [Type] -> m Expr -deriveNewtypeInstance syns className ds tys tyConNm dargs = do +deriveNewtypeInstance mn syns ndis className ds tys tyConNm dargs = do + verifySuperclasses tyCon <- findTypeDecl tyConNm ds go tyCon where @@ -171,6 +226,31 @@ deriveNewtypeInstance syns className ds tys tyConNm dargs = do | arg == arg' = stripRight args t stripRight _ _ = Nothing + verifySuperclasses :: m () + verifySuperclasses = + for_ (M.lookup (qualify mn className) (ndiClasses ndis)) $ \(args, superclasses, _) -> + for_ superclasses $ \Constraint{..} -> do + let constraintClass' = qualify (error "verifySuperclasses: unknown class module") constraintClass + for_ (M.lookup constraintClass' (ndiClasses ndis)) $ \(_, _, deps) -> + -- We need to check whether the newtype is mentioned, because of classes like MonadWriter + -- with its Monoid superclass constraint. + when (not (null args) && any ((last args `elem`) . usedTypeVariables) constraintArgs) $ do + -- For now, we only verify superclasses where the newtype is the only argument, + -- or for which all other arguments are determined by functional dependencies. + -- Everything else raises a UnverifiableSuperclassInstance warning. + -- This covers pretty much all cases we're interested in, but later we might want to do + -- more work to extend this to other superclass relationships. + let determined = map (TypeVar . (args !!)) . ordNub . concatMap fdDetermined . filter ((== [length args - 1]) . fdDeterminers) $ deps + if last constraintArgs == TypeVar (last args) && all (`elem` determined) (init constraintArgs) + then do + -- Now make sure that a superclass instance was derived. Again, this is not a complete + -- check, since the superclass might have multiple type arguments, so overlaps might still + -- be possible, so we warn again. + for_ (extractNewtypeName mn tys) $ \nm -> + unless ((constraintClass', nm) `S.member` ndiDerivedInstances ndis) $ + tell . errorMessage $ MissingNewtypeSuperclassInstance constraintClass className tys + else tell . errorMessage $ UnverifiableSuperclassInstance constraintClass className tys + dataGeneric :: ModuleName dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] From 543a54f882897a52ed1e82c85c6b11be39aa21c8 Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Thu, 1 Jun 2017 05:49:46 +0900 Subject: [PATCH 0795/1580] Allow type signatures in instances (#2912) * Allow functions in instances to have signatures in the Parser. This fixes #2902. * Add some example files. * Change example dealing with general types to be passing. Add two more failing examples. --- examples/failing/InstanceSigsBodyIncorrect.purs | 10 ++++++++++ examples/failing/InstanceSigsDifferentTypes.purs | 10 ++++++++++ examples/failing/InstanceSigsIncorrectType.purs | 10 ++++++++++ .../failing/InstanceSigsOrphanTypeDeclaration.purs | 10 ++++++++++ examples/passing/InstanceSigs.purs | 12 ++++++++++++ examples/passing/InstanceSigsGeneral.purs | 12 ++++++++++++ purescript.cabal | 6 ++++++ src/Language/PureScript/Parser/Declarations.hs | 8 +++++++- 8 files changed, 77 insertions(+), 1 deletion(-) create mode 100644 examples/failing/InstanceSigsBodyIncorrect.purs create mode 100644 examples/failing/InstanceSigsDifferentTypes.purs create mode 100644 examples/failing/InstanceSigsIncorrectType.purs create mode 100644 examples/failing/InstanceSigsOrphanTypeDeclaration.purs create mode 100644 examples/passing/InstanceSigs.purs create mode 100644 examples/passing/InstanceSigsGeneral.purs diff --git a/examples/failing/InstanceSigsBodyIncorrect.purs b/examples/failing/InstanceSigsBodyIncorrect.purs new file mode 100644 index 0000000000..fd3c4370d5 --- /dev/null +++ b/examples/failing/InstanceSigsBodyIncorrect.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith TypesDoNotUnify + +module Main where + +class Foo a where + foo :: a + +instance fooNumber :: Foo Number where + foo :: Number + foo = true diff --git a/examples/failing/InstanceSigsDifferentTypes.purs b/examples/failing/InstanceSigsDifferentTypes.purs new file mode 100644 index 0000000000..0de2109d4d --- /dev/null +++ b/examples/failing/InstanceSigsDifferentTypes.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith TypesDoNotUnify + +module Main where + +class Foo a where + foo :: a + +instance fooNumber :: Foo Number where + foo :: Int + foo = 0.0 diff --git a/examples/failing/InstanceSigsIncorrectType.purs b/examples/failing/InstanceSigsIncorrectType.purs new file mode 100644 index 0000000000..f452f2ebb8 --- /dev/null +++ b/examples/failing/InstanceSigsIncorrectType.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith TypesDoNotUnify + +module Main where + +class Foo a where + foo :: a + +instance fooNumber :: Foo Number where + foo :: Boolean + foo = true diff --git a/examples/failing/InstanceSigsOrphanTypeDeclaration.purs b/examples/failing/InstanceSigsOrphanTypeDeclaration.purs new file mode 100644 index 0000000000..087111995e --- /dev/null +++ b/examples/failing/InstanceSigsOrphanTypeDeclaration.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith OrphanTypeDeclaration + +module Main where + +class Foo a where + foo :: a + +instance fooNumber :: Foo Number where + bar :: Int + foo = 0.0 diff --git a/examples/passing/InstanceSigs.purs b/examples/passing/InstanceSigs.purs new file mode 100644 index 0000000000..b3975a20e8 --- /dev/null +++ b/examples/passing/InstanceSigs.purs @@ -0,0 +1,12 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +class Foo a where + foo :: a + +instance fooNumber :: Foo Number where + foo :: Number + foo = 0.0 + +main = log "Done" diff --git a/examples/passing/InstanceSigsGeneral.purs b/examples/passing/InstanceSigsGeneral.purs new file mode 100644 index 0000000000..05901ad984 --- /dev/null +++ b/examples/passing/InstanceSigsGeneral.purs @@ -0,0 +1,12 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +class Eq a where + eq :: a -> a -> Boolean + +instance eqNumber :: Eq Number where + eq :: forall x y. x -> y -> Boolean + eq _ _ = true + +main = log "Done" diff --git a/purescript.cabal b/purescript.cabal index f1d3bfe020..9f8d272a9d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -188,6 +188,10 @@ extra-source-files: examples/failing/InfiniteType.purs examples/failing/InstanceExport.purs examples/failing/InstanceExport/InstanceExport.purs + examples/failing/InstanceSigsBodyIncorrect.purs + examples/failing/InstanceSigsDifferentTypes.purs + examples/failing/InstanceSigsIncorrectType.purs + examples/failing/InstanceSigsOrphanTypeDeclaration.purs examples/failing/IntOutOfRange.purs examples/failing/InvalidDerivedInstance.purs examples/failing/InvalidDerivedInstance2.purs @@ -402,6 +406,8 @@ extra-source-files: examples/passing/ImportQualified/M1.purs examples/passing/InferRecFunWithConstrainedArgument.purs examples/passing/InstanceBeforeClass.purs + examples/passing/InstanceSigs.purs + examples/passing/InstanceSigsGeneral.purs examples/passing/IntAndChar.purs examples/passing/iota.purs examples/passing/JSReserved.purs diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 0857d578c4..e72f5347d9 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -216,8 +216,14 @@ parseTypeInstanceDeclaration = do instanceDecl <- parseInstanceDeclaration members <- P.option [] $ do indented *> reserved "where" - mark (P.many (same *> positioned parseValueDeclaration)) + mark (P.many (same *> positioned declsInInstance)) return $ instanceDecl (ExplicitInstance members) + where + declsInInstance :: TokenParser Declaration + declsInInstance = P.choice + [ parseTypeDeclaration + , parseValueDeclaration + ] P. "type declaration or value declaration in instance" parseDerivingInstanceDeclaration :: TokenParser Declaration parseDerivingInstanceDeclaration = do From 2bd101dca9b6fadd975e32b2f759d22db87a7dcf Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 4 Jun 2017 08:40:38 +0200 Subject: [PATCH 0796/1580] [purs ide] Groups reexports in completions (#2907) * [purs ide] Groups reexports in completions Adds an option to control how reexport should be grouped in the completions. * adds exportedFrom field to completions * Simplify grouping If the groupReexports flag is set, we just treat every export as a reexport (Even from the origin module). This will require the editors to do a little more work, but makes the behaviours consistent and predictable. * yak shave * documents the new behaviour * update documentation --- psc-ide/PROTOCOL.md | 13 ++- src/Language/PureScript/Ide.hs | 6 +- src/Language/PureScript/Ide/Completion.hs | 110 +++++++++++++++--- src/Language/PureScript/Ide/Error.hs | 4 +- src/Language/PureScript/Ide/Filter.hs | 11 +- src/Language/PureScript/Ide/Types.hs | 8 +- src/Language/PureScript/Ide/Util.hs | 46 +++----- .../Language/PureScript/Ide/CompletionSpec.hs | 26 +++-- 8 files changed, 149 insertions(+), 75 deletions(-) diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index c508317602..eb12cebff7 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -81,7 +81,8 @@ The `complete` command looks up possible completions/corrections. "matcher": {..}, "currentModule": "Main", "options": { - "maxResults": 50 + "maxResults": 50, + "groupReexports": true } } } @@ -107,7 +108,8 @@ couldn't be extracted from a source file. "start": [1, 3], "end": [3, 1] }, - "documentation": "A filtering function" + "documentation": "A filtering function", + "exportedFrom": ["Data.Array"] } ] ``` @@ -614,6 +616,13 @@ Completion options allow to configure the number of returned completion results. If specified limits the number of completion results, otherwise return all results. +- groupReexports :: Maybe Boolean (defaults to False) + +If set to True, groups all reexports of an identifier under the module it +originated from (the original export is also treated as a "reexport"). These +reexports then populate the `exportedFrom` field in their completion results and +the `module` field contains the originating module. + ### Error Errors at this point are merely Error strings. Newlines are escaped like `\n` diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 7262422202..7d232e6e15 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -83,7 +83,7 @@ handleCommand c = case c of case rs of Right rs' -> answerRequest outfp rs' Left question -> - pure (CompletionResult (map (completionFromMatch . map withEmptyAnn) question)) + pure (CompletionResult (map (completionFromMatch . simpleExport . map withEmptyAnn) question)) Rebuild file -> rebuildFileAsync file RebuildSync file -> @@ -104,13 +104,13 @@ findCompletions -> m Success findCompletions filters matcher currentModule complOptions = do modules <- getAllModules currentModule - pure . CompletionResult . map completionFromMatch . getCompletions filters matcher complOptions $ modules + pure (CompletionResult (getCompletions filters matcher complOptions modules)) findType :: Ide m => Text -> [Filter] -> Maybe P.ModuleName -> m Success findType search filters currentModule = do modules <- getAllModules currentModule - pure . CompletionResult . map completionFromMatch . getExactMatches search filters $ modules + pure (CompletionResult (getExactCompletions search filters modules)) findPursuitCompletions :: MonadIO m => PursuitQuery -> m Success diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 10268f0f5c..0b81812d42 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -1,6 +1,9 @@ module Language.PureScript.Ide.Completion ( getCompletions , getExactMatches + , getExactCompletions + , simpleExport + , completionFromMatch , CompletionOptions(..) , defaultCompletionOptions , applyCompletionOptions @@ -8,11 +11,16 @@ module Language.PureScript.Ide.Completion import Protolude +import Control.Lens hiding ((&), op) import Data.Aeson +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Language.PureScript as P +import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine) import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types -import qualified Language.PureScript as P +import Language.PureScript.Ide.Util type Module = (P.ModuleName, [IdeDeclarationAnn]) @@ -23,37 +31,111 @@ getCompletions -> Matcher IdeDeclarationAnn -> CompletionOptions -> [Module] - -> [Match IdeDeclarationAnn] + -> [Completion] getCompletions filters matcher options modules = modules & applyFilters filters - & completionsFromModules + & matchesFromModules & runMatcher matcher & applyCompletionOptions options + <&> completionFromMatch getExactMatches :: Text -> [Filter] -> [Module] -> [Match IdeDeclarationAnn] getExactMatches search filters modules = - completionsFromModules (applyFilters (equalityFilter search : filters) modules) + modules + & applyFilters (equalityFilter search : filters) + & matchesFromModules -completionsFromModules :: [Module] -> [Match IdeDeclarationAnn] -completionsFromModules = foldMap completionFromModule +getExactCompletions :: Text -> [Filter] -> [Module] -> [Completion] +getExactCompletions search filters modules = + modules + & getExactMatches search filters + <&> simpleExport + <&> completionFromMatch + +matchesFromModules :: [Module] -> [Match IdeDeclarationAnn] +matchesFromModules = foldMap completionFromModule where completionFromModule (moduleName, decls) = map (\x -> Match (moduleName, x)) decls data CompletionOptions = CompletionOptions { coMaxResults :: Maybe Int + , coGroupReexports :: Bool } -defaultCompletionOptions :: CompletionOptions -defaultCompletionOptions = CompletionOptions { coMaxResults = Nothing } - -applyCompletionOptions :: CompletionOptions -> [a] -> [a] -applyCompletionOptions co = - maybe identity take (coMaxResults co) - instance FromJSON CompletionOptions where parseJSON = withObject "CompletionOptions" $ \o -> do maxResults <- o .:? "maxResults" - pure (CompletionOptions { coMaxResults = maxResults }) + groupReexports <- o .:? "groupReexports" .!= False + pure (CompletionOptions { coMaxResults = maxResults + , coGroupReexports = groupReexports + }) + +defaultCompletionOptions :: CompletionOptions +defaultCompletionOptions = CompletionOptions { coMaxResults = Nothing, coGroupReexports = False } + +applyCompletionOptions :: CompletionOptions -> [Match IdeDeclarationAnn] -> [(Match IdeDeclarationAnn, [P.ModuleName])] +applyCompletionOptions co decls = + maybe identity take (coMaxResults co) decls + & if coGroupReexports co + then groupCompletionReexports + else map simpleExport + +simpleExport :: Match a -> (Match a, [P.ModuleName]) +simpleExport match@(Match (moduleName, _)) = (match, [moduleName]) + +groupCompletionReexports :: [Match IdeDeclarationAnn] -> [(Match IdeDeclarationAnn, [P.ModuleName])] +groupCompletionReexports initial = + Map.elems (foldr go Map.empty initial) + where + go (Match (moduleName, d@(IdeDeclarationAnn ann decl))) = + let + origin = fromMaybe moduleName (ann^.annExportedFrom) + in + Map.alter + (insertDeclaration moduleName origin d) + (Namespaced (namespaceForDeclaration decl) + (P.runModuleName origin <> "." <> identifierFromIdeDeclaration decl)) + insertDeclaration moduleName origin d old = case old of + Nothing -> Just ( Match (origin, d & idaAnnotation.annExportedFrom .~ Nothing) + , [moduleName] + ) + Just x -> Just (second (moduleName :) x) + +data Namespaced a = Namespaced IdeNamespace a + deriving (Show, Eq, Ord) + +completionFromMatch :: (Match IdeDeclarationAnn, [P.ModuleName]) -> Completion +completionFromMatch (Match (m, IdeDeclarationAnn ann decl), mns) = + Completion {..} + where + (complIdentifier, complExpandedType) = case decl of + IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyPrintTypeSingleLine) + IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind) + IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyPrintTypeSingleLine) + IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyPrintTypeSingleLine) + IdeDeclTypeClass d -> (d ^. ideTCName . properNameT, d ^. ideTCKind & P.prettyPrintKind) + IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) -> + (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyPrintTypeSingleLine typeP) + IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) -> + (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) P.prettyPrintKind kind) + IdeDeclKind k -> (P.runProperName k, "kind") + + complExportedFrom = mns + + complModule = P.runModuleName m + + complType = maybe complExpandedType prettyPrintTypeSingleLine (_annTypeAnnotation ann) + + complLocation = _annLocation ann + + complDocumentation = Nothing + + showFixity p a r o = + let asso = case a of + P.Infix -> "infix" + P.Infixl -> "infixl" + P.Infixr -> "infixr" + in T.unwords [asso, show p, r, "as", P.runOpName o] diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 7fa4133cae..4f1a453b36 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -66,9 +66,9 @@ encodeRebuildErrors = toJSON . map encodeRebuildError . P.runMultipleErrors insertTSCompletions _ _ _ v = v identCompletion (P.Qualified mn i, ty) = - Completion (maybe "" P.runModuleName mn) i (prettyPrintTypeSingleLine ty) (prettyPrintTypeSingleLine ty) Nothing Nothing + Completion (maybe "" P.runModuleName mn) i (prettyPrintTypeSingleLine ty) (prettyPrintTypeSingleLine ty) Nothing Nothing (maybe [] (\x -> [x]) mn) fieldCompletion (label, ty) = - Completion "" ("_." <> P.prettyPrintLabel label) (prettyPrintTypeSingleLine ty) (prettyPrintTypeSingleLine ty) Nothing Nothing + Completion "" ("_." <> P.prettyPrintLabel label) (prettyPrintTypeSingleLine ty) (prettyPrintTypeSingleLine ty) Nothing Nothing [] textError :: IdeError -> Text textError (GeneralError msg) = msg diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index ec9d428885..ae469d62e0 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -46,16 +46,7 @@ namespaceFilter namespaces = mkFilter (filterModuleDecls filterNamespaces) where filterNamespaces :: IdeDeclaration -> Bool - filterNamespaces decl = elem (namespace decl) namespaces - namespace :: IdeDeclaration -> IdeNamespace - namespace (IdeDeclValue _) = IdeNSValue - namespace (IdeDeclType _) = IdeNSType - namespace (IdeDeclTypeSynonym _) = IdeNSType - namespace (IdeDeclDataConstructor _) = IdeNSValue - namespace (IdeDeclTypeClass _) = IdeNSType - namespace (IdeDeclValueOperator _) = IdeNSValue - namespace (IdeDeclTypeOperator _) = IdeNSType - namespace (IdeDeclKind _) = IdeNSKind + filterNamespaces decl = elem (namespaceForDeclaration decl) namespaces -- | Only keeps the given Modules moduleFilter :: [P.ModuleName] -> Filter diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 8c9990df03..2a7a93a476 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -22,9 +22,9 @@ import Protolude import Control.Concurrent.STM import Control.Lens.TH import Data.Aeson -import qualified Data.Map.Lazy as M -import qualified Language.PureScript as P -import qualified Language.PureScript.Errors.JSON as P +import qualified Data.Map.Lazy as M +import qualified Language.PureScript as P +import qualified Language.PureScript.Errors.JSON as P type ModuleIdent = Text type ModuleMap a = Map P.ModuleName a @@ -193,6 +193,7 @@ data Completion = Completion , complExpandedType :: Text , complLocation :: Maybe P.SourceSpan , complDocumentation :: Maybe Text + , complExportedFrom :: [P.ModuleName] } deriving (Show, Eq, Ord) instance ToJSON Completion where @@ -203,6 +204,7 @@ instance ToJSON Completion where , "expandedType" .= complExpandedType , "definedAt" .= complLocation , "documentation" .= complDocumentation + , "exportedFrom" .= complExportedFrom ] identifierFromDeclarationRef :: P.DeclarationRef -> Text diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 6154e21df9..1d8f68f231 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -17,7 +17,7 @@ module Language.PureScript.Ide.Util , unwrapMatch , unwrapPositioned , unwrapPositionedRef - , completionFromMatch + , namespaceForDeclaration , encodeT , decodeT , discardAnn @@ -40,7 +40,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding as TLE import qualified Language.PureScript as P -import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine, IdeError(..)) +import Language.PureScript.Ide.Error (IdeError(..)) import Language.PureScript.Ide.Logging import Language.PureScript.Ide.Types import System.IO.UTF8 (readUTF8FileT) @@ -56,6 +56,17 @@ identifierFromIdeDeclaration d = case d of IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName IdeDeclKind name -> P.runProperName name +namespaceForDeclaration :: IdeDeclaration -> IdeNamespace +namespaceForDeclaration d = case d of + IdeDeclValue _ -> IdeNSValue + IdeDeclType _ -> IdeNSType + IdeDeclTypeSynonym _ -> IdeNSType + IdeDeclDataConstructor _ -> IdeNSValue + IdeDeclTypeClass _ -> IdeNSType + IdeDeclValueOperator _ -> IdeNSValue + IdeDeclTypeOperator _ -> IdeNSType + IdeDeclKind _ -> IdeNSKind + discardAnn :: IdeDeclarationAnn -> IdeDeclaration discardAnn (IdeDeclarationAnn _ d) = d @@ -65,37 +76,6 @@ withEmptyAnn = IdeDeclarationAnn emptyAnn unwrapMatch :: Match a -> a unwrapMatch (Match (_, ed)) = ed -completionFromMatch :: Match IdeDeclarationAnn -> Completion -completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) = - Completion {..} - where - (complIdentifier, complExpandedType) = case decl of - IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyPrintTypeSingleLine) - IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind) - IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyPrintTypeSingleLine) - IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyPrintTypeSingleLine) - IdeDeclTypeClass d -> (d ^. ideTCName . properNameT, d ^. ideTCKind & P.prettyPrintKind) - IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) -> - (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyPrintTypeSingleLine typeP) - IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) -> - (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) P.prettyPrintKind kind) - IdeDeclKind k -> (P.runProperName k, "kind") - - complModule = P.runModuleName m - - complType = maybe complExpandedType prettyPrintTypeSingleLine (_annTypeAnnotation ann) - - complLocation = _annLocation ann - - complDocumentation = Nothing - - showFixity p a r o = - let asso = case a of - P.Infix -> "infix" - P.Infixl -> "infixl" - P.Infixr -> "infixr" - in T.unwords [asso, show p, r, "as", P.runOpName o] - valueOperatorAliasT :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text valueOperatorAliasT i = diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs index a226706cb8..623a58e6e5 100644 --- a/tests/Language/PureScript/Ide/CompletionSpec.hs +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -4,21 +4,31 @@ module Language.PureScript.Ide.CompletionSpec where import Protolude +import Language.PureScript as P import Language.PureScript.Ide.Completion import Language.PureScript.Ide.Test import Language.PureScript.Ide.Types import Test.Hspec -matches :: [Match IdeDeclarationAnn] -matches = map (\d -> Match (mn "Main", d)) [ ideKind "Kind", ideType "Type" Nothing ] +reexportMatches :: [Match IdeDeclarationAnn] +reexportMatches = + map (\d -> Match (mn "A", d)) moduleA + ++ map (\d -> Match (mn "B", d)) moduleB + where + moduleA = [ideKind "Kind"] + moduleB = [ideKind "Kind" `annExp` "A"] + +matches :: [(Match IdeDeclarationAnn, [P.ModuleName])] +matches = map (\d -> (Match (mn "Main", d), [mn "Main"])) [ ideKind "Kind", ideType "Type" Nothing ] spec :: Spec spec = describe "Applying completion options" $ do it "keeps all matches if maxResults is not specified" $ do - applyCompletionOptions (defaultCompletionOptions { coMaxResults = Nothing }) matches - `shouldBe` - matches + applyCompletionOptions (defaultCompletionOptions { coMaxResults = Nothing }) + (map fst matches) `shouldMatchList` matches it "keeps only the specified amount of maxResults" $ do - applyCompletionOptions (defaultCompletionOptions { coMaxResults = Just 1 }) matches - `shouldBe` - take 1 matches + applyCompletionOptions (defaultCompletionOptions { coMaxResults = Just 1 }) + (map fst matches) `shouldMatchList` take 1 matches + it "groups reexports for a single identifier" $ do + applyCompletionOptions (defaultCompletionOptions { coGroupReexports = True }) + reexportMatches `shouldBe` [(Match (mn "A", ideKind "Kind"), [mn "A", mn "B"])] From 7fec7cc1911a8bc8861fb4eb34333f2e2d1f04c5 Mon Sep 17 00:00:00 2001 From: Phillip Freeman Date: Sun, 4 Jun 2017 18:38:03 -0700 Subject: [PATCH 0797/1580] 0.11.5 --- package.yaml | 2 +- purescript.cabal | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index 7a267259e4..9a9376f1e1 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.11.4' +version: '0.11.5' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. diff --git a/purescript.cabal b/purescript.cabal index 9f8d272a9d..159e03cf19 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: purescript -version: 0.11.4 +version: 0.11.5 cabal-version: >= 1.10 build-type: Simple license: BSD3 @@ -606,6 +606,10 @@ extra-source-files: examples/warning/ImplicitImport.purs examples/warning/ImplicitQualifiedImport.purs examples/warning/MissingTypeDeclaration.purs + examples/warning/NewtypeInstance.purs + examples/warning/NewtypeInstance2.purs + examples/warning/NewtypeInstance3.purs + examples/warning/NewtypeInstance4.purs examples/warning/OverlappingInstances.purs examples/warning/OverlappingPattern.purs examples/warning/ScopeShadowing.purs From a13099d8c8a99e8a6a4be566bedf09736c234816 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 4 Jun 2017 20:11:42 -0700 Subject: [PATCH 0798/1580] Fix test dependencies (#2927) --- tests/support/bower.json | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/support/bower.json b/tests/support/bower.json index 6b67afd06a..932650f470 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -8,13 +8,14 @@ "purescript-functions": "3.0.0", "purescript-generics": "4.0.0", "purescript-generics-rep": "5.0.0", + "purescript-lists": "4.6.0", "purescript-newtype": "2.0.0", "purescript-partial": "1.2.0", "purescript-prelude": "3.0.0", "purescript-psci-support": "3.0.0", "purescript-st": "3.0.0", "purescript-symbols": "3.0.0", - "purescript-tailrec": "3.0.0", + "purescript-tailrec": "3.3.0", "purescript-typelevel-prelude": "2.0.0", "purescript-unsafe-coerce": "3.0.0" } From f998d746252a1ffdc09292e607673cacf5031b9a Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 11 Jun 2017 11:14:18 +0200 Subject: [PATCH 0799/1580] [purs ide] improve reexport bundling (#2931) * [purs ide] Fix encoding of exportedFrom field It used the derived json encoding for module names before, which is not what we want for the editors * [purs ide] run reexportGrouping before applying maxResults --- src/Language/PureScript/Ide/Completion.hs | 10 +++++----- src/Language/PureScript/Ide/Types.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 0b81812d42..44a4ac6fea 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -76,11 +76,11 @@ defaultCompletionOptions :: CompletionOptions defaultCompletionOptions = CompletionOptions { coMaxResults = Nothing, coGroupReexports = False } applyCompletionOptions :: CompletionOptions -> [Match IdeDeclarationAnn] -> [(Match IdeDeclarationAnn, [P.ModuleName])] -applyCompletionOptions co decls = - maybe identity take (coMaxResults co) decls - & if coGroupReexports co - then groupCompletionReexports - else map simpleExport +applyCompletionOptions co decls = decls + & (if coGroupReexports co + then groupCompletionReexports + else map simpleExport) + & maybe identity take (coMaxResults co) simpleExport :: Match a -> (Match a, [P.ModuleName]) simpleExport match@(Match (moduleName, _)) = (match, [moduleName]) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 2a7a93a476..72c3d66cb5 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -204,7 +204,7 @@ instance ToJSON Completion where , "expandedType" .= complExpandedType , "definedAt" .= complLocation , "documentation" .= complDocumentation - , "exportedFrom" .= complExportedFrom + , "exportedFrom" .= map P.runModuleName complExportedFrom ] identifierFromDeclarationRef :: P.DeclarationRef -> Text From 348929169a50e1090bd91e62867ae43fd5cb484d Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 11 Jun 2017 22:39:29 +0100 Subject: [PATCH 0800/1580] Add source span annotations to DeclarationRef (#2933) * Add source span annotations to DeclarationRef * Use `SourceSpan` in `errorMessage'` * Fix source span reference in `lintImports` * Fix up `combineTypeRefs` * Remove TODO `SourceSpan` from `findUsedRefs` * Tidy up a few `DeclarationRef` w/`SourceSpan` related things --- src/Language/PureScript/AST/Declarations.hs | 114 ++++++++------- src/Language/PureScript/AST/Exported.hs | 32 ++--- src/Language/PureScript/AST/SourcePos.hs | 37 ++--- src/Language/PureScript/CoreFn/Desugar.hs | 11 +- src/Language/PureScript/Errors.hs | 30 ++-- src/Language/PureScript/Externs.hs | 13 +- src/Language/PureScript/Ide/Externs.hs | 5 +- src/Language/PureScript/Ide/Imports.hs | 25 ++-- src/Language/PureScript/Ide/Rebuild.hs | 2 +- src/Language/PureScript/Ide/Reexports.hs | 12 +- src/Language/PureScript/Ide/Types.hs | 12 +- src/Language/PureScript/Ide/Util.hs | 5 - src/Language/PureScript/Interactive.hs | 20 ++- src/Language/PureScript/Interactive/Module.hs | 10 +- src/Language/PureScript/Linter/Imports.hs | 84 ++++++----- src/Language/PureScript/ModuleDependencies.hs | 2 +- src/Language/PureScript/Parser/Common.hs | 12 ++ .../PureScript/Parser/Declarations.hs | 21 ++- src/Language/PureScript/Sugar/Names.hs | 21 ++- src/Language/PureScript/Sugar/Names/Common.hs | 32 ++--- .../PureScript/Sugar/Names/Exports.hs | 32 ++--- .../PureScript/Sugar/Names/Imports.hs | 132 ++++++++---------- src/Language/PureScript/Sugar/Operators.hs | 18 ++- src/Language/PureScript/Sugar/TypeClasses.hs | 9 +- src/Language/PureScript/TypeChecker.hs | 31 ++-- .../Language/PureScript/Ide/ReexportsSpec.hs | 21 +-- 26 files changed, 354 insertions(+), 389 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index c067e5afc9..f4a04746a7 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -228,11 +228,11 @@ getModuleSourceSpan (Module ss _ _ _ _) = ss -- Add an import declaration for a module if it does not already explicitly import it. -- addDefaultImport :: ModuleName -> Module -> Module -addDefaultImport toImport m@(Module ss coms mn decls exps) = +addDefaultImport toImport m@(Module ss coms mn decls exps) = if isExistingImport `any` decls || mn == toImport then m - else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps + else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit Nothing : decls) exps where - isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True + isExistingImport (ImportDeclaration _ mn' _ _) | mn' == toImport = True isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d isExistingImport _ = False @@ -243,120 +243,116 @@ data DeclarationRef -- | -- A type constructor with data constructors -- - = TypeRef (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName]) + = TypeRef SourceSpan (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName]) -- | -- A type operator -- - | TypeOpRef (OpName 'TypeOpName) + | TypeOpRef SourceSpan (OpName 'TypeOpName) -- | -- A value -- - | ValueRef Ident + | ValueRef SourceSpan Ident -- | -- A value-level operator -- - | ValueOpRef (OpName 'ValueOpName) + | ValueOpRef SourceSpan (OpName 'ValueOpName) -- | -- A type class -- - | TypeClassRef (ProperName 'ClassName) + | TypeClassRef SourceSpan (ProperName 'ClassName) -- | -- A type class instance, created during typeclass desugaring (name, class name, instance types) -- - | TypeInstanceRef Ident + | TypeInstanceRef SourceSpan Ident -- | -- A module, in its entirety -- - | ModuleRef ModuleName + | ModuleRef SourceSpan ModuleName -- | -- A named kind -- - | KindRef (ProperName 'KindName) + | KindRef SourceSpan (ProperName 'KindName) -- | -- A value re-exported from another module. These will be inserted during -- elaboration in name desugaring. -- - | ReExportRef ModuleName DeclarationRef - -- | - -- A declaration reference with source position information - -- - | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef + | ReExportRef SourceSpan ModuleName DeclarationRef deriving (Show) instance Eq DeclarationRef where - (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors' - (TypeOpRef name) == (TypeOpRef name') = name == name' - (ValueRef name) == (ValueRef name') = name == name' - (ValueOpRef name) == (ValueOpRef name') = name == name' - (TypeClassRef name) == (TypeClassRef name') = name == name' - (TypeInstanceRef name) == (TypeInstanceRef name') = name == name' - (ModuleRef name) == (ModuleRef name') = name == name' - (KindRef name) == (KindRef name') = name == name' - (ReExportRef mn ref) == (ReExportRef mn' ref') = mn == mn' && ref == ref' - (PositionedDeclarationRef _ _ r) == r' = r == r' - r == (PositionedDeclarationRef _ _ r') = r == r' + (TypeRef _ name dctors) == (TypeRef _ name' dctors') = name == name' && dctors == dctors' + (TypeOpRef _ name) == (TypeOpRef _ name') = name == name' + (ValueRef _ name) == (ValueRef _ name') = name == name' + (ValueOpRef _ name) == (ValueOpRef _ name') = name == name' + (TypeClassRef _ name) == (TypeClassRef _ name') = name == name' + (TypeInstanceRef _ name) == (TypeInstanceRef _ name') = name == name' + (ModuleRef _ name) == (ModuleRef _ name') = name == name' + (KindRef _ name) == (KindRef _ name') = name == name' + (ReExportRef _ mn ref) == (ReExportRef _ mn' ref') = mn == mn' && ref == ref' _ == _ = False -- enable sorting lists of explicitly imported refs when suggesting imports in linting, IDE, etc. -- not an Ord because this implementation is not consistent with its Eq instance. -- think of it as a notion of contextual, not inherent, ordering. compDecRef :: DeclarationRef -> DeclarationRef -> Ordering -compDecRef (TypeRef name _) (TypeRef name' _) = compare name name' -compDecRef (TypeOpRef name) (TypeOpRef name') = compare name name' -compDecRef (ValueRef ident) (ValueRef ident') = compare ident ident' -compDecRef (ValueOpRef name) (ValueOpRef name') = compare name name' -compDecRef (TypeClassRef name) (TypeClassRef name') = compare name name' -compDecRef (TypeInstanceRef ident) (TypeInstanceRef ident') = compare ident ident' -compDecRef (ModuleRef name) (ModuleRef name') = compare name name' -compDecRef (KindRef name) (KindRef name') = compare name name' -compDecRef (ReExportRef name _) (ReExportRef name' _) = compare name name' -compDecRef (PositionedDeclarationRef _ _ ref) ref' = compDecRef ref ref' -compDecRef ref (PositionedDeclarationRef _ _ ref') = compDecRef ref ref' +compDecRef (TypeRef _ name _) (TypeRef _ name' _) = compare name name' +compDecRef (TypeOpRef _ name) (TypeOpRef _ name') = compare name name' +compDecRef (ValueRef _ ident) (ValueRef _ ident') = compare ident ident' +compDecRef (ValueOpRef _ name) (ValueOpRef _ name') = compare name name' +compDecRef (TypeClassRef _ name) (TypeClassRef _ name') = compare name name' +compDecRef (TypeInstanceRef _ ident) (TypeInstanceRef _ ident') = compare ident ident' +compDecRef (ModuleRef _ name) (ModuleRef _ name') = compare name name' +compDecRef (KindRef _ name) (KindRef _ name') = compare name name' +compDecRef (ReExportRef _ name _) (ReExportRef _ name' _) = compare name name' compDecRef ref ref' = compare (orderOf ref) (orderOf ref') where orderOf :: DeclarationRef -> Int - orderOf (TypeClassRef _) = 0 - orderOf (TypeOpRef _) = 1 - orderOf (TypeRef _ _) = 2 - orderOf (ValueRef _) = 3 - orderOf (ValueOpRef _) = 4 - orderOf (KindRef _) = 5 + orderOf TypeClassRef{} = 0 + orderOf TypeOpRef{} = 1 + orderOf TypeRef{} = 2 + orderOf ValueRef{} = 3 + orderOf ValueOpRef{} = 4 + orderOf KindRef{} = 5 orderOf _ = 6 +declRefSourceSpan :: DeclarationRef -> SourceSpan +declRefSourceSpan (TypeRef ss _ _) = ss +declRefSourceSpan (TypeOpRef ss _) = ss +declRefSourceSpan (ValueRef ss _) = ss +declRefSourceSpan (ValueOpRef ss _) = ss +declRefSourceSpan (TypeClassRef ss _) = ss +declRefSourceSpan (TypeInstanceRef ss _) = ss +declRefSourceSpan (ModuleRef ss _) = ss +declRefSourceSpan (KindRef ss _) = ss +declRefSourceSpan (ReExportRef ss _ _) = ss + getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) -getTypeRef (TypeRef name dctors) = Just (name, dctors) -getTypeRef (PositionedDeclarationRef _ _ r) = getTypeRef r +getTypeRef (TypeRef _ name dctors) = Just (name, dctors) getTypeRef _ = Nothing getTypeOpRef :: DeclarationRef -> Maybe (OpName 'TypeOpName) -getTypeOpRef (TypeOpRef op) = Just op -getTypeOpRef (PositionedDeclarationRef _ _ r) = getTypeOpRef r +getTypeOpRef (TypeOpRef _ op) = Just op getTypeOpRef _ = Nothing getValueRef :: DeclarationRef -> Maybe Ident -getValueRef (ValueRef name) = Just name -getValueRef (PositionedDeclarationRef _ _ r) = getValueRef r +getValueRef (ValueRef _ name) = Just name getValueRef _ = Nothing getValueOpRef :: DeclarationRef -> Maybe (OpName 'ValueOpName) -getValueOpRef (ValueOpRef op) = Just op -getValueOpRef (PositionedDeclarationRef _ _ r) = getValueOpRef r +getValueOpRef (ValueOpRef _ op) = Just op getValueOpRef _ = Nothing getTypeClassRef :: DeclarationRef -> Maybe (ProperName 'ClassName) -getTypeClassRef (TypeClassRef name) = Just name -getTypeClassRef (PositionedDeclarationRef _ _ r) = getTypeClassRef r +getTypeClassRef (TypeClassRef _ name) = Just name getTypeClassRef _ = Nothing getKindRef :: DeclarationRef -> Maybe (ProperName 'KindName) -getKindRef (KindRef name) = Just name -getKindRef (PositionedDeclarationRef _ _ r) = getKindRef r +getKindRef (KindRef _ name) = Just name getKindRef _ = Nothing isModuleRef :: DeclarationRef -> Bool -isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r -isModuleRef (ModuleRef _) = True +isModuleRef ModuleRef{} = True isModuleRef _ = False -- | @@ -435,7 +431,7 @@ data Declaration -- | -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name) -- - | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName) + | ImportDeclaration SourceAnn ModuleName ImportDeclarationType (Maybe ModuleName) -- | -- A type class declaration (name, argument, implies, member declarations) -- diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index 759b9a3be4..257d905d4c 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -85,13 +85,11 @@ filterInstances mn (Just exps) = checkQual q = isQualified q && not (isQualifiedWith mn q) typeName :: DeclarationRef -> Maybe (ProperName 'TypeName) - typeName (TypeRef n _) = Just n - typeName (PositionedDeclarationRef _ _ r) = typeName r + typeName (TypeRef _ n _) = Just n typeName _ = Nothing typeClassName :: DeclarationRef -> Maybe (ProperName 'ClassName) - typeClassName (TypeClassRef n) = Just n - typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r + typeClassName (TypeClassRef _ n) = Just n typeClassName _ = Nothing -- | @@ -127,18 +125,17 @@ isExported _ TypeInstanceDeclaration{} = True isExported exps (PositionedDeclaration _ _ d) = isExported exps d isExported (Just exps) decl = any (matches decl) exps where - matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident' - matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident' - matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident' - matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident' - matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident' - matches (ExternKindDeclaration ident) (KindRef ident') = ident == ident' - matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident' - matches (TypeClassDeclaration ident _ _ _ _) (TypeClassRef ident') = ident == ident' - matches (ValueFixityDeclaration _ _ op) (ValueOpRef op') = op == op' - matches (TypeFixityDeclaration _ _ op) (TypeOpRef op') = op == op' + matches (TypeDeclaration ident _) (ValueRef _ ident') = ident == ident' + matches (ValueDeclaration ident _ _ _) (ValueRef _ ident') = ident == ident' + matches (ExternDeclaration ident _) (ValueRef _ ident') = ident == ident' + matches (DataDeclaration _ ident _ _) (TypeRef _ ident' _) = ident == ident' + matches (ExternDataDeclaration ident _) (TypeRef _ ident' _) = ident == ident' + matches (ExternKindDeclaration ident) (KindRef _ ident') = ident == ident' + matches (TypeSynonymDeclaration ident _ _) (TypeRef _ ident' _) = ident == ident' + matches (TypeClassDeclaration ident _ _ _ _) (TypeClassRef _ ident') = ident == ident' + matches (ValueFixityDeclaration _ _ op) (ValueOpRef _ op') = op == op' + matches (TypeFixityDeclaration _ _ op) (TypeOpRef _ op') = op == op' matches (PositionedDeclaration _ _ d) r = d `matches` r - matches d (PositionedDeclarationRef _ _ r) = d `matches` r matches _ _ = False -- | @@ -149,7 +146,6 @@ isDctorExported :: ProperName 'TypeName -> Maybe [DeclarationRef] -> ProperName isDctorExported _ Nothing _ = True isDctorExported ident (Just exps) ctor = test `any` exps where - test (PositionedDeclarationRef _ _ d) = test d - test (TypeRef ident' Nothing) = ident == ident' - test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors + test (TypeRef _ ident' Nothing) = ident == ident' + test (TypeRef _ ident' (Just ctors)) = ident == ident' && ctor `elem` ctors test _ = False diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 55bcc23985..f208deeb29 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -6,27 +6,25 @@ module Language.PureScript.AST.SourcePos where import Prelude.Compat -import GHC.Generics (Generic) import Control.DeepSeq (NFData) import Data.Aeson ((.=), (.:)) -import qualified Data.Aeson as A import Data.Monoid -import qualified Data.Text as T import Data.Text (Text) +import GHC.Generics (Generic) +import Language.PureScript.Comments +import qualified Data.Aeson as A +import qualified Data.Text as T import System.FilePath (makeRelative) --- | --- Source position information --- +-- | Source annotation - position information and comments. +type SourceAnn = (SourceSpan, [Comment]) + +-- | Source position information data SourcePos = SourcePos - { -- | - -- Line number - -- - sourcePosLine :: Int - -- | - -- Column number - -- + { sourcePosLine :: Int + -- ^ Line number , sourcePosColumn :: Int + -- ^ Column number } deriving (Show, Eq, Ord, Generic) instance NFData SourcePos @@ -46,17 +44,12 @@ instance A.FromJSON SourcePos where return $ SourcePos line col data SourceSpan = SourceSpan - { -- | - -- Source name - -- - spanName :: String - -- | - -- Start of the span - -- + { spanName :: String + -- ^ Source name , spanStart :: SourcePos - -- End of the span - -- + -- ^ Start of the span , spanEnd :: SourcePos + -- ^ End of the span } deriving (Show, Eq, Ord, Generic) instance NFData SourceSpan diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 800c63084b..e3e6ca9c88 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -225,7 +225,7 @@ findQualModules decls = -- | Desugars import declarations from AST to CoreFn representation. importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName) -importToCoreFn (A.ImportDeclaration name _ _) = Just (nullAnn, name) +importToCoreFn (A.ImportDeclaration _ name _ _) = Just (nullAnn, name) importToCoreFn (A.PositionedDeclaration ss _ d) = ((,) (Just ss, [], Nothing, Nothing) . snd) <$> importToCoreFn d importToCoreFn _ = Nothing @@ -240,11 +240,10 @@ externToCoreFn _ = Nothing -- CoreFn modules only export values, so all data constructors, class -- constructor, instances and values are flattened into one list. exportToCoreFn :: A.DeclarationRef -> [Ident] -exportToCoreFn (A.TypeRef _ (Just dctors)) = map properToIdent dctors -exportToCoreFn (A.ValueRef name) = [name] -exportToCoreFn (A.TypeClassRef name) = [properToIdent name] -exportToCoreFn (A.TypeInstanceRef name) = [name] -exportToCoreFn (A.PositionedDeclarationRef _ _ d) = exportToCoreFn d +exportToCoreFn (A.TypeRef _ _ (Just dctors)) = map properToIdent dctors +exportToCoreFn (A.ValueRef _ name) = [name] +exportToCoreFn (A.TypeClassRef _ name) = [properToIdent name] +exportToCoreFn (A.TypeInstanceRef _ name) = [name] exportToCoreFn _ = [] -- | Makes a typeclass dictionary constructor function. The returned expression diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 742640a0c3..2796925fb1 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -189,6 +189,10 @@ nonEmpty = not . null . runMultipleErrors errorMessage :: SimpleErrorMessage -> MultipleErrors errorMessage err = MultipleErrors [ErrorMessage [] err] +-- | Create an error set from a single simple error message and source annotation +errorMessage' :: SourceSpan -> SimpleErrorMessage -> MultipleErrors +errorMessage' ss err = MultipleErrors [ErrorMessage [PositionedError ss] err] + -- | Create an error set from a single error message singleError :: ErrorMessage -> MultipleErrors singleError = MultipleErrors . pure @@ -1190,7 +1194,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl -- Pretty print and export declaration prettyPrintExport :: DeclarationRef -> Text -prettyPrintExport (TypeRef pn _) = runProperName pn +prettyPrintExport (TypeRef _ pn _) = runProperName pn prettyPrintExport ref = fromMaybe (internalError "prettyPrintRef returned Nothing in prettyPrintExport") @@ -1205,30 +1209,28 @@ prettyPrintImport mn idt qual = in i <> maybe "" (\q -> " as " <> runModuleName q) qual prettyPrintRef :: DeclarationRef -> Maybe Text -prettyPrintRef (TypeRef pn Nothing) = +prettyPrintRef (TypeRef _ pn Nothing) = Just $ runProperName pn <> "(..)" -prettyPrintRef (TypeRef pn (Just [])) = +prettyPrintRef (TypeRef _ pn (Just [])) = Just $ runProperName pn -prettyPrintRef (TypeRef pn (Just dctors)) = +prettyPrintRef (TypeRef _ pn (Just dctors)) = Just $ runProperName pn <> "(" <> T.intercalate ", " (map runProperName dctors) <> ")" -prettyPrintRef (TypeOpRef op) = +prettyPrintRef (TypeOpRef _ op) = Just $ "type " <> showOp op -prettyPrintRef (ValueRef ident) = +prettyPrintRef (ValueRef _ ident) = Just $ showIdent ident -prettyPrintRef (ValueOpRef op) = +prettyPrintRef (ValueOpRef _ op) = Just $ showOp op -prettyPrintRef (TypeClassRef pn) = +prettyPrintRef (TypeClassRef _ pn) = Just $ "class " <> runProperName pn -prettyPrintRef (TypeInstanceRef ident) = +prettyPrintRef (TypeInstanceRef _ ident) = Just $ showIdent ident -prettyPrintRef (ModuleRef name) = +prettyPrintRef (ModuleRef _ name) = Just $ "module " <> runModuleName name -prettyPrintRef (KindRef pn) = +prettyPrintRef (KindRef _ pn) = Just $ "kind " <> runProperName pn -prettyPrintRef (ReExportRef _ _) = +prettyPrintRef ReExportRef{} = Nothing -prettyPrintRef (PositionedDeclarationRef _ _ ref) = - prettyPrintRef ref -- | Pretty print multiple errors prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 7a72099438..555eae97d2 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -193,13 +193,12 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} findOp g op = maybe False (== op) . g importDecl :: Declaration -> Maybe ExternsImport - importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn) + importDecl (ImportDeclaration _ m mt qmn) = Just (ExternsImport m mt qmn) importDecl (PositionedDeclaration _ _ d) = importDecl d importDecl _ = Nothing toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration] - toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r - toExternsDeclaration (TypeRef pn dctors) = + toExternsDeclaration (TypeRef _ pn dctors) = case Qualified (Just mn) pn `M.lookup` types env of Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration" Just (kind, TypeSynonym) @@ -211,10 +210,10 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env) ] _ -> internalError "toExternsDeclaration: Invalid input" - toExternsDeclaration (ValueRef ident) + toExternsDeclaration (ValueRef _ ident) | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env = [ EDValue ident ty ] - toExternsDeclaration (TypeClassRef className) + toExternsDeclaration (TypeClassRef _ className) | Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env @@ -222,13 +221,13 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} , EDTypeSynonym (coerceProperName className) typeClassArguments synTy , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies ] - toExternsDeclaration (TypeInstanceRef ident) + toExternsDeclaration (TypeInstanceRef _ ident) = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env)) , m2 <- M.elems m1 , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2) ] - toExternsDeclaration (KindRef pn) + toExternsDeclaration (KindRef _ pn) | Qualified (Just mn) pn `S.member` kinds env = [ EDKind pn ] toExternsDeclaration _ = [] diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index b6315a8f92..62348c37ce 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -28,7 +28,6 @@ import qualified Data.ByteString as BS import Data.Version (showVersion) import Language.PureScript.Ide.Error (IdeError (..)) import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util import qualified Language.PureScript as P @@ -59,7 +58,7 @@ convertExterns ef = decls = map (IdeDeclarationAnn emptyAnn) (resolvedDeclarations ++ operatorDecls ++ tyOperatorDecls) - exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (P.efExports ef) + exportDecls = mapMaybe convertExport (P.efExports ef) operatorDecls = convertOperator <$> P.efFixities ef tyOperatorDecls = convertTypeOperator <$> P.efTypeFixities ef (toResolve, declarations) = @@ -114,7 +113,7 @@ data ToResolve | SynonymToResolve (P.ProperName 'P.TypeName) P.Type convertExport :: P.DeclarationRef -> Maybe (P.ModuleName, P.DeclarationRef) -convertExport (P.ReExportRef m r) = Just (m, r) +convertExport (P.ReExportRef _ m r) = Just (m, r) convertExport _ = Nothing convertDecl :: P.ExternsDeclaration -> Either ToResolve (Maybe IdeDeclaration) diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index a38f56d47f..1714b8eff6 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -93,7 +93,7 @@ parseModuleHeader = do (P.mark (Parsec.many (P.same *> P.parseImportDeclaration'))) pure (ImportParse mn ipStart ipEnd (map mkImport decls)) where - mkImport (mn, (P.Explicit refs), qual) = Import mn (P.Explicit (unwrapPositionedRef <$> refs)) qual + mkImport (mn, (P.Explicit refs), qual) = Import mn (P.Explicit refs) qual mkImport (mn, it, qual) = Import mn it qual sliceImportSection :: [Text] -> Either Text (P.ModuleName, [Text], [Import], [Text]) @@ -192,19 +192,19 @@ addExplicitImport' decl moduleName imports = else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports where refFromDeclaration (IdeDeclTypeClass tc) = - P.TypeClassRef (tc ^. ideTCName) + P.TypeClassRef ideSpan (tc ^. ideTCName) refFromDeclaration (IdeDeclDataConstructor dtor) = - P.TypeRef (dtor ^. ideDtorTypeName) Nothing + P.TypeRef ideSpan (dtor ^. ideDtorTypeName) Nothing refFromDeclaration (IdeDeclType t) = - P.TypeRef (t ^. ideTypeName) (Just []) + P.TypeRef ideSpan (t ^. ideTypeName) (Just []) refFromDeclaration (IdeDeclValueOperator op) = - P.ValueOpRef (op ^. ideValueOpName) + P.ValueOpRef ideSpan (op ^. ideValueOpName) refFromDeclaration (IdeDeclTypeOperator op) = - P.TypeOpRef (op ^. ideTypeOpName) + P.TypeOpRef ideSpan (op ^. ideTypeOpName) refFromDeclaration (IdeDeclKind kn) = - P.KindRef kn + P.KindRef ideSpan kn refFromDeclaration d = - P.ValueRef (P.Ident (identifierFromIdeDeclaration d)) + P.ValueRef ideSpan (P.Ident (identifierFromIdeDeclaration d)) -- | Adds a declaration to an import: -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) @@ -222,13 +222,16 @@ addExplicitImport' decl moduleName imports = refs insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) - insertDtor _ (P.TypeRef tn' _) = P.TypeRef tn' Nothing + insertDtor _ (P.TypeRef ss tn' _) = P.TypeRef ss tn' Nothing insertDtor _ refs = refs matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool - matchType tn (P.TypeRef n _) = tn == n + matchType tn (P.TypeRef _ n _) = tn == n matchType _ _ = False +ideSpan :: P.SourceSpan +ideSpan = P.internalModuleSourceSpan "" + updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a] updateAtFirstOrPrepend p t d l = case findIndex p l of @@ -336,6 +339,6 @@ parseImport t = case P.lex "" t >>= P.runTokenParser "" P.parseImportDeclaration' of Right (mn, P.Explicit refs, mmn) -> - Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn) + Just (Import mn (P.Explicit refs) mmn) Right (mn, idt, mmn) -> Just (Import mn idt mmn) Left _ -> Nothing diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index a26f4e521c..a7e765bdec 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -176,7 +176,7 @@ sortExterns m ex = do mkShallowModule P.ExternsFile{..} = P.Module (P.internalModuleSourceSpan "") [] efModuleName (map mkImport efImports) Nothing mkImport (P.ExternsImport mn it iq) = - P.ImportDeclaration mn it iq + P.ImportDeclaration (P.internalModuleSourceSpan "", []) mn it iq getExtern mn = M.lookup mn ex -- Sort a list so its elements appear in the same order as in another list. inOrderOf :: (Ord a) => [a] -> [a] -> [a] diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index f36f04e596..0a8b1de2ab 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -92,7 +92,7 @@ resolveRef -> P.DeclarationRef -> Either P.DeclarationRef [IdeDeclarationAnn] resolveRef decls ref = case ref of - P.TypeRef tn mdtors -> + P.TypeRef _ tn mdtors -> case findRef (anyOf (_IdeDeclType . ideTypeName) (== tn)) <|> findRef (anyOf (_IdeDeclTypeSynonym . ideSynonymName) (== tn)) of Nothing -> @@ -104,15 +104,15 @@ resolveRef decls ref = case ref of -- those up ourselfes findDtors tn Just dtors -> mapMaybe lookupDtor dtors - P.ValueRef i -> + P.ValueRef _ i -> findWrapped (anyOf (_IdeDeclValue . ideValueIdent) (== i)) - P.ValueOpRef name -> + P.ValueOpRef _ name -> findWrapped (anyOf (_IdeDeclValueOperator . ideValueOpName) (== name)) - P.TypeOpRef name -> + P.TypeOpRef _ name -> findWrapped (anyOf (_IdeDeclTypeOperator . ideTypeOpName) (== name)) - P.TypeClassRef name -> + P.TypeClassRef _ name -> findWrapped (anyOf (_IdeDeclTypeClass . ideTCName) (== name)) - P.KindRef name -> + P.KindRef _ name -> findWrapped (anyOf _IdeDeclKind (== name)) _ -> Left ref diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 72c3d66cb5..07de305e4a 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -208,12 +208,12 @@ instance ToJSON Completion where ] identifierFromDeclarationRef :: P.DeclarationRef -> Text -identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name -identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident -identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name -identifierFromDeclarationRef (P.KindRef name) = P.runProperName name -identifierFromDeclarationRef (P.ValueOpRef op) = P.showOp op -identifierFromDeclarationRef (P.TypeOpRef op) = P.showOp op +identifierFromDeclarationRef (P.TypeRef _ name _) = P.runProperName name +identifierFromDeclarationRef (P.ValueRef _ ident) = P.runIdent ident +identifierFromDeclarationRef (P.TypeClassRef _ name) = P.runProperName name +identifierFromDeclarationRef (P.KindRef _ name) = P.runProperName name +identifierFromDeclarationRef (P.ValueOpRef _ op) = P.showOp op +identifierFromDeclarationRef (P.TypeOpRef _ op) = P.showOp op identifierFromDeclarationRef _ = "" data Success = diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 1d8f68f231..9ecb206a83 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -16,7 +16,6 @@ module Language.PureScript.Ide.Util ( identifierFromIdeDeclaration , unwrapMatch , unwrapPositioned - , unwrapPositionedRef , namespaceForDeclaration , encodeT , decodeT @@ -96,10 +95,6 @@ unwrapPositioned :: P.Declaration -> P.Declaration unwrapPositioned (P.PositionedDeclaration _ _ x) = unwrapPositioned x unwrapPositioned x = x -unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef -unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x -unwrapPositionedRef x = x - properNameT :: Iso' (P.ProperName a) Text properNameT = iso P.runProperName P.ProperName diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 9d91c24c5e..4dcccc3d55 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -202,26 +202,24 @@ handleShowImportedModules print' = do refsList refs = " (" <> commaList (mapMaybe showRef refs) <> ")" showRef :: P.DeclarationRef -> Maybe Text - showRef (P.TypeRef pn dctors) = + showRef (P.TypeRef _ pn dctors) = Just $ N.runProperName pn <> "(" <> maybe ".." (commaList . map N.runProperName) dctors <> ")" - showRef (P.TypeOpRef op) = + showRef (P.TypeOpRef _ op) = Just $ "type " <> N.showOp op - showRef (P.ValueRef ident) = + showRef (P.ValueRef _ ident) = Just $ N.runIdent ident - showRef (P.ValueOpRef op) = + showRef (P.ValueOpRef _ op) = Just $ N.showOp op - showRef (P.TypeClassRef pn) = + showRef (P.TypeClassRef _ pn) = Just $ "class " <> N.runProperName pn - showRef (P.TypeInstanceRef ident) = + showRef (P.TypeInstanceRef _ ident) = Just $ N.runIdent ident - showRef (P.ModuleRef name) = + showRef (P.ModuleRef _ name) = Just $ "module " <> N.runModuleName name - showRef (P.KindRef pn) = + showRef (P.KindRef _ pn) = Just $ "kind " <> N.runProperName pn - showRef (P.ReExportRef _ _) = + showRef (P.ReExportRef _ _ _) = Nothing - showRef (P.PositionedDeclarationRef _ _ ref) = - showRef ref commaList :: [Text] -> Text commaList = T.intercalate ", " diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index a69448af71..9db3cc8c7d 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -61,7 +61,6 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi (P.TypeWildcard internalSpan)) mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] - internalSpan = P.internalModuleSourceSpan "" in P.Module internalSpan [] moduleName @@ -78,7 +77,7 @@ createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBin moduleName = P.ModuleName [P.ProperName "$PSCI"] itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ in - P.Module (P.internalModuleSourceSpan "") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing + P.Module internalSpan [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing -- | -- Makes a volatile module to execute the current imports. @@ -88,13 +87,16 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} = let moduleName = P.ModuleName [P.ProperName "$PSCI"] in - P.Module (P.internalModuleSourceSpan "") [] moduleName (importDecl `map` imports) Nothing + P.Module internalSpan [] moduleName (importDecl `map` imports) Nothing importDecl :: ImportedModule -> P.Declaration -importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ +importDecl (mn, declType, asQ) = P.ImportDeclaration (internalSpan, []) mn declType asQ indexFile :: FilePath indexFile = ".psci_modules" ++ pathSeparator : "index.js" modulesDir :: FilePath modulesDir = ".psci_modules" ++ pathSeparator : "node_modules" + +internalSpan :: P.SourceSpan +internalSpan = P.internalModuleSourceSpan "" diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 680ca09e8f..4be3126bae 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -13,7 +13,7 @@ import Control.Monad.Writer.Class import Data.Function (on) import Data.Foldable (for_) import Data.List (find, intersect, groupBy, sortBy, (\\)) -import Data.Maybe (mapMaybe, fromMaybe) +import Data.Maybe (mapMaybe) import Data.Monoid (Sum(..)) import Data.Traversable (forM) import qualified Data.Text as T @@ -58,7 +58,7 @@ lintImports -> m () lintImports (Module _ _ _ _ Nothing) _ _ = internalError "lintImports needs desugared exports" -lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do +lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do -- TODO: this needs some work to be easier to understand @@ -69,22 +69,20 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do imports = M.toAscList (findImports mdecls) for_ imports $ \(mni, decls) -> - unless (isPrim mni) $ - for_ decls $ \(ss', declType, qualifierName) -> - maybe id warnWithPosition ss' $ do - let names = ordNub $ M.findWithDefault [] mni usedImps' - lintImportDecl env mni qualifierName names declType allowImplicit + unless (isPrim mni) . + for_ decls $ \(ss, declType, qualifierName) -> do + let names = ordNub $ M.findWithDefault [] mni usedImps' + lintImportDecl env mni qualifierName names ss declType allowImplicit for_ (M.toAscList (byQual imports)) $ \(mnq, entries) -> do let mnis = ordNub $ map (\(_, _, mni) -> mni) entries unless (length mnis == 1) $ do let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries - for_ implicits $ \(ss', _, mni) -> - maybe id warnWithPosition ss' $ do - let names = ordNub $ M.findWithDefault [] mni usedImps' - usedRefs = findUsedRefs env mni (Just mnq) names - unless (null usedRefs) $ - tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs + for_ implicits $ \(ss, _, mni) -> do + let names = ordNub $ M.findWithDefault [] mni usedImps' + usedRefs = findUsedRefs ss env mni (Just mnq) names + unless (null usedRefs) . + tell . errorMessage' ss $ ImplicitQualifiedImport mni mnq usedRefs for_ imports $ \(mnq, imps) -> do @@ -100,11 +98,10 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do $ unwarned for_ duplicates $ \(pos, _, _) -> - maybe id warnWithPosition pos $ - tell $ errorMessage $ DuplicateSelectiveImport mnq + tell . errorMessage' pos $ DuplicateSelectiveImport mnq for_ (imps \\ (warned ++ duplicates)) $ \(pos, typ, _) -> - warnDuplicateRefs (fromMaybe ss pos) DuplicateImportRef $ case typ of + warnDuplicateRefs pos DuplicateImportRef $ case typ of Explicit refs -> refs Hiding refs -> refs _ -> [] @@ -120,9 +117,9 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do countOpenImports :: Declaration -> Int countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d - countOpenImports (ImportDeclaration mn' Implicit Nothing) + countOpenImports (ImportDeclaration _ mn' Implicit Nothing) | not (isPrim mn' || mn == mn') = 1 - countOpenImports (ImportDeclaration mn' (Hiding _) Nothing) + countOpenImports (ImportDeclaration _ mn' (Hiding _) Nothing) | not (isPrim mn' || mn == mn') = 1 countOpenImports _ = 0 @@ -135,8 +132,8 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do -- import to that module, with the corresponding source span, import type, -- and module being imported byQual - :: [(ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])] - -> M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, ModuleName)] + :: [(ModuleName, [(SourceSpan, ImportDeclarationType, Maybe ModuleName)])] + -> M.Map ModuleName [(SourceSpan, ImportDeclarationType, ModuleName)] byQual = foldr goImp M.empty where goImp (mni, xs) acc = foldr (goDecl mni) acc xs @@ -150,8 +147,7 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do exportedModules :: [ModuleName] exportedModules = ordNub $ mapMaybe extractModule mexports where - extractModule (PositionedDeclarationRef _ _ r) = extractModule r - extractModule (ModuleRef mne) = Just mne + extractModule (ModuleRef _ mne) = Just mne extractModule _ = Nothing -- Elaborates the UsedImports to include values from modules that are being @@ -195,10 +191,11 @@ lintImportDecl -> ModuleName -> Maybe ModuleName -> [Qualified Name] + -> SourceSpan -> ImportDeclarationType -> Bool -> m Bool -lintImportDecl env mni qualifierName names declType allowImplicit = +lintImportDecl env mni qualifierName names ss declType allowImplicit = case declType of Implicit -> case qualifierName of Nothing -> @@ -224,8 +221,8 @@ lintImportDecl env mni qualifierName names declType allowImplicit = -- used constructors explicity `T(X, Y, [...])` to `T(..)` for suggestion -- message. simplifyTypeRef :: DeclarationRef -> DeclarationRef - simplifyTypeRef (TypeRef name (Just dctors)) - | not (null dctors) = TypeRef name Nothing + simplifyTypeRef (TypeRef ss' name (Just dctors)) + | not (null dctors) = TypeRef ss' name Nothing simplifyTypeRef other = other checkExplicit @@ -250,7 +247,7 @@ lintImportDecl env mni qualifierName names declType allowImplicit = (_, []) | c /= Just [] -> warn (UnusedDctorImport mni tn qualifierName allRefs) (Just ctors, dctors') -> let ddiff = ctors \\ dctors' - in unless' (null ddiff) $ warn $ UnusedDctorExplicitImport mni tn ddiff qualifierName allRefs + in unless' (null ddiff) . warn $ UnusedDctorExplicitImport mni tn ddiff qualifierName allRefs _ -> return False return (didWarn || or didWarn') @@ -259,7 +256,7 @@ lintImportDecl env mni qualifierName names declType allowImplicit = unused = warn (UnusedImport mni) warn :: SimpleErrorMessage -> m Bool - warn err = tell (errorMessage err) >> return True + warn err = tell (errorMessage' ss err) >> return True -- Unless the boolean is true, run the action. Return false when the action is -- not run, otherwise return whatever the action does. @@ -272,7 +269,7 @@ lintImportDecl env mni qualifierName names declType allowImplicit = unless' True _ = return False allRefs :: [DeclarationRef] - allRefs = findUsedRefs env mni qualifierName names + allRefs = findUsedRefs ss env mni qualifierName names dtys :: ModuleName @@ -292,24 +289,25 @@ lintImportDecl env mni qualifierName names declType allowImplicit = typeForDCtor mn pn = fst <$> find (elem pn . fst . snd) (M.toList (dtys mn)) findUsedRefs - :: Env + :: SourceSpan + -> Env -> ModuleName -> Maybe ModuleName -> [Qualified Name] -> [DeclarationRef] -findUsedRefs env mni qn names = +findUsedRefs ss env mni qn names = let - classRefs = TypeClassRef <$> mapMaybe (getClassName <=< disqualifyFor qn) names - valueRefs = ValueRef <$> mapMaybe (getIdentName <=< disqualifyFor qn) names - valueOpRefs = ValueOpRef <$> mapMaybe (getValOpName <=< disqualifyFor qn) names - typeOpRefs = TypeOpRef <$> mapMaybe (getTypeOpName <=< disqualifyFor qn) names + classRefs = TypeClassRef ss <$> mapMaybe (getClassName <=< disqualifyFor qn) names + valueRefs = ValueRef ss <$> mapMaybe (getIdentName <=< disqualifyFor qn) names + valueOpRefs = ValueOpRef ss <$> mapMaybe (getValOpName <=< disqualifyFor qn) names + typeOpRefs = TypeOpRef ss <$> mapMaybe (getTypeOpName <=< disqualifyFor qn) names types = mapMaybe (getTypeName <=< disqualifyFor qn) names dctors = mapMaybe (getDctorName <=< disqualifyFor qn) names typesWithDctors = reconstructTypeRefs dctors typesWithoutDctors = filter (`M.notMember` typesWithDctors) types typesRefs - = map (flip TypeRef (Just [])) typesWithoutDctors - ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors) + = map (flip (TypeRef ss) (Just [])) typesWithoutDctors + ++ map (\(ty, ds) -> TypeRef ss ty (Just ds)) (M.toList typesWithDctors) in sortBy compDecRef $ classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs where @@ -343,12 +341,11 @@ matchName _ ModName{} = Nothing matchName _ name = Just name runDeclRef :: DeclarationRef -> Maybe Name -runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref -runDeclRef (ValueRef ident) = Just $ IdentName ident -runDeclRef (ValueOpRef op) = Just $ ValOpName op -runDeclRef (TypeRef pn _) = Just $ TyName pn -runDeclRef (TypeOpRef op) = Just $ TyOpName op -runDeclRef (TypeClassRef pn) = Just $ TyClassName pn +runDeclRef (ValueRef _ ident) = Just $ IdentName ident +runDeclRef (ValueOpRef _ op) = Just $ ValOpName op +runDeclRef (TypeRef _ pn _) = Just $ TyName pn +runDeclRef (TypeOpRef _ op) = Just $ TyOpName op +runDeclRef (TypeClassRef _ pn) = Just $ TyClassName pn runDeclRef _ = Nothing checkDuplicateImports @@ -360,7 +357,6 @@ checkDuplicateImports checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) = if t1 == t2 && q1 == q2 then do - maybe id warnWithPosition pos $ - tell $ errorMessage $ DuplicateImport mn t2 q2 + tell . errorMessage' pos $ DuplicateImport mn t2 q2 return $ (pos, t2, q2) : xs else return xs diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 21885b0ead..4ee9ed3b02 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -53,7 +53,7 @@ sortModules ms = do usedModules :: Declaration -> Maybe (ModuleName, Maybe SourceSpan) -- Regardless of whether an imported module is qualified we still need to -- take into account its import to build an accurate list of dependencies. -usedModules (ImportDeclaration mn _ _) = pure (mn, Nothing) +usedModules (ImportDeclaration _ mn _ _) = pure (mn, Nothing) usedModules (PositionedDeclaration ss _ d) = fmap (second (const (Just ss))) (usedModules d) usedModules _ = Nothing diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index 5030033ec6..85c4b4cb00 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -143,3 +143,15 @@ withSourceSpan f p = do _ -> Nothing let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos $ fromMaybe end end') return $ f sp comments x + +withSourceAnn + :: (SourceAnn -> a -> b) + -> P.Parsec [PositionedToken] u a + -> P.Parsec [PositionedToken] u b +withSourceAnn = withSourceSpan . curry + +withSourceSpan' + :: (SourceSpan -> a -> b) + -> P.Parsec [PositionedToken] u a + -> P.Parsec [PositionedToken] u b +withSourceSpan' f = withSourceSpan (\ss _ -> f ss) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index e72f5347d9..855d555e24 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -139,9 +139,9 @@ parseFixityDeclaration = do <*> (reserved "as" *> parseOperator) parseImportDeclaration :: TokenParser Declaration -parseImportDeclaration = withSourceSpan PositionedDeclaration $ do +parseImportDeclaration = withSourceAnn (\sa -> ($ ImportDeclaration sa)) $ do (mn, declType, asQ) <- parseImportDeclaration' - return $ ImportDeclaration mn declType asQ + return $ \f -> f mn declType asQ parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName) parseImportDeclaration' = do @@ -159,19 +159,18 @@ parseImportDeclaration' = do parseDeclarationRef :: TokenParser DeclarationRef parseDeclarationRef = - withSourceSpan PositionedDeclarationRef - $ (KindRef <$> P.try (reserved "kind" *> kindName)) - <|> (ValueRef <$> parseIdent) - <|> (ValueOpRef <$> parens parseOperator) - <|> parseTypeRef - <|> (TypeClassRef <$> (reserved "class" *> properName)) - <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName)) - <|> (TypeOpRef <$> (indented *> reserved "type" *> parens parseOperator)) + withSourceSpan' KindRef (P.try (reserved "kind" *> kindName)) + <|> withSourceSpan' ValueRef parseIdent + <|> withSourceSpan' ValueOpRef (parens parseOperator) + <|> withSourceSpan' (\sa -> ($ TypeRef sa)) parseTypeRef + <|> withSourceSpan' TypeClassRef (reserved "class" *> properName) + <|> withSourceSpan' ModuleRef (indented *> reserved "module" *> moduleName) + <|> withSourceSpan' TypeOpRef (indented *> reserved "type" *> parens parseOperator) where parseTypeRef = do name <- typeName dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep dataConstructorName) - return $ TypeRef name (fromMaybe (Just []) dctors) + return $ \f -> f name (fromMaybe (Just []) dctors) parseTypeClassDeclaration :: TokenParser Declaration parseTypeClassDeclaration = do diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 0fb49ed2ff..fc2d3de6d4 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -66,7 +66,7 @@ desugarImportsWithEnv externs modules = do externsEnv env ExternsFile{..} = do let members = Exports{..} env' = M.insert efModuleName (efSourceSpan, primImports, members) env - fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)]) + fromEFImport (ExternsImport mn mt qmn) = (mn, [(efSourceSpan, Just mt, qmn)]) imps <- foldM (resolveModuleImport env') primImports (map fromEFImport efImports) exps <- resolveExports env' efSourceSpan efModuleName imps members efExports return $ M.insert efModuleName (efSourceSpan, imps, exps) env @@ -75,12 +75,11 @@ desugarImportsWithEnv externs modules = do exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) exportedTypes = M.fromList $ mapMaybe toExportedType efExports where - toExportedType (TypeRef tyCon dctors) = Just (tyCon, (fromMaybe (mapMaybe forTyCon efDeclarations) dctors, efModuleName)) + toExportedType (TypeRef _ tyCon dctors) = Just (tyCon, (fromMaybe (mapMaybe forTyCon efDeclarations) dctors, efModuleName)) where forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName) forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn forTyCon _ = Nothing - toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r toExportedType _ = Nothing exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName @@ -127,24 +126,24 @@ elaborateExports :: Exports -> Module -> Module elaborateExports exps (Module ss coms mn decls refs) = Module ss coms mn decls $ Just $ elaboratedTypeRefs - ++ go TypeOpRef exportedTypeOps - ++ go TypeClassRef exportedTypeClasses - ++ go ValueRef exportedValues - ++ go ValueOpRef exportedValueOps - ++ go KindRef exportedKinds + ++ go (TypeOpRef ss) exportedTypeOps + ++ go (TypeClassRef ss) exportedTypeClasses + ++ go (ValueRef ss) exportedValues + ++ go (ValueOpRef ss) exportedValueOps + ++ go (KindRef ss) exportedKinds ++ maybe [] (filter isModuleRef) refs where elaboratedTypeRefs :: [DeclarationRef] elaboratedTypeRefs = flip map (M.toList (exportedTypes exps)) $ \(tctor, (dctors, mn')) -> - let ref = TypeRef tctor (Just dctors) - in if mn == mn' then ref else ReExportRef mn' ref + let ref = TypeRef ss tctor (Just dctors) + in if mn == mn' then ref else ReExportRef ss mn' ref go :: (a -> DeclarationRef) -> (Exports -> M.Map a ModuleName) -> [DeclarationRef] go toRef select = flip map (M.toList (select exps)) $ \(export, mn') -> - if mn == mn' then toRef export else ReExportRef mn' (toRef export) + if mn == mn' then toRef export else ReExportRef ss mn' (toRef export) -- | -- Replaces all local names with qualified names within a module and checks that all existing diff --git a/src/Language/PureScript/Sugar/Names/Common.hs b/src/Language/PureScript/Sugar/Names/Common.hs index a827041419..6a681401e2 100644 --- a/src/Language/PureScript/Sugar/Names/Common.hs +++ b/src/Language/PureScript/Sugar/Names/Common.hs @@ -6,8 +6,7 @@ import Protolude (ordNub) import Control.Monad.Writer (MonadWriter(..)) import Data.Foldable (for_) -import Data.Function (on) -import Data.List (nubBy, (\\)) +import Data.List (nub, (\\)) import Data.Maybe (mapMaybe) import Language.PureScript.AST @@ -25,7 +24,7 @@ warnDuplicateRefs -> m () warnDuplicateRefs pos toError refs = do let withoutCtors = deleteCtors `map` refs - dupeRefs = mapMaybe (refToName pos) $ withoutCtors \\ nubBy ((==) `on` withoutPosInfo) withoutCtors + dupeRefs = mapMaybe (refToName pos) $ withoutCtors \\ nub withoutCtors dupeCtors = concat $ mapMaybe (extractCtors pos) refs for_ (dupeRefs ++ dupeCtors) $ \(pos', name) -> @@ -33,37 +32,26 @@ warnDuplicateRefs pos toError refs = do where - -- Returns a DeclarationRef unwrapped from any PositionedDeclarationRef - -- constructor(s) it may be wrapped within. Used so position info is ignored - -- when making the comparison for duplicates. - withoutPosInfo :: DeclarationRef -> DeclarationRef - withoutPosInfo (PositionedDeclarationRef _ _ ref) = withoutPosInfo ref - withoutPosInfo other = other - -- Deletes the constructor information from TypeRefs so that only the -- referenced type is used in the duplicate check - constructors are handled -- separately deleteCtors :: DeclarationRef -> DeclarationRef - deleteCtors (PositionedDeclarationRef ss com ref) = - PositionedDeclarationRef ss com (deleteCtors ref) - deleteCtors (TypeRef pn _) = TypeRef pn Nothing + deleteCtors (TypeRef sa pn _) = TypeRef sa pn Nothing deleteCtors other = other -- Extracts the names of duplicate constructor references from TypeRefs. extractCtors :: SourceSpan -> DeclarationRef -> Maybe [(SourceSpan, Name)] - extractCtors _ (PositionedDeclarationRef pos' _ ref) = extractCtors pos' ref - extractCtors pos' (TypeRef _ (Just dctors)) = + extractCtors pos' (TypeRef _ _ (Just dctors)) = let dupes = dctors \\ ordNub dctors in if null dupes then Nothing else Just $ ((pos',) . DctorName) <$> dupes extractCtors _ _ = Nothing -- Converts a DeclarationRef into a name for an error message. refToName :: SourceSpan -> DeclarationRef -> Maybe (SourceSpan, Name) - refToName pos' (TypeRef name _) = Just (pos', TyName name) - refToName pos' (TypeOpRef op) = Just (pos', TyOpName op) - refToName pos' (ValueRef name) = Just (pos', IdentName name) - refToName pos' (ValueOpRef op) = Just (pos', ValOpName op) - refToName pos' (TypeClassRef name) = Just (pos', TyClassName name) - refToName pos' (ModuleRef name) = Just (pos', ModName name) - refToName _ (PositionedDeclarationRef pos' _ ref) = refToName pos' ref + refToName pos' (TypeRef _ name _) = Just (pos', TyName name) + refToName pos' (TypeOpRef _ op) = Just (pos', TyOpName op) + refToName pos' (ValueRef _ name) = Just (pos', IdentName name) + refToName pos' (ValueOpRef _ op) = Just (pos', ValOpName op) + refToName pos' (TypeClassRef _ name) = Just (pos', TyClassName name) + refToName pos' (ModuleRef _ name) = Just (pos', ModName name) refToName _ _ = Nothing diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index ac502f5877..31d3bda53d 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -84,9 +84,7 @@ resolveExports env ss mn imps exps refs = -- `DeclarationRef` for an explicit export. When the ref refers to another -- module, export anything from the imports that matches for that module. elaborateModuleExports :: Exports -> DeclarationRef -> m Exports - elaborateModuleExports result (PositionedDeclarationRef pos _ r) = - warnAndRethrowWithPosition pos $ elaborateModuleExports result r - elaborateModuleExports result (ModuleRef name) | name == mn = do + elaborateModuleExports result (ModuleRef _ name) | name == mn = do let types' = exportedTypes result `M.union` exportedTypes exps let typeOps' = exportedTypeOps result `M.union` exportedTypeOps exps let classes' = exportedTypeClasses result `M.union` exportedTypeClasses exps @@ -101,10 +99,10 @@ resolveExports env ss mn imps exps refs = , exportedValueOps = valueOps' , exportedKinds = kinds' } - elaborateModuleExports result (ModuleRef name) = do + elaborateModuleExports result (ModuleRef ss' name) = do let isPseudo = isPseudoModule name when (not isPseudo && not (isImportedModule name)) - . throwError . errorMessage . UnknownExport $ ModName name + . throwError . errorMessage' ss' . UnknownExport $ ModName name reTypes <- extract isPseudo name TyName (importedTypes imps) reTypeOps <- extract isPseudo name TyOpName (importedTypeOps imps) reDctors <- extract isPseudo name DctorName (importedDataConstructors imps) @@ -270,21 +268,19 @@ filterModule mn exps refs = do -- listing for the last ref would be used. combineTypeRefs :: [DeclarationRef] -> [DeclarationRef] combineTypeRefs - = fmap (uncurry TypeRef) - . map (foldr1 $ \(tc, dcs1) (_, dcs2) -> (tc, liftM2 (++) dcs1 dcs2)) - . groupBy ((==) `on` fst) - . sortBy (compare `on` fst) - . mapMaybe getTypeRef + = fmap (\(ss', (tc, dcs)) -> TypeRef ss' tc dcs) + . fmap (foldr1 $ \(ss, (tc, dcs1)) (_, (_, dcs2)) -> (ss, (tc, liftM2 (++) dcs1 dcs2))) + . groupBy ((==) `on` (fst . snd)) + . sortBy (compare `on` (fst . snd)) + . mapMaybe (\ref -> (declRefSourceSpan ref,) <$> getTypeRef ref) filterTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) -> DeclarationRef -> m (M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)) - filterTypes result (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ filterTypes result r - filterTypes result (TypeRef name expDcons) = + filterTypes result (TypeRef ss name expDcons) = case name `M.lookup` exportedTypes exps of - Nothing -> throwError . errorMessage . UnknownExport $ TyName name + Nothing -> throwError . errorMessage' ss . UnknownExport $ TyName name Just (dcons, _) -> do let expDcons' = fromMaybe dcons expDcons traverse_ (checkDcon name dcons) expDcons' @@ -299,8 +295,8 @@ filterModule mn exps refs = do -> ProperName 'ConstructorName -> m () checkDcon tcon dcons dcon = - unless (dcon `elem` dcons) $ - throwError . errorMessage $ UnknownExportDataConstructor tcon dcon + unless (dcon `elem` dcons) . + throwError . errorMessage' ss $ UnknownExportDataConstructor tcon dcon filterTypes result _ = return result filterExport @@ -311,12 +307,10 @@ filterModule mn exps refs = do -> M.Map a ModuleName -> DeclarationRef -> m (M.Map a ModuleName) - filterExport toName get fromExps result (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ filterExport toName get fromExps result r filterExport toName get fromExps result ref | Just name <- get ref = case name `M.lookup` fromExps exps of -- TODO: I'm not sure if we actually need to check mn == mn' here -gb Just mn' | mn == mn' -> return $ M.insert name mn result - _ -> throwError . errorMessage . UnknownExport $ toName name + _ -> throwError . errorMessage' (declRefSourceSpan ref) . UnknownExport $ toName name filterExport _ _ _ result _ = return result diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 9250038ce5..f1a247acb4 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -21,7 +21,7 @@ import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Sugar.Names.Env -type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) +type ImportDef = (SourceSpan, ImportDeclarationType, Maybe ModuleName) -- | -- Finds the imports within a module, mapping the imported module name to an optional set of @@ -30,13 +30,12 @@ type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) findImports :: [Declaration] -> M.Map ModuleName [ImportDef] -findImports = foldl (go Nothing) M.empty +findImports = foldr go M.empty where - go pos result (ImportDeclaration mn typ qual) = + go (ImportDeclaration (pos, _) mn typ qual) result = let imp = (pos, typ, qual) in M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result - go _ result (PositionedDeclaration pos _ d) = go (Just pos) result d - go _ result _ = result + go _ result = result -- | -- Constructs a set of imports for a module. @@ -51,7 +50,7 @@ resolveImports env (Module ss coms currentModule decls exps) = rethrow (addHint (ErrorInModule currentModule)) $ do let imports = findImports decls imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports - scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports' + scope = M.insert currentModule [(internalModuleSourceSpan "", Nothing, Nothing)] imports' (Module ss coms currentModule decls exps,) <$> foldM (resolveModuleImport env) primImports (M.toList scope) @@ -61,17 +60,17 @@ resolveModuleImport . MonadError MultipleErrors m => Env -> Imports - -> (ModuleName, [(Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)]) + -> (ModuleName, [(SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)]) -> m Imports resolveModuleImport env ie (mn, imps) = foldM go ie imps where go :: Imports - -> (Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName) + -> (SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName) -> m Imports - go ie' (pos, typ, impQual) = do + go ie' (ss, typ, impQual) = do modExports <- - positioned $ maybe - (throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn) + maybe + (throwError . errorMessage' ss . UnknownName . Qualified Nothing $ ModName mn) (return . envModuleExports) (mn `M.lookup` env) let impModules = importedModules ie' @@ -79,11 +78,7 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps ie'' = ie' { importedModules = maybe (S.insert mn impModules) (const impModules) impQual , importedQualModules = maybe qualModules (`S.insert` qualModules) impQual } - positioned $ resolveImport mn modExports ie'' impQual typ - where - positioned err = case pos of - Nothing -> err - Just pos' -> rethrowWithPosition pos' err + resolveImport mn modExports ie'' impQual ss typ -- | -- Extends the local environment for a module by resolving an import of another module. @@ -95,67 +90,68 @@ resolveImport -> Exports -> Imports -> Maybe ModuleName + -> SourceSpan -> Maybe ImportDeclarationType -> m Imports resolveImport importModule exps imps impQual = resolveByType where - resolveByType :: Maybe ImportDeclarationType -> m Imports - resolveByType Nothing = - importAll (importRef Local) - resolveByType (Just Implicit) = - importAll (importRef FromImplicit) - resolveByType (Just (Explicit refs)) = + resolveByType :: SourceSpan -> Maybe ImportDeclarationType -> m Imports + resolveByType ss Nothing = + importAll ss (importRef Local) + resolveByType ss (Just Implicit) = + importAll ss (importRef FromImplicit) + resolveByType _ (Just (Explicit refs)) = checkRefs False refs >> foldM (importRef FromExplicit) imps refs - resolveByType (Just (Hiding refs)) = - checkRefs True refs >> importAll (importNonHidden refs) + resolveByType ss (Just (Hiding refs)) = + checkRefs True refs >> importAll ss (importNonHidden refs) -- Check that a 'DeclarationRef' refers to an importable symbol checkRefs :: Bool -> [DeclarationRef] -> m () checkRefs isHiding = traverse_ check where - check (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ check r - check (ValueRef name) = - checkImportExists IdentName (exportedValues exps) name - check (ValueOpRef op) = - checkImportExists ValOpName (exportedValueOps exps) op - check (TypeRef name dctors) = do - checkImportExists TyName (exportedTypes exps) name + check (ValueRef ss name) = + checkImportExists ss IdentName (exportedValues exps) name + check (ValueOpRef ss op) = + checkImportExists ss ValOpName (exportedValueOps exps) op + check (TypeRef ss name dctors) = do + checkImportExists ss TyName (exportedTypes exps) name let (allDctors, _) = allExportedDataConstructors name - for_ dctors $ traverse_ (checkDctorExists name allDctors) - check (TypeOpRef name) = - checkImportExists TyOpName (exportedTypeOps exps) name - check (TypeClassRef name) = - checkImportExists TyClassName (exportedTypeClasses exps) name - check (ModuleRef name) | isHiding = - throwError . errorMessage $ ImportHidingModule name - check (KindRef name) = do - checkImportExists KiName (exportedKinds exps) name + for_ dctors $ traverse_ (checkDctorExists ss name allDctors) + check (TypeOpRef ss name) = + checkImportExists ss TyOpName (exportedTypeOps exps) name + check (TypeClassRef ss name) = + checkImportExists ss TyClassName (exportedTypeClasses exps) name + check (ModuleRef ss name) | isHiding = + throwError . errorMessage' ss $ ImportHidingModule name + check (KindRef ss name) = + checkImportExists ss KiName (exportedKinds exps) name check r = internalError $ "Invalid argument to checkRefs: " ++ show r -- Check that an explicitly imported item exists in the module it is being imported from checkImportExists :: Ord a - => (a -> Name) + => SourceSpan + -> (a -> Name) -> M.Map a b -> a -> m () - checkImportExists toName exports item + checkImportExists ss toName exports item = when (item `M.notMember` exports) - . throwError . errorMessage + . throwError . errorMessage' ss $ UnknownImport importModule (toName item) -- Ensure that an explicitly imported data constructor exists for the type it is being imported -- from checkDctorExists - :: ProperName 'TypeName + :: SourceSpan + -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ProperName 'ConstructorName -> m () - checkDctorExists tcon exports dctor + checkDctorExists ss tcon exports dctor = when (dctor `notElem` exports) - . throwError . errorMessage + . throwError . errorMessage' ss $ UnknownImportDataConstructor importModule tcon dctor importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports @@ -164,51 +160,47 @@ resolveImport importModule exps imps impQual = resolveByType where -- TODO: rework this to be not confusing isHidden :: DeclarationRef -> Bool - isHidden ref'@(TypeRef _ _) = foldl (checkTypeRef ref') False hidden + isHidden ref'@TypeRef{} = foldl (checkTypeRef ref') False hidden isHidden ref' = ref' `elem` hidden checkTypeRef :: DeclarationRef -> Bool -> DeclarationRef -> Bool checkTypeRef _ True _ = True - checkTypeRef r acc (PositionedDeclarationRef _ _ h) = checkTypeRef r acc h - checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc - checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor' - checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name' - checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef + checkTypeRef (TypeRef _ _ Nothing) acc (TypeRef _ _ (Just _)) = acc + checkTypeRef (TypeRef _ name (Just dctor)) _ (TypeRef _ name' (Just dctor')) = name == name' && dctor == dctor' + checkTypeRef (TypeRef _ name _) _ (TypeRef _ name' Nothing) = name == name' checkTypeRef _ acc _ = acc -- Import all symbols - importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports - importAll importer = - foldM (\m (name, (dctors, _)) -> importer m (TypeRef name (Just dctors))) imps (M.toList (exportedTypes exps)) - >>= flip (foldM (\m (name, _) -> importer m (TypeOpRef name))) (M.toList (exportedTypeOps exps)) - >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (M.toList (exportedValues exps)) - >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (M.toList (exportedValueOps exps)) - >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (M.toList (exportedTypeClasses exps)) - >>= flip (foldM (\m (name, _) -> importer m (KindRef name))) (M.toList (exportedKinds exps)) + importAll :: SourceSpan -> (Imports -> DeclarationRef -> m Imports) -> m Imports + importAll ss importer = + foldM (\m (name, (dctors, _)) -> importer m (TypeRef ss name (Just dctors))) imps (M.toList (exportedTypes exps)) + >>= flip (foldM (\m (name, _) -> importer m (TypeOpRef ss name))) (M.toList (exportedTypeOps exps)) + >>= flip (foldM (\m (name, _) -> importer m (ValueRef ss name))) (M.toList (exportedValues exps)) + >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef ss name))) (M.toList (exportedValueOps exps)) + >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef ss name))) (M.toList (exportedTypeClasses exps)) + >>= flip (foldM (\m (name, _) -> importer m (KindRef ss name))) (M.toList (exportedKinds exps)) importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports - importRef prov imp (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ importRef prov imp r - importRef prov imp (ValueRef name) = do + importRef prov imp (ValueRef _ name) = do let values' = updateImports (importedValues imp) (exportedValues exps) id name prov return $ imp { importedValues = values' } - importRef prov imp (ValueOpRef name) = do + importRef prov imp (ValueOpRef _ name) = do let valueOps' = updateImports (importedValueOps imp) (exportedValueOps exps) id name prov return $ imp { importedValueOps = valueOps' } - importRef prov imp (TypeRef name dctors) = do + importRef prov imp (TypeRef ss name dctors) = do let types' = updateImports (importedTypes imp) (exportedTypes exps) snd name prov let (dctorNames, mn) = allExportedDataConstructors name dctorLookup :: M.Map (ProperName 'ConstructorName) ModuleName dctorLookup = M.fromList $ map (, mn) dctorNames - traverse_ (traverse_ $ checkDctorExists name dctorNames) dctors + traverse_ (traverse_ $ checkDctorExists ss name dctorNames) dctors let dctors' = foldl (\m d -> updateImports m dctorLookup id d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors) return $ imp { importedTypes = types', importedDataConstructors = dctors' } - importRef prov imp (TypeOpRef name) = do + importRef prov imp (TypeOpRef _ name) = do let ops' = updateImports (importedTypeOps imp) (exportedTypeOps exps) id name prov return $ imp { importedTypeOps = ops' } - importRef prov imp (TypeClassRef name) = do + importRef prov imp (TypeClassRef _ name) = do let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) id name prov return $ imp { importedTypeClasses = typeClasses' } - importRef prov imp (KindRef name) = do + importRef prov imp (KindRef _ name) = do let kinds' = updateImports (importedKinds imp) (exportedKinds exps) id name prov return $ imp { importedKinds = kinds' } importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef" diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 82af60f40b..0e433789c7 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -367,23 +367,21 @@ checkFixityExports m@(Module ss _ mn ds (Just exps)) = where checkRef :: DeclarationRef -> m () - checkRef (PositionedDeclarationRef pos _ d) = - rethrowWithPosition pos $ checkRef d - checkRef dr@(ValueOpRef op) = + checkRef dr@(ValueOpRef ss' op) = for_ (getValueOpAlias op) $ \case Left ident -> - unless (ValueRef ident `elem` exps) - . throwError . errorMessage - $ TransitiveExportError dr [ValueRef ident] + unless (ValueRef ss' ident `elem` exps) + . throwError . errorMessage' ss' + $ TransitiveExportError dr [ValueRef ss' ident] Right ctor -> unless (anyTypeRef (maybe False (elem ctor) . snd)) - . throwError . errorMessage + . throwError . errorMessage' ss $ TransitiveDctorExportError dr ctor - checkRef dr@(TypeOpRef op) = + checkRef dr@(TypeOpRef ss' op) = for_ (getTypeOpAlias op) $ \ty -> unless (anyTypeRef ((== ty) . fst)) - . throwError . errorMessage - $ TransitiveExportError dr [TypeRef ty Nothing] + . throwError . errorMessage' ss' + $ TransitiveExportError dr [TypeRef ss' ty Nothing] checkRef _ = return () -- Finds the name associated with a type operator when that type is also diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 73fe3d623b..bbddb5cdd2 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -195,11 +195,11 @@ desugarDecl mn exps = go expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef expRef name className tys - | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name + | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef genSpan name | otherwise = Nothing isExportedClass :: Qualified (ProperName 'ClassName) -> Bool - isExportedClass = isExported (elem . TypeClassRef) + isExportedClass = isExported (elem . TypeClassRef genSpan) isExportedType :: Qualified (ProperName 'TypeName) -> Bool isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn) @@ -212,7 +212,7 @@ desugarDecl mn exps = go isExported _ _ = internalError "Names should have been qualified in name desugaring" matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool - matchesTypeRef pn (TypeRef pn' _) = pn == pn' + matchesTypeRef pn (TypeRef _ pn' _) = pn == pn' matchesTypeRef _ _ = False getConstructors :: Type -> [Qualified (ProperName 'TypeName)] @@ -221,6 +221,9 @@ desugarDecl mn exps = go getConstructor (TypeConstructor tcname) = [tcname] getConstructor _ = [] + genSpan :: SourceSpan + genSpan = internalModuleSourceSpan "" + memberToNameAndType :: Declaration -> (Ident, Type) memberToNameAndType (TypeDeclaration ident ty) = (ident, ty) memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 1323b575ed..50cef84404 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -428,7 +428,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = where checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m () - checkMemberExport extract dr@(TypeRef name dctors) = do + checkMemberExport extract dr@(TypeRef _ name dctors) = do env <- getEnv case M.lookup (Qualified (Just mn) name) (typeSynonyms env) of Nothing -> return () @@ -440,7 +440,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = Nothing -> return () Just (_, _, ty, _) -> checkExport dr extract ty return () - checkMemberExport extract dr@(ValueRef name) = do + checkMemberExport extract dr@(ValueRef _ name) = do ty <- lookupVariable (Qualified (Just mn) name) checkExport dr extract ty checkMemberExport _ _ = return () @@ -448,51 +448,50 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m () checkExport dr extract ty = case filter (not . exported) (extract ty) of [] -> return () - hidden -> throwError . errorMessage $ TransitiveExportError dr (nubBy nubEq hidden) + hidden -> throwError . errorMessage' (declRefSourceSpan dr) $ TransitiveExportError dr (nubBy nubEq hidden) where exported e = any (exports e) exps - exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2 - exports (ValueRef id1) (ValueRef id2) = id1 == id2 - exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2 - exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2 - exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2 + exports (TypeRef _ pn1 _) (TypeRef _ pn2 _) = pn1 == pn2 + exports (ValueRef _ id1) (ValueRef _ id2) = id1 == id2 + exports (TypeClassRef _ pn1) (TypeClassRef _ pn2) = pn1 == pn2 exports _ _ = False -- We avoid Eq for `nub`bing as the dctor part of `TypeRef` evaluates to -- `error` for the values generated here (we don't need them anyway) - nubEq (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2 + nubEq (TypeRef _ pn1 _) (TypeRef _ pn2 _) = pn1 == pn2 nubEq r1 r2 = r1 == r2 -- 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 -> m () - checkTypesAreExported = checkMemberExport findTcons + checkTypesAreExported ref = checkMemberExport findTcons ref where findTcons :: Type -> [DeclarationRef] findTcons = everythingOnTypes (++) go where - go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (internalError "Data constructors unused in checkTypesAreExported")] + go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = + [TypeRef (declRefSourceSpan ref) name (internalError "Data constructors unused in checkTypesAreExported")] go _ = [] -- Check that all the classes defined in the current module that appear in member types have also -- been exported from the module checkClassesAreExported :: DeclarationRef -> m () - checkClassesAreExported = checkMemberExport findClasses + checkClassesAreExported ref = checkMemberExport findClasses ref where findClasses :: Type -> [DeclarationRef] findClasses = everythingOnTypes (++) go where - go (ConstrainedType c _) = (fmap TypeClassRef . extractCurrentModuleClass . constraintClass) c + go (ConstrainedType c _) = (fmap (TypeClassRef (declRefSourceSpan ref)) . extractCurrentModuleClass . constraintClass) c go _ = [] extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> [ProperName 'ClassName] extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = [name] extractCurrentModuleClass _ = [] checkClassMembersAreExported :: DeclarationRef -> m () - checkClassMembersAreExported dr@(TypeClassRef name) = do - let members = ValueRef `map` head (mapMaybe findClassMembers decls) + checkClassMembersAreExported dr@(TypeClassRef ss' name) = do + let members = ValueRef ss' `map` head (mapMaybe findClassMembers decls) let missingMembers = members \\ exps - unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members + unless (null missingMembers) . throwError . errorMessage' ss' $ TransitiveExportError dr members where findClassMembers :: Declaration -> Maybe [Ident] findClassMembers (TypeClassDeclaration name' _ _ _ ds) | name == name' = Just $ map extractMemberName ds diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index 2a6952e46e..cba4690a4b 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -27,24 +27,27 @@ env = Map.fromList type Refs = [(P.ModuleName, P.DeclarationRef)] +testSpan :: P.SourceSpan +testSpan = P.internalModuleSourceSpan "" + succTestCases :: [(Text, Refs, [IdeDeclarationAnn])] succTestCases = - [ ("resolves a value reexport", [(mn "A", P.ValueRef (P.Ident "valueA"))], [valueA `annExp` "A"]) + [ ("resolves a value reexport", [(mn "A", P.ValueRef testSpan (P.Ident "valueA"))], [valueA `annExp` "A"]) , ("resolves a type reexport with explicit data constructors" - , [(mn "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], [typeA `annExp` "A", dtorA1 `annExp` "A"]) + , [(mn "A", P.TypeRef testSpan (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], [typeA `annExp` "A", dtorA1 `annExp` "A"]) , ("resolves a type reexport with implicit data constructors" - , [(mn "A", P.TypeRef (P.ProperName "TypeA") Nothing)], map (`annExp` "A") [typeA, dtorA1, dtorA2]) + , [(mn "A", P.TypeRef testSpan (P.ProperName "TypeA") Nothing)], map (`annExp` "A") [typeA, dtorA1, dtorA2]) , ("resolves a synonym reexport" - , [(mn "A", P.TypeRef (P.ProperName "SynonymA") Nothing)], [synonymA `annExp` "A"]) - , ("resolves a class reexport", [(mn "A", P.TypeClassRef (P.ProperName "ClassA"))], [classA `annExp` "A"]) - , ("resolves a kind reexport", [(mn "A", P.KindRef (P.ProperName "KindA"))], [kindA `annExp` "A"]) + , [(mn "A", P.TypeRef testSpan (P.ProperName "SynonymA") Nothing)], [synonymA `annExp` "A"]) + , ("resolves a class reexport", [(mn "A", P.TypeClassRef testSpan (P.ProperName "ClassA"))], [classA `annExp` "A"]) + , ("resolves a kind reexport", [(mn "A", P.KindRef testSpan (P.ProperName "KindA"))], [kindA `annExp` "A"]) ] failTestCases :: [(Text, Refs)] failTestCases = - [ ("fails to resolve a non existing value", [(mn "A", P.ValueRef (P.Ident "valueB"))]) - , ("fails to resolve a non existing type reexport" , [(mn "A", P.TypeRef (P.ProperName "TypeB") Nothing)]) - , ("fails to resolve a non existing class reexport", [(mn "A", P.TypeClassRef (P.ProperName "ClassB"))]) + [ ("fails to resolve a non existing value", [(mn "A", P.ValueRef testSpan (P.Ident "valueB"))]) + , ("fails to resolve a non existing type reexport" , [(mn "A", P.TypeRef testSpan (P.ProperName "TypeB") Nothing)]) + , ("fails to resolve a non existing class reexport", [(mn "A", P.TypeClassRef testSpan (P.ProperName "ClassB"))]) ] spec :: Spec From f1128ecb6f01bb1809adc9787df2958d9fefc096 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 17 Jun 2017 12:21:30 +0100 Subject: [PATCH 0801/1580] Add source span annotations to Declaration (#2935) * Add `SourceAnn` to `Declaration` constructors * Restore parser functionality * Make the tests compile again * Flip things around with parseValueWithIdentAndBinders * Don't include comments in source span * Include position info & comments in docs again * Ensure binding group decls preserve own `SourceAnn`s * Remove comment * Use positioned errors in exhaustivity checker * Add a position for CycleInModules errors * Add position for CycleInTypeSynonym errors * Remove `SourceSpan` from `BindingGroupDeclaration` * Remove `SourceSpan` from `DataBindingGroupDeclaration` * Remove remaning `todoAnn` values --- app/Command/Docs/Tags.hs | 26 +-- app/Command/Hierarchy.hs | 5 +- src/Language/PureScript/AST/Declarations.hs | 73 +++---- src/Language/PureScript/AST/Exported.hs | 31 ++- src/Language/PureScript/AST/Traversals.hs | 192 ++++++++---------- src/Language/PureScript/CodeGen/JS.hs | 17 +- src/Language/PureScript/CoreFn/Ann.hs | 8 +- src/Language/PureScript/CoreFn/Desugar.hs | 119 +++++------ .../PureScript/Docs/Convert/Single.hs | 99 ++++----- src/Language/PureScript/Errors.hs | 3 +- src/Language/PureScript/Externs.hs | 11 +- src/Language/PureScript/Ide/CaseSplit.hs | 5 +- src/Language/PureScript/Ide/SourceFile.hs | 45 ++-- src/Language/PureScript/Ide/Util.hs | 5 - .../PureScript/Interactive/Completion.hs | 17 +- src/Language/PureScript/Interactive/Module.hs | 8 +- src/Language/PureScript/Interactive/Parser.hs | 6 +- src/Language/PureScript/Linter.hs | 17 +- src/Language/PureScript/Linter/Exhaustive.hs | 69 +++---- src/Language/PureScript/Linter/Imports.hs | 1 - src/Language/PureScript/ModuleDependencies.hs | 18 +- src/Language/PureScript/Parser/Common.hs | 9 +- .../PureScript/Parser/Declarations.hs | 131 ++++++------ src/Language/PureScript/Pretty/Values.hs | 13 +- .../PureScript/Sugar/BindingGroups.hs | 59 +++--- .../PureScript/Sugar/CaseDeclarations.hs | 76 ++++--- src/Language/PureScript/Sugar/DoNotation.hs | 8 +- src/Language/PureScript/Sugar/LetPattern.hs | 9 +- src/Language/PureScript/Sugar/Names.hs | 149 ++++++++------ .../PureScript/Sugar/Names/Exports.hs | 30 +-- .../PureScript/Sugar/ObjectWildcards.hs | 5 +- src/Language/PureScript/Sugar/Operators.hs | 68 +++---- src/Language/PureScript/Sugar/TypeClasses.hs | 55 +++-- .../PureScript/Sugar/TypeClasses/Deriving.hs | 158 +++++++------- .../PureScript/Sugar/TypeDeclarations.hs | 32 ++- src/Language/PureScript/TypeChecker.hs | 109 +++++----- src/Language/PureScript/TypeChecker/Types.hs | 99 ++++----- .../Language/PureScript/Ide/SourceFileSpec.hs | 52 ++--- 38 files changed, 881 insertions(+), 956 deletions(-) diff --git a/app/Command/Docs/Tags.hs b/app/Command/Docs/Tags.hs index 6f15169852..6fd3275179 100644 --- a/app/Command/Docs/Tags.hs +++ b/app/Command/Docs/Tags.hs @@ -6,16 +6,16 @@ import qualified Language.PureScript as P tags :: P.Module -> [(String, Int)] tags = map (first T.unpack) . concatMap dtags . P.exportedDeclarations - where dtags (P.PositionedDeclaration sp _ d) = map tag $ names d - where tag name = (name, line) - line = P.sourcePosLine $ P.spanStart sp - dtags _ = [] - names (P.DataDeclaration _ name _ dcons) = P.runProperName name : consNames - where consNames = map (\(cname, _) -> P.runProperName cname) dcons - names (P.TypeDeclaration ident _) = [P.showIdent ident] - names (P.ExternDeclaration ident _) = [P.showIdent ident] - names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name] - names (P.TypeClassDeclaration name _ _ _ _) = [P.runProperName name] - names (P.TypeInstanceDeclaration name _ _ _ _) = [P.showIdent name] - names (P.ExternKindDeclaration name) = [P.runProperName name] - names _ = [] + where + dtags :: P.Declaration -> [(P.Text, Int)] + dtags (P.DataDeclaration (ss, _) _ name _ dcons) = (P.runProperName name, pos ss) : consNames + where consNames = map (\(cname, _) -> (P.runProperName cname, pos ss)) dcons + dtags (P.TypeDeclaration (ss, _) ident _) = [(P.showIdent ident, pos ss)] + dtags (P.ExternDeclaration (ss, _) ident _) = [(P.showIdent ident, pos ss)] + dtags (P.TypeSynonymDeclaration (ss, _) name _ _) = [(P.runProperName name, pos ss)] + dtags (P.TypeClassDeclaration (ss, _) name _ _ _ _) = [(P.runProperName name, pos ss)] + dtags (P.TypeInstanceDeclaration (ss, _) name _ _ _ _) = [(P.showIdent name, pos ss)] + dtags (P.ExternKindDeclaration (ss, _) name) = [(P.runProperName name, pos ss)] + dtags _ = [] + pos :: P.SourceSpan -> Int + pos = P.sourcePosLine . P.spanStart diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs index 90f322648a..d06918e0cb 100644 --- a/app/Command/Hierarchy.hs +++ b/app/Command/Hierarchy.hs @@ -84,10 +84,9 @@ compile (HierarchyOptions inputGlob mOutput) = do exitSuccess superClasses :: P.Declaration -> [SuperMap] -superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _ _) = +superClasses (P.TypeClassDeclaration _ sub _ supers@(_:_) _ _) = fmap (\(P.Constraint (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers -superClasses (P.TypeClassDeclaration sub _ _ _ _) = [SuperMap (Left sub)] -superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl +superClasses (P.TypeClassDeclaration _ sub _ _ _ _) = [SuperMap (Left sub)] superClasses _ = [] inputFile :: Parser FilePath diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index f4a04746a7..8d8d09f7d1 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -14,6 +14,7 @@ import Control.Monad.Identity import Data.Aeson.TH import qualified Data.Map as M import Data.Text (Text) +import qualified Data.List.NonEmpty as NEL import Language.PureScript.AST.Binders import Language.PureScript.AST.Literals @@ -182,7 +183,7 @@ data ErrorMessageHint | ErrorInApplication Expr Type Expr | ErrorInDataConstructor (ProperName 'ConstructorName) | ErrorInTypeConstructor (ProperName 'TypeName) - | ErrorInBindingGroup [Ident] + | ErrorInBindingGroup (NEL.NonEmpty Ident) | ErrorInDataBindingGroup [ProperName 'TypeName] | ErrorInTypeSynonym (ProperName 'TypeName) | ErrorInValueDeclaration Ident @@ -233,7 +234,6 @@ addDefaultImport toImport m@(Module ss coms mn decls exps) = else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit Nothing : decls) exps where isExistingImport (ImportDeclaration _ mn' _ _) | mn' == toImport = True - isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d isExistingImport _ = False -- | @@ -388,46 +388,46 @@ data Declaration -- | -- A data type declaration (data or newtype, name, arguments, data constructors) -- - = DataDeclaration DataDeclType (ProperName 'TypeName) [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])] + = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])] -- | -- A minimal mutually recursive set of data type declarations -- - | DataBindingGroupDeclaration [Declaration] + | DataBindingGroupDeclaration (NEL.NonEmpty Declaration) -- | -- A type synonym declaration (name, arguments, type) -- - | TypeSynonymDeclaration (ProperName 'TypeName) [(Text, Maybe Kind)] Type + | TypeSynonymDeclaration SourceAnn (ProperName 'TypeName) [(Text, Maybe Kind)] Type -- | -- A type declaration for a value (name, ty) -- - | TypeDeclaration Ident Type + | TypeDeclaration SourceAnn Ident Type -- | -- A value declaration (name, top-level binders, optional guard, value) -- - | ValueDeclaration Ident NameKind [Binder] [GuardedExpr] + | ValueDeclaration SourceAnn Ident NameKind [Binder] [GuardedExpr] -- | -- A declaration paired with pattern matching in let-in expression (binder, optional guard, value) - | BoundValueDeclaration Binder Expr + | BoundValueDeclaration SourceAnn Binder Expr -- | -- A minimal mutually recursive set of value declarations -- - | BindingGroupDeclaration [(Ident, NameKind, Expr)] + | BindingGroupDeclaration (NEL.NonEmpty ((SourceAnn, Ident), NameKind, Expr)) -- | -- A foreign import declaration (name, type) -- - | ExternDeclaration Ident Type + | ExternDeclaration SourceAnn Ident Type -- | -- A data type foreign import (name, kind) -- - | ExternDataDeclaration (ProperName 'TypeName) Kind + | ExternDataDeclaration SourceAnn (ProperName 'TypeName) Kind -- | -- A foreign kind import (name) -- - | ExternKindDeclaration (ProperName 'KindName) + | ExternKindDeclaration SourceAnn (ProperName 'KindName) -- | -- A fixity declaration -- - | FixityDeclaration (Either ValueFixity TypeFixity) + | FixityDeclaration SourceAnn (Either ValueFixity TypeFixity) -- | -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name) -- @@ -435,16 +435,12 @@ data Declaration -- | -- A type class declaration (name, argument, implies, member declarations) -- - | TypeClassDeclaration (ProperName 'ClassName) [(Text, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration] + | TypeClassDeclaration SourceAnn (ProperName 'ClassName) [(Text, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration] -- | -- A type instance declaration (name, dependencies, class name, instance types, member -- declarations) -- - | TypeInstanceDeclaration Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody - -- | - -- A declaration with source position information - -- - | PositionedDeclaration SourceSpan [Comment] Declaration + | TypeInstanceDeclaration SourceAnn Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody deriving (Show) data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName) @@ -453,11 +449,11 @@ data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'Cons data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName) deriving (Eq, Ord, Show) -pattern ValueFixityDeclaration :: Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration -pattern ValueFixityDeclaration fixity name op = FixityDeclaration (Left (ValueFixity fixity name op)) +pattern ValueFixityDeclaration :: SourceAnn -> Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration +pattern ValueFixityDeclaration sa fixity name op = FixityDeclaration sa (Left (ValueFixity fixity name op)) -pattern TypeFixityDeclaration :: Fixity -> Qualified (ProperName 'TypeName) -> OpName 'TypeOpName -> Declaration -pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFixity fixity name op)) +pattern TypeFixityDeclaration :: SourceAnn -> Fixity -> Qualified (ProperName 'TypeName) -> OpName 'TypeOpName -> Declaration +pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (TypeFixity fixity name op)) -- | The members of a type class instance declaration data TypeInstanceBody @@ -480,12 +476,30 @@ traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration] traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds traverseTypeInstanceBody _ other = pure other +declSourceAnn :: Declaration -> SourceAnn +declSourceAnn (DataDeclaration sa _ _ _ _) = sa +declSourceAnn (DataBindingGroupDeclaration ds) = declSourceAnn (NEL.head ds) +declSourceAnn (TypeSynonymDeclaration sa _ _ _) = sa +declSourceAnn (TypeDeclaration sa _ _) = sa +declSourceAnn (ValueDeclaration sa _ _ _ _) = sa +declSourceAnn (BoundValueDeclaration sa _ _) = sa +declSourceAnn (BindingGroupDeclaration ds) = let ((sa, _), _, _) = NEL.head ds in sa +declSourceAnn (ExternDeclaration sa _ _) = sa +declSourceAnn (ExternDataDeclaration sa _ _) = sa +declSourceAnn (ExternKindDeclaration sa _) = sa +declSourceAnn (FixityDeclaration sa _) = sa +declSourceAnn (ImportDeclaration sa _ _ _) = sa +declSourceAnn (TypeClassDeclaration sa _ _ _ _ _) = sa +declSourceAnn (TypeInstanceDeclaration sa _ _ _ _ _) = sa + +declSourceSpan :: Declaration -> SourceSpan +declSourceSpan = fst . declSourceAnn + -- | -- Test if a declaration is a value declaration -- isValueDecl :: Declaration -> Bool isValueDecl ValueDeclaration{} = True -isValueDecl (PositionedDeclaration _ _ d) = isValueDecl d isValueDecl _ = False -- | @@ -494,7 +508,6 @@ isValueDecl _ = False isDataDecl :: Declaration -> Bool isDataDecl DataDeclaration{} = True isDataDecl TypeSynonymDeclaration{} = True -isDataDecl (PositionedDeclaration _ _ d) = isDataDecl d isDataDecl _ = False -- | @@ -502,7 +515,6 @@ isDataDecl _ = False -- isImportDecl :: Declaration -> Bool isImportDecl ImportDeclaration{} = True -isImportDecl (PositionedDeclaration _ _ d) = isImportDecl d isImportDecl _ = False -- | @@ -510,7 +522,6 @@ isImportDecl _ = False -- isExternDataDecl :: Declaration -> Bool isExternDataDecl ExternDataDeclaration{} = True -isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d isExternDataDecl _ = False -- | @@ -518,7 +529,6 @@ isExternDataDecl _ = False -- isExternKindDecl :: Declaration -> Bool isExternKindDecl ExternKindDeclaration{} = True -isExternKindDecl (PositionedDeclaration _ _ d) = isExternKindDecl d isExternKindDecl _ = False -- | @@ -526,12 +536,10 @@ isExternKindDecl _ = False -- isFixityDecl :: Declaration -> Bool isFixityDecl FixityDeclaration{} = True -isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d isFixityDecl _ = False getFixityDecl :: Declaration -> Maybe (Either ValueFixity TypeFixity) -getFixityDecl (FixityDeclaration fixity) = Just fixity -getFixityDecl (PositionedDeclaration _ _ d) = getFixityDecl d +getFixityDecl (FixityDeclaration _ fixity) = Just fixity getFixityDecl _ = Nothing -- | @@ -539,7 +547,6 @@ getFixityDecl _ = Nothing -- isExternDecl :: Declaration -> Bool isExternDecl ExternDeclaration{} = True -isExternDecl (PositionedDeclaration _ _ d) = isExternDecl d isExternDecl _ = False -- | @@ -547,7 +554,6 @@ isExternDecl _ = False -- isTypeClassInstanceDeclaration :: Declaration -> Bool isTypeClassInstanceDeclaration TypeInstanceDeclaration{} = True -isTypeClassInstanceDeclaration (PositionedDeclaration _ _ d) = isTypeClassInstanceDeclaration d isTypeClassInstanceDeclaration _ = False -- | @@ -555,7 +561,6 @@ isTypeClassInstanceDeclaration _ = False -- isTypeClassDeclaration :: Declaration -> Bool isTypeClassDeclaration TypeClassDeclaration{} = True -isTypeClassDeclaration (PositionedDeclaration _ _ d) = isTypeClassDeclaration d isTypeClassDeclaration _ = False -- | diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index 257d905d4c..1e5b033528 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -38,11 +38,9 @@ exportedDeclarations (Module _ _ mn decls exps) = go decls -- it unchanged. -- filterDataConstructors :: Maybe [DeclarationRef] -> Declaration -> Declaration -filterDataConstructors exps (DataDeclaration dType tyName tyArgs dctors) = - DataDeclaration dType tyName tyArgs $ +filterDataConstructors exps (DataDeclaration sa dType tyName tyArgs dctors) = + DataDeclaration sa dType tyName tyArgs $ filter (isDctorExported tyName exps . fst) dctors -filterDataConstructors exps (PositionedDeclaration srcSpan coms d) = - PositionedDeclaration srcSpan coms (filterDataConstructors exps d) filterDataConstructors _ other = other -- | @@ -96,7 +94,7 @@ filterInstances mn (Just exps) = -- Get all type and type class names referenced by a type instance declaration. -- typeInstanceConstituents :: Declaration -> [Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))] -typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) = +typeInstanceConstituents (TypeInstanceDeclaration _ _ constraints className tys _) = Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys) where @@ -109,7 +107,6 @@ typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) go (ConstrainedType c _) = fromConstraint c go _ = [] -typeInstanceConstituents (PositionedDeclaration _ _ d) = typeInstanceConstituents d typeInstanceConstituents _ = [] @@ -122,20 +119,18 @@ typeInstanceConstituents _ = [] isExported :: Maybe [DeclarationRef] -> Declaration -> Bool isExported Nothing _ = True isExported _ TypeInstanceDeclaration{} = True -isExported exps (PositionedDeclaration _ _ d) = isExported exps d isExported (Just exps) decl = any (matches decl) exps where - matches (TypeDeclaration ident _) (ValueRef _ ident') = ident == ident' - matches (ValueDeclaration ident _ _ _) (ValueRef _ ident') = ident == ident' - matches (ExternDeclaration ident _) (ValueRef _ ident') = ident == ident' - matches (DataDeclaration _ ident _ _) (TypeRef _ ident' _) = ident == ident' - matches (ExternDataDeclaration ident _) (TypeRef _ ident' _) = ident == ident' - matches (ExternKindDeclaration ident) (KindRef _ ident') = ident == ident' - matches (TypeSynonymDeclaration ident _ _) (TypeRef _ ident' _) = ident == ident' - matches (TypeClassDeclaration ident _ _ _ _) (TypeClassRef _ ident') = ident == ident' - matches (ValueFixityDeclaration _ _ op) (ValueOpRef _ op') = op == op' - matches (TypeFixityDeclaration _ _ op) (TypeOpRef _ op') = op == op' - matches (PositionedDeclaration _ _ d) r = d `matches` r + matches (TypeDeclaration _ ident _) (ValueRef _ ident') = ident == ident' + matches (ValueDeclaration _ ident _ _ _) (ValueRef _ ident') = ident == ident' + matches (ExternDeclaration _ ident _) (ValueRef _ ident') = ident == ident' + matches (DataDeclaration _ _ ident _ _) (TypeRef _ ident' _) = ident == ident' + matches (ExternDataDeclaration _ ident _) (TypeRef _ ident' _) = ident == ident' + matches (ExternKindDeclaration _ ident) (KindRef _ ident') = ident == ident' + matches (TypeSynonymDeclaration _ ident _ _) (TypeRef _ ident' _) = ident == ident' + matches (TypeClassDeclaration _ ident _ _ _ _) (TypeClassRef _ ident') = ident == ident' + matches (ValueFixityDeclaration _ _ _ op) (ValueOpRef _ op') = op == op' + matches (TypeFixityDeclaration _ _ _ op) (TypeOpRef _ op') = op == op' matches _ _ = False -- | diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index d1a8ce59c8..3fe55a8697 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -10,6 +10,7 @@ import Control.Monad import Data.Foldable (fold) import Data.List (mapAccumL) import Data.Maybe (mapMaybe) +import qualified Data.List.NonEmpty as NEL import qualified Data.Set as S import Language.PureScript.AST.Binders @@ -33,7 +34,12 @@ mapGuardedExpr :: (Guard -> Guard) -> GuardedExpr -> GuardedExpr mapGuardedExpr f g (GuardedExpr guards rhs) = - GuardedExpr (map f guards) (g rhs) + GuardedExpr (fmap f guards) (g rhs) + +litM :: Monad m => (a -> m a) -> Literal a -> m (Literal a) +litM go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as +litM go (ArrayLiteral as) = ArrayLiteral <$> traverse go as +litM _ other = pure other everywhereOnValues :: (Declaration -> Declaration) @@ -46,13 +52,12 @@ everywhereOnValues everywhereOnValues f g h = (f', g', h') where f' :: Declaration -> Declaration - f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds)) - f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) (map (mapGuardedExpr handleGuard g') val)) - f' (BoundValueDeclaration b expr) = f (BoundValueDeclaration (h' b) (g' expr)) - f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds)) - f' (TypeClassDeclaration name args implies deps ds) = f (TypeClassDeclaration name args implies deps (map f' ds)) - f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (mapTypeInstanceBody (map f') ds)) - f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d)) + f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (fmap f' ds)) + f' (ValueDeclaration sa name nameKind bs val) = f (ValueDeclaration sa name nameKind (fmap h' bs) (fmap (mapGuardedExpr handleGuard g') val)) + f' (BoundValueDeclaration sa b expr) = f (BoundValueDeclaration sa (h' b) (g' expr)) + f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (fmap (\(name, nameKind, val) -> (name, nameKind, g' val)) ds)) + f' (TypeClassDeclaration sa name args implies deps ds) = f (TypeClassDeclaration sa name args implies deps (fmap f' ds)) + f' (TypeInstanceDeclaration sa name cs className args ds) = f (TypeInstanceDeclaration sa name cs className args (mapTypeInstanceBody (fmap f') ds)) f' other = f other g' :: Expr -> Expr @@ -62,20 +67,20 @@ everywhereOnValues f g h = (f', g', h') g' (Parens v) = g (Parens (g' v)) g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v)) g' (Accessor prop v) = g (Accessor prop (g' v)) - g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs)) + g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (fmap (fmap g') vs)) g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs)) g' (Abs binder v) = g (Abs (h' binder) (g' v)) g' (App v1 v2) = g (App (g' v1) (g' v2)) g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3)) - g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts)) + g' (Case vs alts) = g (Case (fmap g' vs) (fmap handleCaseAlternative alts)) g' (TypedValue check v ty) = g (TypedValue check (g' v) ty) - g' (Let ds v) = g (Let (map f' ds) (g' v)) - g' (Do es) = g (Do (map handleDoNotationElement es)) + g' (Let ds v) = g (Let (fmap f' ds) (g' v)) + g' (Do es) = g (Do (fmap handleDoNotationElement es)) g' (PositionedValue pos com v) = g (PositionedValue pos com (g' v)) g' other = g other h' :: Binder -> Binder - h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs)) + h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (fmap h' bs)) h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3)) h' (ParensInBinder b) = h (ParensInBinder (h' b)) h' (LiteralBinder l) = h (LiteralBinder (lit h' l)) @@ -85,20 +90,20 @@ everywhereOnValues f g h = (f', g', h') h' other = h other lit :: (a -> a) -> Literal a -> Literal a - lit go (ArrayLiteral as) = ArrayLiteral (map go as) - lit go (ObjectLiteral as) = ObjectLiteral (map (fmap go) as) + lit go (ArrayLiteral as) = ArrayLiteral (fmap go as) + lit go (ObjectLiteral as) = ObjectLiteral (fmap (fmap go) as) lit _ other = other handleCaseAlternative :: CaseAlternative -> CaseAlternative handleCaseAlternative ca = - ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca) - , caseAlternativeResult = map (mapGuardedExpr handleGuard g') (caseAlternativeResult ca) + ca { caseAlternativeBinders = fmap h' (caseAlternativeBinders ca) + , caseAlternativeResult = fmap (mapGuardedExpr handleGuard g') (caseAlternativeResult ca) } handleDoNotationElement :: DoNotationElement -> DoNotationElement handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v) handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v) - handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds) + handleDoNotationElement (DoNotationLet ds) = DoNotationLet (fmap f' ds) handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e) handleGuard :: Guard -> Guard @@ -120,16 +125,15 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds - f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val + f' (ValueDeclaration sa name nameKind bs val) = ValueDeclaration sa name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds - f' (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f' <=< f) ds - f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds - f' (BoundValueDeclaration b expr) = BoundValueDeclaration <$> h' b <*> g' expr - f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f') + f' (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f' <=< f) ds + f' (TypeInstanceDeclaration sa name cs className args ds) = TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds + f' (BoundValueDeclaration sa b expr) = BoundValueDeclaration sa <$> h' b <*> g' expr f' other = f other g' :: Expr -> m Expr - g' (Literal l) = Literal <$> lit (g >=> g') l + g' (Literal l) = Literal <$> litM (g >=> g') l g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g') g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g') g' (Parens v) = Parens <$> (g v >>= g') @@ -148,7 +152,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' other = g other h' :: Binder -> m Binder - h' (LiteralBinder l) = LiteralBinder <$> lit (h >=> h') l + h' (LiteralBinder l) = LiteralBinder <$> litM (h >=> h') l h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h') h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h') @@ -157,11 +161,6 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h') h' other = h other - lit :: (a -> m a) -> Literal a -> m (Literal a) - lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as - lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as - lit _ other = pure other - handleCaseAlternative :: CaseAlternative -> m CaseAlternative handleCaseAlternative (CaseAlternative bs val) = CaseAlternative @@ -193,16 +192,15 @@ everywhereOnValuesM f g h = (f', g', h') f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f - f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val) >>= f + f' (ValueDeclaration sa name nameKind bs val) = (ValueDeclaration sa name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val) >>= f f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f - f' (BoundValueDeclaration b expr) = (BoundValueDeclaration <$> h' b <*> g' expr) >>= f - f' (TypeClassDeclaration name args implies deps ds) = (TypeClassDeclaration name args implies deps <$> traverse f' ds) >>= f - f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f - f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f + f' (BoundValueDeclaration sa b expr) = (BoundValueDeclaration sa <$> h' b <*> g' expr) >>= f + f' (TypeClassDeclaration sa name args implies deps ds) = (TypeClassDeclaration sa name args implies deps <$> traverse f' ds) >>= f + f' (TypeInstanceDeclaration sa name cs className args ds) = (TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f f' other = f other g' :: Expr -> m Expr - g' (Literal l) = (Literal <$> lit g' l) >>= g + g' (Literal l) = (Literal <$> litM g' l) >>= g g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g g' (Parens v) = (Parens <$> g' v) >>= g @@ -221,7 +219,7 @@ everywhereOnValuesM f g h = (f', g', h') g' other = g other h' :: Binder -> m Binder - h' (LiteralBinder l) = (LiteralBinder <$> lit h' l) >>= h + h' (LiteralBinder l) = (LiteralBinder <$> litM h' l) >>= h h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h @@ -230,11 +228,6 @@ everywhereOnValuesM f g h = (f', g', h') h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h h' other = h other - lit :: (a -> m a) -> Literal a -> m (Literal a) - lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as - lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as - lit _ other = pure other - handleCaseAlternative :: CaseAlternative -> m CaseAlternative handleCaseAlternative (CaseAlternative bs val) = CaseAlternative @@ -269,13 +262,12 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') where f' :: Declaration -> r - f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds) - f' d@(ValueDeclaration _ _ bs val) = foldl (<>) (f d) (map h' bs ++ concatMap (\(GuardedExpr grd v) -> map k' grd ++ [g' v]) val) - f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds) - f' d@(TypeClassDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds) - f' d@(TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (map f' ds) - f' d@(BoundValueDeclaration b expr) = f d <> h' b <> g' expr - f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1 + f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (fmap f' ds) + f' d@(ValueDeclaration _ _ _ bs val) = foldl (<>) (f d) (fmap h' bs ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) val) + f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (fmap (\(_, _, val) -> g' val) ds) + f' d@(TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>) (f d) (fmap f' ds) + f' d@(TypeInstanceDeclaration _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (fmap f' ds) + f' d@(BoundValueDeclaration _ b expr) = f d <> h' b <> g' expr f' d = f d g' :: Expr -> r @@ -285,21 +277,21 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') g' v@(Parens v1) = g v <> g' v1 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1 g' v@(Accessor _ v1) = g v <> g' v1 - g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs) + g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (fmap (g' . snd) vs) g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (fmap g' vs) g' v@(Abs b v1) = g v <> h' b <> g' v1 g' v@(App v1 v2) = g v <> g' v1 <> g' v2 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3 - g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts) + g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (fmap g' vs)) (fmap i' alts) g' v@(TypedValue _ v1 _) = g v <> g' v1 - g' v@(Let ds v1) = foldl (<>) (g v) (map f' ds) <> g' v1 - g' v@(Do es) = foldl (<>) (g v) (map j' es) + g' v@(Let ds v1) = foldl (<>) (g v) (fmap f' ds) <> g' v1 + g' v@(Do es) = foldl (<>) (g v) (fmap j' es) g' v@(PositionedValue _ _ v1) = g v <> g' v1 g' v = g v h' :: Binder -> r h' b@(LiteralBinder l) = lit (h b) h' l - h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs) + h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (fmap h' bs) h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3 h' b@(ParensInBinder b1) = h b <> h' b1 h' b@(NamedBinder _ b1) = h b <> h' b1 @@ -308,18 +300,18 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') h' b = h b lit :: r -> (a -> r) -> Literal a -> r - lit r go (ArrayLiteral as) = foldl (<>) r (map go as) - lit r go (ObjectLiteral as) = foldl (<>) r (map (go . snd) as) + lit r go (ArrayLiteral as) = foldl (<>) r (fmap go as) + lit r go (ObjectLiteral as) = foldl (<>) r (fmap (go . snd) as) lit r _ _ = r i' :: CaseAlternative -> r i' ca@(CaseAlternative bs gs) = - foldl (<>) (i ca) (map h' bs ++ concatMap (\(GuardedExpr grd val) -> map k' grd ++ [g' val]) gs) + foldl (<>) (i ca) (fmap h' bs ++ concatMap (\(GuardedExpr grd val) -> fmap k' grd ++ [g' val]) gs) j' :: DoNotationElement -> r j' e@(DoNotationValue v) = j e <> g' v j' e@(DoNotationBind b v) = j e <> h' b <> g' v - j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds) + j' e@(DoNotationLet ds) = foldl (<>) (j e) (fmap f' ds) j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1 k' :: Guard -> r @@ -348,12 +340,11 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' f'' s d = let (s', r) = f s d in r <> f' s' d f' :: s -> Declaration -> r - f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds) - f' s (ValueDeclaration _ _ bs val) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(GuardedExpr grd v) -> map (k' s) grd ++ [g'' s v]) val) - f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds) - f' s (TypeClassDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds) - f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (map (f'' s) ds) - f' s (PositionedDeclaration _ _ d1) = f'' s d1 + f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (fmap (f'' s) ds) + f' s (ValueDeclaration _ _ _ bs val) = foldl (<>) r0 (fmap (h'' s) bs ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) val) + f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (fmap (\(_, _, val) -> g'' s val) ds) + f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>) r0 (fmap (f'' s) ds) + f' s (TypeInstanceDeclaration _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (fmap (f'' s) ds) f' _ _ = r0 g'' :: s -> Expr -> r @@ -366,15 +357,15 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' g' s (Parens v1) = g'' s v1 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 - g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs) + g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s . snd) vs) g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s) vs) g' s (Abs binder v1) = h'' s binder <> g'' s v1 g' s (App v1 v2) = g'' s v1 <> g'' s v2 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 - g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts) + g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (fmap (g'' s) vs)) (fmap (i'' s) alts) g' s (TypedValue _ v1 _) = g'' s v1 - g' s (Let ds v1) = foldl (<>) r0 (map (f'' s) ds) <> g'' s v1 - g' s (Do es) = foldl (<>) r0 (map (j'' s) es) + g' s (Let ds v1) = foldl (<>) r0 (fmap (f'' s) ds) <> g'' s v1 + g' s (Do es) = foldl (<>) r0 (fmap (j'' s) es) g' s (PositionedValue _ _ v1) = g'' s v1 g' _ _ = r0 @@ -383,7 +374,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' h' :: s -> Binder -> r h' s (LiteralBinder l) = lit h'' s l - h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs) + h' s (ConstructorBinder _ bs) = foldl (<>) r0 (fmap (h'' s) bs) h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3 h' s (ParensInBinder b) = h'' s b h' s (NamedBinder _ b1) = h'' s b1 @@ -392,15 +383,15 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' h' _ _ = r0 lit :: (s -> a -> r) -> s -> Literal a -> r - lit go s (ArrayLiteral as) = foldl (<>) r0 (map (go s) as) - lit go s (ObjectLiteral as) = foldl (<>) r0 (map (go s . snd) as) + lit go s (ArrayLiteral as) = foldl (<>) r0 (fmap (go s) as) + lit go s (ObjectLiteral as) = foldl (<>) r0 (fmap (go s . snd) as) lit _ _ _ = r0 i'' :: s -> CaseAlternative -> r i'' s ca = let (s', r) = i s ca in r <> i' s' ca i' :: s -> CaseAlternative -> r - i' s (CaseAlternative bs gs) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(GuardedExpr grd val) -> map (k' s) grd ++ [g'' s val]) gs) + i' s (CaseAlternative bs gs) = foldl (<>) r0 (fmap (h'' s) bs ++ concatMap (\(GuardedExpr grd val) -> fmap (k' s) grd ++ [g'' s val]) gs) j'' :: s -> DoNotationElement -> r j'' s e = let (s', r) = j s e in r <> j' s' e @@ -408,7 +399,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' j' :: s -> DoNotationElement -> r j' s (DoNotationValue v) = g'' s v j' s (DoNotationBind b v) = h'' s b <> g'' s v - j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds) + j' s (DoNotationLet ds) = foldl (<>) r0 (fmap (f'' s) ds) j' s (PositionedDoNotationElement _ _ e1) = j'' s e1 k' :: s -> Guard -> r @@ -435,11 +426,10 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j f'' s = uncurry f' <=< f s f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds - f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val + f' s (ValueDeclaration sa name nameKind bs val) = ValueDeclaration sa name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds - f' s (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f'' s) ds - f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds - f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1 + f' s (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f'' s) ds + f' s (TypeInstanceDeclaration sa name cs className args ds) = TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds f' _ other = return other g'' s = uncurry g' <=< g s @@ -516,18 +506,17 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) f' :: S.Set Ident -> Declaration -> r f' s (DataBindingGroupDeclaration ds) = - let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds)) + let s' = S.union s (S.fromList (mapMaybe getDeclIdent (NEL.toList ds))) in foldMap (f'' s') ds - f' s (ValueDeclaration name _ bs val) = + f' s (ValueDeclaration _ name _ bs val) = let s' = S.insert name s s'' = S.union s' (S.fromList (concatMap binderNames bs)) in foldMap (h'' s') bs <> foldMap (l' s'') val f' s (BindingGroupDeclaration ds) = - let s' = S.union s (S.fromList (map (\(name, _, _) -> name) ds)) + let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> name) ds))) in foldMap (\(_, _, val) -> g'' s' val) ds - f' s (TypeClassDeclaration _ _ _ _ ds) = foldMap (f'' s) ds - f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds - f' s (PositionedDeclaration _ _ d) = f'' s d + f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldMap (f'' s) ds + f' s (TypeInstanceDeclaration _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds f' _ _ = mempty g'' :: S.Set Ident -> Expr -> r @@ -607,9 +596,8 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) in r <> l' s' (GuardedExpr gs e) getDeclIdent :: Declaration -> Maybe Ident - getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d - getDeclIdent (ValueDeclaration ident _ _ _) = Just ident - getDeclIdent (TypeDeclaration ident _) = Just ident + getDeclIdent (ValueDeclaration _ ident _ _ _) = Just ident + getDeclIdent (TypeDeclaration _ ident _) = Just ident getDeclIdent _ = Nothing accumTypes @@ -623,16 +611,16 @@ accumTypes ) accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) where - forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors) - forDecls (ExternDeclaration _ ty) = f ty - forDecls (TypeClassDeclaration _ _ implies _ _) = mconcat (concatMap (map f . constraintArgs) implies) - forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . constraintArgs) cs) `mappend` mconcat (map f tys) - forDecls (TypeSynonymDeclaration _ _ ty) = f ty - forDecls (TypeDeclaration _ ty) = f ty + forDecls (DataDeclaration _ _ _ _ dctors) = mconcat (concatMap (fmap f . snd) dctors) + forDecls (ExternDeclaration _ _ ty) = f ty + forDecls (TypeClassDeclaration _ _ _ implies _ _) = mconcat (concatMap (fmap f . constraintArgs) implies) + forDecls (TypeInstanceDeclaration _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) `mappend` mconcat (fmap f tys) + forDecls (TypeSynonymDeclaration _ _ _ ty) = f ty + forDecls (TypeDeclaration _ _ ty) = f ty forDecls _ = mempty - forValues (TypeClassDictionary c _ _) = mconcat (map f (constraintArgs c)) - forValues (DeferredDictionary _ tys) = mconcat (map f tys) + forValues (TypeClassDictionary c _ _) = mconcat (fmap f (constraintArgs c)) + forValues (DeferredDictionary _ tys) = mconcat (fmap f tys) forValues (TypedValue _ _ ty) = f ty forValues _ = mempty @@ -647,21 +635,21 @@ accumKinds ) accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) where - forDecls (DataDeclaration _ _ args dctors) = + forDecls (DataDeclaration _ _ _ args dctors) = foldMap (foldMap f . snd) args `mappend` foldMap (foldMap forTypes . snd) dctors - forDecls (TypeClassDeclaration _ args implies _ _) = + forDecls (TypeClassDeclaration _ _ args implies _ _) = foldMap (foldMap f . snd) args `mappend` foldMap (foldMap forTypes . constraintArgs) implies - forDecls (TypeInstanceDeclaration _ cs _ tys _) = + forDecls (TypeInstanceDeclaration _ _ cs _ tys _) = foldMap (foldMap forTypes . constraintArgs) cs `mappend` foldMap forTypes tys - forDecls (TypeSynonymDeclaration _ args ty) = + forDecls (TypeSynonymDeclaration _ _ args ty) = foldMap (foldMap f . snd) args `mappend` forTypes ty - forDecls (TypeDeclaration _ ty) = forTypes ty - forDecls (ExternDeclaration _ ty) = forTypes ty - forDecls (ExternDataDeclaration _ kn) = f kn + forDecls (TypeDeclaration _ _ ty) = forTypes ty + forDecls (ExternDeclaration _ _ ty) = forTypes ty + forDecls (ExternDataDeclaration _ _ kn) = f kn forDecls _ = mempty forValues (TypeClassDictionary c _ _) = foldMap forTypes (constraintArgs c) @@ -680,5 +668,5 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' where g :: Expr -> Expr g (TypedValue checkTy val t) = TypedValue checkTy val (f t) - g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints + g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (fmap f) c) sco hints g other = other diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 4a67550540..de11a870b3 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -146,13 +146,12 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = js <- valueToJs val withPos ss $ AST.VariableIntroduction Nothing (identToJs ident) (Just js) - withPos :: Maybe SourceSpan -> AST -> m AST - withPos (Just ss) js = do + withPos :: SourceSpan -> AST -> m AST + withPos ss js = do withSM <- asks optionsSourceMaps return $ if withSM then withSourceSpan ss js else js - withPos Nothing js = return js -- | Generate code in the simplified JavaScript intermediate representation for a variable based on a -- PureScript identifier. @@ -177,7 +176,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = valueToJs' :: Expr Ann -> m AST valueToJs' (Literal (pos, _, _, _) l) = - maybe id rethrowWithPosition pos $ literalToValueJS l + rethrowWithPosition pos $ literalToValueJS l valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) = return $ accessorString "value" $ qualifiedToJS id name valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) = @@ -222,9 +221,9 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = valueToJs' (Var (_, _, _, Just IsForeign) ident) = internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident) valueToJs' (Var _ ident) = return $ varToJs ident - valueToJs' (Case (maybeSpan, _, _, _) values binders) = do + valueToJs' (Case (ss, _, _, _) values binders) = do vals <- mapM valueToJs values - bindersToJs maybeSpan binders vals + bindersToJs ss binders vals valueToJs' (Let _ ds val) = do ds' <- concat <$> mapM bindToJs ds ret <- valueToJs val @@ -299,8 +298,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = -- | Generate code in the simplified JavaScript intermediate representation for pattern match binders -- and guards. - bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST - bindersToJs maybeSpan binders vals = do + bindersToJs :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST + bindersToJs ss binders vals = do valNames <- replicateM (length vals) freshName let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals) jss <- forM binders $ \(CaseAlternative bs result) -> do @@ -320,7 +319,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = failedPatternError names = AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing "Error") [AST.Binary Nothing AST.Add (AST.StringLiteral Nothing $ mkString failedPatternMessage) (AST.ArrayLiteral Nothing $ zipWith valueError names vals)] failedPatternMessage :: Text - failedPatternMessage = "Failed pattern match" <> maybe "" (((" at " <> runModuleName mn <> " ") <>) . displayStartEndPos) maybeSpan <> ": " + failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss <> ": " valueError :: Text -> AST -> AST valueError _ l@(AST.NumericLiteral _ _) = l diff --git a/src/Language/PureScript/CoreFn/Ann.hs b/src/Language/PureScript/CoreFn/Ann.hs index 823a7558ff..5d5b96fdff 100644 --- a/src/Language/PureScript/CoreFn/Ann.hs +++ b/src/Language/PureScript/CoreFn/Ann.hs @@ -10,13 +10,13 @@ import Language.PureScript.Types -- | -- Type alias for basic annotations -- -type Ann = (Maybe SourceSpan, [Comment], Maybe Type, Maybe Meta) +type Ann = (SourceSpan, [Comment], Maybe Type, Maybe Meta) -- | --- Initial annotation with no metadata +-- An annotation empty of metadata aside from a source span. -- -nullAnn :: Ann -nullAnn = (Nothing, [], Nothing, Nothing) +ssAnn :: SourceSpan -> Ann +ssAnn ss = (ss, [], Nothing, Nothing) -- | -- Remove the comments from an annotation diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index e3e6ca9c88..f0a681eb91 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -9,6 +9,7 @@ import Data.Function (on) import Data.List (sort, sortBy) import Data.Maybe (mapMaybe) import Data.Tuple (swap) +import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M import Language.PureScript.AST.Literals @@ -32,63 +33,52 @@ import qualified Language.PureScript.AST as A moduleToCoreFn :: Environment -> A.Module -> Module Ann moduleToCoreFn _ (A.Module _ _ _ _ Nothing) = internalError "Module exports were not elaborated before moduleToCoreFn" -moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = - let imports = mapMaybe importToCoreFn decls ++ findQualModules decls - imports' = keepPositionedImports imports +moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = + let imports = mapMaybe importToCoreFn decls ++ fmap (ssAnn modSS,) (findQualModules decls) + imports' = dedupeImports imports exps' = ordNub $ concatMap exportToCoreFn exps externs = ordNub $ mapMaybe externToCoreFn decls - decls' = concatMap (declToCoreFn Nothing []) decls + decls' = concatMap declToCoreFn decls in Module coms mn imports' exps' externs decls' where - -- | Remove duplicate imports favoring the ones containing source span - -- information - keepPositionedImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)] - keepPositionedImports = - map swap . M.toList . M.fromListWith preferSSpan . map swap - where - preferSSpan x y - | hasSS x = x - | otherwise = y - - hasSS :: Ann -> Bool - hasSS (Just _, _, _, _) = True - hasSS _ = False + -- | Remove duplicate imports + dedupeImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)] + dedupeImports = fmap swap . M.toList . M.fromListWith const . fmap swap - ssA :: Maybe SourceSpan -> Ann + ssA :: SourceSpan -> Ann ssA ss = (ss, [], Nothing, Nothing) -- | Desugars member declarations from AST to CoreFn representation. - declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann] - declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) = + declToCoreFn :: A.Declaration -> [Bind Ann] + declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [(ctor, _)]) = [NonRec (ssA ss) (properToIdent ctor) $ - Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))] - declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) = + Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ Qualified Nothing (Ident "x"))] + declToCoreFn d@(A.DataDeclaration _ Newtype _ _ _) = error $ "Found newtype with multiple constructors: " ++ show d - declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) = - flip map ctors $ \(ctor, _) -> + declToCoreFn (A.DataDeclaration (ss, com) Data tyName _ ctors) = + flip fmap ctors $ \(ctor, _) -> let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor) in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields - declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds - declToCoreFn ss com (A.ValueDeclaration name _ _ [A.MkUnguarded e]) = + declToCoreFn (A.DataBindingGroupDeclaration ds) = + concatMap declToCoreFn ds + declToCoreFn (A.ValueDeclaration (ss, com) name _ _ [A.MkUnguarded e]) = [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] - declToCoreFn ss _ (A.BindingGroupDeclaration ds) = - [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds] - declToCoreFn ss com (A.TypeClassDeclaration name _ supers _ members) = - [NonRec (ssA ss) (properToIdent name) $ mkTypeClassConstructor ss com supers members] - declToCoreFn _ com (A.PositionedDeclaration ss com1 d) = - declToCoreFn (Just ss) (com ++ com1) d - declToCoreFn _ _ _ = [] + declToCoreFn (A.BindingGroupDeclaration ds) = + [Rec . NEL.toList $ fmap (\(((ss, com), name), _, e) -> ((ssA ss, name), exprToCoreFn ss com Nothing e)) ds] + declToCoreFn (A.TypeClassDeclaration sa@(ss, _) name _ supers _ members) = + [NonRec (ssA ss) (properToIdent name) $ mkTypeClassConstructor sa supers members] + declToCoreFn _ = [] -- | Desugars expressions from AST to CoreFn representation. - exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann + exprToCoreFn :: SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann exprToCoreFn ss com ty (A.Literal lit) = Literal (ss, com, ty, Nothing) (fmap (exprToCoreFn ss com Nothing) lit) exprToCoreFn ss com ty (A.Accessor name v) = Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) exprToCoreFn ss com ty (A.ObjectUpdate obj vs) = - ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ map (second (exprToCoreFn ss [] Nothing)) vs + ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ fmap (second (exprToCoreFn ss [] Nothing)) vs exprToCoreFn ss com ty (A.Abs (A.VarBinder name) v) = Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) exprToCoreFn _ _ _ (A.Abs _ _) = @@ -99,34 +89,34 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = Var (ss, com, ty, getValueMeta ident) ident exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) = Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1] - [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True] - (Right $ exprToCoreFn Nothing [] Nothing v2) - , CaseAlternative [NullBinder nullAnn] - (Right $ exprToCoreFn Nothing [] Nothing v3) ] + [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True] + (Right $ exprToCoreFn ss [] Nothing v2) + , CaseAlternative [NullBinder (ssAnn ss)] + (Right $ exprToCoreFn ss [] Nothing v3) ] exprToCoreFn ss com ty (A.Constructor name) = Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name exprToCoreFn ss com ty (A.Case vs alts) = - Case (ss, com, ty, Nothing) (map (exprToCoreFn ss [] Nothing) vs) (map (altToCoreFn ss) alts) + Case (ss, com, ty, Nothing) (fmap (exprToCoreFn ss [] Nothing) vs) (fmap (altToCoreFn ss) alts) exprToCoreFn ss com _ (A.TypedValue _ v ty) = exprToCoreFn ss com (Just ty) v exprToCoreFn ss com ty (A.Let ds v) = - Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v) + Let (ss, com, ty, Nothing) (concatMap declToCoreFn ds) (exprToCoreFn ss [] Nothing v) exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal (A.ObjectLiteral _)) _)) = exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name lit) exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal (A.ObjectLiteral vs))) = - let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs + let args = fmap (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name) in foldl (App (ss, com, Nothing, Nothing)) ctor args exprToCoreFn ss com ty (A.TypeClassDictionaryAccessor _ ident) = Abs (ss, com, ty, Nothing) (Ident "dict") - (Accessor nullAnn (mkString $ runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict"))) + (Accessor (ssAnn ss) (mkString $ runIdent ident) (Var (ssAnn ss) $ Qualified Nothing (Ident "dict"))) exprToCoreFn _ com ty (A.PositionedValue ss com1 v) = - exprToCoreFn (Just ss) (com ++ com1) ty v + exprToCoreFn ss (com ++ com1) ty v exprToCoreFn _ _ _ e = error $ "Unexpected value in exprToCoreFn mn: " ++ show e -- | Desugars case alternatives from AST to CoreFn representation. - altToCoreFn :: Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann + altToCoreFn :: SourceSpan -> A.CaseAlternative -> CaseAlternative Ann altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs) where go :: [A.GuardedExpr] -> Either [(Guard Ann, Expr Ann)] (Expr Ann) @@ -142,7 +132,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = guardToExpr _ = internalError "Guard not correctly desugared" -- | Desugars case binders from AST to CoreFn representation. - binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann + binderToCoreFn :: SourceSpan -> [Comment] -> A.Binder -> Binder Ann binderToCoreFn ss com (A.LiteralBinder lit) = LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit) binderToCoreFn ss com A.NullBinder = @@ -151,11 +141,11 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = VarBinder (ss, com, Nothing, Nothing) name binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) = let (_, tctor, _, _) = lookupConstructor env dctor - in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs) + in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (fmap (binderToCoreFn ss []) bs) binderToCoreFn ss com (A.NamedBinder name b) = NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b) binderToCoreFn _ com (A.PositionedBinder ss com1 b) = - binderToCoreFn (Just ss) (com ++ com1) b + binderToCoreFn ss (com ++ com1) b binderToCoreFn ss com (A.TypedBinder _ b) = binderToCoreFn ss com b binderToCoreFn _ _ A.OpBinder{} = @@ -196,15 +186,15 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = -- | Find module names from qualified references to values. This is used to -- ensure instances are imported from any module that is referenced by the -- current module, not just from those that are imported explicitly (#667). -findQualModules :: [A.Declaration] -> [(Ann, ModuleName)] +findQualModules :: [A.Declaration] -> [ModuleName] findQualModules decls = let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const []) - in map (nullAnn,) $ f `concatMap` decls + in f `concatMap` decls where fqDecls :: A.Declaration -> [ModuleName] - fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual' q - fqDecls (A.ValueFixityDeclaration _ q _) = getQual' q - fqDecls (A.TypeFixityDeclaration _ q _) = getQual' q + fqDecls (A.TypeInstanceDeclaration _ _ _ q _ _) = getQual' q + fqDecls (A.ValueFixityDeclaration _ _ q _) = getQual' q + fqDecls (A.TypeFixityDeclaration _ _ q _) = getQual' q fqDecls _ = [] fqValues :: A.Expr -> [ModuleName] @@ -225,22 +215,19 @@ findQualModules decls = -- | Desugars import declarations from AST to CoreFn representation. importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName) -importToCoreFn (A.ImportDeclaration _ name _ _) = Just (nullAnn, name) -importToCoreFn (A.PositionedDeclaration ss _ d) = - ((,) (Just ss, [], Nothing, Nothing) . snd) <$> importToCoreFn d +importToCoreFn (A.ImportDeclaration (ss, com) name _ _) = Just ((ss, com, Nothing, Nothing), name) importToCoreFn _ = Nothing -- | Desugars foreign declarations from AST to CoreFn representation. externToCoreFn :: A.Declaration -> Maybe ForeignDecl -externToCoreFn (A.ExternDeclaration name ty) = Just (name, ty) -externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d +externToCoreFn (A.ExternDeclaration _ name ty) = Just (name, ty) externToCoreFn _ = Nothing -- | Desugars export declarations references from AST to CoreFn representation. -- CoreFn modules only export values, so all data constructors, class -- constructor, instances and values are flattened into one list. exportToCoreFn :: A.DeclarationRef -> [Ident] -exportToCoreFn (A.TypeRef _ _ (Just dctors)) = map properToIdent dctors +exportToCoreFn (A.TypeRef _ _ (Just dctors)) = fmap properToIdent dctors exportToCoreFn (A.ValueRef _ name) = [name] exportToCoreFn (A.TypeClassRef _ name) = [properToIdent name] exportToCoreFn (A.TypeInstanceRef _ name) = [name] @@ -249,15 +236,15 @@ exportToCoreFn _ = [] -- | Makes a typeclass dictionary constructor function. The returned expression -- is a function that accepts the superclass instances and member -- implementations and returns a record for the instance dictionary. -mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.Declaration] -> Expr Ann -mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral []) -mkTypeClassConstructor ss com supers members = - let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers - props = [ (mkString arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ] - dict = Literal nullAnn (ObjectLiteral props) +mkTypeClassConstructor :: SourceAnn -> [Constraint] -> [A.Declaration] -> Expr Ann +mkTypeClassConstructor (ss, com) [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral []) +mkTypeClassConstructor (ss, com) supers members = + let args@(a:as) = sort $ fmap typeClassMemberName members ++ superClassDictionaryNames supers + props = [ (mkString arg, Var (ssAnn ss) $ Qualified Nothing (Ident arg)) | arg <- args ] + dict = Literal (ssAnn ss) (ObjectLiteral props) in Abs (ss, com, Nothing, Just IsTypeClassConstructor) (Ident a) - (foldr (Abs nullAnn . Ident) dict as) + (foldr (Abs (ssAnn ss) . Ident) dict as) -- | Converts a ProperName to an Ident. properToIdent :: ProperName a -> Ident diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 0c4ce0918b..5c1e6eff8a 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -82,66 +82,63 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) = d { declChildren = declChildren d ++ [child] } getDeclarationTitle :: P.Declaration -> Maybe Text -getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name) -getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name) -getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name) -getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name) -getDeclarationTitle (P.ExternKindDeclaration name) = Just (P.runProperName name) -getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) -getDeclarationTitle (P.TypeClassDeclaration name _ _ _ _) = Just (P.runProperName name) -getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name) -getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " <> P.showOp op) -getDeclarationTitle (P.ValueFixityDeclaration _ _ op) = Just (P.showOp op) -getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d +getDeclarationTitle (P.ValueDeclaration _ name _ _ _) = Just (P.showIdent name) +getDeclarationTitle (P.ExternDeclaration _ name _) = Just (P.showIdent name) +getDeclarationTitle (P.DataDeclaration _ _ name _ _) = Just (P.runProperName name) +getDeclarationTitle (P.ExternDataDeclaration _ name _) = Just (P.runProperName name) +getDeclarationTitle (P.ExternKindDeclaration _ name) = Just (P.runProperName name) +getDeclarationTitle (P.TypeSynonymDeclaration _ name _ _) = Just (P.runProperName name) +getDeclarationTitle (P.TypeClassDeclaration _ name _ _ _ _) = Just (P.runProperName name) +getDeclarationTitle (P.TypeInstanceDeclaration _ name _ _ _ _) = Just (P.showIdent name) +getDeclarationTitle (P.TypeFixityDeclaration _ _ _ op) = Just ("type " <> P.showOp op) +getDeclarationTitle (P.ValueFixityDeclaration _ _ _ op) = Just (P.showOp op) getDeclarationTitle _ = Nothing -- | Create a basic Declaration value. -mkDeclaration :: Text -> DeclarationInfo -> Declaration -mkDeclaration title info = +mkDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Declaration +mkDeclaration (ss, com) title info = Declaration { declTitle = title - , declComments = Nothing - , declSourceSpan = Nothing + , declComments = convertComments com + , declSourceSpan = Just ss -- TODO: make this non-optional when we next break the format , declChildren = [] , declInfo = info } -basicDeclaration :: Text -> DeclarationInfo -> Maybe IntermediateDeclaration -basicDeclaration title info = Just $ Right $ mkDeclaration title info +basicDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Maybe IntermediateDeclaration +basicDeclaration sa title = Just . Right . mkDeclaration sa title convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration -convertDeclaration (P.ValueDeclaration _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title = - basicDeclaration title (ValueDeclaration ty) -convertDeclaration P.ValueDeclaration{} title = +convertDeclaration (P.ValueDeclaration sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title = + basicDeclaration sa title (ValueDeclaration ty) +convertDeclaration (P.ValueDeclaration sa _ _ _ _) title = -- If no explicit type declaration was provided, insert a wildcard, so that -- the actual type will be added during type checking. - basicDeclaration title (ValueDeclaration P.TypeWildcard{}) -convertDeclaration (P.ExternDeclaration _ ty) title = - basicDeclaration title (ValueDeclaration ty) -convertDeclaration (P.DataDeclaration dtype _ args ctors) title = - Just (Right (mkDeclaration title info) { declChildren = children }) + basicDeclaration sa title (ValueDeclaration P.TypeWildcard{}) +convertDeclaration (P.ExternDeclaration sa _ ty) title = + basicDeclaration sa title (ValueDeclaration ty) +convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title = + Just (Right (mkDeclaration sa title info) { declChildren = children }) where info = DataDeclaration dtype args children = map convertCtor ctors convertCtor (ctor', tys) = ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys) -convertDeclaration (P.ExternDataDeclaration _ kind') title = - basicDeclaration title (ExternDataDeclaration kind') -convertDeclaration (P.ExternKindDeclaration _) title = - basicDeclaration title ExternKindDeclaration -convertDeclaration (P.TypeSynonymDeclaration _ args ty) title = - basicDeclaration title (TypeSynonymDeclaration args ty) -convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title = - Just (Right (mkDeclaration title info) { declChildren = children }) +convertDeclaration (P.ExternDataDeclaration sa _ kind') title = + basicDeclaration sa title (ExternDataDeclaration kind') +convertDeclaration (P.ExternKindDeclaration sa _) title = + basicDeclaration sa title ExternKindDeclaration +convertDeclaration (P.TypeSynonymDeclaration sa _ args ty) title = + basicDeclaration sa title (TypeSynonymDeclaration args ty) +convertDeclaration (P.TypeClassDeclaration sa _ args implies fundeps ds) title = + Just (Right (mkDeclaration sa title info) { declChildren = children }) where info = TypeClassDeclaration args implies (convertFundepsToStrings args fundeps) children = map convertClassMember ds - convertClassMember (P.PositionedDeclaration _ _ d) = - convertClassMember d - convertClassMember (P.TypeDeclaration ident' ty) = - ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty) + convertClassMember (P.TypeDeclaration (ss, com) ident' ty) = + ChildDeclaration (P.showIdent ident') (convertComments com) (Just ss) (ChildTypeClassMember ty) convertClassMember _ = P.internalError "convertDeclaration: Invalid argument to convertClassMember." -convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = +convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ constraints className tys _) title = Just (Left ((classNameString, AugmentClass) : map (, AugmentType) typeNameStrings, AugmentChild childDecl)) where classNameString = unQual className @@ -151,28 +148,12 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit extractProperNames (P.TypeConstructor n) = [unQual n] extractProperNames _ = [] - childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) + childDecl = ChildDeclaration title (convertComments com) (Just ss) (ChildInstance constraints classApp) classApp = foldl' P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys -convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title = - Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias))) -convertDeclaration (P.TypeFixityDeclaration fixity (P.Qualified mn alias) _) title = - Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Left alias))) -convertDeclaration (P.PositionedDeclaration srcSpan com d') title = - fmap (addComments . addSourceSpan) (convertDeclaration d' title) - where - addComments (Right d) = - Right (d { declComments = convertComments com }) - addComments (Left augment) = - Left (withAugmentChild (\d -> d { cdeclComments = convertComments com }) - augment) - - addSourceSpan (Right d) = - Right (d { declSourceSpan = Just srcSpan }) - addSourceSpan (Left augment) = - Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan }) - augment) - - withAugmentChild f (t, AugmentChild d) = (t, AugmentChild (f d)) +convertDeclaration (P.ValueFixityDeclaration sa fixity (P.Qualified mn alias) _) title = + Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Right alias))) +convertDeclaration (P.TypeFixityDeclaration sa fixity (P.Qualified mn alias) _) title = + Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Left alias))) convertDeclaration _ _ = Nothing convertComments :: [P.Comment] -> Maybe Text diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 2796925fb1..474dc373d8 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -19,6 +19,7 @@ import Data.Either (partitionEithers) import Data.Foldable (fold) import Data.Functor.Identity (Identity(..)) import Data.List (transpose, nubBy, sort, partition, dropWhileEnd) +import qualified Data.List.NonEmpty as NEL import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Text as T @@ -1044,7 +1045,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderHint (ErrorInBindingGroup nms) detail = paras [ detail - , line $ "in binding group " <> T.intercalate ", " (map showIdent nms) + , line $ "in binding group " <> T.intercalate ", " (NEL.toList (fmap showIdent nms)) ] renderHint (ErrorInDataBindingGroup nms) detail = paras [ detail diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 555eae97d2..4b64631413 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -178,15 +178,13 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} efSourceSpan = ss fixityDecl :: Declaration -> Maybe ExternsFixity - fixityDecl (ValueFixityDeclaration (Fixity assoc prec) name op) = - fmap (const (ExternsFixity assoc prec op name)) (find (findOp getValueOpRef op) exps) - fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d + fixityDecl (ValueFixityDeclaration _ (Fixity assoc prec) name op) = + fmap (const (ExternsFixity assoc prec op name)) (find (findOp getValueOpRef op) exps) fixityDecl _ = Nothing typeFixityDecl :: Declaration -> Maybe ExternsTypeFixity - typeFixityDecl (TypeFixityDeclaration (Fixity assoc prec) name op) = - fmap (const (ExternsTypeFixity assoc prec op name)) (find (findOp getTypeOpRef op) exps) - typeFixityDecl (PositionedDeclaration _ _ d) = typeFixityDecl d + typeFixityDecl (TypeFixityDeclaration _ (Fixity assoc prec) name op) = + fmap (const (ExternsTypeFixity assoc prec op name)) (find (findOp getTypeOpRef op) exps) typeFixityDecl _ = Nothing findOp :: (DeclarationRef -> Maybe (OpName a)) -> OpName a -> DeclarationRef -> Bool @@ -194,7 +192,6 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} importDecl :: Declaration -> Maybe ExternsImport importDecl (ImportDeclaration _ m mt qmn) = Just (ExternsImport m mt qmn) - importDecl (PositionedDeclaration _ _ d) = importDecl d importDecl _ = Nothing toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration] diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 460ea91c0a..033120ba26 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -30,7 +30,6 @@ import Language.PureScript.Externs import Language.PureScript.Ide.Error import Language.PureScript.Ide.State import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util import Text.Parsec as Parsec import qualified Text.PrettyPrint.Boxes as Box @@ -129,8 +128,8 @@ parseTypeDeclaration' s = ts <- P.lex "" (toS s) P.runTokenParser "" (P.parseDeclaration <* Parsec.eof) ts in - case unwrapPositioned <$> x of - Right (P.TypeDeclaration i t) -> pure (i, t) + case x of + Right (P.TypeDeclaration _ i t) -> pure (i, t) Right _ -> throwError (GeneralError "Found a non-type-declaration") Left err -> throwError (GeneralError ("Parsing the type signature failed with: " diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 23ec01436f..8a03a5a8f9 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -59,8 +59,8 @@ parseModulesFromFiles paths = do extractAstInformation :: P.Module -> (DefinitionSites P.SourceSpan, TypeAnnotations) -extractAstInformation (P.Module ss _ _ decls _) = - let definitions = Map.fromList (concatMap (extractSpans ss) decls) +extractAstInformation (P.Module _ _ _ decls _) = + let definitions = Map.fromList (concatMap extractSpans decls) typeAnnotations = Map.fromList (extractTypeAnnotations decls) in (definitions, typeAnnotations) @@ -70,40 +70,35 @@ extractTypeAnnotations -> [(P.Ident, P.Type)] extractTypeAnnotations = mapMaybe extract where - extract d = case unwrapPositioned d of - P.TypeDeclaration ident ty -> Just (ident, ty) - _ -> Nothing + extract (P.TypeDeclaration _ ident ty) = Just (ident, ty) + extract _ = Nothing -- | Given a surrounding Sourcespan and a Declaration from the PS AST, extracts -- definition sites inside that Declaration. extractSpans - :: P.SourceSpan - -- ^ The surrounding span - -> P.Declaration + :: P.Declaration -- ^ The declaration to extract spans from -> [(IdeNamespaced, P.SourceSpan)] -- ^ Declarations and their source locations -extractSpans ss d = case d of - P.PositionedDeclaration ss' _ d' -> - extractSpans ss' d' - P.ValueDeclaration i _ _ _ -> +extractSpans d = case d of + P.ValueDeclaration (ss, _) i _ _ _ -> [(IdeNamespaced IdeNSValue (P.runIdent i), ss)] - P.TypeSynonymDeclaration name _ _ -> + P.TypeSynonymDeclaration (ss, _) name _ _ -> [(IdeNamespaced IdeNSType (P.runProperName name), ss)] - P.TypeClassDeclaration name _ _ _ members -> - (IdeNamespaced IdeNSType (P.runProperName name), ss) : concatMap (extractSpans' ss) members - P.DataDeclaration _ name _ ctors -> + P.TypeClassDeclaration (ss, _) name _ _ _ members -> + (IdeNamespaced IdeNSType (P.runProperName name), ss) : concatMap extractSpans' members + P.DataDeclaration (ss, _) _ name _ ctors -> (IdeNamespaced IdeNSType (P.runProperName name), ss) : map (\(cname, _) -> (IdeNamespaced IdeNSValue (P.runProperName cname), ss)) ctors - P.FixityDeclaration (Left (P.ValueFixity _ _ opName)) -> + P.FixityDeclaration (ss, _) (Left (P.ValueFixity _ _ opName)) -> [(IdeNamespaced IdeNSValue (P.runOpName opName), ss)] - P.FixityDeclaration (Right (P.TypeFixity _ _ opName)) -> + P.FixityDeclaration (ss, _) (Right (P.TypeFixity _ _ opName)) -> [(IdeNamespaced IdeNSType (P.runOpName opName), ss)] - P.ExternDeclaration ident _ -> + P.ExternDeclaration (ss, _) ident _ -> [(IdeNamespaced IdeNSValue (P.runIdent ident), ss)] - P.ExternDataDeclaration name _ -> + P.ExternDataDeclaration (ss, _) name _ -> [(IdeNamespaced IdeNSType (P.runProperName name), ss)] - P.ExternKindDeclaration name -> + P.ExternKindDeclaration (ss, _) name -> [(IdeNamespaced IdeNSKind (P.runProperName name), ss)] _ -> [] where @@ -111,9 +106,7 @@ extractSpans ss d = case d of -- typeclass member functions. Typedeclarations would clash with value -- declarations for non-typeclass members, which is why we can't handle them -- in extractSpans. - extractSpans' ssP dP = case dP of - P.PositionedDeclaration ssP' _ dP' -> - extractSpans' ssP' dP' - P.TypeDeclaration ident _ -> - [(IdeNamespaced IdeNSValue (P.runIdent ident), ssP)] + extractSpans' dP = case dP of + P.TypeDeclaration (ss', _) ident _ -> + [(IdeNamespaced IdeNSValue (P.runIdent ident), ss')] _ -> [] diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 9ecb206a83..5e84626b70 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -15,7 +15,6 @@ module Language.PureScript.Ide.Util ( identifierFromIdeDeclaration , unwrapMatch - , unwrapPositioned , namespaceForDeclaration , encodeT , decodeT @@ -91,10 +90,6 @@ encodeT = TL.toStrict . TLE.decodeUtf8 . encode decodeT :: (FromJSON a) => Text -> Maybe a decodeT = decode . TLE.encodeUtf8 . TL.fromStrict -unwrapPositioned :: P.Declaration -> P.Declaration -unwrapPositioned (P.PositionedDeclaration _ _ x) = unwrapPositioned x -unwrapPositioned x = x - properNameT :: Iso' (P.ProperName a) Text properNameT = iso P.runProperName P.ProperName diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index 5f891aee0c..dd94c74768 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -197,28 +197,25 @@ typeDecls :: P.Module -> [(N.ProperName 'N.TypeName, P.Declaration)] typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations where getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, P.Declaration) - getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d) - getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d) - getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d + getTypeName d@(P.TypeSynonymDeclaration _ name _ _) = Just (name, d) + getTypeName d@(P.DataDeclaration _ _ name _ _) = Just (name, d) getTypeName _ = Nothing identNames :: P.Module -> [(N.Ident, P.Declaration)] identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations where getDeclNames :: P.Declaration -> [(P.Ident, P.Declaration)] - getDeclNames d@(P.ValueDeclaration ident _ _ _) = [(ident, d)] - getDeclNames d@(P.TypeDeclaration ident _ ) = [(ident, d)] - getDeclNames d@(P.ExternDeclaration ident _) = [(ident, d)] - getDeclNames d@(P.TypeClassDeclaration _ _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds - getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d + getDeclNames d@(P.ValueDeclaration _ ident _ _ _) = [(ident, d)] + getDeclNames d@(P.TypeDeclaration _ ident _ ) = [(ident, d)] + getDeclNames d@(P.ExternDeclaration _ ident _) = [(ident, d)] + getDeclNames d@(P.TypeClassDeclaration _ _ _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds getDeclNames _ = [] dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)] dctorNames = nubOnFst . concatMap go . P.exportedDeclarations where go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)] - go decl@(P.DataDeclaration _ _ _ ctors) = map ((\n -> (n, decl)) . fst) ctors - go (P.PositionedDeclaration _ _ d) = go d + go decl@(P.DataDeclaration _ _ _ _ ctors) = map ((\n -> (n, decl)) . fst) ctors go _ = [] moduleNames :: [P.Module] -> [String] diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 9db3cc8c7d..18377982cd 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -51,15 +51,15 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"])) eval = P.Var (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval")) mainValue = P.App eval (P.Var (P.Qualified Nothing (P.Ident "it"))) - itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] [P.MkUnguarded val] - typeDecl = P.TypeDeclaration (P.Ident "$main") + itDecl = P.ValueDeclaration (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val] + typeDecl = P.TypeDeclaration (internalSpan, []) (P.Ident "$main") (P.TypeApp (P.TypeApp (P.TypeConstructor (P.Qualified (Just (P.ModuleName [P.ProperName "$Eff"])) (P.ProperName "Eff"))) (P.TypeWildcard internalSpan)) (P.TypeWildcard internalSpan)) - mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] + mainDecl = P.ValueDeclaration (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] in P.Module internalSpan @@ -75,7 +75,7 @@ createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ = let moduleName = P.ModuleName [P.ProperName "$PSCI"] - itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ + itDecl = P.TypeSynonymDeclaration (internalSpan, []) (P.ProperName "IT") [] typ in P.Module internalSpan [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index a29c110575..6f0fc18b00 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -88,15 +88,11 @@ psciImport = do -- (like import declarations). psciDeclaration :: P.TokenParser Command psciDeclaration = fmap Decls $ mark $ many1 $ same *> do - decl <- discardPositionInfo <$> P.parseDeclaration + decl <- P.parseDeclaration if acceptable decl then return decl else fail "this kind of declaration is not supported in psci" -discardPositionInfo :: P.Declaration -> P.Declaration -discardPositionInfo (P.PositionedDeclaration _ _ d) = d -discardPositionInfo d = d - acceptable :: P.Declaration -> Bool acceptable P.DataDeclaration{} = True acceptable P.TypeSynonymDeclaration{} = True diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index d26f361141..a1f99a775c 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -32,11 +32,10 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl moduleNames = S.fromList (ordNub (mapMaybe getDeclIdent ds)) getDeclIdent :: Declaration -> Maybe Ident - getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d - getDeclIdent (ValueDeclaration ident _ _ _) = Just ident - getDeclIdent (ExternDeclaration ident _) = Just ident - getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident - getDeclIdent (BindingGroupDeclaration _) = internalError "lint: binding groups should not be desugared yet." + getDeclIdent (ValueDeclaration _ ident _ _ _) = Just ident + getDeclIdent (ExternDeclaration _ ident _) = Just ident + getDeclIdent (TypeInstanceDeclaration _ ident _ _ _ _) = Just ident + getDeclIdent BindingGroupDeclaration{} = internalError "lint: binding groups should not be desugared yet." getDeclIdent _ = Nothing lintDeclaration :: Declaration -> m () @@ -45,14 +44,12 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl (warningsInDecl, _, _, _, _) = everythingWithScope (\_ _ -> mempty) stepE stepB (\_ _ -> mempty) stepDo f :: Declaration -> MultipleErrors - f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec) - f (TypeClassDeclaration name args _ _ decs) = addHint (ErrorInTypeClassDeclaration name) (foldMap (f' (S.fromList $ fst <$> args)) decs) + f (TypeClassDeclaration _ name args _ _ decs) = addHint (ErrorInTypeClassDeclaration name) (foldMap (f' (S.fromList $ fst <$> args)) decs) f dec = f' S.empty dec f' :: S.Set Text -> Declaration -> MultipleErrors - f' s (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' s dec) - f' s dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec) - f' s (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars s ty) + f' s dec@(ValueDeclaration _ name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec) + f' s (TypeDeclaration _ name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars s ty) f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec stepE :: S.Set Ident -> Expr -> MultipleErrors diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index af9db13b1b..a8a21f8546 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -242,13 +242,14 @@ missingAlternative env mn ca uncovered checkExhaustive :: forall m . (MonadWriter MultipleErrors m, MonadSupply m) - => Environment + => SourceSpan + -> Environment -> ModuleName -> Int -> [CaseAlternative] -> Expr -> m Expr -checkExhaustive env mn numArgs cas expr = makeResult . first ordNub $ foldl' step ([initialize numArgs], (pure True, [])) cas +checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' step ([initialize numArgs], (pure True, [])) cas where step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]])) step (uncovered, (nec, redundant)) ca = @@ -274,8 +275,8 @@ checkExhaustive env mn numArgs cas expr = makeResult . first ordNub $ foldl' ste then return expr else addPartialConstraint (second null (splitAt 5 bss)) expr where - tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss' - tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck + tellRedundant = tell . errorMessage' ss . uncurry OverlappingPattern . second null . splitAt 5 $ bss' + tellIncomplete = tell . errorMessage' ss $ IncompleteExhaustivityCheck -- | We add a Partial constraint by adding a call to the following identity function: -- @@ -294,7 +295,7 @@ checkExhaustive env mn numArgs cas expr = makeResult . first ordNub $ foldl' ste where partial :: Text -> Text -> Declaration partial var tyVar = - ValueDeclaration (Ident C.__unused) Private [] $ + ValueDeclaration (ss, []) (Ident C.__unused) Private [] $ [MkUnguarded (TypedValue True @@ -321,41 +322,41 @@ checkExhaustive env mn numArgs cas expr = makeResult . first ordNub $ foldl' ste checkExhaustiveExpr :: forall m . (MonadWriter MultipleErrors m, MonadSupply m) - => Environment + => SourceSpan + -> Environment -> ModuleName -> Expr -> m Expr -checkExhaustiveExpr env mn = onExpr +checkExhaustiveExpr initSS env mn = onExpr initSS where onDecl :: Declaration -> m Declaration - onDecl (BindingGroupDeclaration bs) = BindingGroupDeclaration <$> mapM (thirdM onExpr) bs - onDecl (ValueDeclaration name x y [MkUnguarded e]) = ValueDeclaration name x y . mkUnguardedExpr <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr e) - onDecl (PositionedDeclaration pos x dec) = PositionedDeclaration pos x <$> censor (addHint (PositionedError pos)) (onDecl dec) + onDecl (BindingGroupDeclaration bs) = BindingGroupDeclaration <$> mapM (\(sai@((ss, _), _), nk, expr) -> (sai, nk,) <$> onExpr ss expr) bs + onDecl (ValueDeclaration sa@(ss, _) name x y [MkUnguarded e]) = ValueDeclaration sa name x y . mkUnguardedExpr <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr ss e) onDecl decl = return decl - onExpr :: Expr -> m Expr - onExpr (UnaryMinus e) = UnaryMinus <$> onExpr e - onExpr (Literal (ArrayLiteral es)) = Literal . ArrayLiteral <$> mapM onExpr es - onExpr (Literal (ObjectLiteral es)) = Literal . ObjectLiteral <$> mapM (sndM onExpr) es - onExpr (TypeClassDictionaryConstructorApp x e) = TypeClassDictionaryConstructorApp x <$> onExpr e - onExpr (Accessor x e) = Accessor x <$> onExpr e - onExpr (ObjectUpdate o es) = ObjectUpdate <$> onExpr o <*> mapM (sndM onExpr) es - onExpr (Abs x e) = Abs x <$> onExpr e - onExpr (App e1 e2) = App <$> onExpr e1 <*> onExpr e2 - onExpr (IfThenElse e1 e2 e3) = IfThenElse <$> onExpr e1 <*> onExpr e2 <*> onExpr e3 - onExpr (Case es cas) = do - case' <- Case <$> mapM onExpr es <*> mapM onCaseAlternative cas - checkExhaustive env mn (length es) cas case' - onExpr (TypedValue x e y) = TypedValue x <$> onExpr e <*> pure y - onExpr (Let ds e) = Let <$> mapM onDecl ds <*> onExpr e - onExpr (PositionedValue pos x e) = PositionedValue pos x <$> censor (addHint (PositionedError pos)) (onExpr e) - onExpr expr = return expr - - onCaseAlternative :: CaseAlternative -> m CaseAlternative - onCaseAlternative (CaseAlternative x [MkUnguarded e]) = CaseAlternative x . mkUnguardedExpr <$> onExpr e - onCaseAlternative (CaseAlternative x es) = CaseAlternative x <$> mapM onGuardedExpr es - - onGuardedExpr :: GuardedExpr -> m GuardedExpr - onGuardedExpr (GuardedExpr guard rhs) = GuardedExpr guard <$> onExpr rhs + onExpr :: SourceSpan -> Expr -> m Expr + onExpr ss (UnaryMinus e) = UnaryMinus <$> onExpr ss e + onExpr ss (Literal (ArrayLiteral es)) = Literal . ArrayLiteral <$> mapM (onExpr ss) es + onExpr ss (Literal (ObjectLiteral es)) = Literal . ObjectLiteral <$> mapM (sndM (onExpr ss)) es + onExpr ss (TypeClassDictionaryConstructorApp x e) = TypeClassDictionaryConstructorApp x <$> onExpr ss e + onExpr ss (Accessor x e) = Accessor x <$> onExpr ss e + onExpr ss (ObjectUpdate o es) = ObjectUpdate <$> onExpr ss o <*> mapM (sndM (onExpr ss)) es + onExpr ss (Abs x e) = Abs x <$> onExpr ss e + onExpr ss (App e1 e2) = App <$> onExpr ss e1 <*> onExpr ss e2 + onExpr ss (IfThenElse e1 e2 e3) = IfThenElse <$> onExpr ss e1 <*> onExpr ss e2 <*> onExpr ss e3 + onExpr ss (Case es cas) = do + case' <- Case <$> mapM (onExpr ss) es <*> mapM (onCaseAlternative ss) cas + checkExhaustive ss env mn (length es) cas case' + onExpr ss (TypedValue x e y) = TypedValue x <$> onExpr ss e <*> pure y + onExpr ss (Let ds e) = Let <$> mapM onDecl ds <*> onExpr ss e + onExpr _ (PositionedValue ss x e) = PositionedValue ss x <$> onExpr ss e + onExpr _ expr = return expr + + onCaseAlternative :: SourceSpan -> CaseAlternative -> m CaseAlternative + onCaseAlternative ss (CaseAlternative x [MkUnguarded e]) = CaseAlternative x . mkUnguardedExpr <$> onExpr ss e + onCaseAlternative ss (CaseAlternative x es) = CaseAlternative x <$> mapM (onGuardedExpr ss) es + + onGuardedExpr :: SourceSpan -> GuardedExpr -> m GuardedExpr + onGuardedExpr ss (GuardedExpr guard rhs) = GuardedExpr guard <$> onExpr ss rhs mkUnguardedExpr = pure . MkUnguarded diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 4be3126bae..a00a141f73 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -116,7 +116,6 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do selfCartesianSubset [] = [] countOpenImports :: Declaration -> Int - countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d countOpenImports (ImportDeclaration _ mn' Implicit Nothing) | not (isPrim mn' || mn == mn') = 1 countOpenImports (ImportDeclaration _ mn' (Hiding _) Nothing) diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 4ee9ed3b02..a270c3eba4 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -4,9 +4,10 @@ module Language.PureScript.ModuleDependencies , ModuleGraph ) where -import Protolude +import Protolude hiding (head) import Data.Graph +import Data.List (head) import qualified Data.Set as S import Language.PureScript.AST import qualified Language.PureScript.Constants as C @@ -41,24 +42,25 @@ sortModules ms = do toGraphNode mns m@(Module _ _ mn ds _) = do let deps = ordNub (mapMaybe usedModules ds) void . parU deps $ \(dep, pos) -> - when (dep /= C.Prim && S.notMember dep mns) $ + when (dep /= C.Prim && S.notMember dep mns) . throwError . addHint (ErrorInModule mn) - . maybe identity (addHint . PositionedError) pos - . errorMessage + . errorMessage' pos $ ModuleNotFound dep pure (m, getModuleName m, map fst deps) -- | Calculate a list of used modules based on explicit imports and qualified names. -usedModules :: Declaration -> Maybe (ModuleName, Maybe SourceSpan) +usedModules :: Declaration -> Maybe (ModuleName, SourceSpan) -- Regardless of whether an imported module is qualified we still need to -- take into account its import to build an accurate list of dependencies. -usedModules (ImportDeclaration _ mn _ _) = pure (mn, Nothing) -usedModules (PositionedDeclaration ss _ d) = fmap (second (const (Just ss))) (usedModules d) +usedModules (ImportDeclaration (ss, _) mn _ _) = pure (mn, ss) usedModules _ = Nothing -- | Convert a strongly connected component of the module graph to a module toModule :: MonadError MultipleErrors m => SCC Module -> m Module toModule (AcyclicSCC m) = return m toModule (CyclicSCC [m]) = return m -toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms) +toModule (CyclicSCC ms) = + throwError + . errorMessage' (getModuleSourceSpan (head ms)) + $ CycleInModules (map getModuleName ms) diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index 85c4b4cb00..4eb5bb69b7 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -133,8 +133,8 @@ withSourceSpan -> P.Parsec [PositionedToken] u a -> P.Parsec [PositionedToken] u b withSourceSpan f p = do - start <- P.getPosition comments <- readComments + start <- P.getPosition x <- p end <- P.getPosition input <- P.getInput @@ -144,11 +144,10 @@ withSourceSpan f p = do let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos $ fromMaybe end end') return $ f sp comments x -withSourceAnn - :: (SourceAnn -> a -> b) +withSourceAnnF + :: P.Parsec [PositionedToken] u (SourceAnn -> a) -> P.Parsec [PositionedToken] u a - -> P.Parsec [PositionedToken] u b -withSourceAnn = withSourceSpan . curry +withSourceAnnF = withSourceSpan (\ss com f -> f (ss, com)) withSourceSpan' :: (SourceSpan -> a -> b) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 855d555e24..1dbb9d5d4c 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -24,6 +24,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Parallel.Strategies (withStrategy, parList, rseq) import Data.Functor (($>)) import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) import qualified Data.Set as S import Data.Text (Text) import Language.PureScript.AST @@ -45,25 +46,27 @@ kindedIdent = (, Nothing) <$> identifier <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind))) parseDataDeclaration :: TokenParser Declaration -parseDataDeclaration = do +parseDataDeclaration = withSourceAnnF $ do dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype) name <- indented *> typeName tyArgs <- many (indented *> kindedIdent) ctors <- P.option [] $ do indented *> equals P.sepBy1 ((,) <$> dataConstructorName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe - return $ DataDeclaration dtype name tyArgs ctors + return $ \sa -> DataDeclaration sa dtype name tyArgs ctors parseTypeDeclaration :: TokenParser Declaration -parseTypeDeclaration = - TypeDeclaration <$> P.try (parseIdent <* indented <* doubleColon) - <*> parsePolyType +parseTypeDeclaration = withSourceAnnF $ do + name <- P.try (parseIdent <* indented <* doubleColon) + ty <- parsePolyType + return $ \sa -> TypeDeclaration sa name ty parseTypeSynonymDeclaration :: TokenParser Declaration -parseTypeSynonymDeclaration = - TypeSynonymDeclaration <$> (reserved "type" *> indented *> typeName) - <*> many (indented *> kindedIdent) - <*> (indented *> equals *> noWildcards parsePolyType) +parseTypeSynonymDeclaration = withSourceAnnF $ do + name <- reserved "type" *> indented *> typeName + vars <- many (indented *> kindedIdent) + ty <- indented *> equals *> noWildcards parsePolyType + return $ \sa -> TypeSynonymDeclaration sa name vars ty parseValueWithWhereClause :: TokenParser Expr parseValueWithWhereClause = do @@ -76,7 +79,7 @@ parseValueWithWhereClause = do mark $ P.many1 (same *> parseLocalDeclaration) return $ maybe value (`Let` value) whereClause -parseValueWithIdentAndBinders :: Ident -> [Binder] -> TokenParser Declaration +parseValueWithIdentAndBinders :: Ident -> [Binder] -> TokenParser (SourceAnn -> Declaration) parseValueWithIdentAndBinders ident bs = do value <- indented *> ( (\v -> [MkUnguarded v]) <$> (equals *> withSourceSpan PositionedValue parseValueWithWhereClause) <|> @@ -84,34 +87,43 @@ parseValueWithIdentAndBinders ident bs = do <*> (indented *> equals *> withSourceSpan PositionedValue parseValueWithWhereClause)) ) - return $ ValueDeclaration ident Public bs value + return $ \sa -> ValueDeclaration sa ident Public bs value parseValueDeclaration :: TokenParser Declaration -parseValueDeclaration = do +parseValueDeclaration = withSourceAnnF $ do ident <- parseIdent binders <- P.many parseBinderNoParens parseValueWithIdentAndBinders ident binders parseLocalValueDeclaration :: TokenParser Declaration -parseLocalValueDeclaration = join $ go <$> parseBinder <*> (P.many parseBinderNoParens) +parseLocalValueDeclaration = withSourceAnnF . + join $ go <$> parseBinder <*> P.many parseBinderNoParens where - go :: Binder -> [Binder] -> TokenParser Declaration + go :: Binder -> [Binder] -> TokenParser (SourceAnn -> Declaration) go (VarBinder ident) bs = parseValueWithIdentAndBinders ident bs go (PositionedBinder _ _ b) bs = go b bs - go binder [] = BoundValueDeclaration binder <$> (indented *> equals *> parseValueWithWhereClause) - go _ _ = P.unexpected $ "patterns in local value declaration" + go binder [] = do + boot <- indented *> equals *> parseValueWithWhereClause + return $ \sa -> BoundValueDeclaration sa binder boot + go _ _ = P.unexpected "patterns in local value declaration" parseExternDeclaration :: TokenParser Declaration -parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *> parseExternAlt where - parseExternAlt = parseExternData <|> P.try parseExternKind <|> parseExternTerm - - parseExternData = ExternDataDeclaration <$> (reserved "data" *> indented *> typeName) - <*> (indented *> doubleColon *> parseKind) - - parseExternKind = ExternKindDeclaration <$> (reserved "kind" *> indented *> kindName) - - parseExternTerm = ExternDeclaration <$> parseIdent - <*> (indented *> doubleColon *> noWildcards parsePolyType) +parseExternDeclaration = withSourceAnnF $ + reserved "foreign" *> + indented *> reserved "import" *> + indented *> (parseExternData <|> P.try parseExternKind <|> parseExternTerm) + where + parseExternData = + (\name kind sa -> ExternDataDeclaration sa name kind) + <$> (reserved "data" *> indented *> typeName) + <*> (indented *> doubleColon *> parseKind) + parseExternKind = + flip ExternKindDeclaration + <$> (reserved "kind" *> indented *> kindName) + parseExternTerm = + (\name ty sa -> ExternDeclaration sa name ty) + <$> parseIdent + <*> (indented *> doubleColon *> noWildcards parsePolyType) parseAssociativity :: TokenParser Associativity parseAssociativity = @@ -123,11 +135,11 @@ parseFixity :: TokenParser Fixity parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural) parseFixityDeclaration :: TokenParser Declaration -parseFixityDeclaration = do +parseFixityDeclaration = withSourceAnnF $ do fixity <- parseFixity indented - FixityDeclaration - <$> ((Right <$> typeFixity fixity) <|> (Left <$> valueFixity fixity)) + def <- (Right <$> typeFixity fixity) <|> (Left <$> valueFixity fixity) + return $ \sa -> FixityDeclaration sa def where typeFixity fixity = TypeFixity fixity @@ -139,9 +151,9 @@ parseFixityDeclaration = do <*> (reserved "as" *> parseOperator) parseImportDeclaration :: TokenParser Declaration -parseImportDeclaration = withSourceAnn (\sa -> ($ ImportDeclaration sa)) $ do +parseImportDeclaration = withSourceAnnF $ do (mn, declType, asQ) <- parseImportDeclaration' - return $ \f -> f mn declType asQ + return $ \sa -> ImportDeclaration sa mn declType asQ parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName) parseImportDeclaration' = do @@ -173,7 +185,7 @@ parseDeclarationRef = return $ \f -> f name (fromMaybe (Just []) dctors) parseTypeClassDeclaration :: TokenParser Declaration -parseTypeClassDeclaration = do +parseTypeClassDeclaration = withSourceAnnF $ do reserved "class" implies <- P.option [] . P.try $ do indented @@ -189,8 +201,8 @@ parseTypeClassDeclaration = do dependencies <- P.option [] (indented *> pipe *> commaSep1 parseFunctionalDependency) members <- P.option [] $ do indented *> reserved "where" - indented *> mark (P.many (same *> positioned parseTypeDeclaration)) - return $ TypeClassDeclaration className idents implies dependencies members + indented *> mark (P.many (same *> parseTypeDeclaration)) + return $ \sa -> TypeClassDeclaration sa className idents implies dependencies members parseConstraint :: TokenParser Constraint parseConstraint = Constraint <$> parseQualified properName @@ -198,24 +210,24 @@ parseConstraint = Constraint <$> parseQualified properName <*> pure Nothing parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) -parseInstanceDeclaration = do +parseInstanceDeclaration = withSourceAnnF $ do reserved "instance" name <- parseIdent <* indented <* doubleColon - deps <- P.optionMaybe $ P.try $ do + deps <- P.optionMaybe . P.try $ do deps <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint) indented rfatArrow return deps className <- indented *> parseQualified properName ty <- P.many (indented *> parseTypeAtom) - return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty + return $ \sa -> TypeInstanceDeclaration sa name (fromMaybe [] deps) className ty parseTypeInstanceDeclaration :: TokenParser Declaration parseTypeInstanceDeclaration = do instanceDecl <- parseInstanceDeclaration members <- P.option [] $ do indented *> reserved "where" - mark (P.many (same *> positioned declsInInstance)) + mark (P.many (same *> declsInInstance)) return $ instanceDecl (ExplicitInstance members) where declsInInstance :: TokenParser Declaration @@ -231,28 +243,27 @@ parseDerivingInstanceDeclaration = do instanceDecl <- parseInstanceDeclaration return $ instanceDecl ty -positioned :: TokenParser Declaration -> TokenParser Declaration -positioned = withSourceSpan PositionedDeclaration - -- | Parse a single declaration parseDeclaration :: TokenParser Declaration -parseDeclaration = positioned (P.choice - [ parseDataDeclaration - , parseTypeDeclaration - , parseTypeSynonymDeclaration - , parseValueDeclaration - , parseExternDeclaration - , parseFixityDeclaration - , parseTypeClassDeclaration - , parseTypeInstanceDeclaration - , parseDerivingInstanceDeclaration - ]) P. "declaration" +parseDeclaration = + P.choice + [ parseDataDeclaration + , parseTypeDeclaration + , parseTypeSynonymDeclaration + , parseValueDeclaration + , parseExternDeclaration + , parseFixityDeclaration + , parseTypeClassDeclaration + , parseTypeInstanceDeclaration + , parseDerivingInstanceDeclaration + ] P. "declaration" parseLocalDeclaration :: TokenParser Declaration -parseLocalDeclaration = positioned (P.choice - [ parseTypeDeclaration - , parseLocalValueDeclaration - ] P. "local declaration") +parseLocalDeclaration = + P.choice + [ parseTypeDeclaration + , parseLocalValueDeclaration + ] P. "local declaration" -- | Parse a module declaration and its export declarations parseModuleDeclaration :: TokenParser (ModuleName, Maybe [DeclarationRef]) @@ -260,7 +271,7 @@ parseModuleDeclaration = do reserved "module" indented name <- moduleName - exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef + exports <- P.optionMaybe . parens $ commaSep1 parseDeclarationRef reserved "where" pure (name, exports) @@ -276,7 +287,7 @@ parseModule = do -- by only parsing as far as the module header. See PR #2054. imports <- P.many (same *> parseImportDeclaration) decls <- P.many (same *> parseDeclaration) - return (imports ++ decls) + return (imports <> decls) _ <- P.eof end <- P.getPosition let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end) @@ -290,7 +301,7 @@ parseModulesFromFiles -> [(k, Text)] -> m [(k, Module)] parseModulesFromFiles toFilePath input = - flip parU wrapError . inParallel . flip map input $ parseModuleFromFile toFilePath + flip parU wrapError . inParallel . flip fmap input $ parseModuleFromFile toFilePath where wrapError :: Either P.ParseError a -> m a wrapError = either (throwError . MultipleErrors . pure . toPositionedError) return @@ -494,7 +505,7 @@ parseUpdaterBodyFields = do return (PathTree (AssocList (reverse tree))) where insertUpdate (seen, xs) (key, node) - | S.member key seen = P.unexpected ("Duplicate key in record update: " ++ show key) + | S.member key seen = P.unexpected ("Duplicate key in record update: " <> show key) | otherwise = return (S.insert key seen, (key, node) : xs) parseUpdaterBody :: Expr -> TokenParser Expr diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 4182f42606..2c28bccbba 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -11,10 +11,10 @@ import Prelude.Compat import Control.Arrow (second) +import Data.Text (Text) +import qualified Data.List.NonEmpty as NEL import qualified Data.Monoid as Monoid ((<>)) - import qualified Data.Text as T -import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Crash @@ -122,15 +122,14 @@ prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ secon prettyPrintDeclaration :: Int -> Declaration -> Box prettyPrintDeclaration d _ | d < 0 = ellipsis -prettyPrintDeclaration _ (TypeDeclaration ident ty) = +prettyPrintDeclaration _ (TypeDeclaration _ ident ty) = text (T.unpack (showIdent ident) ++ " :: ") <> typeAsBox ty -prettyPrintDeclaration d (ValueDeclaration ident _ [] [GuardedExpr [] val]) = +prettyPrintDeclaration d (ValueDeclaration _ ident _ [] [GuardedExpr [] val]) = text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val prettyPrintDeclaration d (BindingGroupDeclaration ds) = - vsep 1 left (map (prettyPrintDeclaration (d - 1) . toDecl) ds) + vsep 1 left (NEL.toList (fmap (prettyPrintDeclaration (d - 1) . toDecl) ds)) where - toDecl (nm, t, e) = ValueDeclaration nm t [] [GuardedExpr [] e] -prettyPrintDeclaration d (PositionedDeclaration _ _ decl) = prettyPrintDeclaration d decl + toDecl ((sa, nm), t, e) = ValueDeclaration sa nm t [] [GuardedExpr [] e] prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration" prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index df391fb2ff..0cb2a8b634 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -18,6 +18,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Data.Graph import Data.List (intersect) import Data.Maybe (isJust) +import qualified Data.List.NonEmpty as NEL import qualified Data.Set as S import Language.PureScript.AST @@ -42,7 +43,7 @@ createBindingGroupsModule (Module ss coms name ds exps) = -- collapseBindingGroupsModule :: [Module] -> [Module] collapseBindingGroupsModule = - map $ \(Module ss coms name ds exps) -> + fmap $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps createBindingGroups @@ -67,11 +68,11 @@ createBindingGroups moduleName = mapM f <=< handleDecls handleDecls ds = do let values = filter isValueDecl ds dataDecls = filter isDataDecl ds - allProperNames = map declTypeName dataDecls - dataVerts = map (\d -> (d, declTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls + allProperNames = fmap declTypeName dataDecls + dataVerts = fmap (\d -> (d, declTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup - let allIdents = map declIdent values - valueVerts = map (\d -> (d, declIdent d, usedIdents moduleName d `intersect` allIdents)) values + let allIdents = fmap declIdent values + valueVerts = fmap (\d -> (d, declIdent d, usedIdents moduleName d `intersect` allIdents)) values bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName) return $ filter isImportDecl ds ++ filter isExternKindDecl ds ++ @@ -89,14 +90,12 @@ createBindingGroups moduleName = mapM f <=< handleDecls collapseBindingGroups :: [Declaration] -> [Declaration] collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id - in map f . concatMap go + in fmap f . concatMap go where - go (DataBindingGroupDeclaration ds) = ds + go (DataBindingGroupDeclaration ds) = NEL.toList ds go (BindingGroupDeclaration ds) = - map (\(ident, nameKind, val) -> - ValueDeclaration ident nameKind [] [MkUnguarded val]) ds - go (PositionedDeclaration pos com d) = - map (PositionedDeclaration pos com) $ go d + NEL.toList $ fmap (\((sa, ident), nameKind, val) -> + ValueDeclaration sa ident nameKind [] [MkUnguarded val]) ds go other = [other] collapseBindingGroupsForValue :: Expr -> Expr @@ -108,9 +107,8 @@ usedIdents moduleName = ordNub . usedIdents' S.empty . getValue where def _ _ = [] - getValue (ValueDeclaration _ _ [] [MkUnguarded val]) = val + getValue (ValueDeclaration _ _ _ [] [MkUnguarded val]) = val getValue ValueDeclaration{} = internalError "Binders should have been desugared" - getValue (PositionedDeclaration _ _ d) = getValue d getValue _ = internalError "Expected ValueDeclaration" (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def @@ -152,14 +150,12 @@ usedTypeNames moduleName = usedNames _ = [] declIdent :: Declaration -> Ident -declIdent (ValueDeclaration ident _ _ _) = ident -declIdent (PositionedDeclaration _ _ d) = declIdent d +declIdent (ValueDeclaration _ ident _ _ _) = ident declIdent _ = internalError "Expected ValueDeclaration" declTypeName :: Declaration -> ProperName 'TypeName -declTypeName (DataDeclaration _ pn _ _) = pn -declTypeName (TypeSynonymDeclaration pn _ _) = pn -declTypeName (PositionedDeclaration _ _ d) = declTypeName d +declTypeName (DataDeclaration _ _ pn _ _) = pn +declTypeName (TypeSynonymDeclaration _ pn _ _) = pn declTypeName _ = internalError "Expected DataDeclaration" -- | @@ -173,7 +169,7 @@ toBindingGroup -> SCC Declaration -> m Declaration toBindingGroup _ (AcyclicSCC d) = return d -toBindingGroup moduleName (CyclicSCC ds') = +toBindingGroup moduleName (CyclicSCC ds') = do -- Once we have a mutually-recursive group of declarations, we need to sort -- them further by their immediate dependencies (those outside function -- bodies). In particular, this is relevant for type instance dictionaries @@ -183,21 +179,20 @@ toBindingGroup moduleName (CyclicSCC ds') = -- If we discover declarations that still contain mutually-recursive -- immediate references, we're guaranteed to get an undefined reference at -- runtime, so treat this as an error. See also github issue #365. - BindingGroupDeclaration <$> mapM toBinding (stronglyConnComp valueVerts) + BindingGroupDeclaration . NEL.fromList <$> mapM toBinding (stronglyConnComp valueVerts) where idents :: [Ident] - idents = map (\(_, i, _) -> i) valueVerts + idents = fmap (\(_, i, _) -> i) valueVerts valueVerts :: [(Declaration, Ident, [Ident])] - valueVerts = map (\d -> (d, declIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds' + valueVerts = fmap (\d -> (d, declIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds' - toBinding :: SCC Declaration -> m (Ident, NameKind, Expr) + toBinding :: SCC Declaration -> m ((SourceAnn, Ident), NameKind, Expr) toBinding (AcyclicSCC d) = return $ fromValueDecl d toBinding (CyclicSCC ds) = throwError $ foldMap cycleError ds cycleError :: Declaration -> MultipleErrors - cycleError (PositionedDeclaration p _ d) = onErrorMessages (withPosition p) $ cycleError d - cycleError (ValueDeclaration n _ _ [MkUnguarded _]) = errorMessage $ CycleInDeclaration n + cycleError (ValueDeclaration (ss, _) n _ _ [MkUnguarded _]) = errorMessage' ss $ CycleInDeclaration n cycleError _ = internalError "cycleError: Expected ValueDeclaration" toDataBindingGroup @@ -206,19 +201,17 @@ toDataBindingGroup -> m Declaration toDataBindingGroup (AcyclicSCC d) = return d toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of - Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn) + Just pn -> throwError . errorMessage' (declSourceSpan d) $ CycleInTypeSynonym (Just pn) _ -> return d toDataBindingGroup (CyclicSCC ds') - | all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing - | otherwise = return $ DataBindingGroupDeclaration ds' + | all (isJust . isTypeSynonym) ds' = throwError . errorMessage' (declSourceSpan (head ds')) $ CycleInTypeSynonym Nothing + | otherwise = return . DataBindingGroupDeclaration $ NEL.fromList ds' isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName) -isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn -isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d +isTypeSynonym (TypeSynonymDeclaration _ pn _ _) = Just pn isTypeSynonym _ = Nothing -fromValueDecl :: Declaration -> (Ident, NameKind, Expr) -fromValueDecl (ValueDeclaration ident nameKind [] [MkUnguarded val]) = (ident, nameKind, val) +fromValueDecl :: Declaration -> ((SourceAnn, Ident), NameKind, Expr) +fromValueDecl (ValueDeclaration sa ident nameKind [] [MkUnguarded val]) = ((sa, ident), nameKind, val) fromValueDecl ValueDeclaration{} = internalError "Binders should have been desugared" -fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d fromValueDecl _ = internalError "Expected ValueDeclaration" diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 3d630118f3..66cf9c953f 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -42,9 +42,11 @@ desugarCaseGuards :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] -desugarCaseGuards declarations = parU declarations f +desugarCaseGuards declarations = parU declarations go where - (f, _, _) = everywhereOnValuesM return desugarGuardedExprs return + go d = + let (f, _, _) = everywhereOnValuesM return (desugarGuardedExprs (declSourceSpan d)) return + in f d -- | -- Desugar case with pattern guards and pattern clauses to a @@ -52,9 +54,10 @@ desugarCaseGuards declarations = parU declarations f -- desugarGuardedExprs :: forall m. (MonadSupply m) - => Expr + => SourceSpan + -> Expr -> m Expr -desugarGuardedExprs (Case scrut alternatives) +desugarGuardedExprs ss (Case scrut alternatives) | any (not . isTrivialExpr) scrut = do -- in case the scrutinee is non trivial (e.g. not a Var or Literal) -- we may evaluate the scrutinee more than once when a guard occurrs. @@ -62,10 +65,10 @@ desugarGuardedExprs (Case scrut alternatives) (scrut', scrut_decls) <- unzip <$> forM scrut (\e -> do scrut_id <- freshIdent' pure ( Var (Qualified Nothing scrut_id) - , ValueDeclaration scrut_id Private [] [MkUnguarded e] + , ValueDeclaration (ss, []) scrut_id Private [] [MkUnguarded e] ) ) - Let scrut_decls <$> desugarGuardedExprs (Case scrut' alternatives) + Let scrut_decls <$> desugarGuardedExprs ss (Case scrut' alternatives) where isTrivialExpr (Var _) = True isTrivialExpr (Literal _) = True @@ -75,7 +78,7 @@ desugarGuardedExprs (Case scrut alternatives) isTrivialExpr (TypedValue _ e _) = isTrivialExpr e isTrivialExpr _ = False -desugarGuardedExprs (Case scrut alternatives) = +desugarGuardedExprs ss (Case scrut alternatives) = let -- Alternatives which do not have guards are -- left as-is. Alternatives which @@ -217,7 +220,7 @@ desugarGuardedExprs (Case scrut alternatives) = desugarAltOutOfLine alt_binder rem_guarded rem_alts mk_body | Just rem_case <- mkCaseOfRemainingGuardsAndAlts = do - desugared <- desugarGuardedExprs rem_case + desugared <- desugarGuardedExprs ss rem_case rem_case_id <- freshIdent' unused_binder <- freshIdent' @@ -228,7 +231,7 @@ desugarGuardedExprs (Case scrut alternatives) = alt_fail = [CaseAlternative [NullBinder] [MkUnguarded goto_rem_case]] pure $ Let [ - ValueDeclaration rem_case_id Private [] + ValueDeclaration (ss, []) rem_case_id Private [] [MkUnguarded (Abs (VarBinder unused_binder) desugared)] ] (mk_body alt_fail) @@ -263,13 +266,13 @@ desugarGuardedExprs (Case scrut alternatives) = alts' <- desugarAlternatives alternatives return $ optimize (Case scrut alts') -desugarGuardedExprs (TypedValue infered e ty) = - TypedValue infered <$> desugarGuardedExprs e <*> pure ty +desugarGuardedExprs ss (TypedValue infered e ty) = + TypedValue infered <$> desugarGuardedExprs ss e <*> pure ty -desugarGuardedExprs (PositionedValue ss comms e) = - PositionedValue ss comms <$> desugarGuardedExprs e +desugarGuardedExprs _ (PositionedValue ss comms e) = + PositionedValue ss comms <$> desugarGuardedExprs ss e -desugarGuardedExprs v = pure v +desugarGuardedExprs _ v = pure v -- | -- Validates that case head and binder lengths match. @@ -323,33 +326,28 @@ desugarCases :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Decla desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup where desugarRest :: [Declaration] -> m [Declaration] - desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) = - (:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest - desugarRest (ValueDeclaration name nameKind bs result : rest) = + desugarRest (TypeInstanceDeclaration sa name constraints className tys ds : rest) = + (:) <$> (TypeInstanceDeclaration sa name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest + desugarRest (ValueDeclaration sa name nameKind bs result : rest) = let (_, f, _) = everywhereOnValuesTopDownM return go return f' = mapM (\(GuardedExpr gs e) -> GuardedExpr gs <$> f e) - in (:) <$> (ValueDeclaration name nameKind bs <$> f' result) <*> desugarRest rest + in (:) <$> (ValueDeclaration sa name nameKind bs <$> f' result) <*> desugarRest rest where go (Let ds val') = Let <$> desugarCases ds <*> pure val' go other = return other - desugarRest (PositionedDeclaration pos com d : ds) = do - (d' : ds') <- desugarRest (d : ds) - return (PositionedDeclaration pos com d' : ds') desugarRest (d : ds) = (:) d <$> desugarRest ds desugarRest [] = pure [] inSameGroup :: Declaration -> Declaration -> Bool -inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2 -inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2 -inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2 +inSameGroup (ValueDeclaration _ ident1 _ _ _) (ValueDeclaration _ ident2 _ _ _) = ident1 == ident2 inSameGroup _ _ = False toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] -toDecls [ValueDeclaration ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do +toDecls [ValueDeclaration sa@(ss, _) ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do args <- mapM fromVarBinder bs let body = foldr (Abs . VarBinder) val args - guardWith (errorMessage (OverlappingArgNames (Just ident))) $ length (ordNub args) == length args - return [ValueDeclaration ident nameKind [] [MkUnguarded body]] + guardWith (errorMessage' ss (OverlappingArgNames (Just ident))) $ length (ordNub args) == length args + return [ValueDeclaration sa ident nameKind [] [MkUnguarded body]] where fromVarBinder :: Binder -> m Ident fromVarBinder NullBinder = freshIdent' @@ -357,30 +355,26 @@ toDecls [ValueDeclaration ident nameKind bs [MkUnguarded val]] | all isIrrefutab fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b fromVarBinder (TypedBinder _ b) = fromVarBinder b fromVarBinder _ = internalError "fromVarBinder: Invalid argument" -toDecls ds@(ValueDeclaration ident _ bs (result : _) : _) = do +toDecls ds@(ValueDeclaration (ss, _) ident _ bs (result : _) : _) = do let tuples = map toTuple ds isGuarded (MkUnguarded _) = False isGuarded _ = True - unless (all ((== length bs) . length . fst) tuples) $ - throwError . errorMessage $ ArgListLengthsDiffer ident - unless (not (null bs) || isGuarded result) $ - throwError . errorMessage $ DuplicateValueDeclaration ident - caseDecl <- makeCaseDeclaration ident tuples + unless (all ((== length bs) . length . fst) tuples) . + throwError . errorMessage' ss $ ArgListLengthsDiffer ident + unless (not (null bs) || isGuarded result) . + throwError . errorMessage' ss $ DuplicateValueDeclaration ident + caseDecl <- makeCaseDeclaration ss ident tuples return [caseDecl] -toDecls (PositionedDeclaration pos com d : ds) = do - (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds) - return (PositionedDeclaration pos com d' : ds') toDecls ds = return ds toTuple :: Declaration -> ([Binder], [GuardedExpr]) -toTuple (ValueDeclaration _ _ bs result) = (bs, result) -toTuple (PositionedDeclaration _ _ d) = toTuple d +toTuple (ValueDeclaration _ _ _ bs result) = (bs, result) toTuple _ = internalError "Not a value declaration" -makeCaseDeclaration :: forall m. (MonadSupply m) => Ident -> [([Binder], [GuardedExpr])] -> m Declaration -makeCaseDeclaration ident alternatives = do +makeCaseDeclaration :: forall m. (MonadSupply m) => SourceSpan -> Ident -> [([Binder], [GuardedExpr])] -> m Declaration +makeCaseDeclaration ss ident alternatives = do let namedArgs = map findName . fst <$> alternatives argNames = foldl1 resolveNames namedArgs args <- if allUnique (catMaybes argNames) @@ -390,7 +384,7 @@ makeCaseDeclaration ident alternatives = do binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] let value = foldr (Abs . VarBinder) (Case vars binders) args - return $ ValueDeclaration ident Public [] [MkUnguarded value] + return $ ValueDeclaration (ss, []) ident Public [] [MkUnguarded value] where -- We will construct a table of potential names. -- VarBinders will become Just _ which is a potential name. diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 4acd0ba2b8..282602a43c 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -24,10 +24,9 @@ desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desu -- | Desugar a single do statement desugarDo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration -desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> rethrowWithPosition pos (desugarDo d) desugarDo d = let (f, _, _) = everywhereOnValuesM return replace return - in f d + in rethrowWithPosition (declSourceSpan d) $ f d where bind :: Expr bind = Var (Qualified Nothing (Ident C.bind)) @@ -62,9 +61,8 @@ desugarDo d = go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet go (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () - checkBind (ValueDeclaration i@(Ident name) _ _ _) - | name `elem` [ C.bind, C.discard ] = throwError . errorMessage $ CannotUseBindWithDo i - checkBind (PositionedDeclaration pos _ decl) = rethrowWithPosition pos (checkBind decl) + checkBind (ValueDeclaration (ss, _) i@(Ident name) _ _ _) + | name `elem` [ C.bind, C.discard ] = throwError . errorMessage' ss $ CannotUseBindWithDo i checkBind _ = pure () mapM_ checkBind ds rest' <- go rest diff --git a/src/Language/PureScript/Sugar/LetPattern.hs b/src/Language/PureScript/Sugar/LetPattern.hs index 901522bdc3..9fb700d15e 100644 --- a/src/Language/PureScript/Sugar/LetPattern.hs +++ b/src/Language/PureScript/Sugar/LetPattern.hs @@ -19,7 +19,6 @@ desugarLetPatternModule (Module ss coms mn ds exts) = Module ss coms mn (map des -- Desugar a single let expression -- desugarLetPattern :: Declaration -> Declaration -desugarLetPattern (PositionedDeclaration pos com d) = PositionedDeclaration pos com $ desugarLetPattern d desugarLetPattern decl = let (f, _, _) = everywhereOnValues id replace id in f decl @@ -34,12 +33,8 @@ desugarLetPattern decl = -- ^ The original let-in result expression -> Expr go [] e = e - go (pd@(PositionedDeclaration pos com d) : ds) e = - case d of - BoundValueDeclaration {} -> PositionedValue pos com $ go (d:ds) e - _ -> append pd $ go ds e - go (BoundValueDeclaration binder boundE : ds) e = - Case [boundE] [CaseAlternative [binder] [MkUnguarded $ go ds e]] + go (BoundValueDeclaration (pos, com) binder boundE : ds) e = + PositionedValue pos com $ Case [boundE] [CaseAlternative [binder] [MkUnguarded $ go ds e]] go (d:ds) e = append d $ go ds e append :: Declaration -> Expr -> Expr diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index fc2d3de6d4..ebdb9f07e2 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -155,58 +155,89 @@ renameInModule => Imports -> Module -> m Module -renameInModule imports (Module ss coms mn decls exps) = - Module ss coms mn <$> parU decls go <*> pure exps +renameInModule imports (Module modSS coms mn decls exps) = + Module modSS coms mn <$> parU decls go <*> pure exps where - (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS + (go, _, _, _, _) = + everywhereWithContextOnValuesM + (modSS, []) + (\(_, bound) d -> (\(bound', d') -> ((declSourceSpan d', bound'), d')) <$> updateDecl bound d) + updateValue + updateBinder + updateCase + defS updateDecl - :: (Maybe SourceSpan, [Ident]) + :: [Ident] -> Declaration - -> m ((Maybe SourceSpan, [Ident]), Declaration) - updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = - return ((Just pos, bound), d) - updateDecl (pos, bound) (DataDeclaration dtype name args dctors) = - (,) (pos, bound) <$> (DataDeclaration dtype name <$> updateTypeArguments pos args - <*> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors) - updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) = - (,) (pos, bound) <$> (TypeSynonymDeclaration name <$> updateTypeArguments pos ps - <*> updateTypesEverywhere pos ty) - updateDecl (pos, bound) (TypeClassDeclaration className args implies deps ds) = - (,) (pos, bound) <$> (TypeClassDeclaration className <$> updateTypeArguments pos args - <*> updateConstraints pos implies - <*> pure deps - <*> pure ds) - updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) = - (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> traverse (updateTypesEverywhere pos) ts <*> pure ds) - updateDecl (pos, bound) (TypeDeclaration name ty) = - (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty) - updateDecl (pos, bound) (ExternDeclaration name ty) = - (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty) - updateDecl (pos, bound) (ExternDataDeclaration name ki) = - (,) (pos, bound) <$> (ExternDataDeclaration name <$> updateKindsEverywhere pos ki) - updateDecl (pos, bound) (TypeFixityDeclaration fixity alias op) = - (,) (pos, bound) <$> (TypeFixityDeclaration fixity <$> updateTypeName alias pos <*> pure op) - updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Left alias)) op) = - (,) (pos, bound) <$> (ValueFixityDeclaration fixity . fmap Left <$> updateValueName (Qualified mn' alias) pos <*> pure op) - updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Right alias)) op) = - (,) (pos, bound) <$> (ValueFixityDeclaration fixity . fmap Right <$> updateDataConstructorName (Qualified mn' alias) pos <*> pure op) - updateDecl s d = return (s, d) + -> m ([Ident], Declaration) + updateDecl bound (DataDeclaration sa@(ss, _) dtype name args dctors) = + fmap (bound,) $ + DataDeclaration sa dtype name + <$> updateTypeArguments ss args + <*> traverse (sndM (traverse (updateTypesEverywhere ss))) dctors + updateDecl bound (TypeSynonymDeclaration sa@(ss, _) name ps ty) = + fmap (bound,) $ + TypeSynonymDeclaration sa name + <$> updateTypeArguments ss ps + <*> updateTypesEverywhere ss ty + updateDecl bound (TypeClassDeclaration sa@(ss, _) className args implies deps ds) = + fmap (bound,) $ + TypeClassDeclaration sa className + <$> updateTypeArguments ss args + <*> updateConstraints ss implies + <*> pure deps + <*> pure ds + updateDecl bound (TypeInstanceDeclaration sa@(ss, _) name cs cn ts ds) = + fmap (bound,) $ + TypeInstanceDeclaration sa name + <$> updateConstraints ss cs + <*> updateClassName cn ss + <*> traverse (updateTypesEverywhere ss) ts + <*> pure ds + updateDecl bound (TypeDeclaration sa@(ss, _) name ty) = + fmap (bound,) $ + TypeDeclaration sa name + <$> updateTypesEverywhere ss ty + updateDecl bound (ExternDeclaration sa@(ss, _) name ty) = + fmap (name : bound,) $ + ExternDeclaration sa name + <$> updateTypesEverywhere ss ty + updateDecl bound (ExternDataDeclaration sa@(ss, _) name ki) = + fmap (bound,) $ + ExternDataDeclaration sa name + <$> updateKindsEverywhere ss ki + updateDecl bound (TypeFixityDeclaration sa@(ss, _) fixity alias op) = + fmap (bound,) $ + TypeFixityDeclaration sa fixity + <$> updateTypeName alias ss + <*> pure op + updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Left alias)) op) = + fmap (bound,) $ + ValueFixityDeclaration sa fixity . fmap Left + <$> updateValueName (Qualified mn' alias) ss + <*> pure op + updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Right alias)) op) = + fmap (bound,) $ + ValueFixityDeclaration sa fixity . fmap Right + <$> updateDataConstructorName (Qualified mn' alias) ss + <*> pure op + updateDecl b d = + return (b, d) updateValue - :: (Maybe SourceSpan, [Ident]) + :: (SourceSpan, [Ident]) -> Expr - -> m ((Maybe SourceSpan, [Ident]), Expr) + -> m ((SourceSpan, [Ident]), Expr) updateValue (_, bound) v@(PositionedValue pos' _ _) = - return ((Just pos', bound), v) + return ((pos', bound), v) updateValue (pos, bound) (Abs (VarBinder arg) val') = return ((pos, arg : bound), Abs (VarBinder arg) val') updateValue (pos, bound) (Let ds val') = do let args = mapMaybe letBoundVariable ds - unless (length (ordNub args) == length args) $ - maybe id rethrowWithPosition pos $ - throwError . errorMessage $ OverlappingNamesInLet + unless (length (ordNub args) == length args) . + throwError . errorMessage' pos $ OverlappingNamesInLet return ((pos, args ++ bound), Let ds val') updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound = (,) (pos, bound) <$> (Var <$> updateValueName name' pos) @@ -221,11 +252,11 @@ renameInModule imports (Module ss coms mn decls exps) = updateValue s v = return (s, v) updateBinder - :: (Maybe SourceSpan, [Ident]) + :: (SourceSpan, [Ident]) -> Binder - -> m ((Maybe SourceSpan, [Ident]), Binder) + -> m ((SourceSpan, [Ident]), Binder) updateBinder (_, bound) v@(PositionedBinder pos _ _) = - return ((Just pos, bound), v) + return ((pos, bound), v) updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b) updateBinder s@(pos, _) (OpBinder op) = @@ -237,9 +268,9 @@ renameInModule imports (Module ss coms mn decls exps) = return (s, v) updateCase - :: (Maybe SourceSpan, [Ident]) + :: (SourceSpan, [Ident]) -> CaseAlternative - -> m ((Maybe SourceSpan, [Ident]), CaseAlternative) + -> m ((SourceSpan, [Ident]), CaseAlternative) updateCase (pos, bound) c@(CaseAlternative bs gs) = return ((pos, concatMap binderNames bs ++ updateGuard gs ++ bound), c) where @@ -252,11 +283,10 @@ renameInModule imports (Module ss coms mn decls exps) = updatePatGuard _ = [] letBoundVariable :: Declaration -> Maybe Ident - letBoundVariable (ValueDeclaration ident _ _ _) = Just ident - letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d + letBoundVariable (ValueDeclaration _ ident _ _ _) = Just ident letBoundVariable _ = Nothing - updateKindsEverywhere :: Maybe SourceSpan -> Kind -> m Kind + updateKindsEverywhere :: SourceSpan -> Kind -> m Kind updateKindsEverywhere pos = everywhereOnKindsM updateKind where updateKind :: Kind -> m Kind @@ -265,11 +295,11 @@ renameInModule imports (Module ss coms mn decls exps) = updateTypeArguments :: (Traversable f, Traversable g) - => Maybe SourceSpan + => SourceSpan -> f (a, g Kind) -> m (f (a, g Kind)) updateTypeArguments pos = traverse (sndM (traverse (updateKindsEverywhere pos))) - updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type + updateTypesEverywhere :: SourceSpan -> Type -> m Type updateTypesEverywhere pos = everywhereOnTypesM updateType where updateType :: Type -> m Type @@ -282,7 +312,7 @@ renameInModule imports (Module ss coms mn decls exps) = updateInConstraint (Constraint name ts info) = Constraint <$> updateClassName name pos <*> pure ts <*> pure info - updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint] + updateConstraints :: SourceSpan -> [Constraint] -> m [Constraint] updateConstraints pos = traverse $ \(Constraint name ts info) -> Constraint <$> updateClassName name pos @@ -291,40 +321,40 @@ renameInModule imports (Module ss coms mn decls exps) = updateTypeName :: Qualified (ProperName 'TypeName) - -> Maybe SourceSpan + -> SourceSpan -> m (Qualified (ProperName 'TypeName)) updateTypeName = update (importedTypes imports) TyName updateTypeOpName :: Qualified (OpName 'TypeOpName) - -> Maybe SourceSpan + -> SourceSpan -> m (Qualified (OpName 'TypeOpName)) updateTypeOpName = update (importedTypeOps imports) TyOpName updateDataConstructorName :: Qualified (ProperName 'ConstructorName) - -> Maybe SourceSpan + -> SourceSpan -> m (Qualified (ProperName 'ConstructorName)) updateDataConstructorName = update (importedDataConstructors imports) DctorName updateClassName :: Qualified (ProperName 'ClassName) - -> Maybe SourceSpan + -> SourceSpan -> m (Qualified (ProperName 'ClassName)) updateClassName = update (importedTypeClasses imports) TyClassName - updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident) + updateValueName :: Qualified Ident -> SourceSpan -> m (Qualified Ident) updateValueName = update (importedValues imports) IdentName updateValueOpName :: Qualified (OpName 'ValueOpName) - -> Maybe SourceSpan + -> SourceSpan -> m (Qualified (OpName 'ValueOpName)) updateValueOpName = update (importedValueOps imports) ValOpName updateKindName :: Qualified (ProperName 'KindName) - -> Maybe SourceSpan + -> SourceSpan -> m (Qualified (ProperName 'KindName)) updateKindName = update (importedKinds imports) KiName @@ -336,9 +366,9 @@ renameInModule imports (Module ss coms mn decls exps) = => M.Map (Qualified a) [ImportRecord a] -> (a -> Name) -> Qualified a - -> Maybe SourceSpan + -> SourceSpan -> m (Qualified a) - update imps toName qname@(Qualified mn' name) pos = positioned $ + update imps toName qname@(Qualified mn' name) pos = warnAndRethrowWithPosition pos $ case (M.lookup qname imps, mn') of -- We found the name in our imports, so we return the name for it, @@ -366,5 +396,4 @@ renameInModule imports (Module ss coms mn decls exps) = _ -> throwUnknown where - positioned err = maybe err (`warnAndRethrowWithPosition` err) pos throwUnknown = throwError . errorMessage . UnknownName . fmap toName $ qname diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 31d3bda53d..660efc1aac 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -27,34 +27,34 @@ import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) -- findExportable :: forall m. (MonadError MultipleErrors m) => Module -> m Exports findExportable (Module _ _ mn ds _) = - rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds + rethrow (addHint (ErrorInModule mn)) $ foldM updateExports' nullExports ds where + updateExports' :: Exports -> Declaration -> m Exports + updateExports' exps decl = rethrowWithPosition (declSourceSpan decl) $ updateExports exps decl + updateExports :: Exports -> Declaration -> m Exports - updateExports exps (TypeClassDeclaration tcn _ _ _ ds') = do - exps' <- exportTypeClass Internal exps tcn mn + updateExports exps (TypeClassDeclaration (ss, _) tcn _ _ _ ds') = do + exps' <- rethrowWithPosition ss $ exportTypeClass Internal exps tcn mn foldM go exps' ds' where - go exps'' (TypeDeclaration name _) = exportValue exps'' name mn - go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d + go exps'' (TypeDeclaration (ss', _) name _) = rethrowWithPosition ss' $ exportValue exps'' name mn go _ _ = internalError "Invalid declaration in TypeClassDeclaration" - updateExports exps (DataDeclaration _ tn _ dcs) = + updateExports exps (DataDeclaration _ _ tn _ dcs) = exportType Internal exps tn (map fst dcs) mn - updateExports exps (TypeSynonymDeclaration tn _ _) = + updateExports exps (TypeSynonymDeclaration _ tn _ _) = exportType Internal exps tn [] mn - updateExports exps (ExternDataDeclaration tn _) = + updateExports exps (ExternDataDeclaration _ tn _) = exportType Internal exps tn [] mn - updateExports exps (ValueDeclaration name _ _ _) = + updateExports exps (ValueDeclaration _ name _ _ _) = exportValue exps name mn - updateExports exps (ValueFixityDeclaration _ _ op) = + updateExports exps (ValueFixityDeclaration _ _ _ op) = exportValueOp exps op mn - updateExports exps (TypeFixityDeclaration _ _ op) = + updateExports exps (TypeFixityDeclaration _ _ _ op) = exportTypeOp exps op mn - updateExports exps (ExternDeclaration name _) = + updateExports exps (ExternDeclaration _ name _) = exportValue exps name mn - updateExports exps (ExternKindDeclaration pn) = + updateExports exps (ExternKindDeclaration _ pn) = exportKind exps pn mn - updateExports exps (PositionedDeclaration pos _ d) = - rethrowWithPosition pos $ updateExports exps d updateExports exps _ = return exps -- | diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index a46d6cc55e..fafa345509 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -26,8 +26,7 @@ desugarObjectConstructors desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts desugarDecl :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration -desugarDecl (PositionedDeclaration pos com d) = rethrowWithPosition pos $ PositionedDeclaration pos com <$> desugarDecl d -desugarDecl other = fn other +desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d where (fn, _, _) = everywhereOnValuesTopDownM return desugarExpr return @@ -70,7 +69,7 @@ desugarDecl other = fn other then Abs (VarBinder val) <$> wrapLambda (buildUpdates valExpr) ps else wrapLambda (buildLet val . buildUpdates valExpr) ps where - buildLet val = Let [ValueDeclaration val Public [] [MkUnguarded obj]] + buildLet val = Let [ValueDeclaration (declSourceSpan d, []) val Public [] [MkUnguarded obj]] -- recursively build up the nested `ObjectUpdate` expressions buildUpdates :: Expr -> PathTree Expr -> Expr diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 0e433789c7..a55071aeda 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -116,16 +116,12 @@ rebracket externs modules = do (f', _, _, _, _) = everywhereWithContextOnValuesM Nothing - (\pos -> uncurry goDecl <=< goDecl' pos) + (\_ d -> (Just (declSourceSpan d),) <$> goDecl' d) (\pos -> uncurry goExpr <=< goExpr' pos) (\pos -> uncurry goBinder <=< goBinder' pos) defS defS - goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration) - goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d) - goDecl pos other = return (pos, other) - goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) goExpr pos (Op op) = @@ -180,7 +176,7 @@ rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) = where (f, _, _) = everywhereOnValuesTopDownM - (decontextify goDecl) + goDecl (goExpr <=< decontextify goExpr') (goBinder <=< decontextify goBinder') @@ -203,7 +199,7 @@ removeParens = f where (f, _, _) = everywhereOnValues - (decontextify goDecl) + (runIdentity . goDecl) (goExpr . decontextify goExpr') (goBinder . decontextify goBinder') @@ -258,11 +254,10 @@ collectFixities :: Module -> [Either ValueFixityRecord TypeFixityRecord] collectFixities (Module _ _ moduleName ds _) = concatMap collect ds where collect :: Declaration -> [Either ValueFixityRecord TypeFixityRecord] - collect (PositionedDeclaration pos _ (ValueFixityDeclaration fixity name op)) = - [Left (Qualified (Just moduleName) op, pos, fixity, name)] - collect (PositionedDeclaration pos _ (TypeFixityDeclaration fixity name op)) = - [Right (Qualified (Just moduleName) op, pos, fixity, name)] - collect FixityDeclaration{} = internalError "Fixity without srcpos info" + collect (ValueFixityDeclaration (ss, _) fixity name op) = + [Left (Qualified (Just moduleName) op, ss, fixity, name)] + collect (TypeFixityDeclaration (ss, _) fixity name op) = + [Right (Qualified (Just moduleName) op, ss, fixity, name)] collect _ = [] ensureNoDuplicates @@ -294,9 +289,9 @@ updateTypes :: forall m . Monad m => (Maybe SourceSpan -> Type -> m Type) - -> ( Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration) - , Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) - , Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) + -> ( Declaration -> m Declaration + , Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) + , Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) ) updateTypes goType = (goDecl, goExpr, goBinder) where @@ -304,28 +299,27 @@ updateTypes goType = (goDecl, goExpr, goBinder) goType' :: Maybe SourceSpan -> Type -> m Type goType' = everywhereOnTypesM . goType - goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration) - goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d) - goDecl pos (DataDeclaration ddt name args dctors) = do - dctors' <- traverse (sndM (traverse (goType' pos))) dctors - return (pos, DataDeclaration ddt name args dctors') - goDecl pos (ExternDeclaration name ty) = do - ty' <- goType' pos ty - return (pos, ExternDeclaration name ty') - goDecl pos (TypeClassDeclaration name args implies deps decls) = do - implies' <- traverse (overConstraintArgs (traverse (goType' pos))) implies - return (pos, TypeClassDeclaration name args implies' deps decls) - goDecl pos (TypeInstanceDeclaration name cs className tys impls) = do - cs' <- traverse (overConstraintArgs (traverse (goType' pos))) cs - tys' <- traverse (goType' pos) tys - return (pos, TypeInstanceDeclaration name cs' className tys' impls) - goDecl pos (TypeSynonymDeclaration name args ty) = do - ty' <- goType' pos ty - return (pos, TypeSynonymDeclaration name args ty') - goDecl pos (TypeDeclaration expr ty) = do - ty' <- goType' pos ty - return (pos, TypeDeclaration expr ty') - goDecl pos other = return (pos, other) + goType'' :: SourceSpan -> Type -> m Type + goType'' = goType' . Just + + goDecl :: Declaration -> m Declaration + goDecl (DataDeclaration sa@(ss, _) ddt name args dctors) = + DataDeclaration sa ddt name args <$> traverse (sndM (traverse (goType'' ss))) dctors + goDecl (ExternDeclaration sa@(ss, _) name ty) = + ExternDeclaration sa name <$> goType'' ss ty + goDecl (TypeClassDeclaration sa@(ss, _) name args implies deps decls) = do + implies' <- traverse (overConstraintArgs (traverse (goType'' ss))) implies + return $ TypeClassDeclaration sa name args implies' deps decls + goDecl (TypeInstanceDeclaration sa@(ss, _) name cs className tys impls) = do + cs' <- traverse (overConstraintArgs (traverse (goType'' ss))) cs + tys' <- traverse (goType'' ss) tys + return $ TypeInstanceDeclaration sa name cs' className tys' impls + goDecl (TypeSynonymDeclaration sa@(ss, _) name args ty) = + TypeSynonymDeclaration sa name args <$> goType'' ss ty + goDecl (TypeDeclaration sa@(ss, _) expr ty) = + TypeDeclaration sa expr <$> goType'' ss ty + goDecl other = + return other goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index bbddb5cdd2..5819bb8c89 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -176,21 +176,18 @@ desugarDecl -> Desugar m (Maybe DeclarationRef, [Declaration]) desugarDecl mn exps = go where - go d@(TypeClassDeclaration name args implies deps members) = do + go d@(TypeClassDeclaration sa name args implies deps members) = do modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps)) - return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) - go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" - go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do + return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) + go (TypeInstanceDeclaration _ _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" + go d@(TypeInstanceDeclaration sa name deps className tys (ExplicitInstance members)) = do desugared <- desugarCases members - dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared + dictDecl <- typeInstanceDictionaryDeclaration sa name mn deps className tys desugared return (expRef name className tys, [d, dictDecl]) - go d@(TypeInstanceDeclaration name deps className tys (NewtypeInstanceWithDictionary dict)) = do + go d@(TypeInstanceDeclaration sa name deps className tys (NewtypeInstanceWithDictionary dict)) = do let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (foldr ConstrainedType dictTy deps) - return (expRef name className tys, [d, ValueDeclaration name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) - go (PositionedDeclaration pos com d) = do - (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d - return (dr, map (PositionedDeclaration pos com) ds) + return (expRef name className tys, [d, ValueDeclaration sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) go other = return (Nothing, [other]) expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef @@ -225,24 +222,24 @@ desugarDecl mn exps = go genSpan = internalModuleSourceSpan "" memberToNameAndType :: Declaration -> (Ident, Type) -memberToNameAndType (TypeDeclaration ident ty) = (ident, ty) -memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d +memberToNameAndType (TypeDeclaration _ ident ty) = (ident, ty) memberToNameAndType _ = internalError "Invalid declaration in type class definition" typeClassDictionaryDeclaration - :: ProperName 'ClassName + :: SourceAnn + -> ProperName 'ClassName -> [(Text, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration -typeClassDictionaryDeclaration name args implies members = +typeClassDictionaryDeclaration sa name args implies members = let superclassTypes = superClassDictionaryNames implies `zip` [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs) | (Constraint superclass tyArgs _) <- implies ] members' = map (first runIdent . memberToNameAndType) members mtys = members' ++ superclassTypes - in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyRecord $ rowFromList (map (first (Label . mkString)) mtys, REmpty)) + in TypeSynonymDeclaration sa (coerceProperName name) args (TypeApp tyRecord $ rowFromList (map (first (Label . mkString)) mtys, REmpty)) typeClassMemberToDictionaryAccessor :: ModuleName @@ -250,15 +247,13 @@ typeClassMemberToDictionaryAccessor -> [(Text, Maybe Kind)] -> Declaration -> Declaration -typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) = +typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration sa ident ty) = let className = Qualified (Just mn) name - in ValueDeclaration ident Private [] $ + in ValueDeclaration sa ident Private [] $ [MkUnguarded ( TypedValue False (TypeClassDictionaryAccessor className ident) $ moveQuantifiersToFront (quantify (ConstrainedType (Constraint className (map (TypeVar . fst) args) Nothing) ty)) )] -typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) = - PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" unit :: Type @@ -267,14 +262,15 @@ unit = TypeApp tyRecord REmpty typeInstanceDictionaryDeclaration :: forall m . (MonadSupply m, MonadError MultipleErrors m) - => Ident + => SourceAnn + -> Ident -> ModuleName -> [Constraint] -> Qualified (ProperName 'ClassName) -> [Type] -> [Declaration] -> Desugar m Declaration -typeInstanceDictionaryDeclaration name mn deps className tys decls = +typeInstanceDictionaryDeclaration sa name mn deps className tys decls = rethrow (addHint (ErrorInInstance className tys)) $ do m <- get @@ -305,30 +301,25 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (foldr ConstrainedType dictTy deps) dict = TypeClassDictionaryConstructorApp className props - result = ValueDeclaration name Private [] [MkUnguarded (TypedValue True dict constrainedTy)] + result = ValueDeclaration sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)] return result where declName :: Declaration -> Maybe Ident - declName (PositionedDeclaration _ _ d) = declName d - declName (ValueDeclaration ident _ _ _) = Just ident - declName (TypeDeclaration ident _) = Just ident + declName (ValueDeclaration _ ident _ _ _) = Just ident + declName (TypeDeclaration _ ident _) = Just ident declName _ = Nothing memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr - memberToValue tys' (ValueDeclaration ident _ [] [MkUnguarded val]) = do + memberToValue tys' (ValueDeclaration _ ident _ [] [MkUnguarded val]) = do _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys' return val - memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do - val <- memberToValue tys' d - return (PositionedValue pos com val) memberToValue _ _ = internalError "Invalid declaration in type instance definition" typeClassMemberName :: Declaration -> Text -typeClassMemberName (TypeDeclaration ident _) = runIdent ident -typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident -typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d +typeClassMemberName (TypeDeclaration _ ident _) = runIdent ident +typeClassMemberName (ValueDeclaration _ ident _ _ _) = runIdent ident typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration in type class definition" superClassDictionaryNames :: [Constraint] -> [Text] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 7bfe373cb1..503487cbb1 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -84,9 +84,8 @@ deriveInstances externs (Module ss coms mn ds exts) = fromExternsDecl mn' (EDTypeSynonym name args ty) = Just (Qualified (Just mn') name, (args, ty)) fromExternsDecl _ _ = Nothing - fromLocalDecl (TypeSynonymDeclaration name args ty) = do + fromLocalDecl (TypeSynonymDeclaration _ name args ty) = Just (Qualified (Just mn) name, (args, ty)) - fromLocalDecl (PositionedDeclaration _ _ d) = fromLocalDecl d fromLocalDecl _ = Nothing instanceData :: NewtypeDerivedInstances @@ -99,11 +98,10 @@ deriveInstances externs (Module ss coms mn ds exts) = foldMap (\nm -> NewtypeDerivedInstances mempty (S.singleton (qualify mn' edInstanceClassName, nm))) (extractNewtypeName mn' edInstanceTypes) fromExternsDecl _ _ = mempty - fromLocalDecl (TypeClassDeclaration cl args cons deps _) = + fromLocalDecl (TypeClassDeclaration _ cl args cons deps _) = NewtypeDerivedInstances (M.singleton (mn, cl) (map fst args, cons, deps)) mempty - fromLocalDecl (TypeInstanceDeclaration _ _ cl tys _) = + fromLocalDecl (TypeInstanceDeclaration _ _ _ cl tys _) = foldMap (\nm -> NewtypeDerivedInstances mempty (S.singleton (qualify mn cl, nm))) (extractNewtypeName mn tys) - fromLocalDecl (PositionedDeclaration _ _ d) = fromLocalDecl d fromLocalDecl _ = mempty -- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration, @@ -116,62 +114,61 @@ deriveInstance -> [Declaration] -> Declaration -> m Declaration -deriveInstance mn syns _ ds (TypeInstanceDeclaration nm deps className tys DerivedInstance) +deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) nm deps className tys DerivedInstance) | className == Qualified (Just dataGeneric) (ProperName C.generic) = case tys of [ty] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn syns ds tyCon args - | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty - _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 + -> TypeInstanceDeclaration sa nm deps className tys . ExplicitInstance <$> deriveGeneric ss mn syns ds tyCon args + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataEq) (ProperName "Eq") = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn syns ds tyCon - | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty - _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 + -> TypeInstanceDeclaration sa nm deps className tys . ExplicitInstance <$> deriveEq ss mn syns ds tyCon + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataOrd) (ProperName "Ord") = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn syns ds tyCon - | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty - _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 + -> TypeInstanceDeclaration sa nm deps className tys . ExplicitInstance <$> deriveOrd ss mn syns ds tyCon + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataFunctor) (ProperName "Functor") = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveFunctor mn syns ds tyCon - | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty - _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 + -> TypeInstanceDeclaration sa nm deps className tys . ExplicitInstance <$> deriveFunctor ss mn syns ds tyCon + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataNewtype) (ProperName "Newtype") = case tys of [wrappedTy, unwrappedTy] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy , mn == fromMaybe mn mn' -> do (inst, actualUnwrappedTy) <- deriveNewtype mn syns ds tyCon args unwrappedTy - return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) - | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys wrappedTy - _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 2 + return $ TypeInstanceDeclaration sa nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys wrappedTy + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 | className == Qualified (Just dataGenericRep) (ProperName C.generic) = case tys of [actualTy, repTy] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy , mn == fromMaybe mn mn' -> do (inst, inferredRepTy) <- deriveGenericRep mn syns ds tyCon args repTy - return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) - | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys actualTy - _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 2 - | otherwise = throwError . errorMessage $ CannotDerive className tys -deriveInstance mn syns ndis ds (TypeInstanceDeclaration nm deps className tys NewtypeInstance) = + return $ TypeInstanceDeclaration sa nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys actualTy + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 + | otherwise = throwError . errorMessage' ss $ CannotDerive className tys +deriveInstance mn syns ndis ds (TypeInstanceDeclaration sa@(ss, _) nm deps className tys NewtypeInstance) = case tys of _ : _ | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys) , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance mn syns ndis className ds tys tyCon args - | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys (last tys) - _ -> throwError . errorMessage $ InvalidNewtypeInstance className tys -deriveInstance mn syns ndis ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn syns ndis ds d + -> TypeInstanceDeclaration sa nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance ss mn syns ndis className ds tys tyCon args + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys (last tys) + _ -> throwError . errorMessage' ss $ InvalidNewtypeInstance className tys deriveInstance _ _ _ _ e = return e unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type]) @@ -186,7 +183,8 @@ unwrapTypeConstructor = fmap (second reverse) . go deriveNewtypeInstance :: forall m . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => ModuleName + => SourceSpan + -> ModuleName -> SynonymMap -> NewtypeDerivedInstances -> Qualified (ProperName 'ClassName) @@ -195,12 +193,12 @@ deriveNewtypeInstance -> ProperName 'TypeName -> [Type] -> m Expr -deriveNewtypeInstance mn syns ndis className ds tys tyConNm dargs = do +deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do verifySuperclasses tyCon <- findTypeDecl tyConNm ds go tyCon where - go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])]) + go (DataDeclaration _ Newtype _ tyArgNames [(_, [wrapped])]) -- The newtype might not be applied to all type arguments. -- This is okay as long as the newtype wraps something which ends with -- sufficiently many type applications to variables. @@ -214,8 +212,7 @@ deriveNewtypeInstance mn syns ndis className ds tys tyConNm dargs = do do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs wrapped'' <- replaceAllTypeSynonymsM syns wrapped' return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped''])) - go (PositionedDeclaration _ _ d) = go d - go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys + go _ = throwError . errorMessage' ss $ InvalidNewtypeInstance className tys takeReverse :: Int -> [a] -> [a] takeReverse n = take n . reverse @@ -248,8 +245,8 @@ deriveNewtypeInstance mn syns ndis className ds tys tyConNm dargs = do -- be possible, so we warn again. for_ (extractNewtypeName mn tys) $ \nm -> unless ((constraintClass', nm) `S.member` ndiDerivedInstances ndis) $ - tell . errorMessage $ MissingNewtypeSuperclassInstance constraintClass className tys - else tell . errorMessage $ UnverifiableSuperclassInstance constraintClass className tys + tell . errorMessage' ss $ MissingNewtypeSuperclassInstance constraintClass className tys + else tell . errorMessage' ss $ UnverifiableSuperclassInstance constraintClass className tys dataGeneric :: ModuleName dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] @@ -280,24 +277,25 @@ unguarded e = [MkUnguarded e] deriveGeneric :: forall m. (MonadError MultipleErrors m, MonadSupply m) - => ModuleName + => SourceSpan + -> ModuleName -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> [Type] -> m [Declaration] -deriveGeneric mn syns ds tyConNm dargs = do +deriveGeneric ss mn syns ds tyConNm dargs = do tyCon <- findTypeDecl tyConNm ds toSpine <- mkSpineFunction tyCon fromSpine <- mkFromSpineFunction tyCon toSignature <- mkSignatureFunction tyCon dargs - return [ ValueDeclaration (Ident C.toSpine) Public [] (unguarded toSpine) - , ValueDeclaration (Ident C.fromSpine) Public [] (unguarded fromSpine) - , ValueDeclaration (Ident C.toSignature) Public [] (unguarded toSignature) + return [ ValueDeclaration (ss, []) (Ident C.toSpine) Public [] (unguarded toSpine) + , ValueDeclaration (ss, []) (Ident C.fromSpine) Public [] (unguarded fromSpine) + , ValueDeclaration (ss, []) (Ident C.toSignature) Public [] (unguarded toSignature) ] where mkSpineFunction :: Declaration -> m Expr - mkSpineFunction (DataDeclaration _ _ _ args) = do + mkSpineFunction (DataDeclaration _ _ _ _ args) = do x <- freshIdent' lamCase x <$> mapM mkCtorClause args where @@ -330,11 +328,10 @@ deriveGeneric mn syns ds tyConNm dargs = do ) $ fields toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i - mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration" mkSignatureFunction :: Declaration -> [Type] -> m Expr - mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd <$> mapM mkProdClause args + mkSignatureFunction (DataDeclaration _ _ name tyArgs args) classArgs = lamNull . mkSigProd <$> mapM mkProdClause args where mkSigProd :: [Expr] -> Expr mkSigProd = @@ -373,11 +370,10 @@ deriveGeneric mn syns ds tyConNm dargs = do mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature)) (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ)) instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs) - mkSignatureFunction (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction d classArgs mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration" mkFromSpineFunction :: Declaration -> m Expr - mkFromSpineFunction (DataDeclaration _ _ _ args) = do + mkFromSpineFunction (DataDeclaration _ _ _ _ args) = do x <- freshIdent' lamCase x <$> (addCatch <$> mapM mkAlternative args) where @@ -434,7 +430,6 @@ deriveGeneric mn syns ds tyConNm dargs = do mkRecFun :: [(Label, Type)] -> Expr mkRecFun xs = mkJust $ foldr (lam . labelToIdent . fst) recLiteral xs where recLiteral = Literal . ObjectLiteral $ map (\(l@(Label s), _) -> (s, mkVar $ labelToIdent l)) xs - mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration" -- Helpers @@ -466,31 +461,30 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do go =<< findTypeDecl tyConNm ds where go :: Declaration -> m ([Declaration], Type) - go (DataDeclaration _ _ args dctors) = do + go (DataDeclaration (ss, _) _ _ args dctors) = do x <- freshIdent "x" (reps, to, from) <- unzip3 <$> traverse makeInst dctors let rep = toRepTy reps inst | null reps = -- If there are no cases, spin - [ ValueDeclaration (Ident "to") Public [] $ unguarded $ + [ ValueDeclaration (ss, []) (Ident "to") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] (unguarded (App toName (Var (Qualified Nothing x)))) ] - , ValueDeclaration (Ident "from") Public [] $ unguarded $ + , ValueDeclaration (ss, []) (Ident "from") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] (unguarded (App fromName (Var (Qualified Nothing x)))) ] ] | otherwise = - [ ValueDeclaration (Ident "to") Public [] $ unguarded $ + [ ValueDeclaration (ss, []) (Ident "to") Public [] $ unguarded $ lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to) - , ValueDeclaration (Ident "from") Public [] $ unguarded $ + , ValueDeclaration (ss, []) (Ident "from") Public [] $ unguarded $ lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from) ] subst = zipWith ((,) . fst) args tyConArgs return (inst, replaceAllTypeVars subst rep) - go (PositionedDeclaration _ _ d) = go d go _ = internalError "deriveGenericRep go: expected DataDeclaration" select :: (a -> a) -> (a -> a) -> Int -> [a -> a] @@ -643,24 +637,25 @@ checkIsWildcard _ (TypeWildcard _) = return () checkIsWildcard tyConNm _ = throwError . errorMessage $ ExpectedWildcard tyConNm -deriveEq :: - forall m. (MonadError MultipleErrors m, MonadSupply m) - => ModuleName +deriveEq + :: forall m + . (MonadError MultipleErrors m, MonadSupply m) + => SourceSpan + -> ModuleName -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> m [Declaration] -deriveEq mn syns ds tyConNm = do +deriveEq ss mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds eqFun <- mkEqFunction tyCon - return [ ValueDeclaration (Ident C.eq) Public [] (unguarded eqFun) ] + return [ ValueDeclaration (ss, []) (Ident C.eq) Public [] (unguarded eqFun) ] where mkEqFunction :: Declaration -> m Expr - mkEqFunction (DataDeclaration _ _ _ args) = do + mkEqFunction (DataDeclaration _ _ _ _ args) = do x <- freshIdent "x" y <- freshIdent "y" lamCase2 x y <$> (addCatch <$> mapM mkCtorClause args) - mkEqFunction (PositionedDeclaration _ _ d) = mkEqFunction d mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration" preludeConj :: Expr -> Expr -> Expr @@ -698,24 +693,25 @@ deriveEq mn syns ds tyConNm = do $ fields toEqTest l r _ = preludeEq l r -deriveOrd :: - forall m. (MonadError MultipleErrors m, MonadSupply m) - => ModuleName +deriveOrd + :: forall m + . (MonadError MultipleErrors m, MonadSupply m) + => SourceSpan + -> ModuleName -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> m [Declaration] -deriveOrd mn syns ds tyConNm = do +deriveOrd ss mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds compareFun <- mkCompareFunction tyCon - return [ ValueDeclaration (Ident C.compare) Public [] (unguarded compareFun) ] + return [ ValueDeclaration (ss, []) (Ident C.compare) Public [] (unguarded compareFun) ] where mkCompareFunction :: Declaration -> m Expr - mkCompareFunction (DataDeclaration _ _ _ args) = do + mkCompareFunction (DataDeclaration _ _ _ _ args) = do x <- freshIdent "x" y <- freshIdent "y" lamCase2 x y <$> (addCatch . concat <$> mapM mkCtorClauses (splitLast args)) - mkCompareFunction (PositionedDeclaration _ _ d) = mkCompareFunction d mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration" splitLast :: [a] -> [(a, Bool)] @@ -801,18 +797,18 @@ deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do go =<< findTypeDecl tyConNm ds where go :: Declaration -> m ([Declaration], Type) - go (DataDeclaration Data name _ _) = - throwError . errorMessage $ CannotDeriveNewtypeForData name - go (DataDeclaration Newtype name args dctors) = do + go (DataDeclaration (ss, _) Data name _ _) = + throwError . errorMessage' ss $ CannotDeriveNewtypeForData name + go (DataDeclaration (ss, _) Newtype name args dctors) = do checkNewtype name dctors wrappedIdent <- freshIdent "n" unwrappedIdent <- freshIdent "a" let (ctorName, [ty]) = head dctors ty' <- replaceAllTypeSynonymsM syns ty let inst = - [ ValueDeclaration (Ident "wrap") Public [] $ unguarded $ + [ ValueDeclaration (ss, []) (Ident "wrap") Public [] $ unguarded $ Constructor (Qualified (Just mn) ctorName) - , ValueDeclaration (Ident "unwrap") Public [] $ unguarded $ + , ValueDeclaration (ss, []) (Ident "unwrap") Public [] $ unguarded $ lamCase wrappedIdent [ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]] @@ -821,7 +817,6 @@ deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do ] subst = zipWith ((,) . fst) args tyConArgs return (inst, replaceAllTypeVars subst ty') - go (PositionedDeclaration _ _ d) = go d go _ = internalError "deriveNewtype go: expected DataDeclaration" findTypeDecl @@ -832,8 +827,7 @@ findTypeDecl findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl where isTypeDecl :: Declaration -> Bool - isTypeDecl (DataDeclaration _ nm _ _) | nm == tyConNm = True - isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d + isTypeDecl (DataDeclaration _ _ nm _ _) | nm == tyConNm = True isTypeDecl _ = False lam :: Ident -> Expr -> Expr @@ -883,24 +877,24 @@ decomposeRec' = sortBy (comparing fst) . go deriveFunctor :: forall m . (MonadError MultipleErrors m, MonadSupply m) - => ModuleName + => SourceSpan + -> ModuleName -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> m [Declaration] -deriveFunctor mn syns ds tyConNm = do +deriveFunctor ss mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds mapFun <- mkMapFunction tyCon - return [ ValueDeclaration (Ident C.map) Public [] (unguarded mapFun) ] + return [ ValueDeclaration (ss, []) (Ident C.map) Public [] (unguarded mapFun) ] where mkMapFunction :: Declaration -> m Expr - mkMapFunction (DataDeclaration _ _ tys ctors) = case reverse tys of - [] -> throwError . errorMessage $ KindsDoNotUnify (FunKind kindType kindType) kindType + mkMapFunction (DataDeclaration (ss', _) _ _ tys ctors) = case reverse tys of + [] -> throwError . errorMessage' ss' $ KindsDoNotUnify (FunKind kindType kindType) kindType ((iTy, _) : _) -> do f <- freshIdent "f" m <- freshIdent "m" lam f . lamCase m <$> mapM (mkCtorClause iTy f) ctors - mkMapFunction (PositionedDeclaration _ _ d) = mkMapFunction d mkMapFunction _ = internalError "mkMapFunction: expected DataDeclaration" mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [Type]) -> m CaseAlternative diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index f9b09eff81..8013f70cbc 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -23,39 +23,33 @@ desugarTypeDeclarationsModule . MonadError MultipleErrors m => Module -> m Module -desugarTypeDeclarationsModule (Module ss coms name ds exps) = +desugarTypeDeclarationsModule (Module modSS coms name ds exps) = rethrow (addHint (ErrorInModule name)) $ - Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps + Module modSS coms name <$> desugarTypeDeclarations ds <*> pure exps where desugarTypeDeclarations :: [Declaration] -> m [Declaration] - desugarTypeDeclarations (PositionedDeclaration pos com d : rest) = do - (d' : rest') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : rest) - return (PositionedDeclaration pos com d' : rest') - desugarTypeDeclarations (TypeDeclaration name' ty : d : rest) = do + desugarTypeDeclarations (TypeDeclaration sa name' ty : d : rest) = do (_, nameKind, val) <- fromValueDeclaration d - desugarTypeDeclarations (ValueDeclaration name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest) + desugarTypeDeclarations (ValueDeclaration sa name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest) where fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr) - fromValueDeclaration (ValueDeclaration name'' nameKind [] [MkUnguarded val]) + fromValueDeclaration (ValueDeclaration _ name'' nameKind [] [MkUnguarded val]) | name' == name'' = return (name'', nameKind, val) - fromValueDeclaration (PositionedDeclaration pos com d') = do - (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d' - return (ident, nameKind, PositionedValue pos com val) - fromValueDeclaration _ = - throwError . errorMessage $ OrphanTypeDeclaration name' - desugarTypeDeclarations [TypeDeclaration name' _] = - throwError . errorMessage $ OrphanTypeDeclaration name' - desugarTypeDeclarations (ValueDeclaration name' nameKind bs val : rest) = do + fromValueDeclaration d' = + throwError . errorMessage' (declSourceSpan d') $ OrphanTypeDeclaration name' + desugarTypeDeclarations [TypeDeclaration (ss, _) name' _] = + throwError . errorMessage' ss $ OrphanTypeDeclaration name' + desugarTypeDeclarations (ValueDeclaration sa name' nameKind bs val : rest) = do let (_, f, _) = everywhereOnValuesTopDownM return go return f' = mapM (\(GuardedExpr g e) -> GuardedExpr g <$> f e) - (:) <$> (ValueDeclaration name' nameKind bs <$> f' val) + (:) <$> (ValueDeclaration sa name' nameKind bs <$> f' val) <*> desugarTypeDeclarations rest where go (Let ds' val') = Let <$> desugarTypeDeclarations ds' <*> pure val' go other = return other - desugarTypeDeclarations (TypeInstanceDeclaration nm deps cls args (ExplicitInstance ds') : rest) = - (:) <$> (TypeInstanceDeclaration nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds') + desugarTypeDeclarations (TypeInstanceDeclaration sa nm deps cls args (ExplicitInstance ds') : rest) = + (:) <$> (TypeInstanceDeclaration sa nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds') <*> desugarTypeDeclarations rest desugarTypeDeclarations (d:rest) = (:) d <$> desugarTypeDeclarations rest desugarTypeDeclarations [] = return [] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 50cef84404..cdac4bebea 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -22,11 +22,12 @@ import Control.Lens ((^..), _1, _2) import Data.Foldable (for_, traverse_, toList) import Data.List (nubBy, (\\), sort, group) import Data.Maybe +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M import qualified Data.Set as S -import Data.Monoid ((<>)) import qualified Data.Text as T -import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Crash @@ -35,7 +36,6 @@ import Language.PureScript.Errors import Language.PureScript.Kinds import Language.PureScript.Linter import Language.PureScript.Names -import Language.PureScript.Traversals import Language.PureScript.TypeChecker.Kinds as T import Language.PureScript.TypeChecker.Monad as T import Language.PureScript.TypeChecker.Synonyms as T @@ -140,8 +140,7 @@ addTypeClass moduleName pn args implies dependencies ds = do argToIndex :: Text -> Maybe Int argToIndex = flip M.lookup $ M.fromList (zipWith ((,) . fst) args [0..]) - toPair (TypeDeclaration ident ty) = (ident, ty) - toPair (PositionedDeclaration _ _ d) = toPair d + toPair (TypeDeclaration _ ident ty) = (ident, ty) toPair _ = internalError "Invalid declaration in TypeClassDeclaration" -- Currently we are only checking usability based on the type class currently @@ -229,17 +228,18 @@ typeCheckAll typeCheckAll moduleName _ = traverse go where go :: Declaration -> m Declaration - go (DataDeclaration dtype name args dctors) = do - warnAndRethrow (addHint (ErrorInTypeConstructor name)) $ do + go (DataDeclaration sa@(ss, _) dtype name args dctors) = do + warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (PositionedError ss)) $ do when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args ctorKind <- kindsOf True moduleName name args (concatMap snd dctors) let args' = args `withKinds` ctorKind addDataType moduleName dtype name args' dctors ctorKind - return $ DataDeclaration dtype name args dctors + return $ DataDeclaration sa dtype name args dctors go (d@(DataBindingGroupDeclaration tys)) = do - let syns = mapMaybe toTypeSynonym tys - dataDecls = mapMaybe toDataDecl tys + let tysList = NEL.toList tys + syns = mapMaybe toTypeSynonym tysList + dataDecls = mapMaybe toDataDecl tysList bindingGroupNames = ordNub ((syns^..traverse._1) ++ (dataDecls^..traverse._2)) warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames)) $ do (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls) @@ -254,56 +254,53 @@ typeCheckAll moduleName _ = traverse go addTypeSynonym moduleName name args' ty kind return d where - toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty) - toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d' + toTypeSynonym (TypeSynonymDeclaration _ nm args ty) = Just (nm, args, ty) toTypeSynonym _ = Nothing - toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors) - toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d' + toDataDecl (DataDeclaration _ dtype nm args dctors) = Just (dtype, nm, args, dctors) toDataDecl _ = Nothing - go (TypeSynonymDeclaration name args ty) = do - warnAndRethrow (addHint (ErrorInTypeSynonym name)) $ do + go (TypeSynonymDeclaration sa@(ss, _) name args ty) = do + warnAndRethrow (addHint (ErrorInTypeSynonym name) . addHint (PositionedError ss) ) $ do checkDuplicateTypeArguments $ map fst args kind <- kindsOf False moduleName name args [ty] let args' = args `withKinds` kind addTypeSynonym moduleName name args' ty kind - return $ TypeSynonymDeclaration name args ty + return $ TypeSynonymDeclaration sa name args ty go TypeDeclaration{} = internalError "Type declarations should have been removed before typeCheckAlld" - go (ValueDeclaration name nameKind [] [MkUnguarded val]) = do + go (ValueDeclaration sa@(ss, _) name nameKind [] [MkUnguarded val]) = do env <- getEnv - warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do - val' <- checkExhaustiveExpr env moduleName val + warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (PositionedError ss)) $ do + val' <- checkExhaustiveExpr ss env moduleName val valueIsNotDefined moduleName name - [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [(name, val')] + [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] addValue moduleName name ty nameKind - return $ ValueDeclaration name nameKind [] [MkUnguarded val''] + return $ ValueDeclaration sa name nameKind [] [MkUnguarded val''] go ValueDeclaration{} = internalError "Binders were not desugared" go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared" go (BindingGroupDeclaration vals) = do env <- getEnv - warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do - for_ vals $ \(ident, _, _) -> - valueIsNotDefined moduleName ident - vals' <- mapM (thirdM (checkExhaustiveExpr env moduleName)) vals - tys <- typesOf RecursiveBindingGroup moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals' - vals'' <- forM [ (name, val, nameKind, ty) - | (name, nameKind, _) <- vals' - , (name', (val, ty)) <- tys + warnAndRethrow (addHint (ErrorInBindingGroup (fmap (\((_, ident), _, _) -> ident) vals))) $ do + for_ vals $ \((_, ident), _, _) -> valueIsNotDefined moduleName ident + vals' <- NEL.toList <$> traverse (\(sai@((ss, _), _), nk, expr) -> (sai, nk,) <$> checkExhaustiveExpr ss env moduleName expr) vals + tys <- typesOf RecursiveBindingGroup moduleName $ fmap (\(sai, _, ty) -> (sai, ty)) vals' + vals'' <- forM [ (sai, val, nameKind, ty) + | (sai@(_, name), nameKind, _) <- vals' + , ((_, name'), (val, ty)) <- tys , name == name' - ] $ \(name, val, nameKind, ty) -> do + ] $ \(sai@(_, name), val, nameKind, ty) -> do addValue moduleName name ty nameKind - return (name, nameKind, val) - return $ BindingGroupDeclaration vals'' - go (d@(ExternDataDeclaration name kind)) = do + return (sai, nameKind, val) + return . BindingGroupDeclaration $ NEL.fromList vals'' + go (d@(ExternDataDeclaration _ name kind)) = do env <- getEnv putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) } return d - go (d@(ExternKindDeclaration name)) = do + go (d@(ExternKindDeclaration _ name)) = do env <- getEnv putEnv $ env { kinds = S.insert (Qualified (Just moduleName) name) (kinds env) } return d - go (d@(ExternDeclaration name ty)) = do - warnAndRethrow (addHint (ErrorInForeignImport name)) $ do + go (d@(ExternDeclaration (ss, _) name ty)) = do + warnAndRethrow (addHint (ErrorInForeignImport name) . addHint (PositionedError ss)) $ do env <- getEnv kind <- kindOf ty guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType @@ -313,23 +310,22 @@ typeCheckAll moduleName _ = traverse go return d go d@FixityDeclaration{} = return d go d@ImportDeclaration{} = return d - go d@(TypeClassDeclaration pn args implies deps tys) = do + go d@(TypeClassDeclaration _ pn args implies deps tys) = do addTypeClass moduleName pn args implies deps tys return d - go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do - env <- getEnv - case M.lookup className (typeClasses env) of - Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" - Just typeClass -> do - checkInstanceArity dictName className typeClass tys - sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys) - checkOrphanInstance dictName className typeClass tys - _ <- traverseTypeInstanceBody checkInstanceMembers body - let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) - addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict - return d - go (PositionedDeclaration pos com d) = - warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d + go (d@(TypeInstanceDeclaration (ss, _) dictName deps className tys body)) = + rethrow (addHint (ErrorInInstance className tys) . addHint (PositionedError ss)) $ do + env <- getEnv + case M.lookup className (typeClasses env) of + Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" + Just typeClass -> do + checkInstanceArity dictName className typeClass tys + sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys) + checkOrphanInstance dictName className typeClass tys + _ <- traverseTypeInstanceBody checkInstanceMembers body + let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) + addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict + return d checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m () checkInstanceArity dictName className typeClass tys = do @@ -346,8 +342,7 @@ typeCheckAll moduleName _ = traverse go return instDecls where memberName :: Declaration -> Ident - memberName (ValueDeclaration ident _ _ _) = ident - memberName (PositionedDeclaration _ _ d) = memberName d + memberName (ValueDeclaration _ ident _ _ _) = ident memberName _ = internalError "checkInstanceMembers: Invalid declaration in type instance definition" firstDuplicate :: (Eq a) => [a] -> Maybe a @@ -494,11 +489,9 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = unless (null missingMembers) . throwError . errorMessage' ss' $ TransitiveExportError dr members where findClassMembers :: Declaration -> Maybe [Ident] - findClassMembers (TypeClassDeclaration name' _ _ _ ds) | name == name' = Just $ map extractMemberName ds - findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d + findClassMembers (TypeClassDeclaration _ name' _ _ _ ds) | name == name' = Just $ map extractMemberName ds findClassMembers _ = Nothing extractMemberName :: Declaration -> Ident - extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d - extractMemberName (TypeDeclaration memberName _) = memberName + extractMemberName (TypeDeclaration _ memberName _) = memberName extractMemberName _ = internalError "Unexpected declaration in typeclass member list" checkClassMembersAreExported _ = return () diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 1d519ffdca..c3d95f8fda 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -40,9 +40,10 @@ import Data.Functor (($>)) import Data.List (transpose, (\\), partition, delete) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) +import Data.Traversable (for) +import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M import qualified Data.Set as S -import Data.Traversable (for) import Language.PureScript.AST import Language.PureScript.Crash @@ -74,8 +75,8 @@ typesOf :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => BindingGroupType -> ModuleName - -> [(Ident, Expr)] - -> m [(Ident, (Expr, Type))] + -> [((SourceAnn, Ident), Expr)] + -> m [((SourceAnn, Ident), (Expr, Type))] typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do (tys, wInfer) <- capturingSubstitution tidyUp $ do (SplitBindingGroup untyped typed dict, w) <- withoutWarnings $ typeDictionaryForBindingGroup (Just moduleName) vals @@ -83,7 +84,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict return (map (False, ) ds1 ++ map (True, ) ds2, w) - inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do + inferred <- forM tys $ \(shouldGeneralize, ((sai@((ss, _), ident), (val, ty)), _)) -> do -- Replace type class dictionary placeholders with actual dictionaries (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize val -- Generalize and constrain the type @@ -94,12 +95,14 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do when shouldGeneralize $ do -- Show the inferred type in a warning - tell . errorMessage $ MissingTypeDeclaration ident generalized + tell + . errorMessage' ss + $ MissingTypeDeclaration ident generalized -- For non-recursive binding groups, can generalize over constraints. -- For recursive binding groups, we throw an error here for now. when (bindingGroupType == RecursiveBindingGroup && not (null unsolved)) . throwError - . errorMessage + . errorMessage' ss $ CannotGeneralizeRecursiveFunction ident generalized -- Make sure any unsolved type constraints only use type variables which appear -- unknown in the inferred type. @@ -111,22 +114,25 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv) let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies let constraintTypeVars = ordNub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..] - when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ do - throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ AmbiguousTypeVariables generalized con + when (any (`notElem` unsolvedTypeVars) constraintTypeVars) . + throwError + . onErrorMessages (replaceTypes currentSubst) + . errorMessage' ss + $ AmbiguousTypeVariables generalized con -- Check skolem variables did not escape their scope skolemEscapeCheck val' - return ((ident, (foldr (Abs . VarBinder . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved) + return ((sai, (foldr (Abs . VarBinder . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved) -- Show warnings here, since types in wildcards might have been solved during -- instance resolution (by functional dependencies). finalState <- get let replaceTypes' = replaceTypes (checkSubstitution finalState) runTypeSearch' gen = runTypeSearch (guard gen $> foldMap snd inferred) finalState - raisePreviousWarnings gen w = (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceTypes')) w + raisePreviousWarnings gen = (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceTypes')) raisePreviousWarnings False wInfer - forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do + forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> raisePreviousWarnings shouldGeneralize w return (map fst inferred) @@ -172,9 +178,9 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -- -- This structure breaks down a binding group into typed and untyped parts. data SplitBindingGroup = SplitBindingGroup - { _splitBindingGroupUntyped :: [(Ident, (Expr, Type))] + { _splitBindingGroupUntyped :: [((SourceAnn, Ident), (Expr, Type))] -- ^ The untyped expressions - , _splitBindingGroupTyped :: [(Ident, (Expr, Type, Bool))] + , _splitBindingGroupTyped :: [((SourceAnn, Ident), (Expr, Type, Bool))] -- ^ The typed expressions, along with their type annotations , _splitBindingGroupNames :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility) -- ^ A map containing all expressions and their assigned types (which might be @@ -190,46 +196,46 @@ data SplitBindingGroup = SplitBindingGroup typeDictionaryForBindingGroup :: (MonadState CheckState m, MonadWriter MultipleErrors m) => Maybe ModuleName - -> [(Ident, Expr)] + -> [((SourceAnn, Ident), Expr)] -> m SplitBindingGroup typeDictionaryForBindingGroup moduleName vals = do -- Filter the typed and untyped declarations and make a map of names to typed declarations. -- Replace type wildcards here so that the resulting dictionary of types contains the -- fully expanded types. let (untyped, typed) = partitionEithers (map splitTypeAnnotation vals) - (typedDict, typed') <- fmap unzip . for typed $ \(ident, (expr, ty, checkType)) -> do + (typedDict, typed') <- fmap unzip . for typed $ \(sai, (expr, ty, checkType)) -> do ty' <- replaceTypeWildcards ty - return ((ident, ty'), (ident, (expr, ty', checkType))) + return ((sai, ty'), (sai, (expr, ty', checkType))) -- Create fresh unification variables for the types of untyped declarations - (untypedDict, untyped') <- fmap unzip . for untyped $ \(ident, expr) -> do + (untypedDict, untyped') <- fmap unzip . for untyped $ \(sai, expr) -> do ty <- freshType - return ((ident, ty), (ident, (expr, ty))) + return ((sai, ty), (sai, (expr, ty))) -- Create the dictionary of all name/type pairs, which will be added to the -- environment during type checking let dict = M.fromList [ (Qualified moduleName ident, (ty, Private, Undefined)) - | (ident, ty) <- typedDict <> untypedDict + | ((_, ident), ty) <- typedDict <> untypedDict ] return (SplitBindingGroup untyped' typed' dict) where -- | Check if a value contains a type annotation, and if so, separate it -- from the value itself. - splitTypeAnnotation :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool)) - splitTypeAnnotation (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType)) - splitTypeAnnotation (name, PositionedValue pos c value) = + splitTypeAnnotation :: (a, Expr) -> Either (a, Expr) (a, (Expr, Type, Bool)) + splitTypeAnnotation (a, TypedValue checkType value ty) = Right (a, (value, ty, checkType)) + splitTypeAnnotation (a, PositionedValue pos c value) = bimap (second (PositionedValue pos c)) (second (\(e, t, b) -> (PositionedValue pos c e, t, b))) - (splitTypeAnnotation (name, value)) - splitTypeAnnotation (name, value) = Left (name, value) + (splitTypeAnnotation (a, value)) + splitTypeAnnotation (a, value) = Left (a, value) -- | Check the type annotation of a typed value in a binding group. checkTypedBindingGroupElement :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName - -> (Ident, (Expr, Type, Bool)) + -> ((SourceAnn, Ident), (Expr, Type, Bool)) -- ^ The identifier we are trying to define, along with the expression and its type annotation -> M.Map (Qualified Ident) (Type, NameKind, NameVisibility) -- ^ Names brought into scope in this binding group - -> m (Ident, (Expr, Type)) + -> m ((SourceAnn, Ident), (Expr, Type)) checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do -- Kind check (kind, args) <- kindOfWithScopedVars ty @@ -246,12 +252,12 @@ checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do -- | Infer a type for a value in a binding group which lacks an annotation. typeForBindingGroupElement :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => (Ident, (Expr, Type)) + => ((SourceAnn, Ident), (Expr, Type)) -- ^ The identifier we are trying to define, along with the expression and its assigned type -- (at this point, this should be a unification variable) -> M.Map (Qualified Ident) (Type, NameKind, NameVisibility) -- ^ Names brought into scope in this binding group - -> m (Ident, (Expr, Type)) + -> m ((SourceAnn, Ident), (Expr, Type)) typeForBindingGroupElement (ident, (val, ty)) dict = do -- Infer the type with the new names in scope TypedValue _ val' ty' <- bindNames dict $ infer val @@ -420,32 +426,31 @@ inferLetBinding -> (Expr -> m Expr) -> m ([Declaration], Expr) inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) -inferLetBinding seen (ValueDeclaration ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)] : rest) ret j = do - Just moduleName <- checkCurrentModule <$> get - (kind, args) <- kindOfWithScopedVars ty - checkTypeKind ty kind - let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined) - ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty - TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv - bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j -inferLetBinding seen (ValueDeclaration ident nameKind [] [MkUnguarded val] : rest) ret j = do - valTy <- freshType - let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined) - TypedValue _ val' valTy' <- bindNames dict $ infer val - unifyTypes valTy valTy' - bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] [MkUnguarded val']]) rest ret j +inferLetBinding seen (ValueDeclaration sa@(ss, _) ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)] : rest) ret j = + warnAndRethrowWithPositionTC ss $ do + Just moduleName <- checkCurrentModule <$> get + (kind, args) <- kindOfWithScopedVars ty + checkTypeKind ty kind + let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined) + ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty + TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv + bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j +inferLetBinding seen (ValueDeclaration sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = + warnAndRethrowWithPositionTC ss $ do + valTy <- freshType + let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined) + TypedValue _ val' valTy' <- bindNames dict $ infer val + unifyTypes valTy valTy' + bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration sa ident nameKind [] [MkUnguarded val']]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do Just moduleName <- checkCurrentModule <$> get - SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing (map (\(i, _, v) -> (i, v)) ds) + SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict - let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] + let ds' = NEL.fromList [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] bindNames dict $ do makeBindingGroupVisible inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j -inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPositionTC pos $ do - (d' : ds', val') <- inferLetBinding seen (d : ds) ret j - return (PositionedDeclaration pos com d' : ds', val') inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding" -- | Infer the types of variables brought into scope by a binder diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 7937c0f595..90b05fddc0 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -16,55 +16,61 @@ span0 = P.SourceSpan "ModuleLevel" (P.SourcePos 0 0) (P.SourcePos 1 1) span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2) span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3) +ann0, ann1, ann2 :: P.SourceAnn +ann0 = (span0, []) +ann1 = (span1, []) +ann2 = (span2, []) + typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, foreign1, foreign2, foreign3, member1 :: P.Declaration -typeAnnotation1 = P.TypeDeclaration (P.Ident "value1") P.REmpty -value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] [] -synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty -class1 = P.TypeClassDeclaration (P.ProperName "Class1") [] [] [] [] -class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] [] - [P.PositionedDeclaration span2 [] member1] -data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] [] -data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])] +typeAnnotation1 = P.TypeDeclaration ann1 (P.Ident "value1") P.REmpty +value1 = P.ValueDeclaration ann1 (P.Ident "value1") P.Public [] [] +synonym1 = P.TypeSynonymDeclaration ann1 (P.ProperName "Synonym1") [] P.REmpty +class1 = P.TypeClassDeclaration ann1 (P.ProperName "Class1") [] [] [] [] +class2 = P.TypeClassDeclaration ann1 (P.ProperName "Class2") [] [] [] [member1] +data1 = P.DataDeclaration ann1 P.Newtype (P.ProperName "Data1") [] [] +data2 = P.DataDeclaration ann1 P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])] valueFixity = P.ValueFixityDeclaration + ann1 (P.Fixity P.Infix 0) (P.Qualified Nothing (Left (P.Ident ""))) (P.OpName "<$>") typeFixity = P.TypeFixityDeclaration + ann1 (P.Fixity P.Infix 0) (P.Qualified Nothing (P.ProperName "")) (P.OpName "~>") -foreign1 = P.ExternDeclaration (P.Ident "foreign1") P.REmpty -foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.kindType -foreign3 = P.ExternKindDeclaration (P.ProperName "Foreign3") -member1 = P.TypeDeclaration (P.Ident "member1") P.REmpty +foreign1 = P.ExternDeclaration ann1 (P.Ident "foreign1") P.REmpty +foreign2 = P.ExternDataDeclaration ann1 (P.ProperName "Foreign2") P.kindType +foreign3 = P.ExternKindDeclaration ann1 (P.ProperName "Foreign3") +member1 = P.TypeDeclaration ann2 (P.Ident "member1") P.REmpty spec :: Spec spec = do describe "Extracting Spans" $ do it "extracts a span for a value declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(IdeNamespaced IdeNSValue "value1", span1)] + extractSpans value1 `shouldBe` [(IdeNamespaced IdeNSValue "value1", span1)] it "extracts a span for a type synonym declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(IdeNamespaced IdeNSType "Synonym1", span1)] + extractSpans synonym1 `shouldBe` [(IdeNamespaced IdeNSType "Synonym1", span1)] it "extracts a span for a typeclass declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(IdeNamespaced IdeNSType "Class1", span1)] + extractSpans class1 `shouldBe` [(IdeNamespaced IdeNSType "Class1", span1)] it "extracts spans for a typeclass declaration and its members" $ - extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(IdeNamespaced IdeNSType "Class2", span1), (IdeNamespaced IdeNSValue "member1", span2)] + extractSpans class2 `shouldBe` [(IdeNamespaced IdeNSType "Class2", span1), (IdeNamespaced IdeNSValue "member1", span2)] it "extracts a span for a data declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(IdeNamespaced IdeNSType "Data1", span1)] + extractSpans data1 `shouldBe` [(IdeNamespaced IdeNSType "Data1", span1)] it "extracts spans for a data declaration and its constructors" $ - extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(IdeNamespaced IdeNSType "Data2", span1), (IdeNamespaced IdeNSValue "Cons1", span1)] + extractSpans data2 `shouldBe` [(IdeNamespaced IdeNSType "Data2", span1), (IdeNamespaced IdeNSValue "Cons1", span1)] it "extracts a span for a value operator fixity declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] valueFixity) `shouldBe` [(IdeNamespaced IdeNSValue "<$>", span1)] + extractSpans valueFixity `shouldBe` [(IdeNamespaced IdeNSValue "<$>", span1)] it "extracts a span for a type operator fixity declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] typeFixity) `shouldBe` [(IdeNamespaced IdeNSType "~>", span1)] + extractSpans typeFixity `shouldBe` [(IdeNamespaced IdeNSType "~>", span1)] it "extracts a span for a foreign declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(IdeNamespaced IdeNSValue "foreign1", span1)] + extractSpans foreign1 `shouldBe` [(IdeNamespaced IdeNSValue "foreign1", span1)] it "extracts a span for a data foreign declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(IdeNamespaced IdeNSType "Foreign2", span1)] + extractSpans foreign2 `shouldBe` [(IdeNamespaced IdeNSType "Foreign2", span1)] it "extracts a span for a foreign kind declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] foreign3) `shouldBe` [(IdeNamespaced IdeNSKind "Foreign3", span1)] + extractSpans foreign3 `shouldBe` [(IdeNamespaced IdeNSKind "Foreign3", span1)] describe "Type annotations" $ do it "extracts a type annotation" $ extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.REmpty)] From 2cc9037c2ca9482f7f00e54dadc178a78393b10e Mon Sep 17 00:00:00 2001 From: Jens Krause Date: Sat, 17 Jun 2017 16:16:29 +0200 Subject: [PATCH 0802/1580] [purs ide] Add declaration type filter (#2924) (#2934) * [purs ide] Add declaration type filter (#2924) * Fix CI build: Defined but not used declarationtype by removing `makeLenses` of `IdeDeclaration` * Fix CI build: Top-level binding with no type sign. * [purs-ide] Quick fixes as requested by @kRITZCREEK (#2934) --- psc-ide/PROTOCOL.md | 39 +++++++++- purescript.cabal | 1 + src/Language/PureScript/Ide/Filter.hs | 14 ++++ .../PureScript/Ide/Filter/Declaration.hs | 55 +++++++++++++ tests/Language/PureScript/Ide/FilterSpec.hs | 77 ++++++++++++++++++- .../Language/PureScript/Ide/SourceFileSpec.hs | 11 --- tests/Language/PureScript/Ide/Test.hs | 11 +++ 7 files changed, 195 insertions(+), 13 deletions(-) create mode 100644 src/Language/PureScript/Ide/Filter/Declaration.hs diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index eb12cebff7..65629a889d 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -560,6 +560,43 @@ Valid namespaces are `value`, `type` and `kind`. } ``` +### Declaration type filter +A filter which allows to filter type declarations. Valid type declarations are +`value`, `type`, `synonym`, `dataconstructor`, `typeclass`, `valueoperator`, +`typeoperator` and `kind`. + +```json +{ + "filter": "declarations", + "params": [ + { + "declarationtype": "value" + }, + { + "declarationtype": "type" + }, + { + "declarationtype": "synonym" + }, + { + "declarationtype": "dataconstructor" + } + { + "declarationtype": "typeclass" + }, + { + "declarationtype": "valueoperator" + }, + { + "declarationtype": "typeoperator" + }, + { + "declarationtype": "kind" + } + ] +} +``` + ## Matcher: ### Flex matcher @@ -611,7 +648,7 @@ All Responses are wrapped in the following format: Completion options allow to configure the number of returned completion results. -- maxResults :: Maybe Int +- maxResults :: Maybe Int If specified limits the number of completion results, otherwise return all results. diff --git a/purescript.cabal b/purescript.cabal index 159e03cf19..bccc2574f2 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -781,6 +781,7 @@ library Language.PureScript.Ide.Error Language.PureScript.Ide.Externs Language.PureScript.Ide.Filter + Language.PureScript.Ide.Filter.Declaration Language.PureScript.Ide.Imports Language.PureScript.Ide.Logging Language.PureScript.Ide.Matcher diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index ae469d62e0..cdb29f4cbd 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -16,6 +16,7 @@ module Language.PureScript.Ide.Filter ( Filter + , declarationTypeFilter , namespaceFilter , moduleFilter , prefixFilter @@ -28,6 +29,7 @@ import Protolude hiding (isPrefixOf) import Data.Aeson import Data.List.NonEmpty (NonEmpty) import Data.Text (isPrefixOf) +import qualified Language.PureScript.Ide.Filter.Declaration as D import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import qualified Language.PureScript as P @@ -77,6 +79,15 @@ declarationFilter :: (IdeDeclaration -> Text -> Bool) -> Text -> [Module] -> [Mo declarationFilter predicate search = filterModuleDecls (flip predicate search) +-- | Only keeps Identifiers in the given type declarations +declarationTypeFilter :: [D.IdeDeclaration] -> Filter +declarationTypeFilter [] = mkFilter identity +declarationTypeFilter decls = + mkFilter $ filterModuleDecls filterDecls + where + filterDecls :: IdeDeclaration -> Bool + filterDecls decl = D.typeDeclarationForDeclaration decl `elem` decls + filterModuleDecls :: (IdeDeclaration -> Bool) -> [Module] -> [Module] filterModuleDecls predicate = filter (not . null . snd) . fmap filterDecls @@ -109,4 +120,7 @@ instance FromJSON Filter where params <- o .: "params" namespaces <- params .: "namespaces" return $ namespaceFilter namespaces + "declarations" -> do + declarations <- o.: "params" + return $ declarationTypeFilter declarations _ -> mzero diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs new file mode 100644 index 0000000000..f92b51e1be --- /dev/null +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Language.PureScript.Ide.Filter.Declaration + ( IdeDeclaration(..) + , DeclarationType(..) + , typeDeclarationForDeclaration + ) where + +import Protolude hiding (isPrefixOf) + +import Data.Aeson +import qualified Language.PureScript.Ide.Types as PI + +data DeclarationType = Value + | Type + | Synonym + | DataConstructor + | TypeClass + | ValueOperator + | TypeOperator + | Kind + deriving (Show, Eq, Ord) + +instance FromJSON DeclarationType where + parseJSON = withText "Declaration type tag" $ \str -> + case str of + "value" -> pure Value + "type" -> pure Type + "synonym" -> pure Synonym + "dataconstructor" -> pure DataConstructor + "typeclass" -> pure TypeClass + "valueoperator" -> pure ValueOperator + "typeoperator" -> pure TypeOperator + "kind" -> pure Kind + _ -> mzero + +newtype IdeDeclaration = IdeDeclaration + { declarationtype :: DeclarationType + } deriving (Show, Eq, Ord) + +instance FromJSON IdeDeclaration where + parseJSON (Object o) = + IdeDeclaration <$> o .: "declarationtype" + parseJSON _ = mzero + +typeDeclarationForDeclaration :: PI.IdeDeclaration -> IdeDeclaration +typeDeclarationForDeclaration decl = case decl of + PI.IdeDeclValue _ -> IdeDeclaration Value + PI.IdeDeclType _ -> IdeDeclaration Type + PI.IdeDeclTypeSynonym _ -> IdeDeclaration Synonym + PI.IdeDeclDataConstructor _ -> IdeDeclaration DataConstructor + PI.IdeDeclTypeClass _ -> IdeDeclaration TypeClass + PI.IdeDeclValueOperator _ -> IdeDeclaration ValueOperator + PI.IdeDeclTypeOperator _ -> IdeDeclaration TypeOperator + PI.IdeDeclKind _ -> IdeDeclaration Kind diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index 2e1c8f97cd..c975863d9e 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -5,6 +5,7 @@ module Language.PureScript.Ide.FilterSpec where import Protolude import Data.List.NonEmpty import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Filter.Declaration as D import Language.PureScript.Ide.Types import Language.PureScript.Ide.Test as T import qualified Language.PureScript as P @@ -12,11 +13,16 @@ import Test.Hspec type Module = (P.ModuleName, [IdeDeclarationAnn]) -moduleA, moduleB, moduleC, moduleD :: Module +moduleA, moduleB, moduleC, moduleD, moduleE, moduleF, moduleG, moduleH, moduleI :: Module moduleA = (P.moduleNameFromString "Module.A", [T.ideValue "function1" Nothing]) moduleB = (P.moduleNameFromString "Module.B", [T.ideValue "data1" Nothing]) moduleC = (P.moduleNameFromString "Module.C", [T.ideType "List" Nothing]) moduleD = (P.moduleNameFromString "Module.D", [T.ideKind "kind1"]) +moduleE = (P.moduleNameFromString "Module.E", [T.ideSynonym "SFType" Nothing Nothing `annLoc` synonymSS]) +moduleF = (P.moduleNameFromString "Module.F", [T.ideDtor "DtorA" "TypeA" Nothing]) +moduleG = (P.moduleNameFromString "Module.G", [T.ideTypeClass "MyClass" P.kindType []]) +moduleH = (P.moduleNameFromString "Module.H", [T.ideValueOp "<$>" (P.Qualified Nothing (Left "")) 0 Nothing Nothing]) +moduleI = (P.moduleNameFromString "Module.I", [T.ideTypeOp "~>" (P.Qualified Nothing "") 0 Nothing Nothing]) modules :: [Module] modules = [moduleA, moduleB] @@ -33,6 +39,9 @@ runModule ms = applyFilters [moduleFilter ms] modules runNamespace :: NonEmpty IdeNamespace -> [Module] -> [Module] runNamespace namespaces = applyFilters [namespaceFilter namespaces] +runDeclaration :: [D.IdeDeclaration] -> [Module] -> [Module] +runDeclaration decls = applyFilters [declarationTypeFilter decls] + spec :: Spec spec = do describe "equality Filter" $ do @@ -91,3 +100,69 @@ spec = do runNamespace (fromList [ IdeNSValue, IdeNSType, IdeNSKind]) [moduleA, moduleB, moduleC, moduleD] `shouldBe` [moduleA, moduleB, moduleC, moduleD] + describe "declarationTypeFilter" $ do + let moduleADecl = D.IdeDeclaration D.Value + moduleCDecl = D.IdeDeclaration D.Type + moduleDDecl = D.IdeDeclaration D.Kind + moduleEDecl = D.IdeDeclaration D.Synonym + moduleFDecl = D.IdeDeclaration D.DataConstructor + moduleGDecl = D.IdeDeclaration D.TypeClass + moduleHDecl = D.IdeDeclaration D.ValueOperator + moduleIDecl = D.IdeDeclaration D.TypeOperator + it "keeps everything on empty list of declarations" $ + runDeclaration [] + [moduleA, moduleB, moduleD] `shouldBe` [moduleA, moduleB, moduleD] + it "extracts modules by filtering `value` declarations" $ + runDeclaration [moduleADecl] + [moduleA, moduleB, moduleD] `shouldBe` [moduleA, moduleB] + it "removes everything if no `value` declarations has been found" $ + runDeclaration [moduleADecl] + [moduleD, moduleG, moduleE, moduleH] `shouldBe` [] + it "extracts module by filtering `type` declarations" $ + runDeclaration [moduleCDecl] + [moduleA, moduleB, moduleC, moduleD, moduleE] `shouldBe` [moduleC] + it "removes everything if a `type` declaration have not been found" $ + runDeclaration [moduleCDecl] + [moduleA, moduleG, moduleE, moduleH] `shouldBe` [] + it "extracts module by filtering `synonym` declarations" $ + runDeclaration [moduleEDecl] + [moduleA, moduleB, moduleD, moduleE] `shouldBe` [moduleE] + it "removes everything if a `synonym` declaration have not been found" $ + runDeclaration [moduleEDecl] + [moduleA, moduleB, moduleC, moduleH] `shouldBe` [] + it "extracts module by filtering `constructor` declarations" $ + runDeclaration [moduleFDecl] + [moduleA, moduleB, moduleC, moduleF] `shouldBe` [moduleF] + it "removes everything if a `constructor` declaration have not been found" $ + runDeclaration [moduleFDecl] + [moduleA, moduleB, moduleC, moduleH] `shouldBe` [] + it "extracts module by filtering `typeclass` declarations" $ + runDeclaration [moduleGDecl] + [moduleA, moduleC, moduleG] `shouldBe` [moduleG] + it "removes everything if a `typeclass` declaration have not been found" $ + runDeclaration [moduleGDecl] + [moduleA, moduleB, moduleC, moduleH] `shouldBe` [] + it "extracts modules by filtering `valueoperator` declarations" $ + runDeclaration [moduleHDecl] + [moduleA, moduleC, moduleG, moduleH, moduleF] `shouldBe` [moduleH] + it "removes everything if a `valueoperator` declaration have not been found" $ + runDeclaration [moduleHDecl] + [moduleA, moduleB, moduleC, moduleD] `shouldBe` [] + it "extracts modules by filtering `typeoperator` declarations" $ + runDeclaration [moduleIDecl] + [moduleA, moduleC, moduleG, moduleI, moduleF] `shouldBe` [moduleI] + it "removes everything if a `typeoperator` declaration have not been found" $ + runDeclaration [moduleIDecl] + [moduleA, moduleD] `shouldBe` [] + it "extracts module by filtering `kind` declarations" $ + runDeclaration [moduleCDecl] + [moduleA, moduleC, moduleG, moduleI, moduleF] `shouldBe` [moduleC] + it "removes everything if a `kind` declaration have not been found" $ + runDeclaration [moduleCDecl] + [moduleA, moduleD] `shouldBe` [] + it "extracts modules by filtering `value` and `synonym` declarations" $ + runDeclaration [moduleADecl, moduleEDecl] + [moduleA, moduleB, moduleD, moduleE] `shouldBe` [moduleA, moduleB, moduleE] + it "extracts modules by filtering `kind`, `synonym` and `valueoperator` declarations" $ + runDeclaration [moduleADecl, moduleDDecl, moduleHDecl] + [moduleA, moduleB, moduleD, moduleG, moduleE, moduleH] `shouldBe` [moduleA, moduleB, moduleD, moduleH] diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 90b05fddc0..3507f773fc 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -115,14 +115,3 @@ getLocation s = do `annLoc` typeOpSS ]) ] - -valueSS, synonymSS, typeSS, classSS, valueOpSS, typeOpSS :: P.SourceSpan -valueSS = ss 3 1 -synonymSS = ss 5 1 -typeSS = ss 7 1 -classSS = ss 8 1 -valueOpSS = ss 12 1 -typeOpSS = ss 13 1 - -ss :: Int -> Int -> P.SourceSpan -ss x y = P.SourceSpan "Test.purs" (P.SourcePos x y) (P.SourcePos x y) diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index 8cb8d3eda9..b74535f3a3 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -98,6 +98,17 @@ ideTypeOp opName ident precedence assoc k = ideKind :: Text -> IdeDeclarationAnn ideKind pn = ida (IdeDeclKind (P.ProperName pn)) +valueSS, synonymSS, typeSS, classSS, valueOpSS, typeOpSS :: P.SourceSpan +valueSS = ss 3 1 +synonymSS = ss 5 1 +typeSS = ss 7 1 +classSS = ss 8 1 +valueOpSS = ss 12 1 +typeOpSS = ss 13 1 + +ss :: Int -> Int -> P.SourceSpan +ss x y = P.SourceSpan "Test.purs" (P.SourcePos x y) (P.SourcePos x y) + mn :: Text -> P.ModuleName mn = P.moduleNameFromString From 0eddb442bfbd8034caccfca2c8ccc401ef37ae02 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sat, 17 Jun 2017 16:25:59 +0200 Subject: [PATCH 0803/1580] [purs ide] Repopulates the rebuild cache when populating volatile state (#2942) Fixes a bug introduced when refactoring the IdeState type. Before this PR the reload after every succesful rebuild would wipe the rebuild cache, and we wouldn't see any module local completions --- src/Language/PureScript/Ide/State.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 86d30faca5..66e1fbd6f5 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -82,7 +82,7 @@ insertModuleSTM ref (fp, module') = getFileState :: Ide m => m IdeFileState getFileState = do st <- ideStateVar <$> ask - fmap ideFileState . liftIO . readTVarIO $ st + ideFileState <$> liftIO (readTVarIO st) -- | STM version of getFileState getFileStateSTM :: TVar IdeState -> STM IdeFileState @@ -93,7 +93,11 @@ getFileStateSTM ref = ideFileState <$> readTVar ref getVolatileState :: Ide m => m IdeVolatileState getVolatileState = do st <- ideStateVar <$> ask - fmap ideVolatileState . liftIO . readTVarIO $ st + liftIO (atomically (getVolatileStateSTM st)) + +-- | STM version of getVolatileState +getVolatileStateSTM :: TVar IdeState -> STM IdeVolatileState +getVolatileStateSTM st = ideVolatileState <$> readTVar st -- | Sets the VolatileState inside Ide's state setVolatileStateSTM :: TVar IdeState -> IdeVolatileState -> STM () @@ -172,6 +176,7 @@ populateVolatileStateSTM -> STM (ModuleMap (ReexportResult [IdeDeclarationAnn])) populateVolatileStateSTM ref = do IdeFileState{fsExterns = externs, fsModules = modules} <- getFileStateSTM ref + rebuildCache <- vsCachedRebuild <$> getVolatileStateSTM ref let asts = map (extractAstInformation . fst) modules let (moduleDeclarations, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs) results = @@ -179,7 +184,7 @@ populateVolatileStateSTM ref = do & resolveInstances externs & resolveOperators & resolveReexports reexportRefs - setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) Nothing) + setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) rebuildCache) pure results resolveLocations From 70a87d4768ea87a1d146fe7fd31b14b453b7cc95 Mon Sep 17 00:00:00 2001 From: Felix Yan Date: Tue, 20 Jun 2017 11:07:51 -0500 Subject: [PATCH 0804/1580] Allow aeson 1.1 (#2873) It seems to work fine here. --- purescript.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index bccc2574f2..974e5a3718 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -662,7 +662,7 @@ flag release library build-depends: - aeson >=1.0 && <1.1 + aeson >=1.0 && <1.2 , aeson-better-errors >=0.8 , ansi-terminal >=0.6.2 && <0.7 , base >=4.8 && <5 @@ -872,7 +872,7 @@ library executable purs build-depends: - aeson >=1.0 && <1.1 + aeson >=1.0 && <1.2 , aeson-better-errors >=0.8 , ansi-terminal >=0.6.2 && <0.7 , base >=4.8 && <5 @@ -961,7 +961,7 @@ executable purs test-suite tests build-depends: - aeson >=1.0 && <1.1 + aeson >=1.0 && <1.2 , aeson-better-errors >=0.8 , ansi-terminal >=0.6.2 && <0.7 , base >=4.8 && <5 From 9a2bb036057a11afe8bde3f26aaa785af720ead2 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 25 Jun 2017 10:53:42 +0200 Subject: [PATCH 0805/1580] [purs ide] Adds declarations for Prim (#2946) * [purs ide] Adds declarations for Prim * don't add imports for Prim * use Prim constant * don't add Prim to the state at all, inject it before completion --- purescript.cabal | 1 + src/Language/PureScript/Ide.hs | 8 ++++++-- src/Language/PureScript/Ide/Prim.hs | 20 ++++++++++++++++++++ 3 files changed, 27 insertions(+), 2 deletions(-) create mode 100644 src/Language/PureScript/Ide/Prim.hs diff --git a/purescript.cabal b/purescript.cabal index 974e5a3718..f927ae5ac8 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -785,6 +785,7 @@ library Language.PureScript.Ide.Imports Language.PureScript.Ide.Logging Language.PureScript.Ide.Matcher + Language.PureScript.Ide.Prim Language.PureScript.Ide.Pursuit Language.PureScript.Ide.Rebuild Language.PureScript.Ide.Reexports diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 7d232e6e15..e26eb9f5d7 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -23,6 +23,7 @@ import Protolude import "monad-logger" Control.Monad.Logger import qualified Language.PureScript as P +import qualified Language.PureScript.Constants as C import qualified Language.PureScript.Ide.CaseSplit as CS import Language.PureScript.Ide.Command import Language.PureScript.Ide.Completion @@ -31,6 +32,7 @@ import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Imports hiding (Import) import Language.PureScript.Ide.Matcher +import Language.PureScript.Ide.Prim import Language.PureScript.Ide.Pursuit import Language.PureScript.Ide.Rebuild import Language.PureScript.Ide.SourceFile @@ -104,13 +106,15 @@ findCompletions -> m Success findCompletions filters matcher currentModule complOptions = do modules <- getAllModules currentModule - pure (CompletionResult (getCompletions filters matcher complOptions modules)) + let insertPrim = (:) (C.Prim, idePrimDeclarations) + pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules))) findType :: Ide m => Text -> [Filter] -> Maybe P.ModuleName -> m Success findType search filters currentModule = do modules <- getAllModules currentModule - pure (CompletionResult (getExactCompletions search filters modules)) + let insertPrim = (:) (C.Prim, idePrimDeclarations) + pure (CompletionResult (getExactCompletions search filters (insertPrim modules))) findPursuitCompletions :: MonadIO m => PursuitQuery -> m Success diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs new file mode 100644 index 0000000000..f65b302a0d --- /dev/null +++ b/src/Language/PureScript/Ide/Prim.hs @@ -0,0 +1,20 @@ +module Language.PureScript.Ide.Prim (idePrimDeclarations) where + +import Protolude +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Language.PureScript as P +import qualified Language.PureScript.Environment as PEnv +import Language.PureScript.Ide.Types + +idePrimDeclarations :: [IdeDeclarationAnn] +idePrimDeclarations = + primTypes <> primKinds <> primClasses + where + primTypes = foreach (Map.toList PEnv.primTypes) $ \(tn, (kind, _)) -> + IdeDeclarationAnn emptyAnn (IdeDeclType (IdeType (P.disqualify tn) kind)) + primKinds = foreach (Set.toList PEnv.primKinds) $ \kn -> + IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) + primClasses = foreach (Map.toList PEnv.primClasses) $ \(cn, _) -> + -- Dummy kind and instances here, but we primarily care about the name completion + IdeDeclarationAnn emptyAnn (IdeDeclTypeClass (IdeTypeClass (P.disqualify cn) P.kindType []) ) From a4df76ef622cb40a6b546a297acb2d939d282c67 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 26 Jun 2017 00:00:40 +0100 Subject: [PATCH 0806/1580] Raise upper bound on aeson in package.yaml (#2953) --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 9a9376f1e1..942f310506 100644 --- a/package.yaml +++ b/package.yaml @@ -32,7 +32,7 @@ extra-source-files: - CONTRIBUTORS.md - CONTRIBUTING.md dependencies: - - aeson >=1.0 && <1.1 + - aeson >=1.0 && <1.2 - aeson-better-errors >=0.8 - ansi-terminal >=0.6.2 && <0.7 - base >=4.8 && <5 From 947c950a58a9949015bdc63f41246578e9696118 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 26 Jun 2017 00:39:30 +0100 Subject: [PATCH 0807/1580] Remove purescript.cabal and add to gitignore (#2952) --- .gitignore | 1 + purescript.cabal | 1051 ---------------------------------------------- 2 files changed, 1 insertion(+), 1051 deletions(-) delete mode 100644 purescript.cabal diff --git a/.gitignore b/.gitignore index 31f2849c06..e9cb747cd0 100644 --- a/.gitignore +++ b/.gitignore @@ -19,3 +19,4 @@ examples/docs/docs/ core-tests/full-core-docs.md .psc-ide-port .psc-package/ +purescript.cabal diff --git a/purescript.cabal b/purescript.cabal deleted file mode 100644 index f927ae5ac8..0000000000 --- a/purescript.cabal +++ /dev/null @@ -1,1051 +0,0 @@ --- This file has been generated from package.yaml by hpack version 0.17.0. --- --- see: https://github.com/sol/hpack - -name: purescript -version: 0.11.5 -cabal-version: >= 1.10 -build-type: Simple -license: BSD3 -license-file: LICENSE -copyright: (c) 2013-17 Phil Freeman, (c) 2014-17 Gary Burgess -maintainer: Phil Freeman -stability: experimental -homepage: http://www.purescript.org/ -bug-reports: https://github.com/purescript/purescript/issues -synopsis: PureScript Programming Language Compiler -description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. -category: Language -author: Phil Freeman , Gary Burgess , Hardy Jones , Harry Garrood , Christoph Hegemann - - -extra-source-files: - app/static/index.html - app/static/index.js - app/static/normalize.css - app/static/pursuit.css - CONTRIBUTING.md - CONTRIBUTORS.md - examples/docs/bower.json - examples/docs/bower_components/purescript-prelude/src/Prelude.purs - examples/docs/resolutions.json - examples/docs/src/Clash.purs - examples/docs/src/Clash1.purs - examples/docs/src/Clash1a.purs - examples/docs/src/Clash2.purs - examples/docs/src/Clash2a.purs - examples/docs/src/ConstrainedArgument.purs - examples/docs/src/Desugar.purs - examples/docs/src/DocComments.purs - examples/docs/src/DuplicateNames.purs - examples/docs/src/Example.purs - examples/docs/src/Example2.purs - examples/docs/src/ExplicitTypeSignatures.purs - examples/docs/src/ImportedTwice.purs - examples/docs/src/ImportedTwiceA.purs - examples/docs/src/ImportedTwiceB.purs - examples/docs/src/MultiVirtual.purs - examples/docs/src/MultiVirtual1.purs - examples/docs/src/MultiVirtual2.purs - examples/docs/src/MultiVirtual3.purs - examples/docs/src/NewOperators.purs - examples/docs/src/NewOperators2.purs - examples/docs/src/NotAllCtors.purs - examples/docs/src/ReExportedTypeClass.purs - examples/docs/src/SolitaryTypeClassMember.purs - examples/docs/src/SomeTypeClass.purs - examples/docs/src/Transitive1.purs - examples/docs/src/Transitive2.purs - examples/docs/src/Transitive3.purs - examples/docs/src/TypeClassWithFunDeps.purs - examples/docs/src/TypeClassWithoutMembers.purs - examples/docs/src/TypeClassWithoutMembersIntermediate.purs - examples/docs/src/TypeLevelString.purs - examples/docs/src/TypeOpAliases.purs - examples/docs/src/UTF8.purs - examples/docs/src/Virtual.purs - examples/failing/1071.purs - examples/failing/1169.purs - examples/failing/1175.purs - examples/failing/1310.purs - examples/failing/1570.purs - examples/failing/1733.purs - examples/failing/1733/Thingy.purs - examples/failing/1825.purs - examples/failing/1881.purs - examples/failing/2128-class.purs - examples/failing/2128-instance.purs - examples/failing/2378.purs - examples/failing/2378/Lib.purs - examples/failing/2379.purs - examples/failing/2379/Lib.purs - examples/failing/2434.purs - examples/failing/2534.purs - examples/failing/2542.purs - examples/failing/2567.purs - examples/failing/2601.purs - examples/failing/2616.purs - examples/failing/2806.purs - examples/failing/2874-forall.purs - examples/failing/2874-forall2.purs - examples/failing/2874-wildcard.purs - examples/failing/365.purs - examples/failing/438.purs - examples/failing/881.purs - examples/failing/AnonArgument1.purs - examples/failing/AnonArgument2.purs - examples/failing/AnonArgument3.purs - examples/failing/ArgLengthMismatch.purs - examples/failing/Arrays.purs - examples/failing/ArrayType.purs - examples/failing/BindInDo-2.purs - examples/failing/BindInDo.purs - examples/failing/CannotDeriveNewtypeForData.purs - examples/failing/CaseBinderLengthsDiffer.purs - examples/failing/CaseDoesNotMatchAllConstructorArgs.purs - examples/failing/ConflictingExports.purs - examples/failing/ConflictingExports/A.purs - examples/failing/ConflictingExports/B.purs - examples/failing/ConflictingImports.purs - examples/failing/ConflictingImports/A.purs - examples/failing/ConflictingImports/B.purs - examples/failing/ConflictingImports2.purs - examples/failing/ConflictingImports2/A.purs - examples/failing/ConflictingImports2/B.purs - examples/failing/ConflictingQualifiedImports.purs - examples/failing/ConflictingQualifiedImports/A.purs - examples/failing/ConflictingQualifiedImports/B.purs - examples/failing/ConflictingQualifiedImports2.purs - examples/failing/ConflictingQualifiedImports2/A.purs - examples/failing/ConflictingQualifiedImports2/B.purs - examples/failing/ConstraintFailure.purs - examples/failing/ConstraintInference.purs - examples/failing/DctorOperatorAliasExport.purs - examples/failing/DeclConflictClassCtor.purs - examples/failing/DeclConflictClassSynonym.purs - examples/failing/DeclConflictClassType.purs - examples/failing/DeclConflictCtorClass.purs - examples/failing/DeclConflictCtorCtor.purs - examples/failing/DeclConflictDuplicateCtor.purs - examples/failing/DeclConflictSynonymClass.purs - examples/failing/DeclConflictSynonymType.purs - examples/failing/DeclConflictTypeClass.purs - examples/failing/DeclConflictTypeSynonym.purs - examples/failing/DeclConflictTypeType.purs - examples/failing/DiffKindsSameName.purs - examples/failing/DiffKindsSameName/LibA.purs - examples/failing/DiffKindsSameName/LibB.purs - examples/failing/Do.purs - examples/failing/DoNotSuggestComposition.purs - examples/failing/DoNotSuggestComposition2.purs - examples/failing/DuplicateDeclarationsInLet.purs - examples/failing/DuplicateModule.purs - examples/failing/DuplicateModule/M1.purs - examples/failing/DuplicateProperties.purs - examples/failing/DuplicateTypeVars.purs - examples/failing/Eff.purs - examples/failing/EmptyCase.purs - examples/failing/EmptyClass.purs - examples/failing/EmptyDo.purs - examples/failing/ExportConflictClass.purs - examples/failing/ExportConflictClass/A.purs - examples/failing/ExportConflictClass/B.purs - examples/failing/ExportConflictCtor.purs - examples/failing/ExportConflictCtor/A.purs - examples/failing/ExportConflictCtor/B.purs - examples/failing/ExportConflictType.purs - examples/failing/ExportConflictType/A.purs - examples/failing/ExportConflictType/B.purs - examples/failing/ExportConflictTypeOp.purs - examples/failing/ExportConflictTypeOp/A.purs - examples/failing/ExportConflictTypeOp/B.purs - examples/failing/ExportConflictValue.purs - examples/failing/ExportConflictValue/A.purs - examples/failing/ExportConflictValue/B.purs - examples/failing/ExportConflictValueOp.purs - examples/failing/ExportConflictValueOp/A.purs - examples/failing/ExportConflictValueOp/B.purs - examples/failing/ExportExplicit.purs - examples/failing/ExportExplicit1.purs - examples/failing/ExportExplicit1/M1.purs - examples/failing/ExportExplicit2.purs - examples/failing/ExportExplicit3.purs - examples/failing/ExportExplicit3/M1.purs - examples/failing/ExtraRecordField.purs - examples/failing/Foldable.purs - examples/failing/Generalization1.purs - examples/failing/Generalization2.purs - examples/failing/ImportExplicit.purs - examples/failing/ImportExplicit/M1.purs - examples/failing/ImportExplicit2.purs - examples/failing/ImportExplicit2/M1.purs - examples/failing/ImportHidingModule.purs - examples/failing/ImportHidingModule/A.purs - examples/failing/ImportHidingModule/B.purs - examples/failing/ImportModule.purs - examples/failing/ImportModule/M2.purs - examples/failing/InfiniteKind.purs - examples/failing/InfiniteType.purs - examples/failing/InstanceExport.purs - examples/failing/InstanceExport/InstanceExport.purs - examples/failing/InstanceSigsBodyIncorrect.purs - examples/failing/InstanceSigsDifferentTypes.purs - examples/failing/InstanceSigsIncorrectType.purs - examples/failing/InstanceSigsOrphanTypeDeclaration.purs - examples/failing/IntOutOfRange.purs - examples/failing/InvalidDerivedInstance.purs - examples/failing/InvalidDerivedInstance2.purs - examples/failing/InvalidOperatorInBinder.purs - examples/failing/KindError.purs - examples/failing/KindStar.purs - examples/failing/LeadingZeros1.purs - examples/failing/LeadingZeros2.purs - examples/failing/Let.purs - examples/failing/LetPatterns1.purs - examples/failing/LetPatterns2.purs - examples/failing/LetPatterns3.purs - examples/failing/LetPatterns4.purs - examples/failing/MissingClassExport.purs - examples/failing/MissingClassMemberExport.purs - examples/failing/MissingRecordField.purs - examples/failing/MPTCs.purs - examples/failing/MultipleErrors.purs - examples/failing/MultipleErrors2.purs - examples/failing/MultipleTypeOpFixities.purs - examples/failing/MultipleValueOpFixities.purs - examples/failing/MutRec.purs - examples/failing/MutRec2.purs - examples/failing/NewtypeInstance.purs - examples/failing/NewtypeInstance2.purs - examples/failing/NewtypeInstance3.purs - examples/failing/NewtypeInstance4.purs - examples/failing/NewtypeInstance5.purs - examples/failing/NewtypeInstance6.purs - examples/failing/NewtypeMultiArgs.purs - examples/failing/NewtypeMultiCtor.purs - examples/failing/NonExhaustivePatGuard.purs - examples/failing/NonWildcardNewtypeInstance.purs - examples/failing/NullaryAbs.purs - examples/failing/Object.purs - examples/failing/OperatorAliasNoExport.purs - examples/failing/OperatorSections.purs - examples/failing/OrphanInstance.purs - examples/failing/OrphanInstance/Class.purs - examples/failing/OrphanInstanceFunDepCycle.purs - examples/failing/OrphanInstanceFunDepCycle/Lib.purs - examples/failing/OrphanInstanceNullary.purs - examples/failing/OrphanInstanceNullary/Lib.purs - examples/failing/OrphanInstanceWithDetermined.purs - examples/failing/OrphanInstanceWithDetermined/Lib.purs - examples/failing/OrphanTypeDecl.purs - examples/failing/OverlappingArguments.purs - examples/failing/OverlappingBinders.purs - examples/failing/OverlappingVars.purs - examples/failing/ProgrammableTypeErrors.purs - examples/failing/ProgrammableTypeErrorsTypeString.purs - examples/failing/Rank2Types.purs - examples/failing/RequiredHiddenType.purs - examples/failing/Reserved.purs - examples/failing/RowConstructors1.purs - examples/failing/RowConstructors2.purs - examples/failing/RowConstructors3.purs - examples/failing/RowInInstanceNotDetermined0.purs - examples/failing/RowInInstanceNotDetermined1.purs - examples/failing/RowInInstanceNotDetermined2.purs - examples/failing/SkolemEscape.purs - examples/failing/SkolemEscape2.purs - examples/failing/SuggestComposition.purs - examples/failing/Superclasses1.purs - examples/failing/Superclasses2.purs - examples/failing/Superclasses3.purs - examples/failing/Superclasses5.purs - examples/failing/TooFewClassInstanceArgs.purs - examples/failing/TopLevelCaseNoArgs.purs - examples/failing/TransitiveDctorExport.purs - examples/failing/TransitiveSynonymExport.purs - examples/failing/TypeClasses2.purs - examples/failing/TypeClassInstances.purs - examples/failing/TypedBinders.purs - examples/failing/TypedBinders2.purs - examples/failing/TypedBinders3.purs - examples/failing/TypedHole.purs - examples/failing/TypeError.purs - examples/failing/TypeOperatorAliasNoExport.purs - examples/failing/TypeSynonyms.purs - examples/failing/TypeSynonyms2.purs - examples/failing/TypeSynonyms3.purs - examples/failing/TypeSynonyms4.purs - examples/failing/TypeSynonyms5.purs - examples/failing/TypeWildcards1.purs - examples/failing/TypeWildcards2.purs - examples/failing/TypeWildcards3.purs - examples/failing/UnderscoreModuleName.purs - examples/failing/UnknownType.purs - examples/failing/UnusableTypeClassMethod.purs - examples/failing/UnusableTypeClassMethodConflictingIdent.purs - examples/failing/UnusableTypeClassMethodSynonym.purs - examples/passing/1110.purs - examples/passing/1185.purs - examples/passing/1335.purs - examples/passing/1570.purs - examples/passing/1664.purs - examples/passing/1697.purs - examples/passing/1807.purs - examples/passing/1881.purs - examples/passing/1991.purs - examples/passing/2018.purs - examples/passing/2018/A.purs - examples/passing/2018/B.purs - examples/passing/2049.purs - examples/passing/2136.purs - examples/passing/2138.purs - examples/passing/2138/Lib.purs - examples/passing/2172.js - examples/passing/2172.purs - examples/passing/2252.purs - examples/passing/2288.purs - examples/passing/2378.purs - examples/passing/2438.purs - examples/passing/2609.purs - examples/passing/2609/Eg.purs - examples/passing/2616.purs - examples/passing/2626.purs - examples/passing/2663.purs - examples/passing/2689.purs - examples/passing/2695.purs - examples/passing/2756.purs - examples/passing/2787.purs - examples/passing/2795.purs - examples/passing/2806.purs - examples/passing/652.purs - examples/passing/810.purs - examples/passing/862.purs - examples/passing/922.purs - examples/passing/Applicative.purs - examples/passing/ArrayType.purs - examples/passing/Auto.purs - examples/passing/AutoPrelude.purs - examples/passing/AutoPrelude2.purs - examples/passing/BindersInFunctions.purs - examples/passing/BindingGroups.purs - examples/passing/BlockString.purs - examples/passing/CaseInDo.purs - examples/passing/CaseInputWildcard.purs - examples/passing/CaseMultipleExpressions.purs - examples/passing/CaseStatement.purs - examples/passing/CheckFunction.purs - examples/passing/CheckSynonymBug.purs - examples/passing/CheckTypeClass.purs - examples/passing/Church.purs - examples/passing/ClassRefSyntax.purs - examples/passing/ClassRefSyntax/Lib.purs - examples/passing/Collatz.purs - examples/passing/Comparisons.purs - examples/passing/Conditional.purs - examples/passing/Console.purs - examples/passing/ConstraintInference.purs - examples/passing/ConstraintParens.purs - examples/passing/ConstraintParsingIssue.purs - examples/passing/ContextSimplification.purs - examples/passing/DataAndType.purs - examples/passing/DctorName.purs - examples/passing/DctorOperatorAlias.purs - examples/passing/DctorOperatorAlias/List.purs - examples/passing/DeepArrayBinder.purs - examples/passing/DeepCase.purs - examples/passing/DeriveNewtype.purs - examples/passing/DeriveWithNestedSynonyms.purs - examples/passing/Deriving.purs - examples/passing/DerivingFunctor.purs - examples/passing/Do.purs - examples/passing/Dollar.purs - examples/passing/DuplicateProperties.purs - examples/passing/Eff.purs - examples/passing/EmptyDataDecls.purs - examples/passing/EmptyRow.purs - examples/passing/EmptyTypeClass.purs - examples/passing/EntailsKindedType.purs - examples/passing/EqOrd.purs - examples/passing/ExplicitImportReExport.purs - examples/passing/ExplicitImportReExport/Bar.purs - examples/passing/ExplicitImportReExport/Foo.purs - examples/passing/ExplicitOperatorSections.purs - examples/passing/ExportedInstanceDeclarations.purs - examples/passing/ExportExplicit.purs - examples/passing/ExportExplicit/M1.purs - examples/passing/ExportExplicit2.purs - examples/passing/ExportExplicit2/M1.purs - examples/passing/ExtendedInfixOperators.purs - examples/passing/Fib.purs - examples/passing/FieldConsPuns.purs - examples/passing/FieldPuns.purs - examples/passing/FinalTagless.purs - examples/passing/ForeignKind.purs - examples/passing/ForeignKind/Lib.purs - examples/passing/FunctionalDependencies.purs - examples/passing/Functions.purs - examples/passing/Functions2.purs - examples/passing/FunctionScope.purs - examples/passing/FunWithFunDeps.js - examples/passing/FunWithFunDeps.purs - examples/passing/Generalization1.purs - examples/passing/GenericsRep.purs - examples/passing/Guards.purs - examples/passing/HasOwnProperty.purs - examples/passing/HoistError.purs - examples/passing/IfThenElseMaybe.purs - examples/passing/IfWildcard.purs - examples/passing/ImplicitEmptyImport.purs - examples/passing/Import.purs - examples/passing/Import/M1.purs - examples/passing/Import/M2.purs - examples/passing/ImportExplicit.purs - examples/passing/ImportExplicit/M1.purs - examples/passing/ImportHiding.purs - examples/passing/ImportQualified.purs - examples/passing/ImportQualified/M1.purs - examples/passing/InferRecFunWithConstrainedArgument.purs - examples/passing/InstanceBeforeClass.purs - examples/passing/InstanceSigs.purs - examples/passing/InstanceSigsGeneral.purs - examples/passing/IntAndChar.purs - examples/passing/iota.purs - examples/passing/JSReserved.purs - examples/passing/KindedType.purs - examples/passing/LargeSumType.purs - examples/passing/Let.purs - examples/passing/Let2.purs - examples/passing/LetInInstance.purs - examples/passing/LetPattern.purs - examples/passing/LiberalTypeSynonyms.purs - examples/passing/Match.purs - examples/passing/Module.purs - examples/passing/Module/M1.purs - examples/passing/Module/M2.purs - examples/passing/ModuleDeps.purs - examples/passing/ModuleDeps/M1.purs - examples/passing/ModuleDeps/M2.purs - examples/passing/ModuleDeps/M3.purs - examples/passing/ModuleExport.purs - examples/passing/ModuleExport/A.purs - examples/passing/ModuleExportDupes.purs - examples/passing/ModuleExportDupes/A.purs - examples/passing/ModuleExportDupes/B.purs - examples/passing/ModuleExportDupes/C.purs - examples/passing/ModuleExportExcluded.purs - examples/passing/ModuleExportExcluded/A.purs - examples/passing/ModuleExportQualified.purs - examples/passing/ModuleExportQualified/A.purs - examples/passing/ModuleExportSelf.purs - examples/passing/ModuleExportSelf/A.purs - examples/passing/Monad.purs - examples/passing/MonadState.purs - examples/passing/MPTCs.purs - examples/passing/MultiArgFunctions.purs - examples/passing/MutRec.purs - examples/passing/MutRec2.purs - examples/passing/MutRec3.purs - examples/passing/NakedConstraint.purs - examples/passing/NamedPatterns.purs - examples/passing/NegativeBinder.purs - examples/passing/NegativeIntInRange.purs - examples/passing/Nested.purs - examples/passing/NestedRecordUpdate.purs - examples/passing/NestedRecordUpdateWildcards.purs - examples/passing/NestedTypeSynonyms.purs - examples/passing/NestedWhere.purs - examples/passing/Newtype.purs - examples/passing/NewtypeClass.purs - examples/passing/NewtypeEff.purs - examples/passing/NewtypeInstance.purs - examples/passing/NewtypeWithRecordUpdate.purs - examples/passing/NonConflictingExports.purs - examples/passing/NonConflictingExports/A.purs - examples/passing/NonOrphanInstanceFunDepExtra.purs - examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs - examples/passing/NonOrphanInstanceMulti.purs - examples/passing/NonOrphanInstanceMulti/Lib.purs - examples/passing/NumberLiterals.purs - examples/passing/ObjectGetter.purs - examples/passing/Objects.purs - examples/passing/ObjectSynonym.purs - examples/passing/ObjectUpdate.purs - examples/passing/ObjectUpdate2.purs - examples/passing/ObjectUpdater.purs - examples/passing/ObjectWildcards.purs - examples/passing/OneConstructor.purs - examples/passing/OperatorAlias.purs - examples/passing/OperatorAliasElsewhere.purs - examples/passing/OperatorAliasElsewhere/Def.purs - examples/passing/OperatorAssociativity.purs - examples/passing/OperatorInlining.purs - examples/passing/Operators.purs - examples/passing/Operators/Other.purs - examples/passing/OperatorSections.purs - examples/passing/OptimizerBug.purs - examples/passing/OptionalQualified.purs - examples/passing/OverlappingInstances.purs - examples/passing/OverlappingInstances2.purs - examples/passing/OverlappingInstances3.purs - examples/passing/ParensInTypedBinder.purs - examples/passing/PartialFunction.purs - examples/passing/Patterns.purs - examples/passing/PendingConflictingImports.purs - examples/passing/PendingConflictingImports/A.purs - examples/passing/PendingConflictingImports/B.purs - examples/passing/PendingConflictingImports2.purs - examples/passing/PendingConflictingImports2/A.purs - examples/passing/Person.purs - examples/passing/PolyLabels.js - examples/passing/PolyLabels.purs - examples/passing/PrimedTypeName.purs - examples/passing/QualifiedNames.purs - examples/passing/QualifiedNames/Either.purs - examples/passing/QualifiedQualifiedImports.purs - examples/passing/Rank2Data.purs - examples/passing/Rank2Object.purs - examples/passing/Rank2Types.purs - examples/passing/Rank2TypeSynonym.purs - examples/passing/RebindableSyntax.purs - examples/passing/Recursion.purs - examples/passing/RedefinedFixity.purs - examples/passing/RedefinedFixity/M1.purs - examples/passing/RedefinedFixity/M2.purs - examples/passing/RedefinedFixity/M3.purs - examples/passing/ReExportQualified.purs - examples/passing/ReExportQualified/A.purs - examples/passing/ReExportQualified/B.purs - examples/passing/ReExportQualified/C.purs - examples/passing/ReservedWords.purs - examples/passing/ResolvableScopeConflict.purs - examples/passing/ResolvableScopeConflict/A.purs - examples/passing/ResolvableScopeConflict/B.purs - examples/passing/ResolvableScopeConflict2.purs - examples/passing/ResolvableScopeConflict2/A.purs - examples/passing/ResolvableScopeConflict3.purs - examples/passing/ResolvableScopeConflict3/A.purs - examples/passing/RowConstructors.purs - examples/passing/RowInInstanceHeadDetermined.purs - examples/passing/RowPolyInstanceContext.purs - examples/passing/RowsInInstanceContext.purs - examples/passing/RowUnion.js - examples/passing/RowUnion.purs - examples/passing/RuntimeScopeIssue.purs - examples/passing/s.purs - examples/passing/ScopedTypeVariables.purs - examples/passing/Sequence.purs - examples/passing/SequenceDesugared.purs - examples/passing/ShadowedModuleName.purs - examples/passing/ShadowedModuleName/Test.purs - examples/passing/ShadowedName.purs - examples/passing/ShadowedRename.purs - examples/passing/ShadowedTCO.purs - examples/passing/ShadowedTCOLet.purs - examples/passing/SignedNumericLiterals.purs - examples/passing/SolvingAppendSymbol.purs - examples/passing/SolvingCompareSymbol.purs - examples/passing/SolvingIsSymbol.purs - examples/passing/SolvingIsSymbol/Lib.purs - examples/passing/Stream.purs - examples/passing/StringEdgeCases.purs - examples/passing/StringEdgeCases/Records.purs - examples/passing/StringEdgeCases/Symbols.purs - examples/passing/StringEscapes.purs - examples/passing/Superclasses1.purs - examples/passing/Superclasses3.purs - examples/passing/TailCall.purs - examples/passing/TCO.purs - examples/passing/TCOCase.purs - examples/passing/Tick.purs - examples/passing/TopLevelCase.purs - examples/passing/TransitiveImport.purs - examples/passing/TransitiveImport/Middle.purs - examples/passing/TransitiveImport/Test.purs - examples/passing/TypeClasses.purs - examples/passing/TypeClassesInOrder.purs - examples/passing/TypeClassesWithOverlappingTypeVariables.purs - examples/passing/TypeClassMemberOrderChange.purs - examples/passing/TypedBinders.purs - examples/passing/TypeDecl.purs - examples/passing/TypedWhere.purs - examples/passing/TypeOperators.purs - examples/passing/TypeOperators/A.purs - examples/passing/TypeSynonymInData.purs - examples/passing/TypeSynonyms.purs - examples/passing/TypeWildcards.purs - examples/passing/TypeWildcardsRecordExtension.purs - examples/passing/TypeWithoutParens.purs - examples/passing/TypeWithoutParens/Lib.purs - examples/passing/UnderscoreIdent.purs - examples/passing/UnicodeIdentifier.purs - examples/passing/UnicodeOperators.purs - examples/passing/UnicodeType.purs - examples/passing/UnifyInTypeInstanceLookup.purs - examples/passing/Unit.purs - examples/passing/UnknownInTypeClassLookup.purs - examples/passing/UntupledConstraints.purs - examples/passing/UsableTypeClassMethods.purs - examples/passing/UTF8Sourcefile.purs - examples/passing/Where.purs - examples/passing/WildcardInInstance.purs - examples/passing/WildcardType.purs - examples/psci/BasicEval.purs - examples/psci/Multiline.purs - examples/warning/2140.purs - examples/warning/2383.purs - examples/warning/2411.purs - examples/warning/2542.purs - examples/warning/CustomWarning.purs - examples/warning/CustomWarning2.purs - examples/warning/CustomWarning3.purs - examples/warning/DuplicateExportRef.purs - examples/warning/DuplicateImport.purs - examples/warning/DuplicateImportRef.purs - examples/warning/DuplicateSelectiveImport.purs - examples/warning/HidingImport.purs - examples/warning/ImplicitImport.purs - examples/warning/ImplicitQualifiedImport.purs - examples/warning/MissingTypeDeclaration.purs - examples/warning/NewtypeInstance.purs - examples/warning/NewtypeInstance2.purs - examples/warning/NewtypeInstance3.purs - examples/warning/NewtypeInstance4.purs - examples/warning/OverlappingInstances.purs - examples/warning/OverlappingPattern.purs - examples/warning/ScopeShadowing.purs - examples/warning/ShadowedBinderPatternGuard.purs - examples/warning/ShadowedNameParens.purs - examples/warning/ShadowedTypeVar.purs - examples/warning/UnnecessaryFFIModule.js - examples/warning/UnnecessaryFFIModule.purs - examples/warning/UnusedDctorExplicitImport.purs - examples/warning/UnusedDctorImportAll.purs - examples/warning/UnusedDctorImportExplicit.purs - examples/warning/UnusedExplicitImport.purs - examples/warning/UnusedExplicitImportTypeOp.purs - examples/warning/UnusedExplicitImportTypeOp/Lib.purs - examples/warning/UnusedExplicitImportValOp.purs - examples/warning/UnusedFFIImplementations.js - examples/warning/UnusedFFIImplementations.purs - examples/warning/UnusedImport.purs - examples/warning/UnusedTypeVar.purs - examples/warning/WildcardInferredType.purs - INSTALL.md - README.md - stack.yaml - tests/support/bower.json - tests/support/package.json - tests/support/prelude-resolutions.json - tests/support/psci/Sample.purs - tests/support/pscide/src/ImportsSpec.purs - tests/support/pscide/src/ImportsSpec1.purs - tests/support/pscide/src/MatcherSpec.purs - tests/support/pscide/src/RebuildSpecDep.purs - tests/support/pscide/src/RebuildSpecSingleModule.fail - tests/support/pscide/src/RebuildSpecSingleModule.purs - tests/support/pscide/src/RebuildSpecWithDeps.purs - tests/support/pscide/src/RebuildSpecWithForeign.js - tests/support/pscide/src/RebuildSpecWithForeign.purs - tests/support/pscide/src/RebuildSpecWithHiddenIdent.purs - tests/support/pscide/src/RebuildSpecWithMissingForeign.fail - tests/support/setup-win.cmd - -source-repository head - type: git - location: https://github.com/purescript/purescript - -flag release - description: Mark this build as a release build: prevents inclusion of extra info e.g. commit SHA in --version output) - - manual: False - default: False - -library - build-depends: - aeson >=1.0 && <1.2 - , aeson-better-errors >=0.8 - , ansi-terminal >=0.6.2 && <0.7 - , base >=4.8 && <5 - , base-compat >=0.6.0 - , blaze-html >=0.8.1 && <0.9 - , bower-json >=1.0.0.1 && <1.1 - , boxes >=0.1.4 && <0.2.0 - , bytestring - , cheapskate >=0.1 && <0.2 - , clock - , containers - , data-ordlist >=0.4.7.0 - , deepseq - , directory >=1.2.3 - , dlist - , edit-distance - , filepath - , fsnotify >=0.2.1 - , Glob >=0.7 && <0.8 - , haskeline >=0.7.0.0 - , http-client >=0.4.30 && <0.6.0 - , http-types - , language-javascript >=0.6.0.9 && <0.7 - , lens ==4.* - , lifted-base >=0.2.3 && <0.2.4 - , monad-control >=1.0.0.0 && <1.1 - , monad-logger >=0.3 && <0.4 - , mtl >=2.1.0 && <2.3.0 - , parallel >=3.2 && <3.3 - , parsec >=3.1.10 - , pattern-arrows >=0.0.2 && <0.1 - , pipes >=4.0.0 && <4.4.0 - , pipes-http - , process >=1.2.0 && <1.5 - , protolude >=0.1.6 - , regex-tdfa - , safe >=0.3.9 && <0.4 - , scientific >=0.3.4.9 && <0.4 - , semigroups >=0.16.2 && <0.19 - , sourcemap >=0.1.6 - , spdx ==0.2.* - , split - , stm >=0.2.4.0 - , stringsearch - , syb - , text - , time - , transformers >=0.3.0 && <0.6 - , transformers-base >=0.4.0 && <0.5 - , transformers-compat >=0.3.0 - , unordered-containers - , utf8-string >=1 && <2 - , vector - exposed-modules: - Control.Monad.Logger - Control.Monad.Supply - Control.Monad.Supply.Class - Language.PureScript - Language.PureScript.AST - Language.PureScript.AST.Binders - Language.PureScript.AST.Declarations - Language.PureScript.AST.Exported - Language.PureScript.AST.Literals - Language.PureScript.AST.Operators - Language.PureScript.AST.SourcePos - Language.PureScript.AST.Traversals - Language.PureScript.Bundle - Language.PureScript.CodeGen - Language.PureScript.CodeGen.JS - Language.PureScript.CodeGen.JS.Common - Language.PureScript.CodeGen.JS.Printer - Language.PureScript.Comments - Language.PureScript.Constants - Language.PureScript.CoreFn - Language.PureScript.CoreFn.Ann - Language.PureScript.CoreFn.Binders - Language.PureScript.CoreFn.Desugar - Language.PureScript.CoreFn.Expr - Language.PureScript.CoreFn.Meta - Language.PureScript.CoreFn.Module - Language.PureScript.CoreFn.ToJSON - Language.PureScript.CoreFn.Traversals - Language.PureScript.CoreImp - Language.PureScript.CoreImp.AST - Language.PureScript.CoreImp.Optimizer - Language.PureScript.CoreImp.Optimizer.Blocks - Language.PureScript.CoreImp.Optimizer.Common - Language.PureScript.CoreImp.Optimizer.Inliner - Language.PureScript.CoreImp.Optimizer.MagicDo - Language.PureScript.CoreImp.Optimizer.TCO - Language.PureScript.CoreImp.Optimizer.Unused - Language.PureScript.Crash - Language.PureScript.Docs - Language.PureScript.Docs.AsHtml - Language.PureScript.Docs.AsMarkdown - Language.PureScript.Docs.Convert - Language.PureScript.Docs.Convert.ReExports - Language.PureScript.Docs.Convert.Single - Language.PureScript.Docs.ParseInPackage - Language.PureScript.Docs.Prim - Language.PureScript.Docs.Render - Language.PureScript.Docs.RenderedCode - Language.PureScript.Docs.RenderedCode.RenderKind - Language.PureScript.Docs.RenderedCode.RenderType - Language.PureScript.Docs.RenderedCode.Types - Language.PureScript.Docs.Types - Language.PureScript.Docs.Utils.MonoidExtras - Language.PureScript.Environment - Language.PureScript.Errors - Language.PureScript.Errors.JSON - Language.PureScript.Externs - Language.PureScript.Ide - Language.PureScript.Ide.CaseSplit - Language.PureScript.Ide.Command - Language.PureScript.Ide.Completion - Language.PureScript.Ide.Error - Language.PureScript.Ide.Externs - Language.PureScript.Ide.Filter - Language.PureScript.Ide.Filter.Declaration - Language.PureScript.Ide.Imports - Language.PureScript.Ide.Logging - Language.PureScript.Ide.Matcher - Language.PureScript.Ide.Prim - Language.PureScript.Ide.Pursuit - Language.PureScript.Ide.Rebuild - Language.PureScript.Ide.Reexports - Language.PureScript.Ide.SourceFile - Language.PureScript.Ide.State - Language.PureScript.Ide.Types - Language.PureScript.Ide.Util - Language.PureScript.Ide.Watcher - Language.PureScript.Interactive - Language.PureScript.Interactive.Completion - Language.PureScript.Interactive.Directive - Language.PureScript.Interactive.IO - Language.PureScript.Interactive.Message - Language.PureScript.Interactive.Module - Language.PureScript.Interactive.Parser - Language.PureScript.Interactive.Printer - Language.PureScript.Interactive.Types - Language.PureScript.Kinds - Language.PureScript.Label - Language.PureScript.Linter - Language.PureScript.Linter.Exhaustive - Language.PureScript.Linter.Imports - Language.PureScript.Make - Language.PureScript.ModuleDependencies - Language.PureScript.Names - Language.PureScript.Options - Language.PureScript.Parser - Language.PureScript.Parser.Common - Language.PureScript.Parser.Declarations - Language.PureScript.Parser.Kinds - Language.PureScript.Parser.Lexer - Language.PureScript.Parser.State - Language.PureScript.Parser.Types - Language.PureScript.Pretty - Language.PureScript.Pretty.Common - Language.PureScript.Pretty.Kinds - Language.PureScript.Pretty.Types - Language.PureScript.Pretty.Values - Language.PureScript.PSString - Language.PureScript.Publish - Language.PureScript.Publish.BoxesHelpers - Language.PureScript.Publish.ErrorsWarnings - Language.PureScript.Publish.Utils - Language.PureScript.Renamer - Language.PureScript.Sugar - Language.PureScript.Sugar.BindingGroups - Language.PureScript.Sugar.CaseDeclarations - Language.PureScript.Sugar.DoNotation - Language.PureScript.Sugar.LetPattern - Language.PureScript.Sugar.Names - Language.PureScript.Sugar.Names.Common - Language.PureScript.Sugar.Names.Env - Language.PureScript.Sugar.Names.Exports - Language.PureScript.Sugar.Names.Imports - Language.PureScript.Sugar.ObjectWildcards - Language.PureScript.Sugar.Operators - Language.PureScript.Sugar.Operators.Binders - Language.PureScript.Sugar.Operators.Common - Language.PureScript.Sugar.Operators.Expr - Language.PureScript.Sugar.Operators.Types - Language.PureScript.Sugar.TypeClasses - Language.PureScript.Sugar.TypeClasses.Deriving - Language.PureScript.Sugar.TypeDeclarations - Language.PureScript.Traversals - Language.PureScript.TypeChecker - Language.PureScript.TypeChecker.Entailment - Language.PureScript.TypeChecker.Kinds - Language.PureScript.TypeChecker.Monad - Language.PureScript.TypeChecker.Skolems - Language.PureScript.TypeChecker.Subsumption - Language.PureScript.TypeChecker.Synonyms - Language.PureScript.TypeChecker.Types - Language.PureScript.TypeChecker.TypeSearch - Language.PureScript.TypeChecker.Unify - Language.PureScript.TypeClassDictionaries - Language.PureScript.Types - System.IO.UTF8 - other-modules: - Paths_purescript - hs-source-dirs: - src - default-extensions: ConstraintKinds DataKinds DeriveFunctor EmptyDataDecls FlexibleContexts KindSignatures LambdaCase MultiParamTypeClasses NoImplicitPrelude PatternGuards PatternSynonyms RankNTypes RecordWildCards OverloadedStrings ScopedTypeVariables TupleSections ViewPatterns - default-language: Haskell2010 - ghc-options: -Wall -O2 - -executable purs - build-depends: - aeson >=1.0 && <1.2 - , aeson-better-errors >=0.8 - , ansi-terminal >=0.6.2 && <0.7 - , base >=4.8 && <5 - , base-compat >=0.6.0 - , blaze-html >=0.8.1 && <0.9 - , bower-json >=1.0.0.1 && <1.1 - , boxes >=0.1.4 && <0.2.0 - , bytestring - , cheapskate >=0.1 && <0.2 - , clock - , containers - , data-ordlist >=0.4.7.0 - , deepseq - , directory >=1.2.3 - , dlist - , edit-distance - , filepath - , fsnotify >=0.2.1 - , Glob >=0.7 && <0.8 - , haskeline >=0.7.0.0 - , http-client >=0.4.30 && <0.6.0 - , http-types - , language-javascript >=0.6.0.9 && <0.7 - , lens ==4.* - , lifted-base >=0.2.3 && <0.2.4 - , monad-control >=1.0.0.0 && <1.1 - , monad-logger >=0.3 && <0.4 - , mtl >=2.1.0 && <2.3.0 - , parallel >=3.2 && <3.3 - , parsec >=3.1.10 - , pattern-arrows >=0.0.2 && <0.1 - , pipes >=4.0.0 && <4.4.0 - , pipes-http - , process >=1.2.0 && <1.5 - , protolude >=0.1.6 - , regex-tdfa - , safe >=0.3.9 && <0.4 - , scientific >=0.3.4.9 && <0.4 - , semigroups >=0.16.2 && <0.19 - , sourcemap >=0.1.6 - , spdx ==0.2.* - , split - , stm >=0.2.4.0 - , stringsearch - , syb - , text - , time - , transformers >=0.3.0 && <0.6 - , transformers-base >=0.4.0 && <0.5 - , transformers-compat >=0.3.0 - , unordered-containers - , utf8-string >=1 && <2 - , vector - , ansi-wl-pprint - , file-embed - , network - , optparse-applicative >=0.13.0 - , purescript - , wai ==3.* - , wai-websockets ==3.* - , warp ==3.* - , websockets >=0.9 && <0.11 - if flag(release) - cpp-options: -DRELEASE - else - build-depends: - gitrev >=1.2.0 && <1.3 - main-is: Main.hs - hs-source-dirs: - app - other-modules: - Command.Bundle - Command.Compile - Command.Docs - Command.Docs.Ctags - Command.Docs.Etags - Command.Docs.Html - Command.Docs.Tags - Command.Hierarchy - Command.Ide - Command.Publish - Command.REPL - Version - default-language: Haskell2010 - ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N - -test-suite tests - build-depends: - aeson >=1.0 && <1.2 - , aeson-better-errors >=0.8 - , ansi-terminal >=0.6.2 && <0.7 - , base >=4.8 && <5 - , base-compat >=0.6.0 - , blaze-html >=0.8.1 && <0.9 - , bower-json >=1.0.0.1 && <1.1 - , boxes >=0.1.4 && <0.2.0 - , bytestring - , cheapskate >=0.1 && <0.2 - , clock - , containers - , data-ordlist >=0.4.7.0 - , deepseq - , directory >=1.2.3 - , dlist - , edit-distance - , filepath - , fsnotify >=0.2.1 - , Glob >=0.7 && <0.8 - , haskeline >=0.7.0.0 - , http-client >=0.4.30 && <0.6.0 - , http-types - , language-javascript >=0.6.0.9 && <0.7 - , lens ==4.* - , lifted-base >=0.2.3 && <0.2.4 - , monad-control >=1.0.0.0 && <1.1 - , monad-logger >=0.3 && <0.4 - , mtl >=2.1.0 && <2.3.0 - , parallel >=3.2 && <3.3 - , parsec >=3.1.10 - , pattern-arrows >=0.0.2 && <0.1 - , pipes >=4.0.0 && <4.4.0 - , pipes-http - , process >=1.2.0 && <1.5 - , protolude >=0.1.6 - , regex-tdfa - , safe >=0.3.9 && <0.4 - , scientific >=0.3.4.9 && <0.4 - , semigroups >=0.16.2 && <0.19 - , sourcemap >=0.1.6 - , spdx ==0.2.* - , split - , stm >=0.2.4.0 - , stringsearch - , syb - , text - , time - , transformers >=0.3.0 && <0.6 - , transformers-base >=0.4.0 && <0.5 - , transformers-compat >=0.3.0 - , unordered-containers - , utf8-string >=1 && <2 - , vector - , purescript - , hspec - , hspec-discover - , HUnit - , silently - ghc-options: -Wall - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Language.PureScript.Ide.CompletionSpec - Language.PureScript.Ide.FilterSpec - Language.PureScript.Ide.ImportsSpec - Language.PureScript.Ide.MatcherSpec - Language.PureScript.Ide.RebuildSpec - Language.PureScript.Ide.ReexportsSpec - Language.PureScript.Ide.SourceFileSpec - Language.PureScript.Ide.StateSpec - Language.PureScript.Ide.Test - PscIdeSpec - TestCompiler - TestDocs - TestPrimDocs - TestPsci - TestPsci.CommandTest - TestPsci.CompletionTest - TestPsci.EvalTest - TestPsci.TestEnv - TestPscIde - TestPscPublish - TestUtils - default-language: Haskell2010 - hs-source-dirs: - tests From 3dca6b7524d86bd9cbcfda9246186b1e730f6fa7 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 26 Jun 2017 00:48:44 +0100 Subject: [PATCH 0808/1580] Allow things to be hidden from Prim (#2951) --- src/Language/PureScript/AST/Declarations.hs | 19 +++++++++++---- src/Language/PureScript/Docs/Convert.hs | 6 +---- src/Language/PureScript/Linter/Imports.hs | 2 +- src/Language/PureScript/Make.hs | 4 ---- src/Language/PureScript/Sugar/Names.hs | 6 ++--- src/Language/PureScript/Sugar/Names/Env.hs | 24 ++----------------- .../PureScript/Sugar/Names/Imports.hs | 2 +- 7 files changed, 23 insertions(+), 40 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 8d8d09f7d1..d897ee0a7c 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -29,6 +29,7 @@ import Language.PureScript.TypeClassDictionaries import Language.PureScript.Comments import Language.PureScript.Environment import qualified Language.PureScript.Bundle as Bundle +import qualified Language.PureScript.Constants as C import qualified Text.Parsec as P @@ -228,14 +229,24 @@ getModuleSourceSpan (Module ss _ _ _ _) = ss -- | -- Add an import declaration for a module if it does not already explicitly import it. -- -addDefaultImport :: ModuleName -> Module -> Module -addDefaultImport toImport m@(Module ss coms mn decls exps) = +addDefaultImport :: Qualified ModuleName -> Module -> Module +addDefaultImport (Qualified toImportAs toImport) m@(Module ss coms mn decls exps) = if isExistingImport `any` decls || mn == toImport then m - else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit Nothing : decls) exps + else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit toImportAs : decls) exps where - isExistingImport (ImportDeclaration _ mn' _ _) | mn' == toImport = True + isExistingImport (ImportDeclaration _ mn' _ as') | mn' == toImport && as' == toImportAs = True isExistingImport _ = False +-- | Adds import declarations to a module for an implicit Prim import and Prim +-- | qualified as Prim, as necessary. +importPrim :: Module -> Module +importPrim = + let + primModName = ModuleName [ProperName C.prim] + in + addDefaultImport (Qualified Nothing primModName) + . addDefaultImport (Qualified (Just primModName) primModName) + -- | -- An item in a list of explicit imports or exports -- diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 8aaf43ce6b..2057a1ecf5 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -20,7 +20,6 @@ import Language.PureScript.Docs.Convert.ReExports (updateReExports) import Language.PureScript.Docs.Convert.Single (convertSingleModule) import Language.PureScript.Docs.Types import qualified Language.PureScript as P -import qualified Language.PureScript.Constants as C import Web.Bower.PackageMeta (PackageName) @@ -87,12 +86,9 @@ convertModulesWithEnv :: m ([Module], P.Env) convertModulesWithEnv withPackage = P.sortModules - >>> fmap (fst >>> map importPrim) + >>> fmap (fst >>> map P.importPrim) >=> convertSorted withPackage -importPrim :: P.Module -> P.Module -importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim]) - -- | -- Convert a sorted list of modules, returning both the list of converted -- modules and the Env produced during desugaring. diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index a00a141f73..bba9e265c5 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -62,7 +62,7 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do -- TODO: this needs some work to be easier to understand - let scope = maybe primImports (\(_, imps', _) -> imps') (M.lookup mn env) + let scope = maybe nullImports (\(_, imps', _) -> imps') (M.lookup mn env) usedImps' = foldr (elaborateUsed scope) usedImps exportedModules numOpenImports = getSum $ foldMap (Sum . countOpenImports) mdecls allowImplicit = numOpenImports == 1 diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 18a7b4fa88..e2f9d46ad0 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -68,7 +68,6 @@ import qualified Language.JavaScript.Parser as JS import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.CodeGen.JS as J import Language.PureScript.CodeGen.JS.Printer -import qualified Language.PureScript.Constants as C import qualified Language.PureScript.CoreFn as CF import qualified Language.PureScript.CoreFn.ToJSON as CFJ import qualified Language.PureScript.CoreImp.AST as Imp @@ -259,9 +258,6 @@ make ma@MakeActions{..} ms = do guard $ T.unpack (efVersion externs) == showVersion Paths.version return externs -importPrim :: Module -> Module -importPrim = addDefaultImport (ModuleName [ProperName C.prim]) - -- | A monad for running make actions newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index ebdb9f07e2..24bbe47442 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -65,9 +65,9 @@ desugarImportsWithEnv externs modules = do externsEnv :: Env -> ExternsFile -> m Env externsEnv env ExternsFile{..} = do let members = Exports{..} - env' = M.insert efModuleName (efSourceSpan, primImports, members) env + env' = M.insert efModuleName (efSourceSpan, nullImports, members) env fromEFImport (ExternsImport mn mt qmn) = (mn, [(efSourceSpan, Just mt, qmn)]) - imps <- foldM (resolveModuleImport env') primImports (map fromEFImport efImports) + imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports) exps <- resolveExports env' efSourceSpan efModuleName imps members efExports return $ M.insert efModuleName (efSourceSpan, imps, exps) env where @@ -103,7 +103,7 @@ desugarImportsWithEnv externs modules = do updateEnv :: ([Module], Env) -> Module -> m ([Module], Env) updateEnv (ms, env) m@(Module ss _ mn _ refs) = do members <- findExportable m - let env' = M.insert mn (ss, primImports, members) env + let env' = M.insert mn (ss, nullImports, members) env (m', imps) <- resolveImports env' m exps <- maybe (return members) (resolveExports env' ss mn imps members) refs return (m' : ms, M.insert mn (ss, imps, exps) env) diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 0ebbcac774..dbb4d3618f 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -2,7 +2,7 @@ module Language.PureScript.Sugar.Names.Env ( ImportRecord(..) , ImportProvenance(..) , Imports(..) - , primImports + , nullImports , Exports(..) , nullExports , Env @@ -114,26 +114,6 @@ data Imports = Imports nullImports :: Imports nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty M.empty --- | --- An 'Imports' value with imports for the `Prim` module. --- -primImports :: Imports -primImports = - nullImports - { importedTypes = M.fromList $ mkEntries `concatMap` M.keys primTypes - , importedTypeClasses = M.fromList $ mkEntries `concatMap` M.keys primClasses - , importedKinds = M.fromList $ mkEntries `concatMap` S.toList primKinds - } - where - mkEntries :: Qualified a -> [(Qualified a, [ImportRecord a])] - mkEntries fullName@(Qualified _ name) = - [ (fullName, [ImportRecord fullName primModuleName Prim]) - , (Qualified Nothing name, [ImportRecord fullName primModuleName Prim]) - ] - -primModuleName :: ModuleName -primModuleName = ModuleName [ProperName "Prim"] - -- | -- The exported declarations from a module. -- @@ -216,7 +196,7 @@ primExports = -- | Environment which only contains the Prim module. primEnv :: Env primEnv = M.singleton - primModuleName + (ModuleName [ProperName "Prim"]) (internalModuleSourceSpan "", nullImports, primExports) -- | diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index f1a247acb4..e7680d104f 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -52,7 +52,7 @@ resolveImports env (Module ss coms currentModule decls exps) = imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports scope = M.insert currentModule [(internalModuleSourceSpan "", Nothing, Nothing)] imports' (Module ss coms currentModule decls exps,) <$> - foldM (resolveModuleImport env) primImports (M.toList scope) + foldM (resolveModuleImport env) nullImports (M.toList scope) -- | Constructs a set of imports for a single module import. resolveModuleImport From b3e470deb302f8f400bbe140e600eba5c9e2c2b5 Mon Sep 17 00:00:00 2001 From: Fredrik Wallberg Date: Tue, 4 Jul 2017 22:20:11 +0200 Subject: [PATCH 0809/1580] Require single-method instance declarations to be indented (#2965) * Require single-method instance declarations to be indented Resolves https://github.com/purescript/purescript/issues/2947 * Add name and licensing notice --- CONTRIBUTORS.md | 1 + examples/failing/2947.purs | 10 ++++++++++ examples/passing/2947.purs | 11 +++++++++++ src/Language/PureScript/Parser/Declarations.hs | 2 +- 4 files changed, 23 insertions(+), 1 deletion(-) create mode 100644 examples/failing/2947.purs create mode 100644 examples/passing/2947.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index e653c77107..2829d4664c 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -82,6 +82,7 @@ If you would prefer to use different terms, please use the section below instead | [@phiggins](https://github.com/phiggins) | Pete Higgins | [MIT license](http://opensource.org/licenses/MIT) | | [@philopon](https://github.com/philopon) | Hirotomo Moriwaki | [MIT license](http://opensource.org/licenses/MIT) | | [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license](http://opensource.org/licenses/MIT) | +| [@quesebifurcan](https://github.com/quesebifurcan) | Fredrik Wallberg | [MIT license](http://opensource.org/licenses/MIT) | | [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) | | [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license](http://opensource.org/licenses/MIT) | | [@RossMeikleham](https://github.com/RossMeikleham) | Ross Meikleham | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/examples/failing/2947.purs b/examples/failing/2947.purs new file mode 100644 index 0000000000..c0f191b5bd --- /dev/null +++ b/examples/failing/2947.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith ErrorParsingModule + +module Main where + +import Prelude + +data Foo = Foo + +instance eqFoo :: Eq Foo where +eq _ _ = true diff --git a/examples/passing/2947.purs b/examples/passing/2947.purs new file mode 100644 index 0000000000..fbc1b201fb --- /dev/null +++ b/examples/passing/2947.purs @@ -0,0 +1,11 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +data Foo = Foo + +instance eqFoo :: Eq Foo where + eq _ _ = true + +main = log "Done" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 1dbb9d5d4c..420c1557e6 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -227,7 +227,7 @@ parseTypeInstanceDeclaration = do instanceDecl <- parseInstanceDeclaration members <- P.option [] $ do indented *> reserved "where" - mark (P.many (same *> declsInInstance)) + indented *> mark (P.many (same *> declsInInstance)) return $ instanceDecl (ExplicitInstance members) where declsInInstance :: TokenParser Declaration From ee66e0dad5436006e11e749af691ee1072e172c7 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Fri, 7 Jul 2017 18:37:37 +0100 Subject: [PATCH 0810/1580] Replace synonyms in instance constraints (#2973) --- examples/passing/2972.purs | 13 +++++++++++++ src/Language/PureScript/TypeChecker.hs | 3 ++- 2 files changed, 15 insertions(+), 1 deletion(-) create mode 100644 examples/passing/2972.purs diff --git a/examples/passing/2972.purs b/examples/passing/2972.purs new file mode 100644 index 0000000000..fbf961e5d6 --- /dev/null +++ b/examples/passing/2972.purs @@ -0,0 +1,13 @@ +module Main where + +import Control.Monad.Eff.Console (log) +import Prelude (class Show, show) + +type I t = t + +newtype Id t = Id t + +instance foo :: Show (I t) => Show (Id t) where + show (Id t) = "Done" + +main = log (show (Id "other")) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index cdac4bebea..819328f99a 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -323,7 +323,8 @@ typeCheckAll moduleName _ = traverse go sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys) checkOrphanInstance dictName className typeClass tys _ <- traverseTypeInstanceBody checkInstanceMembers body - let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) + deps' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps + let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps') addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict return d From c965f35d462be4041c38c13b6badef6edabf4682 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 9 Jul 2017 04:42:25 +0200 Subject: [PATCH 0811/1580] [purs ide] Collect data constructors (#2976) * remove template haskell and formatting * formatting * collect data constructors for each type --- src/Language/PureScript/Ide.hs | 11 ++-- src/Language/PureScript/Ide/Externs.hs | 62 +++++++++++-------- src/Language/PureScript/Ide/Prim.hs | 2 +- src/Language/PureScript/Ide/State.hs | 24 ++++++- src/Language/PureScript/Ide/Types.hs | 1 + .../Language/PureScript/Ide/CompletionSpec.hs | 2 +- tests/Language/PureScript/Ide/FilterSpec.hs | 2 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 4 +- .../Language/PureScript/Ide/ReexportsSpec.hs | 2 +- .../Language/PureScript/Ide/SourceFileSpec.hs | 2 +- tests/Language/PureScript/Ide/StateSpec.hs | 32 +++++----- tests/Language/PureScript/Ide/Test.hs | 5 +- 12 files changed, 95 insertions(+), 54 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index e26eb9f5d7..c566fa5b34 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -12,8 +12,7 @@ -- Interface for the psc-ide-server ----------------------------------------------------------------------------- -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PackageImports #-} module Language.PureScript.Ide ( handleCommand @@ -45,8 +44,10 @@ import System.FilePath.Glob (glob) -- | Accepts a Commmand and runs it against psc-ide's State. This is the main -- entry point for the server. -handleCommand :: (Ide m, MonadLogger m, MonadError IdeError m) => - Command -> m Success +handleCommand + :: (Ide m, MonadLogger m, MonadError IdeError m) + => Command + -> m Success handleCommand c = case c of Load [] -> findAvailableExterns >>= loadModulesAsync @@ -222,7 +223,7 @@ loadModules moduleNames = do (failures, allModules) <- partitionEithers <$> (parseModulesFromFiles =<< findAllSourceFiles) unless (null failures) $ - $(logWarn) ("Failed to parse: " <> show failures) + logWarnN ("Failed to parse: " <> show failures) traverse_ insertModule allModules pure (TextResult ("Loaded " <> show (length efiles) <> " modules and " diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 62348c37ce..0e9e17f694 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -31,8 +31,10 @@ import Language.PureScript.Ide.Types import qualified Language.PureScript as P -readExternFile :: (MonadIO m, MonadError IdeError m, MonadLogger m) => - FilePath -> m P.ExternsFile +readExternFile + :: (MonadIO m, MonadError IdeError m, MonadLogger m) + => FilePath + -> m P.ExternsFile readExternFile fp = do parseResult <- liftIO (decodeStrict <$> BS.readFile fp) case parseResult of @@ -57,7 +59,7 @@ convertExterns ef = where decls = map (IdeDeclarationAnn emptyAnn) - (resolvedDeclarations ++ operatorDecls ++ tyOperatorDecls) + (resolvedDeclarations <> operatorDecls <> tyOperatorDecls) exportDecls = mapMaybe convertExport (P.efExports ef) operatorDecls = convertOperator <$> P.efFixities ef tyOperatorDecls = convertTypeOperator <$> P.efTypeFixities ef @@ -117,31 +119,41 @@ convertExport (P.ReExportRef _ m r) = Just (m, r) convertExport _ = Nothing convertDecl :: P.ExternsDeclaration -> Either ToResolve (Maybe IdeDeclaration) -convertDecl P.EDType{..} = Right $ Just $ IdeDeclType $ - IdeType edTypeName edTypeKind -convertDecl P.EDTypeSynonym{..} = Left (SynonymToResolve edTypeSynonymName edTypeSynonymType) -convertDecl P.EDDataConstructor{..} = Right $ Just $ IdeDeclDataConstructor $ - IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType -convertDecl P.EDValue{..} = Right $ Just $ IdeDeclValue $ - IdeValue edValueName edValueType -convertDecl P.EDClass{..} = Left (TypeClassToResolve edClassName) -convertDecl P.EDKind{..} = Right (Just (IdeDeclKind edKindName)) -convertDecl P.EDInstance{} = Right Nothing +convertDecl ed = case ed of + P.EDType{..} -> + Right (Just (IdeDeclType (IdeType edTypeName edTypeKind []))) + P.EDTypeSynonym{..} -> + Left (SynonymToResolve edTypeSynonymName edTypeSynonymType) + P.EDDataConstructor{..} -> + Right + (Just + (IdeDeclDataConstructor + (IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType))) + P.EDValue{..} -> + Right (Just (IdeDeclValue (IdeValue edValueName edValueType))) + P.EDClass{..} -> + Left (TypeClassToResolve edClassName) + P.EDKind{..} -> + Right (Just (IdeDeclKind edKindName)) + P.EDInstance{} -> + Right Nothing convertOperator :: P.ExternsFixity -> IdeDeclaration convertOperator P.ExternsFixity{..} = - IdeDeclValueOperator $ IdeValueOperator - efOperator - efAlias - efPrecedence - efAssociativity - Nothing + IdeDeclValueOperator + (IdeValueOperator + efOperator + efAlias + efPrecedence + efAssociativity + Nothing) convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration convertTypeOperator P.ExternsTypeFixity{..} = - IdeDeclTypeOperator $ IdeTypeOperator - efTypeOperator - efTypeAlias - efTypePrecedence - efTypeAssociativity - Nothing + IdeDeclTypeOperator + (IdeTypeOperator + efTypeOperator + efTypeAlias + efTypePrecedence + efTypeAssociativity + Nothing) diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index f65b302a0d..5519ad9114 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -12,7 +12,7 @@ idePrimDeclarations = primTypes <> primKinds <> primClasses where primTypes = foreach (Map.toList PEnv.primTypes) $ \(tn, (kind, _)) -> - IdeDeclarationAnn emptyAnn (IdeDeclType (IdeType (P.disqualify tn) kind)) + IdeDeclarationAnn emptyAnn (IdeDeclType (IdeType (P.disqualify tn) kind [])) primKinds = foreach (Set.toList PEnv.primKinds) $ \kn -> IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) primClasses = foreach (Map.toList PEnv.primClasses) $ \(cn, _) -> diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 66e1fbd6f5..81c290c1c4 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -30,6 +30,7 @@ module Language.PureScript.Ide.State -- for tests , resolveOperatorsForModule , resolveInstances + , resolveDataConstructorsForModule ) where import Protolude @@ -180,7 +181,9 @@ populateVolatileStateSTM ref = do let asts = map (extractAstInformation . fst) modules let (moduleDeclarations, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs) results = - resolveLocations asts moduleDeclarations + moduleDeclarations + & map resolveDataConstructorsForModule + & resolveLocations asts & resolveInstances externs & resolveOperators & resolveReexports reexportRefs @@ -311,3 +314,22 @@ resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) mapIf :: Functor f => (b -> Bool) -> (b -> b) -> f b -> f b mapIf p f = map (\x -> if p x then f x else x) + +resolveDataConstructorsForModule + :: [IdeDeclarationAnn] + -> [IdeDeclarationAnn] +resolveDataConstructorsForModule decls = + map (idaDeclaration %~ resolveDataConstructors) decls + where + resolveDataConstructors :: IdeDeclaration -> IdeDeclaration + resolveDataConstructors decl = case decl of + IdeDeclType ty -> + IdeDeclType (ty & ideTypeDtors .~ fromMaybe [] (Map.lookup (ty^.ideTypeName) dtors)) + _ -> + decl + + dtors = + decls + & mapMaybe (preview (idaDeclaration._IdeDeclDataConstructor)) + & foldr (\(IdeDataConstructor name typeName type') -> + Map.insertWith (<>) typeName [(name, type')]) Map.empty diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 07de305e4a..c951e49c2b 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -48,6 +48,7 @@ data IdeValue = IdeValue data IdeType = IdeType { _ideTypeName :: P.ProperName 'P.TypeName , _ideTypeKind :: P.Kind + , _ideTypeDtors :: [(P.ProperName 'P.ConstructorName, P.Type)] } deriving (Show, Eq, Ord) data IdeTypeSynonym = IdeTypeSynonym diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs index 623a58e6e5..255d6974c6 100644 --- a/tests/Language/PureScript/Ide/CompletionSpec.hs +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -19,7 +19,7 @@ reexportMatches = moduleB = [ideKind "Kind" `annExp` "A"] matches :: [(Match IdeDeclarationAnn, [P.ModuleName])] -matches = map (\d -> (Match (mn "Main", d), [mn "Main"])) [ ideKind "Kind", ideType "Type" Nothing ] +matches = map (\d -> (Match (mn "Main", d), [mn "Main"])) [ ideKind "Kind", ideType "Type" Nothing [] ] spec :: Spec spec = describe "Applying completion options" $ do diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index c975863d9e..ed0e376b60 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -16,7 +16,7 @@ type Module = (P.ModuleName, [IdeDeclarationAnn]) moduleA, moduleB, moduleC, moduleD, moduleE, moduleF, moduleG, moduleH, moduleI :: Module moduleA = (P.moduleNameFromString "Module.A", [T.ideValue "function1" Nothing]) moduleB = (P.moduleNameFromString "Module.B", [T.ideValue "data1" Nothing]) -moduleC = (P.moduleNameFromString "Module.C", [T.ideType "List" Nothing]) +moduleC = (P.moduleNameFromString "Module.C", [T.ideType "List" Nothing []]) moduleD = (P.moduleNameFromString "Module.D", [T.ideKind "kind1"]) moduleE = (P.moduleNameFromString "Module.E", [T.ideSynonym "SFType" Nothing Nothing `annLoc` synonymSS]) moduleF = (P.moduleNameFromString "Module.F", [T.ideDtor "DtorA" "TypeA" Nothing]) diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 908531b995..e95309f2c3 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -107,7 +107,7 @@ spec = do addDtorImport i t mn is = prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideDtor i t Nothing)) mn is) addTypeImport i mn is = - prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideType i Nothing)) mn is) + prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideType i Nothing [])) mn is) addKindImport i mn is = prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideKind i)) mn is) it "adds an implicit unqualified import to a file without any imports" $ @@ -208,7 +208,7 @@ spec = do moduleName = (P.moduleNameFromString "Control.Monad") addImport imports import' = addExplicitImport' import' moduleName imports valueImport ident = _idaDeclaration (Test.ideValue ident Nothing) - typeImport name = _idaDeclaration (Test.ideType name Nothing) + typeImport name = _idaDeclaration (Test.ideType name Nothing []) classImport name = _idaDeclaration (Test.ideTypeClass name P.kindType []) dtorImport name typeName = _idaDeclaration (Test.ideDtor name typeName Nothing) -- expect any list of provided identifiers, when imported, to come out as specified diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index cba4690a4b..731672a58c 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -13,7 +13,7 @@ import Test.Hspec valueA, typeA, synonymA, classA, dtorA1, dtorA2, kindA :: IdeDeclarationAnn valueA = ideValue "valueA" Nothing -typeA = ideType "TypeA" Nothing +typeA = ideType "TypeA" Nothing [] synonymA = ideSynonym "SynonymA" Nothing Nothing classA = ideTypeClass "ClassA" P.kindType [] dtorA1 = ideDtor "DtorA1" "TypeA" Nothing diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 3507f773fc..1bf01f470a 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -104,7 +104,7 @@ getLocation s = do [ ("Test", [ ideValue "sfValue" Nothing `annLoc` valueSS , ideSynonym "SFType" Nothing Nothing `annLoc` synonymSS - , ideType "SFData" Nothing `annLoc` typeSS + , ideType "SFData" Nothing [] `annLoc` typeSS , ideDtor "SFOne" "SFData" Nothing `annLoc` typeSS , ideDtor "SFTwo" "SFData" Nothing `annLoc` typeSS , ideDtor "SFThree" "SFData" Nothing `annLoc` typeSS diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index 78f8cea7b0..0a313319b9 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -13,27 +13,26 @@ import qualified Data.Map as Map valueOperator :: Maybe P.Type -> IdeDeclarationAnn valueOperator = - d . IdeDeclValueOperator . IdeValueOperator (P.OpName "<$>") (P.Qualified (Just (mn "Test")) (Left (P.Ident "function"))) 2 P.Infix + ideValueOp "<$>" (P.Qualified (Just (mn "Test")) (Left "function")) 2 Nothing ctorOperator :: Maybe P.Type -> IdeDeclarationAnn ctorOperator = - d . IdeDeclValueOperator . IdeValueOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (Right (P.ProperName "Cons"))) 2 P.Infix + ideValueOp ":" (P.Qualified (Just (mn "Test")) (Right "Cons")) 2 Nothing typeOperator :: Maybe P.Kind -> IdeDeclarationAnn typeOperator = - d . IdeDeclTypeOperator . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix + ideTypeOp ":" (P.Qualified (Just (mn "Test")) "List") 2 Nothing testModule :: (P.ModuleName, [IdeDeclarationAnn]) -testModule = (mn "Test", [ d (IdeDeclValue (IdeValue (P.Ident "function") P.REmpty)) - , d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty))) - , d (IdeDeclType (IdeType (P.ProperName "List") P.kindType)) - , valueOperator Nothing - , ctorOperator Nothing - , typeOperator Nothing - ]) - -d :: IdeDeclaration -> IdeDeclarationAnn -d = IdeDeclarationAnn emptyAnn +testModule = + (mn "Test", + [ ideValue "function" (Just P.REmpty) + , ideDtor "Cons" "List" (Just P.tyString) + , ideType "List" Nothing [] + , valueOperator Nothing + , ctorOperator Nothing + , typeOperator Nothing + ]) testState :: ModuleMap [IdeDeclarationAnn] testState = Map.fromList [testModule] @@ -81,7 +80,7 @@ spec = do it "resolves the type for a value operator" $ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (valueOperator (Just P.REmpty)) it "resolves the type for a constructor operator" $ - resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.REmpty)) + resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.tyString)) it "resolves the kind for a type operator" $ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.kindType)) describe "resolving instances for type classes" $ do @@ -89,3 +88,8 @@ spec = do resolveInstances (Map.singleton (mn "InstanceModule") ef) moduleMap `shouldSatisfy` elemOf (ix (mn "ClassModule") . ix 0 . idaDeclaration . _IdeDeclTypeClass . ideTCInstances . folded) ideInstance + describe "resolving data constructors" $ do + it "resolves a constructor" $ do + resolveDataConstructorsForModule (snd testModule) + `shouldSatisfy` + elem (ideType "List" Nothing [(P.ProperName "Cons", P.tyString)]) diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index b74535f3a3..dd48b8f85f 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE DataKinds #-} module Language.PureScript.Ide.Test where import Control.Concurrent.STM @@ -63,8 +64,8 @@ ida = IdeDeclarationAnn emptyAnn ideValue :: Text -> Maybe P.Type -> IdeDeclarationAnn ideValue i ty = ida (IdeDeclValue (IdeValue (P.Ident i) (fromMaybe P.tyString ty))) -ideType :: Text -> Maybe P.Kind -> IdeDeclarationAnn -ideType pn ki = ida (IdeDeclType (IdeType (P.ProperName pn) (fromMaybe P.kindType ki))) +ideType :: Text -> Maybe P.Kind -> [(P.ProperName 'P.ConstructorName, P.Type)] -> IdeDeclarationAnn +ideType pn ki dtors = ida (IdeDeclType (IdeType (P.ProperName pn) (fromMaybe P.kindType ki) dtors)) ideSynonym :: Text -> Maybe P.Type -> Maybe P.Kind -> IdeDeclarationAnn ideSynonym pn ty kind = ida (IdeDeclTypeSynonym (IdeTypeSynonym (P.ProperName pn) (fromMaybe P.tyString ty) (fromMaybe P.kindType kind))) From 50e1c68d9e8d21fa39ed2c95277f8002003df1f9 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 9 Jul 2017 17:04:01 +0100 Subject: [PATCH 0812/1580] Re-evaluate REPL globs during :reload (#2978) Fixes #2977 --- app/Command/REPL.hs | 6 +++--- src/Language/PureScript/Interactive.hs | 4 +++- src/Language/PureScript/Interactive/Types.hs | 2 +- 3 files changed, 7 insertions(+), 5 deletions(-) diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 9b8ad1269e..1b8199495d 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -57,7 +57,7 @@ import qualified Data.ByteString.Lazy.UTF8 as U -- | Command line options data PSCiOptions = PSCiOptions - { psciInputFile :: [FilePath] + { psciInputGlob :: [String] , psciBackend :: Backend } @@ -310,7 +310,7 @@ command = loop <$> options where loop :: PSCiOptions -> IO () loop PSCiOptions{..} = do - inputFiles <- concat <$> traverse glob psciInputFile + inputFiles <- concat <$> traverse glob psciInputGlob e <- runExceptT $ do modules <- ExceptT (loadAllModules inputFiles) when (null modules) . liftIO $ do @@ -331,7 +331,7 @@ command = loop <$> options historyFilename <- getHistoryFilename let settings = defaultSettings { historyFile = Just historyFilename } initialState = PSCiState [] [] (zip (map snd modules) externs) - config = PSCiConfig inputFiles env + config = PSCiConfig psciInputGlob env runner = flip runReaderT config . flip evalStateT initialState . runInputT (setComplete completion settings) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 4dcccc3d55..ac247353ca 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -40,6 +40,7 @@ import Language.PureScript.Interactive.Types as Interactive import System.Directory (getCurrentDirectory) import System.FilePath (()) +import System.FilePath.Glob (glob) -- | Pretty-print errors printErrors :: MonadIO m => P.MultipleErrors -> m () @@ -118,7 +119,8 @@ handleReloadState -> m () handleReloadState reload = do modify $ updateLets (const []) - files <- asks psciLoadedFiles + globs <- asks psciFileGlobs + files <- liftIO $ concat <$> traverse glob globs e <- runExceptT $ do modules <- ExceptT . liftIO $ loadAllModules files (externs, _) <- ExceptT . liftIO . runMake . make $ modules diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index f54ee375b7..3ab26a61cb 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -12,7 +12,7 @@ import qualified Language.PureScript as P -- These configuration values do not change during execution. -- data PSCiConfig = PSCiConfig - { psciLoadedFiles :: [FilePath] + { psciFileGlobs :: [String] , psciEnvironment :: P.Environment } deriving Show From 5fe26f28e1b69eb33dfccb8440732ead15f9f477 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 9 Jul 2017 18:09:03 +0100 Subject: [PATCH 0813/1580] Fix links to type operators in HTML docs (#2979) Fixes https://github.com/purescript/pursuit/issues/312 Unfortunately this is difficult to test with the way the tests are set up right now, so I have omitted tests. --- src/Language/PureScript/Docs/AsHtml.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index c3eec5bd36..cc1568d35f 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -184,8 +184,9 @@ codeAsHtml r = outputWith elemAsHtml Link mn -> let class_ = if startsWithUpper name then "ctor" else "ident" + target = if ns == TypeLevel then "type (" <> name <> ")" else name in - linkToDecl ns name mn (withClass class_ (text name)) + linkToDecl ns target mn (withClass class_ (text name)) NoLink -> text name From 0e2d8206bd05a5e6094f9ff9cc89fbc1968574bc Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sun, 9 Jul 2017 21:18:40 +0100 Subject: [PATCH 0814/1580] Solve RowToList (#2945) --- src/Language/PureScript/Constants.hs | 14 +++++++++ .../PureScript/TypeChecker/Entailment.hs | 31 +++++++++++++------ 2 files changed, 36 insertions(+), 9 deletions(-) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 0f2fd0050e..73341f80c4 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -359,6 +359,20 @@ orderingEQ = Qualified (Just typeDataOrdering) (ProperName "EQ") orderingGT :: Qualified (ProperName 'TypeName) orderingGT = Qualified (Just typeDataOrdering) (ProperName "GT") +-- Type.Row + +pattern TypeRow :: ModuleName +pattern TypeRow = ModuleName [ProperName "Type", ProperName "Row"] + +pattern RowToList :: Qualified (ProperName 'ClassName) +pattern RowToList = Qualified (Just TypeRow) (ProperName "RowToList") + +pattern RowListNil :: Qualified (ProperName 'TypeName) +pattern RowListNil = Qualified (Just TypeRow) (ProperName "Nil") + +pattern RowListCons :: Qualified (ProperName 'TypeName) +pattern RowListCons = Qualified (Just TypeRow) (ProperName "Cons") + -- Main module main :: forall a. (IsString a) => a diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index e9f3d84ebd..2ab173496f 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -44,20 +44,17 @@ import qualified Language.PureScript.Constants as C -- | Describes what sort of dictionary to generate for type class instances data Evidence + -- | An existing named instance = NamedInstance (Qualified Ident) - -- ^ An existing named instance - | WarnInstance Type - -- ^ Computed instance of the Warn type class with a user-defined warning message - | IsSymbolInstance PSString - -- ^ Computed instance of the IsSymbol type class for a given Symbol literal + + -- | Computed instances + | WarnInstance Type -- ^ Warn type class with a user-defined warning message + | IsSymbolInstance PSString -- ^ The IsSymbol type class for a given Symbol literal | CompareSymbolInstance - -- ^ Computed instance of CompareSymbol | AppendSymbolInstance - -- ^ Computed instance of AppendSymbol | UnionInstance - -- ^ Computed instance of Union | ConsInstance - -- ^ Computed instance of RowCons + | RowToListInstance deriving (Show, Eq) -- | Extract the identifier of a named instance @@ -173,6 +170,9 @@ entails SolverOptions{..} constraint context hints = = [ TypeClassDictionaryInScope UnionInstance [] C.Union [lOut, rOut, uOut] cst ] forClassName _ C.RowCons [TypeLevelString sym, ty, r, _] = [ TypeClassDictionaryInScope ConsInstance [] C.RowCons [TypeLevelString sym, ty, r, RCons (Label sym) ty r] Nothing ] + forClassName _ C.RowToList [r, _] + | Just entries <- solveRowToList r + = [ TypeClassDictionaryInScope RowToListInstance [] C.RowToList [r, entries] Nothing ] forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) forClassName _ _ _ = internalError "forClassName: expected qualified class name" @@ -333,6 +333,7 @@ entails SolverOptions{..} constraint context hints = return $ App (Abs (VarBinder (Ident C.__unused)) valUndefined) e mkDictionary UnionInstance _ = return valUndefined mkDictionary ConsInstance _ = return valUndefined + mkDictionary RowToListInstance _ = return valUndefined mkDictionary (WarnInstance msg) _ = do tell . errorMessage $ UserDefinedWarning msg -- We cannot call the type class constructor here because Warn is declared in Prim. @@ -374,6 +375,18 @@ entails SolverOptions{..} constraint context hints = -- types for such labels. _ -> (not (null fixed), (fixed, rowVar), Just [ Constraint C.Union [rest, r, rowVar] Nothing ]) + -- | Convert a closed row to a sorted list of entries + solveRowToList :: Type -> Maybe Type + solveRowToList r = + guard (REmpty == rest) $> + foldr rowListCons (TypeConstructor C.RowListNil) fixed + where + (fixed, rest) = rowToSortedList r + rowListCons (lbl, ty) tl = foldl TypeApp (TypeConstructor C.RowListCons) + [ TypeLevelString (runLabel lbl) + , ty + , tl ] + -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a -- substitution which makes them match. If not, we return 'Nothing'. From ad6166fff797db34387bf09a0bc3ba00030dd473 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 9 Jul 2017 21:51:12 +0100 Subject: [PATCH 0815/1580] Include comments in child declarations in HTML docs (#2981) That is, if doc-comments are provided in a source file for any of the following: - type class members - instance declarations - data constructors they will now be included in the HTML. Fixes https://github.com/purescript/pursuit/issues/159. --- app/static/pursuit.css | 4 ++++ src/Language/PureScript/Docs/AsHtml.hs | 13 +++++++++---- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/app/static/pursuit.css b/app/static/pursuit.css index e0c7f6ec9f..d250c36aff 100644 --- a/app/static/pursuit.css +++ b/app/static/pursuit.css @@ -413,6 +413,10 @@ ol li { .decl__body .syntax { color: #0B71B4; } +.decl__child_comments { + margin-top: 1rem; + margin-bottom: 1rem; +} /* Component: Dependency Link * -------------------------------------------------------------------------- */ .deplink { diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index cc1568d35f..bf1c7932c1 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -163,11 +163,16 @@ declAsHtml r d@Declaration{..} = do renderChildren :: HtmlRenderContext -> [ChildDeclaration] -> Html renderChildren _ [] = return () -renderChildren r xs = ul $ mapM_ go xs +renderChildren r xs = ul $ mapM_ item xs where - go decl = item decl . code . codeAsHtml r . Render.renderChildDeclaration $ decl - item decl = let fragment = makeFragment (childDeclInfoNamespace (cdeclInfo decl)) (cdeclTitle decl) - in li ! A.id (v (T.drop 1 fragment)) + item decl = + li ! A.id (v (T.drop 1 (fragment decl))) $ do + renderCode decl + for_ (cdeclComments decl) $ \coms -> + H.div ! A.class_ "decl__child_comments" $ renderMarkdown coms + + fragment decl = makeFragment (childDeclInfoNamespace (cdeclInfo decl)) (cdeclTitle decl) + renderCode = code . codeAsHtml r . Render.renderChildDeclaration codeAsHtml :: HtmlRenderContext -> RenderedCode -> Html codeAsHtml r = outputWith elemAsHtml From c41a7a424abcb66e8bd429364130cc870a77eaaa Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 9 Jul 2017 22:41:55 +0100 Subject: [PATCH 0816/1580] Only build master and semver tags in Travis (#2982) Currently, for PRs from branches in this repository, we have to wait for 4 CI builds: 2 Travis and 2 appveyor, one for the branch and one for the PR. As far as I can see, the branch builds don't achieve anything beyond making us wait longer for CI to finish. This change to .travis.yml should hopefully disable the branch ones but leave the builds we want intact. I'll see if I can make a similar change for AppVeyor. --- .travis.yml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/.travis.yml b/.travis.yml index 6280647644..9e3e9b785d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,12 @@ language: c dist: trusty # because of perf issues sudo: required +branches: + # Only build master and tagged versions, i.e. not feature branches; feature + # branches already get built after opening a pull request. + only: + - master + - /^v\d+\.\d+(\.\d+)?(-\S*)?$/ matrix: include: # We use trusty boxes because they seem to be a bit faster. From 7fdd39d9a7ff4a0e8eb66f442f70f2c0d8caed66 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 10 Jul 2017 01:59:35 +0100 Subject: [PATCH 0817/1580] Fix child decl ordering (#2984) * Fix child declarations order in HTML docs Child declarations - that is, data constructors, type class members, and instances - were appearing in the reverse order because of how the `partitionChildren` function works. This fixes https://github.com/purescript/pursuit/issues/125. * Test that order of child declarations is preserved This doesn't fully test what we want it to, as it is still possible to accidentally reverse the list during HTML rendering. However that's not too difficult to verify manually (as I have just done). --- examples/docs/src/ChildDeclOrder.purs | 27 ++++++++++++++++++++++++++ src/Language/PureScript/Docs/AsHtml.hs | 5 ++++- tests/TestDocs.hs | 14 ++++++++----- 3 files changed, 40 insertions(+), 6 deletions(-) create mode 100644 examples/docs/src/ChildDeclOrder.purs diff --git a/examples/docs/src/ChildDeclOrder.purs b/examples/docs/src/ChildDeclOrder.purs new file mode 100644 index 0000000000..7f677856e7 --- /dev/null +++ b/examples/docs/src/ChildDeclOrder.purs @@ -0,0 +1,27 @@ +-- Tests should ensure that, in the docs: +-- - First should come before Second +-- - foo1 should be listed before foo2 +-- - the instances should be listed in the same order as this source file +module ChildDeclOrder where + +data Two + = First + | Second + +class Show a where + show :: a -> String + +class Foo a where + foo1 :: a + foo2 :: a + +instance showTwo :: Show Two where + show _ = "" + +instance fooTwo :: Foo Two where + foo1 = First + foo2 = Second + +instance fooInt :: Foo Int where + foo1 = 1 + foo2 = 2 diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index bf1c7932c1..c33109fcbf 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -299,10 +299,13 @@ withClass className content = H.span ! A.class_ (fromString className) $ content partitionChildren :: [ChildDeclaration] -> ([ChildDeclaration], [ChildDeclaration], [ChildDeclaration]) -partitionChildren = foldl go ([], [], []) +partitionChildren = + reverseAll . foldl go ([], [], []) where go (instances, dctors, members) rcd = case cdeclInfo rcd of ChildInstance _ _ -> (rcd : instances, dctors, members) ChildDataConstructor _ -> (instances, rcd : dctors, members) ChildTypeClassMember _ -> (instances, dctors, rcd : members) + + reverseAll (xs, ys, zs) = (reverse xs, reverse ys, reverse zs) diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 0237bfee8f..d3dbbdbd35 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -13,7 +13,6 @@ import Control.Arrow (first) import Control.Monad.IO.Class (liftIO) import Data.Foldable -import Data.List ((\\)) import Data.Maybe (fromMaybe) import Data.Monoid import Data.Text (Text) @@ -99,7 +98,7 @@ instance Show (ShowFn a) where data AssertionFailure -- | A declaration was not documented, but should have been = NotDocumented P.ModuleName Text - -- | A child declaration was not documented, but should have been + -- | The expected list of child declarations did not match the actual list | ChildrenNotDocumented P.ModuleName Text [Text] -- | A declaration was documented, but should not have been | Documented P.ModuleName Text @@ -152,9 +151,9 @@ runAssertion assertion linksCtx Docs.Module{..} = Nothing -> Fail (NotDocumented mn decl) Just actualChildren -> - case children \\ actualChildren of - [] -> Pass - cs -> Fail (ChildrenNotDocumented mn decl cs) + if children == actualChildren + then Pass + else Fail (ChildrenNotDocumented mn decl actualChildren) ShouldNotBeDocumented mn decl -> case findChildren decl (declarationsFor mn) of @@ -406,6 +405,11 @@ testCases = , ("Desugar", [ ValueShouldHaveTypeSignature (n "Desugar") "test" (renderedType "forall a b. X (a -> b) a -> b") ]) + + , ("ChildDeclOrder", + [ ShouldBeDocumented (n "ChildDeclOrder") "Two" ["First", "Second", "showTwo", "fooTwo"] + , ShouldBeDocumented (n "ChildDeclOrder") "Foo" ["foo1", "foo2", "fooTwo", "fooInt"] + ]) ] where From 4a9e716c83e20164c3805316fe2fa69ffe5c3afc Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 9 Jul 2017 18:35:32 -0700 Subject: [PATCH 0818/1580] Revert "Require single-method instance declarations to be indented" (#2985) * Revert "Fix child decl ordering (#2984)" This reverts commit 7fdd39d9a7ff4a0e8eb66f442f70f2c0d8caed66. * Revert "Only build master and semver tags in Travis (#2982)" This reverts commit c41a7a424abcb66e8bd429364130cc870a77eaaa. * Revert "Include comments in child declarations in HTML docs (#2981)" This reverts commit ad6166fff797db34387bf09a0bc3ba00030dd473. * Revert "Solve RowToList (#2945)" This reverts commit 0e2d8206bd05a5e6094f9ff9cc89fbc1968574bc. * Revert "Fix links to type operators in HTML docs (#2979)" This reverts commit 5fe26f28e1b69eb33dfccb8440732ead15f9f477. * Revert "Re-evaluate REPL globs during :reload (#2978)" This reverts commit 50e1c68d9e8d21fa39ed2c95277f8002003df1f9. * Revert "[purs ide] Collect data constructors (#2976)" This reverts commit c965f35d462be4041c38c13b6badef6edabf4682. * Revert "Replace synonyms in instance constraints (#2973)" This reverts commit ee66e0dad5436006e11e749af691ee1072e172c7. * Revert "Require single-method instance declarations to be indented (#2965)" This reverts commit b3e470deb302f8f400bbe140e600eba5c9e2c2b5. --- CONTRIBUTORS.md | 1 - examples/failing/2947.purs | 10 ---------- examples/passing/2947.purs | 11 ----------- src/Language/PureScript/Parser/Declarations.hs | 2 +- 4 files changed, 1 insertion(+), 23 deletions(-) delete mode 100644 examples/failing/2947.purs delete mode 100644 examples/passing/2947.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 2829d4664c..e653c77107 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -82,7 +82,6 @@ If you would prefer to use different terms, please use the section below instead | [@phiggins](https://github.com/phiggins) | Pete Higgins | [MIT license](http://opensource.org/licenses/MIT) | | [@philopon](https://github.com/philopon) | Hirotomo Moriwaki | [MIT license](http://opensource.org/licenses/MIT) | | [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license](http://opensource.org/licenses/MIT) | -| [@quesebifurcan](https://github.com/quesebifurcan) | Fredrik Wallberg | [MIT license](http://opensource.org/licenses/MIT) | | [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) | | [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license](http://opensource.org/licenses/MIT) | | [@RossMeikleham](https://github.com/RossMeikleham) | Ross Meikleham | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/examples/failing/2947.purs b/examples/failing/2947.purs deleted file mode 100644 index c0f191b5bd..0000000000 --- a/examples/failing/2947.purs +++ /dev/null @@ -1,10 +0,0 @@ --- @shouldFailWith ErrorParsingModule - -module Main where - -import Prelude - -data Foo = Foo - -instance eqFoo :: Eq Foo where -eq _ _ = true diff --git a/examples/passing/2947.purs b/examples/passing/2947.purs deleted file mode 100644 index fbc1b201fb..0000000000 --- a/examples/passing/2947.purs +++ /dev/null @@ -1,11 +0,0 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console (log) - -data Foo = Foo - -instance eqFoo :: Eq Foo where - eq _ _ = true - -main = log "Done" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 420c1557e6..1dbb9d5d4c 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -227,7 +227,7 @@ parseTypeInstanceDeclaration = do instanceDecl <- parseInstanceDeclaration members <- P.option [] $ do indented *> reserved "where" - indented *> mark (P.many (same *> declsInInstance)) + mark (P.many (same *> declsInInstance)) return $ instanceDecl (ExplicitInstance members) where declsInInstance :: TokenParser Declaration From cc6c2c1fe3102d644737dcc9464dffc29cf5b092 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 9 Jul 2017 18:36:09 -0700 Subject: [PATCH 0819/1580] 0.11.6 --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 942f310506..f30357c964 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.11.5' +version: '0.11.6' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From b12ab5452e341668bb55e651e2d40e5808fd101c Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 10 Jul 2017 18:32:25 +0100 Subject: [PATCH 0820/1580] Fix fragment links to type constructors in HTML (#2989) Fixes #2988 --- src/Language/PureScript/Docs/AsHtml.hs | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index c33109fcbf..780e850bd3 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -19,6 +19,7 @@ import Control.Arrow (second) import Control.Category ((>>>)) import Control.Monad (unless) import Data.Char (isUpper) +import Data.Either (isRight) import Data.Monoid ((<>)) import Data.Foldable (for_) import Data.String (fromString) @@ -29,6 +30,7 @@ import qualified Data.Text as T import Text.Blaze.Html5 as H hiding (map) import qualified Text.Blaze.Html5.Attributes as A import qualified Cheapskate +import Text.Parsec (eof) import qualified Language.PureScript as P @@ -188,8 +190,14 @@ codeAsHtml r = outputWith elemAsHtml case link_ of Link mn -> let - class_ = if startsWithUpper name then "ctor" else "ident" - target = if ns == TypeLevel then "type (" <> name <> ")" else name + class_ = + if startsWithUpper name then "ctor" else "ident" + target + | isOp name = + if ns == TypeLevel + then "type (" <> name <> ")" + else "(" <> name <> ")" + | otherwise = name in linkToDecl ns target mn (withClass class_ (text name)) NoLink -> @@ -203,6 +211,13 @@ codeAsHtml r = outputWith elemAsHtml then False else isUpper (T.index str 0) + isOp = isRight . runParser P.symbol + + runParser :: P.TokenParser a -> Text -> Either String a + runParser p' s = either (Left . show) Right $ do + ts <- P.lex "" s + P.runTokenParser "" (p' <* eof) ts + renderLink :: HtmlRenderContext -> DocLink -> Html -> Html renderLink r link_@DocLink{..} = a ! A.href (v (renderDocLink r link_ <> fragmentFor link_)) From e6adc4f37b382aeaa474b291bed13699a87f1639 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 10 Jul 2017 19:26:41 +0100 Subject: [PATCH 0821/1580] Update test dependencies (#2992) This commit updates all the test dependencies to their latest versions. It also pins down the version of all dependencies; there are no longer any transitive dependencies which can cause breakage when new versions are released with different sets of dependencies (this time, it was purescript-strings). --- tests/support/bower.json | 32 ++++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/tests/support/bower.json b/tests/support/bower.json index 932650f470..0973f7a8d8 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -1,22 +1,42 @@ { "name": "purescript-test-suite-support", "dependencies": { - "purescript-arrays": "4.0.0", + "purescript-arrays": "4.1.2", "purescript-assert": "3.0.0", + "purescript-bifunctors": "3.0.0", "purescript-console": "3.0.0", + "purescript-control": "3.3.0", + "purescript-distributive": "3.0.0", "purescript-eff": "3.1.0", + "purescript-either": "3.1.0", + "purescript-foldable-traversable": "3.4.0", "purescript-functions": "3.0.0", + "purescript-gen": "1.1.0", "purescript-generics": "4.0.0", - "purescript-generics-rep": "5.0.0", - "purescript-lists": "4.6.0", + "purescript-generics-rep": "5.1.0", + "purescript-globals": "3.0.0", + "purescript-identity": "3.1.0", + "purescript-integers": "3.1.0", + "purescript-invariant": "3.0.0", + "purescript-lazy": "3.0.0", + "purescript-lists": "4.9.0", + "purescript-math": "2.1.0", + "purescript-maybe": "3.0.0", + "purescript-monoid": "3.1.0", "purescript-newtype": "2.0.0", - "purescript-partial": "1.2.0", - "purescript-prelude": "3.0.0", + "purescript-nonempty": "4.0.0", + "purescript-partial": "1.2.1", + "purescript-prelude": "3.1.0", + "purescript-proxy": "2.1.0", "purescript-psci-support": "3.0.0", "purescript-st": "3.0.0", + "purescript-strings": "3.3.0", "purescript-symbols": "3.0.0", "purescript-tailrec": "3.3.0", - "purescript-typelevel-prelude": "2.0.0", + "purescript-tuples": "4.1.0", + "purescript-type-equality": "2.1.0", + "purescript-typelevel-prelude": "2.3.0", + "purescript-unfoldable": "3.0.0", "purescript-unsafe-coerce": "3.0.0" } } From b6934c47601c61cf0558c1e7550d6b19d6420cc6 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 10 Jul 2017 20:36:37 +0100 Subject: [PATCH 0822/1580] Desugar type operators in instance declarations (#2991) Fixes #2872 Also modify docs tests to allow assertions that an instance has the right type --- examples/docs/src/TypeOpAliases.purs | 26 ++++++++++ src/Language/PureScript/Docs/Convert.hs | 4 ++ src/Language/PureScript/Sugar/Operators.hs | 45 ++++++++++++++--- tests/TestDocs.hs | 57 +++++++++++++++++++--- 4 files changed, 118 insertions(+), 14 deletions(-) diff --git a/examples/docs/src/TypeOpAliases.purs b/examples/docs/src/TypeOpAliases.purs index be11148b22..6d76c4eb70 100644 --- a/examples/docs/src/TypeOpAliases.purs +++ b/examples/docs/src/TypeOpAliases.purs @@ -14,5 +14,31 @@ data Tuple a b = Tuple a b infixl 6 Tuple as × infixl 6 type Tuple as × +data Either a b = Left a | Right b + +infixl 5 type Either as ⊕ + third ∷ ∀ a b c. a × b × c → c third (a × b × c) = c + +class Show a where + show :: a -> String + +instance showTuple :: Show a => Show (a × b) where + show (a × _) = show a + +-- Test that precedence is taken into account while desugaring type operators + +class TestL a where + testL :: a + +class TestR a where + testR :: a + +-- Note: this type is Either Int (Tuple Int String) +instance testLEither :: TestL (Int ⊕ Int × String) where + testL = Right (0 × "hi") + +-- Note: this type is Either (Tuple Int Int) String +instance testREither :: TestR (Int × Int ⊕ String) where + testR = Left (0 × 1) diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 2057a1ecf5..17b72aea80 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -208,5 +208,9 @@ partiallyDesugar = P.evalSupplyT 0 . desugar' >>> traverse P.desugarCasesModule >=> traverse P.desugarTypeDeclarationsModule >=> ignoreWarnings . P.desugarImportsWithEnv [] + >=> traverse (P.rebracketFiltered isInstanceDecl []) ignoreWarnings = fmap fst . runWriterT + + isInstanceDecl (P.TypeInstanceDeclaration {}) = True + isInstanceDecl _ = False diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index a55071aeda..2c9a10f59c 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -8,6 +8,7 @@ module Language.PureScript.Sugar.Operators ( desugarSignedLiterals , rebracket + , rebracketFiltered , checkFixityExports ) where @@ -68,7 +69,24 @@ rebracket => [ExternsFile] -> [Module] -> m [Module] -rebracket externs modules = do +rebracket = + rebracketFiltered (const True) + +-- | +-- A version of `rebracket` which allows you to choose which declarations +-- should be affected. This is used in docs generation, where we want to +-- desugar type operators in instance declarations to ensure that instances are +-- paired up with their types correctly, but we don't want to desugar type +-- operators in value declarations. +-- +rebracketFiltered + :: forall m + . MonadError MultipleErrors m + => (Declaration -> Bool) + -> [ExternsFile] + -> [Module] + -> m [Module] +rebracketFiltered pred_ externs modules = do let (valueFixities, typeFixities) = partitionEithers $ concatMap externsFixities externs @@ -84,7 +102,7 @@ rebracket externs modules = do for modules $ renameAliasedOperators valueAliased typeAliased - <=< rebracketModule valueOpTable typeOpTable + <=< rebracketModule pred_ valueOpTable typeOpTable where @@ -110,7 +128,7 @@ rebracket externs modules = do -> Module -> m Module renameAliasedOperators valueAliased typeAliased (Module ss coms mn ds exts) = - Module ss coms mn <$> mapM f' ds <*> pure exts + Module ss coms mn <$> mapM (usingPredicate pred_ f') ds <*> pure exts where (goDecl', goExpr', goBinder') = updateTypes goType (f', _, _, _, _) = @@ -167,13 +185,19 @@ rebracket externs modules = do rebracketModule :: forall m . (MonadError MultipleErrors m) - => [[(Qualified (OpName 'ValueOpName), Associativity)]] + => (Declaration -> Bool) + -> [[(Qualified (OpName 'ValueOpName), Associativity)]] -> [[(Qualified (OpName 'TypeOpName), Associativity)]] -> Module -> m Module -rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) = - Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts +rebracketModule pred_ valueOpTable typeOpTable (Module ss coms mn ds exts) = + Module ss coms mn <$> f' ds <*> pure exts where + f' :: [Declaration] -> m [Declaration] + f' = + fmap (map (\d -> if pred_ d then removeParens d else d)) . + flip parU (usingPredicate pred_ f) + (f, _, _) = everywhereOnValuesTopDownM goDecl @@ -405,3 +429,12 @@ checkFixityExports m@(Module ss _ mn ds (Just exps)) = :: ((ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) -> Bool) -> Bool anyTypeRef f = any (maybe False f . getTypeRef) exps + +usingPredicate + :: forall f a + . Applicative f + => (a -> Bool) + -> (a -> f a) + -> (a -> f a) +usingPredicate p f x = + if p x then f x else pure x diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index d3dbbdbd35..e7e97e961f 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -13,9 +13,11 @@ import Control.Arrow (first) import Control.Monad.IO.Class (liftIO) import Data.Foldable -import Data.Maybe (fromMaybe) +import Safe (headMay) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import Data.Text (Text) +import qualified Data.Text.IO as TIO import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) import Data.Version (Version(..)) @@ -73,6 +75,9 @@ data Assertion -- | Assert that a particular value declaration exists, and its type -- satisfies the given predicate. | ValueShouldHaveTypeSignature P.ModuleName Text (ShowFn (P.Type -> Bool)) + -- | Assert that a particular instance declaration exists under some class or + -- type declaration, and that its type satisfies the given predicate. + | InstanceShouldHaveTypeSignature P.ModuleName Text Text (ShowFn (P.Type -> Bool)) -- | Assert that a particular type alias exists, and its corresponding -- type, when rendered, matches a given string exactly -- fields: module, type synonym name, expected type @@ -111,11 +116,11 @@ data AssertionFailure -- | A declaration had the wrong "type" (ie, value, type, type class) -- Fields: declaration title, expected "type", actual "type". | WrongDeclarationType P.ModuleName Text Text Text - -- | A value declaration had the wrong type (in the sense of "type - -- checking"), eg, because the inferred type was used when the explicit type - -- should have been. + -- | A declaration had the wrong type (in the sense of "type checking"), eg, + -- because the inferred type was used when the explicit type should have + -- been. -- Fields: module name, declaration name, actual type. - | ValueDeclarationWrongType P.ModuleName Text P.Type + | DeclarationWrongType P.ModuleName Text P.Type -- | A Type synonym has been rendered in an unexpected format -- Fields: module name, declaration name, expected rendering, actual rendering | TypeSynonymMismatch P.ModuleName Text Text Text @@ -138,6 +143,14 @@ data AssertionFailure | BadLinkLocation P.ModuleName Text Text Docs.LinkLocation Docs.LinkLocation deriving (Show) +displayAssertionFailure :: AssertionFailure -> Text +displayAssertionFailure = \case + DeclarationWrongType mn title actual -> + P.runModuleName mn <> "." <> title <> " had the wrong type; got " <> T.pack (P.prettyPrintType actual) + -- TODO: deal with the other constructors nicely + other -> + T.pack (show other) + data AssertionResult = Pass | Fail AssertionFailure @@ -199,12 +212,33 @@ runAssertion assertion linksCtx Docs.Module{..} = Docs.ValueDeclaration ty -> if tyPredicate ty then Pass - else Fail - (ValueDeclarationWrongType mn decl ty) + else Fail (DeclarationWrongType mn decl ty) _ -> Fail (WrongDeclarationType mn decl "value" (Docs.declInfoToString declInfo)) + InstanceShouldHaveTypeSignature mn parent decl (ShowFn tyPredicate) -> + case find ((==) parent . Docs.declTitle) (declarationsFor mn) >>= findTarget of + Just ty -> + if tyPredicate ty + then Pass + else Fail (DeclarationWrongType mn decl ty) + Nothing -> + Fail (NotDocumented mn decl) + + where + findTarget = + headMay . + mapMaybe (extractInstanceType . Docs.cdeclInfo) . + filter (\cdecl -> Docs.cdeclTitle cdecl == decl) . + Docs.declChildren + + extractInstanceType = \case + (Docs.ChildInstance _ ty) -> + Just ty + _ -> + Nothing + TypeSynonymShouldRenderAs mn decl expected -> findDecl mn decl $ \Docs.Declaration{..} -> case declInfo of @@ -293,7 +327,7 @@ runAssertionIO assertion linksCtx mdl = do case runAssertion assertion linksCtx mdl of Pass -> pure () Fail reason -> do - putStrLn ("Failed: " <> show reason) + TIO.putStrLn ("Failed: " <> displayAssertionFailure reason) exitFailure testCases :: [(Text, [Assertion])] @@ -392,6 +426,13 @@ testCases = , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test3" (renderedType "forall a b c d. a ~> (b ~> c) ~> d") , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test4" (renderedType "forall a b c d. ((a ~> b) ~> c) ~> d") , ValueShouldHaveTypeSignature (n "TypeOpAliases") "third" (renderedType "forall a b c. a × b × c -> c") + + , ShouldBeDocumented (n "TypeOpAliases") "Tuple" ["Tuple","showTuple", "testLEither", "testREither"] + , ShouldBeDocumented (n "TypeOpAliases") "Either" ["Left", "Right","testLEither", "testREither"] + , ShouldBeDocumented (n "TypeOpAliases") "Show" ["show","showTuple"] + + , InstanceShouldHaveTypeSignature (n "TypeOpAliases") "Either" "testLEither" (renderedType "TestL (Either Int (Tuple Int String))") + , InstanceShouldHaveTypeSignature (n "TypeOpAliases") "Either" "testREither" (renderedType "TestR (Either (Tuple Int Int) String)") ]) , ("DocComments", From 19f546ebaca697342ccb7cb7f1160cec5f97a186 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 11 Jul 2017 17:44:18 +0100 Subject: [PATCH 0823/1580] Update installation doc [ci skip] (#2994) - The lts-8.5 resolver uses GHC 8.0.2 so update INSTALL.md to reflect that - Homebrew compiles purescript from source, so don't suggest that it uses the prebuilt binaries - Remove Chocolatey since the Chocolatey distribution does not appear to be maintained any more - Suggest using RELEASE flag so that the version reported when running `purs --version` is accurate with a compiler which was built from source --- INSTALL.md | 26 ++++++++++++-------------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/INSTALL.md b/INSTALL.md index 4031f9ed65..27f170a8d5 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -6,10 +6,10 @@ alternatively Stack Overflow. ## Using prebuilt binaries -The prebuilt binaries are compiled with GHC 7.10.3, and therefore they should -run on any operating system supported by GHC 7.10.3, such as: +The prebuilt binaries are compiled with GHC 8.0.2 and therefore they should +run on any operating system supported by GHC 8.0.2, such as: -* Windows 2000 or later, +* Windows Vista or later, * OS X 10.7 or later, * Linux ??? (we're not sure what the minimum version is). @@ -17,20 +17,18 @@ This list is not exhaustive. If your OS is too old or not listed, or if the binaries fail to run, you may be able to install the compiler by building it from source; see below. -It's probably safe to assume that other prebuilt distributions (eg, Homebrew, -Chocolatey, AUR, npm) use the same binaries, and therefore have the same -requirements. +Other prebuilt distributions (eg, Homebrew, AUR, npm) will probably have the +same requirements. ## Compiling from source -GHC 7.10.1 or newer is required to compile from source. The easiest way is to -use stack: +The easiest way is to use stack: ``` $ stack update $ stack unpack purescript $ cd purescript-x.y.z # (replace x.y.z with whichever version you just downloaded) -$ stack install +$ stack install --flag purescript:RELEASE ``` This will then copy the compiler and utilities into `~/.local/bin`. @@ -39,14 +37,14 @@ This will then copy the compiler and utilities into `~/.local/bin`. If you don't have stack installed, there are install instructions [here](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md). -If you don't have ghc installed, stack will prompt you to run `stack setup` -which will install ghc for you. +If you don't have GHC installed, stack will prompt you to run `stack setup` +which will install the correct version of GHC for you. ## The "curses" library -`psci` depends on the `curses` library (via the Haskell package `terminfo`). If -you are having difficulty running the compiler, it may be because the `curses` -library is missing. +The PureScript REPL depends on the `curses` library (via the Haskell package +`terminfo`). If you are having difficulty running the compiler, it may be +because the `curses` library is missing. On Linux, you will probably need to install `ncurses` manually. On Ubuntu, for example, this can be done by running: From f924ed769f619b68e9954bc433f5fd7ab08e5538 Mon Sep 17 00:00:00 2001 From: Felix Schlitter Date: Tue, 18 Jul 2017 01:23:52 +1200 Subject: [PATCH 0824/1580] Fix source links for re-exports (#2997) Part of purescript/pursuit#304 --- app/Command/Docs/Html.hs | 2 +- src/Language/PureScript/Docs/AsHtml.hs | 27 +++++++++++++++++--------- 2 files changed, 19 insertions(+), 10 deletions(-) diff --git a/app/Command/Docs/Html.hs b/app/Command/Docs/Html.hs index 507917e98a..ba53b9a550 100644 --- a/app/Command/Docs/Html.hs +++ b/app/Command/Docs/Html.hs @@ -36,7 +36,7 @@ writeHtmlModules outputDir modules = do mapM_ (writeHtmlModule outputDir . (fst &&& layout moduleList)) modules asHtml :: D.Module -> (P.ModuleName, D.HtmlOutputModule Html) -asHtml m = D.moduleAsHtml (getHtmlRenderContext (D.modName m)) m +asHtml m = D.moduleAsHtml (const $ Just $ getHtmlRenderContext (D.modName m)) m writeHtmlModule :: FilePath -> (P.ModuleName, Html) -> IO () writeHtmlModule outputDir (mn, html) = do diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index 780e850bd3..8bd617d91d 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -15,11 +15,11 @@ module Language.PureScript.Docs.AsHtml ( ) where import Prelude -import Control.Arrow (second) import Control.Category ((>>>)) import Control.Monad (unless) import Data.Char (isUpper) import Data.Either (isRight) +import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Foldable (for_) import Data.String (fromString) @@ -70,22 +70,31 @@ nullRenderContext mn = HtmlRenderContext , renderSourceLink = const Nothing } -packageAsHtml :: (P.ModuleName -> HtmlRenderContext) -> Package a -> HtmlOutput Html +packageAsHtml + :: (InPackage P.ModuleName -> Maybe HtmlRenderContext) + -> Package a + -> HtmlOutput Html packageAsHtml getHtmlCtx Package{..} = HtmlOutput indexFile modules where indexFile = [] - modules = map (\m -> moduleAsHtml (getHtmlCtx (modName m)) m) pkgModules + modules = moduleAsHtml getHtmlCtx <$> pkgModules -moduleAsHtml :: HtmlRenderContext -> Module -> (P.ModuleName, HtmlOutputModule Html) -moduleAsHtml r Module{..} = (modName, HtmlOutputModule modHtml reexports) +moduleAsHtml + :: (InPackage P.ModuleName -> Maybe HtmlRenderContext) + -> Module + -> (P.ModuleName, HtmlOutputModule Html) +moduleAsHtml getR Module{..} = (modName, HtmlOutputModule modHtml reexports) where - renderDecl = declAsHtml r modHtml = do - for_ modComments renderMarkdown - for_ modDeclarations renderDecl + let r = fromMaybe (nullRenderContext modName) $ getR (Local modName) + in do + for_ modComments renderMarkdown + for_ modDeclarations (declAsHtml r) reexports = - map (second (foldMap renderDecl)) modReExports + flip map modReExports $ \(pkg, decls) -> + let r = fromMaybe (nullRenderContext modName) $ getR pkg + in (pkg, foldMap (declAsHtml r) decls) -- renderIndex :: LinksContext -> [(Maybe Char, Html)] -- renderIndex LinksContext{..} = go ctxBookmarks From f8b86e8b0091be84e7676c2035d347bed75450df Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 20 Jul 2017 16:43:50 +0100 Subject: [PATCH 0825/1580] Only build master and semver tags in AppVeyor (#2987) Follow up to #2982 --- appveyor.yml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/appveyor.yml b/appveyor.yml index 6d2b979717..febdab7862 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -6,6 +6,12 @@ environment: STACK_VER: 1.3.2 RELEASE_USER: purescript RELEASE_REPO: purescript +branches: + # Only build master and tagged versions, i.e. not feature branches; feature + # branches already get built after opening a pull request. + only: + - master + - /^v\d+\.\d+(\.\d+)?(-\S*)?$/ cache: - c:\s -> appveyor/cache-buster.txt install: From cf17c0430395aeb9e2d93e5ea8271424b5084057 Mon Sep 17 00:00:00 2001 From: Isaac Elliott Date: Tue, 25 Jul 2017 06:06:29 +1000 Subject: [PATCH 0826/1580] [purs-ide] Fixed case-splitting on local non-exported datatypes (#2986) * Added cachedRebuild ExternsFile to those searched in caseSplit (#2968) * Update CONTRIBUTORS.md --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Ide/CaseSplit.hs | 4 +++- src/Language/PureScript/Ide/State.hs | 1 + 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index e653c77107..0bd2e8a297 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -122,3 +122,4 @@ If you would prefer to use different terms, please use the section below instead | Username | Company | Terms | | :------- | :--- | :------ | | [@slamdata](https://github.com/slamdata) | SlamData, Inc. | Speaking on behalf of SlamData for SlamData employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright SlamData Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - @jdegoes | +| [@qfpl](https://github.com/qfpl) | qfpl @ Data61 / CSIRO | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Data61 / CSIRO, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@lightandlight](https://github.com/lightandlight) | diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 033120ba26..c948b4e26d 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -23,6 +23,7 @@ module Language.PureScript.Ide.CaseSplit import Protolude hiding (Constructor) +import qualified Data.Map as M import qualified Data.Text as T import qualified Language.PureScript as P @@ -58,7 +59,8 @@ findTypeDeclaration :: (Ide m, MonadError IdeError m) => P.ProperName 'P.TypeName -> m ExternsDeclaration findTypeDeclaration q = do efs <- getExternFiles - let m = getFirst $ foldMap (findTypeDeclaration' q) efs + efs' <- maybe efs (flip (uncurry M.insert) efs) <$> cachedRebuild + let m = getFirst $ foldMap (findTypeDeclaration' q) efs' case m of Just mn -> pure mn Nothing -> throwError (GeneralError "Not Found") diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 81c290c1c4..0e133da2cd 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -21,6 +21,7 @@ module Language.PureScript.Ide.State , getExternFiles , resetIdeState , cacheRebuild + , cachedRebuild , insertExterns , insertModule , insertExternsSTM From f87d8026d743fd7352d011695f757e65d1265adf Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Mon, 24 Jul 2017 20:47:59 -0400 Subject: [PATCH 0827/1580] Prevent browser from treating declTitle and linkToSource as one word (#3002) --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Docs/AsHtml.hs | 2 ++ 2 files changed, 3 insertions(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 0bd2e8a297..2cc07b4475 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -85,6 +85,7 @@ If you would prefer to use different terms, please use the section below instead | [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) | | [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license](http://opensource.org/licenses/MIT) | | [@RossMeikleham](https://github.com/RossMeikleham) | Ross Meikleham | [MIT license](http://opensource.org/licenses/MIT) | +| [@Rufflewind](https://github.com/Rufflewind) | Phil Ruffwind | [MIT license](https://opensource.org/licenses/MIT) | | [@rvion](https://github.com/rvion) | Rémi Vion | [MIT license](http://opensource.org/licenses/MIT) | | [@RyanGlScott](https://github.com/RyanGlScott) | Ryan Scott | [MIT license](http://opensource.org/licenses/MIT) | | [@sebastiaanvisser](https://github.com/sebastiaanvisser) | Sebastiaan Visser | MIT license | diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index 8bd617d91d..80856c94cb 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -138,6 +138,8 @@ declAsHtml r d@Declaration{..} = do h3 ! A.class_ "decl__title clearfix" $ do a ! A.class_ "decl__anchor" ! A.href (v declFragment) $ "#" H.span $ text declTitle + text " " -- prevent browser from treating + -- declTitle + linkToSource as one word for_ declSourceSpan (linkToSource r) H.div ! A.class_ "decl__body" $ do From f4e81e7e5ef7c806f93383df46e95c3284aa24af Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 30 Jul 2017 10:32:20 -0700 Subject: [PATCH 0828/1580] Fix a loop in the kind checker (#3005) * Fix a loop in the kind checker, fix #2995 * Add a test --- examples/failing/InfiniteKind2.purs | 5 +++++ src/Language/PureScript/TypeChecker/Kinds.hs | 6 +++--- 2 files changed, 8 insertions(+), 3 deletions(-) create mode 100644 examples/failing/InfiniteKind2.purs diff --git a/examples/failing/InfiniteKind2.purs b/examples/failing/InfiniteKind2.purs new file mode 100644 index 0000000000..63c910400a --- /dev/null +++ b/examples/failing/InfiniteKind2.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith InfiniteKind + +module InfiniteKind2 where + +data Tree m a = Tree a (m (Tree a)) diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 4ca12487a5..58ec2f0fb6 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -86,10 +86,10 @@ unifyKinds k1 k2 = do go (KUnknown u) k = solveKind u k go k (KUnknown u) = solveKind u k go (NamedKind k1') (NamedKind k2') | k1' == k2' = return () - go (Row k1') (Row k2') = go k1' k2' + go (Row k1') (Row k2') = unifyKinds k1' k2' go (FunKind k1' k2') (FunKind k3 k4) = do - go k1' k3 - go k2' k4 + unifyKinds k1' k3 + unifyKinds k2' k4 go k1' k2' = throwError . errorMessage $ KindsDoNotUnify k1' k2' -- | Infer the kind of a single type From 6e689c4a3b76c8b25993212971581b03046e362a Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 30 Jul 2017 21:55:35 +0200 Subject: [PATCH 0829/1580] [purs ide] Editor mode (#3006) * extract asynchronous cache repopulation * [purs ide] Adds an "editor-mode" When the editor-mode flag is specified at startup the server will not start a file watcher process anymore. Instead it only reloads after succesful rebuild commands. This is a lot less fragile than relying on the file system APIs, but will mean that a manual load needs to be triggered after builds that didn't go through purs ide. * Also updates the README under psc-ide/ to be a bit more recent * fix warning * Strictness annotations to make sure we actually populate the cache off-thread This also makes the perf measurement mean something --- app/Command/Ide.hs | 16 ++++++++--- psc-ide/README.md | 30 ++++++++++---------- src/Language/PureScript/AST/Declarations.hs | 6 +++- src/Language/PureScript/Ide.hs | 11 ++------ src/Language/PureScript/Ide/Rebuild.hs | 9 +++++- src/Language/PureScript/Ide/Reexports.hs | 5 +++- src/Language/PureScript/Ide/State.hs | 30 ++++++++++++++------ src/Language/PureScript/Ide/Types.hs | 31 +++++++++++---------- tests/Language/PureScript/Ide/Test.hs | 10 ++++--- 9 files changed, 92 insertions(+), 56 deletions(-) diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index 76ad796d9d..263e27172f 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -69,6 +69,7 @@ data ServerOptions = ServerOptions , _serverNoWatch :: Bool , _serverPolling :: Bool , _serverLoglevel :: IdeLogLevel + , _serverEditorMode :: Bool } deriving (Show) data ClientOptions = ClientOptions @@ -106,7 +107,7 @@ command = Opts.helper <*> subcommands where Opts.option Opts.auto (Opts.long "port" <> Opts.short 'p' <> Opts.value (4242 :: Integer)) server :: ServerOptions -> IO () - server opts'@(ServerOptions dir globs outputPath port noWatch polling logLevel) = do + server opts'@(ServerOptions dir globs outputPath port noWatch polling logLevel editorMode) = do when (logLevel == LogDebug || logLevel == LogAll) (putText "Parsed Options:" *> print opts') maybe (pure ()) setCurrentDirectory dir @@ -118,10 +119,16 @@ command = Opts.helper <*> subcommands where putText "Your output directory didn't exist. This usually means you didn't compile your project yet." putText "psc-ide needs you to compile your project (for example by running pulp build)" - unless noWatch $ + unless (noWatch || editorMode) $ void (forkFinally (watcher polling logLevel ideState fullOutputPath) print) - let conf = IdeConfiguration {confLogLevel = logLevel, confOutputPath = outputPath, confGlobs = globs} - env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf} + let + conf = IdeConfiguration + { confLogLevel = logLevel + , confOutputPath = outputPath + , confGlobs = globs + , confEditorMode = editorMode + } + let env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf} startServer port env serverOptions :: Opts.Parser ServerOptions @@ -138,6 +145,7 @@ command = Opts.helper <*> subcommands where (Opts.long "log-level" `mappend` Opts.value "" `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\"")) + <*> Opts.switch (Opts.long "editor-mode") parseLogLevel s = case s of "debug" -> LogDebug diff --git a/psc-ide/README.md b/psc-ide/README.md index 231793520b..b48efb852a 100644 --- a/psc-ide/README.md +++ b/psc-ide/README.md @@ -1,17 +1,18 @@ -psc-ide +purs ide === -A tool which provides editor support for the PureScript programming language. +Editor and tooling support for the PureScript programming language. -## Editor Integration -* [@epost](https://github.com/epost) wrote a plugin to integrate psc-ide with Emacs at https://github.com/epost/psc-ide-emacs. -* Atom integration is available with https://github.com/nwolverson/atom-ide-purescript. -* Visual Studio Code integration is available with https://github.com/nwolverson/vscode-ide-purescript. -* Vim integration is available here: https://github.com/FrigoEU/psc-ide-vim. +## Setting up your editor + +This document will describe how to run `purs ide` as an editor plugin creator. +If you're looking to set up your PureScript development environment consult +the +[documentation repository](https://github.com/purescript/documentation/blob/master/ecosystem/Editor-and-tool-support.md) instead. ## Running the Server -Start the server by running the `psc-ide-server [SOURCEGLOBS]` executable, where +Start the server by running the `purs ide server [SOURCEGLOBS]` executable, where `SOURCEGLOBS` are (optional) globs that match your PureScript sourcefiles. It supports the following options: @@ -26,21 +27,22 @@ It supports the following options: files. This flag is reversed on Windows and polling is the default. - `--log-level`: Can be set to one of "all", "none", "debug" and "perf" - `--no-watch`: Disables the filewatcher +- `--editor-mode`: Only reload on source file changes reported by the editor - `--version`: Output psc-ide version ## Issuing queries After you started the server you can start issuing requests using -`psc-ide-client`. Make sure you start by loading the modules before you try to +`purs ide client`. Make sure you start by loading the modules before you try to query them. -`psc-ide-server` expects the build externs.purs inside the `output/` folder of -your project after running `pulp build` or `psc-make` respectively. +`purs ide` expects the built externs.json inside the output folder of your +project after running `pulp build` or `purs compile` respectively. (If you changed the port of the server you can change the port for -`psc-ide-client` by using the -p option accordingly) +`purs ide client` by using the -p option accordingly) ## Protocol -For documentation about the protocol have a look at: -[PROTOCOL.md](PROTOCOL.md) +If you want to know how to send commands/queries to `purs ide` take a look +at [PROTOCOL.md](PROTOCOL.md) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index d897ee0a7c..72dffdb5c1 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveAnyClass #-} -- | -- Data types for modules and declarations @@ -9,12 +11,14 @@ module Language.PureScript.AST.Declarations where import Prelude.Compat +import Control.DeepSeq (NFData) import Control.Monad.Identity import Data.Aeson.TH import qualified Data.Map as M import Data.Text (Text) import qualified Data.List.NonEmpty as NEL +import GHC.Generics (Generic) import Language.PureScript.AST.Binders import Language.PureScript.AST.Literals @@ -288,7 +292,7 @@ data DeclarationRef -- elaboration in name desugaring. -- | ReExportRef SourceSpan ModuleName DeclarationRef - deriving (Show) + deriving (Show, Generic, NFData) instance Eq DeclarationRef where (TypeRef _ name dctors) == (TypeRef _ name' dctors') = name == name' && dctors == dctors' diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index c566fa5b34..4c947ea99f 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -187,14 +187,7 @@ loadModulesAsync -> m Success loadModulesAsync moduleNames = do tr <- loadModules moduleNames - - -- Finally we kick off the worker with @async@ and return the number of - -- successfully parsed modules. - env <- ask - let ll = confLogLevel (ideConfiguration env) - -- populateVolatileState return Unit for now, so it's fine to discard this - -- result. We might want to block on this in a benchmarking situation. - _ <- liftIO (async (runLogger ll (runReaderT populateVolatileState env))) + _ <- populateVolatileState pure tr loadModulesSync @@ -203,7 +196,7 @@ loadModulesSync -> m Success loadModulesSync moduleNames = do tr <- loadModules moduleNames - populateVolatileState + populateVolatileStateSync pure tr loadModules diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index a7e765bdec..c54b6a9417 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -72,10 +72,17 @@ rebuildFile path runOpenBuild = do >>= shushProgress $ makeEnv) externs $ m case result of Left errors -> throwError (RebuildError errors) - Right _ -> do + Right newExterns -> do + whenM isEditorMode $ do + insertModule (path, m) + insertExterns newExterns + void populateVolatileState runOpenBuild (rebuildModuleOpen makeEnv externs m) pure (RebuildSuccess warnings) +isEditorMode :: Ide m => m Bool +isEditorMode = asks (confEditorMode . ideConfiguration) + rebuildFileAsync :: forall m. (Ide m, MonadLogger m, MonadError IdeError m) => FilePath -> m Success diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 0a8b1de2ab..8cdc088301 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- -- Module : Language.PureScript.Ide.Reexports @@ -35,7 +36,9 @@ data ReexportResult a = ReexportResult { reResolved :: a , reFailed :: [(P.ModuleName, P.DeclarationRef)] - } deriving (Show, Eq, Functor) + } deriving (Show, Eq, Functor, Generic) + +instance NFData a => NFData (ReexportResult a) -- | Uses the passed formatter to format the resolved module, and adds possible -- failures diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 0e133da2cd..e6c7fed3c5 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -12,9 +12,10 @@ -- Functions to access psc-ide's state ----------------------------------------------------------------------------- -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} module Language.PureScript.Ide.State ( getLoadedModulenames @@ -27,6 +28,7 @@ module Language.PureScript.Ide.State , insertExternsSTM , getAllModules , populateVolatileState + , populateVolatileStateSync , populateVolatileStateSTM -- for tests , resolveOperatorsForModule @@ -163,21 +165,33 @@ cachedRebuild :: Ide m => m (Maybe (P.ModuleName, ExternsFile)) cachedRebuild = vsCachedRebuild <$> getVolatileState -- | Resolves reexports and populates VolatileState with data to be used in queries. -populateVolatileState :: (Ide m, MonadLogger m) => m () -populateVolatileState = do +populateVolatileStateSync :: (Ide m, MonadLogger m) => m () +populateVolatileStateSync = do st <- ideStateVar <$> ask - let message duration = "Finished populating Stage3 in " <> displayTimeSpec duration - results <- logPerf message (liftIO (atomically (populateVolatileStateSTM st))) + let message duration = "Finished populating volatile state in: " <> displayTimeSpec duration + results <- logPerf message $ do + !r <- liftIO (atomically (populateVolatileStateSTM st)) + pure r void $ Map.traverseWithKey (\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn))) (Map.filter reexportHasFailures results) +populateVolatileState :: (Ide m, MonadLogger m) => m (Async ()) +populateVolatileState = do + env <- ask + let ll = confLogLevel (ideConfiguration env) + -- populateVolatileState return Unit for now, so it's fine to discard this + -- result. We might want to block on this in a benchmarking situation. + liftIO (async (runLogger ll (runReaderT populateVolatileStateSync env))) + -- | STM version of populateVolatileState populateVolatileStateSTM :: TVar IdeState -> STM (ModuleMap (ReexportResult [IdeDeclarationAnn])) populateVolatileStateSTM ref = do IdeFileState{fsExterns = externs, fsModules = modules} <- getFileStateSTM ref + -- We're not using the cached rebuild for anything other than preserving it + -- through the repopulation rebuildCache <- vsCachedRebuild <$> getVolatileStateSTM ref let asts = map (extractAstInformation . fst) modules let (moduleDeclarations, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs) @@ -189,7 +203,7 @@ populateVolatileStateSTM ref = do & resolveOperators & resolveReexports reexportRefs setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) rebuildCache) - pure results + pure (force results) resolveLocations :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index c951e49c2b..ffab6bfb90 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -12,6 +12,8 @@ -- Type definitions for psc-ide ----------------------------------------------------------------------------- +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE TemplateHaskell #-} @@ -38,43 +40,43 @@ data IdeDeclaration | IdeDeclValueOperator IdeValueOperator | IdeDeclTypeOperator IdeTypeOperator | IdeDeclKind (P.ProperName 'P.KindName) - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic, NFData) data IdeValue = IdeValue { _ideValueIdent :: P.Ident , _ideValueType :: P.Type - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, NFData) data IdeType = IdeType { _ideTypeName :: P.ProperName 'P.TypeName , _ideTypeKind :: P.Kind , _ideTypeDtors :: [(P.ProperName 'P.ConstructorName, P.Type)] - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, NFData) data IdeTypeSynonym = IdeTypeSynonym { _ideSynonymName :: P.ProperName 'P.TypeName , _ideSynonymType :: P.Type , _ideSynonymKind :: P.Kind - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, NFData) data IdeDataConstructor = IdeDataConstructor { _ideDtorName :: P.ProperName 'P.ConstructorName , _ideDtorTypeName :: P.ProperName 'P.TypeName , _ideDtorType :: P.Type - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, NFData) data IdeTypeClass = IdeTypeClass { _ideTCName :: P.ProperName 'P.ClassName , _ideTCKind :: P.Kind , _ideTCInstances :: [IdeInstance] - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, NFData) data IdeInstance = IdeInstance { _ideInstanceModule :: P.ModuleName , _ideInstanceName :: P.Ident , _ideInstanceTypes :: [P.Type] , _ideInstanceConstraints :: Maybe [P.Constraint] - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, NFData) data IdeValueOperator = IdeValueOperator { _ideValueOpName :: P.OpName 'P.ValueOpName @@ -82,7 +84,7 @@ data IdeValueOperator = IdeValueOperator , _ideValueOpPrecedence :: P.Precedence , _ideValueOpAssociativity :: P.Associativity , _ideValueOpType :: Maybe P.Type - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, NFData) data IdeTypeOperator = IdeTypeOperator { _ideTypeOpName :: P.OpName 'P.TypeOpName @@ -90,7 +92,7 @@ data IdeTypeOperator = IdeTypeOperator , _ideTypeOpPrecedence :: P.Precedence , _ideTypeOpAssociativity :: P.Associativity , _ideTypeOpKind :: Maybe P.Kind - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, NFData) makePrisms ''IdeDeclaration makeLenses ''IdeValue @@ -105,14 +107,14 @@ makeLenses ''IdeTypeOperator data IdeDeclarationAnn = IdeDeclarationAnn { _idaAnnotation :: Annotation , _idaDeclaration :: IdeDeclaration - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, NFData) data Annotation = Annotation { _annLocation :: Maybe P.SourceSpan , _annExportedFrom :: Maybe P.ModuleName , _annTypeAnnotation :: Maybe P.Type - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, NFData) makeLenses ''Annotation makeLenses ''IdeDeclarationAnn @@ -125,7 +127,7 @@ type TypeAnnotations = Map P.Ident P.Type newtype AstData a = AstData (ModuleMap (DefinitionSites a, TypeAnnotations)) -- ^ SourceSpans for the definition sites of values and types as well as type -- annotations found in a module - deriving (Show, Eq, Ord, Functor, Foldable) + deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable) data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone deriving (Show, Eq) @@ -135,6 +137,7 @@ data IdeConfiguration = { confOutputPath :: FilePath , confLogLevel :: IdeLogLevel , confGlobs :: [FilePath] + , confEditorMode :: Bool } data IdeEnvironment = @@ -316,7 +319,7 @@ instance ToJSON PursuitResponse where -- | Denotes the different namespaces a name in PureScript can reside in. data IdeNamespace = IdeNSValue | IdeNSType | IdeNSKind - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic, NFData) instance FromJSON IdeNamespace where parseJSON (String s) = case s of @@ -328,4 +331,4 @@ instance FromJSON IdeNamespace where -- | A name tagged with a namespace data IdeNamespaced = IdeNamespaced IdeNamespace Text - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic, NFData) diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index dd48b8f85f..d9d50aedc7 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -20,10 +20,12 @@ import qualified Language.PureScript as P defConfig :: IdeConfiguration defConfig = - IdeConfiguration { confLogLevel = LogNone - , confOutputPath = "output/" - , confGlobs = ["src/*.purs"] - } + IdeConfiguration + { confLogLevel = LogNone + , confOutputPath = "output/" + , confGlobs = ["src/*.purs"] + , confEditorMode = False + } runIde' :: IdeConfiguration -> IdeState -> [Command] -> IO ([Either IdeError Success], IdeState) runIde' conf s cs = do From 2e1b8527ce8f2ea310d2d249daf8cab5930539f5 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 30 Jul 2017 13:02:15 -0700 Subject: [PATCH 0830/1580] Fix type operator precedence parsing, fix #2958 (#3009) --- examples/passing/2958.purs | 14 ++++++++++++++ src/Language/PureScript/Sugar/Operators.hs | 4 ++-- 2 files changed, 16 insertions(+), 2 deletions(-) create mode 100644 examples/passing/2958.purs diff --git a/examples/passing/2958.purs b/examples/passing/2958.purs new file mode 100644 index 0000000000..462bcaa853 --- /dev/null +++ b/examples/passing/2958.purs @@ -0,0 +1,14 @@ +module Main where + +import Control.Monad.Eff.Console + +data Nil +data Snoc xs x + +infixl 1 type Snoc as :> + +type One = Nil :> Int +type Two = Nil :> Int :> Int +type Three = Nil :> Int :> Int :> Int + +main = log "Done" diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 2c9a10f59c..9f2e7df09c 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -171,7 +171,7 @@ rebracketFiltered pred_ externs modules = do goBinder pos other = return (pos, other) goType :: Maybe SourceSpan -> Type -> m Type - goType pos = maybe id rethrowWithPosition pos . everywhereOnTypesM go + goType pos = maybe id rethrowWithPosition pos . go where go :: Type -> m Type go (BinaryNoParensType (TypeOp op) lhs rhs) = @@ -321,7 +321,7 @@ updateTypes goType = (goDecl, goExpr, goBinder) where goType' :: Maybe SourceSpan -> Type -> m Type - goType' = everywhereOnTypesM . goType + goType' = everywhereOnTypesTopDownM . goType goType'' :: SourceSpan -> Type -> m Type goType'' = goType' . Just From db99634aca48f3b57a781767fbd5d344a539f18d Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 30 Jul 2017 22:02:35 +0200 Subject: [PATCH 0831/1580] also runs type search for data constructors (#3008) --- src/Language/PureScript/TypeChecker/TypeSearch.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index bfb53d0435..ae550330c4 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -116,8 +116,14 @@ typeSearch -> ([(P.Qualified Text, P.Type)], Maybe [(Label, P.Type)]) typeSearch unsolved env st type' = let - resultMap = Map.mapMaybe (\(x, _, _) -> checkSubsume unsolved env st type' x $> x) (P.names env) - (allLabels, solvedLabels) = accessorSearch unsolved env st type' - solvedLabels' = first (P.Qualified Nothing . ("_." <>) . P.prettyPrintLabel) <$> solvedLabels + runTypeSearch :: Map k P.Type -> Map k P.Type + runTypeSearch = Map.mapMaybe (\ty -> checkSubsume unsolved env st type' ty $> ty) + + matchingNames = runTypeSearch (Map.map (\(ty, _, _) -> ty) (P.names env)) + matchingConstructors = runTypeSearch (Map.map (\(_, _, ty, _) -> ty) (P.dataConstructors env)) + (allLabels, matchingLabels) = accessorSearch unsolved env st type' in - (solvedLabels' <> (first (map P.runIdent) <$> Map.toList resultMap), if null allLabels then Nothing else Just allLabels) + ( (first (P.Qualified Nothing . ("_." <>) . P.prettyPrintLabel) <$> matchingLabels) + <> (first (map P.runIdent) <$> Map.toList matchingNames) + <> (first (map P.runProperName) <$> Map.toList matchingConstructors) + , if null allLabels then Nothing else Just allLabels) From ad0c7c04fca8b2dda5a71f558ed943d0b16a2671 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 31 Jul 2017 17:57:51 +0100 Subject: [PATCH 0832/1580] Remove some references to old executables (#3014) This removes all references to the old executables except for those in the IDE code, as I wasn't sure what to do about those. --- src/Language/PureScript/Bundle.hs | 11 ++++++----- src/Language/PureScript/Docs/Types.hs | 2 +- src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/Publish/ErrorsWarnings.hs | 4 ++-- 4 files changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index af226f6db0..19959050a9 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -52,7 +52,8 @@ data ErrorMessage | MissingMainModule String deriving (Show) --- | Modules are either "regular modules" (i.e. those generated by psc) or foreign modules. +-- | Modules are either "regular modules" (i.e. those generated by the PureScript compiler) or +-- foreign modules. data ModuleType = Regular | Foreign @@ -500,7 +501,7 @@ isModuleEmpty (Module _ _ els) = all isElementEmpty els -- In particular, a module and its foreign imports share the same namespace inside PS. -- This saves us from having to generate unique names for a module and its foreign imports, -- and is safe since a module shares a namespace with its foreign imports in PureScript as well --- (so there is no way to have overlaps in code generated by psc). +-- (so there is no way to have overlaps in code generated by the compiler). codeGen :: Maybe String -- ^ main module -> String -- ^ namespace -> [Module] -- ^ input modules @@ -604,7 +605,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o keepCol (TokenPn _ _ c) = TokenPn 0 0 (if c >= 0 then c + 2 else 2) prelude :: JSStatement - prelude = JSVariable (JSAnnot tokenPosnEmpty [ CommentA tokenPosnEmpty $ "// Generated by psc-bundle " ++ showVersion Paths.version + prelude = JSVariable (JSAnnot tokenPosnEmpty [ CommentA tokenPosnEmpty $ "// Generated by purs bundle " ++ showVersion Paths.version , WhiteSpace tokenPosnEmpty "\n" ]) (cList [ JSVarInitExpression (JSIdentifier sp optionsNamespace) @@ -674,7 +675,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o -- This function performs dead code elimination, filters empty modules -- and generates and prints the final JavaScript bundle. bundleSM :: (MonadError ErrorMessage m) - => [(ModuleIdentifier, Maybe FilePath, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. + => [(ModuleIdentifier, Maybe FilePath, String)] -- ^ The input modules. Each module should be javascript rendered from the compiler. -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination -> Maybe String -- ^ An optional main module. -> String -- ^ The namespace (e.g. PS). @@ -703,7 +704,7 @@ bundleSM inputStrs entryPoints mainModule namespace outFilename = do -- This function performs dead code elimination, filters empty modules -- and generates and prints the final JavaScript bundle. bundle :: (MonadError ErrorMessage m) - => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. + => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from the compiler. -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination -> Maybe String -- ^ An optional main module. -> String -- ^ The namespace (e.g. PS). diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index f97a25d2bd..b53f92ba30 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -488,7 +488,7 @@ asPackage :: Version -> (forall e. Parse e a) -> Parse PackageError (Package a) asPackage minimumVersion uploader = do -- If the compilerVersion key is missing, we can be sure that it was produced -- with 0.7.0.0, since that is the only released version that included the - -- psc-publish tool before this key was added. + -- `psc-publish` tool (now `purs publish`) before this key was added. compilerVersion <- keyOrDefault "compilerVersion" (Version [0,7,0,0] []) asVersion when (compilerVersion < minimumVersion) (throwCustomError $ CompilerTooOld minimumVersion compilerVersion) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 474dc373d8..47da4e29bb 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -431,7 +431,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box renderSimpleErrorMessage (ModuleNotFound mn) = paras [ line $ "Module " <> markCode (runModuleName mn) <> " was not found." - , line "Make sure the source file exists, and that it has been provided as an input to psc." + , line "Make sure the source file exists, and that it has been provided as an input to the compiler." ] renderSimpleErrorMessage (CannotGetFileInfo path) = paras [ line "Unable to read file info: " diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index e62b0a224a..fb8d5fbb08 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -140,7 +140,7 @@ displayUserError e = case e of TagMustBeCheckedOut -> vcat [ para (concat - [ "psc-publish requires a tagged version to be checked out in " + [ "purs publish requires a tagged version to be checked out in " , "order to build documentation, and no suitable tag was found. " , "Please check out a previously tagged version, or tag a new " , "version." @@ -152,7 +152,7 @@ displayUserError e = case e of , para (concat [ "If the version you are publishing is not yet tagged, you might " , "want to use the --dry-run flag instead, which removes this " - , "requirement. Run psc-publish --help for more details." + , "requirement. Run `purs publish --help` for more details." ]) ] AmbiguousVersions vs -> From 9632949f1bf48e8b94a957c1a1e1e931001b0fae Mon Sep 17 00:00:00 2001 From: Hardy Jones Date: Wed, 2 Aug 2017 06:54:58 -0700 Subject: [PATCH 0833/1580] Fix pretty-printing of class names in hierarchy (#3013) * Don't use `Show` instance for pretty printing in `purs hierarchy` The `Show` instance was not following the intent of the type class. https://hackage.haskell.org/package/base-4.10.0.0/docs/Text-Show.html#t:Show We weren't making a "syntactically correct Haskell expression." Instead, we were using it to pretty print the representation we wanted. Rather than conflate the ideas, we use a function specific for pretty printing. The name might not be the best. But, it more correctly reflects the intent/purpose. * Extract code from `hierarchy` command into the library * Add tests for Language.PureScript.Hierarchy --- app/Command/Hierarchy.hs | 42 +++----------- src/Language/PureScript/Hierarchy.hs | 86 ++++++++++++++++++++++++++++ tests/Main.hs | 6 +- tests/TestHierarchy.hs | 65 +++++++++++++++++++++ 4 files changed, 163 insertions(+), 36 deletions(-) create mode 100644 src/Language/PureScript/Hierarchy.hs create mode 100644 tests/TestHierarchy.hs diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs index d06918e0cb..1bb9346534 100644 --- a/app/Command/Hierarchy.hs +++ b/app/Command/Hierarchy.hs @@ -18,14 +18,13 @@ module Command.Hierarchy (command) where -import Protolude (ordNub) +import Protolude (catMaybes) import Control.Applicative (optional) -import Control.Monad (unless) -import Data.List (intercalate, sort) import Data.Foldable (for_) import Data.Monoid ((<>)) import qualified Data.Text as T +import qualified Data.Text.IO as T import Options.Applicative (Parser) import qualified Options.Applicative as Opts import System.Directory (createDirectoryIfMissing) @@ -35,27 +34,13 @@ import System.Exit (exitFailure, exitSuccess) import System.IO (hPutStr, stderr) import System.IO.UTF8 (readUTF8FileT) import qualified Language.PureScript as P +import Language.PureScript.Hierarchy (Graph(..), _unDigraph, _unGraphName, typeClasses) data HierarchyOptions = HierarchyOptions { _hierachyInput :: FilePath , _hierarchyOutput :: Maybe FilePath } -newtype SuperMap = SuperMap { _unSuperMap :: Either (P.ProperName 'P.ClassName) (P.ProperName 'P.ClassName, P.ProperName 'P.ClassName) } - deriving Eq - -instance Show SuperMap where - show (SuperMap (Left sub)) = show sub - show (SuperMap (Right (super, sub))) = show super ++ " -> " ++ show sub - -instance Ord SuperMap where - compare (SuperMap s) (SuperMap s') = getCls s `compare` getCls s' - where - getCls = either id snd - -runModuleName :: P.ModuleName -> String -runModuleName (P.ModuleName pns) = intercalate "_" ((T.unpack . P.runProperName) `map` pns) - readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module]) readInput paths = do content <- mapM (\path -> (path, ) <$> readUTF8FileT path) paths @@ -68,27 +53,14 @@ compile (HierarchyOptions inputGlob mOutput) = do case modules of Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure Right ms -> do - for_ ms $ \(P.Module _ _ moduleName decls _) -> - let name = runModuleName moduleName - tcs = filter P.isTypeClassDeclaration decls - supers = sort . ordNub . filter (not . null) $ fmap superClasses tcs - prologue = "digraph " ++ name ++ " {\n" - body = intercalate "\n" (concatMap (fmap (\s -> " " ++ show s ++ ";")) supers) - epilogue = "\n}" - hier = prologue ++ body ++ epilogue - in unless (null supers) $ case mOutput of + for_ (catMaybes $ typeClasses ms) $ \(Graph name graph) -> + case mOutput of Just output -> do createDirectoryIfMissing True output - writeFile (output name) hier - Nothing -> putStrLn hier + T.writeFile (output T.unpack (_unGraphName name)) (_unDigraph graph) + Nothing -> T.putStrLn (_unDigraph graph) exitSuccess -superClasses :: P.Declaration -> [SuperMap] -superClasses (P.TypeClassDeclaration _ sub _ supers@(_:_) _ _) = - fmap (\(P.Constraint (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers -superClasses (P.TypeClassDeclaration _ sub _ _ _ _) = [SuperMap (Left sub)] -superClasses _ = [] - inputFile :: Parser FilePath inputFile = Opts.strArgument $ Opts.metavar "FILE" diff --git a/src/Language/PureScript/Hierarchy.hs b/src/Language/PureScript/Hierarchy.hs new file mode 100644 index 0000000000..837fd3a33a --- /dev/null +++ b/src/Language/PureScript/Hierarchy.hs @@ -0,0 +1,86 @@ +----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Hierarchy +-- Copyright : (c) Hardy Jones 2014 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Hardy Jones +-- Stability : experimental +-- Portability : +-- +-- | +-- Generate Directed Graphs of PureScript TypeClasses +-- +----------------------------------------------------------------------------- + +module Language.PureScript.Hierarchy where + +import Prelude.Compat +import Protolude (ordNub) + +import Data.List (sort) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import qualified Language.PureScript as P + +newtype SuperMap = SuperMap + { _unSuperMap :: Either (P.ProperName 'P.ClassName) (P.ProperName 'P.ClassName, P.ProperName 'P.ClassName) + } + deriving Eq + +instance Ord SuperMap where + compare (SuperMap s) (SuperMap s') = getCls s `compare` getCls s' + where + getCls = either id snd + +data Graph = Graph + { graphName :: GraphName + , digraph :: Digraph + } + deriving (Eq, Show) + +newtype GraphName = GraphName + { _unGraphName :: T.Text + } + deriving (Eq, Show) + +newtype Digraph = Digraph + { _unDigraph :: T.Text + } + deriving (Eq, Show) + +prettyPrint :: SuperMap -> T.Text +prettyPrint (SuperMap (Left sub)) = " " <> P.runProperName sub <> ";" +prettyPrint (SuperMap (Right (super, sub))) = + " " <> P.runProperName super <> " -> " <> P.runProperName sub <> ";" + +runModuleName :: P.ModuleName -> GraphName +runModuleName (P.ModuleName pns) = + GraphName $ T.intercalate "_" (P.runProperName <$> pns) + +typeClasses :: Functor f => f P.Module -> f (Maybe Graph) +typeClasses = + fmap typeClassGraph + +typeClassGraph :: P.Module -> Maybe Graph +typeClassGraph (P.Module _ _ moduleName decls _) = + if null supers then Nothing else Just (Graph name graph) + where + name = runModuleName moduleName + supers = sort . ordNub $ concatMap superClasses decls + graph = Digraph $ typeClassPrologue name <> typeClassBody supers <> typeClassEpilogue + +typeClassPrologue :: GraphName -> T.Text +typeClassPrologue (GraphName name) = "digraph " <> name <> " {\n" + +typeClassBody :: [SuperMap] -> T.Text +typeClassBody supers = T.intercalate "\n" (prettyPrint <$> supers) + +typeClassEpilogue :: T.Text +typeClassEpilogue = "\n}" + +superClasses :: P.Declaration -> [SuperMap] +superClasses (P.TypeClassDeclaration _ sub _ supers@(_:_) _ _) = + fmap (\(P.Constraint (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers +superClasses (P.TypeClassDeclaration _ sub _ _ _ _) = [SuperMap (Left sub)] +superClasses _ = [] diff --git a/tests/Main.hs b/tests/Main.hs index acfce36647..1622bd481d 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -10,10 +10,11 @@ import Prelude.Compat import qualified TestCompiler import qualified TestDocs +import qualified TestHierarchy +import qualified TestPrimDocs import qualified TestPsci import qualified TestPscIde import qualified TestPscPublish -import qualified TestPrimDocs import qualified TestUtils import System.IO (hSetEncoding, stdout, stderr, utf8) @@ -29,6 +30,9 @@ main = do TestCompiler.main heading "Documentation test suite" TestDocs.main + heading "Hierarchy test suite" + TestHierarchy.main + heading "Prim documentation test suite" TestPrimDocs.main heading "psc-publish test suite" TestPscPublish.main diff --git a/tests/TestHierarchy.hs b/tests/TestHierarchy.hs new file mode 100644 index 0000000000..98bea9a65b --- /dev/null +++ b/tests/TestHierarchy.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} +module TestHierarchy where + +import Language.PureScript.Hierarchy +import qualified Language.PureScript as P +import Test.Hspec (describe, hspec, it, shouldBe) + +main :: IO () +main = hspec $ do + describe "Language.PureScript.Hierarchy" $ do + describe "prettyPrint" $ do + it "creates just the node when there is no relation" $ do + let superMap = SuperMap (Left $ P.ProperName "A") + + let prettyPrinted = prettyPrint superMap + + prettyPrinted `shouldBe` " A;" + + it "creates a relation when there is one" $ do + let superMap = SuperMap (Right $ (P.ProperName "A", P.ProperName "B")) + + let prettyPrinted = prettyPrint superMap + + prettyPrinted `shouldBe` " A -> B;" + + describe "typeClassGraph" $ do + it "doesn't generate a graph if there are no type classes" $ do + let mainModule = P.Module + (P.internalModuleSourceSpan "") + [] + (P.ModuleName [P.ProperName "Main"]) + [] + Nothing + + let graph = typeClassGraph mainModule + + graph `shouldBe` Nothing + + it "generates usable graphviz graphs" $ do + let declarations = + [ P.TypeClassDeclaration + (P.internalModuleSourceSpan "", []) + (P.ProperName "A") + [] + [] + [] + [] + , P.TypeClassDeclaration + (P.internalModuleSourceSpan "", []) + (P.ProperName "B") + [] + [P.Constraint (P.Qualified Nothing $ P.ProperName "A") [] Nothing] + [] + [] + ] + let mainModule = P.Module + (P.internalModuleSourceSpan "") + [] + (P.ModuleName [P.ProperName "Main"]) + declarations + Nothing + + let graph = typeClassGraph mainModule + + graph `shouldBe` Just (Graph (GraphName "Main") (Digraph "digraph Main {\n A;\n A -> B;\n}")) From 4760262c8f0d8d7ab01e37bb3133a075cd8ee6d5 Mon Sep 17 00:00:00 2001 From: Coot Date: Thu, 3 Aug 2017 22:31:28 +0200 Subject: [PATCH 0834/1580] Improve suggested git url in purs publish error message (#2998) If `git config remote.origin.url` gives us a GitHub url, we now use that url in the suggested "repository" section of the manifest file (usually bower.json) in `purs publish`. Otherwise, we provide an example which is more obviously meant to be amended before being put in (github.com/USER/REPO.git rather than the prelude URL). This helps avoid situations where people copy-and-paste the default suggestion into their manifest files, resulting in an incorrect value for the repository url. --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Publish.hs | 21 ++++++++++++------- .../PureScript/Publish/ErrorsWarnings.hs | 6 +++--- 3 files changed, 17 insertions(+), 11 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 2cc07b4475..a4799bfb08 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -33,6 +33,7 @@ If you would prefer to use different terms, please use the section below instead | [@chrisdone](https://github.com/chrisdone) | Chris Done | MIT license | | [@cmdv](https://github.com/cmdv) | Vincent Orr | MIT license | | [@codedmart](https://github.com/codedmart) | Brandon Martin | [MIT license](http://opensource.org/licenses/MIT) | +| [@coot](https://github.com/coot) | Marcin Szamotulski | [MIT license](http://opensource.org/licenses/MIT) | | [@davidchambers](https://github.com/davidchambers) | David Chambers | [MIT license](http://opensource.org/licenses/MIT) | | [@DavidLindbom](https://github.com/DavidLindbom) | David Lindbom | [MIT license](http://opensource.org/licenses/MIT) | | [@dckc](https://github.com/dckc) | Dan Connolly | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index a1ec6867a0..e41620e33b 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -202,15 +202,20 @@ getTagTime tag = do _ -> internalError (CouldntParseGitTagDate tag) getManifestRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo) -getManifestRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract +getManifestRepositoryInfo pkgMeta = + case bowerRepository pkgMeta of + Nothing -> do + giturl <- catchError (Just . T.strip . T.pack <$> readProcess' "git" ["config", "remote.origin.url"] "") + (const (return Nothing)) + userError (BadRepositoryField (RepositoryFieldMissing (giturl >>= extractGithub >>= return . format))) + Just Repository{..} -> do + unless (repositoryType == "git") + (userError (BadRepositoryField (BadRepositoryType repositoryType))) + maybe (userError (BadRepositoryField NotOnGithub)) return (extractGithub repositoryUrl) + where - tryExtract pkgMeta = - case bowerRepository pkgMeta of - Nothing -> Left RepositoryFieldMissing - Just Repository{..} -> do - unless (repositoryType == "git") - (Left (BadRepositoryType repositoryType)) - maybe (Left NotOnGithub) Right (extractGithub repositoryUrl) + format :: (D.GithubUser, D.GithubRepo) -> Text + format (user, repo) = "https://github.com/" <> D.runGithubUser user <> "/" <> D.runGithubRepo repo <> ".git" checkLicense :: PackageMeta -> PrepareM () checkLicense pkgMeta = diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index fb8d5fbb08..806739574c 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -66,7 +66,7 @@ data UserError deriving (Show) data RepositoryFieldError - = RepositoryFieldMissing + = RepositoryFieldMissing (Maybe Text) | BadRepositoryType Text | NotOnGithub deriving (Show) @@ -234,7 +234,7 @@ spdxExamples = displayRepositoryError :: RepositoryFieldError -> Box displayRepositoryError err = case err of - RepositoryFieldMissing -> + RepositoryFieldMissing giturl -> vcat [ para (concat [ "The 'repository' field is not present in your package manifest file. " @@ -246,7 +246,7 @@ displayRepositoryError err = case err of , indented (vcat [ para "\"repository\": {" , indented (para "\"type\": \"git\",") - , indented (para "\"url\": \"git://github.com/purescript/purescript-prelude.git\"") + , indented (para ("\"url\": \"" ++ T.unpack (fromMaybe "https://github.com/USER/REPO.git" giturl) ++ "\"")) , para "}" ] ) From 3103dbf317c84e103384243944a377f0a0594774 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Fri, 4 Aug 2017 01:34:02 +0100 Subject: [PATCH 0835/1580] Treat kinds as used in import warnings (#3019) --- src/Language/PureScript/Linter/Imports.hs | 3 ++- src/Language/PureScript/Names.hs | 4 ++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index bba9e265c5..3a57797590 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -301,13 +301,14 @@ findUsedRefs ss env mni qn names = valueOpRefs = ValueOpRef ss <$> mapMaybe (getValOpName <=< disqualifyFor qn) names typeOpRefs = TypeOpRef ss <$> mapMaybe (getTypeOpName <=< disqualifyFor qn) names types = mapMaybe (getTypeName <=< disqualifyFor qn) names + kindRefs = KindRef ss <$> mapMaybe (getKindName <=< disqualifyFor qn) names dctors = mapMaybe (getDctorName <=< disqualifyFor qn) names typesWithDctors = reconstructTypeRefs dctors typesWithoutDctors = filter (`M.notMember` typesWithDctors) types typesRefs = map (flip (TypeRef ss) (Just [])) typesWithoutDctors ++ map (\(ty, ds) -> TypeRef ss ty (Just ds)) (M.toList typesWithDctors) - in sortBy compDecRef $ classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs + in sortBy compDecRef $ classRefs ++ typeOpRefs ++ typesRefs ++ kindRefs ++ valueRefs ++ valueOpRefs where diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index c804b20940..ea84f152a3 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -44,6 +44,10 @@ getTypeName :: Name -> Maybe (ProperName 'TypeName) getTypeName (TyName name) = Just name getTypeName _ = Nothing +getKindName :: Name -> Maybe (ProperName 'KindName) +getKindName (KiName name) = Just name +getKindName _ = Nothing + getTypeOpName :: Name -> Maybe (OpName 'TypeOpName) getTypeOpName (TyOpName name) = Just name getTypeOpName _ = Nothing From 6303c44be8409e51f58ba1021e0ee33b9d34e96c Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Fri, 4 Aug 2017 20:29:14 +0100 Subject: [PATCH 0836/1580] eliminate redundant whitespace in js output (#3021) fixes #3020 --- src/Language/PureScript/CodeGen/JS/Printer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index 8c72e08397..18a4798d18 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -49,7 +49,7 @@ literals = mkPattern' match' , withIndent $ do jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key <> emit ": ") <>) . prettyPrintJS' $ value indentString <- currentIndent - return $ intercalate (emit ", \n") $ map (indentString <>) jss + return $ intercalate (emit ",\n") $ map (indentString <>) jss , return $ emit "\n" , currentIndent , return $ emit "}" From 3eb47734402e1fdf77b38daf6af253dfbddd3156 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 4 Aug 2017 20:30:18 +0100 Subject: [PATCH 0837/1580] Use order given in export list in generated docs (#3015) If a module has an explicit export list, the declarations in the generated docs now appear in the same order as in the export list. Otherwise, they appear in the same order as they did in the source file. Fixes #3003 --- examples/docs/src/DeclOrder.purs | 17 ++++++++ examples/docs/src/DeclOrderNoExportList.purs | 10 +++++ src/Language/PureScript/AST/Declarations.hs | 28 ++++++++++++ src/Language/PureScript/AST/Exported.hs | 34 +++++++++------ src/Language/PureScript/Sugar/Names.hs | 26 +++++++++-- src/Language/PureScript/Sugar/TypeClasses.hs | 10 ++--- tests/TestDocs.hs | 45 ++++++++++++++++++-- 7 files changed, 147 insertions(+), 23 deletions(-) create mode 100644 examples/docs/src/DeclOrder.purs create mode 100644 examples/docs/src/DeclOrderNoExportList.purs diff --git a/examples/docs/src/DeclOrder.purs b/examples/docs/src/DeclOrder.purs new file mode 100644 index 0000000000..9ec2d2166b --- /dev/null +++ b/examples/docs/src/DeclOrder.purs @@ -0,0 +1,17 @@ +module DeclOrder + ( class A + , x1 + , X2 + , x3 + , X4 + , class B + ) where + +x1 = 0 +x3 = 0 + +data X2 +data X4 + +class A +class B diff --git a/examples/docs/src/DeclOrderNoExportList.purs b/examples/docs/src/DeclOrderNoExportList.purs new file mode 100644 index 0000000000..2cfed5d8a0 --- /dev/null +++ b/examples/docs/src/DeclOrderNoExportList.purs @@ -0,0 +1,10 @@ +module DeclOrderNoExportList where + +x1 = 0 +x3 = 0 + +data X2 +data X4 + +class A +class B diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 72dffdb5c1..16249e18f2 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -342,6 +342,17 @@ declRefSourceSpan (ModuleRef ss _) = ss declRefSourceSpan (KindRef ss _) = ss declRefSourceSpan (ReExportRef ss _ _) = ss +declRefName :: DeclarationRef -> Name +declRefName (TypeRef _ n _) = TyName n +declRefName (TypeOpRef _ n) = TyOpName n +declRefName (ValueRef _ n) = IdentName n +declRefName (ValueOpRef _ n) = ValOpName n +declRefName (TypeClassRef _ n) = TyClassName n +declRefName (TypeInstanceRef _ n) = IdentName n +declRefName (ModuleRef _ n) = ModName n +declRefName (KindRef _ n) = KiName n +declRefName (ReExportRef _ _ ref) = declRefName ref + getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) getTypeRef (TypeRef _ name dctors) = Just (name, dctors) getTypeRef _ = Nothing @@ -510,6 +521,23 @@ declSourceAnn (TypeInstanceDeclaration sa _ _ _ _ _) = sa declSourceSpan :: Declaration -> SourceSpan declSourceSpan = fst . declSourceAnn +declName :: Declaration -> Maybe Name +declName (DataDeclaration _ _ n _ _) = Just (TyName n) +declName (TypeSynonymDeclaration _ n _ _) = Just (TyName n) +declName (ValueDeclaration _ n _ _ _) = Just (IdentName n) +declName (ExternDeclaration _ n _) = Just (IdentName n) +declName (ExternDataDeclaration _ n _) = Just (TyName n) +declName (ExternKindDeclaration _ n) = Just (KiName n) +declName (FixityDeclaration _ (Left (ValueFixity _ _ n))) = Just (ValOpName n) +declName (FixityDeclaration _ (Right (TypeFixity _ _ n))) = Just (TyOpName n) +declName (TypeClassDeclaration _ n _ _ _ _) = Just (TyClassName n) +declName (TypeInstanceDeclaration _ n _ _ _ _) = Just (IdentName n) +declName ImportDeclaration{} = Nothing +declName BindingGroupDeclaration{} = Nothing +declName DataBindingGroupDeclaration{} = Nothing +declName BoundValueDeclaration{} = Nothing +declName TypeDeclaration{} = Nothing + -- | -- Test if a declaration is a value declaration -- diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index 1e5b033528..be6fa74067 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -4,10 +4,12 @@ module Language.PureScript.AST.Exported ) where import Prelude.Compat +import Protolude (sortBy, on) import Control.Category ((>>>)) import Data.Maybe (mapMaybe) +import qualified Data.Map as M import Language.PureScript.AST.Declarations import Language.PureScript.Types @@ -24,6 +26,10 @@ import Language.PureScript.Names -- produce incorrect results if this is not the case - for example, type class -- instances will be incorrectly removed in some cases. -- +-- The returned declarations are in the same order as they appear in the export +-- list, unless there is no export list, in which case they appear in the same +-- order as they do in the source file. +-- exportedDeclarations :: Module -> [Declaration] exportedDeclarations (Module _ _ mn decls exps) = go decls where @@ -31,6 +37,7 @@ exportedDeclarations (Module _ _ mn decls exps) = go decls >>> filter (isExported exps) >>> map (filterDataConstructors exps) >>> filterInstances mn exps + >>> maybe id reorder exps -- | -- Filter out all data constructors from a declaration which are not exported. @@ -119,19 +126,9 @@ typeInstanceConstituents _ = [] isExported :: Maybe [DeclarationRef] -> Declaration -> Bool isExported Nothing _ = True isExported _ TypeInstanceDeclaration{} = True -isExported (Just exps) decl = any (matches decl) exps +isExported (Just exps) decl = any matches exps where - matches (TypeDeclaration _ ident _) (ValueRef _ ident') = ident == ident' - matches (ValueDeclaration _ ident _ _ _) (ValueRef _ ident') = ident == ident' - matches (ExternDeclaration _ ident _) (ValueRef _ ident') = ident == ident' - matches (DataDeclaration _ _ ident _ _) (TypeRef _ ident' _) = ident == ident' - matches (ExternDataDeclaration _ ident _) (TypeRef _ ident' _) = ident == ident' - matches (ExternKindDeclaration _ ident) (KindRef _ ident') = ident == ident' - matches (TypeSynonymDeclaration _ ident _ _) (TypeRef _ ident' _) = ident == ident' - matches (TypeClassDeclaration _ ident _ _ _ _) (TypeClassRef _ ident') = ident == ident' - matches (ValueFixityDeclaration _ _ _ op) (ValueOpRef _ op') = op == op' - matches (TypeFixityDeclaration _ _ _ op) (TypeOpRef _ op') = op == op' - matches _ _ = False + matches declRef = declName decl == Just (declRefName declRef) -- | -- Test if a data constructor for a given type is exported, given a module's @@ -144,3 +141,16 @@ isDctorExported ident (Just exps) ctor = test `any` exps test (TypeRef _ ident' Nothing) = ident == ident' test (TypeRef _ ident' (Just ctors)) = ident == ident' && ctor `elem` ctors test _ = False + +-- | +-- Reorder declarations based on the order they appear in the given export +-- list. +-- +reorder :: [DeclarationRef] -> [Declaration] -> [Declaration] +reorder refs = + sortBy (compare `on` refIndex) + where + refIndices = + M.fromList $ zip (map declRefName refs) [(0::Int)..] + refIndex decl = + declName decl >>= flip M.lookup refIndices diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 24bbe47442..5ed9816ba4 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -9,7 +9,7 @@ module Language.PureScript.Sugar.Names ) where import Prelude.Compat -import Protolude (ordNub) +import Protolude (ordNub, sortBy, on) import Control.Arrow (first) import Control.Monad @@ -118,13 +118,17 @@ desugarImportsWithEnv externs modules = do return m'' -- | --- Make all exports for a module explicit. This may still effect modules that +-- Make all exports for a module explicit. This may still affect modules that -- have an exports list, as it will also make all data constructor exports -- explicit. -- +-- The exports will appear in the same order as they do in the existing exports +-- list, or if there is no export list, declarations are order based on their +-- order of appearance in the module. +-- elaborateExports :: Exports -> Module -> Module elaborateExports exps (Module ss coms mn decls refs) = - Module ss coms mn decls $ Just + Module ss coms mn decls $ Just $ reorderExports decls refs $ elaboratedTypeRefs ++ go (TypeOpRef ss) exportedTypeOps ++ go (TypeClassRef ss) exportedTypeClasses @@ -145,6 +149,22 @@ elaborateExports exps (Module ss coms mn decls refs) = flip map (M.toList (select exps)) $ \(export, mn') -> if mn == mn' then toRef export else ReExportRef ss mn' (toRef export) +-- | +-- Given a list of declarations, an original exports list, and an elaborated +-- exports list, reorder the elaborated list so that it matches the original +-- order. If there is no original exports list, reorder declarations based on +-- their order in the source file. +reorderExports :: [Declaration] -> Maybe [DeclarationRef] -> [DeclarationRef] -> [DeclarationRef] +reorderExports decls originalRefs = + sortBy (compare `on` originalIndex) + where + names = + maybe (mapMaybe declName decls) (map declRefName) originalRefs + namesMap = + M.fromList $ zip names [(0::Int)..] + originalIndex ref = + M.lookup (declRefName ref) namesMap + -- | -- Replaces all local names with qualified names within a module and checks that all existing -- qualified names are valid. diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 5819bb8c89..217076c370 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -279,7 +279,7 @@ typeInstanceDictionaryDeclaration sa name mn deps className tys decls = maybe (throwError . errorMessage . UnknownName $ fmap TyClassName className) return $ M.lookup (qualify mn className) m - case map fst typeClassMembers \\ mapMaybe declName decls of + case map fst typeClassMembers \\ mapMaybe declIdent decls of member : _ -> throwError . errorMessage $ MissingClassMember member [] -> do -- Replace the type arguments with the appropriate types in the member types @@ -306,10 +306,10 @@ typeInstanceDictionaryDeclaration sa name mn deps className tys decls = where - declName :: Declaration -> Maybe Ident - declName (ValueDeclaration _ ident _ _ _) = Just ident - declName (TypeDeclaration _ ident _) = Just ident - declName _ = Nothing + declIdent :: Declaration -> Maybe Ident + declIdent (ValueDeclaration _ ident _ _ _) = Just ident + declIdent (TypeDeclaration _ ident _) = Just ident + declIdent _ = Nothing memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr memberToValue tys' (ValueDeclaration _ ident _ [] [MkUnguarded val]) = do diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index e7e97e961f..229631cc5c 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -12,6 +12,7 @@ import Prelude.Compat import Control.Arrow (first) import Control.Monad.IO.Class (liftIO) +import Data.List (findIndex) import Data.Foldable import Safe (headMay) import Data.Maybe (fromMaybe, mapMaybe) @@ -41,9 +42,14 @@ publishOpts = Publish.defaultPublishOptions } where testVersion = ("v999.0.0", Version [999,0,0] []) +getPackage :: IO (Either Publish.PackageError (Docs.Package Docs.NotYetKnown)) +getPackage = + pushd "examples/docs" $ + Publish.preparePackage "bower.json" "resolutions.json" publishOpts + main :: IO () -main = pushd "examples/docs" $ do - res <- Publish.preparePackage "bower.json" "resolutions.json" publishOpts +main = do + res <- getPackage case res of Left e -> Publish.printErrorToStdout e >> exitFailure Right pkg@Docs.Package{..} -> @@ -53,7 +59,6 @@ main = pushd "examples/docs" $ do linksCtx = Docs.getLinksContext pkg in forM_ pragmas (\a -> runAssertionIO a linksCtx mdl) - takeJust :: String -> Maybe a -> a takeJust msg = fromMaybe (error msg) @@ -93,6 +98,8 @@ data Assertion -- declaration title, title of linked declaration, namespace of linked -- declaration, destination of link. | ShouldHaveLink P.ModuleName Text Text Docs.Namespace Docs.LinkLocation + -- | Assert that a given declaration comes before another in the output + | ShouldComeBefore P.ModuleName Text Text deriving (Show) newtype ShowFn a = ShowFn a @@ -141,12 +148,16 @@ data AssertionFailure -- declaration, title of the linked declaration, expected location, actual -- location. | BadLinkLocation P.ModuleName Text Text Docs.LinkLocation Docs.LinkLocation + -- | Declarations were in the wrong order + | WrongOrder P.ModuleName Text Text deriving (Show) displayAssertionFailure :: AssertionFailure -> Text displayAssertionFailure = \case DeclarationWrongType mn title actual -> P.runModuleName mn <> "." <> title <> " had the wrong type; got " <> T.pack (P.prettyPrintType actual) + WrongOrder mn before after -> + "In " <> P.runModuleName mn <> ": expected to see " <> before <> " before " <> after -- TODO: deal with the other constructors nicely other -> T.pack (show other) @@ -278,6 +289,23 @@ runAssertion assertion linksCtx Docs.Module{..} = Nothing -> Fail (LinkedDeclarationMissing mn decl destTitle) + ShouldComeBefore mn before after -> + let + decls = declarationsFor mn + + indexOf :: Text -> Maybe Int + indexOf title = findIndex ((==) title . Docs.declTitle) decls + in + case (indexOf before, indexOf after) of + (Just i, Just j) -> + if i < j + then Pass + else Fail (WrongOrder mn before after) + (Nothing, _) -> + Fail (NotDocumented mn before) + (_, Nothing) -> + Fail (NotDocumented mn after) + where declarationsFor mn = if mn == modName @@ -451,6 +479,14 @@ testCases = [ ShouldBeDocumented (n "ChildDeclOrder") "Two" ["First", "Second", "showTwo", "fooTwo"] , ShouldBeDocumented (n "ChildDeclOrder") "Foo" ["foo1", "foo2", "fooTwo", "fooInt"] ]) + + , ("DeclOrder", + shouldBeOrdered (n "DeclOrder") + ["A", "x1", "X2", "x3", "X4", "B"]) + + , ("DeclOrderNoExportList", + shouldBeOrdered (n "DeclOrderNoExportList") + [ "x1", "x3", "X2", "X4", "A", "B" ]) ] where @@ -465,3 +501,6 @@ testCases = renderedType expected = ShowFn $ \ty -> codeToString (Docs.renderType ty) == expected + + shouldBeOrdered mn declNames = + zipWith (ShouldComeBefore mn) declNames (tail declNames) From bb5521a5f3aec7e6e5b2526852bc4166989ce6d6 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 4 Aug 2017 20:37:36 +0100 Subject: [PATCH 0838/1580] Embed CSS for HTML docs (#3017) Fixes #3016 --- app/Command/Docs/Html.hs | 11 +- app/static/pursuit.css | 10 +- app/static/pursuit.less | 875 ++++++++++++++++++++++++++++ package.yaml | 1 + src/Language/PureScript/Docs.hs | 1 + src/Language/PureScript/Docs/Css.hs | 31 + 6 files changed, 919 insertions(+), 10 deletions(-) create mode 100644 app/static/pursuit.less create mode 100644 src/Language/PureScript/Docs/Css.hs diff --git a/app/Command/Docs/Html.hs b/app/Command/Docs/Html.hs index ba53b9a550..0352fce7f3 100644 --- a/app/Command/Docs/Html.hs +++ b/app/Command/Docs/Html.hs @@ -15,7 +15,6 @@ import Data.List (sort) import Data.Text (Text) import Data.Text.Lazy (toStrict) import qualified Data.Text as T -import Data.FileEmbed (embedStringFile) import qualified Language.PureScript as P import qualified Language.PureScript.Docs as D import qualified Language.PureScript.Docs.AsHtml as D @@ -133,9 +132,9 @@ basicLayout title inner = H.link ! A.href "https://fonts.googleapis.com/css?family=Roboto+Mono|Roboto:300,400,400i,700,700i" ! A.type_ "text/css" ! A.rel "stylesheet" H.style ! A.type_ "text/css" $ - toMarkup normalize_css + toMarkup D.normalizeCssT H.style ! A.type_ "text/css" $ - toMarkup pursuit_css + toMarkup D.pursuitCssT H.body $ do H.div ! A.class_ "everything-except-footer" $ do H.div ! A.class_ "top-banner clearfix" $ do @@ -173,9 +172,3 @@ renderModuleList moduleList = listItem mn = H.li $ H.a ! A.href (H.toValue (P.runModuleName mn <> ".html")) $ toMarkup (P.runModuleName mn) - -normalize_css :: Text -normalize_css = $(embedStringFile "app/static/normalize.css") - -pursuit_css :: Text -pursuit_css = $(embedStringFile "app/static/pursuit.css") diff --git a/app/static/pursuit.css b/app/static/pursuit.css index d250c36aff..dd4671995f 100644 --- a/app/static/pursuit.css +++ b/app/static/pursuit.css @@ -1,5 +1,5 @@ /** ************************************************************************* * - ** Pursuit CSS + ** CSS for HTML docs (e.g. Pursuit) ** ** STRUCTURE ** @@ -36,6 +36,14 @@ ** To make use of this modular scale, use a ratio of the form ** (5/4)^n ** where n ∈ ℤ, -6 ≤ n ≤ 8. + ** + ** LESS + ** + ** This CSS is generated by less. To compile it: + ** + ** npm install [-g] less + ** lessc app/static/pursuit.less > app/static/pursuit.css + ** ** ************************************************************************* */ /* Section: Variables * ========================================================================== */ diff --git a/app/static/pursuit.less b/app/static/pursuit.less new file mode 100644 index 0000000000..1b064b2c5f --- /dev/null +++ b/app/static/pursuit.less @@ -0,0 +1,875 @@ +/** ************************************************************************* * + ** CSS for HTML docs (e.g. Pursuit) + ** + ** STRUCTURE + ** + ** This CSS file is structured into several sections, from general to + ** specific, and (mostly) alphabetically within the sections. + ** + ** Several global element styles are used. This is not encouraged and should + ** be kept to a minimum. If you want to add new styles you'll most likely + ** want to add a new CSS component. See the Components section for examples. + ** + ** CSS components use three simple naming ideas from the BEM system: + ** - Block: `.my-component` + ** - Element: `.my-component__item` + ** - Modifier: `.my-component.my-component--highlighted` + ** + ** Example: + **
+ **
+ **
+ ** ... + **
+ **
+ **
+ ** + ** Components can be nested. + ** + ** + ** TYPOGRAPHY + ** + ** Typographic choices for sizes, line-heights and margins are based on a + ** musical major third scale (4:5). This gives us a way to find numbers + ** and relationships between them that are perceived as harmonic. + ** + ** To make use of this modular scale, use a ratio of the form + ** (5/4)^n + ** where n ∈ ℤ, -6 ≤ n ≤ 8. + ** + ** LESS + ** + ** This CSS is generated by less. To compile it: + ** + ** npm install [-g] less + ** lessc app/static/pursuit.less > app/static/pursuit.css + ** + ** ************************************************************************* */ + +/* Section: Variables + * ========================================================================== */ +@background: rgb(255, 255, 255); +@banner_background: rgb(29, 34, 45); +@package_banner_background: lighten(@banner_background, 30%); +@dark_foreground: rgb(240, 240, 240); +@link: rgb(196, 149, 58); +@link_active: rgb(123, 89, 4); +@error_background: rgb(255, 240, 240); +@error_border: rgb(200, 80, 80); +@not_available_background: rgb(240, 240, 150); +@code_foreground: rgb(25, 74, 91); +@code_background: rgb(241, 245, 249); +@light_glyph: rgb(160, 160, 160); +@light_type: rgb(102, 102, 102); + +/* Section: Document Styles + * ========================================================================== */ + +html { + box-sizing: border-box; + + /* This overflow rule prevents everything from shifting slightly to the side + when moving from a page which isn't large enough to generate a scrollbar + to one that is. */ + overflow-y: scroll; +} + +*, *::before, *::after { + box-sizing: inherit; +} + +body { + background-color: @background; + color: #000; + font-family: "Roboto", sans-serif; + font-size: 87.5%; + line-height: 1.563; +} + +@media (min-width: 38em) { + body { + font-size: 100%; + } +} + + +/* Section: Utility Classes + * ========================================================================== */ + +.clear-floats { + clear: both; +} + +.clearfix::before, +.clearfix::after { + content: " "; + display: table; +} + +.clearfix::after { + clear: both; +} + +/* Content hidden like this will still be read by a screen reader */ +.hide-visually { + position: absolute; + left: -10000px; + top: auto; + width: 1px; + height: 1px; + overflow: hidden; +} + + +/* Section: Layout + * ========================================================================== */ + +.container { + display: block; + max-width: 66em; + margin-left: auto; + margin-right: auto; + padding-left: 20px; + padding-right: 20px; +} + +.col { + display: block; + position: relative; + width: 100%; +} + +.col.col--main { + margin-bottom: 3.08em; +} + +.col.col--aside { + margin-bottom: 2.44em; +} + +@media (min-width: 52em) { + .container { + padding-left: 30px; + padding-right: 30px; + } + + .col.col--main { + float: left; + width: 63.655%; /* 66.6…% - 30px */ + } + + .col.col--aside { + float: right; + font-size: 87.5%; + width: 33.333333%; + } +} + +@media (min-width: 66em) { + .col.col--aside { + font-size: inherit; + } +} + + +/* Footer + * Based on http://www.lwis.net/journal/2008/02/08/pure-css-sticky-footer/ + * Except we don't support IE6 + * -------------------------------------------------------------------------- */ + +html, body { + height: 100%; +} + +.everything-except-footer { + min-height: 100%; + padding-bottom: 3em; +} + +.footer { + position: relative; + height: 3em; + margin-top: -3em; + width: 100%; + text-align: center; + background-color: @banner_background; + color: @dark_foreground; +} + +.footer * { + margin-bottom: 0; +} + + +/* Section: Element Styles + * + * Have as few of these as possible and keep them general, because they will + * influence every component hereafter. + * ========================================================================== */ + +:target { + background-color: @code_background; +} + +a, a:visited { + color: @link; + text-decoration: none; + font-weight: bold; +} + +a:hover { + color: @link_active; + text-decoration: none; +} + +code, pre { + background-color: @code_background; + border-radius: 3px; + color: @code_foreground; + font-family: "Roboto Mono", monospace; + font-size: 87.5%; +} + +:target code, +:target pre { + background-color: darken(@code_background, 5%); +} + +code { + padding: 0.2em 0; + margin: 0; + white-space: pre-wrap; + word-wrap: break-word; +} + +code::before, +code::after { + letter-spacing: -0.2em; + content: "\00a0"; +} + +a > code { + font-weight: normal; +} + +a > code::before { + content: "🡒"; + letter-spacing: 0.33em; +} + +a:hover > code { + color: @link; +} + +pre { + margin-top: 0; + margin-bottom: 0; + padding: 1em 1.25rem; /* Using rem here to align with lists etc. */ + overflow: auto; + white-space: pre; + word-wrap: normal; +} + +pre code { + background-color: transparent; + border: 0; + font-size: 100%; + max-width: auto; + padding: 0; + margin: 0; + overflow: visible; + line-height: inherit; + white-space: pre; + word-break: normal; + word-wrap: normal; +} + +pre code::before, +pre code::after { + content: normal; +} + +h1 { + font-size: 3.052em; + font-weight: 300; + letter-spacing: -0.5px; + line-height: 1.125; + margin-top: 1.563rem; + margin-bottom: 1.25rem; +} + +@media (min-width: 52em) { + h1 { + font-size: 3.814em; + margin-top: 5.96rem; + } +} + +h2 { + font-size: 1.953em; + font-weight: normal; + line-height: 1.250; + margin-top: 3.052rem; + margin-bottom: 1rem; +} + +h3 { + font-size: 1.563em; + font-weight: normal; + line-height: 1.250; + margin-top: 2.441rem; + margin-bottom: 1rem; +} + +h4 { + font-size: 1.25em; + font-weight: normal; + margin-top: 2.441rem; + margin-bottom: 1rem; +} + +h1 + h2, +h1 + h3, +h1 + h4, +h2 + h3, +h2 + h4, +h3 + h4 { + margin-top: 1rem; +} + +hr { + border: none; + height: 1px; + background-color: darken(@background, 20%); +} + +img { + border-style: none; + max-width: 100%; +} + +p { + font-size: 1em; + margin-top: 1rem; + margin-bottom: 1rem; +} + +table { + border-bottom: 1px solid darken(@background, 20%); + border-collapse: collapse; + border-spacing: 0; + margin-top: 1rem; + margin-bottom: 1rem; + width: 100%; +} + +td, th { + text-align: left; + padding: 0.41em 0.51em; +} + +td { + border-top: 1px solid darken(@background, 20%); +} + +td:first-child, th:first-child { + padding-left: 0; +} + +td:last-child, th:last-child { + padding-right: 0; +} + +ul { + list-style-type: none; + margin-top: 1rem; + margin-bottom: 1rem; + padding-left: 0; +} + +ul li { + position: relative; + padding-left: 1.250em; +} + +ul li::before { + position: absolute; + color: @light_glyph; + content: "–"; + display: inline-block; + margin-left: -1.250em; + width: 1.250em; +} + +/* Tying this tightly to ul at the moment because it's a slight variation thereof */ +ul.ul--search li::before { + content: "⚲"; + top: -0.2em; + transform: rotate(-45deg); +} + +ol { + margin-top: 1rem; + margin-bottom: 1rem; + padding-left: 1.250em; +} + +ol li { + position: relative; + padding-left: 0; +} + + +/* Section: Components + * ========================================================================== */ + +/* Component: Badge + * -------------------------------------------------------------------------- */ + +.badge { + position: relative; + top: -0.1em; + display: inline-block; + background-color: #000; + border-radius: 1.3em; + color: #fff; + font-size: 77%; + font-weight: bold; + line-height: 1.563; + text-align: center; + height: 1.5em; + width: 1.5em; +} + +.badge.badge--package { + background-color: @link; + letter-spacing: -0.1em; +} + +.badge.badge--module { + background-color: #75B134; +} + + +/* Component: Declarations + * -------------------------------------------------------------------------- */ + +.decl {} + +.decl__title { + position: relative; + padding-bottom: 0.328em; + margin-bottom: 0.262em; +} + +.decl__source { + display: block; + float: right; + font-size: 64%; + position: relative; + top: 0.57em; +} + +.decl__anchor, .decl__anchor:visited { + position: absolute; + left: -0.8em; + color: lighten(@light_glyph, 10%); +} + +.decl__anchor:hover { + color: @link; +} + +.decl__signature { + background-color: transparent; + border-radius: 0; + border-top: 1px solid darken(@background, 20%); + border-bottom: 1px solid darken(@background, 20%); + padding: 0.328em 0; +} + +.decl__signature code { + display: block; + padding-left: 2.441em; + text-indent: -2.441em; + white-space: normal; +} + +:target .decl__signature, +:target .decl__signature code { + /* We want the background to be transparent, even when the parent is a target */ + background-color: transparent; +} + +.decl__body .keyword, +.decl__body .syntax { + color: #0B71B4; +} + +.decl__child_comments { + margin-top: 1rem; + margin-bottom: 1rem; +} + +/* Component: Dependency Link + * -------------------------------------------------------------------------- */ + +.deplink { /* Currently no root styles, but keep the class as a namespace */ } + +.deplink__link { + display: inline-block; + margin-right: 0.41em; +} + +.deplink__version { + color: @light_type; + display: inline-block; + font-size: 0.8em; + line-height: 1; +} + + +/* Component: Grouped List + * -------------------------------------------------------------------------- */ + +.grouped-list { + border-top: 1px solid darken(@background, 20%); + margin: 0 0 2.44em 0; +} + +.grouped-list__title { + color: @light_type; + font-size: 0.8em; + font-weight: 300; + letter-spacing: 1px; + margin: 0.8em 0 -0.1em 0; + text-transform: uppercase; +} + +.grouped-list__item { + margin: 0; +} + + +/* Component: Message + * -------------------------------------------------------------------------- */ + +.message { + border: 5px solid; + border-radius: 5px; + padding: 1em !important; +} + +.message.message--error { + background-color: @error_background; + border-color: @error_border; +} + +.message.message--not-available { + background-color: @not_available_background; + border-color: darken(@not_available_background, 20%); +} + + +/* Component: Multi Col + * Multiple columns side by side + * -------------------------------------------------------------------------- */ + +.multi-col { + margin-bottom: 2.44em; +} + +.multi-col__col { + display: block; + padding-right: 1em; + position: relative; + width: 100%; +} + +@media (min-width: 38em) and (max-width: 51.999999em) { + .multi-col__col { + float: left; + width: 50%; + } + + .multi-col__col:nth-child(2n+3) { + clear: both; + } +} + +@media (min-width: 52em) { + .multi-col__col { + float: left; + width: 33.333333%; + } + + .multi-col__col:nth-child(3n+4) { + clear: both; + } +} + + +/* Component: Page Title + * -------------------------------------------------------------------------- */ + +.page-title { + margin: 4.77em 0 1.56em; + padding-bottom: 1.25em; + position: relative; +} + +.page-title__title { + margin: 0 0 0 -0.05em; /* Visually align on left edge */ +} + +.page-title__label { + position: relative; + color: @light_type; + font-size: 0.8rem; + font-weight: 300; + letter-spacing: 1px; + margin-bottom: -0.8em; + text-transform: uppercase; + z-index: 1; +} + + +/* Component: Top Banner + * -------------------------------------------------------------------------- */ + +.top-banner { + background-color: @banner_background; + color: @dark_foreground; + font-weight: normal; +} + +.top-banner__logo, +.top-banner__logo:visited { + float: left; + color: @dark_foreground; + font-size: 2.44em; + font-weight: 300; + line-height: 90px; + margin: 0; +} + +.top-banner__logo:hover { + color: @link; + text-decoration: none; +} + +.top-banner__form { + margin-bottom: 1.25em; +} + +.top-banner__form input { + border: 1px solid @banner_background; + border-radius: 3px; + color: @banner_background; + font-weight: 300; + line-height: 2; + padding: 0.21em 0.512em; + width: 100%; +} + +.top-banner__actions { + float: right; + text-align: right; +} + +.top-banner__actions__item { + display: inline-block; + line-height: 90px; + margin: 0; + padding-left: 1.25em; +} + +.top-banner__actions__item:first-child { + padding-left: 0; +} + +.top-banner__actions__item a, +.top-banner__actions__item a:visited { + color: @dark_foreground; +} + +.top-banner__actions__item a:hover { + color: @link; +} + +@media (min-width: 38em) { + .top-banner__logo { + float: left; + width: 25%; + } + + .top-banner__form { + float: left; + line-height: 90px; + margin-bottom: 0; + width: 50%; + } + + .top-banner__actions { + float: right; + width: 25%; + } +} + + +/* Component: Search Results + * -------------------------------------------------------------------------- */ + +.result {} + +.result.result--empty { + font-size: 1.25em; +} + +.result__title { + font-size: 1.25em; + margin-bottom: 0.2rem; +} + +.result__badge { + margin-left: -0.1em; +} + +.result__body > *:first-child { + margin-top: 0!important; +} + +.result__body > *:last-child { + margin-bottom: 0!important; +} + +.result__signature { + background-color: transparent; + border-radius: 0; + border-top: 1px solid darken(@background, 20%); + border-bottom: 1px solid darken(@background, 20%); + padding: 0.328em 0; +} + +.result__signature code { + display: block; + padding-left: 2.441em; + text-indent: -2.441em; + white-space: normal; +} + +.result__actions { + margin-top: 0.2rem; +} + +.result__actions__item { + font-size: 80%; +} + +.result__actions__item + .result__actions__item { + margin-left: 0.65em; +} + + +/* Component: Version Selector + * -------------------------------------------------------------------------- */ + +.version-selector { + margin-bottom: 0.8em; +} + +@media (min-width: 38em) { + .version-selector { + position: absolute; + top: 0.8em; + right: 0; + margin-bottom: 0; + } +} + + +/* Section: FIXME + * These styles should be cleaned up + * ========================================================================== */ + +/* Help paragraphs */ +.help { + padding: 5px 0; +} + +.help h3 { /* FIXME: target with class */ + margin-top: 16px; +} + + +/* Section: Markdown + * Github rendered README + * ========================================================================== */ + +.markdown-body { + /* + Useful for narrow screens, such as mobiles. Documentation often contains URLs + which would otherwise force the page to become wider, and force creation of + horizontal scrollbars. Yuck. + */ + word-wrap: break-word; +} + +.markdown-body>*:first-child { + margin-top: 0 !important; +} + +.markdown-body>*:last-child { + margin-bottom: 0 !important; +} + +.markdown-body a:not([href]) { + color: inherit; + text-decoration: none; +} + +.markdown-body blockquote { + margin: 0; + padding: 0 1em; + color: #777; + border-left: 0.25em solid #ddd; +} + +.markdown-body blockquote>:first-child { + margin-top: 0; +} + +.markdown-body blockquote>:last-child { + margin-bottom: 0; +} + +.markdown-body .anchor { + /* We hide the anchor because the link doesn't point to a valid location */ + display: none; +} + +.markdown-body .pl-k { + /* Keyword */ + color: #a0a0a0; +} + +.markdown-body .pl-c1, +.markdown-body .pl-en { + /* Not really sure what this is */ + color: #39d; +} + +.markdown-body .pl-s { + /* String literals */ + color: #1a1; +} + +.markdown-body .pl-cce { + /* String literal escape sequences */ + color: #921; +} + +.markdown-body .pl-smi { + /* type variables? */ + color: #62b; +} diff --git a/package.yaml b/package.yaml index f30357c964..6a6fcc9d3b 100644 --- a/package.yaml +++ b/package.yaml @@ -49,6 +49,7 @@ dependencies: - directory >=1.2.3 - dlist - edit-distance + - file-embed - filepath - fsnotify >=0.2.1 - Glob >=0.7 && <0.8 diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs index 7773952e78..f63544c639 100644 --- a/src/Language/PureScript/Docs.hs +++ b/src/Language/PureScript/Docs.hs @@ -12,3 +12,4 @@ import Language.PureScript.Docs.ParseInPackage as Docs import Language.PureScript.Docs.Render as Docs import Language.PureScript.Docs.RenderedCode as Docs import Language.PureScript.Docs.Types as Docs +import Language.PureScript.Docs.Css as Docs diff --git a/src/Language/PureScript/Docs/Css.hs b/src/Language/PureScript/Docs/Css.hs new file mode 100644 index 0000000000..9567db96e3 --- /dev/null +++ b/src/Language/PureScript/Docs/Css.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-} +module Language.PureScript.Docs.Css where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.FileEmbed (embedFile) + +-- | +-- An embedded copy of normalize.css as a UTF-8 encoded ByteString; this should +-- be included before pursuit.css in any HTML page using pursuit.css. +-- +normalizeCss :: ByteString +normalizeCss = $(embedFile "app/static/normalize.css") + +-- | +-- Like 'normalizeCss', but as a 'Text'. +normalizeCssT :: Text +normalizeCssT = decodeUtf8 normalizeCss + +-- | +-- CSS for use with generated HTML docs, as a UTF-8 encoded ByteString. +-- +pursuitCss :: ByteString +pursuitCss = $(embedFile "app/static/pursuit.css") + +-- | +-- Like 'pursuitCss', but as a 'Text'. +-- +pursuitCssT :: Text +pursuitCssT = decodeUtf8 pursuitCss From 7e499cf13b729cca868c966098e0cca91c591edf Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sat, 5 Aug 2017 22:22:43 +0100 Subject: [PATCH 0839/1580] [purs ide] Add qualified explicit import (#3024) - Optional qualifier added to explicit import command - Update PROTOCOL.md overview and some typos --- psc-ide/PROTOCOL.md | 52 +++++++-- src/Language/PureScript/Ide.hs | 4 +- src/Language/PureScript/Ide/Command.hs | 7 +- src/Language/PureScript/Ide/Imports.hs | 27 ++--- tests/Language/PureScript/Ide/ImportsSpec.hs | 109 +++++++++++++++---- 5 files changed, 148 insertions(+), 51 deletions(-) diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index 65629a889d..e5b12d110a 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -1,10 +1,16 @@ # Protocol -Encode the following JSON formats into a single line string and pass them to -`psc-ide-client`s stdin. You can then read the result from `psc-ide-client`s -stdout as a single line. The result needs to be unwrapped from the "wrapper" -which separates success from failure. This wrapper is described at the end of -this document. +Communication with `purs ide server` is via a JSON protocol over a TCP connection: +the server listens on a particular (configurable) port, and will accept a single line +of JSON input in the format described below, terminated by a newline, before giving +a JSON response and closing the connection. + +The `purs ide client` command can be used as a wrapper for the TCP connection, but +otherwise behaves the same, accepting a line of JSON on stdin and exiting after +giving a result on stdout. + +The result needs to be unwrapped from the "wrapper" which separates success +from failure. This wrapper is described at the end of this document. ## Command: ### Load @@ -218,7 +224,7 @@ Example: This command just adds an unqualified import for the given modulename. Arguments: -- `moduleName :: String` +- `module :: String` Example: ```json @@ -239,7 +245,8 @@ Example: This command adds an import for the given modulename and qualifier. Arguments: -- `moduleName :: String` +- `module :: String` +- `qualifier :: String` Example: ```json @@ -264,13 +271,14 @@ match it adds the import and returns. If it finds more than one match it responds with a list of the found matches as completions like the complete command. -You can also supply a list of filters like the ones for completion. This way you -can narrow down the search to a certain module and resolve the case in which +You can also supply a list of filters like the ones for completion. These are +specified as part of the top level command rather than within the `importCommand`. +This way you can narrow down the search to a certain module and resolve the case in which more then one match was found. Arguments: -- `moduleName :: String` -- `filters :: [Filter]` +- `identifier :: String` +- `qualifier :: String` (optional) Example: ```json @@ -287,6 +295,28 @@ Example: } ``` +Example with qualifier and filter: +```json +{ + "command": "import", + "params": { + "file": "/home/creek/Documents/chromacannon/src/Demo.purs", + "outfile": "/home/creek/Documents/chromacannon/src/Demo.purs", + "importCommand": { + "importCommand": "addImport", + "identifier": "length", + "qualifier": "Array" + }, + "filters": [{ + "filter": "modules", + "params": { + "modules": ["Data.Array"] + } + }] + } +} +``` + ### Rebuild The `rebuild` command provides a fast rebuild for a single module. It doesn't diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 4c947ea99f..4c6eb0da4d 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -81,8 +81,8 @@ handleCommand c = case c of Import fp outfp _ (AddQualifiedImport mn qual) -> do rs <- addQualifiedImport fp mn qual answerRequest outfp rs - Import fp outfp filters (AddImportForIdentifier ident) -> do - rs <- addImportForIdentifier fp ident filters + Import fp outfp filters (AddImportForIdentifier ident qual) -> do + rs <- addImportForIdentifier fp ident qual filters case rs of Right rs' -> answerRequest outfp rs' Left question -> diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 5763fcb5a2..a8383b3290 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -82,7 +82,7 @@ commandName c = case c of data ImportCommand = AddImplicitImport P.ModuleName | AddQualifiedImport P.ModuleName P.ModuleName - | AddImportForIdentifier Text + | AddImportForIdentifier Text (Maybe P.ModuleName) deriving (Show, Eq) instance FromJSON ImportCommand where @@ -96,7 +96,10 @@ instance FromJSON ImportCommand where <$> (P.moduleNameFromString <$> o .: "module") <*> (P.moduleNameFromString <$> o .: "qualifier") "addImport" -> - AddImportForIdentifier <$> o .: "identifier" + AddImportForIdentifier + <$> (o .: "identifier") + <*> (fmap P.moduleNameFromString <$> o .:? "qualifier") + _ -> mzero data ListType = LoadedModules | Imports FilePath | AvailableModules diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 1714b8eff6..beed3d6c3b 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -165,27 +165,27 @@ addQualifiedImport' imports mn qualifier = -- @import Prelude (bind)@ in the file File.purs returns @["import Prelude -- (bind, unit)"]@ addExplicitImport :: (MonadIO m, MonadError IdeError m) => - FilePath -> IdeDeclaration -> P.ModuleName -> m [Text] -addExplicitImport fp decl moduleName = do + FilePath -> IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> m [Text] +addExplicitImport fp decl moduleName qualifier = do (mn, pre, imports, post) <- parseImportsFromFile' fp let newImportSection = -- TODO: Open an issue when this PR is merged, we should optimise this -- so that this case does not write to disc if mn == moduleName then imports - else addExplicitImport' decl moduleName imports + else addExplicitImport' decl moduleName qualifier imports pure (pre ++ prettyPrintImportSection newImportSection ++ post) -addExplicitImport' :: IdeDeclaration -> P.ModuleName -> [Import] -> [Import] -addExplicitImport' decl moduleName imports = +addExplicitImport' :: IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> [Import] -> [Import] +addExplicitImport' decl moduleName qualifier imports = let isImplicitlyImported = not . null $ filter (\case - (Import mn P.Implicit Nothing) -> mn == moduleName + (Import mn P.Implicit qualifier') -> mn == moduleName && qualifier == qualifier' _ -> False) imports - matches (Import mn (P.Explicit _) Nothing) = mn == moduleName + matches (Import mn (P.Explicit _) qualifier') = mn == moduleName && qualifier == qualifier' matches _ = False - freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) Nothing + freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) qualifier in if isImplicitlyImported then imports @@ -209,8 +209,8 @@ addExplicitImport' decl moduleName imports = -- | Adds a declaration to an import: -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) insertDeclIntoImport :: IdeDeclaration -> Import -> Import - insertDeclIntoImport decl' (Import mn (P.Explicit refs) Nothing) = - Import mn (P.Explicit (sortBy P.compDecRef (insertDeclIntoRefs decl' refs))) Nothing + insertDeclIntoImport decl' (Import mn (P.Explicit refs) qual) = + Import mn (P.Explicit (sortBy P.compDecRef (insertDeclIntoRefs decl' refs))) qual insertDeclIntoImport _ is = is insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef] @@ -251,10 +251,11 @@ updateAtFirstOrPrepend p t d l = addImportForIdentifier :: (Ide m, MonadError IdeError m) => FilePath -- ^ The Sourcefile to read from -> Text -- ^ The identifier to import + -> Maybe P.ModuleName -- ^ The optional qualifier under which to import -> [Filter] -- ^ Filters to apply before searching for -- the identifier -> m (Either [Match IdeDeclaration] [Text]) -addImportForIdentifier fp ident filters = do +addImportForIdentifier fp ident qual filters = do modules <- getAllModules Nothing case map (fmap discardAnn) (getExactMatches ident filters modules) of [] -> @@ -264,7 +265,7 @@ addImportForIdentifier fp ident filters = do -- Only one match was found for the given identifier, so we can insert it -- right away [Match (m, decl)] -> - Right <$> addExplicitImport fp decl m + Right <$> addExplicitImport fp decl m qual -- This case comes up for newtypes and dataconstructors. Because values and -- types don't share a namespace we can get multiple matches from the same @@ -281,7 +282,7 @@ addImportForIdentifier fp ident filters = do -- dataconstructor as that will give us an unnecessary import warning at -- worst Just decl -> - Right <$> addExplicitImport fp decl m1 + Right <$> addExplicitImport fp decl m1 qual -- Here we need the user to specify whether he wanted a dataconstructor -- or a type diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index e95309f2c3..2dd0b8fa37 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -100,16 +100,17 @@ spec = do describe "import commands" $ do let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i - addValueImport i mn is = - prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValue i Nothing)) mn is) - addOpImport op mn is = - prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValueOp op (P.Qualified Nothing (Left "")) 2 Nothing Nothing)) mn is) - addDtorImport i t mn is = - prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideDtor i t Nothing)) mn is) - addTypeImport i mn is = - prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideType i Nothing [])) mn is) - addKindImport i mn is = - prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideKind i)) mn is) + addValueImport i mn q is = + prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValue i Nothing)) mn q is) + addOpImport op mn q is = + prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValueOp op (P.Qualified q (Left "")) 2 Nothing Nothing)) mn q is) + addDtorImport i t mn q is = + prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideDtor i t Nothing)) mn q is) + addTypeImport i mn q is = + prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideType i Nothing [])) mn q is) + addKindImport i mn q is = + prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideKind i)) mn q is) + qualify s = Just (Test.mn s) it "adds an implicit unqualified import to a file without any imports" $ shouldBe (addImplicitImport' [] (P.moduleNameFromString "Data.Map")) @@ -129,84 +130,146 @@ spec = do ] it "adds an explicit unqualified import to a file without any imports" $ shouldBe - (addValueImport "head" (P.moduleNameFromString "Data.Array") []) + (addValueImport "head" (P.moduleNameFromString "Data.Array") Nothing []) ["import Data.Array (head)"] + it "adds an explicit qualified import to a file without any imports" $ + shouldBe + (addValueImport "head" (P.moduleNameFromString "Data.Array") (qualify "Array") []) + ["import Data.Array (head) as Array"] it "adds an explicit unqualified import" $ shouldBe - (addValueImport "head" (P.moduleNameFromString "Data.Array") simpleFileImports) + (addValueImport "head" (P.moduleNameFromString "Data.Array") Nothing simpleFileImports) [ "import Prelude" , "" , "import Data.Array (head)" ] + it "adds an explicit qualified import" $ + shouldBe + (addValueImport "head" (P.moduleNameFromString "Data.Array") (qualify "Array") simpleFileImports) + [ "import Prelude" + , "" + , "import Data.Array (head) as Array" + ] it "doesn't add an import if the containing module is imported implicitly" $ shouldBe - (addValueImport "const" (P.moduleNameFromString "Prelude") simpleFileImports) + (addValueImport "const" (P.moduleNameFromString "Prelude") Nothing simpleFileImports) ["import Prelude"] + let Right (_, _, qualifiedImports, _) = sliceImportSection (withImports ["import Data.Array as Array"]) + it "doesn't add a qualified explicit import if the containing module is imported qualified" $ + shouldBe + (addValueImport "length" (P.moduleNameFromString "Data.Array") (qualify "Array") qualifiedImports) + ["import Prelude" + , "" + , "import Data.Array as Array"] let Right (_, _, explicitImports, _) = sliceImportSection (withImports ["import Data.Array (tail)"]) it "adds an identifier to an explicit import list" $ shouldBe - (addValueImport "head" (P.moduleNameFromString "Data.Array") explicitImports) + (addValueImport "head" (P.moduleNameFromString "Data.Array") Nothing explicitImports) [ "import Prelude" , "" , "import Data.Array (head, tail)" ] + let Right (_, _, explicitQualImports, _) = sliceImportSection (withImports ["import Data.Array (tail) as Array"]) + it "adds an identifier to an explicit qualified import list" $ + shouldBe + (addValueImport "head" (P.moduleNameFromString "Data.Array") (qualify "Array") explicitQualImports) + [ "import Prelude" + , "" + , "import Data.Array (head, tail) as Array" + ] it "adds a kind to an explicit import list" $ shouldBe - (addKindImport "Effect" (P.moduleNameFromString "Control.Monad.Eff") simpleFileImports) + (addKindImport "Effect" (P.moduleNameFromString "Control.Monad.Eff") Nothing simpleFileImports) [ "import Prelude" , "" , "import Control.Monad.Eff (kind Effect)" ] + it "adds a kind to an explicit qualified import list" $ + shouldBe + (addKindImport "Effect" (P.moduleNameFromString "Control.Monad.Eff") (qualify "Eff") simpleFileImports) + [ "import Prelude" + , "" + , "import Control.Monad.Eff (kind Effect) as Eff" + ] it "adds an operator to an explicit import list" $ shouldBe - (addOpImport "<~>" (P.moduleNameFromString "Data.Array") explicitImports) + (addOpImport "<~>" (P.moduleNameFromString "Data.Array") Nothing explicitImports) [ "import Prelude" , "" , "import Data.Array (tail, (<~>))" ] + it "adds an operator to an explicit qualified import list" $ + shouldBe + (addOpImport "<~>" (P.moduleNameFromString "Data.Array") (qualify "Array") explicitQualImports) + [ "import Prelude" + , "" + , "import Data.Array (tail, (<~>)) as Array" + ] it "adds a type with constructors without automatically adding an open import of said constructors " $ shouldBe - (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") simpleFileImports) + (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") Nothing simpleFileImports) [ "import Prelude" , "" , "import Data.Maybe (Maybe)" ] it "adds the type for a given DataConstructor" $ shouldBe - (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") simpleFileImports) + (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") Nothing simpleFileImports) [ "import Prelude" , "" , "import Data.Maybe (Maybe(..))" ] + it "adds the type for a given DataConstructor qualified" $ + shouldBe + (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") (qualify "M") simpleFileImports) + [ "import Prelude" + , "" + , "import Data.Maybe (Maybe(..)) as M" + ] it "adds a dataconstructor to an existing type import" $ do let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"]) shouldBe - (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") typeImports) + (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") Nothing typeImports) [ "import Prelude" , "" , "import Data.Maybe (Maybe(..))" ] + it "adds a dataconstructor to an existing qualified type import" $ do + let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe) as M"]) + shouldBe + (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") (qualify "M") typeImports) + [ "import Prelude" + , "" + , "import Data.Maybe (Maybe(..)) as M" + ] it "doesn't add a dataconstructor to an existing type import with open dtors" $ do let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe(..))"]) shouldBe - (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") typeImports) + (addDtorImport "Just" "Maybe" (P.moduleNameFromString "Data.Maybe") Nothing typeImports) [ "import Prelude" , "" , "import Data.Maybe (Maybe(..))" ] it "doesn't add an identifier to an explicit import list if it's already imported" $ shouldBe - (addValueImport "tail" (P.moduleNameFromString "Data.Array") explicitImports) + (addValueImport "tail" (P.moduleNameFromString "Data.Array") Nothing explicitImports) [ "import Prelude" , "" , "import Data.Array (tail)" ] + it "doesn't add an identifier to an explicit qualified import list if it's already imported qualified" $ + shouldBe + (addValueImport "tail" (P.moduleNameFromString "Data.Array") (qualify "Array") explicitQualImports) + [ "import Prelude" + , "" + , "import Data.Array (tail) as Array" + ] describe "explicit import sorting" $ do -- given some basic import skeleton let Right (_, _, baseImports, _) = sliceImportSection $ withImports ["import Control.Monad (ap)"] moduleName = (P.moduleNameFromString "Control.Monad") - addImport imports import' = addExplicitImport' import' moduleName imports + addImport imports import' = addExplicitImport' import' moduleName Nothing imports valueImport ident = _idaDeclaration (Test.ideValue ident Nothing) typeImport name = _idaDeclaration (Test.ideType name Nothing []) classImport name = _idaDeclaration (Test.ideTypeClass name P.kindType []) @@ -244,7 +307,7 @@ implImport mn = addExplicitImport :: Text -> Command addExplicitImport i = - Command.Import ("src" "ImportsSpec.purs") Nothing [] (Command.AddImportForIdentifier i) + Command.Import ("src" "ImportsSpec.purs") Nothing [] (Command.AddImportForIdentifier i Nothing) importShouldBe :: [Text] -> [Text] -> Expectation importShouldBe res importSection = From cb1393cacf0fc84c8e3bfb9301cf89475b48bab9 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 5 Aug 2017 16:59:03 -0700 Subject: [PATCH 0840/1580] Run AppendSymbol in reverse (#3025) --- examples/passing/AppendInReverse.purs | 24 +++++++++++++++++++ .../PureScript/TypeChecker/Entailment.hs | 24 +++++++++++++++---- tests/support/bower.json | 2 +- 3 files changed, 45 insertions(+), 5 deletions(-) create mode 100644 examples/passing/AppendInReverse.purs diff --git a/examples/passing/AppendInReverse.purs b/examples/passing/AppendInReverse.purs new file mode 100644 index 0000000000..735e1eeed5 --- /dev/null +++ b/examples/passing/AppendInReverse.purs @@ -0,0 +1,24 @@ +module Main where + +import Prelude +import Type.Data.Symbol (class AppendSymbol, SProxy(..)) +import Control.Monad.Eff.Console (log) + +class Balanced (sym :: Symbol) + +instance balanced1 :: Balanced "" +instance balanced2 + :: ( AppendSymbol "(" sym1 sym + , AppendSymbol sym2 ")" sym1 + , Balanced sym2 + ) => Balanced sym + +balanced :: forall sym. Balanced sym => SProxy sym -> String +balanced _ = "ok" + +main = do + log (balanced (SProxy :: SProxy "")) + log (balanced (SProxy :: SProxy "()")) + log (balanced (SProxy :: SProxy "(())")) + log (balanced (SProxy :: SProxy "((()))")) + log "Done" diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 2ab173496f..a9dd1e2bd7 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -27,7 +27,7 @@ import Data.List (minimumBy) import Data.Maybe (fromMaybe, maybeToList, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S -import Data.Text (Text) +import Data.Text (Text, stripPrefix, stripSuffix) import Language.PureScript.AST import Language.PureScript.Crash @@ -39,7 +39,7 @@ import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types import Language.PureScript.Label (Label(..)) -import Language.PureScript.PSString (PSString, mkString) +import Language.PureScript.PSString (PSString, mkString, decodeString) import qualified Language.PureScript.Constants as C -- | Describes what sort of dictionary to generate for type class instances @@ -162,8 +162,9 @@ entails SolverOptions{..} constraint context hints = GT -> C.orderingGT args = [arg0, arg1, TypeConstructor ordering] in [TypeClassDictionaryInScope CompareSymbolInstance [] C.CompareSymbol args Nothing] - forClassName _ C.AppendSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = - let args = [arg0, arg1, TypeLevelString (lhs <> rhs)] + forClassName _ C.AppendSymbol [arg0, arg1, arg2] + | Just (arg0', arg1', arg2') <- appendSymbols arg0 arg1 arg2 = + let args = [arg0', arg1', arg2'] in [TypeClassDictionaryInScope AppendSymbolInstance [] C.AppendSymbol args Nothing] forClassName _ C.Union [l, r, u] | Just (lOut, rOut, uOut, cst) <- unionRows l r u @@ -353,6 +354,21 @@ entails SolverOptions{..} constraint context hints = subclassDictionaryValue dict className index = App (Accessor (mkString (superclassName className index)) dict) valUndefined + -- | Append type level symbols, or, run backwards, strip a prefix or suffix + appendSymbols :: Type -> Type -> Type -> Maybe (Type, Type, Type) + appendSymbols arg0@(TypeLevelString lhs) arg1@(TypeLevelString rhs) _ = Just (arg0, arg1, TypeLevelString (lhs <> rhs)) + appendSymbols arg0@(TypeLevelString lhs) _ arg2@(TypeLevelString out) = do + lhs' <- decodeString lhs + out' <- decodeString out + rhs <- stripPrefix lhs' out' + pure (arg0, TypeLevelString (mkString rhs), arg2) + appendSymbols _ arg1@(TypeLevelString rhs) arg2@(TypeLevelString out) = do + rhs' <- decodeString rhs + out' <- decodeString out + lhs <- stripSuffix rhs' out' + pure (TypeLevelString (mkString lhs), arg1, arg2) + appendSymbols _ _ _ = Nothing + -- | Left biased union of two row types unionRows :: Type -> Type -> Type -> Maybe (Type, Type, Type, Maybe [Constraint]) unionRows l r _ = diff --git a/tests/support/bower.json b/tests/support/bower.json index 0973f7a8d8..9f21cd342e 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -35,7 +35,7 @@ "purescript-tailrec": "3.3.0", "purescript-tuples": "4.1.0", "purescript-type-equality": "2.1.0", - "purescript-typelevel-prelude": "2.3.0", + "purescript-typelevel-prelude": "#phil/append-symbol", "purescript-unfoldable": "3.0.0", "purescript-unsafe-coerce": "3.0.0" } From 59d1c6ae4c087aab001a2596270e56fa8e74fed4 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 6 Aug 2017 12:35:51 -0700 Subject: [PATCH 0841/1580] Revert "Run AppendSymbol in reverse (#3025)" (#3027) This reverts commit cb1393cacf0fc84c8e3bfb9301cf89475b48bab9. --- examples/passing/AppendInReverse.purs | 24 ------------------- .../PureScript/TypeChecker/Entailment.hs | 24 ++++--------------- tests/support/bower.json | 2 +- 3 files changed, 5 insertions(+), 45 deletions(-) delete mode 100644 examples/passing/AppendInReverse.purs diff --git a/examples/passing/AppendInReverse.purs b/examples/passing/AppendInReverse.purs deleted file mode 100644 index 735e1eeed5..0000000000 --- a/examples/passing/AppendInReverse.purs +++ /dev/null @@ -1,24 +0,0 @@ -module Main where - -import Prelude -import Type.Data.Symbol (class AppendSymbol, SProxy(..)) -import Control.Monad.Eff.Console (log) - -class Balanced (sym :: Symbol) - -instance balanced1 :: Balanced "" -instance balanced2 - :: ( AppendSymbol "(" sym1 sym - , AppendSymbol sym2 ")" sym1 - , Balanced sym2 - ) => Balanced sym - -balanced :: forall sym. Balanced sym => SProxy sym -> String -balanced _ = "ok" - -main = do - log (balanced (SProxy :: SProxy "")) - log (balanced (SProxy :: SProxy "()")) - log (balanced (SProxy :: SProxy "(())")) - log (balanced (SProxy :: SProxy "((()))")) - log "Done" diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index a9dd1e2bd7..2ab173496f 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -27,7 +27,7 @@ import Data.List (minimumBy) import Data.Maybe (fromMaybe, maybeToList, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S -import Data.Text (Text, stripPrefix, stripSuffix) +import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Crash @@ -39,7 +39,7 @@ import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types import Language.PureScript.Label (Label(..)) -import Language.PureScript.PSString (PSString, mkString, decodeString) +import Language.PureScript.PSString (PSString, mkString) import qualified Language.PureScript.Constants as C -- | Describes what sort of dictionary to generate for type class instances @@ -162,9 +162,8 @@ entails SolverOptions{..} constraint context hints = GT -> C.orderingGT args = [arg0, arg1, TypeConstructor ordering] in [TypeClassDictionaryInScope CompareSymbolInstance [] C.CompareSymbol args Nothing] - forClassName _ C.AppendSymbol [arg0, arg1, arg2] - | Just (arg0', arg1', arg2') <- appendSymbols arg0 arg1 arg2 = - let args = [arg0', arg1', arg2'] + forClassName _ C.AppendSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = + let args = [arg0, arg1, TypeLevelString (lhs <> rhs)] in [TypeClassDictionaryInScope AppendSymbolInstance [] C.AppendSymbol args Nothing] forClassName _ C.Union [l, r, u] | Just (lOut, rOut, uOut, cst) <- unionRows l r u @@ -354,21 +353,6 @@ entails SolverOptions{..} constraint context hints = subclassDictionaryValue dict className index = App (Accessor (mkString (superclassName className index)) dict) valUndefined - -- | Append type level symbols, or, run backwards, strip a prefix or suffix - appendSymbols :: Type -> Type -> Type -> Maybe (Type, Type, Type) - appendSymbols arg0@(TypeLevelString lhs) arg1@(TypeLevelString rhs) _ = Just (arg0, arg1, TypeLevelString (lhs <> rhs)) - appendSymbols arg0@(TypeLevelString lhs) _ arg2@(TypeLevelString out) = do - lhs' <- decodeString lhs - out' <- decodeString out - rhs <- stripPrefix lhs' out' - pure (arg0, TypeLevelString (mkString rhs), arg2) - appendSymbols _ arg1@(TypeLevelString rhs) arg2@(TypeLevelString out) = do - rhs' <- decodeString rhs - out' <- decodeString out - lhs <- stripSuffix rhs' out' - pure (TypeLevelString (mkString lhs), arg1, arg2) - appendSymbols _ _ _ = Nothing - -- | Left biased union of two row types unionRows :: Type -> Type -> Type -> Maybe (Type, Type, Type, Maybe [Constraint]) unionRows l r _ = diff --git a/tests/support/bower.json b/tests/support/bower.json index 9f21cd342e..0973f7a8d8 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -35,7 +35,7 @@ "purescript-tailrec": "3.3.0", "purescript-tuples": "4.1.0", "purescript-type-equality": "2.1.0", - "purescript-typelevel-prelude": "#phil/append-symbol", + "purescript-typelevel-prelude": "2.3.0", "purescript-unfoldable": "3.0.0", "purescript-unsafe-coerce": "3.0.0" } From 8c1bdf972852431599a7fafca1c7c9b4e423af94 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 6 Aug 2017 22:01:13 +0100 Subject: [PATCH 0842/1580] Use Hspec in TestDocs (#3028) This doesn't have any immediate effects apart from making the output of the docs tests slightly nicer. It does, however, get us one step closer to switching over to a nicer test runner such as tasty's (see #2848 for more details). --- tests/TestDocs.hs | 196 +++++++++++++++++++++++++++++++++------------- 1 file changed, 142 insertions(+), 54 deletions(-) diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 229631cc5c..e486988575 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -18,7 +18,6 @@ import Safe (headMay) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import Data.Text (Text) -import qualified Data.Text.IO as TIO import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) import Data.Version (Version(..)) @@ -30,9 +29,10 @@ import Language.PureScript.Docs.AsMarkdown (codeToString) import qualified Language.PureScript.Publish as Publish import qualified Language.PureScript.Publish.ErrorsWarnings as Publish -import Web.Bower.PackageMeta (parsePackageName) +import Web.Bower.PackageMeta (parsePackageName, runPackageName) import TestUtils +import Test.Hspec (Spec, it, context, expectationFailure, runIO, hspec) publishOpts :: Publish.PublishOptions publishOpts = Publish.defaultPublishOptions @@ -48,21 +48,48 @@ getPackage = Publish.preparePackage "bower.json" "resolutions.json" publishOpts main :: IO () -main = do - res <- getPackage - case res of - Left e -> Publish.printErrorToStdout e >> exitFailure - Right pkg@Docs.Package{..} -> - forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) -> - let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn)) - (find ((==) mn . Docs.modName) pkgModules) - linksCtx = Docs.getLinksContext pkg - in forM_ pragmas (\a -> runAssertionIO a linksCtx mdl) +main = hspec spec + +spec :: Spec +spec = do + pkg@Docs.Package{..} <- runIO $ do + res <- getPackage + case res of + Left e -> + Publish.printErrorToStdout e >> exitFailure + Right p -> + pure p + + let linksCtx = Docs.getLinksContext pkg + + context "Language.PureScript.Docs" $ + forM_ testCases $ \(mnString, assertions) -> do + let mn = P.moduleNameFromString mnString + mdl = find ((==) mn . Docs.modName) pkgModules + + context ("in module " ++ T.unpack mnString) $ do + case mdl of + Nothing -> + it "exists in docs output" $ + expectationFailure ("module not found in docs: " ++ T.unpack mnString) + Just mdl' -> + toHspec linksCtx mdl' assertions + + where + toHspec :: Docs.LinksContext -> Docs.Module -> [DocsAssertion] -> Spec + toHspec linksCtx mdl assertions = + forM_ assertions $ \a -> + it (T.unpack (displayAssertion a)) $ do + case runAssertion a linksCtx mdl of + Pass -> + pure () + Fail reason -> + expectationFailure (T.unpack (displayAssertionFailure reason)) takeJust :: String -> Maybe a -> a takeJust msg = fromMaybe (error msg) -data Assertion +data DocsAssertion -- | Assert that a particular declaration is documented with the given -- children = ShouldBeDocumented P.ModuleName Text [Text] @@ -79,10 +106,10 @@ data Assertion | ShouldHaveFunDeps P.ModuleName Text [([Text],[Text])] -- | Assert that a particular value declaration exists, and its type -- satisfies the given predicate. - | ValueShouldHaveTypeSignature P.ModuleName Text (ShowFn (P.Type -> Bool)) + | ValueShouldHaveTypeSignature P.ModuleName Text (P.Type -> Bool) -- | Assert that a particular instance declaration exists under some class or -- type declaration, and that its type satisfies the given predicate. - | InstanceShouldHaveTypeSignature P.ModuleName Text Text (ShowFn (P.Type -> Bool)) + | InstanceShouldHaveTypeSignature P.ModuleName Text Text (P.Type -> Bool) -- | Assert that a particular type alias exists, and its corresponding -- type, when rendered, matches a given string exactly -- fields: module, type synonym name, expected type @@ -100,14 +127,45 @@ data Assertion | ShouldHaveLink P.ModuleName Text Text Docs.Namespace Docs.LinkLocation -- | Assert that a given declaration comes before another in the output | ShouldComeBefore P.ModuleName Text Text - deriving (Show) - -newtype ShowFn a = ShowFn a - -instance Show (ShowFn a) where - show _ = "" -data AssertionFailure +displayAssertion :: DocsAssertion -> Text +displayAssertion = \case + ShouldBeDocumented mn decl children -> + showQual mn decl <> " should be documented" <> + (if not (null children) + then " with children: " <> T.pack (show children) + else "") + ShouldNotBeDocumented mn decl -> + showQual mn decl <> " should not be documented" + ChildShouldNotBeDocumented mn decl child -> + showQual mn decl <> " should not have " <> child <> " as a child declaration" + ShouldBeConstrained mn decl constraint -> + showQual mn decl <> " should have a " <> constraint <> " constraint" + ShouldHaveFunDeps mn decl fundeps -> + showQual mn decl <> " should have fundeps: " <> T.pack (show fundeps) + ValueShouldHaveTypeSignature mn decl _ -> + "the type signature for " <> showQual mn decl <> + " should satisfy the given predicate" + InstanceShouldHaveTypeSignature _ parent instName _ -> + "the instance " <> instName <> " (under " <> parent <> ") should have" <> + " a type signature satisfying the given predicate" + TypeSynonymShouldRenderAs mn synName code -> + "the RHS of the type synonym " <> showQual mn synName <> + " should be rendered as " <> code + ShouldHaveDocComment mn decl excerpt -> + "the string " <> T.pack (show excerpt) <> " should appear in the" <> + " doc-comments for " <> showQual mn decl + ShouldHaveReExport inPkg -> + "there should be some re-exports from " <> + showInPkg P.runModuleName inPkg + ShouldHaveLink mn decl targetTitle targetNs _ -> + "the rendered code for " <> showQual mn decl <> " should contain a link" <> + " to " <> targetTitle <> " (" <> T.pack (show targetNs) <> ")" + ShouldComeBefore mn declA declB -> + showQual mn declA <> " should come before " <> showQual mn declB <> + " in the docs" + +data DocsAssertionFailure -- | A declaration was not documented, but should have been = NotDocumented P.ModuleName Text -- | The expected list of child declarations did not match the actual list @@ -132,7 +190,7 @@ data AssertionFailure -- Fields: module name, declaration name, expected rendering, actual rendering | TypeSynonymMismatch P.ModuleName Text Text Text -- | A doc comment was not found or did not match what was expected - -- Fields: module name, expected substring, actual comments + -- Fields: module name, declaration, actual comments | DocCommentMissing P.ModuleName Text (Maybe Text) -- | A module was missing re-exports from a particular module. -- Fields: module name, expected re-export, actual re-exports. @@ -150,24 +208,52 @@ data AssertionFailure | BadLinkLocation P.ModuleName Text Text Docs.LinkLocation Docs.LinkLocation -- | Declarations were in the wrong order | WrongOrder P.ModuleName Text Text - deriving (Show) -displayAssertionFailure :: AssertionFailure -> Text +displayAssertionFailure :: DocsAssertionFailure -> Text displayAssertionFailure = \case - DeclarationWrongType mn title actual -> - P.runModuleName mn <> "." <> title <> " had the wrong type; got " <> T.pack (P.prettyPrintType actual) - WrongOrder mn before after -> - "In " <> P.runModuleName mn <> ": expected to see " <> before <> " before " <> after - -- TODO: deal with the other constructors nicely - other -> - T.pack (show other) - -data AssertionResult + NotDocumented _ decl -> + decl <> " was not documented, but should have been" + ChildrenNotDocumented _ decl children -> + decl <> " had the wrong children; got " <> T.pack (show children) + Documented _ decl -> + decl <> " was documented, but should not have been" + ChildDocumented _ decl child -> + decl <> " had " <> child <> " as a child" + ConstraintMissing _ decl constraint -> + decl <> " did not have a " <> constraint <> " constraint" + FunDepMissing _ decl fundeps -> + decl <> " had the wrong fundeps; got " <> T.pack (show fundeps) + WrongDeclarationType _ decl expected actual -> + "expected " <> decl <> " to be a " <> expected <> " declaration, but it" <> + " was a " <> actual <> " declaration" + DeclarationWrongType _ decl actual -> + decl <> " had the wrong type; got " <> T.pack (P.prettyPrintType actual) + TypeSynonymMismatch _ decl expected actual -> + "expected the RHS of " <> decl <> " to be " <> expected <> + "; got " <> actual + DocCommentMissing _ decl actual -> + "the doc-comment for " <> decl <> " did not contain the expected substring;" <> + " got " <> T.pack (show actual) + ReExportMissing _ expected actuals -> + "expected to see some re-exports from " <> + showInPkg P.runModuleName expected <> + "; instead only saw re-exports from " <> + T.pack (show (map (showInPkg P.runModuleName) actuals)) + LinkedDeclarationMissing _ decl target -> + "expected to find a link to " <> target <> " within the rendered code" <> + " for " <> decl <> ", but no such link was found" + BadLinkLocation _ decl target expected actual -> + "in rendered code for " <> decl <> ", bad link location for " <> target <> + ": expected " <> T.pack (show expected) <> + " got " <> T.pack (show actual) + WrongOrder _ before after -> + "expected to see " <> before <> " before " <> after + +data DocsAssertionResult = Pass - | Fail AssertionFailure - deriving (Show) + | Fail DocsAssertionFailure -runAssertion :: Assertion -> Docs.LinksContext -> Docs.Module -> AssertionResult +runAssertion :: DocsAssertion -> Docs.LinksContext -> Docs.Module -> DocsAssertionResult runAssertion assertion linksCtx Docs.Module{..} = case assertion of ShouldBeDocumented mn decl children -> @@ -217,7 +303,7 @@ runAssertion assertion linksCtx Docs.Module{..} = Fail (WrongDeclarationType mn decl "value" (Docs.declInfoToString declInfo)) - ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) -> + ValueShouldHaveTypeSignature mn decl tyPredicate -> findDecl mn decl $ \Docs.Declaration{..} -> case declInfo of Docs.ValueDeclaration ty -> @@ -228,7 +314,7 @@ runAssertion assertion linksCtx Docs.Module{..} = Fail (WrongDeclarationType mn decl "value" (Docs.declInfoToString declInfo)) - InstanceShouldHaveTypeSignature mn parent decl (ShowFn tyPredicate) -> + InstanceShouldHaveTypeSignature mn parent decl tyPredicate -> case find ((==) parent . Docs.declTitle) (declarationsFor mn) >>= findTarget of Just ty -> if tyPredicate ty @@ -349,16 +435,7 @@ checkConstrained ty tyClass = matches className = (==) className . P.runProperName . P.disqualify . P.constraintClass -runAssertionIO :: Assertion -> Docs.LinksContext -> Docs.Module -> IO () -runAssertionIO assertion linksCtx mdl = do - putStrLn ("In " ++ T.unpack (P.runModuleName (Docs.modName mdl)) ++ ": " ++ show assertion) - case runAssertion assertion linksCtx mdl of - Pass -> pure () - Fail reason -> do - TIO.putStrLn ("Failed: " <> displayAssertionFailure reason) - exitFailure - -testCases :: [(Text, [Assertion])] +testCases :: [(Text, [DocsAssertion])] testCases = [ ("Example", [ -- From dependencies @@ -436,9 +513,9 @@ testCases = ]) , ("ExplicitTypeSignatures", - [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something")) - , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==)) - , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==)) + [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (hasTypeVar "something") + , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (P.tyInt ==) + , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (P.tyNumber ==) ]) , ("ConstrainedArgument", @@ -499,8 +576,19 @@ testCases = isVar varName (P.TypeVar name) | varName == T.unpack name = True isVar _ _ = False - renderedType expected = - ShowFn $ \ty -> codeToString (Docs.renderType ty) == expected + renderedType expected ty = + codeToString (Docs.renderType ty) == expected shouldBeOrdered mn declNames = zipWith (ShouldComeBefore mn) declNames (tail declNames) + +showQual :: P.ModuleName -> Text -> Text +showQual mn decl = + P.runModuleName mn <> "." <> decl + +showInPkg :: (a -> Text) -> Docs.InPackage a -> Text +showInPkg f = \case + Docs.Local x -> + f x <> " (local)" + Docs.FromDep pkgName x -> + f x <> " (from dep: " <> runPackageName pkgName <> ")" From ee44ff01d217429e210aa143452d52fc137dfc33 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 6 Aug 2017 22:01:34 +0100 Subject: [PATCH 0843/1580] Fix AppVeyor deployment (#2774) (#3029) Tested on my fork of this repo. This commit also contains some minor additional tweaks: - update to stack 1.5.1 - update to node 6.x - remove semver regexp in appveyor.yml, as it isn't doing anything. --- appveyor.yml | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/appveyor.yml b/appveyor.yml index febdab7862..aedd5650a0 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -3,20 +3,23 @@ version: '{build}' environment: # Keep the path as short as possible, just in case. STACK_ROOT: c:\s - STACK_VER: 1.3.2 + STACK_VER: 1.5.1 RELEASE_USER: purescript RELEASE_REPO: purescript branches: # Only build master and tagged versions, i.e. not feature branches; feature # branches already get built after opening a pull request. + # + # Note that, unlike Travis CI, there is no need for a semver tag regexp + # here, as AppVeyor seems to build all tags which are reachable from any + # of the branches listed below. only: - master - - /^v\d+\.\d+(\.\d+)?(-\S*)?$/ cache: - c:\s -> appveyor/cache-buster.txt install: - git submodule update --init -- ps: Install-Product node 5 +- ps: Install-Product node 6 - npm install -g bower - ps: | @@ -38,9 +41,19 @@ build_script: # failed. - echo "" test_script: -- if defined APPVEYOR_REPO_TAG_NAME (set stack_extra_flags="--flag purescript:RELEASE") -- echo "stack_extra_flags=%stack_extra_flags%" -- stack --jobs=1 --no-terminal test --pedantic %stack_extra_flags% +- ps: | + $stack_extra_flags="" + if ($env:APPVEYOR_REPO_TAG_NAME) + { + $stack_extra_flags+="--flag purescript:RELEASE" + } + echo "stack_extra_flags = $stack_extra_flags" + + # This is an incredibly stupid workaround for a bizarre PowerShell + # 'feature' where any text printed to stderr is treated as the command + # having failed; see + # https://stackoverflow.com/questions/10666101/lastexitcode-0-but-false-in-powershell-redirecting-stderr-to-stdout-gives-n + cmd /c "stack --jobs=1 --no-terminal test --pedantic $stack_extra_flags 2>&1" on_success: - ps: | function UploadFile From 1b2011f0fb2744eb2b5541f4c609f549e5c54aca Mon Sep 17 00:00:00 2001 From: Felix Yan Date: Sat, 12 Aug 2017 12:19:54 -0500 Subject: [PATCH 0844/1580] Allow blaze-html 0.9 (#3031) Non of the changelog items were used by us, and the build is successful. --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 6a6fcc9d3b..a86f973363 100644 --- a/package.yaml +++ b/package.yaml @@ -37,7 +37,7 @@ dependencies: - ansi-terminal >=0.6.2 && <0.7 - base >=4.8 && <5 - base-compat >=0.6.0 - - blaze-html >=0.8.1 && <0.9 + - blaze-html >=0.8.1 && <0.10 - bower-json >=1.0.0.1 && <1.1 - boxes >=0.1.4 && <0.2.0 - bytestring From 7a59b02221df1f906efa4a911b8ad83c86d2fdc6 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 13 Aug 2017 20:39:41 +0200 Subject: [PATCH 0845/1580] Introduces a type for type declarations (#3034) * Introduces a data type for TypeDeclarations * extract a little helper * adds some comments --- app/Command/Docs/Tags.hs | 2 +- src/Language/PureScript/AST/Declarations.hs | 25 +++++++++++++++++-- src/Language/PureScript/AST/Traversals.hs | 6 ++--- .../PureScript/Docs/Convert/Single.hs | 2 +- src/Language/PureScript/Ide/CaseSplit.hs | 2 +- src/Language/PureScript/Ide/SourceFile.hs | 11 +++----- .../PureScript/Interactive/Completion.hs | 2 +- src/Language/PureScript/Interactive/Module.hs | 11 ++++---- src/Language/PureScript/Linter.hs | 2 +- .../PureScript/Parser/Declarations.hs | 2 +- src/Language/PureScript/Pretty/Values.hs | 4 +-- src/Language/PureScript/Sugar/Names.hs | 4 +-- .../PureScript/Sugar/Names/Exports.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 4 +-- src/Language/PureScript/Sugar/TypeClasses.hs | 20 +++++++-------- .../PureScript/Sugar/TypeDeclarations.hs | 4 +-- src/Language/PureScript/TypeChecker.hs | 4 +-- .../Language/PureScript/Ide/SourceFileSpec.hs | 4 +-- 18 files changed, 63 insertions(+), 48 deletions(-) diff --git a/app/Command/Docs/Tags.hs b/app/Command/Docs/Tags.hs index 6fd3275179..ecdbdbc7b2 100644 --- a/app/Command/Docs/Tags.hs +++ b/app/Command/Docs/Tags.hs @@ -10,7 +10,7 @@ tags = map (first T.unpack) . concatMap dtags . P.exportedDeclarations dtags :: P.Declaration -> [(P.Text, Int)] dtags (P.DataDeclaration (ss, _) _ name _ dcons) = (P.runProperName name, pos ss) : consNames where consNames = map (\(cname, _) -> (P.runProperName cname, pos ss)) dcons - dtags (P.TypeDeclaration (ss, _) ident _) = [(P.showIdent ident, pos ss)] + dtags (P.TypeDeclaration (P.TypeDeclarationData (ss, _) ident _)) = [(P.showIdent ident, pos ss)] dtags (P.ExternDeclaration (ss, _) ident _) = [(P.showIdent ident, pos ss)] dtags (P.TypeSynonymDeclaration (ss, _) name _ _) = [(P.runProperName name, pos ss)] dtags (P.TypeClassDeclaration (ss, _) name _ _ _ _) = [(P.runProperName name, pos ss)] diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 16249e18f2..057fc07408 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -407,6 +407,27 @@ isExplicit :: ImportDeclarationType -> Bool isExplicit (Explicit _) = True isExplicit _ = False +-- | A type declaration assigns a type to an identifier, eg: +-- +-- @identity :: forall a. a -> a@ +-- +-- In this example @identity@ is the identifier and @forall a. a -> a@ the type. +data TypeDeclarationData = TypeDeclarationData + { tydeclSourceAnn :: !SourceAnn + , tydeclIdent :: !Ident + , tydeclType :: !Type + } deriving (Show, Eq) + +overTypeDeclaration :: (TypeDeclarationData -> TypeDeclarationData) -> Declaration -> Declaration +overTypeDeclaration f d = maybe d (TypeDeclaration . f) (getTypeDeclaration d) + +getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData +getTypeDeclaration (TypeDeclaration d) = Just d +getTypeDeclaration _ = Nothing + +unwrapTypeDeclaration :: TypeDeclarationData -> (Ident, Type) +unwrapTypeDeclaration td = (tydeclIdent td, tydeclType td) + -- | -- The data type of declarations -- @@ -426,7 +447,7 @@ data Declaration -- | -- A type declaration for a value (name, ty) -- - | TypeDeclaration SourceAnn Ident Type + | TypeDeclaration {-# UNPACK #-} !TypeDeclarationData -- | -- A value declaration (name, top-level binders, optional guard, value) -- @@ -506,7 +527,7 @@ declSourceAnn :: Declaration -> SourceAnn declSourceAnn (DataDeclaration sa _ _ _ _) = sa declSourceAnn (DataBindingGroupDeclaration ds) = declSourceAnn (NEL.head ds) declSourceAnn (TypeSynonymDeclaration sa _ _ _) = sa -declSourceAnn (TypeDeclaration sa _ _) = sa +declSourceAnn (TypeDeclaration td) = tydeclSourceAnn td declSourceAnn (ValueDeclaration sa _ _ _ _) = sa declSourceAnn (BoundValueDeclaration sa _ _) = sa declSourceAnn (BindingGroupDeclaration ds) = let ((sa, _), _, _) = NEL.head ds in sa diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 3fe55a8697..9f8999bcdd 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -597,7 +597,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) getDeclIdent :: Declaration -> Maybe Ident getDeclIdent (ValueDeclaration _ ident _ _ _) = Just ident - getDeclIdent (TypeDeclaration _ ident _) = Just ident + getDeclIdent (TypeDeclaration td) = Just (tydeclIdent td) getDeclIdent _ = Nothing accumTypes @@ -616,7 +616,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con forDecls (TypeClassDeclaration _ _ _ implies _ _) = mconcat (concatMap (fmap f . constraintArgs) implies) forDecls (TypeInstanceDeclaration _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) `mappend` mconcat (fmap f tys) forDecls (TypeSynonymDeclaration _ _ _ ty) = f ty - forDecls (TypeDeclaration _ _ ty) = f ty + forDecls (TypeDeclaration td) = f (tydeclType td) forDecls _ = mempty forValues (TypeClassDictionary c _ _) = mconcat (fmap f (constraintArgs c)) @@ -647,7 +647,7 @@ accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (con forDecls (TypeSynonymDeclaration _ _ args ty) = foldMap (foldMap f . snd) args `mappend` forTypes ty - forDecls (TypeDeclaration _ _ ty) = forTypes ty + forDecls (TypeDeclaration td) = forTypes (tydeclType td) forDecls (ExternDeclaration _ _ ty) = forTypes ty forDecls (ExternDataDeclaration _ _ kn) = f kn forDecls _ = mempty diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 5c1e6eff8a..b1d2e5c744 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -134,7 +134,7 @@ convertDeclaration (P.TypeClassDeclaration sa _ args implies fundeps ds) title = where info = TypeClassDeclaration args implies (convertFundepsToStrings args fundeps) children = map convertClassMember ds - convertClassMember (P.TypeDeclaration (ss, com) ident' ty) = + convertClassMember (P.TypeDeclaration (P.TypeDeclarationData (ss, com) ident' ty)) = ChildDeclaration (P.showIdent ident') (convertComments com) (Just ss) (ChildTypeClassMember ty) convertClassMember _ = P.internalError "convertDeclaration: Invalid argument to convertClassMember." diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index c948b4e26d..7ee696b407 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -131,7 +131,7 @@ parseTypeDeclaration' s = P.runTokenParser "" (P.parseDeclaration <* Parsec.eof) ts in case x of - Right (P.TypeDeclaration _ i t) -> pure (i, t) + Right (P.TypeDeclaration td) -> pure (P.unwrapTypeDeclaration td) Right _ -> throwError (GeneralError "Found a non-type-declaration") Left err -> throwError (GeneralError ("Parsing the type signature failed with: " diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 8a03a5a8f9..776de5ca05 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -65,13 +65,8 @@ extractAstInformation (P.Module _ _ _ decls _) = in (definitions, typeAnnotations) -- | Extracts type annotations for functions from a given Module -extractTypeAnnotations - :: [P.Declaration] - -> [(P.Ident, P.Type)] -extractTypeAnnotations = mapMaybe extract - where - extract (P.TypeDeclaration _ ident ty) = Just (ident, ty) - extract _ = Nothing +extractTypeAnnotations :: [P.Declaration] -> [(P.Ident, P.Type)] +extractTypeAnnotations = mapMaybe (map P.unwrapTypeDeclaration . P.getTypeDeclaration) -- | Given a surrounding Sourcespan and a Declaration from the PS AST, extracts -- definition sites inside that Declaration. @@ -107,6 +102,6 @@ extractSpans d = case d of -- declarations for non-typeclass members, which is why we can't handle them -- in extractSpans. extractSpans' dP = case dP of - P.TypeDeclaration (ss', _) ident _ -> + P.TypeDeclaration (P.TypeDeclarationData (ss', _) ident _) -> [(IdeNamespaced IdeNSValue (P.runIdent ident), ss')] _ -> [] diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index dd94c74768..9c868c9c15 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -206,7 +206,7 @@ identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations where getDeclNames :: P.Declaration -> [(P.Ident, P.Declaration)] getDeclNames d@(P.ValueDeclaration _ ident _ _ _) = [(ident, d)] - getDeclNames d@(P.TypeDeclaration _ ident _ ) = [(ident, d)] + getDeclNames d@(P.TypeDeclaration td) = [(P.tydeclIdent td, d)] getDeclNames d@(P.ExternDeclaration _ ident _) = [(ident, d)] getDeclNames d@(P.TypeClassDeclaration _ _ _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds getDeclNames _ = [] diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 18377982cd..ec0c58b85f 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -52,13 +52,14 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi eval = P.Var (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval")) mainValue = P.App eval (P.Var (P.Qualified Nothing (P.Ident "it"))) itDecl = P.ValueDeclaration (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val] - typeDecl = P.TypeDeclaration (internalSpan, []) (P.Ident "$main") - (P.TypeApp + typeDecl = P.TypeDeclaration + (P.TypeDeclarationData (internalSpan, []) (P.Ident "$main") (P.TypeApp - (P.TypeConstructor - (P.Qualified (Just (P.ModuleName [P.ProperName "$Eff"])) (P.ProperName "Eff"))) - (P.TypeWildcard internalSpan)) + (P.TypeApp + (P.TypeConstructor + (P.Qualified (Just (P.ModuleName [P.ProperName "$Eff"])) (P.ProperName "Eff"))) (P.TypeWildcard internalSpan)) + (P.TypeWildcard internalSpan))) mainDecl = P.ValueDeclaration (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] in diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index a1f99a775c..17910d93ed 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -49,7 +49,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl f' :: S.Set Text -> Declaration -> MultipleErrors f' s dec@(ValueDeclaration _ name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec) - f' s (TypeDeclaration _ name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars s ty) + f' s (TypeDeclaration td) = addHint (ErrorInTypeDeclaration (tydeclIdent td)) (checkTypeVars s (tydeclType td)) f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec stepE :: S.Set Ident -> Expr -> MultipleErrors diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 1dbb9d5d4c..13ee26cad3 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -59,7 +59,7 @@ parseTypeDeclaration :: TokenParser Declaration parseTypeDeclaration = withSourceAnnF $ do name <- P.try (parseIdent <* indented <* doubleColon) ty <- parsePolyType - return $ \sa -> TypeDeclaration sa name ty + return $ \sa -> TypeDeclaration (TypeDeclarationData sa name ty) parseTypeSynonymDeclaration :: TokenParser Declaration parseTypeSynonymDeclaration = withSourceAnnF $ do diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 2c28bccbba..44993f8373 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -122,8 +122,8 @@ prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ secon prettyPrintDeclaration :: Int -> Declaration -> Box prettyPrintDeclaration d _ | d < 0 = ellipsis -prettyPrintDeclaration _ (TypeDeclaration _ ident ty) = - text (T.unpack (showIdent ident) ++ " :: ") <> typeAsBox ty +prettyPrintDeclaration _ (TypeDeclaration td) = + text (T.unpack (showIdent (tydeclIdent td)) ++ " :: ") <> typeAsBox (tydeclType td) prettyPrintDeclaration d (ValueDeclaration _ ident _ [] [GuardedExpr [] val]) = text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val prettyPrintDeclaration d (BindingGroupDeclaration ds) = diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 5ed9816ba4..7c4c41b8a9 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -216,9 +216,9 @@ renameInModule imports (Module modSS coms mn decls exps) = <*> updateClassName cn ss <*> traverse (updateTypesEverywhere ss) ts <*> pure ds - updateDecl bound (TypeDeclaration sa@(ss, _) name ty) = + updateDecl bound (TypeDeclaration (TypeDeclarationData sa@(ss, _) name ty)) = fmap (bound,) $ - TypeDeclaration sa name + TypeDeclaration . TypeDeclarationData sa name <$> updateTypesEverywhere ss ty updateDecl bound (ExternDeclaration sa@(ss, _) name ty) = fmap (name : bound,) $ diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 660efc1aac..b3c195c692 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -37,7 +37,7 @@ findExportable (Module _ _ mn ds _) = exps' <- rethrowWithPosition ss $ exportTypeClass Internal exps tcn mn foldM go exps' ds' where - go exps'' (TypeDeclaration (ss', _) name _) = rethrowWithPosition ss' $ exportValue exps'' name mn + go exps'' (TypeDeclaration (TypeDeclarationData (ss', _) name _)) = rethrowWithPosition ss' $ exportValue exps'' name mn go _ _ = internalError "Invalid declaration in TypeClassDeclaration" updateExports exps (DataDeclaration _ _ tn _ dcs) = exportType Internal exps tn (map fst dcs) mn diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 9f2e7df09c..b4b9714e8e 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -340,8 +340,8 @@ updateTypes goType = (goDecl, goExpr, goBinder) return $ TypeInstanceDeclaration sa name cs' className tys' impls goDecl (TypeSynonymDeclaration sa@(ss, _) name args ty) = TypeSynonymDeclaration sa name args <$> goType'' ss ty - goDecl (TypeDeclaration sa@(ss, _) expr ty) = - TypeDeclaration sa expr <$> goType'' ss ty + goDecl (TypeDeclaration (TypeDeclarationData sa@(ss, _) expr ty)) = + TypeDeclaration . TypeDeclarationData sa expr <$> goType'' ss ty goDecl other = return other diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 217076c370..50a024f97c 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -16,7 +16,7 @@ import Control.Monad.State import Control.Monad.Supply.Class import Data.List ((\\), find, sortBy) import qualified Data.Map as M -import Data.Maybe (catMaybes, mapMaybe, isJust) +import Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe) import Data.Text (Text) import qualified Language.PureScript.Constants as C import Language.PureScript.Crash @@ -222,7 +222,7 @@ desugarDecl mn exps = go genSpan = internalModuleSourceSpan "" memberToNameAndType :: Declaration -> (Ident, Type) -memberToNameAndType (TypeDeclaration _ ident ty) = (ident, ty) +memberToNameAndType (TypeDeclaration td) = unwrapTypeDeclaration td memberToNameAndType _ = internalError "Invalid declaration in type class definition" typeClassDictionaryDeclaration @@ -247,7 +247,7 @@ typeClassMemberToDictionaryAccessor -> [(Text, Maybe Kind)] -> Declaration -> Declaration -typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration sa ident ty) = +typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarationData sa ident ty)) = let className = Qualified (Just mn) name in ValueDeclaration sa ident Private [] $ [MkUnguarded ( @@ -306,21 +306,19 @@ typeInstanceDictionaryDeclaration sa name mn deps className tys decls = where - declIdent :: Declaration -> Maybe Ident - declIdent (ValueDeclaration _ ident _ _ _) = Just ident - declIdent (TypeDeclaration _ ident _) = Just ident - declIdent _ = Nothing - memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr memberToValue tys' (ValueDeclaration _ ident _ [] [MkUnguarded val]) = do _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys' return val memberToValue _ _ = internalError "Invalid declaration in type instance definition" +declIdent :: Declaration -> Maybe Ident +declIdent (ValueDeclaration _ ident _ _ _) = Just ident +declIdent (TypeDeclaration td) = Just (tydeclIdent td) +declIdent _ = Nothing + typeClassMemberName :: Declaration -> Text -typeClassMemberName (TypeDeclaration _ ident _) = runIdent ident -typeClassMemberName (ValueDeclaration _ ident _ _ _) = runIdent ident -typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration in type class definition" +typeClassMemberName = fromMaybe (internalError "typeClassMemberName: Invalid declaration in type class definition") . fmap runIdent . declIdent superClassDictionaryNames :: [Constraint] -> [Text] superClassDictionaryNames supers = diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 8013f70cbc..d4d38c1f5d 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -29,7 +29,7 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) = where desugarTypeDeclarations :: [Declaration] -> m [Declaration] - desugarTypeDeclarations (TypeDeclaration sa name' ty : d : rest) = do + desugarTypeDeclarations (TypeDeclaration (TypeDeclarationData sa name' ty) : d : rest) = do (_, nameKind, val) <- fromValueDeclaration d desugarTypeDeclarations (ValueDeclaration sa name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest) where @@ -38,7 +38,7 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) = | name' == name'' = return (name'', nameKind, val) fromValueDeclaration d' = throwError . errorMessage' (declSourceSpan d') $ OrphanTypeDeclaration name' - desugarTypeDeclarations [TypeDeclaration (ss, _) name' _] = + desugarTypeDeclarations [TypeDeclaration (TypeDeclarationData (ss, _) name' _)] = throwError . errorMessage' ss $ OrphanTypeDeclaration name' desugarTypeDeclarations (ValueDeclaration sa name' nameKind bs val : rest) = do let (_, f, _) = everywhereOnValuesTopDownM return go return diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 819328f99a..15c653fcc0 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -140,7 +140,7 @@ addTypeClass moduleName pn args implies dependencies ds = do argToIndex :: Text -> Maybe Int argToIndex = flip M.lookup $ M.fromList (zipWith ((,) . fst) args [0..]) - toPair (TypeDeclaration _ ident ty) = (ident, ty) + toPair (TypeDeclaration (TypeDeclarationData _ ident ty)) = (ident, ty) toPair _ = internalError "Invalid declaration in TypeClassDeclaration" -- Currently we are only checking usability based on the type class currently @@ -493,6 +493,6 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = findClassMembers (TypeClassDeclaration _ name' _ _ _ ds) | name == name' = Just $ map extractMemberName ds findClassMembers _ = Nothing extractMemberName :: Declaration -> Ident - extractMemberName (TypeDeclaration _ memberName _) = memberName + extractMemberName (TypeDeclaration td) = tydeclIdent td extractMemberName _ = internalError "Unexpected declaration in typeclass member list" checkClassMembersAreExported _ = return () diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 1bf01f470a..0b65de688f 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -22,7 +22,7 @@ ann1 = (span1, []) ann2 = (span2, []) typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, foreign1, foreign2, foreign3, member1 :: P.Declaration -typeAnnotation1 = P.TypeDeclaration ann1 (P.Ident "value1") P.REmpty +typeAnnotation1 = P.TypeDeclaration (P.TypeDeclarationData ann1 (P.Ident "value1") P.REmpty) value1 = P.ValueDeclaration ann1 (P.Ident "value1") P.Public [] [] synonym1 = P.TypeSynonymDeclaration ann1 (P.ProperName "Synonym1") [] P.REmpty class1 = P.TypeClassDeclaration ann1 (P.ProperName "Class1") [] [] [] [] @@ -44,7 +44,7 @@ typeFixity = foreign1 = P.ExternDeclaration ann1 (P.Ident "foreign1") P.REmpty foreign2 = P.ExternDataDeclaration ann1 (P.ProperName "Foreign2") P.kindType foreign3 = P.ExternKindDeclaration ann1 (P.ProperName "Foreign3") -member1 = P.TypeDeclaration ann2 (P.Ident "member1") P.REmpty +member1 = P.TypeDeclaration (P.TypeDeclarationData ann2 (P.Ident "member1") P.REmpty) spec :: Spec spec = do From 4c3ddb132296ea0c44a318f53fc7464f656b7ddf Mon Sep 17 00:00:00 2001 From: Joe Kachmar Date: Sun, 13 Aug 2017 19:13:17 -0400 Subject: [PATCH 0846/1580] Improves ExternsFile parse errors (#3037) * Improves ExternsFile parse errors * Updates CONTRIBUTORS and removes extraneous parens --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Ide/Externs.hs | 18 +++++++++++------- 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index a4799bfb08..6812f5da3e 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -53,6 +53,7 @@ If you would prefer to use different terms, please use the section below instead | [@izgzhen](https://github.com/izgzhen) | Zhen Zhang | [MIT license](http://opensource.org/licenses/MIT) | | [@jacereda](https://github.com/jacereda) | Jorge Acereda | [MIT license](http://opensource.org/licenses/MIT) | | [@japesinator](https://github.com/japesinator) | JP Smith | [MIT license](http://opensource.org/licenses/MIT) | +| [@jkachmar](https://github.com/jkachmar) | Joe Kachmar | MIT license | | [@joneshf](https://github.com/joneshf) | Hardy Jones | MIT license | | [@kika](https://github.com/kika) | Kirill Pertsev | MIT license | | [@kRITZCREEK](https://github.com/kRITZCREEK) | Christoph Hegemann | MIT license | diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 0e9e17f694..ca7a53d5a7 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -24,6 +24,7 @@ import Protolude hiding (to, from, (&)) import Control.Lens import "monad-logger" Control.Monad.Logger import Data.Aeson (decodeStrict) +import Data.Aeson.Types (withObject, parseMaybe, (.:)) import qualified Data.ByteString as BS import Data.Version (showVersion) import Language.PureScript.Ide.Error (IdeError (..)) @@ -36,16 +37,19 @@ readExternFile => FilePath -> m P.ExternsFile readExternFile fp = do - parseResult <- liftIO (decodeStrict <$> BS.readFile fp) - case parseResult of + externsFile <- liftIO (BS.readFile fp) + case decodeStrict externsFile of Nothing -> - throwError (GeneralError - ("Parsing the extern at: " <> toS fp <> " failed")) - Just externs - | P.efVersion externs /= version -> do + let parser = withObject "ExternsFileVersion" $ \o -> o .: "efVersion" + maybeEFVersion = parseMaybe parser =<< decodeStrict externsFile + in case maybeEFVersion of + Nothing -> + throwError (GeneralError + ("Parsing the extern at: " <> toS fp <> " failed")) + Just efVersion -> do let errMsg = "Version mismatch for the externs at: " <> toS fp <> " Expected: " <> version - <> " Found: " <> P.efVersion externs + <> " Found: " <> efVersion logErrorN errMsg throwError (GeneralError errMsg) Just externs -> pure externs From 39477d3c45319a1cb838bfe65bdc1f444c263a31 Mon Sep 17 00:00:00 2001 From: Michael Hoy Date: Wed, 16 Aug 2017 21:48:29 -0500 Subject: [PATCH 0847/1580] bump glob dependency (#3041) --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index a86f973363..9f33ba0c4c 100644 --- a/package.yaml +++ b/package.yaml @@ -52,7 +52,7 @@ dependencies: - file-embed - filepath - fsnotify >=0.2.1 - - Glob >=0.7 && <0.8 + - Glob >=0.7 && <0.9 - haskeline >=0.7.0.0 - http-client >=0.4.30 && <0.6.0 - http-types From f768720e7d924d57e2b17c774752c01ba3b4484e Mon Sep 17 00:00:00 2001 From: b123400 Date: Fri, 18 Aug 2017 01:59:45 +0300 Subject: [PATCH 0848/1580] [psc-ide] Make `type` command's `filters` param optional to align with doc (#3040) * Make type command's filters param optional to align with doc * Add myself into contributors --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Ide/Command.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 6812f5da3e..f16dd5dcee 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -108,6 +108,7 @@ If you would prefer to use different terms, please use the section below instead | [@utkarshkukreti](https://github.com/utkarshkukreti) | Utkarsh Kukreti | [MIT license](http://opensource.org/licenses/MIT) | | [@vkorablin](https://github.com/vkorablin) | Vladimir Korablin | MIT license | | [@zudov](https://github.com/zudov) | Konstantin Zudov | [MIT license](http://opensource.org/licenses/MIT) | +| [@b123400](https://github.com/b123400) | b123400 | [MIT license](https://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index a8383b3290..b98f5fe485 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -131,7 +131,7 @@ instance FromJSON Command where params <- o .: "params" Type <$> params .: "search" - <*> params .: "filters" + <*> params .:? "filters" .!= [] <*> (fmap P.moduleNameFromString <$> params .:? "currentModule") "complete" -> do params <- o .: "params" From 81ea774014b4f095049dd5a8fa71159742611e24 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sat, 19 Aug 2017 02:50:22 +0200 Subject: [PATCH 0849/1580] [purs ide] Adds an `actualFile` parameter to the rebuild command (#3045) * [purs ide] Adds an `actualPath` parameter to the rebuild command This allows us to specify the actual path of the source file (important for declaration location information as well as correct parse error locations), in case we are using a temp file for rebuilding. * naming things... --- psc-ide/PROTOCOL.md | 4 ++++ src/Language/PureScript/Ide.hs | 8 ++++---- src/Language/PureScript/Ide/Command.hs | 5 +++-- src/Language/PureScript/Ide/Rebuild.hs | 20 +++++++++++--------- tests/Language/PureScript/Ide/RebuildSpec.hs | 14 ++++++++++++-- 5 files changed, 34 insertions(+), 17 deletions(-) diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index e5b12d110a..fdab0115d6 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -326,12 +326,16 @@ identifiers. Arguments: - `file :: String` the path to the module to rebuild + - `actualFile :: Maybe String` Specifies the path to be used for location + information and parse errors. This is useful in case a temp file is used as + the source for a rebuild. ```json { "command": "rebuild", "params": { "file": "/path/to/file.purs" + "actualFile": "/path/to/actualFile.purs" } } ``` diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 4c6eb0da4d..d6e339d139 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -87,10 +87,10 @@ handleCommand c = case c of Right rs' -> answerRequest outfp rs' Left question -> pure (CompletionResult (map (completionFromMatch . simpleExport . map withEmptyAnn) question)) - Rebuild file -> - rebuildFileAsync file - RebuildSync file -> - rebuildFileSync file + Rebuild file actualFile -> + rebuildFileAsync file actualFile + RebuildSync file actualFile -> + rebuildFileSync file actualFile Cwd -> TextResult . toS <$> liftIO getCurrentDirectory Reset -> diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index b98f5fe485..46c6f3d913 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -56,8 +56,8 @@ data Command -- Import InputFile OutputFile | Import FilePath (Maybe FilePath) [Filter] ImportCommand | List { listType :: ListType } - | Rebuild FilePath -- ^ Rebuild the specified file using the loaded externs - | RebuildSync FilePath -- ^ Rebuild the specified file using the loaded externs + | Rebuild FilePath (Maybe FilePath) + | RebuildSync FilePath (Maybe FilePath) | Cwd | Reset | Quit @@ -169,6 +169,7 @@ instance FromJSON Command where params <- o .: "params" Rebuild <$> params .: "file" + <*> params .:? "actualFile" _ -> mzero where mkAnnotations True = explicitAnnotations diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index c54b6a9417..c4f4b204a8 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -40,14 +40,16 @@ rebuildFile :: (Ide m, MonadLogger m, MonadError IdeError m) => FilePath -- ^ The file to rebuild + -> Maybe FilePath + -- ^ The file to use as the location for parsing and errors -> (ReaderT IdeEnvironment (LoggingT IO) () -> m ()) -- ^ A runner for the second build with open exports -> m Success -rebuildFile path runOpenBuild = do +rebuildFile file actualFile runOpenBuild = do - input <- ideReadFile path + input <- ideReadFile file - m <- case snd <$> P.parseModuleFromFile identity (path, input) of + m <- case snd <$> P.parseModuleFromFile (maybe identity const actualFile) (file, input) of Left parseError -> throwError (RebuildError (P.MultipleErrors [P.toPositionedError parseError])) Right m -> pure m @@ -61,7 +63,7 @@ rebuildFile path runOpenBuild = do -- For rebuilding, we want to 'RebuildAlways', but for inferring foreign -- modules using their file paths, we need to specify the path in the 'Map'. let filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways) - foreigns <- P.inferForeignModules (M.singleton (P.getModuleName m) (Right path)) + foreigns <- P.inferForeignModules (M.singleton (P.getModuleName m) (Right file)) let makeEnv = MakeActionsEnv outputDirectory filePathMap foreigns False -- Rebuild the single module using the cached externs @@ -74,7 +76,7 @@ rebuildFile path runOpenBuild = do Left errors -> throwError (RebuildError errors) Right newExterns -> do whenM isEditorMode $ do - insertModule (path, m) + insertModule (fromMaybe file actualFile, m) insertExterns newExterns void populateVolatileState runOpenBuild (rebuildModuleOpen makeEnv externs m) @@ -85,8 +87,8 @@ isEditorMode = asks (confEditorMode . ideConfiguration) rebuildFileAsync :: forall m. (Ide m, MonadLogger m, MonadError IdeError m) - => FilePath -> m Success -rebuildFileAsync fp = rebuildFile fp asyncRun + => FilePath -> Maybe FilePath -> m Success +rebuildFileAsync fp fp' = rebuildFile fp fp' asyncRun where asyncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m () asyncRun action = do @@ -96,8 +98,8 @@ rebuildFileAsync fp = rebuildFile fp asyncRun rebuildFileSync :: forall m. (Ide m, MonadLogger m, MonadError IdeError m) - => FilePath -> m Success -rebuildFileSync fp = rebuildFile fp syncRun + => FilePath -> Maybe FilePath -> m Success +rebuildFileSync fp fp' = rebuildFile fp fp' syncRun where syncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m () syncRun action = do diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index 9c00312598..03ea688ae0 100644 --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -4,6 +4,7 @@ module Language.PureScript.Ide.RebuildSpec where import Protolude +import Language.PureScript.AST.SourcePos (spanName) import Language.PureScript.Ide.Command import Language.PureScript.Ide.Completion import Language.PureScript.Ide.Matcher @@ -16,10 +17,10 @@ load :: [Text] -> Command load = LoadSync . map Test.mn rebuild :: FilePath -> Command -rebuild fp = Rebuild ("src" fp) +rebuild fp = Rebuild ("src" fp) Nothing rebuildSync :: FilePath -> Command -rebuildSync fp = RebuildSync ("src" fp) +rebuildSync fp = RebuildSync ("src" fp) Nothing spec :: Spec spec = describe "Rebuilding single modules" $ do @@ -60,3 +61,12 @@ spec = describe "Rebuilding single modules" $ do Test.runIde [ rebuildSync "RebuildSpecWithHiddenIdent.purs" , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent")) defaultCompletionOptions] complIdentifier result `shouldBe` "hidden" + it "uses the specified `actualFile` for location information (in editor mode)" $ do + let editorConfig = Test.defConfig { confEditorMode = True } + ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + Test.runIde' + editorConfig + emptyIdeState + [ RebuildSync ("src" "RebuildSpecWithHiddenIdent.purs") (Just "actualFile") + , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent")) defaultCompletionOptions] + map spanName (complLocation result) `shouldBe` Just "actualFile" From cc422346e0ae9711077aa78ba8114c53cf59ab80 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 20 Aug 2017 19:57:51 +0200 Subject: [PATCH 0850/1580] Introduce data type for value declarations (#3048) * Introduce data type for value declarations * Reduce partiality in Sugar.BindingGroups * cleanup * Adds instances to ValueDeclarationData Also reduces partiality in Desugar.BindingGroups --- src/Language/PureScript/AST/Declarations.hs | 28 +++++++++-- src/Language/PureScript/AST/Traversals.hs | 20 +++++--- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- .../PureScript/Docs/Convert/Single.hs | 6 +-- src/Language/PureScript/Ide/SourceFile.hs | 2 +- .../PureScript/Interactive/Completion.hs | 2 +- src/Language/PureScript/Interactive/Module.hs | 4 +- src/Language/PureScript/Linter.hs | 4 +- src/Language/PureScript/Linter/Exhaustive.hs | 5 +- .../PureScript/Parser/Declarations.hs | 2 +- src/Language/PureScript/Pretty/Values.hs | 4 +- .../PureScript/Sugar/BindingGroups.hs | 50 +++++++++---------- .../PureScript/Sugar/CaseDeclarations.hs | 20 ++++---- src/Language/PureScript/Sugar/DoNotation.hs | 2 +- src/Language/PureScript/Sugar/Names.hs | 3 +- .../PureScript/Sugar/Names/Exports.hs | 4 +- .../PureScript/Sugar/ObjectWildcards.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 10 ++-- .../PureScript/Sugar/TypeClasses/Deriving.hs | 24 ++++----- .../PureScript/Sugar/TypeDeclarations.hs | 8 +-- src/Language/PureScript/TypeChecker.hs | 6 +-- src/Language/PureScript/TypeChecker/Types.hs | 10 ++-- .../Language/PureScript/Ide/SourceFileSpec.hs | 2 +- 23 files changed, 122 insertions(+), 98 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 057fc07408..e4ea628365 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -428,6 +428,28 @@ getTypeDeclaration _ = Nothing unwrapTypeDeclaration :: TypeDeclarationData -> (Ident, Type) unwrapTypeDeclaration td = (tydeclIdent td, tydeclType td) +-- | A value declaration assigns a name and potential binders, to an expression (or multiple guarded expressions). +-- +-- @double x = x + x@ +-- +-- In this example @double@ is the identifier, @x@ is a binder and @x + x@ is the expression. +data ValueDeclarationData a = ValueDeclarationData + { valdeclSourceAnn :: !SourceAnn + , valdeclIdent :: !Ident + -- ^ The declared value's name + , valdeclName :: !NameKind + -- ^ Whether or not this value is exported/visible + , valdeclBinders :: ![Binder] + , valdeclExpression :: !a + } deriving (Show, Functor, Foldable, Traversable) + +overValueDeclaration :: (ValueDeclarationData [GuardedExpr] -> ValueDeclarationData [GuardedExpr]) -> Declaration -> Declaration +overValueDeclaration f d = maybe d (ValueDeclaration . f) (getValueDeclaration d) + +getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr]) +getValueDeclaration (ValueDeclaration d) = Just d +getValueDeclaration _ = Nothing + -- | -- The data type of declarations -- @@ -451,7 +473,7 @@ data Declaration -- | -- A value declaration (name, top-level binders, optional guard, value) -- - | ValueDeclaration SourceAnn Ident NameKind [Binder] [GuardedExpr] + | ValueDeclaration {-# UNPACK #-} !(ValueDeclarationData [GuardedExpr]) -- | -- A declaration paired with pattern matching in let-in expression (binder, optional guard, value) | BoundValueDeclaration SourceAnn Binder Expr @@ -528,7 +550,7 @@ declSourceAnn (DataDeclaration sa _ _ _ _) = sa declSourceAnn (DataBindingGroupDeclaration ds) = declSourceAnn (NEL.head ds) declSourceAnn (TypeSynonymDeclaration sa _ _ _) = sa declSourceAnn (TypeDeclaration td) = tydeclSourceAnn td -declSourceAnn (ValueDeclaration sa _ _ _ _) = sa +declSourceAnn (ValueDeclaration vd) = valdeclSourceAnn vd declSourceAnn (BoundValueDeclaration sa _ _) = sa declSourceAnn (BindingGroupDeclaration ds) = let ((sa, _), _, _) = NEL.head ds in sa declSourceAnn (ExternDeclaration sa _ _) = sa @@ -545,7 +567,7 @@ declSourceSpan = fst . declSourceAnn declName :: Declaration -> Maybe Name declName (DataDeclaration _ _ n _ _) = Just (TyName n) declName (TypeSynonymDeclaration _ n _ _) = Just (TyName n) -declName (ValueDeclaration _ n _ _ _) = Just (IdentName n) +declName (ValueDeclaration vd) = Just (IdentName (valdeclIdent vd)) declName (ExternDeclaration _ n _) = Just (IdentName n) declName (ExternDataDeclaration _ n _) = Just (TyName n) declName (ExternKindDeclaration _ n) = Just (KiName n) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 9f8999bcdd..7148dff737 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -53,7 +53,8 @@ everywhereOnValues f g h = (f', g', h') where f' :: Declaration -> Declaration f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (fmap f' ds)) - f' (ValueDeclaration sa name nameKind bs val) = f (ValueDeclaration sa name nameKind (fmap h' bs) (fmap (mapGuardedExpr handleGuard g') val)) + f' (ValueDeclaration (ValueDeclarationData sa name nameKind bs val)) = + f (ValueDeclaration (ValueDeclarationData sa name nameKind (fmap h' bs) (fmap (mapGuardedExpr handleGuard g') val))) f' (BoundValueDeclaration sa b expr) = f (BoundValueDeclaration sa (h' b) (g' expr)) f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (fmap (\(name, nameKind, val) -> (name, nameKind, g' val)) ds)) f' (TypeClassDeclaration sa name args implies deps ds) = f (TypeClassDeclaration sa name args implies deps (fmap f' ds)) @@ -125,7 +126,8 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds - f' (ValueDeclaration sa name nameKind bs val) = ValueDeclaration sa name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val + f' (ValueDeclaration (ValueDeclarationData sa name nameKind bs val)) = + ValueDeclaration <$> (ValueDeclarationData sa name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val) f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds f' (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f' <=< f) ds f' (TypeInstanceDeclaration sa name cs className args ds) = TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds @@ -192,7 +194,8 @@ everywhereOnValuesM f g h = (f', g', h') f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f - f' (ValueDeclaration sa name nameKind bs val) = (ValueDeclaration sa name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val) >>= f + f' (ValueDeclaration (ValueDeclarationData sa name nameKind bs val)) = + ValueDeclaration <$> (ValueDeclarationData sa name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val) >>= f f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f f' (BoundValueDeclaration sa b expr) = (BoundValueDeclaration sa <$> h' b <*> g' expr) >>= f f' (TypeClassDeclaration sa name args implies deps ds) = (TypeClassDeclaration sa name args implies deps <$> traverse f' ds) >>= f @@ -263,7 +266,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') f' :: Declaration -> r f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (fmap f' ds) - f' d@(ValueDeclaration _ _ _ bs val) = foldl (<>) (f d) (fmap h' bs ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) val) + f' d@(ValueDeclaration vd) = foldl (<>) (f d) (fmap h' (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) (valdeclExpression vd)) f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (fmap (\(_, _, val) -> g' val) ds) f' d@(TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>) (f d) (fmap f' ds) f' d@(TypeInstanceDeclaration _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (fmap f' ds) @@ -341,7 +344,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' f' :: s -> Declaration -> r f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (fmap (f'' s) ds) - f' s (ValueDeclaration _ _ _ bs val) = foldl (<>) r0 (fmap (h'' s) bs ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) val) + f' s (ValueDeclaration vd) = foldl (<>) r0 (fmap (h'' s) (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) (valdeclExpression vd)) f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (fmap (\(_, _, val) -> g'' s val) ds) f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>) r0 (fmap (f'' s) ds) f' s (TypeInstanceDeclaration _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (fmap (f'' s) ds) @@ -426,7 +429,8 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j f'' s = uncurry f' <=< f s f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds - f' s (ValueDeclaration sa name nameKind bs val) = ValueDeclaration sa name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val + f' s (ValueDeclaration (ValueDeclarationData sa name nameKind bs val)) = + ValueDeclaration <$> (ValueDeclarationData sa name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val) f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds f' s (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f'' s) ds f' s (TypeInstanceDeclaration sa name cs className args ds) = TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds @@ -508,7 +512,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) f' s (DataBindingGroupDeclaration ds) = let s' = S.union s (S.fromList (mapMaybe getDeclIdent (NEL.toList ds))) in foldMap (f'' s') ds - f' s (ValueDeclaration _ name _ bs val) = + f' s (ValueDeclaration (ValueDeclarationData _ name _ bs val)) = let s' = S.insert name s s'' = S.union s' (S.fromList (concatMap binderNames bs)) in foldMap (h'' s') bs <> foldMap (l' s'') val @@ -596,7 +600,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) in r <> l' s' (GuardedExpr gs e) getDeclIdent :: Declaration -> Maybe Ident - getDeclIdent (ValueDeclaration _ ident _ _ _) = Just ident + getDeclIdent (ValueDeclaration vd) = Just (valdeclIdent vd) getDeclIdent (TypeDeclaration td) = Just (tydeclIdent td) getDeclIdent _ = Nothing diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index f0a681eb91..82866d8efc 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -63,7 +63,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields declToCoreFn (A.DataBindingGroupDeclaration ds) = concatMap declToCoreFn ds - declToCoreFn (A.ValueDeclaration (ss, com) name _ _ [A.MkUnguarded e]) = + declToCoreFn (A.ValueDeclaration (A.ValueDeclarationData (ss, com) name _ _ [A.MkUnguarded e])) = [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] declToCoreFn (A.BindingGroupDeclaration ds) = [Rec . NEL.toList $ fmap (\(((ss, com), name), _, e) -> ((ssA ss, name), exprToCoreFn ss com Nothing e)) ds] diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index b1d2e5c744..c3ea08db17 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -82,7 +82,7 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) = d { declChildren = declChildren d ++ [child] } getDeclarationTitle :: P.Declaration -> Maybe Text -getDeclarationTitle (P.ValueDeclaration _ name _ _ _) = Just (P.showIdent name) +getDeclarationTitle (P.ValueDeclaration vd) = Just (P.showIdent (P.valdeclIdent vd)) getDeclarationTitle (P.ExternDeclaration _ name _) = Just (P.showIdent name) getDeclarationTitle (P.DataDeclaration _ _ name _ _) = Just (P.runProperName name) getDeclarationTitle (P.ExternDataDeclaration _ name _) = Just (P.runProperName name) @@ -108,9 +108,9 @@ basicDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Maybe Intermediate basicDeclaration sa title = Just . Right . mkDeclaration sa title convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration -convertDeclaration (P.ValueDeclaration sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title = +convertDeclaration (P.ValueDeclaration (P.ValueDeclarationData sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)])) title = basicDeclaration sa title (ValueDeclaration ty) -convertDeclaration (P.ValueDeclaration sa _ _ _ _) title = +convertDeclaration (P.ValueDeclaration (P.ValueDeclarationData sa _ _ _ _)) title = -- If no explicit type declaration was provided, insert a wildcard, so that -- the actual type will be added during type checking. basicDeclaration sa title (ValueDeclaration P.TypeWildcard{}) diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 776de5ca05..b7eeeabcde 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -76,7 +76,7 @@ extractSpans -> [(IdeNamespaced, P.SourceSpan)] -- ^ Declarations and their source locations extractSpans d = case d of - P.ValueDeclaration (ss, _) i _ _ _ -> + P.ValueDeclaration (P.ValueDeclarationData (ss, _) i _ _ _) -> [(IdeNamespaced IdeNSValue (P.runIdent i), ss)] P.TypeSynonymDeclaration (ss, _) name _ _ -> [(IdeNamespaced IdeNSType (P.runProperName name), ss)] diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index 9c868c9c15..866b7db3f4 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -205,7 +205,7 @@ identNames :: P.Module -> [(N.Ident, P.Declaration)] identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations where getDeclNames :: P.Declaration -> [(P.Ident, P.Declaration)] - getDeclNames d@(P.ValueDeclaration _ ident _ _ _) = [(ident, d)] + getDeclNames d@(P.ValueDeclaration (P.ValueDeclarationData _ ident _ _ _)) = [(ident, d)] getDeclNames d@(P.TypeDeclaration td) = [(P.tydeclIdent td, d)] getDeclNames d@(P.ExternDeclaration _ ident _) = [(ident, d)] getDeclNames d@(P.TypeClassDeclaration _ _ _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index ec0c58b85f..5b8691739c 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -51,7 +51,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"])) eval = P.Var (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval")) mainValue = P.App eval (P.Var (P.Qualified Nothing (P.Ident "it"))) - itDecl = P.ValueDeclaration (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val] + itDecl = P.ValueDeclaration $ P.ValueDeclarationData (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val] typeDecl = P.TypeDeclaration (P.TypeDeclarationData (internalSpan, []) (P.Ident "$main") (P.TypeApp @@ -60,7 +60,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi (P.Qualified (Just (P.ModuleName [P.ProperName "$Eff"])) (P.ProperName "Eff"))) (P.TypeWildcard internalSpan)) (P.TypeWildcard internalSpan))) - mainDecl = P.ValueDeclaration (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] + mainDecl = P.ValueDeclaration $ P.ValueDeclarationData (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] in P.Module internalSpan diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 17910d93ed..7c7a2758c4 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -32,7 +32,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl moduleNames = S.fromList (ordNub (mapMaybe getDeclIdent ds)) getDeclIdent :: Declaration -> Maybe Ident - getDeclIdent (ValueDeclaration _ ident _ _ _) = Just ident + getDeclIdent (ValueDeclaration vd) = Just (valdeclIdent vd) getDeclIdent (ExternDeclaration _ ident _) = Just ident getDeclIdent (TypeInstanceDeclaration _ ident _ _ _ _) = Just ident getDeclIdent BindingGroupDeclaration{} = internalError "lint: binding groups should not be desugared yet." @@ -48,7 +48,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl f dec = f' S.empty dec f' :: S.Set Text -> Declaration -> MultipleErrors - f' s dec@(ValueDeclaration _ name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec) + f' s dec@(ValueDeclaration vd) = addHint (ErrorInValueDeclaration (valdeclIdent vd)) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec) f' s (TypeDeclaration td) = addHint (ErrorInTypeDeclaration (tydeclIdent td)) (checkTypeVars s (tydeclType td)) f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index a8a21f8546..e5bf1cb727 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -295,7 +295,7 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' where partial :: Text -> Text -> Declaration partial var tyVar = - ValueDeclaration (ss, []) (Ident C.__unused) Private [] $ + ValueDeclaration $ ValueDeclarationData (ss, []) (Ident C.__unused) Private [] $ [MkUnguarded (TypedValue True @@ -331,7 +331,8 @@ checkExhaustiveExpr initSS env mn = onExpr initSS where onDecl :: Declaration -> m Declaration onDecl (BindingGroupDeclaration bs) = BindingGroupDeclaration <$> mapM (\(sai@((ss, _), _), nk, expr) -> (sai, nk,) <$> onExpr ss expr) bs - onDecl (ValueDeclaration sa@(ss, _) name x y [MkUnguarded e]) = ValueDeclaration sa name x y . mkUnguardedExpr <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr ss e) + onDecl (ValueDeclaration (ValueDeclarationData sa@(ss, _) name x y [MkUnguarded e])) = + ValueDeclaration <$> ValueDeclarationData sa name x y . mkUnguardedExpr <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr ss e) onDecl decl = return decl onExpr :: SourceSpan -> Expr -> m Expr diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 13ee26cad3..b0db264a78 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -87,7 +87,7 @@ parseValueWithIdentAndBinders ident bs = do <*> (indented *> equals *> withSourceSpan PositionedValue parseValueWithWhereClause)) ) - return $ \sa -> ValueDeclaration sa ident Public bs value + return $ \sa -> ValueDeclaration (ValueDeclarationData sa ident Public bs value) parseValueDeclaration :: TokenParser Declaration parseValueDeclaration = withSourceAnnF $ do diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 44993f8373..4ba0d39d6f 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -124,12 +124,12 @@ prettyPrintDeclaration :: Int -> Declaration -> Box prettyPrintDeclaration d _ | d < 0 = ellipsis prettyPrintDeclaration _ (TypeDeclaration td) = text (T.unpack (showIdent (tydeclIdent td)) ++ " :: ") <> typeAsBox (tydeclType td) -prettyPrintDeclaration d (ValueDeclaration _ ident _ [] [GuardedExpr [] val]) = +prettyPrintDeclaration d (ValueDeclaration (ValueDeclarationData _ ident _ [] [GuardedExpr [] val])) = text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val prettyPrintDeclaration d (BindingGroupDeclaration ds) = vsep 1 left (NEL.toList (fmap (prettyPrintDeclaration (d - 1) . toDecl) ds)) where - toDecl ((sa, nm), t, e) = ValueDeclaration sa nm t [] [GuardedExpr [] e] + toDecl ((sa, nm), t, e) = ValueDeclaration (ValueDeclarationData sa nm t [] [GuardedExpr [] e]) prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration" prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 0cb2a8b634..004374bf27 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -17,7 +17,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Data.Graph import Data.List (intersect) -import Data.Maybe (isJust) +import Data.Maybe (isJust, mapMaybe) import qualified Data.List.NonEmpty as NEL import qualified Data.Set as S @@ -66,13 +66,13 @@ createBindingGroups moduleName = mapM f <=< handleDecls -- handleDecls :: [Declaration] -> m [Declaration] handleDecls ds = do - let values = filter isValueDecl ds + let values = mapMaybe (fmap (fmap extractGuardedExpr) . getValueDeclaration) ds dataDecls = filter isDataDecl ds allProperNames = fmap declTypeName dataDecls dataVerts = fmap (\d -> (d, declTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup - let allIdents = fmap declIdent values - valueVerts = fmap (\d -> (d, declIdent d, usedIdents moduleName d `intersect` allIdents)) values + let allIdents = fmap valdeclIdent values + valueVerts = fmap (\d -> (d, valdeclIdent d, usedIdents moduleName d `intersect` allIdents)) values bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName) return $ filter isImportDecl ds ++ filter isExternKindDecl ds ++ @@ -83,6 +83,9 @@ createBindingGroups moduleName = mapM f <=< handleDecls filter isFixityDecl ds ++ filter isExternDecl ds ++ bindingGroupDecls + where + extractGuardedExpr [MkUnguarded expr] = expr + extractGuardedExpr _ = internalError "Expected Guards to have been desugared in handleDecls." -- | -- Collapse all binding groups to individual declarations @@ -95,22 +98,18 @@ collapseBindingGroups = go (DataBindingGroupDeclaration ds) = NEL.toList ds go (BindingGroupDeclaration ds) = NEL.toList $ fmap (\((sa, ident), nameKind, val) -> - ValueDeclaration sa ident nameKind [] [MkUnguarded val]) ds + ValueDeclaration (ValueDeclarationData sa ident nameKind [] [MkUnguarded val])) ds go other = [other] collapseBindingGroupsForValue :: Expr -> Expr collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val collapseBindingGroupsForValue other = other -usedIdents :: ModuleName -> Declaration -> [Ident] -usedIdents moduleName = ordNub . usedIdents' S.empty . getValue +usedIdents :: ModuleName -> ValueDeclarationData Expr -> [Ident] +usedIdents moduleName = ordNub . usedIdents' S.empty . valdeclExpression where def _ _ = [] - getValue (ValueDeclaration _ _ _ [] [MkUnguarded val]) = val - getValue ValueDeclaration{} = internalError "Binders should have been desugared" - getValue _ = internalError "Expected ValueDeclaration" - (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def usedNamesE :: S.Set Ident -> Expr -> [Ident] @@ -149,10 +148,6 @@ usedTypeNames moduleName = | moduleName == moduleName' = [name] usedNames _ = [] -declIdent :: Declaration -> Ident -declIdent (ValueDeclaration _ ident _ _ _) = ident -declIdent _ = internalError "Expected ValueDeclaration" - declTypeName :: Declaration -> ProperName 'TypeName declTypeName (DataDeclaration _ _ pn _ _) = pn declTypeName (TypeSynonymDeclaration _ pn _ _) = pn @@ -166,9 +161,9 @@ toBindingGroup :: forall m . (MonadError MultipleErrors m) => ModuleName - -> SCC Declaration + -> SCC (ValueDeclarationData Expr) -> m Declaration -toBindingGroup _ (AcyclicSCC d) = return d +toBindingGroup _ (AcyclicSCC d) = return (mkDeclaration d) toBindingGroup moduleName (CyclicSCC ds') = do -- Once we have a mutually-recursive group of declarations, we need to sort -- them further by their immediate dependencies (those outside function @@ -184,16 +179,15 @@ toBindingGroup moduleName (CyclicSCC ds') = do idents :: [Ident] idents = fmap (\(_, i, _) -> i) valueVerts - valueVerts :: [(Declaration, Ident, [Ident])] - valueVerts = fmap (\d -> (d, declIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds' + valueVerts :: [(ValueDeclarationData Expr, Ident, [Ident])] + valueVerts = fmap (\d -> (d, valdeclIdent d, usedImmediateIdents moduleName (mkDeclaration d) `intersect` idents)) ds' - toBinding :: SCC Declaration -> m ((SourceAnn, Ident), NameKind, Expr) + toBinding :: SCC (ValueDeclarationData Expr) -> m ((SourceAnn, Ident), NameKind, Expr) toBinding (AcyclicSCC d) = return $ fromValueDecl d toBinding (CyclicSCC ds) = throwError $ foldMap cycleError ds - cycleError :: Declaration -> MultipleErrors - cycleError (ValueDeclaration (ss, _) n _ _ [MkUnguarded _]) = errorMessage' ss $ CycleInDeclaration n - cycleError _ = internalError "cycleError: Expected ValueDeclaration" + cycleError :: ValueDeclarationData Expr -> MultipleErrors + cycleError (ValueDeclarationData (ss, _) n _ _ _) = errorMessage' ss $ CycleInDeclaration n toDataBindingGroup :: MonadError MultipleErrors m @@ -211,7 +205,9 @@ isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName) isTypeSynonym (TypeSynonymDeclaration _ pn _ _) = Just pn isTypeSynonym _ = Nothing -fromValueDecl :: Declaration -> ((SourceAnn, Ident), NameKind, Expr) -fromValueDecl (ValueDeclaration sa ident nameKind [] [MkUnguarded val]) = ((sa, ident), nameKind, val) -fromValueDecl ValueDeclaration{} = internalError "Binders should have been desugared" -fromValueDecl _ = internalError "Expected ValueDeclaration" +mkDeclaration :: ValueDeclarationData Expr -> Declaration +mkDeclaration = ValueDeclaration . fmap (pure . MkUnguarded) + +fromValueDecl :: ValueDeclarationData Expr -> ((SourceAnn, Ident), NameKind, Expr) +fromValueDecl (ValueDeclarationData sa ident nameKind [] val) = ((sa, ident), nameKind, val) +fromValueDecl ValueDeclarationData{} = internalError "Binders should have been desugared" diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 66cf9c953f..6595064c0d 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -65,7 +65,7 @@ desugarGuardedExprs ss (Case scrut alternatives) (scrut', scrut_decls) <- unzip <$> forM scrut (\e -> do scrut_id <- freshIdent' pure ( Var (Qualified Nothing scrut_id) - , ValueDeclaration (ss, []) scrut_id Private [] [MkUnguarded e] + , ValueDeclaration (ValueDeclarationData (ss, []) scrut_id Private [] [MkUnguarded e]) ) ) Let scrut_decls <$> desugarGuardedExprs ss (Case scrut' alternatives) @@ -231,7 +231,7 @@ desugarGuardedExprs ss (Case scrut alternatives) = alt_fail = [CaseAlternative [NullBinder] [MkUnguarded goto_rem_case]] pure $ Let [ - ValueDeclaration (ss, []) rem_case_id Private [] + ValueDeclaration $ ValueDeclarationData (ss, []) rem_case_id Private [] [MkUnguarded (Abs (VarBinder unused_binder) desugared)] ] (mk_body alt_fail) @@ -328,10 +328,10 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro desugarRest :: [Declaration] -> m [Declaration] desugarRest (TypeInstanceDeclaration sa name constraints className tys ds : rest) = (:) <$> (TypeInstanceDeclaration sa name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest - desugarRest (ValueDeclaration sa name nameKind bs result : rest) = + desugarRest (ValueDeclaration (ValueDeclarationData sa name nameKind bs result) : rest) = let (_, f, _) = everywhereOnValuesTopDownM return go return f' = mapM (\(GuardedExpr gs e) -> GuardedExpr gs <$> f e) - in (:) <$> (ValueDeclaration sa name nameKind bs <$> f' result) <*> desugarRest rest + in (:) <$> (ValueDeclaration <$> (ValueDeclarationData sa name nameKind bs <$> f' result)) <*> desugarRest rest where go (Let ds val') = Let <$> desugarCases ds <*> pure val' go other = return other @@ -339,15 +339,15 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro desugarRest [] = pure [] inSameGroup :: Declaration -> Declaration -> Bool -inSameGroup (ValueDeclaration _ ident1 _ _ _) (ValueDeclaration _ ident2 _ _ _) = ident1 == ident2 +inSameGroup (ValueDeclaration vd1) (ValueDeclaration vd2) = valdeclIdent vd1 == valdeclIdent vd2 inSameGroup _ _ = False toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] -toDecls [ValueDeclaration sa@(ss, _) ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do +toDecls [ValueDeclaration (ValueDeclarationData sa@(ss, _) ident nameKind bs [MkUnguarded val])] | all isIrrefutable bs = do args <- mapM fromVarBinder bs let body = foldr (Abs . VarBinder) val args guardWith (errorMessage' ss (OverlappingArgNames (Just ident))) $ length (ordNub args) == length args - return [ValueDeclaration sa ident nameKind [] [MkUnguarded body]] + return [ValueDeclaration (ValueDeclarationData sa ident nameKind [] [MkUnguarded body])] where fromVarBinder :: Binder -> m Ident fromVarBinder NullBinder = freshIdent' @@ -355,7 +355,7 @@ toDecls [ValueDeclaration sa@(ss, _) ident nameKind bs [MkUnguarded val]] | all fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b fromVarBinder (TypedBinder _ b) = fromVarBinder b fromVarBinder _ = internalError "fromVarBinder: Invalid argument" -toDecls ds@(ValueDeclaration (ss, _) ident _ bs (result : _) : _) = do +toDecls ds@(ValueDeclaration (ValueDeclarationData (ss, _) ident _ bs (result : _)) : _) = do let tuples = map toTuple ds isGuarded (MkUnguarded _) = False @@ -370,7 +370,7 @@ toDecls ds@(ValueDeclaration (ss, _) ident _ bs (result : _) : _) = do toDecls ds = return ds toTuple :: Declaration -> ([Binder], [GuardedExpr]) -toTuple (ValueDeclaration _ _ _ bs result) = (bs, result) +toTuple (ValueDeclaration (ValueDeclarationData _ _ _ bs result)) = (bs, result) toTuple _ = internalError "Not a value declaration" makeCaseDeclaration :: forall m. (MonadSupply m) => SourceSpan -> Ident -> [([Binder], [GuardedExpr])] -> m Declaration @@ -384,7 +384,7 @@ makeCaseDeclaration ss ident alternatives = do binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] let value = foldr (Abs . VarBinder) (Case vars binders) args - return $ ValueDeclaration (ss, []) ident Public [] [MkUnguarded value] + return $ ValueDeclaration (ValueDeclarationData (ss, []) ident Public [] [MkUnguarded value]) where -- We will construct a table of potential names. -- VarBinders will become Just _ which is a potential name. diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 282602a43c..24374112ea 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -61,7 +61,7 @@ desugarDo d = go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet go (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () - checkBind (ValueDeclaration (ss, _) i@(Ident name) _ _ _) + checkBind (ValueDeclaration (ValueDeclarationData (ss, _) i@(Ident name) _ _ _)) | name `elem` [ C.bind, C.discard ] = throwError . errorMessage' ss $ CannotUseBindWithDo i checkBind _ = pure () mapM_ checkBind ds diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 7c4c41b8a9..4f341cf172 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -303,8 +303,7 @@ renameInModule imports (Module modSS coms mn decls exps) = updatePatGuard _ = [] letBoundVariable :: Declaration -> Maybe Ident - letBoundVariable (ValueDeclaration _ ident _ _ _) = Just ident - letBoundVariable _ = Nothing + letBoundVariable = fmap valdeclIdent . getValueDeclaration updateKindsEverywhere :: SourceSpan -> Kind -> m Kind updateKindsEverywhere pos = everywhereOnKindsM updateKind diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index b3c195c692..14156c709d 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -45,8 +45,8 @@ findExportable (Module _ _ mn ds _) = exportType Internal exps tn [] mn updateExports exps (ExternDataDeclaration _ tn _) = exportType Internal exps tn [] mn - updateExports exps (ValueDeclaration _ name _ _ _) = - exportValue exps name mn + updateExports exps (ValueDeclaration vd) = + exportValue exps (valdeclIdent vd) mn updateExports exps (ValueFixityDeclaration _ _ _ op) = exportValueOp exps op mn updateExports exps (TypeFixityDeclaration _ _ _ op) = diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index fafa345509..8233a1de00 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -69,7 +69,7 @@ desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d then Abs (VarBinder val) <$> wrapLambda (buildUpdates valExpr) ps else wrapLambda (buildLet val . buildUpdates valExpr) ps where - buildLet val = Let [ValueDeclaration (declSourceSpan d, []) val Public [] [MkUnguarded obj]] + buildLet val = Let [ValueDeclaration (ValueDeclarationData (declSourceSpan d, []) val Public [] [MkUnguarded obj])] -- recursively build up the nested `ObjectUpdate` expressions buildUpdates :: Expr -> PathTree Expr -> Expr diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 50a024f97c..a36f617c29 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -187,7 +187,7 @@ desugarDecl mn exps = go go d@(TypeInstanceDeclaration sa name deps className tys (NewtypeInstanceWithDictionary dict)) = do let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (foldr ConstrainedType dictTy deps) - return (expRef name className tys, [d, ValueDeclaration sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) + return (expRef name className tys, [d, ValueDeclaration $ ValueDeclarationData sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) go other = return (Nothing, [other]) expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef @@ -249,7 +249,7 @@ typeClassMemberToDictionaryAccessor -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarationData sa ident ty)) = let className = Qualified (Just mn) name - in ValueDeclaration sa ident Private [] $ + in ValueDeclaration $ ValueDeclarationData sa ident Private [] $ [MkUnguarded ( TypedValue False (TypeClassDictionaryAccessor className ident) $ moveQuantifiersToFront (quantify (ConstrainedType (Constraint className (map (TypeVar . fst) args) Nothing) ty)) @@ -301,19 +301,19 @@ typeInstanceDictionaryDeclaration sa name mn deps className tys decls = dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (foldr ConstrainedType dictTy deps) dict = TypeClassDictionaryConstructorApp className props - result = ValueDeclaration sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)] + result = ValueDeclaration (ValueDeclarationData sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]) return result where memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr - memberToValue tys' (ValueDeclaration _ ident _ [] [MkUnguarded val]) = do + memberToValue tys' (ValueDeclaration (ValueDeclarationData _ ident _ [] [MkUnguarded val])) = do _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys' return val memberToValue _ _ = internalError "Invalid declaration in type instance definition" declIdent :: Declaration -> Maybe Ident -declIdent (ValueDeclaration _ ident _ _ _) = Just ident +declIdent (ValueDeclaration vd) = Just (valdeclIdent vd) declIdent (TypeDeclaration td) = Just (tydeclIdent td) declIdent _ = Nothing diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 503487cbb1..490ab360f6 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -289,9 +289,9 @@ deriveGeneric ss mn syns ds tyConNm dargs = do toSpine <- mkSpineFunction tyCon fromSpine <- mkFromSpineFunction tyCon toSignature <- mkSignatureFunction tyCon dargs - return [ ValueDeclaration (ss, []) (Ident C.toSpine) Public [] (unguarded toSpine) - , ValueDeclaration (ss, []) (Ident C.fromSpine) Public [] (unguarded fromSpine) - , ValueDeclaration (ss, []) (Ident C.toSignature) Public [] (unguarded toSignature) + return [ ValueDeclaration $ ValueDeclarationData (ss, []) (Ident C.toSpine) Public [] (unguarded toSpine) + , ValueDeclaration $ ValueDeclarationData (ss, []) (Ident C.fromSpine) Public [] (unguarded fromSpine) + , ValueDeclaration $ ValueDeclarationData (ss, []) (Ident C.toSignature) Public [] (unguarded toSignature) ] where mkSpineFunction :: Declaration -> m Expr @@ -467,19 +467,19 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do let rep = toRepTy reps inst | null reps = -- If there are no cases, spin - [ ValueDeclaration (ss, []) (Ident "to") Public [] $ unguarded $ + [ ValueDeclaration $ ValueDeclarationData (ss, []) (Ident "to") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] (unguarded (App toName (Var (Qualified Nothing x)))) ] - , ValueDeclaration (ss, []) (Ident "from") Public [] $ unguarded $ + , ValueDeclaration $ ValueDeclarationData (ss, []) (Ident "from") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] (unguarded (App fromName (Var (Qualified Nothing x)))) ] ] | otherwise = - [ ValueDeclaration (ss, []) (Ident "to") Public [] $ unguarded $ + [ ValueDeclaration $ ValueDeclarationData (ss, []) (Ident "to") Public [] $ unguarded $ lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to) - , ValueDeclaration (ss, []) (Ident "from") Public [] $ unguarded $ + , ValueDeclaration $ ValueDeclarationData (ss, []) (Ident "from") Public [] $ unguarded $ lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from) ] @@ -649,7 +649,7 @@ deriveEq deriveEq ss mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds eqFun <- mkEqFunction tyCon - return [ ValueDeclaration (ss, []) (Ident C.eq) Public [] (unguarded eqFun) ] + return [ ValueDeclaration $ ValueDeclarationData (ss, []) (Ident C.eq) Public [] (unguarded eqFun) ] where mkEqFunction :: Declaration -> m Expr mkEqFunction (DataDeclaration _ _ _ _ args) = do @@ -705,7 +705,7 @@ deriveOrd deriveOrd ss mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds compareFun <- mkCompareFunction tyCon - return [ ValueDeclaration (ss, []) (Ident C.compare) Public [] (unguarded compareFun) ] + return [ ValueDeclaration $ ValueDeclarationData (ss, []) (Ident C.compare) Public [] (unguarded compareFun) ] where mkCompareFunction :: Declaration -> m Expr mkCompareFunction (DataDeclaration _ _ _ _ args) = do @@ -806,9 +806,9 @@ deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do let (ctorName, [ty]) = head dctors ty' <- replaceAllTypeSynonymsM syns ty let inst = - [ ValueDeclaration (ss, []) (Ident "wrap") Public [] $ unguarded $ + [ ValueDeclaration $ ValueDeclarationData (ss, []) (Ident "wrap") Public [] $ unguarded $ Constructor (Qualified (Just mn) ctorName) - , ValueDeclaration (ss, []) (Ident "unwrap") Public [] $ unguarded $ + , ValueDeclaration $ ValueDeclarationData (ss, []) (Ident "unwrap") Public [] $ unguarded $ lamCase wrappedIdent [ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]] @@ -886,7 +886,7 @@ deriveFunctor deriveFunctor ss mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds mapFun <- mkMapFunction tyCon - return [ ValueDeclaration (ss, []) (Ident C.map) Public [] (unguarded mapFun) ] + return [ ValueDeclaration $ ValueDeclarationData (ss, []) (Ident C.map) Public [] (unguarded mapFun) ] where mkMapFunction :: Declaration -> m Expr mkMapFunction (DataDeclaration (ss', _) _ _ tys ctors) = case reverse tys of diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index d4d38c1f5d..ca92271a52 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -31,19 +31,19 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) = desugarTypeDeclarations :: [Declaration] -> m [Declaration] desugarTypeDeclarations (TypeDeclaration (TypeDeclarationData sa name' ty) : d : rest) = do (_, nameKind, val) <- fromValueDeclaration d - desugarTypeDeclarations (ValueDeclaration sa name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest) + desugarTypeDeclarations (ValueDeclaration (ValueDeclarationData sa name' nameKind [] [MkUnguarded (TypedValue True val ty)]) : rest) where fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr) - fromValueDeclaration (ValueDeclaration _ name'' nameKind [] [MkUnguarded val]) + fromValueDeclaration (ValueDeclaration (ValueDeclarationData _ name'' nameKind [] [MkUnguarded val])) | name' == name'' = return (name'', nameKind, val) fromValueDeclaration d' = throwError . errorMessage' (declSourceSpan d') $ OrphanTypeDeclaration name' desugarTypeDeclarations [TypeDeclaration (TypeDeclarationData (ss, _) name' _)] = throwError . errorMessage' ss $ OrphanTypeDeclaration name' - desugarTypeDeclarations (ValueDeclaration sa name' nameKind bs val : rest) = do + desugarTypeDeclarations (ValueDeclaration (ValueDeclarationData sa name' nameKind bs val) : rest) = do let (_, f, _) = everywhereOnValuesTopDownM return go return f' = mapM (\(GuardedExpr g e) -> GuardedExpr g <$> f e) - (:) <$> (ValueDeclaration sa name' nameKind bs <$> f' val) + (:) <$> (ValueDeclaration <$> (ValueDeclarationData sa name' nameKind bs <$> f' val)) <*> desugarTypeDeclarations rest where go (Let ds' val') = Let <$> desugarTypeDeclarations ds' <*> pure val' diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 15c653fcc0..255ae71587 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -267,14 +267,14 @@ typeCheckAll moduleName _ = traverse go return $ TypeSynonymDeclaration sa name args ty go TypeDeclaration{} = internalError "Type declarations should have been removed before typeCheckAlld" - go (ValueDeclaration sa@(ss, _) name nameKind [] [MkUnguarded val]) = do + go (ValueDeclaration (ValueDeclarationData sa@(ss, _) name nameKind [] [MkUnguarded val])) = do env <- getEnv warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (PositionedError ss)) $ do val' <- checkExhaustiveExpr ss env moduleName val valueIsNotDefined moduleName name [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] addValue moduleName name ty nameKind - return $ ValueDeclaration sa name nameKind [] [MkUnguarded val''] + return $ ValueDeclaration $ ValueDeclarationData sa name nameKind [] [MkUnguarded val''] go ValueDeclaration{} = internalError "Binders were not desugared" go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared" go (BindingGroupDeclaration vals) = do @@ -343,7 +343,7 @@ typeCheckAll moduleName _ = traverse go return instDecls where memberName :: Declaration -> Ident - memberName (ValueDeclaration _ ident _ _ _) = ident + memberName (ValueDeclaration vd) = valdeclIdent vd memberName _ = internalError "checkInstanceMembers: Invalid declaration in type instance definition" firstDuplicate :: (Eq a) => [a] -> Maybe a diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index c3d95f8fda..0f736cd905 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -426,7 +426,7 @@ inferLetBinding -> (Expr -> m Expr) -> m ([Declaration], Expr) inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) -inferLetBinding seen (ValueDeclaration sa@(ss, _) ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)] : rest) ret j = +inferLetBinding seen (ValueDeclaration (ValueDeclarationData sa@(ss, _) ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)]) : rest) ret j = warnAndRethrowWithPositionTC ss $ do Just moduleName <- checkCurrentModule <$> get (kind, args) <- kindOfWithScopedVars ty @@ -434,14 +434,16 @@ inferLetBinding seen (ValueDeclaration sa@(ss, _) ident nameKind [] [MkUnguarded let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined) ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv - bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j -inferLetBinding seen (ValueDeclaration sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = + bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) + $ inferLetBinding (seen ++ [ValueDeclaration $ ValueDeclarationData sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j +inferLetBinding seen (ValueDeclaration (ValueDeclarationData sa@(ss, _) ident nameKind [] [MkUnguarded val]) : rest) ret j = warnAndRethrowWithPositionTC ss $ do valTy <- freshType let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined) TypedValue _ val' valTy' <- bindNames dict $ infer val unifyTypes valTy valTy' - bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration sa ident nameKind [] [MkUnguarded val']]) rest ret j + bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) + $ inferLetBinding (seen ++ [ValueDeclaration $ ValueDeclarationData sa ident nameKind [] [MkUnguarded val']]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do Just moduleName <- checkCurrentModule <$> get SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 0b65de688f..4da31bd201 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -23,7 +23,7 @@ ann2 = (span2, []) typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, foreign1, foreign2, foreign3, member1 :: P.Declaration typeAnnotation1 = P.TypeDeclaration (P.TypeDeclarationData ann1 (P.Ident "value1") P.REmpty) -value1 = P.ValueDeclaration ann1 (P.Ident "value1") P.Public [] [] +value1 = P.ValueDeclaration $ P.ValueDeclarationData ann1 (P.Ident "value1") P.Public [] [] synonym1 = P.TypeSynonymDeclaration ann1 (P.ProperName "Synonym1") [] P.REmpty class1 = P.TypeClassDeclaration ann1 (P.ProperName "Class1") [] [] [] [] class2 = P.TypeClassDeclaration ann1 (P.ProperName "Class2") [] [] [] [member1] From c9c4385e78360218bcf254c03fbd8daed73b7acc Mon Sep 17 00:00:00 2001 From: Coot Date: Tue, 22 Aug 2017 22:28:22 +0200 Subject: [PATCH 0851/1580] inline Unsafe.Coerce.unsafeCoerce (#3050) * inline Unsafe.Coerce.unsafeCoerce * add a test --- examples/passing/UnsafeCoerce.purs | 16 ++++++++++++++++ src/Language/PureScript/Constants.hs | 6 ++++++ src/Language/PureScript/CoreImp/Optimizer.hs | 2 +- .../PureScript/CoreImp/Optimizer/Inliner.hs | 8 ++++++++ 4 files changed, 31 insertions(+), 1 deletion(-) create mode 100644 examples/passing/UnsafeCoerce.purs diff --git a/examples/passing/UnsafeCoerce.purs b/examples/passing/UnsafeCoerce.purs new file mode 100644 index 0000000000..6b4dbb1022 --- /dev/null +++ b/examples/passing/UnsafeCoerce.purs @@ -0,0 +1,16 @@ +module Main where + +import Prelude (Unit) +import Unsafe.Coerce (unsafeCoerce) +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) + +x :: Number +x = unsafeCoerce 1 + +y :: Number +y = case unsafeCoerce 1 of + z -> unsafeCoerce z + +main :: Eff (console :: CONSOLE) Unit +main = log "Done" diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 73341f80c4..717aab7098 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -479,3 +479,9 @@ partialUnsafe = "Partial_Unsafe" unsafePartial :: forall a. (IsString a) => a unsafePartial = "unsafePartial" + +unsafeCoerce :: forall a. (IsString a) => a +unsafeCoerce = "Unsafe_Coerce" + +unsafeCoerceFn :: forall a. (IsString a) => a +unsafeCoerceFn = "unsafeCoerce" diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs index cfdee15ca9..e85e3efaf9 100644 --- a/src/Language/PureScript/CoreImp/Optimizer.hs +++ b/src/Language/PureScript/CoreImp/Optimizer.hs @@ -33,7 +33,7 @@ import Language.PureScript.CoreImp.Optimizer.Unused -- | Apply a series of optimizer passes to simplified JavaScript code optimize :: MonadSupply m => AST -> m AST optimize js = do - js' <- untilFixedPoint (inlineFnComposition . inlineUnsafePartial . tidyUp . applyAll + js' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . applyAll [ inlineCommonValues , inlineCommonOperators ]) js diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index 0c091e6497..d7dc9989c5 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -4,6 +4,7 @@ module Language.PureScript.CoreImp.Optimizer.Inliner , inlineCommonValues , inlineCommonOperators , inlineFnComposition + , inlineUnsafeCoerce , inlineUnsafePartial , etaConvert , unThunk @@ -265,6 +266,13 @@ inlineFnComposition = everywhereTopDownM convert where fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b) fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped) +inlineUnsafeCoerce :: AST -> AST +inlineUnsafeCoerce = everywhereTopDown convert where + convert (App _ (Indexer _ (StringLiteral _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ]) + | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce + = comp + convert other = other + inlineUnsafePartial :: AST -> AST inlineUnsafePartial = everywhereTopDown convert where convert (App ss (Indexer _ (StringLiteral _ unsafePartial) (Var _ partialUnsafe)) [ comp ]) From 3a6f3f6dd7981cc41e318d8000b06c044e98c54c Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 22 Aug 2017 22:35:15 +0200 Subject: [PATCH 0852/1580] Adds a pattern synonym for ValueDeclarations (#3051) --- src/Language/PureScript/AST/Declarations.hs | 4 ++++ src/Language/PureScript/AST/Traversals.hs | 18 +++++++------- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- .../PureScript/Docs/Convert/Single.hs | 4 ++-- src/Language/PureScript/Ide/SourceFile.hs | 2 +- .../PureScript/Interactive/Completion.hs | 2 +- src/Language/PureScript/Interactive/Module.hs | 4 ++-- src/Language/PureScript/Linter/Exhaustive.hs | 6 ++--- .../PureScript/Parser/Declarations.hs | 2 +- src/Language/PureScript/Pretty/Values.hs | 4 ++-- .../PureScript/Sugar/BindingGroups.hs | 2 +- .../PureScript/Sugar/CaseDeclarations.hs | 18 +++++++------- src/Language/PureScript/Sugar/DoNotation.hs | 2 +- .../PureScript/Sugar/ObjectWildcards.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 8 +++---- .../PureScript/Sugar/TypeClasses/Deriving.hs | 24 +++++++++---------- .../PureScript/Sugar/TypeDeclarations.hs | 8 +++---- src/Language/PureScript/TypeChecker.hs | 4 ++-- src/Language/PureScript/TypeChecker/Types.hs | 8 +++---- .../Language/PureScript/Ide/SourceFileSpec.hs | 2 +- 20 files changed, 65 insertions(+), 61 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index e4ea628365..67c2baa13b 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -450,6 +450,10 @@ getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr]) getValueDeclaration (ValueDeclaration d) = Just d getValueDeclaration _ = Nothing +pattern ValueDecl :: SourceAnn -> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration +pattern ValueDecl sann ident name binders expr + = ValueDeclaration (ValueDeclarationData sann ident name binders expr) + -- | -- The data type of declarations -- diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 7148dff737..4da91b128e 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -53,8 +53,8 @@ everywhereOnValues f g h = (f', g', h') where f' :: Declaration -> Declaration f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (fmap f' ds)) - f' (ValueDeclaration (ValueDeclarationData sa name nameKind bs val)) = - f (ValueDeclaration (ValueDeclarationData sa name nameKind (fmap h' bs) (fmap (mapGuardedExpr handleGuard g') val))) + f' (ValueDecl sa name nameKind bs val) = + f (ValueDecl sa name nameKind (fmap h' bs) (fmap (mapGuardedExpr handleGuard g') val)) f' (BoundValueDeclaration sa b expr) = f (BoundValueDeclaration sa (h' b) (g' expr)) f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (fmap (\(name, nameKind, val) -> (name, nameKind, g' val)) ds)) f' (TypeClassDeclaration sa name args implies deps ds) = f (TypeClassDeclaration sa name args implies deps (fmap f' ds)) @@ -126,8 +126,8 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds - f' (ValueDeclaration (ValueDeclarationData sa name nameKind bs val)) = - ValueDeclaration <$> (ValueDeclarationData sa name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val) + f' (ValueDecl sa name nameKind bs val) = + ValueDecl sa name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds f' (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f' <=< f) ds f' (TypeInstanceDeclaration sa name cs className args ds) = TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds @@ -194,8 +194,8 @@ everywhereOnValuesM f g h = (f', g', h') f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f - f' (ValueDeclaration (ValueDeclarationData sa name nameKind bs val)) = - ValueDeclaration <$> (ValueDeclarationData sa name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val) >>= f + f' (ValueDecl sa name nameKind bs val) = + ValueDecl sa name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val >>= f f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f f' (BoundValueDeclaration sa b expr) = (BoundValueDeclaration sa <$> h' b <*> g' expr) >>= f f' (TypeClassDeclaration sa name args implies deps ds) = (TypeClassDeclaration sa name args implies deps <$> traverse f' ds) >>= f @@ -429,8 +429,8 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j f'' s = uncurry f' <=< f s f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds - f' s (ValueDeclaration (ValueDeclarationData sa name nameKind bs val)) = - ValueDeclaration <$> (ValueDeclarationData sa name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val) + f' s (ValueDecl sa name nameKind bs val) = + ValueDecl sa name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds f' s (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f'' s) ds f' s (TypeInstanceDeclaration sa name cs className args ds) = TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds @@ -512,7 +512,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) f' s (DataBindingGroupDeclaration ds) = let s' = S.union s (S.fromList (mapMaybe getDeclIdent (NEL.toList ds))) in foldMap (f'' s') ds - f' s (ValueDeclaration (ValueDeclarationData _ name _ bs val)) = + f' s (ValueDecl _ name _ bs val) = let s' = S.insert name s s'' = S.union s' (S.fromList (concatMap binderNames bs)) in foldMap (h'' s') bs <> foldMap (l' s'') val diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 82866d8efc..03873fb46e 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -63,7 +63,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields declToCoreFn (A.DataBindingGroupDeclaration ds) = concatMap declToCoreFn ds - declToCoreFn (A.ValueDeclaration (A.ValueDeclarationData (ss, com) name _ _ [A.MkUnguarded e])) = + declToCoreFn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] declToCoreFn (A.BindingGroupDeclaration ds) = [Rec . NEL.toList $ fmap (\(((ss, com), name), _, e) -> ((ssA ss, name), exprToCoreFn ss com Nothing e)) ds] diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index c3ea08db17..3ca683861f 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -108,9 +108,9 @@ basicDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Maybe Intermediate basicDeclaration sa title = Just . Right . mkDeclaration sa title convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration -convertDeclaration (P.ValueDeclaration (P.ValueDeclarationData sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)])) title = +convertDeclaration (P.ValueDecl sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title = basicDeclaration sa title (ValueDeclaration ty) -convertDeclaration (P.ValueDeclaration (P.ValueDeclarationData sa _ _ _ _)) title = +convertDeclaration (P.ValueDecl sa _ _ _ _) title = -- If no explicit type declaration was provided, insert a wildcard, so that -- the actual type will be added during type checking. basicDeclaration sa title (ValueDeclaration P.TypeWildcard{}) diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index b7eeeabcde..7b36e60bdd 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -76,7 +76,7 @@ extractSpans -> [(IdeNamespaced, P.SourceSpan)] -- ^ Declarations and their source locations extractSpans d = case d of - P.ValueDeclaration (P.ValueDeclarationData (ss, _) i _ _ _) -> + P.ValueDecl (ss, _) i _ _ _ -> [(IdeNamespaced IdeNSValue (P.runIdent i), ss)] P.TypeSynonymDeclaration (ss, _) name _ _ -> [(IdeNamespaced IdeNSType (P.runProperName name), ss)] diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index 866b7db3f4..b6e12fe340 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -205,7 +205,7 @@ identNames :: P.Module -> [(N.Ident, P.Declaration)] identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations where getDeclNames :: P.Declaration -> [(P.Ident, P.Declaration)] - getDeclNames d@(P.ValueDeclaration (P.ValueDeclarationData _ ident _ _ _)) = [(ident, d)] + getDeclNames d@(P.ValueDecl _ ident _ _ _) = [(ident, d)] getDeclNames d@(P.TypeDeclaration td) = [(P.tydeclIdent td, d)] getDeclNames d@(P.ExternDeclaration _ ident _) = [(ident, d)] getDeclNames d@(P.TypeClassDeclaration _ _ _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 5b8691739c..f68a37351b 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -51,7 +51,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"])) eval = P.Var (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval")) mainValue = P.App eval (P.Var (P.Qualified Nothing (P.Ident "it"))) - itDecl = P.ValueDeclaration $ P.ValueDeclarationData (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val] + itDecl = P.ValueDecl (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val] typeDecl = P.TypeDeclaration (P.TypeDeclarationData (internalSpan, []) (P.Ident "$main") (P.TypeApp @@ -60,7 +60,7 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi (P.Qualified (Just (P.ModuleName [P.ProperName "$Eff"])) (P.ProperName "Eff"))) (P.TypeWildcard internalSpan)) (P.TypeWildcard internalSpan))) - mainDecl = P.ValueDeclaration $ P.ValueDeclarationData (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] + mainDecl = P.ValueDecl (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] in P.Module internalSpan diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index e5bf1cb727..30ad256827 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -295,7 +295,7 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' where partial :: Text -> Text -> Declaration partial var tyVar = - ValueDeclaration $ ValueDeclarationData (ss, []) (Ident C.__unused) Private [] $ + ValueDecl (ss, []) (Ident C.__unused) Private [] $ [MkUnguarded (TypedValue True @@ -331,8 +331,8 @@ checkExhaustiveExpr initSS env mn = onExpr initSS where onDecl :: Declaration -> m Declaration onDecl (BindingGroupDeclaration bs) = BindingGroupDeclaration <$> mapM (\(sai@((ss, _), _), nk, expr) -> (sai, nk,) <$> onExpr ss expr) bs - onDecl (ValueDeclaration (ValueDeclarationData sa@(ss, _) name x y [MkUnguarded e])) = - ValueDeclaration <$> ValueDeclarationData sa name x y . mkUnguardedExpr <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr ss e) + onDecl (ValueDecl sa@(ss, _) name x y [MkUnguarded e]) = + ValueDecl sa name x y . mkUnguardedExpr <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr ss e) onDecl decl = return decl onExpr :: SourceSpan -> Expr -> m Expr diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index b0db264a78..242312b190 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -87,7 +87,7 @@ parseValueWithIdentAndBinders ident bs = do <*> (indented *> equals *> withSourceSpan PositionedValue parseValueWithWhereClause)) ) - return $ \sa -> ValueDeclaration (ValueDeclarationData sa ident Public bs value) + return $ \sa -> ValueDecl sa ident Public bs value parseValueDeclaration :: TokenParser Declaration parseValueDeclaration = withSourceAnnF $ do diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 4ba0d39d6f..659e98cc8d 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -124,12 +124,12 @@ prettyPrintDeclaration :: Int -> Declaration -> Box prettyPrintDeclaration d _ | d < 0 = ellipsis prettyPrintDeclaration _ (TypeDeclaration td) = text (T.unpack (showIdent (tydeclIdent td)) ++ " :: ") <> typeAsBox (tydeclType td) -prettyPrintDeclaration d (ValueDeclaration (ValueDeclarationData _ ident _ [] [GuardedExpr [] val])) = +prettyPrintDeclaration d (ValueDecl _ ident _ [] [GuardedExpr [] val]) = text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val prettyPrintDeclaration d (BindingGroupDeclaration ds) = vsep 1 left (NEL.toList (fmap (prettyPrintDeclaration (d - 1) . toDecl) ds)) where - toDecl ((sa, nm), t, e) = ValueDeclaration (ValueDeclarationData sa nm t [] [GuardedExpr [] e]) + toDecl ((sa, nm), t, e) = ValueDecl sa nm t [] [GuardedExpr [] e] prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration" prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 004374bf27..f31ad3c213 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -98,7 +98,7 @@ collapseBindingGroups = go (DataBindingGroupDeclaration ds) = NEL.toList ds go (BindingGroupDeclaration ds) = NEL.toList $ fmap (\((sa, ident), nameKind, val) -> - ValueDeclaration (ValueDeclarationData sa ident nameKind [] [MkUnguarded val])) ds + ValueDecl sa ident nameKind [] [MkUnguarded val]) ds go other = [other] collapseBindingGroupsForValue :: Expr -> Expr diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 6595064c0d..a8f15a1d49 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -65,7 +65,7 @@ desugarGuardedExprs ss (Case scrut alternatives) (scrut', scrut_decls) <- unzip <$> forM scrut (\e -> do scrut_id <- freshIdent' pure ( Var (Qualified Nothing scrut_id) - , ValueDeclaration (ValueDeclarationData (ss, []) scrut_id Private [] [MkUnguarded e]) + , ValueDecl (ss, []) scrut_id Private [] [MkUnguarded e] ) ) Let scrut_decls <$> desugarGuardedExprs ss (Case scrut' alternatives) @@ -231,7 +231,7 @@ desugarGuardedExprs ss (Case scrut alternatives) = alt_fail = [CaseAlternative [NullBinder] [MkUnguarded goto_rem_case]] pure $ Let [ - ValueDeclaration $ ValueDeclarationData (ss, []) rem_case_id Private [] + ValueDecl (ss, []) rem_case_id Private [] [MkUnguarded (Abs (VarBinder unused_binder) desugared)] ] (mk_body alt_fail) @@ -328,10 +328,10 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro desugarRest :: [Declaration] -> m [Declaration] desugarRest (TypeInstanceDeclaration sa name constraints className tys ds : rest) = (:) <$> (TypeInstanceDeclaration sa name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest - desugarRest (ValueDeclaration (ValueDeclarationData sa name nameKind bs result) : rest) = + desugarRest (ValueDecl sa name nameKind bs result : rest) = let (_, f, _) = everywhereOnValuesTopDownM return go return f' = mapM (\(GuardedExpr gs e) -> GuardedExpr gs <$> f e) - in (:) <$> (ValueDeclaration <$> (ValueDeclarationData sa name nameKind bs <$> f' result)) <*> desugarRest rest + in (:) <$> (ValueDecl sa name nameKind bs <$> f' result) <*> desugarRest rest where go (Let ds val') = Let <$> desugarCases ds <*> pure val' go other = return other @@ -343,11 +343,11 @@ inSameGroup (ValueDeclaration vd1) (ValueDeclaration vd2) = valdeclIdent vd1 == inSameGroup _ _ = False toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] -toDecls [ValueDeclaration (ValueDeclarationData sa@(ss, _) ident nameKind bs [MkUnguarded val])] | all isIrrefutable bs = do +toDecls [ValueDecl sa@(ss, _) ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do args <- mapM fromVarBinder bs let body = foldr (Abs . VarBinder) val args guardWith (errorMessage' ss (OverlappingArgNames (Just ident))) $ length (ordNub args) == length args - return [ValueDeclaration (ValueDeclarationData sa ident nameKind [] [MkUnguarded body])] + return [ValueDecl sa ident nameKind [] [MkUnguarded body]] where fromVarBinder :: Binder -> m Ident fromVarBinder NullBinder = freshIdent' @@ -355,7 +355,7 @@ toDecls [ValueDeclaration (ValueDeclarationData sa@(ss, _) ident nameKind bs [Mk fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b fromVarBinder (TypedBinder _ b) = fromVarBinder b fromVarBinder _ = internalError "fromVarBinder: Invalid argument" -toDecls ds@(ValueDeclaration (ValueDeclarationData (ss, _) ident _ bs (result : _)) : _) = do +toDecls ds@(ValueDecl (ss, _) ident _ bs (result : _) : _) = do let tuples = map toTuple ds isGuarded (MkUnguarded _) = False @@ -370,7 +370,7 @@ toDecls ds@(ValueDeclaration (ValueDeclarationData (ss, _) ident _ bs (result : toDecls ds = return ds toTuple :: Declaration -> ([Binder], [GuardedExpr]) -toTuple (ValueDeclaration (ValueDeclarationData _ _ _ bs result)) = (bs, result) +toTuple (ValueDecl _ _ _ bs result) = (bs, result) toTuple _ = internalError "Not a value declaration" makeCaseDeclaration :: forall m. (MonadSupply m) => SourceSpan -> Ident -> [([Binder], [GuardedExpr])] -> m Declaration @@ -384,7 +384,7 @@ makeCaseDeclaration ss ident alternatives = do binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] let value = foldr (Abs . VarBinder) (Case vars binders) args - return $ ValueDeclaration (ValueDeclarationData (ss, []) ident Public [] [MkUnguarded value]) + return $ ValueDecl (ss, []) ident Public [] [MkUnguarded value] where -- We will construct a table of potential names. -- VarBinders will become Just _ which is a potential name. diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 24374112ea..4edb6b6f9f 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -61,7 +61,7 @@ desugarDo d = go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet go (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () - checkBind (ValueDeclaration (ValueDeclarationData (ss, _) i@(Ident name) _ _ _)) + checkBind (ValueDecl (ss, _) i@(Ident name) _ _ _) | name `elem` [ C.bind, C.discard ] = throwError . errorMessage' ss $ CannotUseBindWithDo i checkBind _ = pure () mapM_ checkBind ds diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 8233a1de00..7556f940d7 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -69,7 +69,7 @@ desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d then Abs (VarBinder val) <$> wrapLambda (buildUpdates valExpr) ps else wrapLambda (buildLet val . buildUpdates valExpr) ps where - buildLet val = Let [ValueDeclaration (ValueDeclarationData (declSourceSpan d, []) val Public [] [MkUnguarded obj])] + buildLet val = Let [ValueDecl (declSourceSpan d, []) val Public [] [MkUnguarded obj]] -- recursively build up the nested `ObjectUpdate` expressions buildUpdates :: Expr -> PathTree Expr -> Expr diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index a36f617c29..84ce5d9fe2 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -187,7 +187,7 @@ desugarDecl mn exps = go go d@(TypeInstanceDeclaration sa name deps className tys (NewtypeInstanceWithDictionary dict)) = do let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (foldr ConstrainedType dictTy deps) - return (expRef name className tys, [d, ValueDeclaration $ ValueDeclarationData sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) + return (expRef name className tys, [d, ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) go other = return (Nothing, [other]) expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef @@ -249,7 +249,7 @@ typeClassMemberToDictionaryAccessor -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarationData sa ident ty)) = let className = Qualified (Just mn) name - in ValueDeclaration $ ValueDeclarationData sa ident Private [] $ + in ValueDecl sa ident Private [] $ [MkUnguarded ( TypedValue False (TypeClassDictionaryAccessor className ident) $ moveQuantifiersToFront (quantify (ConstrainedType (Constraint className (map (TypeVar . fst) args) Nothing) ty)) @@ -301,13 +301,13 @@ typeInstanceDictionaryDeclaration sa name mn deps className tys decls = dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (foldr ConstrainedType dictTy deps) dict = TypeClassDictionaryConstructorApp className props - result = ValueDeclaration (ValueDeclarationData sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]) + result = ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)] return result where memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr - memberToValue tys' (ValueDeclaration (ValueDeclarationData _ ident _ [] [MkUnguarded val])) = do + memberToValue tys' (ValueDecl _ ident _ [] [MkUnguarded val]) = do _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys' return val memberToValue _ _ = internalError "Invalid declaration in type instance definition" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 490ab360f6..6914f4bb39 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -289,9 +289,9 @@ deriveGeneric ss mn syns ds tyConNm dargs = do toSpine <- mkSpineFunction tyCon fromSpine <- mkFromSpineFunction tyCon toSignature <- mkSignatureFunction tyCon dargs - return [ ValueDeclaration $ ValueDeclarationData (ss, []) (Ident C.toSpine) Public [] (unguarded toSpine) - , ValueDeclaration $ ValueDeclarationData (ss, []) (Ident C.fromSpine) Public [] (unguarded fromSpine) - , ValueDeclaration $ ValueDeclarationData (ss, []) (Ident C.toSignature) Public [] (unguarded toSignature) + return [ ValueDecl (ss, []) (Ident C.toSpine) Public [] (unguarded toSpine) + , ValueDecl (ss, []) (Ident C.fromSpine) Public [] (unguarded fromSpine) + , ValueDecl (ss, []) (Ident C.toSignature) Public [] (unguarded toSignature) ] where mkSpineFunction :: Declaration -> m Expr @@ -467,19 +467,19 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do let rep = toRepTy reps inst | null reps = -- If there are no cases, spin - [ ValueDeclaration $ ValueDeclarationData (ss, []) (Ident "to") Public [] $ unguarded $ + [ ValueDecl (ss, []) (Ident "to") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] (unguarded (App toName (Var (Qualified Nothing x)))) ] - , ValueDeclaration $ ValueDeclarationData (ss, []) (Ident "from") Public [] $ unguarded $ + , ValueDecl (ss, []) (Ident "from") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] (unguarded (App fromName (Var (Qualified Nothing x)))) ] ] | otherwise = - [ ValueDeclaration $ ValueDeclarationData (ss, []) (Ident "to") Public [] $ unguarded $ + [ ValueDecl (ss, []) (Ident "to") Public [] $ unguarded $ lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to) - , ValueDeclaration $ ValueDeclarationData (ss, []) (Ident "from") Public [] $ unguarded $ + , ValueDecl (ss, []) (Ident "from") Public [] $ unguarded $ lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from) ] @@ -649,7 +649,7 @@ deriveEq deriveEq ss mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds eqFun <- mkEqFunction tyCon - return [ ValueDeclaration $ ValueDeclarationData (ss, []) (Ident C.eq) Public [] (unguarded eqFun) ] + return [ ValueDecl (ss, []) (Ident C.eq) Public [] (unguarded eqFun) ] where mkEqFunction :: Declaration -> m Expr mkEqFunction (DataDeclaration _ _ _ _ args) = do @@ -705,7 +705,7 @@ deriveOrd deriveOrd ss mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds compareFun <- mkCompareFunction tyCon - return [ ValueDeclaration $ ValueDeclarationData (ss, []) (Ident C.compare) Public [] (unguarded compareFun) ] + return [ ValueDecl (ss, []) (Ident C.compare) Public [] (unguarded compareFun) ] where mkCompareFunction :: Declaration -> m Expr mkCompareFunction (DataDeclaration _ _ _ _ args) = do @@ -806,9 +806,9 @@ deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do let (ctorName, [ty]) = head dctors ty' <- replaceAllTypeSynonymsM syns ty let inst = - [ ValueDeclaration $ ValueDeclarationData (ss, []) (Ident "wrap") Public [] $ unguarded $ + [ ValueDecl (ss, []) (Ident "wrap") Public [] $ unguarded $ Constructor (Qualified (Just mn) ctorName) - , ValueDeclaration $ ValueDeclarationData (ss, []) (Ident "unwrap") Public [] $ unguarded $ + , ValueDecl (ss, []) (Ident "unwrap") Public [] $ unguarded $ lamCase wrappedIdent [ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]] @@ -886,7 +886,7 @@ deriveFunctor deriveFunctor ss mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds mapFun <- mkMapFunction tyCon - return [ ValueDeclaration $ ValueDeclarationData (ss, []) (Ident C.map) Public [] (unguarded mapFun) ] + return [ ValueDecl (ss, []) (Ident C.map) Public [] (unguarded mapFun) ] where mkMapFunction :: Declaration -> m Expr mkMapFunction (DataDeclaration (ss', _) _ _ tys ctors) = case reverse tys of diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index ca92271a52..1003a10456 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -31,19 +31,19 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) = desugarTypeDeclarations :: [Declaration] -> m [Declaration] desugarTypeDeclarations (TypeDeclaration (TypeDeclarationData sa name' ty) : d : rest) = do (_, nameKind, val) <- fromValueDeclaration d - desugarTypeDeclarations (ValueDeclaration (ValueDeclarationData sa name' nameKind [] [MkUnguarded (TypedValue True val ty)]) : rest) + desugarTypeDeclarations (ValueDecl sa name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest) where fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr) - fromValueDeclaration (ValueDeclaration (ValueDeclarationData _ name'' nameKind [] [MkUnguarded val])) + fromValueDeclaration (ValueDecl _ name'' nameKind [] [MkUnguarded val]) | name' == name'' = return (name'', nameKind, val) fromValueDeclaration d' = throwError . errorMessage' (declSourceSpan d') $ OrphanTypeDeclaration name' desugarTypeDeclarations [TypeDeclaration (TypeDeclarationData (ss, _) name' _)] = throwError . errorMessage' ss $ OrphanTypeDeclaration name' - desugarTypeDeclarations (ValueDeclaration (ValueDeclarationData sa name' nameKind bs val) : rest) = do + desugarTypeDeclarations (ValueDecl sa name' nameKind bs val : rest) = do let (_, f, _) = everywhereOnValuesTopDownM return go return f' = mapM (\(GuardedExpr g e) -> GuardedExpr g <$> f e) - (:) <$> (ValueDeclaration <$> (ValueDeclarationData sa name' nameKind bs <$> f' val)) + (:) <$> (ValueDecl sa name' nameKind bs <$> f' val) <*> desugarTypeDeclarations rest where go (Let ds' val') = Let <$> desugarTypeDeclarations ds' <*> pure val' diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 255ae71587..b7e7facaa6 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -267,14 +267,14 @@ typeCheckAll moduleName _ = traverse go return $ TypeSynonymDeclaration sa name args ty go TypeDeclaration{} = internalError "Type declarations should have been removed before typeCheckAlld" - go (ValueDeclaration (ValueDeclarationData sa@(ss, _) name nameKind [] [MkUnguarded val])) = do + go (ValueDecl sa@(ss, _) name nameKind [] [MkUnguarded val]) = do env <- getEnv warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (PositionedError ss)) $ do val' <- checkExhaustiveExpr ss env moduleName val valueIsNotDefined moduleName name [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] addValue moduleName name ty nameKind - return $ ValueDeclaration $ ValueDeclarationData sa name nameKind [] [MkUnguarded val''] + return $ ValueDecl sa name nameKind [] [MkUnguarded val''] go ValueDeclaration{} = internalError "Binders were not desugared" go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared" go (BindingGroupDeclaration vals) = do diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 0f736cd905..ba438a34c2 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -426,7 +426,7 @@ inferLetBinding -> (Expr -> m Expr) -> m ([Declaration], Expr) inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) -inferLetBinding seen (ValueDeclaration (ValueDeclarationData sa@(ss, _) ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)]) : rest) ret j = +inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)] : rest) ret j = warnAndRethrowWithPositionTC ss $ do Just moduleName <- checkCurrentModule <$> get (kind, args) <- kindOfWithScopedVars ty @@ -435,15 +435,15 @@ inferLetBinding seen (ValueDeclaration (ValueDeclarationData sa@(ss, _) ident na ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) - $ inferLetBinding (seen ++ [ValueDeclaration $ ValueDeclarationData sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j -inferLetBinding seen (ValueDeclaration (ValueDeclarationData sa@(ss, _) ident nameKind [] [MkUnguarded val]) : rest) ret j = + $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j +inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = warnAndRethrowWithPositionTC ss $ do valTy <- freshType let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined) TypedValue _ val' valTy' <- bindNames dict $ infer val unifyTypes valTy valTy' bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) - $ inferLetBinding (seen ++ [ValueDeclaration $ ValueDeclarationData sa ident nameKind [] [MkUnguarded val']]) rest ret j + $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do Just moduleName <- checkCurrentModule <$> get SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 4da31bd201..dbcfed91f0 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -23,7 +23,7 @@ ann2 = (span2, []) typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, foreign1, foreign2, foreign3, member1 :: P.Declaration typeAnnotation1 = P.TypeDeclaration (P.TypeDeclarationData ann1 (P.Ident "value1") P.REmpty) -value1 = P.ValueDeclaration $ P.ValueDeclarationData ann1 (P.Ident "value1") P.Public [] [] +value1 = P.ValueDecl ann1 (P.Ident "value1") P.Public [] [] synonym1 = P.TypeSynonymDeclaration ann1 (P.ProperName "Synonym1") [] P.REmpty class1 = P.TypeClassDeclaration ann1 (P.ProperName "Class1") [] [] [] [] class2 = P.TypeClassDeclaration ann1 (P.ProperName "Class2") [] [] [] [member1] From f124db12c9dbd3bb8fba04e17ae9fbab4288a26c Mon Sep 17 00:00:00 2001 From: Dave Aitken Date: Fri, 1 Sep 2017 15:38:33 +0100 Subject: [PATCH 0853/1580] Add `:complete` directive to psci (#3038) Some wrappers around psci (such as emacs-psci) are unable to hook into the tab-complete functionality provided by psci. There is some basic tab completion in emacs-psci but it currently seems to work only on filenames as far as I'm able to work out. This exposes the completions produced usually by hitting tab to the normal eval/print mechanism via a :complete directive so they can be accessed by these kinds of tools (inspired by https://github.com/commercialhaskell/intero/blob/master/elisp/intero.el#L819). --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Interactive.hs | 15 ++++++- .../PureScript/Interactive/Completion.hs | 10 +++++ .../PureScript/Interactive/Directive.hs | 41 ++++++++++--------- src/Language/PureScript/Interactive/Parser.hs | 22 +++++----- src/Language/PureScript/Interactive/Types.hs | 3 ++ tests/TestPsci/CommandTest.hs | 6 +++ tests/TestPsci/CompletionTest.hs | 10 ++--- tests/TestPsci/TestEnv.hs | 39 ++++++++++++------ 9 files changed, 98 insertions(+), 49 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index f16dd5dcee..abbb1608db 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -15,6 +15,7 @@ If you would prefer to use different terms, please use the section below instead | Username | Name | License | | :------- | :--- | :------ | | [@5outh](https://github.com/5outh) | Benjamin Kovach | MIT license | +| [@actionshrimp](https://github.com/actionshrimp) | David Aitken | [MIT license](http://opensource.org/licenses/MIT) | | [@alexbiehl](https://github.com/alexbiehl) | Alexander Biehl | [MIT license](http://opensource.org/licenses/MIT) | | [@andreypopp](https://github.com/andreypopp) | Andrey Popp | MIT license | | [@andyarvanitis](https://github.com/andyarvanitis) | Andy Arvanitis | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index ac247353ca..ce051e9f3e 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -24,7 +24,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State.Class import Control.Monad.Reader.Class import Control.Monad.Trans.Except (ExceptT(..), runExceptT) -import Control.Monad.Trans.State.Strict (StateT, runStateT) +import Control.Monad.Trans.State.Strict (StateT, runStateT, evalStateT) import Control.Monad.Writer.Strict (Writer(), runWriter) import qualified Language.PureScript as P @@ -110,6 +110,7 @@ handleCommand _ _ p (KindOf typ) = handleKindOf p typ handleCommand _ _ p (BrowseModule moduleName) = handleBrowse p moduleName handleCommand _ _ p (ShowInfo QueryLoaded) = handleShowLoadedModules p handleCommand _ _ p (ShowInfo QueryImport) = handleShowImportedModules p +handleCommand _ _ p (CompleteStr prefix) = handleComplete p prefix handleCommand _ _ _ _ = P.internalError "handleCommand: unexpected command" -- | Reload the application state @@ -307,3 +308,15 @@ handleBrowse print' moduleName = do print' $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid." lookupUnQualifiedModName quaModName st = (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st) + +-- | Return output as would be returned by tab completion, for tools integration etc. +handleComplete + :: (MonadState PSCiState m, MonadIO m) + => (String -> m ()) + -> String + -> m () +handleComplete print' prefix = do + st <- get + let act = liftCompletionM (completion' (reverse prefix, "")) + results <- evalStateT act st + print' $ unlines (formatCompletions results) diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index b6e12fe340..90d05ee871 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -3,6 +3,7 @@ module Language.PureScript.Interactive.Completion , liftCompletionM , completion , completion' + , formatCompletions ) where import Prelude.Compat @@ -85,6 +86,14 @@ findCompletions prev word = do go _ (':' : _) = GT go xs ys = compare xs ys +-- | +-- Convert Haskeline completion result to results as they would be displayed +formatCompletions :: (String, [Completion]) -> [String] +formatCompletions (unusedR, completions) = actuals + where + unused = reverse unusedR + actuals = map ((unused ++) . replacement) completions + data CompletionContext = CtxDirective String | CtxFilePath String @@ -128,6 +137,7 @@ directiveArg _ Paste = [] directiveArg _ Show = map CtxFixed replQueryStrings directiveArg _ Type = [CtxIdentifier] directiveArg _ Kind = [CtxType] +directiveArg _ Complete = [] completeImport :: [String] -> String -> [CompletionContext] completeImport ws w' = diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs index 7f2f010e1c..c99648841c 100644 --- a/src/Language/PureScript/Interactive/Directive.hs +++ b/src/Language/PureScript/Interactive/Directive.hs @@ -23,15 +23,16 @@ directives = map fst directiveStrings -- directiveStrings :: [(Directive, [String])] directiveStrings = - [ (Help , ["?", "help"]) - , (Quit , ["quit"]) - , (Reload , ["reload"]) - , (Clear , ["clear"]) - , (Browse , ["browse"]) - , (Type , ["type"]) - , (Kind , ["kind"]) - , (Show , ["show"]) - , (Paste , ["paste"]) + [ (Help , ["?", "help"]) + , (Quit , ["quit"]) + , (Reload , ["reload"]) + , (Clear , ["clear"]) + , (Browse , ["browse"]) + , (Type , ["type"]) + , (Kind , ["kind"]) + , (Show , ["show"]) + , (Paste , ["paste"]) + , (Complete , ["complete"]) ] -- | @@ -93,14 +94,16 @@ hasArgument _ = True -- help :: [(Directive, String, String)] help = - [ (Help, "", "Show this help menu") - , (Quit, "", "Quit PSCi") - , (Reload, "", "Reload all imported modules while discarding bindings") - , (Clear, "", "Discard all imported modules and declared bindings") - , (Browse, "", "See all functions in ") - , (Type, "", "Show the type of ") - , (Kind, "", "Show the kind of ") - , (Show, "import", "Show all imported modules") - , (Show, "loaded", "Show all loaded modules") - , (Paste, "paste", "Enter multiple lines, terminated by ^D") + [ (Help, "", "Show this help menu") + , (Quit, "", "Quit PSCi") + , (Reload, "", "Reload all imported modules while discarding bindings") + , (Clear, "", "Discard all imported modules and declared bindings") + , (Browse, "", "See all functions in ") + , (Type, "", "Show the type of ") + , (Kind, "", "Show the kind of ") + , (Show, "import", "Show all imported modules") + , (Show, "loaded", "Show all loaded modules") + , (Paste, "paste", "Enter multiple lines, terminated by ^D") + , (Complete, "", "Show completions for as if pressing tab") ] + diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index 6f0fc18b00..8c0ed26976 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -58,19 +58,19 @@ parseDirective cmd = ds -> Left ("Ambiguous directive. Possible matches: " ++ intercalate ", " (map snd ds) ++ ". Type :? for help.") where - (dstr, arg) = break isSpace cmd + (dstr, arg) = trim <$> break isSpace cmd commandFor d = case d of - Help -> return ShowHelp - Quit -> return QuitPSCi - Reload -> return ReloadState - Clear -> return ClearState - Paste -> return PasteLines - Browse -> BrowseModule <$> parseRest P.moduleName arg - Show -> ShowInfo <$> parseReplQuery' (trim arg) - Type -> TypeOf <$> parseRest P.parseValue arg - Kind -> KindOf <$> parseRest P.parseType arg - + Help -> return ShowHelp + Quit -> return QuitPSCi + Reload -> return ReloadState + Clear -> return ClearState + Paste -> return PasteLines + Browse -> BrowseModule <$> parseRest P.moduleName arg + Show -> ShowInfo <$> parseReplQuery' arg + Type -> TypeOf <$> parseRest P.parseValue arg + Kind -> KindOf <$> parseRest P.parseType arg + Complete -> return (CompleteStr arg) -- | -- Parses expressions entered at the PSCI repl. -- diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index 3ab26a61cb..003b90b100 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -96,6 +96,8 @@ data Command | ShowInfo ReplQuery -- | Paste multiple lines | PasteLines + -- | Return auto-completion output as if pressing + | CompleteStr String deriving Show data ReplQuery @@ -129,4 +131,5 @@ data Directive | Kind | Show | Paste + | Complete deriving (Eq, Show) diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs index f1e36b2536..57e7742a82 100644 --- a/tests/TestPsci/CommandTest.hs +++ b/tests/TestPsci/CommandTest.hs @@ -32,3 +32,9 @@ commandTests = context "commandTests" $ do run ":reload" ms' <- psciImportedModules <$> get length ms' `equalsTo` 3 + + specPSCi ":complete" $ do + ":complete ma" `prints` [] + ":complete Data.Functor.ma" `prints` (unlines (map ("Data.Functor." ++ ) ["map", "mapFlipped"])) + run "import Data.Functor" + ":complete ma" `prints` (unlines ["map", "mapFlipped"]) diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index fef5f7b11c..104056155e 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -12,7 +12,6 @@ import Data.List (sort) import qualified Data.Text as T import qualified Language.PureScript as P import Language.PureScript.Interactive -import System.Console.Haskeline import TestPsci.TestEnv (initTestPSCiEnv) import TestUtils (getSupportModuleNames) @@ -29,7 +28,7 @@ completionTestData supportModuleNames = -- basic directives [ (":h", [":help"]) , (":r", [":reload"]) - , (":c", [":clear"]) + , (":c", [":clear", ":complete"]) , (":q", [":quit"]) , (":b", [":browse"]) @@ -88,10 +87,9 @@ completionTestData supportModuleNames = assertCompletedOk :: (String, [String]) -> Spec assertCompletedOk (line, expecteds) = specify line $ do - (unusedR, completions) <- runCM (completion' (reverse line, "")) - let unused = reverse unusedR - let actuals = map ((unused ++) . replacement) completions - sort expecteds `shouldBe` sort actuals + results <- runCM (completion' (reverse line, "")) + let actuals = formatCompletions results + sort actuals `shouldBe` sort expecteds runCM :: CompletionM a -> IO a runCM act = do diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 8f71d9ad01..fdf0ca9a91 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -56,26 +56,41 @@ jsEval = liftIO $ do Just (ExitFailure _, _, err) -> putStrLn err >> exitFailure Nothing -> putStrLn "Couldn't find node.js" >> exitFailure --- | Run a PSCi command and evaluate the output with 'eval'. -runAndEval :: String -> TestPSCi () -> TestPSCi () -runAndEval comm eval = +-- | Run a PSCi command and evaluate its outputs: +-- * jsOutputEval is used to evaluate compiled JS output by PSCi +-- * printedOutputEval is used to evaluate text printed directly by PSCi itself +runAndEval :: String -> TestPSCi () -> (String -> TestPSCi ()) -> TestPSCi () +runAndEval comm jsOutputEval textOutputEval = case parseCommand comm of Left errStr -> liftIO $ putStrLn errStr >> exitFailure Right command -> - -- the JS result can be ignored, as it's already written in a source file - -- for the detail, please refer to Interactive.hs - handleCommand (\_ -> eval) (return ()) (\_ -> return ()) command + -- The JS result is ignored, as it's already written in a JS source file. + -- For the detail, please refer to Interactive.hs + handleCommand (\_ -> jsOutputEval) (return ()) textOutputEval command --- | Run a PSCi command and ignore the output +-- | Run a PSCi command, evaluate compiled JS, and ignore evaluation output and printed output run :: String -> TestPSCi () -run comm = runAndEval comm $ jsEval *> return () +run comm = runAndEval comm evalJsAndIgnore ignorePrinted + where + evalJsAndIgnore = jsEval *> return () + ignorePrinted _ = return () -- | A lifted evaluation of Hspec 'shouldBe' for the TestPSCi equalsTo :: (Eq a, Show a) => a -> a -> TestPSCi () equalsTo x y = liftIO $ x `shouldBe` y --- | An assertion to check if a command evaluates to a string +-- | An assertion to check command evaluated javascript output against a given string evaluatesTo :: String -> String -> TestPSCi () -evaluatesTo command expected = runAndEval command $ do - actual <- jsEval - actual `equalsTo` (expected ++ "\n") +evaluatesTo command expected = runAndEval command evalJsAndCompare ignorePrinted + where + evalJsAndCompare = do + actual <- jsEval + actual `equalsTo` (expected ++ "\n") + ignorePrinted _ = return () + +-- | An assertion to check command PSCi printed output against a given string +prints :: String -> String -> TestPSCi () +prints command expected = runAndEval command evalJsAndIgnore evalPrinted + where + evalJsAndIgnore = jsEval *> return () + evalPrinted s = s `equalsTo` expected From 2d974bae9fb1a17d0b9b7c5ebd5b5ed875dd6416 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 9 Sep 2017 13:05:11 -0700 Subject: [PATCH 0854/1580] Don't recommend IRC any more (#3064) It's pretty much dead --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 504c5ca019..3ac5df9543 100644 --- a/README.md +++ b/README.md @@ -19,7 +19,7 @@ A small strongly typed programming language with expressive types that compiles ## Help! -- [#purescript IRC @ FreeNode](http://webchat.freenode.net/?channels=purescript) +- [#purescript @ FP Slack](https://functionalprogramming.slack.com/) - [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript) - [Google Group](https://groups.google.com/forum/#!forum/purescript) - [Gitter Channel](https://gitter.im/purescript/purescript?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) From 4289974a872501679889dd26f0344a84a5ddad9d Mon Sep 17 00:00:00 2001 From: Csongor Kiss Date: Sat, 9 Sep 2017 23:36:41 +0100 Subject: [PATCH 0855/1580] Solve ConsSymbol (#3054) * Solve ConsSymbol This adds and solves a new 'magic' constraint, `Type.Data.Symbol.ConsSymbol`, with the following functional dependencies: class ConsSymbol (head :: Symbol) (tail :: Symbol) (sym :: Symbol) | sym -> head tail, head tail -> sym * The `head tail -> sym` direction works like `AppendSymbol`, but only resolves when `head` is a singleton symbol. * The `sym -> head tail` direction deconstructs the symbol into its first character and the remaining string. * Style fixes --- src/Language/PureScript/Constants.hs | 3 +++ .../PureScript/TypeChecker/Entailment.hs | 22 ++++++++++++++++++- 2 files changed, 24 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 717aab7098..ce6ed2e2c2 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -345,6 +345,9 @@ pattern CompareSymbol = Qualified (Just TypeDataSymbol) (ProperName "CompareSymb pattern AppendSymbol :: Qualified (ProperName 'ClassName) pattern AppendSymbol = Qualified (Just TypeDataSymbol) (ProperName "AppendSymbol") +pattern ConsSymbol :: Qualified (ProperName 'ClassName) +pattern ConsSymbol = Qualified (Just TypeDataSymbol) (ProperName "ConsSymbol") + -- Type.Data.Ordering typeDataOrdering :: ModuleName diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 2ab173496f..698f386da6 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -28,6 +28,7 @@ import Data.Maybe (fromMaybe, maybeToList, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.AST import Language.PureScript.Crash @@ -39,7 +40,7 @@ import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types import Language.PureScript.Label (Label(..)) -import Language.PureScript.PSString (PSString, mkString) +import Language.PureScript.PSString (PSString, mkString, decodeString) import qualified Language.PureScript.Constants as C -- | Describes what sort of dictionary to generate for type class instances @@ -51,6 +52,7 @@ data Evidence | WarnInstance Type -- ^ Warn type class with a user-defined warning message | IsSymbolInstance PSString -- ^ The IsSymbol type class for a given Symbol literal | CompareSymbolInstance + | ConsSymbolInstance | AppendSymbolInstance | UnionInstance | ConsInstance @@ -165,6 +167,10 @@ entails SolverOptions{..} constraint context hints = forClassName _ C.AppendSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = let args = [arg0, arg1, TypeLevelString (lhs <> rhs)] in [TypeClassDictionaryInScope AppendSymbolInstance [] C.AppendSymbol args Nothing] + forClassName _ C.ConsSymbol [arg0, arg1, arg2] + | Just (arg0', arg1', arg2') <- consSymbol arg0 arg1 arg2 = + let args = [arg0', arg1', arg2'] + in [TypeClassDictionaryInScope ConsSymbolInstance [] C.ConsSymbol args Nothing] forClassName _ C.Union [l, r, u] | Just (lOut, rOut, uOut, cst) <- unionRows l r u = [ TypeClassDictionaryInScope UnionInstance [] C.Union [lOut, rOut, uOut] cst ] @@ -345,6 +351,8 @@ entails SolverOptions{..} constraint context hints = return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) mkDictionary CompareSymbolInstance _ = return $ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral [])) + mkDictionary ConsSymbolInstance _ = + return $ TypeClassDictionaryConstructorApp C.ConsSymbol (Literal (ObjectLiteral [])) mkDictionary AppendSymbolInstance _ = return $ TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral [])) @@ -353,6 +361,18 @@ entails SolverOptions{..} constraint context hints = subclassDictionaryValue dict className index = App (Accessor (mkString (superclassName className index)) dict) valUndefined + consSymbol :: Type -> Type -> Type -> Maybe (Type, Type, Type) + consSymbol _ _ arg@(TypeLevelString s) = do + (h, t) <- T.uncons =<< decodeString s + pure (mkTLString (T.singleton h), mkTLString t, arg) + where mkTLString = TypeLevelString . mkString + consSymbol arg1@(TypeLevelString h) arg2@(TypeLevelString t) _ = do + h' <- decodeString h + t' <- decodeString t + guard (T.length h' == 1) + pure (arg1, arg2, TypeLevelString (mkString $ h' <> t')) + consSymbol _ _ _ = Nothing + -- | Left biased union of two row types unionRows :: Type -> Type -> Type -> Maybe (Type, Type, Type, Maybe [Constraint]) unionRows l r _ = From 74bc4a923dfbd84e1f4dfa448981b57ab3d4ab9c Mon Sep 17 00:00:00 2001 From: rightfold Date: Sun, 10 Sep 2017 00:55:26 +0200 Subject: [PATCH 0856/1580] Add proxies (#2846) * Add proxies * Add failing proxy test cases * Make proxy types of higher precedence * Proxy is no longer reserved * Move "proxy" to reservedTypeNames * s/proxy/@/g --- examples/failing/ProxyKind.purs | 12 +++++++++++ examples/failing/ProxyUnify.purs | 12 +++++++++++ examples/passing/DuplicateProperties.purs | 20 +++++++----------- examples/passing/FunctionalDependencies.purs | 8 +++---- examples/passing/Proxy.purs | 21 +++++++++++++++++++ src/Language/PureScript/AST/Declarations.hs | 4 ++++ src/Language/PureScript/CoreFn/Desugar.hs | 2 ++ .../PureScript/Parser/Declarations.hs | 4 ++++ src/Language/PureScript/Parser/Types.hs | 4 ++++ src/Language/PureScript/Pretty/Types.hs | 1 + src/Language/PureScript/Pretty/Values.hs | 2 ++ src/Language/PureScript/TypeChecker/Kinds.hs | 3 +++ .../PureScript/TypeChecker/Skolems.hs | 2 ++ src/Language/PureScript/TypeChecker/Types.hs | 2 ++ src/Language/PureScript/TypeChecker/Unify.hs | 5 ++++- src/Language/PureScript/Types.hs | 10 +++++++++ 16 files changed, 94 insertions(+), 18 deletions(-) create mode 100644 examples/failing/ProxyKind.purs create mode 100644 examples/failing/ProxyUnify.purs create mode 100644 examples/passing/Proxy.purs diff --git a/examples/failing/ProxyKind.purs b/examples/failing/ProxyKind.purs new file mode 100644 index 0000000000..df39c8c6bf --- /dev/null +++ b/examples/failing/ProxyKind.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith TypesDoNotUnify + +module Main where + +import Prelude +import Control.Monad.Eff (Eff) + +a :: @"a" +a = @Int + +main :: Eff _ _ +main = pure unit diff --git a/examples/failing/ProxyUnify.purs b/examples/failing/ProxyUnify.purs new file mode 100644 index 0000000000..53a9cfd07d --- /dev/null +++ b/examples/failing/ProxyUnify.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith TypesDoNotUnify + +module Main where + +import Prelude +import Control.Monad.Eff (Eff) + +a :: @"a" +a = @"b" + +main :: Eff _ _ +main = pure unit diff --git a/examples/passing/DuplicateProperties.purs b/examples/passing/DuplicateProperties.purs index d91f6bd317..389e0a7cfe 100644 --- a/examples/passing/DuplicateProperties.purs +++ b/examples/passing/DuplicateProperties.purs @@ -3,25 +3,21 @@ module Main where import Prelude import Control.Monad.Eff.Console (log) -data RProxy (r :: # Type) = RProxy +subtractX :: forall r a. @(x :: a | r) -> @r +subtractX _ = @r -data Proxy (a :: Type) = Proxy +extractX :: forall r a. @(x :: a | r) -> @a +extractX _ = @a -subtractX :: forall r a. RProxy (x :: a | r) -> RProxy r -subtractX RProxy = RProxy - -extractX :: forall r a. RProxy (x :: a | r) -> Proxy a -extractX RProxy = Proxy - -hasX :: forall r a b. RProxy (x :: a, y :: b | r) -hasX = RProxy +hasX :: forall r a b. @(x :: a, y :: b | r) +hasX = @(x :: a, y :: b | r) test1 = subtractX (subtractX hasX) test2 :: forall r a b - . RProxy (x :: a, x :: b, x :: Int | r) - -> Proxy Int + . @(x :: a, x :: b, x :: Int | r) + -> @Int test2 x = extractX (subtractX (subtractX x)) main = log "Done" diff --git a/examples/passing/FunctionalDependencies.purs b/examples/passing/FunctionalDependencies.purs index cb8026e591..810861ebb4 100644 --- a/examples/passing/FunctionalDependencies.purs +++ b/examples/passing/FunctionalDependencies.purs @@ -11,11 +11,9 @@ instance appendNil :: Append Nil b b instance appendCons :: Append xs b c => Append (Cons x xs) b (Cons x c) -data Proxy a = Proxy +appendProxy :: forall a b c. Append a b c => @a -> @b -> @c +appendProxy _ _ = @c -appendProxy :: forall a b c. Append a b c => Proxy a -> Proxy b -> Proxy c -appendProxy Proxy Proxy = Proxy - -test = appendProxy (Proxy :: Proxy (Cons Int Nil)) (Proxy :: Proxy (Cons String Nil)) +test = appendProxy @(Cons Int Nil) @(Cons String Nil) main = log "Done" diff --git a/examples/passing/Proxy.purs b/examples/passing/Proxy.purs new file mode 100644 index 0000000000..1a3984fe50 --- /dev/null +++ b/examples/passing/Proxy.purs @@ -0,0 +1,21 @@ +module Main (main) where + +import Prelude +import Control.Monad.Eff.Console (CONSOLE, log) + +f :: @Int -> Unit +f _ = unit + +g :: forall eff. @(console :: CONSOLE | eff) -> Unit +g _ = unit + +h :: @"foo" -> Unit +h _ = unit + +i :: @"foo" +i = @"foo" + +j :: Unit +j = h i + +main = log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 67c2baa13b..aa64efa52a 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -760,6 +760,10 @@ data Expr -- | Do [DoNotationElement] -- | + -- A proxy value + -- + | Proxy Type + -- | -- An application of a typeclass dictionary constructor. The value should be -- an ObjectLiteral. -- diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 03873fb46e..560d4967d7 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -101,6 +101,8 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = exprToCoreFn ss com (Just ty) v exprToCoreFn ss com ty (A.Let ds v) = Let (ss, com, ty, Nothing) (concatMap declToCoreFn ds) (exprToCoreFn ss [] Nothing v) + exprToCoreFn ss com ty (A.Proxy _) = + Literal (ss, com, ty, Nothing) (ObjectLiteral []) exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal (A.ObjectLiteral _)) _)) = exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name lit) exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal (A.ObjectLiteral vs))) = diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 242312b190..8119114489 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -408,6 +408,9 @@ parseLet = do result <- parseValue return $ Let ds result +parseProxy :: TokenParser Expr +parseProxy = Proxy <$> (at *> parseTypeAtom) + parseValueAtom :: TokenParser Expr parseValueAtom = withSourceSpan PositionedValue $ P.choice [ parseAnonymousArgument @@ -424,6 +427,7 @@ parseValueAtom = withSourceSpan PositionedValue $ P.choice , parseIfThenElse , parseDo , parseLet + , parseProxy , P.try $ Parens <$> parens parseValue , Op <$> parseQualified (parens parseOperator) , parseHole diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 3a9803c7bd..0f37ab8bd8 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -49,6 +49,9 @@ parseTypeVariable = do parseTypeConstructor :: TokenParser Type parseTypeConstructor = TypeConstructor <$> parseQualified typeName +parseProxyType :: TokenParser Type +parseProxyType = ProxyType <$> (at *> parseTypeAtom) + parseForAll :: TokenParser Type parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (indented *> identifier) <* indented <* dot) <*> parseType @@ -75,6 +78,7 @@ parseTypeAtom = indented *> P.choice , parseForAll , parseTypeVariable , parseTypeConstructor + , parseProxyType -- This try is needed due to some unfortunate ambiguities between rows and kinded types , P.try (parens parseRow) , ParensInType <$> parens parsePolyType diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index bee62db14c..d24c9a3ae5 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -135,6 +135,7 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} = | otherwise = Just $ text $ T.unpack name ++ show s match REmpty = Just $ text "()" match row@RCons{} = Just $ prettyPrintRowWith tro '(' ')' row + match (ProxyType t) = Just $ text "@" <> typeAtomAsBox t match (BinaryNoParensType op l r) = Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r match (TypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 659e98cc8d..642e699797 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -78,6 +78,8 @@ prettyPrintValue d (Let ds val) = (text "in " <> prettyPrintValue (d - 1) val) prettyPrintValue d (Do els) = text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) +prettyPrintValue _ (Proxy ty) = + text "@" <> typeAtomAsBox ty prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map typeAtomAsBox tys prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name)) prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 58ec2f0fb6..123dd35675 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -256,6 +256,9 @@ infer' other = (, []) <$> go other k2 <- go row unifyKinds k2 (Row k1) return $ Row k1 + go (ProxyType ty) = do + _ <- go ty + return kindType go (ConstrainedType (Constraint className tys _) ty) = do k1 <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys unifyKinds k1 kindType diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 0b6ef54537..33798dbf78 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -64,6 +64,8 @@ skolemizeTypesInValue ident sko scope ss = | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts)) onExpr sco (TypedValue check val ty) | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty)) + onExpr sco (Proxy ty) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, Proxy (skolemize ident sko scope ss ty)) onExpr sco other = return (sco, other) onBinder :: [Text] -> Binder -> Identity ([Text], Binder) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index ba438a34c2..05c5bef085 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -394,6 +394,8 @@ infer' (IfThenElse cond th el) = do infer' (Let ds val) = do (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer return $ TypedValue True (Let ds' val') valTy +infer' (Proxy ty) = + return $ TypedValue True (Proxy ty) (ProxyType ty) infer' (DeferredDictionary className tys) = do dicts <- getTypeClassDictionaries hints <- getHints diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 04186dbc93..2c7f80b444 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -85,7 +85,8 @@ unknownsInType t = everythingOnTypes (.) go t [] unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m () unifyTypes t1 t2 = do sub <- gets checkSubstitution - withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes' (substituteType sub t1) (substituteType sub t2) + withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ + unifyTypes' (substituteType sub t1) (substituteType sub t2) where unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return () unifyTypes' (TUnknown u) t = solveType u t @@ -118,6 +119,8 @@ unifyTypes t1 t2 = do unifyTypes' r1 r2@RCons{} = unifyRows r1 r2 unifyTypes' r1@REmpty r2 = unifyRows r1 r2 unifyTypes' r1 r2@REmpty = unifyRows r1 r2 + unifyTypes' (ProxyType ty1) (ProxyType ty2) = + ty1 `unifyTypes` ty2 unifyTypes' ty1@ConstrainedType{} ty2 = throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2 unifyTypes' t3 t4@ConstrainedType{} = unifyTypes' t4 t3 diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index d600bf47f7..b5dcdcef95 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -66,6 +66,8 @@ data Type | REmpty -- | A non-empty row | RCons Label Type Type + -- | A proxy type + | ProxyType Type -- | A type with a kind annotation | KindedType Type Kind -- | A placeholder used in pretty printing @@ -168,6 +170,7 @@ replaceAllTypeVars = go [] where usedVars = concatMap (usedTypeVariables . snd) m go bs m (ConstrainedType c t) = ConstrainedType (mapConstraintArgs (map (go bs m)) c) (go bs m t) go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r) + go bs m (ProxyType t) = ProxyType (go bs m t) go bs m (KindedType t k) = KindedType (go bs m t) k go bs m (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go bs m t1) (go bs m t2) (go bs m t3) go bs m (ParensInType t) = ParensInType (go bs m t) @@ -193,6 +196,7 @@ freeTypeVariables = ordNub . go [] where go bound (ForAll v t _) = go (v : bound) t go bound (ConstrainedType c t) = concatMap (go bound) (constraintArgs c) ++ go bound t go bound (RCons _ t r) = go bound t ++ go bound r + go bound (ProxyType t) = go bound t go bound (KindedType t _) = go bound t go bound (BinaryNoParensType t1 t2 t3) = go bound t1 ++ go bound t2 ++ go bound t3 go bound (ParensInType t) = go bound t @@ -229,6 +233,7 @@ everywhereOnTypes f = go where go (ForAll arg ty sco) = f (ForAll arg (go ty) sco) go (ConstrainedType c ty) = f (ConstrainedType (mapConstraintArgs (map go) c) (go ty)) go (RCons name ty rest) = f (RCons name (go ty) (go rest)) + go (ProxyType ty) = f (ProxyType (go ty)) go (KindedType ty k) = f (KindedType (go ty) k) go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2)) go (PrettyPrintObject t) = f (PrettyPrintObject (go t)) @@ -243,6 +248,7 @@ everywhereOnTypesTopDown f = go . f where go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco go (ConstrainedType c ty) = ConstrainedType (mapConstraintArgs (map (go . f)) c) (go (f ty)) go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest)) + go (ProxyType ty) = ProxyType (go (f ty)) go (KindedType ty k) = KindedType (go (f ty)) k go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2)) go (PrettyPrintObject t) = PrettyPrintObject (go (f t)) @@ -257,6 +263,7 @@ everywhereOnTypesM f = go where go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f go (ConstrainedType c ty) = (ConstrainedType <$> overConstraintArgs (mapM go) c <*> go ty) >>= f go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f + go (ProxyType ty) = (ProxyType <$> go ty) >>= f go (KindedType ty k) = (KindedType <$> go ty <*> pure k) >>= f go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f @@ -271,6 +278,7 @@ everywhereOnTypesTopDownM f = go <=< f where go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco go (ConstrainedType c ty) = ConstrainedType <$> overConstraintArgs (mapM (go <=< f)) c <*> (f ty >>= go) go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go) + go (ProxyType ty) = ProxyType <$> (f ty >>= go) go (KindedType ty k) = KindedType <$> (f ty >>= go) <*> pure k go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go) go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go) @@ -285,6 +293,7 @@ everythingOnTypes (<+>) f = go where go t@(ForAll _ ty _) = f t <+> go ty go t@(ConstrainedType c ty) = foldl (<+>) (f t) (map go (constraintArgs c)) <+> go ty go t@(RCons _ ty rest) = f t <+> go ty <+> go rest + go t@(ProxyType ty) = f t <+> go ty go t@(KindedType ty _) = f t <+> go ty go t@(PrettyPrintFunction t1 t2) = f t <+> go t1 <+> go t2 go t@(PrettyPrintObject t1) = f t <+> go t1 @@ -300,6 +309,7 @@ everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 where go s (ForAll _ ty _) = go' s ty go s (ConstrainedType c ty) = foldl (<+>) r0 (map (go' s) (constraintArgs c)) <+> go' s ty go s (RCons _ ty rest) = go' s ty <+> go' s rest + go s (ProxyType ty) = go' s ty go s (KindedType ty _) = go' s ty go s (PrettyPrintFunction t1 t2) = go' s t1 <+> go' s t2 go s (PrettyPrintObject t1) = go' s t1 From 6f2527b1545853dcb6974999084433c7389136cd Mon Sep 17 00:00:00 2001 From: rightfold Date: Sun, 10 Sep 2017 02:10:50 +0200 Subject: [PATCH 0857/1580] Add applicative do notation (#2889) * Add applicative do notation * Test the order of arguments to the result of an applicative do-block * Implement let statements in applicative do-blocks * Correctly handle PositionedDoNotationElement in applicative do-notation * Prefer map over pure when desugaring applicative do-notation * Delete AdoLetNotSupported variant --- examples/passing/Ado.purs | 77 +++++++++++++++++++ src/Language/PureScript/AST/Declarations.hs | 5 +- src/Language/PureScript/AST/Traversals.hs | 11 ++- .../PureScript/Parser/Declarations.hs | 9 +++ src/Language/PureScript/Parser/Lexer.hs | 1 + src/Language/PureScript/Pretty/Values.hs | 3 + src/Language/PureScript/Sugar.hs | 4 + src/Language/PureScript/Sugar/AdoNotation.hs | 67 ++++++++++++++++ tests/TestPsci/CompletionTest.hs | 8 +- tests/support/bower.json | 1 + 10 files changed, 180 insertions(+), 6 deletions(-) create mode 100644 examples/passing/Ado.purs create mode 100644 src/Language/PureScript/Sugar/AdoNotation.hs diff --git a/examples/passing/Ado.purs b/examples/passing/Ado.purs new file mode 100644 index 0000000000..3e7ed949fb --- /dev/null +++ b/examples/passing/Ado.purs @@ -0,0 +1,77 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Control.Monad.Eff.Ref (newRef, writeRef, readRef) + +data Maybe a = Nothing | Just a + +instance functorMaybe :: Functor Maybe where + map f Nothing = Nothing + map f (Just x) = Just (f x) + +instance applyMaybe :: Apply Maybe where + apply (Just f) (Just x) = Just (f x) + apply _ _ = Nothing + +instance applicativeMaybe :: Applicative Maybe where + pure = Just + +test1 = \_ -> ado + in "abc" + +test2 = \_ -> ado + x <- Just 1.0 + y <- Just 2.0 + in x + y + +test3 = \_ -> ado + _ <- Just 1.0 + _ <- Nothing :: Maybe Number + in 2.0 + +test4 mx my = ado + x <- mx + y <- my + in x + y + 1.0 + +test5 mx my mz = ado + x <- mx + y <- my + let sum = x + y + z <- mz + in z + sum + 1.0 + +test6 mx = \_ -> ado + let + f :: forall a. Maybe a -> a + f (Just x) = x + in f mx + +test8 = \_ -> ado + in (ado + in 1.0) + +test9 = \_ -> (+) <$> Just 1.0 <*> Just 2.0 + +test10 _ = ado + let + f x = g x * 3.0 + g x = f x / 2.0 + in f 10.0 + +test11 = \_ -> ado + x <- pure 1 + y <- pure "A" + z <- pure [] + in show (x :: Int) <> y <> show (z :: Array Int) + +main = do + r <- newRef "X" + log =<< ado + _ <- writeRef r "D" + a <- readRef r + b <- pure "o" + let c = "n" + d <- pure "e" + in a <> b <> c <> d diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index aa64efa52a..77a01defd2 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -451,7 +451,7 @@ getValueDeclaration (ValueDeclaration d) = Just d getValueDeclaration _ = Nothing pattern ValueDecl :: SourceAnn -> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration -pattern ValueDecl sann ident name binders expr +pattern ValueDecl sann ident name binders expr = ValueDeclaration (ValueDeclarationData sann ident name binders expr) -- | @@ -763,6 +763,9 @@ data Expr -- A proxy value -- | Proxy Type + -- An ado-notation block + -- + | Ado [DoNotationElement] Expr -- | -- An application of a typeclass dictionary constructor. The value should be -- an ObjectLiteral. diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 4da91b128e..29b1c47561 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -77,6 +77,7 @@ everywhereOnValues f g h = (f', g', h') g' (TypedValue check v ty) = g (TypedValue check (g' v) ty) g' (Let ds v) = g (Let (fmap f' ds) (g' v)) g' (Do es) = g (Do (fmap handleDoNotationElement es)) + g' (Ado es v) = g (Ado (fmap handleDoNotationElement es) (g' v)) g' (PositionedValue pos com v) = g (PositionedValue pos com (g' v)) g' other = g other @@ -150,6 +151,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty g' (Let ds v) = Let <$> traverse (f' <=< f) ds <*> (g v >>= g') g' (Do es) = Do <$> traverse handleDoNotationElement es + g' (Ado es v) = Ado <$> traverse handleDoNotationElement es <*> (g v >>= g') g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g') g' other = g other @@ -194,7 +196,7 @@ everywhereOnValuesM f g h = (f', g', h') f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f - f' (ValueDecl sa name nameKind bs val) = + f' (ValueDecl sa name nameKind bs val) = ValueDecl sa name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val >>= f f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f f' (BoundValueDeclaration sa b expr) = (BoundValueDeclaration sa <$> h' b <*> g' expr) >>= f @@ -218,6 +220,7 @@ everywhereOnValuesM f g h = (f', g', h') g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g g' (Let ds v) = (Let <$> traverse f' ds <*> g' v) >>= g g' (Do es) = (Do <$> traverse handleDoNotationElement es) >>= g + g' (Ado es v) = (Ado <$> traverse handleDoNotationElement es <*> g' v) >>= g g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g g' other = g other @@ -289,6 +292,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') g' v@(TypedValue _ v1 _) = g v <> g' v1 g' v@(Let ds v1) = foldl (<>) (g v) (fmap f' ds) <> g' v1 g' v@(Do es) = foldl (<>) (g v) (fmap j' es) + g' v@(Ado es v1) = foldl (<>) (g v) (fmap j' es) <> g' v1 g' v@(PositionedValue _ _ v1) = g v <> g' v1 g' v = g v @@ -369,6 +373,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' g' s (TypedValue _ v1 _) = g'' s v1 g' s (Let ds v1) = foldl (<>) r0 (fmap (f'' s) ds) <> g'' s v1 g' s (Do es) = foldl (<>) r0 (fmap (j'' s) es) + g' s (Ado es v1) = foldl (<>) r0 (fmap (j'' s) es) <> g'' s v1 g' s (PositionedValue _ _ v1) = g'' s v1 g' _ _ = r0 @@ -453,6 +458,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty g' s (Let ds v) = Let <$> traverse (f'' s) ds <*> g'' s v g' s (Do es) = Do <$> traverse (j'' s) es + g' s (Ado es v) = Ado <$> traverse (j'' s) es <*> g'' s v g' s (PositionedValue pos com v) = PositionedValue pos com <$> g'' s v g' _ other = return other @@ -546,6 +552,9 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds)) in foldMap (f'' s') ds <> g'' s' v1 g' s (Do es) = fold . snd . mapAccumL j'' s $ es + g' s (Ado es v1) = + let s' = S.union s (foldMap (fst . j'' s) es) + in g'' s' v1 g' s (PositionedValue _ _ v1) = g'' s v1 g' _ _ = mempty diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 8119114489..9a0ece16fa 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -426,6 +426,7 @@ parseValueAtom = withSourceSpan PositionedValue $ P.choice , parseCase , parseIfThenElse , parseDo + , parseAdo , parseLet , parseProxy , P.try $ Parens <$> parens parseValue @@ -464,6 +465,14 @@ parseDo = do indented Do <$> mark (P.many1 (same *> mark parseDoNotationElement)) +parseAdo :: TokenParser Expr +parseAdo = do + reserved "ado" + indented + elements <- mark (P.many (same *> mark parseDoNotationElement)) + yield <- mark (reserved "in" *> parseValue) + pure $ Ado elements yield + parseDoNotationLet :: TokenParser DoNotationElement parseDoNotationLet = DoNotationLet <$> (reserved "let" *> indented *> mark (P.many1 (same *> parseLocalDeclaration))) diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 9b62cc2c0e..71812e8977 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -570,6 +570,7 @@ reservedPsNames = [ "data" , "then" , "else" , "do" + , "ado" , "let" , "true" , "false" diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 642e699797..04d1a43c0a 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -80,6 +80,9 @@ prettyPrintValue d (Do els) = text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) prettyPrintValue _ (Proxy ty) = text "@" <> typeAtomAsBox ty +prettyPrintValue d (Ado els yield) = + text "ado " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) // + (text "in " <> prettyPrintValue (d - 1) yield) prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map typeAtomAsBox tys prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name)) prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 2c7bf0d1b0..c819797d2e 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -18,6 +18,7 @@ import Language.PureScript.Externs import Language.PureScript.Sugar.BindingGroups as S import Language.PureScript.Sugar.CaseDeclarations as S import Language.PureScript.Sugar.DoNotation as S +import Language.PureScript.Sugar.AdoNotation as S import Language.PureScript.Sugar.LetPattern as S import Language.PureScript.Sugar.Names as S import Language.PureScript.Sugar.ObjectWildcards as S @@ -37,6 +38,8 @@ import Language.PureScript.Sugar.TypeDeclarations as S -- -- * Desugar do-notation -- +-- * Desugar ado-notation +-- -- * Desugar top-level case declarations into explicit case expressions -- -- * Desugar type declarations into value declarations with explicit type annotations @@ -58,6 +61,7 @@ desugar externs = map desugarSignedLiterals >>> traverse desugarObjectConstructors >=> traverse desugarDoModule + >=> traverse desugarAdoModule >=> map desugarLetPatternModule >>> traverse desugarCasesModule >=> traverse desugarTypeDeclarationsModule diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs new file mode 100644 index 0000000000..68b18fc3d9 --- /dev/null +++ b/src/Language/PureScript/Sugar/AdoNotation.hs @@ -0,0 +1,67 @@ +-- | This module implements the desugaring pass which replaces ado-notation statements with +-- appropriate calls to pure and apply. + +{-# LANGUAGE PatternGuards #-} + +module Language.PureScript.Sugar.AdoNotation (desugarAdoModule) where + +import Prelude.Compat hiding (abs) + +import Control.Monad (foldM) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class +import Data.List (foldl') +import Language.PureScript.AST +import Language.PureScript.Errors +import Language.PureScript.Names +import qualified Language.PureScript.Constants as C + +-- | Replace all @AdoNotationBind@ and @AdoNotationValue@ constructors with +-- applications of the pure and apply functions in scope, and all @AdoNotationLet@ +-- constructors with let expressions. +desugarAdoModule :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Module -> m Module +desugarAdoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarAdo <*> pure exts + +-- | Desugar a single ado statement +desugarAdo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration +desugarAdo d = + let (f, _, _) = everywhereOnValuesM return replace return + in f d + where + pure' :: Expr + pure' = Var (Qualified Nothing (Ident C.pure')) + + map' :: Expr + map' = Var (Qualified Nothing (Ident C.map)) + + apply :: Expr + apply = Var (Qualified Nothing (Ident C.apply)) + + replace :: Expr -> m Expr + replace (Ado els yield) = do + (func, args) <- foldM go (yield, []) (reverse els) + return $ case args of + [] -> App pure' func + hd : tl -> foldl' (\a b -> App (App apply a) b) (App (App map' func) hd) tl + replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v) + replace other = return other + + go :: (Expr, [Expr]) -> DoNotationElement -> m (Expr, [Expr]) + go (yield, args) (DoNotationValue val) = + return (Abs NullBinder yield, val : args) + go (yield, args) (DoNotationBind (VarBinder ident) val) = + return (Abs (VarBinder ident) yield, val : args) + go (yield, args) (DoNotationBind binder val) = do + ident <- freshIdent' + let abs = Abs (VarBinder ident) + (Case [Var (Qualified Nothing ident)] + [CaseAlternative [binder] [MkUnguarded yield]]) + return (abs, val : args) + go (yield, args) (DoNotationLet ds) = do + return (Let ds yield, args) + go acc (PositionedDoNotationElement pos com el) = + rethrowWithPosition pos $ do + (yield, args) <- go acc el + return $ case args of + [] -> (PositionedValue pos com yield, args) + (a : as) -> (yield, PositionedValue pos com a : as) diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index 104056155e..da1e586f85 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -33,12 +33,12 @@ completionTestData supportModuleNames = , (":b", [":browse"]) -- :browse should complete module names - , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried"]) - , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console", ".Uncurried"]) + , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref", ".Ref.Unsafe"]) + , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref", ".Ref.Unsafe"]) -- import should complete module names - , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried"]) - , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console", ".Uncurried"]) + , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref", ".Ref.Unsafe"]) + , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref", ".Ref.Unsafe"]) -- :quit, :help, :reload, :clear should not complete , (":help ", []) diff --git a/tests/support/bower.json b/tests/support/bower.json index 0973f7a8d8..837f51eac0 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -29,6 +29,7 @@ "purescript-prelude": "3.1.0", "purescript-proxy": "2.1.0", "purescript-psci-support": "3.0.0", + "purescript-refs": "3.0.0", "purescript-st": "3.0.0", "purescript-strings": "3.3.0", "purescript-symbols": "3.0.0", From eb0007d42e8eb48cbab32b5718e0cde550b3ef13 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sat, 9 Sep 2017 17:50:02 -0700 Subject: [PATCH 0858/1580] Remove scripts, fix #2993 (#3011) --- bundle/build.sh | 1 - scripts/psc | 2 -- scripts/psc-bundle | 2 -- scripts/psc-docs | 2 -- scripts/psc-hierarchy | 2 -- scripts/psc-ide-client | 2 -- scripts/psc-ide-server | 2 -- scripts/psc-publish | 2 -- scripts/psci | 2 -- 9 files changed, 17 deletions(-) delete mode 100755 scripts/psc delete mode 100755 scripts/psc-bundle delete mode 100755 scripts/psc-docs delete mode 100755 scripts/psc-hierarchy delete mode 100755 scripts/psc-ide-client delete mode 100755 scripts/psc-ide-server delete mode 100755 scripts/psc-publish delete mode 100755 scripts/psci diff --git a/bundle/build.sh b/bundle/build.sh index 029756b093..5a9ed9712c 100755 --- a/bundle/build.sh +++ b/bundle/build.sh @@ -35,7 +35,6 @@ fi cp "$FULL_BIN" bundle/build/purescript # Copy extra files to the staging directory -cp scripts/* bundle/build/purescript/ cp bundle/README bundle/build/purescript/ cp LICENSE bundle/build/purescript/ cp INSTALL.md bundle/build/purescript/ diff --git a/scripts/psc b/scripts/psc deleted file mode 100755 index 95e4b1b73d..0000000000 --- a/scripts/psc +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -purs compile "$@" diff --git a/scripts/psc-bundle b/scripts/psc-bundle deleted file mode 100755 index fb3814456c..0000000000 --- a/scripts/psc-bundle +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -purs bundle "$@" diff --git a/scripts/psc-docs b/scripts/psc-docs deleted file mode 100755 index bf9acc6cbf..0000000000 --- a/scripts/psc-docs +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -purs docs "$@" diff --git a/scripts/psc-hierarchy b/scripts/psc-hierarchy deleted file mode 100755 index 9b0fe41891..0000000000 --- a/scripts/psc-hierarchy +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -purs hierarchy "$@" diff --git a/scripts/psc-ide-client b/scripts/psc-ide-client deleted file mode 100755 index c780e12b3f..0000000000 --- a/scripts/psc-ide-client +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -purs ide client "$@" diff --git a/scripts/psc-ide-server b/scripts/psc-ide-server deleted file mode 100755 index 0ac3802ef9..0000000000 --- a/scripts/psc-ide-server +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -purs ide server "$@" diff --git a/scripts/psc-publish b/scripts/psc-publish deleted file mode 100755 index b571e81a69..0000000000 --- a/scripts/psc-publish +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -purs publish "$@" diff --git a/scripts/psci b/scripts/psci deleted file mode 100755 index d33d81b6ae..0000000000 --- a/scripts/psci +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -purs repl "$@" From 2a848782a90ef00cd5c01a2f19b0ff8df61e901f Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Sun, 10 Sep 2017 14:33:00 -0700 Subject: [PATCH 0859/1580] Revert "Revert "Run AppendSymbol in reverse (#3025)" (#3027)" (#3030) This reverts commit 59d1c6ae4c087aab001a2596270e56fa8e74fed4. --- examples/passing/AppendInReverse.purs | 24 +++++++++++++++++++ .../PureScript/TypeChecker/Entailment.hs | 22 ++++++++++++++--- tests/support/bower.json | 2 +- 3 files changed, 44 insertions(+), 4 deletions(-) create mode 100644 examples/passing/AppendInReverse.purs diff --git a/examples/passing/AppendInReverse.purs b/examples/passing/AppendInReverse.purs new file mode 100644 index 0000000000..735e1eeed5 --- /dev/null +++ b/examples/passing/AppendInReverse.purs @@ -0,0 +1,24 @@ +module Main where + +import Prelude +import Type.Data.Symbol (class AppendSymbol, SProxy(..)) +import Control.Monad.Eff.Console (log) + +class Balanced (sym :: Symbol) + +instance balanced1 :: Balanced "" +instance balanced2 + :: ( AppendSymbol "(" sym1 sym + , AppendSymbol sym2 ")" sym1 + , Balanced sym2 + ) => Balanced sym + +balanced :: forall sym. Balanced sym => SProxy sym -> String +balanced _ = "ok" + +main = do + log (balanced (SProxy :: SProxy "")) + log (balanced (SProxy :: SProxy "()")) + log (balanced (SProxy :: SProxy "(())")) + log (balanced (SProxy :: SProxy "((()))")) + log "Done" diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 698f386da6..eae5ff2a18 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -27,7 +27,7 @@ import Data.List (minimumBy) import Data.Maybe (fromMaybe, maybeToList, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S -import Data.Text (Text) +import Data.Text (Text, stripPrefix, stripSuffix) import qualified Data.Text as T import Language.PureScript.AST @@ -164,8 +164,9 @@ entails SolverOptions{..} constraint context hints = GT -> C.orderingGT args = [arg0, arg1, TypeConstructor ordering] in [TypeClassDictionaryInScope CompareSymbolInstance [] C.CompareSymbol args Nothing] - forClassName _ C.AppendSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = - let args = [arg0, arg1, TypeLevelString (lhs <> rhs)] + forClassName _ C.AppendSymbol [arg0, arg1, arg2] + | Just (arg0', arg1', arg2') <- appendSymbols arg0 arg1 arg2 = + let args = [arg0', arg1', arg2'] in [TypeClassDictionaryInScope AppendSymbolInstance [] C.AppendSymbol args Nothing] forClassName _ C.ConsSymbol [arg0, arg1, arg2] | Just (arg0', arg1', arg2') <- consSymbol arg0 arg1 arg2 = @@ -361,6 +362,21 @@ entails SolverOptions{..} constraint context hints = subclassDictionaryValue dict className index = App (Accessor (mkString (superclassName className index)) dict) valUndefined + -- | Append type level symbols, or, run backwards, strip a prefix or suffix + appendSymbols :: Type -> Type -> Type -> Maybe (Type, Type, Type) + appendSymbols arg0@(TypeLevelString lhs) arg1@(TypeLevelString rhs) _ = Just (arg0, arg1, TypeLevelString (lhs <> rhs)) + appendSymbols arg0@(TypeLevelString lhs) _ arg2@(TypeLevelString out) = do + lhs' <- decodeString lhs + out' <- decodeString out + rhs <- stripPrefix lhs' out' + pure (arg0, TypeLevelString (mkString rhs), arg2) + appendSymbols _ arg1@(TypeLevelString rhs) arg2@(TypeLevelString out) = do + rhs' <- decodeString rhs + out' <- decodeString out + lhs <- stripSuffix rhs' out' + pure (TypeLevelString (mkString lhs), arg1, arg2) + appendSymbols _ _ _ = Nothing + consSymbol :: Type -> Type -> Type -> Maybe (Type, Type, Type) consSymbol _ _ arg@(TypeLevelString s) = do (h, t) <- T.uncons =<< decodeString s diff --git a/tests/support/bower.json b/tests/support/bower.json index 837f51eac0..6a1f0a5472 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -36,7 +36,7 @@ "purescript-tailrec": "3.3.0", "purescript-tuples": "4.1.0", "purescript-type-equality": "2.1.0", - "purescript-typelevel-prelude": "2.3.0", + "purescript-typelevel-prelude": "#phil/append-symbol", "purescript-unfoldable": "3.0.0", "purescript-unsafe-coerce": "3.0.0" } From 305fbeda5f7f12dbe42263b10513d3bb3d606cf7 Mon Sep 17 00:00:00 2001 From: Csongor Kiss Date: Mon, 11 Sep 2017 15:33:42 +0100 Subject: [PATCH 0860/1580] Update CONTRIBUTORS.md (#3066) --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index abbb1608db..f009496d38 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -110,6 +110,7 @@ If you would prefer to use different terms, please use the section below instead | [@vkorablin](https://github.com/vkorablin) | Vladimir Korablin | MIT license | | [@zudov](https://github.com/zudov) | Konstantin Zudov | [MIT license](http://opensource.org/licenses/MIT) | | [@b123400](https://github.com/b123400) | b123400 | [MIT license](https://opensource.org/licenses/MIT) | +| [@kcsongor](https://github.com/kcsongor) | Csongor Kiss | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms From 46a3dcd155d2594ecf62ea3419ce8596d7153b5b Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 13 Sep 2017 12:48:14 +0200 Subject: [PATCH 0861/1580] [purs ide] Groups hiding imports with implicit ones (#3069) --- src/Language/PureScript/Ide/Imports.hs | 1 + tests/Language/PureScript/Ide/ImportsSpec.hs | 24 +++++++++++++++++--- 2 files changed, 22 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index beed3d6c3b..92d62b83be 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -320,6 +320,7 @@ prettyPrintImportSection imports = isImplicitImport :: Import -> Bool isImplicitImport i = case i of Import _ P.Implicit Nothing -> True + Import _ (P.Hiding _) Nothing -> True _ -> False diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 2dd0b8fa37..177ce39ace 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -29,6 +29,15 @@ simpleFile = , "myFunc x y = x + y" ] +hidingFile :: [Text] +hidingFile = + [ "module Main where" + , "import Prelude" + , "import Data.Maybe hiding (maybe)" + , "" + , "myFunc x y = x + y" + ] + syntaxErrorFile :: [Text] syntaxErrorFile = [ "module Main where" @@ -37,8 +46,8 @@ syntaxErrorFile = , "myFunc =" ] -splitSimpleFile :: (P.ModuleName, [Text], [Import], [Text]) -splitSimpleFile = fromRight (sliceImportSection simpleFile) +testSliceImportSection :: [Text] -> (P.ModuleName, [Text], [Import], [Text]) +testSliceImportSection = fromRight . sliceImportSection where fromRight = fromJust . rightToMaybe @@ -99,7 +108,8 @@ spec = do shouldBe (prettyPrintImport' maybeImport) "import Data.Maybe (Maybe(Just))" describe "import commands" $ do - let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i + let simpleFileImports = let (_, _, i, _) = testSliceImportSection simpleFile in i + hidingFileImports = let (_, _, i, _) = testSliceImportSection hidingFile in i addValueImport i mn q is = prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValue i Nothing)) mn q is) addOpImport op mn q is = @@ -128,6 +138,14 @@ spec = do , "" , "import Data.Map as Map" ] + it "adds a qualified import and maintains proper grouping for implicit hiding imports" $ + shouldBe + (addQualifiedImport' hidingFileImports (Test.mn "Data.Map") (Test.mn "Map")) + [ "import Data.Maybe hiding (maybe)" + , "import Prelude" + , "" + , "import Data.Map as Map" + ] it "adds an explicit unqualified import to a file without any imports" $ shouldBe (addValueImport "head" (P.moduleNameFromString "Data.Array") Nothing []) From aacdb9abd0c81320e6c13c71dfaf92b060acd66a Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Wed, 13 Sep 2017 22:25:14 +0100 Subject: [PATCH 0862/1580] Instance chain groups (#2929) * Add instance chain groups * Make OverlappingInstances an error --- app/Command/Docs/Tags.hs | 2 +- .../OverlappingInstances.purs | 4 +- examples/passing/AppendInReverse.purs | 25 +++- examples/passing/InstanceChain.purs | 71 ++++++++++ examples/passing/OverlappingInstances.purs | 17 --- examples/passing/OverlappingInstances2.purs | 27 ---- examples/passing/OverlappingInstances3.purs | 20 --- src/Language/PureScript/AST/Declarations.hs | 10 +- src/Language/PureScript/AST/Exported.hs | 2 +- src/Language/PureScript/AST/Traversals.hs | 18 +-- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- .../PureScript/Docs/Convert/Single.hs | 4 +- src/Language/PureScript/Externs.hs | 8 +- src/Language/PureScript/Ide/CaseSplit.hs | 2 +- src/Language/PureScript/Interactive/Parser.hs | 12 +- src/Language/PureScript/Linter.hs | 2 +- .../PureScript/Parser/Declarations.hs | 55 ++++++-- .../PureScript/Sugar/CaseDeclarations.hs | 4 +- src/Language/PureScript/Sugar/Names.hs | 4 +- src/Language/PureScript/Sugar/Operators.hs | 4 +- src/Language/PureScript/Sugar/TypeClasses.hs | 6 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 20 +-- .../PureScript/Sugar/TypeDeclarations.hs | 4 +- src/Language/PureScript/TypeChecker.hs | 4 +- .../PureScript/TypeChecker/Entailment.hs | 122 +++++++++++------- .../PureScript/TypeClassDictionaries.hs | 6 +- tests/Language/PureScript/Ide/StateSpec.hs | 4 + 27 files changed, 271 insertions(+), 188 deletions(-) rename examples/{warning => failing}/OverlappingInstances.purs (72%) create mode 100644 examples/passing/InstanceChain.purs delete mode 100644 examples/passing/OverlappingInstances.purs delete mode 100644 examples/passing/OverlappingInstances2.purs delete mode 100644 examples/passing/OverlappingInstances3.purs diff --git a/app/Command/Docs/Tags.hs b/app/Command/Docs/Tags.hs index ecdbdbc7b2..ebf3ae82ad 100644 --- a/app/Command/Docs/Tags.hs +++ b/app/Command/Docs/Tags.hs @@ -14,7 +14,7 @@ tags = map (first T.unpack) . concatMap dtags . P.exportedDeclarations dtags (P.ExternDeclaration (ss, _) ident _) = [(P.showIdent ident, pos ss)] dtags (P.TypeSynonymDeclaration (ss, _) name _ _) = [(P.runProperName name, pos ss)] dtags (P.TypeClassDeclaration (ss, _) name _ _ _ _) = [(P.runProperName name, pos ss)] - dtags (P.TypeInstanceDeclaration (ss, _) name _ _ _ _) = [(P.showIdent name, pos ss)] + dtags (P.TypeInstanceDeclaration (ss, _) _ _ name _ _ _ _) = [(P.showIdent name, pos ss)] dtags (P.ExternKindDeclaration (ss, _) name) = [(P.runProperName name, pos ss)] dtags _ = [] pos :: P.SourceSpan -> Int diff --git a/examples/warning/OverlappingInstances.purs b/examples/failing/OverlappingInstances.purs similarity index 72% rename from examples/warning/OverlappingInstances.purs rename to examples/failing/OverlappingInstances.purs index b5d932302a..9ae7230584 100644 --- a/examples/warning/OverlappingInstances.purs +++ b/examples/failing/OverlappingInstances.purs @@ -1,4 +1,4 @@ --- @shouldWarnWith OverlappingInstances +-- @shouldFailWith OverlappingInstances module Main where class Test a where @@ -10,7 +10,7 @@ instance testRefl :: Test a where instance testInt :: Test Int where test _ = 0 --- The OverlappingInstances instances warning only arises when there are two +-- The OverlappingInstances instances error only arises when there are two -- choices for a dictionary, not when the instances are defined. So without -- `value` this module would not raise a warning. value :: Int diff --git a/examples/passing/AppendInReverse.purs b/examples/passing/AppendInReverse.purs index 735e1eeed5..c510d2eec6 100644 --- a/examples/passing/AppendInReverse.purs +++ b/examples/passing/AppendInReverse.purs @@ -1,24 +1,37 @@ module Main where import Prelude -import Type.Data.Symbol (class AppendSymbol, SProxy(..)) +import Type.Data.Symbol (class AppendSymbol) import Control.Monad.Eff.Console (log) class Balanced (sym :: Symbol) instance balanced1 :: Balanced "" +else instance balanced2 :: ( AppendSymbol "(" sym1 sym , AppendSymbol sym2 ")" sym1 , Balanced sym2 ) => Balanced sym -balanced :: forall sym. Balanced sym => SProxy sym -> String +balanced :: forall sym. Balanced sym => @sym -> String balanced _ = "ok" +b0 :: String +b0 = balanced @"" + +b1 :: String +b1 = balanced @"()" + +b2 :: String +b2 = balanced @"(())" + +b3 :: String +b3 = balanced @"((()))" + main = do - log (balanced (SProxy :: SProxy "")) - log (balanced (SProxy :: SProxy "()")) - log (balanced (SProxy :: SProxy "(())")) - log (balanced (SProxy :: SProxy "((()))")) + log b0 + log b1 + log b2 + log b3 log "Done" diff --git a/examples/passing/InstanceChain.purs b/examples/passing/InstanceChain.purs new file mode 100644 index 0000000000..a5a1fafa52 --- /dev/null +++ b/examples/passing/InstanceChain.purs @@ -0,0 +1,71 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +class Arg i o | i -> o + +data Proxy p = Proxy + +arg :: forall i o. Arg i o => Proxy i -> Proxy o +arg _ = Proxy + +instance appArg :: Arg i o => Arg (f i) o +else instance reflArg :: Arg i i + +argEg0 :: Proxy Int +argEg0 = arg (Proxy :: Proxy Int) + +argEg1 :: Proxy Int +argEg1 = arg (Proxy :: Proxy (Array Int)) + +argEg2 :: Proxy Int +argEg2 = arg (Proxy :: Proxy (Boolean -> Array Int)) + + +class IsEq l r o | l r -> o + +foreign import data True :: Type +foreign import data False :: Type + +isEq :: forall l r o. IsEq l r o => Proxy l -> Proxy r -> Proxy o +isEq _ _ = Proxy + +instance reflIsEq :: IsEq a a True +else instance notIsEq :: IsEq a b False + +isEqEg0 :: Proxy True +isEqEg0 = isEq (Proxy :: Proxy Int) (Proxy :: Proxy Int) + +isEqEg1 :: Proxy True +isEqEg1 = isEq (Proxy :: Proxy (Array Int)) (Proxy :: Proxy (Array Int)) + +isEqEg2 :: Proxy False +isEqEg2 = isEq (Proxy :: Proxy (Array Int)) (Proxy :: Proxy (Array Boolean)) + + +-- example chain in which we should only commit to `isStringElse` once we've +-- learnt that the type param is apart from `String`. + +class Learn a b | a -> b +instance learnInst :: Learn a a + +class IsString t o | t -> o +instance isStringString :: IsString String True +else instance isStringElse :: IsString t False + +learnIsString :: forall a t o. + IsString t o => + Learn a t => + Proxy a -> + Proxy o +learnIsString _ = Proxy + +isStringEg0 :: Proxy True +isStringEg0 = learnIsString (Proxy :: Proxy String) + +isStringEg1 :: Proxy False +isStringEg1 = learnIsString (Proxy :: Proxy Int) + + +main = log "Done" diff --git a/examples/passing/OverlappingInstances.purs b/examples/passing/OverlappingInstances.purs deleted file mode 100644 index 9e981e067c..0000000000 --- a/examples/passing/OverlappingInstances.purs +++ /dev/null @@ -1,17 +0,0 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console (log) -import Test.Assert (assert) - -data A = A - -instance showA1 :: Show A where - show A = "Instance 1" - -instance showA2 :: Show A where - show A = "Instance 2" - -main = do - assert $ show A == "Instance 1" - log "Done" diff --git a/examples/passing/OverlappingInstances2.purs b/examples/passing/OverlappingInstances2.purs deleted file mode 100644 index 6b6fb0a56b..0000000000 --- a/examples/passing/OverlappingInstances2.purs +++ /dev/null @@ -1,27 +0,0 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console (log) -import Test.Assert (assert) - -data A = A | B - -instance eqA1 :: Eq A where - eq A A = true - eq B B = true - eq _ _ = false - -instance eqA2 :: Eq A where - eq _ _ = true - -instance ordA :: Ord A where - compare A B = LT - compare B A = GT - compare _ _ = EQ - -test :: forall a. Ord a => a -> a -> String -test x y = show $ x == y - -main = do - assert $ test A B == "false" - log "Done" diff --git a/examples/passing/OverlappingInstances3.purs b/examples/passing/OverlappingInstances3.purs deleted file mode 100644 index 011c1f991d..0000000000 --- a/examples/passing/OverlappingInstances3.purs +++ /dev/null @@ -1,20 +0,0 @@ -module Main where - -import Prelude -import Control.Monad.Eff.Console (log) -import Test.Assert (assert) - -class Foo a - -instance foo1 :: Foo Number - -instance foo2 :: Foo Number - -test :: forall a. Foo a => a -> a -test a = a - -test1 = test 0.0 - -main = do - assert (test1 == 0.0) - log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 77a01defd2..51dffe1c68 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -510,10 +510,10 @@ data Declaration -- | TypeClassDeclaration SourceAnn (ProperName 'ClassName) [(Text, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration] -- | - -- A type instance declaration (name, dependencies, class name, instance types, member - -- declarations) + -- A type instance declaration (instance chain, chain index, name, + -- dependencies, class name, instance types, member declarations) -- - | TypeInstanceDeclaration SourceAnn Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody + | TypeInstanceDeclaration SourceAnn [Ident] Integer Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody deriving (Show) data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName) @@ -563,7 +563,7 @@ declSourceAnn (ExternKindDeclaration sa _) = sa declSourceAnn (FixityDeclaration sa _) = sa declSourceAnn (ImportDeclaration sa _ _ _) = sa declSourceAnn (TypeClassDeclaration sa _ _ _ _ _) = sa -declSourceAnn (TypeInstanceDeclaration sa _ _ _ _ _) = sa +declSourceAnn (TypeInstanceDeclaration sa _ _ _ _ _ _ _) = sa declSourceSpan :: Declaration -> SourceSpan declSourceSpan = fst . declSourceAnn @@ -578,7 +578,7 @@ declName (ExternKindDeclaration _ n) = Just (KiName n) declName (FixityDeclaration _ (Left (ValueFixity _ _ n))) = Just (ValOpName n) declName (FixityDeclaration _ (Right (TypeFixity _ _ n))) = Just (TyOpName n) declName (TypeClassDeclaration _ n _ _ _ _) = Just (TyClassName n) -declName (TypeInstanceDeclaration _ n _ _ _ _) = Just (IdentName n) +declName (TypeInstanceDeclaration _ _ _ n _ _ _ _) = Just (IdentName n) declName ImportDeclaration{} = Nothing declName BindingGroupDeclaration{} = Nothing declName DataBindingGroupDeclaration{} = Nothing diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index be6fa74067..a566773a8d 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -101,7 +101,7 @@ filterInstances mn (Just exps) = -- Get all type and type class names referenced by a type instance declaration. -- typeInstanceConstituents :: Declaration -> [Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))] -typeInstanceConstituents (TypeInstanceDeclaration _ _ constraints className tys _) = +typeInstanceConstituents (TypeInstanceDeclaration _ _ _ _ constraints className tys _) = Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys) where diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 29b1c47561..0dce4ae926 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -58,7 +58,7 @@ everywhereOnValues f g h = (f', g', h') f' (BoundValueDeclaration sa b expr) = f (BoundValueDeclaration sa (h' b) (g' expr)) f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (fmap (\(name, nameKind, val) -> (name, nameKind, g' val)) ds)) f' (TypeClassDeclaration sa name args implies deps ds) = f (TypeClassDeclaration sa name args implies deps (fmap f' ds)) - f' (TypeInstanceDeclaration sa name cs className args ds) = f (TypeInstanceDeclaration sa name cs className args (mapTypeInstanceBody (fmap f') ds)) + f' (TypeInstanceDeclaration sa ch idx name cs className args ds) = f (TypeInstanceDeclaration sa ch idx name cs className args (mapTypeInstanceBody (fmap f') ds)) f' other = f other g' :: Expr -> Expr @@ -131,7 +131,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) ValueDecl sa name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds f' (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f' <=< f) ds - f' (TypeInstanceDeclaration sa name cs className args ds) = TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds + f' (TypeInstanceDeclaration sa ch idx name cs className args ds) = TypeInstanceDeclaration sa ch idx name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds f' (BoundValueDeclaration sa b expr) = BoundValueDeclaration sa <$> h' b <*> g' expr f' other = f other @@ -201,7 +201,7 @@ everywhereOnValuesM f g h = (f', g', h') f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f f' (BoundValueDeclaration sa b expr) = (BoundValueDeclaration sa <$> h' b <*> g' expr) >>= f f' (TypeClassDeclaration sa name args implies deps ds) = (TypeClassDeclaration sa name args implies deps <$> traverse f' ds) >>= f - f' (TypeInstanceDeclaration sa name cs className args ds) = (TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f + f' (TypeInstanceDeclaration sa ch idx name cs className args ds) = (TypeInstanceDeclaration sa ch idx name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f f' other = f other g' :: Expr -> m Expr @@ -272,7 +272,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') f' d@(ValueDeclaration vd) = foldl (<>) (f d) (fmap h' (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) (valdeclExpression vd)) f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (fmap (\(_, _, val) -> g' val) ds) f' d@(TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>) (f d) (fmap f' ds) - f' d@(TypeInstanceDeclaration _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (fmap f' ds) + f' d@(TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (fmap f' ds) f' d@(BoundValueDeclaration _ b expr) = f d <> h' b <> g' expr f' d = f d @@ -351,7 +351,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' f' s (ValueDeclaration vd) = foldl (<>) r0 (fmap (h'' s) (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) (valdeclExpression vd)) f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (fmap (\(_, _, val) -> g'' s val) ds) f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>) r0 (fmap (f'' s) ds) - f' s (TypeInstanceDeclaration _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (fmap (f'' s) ds) + f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (fmap (f'' s) ds) f' _ _ = r0 g'' :: s -> Expr -> r @@ -438,7 +438,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j ValueDecl sa name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds f' s (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f'' s) ds - f' s (TypeInstanceDeclaration sa name cs className args ds) = TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds + f' s (TypeInstanceDeclaration sa ch idx name cs className args ds) = TypeInstanceDeclaration sa ch idx name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds f' _ other = return other g'' s = uncurry g' <=< g s @@ -526,7 +526,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> name) ds))) in foldMap (\(_, _, val) -> g'' s' val) ds f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldMap (f'' s) ds - f' s (TypeInstanceDeclaration _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds + f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds f' _ _ = mempty g'' :: S.Set Ident -> Expr -> r @@ -627,7 +627,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con forDecls (DataDeclaration _ _ _ _ dctors) = mconcat (concatMap (fmap f . snd) dctors) forDecls (ExternDeclaration _ _ ty) = f ty forDecls (TypeClassDeclaration _ _ _ implies _ _) = mconcat (concatMap (fmap f . constraintArgs) implies) - forDecls (TypeInstanceDeclaration _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) `mappend` mconcat (fmap f tys) + forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) `mappend` mconcat (fmap f tys) forDecls (TypeSynonymDeclaration _ _ _ ty) = f ty forDecls (TypeDeclaration td) = f (tydeclType td) forDecls _ = mempty @@ -654,7 +654,7 @@ accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (con forDecls (TypeClassDeclaration _ _ args implies _ _) = foldMap (foldMap f . snd) args `mappend` foldMap (foldMap forTypes . constraintArgs) implies - forDecls (TypeInstanceDeclaration _ _ cs _ tys _) = + forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = foldMap (foldMap forTypes . constraintArgs) cs `mappend` foldMap forTypes tys forDecls (TypeSynonymDeclaration _ _ args ty) = diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 560d4967d7..86e82a160c 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -194,7 +194,7 @@ findQualModules decls = in f `concatMap` decls where fqDecls :: A.Declaration -> [ModuleName] - fqDecls (A.TypeInstanceDeclaration _ _ _ q _ _) = getQual' q + fqDecls (A.TypeInstanceDeclaration _ _ _ _ _ q _ _) = getQual' q fqDecls (A.ValueFixityDeclaration _ _ q _) = getQual' q fqDecls (A.TypeFixityDeclaration _ _ q _) = getQual' q fqDecls _ = [] diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 3ca683861f..5e8c657330 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -89,7 +89,7 @@ getDeclarationTitle (P.ExternDataDeclaration _ name _) = Just (P.runProperName n getDeclarationTitle (P.ExternKindDeclaration _ name) = Just (P.runProperName name) getDeclarationTitle (P.TypeSynonymDeclaration _ name _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeClassDeclaration _ name _ _ _ _) = Just (P.runProperName name) -getDeclarationTitle (P.TypeInstanceDeclaration _ name _ _ _ _) = Just (P.showIdent name) +getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ name _ _ _ _) = Just (P.showIdent name) getDeclarationTitle (P.TypeFixityDeclaration _ _ _ op) = Just ("type " <> P.showOp op) getDeclarationTitle (P.ValueFixityDeclaration _ _ _ op) = Just (P.showOp op) getDeclarationTitle _ = Nothing @@ -138,7 +138,7 @@ convertDeclaration (P.TypeClassDeclaration sa _ args implies fundeps ds) title = ChildDeclaration (P.showIdent ident') (convertComments com) (Just ss) (ChildTypeClassMember ty) convertClassMember _ = P.internalError "convertDeclaration: Invalid argument to convertClassMember." -convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ constraints className tys _) title = +convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ _ _ constraints className tys _) title = Just (Left ((classNameString, AugmentClass) : map (, AugmentType) typeNameStrings, AugmentChild childDecl)) where classNameString = unQual className diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 4b64631413..e76e000936 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -134,6 +134,8 @@ data ExternsDeclaration = , edInstanceName :: Ident , edInstanceTypes :: [Type] , edInstanceConstraints :: Maybe [Constraint] + , edInstanceChain :: [Qualified Ident] + , edInstanceChainIndex :: Integer } -- | A kind declaration | EDKind @@ -152,10 +154,10 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps) (typeClasses env) } applyDecl env (EDKind pn) = env { kinds = S.insert (qual pn) (kinds env) } - applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) } + applyDecl env (EDInstance className ident tys cs ch idx) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) } where dict :: NamedDict - dict = TypeClassDictionaryInScope (qual ident) [] className tys cs + dict = TypeClassDictionaryInScope ch idx (qual ident) [] className tys cs updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a updateMap f = M.alter (Just . f . fold) @@ -219,7 +221,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies ] toExternsDeclaration (TypeInstanceRef _ ident) - = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies + = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies tcdChain tcdIndex | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env)) , m2 <- M.elems m1 , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2) diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 7ee696b407..2493374d83 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -131,7 +131,7 @@ parseTypeDeclaration' s = P.runTokenParser "" (P.parseDeclaration <* Parsec.eof) ts in case x of - Right (P.TypeDeclaration td) -> pure (P.unwrapTypeDeclaration td) + Right (P.TypeDeclaration td : _) -> pure (P.unwrapTypeDeclaration td) Right _ -> throwError (GeneralError "Found a non-type-declaration") Left err -> throwError (GeneralError ("Parsing the type signature failed with: " diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index 8c0ed26976..9a13b22a63 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -7,6 +7,7 @@ module Language.PureScript.Interactive.Parser import Prelude.Compat hiding (lex) +import Control.Monad (join) import Data.Bifunctor (first) import Data.Char (isSpace) import Data.List (intercalate) @@ -87,11 +88,12 @@ psciImport = do -- | Any declaration that we don't need a 'special case' parser for -- (like import declarations). psciDeclaration :: P.TokenParser Command -psciDeclaration = fmap Decls $ mark $ many1 $ same *> do - decl <- P.parseDeclaration - if acceptable decl - then return decl - else fail "this kind of declaration is not supported in psci" +psciDeclaration = fmap Decls $ mark $ fmap join (many1 $ same *> + (traverse accept =<< P.parseDeclaration)) + where + accept decl + | acceptable decl = return decl + | otherwise = fail "this kind of declaration is not supported in psci" acceptable :: P.Declaration -> Bool acceptable P.DataDeclaration{} = True diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 7c7a2758c4..271bb62247 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -34,7 +34,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl getDeclIdent :: Declaration -> Maybe Ident getDeclIdent (ValueDeclaration vd) = Just (valdeclIdent vd) getDeclIdent (ExternDeclaration _ ident _) = Just ident - getDeclIdent (TypeInstanceDeclaration _ ident _ _ _ _) = Just ident + getDeclIdent (TypeInstanceDeclaration _ _ _ ident _ _ _ _) = Just ident getDeclIdent BindingGroupDeclaration{} = internalError "lint: binding groups should not be desugared yet." getDeclIdent _ = Nothing diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 9a0ece16fa..c1a282f0df 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -16,10 +16,11 @@ module Language.PureScript.Parser.Declarations ) where import Prelude hiding (lex) +import Protolude (ordNub) import Control.Applicative import Control.Arrow ((+++)) -import Control.Monad (foldM, join) +import Control.Monad (foldM, join, zipWithM) import Control.Monad.Error.Class (MonadError(..)) import Control.Parallel.Strategies (withStrategy, parList, rseq) import Data.Functor (($>)) @@ -220,7 +221,7 @@ parseInstanceDeclaration = withSourceAnnF $ do return deps className <- indented *> parseQualified properName ty <- P.many (indented *> parseTypeAtom) - return $ \sa -> TypeInstanceDeclaration sa name (fromMaybe [] deps) className ty + return $ \sa -> TypeInstanceDeclaration sa [] 0 name (fromMaybe [] deps) className ty parseTypeInstanceDeclaration :: TokenParser Declaration parseTypeInstanceDeclaration = do @@ -236,6 +237,32 @@ parseTypeInstanceDeclaration = do , parseValueDeclaration ] P. "type declaration or value declaration in instance" +parseTypeInstanceChainDeclaration :: TokenParser [Declaration] +parseTypeInstanceChainDeclaration = do + instances <- P.sepBy1 parseTypeInstanceDeclaration (reserved "else") + ensureSameTypeClass instances + chainId <- traverse getTypeInstanceName instances + zipWithM (setTypeInstanceChain chainId) instances [0..] + where + getTypeInstanceName :: Declaration -> TokenParser Ident + getTypeInstanceName (TypeInstanceDeclaration _ _ _ name _ _ _ _) = return name + getTypeInstanceName _ = P.unexpected "Found non-instance in chain declaration." + + setTypeInstanceChain :: [Ident] -> Declaration -> Integer -> TokenParser Declaration + setTypeInstanceChain chain (TypeInstanceDeclaration sa _ _ n d c t b) index = return (TypeInstanceDeclaration sa chain index n d c t b) + setTypeInstanceChain _ _ _ = P.unexpected "Found non-instance in chain declaration." + + getTypeInstanceClass :: Declaration -> TokenParser (Qualified (ProperName 'ClassName)) + getTypeInstanceClass (TypeInstanceDeclaration _ _ _ _ _ tc _ _) = return tc + getTypeInstanceClass _ = P.unexpected "Found non-instance in chain declaration." + + ensureSameTypeClass :: [Declaration] -> TokenParser () + ensureSameTypeClass xs = do + classNames <- ordNub <$> traverse getTypeInstanceClass xs + case classNames of + [_] -> return () + _ -> P.unexpected "All instances in a chain must implement the same type class." + parseDerivingInstanceDeclaration :: TokenParser Declaration parseDerivingInstanceDeclaration = do reserved "derive" @@ -243,19 +270,19 @@ parseDerivingInstanceDeclaration = do instanceDecl <- parseInstanceDeclaration return $ instanceDecl ty --- | Parse a single declaration -parseDeclaration :: TokenParser Declaration +-- | Parse a single declaration. May include a collection of instances in a chain. +parseDeclaration :: TokenParser [Declaration] parseDeclaration = P.choice - [ parseDataDeclaration - , parseTypeDeclaration - , parseTypeSynonymDeclaration - , parseValueDeclaration - , parseExternDeclaration - , parseFixityDeclaration - , parseTypeClassDeclaration - , parseTypeInstanceDeclaration - , parseDerivingInstanceDeclaration + [ pure <$> parseDataDeclaration + , pure <$> parseTypeDeclaration + , pure <$> parseTypeSynonymDeclaration + , pure <$> parseValueDeclaration + , pure <$> parseExternDeclaration + , pure <$> parseFixityDeclaration + , pure <$> parseTypeClassDeclaration + , parseTypeInstanceChainDeclaration + , pure <$> parseDerivingInstanceDeclaration ] P. "declaration" parseLocalDeclaration :: TokenParser Declaration @@ -286,7 +313,7 @@ parseModule = do -- parseModuleHeader function. This should allow us to speed up rebuilds -- by only parsing as far as the module header. See PR #2054. imports <- P.many (same *> parseImportDeclaration) - decls <- P.many (same *> parseDeclaration) + decls <- join <$> P.many (same *> parseDeclaration) return (imports <> decls) _ <- P.eof end <- P.getPosition diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index a8f15a1d49..4963ef685c 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -326,8 +326,8 @@ desugarCases :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Decla desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup where desugarRest :: [Declaration] -> m [Declaration] - desugarRest (TypeInstanceDeclaration sa name constraints className tys ds : rest) = - (:) <$> (TypeInstanceDeclaration sa name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest + desugarRest (TypeInstanceDeclaration sa cd idx name constraints className tys ds : rest) = + (:) <$> (TypeInstanceDeclaration sa cd idx name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest desugarRest (ValueDecl sa name nameKind bs result : rest) = let (_, f, _) = everywhereOnValuesTopDownM return go return f' = mapM (\(GuardedExpr gs e) -> GuardedExpr gs <$> f e) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 4f341cf172..4afbdccc9e 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -209,9 +209,9 @@ renameInModule imports (Module modSS coms mn decls exps) = <*> updateConstraints ss implies <*> pure deps <*> pure ds - updateDecl bound (TypeInstanceDeclaration sa@(ss, _) name cs cn ts ds) = + updateDecl bound (TypeInstanceDeclaration sa@(ss, _) ch idx name cs cn ts ds) = fmap (bound,) $ - TypeInstanceDeclaration sa name + TypeInstanceDeclaration sa ch idx name <$> updateConstraints ss cs <*> updateClassName cn ss <*> traverse (updateTypesEverywhere ss) ts diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index b4b9714e8e..b537e621a9 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -334,10 +334,10 @@ updateTypes goType = (goDecl, goExpr, goBinder) goDecl (TypeClassDeclaration sa@(ss, _) name args implies deps decls) = do implies' <- traverse (overConstraintArgs (traverse (goType'' ss))) implies return $ TypeClassDeclaration sa name args implies' deps decls - goDecl (TypeInstanceDeclaration sa@(ss, _) name cs className tys impls) = do + goDecl (TypeInstanceDeclaration sa@(ss, _) ch idx name cs className tys impls) = do cs' <- traverse (overConstraintArgs (traverse (goType'' ss))) cs tys' <- traverse (goType'' ss) tys - return $ TypeInstanceDeclaration sa name cs' className tys' impls + return $ TypeInstanceDeclaration sa ch idx name cs' className tys' impls goDecl (TypeSynonymDeclaration sa@(ss, _) name args ty) = TypeSynonymDeclaration sa name args <$> goType'' ss ty goDecl (TypeDeclaration (TypeDeclarationData sa@(ss, _) expr ty)) = diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 84ce5d9fe2..577479f39f 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -179,12 +179,12 @@ desugarDecl mn exps = go go d@(TypeClassDeclaration sa name args implies deps members) = do modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps)) return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) - go (TypeInstanceDeclaration _ _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" - go d@(TypeInstanceDeclaration sa name deps className tys (ExplicitInstance members)) = do + go (TypeInstanceDeclaration _ _ _ _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" + go d@(TypeInstanceDeclaration sa _ _ name deps className tys (ExplicitInstance members)) = do desugared <- desugarCases members dictDecl <- typeInstanceDictionaryDeclaration sa name mn deps className tys desugared return (expRef name className tys, [d, dictDecl]) - go d@(TypeInstanceDeclaration sa name deps className tys (NewtypeInstanceWithDictionary dict)) = do + go d@(TypeInstanceDeclaration sa _ _ name deps className tys (NewtypeInstanceWithDictionary dict)) = do let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (foldr ConstrainedType dictTy deps) return (expRef name className tys, [d, ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 6914f4bb39..da5b9f4253 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -100,7 +100,7 @@ deriveInstances externs (Module ss coms mn ds exts) = fromLocalDecl (TypeClassDeclaration _ cl args cons deps _) = NewtypeDerivedInstances (M.singleton (mn, cl) (map fst args, cons, deps)) mempty - fromLocalDecl (TypeInstanceDeclaration _ _ _ cl tys _) = + fromLocalDecl (TypeInstanceDeclaration _ _ _ _ _ cl tys _) = foldMap (\nm -> NewtypeDerivedInstances mempty (S.singleton (qualify mn cl, nm))) (extractNewtypeName mn tys) fromLocalDecl _ = mempty @@ -114,33 +114,33 @@ deriveInstance -> [Declaration] -> Declaration -> m Declaration -deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) nm deps className tys DerivedInstance) +deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys DerivedInstance) | className == Qualified (Just dataGeneric) (ProperName C.generic) = case tys of [ty] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa nm deps className tys . ExplicitInstance <$> deriveGeneric ss mn syns ds tyCon args + -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveGeneric ss mn syns ds tyCon args | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataEq) (ProperName "Eq") = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa nm deps className tys . ExplicitInstance <$> deriveEq ss mn syns ds tyCon + -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveEq ss mn syns ds tyCon | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataOrd) (ProperName "Ord") = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa nm deps className tys . ExplicitInstance <$> deriveOrd ss mn syns ds tyCon + -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveOrd ss mn syns ds tyCon | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataFunctor) (ProperName "Functor") = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa nm deps className tys . ExplicitInstance <$> deriveFunctor ss mn syns ds tyCon + -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveFunctor ss mn syns ds tyCon | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataNewtype) (ProperName "Newtype") @@ -149,7 +149,7 @@ deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) nm deps classNam | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy , mn == fromMaybe mn mn' -> do (inst, actualUnwrappedTy) <- deriveNewtype mn syns ds tyCon args unwrappedTy - return $ TypeInstanceDeclaration sa nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) + return $ TypeInstanceDeclaration sa ch idx nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys wrappedTy _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 | className == Qualified (Just dataGenericRep) (ProperName C.generic) @@ -158,15 +158,15 @@ deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) nm deps classNam | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy , mn == fromMaybe mn mn' -> do (inst, inferredRepTy) <- deriveGenericRep mn syns ds tyCon args repTy - return $ TypeInstanceDeclaration sa nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) + return $ TypeInstanceDeclaration sa ch idx nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys actualTy _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 | otherwise = throwError . errorMessage' ss $ CannotDerive className tys -deriveInstance mn syns ndis ds (TypeInstanceDeclaration sa@(ss, _) nm deps className tys NewtypeInstance) = +deriveInstance mn syns ndis ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys NewtypeInstance) = case tys of _ : _ | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys) , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance ss mn syns ndis className ds tys tyCon args + -> TypeInstanceDeclaration sa ch idx nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance ss mn syns ndis className ds tys tyCon args | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys (last tys) _ -> throwError . errorMessage' ss $ InvalidNewtypeInstance className tys deriveInstance _ _ _ _ e = return e diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 1003a10456..bb4f99a8e1 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -48,8 +48,8 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) = where go (Let ds' val') = Let <$> desugarTypeDeclarations ds' <*> pure val' go other = return other - desugarTypeDeclarations (TypeInstanceDeclaration sa nm deps cls args (ExplicitInstance ds') : rest) = - (:) <$> (TypeInstanceDeclaration sa nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds') + desugarTypeDeclarations (TypeInstanceDeclaration sa ch idx nm deps cls args (ExplicitInstance ds') : rest) = + (:) <$> (TypeInstanceDeclaration sa ch idx nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds') <*> desugarTypeDeclarations rest desugarTypeDeclarations (d:rest) = (:) d <$> desugarTypeDeclarations rest desugarTypeDeclarations [] = return [] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index b7e7facaa6..e00cf051e5 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -313,7 +313,7 @@ typeCheckAll moduleName _ = traverse go go d@(TypeClassDeclaration _ pn args implies deps tys) = do addTypeClass moduleName pn args implies deps tys return d - go (d@(TypeInstanceDeclaration (ss, _) dictName deps className tys body)) = + go (d@(TypeInstanceDeclaration (ss, _) ch idx dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys) . addHint (PositionedError ss)) $ do env <- getEnv case M.lookup className (typeClasses env) of @@ -324,7 +324,7 @@ typeCheckAll moduleName _ = traverse go checkOrphanInstance dictName className typeClass tys _ <- traverseTypeInstanceBody checkInstanceMembers body deps' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps - let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps') + let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) <$> ch) idx (Qualified (Just moduleName) dictName) [] className tys (Just deps') addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict return d diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index eae5ff2a18..66ba9b2b04 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -14,7 +14,7 @@ module Language.PureScript.TypeChecker.Entailment import Prelude.Compat import Protolude (ordNub) -import Control.Arrow (second) +import Control.Arrow (second, (&&&)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State import Control.Monad.Supply.Class (MonadSupply(..)) @@ -23,10 +23,11 @@ import Control.Monad.Writer import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.Functor (($>)) -import Data.List (minimumBy) -import Data.Maybe (fromMaybe, maybeToList, mapMaybe) +import Data.List (minimumBy, groupBy, sortBy) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S +import Data.Traversable (for) import Data.Text (Text, stripPrefix, stripSuffix) import qualified Data.Text as T @@ -133,6 +134,18 @@ data SolverOptions = SolverOptions -- ^ Should the solver be allowed to defer errors by skipping constraints? } +data Matched t + = Match t + | Apart + | Unknown + deriving (Eq, Show) + +bothMatched :: Matched () -> Matched () -> Matched () +bothMatched (Match _) (Match _) = Match () +bothMatched Unknown r = r +bothMatched l Unknown = l +bothMatched _ _ = Apart + -- | Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. entails @@ -154,32 +167,32 @@ entails SolverOptions{..} constraint context hints = forClassName ctx cn@C.Warn [msg] = -- Prefer a warning dictionary in scope if there is one available. -- This allows us to defer a warning by propagating the constraint. - findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope (WarnInstance msg) [] C.Warn [msg] Nothing] + findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope [] 0 (WarnInstance msg) [] C.Warn [msg] Nothing] forClassName _ C.IsSymbol [TypeLevelString sym] = - [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing] + [TypeClassDictionaryInScope [] 0 (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing] forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = let ordering = case compare lhs rhs of LT -> C.orderingLT EQ -> C.orderingEQ GT -> C.orderingGT args = [arg0, arg1, TypeConstructor ordering] - in [TypeClassDictionaryInScope CompareSymbolInstance [] C.CompareSymbol args Nothing] + in [TypeClassDictionaryInScope [] 0 CompareSymbolInstance [] C.CompareSymbol args Nothing] forClassName _ C.AppendSymbol [arg0, arg1, arg2] | Just (arg0', arg1', arg2') <- appendSymbols arg0 arg1 arg2 = let args = [arg0', arg1', arg2'] - in [TypeClassDictionaryInScope AppendSymbolInstance [] C.AppendSymbol args Nothing] + in [TypeClassDictionaryInScope [] 0 AppendSymbolInstance [] C.AppendSymbol args Nothing] forClassName _ C.ConsSymbol [arg0, arg1, arg2] | Just (arg0', arg1', arg2') <- consSymbol arg0 arg1 arg2 = let args = [arg0', arg1', arg2'] - in [TypeClassDictionaryInScope ConsSymbolInstance [] C.ConsSymbol args Nothing] + in [TypeClassDictionaryInScope [] 0 ConsSymbolInstance [] C.ConsSymbol args Nothing] forClassName _ C.Union [l, r, u] | Just (lOut, rOut, uOut, cst) <- unionRows l r u - = [ TypeClassDictionaryInScope UnionInstance [] C.Union [lOut, rOut, uOut] cst ] + = [ TypeClassDictionaryInScope [] 0 UnionInstance [] C.Union [lOut, rOut, uOut] cst ] forClassName _ C.RowCons [TypeLevelString sym, ty, r, _] - = [ TypeClassDictionaryInScope ConsInstance [] C.RowCons [TypeLevelString sym, ty, r, RCons (Label sym) ty r] Nothing ] + = [ TypeClassDictionaryInScope [] 0 ConsInstance [] C.RowCons [TypeLevelString sym, ty, r, RCons (Label sym) ty r] Nothing ] forClassName _ C.RowToList [r, _] | Just entries <- solveRowToList r - = [ TypeClassDictionaryInScope RowToListInstance [] C.RowToList [r, entries] Nothing ] + = [ TypeClassDictionaryInScope [] 0 RowToListInstance [] C.RowToList [r, entries] Nothing ] forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) forClassName _ _ _ = internalError "forClassName: expected qualified class name" @@ -214,12 +227,21 @@ entails SolverOptions{..} constraint context hints = TypeClassData{ typeClassDependencies } <- case M.lookup className' classesInScope of Nothing -> throwError . errorMessage $ UnknownClass className' Just tcd -> pure tcd - let instances = - [ (substs, tcd) - | tcd <- forClassName (combineContexts context inferred) className' tys'' - -- Make sure the type unifies with the type in the type instance definition - , substs <- maybeToList (matches typeClassDependencies tcd tys'') - ] + let instances = do + chain <- groupBy ((==) `on` tcdChain) $ + sortBy (compare `on` (tcdChain &&& tcdIndex)) $ + forClassName (combineContexts context inferred) className' tys'' + -- process instances in a chain in index order + let found = for chain $ \tcd -> + -- Make sure the type unifies with the type in the type instance definition + case matches typeClassDependencies tcd tys'' of + Apart -> Right () -- keep searching + Match substs -> Left (Just (substs, tcd)) -- found a match + Unknown -> Left Nothing -- can't continue with this chain yet, need proof of apartness + case found of + Right _ -> [] -- all apart + Left Nothing -> [] -- last unknown + Left (Just substsTcd) -> [substsTcd] -- found a match solution <- lift . lift $ unique tys'' instances case solution of Solved substs tcd -> do @@ -302,9 +324,8 @@ entails SolverOptions{..} constraint context hints = | otherwise = throwError . errorMessage $ NoInstanceFound (Constraint className' tyArgs conInfo) unique _ [(a, dict)] = return $ Solved a dict unique tyArgs tcds - | pairwiseAny overlapping (map snd tcds) = do - tell . errorMessage $ OverlappingInstances className' tyArgs (tcds >>= (toList . namedInstanceIdentifier . tcdValue . snd)) - return $ uncurry Solved (head tcds) + | pairwiseAny overlapping (map snd tcds) = + throwError . errorMessage $ OverlappingInstances className' tyArgs (tcds >>= (toList . namedInstanceIdentifier . tcdValue . snd)) | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds) canBeGeneralized :: Type -> Bool @@ -426,23 +447,24 @@ entails SolverOptions{..} constraint context hints = -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a -- substitution which makes them match. If not, we return 'Nothing'. -matches :: [FunctionalDependency] -> TypeClassDict -> [Type] -> Maybe (Matching [Type]) -matches deps TypeClassDictionaryInScope{..} tys = do +matches :: [FunctionalDependency] -> TypeClassDict -> [Type] -> Matched (Matching [Type]) +matches deps TypeClassDictionaryInScope{..} tys = -- First, find those types which match exactly - let matched = zipWith typeHeadsAreEqual tys tcdInstanceTypes + let matched = zipWith typeHeadsAreEqual tys tcdInstanceTypes in -- Now, use any functional dependencies to infer any remaining types - guard $ covers matched - -- Verify that any repeated type variables are unifiable - let determinedSet = foldMap (S.fromList . fdDetermined) deps - solved = map snd . filter ((`S.notMember` determinedSet) . fst) $ zipWith (\(_, ts) i -> (i, ts)) matched [0..] - verifySubstitution (M.unionsWith (++) solved) + if not (covers matched) + then if any ((==) Apart . fst) matched then Apart else Unknown + else -- Verify that any repeated type variables are unifiable + let determinedSet = foldMap (S.fromList . fdDetermined) deps + solved = map snd . filter ((`S.notMember` determinedSet) . fst) $ zipWith (\(_, ts) i -> (i, ts)) matched [0..] + in maybe Apart Match $ verifySubstitution (M.unionsWith (++) solved) where -- | Find the closure of a set of functional dependencies. - covers :: [(Bool, subst)] -> Bool + covers :: [(Matched (), subst)] -> Bool covers ms = finalSet == S.fromList [0..length ms - 1] where initialSet :: S.Set Int - initialSet = S.fromList . map snd . filter (fst . fst) $ zip ms [0..] + initialSet = S.fromList . map snd . filter ((==) (Match ()) . fst . fst) $ zip ms [0..] finalSet :: S.Set Int finalSet = untilFixedPoint applyAll initialSet @@ -466,35 +488,37 @@ matches deps TypeClassDictionaryInScope{..} tys = do -- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup), -- and return a substitution from type variables to types which makes the type heads unify. -- - typeHeadsAreEqual :: Type -> Type -> (Bool, Matching [Type]) + typeHeadsAreEqual :: Type -> Type -> (Matched (), Matching [Type]) typeHeadsAreEqual (KindedType t1 _) t2 = typeHeadsAreEqual t1 t2 typeHeadsAreEqual t1 (KindedType t2 _) = typeHeadsAreEqual t1 t2 - typeHeadsAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = (True, M.empty) - typeHeadsAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = (True, M.empty) - typeHeadsAreEqual t (TypeVar v) = (True, M.singleton v [t]) - typeHeadsAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = (True, M.empty) - typeHeadsAreEqual (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = (True, M.empty) + typeHeadsAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = (Match (), M.empty) + typeHeadsAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = (Match (), M.empty) + typeHeadsAreEqual t (TypeVar v) = (Match (), M.singleton v [t]) + typeHeadsAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = (Match (), M.empty) + typeHeadsAreEqual (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = (Match (), M.empty) typeHeadsAreEqual (TypeApp h1 t1) (TypeApp h2 t2) = both (typeHeadsAreEqual h1 h2) (typeHeadsAreEqual t1 t2) - typeHeadsAreEqual REmpty REmpty = (True, M.empty) + typeHeadsAreEqual REmpty REmpty = (Match (), M.empty) typeHeadsAreEqual r1@RCons{} r2@RCons{} = foldr both (uncurry go rest) common where (common, rest) = alignRowsWith typeHeadsAreEqual r1 r2 - go :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> (Bool, Matching [Type]) + go :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> (Matched (), Matching [Type]) go (l, KindedType t1 _) (r, t2) = go (l, t1) (r, t2) go (l, t1) (r, KindedType t2 _) = go (l, t1) (r, t2) - go ([], REmpty) ([], REmpty) = (True, M.empty) - go ([], TUnknown u1) ([], TUnknown u2) | u1 == u2 = (True, M.empty) - go ([], TypeVar v1) ([], TypeVar v2) | v1 == v2 = (True, M.empty) - go ([], Skolem _ sk1 _ _) ([], Skolem _ sk2 _ _) | sk1 == sk2 = (True, M.empty) - go (sd, r) ([], TypeVar v) = (True, M.singleton v [rowFromList (sd, r)]) - go _ _ = (False, M.empty) - typeHeadsAreEqual _ _ = (False, M.empty) - - both :: (Bool, Matching [Type]) -> (Bool, Matching [Type]) -> (Bool, Matching [Type]) - both (b1, m1) (b2, m2) = (b1 && b2, M.unionWith (++) m1 m2) + go ([], REmpty) ([], REmpty) = (Match (), M.empty) + go ([], TUnknown u1) ([], TUnknown u2) | u1 == u2 = (Match (), M.empty) + go ([], TypeVar v1) ([], TypeVar v2) | v1 == v2 = (Match (), M.empty) + go ([], Skolem _ sk1 _ _) ([], Skolem _ sk2 _ _) | sk1 == sk2 = (Match (), M.empty) + go ([], TUnknown _) _ = (Unknown, M.empty) + go (sd, r) ([], TypeVar v) = (Match (), M.singleton v [rowFromList (sd, r)]) + go _ _ = (Apart, M.empty) + typeHeadsAreEqual (TUnknown _) _ = (Unknown, M.empty) + typeHeadsAreEqual _ _ = (Apart, M.empty) + + both :: (Matched (), Matching [Type]) -> (Matched (), Matching [Type]) -> (Matched (), Matching [Type]) + both (b1, m1) (b2, m2) = (bothMatched b1 b2, M.unionWith (++) m1 m2) -- Ensure that a substitution is valid verifySubstitution :: Matching [Type] -> Maybe (Matching [Type]) @@ -549,7 +573,7 @@ newDictionaries path name (Constraint className instanceTy _) = do name (Constraint supName (instantiateSuperclass (map fst typeClassArguments) supArgs instanceTy) Nothing) ) typeClassSuperclasses [0..] - return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts) + return (TypeClassDictionaryInScope [] 0 name path className instanceTy Nothing : supDicts) where instantiateSuperclass :: [Text] -> [Type] -> [Type] -> [Type] instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 70d138b56e..af00286035 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -18,8 +18,12 @@ import Language.PureScript.Types -- data TypeClassDictionaryInScope v = TypeClassDictionaryInScope { + -- | The instance chain + tcdChain :: [Qualified Ident] + -- | Index of the instance chain + , tcdIndex :: Integer -- | The value with which the dictionary can be accessed at runtime - tcdValue :: v + , tcdValue :: v -- | How to obtain this instance via superclass relationships , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)] -- | The name of the type class to which this type class instance applies diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index 0a313319b9..67a66713d8 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -62,6 +62,10 @@ ef = P.ExternsFile mempty -- , edInstanceConstraints = mempty + -- , edInstanceChain = + mempty + -- , edInstanceChainIndex = + 0 -- } ] --, efSourceSpan = From 0d1568f30e6ab5bb38674feaad810f49ff90970e Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Thu, 14 Sep 2017 03:56:03 +0100 Subject: [PATCH 0863/1580] Add inlining for runEffFnN/mkEffFnN (#3026) * Add inlining for runEffFnN/mkEffFnN * Magic-do case to improve EffFn usage From natefaubion https://github.com/purescript/purescript/pull/3026#issuecomment-320516974 * Apply magicDo until fixed point * Rearrange magic do optimizations * Stop run(Eff)FnX optimisation firing from local definitions * Add EffFn optimisation test --- examples/passing/EffFn.js | 1 + examples/passing/EffFn.purs | 22 +++++++++ examples/passing/RunFnInline.purs | 11 +++++ src/Language/PureScript/Constants.hs | 15 +++++- src/Language/PureScript/CoreImp/Optimizer.hs | 2 +- .../PureScript/CoreImp/Optimizer/Inliner.hs | 46 +++++++++++++------ .../PureScript/CoreImp/Optimizer/MagicDo.hs | 14 +++--- 7 files changed, 87 insertions(+), 24 deletions(-) create mode 100644 examples/passing/EffFn.js create mode 100644 examples/passing/EffFn.purs create mode 100644 examples/passing/RunFnInline.purs diff --git a/examples/passing/EffFn.js b/examples/passing/EffFn.js new file mode 100644 index 0000000000..b645b0527e --- /dev/null +++ b/examples/passing/EffFn.js @@ -0,0 +1 @@ +exports.add3 = function (a,b,c) { return a + b + c; }; \ No newline at end of file diff --git a/examples/passing/EffFn.purs b/examples/passing/EffFn.purs new file mode 100644 index 0000000000..b4f56d0805 --- /dev/null +++ b/examples/passing/EffFn.purs @@ -0,0 +1,22 @@ +module Main where + +import Prelude + +import Control.Monad.Eff.Console (log) +import Control.Monad.Eff.Uncurried (EffFn3, mkEffFn7, runEffFn3, runEffFn7) +import Test.Assert (assert) + +testBothWays = do + res <- (runEffFn7 $ mkEffFn7 \x1 x2 x3 x4 x5 x6 x7 -> pure 42) 1 2 3 4 5 6 7 + assert $ res == 42 + +foreign import add3 :: forall eff. EffFn3 eff String String String String + +testRunFn = do + str <- runEffFn3 add3 "a" "b" "c" + assert $ str == "abc" + +main = do + testBothWays + testRunFn + log "Done" diff --git a/examples/passing/RunFnInline.purs b/examples/passing/RunFnInline.purs new file mode 100644 index 0000000000..24babe5adc --- /dev/null +++ b/examples/passing/RunFnInline.purs @@ -0,0 +1,11 @@ +module Main where + +import Prelude + +import Control.Monad.Eff.Console (log) + +runFn3 :: forall a b c d. (a -> b -> c -> d) -> a -> b -> c -> d +runFn3 f a b c = f a b c + +main = do + log $ runFn3 (\a b c -> c) 1 2 "Done" diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index ce6ed2e2c2..3703e07bf1 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -191,6 +191,11 @@ pure' = "pure" returnEscaped :: forall a. (IsString a) => a returnEscaped = "$return" +unit :: forall a. (IsString a) => a +unit = "unit" + +-- Core lib values + untilE :: forall a. (IsString a) => a untilE = "untilE" @@ -221,8 +226,11 @@ mkFn = "mkFn" runFn :: forall a. (IsString a) => a runFn = "runFn" -unit :: forall a. (IsString a) => a -unit = "unit" +mkEffFn :: forall a. (IsString a) => a +mkEffFn = "mkEffFn" + +runEffFn :: forall a. (IsString a) => a +runEffFn = "runEffFn" -- Prim values @@ -444,6 +452,9 @@ pattern ControlBind = ModuleName [ProperName "Control", ProperName "Bind"] controlBind :: forall a. (IsString a) => a controlBind = "Control_Bind" +controlMonadEffUncurried :: forall a. (IsString a) => a +controlMonadEffUncurried = "Control_Monad_Eff_Uncurried" + dataBounded :: forall a. (IsString a) => a dataBounded = "Data_Bounded" diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs index e85e3efaf9..23013b7ba8 100644 --- a/src/Language/PureScript/CoreImp/Optimizer.hs +++ b/src/Language/PureScript/CoreImp/Optimizer.hs @@ -37,7 +37,7 @@ optimize js = do [ inlineCommonValues , inlineCommonOperators ]) js - untilFixedPoint (return . tidyUp) . tco . magicDo $ js' + untilFixedPoint (return . tidyUp) . tco . inlineST =<< untilFixedPoint (return . magicDo) js' where tidyUp :: AST -> AST tidyUp = applyAll diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index d7dc9989c5..ae291a2ee0 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -24,6 +24,7 @@ import qualified Data.Text as T import Language.PureScript.PSString (PSString) import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Common +import Language.PureScript.AST (SourceSpan(..)) import qualified Language.PureScript.Constants as C -- TODO: Potential bug: @@ -169,7 +170,8 @@ inlineCommonOperators = everywhereTopDown $ applyAll $ , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x] , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing) ] ++ - [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] + [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++ + [ fn | i <- [0..10], fn <- [ mkEffFn i, runEffFn i ] ] where binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST binary dict fns op = convert where @@ -191,37 +193,53 @@ inlineCommonOperators = everywhereTopDown $ applyAll $ convert :: AST -> AST convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op x convert other = other + mkFn :: Int -> AST -> AST - mkFn 0 = convert where + mkFn = mkFn' C.dataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args js -> + Function ss1 Nothing args (Block ss2 [Return ss3 js]) + + mkEffFn :: Int -> AST -> AST + mkEffFn = mkFn' C.controlMonadEffUncurried C.mkEffFn $ \ss1 ss2 ss3 args js -> + Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 js [])]) + + mkFn' :: Text -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST + mkFn' modName fnName res 0 = convert where convert :: AST -> AST - convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 js)]) | isNFn C.mkFn 0 mkFnN = - Function s1 Nothing [] (Block s2 js) + convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 js])]) | isNFn modName fnName 0 mkFnN = + res s1 s2 s3 [] js convert other = other - mkFn n = convert where + mkFn' modName fnName res n = convert where convert :: AST -> AST - convert orig@(App ss mkFnN [fn]) | isNFn C.mkFn n mkFnN = + convert orig@(App ss mkFnN [fn]) | isNFn modName fnName n mkFnN = case collectArgs n [] fn of - Just (args, js) -> Function ss Nothing args (Block ss js) - Nothing -> orig + Just (args, [Return ss' ret]) -> res ss ss ss' args ret + _ -> orig convert other = other collectArgs :: Int -> [Text] -> AST -> Maybe ([Text], [AST]) collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js) collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret collectArgs _ _ _ = Nothing - isNFn :: Text -> Int -> AST -> Bool - isNFn prefix n (Var _ name) = name == (prefix <> T.pack (show n)) - isNFn prefix n (Indexer _ (StringLiteral _ name) (Var _ dataFunctionUncurried)) | dataFunctionUncurried == C.dataFunctionUncurried = + isNFn :: Text -> Text -> Int -> AST -> Bool + isNFn expectMod prefix n (Indexer _ (StringLiteral _ name) (Var _ modName)) | modName == expectMod = name == fromString (T.unpack prefix <> show n) - isNFn _ _ _ = False + isNFn _ _ _ _ = False runFn :: Int -> AST -> AST - runFn n = convert where + runFn = runFn' C.dataFunctionUncurried C.runFn App + + runEffFn :: Int -> AST -> AST + runEffFn = runFn' C.controlMonadEffUncurried C.runEffFn $ \ss fn acc -> + Function ss Nothing [] (Block ss [Return ss (App ss fn acc)]) + + runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST + runFn' modName runFnName res n = convert where convert :: AST -> AST convert js = fromMaybe js $ go n [] js go :: Int -> [AST] -> AST -> Maybe AST - go 0 acc (App ss runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (App ss fn acc) + go 0 acc (App ss runFnN [fn]) | isNFn modName runFnName n runFnN && length acc == n = + Just $ res ss fn acc go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs go _ _ _ = Nothing diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs index cf03f41056..5d83c3ab5d 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs @@ -1,6 +1,6 @@ -- | This module implements the "Magic Do" optimization, which inlines calls to return -- and bind for the Eff monad, as well as some of its actions. -module Language.PureScript.CoreImp.Optimizer.MagicDo (magicDo) where +module Language.PureScript.CoreImp.Optimizer.MagicDo (magicDo, inlineST) where import Prelude.Compat import Protolude (ordNub) @@ -27,7 +27,7 @@ import qualified Language.PureScript.Constants as C -- ... -- } magicDo :: AST -> AST -magicDo = inlineST . everywhere undo . everywhereTopDown convert +magicDo = everywhereTopDown convert where -- The name of the function block which is added to denote a do block fnName = "__do" @@ -47,6 +47,11 @@ magicDo = inlineST . everywhere undo . everywhereTopDown convert -- Desugar whileE convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc C.whileE f = App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) [] + -- Inline __do returns + convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body + -- Inline double applications + convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) = + App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) [] convert other = other -- Check if an expression represents a monomorphic call to >>= for the Eff monad isBind (App _ fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True @@ -70,11 +75,6 @@ magicDo = inlineST . everywhere undo . everywhereTopDown convert isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == C.eff && name == name' isEffFunc _ _ = False - -- Remove __do function applications which remain after desugaring - undo :: AST -> AST - undo (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body - undo other = other - applyReturns :: AST -> AST applyReturns (Return ss ret) = Return ss (App ss ret []) applyReturns (Block ss jss) = Block ss (map applyReturns jss) From fe6a0981f83134c5fc2b5669c672dd8285b43c8b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Thu, 14 Sep 2017 12:47:51 -0700 Subject: [PATCH 0864/1580] Remove old generics (#3007) --- examples/failing/DeriveOldGeneric.purs | 10 + examples/passing/2695.purs | 13 - examples/passing/GenericsRep.purs | 24 +- examples/passing/StringEdgeCases/Records.purs | 27 -- .../PureScript/Sugar/TypeClasses/Deriving.hs | 248 +----------------- 5 files changed, 15 insertions(+), 307 deletions(-) create mode 100644 examples/failing/DeriveOldGeneric.purs delete mode 100644 examples/passing/2695.purs diff --git a/examples/failing/DeriveOldGeneric.purs b/examples/failing/DeriveOldGeneric.purs new file mode 100644 index 0000000000..c90ec9e50d --- /dev/null +++ b/examples/failing/DeriveOldGeneric.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith CannotDerive +module DeriveOldGeneric where + +import Prelude +import Data.Generic +import Control.Monad.Eff.Console (log) + +newtype Foo = Foo Int + +derive instance genericFoo :: Generic Foo diff --git a/examples/passing/2695.purs b/examples/passing/2695.purs deleted file mode 100644 index 1957342b48..0000000000 --- a/examples/passing/2695.purs +++ /dev/null @@ -1,13 +0,0 @@ -module Main where - -import Prelude -import Data.Generic -import Control.Monad.Eff.Console (log) - -type Foo = { foo :: Int } - -newtype Foo' = Foo' Foo - -derive instance genericFoo :: Generic Foo' - -main = log "Done" diff --git a/examples/passing/GenericsRep.purs b/examples/passing/GenericsRep.purs index b83537ef30..646e74d890 100644 --- a/examples/passing/GenericsRep.purs +++ b/examples/passing/GenericsRep.purs @@ -6,8 +6,8 @@ import Control.Monad.Eff.Console (CONSOLE, log, logShow) import Data.Generic.Rep (class Generic) import Data.Generic.Rep.Eq (genericEq) -data X a = X a - +data X a = X a + derive instance genericX :: Generic (X a) _ instance eqX :: Eq a => Eq (X a) where @@ -33,23 +33,6 @@ newtype W = W { x :: Int, y :: MyString } derive instance genericW :: Generic W _ -instance eqW :: Eq W where - eq x y = genericEq x y - -data V = V { x :: Int } { x :: Int } - -derive instance genericV :: Generic V _ - -instance eqV :: Eq V where - eq x y = genericEq x y - -newtype U = U {} - -derive instance genericU :: Generic U _ - -instance eqU :: Eq U where - eq x y = genericEq x y - main :: Eff (console :: CONSOLE) Unit main = do logShow (X 0 == X 1) @@ -57,7 +40,4 @@ main = do logShow (Z 1 Y == Z 1 Y) logShow (Z 1 Y == Y) logShow (Y == Y :: Y Z) - logShow (W { x: 0, y: "A" } == W { x: 0, y: "A" }) - logShow (V { x: 0 } { x: 0 } == V { x: 0 } { x: 0 }) - logShow (U {} == U {}) log "Done" diff --git a/examples/passing/StringEdgeCases/Records.purs b/examples/passing/StringEdgeCases/Records.purs index faa58c6751..82300b3300 100644 --- a/examples/passing/StringEdgeCases/Records.purs +++ b/examples/passing/StringEdgeCases/Records.purs @@ -1,19 +1,12 @@ module Records where import Prelude -import Data.Generic (class Generic, toSpine, GenericSpine(..)) import Control.Monad.Eff.Console (log) import Test.Assert (assert') newtype AstralKeys = AstralKeys { "💡" :: Int, "💢" :: Int } newtype LoneSurrogateKeys = LoneSurrogateKeys { "\xdf06" :: Int, "\xd834" :: Int } -derive instance genericAstralKeys :: Generic AstralKeys -derive instance genericLoneSurrogateKeys :: Generic LoneSurrogateKeys - -spineOf :: forall a. Generic a => a -> Unit -> GenericSpine -spineOf x _ = toSpine x - testLoneSurrogateKeys = let expected = 5 @@ -40,27 +33,7 @@ testAstralKeys = case o."💡" of x -> { "💢": x } -testGenericLoneSurrogateKeys = do - let expected = SProd "Records.LoneSurrogateKeys" - [ \_ -> SRecord [ {recLabel: "\xd834", recValue: spineOf 1} - , {recLabel: "\xdf06", recValue: spineOf 0} - ] - ] - actual = toSpine (LoneSurrogateKeys { "\xdf06": 0, "\xd834": 1 }) - assert' ("generic lone surrogate keys: " <> show actual) (expected == actual) - -testGenericAstralKeys = do - let expected = SProd "Records.AstralKeys" - [ \_ -> SRecord [ {recLabel: "💡", recValue: spineOf 0} - , {recLabel: "💢", recValue: spineOf 1} - ] - ] - actual = toSpine (AstralKeys { "💡": 0, "💢": 1 }) - assert' ("generic astral keys: " <> show actual) (expected == actual) - main = do testLoneSurrogateKeys testAstralKeys - testGenericLoneSurrogateKeys - testGenericAstralKeys log "Done" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index da5b9f4253..27fcf75393 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -17,7 +17,6 @@ import Data.Maybe (fromMaybe, mapMaybe) import Data.Ord (comparing) import qualified Data.Set as S import Data.Text (Text) -import qualified Data.Text as T import Language.PureScript.AST import qualified Language.PureScript.Constants as C import Language.PureScript.Crash @@ -27,7 +26,7 @@ import Language.PureScript.Externs import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Label (Label(..)) -import Language.PureScript.PSString (mkString, decodeStringEither) +import Language.PureScript.PSString (mkString) import Language.PureScript.Types import Language.PureScript.TypeChecker (checkNewtype) import Language.PureScript.TypeChecker.Synonyms (SynonymMap, replaceAllTypeSynonymsM) @@ -115,13 +114,6 @@ deriveInstance -> Declaration -> m Declaration deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys DerivedInstance) - | className == Qualified (Just dataGeneric) (ProperName C.generic) - = case tys of - [ty] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty - , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveGeneric ss mn syns ds tyCon args - | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty - _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataEq) (ProperName "Eq") = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty @@ -248,18 +240,9 @@ deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do tell . errorMessage' ss $ MissingNewtypeSuperclassInstance constraintClass className tys else tell . errorMessage' ss $ UnverifiableSuperclassInstance constraintClass className tys -dataGeneric :: ModuleName -dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] - dataGenericRep :: ModuleName dataGenericRep = ModuleName [ ProperName "Data", ProperName "Generic", ProperName "Rep" ] -dataMaybe :: ModuleName -dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ] - -typesProxy :: ModuleName -typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ] - dataEq :: ModuleName dataEq = ModuleName [ ProperName "Data", ProperName "Eq" ] @@ -275,177 +258,6 @@ dataFunctor = ModuleName [ ProperName "Data", ProperName "Functor" ] unguarded :: Expr -> [GuardedExpr] unguarded e = [MkUnguarded e] -deriveGeneric - :: forall m. (MonadError MultipleErrors m, MonadSupply m) - => SourceSpan - -> ModuleName - -> SynonymMap - -> [Declaration] - -> ProperName 'TypeName - -> [Type] - -> m [Declaration] -deriveGeneric ss mn syns ds tyConNm dargs = do - tyCon <- findTypeDecl tyConNm ds - toSpine <- mkSpineFunction tyCon - fromSpine <- mkFromSpineFunction tyCon - toSignature <- mkSignatureFunction tyCon dargs - return [ ValueDecl (ss, []) (Ident C.toSpine) Public [] (unguarded toSpine) - , ValueDecl (ss, []) (Ident C.fromSpine) Public [] (unguarded fromSpine) - , ValueDecl (ss, []) (Ident C.toSignature) Public [] (unguarded toSignature) - ] - where - mkSpineFunction :: Declaration -> m Expr - mkSpineFunction (DataDeclaration _ _ _ _ args) = do - x <- freshIdent' - lamCase x <$> mapM mkCtorClause args - where - prodConstructor :: Expr -> Expr - prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd"))) - - recordConstructor :: Expr -> Expr - recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord"))) - - mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative - mkCtorClause (ctorName, tys) = do - idents <- replicateM (length tys) freshIdent' - tys' <- mapM (replaceAllTypeSynonymsM syns) tys - let caseResult = - App (prodConstructor (Literal . StringLiteral . mkString . showQualified runProperName $ Qualified (Just mn) ctorName)) - . Literal . ArrayLiteral - $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys' - return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (unguarded caseResult) - - toSpineFun :: Expr -> Type -> Expr - toSpineFun i r | Just rec <- objectType r - , Just fields <- decomposeRec rec = - lamNull . recordConstructor . Literal . ArrayLiteral - . map - (\((Label str),typ) -> - Literal $ ObjectLiteral - [ ("recLabel", Literal (StringLiteral str)) - , ("recValue", toSpineFun (Accessor str i) typ) - ] - ) - $ fields - toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i - mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration" - - mkSignatureFunction :: Declaration -> [Type] -> m Expr - mkSignatureFunction (DataDeclaration _ _ name tyArgs args) classArgs = lamNull . mkSigProd <$> mapM mkProdClause args - where - mkSigProd :: [Expr] -> Expr - mkSigProd = - App - (App - (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) - (Literal (StringLiteral $ mkString (showQualified runProperName (Qualified (Just mn) name)))) - ) - . Literal - . ArrayLiteral - - mkSigRec :: [Expr] -> Expr - mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . Literal . ArrayLiteral - - proxy :: Type -> Type - proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy"))) - - mkProdClause :: (ProperName 'ConstructorName, [Type]) -> m Expr - mkProdClause (ctorName, tys) = do - tys' <- mapM (replaceAllTypeSynonymsM syns) tys - return $ Literal $ ObjectLiteral - [ ("sigConstructor", Literal (StringLiteral $ mkString (showQualified runProperName (Qualified (Just mn) ctorName)))) - , ("sigValues", Literal . ArrayLiteral . map (mkProductSignature . instantiate) $ tys') - ] - - mkProductSignature :: Type -> Expr - mkProductSignature r | Just rec <- objectType r - , Just fields <- decomposeRec rec = - lamNull . mkSigRec $ - [ Literal $ ObjectLiteral - [ ("recLabel", Literal (StringLiteral str)) - , ("recValue", mkProductSignature typ) - ] - | ((Label str), typ) <- fields - ] - mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature)) - (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ)) - instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs) - mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration" - - mkFromSpineFunction :: Declaration -> m Expr - mkFromSpineFunction (DataDeclaration _ _ _ _ args) = do - x <- freshIdent' - lamCase x <$> (addCatch <$> mapM mkAlternative args) - where - mkJust :: Expr -> Expr - mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just"))) - - mkNothing :: Expr - mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing")) - - prodBinder :: [Binder] -> Binder - prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd")) - - recordBinder :: [Binder] -> Binder - recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord")) - - mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative - mkAlternative (ctorName, tys) = do - idents <- replicateM (length tys) freshIdent' - tys' <- mapM (replaceAllTypeSynonymsM syns) tys - return $ - CaseAlternative - [ prodBinder - [ LiteralBinder (StringLiteral $ mkString (showQualified runProperName (Qualified (Just mn) ctorName))) - , LiteralBinder (ArrayLiteral (map VarBinder idents)) - ] - ] - . unguarded - $ liftApplicative - (mkJust $ Constructor (Qualified (Just mn) ctorName)) - (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys') - - addCatch :: [CaseAlternative] -> [CaseAlternative] - addCatch = (++ [catchAll]) - where - catchAll = CaseAlternative [NullBinder] (unguarded mkNothing) - - fromSpineFun :: Expr -> Type -> Expr - fromSpineFun e r - | Just rec <- objectType r - , Just fields <- decomposeRec rec - = App (lamCase (Ident "r") [ mkRecCase fields - , CaseAlternative [NullBinder] (unguarded mkNothing) - ]) - (App e unitVal) - fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e unitVal) - - mkRecCase :: [(Label, Type)] -> CaseAlternative - mkRecCase rs = - CaseAlternative - [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . labelToIdent . fst) rs)) ] ] - . unguarded - $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar $ labelToIdent x)) y) rs) - - mkRecFun :: [(Label, Type)] -> Expr - mkRecFun xs = mkJust $ foldr (lam . labelToIdent . fst) recLiteral xs - where recLiteral = Literal . ObjectLiteral $ map (\(l@(Label s), _) -> (s, mkVar $ labelToIdent l)) xs - mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration" - - -- Helpers - - liftApplicative :: Expr -> [Expr] -> Expr - liftApplicative = foldl' (\x e -> App (App applyFn x) e) - - unitVal :: Expr - unitVal = mkVarMn (Just (ModuleName [ProperName "Data", ProperName "Unit"])) (Ident "unit") - - applyFn :: Expr - applyFn = mkVarMn (Just (ModuleName [ProperName "Control", ProperName "Apply"])) (Ident "apply") - - mkGenVar :: Ident -> Expr - mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) - deriveGenericRep :: forall m . (MonadError MultipleErrors m, MonadSupply m) @@ -512,7 +324,7 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do (TypeLevelString $ mkString (runProperName ctorName))) ctorTy , CaseAlternative [ ConstructorBinder constructor [matchProduct] ] - (unguarded (foldl App (Constructor (Qualified (Just mn) ctorName)) ctorArgs)) + (unguarded (foldl' App (Constructor (Qualified (Just mn) ctorName)) ctorArgs)) , CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) matchCtor ] (unguarded (constructor' mkProduct)) ) @@ -532,34 +344,6 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do ) makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr) - makeArg arg | Just rec <- objectType arg - , Just fields <- decomposeRec rec = do - fieldNames <- traverse freshIdent (map (runIdent . labelToIdent . fst) fields) - case fieldNames of - [] -> - pure ( TypeApp (TypeConstructor record) noArgs - , ConstructorBinder record [ NullBinder ] - , Literal (ObjectLiteral []) - , LiteralBinder (ObjectLiteral []) - , record' noArgs' - ) - _ -> - pure ( TypeApp (TypeConstructor record) - (foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) - (map (\((Label name), ty) -> - TypeApp (TypeApp (TypeConstructor field) (TypeLevelString name)) ty) fields)) - , ConstructorBinder record - [ foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2]) - (map (\ident -> ConstructorBinder field [VarBinder ident]) fieldNames) - ] - , Literal . ObjectLiteral $ - zipWith (\((Label name), _) ident -> (name, Var (Qualified Nothing ident))) fields fieldNames - , LiteralBinder . ObjectLiteral $ - zipWith (\((Label name), _) ident -> (name, VarBinder ident)) fields fieldNames - , record' $ - foldr1 (\e1 -> App (App (Constructor productName) e1)) - (map (field' . Var . Qualified Nothing) fieldNames) - ) makeArg arg = do argName <- freshIdent "arg" pure ( TypeApp (TypeConstructor argument) arg @@ -620,18 +404,6 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do argument' :: Expr -> Expr argument' = App (Constructor argument) - record :: Qualified (ProperName ty) - record = Qualified (Just dataGenericRep) (ProperName "Rec") - - record' :: Expr -> Expr - record' = App (Constructor record) - - field :: Qualified (ProperName ty) - field = Qualified (Just dataGenericRep) (ProperName "Field") - - field' :: Expr -> Expr - field' = App (Constructor field) - checkIsWildcard :: MonadError MultipleErrors m => ProperName 'TypeName -> Type -> m () checkIsWildcard _ (TypeWildcard _) = return () checkIsWildcard tyConNm _ = @@ -833,9 +605,6 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType lam :: Ident -> Expr -> Expr lam = Abs . VarBinder -lamNull :: Expr -> Expr -lamNull = lam (Ident "$q") -- TODO: use GenIdent - lamCase :: Ident -> [CaseAlternative] -> Expr lamCase s = lam s . Case [mkVar s] @@ -848,17 +617,6 @@ mkVarMn mn = Var . Qualified mn mkVar :: Ident -> Expr mkVar = mkVarMn Nothing --- This function may seem a little obtuse, but it's only this way to ensure --- that it is injective. Injectivity is important here; without it, we can end --- up with accidental variable shadowing in the generated code. -labelToIdent :: Label -> Ident -labelToIdent = - Ident . foldMap (either loneSurrogate char) . decodeStringEither . runLabel - where - char '_' = "__" - char c = T.singleton c - loneSurrogate x = "_" <> T.pack (show x) <> "_" - objectType :: Type -> Maybe Type objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec objectType _ = Nothing @@ -903,7 +661,7 @@ deriveFunctor ss mn syns ds tyConNm = do ctorTys' <- mapM (replaceAllTypeSynonymsM syns) ctorTys args <- zipWithM transformArg idents ctorTys' let ctor = Constructor (Qualified (Just mn) ctorName) - rebuilt = foldl App ctor args + rebuilt = foldl' App ctor args caseBinder = ConstructorBinder (Qualified (Just mn) ctorName) (VarBinder <$> idents) return $ CaseAlternative [caseBinder] (unguarded rebuilt) where From 703dd5229536a3330c9da79518bd8d5354704c66 Mon Sep 17 00:00:00 2001 From: Fredrik Wallberg Date: Sat, 16 Sep 2017 01:16:41 +0200 Subject: [PATCH 0865/1580] Require single-method instance declarations to be indented (#3073) Resolves https://github.com/purescript/purescript/issues/2947 --- CONTRIBUTORS.md | 1 + examples/failing/2947.purs | 10 ++++++++++ examples/passing/2947.purs | 11 +++++++++++ src/Language/PureScript/Parser/Declarations.hs | 2 +- 4 files changed, 23 insertions(+), 1 deletion(-) create mode 100644 examples/failing/2947.purs create mode 100644 examples/passing/2947.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index f009496d38..82765ae2f2 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -85,6 +85,7 @@ If you would prefer to use different terms, please use the section below instead | [@phiggins](https://github.com/phiggins) | Pete Higgins | [MIT license](http://opensource.org/licenses/MIT) | | [@philopon](https://github.com/philopon) | Hirotomo Moriwaki | [MIT license](http://opensource.org/licenses/MIT) | | [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license](http://opensource.org/licenses/MIT) | +| [@quesebifurcan](https://github.com/quesebifurcan) | Fredrik Wallberg | [MIT license](http://opensource.org/licenses/MIT) | | [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) | | [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license](http://opensource.org/licenses/MIT) | | [@RossMeikleham](https://github.com/RossMeikleham) | Ross Meikleham | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/examples/failing/2947.purs b/examples/failing/2947.purs new file mode 100644 index 0000000000..c0f191b5bd --- /dev/null +++ b/examples/failing/2947.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith ErrorParsingModule + +module Main where + +import Prelude + +data Foo = Foo + +instance eqFoo :: Eq Foo where +eq _ _ = true diff --git a/examples/passing/2947.purs b/examples/passing/2947.purs new file mode 100644 index 0000000000..fbc1b201fb --- /dev/null +++ b/examples/passing/2947.purs @@ -0,0 +1,11 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +data Foo = Foo + +instance eqFoo :: Eq Foo where + eq _ _ = true + +main = log "Done" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index c1a282f0df..d17ab94b58 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -228,7 +228,7 @@ parseTypeInstanceDeclaration = do instanceDecl <- parseInstanceDeclaration members <- P.option [] $ do indented *> reserved "where" - mark (P.many (same *> declsInInstance)) + indented *> mark (P.many (same *> declsInInstance)) return $ instanceDecl (ExplicitInstance members) where declsInInstance :: TokenParser Declaration From 2b10b06ee5b75373505d497d6dd7602680ad6efc Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sat, 16 Sep 2017 01:17:03 +0200 Subject: [PATCH 0866/1580] Bump to ghc8 2 (#3070) * fixes cabal warning about an unspecified Paths module * Bump to GHC 8.2 stack nightly * trigger rebuild * fix more shadowing warnings * retrigger build * try again --- app/Command/Ide.hs | 1 + package.yaml | 23 +++++++++++++++---- .../PureScript/Docs/Convert/Single.hs | 2 +- src/Language/PureScript/Ide/Completion.hs | 2 +- src/Language/PureScript/Ide/Imports.hs | 2 +- src/Language/PureScript/Ide/Reexports.hs | 2 +- src/Language/PureScript/Ide/State.hs | 2 +- src/Language/PureScript/Ide/Types.hs | 2 +- stack.yaml | 3 ++- tests/Language/PureScript/Ide/ImportsSpec.hs | 2 +- 10 files changed, 29 insertions(+), 12 deletions(-) diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index 263e27172f..a33c33d90a 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -147,6 +147,7 @@ command = Opts.helper <*> subcommands where `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\"")) <*> Opts.switch (Opts.long "editor-mode") + parseLogLevel :: Text -> IdeLogLevel parseLogLevel s = case s of "debug" -> LogDebug "perf" -> LogPerf diff --git a/package.yaml b/package.yaml index 9f33ba0c4c..ddeb153eec 100644 --- a/package.yaml +++ b/package.yaml @@ -32,7 +32,7 @@ extra-source-files: - CONTRIBUTORS.md - CONTRIBUTING.md dependencies: - - aeson >=1.0 && <1.2 + - aeson >=1.0 && <1.3 - aeson-better-errors >=0.8 - ansi-terminal >=0.6.2 && <0.7 - base >=4.8 && <5 @@ -67,7 +67,7 @@ dependencies: - pattern-arrows >=0.0.2 && <0.1 - pipes >=4.0.0 && <4.4.0 - pipes-http - - process >=1.2.0 && <1.5 + - process >=1.2.0 && <1.7 - protolude >=0.1.6 - regex-tdfa - safe >=0.3.9 && <0.4 @@ -116,6 +116,21 @@ executables: main: Main.hs source-dirs: app ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N + other-modules: + - Command.Bundle + - Command.Compile + - Command.Docs + - Command.Docs.Ctags + - Command.Docs.Etags + - Command.Docs.Html + - Command.Docs.Tags + - Command.Hierarchy + - Command.Ide + - Command.Publish + - Command.REPL + - Paths_purescript + - Version + dependencies: - ansi-wl-pprint - file-embed @@ -125,14 +140,14 @@ executables: - wai ==3.* - wai-websockets ==3.* - warp ==3.* - - websockets >=0.9 && <0.11 + - websockets >=0.9 && <0.13 when: - condition: flag(release) then: cpp-options: -DRELEASE else: dependencies: - - gitrev >=1.2.0 && <1.3 + - gitrev >=1.2.0 && <1.4 tests: tests: diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 5e8c657330..98c8c90cca 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -2,7 +2,7 @@ module Language.PureScript.Docs.Convert.Single ( convertSingleModule ) where -import Protolude +import Protolude hiding (moduleName) import Control.Category ((>>>)) diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 44a4ac6fea..b4e9f2ed66 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -9,7 +9,7 @@ module Language.PureScript.Ide.Completion , applyCompletionOptions ) where -import Protolude +import Protolude hiding ((<&>), moduleName) import Control.Lens hiding ((&), op) import Data.Aeson diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 92d62b83be..251864909d 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -30,7 +30,7 @@ module Language.PureScript.Ide.Imports ) where -import Protolude +import Protolude hiding (moduleName) import Control.Lens ((^.), (%~), ix) import Data.List (findIndex, nubBy, partition) diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 8cdc088301..82a639c9cb 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -23,7 +23,7 @@ module Language.PureScript.Ide.Reexports , resolveReexports' ) where -import Protolude +import Protolude hiding (moduleName) import Control.Lens hiding ((&)) import qualified Data.Map as Map diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index e6c7fed3c5..f7d7a57a6c 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -36,7 +36,7 @@ module Language.PureScript.Ide.State , resolveDataConstructorsForModule ) where -import Protolude +import Protolude hiding (moduleName) import Control.Arrow import Control.Concurrent.STM diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index ffab6bfb90..a19a2d72da 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -19,7 +19,7 @@ module Language.PureScript.Ide.Types where -import Protolude +import Protolude hiding (moduleName) import Control.Concurrent.STM import Control.Lens.TH diff --git a/stack.yaml b/stack.yaml index c04a09eede..df22368d47 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,6 @@ -resolver: lts-8.5 +resolver: nightly-2017-09-10 packages: - '.' extra-deps: - pipes-http-1.0.5 +- Win32-notify-0.3.0.3 diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 177ce39ace..71a883cde1 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.ImportsSpec where -import Protolude +import Protolude hiding (moduleName) import Data.Maybe (fromJust) import qualified Language.PureScript as P From 48590ca766cd8d01f53230e0341d605a3aa76dd9 Mon Sep 17 00:00:00 2001 From: Isaac Elliott Date: Sun, 24 Sep 2017 03:13:43 +1000 Subject: [PATCH 0867/1580] Fixed type shadowing error (#2967) * Fix and regression tests for #2197 * Updated Prim module documentation * Added test using Record type * Added some peace-of-mind tests --- examples/failing/2197-shouldFail.purs | 10 ++++++++++ examples/failing/2197-shouldFail2.purs | 7 +++++++ examples/passing/2197-1.purs | 12 ++++++++++++ examples/passing/2197-2.purs | 11 +++++++++++ src/Language/PureScript/AST/Declarations.hs | 13 ++++++++++--- src/Language/PureScript/Docs/Prim.hs | 2 +- 6 files changed, 51 insertions(+), 4 deletions(-) create mode 100644 examples/failing/2197-shouldFail.purs create mode 100644 examples/failing/2197-shouldFail2.purs create mode 100644 examples/passing/2197-1.purs create mode 100644 examples/passing/2197-2.purs diff --git a/examples/failing/2197-shouldFail.purs b/examples/failing/2197-shouldFail.purs new file mode 100644 index 0000000000..a211f195d0 --- /dev/null +++ b/examples/failing/2197-shouldFail.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith ScopeConflict +module Main where + +import Prim as P +import Prim (Number) + +type Number = P.Number + +z :: Number +z = 0.0 diff --git a/examples/failing/2197-shouldFail2.purs b/examples/failing/2197-shouldFail2.purs new file mode 100644 index 0000000000..fb1b11b5d7 --- /dev/null +++ b/examples/failing/2197-shouldFail2.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith UnknownName +module Main where + +import Prim (Boolean) + +z :: Number +z = 0.0 diff --git a/examples/passing/2197-1.purs b/examples/passing/2197-1.purs new file mode 100644 index 0000000000..a0c808f350 --- /dev/null +++ b/examples/passing/2197-1.purs @@ -0,0 +1,12 @@ +module Main where + +import Control.Monad.Eff.Console +import Prim as P + +type Number = P.Number +type Test = {} + +z :: Number +z = 0.0 + +main = log "Done" diff --git a/examples/passing/2197-2.purs b/examples/passing/2197-2.purs new file mode 100644 index 0000000000..94354e94cd --- /dev/null +++ b/examples/passing/2197-2.purs @@ -0,0 +1,11 @@ +module Main where + +import Control.Monad.Eff.Console +import Prim (Int) + +type Number = Int + +z :: Number +z = 0 + +main = log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 51dffe1c68..1042b42ad9 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -233,12 +233,19 @@ getModuleSourceSpan (Module ss _ _ _ _) = ss -- | -- Add an import declaration for a module if it does not already explicitly import it. -- +-- Will not import an unqualified module if that module has already been imported qualified. +-- (See #2197) +-- addDefaultImport :: Qualified ModuleName -> Module -> Module addDefaultImport (Qualified toImportAs toImport) m@(Module ss coms mn decls exps) = if isExistingImport `any` decls || mn == toImport then m else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit toImportAs : decls) exps where - isExistingImport (ImportDeclaration _ mn' _ as') | mn' == toImport && as' == toImportAs = True + isExistingImport (ImportDeclaration _ mn' _ as') + | mn' == toImport = + case toImportAs of + Nothing -> True + _ -> as' == toImportAs isExistingImport _ = False -- | Adds import declarations to a module for an implicit Prim import and Prim @@ -248,8 +255,8 @@ importPrim = let primModName = ModuleName [ProperName C.prim] in - addDefaultImport (Qualified Nothing primModName) - . addDefaultImport (Qualified (Just primModName) primModName) + addDefaultImport (Qualified (Just primModName) primModName) + . addDefaultImport (Qualified Nothing primModName) -- | -- An item in a list of explicit imports or exports diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 2a5e62c641..aa8b68c3e4 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -12,7 +12,7 @@ import qualified Language.PureScript as P primDocsModule :: Module primDocsModule = Module { modName = P.moduleNameFromString "Prim" - , modComments = Just "The Prim module is embedded in the PureScript compiler in order to provide compiler support for certain types — for example, value literals, or syntax sugar." + , modComments = Just "The Prim module is embedded in the PureScript compiler in order to provide compiler support for certain types — for example, value literals, or syntax sugar. It is implicitly imported unqualified in every module except those that list it as a qualified import." , modDeclarations = [ function , array From 15b58276f7a38b89371f11ad6b852204a30f5b1c Mon Sep 17 00:00:00 2001 From: Tom Harding Date: Sun, 24 Sep 2017 21:40:25 +0100 Subject: [PATCH 0868/1580] Expand error message for UnusableDeclaration (#3088) Previously, the error message made no mention of a solution to the error. This update adds possible solutions to the error message in the form of the remaining covering sets. In other words, the remaining variables that need to be determined in order to satisfy the typechecker. --- CONTRIBUTORS.md | 1 + src/Language/PureScript/AST/Declarations.hs | 5 ++--- src/Language/PureScript/Errors.hs | 17 ++++++++++++++--- src/Language/PureScript/TypeChecker.hs | 11 ++++++++--- 4 files changed, 25 insertions(+), 9 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 82765ae2f2..60cddf762d 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -51,6 +51,7 @@ If you would prefer to use different terms, please use the section below instead | [@houli](https://github.com/houli) | Eoin Houlihan | [MIT license](http://opensource.org/licenses/MIT) | | [@ianbollinger](https://github.com/ianbollinger) | Ian D. Bollinger | [MIT license](http://opensource.org/licenses/MIT) | | [@ilovezfs](https://github.com/ilovezfs) | ilovezfs | MIT license | +| [@i-am-tom](https://github.com/i-am-tom) | i-am-tom | [MIT license](http://opensource.org/licenses/MIT) | | [@izgzhen](https://github.com/izgzhen) | Zhen Zhang | [MIT license](http://opensource.org/licenses/MIT) | | [@jacereda](https://github.com/jacereda) | Jorge Acereda | [MIT license](http://opensource.org/licenses/MIT) | | [@japesinator](https://github.com/japesinator) | JP Smith | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 1042b42ad9..a32859f27a 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -168,9 +168,8 @@ data SimpleErrorMessage | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int -- | a user-defined warning raised by using the Warn type class | UserDefinedWarning Type - -- | a declaration couldn't be used because there wouldn't be enough information - -- | to choose an instance - | UnusableDeclaration Ident + -- | a declaration couldn't be used because it contained free variables + | UnusableDeclaration Ident [[Text]] deriving (Show) -- | Error message hints, providing more detailed information about failure. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 47da4e29bb..63209cb1a6 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -950,9 +950,20 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , indent msg ] - renderSimpleErrorMessage (UnusableDeclaration ident) = - paras [ line $ "The declaration " <> markCode (showIdent ident) <> " is unusable." - , line $ "This happens when a constraint couldn't possibly have enough information to work out which instance is required." + renderSimpleErrorMessage (UnusableDeclaration ident unexplained) = + paras $ + [ line $ "The declaration " <> markCode (showIdent ident) <> " contains arguments that couldn't be determined." + ] <> + + case unexplained of + [required] -> + [ line $ "These arguments are: { " <> T.intercalate "," required <> "}" + ] + + options -> + [ line "To fix this, one of the following sets of variables must be determined:" + , Box.moveRight 2 . Box.vsep 0 Box.top $ + map (\set -> line $ "{ " <> T.intercalate ", " set <> " }") options ] renderHint :: ErrorMessageHint -> Box.Box -> Box.Box diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index e00cf051e5..723db34ff4 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -20,7 +20,7 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Lens ((^..), _1, _2) import Data.Foldable (for_, traverse_, toList) -import Data.List (nubBy, (\\), sort, group) +import Data.List (nub, nubBy, (\\), sort, group) import Data.Maybe import Data.Monoid ((<>)) import Data.Text (Text) @@ -150,8 +150,13 @@ addTypeClass moduleName pn args implies dependencies ds = do checkMemberIsUsable syns (ident, memberTy) = do memberTy' <- T.replaceAllTypeSynonymsM syns memberTy let mentionedArgIndexes = S.fromList (mapMaybe argToIndex (freeTypeVariables memberTy')) - unless (any (`S.isSubsetOf` mentionedArgIndexes) coveringSets) $ - throwError . errorMessage $ UnusableDeclaration ident + let leftovers = map (`S.difference` mentionedArgIndexes) coveringSets + + unless (any null leftovers) . throwError . errorMessage $ + let + solutions = map (map (fst . (args !!)) . S.toList) leftovers + in + UnusableDeclaration ident (nub solutions) addTypeClassDictionaries :: (MonadState CheckState m) From d4a33788fde9c2dd7dce4bf6c800d60b2b004bd2 Mon Sep 17 00:00:00 2001 From: Dmitry Rets Date: Sun, 24 Sep 2017 22:44:54 +0200 Subject: [PATCH 0869/1580] Update Overlapping instances error message. (#3084) * Update Overlapping instances error message. Fixes #3071. * Remove explanation for Overlapping instances error. * Add to contributors. --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Errors.hs | 8 +++----- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 60cddf762d..04d36c4b31 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -113,6 +113,7 @@ If you would prefer to use different terms, please use the section below instead | [@zudov](https://github.com/zudov) | Konstantin Zudov | [MIT license](http://opensource.org/licenses/MIT) | | [@b123400](https://github.com/b123400) | b123400 | [MIT license](https://opensource.org/licenses/MIT) | | [@kcsongor](https://github.com/kcsongor) | Csongor Kiss | [MIT license](http://opensource.org/licenses/MIT) | +| [@drets](https://github.com/drets) | Dmytro Rets | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 63209cb1a6..31c3f748d3 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -599,18 +599,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , line "with type" , markCodeBox $ indent $ typeAsBox t2 ] - renderSimpleErrorMessage (OverlappingInstances nm ts (d : ds)) = + renderSimpleErrorMessage (OverlappingInstances _ _ []) = internalError "OverlappingInstances: empty instance list" + renderSimpleErrorMessage (OverlappingInstances nm ts ds) = paras [ line "Overlapping type class instances found for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map typeAtomAsBox ts) ] , line "The following instances were found:" - , indent $ paras (line (showQualified showIdent d <> " (chosen)") : map (line . showQualified showIdent) ds) - , line "Overlapping type class instances can lead to different behavior based on the order of module imports, and for that reason are not recommended." - , line "They may be disallowed completely in a future version of the compiler." + , indent $ paras (map (line . showQualified showIdent) ds) ] - renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list" renderSimpleErrorMessage (UnknownClass nm) = paras [ line "No type class instance was found for class" , markCodeBox $ indent $ line (showQualified runProperName nm) From 923fd4c45e4d8e7e0419bbf01968c5f34bff1d9b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 25 Sep 2017 17:19:36 -0700 Subject: [PATCH 0870/1580] A couple of minor changes to contributing guide Remove old video link Add note about opening issues --- CONTRIBUTING.md | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index da40134ebf..ef683c00d8 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -1,6 +1,4 @@ -An introductory overview of the compiler is available [here](https://www.youtube.com/watch?v=Y3P1dxqwFiE). - -Pull requests are encouraged. +Pull requests are encouraged, but please open issues before starting to work on something that you intend to make into a PR, so that we can decide if it is a good fit or not. ## Finding Issues to Work On From 2bce85802de0c0273ad7fe4e7b8f9779c7264e09 Mon Sep 17 00:00:00 2001 From: Brandon Hamilton Date: Sun, 1 Oct 2017 21:06:29 +0200 Subject: [PATCH 0871/1580] Only add newline before initial group of comment lines in javascript codegen (#3098) --- src/Language/PureScript/CodeGen/JS/Printer.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index 18a4798d18..d8b59dc268 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -116,20 +116,19 @@ literals = mkPattern' match' , prettyPrintJS' value ] match (Comment _ com js) = mconcat <$> sequence - [ mconcat <$> forM com comment + [ return $ emit "\n" + , mconcat <$> forM com comment , prettyPrintJS' js ] match _ = mzero comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen comment (LineComment com) = fmap mconcat $ sequence $ - [ return $ emit "\n" - , currentIndent + [ currentIndent , return $ emit "//" <> emit com <> emit "\n" ] comment (BlockComment com) = fmap mconcat $ sequence $ - [ return $ emit "\n" - , currentIndent + [ currentIndent , return $ emit "/**\n" ] ++ map asLine (T.lines com) ++ From fe0aa0d7d448e9d660ab00b59ca3094e49e5b7f7 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sun, 1 Oct 2017 23:47:37 +0100 Subject: [PATCH 0872/1580] Fix proxies: synonyms, inference, traversals, instances (#3095) --- examples/passing/Proxy.purs | 59 +++++++++++++++++++ src/Language/PureScript/AST/Traversals.hs | 3 + src/Language/PureScript/Sugar/Names.hs | 2 + src/Language/PureScript/Sugar/Operators.hs | 3 + src/Language/PureScript/TypeChecker.hs | 1 + .../PureScript/TypeChecker/Entailment.hs | 2 + src/Language/PureScript/TypeChecker/Types.hs | 5 +- 7 files changed, 73 insertions(+), 2 deletions(-) diff --git a/examples/passing/Proxy.purs b/examples/passing/Proxy.purs index 1a3984fe50..a2666b37f8 100644 --- a/examples/passing/Proxy.purs +++ b/examples/passing/Proxy.purs @@ -18,4 +18,63 @@ i = @"foo" j :: Unit j = h i +data P t = P + +switchP :: forall p. @p -> P p +switchP _ = P :: P p + +switchP' :: forall p. P p -> @p +switchP' P = @p + +type Ap f x = f x +infix 4 type Ap as $ +type Eg0 = Array $ Unit +type Eg1 = Array $ Unit + +eg0 :: P Eg0 +eg0 = switchP @Eg1 + +eg0' :: @Eg0 +eg0' = switchP' (P :: P Eg1) + +eg1 :: @Eg0 +eg1 = switchP' (switchP @Eg1) + +eg1' :: P Eg0 +eg1' = switchP (switchP' (P :: P Eg0)) + + +class Go a b | a -> b + +instance goInst :: Go Int Int + +goGo :: forall a b c. Go a b => Go b c => @a -> P c +goGo _ = P :: P c + +go0 :: P Int +go0 = goGo @Int + +type Go1 = Int +type Go1' = Int + +go1 :: P Go1 +go1 = goGo @Go1' + + +class Determined a p | a -> p where + determined :: a -> p + +instance determinedIntProxy :: Determined Int @Int where + determined _ = @Int + +instance determinedProxyInt :: Determined @Int Int where + determined _ = 42 + +determined0 :: @Int +determined0 = determined 42 + +determined1 :: Int +determined1 = determined @Int + + main = log "Done" diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 0dce4ae926..54547a87eb 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -635,6 +635,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con forValues (TypeClassDictionary c _ _) = mconcat (fmap f (constraintArgs c)) forValues (DeferredDictionary _ tys) = mconcat (fmap f tys) forValues (TypedValue _ _ ty) = f ty + forValues (Proxy ty) = f ty forValues _ = mempty accumKinds @@ -668,6 +669,7 @@ accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (con forValues (TypeClassDictionary c _ _) = foldMap forTypes (constraintArgs c) forValues (DeferredDictionary _ tys) = foldMap forTypes tys forValues (TypedValue _ _ ty) = forTypes ty + forValues (Proxy ty) = forTypes ty forValues _ = mempty forTypes (KindedType _ k) = f k @@ -681,5 +683,6 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' where g :: Expr -> Expr g (TypedValue checkTy val t) = TypedValue checkTy val (f t) + g (Proxy t) = Proxy (f t) g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (fmap f) c) sco hints g other = other diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 4afbdccc9e..bfc45f77d4 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -269,6 +269,8 @@ renameInModule imports (Module modSS coms mn decls exps) = (,) s <$> (Constructor <$> updateDataConstructorName name pos) updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty) + updateValue s@(pos, _) (Proxy ty) = + (,) s <$> (Proxy <$> updateTypesEverywhere pos ty) updateValue s v = return (s, v) updateBinder diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index b537e621a9..8687636e49 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -356,6 +356,9 @@ updateTypes goType = (goDecl, goExpr, goBinder) goExpr pos (TypedValue check v ty) = do ty' <- goType' pos ty return (pos, TypedValue check v ty') + goExpr pos (Proxy ty) = do + ty' <- goType' pos ty + return (pos, Proxy ty') goExpr pos other = return (pos, other) goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 723db34ff4..3167f81d87 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -199,6 +199,7 @@ checkTypeClassInstance cls i = check where TypeApp t1 t2 -> check t1 >> check t2 REmpty | isFunDepDetermined -> return () RCons _ hd tl | isFunDepDetermined -> check hd >> check tl + ProxyType ty -> check ty ty -> throwError . errorMessage $ InvalidInstanceHead ty -- | diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 66ba9b2b04..740beb2714 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -496,6 +496,7 @@ matches deps TypeClassDictionaryInScope{..} tys = typeHeadsAreEqual t (TypeVar v) = (Match (), M.singleton v [t]) typeHeadsAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = (Match (), M.empty) typeHeadsAreEqual (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = (Match (), M.empty) + typeHeadsAreEqual (ProxyType t1) (ProxyType t2) = typeHeadsAreEqual t1 t2 typeHeadsAreEqual (TypeApp h1 t1) (TypeApp h2 t2) = both (typeHeadsAreEqual h1 h2) (typeHeadsAreEqual t1 t2) typeHeadsAreEqual REmpty REmpty = (Match (), M.empty) @@ -538,6 +539,7 @@ matches deps TypeClassDictionaryInScope{..} tys = typesAreEqual (TypeLevelString s1) (TypeLevelString s2) = s1 == s2 typesAreEqual (TypeConstructor c1) (TypeConstructor c2) = c1 == c2 typesAreEqual (TypeApp h1 t1) (TypeApp h2 t2) = typesAreEqual h1 h2 && typesAreEqual t1 t2 + typesAreEqual (ProxyType t1) (ProxyType t2) = typesAreEqual t1 t2 typesAreEqual REmpty REmpty = True typesAreEqual r1 r2 | isRCons r1 || isRCons r2 = let (common, rest) = alignRowsWith typesAreEqual r1 r2 diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 05c5bef085..e3bb2d442b 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -394,8 +394,9 @@ infer' (IfThenElse cond th el) = do infer' (Let ds val) = do (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer return $ TypedValue True (Let ds' val') valTy -infer' (Proxy ty) = - return $ TypedValue True (Proxy ty) (ProxyType ty) +infer' (Proxy ty) = do + ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty + return $ TypedValue True (Proxy ty') (ProxyType ty') infer' (DeferredDictionary className tys) = do dicts <- getTypeClassDictionaries hints <- getHints From d31638f7031935c7a412371492e660e39faae19f Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 2 Oct 2017 04:22:54 +0200 Subject: [PATCH 0873/1580] Corefn Json representation (#3049) * CoreFn.FromJSON: parse json representation of CoreFn * CoreFn.Module: ModuleT Polymorphic ModuleT type: when parsing foreign declarations we don't have access to their type, and thus we need a `ModuleT ()` type. The original `Module` type becomes an alias for `ModuleT Type`. * Language.PureScript.CoreFn.DCE module * CoreFn: include `SourceSpan`s in json representation * CoreFn: add Meta to json representation It is required when runnings `moduleToJs`. * Update TestCoreFn * Change json encoding of CoreFn Bind * Remove `purs dce` command. * Remove CoreFN.DCE module * clean * remove white space in TestCoreFn * Object CoreFn representation. * CoreFn moduleToJSON: new representation - change the json representation of CoreFn - store module name on the module object - `buildMakeAction`: output single module json object, rather an object with a single key (module name) pointing to module json object. * CoreFn.FromJSON: update `moduleFromJson` - read the new json CoreFn representation - extend tests so that all the CoreFn structures are tested. * Add Module Comments to json CoreFn representation - `moduleToJSON`: include module comments inside `comments` field. - `moduleFromJSON` - add tests * CoreFn json repr: modulePath to the top level * Applied @paf31 & @kRITZCREEK review --- src/Language/PureScript/CodeGen/JS.hs | 6 +- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- src/Language/PureScript/CoreFn/FromJSON.hs | 290 ++++++++++++++++++++ src/Language/PureScript/CoreFn/Module.hs | 14 +- src/Language/PureScript/CoreFn/ToJSON.hs | 300 ++++++++++++++------- src/Language/PureScript/Make.hs | 4 +- src/Language/PureScript/Renamer.hs | 2 +- tests/Main.hs | 3 + tests/TestCoreFn.hs | 240 +++++++++++++++++ 9 files changed, 749 insertions(+), 112 deletions(-) create mode 100644 src/Language/PureScript/CoreFn/FromJSON.hs create mode 100644 tests/TestCoreFn.hs diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index de11a870b3..f90eacff42 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -45,12 +45,12 @@ import System.FilePath.Posix (()) -- | Generate code in the simplified JavaScript intermediate representation for all declarations in a -- module. moduleToJs - :: forall m + :: forall m t . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) - => Module Ann + => ModuleT t Ann -> Maybe AST -> m [AST] -moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = +moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 86e82a160c..8e820f9084 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -39,7 +39,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = exps' = ordNub $ concatMap exportToCoreFn exps externs = ordNub $ mapMaybe externToCoreFn decls decls' = concatMap declToCoreFn decls - in Module coms mn imports' exps' externs decls' + in Module coms mn (spanName modSS) imports' exps' externs decls' where diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs new file mode 100644 index 0000000000..5318888cfc --- /dev/null +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -0,0 +1,290 @@ +-- | +-- Read the core functional representation from JSON format +-- + +module Language.PureScript.CoreFn.FromJSON + ( moduleFromJSON + ) where + +import Prelude.Compat + +import Data.Aeson +import Data.Aeson.Types (Parser, Value, listParser) +import Data.Text (Text) +import qualified Data.Text as T +import Text.ParserCombinators.ReadP (readP_to_S) +import qualified Data.Vector as V +import Data.Version (Version, parseVersion) + +import Language.PureScript.AST.SourcePos (SourceSpan(SourceSpan)) +import Language.PureScript.AST.Literals +import Language.PureScript.CoreFn.Ann +import Language.PureScript.CoreFn +import Language.PureScript.Names +import Language.PureScript.PSString (PSString) + +constructorTypeFromJSON :: Value -> Parser ConstructorType +constructorTypeFromJSON v = do + t <- parseJSON v + case t of + "ProductType" -> return ProductType + "SumType" -> return SumType + _ -> fail ("not recognized ConstructorType: " ++ T.unpack t) + +metaFromJSON :: Value -> Parser (Maybe Meta) +metaFromJSON Null = return Nothing +metaFromJSON v = withObject "Meta" metaFromObj v + where + metaFromObj o = do + type_ <- o .: "metaType" + case type_ of + "IsConstructor" -> isConstructorFromJSON o + "IsNewtype" -> return $ Just IsNewtype + "IsTypeClassConstructor" + -> return $ Just IsTypeClassConstructor + "IsForeign" -> return $ Just IsForeign + _ -> fail ("not recognized Meta: " ++ T.unpack type_) + + isConstructorFromJSON o = do + ct <- o .: "constructorType" >>= constructorTypeFromJSON + is <- o .: "identifiers" >>= listParser identFromJSON + return $ Just (IsConstructor ct is) + +annFromJSON :: FilePath -> Value -> Parser Ann +annFromJSON modulePath = withObject "Ann" annFromObj + where + annFromObj o = do + ss <- o .: "sourceSpan" >>= sourceSpanFromJSON + mm <- o .: "meta" >>= metaFromJSON + return (ss, [], Nothing, mm) + + sourceSpanFromJSON = withObject "SourceSpan" $ \o -> + SourceSpan modulePath <$> + o .: "start" <*> + o .: "end" + +literalFromJSON :: (Value -> Parser a) -> Value -> Parser (Literal a) +literalFromJSON t = withObject "Literal" literalFromObj + where + literalFromObj o = do + type_ <- o .: "literalType" :: Parser Text + case type_ of + "IntLiteral" -> NumericLiteral . Left <$> o .: "value" + "NumberLiteral" -> NumericLiteral . Right <$> o .: "value" + "StringLiteral" -> StringLiteral <$> o .: "value" + "CharLiteral" -> CharLiteral <$> o .: "value" + "BooleanLiteral" -> BooleanLiteral <$> o .: "value" + "ArrayLiteral" -> parseArrayLiteral o + "ObjectLiteral" -> parseObjectLiteral o + _ -> fail ("error parsing Literal: " ++ show o) + + parseArrayLiteral o = do + val <- o .: "value" + as <- mapM t (V.toList val) + return $ ArrayLiteral as + + parseObjectLiteral o = do + val <- o .: "value" + ObjectLiteral <$> recordFromJSON t val + +identFromJSON :: Value -> Parser Ident +identFromJSON = withText "Ident" (return . Ident) + +properNameFromJSON :: Value -> Parser (ProperName a) +properNameFromJSON = fmap ProperName . parseJSON + +qualifiedFromJSON :: (Text -> a) -> Value -> Parser (Qualified a) +qualifiedFromJSON f = withObject "Qualified" qualifiedFromObj + where + qualifiedFromObj o = do + mn <- o .:? "moduleName" >>= traverse moduleNameFromJSON + i <- o .: "identifier" >>= withText "Ident" (return . f) + return $ Qualified mn i + +moduleNameFromJSON :: Value -> Parser ModuleName +moduleNameFromJSON v = ModuleName <$> listParser properNameFromJSON v + +moduleFromJSON :: Value -> Parser (Version, ModuleT () Ann) +moduleFromJSON = withObject "Module" moduleFromObj + where + moduleFromObj o = do + version <- o .: "builtWith" >>= versionFromJSON + moduleName <- o .: "moduleName" >>= moduleNameFromJSON + modulePath <- o .: "modulePath" + moduleImports <- o .: "imports" >>= listParser (importFromJSON modulePath) + moduleExports <- o .: "exports" >>= listParser identFromJSON + moduleDecls <- o .: "decls" >>= listParser (bindFromJSON modulePath) + moduleForeign <- o .: "foreign" >>= listParser (fmap (flip (,) ()) . identFromJSON) + moduleComments <- o .: "comments" >>= listParser parseJSON + return (version, Module {..}) + + versionFromJSON :: String -> Parser Version + versionFromJSON v = + case readP_to_S parseVersion v of + (r, _) : _ -> return r + _ -> fail "failed parsing purs version" + + importFromJSON :: FilePath -> Value -> Parser (Ann, ModuleName) + importFromJSON modulePath = withObject "Import" + (\o -> do + ann <- o .: "annotation" >>= annFromJSON modulePath + mn <- o .: "moduleName" >>= moduleNameFromJSON + return (ann, mn)) + +bindFromJSON :: FilePath -> Value -> Parser (Bind Ann) +bindFromJSON modulePath = withObject "Bind" bindFromObj + where + bindFromObj :: Object -> Parser (Bind Ann) + bindFromObj o = do + type_ <- o .: "bindType" :: Parser Text + case type_ of + "NonRec" -> (uncurry . uncurry) NonRec <$> bindFromObj' o + "Rec" -> Rec <$> (o .: "binds" >>= listParser (withObject "Bind" bindFromObj')) + _ -> fail ("not recognized bind type \"" ++ T.unpack type_ ++ "\"") + + bindFromObj' :: Object -> Parser ((Ann, Ident), Expr Ann) + bindFromObj' o = do + a <- o .: "annotation" >>= annFromJSON modulePath + i <- o .: "identifier" >>= identFromJSON + e <- o .: "expression" >>= exprFromJSON modulePath + return ((a, i), e) + +recordFromJSON :: (Value -> Parser a) -> Value -> Parser [(PSString, a)] +recordFromJSON p = listParser parsePair + where + parsePair v = do + (l, v') <- parseJSON v :: Parser (PSString, Value) + a <- p v' + return (l, a) + +exprFromJSON :: FilePath -> Value -> Parser (Expr Ann) +exprFromJSON modulePath = withObject "Expr" exprFromObj + where + exprFromObj o = do + type_ <- o .: "type" + case type_ of + "Var" -> varFromObj o + "Literal" -> literalExprFromObj o + "Constructor" -> constructorFromObj o + "Accessor" -> accessorFromObj o + "ObjectUpdate" -> objectUpdateFromObj o + "Abs" -> absFromObj o + "App" -> appFromObj o + "Case" -> caseFromObj o + "Let" -> letFromObj o + _ -> fail ("not recognized expression type: \"" ++ T.unpack type_ ++ "\"") + + varFromObj o = do + ann <- o .: "annotation" >>= annFromJSON modulePath + qi <- o .: "value" >>= qualifiedFromJSON Ident + return $ Var ann qi + + literalExprFromObj o = do + ann <- o .: "annotation" >>= annFromJSON modulePath + lit <- o .: "value" >>= literalFromJSON (exprFromJSON modulePath) + return $ Literal ann lit + + constructorFromObj o = do + ann <- o .: "annotation" >>= annFromJSON modulePath + tyn <- o .: "typeName" >>= properNameFromJSON + con <- o .: "constructorName" >>= properNameFromJSON + is <- o .: "fieldNames" >>= listParser identFromJSON + return $ Constructor ann tyn con is + + accessorFromObj o = do + ann <- o .: "annotation" >>= annFromJSON modulePath + f <- o .: "fieldName" + e <- o .: "expression" >>= exprFromJSON modulePath + return $ Accessor ann f e + + objectUpdateFromObj o = do + ann <- o .: "annotation" >>= annFromJSON modulePath + e <- o .: "expression" >>= exprFromJSON modulePath + us <- o .: "updates" >>= recordFromJSON (exprFromJSON modulePath) + return $ ObjectUpdate ann e us + + absFromObj o = do + ann <- o .: "annotation" >>= annFromJSON modulePath + idn <- o .: "argument" >>= identFromJSON + e <- o .: "body" >>= exprFromJSON modulePath + return $ Abs ann idn e + + appFromObj o = do + ann <- o .: "annotation" >>= annFromJSON modulePath + e <- o .: "abstraction" >>= exprFromJSON modulePath + e' <- o .: "argument" >>= exprFromJSON modulePath + return $ App ann e e' + + caseFromObj o = do + ann <- o .: "annotation" >>= annFromJSON modulePath + cs <- o .: "caseExpressions" >>= listParser (exprFromJSON modulePath) + cas <- o .: "caseAlternatives" >>= listParser (caseAlternativeFromJSON modulePath) + return $ Case ann cs cas + + letFromObj o = do + ann <- o .: "annotation" >>= annFromJSON modulePath + bs <- o .: "binds" >>= listParser (bindFromJSON modulePath) + e <- o .: "expression" >>= exprFromJSON modulePath + return $ Let ann bs e + +caseAlternativeFromJSON :: FilePath -> Value -> Parser (CaseAlternative Ann) +caseAlternativeFromJSON modulePath = withObject "CaseAlternative" caseAlternativeFromObj + where + caseAlternativeFromObj o = do + bs <- o .: "binders" >>= listParser (binderFromJSON modulePath) + isGuarded <- o .: "isGuarded" + if isGuarded + then do + es <- o .: "expressions" >>= listParser parseResultWithGuard + return $ CaseAlternative bs (Left es) + else do + e <- o .: "expression" >>= exprFromJSON modulePath + return $ CaseAlternative bs (Right e) + + parseResultWithGuard :: Value -> Parser (Guard Ann, Expr Ann) + parseResultWithGuard = withObject "parseCaseWithGuards" $ + \o -> do + g <- o .: "guard" >>= exprFromJSON modulePath + e <- o .: "expression" >>= exprFromJSON modulePath + return (g, e) + +binderFromJSON :: FilePath -> Value -> Parser (Binder Ann) +binderFromJSON modulePath = withObject "Binder" binderFromObj + where + binderFromObj o = do + type_ <- o .: "binderType" + case type_ of + "NullBinder" -> nullBinderFromObj o + "VarBinder" -> varBinderFromObj o + "LiteralBinder" -> literalBinderFromObj o + "ConstructorBinder" -> constructorBinderFromObj o + "NamedBinder" -> namedBinderFromObj o + _ -> fail ("not recognized binder: \"" ++ T.unpack type_ ++ "\"") + + + nullBinderFromObj o = do + ann <- o .: "annotation" >>= annFromJSON modulePath + return $ NullBinder ann + + varBinderFromObj o = do + ann <- o .: "annotation" >>= annFromJSON modulePath + idn <- o .: "identifier" >>= identFromJSON + return $ VarBinder ann idn + + literalBinderFromObj o = do + ann <- o .: "annotation" >>= annFromJSON modulePath + lit <- o .: "literal" >>= literalFromJSON (binderFromJSON modulePath) + return $ LiteralBinder ann lit + + constructorBinderFromObj o = do + ann <- o .: "annotation" >>= annFromJSON modulePath + tyn <- o .: "typeName" >>= qualifiedFromJSON ProperName + con <- o .: "constructorName" >>= qualifiedFromJSON ProperName + bs <- o .: "binders" >>= listParser (binderFromJSON modulePath) + return $ ConstructorBinder ann tyn con bs + + namedBinderFromObj o = do + ann <- o .: "annotation" >>= annFromJSON modulePath + n <- o .: "identifier" >>= identFromJSON + b <- o .: "binder" >>= binderFromJSON modulePath + return $ NamedBinder ann n b diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index 56fe0f7aa4..dc81c40aa2 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -10,13 +10,21 @@ import Language.PureScript.Types -- | -- The CoreFn module representation -- -data Module a = Module +-- The json CoreFn representation does not contain type information. When +-- parsing it one gets back `ModuleT () Ann` rathern than `ModuleT Type Ann`, +-- which is enough for `moduleToJs`. +data ModuleT t a = Module { moduleComments :: [Comment] , moduleName :: ModuleName + , modulePath :: FilePath , moduleImports :: [(a, ModuleName)] , moduleExports :: [Ident] - , moduleForeign :: [ForeignDecl] + , moduleForeign :: [ForeignDeclT t] , moduleDecls :: [Bind a] } deriving (Show) -type ForeignDecl = (Ident, Type) +type Module a = ModuleT Type a + +type ForeignDeclT t = (Ident, t) + +type ForeignDecl = ForeignDeclT Type diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index fa84d1bca8..3472f5ea3b 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -7,27 +7,84 @@ module Language.PureScript.CoreFn.ToJSON ( moduleToJSON ) where -import Prelude.Compat +import Prelude.Compat -import Data.Maybe (fromMaybe) -import Data.Aeson -import Data.Version (Version, showVersion) -import Data.Text (Text) +import Control.Arrow ((***)) +import Data.Either (isLeft) +import Data.Maybe (maybe) +import Data.Aeson +import Data.Version (Version, showVersion) +import Data.Text (Text) import qualified Data.Text as T -import Language.PureScript.AST.Literals -import Language.PureScript.CoreFn -import Language.PureScript.Names -import Language.PureScript.PSString (PSString, decodeString) +import Language.PureScript.AST.Literals +import Language.PureScript.AST.SourcePos (SourceSpan(SourceSpan)) +import Language.PureScript.CoreFn +import Language.PureScript.Names +import Language.PureScript.PSString (PSString) + +constructorTypeToJSON :: ConstructorType -> Value +constructorTypeToJSON ProductType = toJSON "ProductType" +constructorTypeToJSON SumType = toJSON "SumType" + +metaToJSON :: Meta -> Value +metaToJSON (IsConstructor t is) + = object + [ T.pack "metaType" .= "IsConstructor" + , T.pack "constructorType" .= constructorTypeToJSON t + , T.pack "identifiers" .= identToJSON `map` is + ] +metaToJSON IsNewtype = object [ T.pack "metaType" .= "IsNewtype" ] +metaToJSON IsTypeClassConstructor = object [ T.pack "metaType" .= "IsTypeClassConstructor" ] +metaToJSON IsForeign = object [ T.pack "metaType" .= "IsForeign" ] + +sourceSpanToJSON :: SourceSpan -> Value +sourceSpanToJSON (SourceSpan _ spanStart spanEnd) = + object [ T.pack "start" .= spanStart + , T.pack "end" .= spanEnd + ] + +annToJSON :: Ann -> Value +annToJSON (ss, _, _, m) = object [ T.pack "sourceSpan" .= sourceSpanToJSON ss + , T.pack "meta" .= maybe Null metaToJSON m + ] literalToJSON :: (a -> Value) -> Literal a -> Value -literalToJSON _ (NumericLiteral (Left n)) = toJSON ("IntLiteral", n) -literalToJSON _ (NumericLiteral (Right n)) = toJSON ("NumberLiteral", n) -literalToJSON _ (StringLiteral s) = toJSON ("StringLiteral", s) -literalToJSON _ (CharLiteral c) = toJSON ("CharLiteral", c) -literalToJSON _ (BooleanLiteral b) = toJSON ("BooleanLiteral", b) -literalToJSON t (ArrayLiteral xs) = toJSON ("ArrayLiteral", map t xs) -literalToJSON t (ObjectLiteral xs) = toJSON ("ObjectLiteral", recordToJSON t xs) +literalToJSON _ (NumericLiteral (Left n)) + = object + [ T.pack "literalType" .= "IntLiteral" + , T.pack "value" .= n + ] +literalToJSON _ (NumericLiteral (Right n)) + = object + [ T.pack "literalType" .= "NumberLiteral" + , T.pack "value" .= n + ] +literalToJSON _ (StringLiteral s) + = object + [ T.pack "literalType" .= "StringLiteral" + , T.pack "value" .= s + ] +literalToJSON _ (CharLiteral c) + = object + [ T.pack "literalType" .= "CharLiteral" + , T.pack "value" .= c + ] +literalToJSON _ (BooleanLiteral b) + = object + [ T.pack "literalType" .= "BooleanLiteral" + , T.pack "value" .= b + ] +literalToJSON t (ArrayLiteral xs) + = object + [ T.pack "literalType" .= "ArrayLiteral" + , T.pack "value" .= map t xs + ] +literalToJSON t (ObjectLiteral xs) + = object + [ T.pack "literalType" .= "ObjectLiteral" + , T.pack "value" .= recordToJSON t xs + ] identToJSON :: Ident -> Value identToJSON = toJSON . runIdent @@ -36,94 +93,135 @@ properNameToJSON :: ProperName a -> Value properNameToJSON = toJSON . runProperName qualifiedToJSON :: (a -> Text) -> Qualified a -> Value -qualifiedToJSON f = toJSON . showQualified f +qualifiedToJSON f (Qualified mn a) = object + [ T.pack "moduleName" .= maybe Null moduleNameToJSON mn + , T.pack "identifier" .= toJSON (f a) + ] moduleNameToJSON :: ModuleName -> Value -moduleNameToJSON = toJSON . runModuleName - -moduleToJSON :: Version -> Module a -> Value -moduleToJSON v m = object [ T.pack "imports" .= map (moduleNameToJSON . snd) (moduleImports m) - , T.pack "exports" .= map identToJSON (moduleExports m) - , T.pack "foreign" .= map (identToJSON . fst) (moduleForeign m) - , T.pack "decls" .= map bindToJSON (moduleDecls m) - , T.pack "builtWith" .= toJSON (showVersion v) - ] - -bindToJSON :: Bind a -> Value -bindToJSON (NonRec _ n e) = object [ runIdent n .= exprToJSON e ] -bindToJSON (Rec bs) = object $ map (\((_, n), e) -> runIdent n .= exprToJSON e) bs - --- If all of the labels in the record can safely be converted to JSON strings, --- we generate a JSON object. Otherwise the labels must be represented as --- arrays of integers in the JSON, and in this case we generate the record as --- an array of pairs. -recordToJSON :: (a -> Value) -> [(PSString, a)] -> Value -recordToJSON f rec = fromMaybe (asArrayOfPairs rec) (asObject rec) +moduleNameToJSON (ModuleName pns) = toJSON $ properNameToJSON `map` pns + +moduleToJSON :: Version -> ModuleT a Ann -> Value +moduleToJSON v m = object + [ T.pack "moduleName" .= moduleNameToJSON (moduleName m) + , T.pack "modulePath" .= toJSON (modulePath m) + , T.pack "imports" .= map importToJSON (moduleImports m) + , T.pack "exports" .= map identToJSON (moduleExports m) + , T.pack "foreign" .= map (identToJSON . fst) (moduleForeign m) + , T.pack "decls" .= map bindToJSON (moduleDecls m) + , T.pack "builtWith" .= toJSON (showVersion v) + , T.pack "comments" .= map toJSON (moduleComments m) + ] + where - asObject = fmap object . traverse (uncurry maybePair) - maybePair label a = fmap (\l -> l .= f a) (decodeString label) - - asArrayOfPairs = toJSON . map (\(label, a) -> (toJSON label, f a)) - -exprToJSON :: Expr a -> Value -exprToJSON (Var _ i) = toJSON ( "Var" - , qualifiedToJSON runIdent i - ) -exprToJSON (Literal _ l) = toJSON ( "Literal" - , literalToJSON (exprToJSON) l - ) -exprToJSON (Constructor _ d c is) = toJSON ( "Constructor" - , properNameToJSON d - , properNameToJSON c - , map identToJSON is - ) -exprToJSON (Accessor _ f r) = toJSON ( "Accessor" - , f - , exprToJSON r - ) -exprToJSON (ObjectUpdate _ r fs) = toJSON ( "ObjectUpdate" - , exprToJSON r - , recordToJSON exprToJSON fs - ) -exprToJSON (Abs _ p b) = toJSON ( "Abs" - , identToJSON p - , exprToJSON b - ) -exprToJSON (App _ f x) = toJSON ( "App" - , exprToJSON f - , exprToJSON x - ) -exprToJSON (Case _ ss cs) = toJSON ( "Case" - , map exprToJSON ss - , map caseAlternativeToJSON cs - ) -exprToJSON (Let _ bs e) = toJSON ( "Let" - , map bindToJSON bs - , exprToJSON e - ) - -caseAlternativeToJSON :: CaseAlternative a -> Value + importToJSON (ann,mn) = object + [ T.pack "annotation" .= annToJSON ann + , T.pack "moduleName" .= moduleNameToJSON mn + ] + +bindToJSON :: Bind Ann -> Value +bindToJSON (NonRec ann n e) + = object + [ T.pack "bindType" .= "NonRec" + , T.pack "annotation" .= annToJSON ann + , T.pack "identifier" .= identToJSON n + , T.pack "expression" .= exprToJSON e + ] +bindToJSON (Rec bs) + = object + [ T.pack "bindType" .= "Rec" + , T.pack "binds" .= map (\((ann, n), e) + -> object + [ T.pack "identifier" .= identToJSON n + , T.pack "annotation" .= annToJSON ann + , T.pack "expression" .= exprToJSON e + ]) bs + ] + +recordToJSON :: (a -> Value) -> [(PSString, a)] -> Value +recordToJSON f = toJSON . map (toJSON *** f) + +exprToJSON :: Expr Ann -> Value +exprToJSON (Var ann i) = object [ T.pack "type" .= toJSON "Var" + , T.pack "annotation" .= annToJSON ann + , T.pack "value" .= qualifiedToJSON runIdent i + ] +exprToJSON (Literal ann l) = object [ T.pack "type" .= "Literal" + , T.pack "annotation" .= annToJSON ann + , T.pack "value" .= literalToJSON exprToJSON l + ] +exprToJSON (Constructor ann d c is) = object [ T.pack "type" .= "Constructor" + , T.pack "annotation" .= annToJSON ann + , T.pack "typeName" .= properNameToJSON d + , T.pack "constructorName" .= properNameToJSON c + , T.pack "fieldNames" .= map identToJSON is + ] +exprToJSON (Accessor ann f r) = object [ T.pack "type" .= "Accessor" + , T.pack "annotation" .= annToJSON ann + , T.pack "fieldName" .= f + , T.pack "expression" .= exprToJSON r + ] +exprToJSON (ObjectUpdate ann r fs) = object [ T.pack "type" .= "ObjectUpdate" + , T.pack "annotation" .= annToJSON ann + , T.pack "expression" .= exprToJSON r + , T.pack "updates" .= recordToJSON exprToJSON fs + ] +exprToJSON (Abs ann p b) = object [ T.pack "type" .= "Abs" + , T.pack "annotation" .= annToJSON ann + , T.pack "argument" .= identToJSON p + , T.pack "body" .= exprToJSON b + ] +exprToJSON (App ann f x) = object [ T.pack "type" .= "App" + , T.pack "annotation" .= annToJSON ann + , T.pack "abstraction" .= exprToJSON f + , T.pack "argument" .= exprToJSON x + ] +exprToJSON (Case ann ss cs) = object [ T.pack "type" .= "Case" + , T.pack "annotation" .= annToJSON ann + , T.pack "caseExpressions" + .= map exprToJSON ss + , T.pack "caseAlternatives" + .= map caseAlternativeToJSON cs + ] +exprToJSON (Let ann bs e) = object [ T.pack "type" .= "Let" + , T.pack "annotation" .= annToJSON ann + , T.pack "binds" .= map bindToJSON bs + , T.pack "expression" .= exprToJSON e + ] + +caseAlternativeToJSON :: CaseAlternative Ann -> Value caseAlternativeToJSON (CaseAlternative bs r') = - toJSON [ toJSON (map binderToJSON bs) - , case r' of - Left rs -> toJSON $ map (\(g, e) -> (exprToJSON g, exprToJSON e)) rs + let isGuarded = isLeft r' + in object + [ T.pack "binders" .= toJSON (map binderToJSON bs) + , T.pack "isGuarded" .= toJSON isGuarded + , T.pack (if isGuarded then "expressions" else "expression") + .= case r' of + Left rs -> toJSON $ map (\(g, e) -> object [ T.pack "guard" .= exprToJSON g, T.pack "expression" .= exprToJSON e]) rs Right r -> exprToJSON r - ] + ] -binderToJSON :: Binder a -> Value -binderToJSON (VarBinder _ v) = toJSON ( "VarBinder" - , identToJSON v - ) -binderToJSON (NullBinder _) = toJSON "NullBinder" -binderToJSON (LiteralBinder _ l) = toJSON ( "LiteralBinder" - , literalToJSON binderToJSON l - ) -binderToJSON (ConstructorBinder _ d c bs) = toJSON ( "ConstructorBinder" - , qualifiedToJSON runProperName d - , qualifiedToJSON runProperName c - , map binderToJSON bs - ) -binderToJSON (NamedBinder _ n b) = toJSON ( "NamedBinder" - , identToJSON n - , binderToJSON b - ) +binderToJSON :: Binder Ann -> Value +binderToJSON (VarBinder ann v) = object [ T.pack "binderType" .= "VarBinder" + , T.pack "annotation" .= annToJSON ann + , T.pack "identifier" .= identToJSON v + ] +binderToJSON (NullBinder ann) = object [ T.pack "binderType" .= "NullBinder" + , T.pack "annotation" .= annToJSON ann + ] +binderToJSON (LiteralBinder ann l) = object [ T.pack "binderType" .= "LiteralBinder" + , T.pack "annotation" .= annToJSON ann + , T.pack "literal" .= literalToJSON binderToJSON l + ] +binderToJSON (ConstructorBinder ann d c bs) = object [ T.pack "binderType" .= "ConstructorBinder" + , T.pack "annotation" .= annToJSON ann + , T.pack "typeName" .= qualifiedToJSON runProperName d + , T.pack "constructorName" + .= qualifiedToJSON runProperName c + , T.pack "binders" .= map binderToJSON bs + ] +binderToJSON (NamedBinder ann n b) = object [ T.pack "binderType" .= "NamedBinder" + , T.pack "annotation" .= annToJSON ann + , T.pack "identifier" .= identToJSON n + , T.pack "binder" .= binderToJSON b + ] diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index e2f9d46ad0..601c953f81 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -35,7 +35,6 @@ import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Trans.Except import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Aeson (encode, decode) -import qualified Data.Aeson as Aeson import Data.Either (partitionEithers) import Data.Function (on) import Data.Foldable (for_) @@ -378,8 +377,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = dumpCoreFn <- lift $ asks optionsDumpCoreFn when dumpCoreFn $ do let coreFnFile = outputDir filePath "corefn.json" - let jsonPayload = CFJ.moduleToJSON Paths.version m - let json = Aeson.object [ (runModuleName mn, jsonPayload) ] + let json = CFJ.moduleToJSON Paths.version m lift $ writeTextFile coreFnFile (encode json) genSourceMap :: String -> String -> Int -> [SMap] -> Make () diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index cb28d1eb29..5d4aba6ee2 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -111,7 +111,7 @@ renameInModules :: [Module Ann] -> [Module Ann] renameInModules = map go where go :: Module Ann -> Module Ann - go m@(Module _ _ _ _ _ decls) = m { moduleDecls = map (renameInDecl' (findDeclIdents decls)) decls } + go m@(Module _ _ _ _ _ _ decls) = m { moduleDecls = map (renameInDecl' (findDeclIdents decls)) decls } renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann renameInDecl' scope = runRename scope . renameInDecl True diff --git a/tests/Main.hs b/tests/Main.hs index 1622bd481d..576b288daf 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -9,6 +9,7 @@ import Prelude () import Prelude.Compat import qualified TestCompiler +import qualified TestCoreFn import qualified TestDocs import qualified TestHierarchy import qualified TestPrimDocs @@ -28,6 +29,8 @@ main = do TestUtils.updateSupportCode heading "Main compiler test suite" TestCompiler.main + heading "CoreFn test suite" + TestCoreFn.main heading "Documentation test suite" TestDocs.main heading "Hierarchy test suite" diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs new file mode 100644 index 0000000000..e8a390b61b --- /dev/null +++ b/tests/TestCoreFn.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module TestCoreFn (main) where + +import Prelude () +import Prelude.Compat + +import Data.Aeson +import Data.Aeson.Types +import Data.Version + +import Language.PureScript.AST.Literals +import Language.PureScript.AST.SourcePos +import Language.PureScript.Comments +import Language.PureScript.CoreFn +import Language.PureScript.CoreFn.FromJSON +import Language.PureScript.CoreFn.ToJSON +import Language.PureScript.Names +import Language.PureScript.Types +import Language.PureScript.PSString + +import Test.Hspec + +main :: IO () +main = hspec spec + +parseModule :: Value -> Result (Version, ModuleT () Ann) +parseModule = parse moduleFromJSON + +-- convert a module to its json CoreFn representation and back +parseMod :: Module Ann -> Result (ModuleT () Ann) +parseMod m = + let v = Version [0] [] + in snd <$> parseModule (moduleToJSON v m) + +isSuccess :: Result a -> Bool +isSuccess (Success _) = True +isSuccess _ = False + +spec :: Spec +spec = context "CoreFnFromJsonTest" $ do + let mn = ModuleName [ProperName "Example", ProperName "Main"] + mp = "src/Example/Main.purs" + ss = SourceSpan mp (SourcePos 0 0) (SourcePos 0 0) + ann = ssAnn ss + + specify "should parse an empty module" $ do + let r = parseMod $ Module [] mn mp [] [] [] [] + r `shouldSatisfy` isSuccess + case r of + Error _ -> return () + Success m -> moduleName m `shouldBe` mn + + specify "should parse module path" $ do + let r = parseMod $ Module [] mn mp [] [] [] [] + r `shouldSatisfy` isSuccess + case r of + Error _ -> return () + Success m -> modulePath m `shouldBe` mp + + specify "should parse imports" $ do + let r = parseMod $ Module [] mn mp [(ann, mn)] [] [] [] + r `shouldSatisfy` isSuccess + case r of + Error _ -> return () + Success m -> moduleImports m `shouldBe` [(ann, mn)] + + specify "should parse exports" $ do + let r = parseMod $ Module [] mn mp [] [Ident "exp"] [] [] + r `shouldSatisfy` isSuccess + case r of + Error _ -> return () + Success m -> moduleExports m `shouldBe` [Ident "exp"] + + specify "should parse foreign" $ do + let r = parseMod $ Module [] mn mp [] [] [(Ident "exp", TUnknown 0)] [] + r `shouldSatisfy` isSuccess + case r of + Error _ -> return () + Success m -> moduleForeign m `shouldBe` [(Ident "exp", ())] + + context "Expr" $ do + specify "should parse literals" $ do + let m = Module [] mn mp [] [] [] + [ NonRec ann (Ident "x1") $ Literal ann (NumericLiteral (Left 1)) + , NonRec ann (Ident "x2") $ Literal ann (NumericLiteral (Right 1.0)) + , NonRec ann (Ident "x3") $ Literal ann (StringLiteral (mkString "abc")) + , NonRec ann (Ident "x4") $ Literal ann (CharLiteral 'c') + , NonRec ann (Ident "x5") $ Literal ann (BooleanLiteral True) + , NonRec ann (Ident "x6") $ Literal ann (ArrayLiteral [Literal ann (CharLiteral 'a')]) + , NonRec ann (Ident "x7") $ Literal ann (ObjectLiteral [(mkString "a", Literal ann (CharLiteral 'a'))]) + ] + parseMod m `shouldSatisfy` isSuccess + + specify "should parse Constructor" $ do + let m = Module [] mn mp [] [] [] + [ NonRec ann (Ident "constructor") $ Constructor ann (ProperName "Either") (ProperName "Left") [Ident "value0"] ] + parseMod m `shouldSatisfy` isSuccess + + specify "should parse Accessor" $ do + let m = Module [] mn mp [] [] [] + [ NonRec ann (Ident "x") $ + Accessor ann (mkString "field") (Literal ann $ ObjectLiteral [(mkString "field", Literal ann (NumericLiteral (Left 1)))]) ] + parseMod m `shouldSatisfy` isSuccess + + specify "should parse ObjectUpdate" $ do + let m = Module [] mn mp [] [] [] + [ NonRec ann (Ident "objectUpdate") $ + ObjectUpdate ann + (Literal ann $ ObjectLiteral [(mkString "field", Literal ann (StringLiteral (mkString "abc")))]) + [(mkString "field", Literal ann (StringLiteral (mkString "xyz")))] + ] + parseMod m `shouldSatisfy` isSuccess + + specify "should parse Abs" $ do + let m = Module [] mn mp [] [] [] + [ NonRec ann (Ident "abs") + $ Abs ann (Ident "x") (Var ann (Qualified (Just mn) (Ident "x"))) + ] + parseMod m `shouldSatisfy` isSuccess + + specify "should parse App" $ do + let m = Module [] mn mp [] [] [] + [ NonRec ann (Ident "app") + $ App ann + (Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "x")))) + (Literal ann (CharLiteral 'c')) + ] + parseMod m `shouldSatisfy` isSuccess + + specify "should parse Case" $ do + let m = Module [] mn mp [] [] [] + [ NonRec ann (Ident "case") $ + Case ann [Var ann (Qualified Nothing (Ident "x"))] + [ CaseAlternative + [ NullBinder ann ] + (Right (Literal ann (CharLiteral 'a'))) + ] + ] + parseMod m `shouldSatisfy` isSuccess + + specify "should parse Case with guards" $ do + let m = Module [] mn mp [] [] [] + [ NonRec ann (Ident "case") $ + Case ann [Var ann (Qualified Nothing (Ident "x"))] + [ CaseAlternative + [ NullBinder ann ] + (Left [(Literal ann (BooleanLiteral True), Literal ann (CharLiteral 'a'))]) + ] + ] + parseMod m `shouldSatisfy` isSuccess + + specify "should parse Let" $ do + let m = Module [] mn mp [] [] [] + [ NonRec ann (Ident "case") $ + Let ann + [ Rec [((ann, Ident "a"), Var ann (Qualified Nothing (Ident "x")))] ] + (Literal ann (BooleanLiteral True)) + ] + parseMod m `shouldSatisfy` isSuccess + + context "Meta" $ do + specify "should parse IsConstructor" $ do + let m = Module [] mn mp [] [] [] + [ NonRec (ss, [], Nothing, Just (IsConstructor ProductType [Ident "x"])) (Ident "x") $ + Literal (ss, [], Nothing, Just (IsConstructor SumType [])) (CharLiteral 'a') + ] + parseMod m `shouldSatisfy` isSuccess + + specify "should parse IsNewtype" $ do + let m = Module [] mn mp [] [] [] + [ NonRec (ss, [], Nothing, Just IsNewtype) (Ident "x") $ + Literal ann (CharLiteral 'a') + ] + parseMod m `shouldSatisfy` isSuccess + + specify "should parse IsTypeClassConstructor" $ do + let m = Module [] mn mp [] [] [] + [ NonRec (ss, [], Nothing, Just IsTypeClassConstructor) (Ident "x") $ + Literal ann (CharLiteral 'a') + ] + parseMod m `shouldSatisfy` isSuccess + + specify "should parse IsForeign" $ do + let m = Module [] mn mp [] [] [] + [ NonRec (ss, [], Nothing, Just IsForeign) (Ident "x") $ + Literal ann (CharLiteral 'a') + ] + parseMod m `shouldSatisfy` isSuccess + + context "Binders" $ do + specify "should parse LiteralBinder" $ do + let m = Module [] mn mp [] [] [] + [ NonRec ann (Ident "case") $ + Case ann [Var ann (Qualified Nothing (Ident "x"))] + [ CaseAlternative + [ LiteralBinder ann (BooleanLiteral True) ] + (Right (Literal ann (CharLiteral 'a'))) + ] + ] + parseMod m `shouldSatisfy` isSuccess + + specify "should parse VarBinder" $ do + let m = Module [] mn mp [] [] [] + [ NonRec ann (Ident "case") $ + Case ann [Var ann (Qualified Nothing (Ident "x"))] + [ CaseAlternative + [ ConstructorBinder + ann + (Qualified (Just (ModuleName [ProperName "Data", ProperName "Either"])) (ProperName "Either")) + (Qualified Nothing (ProperName "Left")) + [VarBinder ann (Ident "z")] + ] + (Right (Literal ann (CharLiteral 'a'))) + ] + ] + parseMod m `shouldSatisfy` isSuccess + + specify "should parse NamedBinder" $ do + let m = Module [] mn mp [] [] [] + [ NonRec ann (Ident "case") $ + Case ann [Var ann (Qualified Nothing (Ident "x"))] + [ CaseAlternative + [ NamedBinder ann (Ident "w") (NamedBinder ann (Ident "w'") (VarBinder ann (Ident "w''"))) ] + (Right (Literal ann (CharLiteral 'a'))) + ] + ] + parseMod m `shouldSatisfy` isSuccess + + context "Comments" $ do + specify "should parse LineComment" $ do + let m = Module [ LineComment "line" ] mn mp [] [] [] [] + parseMod m `shouldSatisfy` isSuccess + + specify "should parse BlockComment" $ do + let m = Module [ BlockComment "block" ] mn mp [] [] [] [] + parseMod m `shouldSatisfy` isSuccess From 1a3ee21c110dd3dce45e7e2a77349141e943e254 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 5 Oct 2017 02:36:12 +0200 Subject: [PATCH 0874/1580] CoreFn Module type (#3101) Remove the type variable. --- src/Language/PureScript/CodeGen/JS.hs | 6 +++--- src/Language/PureScript/CoreFn/Desugar.hs | 4 ++-- src/Language/PureScript/CoreFn/FromJSON.hs | 4 ++-- src/Language/PureScript/CoreFn/Module.hs | 11 ++--------- src/Language/PureScript/CoreFn/ToJSON.hs | 4 ++-- src/Language/PureScript/Make.hs | 2 +- tests/TestCoreFn.hs | 9 ++++----- 7 files changed, 16 insertions(+), 24 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index f90eacff42..39d00ea5dc 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -45,9 +45,9 @@ import System.FilePath.Posix (()) -- | Generate code in the simplified JavaScript intermediate representation for all declarations in a -- module. moduleToJs - :: forall m t + :: forall m . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) - => ModuleT t Ann + => Module Ann -> Maybe AST -> m [AST] moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ = @@ -64,7 +64,7 @@ moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ = let header = if comments && not (null coms) then AST.Comment Nothing coms strict else strict let foreign' = [AST.VariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_] let moduleBody = header : foreign' ++ jsImports ++ concat optimized - let foreignExps = exps `intersect` (fst `map` foreigns) + let foreignExps = exps `intersect` foreigns let standardExps = exps \\ foreignExps let exps' = AST.ObjectLiteral Nothing $ map (mkString . runIdent &&& AST.Var Nothing . identToJs) standardExps ++ map (mkString . runIdent &&& foreignIdent) foreignExps diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 8e820f9084..005bd55562 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -221,8 +221,8 @@ importToCoreFn (A.ImportDeclaration (ss, com) name _ _) = Just ((ss, com, Nothin importToCoreFn _ = Nothing -- | Desugars foreign declarations from AST to CoreFn representation. -externToCoreFn :: A.Declaration -> Maybe ForeignDecl -externToCoreFn (A.ExternDeclaration _ name ty) = Just (name, ty) +externToCoreFn :: A.Declaration -> Maybe Ident +externToCoreFn (A.ExternDeclaration _ name _) = Just name externToCoreFn _ = Nothing -- | Desugars export declarations references from AST to CoreFn representation. diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 5318888cfc..6cb642aca1 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -104,7 +104,7 @@ qualifiedFromJSON f = withObject "Qualified" qualifiedFromObj moduleNameFromJSON :: Value -> Parser ModuleName moduleNameFromJSON v = ModuleName <$> listParser properNameFromJSON v -moduleFromJSON :: Value -> Parser (Version, ModuleT () Ann) +moduleFromJSON :: Value -> Parser (Version, Module Ann) moduleFromJSON = withObject "Module" moduleFromObj where moduleFromObj o = do @@ -114,7 +114,7 @@ moduleFromJSON = withObject "Module" moduleFromObj moduleImports <- o .: "imports" >>= listParser (importFromJSON modulePath) moduleExports <- o .: "exports" >>= listParser identFromJSON moduleDecls <- o .: "decls" >>= listParser (bindFromJSON modulePath) - moduleForeign <- o .: "foreign" >>= listParser (fmap (flip (,) ()) . identFromJSON) + moduleForeign <- o .: "foreign" >>= listParser identFromJSON moduleComments <- o .: "comments" >>= listParser parseJSON return (version, Module {..}) diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index dc81c40aa2..cafa3ef10c 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -5,7 +5,6 @@ import Prelude.Compat import Language.PureScript.Comments import Language.PureScript.CoreFn.Expr import Language.PureScript.Names -import Language.PureScript.Types -- | -- The CoreFn module representation @@ -13,18 +12,12 @@ import Language.PureScript.Types -- The json CoreFn representation does not contain type information. When -- parsing it one gets back `ModuleT () Ann` rathern than `ModuleT Type Ann`, -- which is enough for `moduleToJs`. -data ModuleT t a = Module +data Module a = Module { moduleComments :: [Comment] , moduleName :: ModuleName , modulePath :: FilePath , moduleImports :: [(a, ModuleName)] , moduleExports :: [Ident] - , moduleForeign :: [ForeignDeclT t] + , moduleForeign :: [Ident] , moduleDecls :: [Bind a] } deriving (Show) - -type Module a = ModuleT Type a - -type ForeignDeclT t = (Ident, t) - -type ForeignDecl = ForeignDeclT Type diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 3472f5ea3b..a832c7f3d3 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -101,13 +101,13 @@ qualifiedToJSON f (Qualified mn a) = object moduleNameToJSON :: ModuleName -> Value moduleNameToJSON (ModuleName pns) = toJSON $ properNameToJSON `map` pns -moduleToJSON :: Version -> ModuleT a Ann -> Value +moduleToJSON :: Version -> Module Ann -> Value moduleToJSON v m = object [ T.pack "moduleName" .= moduleNameToJSON (moduleName m) , T.pack "modulePath" .= toJSON (modulePath m) , T.pack "imports" .= map importToJSON (moduleImports m) , T.pack "exports" .= map identToJSON (moduleExports m) - , T.pack "foreign" .= map (identToJSON . fst) (moduleForeign m) + , T.pack "foreign" .= map identToJSON (moduleForeign m) , T.pack "decls" .= map bindToJSON (moduleDecls m) , T.pack "builtWith" .= toJSON (showVersion v) , T.pack "comments" .= map toJSON (moduleComments m) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 601c953f81..3031dc315c 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -435,7 +435,7 @@ checkForeignDecls m path = do errorInvalidForeignIdentifiers (pure . S.fromList) (parseIdents foreignIdentsStrs) - let importedIdents = S.fromList $ map fst (CF.moduleForeign m) + let importedIdents = S.fromList (CF.moduleForeign m) let unusedFFI = foreignIdents S.\\ importedIdents unless (null unusedFFI) $ diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index e8a390b61b..d162afd2dd 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -19,7 +19,6 @@ import Language.PureScript.CoreFn import Language.PureScript.CoreFn.FromJSON import Language.PureScript.CoreFn.ToJSON import Language.PureScript.Names -import Language.PureScript.Types import Language.PureScript.PSString import Test.Hspec @@ -27,11 +26,11 @@ import Test.Hspec main :: IO () main = hspec spec -parseModule :: Value -> Result (Version, ModuleT () Ann) +parseModule :: Value -> Result (Version, Module Ann) parseModule = parse moduleFromJSON -- convert a module to its json CoreFn representation and back -parseMod :: Module Ann -> Result (ModuleT () Ann) +parseMod :: Module Ann -> Result (Module Ann) parseMod m = let v = Version [0] [] in snd <$> parseModule (moduleToJSON v m) @@ -76,11 +75,11 @@ spec = context "CoreFnFromJsonTest" $ do Success m -> moduleExports m `shouldBe` [Ident "exp"] specify "should parse foreign" $ do - let r = parseMod $ Module [] mn mp [] [] [(Ident "exp", TUnknown 0)] [] + let r = parseMod $ Module [] mn mp [] [] [Ident "exp"] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () - Success m -> moduleForeign m `shouldBe` [(Ident "exp", ())] + Success m -> moduleForeign m `shouldBe` [Ident "exp"] context "Expr" $ do specify "should parse literals" $ do From 71fc308a53bf89678c1e1d4a242cc01561d556d1 Mon Sep 17 00:00:00 2001 From: Tom Harding Date: Sun, 8 Oct 2017 21:34:58 +0100 Subject: [PATCH 0875/1580] Add valid location list to orphan instance error (#3106) * Add valid location list to orphan instance error Previously, the orphan instance simply said to consider a newtype. Now, it lists all the places in the project that would be considered valid locations for the instance as well. This hopefully closes #3063. * Updates from review Firstly, there's a little change to the error output in the case of there being no place for the instance except Prim. Previously, it just printed an empty list, which didn't make much sense, gramatically. Now, however, a different error is displayed to point out that there's no reasonable home for the instance. As well as this, the `typeModule` function in `TypeChecker.hs` can now deal with proxy types. Previously, it couldn't, and the tests were passing really due to an accident of laziness. Now, the tests pass, and all is well in the world. * Tidy the orphan instance error further. Thinking about it, you'll only ever see, at most, two things in the list of possible locations. So, we can intercalate the list with `or` and get a much friendlier-looking error. * Adjust wording on error feedback Previously, the error mentioned that the instance "must" be declared in one of a set of places, which @goodacre.liam (rightly) noted would imply that there aren't other, equally valid, solutions. The wording has been altered to address this. --- src/Language/PureScript/AST/Declarations.hs | 3 ++- src/Language/PureScript/Errors.hs | 23 ++++++++++++++------- src/Language/PureScript/TypeChecker.hs | 8 +++++-- 3 files changed, 24 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index a32859f27a..4e8198d613 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -16,6 +16,7 @@ import Control.Monad.Identity import Data.Aeson.TH import qualified Data.Map as M +import Data.Set (Set) import Data.Text (Text) import qualified Data.List.NonEmpty as NEL import GHC.Generics (Generic) @@ -130,7 +131,7 @@ data SimpleErrorMessage | PropertyIsMissing Label | AdditionalProperty Label | TypeSynonymInstance - | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type] + | OrphanInstance Ident (Qualified (ProperName 'ClassName)) (Set ModuleName) [Type] | InvalidNewtype (ProperName 'TypeName) | InvalidInstanceHead Type | TransitiveExportError DeclarationRef [DeclarationRef] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 31c3f748d3..4c7f335708 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -22,6 +22,7 @@ import Data.List (transpose, nubBy, sort, partition, dropWhileEnd) import qualified Data.List.NonEmpty as NEL import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text) import Language.PureScript.AST @@ -274,7 +275,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (InvalidDerivedInstance cl ts n) = InvalidDerivedInstance cl <$> traverse f ts <*> pure n gSimple (ExpectedTypeConstructor cl ts ty) = ExpectedTypeConstructor cl <$> traverse f ts <*> f ty gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k - gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts + gSimple (OrphanInstance nm cl noms ts) = OrphanInstance nm cl noms <$> traverse f ts gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx <*> onTypeSearchTypesM f env gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty @@ -763,16 +764,24 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "Type of expression contains additional label " <> markCode (prettyPrintLabel prop) <> "." renderSimpleErrorMessage TypeSynonymInstance = line "Type class instances for type synonyms are disallowed." - renderSimpleErrorMessage (OrphanInstance nm cnm ts) = - paras [ line $ "Type class instance " <> markCode (showIdent nm) <> " for " + renderSimpleErrorMessage (OrphanInstance nm cnm nonOrphanModules ts) = + paras [ line $ "Orphan instance " <> markCode (showIdent nm) <> " found for " , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm) , Box.vcat Box.left (map typeAtomAsBox ts) ] - , line "is an orphan instance." - , line "An orphan instance is one which is defined in a module that is unrelated to either the class or the collection of data types that the instance is defined for." - , line "Consider moving the instance, if possible, or using a newtype wrapper." - ] + , Box.vcat Box.left $ case modulesToList of + [] -> [ line "There is nowhere this instance can be placed without being an orphan." + , line "A newtype wrapper can be used to avoid this problem." + ] + _ -> [ Box.text $ "This problem can be resolved by declaring the instance in " + <> T.unpack formattedModules + <> ", or by defining the instance on a newtype wrapper." + ] + ] + where + modulesToList = S.toList $ S.delete (moduleNameFromString "Prim") nonOrphanModules + formattedModules = T.intercalate " or " ((markCode . runModuleName) <$> modulesToList) renderSimpleErrorMessage (InvalidNewtype name) = paras [ line $ "Newtype " <> markCode (runProperName name) <> " is invalid." , line "Newtypes must define a single constructor with a single argument." diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 3167f81d87..4e2996537d 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -360,15 +360,19 @@ typeCheckAll moduleName _ = traverse go checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m () checkOrphanInstance dictName className@(Qualified (Just mn') _) typeClass tys' - | moduleName == mn' || moduleName `S.member` nonOrphanModules = return () - | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys' + | moduleName `S.member` nonOrphanModules' = return () + | otherwise = throwError . errorMessage $ OrphanInstance dictName className nonOrphanModules' tys' where + nonOrphanModules' :: S.Set ModuleName + nonOrphanModules' = S.insert mn' nonOrphanModules + typeModule :: Type -> Maybe ModuleName typeModule (TypeVar _) = Nothing typeModule (TypeLevelString _) = Nothing typeModule (TypeConstructor (Qualified (Just mn'') _)) = Just mn'' typeModule (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance" typeModule (TypeApp t1 _) = typeModule t1 + typeModule (ProxyType _) = Nothing typeModule _ = internalError "Invalid type in instance in checkOrphanInstance" modulesByTypeIndex :: M.Map Int (Maybe ModuleName) From a5aad4a0d08d53a468454b1f4a2ef0bd04d6cd24 Mon Sep 17 00:00:00 2001 From: Sergey Homa Date: Thu, 19 Oct 2017 12:33:41 +0300 Subject: [PATCH 0876/1580] Update PROTOCOL.md (#3119) * Update PROTOCOL.md improve `currentModule` description * Update CONTRIBUTORS.md add myself to contributors list --- CONTRIBUTORS.md | 1 + psc-ide/PROTOCOL.md | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 04d36c4b31..644eec55d7 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -114,6 +114,7 @@ If you would prefer to use different terms, please use the section below instead | [@b123400](https://github.com/b123400) | b123400 | [MIT license](https://opensource.org/licenses/MIT) | | [@kcsongor](https://github.com/kcsongor) | Csongor Kiss | [MIT license](http://opensource.org/licenses/MIT) | | [@drets](https://github.com/drets) | Dmytro Rets | [MIT license](http://opensource.org/licenses/MIT) | +| [@bjornmelgaaard](https://github.com/BjornMelgaard) | Sergey Homa | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index fdab0115d6..33e8c2476c 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -72,7 +72,8 @@ The `complete` command looks up possible completions/corrections. If no matcher is given every candidate, that passes the filters, is returned in no particular order. - - `currentModule :: (optional) String`: The current modules name. If it matches + - `currentModule :: (optional) String`: The current modules name. Allows you + to see module-private functions after a successful rebuild. If it matches with the rebuild cache non-exported modules will also be completed. You can fill the rebuild cache by using the "Rebuild" command. From 8c80928136d77b46da463549e44f686af72dc67a Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 20 Oct 2017 00:11:29 +0200 Subject: [PATCH 0877/1580] Adds a (non-completed) document for ide's design. (#3108) * Adds a (non-completed) document for ide's design. I hope this helps potential contributors and people generally interested in the project * some thoughts that need to be added somewhere * thoughts about in-memory state for ide * a collection of thoughts on rebuilding * Why do we pretty print the entire import section? * rename random heading --- psc-ide/DESIGN.org | 279 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 279 insertions(+) create mode 100644 psc-ide/DESIGN.org diff --git a/psc-ide/DESIGN.org b/psc-ide/DESIGN.org new file mode 100644 index 0000000000..00129e6603 --- /dev/null +++ b/psc-ide/DESIGN.org @@ -0,0 +1,279 @@ +* Introduction + This document is meant to outline and explain some of the architecture + decisions for =purs ide=. Read this document, if you plan on contributing to + =purs ide= or are just generally interested in the project. + +* What does `purs ide` do? + The =purs ide= project provides functionality for PureScript tooling and + editors. + - Cross platform + - Distributed and versioned with the compiler + - Reuses types and functionality from the compiler -> up-to-date + - Reduces reimplementation of the same feature for every editor + +* Using `purs ide` as a library from Haskell + =purs ide= is split into a library and an executable. The library code lives + inside =src/Language/PureScript/Ide=. The executable, which is invoked by the + editors is located inside =app/Command/Ide.hs=. + + The =purs ide= library is unopinionated about: + + - Protocol + - Concurrency Model + - Logging + - File watchers + + And so other executables, like an implementation of the Language Server + Protocol, are supported by this model and can be added in the future. + + The main entry point into the library is the =handleCommand= function inside + the =PureScript.Language.Ide= module. +** handleCommand + + Break down the type signature: + + =handleCommand :: (Ide m, MonadLogger m, MonadError IdeError m) => Command -> m Success= + + Ide m expands to (MonadReader IdeEnvironment m, MonadIO m) and so we end up + with 4 constraints/capabilities handleCommand needs to be provided with by + the caller. + + - MonadIO + + handleCommand needs access to IO + + - MonadError IdeError + + Errors can occur during the evaluation of a Command, and the executable + gets to decide how to handle them. + + - MonadLogger + + purs ide uses the =MonadLogger= constraint to defer the choice of logging + to the exeutable. This constraint can be fulfilled with a console based + logger, a file-based one or the log messages can just be discarded (helpful + during testing) + + - MonadReader IdeEnvironment + + The IdeEnvironment holds some configuration type, but crucially it also + contains a TVar (thread variable), which contains all of purs ide's state. + We're using a threadvariable over a =MonadState= constraint here, so it's + easier to evaluate concurrent or asynchronous evaluation of commands. + +** Ide's State type + Ide's State is split into =IdeFileState= and =IdeVolatileState=. + +*** =IdeFileState= + The file state holds externs files and parsed module ASTs and thus directly + corresponds to entities on the file system. This part of the state can be + changed per module (eg. by a filewatcher). + +*** =IdeVolatileState= + The volatile state contains all the derived data, like the declarations we + use to provide autocompletion. The data is denormalized and optimized for + reading/querying, but is harder to invalidate and thus needs to be updated + more coarsely whenever something in FileState changes. Right now we + completely recompute it on every change because it's still very fast. In the + future we might need to be cleverer as the information we collect gets more + sophisticated and more expensive to compute. + +** How to invoke =handleCommand= in an executable + Relevant files: tests/Language/PureScript/Ide/Test.hs app/Commands/Ide.hs + + Running =handleCommand= requires that we satisfy all the constraints placed + on it. It's easiest to just show how to write a function that accepts a + single command and runs it against an empty =IdeState=. We'll also retrieve + the resulting state and any errors that ocurred. + + #+BEGIN_SRC haskell + runIdeCommand :: Command -> IO (Either IdeError Success, IdeState) + runIdeCommand command = do + -- First we'll create a TVar of an empty IdeState. + stateVar <- newTVarIO emptyIdeState + -- We create a new IdeEnvironment using the default IdeConfig and our state + -- variable + let environment = IdeEnvironment {ideStateVar = stateVar, ideConfiguration = defConfig} + -- It's easiest to read the next line inside out: + + -- 1. apply =handleCommand= to the command + + -- 2. Satisfy the MonadReader IdeEnvironment constraint by passing + -- =environment= to =runReaderT= + + -- 3. Turn any thrown Errors into an Either IdeError with =runExceptT= + + -- 4. Finally, discard any log messages with =runNoLoggingT=. + + -- (5. The MonadIO constraint is satisfied by choosing IO as the underlying + -- Monad) + result <- runNoLoggingT (runExceptT (runReaderT (handleCommand command) environment)) + + -- We read the resulting IdeState from the state variable + newState <- readTVarIO stateVar + -- Return the command result, as well as the resulting state + pure (result, newState) + #+END_SRC + +** Concurrency model is up to the caller of handleCommand + + By using a =TVar= instead of a MonadState constraint =ide='s design allows to + run multiple invocations of =handleCommand= in parallel. By using =STM=, + =ide= makes sure to not run into deadlocks or data races. + + However the current implementation of =purs ide server= runs all the commands + sequentially, because the commmands run fast enough at this point, and a + users interaction with his editor are mostly sequential anyway. +* Commands + The three most involved commands are completion, adding imports and rebuilding. + + - Completions are found by composing filters and matchers, a `purs ide` DSL + - Adding imports involves file manipulation, some custom parsing and surprisingly complex logic + - Rebuilding involves calling compiler APIs +** Completions + Important files: Ide.Filter Ide.Matcher Ide.Completion + + The =completion= command filters all of the stored =IdeDeclarations= inside + =ide='s volatile state through a list of =Filters= as well as an optional + =Matcher=. Completion options can be specified to apply further + post-processing (choosing the maximum number of results, how to group + reexports of the same value) + + Afterwards they are turned into a stripped down =Completions= + format, which contains information that can be easily consumed by editor + plugins. + +*** The Query Pipeline + + When fulfilling completion requests or other queries, `ide` runs the stored + declarations through the following pipeline: + + =Declarations |> Filters |> Matcher |> CompletionOptions |> Completions= + + First we apply the filters, which either keep a declaration or drop it. Then + we apply Matchers, which can also drop declarations, but assign a score to + the declarations, which determines their ordering. We use this to sort + declarations in terms of how far the edit distance between them and a query + string is, or how many characters we needed to skip for a flex match. + + TODO: links for levenshtein and flex match + + Finally we apply the completion options, which apply certain a certain + formatting, limit the number of results or apply grouping operations. + + All the different filters, matchers and completion options are documented in + the PROTOCOL.md file. + +*** Filters + Filters are functions of type =Map ModuleName [IdeDeclaration] -> Map + ModuleName [IdeDeclaration]=. We keep the =Map= structure around to make the + common case of filtering by module names fast. + +*** Matchers + Matchers operate on individual declarations rather than a =Map=. They also + assign a score to every result, which is a simple Double. +** Adding Imports + Important Files: Ide.Imports +*** We pretty print the entire import section on every import command instead of patching the existing section +**** Pros +- Small diffs if you use =ide= all the time +- Uniform formatting +- Simplifies the implementation +**** Cons +- Big diff on first use +- Makes it hard to maintain comments in between imports, so we just remove them + +*** Formatting Rules for imports +1. Unqualified imports +2. Space divider +3. All the other imports in alphabetic ordering + +**** Pro +- Easy enough to achieve without using =ide= by just sorting the imports linewise +**** Cons +- Can lead to very long import lines +** Rebuilding + Important Files: Ide.Rebuild + +*** The rebuild command acts on a single file input +Unlike the compiler which gets paths to all the modules in our program, the +Rebuild command only gets handed the path to a single module. + +*** IDE's rebuilds are fast +There are two reasons why ide's rebuilds are an order of magnitude faster than +the compilers incremental builds. +**** Rebuild ONLY respects downstream modules +**** All the externs data is already held in RAM +*** Steps rebuilding takes +**** Parse input model +**** Check if FFI file exists and also load that +**** Grab the Externsfiles out of IDE's state +**** Delete the Externsfile corresponding to the module to be rebuilt +**** Convert all the externs files into "shallow modules" which only hold their dependency information +**** Run the compilers topo-sort to figure out all the transitive dependencies of the module we just parsed +**** Rebuild the Environment against the set of externs files we just figured out +*** Extra Rebuild with open imports (only when the first Rebuild succeeds) +This is so that we can mitigate the fact that Externsfiles only give us access +to exported declarations. We rebuild the file a second time, but this time we +remove all the export restrictions before doing so, and store the resulting +Externsfile inside IDE's cache. It's important! that we do not write this file +to disc, because it's incorrect when used by a normal compile or rebuild. +**** The caller gets to decide how the extra Rebuild is run +The primary motivation for this is that we don't need the second build to run to +detect all the compiler errors, so in the usual mode of operation we want to run +it asynchronously and just return the errors/warnings to the editors +immediately. In a test setting however, we might want to test that the rebuild +cache was filled properly and serves completions for private members. (Examples: +Language.PureScript.Ide.RebuildSpec) +** Everything else +* Tips and Tricks +** Running only =ide='s test suite + ~stack test --test-arguments "-m Language.PureScript.Ide"~ +* Facts and thoughts without a good place yet +** Using externs files as source of truth +*** Pros +- Everything has types, because it went through the compiler +- Module visibility is respected, because everything went through the compiler +- Works even when the source file has syntax errors/doesn't compile +- Easy plug-and-play, people rarely change the `output/` directory (as + opposed to the file structure) +- Decoding JSON is fast! (As opposed to parsing source code) +*** Cons +- All type synonyms are expanded (Just something the compiler does) +- Means non-exported values are unaccessible (They should be in scope while + editing the corresponding module though) +- Can serve stale declaration information, eg. a declaration might've been + removed from a module, but the module doesn't compile yet, so the externs + hasn't been overridden and we still suggest the declaration +- Can serve stale module information, when a source file gets deleted, the + corresponding externs file does not. Which means we can't detect whether a + module still exists. +- No source positions or docstrings +** When source globs are added +*** New features enabled +- Enables go-to-definition by allowing us to grab source spans for declarations +- Enables us to recover type signatures without synonyms expanded +- Enables us to grab docstrings (We don't do that yet, unfortunately) +*** Cons +- Slower startup (Actually the load command takes longer, but because the server + is useless until load has been run I count that as startup). Startup on + slamdata is at around 5-6seconds. +- Higher memory footprint. We hold the ASTs for all the modules and add + additional information to the declarations TODO: quantify this for slamdata +- It's harder to watch source files for changes, because they aren't collected + in a single directory (which is why we don't do it) +** PureScript's package story involves downloading all the source +- Great for us, because we get go-to-definition and docstrings without having to + query some external resource +** Keeping everything in memory +*** Pros +- All data is regenerated on starting ide = no cache invalidation necessary +- Things are fast, without any effort spent on optimizing things +- Simple model, keeps complexity low +- We don't polute projects with ide artifacts +*** Cons +- Imposes a limit on how big of a project we can handle +- Means we need to be careful about what information we denormalize, since it + can blow up on us +- All data is regenerated on starting ide = slower startup than (maybe?) necessary +- Impossible to share information between projects (for shared dependencies) From 32809237d213ea3f65767b2b273e03606c67ef7e Mon Sep 17 00:00:00 2001 From: b123400 Date: Sun, 22 Oct 2017 04:36:03 +0800 Subject: [PATCH 0878/1580] Add position to type class declaration error (#3109) --- src/Language/PureScript/TypeChecker.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 4e2996537d..b141651ef3 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -316,9 +316,10 @@ typeCheckAll moduleName _ = traverse go return d go d@FixityDeclaration{} = return d go d@ImportDeclaration{} = return d - go d@(TypeClassDeclaration _ pn args implies deps tys) = do - addTypeClass moduleName pn args implies deps tys - return d + go d@(TypeClassDeclaration (ss, _) pn args implies deps tys) = do + warnAndRethrow (addHint (ErrorInTypeClassDeclaration pn) . addHint (PositionedError ss)) $ do + addTypeClass moduleName pn args implies deps tys + return d go (d@(TypeInstanceDeclaration (ss, _) ch idx dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys) . addHint (PositionedError ss)) $ do env <- getEnv From c9b58e18c7ef9b1405bc9cbaadf2bc217fb4b2fa Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sat, 21 Oct 2017 23:57:51 +0100 Subject: [PATCH 0879/1580] Error on duplicate type class or instance declarations (#3126) --- examples/failing/DuplicateInstance.purs | 6 ++++++ examples/failing/DuplicateTypeClass.purs | 4 ++++ src/Language/PureScript/AST/Declarations.hs | 2 ++ src/Language/PureScript/Errors.hs | 10 ++++++++++ src/Language/PureScript/TypeChecker.hs | 19 +++++++++++++------ 5 files changed, 35 insertions(+), 6 deletions(-) create mode 100644 examples/failing/DuplicateInstance.purs create mode 100644 examples/failing/DuplicateTypeClass.purs diff --git a/examples/failing/DuplicateInstance.purs b/examples/failing/DuplicateInstance.purs new file mode 100644 index 0000000000..bb3c13e20f --- /dev/null +++ b/examples/failing/DuplicateInstance.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DuplicateInstance +module Main where +class X +class Y +instance i :: X +instance i :: Y diff --git a/examples/failing/DuplicateTypeClass.purs b/examples/failing/DuplicateTypeClass.purs new file mode 100644 index 0000000000..969c3e3c17 --- /dev/null +++ b/examples/failing/DuplicateTypeClass.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith DuplicateTypeClass +module Main where +class C +class C diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 4e8198d613..0d760ab7df 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -94,6 +94,8 @@ data SimpleErrorMessage | DeclConflict Name Name | ExportConflict (Qualified Name) (Qualified Name) | DuplicateModule ModuleName [SourceSpan] + | DuplicateTypeClass (ProperName 'ClassName) SourceSpan + | DuplicateInstance Ident SourceSpan | DuplicateTypeArgument Text | InvalidDoBind | InvalidDoLet diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 4c7f335708..d260836946 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -103,6 +103,8 @@ errorCode em = case unwrapErrorMessage em of DeclConflict{} -> "DeclConflict" ExportConflict{} -> "ExportConflict" DuplicateModule{} -> "DuplicateModule" + DuplicateTypeClass{} -> "DuplicateTypeClass" + DuplicateInstance{} -> "DuplicateInstance" DuplicateTypeArgument{} -> "DuplicateTypeArgument" InvalidDoBind -> "InvalidDoBind" InvalidDoLet -> "InvalidDoLet" @@ -536,6 +538,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line ("Module " <> markCode (runModuleName mn) <> " has been defined multiple times:") , indent . paras $ map (line . displaySourceSpan relPath) ss ] + renderSimpleErrorMessage (DuplicateTypeClass pn ss) = + paras [ line ("Type class " <> markCode (runProperName pn) <> " has been defined multiple times:") + , indent $ line $ displaySourceSpan relPath ss + ] + renderSimpleErrorMessage (DuplicateInstance pn ss) = + paras [ line ("Instance " <> markCode (showIdent pn) <> " has been defined multiple times:") + , indent $ line $ displaySourceSpan relPath ss + ] renderSimpleErrorMessage (CycleInDeclaration nm) = line $ "The value of " <> markCode (showIdent nm) <> " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index b141651ef3..2d52d9a842 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -116,17 +116,16 @@ addValue moduleName name ty nameKind = do addTypeClass :: forall m . (MonadState CheckState m, MonadError MultipleErrors m) - => ModuleName - -> ProperName 'ClassName + => Qualified (ProperName 'ClassName) -> [(Text, Maybe Kind)] -> [Constraint] -> [FunctionalDependency] -> [Declaration] -> m () -addTypeClass moduleName pn args implies dependencies ds = do +addTypeClass qualifiedClassName args implies dependencies ds = do env <- getEnv traverse_ (checkMemberIsUsable (typeSynonyms env)) classMembers - modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) newClass (typeClasses . checkEnv $ st) } } + modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert qualifiedClassName newClass (typeClasses . checkEnv $ st) } } where classMembers :: [(Ident, Type)] classMembers = map toPair ds @@ -318,11 +317,19 @@ typeCheckAll moduleName _ = traverse go go d@ImportDeclaration{} = return d go d@(TypeClassDeclaration (ss, _) pn args implies deps tys) = do warnAndRethrow (addHint (ErrorInTypeClassDeclaration pn) . addHint (PositionedError ss)) $ do - addTypeClass moduleName pn args implies deps tys + env <- getEnv + let qualifiedClassName = Qualified (Just moduleName) pn + guardWith (errorMessage (DuplicateTypeClass pn ss)) $ + not (M.member qualifiedClassName (typeClasses env)) + addTypeClass qualifiedClassName args implies deps tys return d go (d@(TypeInstanceDeclaration (ss, _) ch idx dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys) . addHint (PositionedError ss)) $ do env <- getEnv + let qualifiedDictName = Qualified (Just moduleName) dictName + flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries -> + guardWith (errorMessage (DuplicateInstance dictName ss)) $ + not (M.member qualifiedDictName dictionaries) case M.lookup className (typeClasses env) of Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" Just typeClass -> do @@ -331,7 +338,7 @@ typeCheckAll moduleName _ = traverse go checkOrphanInstance dictName className typeClass tys _ <- traverseTypeInstanceBody checkInstanceMembers body deps' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps - let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) <$> ch) idx (Qualified (Just moduleName) dictName) [] className tys (Just deps') + let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) <$> ch) idx qualifiedDictName [] className tys (Just deps') addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict return d From c68befe2ccac0bbb75178fb9ec2b8de1832be219 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sun, 22 Oct 2017 00:01:06 +0100 Subject: [PATCH 0880/1580] Fix entailment issues with skolems and matches (#3121) When verifying a substitution, if we see a skolem (that hasn't been matched with itself) then it is unknown whether or not we might have a match or be apart. Combining a match with an unknown should be an unknown not a match. I.e: knowing that one of two things match doesn't make the other one now a match. Added failing examples to catch these cases. --- .../InstanceChainBothUnknownAndMatch.purs | 14 ++++ .../InstanceChainSkolemUnknownMatch.purs | 12 ++++ .../PureScript/TypeChecker/Entailment.hs | 70 ++++++++++--------- 3 files changed, 64 insertions(+), 32 deletions(-) create mode 100644 examples/failing/InstanceChainBothUnknownAndMatch.purs create mode 100644 examples/failing/InstanceChainSkolemUnknownMatch.purs diff --git a/examples/failing/InstanceChainBothUnknownAndMatch.purs b/examples/failing/InstanceChainBothUnknownAndMatch.purs new file mode 100644 index 0000000000..6713d93f02 --- /dev/null +++ b/examples/failing/InstanceChainBothUnknownAndMatch.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith NoInstanceFound +module InstanceChains.BothUnknownAndMatch where + +class Same l r o | l r -> o +instance sameY :: Same t t @"Y" else instance sameN :: Same l r @"N" +same :: forall l r o. Same l r o => l -> r -> @o +same _ _ = @o + +-- for label `u`, `t ~ Int` should be Unknown +-- for label `m`, `Int ~ Int` should be a match +-- together they should be Unknown +example :: forall t. @t -> @_ +example _ = same @(u :: t, m :: Int) @(u :: Int, m :: Int) + diff --git a/examples/failing/InstanceChainSkolemUnknownMatch.purs b/examples/failing/InstanceChainSkolemUnknownMatch.purs new file mode 100644 index 0000000000..e7dc90d334 --- /dev/null +++ b/examples/failing/InstanceChainSkolemUnknownMatch.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith NoInstanceFound +module InstanceChainSkolemUnknownMatch where + +class Same l r o | l r -> o +instance sameY :: Same t t @"Y" else instance sameN :: Same l r @"N" +same :: forall l r o. Same l r o => l -> r -> @o +same _ _ = @o + +-- shouldn't discard sameY as Apart +example :: forall t. @t -> @_ +example _ = same @t @Int + diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 740beb2714..f87c548f48 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -138,13 +138,15 @@ data Matched t = Match t | Apart | Unknown - deriving (Eq, Show) + deriving (Eq, Show, Functor) -bothMatched :: Matched () -> Matched () -> Matched () -bothMatched (Match _) (Match _) = Match () -bothMatched Unknown r = r -bothMatched l Unknown = l -bothMatched _ _ = Apart +instance Monoid t => Monoid (Matched t) where + mempty = Match mempty + + mappend (Match l) (Match r) = Match (l <> r) + mappend Apart _ = Apart + mappend _ Apart = Apart + mappend _ _ = Unknown -- | Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. @@ -457,7 +459,7 @@ matches deps TypeClassDictionaryInScope{..} tys = else -- Verify that any repeated type variables are unifiable let determinedSet = foldMap (S.fromList . fdDetermined) deps solved = map snd . filter ((`S.notMember` determinedSet) . fst) $ zipWith (\(_, ts) i -> (i, ts)) matched [0..] - in maybe Apart Match $ verifySubstitution (M.unionsWith (++) solved) + in verifySubstitution (M.unionsWith (++) solved) where -- | Find the closure of a set of functional dependencies. covers :: [(Matched (), subst)] -> Bool @@ -518,42 +520,46 @@ matches deps TypeClassDictionaryInScope{..} tys = typeHeadsAreEqual (TUnknown _) _ = (Unknown, M.empty) typeHeadsAreEqual _ _ = (Apart, M.empty) + both :: (Matched (), Matching [Type]) -> (Matched (), Matching [Type]) -> (Matched (), Matching [Type]) - both (b1, m1) (b2, m2) = (bothMatched b1 b2, M.unionWith (++) m1 m2) + both (b1, m1) (b2, m2) = (b1 <> b2, M.unionWith (++) m1 m2) -- Ensure that a substitution is valid - verifySubstitution :: Matching [Type] -> Maybe (Matching [Type]) - verifySubstitution = traverse meet where - meet ts | pairwiseAll typesAreEqual ts = Just ts - | otherwise = Nothing + verifySubstitution :: Matching [Type] -> Matched (Matching [Type]) + verifySubstitution mts = foldMap meet mts $> mts where + meet = pairwiseAll typesAreEqual -- Note that unknowns are only allowed to unify if they came from a type -- which was _not_ solved, i.e. one which was inferred by a functional -- dependency. - typesAreEqual :: Type -> Type -> Bool + typesAreEqual :: Type -> Type -> Matched () typesAreEqual (KindedType t1 _) t2 = typesAreEqual t1 t2 typesAreEqual t1 (KindedType t2 _) = typesAreEqual t1 t2 - typesAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = True - typesAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2 - typesAreEqual (TypeVar v1) (TypeVar v2) = v1 == v2 - typesAreEqual (TypeLevelString s1) (TypeLevelString s2) = s1 == s2 - typesAreEqual (TypeConstructor c1) (TypeConstructor c2) = c1 == c2 - typesAreEqual (TypeApp h1 t1) (TypeApp h2 t2) = typesAreEqual h1 h2 && typesAreEqual t1 t2 + typesAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = Match () + typesAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Match () + typesAreEqual (Skolem _ _ _ _) _ = Unknown + typesAreEqual _ (Skolem _ _ _ _) = Unknown + typesAreEqual (TypeVar v1) (TypeVar v2) | v1 == v2 = Match () + typesAreEqual (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = Match () + typesAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Match () + typesAreEqual (TypeApp h1 t1) (TypeApp h2 t2) = typesAreEqual h1 h2 <> typesAreEqual t1 t2 typesAreEqual (ProxyType t1) (ProxyType t2) = typesAreEqual t1 t2 - typesAreEqual REmpty REmpty = True + typesAreEqual REmpty REmpty = Match () typesAreEqual r1 r2 | isRCons r1 || isRCons r2 = let (common, rest) = alignRowsWith typesAreEqual r1 r2 - in and common && uncurry go rest + in fold common <> uncurry go rest where - go :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> Bool + go :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> Matched () go (l, KindedType t1 _) (r, t2) = go (l, t1) (r, t2) go (l, t1) (r, KindedType t2 _) = go (l, t1) (r, t2) - go ([], TUnknown u1) ([], TUnknown u2) | u1 == u2 = True - go ([], Skolem _ s1 _ _) ([], Skolem _ s2 _ _) = s1 == s2 - go ([], REmpty) ([], REmpty) = True - go ([], TypeVar v1) ([], TypeVar v2) = v1 == v2 - go _ _ = False - typesAreEqual _ _ = False + go ([], TUnknown u1) ([], TUnknown u2) | u1 == u2 = Match () + go ([], Skolem _ s1 _ _) ([], Skolem _ s2 _ _) | s1 == s2 = Match () + go ([], Skolem _ _ _ _) _ = Unknown + go _ ([], Skolem _ _ _ _) = Unknown + go ([], REmpty) ([], REmpty) = Match () + go ([], TypeVar v1) ([], TypeVar v2) | v1 == v2 = Match () + go _ _ = Apart + typesAreEqual _ _ = Apart isRCons :: Type -> Bool isRCons RCons{} = True @@ -585,10 +591,10 @@ mkContext = foldr combineContexts M.empty . map fromDict where fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdValue d) d)) -- | Check all pairs of values in a list match a predicate -pairwiseAll :: (a -> a -> Bool) -> [a] -> Bool -pairwiseAll _ [] = True -pairwiseAll _ [_] = True -pairwiseAll p (x : xs) = all (p x) xs && pairwiseAll p xs +pairwiseAll :: Monoid m => (a -> a -> m) -> [a] -> m +pairwiseAll _ [] = mempty +pairwiseAll _ [_] = mempty +pairwiseAll p (x : xs) = foldMap (p x) xs <> pairwiseAll p xs -- | Check any pair of values in a list match a predicate pairwiseAny :: (a -> a -> Bool) -> [a] -> Bool From cfd1db3ab9eb8f8af400ffc5812af13d4cad9302 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sun, 22 Oct 2017 01:57:05 +0100 Subject: [PATCH 0881/1580] Print proxy type as an operator (#3124) --- src/Language/PureScript/Pretty/Types.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index d24c9a3ae5..ad8ee7763d 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -74,6 +74,15 @@ prettyPrintRowWith tro open close = uncurry listToBox . toList [] prettyPrintRow :: Type -> String prettyPrintRow = render . prettyPrintRowWith defaultOptions '(' ')' +-- Treat `ProxyType t` in a similar way to the application of a type +-- constructor `@` to `t`, i.e: `@ t`, except that we don't render the unneeded +-- space. So we end up with `@t`. +proxyType :: Pattern () Type (Type, Type) +proxyType = mkPattern match + where + match (ProxyType t) = Just (TypeConstructor (Qualified Nothing (ProperName "@")), t) + match _ = Nothing + typeApp :: Pattern () Type (Type, Type) typeApp = mkPattern match where @@ -135,7 +144,6 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} = | otherwise = Just $ text $ T.unpack name ++ show s match REmpty = Just $ text "()" match row@RCons{} = Just $ prettyPrintRowWith tro '(' ')' row - match (ProxyType t) = Just $ text "@" <> typeAtomAsBox t match (BinaryNoParensType op l r) = Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r match (TypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op @@ -145,7 +153,8 @@ matchType :: TypeRenderOptions -> Pattern () Type Box matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where operators :: OperatorTable () Type Box operators = - OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ] + OperatorTable [ [ AssocL proxyType $ \p ty -> p <> ty ] + , [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ] , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text rightArrow <> " " <> ret) ] , [ Wrap constrained $ \deps ty -> constraintsAsBox tro deps ty ] , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text (forall' ++ " " ++ unwords idents ++ ".")) ty ] From 38a9177752cfe6dccd24380bc0d22c809cbdfcbe Mon Sep 17 00:00:00 2001 From: Nicholas Scheel Date: Mon, 23 Oct 2017 12:54:41 -0500 Subject: [PATCH 0882/1580] Desugar nested parentheses (#3086) This caused an issue in inferring kinds (Invalid argument ...) then in unifying types (Could not match type Unit with Unit), but desugaring it earlier fixes both of those problems. --- examples/passing/ParensInType.purs | 20 ++++++++++++++++++++ src/Language/PureScript/Sugar/Operators.hs | 6 +++--- 2 files changed, 23 insertions(+), 3 deletions(-) create mode 100644 examples/passing/ParensInType.purs diff --git a/examples/passing/ParensInType.purs b/examples/passing/ParensInType.purs new file mode 100644 index 0000000000..75d0120996 --- /dev/null +++ b/examples/passing/ParensInType.purs @@ -0,0 +1,20 @@ +module Main where + +import Prelude +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) + +class Foo a where + foo :: forall eff. (String -> a (( console :: CONSOLE | eff)) ((Unit))) + +instance fooLogEff :: Foo Eff where + foo = log + +main :: + forall eff. + Eff + ( console :: CONSOLE + | eff + ) + Unit +main = foo "Done" diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 8687636e49..43ef78cded 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -230,15 +230,15 @@ removeParens = f (goDecl, goExpr', goBinder') = updateTypes (\_ -> return . goType) goExpr :: Expr -> Expr - goExpr (Parens val) = val + goExpr (Parens val) = goExpr val goExpr val = val goBinder :: Binder -> Binder - goBinder (ParensInBinder b) = b + goBinder (ParensInBinder b) = goBinder b goBinder b = b goType :: Type -> Type - goType (ParensInType t) = t + goType (ParensInType t) = goType t goType t = t decontextify From ac18e538e833e25e7a87fa6d709c790db9b9802b Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sat, 28 Oct 2017 11:41:53 +0100 Subject: [PATCH 0883/1580] Fix #3131 Ide inserts conflicting imports for types (#3139) --- src/Language/PureScript/Ide/Imports.hs | 5 +++++ tests/Language/PureScript/Ide/ImportsSpec.hs | 16 ++++++++++++++++ 2 files changed, 21 insertions(+) diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 251864909d..82ec75c08b 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -220,6 +220,11 @@ addExplicitImport' decl moduleName qualifier imports = (insertDtor (dtor ^. ideDtorName)) (refFromDeclaration d) refs + insertDeclIntoRefs (IdeDeclType t) refs + | any matches refs = refs + where + matches (P.TypeRef _ typeName _) = _ideTypeName t == typeName + matches _ = False insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) insertDtor _ (P.TypeRef ss tn' _) = P.TypeRef ss tn' Nothing diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 71a883cde1..b7c81966da 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -252,6 +252,22 @@ spec = do , "" , "import Data.Maybe (Maybe(..))" ] + it "adding a type to an existing import of that type is noop" $ do + let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"]) + shouldBe + (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") Nothing typeImports) + [ "import Prelude" + , "" + , "import Data.Maybe (Maybe)" + ] + it "adding a type to an existing import of that type with its constructors is noop" $ do + let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe (..))"]) + shouldBe + (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") Nothing typeImports) + [ "import Prelude" + , "" + , "import Data.Maybe (Maybe(..))" + ] it "adds a dataconstructor to an existing qualified type import" $ do let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe) as M"]) shouldBe From c507005489627d1bc521471b7a93550a66233cc0 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sat, 28 Oct 2017 21:45:20 +0100 Subject: [PATCH 0884/1580] Instantiate abstraction body during inference (#3128) --- examples/passing/3125.purs | 16 ++++++++++++++++ src/Language/PureScript/TypeChecker/Types.hs | 3 ++- 2 files changed, 18 insertions(+), 1 deletion(-) create mode 100644 examples/passing/3125.purs diff --git a/examples/passing/3125.purs b/examples/passing/3125.purs new file mode 100644 index 0000000000..d427fd46bb --- /dev/null +++ b/examples/passing/3125.purs @@ -0,0 +1,16 @@ +module Main where + +import Prelude +import Data.Monoid (class Monoid, mempty) +import Control.Monad.Eff.Console (log, logShow) + +data B a = B a a + +memptyB :: forall a b. Monoid b => B (a -> b) +memptyB = B l r where + l _ = mempty + r _ = mempty + +main = do + logShow $ case (memptyB :: B (Int -> Array Unit)) of B l r -> l 0 == r 0 + log "Done" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index e3bb2d442b..8e7adf80d8 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -357,7 +357,8 @@ infer' (Abs binder ret) ty <- freshType withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do body@(TypedValue _ _ bodyTy) <- infer' ret - return $ TypedValue True (Abs (VarBinder arg) body) $ function ty bodyTy + (body', bodyTy') <- instantiatePolyTypeWithUnknowns body bodyTy + return $ TypedValue True (Abs (VarBinder arg) body') (function ty bodyTy') | otherwise = internalError "Binder was not desugared" infer' (App f arg) = do f'@(TypedValue _ _ ft) <- infer f From 3541dd2e9d0572b7e914884ddd7e1e34ec65ca3c Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Mon, 30 Oct 2017 09:13:00 +0000 Subject: [PATCH 0885/1580] [purs ide] return documentation comments (#3138) --- .../PureScript/Docs/Convert/Single.hs | 1 + src/Language/PureScript/Ide/Completion.hs | 2 +- src/Language/PureScript/Ide/State.hs | 85 +++++++++++++++---- src/Language/PureScript/Ide/Types.hs | 3 +- .../Language/PureScript/Ide/CompletionSpec.hs | 34 +++++++- .../pscide/src/CompletionSpecDocs.purs | 13 +++ 6 files changed, 118 insertions(+), 20 deletions(-) create mode 100644 tests/support/pscide/src/CompletionSpecDocs.purs diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 98c8c90cca..deaccf2db5 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -1,5 +1,6 @@ module Language.PureScript.Docs.Convert.Single ( convertSingleModule + , convertComments ) where import Protolude hiding (moduleName) diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index b4e9f2ed66..eace77b3fa 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -130,7 +130,7 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl), mns) = complLocation = _annLocation ann - complDocumentation = Nothing + complDocumentation = _annDocumentation ann showFixity p a r o = let asso = case a of diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index f7d7a57a6c..28211f9423 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -44,6 +44,7 @@ import Control.Lens hiding (op, (&)) import "monad-logger" Control.Monad.Logger import qualified Data.Map.Lazy as Map import qualified Language.PureScript as P +import Language.PureScript.Docs.Convert.Single (convertComments) import Language.PureScript.Externs import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Reexports @@ -199,6 +200,7 @@ populateVolatileStateSTM ref = do moduleDeclarations & map resolveDataConstructorsForModule & resolveLocations asts + & resolveDocumentation (map fst modules) & resolveInstances externs & resolveOperators & resolveReexports reexportRefs @@ -221,23 +223,7 @@ resolveLocationsForModule (defs, types) decls = map convertDeclaration decls where convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn - convertDeclaration (IdeDeclarationAnn ann d) = case d of - IdeDeclValue v -> - annotateFunction (v ^. ideValueIdent) (IdeDeclValue v) - IdeDeclType t -> - annotateType (t ^. ideTypeName . properNameT) (IdeDeclType t) - IdeDeclTypeSynonym s -> - annotateType (s ^. ideSynonymName . properNameT) (IdeDeclTypeSynonym s) - IdeDeclDataConstructor dtor -> - annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor) - IdeDeclTypeClass tc -> - annotateType (tc ^. ideTCName . properNameT) (IdeDeclTypeClass tc) - IdeDeclValueOperator operator -> - annotateValue (operator ^. ideValueOpName . opNameT) (IdeDeclValueOperator operator) - IdeDeclTypeOperator operator -> - annotateType (operator ^. ideTypeOpName . opNameT) (IdeDeclTypeOperator operator) - IdeDeclKind i -> - annotateKind (i ^. properNameT) (IdeDeclKind i) + convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' annotateFunction annotateValue annotateType annotateKind d where annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs , _annTypeAnnotation = Map.lookup x types @@ -246,6 +232,71 @@ resolveLocationsForModule (defs, types) decls = annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs}) annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSKind x) defs}) +convertDeclaration' + :: (P.Ident -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> IdeDeclaration + -> IdeDeclarationAnn +convertDeclaration' annotateFunction annotateValue annotateType annotateKind d = + case d of + IdeDeclValue v -> + annotateFunction (v ^. ideValueIdent) d + IdeDeclType t -> + annotateType (t ^. ideTypeName . properNameT) d + IdeDeclTypeSynonym s -> + annotateType (s ^. ideSynonymName . properNameT) d + IdeDeclDataConstructor dtor -> + annotateValue (dtor ^. ideDtorName . properNameT) d + IdeDeclTypeClass tc -> + annotateType (tc ^. ideTCName . properNameT) d + IdeDeclValueOperator operator -> + annotateValue (operator ^. ideValueOpName . opNameT) d + IdeDeclTypeOperator operator -> + annotateType (operator ^. ideTypeOpName . opNameT) d + IdeDeclKind i -> + annotateKind (i ^. properNameT) d + +resolveDocumentation + :: ModuleMap P.Module + -> ModuleMap [IdeDeclarationAnn] + -> ModuleMap [IdeDeclarationAnn] +resolveDocumentation modules = + Map.mapWithKey (\mn decls -> + maybe decls (flip resolveDocumentationForModule decls) (Map.lookup mn modules)) + +resolveDocumentationForModule + :: P.Module + -> [IdeDeclarationAnn] + -> [IdeDeclarationAnn] +resolveDocumentationForModule (P.Module _ _ _ sdecls _) decls = map convertDecl decls + where + comments :: Map P.Name [P.Comment] + comments = Map.fromListWith (flip (<>)) $ mapMaybe (\d -> + case name d of + Just name' -> Just (name', snd $ P.declSourceAnn d) + _ -> Nothing) + sdecls + + name :: P.Declaration -> Maybe P.Name + name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d + name decl = P.declName decl + + convertDecl :: IdeDeclarationAnn -> IdeDeclarationAnn + convertDecl (IdeDeclarationAnn ann d) = + convertDeclaration' + (annotateValue . P.IdentName) + (annotateValue . P.IdentName . P.Ident) + (annotateValue . P.TyName . P.ProperName) + (annotateValue . P.KiName . P.ProperName) + d + where + docs :: P.Name -> Text + docs ident = fromMaybe "" $ convertComments =<< Map.lookup ident comments + + annotateValue ident = IdeDeclarationAnn (ann { _annDocumentation = Just $ docs ident }) + resolveInstances :: ModuleMap P.ExternsFile -> ModuleMap [IdeDeclarationAnn] diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index a19a2d72da..f013ace268 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -114,13 +114,14 @@ data Annotation { _annLocation :: Maybe P.SourceSpan , _annExportedFrom :: Maybe P.ModuleName , _annTypeAnnotation :: Maybe P.Type + , _annDocumentation :: Maybe Text } deriving (Show, Eq, Ord, Generic, NFData) makeLenses ''Annotation makeLenses ''IdeDeclarationAnn emptyAnn :: Annotation -emptyAnn = Annotation Nothing Nothing Nothing +emptyAnn = Annotation Nothing Nothing Nothing Nothing type DefinitionSites a = Map IdeNamespaced a type TypeAnnotations = Map P.Ident P.Type diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs index 255d6974c6..4df331aad4 100644 --- a/tests/Language/PureScript/Ide/CompletionSpec.hs +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -5,10 +5,12 @@ module Language.PureScript.Ide.CompletionSpec where import Protolude import Language.PureScript as P +import Language.PureScript.Ide.Test as Test +import Language.PureScript.Ide.Command as Command import Language.PureScript.Ide.Completion -import Language.PureScript.Ide.Test import Language.PureScript.Ide.Types import Test.Hspec +import System.FilePath reexportMatches :: [Match IdeDeclarationAnn] reexportMatches = @@ -21,6 +23,15 @@ reexportMatches = matches :: [(Match IdeDeclarationAnn, [P.ModuleName])] matches = map (\d -> (Match (mn "Main", d), [mn "Main"])) [ ideKind "Kind", ideType "Type" Nothing [] ] +typ :: Text -> Command +typ txt = Type txt [] Nothing + +load :: [Text] -> Command +load = LoadSync . map Test.mn + +rebuildSync :: FilePath -> Command +rebuildSync fp = RebuildSync ("src" fp) Nothing + spec :: Spec spec = describe "Applying completion options" $ do it "keeps all matches if maxResults is not specified" $ do @@ -32,3 +43,24 @@ spec = describe "Applying completion options" $ do it "groups reexports for a single identifier" $ do applyCompletionOptions (defaultCompletionOptions { coGroupReexports = True }) reexportMatches `shouldBe` [(Match (mn "A", ideKind "Kind"), [mn "A", mn "B"])] + + it "gets simple docs on definition itself" $ do + ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpecDocs"] + , typ "something" + ] + result `shouldSatisfy` \res -> complDocumentation res == Just "Doc x\n" + + it "gets multiline docs" $ do + ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpecDocs"] + , typ "multiline" + ] + result `shouldSatisfy` \res -> complDocumentation res == Just "This is\na multi-line\ncomment\n" + + it "gets simple docs on type annotation" $ do + ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpecDocs"] + , typ "withType" + ] + result `shouldSatisfy` \res -> complDocumentation res == Just "Doc *123*\n" \ No newline at end of file diff --git a/tests/support/pscide/src/CompletionSpecDocs.purs b/tests/support/pscide/src/CompletionSpecDocs.purs new file mode 100644 index 0000000000..1c92a37752 --- /dev/null +++ b/tests/support/pscide/src/CompletionSpecDocs.purs @@ -0,0 +1,13 @@ +module CompletionSpecDocs where + +-- | Doc x +something = "something" + +-- | Doc *123* +withType :: Int +withType = 42 + +-- | This is +-- | a multi-line +-- | comment +multiline = "multiline" \ No newline at end of file From 5c2463f0c5cf15d8e5ecbe396bdd8f78ef2d741b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 31 Oct 2017 16:07:04 -0700 Subject: [PATCH 0886/1580] Add docs for duplicate labels in record types (#3143) * Add docs for duplicate labels in record types * Typo --- src/Language/PureScript/Docs/Prim.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index aa8b68c3e4..66c478411a 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -148,6 +148,12 @@ record = primType "Record" $ T.unlines , "The syntactic sugar with curly braces `{ }` is generally preferred, though:" , "" , " type Person = { name :: String, age :: Number }" + , "" + , "The row associates a type to each label which appears in the record." + , "" + , "_Technical note_: PureScript allows duplicate labels in rows, and the" + , "meaning of `Record r` is based on the _first_ occurrence of each label in" + , "the row `r`." ] number :: Declaration From f7209a595499b1dd1ec5f202239678b1b191fb8a Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 13 Sep 2017 12:48:14 +0200 Subject: [PATCH 0887/1580] [purs ide] Groups hiding imports with implicit ones (#3069) --- src/Language/PureScript/Ide/Imports.hs | 1 + tests/Language/PureScript/Ide/ImportsSpec.hs | 24 +++++++++++++++++--- 2 files changed, 22 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index beed3d6c3b..92d62b83be 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -320,6 +320,7 @@ prettyPrintImportSection imports = isImplicitImport :: Import -> Bool isImplicitImport i = case i of Import _ P.Implicit Nothing -> True + Import _ (P.Hiding _) Nothing -> True _ -> False diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 2dd0b8fa37..177ce39ace 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -29,6 +29,15 @@ simpleFile = , "myFunc x y = x + y" ] +hidingFile :: [Text] +hidingFile = + [ "module Main where" + , "import Prelude" + , "import Data.Maybe hiding (maybe)" + , "" + , "myFunc x y = x + y" + ] + syntaxErrorFile :: [Text] syntaxErrorFile = [ "module Main where" @@ -37,8 +46,8 @@ syntaxErrorFile = , "myFunc =" ] -splitSimpleFile :: (P.ModuleName, [Text], [Import], [Text]) -splitSimpleFile = fromRight (sliceImportSection simpleFile) +testSliceImportSection :: [Text] -> (P.ModuleName, [Text], [Import], [Text]) +testSliceImportSection = fromRight . sliceImportSection where fromRight = fromJust . rightToMaybe @@ -99,7 +108,8 @@ spec = do shouldBe (prettyPrintImport' maybeImport) "import Data.Maybe (Maybe(Just))" describe "import commands" $ do - let simpleFileImports = let (_, _, i, _) = splitSimpleFile in i + let simpleFileImports = let (_, _, i, _) = testSliceImportSection simpleFile in i + hidingFileImports = let (_, _, i, _) = testSliceImportSection hidingFile in i addValueImport i mn q is = prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValue i Nothing)) mn q is) addOpImport op mn q is = @@ -128,6 +138,14 @@ spec = do , "" , "import Data.Map as Map" ] + it "adds a qualified import and maintains proper grouping for implicit hiding imports" $ + shouldBe + (addQualifiedImport' hidingFileImports (Test.mn "Data.Map") (Test.mn "Map")) + [ "import Data.Maybe hiding (maybe)" + , "import Prelude" + , "" + , "import Data.Map as Map" + ] it "adds an explicit unqualified import to a file without any imports" $ shouldBe (addValueImport "head" (P.moduleNameFromString "Data.Array") Nothing []) From 21c096e34913a0d9a866e396cef803ed547d5550 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sat, 16 Sep 2017 01:17:03 +0200 Subject: [PATCH 0888/1580] Bump to ghc8 2 (#3070) * fixes cabal warning about an unspecified Paths module * Bump to GHC 8.2 stack nightly * trigger rebuild * fix more shadowing warnings * retrigger build * try again --- app/Command/Ide.hs | 1 + package.yaml | 23 +++++++++++++++---- .../PureScript/Docs/Convert/Single.hs | 2 +- src/Language/PureScript/Ide/Completion.hs | 2 +- src/Language/PureScript/Ide/Imports.hs | 2 +- src/Language/PureScript/Ide/Reexports.hs | 2 +- src/Language/PureScript/Ide/State.hs | 2 +- src/Language/PureScript/Ide/Types.hs | 2 +- stack.yaml | 3 ++- tests/Language/PureScript/Ide/ImportsSpec.hs | 2 +- 10 files changed, 29 insertions(+), 12 deletions(-) diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index 263e27172f..a33c33d90a 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -147,6 +147,7 @@ command = Opts.helper <*> subcommands where `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\"")) <*> Opts.switch (Opts.long "editor-mode") + parseLogLevel :: Text -> IdeLogLevel parseLogLevel s = case s of "debug" -> LogDebug "perf" -> LogPerf diff --git a/package.yaml b/package.yaml index 9f33ba0c4c..ddeb153eec 100644 --- a/package.yaml +++ b/package.yaml @@ -32,7 +32,7 @@ extra-source-files: - CONTRIBUTORS.md - CONTRIBUTING.md dependencies: - - aeson >=1.0 && <1.2 + - aeson >=1.0 && <1.3 - aeson-better-errors >=0.8 - ansi-terminal >=0.6.2 && <0.7 - base >=4.8 && <5 @@ -67,7 +67,7 @@ dependencies: - pattern-arrows >=0.0.2 && <0.1 - pipes >=4.0.0 && <4.4.0 - pipes-http - - process >=1.2.0 && <1.5 + - process >=1.2.0 && <1.7 - protolude >=0.1.6 - regex-tdfa - safe >=0.3.9 && <0.4 @@ -116,6 +116,21 @@ executables: main: Main.hs source-dirs: app ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N + other-modules: + - Command.Bundle + - Command.Compile + - Command.Docs + - Command.Docs.Ctags + - Command.Docs.Etags + - Command.Docs.Html + - Command.Docs.Tags + - Command.Hierarchy + - Command.Ide + - Command.Publish + - Command.REPL + - Paths_purescript + - Version + dependencies: - ansi-wl-pprint - file-embed @@ -125,14 +140,14 @@ executables: - wai ==3.* - wai-websockets ==3.* - warp ==3.* - - websockets >=0.9 && <0.11 + - websockets >=0.9 && <0.13 when: - condition: flag(release) then: cpp-options: -DRELEASE else: dependencies: - - gitrev >=1.2.0 && <1.3 + - gitrev >=1.2.0 && <1.4 tests: tests: diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 3ca683861f..76810c1f9e 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -2,7 +2,7 @@ module Language.PureScript.Docs.Convert.Single ( convertSingleModule ) where -import Protolude +import Protolude hiding (moduleName) import Control.Category ((>>>)) diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 44a4ac6fea..b4e9f2ed66 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -9,7 +9,7 @@ module Language.PureScript.Ide.Completion , applyCompletionOptions ) where -import Protolude +import Protolude hiding ((<&>), moduleName) import Control.Lens hiding ((&), op) import Data.Aeson diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 92d62b83be..251864909d 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -30,7 +30,7 @@ module Language.PureScript.Ide.Imports ) where -import Protolude +import Protolude hiding (moduleName) import Control.Lens ((^.), (%~), ix) import Data.List (findIndex, nubBy, partition) diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 8cdc088301..82a639c9cb 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -23,7 +23,7 @@ module Language.PureScript.Ide.Reexports , resolveReexports' ) where -import Protolude +import Protolude hiding (moduleName) import Control.Lens hiding ((&)) import qualified Data.Map as Map diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index e6c7fed3c5..f7d7a57a6c 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -36,7 +36,7 @@ module Language.PureScript.Ide.State , resolveDataConstructorsForModule ) where -import Protolude +import Protolude hiding (moduleName) import Control.Arrow import Control.Concurrent.STM diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index ffab6bfb90..a19a2d72da 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -19,7 +19,7 @@ module Language.PureScript.Ide.Types where -import Protolude +import Protolude hiding (moduleName) import Control.Concurrent.STM import Control.Lens.TH diff --git a/stack.yaml b/stack.yaml index c04a09eede..df22368d47 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,6 @@ -resolver: lts-8.5 +resolver: nightly-2017-09-10 packages: - '.' extra-deps: - pipes-http-1.0.5 +- Win32-notify-0.3.0.3 diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 177ce39ace..71a883cde1 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.ImportsSpec where -import Protolude +import Protolude hiding (moduleName) import Data.Maybe (fromJust) import qualified Language.PureScript as P From c4577de5d1c36ca99118e6848fe4b7f0bdcbf30b Mon Sep 17 00:00:00 2001 From: Isaac Elliott Date: Sun, 24 Sep 2017 03:13:43 +1000 Subject: [PATCH 0889/1580] Fixed type shadowing error (#2967) * Fix and regression tests for #2197 * Updated Prim module documentation * Added test using Record type * Added some peace-of-mind tests --- examples/failing/2197-shouldFail.purs | 10 ++++++++++ examples/failing/2197-shouldFail2.purs | 7 +++++++ examples/passing/2197-1.purs | 12 ++++++++++++ examples/passing/2197-2.purs | 11 +++++++++++ src/Language/PureScript/AST/Declarations.hs | 13 ++++++++++--- src/Language/PureScript/Docs/Prim.hs | 2 +- 6 files changed, 51 insertions(+), 4 deletions(-) create mode 100644 examples/failing/2197-shouldFail.purs create mode 100644 examples/failing/2197-shouldFail2.purs create mode 100644 examples/passing/2197-1.purs create mode 100644 examples/passing/2197-2.purs diff --git a/examples/failing/2197-shouldFail.purs b/examples/failing/2197-shouldFail.purs new file mode 100644 index 0000000000..a211f195d0 --- /dev/null +++ b/examples/failing/2197-shouldFail.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith ScopeConflict +module Main where + +import Prim as P +import Prim (Number) + +type Number = P.Number + +z :: Number +z = 0.0 diff --git a/examples/failing/2197-shouldFail2.purs b/examples/failing/2197-shouldFail2.purs new file mode 100644 index 0000000000..fb1b11b5d7 --- /dev/null +++ b/examples/failing/2197-shouldFail2.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith UnknownName +module Main where + +import Prim (Boolean) + +z :: Number +z = 0.0 diff --git a/examples/passing/2197-1.purs b/examples/passing/2197-1.purs new file mode 100644 index 0000000000..a0c808f350 --- /dev/null +++ b/examples/passing/2197-1.purs @@ -0,0 +1,12 @@ +module Main where + +import Control.Monad.Eff.Console +import Prim as P + +type Number = P.Number +type Test = {} + +z :: Number +z = 0.0 + +main = log "Done" diff --git a/examples/passing/2197-2.purs b/examples/passing/2197-2.purs new file mode 100644 index 0000000000..94354e94cd --- /dev/null +++ b/examples/passing/2197-2.purs @@ -0,0 +1,11 @@ +module Main where + +import Control.Monad.Eff.Console +import Prim (Int) + +type Number = Int + +z :: Number +z = 0 + +main = log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 67c2baa13b..80b73f9dda 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -233,12 +233,19 @@ getModuleSourceSpan (Module ss _ _ _ _) = ss -- | -- Add an import declaration for a module if it does not already explicitly import it. -- +-- Will not import an unqualified module if that module has already been imported qualified. +-- (See #2197) +-- addDefaultImport :: Qualified ModuleName -> Module -> Module addDefaultImport (Qualified toImportAs toImport) m@(Module ss coms mn decls exps) = if isExistingImport `any` decls || mn == toImport then m else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit toImportAs : decls) exps where - isExistingImport (ImportDeclaration _ mn' _ as') | mn' == toImport && as' == toImportAs = True + isExistingImport (ImportDeclaration _ mn' _ as') + | mn' == toImport = + case toImportAs of + Nothing -> True + _ -> as' == toImportAs isExistingImport _ = False -- | Adds import declarations to a module for an implicit Prim import and Prim @@ -248,8 +255,8 @@ importPrim = let primModName = ModuleName [ProperName C.prim] in - addDefaultImport (Qualified Nothing primModName) - . addDefaultImport (Qualified (Just primModName) primModName) + addDefaultImport (Qualified (Just primModName) primModName) + . addDefaultImport (Qualified Nothing primModName) -- | -- An item in a list of explicit imports or exports diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 2a5e62c641..aa8b68c3e4 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -12,7 +12,7 @@ import qualified Language.PureScript as P primDocsModule :: Module primDocsModule = Module { modName = P.moduleNameFromString "Prim" - , modComments = Just "The Prim module is embedded in the PureScript compiler in order to provide compiler support for certain types — for example, value literals, or syntax sugar." + , modComments = Just "The Prim module is embedded in the PureScript compiler in order to provide compiler support for certain types — for example, value literals, or syntax sugar. It is implicitly imported unqualified in every module except those that list it as a qualified import." , modDeclarations = [ function , array From 75d381932bbcadeb4bc0a5dc8ef50a918a4d7a3e Mon Sep 17 00:00:00 2001 From: Tom Harding Date: Sun, 24 Sep 2017 21:40:25 +0100 Subject: [PATCH 0890/1580] Expand error message for UnusableDeclaration (#3088) Previously, the error message made no mention of a solution to the error. This update adds possible solutions to the error message in the form of the remaining covering sets. In other words, the remaining variables that need to be determined in order to satisfy the typechecker. --- CONTRIBUTORS.md | 1 + src/Language/PureScript/AST/Declarations.hs | 5 ++--- src/Language/PureScript/Errors.hs | 17 ++++++++++++++--- src/Language/PureScript/TypeChecker.hs | 11 ++++++++--- 4 files changed, 25 insertions(+), 9 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index abbb1608db..9616d9e09e 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -51,6 +51,7 @@ If you would prefer to use different terms, please use the section below instead | [@houli](https://github.com/houli) | Eoin Houlihan | [MIT license](http://opensource.org/licenses/MIT) | | [@ianbollinger](https://github.com/ianbollinger) | Ian D. Bollinger | [MIT license](http://opensource.org/licenses/MIT) | | [@ilovezfs](https://github.com/ilovezfs) | ilovezfs | MIT license | +| [@i-am-tom](https://github.com/i-am-tom) | i-am-tom | [MIT license](http://opensource.org/licenses/MIT) | | [@izgzhen](https://github.com/izgzhen) | Zhen Zhang | [MIT license](http://opensource.org/licenses/MIT) | | [@jacereda](https://github.com/jacereda) | Jorge Acereda | [MIT license](http://opensource.org/licenses/MIT) | | [@japesinator](https://github.com/japesinator) | JP Smith | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 80b73f9dda..148a14e7db 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -168,9 +168,8 @@ data SimpleErrorMessage | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int -- | a user-defined warning raised by using the Warn type class | UserDefinedWarning Type - -- | a declaration couldn't be used because there wouldn't be enough information - -- | to choose an instance - | UnusableDeclaration Ident + -- | a declaration couldn't be used because it contained free variables + | UnusableDeclaration Ident [[Text]] deriving (Show) -- | Error message hints, providing more detailed information about failure. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 47da4e29bb..63209cb1a6 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -950,9 +950,20 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , indent msg ] - renderSimpleErrorMessage (UnusableDeclaration ident) = - paras [ line $ "The declaration " <> markCode (showIdent ident) <> " is unusable." - , line $ "This happens when a constraint couldn't possibly have enough information to work out which instance is required." + renderSimpleErrorMessage (UnusableDeclaration ident unexplained) = + paras $ + [ line $ "The declaration " <> markCode (showIdent ident) <> " contains arguments that couldn't be determined." + ] <> + + case unexplained of + [required] -> + [ line $ "These arguments are: { " <> T.intercalate "," required <> "}" + ] + + options -> + [ line "To fix this, one of the following sets of variables must be determined:" + , Box.moveRight 2 . Box.vsep 0 Box.top $ + map (\set -> line $ "{ " <> T.intercalate ", " set <> " }") options ] renderHint :: ErrorMessageHint -> Box.Box -> Box.Box diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index b7e7facaa6..4c2b6f3e22 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -20,7 +20,7 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Lens ((^..), _1, _2) import Data.Foldable (for_, traverse_, toList) -import Data.List (nubBy, (\\), sort, group) +import Data.List (nub, nubBy, (\\), sort, group) import Data.Maybe import Data.Monoid ((<>)) import Data.Text (Text) @@ -150,8 +150,13 @@ addTypeClass moduleName pn args implies dependencies ds = do checkMemberIsUsable syns (ident, memberTy) = do memberTy' <- T.replaceAllTypeSynonymsM syns memberTy let mentionedArgIndexes = S.fromList (mapMaybe argToIndex (freeTypeVariables memberTy')) - unless (any (`S.isSubsetOf` mentionedArgIndexes) coveringSets) $ - throwError . errorMessage $ UnusableDeclaration ident + let leftovers = map (`S.difference` mentionedArgIndexes) coveringSets + + unless (any null leftovers) . throwError . errorMessage $ + let + solutions = map (map (fst . (args !!)) . S.toList) leftovers + in + UnusableDeclaration ident (nub solutions) addTypeClassDictionaries :: (MonadState CheckState m) From 4301160423e15be1376fb54f24e27a39e9fd09b1 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Mon, 25 Sep 2017 17:19:36 -0700 Subject: [PATCH 0891/1580] A couple of minor changes to contributing guide Remove old video link Add note about opening issues --- CONTRIBUTING.md | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index da40134ebf..ef683c00d8 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -1,6 +1,4 @@ -An introductory overview of the compiler is available [here](https://www.youtube.com/watch?v=Y3P1dxqwFiE). - -Pull requests are encouraged. +Pull requests are encouraged, but please open issues before starting to work on something that you intend to make into a PR, so that we can decide if it is a good fit or not. ## Finding Issues to Work On From eac822e437fa59deea1441a664ce068a82c67593 Mon Sep 17 00:00:00 2001 From: Brandon Hamilton Date: Sun, 1 Oct 2017 21:06:29 +0200 Subject: [PATCH 0892/1580] Only add newline before initial group of comment lines in javascript codegen (#3098) --- src/Language/PureScript/CodeGen/JS/Printer.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index 18a4798d18..d8b59dc268 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -116,20 +116,19 @@ literals = mkPattern' match' , prettyPrintJS' value ] match (Comment _ com js) = mconcat <$> sequence - [ mconcat <$> forM com comment + [ return $ emit "\n" + , mconcat <$> forM com comment , prettyPrintJS' js ] match _ = mzero comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen comment (LineComment com) = fmap mconcat $ sequence $ - [ return $ emit "\n" - , currentIndent + [ currentIndent , return $ emit "//" <> emit com <> emit "\n" ] comment (BlockComment com) = fmap mconcat $ sequence $ - [ return $ emit "\n" - , currentIndent + [ currentIndent , return $ emit "/**\n" ] ++ map asLine (T.lines com) ++ From 39af532d0b78491df0b3ecff426c175e11dec137 Mon Sep 17 00:00:00 2001 From: Tom Harding Date: Sun, 8 Oct 2017 21:34:58 +0100 Subject: [PATCH 0893/1580] Add valid location list to orphan instance error (#3106) * Add valid location list to orphan instance error Previously, the orphan instance simply said to consider a newtype. Now, it lists all the places in the project that would be considered valid locations for the instance as well. This hopefully closes #3063. * Updates from review Firstly, there's a little change to the error output in the case of there being no place for the instance except Prim. Previously, it just printed an empty list, which didn't make much sense, gramatically. Now, however, a different error is displayed to point out that there's no reasonable home for the instance. As well as this, the `typeModule` function in `TypeChecker.hs` can now deal with proxy types. Previously, it couldn't, and the tests were passing really due to an accident of laziness. Now, the tests pass, and all is well in the world. * Tidy the orphan instance error further. Thinking about it, you'll only ever see, at most, two things in the list of possible locations. So, we can intercalate the list with `or` and get a much friendlier-looking error. * Adjust wording on error feedback Previously, the error mentioned that the instance "must" be declared in one of a set of places, which @goodacre.liam (rightly) noted would imply that there aren't other, equally valid, solutions. The wording has been altered to address this. --- src/Language/PureScript/AST/Declarations.hs | 3 ++- src/Language/PureScript/Errors.hs | 23 ++++++++++++++------- src/Language/PureScript/TypeChecker.hs | 8 +++++-- 3 files changed, 24 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 148a14e7db..f2981eecad 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -16,6 +16,7 @@ import Control.Monad.Identity import Data.Aeson.TH import qualified Data.Map as M +import Data.Set (Set) import Data.Text (Text) import qualified Data.List.NonEmpty as NEL import GHC.Generics (Generic) @@ -130,7 +131,7 @@ data SimpleErrorMessage | PropertyIsMissing Label | AdditionalProperty Label | TypeSynonymInstance - | OrphanInstance Ident (Qualified (ProperName 'ClassName)) [Type] + | OrphanInstance Ident (Qualified (ProperName 'ClassName)) (Set ModuleName) [Type] | InvalidNewtype (ProperName 'TypeName) | InvalidInstanceHead Type | TransitiveExportError DeclarationRef [DeclarationRef] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 63209cb1a6..1e09a8f94e 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -22,6 +22,7 @@ import Data.List (transpose, nubBy, sort, partition, dropWhileEnd) import qualified Data.List.NonEmpty as NEL import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text) import Language.PureScript.AST @@ -274,7 +275,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (InvalidDerivedInstance cl ts n) = InvalidDerivedInstance cl <$> traverse f ts <*> pure n gSimple (ExpectedTypeConstructor cl ts ty) = ExpectedTypeConstructor cl <$> traverse f ts <*> f ty gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k - gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts + gSimple (OrphanInstance nm cl noms ts) = OrphanInstance nm cl noms <$> traverse f ts gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx <*> onTypeSearchTypesM f env gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty @@ -765,16 +766,24 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "Type of expression contains additional label " <> markCode (prettyPrintLabel prop) <> "." renderSimpleErrorMessage TypeSynonymInstance = line "Type class instances for type synonyms are disallowed." - renderSimpleErrorMessage (OrphanInstance nm cnm ts) = - paras [ line $ "Type class instance " <> markCode (showIdent nm) <> " for " + renderSimpleErrorMessage (OrphanInstance nm cnm nonOrphanModules ts) = + paras [ line $ "Orphan instance " <> markCode (showIdent nm) <> " found for " , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm) , Box.vcat Box.left (map typeAtomAsBox ts) ] - , line "is an orphan instance." - , line "An orphan instance is one which is defined in a module that is unrelated to either the class or the collection of data types that the instance is defined for." - , line "Consider moving the instance, if possible, or using a newtype wrapper." - ] + , Box.vcat Box.left $ case modulesToList of + [] -> [ line "There is nowhere this instance can be placed without being an orphan." + , line "A newtype wrapper can be used to avoid this problem." + ] + _ -> [ Box.text $ "This problem can be resolved by declaring the instance in " + <> T.unpack formattedModules + <> ", or by defining the instance on a newtype wrapper." + ] + ] + where + modulesToList = S.toList $ S.delete (moduleNameFromString "Prim") nonOrphanModules + formattedModules = T.intercalate " or " ((markCode . runModuleName) <$> modulesToList) renderSimpleErrorMessage (InvalidNewtype name) = paras [ line $ "Newtype " <> markCode (runProperName name) <> " is invalid." , line "Newtypes must define a single constructor with a single argument." diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 4c2b6f3e22..85db7400eb 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -359,15 +359,19 @@ typeCheckAll moduleName _ = traverse go checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m () checkOrphanInstance dictName className@(Qualified (Just mn') _) typeClass tys' - | moduleName == mn' || moduleName `S.member` nonOrphanModules = return () - | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys' + | moduleName `S.member` nonOrphanModules' = return () + | otherwise = throwError . errorMessage $ OrphanInstance dictName className nonOrphanModules' tys' where + nonOrphanModules' :: S.Set ModuleName + nonOrphanModules' = S.insert mn' nonOrphanModules + typeModule :: Type -> Maybe ModuleName typeModule (TypeVar _) = Nothing typeModule (TypeLevelString _) = Nothing typeModule (TypeConstructor (Qualified (Just mn'') _)) = Just mn'' typeModule (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance" typeModule (TypeApp t1 _) = typeModule t1 + typeModule (ProxyType _) = Nothing typeModule _ = internalError "Invalid type in instance in checkOrphanInstance" modulesByTypeIndex :: M.Map Int (Maybe ModuleName) From 5e778e2509ec51a16af732b180fa38b25b5f98ab Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 7 Nov 2017 20:32:25 -0800 Subject: [PATCH 0894/1580] Remove reference to ProxyType in master --- src/Language/PureScript/TypeChecker.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 85db7400eb..0d92edcf5d 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -371,7 +371,6 @@ typeCheckAll moduleName _ = traverse go typeModule (TypeConstructor (Qualified (Just mn'') _)) = Just mn'' typeModule (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance" typeModule (TypeApp t1 _) = typeModule t1 - typeModule (ProxyType _) = Nothing typeModule _ = internalError "Invalid type in instance in checkOrphanInstance" modulesByTypeIndex :: M.Map Int (Maybe ModuleName) From 6df7a14c590c29ba4429a0fc2b3ac029239ec169 Mon Sep 17 00:00:00 2001 From: Sergey Homa Date: Thu, 19 Oct 2017 12:33:41 +0300 Subject: [PATCH 0895/1580] Merge --- CONTRIBUTORS.md | 2 ++ psc-ide/PROTOCOL.md | 3 ++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 9616d9e09e..96f7e5f41c 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -111,6 +111,8 @@ If you would prefer to use different terms, please use the section below instead | [@vkorablin](https://github.com/vkorablin) | Vladimir Korablin | MIT license | | [@zudov](https://github.com/zudov) | Konstantin Zudov | [MIT license](http://opensource.org/licenses/MIT) | | [@b123400](https://github.com/b123400) | b123400 | [MIT license](https://opensource.org/licenses/MIT) | +| [@drets](https://github.com/drets) | Dmytro Rets | [MIT license](http://opensource.org/licenses/MIT) | +| [@bjornmelgaaard](https://github.com/BjornMelgaard) | Sergey Homa | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index fdab0115d6..33e8c2476c 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -72,7 +72,8 @@ The `complete` command looks up possible completions/corrections. If no matcher is given every candidate, that passes the filters, is returned in no particular order. - - `currentModule :: (optional) String`: The current modules name. If it matches + - `currentModule :: (optional) String`: The current modules name. Allows you + to see module-private functions after a successful rebuild. If it matches with the rebuild cache non-exported modules will also be completed. You can fill the rebuild cache by using the "Rebuild" command. From 561bb9816c16ece33f9caa9b65b3824797bf8353 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 20 Oct 2017 00:11:29 +0200 Subject: [PATCH 0896/1580] Adds a (non-completed) document for ide's design. (#3108) * Adds a (non-completed) document for ide's design. I hope this helps potential contributors and people generally interested in the project * some thoughts that need to be added somewhere * thoughts about in-memory state for ide * a collection of thoughts on rebuilding * Why do we pretty print the entire import section? * rename random heading --- psc-ide/DESIGN.org | 279 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 279 insertions(+) create mode 100644 psc-ide/DESIGN.org diff --git a/psc-ide/DESIGN.org b/psc-ide/DESIGN.org new file mode 100644 index 0000000000..00129e6603 --- /dev/null +++ b/psc-ide/DESIGN.org @@ -0,0 +1,279 @@ +* Introduction + This document is meant to outline and explain some of the architecture + decisions for =purs ide=. Read this document, if you plan on contributing to + =purs ide= or are just generally interested in the project. + +* What does `purs ide` do? + The =purs ide= project provides functionality for PureScript tooling and + editors. + - Cross platform + - Distributed and versioned with the compiler + - Reuses types and functionality from the compiler -> up-to-date + - Reduces reimplementation of the same feature for every editor + +* Using `purs ide` as a library from Haskell + =purs ide= is split into a library and an executable. The library code lives + inside =src/Language/PureScript/Ide=. The executable, which is invoked by the + editors is located inside =app/Command/Ide.hs=. + + The =purs ide= library is unopinionated about: + + - Protocol + - Concurrency Model + - Logging + - File watchers + + And so other executables, like an implementation of the Language Server + Protocol, are supported by this model and can be added in the future. + + The main entry point into the library is the =handleCommand= function inside + the =PureScript.Language.Ide= module. +** handleCommand + + Break down the type signature: + + =handleCommand :: (Ide m, MonadLogger m, MonadError IdeError m) => Command -> m Success= + + Ide m expands to (MonadReader IdeEnvironment m, MonadIO m) and so we end up + with 4 constraints/capabilities handleCommand needs to be provided with by + the caller. + + - MonadIO + + handleCommand needs access to IO + + - MonadError IdeError + + Errors can occur during the evaluation of a Command, and the executable + gets to decide how to handle them. + + - MonadLogger + + purs ide uses the =MonadLogger= constraint to defer the choice of logging + to the exeutable. This constraint can be fulfilled with a console based + logger, a file-based one or the log messages can just be discarded (helpful + during testing) + + - MonadReader IdeEnvironment + + The IdeEnvironment holds some configuration type, but crucially it also + contains a TVar (thread variable), which contains all of purs ide's state. + We're using a threadvariable over a =MonadState= constraint here, so it's + easier to evaluate concurrent or asynchronous evaluation of commands. + +** Ide's State type + Ide's State is split into =IdeFileState= and =IdeVolatileState=. + +*** =IdeFileState= + The file state holds externs files and parsed module ASTs and thus directly + corresponds to entities on the file system. This part of the state can be + changed per module (eg. by a filewatcher). + +*** =IdeVolatileState= + The volatile state contains all the derived data, like the declarations we + use to provide autocompletion. The data is denormalized and optimized for + reading/querying, but is harder to invalidate and thus needs to be updated + more coarsely whenever something in FileState changes. Right now we + completely recompute it on every change because it's still very fast. In the + future we might need to be cleverer as the information we collect gets more + sophisticated and more expensive to compute. + +** How to invoke =handleCommand= in an executable + Relevant files: tests/Language/PureScript/Ide/Test.hs app/Commands/Ide.hs + + Running =handleCommand= requires that we satisfy all the constraints placed + on it. It's easiest to just show how to write a function that accepts a + single command and runs it against an empty =IdeState=. We'll also retrieve + the resulting state and any errors that ocurred. + + #+BEGIN_SRC haskell + runIdeCommand :: Command -> IO (Either IdeError Success, IdeState) + runIdeCommand command = do + -- First we'll create a TVar of an empty IdeState. + stateVar <- newTVarIO emptyIdeState + -- We create a new IdeEnvironment using the default IdeConfig and our state + -- variable + let environment = IdeEnvironment {ideStateVar = stateVar, ideConfiguration = defConfig} + -- It's easiest to read the next line inside out: + + -- 1. apply =handleCommand= to the command + + -- 2. Satisfy the MonadReader IdeEnvironment constraint by passing + -- =environment= to =runReaderT= + + -- 3. Turn any thrown Errors into an Either IdeError with =runExceptT= + + -- 4. Finally, discard any log messages with =runNoLoggingT=. + + -- (5. The MonadIO constraint is satisfied by choosing IO as the underlying + -- Monad) + result <- runNoLoggingT (runExceptT (runReaderT (handleCommand command) environment)) + + -- We read the resulting IdeState from the state variable + newState <- readTVarIO stateVar + -- Return the command result, as well as the resulting state + pure (result, newState) + #+END_SRC + +** Concurrency model is up to the caller of handleCommand + + By using a =TVar= instead of a MonadState constraint =ide='s design allows to + run multiple invocations of =handleCommand= in parallel. By using =STM=, + =ide= makes sure to not run into deadlocks or data races. + + However the current implementation of =purs ide server= runs all the commands + sequentially, because the commmands run fast enough at this point, and a + users interaction with his editor are mostly sequential anyway. +* Commands + The three most involved commands are completion, adding imports and rebuilding. + + - Completions are found by composing filters and matchers, a `purs ide` DSL + - Adding imports involves file manipulation, some custom parsing and surprisingly complex logic + - Rebuilding involves calling compiler APIs +** Completions + Important files: Ide.Filter Ide.Matcher Ide.Completion + + The =completion= command filters all of the stored =IdeDeclarations= inside + =ide='s volatile state through a list of =Filters= as well as an optional + =Matcher=. Completion options can be specified to apply further + post-processing (choosing the maximum number of results, how to group + reexports of the same value) + + Afterwards they are turned into a stripped down =Completions= + format, which contains information that can be easily consumed by editor + plugins. + +*** The Query Pipeline + + When fulfilling completion requests or other queries, `ide` runs the stored + declarations through the following pipeline: + + =Declarations |> Filters |> Matcher |> CompletionOptions |> Completions= + + First we apply the filters, which either keep a declaration or drop it. Then + we apply Matchers, which can also drop declarations, but assign a score to + the declarations, which determines their ordering. We use this to sort + declarations in terms of how far the edit distance between them and a query + string is, or how many characters we needed to skip for a flex match. + + TODO: links for levenshtein and flex match + + Finally we apply the completion options, which apply certain a certain + formatting, limit the number of results or apply grouping operations. + + All the different filters, matchers and completion options are documented in + the PROTOCOL.md file. + +*** Filters + Filters are functions of type =Map ModuleName [IdeDeclaration] -> Map + ModuleName [IdeDeclaration]=. We keep the =Map= structure around to make the + common case of filtering by module names fast. + +*** Matchers + Matchers operate on individual declarations rather than a =Map=. They also + assign a score to every result, which is a simple Double. +** Adding Imports + Important Files: Ide.Imports +*** We pretty print the entire import section on every import command instead of patching the existing section +**** Pros +- Small diffs if you use =ide= all the time +- Uniform formatting +- Simplifies the implementation +**** Cons +- Big diff on first use +- Makes it hard to maintain comments in between imports, so we just remove them + +*** Formatting Rules for imports +1. Unqualified imports +2. Space divider +3. All the other imports in alphabetic ordering + +**** Pro +- Easy enough to achieve without using =ide= by just sorting the imports linewise +**** Cons +- Can lead to very long import lines +** Rebuilding + Important Files: Ide.Rebuild + +*** The rebuild command acts on a single file input +Unlike the compiler which gets paths to all the modules in our program, the +Rebuild command only gets handed the path to a single module. + +*** IDE's rebuilds are fast +There are two reasons why ide's rebuilds are an order of magnitude faster than +the compilers incremental builds. +**** Rebuild ONLY respects downstream modules +**** All the externs data is already held in RAM +*** Steps rebuilding takes +**** Parse input model +**** Check if FFI file exists and also load that +**** Grab the Externsfiles out of IDE's state +**** Delete the Externsfile corresponding to the module to be rebuilt +**** Convert all the externs files into "shallow modules" which only hold their dependency information +**** Run the compilers topo-sort to figure out all the transitive dependencies of the module we just parsed +**** Rebuild the Environment against the set of externs files we just figured out +*** Extra Rebuild with open imports (only when the first Rebuild succeeds) +This is so that we can mitigate the fact that Externsfiles only give us access +to exported declarations. We rebuild the file a second time, but this time we +remove all the export restrictions before doing so, and store the resulting +Externsfile inside IDE's cache. It's important! that we do not write this file +to disc, because it's incorrect when used by a normal compile or rebuild. +**** The caller gets to decide how the extra Rebuild is run +The primary motivation for this is that we don't need the second build to run to +detect all the compiler errors, so in the usual mode of operation we want to run +it asynchronously and just return the errors/warnings to the editors +immediately. In a test setting however, we might want to test that the rebuild +cache was filled properly and serves completions for private members. (Examples: +Language.PureScript.Ide.RebuildSpec) +** Everything else +* Tips and Tricks +** Running only =ide='s test suite + ~stack test --test-arguments "-m Language.PureScript.Ide"~ +* Facts and thoughts without a good place yet +** Using externs files as source of truth +*** Pros +- Everything has types, because it went through the compiler +- Module visibility is respected, because everything went through the compiler +- Works even when the source file has syntax errors/doesn't compile +- Easy plug-and-play, people rarely change the `output/` directory (as + opposed to the file structure) +- Decoding JSON is fast! (As opposed to parsing source code) +*** Cons +- All type synonyms are expanded (Just something the compiler does) +- Means non-exported values are unaccessible (They should be in scope while + editing the corresponding module though) +- Can serve stale declaration information, eg. a declaration might've been + removed from a module, but the module doesn't compile yet, so the externs + hasn't been overridden and we still suggest the declaration +- Can serve stale module information, when a source file gets deleted, the + corresponding externs file does not. Which means we can't detect whether a + module still exists. +- No source positions or docstrings +** When source globs are added +*** New features enabled +- Enables go-to-definition by allowing us to grab source spans for declarations +- Enables us to recover type signatures without synonyms expanded +- Enables us to grab docstrings (We don't do that yet, unfortunately) +*** Cons +- Slower startup (Actually the load command takes longer, but because the server + is useless until load has been run I count that as startup). Startup on + slamdata is at around 5-6seconds. +- Higher memory footprint. We hold the ASTs for all the modules and add + additional information to the declarations TODO: quantify this for slamdata +- It's harder to watch source files for changes, because they aren't collected + in a single directory (which is why we don't do it) +** PureScript's package story involves downloading all the source +- Great for us, because we get go-to-definition and docstrings without having to + query some external resource +** Keeping everything in memory +*** Pros +- All data is regenerated on starting ide = no cache invalidation necessary +- Things are fast, without any effort spent on optimizing things +- Simple model, keeps complexity low +- We don't polute projects with ide artifacts +*** Cons +- Imposes a limit on how big of a project we can handle +- Means we need to be careful about what information we denormalize, since it + can blow up on us +- All data is regenerated on starting ide = slower startup than (maybe?) necessary +- Impossible to share information between projects (for shared dependencies) From b515a8011d27a73b30fe1f7796b8dc9e096661a4 Mon Sep 17 00:00:00 2001 From: b123400 Date: Sun, 22 Oct 2017 04:36:03 +0800 Subject: [PATCH 0897/1580] Add position to type class declaration error (#3109) --- src/Language/PureScript/TypeChecker.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 0d92edcf5d..96d2064c5e 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -315,9 +315,10 @@ typeCheckAll moduleName _ = traverse go return d go d@FixityDeclaration{} = return d go d@ImportDeclaration{} = return d - go d@(TypeClassDeclaration _ pn args implies deps tys) = do - addTypeClass moduleName pn args implies deps tys - return d + go d@(TypeClassDeclaration (ss, _) pn args implies deps tys) = do + warnAndRethrow (addHint (ErrorInTypeClassDeclaration pn) . addHint (PositionedError ss)) $ do + addTypeClass moduleName pn args implies deps tys + return d go (d@(TypeInstanceDeclaration (ss, _) dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys) . addHint (PositionedError ss)) $ do env <- getEnv From 129a378e956333ab9a4b01210293cf3724545fee Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sat, 21 Oct 2017 23:57:51 +0100 Subject: [PATCH 0898/1580] Error on duplicate type class or instance declarations (#3126) --- examples/failing/DuplicateInstance.purs | 6 ++++++ examples/failing/DuplicateTypeClass.purs | 4 ++++ src/Language/PureScript/AST/Declarations.hs | 2 ++ src/Language/PureScript/Errors.hs | 10 ++++++++++ src/Language/PureScript/TypeChecker.hs | 19 +++++++++++++------ 5 files changed, 35 insertions(+), 6 deletions(-) create mode 100644 examples/failing/DuplicateInstance.purs create mode 100644 examples/failing/DuplicateTypeClass.purs diff --git a/examples/failing/DuplicateInstance.purs b/examples/failing/DuplicateInstance.purs new file mode 100644 index 0000000000..bb3c13e20f --- /dev/null +++ b/examples/failing/DuplicateInstance.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DuplicateInstance +module Main where +class X +class Y +instance i :: X +instance i :: Y diff --git a/examples/failing/DuplicateTypeClass.purs b/examples/failing/DuplicateTypeClass.purs new file mode 100644 index 0000000000..969c3e3c17 --- /dev/null +++ b/examples/failing/DuplicateTypeClass.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith DuplicateTypeClass +module Main where +class C +class C diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index f2981eecad..77012c336a 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -94,6 +94,8 @@ data SimpleErrorMessage | DeclConflict Name Name | ExportConflict (Qualified Name) (Qualified Name) | DuplicateModule ModuleName [SourceSpan] + | DuplicateTypeClass (ProperName 'ClassName) SourceSpan + | DuplicateInstance Ident SourceSpan | DuplicateTypeArgument Text | InvalidDoBind | InvalidDoLet diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 1e09a8f94e..bd447fba8c 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -103,6 +103,8 @@ errorCode em = case unwrapErrorMessage em of DeclConflict{} -> "DeclConflict" ExportConflict{} -> "ExportConflict" DuplicateModule{} -> "DuplicateModule" + DuplicateTypeClass{} -> "DuplicateTypeClass" + DuplicateInstance{} -> "DuplicateInstance" DuplicateTypeArgument{} -> "DuplicateTypeArgument" InvalidDoBind -> "InvalidDoBind" InvalidDoLet -> "InvalidDoLet" @@ -536,6 +538,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line ("Module " <> markCode (runModuleName mn) <> " has been defined multiple times:") , indent . paras $ map (line . displaySourceSpan relPath) ss ] + renderSimpleErrorMessage (DuplicateTypeClass pn ss) = + paras [ line ("Type class " <> markCode (runProperName pn) <> " has been defined multiple times:") + , indent $ line $ displaySourceSpan relPath ss + ] + renderSimpleErrorMessage (DuplicateInstance pn ss) = + paras [ line ("Instance " <> markCode (showIdent pn) <> " has been defined multiple times:") + , indent $ line $ displaySourceSpan relPath ss + ] renderSimpleErrorMessage (CycleInDeclaration nm) = line $ "The value of " <> markCode (showIdent nm) <> " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 96d2064c5e..63875ad0d4 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -116,17 +116,16 @@ addValue moduleName name ty nameKind = do addTypeClass :: forall m . (MonadState CheckState m, MonadError MultipleErrors m) - => ModuleName - -> ProperName 'ClassName + => Qualified (ProperName 'ClassName) -> [(Text, Maybe Kind)] -> [Constraint] -> [FunctionalDependency] -> [Declaration] -> m () -addTypeClass moduleName pn args implies dependencies ds = do +addTypeClass qualifiedClassName args implies dependencies ds = do env <- getEnv traverse_ (checkMemberIsUsable (typeSynonyms env)) classMembers - modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) newClass (typeClasses . checkEnv $ st) } } + modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert qualifiedClassName newClass (typeClasses . checkEnv $ st) } } where classMembers :: [(Ident, Type)] classMembers = map toPair ds @@ -317,11 +316,19 @@ typeCheckAll moduleName _ = traverse go go d@ImportDeclaration{} = return d go d@(TypeClassDeclaration (ss, _) pn args implies deps tys) = do warnAndRethrow (addHint (ErrorInTypeClassDeclaration pn) . addHint (PositionedError ss)) $ do - addTypeClass moduleName pn args implies deps tys + env <- getEnv + let qualifiedClassName = Qualified (Just moduleName) pn + guardWith (errorMessage (DuplicateTypeClass pn ss)) $ + not (M.member qualifiedClassName (typeClasses env)) + addTypeClass qualifiedClassName args implies deps tys return d go (d@(TypeInstanceDeclaration (ss, _) dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys) . addHint (PositionedError ss)) $ do env <- getEnv + let qualifiedDictName = Qualified (Just moduleName) dictName + flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries -> + guardWith (errorMessage (DuplicateInstance dictName ss)) $ + not (M.member qualifiedDictName dictionaries) case M.lookup className (typeClasses env) of Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" Just typeClass -> do @@ -330,7 +337,7 @@ typeCheckAll moduleName _ = traverse go checkOrphanInstance dictName className typeClass tys _ <- traverseTypeInstanceBody checkInstanceMembers body deps' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps - let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps') + let dict = TypeClassDictionaryInScope qualifiedDictName [] className tys (Just deps') addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict return d From 048705f87e4c1b4cd4788e31a2763498f554926d Mon Sep 17 00:00:00 2001 From: Nicholas Scheel Date: Mon, 23 Oct 2017 12:54:41 -0500 Subject: [PATCH 0899/1580] Desugar nested parentheses (#3086) This caused an issue in inferring kinds (Invalid argument ...) then in unifying types (Could not match type Unit with Unit), but desugaring it earlier fixes both of those problems. --- examples/passing/ParensInType.purs | 20 ++++++++++++++++++++ src/Language/PureScript/Sugar/Operators.hs | 6 +++--- 2 files changed, 23 insertions(+), 3 deletions(-) create mode 100644 examples/passing/ParensInType.purs diff --git a/examples/passing/ParensInType.purs b/examples/passing/ParensInType.purs new file mode 100644 index 0000000000..75d0120996 --- /dev/null +++ b/examples/passing/ParensInType.purs @@ -0,0 +1,20 @@ +module Main where + +import Prelude +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) + +class Foo a where + foo :: forall eff. (String -> a (( console :: CONSOLE | eff)) ((Unit))) + +instance fooLogEff :: Foo Eff where + foo = log + +main :: + forall eff. + Eff + ( console :: CONSOLE + | eff + ) + Unit +main = foo "Done" diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index b4b9714e8e..f8033beab4 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -230,15 +230,15 @@ removeParens = f (goDecl, goExpr', goBinder') = updateTypes (\_ -> return . goType) goExpr :: Expr -> Expr - goExpr (Parens val) = val + goExpr (Parens val) = goExpr val goExpr val = val goBinder :: Binder -> Binder - goBinder (ParensInBinder b) = b + goBinder (ParensInBinder b) = goBinder b goBinder b = b goType :: Type -> Type - goType (ParensInType t) = t + goType (ParensInType t) = goType t goType t = t decontextify From 6a30b5667df98368166736e2ed01520e993035fb Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sat, 28 Oct 2017 11:41:53 +0100 Subject: [PATCH 0900/1580] Fix #3131 Ide inserts conflicting imports for types (#3139) --- src/Language/PureScript/Ide/Imports.hs | 5 +++++ tests/Language/PureScript/Ide/ImportsSpec.hs | 16 ++++++++++++++++ 2 files changed, 21 insertions(+) diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 251864909d..82ec75c08b 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -220,6 +220,11 @@ addExplicitImport' decl moduleName qualifier imports = (insertDtor (dtor ^. ideDtorName)) (refFromDeclaration d) refs + insertDeclIntoRefs (IdeDeclType t) refs + | any matches refs = refs + where + matches (P.TypeRef _ typeName _) = _ideTypeName t == typeName + matches _ = False insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) insertDtor _ (P.TypeRef ss tn' _) = P.TypeRef ss tn' Nothing diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 71a883cde1..b7c81966da 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -252,6 +252,22 @@ spec = do , "" , "import Data.Maybe (Maybe(..))" ] + it "adding a type to an existing import of that type is noop" $ do + let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe)"]) + shouldBe + (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") Nothing typeImports) + [ "import Prelude" + , "" + , "import Data.Maybe (Maybe)" + ] + it "adding a type to an existing import of that type with its constructors is noop" $ do + let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe (..))"]) + shouldBe + (addTypeImport "Maybe" (P.moduleNameFromString "Data.Maybe") Nothing typeImports) + [ "import Prelude" + , "" + , "import Data.Maybe (Maybe(..))" + ] it "adds a dataconstructor to an existing qualified type import" $ do let Right (_, _, typeImports, _) = sliceImportSection (withImports ["import Data.Maybe (Maybe) as M"]) shouldBe From 64d6c5a2e03a03894445c59ef65e6a2bca854d58 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sat, 28 Oct 2017 21:45:20 +0100 Subject: [PATCH 0901/1580] Instantiate abstraction body during inference (#3128) --- examples/passing/3125.purs | 16 ++++++++++++++++ src/Language/PureScript/TypeChecker/Types.hs | 3 ++- 2 files changed, 18 insertions(+), 1 deletion(-) create mode 100644 examples/passing/3125.purs diff --git a/examples/passing/3125.purs b/examples/passing/3125.purs new file mode 100644 index 0000000000..d427fd46bb --- /dev/null +++ b/examples/passing/3125.purs @@ -0,0 +1,16 @@ +module Main where + +import Prelude +import Data.Monoid (class Monoid, mempty) +import Control.Monad.Eff.Console (log, logShow) + +data B a = B a a + +memptyB :: forall a b. Monoid b => B (a -> b) +memptyB = B l r where + l _ = mempty + r _ = mempty + +main = do + logShow $ case (memptyB :: B (Int -> Array Unit)) of B l r -> l 0 == r 0 + log "Done" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index ba438a34c2..f96771a8b0 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -357,7 +357,8 @@ infer' (Abs binder ret) ty <- freshType withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do body@(TypedValue _ _ bodyTy) <- infer' ret - return $ TypedValue True (Abs (VarBinder arg) body) $ function ty bodyTy + (body', bodyTy') <- instantiatePolyTypeWithUnknowns body bodyTy + return $ TypedValue True (Abs (VarBinder arg) body') (function ty bodyTy') | otherwise = internalError "Binder was not desugared" infer' (App f arg) = do f'@(TypedValue _ _ ft) <- infer f From a85b7e97ef651f53e873bb17c2a0620fa3d1e588 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Mon, 30 Oct 2017 09:13:00 +0000 Subject: [PATCH 0902/1580] [purs ide] return documentation comments (#3138) --- .../PureScript/Docs/Convert/Single.hs | 1 + src/Language/PureScript/Ide/Completion.hs | 2 +- src/Language/PureScript/Ide/State.hs | 85 +++++++++++++++---- src/Language/PureScript/Ide/Types.hs | 3 +- .../Language/PureScript/Ide/CompletionSpec.hs | 34 +++++++- .../pscide/src/CompletionSpecDocs.purs | 13 +++ 6 files changed, 118 insertions(+), 20 deletions(-) create mode 100644 tests/support/pscide/src/CompletionSpecDocs.purs diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 76810c1f9e..6b16d5766c 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -1,5 +1,6 @@ module Language.PureScript.Docs.Convert.Single ( convertSingleModule + , convertComments ) where import Protolude hiding (moduleName) diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index b4e9f2ed66..eace77b3fa 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -130,7 +130,7 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl), mns) = complLocation = _annLocation ann - complDocumentation = Nothing + complDocumentation = _annDocumentation ann showFixity p a r o = let asso = case a of diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index f7d7a57a6c..28211f9423 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -44,6 +44,7 @@ import Control.Lens hiding (op, (&)) import "monad-logger" Control.Monad.Logger import qualified Data.Map.Lazy as Map import qualified Language.PureScript as P +import Language.PureScript.Docs.Convert.Single (convertComments) import Language.PureScript.Externs import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Reexports @@ -199,6 +200,7 @@ populateVolatileStateSTM ref = do moduleDeclarations & map resolveDataConstructorsForModule & resolveLocations asts + & resolveDocumentation (map fst modules) & resolveInstances externs & resolveOperators & resolveReexports reexportRefs @@ -221,23 +223,7 @@ resolveLocationsForModule (defs, types) decls = map convertDeclaration decls where convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn - convertDeclaration (IdeDeclarationAnn ann d) = case d of - IdeDeclValue v -> - annotateFunction (v ^. ideValueIdent) (IdeDeclValue v) - IdeDeclType t -> - annotateType (t ^. ideTypeName . properNameT) (IdeDeclType t) - IdeDeclTypeSynonym s -> - annotateType (s ^. ideSynonymName . properNameT) (IdeDeclTypeSynonym s) - IdeDeclDataConstructor dtor -> - annotateValue (dtor ^. ideDtorName . properNameT) (IdeDeclDataConstructor dtor) - IdeDeclTypeClass tc -> - annotateType (tc ^. ideTCName . properNameT) (IdeDeclTypeClass tc) - IdeDeclValueOperator operator -> - annotateValue (operator ^. ideValueOpName . opNameT) (IdeDeclValueOperator operator) - IdeDeclTypeOperator operator -> - annotateType (operator ^. ideTypeOpName . opNameT) (IdeDeclTypeOperator operator) - IdeDeclKind i -> - annotateKind (i ^. properNameT) (IdeDeclKind i) + convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' annotateFunction annotateValue annotateType annotateKind d where annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs , _annTypeAnnotation = Map.lookup x types @@ -246,6 +232,71 @@ resolveLocationsForModule (defs, types) decls = annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs}) annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSKind x) defs}) +convertDeclaration' + :: (P.Ident -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> IdeDeclaration + -> IdeDeclarationAnn +convertDeclaration' annotateFunction annotateValue annotateType annotateKind d = + case d of + IdeDeclValue v -> + annotateFunction (v ^. ideValueIdent) d + IdeDeclType t -> + annotateType (t ^. ideTypeName . properNameT) d + IdeDeclTypeSynonym s -> + annotateType (s ^. ideSynonymName . properNameT) d + IdeDeclDataConstructor dtor -> + annotateValue (dtor ^. ideDtorName . properNameT) d + IdeDeclTypeClass tc -> + annotateType (tc ^. ideTCName . properNameT) d + IdeDeclValueOperator operator -> + annotateValue (operator ^. ideValueOpName . opNameT) d + IdeDeclTypeOperator operator -> + annotateType (operator ^. ideTypeOpName . opNameT) d + IdeDeclKind i -> + annotateKind (i ^. properNameT) d + +resolveDocumentation + :: ModuleMap P.Module + -> ModuleMap [IdeDeclarationAnn] + -> ModuleMap [IdeDeclarationAnn] +resolveDocumentation modules = + Map.mapWithKey (\mn decls -> + maybe decls (flip resolveDocumentationForModule decls) (Map.lookup mn modules)) + +resolveDocumentationForModule + :: P.Module + -> [IdeDeclarationAnn] + -> [IdeDeclarationAnn] +resolveDocumentationForModule (P.Module _ _ _ sdecls _) decls = map convertDecl decls + where + comments :: Map P.Name [P.Comment] + comments = Map.fromListWith (flip (<>)) $ mapMaybe (\d -> + case name d of + Just name' -> Just (name', snd $ P.declSourceAnn d) + _ -> Nothing) + sdecls + + name :: P.Declaration -> Maybe P.Name + name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d + name decl = P.declName decl + + convertDecl :: IdeDeclarationAnn -> IdeDeclarationAnn + convertDecl (IdeDeclarationAnn ann d) = + convertDeclaration' + (annotateValue . P.IdentName) + (annotateValue . P.IdentName . P.Ident) + (annotateValue . P.TyName . P.ProperName) + (annotateValue . P.KiName . P.ProperName) + d + where + docs :: P.Name -> Text + docs ident = fromMaybe "" $ convertComments =<< Map.lookup ident comments + + annotateValue ident = IdeDeclarationAnn (ann { _annDocumentation = Just $ docs ident }) + resolveInstances :: ModuleMap P.ExternsFile -> ModuleMap [IdeDeclarationAnn] diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index a19a2d72da..f013ace268 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -114,13 +114,14 @@ data Annotation { _annLocation :: Maybe P.SourceSpan , _annExportedFrom :: Maybe P.ModuleName , _annTypeAnnotation :: Maybe P.Type + , _annDocumentation :: Maybe Text } deriving (Show, Eq, Ord, Generic, NFData) makeLenses ''Annotation makeLenses ''IdeDeclarationAnn emptyAnn :: Annotation -emptyAnn = Annotation Nothing Nothing Nothing +emptyAnn = Annotation Nothing Nothing Nothing Nothing type DefinitionSites a = Map IdeNamespaced a type TypeAnnotations = Map P.Ident P.Type diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs index 255d6974c6..4df331aad4 100644 --- a/tests/Language/PureScript/Ide/CompletionSpec.hs +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -5,10 +5,12 @@ module Language.PureScript.Ide.CompletionSpec where import Protolude import Language.PureScript as P +import Language.PureScript.Ide.Test as Test +import Language.PureScript.Ide.Command as Command import Language.PureScript.Ide.Completion -import Language.PureScript.Ide.Test import Language.PureScript.Ide.Types import Test.Hspec +import System.FilePath reexportMatches :: [Match IdeDeclarationAnn] reexportMatches = @@ -21,6 +23,15 @@ reexportMatches = matches :: [(Match IdeDeclarationAnn, [P.ModuleName])] matches = map (\d -> (Match (mn "Main", d), [mn "Main"])) [ ideKind "Kind", ideType "Type" Nothing [] ] +typ :: Text -> Command +typ txt = Type txt [] Nothing + +load :: [Text] -> Command +load = LoadSync . map Test.mn + +rebuildSync :: FilePath -> Command +rebuildSync fp = RebuildSync ("src" fp) Nothing + spec :: Spec spec = describe "Applying completion options" $ do it "keeps all matches if maxResults is not specified" $ do @@ -32,3 +43,24 @@ spec = describe "Applying completion options" $ do it "groups reexports for a single identifier" $ do applyCompletionOptions (defaultCompletionOptions { coGroupReexports = True }) reexportMatches `shouldBe` [(Match (mn "A", ideKind "Kind"), [mn "A", mn "B"])] + + it "gets simple docs on definition itself" $ do + ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpecDocs"] + , typ "something" + ] + result `shouldSatisfy` \res -> complDocumentation res == Just "Doc x\n" + + it "gets multiline docs" $ do + ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpecDocs"] + , typ "multiline" + ] + result `shouldSatisfy` \res -> complDocumentation res == Just "This is\na multi-line\ncomment\n" + + it "gets simple docs on type annotation" $ do + ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpecDocs"] + , typ "withType" + ] + result `shouldSatisfy` \res -> complDocumentation res == Just "Doc *123*\n" \ No newline at end of file diff --git a/tests/support/pscide/src/CompletionSpecDocs.purs b/tests/support/pscide/src/CompletionSpecDocs.purs new file mode 100644 index 0000000000..1c92a37752 --- /dev/null +++ b/tests/support/pscide/src/CompletionSpecDocs.purs @@ -0,0 +1,13 @@ +module CompletionSpecDocs where + +-- | Doc x +something = "something" + +-- | Doc *123* +withType :: Int +withType = 42 + +-- | This is +-- | a multi-line +-- | comment +multiline = "multiline" \ No newline at end of file From 56b345108479984c995e15e503d9c896bcf3ac34 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 31 Oct 2017 16:07:04 -0700 Subject: [PATCH 0903/1580] Add docs for duplicate labels in record types (#3143) * Add docs for duplicate labels in record types * Typo --- src/Language/PureScript/Docs/Prim.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index aa8b68c3e4..66c478411a 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -148,6 +148,12 @@ record = primType "Record" $ T.unlines , "The syntactic sugar with curly braces `{ }` is generally preferred, though:" , "" , " type Person = { name :: String, age :: Number }" + , "" + , "The row associates a type to each label which appears in the record." + , "" + , "_Technical note_: PureScript allows duplicate labels in rows, and the" + , "meaning of `Record r` is based on the _first_ occurrence of each label in" + , "the row `r`." ] number :: Declaration From b2004c9781b17ba5e79d26962e87ce0f6b2c9821 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 7 Nov 2017 20:45:08 -0800 Subject: [PATCH 0904/1580] 0.11.7 --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index ddeb153eec..52b66f0da1 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.11.6' +version: '0.11.7' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 15d7330b3adb7f8d941052a7cfc4df075724d248 Mon Sep 17 00:00:00 2001 From: Thimoteus Date: Tue, 14 Nov 2017 18:27:56 -0800 Subject: [PATCH 0905/1580] correctly quote uppercased field labels which would otherwise remain unquoted (#3148) --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Pretty/Common.hs | 6 +++++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 96f7e5f41c..30ae2b4e56 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -113,6 +113,7 @@ If you would prefer to use different terms, please use the section below instead | [@b123400](https://github.com/b123400) | b123400 | [MIT license](https://opensource.org/licenses/MIT) | | [@drets](https://github.com/drets) | Dmytro Rets | [MIT license](http://opensource.org/licenses/MIT) | | [@bjornmelgaaard](https://github.com/BjornMelgaard) | Sergey Homa | [MIT license](http://opensource.org/licenses/MIT) | +| [@thimoteus](https://github.com/Thimoteus) | thimoteus | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 32b5ea2608..b7280232e7 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -13,6 +13,7 @@ import Data.List (elemIndices, intersperse) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T +import Data.Char (isUpper) import Language.PureScript.AST (SourcePos(..), SourceSpan(..)) import Language.PureScript.Parser.Lexer (isUnquotedKey, reservedPsNames) @@ -148,7 +149,10 @@ prettyPrintMany f xs = do objectKeyRequiresQuoting :: Text -> Bool objectKeyRequiresQuoting s = - s `elem` reservedPsNames || not (isUnquotedKey s) + s `elem` reservedPsNames || not (isUnquotedKey s) || startsUppercase s where + startsUppercase label = case T.uncons label of + Just (c, _) -> isUpper c + _ -> False -- | Place a box before another, vertically when the first box takes up multiple lines. before :: Box -> Box -> Box From 14227c7151d1a907bf7f00af5701ab61dadb1c0b Mon Sep 17 00:00:00 2001 From: Simon Date: Sun, 19 Nov 2017 15:17:23 +0100 Subject: [PATCH 0906/1580] pretty print proxy types when rendering docs (#3144) * pretty print proxy types when rendering docs * add tests for proxy doc * changed contributors --- CONTRIBUTORS.md | 1 + examples/docs/src/Proxy.purs | 4 ++++ src/Language/PureScript/Docs/RenderedCode/RenderType.hs | 9 ++++++++- tests/TestDocs.hs | 4 ++++ 4 files changed, 17 insertions(+), 1 deletion(-) create mode 100644 examples/docs/src/Proxy.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 644eec55d7..818378b926 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -115,6 +115,7 @@ If you would prefer to use different terms, please use the section below instead | [@kcsongor](https://github.com/kcsongor) | Csongor Kiss | [MIT license](http://opensource.org/licenses/MIT) | | [@drets](https://github.com/drets) | Dmytro Rets | [MIT license](http://opensource.org/licenses/MIT) | | [@bjornmelgaaard](https://github.com/BjornMelgaard) | Sergey Homa | [MIT license](http://opensource.org/licenses/MIT) | +| [@sloosch](https://github.com/sloosch) | Simon Looschen | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/examples/docs/src/Proxy.purs b/examples/docs/src/Proxy.purs new file mode 100644 index 0000000000..9a6544d796 --- /dev/null +++ b/examples/docs/src/Proxy.purs @@ -0,0 +1,4 @@ +module Proxy where + +foo :: @Int +foo = @Int diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index 15f51dc94c..114a03d12d 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -96,6 +96,12 @@ renderTail :: Type -> RenderedCode renderTail REmpty = mempty renderTail other = sp <> syntax "|" <> sp <> renderType other +proxyType :: Pattern () Type ((), Type) +proxyType = mkPattern match + where + match (ProxyType t) = Just ((), t) + match _ = Nothing + typeApp :: Pattern () Type (Type, Type) typeApp = mkPattern match where @@ -136,7 +142,8 @@ matchType = buildPrettyPrinter operators matchTypeAtom where operators :: OperatorTable () Type RenderedCode operators = - OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ] + OperatorTable [ [ Wrap proxyType $ \_ ty -> syntax "@" <> ty ] + , [ AssocL typeApp $ \f x -> f <> sp <> x ] , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ] , [ Wrap constrained $ \deps ty -> renderConstraints deps ty ] , [ Wrap forall_ $ \tyVars ty -> mconcat [keywordForall, sp, mintersperse sp (map typeVar tyVars), syntax ".", sp, ty] ] diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index e486988575..958adb8078 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -564,6 +564,10 @@ testCases = , ("DeclOrderNoExportList", shouldBeOrdered (n "DeclOrderNoExportList") [ "x1", "x3", "X2", "X4", "A", "B" ]) + + , ("Proxy", + [ ValueShouldHaveTypeSignature (n "Proxy") "foo" (renderedType "@Int") + ]) ] where From 82a47da5a2b47ddce4f5c83289335057f6c8f6a5 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 21 Nov 2017 15:18:07 +0000 Subject: [PATCH 0907/1580] Update Glob library, fixes #3055 (#3156) * Update Glob library, fixes #3055 Also update the Stackage snapshot so that we get the latest version of Glob, which includes memory usage and performance fixes. * Reduce timeout threshold to help avoid CI failures --- package.yaml | 2 +- stack.yaml | 2 +- travis/build.sh | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/package.yaml b/package.yaml index 52b66f0da1..c89f0f75b4 100644 --- a/package.yaml +++ b/package.yaml @@ -52,7 +52,7 @@ dependencies: - file-embed - filepath - fsnotify >=0.2.1 - - Glob >=0.7 && <0.9 + - Glob >=0.9 && <0.10 - haskeline >=0.7.0.0 - http-client >=0.4.30 && <0.6.0 - http-types diff --git a/stack.yaml b/stack.yaml index df22368d47..4336168e7a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2017-09-10 +resolver: nightly-2017-11-20 packages: - '.' extra-deps: diff --git a/travis/build.sh b/travis/build.sh index 679612883b..5005a5f9ed 100755 --- a/travis/build.sh +++ b/travis/build.sh @@ -5,7 +5,7 @@ STACK="stack --no-terminal --jobs=1" # Setup & install dependencies or abort ret=0 -$TIMEOUT 40m $STACK --install-ghc build \ +$TIMEOUT 30m $STACK --install-ghc build \ --only-dependencies --test --haddock \ || ret=$? case "$ret" in From 6e1903649b8c43a5fe1188b8563825a71a8e88a4 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 21 Nov 2017 16:57:22 +0000 Subject: [PATCH 0908/1580] Empty commit to fix Travis From adf3a29706765a2001ddcfe89acadfbd4c6ad05a Mon Sep 17 00:00:00 2001 From: Brandon Martin Date: Mon, 27 Nov 2017 22:21:53 -0800 Subject: [PATCH 0909/1580] remove stack 7.10 yaml file (#3161) --- stack-ghc-7.10.yaml | 7 ------- 1 file changed, 7 deletions(-) delete mode 100644 stack-ghc-7.10.yaml diff --git a/stack-ghc-7.10.yaml b/stack-ghc-7.10.yaml deleted file mode 100644 index 4e9e34c595..0000000000 --- a/stack-ghc-7.10.yaml +++ /dev/null @@ -1,7 +0,0 @@ -resolver: lts-6.25 -packages: -- '.' -extra-deps: -- aeson-better-errors-0.9.1.0 -- bower-json-1.0.0.1 -- optparse-applicative-0.13.0.0 From 559ae9e2fb415ca0bc67253dc9f81ef8373ae159 Mon Sep 17 00:00:00 2001 From: Nicholas Kircher Date: Sat, 9 Dec 2017 23:23:45 +1100 Subject: [PATCH 0910/1580] Added pre-built installers to INSTALL.md (#3167) * Added pre-built installers to INSTALL.md Added 3 examples of installing the latest pre-built PureScript compiler binary, for Homebrew, NPM and PSVM. Also added reference to FPChat Slack channel for getting help with PureScript. * Added self to contributors --- CONTRIBUTORS.md | 1 + INSTALL.md | 13 ++++++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 3fa63e2962..bf60a312dc 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -65,6 +65,7 @@ If you would prefer to use different terms, please use the section below instead | [@lukerandall](https://github.com/lukerandall) | Luke Randall | [MIT license](http://opensource.org/licenses/MIT) | | [@matthewleon](https://github.com/matthewleon) | Matthew Leon | [MIT license](http://opensource.org/licenses/MIT) | | [@mcoffin](https://github.com/mcoffin) | Matt Coffin | [MIT license](http://opensource.org/licenses/MIT) | +| [@MiracleBlue](https://github.com/MiracleBlue) | Nicholas Kircher | [MIT license](http://opensource.org/licenses/MIT) | | [@mrkgnao](https://github.com/mrkgnao) | Soham Chowdhury | [MIT license](http://opensource.org/licenses/MIT) | | [@mgmeier](https://github.com/mgmeier) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) | | [@michaelficarra](https://github.com/michaelficarra) | Michael Ficarra | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/INSTALL.md b/INSTALL.md index 27f170a8d5..bf42c749e3 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -1,7 +1,7 @@ # Installation information If you are having difficulty installing the PureScript compiler, feel free to -ask for help! A good place is the #purescript IRC channel on Freenode, or +ask for help! A good place is the #purescript IRC channel on Freenode, the #purescript channel on [FPChat Slack](https://fpchat-invite.herokuapp.com/), or alternatively Stack Overflow. ## Using prebuilt binaries @@ -20,6 +20,17 @@ from source; see below. Other prebuilt distributions (eg, Homebrew, AUR, npm) will probably have the same requirements. +## Installing a pre-built distribution + +There are several options available for aquiring a pre-built binary of the PureScript compiler. This is by no means an exhaustive list, and is presented in no particular order. Each example is expected to install the latest available compiler version at the time of running the command. Many of these are provided and maintained by the community, and may not be immediately up to date. + +* NPM: `npm install -g purescript` +* Homebrew (for OS X): `brew install purescript` +* [PSVM](https://github.com/ThomasCrevoisier/psvm-js) (PS Version Manager): + 1) `psvm install-latest` will install the latest version available + 2) `psvm latest` will print the latest version number available + 3) `psvm use ` will enable the version we just installed. For example, if the version is `v0.11.7`, you'd run `psvm use v0.11.7` + ## Compiling from source The easiest way is to use stack: From 31de60ba85d0c89b34ea726384548e817758e716 Mon Sep 17 00:00:00 2001 From: b123400 Date: Wed, 20 Dec 2017 19:40:07 +0800 Subject: [PATCH 0911/1580] Add position information for type warning (#3174) --- src/Language/PureScript/Linter.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 271bb62247..cabb840c20 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -49,7 +49,8 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl f' :: S.Set Text -> Declaration -> MultipleErrors f' s dec@(ValueDeclaration vd) = addHint (ErrorInValueDeclaration (valdeclIdent vd)) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec) - f' s (TypeDeclaration td) = addHint (ErrorInTypeDeclaration (tydeclIdent td)) (checkTypeVars s (tydeclType td)) + f' s (TypeDeclaration td@(TypeDeclarationData (ss, _) _ _)) = + addHint (PositionedError ss) $ addHint (ErrorInTypeDeclaration (tydeclIdent td)) (checkTypeVars s (tydeclType td)) f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec stepE :: S.Set Ident -> Expr -> MultipleErrors From 6c14cab09c1c0dbb3a1cd598075fd2da62017f36 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Wed, 20 Dec 2017 14:47:59 -0700 Subject: [PATCH 0912/1580] Print error message on failed examples (#3181) * Print error message * Add newline * Add myself :D [skip ci] --- CONTRIBUTORS.md | 1 + tests/TestCompiler.hs | 4 +++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index bf60a312dc..620c7929df 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -80,6 +80,7 @@ If you would prefer to use different terms, please use the section below instead | [@nwolverson](https://github.com/nwolverson) | Nicholas Wolverson | [MIT license](http://opensource.org/licenses/MIT) | | [@osa1](https://github.com/osa1) | Ömer Sinan Ağacan | MIT license | | [@paf31](https://github.com/paf31) | Phil Freeman | [MIT license](http://opensource.org/licenses/MIT) | +| [@parsonsmatt](https://github.com/parsonsmatt) | Matt Parsons | [MIT license](http://opensource.org/licenses/MIT) | | [@passy](https://github.com/passy) | Pascal Hartig | [MIT license](http://opensource.org/licenses/MIT) | | [@paulyoung](https://github.com/paulyoung) | Paul Young | [MIT license](http://opensource.org/licenses/MIT) | | [@pelotom](https://github.com/pelotom) | Thomas Crockett | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index de8f19f854..3cce623d09 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -227,7 +227,9 @@ checkShouldFailWith expected errs = let actual = map P.errorCode $ P.runMultipleErrors errs in if sort expected == sort (map T.unpack actual) then Nothing - else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual + else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " + ++ show actual ++ ", full error messages: \n" + ++ unlines (map (P.renderBox . P.prettyPrintSingleError P.defaultPPEOptions) (P.runMultipleErrors errs)) assertCompiles :: [P.Module] From 86b00306cc95c0d8867425bf6c6fc930d4c4480e Mon Sep 17 00:00:00 2001 From: Eoin Houlihan Date: Fri, 22 Dec 2017 11:51:39 +0000 Subject: [PATCH 0913/1580] Fix functional dependencies rendering as links (#3184) * Fix functional dependencies rendering as links * Rename idents to typeVars --- src/Language/PureScript/Docs/Render.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index b60cae8e0d..572449386e 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -67,10 +67,10 @@ renderDeclarationWithOptions opts Declaration{..} = [syntax "|" | not (null fundeps)] ++ [mintersperse (syntax "," <> sp) - [idents from <> sp <> syntax "->" <> sp <> idents to | (from, to) <- fundeps ] + [typeVars from <> sp <> syntax "->" <> sp <> typeVars to | (from, to) <- fundeps ] ] where - idents = mintersperse sp . map ident' + typeVars = mintersperse sp . map typeVar AliasDeclaration (P.Fixity associativity precedence) for -> [ keywordFixity associativity From 94197b36f2502f4373e5488ad502091cb34eb335 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Fri, 29 Dec 2017 03:30:33 -0700 Subject: [PATCH 0914/1580] Add test cases for #3114 (#3175) --- examples/passing/3114.purs | 53 ++++++++++++++++++++++ examples/passing/3114/VendoredVariant.purs | 40 ++++++++++++++++ 2 files changed, 93 insertions(+) create mode 100644 examples/passing/3114.purs create mode 100644 examples/passing/3114/VendoredVariant.purs diff --git a/examples/passing/3114.purs b/examples/passing/3114.purs new file mode 100644 index 0000000000..9d330b14bd --- /dev/null +++ b/examples/passing/3114.purs @@ -0,0 +1,53 @@ +module Main where + +import Prelude + +import Data.Either +import Data.Maybe +import Data.Tuple +import Control.Monad.Eff +import Control.Monad.Eff.Console (log) +import VendoredVariant +import Data.Symbol + +type TestVariants = + ( foo :: FProxy Maybe + , bar :: FProxy (Tuple String) + ) + +_foo :: SProxy "foo" +_foo = SProxy + +_bar :: SProxy "bar" +_bar = SProxy + +main :: Eff _ Unit +main = do + let + -- with the type signatures on `a`, this compiles fine. + case1 :: VariantF TestVariants Int → String + case1 = case_ + # on _foo (\a → "foo: " <> show (a :: Maybe Int)) + # on _bar (\a → "bar: " <> show (a :: Tuple String Int)) + + -- without the type signature, this would complain about + -- Could not match type + -- Array + -- with type + -- Tuple String + -- while trying to match the type FProxy Array + -- with type FProxy (Tuple String) + -- while solving type class constraint + -- Prim.RowCons "baz" + -- (FProxy t0) + -- t1 + -- ( foo :: FProxy Maybe + -- , bar :: FProxy (Tuple String) + -- ) + -- while inferring the type of `on _baz` + case2 :: VariantF TestVariants Int → String + case2 = case_ + # on _foo (\a → "foo: " <> show a) + # on _bar (\a → "bar: " <> show a) + + log "Done" diff --git a/examples/passing/3114/VendoredVariant.purs b/examples/passing/3114/VendoredVariant.purs new file mode 100644 index 0000000000..a176bb1f91 --- /dev/null +++ b/examples/passing/3114/VendoredVariant.purs @@ -0,0 +1,40 @@ +module VendoredVariant where + +import Prelude + +import Unsafe.Coerce (unsafeCoerce) +import Partial.Unsafe (unsafeCrashWith) +import Data.Symbol + +data FProxy (k :: Type -> Type) = FProxy +data VariantF (f :: # Type) a + +newtype VariantFRep f a = VariantFRep + { type :: String + , value :: f a + , map :: forall x y. (x -> y) -> f x -> f y + } + +case_ :: forall a b. VariantF () a -> b +case_ r = unsafeCrashWith case unsafeCoerce r of + VariantFRep v -> "failure on " <> v.type + +on + :: forall sym f a b r1 r2 + . RowCons sym (FProxy f) r1 r2 + => IsSymbol sym + => SProxy sym + -> (f a -> b) + -> (VariantF r1 a -> b) + -> VariantF r2 a + -> b +on p f g r = + case coerceY r of + VariantFRep v | v.type == reflectSymbol p -> f v.value + _ -> g (coerceR r) + where + coerceY :: VariantF r2 a -> VariantFRep f a + coerceY = unsafeCoerce + + coerceR :: VariantF r2 a -> VariantF r1 a + coerceR = unsafeCoerce From 8afe8c04c99646941466c133fc941f9dc77625d4 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 3 Jan 2018 12:06:27 +0100 Subject: [PATCH 0915/1580] Switch test suite to use tasty (#2848) * Initial switch for test suite to tasty. Still missing docs and publish tests, since these use a custom test runner mechanism * move hierarchy, docs and corefn tests into tasty * silence progress messages through make options Instead of using the silently package, which causes trouble in combination with tasty, since it silences part of its output as well. * documents how to run individidual test suites * documents how to run individual tests --- CONTRIBUTING.md | 14 +++++++------- package.yaml | 11 ++++++----- tests/Main.hs | 34 +++++++++++++++++++++------------- tests/TestCompiler.hs | 11 ++++++----- tests/TestCoreFn.hs | 7 ++++--- tests/TestDocs.hs | 8 +++++--- tests/TestHierarchy.hs | 8 +++++--- tests/TestIde.hs | 17 +++++++++++++++++ tests/TestPscIde.hs | 13 ------------- tests/TestPsci.hs | 8 +++++--- 10 files changed, 76 insertions(+), 55 deletions(-) create mode 100644 tests/TestIde.hs delete mode 100644 tests/TestPscIde.hs diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index ef683c00d8..8ce80c017b 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -17,15 +17,15 @@ Please follow the following guidelines: Run all test suites with `stack test`. You will need `npm`, `bower` and `node` on your PATH to run the tests. -To build and run a specific test in `examples/passing/` or `examples/failing/`, execute the following commands. +You can run individual test suites using `stack test --test-arguments="-p +PATTERN"` where `PATTERN` is one of `compiler`, `repl`, `ide`, `docs`, `corefn`, +or `hierarchy`. -``` bash -# Build -stack exec purs -- compile 'tests/support/bower_components/purescript-*/src/**/*.purs' examples/blah/Blah.purs +To build and run a specific test in `examples/passing/` or `examples/failing/`, add test arguments like so: -# Run -node -e "require('./output/Main/').main()" -``` +`stack test --fast --test-arguments="-p compiler/**1110.purs*"` + +This will run whatever test uses the example file `1110.purs`. ## Code Review diff --git a/package.yaml b/package.yaml index c89f0f75b4..69c0362f15 100644 --- a/package.yaml +++ b/package.yaml @@ -155,11 +155,12 @@ tests: source-dirs: tests ghc-options: -Wall dependencies: - - purescript - - hspec - - hspec-discover - - HUnit - - silently + - purescript + - tasty + - tasty-hspec + - hspec + - hspec-discover + - HUnit flags: release: diff --git a/tests/Main.hs b/tests/Main.hs index 576b288daf..c026938241 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -8,13 +8,15 @@ module Main (main) where import Prelude () import Prelude.Compat +import Test.Tasty + import qualified TestCompiler import qualified TestCoreFn import qualified TestDocs import qualified TestHierarchy import qualified TestPrimDocs import qualified TestPsci -import qualified TestPscIde +import qualified TestIde import qualified TestPscPublish import qualified TestUtils @@ -27,22 +29,28 @@ main = do heading "Updating support code" TestUtils.updateSupportCode - heading "Main compiler test suite" - TestCompiler.main - heading "CoreFn test suite" - TestCoreFn.main - heading "Documentation test suite" - TestDocs.main - heading "Hierarchy test suite" - TestHierarchy.main heading "Prim documentation test suite" TestPrimDocs.main heading "psc-publish test suite" TestPscPublish.main - heading "psci test suite" - TestPsci.main - heading "psc-ide test suite" - TestPscIde.main + + ideTests <- TestIde.main + compilerTests <- TestCompiler.main + psciTests <- TestPsci.main + coreFnTests <- TestCoreFn.main + docsTests <- TestDocs.main + hierarchyTests <- TestHierarchy.main + + defaultMain $ + testGroup + "Tests" + [ compilerTests + , psciTests + , ideTests + , coreFnTests + , docsTests + , hierarchyTests + ] where heading msg = do diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 3cce623d09..bd2edae766 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -49,14 +49,14 @@ import System.FilePath import System.Directory import System.IO import System.IO.UTF8 -import System.IO.Silently import qualified System.FilePath.Glob as Glob import TestUtils -import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec -main :: IO () -main = hspec spec +main :: IO TestTree +main = testSpec "compiler" spec spec :: Spec spec = do @@ -169,6 +169,7 @@ makeActions :: [P.Module] -> M.Map P.ModuleName FilePath -> P.MakeActions P.Make makeActions modules foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False) { P.getInputTimestamp = getInputTimestamp , P.getOutputTimestamp = getOutputTimestamp + , P.progress = const (pure ()) } where getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime)) @@ -194,7 +195,7 @@ compile -> [FilePath] -> ([P.Module] -> IO ()) -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) -compile supportModules supportExterns supportForeigns inputFiles check = silence $ runTest $ do +compile supportModules supportExterns supportForeigns inputFiles check = runTest $ do fs <- liftIO $ readInput inputFiles ms <- P.parseModulesFromFiles id fs foreigns <- inferForeignModules ms diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index d162afd2dd..3f6972b126 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -21,10 +21,11 @@ import Language.PureScript.CoreFn.ToJSON import Language.PureScript.Names import Language.PureScript.PSString -import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec -main :: IO () -main = hspec spec +main :: IO TestTree +main = testSpec "corefn" spec parseModule :: Value -> Result (Version, Module Ann) parseModule = parse moduleFromJSON diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 958adb8078..a80ca927a2 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -32,7 +32,9 @@ import qualified Language.PureScript.Publish.ErrorsWarnings as Publish import Web.Bower.PackageMeta (parsePackageName, runPackageName) import TestUtils -import Test.Hspec (Spec, it, context, expectationFailure, runIO, hspec) + +import Test.Tasty +import Test.Tasty.Hspec (Spec, it, context, expectationFailure, runIO, testSpec) publishOpts :: Publish.PublishOptions publishOpts = Publish.defaultPublishOptions @@ -47,8 +49,8 @@ getPackage = pushd "examples/docs" $ Publish.preparePackage "bower.json" "resolutions.json" publishOpts -main :: IO () -main = hspec spec +main :: IO TestTree +main = testSpec "docs" spec spec :: Spec spec = do diff --git a/tests/TestHierarchy.hs b/tests/TestHierarchy.hs index 98bea9a65b..9737fd0789 100644 --- a/tests/TestHierarchy.hs +++ b/tests/TestHierarchy.hs @@ -3,10 +3,12 @@ module TestHierarchy where import Language.PureScript.Hierarchy import qualified Language.PureScript as P -import Test.Hspec (describe, hspec, it, shouldBe) -main :: IO () -main = hspec $ do +import Test.Tasty +import Test.Tasty.Hspec (describe, it, shouldBe, testSpec) + +main :: IO TestTree +main = testSpec "hierarchy" $ do describe "Language.PureScript.Hierarchy" $ do describe "prettyPrint" $ do it "creates just the node when there is no relation" $ do diff --git a/tests/TestIde.hs b/tests/TestIde.hs new file mode 100644 index 0000000000..801e5436aa --- /dev/null +++ b/tests/TestIde.hs @@ -0,0 +1,17 @@ +module TestIde where + +import Control.Monad (unless) +import Language.PureScript.Ide.Test +import qualified PscIdeSpec +import Test.Tasty +import Test.Tasty.Hspec + +main :: IO TestTree +main = + testSpec "ide" (beforeAll_ setup PscIdeSpec.spec) + where + setup = do + deleteOutputFolder + s <- compileTestProject + unless s (fail "Failed to compile .purs sources") + diff --git a/tests/TestPscIde.hs b/tests/TestPscIde.hs deleted file mode 100644 index 97ff41f4cb..0000000000 --- a/tests/TestPscIde.hs +++ /dev/null @@ -1,13 +0,0 @@ -module TestPscIde where - -import Control.Monad (unless) -import qualified PscIdeSpec -import Language.PureScript.Ide.Test -import Test.Hspec - -main :: IO () -main = do - deleteOutputFolder - s <- compileTestProject - unless s (fail "Failed to compile .purs sources") - hspec PscIdeSpec.spec diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index c5017f11d6..1f985c194f 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -3,13 +3,15 @@ module TestPsci where import Prelude () import Prelude.Compat -import Test.Hspec import TestPsci.CommandTest (commandTests) import TestPsci.CompletionTest (completionTests) import TestPsci.EvalTest (evalTests) -main :: IO () -main = hspec $ do +import Test.Tasty +import Test.Tasty.Hspec + +main :: IO TestTree +main = testSpec "repl" $ do completionTests commandTests evalTests From 38f631c71367cffcc973ce0dab2229e81969e161 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 3 Jan 2018 19:50:35 +0000 Subject: [PATCH 0916/1580] Revert proxies (#3186) * Revert "pretty print proxy types when rendering docs (#3144)" This reverts commit 14227c7151d1a907bf7f00af5701ab61dadb1c0b. * Revert "Print proxy type as an operator (#3124)" This reverts commit cfd1db3ab9eb8f8af400ffc5812af13d4cad9302. * Revert "Fix proxies: synonyms, inference, traversals, instances (#3095)" This reverts commit fe0aa0d7d448e9d660ab00b59ca3094e49e5b7f7. * Revert "Add proxies (#2846)" This reverts commit 74bc4a923dfbd84e1f4dfa448981b57ab3d4ab9c. * Remove one last occurrence of the ProxyType constructor * Update tests to not use new proxies --- examples/docs/src/Proxy.purs | 4 - .../InstanceChainBothUnknownAndMatch.purs | 18 +++-- .../InstanceChainSkolemUnknownMatch.purs | 15 ++-- examples/failing/ProxyKind.purs | 12 --- examples/failing/ProxyUnify.purs | 12 --- examples/passing/AppendInReverse.purs | 11 +-- examples/passing/DuplicateProperties.purs | 20 +++-- examples/passing/FunctionalDependencies.purs | 8 +- examples/passing/Proxy.purs | 80 ------------------- src/Language/PureScript/AST/Declarations.hs | 3 - src/Language/PureScript/AST/Traversals.hs | 3 - src/Language/PureScript/CoreFn/Desugar.hs | 2 - .../Docs/RenderedCode/RenderType.hs | 9 +-- .../PureScript/Parser/Declarations.hs | 4 - src/Language/PureScript/Parser/Types.hs | 4 - src/Language/PureScript/Pretty/Types.hs | 12 +-- src/Language/PureScript/Pretty/Values.hs | 2 - src/Language/PureScript/Sugar/Names.hs | 2 - src/Language/PureScript/Sugar/Operators.hs | 3 - src/Language/PureScript/TypeChecker.hs | 2 - .../PureScript/TypeChecker/Entailment.hs | 2 - src/Language/PureScript/TypeChecker/Kinds.hs | 3 - .../PureScript/TypeChecker/Skolems.hs | 2 - src/Language/PureScript/TypeChecker/Types.hs | 3 - src/Language/PureScript/TypeChecker/Unify.hs | 5 +- src/Language/PureScript/Types.hs | 10 --- tests/TestDocs.hs | 4 - 27 files changed, 46 insertions(+), 209 deletions(-) delete mode 100644 examples/docs/src/Proxy.purs delete mode 100644 examples/failing/ProxyKind.purs delete mode 100644 examples/failing/ProxyUnify.purs delete mode 100644 examples/passing/Proxy.purs diff --git a/examples/docs/src/Proxy.purs b/examples/docs/src/Proxy.purs deleted file mode 100644 index 9a6544d796..0000000000 --- a/examples/docs/src/Proxy.purs +++ /dev/null @@ -1,4 +0,0 @@ -module Proxy where - -foo :: @Int -foo = @Int diff --git a/examples/failing/InstanceChainBothUnknownAndMatch.purs b/examples/failing/InstanceChainBothUnknownAndMatch.purs index 6713d93f02..2c9cf6ef06 100644 --- a/examples/failing/InstanceChainBothUnknownAndMatch.purs +++ b/examples/failing/InstanceChainBothUnknownAndMatch.purs @@ -1,14 +1,18 @@ -- @shouldFailWith NoInstanceFound module InstanceChains.BothUnknownAndMatch where -class Same l r o | l r -> o -instance sameY :: Same t t @"Y" else instance sameN :: Same l r @"N" -same :: forall l r o. Same l r o => l -> r -> @o -same _ _ = @o +import Type.Proxy (Proxy) +import Type.Row (RProxy(..)) +import Data.Symbol (SProxy(..)) + +class Same l r (o :: Symbol) | l r -> o +instance sameY :: Same t t "Y" else instance sameN :: Same l r "N" +same :: forall l r o. Same l r o => l -> r -> SProxy o +same _ _ = SProxy -- for label `u`, `t ~ Int` should be Unknown -- for label `m`, `Int ~ Int` should be a match -- together they should be Unknown -example :: forall t. @t -> @_ -example _ = same @(u :: t, m :: Int) @(u :: Int, m :: Int) - +example :: forall t. Proxy t -> SProxy _ +example _ = same (RProxy :: RProxy (u :: t, m :: Int)) + (RProxy :: RProxy (u :: Int, m :: Int)) diff --git a/examples/failing/InstanceChainSkolemUnknownMatch.purs b/examples/failing/InstanceChainSkolemUnknownMatch.purs index e7dc90d334..a3111f307b 100644 --- a/examples/failing/InstanceChainSkolemUnknownMatch.purs +++ b/examples/failing/InstanceChainSkolemUnknownMatch.purs @@ -1,12 +1,15 @@ -- @shouldFailWith NoInstanceFound module InstanceChainSkolemUnknownMatch where -class Same l r o | l r -> o -instance sameY :: Same t t @"Y" else instance sameN :: Same l r @"N" -same :: forall l r o. Same l r o => l -> r -> @o -same _ _ = @o +import Type.Proxy (Proxy(..)) +import Data.Symbol (SProxy(..)) + +class Same l r (o :: Symbol) | l r -> o +instance sameY :: Same t t "Y" else instance sameN :: Same l r "N" +same :: forall l r o. Same l r o => l -> r -> SProxy o +same _ _ = SProxy -- shouldn't discard sameY as Apart -example :: forall t. @t -> @_ -example _ = same @t @Int +example :: forall t. Proxy t -> SProxy _ +example _ = same (Proxy :: Proxy t) (Proxy :: Proxy Int) diff --git a/examples/failing/ProxyKind.purs b/examples/failing/ProxyKind.purs deleted file mode 100644 index df39c8c6bf..0000000000 --- a/examples/failing/ProxyKind.purs +++ /dev/null @@ -1,12 +0,0 @@ --- @shouldFailWith TypesDoNotUnify - -module Main where - -import Prelude -import Control.Monad.Eff (Eff) - -a :: @"a" -a = @Int - -main :: Eff _ _ -main = pure unit diff --git a/examples/failing/ProxyUnify.purs b/examples/failing/ProxyUnify.purs deleted file mode 100644 index 53a9cfd07d..0000000000 --- a/examples/failing/ProxyUnify.purs +++ /dev/null @@ -1,12 +0,0 @@ --- @shouldFailWith TypesDoNotUnify - -module Main where - -import Prelude -import Control.Monad.Eff (Eff) - -a :: @"a" -a = @"b" - -main :: Eff _ _ -main = pure unit diff --git a/examples/passing/AppendInReverse.purs b/examples/passing/AppendInReverse.purs index c510d2eec6..d70ba70689 100644 --- a/examples/passing/AppendInReverse.purs +++ b/examples/passing/AppendInReverse.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Data.Symbol (SProxy(..)) import Type.Data.Symbol (class AppendSymbol) import Control.Monad.Eff.Console (log) @@ -14,20 +15,20 @@ instance balanced2 , Balanced sym2 ) => Balanced sym -balanced :: forall sym. Balanced sym => @sym -> String +balanced :: forall sym. Balanced sym => SProxy sym -> String balanced _ = "ok" b0 :: String -b0 = balanced @"" +b0 = balanced (SProxy :: SProxy "") b1 :: String -b1 = balanced @"()" +b1 = balanced (SProxy :: SProxy "()") b2 :: String -b2 = balanced @"(())" +b2 = balanced (SProxy :: SProxy "(())") b3 :: String -b3 = balanced @"((()))" +b3 = balanced (SProxy :: SProxy "((()))") main = do log b0 diff --git a/examples/passing/DuplicateProperties.purs b/examples/passing/DuplicateProperties.purs index 389e0a7cfe..d91f6bd317 100644 --- a/examples/passing/DuplicateProperties.purs +++ b/examples/passing/DuplicateProperties.purs @@ -3,21 +3,25 @@ module Main where import Prelude import Control.Monad.Eff.Console (log) -subtractX :: forall r a. @(x :: a | r) -> @r -subtractX _ = @r +data RProxy (r :: # Type) = RProxy -extractX :: forall r a. @(x :: a | r) -> @a -extractX _ = @a +data Proxy (a :: Type) = Proxy -hasX :: forall r a b. @(x :: a, y :: b | r) -hasX = @(x :: a, y :: b | r) +subtractX :: forall r a. RProxy (x :: a | r) -> RProxy r +subtractX RProxy = RProxy + +extractX :: forall r a. RProxy (x :: a | r) -> Proxy a +extractX RProxy = Proxy + +hasX :: forall r a b. RProxy (x :: a, y :: b | r) +hasX = RProxy test1 = subtractX (subtractX hasX) test2 :: forall r a b - . @(x :: a, x :: b, x :: Int | r) - -> @Int + . RProxy (x :: a, x :: b, x :: Int | r) + -> Proxy Int test2 x = extractX (subtractX (subtractX x)) main = log "Done" diff --git a/examples/passing/FunctionalDependencies.purs b/examples/passing/FunctionalDependencies.purs index 810861ebb4..cb8026e591 100644 --- a/examples/passing/FunctionalDependencies.purs +++ b/examples/passing/FunctionalDependencies.purs @@ -11,9 +11,11 @@ instance appendNil :: Append Nil b b instance appendCons :: Append xs b c => Append (Cons x xs) b (Cons x c) -appendProxy :: forall a b c. Append a b c => @a -> @b -> @c -appendProxy _ _ = @c +data Proxy a = Proxy -test = appendProxy @(Cons Int Nil) @(Cons String Nil) +appendProxy :: forall a b c. Append a b c => Proxy a -> Proxy b -> Proxy c +appendProxy Proxy Proxy = Proxy + +test = appendProxy (Proxy :: Proxy (Cons Int Nil)) (Proxy :: Proxy (Cons String Nil)) main = log "Done" diff --git a/examples/passing/Proxy.purs b/examples/passing/Proxy.purs deleted file mode 100644 index a2666b37f8..0000000000 --- a/examples/passing/Proxy.purs +++ /dev/null @@ -1,80 +0,0 @@ -module Main (main) where - -import Prelude -import Control.Monad.Eff.Console (CONSOLE, log) - -f :: @Int -> Unit -f _ = unit - -g :: forall eff. @(console :: CONSOLE | eff) -> Unit -g _ = unit - -h :: @"foo" -> Unit -h _ = unit - -i :: @"foo" -i = @"foo" - -j :: Unit -j = h i - -data P t = P - -switchP :: forall p. @p -> P p -switchP _ = P :: P p - -switchP' :: forall p. P p -> @p -switchP' P = @p - -type Ap f x = f x -infix 4 type Ap as $ -type Eg0 = Array $ Unit -type Eg1 = Array $ Unit - -eg0 :: P Eg0 -eg0 = switchP @Eg1 - -eg0' :: @Eg0 -eg0' = switchP' (P :: P Eg1) - -eg1 :: @Eg0 -eg1 = switchP' (switchP @Eg1) - -eg1' :: P Eg0 -eg1' = switchP (switchP' (P :: P Eg0)) - - -class Go a b | a -> b - -instance goInst :: Go Int Int - -goGo :: forall a b c. Go a b => Go b c => @a -> P c -goGo _ = P :: P c - -go0 :: P Int -go0 = goGo @Int - -type Go1 = Int -type Go1' = Int - -go1 :: P Go1 -go1 = goGo @Go1' - - -class Determined a p | a -> p where - determined :: a -> p - -instance determinedIntProxy :: Determined Int @Int where - determined _ = @Int - -instance determinedProxyInt :: Determined @Int Int where - determined _ = 42 - -determined0 :: @Int -determined0 = determined 42 - -determined1 :: Int -determined1 = determined @Int - - -main = log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 0d760ab7df..b1dcd03b16 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -769,9 +769,6 @@ data Expr -- | Do [DoNotationElement] -- | - -- A proxy value - -- - | Proxy Type -- An ado-notation block -- | Ado [DoNotationElement] Expr diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 54547a87eb..0dce4ae926 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -635,7 +635,6 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con forValues (TypeClassDictionary c _ _) = mconcat (fmap f (constraintArgs c)) forValues (DeferredDictionary _ tys) = mconcat (fmap f tys) forValues (TypedValue _ _ ty) = f ty - forValues (Proxy ty) = f ty forValues _ = mempty accumKinds @@ -669,7 +668,6 @@ accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (con forValues (TypeClassDictionary c _ _) = foldMap forTypes (constraintArgs c) forValues (DeferredDictionary _ tys) = foldMap forTypes tys forValues (TypedValue _ _ ty) = forTypes ty - forValues (Proxy ty) = forTypes ty forValues _ = mempty forTypes (KindedType _ k) = f k @@ -683,6 +681,5 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' where g :: Expr -> Expr g (TypedValue checkTy val t) = TypedValue checkTy val (f t) - g (Proxy t) = Proxy (f t) g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (fmap f) c) sco hints g other = other diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 005bd55562..ed788ab63d 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -101,8 +101,6 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = exprToCoreFn ss com (Just ty) v exprToCoreFn ss com ty (A.Let ds v) = Let (ss, com, ty, Nothing) (concatMap declToCoreFn ds) (exprToCoreFn ss [] Nothing v) - exprToCoreFn ss com ty (A.Proxy _) = - Literal (ss, com, ty, Nothing) (ObjectLiteral []) exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal (A.ObjectLiteral _)) _)) = exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name lit) exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal (A.ObjectLiteral vs))) = diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index 114a03d12d..15f51dc94c 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -96,12 +96,6 @@ renderTail :: Type -> RenderedCode renderTail REmpty = mempty renderTail other = sp <> syntax "|" <> sp <> renderType other -proxyType :: Pattern () Type ((), Type) -proxyType = mkPattern match - where - match (ProxyType t) = Just ((), t) - match _ = Nothing - typeApp :: Pattern () Type (Type, Type) typeApp = mkPattern match where @@ -142,8 +136,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom where operators :: OperatorTable () Type RenderedCode operators = - OperatorTable [ [ Wrap proxyType $ \_ ty -> syntax "@" <> ty ] - , [ AssocL typeApp $ \f x -> f <> sp <> x ] + OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ] , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ] , [ Wrap constrained $ \deps ty -> renderConstraints deps ty ] , [ Wrap forall_ $ \tyVars ty -> mconcat [keywordForall, sp, mintersperse sp (map typeVar tyVars), syntax ".", sp, ty] ] diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index d17ab94b58..585fa75aed 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -435,9 +435,6 @@ parseLet = do result <- parseValue return $ Let ds result -parseProxy :: TokenParser Expr -parseProxy = Proxy <$> (at *> parseTypeAtom) - parseValueAtom :: TokenParser Expr parseValueAtom = withSourceSpan PositionedValue $ P.choice [ parseAnonymousArgument @@ -455,7 +452,6 @@ parseValueAtom = withSourceSpan PositionedValue $ P.choice , parseDo , parseAdo , parseLet - , parseProxy , P.try $ Parens <$> parens parseValue , Op <$> parseQualified (parens parseOperator) , parseHole diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 0f37ab8bd8..3a9803c7bd 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -49,9 +49,6 @@ parseTypeVariable = do parseTypeConstructor :: TokenParser Type parseTypeConstructor = TypeConstructor <$> parseQualified typeName -parseProxyType :: TokenParser Type -parseProxyType = ProxyType <$> (at *> parseTypeAtom) - parseForAll :: TokenParser Type parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (indented *> identifier) <* indented <* dot) <*> parseType @@ -78,7 +75,6 @@ parseTypeAtom = indented *> P.choice , parseForAll , parseTypeVariable , parseTypeConstructor - , parseProxyType -- This try is needed due to some unfortunate ambiguities between rows and kinded types , P.try (parens parseRow) , ParensInType <$> parens parsePolyType diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index ad8ee7763d..bee62db14c 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -74,15 +74,6 @@ prettyPrintRowWith tro open close = uncurry listToBox . toList [] prettyPrintRow :: Type -> String prettyPrintRow = render . prettyPrintRowWith defaultOptions '(' ')' --- Treat `ProxyType t` in a similar way to the application of a type --- constructor `@` to `t`, i.e: `@ t`, except that we don't render the unneeded --- space. So we end up with `@t`. -proxyType :: Pattern () Type (Type, Type) -proxyType = mkPattern match - where - match (ProxyType t) = Just (TypeConstructor (Qualified Nothing (ProperName "@")), t) - match _ = Nothing - typeApp :: Pattern () Type (Type, Type) typeApp = mkPattern match where @@ -153,8 +144,7 @@ matchType :: TypeRenderOptions -> Pattern () Type Box matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where operators :: OperatorTable () Type Box operators = - OperatorTable [ [ AssocL proxyType $ \p ty -> p <> ty ] - , [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ] + OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ] , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text rightArrow <> " " <> ret) ] , [ Wrap constrained $ \deps ty -> constraintsAsBox tro deps ty ] , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text (forall' ++ " " ++ unwords idents ++ ".")) ty ] diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 04d1a43c0a..288c0f1030 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -78,8 +78,6 @@ prettyPrintValue d (Let ds val) = (text "in " <> prettyPrintValue (d - 1) val) prettyPrintValue d (Do els) = text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) -prettyPrintValue _ (Proxy ty) = - text "@" <> typeAtomAsBox ty prettyPrintValue d (Ado els yield) = text "ado " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) // (text "in " <> prettyPrintValue (d - 1) yield) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index bfc45f77d4..4afbdccc9e 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -269,8 +269,6 @@ renameInModule imports (Module modSS coms mn decls exps) = (,) s <$> (Constructor <$> updateDataConstructorName name pos) updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty) - updateValue s@(pos, _) (Proxy ty) = - (,) s <$> (Proxy <$> updateTypesEverywhere pos ty) updateValue s v = return (s, v) updateBinder diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 43ef78cded..8d3b3ecbbc 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -356,9 +356,6 @@ updateTypes goType = (goDecl, goExpr, goBinder) goExpr pos (TypedValue check v ty) = do ty' <- goType' pos ty return (pos, TypedValue check v ty') - goExpr pos (Proxy ty) = do - ty' <- goType' pos ty - return (pos, Proxy ty') goExpr pos other = return (pos, other) goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 2d52d9a842..3ae1a76ad0 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -198,7 +198,6 @@ checkTypeClassInstance cls i = check where TypeApp t1 t2 -> check t1 >> check t2 REmpty | isFunDepDetermined -> return () RCons _ hd tl | isFunDepDetermined -> check hd >> check tl - ProxyType ty -> check ty ty -> throwError . errorMessage $ InvalidInstanceHead ty -- | @@ -380,7 +379,6 @@ typeCheckAll moduleName _ = traverse go typeModule (TypeConstructor (Qualified (Just mn'') _)) = Just mn'' typeModule (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance" typeModule (TypeApp t1 _) = typeModule t1 - typeModule (ProxyType _) = Nothing typeModule _ = internalError "Invalid type in instance in checkOrphanInstance" modulesByTypeIndex :: M.Map Int (Maybe ModuleName) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index f87c548f48..b6a19d5458 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -498,7 +498,6 @@ matches deps TypeClassDictionaryInScope{..} tys = typeHeadsAreEqual t (TypeVar v) = (Match (), M.singleton v [t]) typeHeadsAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = (Match (), M.empty) typeHeadsAreEqual (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = (Match (), M.empty) - typeHeadsAreEqual (ProxyType t1) (ProxyType t2) = typeHeadsAreEqual t1 t2 typeHeadsAreEqual (TypeApp h1 t1) (TypeApp h2 t2) = both (typeHeadsAreEqual h1 h2) (typeHeadsAreEqual t1 t2) typeHeadsAreEqual REmpty REmpty = (Match (), M.empty) @@ -543,7 +542,6 @@ matches deps TypeClassDictionaryInScope{..} tys = typesAreEqual (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = Match () typesAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Match () typesAreEqual (TypeApp h1 t1) (TypeApp h2 t2) = typesAreEqual h1 h2 <> typesAreEqual t1 t2 - typesAreEqual (ProxyType t1) (ProxyType t2) = typesAreEqual t1 t2 typesAreEqual REmpty REmpty = Match () typesAreEqual r1 r2 | isRCons r1 || isRCons r2 = let (common, rest) = alignRowsWith typesAreEqual r1 r2 diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 123dd35675..58ec2f0fb6 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -256,9 +256,6 @@ infer' other = (, []) <$> go other k2 <- go row unifyKinds k2 (Row k1) return $ Row k1 - go (ProxyType ty) = do - _ <- go ty - return kindType go (ConstrainedType (Constraint className tys _) ty) = do k1 <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys unifyKinds k1 kindType diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 33798dbf78..0b6ef54537 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -64,8 +64,6 @@ skolemizeTypesInValue ident sko scope ss = | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts)) onExpr sco (TypedValue check val ty) | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty)) - onExpr sco (Proxy ty) - | ident `notElem` sco = return (sco ++ peelTypeVars ty, Proxy (skolemize ident sko scope ss ty)) onExpr sco other = return (sco, other) onBinder :: [Text] -> Binder -> Identity ([Text], Binder) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 8e7adf80d8..f96771a8b0 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -395,9 +395,6 @@ infer' (IfThenElse cond th el) = do infer' (Let ds val) = do (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer return $ TypedValue True (Let ds' val') valTy -infer' (Proxy ty) = do - ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty - return $ TypedValue True (Proxy ty') (ProxyType ty') infer' (DeferredDictionary className tys) = do dicts <- getTypeClassDictionaries hints <- getHints diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 2c7f80b444..04186dbc93 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -85,8 +85,7 @@ unknownsInType t = everythingOnTypes (.) go t [] unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m () unifyTypes t1 t2 = do sub <- gets checkSubstitution - withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ - unifyTypes' (substituteType sub t1) (substituteType sub t2) + withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes' (substituteType sub t1) (substituteType sub t2) where unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return () unifyTypes' (TUnknown u) t = solveType u t @@ -119,8 +118,6 @@ unifyTypes t1 t2 = do unifyTypes' r1 r2@RCons{} = unifyRows r1 r2 unifyTypes' r1@REmpty r2 = unifyRows r1 r2 unifyTypes' r1 r2@REmpty = unifyRows r1 r2 - unifyTypes' (ProxyType ty1) (ProxyType ty2) = - ty1 `unifyTypes` ty2 unifyTypes' ty1@ConstrainedType{} ty2 = throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2 unifyTypes' t3 t4@ConstrainedType{} = unifyTypes' t4 t3 diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index b5dcdcef95..d600bf47f7 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -66,8 +66,6 @@ data Type | REmpty -- | A non-empty row | RCons Label Type Type - -- | A proxy type - | ProxyType Type -- | A type with a kind annotation | KindedType Type Kind -- | A placeholder used in pretty printing @@ -170,7 +168,6 @@ replaceAllTypeVars = go [] where usedVars = concatMap (usedTypeVariables . snd) m go bs m (ConstrainedType c t) = ConstrainedType (mapConstraintArgs (map (go bs m)) c) (go bs m t) go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r) - go bs m (ProxyType t) = ProxyType (go bs m t) go bs m (KindedType t k) = KindedType (go bs m t) k go bs m (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go bs m t1) (go bs m t2) (go bs m t3) go bs m (ParensInType t) = ParensInType (go bs m t) @@ -196,7 +193,6 @@ freeTypeVariables = ordNub . go [] where go bound (ForAll v t _) = go (v : bound) t go bound (ConstrainedType c t) = concatMap (go bound) (constraintArgs c) ++ go bound t go bound (RCons _ t r) = go bound t ++ go bound r - go bound (ProxyType t) = go bound t go bound (KindedType t _) = go bound t go bound (BinaryNoParensType t1 t2 t3) = go bound t1 ++ go bound t2 ++ go bound t3 go bound (ParensInType t) = go bound t @@ -233,7 +229,6 @@ everywhereOnTypes f = go where go (ForAll arg ty sco) = f (ForAll arg (go ty) sco) go (ConstrainedType c ty) = f (ConstrainedType (mapConstraintArgs (map go) c) (go ty)) go (RCons name ty rest) = f (RCons name (go ty) (go rest)) - go (ProxyType ty) = f (ProxyType (go ty)) go (KindedType ty k) = f (KindedType (go ty) k) go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2)) go (PrettyPrintObject t) = f (PrettyPrintObject (go t)) @@ -248,7 +243,6 @@ everywhereOnTypesTopDown f = go . f where go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco go (ConstrainedType c ty) = ConstrainedType (mapConstraintArgs (map (go . f)) c) (go (f ty)) go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest)) - go (ProxyType ty) = ProxyType (go (f ty)) go (KindedType ty k) = KindedType (go (f ty)) k go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2)) go (PrettyPrintObject t) = PrettyPrintObject (go (f t)) @@ -263,7 +257,6 @@ everywhereOnTypesM f = go where go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f go (ConstrainedType c ty) = (ConstrainedType <$> overConstraintArgs (mapM go) c <*> go ty) >>= f go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f - go (ProxyType ty) = (ProxyType <$> go ty) >>= f go (KindedType ty k) = (KindedType <$> go ty <*> pure k) >>= f go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f @@ -278,7 +271,6 @@ everywhereOnTypesTopDownM f = go <=< f where go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco go (ConstrainedType c ty) = ConstrainedType <$> overConstraintArgs (mapM (go <=< f)) c <*> (f ty >>= go) go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go) - go (ProxyType ty) = ProxyType <$> (f ty >>= go) go (KindedType ty k) = KindedType <$> (f ty >>= go) <*> pure k go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go) go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go) @@ -293,7 +285,6 @@ everythingOnTypes (<+>) f = go where go t@(ForAll _ ty _) = f t <+> go ty go t@(ConstrainedType c ty) = foldl (<+>) (f t) (map go (constraintArgs c)) <+> go ty go t@(RCons _ ty rest) = f t <+> go ty <+> go rest - go t@(ProxyType ty) = f t <+> go ty go t@(KindedType ty _) = f t <+> go ty go t@(PrettyPrintFunction t1 t2) = f t <+> go t1 <+> go t2 go t@(PrettyPrintObject t1) = f t <+> go t1 @@ -309,7 +300,6 @@ everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 where go s (ForAll _ ty _) = go' s ty go s (ConstrainedType c ty) = foldl (<+>) r0 (map (go' s) (constraintArgs c)) <+> go' s ty go s (RCons _ ty rest) = go' s ty <+> go' s rest - go s (ProxyType ty) = go' s ty go s (KindedType ty _) = go' s ty go s (PrettyPrintFunction t1 t2) = go' s t1 <+> go' s t2 go s (PrettyPrintObject t1) = go' s t1 diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index a80ca927a2..8311fefad5 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -566,10 +566,6 @@ testCases = , ("DeclOrderNoExportList", shouldBeOrdered (n "DeclOrderNoExportList") [ "x1", "x3", "X2", "X4", "A", "B" ]) - - , ("Proxy", - [ ValueShouldHaveTypeSignature (n "Proxy") "foo" (renderedType "@Int") - ]) ] where From 3679da409c5c3aa5ee5b2df2035e4f4d94bae104 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sat, 20 Jan 2018 12:21:09 +0000 Subject: [PATCH 0917/1580] Make explicit import suggestions more consistent (#3142) * Make explicit import suggestions more consistent * Make ImplicitQualifiedImport suggestions consistent --- src/Language/PureScript/Linter/Imports.hs | 36 +++++++++++++++-------- 1 file changed, 23 insertions(+), 13 deletions(-) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 3a57797590..19e7662aad 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -82,7 +82,7 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do let names = ordNub $ M.findWithDefault [] mni usedImps' usedRefs = findUsedRefs ss env mni (Just mnq) names unless (null usedRefs) . - tell . errorMessage' ss $ ImplicitQualifiedImport mni mnq usedRefs + tell . errorMessage' ss $ ImplicitQualifiedImport mni mnq $ map (simplifyTypeRef $ const True) usedRefs for_ imports $ \(mnq, imps) -> do @@ -183,6 +183,17 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do _ -> internalError "unqualified name in extractByQual" go _ = Nothing + +-- Replace explicit type refs with data constructor lists from listing the +-- used constructors explicity `T(X, Y, [...])` to `T(..)` for suggestion +-- message. +-- Done everywhere when suggesting a completely new explicit imports list, otherwise +-- maintain the existing form. +simplifyTypeRef :: (ProperName 'TypeName -> Bool) -> DeclarationRef -> DeclarationRef +simplifyTypeRef shouldOpen (TypeRef ss name (Just dctors)) + | not (null dctors) && shouldOpen name = TypeRef ss name Nothing +simplifyTypeRef _ other = other + lintImportDecl :: forall m . MonadWriter MultipleErrors m @@ -214,15 +225,7 @@ lintImportDecl env mni qualifierName names ss declType allowImplicit = checkImplicit warning = if null allRefs then unused - else warn (warning mni (map simplifyTypeRef allRefs)) - where - -- Replace explicit type refs with data constructor lists from listing the - -- used constructors explicity `T(X, Y, [...])` to `T(..)` for suggestion - -- message. - simplifyTypeRef :: DeclarationRef -> DeclarationRef - simplifyTypeRef (TypeRef ss' name (Just dctors)) - | not (null dctors) = TypeRef ss' name Nothing - simplifyTypeRef other = other + else warn (warning mni (map (simplifyTypeRef $ const True) allRefs)) checkExplicit :: [DeclarationRef] @@ -236,21 +239,28 @@ lintImportDecl env mni qualifierName names ss declType allowImplicit = didWarn <- case (length diff, length idents) of (0, _) -> return False (n, m) | n == m -> unused - _ -> warn (UnusedExplicitImport mni diff qualifierName allRefs) + _ -> warn (UnusedExplicitImport mni diff qualifierName $ map simplifyTypeRef' allRefs) didWarn' <- forM (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do let allCtors = dctorsForType mni tn -- If we've not already warned a type is unused, check its data constructors unless' (TyName tn `notElem` usedNames) $ case (c, dctors `intersect` allCtors) of - (_, []) | c /= Just [] -> warn (UnusedDctorImport mni tn qualifierName allRefs) + (_, []) | c /= Just [] -> warn (UnusedDctorImport mni tn qualifierName $ map simplifyTypeRef' allRefs) (Just ctors, dctors') -> let ddiff = ctors \\ dctors' - in unless' (null ddiff) . warn $ UnusedDctorExplicitImport mni tn ddiff qualifierName allRefs + in unless' (null ddiff) . warn $ UnusedDctorExplicitImport mni tn ddiff qualifierName $ map simplifyTypeRef' allRefs _ -> return False return (didWarn || or didWarn') + where + simplifyTypeRef' :: DeclarationRef -> DeclarationRef + simplifyTypeRef' = simplifyTypeRef (\name -> any (isMatch name) declrefs) + where + isMatch name (TypeRef _ name' Nothing) = name == name' + isMatch _ _ = False + unused :: m Bool unused = warn (UnusedImport mni) From 950f184609af48dea305ca9314598ea7d9493411 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Sat, 20 Jan 2018 08:03:59 -0700 Subject: [PATCH 0918/1580] Fix error on missing type class name with non-exported superclass (#3132) (#3173) Resolves #3132. Attempting to export a type class where the superclass is defined in the same module but not exported now triggers a TransitiveExportError. --- examples/failing/3132.purs | 18 +++++ src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Environment.hs | 4 +- src/Language/PureScript/TypeChecker.hs | 81 ++++++++++++++++++--- 4 files changed, 91 insertions(+), 14 deletions(-) create mode 100644 examples/failing/3132.purs diff --git a/examples/failing/3132.purs b/examples/failing/3132.purs new file mode 100644 index 0000000000..9bbf3c6d96 --- /dev/null +++ b/examples/failing/3132.purs @@ -0,0 +1,18 @@ +-- @shouldFailWith TransitiveExportError +module Main (class C3) where + +import Prelude + +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) + +class C1 +instance inst1 :: C1 + +class C1 <= C2 a + +class (C2 a) <= C3 a b + +main :: forall e. Eff (console :: CONSOLE | e) Unit +main = do + log "Done" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index b1dcd03b16..5771fe6f6f 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -800,7 +800,7 @@ data Expr -- | AnonymousArgument -- | - -- A typed hole that will be turned into a hint/error duing typechecking + -- A typed hole that will be turned into a hint/error during typechecking -- | Hole Text -- | diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 2a22a1b7fd..b1734f3b55 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -37,7 +37,9 @@ data Environment = Environment , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type) -- ^ Type synonyms currently in scope , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)) - -- ^ Available type class dictionaries + -- ^ Available type class dictionaries. When looking up 'Nothing' in the + -- outer map, this returns the map of type class dictionaries in local + -- scope (ie dictionaries brought in by a constrained type). , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData -- ^ Type classes , kinds :: S.Set (Qualified (ProperName 'KindName)) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 3ae1a76ad0..9ec8c0960a 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -14,7 +14,7 @@ import Protolude (ordNub) import Control.Monad (when, unless, void, forM) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State.Class (MonadState(..), modify) +import Control.Monad.State.Class (MonadState(..), modify, gets) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Lens ((^..), _1, _2) @@ -432,31 +432,87 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do modify (\s -> s { checkCurrentModule = Just mn }) decls' <- typeCheckAll mn exps decls + checkSuperClassesAreExported <- getSuperClassExportCheck for_ exps $ \e -> do checkTypesAreExported e checkClassMembersAreExported e checkClassesAreExported e + checkSuperClassesAreExported e return $ Module ss coms mn decls' (Just exps) where + qualify' :: a -> Qualified a + qualify' = Qualified (Just mn) + + getSuperClassExportCheck = do + classesToSuperClasses <- gets + ( M.map + ( S.fromList + . filter (\(Qualified mn' _) -> mn' == Just mn) + . fmap constraintClass + . typeClassSuperclasses + ) + . typeClasses + . checkEnv + ) + let + -- A function that, given a class name, returns the set of + -- transitive class dependencies that are defined in this + -- module. + transitiveSuperClassesFor + :: Qualified (ProperName 'ClassName) + -> S.Set (Qualified (ProperName 'ClassName)) + transitiveSuperClassesFor qname = + untilSame + (\s -> s <> foldMap (\n -> fromMaybe S.empty (M.lookup n classesToSuperClasses)) s) + (fromMaybe S.empty (M.lookup qname classesToSuperClasses)) + + superClassesFor qname = + fromMaybe S.empty (M.lookup qname classesToSuperClasses) + + pure $ checkSuperClassExport superClassesFor transitiveSuperClassesFor + moduleClassExports :: S.Set (Qualified (ProperName 'ClassName)) + moduleClassExports = S.fromList $ mapMaybe (\x -> case x of + TypeClassRef _ name -> Just (qualify' name) + _ -> Nothing) exps + + untilSame :: Eq a => (a -> a) -> a -> a + untilSame f a = let a' = f a in if a == a' then a else untilSame f a' checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m () checkMemberExport extract dr@(TypeRef _ name dctors) = do env <- getEnv - case M.lookup (Qualified (Just mn) name) (typeSynonyms env) of - Nothing -> return () - Just (_, ty) -> checkExport dr extract ty - case dctors of - Nothing -> return () - Just dctors' -> for_ dctors' $ \dctor -> - case M.lookup (Qualified (Just mn) dctor) (dataConstructors env) of - Nothing -> return () - Just (_, _, ty, _) -> checkExport dr extract ty - return () + for_ (M.lookup (qualify' name) (typeSynonyms env)) $ \(_, ty) -> + checkExport dr extract ty + for_ dctors $ \dctors' -> + for_ dctors' $ \dctor -> + for_ (M.lookup (qualify' dctor) (dataConstructors env)) $ \(_, _, ty, _) -> + checkExport dr extract ty checkMemberExport extract dr@(ValueRef _ name) = do - ty <- lookupVariable (Qualified (Just mn) name) + ty <- lookupVariable (qualify' name) checkExport dr extract ty checkMemberExport _ _ = return () + checkSuperClassExport + :: (Qualified (ProperName 'ClassName) -> S.Set (Qualified (ProperName 'ClassName))) + -> (Qualified (ProperName 'ClassName) -> S.Set (Qualified (ProperName 'ClassName))) + -> DeclarationRef + -> m () + checkSuperClassExport superClassesFor transitiveSuperClassesFor dr@(TypeClassRef drss className) = do + let superClasses = superClassesFor (qualify' className) + -- thanks to laziness, the computation of the transitive + -- superclasses defined in-module will only occur if we actually + -- throw the error. Constructing the full set of transitive + -- superclasses is likely to be costly for every single term. + transitiveSuperClasses = transitiveSuperClassesFor (qualify' className) + unexported = S.difference superClasses moduleClassExports + unless (null unexported) + . throwError . errorMessage' drss + . TransitiveExportError dr + . map (TypeClassRef drss . disqualify) + $ toList transitiveSuperClasses + checkSuperClassExport _ _ _ = + return () + checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m () checkExport dr extract ty = case filter (not . exported) (extract ty) of [] -> return () @@ -512,3 +568,4 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = extractMemberName (TypeDeclaration td) = tydeclIdent td extractMemberName _ = internalError "Unexpected declaration in typeclass member list" checkClassMembersAreExported _ = return () + From 8369db42eebe535cf7a1fb85e501bb72731a3c68 Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Sat, 20 Jan 2018 17:56:01 -0500 Subject: [PATCH 0919/1580] create UnusedIdent (#3194) Fixes https://github.com/purescript/purescript/issues/3187 Rather than using the magic string "__unused" to represent generated names that are meant to go unused, we create a new Ident constructor for them. Instead of eliminating them as arguments in the optimization phase, they are stripped during the conversion from CoreFn to CoreImp. --- examples/passing/3187-UnusedNameClash.purs | 12 ++++++++++++ src/Language/PureScript/CodeGen/JS.hs | 6 +++++- src/Language/PureScript/CodeGen/JS/Common.hs | 1 + src/Language/PureScript/Constants.hs | 5 ----- src/Language/PureScript/CoreImp/Optimizer.hs | 1 - src/Language/PureScript/CoreImp/Optimizer/Unused.hs | 7 ------- src/Language/PureScript/Linter/Exhaustive.hs | 4 ++-- src/Language/PureScript/Names.hs | 5 +++++ src/Language/PureScript/Renamer.hs | 5 ++--- src/Language/PureScript/Sugar/DoNotation.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- src/Language/PureScript/TypeChecker/Entailment.hs | 4 ++-- 12 files changed, 31 insertions(+), 23 deletions(-) create mode 100644 examples/passing/3187-UnusedNameClash.purs diff --git a/examples/passing/3187-UnusedNameClash.purs b/examples/passing/3187-UnusedNameClash.purs new file mode 100644 index 0000000000..bd84f095b8 --- /dev/null +++ b/examples/passing/3187-UnusedNameClash.purs @@ -0,0 +1,12 @@ +module Main (main) where + +import Prelude ((+)) +import Control.Monad.Eff.Console (log) + +-- the __unused parameter used to get optimized away +abuseUnused :: forall a. a -> a +abuseUnused __unused = __unused + +main = do + let explode = abuseUnused 0 + abuseUnused 0 + log "Done" diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 39d00ea5dc..c33ce2a36f 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -164,6 +164,7 @@ moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ = accessor :: Ident -> AST -> AST accessor (Ident prop) = accessorString $ mkString prop accessor (GenIdent _ _) = internalError "GenIdent in accessor" + accessor UnusedIdent = internalError "UnusedIdent in accessor" accessorString :: PSString -> AST -> AST accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop) @@ -199,7 +200,10 @@ moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ = (var name) valueToJs' (Abs _ arg val) = do ret <- valueToJs val - return $ AST.Function Nothing Nothing [identToJs arg] (AST.Block Nothing [AST.Return Nothing ret]) + let jsArg = case arg of + UnusedIdent -> [] + _ -> [identToJs arg] + return $ AST.Function Nothing Nothing jsArg (AST.Block Nothing [AST.Return Nothing ret]) valueToJs' e@App{} = do let (f, args) = unApp e [] args' <- mapM valueToJs args diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 0060b56d97..259cd4afa2 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -26,6 +26,7 @@ moduleNameToJs (ModuleName pns) = identToJs :: Ident -> Text identToJs (Ident name) = properToJs name identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" +identToJs UnusedIdent = "$__unused" properToJs :: Text -> Text properToJs name diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 3703e07bf1..8b2d56d19d 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -418,11 +418,6 @@ typ = "Type" symbol :: forall a. (IsString a) => a symbol = "Symbol" --- Code Generation - -__unused :: forall a. (IsString a) => a -__unused = "__unused" - -- Modules prim :: forall a. (IsString a) => a diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs index 23013b7ba8..a4078274c8 100644 --- a/src/Language/PureScript/CoreImp/Optimizer.hs +++ b/src/Language/PureScript/CoreImp/Optimizer.hs @@ -44,7 +44,6 @@ optimize js = do [ collapseNestedBlocks , collapseNestedIfs , removeCodeAfterReturnStatements - , removeUnusedArg , removeUndefinedApp , unThunk , etaConvert diff --git a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs index ff05c64677..4dc5ceb0cf 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs @@ -1,7 +1,6 @@ -- | Removes unused variables module Language.PureScript.CoreImp.Optimizer.Unused ( removeCodeAfterReturnStatements - , removeUnusedArg , removeUndefinedApp ) where @@ -21,12 +20,6 @@ removeCodeAfterReturnStatements = everywhere (removeFromBlock go) isReturn (ReturnNoResult _) = True isReturn _ = False -removeUnusedArg :: AST -> AST -removeUnusedArg = everywhere convert - where - convert (Function ss name [arg] body) | arg == C.__unused = Function ss name [] body - convert js = js - removeUndefinedApp :: AST -> AST removeUndefinedApp = everywhere convert where diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 30ad256827..23d39d9a8c 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -291,11 +291,11 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' return $ Let [ partial var tyVar ] - $ App (Var (Qualified Nothing (Ident C.__unused))) e + $ App (Var (Qualified Nothing UnusedIdent)) e where partial :: Text -> Text -> Declaration partial var tyVar = - ValueDecl (ss, []) (Ident C.__unused) Private [] $ + ValueDecl (ss, []) UnusedIdent Private [] $ [MkUnguarded (TypedValue True diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index ea84f152a3..701de1d499 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -76,6 +76,10 @@ data Ident -- A generated name for an identifier -- | GenIdent (Maybe Text) Integer + -- | + -- A generated name used only for type-checking + -- + | UnusedIdent deriving (Show, Eq, Ord, Generic) instance NFData Ident @@ -84,6 +88,7 @@ runIdent :: Ident -> Text runIdent (Ident i) = i runIdent (GenIdent Nothing n) = "$" <> T.pack (show n) runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n) +runIdent UnusedIdent = "$__unused" showIdent :: Ident -> Text showIdent = runIdent diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index 5d4aba6ee2..19dad5d08c 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -17,7 +17,6 @@ import qualified Data.Text as T import Language.PureScript.CoreFn import Language.PureScript.Names import Language.PureScript.Traversals -import qualified Language.PureScript.Constants as C -- | -- The state object used in this module @@ -62,8 +61,8 @@ newScope x = do updateScope :: Ident -> Rename Ident updateScope ident = case ident of - Ident name | name == C.__unused -> return ident GenIdent name _ -> go ident $ Ident (fromMaybe "v" name) + UnusedIdent -> return UnusedIdent _ -> go ident ident where go :: Ident -> Ident -> Rename Ident @@ -88,7 +87,7 @@ updateScope ident = -- Finds the new name to use for an ident. -- lookupIdent :: Ident -> Rename Ident -lookupIdent i@(Ident name) | name == C.__unused = return i +lookupIdent UnusedIdent = return UnusedIdent lookupIdent name = do name' <- gets $ M.lookup name . rsBoundNames case name' of diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 4edb6b6f9f..713e16d93a 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -44,7 +44,7 @@ desugarDo d = go [DoNotationValue val] = return val go (DoNotationValue val : rest) = do rest' <- go rest - return $ App (App discard val) (Abs (VarBinder (Ident C.__unused)) rest') + return $ App (App discard val) (Abs (VarBinder UnusedIdent) rest') go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind go (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) = throwError . errorMessage $ CannotUseBindWithDo (Ident ident) diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 577479f39f..90476e666e 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -292,7 +292,7 @@ typeInstanceDictionaryDeclaration sa name mn deps className tys decls = -- The type is a record type, but depending on type instance dependencies, may be constrained. -- The dictionary itself is a record literal. let superclasses = superClassDictionaryNames typeClassSuperclasses `zip` - [ Abs (VarBinder (Ident C.__unused)) (DeferredDictionary superclass tyArgs) + [ Abs (VarBinder UnusedIdent) (DeferredDictionary superclass tyArgs) | (Constraint superclass suTyArgs _) <- typeClassSuperclasses , let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs ] diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index b6a19d5458..928e157d19 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -360,7 +360,7 @@ entails SolverOptions{..} constraint context hints = mkDictionary (NamedInstance n) args = return $ foldl App (Var n) (fold args) mkDictionary UnionInstance (Just [e]) = -- We need the subgoal dictionary to appear in the term somewhere - return $ App (Abs (VarBinder (Ident C.__unused)) valUndefined) e + return $ App (Abs (VarBinder UnusedIdent) valUndefined) e mkDictionary UnionInstance _ = return valUndefined mkDictionary ConsInstance _ = return valUndefined mkDictionary RowToListInstance _ = return valUndefined @@ -371,7 +371,7 @@ entails SolverOptions{..} constraint context hints = -- So pass an empty placeholder (undefined) instead. return valUndefined mkDictionary (IsSymbolInstance sym) _ = - let fields = [ ("reflectSymbol", Abs (VarBinder (Ident C.__unused)) (Literal (StringLiteral sym))) ] in + let fields = [ ("reflectSymbol", Abs (VarBinder UnusedIdent) (Literal (StringLiteral sym))) ] in return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) mkDictionary CompareSymbolInstance _ = return $ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral [])) From 683f6da43bfe3c6756bd7b748b633a9f2a817005 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 21 Jan 2018 18:27:43 +0100 Subject: [PATCH 0920/1580] throw IntOutOfRange error with position information if present (#3210) --- src/Language/PureScript/CodeGen/JS.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index c33ce2a36f..4cf389f76b 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -32,8 +32,8 @@ import Language.PureScript.CoreImp.Optimizer import Language.PureScript.CoreFn import Language.PureScript.Crash import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..), - MultipleErrors(..), rethrow, - errorMessage, rethrowWithPosition, addHint) + MultipleErrors(..), rethrow, errorMessage, + errorMessage', rethrowWithPosition, addHint) import Language.PureScript.Names import Language.PureScript.Options import Language.PureScript.PSString (PSString, mkString) @@ -423,10 +423,10 @@ moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ = -- the value is `Unary Negate (NumericLiteral (Left 2147483648))`, and -- 2147483648 is larger than the maximum allowed int. return $ AST.NumericLiteral ss (Left (-i)) - go js@(AST.NumericLiteral _ (Left i)) = + go js@(AST.NumericLiteral ss (Left i)) = let minInt = -2147483648 maxInt = 2147483647 in if i < minInt || i > maxInt - then throwError . errorMessage $ IntOutOfRange i "JavaScript" minInt maxInt + then throwError . maybe errorMessage errorMessage' ss $ IntOutOfRange i "JavaScript" minInt maxInt else return js go other = return other From 4b2317152c326c66be90c9ea0f30fc466e413007 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 21 Jan 2018 18:04:51 +0000 Subject: [PATCH 0921/1580] Eq1 / Ord1 deriving again (#3207) * Allow `Eq1` to be used when deriving `Eq` * Derive `Eq1` (as `eq1 = eq`) * Allow `Ord1` to be used when deriving `Ord` * Derive `Ord1` (as `compare1 = compare`) * Remove unnecessary constraints * Update DerivingFunctor test for Eq1 deriving --- examples/passing/DerivingFunctor.purs | 5 +- examples/passing/Eq1Deriving.purs | 12 ++++ examples/passing/Eq1InEqDeriving.purs | 11 ++++ examples/passing/Ord1Deriving.purs | 16 +++++ examples/passing/Ord1InOrdDeriving.purs | 13 ++++ src/Language/PureScript/Constants.hs | 6 ++ .../PureScript/Sugar/TypeClasses/Deriving.hs | 66 +++++++++++++++---- 7 files changed, 115 insertions(+), 14 deletions(-) create mode 100644 examples/passing/Eq1Deriving.purs create mode 100644 examples/passing/Eq1InEqDeriving.purs create mode 100644 examples/passing/Ord1Deriving.purs create mode 100644 examples/passing/Ord1InOrdDeriving.purs diff --git a/examples/passing/DerivingFunctor.purs b/examples/passing/DerivingFunctor.purs index bd40cac9f2..765564bb91 100644 --- a/examples/passing/DerivingFunctor.purs +++ b/examples/passing/DerivingFunctor.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Data.Eq (class Eq1) import Control.Monad.Eff.Console (log) import Test.Assert @@ -13,7 +14,7 @@ data M f a | M3 { foo :: Int, bar :: a, baz :: f a } | M4 (MyRecord a) -derive instance eqM :: (Eq (f a), Eq a) => Eq (M f a) +derive instance eqM :: (Eq1 f, Eq a) => Eq (M f a) derive instance functorM :: Functor f => Functor (M f) @@ -24,5 +25,5 @@ main = do assert $ map show (M1 0 :: MA Int) == M1 0 assert $ map show (M2 [0, 1] :: MA Int) == M2 ["0", "1"] assert $ map show (M3 {foo: 0, bar: 1, baz: [2, 3]} :: MA Int) == M3 {foo: 0, bar: "1", baz: ["2", "3"]} - assert $ map show (M4 { myField: 42 }) == M4 { myField: "42" } :: MA String + assert $ map show (M4 { myField: 42 }) == M4 { myField: "42" } :: MA String log "Done" diff --git a/examples/passing/Eq1Deriving.purs b/examples/passing/Eq1Deriving.purs new file mode 100644 index 0000000000..52ff900b8f --- /dev/null +++ b/examples/passing/Eq1Deriving.purs @@ -0,0 +1,12 @@ +module Main where + +import Prelude +import Data.Eq (class Eq1) +import Control.Monad.Eff.Console (log) + +data Product a b = Product a b + +derive instance eqMu :: (Eq a, Eq b) => Eq (Product a b) +derive instance eq1Mu :: Eq a => Eq1 (Product a) + +main = log "Done" diff --git a/examples/passing/Eq1InEqDeriving.purs b/examples/passing/Eq1InEqDeriving.purs new file mode 100644 index 0000000000..a916c87804 --- /dev/null +++ b/examples/passing/Eq1InEqDeriving.purs @@ -0,0 +1,11 @@ +module Main where + +import Prelude +import Data.Eq (class Eq1) +import Control.Monad.Eff.Console (log) + +newtype Mu f = In (f (Mu f)) + +derive instance eqMu :: Eq1 f => Eq (Mu f) + +main = log "Done" diff --git a/examples/passing/Ord1Deriving.purs b/examples/passing/Ord1Deriving.purs new file mode 100644 index 0000000000..88a6394c2b --- /dev/null +++ b/examples/passing/Ord1Deriving.purs @@ -0,0 +1,16 @@ +module Main where + +import Prelude +import Data.Eq (class Eq1) +import Data.Ord (class Ord1) +import Control.Monad.Eff.Console (log) + +data Product a b = Product a b + +derive instance eqMu :: (Eq a, Eq b) => Eq (Product a b) +derive instance eq1Mu :: Eq a => Eq1 (Product a) + +derive instance ordMu :: (Ord a, Ord b) => Ord (Product a b) +derive instance ord1Mu :: Ord a => Ord1 (Product a) + +main = log "Done" diff --git a/examples/passing/Ord1InOrdDeriving.purs b/examples/passing/Ord1InOrdDeriving.purs new file mode 100644 index 0000000000..00ae1ca997 --- /dev/null +++ b/examples/passing/Ord1InOrdDeriving.purs @@ -0,0 +1,13 @@ +module Main where + +import Prelude +import Data.Eq (class Eq1) +import Data.Ord (class Ord1) +import Control.Monad.Eff.Console (log) + +newtype Mu f = In (f (Mu f)) + +derive instance eqMu :: Eq1 f => Eq (Mu f) +derive instance ordMu :: Ord1 f => Ord (Mu f) + +main = log "Done" diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 8b2d56d19d..57b01d07a9 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -100,6 +100,9 @@ greaterThanOrEq = "greaterThanOrEq" eq :: forall a. (IsString a) => a eq = "eq" +eq1 :: forall a. (IsString a) => a +eq1 = "eq1" + (/=) :: forall a. (IsString a) => a (/=) = "/=" @@ -109,6 +112,9 @@ notEq = "notEq" compare :: forall a. (IsString a) => a compare = "compare" +compare1 :: forall a. (IsString a) => a +compare1 = "compare1" + (&&) :: forall a. (IsString a) => a (&&) = "&&" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 27fcf75393..279785c0f0 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -121,6 +121,13 @@ deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps c -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveEq ss mn syns ds tyCon | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 + | className == Qualified (Just dataEq) (ProperName "Eq1") + = case tys of + [ty] | Just (Qualified mn' _, _) <- unwrapTypeConstructor ty + , mn == fromMaybe mn mn' + -> pure . TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance $ deriveEq1 ss + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataOrd) (ProperName "Ord") = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty @@ -128,6 +135,13 @@ deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps c -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveOrd ss mn syns ds tyCon | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 + | className == Qualified (Just dataOrd) (ProperName "Ord1") + = case tys of + [ty] | Just (Qualified mn' _, _) <- unwrapTypeConstructor ty + , mn == fromMaybe mn mn' + -> pure . TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance $ deriveOrd1 ss + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataFunctor) (ProperName "Functor") = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty @@ -436,6 +450,9 @@ deriveEq ss mn syns ds tyConNm = do preludeEq :: Expr -> Expr -> Expr preludeEq = App . App (Var (Qualified (Just dataEq) (Ident C.eq))) + preludeEq1 :: Expr -> Expr -> Expr + preludeEq1 = App . App (Var (Qualified (Just dataEq) (Ident C.eq1))) + addCatch :: [CaseAlternative] -> [CaseAlternative] addCatch xs | length xs /= 1 = xs ++ [catchAll] @@ -458,12 +475,21 @@ deriveEq ss mn syns ds tyConNm = do conjAll xs = foldl1 preludeConj xs toEqTest :: Expr -> Expr -> Type -> Expr - toEqTest l r ty | Just rec <- objectType ty - , Just fields <- decomposeRec rec = - conjAll - . map (\((Label str), typ) -> toEqTest (Accessor str l) (Accessor str r) typ) - $ fields - toEqTest l r _ = preludeEq l r + toEqTest l r ty + | Just rec <- objectType ty + , Just fields <- decomposeRec rec = + conjAll + . map (\((Label str), typ) -> toEqTest (Accessor str l) (Accessor str r) typ) + $ fields + | isAppliedVar ty = preludeEq1 l r + | otherwise = preludeEq l r + +deriveEq1 :: SourceSpan -> [Declaration] +deriveEq1 ss = + [ ValueDecl (ss, []) (Ident C.eq1) Public [] (unguarded preludeEq)] + where + preludeEq :: Expr + preludeEq = Var (Qualified (Just dataEq) (Ident C.eq)) deriveOrd :: forall m @@ -510,6 +536,9 @@ deriveOrd ss mn syns ds tyConNm = do ordCompare :: Expr -> Expr -> Expr ordCompare = App . App (Var (Qualified (Just dataOrd) (Ident C.compare))) + ordCompare1 :: Expr -> Expr -> Expr + ordCompare1 = App . App (Var (Qualified (Just dataOrd) (Ident C.compare1))) + mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative] mkCtorClauses ((ctorName, tys), isLast) = do identsL <- replicateM (length tys) (freshIdent "l") @@ -547,12 +576,21 @@ deriveOrd ss mn syns ds tyConNm = do ] toOrdering :: Expr -> Expr -> Type -> Expr - toOrdering l r ty | Just rec <- objectType ty - , Just fields <- decomposeRec rec = - appendAll - . map (\((Label str), typ) -> toOrdering (Accessor str l) (Accessor str r) typ) - $ fields - toOrdering l r _ = ordCompare l r + toOrdering l r ty + | Just rec <- objectType ty + , Just fields <- decomposeRec rec = + appendAll + . map (\((Label str), typ) -> toOrdering (Accessor str l) (Accessor str r) typ) + $ fields + | isAppliedVar ty = ordCompare1 l r + | otherwise = ordCompare l r + +deriveOrd1 :: SourceSpan -> [Declaration] +deriveOrd1 ss = + [ ValueDecl (ss, []) (Ident C.compare1) Public [] (unguarded dataOrdCompare)] + where + dataOrdCompare :: Expr + dataOrdCompare = Var (Qualified (Just dataOrd) (Ident C.compare)) deriveNewtype :: forall m @@ -617,6 +655,10 @@ mkVarMn mn = Var . Qualified mn mkVar :: Ident -> Expr mkVar = mkVarMn Nothing +isAppliedVar :: Type -> Bool +isAppliedVar (TypeApp (TypeVar _) _) = True +isAppliedVar _ = False + objectType :: Type -> Maybe Type objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec objectType _ = Nothing From 939b9d0946279e5a06b89a01ab2fb918e45a86cb Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Sun, 21 Jan 2018 14:21:38 -0500 Subject: [PATCH 0922/1580] update stack resolver to lts-10.3 (#3209) `stack build` will thus use GHC 8.2.2 --- appveyor.yml | 2 +- package.yaml | 2 +- stack.yaml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/appveyor.yml b/appveyor.yml index aedd5650a0..d2788c2071 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -3,7 +3,7 @@ version: '{build}' environment: # Keep the path as short as possible, just in case. STACK_ROOT: c:\s - STACK_VER: 1.5.1 + STACK_VER: 1.6.3 RELEASE_USER: purescript RELEASE_REPO: purescript branches: diff --git a/package.yaml b/package.yaml index 69c0362f15..18345642b4 100644 --- a/package.yaml +++ b/package.yaml @@ -34,7 +34,7 @@ extra-source-files: dependencies: - aeson >=1.0 && <1.3 - aeson-better-errors >=0.8 - - ansi-terminal >=0.6.2 && <0.7 + - ansi-terminal >=0.7.1 && <0.8 - base >=4.8 && <5 - base-compat >=0.6.0 - blaze-html >=0.8.1 && <0.10 diff --git a/stack.yaml b/stack.yaml index 4336168e7a..e15349401f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2017-11-20 +resolver: lts-10.3 packages: - '.' extra-deps: From 30de1f87514b96a53fed0d1c83160af5f05f824f Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 21 Jan 2018 23:47:05 +0100 Subject: [PATCH 0923/1580] [purs ide] Find Usages round two (#3206) * don't prematurely convert from a Map to a List * adds getModuleDeclarations * [WIP] Finds modules that are eligible for usage search * adds a Playground file for easier experimentation in GHCI * first simple matches * Clean up applySearch code, use a better Search type * find constructor usages in binders as well as Operator usages * adds a Command for findUsages * collect usages and return result * more playground tests * adds testcases * removes testing ground * moving code around, a little documentation * documentation * include ide test sources nested in a directory * adds a few lines to the design document also updates a few outdated paragraphs --- package.yaml | 6 +- psc-ide/DESIGN.org | 19 +- psc-ide/PROTOCOL.md | 55 ++++-- src/Language/PureScript/AST/Declarations.hs | 4 + src/Language/PureScript/Ide.hs | 18 +- src/Language/PureScript/Ide/Command.hs | 12 ++ src/Language/PureScript/Ide/Imports.hs | 3 +- src/Language/PureScript/Ide/State.hs | 9 +- src/Language/PureScript/Ide/Types.hs | 2 + src/Language/PureScript/Ide/Usage.hs | 165 ++++++++++++++++++ src/Language/PureScript/Names.hs | 4 +- tests/Language/PureScript/Ide/UsageSpec.hs | 69 ++++++++ tests/support/pscide/src/FindUsage.purs | 12 ++ .../pscide/src/FindUsage/Definition.purs | 13 ++ .../pscide/src/FindUsage/Reexport.purs | 3 + 15 files changed, 367 insertions(+), 27 deletions(-) create mode 100644 src/Language/PureScript/Ide/Usage.hs create mode 100644 tests/Language/PureScript/Ide/UsageSpec.hs create mode 100644 tests/support/pscide/src/FindUsage.purs create mode 100644 tests/support/pscide/src/FindUsage/Definition.purs create mode 100644 tests/support/pscide/src/FindUsage/Reexport.purs diff --git a/package.yaml b/package.yaml index 18345642b4..6a2b0bf4d6 100644 --- a/package.yaml +++ b/package.yaml @@ -23,9 +23,9 @@ extra-source-files: - tests/support/*.json - tests/support/setup-win.cmd - tests/support/psci/*.purs - - tests/support/pscide/src/*.purs - - tests/support/pscide/src/*.js - - tests/support/pscide/src/*.fail + - tests/support/pscide/src/**/*.purs + - tests/support/pscide/src/**/*.js + - tests/support/pscide/src/**/*.fail - stack.yaml - README.md - INSTALL.md diff --git a/psc-ide/DESIGN.org b/psc-ide/DESIGN.org index 00129e6603..af4e023e08 100644 --- a/psc-ide/DESIGN.org +++ b/psc-ide/DESIGN.org @@ -225,10 +225,21 @@ it asynchronously and just return the errors/warnings to the editors immediately. In a test setting however, we might want to test that the rebuild cache was filled properly and serves completions for private members. (Examples: Language.PureScript.Ide.RebuildSpec) +** Find Usages + Important Files: Ide.Usages + + Find usages is implemented to execute during query time, rather than load + time, to reduce memory usage. We expect the callee to provide us with a + module name, namespace, and textual identifier, which uniquely identifies a + declaration. + + By starting from a given declaration we can efficiently filter the set of all + modules by only looking at reexports and imports first before we perform + expensive ASTs traversals searching for usages. ** Everything else * Tips and Tricks ** Running only =ide='s test suite - ~stack test --test-arguments "-m Language.PureScript.Ide"~ + ~stack test --ta "-p ide"~ * Facts and thoughts without a good place yet ** Using externs files as source of truth *** Pros @@ -251,9 +262,11 @@ Language.PureScript.Ide.RebuildSpec) - No source positions or docstrings ** When source globs are added *** New features enabled -- Enables go-to-definition by allowing us to grab source spans for declarations +- Enables go-to-definition by allowing us to collect source spans for + declarations - Enables us to recover type signatures without synonyms expanded -- Enables us to grab docstrings (We don't do that yet, unfortunately) +- Enables us to collect docstrings +- Enables us to collect usages *** Cons - Slower startup (Actually the load command takes longer, but because the server is useless until load has been run I count that as startup). Startup on diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index 33e8c2476c..2c7b6c2f8f 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -10,7 +10,15 @@ otherwise behaves the same, accepting a line of JSON on stdin and exiting after giving a result on stdout. The result needs to be unwrapped from the "wrapper" which separates success -from failure. This wrapper is described at the end of this document. +from failure: + +```json +{ + "resultType": "success|error", + "result": Result|Error +} +``` + ## Command: ### Load @@ -180,6 +188,40 @@ The following format is returned as the Result: ``` You should then be able to replace the affected line of code in the editor with the new suggestions. +### Usages + +The Usages command accepts a triplet of modulename, namespace, and identifier, +which uniquely identify a declaration and returns all usages of that identifier +in all loaded files. Note that we use the parsed source files, so you need to +pass source globs at startup to use this command. + +```json +{ + "command": "usages", + "params": { + "module": "Data.Array", + "namespace": "value|type|kind", + "identifier": "filter" + } +} +``` + +**Result:** + +The following format is returned as the Result: + +```json +[ { "name": "/path/to/file" + , "start": [1, 3] + , "end": [3, 1] + } +, { "name": "/path/to/file" + , "start": [5, 6] + , "end": [5, 8] + } +] +``` + ### Import For now all of the import related commands work with a file on the filesystem. @@ -668,17 +710,6 @@ the edit distance in between the search and the loaded identifiers. } ``` -## Responses - -All Responses are wrapped in the following format: - -```json -{ - "resultType": "success|error", - "result": Result|Error -} -``` - ## CompletionOptions Completion options allow to configure the number of returned completion results. diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 5771fe6f6f..08ae8ea61d 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -232,6 +232,10 @@ getModuleName (Module _ _ name _ _) = name getModuleSourceSpan :: Module -> SourceSpan getModuleSourceSpan (Module ss _ _ _ _) = ss +-- | Return a module's declarations. +getModuleDeclarations :: Module -> [Declaration] +getModuleDeclarations (Module _ _ _ declarations _) = declarations + -- | -- Add an import declaration for a module if it does not already explicitly import it. -- diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index d6e339d139..a6d98f78c9 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -18,9 +18,10 @@ module Language.PureScript.Ide ( handleCommand ) where -import Protolude +import Protolude hiding (moduleName) import "monad-logger" Control.Monad.Logger +import qualified Data.Map as Map import qualified Language.PureScript as P import qualified Language.PureScript.Constants as C import qualified Language.PureScript.Ide.CaseSplit as CS @@ -38,6 +39,7 @@ import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import Language.PureScript.Ide.Usage (findUsages) import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist, doesFileExist) import System.FilePath (()) import System.FilePath.Glob (glob) @@ -75,6 +77,16 @@ handleCommand c = case c of caseSplit l b e wca t AddClause l wca -> MultilineTextResult <$> CS.addClause l wca + FindUsages moduleName ident namespace -> do + Map.lookup moduleName <$> getAllModules Nothing >>= \case + Nothing -> throwError (GeneralError "Module not found") + Just decls -> do + case find (\d -> namespaceForDeclaration (discardAnn d) == namespace + && identifierFromIdeDeclaration (discardAnn d) == ident) decls of + Nothing -> throwError (GeneralError "Declaration not found") + Just declaration -> do + let sourceModule = fromMaybe moduleName (declaration & _idaAnnotation & _annExportedFrom) + UsagesResult . fold <$> findUsages (discardAnn declaration) sourceModule Import fp outfp _ (AddImplicitImport mn) -> do rs <- addImplicitImport fp mn answerRequest outfp rs @@ -106,14 +118,14 @@ findCompletions -> CompletionOptions -> m Success findCompletions filters matcher currentModule complOptions = do - modules <- getAllModules currentModule + modules <- Map.toList <$> getAllModules currentModule let insertPrim = (:) (C.Prim, idePrimDeclarations) pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules))) findType :: Ide m => Text -> [Filter] -> Maybe P.ModuleName -> m Success findType search filters currentModule = do - modules <- getAllModules currentModule + modules <- Map.toList <$> getAllModules currentModule let insertPrim = (:) (C.Prim, idePrimDeclarations) pure (CompletionResult (getExactCompletions search filters (insertPrim modules))) diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 46c6f3d913..5541814f50 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -53,6 +53,11 @@ data Command { addClauseLine :: Text , addClauseAnnotations :: WildcardAnnotations } + | FindUsages + { usagesModule :: P.ModuleName + , usagesIdentifier :: Text + , usagesNamespace :: IdeNamespace + } -- Import InputFile OutputFile | Import FilePath (Maybe FilePath) [Filter] ImportCommand | List { listType :: ListType } @@ -71,6 +76,7 @@ commandName c = case c of Pursuit{} -> "Pursuit" CaseSplit{} -> "CaseSplit" AddClause{} -> "AddClause" + FindUsages{} -> "FindUsages" Import{} -> "Import" List{} -> "List" Rebuild{} -> "Rebuild" @@ -158,6 +164,12 @@ instance FromJSON Command where AddClause <$> params .: "line" <*> (mkAnnotations <$> params .: "annotations") + "usages" -> do + params <- o .: "params" + FindUsages + <$> (map P.moduleNameFromString (params .: "module")) + <*> params .: "identifier" + <*> params .: "namespace" "import" -> do params <- o .: "params" Import diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 82ec75c08b..f1c510a85a 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -34,6 +34,7 @@ import Protolude hiding (moduleName) import Control.Lens ((^.), (%~), ix) import Data.List (findIndex, nubBy, partition) +import qualified Data.Map as Map import qualified Data.Text as T import qualified Language.PureScript as P import Language.PureScript.Ide.Completion @@ -261,7 +262,7 @@ addImportForIdentifier :: (Ide m, MonadError IdeError m) -- the identifier -> m (Either [Match IdeDeclaration] [Text]) addImportForIdentifier fp ident qual filters = do - modules <- getAllModules Nothing + modules <- Map.toList <$> getAllModules Nothing case map (fmap discardAnn) (getExactMatches ident filters modules) of [] -> throwError (NotFound "Couldn't find the given identifier. \ diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 28211f9423..b34f465d7d 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -20,6 +20,7 @@ module Language.PureScript.Ide.State ( getLoadedModulenames , getExternFiles + , getFileState , resetIdeState , cacheRebuild , cachedRebuild @@ -114,12 +115,12 @@ setVolatileStateSTM ref vs = do -- | Checks if the given ModuleName matches the last rebuild cache and if it -- does returns all loaded definitions + the definitions inside the rebuild -- cache -getAllModules :: Ide m => Maybe P.ModuleName -> m [(P.ModuleName, [IdeDeclarationAnn])] +getAllModules :: Ide m => Maybe P.ModuleName -> m (ModuleMap [IdeDeclarationAnn]) getAllModules mmoduleName = do declarations <- vsDeclarations <$> getVolatileState rebuild <- cachedRebuild case mmoduleName of - Nothing -> pure (Map.toList declarations) + Nothing -> pure declarations Just moduleName -> case rebuild of Just (cachedModulename, ef) @@ -135,8 +136,8 @@ getAllModules mmoduleName = do resolved = Map.adjust (resolveOperatorsForModule tmp) moduleName tmp - pure (Map.toList resolved) - _ -> pure (Map.toList declarations) + pure resolved + _ -> pure declarations -- | Adds an ExternsFile into psc-ide's FileState. This does not populate the -- VolatileState, which needs to be done after all the necessary Externs and diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index f013ace268..8a6a388c7e 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -224,6 +224,7 @@ identifierFromDeclarationRef _ = "" data Success = CompletionResult [Completion] | TextResult Text + | UsagesResult [P.SourceSpan] | MultilineTextResult [Text] | PursuitResult [PursuitResponse] | ImportList (P.ModuleName, [(P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)]) @@ -238,6 +239,7 @@ encodeSuccess res = instance ToJSON Success where toJSON (CompletionResult cs) = encodeSuccess cs toJSON (TextResult t) = encodeSuccess t + toJSON (UsagesResult ssp) = encodeSuccess ssp toJSON (MultilineTextResult ts) = encodeSuccess ts toJSON (PursuitResult resp) = encodeSuccess resp toJSON (ImportList (moduleName, imports)) = object [ "resultType" .= ("success" :: Text) diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs new file mode 100644 index 0000000000..3d61297c30 --- /dev/null +++ b/src/Language/PureScript/Ide/Usage.hs @@ -0,0 +1,165 @@ +module Language.PureScript.Ide.Usage + ( findReexportingModules + , directDependants + , eligibleModules + , applySearch + , findUsages + ) where + +import Protolude hiding (moduleName) + +import Control.Lens (preview) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Language.PureScript as P +import Language.PureScript.Ide.State (getAllModules, getFileState) +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util + +-- | +-- How we find usages, given an IdeDeclaration and the module it was defined in: +-- +-- 1. Find all modules that reexport the given declaration +-- 2. Find all modules that import from those modules, and while traversing the +-- imports build a specification for how the identifier can be found in the +-- module. +-- 3. Apply the collected search specifications and collect the results +findUsages + :: (MonadIO m, Ide m) + => IdeDeclaration + -> P.ModuleName + -> m (ModuleMap [P.SourceSpan]) +findUsages declaration moduleName = do + ms <- getAllModules Nothing + asts <- Map.map fst . fsModules <$> getFileState + let elig = eligibleModules (moduleName, declaration) ms asts + pure + $ Map.filter (not . null) + $ Map.mapWithKey (\mn searches -> + foldMap (\m -> foldMap (applySearch m) searches) (Map.lookup mn asts)) elig + +-- | A declaration can either be imported qualified, or unqualified. All the +-- information we need to find usages through a Traversal is thus captured in +-- the `Search` type. +type Search = P.Qualified IdeDeclaration + +findReexportingModules + :: (P.ModuleName, IdeDeclaration) + -- ^ The declaration and the module it is defined in for which we are + -- searching usages + -> ModuleMap [IdeDeclarationAnn] + -- ^ Our declaration cache. Needs to have reexports resolved + -> [P.ModuleName] + -- ^ All the modules that reexport the declaration. This does NOT include + -- the defining module +findReexportingModules (moduleName, declaration) decls = + Map.keys (Map.filter (any hasReexport) decls) + where + hasReexport d = + (d & _idaDeclaration & identifierFromIdeDeclaration) == identifierFromIdeDeclaration declaration + && (d & _idaAnnotation & _annExportedFrom) == Just moduleName + && (d & _idaDeclaration & namespaceForDeclaration) == namespaceForDeclaration declaration + +directDependants :: IdeDeclaration -> ModuleMap P.Module -> P.ModuleName -> ModuleMap (NonEmpty Search) +directDependants declaration modules mn = Map.mapMaybe (nonEmpty . go) modules + where + go :: P.Module -> [Search] + go = foldMap isImporting . P.getModuleDeclarations + + isImporting d = case d of + P.ImportDeclaration _ mn' it qual | mn == mn' -> P.Qualified qual <$> case it of + P.Implicit -> pure declaration + P.Explicit refs + | any (declaration `matchesRef`) refs -> pure declaration + P.Explicit _ -> [] + P.Hiding refs + | not (any (declaration `matchesRef`) refs) -> pure declaration + P.Hiding _ -> [] + _ -> [] + +-- | Determines whether an IdeDeclaration is referenced by a DeclarationRef. +-- +-- TODO(Christoph): We should also extract the spans of matching refs here, +-- since they also count as a usage (at least for rename refactorings) +matchesRef :: IdeDeclaration -> P.DeclarationRef -> Bool +matchesRef declaration ref = case declaration of + IdeDeclValue valueDecl -> case ref of + P.ValueRef _ i -> i == _ideValueIdent valueDecl + _ -> False + IdeDeclType typeDecl -> case ref of + P.TypeRef _ tn _ -> tn == _ideTypeName typeDecl + _ -> False + IdeDeclTypeSynonym synonym -> case ref of + P.TypeRef _ tn _ -> tn == _ideSynonymName synonym + _ -> False + IdeDeclDataConstructor dtor -> case ref of + P.TypeRef _ tn dtors + -- We check if the given data constructor constructs the type imported + -- here. + -- This way we match `Just` with an import like `import Data.Maybe (Maybe(..))` + | _ideDtorTypeName dtor == tn -> + maybe True (elem (_ideDtorName dtor)) dtors + _ -> False + IdeDeclTypeClass typeClass -> case ref of + P.TypeClassRef _ name -> name == _ideTCName typeClass + _ -> False + IdeDeclValueOperator valueOperator -> case ref of + P.ValueOpRef _ opName -> opName == _ideValueOpName valueOperator + _ -> False + IdeDeclTypeOperator typeOperator -> case ref of + P.TypeOpRef _ opName -> opName == _ideTypeOpName typeOperator + _ -> False + IdeDeclKind kind -> case ref of + P.KindRef _ kindName -> kindName == kind + _ -> False + +eligibleModules + :: (P.ModuleName, IdeDeclaration) + -> ModuleMap [IdeDeclarationAnn] + -> ModuleMap P.Module + -> ModuleMap (NonEmpty Search) +eligibleModules query@(moduleName, declaration) decls modules = + let + searchDefiningModule = P.Qualified Nothing declaration :| [] + in + Map.insert moduleName searchDefiningModule $ + foldMap (directDependants declaration modules) (moduleName :| findReexportingModules query decls) + +-- | Finds all usages for a given `Search` throughout a module +applySearch :: P.Module -> Search -> [P.SourceSpan] +applySearch module_ search = + -- TODO(Christoph): Figure out how to find usages inside the defining module. + -- The Traversal adds declarations for the current module into `scope` so we + -- can't tell shadowed variable from actual usage. + let + decls = P.getModuleDeclarations module_ + (extr, _, _, _, _) = P.everythingWithScope mempty goExpr goBinder mempty mempty + + goExpr scope expr = case expr of + P.PositionedValue sp _ (P.Var i) + | Just ideValue <- preview _IdeDeclValue (P.disqualify search) + , P.isQualified search || not (_ideValueIdent ideValue `Set.member` scope) -> + [sp | map P.runIdent i == map identifierFromIdeDeclaration search] + + P.PositionedValue sp _ (P.Constructor name) + | Just ideDtor <- traverse (preview _IdeDeclDataConstructor) search -> + [sp | name == map _ideDtorName ideDtor] + P.PositionedValue sp _ (P.Op opName) + | Just ideOp <- traverse (preview _IdeDeclValueOperator) search -> + [sp | opName == map _ideValueOpName ideOp] + _ -> [] + + goBinder _ binder = case binder of + P.PositionedBinder sp _ (P.ConstructorBinder ctorName _) + | Just ideDtor <- traverse (preview _IdeDeclDataConstructor) search -> + [sp | ctorName == map _ideDtorName ideDtor] + P.PositionedBinder sp _ (P.OpBinder opName) + | Just op <- traverse (preview _IdeDeclValueOperator) search -> + [sp | opName == map _ideValueOpName op] + P.PositionedBinder sp _ (P.BinaryNoParensBinder (P.OpBinder opName) _ _) + | Just op <- traverse (preview _IdeDeclValueOperator) search -> + [sp | opName == map _ideValueOpName op] + _ -> [] + in + foldMap (extr mempty) decls + diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 701de1d499..77c927d49a 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -1,5 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} -- | -- Data types for names @@ -176,7 +178,7 @@ moduleNameFromString = ModuleName . splitProperNames -- A qualified name, i.e. a name with an optional module name -- data Qualified a = Qualified (Maybe ModuleName) a - deriving (Show, Eq, Ord, Functor, Generic) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) instance NFData a => NFData (Qualified a) diff --git a/tests/Language/PureScript/Ide/UsageSpec.hs b/tests/Language/PureScript/Ide/UsageSpec.hs new file mode 100644 index 0000000000..ec1ddd26e5 --- /dev/null +++ b/tests/Language/PureScript/Ide/UsageSpec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Language.PureScript.Ide.UsageSpec where + +import Protolude + +import qualified Data.Text as Text +import Language.PureScript.Ide.Command +import Language.PureScript.Ide.Types +import qualified Language.PureScript.Ide.Test as Test +import qualified Language.PureScript as P +import Test.Hspec +import Data.Text.Read (decimal) +import System.FilePath + +load :: [Text] -> Command +load = LoadSync . map Test.mn + +usage :: P.ModuleName -> Text -> IdeNamespace -> Command +usage mn ident ns = FindUsages mn ident ns + +shouldBeUsage :: P.SourceSpan -> (FilePath, Text) -> Expectation +shouldBeUsage usage' (fp, range) = + let + [ start, end] = Text.splitOn "-" range + unsafeReadInt = fst . either (panic "") identity . decimal + [ startLine, startColumn ] = map unsafeReadInt (Text.splitOn ":" start) + [ endLine, endColumn ] = map unsafeReadInt (Text.splitOn ":" end) + in + do + fp `shouldBe` P.spanName usage' + + (startLine, startColumn) + `shouldBe` + ( P.sourcePosLine (P.spanStart usage') + , P.sourcePosColumn (P.spanStart usage')) + (endLine, endColumn) + `shouldBe` + ( P.sourcePosLine (P.spanEnd usage') + , P.sourcePosColumn (P.spanEnd usage')) + +spec :: Spec +spec = describe "Finding Usages" $ do + it "finds a simple usage" $ do + ([_, Right (UsagesResult [usage1])], _) <- Test.inProject $ + Test.runIde [ load ["FindUsage", "FindUsage.Definition", "FindUsage.Reexport"] + , usage (Test.mn "FindUsage.Definition") "usageId" IdeNSValue + ] + usage1 `shouldBeUsage` ("src" "FindUsage.purs", "12:11-12:18") + it "finds a constructor usage" $ do + ([_, Right (UsagesResult [usage1])], _) <- Test.inProject $ + Test.runIde [ load ["FindUsage", "FindUsage.Definition", "FindUsage.Reexport"] + , usage (Test.mn "FindUsage.Definition") "Used" IdeNSValue + ] + usage1 `shouldBeUsage` ("src" "FindUsage.purs", "8:3-8:9") + it "finds a constructor alias usage" $ do + ([_, Right (UsagesResult [usage1])], _) <- Test.inProject $ + Test.runIde [ load ["FindUsage", "FindUsage.Definition", "FindUsage.Reexport"] + , usage (Test.mn "FindUsage.Definition") "$%" IdeNSValue + ] + usage1 `shouldBeUsage` ("src" "FindUsage.purs", "9:3-9:9") + it "finds a reexported usage" $ do + ([_, Right (UsagesResult [usage1])], _) <- Test.inProject $ + Test.runIde [ load ["FindUsage", "FindUsage.Definition", "FindUsage.Reexport"] + , usage (Test.mn "FindUsage.Reexport") "toBeReexported" IdeNSValue + ] + -- TODO(Christoph): Interesting parser bug here. It seems the position + -- of the last token in the file has the wrong ending span + usage1 `shouldBeUsage` ("src" "FindUsage.purs", "12:19-12:19") diff --git a/tests/support/pscide/src/FindUsage.purs b/tests/support/pscide/src/FindUsage.purs new file mode 100644 index 0000000000..b8a6ab094e --- /dev/null +++ b/tests/support/pscide/src/FindUsage.purs @@ -0,0 +1,12 @@ +module FindUsage where + +import FindUsage.Definition (usageId, ($%), Usage(..)) +import FindUsage.Reexport (toBeReexported) + +usagePatternMatch ∷ Usage → Usage +usagePatternMatch x = case x of + Used _ → x + _ $% _ → x + +usageFn ∷ ∀ a. a → a +usageFn = usageId toBeReexported diff --git a/tests/support/pscide/src/FindUsage/Definition.purs b/tests/support/pscide/src/FindUsage/Definition.purs new file mode 100644 index 0000000000..f94b60500e --- /dev/null +++ b/tests/support/pscide/src/FindUsage/Definition.purs @@ -0,0 +1,13 @@ +module FindUsage.Definition (Usage(..), ($%), usageId, toBeReexported) where + +data Usage + = Used Int + | Usage Int Int + +infixl 2 Usage as $% + +usageId ∷ ∀ a. a → a +usageId x = x + +toBeReexported ∷ ∀ a. a → a +toBeReexported = usageId diff --git a/tests/support/pscide/src/FindUsage/Reexport.purs b/tests/support/pscide/src/FindUsage/Reexport.purs new file mode 100644 index 0000000000..7a55c39097 --- /dev/null +++ b/tests/support/pscide/src/FindUsage/Reexport.purs @@ -0,0 +1,3 @@ +module FindUsage.Reexport (module X) where + +import FindUsage.Definition (toBeReexported) as X From ce94cd94e836a013c52ab8f7545ff6dd63c7e69c Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 21 Jan 2018 23:23:15 +0000 Subject: [PATCH 0924/1580] Add source spans to name constructors and fix `ShadowedName` warning (#3213) --- src/Language/PureScript/AST/Binders.hs | 17 +++-- src/Language/PureScript/AST/Declarations.hs | 12 ++-- src/Language/PureScript/AST/SourcePos.hs | 3 + src/Language/PureScript/AST/Traversals.hs | 42 +++++------ src/Language/PureScript/CoreFn/Desugar.hs | 18 ++--- src/Language/PureScript/Interactive/Module.hs | 4 +- src/Language/PureScript/Linter.hs | 10 +-- src/Language/PureScript/Linter/Exhaustive.hs | 20 +++--- src/Language/PureScript/Parser/Common.hs | 5 ++ .../PureScript/Parser/Declarations.hs | 64 +++++++++-------- src/Language/PureScript/Pretty/Values.hs | 20 +++--- src/Language/PureScript/Sugar/AdoNotation.hs | 14 ++-- .../PureScript/Sugar/BindingGroups.hs | 8 +-- .../PureScript/Sugar/CaseDeclarations.hs | 24 +++---- src/Language/PureScript/Sugar/DoNotation.hs | 12 ++-- src/Language/PureScript/Sugar/Names.hs | 28 ++++---- .../PureScript/Sugar/ObjectWildcards.hs | 16 ++--- src/Language/PureScript/Sugar/Operators.hs | 24 +++---- .../PureScript/Sugar/Operators/Binders.hs | 8 +-- .../PureScript/Sugar/Operators/Common.hs | 25 ++++--- .../PureScript/Sugar/Operators/Expr.hs | 10 +-- .../PureScript/Sugar/Operators/Types.hs | 9 +-- src/Language/PureScript/Sugar/TypeClasses.hs | 4 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 72 +++++++++---------- .../PureScript/TypeChecker/Entailment.hs | 12 ++-- .../PureScript/TypeChecker/TypeSearch.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 45 ++++++------ 27 files changed, 271 insertions(+), 257 deletions(-) diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index 834b4be9b6..c5054ce216 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -26,16 +26,16 @@ data Binder -- | -- A binder which binds an identifier -- - | VarBinder Ident + | VarBinder SourceSpan Ident -- | -- A binder which matches a data constructor -- - | ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder] + | ConstructorBinder SourceSpan (Qualified (ProperName 'ConstructorName)) [Binder] -- | -- A operator alias binder. During the rebracketing phase of desugaring, -- this data constructor will be removed. -- - | OpBinder (Qualified (OpName 'ValueOpName)) + | OpBinder SourceSpan (Qualified (OpName 'ValueOpName)) -- | -- Binary operator application. During the rebracketing phase of desugaring, -- this data constructor will be removed. @@ -52,7 +52,7 @@ data Binder -- | -- A binder which binds its input to an identifier -- - | NamedBinder Ident Binder + | NamedBinder SourceSpan Ident Binder -- | -- A binder with source position information -- @@ -70,11 +70,11 @@ binderNames :: Binder -> [Ident] binderNames = go [] where go ns (LiteralBinder b) = lit ns b - go ns (VarBinder name) = name : ns - go ns (ConstructorBinder _ bs) = foldl go ns bs + go ns (VarBinder _ name) = name : ns + go ns (ConstructorBinder _ _ bs) = foldl go ns bs go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3] go ns (ParensInBinder b) = go ns b - go ns (NamedBinder name b) = go (name : ns) b + go ns (NamedBinder _ name b) = go (name : ns) b go ns (PositionedBinder _ _ b) = go ns b go ns (TypedBinder _ b) = go ns b go ns _ = ns @@ -84,8 +84,7 @@ binderNames = go [] isIrrefutable :: Binder -> Bool isIrrefutable NullBinder = True -isIrrefutable (VarBinder _) = True +isIrrefutable (VarBinder _ _) = True isIrrefutable (PositionedBinder _ _ b) = isIrrefutable b isIrrefutable (TypedBinder _ b) = isIrrefutable b isIrrefutable _ = False - diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 08ae8ea61d..41eabcab53 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -701,7 +701,7 @@ data Expr -- | -- A prefix -, will be desugared -- - | UnaryMinus Expr + | UnaryMinus SourceSpan Expr -- | -- Binary operator application. During the rebracketing phase of desugaring, this data constructor -- will be removed. @@ -741,12 +741,12 @@ data Expr -- | -- Variable -- - | Var (Qualified Ident) + | Var SourceSpan (Qualified Ident) -- | -- An operator. This will be desugared into a function during the "operators" -- phase of desugaring. -- - | Op (Qualified (OpName 'ValueOpName)) + | Op SourceSpan (Qualified (OpName 'ValueOpName)) -- | -- Conditional (if-then-else expression) -- @@ -754,7 +754,7 @@ data Expr -- | -- A data constructor -- - | Constructor (Qualified (ProperName 'ConstructorName)) + | Constructor SourceSpan (Qualified (ProperName 'ConstructorName)) -- | -- 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. @@ -887,8 +887,8 @@ $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDe isTrueExpr :: Expr -> Bool isTrueExpr (Literal (BooleanLiteral True)) = True -isTrueExpr (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True -isTrueExpr (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True +isTrueExpr (Var _ (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True +isTrueExpr (Var _ (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True isTrueExpr (TypedValue _ e _) = isTrueExpr e isTrueExpr (PositionedValue _ _ e) = isTrueExpr e isTrueExpr _ = False diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index f208deeb29..60605d7aaa 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -80,3 +80,6 @@ instance A.FromJSON SourceSpan where internalModuleSourceSpan :: String -> SourceSpan internalModuleSourceSpan name = SourceSpan name (SourcePos 0 0) (SourcePos 0 0) + +nullSourceSpan :: SourceSpan +nullSourceSpan = internalModuleSourceSpan "" diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 0dce4ae926..88f87eca54 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -63,7 +63,7 @@ everywhereOnValues f g h = (f', g', h') g' :: Expr -> Expr g' (Literal l) = g (Literal (lit g' l)) - g' (UnaryMinus v) = g (UnaryMinus (g' v)) + g' (UnaryMinus ss v) = g (UnaryMinus ss (g' v)) g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2)) g' (Parens v) = g (Parens (g' v)) g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v)) @@ -82,11 +82,11 @@ everywhereOnValues f g h = (f', g', h') g' other = g other h' :: Binder -> Binder - h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (fmap h' bs)) + h' (ConstructorBinder ss ctor bs) = h (ConstructorBinder ss ctor (fmap h' bs)) h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3)) h' (ParensInBinder b) = h (ParensInBinder (h' b)) h' (LiteralBinder l) = h (LiteralBinder (lit h' l)) - h' (NamedBinder name b) = h (NamedBinder name (h' b)) + h' (NamedBinder ss name b) = h (NamedBinder ss name (h' b)) h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b)) h' (TypedBinder t b) = h (TypedBinder t (h' b)) h' other = h other @@ -137,7 +137,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' :: Expr -> m Expr g' (Literal l) = Literal <$> litM (g >=> g') l - g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g') + g' (UnaryMinus ss v) = UnaryMinus ss <$> (g v >>= g') g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g') g' (Parens v) = Parens <$> (g v >>= g') g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g') @@ -157,10 +157,10 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) h' :: Binder -> m Binder h' (LiteralBinder l) = LiteralBinder <$> litM (h >=> h') l - h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs + h' (ConstructorBinder ss ctor bs) = ConstructorBinder ss ctor <$> traverse (h' <=< h) bs h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h') h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h') - h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h') + h' (NamedBinder ss name b) = NamedBinder ss name <$> (h b >>= h') h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h') h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h') h' other = h other @@ -206,7 +206,7 @@ everywhereOnValuesM f g h = (f', g', h') g' :: Expr -> m Expr g' (Literal l) = (Literal <$> litM g' l) >>= g - g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g + g' (UnaryMinus ss v) = (UnaryMinus ss <$> g' v) >>= g g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g g' (Parens v) = (Parens <$> g' v) >>= g g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g @@ -226,10 +226,10 @@ everywhereOnValuesM f g h = (f', g', h') h' :: Binder -> m Binder h' (LiteralBinder l) = (LiteralBinder <$> litM h' l) >>= h - h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h + h' (ConstructorBinder ss ctor bs) = (ConstructorBinder ss ctor <$> traverse h' bs) >>= h h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h - h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h + h' (NamedBinder ss name b) = (NamedBinder ss name <$> h' b) >>= h h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h h' other = h other @@ -278,7 +278,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') g' :: Expr -> r g' v@(Literal l) = lit (g v) g' l - g' v@(UnaryMinus v1) = g v <> g' v1 + g' v@(UnaryMinus _ v1) = g v <> g' v1 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2 g' v@(Parens v1) = g v <> g' v1 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1 @@ -298,10 +298,10 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') h' :: Binder -> r h' b@(LiteralBinder l) = lit (h b) h' l - h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (fmap h' bs) + h' b@(ConstructorBinder _ _ bs) = foldl (<>) (h b) (fmap h' bs) h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3 h' b@(ParensInBinder b1) = h b <> h' b1 - h' b@(NamedBinder _ b1) = h b <> h' b1 + h' b@(NamedBinder _ _ b1) = h b <> h' b1 h' b@(PositionedBinder _ _ b1) = h b <> h' b1 h' b@(TypedBinder _ b1) = h b <> h' b1 h' b = h b @@ -359,7 +359,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' g' :: s -> Expr -> r g' s (Literal l) = lit g'' s l - g' s (UnaryMinus v1) = g'' s v1 + g' s (UnaryMinus _ v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 g' s (Parens v1) = g'' s v1 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 @@ -382,10 +382,10 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' h' :: s -> Binder -> r h' s (LiteralBinder l) = lit h'' s l - h' s (ConstructorBinder _ bs) = foldl (<>) r0 (fmap (h'' s) bs) + h' s (ConstructorBinder _ _ bs) = foldl (<>) r0 (fmap (h'' s) bs) h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3 h' s (ParensInBinder b) = h'' s b - h' s (NamedBinder _ b1) = h'' s b1 + h' s (NamedBinder _ _ b1) = h'' s b1 h' s (PositionedBinder _ _ b1) = h'' s b1 h' s (TypedBinder _ b1) = h'' s b1 h' _ _ = r0 @@ -444,7 +444,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g'' s = uncurry g' <=< g s g' s (Literal l) = Literal <$> lit g'' s l - g' s (UnaryMinus v) = UnaryMinus <$> g'' s v + g' s (UnaryMinus ss v) = UnaryMinus ss <$> g'' s v g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2 g' s (Parens v) = Parens <$> g'' s v g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v @@ -465,10 +465,10 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j h'' s = uncurry h' <=< h s h' s (LiteralBinder l) = LiteralBinder <$> lit h'' s l - h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs + h' s (ConstructorBinder ss ctor bs) = ConstructorBinder ss ctor <$> traverse (h'' s) bs h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3 h' s (ParensInBinder b) = ParensInBinder <$> h'' s b - h' s (NamedBinder name b) = NamedBinder name <$> h'' s b + h' s (NamedBinder ss name b) = NamedBinder ss name <$> h'' s b h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b h' s (TypedBinder t b) = TypedBinder t <$> h'' s b h' _ other = return other @@ -534,7 +534,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' :: S.Set Ident -> Expr -> r g' s (Literal l) = lit g'' s l - g' s (UnaryMinus v1) = g'' s v1 + g' s (UnaryMinus _ v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 g' s (Parens v1) = g'' s v1 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 @@ -563,10 +563,10 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) h' :: S.Set Ident -> Binder -> r h' s (LiteralBinder l) = lit h'' s l - h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs + h' s (ConstructorBinder _ _ bs) = foldMap (h'' s) bs h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3] h' s (ParensInBinder b) = h'' s b - h' s (NamedBinder name b1) = h'' (S.insert name s) b1 + h' s (NamedBinder _ name b1) = h'' (S.insert name s) b1 h' s (PositionedBinder _ _ b1) = h'' s b1 h' s (TypedBinder _ b1) = h'' s b1 h' _ _ = mempty diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index ed788ab63d..decef9f1f7 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -79,13 +79,13 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) exprToCoreFn ss com ty (A.ObjectUpdate obj vs) = ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ fmap (second (exprToCoreFn ss [] Nothing)) vs - exprToCoreFn ss com ty (A.Abs (A.VarBinder name) v) = + exprToCoreFn ss com ty (A.Abs (A.VarBinder _ name) v) = Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) exprToCoreFn _ _ _ (A.Abs _ _) = internalError "Abs with Binder argument was not desugared before exprToCoreFn mn" exprToCoreFn ss com ty (A.App v1 v2) = App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2) - exprToCoreFn ss com ty (A.Var ident) = + exprToCoreFn _ com ty (A.Var ss ident) = Var (ss, com, ty, getValueMeta ident) ident exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) = Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1] @@ -93,7 +93,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = (Right $ exprToCoreFn ss [] Nothing v2) , CaseAlternative [NullBinder (ssAnn ss)] (Right $ exprToCoreFn ss [] Nothing v3) ] - exprToCoreFn ss com ty (A.Constructor name) = + exprToCoreFn _ com ty (A.Constructor ss name) = Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name exprToCoreFn ss com ty (A.Case vs alts) = Case (ss, com, ty, Nothing) (fmap (exprToCoreFn ss [] Nothing) vs) (fmap (altToCoreFn ss) alts) @@ -137,12 +137,12 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit) binderToCoreFn ss com A.NullBinder = NullBinder (ss, com, Nothing, Nothing) - binderToCoreFn ss com (A.VarBinder name) = + binderToCoreFn _ com (A.VarBinder ss name) = VarBinder (ss, com, Nothing, Nothing) name - binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) = + binderToCoreFn _ com (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = let (_, tctor, _, _) = lookupConstructor env dctor in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (fmap (binderToCoreFn ss []) bs) - binderToCoreFn ss com (A.NamedBinder name b) = + binderToCoreFn _ com (A.NamedBinder ss name b) = NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b) binderToCoreFn _ com (A.PositionedBinder ss com1 b) = binderToCoreFn ss (com ++ com1) b @@ -198,8 +198,8 @@ findQualModules decls = fqDecls _ = [] fqValues :: A.Expr -> [ModuleName] - fqValues (A.Var q) = getQual' q - fqValues (A.Constructor q) = getQual' q + fqValues (A.Var _ q) = getQual' q + fqValues (A.Constructor _ q) = getQual' q -- Some instances are automatically solved and have their class dictionaries -- built inline instead of having a named instance defined and imported. -- We therefore need to import these constructors if they aren't already. @@ -207,7 +207,7 @@ findQualModules decls = fqValues _ = [] fqBinders :: A.Binder -> [ModuleName] - fqBinders (A.ConstructorBinder q _) = getQual' q + fqBinders (A.ConstructorBinder _ q _) = getQual' q fqBinders _ = [] getQual' :: Qualified a -> [ModuleName] diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index f68a37351b..a7855cdb68 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -49,8 +49,8 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi effModuleName = P.moduleNameFromString "Control.Monad.Eff" effImport = (effModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Eff"])) supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"])) - eval = P.Var (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval")) - mainValue = P.App eval (P.Var (P.Qualified Nothing (P.Ident "it"))) + eval = P.Var internalSpan (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval")) + mainValue = P.App eval (P.Var internalSpan (P.Qualified Nothing (P.Ident "it"))) itDecl = P.ValueDecl (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val] typeDecl = P.TypeDeclaration (P.TypeDeclarationData (internalSpan, []) (P.Ident "$main") diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index cabb840c20..51b74c2ae6 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -54,24 +54,24 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec stepE :: S.Set Ident -> Expr -> MultipleErrors - stepE s (Abs (VarBinder name) _) | name `S.member` s = errorMessage (ShadowedName name) + stepE s (Abs (VarBinder ss name) _) | name `S.member` s = errorMessage' ss (ShadowedName name) stepE s (Let ds' _) = foldMap go ds' where go d | Just i <- getDeclIdent d - , i `S.member` s = errorMessage (ShadowedName i) + , i `S.member` s = errorMessage' (declSourceSpan d) (ShadowedName i) | otherwise = mempty stepE _ _ = mempty stepB :: S.Set Ident -> Binder -> MultipleErrors - stepB s (VarBinder name) | name `S.member` s = errorMessage (ShadowedName name) - stepB s (NamedBinder name _) | name `S.member` s = errorMessage (ShadowedName name) + stepB s (VarBinder ss name) | name `S.member` s = errorMessage' ss (ShadowedName name) + stepB s (NamedBinder ss name _) | name `S.member` s = errorMessage' ss (ShadowedName name) stepB _ _ = mempty stepDo :: S.Set Ident -> DoNotationElement -> MultipleErrors stepDo s (DoNotationLet ds') = foldMap go ds' where go d | Just i <- getDeclIdent d - , i `S.member` s = errorMessage (ShadowedName i) + , i `S.member` s = errorMessage' (declSourceSpan d) (ShadowedName i) | otherwise = mempty stepDo _ _ = mempty diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 23d39d9a8c..53615b8aec 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -115,16 +115,16 @@ genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs') -- missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedundancyError Bool) missingCasesSingle _ _ _ NullBinder = ([], return True) -missingCasesSingle _ _ _ (VarBinder _) = ([], return True) -missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b -missingCasesSingle env mn br (NamedBinder _ bl) = missingCasesSingle env mn br bl -missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) = +missingCasesSingle _ _ _ (VarBinder _ _) = ([], return True) +missingCasesSingle env mn (VarBinder _ _) b = missingCasesSingle env mn NullBinder b +missingCasesSingle env mn br (NamedBinder _ _ bl) = missingCasesSingle env mn br bl +missingCasesSingle env mn NullBinder cb@(ConstructorBinder ss con _) = (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, return True) where - allPatterns = map (\(p, t) -> ConstructorBinder (qualifyName p mn con) (initialize $ length t)) + allPatterns = map (\(p, t) -> ConstructorBinder ss (qualifyName p mn con) (initialize $ length t)) $ getConstructors env mn con -missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs') - | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr) +missingCasesSingle env mn cb@(ConstructorBinder ss con bs) (ConstructorBinder _ con' bs') + | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder ss con) bs'', pr) | otherwise = ([cb], return False) missingCasesSingle env mn NullBinder (LiteralBinder (ObjectLiteral bs)) = (map (LiteralBinder . ObjectLiteral . zip (map fst bs)) allMisses, pr) @@ -291,7 +291,7 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' return $ Let [ partial var tyVar ] - $ App (Var (Qualified Nothing UnusedIdent)) e + $ App (Var ss (Qualified Nothing UnusedIdent)) e where partial :: Text -> Text -> Declaration partial var tyVar = @@ -299,7 +299,7 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' [MkUnguarded (TypedValue True - (Abs (VarBinder (Ident var)) (Var (Qualified Nothing (Ident var)))) + (Abs (VarBinder ss (Ident var)) (Var ss (Qualified Nothing (Ident var)))) (ty tyVar)) ] @@ -336,7 +336,7 @@ checkExhaustiveExpr initSS env mn = onExpr initSS onDecl decl = return decl onExpr :: SourceSpan -> Expr -> m Expr - onExpr ss (UnaryMinus e) = UnaryMinus <$> onExpr ss e + onExpr _ (UnaryMinus ss e) = UnaryMinus ss <$> onExpr ss e onExpr ss (Literal (ArrayLiteral es)) = Literal . ArrayLiteral <$> mapM (onExpr ss) es onExpr ss (Literal (ObjectLiteral es)) = Literal . ObjectLiteral <$> mapM (sndM (onExpr ss)) es onExpr ss (TypeClassDictionaryConstructorApp x e) = TypeClassDictionaryConstructorApp x <$> onExpr ss e diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index 4eb5bb69b7..6f21f9f16d 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -154,3 +154,8 @@ withSourceSpan' -> P.Parsec [PositionedToken] u a -> P.Parsec [PositionedToken] u b withSourceSpan' f = withSourceSpan (\ss _ -> f ss) + +withSourceSpanF + :: P.Parsec [PositionedToken] u (SourceSpan -> a) + -> P.Parsec [PositionedToken] u a +withSourceSpanF = withSourceSpan (\ss _ f -> f ss) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 585fa75aed..0486696220 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -101,7 +101,7 @@ parseLocalValueDeclaration = withSourceAnnF . join $ go <$> parseBinder <*> P.many parseBinderNoParens where go :: Binder -> [Binder] -> TokenParser (SourceAnn -> Declaration) - go (VarBinder ident) bs = parseValueWithIdentAndBinders ident bs + go (VarBinder _ ident) bs = parseValueWithIdentAndBinders ident bs go (PositionedBinder _ _ b) bs = go b bs go binder [] = do boot <- indented *> equals *> parseValueWithWhereClause @@ -381,8 +381,8 @@ parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p) parseIdentifierAndValue :: TokenParser (PSString, Expr) parseIdentifierAndValue = do - name <- indented *> lname - b <- P.option (Var $ Qualified Nothing (Ident name)) rest + (ss, name) <- indented *> withSourceSpan' (,) lname + b <- P.option (Var ss $ Qualified Nothing (Ident name)) rest return (mkString name, b) <|> (,) <$> (indented *> stringLiteral) <*> rest where @@ -400,10 +400,10 @@ parseAbs = do toFunction args value = foldr ($) value args parseVar :: TokenParser Expr -parseVar = Var <$> parseQualified parseIdent +parseVar = withSourceSpan' Var $ parseQualified parseIdent parseConstructor :: TokenParser Expr -parseConstructor = Constructor <$> parseQualified dataConstructorName +parseConstructor = withSourceSpan' Constructor $ parseQualified dataConstructorName parseCase :: TokenParser Expr parseCase = Case <$> P.between (reserved "case") (indented *> reserved "of") (commaSep1 parseValue) @@ -453,7 +453,7 @@ parseValueAtom = withSourceSpan PositionedValue $ P.choice , parseAdo , parseLet , P.try $ Parens <$> parens parseValue - , Op <$> parseQualified (parens parseOperator) + , withSourceSpan' Op $ parseQualified (parens parseOperator) , parseHole ] @@ -461,7 +461,7 @@ parseValueAtom = withSourceSpan PositionedValue $ P.choice parseInfixExpr :: TokenParser Expr parseInfixExpr = P.between tick tick parseValue - <|> withSourceSpan PositionedValue (Op <$> parseQualified parseOperator) + <|> withSourceSpan' Op (parseQualified parseOperator) parseHole :: TokenParser Expr parseHole = Hole <$> holeLit @@ -479,7 +479,7 @@ parsePropertyUpdate = do parseNestedUpdate = Branch <$> parseUpdaterBodyFields parseAccessor :: Expr -> TokenParser Expr -parseAccessor (Constructor _) = P.unexpected "constructor" +parseAccessor (Constructor _ _) = P.unexpected "constructor" parseAccessor obj = P.try $ Accessor <$> (indented *> dot *> indented *> parseLabel) <*> pure obj parseDo :: TokenParser Expr @@ -519,15 +519,15 @@ indexersAndAccessors = buildPostfixParser postfixTable parseValueAtom -- | Parse an expression parseValue :: TokenParser Expr -parseValue = withSourceSpan PositionedValue - (P.buildExpressionParser operators - . buildPostfixParser postfixTable - $ indexersAndAccessors) P. "expression" +parseValue = + P.buildExpressionParser operators + (buildPostfixParser postfixTable indexersAndAccessors) + P. "expression" where postfixTable = [ \v -> P.try (flip App <$> (indented *> indexersAndAccessors)) <*> pure v , \v -> flip (TypedValue True) <$> (indented *> doubleColon *> parsePolyType) <*> pure v ] - operators = [ [ P.Prefix (indented *> symbol' "-" *> return UnaryMinus) + operators = [ [ P.Prefix (indented *> withSourceSpan' (\ss _ -> UnaryMinus ss) (symbol' "-")) ] , [ P.Infix (P.try (indented *> parseInfixExpr P. "infix expression") >>= \ident -> return (BinaryNoParens ident)) P.AssocRight @@ -559,35 +559,41 @@ parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number) <|> return id parseNullaryConstructorBinder :: TokenParser Binder -parseNullaryConstructorBinder = ConstructorBinder <$> parseQualified dataConstructorName <*> pure [] +parseNullaryConstructorBinder = withSourceSpanF $ + (\name ss -> ConstructorBinder ss name []) + <$> parseQualified dataConstructorName parseConstructorBinder :: TokenParser Binder -parseConstructorBinder = ConstructorBinder <$> parseQualified dataConstructorName <*> many (indented *> parseBinderNoParens) +parseConstructorBinder = withSourceSpanF $ + (\name args ss -> ConstructorBinder ss name args) + <$> parseQualified dataConstructorName + <*> many (indented *> parseBinderNoParens) parseObjectBinder:: TokenParser Binder -parseObjectBinder = LiteralBinder <$> parseObjectLiteral (indented *> parseIdentifierAndBinder) +parseObjectBinder = + LiteralBinder <$> parseObjectLiteral (indented *> parseEntry) + where + parseEntry :: TokenParser (PSString, Binder) + parseEntry = var <|> (,) <$> stringLiteral <*> rest + where + var = withSourceSpanF $ do + name <- lname + b <- P.option (\ss -> VarBinder ss (Ident name)) (const <$> rest) + return $ \ss -> (mkString name, b ss) + rest = indented *> colon *> indented *> parseBinder parseArrayBinder :: TokenParser Binder parseArrayBinder = LiteralBinder <$> parseArrayLiteral (indented *> parseBinder) parseVarOrNamedBinder :: TokenParser Binder -parseVarOrNamedBinder = do +parseVarOrNamedBinder = withSourceSpanF $ do name <- parseIdent - let parseNamedBinder = NamedBinder name <$> (at *> indented *> parseBinderAtom) - parseNamedBinder <|> return (VarBinder name) + let parseNamedBinder = (\b ss -> NamedBinder ss name b) <$> (at *> indented *> parseBinderAtom) + parseNamedBinder <|> return (`VarBinder` name) parseNullBinder :: TokenParser Binder parseNullBinder = underscore *> return NullBinder -parseIdentifierAndBinder :: TokenParser (PSString, Binder) -parseIdentifierAndBinder = - do name <- lname - b <- P.option (VarBinder (Ident name)) rest - return (mkString name, b) - <|> (,) <$> stringLiteral <*> rest - where - rest = indented *> colon *> indented *> parseBinder - -- | Parse a binder parseBinder :: TokenParser Binder parseBinder = @@ -607,7 +613,7 @@ parseBinder = postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parsePolyType) ] parseOpBinder :: TokenParser Binder - parseOpBinder = OpBinder <$> parseQualified parseOperator + parseOpBinder = withSourceSpan' OpBinder $ parseQualified parseOperator parseBinderAtom :: TokenParser Binder parseBinderAtom = withSourceSpan PositionedBinder diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 288c0f1030..82832c0cb1 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -101,17 +101,17 @@ prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr prettyPrintValueAtom :: Int -> Expr -> Box prettyPrintValueAtom d (Literal l) = prettyPrintLiteralValue d l prettyPrintValueAtom _ AnonymousArgument = text "_" -prettyPrintValueAtom _ (Constructor name) = text $ T.unpack $ runProperName (disqualify name) -prettyPrintValueAtom _ (Var ident) = text $ T.unpack $ showIdent (disqualify ident) +prettyPrintValueAtom _ (Constructor _ name) = text $ T.unpack $ runProperName (disqualify name) +prettyPrintValueAtom _ (Var _ ident) = text $ T.unpack $ showIdent (disqualify ident) prettyPrintValueAtom d (BinaryNoParens op lhs rhs) = prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs where - printOp (Op (Qualified _ name)) = text $ T.unpack $ runOpName name + printOp (Op _ (Qualified _ name)) = text $ T.unpack $ runOpName name printOp expr = text "`" <> prettyPrintValue (d - 1) expr `before` text "`" prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val prettyPrintValueAtom d (Parens expr) = (text "(" <> prettyPrintValue d expr) `before` text ")" -prettyPrintValueAtom d (UnaryMinus expr) = text "(-" <> prettyPrintValue d expr <> text ")" +prettyPrintValueAtom d (UnaryMinus _ expr) = text "(-" <> prettyPrintValue d expr <> text ")" prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")" prettyPrintLiteralValue :: Int -> Literal Expr -> Box @@ -186,13 +186,13 @@ prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrin prettyPrintBinderAtom :: Binder -> Text prettyPrintBinderAtom NullBinder = "_" prettyPrintBinderAtom (LiteralBinder l) = prettyPrintLiteralBinder l -prettyPrintBinderAtom (VarBinder ident) = showIdent ident -prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor) +prettyPrintBinderAtom (VarBinder _ ident) = showIdent ident +prettyPrintBinderAtom (ConstructorBinder _ ctor []) = runProperName (disqualify ctor) prettyPrintBinderAtom b@ConstructorBinder{} = parensT (prettyPrintBinder b) -prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident Monoid.<> "@" Monoid.<> prettyPrintBinder binder +prettyPrintBinderAtom (NamedBinder _ ident binder) = showIdent ident Monoid.<> "@" Monoid.<> prettyPrintBinder binder prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder -prettyPrintBinderAtom (OpBinder op) = runOpName (disqualify op) +prettyPrintBinderAtom (OpBinder _ op) = runOpName (disqualify op) prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) = prettyPrintBinderAtom b1 Monoid.<> " " Monoid.<> prettyPrintBinderAtom op Monoid.<> " " Monoid.<> prettyPrintBinderAtom b2 prettyPrintBinderAtom (ParensInBinder b) = parensT (prettyPrintBinder b) @@ -219,8 +219,8 @@ prettyPrintLiteralBinder (ArrayLiteral bs) = -- Generate a pretty-printed string representing a Binder -- prettyPrintBinder :: Binder -> Text -prettyPrintBinder (ConstructorBinder ctor []) = runProperName (disqualify ctor) -prettyPrintBinder (ConstructorBinder ctor args) = (runProperName (disqualify ctor)) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args) +prettyPrintBinder (ConstructorBinder _ ctor []) = runProperName (disqualify ctor) +prettyPrintBinder (ConstructorBinder _ ctor args) = (runProperName (disqualify ctor)) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args) prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder prettyPrintBinder (TypedBinder _ binder) = prettyPrintBinder binder prettyPrintBinder b = prettyPrintBinderAtom b diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs index 68b18fc3d9..577f99a316 100644 --- a/src/Language/PureScript/Sugar/AdoNotation.hs +++ b/src/Language/PureScript/Sugar/AdoNotation.hs @@ -29,13 +29,13 @@ desugarAdo d = in f d where pure' :: Expr - pure' = Var (Qualified Nothing (Ident C.pure')) + pure' = Var nullSourceSpan (Qualified Nothing (Ident C.pure')) map' :: Expr - map' = Var (Qualified Nothing (Ident C.map)) + map' = Var nullSourceSpan (Qualified Nothing (Ident C.map)) apply :: Expr - apply = Var (Qualified Nothing (Ident C.apply)) + apply = Var nullSourceSpan (Qualified Nothing (Ident C.apply)) replace :: Expr -> m Expr replace (Ado els yield) = do @@ -49,12 +49,12 @@ desugarAdo d = go :: (Expr, [Expr]) -> DoNotationElement -> m (Expr, [Expr]) go (yield, args) (DoNotationValue val) = return (Abs NullBinder yield, val : args) - go (yield, args) (DoNotationBind (VarBinder ident) val) = - return (Abs (VarBinder ident) yield, val : args) + go (yield, args) (DoNotationBind (VarBinder ss ident) val) = + return (Abs (VarBinder ss ident) yield, val : args) go (yield, args) (DoNotationBind binder val) = do ident <- freshIdent' - let abs = Abs (VarBinder ident) - (Case [Var (Qualified Nothing ident)] + let abs = Abs (VarBinder nullSourceSpan ident) + (Case [Var nullSourceSpan (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded yield]]) return (abs, val : args) go (yield, args) (DoNotationLet ds) = do diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index f31ad3c213..0c801203ac 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -113,9 +113,9 @@ usedIdents moduleName = ordNub . usedIdents' S.empty . valdeclExpression (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def usedNamesE :: S.Set Ident -> Expr -> [Ident] - usedNamesE scope (Var (Qualified Nothing name)) + usedNamesE scope (Var _ (Qualified Nothing name)) | name `S.notMember` scope = [name] - usedNamesE scope (Var (Qualified (Just moduleName') name)) + usedNamesE scope (Var _ (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = [name] usedNamesE _ _ = [] @@ -127,8 +127,8 @@ usedImmediateIdents moduleName = def s _ = (s, []) usedNamesE :: Bool -> Expr -> (Bool, [Ident]) - usedNamesE True (Var (Qualified Nothing name)) = (True, [name]) - usedNamesE True (Var (Qualified (Just moduleName') name)) + usedNamesE True (Var _ (Qualified Nothing name)) = (True, [name]) + usedNamesE True (Var _ (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name]) usedNamesE True (Abs _ _) = (False, []) usedNamesE scope _ = (scope, []) diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 4963ef685c..5c7eb0edcc 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -64,13 +64,13 @@ desugarGuardedExprs ss (Case scrut alternatives) -- We bind the scrutinee to Vars here to mitigate this case. (scrut', scrut_decls) <- unzip <$> forM scrut (\e -> do scrut_id <- freshIdent' - pure ( Var (Qualified Nothing scrut_id) + pure ( Var ss (Qualified Nothing scrut_id) , ValueDecl (ss, []) scrut_id Private [] [MkUnguarded e] ) ) Let scrut_decls <$> desugarGuardedExprs ss (Case scrut' alternatives) where - isTrivialExpr (Var _) = True + isTrivialExpr (Var _ _) = True isTrivialExpr (Literal _) = True isTrivialExpr (Accessor _ e) = isTrivialExpr e isTrivialExpr (Parens e) = isTrivialExpr e @@ -226,13 +226,13 @@ desugarGuardedExprs ss (Case scrut alternatives) = let goto_rem_case :: Expr - goto_rem_case = Var (Qualified Nothing rem_case_id) + goto_rem_case = Var ss (Qualified Nothing rem_case_id) `App` Literal (BooleanLiteral True) alt_fail = [CaseAlternative [NullBinder] [MkUnguarded goto_rem_case]] pure $ Let [ ValueDecl (ss, []) rem_case_id Private [] - [MkUnguarded (Abs (VarBinder unused_binder) desugared)] + [MkUnguarded (Abs (VarBinder ss unused_binder) desugared)] ] (mk_body alt_fail) | otherwise @@ -308,11 +308,11 @@ desugarAbs = flip parU f (f, _, _) = everywhereOnValuesM return replace return replace :: Expr -> m Expr - replace (Abs (stripPositioned -> (VarBinder i)) val) = - pure (Abs (VarBinder i) val) + replace (Abs (stripPositioned -> (VarBinder ss i)) val) = + pure (Abs (VarBinder ss i) val) replace (Abs binder val) = do ident <- freshIdent' - return $ Abs (VarBinder ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded val]] + return $ Abs (VarBinder nullSourceSpan ident) $ Case [Var nullSourceSpan (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded val]] replace other = return other stripPositioned :: Binder -> Binder @@ -345,13 +345,13 @@ inSameGroup _ _ = False toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] toDecls [ValueDecl sa@(ss, _) ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do args <- mapM fromVarBinder bs - let body = foldr (Abs . VarBinder) val args + let body = foldr (Abs . VarBinder ss) val args guardWith (errorMessage' ss (OverlappingArgNames (Just ident))) $ length (ordNub args) == length args return [ValueDecl sa ident nameKind [] [MkUnguarded body]] where fromVarBinder :: Binder -> m Ident fromVarBinder NullBinder = freshIdent' - fromVarBinder (VarBinder name) = return name + fromVarBinder (VarBinder _ name) = return name fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b fromVarBinder (TypedBinder _ b) = fromVarBinder b fromVarBinder _ = internalError "fromVarBinder: Invalid argument" @@ -380,9 +380,9 @@ makeCaseDeclaration ss ident alternatives = do args <- if allUnique (catMaybes argNames) then mapM argName argNames else replicateM (length argNames) freshIdent' - let vars = map (Var . Qualified Nothing) args + let vars = map (Var ss . Qualified Nothing) args binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] - let value = foldr (Abs . VarBinder) (Case vars binders) args + let value = foldr (Abs . VarBinder ss) (Case vars binders) args return $ ValueDecl (ss, []) ident Public [] [MkUnguarded value] where @@ -391,7 +391,7 @@ makeCaseDeclaration ss ident alternatives = do -- Everything else becomes Nothing, which indicates that we -- have to generate a name. findName :: Binder -> Maybe Ident - findName (VarBinder name) = Just name + findName (VarBinder _ name) = Just name findName (PositionedBinder _ _ binder) = findName binder findName _ = Nothing diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 713e16d93a..95c77cf560 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -29,10 +29,10 @@ desugarDo d = in rethrowWithPosition (declSourceSpan d) $ f d where bind :: Expr - bind = Var (Qualified Nothing (Ident C.bind)) + bind = Var nullSourceSpan (Qualified Nothing (Ident C.bind)) discard :: Expr - discard = Var (Qualified Nothing (Ident C.discard)) + discard = Var nullSourceSpan (Qualified Nothing (Ident C.discard)) replace :: Expr -> m Expr replace (Do els) = go els @@ -44,20 +44,20 @@ desugarDo d = go [DoNotationValue val] = return val go (DoNotationValue val : rest) = do rest' <- go rest - return $ App (App discard val) (Abs (VarBinder UnusedIdent) rest') + return $ App (App discard val) (Abs (VarBinder nullSourceSpan UnusedIdent) rest') go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind go (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) = throwError . errorMessage $ CannotUseBindWithDo (Ident ident) where fromIdent (Ident i) | i `elem` [ C.bind, C.discard ] = First (Just i) fromIdent _ = mempty - go (DoNotationBind (VarBinder ident) val : rest) = do + go (DoNotationBind (VarBinder ss ident) val : rest) = do rest' <- go rest - return $ App (App bind val) (Abs (VarBinder ident) rest') + return $ App (App bind val) (Abs (VarBinder ss ident) rest') go (DoNotationBind binder val : rest) = do rest' <- go rest ident <- freshIdent' - return $ App (App bind val) (Abs (VarBinder ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']])) + return $ App (App bind val) (Abs (VarBinder nullSourceSpan ident) (Case [Var nullSourceSpan (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']])) go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet go (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 4afbdccc9e..ca1ee4cb29 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -252,21 +252,21 @@ renameInModule imports (Module modSS coms mn decls exps) = -> m ((SourceSpan, [Ident]), Expr) updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((pos', bound), v) - updateValue (pos, bound) (Abs (VarBinder arg) val') = - return ((pos, arg : bound), Abs (VarBinder arg) val') + updateValue (pos, bound) (Abs (VarBinder ss arg) val') = + return ((pos, arg : bound), Abs (VarBinder ss arg) val') updateValue (pos, bound) (Let ds val') = do let args = mapMaybe letBoundVariable ds unless (length (ordNub args) == length args) . throwError . errorMessage' pos $ OverlappingNamesInLet return ((pos, args ++ bound), Let ds val') - updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound = - (,) (pos, bound) <$> (Var <$> updateValueName name' pos) - updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) = - (,) (pos, bound) <$> (Var <$> updateValueName name' pos) - updateValue (pos, bound) (Op op) = - (,) (pos, bound) <$> (Op <$> updateValueOpName op pos) - updateValue s@(pos, _) (Constructor name) = - (,) s <$> (Constructor <$> updateDataConstructorName name pos) + updateValue (_, bound) (Var ss name'@(Qualified Nothing ident)) | ident `notElem` bound = + (,) (ss, bound) <$> (Var ss <$> updateValueName name' ss) + updateValue (_, bound) (Var ss name'@(Qualified (Just _) _)) = + (,) (ss, bound) <$> (Var ss <$> updateValueName name' ss) + updateValue (_, bound) (Op ss op) = + (,) (ss, bound) <$> (Op ss <$> updateValueOpName op ss) + updateValue (_, bound) (Constructor ss name) = + (,) (ss, bound) <$> (Constructor ss <$> updateDataConstructorName name ss) updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty) updateValue s v = return (s, v) @@ -277,10 +277,10 @@ renameInModule imports (Module modSS coms mn decls exps) = -> m ((SourceSpan, [Ident]), Binder) updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((pos, bound), v) - updateBinder s@(pos, _) (ConstructorBinder name b) = - (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b) - updateBinder s@(pos, _) (OpBinder op) = - (,) s <$> (OpBinder <$> updateValueOpName op pos) + updateBinder (_, bound) (ConstructorBinder ss name b) = + (,) (ss, bound) <$> (ConstructorBinder ss <$> updateDataConstructorName name ss <*> pure b) + updateBinder (_, bound) (OpBinder ss op) = + (,) (ss, bound) <$> (OpBinder ss <$> updateValueOpName op ss) updateBinder s@(pos, _) (TypedBinder t b) = do t' <- updateTypesEverywhere pos t return (s, TypedBinder t' b) diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 7556f940d7..31998c4bf6 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -36,27 +36,27 @@ desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d | b' <- stripPositionInfo b , BinaryNoParens op val u <- b' , isAnonymousArgument u = do arg <- freshIdent' - return $ Abs (VarBinder arg) $ App (App op val) (Var (Qualified Nothing arg)) + return $ Abs (VarBinder nullSourceSpan arg) $ App (App op val) (Var nullSourceSpan (Qualified Nothing arg)) | b' <- stripPositionInfo b , BinaryNoParens op u val <- b' , isAnonymousArgument u = do arg <- freshIdent' - return $ Abs (VarBinder arg) $ App (App op (Var (Qualified Nothing arg))) val + return $ Abs (VarBinder nullSourceSpan arg) $ App (App op (Var nullSourceSpan (Qualified Nothing arg))) val desugarExpr (Literal (ObjectLiteral ps)) = wrapLambdaAssoc (Literal . ObjectLiteral) ps desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps desugarExpr (Accessor prop u) | Just props <- peelAnonAccessorChain u = do arg <- freshIdent' - return $ Abs (VarBinder arg) $ foldr Accessor (argToExpr arg) (prop:props) + return $ Abs (VarBinder nullSourceSpan arg) $ foldr Accessor (argToExpr arg) (prop:props) desugarExpr (Case args cas) | any isAnonymousArgument args = do argIdents <- forM args freshIfAnon let args' = zipWith (`maybe` argToExpr) args argIdents - return $ foldr (Abs . VarBinder) (Case args' cas) (catMaybes argIdents) + return $ foldr (Abs . VarBinder nullSourceSpan) (Case args' cas) (catMaybes argIdents) desugarExpr (IfThenElse u t f) | any isAnonymousArgument [u, t, f] = do u' <- freshIfAnon u t' <- freshIfAnon t f' <- freshIfAnon f let if_ = IfThenElse (maybe u argToExpr u') (maybe t argToExpr t') (maybe f argToExpr f') - return $ foldr (Abs . VarBinder) if_ (catMaybes [u', t', f']) + return $ foldr (Abs . VarBinder nullSourceSpan) if_ (catMaybes [u', t', f']) desugarExpr e = return e transformNestedUpdate :: Expr -> PathTree Expr -> m Expr @@ -66,7 +66,7 @@ desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d val <- freshIdent' let valExpr = argToExpr val if isAnonymousArgument obj - then Abs (VarBinder val) <$> wrapLambda (buildUpdates valExpr) ps + then Abs (VarBinder nullSourceSpan val) <$> wrapLambda (buildUpdates valExpr) ps else wrapLambda (buildLet val . buildUpdates valExpr) ps where buildLet val = Let [ValueDecl (declSourceSpan d, []) val Public [] [MkUnguarded obj]] @@ -86,7 +86,7 @@ desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d wrapLambda :: forall t. Traversable t => (t Expr -> Expr) -> t Expr -> m Expr wrapLambda mkVal ps = do args <- traverse processExpr ps - return $ foldr (Abs . VarBinder) (mkVal (snd <$> args)) (catMaybes $ toList (fst <$> args)) + return $ foldr (Abs . VarBinder nullSourceSpan) (mkVal (snd <$> args)) (catMaybes $ toList (fst <$> args)) where processExpr :: Expr -> m (Maybe Ident, Expr) processExpr e = do @@ -117,4 +117,4 @@ desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d | otherwise = return Nothing argToExpr :: Ident -> Expr - argToExpr = Var . Qualified Nothing + argToExpr = Var nullSourceSpan . Qualified Nothing diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 8d3b3ecbbc..99071c1aa1 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -47,7 +47,7 @@ desugarSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts where (f', _, _) = everywhereOnValues id go id - go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val + go (UnaryMinus ss' val) = App (Var ss' (Qualified Nothing (Ident C.negate))) val go other = other -- | @@ -142,30 +142,26 @@ rebracketFiltered pred_ externs modules = do goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) - goExpr pos (Op op) = - (pos, ) <$> case op `M.lookup` valueAliased of + goExpr _ (Op pos op) = + (Just pos, ) <$> case op `M.lookup` valueAliased of Just (Qualified mn' (Left alias)) -> - return $ Var (Qualified mn' alias) + return $ Var pos (Qualified mn' alias) Just (Qualified mn' (Right alias)) -> - return $ Constructor (Qualified mn' alias) + return $ Constructor pos (Qualified mn' alias) Nothing -> - maybe id rethrowWithPosition pos $ - throwError . errorMessage . UnknownName $ fmap ValOpName op + throwError . errorMessage' pos . UnknownName $ fmap ValOpName op goExpr pos other = return (pos, other) goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b) - goBinder pos (BinaryNoParensBinder (OpBinder op) lhs rhs) = + goBinder _ (BinaryNoParensBinder (OpBinder pos op) lhs rhs) = case op `M.lookup` valueAliased of Just (Qualified mn' (Left alias)) -> - maybe id rethrowWithPosition pos $ - throwError . errorMessage $ - InvalidOperatorInBinder op (Qualified mn' alias) + throwError . errorMessage' pos $ InvalidOperatorInBinder op (Qualified mn' alias) Just (Qualified mn' (Right alias)) -> - return (pos, ConstructorBinder (Qualified mn' alias) [lhs, rhs]) + return (Just pos, ConstructorBinder pos (Qualified mn' alias) [lhs, rhs]) Nothing -> - maybe id rethrowWithPosition pos $ - throwError . errorMessage . UnknownName $ fmap ValOpName op + throwError . errorMessage' pos . UnknownName $ fmap ValOpName op goBinder _ BinaryNoParensBinder{} = internalError "BinaryNoParensBinder has no OpBinder" goBinder pos other = return (pos, other) diff --git a/src/Language/PureScript/Sugar/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs index bdc0110d5e..8906703c03 100644 --- a/src/Language/PureScript/Sugar/Operators/Binders.hs +++ b/src/Language/PureScript/Sugar/Operators/Binders.hs @@ -18,9 +18,9 @@ matchBinderOperators = matchOperators isBinOp extractOp fromOp reapply id extractOp (BinaryNoParensBinder op l r) = Just (op, l, r) extractOp _ = Nothing - fromOp :: Binder -> Maybe (Qualified (OpName 'ValueOpName)) - fromOp (OpBinder q@(Qualified _ (OpName _))) = Just q + fromOp :: Binder -> Maybe (SourceSpan, Qualified (OpName 'ValueOpName)) + fromOp (OpBinder ss q@(Qualified _ (OpName _))) = Just (ss, q) fromOp _ = Nothing - reapply :: Qualified (OpName 'ValueOpName) -> Binder -> Binder -> Binder - reapply = BinaryNoParensBinder . OpBinder + reapply :: SourceSpan -> Qualified (OpName 'ValueOpName) -> Binder -> Binder -> Binder + reapply ss = BinaryNoParensBinder . OpBinder ss diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index dd0e43da4f..34201404d4 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -16,6 +16,9 @@ import Language.PureScript.Names type Chain a = [Either a a] +type FromOp nameType a = a -> Maybe (SourceSpan, Qualified (OpName nameType)) +type Reapply nameType a = SourceSpan -> Qualified (OpName nameType) -> a -> a -> a + toAssoc :: Associativity -> P.Assoc toAssoc Infixl = P.AssocLeft toAssoc Infixr = P.AssocRight @@ -28,34 +31,34 @@ parseValue :: P.Parsec (Chain a) () a parseValue = token (either Just (const Nothing)) P. "expression" parseOp - :: (a -> Maybe (Qualified (OpName nameType))) - -> P.Parsec (Chain a) () (Qualified (OpName nameType)) + :: FromOp nameType a + -> P.Parsec (Chain a) () (SourceSpan, Qualified (OpName nameType)) parseOp fromOp = token (either (const Nothing) fromOp) P. "operator" matchOp - :: (a -> Maybe (Qualified (OpName nameType))) + :: FromOp nameType a -> Qualified (OpName nameType) - -> P.Parsec (Chain a) () () + -> P.Parsec (Chain a) () SourceSpan matchOp fromOp op = do - ident <- parseOp fromOp + (ss, ident) <- parseOp fromOp guard $ ident == op + pure ss opTable :: [[(Qualified (OpName nameType), Associativity)]] - -> (a -> Maybe (Qualified (OpName nameType))) - -> (Qualified (OpName nameType) -> a -> a -> a) + -> FromOp nameType a + -> Reapply nameType a -> [[P.Operator (Chain a) () Identity a]] opTable ops fromOp reapply = - map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >> return (reapply name)) (toAssoc a))) ops - ++ [[ P.Infix (P.try (parseOp fromOp >>= \ident -> return (reapply ident))) P.AssocLeft ]] + map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >>= \ss -> return (reapply ss name)) (toAssoc a))) ops matchOperators :: forall a nameType . Show a => (a -> Bool) -> (a -> Maybe (a, a, a)) - -> (a -> Maybe (Qualified (OpName nameType))) - -> (Qualified (OpName nameType) -> a -> a -> a) + -> FromOp nameType a + -> Reapply nameType a -> ([[P.Operator (Chain a) () Identity a]] -> P.OperatorTable (Chain a) () Identity a) -> [[(Qualified (OpName nameType), Associativity)]] -> a diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index 84a1691ad3..99a0731e24 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -25,12 +25,12 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable | otherwise = Just (op, l, r) extractOp _ = Nothing - fromOp :: Expr -> Maybe (Qualified (OpName 'ValueOpName)) - fromOp (Op q@(Qualified _ (OpName _))) = Just q + fromOp :: Expr -> Maybe (SourceSpan, Qualified (OpName 'ValueOpName)) + fromOp (Op ss q@(Qualified _ (OpName _))) = Just (ss, q) fromOp _ = Nothing - reapply :: Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr - reapply op t1 = App (App (Op op) t1) + reapply :: SourceSpan -> Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr + reapply ss op t1 = App (App (Op ss op) t1) modOpTable :: [[P.Operator (Chain Expr) () Identity Expr]] @@ -42,5 +42,5 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable parseTicks :: P.Parsec (Chain Expr) () Expr parseTicks = token (either (const Nothing) fromOther) P. "infix function" where - fromOther (Op _) = Nothing + fromOther (Op _ _) = Nothing fromOther v = Just v diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs index f70ecf2d36..a4ef1f8848 100644 --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -3,6 +3,7 @@ module Language.PureScript.Sugar.Operators.Types where import Prelude.Compat import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Names import Language.PureScript.Sugar.Operators.Common import Language.PureScript.Types @@ -19,9 +20,9 @@ matchTypeOperators = matchOperators isBinOp extractOp fromOp reapply id extractOp (BinaryNoParensType op l r) = Just (op, l, r) extractOp _ = Nothing - fromOp :: Type -> Maybe (Qualified (OpName 'TypeOpName)) - fromOp (TypeOp q@(Qualified _ (OpName _))) = Just q + fromOp :: Type -> Maybe (a, Qualified (OpName 'TypeOpName)) + fromOp (TypeOp q@(Qualified _ (OpName _))) = Just (internalError "tried to use type operator source span", q) fromOp _ = Nothing - reapply :: Qualified (OpName 'TypeOpName) -> Type -> Type -> Type - reapply = BinaryNoParensType . TypeOp + reapply :: a -> Qualified (OpName 'TypeOpName) -> Type -> Type -> Type + reapply _ = BinaryNoParensType . TypeOp diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 90476e666e..a0d84182b9 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -270,7 +270,7 @@ typeInstanceDictionaryDeclaration -> [Type] -> [Declaration] -> Desugar m Declaration -typeInstanceDictionaryDeclaration sa name mn deps className tys decls = +typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = rethrow (addHint (ErrorInInstance className tys)) $ do m <- get @@ -292,7 +292,7 @@ typeInstanceDictionaryDeclaration sa name mn deps className tys decls = -- The type is a record type, but depending on type instance dependencies, may be constrained. -- The dictionary itself is a record literal. let superclasses = superClassDictionaryNames typeClassSuperclasses `zip` - [ Abs (VarBinder UnusedIdent) (DeferredDictionary superclass tyArgs) + [ Abs (VarBinder ss UnusedIdent) (DeferredDictionary superclass tyArgs) | (Constraint superclass suTyArgs _) <- typeClassSuperclasses , let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs ] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 279785c0f0..54c9f6a3f9 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -295,11 +295,11 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do -- If there are no cases, spin [ ValueDecl (ss, []) (Ident "to") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] - (unguarded (App toName (Var (Qualified Nothing x)))) + (unguarded (App toName (Var nullSourceSpan (Qualified Nothing x)))) ] , ValueDecl (ss, []) (Ident "from") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] - (unguarded (App fromName (Var (Qualified Nothing x)))) + (unguarded (App fromName (Var nullSourceSpan (Qualified Nothing x)))) ] ] | otherwise = @@ -319,10 +319,10 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do select l r n = take (n - 1) (iterate (r .) l) ++ [compN (n - 1) r] sumBinders :: Int -> [Binder -> Binder] - sumBinders = select (ConstructorBinder inl . pure) (ConstructorBinder inr . pure) + sumBinders = select (ConstructorBinder nullSourceSpan inl . pure) (ConstructorBinder nullSourceSpan inr . pure) sumExprs :: Int -> [Expr -> Expr] - sumExprs = select (App (Constructor inl)) (App (Constructor inr)) + sumExprs = select (App (Constructor nullSourceSpan inl)) (App (Constructor nullSourceSpan inr)) compN :: Int -> (a -> a) -> a -> a compN 0 _ = id @@ -337,9 +337,9 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do return ( TypeApp (TypeApp (TypeConstructor constructor) (TypeLevelString $ mkString (runProperName ctorName))) ctorTy - , CaseAlternative [ ConstructorBinder constructor [matchProduct] ] - (unguarded (foldl' App (Constructor (Qualified (Just mn) ctorName)) ctorArgs)) - , CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) matchCtor ] + , CaseAlternative [ ConstructorBinder nullSourceSpan constructor [matchProduct] ] + (unguarded (foldl' App (Constructor nullSourceSpan (Qualified (Just mn) ctorName)) ctorArgs)) + , CaseAlternative [ ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) matchCtor ] (unguarded (constructor' mkProduct)) ) @@ -351,20 +351,20 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do makeProduct args = do (tys, bs1, es1, bs2, es2) <- unzip5 <$> traverse makeArg args pure ( foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) tys - , foldr1 (\b1 b2 -> ConstructorBinder productName [b1, b2]) bs1 + , foldr1 (\b1 b2 -> ConstructorBinder nullSourceSpan productName [b1, b2]) bs1 , es1 , bs2 - , foldr1 (\e1 -> App (App (Constructor productName) e1)) es2 + , foldr1 (\e1 -> App (App (Constructor nullSourceSpan productName) e1)) es2 ) makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr) makeArg arg = do argName <- freshIdent "arg" pure ( TypeApp (TypeConstructor argument) arg - , ConstructorBinder argument [ VarBinder argName ] - , Var (Qualified Nothing argName) - , VarBinder argName - , argument' (Var (Qualified Nothing argName)) + , ConstructorBinder nullSourceSpan argument [ VarBinder nullSourceSpan argName ] + , Var nullSourceSpan (Qualified Nothing argName) + , VarBinder nullSourceSpan argName + , argument' (Var nullSourceSpan (Qualified Nothing argName)) ) underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative @@ -380,10 +380,10 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do toRepTy ctors = foldr1 (\f -> TypeApp (TypeApp sumCtor f)) ctors toName :: Expr - toName = Var (Qualified (Just dataGenericRep) (Ident "to")) + toName = Var nullSourceSpan (Qualified (Just dataGenericRep) (Ident "to")) fromName :: Expr - fromName = Var (Qualified (Just dataGenericRep) (Ident "from")) + fromName = Var nullSourceSpan (Qualified (Just dataGenericRep) (Ident "from")) noCtors :: Type noCtors = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoConstructors")) @@ -392,7 +392,7 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do noArgs = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoArguments")) noArgs' :: Expr - noArgs' = Constructor (Qualified (Just dataGenericRep) (ProperName "NoArguments")) + noArgs' = Constructor nullSourceSpan (Qualified (Just dataGenericRep) (ProperName "NoArguments")) sumCtor :: Type sumCtor = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "Sum")) @@ -410,13 +410,13 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do constructor = Qualified (Just dataGenericRep) (ProperName "Constructor") constructor' :: Expr -> Expr - constructor' = App (Constructor constructor) + constructor' = App (Constructor nullSourceSpan constructor) argument :: Qualified (ProperName ty) argument = Qualified (Just dataGenericRep) (ProperName "Argument") argument' :: Expr -> Expr - argument' = App (Constructor argument) + argument' = App (Constructor nullSourceSpan argument) checkIsWildcard :: MonadError MultipleErrors m => ProperName 'TypeName -> Type -> m () checkIsWildcard _ (TypeWildcard _) = return () @@ -445,10 +445,10 @@ deriveEq ss mn syns ds tyConNm = do mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration" preludeConj :: Expr -> Expr -> Expr - preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "HeytingAlgebra"])) (Ident C.conj))) + preludeConj = App . App (Var nullSourceSpan (Qualified (Just (ModuleName [ProperName "Data", ProperName "HeytingAlgebra"])) (Ident C.conj))) preludeEq :: Expr -> Expr -> Expr - preludeEq = App . App (Var (Qualified (Just dataEq) (Ident C.eq))) + preludeEq = App . App (Var nullSourceSpan (Qualified (Just dataEq) (Ident C.eq))) preludeEq1 :: Expr -> Expr -> Expr preludeEq1 = App . App (Var (Qualified (Just dataEq) (Ident C.eq1))) @@ -465,10 +465,10 @@ deriveEq ss mn syns ds tyConNm = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") tys' <- mapM (replaceAllTypeSynonymsM syns) tys - let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys' + let tests = zipWith3 toEqTest (map (Var nullSourceSpan . Qualified Nothing) identsL) (map (Var nullSourceSpan . Qualified Nothing) identsR) tys' return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (unguarded (conjAll tests)) where - caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents) + caseBinder idents = ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) (map (VarBinder nullSourceSpan) idents) conjAll :: [Expr] -> Expr conjAll [] = Literal (BooleanLiteral True) @@ -528,13 +528,13 @@ deriveOrd ss mn syns ds tyConNm = do orderingName = Qualified (Just (ModuleName [ProperName "Data", ProperName "Ordering"])) . ProperName orderingCtor :: Text -> Expr - orderingCtor = Constructor . orderingName + orderingCtor = Constructor nullSourceSpan . orderingName orderingBinder :: Text -> Binder - orderingBinder name = ConstructorBinder (orderingName name) [] + orderingBinder name = ConstructorBinder nullSourceSpan (orderingName name) [] ordCompare :: Expr -> Expr -> Expr - ordCompare = App . App (Var (Qualified (Just dataOrd) (Ident C.compare))) + ordCompare = App . App (Var nullSourceSpan (Qualified (Just dataOrd) (Ident C.compare))) ordCompare1 :: Expr -> Expr -> Expr ordCompare1 = App . App (Var (Qualified (Just dataOrd) (Ident C.compare1))) @@ -544,13 +544,13 @@ deriveOrd ss mn syns ds tyConNm = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") tys' <- mapM (replaceAllTypeSynonymsM syns) tys - let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys' - extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) + let tests = zipWith3 toOrdering (map (Var nullSourceSpan . Qualified Nothing) identsL) (map (Var nullSourceSpan . Qualified Nothing) identsR) tys' + extras | not isLast = [ CaseAlternative [ ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) , NullBinder ] (unguarded (orderingCtor "LT")) , CaseAlternative [ NullBinder - , ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) + , ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) ] (unguarded (orderingCtor "GT")) ] @@ -562,7 +562,7 @@ deriveOrd ss mn syns ds tyConNm = do : extras where - caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents) + caseBinder idents = ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) (map (VarBinder nullSourceSpan) idents) appendAll :: [Expr] -> Expr appendAll [] = orderingCtor "EQ" @@ -617,12 +617,12 @@ deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do ty' <- replaceAllTypeSynonymsM syns ty let inst = [ ValueDecl (ss, []) (Ident "wrap") Public [] $ unguarded $ - Constructor (Qualified (Just mn) ctorName) + Constructor nullSourceSpan (Qualified (Just mn) ctorName) , ValueDecl (ss, []) (Ident "unwrap") Public [] $ unguarded $ lamCase wrappedIdent [ CaseAlternative - [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]] - (unguarded (Var (Qualified Nothing unwrappedIdent))) + [ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) [VarBinder nullSourceSpan unwrappedIdent]] + (unguarded (Var nullSourceSpan (Qualified Nothing unwrappedIdent))) ] ] subst = zipWith ((,) . fst) args tyConArgs @@ -641,7 +641,7 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType isTypeDecl _ = False lam :: Ident -> Expr -> Expr -lam = Abs . VarBinder +lam = Abs . VarBinder nullSourceSpan lamCase :: Ident -> [CaseAlternative] -> Expr lamCase s = lam s . Case [mkVar s] @@ -650,7 +650,7 @@ lamCase2 :: Ident -> Ident -> [CaseAlternative] -> Expr lamCase2 s t = lam s . lam t . Case [mkVar s, mkVar t] mkVarMn :: Maybe ModuleName -> Ident -> Expr -mkVarMn mn = Var . Qualified mn +mkVarMn mn = Var nullSourceSpan . Qualified mn mkVar :: Ident -> Expr mkVar = mkVarMn Nothing @@ -702,9 +702,9 @@ deriveFunctor ss mn syns ds tyConNm = do idents <- replicateM (length ctorTys) (freshIdent "v") ctorTys' <- mapM (replaceAllTypeSynonymsM syns) ctorTys args <- zipWithM transformArg idents ctorTys' - let ctor = Constructor (Qualified (Just mn) ctorName) + let ctor = Constructor nullSourceSpan (Qualified (Just mn) ctorName) rebuilt = foldl' App ctor args - caseBinder = ConstructorBinder (Qualified (Just mn) ctorName) (VarBinder <$> idents) + caseBinder = ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) (VarBinder nullSourceSpan <$> idents) return $ CaseAlternative [caseBinder] (unguarded rebuilt) where fVar = mkVar f diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 928e157d19..823a3b47f4 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -209,7 +209,7 @@ entails SolverOptions{..} constraint context hints = findDicts ctx cn = fmap (fmap NamedInstance) . maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx valUndefined :: Expr - valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) + valUndefined = Var nullSourceSpan (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) solve :: Constraint -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr solve con = go 0 con @@ -280,7 +280,7 @@ entails SolverOptions{..} constraint context hints = modify (combineContexts newContext) -- Mark this constraint for generalization tell (mempty, [(ident, context, unsolved)]) - return (Var qident) + return (Var nullSourceSpan qident) Deferred -> -- Constraint was deferred, just return the dictionary unchanged, -- with no unsolved constraints. Hopefully, we can solve this later. @@ -357,10 +357,10 @@ entails SolverOptions{..} constraint context hints = -- Make a dictionary from subgoal dictionaries by applying the correct function mkDictionary :: Evidence -> Maybe [Expr] -> m Expr - mkDictionary (NamedInstance n) args = return $ foldl App (Var n) (fold args) + mkDictionary (NamedInstance n) args = return $ foldl App (Var nullSourceSpan n) (fold args) mkDictionary UnionInstance (Just [e]) = -- We need the subgoal dictionary to appear in the term somewhere - return $ App (Abs (VarBinder UnusedIdent) valUndefined) e + return $ App (Abs (VarBinder nullSourceSpan UnusedIdent) valUndefined) e mkDictionary UnionInstance _ = return valUndefined mkDictionary ConsInstance _ = return valUndefined mkDictionary RowToListInstance _ = return valUndefined @@ -371,7 +371,7 @@ entails SolverOptions{..} constraint context hints = -- So pass an empty placeholder (undefined) instead. return valUndefined mkDictionary (IsSymbolInstance sym) _ = - let fields = [ ("reflectSymbol", Abs (VarBinder UnusedIdent) (Literal (StringLiteral sym))) ] in + let fields = [ ("reflectSymbol", Abs (VarBinder nullSourceSpan UnusedIdent) (Literal (StringLiteral sym))) ] in return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) mkDictionary CompareSymbolInstance _ = return $ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral [])) @@ -399,7 +399,7 @@ entails SolverOptions{..} constraint context hints = lhs <- stripSuffix rhs' out' pure (TypeLevelString (mkString lhs), arg1, arg2) appendSymbols _ _ _ = Nothing - + consSymbol :: Type -> Type -> Type -> Maybe (Type, Type, Type) consSymbol _ _ arg@(TypeLevelString s) = do (h, t) <- T.uncons =<< decodeString s diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index ae550330c4..225410ab5b 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -59,7 +59,7 @@ checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do userT' <- initializeSkolems userT envT' <- initializeSkolems envT - let dummyExpression = P.Var (P.Qualified Nothing (P.Ident "x")) + let dummyExpression = P.Var nullSourceSpan (P.Qualified Nothing (P.Ident "x")) elab <- subsumes envT' userT' subst <- gets TC.checkSubstitution diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index f96771a8b0..309111f9fa 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -122,7 +122,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -- Check skolem variables did not escape their scope skolemEscapeCheck val' - return ((sai, (foldr (Abs . VarBinder . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved) + return ((sai, (foldr (Abs . VarBinder nullSourceSpan . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved) -- Show warnings here, since types in wildcards might have been solved during -- instance resolution (by functional dependencies). @@ -353,27 +353,27 @@ infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val pro typed <- check val (TypeApp tyRecord (RCons (Label prop) field rest)) return $ TypedValue True (Accessor prop typed) field infer' (Abs binder ret) - | VarBinder arg <- binder = do + | VarBinder ss arg <- binder = do ty <- freshType withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do body@(TypedValue _ _ bodyTy) <- infer' ret (body', bodyTy') <- instantiatePolyTypeWithUnknowns body bodyTy - return $ TypedValue True (Abs (VarBinder arg) body') (function ty bodyTy') + return $ TypedValue True (Abs (VarBinder ss arg) body') (function ty bodyTy') | otherwise = internalError "Binder was not desugared" infer' (App f arg) = do f'@(TypedValue _ _ ft) <- infer f (ret, app) <- checkFunctionApplication f' ft arg return $ TypedValue True app ret -infer' (Var var) = do +infer' (Var ss var) = do checkVisibility var ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable $ var case ty of ConstrainedType con ty' -> do dicts <- getTypeClassDictionaries hints <- getHints - return $ TypedValue True (App (Var var) (TypeClassDictionary con dicts hints)) ty' - _ -> return $ TypedValue True (Var var) ty -infer' v@(Constructor c) = do + return $ TypedValue True (App (Var ss var) (TypeClassDictionary con dicts hints)) ty' + _ -> return $ TypedValue True (Var ss var) ty +infer' v@(Constructor _ c) = do env <- getEnv case M.lookup c (dataConstructors env) of Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c @@ -435,7 +435,7 @@ inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded tv@(Ty let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined) ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv - bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) + bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = warnAndRethrowWithPositionTC ss $ do @@ -443,7 +443,7 @@ inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined) TypedValue _ val' valTy' <- bindNames dict $ infer val unifyTypes valTy valTy' - bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) + bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do Just moduleName <- checkCurrentModule <$> get @@ -469,8 +469,8 @@ inferBinder val (LiteralBinder (CharLiteral _)) = unifyTypes val tyChar >> retur inferBinder val (LiteralBinder (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty inferBinder val (LiteralBinder (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty inferBinder val (LiteralBinder (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty -inferBinder val (VarBinder name) = return $ M.singleton name val -inferBinder val (ConstructorBinder ctor binders) = do +inferBinder val (VarBinder _ name) = return $ M.singleton name val +inferBinder val (ConstructorBinder ss ctor binders) = do env <- getEnv case M.lookup ctor (dataConstructors env) of Just (_, _, ty, _) -> do @@ -480,7 +480,7 @@ inferBinder val (ConstructorBinder ctor binders) = do unless (length args == length binders) . throwError . errorMessage $ IncorrectConstructorArity ctor unifyTypes ret val M.unions <$> zipWithM inferBinder (reverse args) binders - _ -> throwError . errorMessage . UnknownName . fmap DctorName $ ctor + _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor where peelArgs :: Type -> ([Type], Type) peelArgs = go [] @@ -506,9 +506,10 @@ inferBinder val (LiteralBinder (ArrayLiteral binders)) = do m1 <- M.unions <$> traverse (inferBinder el) binders unifyTypes val (TypeApp tyArray el) return m1 -inferBinder val (NamedBinder name binder) = do - m <- inferBinder val binder - return $ M.insert name val m +inferBinder val (NamedBinder ss name binder) = + warnAndRethrowWithPositionTC ss $ do + m <- inferBinder val binder + return $ M.insert name val m inferBinder val (PositionedBinder pos _ binder) = warnAndRethrowWithPositionTC pos $ inferBinder val binder inferBinder val (TypedBinder ty binder) = do @@ -528,8 +529,8 @@ inferBinder _ ParensInBinder{} = -- | If this is the case, we need to instantiate any polymorphic types before checking binders. binderRequiresMonotype :: Binder -> Bool binderRequiresMonotype NullBinder = False -binderRequiresMonotype (VarBinder _) = False -binderRequiresMonotype (NamedBinder _ b) = binderRequiresMonotype b +binderRequiresMonotype (VarBinder _ _) = False +binderRequiresMonotype (NamedBinder _ _ b) = binderRequiresMonotype b binderRequiresMonotype (PositionedBinder _ _ b) = binderRequiresMonotype b binderRequiresMonotype (TypedBinder ty b) = isMonoType ty || binderRequiresMonotype b binderRequiresMonotype _ = True @@ -622,7 +623,7 @@ check' val t@(ConstrainedType con@(Constraint (Qualified _ (ProperName className dictName <- freshIdent ("dict" <> className) dicts <- newDictionaries [] (Qualified Nothing dictName) con val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty - return $ TypedValue True (Abs (VarBinder dictName) val') t + return $ TypedValue True (Abs (VarBinder nullSourceSpan dictName) val') t check' val u@(TUnknown _) = do val'@(TypedValue _ _ ty) <- infer val -- Don't unify an unknown with an inferred polytype @@ -644,17 +645,17 @@ check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do array <- Literal . ArrayLiteral <$> forM vals (`check` ty) return $ TypedValue True array t check' (Abs binder ret) ty@(TypeApp (TypeApp t argTy) retTy) - | VarBinder arg <- binder = do + | VarBinder ss arg <- binder = do unifyTypes t tyFunction ret' <- withBindingGroupVisible $ bindLocalVariables [(arg, argTy, Defined)] $ check ret retTy - return $ TypedValue True (Abs (VarBinder arg) ret') ty + return $ TypedValue True (Abs (VarBinder ss arg) ret') ty | otherwise = internalError "Binder was not desugared" check' (App f arg) ret = do f'@(TypedValue _ _ ft) <- infer f (retTy, app) <- checkFunctionApplication f' ft arg elaborate <- subsumes retTy ret return $ TypedValue True (elaborate app) ret -check' v@(Var var) ty = do +check' v@(Var _ var) ty = do checkVisibility var repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty @@ -712,7 +713,7 @@ check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val rest <- freshType val' <- check val (TypeApp tyRecord (RCons (Label prop) ty rest)) return $ TypedValue True (Accessor prop val') ty -check' v@(Constructor c) ty = do +check' v@(Constructor _ c) ty = do env <- getEnv case M.lookup c (dataConstructors env) of Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c From 3f3b47391a276430c7db58ecd3cb02a3612054df Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 22 Jan 2018 11:04:51 +0000 Subject: [PATCH 0925/1580] Fix build errors in master (#3215) * Fix build errors in master * fix ide tests --- src/Language/PureScript/Ide/Usage.hs | 14 ++++----- .../PureScript/Sugar/TypeClasses/Deriving.hs | 30 +++++++++---------- tests/Language/PureScript/Ide/UsageSpec.hs | 13 ++++---- 3 files changed, 26 insertions(+), 31 deletions(-) diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index 3d61297c30..f414931750 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -136,27 +136,23 @@ applySearch module_ search = (extr, _, _, _, _) = P.everythingWithScope mempty goExpr goBinder mempty mempty goExpr scope expr = case expr of - P.PositionedValue sp _ (P.Var i) + P.Var sp i | Just ideValue <- preview _IdeDeclValue (P.disqualify search) , P.isQualified search || not (_ideValueIdent ideValue `Set.member` scope) -> [sp | map P.runIdent i == map identifierFromIdeDeclaration search] - - P.PositionedValue sp _ (P.Constructor name) + P.Constructor sp name | Just ideDtor <- traverse (preview _IdeDeclDataConstructor) search -> [sp | name == map _ideDtorName ideDtor] - P.PositionedValue sp _ (P.Op opName) + P.Op sp opName | Just ideOp <- traverse (preview _IdeDeclValueOperator) search -> [sp | opName == map _ideValueOpName ideOp] _ -> [] goBinder _ binder = case binder of - P.PositionedBinder sp _ (P.ConstructorBinder ctorName _) + P.ConstructorBinder sp ctorName _ | Just ideDtor <- traverse (preview _IdeDeclDataConstructor) search -> [sp | ctorName == map _ideDtorName ideDtor] - P.PositionedBinder sp _ (P.OpBinder opName) - | Just op <- traverse (preview _IdeDeclValueOperator) search -> - [sp | opName == map _ideValueOpName op] - P.PositionedBinder sp _ (P.BinaryNoParensBinder (P.OpBinder opName) _ _) + P.OpBinder sp opName | Just op <- traverse (preview _IdeDeclValueOperator) search -> [sp | opName == map _ideValueOpName op] _ -> [] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 54c9f6a3f9..7ca8049d3e 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -445,13 +445,13 @@ deriveEq ss mn syns ds tyConNm = do mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration" preludeConj :: Expr -> Expr -> Expr - preludeConj = App . App (Var nullSourceSpan (Qualified (Just (ModuleName [ProperName "Data", ProperName "HeytingAlgebra"])) (Ident C.conj))) + preludeConj = App . App (Var ss (Qualified (Just (ModuleName [ProperName "Data", ProperName "HeytingAlgebra"])) (Ident C.conj))) preludeEq :: Expr -> Expr -> Expr - preludeEq = App . App (Var nullSourceSpan (Qualified (Just dataEq) (Ident C.eq))) + preludeEq = App . App (Var ss (Qualified (Just dataEq) (Ident C.eq))) preludeEq1 :: Expr -> Expr -> Expr - preludeEq1 = App . App (Var (Qualified (Just dataEq) (Ident C.eq1))) + preludeEq1 = App . App (Var ss (Qualified (Just dataEq) (Ident C.eq1))) addCatch :: [CaseAlternative] -> [CaseAlternative] addCatch xs @@ -465,10 +465,10 @@ deriveEq ss mn syns ds tyConNm = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") tys' <- mapM (replaceAllTypeSynonymsM syns) tys - let tests = zipWith3 toEqTest (map (Var nullSourceSpan . Qualified Nothing) identsL) (map (Var nullSourceSpan . Qualified Nothing) identsR) tys' + let tests = zipWith3 toEqTest (map (Var ss . Qualified Nothing) identsL) (map (Var ss . Qualified Nothing) identsR) tys' return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (unguarded (conjAll tests)) where - caseBinder idents = ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) (map (VarBinder nullSourceSpan) idents) + caseBinder idents = ConstructorBinder ss (Qualified (Just mn) ctorName) (map (VarBinder ss) idents) conjAll :: [Expr] -> Expr conjAll [] = Literal (BooleanLiteral True) @@ -489,7 +489,7 @@ deriveEq1 ss = [ ValueDecl (ss, []) (Ident C.eq1) Public [] (unguarded preludeEq)] where preludeEq :: Expr - preludeEq = Var (Qualified (Just dataEq) (Ident C.eq)) + preludeEq = Var ss (Qualified (Just dataEq) (Ident C.eq)) deriveOrd :: forall m @@ -528,29 +528,29 @@ deriveOrd ss mn syns ds tyConNm = do orderingName = Qualified (Just (ModuleName [ProperName "Data", ProperName "Ordering"])) . ProperName orderingCtor :: Text -> Expr - orderingCtor = Constructor nullSourceSpan . orderingName + orderingCtor = Constructor ss . orderingName orderingBinder :: Text -> Binder - orderingBinder name = ConstructorBinder nullSourceSpan (orderingName name) [] + orderingBinder name = ConstructorBinder ss (orderingName name) [] ordCompare :: Expr -> Expr -> Expr - ordCompare = App . App (Var nullSourceSpan (Qualified (Just dataOrd) (Ident C.compare))) + ordCompare = App . App (Var ss (Qualified (Just dataOrd) (Ident C.compare))) ordCompare1 :: Expr -> Expr -> Expr - ordCompare1 = App . App (Var (Qualified (Just dataOrd) (Ident C.compare1))) + ordCompare1 = App . App (Var ss (Qualified (Just dataOrd) (Ident C.compare1))) mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative] mkCtorClauses ((ctorName, tys), isLast) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") tys' <- mapM (replaceAllTypeSynonymsM syns) tys - let tests = zipWith3 toOrdering (map (Var nullSourceSpan . Qualified Nothing) identsL) (map (Var nullSourceSpan . Qualified Nothing) identsR) tys' - extras | not isLast = [ CaseAlternative [ ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) + let tests = zipWith3 toOrdering (map (Var ss . Qualified Nothing) identsL) (map (Var ss . Qualified Nothing) identsR) tys' + extras | not isLast = [ CaseAlternative [ ConstructorBinder ss (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) , NullBinder ] (unguarded (orderingCtor "LT")) , CaseAlternative [ NullBinder - , ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) + , ConstructorBinder ss (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) ] (unguarded (orderingCtor "GT")) ] @@ -562,7 +562,7 @@ deriveOrd ss mn syns ds tyConNm = do : extras where - caseBinder idents = ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) (map (VarBinder nullSourceSpan) idents) + caseBinder idents = ConstructorBinder ss (Qualified (Just mn) ctorName) (map (VarBinder ss) idents) appendAll :: [Expr] -> Expr appendAll [] = orderingCtor "EQ" @@ -590,7 +590,7 @@ deriveOrd1 ss = [ ValueDecl (ss, []) (Ident C.compare1) Public [] (unguarded dataOrdCompare)] where dataOrdCompare :: Expr - dataOrdCompare = Var (Qualified (Just dataOrd) (Ident C.compare)) + dataOrdCompare = Var ss (Qualified (Just dataOrd) (Ident C.compare)) deriveNewtype :: forall m diff --git a/tests/Language/PureScript/Ide/UsageSpec.hs b/tests/Language/PureScript/Ide/UsageSpec.hs index ec1ddd26e5..1214409e87 100644 --- a/tests/Language/PureScript/Ide/UsageSpec.hs +++ b/tests/Language/PureScript/Ide/UsageSpec.hs @@ -30,14 +30,13 @@ shouldBeUsage usage' (fp, range) = do fp `shouldBe` P.spanName usage' - (startLine, startColumn) + (P.sourcePosLine (P.spanStart usage'), P.sourcePosColumn (P.spanStart usage')) `shouldBe` - ( P.sourcePosLine (P.spanStart usage') - , P.sourcePosColumn (P.spanStart usage')) - (endLine, endColumn) + (startLine, startColumn) + + (P.sourcePosLine (P.spanEnd usage'), P.sourcePosColumn (P.spanEnd usage')) `shouldBe` - ( P.sourcePosLine (P.spanEnd usage') - , P.sourcePosColumn (P.spanEnd usage')) + (endLine, endColumn) spec :: Spec spec = describe "Finding Usages" $ do @@ -58,7 +57,7 @@ spec = describe "Finding Usages" $ do Test.runIde [ load ["FindUsage", "FindUsage.Definition", "FindUsage.Reexport"] , usage (Test.mn "FindUsage.Definition") "$%" IdeNSValue ] - usage1 `shouldBeUsage` ("src" "FindUsage.purs", "9:3-9:9") + usage1 `shouldBeUsage` ("src" "FindUsage.purs", "9:5-9:7") it "finds a reexported usage" $ do ([_, Right (UsagesResult [usage1])], _) <- Test.inProject $ Test.runIde [ load ["FindUsage", "FindUsage.Definition", "FindUsage.Reexport"] From 80339ffd4fcadd4b887c103b2f1b219969fe8af2 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 23 Jan 2018 01:30:48 +0000 Subject: [PATCH 0926/1580] Fix `UnusedTypeVar` missing position info (#3214) --- src/Language/PureScript/Linter.hs | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 51b74c2ae6..9d4917f247 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -48,9 +48,10 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl f dec = f' S.empty dec f' :: S.Set Text -> Declaration -> MultipleErrors - f' s dec@(ValueDeclaration vd) = addHint (ErrorInValueDeclaration (valdeclIdent vd)) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec) + f' s dec@(ValueDeclaration vd) = + addHint (ErrorInValueDeclaration (valdeclIdent vd)) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec) f' s (TypeDeclaration td@(TypeDeclarationData (ss, _) _ _)) = - addHint (PositionedError ss) $ addHint (ErrorInTypeDeclaration (tydeclIdent td)) (checkTypeVars s (tydeclType td)) + addHint (ErrorInTypeDeclaration (tydeclIdent td)) (checkTypeVars ss s (tydeclType td)) f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec stepE :: S.Set Ident -> Expr -> MultipleErrors @@ -76,27 +77,28 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl stepDo _ _ = mempty checkTypeVarsInDecl :: S.Set Text -> Declaration -> MultipleErrors - checkTypeVarsInDecl s d = let (f, _, _, _, _) = accumTypes (checkTypeVars s) in f d + checkTypeVarsInDecl s d = let (f, _, _, _, _) = accumTypes (checkTypeVars (declSourceSpan d) s) in f d - checkTypeVars :: S.Set Text -> Type -> MultipleErrors - checkTypeVars set ty = everythingWithContextOnTypes set mempty mappend step ty <> findUnused ty + checkTypeVars :: SourceSpan -> S.Set Text -> Type -> MultipleErrors + checkTypeVars ss set ty = everythingWithContextOnTypes set mempty mappend step ty <> findUnused ty where step :: S.Set Text -> Type -> (S.Set Text, MultipleErrors) step s (ForAll tv _ _) = bindVar s tv step s _ = (s, mempty) bindVar :: S.Set Text -> Text -> (S.Set Text, MultipleErrors) - bindVar = bind ShadowedTypeVar + bindVar = bind ss ShadowedTypeVar findUnused :: Type -> MultipleErrors findUnused ty' = let used = usedTypeVariables ty' declared = everythingOnTypes (++) go ty' unused = ordNub declared \\ ordNub used - in foldl (<>) mempty $ map (errorMessage . UnusedTypeVar) unused + in foldl (<>) mempty $ map (errorMessage' ss . UnusedTypeVar) unused where go :: Type -> [Text] go (ForAll tv _ _) = [tv] go _ = [] - bind :: (Ord a) => (a -> SimpleErrorMessage) -> S.Set a -> a -> (S.Set a, MultipleErrors) - bind mkError s name | name `S.member` s = (s, errorMessage (mkError name)) - | otherwise = (S.insert name s, mempty) + bind :: (Ord a) => SourceSpan -> (a -> SimpleErrorMessage) -> S.Set a -> a -> (S.Set a, MultipleErrors) + bind ss mkError s name + | name `S.member` s = (s, errorMessage' ss (mkError name)) + | otherwise = (S.insert name s, mempty) From 65df12af20f7a893185ca336c985beb17bc22194 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 23 Jan 2018 10:38:00 +0000 Subject: [PATCH 0927/1580] Fix various typeclass-related error spans (#3216) * Ensure MissingClassMember, ExtraneousClassMember have source spans * Ensure ExpectedWildcard has source span --- ...ypeInstance.purs => ExpectedWildcard.purs} | 2 +- examples/failing/ExtraneousClassMember.purs | 11 ++ ...Instances.purs => MissingClassMember.purs} | 0 src/Language/PureScript/Sugar/TypeClasses.hs | 8 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 155 +++++++++--------- 5 files changed, 97 insertions(+), 79 deletions(-) rename examples/failing/{NonWildcardNewtypeInstance.purs => ExpectedWildcard.purs} (77%) create mode 100644 examples/failing/ExtraneousClassMember.purs rename examples/failing/{TypeClassInstances.purs => MissingClassMember.purs} (100%) diff --git a/examples/failing/NonWildcardNewtypeInstance.purs b/examples/failing/ExpectedWildcard.purs similarity index 77% rename from examples/failing/NonWildcardNewtypeInstance.purs rename to examples/failing/ExpectedWildcard.purs index 3c1ac5dfce..72c1365868 100644 --- a/examples/failing/NonWildcardNewtypeInstance.purs +++ b/examples/failing/ExpectedWildcard.purs @@ -1,5 +1,5 @@ -- @shouldFailWith ExpectedWildcard -module NonWildcardNewtypeInstance where +module ExpectedWildcard where import Data.Newtype diff --git a/examples/failing/ExtraneousClassMember.purs b/examples/failing/ExtraneousClassMember.purs new file mode 100644 index 0000000000..9893d7fba5 --- /dev/null +++ b/examples/failing/ExtraneousClassMember.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith ExtraneousClassMember +module Main where + +import Prelude + +class A a where + a :: a -> String + +instance aString :: A String where + a s = s + b x = x diff --git a/examples/failing/TypeClassInstances.purs b/examples/failing/MissingClassMember.purs similarity index 100% rename from examples/failing/TypeClassInstances.purs rename to examples/failing/MissingClassMember.purs diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index a0d84182b9..b143fa9803 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -276,11 +276,11 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = -- Lookup the type arguments and member types for the type class TypeClassData{..} <- - maybe (throwError . errorMessage . UnknownName $ fmap TyClassName className) return $ + maybe (throwError . errorMessage' ss . UnknownName $ fmap TyClassName className) return $ M.lookup (qualify mn className) m case map fst typeClassMembers \\ mapMaybe declIdent decls of - member : _ -> throwError . errorMessage $ MissingClassMember member + member : _ -> throwError . errorMessage' ss $ MissingClassMember member [] -> do -- Replace the type arguments with the appropriate types in the member types let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers @@ -307,8 +307,8 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = where memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr - memberToValue tys' (ValueDecl _ ident _ [] [MkUnguarded val]) = do - _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys' + memberToValue tys' (ValueDecl (ss', _) ident _ [] [MkUnguarded val]) = do + _ <- maybe (throwError . errorMessage' ss' $ ExtraneousClassMember ident className) return $ lookup ident tys' return val memberToValue _ _ = internalError "Invalid declaration in type instance definition" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 7ca8049d3e..1e76cc4db8 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -154,7 +154,7 @@ deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps c [wrappedTy, unwrappedTy] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy , mn == fromMaybe mn mn' - -> do (inst, actualUnwrappedTy) <- deriveNewtype mn syns ds tyCon args unwrappedTy + -> do (inst, actualUnwrappedTy) <- deriveNewtype ss mn syns ds tyCon args unwrappedTy return $ TypeInstanceDeclaration sa ch idx nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys wrappedTy _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 @@ -163,7 +163,7 @@ deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps c [actualTy, repTy] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy , mn == fromMaybe mn mn' - -> do (inst, inferredRepTy) <- deriveGenericRep mn syns ds tyCon args repTy + -> do (inst, inferredRepTy) <- deriveGenericRep ss mn syns ds tyCon args repTy return $ TypeInstanceDeclaration sa ch idx nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys actualTy _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 @@ -275,38 +275,43 @@ unguarded e = [MkUnguarded e] deriveGenericRep :: forall m . (MonadError MultipleErrors m, MonadSupply m) - => ModuleName + => SourceSpan + -> ModuleName -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> [Type] -> Type -> m ([Declaration], Type) -deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do - checkIsWildcard tyConNm repTy +deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do + checkIsWildcard ss tyConNm repTy go =<< findTypeDecl tyConNm ds where go :: Declaration -> m ([Declaration], Type) - go (DataDeclaration (ss, _) _ _ args dctors) = do + go (DataDeclaration (ss', _) _ _ args dctors) = do x <- freshIdent "x" (reps, to, from) <- unzip3 <$> traverse makeInst dctors let rep = toRepTy reps inst | null reps = -- If there are no cases, spin - [ ValueDecl (ss, []) (Ident "to") Public [] $ unguarded $ - lamCase x [ CaseAlternative [NullBinder] - (unguarded (App toName (Var nullSourceSpan (Qualified Nothing x)))) - ] - , ValueDecl (ss, []) (Ident "from") Public [] $ unguarded $ - lamCase x [ CaseAlternative [NullBinder] - (unguarded (App fromName (Var nullSourceSpan (Qualified Nothing x)))) - ] + [ ValueDecl (ss', []) (Ident "to") Public [] $ unguarded $ + lamCase ss' x + [ CaseAlternative + [NullBinder] + (unguarded (App toName (Var ss' (Qualified Nothing x)))) + ] + , ValueDecl (ss', []) (Ident "from") Public [] $ unguarded $ + lamCase ss' x + [ CaseAlternative + [NullBinder] + (unguarded (App fromName (Var ss' (Qualified Nothing x)))) + ] ] | otherwise = - [ ValueDecl (ss, []) (Ident "to") Public [] $ unguarded $ - lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to) - , ValueDecl (ss, []) (Ident "from") Public [] $ unguarded $ - lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from) + [ ValueDecl (ss', []) (Ident "to") Public [] $ unguarded $ + lamCase ss' x (zipWith ($) (map underBinder (sumBinders (length dctors))) to) + , ValueDecl (ss', []) (Ident "from") Public [] $ unguarded $ + lamCase ss' x (zipWith ($) (map underExpr (sumExprs (length dctors))) from) ] subst = zipWith ((,) . fst) args tyConArgs @@ -319,10 +324,10 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do select l r n = take (n - 1) (iterate (r .) l) ++ [compN (n - 1) r] sumBinders :: Int -> [Binder -> Binder] - sumBinders = select (ConstructorBinder nullSourceSpan inl . pure) (ConstructorBinder nullSourceSpan inr . pure) + sumBinders = select (ConstructorBinder ss inl . pure) (ConstructorBinder ss inr . pure) sumExprs :: Int -> [Expr -> Expr] - sumExprs = select (App (Constructor nullSourceSpan inl)) (App (Constructor nullSourceSpan inr)) + sumExprs = select (App (Constructor ss inl)) (App (Constructor ss inr)) compN :: Int -> (a -> a) -> a -> a compN 0 _ = id @@ -337,9 +342,9 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do return ( TypeApp (TypeApp (TypeConstructor constructor) (TypeLevelString $ mkString (runProperName ctorName))) ctorTy - , CaseAlternative [ ConstructorBinder nullSourceSpan constructor [matchProduct] ] - (unguarded (foldl' App (Constructor nullSourceSpan (Qualified (Just mn) ctorName)) ctorArgs)) - , CaseAlternative [ ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) matchCtor ] + , CaseAlternative [ ConstructorBinder ss constructor [matchProduct] ] + (unguarded (foldl' App (Constructor ss (Qualified (Just mn) ctorName)) ctorArgs)) + , CaseAlternative [ ConstructorBinder ss (Qualified (Just mn) ctorName) matchCtor ] (unguarded (constructor' mkProduct)) ) @@ -351,20 +356,20 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do makeProduct args = do (tys, bs1, es1, bs2, es2) <- unzip5 <$> traverse makeArg args pure ( foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) tys - , foldr1 (\b1 b2 -> ConstructorBinder nullSourceSpan productName [b1, b2]) bs1 + , foldr1 (\b1 b2 -> ConstructorBinder ss productName [b1, b2]) bs1 , es1 , bs2 - , foldr1 (\e1 -> App (App (Constructor nullSourceSpan productName) e1)) es2 + , foldr1 (\e1 -> App (App (Constructor ss productName) e1)) es2 ) makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr) makeArg arg = do argName <- freshIdent "arg" pure ( TypeApp (TypeConstructor argument) arg - , ConstructorBinder nullSourceSpan argument [ VarBinder nullSourceSpan argName ] - , Var nullSourceSpan (Qualified Nothing argName) - , VarBinder nullSourceSpan argName - , argument' (Var nullSourceSpan (Qualified Nothing argName)) + , ConstructorBinder ss argument [ VarBinder ss argName ] + , Var ss (Qualified Nothing argName) + , VarBinder ss argName + , argument' (Var ss (Qualified Nothing argName)) ) underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative @@ -380,10 +385,10 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do toRepTy ctors = foldr1 (\f -> TypeApp (TypeApp sumCtor f)) ctors toName :: Expr - toName = Var nullSourceSpan (Qualified (Just dataGenericRep) (Ident "to")) + toName = Var ss (Qualified (Just dataGenericRep) (Ident "to")) fromName :: Expr - fromName = Var nullSourceSpan (Qualified (Just dataGenericRep) (Ident "from")) + fromName = Var ss (Qualified (Just dataGenericRep) (Ident "from")) noCtors :: Type noCtors = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoConstructors")) @@ -392,7 +397,7 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do noArgs = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoArguments")) noArgs' :: Expr - noArgs' = Constructor nullSourceSpan (Qualified (Just dataGenericRep) (ProperName "NoArguments")) + noArgs' = Constructor ss (Qualified (Just dataGenericRep) (ProperName "NoArguments")) sumCtor :: Type sumCtor = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "Sum")) @@ -410,18 +415,18 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do constructor = Qualified (Just dataGenericRep) (ProperName "Constructor") constructor' :: Expr -> Expr - constructor' = App (Constructor nullSourceSpan constructor) + constructor' = App (Constructor ss constructor) argument :: Qualified (ProperName ty) argument = Qualified (Just dataGenericRep) (ProperName "Argument") argument' :: Expr -> Expr - argument' = App (Constructor nullSourceSpan argument) + argument' = App (Constructor ss argument) -checkIsWildcard :: MonadError MultipleErrors m => ProperName 'TypeName -> Type -> m () -checkIsWildcard _ (TypeWildcard _) = return () -checkIsWildcard tyConNm _ = - throwError . errorMessage $ ExpectedWildcard tyConNm +checkIsWildcard :: MonadError MultipleErrors m => SourceSpan -> ProperName 'TypeName -> Type -> m () +checkIsWildcard _ _ (TypeWildcard _) = return () +checkIsWildcard ss tyConNm _ = + throwError . errorMessage' ss $ ExpectedWildcard tyConNm deriveEq :: forall m @@ -438,10 +443,10 @@ deriveEq ss mn syns ds tyConNm = do return [ ValueDecl (ss, []) (Ident C.eq) Public [] (unguarded eqFun) ] where mkEqFunction :: Declaration -> m Expr - mkEqFunction (DataDeclaration _ _ _ _ args) = do + mkEqFunction (DataDeclaration (ss', _) _ _ _ args) = do x <- freshIdent "x" y <- freshIdent "y" - lamCase2 x y <$> (addCatch <$> mapM mkCtorClause args) + lamCase2 ss' x y <$> (addCatch <$> mapM mkCtorClause args) mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration" preludeConj :: Expr -> Expr -> Expr @@ -506,10 +511,10 @@ deriveOrd ss mn syns ds tyConNm = do return [ ValueDecl (ss, []) (Ident C.compare) Public [] (unguarded compareFun) ] where mkCompareFunction :: Declaration -> m Expr - mkCompareFunction (DataDeclaration _ _ _ _ args) = do + mkCompareFunction (DataDeclaration (ss', _) _ _ _ args) = do x <- freshIdent "x" y <- freshIdent "y" - lamCase2 x y <$> (addCatch . concat <$> mapM mkCtorClauses (splitLast args)) + lamCase2 ss' x y <$> (addCatch . concat <$> mapM mkCtorClauses (splitLast args)) mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration" splitLast :: [a] -> [(a, Bool)] @@ -595,34 +600,35 @@ deriveOrd1 ss = deriveNewtype :: forall m . (MonadError MultipleErrors m, MonadSupply m) - => ModuleName + => SourceSpan + -> ModuleName -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> [Type] -> Type -> m ([Declaration], Type) -deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do - checkIsWildcard tyConNm unwrappedTy +deriveNewtype ss mn syns ds tyConNm tyConArgs unwrappedTy = do + checkIsWildcard ss tyConNm unwrappedTy go =<< findTypeDecl tyConNm ds where go :: Declaration -> m ([Declaration], Type) - go (DataDeclaration (ss, _) Data name _ _) = - throwError . errorMessage' ss $ CannotDeriveNewtypeForData name - go (DataDeclaration (ss, _) Newtype name args dctors) = do + go (DataDeclaration (ss', _) Data name _ _) = + throwError . errorMessage' ss' $ CannotDeriveNewtypeForData name + go (DataDeclaration (ss', _) Newtype name args dctors) = do checkNewtype name dctors wrappedIdent <- freshIdent "n" unwrappedIdent <- freshIdent "a" let (ctorName, [ty]) = head dctors ty' <- replaceAllTypeSynonymsM syns ty let inst = - [ ValueDecl (ss, []) (Ident "wrap") Public [] $ unguarded $ - Constructor nullSourceSpan (Qualified (Just mn) ctorName) - , ValueDecl (ss, []) (Ident "unwrap") Public [] $ unguarded $ - lamCase wrappedIdent + [ ValueDecl (ss', []) (Ident "wrap") Public [] $ unguarded $ + Constructor ss' (Qualified (Just mn) ctorName) + , ValueDecl (ss', []) (Ident "unwrap") Public [] $ unguarded $ + lamCase ss' wrappedIdent [ CaseAlternative - [ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) [VarBinder nullSourceSpan unwrappedIdent]] - (unguarded (Var nullSourceSpan (Qualified Nothing unwrappedIdent))) + [ConstructorBinder ss' (Qualified (Just mn) ctorName) [VarBinder ss' unwrappedIdent]] + (unguarded (Var ss' (Qualified Nothing unwrappedIdent))) ] ] subst = zipWith ((,) . fst) args tyConArgs @@ -640,20 +646,20 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType isTypeDecl (DataDeclaration _ _ nm _ _) | nm == tyConNm = True isTypeDecl _ = False -lam :: Ident -> Expr -> Expr -lam = Abs . VarBinder nullSourceSpan +lam :: SourceSpan -> Ident -> Expr -> Expr +lam ss = Abs . VarBinder ss -lamCase :: Ident -> [CaseAlternative] -> Expr -lamCase s = lam s . Case [mkVar s] +lamCase :: SourceSpan -> Ident -> [CaseAlternative] -> Expr +lamCase ss s = lam ss s . Case [mkVar ss s] -lamCase2 :: Ident -> Ident -> [CaseAlternative] -> Expr -lamCase2 s t = lam s . lam t . Case [mkVar s, mkVar t] +lamCase2 :: SourceSpan -> Ident -> Ident -> [CaseAlternative] -> Expr +lamCase2 ss s t = lam ss s . lam ss t . Case [mkVar ss s, mkVar ss t] -mkVarMn :: Maybe ModuleName -> Ident -> Expr -mkVarMn mn = Var nullSourceSpan . Qualified mn +mkVarMn :: SourceSpan -> Maybe ModuleName -> Ident -> Expr +mkVarMn ss mn = Var ss . Qualified mn -mkVar :: Ident -> Expr -mkVar = mkVarMn Nothing +mkVar :: SourceSpan -> Ident -> Expr +mkVar ss = mkVarMn ss Nothing isAppliedVar :: Type -> Bool isAppliedVar (TypeApp (TypeVar _) _) = True @@ -694,7 +700,7 @@ deriveFunctor ss mn syns ds tyConNm = do ((iTy, _) : _) -> do f <- freshIdent "f" m <- freshIdent "m" - lam f . lamCase m <$> mapM (mkCtorClause iTy f) ctors + lam ss' f . lamCase ss' m <$> mapM (mkCtorClause iTy f) ctors mkMapFunction _ = internalError "mkMapFunction: expected DataDeclaration" mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [Type]) -> m CaseAlternative @@ -702,17 +708,17 @@ deriveFunctor ss mn syns ds tyConNm = do idents <- replicateM (length ctorTys) (freshIdent "v") ctorTys' <- mapM (replaceAllTypeSynonymsM syns) ctorTys args <- zipWithM transformArg idents ctorTys' - let ctor = Constructor nullSourceSpan (Qualified (Just mn) ctorName) + let ctor = Constructor ss (Qualified (Just mn) ctorName) rebuilt = foldl' App ctor args - caseBinder = ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) (VarBinder nullSourceSpan <$> idents) + caseBinder = ConstructorBinder ss (Qualified (Just mn) ctorName) (VarBinder ss <$> idents) return $ CaseAlternative [caseBinder] (unguarded rebuilt) where - fVar = mkVar f - mapVar = mkVarMn (Just dataFunctor) (Ident C.map) + fVar = mkVar ss f + mapVar = mkVarMn ss (Just dataFunctor) (Ident C.map) -- TODO: deal with type synonyms, ala https://github.com/purescript/purescript/pull/2516 transformArg :: Ident -> Type -> m Expr - transformArg ident = fmap (foldr App (mkVar ident)) . goType where + transformArg ident = fmap (foldr App (mkVar ss ident)) . goType where goType :: Type -> m (Maybe Expr) -- argument matches the index type @@ -730,10 +736,11 @@ deriveFunctor ss mn syns ds tyConNm = do return ((lbl,) <$> upd) buildRecord :: [(Label, Expr)] -> m Expr - buildRecord updates = do arg <- freshIdent "o" - let argVar = mkVar arg - mkAssignment ((Label l), x) = (l, App x (Accessor l argVar)) - return (lam arg (ObjectUpdate argVar (mkAssignment <$> updates))) + buildRecord updates = do + arg <- freshIdent "o" + let argVar = mkVar ss arg + mkAssignment ((Label l), x) = (l, App x (Accessor l argVar)) + return (lam ss arg (ObjectUpdate argVar (mkAssignment <$> updates))) -- under a `* -> *`, just assume functor for now goType (TypeApp _ t) = fmap (App mapVar) <$> goType t From d60d0f5436a655e50f11c814d73af7993b442c05 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 23 Jan 2018 10:44:02 +0000 Subject: [PATCH 0928/1580] Ensure ExportConflict has source span (#3217) --- src/Language/PureScript/Sugar/Names/Env.hs | 58 +++++++++++-------- .../PureScript/Sugar/Names/Exports.hs | 46 +++++++-------- 2 files changed, 56 insertions(+), 48 deletions(-) diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index dbb4d3618f..2aef0d1acf 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -214,13 +214,14 @@ data ExportMode = Internal | ReExport -- exportType :: MonadError MultipleErrors m - => ExportMode + => SourceSpan + -> ExportMode -> Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ModuleName -> m Exports -exportType exportMode exps name dctors mn = do +exportType ss exportMode exps name dctors mn = do let exTypes = exportedTypes exps exClasses = exportedTypeClasses exps dctorNameCounts :: [(ProperName 'ConstructorName, Int)] @@ -242,11 +243,11 @@ exportType exportMode exps name dctors mn = do ReExport -> do forM_ (name `M.lookup` exTypes) $ \(_, mn') -> when (mn /= mn') $ - throwExportConflict mn mn' (TyName name) + throwExportConflict ss mn mn' (TyName name) forM_ dctors $ \dctor -> forM_ ((elem dctor . fst) `find` exTypes) $ \(_, mn') -> when (mn /= mn') $ - throwExportConflict mn mn' (DctorName dctor) + throwExportConflict ss mn mn' (DctorName dctor) return $ exps { exportedTypes = M.alter updateOrInsert name exTypes } where updateOrInsert Nothing = Just (dctors, mn) @@ -258,12 +259,13 @@ exportType exportMode exps name dctors mn = do -- exportTypeOp :: MonadError MultipleErrors m - => Exports + => SourceSpan + -> Exports -> OpName 'TypeOpName -> ModuleName -> m Exports -exportTypeOp exps op mn = do - typeOps <- addExport TyOpName op mn (exportedTypeOps exps) +exportTypeOp ss exps op mn = do + typeOps <- addExport ss TyOpName op mn (exportedTypeOps exps) return $ exps { exportedTypeOps = typeOps } -- | @@ -271,19 +273,20 @@ exportTypeOp exps op mn = do -- exportTypeClass :: MonadError MultipleErrors m - => ExportMode + => SourceSpan + -> ExportMode -> Exports -> ProperName 'ClassName -> ModuleName -> m Exports -exportTypeClass exportMode exps name mn = do +exportTypeClass ss exportMode exps name mn = do let exTypes = exportedTypes exps when (exportMode == Internal) $ do when (coerceProperName name `M.member` exTypes) $ throwDeclConflict (TyClassName name) (TyName (coerceProperName name)) when ((elem (coerceProperName name) . fst) `any` exTypes) $ throwDeclConflict (TyClassName name) (DctorName (coerceProperName name)) - classes <- addExport TyClassName name mn (exportedTypeClasses exps) + classes <- addExport ss TyClassName name mn (exportedTypeClasses exps) return $ exps { exportedTypeClasses = classes } -- | @@ -291,12 +294,13 @@ exportTypeClass exportMode exps name mn = do -- exportValue :: MonadError MultipleErrors m - => Exports + => SourceSpan + -> Exports -> Ident -> ModuleName -> m Exports -exportValue exps name mn = do - values <- addExport IdentName name mn (exportedValues exps) +exportValue ss exps name mn = do + values <- addExport ss IdentName name mn (exportedValues exps) return $ exps { exportedValues = values } -- | @@ -305,12 +309,13 @@ exportValue exps name mn = do -- exportValueOp :: MonadError MultipleErrors m - => Exports + => SourceSpan + -> Exports -> OpName 'ValueOpName -> ModuleName -> m Exports -exportValueOp exps op mn = do - valueOps <- addExport ValOpName op mn (exportedValueOps exps) +exportValueOp ss exps op mn = do + valueOps <- addExport ss ValOpName op mn (exportedValueOps exps) return $ exps { exportedValueOps = valueOps } -- | @@ -318,12 +323,13 @@ exportValueOp exps op mn = do -- exportKind :: MonadError MultipleErrors m - => Exports + => SourceSpan + -> Exports -> ProperName 'KindName -> ModuleName -> m Exports -exportKind exps name mn = do - kinds <- addExport KiName name mn (exportedKinds exps) +exportKind ss exps name mn = do + kinds <- addExport ss KiName name mn (exportedKinds exps) return $ exps { exportedKinds = kinds } -- | @@ -332,16 +338,17 @@ exportKind exps name mn = do -- addExport :: (MonadError MultipleErrors m, Ord a) - => (a -> Name) + => SourceSpan + -> (a -> Name) -> a -> ModuleName -> M.Map a ModuleName -> m (M.Map a ModuleName) -addExport toName name mn exports = +addExport ss toName name mn exports = case M.lookup name exports of Just mn' | mn == mn' -> return exports - | otherwise -> throwExportConflict mn mn' (toName name) + | otherwise -> throwExportConflict ss mn mn' (toName name) Nothing -> return $ M.insert name mn exports @@ -361,12 +368,13 @@ throwDeclConflict new existing = -- throwExportConflict :: MonadError MultipleErrors m - => ModuleName + => SourceSpan + -> ModuleName -> ModuleName -> Name -> m a -throwExportConflict new existing name = - throwError . errorMessage $ +throwExportConflict ss new existing name = + throwError . errorMessage' ss $ ExportConflict (Qualified (Just new) name) (Qualified (Just existing) name) -- | diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 14156c709d..ed02b81074 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -34,27 +34,27 @@ findExportable (Module _ _ mn ds _) = updateExports :: Exports -> Declaration -> m Exports updateExports exps (TypeClassDeclaration (ss, _) tcn _ _ _ ds') = do - exps' <- rethrowWithPosition ss $ exportTypeClass Internal exps tcn mn + exps' <- rethrowWithPosition ss $ exportTypeClass ss Internal exps tcn mn foldM go exps' ds' where - go exps'' (TypeDeclaration (TypeDeclarationData (ss', _) name _)) = rethrowWithPosition ss' $ exportValue exps'' name mn + go exps'' (TypeDeclaration (TypeDeclarationData (ss', _) name _)) = exportValue ss' exps'' name mn go _ _ = internalError "Invalid declaration in TypeClassDeclaration" - updateExports exps (DataDeclaration _ _ tn _ dcs) = - exportType Internal exps tn (map fst dcs) mn - updateExports exps (TypeSynonymDeclaration _ tn _ _) = - exportType Internal exps tn [] mn - updateExports exps (ExternDataDeclaration _ tn _) = - exportType Internal exps tn [] mn + updateExports exps (DataDeclaration (ss, _) _ tn _ dcs) = + exportType ss Internal exps tn (map fst dcs) mn + updateExports exps (TypeSynonymDeclaration (ss, _) tn _ _) = + exportType ss Internal exps tn [] mn + updateExports exps (ExternDataDeclaration (ss, _) tn _) = + exportType ss Internal exps tn [] mn updateExports exps (ValueDeclaration vd) = - exportValue exps (valdeclIdent vd) mn - updateExports exps (ValueFixityDeclaration _ _ _ op) = - exportValueOp exps op mn - updateExports exps (TypeFixityDeclaration _ _ _ op) = - exportTypeOp exps op mn - updateExports exps (ExternDeclaration _ name _) = - exportValue exps name mn - updateExports exps (ExternKindDeclaration _ pn) = - exportKind exps pn mn + exportValue (fst (valdeclSourceAnn vd)) exps (valdeclIdent vd) mn + updateExports exps (ValueFixityDeclaration (ss, _) _ _ op) = + exportValueOp ss exps op mn + updateExports exps (TypeFixityDeclaration (ss, _) _ _ op) = + exportTypeOp ss exps op mn + updateExports exps (ExternDeclaration (ss, _) name _) = + exportValue ss exps name mn + updateExports exps (ExternKindDeclaration (ss, _) pn) = + exportKind ss exps pn mn updateExports exps _ = return exps -- | @@ -110,12 +110,12 @@ resolveExports env ss mn imps exps refs = reValues <- extract isPseudo name IdentName (importedValues imps) reValueOps <- extract isPseudo name ValOpName (importedValueOps imps) reKinds <- extract isPseudo name KiName (importedKinds imps) - foldM (\exps' ((tctor, dctors), mn') -> exportType ReExport exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors) - >>= flip (foldM (uncurry . exportTypeOp)) (map resolveTypeOp reTypeOps) - >>= flip (foldM (uncurry . exportTypeClass ReExport)) (map resolveClass reClasses) - >>= flip (foldM (uncurry . exportValue)) (map resolveValue reValues) - >>= flip (foldM (uncurry . exportValueOp)) (map resolveValueOp reValueOps) - >>= flip (foldM (uncurry . exportKind)) (map resolveKind reKinds) + foldM (\exps' ((tctor, dctors), mn') -> exportType ss' ReExport exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors) + >>= flip (foldM (uncurry . exportTypeOp ss')) (map resolveTypeOp reTypeOps) + >>= flip (foldM (uncurry . exportTypeClass ss' ReExport)) (map resolveClass reClasses) + >>= flip (foldM (uncurry . exportValue ss')) (map resolveValue reValues) + >>= flip (foldM (uncurry . exportValueOp ss')) (map resolveValueOp reValueOps) + >>= flip (foldM (uncurry . exportKind ss')) (map resolveKind reKinds) elaborateModuleExports result _ = return result -- Extracts a list of values for a module based on a lookup table. If the From 0798e334c7cfc22b508d54786b94d463b93ef156 Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Tue, 23 Jan 2018 06:23:57 -0500 Subject: [PATCH 0929/1580] allow for explicit exports in generating tags (#3205) * allow for explicit exports in generating tags fixes https://github.com/purescript/purescript/issues/3204 Reuses other formats' (HTML, Markdown) machinery for converting PS modules to a friendlier doc module format before generating tags. This eliminates some error-prone ad-hoc logic for converting declarations directly to tags. * test tags * move tag generation into lib this makes tag generation more testable * ensure proper sorting in tag generation For all tags, use a Map to ensure that filenames and modules correspond correctly. For ctags, add a comment explaining why we sort on tag name. For etags, ensure that they are sorted by module. * docs/tags: move logic for linking paths to modules Move the logic for maintaining a map between module paths and data from Command.Docs to Language.PureScript.Docs.Convert, allowing other callers to reuse the functionality. --- app/Command/Docs.hs | 44 ++----- app/Command/Docs/Ctags.hs | 13 -- app/Command/Docs/Etags.hs | 13 -- app/Command/Docs/Tags.hs | 21 --- examples/docs/src/ExplicitExport.purs | 7 + package.yaml | 3 - src/Language/PureScript/Docs.hs | 1 + src/Language/PureScript/Docs/Convert.hs | 26 ++++ .../PureScript/Docs/ParseInPackage.hs | 11 +- src/Language/PureScript/Docs/Tags.hs | 53 ++++++++ src/Language/PureScript/Publish.hs | 2 +- tests/TestDocs.hs | 122 ++++++++++++++++-- 12 files changed, 214 insertions(+), 102 deletions(-) delete mode 100644 app/Command/Docs/Ctags.hs delete mode 100644 app/Command/Docs/Etags.hs delete mode 100644 app/Command/Docs/Tags.hs create mode 100644 examples/docs/src/ExplicitExport.purs create mode 100644 src/Language/PureScript/Docs/Tags.hs diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index 8e728eb19c..1a4841f094 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -2,34 +2,29 @@ module Command.Docs (command, infoModList) where -import Protolude (ordNub) - -import Command.Docs.Etags -import Command.Docs.Ctags import Command.Docs.Html import Control.Applicative import Control.Arrow (first, second) import Control.Category ((>>>)) import Control.Monad.Writer import Control.Monad.Trans.Except (runExceptT) -import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Function (on) import Data.List -import Data.Maybe (fromMaybe) import Data.Tuple (swap) import qualified Language.PureScript as P import qualified Language.PureScript.Docs as D import qualified Language.PureScript.Docs.AsMarkdown as D +import Language.PureScript.Docs.Tags (dumpCtags, dumpEtags) import qualified Options.Applicative as Opts import qualified Text.PrettyPrint.ANSI.Leijen as PP import System.Directory (createDirectoryIfMissing) import System.Exit (exitFailure) import System.FilePath (takeDirectory) import System.FilePath.Glob (glob) -import System.IO (hPutStrLn, hPrint, stderr) -import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT) +import System.IO (hPutStrLn, stderr) +import System.IO.UTF8 (writeUTF8FileT) -- | Available output formats data Format @@ -60,19 +55,18 @@ docgen (PSCDocsOptions fmt inputGlob output) = do hPutStrLn stderr "purs docs: no input files." exitFailure + fileMs <- parseAndConvert input + let ms = map snd fileMs case fmt of - Etags -> dumpTags input dumpEtags - Ctags -> dumpTags input dumpCtags + Etags -> mapM_ putStrLn $ dumpEtags fileMs + Ctags -> mapM_ putStrLn $ dumpCtags fileMs Html -> do let outputDir = "./generated-docs" -- TODO: make this configurable - ms <- parseAndConvert input let msHtml = map asHtml (D.primDocsModule : ms) createDirectoryIfMissing False outputDir writeHtmlModules outputDir msHtml - Markdown -> do - ms <- parseAndConvert input - + Markdown -> case output of EverythingToStdOut -> T.putStrLn (D.runDocs (D.modulesAsMarkdown ms)) @@ -115,7 +109,7 @@ docgen (PSCDocsOptions fmt inputGlob output) = do parseAndConvert input = runExceptT (D.parseFilesInPackages input [] - >>= uncurry D.convertModulesInPackage) + >>= uncurry D.convertTaggedModulesInPackage) >>= successOrExit -- | @@ -139,26 +133,6 @@ takeModulesByName' getModuleName modules = foldl go ([], []) Just m -> ((m, x) : ms, missing) Nothing -> (ms, name : missing) -dumpTags :: [FilePath] -> ([(String, P.Module)] -> [String]) -> IO () -dumpTags input renderTags = do - e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (ordNub input) - case e of - Left err -> do - hPrint stderr err - exitFailure - Right ms -> - ldump (renderTags (pairs ms)) - - where - pairs :: [(Maybe String, m)] -> [(String, m)] - pairs = map (first (fromMaybe "")) - - ldump :: [String] -> IO () - ldump = mapM_ putStrLn - -parseFile :: FilePath -> IO (FilePath, Text) -parseFile input = (,) input <$> readUTF8FileT input - inputFile :: Opts.Parser FilePath inputFile = Opts.strArgument $ Opts.metavar "FILE" diff --git a/app/Command/Docs/Ctags.hs b/app/Command/Docs/Ctags.hs deleted file mode 100644 index 9cfd71442f..0000000000 --- a/app/Command/Docs/Ctags.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Command.Docs.Ctags (dumpCtags) where - -import Command.Docs.Tags -import Data.List (sort) -import qualified Language.PureScript as P - -dumpCtags :: [(String, P.Module)] -> [String] -dumpCtags = sort . concatMap renderModCtags - -renderModCtags :: (String, P.Module) -> [String] -renderModCtags (path, mdl) = sort tagLines - where tagLines = map tagLine $ tags mdl - tagLine (name, line) = name ++ "\t" ++ path ++ "\t" ++ show line diff --git a/app/Command/Docs/Etags.hs b/app/Command/Docs/Etags.hs deleted file mode 100644 index c6e431916e..0000000000 --- a/app/Command/Docs/Etags.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Command.Docs.Etags (dumpEtags) where - -import Command.Docs.Tags -import qualified Language.PureScript as P - -dumpEtags :: [(String, P.Module)] -> [String] -dumpEtags = concatMap renderModEtags - -renderModEtags :: (String, P.Module) -> [String] -renderModEtags (path, mdl) = ["\x0c", path ++ "," ++ show tagsLen] ++ tagLines - where tagsLen = sum $ map length tagLines - tagLines = map tagLine $ tags mdl - tagLine (name, line) = "\x7f" ++ name ++ "\x01" ++ show line ++ "," diff --git a/app/Command/Docs/Tags.hs b/app/Command/Docs/Tags.hs deleted file mode 100644 index ebf3ae82ad..0000000000 --- a/app/Command/Docs/Tags.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Command.Docs.Tags where - -import Control.Arrow (first) -import qualified Data.Text as T -import qualified Language.PureScript as P - -tags :: P.Module -> [(String, Int)] -tags = map (first T.unpack) . concatMap dtags . P.exportedDeclarations - where - dtags :: P.Declaration -> [(P.Text, Int)] - dtags (P.DataDeclaration (ss, _) _ name _ dcons) = (P.runProperName name, pos ss) : consNames - where consNames = map (\(cname, _) -> (P.runProperName cname, pos ss)) dcons - dtags (P.TypeDeclaration (P.TypeDeclarationData (ss, _) ident _)) = [(P.showIdent ident, pos ss)] - dtags (P.ExternDeclaration (ss, _) ident _) = [(P.showIdent ident, pos ss)] - dtags (P.TypeSynonymDeclaration (ss, _) name _ _) = [(P.runProperName name, pos ss)] - dtags (P.TypeClassDeclaration (ss, _) name _ _ _ _) = [(P.runProperName name, pos ss)] - dtags (P.TypeInstanceDeclaration (ss, _) _ _ name _ _ _ _) = [(P.showIdent name, pos ss)] - dtags (P.ExternKindDeclaration (ss, _) name) = [(P.runProperName name, pos ss)] - dtags _ = [] - pos :: P.SourceSpan -> Int - pos = P.sourcePosLine . P.spanStart diff --git a/examples/docs/src/ExplicitExport.purs b/examples/docs/src/ExplicitExport.purs new file mode 100644 index 0000000000..43e7ba6610 --- /dev/null +++ b/examples/docs/src/ExplicitExport.purs @@ -0,0 +1,7 @@ +module ExplicitExport (one) where + +one :: Int +one = 1 + +two :: Int +two = 2 diff --git a/package.yaml b/package.yaml index 6a2b0bf4d6..19ce9c58c2 100644 --- a/package.yaml +++ b/package.yaml @@ -120,10 +120,7 @@ executables: - Command.Bundle - Command.Compile - Command.Docs - - Command.Docs.Ctags - - Command.Docs.Etags - Command.Docs.Html - - Command.Docs.Tags - Command.Hierarchy - Command.Ide - Command.Publish diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs index f63544c639..16673c053e 100644 --- a/src/Language/PureScript/Docs.hs +++ b/src/Language/PureScript/Docs.hs @@ -11,5 +11,6 @@ import Language.PureScript.Docs.Prim as Docs import Language.PureScript.Docs.ParseInPackage as Docs import Language.PureScript.Docs.Render as Docs import Language.PureScript.Docs.RenderedCode as Docs +import Language.PureScript.Docs.Tags as Docs import Language.PureScript.Docs.Types as Docs import Language.PureScript.Docs.Css as Docs diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 17b72aea80..af3cf067cd 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -4,6 +4,7 @@ module Language.PureScript.Docs.Convert ( convertModules , convertModulesWithEnv + , convertTaggedModulesInPackage , convertModulesInPackage , convertModulesInPackageWithEnv ) where @@ -25,6 +26,31 @@ import Web.Bower.PackageMeta (PackageName) import Text.Parsec (eof) +-- | +-- Like convertModuleInPackage, but with the modules tagged by their +-- file paths. +-- +convertTaggedModulesInPackage :: + (MonadError P.MultipleErrors m) => + [(FilePath, P.Module)] -> + Map P.ModuleName PackageName -> + m [(FilePath, Module)] +convertTaggedModulesInPackage taggedModules modulesDeps = + traverse pairDocModule =<< convertModulesInPackage modules modulesDeps + where + modules = map snd taggedModules + + moduleNameToFileMap = + Map.fromList $ swap . fmap P.getModuleName <$> taggedModules + + getModuleFile docModule = + case Map.lookup (modName docModule) moduleNameToFileMap of + Just filePath -> pure filePath + Nothing -> throwError . P.errorMessage $ + P.ModuleNotFound $ modName docModule + + pairDocModule docModule = (, docModule) <$> getModuleFile docModule + -- | -- Like convertModules, except that it takes a list of modules, together with -- their dependency status, and discards dependency modules in the resulting diff --git a/src/Language/PureScript/Docs/ParseInPackage.hs b/src/Language/PureScript/Docs/ParseInPackage.hs index 311980b4ac..7a90a84067 100644 --- a/src/Language/PureScript/Docs/ParseInPackage.hs +++ b/src/Language/PureScript/Docs/ParseInPackage.hs @@ -23,14 +23,15 @@ import Web.Bower.PackageMeta (PackageName) -- * Parse all of the input and dependency source files -- * Associate each dependency module with its package name, thereby -- distinguishing these from local modules --- * Return the parsed modules and a Map mapping module names to package --- names for modules which come from dependencies. If a module does not --- exist in the map, it can safely be assumed to be local. +-- * Return the paths paired with parsed modules, and a Map of module names +-- to package names for modules which come from dependencies. +-- If a module does not exist in the map, it can safely be assumed to be +-- local. parseFilesInPackages :: (MonadError P.MultipleErrors m, MonadIO m) => [FilePath] -> [(PackageName, FilePath)] - -> m ([P.Module], Map P.ModuleName PackageName) + -> m ([(FilePath, P.Module)], Map P.ModuleName PackageName) parseFilesInPackages inputFiles depsFiles = do inputFiles' <- traverse (readFileAs . Local) inputFiles depsFiles' <- traverse (readFileAs . uncurry FromDep) depsFiles @@ -39,7 +40,7 @@ parseFilesInPackages inputFiles depsFiles = do let mnMap = M.fromList (mapMaybe (\(inpkg, m) -> (P.getModuleName m,) <$> inPkgToMaybe inpkg) modules) - pure (map snd modules, mnMap) + pure (map (first fileInfoToString) modules, mnMap) where parse :: diff --git a/src/Language/PureScript/Docs/Tags.hs b/src/Language/PureScript/Docs/Tags.hs new file mode 100644 index 0000000000..0310bb7a63 --- /dev/null +++ b/src/Language/PureScript/Docs/Tags.hs @@ -0,0 +1,53 @@ +module Language.PureScript.Docs.Tags + ( tags + , dumpCtags + , dumpEtags + ) where + +import Prelude + +import Control.Arrow (first) +import Data.List (sort) +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import Language.PureScript.AST (SourceSpan, sourcePosLine, spanStart) +import Language.PureScript.Docs.Types + +tags :: Module -> [(String, Int)] +tags = map (first T.unpack) . concatMap dtags . modDeclarations + where + dtags :: Declaration -> [(T.Text, Int)] + dtags decl = case declSourceSpan decl of + Just ss -> (declTitle decl, pos ss):(mapMaybe subtag $ declChildren decl) + Nothing -> mapMaybe subtag $ declChildren decl + + subtag :: ChildDeclaration -> Maybe (T.Text, Int) + subtag cdecl = case cdeclSourceSpan cdecl of + Just ss -> Just (cdeclTitle cdecl, pos ss) + Nothing -> Nothing + + pos :: SourceSpan -> Int + pos = sourcePosLine . spanStart + +-- etags files appear to be sorted on module file name: +-- from emacs source, `emacs/lib-src/etags.c`: +-- "In etags mode, sort by file name." +dumpEtags :: [(String, Module)] -> [String] +dumpEtags = concatMap renderModEtags . sort + +renderModEtags :: (String, Module) -> [String] +renderModEtags (path, mdl) = ["\x0c", path ++ "," ++ show tagsLen] ++ tagLines + where tagsLen = sum $ map length tagLines + tagLines = map tagLine $ tags mdl + tagLine (name, line) = "\x7f" ++ name ++ "\x01" ++ show line ++ "," + +-- ctags files are required to be sorted: http://ctags.sourceforge.net/FORMAT +-- "The tags file is sorted on {tagname}. This allows for a binary search in +-- the file." +dumpCtags :: [(String, Module)] -> [String] +dumpCtags = sort . concatMap renderModCtags + +renderModCtags :: (String, Module) -> [String] +renderModCtags (path, mdl) = sort tagLines + where tagLines = map tagLine $ tags mdl + tagLine (name, line) = name ++ "\t" ++ path ++ "\t" ++ show line diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index e41620e33b..73545bf488 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -149,7 +149,7 @@ getModules paths = do (inputFiles, depsFiles) <- liftIO (getInputAndDepsFiles paths) (modules', moduleMap) <- parseFilesInPackages inputFiles depsFiles - case runExcept (D.convertModulesInPackage modules' moduleMap) of + case runExcept (D.convertModulesInPackage (map snd modules') moduleMap) of Right modules -> return (modules, moduleMap) Left err -> userError (CompileError err) diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 8311fefad5..5d438d86ad 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -15,6 +15,7 @@ import Control.Monad.IO.Class (liftIO) import Data.List (findIndex) import Data.Foldable import Safe (headMay) +import qualified Data.Map as Map import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import Data.Text (Text) @@ -64,18 +65,31 @@ spec = do let linksCtx = Docs.getLinksContext pkg - context "Language.PureScript.Docs" $ - forM_ testCases $ \(mnString, assertions) -> do - let mn = P.moduleNameFromString mnString - mdl = find ((==) mn . Docs.modName) pkgModules + context "Language.PureScript.Docs" $ do + context "Doc generation tests:" $ + forM_ testCases $ \(mnString, assertions) -> do + let mn = P.moduleNameFromString mnString + mdl = find ((==) mn . Docs.modName) pkgModules - context ("in module " ++ T.unpack mnString) $ do - case mdl of - Nothing -> - it "exists in docs output" $ - expectationFailure ("module not found in docs: " ++ T.unpack mnString) - Just mdl' -> - toHspec linksCtx mdl' assertions + context ("in module " ++ T.unpack mnString) $ + case mdl of + Nothing -> + it "exists in docs output" $ + expectationFailure ("module not found in docs: " ++ T.unpack mnString) + Just mdl' -> + toHspec linksCtx mdl' assertions + + context "Tag generation tests:" $ + forM_ testTagsCases $ \(mnString, assertions) -> do + let mn = P.moduleNameFromString mnString + mdl = find ((==) mn . Docs.modName) pkgModules + context ("in module " ++ T.unpack mnString) $ + case mdl of + Nothing -> + it "exists in docs output" $ + expectationFailure ("module not found in docs: " ++ T.unpack mnString) + Just mdl' -> + tagAssertionsToHspec mdl' assertions where toHspec :: Docs.LinksContext -> Docs.Module -> [DocsAssertion] -> Spec @@ -88,6 +102,17 @@ spec = do Fail reason -> expectationFailure (T.unpack (displayAssertionFailure reason)) + tagAssertionsToHspec :: Docs.Module -> [TagsAssertion] -> Spec + tagAssertionsToHspec mdl assertions = + let tags = Map.fromList $ Docs.tags mdl + in forM_ assertions $ \a -> + it (T.unpack (displayTagsAssertion a)) $ do + case runTagsAssertion a tags of + TagsPass -> + pure () + TagsFail reason -> + expectationFailure (T.unpack (displayTagsAssertionFailure reason)) + takeJust :: String -> Maybe a -> a takeJust msg = fromMaybe (error msg) @@ -130,6 +155,12 @@ data DocsAssertion -- | Assert that a given declaration comes before another in the output | ShouldComeBefore P.ModuleName Text Text +data TagsAssertion + -- | Assert that a particular declaration is tagged + = ShouldBeTagged Text Int + -- | Assert that a particular declaration is not tagged + | ShouldNotBeTagged Text + displayAssertion :: DocsAssertion -> Text displayAssertion = \case ShouldBeDocumented mn decl children -> @@ -167,6 +198,13 @@ displayAssertion = \case showQual mn declA <> " should come before " <> showQual mn declB <> " in the docs" +displayTagsAssertion :: TagsAssertion -> Text +displayTagsAssertion = \case + ShouldBeTagged decl l -> + decl <> " should be tagged at line " <> T.pack (show l) + ShouldNotBeTagged decl -> + decl <> " should not be tagged" + data DocsAssertionFailure -- | A declaration was not documented, but should have been = NotDocumented P.ModuleName Text @@ -211,6 +249,14 @@ data DocsAssertionFailure -- | Declarations were in the wrong order | WrongOrder P.ModuleName Text Text +data TagsAssertionFailure + -- | A declaration was not tagged, but should have been + = NotTagged Text + -- | A declaration was tagged, but should not have been + | Tagged Text Int + -- | A declaration was tagged on the wrong line + | TaggedWrongLine Text Int Int + displayAssertionFailure :: DocsAssertionFailure -> Text displayAssertionFailure = \case NotDocumented _ decl -> @@ -251,10 +297,25 @@ displayAssertionFailure = \case WrongOrder _ before after -> "expected to see " <> before <> " before " <> after +displayTagsAssertionFailure :: TagsAssertionFailure -> Text +displayTagsAssertionFailure = \case + NotTagged decl -> + decl <> " was not tagged, but should have been" + Tagged decl line -> + decl <> " was tagged at line " <> T.pack (show line) <> + ", but should not have been" + TaggedWrongLine decl taggedLine desiredLine -> + decl <> " was tagged at line " <> T.pack (show taggedLine) <> + ", but should have been tagged at line " <> T.pack (show desiredLine) + data DocsAssertionResult = Pass | Fail DocsAssertionFailure +data TagsAssertionResult + = TagsPass + | TagsFail TagsAssertionFailure + runAssertion :: DocsAssertion -> Docs.LinksContext -> Docs.Module -> DocsAssertionResult runAssertion assertion linksCtx Docs.Module{..} = case assertion of @@ -423,6 +484,22 @@ runAssertion assertion linksCtx Docs.Module{..} = _ -> Nothing +runTagsAssertion :: TagsAssertion -> Map.Map String Int -> TagsAssertionResult +runTagsAssertion assertion tags = + case assertion of + ShouldBeTagged decl line -> + case Map.lookup (T.unpack decl) tags of + Just taggedLine -> + if taggedLine == line + then TagsPass + else TagsFail $ TaggedWrongLine decl taggedLine line + Nothing -> TagsFail $ NotTagged decl + + ShouldNotBeTagged decl -> + case Map.lookup (T.unpack decl) tags of + Just taggedLine -> TagsFail $ Tagged decl taggedLine + Nothing -> TagsPass + checkConstrained :: P.Type -> Text -> Bool checkConstrained ty tyClass = case ty of @@ -584,6 +661,29 @@ testCases = shouldBeOrdered mn declNames = zipWith (ShouldComeBefore mn) declNames (tail declNames) +testTagsCases :: [(Text, [TagsAssertion])] +testTagsCases = + [ ("DeclOrder", + [ -- explicit exports + ShouldBeTagged "x1" 10 + , ShouldBeTagged "x3" 11 + , ShouldBeTagged "X2" 13 + , ShouldBeTagged "X4" 14 + , ShouldBeTagged "A" 16 + , ShouldBeTagged "B" 17 + ]) + , ("Example2", + [ -- all symbols exported + ShouldBeTagged "one" 3 + , ShouldBeTagged "two" 6 + ]) + , ("ExplicitExport", + [ -- only one of two symbols exported + ShouldBeTagged "one" 3 + , ShouldNotBeTagged "two" + ]) + ] + showQual :: P.ModuleName -> Text -> Text showQual mn decl = P.runModuleName mn <> "." <> decl From 6c7f561584af2591b851366d914eafa6398ae3e3 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Wed, 24 Jan 2018 16:12:29 +0000 Subject: [PATCH 0930/1580] Fix source span for a case of ScopeShadowing warning (#3219) --- examples/warning/ScopeShadowing2.purs | 10 +++++++ .../PureScript/Docs/Convert/ReExports.hs | 2 +- src/Language/PureScript/Sugar/Names/Env.hs | 7 +++-- .../PureScript/Sugar/Names/Imports.hs | 29 ++++++++++--------- 4 files changed, 30 insertions(+), 18 deletions(-) create mode 100644 examples/warning/ScopeShadowing2.purs diff --git a/examples/warning/ScopeShadowing2.purs b/examples/warning/ScopeShadowing2.purs new file mode 100644 index 0000000000..d9c359899e --- /dev/null +++ b/examples/warning/ScopeShadowing2.purs @@ -0,0 +1,10 @@ +-- @shouldWarnWith ScopeShadowing +module Main + ( append + , module Data.Semigroup + ) where + +import Data.Semigroup + +append :: forall a. a -> a -> a +append x _ = x diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 481fc60385..370a4bad61 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -172,7 +172,7 @@ findImport :: m (P.ModuleName, name) findImport imps (name, orig) = let - matches (P.ImportRecord qual mn _) = P.disqualify qual == name && mn == orig + matches (P.ImportRecord qual mn _ _) = P.disqualify qual == name && mn == orig matching = filter matches imps getQualified (P.Qualified mname _) = mname in diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 2aef0d1acf..7a7994fac7 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -48,6 +48,7 @@ data ImportRecord a = ImportRecord { importName :: Qualified a , importSourceModule :: ModuleName + , importSourceSpan :: SourceSpan , importProvenance :: ImportProvenance } deriving (Eq, Ord, Show) @@ -408,11 +409,11 @@ checkImportConflicts currentModule toName xs = in if length groups > 1 then case nonImplicit of - [ImportRecord (Qualified (Just mnNew) _) mnOrig _] -> do + [ImportRecord (Qualified (Just mnNew) _) mnOrig ss _] -> do let warningModule = if mnNew == currentModule then Nothing else Just mnNew - tell . errorMessage $ ScopeShadowing name warningModule $ delete mnNew conflictModules + tell . errorMessage' ss $ ScopeShadowing name warningModule $ delete mnNew conflictModules return (mnNew, mnOrig) _ -> throwError . errorMessage $ ScopeConflict name conflictModules else - let ImportRecord (Qualified (Just mnNew) _) mnOrig _ = head byOrig + let ImportRecord (Qualified (Just mnNew) _) mnOrig _ _ = head byOrig in return (mnNew, mnOrig) diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index e7680d104f..3db7d5a3ec 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -180,28 +180,28 @@ resolveImport importModule exps imps impQual = resolveByType >>= flip (foldM (\m (name, _) -> importer m (KindRef ss name))) (M.toList (exportedKinds exps)) importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports - importRef prov imp (ValueRef _ name) = do - let values' = updateImports (importedValues imp) (exportedValues exps) id name prov + importRef prov imp (ValueRef ss name) = do + let values' = updateImports (importedValues imp) (exportedValues exps) id name ss prov return $ imp { importedValues = values' } - importRef prov imp (ValueOpRef _ name) = do - let valueOps' = updateImports (importedValueOps imp) (exportedValueOps exps) id name prov + importRef prov imp (ValueOpRef ss name) = do + let valueOps' = updateImports (importedValueOps imp) (exportedValueOps exps) id name ss prov return $ imp { importedValueOps = valueOps' } importRef prov imp (TypeRef ss name dctors) = do - let types' = updateImports (importedTypes imp) (exportedTypes exps) snd name prov + let types' = updateImports (importedTypes imp) (exportedTypes exps) snd name ss prov let (dctorNames, mn) = allExportedDataConstructors name dctorLookup :: M.Map (ProperName 'ConstructorName) ModuleName dctorLookup = M.fromList $ map (, mn) dctorNames traverse_ (traverse_ $ checkDctorExists ss name dctorNames) dctors - let dctors' = foldl (\m d -> updateImports m dctorLookup id d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors) + let dctors' = foldl (\m d -> updateImports m dctorLookup id d ss prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors) return $ imp { importedTypes = types', importedDataConstructors = dctors' } - importRef prov imp (TypeOpRef _ name) = do - let ops' = updateImports (importedTypeOps imp) (exportedTypeOps exps) id name prov + importRef prov imp (TypeOpRef ss name) = do + let ops' = updateImports (importedTypeOps imp) (exportedTypeOps exps) id name ss prov return $ imp { importedTypeOps = ops' } - importRef prov imp (TypeClassRef _ name) = do - let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) id name prov + importRef prov imp (TypeClassRef ss name) = do + let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) id name ss prov return $ imp { importedTypeClasses = typeClasses' } - importRef prov imp (KindRef _ name) = do - let kinds' = updateImports (importedKinds imp) (exportedKinds exps) id name prov + importRef prov imp (KindRef ss name) = do + let kinds' = updateImports (importedKinds imp) (exportedKinds exps) id name ss prov return $ imp { importedKinds = kinds' } importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef" importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef" @@ -222,12 +222,13 @@ resolveImport importModule exps imps impQual = resolveByType -> M.Map a b -> (b -> ModuleName) -> a + -> SourceSpan -> ImportProvenance -> M.Map (Qualified a) [ImportRecord a] - updateImports imps' exps' expName name prov = + updateImports imps' exps' expName name ss prov = let mnOrig = maybe (internalError "Invalid state in updateImports") expName (name `M.lookup` exps') - rec = ImportRecord (Qualified (Just importModule) name) mnOrig prov + rec = ImportRecord (Qualified (Just importModule) name) mnOrig ss prov in M.alter (\currNames -> Just $ rec : fromMaybe [] currNames) From f999179792ae2c49b2ad3019959081540da0ad9f Mon Sep 17 00:00:00 2001 From: rndnoise <34294193+rndnoise@users.noreply.github.com> Date: Fri, 2 Feb 2018 14:58:57 -0600 Subject: [PATCH 0931/1580] Improvments to REPL tab-completion (#3231) - Complete all names that have been imported (transitively or directly) - Do not complete names that haven't been imported - Only recompute list of names after import or adding a let binding rather than after each request for name completion This commit fixes #3227 --- CONTRIBUTORS.md | 1 + app/Command/REPL.hs | 2 +- src/Language/PureScript/Interactive.hs | 3 +- .../PureScript/Interactive/Completion.hs | 93 ++++---------- src/Language/PureScript/Interactive/Module.hs | 13 +- src/Language/PureScript/Interactive/Types.hs | 116 +++++++++++++++--- src/Language/PureScript/Sugar/Names/Env.hs | 1 + tests/TestPsci/CommandTest.hs | 6 +- tests/TestPsci/CompletionTest.hs | 63 ++++++---- tests/TestPsci/TestEnv.hs | 2 +- 10 files changed, 178 insertions(+), 122 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 620c7929df..b87b25adf3 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -90,6 +90,7 @@ If you would prefer to use different terms, please use the section below instead | [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license](http://opensource.org/licenses/MIT) | | [@quesebifurcan](https://github.com/quesebifurcan) | Fredrik Wallberg | [MIT license](http://opensource.org/licenses/MIT) | | [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) | +| [@rndnoise](https://github.com/rndnoise) | rndnoise | [MIT license](http://opensource.org/licenses/MIT) | | [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license](http://opensource.org/licenses/MIT) | | [@RossMeikleham](https://github.com/RossMeikleham) | Ross Meikleham | [MIT license](http://opensource.org/licenses/MIT) | | [@Rufflewind](https://github.com/Rufflewind) | Phil Ruffwind | [MIT license](https://opensource.org/licenses/MIT) | diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 1b8199495d..c07db590d0 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -330,7 +330,7 @@ command = loop <$> options Right (modules, externs, env) -> do historyFilename <- getHistoryFilename let settings = defaultSettings { historyFile = Just historyFilename } - initialState = PSCiState [] [] (zip (map snd modules) externs) + initialState = updateLoadedExterns (const (zip (map snd modules) externs)) initialPSCiState config = PSCiConfig psciInputGlob env runner = flip runReaderT config . flip evalStateT initialState diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index ce051e9f3e..facde9e992 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -190,9 +190,8 @@ handleShowImportedModules => (String -> m ()) -> m () handleShowImportedModules print' = do - PSCiState { psciImportedModules = importedModules } <- get + importedModules <- psciImportedModules <$> get print' $ showModules importedModules - return () where showModules = unlines . sort . map (T.unpack . showModule) showModule (mn, declType, asQ) = diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index 90d05ee871..8833eb46fa 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -9,19 +9,16 @@ module Language.PureScript.Interactive.Completion import Prelude.Compat import Protolude (ordNub) -import Control.Arrow (second) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) -import Data.Function (on) -import Data.List (nubBy, isPrefixOf, sortBy, stripPrefix) +import Data.List (nub, isPrefixOf, sortBy, stripPrefix) +import Data.Map (keys) import Data.Maybe (mapMaybe) -import Data.Text (Text) import qualified Data.Text as T import qualified Language.PureScript as P import qualified Language.PureScript.Interactive.Directive as D import Language.PureScript.Interactive.Types -import qualified Language.PureScript.Names as N import System.Console.Haskeline -- Completions may read the state, but not modify it. @@ -157,76 +154,36 @@ getLoadedModules = asks (map fst . psciLoadedExterns) getModuleNames :: CompletionM [String] getModuleNames = moduleNames <$> getLoadedModules -mapLoadedModulesAndQualify :: (a -> Text) -> (P.Module -> [(a, P.Declaration)]) -> CompletionM [String] -mapLoadedModulesAndQualify sho f = do - ms <- getLoadedModules - let argPairs = do m <- ms - fm <- f m - return (m, fm) - concat <$> traverse (uncurry (getAllQualifications sho)) argPairs - getIdentNames :: CompletionM [String] -getIdentNames = mapLoadedModulesAndQualify P.showIdent identNames - -getDctorNames :: CompletionM [String] -getDctorNames = mapLoadedModulesAndQualify P.runProperName dctorNames - -getTypeNames :: CompletionM [String] -getTypeNames = mapLoadedModulesAndQualify P.runProperName typeDecls - --- | Given a module and a declaration in that module, return all possible ways --- it could have been referenced given the current PSCiState - including fully --- qualified, qualified using an alias, and unqualified. -getAllQualifications :: (a -> Text) -> P.Module -> (a, P.Declaration) -> CompletionM [String] -getAllQualifications sho m (declName, decl) = do - imports <- getAllImportsOf m - let fullyQualified = qualifyWith (Just (P.getModuleName m)) - let otherQuals = ordNub (concatMap qualificationsUsing imports) - return $ fullyQualified : otherQuals - where - qualifyWith mMod = T.unpack (P.showQualified sho (P.Qualified mMod declName)) - referencedBy refs = P.isExported (Just refs) decl +getIdentNames = do + importedVals <- asks (keys . P.importedValues . psciImports) + exportedVals <- asks (keys . P.exportedValues . psciExports) - qualificationsUsing (_, importType, asQ') = - let q = qualifyWith asQ' - in case importType of - P.Implicit -> [q] - P.Explicit refs -> [q | referencedBy refs] - P.Hiding refs -> [q | not $ referencedBy refs] + importedValOps <- asks (keys . P.importedValueOps . psciImports) + exportedValOps <- asks (keys . P.exportedValueOps . psciExports) + return . nub $ map (T.unpack . P.showQualified P.showIdent) importedVals + ++ map (T.unpack . P.showQualified P.runOpName) importedValOps + ++ map (T.unpack . P.showIdent) exportedVals + ++ map (T.unpack . P.runOpName) exportedValOps --- | Returns all the ImportedModule values referring to imports of a particular --- module. -getAllImportsOf :: P.Module -> CompletionM [ImportedModule] -getAllImportsOf = asks . allImportsOf +getDctorNames :: CompletionM [String] +getDctorNames = do + imports <- asks (keys . P.importedDataConstructors . psciImports) + return . nub $ map (T.unpack . P.showQualified P.runProperName) imports -nubOnFst :: Eq a => [(a, b)] -> [(a, b)] -nubOnFst = nubBy ((==) `on` fst) +getTypeNames :: CompletionM [String] +getTypeNames = do + importedTypes <- asks (keys . P.importedTypes . psciImports) + exportedTypes <- asks (keys . P.exportedTypes . psciExports) -typeDecls :: P.Module -> [(N.ProperName 'N.TypeName, P.Declaration)] -typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations - where - getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, P.Declaration) - getTypeName d@(P.TypeSynonymDeclaration _ name _ _) = Just (name, d) - getTypeName d@(P.DataDeclaration _ _ name _ _) = Just (name, d) - getTypeName _ = Nothing + importedTypeOps <- asks (keys . P.importedTypeOps . psciImports) + exportedTypeOps <- asks (keys . P.exportedTypeOps . psciExports) -identNames :: P.Module -> [(N.Ident, P.Declaration)] -identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations - where - getDeclNames :: P.Declaration -> [(P.Ident, P.Declaration)] - getDeclNames d@(P.ValueDecl _ ident _ _ _) = [(ident, d)] - getDeclNames d@(P.TypeDeclaration td) = [(P.tydeclIdent td, d)] - getDeclNames d@(P.ExternDeclaration _ ident _) = [(ident, d)] - getDeclNames d@(P.TypeClassDeclaration _ _ _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds - getDeclNames _ = [] - -dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)] -dctorNames = nubOnFst . concatMap go . P.exportedDeclarations - where - go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)] - go decl@(P.DataDeclaration _ _ _ _ ctors) = map ((\n -> (n, decl)) . fst) ctors - go _ = [] + return . nub $ map (T.unpack . P.showQualified P.runProperName) importedTypes + ++ map (T.unpack . P.showQualified P.runOpName) importedTypeOps + ++ map (T.unpack . P.runProperName) exportedTypes + ++ map (T.unpack . P.runOpName) exportedTypeOps moduleNames :: [P.Module] -> [String] moduleNames = ordNub . map (T.unpack . P.runModuleName . P.getModuleName) diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index a7855cdb68..1984471b2f 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -43,8 +43,10 @@ loadAllModules files = do -- Makes a volatile module to execute the current expression. -- createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module -createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val = +createTemporaryModule exec st val = let + imports = psciImportedModules st + lets = psciLetBindings st moduleName = P.ModuleName [P.ProperName "$PSCI"] effModuleName = P.moduleNameFromString "Control.Monad.Eff" effImport = (effModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Eff"])) @@ -73,10 +75,12 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi -- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration. -- createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module -createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ = +createTemporaryModuleForKind st typ = let + imports = psciImportedModules st + lets = psciLetBindings st moduleName = P.ModuleName [P.ProperName "$PSCI"] - itDecl = P.TypeSynonymDeclaration (internalSpan, []) (P.ProperName "IT") [] typ + itDecl = P.TypeSynonymDeclaration (internalSpan, []) (P.ProperName "IT") [] typ in P.Module internalSpan [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing @@ -84,8 +88,9 @@ createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBin -- Makes a volatile module to execute the current imports. -- createTemporaryModuleForImports :: PSCiState -> P.Module -createTemporaryModuleForImports PSCiState{psciImportedModules = imports} = +createTemporaryModuleForImports st = let + imports = psciImportedModules st moduleName = P.ModuleName [P.ProperName "$PSCI"] in P.Module internalSpan [] moduleName (importDecl `map` imports) Nothing diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index 003b90b100..15e1427024 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -1,11 +1,38 @@ -- | -- Type declarations and associated basic functions for PSCI. -- -module Language.PureScript.Interactive.Types where +module Language.PureScript.Interactive.Types + ( PSCiConfig(..) + , PSCiState -- constructor is not exported, to prevent psciImports and psciExports from + -- becoming inconsistent with importedModules, letBindings and loadedExterns + , ImportedModule + , psciExports + , psciImports + , psciLoadedExterns + , psciImportedModules + , psciLetBindings + , initialPSCiState + , psciImportedModuleNames + , updateImportedModules + , updateLoadedExterns + , updateLets + , Command(..) + , ReplQuery(..) + , replQueries + , replQueryStrings + , showReplQuery + , parseReplQuery + , Directive(..) + ) where import Prelude.Compat import qualified Language.PureScript as P +import qualified Data.Map as M +import Language.PureScript.Sugar.Names.Env (nullImports, primExports) +import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Writer.Strict (runWriterT) + -- | The PSCI configuration. -- @@ -19,16 +46,37 @@ data PSCiConfig = PSCiConfig -- | The PSCI state. -- -- Holds a list of imported modules, loaded files, and partial let bindings. --- The let bindings are partial, --- because it makes more sense to apply the binding to the final evaluated expression. +-- The let bindings are partial, because it makes more sense to apply the +-- binding to the final evaluated expression. +-- +-- The last two fields are derived from the first three via updateImportExports +-- each time a module is imported, a let binding is added, or the session is +-- cleared or reloaded data PSCiState = PSCiState - { psciImportedModules :: [ImportedModule] - , psciLetBindings :: [P.Declaration] - , psciLoadedExterns :: [(P.Module, P.ExternsFile)] - } deriving Show + [ImportedModule] + [P.Declaration] + [(P.Module, P.ExternsFile)] + P.Imports + P.Exports + deriving Show + +psciImportedModules :: PSCiState -> [ImportedModule] +psciImportedModules (PSCiState x _ _ _ _) = x + +psciLetBindings :: PSCiState -> [P.Declaration] +psciLetBindings (PSCiState _ x _ _ _) = x + +psciLoadedExterns :: PSCiState -> [(P.Module, P.ExternsFile)] +psciLoadedExterns (PSCiState _ _ x _ _) = x + +psciImports :: PSCiState -> P.Imports +psciImports (PSCiState _ _ _ x _) = x + +psciExports :: PSCiState -> P.Exports +psciExports (PSCiState _ _ _ _ x) = x initialPSCiState :: PSCiState -initialPSCiState = PSCiState [] [] [] +initialPSCiState = PSCiState [] [] [] nullImports primExports -- | All of the data that is contained by an ImportDeclaration in the AST. -- That is: @@ -42,29 +90,59 @@ initialPSCiState = PSCiState [] [] [] type ImportedModule = (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName) psciImportedModuleNames :: PSCiState -> [P.ModuleName] -psciImportedModuleNames PSCiState{psciImportedModules = is} = - map (\(mn, _, _) -> mn) is +psciImportedModuleNames st = + map (\(mn, _, _) -> mn) (psciImportedModules st) + +-- * State helpers -allImportsOf :: P.Module -> PSCiState -> [ImportedModule] -allImportsOf m PSCiState{psciImportedModules = is} = - filter isImportOfThis is +-- This function updates the Imports and Exports values in the PSCiState, which are used for +-- handling completions. This function must be called whenever the PSCiState is modified to +-- ensure that completions remain accurate. +updateImportExports :: PSCiState -> PSCiState +updateImportExports st@(PSCiState modules lets externs _ _) = + case desugarModule [temporaryModule] of + Left _ -> st -- TODO: can this fail and what should we do? + Right (env, _) -> + case M.lookup temporaryName env of + Just (_, is, es) -> PSCiState modules lets externs is es + _ -> st -- impossible where - name = P.getModuleName m - isImportOfThis (name', _, _) = name == name' --- * State helpers + desugarModule :: [P.Module] -> Either P.MultipleErrors (P.Env, [P.Module]) + desugarModule = runExceptT =<< hushWarnings . P.desugarImportsWithEnv (map snd externs) + hushWarnings = fmap fst . runWriterT + + temporaryName :: P.ModuleName + temporaryName = P.ModuleName [P.ProperName "$PSCI"] + + temporaryModule :: P.Module + temporaryModule = + let + prim = (P.ModuleName [P.ProperName "Prim"], P.Implicit, Nothing) + decl = (importDecl `map` (prim : modules)) ++ lets + in + P.Module internalSpan [] temporaryName decl Nothing + + importDecl :: ImportedModule -> P.Declaration + importDecl (mn, declType, asQ) = P.ImportDeclaration (internalSpan, []) mn declType asQ + + internalSpan :: P.SourceSpan + internalSpan = P.internalModuleSourceSpan "" -- | Updates the imported modules in the state record. updateImportedModules :: ([ImportedModule] -> [ImportedModule]) -> PSCiState -> PSCiState -updateImportedModules f st = st { psciImportedModules = f (psciImportedModules st) } +updateImportedModules f (PSCiState x a b c d) = + updateImportExports (PSCiState (f x) a b c d) -- | Updates the loaded externs files in the state record. updateLoadedExterns :: ([(P.Module, P.ExternsFile)] -> [(P.Module, P.ExternsFile)]) -> PSCiState -> PSCiState -updateLoadedExterns f st = st { psciLoadedExterns = f (psciLoadedExterns st) } +updateLoadedExterns f (PSCiState a b x c d) = + PSCiState a b (f x) c d -- | Updates the let bindings in the state record. updateLets :: ([P.Declaration] -> [P.Declaration]) -> PSCiState -> PSCiState -updateLets f st = st { psciLetBindings = f (psciLetBindings st) } +updateLets f (PSCiState a x b c d) = + updateImportExports (PSCiState a (f x) b c d) -- * Commands diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 7a7994fac7..fc5f2cd21a 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -7,6 +7,7 @@ module Language.PureScript.Sugar.Names.Env , nullExports , Env , primEnv + , primExports , envModuleSourceSpan , envModuleImports , envModuleExports diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs index 57e7742a82..2e3980da81 100644 --- a/tests/TestPsci/CommandTest.hs +++ b/tests/TestPsci/CommandTest.hs @@ -35,6 +35,8 @@ commandTests = context "commandTests" $ do specPSCi ":complete" $ do ":complete ma" `prints` [] - ":complete Data.Functor.ma" `prints` (unlines (map ("Data.Functor." ++ ) ["map", "mapFlipped"])) + ":complete Data.Functor.ma" `prints` [] run "import Data.Functor" - ":complete ma" `prints` (unlines ["map", "mapFlipped"]) + ":complete ma" `prints` unlines ["map", "mapFlipped"] + run "import Control.Monad as M" + ":complete M.a" `prints` unlines ["M.ap", "M.apply"] diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index da1e586f85..958ce0b2a1 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -50,19 +50,24 @@ completionTestData supportModuleNames = , (":show ", [":show import", ":show loaded"]) , (":show a", []) - -- :type should complete values and data constructors in scope - , (":type Control.Monad.Eff.Console.lo", [":type Control.Monad.Eff.Console.log", ":type Control.Monad.Eff.Console.logShow"]) - --, (":type uni", [":type unit"]) - --, (":type E", [":type EQ"]) - - -- :kind should complete types in scope - --, (":kind C", [":kind Control.Monad.Eff.Pure"]) - --, (":kind O", [":kind Ordering"]) + -- :type should complete next word from values and constructors in scope + , (":type uni", [":type unit"]) + , (":type E", [":type EQ"]) + , (":type P.", map (":type P." ++) ["EQ", "GT", "LT", "unit"]) -- import Prelude (unit, Ordering(..)) as P + , (":type Control.Monad.Eff.Console.lo", []) + , (":type voi", []) + + -- :kind should complete next word from types in scope + , (":kind Str", [":kind String"]) + , (":kind ST.", [":kind ST.ST", ":kind ST.STRef"]) -- import Control.Monad.ST as ST + , (":kind Control.Monad.Eff.", []) -- Only one argument for directives should be completed , (":show import ", []) , (":type EQ ", []) + , (":type unit compa", []) , (":kind Ordering ", []) + , (":kind Array In", []) -- a few other import tests , ("impor", ["import"]) @@ -73,16 +78,13 @@ completionTestData supportModuleNames = , ("\"hi", []) , ("34", []) - -- Identifiers and data constructors should be completed - --, ("uni", ["unit"]) - , ("Control.Monad.Eff.Class.", ["Control.Monad.Eff.Class.liftEff"]) - --, ("G", ["GT"]) - , ("Data.Ordering.L", ["Data.Ordering.LT"]) - - -- if a module is imported qualified, values should complete under the - -- qualified name, as well as the original name. - , ("ST.new", ["ST.newSTRef"]) - , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"]) + -- Identifiers and data constructors in scope should be completed + , ("uni", ["unit"]) + , ("G", ["GT"]) + , ("P.G", ["P.GT"]) + , ("P.uni", ["P.unit"]) + , ("voi", []) -- import Prelude hiding (void) + , ("Control.Monad.Eff.Class.", []) ] assertCompletedOk :: (String, [String]) -> Spec @@ -98,11 +100,22 @@ runCM act = do getPSCiStateForCompletion :: IO PSCiState getPSCiStateForCompletion = do - (PSCiState _ bs es, _) <- initTestPSCiEnv - let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)] - return $ PSCiState imports bs es - -controlMonadSTasST :: ImportedModule -controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST")) + (st, _) <- initTestPSCiEnv + let imports = [-- import Control.Monad.ST as S + (qualName "Control.Monad.ST" + ,P.Implicit + ,Just (qualName "ST")) + -- import Prelude hiding (void) + ,(qualName "Prelude" + ,P.Hiding [valName "void"] + ,Nothing) + -- import Prelude (unit, Ordering(..)) as P + ,(qualName "Prelude" + ,P.Explicit [valName "unit", typeName "Ordering"] + ,Just (qualName "P"))] + return $ updateImportedModules (const imports) st where - s = P.moduleNameFromString + qualName = P.moduleNameFromString + valName = P.ValueRef srcSpan . P.Ident + typeName t = P.TypeRef srcSpan (P.ProperName t) Nothing + srcSpan = P.internalModuleSourceSpan "" diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index fdf0ca9a91..13a655f1a2 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -35,7 +35,7 @@ initTestPSCiEnv = do case makeResultOrError of Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure Right (externs, env) -> - return (PSCiState [] [] (zip (map snd modules) externs), PSCiConfig pursFiles env) + return (updateLoadedExterns (const (zip (map snd modules) externs)) initialPSCiState, PSCiConfig pursFiles env) -- | Execute a TestPSCi, returning IO execTestPSCi :: TestPSCi a -> IO a From 143f8f1f04144a0ee6bf10fc9ebf3755b75c1b62 Mon Sep 17 00:00:00 2001 From: rndnoise <34294193+rndnoise@users.noreply.github.com> Date: Fri, 16 Feb 2018 23:18:08 -0600 Subject: [PATCH 0932/1580] Make REPL completion tests faster (#3234) --- tests/TestPsci/CompletionTest.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index 958ce0b2a1..f84c3eb7d4 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -17,8 +17,9 @@ import TestUtils (getSupportModuleNames) completionTests :: Spec completionTests = context "completionTests" $ do - mns <- runIO $ getSupportModuleNames - mapM_ assertCompletedOk (completionTestData mns) + mns <- runIO getSupportModuleNames + psciState <- runIO getPSCiStateForCompletion + mapM_ (assertCompletedOk psciState) (completionTestData mns) -- If the cursor is at the right end of the line, with the 1st element of the -- pair as the text in the line, then pressing tab should offer all the @@ -87,16 +88,14 @@ completionTestData supportModuleNames = , ("Control.Monad.Eff.Class.", []) ] -assertCompletedOk :: (String, [String]) -> Spec -assertCompletedOk (line, expecteds) = specify line $ do - results <- runCM (completion' (reverse line, "")) +assertCompletedOk :: PSCiState -> (String, [String]) -> Spec +assertCompletedOk psciState (line, expecteds) = specify line $ do + results <- runCM psciState (completion' (reverse line, "")) let actuals = formatCompletions results sort actuals `shouldBe` sort expecteds -runCM :: CompletionM a -> IO a -runCM act = do - psciState <- getPSCiStateForCompletion - evalStateT (liftCompletionM act) psciState +runCM :: PSCiState -> CompletionM a -> IO a +runCM psciState act = evalStateT (liftCompletionM act) psciState getPSCiStateForCompletion :: IO PSCiState getPSCiStateForCompletion = do From d73957dbe12c2fe34bfb7472fcac7399631664f6 Mon Sep 17 00:00:00 2001 From: Chris Allen Date: Tue, 6 Mar 2018 11:04:26 -0600 Subject: [PATCH 0933/1580] Skip SourceSpan in Binder Eq, Ord for faster exhaustivity check (#3265) * Skip SourceSpan in Binder Eq, Ord for faster exhaustivity check * Use Semigroup rather than sui generis function * contributors.md --- CONTRIBUTORS.md | 1 + src/Language/PureScript/AST/Binders.hs | 100 ++++++++++++++++++++++++- 2 files changed, 100 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index b87b25adf3..c127ff37d4 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -26,6 +26,7 @@ If you would prefer to use different terms, please use the section below instead | [@balajirrao](https://github.com/balajirrao) | Balaji Rao | MIT license | | [@bbqbaron](https://github.com/bbqbaron) | Eric Loren | [MIT license](http://opensource.org/licenses/MIT) | | [@bergmark](https://github.com/bergmark) | Adam Bergmark | MIT license | +| [@bitemyapp](https://github.com/bitemyapp) | Chris Allen | [MIT license](http://opensource.org/licenses/MIT) | | [@bmjames](https://github.com/bmjames) | Ben James | [MIT license](http://opensource.org/licenses/MIT) | | [@Bogdanp](https://github.com/Bogdanp) | Bogdan Paul Popa | [MIT license](http://opensource.org/licenses/MIT) | | [@brandonhamilton](https://github.com/brandonhamilton) | Brandon Hamilton | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index c5054ce216..c27105c534 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -5,6 +5,8 @@ module Language.PureScript.AST.Binders where import Prelude.Compat +import Data.Semigroup + import Language.PureScript.AST.SourcePos import Language.PureScript.AST.Literals import Language.PureScript.Names @@ -61,7 +63,103 @@ data Binder -- A binder with a type annotation -- | TypedBinder Type Binder - deriving (Show, Eq, Ord) + deriving (Show) + +instance Eq Binder where + (==) NullBinder NullBinder = True + (==) NullBinder _ = False + + (==) (LiteralBinder lb) (LiteralBinder lb') = (==) lb lb' + (==) LiteralBinder{} _ = False + + (==) (VarBinder _ ident) (VarBinder _ ident') = (==) ident ident' + (==) VarBinder{} _ = False + + (==) (ConstructorBinder _ qpc bs) (ConstructorBinder _ qpc' bs') = + (==) qpc qpc' && (==) bs bs' + (==) ConstructorBinder{} _ = False + + (==) (OpBinder _ qov) (OpBinder _ qov') = + (==) qov qov' + (==) OpBinder{} _ = False + + (==) (BinaryNoParensBinder b1 b2 b3) (BinaryNoParensBinder b1' b2' b3') = + (==) b1 b1' && (==) b2 b2' && (==) b3 b3' + (==) BinaryNoParensBinder{} _ = False + + (==) (ParensInBinder b) (ParensInBinder b') = + (==) b b' + (==) ParensInBinder{} _ = False + + (==) (NamedBinder _ ident b) (NamedBinder _ ident' b') = + (==) ident ident' && (==) b b' + (==) NamedBinder{} _ = False + + (==) (PositionedBinder _ comments b) (PositionedBinder _ comments' b') = + (==) comments comments' && (==) b b' + (==) PositionedBinder{} _ = False + + (==) (TypedBinder ty b) (TypedBinder ty' b') = + (==) ty ty' && (==) b b' + (==) TypedBinder{} _ = False + +instance Ord Binder where + compare NullBinder NullBinder = EQ + compare NullBinder _ = LT + + compare (LiteralBinder lb) (LiteralBinder lb') = compare lb lb' + compare LiteralBinder{} NullBinder = GT + compare LiteralBinder{} _ = LT + + compare (VarBinder _ ident) (VarBinder _ ident') = compare ident ident' + compare VarBinder{} NullBinder = GT + compare VarBinder{} LiteralBinder{} = GT + compare VarBinder{} _ = LT + + compare (ConstructorBinder _ qpc bs) (ConstructorBinder _ qpc' bs') = + compare qpc qpc' <> compare bs bs' + compare ConstructorBinder{} NullBinder = GT + compare ConstructorBinder{} LiteralBinder{} = GT + compare ConstructorBinder{} VarBinder{} = GT + compare ConstructorBinder{} _ = LT + + compare (OpBinder _ qov) (OpBinder _ qov') = + compare qov qov' + compare OpBinder{} NullBinder = GT + compare OpBinder{} LiteralBinder{} = GT + compare OpBinder{} VarBinder{} = GT + compare OpBinder{} ConstructorBinder{} = GT + compare OpBinder{} _ = LT + + compare (BinaryNoParensBinder b1 b2 b3) (BinaryNoParensBinder b1' b2' b3') = + compare b1 b1' <> compare b2 b2' <> compare b3 b3' + compare BinaryNoParensBinder{} ParensInBinder{} = LT + compare BinaryNoParensBinder{} NamedBinder{} = LT + compare BinaryNoParensBinder{} PositionedBinder{} = LT + compare BinaryNoParensBinder{} TypedBinder{} = LT + compare BinaryNoParensBinder{} _ = GT + + compare (ParensInBinder b) (ParensInBinder b') = + compare b b' + compare ParensInBinder{} NamedBinder{} = LT + compare ParensInBinder{} PositionedBinder{} = LT + compare ParensInBinder{} TypedBinder{} = LT + compare ParensInBinder{} _ = GT + + compare (NamedBinder _ ident b) (NamedBinder _ ident' b') = + compare ident ident' <> compare b b' + compare NamedBinder{} PositionedBinder{} = LT + compare NamedBinder{} TypedBinder{} = LT + compare NamedBinder{} _ = GT + + compare (PositionedBinder _ comments b) (PositionedBinder _ comments' b') = + compare comments comments' <> compare b b' + compare PositionedBinder{} TypedBinder{} = LT + compare PositionedBinder{} _ = GT + + compare (TypedBinder ty b) (TypedBinder ty' b') = + compare ty ty' <> compare b b' + compare TypedBinder{} _ = GT -- | -- Collect all names introduced in binders in an expression From 9e42339d4be7f3fbc14cdf3ebf64bab67a4c84eb Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 6 Mar 2018 20:03:31 +0100 Subject: [PATCH 0934/1580] Make Let-Pattern desugaring less brittle (#3268) The old code relies on the Parser inserting PositionedValue wrappers in certain places, so that some patterns miss. I wrote this code a while back with @paf31, when we were trying to add SourceSpans to Binders and Exprs. --- src/Language/PureScript/Sugar/LetPattern.hs | 36 +++++++++++++-------- 1 file changed, 23 insertions(+), 13 deletions(-) diff --git a/src/Language/PureScript/Sugar/LetPattern.hs b/src/Language/PureScript/Sugar/LetPattern.hs index 9fb700d15e..69bb7ef07c 100644 --- a/src/Language/PureScript/Sugar/LetPattern.hs +++ b/src/Language/PureScript/Sugar/LetPattern.hs @@ -6,37 +6,47 @@ module Language.PureScript.Sugar.LetPattern (desugarLetPatternModule) where import Prelude.Compat +import Data.List (groupBy, concatMap) +import Data.Function (on) + import Language.PureScript.AST +import Language.PureScript.Crash --- | --- Replace every @BoundValueDeclaration@ in @Let@ expressions with @Case@ +-- | Replace every @BoundValueDeclaration@ in @Let@ expressions with @Case@ -- expressions. --- desugarLetPatternModule :: Module -> Module desugarLetPatternModule (Module ss coms mn ds exts) = Module ss coms mn (map desugarLetPattern ds) exts --- | --- Desugar a single let expression --- +-- | Desugar a single let expression desugarLetPattern :: Declaration -> Declaration desugarLetPattern decl = let (f, _, _) = everywhereOnValues id replace id in f decl where replace :: Expr -> Expr - replace (Let ds e) = go ds e + replace (Let ds e) = go (partitionDecls ds) e replace other = other - go :: [Declaration] + go :: [Either [Declaration] (SourceAnn, Binder, Expr)] -- ^ Declarations to desugar -> Expr -- ^ The original let-in result expression -> Expr go [] e = e - go (BoundValueDeclaration (pos, com) binder boundE : ds) e = + go (Right ((pos, com), binder, boundE) : ds) e = PositionedValue pos com $ Case [boundE] [CaseAlternative [binder] [MkUnguarded $ go ds e]] - go (d:ds) e = append d $ go ds e + go (Left ds:dss) e = Let ds (go dss e) + +partitionDecls :: [Declaration] -> [Either [Declaration] (SourceAnn, Binder, Expr)] +partitionDecls = concatMap f . groupBy ((==) `on` isBoundValueDeclaration) + where + f ds@(d:_) + | isBoundValueDeclaration d = map (Right . g) ds + f ds = [Left ds] + + g (BoundValueDeclaration sa binder expr) = (sa, binder, expr) + g _ = internalError "partitionDecls: the impossible happened." - append :: Declaration -> Expr -> Expr - append d (Let ds e) = Let (d:ds) e - append d e = Let [d] e +isBoundValueDeclaration :: Declaration -> Bool +isBoundValueDeclaration BoundValueDeclaration{} = True +isBoundValueDeclaration _ = False From 13bd530a1a88eff45a5dc31e6928b840c61f03a6 Mon Sep 17 00:00:00 2001 From: Chris Allen Date: Thu, 8 Mar 2018 22:40:04 -0600 Subject: [PATCH 0935/1580] Explaining the custom Eq, Ord instances for Binder (#3271) * Explaining the custom Eq, Ord instances for Binder * fix type and stretch to 80 characters --- src/Language/PureScript/AST/Binders.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index c27105c534..e7bbd29fbb 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -65,6 +65,13 @@ data Binder | TypedBinder Type Binder deriving (Show) +-- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing +-- the `SourceSpan` values embedded in some of the data constructors of `Binder` +-- was expensive. This made exhaustiveness checking observably slow for code +-- such as the `explode` function in `examples/passing/LargeSumTypes.purs`. +-- Custom instances were written to skip comparing the `SourceSpan` values. Only +-- the `Ord` instance was needed for the speed-up, but I did not want the `Eq` +-- to have mismatched behavior. instance Eq Binder where (==) NullBinder NullBinder = True (==) NullBinder _ = False From 3171a77e117ed4dcdbf994e40d0308fb440f6f57 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 10 Mar 2018 20:01:09 +0000 Subject: [PATCH 0936/1580] Allow errors to carry multiple positions (#3255) --- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Errors.hs | 16 +++++++++++----- src/Language/PureScript/Errors/JSON.hs | 12 +++++++----- src/Language/PureScript/Parser/Declarations.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 13 ++++++------- src/Language/PureScript/TypeChecker/Monad.hs | 2 +- src/Language/PureScript/TypeChecker/Skolems.hs | 2 +- 7 files changed, 28 insertions(+), 21 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 41eabcab53..adc8f95c54 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -198,7 +198,7 @@ data ErrorMessageHint | ErrorInTypeClassDeclaration (ProperName 'ClassName) | ErrorInForeignImport Ident | ErrorSolvingConstraint Constraint - | PositionedError SourceSpan + | PositionedError (NEL.NonEmpty SourceSpan) deriving (Show) -- | Categories of hints diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index d260836946..f9c40519ff 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -47,7 +47,7 @@ import qualified Text.PrettyPrint.Boxes as Box newtype ErrorSuggestion = ErrorSuggestion Text -- | Get the source span for an error -errorSpan :: ErrorMessage -> Maybe SourceSpan +errorSpan :: ErrorMessage -> Maybe (NEL.NonEmpty SourceSpan) errorSpan = findHint matchSpan where matchSpan (PositionedError ss) = Just ss @@ -195,7 +195,7 @@ errorMessage err = MultipleErrors [ErrorMessage [] err] -- | Create an error set from a single simple error message and source annotation errorMessage' :: SourceSpan -> SimpleErrorMessage -> MultipleErrors -errorMessage' ss err = MultipleErrors [ErrorMessage [PositionedError ss] err] +errorMessage' ss err = MultipleErrors [ErrorMessage [positionedError ss] err] -- | Create an error set from a single error message singleError :: ErrorMessage -> MultipleErrors @@ -327,7 +327,10 @@ errorSuggestion err = suggestionSpan :: ErrorMessage -> Maybe SourceSpan suggestionSpan e = - getSpan (unwrapErrorMessage e) <$> errorSpan e + -- The `NEL.head` is a bit arbitrary here, but I don't think we'll + -- have errors-with-suggestions that also have multiple source + -- spans. -garyb + getSpan (unwrapErrorMessage e) . NEL.head <$> errorSpan e where startOnly SourceSpan{spanName, spanStart} = SourceSpan {spanName, spanStart, spanEnd = spanStart} @@ -1108,7 +1111,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] ] renderHint (PositionedError srcSpan) detail = - paras [ line $ "at " <> displaySourceSpan relPath srcSpan + paras [ line $ "at " <> displaySourceSpan relPath (NEL.head srcSpan) , detail ] @@ -1393,7 +1396,10 @@ warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter Multiple warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage -withPosition pos (ErrorMessage hints se) = ErrorMessage (PositionedError pos : hints) se +withPosition pos (ErrorMessage hints se) = ErrorMessage (positionedError pos : hints) se + +positionedError :: SourceSpan -> ErrorMessageHint +positionedError = PositionedError . pure -- | Runs a computation listening for warnings and then escalating any warnings -- that match the predicate to error status. diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index d013235011..65f872d23b 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -5,6 +5,7 @@ module Language.PureScript.Errors.JSON where import Prelude.Compat import qualified Data.Aeson.TH as A +import qualified Data.List.NonEmpty as NEL import Data.Monoid ((<>)) import qualified Data.Text as T import Data.Text (Text) @@ -31,6 +32,7 @@ data JSONError = JSONError , filename :: Maybe String , moduleName :: Maybe Text , suggestion :: Maybe ErrorSuggestion + , allSpans :: [P.SourceSpan] } deriving (Show, Eq) data JSONResult = JSONResult @@ -43,22 +45,22 @@ $(A.deriveJSON A.defaultOptions ''JSONError) $(A.deriveJSON A.defaultOptions ''JSONResult) $(A.deriveJSON A.defaultOptions ''ErrorSuggestion) - toJSONErrors :: Bool -> P.Level -> P.MultipleErrors -> [JSONError] toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErrors toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError toJSONError verbose level e = - JSONError (toErrorPosition <$> sspan) + JSONError (toErrorPosition <$> fmap NEL.head spans) (P.renderBox (P.prettyPrintSingleError (P.PPEOptions Nothing verbose level False mempty) (P.stripModuleAndSpan e))) (P.errorCode e) (P.errorDocUri e) - (P.spanName <$> sspan) + (P.spanName <$> fmap NEL.head spans) (P.runModuleName <$> P.errorModule e) (toSuggestion e) + (maybe [] NEL.toList spans) where - sspan :: Maybe P.SourceSpan - sspan = P.errorSpan e + spans :: Maybe (NEL.NonEmpty P.SourceSpan) + spans = P.errorSpan e toErrorPosition :: P.SourceSpan -> ErrorPosition toErrorPosition ss = diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 0486696220..71ecd20cc9 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -351,7 +351,7 @@ parseModuleFromFile toFilePath (k, content) = do -- | Converts a 'ParseError' into a 'PositionedError' toPositionedError :: P.ParseError -> ErrorMessage -toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr) +toPositionedError perr = ErrorMessage [ positionedError (SourceSpan name start end) ] (ErrorParsingModule perr) where name = (P.sourceName . P.errorPos) perr start = (toSourcePos . P.errorPos) perr diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 9ec8c0960a..9cd3500098 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -233,7 +233,7 @@ typeCheckAll moduleName _ = traverse go where go :: Declaration -> m Declaration go (DataDeclaration sa@(ss, _) dtype name args dctors) = do - warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (PositionedError ss)) $ do + warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (positionedError ss)) $ do when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args ctorKind <- kindsOf True moduleName name args (concatMap snd dctors) @@ -263,7 +263,7 @@ typeCheckAll moduleName _ = traverse go toDataDecl (DataDeclaration _ dtype nm args dctors) = Just (dtype, nm, args, dctors) toDataDecl _ = Nothing go (TypeSynonymDeclaration sa@(ss, _) name args ty) = do - warnAndRethrow (addHint (ErrorInTypeSynonym name) . addHint (PositionedError ss) ) $ do + warnAndRethrow (addHint (ErrorInTypeSynonym name) . addHint (positionedError ss) ) $ do checkDuplicateTypeArguments $ map fst args kind <- kindsOf False moduleName name args [ty] let args' = args `withKinds` kind @@ -273,7 +273,7 @@ typeCheckAll moduleName _ = traverse go internalError "Type declarations should have been removed before typeCheckAlld" go (ValueDecl sa@(ss, _) name nameKind [] [MkUnguarded val]) = do env <- getEnv - warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (PositionedError ss)) $ do + warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (positionedError ss)) $ do val' <- checkExhaustiveExpr ss env moduleName val valueIsNotDefined moduleName name [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] @@ -304,7 +304,7 @@ typeCheckAll moduleName _ = traverse go putEnv $ env { kinds = S.insert (Qualified (Just moduleName) name) (kinds env) } return d go (d@(ExternDeclaration (ss, _) name ty)) = do - warnAndRethrow (addHint (ErrorInForeignImport name) . addHint (PositionedError ss)) $ do + warnAndRethrow (addHint (ErrorInForeignImport name) . addHint (positionedError ss)) $ do env <- getEnv kind <- kindOf ty guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType @@ -315,7 +315,7 @@ typeCheckAll moduleName _ = traverse go go d@FixityDeclaration{} = return d go d@ImportDeclaration{} = return d go d@(TypeClassDeclaration (ss, _) pn args implies deps tys) = do - warnAndRethrow (addHint (ErrorInTypeClassDeclaration pn) . addHint (PositionedError ss)) $ do + warnAndRethrow (addHint (ErrorInTypeClassDeclaration pn) . addHint (positionedError ss)) $ do env <- getEnv let qualifiedClassName = Qualified (Just moduleName) pn guardWith (errorMessage (DuplicateTypeClass pn ss)) $ @@ -323,7 +323,7 @@ typeCheckAll moduleName _ = traverse go addTypeClass qualifiedClassName args implies deps tys return d go (d@(TypeInstanceDeclaration (ss, _) ch idx dictName deps className tys body)) = - rethrow (addHint (ErrorInInstance className tys) . addHint (PositionedError ss)) $ do + rethrow (addHint (ErrorInInstance className tys) . addHint (positionedError ss)) $ do env <- getEnv let qualifiedDictName = Qualified (Just moduleName) dictName flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries -> @@ -568,4 +568,3 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = extractMemberName (TypeDeclaration td) = tydeclIdent td extractMemberName _ = internalError "Unexpected declaration in typeclass member list" checkClassMembersAreExported _ = return () - diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 4fee1b8586..c8ecc791c2 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -127,7 +127,7 @@ rethrowWithPositionTC => SourceSpan -> m a -> m a -rethrowWithPositionTC pos = withErrorMessageHint (PositionedError pos) +rethrowWithPositionTC pos = withErrorMessageHint (positionedError pos) warnAndRethrowWithPositionTC :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 0b6ef54537..f80d87e177 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -100,7 +100,7 @@ skolemEscapeCheck expr@TypedValue{} = go (scopes, _) (PositionedValue ss _ _) = ((scopes, Just ss), []) go (scopes, ssUsed) val@(TypedValue _ _ ty) = ( (allScopes, ssUsed) - , [ ErrorMessage (maybe id ((:) . PositionedError) ssUsed [ ErrorInExpression val ]) $ + , [ ErrorMessage (maybe id ((:) . positionedError) ssUsed [ ErrorInExpression val ]) $ EscapedSkolem name ssBound ty | (name, scope, ssBound) <- collectSkolems ty , notMember scope allScopes From 80c671e7a0c1dd9f50cf1b77e5cdc655e14876de Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 11 Mar 2018 13:49:24 +0000 Subject: [PATCH 0937/1580] Error positions for FFI related errors (#3276) * Add source span for UnnecessaryFFIModule * Add source spans for more FFI warnings * Add error test for MissingFFIImplementations --- examples/failing/MissingFFIImplementations.js | 1 + .../failing/MissingFFIImplementations.purs | 5 +++++ src/Language/PureScript/Ide/Rebuild.hs | 2 +- src/Language/PureScript/Make.hs | 20 +++++++++---------- 4 files changed, 17 insertions(+), 11 deletions(-) create mode 100644 examples/failing/MissingFFIImplementations.js create mode 100644 examples/failing/MissingFFIImplementations.purs diff --git a/examples/failing/MissingFFIImplementations.js b/examples/failing/MissingFFIImplementations.js new file mode 100644 index 0000000000..d29ee4cff9 --- /dev/null +++ b/examples/failing/MissingFFIImplementations.js @@ -0,0 +1 @@ +exports.yes = true; diff --git a/examples/failing/MissingFFIImplementations.purs b/examples/failing/MissingFFIImplementations.purs new file mode 100644 index 0000000000..1f47ef841b --- /dev/null +++ b/examples/failing/MissingFFIImplementations.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith MissingFFIImplementations +module Main where + +foreign import yes :: Boolean +foreign import no :: Boolean diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index c4f4b204a8..6604e2de33 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -158,7 +158,7 @@ shushProgress ma _ = -- files though) shushCodegen :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make shushCodegen ma MakeActionsEnv{..} = - ma { P.codegen = \_ _ _ -> pure () } + ma { P.codegen = \_ _ _ _ -> pure () } -- | Returns a topologically sorted list of dependent ExternsFiles for the given -- module. Throws an error if there is a cyclic dependency within the diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 3031dc315c..12e68ec315 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -108,7 +108,7 @@ data MakeActions m = MakeActions , readExterns :: ModuleName -> m (FilePath, Externs) -- ^ Read the externs file for a module as a string and also return the actual -- path for the file. - , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m () + , codegen :: SourceSpan -> CF.Module CF.Ann -> Environment -> Externs -> SupplyT m () -- ^ Run the code generator for the module and write any required output files. , progress :: ProgressMessage -> m () -- ^ Respond to a progress update. @@ -154,7 +154,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do corefn = CF.moduleToCoreFn env' mod' [renamed] = renameInModules [corefn] exts = moduleToExternsFile mod' env' - evalSupplyT nextVar' . codegen renamed env' . encode $ exts + evalSupplyT nextVar' . codegen ss renamed env' . encode $ exts return exts -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.json@ file. @@ -344,16 +344,16 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = let path = outputDir T.unpack (runModuleName mn) "externs.json" (path, ) <$> readTextFile path - codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make () - codegen m _ exts = do + codegen :: SourceSpan -> CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make () + codegen modSS m _ exts = do let mn = CF.moduleName m foreignInclude <- case mn `M.lookup` foreigns of Just path | not $ requiresForeign m -> do - tell $ errorMessage $ UnnecessaryFFIModule mn path + tell $ errorMessage' modSS $ UnnecessaryFFIModule mn path return Nothing | otherwise -> do - checkForeignDecls m path + checkForeignDecls modSS m path return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign"] Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn | otherwise -> return Nothing @@ -425,8 +425,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = -- | Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module. -checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make () -checkForeignDecls m path = do +checkForeignDecls :: SourceSpan -> CF.Module ann -> FilePath -> SupplyT Make () +checkForeignDecls modSS m path = do jsStr <- lift $ readTextFile path js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse (BU8.toString (B.toStrict jsStr)) path @@ -439,12 +439,12 @@ checkForeignDecls m path = do let unusedFFI = foreignIdents S.\\ importedIdents unless (null unusedFFI) $ - tell . errorMessage . UnusedFFIImplementations mname $ + tell . errorMessage' modSS . UnusedFFIImplementations mname $ S.toList unusedFFI let missingFFI = importedIdents S.\\ foreignIdents unless (null missingFFI) $ - throwError . errorMessage . MissingFFIImplementations mname $ + throwError . errorMessage' modSS . MissingFFIImplementations mname $ S.toList missingFFI where From 96ccf1ebb69de3425d89cf711e7e6cc66dc89aed Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 11 Mar 2018 14:18:02 +0000 Subject: [PATCH 0938/1580] Take advantage of multi-span errors (#3273) * Take advantage of multi-span errors This fixes `CycleInModule ` not having many positions, and adds all positions for `DuplicateModule` using the usual form rather than special handling * Work around Data.Graph not using NELs --- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Errors.hs | 10 ++++++---- src/Language/PureScript/Make.hs | 11 ++++++----- src/Language/PureScript/ModuleDependencies.hs | 7 ++++--- 4 files changed, 17 insertions(+), 13 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index adc8f95c54..2657079567 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -93,7 +93,7 @@ data SimpleErrorMessage | ScopeShadowing Name (Maybe ModuleName) [ModuleName] | DeclConflict Name Name | ExportConflict (Qualified Name) (Qualified Name) - | DuplicateModule ModuleName [SourceSpan] + | DuplicateModule ModuleName | DuplicateTypeClass (ProperName 'ClassName) SourceSpan | DuplicateInstance Ident SourceSpan | DuplicateTypeArgument Text diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index f9c40519ff..86869d7f0b 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -197,6 +197,10 @@ errorMessage err = MultipleErrors [ErrorMessage [] err] errorMessage' :: SourceSpan -> SimpleErrorMessage -> MultipleErrors errorMessage' ss err = MultipleErrors [ErrorMessage [positionedError ss] err] +-- | Create an error set from a single simple error message and source annotations +errorMessage'' :: NEL.NonEmpty SourceSpan -> SimpleErrorMessage -> MultipleErrors +errorMessage'' sss err = MultipleErrors [ErrorMessage [PositionedError sss] err] + -- | Create an error set from a single error message singleError :: ErrorMessage -> MultipleErrors singleError = MultipleErrors . pure @@ -537,10 +541,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "Declaration for " <> printName (Qualified Nothing new) <> " conflicts with an existing " <> nameType existing <> " of the same name." renderSimpleErrorMessage (ExportConflict new existing) = line $ "Export for " <> printName new <> " conflicts with " <> runName existing - renderSimpleErrorMessage (DuplicateModule mn ss) = - paras [ line ("Module " <> markCode (runModuleName mn) <> " has been defined multiple times:") - , indent . paras $ map (line . displaySourceSpan relPath) ss - ] + renderSimpleErrorMessage (DuplicateModule mn) = + line $ "Module " <> markCode (runModuleName mn) <> " has been defined multiple times" renderSimpleErrorMessage (DuplicateTypeClass pn ss) = paras [ line ("Type class " <> markCode (runProperName pn) <> " has been defined multiple times:") , indent $ line $ displaySourceSpan relPath ss diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 12e68ec315..3609fc2cc2 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -38,7 +38,8 @@ import Data.Aeson (encode, decode) import Data.Either (partitionEithers) import Data.Function (on) import Data.Foldable (for_) -import Data.List (foldl', sortBy, groupBy) +import Data.List (foldl', sortBy) +import qualified Data.List.NonEmpty as NEL import Data.Maybe (fromMaybe, catMaybes) import Data.Monoid ((<>)) import Data.Time.Clock @@ -191,13 +192,13 @@ make ma@MakeActions{..} ms = do checkModuleNamesAreUnique = for_ (findDuplicates getModuleName ms) $ \mss -> throwError . flip foldMap mss $ \ms' -> - let mn = getModuleName (head ms') - in errorMessage $ DuplicateModule mn (map getModuleSourceSpan ms') + let mn = getModuleName (NEL.head ms') + in errorMessage'' (fmap getModuleSourceSpan ms') $ DuplicateModule mn -- Find all groups of duplicate values in a list based on a projection. - findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [[a]] + findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [NEL.NonEmpty a] findDuplicates f xs = - case filter ((> 1) . length) . groupBy ((==) `on` f) . sortBy (compare `on` f) $ xs of + case filter ((> 1) . length) . NEL.groupBy ((==) `on` f) . sortBy (compare `on` f) $ xs of [] -> Nothing xss -> Just xss diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index a270c3eba4..485174ed67 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -7,7 +7,7 @@ module Language.PureScript.ModuleDependencies import Protolude hiding (head) import Data.Graph -import Data.List (head) +import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.Set as S import Language.PureScript.AST import qualified Language.PureScript.Constants as C @@ -59,8 +59,9 @@ usedModules _ = Nothing -- | Convert a strongly connected component of the module graph to a module toModule :: MonadError MultipleErrors m => SCC Module -> m Module toModule (AcyclicSCC m) = return m +toModule (CyclicSCC []) = internalError "toModule: empty CyclicSCC" toModule (CyclicSCC [m]) = return m -toModule (CyclicSCC ms) = +toModule (CyclicSCC (m : ms)) = throwError - . errorMessage' (getModuleSourceSpan (head ms)) + . errorMessage'' (fmap getModuleSourceSpan (m :| ms)) $ CycleInModules (map getModuleName ms) From 9a4992a110056c9c41751cccea1d92808d2997bc Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 11 Mar 2018 14:23:43 +0000 Subject: [PATCH 0939/1580] Add source spans for literals (#3277) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Add source spans for literals This fixes the IntOutOfRange error (again 😄) * Don't parenthesise flipped constructors --- src/Language/PureScript/AST/Binders.hs | 8 +-- src/Language/PureScript/AST/Declarations.hs | 4 +- src/Language/PureScript/AST/Traversals.hs | 28 +++++------ src/Language/PureScript/CodeGen/JS.hs | 18 +++---- src/Language/PureScript/CoreFn/Desugar.hs | 8 +-- src/Language/PureScript/Interactive.hs | 2 +- src/Language/PureScript/Linter/Exhaustive.hs | 18 +++---- .../PureScript/Parser/Declarations.hs | 34 +++++++------ src/Language/PureScript/Pretty/Values.hs | 6 +-- .../PureScript/Sugar/CaseDeclarations.hs | 6 +-- .../PureScript/Sugar/ObjectWildcards.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 4 +- .../PureScript/TypeChecker/Entailment.hs | 10 ++-- src/Language/PureScript/TypeChecker/Types.hs | 50 +++++++++---------- 15 files changed, 101 insertions(+), 99 deletions(-) diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index e7bbd29fbb..dd31894b52 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -24,7 +24,7 @@ data Binder -- | -- A binder which matches a literal -- - | LiteralBinder (Literal Binder) + | LiteralBinder SourceSpan (Literal Binder) -- | -- A binder which binds an identifier -- @@ -76,7 +76,7 @@ instance Eq Binder where (==) NullBinder NullBinder = True (==) NullBinder _ = False - (==) (LiteralBinder lb) (LiteralBinder lb') = (==) lb lb' + (==) (LiteralBinder _ lb) (LiteralBinder _ lb') = (==) lb lb' (==) LiteralBinder{} _ = False (==) (VarBinder _ ident) (VarBinder _ ident') = (==) ident ident' @@ -114,7 +114,7 @@ instance Ord Binder where compare NullBinder NullBinder = EQ compare NullBinder _ = LT - compare (LiteralBinder lb) (LiteralBinder lb') = compare lb lb' + compare (LiteralBinder _ lb) (LiteralBinder _ lb') = compare lb lb' compare LiteralBinder{} NullBinder = GT compare LiteralBinder{} _ = LT @@ -174,7 +174,7 @@ instance Ord Binder where binderNames :: Binder -> [Ident] binderNames = go [] where - go ns (LiteralBinder b) = lit ns b + go ns (LiteralBinder _ b) = lit ns b go ns (VarBinder _ name) = name : ns go ns (ConstructorBinder _ _ bs) = foldl go ns bs go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3] diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 2657079567..0ca9ddff51 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -697,7 +697,7 @@ data Expr -- | -- A literal value -- - = Literal (Literal Expr) + = Literal SourceSpan (Literal Expr) -- | -- A prefix -, will be desugared -- @@ -886,7 +886,7 @@ $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Declarat $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType) isTrueExpr :: Expr -> Bool -isTrueExpr (Literal (BooleanLiteral True)) = True +isTrueExpr (Literal _ (BooleanLiteral True)) = True isTrueExpr (Var _ (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True isTrueExpr (Var _ (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True isTrueExpr (TypedValue _ e _) = isTrueExpr e diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 88f87eca54..a7c8297e91 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -62,7 +62,7 @@ everywhereOnValues f g h = (f', g', h') f' other = f other g' :: Expr -> Expr - g' (Literal l) = g (Literal (lit g' l)) + g' (Literal ss l) = g (Literal ss (lit g' l)) g' (UnaryMinus ss v) = g (UnaryMinus ss (g' v)) g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2)) g' (Parens v) = g (Parens (g' v)) @@ -85,7 +85,7 @@ everywhereOnValues f g h = (f', g', h') h' (ConstructorBinder ss ctor bs) = h (ConstructorBinder ss ctor (fmap h' bs)) h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3)) h' (ParensInBinder b) = h (ParensInBinder (h' b)) - h' (LiteralBinder l) = h (LiteralBinder (lit h' l)) + h' (LiteralBinder ss l) = h (LiteralBinder ss (lit h' l)) h' (NamedBinder ss name b) = h (NamedBinder ss name (h' b)) h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b)) h' (TypedBinder t b) = h (TypedBinder t (h' b)) @@ -136,7 +136,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) f' other = f other g' :: Expr -> m Expr - g' (Literal l) = Literal <$> litM (g >=> g') l + g' (Literal ss l) = Literal ss <$> litM (g >=> g') l g' (UnaryMinus ss v) = UnaryMinus ss <$> (g v >>= g') g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g') g' (Parens v) = Parens <$> (g v >>= g') @@ -156,7 +156,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' other = g other h' :: Binder -> m Binder - h' (LiteralBinder l) = LiteralBinder <$> litM (h >=> h') l + h' (LiteralBinder ss l) = LiteralBinder ss <$> litM (h >=> h') l h' (ConstructorBinder ss ctor bs) = ConstructorBinder ss ctor <$> traverse (h' <=< h) bs h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h') h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h') @@ -205,7 +205,7 @@ everywhereOnValuesM f g h = (f', g', h') f' other = f other g' :: Expr -> m Expr - g' (Literal l) = (Literal <$> litM g' l) >>= g + g' (Literal ss l) = (Literal ss <$> litM g' l) >>= g g' (UnaryMinus ss v) = (UnaryMinus ss <$> g' v) >>= g g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g g' (Parens v) = (Parens <$> g' v) >>= g @@ -225,7 +225,7 @@ everywhereOnValuesM f g h = (f', g', h') g' other = g other h' :: Binder -> m Binder - h' (LiteralBinder l) = (LiteralBinder <$> litM h' l) >>= h + h' (LiteralBinder ss l) = (LiteralBinder ss <$> litM h' l) >>= h h' (ConstructorBinder ss ctor bs) = (ConstructorBinder ss ctor <$> traverse h' bs) >>= h h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h @@ -277,7 +277,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') f' d = f d g' :: Expr -> r - g' v@(Literal l) = lit (g v) g' l + g' v@(Literal _ l) = lit (g v) g' l g' v@(UnaryMinus _ v1) = g v <> g' v1 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2 g' v@(Parens v1) = g v <> g' v1 @@ -297,7 +297,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') g' v = g v h' :: Binder -> r - h' b@(LiteralBinder l) = lit (h b) h' l + h' b@(LiteralBinder _ l) = lit (h b) h' l h' b@(ConstructorBinder _ _ bs) = foldl (<>) (h b) (fmap h' bs) h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3 h' b@(ParensInBinder b1) = h b <> h' b1 @@ -358,7 +358,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' g'' s v = let (s', r) = g s v in r <> g' s' v g' :: s -> Expr -> r - g' s (Literal l) = lit g'' s l + g' s (Literal _ l) = lit g'' s l g' s (UnaryMinus _ v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 g' s (Parens v1) = g'' s v1 @@ -381,7 +381,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' h'' s b = let (s', r) = h s b in r <> h' s' b h' :: s -> Binder -> r - h' s (LiteralBinder l) = lit h'' s l + h' s (LiteralBinder _ l) = lit h'' s l h' s (ConstructorBinder _ _ bs) = foldl (<>) r0 (fmap (h'' s) bs) h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3 h' s (ParensInBinder b) = h'' s b @@ -443,7 +443,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g'' s = uncurry g' <=< g s - g' s (Literal l) = Literal <$> lit g'' s l + g' s (Literal ss l) = Literal ss <$> lit g'' s l g' s (UnaryMinus ss v) = UnaryMinus ss <$> g'' s v g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2 g' s (Parens v) = Parens <$> g'' s v @@ -464,7 +464,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j h'' s = uncurry h' <=< h s - h' s (LiteralBinder l) = LiteralBinder <$> lit h'' s l + h' s (LiteralBinder ss l) = LiteralBinder ss <$> lit h'' s l h' s (ConstructorBinder ss ctor bs) = ConstructorBinder ss ctor <$> traverse (h'' s) bs h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3 h' s (ParensInBinder b) = ParensInBinder <$> h'' s b @@ -533,7 +533,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g'' s a = g s a <> g' s a g' :: S.Set Ident -> Expr -> r - g' s (Literal l) = lit g'' s l + g' s (Literal _ l) = lit g'' s l g' s (UnaryMinus _ v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 g' s (Parens v1) = g'' s v1 @@ -562,7 +562,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) h'' s a = h s a <> h' s a h' :: S.Set Ident -> Binder -> r - h' s (LiteralBinder l) = lit h'' s l + h' s (LiteralBinder _ l) = lit h'' s l h' s (ConstructorBinder _ _ bs) = foldMap (h'' s) bs h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3] h' s (ParensInBinder b) = h'' s b diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 4cf389f76b..bad739c11e 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -177,7 +177,7 @@ moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ = valueToJs' :: Expr Ann -> m AST valueToJs' (Literal (pos, _, _, _) l) = - rethrowWithPosition pos $ literalToValueJS l + rethrowWithPosition pos $ literalToValueJS pos l valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) = return $ accessorString "value" $ qualifiedToJS id name valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) = @@ -255,14 +255,14 @@ moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ = iife :: Text -> [AST] -> AST iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) [] - literalToValueJS :: Literal (Expr Ann) -> m AST - literalToValueJS (NumericLiteral (Left i)) = return $ AST.NumericLiteral Nothing (Left i) - literalToValueJS (NumericLiteral (Right n)) = return $ AST.NumericLiteral Nothing (Right n) - literalToValueJS (StringLiteral s) = return $ AST.StringLiteral Nothing s - literalToValueJS (CharLiteral c) = return $ AST.StringLiteral Nothing (fromString [c]) - literalToValueJS (BooleanLiteral b) = return $ AST.BooleanLiteral Nothing b - literalToValueJS (ArrayLiteral xs) = AST.ArrayLiteral Nothing <$> mapM valueToJs xs - literalToValueJS (ObjectLiteral ps) = AST.ObjectLiteral Nothing <$> mapM (sndM valueToJs) ps + literalToValueJS :: SourceSpan -> Literal (Expr Ann) -> m AST + literalToValueJS ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i) + literalToValueJS ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n) + literalToValueJS ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s + literalToValueJS ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c]) + literalToValueJS ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b + literalToValueJS ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToJs xs + literalToValueJS ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToJs) ps -- | Shallow copy an object. extendObj :: AST -> [(PSString, AST)] -> m AST diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index decef9f1f7..c28f8c8120 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -73,7 +73,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = -- | Desugars expressions from AST to CoreFn representation. exprToCoreFn :: SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann - exprToCoreFn ss com ty (A.Literal lit) = + exprToCoreFn _ com ty (A.Literal ss lit) = Literal (ss, com, ty, Nothing) (fmap (exprToCoreFn ss com Nothing) lit) exprToCoreFn ss com ty (A.Accessor name v) = Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) @@ -101,9 +101,9 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = exprToCoreFn ss com (Just ty) v exprToCoreFn ss com ty (A.Let ds v) = Let (ss, com, ty, Nothing) (concatMap declToCoreFn ds) (exprToCoreFn ss [] Nothing v) - exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal (A.ObjectLiteral _)) _)) = + exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal _ (A.ObjectLiteral _)) _)) = exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name lit) - exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal (A.ObjectLiteral vs))) = + exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal _ (A.ObjectLiteral vs))) = let args = fmap (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name) in foldl (App (ss, com, Nothing, Nothing)) ctor args @@ -133,7 +133,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = -- | Desugars case binders from AST to CoreFn representation. binderToCoreFn :: SourceSpan -> [Comment] -> A.Binder -> Binder Ann - binderToCoreFn ss com (A.LiteralBinder lit) = + binderToCoreFn _ com (A.LiteralBinder ss lit) = LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit) binderToCoreFn ss com A.NullBinder = NullBinder (ss, com, Nothing, Nothing) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index facde9e992..61782de7d3 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -167,7 +167,7 @@ handleDecls -> m () handleDecls ds = do st <- gets (updateLets (++ ds)) - let m = createTemporaryModule False st (P.Literal (P.ObjectLiteral [])) + let m = createTemporaryModule False st (P.Literal P.nullSourceSpan (P.ObjectLiteral [])) e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m case e of Left err -> printErrors err diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 53615b8aec..179497db47 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -126,12 +126,12 @@ missingCasesSingle env mn NullBinder cb@(ConstructorBinder ss con _) = missingCasesSingle env mn cb@(ConstructorBinder ss con bs) (ConstructorBinder _ con' bs') | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder ss con) bs'', pr) | otherwise = ([cb], return False) -missingCasesSingle env mn NullBinder (LiteralBinder (ObjectLiteral bs)) = - (map (LiteralBinder . ObjectLiteral . zip (map fst bs)) allMisses, pr) +missingCasesSingle env mn NullBinder (LiteralBinder ss (ObjectLiteral bs)) = + (map (LiteralBinder ss . ObjectLiteral . zip (map fst bs)) allMisses, pr) where (allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs) -missingCasesSingle env mn (LiteralBinder (ObjectLiteral bs)) (LiteralBinder (ObjectLiteral bs')) = - (map (LiteralBinder . ObjectLiteral . zip sortedNames) allMisses, pr) +missingCasesSingle env mn (LiteralBinder _ (ObjectLiteral bs)) (LiteralBinder ss (ObjectLiteral bs')) = + (map (LiteralBinder ss . ObjectLiteral . zip sortedNames) allMisses, pr) where (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders) @@ -148,10 +148,10 @@ missingCasesSingle env mn (LiteralBinder (ObjectLiteral bs)) (LiteralBinder (Obj compBS e s b b' = (s, compB e b b') (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs' -missingCasesSingle _ _ NullBinder (LiteralBinder (BooleanLiteral b)) = ([LiteralBinder . BooleanLiteral $ not b], return True) -missingCasesSingle _ _ (LiteralBinder (BooleanLiteral bl)) (LiteralBinder (BooleanLiteral br)) +missingCasesSingle _ _ NullBinder (LiteralBinder ss (BooleanLiteral b)) = ([LiteralBinder ss . BooleanLiteral $ not b], return True) +missingCasesSingle _ _ (LiteralBinder ss (BooleanLiteral bl)) (LiteralBinder _ (BooleanLiteral br)) | bl == br = ([], return True) - | otherwise = ([LiteralBinder $ BooleanLiteral bl], return False) + | otherwise = ([LiteralBinder ss $ BooleanLiteral bl], return False) missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb missingCasesSingle _ _ b _ = ([b], Left Unknown) @@ -337,8 +337,8 @@ checkExhaustiveExpr initSS env mn = onExpr initSS onExpr :: SourceSpan -> Expr -> m Expr onExpr _ (UnaryMinus ss e) = UnaryMinus ss <$> onExpr ss e - onExpr ss (Literal (ArrayLiteral es)) = Literal . ArrayLiteral <$> mapM (onExpr ss) es - onExpr ss (Literal (ObjectLiteral es)) = Literal . ObjectLiteral <$> mapM (sndM (onExpr ss)) es + onExpr _ (Literal ss (ArrayLiteral es)) = Literal ss . ArrayLiteral <$> mapM (onExpr ss) es + onExpr _ (Literal ss (ObjectLiteral es)) = Literal ss . ObjectLiteral <$> mapM (sndM (onExpr ss)) es onExpr ss (TypeClassDictionaryConstructorApp x e) = TypeClassDictionaryConstructorApp x <$> onExpr ss e onExpr ss (Accessor x e) = Accessor x <$> onExpr ss e onExpr ss (ObjectUpdate o es) = ObjectUpdate <$> onExpr ss o <*> mapM (sndM (onExpr ss)) es diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 71ecd20cc9..1e84c952f1 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -438,12 +438,12 @@ parseLet = do parseValueAtom :: TokenParser Expr parseValueAtom = withSourceSpan PositionedValue $ P.choice [ parseAnonymousArgument - , Literal <$> parseNumericLiteral - , Literal <$> parseCharLiteral - , Literal <$> parseStringLiteral - , Literal <$> parseBooleanLiteral - , Literal <$> parseArrayLiteral parseValue - , Literal <$> parseObjectLiteral parseIdentifierAndValue + , withSourceSpan' Literal $ parseNumericLiteral + , withSourceSpan' Literal $ parseCharLiteral + , withSourceSpan' Literal $ parseStringLiteral + , withSourceSpan' Literal $ parseBooleanLiteral + , withSourceSpan' Literal $ parseArrayLiteral parseValue + , withSourceSpan' Literal $ parseObjectLiteral parseIdentifierAndValue , parseAbs , P.try parseConstructor , P.try parseVar @@ -551,7 +551,8 @@ parseAnonymousArgument :: TokenParser Expr parseAnonymousArgument = underscore *> pure AnonymousArgument parseNumberLiteral :: TokenParser Binder -parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number) +parseNumberLiteral = withSourceSpanF $ + (\n ss -> LiteralBinder ss (NumericLiteral n)) <$> (sign <*> number) where sign :: TokenParser (Either Integer Double -> Either Integer Double) sign = (symbol' "-" >> return (negate +++ negate)) @@ -570,8 +571,8 @@ parseConstructorBinder = withSourceSpanF $ <*> many (indented *> parseBinderNoParens) parseObjectBinder:: TokenParser Binder -parseObjectBinder = - LiteralBinder <$> parseObjectLiteral (indented *> parseEntry) +parseObjectBinder = withSourceSpanF $ + flip LiteralBinder <$> parseObjectLiteral (indented *> parseEntry) where parseEntry :: TokenParser (PSString, Binder) parseEntry = var <|> (,) <$> stringLiteral <*> rest @@ -583,7 +584,8 @@ parseObjectBinder = rest = indented *> colon *> indented *> parseBinder parseArrayBinder :: TokenParser Binder -parseArrayBinder = LiteralBinder <$> parseArrayLiteral (indented *> parseBinder) +parseArrayBinder = withSourceSpanF $ + flip LiteralBinder <$> parseArrayLiteral (indented *> parseBinder) parseVarOrNamedBinder :: TokenParser Binder parseVarOrNamedBinder = withSourceSpanF $ do @@ -619,9 +621,9 @@ parseBinderAtom :: TokenParser Binder parseBinderAtom = withSourceSpan PositionedBinder (P.choice [ parseNullBinder - , LiteralBinder <$> parseCharLiteral - , LiteralBinder <$> parseStringLiteral - , LiteralBinder <$> parseBooleanLiteral + , withSourceSpanF $ flip LiteralBinder <$> parseCharLiteral + , withSourceSpanF $ flip LiteralBinder <$> parseStringLiteral + , withSourceSpanF $ flip LiteralBinder <$> parseBooleanLiteral , parseNumberLiteral , parseVarOrNamedBinder , parseConstructorBinder @@ -635,9 +637,9 @@ parseBinderNoParens :: TokenParser Binder parseBinderNoParens = withSourceSpan PositionedBinder (P.choice [ parseNullBinder - , LiteralBinder <$> parseCharLiteral - , LiteralBinder <$> parseStringLiteral - , LiteralBinder <$> parseBooleanLiteral + , withSourceSpanF $ flip LiteralBinder <$> parseCharLiteral + , withSourceSpanF $ flip LiteralBinder <$> parseStringLiteral + , withSourceSpanF $ flip LiteralBinder <$> parseBooleanLiteral , parseNumberLiteral , parseVarOrNamedBinder , parseNullaryConstructorBinder diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 82832c0cb1..89dc52f875 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -87,7 +87,7 @@ prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = text "#dict-accessor " <> text (T.unpack (runProperName (disqualify className))) <> text "." <> text (T.unpack (showIdent ident)) <> text ">" prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val -prettyPrintValue d (Literal l) = prettyPrintLiteralValue d l +prettyPrintValue d (Literal _ l) = prettyPrintLiteralValue d l prettyPrintValue _ (Hole name) = text "?" <> textT name prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr @@ -99,7 +99,7 @@ prettyPrintValue d expr@UnaryMinus{} = prettyPrintValueAtom d expr -- | Pretty-print an atomic expression, adding parentheses if necessary. prettyPrintValueAtom :: Int -> Expr -> Box -prettyPrintValueAtom d (Literal l) = prettyPrintLiteralValue d l +prettyPrintValueAtom d (Literal _ l) = prettyPrintLiteralValue d l prettyPrintValueAtom _ AnonymousArgument = text "_" prettyPrintValueAtom _ (Constructor _ name) = text $ T.unpack $ runProperName (disqualify name) prettyPrintValueAtom _ (Var _ ident) = text $ T.unpack $ showIdent (disqualify ident) @@ -185,7 +185,7 @@ prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrin prettyPrintBinderAtom :: Binder -> Text prettyPrintBinderAtom NullBinder = "_" -prettyPrintBinderAtom (LiteralBinder l) = prettyPrintLiteralBinder l +prettyPrintBinderAtom (LiteralBinder _ l) = prettyPrintLiteralBinder l prettyPrintBinderAtom (VarBinder _ ident) = showIdent ident prettyPrintBinderAtom (ConstructorBinder _ ctor []) = runProperName (disqualify ctor) prettyPrintBinderAtom b@ConstructorBinder{} = parensT (prettyPrintBinder b) diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 5c7eb0edcc..7598bedac7 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -71,7 +71,7 @@ desugarGuardedExprs ss (Case scrut alternatives) Let scrut_decls <$> desugarGuardedExprs ss (Case scrut' alternatives) where isTrivialExpr (Var _ _) = True - isTrivialExpr (Literal _) = True + isTrivialExpr (Literal _ _) = True isTrivialExpr (Accessor _ e) = isTrivialExpr e isTrivialExpr (Parens e) = isTrivialExpr e isTrivialExpr (PositionedValue _ _ e) = isTrivialExpr e @@ -196,7 +196,7 @@ desugarGuardedExprs ss (Case scrut alternatives) = | isTrueExpr c = desugarGuard gs e match_failed | otherwise = Case [c] - (CaseAlternative [LiteralBinder (BooleanLiteral True)] + (CaseAlternative [LiteralBinder ss (BooleanLiteral True)] [MkUnguarded (desugarGuard gs e match_failed)] : match_failed) desugarGuard (PatternGuard vb g : gs) e match_failed = @@ -227,7 +227,7 @@ desugarGuardedExprs ss (Case scrut alternatives) = let goto_rem_case :: Expr goto_rem_case = Var ss (Qualified Nothing rem_case_id) - `App` Literal (BooleanLiteral True) + `App` Literal ss (BooleanLiteral True) alt_fail = [CaseAlternative [NullBinder] [MkUnguarded goto_rem_case]] pure $ Let [ diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 31998c4bf6..c0bda4e7f1 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -41,7 +41,7 @@ desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d , BinaryNoParens op u val <- b' , isAnonymousArgument u = do arg <- freshIdent' return $ Abs (VarBinder nullSourceSpan arg) $ App (App op (Var nullSourceSpan (Qualified Nothing arg))) val - desugarExpr (Literal (ObjectLiteral ps)) = wrapLambdaAssoc (Literal . ObjectLiteral) ps + desugarExpr (Literal ss (ObjectLiteral ps)) = wrapLambdaAssoc (Literal ss . ObjectLiteral) ps desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps desugarExpr (Accessor prop u) | Just props <- peelAnonAccessorChain u = do diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index b143fa9803..d9588dc66f 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -297,7 +297,7 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = , let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs ] - let props = Literal $ ObjectLiteral $ map (first mkString) (members ++ superclasses) + let props = Literal ss $ ObjectLiteral $ map (first mkString) (members ++ superclasses) dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (foldr ConstrainedType dictTy deps) dict = TypeClassDictionaryConstructorApp className props diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 1e76cc4db8..1d8100f1fe 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -463,7 +463,7 @@ deriveEq ss mn syns ds tyConNm = do | length xs /= 1 = xs ++ [catchAll] | otherwise = xs -- Avoid redundant case where - catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (Literal (BooleanLiteral False))) + catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (Literal ss (BooleanLiteral False))) mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative mkCtorClause (ctorName, tys) = do @@ -476,7 +476,7 @@ deriveEq ss mn syns ds tyConNm = do caseBinder idents = ConstructorBinder ss (Qualified (Just mn) ctorName) (map (VarBinder ss) idents) conjAll :: [Expr] -> Expr - conjAll [] = Literal (BooleanLiteral True) + conjAll [] = Literal ss (BooleanLiteral True) conjAll xs = foldl1 preludeConj xs toEqTest :: Expr -> Expr -> Type -> Expr diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 823a3b47f4..f882dfe170 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -371,14 +371,14 @@ entails SolverOptions{..} constraint context hints = -- So pass an empty placeholder (undefined) instead. return valUndefined mkDictionary (IsSymbolInstance sym) _ = - let fields = [ ("reflectSymbol", Abs (VarBinder nullSourceSpan UnusedIdent) (Literal (StringLiteral sym))) ] in - return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) + let fields = [ ("reflectSymbol", Abs (VarBinder nullSourceSpan UnusedIdent) (Literal nullSourceSpan (StringLiteral sym))) ] in + return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal nullSourceSpan (ObjectLiteral fields)) mkDictionary CompareSymbolInstance _ = - return $ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral [])) + return $ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal nullSourceSpan (ObjectLiteral [])) mkDictionary ConsSymbolInstance _ = - return $ TypeClassDictionaryConstructorApp C.ConsSymbol (Literal (ObjectLiteral [])) + return $ TypeClassDictionaryConstructorApp C.ConsSymbol (Literal nullSourceSpan (ObjectLiteral [])) mkDictionary AppendSymbolInstance _ = - return $ TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral [])) + return $ TypeClassDictionaryConstructorApp C.AppendSymbol (Literal nullSourceSpan (ObjectLiteral [])) -- Turn a DictionaryValue into a Expr subclassDictionaryValue :: Expr -> Qualified (ProperName 'ClassName) -> Integer -> Expr diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 309111f9fa..d12e711179 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -305,20 +305,20 @@ infer' . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> m Expr -infer' v@(Literal (NumericLiteral (Left _))) = return $ TypedValue True v tyInt -infer' v@(Literal (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber -infer' v@(Literal (StringLiteral _)) = return $ TypedValue True v tyString -infer' v@(Literal (CharLiteral _)) = return $ TypedValue True v tyChar -infer' v@(Literal (BooleanLiteral _)) = return $ TypedValue True v tyBoolean -infer' (Literal (ArrayLiteral vals)) = do +infer' v@(Literal _ (NumericLiteral (Left _))) = return $ TypedValue True v tyInt +infer' v@(Literal _ (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber +infer' v@(Literal _ (StringLiteral _)) = return $ TypedValue True v tyString +infer' v@(Literal _ (CharLiteral _)) = return $ TypedValue True v tyChar +infer' v@(Literal _ (BooleanLiteral _)) = return $ TypedValue True v tyBoolean +infer' (Literal ss (ArrayLiteral vals)) = do ts <- traverse infer vals els <- freshType ts' <- forM ts $ \(TypedValue ch val t) -> do (val', t') <- instantiatePolyTypeWithUnknowns val t unifyTypes els t' return (TypedValue ch val' t') - return $ TypedValue True (Literal (ArrayLiteral ts')) (TypeApp tyArray els) -infer' (Literal (ObjectLiteral ps)) = do + return $ TypedValue True (Literal ss (ArrayLiteral ts')) (TypeApp tyArray els) +infer' (Literal ss (ObjectLiteral ps)) = do ensureNoDuplicateProperties ps -- We make a special case for Vars in record labels, since these are the -- only types of expressions for which 'infer' can return a polymorphic type. @@ -337,7 +337,7 @@ infer' (Literal (ObjectLiteral ps)) = do pure (name, valAndType) fields <- forM ps inferProperty let ty = TypeApp tyRecord $ rowFromList (map (Label *** snd) fields, REmpty) - return $ TypedValue True (Literal (ObjectLiteral (map (fmap (uncurry (TypedValue True))) fields))) ty + return $ TypedValue True (Literal ss (ObjectLiteral (map (fmap (uncurry (TypedValue True))) fields))) ty infer' (ObjectUpdate o ps) = do ensureNoDuplicateProperties ps row <- freshType @@ -464,11 +464,11 @@ inferBinder -> Binder -> m (M.Map Ident Type) inferBinder _ NullBinder = return M.empty -inferBinder val (LiteralBinder (StringLiteral _)) = unifyTypes val tyString >> return M.empty -inferBinder val (LiteralBinder (CharLiteral _)) = unifyTypes val tyChar >> return M.empty -inferBinder val (LiteralBinder (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty -inferBinder val (LiteralBinder (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty -inferBinder val (LiteralBinder (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty +inferBinder val (LiteralBinder _ (StringLiteral _)) = unifyTypes val tyString >> return M.empty +inferBinder val (LiteralBinder _ (CharLiteral _)) = unifyTypes val tyChar >> return M.empty +inferBinder val (LiteralBinder _ (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty +inferBinder val (LiteralBinder _ (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty +inferBinder val (LiteralBinder _ (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty inferBinder val (VarBinder _ name) = return $ M.singleton name val inferBinder val (ConstructorBinder ss ctor binders) = do env <- getEnv @@ -487,7 +487,7 @@ inferBinder val (ConstructorBinder ss ctor binders) = do where go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret go args ret = (args, ret) -inferBinder val (LiteralBinder (ObjectLiteral props)) = do +inferBinder val (LiteralBinder _ (ObjectLiteral props)) = do row <- freshType rest <- freshType m1 <- inferRowProperties row rest props @@ -501,7 +501,7 @@ inferBinder val (LiteralBinder (ObjectLiteral props)) = do m1 <- inferBinder propTy binder m2 <- inferRowProperties nrow (RCons (Label name) propTy row) binders return $ m1 `M.union` m2 -inferBinder val (LiteralBinder (ArrayLiteral binders)) = do +inferBinder val (LiteralBinder _ (ArrayLiteral binders)) = do el <- freshType m1 <- M.unions <$> traverse (inferBinder el) binders unifyTypes val (TypeApp tyArray el) @@ -630,19 +630,19 @@ check' val u@(TUnknown _) = do (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty unifyTypes ty' u return $ TypedValue True val'' ty' -check' v@(Literal (NumericLiteral (Left _))) t | t == tyInt = +check' v@(Literal _ (NumericLiteral (Left _))) t | t == tyInt = return $ TypedValue True v t -check' v@(Literal (NumericLiteral (Right _))) t | t == tyNumber = +check' v@(Literal _ (NumericLiteral (Right _))) t | t == tyNumber = return $ TypedValue True v t -check' v@(Literal (StringLiteral _)) t | t == tyString = +check' v@(Literal _ (StringLiteral _)) t | t == tyString = return $ TypedValue True v t -check' v@(Literal (CharLiteral _)) t | t == tyChar = +check' v@(Literal _ (CharLiteral _)) t | t == tyChar = return $ TypedValue True v t -check' v@(Literal (BooleanLiteral _)) t | t == tyBoolean = +check' v@(Literal _ (BooleanLiteral _)) t | t == tyBoolean = return $ TypedValue True v t -check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do +check' (Literal ss (ArrayLiteral vals)) t@(TypeApp a ty) = do unifyTypes a tyArray - array <- Literal . ArrayLiteral <$> forM vals (`check` ty) + array <- Literal ss . ArrayLiteral <$> forM vals (`check` ty) return $ TypedValue True array t check' (Abs binder ret) ty@(TypeApp (TypeApp t argTy) retTy) | VarBinder ss arg <- binder = do @@ -692,10 +692,10 @@ check' (IfThenElse cond th el) ty = do th' <- check th ty el' <- check el ty return $ TypedValue True (IfThenElse cond' th' el') ty -check' e@(Literal (ObjectLiteral ps)) t@(TypeApp obj row) | obj == tyRecord = do +check' e@(Literal ss (ObjectLiteral ps)) t@(TypeApp obj row) | obj == tyRecord = do ensureNoDuplicateProperties ps ps' <- checkProperties e ps row False - return $ TypedValue True (Literal (ObjectLiteral ps')) t + return $ TypedValue True (Literal ss (ObjectLiteral ps')) t check' (TypeClassDictionaryConstructorApp name ps) t = do ps' <- check' ps t return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t From cddf62dc64a74964e789981876723c3063b46a1e Mon Sep 17 00:00:00 2001 From: rndnoise <34294193+rndnoise@users.noreply.github.com> Date: Thu, 22 Mar 2018 18:15:01 -0500 Subject: [PATCH 0940/1580] Complete after parens and brackets in REPL (#3236) * Improvments to REPL tab-completion - Complete all names that have been imported (transitively or directly) - Do not complete names that haven't been imported - Only recompute list of names after import or adding a let binding rather than after each request for name completion This commit fixes #3227 * Complete names following [ and ( in REPL --- src/Language/PureScript/Interactive/Completion.hs | 2 +- tests/TestPsci/CompletionTest.hs | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index 8833eb46fa..a434358df9 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -42,7 +42,7 @@ completion completion = liftCompletionM . completion' completion' :: CompletionFunc CompletionM -completion' = completeWordWithPrev Nothing " \t\n\r" findCompletions +completion' = completeWordWithPrev Nothing " \t\n\r([" findCompletions -- | Callback for Haskeline's `completeWordWithPrev`. -- Expects: diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index f84c3eb7d4..38608fdd14 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -86,6 +86,10 @@ completionTestData supportModuleNames = , ("P.uni", ["P.unit"]) , ("voi", []) -- import Prelude hiding (void) , ("Control.Monad.Eff.Class.", []) + + -- Parens and brackets aren't considered part of the current identifier + , ("map id [uni", ["map id [unit"]) + , ("map (cons", ["map (const"]) ] assertCompletedOk :: PSCiState -> (String, [String]) -> Spec From e970a4fad0b6842896b9686bd8dd7c6f62d40671 Mon Sep 17 00:00:00 2001 From: rndnoise <34294193+rndnoise@users.noreply.github.com> Date: Thu, 22 Mar 2018 18:16:45 -0500 Subject: [PATCH 0941/1580] Complete any number of words after :kind and :type in REPL (#3237) * Improvments to REPL tab-completion - Complete all names that have been imported (transitively or directly) - Do not complete names that haven't been imported - Only recompute list of names after import or adding a let binding rather than after each request for name completion This commit fixes #3227 * Complete any number of words after :kind and :type in REPL --- .../PureScript/Interactive/Completion.hs | 34 +++++++------------ tests/TestPsci/CompletionTest.hs | 11 +++--- 2 files changed, 18 insertions(+), 27 deletions(-) diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index a434358df9..f0fc83df79 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -113,28 +113,18 @@ completionContext _ _ = [CtxIdentifier] completeDirective :: [String] -> String -> [CompletionContext] completeDirective ws w = case ws of - [] -> [CtxDirective w] - [dir] -> case D.directivesFor <$> stripPrefix ":" dir of - -- only offer completions if the directive is unambiguous - Just [dir'] -> directiveArg w dir' - _ -> [] - - -- All directives take exactly one argument. If we haven't yet matched, - -- that means one argument has already been supplied. So don't complete - -- any others. - _ -> [] - -directiveArg :: String -> Directive -> [CompletionContext] -directiveArg _ Browse = [CtxModule] -directiveArg _ Quit = [] -directiveArg _ Reload = [] -directiveArg _ Clear = [] -directiveArg _ Help = [] -directiveArg _ Paste = [] -directiveArg _ Show = map CtxFixed replQueryStrings -directiveArg _ Type = [CtxIdentifier] -directiveArg _ Kind = [CtxType] -directiveArg _ Complete = [] + [] -> [CtxDirective w] + (x:xs) -> case D.directivesFor <$> stripPrefix ":" x of + -- only offer completions if the directive is unambiguous + Just [dir] -> directiveArg xs dir + _ -> [] + +directiveArg :: [String] -> Directive -> [CompletionContext] +directiveArg [] Browse = [CtxModule] -- only complete very next term +directiveArg [] Show = map CtxFixed replQueryStrings -- only complete very next term +directiveArg _ Type = [CtxIdentifier] +directiveArg _ Kind = [CtxType] +directiveArg _ _ = [] completeImport :: [String] -> String -> [CompletionContext] completeImport ws w' = diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index 38608fdd14..308133e41e 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -63,12 +63,13 @@ completionTestData supportModuleNames = , (":kind ST.", [":kind ST.ST", ":kind ST.STRef"]) -- import Control.Monad.ST as ST , (":kind Control.Monad.Eff.", []) - -- Only one argument for directives should be completed + -- Only one argument for these directives should be completed , (":show import ", []) - , (":type EQ ", []) - , (":type unit compa", []) - , (":kind Ordering ", []) - , (":kind Array In", []) + , (":browse Data.List ", []) + + -- These directives take any number of completable terms + , (":type const compa", [":type const compare", ":type const comparing"]) + , (":kind Array In", [":kind Array Int"]) -- a few other import tests , ("impor", ["import"]) From 7efbbc930176d98413439425cb08efc20d52c189 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Sun, 25 Mar 2018 14:10:16 -0600 Subject: [PATCH 0942/1580] Rename prim classes (#3176) * Rename Prim classes * Rename tests * Fix docs * clean warns * Figured out how to add virtual modules * Move TypeString and TypeConcat into TypeError * Fix docs * Update tests * hmmm * put it back * debugging * It is being added to the imports. But not the environment. Why? * Add to environment and fix docs * remove some comments * simplify * Apparently imports already work on the virtual module. * Add restructuring to IDE * IDE stuff? * [skip ci] whitespace * Add Cons class test * importing Union * Merge master, fix thing * Add a test to verify that we can have name overlap * timeout??? * unused import warning * Update test dependencies * AppendSymbol can't strip prefixes * Whitespace, comment clarification * Identify fix * point at ordinary repo * Avoid state usage to populate Environment --- examples/docs/src/TypeLevelString.purs | 2 + examples/failing/2567.purs | 2 + examples/failing/PrimRow.purs | 13 ++ examples/failing/ProgrammableTypeErrors.purs | 1 + .../ProgrammableTypeErrorsTypeString.purs | 1 + examples/passing/2663.purs | 1 + examples/passing/3114/VendoredVariant.purs | 4 +- .../passing/DataConsClassConsOverlapOk.purs | 8 ++ examples/passing/NewConsClass.purs | 12 ++ examples/passing/PolyLabels.purs | 11 +- examples/passing/RowUnion.purs | 1 + examples/warning/CustomWarning.purs | 2 + examples/warning/CustomWarning2.purs | 2 + examples/warning/CustomWarning3.purs | 2 + src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/CodeGen/JS.hs | 5 +- src/Language/PureScript/Constants.hs | 14 +- src/Language/PureScript/Docs/Prim.hs | 95 ++++++++++---- src/Language/PureScript/Environment.hs | 121 ++++++++++++------ src/Language/PureScript/Ide.hs | 5 +- src/Language/PureScript/Ide/Prim.hs | 31 ++++- src/Language/PureScript/ModuleDependencies.hs | 2 +- src/Language/PureScript/Sugar.hs | 1 - src/Language/PureScript/Sugar/Names/Env.hs | 47 +++++-- src/Language/PureScript/Sugar/TypeClasses.hs | 8 +- tests/TestPrimDocs.hs | 7 +- tests/support/bower.json | 10 +- travis/build.sh | 2 +- 28 files changed, 305 insertions(+), 107 deletions(-) create mode 100644 examples/failing/PrimRow.purs create mode 100644 examples/passing/DataConsClassConsOverlapOk.purs create mode 100644 examples/passing/NewConsClass.purs diff --git a/examples/docs/src/TypeLevelString.purs b/examples/docs/src/TypeLevelString.purs index 34d4f038bc..60f500b615 100644 --- a/examples/docs/src/TypeLevelString.purs +++ b/examples/docs/src/TypeLevelString.purs @@ -1,5 +1,7 @@ module TypeLevelString where +import Prim.TypeError (class Fail) + data Foo class Bar a diff --git a/examples/failing/2567.purs b/examples/failing/2567.purs index 00f8ea844b..eb243a2a64 100644 --- a/examples/failing/2567.purs +++ b/examples/failing/2567.purs @@ -1,5 +1,7 @@ -- @shouldFailWith NoInstanceFound module Main where +import Prim.TypeError + foo :: Int foo = (0 :: Fail "This constraint should be checked" => Int) diff --git a/examples/failing/PrimRow.purs b/examples/failing/PrimRow.purs new file mode 100644 index 0000000000..e9dfe05373 --- /dev/null +++ b/examples/failing/PrimRow.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith UnknownName +module Main where + +import Prelude + +-- The 'Cons' class is not imported here, so we should not be able to refer to +-- it in the module. +import Prim.Row () + +x :: Cons "hello" Int () ("hello" :: Int) + => Unit +x = unit + diff --git a/examples/failing/ProgrammableTypeErrors.purs b/examples/failing/ProgrammableTypeErrors.purs index 72d51ef57b..e7cd509405 100644 --- a/examples/failing/ProgrammableTypeErrors.purs +++ b/examples/failing/ProgrammableTypeErrors.purs @@ -3,6 +3,7 @@ module Main where import Prelude +import Prim.TypeError import Control.Monad.Eff (Eff) import Control.Monad.Eff.Console (log) diff --git a/examples/failing/ProgrammableTypeErrorsTypeString.purs b/examples/failing/ProgrammableTypeErrorsTypeString.purs index b0b7c0f50d..a5759fa103 100644 --- a/examples/failing/ProgrammableTypeErrorsTypeString.purs +++ b/examples/failing/ProgrammableTypeErrorsTypeString.purs @@ -3,6 +3,7 @@ module Main where import Prelude +import Prim.TypeError import Control.Monad.Eff (Eff) import Control.Monad.Eff.Console (log) diff --git a/examples/passing/2663.purs b/examples/passing/2663.purs index 1bd70dcca5..dd0d1e5c22 100644 --- a/examples/passing/2663.purs +++ b/examples/passing/2663.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Prim.TypeError (class Warn) import Control.Monad.Eff.Console (log) foo :: forall t. Warn "Example" => t -> t diff --git a/examples/passing/3114/VendoredVariant.purs b/examples/passing/3114/VendoredVariant.purs index a176bb1f91..2442e99a96 100644 --- a/examples/passing/3114/VendoredVariant.purs +++ b/examples/passing/3114/VendoredVariant.purs @@ -2,6 +2,8 @@ module VendoredVariant where import Prelude +import Prim.Row as Row + import Unsafe.Coerce (unsafeCoerce) import Partial.Unsafe (unsafeCrashWith) import Data.Symbol @@ -21,7 +23,7 @@ case_ r = unsafeCrashWith case unsafeCoerce r of on :: forall sym f a b r1 r2 - . RowCons sym (FProxy f) r1 r2 + . Row.Cons sym (FProxy f) r1 r2 => IsSymbol sym => SProxy sym -> (f a -> b) diff --git a/examples/passing/DataConsClassConsOverlapOk.purs b/examples/passing/DataConsClassConsOverlapOk.purs new file mode 100644 index 0000000000..76ab731091 --- /dev/null +++ b/examples/passing/DataConsClassConsOverlapOk.purs @@ -0,0 +1,8 @@ +module Main where + +import Control.Monad.Eff.Console (log) +import Prim.Row (class Cons) + +data Cons = Cons + +main = log "Done" diff --git a/examples/passing/NewConsClass.purs b/examples/passing/NewConsClass.purs new file mode 100644 index 0000000000..384d8c0b62 --- /dev/null +++ b/examples/passing/NewConsClass.purs @@ -0,0 +1,12 @@ +-- This test verifies that we can write a new type class `Cons` without errors +-- in the presence of the `Cons` class from `Prim.Row`. +module Main where + +import Control.Monad.Eff.Console (log) +import Prim.Row(class Union) + +class Cons x xs | xs -> x where + cons :: x -> xs -> xs + + +main = log "Done" diff --git a/examples/passing/PolyLabels.purs b/examples/passing/PolyLabels.purs index c5a50cd43a..259f387127 100644 --- a/examples/passing/PolyLabels.purs +++ b/examples/passing/PolyLabels.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Prim.Row import Control.Monad.Eff import Control.Monad.Eff.Console import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) @@ -21,7 +22,7 @@ foreign import unsafeSet get :: forall r r' l a . IsSymbol l - => RowCons l a r' r + => Cons l a r' r => SProxy l -> Record r -> a @@ -30,8 +31,8 @@ get l = unsafeGet (reflectSymbol l) set :: forall r1 r2 r l a b . IsSymbol l - => RowCons l a r r1 - => RowCons l b r r2 + => Cons l a r r1 + => Cons l b r r2 => SProxy l -> b -> Record r1 @@ -41,8 +42,8 @@ set l = unsafeSet (reflectSymbol l) lens :: forall l f r1 r2 r a b . IsSymbol l - => RowCons l a r r1 - => RowCons l b r r2 + => Cons l a r r1 + => Cons l b r r2 => Functor f => SProxy l -> (a -> f b) diff --git a/examples/passing/RowUnion.purs b/examples/passing/RowUnion.purs index 57a47e6c95..112294c0d8 100644 --- a/examples/passing/RowUnion.purs +++ b/examples/passing/RowUnion.purs @@ -1,6 +1,7 @@ module Main where import Prelude +import Prim.Row import Control.Monad.Eff import Control.Monad.Eff.Console diff --git a/examples/warning/CustomWarning.purs b/examples/warning/CustomWarning.purs index 25540c66d1..f223900456 100644 --- a/examples/warning/CustomWarning.purs +++ b/examples/warning/CustomWarning.purs @@ -1,6 +1,8 @@ -- @shouldWarnWith UserDefinedWarning module Main where +import Prim.TypeError + foo :: forall t. Warn (TypeConcat "Custom warning " (TypeString t)) => t -> t foo x = x diff --git a/examples/warning/CustomWarning2.purs b/examples/warning/CustomWarning2.purs index 72afec3db1..c217899c6d 100644 --- a/examples/warning/CustomWarning2.purs +++ b/examples/warning/CustomWarning2.purs @@ -1,6 +1,8 @@ -- @shouldWarnWith UserDefinedWarning module Main where +import Prim.TypeError + foo :: Warn "foo" => Int -> Int foo x = x diff --git a/examples/warning/CustomWarning3.purs b/examples/warning/CustomWarning3.purs index e06f7f12fa..07d9ba10f9 100644 --- a/examples/warning/CustomWarning3.purs +++ b/examples/warning/CustomWarning3.purs @@ -2,6 +2,8 @@ -- @shouldWarnWith UserDefinedWarning module Main where +import Prim.TypeError + foo :: Warn "foo" => Int -> Int foo x = x diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 0ca9ddff51..351a670cec 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -259,7 +259,7 @@ addDefaultImport (Qualified toImportAs toImport) m@(Module ss coms mn decls exps importPrim :: Module -> Module importPrim = let - primModName = ModuleName [ProperName C.prim] + primModName = C.Prim in addDefaultImport (Qualified (Just primModName) primModName) . addDefaultImport (Qualified Nothing primModName) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index bad739c11e..2cc734cf80 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -15,7 +15,7 @@ import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class -import Data.List ((\\), delete, intersect) +import Data.List ((\\), intersect) import qualified Data.Foldable as F import qualified Data.Map as M import Data.Maybe (fromMaybe, isNothing) @@ -54,7 +54,8 @@ moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps - jsImports <- traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ ordNub $ map snd imps + jsImports <- traverse (importToJs mnLookup) + . (\\ [mn, C.Prim, C.PrimRow, C.PrimTypeError]) $ ordNub $ map snd imps let decls' = renameModules mnLookup decls jsDecls <- mapM bindToJs decls' optimized <- traverse (traverse optimize) jsDecls diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 57b01d07a9..cb8922d11b 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -403,20 +403,26 @@ partial = "Partial" pattern Prim :: ModuleName pattern Prim = ModuleName [ProperName "Prim"] +pattern PrimRow :: ModuleName +pattern PrimRow = ModuleName [ProperName "Prim", ProperName "Row"] + +pattern PrimTypeError :: ModuleName +pattern PrimTypeError = ModuleName [ProperName "Prim", ProperName "TypeError"] + pattern Partial :: Qualified (ProperName 'ClassName) pattern Partial = Qualified (Just Prim) (ProperName "Partial") pattern Fail :: Qualified (ProperName 'ClassName) -pattern Fail = Qualified (Just Prim) (ProperName "Fail") +pattern Fail = Qualified (Just PrimTypeError) (ProperName "Fail") pattern Warn :: Qualified (ProperName 'ClassName) -pattern Warn = Qualified (Just Prim) (ProperName "Warn") +pattern Warn = Qualified (Just PrimTypeError) (ProperName "Warn") pattern Union :: Qualified (ProperName 'ClassName) -pattern Union = Qualified (Just Prim) (ProperName "Union") +pattern Union = Qualified (Just PrimRow) (ProperName "Union") pattern RowCons :: Qualified (ProperName 'ClassName) -pattern RowCons = Qualified (Just Prim) (ProperName "RowCons") +pattern RowCons = Qualified (Just PrimRow) (ProperName "Cons") typ :: forall a. (IsString a) => a typ = "Type" diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 66c478411a..2bd8d4aafa 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -1,7 +1,13 @@ --- | This module provides documentation for the builtin Prim module. -module Language.PureScript.Docs.Prim (primDocsModule) where +-- | This module provides documentation for the builtin Prim modules. +module Language.PureScript.Docs.Prim + ( primDocsModule + , primRowDocsModule + , primTypeErrorDocsModule + , primModules + ) where import Prelude.Compat hiding (fail) +import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Map as Map @@ -9,6 +15,9 @@ import qualified Data.Set as Set import Language.PureScript.Docs.Types import qualified Language.PureScript as P +primModules :: [Module] +primModules = [primDocsModule, primRowDocsModule, primTypeErrorDocsModule] + primDocsModule :: Module primDocsModule = Module { modName = P.moduleNameFromString "Prim" @@ -23,23 +32,48 @@ primDocsModule = Module , char , boolean , partial - , fail - , warn - , union + , kindType + , kindSymbol + ] + , modReExports = [] + } + +primRowDocsModule :: Module +primRowDocsModule = Module + { modName = P.moduleNameFromString "Prim.Row" + , modComments = Just "The Prim.Row module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains automatically solved classes for working with row types." + , modDeclarations = + [ union , rowCons + ] + , modReExports = [] + } + +primTypeErrorDocsModule :: Module +primTypeErrorDocsModule = Module + { modName = P.moduleNameFromString "Prim.TypeError" + , modComments = Just "The Prim.TypeError module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains classes that provide custom type error and warning functionality." + , modDeclarations = + [ warn + , fail , typeConcat , typeString - , kindType - , kindSymbol ] , modReExports = [] } -unsafeLookup :: forall v (a :: P.ProperNameType). - Map.Map (P.Qualified (P.ProperName a)) v -> String -> Text -> v -unsafeLookup m errorMsg name = go name +type NameGen a = Text -> P.Qualified (P.ProperName a) + +unsafeLookupOf + :: forall v (a :: P.ProperNameType) + . NameGen a + -> Map.Map (P.Qualified (P.ProperName a)) v + -> String + -> Text + -> v +unsafeLookupOf k m errorMsg name = go name where - go = fromJust' . flip Map.lookup m . P.primName + go = fromJust' . flip Map.lookup m . k fromJust' (Just x) = x fromJust' _ = P.internalError $ errorMsg ++ show name @@ -56,32 +90,41 @@ primKind title comments = } else P.internalError $ "Docs.Prim: No such Prim kind: " ++ T.unpack title -lookupPrimTypeKind :: Text -> P.Kind -lookupPrimTypeKind = fst . unsafeLookup P.primTypes "Docs.Prim: No such Prim type: " +lookupPrimTypeKindOf + :: NameGen 'P.TypeName + -> Text + -> P.Kind +lookupPrimTypeKindOf k = fst . unsafeLookupOf k (P.primTypes <> P.primRowTypes <> P.primTypeErrorTypes) "Docs.Prim: No such Prim type: " primType :: Text -> Text -> Declaration -primType title comments = Declaration +primType = primTypeOf P.primName + +primTypeOf :: NameGen 'P.TypeName -> Text -> Text -> Declaration +primTypeOf gen title comments = Declaration { declTitle = title , declComments = Just comments , declSourceSpan = Nothing , declChildren = [] - , declInfo = ExternDataDeclaration (lookupPrimTypeKind title) + , declInfo = ExternDataDeclaration (lookupPrimTypeKindOf gen title) } -- | Lookup the TypeClassData of a Prim class. This function is specifically -- not exported because it is partial. -lookupPrimClass :: Text -> P.TypeClassData -lookupPrimClass = unsafeLookup P.primClasses "Docs.Prim: No such Prim class: " +lookupPrimClassOf :: NameGen 'P.ClassName -> Text -> P.TypeClassData +lookupPrimClassOf g = unsafeLookupOf g (P.primClasses <> P.primTypeErrorClasses <> P.primRowClasses) "Docs.Prim: No such Prim class: " primClass :: Text -> Text -> Declaration -primClass title comments = Declaration +primClass = primClassOf P.primName + +primClassOf :: NameGen 'P.ClassName -> Text -> Text -> Declaration +primClassOf gen title comments = Declaration { declTitle = title , declComments = Just comments , declSourceSpan = Nothing , declChildren = [] , declInfo = let - tcd = lookupPrimClass title + tcd = lookupPrimClassOf gen title args = P.typeClassArguments tcd superclasses = P.typeClassSuperclasses tcd fundeps = convertFundepsToStrings args (P.typeClassDependencies tcd) @@ -219,7 +262,7 @@ partial = primClass "Partial" $ T.unlines ] fail :: Declaration -fail = primClass "Fail" $ T.unlines +fail = primClassOf (P.primSubName "TypeError") "Fail" $ T.unlines [ "The Fail type class is part of the custom type errors feature. To provide" , "a custom type error when someone tries to use a particular instance," , "write that instance out with a Fail constraint." @@ -229,7 +272,7 @@ fail = primClass "Fail" $ T.unlines ] warn :: Declaration -warn = primClass "Warn" $ T.unlines +warn = primClassOf (P.primSubName "TypeError") "Warn" $ T.unlines [ "The Warn type class allows a custom compiler warning to be displayed." , "" , "For more information, see" @@ -237,7 +280,7 @@ warn = primClass "Warn" $ T.unlines ] union :: Declaration -union = primClass "Union" $ T.unlines +union = primClassOf (P.primSubName "Row") "Union" $ T.unlines [ "The Union type class is used to compute the union of two rows of types" , "(left-biased, including duplicates)." , "" @@ -245,14 +288,14 @@ union = primClass "Union" $ T.unlines ] rowCons :: Declaration -rowCons = primClass "RowCons" $ T.unlines - [ "The RowCons type class is a 4-way relation which asserts that one row of" +rowCons = primClassOf (P.primSubName "Row") "Cons" $ T.unlines + [ "The Cons type class is a 4-way relation which asserts that one row of" , "types can be obtained from another by inserting a new label/type pair on" , "the left." ] typeConcat :: Declaration -typeConcat = primType "TypeConcat" $ T.unlines +typeConcat = primTypeOf (P.primSubName "TypeError") "TypeConcat" $ T.unlines [ "The TypeConcat type constructor concatenates two Symbols in a custom type" , "error." , "" @@ -261,7 +304,7 @@ typeConcat = primType "TypeConcat" $ T.unlines ] typeString :: Declaration -typeString = primType "TypeString" $ T.unlines +typeString = primTypeOf (P.primSubName "TypeError") "TypeString" $ T.unlines [ "The TypeString type constructor renders any concrete type into a Symbol" , "in a custom type error." , "" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index b1734f3b55..e6a29b99a7 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -96,7 +96,7 @@ instance A.ToJSON FunctionalDependency where -- | The initial environment with no values and only the default javascript types defined initEnvironment :: Environment -initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses primKinds +initEnvironment = Environment M.empty allPrimTypes M.empty M.empty M.empty allPrimClasses primKinds -- | A constructor for TypeClassData that computes which type class arguments are fully determined -- and argument covering sets. @@ -261,6 +261,11 @@ instance A.FromJSON DataDeclType where primName :: Text -> Qualified (ProperName a) primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName +-- | Construct a 'ProperName' in the @Prim.NAME@ module. +primSubName :: Text -> Text -> Qualified (ProperName a) +primSubName sub = + Qualified (Just $ ModuleName [ProperName C.prim, ProperName sub]) . ProperName + primKind :: Text -> Kind primKind = NamedKind . primName @@ -337,55 +342,91 @@ primKinds = primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) primTypes = M.fromList - [ (primName "Function", (FunKind kindType (FunKind kindType kindType), ExternData)) - , (primName "Array", (FunKind kindType kindType, ExternData)) - , (primName "Record", (FunKind (Row kindType) kindType, ExternData)) - , (primName "String", (kindType, ExternData)) - , (primName "Char", (kindType, ExternData)) - , (primName "Number", (kindType, ExternData)) - , (primName "Int", (kindType, ExternData)) - , (primName "Boolean", (kindType, ExternData)) - , (primName "Partial", (kindType, ExternData)) - , (primName "Union", (FunKind (Row kindType) (FunKind (Row kindType) (FunKind (Row kindType) kindType)), ExternData)) - , (primName "RowCons", (FunKind kindSymbol (FunKind kindType (FunKind (Row kindType) (FunKind (Row kindType) kindType))), ExternData)) - , (primName "Fail", (FunKind kindSymbol kindType, ExternData)) - , (primName "Warn", (FunKind kindSymbol kindType, ExternData)) - , (primName "TypeString", (FunKind kindType kindSymbol, ExternData)) - , (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData)) + [ (primName "Function", (FunKind kindType (FunKind kindType kindType), ExternData)) + , (primName "Array", (FunKind kindType kindType, ExternData)) + , (primName "Record", (FunKind (Row kindType) kindType, ExternData)) + , (primName "String", (kindType, ExternData)) + , (primName "Char", (kindType, ExternData)) + , (primName "Number", (kindType, ExternData)) + , (primName "Int", (kindType, ExternData)) + , (primName "Boolean", (kindType, ExternData)) + , (primName "Partial", (kindType, ExternData)) + ] + +-- | This 'Map' contains all of the prim types from all Prim modules. +allPrimTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +allPrimTypes = M.unions + [ primTypes + , primTypeErrorTypes + , primRowTypes + ] + +primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +primTypeErrorTypes = + M.fromList + [ (primSubName "TypeError" "Fail", (FunKind kindSymbol kindType, ExternData)) + , (primSubName "TypeError" "Warn", (FunKind kindSymbol kindType, ExternData)) + , (primSubName "TypeError" "TypeString", (FunKind kindType kindSymbol, ExternData)) + , (primSubName "TypeError" "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData)) + ] + +primRowTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +primRowTypes = + M.fromList + [ (primSubName "Row" "Union", (FunKind (Row kindType) (FunKind (Row kindType) (FunKind (Row kindType) kindType)), ExternData)) + , (primSubName "Row" "Cons", (FunKind kindSymbol (FunKind kindType (FunKind (Row kindType) (FunKind (Row kindType) kindType))), ExternData)) ] --- | The primitive class map. This just contains the `Fail`, `Warn`, and `Partial` --- classes. `Partial` is used as a kind of magic constraint for partial --- functions. `Fail` is used for user-defined type errors. `Warn` for --- user-defined warnings. +-- | The primitive class map. This just contains the `Partial` class. +-- `Partial` is used as a kind of magic constraint for partial functions. primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses = M.fromList [ (primName "Partial", (makeTypeClassData [] [] [] [])) + ] + +-- | This contains all of the type classes from all Prim modules. +allPrimClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +allPrimClasses = M.unions + [ primClasses + , primTypeErrorClasses + , primRowClasses + ] + +primTypeErrorClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primTypeErrorClasses = + M.fromList + [ -- class Fail (message :: Symbol) - , (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] [])) + (primSubName "TypeError" "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] [])) -- class Warn (message :: Symbol) - , (primName "Warn", (makeTypeClassData [("message", Just kindSymbol)] [] [] [])) + , (primSubName "TypeError" "Warn", (makeTypeClassData [("message", Just kindSymbol)] [] [] [])) + ] + +primRowClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primRowClasses = + M.fromList + [ -- class Union (l :: # Type) (r :: # Type) (u :: # Type) | l r -> u, r u -> l, u l -> r - , (primName "Union", (makeTypeClassData - [ ("l", Just (Row kindType)) - , ("r", Just (Row kindType)) - , ("u", Just (Row kindType)) - ] [] [] - [ FunctionalDependency [0, 1] [2] - , FunctionalDependency [1, 2] [0] - , FunctionalDependency [2, 0] [1] - ])) + (primSubName "Row" "Union", (makeTypeClassData + [ ("l", Just (Row kindType)) + , ("r", Just (Row kindType)) + , ("u", Just (Row kindType)) + ] [] [] + [ FunctionalDependency [0, 1] [2] + , FunctionalDependency [1, 2] [0] + , FunctionalDependency [2, 0] [1] + ])) -- class RowCons (l :: Symbol) (a :: Type) (i :: # Type) (o :: # Type) | l i a -> o, l o -> a i - , (primName "RowCons", (makeTypeClassData - [ ("l", Just kindSymbol) - , ("a", Just kindType) - , ("i", Just (Row kindType)) - , ("o", Just (Row kindType)) - ] [] [] - [ FunctionalDependency [0, 1, 2] [3] - , FunctionalDependency [0, 3] [1, 2] - ])) + , (primSubName "Row" "Cons", (makeTypeClassData + [ ("l", Just kindSymbol) + , ("a", Just kindType) + , ("i", Just (Row kindType)) + , ("o", Just (Row kindType)) + ] [] [] + [ FunctionalDependency [0, 1, 2] [3] + , FunctionalDependency [0, 3] [1, 2] + ])) ] -- | Finds information about data constructors from the current environment. diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index a6d98f78c9..624a82ae9a 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -23,7 +23,6 @@ import Protolude hiding (moduleName) import "monad-logger" Control.Monad.Logger import qualified Data.Map as Map import qualified Language.PureScript as P -import qualified Language.PureScript.Constants as C import qualified Language.PureScript.Ide.CaseSplit as CS import Language.PureScript.Ide.Command import Language.PureScript.Ide.Completion @@ -119,14 +118,14 @@ findCompletions -> m Success findCompletions filters matcher currentModule complOptions = do modules <- Map.toList <$> getAllModules currentModule - let insertPrim = (:) (C.Prim, idePrimDeclarations) + let insertPrim = (++) idePrimDeclarations pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules))) findType :: Ide m => Text -> [Filter] -> Maybe P.ModuleName -> m Success findType search filters currentModule = do modules <- Map.toList <$> getAllModules currentModule - let insertPrim = (:) (C.Prim, idePrimDeclarations) + let insertPrim = (++) idePrimDeclarations pure (CompletionResult (getExactCompletions search filters (insertPrim modules))) findPursuitCompletions :: MonadIO m => diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index 5519ad9114..436e2565a5 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -4,17 +4,36 @@ import Protolude import qualified Data.Map as Map import qualified Data.Set as Set import qualified Language.PureScript as P +import qualified Language.PureScript.Constants as C import qualified Language.PureScript.Environment as PEnv import Language.PureScript.Ide.Types -idePrimDeclarations :: [IdeDeclarationAnn] +idePrimDeclarations :: [(P.ModuleName, [IdeDeclarationAnn])] idePrimDeclarations = - primTypes <> primKinds <> primClasses + [ ( C.Prim + , mconcat [primTypes, primKinds, primClasses] + ) + , ( C.PrimRow + , mconcat [primRowTypes, primRowClasses] + ) + , ( C.PrimTypeError + , mconcat [primTypeErrorTypes, primTypeErrorClasses] + ) + ] where - primTypes = foreach (Map.toList PEnv.primTypes) $ \(tn, (kind, _)) -> + annType tys = foreach (Map.toList tys) $ \(tn, (kind, _)) -> IdeDeclarationAnn emptyAnn (IdeDeclType (IdeType (P.disqualify tn) kind [])) - primKinds = foreach (Set.toList PEnv.primKinds) $ \kn -> - IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) - primClasses = foreach (Map.toList PEnv.primClasses) $ \(cn, _) -> + annClass cls = foreach (Map.toList cls) $ \(cn, _) -> -- Dummy kind and instances here, but we primarily care about the name completion IdeDeclarationAnn emptyAnn (IdeDeclTypeClass (IdeTypeClass (P.disqualify cn) P.kindType []) ) + + primTypes = annType PEnv.primTypes + primRowTypes = annType PEnv.primRowTypes + primTypeErrorTypes = annType PEnv.primTypeErrorTypes + + primClasses = annClass PEnv.primClasses + primRowClasses = annClass PEnv.primRowClasses + primTypeErrorClasses = annClass PEnv.primTypeErrorClasses + + primKinds = foreach (Set.toList PEnv.primKinds) $ \kn -> + IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 485174ed67..a5918b6109 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -42,7 +42,7 @@ sortModules ms = do toGraphNode mns m@(Module _ _ mn ds _) = do let deps = ordNub (mapMaybe usedModules ds) void . parU deps $ \(dep, pos) -> - when (dep /= C.Prim && S.notMember dep mns) . + when (dep `notElem` [C.Prim, C.PrimRow, C.PrimTypeError] && S.notMember dep mns) . throwError . addHint (ErrorInModule mn) . errorMessage' pos diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index c819797d2e..99d422c76c 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -71,4 +71,3 @@ desugar externs = >=> traverse (deriveInstances externs) >=> desugarTypeClasses externs >=> traverse createBindingGroupsModule - diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index fc5f2cd21a..7930547e6e 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -35,6 +35,7 @@ import Data.Maybe (fromJust, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S +import qualified Language.PureScript.Constants as C import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Errors @@ -184,22 +185,52 @@ envModuleExports (_, _, exps) = exps -- The exported types from the @Prim@ module -- primExports :: Exports -primExports = +primExports = mkPrimExports primTypes primClasses primKinds + +-- | +-- The exported types from the @Prim.Row@ module +-- +primRowExports :: Exports +primRowExports = mkPrimExports primRowTypes primRowClasses mempty + +-- | +-- The exported types from the @Prim.TypeError@ module +-- +primTypeErrorExports :: Exports +primTypeErrorExports = mkPrimExports primTypeErrorTypes primTypeErrorClasses mempty + +-- | +-- Create a set of exports for a Prim module. +-- +mkPrimExports + :: M.Map (Qualified (ProperName 'TypeName)) a + -> M.Map (Qualified (ProperName 'ClassName)) b + -> S.Set (Qualified (ProperName 'KindName)) + -> Exports +mkPrimExports ts cs ks = nullExports - { exportedTypes = M.fromList $ mkTypeEntry `map` M.keys primTypes - , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys primClasses - , exportedKinds = M.fromList $ mkKindEntry `map` S.toList primKinds + { exportedTypes = M.fromList $ mkTypeEntry `map` M.keys ts + , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys cs + , exportedKinds = M.fromList $ mkKindEntry `map` S.toList ks } where mkTypeEntry (Qualified mn name) = (name, ([], fromJust mn)) mkClassEntry (Qualified mn name) = (name, fromJust mn) mkKindEntry (Qualified mn name) = (name, fromJust mn) --- | Environment which only contains the Prim module. +-- | Environment which only contains the Prim modules. primEnv :: Env -primEnv = M.singleton - (ModuleName [ProperName "Prim"]) - (internalModuleSourceSpan "", nullImports, primExports) +primEnv = M.fromList + [ ( C.Prim + , (internalModuleSourceSpan "", nullImports, primExports) + ) + , ( C.PrimRow + , (internalModuleSourceSpan "", nullImports, primRowExports) + ) + , ( C.PrimTypeError + , (internalModuleSourceSpan "", nullImports, primTypeErrorExports) + ) + ] -- | -- When updating the `Exports` the behaviour is slightly different depending diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index d9588dc66f..63d6035b35 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -48,8 +48,12 @@ desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModu where initialState :: MemberMap initialState = - M.mapKeys (qualify (ModuleName [ProperName C.prim])) primClasses - `M.union` M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) + mconcat + [ M.mapKeys (qualify (ModuleName [ProperName C.prim])) primClasses + , M.mapKeys (qualify C.PrimRow) primRowClasses + , M.mapKeys (qualify C.PrimTypeError) primTypeErrorClasses + , M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) + ] fromExternsDecl :: ModuleName diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index 9309684dcb..70ab317847 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -1,6 +1,7 @@ module TestPrimDocs where import Control.Monad +import Data.Monoid ((<>)) import Data.List ((\\)) import qualified Data.Map as Map import qualified Data.Set as Set @@ -11,14 +12,14 @@ import qualified Language.PureScript.Docs.AsMarkdown as D main :: IO () main = do putStrLn "Test that there are no bottoms hiding in primDocsModule" - seq (D.runDocs (D.modulesAsMarkdown [D.primDocsModule])) (return ()) + seq (D.runDocs (D.modulesAsMarkdown D.primModules)) (return ()) putStrLn "Test that Prim is fully documented" let actualPrimNames = -- note that prim type classes are listed in P.primTypes - (map (P.runProperName . P.disqualify . fst) $ Map.toList P.primTypes) ++ + (map (P.runProperName . P.disqualify . fst) $ Map.toList (P.primTypes <> P.primTypeErrorTypes <> P.primRowTypes)) ++ (map (P.runProperName . P.disqualify) $ Set.toList P.primKinds) - let documentedPrimNames = map D.declTitle (D.modDeclarations D.primDocsModule) + let documentedPrimNames = map D.declTitle (concatMap D.modDeclarations D.primModules) let undocumentedNames = actualPrimNames \\ documentedPrimNames let extraNames = documentedPrimNames \\ actualPrimNames diff --git a/tests/support/bower.json b/tests/support/bower.json index 6a1f0a5472..37b855c8b4 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -19,7 +19,7 @@ "purescript-integers": "3.1.0", "purescript-invariant": "3.0.0", "purescript-lazy": "3.0.0", - "purescript-lists": "4.9.0", + "purescript-lists": "purescript/purescript-lists#compiler/0.12", "purescript-math": "2.1.0", "purescript-maybe": "3.0.0", "purescript-monoid": "3.1.0", @@ -32,12 +32,16 @@ "purescript-refs": "3.0.0", "purescript-st": "3.0.0", "purescript-strings": "3.3.0", - "purescript-symbols": "3.0.0", + "purescript-symbols": "purescript/purescript-symbols#compiler/0.12", "purescript-tailrec": "3.3.0", "purescript-tuples": "4.1.0", "purescript-type-equality": "2.1.0", - "purescript-typelevel-prelude": "#phil/append-symbol", + "purescript-typelevel-prelude": "purescript/purescript-typelevel-prelude#compiler/0.12", "purescript-unfoldable": "3.0.0", "purescript-unsafe-coerce": "3.0.0" + }, + "resolutions": { + "purescript-symbols": "compiler/0.12", + "purescript-lists": "compiler/0.12" } } diff --git a/travis/build.sh b/travis/build.sh index 5005a5f9ed..5cee10e709 100755 --- a/travis/build.sh +++ b/travis/build.sh @@ -5,7 +5,7 @@ STACK="stack --no-terminal --jobs=1" # Setup & install dependencies or abort ret=0 -$TIMEOUT 30m $STACK --install-ghc build \ +$TIMEOUT 45m $STACK --install-ghc build \ --only-dependencies --test --haddock \ || ret=$? case "$ret" in From d6667180dc73cab62d0924d3dec1e0b1abc03f5f Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Mon, 26 Mar 2018 04:08:49 -0600 Subject: [PATCH 0943/1580] Disallow Prim modules (#3291) * Disallow Prim modules * Address comments --- examples/failing/PrimModuleReserved.purs | 4 ++++ examples/failing/PrimModuleReserved/Prim.purs | 1 + examples/failing/PrimSubModuleReserved.purs | 4 ++++ .../PrimSubModuleReserved/Prim_Foobar.purs | 1 + src/Language/PureScript/AST/Declarations.hs | 1 + src/Language/PureScript/Errors.hs | 7 +++++++ src/Language/PureScript/Make.hs | 16 +++++++++++++++- 7 files changed, 33 insertions(+), 1 deletion(-) create mode 100644 examples/failing/PrimModuleReserved.purs create mode 100644 examples/failing/PrimModuleReserved/Prim.purs create mode 100644 examples/failing/PrimSubModuleReserved.purs create mode 100644 examples/failing/PrimSubModuleReserved/Prim_Foobar.purs diff --git a/examples/failing/PrimModuleReserved.purs b/examples/failing/PrimModuleReserved.purs new file mode 100644 index 0000000000..f09fe55a0e --- /dev/null +++ b/examples/failing/PrimModuleReserved.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith CannotDefinePrimModules +module Main where + +import Prim diff --git a/examples/failing/PrimModuleReserved/Prim.purs b/examples/failing/PrimModuleReserved/Prim.purs new file mode 100644 index 0000000000..bac15169ac --- /dev/null +++ b/examples/failing/PrimModuleReserved/Prim.purs @@ -0,0 +1 @@ +module Prim where diff --git a/examples/failing/PrimSubModuleReserved.purs b/examples/failing/PrimSubModuleReserved.purs new file mode 100644 index 0000000000..a4d4ae9e9a --- /dev/null +++ b/examples/failing/PrimSubModuleReserved.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith CannotDefinePrimModules +module Main where + +import Prim.Foobar diff --git a/examples/failing/PrimSubModuleReserved/Prim_Foobar.purs b/examples/failing/PrimSubModuleReserved/Prim_Foobar.purs new file mode 100644 index 0000000000..bab6dabf56 --- /dev/null +++ b/examples/failing/PrimSubModuleReserved/Prim_Foobar.purs @@ -0,0 +1 @@ +module Prim.Foobar where diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 351a670cec..c961f718ae 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -173,6 +173,7 @@ data SimpleErrorMessage | UserDefinedWarning Type -- | a declaration couldn't be used because it contained free variables | UnusableDeclaration Ident [[Text]] + | CannotDefinePrimModules ModuleName deriving (Show) -- | Error message hints, providing more detailed information about failure. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 86869d7f0b..ec35d452f0 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -179,6 +179,7 @@ errorCode em = case unwrapErrorMessage em of ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch" UserDefinedWarning{} -> "UserDefinedWarning" UnusableDeclaration{} -> "UnusableDeclaration" + CannotDefinePrimModules{} -> "CannotDefinePrimModules" -- | A stack trace for an error newtype MultipleErrors = MultipleErrors @@ -988,6 +989,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl map (\set -> line $ "{ " <> T.intercalate ", " set <> " }") options ] + renderSimpleErrorMessage (CannotDefinePrimModules mn) = + paras $ + [ line $ "The module name " <> markCode (runModuleName mn) <> " is in the Prim namespace." + , line $ "The Prim namespace is reserved for compiler-defined terms." + ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 3609fc2cc2..b729a6a448 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -167,7 +167,7 @@ make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, -> [Module] -> m [ExternsFile] make ma@MakeActions{..} ms = do - checkModuleNamesAreUnique + checkModuleNames (sorted, graph) <- sortModules ms @@ -188,6 +188,20 @@ make ma@MakeActions{..} ms = do return externs where + checkModuleNames :: m () + checkModuleNames = checkNoPrim *> checkModuleNamesAreUnique + + checkNoPrim :: m () + checkNoPrim = + for_ ms $ \m -> do + case getModuleName m of + mn@(ModuleName (ProperName "Prim" : _)) -> + throwError + . errorMessage' (getModuleSourceSpan m) + $ CannotDefinePrimModules mn + _ -> + pure () + checkModuleNamesAreUnique :: m () checkModuleNamesAreUnique = for_ (findDuplicates getModuleName ms) $ \mss -> From 978c353e6eac35d0f40fb9823267f2a73618e597 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 27 Mar 2018 09:37:25 +0200 Subject: [PATCH 0944/1580] Implements magic-do for Control.Monad.Effect (#3289) --- src/Language/PureScript/Constants.hs | 32 ++++++++++++++----- src/Language/PureScript/CoreImp/Optimizer.hs | 4 ++- .../PureScript/CoreImp/Optimizer/MagicDo.hs | 21 ++++++++---- 3 files changed, 41 insertions(+), 16 deletions(-) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index cb8922d11b..69e38ab487 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -2,7 +2,9 @@ module Language.PureScript.Constants where import Prelude.Compat + import Data.String (IsString) +import Language.PureScript.PSString (PSString) import Language.PureScript.Names -- Operators @@ -245,14 +247,25 @@ undefined = "undefined" -- Type Class Dictionary Names -monadEffDictionary :: forall a. (IsString a) => a -monadEffDictionary = "monadEff" - -applicativeEffDictionary :: forall a. (IsString a) => a -applicativeEffDictionary = "applicativeEff" - -bindEffDictionary :: forall a. (IsString a) => a -bindEffDictionary = "bindEff" +data EffectDictionaries = EffectDictionaries + { edApplicativeDict :: PSString + , edBindDict :: PSString + , edMonadDict :: PSString + } + +effDictionaries :: EffectDictionaries +effDictionaries = EffectDictionaries + { edApplicativeDict = "applicativeEff" + , edBindDict = "bindEff" + , edMonadDict = "monadEff" + } + +effectDictionaries :: EffectDictionaries +effectDictionaries = EffectDictionaries + { edApplicativeDict = "applicativeEffect" + , edBindDict = "bindEffect" + , edMonadDict = "monadEffect" + } discardUnitDictionary :: forall a. (IsString a) => a discardUnitDictionary = "discardUnit" @@ -444,6 +457,9 @@ dataArray = "Data_Array" eff :: forall a. (IsString a) => a eff = "Control_Monad_Eff" +effect :: forall a. (IsString a) => a +effect = "Control_Monad_Effect" + st :: forall a. (IsString a) => a st = "Control_Monad_ST" diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs index a4078274c8..9994debf8e 100644 --- a/src/Language/PureScript/CoreImp/Optimizer.hs +++ b/src/Language/PureScript/CoreImp/Optimizer.hs @@ -37,7 +37,9 @@ optimize js = do [ inlineCommonValues , inlineCommonOperators ]) js - untilFixedPoint (return . tidyUp) . tco . inlineST =<< untilFixedPoint (return . magicDo) js' + untilFixedPoint (return . tidyUp) . tco . inlineST + =<< untilFixedPoint (return . magicDo') + =<< untilFixedPoint (return . magicDo) js' where tidyUp :: AST -> AST tidyUp = applyAll diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs index 5d83c3ab5d..2067e38d37 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs @@ -1,11 +1,12 @@ -- | This module implements the "Magic Do" optimization, which inlines calls to return -- and bind for the Eff monad, as well as some of its actions. -module Language.PureScript.CoreImp.Optimizer.MagicDo (magicDo, inlineST) where +module Language.PureScript.CoreImp.Optimizer.MagicDo (magicDo, magicDo', inlineST) where import Prelude.Compat import Protolude (ordNub) import Data.Maybe (fromJust, isJust) +import Data.Text (Text) import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Common @@ -27,7 +28,13 @@ import qualified Language.PureScript.Constants as C -- ... -- } magicDo :: AST -> AST -magicDo = everywhereTopDown convert +magicDo = magicDo'' C.eff C.effDictionaries + +magicDo' :: AST -> AST +magicDo' = magicDo'' C.effect C.effectDictionaries + +magicDo'' :: Text -> C.EffectDictionaries -> AST -> AST +magicDo'' effectModule C.EffectDictionaries{..} = everywhereTopDown convert where -- The name of the function block which is added to denote a do block fnName = "__do" @@ -54,16 +61,16 @@ magicDo = everywhereTopDown convert App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) [] convert other = other -- Check if an expression represents a monomorphic call to >>= for the Eff monad - isBind (App _ fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True + isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True isBind _ = False -- Check if an expression represents a call to @discard@ isDiscard (App _ (App _ fn [dict1]) [dict2]) | isDict (C.controlBind, C.discardUnitDictionary) dict1 && - isDict (C.eff, C.bindEffDictionary) dict2 && + isDict (effectModule, edBindDict) dict2 && isDiscardPoly fn = True isDiscard _ = False -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative - isPure (App _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True + isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True isPure _ = False -- Check if an expression represents the polymorphic >>= function isBindPoly = isDict (C.controlBind, C.bind) @@ -71,8 +78,8 @@ magicDo = everywhereTopDown convert isPurePoly = isDict (C.controlApplicative, C.pure') -- Check if an expression represents the polymorphic discard function isDiscardPoly = isDict (C.controlBind, C.discard) - -- Check if an expression represents a function in the Eff module - isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == C.eff && name == name' + -- Check if an expression represents a function in the Effect module + isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == effectModule && name == name' isEffFunc _ _ = False applyReturns :: AST -> AST From 80cef847264f4124ca20cce01e2657998bcaaeaa Mon Sep 17 00:00:00 2001 From: Chris Allen Date: Fri, 30 Mar 2018 18:05:02 -0500 Subject: [PATCH 0945/1580] Makefiles make things easier for new and regular contributors alike (#3266) * Makefiles make things easier for new and regular contributors alike * Added stack exec in case people run 'make dev-deps' * contributors.md --- .gitignore | 8 ++++++++ Makefile | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 60 insertions(+) create mode 100644 Makefile diff --git a/.gitignore b/.gitignore index e9cb747cd0..6715e434d1 100644 --- a/.gitignore +++ b/.gitignore @@ -17,6 +17,14 @@ tmp/ output examples/docs/docs/ core-tests/full-core-docs.md +tests/support/package-lock.json .psc-ide-port .psc-package/ purescript.cabal + +# Profiling related +*.aux +*.hp +*.prof +*.ps +*.svg diff --git a/Makefile b/Makefile new file mode 100644 index 0000000000..060386a5df --- /dev/null +++ b/Makefile @@ -0,0 +1,52 @@ +package = purescript +exe_target = purs +stack_yaml = STACK_YAML="stack.yaml" +stack = $(stack_yaml) stack + +build: + $(stack) build $(package) + +build-dirty: + $(stack) build --ghc-options=-fforce-recomp $(package) + +run: + $(stack) build --fast && $(stack) exec -- $(package) + +install: + $(stack) install + +ghci: + $(stack) ghci $(package):lib + +test: + $(stack) test --fast $(package) + +test-ghci: + $(stack) ghci $(package):test:$(package)-tests + +# If you want to profile a particular test, such +# as LargeSumType.purs, add -p to the test arguments like so: +# stack test --executable-profiling --ta '-p LargeSum +RTS -pj -RTS' + +# Also, you'll need flamegraph.pl and ghc-prof-aeson-flamegraph +# (cf. dev-deps), I git cloned the FlameGraph repository and +# symlinked the Perl script into my path. +# Open the SVG with your browser, you can reload the browser when you +# rerun the profiled test run. +test-profiling: + $(stack) test --executable-profiling --ta '+RTS -pj -RTS' $(package) + cat tests.prof | stack exec ghc-prof-aeson-flamegraph | flamegraph.pl > tests.svg + +bench: + $(stack) bench $(package) + +ghcid: + $(stack) exec -- ghcid -c "stack ghci $(package):lib --test --ghci-options='-fobject-code -fno-warn-unused-do-bind'" + +# if you want these to be globally available run it outside of purescript +# but incompatibilities might arise between ghcid and the version of GHC +# you're using to build PureScript. +dev-deps: + stack install ghcid ghc-prof-aeson-flamegraph + +.PHONY : build build-dirty run install ghci test test-ghci test-profiling ghcid dev-deps From 662da01c9f73873fcc2c4577bbc58fcc3f776f41 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 4 Apr 2018 22:54:35 +0200 Subject: [PATCH 0946/1580] [purs ide] Find usages for recursive definitions (#3282) * [purs ide] Find usages for recursive definitions Previously we'd fail to find these because the name is already in "scope", but for recursive definitions that name still refers to the top level declaration. * The simple usage test also finds the usage in the defining module * Filepaths are not strings --- src/Language/PureScript/Ide/Usage.hs | 23 +++++++++++-------- tests/Language/PureScript/Ide/Test.hs | 2 +- tests/Language/PureScript/Ide/UsageSpec.hs | 9 +++++++- .../pscide/src/FindUsage/Recursive.purs | 8 +++++++ 4 files changed, 30 insertions(+), 12 deletions(-) create mode 100644 tests/support/pscide/src/FindUsage/Recursive.purs diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index f414931750..3c64301ad0 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -128,17 +128,23 @@ eligibleModules query@(moduleName, declaration) decls modules = -- | Finds all usages for a given `Search` throughout a module applySearch :: P.Module -> Search -> [P.SourceSpan] applySearch module_ search = - -- TODO(Christoph): Figure out how to find usages inside the defining module. - -- The Traversal adds declarations for the current module into `scope` so we - -- can't tell shadowed variable from actual usage. - let + foldMap findUsageInDeclaration decls + where decls = P.getModuleDeclarations module_ - (extr, _, _, _, _) = P.everythingWithScope mempty goExpr goBinder mempty mempty + findUsageInDeclaration decl = + let + (extr, _, _, _, _) = P.everythingWithScope mempty (goExpr decl) goBinder mempty mempty + in + extr mempty decl - goExpr scope expr = case expr of + goExpr decl scope expr = case expr of P.Var sp i | Just ideValue <- preview _IdeDeclValue (P.disqualify search) - , P.isQualified search || not (_ideValueIdent ideValue `Set.member` scope) -> + , P.isQualified search + || not (_ideValueIdent ideValue `Set.member` scope) + -- This case means we're looking at a recursive definition for a + -- value, which we count as a usage. + || P.declName decl == Just (P.IdentName (_ideValueIdent ideValue)) -> [sp | map P.runIdent i == map identifierFromIdeDeclaration search] P.Constructor sp name | Just ideDtor <- traverse (preview _IdeDeclDataConstructor) search -> @@ -156,6 +162,3 @@ applySearch module_ search = | Just op <- traverse (preview _IdeDeclValueOperator) search -> [sp | opName == map _ideValueOpName op] _ -> [] - in - foldMap (extr mempty) decls - diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index d9d50aedc7..8358ac563e 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -23,7 +23,7 @@ defConfig = IdeConfiguration { confLogLevel = LogNone , confOutputPath = "output/" - , confGlobs = ["src/*.purs"] + , confGlobs = ["src/**/*.purs"] , confEditorMode = False } diff --git a/tests/Language/PureScript/Ide/UsageSpec.hs b/tests/Language/PureScript/Ide/UsageSpec.hs index 1214409e87..cce46bbd40 100644 --- a/tests/Language/PureScript/Ide/UsageSpec.hs +++ b/tests/Language/PureScript/Ide/UsageSpec.hs @@ -41,11 +41,18 @@ shouldBeUsage usage' (fp, range) = spec :: Spec spec = describe "Finding Usages" $ do it "finds a simple usage" $ do - ([_, Right (UsagesResult [usage1])], _) <- Test.inProject $ + ([_, Right (UsagesResult [usage1, usage2])], _) <- Test.inProject $ Test.runIde [ load ["FindUsage", "FindUsage.Definition", "FindUsage.Reexport"] , usage (Test.mn "FindUsage.Definition") "usageId" IdeNSValue ] usage1 `shouldBeUsage` ("src" "FindUsage.purs", "12:11-12:18") + usage2 `shouldBeUsage` ("src" "FindUsage" "Definition.purs", "13:18-13:18") + it "finds a simple recursive usage" $ do + ([_, Right (UsagesResult [usage1])], _) <- Test.inProject $ + Test.runIde [ load ["FindUsage.Recursive"] + , usage (Test.mn "FindUsage.Recursive") "recursiveUsage" IdeNSValue + ] + usage1 `shouldBeUsage` ("src" "FindUsage" "Recursive.purs", "7:12-7:26") it "finds a constructor usage" $ do ([_, Right (UsagesResult [usage1])], _) <- Test.inProject $ Test.runIde [ load ["FindUsage", "FindUsage.Definition", "FindUsage.Reexport"] diff --git a/tests/support/pscide/src/FindUsage/Recursive.purs b/tests/support/pscide/src/FindUsage/Recursive.purs new file mode 100644 index 0000000000..e32ba99212 --- /dev/null +++ b/tests/support/pscide/src/FindUsage/Recursive.purs @@ -0,0 +1,8 @@ +module FindUsage.Recursive where + +data Nat = Suc Nat | Z + +recursiveUsage :: Nat -> Int +recursiveUsage = case _ of + Suc x -> recursiveUsage x + Z -> 0 From fdd9e492210c5c3124633aa2a9c149b15a2e2daa Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 6 Apr 2018 11:23:39 +0200 Subject: [PATCH 0947/1580] Smarter make (#3270) * Smarter make * all tests pass :tada: * reduces partiality * Refactors Make into smaller modules * fix prefix on data accessors * minor refactor * removes redundant constraints --- src/Language/PureScript/Make.hs | 376 ++-------------------- src/Language/PureScript/Make/Actions.hs | 274 ++++++++++++++++ src/Language/PureScript/Make/BuildPlan.hs | 160 +++++++++ src/Language/PureScript/Make/Monad.hs | 54 ++++ 4 files changed, 520 insertions(+), 344 deletions(-) create mode 100644 src/Language/PureScript/Make/Actions.hs create mode 100644 src/Language/PureScript/Make/BuildPlan.hs create mode 100644 src/Language/PureScript/Make/Monad.hs diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index b729a6a448..4340cb5c41 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -1,56 +1,30 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - module Language.PureScript.Make ( -- * Make API - RebuildPolicy(..) - , ProgressMessage(..), renderProgressMessage - , MakeActions(..) - , Externs() - , rebuildModule + rebuildModule , make - - -- * Implementation of Make API using files on disk - , Make(..) - , runMake - , makeIO - , readTextFile - , buildMakeActions , inferForeignModules + , module Monad + , module Actions ) where import Prelude.Compat import Control.Concurrent.Lifted as C import Control.Monad hiding (sequence) -import Control.Monad.Base (MonadBase(..)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) import Control.Monad.Supply -import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Control (MonadBaseControl(..)) -import Control.Monad.Trans.Except import Control.Monad.Writer.Class (MonadWriter(..)) -import Data.Aeson (encode, decode) -import Data.Either (partitionEithers) +import Data.Aeson (encode) import Data.Function (on) import Data.Foldable (for_) import Data.List (foldl', sortBy) import qualified Data.List.NonEmpty as NEL -import Data.Maybe (fromMaybe, catMaybes) -import Data.Monoid ((<>)) -import Data.Time.Clock -import Data.Traversable (for) -import Data.Version (showVersion) -import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString.UTF8 as BU8 +import Data.Maybe (fromMaybe) import qualified Data.Map as M import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Environment @@ -59,71 +33,16 @@ import Language.PureScript.Externs import Language.PureScript.Linter import Language.PureScript.ModuleDependencies import Language.PureScript.Names -import Language.PureScript.Options -import Language.PureScript.Pretty.Common (SMap(..)) import Language.PureScript.Renamer import Language.PureScript.Sugar import Language.PureScript.TypeChecker -import qualified Language.JavaScript.Parser as JS -import qualified Language.PureScript.Bundle as Bundle -import qualified Language.PureScript.CodeGen.JS as J -import Language.PureScript.CodeGen.JS.Printer +import Language.PureScript.Make.BuildPlan +import qualified Language.PureScript.Make.BuildPlan as BuildPlan +import Language.PureScript.Make.Actions as Actions +import Language.PureScript.Make.Monad as Monad import qualified Language.PureScript.CoreFn as CF -import qualified Language.PureScript.CoreFn.ToJSON as CFJ -import qualified Language.PureScript.CoreImp.AST as Imp -import qualified Language.PureScript.Parser as PSParser -import qualified Paths_purescript as Paths -import SourceMap -import SourceMap.Types -import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) -import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise, replaceExtension) -import System.IO.Error (tryIOError) -import qualified Text.Parsec as Parsec - --- | Progress messages from the make process -data ProgressMessage - = CompilingModule ModuleName - -- ^ Compilation started for the specified module - deriving (Show, Eq, Ord) - --- | Render a progress message -renderProgressMessage :: ProgressMessage -> String -renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModuleName mn) - --- | Actions that require implementations when running in "make" mode. --- --- This type exists to make two things abstract: --- --- * The particular backend being used (JavaScript, C++11, etc.) --- --- * The details of how files are read/written etc. -data MakeActions m = MakeActions - { getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime)) - -- ^ Get the timestamp for the input file(s) for a module. If there are multiple - -- files (@.purs@ and foreign files, for example) the timestamp should be for - -- the most recently modified file. - , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime) - -- ^ Get the timestamp for the output files for a module. This should be the - -- timestamp for the oldest modified file, or 'Nothing' if any of the required - -- output files are missing. - , readExterns :: ModuleName -> m (FilePath, Externs) - -- ^ Read the externs file for a module as a string and also return the actual - -- path for the file. - , codegen :: SourceSpan -> CF.Module CF.Ann -> Environment -> Externs -> SupplyT m () - -- ^ Run the code generator for the module and write any required output files. - , progress :: ProgressMessage -> m () - -- ^ Respond to a progress update. - } - --- | Generated code for an externs file. -type Externs = B.ByteString - --- | Determines when to rebuild a module -data RebuildPolicy - -- | Never rebuild this module - = RebuildNever - -- | Always rebuild this module - | RebuildAlways deriving (Show, Eq, Ord) +import System.Directory (doesFileExist) +import System.FilePath (replaceExtension) -- | Rebuild a single module. -- @@ -171,21 +90,27 @@ make ma@MakeActions{..} ms = do (sorted, graph) <- sortModules ms - barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar) + buildPlan <- BuildPlan.construct ma (sorted, graph) - for_ sorted $ \m -> fork $ do + let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName) sorted + for_ toBeRebuilt $ \m -> fork $ do let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph) - buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted) + buildModule buildPlan (importPrim m) (deps `inOrderOf` map getModuleName sorted) -- Wait for all threads to complete, and collect errors. - errors <- catMaybes <$> for barriers (takeMVar . snd . snd) + errors <- BuildPlan.collectErrors buildPlan -- All threads have completed, rethrow any caught errors. unless (null errors) $ throwError (mconcat errors) - -- Bundle up all the externs and return them as an Environment - (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd) - return externs + -- Collect all ExternsFiles + results <- BuildPlan.collectResults buildPlan + + -- Here we return all the ExternsFile in the ordering of the topological sort, + -- so they can be folded into an Environment. This result is used in the tests + -- and in PSCI. + let lookupResult mn = fromMaybe (internalError "make: module not found in results") (M.lookup mn results) + return (map (lookupResult . getModuleName) sorted) where checkModuleNames :: m () @@ -220,86 +145,21 @@ make ma@MakeActions{..} ms = do inOrderOf :: (Ord a) => [a] -> [a] -> [a] inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys - buildModule :: [(ModuleName, (C.MVar (Maybe (MultipleErrors, ExternsFile)), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m () - buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do + buildModule :: BuildPlan -> Module -> [ModuleName] -> m () + buildModule buildPlan m@(Module _ _ moduleName _ _) deps = flip catchError (complete Nothing . Just) $ do -- We need to wait for dependencies to be built, before checking if the current -- module should be rebuilt, so the first thing to do is to wait on the -- MVars for the module's dependencies. - mexterns <- fmap unzip . sequence <$> traverse (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps + mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps case mexterns of Just (_, externs) -> do - outputTimestamp <- getOutputTimestamp moduleName - dependencyTimestamp <- maximumMaybe <$> traverse (fmap shouldExist . getOutputTimestamp) deps - inputTimestamp <- getInputTimestamp moduleName - - let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of - (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2 - (Right (Just t1), Nothing, Just t2) -> t1 > t2 - (Left RebuildNever, _, Just _) -> False - _ -> True - - let rebuild = do - (exts, warnings) <- listen $ rebuildModule ma externs m - markComplete (Just (warnings, exts)) Nothing - - if shouldRebuild - then rebuild - else do - mexts <- decodeExterns . snd <$> readExterns moduleName - case mexts of - Just exts -> markComplete (Just (mempty, exts)) Nothing - Nothing -> rebuild - Nothing -> markComplete Nothing Nothing + (exts, warnings) <- listen $ rebuildModule ma externs m + complete (Just (warnings, exts)) Nothing + Nothing -> complete Nothing Nothing where - markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m () - markComplete externs errors = do - putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs - putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors - - maximumMaybe :: Ord a => [a] -> Maybe a - maximumMaybe [] = Nothing - maximumMaybe xs = Just $ maximum xs - - -- Make sure a dependency exists - shouldExist :: Maybe UTCTime -> UTCTime - shouldExist (Just t) = t - shouldExist _ = internalError "make: dependency should already have been built." - - decodeExterns :: Externs -> Maybe ExternsFile - decodeExterns bs = do - externs <- decode bs - guard $ T.unpack (efVersion externs) == showVersion Paths.version - return externs - --- | A monad for running make actions -newtype Make a = Make - { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a - } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options) - -instance MonadBase IO Make where - liftBase = liftIO - -instance MonadBaseControl IO Make where - type StM Make a = Either MultipleErrors a - liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake) - restoreM = Make . restoreM - --- | Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings. -runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors) -runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake - --- | Run an 'IO' action in the 'Make' monad, by specifying how IO errors should --- be rendered as 'ErrorMessage' values. -makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a -makeIO f io = do - e <- liftIO $ tryIOError io - either (throwError . singleError . f) return e - --- | Read a text file in the 'Make' monad, capturing any errors using the --- 'MonadError' instance. -readTextFile :: FilePath -> Make B.ByteString -readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path + complete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m () + complete = BuildPlan.markComplete buildPlan moduleName -- | Infer the module name for a module by looking for the same filename with -- a .js extension. @@ -319,175 +179,3 @@ inferForeignModules = if exists then return (Just jsFile) else return Nothing - --- | A set of make actions that read and write modules from the given directory. -buildMakeActions - :: FilePath - -- ^ the output directory - -> M.Map ModuleName (Either RebuildPolicy FilePath) - -- ^ a map between module names and paths to the file containing the PureScript module - -> M.Map ModuleName FilePath - -- ^ a map between module name and the file containing the foreign javascript for the module - -> Bool - -- ^ Generate a prefix comment? - -> MakeActions Make -buildMakeActions outputDir filePathMap foreigns usePrefix = - MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress - where - - getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime)) - getInputTimestamp mn = do - let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap - e1 <- traverse getTimestamp path - fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns - return $ fmap (max fPath) e1 - - getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) - getOutputTimestamp mn = do - dumpCoreFn <- asks optionsDumpCoreFn - let filePath = T.unpack (runModuleName mn) - jsFile = outputDir filePath "index.js" - externsFile = outputDir filePath "externs.json" - coreFnFile = outputDir filePath "corefn.json" - min3 js exts coreFn - | dumpCoreFn = min (min js exts) coreFn - | otherwise = min js exts - min3 <$> getTimestamp jsFile <*> getTimestamp externsFile <*> getTimestamp coreFnFile - - readExterns :: ModuleName -> Make (FilePath, Externs) - readExterns mn = do - let path = outputDir T.unpack (runModuleName mn) "externs.json" - (path, ) <$> readTextFile path - - codegen :: SourceSpan -> CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make () - codegen modSS m _ exts = do - let mn = CF.moduleName m - foreignInclude <- case mn `M.lookup` foreigns of - Just path - | not $ requiresForeign m -> do - tell $ errorMessage' modSS $ UnnecessaryFFIModule mn path - return Nothing - | otherwise -> do - checkForeignDecls modSS m path - return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign"] - Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn - | otherwise -> return Nothing - rawJs <- J.moduleToJs m foreignInclude - dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory - sourceMaps <- lift $ asks optionsSourceMaps - let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, []) - let filePath = T.unpack (runModuleName mn) - jsFile = outputDir filePath "index.js" - mapFile = outputDir filePath "index.js.map" - externsFile = outputDir filePath "externs.json" - foreignFile = outputDir filePath "foreign.js" - prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix] - js = T.unlines $ map ("// " <>) prefix ++ [pjs] - mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else "" - lift $ do - writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef) - for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile) - writeTextFile externsFile exts - lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings - dumpCoreFn <- lift $ asks optionsDumpCoreFn - when dumpCoreFn $ do - let coreFnFile = outputDir filePath "corefn.json" - let json = CFJ.moduleToJSON Paths.version m - lift $ writeTextFile coreFnFile (encode json) - - genSourceMap :: String -> String -> Int -> [SMap] -> Make () - genSourceMap dir mapFile extraLines mappings = do - let pathToDir = iterate (".." ) ".." !! length (splitPath $ normalise outputDir) - sourceFile = case mappings of - (SMap file _ _ : _) -> Just $ pathToDir makeRelative dir (T.unpack file) - _ -> Nothing - let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings = - map (\(SMap _ orig gen) -> Mapping { - mapOriginal = Just $ convertPos $ add 0 (-1) orig - , mapSourceFile = sourceFile - , mapGenerated = convertPos $ add (extraLines+1) 0 gen - , mapName = Nothing - }) mappings - } - let mapping = generate rawMapping - writeTextFile mapFile (encode mapping) - where - add :: Int -> Int -> SourcePos -> SourcePos - add n m (SourcePos n' m') = SourcePos (n+n') (m+m') - - convertPos :: SourcePos -> Pos - convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } = - Pos { posLine = fromIntegral l, posColumn = fromIntegral c } - - requiresForeign :: CF.Module a -> Bool - requiresForeign = not . null . CF.moduleForeign - - getTimestamp :: FilePath -> Make (Maybe UTCTime) - getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do - exists <- doesFileExist path - traverse (const $ getModificationTime path) $ guard exists - - writeTextFile :: FilePath -> B.ByteString -> Make () - writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do - mkdirp path - B.writeFile path text - where - mkdirp :: FilePath -> IO () - mkdirp = createDirectoryIfMissing True . takeDirectory - - progress :: ProgressMessage -> Make () - progress = liftIO . putStrLn . renderProgressMessage - --- | Check that the declarations in a given PureScript module match with those --- in its corresponding foreign module. -checkForeignDecls :: SourceSpan -> CF.Module ann -> FilePath -> SupplyT Make () -checkForeignDecls modSS m path = do - jsStr <- lift $ readTextFile path - js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse (BU8.toString (B.toStrict jsStr)) path - - foreignIdentsStrs <- either errorParsingModule pure $ getExps js - foreignIdents <- either - errorInvalidForeignIdentifiers - (pure . S.fromList) - (parseIdents foreignIdentsStrs) - let importedIdents = S.fromList (CF.moduleForeign m) - - let unusedFFI = foreignIdents S.\\ importedIdents - unless (null unusedFFI) $ - tell . errorMessage' modSS . UnusedFFIImplementations mname $ - S.toList unusedFFI - - let missingFFI = importedIdents S.\\ foreignIdents - unless (null missingFFI) $ - throwError . errorMessage' modSS . MissingFFIImplementations mname $ - S.toList missingFFI - - where - mname = CF.moduleName m - - errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a - errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just - - getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String] - getExps = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname)) - - errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a - errorInvalidForeignIdentifiers = - throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack) - - parseIdents :: [String] -> Either [String] [Ident] - parseIdents strs = - case partitionEithers (map parseIdent strs) of - ([], idents) -> - Right idents - (errs, _) -> - Left errs - - -- We ignore the error message here, just being told it's an invalid - -- identifier should be enough. - parseIdent :: String -> Either String Ident - parseIdent str = try (T.pack str) - where - try s = either (const (Left str)) Right $ do - ts <- PSParser.lex "" s - PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs new file mode 100644 index 0000000000..cbe0886480 --- /dev/null +++ b/src/Language/PureScript/Make/Actions.hs @@ -0,0 +1,274 @@ +module Language.PureScript.Make.Actions + ( MakeActions(..) + , RebuildPolicy(..) + , Externs() + , ProgressMessage(..) + , buildMakeActions + ) where + +import Prelude + +import Control.Monad hiding (sequence) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.IO.Class +import Control.Monad.Reader (asks) +import Control.Monad.Supply +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Aeson (encode) +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.UTF8 as BU8 +import Data.Either (partitionEithers) +import Data.Foldable (for_) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Time.Clock (UTCTime) +import Data.Version (showVersion) +import qualified Language.JavaScript.Parser as JS +import Language.PureScript.AST +import qualified Language.PureScript.Bundle as Bundle +import qualified Language.PureScript.CodeGen.JS as J +import Language.PureScript.CodeGen.JS.Printer +import qualified Language.PureScript.CoreFn as CF +import qualified Language.PureScript.CoreFn.ToJSON as CFJ +import qualified Language.PureScript.CoreImp.AST as Imp +import Language.PureScript.Crash +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Make.Monad +import Language.PureScript.Names +import Language.PureScript.Names (runModuleName, ModuleName) +import Language.PureScript.Options +import qualified Language.PureScript.Parser as PSParser +import Language.PureScript.Pretty.Common (SMap(..)) +import qualified Paths_purescript as Paths +import SourceMap +import SourceMap.Types +import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) +import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise) +import qualified Text.Parsec as Parsec + +-- | Determines when to rebuild a module +data RebuildPolicy + -- | Never rebuild this module + = RebuildNever + -- | Always rebuild this module + | RebuildAlways + deriving (Show, Eq, Ord) + +-- | Progress messages from the make process +data ProgressMessage + = CompilingModule ModuleName + -- ^ Compilation started for the specified module + deriving (Show, Eq, Ord) + +-- | Generated code for an externs file. +type Externs = LB.ByteString + +-- | Render a progress message +renderProgressMessage :: ProgressMessage -> String +renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModuleName mn) + +-- | Actions that require implementations when running in "make" mode. +-- +-- This type exists to make two things abstract: +-- +-- * The particular backend being used (JavaScript, C++11, etc.) +-- +-- * The details of how files are read/written etc. +data MakeActions m = MakeActions + { getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime)) + -- ^ Get the timestamp for the input file(s) for a module. If there are multiple + -- files (@.purs@ and foreign files, for example) the timestamp should be for + -- the most recently modified file. + , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime) + -- ^ Get the timestamp for the output files for a module. This should be the + -- timestamp for the oldest modified file, or 'Nothing' if any of the required + -- output files are missing. + , readExterns :: ModuleName -> m (FilePath, Externs) + -- ^ Read the externs file for a module as a string and also return the actual + -- path for the file. + , codegen :: SourceSpan -> CF.Module CF.Ann -> Environment -> Externs -> SupplyT m () + -- ^ Run the code generator for the module and write any required output files. + , progress :: ProgressMessage -> m () + -- ^ Respond to a progress update. + } + +-- | A set of make actions that read and write modules from the given directory. +buildMakeActions + :: FilePath + -- ^ the output directory + -> M.Map ModuleName (Either RebuildPolicy FilePath) + -- ^ a map between module names and paths to the file containing the PureScript module + -> M.Map ModuleName FilePath + -- ^ a map between module name and the file containing the foreign javascript for the module + -> Bool + -- ^ Generate a prefix comment? + -> MakeActions Make +buildMakeActions outputDir filePathMap foreigns usePrefix = + MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress + where + + getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime)) + getInputTimestamp mn = do + let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap + e1 <- traverse getTimestamp path + fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns + return $ fmap (max fPath) e1 + + getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) + getOutputTimestamp mn = do + dumpCoreFn <- asks optionsDumpCoreFn + let filePath = T.unpack (runModuleName mn) + jsFile = outputDir filePath "index.js" + externsFile = outputDir filePath "externs.json" + coreFnFile = outputDir filePath "corefn.json" + min3 js exts coreFn + | dumpCoreFn = min (min js exts) coreFn + | otherwise = min js exts + min3 <$> getTimestamp jsFile <*> getTimestamp externsFile <*> getTimestamp coreFnFile + + readExterns :: ModuleName -> Make (FilePath, Externs) + readExterns mn = do + let path = outputDir T.unpack (runModuleName mn) "externs.json" + (path, ) <$> readTextFile path + + codegen :: SourceSpan -> CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make () + codegen modSS m _ exts = do + let mn = CF.moduleName m + foreignInclude <- case mn `M.lookup` foreigns of + Just path + | not $ requiresForeign m -> do + tell $ errorMessage' modSS $ UnnecessaryFFIModule mn path + return Nothing + | otherwise -> do + checkForeignDecls modSS m path + return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign"] + Nothing | requiresForeign m -> throwError . errorMessage' modSS $ MissingFFIModule mn + | otherwise -> return Nothing + rawJs <- J.moduleToJs m foreignInclude + dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory + sourceMaps <- lift $ asks optionsSourceMaps + let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, []) + let filePath = T.unpack (runModuleName mn) + jsFile = outputDir filePath "index.js" + mapFile = outputDir filePath "index.js.map" + externsFile = outputDir filePath "externs.json" + foreignFile = outputDir filePath "foreign.js" + prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix] + js = T.unlines $ map ("// " <>) prefix ++ [pjs] + mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else "" + lift $ do + writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef) + for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile) + writeTextFile externsFile exts + lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings + dumpCoreFn <- lift $ asks optionsDumpCoreFn + when dumpCoreFn $ do + let coreFnFile = outputDir filePath "corefn.json" + let json = CFJ.moduleToJSON Paths.version m + lift $ writeTextFile coreFnFile (encode json) + + genSourceMap :: String -> String -> Int -> [SMap] -> Make () + genSourceMap dir mapFile extraLines mappings = do + let pathToDir = iterate (".." ) ".." !! length (splitPath $ normalise outputDir) + sourceFile = case mappings of + (SMap file _ _ : _) -> Just $ pathToDir makeRelative dir (T.unpack file) + _ -> Nothing + let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings = + map (\(SMap _ orig gen) -> Mapping { + mapOriginal = Just $ convertPos $ add 0 (-1) orig + , mapSourceFile = sourceFile + , mapGenerated = convertPos $ add (extraLines+1) 0 gen + , mapName = Nothing + }) mappings + } + let mapping = generate rawMapping + writeTextFile mapFile (encode mapping) + where + add :: Int -> Int -> SourcePos -> SourcePos + add n m (SourcePos n' m') = SourcePos (n+n') (m+m') + + convertPos :: SourcePos -> Pos + convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } = + Pos { posLine = fromIntegral l, posColumn = fromIntegral c } + + requiresForeign :: CF.Module a -> Bool + requiresForeign = not . null . CF.moduleForeign + + getTimestamp :: FilePath -> Make (Maybe UTCTime) + getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do + exists <- doesFileExist path + if exists + then Just <$> getModificationTime path + else pure Nothing + + writeTextFile :: FilePath -> B.ByteString -> Make () + writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do + mkdirp path + B.writeFile path text + where + mkdirp :: FilePath -> IO () + mkdirp = createDirectoryIfMissing True . takeDirectory + + progress :: ProgressMessage -> Make () + progress = liftIO . putStrLn . renderProgressMessage + +-- | Check that the declarations in a given PureScript module match with those +-- in its corresponding foreign module. +checkForeignDecls :: SourceSpan -> CF.Module ann -> FilePath -> SupplyT Make () +checkForeignDecls modSS m path = do + jsStr <- lift $ readTextFile path + js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse (BU8.toString (B.toStrict jsStr)) path + + foreignIdentsStrs <- either errorParsingModule pure $ getExps js + foreignIdents <- either + errorInvalidForeignIdentifiers + (pure . S.fromList) + (parseIdents foreignIdentsStrs) + let importedIdents = S.fromList (CF.moduleForeign m) + + let unusedFFI = foreignIdents S.\\ importedIdents + unless (null unusedFFI) $ + tell . errorMessage' modSS . UnusedFFIImplementations mname $ + S.toList unusedFFI + + let missingFFI = importedIdents S.\\ foreignIdents + unless (null missingFFI) $ + throwError . errorMessage' modSS . MissingFFIImplementations mname $ + S.toList missingFFI + + where + mname = CF.moduleName m + + errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a + errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just + + getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String] + getExps = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname)) + + errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a + errorInvalidForeignIdentifiers = + throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack) + + parseIdents :: [String] -> Either [String] [Ident] + parseIdents strs = + case partitionEithers (map parseIdent strs) of + ([], idents) -> + Right idents + (errs, _) -> + Left errs + + -- We ignore the error message here, just being told it's an invalid + -- identifier should be enough. + parseIdent :: String -> Either String Ident + parseIdent str = try (T.pack str) + where + try s = either (const (Left str)) Right $ do + ts <- PSParser.lex "" s + PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs new file mode 100644 index 0000000000..a60bcd3c10 --- /dev/null +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -0,0 +1,160 @@ +module Language.PureScript.Make.BuildPlan + ( BuildPlan() + , construct + , getResult + , collectErrors + , collectResults + , markComplete + , needsRebuild + ) where + +import Prelude + +import Control.Concurrent.Lifted as C +import Control.Monad hiding (sequence) +import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Data.Aeson (decode) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromMaybe) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) +import Data.Version (showVersion) +import Language.PureScript.AST +import Language.PureScript.Crash +import Language.PureScript.Errors +import Language.PureScript.Externs +import Language.PureScript.Make.Actions as Actions +import Language.PureScript.Names (ModuleName) +import qualified Paths_purescript as Paths + +-- | The BuildPlan tracks information about our build progress, and holds all +-- prebuilt modules for incremental builds. +data BuildPlan = BuildPlan + { bpPrebuilt :: M.Map ModuleName Prebuilt + , bpBuildJobs :: M.Map ModuleName BuildJob + } + +data Prebuilt = Prebuilt + { pbModificationTime :: UTCTime + , pbExternsFile :: ExternsFile + } + +data BuildJob = BuildJob + { bjResult :: C.MVar (Maybe (MultipleErrors, ExternsFile)) + , bjErrors :: C.MVar (Maybe MultipleErrors) + } + +-- | Called when we finished compiling a module and want to report back the +-- compilation result, as well as any potential errors that were thrown. +markComplete + :: (MonadBaseControl IO m) + => BuildPlan + -> ModuleName + -> Maybe (MultipleErrors, ExternsFile) + -> Maybe MultipleErrors + -> m () +markComplete buildPlan moduleName result errors = do + let BuildJob rVar eVar = fromMaybe (internalError "make: markComplete no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) + putMVar rVar result + putMVar eVar errors + +-- | Whether or not the module with the given ModuleName needs to be rebuilt +needsRebuild :: BuildPlan -> ModuleName -> Bool +needsRebuild bp moduleName = M.member moduleName (bpBuildJobs bp) + +-- | Collects errors for all modules that have been rebuilt. This will block +-- until all outstanding build jobs are finished. +collectErrors + :: (MonadBaseControl IO m) + => BuildPlan + -> m [MultipleErrors] +collectErrors buildPlan = do + errors <- traverse readMVar $ map bjErrors $ M.elems (bpBuildJobs buildPlan) + pure (catMaybes errors) + +-- | Collects ExternsFiles for all prebuilt as well as rebuilt modules. Panics +-- if any build job returned an error. +collectResults + :: (MonadBaseControl IO m) + => BuildPlan + -> m (M.Map ModuleName ExternsFile) +collectResults buildPlan = do + let externs = M.map pbExternsFile (bpPrebuilt buildPlan) + barrierResults <- traverse (takeMVar . bjResult) $ bpBuildJobs buildPlan + let barrierExterns = M.map (snd . fromMaybe (internalError "make: externs were missing but no errors reported.")) barrierResults + pure (M.union externs barrierExterns) + +-- | Gets the the build result for a given module name independent of whether it +-- was rebuilt or prebuilt. Prebuilt modules always return no warnings. +getResult + :: (MonadBaseControl IO m) + => BuildPlan + -> ModuleName + -> m (Maybe (MultipleErrors, ExternsFile)) +getResult buildPlan moduleName = + case M.lookup moduleName (bpPrebuilt buildPlan) of + Just es -> + pure (Just (MultipleErrors [], pbExternsFile es)) + Nothing -> + readMVar $ bjResult $ fromMaybe (internalError "make: no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) + +-- | Constructs a BuildPlan for the given module graph. +-- +-- The given MakeActions are used to collect various timestamps in order to +-- determine whether a module needs rebuilding. +construct + :: forall m. (Monad m, MonadBaseControl IO m) + => MakeActions m + -> ([Module], [(ModuleName, [ModuleName])]) + -> m BuildPlan +construct MakeActions{..} (sorted, graph) = do + prebuilt <- foldM findExistingExtern M.empty sorted + let toBeRebuilt = filter (not . flip M.member prebuilt . getModuleName) sorted + buildJobs <- foldM makeBuildJob M.empty (map getModuleName toBeRebuilt) + pure $ BuildPlan prebuilt buildJobs + where + makeBuildJob prev moduleName = do + buildJob <- BuildJob <$> C.newEmptyMVar <*> C.newEmptyMVar + pure (M.insert moduleName buildJob prev) + + findExistingExtern :: M.Map ModuleName Prebuilt -> Module -> m (M.Map ModuleName Prebuilt) + findExistingExtern prev (getModuleName -> moduleName) = do + outputTimestamp <- getOutputTimestamp moduleName + let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph) + case traverse (fmap pbModificationTime . flip M.lookup prev) deps of + Nothing -> + -- If we end up here, one of the dependencies didn't exist in the + -- prebuilt map and so we know a dependency needs to be rebuilt, which + -- means we need to be rebuilt in turn. + pure prev + Just modTimes -> do + let dependencyTimestamp = maximumMaybe modTimes + inputTimestamp <- getInputTimestamp moduleName + let + existingExtern = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of + (Right (Just t1), Just t3, Just t2) -> + if t1 > t2 || t3 > t2 then Nothing else Just t2 + (Right (Just t1), Nothing, Just t2) -> + if t1 > t2 then Nothing else Just t2 + (Left RebuildNever, _, Just t2) -> + Just t2 + _ -> + Nothing + case existingExtern of + Nothing -> pure prev + Just outputTime -> do + mexts <- decodeExterns . snd <$> readExterns moduleName + case mexts of + Just exts -> + pure (M.insert moduleName (Prebuilt outputTime exts) prev) + Nothing -> pure prev + +maximumMaybe :: Ord a => [a] -> Maybe a +maximumMaybe [] = Nothing +maximumMaybe xs = Just $ maximum xs + +decodeExterns :: Externs -> Maybe ExternsFile +decodeExterns bs = do + externs <- decode bs + guard $ T.unpack (efVersion externs) == showVersion Paths.version + return externs diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs new file mode 100644 index 0000000000..bbc737e7b3 --- /dev/null +++ b/src/Language/PureScript/Make/Monad.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Language.PureScript.Make.Monad + ( -- * Implementation of Make API using files on disk + Make(..) + , runMake + , makeIO + , readTextFile + ) where + +import Prelude + +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.IO.Class +import Control.Monad.Logger +import Control.Monad.Reader (MonadReader(..), ReaderT(..)) +import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Control.Monad.Trans.Except +import Control.Monad.Writer.Class (MonadWriter(..)) +import qualified Data.ByteString.Lazy as B +import Language.PureScript.AST +import Language.PureScript.Errors +import Language.PureScript.Options +import System.IO.Error (tryIOError) + +-- | A monad for running make actions +newtype Make a = Make + { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a + } deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options) + +instance MonadBase IO Make where + liftBase = liftIO + +instance MonadBaseControl IO Make where + type StM Make a = Either MultipleErrors a + liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake) + restoreM = Make . restoreM + +-- | Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings. +runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors) +runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake + +-- | Run an 'IO' action in the 'Make' monad, by specifying how IO errors should +-- be rendered as 'ErrorMessage' values. +makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a +makeIO f io = do + e <- liftIO $ tryIOError io + either (throwError . singleError . f) return e + +-- | Read a text file in the 'Make' monad, capturing any errors using the +-- 'MonadError' instance. +readTextFile :: FilePath -> Make B.ByteString +readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path From 86d8b5ce0272d8d03a1819891acf2ece342d9e37 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sat, 7 Apr 2018 10:43:49 -0700 Subject: [PATCH 0948/1580] Add compiler derived Prim.Row.Nub class (#3293) --- examples/passing/RowNub.purs | 23 +++++++++++++++++++ src/Language/PureScript/Constants.hs | 3 +++ src/Language/PureScript/Docs/Prim.hs | 6 +++++ src/Language/PureScript/Environment.hs | 8 +++++++ .../PureScript/TypeChecker/Entailment.hs | 14 ++++++++++- 5 files changed, 53 insertions(+), 1 deletion(-) create mode 100644 examples/passing/RowNub.purs diff --git a/examples/passing/RowNub.purs b/examples/passing/RowNub.purs new file mode 100644 index 0000000000..cc9436f11c --- /dev/null +++ b/examples/passing/RowNub.purs @@ -0,0 +1,23 @@ +module Main where + +import Control.Monad.Eff.Console (log) +import Prim.Row (class Nub, class Union) +import Type.Row (RProxy(..)) + +nubUnion + :: forall r1 r2 r3 r4 + . Union r1 r2 r3 + => Nub r3 r4 + => RProxy r1 + -> RProxy r2 + -> RProxy r4 +nubUnion _ _ = RProxy + +type InL = (x :: Int, y :: String) +type InR = (x :: String, y :: Int, z :: Boolean) +type Out = (x :: Int, y :: String, z :: Boolean) + +test :: RProxy Out +test = nubUnion (RProxy :: RProxy InL) (RProxy :: RProxy InR) + +main = log "Done" diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 69e38ab487..4f5ae1fe71 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -434,6 +434,9 @@ pattern Warn = Qualified (Just PrimTypeError) (ProperName "Warn") pattern Union :: Qualified (ProperName 'ClassName) pattern Union = Qualified (Just PrimRow) (ProperName "Union") +pattern Nub :: Qualified (ProperName 'ClassName) +pattern Nub = Qualified (Just PrimRow) (ProperName "Nub") + pattern RowCons :: Qualified (ProperName 'ClassName) pattern RowCons = Qualified (Just PrimRow) (ProperName "Cons") diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 2bd8d4aafa..6c0bdeb253 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -44,6 +44,7 @@ primRowDocsModule = Module , modComments = Just "The Prim.Row module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains automatically solved classes for working with row types." , modDeclarations = [ union + , nub , rowCons ] , modReExports = [] @@ -287,6 +288,11 @@ union = primClassOf (P.primSubName "Row") "Union" $ T.unlines , "The third type argument represents the union of the first two." ] +nub :: Declaration +nub = primClassOf (P.primSubName "Row") "Nub" $ T.unlines + [ "The Nub type class is used to remove duplicate labels from rows." + ] + rowCons :: Declaration rowCons = primClassOf (P.primSubName "Row") "Cons" $ T.unlines [ "The Cons type class is a 4-way relation which asserts that one row of" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index e6a29b99a7..07330d43ef 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -374,6 +374,7 @@ primRowTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) primRowTypes = M.fromList [ (primSubName "Row" "Union", (FunKind (Row kindType) (FunKind (Row kindType) (FunKind (Row kindType) kindType)), ExternData)) + , (primSubName "Row" "Nub", (FunKind (Row kindType) (FunKind (Row kindType) kindType), ExternData)) , (primSubName "Row" "Cons", (FunKind kindSymbol (FunKind kindType (FunKind (Row kindType) (FunKind (Row kindType) kindType))), ExternData)) ] @@ -417,6 +418,13 @@ primRowClasses = , FunctionalDependency [1, 2] [0] , FunctionalDependency [2, 0] [1] ])) + -- class Nub (i :: # Type) (o :: # Type) | i -> o + , (primSubName "Row" "Nub", (makeTypeClassData + [ ("i", Just (Row kindType)) + , ("o", Just (Row kindType)) + ] [] [] + [ FunctionalDependency [0] [1] + ])) -- class RowCons (l :: Symbol) (a :: Type) (i :: # Type) (o :: # Type) | l i a -> o, l o -> a i , (primSubName "Row" "Cons", (makeTypeClassData [ ("l", Just kindSymbol) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index f882dfe170..354a3f51d6 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -23,7 +23,7 @@ import Control.Monad.Writer import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.Functor (($>)) -import Data.List (minimumBy, groupBy, sortBy) +import Data.List (minimumBy, groupBy, nubBy, sortBy) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -57,6 +57,7 @@ data Evidence | AppendSymbolInstance | UnionInstance | ConsInstance + | NubInstance | RowToListInstance deriving (Show, Eq) @@ -190,6 +191,9 @@ entails SolverOptions{..} constraint context hints = forClassName _ C.Union [l, r, u] | Just (lOut, rOut, uOut, cst) <- unionRows l r u = [ TypeClassDictionaryInScope [] 0 UnionInstance [] C.Union [lOut, rOut, uOut] cst ] + forClassName _ C.Nub [r, _] + | Just r' <- nubRows r + = [ TypeClassDictionaryInScope [] 0 NubInstance [] C.Nub [r, r'] Nothing ] forClassName _ C.RowCons [TypeLevelString sym, ty, r, _] = [ TypeClassDictionaryInScope [] 0 ConsInstance [] C.RowCons [TypeLevelString sym, ty, r, RCons (Label sym) ty r] Nothing ] forClassName _ C.RowToList [r, _] @@ -363,6 +367,7 @@ entails SolverOptions{..} constraint context hints = return $ App (Abs (VarBinder nullSourceSpan UnusedIdent) valUndefined) e mkDictionary UnionInstance _ = return valUndefined mkDictionary ConsInstance _ = return valUndefined + mkDictionary NubInstance _ = return valUndefined mkDictionary RowToListInstance _ = return valUndefined mkDictionary (WarnInstance msg) _ = do tell . errorMessage $ UserDefinedWarning msg @@ -446,6 +451,13 @@ entails SolverOptions{..} constraint context hints = , ty , tl ] + nubRows :: Type -> Maybe Type + nubRows r = + guard (REmpty == rest) $> + rowFromList (nubBy ((==) `on` fst) fixed, rest) + where + (fixed, rest) = rowToSortedList r + -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a -- substitution which makes them match. If not, we return 'Nothing'. From a5e87c7b9339f1f336cc233f9caa275f18c7b27b Mon Sep 17 00:00:00 2001 From: Vladimir Ciobanu Date: Wed, 11 Apr 2018 01:10:43 +0300 Subject: [PATCH 0949/1580] updated docs for RowCons and RowUnion (#3292) * updated docs for RowCons and RowUnion * updated contributors --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Environment.hs | 22 +++++++++++----------- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index c127ff37d4..79b8ff6064 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -114,6 +114,7 @@ If you would prefer to use different terms, please use the section below instead | [@trofi](https://github.com/trofi) | Sergei Trofimovich | [MIT license](http://opensource.org/licenses/MIT) | | [@utkarshkukreti](https://github.com/utkarshkukreti) | Utkarsh Kukreti | [MIT license](http://opensource.org/licenses/MIT) | | [@vkorablin](https://github.com/vkorablin) | Vladimir Korablin | MIT license | +| [@vladciobanu](https://github.com/vladciobanu) | Vladimir Ciobanu | [MIT license](http://opensource.org/licenses/MIT) | | [@zudov](https://github.com/zudov) | Konstantin Zudov | [MIT license](http://opensource.org/licenses/MIT) | | [@b123400](https://github.com/b123400) | b123400 | [MIT license](https://opensource.org/licenses/MIT) | | [@kcsongor](https://github.com/kcsongor) | Csongor Kiss | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 07330d43ef..3a756d768c 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -408,29 +408,29 @@ primRowClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primRowClasses = M.fromList [ - -- class Union (l :: # Type) (r :: # Type) (u :: # Type) | l r -> u, r u -> l, u l -> r + -- class Union (left :: # Type) (right :: # Type) (union :: # Type) | left right -> union, right union -> left, union left -> right (primSubName "Row" "Union", (makeTypeClassData - [ ("l", Just (Row kindType)) - , ("r", Just (Row kindType)) - , ("u", Just (Row kindType)) + [ ("left", Just (Row kindType)) + , ("right", Just (Row kindType)) + , ("union", Just (Row kindType)) ] [] [] [ FunctionalDependency [0, 1] [2] , FunctionalDependency [1, 2] [0] , FunctionalDependency [2, 0] [1] ])) - -- class Nub (i :: # Type) (o :: # Type) | i -> o + -- class Nub (original :: # Type) (nubbed :: # Type) | i -> o , (primSubName "Row" "Nub", (makeTypeClassData - [ ("i", Just (Row kindType)) - , ("o", Just (Row kindType)) + [ ("original", Just (Row kindType)) + , ("nubbed", Just (Row kindType)) ] [] [] [ FunctionalDependency [0] [1] ])) - -- class RowCons (l :: Symbol) (a :: Type) (i :: # Type) (o :: # Type) | l i a -> o, l o -> a i + -- class RowCons (label :: Symbol) (a :: Type) (tail :: # Type) (row :: # Type) | label tail a -> row, label row -> tail a , (primSubName "Row" "Cons", (makeTypeClassData - [ ("l", Just kindSymbol) + [ ("label", Just kindSymbol) , ("a", Just kindType) - , ("i", Just (Row kindType)) - , ("o", Just (Row kindType)) + , ("tail", Just (Row kindType)) + , ("row", Just (Row kindType)) ] [] [] [ FunctionalDependency [0, 1, 2] [3] , FunctionalDependency [0, 3] [1, 2] From f88caabdb33d4ca1eef5f30fe1d37b9fea6a69f0 Mon Sep 17 00:00:00 2001 From: Tom Harding Date: Tue, 10 Apr 2018 23:20:53 +0100 Subject: [PATCH 0950/1580] Allow functor derivation under quantification (#3295) * Allow functor derivation under quantification When "functor variables" exist within a quantifier, they don't seem to derive properly: ``` data T a = T (forall x. a) ``` This commit (hopefully!) fixes this, allowing the compiler to drill down through these skolem scopes. * Allow for constraints in derived functors, quantification shadowing - One can now derive functors for types that involve constraints. - Shadowed variables are now properly handled in functor deriving. tl;dr: this works now! ``` data T a = T (forall x. Show x => a) (forall a. a) ``` --- examples/passing/DerivingFunctor.purs | 9 ++++++++- src/Language/PureScript/Sugar/TypeClasses/Deriving.hs | 6 ++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/examples/passing/DerivingFunctor.purs b/examples/passing/DerivingFunctor.purs index 765564bb91..18c4deed90 100644 --- a/examples/passing/DerivingFunctor.purs +++ b/examples/passing/DerivingFunctor.purs @@ -15,9 +15,11 @@ data M f a | M4 (MyRecord a) derive instance eqM :: (Eq1 f, Eq a) => Eq (M f a) - derive instance functorM :: Functor f => Functor (M f) +data T a = T (forall t. Show t => t -> a) +derive instance functorT :: Functor T + type MA = M Array main = do @@ -26,4 +28,9 @@ main = do assert $ map show (M2 [0, 1] :: MA Int) == M2 ["0", "1"] assert $ map show (M3 {foo: 0, bar: 1, baz: [2, 3]} :: MA Int) == M3 {foo: 0, bar: "1", baz: ["2", "3"]} assert $ map show (M4 { myField: 42 }) == M4 { myField: "42" } :: MA String + + case map show (T \_ -> 42) of + T f -> assert $ f "hello" == "42" + _ -> assert false + log "Done" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 1d8100f1fe..678e6274ed 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -742,6 +742,12 @@ deriveFunctor ss mn syns ds tyConNm = do mkAssignment ((Label l), x) = (l, App x (Accessor l argVar)) return (lam ss arg (ObjectUpdate argVar (mkAssignment <$> updates))) + -- quantifiers + goType (ForAll scopedVar t _) | scopedVar /= iTyName = goType t + + -- constraints + goType (ConstrainedType _ t) = goType t + -- under a `* -> *`, just assume functor for now goType (TypeApp _ t) = fmap (App mapVar) <$> goType t From 1b541b8807e3d52de00ba10431f6295e958c0425 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Wed, 11 Apr 2018 08:05:20 -0600 Subject: [PATCH 0951/1580] Add a Makefile with ghcid and testing commands (#3290) * ghcid is love * gotta go fast --- Makefile | 35 +++++++++++++++++++++-------------- package.yaml | 2 ++ tests/TestHierarchy.hs | 2 ++ tests/TestIde.hs | 2 ++ tests/TestPrimDocs.hs | 2 ++ tests/TestPscPublish.hs | 2 ++ 6 files changed, 31 insertions(+), 14 deletions(-) diff --git a/Makefile b/Makefile index 060386a5df..8316136b5f 100644 --- a/Makefile +++ b/Makefile @@ -3,25 +3,35 @@ exe_target = purs stack_yaml = STACK_YAML="stack.yaml" stack = $(stack_yaml) stack -build: +help: ## Print documentation + @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' + +ghcid: ## Run ghcid to quickly reload code on save. + ghcid --command "stack ghci purescript:lib purescript:test:tests --ghci-options -fno-code" + +ghcid-test: ## Run ghcid to quickly reload code and run tests on save. + ghcid --command "stack ghci purescript:lib purescript:test:tests --ghci-options -fobject-code" \ + --test "Main.main" + +build: ## Build the package. $(stack) build $(package) -build-dirty: +build-dirty: ## Force recompilation of the entire package. $(stack) build --ghc-options=-fforce-recomp $(package) -run: - $(stack) build --fast && $(stack) exec -- $(package) +run: ## Run the compiler. + $(stack) build --fast && $(stack) exec -- $(exe_target) -install: +install: ## Install the executables to stack's path $(stack) install -ghci: +ghci: ## Open GHCi with the PureScript library $(stack) ghci $(package):lib -test: +test: ## Run the tests. $(stack) test --fast $(package) -test-ghci: +test-ghci: ## Open GHCi with the test suite loaded. $(stack) ghci $(package):test:$(package)-tests # If you want to profile a particular test, such @@ -33,20 +43,17 @@ test-ghci: # symlinked the Perl script into my path. # Open the SVG with your browser, you can reload the browser when you # rerun the profiled test run. -test-profiling: +test-profiling: ## Run the tests, with profiling enabled. Also builds a flamegraph of the test. $(stack) test --executable-profiling --ta '+RTS -pj -RTS' $(package) cat tests.prof | stack exec ghc-prof-aeson-flamegraph | flamegraph.pl > tests.svg -bench: +bench: ## Run benchmarks for PureScript $(stack) bench $(package) -ghcid: - $(stack) exec -- ghcid -c "stack ghci $(package):lib --test --ghci-options='-fobject-code -fno-warn-unused-do-bind'" - # if you want these to be globally available run it outside of purescript # but incompatibilities might arise between ghcid and the version of GHC # you're using to build PureScript. -dev-deps: +dev-deps: ## Install helpful development tools. stack install ghcid ghc-prof-aeson-flamegraph .PHONY : build build-dirty run install ghci test test-ghci test-profiling ghcid dev-deps diff --git a/package.yaml b/package.yaml index 19ce9c58c2..080f7da111 100644 --- a/package.yaml +++ b/package.yaml @@ -158,6 +158,8 @@ tests: - hspec - hspec-discover - HUnit + default-extensions: + - NoImplicitPrelude flags: release: diff --git a/tests/TestHierarchy.hs b/tests/TestHierarchy.hs index 9737fd0789..898f869f8f 100644 --- a/tests/TestHierarchy.hs +++ b/tests/TestHierarchy.hs @@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module TestHierarchy where +import Prelude + import Language.PureScript.Hierarchy import qualified Language.PureScript as P diff --git a/tests/TestIde.hs b/tests/TestIde.hs index 801e5436aa..8879d85a1e 100644 --- a/tests/TestIde.hs +++ b/tests/TestIde.hs @@ -1,5 +1,7 @@ module TestIde where +import Prelude + import Control.Monad (unless) import Language.PureScript.Ide.Test import qualified PscIdeSpec diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index 70ab317847..b23c037664 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -1,5 +1,7 @@ module TestPrimDocs where +import Prelude + import Control.Monad import Data.Monoid ((<>)) import Data.List ((\\)) diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 89c6f4cd7e..9126d36ced 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -4,6 +4,8 @@ module TestPscPublish where +import Prelude + import Control.Monad.IO.Class (liftIO) import System.Exit (exitFailure) import Data.ByteString.Lazy (ByteString) From e996ca181dcc08f26e4ef1e49f8c5bc2a58c503d Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Thu, 12 Apr 2018 19:37:51 +0100 Subject: [PATCH 0952/1580] Raise warning for re-export of qualified module with implicit imports (#3299) Resolves #2726 --- .../ImplicitQualifiedImportReExport.purs | 13 +++++++++++++ src/Language/PureScript/AST/Declarations.hs | 1 + src/Language/PureScript/Errors.hs | 7 +++++++ src/Language/PureScript/Linter/Imports.hs | 17 +++++++++++++++++ 4 files changed, 38 insertions(+) create mode 100644 examples/warning/ImplicitQualifiedImportReExport.purs diff --git a/examples/warning/ImplicitQualifiedImportReExport.purs b/examples/warning/ImplicitQualifiedImportReExport.purs new file mode 100644 index 0000000000..6f6ea6a9c8 --- /dev/null +++ b/examples/warning/ImplicitQualifiedImportReExport.purs @@ -0,0 +1,13 @@ +-- @shouldWarnWith ImplicitQualifiedImportReExport +-- @shouldWarnWith ImplicitQualifiedImportReExport +module Main (module X, module Y, main) where + +import Prelude + +import Control.Monad.Eff (Eff) +import Control.Monad.Eff.Console (CONSOLE, log) +import Data.Maybe as X +import Data.Either as Y + +main :: Eff (console :: CONSOLE) Unit +main = log "test" diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index c961f718ae..2072b340ba 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -158,6 +158,7 @@ data SimpleErrorMessage | DuplicateExportRef Name | IntOutOfRange Integer Text Integer Integer | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef] + | ImplicitQualifiedImportReExport ModuleName ModuleName [DeclarationRef] | ImplicitImport ModuleName [DeclarationRef] | HidingImport ModuleName [DeclarationRef] | CaseBinderLengthDiffers Int [Binder] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index ec35d452f0..fc24475c04 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -167,6 +167,7 @@ errorCode em = case unwrapErrorMessage em of DuplicateExportRef{} -> "DuplicateExportRef" IntOutOfRange{} -> "IntOutOfRange" ImplicitQualifiedImport{} -> "ImplicitQualifiedImport" + ImplicitQualifiedImportReExport{} -> "ImplicitQualifiedImportReExport" ImplicitImport{} -> "ImplicitImport" HidingImport{} -> "HidingImport" CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers" @@ -314,6 +315,7 @@ errorSuggestion err = UnusedDctorExplicitImport mn _ _ qual refs -> suggest $ importSuggestion mn refs qual ImplicitImport mn refs -> suggest $ importSuggestion mn refs Nothing ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) + ImplicitQualifiedImportReExport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing MissingTypeDeclaration ident ty -> suggest $ showIdent ident <> " :: " <> T.pack (prettyPrintSuggestedType ty) WildcardInferredType ty _ -> suggest $ T.pack (prettyPrintSuggestedType ty) @@ -914,6 +916,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , line $ "As there are multiple modules being imported as " <> markCode (runModuleName asModule) <> ", consider using the explicit form:" , indent $ line $ markCode $ showSuggestion msg ] + renderSimpleErrorMessage msg@(ImplicitQualifiedImportReExport importedModule asModule _) = + paras [ line $ "Module " <> markCode (runModuleName importedModule) <> " was imported as " <> markCode (runModuleName asModule) <> " with unspecified imports." + , line $ "As this module is being re-exported, consider using the explicit form:" + , indent $ line $ markCode $ showSuggestion msg + ] renderSimpleErrorMessage msg@(ImplicitImport mn _) = paras [ line $ "Module " <> markCode (runModuleName mn) <> " has unspecified imports, consider using the explicit form: " diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 19e7662aad..bfb0f9dbc3 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -106,6 +106,23 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do Hiding refs -> refs _ -> [] + -- Check re-exported modules to see if we are re-exporting a qualified module + -- that has unspecified imports. + for_ mexports $ \case + ModuleRef _ mnq -> + case M.lookup mnq (byQual imports) of + -- We only match the single-entry case here as otherwise there will be + -- a different warning about implicit imports potentially colliding + -- anyway + Just [(ss, Implicit, mni)] -> do + let names = ordNub $ M.findWithDefault [] mni usedImps' + usedRefs = findUsedRefs ss env mni (Just mnq) names + tell . errorMessage' ss $ + ImplicitQualifiedImportReExport mni mnq + $ map (simplifyTypeRef $ const True) usedRefs + _ -> pure () + _ -> pure () + where defQual :: ImportDef -> Maybe ModuleName From 143c86548851c13dcb24f32ee2fe4fb06a6756f5 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 13 Apr 2018 01:05:59 +0100 Subject: [PATCH 0953/1580] Update `Effect` inlining (#3301) --- src/Language/PureScript/Constants.hs | 11 ++++++++++- src/Language/PureScript/CoreImp/Optimizer/Inliner.hs | 11 ++++++----- 2 files changed, 16 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 4f5ae1fe71..8fd335b23a 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -240,6 +240,12 @@ mkEffFn = "mkEffFn" runEffFn :: forall a. (IsString a) => a runEffFn = "runEffFn" +mkEffectFn :: forall a. (IsString a) => a +mkEffectFn = "mkEffectFn" + +runEffectFn :: forall a. (IsString a) => a +runEffectFn = "runEffectFn" + -- Prim values undefined :: forall a. (IsString a) => a @@ -461,7 +467,7 @@ eff :: forall a. (IsString a) => a eff = "Control_Monad_Eff" effect :: forall a. (IsString a) => a -effect = "Control_Monad_Effect" +effect = "Effect" st :: forall a. (IsString a) => a st = "Control_Monad_ST" @@ -481,6 +487,9 @@ controlBind = "Control_Bind" controlMonadEffUncurried :: forall a. (IsString a) => a controlMonadEffUncurried = "Control_Monad_Eff_Uncurried" +effectUncurried :: forall a. (IsString a) => a +effectUncurried = "Effect_Uncurried" + dataBounded :: forall a. (IsString a) => a dataBounded = "Data_Bounded" diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index ae291a2ee0..719579328f 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -171,7 +171,8 @@ inlineCommonOperators = everywhereTopDown $ applyAll $ , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing) ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++ - [ fn | i <- [0..10], fn <- [ mkEffFn i, runEffFn i ] ] + [ fn | i <- [0..10], fn <- [ mkEffFn C.controlMonadEffUncurried C.mkEffFn i, runEffFn C.controlMonadEffUncurried C.runEffFn i ] ] ++ + [ fn | i <- [0..10], fn <- [ mkEffFn C.effectUncurried C.mkEffectFn i, runEffFn C.effectUncurried C.runEffectFn i ] ] where binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST binary dict fns op = convert where @@ -198,8 +199,8 @@ inlineCommonOperators = everywhereTopDown $ applyAll $ mkFn = mkFn' C.dataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args js -> Function ss1 Nothing args (Block ss2 [Return ss3 js]) - mkEffFn :: Int -> AST -> AST - mkEffFn = mkFn' C.controlMonadEffUncurried C.mkEffFn $ \ss1 ss2 ss3 args js -> + mkEffFn :: Text -> Text -> Int -> AST -> AST + mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args js -> Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 js [])]) mkFn' :: Text -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST @@ -228,8 +229,8 @@ inlineCommonOperators = everywhereTopDown $ applyAll $ runFn :: Int -> AST -> AST runFn = runFn' C.dataFunctionUncurried C.runFn App - runEffFn :: Int -> AST -> AST - runEffFn = runFn' C.controlMonadEffUncurried C.runEffFn $ \ss fn acc -> + runEffFn :: Text -> Text -> Int -> AST -> AST + runEffFn modName fnName = runFn' modName fnName $ \ss fn acc -> Function ss Nothing [] (Block ss [Return ss (App ss fn acc)]) runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST From 75d1e8bb284f65b81e77ba2fce55b5243bc29f3f Mon Sep 17 00:00:00 2001 From: Tom Harding Date: Fri, 13 Apr 2018 11:46:15 +0100 Subject: [PATCH 0954/1580] Tidy up "undetermined class argument" warning (#3304) --- src/Language/PureScript/Errors.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index fc24475c04..433cac2ba1 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -987,7 +987,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl case unexplained of [required] -> - [ line $ "These arguments are: { " <> T.intercalate "," required <> "}" + [ line $ "These arguments are: { " <> T.intercalate ", " required <> " }" ] options -> From f5f347959716e401b6956d86ae5464fb3ea10a66 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Fri, 13 Apr 2018 11:55:32 +0100 Subject: [PATCH 0955/1580] Switch to Doc for custom type errors & remove TypeConcat/TypeString (#3298) --- examples/docs/src/TypeLevelString.purs | 4 +- examples/failing/2567.purs | 2 +- examples/failing/ProgrammableTypeErrors.purs | 2 +- .../ProgrammableTypeErrorsTypeString.purs | 11 +++- examples/passing/2663.purs | 4 +- examples/warning/CustomWarning.purs | 2 +- examples/warning/CustomWarning2.purs | 4 +- examples/warning/CustomWarning3.purs | 4 +- src/Language/PureScript/Constants.hs | 9 +++ src/Language/PureScript/Docs/Prim.hs | 60 +++++++++++++++---- src/Language/PureScript/Environment.hs | 33 ++++++---- src/Language/PureScript/Errors.hs | 9 ++- src/Language/PureScript/Kinds.hs | 4 +- tests/support/bower.json | 4 +- 14 files changed, 108 insertions(+), 44 deletions(-) diff --git a/examples/docs/src/TypeLevelString.purs b/examples/docs/src/TypeLevelString.purs index 60f500b615..7c55068a18 100644 --- a/examples/docs/src/TypeLevelString.purs +++ b/examples/docs/src/TypeLevelString.purs @@ -1,9 +1,9 @@ module TypeLevelString where -import Prim.TypeError (class Fail) +import Prim.TypeError (class Fail, Text) data Foo class Bar a -instance fooBar :: Fail "oops" => Bar Foo +instance fooBar :: Fail (Text "oops") => Bar Foo diff --git a/examples/failing/2567.purs b/examples/failing/2567.purs index eb243a2a64..4d601cc280 100644 --- a/examples/failing/2567.purs +++ b/examples/failing/2567.purs @@ -4,4 +4,4 @@ module Main where import Prim.TypeError foo :: Int -foo = (0 :: Fail "This constraint should be checked" => Int) +foo = (0 :: Fail (Text "This constraint should be checked") => Int) diff --git a/examples/failing/ProgrammableTypeErrors.purs b/examples/failing/ProgrammableTypeErrors.purs index e7cd509405..845a3251b1 100644 --- a/examples/failing/ProgrammableTypeErrors.purs +++ b/examples/failing/ProgrammableTypeErrors.purs @@ -10,7 +10,7 @@ import Control.Monad.Eff.Console (log) class MyShow a where myShow :: a -> String -instance cannotShowFunctions :: Fail "Cannot show functions" => MyShow (a -> b) where +instance cannotShowFunctions :: Fail (Text "Cannot show functions") => MyShow (a -> b) where myShow _ = "unreachable" main :: Eff _ _ diff --git a/examples/failing/ProgrammableTypeErrorsTypeString.purs b/examples/failing/ProgrammableTypeErrorsTypeString.purs index a5759fa103..904e127e4e 100644 --- a/examples/failing/ProgrammableTypeErrorsTypeString.purs +++ b/examples/failing/ProgrammableTypeErrorsTypeString.purs @@ -9,10 +9,15 @@ import Control.Monad.Eff.Console (log) newtype MyType a = MyType a -instance cannotShowFunctions :: Fail ("Don't want to show " <> TypeString (MyType a) <> " because.") => Show (MyType a) where - show _ = "unreachable" +instance cannotShowFunctions :: + Fail ( Text "Don't want to show " <> + Quote (MyType a) <> + Text " because." + ) => Show (MyType a) + where + show _ = "unreachable" -infixl 6 type TypeConcat as <> +infixl 6 type Beside as <> main :: Eff _ _ main = do diff --git a/examples/passing/2663.purs b/examples/passing/2663.purs index dd0d1e5c22..0e690908a2 100644 --- a/examples/passing/2663.purs +++ b/examples/passing/2663.purs @@ -1,10 +1,10 @@ module Main where import Prelude -import Prim.TypeError (class Warn) +import Prim.TypeError (class Warn, Text) import Control.Monad.Eff.Console (log) -foo :: forall t. Warn "Example" => t -> t +foo :: forall t. Warn (Text "Example") => t -> t foo x = x main = when (foo 42 == 42) $ log "Done" diff --git a/examples/warning/CustomWarning.purs b/examples/warning/CustomWarning.purs index f223900456..7d509ebb20 100644 --- a/examples/warning/CustomWarning.purs +++ b/examples/warning/CustomWarning.purs @@ -3,7 +3,7 @@ module Main where import Prim.TypeError -foo :: forall t. Warn (TypeConcat "Custom warning " (TypeString t)) => t -> t +foo :: forall t. Warn (Beside (Text "Custom warning ") (Quote t)) => t -> t foo x = x bar :: Int diff --git a/examples/warning/CustomWarning2.purs b/examples/warning/CustomWarning2.purs index c217899c6d..488dc4d724 100644 --- a/examples/warning/CustomWarning2.purs +++ b/examples/warning/CustomWarning2.purs @@ -3,10 +3,10 @@ module Main where import Prim.TypeError -foo :: Warn "foo" => Int -> Int +foo :: Warn (Text "foo") => Int -> Int foo x = x -bar :: Warn "foo" => Int +bar :: Warn (Text "foo") => Int bar = foo 42 baz :: Int diff --git a/examples/warning/CustomWarning3.purs b/examples/warning/CustomWarning3.purs index 07d9ba10f9..a43cce6c9e 100644 --- a/examples/warning/CustomWarning3.purs +++ b/examples/warning/CustomWarning3.purs @@ -4,11 +4,11 @@ module Main where import Prim.TypeError -foo :: Warn "foo" => Int -> Int +foo :: Warn (Text "foo") => Int -> Int foo x = x -- Defer the "foo" warning and warn with "bar" as well -bar :: Warn "foo" => Warn "bar" => Int +bar :: Warn (Text "foo") => Warn (Text "bar") => Int bar = foo 42 baz :: Int diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 8fd335b23a..a4641028ef 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -452,11 +452,20 @@ typ = "Type" symbol :: forall a. (IsString a) => a symbol = "Symbol" +doc :: forall a. (IsString a) => a +doc = "Doc" + -- Modules prim :: forall a. (IsString a) => a prim = "Prim" +typeError :: forall a. (IsString a) => a +typeError = "TypeError" + +row :: forall a. (IsString a) => a +row = "Row" + prelude :: forall a. (IsString a) => a prelude = "Prelude" diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 6c0bdeb253..442176f25e 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -57,8 +57,11 @@ primTypeErrorDocsModule = Module , modDeclarations = [ warn , fail - , typeConcat - , typeString + , kindDoc + , textDoc + , quoteDoc + , besideDoc + , aboveDoc ] , modReExports = [] } @@ -79,9 +82,13 @@ unsafeLookupOf k m errorMsg name = go name fromJust' (Just x) = x fromJust' _ = P.internalError $ errorMsg ++ show name -primKind :: Text -> Text -> Declaration -primKind title comments = - if Set.member (P.primName title) P.primKinds +primKindOf + :: NameGen 'P.KindName + -> Text + -> Text + -> Declaration +primKindOf g title comments = + if Set.member (g title) P.primKinds then Declaration { declTitle = title , declComments = Just comments @@ -91,6 +98,9 @@ primKind title comments = } else P.internalError $ "Docs.Prim: No such Prim kind: " ++ T.unpack title +primKind :: Text -> Text -> Declaration +primKind = primKindOf P.primName + lookupPrimTypeKindOf :: NameGen 'P.TypeName -> Text @@ -300,18 +310,44 @@ rowCons = primClassOf (P.primSubName "Row") "Cons" $ T.unlines , "the left." ] -typeConcat :: Declaration -typeConcat = primTypeOf (P.primSubName "TypeError") "TypeConcat" $ T.unlines - [ "The TypeConcat type constructor concatenates two Symbols in a custom type" - , "error." +kindDoc :: Declaration +kindDoc = primKindOf (P.primSubName "TypeError") "Doc" $ T.unlines + [ "`Doc` is the kind of type-level documents." + , "" + , "This kind is used with the `Fail` and `Warn` type clases." + , "Build up a `Doc` with `Text`, `Quote`, `Beside`, and `Above`." + ] + +textDoc :: Declaration +textDoc = primTypeOf (P.primSubName "TypeError") "Text" $ T.unlines + [ "The Text type constructor makes a Doc from a Symbol" + , "to be used in a custom type error." + , "" + , "For more information, see" + , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." + ] + +quoteDoc :: Declaration +quoteDoc = primTypeOf (P.primSubName "TypeError") "Quote" $ T.unlines + [ "The Quote type constructor renders any concrete type as a Doc" + , "to be used in a custom type error." + , "" + , "For more information, see" + , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." + ] + +besideDoc :: Declaration +besideDoc = primTypeOf (P.primSubName "TypeError") "Beside" $ T.unlines + [ "The Beside type constructor combines two Docs horizontally" + , "to be used in a custom type error." , "" , "For more information, see" , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." ] -typeString :: Declaration -typeString = primTypeOf (P.primSubName "TypeError") "TypeString" $ T.unlines - [ "The TypeString type constructor renders any concrete type into a Symbol" +aboveDoc :: Declaration +aboveDoc = primTypeOf (P.primSubName "TypeError") "Above" $ T.unlines + [ "The Above type constructor combines two Docs vertically" , "in a custom type error." , "" , "For more information, see" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 3a756d768c..f23648e7da 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -269,6 +269,9 @@ primSubName sub = primKind :: Text -> Kind primKind = NamedKind . primName +primSubKind :: Text -> Text -> Kind +primSubKind sub = NamedKind . primSubName sub + -- | Kind of ground types kindType :: Kind kindType = primKind C.typ @@ -276,6 +279,9 @@ kindType = primKind C.typ kindSymbol :: Kind kindSymbol = primKind C.symbol +kindDoc :: Kind +kindDoc = primSubKind C.typeError C.doc + -- | Construct a type in the Prim module primTy :: Text -> Type primTy = TypeConstructor . primName @@ -334,6 +340,7 @@ primKinds = S.fromList [ primName C.typ , primName C.symbol + , primSubName C.typeError C.doc ] -- | The primitive types in the external javascript environment with their @@ -364,18 +371,20 @@ allPrimTypes = M.unions primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) primTypeErrorTypes = M.fromList - [ (primSubName "TypeError" "Fail", (FunKind kindSymbol kindType, ExternData)) - , (primSubName "TypeError" "Warn", (FunKind kindSymbol kindType, ExternData)) - , (primSubName "TypeError" "TypeString", (FunKind kindType kindSymbol, ExternData)) - , (primSubName "TypeError" "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData)) + [ (primSubName C.typeError "Fail", (FunKind kindDoc kindType, ExternData)) + , (primSubName C.typeError "Warn", (FunKind kindDoc kindType, ExternData)) + , (primSubName C.typeError "Text", (FunKind kindSymbol kindDoc, ExternData)) + , (primSubName C.typeError "Quote", (FunKind kindType kindDoc, ExternData)) + , (primSubName C.typeError "Beside", (FunKind kindDoc (FunKind kindDoc kindDoc), ExternData)) + , (primSubName C.typeError "Above", (FunKind kindDoc (FunKind kindDoc kindDoc), ExternData)) ] primRowTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) primRowTypes = M.fromList - [ (primSubName "Row" "Union", (FunKind (Row kindType) (FunKind (Row kindType) (FunKind (Row kindType) kindType)), ExternData)) - , (primSubName "Row" "Nub", (FunKind (Row kindType) (FunKind (Row kindType) kindType), ExternData)) - , (primSubName "Row" "Cons", (FunKind kindSymbol (FunKind kindType (FunKind (Row kindType) (FunKind (Row kindType) kindType))), ExternData)) + [ (primSubName C.row "Union", (FunKind (Row kindType) (FunKind (Row kindType) (FunKind (Row kindType) kindType)), ExternData)) + , (primSubName C.row "Nub", (FunKind (Row kindType) (FunKind (Row kindType) kindType), ExternData)) + , (primSubName C.row "Cons", (FunKind kindSymbol (FunKind kindType (FunKind (Row kindType) (FunKind (Row kindType) kindType))), ExternData)) ] -- | The primitive class map. This just contains the `Partial` class. @@ -399,9 +408,9 @@ primTypeErrorClasses = M.fromList [ -- class Fail (message :: Symbol) - (primSubName "TypeError" "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] [])) + (primSubName C.typeError "Fail", (makeTypeClassData [("message", Just kindDoc)] [] [] [])) -- class Warn (message :: Symbol) - , (primSubName "TypeError" "Warn", (makeTypeClassData [("message", Just kindSymbol)] [] [] [])) + , (primSubName C.typeError "Warn", (makeTypeClassData [("message", Just kindDoc)] [] [] [])) ] primRowClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData @@ -409,7 +418,7 @@ primRowClasses = M.fromList [ -- class Union (left :: # Type) (right :: # Type) (union :: # Type) | left right -> union, right union -> left, union left -> right - (primSubName "Row" "Union", (makeTypeClassData + (primSubName C.row "Union", (makeTypeClassData [ ("left", Just (Row kindType)) , ("right", Just (Row kindType)) , ("union", Just (Row kindType)) @@ -419,14 +428,14 @@ primRowClasses = , FunctionalDependency [2, 0] [1] ])) -- class Nub (original :: # Type) (nubbed :: # Type) | i -> o - , (primSubName "Row" "Nub", (makeTypeClassData + , (primSubName C.row "Nub", (makeTypeClassData [ ("original", Just (Row kindType)) , ("nubbed", Just (Row kindType)) ] [] [] [ FunctionalDependency [0] [1] ])) -- class RowCons (label :: Symbol) (a :: Type) (tail :: # Type) (row :: # Type) | label tail a -> row, label row -> tail a - , (primSubName "Row" "Cons", (makeTypeClassData + , (primSubName C.row "Cons", (makeTypeClassData [ ("label", Just kindSymbol) , ("a", Just kindType) , ("tail", Just (Row kindType)) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 433cac2ba1..4ce303ce5a 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1382,10 +1382,15 @@ toTypelevelString :: Type -> Maybe Box.Box toTypelevelString (TypeLevelString s) = Just . Box.text $ decodeStringWithReplacement s toTypelevelString (TypeApp (TypeConstructor f) x) - | f == primName "TypeString" = Just (typeAsBox x) + | f == primSubName C.typeError "Text" = toTypelevelString x +toTypelevelString (TypeApp (TypeConstructor f) x) + | f == primSubName C.typeError "Quote" = Just (typeAsBox x) toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret) - | f == primName "TypeConcat" = + | f == primSubName C.typeError "Beside" = (Box.<>) <$> toTypelevelString x <*> toTypelevelString ret +toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret) + | f == primSubName C.typeError "Above" = + (Box.//) <$> toTypelevelString x <*> toTypelevelString ret toTypelevelString _ = Nothing -- | Rethrow an error with a more detailed error message in the case of failure diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 8de3b29daa..2088a3fb06 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -81,8 +81,8 @@ kindFromJSON = do primKind :: Text -> Kind primKind = NamedKind . primName - kindType = primKind "Type" - kindSymbol = primKind "Symbol" + kindType = primKind C.typ + kindSymbol = primKind C.symbol instance A.FromJSON Kind where parseJSON = toAesonParser id kindFromJSON diff --git a/tests/support/bower.json b/tests/support/bower.json index 37b855c8b4..ce19d3bde3 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -19,7 +19,7 @@ "purescript-integers": "3.1.0", "purescript-invariant": "3.0.0", "purescript-lazy": "3.0.0", - "purescript-lists": "purescript/purescript-lists#compiler/0.12", + "purescript-lists": "LiamGoodacre/purescript-lists#feature/error-doc", "purescript-math": "2.1.0", "purescript-maybe": "3.0.0", "purescript-monoid": "3.1.0", @@ -42,6 +42,6 @@ }, "resolutions": { "purescript-symbols": "compiler/0.12", - "purescript-lists": "compiler/0.12" + "purescript-lists": "feature/error-doc" } } From 1d9e0ff3f41288bfdd89df9e59a680c3d59eb6e8 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Fri, 13 Apr 2018 14:16:57 +0100 Subject: [PATCH 0956/1580] Revert tests support deps (#3306) --- tests/support/bower.json | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/support/bower.json b/tests/support/bower.json index ce19d3bde3..37b855c8b4 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -19,7 +19,7 @@ "purescript-integers": "3.1.0", "purescript-invariant": "3.0.0", "purescript-lazy": "3.0.0", - "purescript-lists": "LiamGoodacre/purescript-lists#feature/error-doc", + "purescript-lists": "purescript/purescript-lists#compiler/0.12", "purescript-math": "2.1.0", "purescript-maybe": "3.0.0", "purescript-monoid": "3.1.0", @@ -42,6 +42,6 @@ }, "resolutions": { "purescript-symbols": "compiler/0.12", - "purescript-lists": "feature/error-doc" + "purescript-lists": "compiler/0.12" } } From dd6925d1b4d0ebb01c3247a9ca284cae40cdbd58 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Fri, 13 Apr 2018 14:56:41 +0100 Subject: [PATCH 0957/1580] Check that instance declarations don't overlap in related modules (#3129) --- examples/failing/OverlapAcrossModules.purs | 7 ++ .../failing/OverlapAcrossModules/Class.purs | 2 + examples/failing/OverlapAcrossModules/X.purs | 4 + .../passing/ExportedInstanceDeclarations.purs | 24 ++--- examples/passing/MPTCs.purs | 6 +- src/Language/PureScript/TypeChecker.hs | 93 ++++++++++++++++--- src/Language/PureScript/TypeChecker/Monad.hs | 8 ++ tests/support/bower.json | 2 +- 8 files changed, 115 insertions(+), 31 deletions(-) create mode 100644 examples/failing/OverlapAcrossModules.purs create mode 100644 examples/failing/OverlapAcrossModules/Class.purs create mode 100644 examples/failing/OverlapAcrossModules/X.purs diff --git a/examples/failing/OverlapAcrossModules.purs b/examples/failing/OverlapAcrossModules.purs new file mode 100644 index 0000000000..29c87b889c --- /dev/null +++ b/examples/failing/OverlapAcrossModules.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith OverlappingInstances +module OverlapAcrossModules where +import OverlapAcrossModules.Class +import OverlapAcrossModules.X +data Y +instance cxy :: C X Y + diff --git a/examples/failing/OverlapAcrossModules/Class.purs b/examples/failing/OverlapAcrossModules/Class.purs new file mode 100644 index 0000000000..6b4699a9a1 --- /dev/null +++ b/examples/failing/OverlapAcrossModules/Class.purs @@ -0,0 +1,2 @@ +module OverlapAcrossModules.Class where +class C x y diff --git a/examples/failing/OverlapAcrossModules/X.purs b/examples/failing/OverlapAcrossModules/X.purs new file mode 100644 index 0000000000..df3a6b2d13 --- /dev/null +++ b/examples/failing/OverlapAcrossModules/X.purs @@ -0,0 +1,4 @@ +module OverlapAcrossModules.X where +import OverlapAcrossModules.Class +data X +instance cxy :: C X y diff --git a/examples/passing/ExportedInstanceDeclarations.purs b/examples/passing/ExportedInstanceDeclarations.purs index ee3dd922a9..97cd196bf4 100644 --- a/examples/passing/ExportedInstanceDeclarations.purs +++ b/examples/passing/ExportedInstanceDeclarations.purs @@ -22,24 +22,24 @@ class NonexportedClass a where -- There are three places that a nonexported type or type class can occur, -- leading an instance to count as non-exported: +-- * The instance types -- * Constraints -- * The type class itself --- * The instance types --- Case 1: constraints -instance nonExportedFoo :: (NonexportedClass a) => Foo a where - foo = notExported - --- Another instance of case 1: -instance nonExportedFoo2 :: (Foo NonexportedType) => Foo (a -> a) where +-- Case 1: instance types +instance constFoo :: Foo (Const NonexportedType b) where + foo = Const NonexportedType +else +-- Case 2: constraints +instance nonExportedFoo :: (Foo NonexportedType) => Foo (a -> a) where foo = id +else +-- Another instance of case 2: +instance nonExportedFoo2 :: (NonexportedClass a) => Foo a where + foo = notExported --- Case 2: type class +-- Case 3: type class instance nonExportedNonexportedType :: NonexportedClass (Const Int a) where notExported = Const 0 --- Case 3: instance types -instance constFoo :: Foo (Const NonexportedType b) where - foo = Const NonexportedType - main = log "Done" diff --git a/examples/passing/MPTCs.purs b/examples/passing/MPTCs.purs index 195d3dc285..d7587738bd 100644 --- a/examples/passing/MPTCs.purs +++ b/examples/passing/MPTCs.purs @@ -12,10 +12,10 @@ instance nullaryTypeClass :: NullaryTypeClass where class Coerce a b where coerce :: a -> b -instance coerceRefl :: Coerce a a where - coerce a = a - instance coerceShow :: Show a => Coerce a String where coerce = show +else +instance coerceRefl :: Coerce a a where + coerce a = a main = log "Done" diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 9cd3500098..005b5b2bd5 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -334,10 +334,13 @@ typeCheckAll moduleName _ = traverse go Just typeClass -> do checkInstanceArity dictName className typeClass tys sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys) - checkOrphanInstance dictName className typeClass tys + let nonOrphanModules = findNonOrphanModules className typeClass tys + checkOrphanInstance dictName className tys nonOrphanModules + let qualifiedChain = Qualified (Just moduleName) <$> ch + checkOverlappingInstance qualifiedChain dictName className typeClass tys nonOrphanModules _ <- traverseTypeInstanceBody checkInstanceMembers body deps' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps - let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) <$> ch) idx qualifiedDictName [] className tys (Just deps') + let dict = TypeClassDictionaryInScope qualifiedChain idx qualifiedDictName [] className tys (Just deps') addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict return d @@ -365,21 +368,23 @@ typeCheckAll moduleName _ = traverse go | otherwise = firstDuplicate xs firstDuplicate _ = Nothing - checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m () - checkOrphanInstance dictName className@(Qualified (Just mn') _) typeClass tys' - | moduleName `S.member` nonOrphanModules' = return () - | otherwise = throwError . errorMessage $ OrphanInstance dictName className nonOrphanModules' tys' + findNonOrphanModules + :: Qualified (ProperName 'ClassName) + -> TypeClassData + -> [Type] + -> S.Set ModuleName + findNonOrphanModules (Qualified (Just mn') _) typeClass tys' = nonOrphanModules where - nonOrphanModules' :: S.Set ModuleName - nonOrphanModules' = S.insert mn' nonOrphanModules + nonOrphanModules :: S.Set ModuleName + nonOrphanModules = S.insert mn' nonOrphanModules' typeModule :: Type -> Maybe ModuleName typeModule (TypeVar _) = Nothing typeModule (TypeLevelString _) = Nothing typeModule (TypeConstructor (Qualified (Just mn'') _)) = Just mn'' - typeModule (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance" + typeModule (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in findNonOrphanModules" typeModule (TypeApp t1 _) = typeModule t1 - typeModule _ = internalError "Invalid type in instance in checkOrphanInstance" + typeModule _ = internalError "Invalid type in instance in findNonOrphanModules" modulesByTypeIndex :: M.Map Int (Maybe ModuleName) modulesByTypeIndex = M.fromList (zip [0 ..] (typeModule <$> tys')) @@ -387,16 +392,74 @@ typeCheckAll moduleName _ = traverse go lookupModule :: Int -> S.Set ModuleName lookupModule idx = case M.lookup idx modulesByTypeIndex of Just ms -> S.fromList (toList ms) - Nothing -> internalError "Unknown type index in checkOrphanInstance" + Nothing -> internalError "Unknown type index in findNonOrphanModules" -- If the instance is declared in a module that wouldn't be found based on a covering set -- then it is considered an orphan - because we'd have a situation in which we expect an -- instance but can't find it. So a valid module must be applicable across *all* covering -- sets - therefore we take the intersection of covering set modules. - nonOrphanModules :: S.Set ModuleName - nonOrphanModules = foldl1 S.intersection (foldMap lookupModule `S.map` typeClassCoveringSets typeClass) - - checkOrphanInstance _ _ _ _ = internalError "Unqualified class name in checkOrphanInstance" + nonOrphanModules' :: S.Set ModuleName + nonOrphanModules' = foldl1 S.intersection (foldMap lookupModule `S.map` typeClassCoveringSets typeClass) + findNonOrphanModules _ _ _ = internalError "Unqualified class name in findNonOrphanModules" + + -- Check that the instance currently being declared doesn't overlap with any + -- other instance in any module that this instance wouldn't be considered an + -- orphan in. There are overlapping instance situations that won't be caught + -- by this, for example when combining multiparametr type classes with + -- flexible instances: the instances `Cls X y` and `Cls x Y` overlap and + -- could live in different modules but won't be caught here. + checkOverlappingInstance + :: [Qualified Ident] + -> Ident + -> Qualified (ProperName 'ClassName) + -> TypeClassData + -> [Type] + -> S.Set ModuleName + -> m () + checkOverlappingInstance ch dictName className typeClass tys' nonOrphanModules = do + for_ nonOrphanModules $ \m -> do + dicts <- M.toList <$> lookupTypeClassDictionariesForClass (Just m) className + + for_ dicts $ \(ident, dict) -> do + -- ignore instances in the same instance chain + if ch == tcdChain dict || + instancesAreApart (typeClassCoveringSets typeClass) tys' (tcdInstanceTypes dict) + then return () + else throwError . errorMessage $ + OverlappingInstances className + tys' + [ident, Qualified (Just moduleName) dictName] + + instancesAreApart + :: S.Set (S.Set Int) + -> [Type] + -> [Type] + -> Bool + instancesAreApart sets lhs rhs = all (any typesApart . S.toList) (S.toList sets) + where + typesApart :: Int -> Bool + typesApart i = typeHeadsApart (lhs !! i) (rhs !! i) + + -- Note: implementation doesn't need to care about all possible cases: + -- TUnknown, Skolem, etc. + typeHeadsApart :: Type -> Type -> Bool + typeHeadsApart l r | l == r = False + typeHeadsApart (TypeVar _) _ = False + typeHeadsApart _ (TypeVar _) = False + typeHeadsApart (KindedType t1 _) t2 = typeHeadsApart t1 t2 + typeHeadsApart t1 (KindedType t2 _) = typeHeadsApart t1 t2 + typeHeadsApart (TypeApp h1 t1) (TypeApp h2 t2) = typeHeadsApart h1 h2 || typeHeadsApart t1 t2 + typeHeadsApart _ _ = True + + checkOrphanInstance + :: Ident + -> Qualified (ProperName 'ClassName) + -> [Type] + -> S.Set ModuleName + -> m () + checkOrphanInstance dictName className tys' nonOrphanModules + | moduleName `S.member` nonOrphanModules = return () + | otherwise = throwError . errorMessage $ OrphanInstance dictName className nonOrphanModules tys' -- | -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index c8ecc791c2..dcc40cc42f 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -163,6 +163,14 @@ lookupTypeClassDictionaries -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)) lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get +-- | Lookup type class dictionaries in a module. +lookupTypeClassDictionariesForClass + :: (MonadState CheckState m) + => Maybe ModuleName + -> Qualified (ProperName 'ClassName) + -> m (M.Map (Qualified Ident) NamedDict) +lookupTypeClassDictionariesForClass mn cn = fromMaybe M.empty . M.lookup cn <$> lookupTypeClassDictionaries mn + -- | Temporarily bind a collection of names to local variables bindLocalVariables :: (MonadState CheckState m) diff --git a/tests/support/bower.json b/tests/support/bower.json index 37b855c8b4..9b5b342e07 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -28,7 +28,7 @@ "purescript-partial": "1.2.1", "purescript-prelude": "3.1.0", "purescript-proxy": "2.1.0", - "purescript-psci-support": "3.0.0", + "purescript-psci-support": "purescript/purescript-psci-support#compiler/0.12", "purescript-refs": "3.0.0", "purescript-st": "3.0.0", "purescript-strings": "3.3.0", From f509ffe7e8ede2305ad13b84732a3e51a26c2eb1 Mon Sep 17 00:00:00 2001 From: rndnoise <34294193+rndnoise@users.noreply.github.com> Date: Sat, 14 Apr 2018 05:05:17 -0500 Subject: [PATCH 0958/1580] Complete type identifiers following '::' in REPL (#3239) * Improvments to REPL tab-completion - Complete all names that have been imported (transitively or directly) - Do not complete names that haven't been imported - Only recompute list of names after import or adding a let binding rather than after each request for name completion This commit fixes #3227 * Complete type identifiers following '::' in REPL --- .../PureScript/Interactive/Completion.hs | 22 +++++++++++++++---- tests/TestPsci/CompletionTest.hs | 7 ++++++ 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index f0fc83df79..eccbcfcf2d 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -12,7 +12,7 @@ import Protolude (ordNub) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) -import Data.List (nub, isPrefixOf, sortBy, stripPrefix) +import Data.List (nub, isPrefixOf, isInfixOf, isSuffixOf, sortBy, stripPrefix) import Data.Map (keys) import Data.Maybe (mapMaybe) import qualified Data.Text as T @@ -63,7 +63,7 @@ findCompletions prev word = do CtxFilePath f -> map Right <$> listFiles f CtxModule -> map Left <$> getModuleNames CtxIdentifier -> map Left <$> ((++) <$> getIdentNames <*> getDctorNames) - CtxType -> map Left <$> getTypeNames + CtxType pre -> map (Left . (pre ++)) <$> getTypeNames CtxFixed str -> return [Left str] CtxDirective d -> return (map Left (completeDirectives d)) @@ -96,7 +96,7 @@ data CompletionContext | CtxFilePath String | CtxModule | CtxIdentifier - | CtxType + | CtxType String | CtxFixed String deriving (Show) @@ -105,11 +105,21 @@ data CompletionContext -- a list of complete words (to the left of the cursor) as the first argument, -- and the current word as the second argument. completionContext :: [String] -> String -> [CompletionContext] +completionContext _ w | "::" `isInfixOf` w = [CtxType (w `endingWith` "::")] +completionContext ws _ | lastSatisfies ("::" `isSuffixOf`) ws = [CtxType ""] completionContext [] _ = [CtxDirective "", CtxIdentifier, CtxFixed "import"] completionContext ws w | headSatisfies (":" `isPrefixOf`) ws = completeDirective ws w completionContext ws w | headSatisfies (== "import") ws = completeImport ws w completionContext _ _ = [CtxIdentifier] +endingWith :: String -> String -> String +endingWith str stop = aux "" str + where + aux acc s@(x:xs) + | stop `isPrefixOf` s = reverse (stop ++ acc) + | otherwise = aux (x:acc) xs + aux acc [] = reverse (stop ++ acc) + completeDirective :: [String] -> String -> [CompletionContext] completeDirective ws w = case ws of @@ -123,7 +133,7 @@ directiveArg :: [String] -> Directive -> [CompletionContext] directiveArg [] Browse = [CtxModule] -- only complete very next term directiveArg [] Show = map CtxFixed replQueryStrings -- only complete very next term directiveArg _ Type = [CtxIdentifier] -directiveArg _ Kind = [CtxType] +directiveArg _ Kind = [CtxType ""] directiveArg _ _ = [] completeImport :: [String] -> String -> [CompletionContext] @@ -138,6 +148,10 @@ headSatisfies p str = (c:_) -> p c _ -> False +lastSatisfies :: (a -> Bool) -> [a] -> Bool +lastSatisfies _ [] = False +lastSatisfies p xs = p (last xs) + getLoadedModules :: CompletionM [P.Module] getLoadedModules = asks (map fst . psciLoadedExterns) diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index 308133e41e..d71bec59e3 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -88,6 +88,13 @@ completionTestData supportModuleNames = , ("voi", []) -- import Prelude hiding (void) , ("Control.Monad.Eff.Class.", []) + -- complete first name after type annotation symbol + , ("1 :: I", ["1 :: Int"]) + , ("1 ::I", ["1 ::Int"]) + , ("1:: I", ["1:: Int"]) + , ("1::I", ["1::Int"]) + , ("(1::Int) uni", ["(1::Int) unit"]) -- back to completing values + -- Parens and brackets aren't considered part of the current identifier , ("map id [uni", ["map id [unit"]) , ("map (cons", ["map (const"]) From 21760f7ea3fe4f4aeba88ef8cc4eec9184acce15 Mon Sep 17 00:00:00 2001 From: rndnoise <34294193+rndnoise@users.noreply.github.com> Date: Sat, 14 Apr 2018 08:48:00 -0500 Subject: [PATCH 0959/1580] Fix :browse Prim, it has no ExternsFile (#3246) Fixes #2672. --- src/Language/PureScript/Interactive.hs | 32 +++++++++++++------------- tests/TestPsci/CommandTest.hs | 4 ++++ tests/TestPsci/TestEnv.hs | 11 +++++---- 3 files changed, 26 insertions(+), 21 deletions(-) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 61782de7d3..ebe3e7d856 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -14,9 +14,10 @@ import Prelude.Compat import Protolude (ordNub) import Data.List (sort, find, foldl') -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import Data.Monoid ((<>)) +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T @@ -291,22 +292,21 @@ handleBrowse handleBrowse print' moduleName = do st <- get env <- asks psciEnvironment - if isModInEnv moduleName st - then print' $ printModuleSignatures moduleName env - else case lookupUnQualifiedModName moduleName st of - Just unQualifiedName -> - if isModInEnv unQualifiedName st - then print' $ printModuleSignatures unQualifiedName env - else failNotInEnv moduleName - Nothing -> - failNotInEnv moduleName + case findMod moduleName (psciLoadedExterns st) (psciImportedModules st) of + Just qualName -> print' $ printModuleSignatures qualName env + Nothing -> failNotInEnv moduleName where - isModInEnv modName = - any ((== modName) . P.getModuleName . fst) . psciLoadedExterns - failNotInEnv modName = - print' $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid." - lookupUnQualifiedModName quaModName st = - (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st) + findMod needle externs imports = + let qualMod = fromMaybe needle (lookupUnQualifiedModName needle imports) + primMod = P.ModuleName [P.ProperName "Prim"] + modules = S.fromList (primMod : (P.getModuleName . fst <$> externs)) + in if qualMod `S.member` modules + then Just qualMod + else Nothing + + failNotInEnv modName = print' $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid." + lookupUnQualifiedModName needle imports = + (\(modName,_,_) -> modName) <$> find (\(_,_,mayQuaName) -> mayQuaName == Just needle) imports -- | Return output as would be returned by tab completion, for tools integration etc. handleComplete diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs index 2e3980da81..a84fdcaf16 100644 --- a/tests/TestPsci/CommandTest.hs +++ b/tests/TestPsci/CommandTest.hs @@ -40,3 +40,7 @@ commandTests = context "commandTests" $ do ":complete ma" `prints` unlines ["map", "mapFlipped"] run "import Control.Monad as M" ":complete M.a" `prints` unlines ["M.ap", "M.apply"] + + specPSCi ":browse" $ do + ":browse Mirp" `printed` flip shouldContain "is not valid" + ":browse Prim" `printed` flip shouldContain "class Partial" diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 13a655f1a2..a41c018871 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -3,6 +3,7 @@ module TestPsci.TestEnv where import Prelude () import Prelude.Compat +import Control.Monad (void) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.RWS.Strict (evalRWST, RWST) import qualified Language.PureScript as P @@ -12,7 +13,7 @@ import System.Exit import System.FilePath (()) import qualified System.FilePath.Glob as Glob import System.Process (readProcessWithExitCode) -import Test.Hspec (shouldBe) +import Test.Hspec (shouldBe, Expectation) -- | A monad transformer for handle PSCi actions in tests type TestPSCi a = RWST PSCiConfig () PSCiState IO a @@ -90,7 +91,7 @@ evaluatesTo command expected = runAndEval command evalJsAndCompare ignorePrinted -- | An assertion to check command PSCi printed output against a given string prints :: String -> String -> TestPSCi () -prints command expected = runAndEval command evalJsAndIgnore evalPrinted - where - evalJsAndIgnore = jsEval *> return () - evalPrinted s = s `equalsTo` expected +prints command expected = printed command (`shouldBe` expected) + +printed :: String -> (String -> Expectation) -> TestPSCi () +printed command f = runAndEval command (void jsEval) (liftIO . f) From 7be8051b2327621fa1ebf4a8a0119b875e30d10c Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sat, 14 Apr 2018 16:45:00 +0100 Subject: [PATCH 0960/1580] Add some source span to ErrorParsingFFIModule (#3307) --- src/Language/PureScript/Make/Actions.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index cbe0886480..ecc7a13adf 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -247,7 +247,7 @@ checkForeignDecls modSS m path = do mname = CF.moduleName m errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a - errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just + errorParsingModule = throwError . errorMessage' modSS . ErrorParsingFFIModule path . Just getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String] getExps = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname)) From dcc73640cc246964f730e3fad32f36d7aef4cea7 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sat, 14 Apr 2018 17:48:15 +0100 Subject: [PATCH 0961/1580] Remove MultipleFFIModules error code (#3308) This is no longer possible since FFI implementation lives beside the source module. --- src/Language/PureScript/AST/Declarations.hs | 1 - src/Language/PureScript/Errors.hs | 5 ----- 2 files changed, 6 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 2072b340ba..ac15e46bf1 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -69,7 +69,6 @@ data SimpleErrorMessage | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) | ErrorParsingModule P.ParseError | MissingFFIModule ModuleName - | MultipleFFIModules ModuleName [FilePath] | UnnecessaryFFIModule ModuleName FilePath | MissingFFIImplementations ModuleName [Ident] | UnusedFFIImplementations ModuleName [Ident] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 4ce303ce5a..ab049884e2 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -78,7 +78,6 @@ errorCode em = case unwrapErrorMessage em of ErrorParsingFFIModule{} -> "ErrorParsingFFIModule" ErrorParsingModule{} -> "ErrorParsingModule" MissingFFIModule{} -> "MissingFFIModule" - MultipleFFIModules{} -> "MultipleFFIModules" UnnecessaryFFIModule{} -> "UnnecessaryFFIModule" MissingFFIImplementations{} -> "MissingFFIImplementations" UnusedFFIImplementations{} -> "UnusedFFIImplementations" @@ -489,10 +488,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers." ] ] - renderSimpleErrorMessage (MultipleFFIModules mn paths) = - paras [ line $ "Multiple foreign module implementations have been provided for module " <> markCode (runModuleName mn) <> ": " - , indent . paras $ map lineS paths - ] renderSimpleErrorMessage InvalidDoBind = line "The last statement in a 'do' block must be an expression, but this block ends with a binder." renderSimpleErrorMessage InvalidDoLet = From 2495be53436f39321be257753e8b33d7ad8611de Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Tue, 17 Apr 2018 07:16:18 -0700 Subject: [PATCH 0962/1580] Add Prim.Row.Lacks constraint (#3305) * Add Prim.Row.Lacks constraint * Doc fix: rows -> tow * Remove unnecessary parens * Rearrange forClassName patterns to avoid warning * Fix fallthrough in forClassName * Move instance solvers to separate functions --- examples/failing/RowLacks.purs | 18 +++ examples/passing/RowLacks.purs | 23 ++++ src/Language/PureScript/Constants.hs | 3 + src/Language/PureScript/Docs/Prim.hs | 6 + src/Language/PureScript/Environment.hs | 6 + .../PureScript/TypeChecker/Entailment.hs | 113 +++++++++++++----- tests/TestPrimDocs.hs | 2 +- 7 files changed, 140 insertions(+), 31 deletions(-) create mode 100644 examples/failing/RowLacks.purs create mode 100644 examples/passing/RowLacks.purs diff --git a/examples/failing/RowLacks.purs b/examples/failing/RowLacks.purs new file mode 100644 index 0000000000..d39042e557 --- /dev/null +++ b/examples/failing/RowLacks.purs @@ -0,0 +1,18 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Control.Monad.Eff.Console (log) +import Prim.Row (class Lacks) +import Type.Row (RProxy(..)) + +lacksX + :: forall r + . Lacks "x" r + => RProxy r + -> RProxy () +lacksX _ = RProxy + +test1 :: RProxy () +test1 = lacksX (RProxy :: RProxy (x :: Int, y :: Int, z :: String)) + +main = log "Done" diff --git a/examples/passing/RowLacks.purs b/examples/passing/RowLacks.purs new file mode 100644 index 0000000000..171eef8d55 --- /dev/null +++ b/examples/passing/RowLacks.purs @@ -0,0 +1,23 @@ +module Main where + +import Control.Monad.Eff.Console (log) +import Prim.Row (class Lacks) +import Type.Row (RProxy(..)) + +lacksX + :: forall r + . Lacks "x" r + => RProxy r + -> RProxy () +lacksX _ = RProxy + +test1 :: RProxy () +test1 = lacksX (RProxy :: RProxy (y :: Int, z :: String)) + +test2 :: forall r. Lacks "x" r => RProxy r -> RProxy () +test2 _ = lacksX (RProxy :: RProxy (y :: Int, z :: String | r)) + +test3 :: RProxy () +test3 = test2 (RProxy :: RProxy (a :: String)) + +main = log "Done" diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index a4641028ef..ad0cd94861 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -443,6 +443,9 @@ pattern Union = Qualified (Just PrimRow) (ProperName "Union") pattern Nub :: Qualified (ProperName 'ClassName) pattern Nub = Qualified (Just PrimRow) (ProperName "Nub") +pattern Lacks :: Qualified (ProperName 'ClassName) +pattern Lacks = Qualified (Just PrimRow) (ProperName "Lacks") + pattern RowCons :: Qualified (ProperName 'ClassName) pattern RowCons = Qualified (Just PrimRow) (ProperName "Cons") diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 442176f25e..d280362bb2 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -45,6 +45,7 @@ primRowDocsModule = Module , modDeclarations = [ union , nub + , lacks , rowCons ] , modReExports = [] @@ -303,6 +304,11 @@ nub = primClassOf (P.primSubName "Row") "Nub" $ T.unlines [ "The Nub type class is used to remove duplicate labels from rows." ] +lacks :: Declaration +lacks = primClassOf (P.primSubName "Row") "Lacks" $ T.unlines + [ "The Lacks type class asserts that a label does not occur in a given row." + ] + rowCons :: Declaration rowCons = primClassOf (P.primSubName "Row") "Cons" $ T.unlines [ "The Cons type class is a 4-way relation which asserts that one row of" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index f23648e7da..38f085f804 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -384,6 +384,7 @@ primRowTypes = M.fromList [ (primSubName C.row "Union", (FunKind (Row kindType) (FunKind (Row kindType) (FunKind (Row kindType) kindType)), ExternData)) , (primSubName C.row "Nub", (FunKind (Row kindType) (FunKind (Row kindType) kindType), ExternData)) + , (primSubName C.row "Lacks", (FunKind kindSymbol (FunKind (Row kindType) kindType), ExternData)) , (primSubName C.row "Cons", (FunKind kindSymbol (FunKind kindType (FunKind (Row kindType) (FunKind (Row kindType) kindType))), ExternData)) ] @@ -434,6 +435,11 @@ primRowClasses = ] [] [] [ FunctionalDependency [0] [1] ])) + -- class Lacks (label :: Symbol) (row :: # Type) + , (primSubName C.row "Lacks", (makeTypeClassData + [ ("label", Just kindSymbol) + , ("row", Just (Row kindType)) + ] [] [] [])) -- class RowCons (label :: Symbol) (a :: Type) (tail :: # Type) (row :: # Type) | label tail a -> row, label row -> tail a , (primSubName C.row "Cons", (makeTypeClassData [ ("label", Just kindSymbol) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 354a3f51d6..dd8fe33da5 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -58,6 +58,7 @@ data Evidence | UnionInstance | ConsInstance | NubInstance + | LacksInstance | RowToListInstance deriving (Show, Eq) @@ -171,34 +172,15 @@ entails SolverOptions{..} constraint context hints = -- Prefer a warning dictionary in scope if there is one available. -- This allows us to defer a warning by propagating the constraint. findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope [] 0 (WarnInstance msg) [] C.Warn [msg] Nothing] - forClassName _ C.IsSymbol [TypeLevelString sym] = - [TypeClassDictionaryInScope [] 0 (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing] - forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = - let ordering = case compare lhs rhs of - LT -> C.orderingLT - EQ -> C.orderingEQ - GT -> C.orderingGT - args = [arg0, arg1, TypeConstructor ordering] - in [TypeClassDictionaryInScope [] 0 CompareSymbolInstance [] C.CompareSymbol args Nothing] - forClassName _ C.AppendSymbol [arg0, arg1, arg2] - | Just (arg0', arg1', arg2') <- appendSymbols arg0 arg1 arg2 = - let args = [arg0', arg1', arg2'] - in [TypeClassDictionaryInScope [] 0 AppendSymbolInstance [] C.AppendSymbol args Nothing] - forClassName _ C.ConsSymbol [arg0, arg1, arg2] - | Just (arg0', arg1', arg2') <- consSymbol arg0 arg1 arg2 = - let args = [arg0', arg1', arg2'] - in [TypeClassDictionaryInScope [] 0 ConsSymbolInstance [] C.ConsSymbol args Nothing] - forClassName _ C.Union [l, r, u] - | Just (lOut, rOut, uOut, cst) <- unionRows l r u - = [ TypeClassDictionaryInScope [] 0 UnionInstance [] C.Union [lOut, rOut, uOut] cst ] - forClassName _ C.Nub [r, _] - | Just r' <- nubRows r - = [ TypeClassDictionaryInScope [] 0 NubInstance [] C.Nub [r, r'] Nothing ] - forClassName _ C.RowCons [TypeLevelString sym, ty, r, _] - = [ TypeClassDictionaryInScope [] 0 ConsInstance [] C.RowCons [TypeLevelString sym, ty, r, RCons (Label sym) ty r] Nothing ] - forClassName _ C.RowToList [r, _] - | Just entries <- solveRowToList r - = [ TypeClassDictionaryInScope [] 0 RowToListInstance [] C.RowToList [r, entries] Nothing ] + forClassName _ C.IsSymbol args | Just dicts <- solveIsSymbol args = dicts + forClassName _ C.CompareSymbol args | Just dicts <- solveCompareSymbol args = dicts + forClassName _ C.AppendSymbol args | Just dicts <- solveAppendSymbol args = dicts + forClassName _ C.ConsSymbol args | Just dicts <- solveConsSymbol args = dicts + forClassName _ C.Union args | Just dicts <- solveUnion args = dicts + forClassName _ C.Nub args | Just dicts <- solveNub args = dicts + forClassName _ C.Lacks args | Just dicts <- solveLacks args = dicts + forClassName _ C.RowCons args | Just dicts <- solveRowCons args = dicts + forClassName _ C.RowToList args | Just dicts <- solveRowToList args = dicts forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) forClassName _ _ _ = internalError "forClassName: expected qualified class name" @@ -368,6 +350,7 @@ entails SolverOptions{..} constraint context hints = mkDictionary UnionInstance _ = return valUndefined mkDictionary ConsInstance _ = return valUndefined mkDictionary NubInstance _ = return valUndefined + mkDictionary LacksInstance _ = return valUndefined mkDictionary RowToListInstance _ = return valUndefined mkDictionary (WarnInstance msg) _ = do tell . errorMessage $ UserDefinedWarning msg @@ -390,6 +373,27 @@ entails SolverOptions{..} constraint context hints = subclassDictionaryValue dict className index = App (Accessor (mkString (superclassName className index)) dict) valUndefined + solveIsSymbol :: [Type] -> Maybe [TypeClassDict] + solveIsSymbol [TypeLevelString sym] = Just [TypeClassDictionaryInScope [] 0 (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing] + solveIsSymbol _ = Nothing + + solveCompareSymbol :: [Type] -> Maybe [TypeClassDict] + solveCompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = + let ordering = case compare lhs rhs of + LT -> C.orderingLT + EQ -> C.orderingEQ + GT -> C.orderingGT + args' = [arg0, arg1, TypeConstructor ordering] + in Just [TypeClassDictionaryInScope [] 0 CompareSymbolInstance [] C.CompareSymbol args' Nothing] + solveCompareSymbol _ = Nothing + + solveAppendSymbol :: [Type] -> Maybe [TypeClassDict] + solveAppendSymbol [arg0, arg1, arg2] = do + (arg0', arg1', arg2') <- appendSymbols arg0 arg1 arg2 + let args' = [arg0', arg1', arg2'] + pure [TypeClassDictionaryInScope [] 0 AppendSymbolInstance [] C.AppendSymbol args' Nothing] + solveAppendSymbol _ = Nothing + -- | Append type level symbols, or, run backwards, strip a prefix or suffix appendSymbols :: Type -> Type -> Type -> Maybe (Type, Type, Type) appendSymbols arg0@(TypeLevelString lhs) arg1@(TypeLevelString rhs) _ = Just (arg0, arg1, TypeLevelString (lhs <> rhs)) @@ -405,6 +409,13 @@ entails SolverOptions{..} constraint context hints = pure (TypeLevelString (mkString lhs), arg1, arg2) appendSymbols _ _ _ = Nothing + solveConsSymbol :: [Type] -> Maybe [TypeClassDict] + solveConsSymbol [arg0, arg1, arg2] = do + (arg0', arg1', arg2') <- consSymbol arg0 arg1 arg2 + let args' = [arg0', arg1', arg2'] + pure [TypeClassDictionaryInScope [] 0 ConsSymbolInstance [] C.ConsSymbol args' Nothing] + solveConsSymbol _ = Nothing + consSymbol :: Type -> Type -> Type -> Maybe (Type, Type, Type) consSymbol _ _ arg@(TypeLevelString s) = do (h, t) <- T.uncons =<< decodeString s @@ -417,6 +428,12 @@ entails SolverOptions{..} constraint context hints = pure (arg1, arg2, TypeLevelString (mkString $ h' <> t')) consSymbol _ _ _ = Nothing + solveUnion :: [Type] -> Maybe [TypeClassDict] + solveUnion [l, r, u] = do + (lOut, rOut, uOut, cst) <- unionRows l r u + pure [ TypeClassDictionaryInScope [] 0 UnionInstance [] C.Union [lOut, rOut, uOut] cst ] + solveUnion _ = Nothing + -- | Left biased union of two row types unionRows :: Type -> Type -> Type -> Maybe (Type, Type, Type, Maybe [Constraint]) unionRows l r _ = @@ -439,9 +456,20 @@ entails SolverOptions{..} constraint context hints = -- types for such labels. _ -> (not (null fixed), (fixed, rowVar), Just [ Constraint C.Union [rest, r, rowVar] Nothing ]) + solveRowCons :: [Type] -> Maybe [TypeClassDict] + solveRowCons [TypeLevelString sym, ty, r, _] = + Just [ TypeClassDictionaryInScope [] 0 ConsInstance [] C.RowCons [TypeLevelString sym, ty, r, RCons (Label sym) ty r] Nothing ] + solveRowCons _ = Nothing + + solveRowToList :: [Type] -> Maybe [TypeClassDict] + solveRowToList [r, _] = do + entries <- rowToRowList r + pure [ TypeClassDictionaryInScope [] 0 RowToListInstance [] C.RowToList [r, entries] Nothing ] + solveRowToList _ = Nothing + -- | Convert a closed row to a sorted list of entries - solveRowToList :: Type -> Maybe Type - solveRowToList r = + rowToRowList :: Type -> Maybe Type + rowToRowList r = guard (REmpty == rest) $> foldr rowListCons (TypeConstructor C.RowListNil) fixed where @@ -451,6 +479,12 @@ entails SolverOptions{..} constraint context hints = , ty , tl ] + solveNub :: [Type] -> Maybe [TypeClassDict] + solveNub [r, _] = do + r' <- nubRows r + pure [ TypeClassDictionaryInScope [] 0 NubInstance [] C.Nub [r, r'] Nothing ] + solveNub _ = Nothing + nubRows :: Type -> Maybe Type nubRows r = guard (REmpty == rest) $> @@ -458,6 +492,25 @@ entails SolverOptions{..} constraint context hints = where (fixed, rest) = rowToSortedList r + solveLacks :: [Type] -> Maybe [TypeClassDict] + solveLacks [TypeLevelString sym, r] = do + (r', cst) <- rowLacks sym r + pure [ TypeClassDictionaryInScope [] 0 LacksInstance [] C.Lacks [TypeLevelString sym, r'] cst ] + solveLacks _ = Nothing + + rowLacks :: PSString -> Type -> Maybe (Type, Maybe [Constraint]) + rowLacks sym r = + guard (lacksSym && canMakeProgress) $> (r, cst) + where + (fixed, rest) = rowToList r + + lacksSym = + not $ sym `elem` (runLabel . fst <$> fixed) + + (canMakeProgress, cst) = case rest of + REmpty -> (True, Nothing) + _ -> (not (null fixed), Just [ Constraint C.Lacks [TypeLevelString sym, rest] Nothing ]) + -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a -- substitution which makes them match. If not, we return 'Nothing'. diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index b23c037664..ca691e5a8a 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -30,4 +30,4 @@ main = do error $ "Undocumented Prim names: " ++ show undocumentedNames when (not (null extraNames)) $ - error $ "Extra Prim names: " ++ show undocumentedNames + error $ "Extra Prim names: " ++ show extraNames From 263b3cc75179998ebd806aeabcf2f1c9e9a15e36 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Thu, 19 Apr 2018 18:32:43 +0700 Subject: [PATCH 0963/1580] Add missing output directory to error (#3311) * Add missing output directory to error * Update CONTRIBUTORS file * Clarify error message and normalise the path --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Ide.hs | 5 +++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 79b8ff6064..ac47e82975 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -122,6 +122,7 @@ If you would prefer to use different terms, please use the section below instead | [@bjornmelgaaard](https://github.com/BjornMelgaard) | Sergey Homa | [MIT license](http://opensource.org/licenses/MIT) | | [@thimoteus](https://github.com/Thimoteus) | thimoteus | [MIT license](http://opensource.org/licenses/MIT) | | [@sloosch](https://github.com/sloosch) | Simon Looschen | [MIT license](http://opensource.org/licenses/MIT) | +| [@rgrinberg](https://github.com/rgrinberg) | Rudi Grinberg | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 624a82ae9a..3a86d64352 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -22,6 +22,7 @@ import Protolude hiding (moduleName) import "monad-logger" Control.Monad.Logger import qualified Data.Map as Map +import qualified Data.Text as T import qualified Language.PureScript as P import qualified Language.PureScript.Ide.CaseSplit as CS import Language.PureScript.Ide.Command @@ -40,7 +41,7 @@ import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import Language.PureScript.Ide.Usage (findUsages) import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist, doesFileExist) -import System.FilePath (()) +import System.FilePath ((), normalise) import System.FilePath.Glob (glob) -- | Accepts a Commmand and runs it against psc-ide's State. This is the main @@ -167,7 +168,7 @@ findAvailableExterns :: (Ide m, MonadError IdeError m) => m [P.ModuleName] findAvailableExterns = do oDir <- outputDirectory unlessM (liftIO (doesDirectoryExist oDir)) - (throwError (GeneralError "Couldn't locate your output directory.")) + (throwError (GeneralError $ "Couldn't locate your output directory at: " <> (T.pack (normalise oDir)))) liftIO $ do directories <- getDirectoryContents oDir moduleNames <- filterM (containsExterns oDir) directories From 270dc077093e938d29a5448248baf6ff6cb2d1fc Mon Sep 17 00:00:00 2001 From: rndnoise <34294193+rndnoise@users.noreply.github.com> Date: Sun, 22 Apr 2018 09:25:43 -0500 Subject: [PATCH 0964/1580] Improve parse error messages for .purs-repl (#3249) - Set the file name in error message - Parse whole file at once so correct lines numbers are given in errors - Don't fail on empty lines, whitespace, etc This fixes #3248 --- app/Command/REPL.hs | 11 ++++------- src/Language/PureScript/Interactive/Parser.hs | 15 ++++++++++++++- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index c07db590d0..04033b57eb 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -360,13 +360,10 @@ command = loop <$> options configFile <- ( ".purs-repl") <$> liftIO getCurrentDirectory exists <- liftIO $ doesFileExist configFile when exists $ do - ls <- lines <$> liftIO (readUTF8File configFile) - for_ ls $ \l -> do - liftIO (putStrLn l) - case parseCommand l of - Left err -> liftIO (putStrLn err >> exitFailure) - Right cmd@Import{} -> handleCommand' state cmd - Right _ -> liftIO (putStrLn "The .purs-repl file only supports import declarations") + cf <- liftIO (readUTF8File configFile) + case parseDotFile configFile cf of + Left err -> liftIO (putStrLn err >> exitFailure) + Right cmds -> liftIO (putStrLn cf) >> for_ cmds (handleCommand' state) handleCommandWithInterrupts :: state diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index 9a13b22a63..9d6df35f69 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -2,11 +2,13 @@ -- Parser for PSCI. -- module Language.PureScript.Interactive.Parser - ( parseCommand + ( parseDotFile + , parseCommand ) where import Prelude.Compat hiding (lex) +import Control.Applicative ((<|>)) import Control.Monad (join) import Data.Bifunctor (first) import Data.Char (isSpace) @@ -18,6 +20,16 @@ import qualified Language.PureScript.Interactive.Directive as D import Language.PureScript.Interactive.Types import Language.PureScript.Parser.Common (mark, same) +-- | +-- Parses a limited set of commands from from .purs-repl +-- +parseDotFile :: FilePath -> String -> Either String [Command] +parseDotFile filePath s = first show $ do + ts <- P.lex filePath (T.pack s) + P.runTokenParser filePath (many parser <* eof) ts + where + parser = psciImport <|> fail "The .purs-repl file only supports import declarations" + -- | -- Parses PSCI metacommands or expressions input from the user. -- @@ -72,6 +84,7 @@ parseDirective cmd = Type -> TypeOf <$> parseRest P.parseValue arg Kind -> KindOf <$> parseRest P.parseType arg Complete -> return (CompleteStr arg) + -- | -- Parses expressions entered at the PSCI repl. -- From 0ebc45779ed21ee16c2fb48a3a2c42544a560512 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 22 Apr 2018 19:03:20 +0100 Subject: [PATCH 0965/1580] Remove inlining for `mod` for `Int` (#3309) * Remove inlining for `mod` for `Int` * Remove inlining for `div` for `Int` --- src/Language/PureScript/CoreImp/Optimizer/Inliner.hs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index 719579328f..391f9391d6 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -95,7 +95,6 @@ inlineCommonValues = everywhere convert convert (App ss (App _ (App _ fn [dict]) [x]) [y]) | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add x y | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply x y - | isDict euclideanRingInt dict && isDict fnDivide fn = intOp ss Divide x y | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract x y convert other = other fnZero = (C.dataSemiring, C.zero) @@ -103,7 +102,6 @@ inlineCommonValues = everywhere convert fnBottom = (C.dataBounded, C.bottom) fnTop = (C.dataBounded, C.top) fnAdd = (C.dataSemiring, C.add) - fnDivide = (C.dataEuclideanRing, C.div) fnMultiply = (C.dataSemiring, C.mul) fnSubtract = (C.dataRing, C.sub) fnNegate = (C.dataRing, C.negate) @@ -118,7 +116,6 @@ inlineCommonOperators = everywhereTopDown $ applyAll $ , unary ringNumber opNegate Negate , binary euclideanRingNumber opDiv Divide - , binary euclideanRingInt opMod Modulus , binary eqNumber opEq EqualTo , binary eqNumber opNotEq NotEqualTo @@ -316,9 +313,6 @@ ringInt = (C.dataRing, C.ringInt) euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b) euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber) -euclideanRingInt :: forall a b. (IsString a, IsString b) => (a, b) -euclideanRingInt = (C.dataEuclideanRing, C.euclideanRingInt) - eqNumber :: forall a b. (IsString a, IsString b) => (a, b) eqNumber = (C.dataEq, C.eqNumber) @@ -397,9 +391,6 @@ opNegate = (C.dataRing, C.negate) opDiv :: forall a b. (IsString a, IsString b) => (a, b) opDiv = (C.dataEuclideanRing, C.div) -opMod :: forall a b. (IsString a, IsString b) => (a, b) -opMod = (C.dataEuclideanRing, C.mod) - opConj :: forall a b. (IsString a, IsString b) => (a, b) opConj = (C.dataHeytingAlgebra, C.conj) From 8ae2a06180dd17c8efd7f2cc9431f1a95b8eadab Mon Sep 17 00:00:00 2001 From: Alex Berg Date: Mon, 23 Apr 2018 06:18:08 -0500 Subject: [PATCH 0966/1580] Include full file path in CJS requires. (#3314) --- src/Language/PureScript/CodeGen/JS.hs | 3 ++- src/Language/PureScript/Make/Actions.hs | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 2cc734cf80..e1517a5f66 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -104,7 +104,8 @@ moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ = importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m AST importToJs mnLookup mn' = do let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - let moduleBody = AST.App Nothing (AST.Var Nothing "require") [AST.StringLiteral Nothing (fromString (".." T.unpack (runModuleName mn')))] + let moduleBody = AST.App Nothing (AST.Var Nothing "require") + [AST.StringLiteral Nothing (fromString (".." T.unpack (runModuleName mn') "index.js"))] withPos ss $ AST.VariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody) -- | Replaces the `ModuleName`s in the AST so that the generated code refers to diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index ecc7a13adf..3494a29d78 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -148,7 +148,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = return Nothing | otherwise -> do checkForeignDecls modSS m path - return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign"] + return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign.js"] Nothing | requiresForeign m -> throwError . errorMessage' modSS $ MissingFFIModule mn | otherwise -> return Nothing rawJs <- J.moduleToJs m foreignInclude From 92d7b6b1e9714287680e4a9cbf947a612553259e Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Tue, 24 Apr 2018 10:03:40 +0100 Subject: [PATCH 0967/1580] Move solved type classes into Prim modules & bump test deps (#3312) * Move solved type classes into Prim modules & bump test deps * Update many many many many tests * Split up primKinds, used new prim modules in missing places * Prim type classes can't have dictionary constructors * Fix append symbol test * test fixes * more test fixes * make EscapedSkolem test fail (pass) again * fixes repl tests * remove old generic test * formatting * Fix docs typo and use be consistent with kind annotating constraints --- core-tests/tests/GenericDeriving.purs | 6 +- core-tests/tests/Main.purs | 5 +- examples/failing/1310.purs | 10 +- examples/failing/3132.purs | 6 +- examples/failing/ArrayType.purs | 1 - examples/failing/DeriveOldGeneric.purs | 10 - examples/failing/Eff.purs | 13 - examples/failing/ExportExplicit1.purs | 2 +- examples/failing/ExportExplicit3.purs | 2 +- examples/failing/ProgrammableTypeErrors.purs | 6 +- .../ProgrammableTypeErrorsTypeString.purs | 6 +- examples/failing/RowConstructors1.purs | 2 +- examples/failing/RowConstructors2.purs | 2 +- examples/failing/RowConstructors3.purs | 2 +- examples/failing/RowLacks.purs | 2 +- examples/failing/SkolemEscape2.purs | 9 +- examples/failing/Superclasses5.purs | 2 +- examples/failing/TypedBinders.purs | 4 +- examples/failing/TypedBinders2.purs | 2 +- examples/failing/TypedBinders3.purs | 2 +- examples/failing/TypedHole.purs | 5 +- examples/failing/UnderscoreModuleName.purs | 2 +- examples/passing/1110.purs | 2 +- examples/passing/1185.purs | 2 +- examples/passing/1335.purs | 2 +- examples/passing/1570.purs | 2 +- examples/passing/1664.purs | 8 +- examples/passing/1697.purs | 2 +- examples/passing/1807.purs | 2 +- examples/passing/1881.purs | 2 +- examples/passing/1991.purs | 2 +- examples/passing/2018.purs | 6 +- examples/passing/2049.purs | 2 +- examples/passing/2136.purs | 2 +- examples/passing/2138.purs | 2 +- examples/passing/2172.purs | 2 +- examples/passing/2197-1.purs | 2 +- examples/passing/2197-2.purs | 2 +- examples/passing/2252.purs | 2 +- examples/passing/2288.purs | 4 +- examples/passing/2378.purs | 2 +- examples/passing/2438.purs | 2 +- examples/passing/2609.purs | 6 +- examples/passing/2616.purs | 4 +- examples/passing/2626.purs | 2 +- examples/passing/2663.purs | 2 +- examples/passing/2689.purs | 6 +- examples/passing/2756.purs | 14 +- examples/passing/2787.purs | 2 +- examples/passing/2795.purs | 2 +- examples/passing/2806.purs | 2 +- examples/passing/2947.purs | 2 +- examples/passing/2958.purs | 2 +- examples/passing/2972.purs | 2 +- examples/passing/3114.purs | 6 +- examples/passing/3125.purs | 2 +- examples/passing/3187-UnusedNameClash.purs | 2 +- examples/passing/652.purs | 2 +- examples/passing/810.purs | 2 +- examples/passing/862.purs | 2 +- examples/passing/922.purs | 2 +- examples/passing/Ado.purs | 10 +- examples/passing/AppendInReverse.purs | 8 +- examples/passing/Applicative.purs | 2 +- examples/passing/ArrayType.purs | 2 +- examples/passing/Auto.purs | 2 +- examples/passing/AutoPrelude.purs | 2 +- examples/passing/AutoPrelude2.purs | 4 +- examples/passing/BindersInFunctions.purs | 6 +- examples/passing/BindingGroups.purs | 2 +- examples/passing/BlockString.purs | 2 +- examples/passing/CaseInDo.purs | 6 +- examples/passing/CaseInputWildcard.purs | 6 +- examples/passing/CaseMultipleExpressions.purs | 6 +- examples/passing/CaseStatement.purs | 2 +- examples/passing/CheckFunction.purs | 2 +- examples/passing/CheckSynonymBug.purs | 2 +- examples/passing/CheckTypeClass.purs | 2 +- examples/passing/Church.purs | 2 +- examples/passing/ClassRefSyntax.purs | 2 +- examples/passing/Collatz.purs | 24 +- examples/passing/Comparisons.purs | 4 +- examples/passing/Conditional.purs | 2 +- examples/passing/Console.purs | 4 +- examples/passing/ConstraintInference.purs | 2 +- examples/passing/ConstraintParens.purs | 2 +- examples/passing/ConstraintParsingIssue.purs | 2 +- examples/passing/ContextSimplification.purs | 2 +- examples/passing/DataAndType.purs | 2 +- .../passing/DataConsClassConsOverlapOk.purs | 2 +- examples/passing/DctorName.purs | 4 +- examples/passing/DctorOperatorAlias.purs | 8 +- examples/passing/DeepArrayBinder.purs | 4 +- examples/passing/DeepCase.purs | 2 +- examples/passing/DeriveNewtype.purs | 2 +- .../passing/DeriveWithNestedSynonyms.purs | 2 +- examples/passing/Deriving.purs | 2 +- examples/passing/DerivingFunctor.purs | 2 +- examples/passing/Do.purs | 2 +- examples/passing/Dollar.purs | 2 +- examples/passing/DuplicateProperties.purs | 2 +- examples/passing/Eff.purs | 26 -- examples/passing/EffFn.purs | 10 +- examples/passing/EmptyDataDecls.purs | 2 +- examples/passing/EmptyRow.purs | 2 +- examples/passing/EmptyTypeClass.purs | 6 +- examples/passing/EntailsKindedType.purs | 4 +- examples/passing/Eq1Deriving.purs | 2 +- examples/passing/Eq1InEqDeriving.purs | 2 +- examples/passing/EqOrd.purs | 2 +- examples/passing/ExplicitImportReExport.purs | 2 +- .../passing/ExplicitOperatorSections.purs | 2 +- examples/passing/ExportExplicit.purs | 2 +- examples/passing/ExportExplicit2.purs | 2 +- .../passing/ExportedInstanceDeclarations.purs | 4 +- examples/passing/ExtendedInfixOperators.purs | 2 +- examples/passing/Fib.purs | 26 +- examples/passing/FieldConsPuns.purs | 2 +- examples/passing/FieldPuns.purs | 2 +- examples/passing/FinalTagless.purs | 2 +- examples/passing/ForeignKind.purs | 2 +- examples/passing/FunWithFunDeps.purs | 2 +- examples/passing/FunctionScope.purs | 2 +- examples/passing/FunctionalDependencies.purs | 2 +- examples/passing/Functions.purs | 2 +- examples/passing/Functions2.purs | 2 +- examples/passing/Generalization1.purs | 2 +- examples/passing/GenericsRep.purs | 6 +- examples/passing/Guards.purs | 2 +- examples/passing/HasOwnProperty.purs | 2 +- examples/passing/HoistError.purs | 4 +- examples/passing/IfThenElseMaybe.purs | 2 +- examples/passing/IfWildcard.purs | 6 +- examples/passing/ImplicitEmptyImport.purs | 2 +- examples/passing/Import.purs | 2 +- examples/passing/ImportExplicit.purs | 2 +- examples/passing/ImportHiding.purs | 2 +- examples/passing/ImportQualified.purs | 4 +- .../InferRecFunWithConstrainedArgument.purs | 2 +- examples/passing/InstanceBeforeClass.purs | 2 +- examples/passing/InstanceChain.purs | 2 +- examples/passing/InstanceSigs.purs | 2 +- examples/passing/InstanceSigsGeneral.purs | 2 +- examples/passing/IntAndChar.purs | 4 +- examples/passing/JSReserved.purs | 2 +- examples/passing/KindedType.purs | 2 +- examples/passing/LargeSumType.purs | 2 +- examples/passing/Let.purs | 6 +- examples/passing/Let2.purs | 2 +- examples/passing/LetInInstance.purs | 2 +- examples/passing/LetPattern.purs | 28 +- examples/passing/LiberalTypeSynonyms.purs | 2 +- examples/passing/MPTCs.purs | 2 +- examples/passing/Match.purs | 2 +- examples/passing/Module.purs | 2 +- examples/passing/ModuleDeps.purs | 2 +- examples/passing/ModuleExport.purs | 2 +- examples/passing/ModuleExportDupes.purs | 2 +- examples/passing/ModuleExportExcluded.purs | 2 +- examples/passing/ModuleExportQualified.purs | 2 +- examples/passing/ModuleExportSelf.purs | 2 +- examples/passing/Monad.purs | 2 +- examples/passing/MonadState.purs | 4 +- examples/passing/MultiArgFunctions.purs | 4 +- examples/passing/MutRec.purs | 2 +- examples/passing/MutRec2.purs | 2 +- examples/passing/MutRec3.purs | 2 +- examples/passing/NakedConstraint.purs | 2 +- examples/passing/NamedPatterns.purs | 2 +- examples/passing/NegativeBinder.purs | 2 +- examples/passing/NegativeIntInRange.purs | 2 +- examples/passing/Nested.purs | 2 +- examples/passing/NestedRecordUpdate.purs | 2 +- .../passing/NestedRecordUpdateWildcards.purs | 2 +- examples/passing/NestedTypeSynonyms.purs | 2 +- examples/passing/NestedWhere.purs | 2 +- examples/passing/NewConsClass.purs | 2 +- examples/passing/Newtype.purs | 4 +- examples/passing/NewtypeClass.purs | 4 +- examples/passing/NewtypeEff.purs | 8 +- examples/passing/NewtypeInstance.purs | 4 +- examples/passing/NewtypeWithRecordUpdate.purs | 2 +- examples/passing/NonConflictingExports.purs | 2 +- .../passing/NonOrphanInstanceFunDepExtra.purs | 2 +- examples/passing/NonOrphanInstanceMulti.purs | 2 +- examples/passing/NumberLiterals.purs | 2 +- examples/passing/ObjectGetter.purs | 2 +- examples/passing/ObjectSynonym.purs | 2 +- examples/passing/ObjectUpdate.purs | 2 +- examples/passing/ObjectUpdate2.purs | 2 +- examples/passing/ObjectUpdater.purs | 6 +- examples/passing/ObjectWildcards.purs | 6 +- examples/passing/Objects.purs | 2 +- examples/passing/OneConstructor.purs | 2 +- examples/passing/OperatorAlias.purs | 2 +- examples/passing/OperatorAliasElsewhere.purs | 2 +- examples/passing/OperatorAssociativity.purs | 4 +- examples/passing/OperatorInlining.purs | 2 +- examples/passing/OperatorSections.purs | 2 +- examples/passing/Operators.purs | 4 +- examples/passing/OptimizerBug.purs | 2 +- examples/passing/OptionalQualified.purs | 2 +- examples/passing/Ord1Deriving.purs | 2 +- examples/passing/Ord1InOrdDeriving.purs | 2 +- examples/passing/ParensInType.purs | 16 +- examples/passing/ParensInTypedBinder.purs | 12 +- examples/passing/PartialFunction.purs | 4 +- examples/passing/Patterns.purs | 2 +- .../passing/PendingConflictingImports.purs | 2 +- .../passing/PendingConflictingImports2.purs | 2 +- examples/passing/Person.purs | 2 +- examples/passing/PolyLabels.purs | 6 +- examples/passing/PrimedTypeName.purs | 2 +- examples/passing/QualifiedNames.purs | 4 +- .../passing/QualifiedQualifiedImports.purs | 2 +- examples/passing/Rank2Data.purs | 2 +- examples/passing/Rank2Object.purs | 2 +- examples/passing/Rank2TypeSynonym.purs | 2 +- examples/passing/Rank2Types.purs | 2 +- examples/passing/ReExportQualified.purs | 2 +- examples/passing/RebindableSyntax.purs | 4 +- examples/passing/Recursion.purs | 2 +- examples/passing/RedefinedFixity.purs | 2 +- examples/passing/ReservedWords.purs | 6 +- examples/passing/ResolvableScopeConflict.purs | 2 +- .../passing/ResolvableScopeConflict2.purs | 2 +- .../passing/ResolvableScopeConflict3.purs | 2 +- examples/passing/RowConstructors.purs | 4 +- .../passing/RowInInstanceHeadDetermined.purs | 2 +- examples/passing/RowLacks.purs | 2 +- examples/passing/RowNub.purs | 2 +- examples/passing/RowPolyInstanceContext.purs | 2 +- examples/passing/RowUnion.purs | 6 +- examples/passing/RowsInInstanceContext.purs | 10 +- examples/passing/RunFnInline.purs | 2 +- examples/passing/RuntimeScopeIssue.purs | 2 +- examples/passing/ScopedTypeVariables.purs | 2 +- examples/passing/Sequence.purs | 4 +- examples/passing/SequenceDesugared.purs | 4 +- examples/passing/ShadowedModuleName.purs | 2 +- examples/passing/ShadowedName.purs | 4 +- examples/passing/ShadowedRename.purs | 4 +- examples/passing/ShadowedTCO.purs | 2 +- examples/passing/ShadowedTCOLet.purs | 6 +- examples/passing/SignedNumericLiterals.purs | 2 +- examples/passing/SolvingAppendSymbol.purs | 12 +- examples/passing/SolvingCompareSymbol.purs | 15 +- examples/passing/SolvingIsSymbol.purs | 4 +- examples/passing/Stream.purs | 6 +- examples/passing/StringEdgeCases/Records.purs | 2 +- examples/passing/StringEdgeCases/Symbols.purs | 10 +- examples/passing/StringEscapes.purs | 2 +- examples/passing/Superclasses1.purs | 2 +- examples/passing/Superclasses3.purs | 8 +- examples/passing/TCO.purs | 4 +- examples/passing/TCOCase.purs | 2 +- examples/passing/TailCall.purs | 2 +- examples/passing/Tick.purs | 2 +- examples/passing/TopLevelCase.purs | 2 +- examples/passing/TransitiveImport.purs | 2 +- .../passing/TypeClassMemberOrderChange.purs | 2 +- examples/passing/TypeClasses.purs | 2 +- examples/passing/TypeClassesInOrder.purs | 2 +- ...peClassesWithOverlappingTypeVariables.purs | 2 +- examples/passing/TypeDecl.purs | 2 +- examples/passing/TypeOperators.purs | 2 +- examples/passing/TypeSynonymInData.purs | 2 +- examples/passing/TypeSynonyms.purs | 2 +- examples/passing/TypeWildcards.purs | 2 +- .../passing/TypeWildcardsRecordExtension.purs | 2 +- examples/passing/TypeWithoutParens.purs | 2 +- examples/passing/TypedBinders.purs | 4 +- examples/passing/TypedWhere.purs | 2 +- examples/passing/UTF8Sourcefile.purs | 2 +- examples/passing/UnderscoreIdent.purs | 2 +- examples/passing/UnicodeIdentifier.purs | 2 +- examples/passing/UnicodeOperators.purs | 2 +- examples/passing/UnicodeType.purs | 2 +- .../passing/UnifyInTypeInstanceLookup.purs | 2 +- examples/passing/Unit.purs | 2 +- .../passing/UnknownInTypeClassLookup.purs | 2 +- examples/passing/UnsafeCoerce.purs | 6 +- examples/passing/UntupledConstraints.purs | 2 +- examples/passing/UsableTypeClassMethods.purs | 2 +- examples/passing/Where.purs | 6 +- examples/passing/WildcardInInstance.purs | 28 +- examples/passing/WildcardType.purs | 2 +- examples/passing/iota.purs | 2 +- examples/passing/s.purs | 2 +- examples/warning/2383.purs | 4 +- examples/warning/2411.purs | 4 +- examples/warning/2542.purs | 2 +- examples/warning/DuplicateImport.purs | 4 +- .../warning/DuplicateSelectiveImport.purs | 4 +- examples/warning/HidingImport.purs | 4 +- examples/warning/ImplicitImport.purs | 4 +- examples/warning/ImplicitQualifiedImport.purs | 6 +- .../ImplicitQualifiedImportReExport.purs | 6 +- examples/warning/NewtypeInstance2.purs | 1 - examples/warning/NewtypeInstance3.purs | 1 - examples/warning/NewtypeInstance4.purs | 1 - examples/warning/UnusedExplicitImport.purs | 4 +- .../warning/UnusedExplicitImportTypeOp.purs | 4 +- .../warning/UnusedExplicitImportValOp.purs | 4 +- examples/warning/UnusedImport.purs | 4 +- src/Language/PureScript/CodeGen/JS.hs | 2 +- src/Language/PureScript/Constants.hs | 125 +++++---- src/Language/PureScript/Docs/Prim.hs | 162 +++++++++-- src/Language/PureScript/Environment.hs | 265 +++++++++++++----- src/Language/PureScript/Ide/Prim.hs | 29 +- src/Language/PureScript/Interactive/Module.hs | 10 +- src/Language/PureScript/ModuleDependencies.hs | 2 +- src/Language/PureScript/Sugar/Names/Env.hs | 29 +- src/Language/PureScript/Sugar/TypeClasses.hs | 2 + .../PureScript/TypeChecker/Entailment.hs | 61 ++-- tests/Language/PureScript/Ide/ImportsSpec.hs | 4 +- tests/TestPrimDocs.hs | 10 +- tests/TestPsci/CompletionTest.hs | 21 +- tests/support/bower.json | 102 ++++--- 319 files changed, 1096 insertions(+), 807 deletions(-) delete mode 100644 examples/failing/DeriveOldGeneric.purs delete mode 100644 examples/failing/Eff.purs delete mode 100644 examples/passing/Eff.purs diff --git a/core-tests/tests/GenericDeriving.purs b/core-tests/tests/GenericDeriving.purs index f8e229c70a..b95b185fb2 100755 --- a/core-tests/tests/GenericDeriving.purs +++ b/core-tests/tests/GenericDeriving.purs @@ -2,8 +2,8 @@ module Test.GenericDeriving where import Prelude -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log, logShow) +import Effect (Effect) +import Effect.Console (log, logShow) import Data.Generic (class Generic, gShow, gEq) import Partial.Unsafe (unsafePartial) @@ -24,7 +24,7 @@ newtype X b = X b derive instance genericX :: Generic (X String) -main :: forall eff. Eff (console :: CONSOLE | eff) Unit +main :: Effect Unit main = unsafePartial do log $ gShow (D { "asgård": C [ A 1.0 "test", B 42, D { "asgård": true } ] }) logShow $ gEq (C [B 0]) (C [B 0] :: A Empty) diff --git a/core-tests/tests/Main.purs b/core-tests/tests/Main.purs index 8cd7b682cc..8559c444ac 100644 --- a/core-tests/tests/Main.purs +++ b/core-tests/tests/Main.purs @@ -1,9 +1,8 @@ module Test.Main where import Prelude -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE) +import Effect (Effect) import Test.GenericDeriving as GenericDeriving -main :: forall eff. Eff (console :: CONSOLE | eff) Unit +main :: Effect Unit main = GenericDeriving.main diff --git a/examples/failing/1310.purs b/examples/failing/1310.purs index 02fde55f9f..1f4ff96660 100644 --- a/examples/failing/1310.purs +++ b/examples/failing/1310.purs @@ -3,8 +3,8 @@ module Issue1310 where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console class Inject f g where inj :: forall a. f a -> g a @@ -12,7 +12,7 @@ class Inject f g where instance inject :: Inject f f where inj x = x -foreign import data Oops :: Effect +newtype Oops a = Oops (Effect a) -main :: forall eff. Eff (oops :: Oops | eff) Unit -main = inj (log "Oops") +main :: Effect Unit +main = inj (Oops (log "Oops")) diff --git a/examples/failing/3132.purs b/examples/failing/3132.purs index 9bbf3c6d96..7c76d70cce 100644 --- a/examples/failing/3132.purs +++ b/examples/failing/3132.purs @@ -3,8 +3,8 @@ module Main (class C3) where import Prelude -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log) +import Effect (Effect) +import Effect.Console (log) class C1 instance inst1 :: C1 @@ -13,6 +13,6 @@ class C1 <= C2 a class (C2 a) <= C3 a b -main :: forall e. Eff (console :: CONSOLE | e) Unit +main :: Effect Unit main = do log "Done" diff --git a/examples/failing/ArrayType.purs b/examples/failing/ArrayType.purs index a93731c493..708fa5cdf4 100644 --- a/examples/failing/ArrayType.purs +++ b/examples/failing/ArrayType.purs @@ -3,7 +3,6 @@ module Main where import Prelude -import Control.Monad.Eff.Console bar :: Number -> Number -> Number bar n m = n + m diff --git a/examples/failing/DeriveOldGeneric.purs b/examples/failing/DeriveOldGeneric.purs deleted file mode 100644 index c90ec9e50d..0000000000 --- a/examples/failing/DeriveOldGeneric.purs +++ /dev/null @@ -1,10 +0,0 @@ --- @shouldFailWith CannotDerive -module DeriveOldGeneric where - -import Prelude -import Data.Generic -import Control.Monad.Eff.Console (log) - -newtype Foo = Foo Int - -derive instance genericFoo :: Generic Foo diff --git a/examples/failing/Eff.purs b/examples/failing/Eff.purs deleted file mode 100644 index e41e085817..0000000000 --- a/examples/failing/Eff.purs +++ /dev/null @@ -1,13 +0,0 @@ --- @shouldFailWith TypesDoNotUnify -module Main where - -import Prelude -import Control.Monad.Eff -import Control.Monad.ST -import Control.Monad.Eff.Console - -test = pureST (do - ref <- newSTRef 0 - log "ST" - modifySTRef ref $ \n -> n + 1 - readSTRef ref) diff --git a/examples/failing/ExportExplicit1.purs b/examples/failing/ExportExplicit1.purs index f99e824756..78044a5cc8 100644 --- a/examples/failing/ExportExplicit1.purs +++ b/examples/failing/ExportExplicit1.purs @@ -2,7 +2,7 @@ module Main where import M1 -import Control.Monad.Eff.Console (log) +import Effect.Console (log) testX = X diff --git a/examples/failing/ExportExplicit3.purs b/examples/failing/ExportExplicit3.purs index e4cbe54c45..f52293fc0a 100644 --- a/examples/failing/ExportExplicit3.purs +++ b/examples/failing/ExportExplicit3.purs @@ -2,7 +2,7 @@ module Main where import M1 as M -import Control.Monad.Eff.Console (log) +import Effect.Console (log) -- should fail as Z is not exported from M1 testZ = M.Z diff --git a/examples/failing/ProgrammableTypeErrors.purs b/examples/failing/ProgrammableTypeErrors.purs index 845a3251b1..11e7b488b0 100644 --- a/examples/failing/ProgrammableTypeErrors.purs +++ b/examples/failing/ProgrammableTypeErrors.purs @@ -4,8 +4,8 @@ module Main where import Prelude import Prim.TypeError -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (log) +import Effect (Effect) +import Effect.Console (log) class MyShow a where myShow :: a -> String @@ -13,5 +13,5 @@ class MyShow a where instance cannotShowFunctions :: Fail (Text "Cannot show functions") => MyShow (a -> b) where myShow _ = "unreachable" -main :: Eff _ _ +main :: Effect Unit main = log (myShow (_ + 1)) diff --git a/examples/failing/ProgrammableTypeErrorsTypeString.purs b/examples/failing/ProgrammableTypeErrorsTypeString.purs index 904e127e4e..d9ba1b27df 100644 --- a/examples/failing/ProgrammableTypeErrorsTypeString.purs +++ b/examples/failing/ProgrammableTypeErrorsTypeString.purs @@ -4,8 +4,8 @@ module Main where import Prelude import Prim.TypeError -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (log) +import Effect (Effect) +import Effect.Console (log) newtype MyType a = MyType a @@ -19,6 +19,6 @@ instance cannotShowFunctions :: infixl 6 type Beside as <> -main :: Eff _ _ +main :: Effect Unit main = do log $ show (MyType 2) diff --git a/examples/failing/RowConstructors1.purs b/examples/failing/RowConstructors1.purs index 533773ce84..9587fda5aa 100644 --- a/examples/failing/RowConstructors1.purs +++ b/examples/failing/RowConstructors1.purs @@ -1,7 +1,7 @@ -- @shouldFailWith KindsDoNotUnify module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Foo = Bar type Baz = { | Foo } diff --git a/examples/failing/RowConstructors2.purs b/examples/failing/RowConstructors2.purs index 1ab8236877..aeec350276 100644 --- a/examples/failing/RowConstructors2.purs +++ b/examples/failing/RowConstructors2.purs @@ -1,7 +1,7 @@ -- @shouldFailWith KindsDoNotUnify module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) type Foo r = (x :: Number | r) type Bar = { | Foo } diff --git a/examples/failing/RowConstructors3.purs b/examples/failing/RowConstructors3.purs index 60e3950e3e..9cb9ca92ce 100644 --- a/examples/failing/RowConstructors3.purs +++ b/examples/failing/RowConstructors3.purs @@ -1,7 +1,7 @@ -- @shouldFailWith KindsDoNotUnify module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) type Foo = { x :: Number } type Bar = { | Foo } diff --git a/examples/failing/RowLacks.purs b/examples/failing/RowLacks.purs index d39042e557..7805872e63 100644 --- a/examples/failing/RowLacks.purs +++ b/examples/failing/RowLacks.purs @@ -1,7 +1,7 @@ -- @shouldFailWith NoInstanceFound module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Prim.Row (class Lacks) import Type.Row (RProxy(..)) diff --git a/examples/failing/SkolemEscape2.purs b/examples/failing/SkolemEscape2.purs index 38d64cc332..1a9b0606aa 100644 --- a/examples/failing/SkolemEscape2.purs +++ b/examples/failing/SkolemEscape2.purs @@ -2,9 +2,10 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.ST +import Effect +import Control.Monad.ST as ST +import Control.Monad.ST.Ref as STRef test _ = do - r <- runST (newSTRef 0) - pure 0 + r <- pure (ST.run (STRef.new 0)) + pure r diff --git a/examples/failing/Superclasses5.purs b/examples/failing/Superclasses5.purs index 486f4e8cb9..5bbfae69ea 100644 --- a/examples/failing/Superclasses5.purs +++ b/examples/failing/Superclasses5.purs @@ -3,7 +3,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (logShow) +import Effect.Console (logShow) class Su a where su :: a -> a diff --git a/examples/failing/TypedBinders.purs b/examples/failing/TypedBinders.purs index 756f27558f..f13a759543 100644 --- a/examples/failing/TypedBinders.purs +++ b/examples/failing/TypedBinders.purs @@ -1,9 +1,9 @@ -- @shouldFailWith ErrorParsingModule module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) -test = (\f :: Int -> Int -> f 10) id +test = (\f :: Int -> Int -> f 10) identity main = do let t1 = test diff --git a/examples/failing/TypedBinders2.purs b/examples/failing/TypedBinders2.purs index f23c1a1b5e..7262441163 100644 --- a/examples/failing/TypedBinders2.purs +++ b/examples/failing/TypedBinders2.purs @@ -2,7 +2,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) main = do s :: String <- log "Foo" diff --git a/examples/failing/TypedBinders3.purs b/examples/failing/TypedBinders3.purs index 8a25264201..3edcfd9404 100644 --- a/examples/failing/TypedBinders3.purs +++ b/examples/failing/TypedBinders3.purs @@ -2,7 +2,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) test = case 1 of (0 :: String) -> true diff --git a/examples/failing/TypedHole.purs b/examples/failing/TypedHole.purs index c371e67d0e..9cb6e34fde 100644 --- a/examples/failing/TypedHole.purs +++ b/examples/failing/TypedHole.purs @@ -2,8 +2,7 @@ module Main where import Prelude -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log) +import Effect (Effect) -main :: forall e. Eff (console :: CONSOLE | e) Unit +main :: Effect Unit main = ?ummm diff --git a/examples/failing/UnderscoreModuleName.purs b/examples/failing/UnderscoreModuleName.purs index a7d3f0440b..671e6a34a6 100644 --- a/examples/failing/UnderscoreModuleName.purs +++ b/examples/failing/UnderscoreModuleName.purs @@ -1,6 +1,6 @@ -- @shouldFailWith ErrorParsingModule module Bad_Module where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) main = log "Done" diff --git a/examples/passing/1110.purs b/examples/passing/1110.purs index f475fc028b..32ecebcec9 100644 --- a/examples/passing/1110.purs +++ b/examples/passing/1110.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data X a = X diff --git a/examples/passing/1185.purs b/examples/passing/1185.purs index f4ba728f20..c32b7e3248 100644 --- a/examples/passing/1185.purs +++ b/examples/passing/1185.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Person = Person String Boolean diff --git a/examples/passing/1335.purs b/examples/passing/1335.purs index 3a0bb6b34f..eadb2572ea 100644 --- a/examples/passing/1335.purs +++ b/examples/passing/1335.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) x :: forall a. a -> String x a = y "Test" diff --git a/examples/passing/1570.purs b/examples/passing/1570.purs index 1bd0172918..18988478f2 100644 --- a/examples/passing/1570.purs +++ b/examples/passing/1570.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) test :: forall a. a -> a test = \(x :: a) -> x diff --git a/examples/passing/1664.purs b/examples/passing/1664.purs index 35a17eddab..c488037c15 100644 --- a/examples/passing/1664.purs +++ b/examples/passing/1664.purs @@ -1,14 +1,14 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console data Identity a = Identity a -newtype IdentityEff e a = IdentityEff (Eff e (Identity a)) +newtype IdentityEff a = IdentityEff (Effect (Identity a)) -test :: forall e a. IdentityEff e a -> IdentityEff e Unit +test :: forall a. IdentityEff a -> IdentityEff Unit test (IdentityEff action) = IdentityEff $ do (Identity x :: Identity _) <- action pure $ Identity unit diff --git a/examples/passing/1697.purs b/examples/passing/1697.purs index 83e87eb0de..fee4d77d0f 100644 --- a/examples/passing/1697.purs +++ b/examples/passing/1697.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) _2 :: forall a. a -> a _2 a = a diff --git a/examples/passing/1807.purs b/examples/passing/1807.purs index 7b221b3416..3e9e63fa62 100644 --- a/examples/passing/1807.purs +++ b/examples/passing/1807.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) fn = _.b.c.d a = {b:{c:{d:2}}} diff --git a/examples/passing/1881.purs b/examples/passing/1881.purs index b4351cb89b..595400fe78 100644 --- a/examples/passing/1881.purs +++ b/examples/passing/1881.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) foo = 1 diff --git a/examples/passing/1991.purs b/examples/passing/1991.purs index f7d10b674f..b98d2ea96d 100644 --- a/examples/passing/1991.purs +++ b/examples/passing/1991.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) singleton :: forall a. a -> Array a singleton x = [x] diff --git a/examples/passing/2018.purs b/examples/passing/2018.purs index e09f4825a8..8ace881679 100644 --- a/examples/passing/2018.purs +++ b/examples/passing/2018.purs @@ -3,10 +3,10 @@ module Main where import Prelude import A (foo) import B (Foo(..)) -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log) +import Effect (Effect) +import Effect.Console (log) -main :: forall e. Eff (console :: CONSOLE | e) Unit +main :: Effect Unit main = do let tmp = foo X log "Done" diff --git a/examples/passing/2049.purs b/examples/passing/2049.purs index 2e44907962..d9307b301f 100644 --- a/examples/passing/2049.purs +++ b/examples/passing/2049.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data List a = Cons a (List a) | Nil diff --git a/examples/passing/2136.purs b/examples/passing/2136.purs index 98c3972ed3..9082a906e3 100644 --- a/examples/passing/2136.purs +++ b/examples/passing/2136.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) main = if (negate (bottom :: Int) > top) diff --git a/examples/passing/2138.purs b/examples/passing/2138.purs index 1c05373757..b0cae5ee48 100644 --- a/examples/passing/2138.purs +++ b/examples/passing/2138.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Lib (A(B,C)) diff --git a/examples/passing/2172.purs b/examples/passing/2172.purs index 087301e9d2..34580ccd3d 100644 --- a/examples/passing/2172.purs +++ b/examples/passing/2172.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) foreign import a' :: Number foreign import b' :: Number diff --git a/examples/passing/2197-1.purs b/examples/passing/2197-1.purs index a0c808f350..6b05c680e8 100644 --- a/examples/passing/2197-1.purs +++ b/examples/passing/2197-1.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console +import Effect.Console import Prim as P type Number = P.Number diff --git a/examples/passing/2197-2.purs b/examples/passing/2197-2.purs index 94354e94cd..b9122c5a83 100644 --- a/examples/passing/2197-2.purs +++ b/examples/passing/2197-2.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console +import Effect.Console import Prim (Int) type Number = Int diff --git a/examples/passing/2252.purs b/examples/passing/2252.purs index a69c517797..598b37960b 100644 --- a/examples/passing/2252.purs +++ b/examples/passing/2252.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data T a = T diff --git a/examples/passing/2288.purs b/examples/passing/2288.purs index 78c8ab4e83..cab96bd151 100644 --- a/examples/passing/2288.purs +++ b/examples/passing/2288.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console import Data.Array import Data.Array.Partial as P import Partial.Unsafe diff --git a/examples/passing/2378.purs b/examples/passing/2378.purs index 75ada8ce72..fb42baeaad 100644 --- a/examples/passing/2378.purs +++ b/examples/passing/2378.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class Foo (a :: Symbol) diff --git a/examples/passing/2438.purs b/examples/passing/2438.purs index 75bd83ca82..223f2ff8ee 100644 --- a/examples/passing/2438.purs +++ b/examples/passing/2438.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) done :: String done = {"𝌆": "Done"}."𝌆" diff --git a/examples/passing/2609.purs b/examples/passing/2609.purs index eb54bb8a2f..132e04462a 100644 --- a/examples/passing/2609.purs +++ b/examples/passing/2609.purs @@ -2,11 +2,11 @@ module Main where import Prelude import Eg (Foo'(Bar'), (:->)) -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log) +import Effect (Effect) +import Effect.Console (log) bar' :: Foo' bar' = 4 :-> 5 -main :: forall e. Eff (console :: CONSOLE | e) Unit +main :: Effect Unit main = case bar' of Bar' l r -> log "Done" diff --git a/examples/passing/2616.purs b/examples/passing/2616.purs index d48e99df3e..92b6666904 100644 --- a/examples/passing/2616.purs +++ b/examples/passing/2616.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) newtype F r a = F { x :: a | r } @@ -10,4 +10,4 @@ unF (F x) = x derive instance functorF :: Functor (F r) -main = log (unF (map id (F { x: "Done", y: 42 }))).x +main = log (unF (map identity (F { x: "Done", y: 42 }))).x diff --git a/examples/passing/2626.purs b/examples/passing/2626.purs index cee8514f8e..5fd03609ff 100644 --- a/examples/passing/2626.purs +++ b/examples/passing/2626.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) f = \(x :: forall a. a -> a) -> x x diff --git a/examples/passing/2663.purs b/examples/passing/2663.purs index 0e690908a2..fd6ca35617 100644 --- a/examples/passing/2663.purs +++ b/examples/passing/2663.purs @@ -2,7 +2,7 @@ module Main where import Prelude import Prim.TypeError (class Warn, Text) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) foo :: forall t. Warn (Text "Example") => t -> t foo x = x diff --git a/examples/passing/2689.purs b/examples/passing/2689.purs index ab0afd8925..08e6851e30 100644 --- a/examples/passing/2689.purs +++ b/examples/passing/2689.purs @@ -1,11 +1,11 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Effect.Console import Data.Array.Partial import Partial.Unsafe -sumTCObug = go id where +sumTCObug = go identity where go f 0 = f go f n = let @@ -13,7 +13,7 @@ sumTCObug = go id where in go f' 0 -sumTCObug' = go id where +sumTCObug' = go identity where go f 0 = f go f n = go (\a -> n + a) 0 diff --git a/examples/passing/2756.purs b/examples/passing/2756.purs index 81e5660f60..46a930f9e8 100644 --- a/examples/passing/2756.purs +++ b/examples/passing/2756.purs @@ -1,20 +1,20 @@ module Main where -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (log) +import Effect (Effect) +import Effect.Console (log) import Prelude -pu :: forall eff. Eff eff Unit -pu = pure unit +pu :: forall i. i -> Effect Unit +pu _ = pure unit -type C eff = { pu :: Eff eff Unit } +type C i = { pu :: i -> Effect Unit } -sampleC :: C () +sampleC :: C Unit sampleC = { pu: pu } newtype Identity a = Id a -sampleIdC :: Identity (C ()) +sampleIdC :: Identity (C Unit) sampleIdC = Id { pu : pu } main = log "Done" diff --git a/examples/passing/2787.purs b/examples/passing/2787.purs index d7e957a5bd..608cfc785c 100644 --- a/examples/passing/2787.purs +++ b/examples/passing/2787.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Effect.Console main | between 0 1 2 = log "Fail" diff --git a/examples/passing/2795.purs b/examples/passing/2795.purs index a291a7d343..110dc023aa 100644 --- a/examples/passing/2795.purs +++ b/examples/passing/2795.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data X = X Int | Y diff --git a/examples/passing/2806.purs b/examples/passing/2806.purs index 848b3a3b24..658a913287 100644 --- a/examples/passing/2806.purs +++ b/examples/passing/2806.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Stream a = Cons a (Stream a) diff --git a/examples/passing/2947.purs b/examples/passing/2947.purs index fbc1b201fb..0b0b3f2419 100644 --- a/examples/passing/2947.purs +++ b/examples/passing/2947.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Foo = Foo diff --git a/examples/passing/2958.purs b/examples/passing/2958.purs index 462bcaa853..b6b0619dfb 100644 --- a/examples/passing/2958.purs +++ b/examples/passing/2958.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console +import Effect.Console data Nil data Snoc xs x diff --git a/examples/passing/2972.purs b/examples/passing/2972.purs index fbf961e5d6..d0e97b398e 100644 --- a/examples/passing/2972.purs +++ b/examples/passing/2972.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Prelude (class Show, show) type I t = t diff --git a/examples/passing/3114.purs b/examples/passing/3114.purs index 9d330b14bd..5d9d2af4c8 100644 --- a/examples/passing/3114.purs +++ b/examples/passing/3114.purs @@ -5,8 +5,8 @@ import Prelude import Data.Either import Data.Maybe import Data.Tuple -import Control.Monad.Eff -import Control.Monad.Eff.Console (log) +import Effect +import Effect.Console (log) import VendoredVariant import Data.Symbol @@ -21,7 +21,7 @@ _foo = SProxy _bar :: SProxy "bar" _bar = SProxy -main :: Eff _ Unit +main :: Effect Unit main = do let -- with the type signatures on `a`, this compiles fine. diff --git a/examples/passing/3125.purs b/examples/passing/3125.purs index d427fd46bb..152e86d01d 100644 --- a/examples/passing/3125.purs +++ b/examples/passing/3125.purs @@ -2,7 +2,7 @@ module Main where import Prelude import Data.Monoid (class Monoid, mempty) -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) data B a = B a a diff --git a/examples/passing/3187-UnusedNameClash.purs b/examples/passing/3187-UnusedNameClash.purs index bd84f095b8..434a3c9f9b 100644 --- a/examples/passing/3187-UnusedNameClash.purs +++ b/examples/passing/3187-UnusedNameClash.purs @@ -1,7 +1,7 @@ module Main (main) where import Prelude ((+)) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) -- the __unused parameter used to get optimized away abuseUnused :: forall a. a -> a diff --git a/examples/passing/652.purs b/examples/passing/652.purs index 79995a706a..c001d0292a 100644 --- a/examples/passing/652.purs +++ b/examples/passing/652.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class Foo a b diff --git a/examples/passing/810.purs b/examples/passing/810.purs index 4e32d10da6..332723c3da 100644 --- a/examples/passing/810.purs +++ b/examples/passing/810.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Maybe a = Nothing | Just a diff --git a/examples/passing/862.purs b/examples/passing/862.purs index 97c664d5cb..53570ee62c 100644 --- a/examples/passing/862.purs +++ b/examples/passing/862.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Effect.Console id' = (\x -> x) <$> \y -> y diff --git a/examples/passing/922.purs b/examples/passing/922.purs index 07a7ad15a9..3e944b30f3 100644 --- a/examples/passing/922.purs +++ b/examples/passing/922.purs @@ -2,7 +2,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Effect.Console class Default a where def :: a diff --git a/examples/passing/Ado.purs b/examples/passing/Ado.purs index 3e7ed949fb..4bb1c5d613 100644 --- a/examples/passing/Ado.purs +++ b/examples/passing/Ado.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) -import Control.Monad.Eff.Ref (newRef, writeRef, readRef) +import Effect.Console (log) +import Effect.Ref as Ref data Maybe a = Nothing | Just a @@ -67,10 +67,10 @@ test11 = \_ -> ado in show (x :: Int) <> y <> show (z :: Array Int) main = do - r <- newRef "X" + r <- Ref.new "X" log =<< ado - _ <- writeRef r "D" - a <- readRef r + _ <- Ref.write "D" r + a <- Ref.read r b <- pure "o" let c = "n" d <- pure "e" diff --git a/examples/passing/AppendInReverse.purs b/examples/passing/AppendInReverse.purs index d70ba70689..b900657e59 100644 --- a/examples/passing/AppendInReverse.purs +++ b/examples/passing/AppendInReverse.purs @@ -2,16 +2,16 @@ module Main where import Prelude import Data.Symbol (SProxy(..)) -import Type.Data.Symbol (class AppendSymbol) -import Control.Monad.Eff.Console (log) +import Prim.Symbol (class Append) +import Effect.Console (log) class Balanced (sym :: Symbol) instance balanced1 :: Balanced "" else instance balanced2 - :: ( AppendSymbol "(" sym1 sym - , AppendSymbol sym2 ")" sym1 + :: ( Append "(" sym1 sym + , Append sym2 ")" sym1 , Balanced sym2 ) => Balanced sym diff --git a/examples/passing/Applicative.purs b/examples/passing/Applicative.purs index d78e2aa13f..f8ea7c5689 100644 --- a/examples/passing/Applicative.purs +++ b/examples/passing/Applicative.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class Applicative f where pure :: forall a. a -> f a diff --git a/examples/passing/ArrayType.purs b/examples/passing/ArrayType.purs index a3530a545e..b801b930e2 100644 --- a/examples/passing/ArrayType.purs +++ b/examples/passing/ArrayType.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class Pointed p where point :: forall a. a -> p a diff --git a/examples/passing/Auto.purs b/examples/passing/Auto.purs index 34b7858a12..5a831d9458 100644 --- a/examples/passing/Auto.purs +++ b/examples/passing/Auto.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Auto s i o = Auto { state :: s, step :: s -> i -> o } diff --git a/examples/passing/AutoPrelude.purs b/examples/passing/AutoPrelude.purs index 27fa41c123..d7e95b5b40 100644 --- a/examples/passing/AutoPrelude.purs +++ b/examples/passing/AutoPrelude.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) f x = x * 10.0 g y = y - 10.0 diff --git a/examples/passing/AutoPrelude2.purs b/examples/passing/AutoPrelude2.purs index 4db3aaf14a..03d18fdbf8 100644 --- a/examples/passing/AutoPrelude2.purs +++ b/examples/passing/AutoPrelude2.purs @@ -2,9 +2,9 @@ module Main where import Prelude import Prelude as P -import Control.Monad.Eff.Console +import Effect.Console f :: forall a. a -> a -f = P.id +f = P.identity main = P.($) log ((f P.<<< f) "Done") diff --git a/examples/passing/BindersInFunctions.purs b/examples/passing/BindersInFunctions.purs index ee9c5dd141..d1fda599e1 100644 --- a/examples/passing/BindersInFunctions.purs +++ b/examples/passing/BindersInFunctions.purs @@ -3,13 +3,13 @@ module Main where import Prelude import Partial.Unsafe (unsafePartial) import Test.Assert (assert') -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (log) +import Effect (Effect) +import Effect.Console (log) snd :: forall a. Partial => Array a -> a snd = \[_, y] -> y -main :: Eff _ _ +main :: Effect _ main = do let ts = unsafePartial (snd [1.0, 2.0]) assert' "Incorrect result from 'snd'." (ts == 2.0) diff --git a/examples/passing/BindingGroups.purs b/examples/passing/BindingGroups.purs index 0e112d2091..43d0df6c6f 100644 --- a/examples/passing/BindingGroups.purs +++ b/examples/passing/BindingGroups.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) foo = bar where bar r = r + 1.0 diff --git a/examples/passing/BlockString.purs b/examples/passing/BlockString.purs index 2ffa526001..eeb0a7d8d3 100644 --- a/examples/passing/BlockString.purs +++ b/examples/passing/BlockString.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) foo :: String foo = """foo""" diff --git a/examples/passing/CaseInDo.purs b/examples/passing/CaseInDo.purs index 48716f4854..a4fbd8356d 100644 --- a/examples/passing/CaseInDo.purs +++ b/examples/passing/CaseInDo.purs @@ -2,10 +2,10 @@ module Main where import Prelude import Partial.Unsafe (unsafeCrashWith) -import Control.Monad.Eff.Console -import Control.Monad.Eff +import Effect.Console +import Effect -doIt :: forall eff. Eff eff Boolean +doIt :: Effect Boolean doIt = pure true set = do diff --git a/examples/passing/CaseInputWildcard.purs b/examples/passing/CaseInputWildcard.purs index 6448939b9a..d18098f9df 100644 --- a/examples/passing/CaseInputWildcard.purs +++ b/examples/passing/CaseInputWildcard.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (log, CONSOLE) +import Effect (Effect) +import Effect.Console (log) data Foo = X | Y @@ -12,7 +12,7 @@ what x = case _, x, _ of 0, Y, true → X _, _, _ → Y -main :: forall e. Eff (console :: CONSOLE | e) Unit +main :: Effect Unit main = do let tmp = what Y 0 true log "Done" diff --git a/examples/passing/CaseMultipleExpressions.purs b/examples/passing/CaseMultipleExpressions.purs index d434e56de7..535faf1a5c 100644 --- a/examples/passing/CaseMultipleExpressions.purs +++ b/examples/passing/CaseMultipleExpressions.purs @@ -2,10 +2,10 @@ module Main where import Prelude import Partial.Unsafe (unsafeCrashWith) -import Control.Monad.Eff.Console -import Control.Monad.Eff +import Effect.Console +import Effect -doIt :: forall eff. Eff eff Boolean +doIt :: Effect Boolean doIt = pure true set = do diff --git a/examples/passing/CaseStatement.purs b/examples/passing/CaseStatement.purs index 324282d61c..5eb635be99 100644 --- a/examples/passing/CaseStatement.purs +++ b/examples/passing/CaseStatement.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data A = A | B | C diff --git a/examples/passing/CheckFunction.purs b/examples/passing/CheckFunction.purs index cde7d4ba15..82e4152856 100644 --- a/examples/passing/CheckFunction.purs +++ b/examples/passing/CheckFunction.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) test = ((\x -> x+1.0) >>> (\x -> x*2.0)) 4.0 diff --git a/examples/passing/CheckSynonymBug.purs b/examples/passing/CheckSynonymBug.purs index cd06f63f6c..0a664d0766 100644 --- a/examples/passing/CheckSynonymBug.purs +++ b/examples/passing/CheckSynonymBug.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) length :: forall a. Array a -> Int length _ = 0 diff --git a/examples/passing/CheckTypeClass.purs b/examples/passing/CheckTypeClass.purs index 50f2d3e823..cf1e009c66 100644 --- a/examples/passing/CheckTypeClass.purs +++ b/examples/passing/CheckTypeClass.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Bar a = Bar data Baz diff --git a/examples/passing/Church.purs b/examples/passing/Church.purs index 3745805069..ab01d25f34 100644 --- a/examples/passing/Church.purs +++ b/examples/passing/Church.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) type List a = forall r. r -> (a -> r -> r) -> r diff --git a/examples/passing/ClassRefSyntax.purs b/examples/passing/ClassRefSyntax.purs index 13e4e649bb..9297db582e 100644 --- a/examples/passing/ClassRefSyntax.purs +++ b/examples/passing/ClassRefSyntax.purs @@ -1,7 +1,7 @@ module Main where import Lib (class X, go) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) go' :: forall a. X a => a -> a go' = go diff --git a/examples/passing/Collatz.purs b/examples/passing/Collatz.purs index 0fda815c7a..df267fc868 100644 --- a/examples/passing/Collatz.purs +++ b/examples/passing/Collatz.purs @@ -1,20 +1,20 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.ST -import Control.Monad.Eff.Console (log, logShow) +import Effect +import Control.Monad.ST as ST +import Control.Monad.ST.Ref as STRef +import Effect.Console (log, logShow) collatz :: Int -> Int -collatz n = runPure (runST (do - r <- newSTRef n - count <- newSTRef 0 - untilE $ do - _ <- modifySTRef count $ (+) 1 - m <- readSTRef r - _ <- writeSTRef r $ if m `mod` 2 == 0 then m / 2 else 3 * m + 1 - pure $ m == 1 - readSTRef count)) +collatz n = ST.run (do + r <- STRef.new n + count <- STRef.new 0 + ST.while (map (_ /= 1) (STRef.read r)) do + _ <- STRef.modify (_ + 1) count + m <- STRef.read r + void $ STRef.write (if m `mod` 2 == 0 then m / 2 else 3 * m + 1) r + STRef.read count) main = do logShow $ collatz 1000 diff --git a/examples/passing/Comparisons.purs b/examples/passing/Comparisons.purs index 375098d3c2..08038e9ecf 100644 --- a/examples/passing/Comparisons.purs +++ b/examples/passing/Comparisons.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console import Test.Assert main = do diff --git a/examples/passing/Conditional.purs b/examples/passing/Conditional.purs index a3d20520d0..7e36c012a5 100644 --- a/examples/passing/Conditional.purs +++ b/examples/passing/Conditional.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) fns = \f -> if f true then f else \x -> x diff --git a/examples/passing/Console.purs b/examples/passing/Console.purs index a12d699b69..65167277f5 100644 --- a/examples/passing/Console.purs +++ b/examples/passing/Console.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console replicateM_ :: forall m a. Monad m => Number -> m a -> m Unit replicateM_ 0.0 _ = pure unit diff --git a/examples/passing/ConstraintInference.purs b/examples/passing/ConstraintInference.purs index 05f9a2178e..1e11d3119b 100644 --- a/examples/passing/ConstraintInference.purs +++ b/examples/passing/ConstraintInference.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) shout = log <<< (_ <> "!") <<< show diff --git a/examples/passing/ConstraintParens.purs b/examples/passing/ConstraintParens.purs index 5545332f3a..3600718814 100644 --- a/examples/passing/ConstraintParens.purs +++ b/examples/passing/ConstraintParens.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class Foo a where foo ∷ a → a diff --git a/examples/passing/ConstraintParsingIssue.purs b/examples/passing/ConstraintParsingIssue.purs index b16f684ade..04ad2cdbf1 100644 --- a/examples/passing/ConstraintParsingIssue.purs +++ b/examples/passing/ConstraintParsingIssue.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console +import Effect.Console class X a diff --git a/examples/passing/ContextSimplification.purs b/examples/passing/ContextSimplification.purs index 349dcfbd66..e6d3cd61c9 100644 --- a/examples/passing/ContextSimplification.purs +++ b/examples/passing/ContextSimplification.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Effect.Console shout = log <<< (_ <> "!") <<< show diff --git a/examples/passing/DataAndType.purs b/examples/passing/DataAndType.purs index 3d35ce1c99..ce594efcae 100644 --- a/examples/passing/DataAndType.purs +++ b/examples/passing/DataAndType.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data A = A B diff --git a/examples/passing/DataConsClassConsOverlapOk.purs b/examples/passing/DataConsClassConsOverlapOk.purs index 76ab731091..6e32f62b2d 100644 --- a/examples/passing/DataConsClassConsOverlapOk.purs +++ b/examples/passing/DataConsClassConsOverlapOk.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Prim.Row (class Cons) data Cons = Cons diff --git a/examples/passing/DctorName.purs b/examples/passing/DctorName.purs index 05d4f8d1bd..7a16b724bf 100644 --- a/examples/passing/DctorName.purs +++ b/examples/passing/DctorName.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) newtype Bar' = Bar' Int @@ -30,4 +30,4 @@ h (Bar' x) h' ∷ Int h' = h $ Bar' 4 -main = log "Done" \ No newline at end of file +main = log "Done" diff --git a/examples/passing/DctorOperatorAlias.purs b/examples/passing/DctorOperatorAlias.purs index 0a12c8f06a..67f2dfbb8e 100644 --- a/examples/passing/DctorOperatorAlias.purs +++ b/examples/passing/DctorOperatorAlias.purs @@ -1,9 +1,9 @@ module Main where import Prelude (Unit, bind, discard, (==)) - import Control.Monad.Eff (Eff) - import Control.Monad.Eff.Console (CONSOLE, log) - import Test.Assert (ASSERT, assert') + import Effect (Effect) + import Effect.Console (log) + import Test.Assert (assert') import List (List(..), (:)) import List as L @@ -26,7 +26,7 @@ module Main where get3 _ (_ ! (x ! _)) = x get3 y _ = y - main ∷ Eff (assert ∷ ASSERT, console ∷ CONSOLE) Unit + main ∷ Effect Unit main = do assert' "Incorrect result!" (get1 0 (1 : 2 : 3 : Nil) == 2) assert' "Incorrect result!" (get2 0 (1 ! (2 ! (3 ! Nil))) == 2) diff --git a/examples/passing/DeepArrayBinder.purs b/examples/passing/DeepArrayBinder.purs index 399b2a4ab8..a5be9736f7 100644 --- a/examples/passing/DeepArrayBinder.purs +++ b/examples/passing/DeepArrayBinder.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console (log) +import Effect +import Effect.Console (log) import Test.Assert data List a = Cons a (List a) | Nil diff --git a/examples/passing/DeepCase.purs b/examples/passing/DeepCase.purs index e19f0e8d06..687993f1f5 100644 --- a/examples/passing/DeepCase.purs +++ b/examples/passing/DeepCase.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) f x y = let diff --git a/examples/passing/DeriveNewtype.purs b/examples/passing/DeriveNewtype.purs index 3f0648c1c7..e76df26638 100644 --- a/examples/passing/DeriveNewtype.purs +++ b/examples/passing/DeriveNewtype.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Data.Newtype diff --git a/examples/passing/DeriveWithNestedSynonyms.purs b/examples/passing/DeriveWithNestedSynonyms.purs index c23c8e3e51..56a7b45f3e 100644 --- a/examples/passing/DeriveWithNestedSynonyms.purs +++ b/examples/passing/DeriveWithNestedSynonyms.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) type L = {} data X = X L diff --git a/examples/passing/Deriving.purs b/examples/passing/Deriving.purs index 9630699928..576603d677 100644 --- a/examples/passing/Deriving.purs +++ b/examples/passing/Deriving.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Test.Assert data V diff --git a/examples/passing/DerivingFunctor.purs b/examples/passing/DerivingFunctor.purs index 18c4deed90..e931483df5 100644 --- a/examples/passing/DerivingFunctor.purs +++ b/examples/passing/DerivingFunctor.purs @@ -2,7 +2,7 @@ module Main where import Prelude import Data.Eq (class Eq1) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Test.Assert type MyRecord a = { myField :: a } diff --git a/examples/passing/Do.purs b/examples/passing/Do.purs index 0dd00c68d0..e8552acfb7 100644 --- a/examples/passing/Do.purs +++ b/examples/passing/Do.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Maybe a = Nothing | Just a diff --git a/examples/passing/Dollar.purs b/examples/passing/Dollar.purs index 3c0d4d44e6..18988357c2 100644 --- a/examples/passing/Dollar.purs +++ b/examples/passing/Dollar.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) applyFn :: forall a b. (a -> b) -> a -> b applyFn f x = f x diff --git a/examples/passing/DuplicateProperties.purs b/examples/passing/DuplicateProperties.purs index d91f6bd317..238a9f221b 100644 --- a/examples/passing/DuplicateProperties.purs +++ b/examples/passing/DuplicateProperties.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data RProxy (r :: # Type) = RProxy diff --git a/examples/passing/Eff.purs b/examples/passing/Eff.purs deleted file mode 100644 index 4c74c2522d..0000000000 --- a/examples/passing/Eff.purs +++ /dev/null @@ -1,26 +0,0 @@ -module Main where - -import Prelude -import Control.Monad.Eff -import Control.Monad.ST -import Control.Monad.Eff.Console (log, logShow) - -test1 = do - log "Line 1" - log "Line 2" - -test2 = runPure (runST (do - ref <- newSTRef 0.0 - _ <- modifySTRef ref $ \n -> n + 1.0 - readSTRef ref)) - -test3 = pureST (do - ref <- newSTRef 0.0 - _ <- modifySTRef ref $ \n -> n + 1.0 - readSTRef ref) - -main = do - test1 - logShow test2 - logShow test3 - log "Done" diff --git a/examples/passing/EffFn.purs b/examples/passing/EffFn.purs index b4f56d0805..5cf26d6d16 100644 --- a/examples/passing/EffFn.purs +++ b/examples/passing/EffFn.purs @@ -2,18 +2,18 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) -import Control.Monad.Eff.Uncurried (EffFn3, mkEffFn7, runEffFn3, runEffFn7) +import Effect.Console (log) +import Effect.Uncurried (EffectFn3, mkEffectFn7, runEffectFn3, runEffectFn7) import Test.Assert (assert) testBothWays = do - res <- (runEffFn7 $ mkEffFn7 \x1 x2 x3 x4 x5 x6 x7 -> pure 42) 1 2 3 4 5 6 7 + res <- (runEffectFn7 $ mkEffectFn7 \x1 x2 x3 x4 x5 x6 x7 -> pure 42) 1 2 3 4 5 6 7 assert $ res == 42 -foreign import add3 :: forall eff. EffFn3 eff String String String String +foreign import add3 :: EffectFn3 String String String String testRunFn = do - str <- runEffFn3 add3 "a" "b" "c" + str <- runEffectFn3 add3 "a" "b" "c" assert $ str == "abc" main = do diff --git a/examples/passing/EmptyDataDecls.purs b/examples/passing/EmptyDataDecls.purs index 6c143cde55..a52c6005c8 100644 --- a/examples/passing/EmptyDataDecls.purs +++ b/examples/passing/EmptyDataDecls.purs @@ -2,7 +2,7 @@ module Main where import Prelude import Test.Assert -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Z data S n diff --git a/examples/passing/EmptyRow.purs b/examples/passing/EmptyRow.purs index b6c0fc2916..ebbcca2007 100644 --- a/examples/passing/EmptyRow.purs +++ b/examples/passing/EmptyRow.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Foo r = Foo { | r } diff --git a/examples/passing/EmptyTypeClass.purs b/examples/passing/EmptyTypeClass.purs index 88180496c5..2bb5cbc4f3 100644 --- a/examples/passing/EmptyTypeClass.purs +++ b/examples/passing/EmptyTypeClass.purs @@ -1,11 +1,11 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console head :: forall a. Partial => Array a -> a head [x] = x -main :: Eff _ _ +main :: Effect _ main = log "Done" diff --git a/examples/passing/EntailsKindedType.purs b/examples/passing/EntailsKindedType.purs index 5d345b5553..00197beac4 100644 --- a/examples/passing/EntailsKindedType.purs +++ b/examples/passing/EntailsKindedType.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console test x = show (x :: _ :: Type) diff --git a/examples/passing/Eq1Deriving.purs b/examples/passing/Eq1Deriving.purs index 52ff900b8f..3cb98e3072 100644 --- a/examples/passing/Eq1Deriving.purs +++ b/examples/passing/Eq1Deriving.purs @@ -2,7 +2,7 @@ module Main where import Prelude import Data.Eq (class Eq1) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Product a b = Product a b diff --git a/examples/passing/Eq1InEqDeriving.purs b/examples/passing/Eq1InEqDeriving.purs index a916c87804..2a8d7314d6 100644 --- a/examples/passing/Eq1InEqDeriving.purs +++ b/examples/passing/Eq1InEqDeriving.purs @@ -2,7 +2,7 @@ module Main where import Prelude import Data.Eq (class Eq1) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) newtype Mu f = In (f (Mu f)) diff --git a/examples/passing/EqOrd.purs b/examples/passing/EqOrd.purs index 3d214a55be..5b0f2ba27c 100644 --- a/examples/passing/EqOrd.purs +++ b/examples/passing/EqOrd.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) data Pair a b = Pair a b diff --git a/examples/passing/ExplicitImportReExport.purs b/examples/passing/ExplicitImportReExport.purs index 3c01ca8712..cea31c23f5 100644 --- a/examples/passing/ExplicitImportReExport.purs +++ b/examples/passing/ExplicitImportReExport.purs @@ -2,7 +2,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Bar (foo) baz :: Int diff --git a/examples/passing/ExplicitOperatorSections.purs b/examples/passing/ExplicitOperatorSections.purs index 2f3f0bedc4..79f4fcf65e 100644 --- a/examples/passing/ExplicitOperatorSections.purs +++ b/examples/passing/ExplicitOperatorSections.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) subtractOne :: Int -> Int subtractOne = (_ - 1) diff --git a/examples/passing/ExportExplicit.purs b/examples/passing/ExportExplicit.purs index 8443d4fc59..97507a6cea 100644 --- a/examples/passing/ExportExplicit.purs +++ b/examples/passing/ExportExplicit.purs @@ -1,7 +1,7 @@ module Main where import M1 -import Control.Monad.Eff.Console (log) +import Effect.Console (log) testX = X testZ = Z diff --git a/examples/passing/ExportExplicit2.purs b/examples/passing/ExportExplicit2.purs index a8803e5a83..018c826233 100644 --- a/examples/passing/ExportExplicit2.purs +++ b/examples/passing/ExportExplicit2.purs @@ -1,7 +1,7 @@ module Main where import M1 -import Control.Monad.Eff.Console (log) +import Effect.Console (log) testBar = bar diff --git a/examples/passing/ExportedInstanceDeclarations.purs b/examples/passing/ExportedInstanceDeclarations.purs index 97cd196bf4..cddf87b0a5 100644 --- a/examples/passing/ExportedInstanceDeclarations.purs +++ b/examples/passing/ExportedInstanceDeclarations.purs @@ -8,7 +8,7 @@ module Main ) where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Const a b = Const a @@ -32,7 +32,7 @@ instance constFoo :: Foo (Const NonexportedType b) where else -- Case 2: constraints instance nonExportedFoo :: (Foo NonexportedType) => Foo (a -> a) where - foo = id + foo = identity else -- Another instance of case 2: instance nonExportedFoo2 :: (NonexportedClass a) => Foo a where diff --git a/examples/passing/ExtendedInfixOperators.purs b/examples/passing/ExtendedInfixOperators.purs index 5e12f6029f..68ff336167 100644 --- a/examples/passing/ExtendedInfixOperators.purs +++ b/examples/passing/ExtendedInfixOperators.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) import Data.Function (on) comparing :: forall a b. Ord b => (a -> b) -> a -> a -> Ordering diff --git a/examples/passing/Fib.purs b/examples/passing/Fib.purs index c9729c7ae2..71dc31da97 100644 --- a/examples/passing/Fib.purs +++ b/examples/passing/Fib.purs @@ -1,18 +1,20 @@ module Main where import Prelude -import Control.Monad.Eff (whileE) -import Control.Monad.Eff.Console (log, logShow) -import Control.Monad.ST (runST, newSTRef, readSTRef, writeSTRef) +import Effect.Console (log) +import Control.Monad.ST as ST +import Control.Monad.ST.Ref as STRef + +fib :: Number +fib = ST.run do + n1 <- STRef.new 1.0 + n2 <- STRef.new 1.0 + ST.while ((>) 1000.0 <$> STRef.read n1) do + n1' <- STRef.read n1 + n2' <- STRef.read n2 + _ <- STRef.write (n1' + n2') n2 + STRef.write n2' n1 + STRef.read n2 main = do - runST do - n1 <- newSTRef 1.0 - n2 <- newSTRef 1.0 - whileE ((>) 1000.0 <$> readSTRef n1) $ do - n1' <- readSTRef n1 - n2' <- readSTRef n2 - _ <- writeSTRef n2 $ n1' + n2' - _ <- writeSTRef n1 n2' - logShow n2' log "Done" diff --git a/examples/passing/FieldConsPuns.purs b/examples/passing/FieldConsPuns.purs index 1449ad8a8d..2a068df614 100644 --- a/examples/passing/FieldConsPuns.purs +++ b/examples/passing/FieldConsPuns.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) greet { greeting, name } = log $ greeting <> ", " <> name <> "." diff --git a/examples/passing/FieldPuns.purs b/examples/passing/FieldPuns.purs index 5bd00fcf73..43389e2c8f 100644 --- a/examples/passing/FieldPuns.purs +++ b/examples/passing/FieldPuns.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Effect.Console greet { greeting, name } = log $ greeting <> ", " <> name <> "." diff --git a/examples/passing/FinalTagless.purs b/examples/passing/FinalTagless.purs index b7cd4d8441..b60742703b 100644 --- a/examples/passing/FinalTagless.purs +++ b/examples/passing/FinalTagless.purs @@ -1,7 +1,7 @@ module Main where import Prelude hiding (add) -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) class E e where num :: Number -> e Number diff --git a/examples/passing/ForeignKind.purs b/examples/passing/ForeignKind.purs index 0b91f7d99c..c2d4421f2b 100644 --- a/examples/passing/ForeignKind.purs +++ b/examples/passing/ForeignKind.purs @@ -2,7 +2,7 @@ module Main where import Prelude import ForeignKinds.Lib (kind Nat, Zero, Succ, N3, NatProxy, class AddNat, addNat, proxy1, proxy2) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) proxy1Add2Is3 :: NatProxy N3 proxy1Add2Is3 = addNat proxy1 proxy2 diff --git a/examples/passing/FunWithFunDeps.purs b/examples/passing/FunWithFunDeps.purs index d69aa33ee4..9b9a99145d 100644 --- a/examples/passing/FunWithFunDeps.purs +++ b/examples/passing/FunWithFunDeps.purs @@ -2,7 +2,7 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) -- Nat : Type data Z diff --git a/examples/passing/FunctionScope.purs b/examples/passing/FunctionScope.purs index 3212d44e4a..d8594926f1 100644 --- a/examples/passing/FunctionScope.purs +++ b/examples/passing/FunctionScope.purs @@ -2,7 +2,7 @@ module Main where import Prelude import Test.Assert -import Control.Monad.Eff.Console (log) +import Effect.Console (log) mkValue :: Number -> Number mkValue id = id diff --git a/examples/passing/FunctionalDependencies.purs b/examples/passing/FunctionalDependencies.purs index cb8026e591..6cc64859c6 100644 --- a/examples/passing/FunctionalDependencies.purs +++ b/examples/passing/FunctionalDependencies.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Nil data Cons x xs diff --git a/examples/passing/Functions.purs b/examples/passing/Functions.purs index b6da679773..368a69f9c0 100644 --- a/examples/passing/Functions.purs +++ b/examples/passing/Functions.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) test1 = \_ -> 0.0 diff --git a/examples/passing/Functions2.purs b/examples/passing/Functions2.purs index 1a658ab0d2..1aede050e4 100644 --- a/examples/passing/Functions2.purs +++ b/examples/passing/Functions2.purs @@ -2,7 +2,7 @@ module Main where import Prelude import Test.Assert -import Control.Monad.Eff.Console (log) +import Effect.Console (log) test :: forall a b. a -> b -> a test = \const _ -> const diff --git a/examples/passing/Generalization1.purs b/examples/passing/Generalization1.purs index e16826829d..0ce76c4e51 100644 --- a/examples/passing/Generalization1.purs +++ b/examples/passing/Generalization1.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (logShow, log) +import Effect.Console (logShow, log) main = do logShow (sum 1.0 2.0) diff --git a/examples/passing/GenericsRep.purs b/examples/passing/GenericsRep.purs index 646e74d890..a7e974882a 100644 --- a/examples/passing/GenericsRep.purs +++ b/examples/passing/GenericsRep.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log, logShow) +import Effect (Effect) +import Effect.Console (log, logShow) import Data.Generic.Rep (class Generic) import Data.Generic.Rep.Eq (genericEq) @@ -33,7 +33,7 @@ newtype W = W { x :: Int, y :: MyString } derive instance genericW :: Generic W _ -main :: Eff (console :: CONSOLE) Unit +main :: Effect Unit main = do logShow (X 0 == X 1) logShow (X 1 == X 1) diff --git a/examples/passing/Guards.purs b/examples/passing/Guards.purs index 6f86d590c2..2894d2e9c8 100644 --- a/examples/passing/Guards.purs +++ b/examples/passing/Guards.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) collatz = \x -> case x of y | y `mod` 2.0 == 0.0 -> y / 2.0 diff --git a/examples/passing/HasOwnProperty.purs b/examples/passing/HasOwnProperty.purs index 6a70fb73ec..f4630f7033 100644 --- a/examples/passing/HasOwnProperty.purs +++ b/examples/passing/HasOwnProperty.purs @@ -1,5 +1,5 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) main = log ({hasOwnProperty: "Hi"} {hasOwnProperty = "Done"}).hasOwnProperty diff --git a/examples/passing/HoistError.purs b/examples/passing/HoistError.purs index 5128a754b2..be8a8a874c 100644 --- a/examples/passing/HoistError.purs +++ b/examples/passing/HoistError.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console import Test.Assert main = do diff --git a/examples/passing/IfThenElseMaybe.purs b/examples/passing/IfThenElseMaybe.purs index 80c83ccee4..320c3036b2 100644 --- a/examples/passing/IfThenElseMaybe.purs +++ b/examples/passing/IfThenElseMaybe.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Maybe a = Nothing | Just a diff --git a/examples/passing/IfWildcard.purs b/examples/passing/IfWildcard.purs index dd7d1546f2..243d7fbf89 100644 --- a/examples/passing/IfWildcard.purs +++ b/examples/passing/IfWildcard.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (log, CONSOLE) +import Effect (Effect) +import Effect.Console (log) data Foo = X | Y @@ -12,7 +12,7 @@ cond = if _ then _ else _ what ∷ Boolean → Foo what = if _ then X else Y -main :: forall e. Eff (console :: CONSOLE | e) Unit +main :: Effect Unit main = do let tmp1 = what true tmp2 = cond true 0 1 diff --git a/examples/passing/ImplicitEmptyImport.purs b/examples/passing/ImplicitEmptyImport.purs index 6265490277..a0b0d394ca 100644 --- a/examples/passing/ImplicitEmptyImport.purs +++ b/examples/passing/ImplicitEmptyImport.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) main = do log "Hello" diff --git a/examples/passing/Import.purs b/examples/passing/Import.purs index 75c2d147fa..b823ab2040 100644 --- a/examples/passing/Import.purs +++ b/examples/passing/Import.purs @@ -1,6 +1,6 @@ module Main where import M2 -import Control.Monad.Eff.Console (log) +import Effect.Console (log) main = log "Done" diff --git a/examples/passing/ImportExplicit.purs b/examples/passing/ImportExplicit.purs index 92d5ee6de0..0183f00052 100644 --- a/examples/passing/ImportExplicit.purs +++ b/examples/passing/ImportExplicit.purs @@ -1,7 +1,7 @@ module Main where import M1 (X(..)) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) testX :: X testX = X diff --git a/examples/passing/ImportHiding.purs b/examples/passing/ImportHiding.purs index 8808ea358c..2c355ac617 100644 --- a/examples/passing/ImportHiding.purs +++ b/examples/passing/ImportHiding.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console +import Effect.Console import Prelude hiding ( show, -- a value class Show, -- a type class diff --git a/examples/passing/ImportQualified.purs b/examples/passing/ImportQualified.purs index 303f6e1055..c23018c96f 100644 --- a/examples/passing/ImportQualified.purs +++ b/examples/passing/ImportQualified.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff +import Effect import M1 -import Control.Monad.Eff.Console as C +import Effect.Console as C main = C.log (log "Done") diff --git a/examples/passing/InferRecFunWithConstrainedArgument.purs b/examples/passing/InferRecFunWithConstrainedArgument.purs index cd78e9b3c9..a06f573817 100644 --- a/examples/passing/InferRecFunWithConstrainedArgument.purs +++ b/examples/passing/InferRecFunWithConstrainedArgument.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) test 100 = 100 test n = test(1 + n) diff --git a/examples/passing/InstanceBeforeClass.purs b/examples/passing/InstanceBeforeClass.purs index d187655b29..76279f9942 100644 --- a/examples/passing/InstanceBeforeClass.purs +++ b/examples/passing/InstanceBeforeClass.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) instance fooNumber :: Foo Number where foo = 0.0 diff --git a/examples/passing/InstanceChain.purs b/examples/passing/InstanceChain.purs index a5a1fafa52..7039afb1cb 100644 --- a/examples/passing/InstanceChain.purs +++ b/examples/passing/InstanceChain.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class Arg i o | i -> o diff --git a/examples/passing/InstanceSigs.purs b/examples/passing/InstanceSigs.purs index b3975a20e8..c98f4372b9 100644 --- a/examples/passing/InstanceSigs.purs +++ b/examples/passing/InstanceSigs.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class Foo a where foo :: a diff --git a/examples/passing/InstanceSigsGeneral.purs b/examples/passing/InstanceSigsGeneral.purs index 05901ad984..3a324a5426 100644 --- a/examples/passing/InstanceSigsGeneral.purs +++ b/examples/passing/InstanceSigsGeneral.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class Eq a where eq :: a -> a -> Boolean diff --git a/examples/passing/IntAndChar.purs b/examples/passing/IntAndChar.purs index 366cfcdc63..476764dbb7 100644 --- a/examples/passing/IntAndChar.purs +++ b/examples/passing/IntAndChar.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console (log) +import Effect +import Effect.Console (log) import Test.Assert f 1 = 1 diff --git a/examples/passing/JSReserved.purs b/examples/passing/JSReserved.purs index 26bde69568..bb9e9c22a2 100644 --- a/examples/passing/JSReserved.purs +++ b/examples/passing/JSReserved.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) yield = 0 member = 1 diff --git a/examples/passing/KindedType.purs b/examples/passing/KindedType.purs index 3abe5128a8..13b9817bf8 100644 --- a/examples/passing/KindedType.purs +++ b/examples/passing/KindedType.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) type Star2Star f = f :: Type -> Type diff --git a/examples/passing/LargeSumType.purs b/examples/passing/LargeSumType.purs index d833e8a881..9d83a73cf9 100644 --- a/examples/passing/LargeSumType.purs +++ b/examples/passing/LargeSumType.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Large = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z diff --git a/examples/passing/Let.purs b/examples/passing/Let.purs index 793dac0e17..03cd3cf622 100644 --- a/examples/passing/Let.purs +++ b/examples/passing/Let.purs @@ -2,8 +2,8 @@ module Main where import Prelude import Partial.Unsafe (unsafePartial) -import Control.Monad.Eff -import Control.Monad.Eff.Console (log, logShow) +import Effect +import Effect.Console (log, logShow) import Control.Monad.ST test1 x = let @@ -46,7 +46,7 @@ test10 _ = g x = f x / 2.0 in f 10.0 -main :: Eff _ _ +main :: Effect _ main = do logShow (test1 1.0) logShow (test2 1.0 2.0) diff --git a/examples/passing/Let2.purs b/examples/passing/Let2.purs index 51fc2516a0..37e96aca57 100644 --- a/examples/passing/Let2.purs +++ b/examples/passing/Let2.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) test = let f :: Number -> Boolean diff --git a/examples/passing/LetInInstance.purs b/examples/passing/LetInInstance.purs index 991548528c..0688893e8f 100644 --- a/examples/passing/LetInInstance.purs +++ b/examples/passing/LetInInstance.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class Foo a where foo :: a -> String diff --git a/examples/passing/LetPattern.purs b/examples/passing/LetPattern.purs index e8231208d8..799e22f54d 100644 --- a/examples/passing/LetPattern.purs +++ b/examples/passing/LetPattern.purs @@ -2,9 +2,9 @@ module Main where import Prelude import Partial.Unsafe (unsafePartial) -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log) -import Test.Assert (ASSERT, assert') +import Effect (Effect) +import Effect.Console (log) +import Test.Assert (assert') patternSimple :: Boolean patternSimple = @@ -12,7 +12,7 @@ patternSimple = in x == 25252 -patternDoSimple :: forall e. Eff e Boolean +patternDoSimple :: Effect Boolean patternDoSimple = do let x = 25252 pure $ x == 25252 @@ -25,7 +25,7 @@ patternNewtype = in a == 123 -patternDoNewtype :: forall e. Eff e Boolean +patternDoNewtype :: Effect Boolean patternDoNewtype = do let X a = X 123 pure $ a == 123 @@ -44,12 +44,12 @@ patternDataIgnored = in x == "world, hello" -patternDoData :: forall e. Eff e Boolean +patternDoData :: Effect Boolean patternDoData = do let Y a b c = Y 456 "hello, world" false pure $ a == 456 && b == "hello, world" && not c -patternDoDataIgnored :: forall e. Eff e Boolean +patternDoDataIgnored :: Effect Boolean patternDoDataIgnored = do let Y _ x _ = Y 789 "world, hello" true pure $ x == "world, hello" @@ -60,7 +60,7 @@ patternArray = unsafePartial $ in a == 1 && b == 2 -patternDoArray :: forall e. Eff e Boolean +patternDoArray :: Effect Boolean patternDoArray = unsafePartial do let [a, b] = [1, 2] pure $ a == 1 && b == 2 @@ -77,7 +77,7 @@ patternMultiple = unsafePartial $ x == 25252 && a == 25252 && b == 25252 && c == "hello, world" && not d && e == "world, hello" && f == 1 && g == 2 -patternDoMultiple :: forall e. Eff e Boolean +patternDoMultiple :: Effect Boolean patternDoMultiple = unsafePartial do let x = 25252 @@ -99,7 +99,7 @@ patternMultipleWithNormal = unsafePartial $ x == 25252 && y == 2525 && a == 25252 && b == 2525 && c == "hello, world" && not d -patternDoMultipleWithNormal :: forall e. Eff e Boolean +patternDoMultipleWithNormal :: Effect Boolean patternDoMultipleWithNormal = unsafePartial do let x = 25252 @@ -121,7 +121,7 @@ patternWithParens = unsafePartial $ x == 25252 && a == 25252 && b == 25252 && c == "hello, world" && not d && e == "world, hello" && f == 1 && g == 2 -patternDoWithParens :: forall e. Eff e Boolean +patternDoWithParens :: Effect Boolean patternDoWithParens = unsafePartial do let (x) = 25252 @@ -139,7 +139,7 @@ patternWithNamedBinder = unsafePartial $ in a.x == 10 && x == 10 && a.y == 20 && y == 20 -patternDoWithNamedBinder :: forall e. Eff e Boolean +patternDoWithNamedBinder :: Effect Boolean patternDoWithNamedBinder = unsafePartial do let a@{x, y} = {x: 10, y: 20} @@ -164,14 +164,14 @@ patternWithInfixOp = unsafePartial $ in x == 1 && xs == 2 : 3 : 4 : Nil -patternDoWithInfixOp :: forall e. Eff e Boolean +patternDoWithInfixOp :: Effect Boolean patternDoWithInfixOp = unsafePartial do let x : xs = 1 : 2 : 3 : 4 : Nil pure $ x == 1 && xs == 2 : 3 : 4 : Nil -main :: Eff (assert :: ASSERT, console :: CONSOLE) Unit +main :: Effect Unit main = do assert' "simple variable pattern" patternSimple assert' "simple variable pattern with do" =<< patternDoSimple diff --git a/examples/passing/LiberalTypeSynonyms.purs b/examples/passing/LiberalTypeSynonyms.purs index b388af69e1..1f6c3d1cd8 100644 --- a/examples/passing/LiberalTypeSynonyms.purs +++ b/examples/passing/LiberalTypeSynonyms.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) type Reader = (->) String diff --git a/examples/passing/MPTCs.purs b/examples/passing/MPTCs.purs index d7587738bd..6de6002aee 100644 --- a/examples/passing/MPTCs.purs +++ b/examples/passing/MPTCs.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class NullaryTypeClass where greeting :: String diff --git a/examples/passing/Match.purs b/examples/passing/Match.purs index 50244bb8da..60a264d195 100644 --- a/examples/passing/Match.purs +++ b/examples/passing/Match.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Foo a = Foo diff --git a/examples/passing/Module.purs b/examples/passing/Module.purs index e8d5f06bc1..d8f55019bc 100644 --- a/examples/passing/Module.purs +++ b/examples/passing/Module.purs @@ -2,6 +2,6 @@ module Main where import M1 import M2 -import Control.Monad.Eff.Console (log) +import Effect.Console (log) main = log "Done" diff --git a/examples/passing/ModuleDeps.purs b/examples/passing/ModuleDeps.purs index 5736a97c98..436831809b 100644 --- a/examples/passing/ModuleDeps.purs +++ b/examples/passing/ModuleDeps.purs @@ -1,6 +1,6 @@ module Main where import M1 -import Control.Monad.Eff.Console (log) +import Effect.Console (log) main = log "Done" diff --git a/examples/passing/ModuleExport.purs b/examples/passing/ModuleExport.purs index 0ce2e51bbf..9a04dbe257 100644 --- a/examples/passing/ModuleExport.purs +++ b/examples/passing/ModuleExport.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) import A main = do diff --git a/examples/passing/ModuleExportDupes.purs b/examples/passing/ModuleExportDupes.purs index 6a354a7411..4cf1a72dcc 100644 --- a/examples/passing/ModuleExportDupes.purs +++ b/examples/passing/ModuleExportDupes.purs @@ -1,6 +1,6 @@ module Main where - import Control.Monad.Eff.Console + import Effect.Console import A import B import C diff --git a/examples/passing/ModuleExportExcluded.purs b/examples/passing/ModuleExportExcluded.purs index c5b425dbdd..99c97fa57d 100644 --- a/examples/passing/ModuleExportExcluded.purs +++ b/examples/passing/ModuleExportExcluded.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) import A (foo) otherwise = false diff --git a/examples/passing/ModuleExportQualified.purs b/examples/passing/ModuleExportQualified.purs index a8e8c6e5d0..5d0e289f8c 100644 --- a/examples/passing/ModuleExportQualified.purs +++ b/examples/passing/ModuleExportQualified.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) import A as B main = do diff --git a/examples/passing/ModuleExportSelf.purs b/examples/passing/ModuleExportSelf.purs index 5063d2bb04..edcd9f4363 100644 --- a/examples/passing/ModuleExportSelf.purs +++ b/examples/passing/ModuleExportSelf.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console +import Effect.Console import A bar :: Foo diff --git a/examples/passing/Monad.purs b/examples/passing/Monad.purs index a1f5120124..8bf3c33b0e 100644 --- a/examples/passing/Monad.purs +++ b/examples/passing/Monad.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) type Monad m = { return :: forall a. a -> m a , bind :: forall a b. m a -> (a -> m b) -> m b } diff --git a/examples/passing/MonadState.purs b/examples/passing/MonadState.purs index 46b2aaa13e..7073014c69 100644 --- a/examples/passing/MonadState.purs +++ b/examples/passing/MonadState.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Effect.Console data Tuple a b = Tuple a b @@ -56,7 +56,7 @@ modify f = put (same f s) where same :: forall a. (a -> a) -> (a -> a) - same = id + same = identity main = do logShow $ runState 0 (modify (_ + 1)) diff --git a/examples/passing/MultiArgFunctions.purs b/examples/passing/MultiArgFunctions.purs index ed9239224b..80aa0bdff3 100644 --- a/examples/passing/MultiArgFunctions.purs +++ b/examples/passing/MultiArgFunctions.purs @@ -2,8 +2,8 @@ module Main where import Prelude import Data.Function.Uncurried -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console f = mkFn2 $ \a b -> runFn2 g a b + runFn2 g b a diff --git a/examples/passing/MutRec.purs b/examples/passing/MutRec.purs index c800b4c8a9..d2f2c56bab 100644 --- a/examples/passing/MutRec.purs +++ b/examples/passing/MutRec.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) f 0.0 = 0.0 f x = g x + 0.0 diff --git a/examples/passing/MutRec2.purs b/examples/passing/MutRec2.purs index bac123773d..f20afaf0d6 100644 --- a/examples/passing/MutRec2.purs +++ b/examples/passing/MutRec2.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data A = A B diff --git a/examples/passing/MutRec3.purs b/examples/passing/MutRec3.purs index ac22c69aca..98f7768cad 100644 --- a/examples/passing/MutRec3.purs +++ b/examples/passing/MutRec3.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data A = A B diff --git a/examples/passing/NakedConstraint.purs b/examples/passing/NakedConstraint.purs index 8ec2099a7c..fe266edecf 100644 --- a/examples/passing/NakedConstraint.purs +++ b/examples/passing/NakedConstraint.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console +import Effect.Console data List a = Nil | Cons a (List a) diff --git a/examples/passing/NamedPatterns.purs b/examples/passing/NamedPatterns.purs index d6f43778a1..37764daa0e 100644 --- a/examples/passing/NamedPatterns.purs +++ b/examples/passing/NamedPatterns.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) foo = \x -> case x of y@{ foo: "Foo" } -> y diff --git a/examples/passing/NegativeBinder.purs b/examples/passing/NegativeBinder.purs index 1c73e705a6..2d4e36b52a 100644 --- a/examples/passing/NegativeBinder.purs +++ b/examples/passing/NegativeBinder.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) test :: Number -> Boolean test -1.0 = false diff --git a/examples/passing/NegativeIntInRange.purs b/examples/passing/NegativeIntInRange.purs index 57a60d08ff..37403db0b0 100644 --- a/examples/passing/NegativeIntInRange.purs +++ b/examples/passing/NegativeIntInRange.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) n :: Int n = -2147483648 diff --git a/examples/passing/Nested.purs b/examples/passing/Nested.purs index b29554ab2b..f7d97e0a0c 100644 --- a/examples/passing/Nested.purs +++ b/examples/passing/Nested.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Extend r a = Extend { prev :: r a, next :: a } diff --git a/examples/passing/NestedRecordUpdate.purs b/examples/passing/NestedRecordUpdate.purs index 60eef8f557..497c25dec5 100644 --- a/examples/passing/NestedRecordUpdate.purs +++ b/examples/passing/NestedRecordUpdate.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Effect.Console type T = { foo :: Int, bar :: { baz :: Int, qux :: { lhs :: Int, rhs :: Int } } } diff --git a/examples/passing/NestedRecordUpdateWildcards.purs b/examples/passing/NestedRecordUpdateWildcards.purs index 7c99276018..ce9d90c8bc 100644 --- a/examples/passing/NestedRecordUpdateWildcards.purs +++ b/examples/passing/NestedRecordUpdateWildcards.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Effect.Console update = _ { foo = _, bar { baz = _, qux = _ } } diff --git a/examples/passing/NestedTypeSynonyms.purs b/examples/passing/NestedTypeSynonyms.purs index 3ae9327d7a..fa8ec24f62 100644 --- a/examples/passing/NestedTypeSynonyms.purs +++ b/examples/passing/NestedTypeSynonyms.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) type X = String type Y = X -> X diff --git a/examples/passing/NestedWhere.purs b/examples/passing/NestedWhere.purs index 3f098a567e..496d253242 100644 --- a/examples/passing/NestedWhere.purs +++ b/examples/passing/NestedWhere.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) f x = g x where diff --git a/examples/passing/NewConsClass.purs b/examples/passing/NewConsClass.purs index 384d8c0b62..6afc954aeb 100644 --- a/examples/passing/NewConsClass.purs +++ b/examples/passing/NewConsClass.purs @@ -2,7 +2,7 @@ -- in the presence of the `Cons` class from `Prim.Row`. module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Prim.Row(class Union) class Cons x xs | xs -> x where diff --git a/examples/passing/Newtype.purs b/examples/passing/Newtype.purs index 43016b2568..645fb205f6 100644 --- a/examples/passing/Newtype.purs +++ b/examples/passing/Newtype.purs @@ -1,8 +1,8 @@ module Main where import Prelude hiding (apply) -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console newtype Thing = Thing String diff --git a/examples/passing/NewtypeClass.purs b/examples/passing/NewtypeClass.purs index 0e7c8a8494..47ce815d7b 100644 --- a/examples/passing/NewtypeClass.purs +++ b/examples/passing/NewtypeClass.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console class Newtype t a | t -> a where wrap :: a -> t diff --git a/examples/passing/NewtypeEff.purs b/examples/passing/NewtypeEff.purs index ad9fdbf721..666adbea12 100644 --- a/examples/passing/NewtypeEff.purs +++ b/examples/passing/NewtypeEff.purs @@ -1,12 +1,12 @@ module Main where import Prelude -import Control.Monad.Eff.Console -import Control.Monad.Eff +import Effect.Console +import Effect -newtype T a = T (Eff (console :: CONSOLE) a) +newtype T a = T (Effect a) -runT :: forall a. T a -> Eff (console :: CONSOLE) a +runT :: forall a. T a -> Effect a runT (T t) = t instance functorT :: Functor T where diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs index 1e01f710f9..62794c14b0 100644 --- a/examples/passing/NewtypeInstance.purs +++ b/examples/passing/NewtypeInstance.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console import Data.Monoid import Data.Tuple diff --git a/examples/passing/NewtypeWithRecordUpdate.purs b/examples/passing/NewtypeWithRecordUpdate.purs index 83bb139b15..ac63c40ce8 100644 --- a/examples/passing/NewtypeWithRecordUpdate.purs +++ b/examples/passing/NewtypeWithRecordUpdate.purs @@ -3,7 +3,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Effect.Console newtype NewType a = NewType (Record a) diff --git a/examples/passing/NonConflictingExports.purs b/examples/passing/NonConflictingExports.purs index 157d996ad2..c0b0cfb43f 100644 --- a/examples/passing/NonConflictingExports.purs +++ b/examples/passing/NonConflictingExports.purs @@ -2,7 +2,7 @@ module Main (thing, main) where import A -import Control.Monad.Eff.Console (log) +import Effect.Console (log) thing :: Int thing = 2 diff --git a/examples/passing/NonOrphanInstanceFunDepExtra.purs b/examples/passing/NonOrphanInstanceFunDepExtra.purs index eb86ead53a..b94e07be95 100644 --- a/examples/passing/NonOrphanInstanceFunDepExtra.purs +++ b/examples/passing/NonOrphanInstanceFunDepExtra.purs @@ -1,6 +1,6 @@ -- Both f and l must be known, thus can be in separate modules module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Lib data F data R diff --git a/examples/passing/NonOrphanInstanceMulti.purs b/examples/passing/NonOrphanInstanceMulti.purs index 71d5634d75..4a8821824a 100644 --- a/examples/passing/NonOrphanInstanceMulti.purs +++ b/examples/passing/NonOrphanInstanceMulti.purs @@ -1,6 +1,6 @@ -- Both l and r must be known, thus can be in separate modules module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Lib data L instance clr :: C L R diff --git a/examples/passing/NumberLiterals.purs b/examples/passing/NumberLiterals.purs index b8271790dd..8d2ac16eee 100644 --- a/examples/passing/NumberLiterals.purs +++ b/examples/passing/NumberLiterals.purs @@ -4,7 +4,7 @@ module Main where import Prelude import Test.Assert (assert') -import Control.Monad.Eff.Console (log) +import Effect.Console (log) main = do test "0.17" 0.17 diff --git a/examples/passing/ObjectGetter.purs b/examples/passing/ObjectGetter.purs index d2a50c7f75..901a4493ed 100644 --- a/examples/passing/ObjectGetter.purs +++ b/examples/passing/ObjectGetter.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) getX = _.x diff --git a/examples/passing/ObjectSynonym.purs b/examples/passing/ObjectSynonym.purs index 3b82ebfaab..9118c735ff 100644 --- a/examples/passing/ObjectSynonym.purs +++ b/examples/passing/ObjectSynonym.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) type Inner = Number diff --git a/examples/passing/ObjectUpdate.purs b/examples/passing/ObjectUpdate.purs index f17f6589ff..bb4bfa7783 100644 --- a/examples/passing/ObjectUpdate.purs +++ b/examples/passing/ObjectUpdate.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) update1 = \o -> o { foo = "Foo" } diff --git a/examples/passing/ObjectUpdate2.purs b/examples/passing/ObjectUpdate2.purs index 6d10409317..394cfeca63 100644 --- a/examples/passing/ObjectUpdate2.purs +++ b/examples/passing/ObjectUpdate2.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) type X r = { | r } diff --git a/examples/passing/ObjectUpdater.purs b/examples/passing/ObjectUpdater.purs index a09c42c56f..90213878a0 100644 --- a/examples/passing/ObjectUpdater.purs +++ b/examples/passing/ObjectUpdater.purs @@ -1,11 +1,11 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console import Test.Assert -getValue :: forall e. Eff (| e) Boolean +getValue :: Effect Boolean getValue = pure true main = do diff --git a/examples/passing/ObjectWildcards.purs b/examples/passing/ObjectWildcards.purs index aae90adc1d..1789d83b15 100644 --- a/examples/passing/ObjectWildcards.purs +++ b/examples/passing/ObjectWildcards.purs @@ -1,13 +1,13 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console import Test.Assert mkRecord = { foo: _, bar: _, baz: "baz" } -getValue :: forall e. Eff (| e) Boolean +getValue :: Effect Boolean getValue = pure true main = do diff --git a/examples/passing/Objects.purs b/examples/passing/Objects.purs index f320372aef..b319a13ac0 100644 --- a/examples/passing/Objects.purs +++ b/examples/passing/Objects.purs @@ -1,7 +1,7 @@ module Main where import Prelude hiding (append) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) test = \x -> x.foo + x.bar + 1.0 diff --git a/examples/passing/OneConstructor.purs b/examples/passing/OneConstructor.purs index 8f3fcf299f..ad8bc14824 100644 --- a/examples/passing/OneConstructor.purs +++ b/examples/passing/OneConstructor.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data One a = One a diff --git a/examples/passing/OperatorAlias.purs b/examples/passing/OperatorAlias.purs index d3615deb47..a5b7c6e3ad 100644 --- a/examples/passing/OperatorAlias.purs +++ b/examples/passing/OperatorAlias.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Effect.Console infixl 4 what as ?! diff --git a/examples/passing/OperatorAliasElsewhere.purs b/examples/passing/OperatorAliasElsewhere.purs index 34d294a5bc..8b1d063173 100644 --- a/examples/passing/OperatorAliasElsewhere.purs +++ b/examples/passing/OperatorAliasElsewhere.purs @@ -2,7 +2,7 @@ module Main where import Prelude import Def (what) -import Control.Monad.Eff.Console +import Effect.Console infixl 4 what as ?! diff --git a/examples/passing/OperatorAssociativity.purs b/examples/passing/OperatorAssociativity.purs index 137fb4d646..bdeca47301 100644 --- a/examples/passing/OperatorAssociativity.purs +++ b/examples/passing/OperatorAssociativity.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console import Test.Assert bug :: Number -> Number -> Number diff --git a/examples/passing/OperatorInlining.purs b/examples/passing/OperatorInlining.purs index d632cb1087..7f9b51a53f 100644 --- a/examples/passing/OperatorInlining.purs +++ b/examples/passing/OperatorInlining.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (logShow, log) +import Effect.Console (logShow, log) main = do diff --git a/examples/passing/OperatorSections.purs b/examples/passing/OperatorSections.purs index 8b032c5376..00538142eb 100644 --- a/examples/passing/OperatorSections.purs +++ b/examples/passing/OperatorSections.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Test.Assert main = do diff --git a/examples/passing/Operators.purs b/examples/passing/Operators.purs index aa6f24f558..bcb3c11305 100644 --- a/examples/passing/Operators.purs +++ b/examples/passing/Operators.purs @@ -3,8 +3,8 @@ module Main where import Prelude import Other (foo) import Other as Other -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console op1 :: forall a. a -> a -> a op1 x _ = x diff --git a/examples/passing/OptimizerBug.purs b/examples/passing/OptimizerBug.purs index 0e4c0f9d81..f870642457 100644 --- a/examples/passing/OptimizerBug.purs +++ b/examples/passing/OptimizerBug.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) x a = 1.0 + y a diff --git a/examples/passing/OptionalQualified.purs b/examples/passing/OptionalQualified.purs index 76c5bea4e3..2159fdacc1 100644 --- a/examples/passing/OptionalQualified.purs +++ b/examples/passing/OptionalQualified.purs @@ -3,7 +3,7 @@ module Main where import Prelude as P -- qualified import without the "qualified" keyword -import Control.Monad.Eff.Console as Console +import Effect.Console as Console bind = P.bind diff --git a/examples/passing/Ord1Deriving.purs b/examples/passing/Ord1Deriving.purs index 88a6394c2b..6f0561672e 100644 --- a/examples/passing/Ord1Deriving.purs +++ b/examples/passing/Ord1Deriving.purs @@ -3,7 +3,7 @@ module Main where import Prelude import Data.Eq (class Eq1) import Data.Ord (class Ord1) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Product a b = Product a b diff --git a/examples/passing/Ord1InOrdDeriving.purs b/examples/passing/Ord1InOrdDeriving.purs index 00ae1ca997..5de2ab6fac 100644 --- a/examples/passing/Ord1InOrdDeriving.purs +++ b/examples/passing/Ord1InOrdDeriving.purs @@ -3,7 +3,7 @@ module Main where import Prelude import Data.Eq (class Eq1) import Data.Ord (class Ord1) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) newtype Mu f = In (f (Mu f)) diff --git a/examples/passing/ParensInType.purs b/examples/passing/ParensInType.purs index 75d0120996..6ccd8bebd2 100644 --- a/examples/passing/ParensInType.purs +++ b/examples/passing/ParensInType.purs @@ -1,20 +1,14 @@ module Main where import Prelude -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log) +import Effect (Effect) +import Effect.Console (log) class Foo a where - foo :: forall eff. (String -> a (( console :: CONSOLE | eff)) ((Unit))) + foo :: (String -> a ((Unit))) -instance fooLogEff :: Foo Eff where +instance fooLogEff :: Foo Effect where foo = log -main :: - forall eff. - Eff - ( console :: CONSOLE - | eff - ) - Unit +main :: Effect Unit main = foo "Done" diff --git a/examples/passing/ParensInTypedBinder.purs b/examples/passing/ParensInTypedBinder.purs index 468f3ecc19..43573f118f 100644 --- a/examples/passing/ParensInTypedBinder.purs +++ b/examples/passing/ParensInTypedBinder.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log) +import Effect (Effect) +import Effect.Console (log) foo :: Array Int foo = do @@ -10,11 +10,5 @@ foo = do xs :: Array Int <- xss xs -main :: - forall eff. - Eff - ( console :: CONSOLE - | eff - ) - Unit +main :: Effect Unit main = log "Done" diff --git a/examples/passing/PartialFunction.purs b/examples/passing/PartialFunction.purs index 00a1f026de..5eac37835b 100644 --- a/examples/passing/PartialFunction.purs +++ b/examples/passing/PartialFunction.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console fn :: Partial => Number -> Number fn 0.0 = 0.0 diff --git a/examples/passing/Patterns.purs b/examples/passing/Patterns.purs index b715ec9ccf..91289794cf 100644 --- a/examples/passing/Patterns.purs +++ b/examples/passing/Patterns.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) test = \x -> case x of { str: "Foo", bool: true } -> true diff --git a/examples/passing/PendingConflictingImports.purs b/examples/passing/PendingConflictingImports.purs index 87c1ad8372..d43063c3b5 100644 --- a/examples/passing/PendingConflictingImports.purs +++ b/examples/passing/PendingConflictingImports.purs @@ -3,6 +3,6 @@ module Main where -- No error as we never force `thing` to be resolved in `Main` import A import B -import Control.Monad.Eff.Console (log) +import Effect.Console (log) main = log "Done" diff --git a/examples/passing/PendingConflictingImports2.purs b/examples/passing/PendingConflictingImports2.purs index 0041adc30a..c3fd2c750a 100644 --- a/examples/passing/PendingConflictingImports2.purs +++ b/examples/passing/PendingConflictingImports2.purs @@ -1,7 +1,7 @@ module Main where import A -import Control.Monad.Eff.Console (log) +import Effect.Console (log) -- No error as we never force `thing` to be resolved in `Main` thing :: Int diff --git a/examples/passing/Person.purs b/examples/passing/Person.purs index fd0e4f9806..edee6a13ee 100644 --- a/examples/passing/Person.purs +++ b/examples/passing/Person.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Person = Person { name :: String, age :: Number } diff --git a/examples/passing/PolyLabels.purs b/examples/passing/PolyLabels.purs index 259f387127..15caed8e8d 100644 --- a/examples/passing/PolyLabels.purs +++ b/examples/passing/PolyLabels.purs @@ -2,8 +2,8 @@ module Main where import Prelude import Prim.Row -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) foreign import unsafeGet @@ -60,7 +60,7 @@ setFoo = set (SProxy :: SProxy "foo") fooLens :: forall f a b r. Functor f => (a -> f b) -> { foo :: a | r } -> f { foo :: b | r } fooLens = lens (SProxy :: SProxy "foo") -main :: Eff (console :: CONSOLE) Unit +main :: Effect Unit main = do _ <- fooLens logShow { foo: 1 } log (getFoo (setFoo "Done" { foo: 1 })) diff --git a/examples/passing/PrimedTypeName.purs b/examples/passing/PrimedTypeName.purs index 7b59c0be1a..9e7e4cbc47 100644 --- a/examples/passing/PrimedTypeName.purs +++ b/examples/passing/PrimedTypeName.purs @@ -1,7 +1,7 @@ module Main (T, T', T'', T''', main) where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data T a = T type T' = T Unit diff --git a/examples/passing/QualifiedNames.purs b/examples/passing/QualifiedNames.purs index 0dcda36824..f6a20ec02f 100644 --- a/examples/passing/QualifiedNames.purs +++ b/examples/passing/QualifiedNames.purs @@ -2,10 +2,10 @@ module Main where import Prelude import Either as Either -import Control.Monad.Eff.Console (log) +import Effect.Console (log) either :: forall a b c. (a -> c) -> (b -> c) -> Either.Either a b -> c either f _ (Either.Left x) = f x either _ g (Either.Right y) = g y -main = log (either id id (Either.Left "Done")) +main = log (either identity identity (Either.Left "Done")) diff --git a/examples/passing/QualifiedQualifiedImports.purs b/examples/passing/QualifiedQualifiedImports.purs index 384bb7ee97..83e071d954 100644 --- a/examples/passing/QualifiedQualifiedImports.purs +++ b/examples/passing/QualifiedQualifiedImports.purs @@ -1,6 +1,6 @@ module Main where -- qualified import with qualified imported names -import Control.Monad.Eff.Console (log) as Console +import Effect.Console (log) as Console main = Console.log "Done" diff --git a/examples/passing/Rank2Data.purs b/examples/passing/Rank2Data.purs index 8833a43502..d1b7331036 100644 --- a/examples/passing/Rank2Data.purs +++ b/examples/passing/Rank2Data.purs @@ -1,7 +1,7 @@ module Main where import Prelude hiding (add) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Id = Id forall a. a -> a diff --git a/examples/passing/Rank2Object.purs b/examples/passing/Rank2Object.purs index 2460b4fb79..717115505d 100644 --- a/examples/passing/Rank2Object.purs +++ b/examples/passing/Rank2Object.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console +import Effect.Console data Foo = Foo { id :: forall a. a -> a } diff --git a/examples/passing/Rank2TypeSynonym.purs b/examples/passing/Rank2TypeSynonym.purs index 3db194d5af..13245c9ff4 100644 --- a/examples/passing/Rank2TypeSynonym.purs +++ b/examples/passing/Rank2TypeSynonym.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) type Foo a = forall f. Monad f => f a diff --git a/examples/passing/Rank2Types.purs b/examples/passing/Rank2Types.purs index fccea0c0bf..b682f50806 100644 --- a/examples/passing/Rank2Types.purs +++ b/examples/passing/Rank2Types.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) test1 :: (forall a. (a -> a)) -> Number test1 = \f -> f 0.0 diff --git a/examples/passing/ReExportQualified.purs b/examples/passing/ReExportQualified.purs index 98a1a579aa..b7e8e7a95c 100644 --- a/examples/passing/ReExportQualified.purs +++ b/examples/passing/ReExportQualified.purs @@ -2,6 +2,6 @@ module Main where import Prelude import C -import Control.Monad.Eff.Console (log) +import Effect.Console (log) main = log (x <> y) diff --git a/examples/passing/RebindableSyntax.purs b/examples/passing/RebindableSyntax.purs index b0a7cc3e0c..11da9a6367 100644 --- a/examples/passing/RebindableSyntax.purs +++ b/examples/passing/RebindableSyntax.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) example1 :: String example1 = do @@ -13,7 +13,7 @@ example1 = do discard x f = x <> f unit applySecond :: forall f a b. Apply f => f a -> f b -> f b -applySecond fa fb = const id <$> fa <*> fb +applySecond fa fb = const identity <$> fa <*> fb infixl 4 applySecond as *> diff --git a/examples/passing/Recursion.purs b/examples/passing/Recursion.purs index f9798f9b9b..d0711497b9 100644 --- a/examples/passing/Recursion.purs +++ b/examples/passing/Recursion.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) fib = \n -> case n of 0.0 -> 1.0 diff --git a/examples/passing/RedefinedFixity.purs b/examples/passing/RedefinedFixity.purs index 48f147b540..57e95d95af 100644 --- a/examples/passing/RedefinedFixity.purs +++ b/examples/passing/RedefinedFixity.purs @@ -1,6 +1,6 @@ module Main where import M3 -import Control.Monad.Eff.Console (log) +import Effect.Console (log) main = log "Done" diff --git a/examples/passing/ReservedWords.purs b/examples/passing/ReservedWords.purs index e96a643a99..84120b6d95 100644 --- a/examples/passing/ReservedWords.purs +++ b/examples/passing/ReservedWords.purs @@ -2,8 +2,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console (log) +import Effect +import Effect.Console (log) o :: { type :: String } o = { type: "o" } @@ -15,5 +15,5 @@ f :: forall r. { type :: String | r } -> String f { type: "p" } = "Done" f _ = "Fail" -main :: Eff _ _ +main :: Effect _ main = log $ f { type: p.type, foo: "bar" } diff --git a/examples/passing/ResolvableScopeConflict.purs b/examples/passing/ResolvableScopeConflict.purs index 4f63802273..42c2a90c17 100644 --- a/examples/passing/ResolvableScopeConflict.purs +++ b/examples/passing/ResolvableScopeConflict.purs @@ -2,7 +2,7 @@ module Main where import A (thing) import B -import Control.Monad.Eff.Console (log) +import Effect.Console (log) -- Not an error as although we have `thing` in scope from both A and B, it is -- imported explicitly from A, giving it a resolvable solution. diff --git a/examples/passing/ResolvableScopeConflict2.purs b/examples/passing/ResolvableScopeConflict2.purs index 7101c959c2..2bbe9911d9 100644 --- a/examples/passing/ResolvableScopeConflict2.purs +++ b/examples/passing/ResolvableScopeConflict2.purs @@ -1,7 +1,7 @@ module Main where import A -import Control.Monad.Eff.Console (log) +import Effect.Console (log) thing :: Int thing = 1 diff --git a/examples/passing/ResolvableScopeConflict3.purs b/examples/passing/ResolvableScopeConflict3.purs index 396b8cc9f2..853adcf56c 100644 --- a/examples/passing/ResolvableScopeConflict3.purs +++ b/examples/passing/ResolvableScopeConflict3.purs @@ -1,7 +1,7 @@ module Main (thing, main, module A) where import A -import Control.Monad.Eff.Console (log) +import Effect.Console (log) thing :: Int thing = 2 diff --git a/examples/passing/RowConstructors.purs b/examples/passing/RowConstructors.purs index 53e7b8ec67..d80457c118 100644 --- a/examples/passing/RowConstructors.purs +++ b/examples/passing/RowConstructors.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) type Foo = (x :: Number | (y :: Number | (z :: Number))) type Bar = (x :: Number, y :: Number, z :: Number) @@ -14,7 +14,7 @@ bar :: { | Bar } bar = { x: 0.0, y: 0.0, z: 0.0 } id' :: Record Foo -> Record Bar -id' = id +id' = identity foo' :: { | Foo } foo' = id' foo diff --git a/examples/passing/RowInInstanceHeadDetermined.purs b/examples/passing/RowInInstanceHeadDetermined.purs index 73a89ba54b..036618de5d 100644 --- a/examples/passing/RowInInstanceHeadDetermined.purs +++ b/examples/passing/RowInInstanceHeadDetermined.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Empty = Empty data Cons = Cons diff --git a/examples/passing/RowLacks.purs b/examples/passing/RowLacks.purs index 171eef8d55..06e7b91d09 100644 --- a/examples/passing/RowLacks.purs +++ b/examples/passing/RowLacks.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Prim.Row (class Lacks) import Type.Row (RProxy(..)) diff --git a/examples/passing/RowNub.purs b/examples/passing/RowNub.purs index cc9436f11c..fd9f6ca3b8 100644 --- a/examples/passing/RowNub.purs +++ b/examples/passing/RowNub.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Prim.Row (class Nub, class Union) import Type.Row (RProxy(..)) diff --git a/examples/passing/RowPolyInstanceContext.purs b/examples/passing/RowPolyInstanceContext.purs index 796adef766..90f9ce427a 100644 --- a/examples/passing/RowPolyInstanceContext.purs +++ b/examples/passing/RowPolyInstanceContext.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class T s m | m -> s where state :: (s -> s) -> m Unit diff --git a/examples/passing/RowUnion.purs b/examples/passing/RowUnion.purs index 112294c0d8..2b921f2037 100644 --- a/examples/passing/RowUnion.purs +++ b/examples/passing/RowUnion.purs @@ -2,8 +2,8 @@ module Main where import Prelude import Prim.Row -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console foreign import merge :: forall r1 r2 r3 @@ -51,7 +51,7 @@ test4 = withDefaults { x: 1, y: 2 } class Subrow (r :: # Type) (s :: # Type) instance subrow :: Union r t s => Subrow r s -main :: Eff (console :: CONSOLE) Unit +main :: Effect Unit main = do logShow test1.x logShow test1.y diff --git a/examples/passing/RowsInInstanceContext.purs b/examples/passing/RowsInInstanceContext.purs index 708d9d4a15..19fa17f01b 100644 --- a/examples/passing/RowsInInstanceContext.purs +++ b/examples/passing/RowsInInstanceContext.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log) +import Effect (Effect) +import Effect.Console (log) import Data.Newtype (class Newtype, unwrap) class TypeEquals a b | a -> b, b -> a where @@ -10,8 +10,8 @@ class TypeEquals a b | a -> b, b -> a where coerceBack :: b -> a instance refl :: TypeEquals a a where - coerce = id - coerceBack = id + coerce = identity + coerceBack = identity newtype RecordNewtype = RecordNewtype { x :: String } @@ -21,5 +21,5 @@ instance newtypeRecordNewtype :: wrap = RecordNewtype <<< coerce unwrap (RecordNewtype rec) = coerceBack rec -main :: Eff (console :: CONSOLE) Unit +main :: Effect Unit main = log (unwrap (RecordNewtype { x: "Done" })).x diff --git a/examples/passing/RunFnInline.purs b/examples/passing/RunFnInline.purs index 24babe5adc..dd735886c6 100644 --- a/examples/passing/RunFnInline.purs +++ b/examples/passing/RunFnInline.purs @@ -2,7 +2,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) runFn3 :: forall a b c d. (a -> b -> c -> d) -> a -> b -> c -> d runFn3 f a b c = f a b c diff --git a/examples/passing/RuntimeScopeIssue.purs b/examples/passing/RuntimeScopeIssue.purs index 2b1b7f9b21..447d80fcbc 100644 --- a/examples/passing/RuntimeScopeIssue.purs +++ b/examples/passing/RuntimeScopeIssue.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) class A a where a :: a -> Boolean diff --git a/examples/passing/ScopedTypeVariables.purs b/examples/passing/ScopedTypeVariables.purs index 862d821135..3f71bbeb54 100644 --- a/examples/passing/ScopedTypeVariables.purs +++ b/examples/passing/ScopedTypeVariables.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) test1 :: forall a. (a -> a) -> a -> a test1 f x = g (g x) diff --git a/examples/passing/Sequence.purs b/examples/passing/Sequence.purs index 37febf1ad7..b6adc20030 100644 --- a/examples/passing/Sequence.purs +++ b/examples/passing/Sequence.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console (log) +import Effect +import Effect.Console (log) data List a = Cons a (List a) | Nil diff --git a/examples/passing/SequenceDesugared.purs b/examples/passing/SequenceDesugared.purs index 9268a276ce..696e016dcc 100644 --- a/examples/passing/SequenceDesugared.purs +++ b/examples/passing/SequenceDesugared.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console (log) +import Effect +import Effect.Console (log) data List a = Cons a (List a) | Nil diff --git a/examples/passing/ShadowedModuleName.purs b/examples/passing/ShadowedModuleName.purs index 764b8c5327..bf89d70103 100644 --- a/examples/passing/ShadowedModuleName.purs +++ b/examples/passing/ShadowedModuleName.purs @@ -1,7 +1,7 @@ module Main where import Test -import Control.Monad.Eff.Console +import Effect.Console data Test = Test diff --git a/examples/passing/ShadowedName.purs b/examples/passing/ShadowedName.purs index 6098249c7e..3c06295326 100644 --- a/examples/passing/ShadowedName.purs +++ b/examples/passing/ShadowedName.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff.Console -import Control.Monad.Eff.Console (log) +import Effect.Console +import Effect.Console (log) done :: String done = let str = "Not yet done" in diff --git a/examples/passing/ShadowedRename.purs b/examples/passing/ShadowedRename.purs index 4b0c31798b..26def25483 100644 --- a/examples/passing/ShadowedRename.purs +++ b/examples/passing/ShadowedRename.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console import Test.Assert foo foo = let foo_1 = \_ -> foo diff --git a/examples/passing/ShadowedTCO.purs b/examples/passing/ShadowedTCO.purs index 47d222d6a9..54fb9f87ed 100644 --- a/examples/passing/ShadowedTCO.purs +++ b/examples/passing/ShadowedTCO.purs @@ -1,7 +1,7 @@ module Main where import Prelude hiding (add) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) runNat f = f 0.0 (\n -> n + 1.0) diff --git a/examples/passing/ShadowedTCOLet.purs b/examples/passing/ShadowedTCOLet.purs index 3b04ec6eda..b154761810 100644 --- a/examples/passing/ShadowedTCOLet.purs +++ b/examples/passing/ShadowedTCOLet.purs @@ -2,14 +2,14 @@ module Main where import Prelude import Partial.Unsafe (unsafePartial) -import Control.Monad.Eff -import Control.Monad.Eff.Console (log) +import Effect +import Effect.Console (log) f x y z = let f 1.0 2.0 3.0 = 1.0 in f x z y -main :: Eff _ _ +main :: Effect _ main = do log $ show $ unsafePartial f 1.0 3.0 2.0 log "Done" diff --git a/examples/passing/SignedNumericLiterals.purs b/examples/passing/SignedNumericLiterals.purs index 1ebcdb4f54..851e7aa73f 100644 --- a/examples/passing/SignedNumericLiterals.purs +++ b/examples/passing/SignedNumericLiterals.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) p = 0.5 q = 1.0 diff --git a/examples/passing/SolvingAppendSymbol.purs b/examples/passing/SolvingAppendSymbol.purs index 41fa545829..a1656dcea5 100644 --- a/examples/passing/SolvingAppendSymbol.purs +++ b/examples/passing/SolvingAppendSymbol.purs @@ -1,8 +1,10 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) -import Type.Data.Symbol (SProxy(..), class AppendSymbol, appendSymbol, reflectSymbol) +import Effect.Console (log) +import Prim.Symbol (class Append) +import Type.Data.Symbol (SProxy(..), reflectSymbol) +import Type.Data.Symbol (append) as Symbol sym :: SProxy "" sym = SProxy @@ -14,13 +16,13 @@ symB :: SProxy "B" symB = SProxy egAB :: SProxy "AB" -egAB = appendSymbol symA symB +egAB = Symbol.append symA symB egBA :: SProxy "BA" -egBA = appendSymbol symB symA +egBA = Symbol.append symB symA egA' :: SProxy "A" -egA' = appendSymbol sym (appendSymbol symA sym) +egA' = Symbol.append sym (Symbol.append symA sym) main = do let gotAB = reflectSymbol egAB == "AB" diff --git a/examples/passing/SolvingCompareSymbol.purs b/examples/passing/SolvingCompareSymbol.purs index 24ffece8a7..0b18b12fde 100644 --- a/examples/passing/SolvingCompareSymbol.purs +++ b/examples/passing/SolvingCompareSymbol.purs @@ -1,9 +1,12 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) -import Type.Data.Symbol (SProxy(..), class CompareSymbol, compareSymbol) -import Type.Data.Ordering (OProxy(..), kind Ordering, LT, EQ, GT, reflectOrdering) +import Effect.Console (log) +import Prim.Symbol (class Compare) +import Prim.Ordering (kind Ordering, LT, EQ, GT) +import Type.Data.Symbol (SProxy(..)) +import Type.Data.Symbol (compare) as Symbol +import Type.Data.Ordering (OProxy(..), reflectOrdering) symA :: SProxy "A" symA = SProxy @@ -12,13 +15,13 @@ symB :: SProxy "B" symB = SProxy egLT :: OProxy LT -egLT = compareSymbol symA symB +egLT = Symbol.compare symA symB egEQ :: OProxy EQ -egEQ = compareSymbol symA symA +egEQ = Symbol.compare symA symA egGT :: OProxy GT -egGT = compareSymbol symB symA +egGT = Symbol.compare symB symA main = do let gotLT = reflectOrdering egLT == LT diff --git a/examples/passing/SolvingIsSymbol.purs b/examples/passing/SolvingIsSymbol.purs index e14866a293..71f5c18f6a 100644 --- a/examples/passing/SolvingIsSymbol.purs +++ b/examples/passing/SolvingIsSymbol.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console -- Here we import as alias of reflectSymbol without importing Data.Symbol. However, -- Data.Symbol should be implicitly imported as we have an instance of IsSymbol solved. diff --git a/examples/passing/Stream.purs b/examples/passing/Stream.purs index cc62a39668..cd9b86b6a3 100644 --- a/examples/passing/Stream.purs +++ b/examples/passing/Stream.purs @@ -2,8 +2,8 @@ module Main where import Prelude -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log) +import Effect (Effect) +import Effect.Console (log) class IsStream el s | s -> el where cons :: el -> (Unit -> s) -> s @@ -19,7 +19,7 @@ test :: forall el s. IsStream el s => s -> s test s = case uncons s of { head, tail } -> cons head \_ -> tail -main :: Eff (console :: CONSOLE) Unit +main :: Effect Unit main = do let dones :: Stream String dones = cons "Done" \_ -> dones diff --git a/examples/passing/StringEdgeCases/Records.purs b/examples/passing/StringEdgeCases/Records.purs index 82300b3300..6d0c455e82 100644 --- a/examples/passing/StringEdgeCases/Records.purs +++ b/examples/passing/StringEdgeCases/Records.purs @@ -1,7 +1,7 @@ module Records where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) import Test.Assert (assert') newtype AstralKeys = AstralKeys { "💡" :: Int, "💢" :: Int } diff --git a/examples/passing/StringEdgeCases/Symbols.purs b/examples/passing/StringEdgeCases/Symbols.purs index 991563adf6..0289a893d0 100644 --- a/examples/passing/StringEdgeCases/Symbols.purs +++ b/examples/passing/StringEdgeCases/Symbols.purs @@ -4,8 +4,10 @@ module Symbols where import Prelude -import Control.Monad.Eff.Console (log) -import Type.Data.Symbol (SProxy(..), class AppendSymbol, appendSymbol, reflectSymbol) +import Effect.Console (log) +import Prim.Symbol (class Append) +import Type.Data.Symbol (SProxy(..), reflectSymbol) +import Type.Data.Symbol (append) as Symbol import Test.Assert (assert') highS :: SProxy "\xd834" @@ -15,10 +17,10 @@ lowS :: SProxy "\xdf06" lowS = SProxy loneSurrogates :: Boolean -loneSurrogates = reflectSymbol (appendSymbol highS lowS) == "\x1d306" +loneSurrogates = reflectSymbol (Symbol.append highS lowS) == "\x1d306" outOfOrderSurrogates :: Boolean -outOfOrderSurrogates = reflectSymbol (appendSymbol lowS highS) == "\xdf06\xd834" +outOfOrderSurrogates = reflectSymbol (Symbol.append lowS highS) == "\xdf06\xd834" notReplacing :: Boolean notReplacing = reflectSymbol lowS /= "\xfffd" diff --git a/examples/passing/StringEscapes.purs b/examples/passing/StringEscapes.purs index 7d0732b83f..9194ce7937 100644 --- a/examples/passing/StringEscapes.purs +++ b/examples/passing/StringEscapes.purs @@ -2,7 +2,7 @@ module Main where import Prelude ((==), (/=), (<>), discard) import Test.Assert (assert, assert') -import Control.Monad.Eff.Console (log) +import Effect.Console (log) singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C" hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0" diff --git a/examples/passing/Superclasses1.purs b/examples/passing/Superclasses1.purs index 4f00c1f7c5..2f514cf29f 100644 --- a/examples/passing/Superclasses1.purs +++ b/examples/passing/Superclasses1.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) class Su a where su :: a -> a diff --git a/examples/passing/Superclasses3.purs b/examples/passing/Superclasses3.purs index 8115fb2a26..ec3da56e07 100644 --- a/examples/passing/Superclasses3.purs +++ b/examples/passing/Superclasses3.purs @@ -1,8 +1,8 @@ module Main where import Prelude -import Control.Monad.Eff.Console -import Control.Monad.Eff +import Effect.Console +import Effect class Monad m <= MonadWriter w m where tell :: w -> m Unit @@ -16,9 +16,9 @@ test w = do tell w tell w -data MTrace a = MTrace (Eff (console :: CONSOLE) a) +data MTrace a = MTrace (Effect a) -runMTrace :: forall a. MTrace a -> Eff (console :: CONSOLE) a +runMTrace :: forall a. MTrace a -> Effect a runMTrace (MTrace a) = a instance functorMTrace :: Functor MTrace where diff --git a/examples/passing/TCO.purs b/examples/passing/TCO.purs index fbd9951886..d1a1fa9835 100644 --- a/examples/passing/TCO.purs +++ b/examples/passing/TCO.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) import Control.Monad.Rec.Class import Data.Array ((..), span, length) @@ -22,7 +22,7 @@ main = do log "Done" applyN :: forall a. Int -> (a -> a) -> a -> a -applyN = go id +applyN = go identity where go f n _ | n <= 0 = f go f n g = go (f >>> g) (n - 1) g diff --git a/examples/passing/TCOCase.purs b/examples/passing/TCOCase.purs index 45cde9fa3d..b42e299213 100644 --- a/examples/passing/TCOCase.purs +++ b/examples/passing/TCOCase.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Data = One | More Data diff --git a/examples/passing/TailCall.purs b/examples/passing/TailCall.purs index 83d199e1a1..2435d2d544 100644 --- a/examples/passing/TailCall.purs +++ b/examples/passing/TailCall.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log, logShow) +import Effect.Console (log, logShow) data L a = C a (L a) | N diff --git a/examples/passing/Tick.purs b/examples/passing/Tick.purs index 4e655e6cef..58867a50d8 100644 --- a/examples/passing/Tick.purs +++ b/examples/passing/Tick.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) test' x = x diff --git a/examples/passing/TopLevelCase.purs b/examples/passing/TopLevelCase.purs index c43bc65782..b74039959e 100644 --- a/examples/passing/TopLevelCase.purs +++ b/examples/passing/TopLevelCase.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) gcd :: Number -> Number -> Number gcd 0.0 x = x diff --git a/examples/passing/TransitiveImport.purs b/examples/passing/TransitiveImport.purs index 04e00d3116..62830afcb7 100644 --- a/examples/passing/TransitiveImport.purs +++ b/examples/passing/TransitiveImport.purs @@ -2,7 +2,7 @@ module Main where import Prelude import Middle - import Control.Monad.Eff.Console + import Effect.Console main = do logShow (middle unit) diff --git a/examples/passing/TypeClassMemberOrderChange.purs b/examples/passing/TypeClassMemberOrderChange.purs index 5ad8dcba1a..e1957264af 100644 --- a/examples/passing/TypeClassMemberOrderChange.purs +++ b/examples/passing/TypeClassMemberOrderChange.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class Test a where fn :: a -> a -> a diff --git a/examples/passing/TypeClasses.purs b/examples/passing/TypeClasses.purs index 2a52bac122..b4650d3b26 100644 --- a/examples/passing/TypeClasses.purs +++ b/examples/passing/TypeClasses.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) test1 = \_ -> show "testing" diff --git a/examples/passing/TypeClassesInOrder.purs b/examples/passing/TypeClassesInOrder.purs index f02c037070..fe62bcf806 100644 --- a/examples/passing/TypeClassesInOrder.purs +++ b/examples/passing/TypeClassesInOrder.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class Foo a where foo :: a -> String diff --git a/examples/passing/TypeClassesWithOverlappingTypeVariables.purs b/examples/passing/TypeClassesWithOverlappingTypeVariables.purs index 281e7af8f3..c8019d1e1e 100644 --- a/examples/passing/TypeClassesWithOverlappingTypeVariables.purs +++ b/examples/passing/TypeClassesWithOverlappingTypeVariables.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Either a b = Left a | Right b diff --git a/examples/passing/TypeDecl.purs b/examples/passing/TypeDecl.purs index 6cecb573c7..64b8b77221 100644 --- a/examples/passing/TypeDecl.purs +++ b/examples/passing/TypeDecl.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) k :: String -> Number -> String k x y = x diff --git a/examples/passing/TypeOperators.purs b/examples/passing/TypeOperators.purs index fbbc723e4f..2c0c4df8b3 100644 --- a/examples/passing/TypeOperators.purs +++ b/examples/passing/TypeOperators.purs @@ -1,7 +1,7 @@ module Main where import A (type (~>), type (/\), (/\)) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) natty ∷ ∀ f. f ~> f natty x = x diff --git a/examples/passing/TypeSynonymInData.purs b/examples/passing/TypeSynonymInData.purs index 198d6f78c3..a003f1ffb5 100644 --- a/examples/passing/TypeSynonymInData.purs +++ b/examples/passing/TypeSynonymInData.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) type A a = Array a diff --git a/examples/passing/TypeSynonyms.purs b/examples/passing/TypeSynonyms.purs index 0ca79844c7..55ddf98f79 100644 --- a/examples/passing/TypeSynonyms.purs +++ b/examples/passing/TypeSynonyms.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) type Lens a b = { get :: a -> b diff --git a/examples/passing/TypeWildcards.purs b/examples/passing/TypeWildcards.purs index 262cf2c2c5..3fe4cfdb09 100644 --- a/examples/passing/TypeWildcards.purs +++ b/examples/passing/TypeWildcards.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) testTopLevel :: _ -> _ testTopLevel n = n + 1.0 diff --git a/examples/passing/TypeWildcardsRecordExtension.purs b/examples/passing/TypeWildcardsRecordExtension.purs index fe21b47484..d2400cfd94 100644 --- a/examples/passing/TypeWildcardsRecordExtension.purs +++ b/examples/passing/TypeWildcardsRecordExtension.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) foo :: forall a. {b :: Number | a} -> {b :: Number | _} foo f = f diff --git a/examples/passing/TypeWithoutParens.purs b/examples/passing/TypeWithoutParens.purs index 729016f5eb..aff33f2c40 100644 --- a/examples/passing/TypeWithoutParens.purs +++ b/examples/passing/TypeWithoutParens.purs @@ -1,7 +1,7 @@ module Main where import Lib (X, Y) -import Control.Monad.Eff.Console (log) +import Effect.Console (log) idX :: X -> X idX x = x diff --git a/examples/passing/TypedBinders.purs b/examples/passing/TypedBinders.purs index 92e50b672a..f94926e2d5 100644 --- a/examples/passing/TypedBinders.purs +++ b/examples/passing/TypedBinders.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Tuple a b = Tuple a b @@ -62,7 +62,7 @@ test5 = \(x :: Int1) -> x main = do let t1 = test - t2 = test2 id + t2 = test2 identity t3 = test3 1 t4 = test4 (Tuple 1 0) log "Done" diff --git a/examples/passing/TypedWhere.purs b/examples/passing/TypedWhere.purs index d9c489ad88..dfacebe3ae 100644 --- a/examples/passing/TypedWhere.purs +++ b/examples/passing/TypedWhere.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data E a b = L a | R b diff --git a/examples/passing/UTF8Sourcefile.purs b/examples/passing/UTF8Sourcefile.purs index 1dbc2cb2a0..5a589d162e 100644 --- a/examples/passing/UTF8Sourcefile.purs +++ b/examples/passing/UTF8Sourcefile.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console +import Effect.Console -- '→' is multibyte sequence \u2192. utf8multibyte = "Hello λ→ world!!" diff --git a/examples/passing/UnderscoreIdent.purs b/examples/passing/UnderscoreIdent.purs index 0a02edc5bf..e09a09cba2 100644 --- a/examples/passing/UnderscoreIdent.purs +++ b/examples/passing/UnderscoreIdent.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Data_type = Con_Structor | Con_2 String diff --git a/examples/passing/UnicodeIdentifier.purs b/examples/passing/UnicodeIdentifier.purs index 9041a4f9e8..021aa4e49c 100644 --- a/examples/passing/UnicodeIdentifier.purs +++ b/examples/passing/UnicodeIdentifier.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) f asgård = asgård diff --git a/examples/passing/UnicodeOperators.purs b/examples/passing/UnicodeOperators.purs index f93584fb8e..0c86721ffa 100644 --- a/examples/passing/UnicodeOperators.purs +++ b/examples/passing/UnicodeOperators.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) compose :: forall a b c. (b -> c) -> (a -> b) -> a -> c compose f g a = f (g a) diff --git a/examples/passing/UnicodeType.purs b/examples/passing/UnicodeType.purs index ea925253c7..2fd5b8a53a 100644 --- a/examples/passing/UnicodeType.purs +++ b/examples/passing/UnicodeType.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class Monad m ⇐ Monad1 m where f1 :: m Int diff --git a/examples/passing/UnifyInTypeInstanceLookup.purs b/examples/passing/UnifyInTypeInstanceLookup.purs index b235a83d5f..dade5e925c 100644 --- a/examples/passing/UnifyInTypeInstanceLookup.purs +++ b/examples/passing/UnifyInTypeInstanceLookup.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) data Z = Z data S n = S n diff --git a/examples/passing/Unit.purs b/examples/passing/Unit.purs index 1449d72c9a..c585f64770 100644 --- a/examples/passing/Unit.purs +++ b/examples/passing/Unit.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (logShow, log) +import Effect.Console (logShow, log) main = do logShow (const unit $ "Hello world") diff --git a/examples/passing/UnknownInTypeClassLookup.purs b/examples/passing/UnknownInTypeClassLookup.purs index 8b90b1fe74..d5d19368f1 100644 --- a/examples/passing/UnknownInTypeClassLookup.purs +++ b/examples/passing/UnknownInTypeClassLookup.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class EQ a b diff --git a/examples/passing/UnsafeCoerce.purs b/examples/passing/UnsafeCoerce.purs index 6b4dbb1022..357e90f8df 100644 --- a/examples/passing/UnsafeCoerce.purs +++ b/examples/passing/UnsafeCoerce.purs @@ -2,8 +2,8 @@ module Main where import Prelude (Unit) import Unsafe.Coerce (unsafeCoerce) -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log) +import Effect (Effect) +import Effect.Console (log) x :: Number x = unsafeCoerce 1 @@ -12,5 +12,5 @@ y :: Number y = case unsafeCoerce 1 of z -> unsafeCoerce z -main :: Eff (console :: CONSOLE) Unit +main :: Effect Unit main = log "Done" diff --git a/examples/passing/UntupledConstraints.purs b/examples/passing/UntupledConstraints.purs index 48507943ff..2724fe6412 100644 --- a/examples/passing/UntupledConstraints.purs +++ b/examples/passing/UntupledConstraints.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) class Show a <= Nonsense a where method :: a -> a diff --git a/examples/passing/UsableTypeClassMethods.purs b/examples/passing/UsableTypeClassMethods.purs index 5545dedf05..3222f04355 100644 --- a/examples/passing/UsableTypeClassMethods.purs +++ b/examples/passing/UsableTypeClassMethods.purs @@ -2,7 +2,7 @@ -- class methods that should be valid based on various configurations of fundeps module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) -- no fundeps class C0 a b where diff --git a/examples/passing/Where.purs b/examples/passing/Where.purs index fa9169db8c..2b379daa00 100644 --- a/examples/passing/Where.purs +++ b/examples/passing/Where.purs @@ -2,8 +2,8 @@ module Main where import Prelude import Partial.Unsafe (unsafePartial) -import Control.Monad.Eff -import Control.Monad.Eff.Console (logShow, log) +import Effect +import Effect.Console (logShow, log) test1 x = y where @@ -37,7 +37,7 @@ test7 x = go x go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y go y = go $ (y + x / y) / 2.0 -main :: Eff _ _ +main :: Effect _ main = do logShow (test1 1.0) logShow (test2 1.0 2.0) diff --git a/examples/passing/WildcardInInstance.purs b/examples/passing/WildcardInInstance.purs index 4b2d5ab710..f619a2ce76 100644 --- a/examples/passing/WildcardInInstance.purs +++ b/examples/passing/WildcardInInstance.purs @@ -1,23 +1,21 @@ module Main where import Prelude -import Control.Monad.Eff -import Control.Monad.Eff.Console +import Effect +import Effect.Console --- Until the functional dependency gets added to purescript-eff, --- we need this here. -class Monad m <= MonadEff eff m | m -> eff where - liftEff :: forall a. Eff eff a -> m a +class Monad m <= MonadAsk r m | m -> r where + ask :: m r -instance monadEffEff :: MonadEff eff (Eff eff) where - liftEff = id +instance monadAskFun :: MonadAsk r ((->) r) where + ask = identity -- This should generate a warning with the correct inferred type. -test :: forall m. MonadEff _ m => m Unit -test = liftEff $ log "Done" +test :: forall m. MonadAsk _ m => m Int +test = do + x <- ask + pure (x + 1) -test1 :: Eff _ Unit -test1 = liftEff $ log "Done" - -main :: forall eff. Eff (console :: CONSOLE | eff) Unit -main = test +main :: Effect Unit +main = do + log "Done" diff --git a/examples/passing/WildcardType.purs b/examples/passing/WildcardType.purs index b661acac1f..92fb8dc3be 100644 --- a/examples/passing/WildcardType.purs +++ b/examples/passing/WildcardType.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) f1 :: (_ -> _) -> _ f1 g = g 1 diff --git a/examples/passing/iota.purs b/examples/passing/iota.purs index a261eb55f0..a24ed80395 100644 --- a/examples/passing/iota.purs +++ b/examples/passing/iota.purs @@ -1,6 +1,6 @@ module Main where -import Control.Monad.Eff.Console (log) +import Effect.Console (log) s = \x -> \y -> \z -> x z (y z) diff --git a/examples/passing/s.purs b/examples/passing/s.purs index a16149129e..a9589fda53 100644 --- a/examples/passing/s.purs +++ b/examples/passing/s.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import Control.Monad.Eff.Console (log) +import Effect.Console (log) s = \x y z -> x z (y z) diff --git a/examples/warning/2383.purs b/examples/warning/2383.purs index dfcb8ebb7a..855a4d6ba4 100644 --- a/examples/warning/2383.purs +++ b/examples/warning/2383.purs @@ -4,9 +4,9 @@ module Main where import Prelude -import Control.Monad.Eff (Eff) +import Effect (Effect) -main :: Eff () Unit +main :: Effect Unit main = do x <- let x = pure unit in x pure unit diff --git a/examples/warning/2411.purs b/examples/warning/2411.purs index c53ca23573..581c606479 100644 --- a/examples/warning/2411.purs +++ b/examples/warning/2411.purs @@ -3,13 +3,13 @@ module Main where import Prelude -import Control.Monad.Eff (Eff) +import Effect (Effect) test :: forall m. Monad m => Int -> m Unit test x = let x = unit in pure x -main :: Eff () Unit +main :: Effect Unit main = test 42 diff --git a/examples/warning/2542.purs b/examples/warning/2542.purs index 8a1351841e..df7a68c4e3 100644 --- a/examples/warning/2542.purs +++ b/examples/warning/2542.purs @@ -1,7 +1,7 @@ -- @shouldWarnWith MissingTypeDeclaration module Main where -import Control.Monad.Eff.Console +import Effect.Console type T = forall a. Array a diff --git a/examples/warning/DuplicateImport.purs b/examples/warning/DuplicateImport.purs index ff92cbe26f..f9a179bb50 100644 --- a/examples/warning/DuplicateImport.purs +++ b/examples/warning/DuplicateImport.purs @@ -4,7 +4,7 @@ module Main where import Prelude (Unit, unit, pure) import Prelude (Unit, unit, pure) -import Control.Monad.Eff (Eff) +import Effect (Effect) -main :: Eff () Unit +main :: Effect Unit main = pure unit diff --git a/examples/warning/DuplicateSelectiveImport.purs b/examples/warning/DuplicateSelectiveImport.purs index 848b21d8ee..ea97e852b1 100644 --- a/examples/warning/DuplicateSelectiveImport.purs +++ b/examples/warning/DuplicateSelectiveImport.purs @@ -4,7 +4,7 @@ module Main where import Prelude (Unit, unit) import Prelude (pure) -import Control.Monad.Eff (Eff) +import Effect (Effect) -main :: Eff () Unit +main :: Effect Unit main = pure unit diff --git a/examples/warning/HidingImport.purs b/examples/warning/HidingImport.purs index a45bfb9aa7..aba434b275 100644 --- a/examples/warning/HidingImport.purs +++ b/examples/warning/HidingImport.purs @@ -3,7 +3,7 @@ module Main where import Prelude hiding (one) -import Control.Monad.Eff hiding (runPure) +import Effect hiding (untilE) -main :: Eff () Unit +main :: Effect Unit main = pure unit diff --git a/examples/warning/ImplicitImport.purs b/examples/warning/ImplicitImport.purs index bca2996706..29a2f35ed3 100644 --- a/examples/warning/ImplicitImport.purs +++ b/examples/warning/ImplicitImport.purs @@ -3,7 +3,7 @@ module Main where import Prelude -import Control.Monad.Eff +import Effect -main :: Eff () Unit +main :: Effect Unit main = pure unit diff --git a/examples/warning/ImplicitQualifiedImport.purs b/examples/warning/ImplicitQualifiedImport.purs index 36f69d6c20..193e72bc1f 100644 --- a/examples/warning/ImplicitQualifiedImport.purs +++ b/examples/warning/ImplicitQualifiedImport.purs @@ -4,8 +4,8 @@ module Main where import Data.Unit -import Control.Monad.Eff as E -import Control.Monad.Eff.Console as E +import Effect as E +import Effect.Console as E -main :: E.Eff (console :: E.CONSOLE) Unit +main :: E.Effect Unit main = E.log "test" diff --git a/examples/warning/ImplicitQualifiedImportReExport.purs b/examples/warning/ImplicitQualifiedImportReExport.purs index 6f6ea6a9c8..92889ccb31 100644 --- a/examples/warning/ImplicitQualifiedImportReExport.purs +++ b/examples/warning/ImplicitQualifiedImportReExport.purs @@ -4,10 +4,10 @@ module Main (module X, module Y, main) where import Prelude -import Control.Monad.Eff (Eff) -import Control.Monad.Eff.Console (CONSOLE, log) +import Effect (Effect) +import Effect.Console (log) import Data.Maybe as X import Data.Either as Y -main :: Eff (console :: CONSOLE) Unit +main :: Effect Unit main = log "test" diff --git a/examples/warning/NewtypeInstance2.purs b/examples/warning/NewtypeInstance2.purs index de5f56bb0a..d148ed037b 100644 --- a/examples/warning/NewtypeInstance2.purs +++ b/examples/warning/NewtypeInstance2.purs @@ -2,7 +2,6 @@ module Main where import Prelude -import Data.Monoid (class Monoid) import Data.Tuple (Tuple(..)) class (Monad m, Monoid w) <= MonadWriter w m | m -> w where diff --git a/examples/warning/NewtypeInstance3.purs b/examples/warning/NewtypeInstance3.purs index 7357d5b8c1..f61a558c87 100644 --- a/examples/warning/NewtypeInstance3.purs +++ b/examples/warning/NewtypeInstance3.purs @@ -2,7 +2,6 @@ module Main where import Prelude -import Data.Monoid (class Monoid) import Data.Tuple (Tuple(..)) class (Monad m, Monoid w) <= MonadTell w m | m -> w where diff --git a/examples/warning/NewtypeInstance4.purs b/examples/warning/NewtypeInstance4.purs index 625d1d3ee1..878d56e3f3 100644 --- a/examples/warning/NewtypeInstance4.purs +++ b/examples/warning/NewtypeInstance4.purs @@ -2,7 +2,6 @@ module Main where import Prelude -import Data.Monoid (class Monoid) import Data.Tuple (Tuple(..)) class Monoid w <= MonadTell w m where diff --git a/examples/warning/UnusedExplicitImport.purs b/examples/warning/UnusedExplicitImport.purs index a6705e38d0..d456c7a62e 100644 --- a/examples/warning/UnusedExplicitImport.purs +++ b/examples/warning/UnusedExplicitImport.purs @@ -2,7 +2,7 @@ module Main where import Prelude (Unit, unit, pure, bind) -import Control.Monad.Eff (Eff) +import Effect (Effect) -main :: Eff () Unit +main :: Effect Unit main = pure unit diff --git a/examples/warning/UnusedExplicitImportTypeOp.purs b/examples/warning/UnusedExplicitImportTypeOp.purs index 41caf6b0a5..a7151ae1e9 100644 --- a/examples/warning/UnusedExplicitImportTypeOp.purs +++ b/examples/warning/UnusedExplicitImportTypeOp.purs @@ -2,8 +2,8 @@ module Main where import Prelude (Unit, unit, pure) -import Control.Monad.Eff (Eff) +import Effect (Effect) import Lib (type (~>), natId) -main :: Eff () Unit +main :: Effect Unit main = natId (pure unit) diff --git a/examples/warning/UnusedExplicitImportValOp.purs b/examples/warning/UnusedExplicitImportValOp.purs index 26a792856d..920efe947a 100644 --- a/examples/warning/UnusedExplicitImportValOp.purs +++ b/examples/warning/UnusedExplicitImportValOp.purs @@ -2,7 +2,7 @@ module Main where import Prelude (Unit, unit, pure, (+)) -import Control.Monad.Eff (Eff) +import Effect (Effect) -main :: Eff () Unit +main :: Effect Unit main = pure unit diff --git a/examples/warning/UnusedImport.purs b/examples/warning/UnusedImport.purs index d13840bbb3..1ecd4a3641 100644 --- a/examples/warning/UnusedImport.purs +++ b/examples/warning/UnusedImport.purs @@ -6,8 +6,8 @@ module Main where import Data.Unit (Unit, unit) -- All of the below are unused -import Control.Monad.Eff -import Control.Monad.Eff.Console as Console +import Effect +import Effect.Console as Console import Test.Assert () main :: Unit diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index e1517a5f66..daac78d7fe 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -55,7 +55,7 @@ moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ = let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps jsImports <- traverse (importToJs mnLookup) - . (\\ [mn, C.Prim, C.PrimRow, C.PrimTypeError]) $ ordNub $ map snd imps + . (\\ [mn, C.Prim, C.PrimOrdering, C.PrimRow, C.PrimRowList, C.PrimSymbol, C.PrimTypeError]) $ ordNub $ map snd imps let decls' = renameModules mnLookup decls jsDecls <- mapM bindToJs decls' optimized <- traverse (traverse optimize) jsDecls diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index ad0cd94861..2e9b144e11 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -359,99 +359,109 @@ fromSpine = "fromSpine" toSignature :: forall a. (IsString a) => a toSignature = "toSignature" --- Data.Symbol - -pattern DataSymbol :: ModuleName -pattern DataSymbol = ModuleName [ProperName "Data", ProperName "Symbol"] - -pattern IsSymbol :: Qualified (ProperName 'ClassName) -pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol") +-- Main module --- Type.Data.Symbol +main :: forall a. (IsString a) => a +main = "main" -pattern TypeDataSymbol :: ModuleName -pattern TypeDataSymbol = ModuleName [ProperName "Type", ProperName "Data", ProperName "Symbol"] +-- Prim -pattern CompareSymbol :: Qualified (ProperName 'ClassName) -pattern CompareSymbol = Qualified (Just TypeDataSymbol) (ProperName "CompareSymbol") +partial :: forall a. (IsString a) => a +partial = "Partial" -pattern AppendSymbol :: Qualified (ProperName 'ClassName) -pattern AppendSymbol = Qualified (Just TypeDataSymbol) (ProperName "AppendSymbol") +pattern Prim :: ModuleName +pattern Prim = ModuleName [ProperName "Prim"] -pattern ConsSymbol :: Qualified (ProperName 'ClassName) -pattern ConsSymbol = Qualified (Just TypeDataSymbol) (ProperName "ConsSymbol") +pattern Partial :: Qualified (ProperName 'ClassName) +pattern Partial = Qualified (Just Prim) (ProperName "Partial") --- Type.Data.Ordering +-- Prim.Ordering -typeDataOrdering :: ModuleName -typeDataOrdering = ModuleName [ProperName "Type", ProperName "Data", ProperName "Ordering"] +pattern PrimOrdering :: ModuleName +pattern PrimOrdering = ModuleName [ProperName "Prim", ProperName "Ordering"] orderingLT :: Qualified (ProperName 'TypeName) -orderingLT = Qualified (Just typeDataOrdering) (ProperName "LT") +orderingLT = Qualified (Just PrimOrdering) (ProperName "LT") orderingEQ :: Qualified (ProperName 'TypeName) -orderingEQ = Qualified (Just typeDataOrdering) (ProperName "EQ") +orderingEQ = Qualified (Just PrimOrdering) (ProperName "EQ") orderingGT :: Qualified (ProperName 'TypeName) -orderingGT = Qualified (Just typeDataOrdering) (ProperName "GT") +orderingGT = Qualified (Just PrimOrdering) (ProperName "GT") + +-- Prim.Row + +pattern PrimRow :: ModuleName +pattern PrimRow = ModuleName [ProperName "Prim", ProperName "Row"] --- Type.Row +pattern RowUnion :: Qualified (ProperName 'ClassName) +pattern RowUnion = Qualified (Just PrimRow) (ProperName "Union") -pattern TypeRow :: ModuleName -pattern TypeRow = ModuleName [ProperName "Type", ProperName "Row"] +pattern RowNub :: Qualified (ProperName 'ClassName) +pattern RowNub = Qualified (Just PrimRow) (ProperName "Nub") + +pattern RowCons :: Qualified (ProperName 'ClassName) +pattern RowCons = Qualified (Just PrimRow) (ProperName "Cons") + +pattern RowLacks :: Qualified (ProperName 'ClassName) +pattern RowLacks = Qualified (Just PrimRow) (ProperName "Lacks") + +-- Prim.RowList + +pattern PrimRowList :: ModuleName +pattern PrimRowList = ModuleName [ProperName "Prim", ProperName "RowList"] pattern RowToList :: Qualified (ProperName 'ClassName) -pattern RowToList = Qualified (Just TypeRow) (ProperName "RowToList") +pattern RowToList = Qualified (Just PrimRowList) (ProperName "RowToList") pattern RowListNil :: Qualified (ProperName 'TypeName) -pattern RowListNil = Qualified (Just TypeRow) (ProperName "Nil") +pattern RowListNil = Qualified (Just PrimRowList) (ProperName "Nil") pattern RowListCons :: Qualified (ProperName 'TypeName) -pattern RowListCons = Qualified (Just TypeRow) (ProperName "Cons") +pattern RowListCons = Qualified (Just PrimRowList) (ProperName "Cons") --- Main module +-- Prim.Symbol -main :: forall a. (IsString a) => a -main = "main" +pattern PrimSymbol :: ModuleName +pattern PrimSymbol = ModuleName [ProperName "Prim", ProperName "Symbol"] --- Prim +pattern SymbolCompare :: Qualified (ProperName 'ClassName) +pattern SymbolCompare = Qualified (Just PrimSymbol) (ProperName "Compare") -partial :: forall a. (IsString a) => a -partial = "Partial" +pattern SymbolAppend :: Qualified (ProperName 'ClassName) +pattern SymbolAppend = Qualified (Just PrimSymbol) (ProperName "Append") -pattern Prim :: ModuleName -pattern Prim = ModuleName [ProperName "Prim"] +pattern SymbolCons :: Qualified (ProperName 'ClassName) +pattern SymbolCons = Qualified (Just PrimSymbol) (ProperName "Cons") -pattern PrimRow :: ModuleName -pattern PrimRow = ModuleName [ProperName "Prim", ProperName "Row"] +-- Prim.TypeError pattern PrimTypeError :: ModuleName pattern PrimTypeError = ModuleName [ProperName "Prim", ProperName "TypeError"] -pattern Partial :: Qualified (ProperName 'ClassName) -pattern Partial = Qualified (Just Prim) (ProperName "Partial") - pattern Fail :: Qualified (ProperName 'ClassName) pattern Fail = Qualified (Just PrimTypeError) (ProperName "Fail") pattern Warn :: Qualified (ProperName 'ClassName) pattern Warn = Qualified (Just PrimTypeError) (ProperName "Warn") -pattern Union :: Qualified (ProperName 'ClassName) -pattern Union = Qualified (Just PrimRow) (ProperName "Union") - -pattern Nub :: Qualified (ProperName 'ClassName) -pattern Nub = Qualified (Just PrimRow) (ProperName "Nub") +-- Data.Symbol -pattern Lacks :: Qualified (ProperName 'ClassName) -pattern Lacks = Qualified (Just PrimRow) (ProperName "Lacks") +pattern DataSymbol :: ModuleName +pattern DataSymbol = ModuleName [ProperName "Data", ProperName "Symbol"] -pattern RowCons :: Qualified (ProperName 'ClassName) -pattern RowCons = Qualified (Just PrimRow) (ProperName "Cons") +pattern IsSymbol :: Qualified (ProperName 'ClassName) +pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol") typ :: forall a. (IsString a) => a typ = "Type" +kindOrdering :: forall a. (IsString a) => a +kindOrdering = "Ordering" + +kindRowList :: forall a. (IsString a) => a +kindRowList = "RowList" + symbol :: forall a. (IsString a) => a symbol = "Symbol" @@ -463,12 +473,21 @@ doc = "Doc" prim :: forall a. (IsString a) => a prim = "Prim" +moduleOrdering :: forall a. (IsString a) => a +moduleOrdering = "Ordering" + +moduleRow :: forall a. (IsString a) => a +moduleRow = "Row" + +moduleRowList :: forall a. (IsString a) => a +moduleRowList = "RowList" + +moduleSymbol :: forall a. (IsString a) => a +moduleSymbol = "Symbol" + typeError :: forall a. (IsString a) => a typeError = "TypeError" -row :: forall a. (IsString a) => a -row = "Row" - prelude :: forall a. (IsString a) => a prelude = "Prelude" diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index d280362bb2..79889d53ea 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -16,7 +16,14 @@ import Language.PureScript.Docs.Types import qualified Language.PureScript as P primModules :: [Module] -primModules = [primDocsModule, primRowDocsModule, primTypeErrorDocsModule] +primModules = + [ primDocsModule + , primOrderingDocsModule + , primRowDocsModule + , primRowListDocsModule + , primSymbolDocsModule + , primTypeErrorDocsModule + ] primDocsModule :: Module primDocsModule = Module @@ -38,10 +45,23 @@ primDocsModule = Module , modReExports = [] } +primOrderingDocsModule :: Module +primOrderingDocsModule = Module + { modName = P.moduleNameFromString "Prim.Ordering" + , modComments = Just "The Prim.Row module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains a type level `Ordering` data structure." + , modDeclarations = + [ kindOrdering + , orderingLT + , orderingEQ + , orderingGT + ] + , modReExports = [] + } + primRowDocsModule :: Module primRowDocsModule = Module { modName = P.moduleNameFromString "Prim.Row" - , modComments = Just "The Prim.Row module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains automatically solved classes for working with row types." + , modComments = Just "The Prim.Row module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains automatically solved type classes for working with row types." , modDeclarations = [ union , nub @@ -51,10 +71,35 @@ primRowDocsModule = Module , modReExports = [] } +primRowListDocsModule :: Module +primRowListDocsModule = Module + { modName = P.moduleNameFromString "Prim.RowList" + , modComments = Just "The Prim.RowList module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains a type level list (`RowList`) that represents an ordered view of a row of types." + , modDeclarations = + [ kindRowList + , rowListCons + , rowListNil + , rowToList + ] + , modReExports = [] + } + +primSymbolDocsModule :: Module +primSymbolDocsModule = Module + { modName = P.moduleNameFromString "Prim.Symbol" + , modComments = Just "The Prim.Symbol module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains automatically solved type classes for working with `Symbols`." + , modDeclarations = + [ symbolAppend + , symbolCompare + , symbolCons + ] + , modReExports = [] + } + primTypeErrorDocsModule :: Module primTypeErrorDocsModule = Module { modName = P.moduleNameFromString "Prim.TypeError" - , modComments = Just "The Prim.TypeError module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains classes that provide custom type error and warning functionality." + , modComments = Just "The Prim.TypeError module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains type classes that provide custom type error and warning functionality." , modDeclarations = [ warn , fail @@ -89,7 +134,7 @@ primKindOf -> Text -> Declaration primKindOf g title comments = - if Set.member (g title) P.primKinds + if Set.member (g title) P.allPrimKinds then Declaration { declTitle = title , declComments = Just comments @@ -106,7 +151,13 @@ lookupPrimTypeKindOf :: NameGen 'P.TypeName -> Text -> P.Kind -lookupPrimTypeKindOf k = fst . unsafeLookupOf k (P.primTypes <> P.primRowTypes <> P.primTypeErrorTypes) "Docs.Prim: No such Prim type: " +lookupPrimTypeKindOf k = fst . unsafeLookupOf k + ( P.primTypes <> + P.primOrderingTypes <> + P.primRowTypes <> + P.primRowListTypes <> + P.primTypeErrorTypes + ) "Docs.Prim: No such Prim type: " primType :: Text -> Text -> Declaration primType = primTypeOf P.primName @@ -123,7 +174,13 @@ primTypeOf gen title comments = Declaration -- | Lookup the TypeClassData of a Prim class. This function is specifically -- not exported because it is partial. lookupPrimClassOf :: NameGen 'P.ClassName -> Text -> P.TypeClassData -lookupPrimClassOf g = unsafeLookupOf g (P.primClasses <> P.primTypeErrorClasses <> P.primRowClasses) "Docs.Prim: No such Prim class: " +lookupPrimClassOf g = unsafeLookupOf g + ( P.primClasses <> + P.primRowClasses <> + P.primRowListClasses <> + P.primSymbolClasses <> + P.primTypeErrorClasses + ) "Docs.Prim: No such Prim class: " primClass :: Text -> Text -> Declaration primClass = primClassOf P.primName @@ -273,22 +330,26 @@ partial = primClass "Partial" $ T.unlines , "[the Partial type class guide](https://github.com/purescript/documentation/blob/master/guides/The-Partial-type-class.md)." ] -fail :: Declaration -fail = primClassOf (P.primSubName "TypeError") "Fail" $ T.unlines - [ "The Fail type class is part of the custom type errors feature. To provide" - , "a custom type error when someone tries to use a particular instance," - , "write that instance out with a Fail constraint." - , "" - , "For more information, see" - , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." +kindOrdering :: Declaration +kindOrdering = primKindOf (P.primSubName "Ordering") "Ordering" $ T.unlines + [ "The `Ordering` kind represents the three possibilites of comparing two" + , "types of the same kind: `LT` (less than), `EQ` (equal to), and" + , "`GT` (greater than)." ] -warn :: Declaration -warn = primClassOf (P.primSubName "TypeError") "Warn" $ T.unlines - [ "The Warn type class allows a custom compiler warning to be displayed." - , "" - , "For more information, see" - , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." +orderingLT :: Declaration +orderingLT = primTypeOf (P.primSubName "Ordering") "LT" $ T.unlines + [ "The 'less than' ordering type." + ] + +orderingEQ :: Declaration +orderingEQ = primTypeOf (P.primSubName "Ordering") "EQ" $ T.unlines + [ "The 'equal to' ordering type." + ] + +orderingGT :: Declaration +orderingGT = primTypeOf (P.primSubName "Ordering") "GT" $ T.unlines + [ "The 'greater than' ordering type." ] union :: Declaration @@ -316,6 +377,66 @@ rowCons = primClassOf (P.primSubName "Row") "Cons" $ T.unlines , "the left." ] +kindRowList :: Declaration +kindRowList = primKindOf (P.primSubName "RowList") "RowList" $ T.unlines + [ "A type level list representation of a row of types." + ] + +rowListCons :: Declaration +rowListCons = primTypeOf (P.primSubName "RowList") "Cons" $ T.unlines + [ "Constructs a new `RowList` from a label, a type, and an existing tail" + , "`RowList`. E.g: `Cons \"x\" Int (Cons \"y\" Int Nil)`." + ] + +rowListNil :: Declaration +rowListNil = primTypeOf (P.primSubName "RowList") "Nil" $ T.unlines + [ "The empty `RowList`." + ] + +rowToList :: Declaration +rowToList = primTypeOf (P.primSubName "RowList") "RowToList" $ T.unlines + [ "Compiler solved type class for generating a `RowList` from a closed row" + , "of types. Entries are sorted by label and duplicates are preserved in" + , "the order they appeared in the row." + ] + +symbolAppend :: Declaration +symbolAppend = primClassOf (P.primSubName "Symbol") "Append" $ T.unlines + [ "Compiler solved type class for appending `Symbol`s together." + ] + +symbolCompare :: Declaration +symbolCompare = primClassOf (P.primSubName "Symbol") "Compare" $ T.unlines + [ "Compiler solved type class for comparing two `Symbol`s." + , "Produces an `Ordering`." + ] + +symbolCons :: Declaration +symbolCons = primClassOf (P.primSubName "Symbol") "Cons" $ T.unlines + [ "Compiler solved type class for either splitting up a symbol into its" + , "head and tail or for combining a head and tail into a new symbol." + , "Requires the head to be a single character and the combined string" + , "cannot be empty." + ] + +fail :: Declaration +fail = primClassOf (P.primSubName "TypeError") "Fail" $ T.unlines + [ "The Fail type class is part of the custom type errors feature. To provide" + , "a custom type error when someone tries to use a particular instance," + , "write that instance out with a Fail constraint." + , "" + , "For more information, see" + , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." + ] + +warn :: Declaration +warn = primClassOf (P.primSubName "TypeError") "Warn" $ T.unlines + [ "The Warn type class allows a custom compiler warning to be displayed." + , "" + , "For more information, see" + , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." + ] + kindDoc :: Declaration kindDoc = primKindOf (P.primSubName "TypeError") "Doc" $ T.unlines [ "`Doc` is the kind of type-level documents." @@ -359,3 +480,4 @@ aboveDoc = primTypeOf (P.primSubName "TypeError") "Above" $ T.unlines , "For more information, see" , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." ] + diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 38f085f804..abb25bcaa8 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -16,7 +16,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Tree (Tree, rootLabel) import qualified Data.Graph as G -import Data.Foldable (toList) +import Data.Foldable (toList, fold) import Language.PureScript.Crash import Language.PureScript.Kinds @@ -96,7 +96,7 @@ instance A.ToJSON FunctionalDependency where -- | The initial environment with no values and only the default javascript types defined initEnvironment :: Environment -initEnvironment = Environment M.empty allPrimTypes M.empty M.empty M.empty allPrimClasses primKinds +initEnvironment = Environment M.empty allPrimTypes M.empty M.empty M.empty allPrimClasses allPrimKinds -- | A constructor for TypeClassData that computes which type class arguments are fully determined -- and argument covering sets. @@ -276,12 +276,26 @@ primSubKind sub = NamedKind . primSubName sub kindType :: Kind kindType = primKind C.typ +-- To make reading the kind signatures below easier +kindConstraint :: Kind +kindConstraint = kindType + +(-:>) :: Kind -> Kind -> Kind +(-:>) = FunKind +infixr 4 -:> + kindSymbol :: Kind kindSymbol = primKind C.symbol kindDoc :: Kind kindDoc = primSubKind C.typeError C.doc +kindOrdering :: Kind +kindOrdering = primSubKind C.moduleOrdering C.kindOrdering + +kindRowList :: Kind +kindRowList = primSubKind C.moduleRowList C.kindRowList + -- | Construct a type in the Prim module primTy :: Text -> Type primTy = TypeConstructor . primName @@ -334,58 +348,109 @@ isTypeOrApplied t1 t2 = t1 == t2 function :: Type -> Type -> Type function t1 = TypeApp (TypeApp tyFunction t1) --- | The primitive kinds +-- | Kinds in @Prim@ primKinds :: S.Set (Qualified (ProperName 'KindName)) -primKinds = - S.fromList - [ primName C.typ - , primName C.symbol - , primSubName C.typeError C.doc - ] +primKinds = S.fromList + [ primName C.typ + , primName C.symbol + ] + +-- | Kinds in @Prim.Ordering@ +primOrderingKinds :: S.Set (Qualified (ProperName 'KindName)) +primOrderingKinds = S.fromList + [ primSubName C.moduleOrdering C.kindOrdering + ] + +-- | Kinds in @Prim.RowList@ +primRowListKinds :: S.Set (Qualified (ProperName 'KindName)) +primRowListKinds = S.fromList + [ primSubName C.moduleRowList C.kindRowList + ] + +-- | Kinds in @Prim.TypeError@ +primTypeErrorKinds :: S.Set (Qualified (ProperName 'KindName)) +primTypeErrorKinds = S.fromList + [ primSubName C.typeError C.doc + ] + +-- | All primitive kinds +allPrimKinds :: S.Set (Qualified (ProperName 'KindName)) +allPrimKinds = fold + [ primKinds + , primOrderingKinds + , primRowListKinds + , primTypeErrorKinds + ] -- | The primitive types in the external javascript environment with their -- associated kinds. There are also pseudo `Fail`, `Warn`, and `Partial` types -- that correspond to the classes with the same names. primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) -primTypes = - M.fromList - [ (primName "Function", (FunKind kindType (FunKind kindType kindType), ExternData)) - , (primName "Array", (FunKind kindType kindType, ExternData)) - , (primName "Record", (FunKind (Row kindType) kindType, ExternData)) - , (primName "String", (kindType, ExternData)) - , (primName "Char", (kindType, ExternData)) - , (primName "Number", (kindType, ExternData)) - , (primName "Int", (kindType, ExternData)) - , (primName "Boolean", (kindType, ExternData)) - , (primName "Partial", (kindType, ExternData)) - ] +primTypes = M.fromList + [ (primName "Function", (kindType -:> kindType -:> kindType, ExternData)) + , (primName "Array", (kindType -:> kindType, ExternData)) + , (primName "Record", (Row kindType -:> kindType, ExternData)) + , (primName "String", (kindType, ExternData)) + , (primName "Char", (kindType, ExternData)) + , (primName "Number", (kindType, ExternData)) + , (primName "Int", (kindType, ExternData)) + , (primName "Boolean", (kindType, ExternData)) + , (primName "Partial", (kindConstraint, ExternData)) + ] -- | This 'Map' contains all of the prim types from all Prim modules. allPrimTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) allPrimTypes = M.unions [ primTypes - , primTypeErrorTypes + , primOrderingTypes , primRowTypes + , primRowListTypes + , primSymbolTypes + , primTypeErrorTypes ] -primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) -primTypeErrorTypes = +primOrderingTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +primOrderingTypes = M.fromList - [ (primSubName C.typeError "Fail", (FunKind kindDoc kindType, ExternData)) - , (primSubName C.typeError "Warn", (FunKind kindDoc kindType, ExternData)) - , (primSubName C.typeError "Text", (FunKind kindSymbol kindDoc, ExternData)) - , (primSubName C.typeError "Quote", (FunKind kindType kindDoc, ExternData)) - , (primSubName C.typeError "Beside", (FunKind kindDoc (FunKind kindDoc kindDoc), ExternData)) - , (primSubName C.typeError "Above", (FunKind kindDoc (FunKind kindDoc kindDoc), ExternData)) + [ (primSubName C.moduleOrdering "LT", (kindOrdering, ExternData)) + , (primSubName C.moduleOrdering "EQ", (kindOrdering, ExternData)) + , (primSubName C.moduleOrdering "GT", (kindOrdering, ExternData)) ] primRowTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) primRowTypes = M.fromList - [ (primSubName C.row "Union", (FunKind (Row kindType) (FunKind (Row kindType) (FunKind (Row kindType) kindType)), ExternData)) - , (primSubName C.row "Nub", (FunKind (Row kindType) (FunKind (Row kindType) kindType), ExternData)) - , (primSubName C.row "Lacks", (FunKind kindSymbol (FunKind (Row kindType) kindType), ExternData)) - , (primSubName C.row "Cons", (FunKind kindSymbol (FunKind kindType (FunKind (Row kindType) (FunKind (Row kindType) kindType))), ExternData)) + [ (primSubName C.moduleRow "Union", (Row kindType -:> Row kindType -:> Row kindType -:> kindConstraint, ExternData)) + , (primSubName C.moduleRow "Nub", (Row kindType -:> Row kindType -:> kindConstraint, ExternData)) + , (primSubName C.moduleRow "Lacks", (kindSymbol -:> Row kindType -:> kindConstraint, ExternData)) + , (primSubName C.moduleRow "Cons", (kindSymbol -:> kindType -:> Row kindType -:> Row kindType -:> kindConstraint, ExternData)) + ] + +primRowListTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +primRowListTypes = + M.fromList + [ (primSubName C.moduleRowList "Cons", (kindSymbol -:> kindType -:> kindRowList -:> kindRowList, ExternData)) + , (primSubName C.moduleRowList "Nil", (kindRowList, ExternData)) + , (primSubName C.moduleRowList "RowToList", (Row kindType -:> kindRowList -:> kindConstraint, ExternData)) + ] + +primSymbolTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +primSymbolTypes = + M.fromList + [ (primSubName C.moduleSymbol "Append", (kindSymbol -:> kindSymbol -:> kindSymbol -:> kindConstraint, ExternData)) + , (primSubName C.moduleSymbol "Compare", (kindSymbol -:> kindSymbol -:> kindOrdering -:> kindConstraint, ExternData)) + , (primSubName C.moduleSymbol "Cons", (kindSymbol -:> kindSymbol -:> kindSymbol -:> kindConstraint, ExternData)) + ] + +primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +primTypeErrorTypes = + M.fromList + [ (primSubName C.typeError "Fail", (kindDoc -:> kindConstraint, ExternData)) + , (primSubName C.typeError "Warn", (kindDoc -:> kindConstraint, ExternData)) + , (primSubName C.typeError "Text", (kindSymbol -:> kindDoc, ExternData)) + , (primSubName C.typeError "Quote", (kindType -:> kindDoc, ExternData)) + , (primSubName C.typeError "Beside", (kindDoc -:> kindDoc -:> kindDoc, ExternData)) + , (primSubName C.typeError "Above", (kindDoc -:> kindDoc -:> kindDoc, ExternData)) ] -- | The primitive class map. This just contains the `Partial` class. @@ -400,56 +465,108 @@ primClasses = allPrimClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData allPrimClasses = M.unions [ primClasses - , primTypeErrorClasses , primRowClasses + , primRowListClasses + , primSymbolClasses + , primTypeErrorClasses ] -primTypeErrorClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData -primTypeErrorClasses = - M.fromList - [ - -- class Fail (message :: Symbol) - (primSubName C.typeError "Fail", (makeTypeClassData [("message", Just kindDoc)] [] [] [])) - -- class Warn (message :: Symbol) - , (primSubName C.typeError "Warn", (makeTypeClassData [("message", Just kindDoc)] [] [] [])) - ] - primRowClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primRowClasses = M.fromList - [ -- class Union (left :: # Type) (right :: # Type) (union :: # Type) | left right -> union, right union -> left, union left -> right - (primSubName C.row "Union", (makeTypeClassData - [ ("left", Just (Row kindType)) - , ("right", Just (Row kindType)) - , ("union", Just (Row kindType)) - ] [] [] - [ FunctionalDependency [0, 1] [2] - , FunctionalDependency [1, 2] [0] - , FunctionalDependency [2, 0] [1] - ])) + [ (primSubName C.moduleRow "Union", makeTypeClassData + [ ("left", Just (Row kindType)) + , ("right", Just (Row kindType)) + , ("union", Just (Row kindType)) + ] [] [] + [ FunctionalDependency [0, 1] [2] + , FunctionalDependency [1, 2] [0] + , FunctionalDependency [2, 0] [1] + ]) + -- class Nub (original :: # Type) (nubbed :: # Type) | i -> o - , (primSubName C.row "Nub", (makeTypeClassData - [ ("original", Just (Row kindType)) - , ("nubbed", Just (Row kindType)) - ] [] [] - [ FunctionalDependency [0] [1] - ])) + , (primSubName C.moduleRow "Nub", makeTypeClassData + [ ("original", Just (Row kindType)) + , ("nubbed", Just (Row kindType)) + ] [] [] + [ FunctionalDependency [0] [1] + ]) + -- class Lacks (label :: Symbol) (row :: # Type) - , (primSubName C.row "Lacks", (makeTypeClassData - [ ("label", Just kindSymbol) - , ("row", Just (Row kindType)) - ] [] [] [])) + , (primSubName C.moduleRow "Lacks", makeTypeClassData + [ ("label", Just kindSymbol) + , ("row", Just (Row kindType)) + ] [] [] []) + -- class RowCons (label :: Symbol) (a :: Type) (tail :: # Type) (row :: # Type) | label tail a -> row, label row -> tail a - , (primSubName C.row "Cons", (makeTypeClassData - [ ("label", Just kindSymbol) - , ("a", Just kindType) - , ("tail", Just (Row kindType)) - , ("row", Just (Row kindType)) - ] [] [] - [ FunctionalDependency [0, 1, 2] [3] - , FunctionalDependency [0, 3] [1, 2] - ])) + , (primSubName C.moduleRow "Cons", makeTypeClassData + [ ("label", Just kindSymbol) + , ("a", Just kindType) + , ("tail", Just (Row kindType)) + , ("row", Just (Row kindType)) + ] [] [] + [ FunctionalDependency [0, 1, 2] [3] + , FunctionalDependency [0, 3] [1, 2] + ]) + ] + +primRowListClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primRowListClasses = + M.fromList + -- class RowToList (row :: # Type) (list :: RowList) | row -> list + [ (primSubName C.moduleRowList "RowToList", makeTypeClassData + [ ("row", Just (Row kindType)) + , ("list", Just kindRowList) + ] [] [] + [ FunctionalDependency [0] [1] + ]) + ] + +primSymbolClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primSymbolClasses = + M.fromList + -- class Append (left :: Symbol) (right :: Symbol) (appended :: Symbol) | left right -> appended, right appended -> left, appended left -> right + [ (primSubName C.moduleSymbol "Append", makeTypeClassData + [ ("left", Just kindSymbol) + , ("right", Just kindSymbol) + , ("appended", Just kindSymbol) + ] [] [] + [ FunctionalDependency [0, 1] [2] + , FunctionalDependency [1, 2] [0] + , FunctionalDependency [2, 0] [1] + ]) + + -- class Compare (left :: Symbol) (right :: Symbol) (ordering :: Ordering) | left right -> ordering + , (primSubName C.moduleSymbol "Compare", makeTypeClassData + [ ("left", Just kindSymbol) + , ("right", Just kindSymbol) + , ("ordering", Just kindOrdering) + ] [] [] + [ FunctionalDependency [0, 1] [2] + ]) + + -- class Cons (head :: Symbol) (tail :: Symbol) (symbol :: Symbol) | head tail -> symbol, symbol -> head tail + , (primSubName C.moduleSymbol "Cons", makeTypeClassData + [ ("head", Just kindSymbol) + , ("tail", Just kindSymbol) + , ("symbol", Just kindSymbol) + ] [] [] + [ FunctionalDependency [0, 1] [2] + , FunctionalDependency [2] [0, 1] + ]) + ] + +primTypeErrorClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primTypeErrorClasses = + M.fromList + -- class Fail (message :: Symbol) + [ (primSubName C.typeError "Fail", makeTypeClassData + [("message", Just kindDoc)] [] [] []) + + -- class Warn (message :: Symbol) + , (primSubName C.typeError "Warn", makeTypeClassData + [("message", Just kindDoc)] [] [] []) ] -- | Finds information about data constructors from the current environment. diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index 436e2565a5..1bd6e4896f 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -11,13 +11,22 @@ import Language.PureScript.Ide.Types idePrimDeclarations :: [(P.ModuleName, [IdeDeclarationAnn])] idePrimDeclarations = [ ( C.Prim - , mconcat [primTypes, primKinds, primClasses] + , mconcat [primTypes, primKinds, primClasses] + ) + , ( C.PrimOrdering + , mconcat [primOrderingTypes, primOrderingKinds] ) , ( C.PrimRow - , mconcat [primRowTypes, primRowClasses] + , mconcat [primRowTypes, primRowClasses] + ) + , ( C.PrimRowList + , mconcat [primRowListTypes, primRowListClasses, primRowListKinds] + ) + , ( C.PrimSymbol + , mconcat [primSymbolTypes, primSymbolClasses] ) , ( C.PrimTypeError - , mconcat [primTypeErrorTypes, primTypeErrorClasses] + , mconcat [primTypeErrorTypes, primTypeErrorClasses, primTypeErrorKinds] ) ] where @@ -28,12 +37,26 @@ idePrimDeclarations = IdeDeclarationAnn emptyAnn (IdeDeclTypeClass (IdeTypeClass (P.disqualify cn) P.kindType []) ) primTypes = annType PEnv.primTypes + primOrderingTypes = annType PEnv.primOrderingTypes primRowTypes = annType PEnv.primRowTypes + primRowListTypes = annType PEnv.primRowListTypes + primSymbolTypes = annType PEnv.primSymbolTypes primTypeErrorTypes = annType PEnv.primTypeErrorTypes primClasses = annClass PEnv.primClasses primRowClasses = annClass PEnv.primRowClasses + primRowListClasses = annClass PEnv.primRowListClasses + primSymbolClasses = annClass PEnv.primSymbolClasses primTypeErrorClasses = annClass PEnv.primTypeErrorClasses primKinds = foreach (Set.toList PEnv.primKinds) $ \kn -> IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) + + primOrderingKinds = foreach (Set.toList PEnv.primOrderingKinds) $ \kn -> + IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) + + primRowListKinds = foreach (Set.toList PEnv.primRowListKinds) $ \kn -> + IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) + + primTypeErrorKinds = foreach (Set.toList PEnv.primTypeErrorKinds) $ \kn -> + IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 1984471b2f..289ed4c964 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -48,8 +48,8 @@ createTemporaryModule exec st val = imports = psciImportedModules st lets = psciLetBindings st moduleName = P.ModuleName [P.ProperName "$PSCI"] - effModuleName = P.moduleNameFromString "Control.Monad.Eff" - effImport = (effModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Eff"])) + effModuleName = P.moduleNameFromString "Effect" + effImport = (effModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Effect"])) supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"])) eval = P.Var internalSpan (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval")) mainValue = P.App eval (P.Var internalSpan (P.Qualified Nothing (P.Ident "it"))) @@ -57,10 +57,8 @@ createTemporaryModule exec st val = typeDecl = P.TypeDeclaration (P.TypeDeclarationData (internalSpan, []) (P.Ident "$main") (P.TypeApp - (P.TypeApp - (P.TypeConstructor - (P.Qualified (Just (P.ModuleName [P.ProperName "$Eff"])) (P.ProperName "Eff"))) - (P.TypeWildcard internalSpan)) + (P.TypeConstructor + (P.Qualified (Just (P.ModuleName [P.ProperName "$Effect"])) (P.ProperName "Effect"))) (P.TypeWildcard internalSpan))) mainDecl = P.ValueDecl (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index a5918b6109..b0aa2b2ed6 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -42,7 +42,7 @@ sortModules ms = do toGraphNode mns m@(Module _ _ mn ds _) = do let deps = ordNub (mapMaybe usedModules ds) void . parU deps $ \(dep, pos) -> - when (dep `notElem` [C.Prim, C.PrimRow, C.PrimTypeError] && S.notMember dep mns) . + when (dep `notElem` [C.Prim, C.PrimOrdering, C.PrimRow, C.PrimRowList, C.PrimSymbol, C.PrimTypeError] && S.notMember dep mns) . throwError . addHint (ErrorInModule mn) . errorMessage' pos diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 7930547e6e..ad004f37c0 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -187,17 +187,35 @@ envModuleExports (_, _, exps) = exps primExports :: Exports primExports = mkPrimExports primTypes primClasses primKinds +-- | +-- The exported types from the @Prim.Ordering@ module +-- +primOrderingExports :: Exports +primOrderingExports = mkPrimExports primOrderingTypes mempty primOrderingKinds + -- | -- The exported types from the @Prim.Row@ module -- primRowExports :: Exports primRowExports = mkPrimExports primRowTypes primRowClasses mempty +-- | +-- The exported types from the @Prim.RowList@ module +-- +primRowListExports :: Exports +primRowListExports = mkPrimExports primRowListTypes primRowListClasses primRowListKinds + +-- | +-- The exported types from the @Prim.Symbol@ module +-- +primSymbolExports :: Exports +primSymbolExports = mkPrimExports primSymbolTypes primSymbolClasses mempty + -- | -- The exported types from the @Prim.TypeError@ module -- primTypeErrorExports :: Exports -primTypeErrorExports = mkPrimExports primTypeErrorTypes primTypeErrorClasses mempty +primTypeErrorExports = mkPrimExports primTypeErrorTypes primTypeErrorClasses primTypeErrorKinds -- | -- Create a set of exports for a Prim module. @@ -224,9 +242,18 @@ primEnv = M.fromList [ ( C.Prim , (internalModuleSourceSpan "", nullImports, primExports) ) + , ( C.PrimOrdering + , (internalModuleSourceSpan "", nullImports, primOrderingExports) + ) , ( C.PrimRow , (internalModuleSourceSpan "", nullImports, primRowExports) ) + , ( C.PrimRowList + , (internalModuleSourceSpan "", nullImports, primRowListExports) + ) + , ( C.PrimSymbol + , (internalModuleSourceSpan "", nullImports, primSymbolExports) + ) , ( C.PrimTypeError , (internalModuleSourceSpan "", nullImports, primTypeErrorExports) ) diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 63d6035b35..a6c80750b7 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -51,6 +51,8 @@ desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModu mconcat [ M.mapKeys (qualify (ModuleName [ProperName C.prim])) primClasses , M.mapKeys (qualify C.PrimRow) primRowClasses + , M.mapKeys (qualify C.PrimRowList) primRowListClasses + , M.mapKeys (qualify C.PrimSymbol) primSymbolClasses , M.mapKeys (qualify C.PrimTypeError) primTypeErrorClasses , M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) ] diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index dd8fe33da5..0cf77a6d44 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -52,9 +52,9 @@ data Evidence -- | Computed instances | WarnInstance Type -- ^ Warn type class with a user-defined warning message | IsSymbolInstance PSString -- ^ The IsSymbol type class for a given Symbol literal - | CompareSymbolInstance - | ConsSymbolInstance - | AppendSymbolInstance + | SymbolCompareInstance + | SymbolConsInstance + | SymbolAppendInstance | UnionInstance | ConsInstance | NubInstance @@ -173,12 +173,12 @@ entails SolverOptions{..} constraint context hints = -- This allows us to defer a warning by propagating the constraint. findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope [] 0 (WarnInstance msg) [] C.Warn [msg] Nothing] forClassName _ C.IsSymbol args | Just dicts <- solveIsSymbol args = dicts - forClassName _ C.CompareSymbol args | Just dicts <- solveCompareSymbol args = dicts - forClassName _ C.AppendSymbol args | Just dicts <- solveAppendSymbol args = dicts - forClassName _ C.ConsSymbol args | Just dicts <- solveConsSymbol args = dicts - forClassName _ C.Union args | Just dicts <- solveUnion args = dicts - forClassName _ C.Nub args | Just dicts <- solveNub args = dicts - forClassName _ C.Lacks args | Just dicts <- solveLacks args = dicts + forClassName _ C.SymbolCompare args | Just dicts <- solveSymbolCompare args = dicts + forClassName _ C.SymbolAppend args | Just dicts <- solveSymbolAppend args = dicts + forClassName _ C.SymbolCons args | Just dicts <- solveSymbolCons args = dicts + forClassName _ C.RowUnion args | Just dicts <- solveUnion args = dicts + forClassName _ C.RowNub args | Just dicts <- solveNub args = dicts + forClassName _ C.RowLacks args | Just dicts <- solveLacks args = dicts forClassName _ C.RowCons args | Just dicts <- solveRowCons args = dicts forClassName _ C.RowToList args | Just dicts <- solveRowToList args = dicts forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) @@ -361,12 +361,9 @@ entails SolverOptions{..} constraint context hints = mkDictionary (IsSymbolInstance sym) _ = let fields = [ ("reflectSymbol", Abs (VarBinder nullSourceSpan UnusedIdent) (Literal nullSourceSpan (StringLiteral sym))) ] in return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal nullSourceSpan (ObjectLiteral fields)) - mkDictionary CompareSymbolInstance _ = - return $ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal nullSourceSpan (ObjectLiteral [])) - mkDictionary ConsSymbolInstance _ = - return $ TypeClassDictionaryConstructorApp C.ConsSymbol (Literal nullSourceSpan (ObjectLiteral [])) - mkDictionary AppendSymbolInstance _ = - return $ TypeClassDictionaryConstructorApp C.AppendSymbol (Literal nullSourceSpan (ObjectLiteral [])) + mkDictionary SymbolCompareInstance _ = return valUndefined + mkDictionary SymbolConsInstance _ = return valUndefined + mkDictionary SymbolAppendInstance _ = return valUndefined -- Turn a DictionaryValue into a Expr subclassDictionaryValue :: Expr -> Qualified (ProperName 'ClassName) -> Integer -> Expr @@ -377,22 +374,22 @@ entails SolverOptions{..} constraint context hints = solveIsSymbol [TypeLevelString sym] = Just [TypeClassDictionaryInScope [] 0 (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing] solveIsSymbol _ = Nothing - solveCompareSymbol :: [Type] -> Maybe [TypeClassDict] - solveCompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = + solveSymbolCompare :: [Type] -> Maybe [TypeClassDict] + solveSymbolCompare [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = let ordering = case compare lhs rhs of LT -> C.orderingLT EQ -> C.orderingEQ GT -> C.orderingGT args' = [arg0, arg1, TypeConstructor ordering] - in Just [TypeClassDictionaryInScope [] 0 CompareSymbolInstance [] C.CompareSymbol args' Nothing] - solveCompareSymbol _ = Nothing + in Just [TypeClassDictionaryInScope [] 0 SymbolCompareInstance [] C.SymbolCompare args' Nothing] + solveSymbolCompare _ = Nothing - solveAppendSymbol :: [Type] -> Maybe [TypeClassDict] - solveAppendSymbol [arg0, arg1, arg2] = do + solveSymbolAppend :: [Type] -> Maybe [TypeClassDict] + solveSymbolAppend [arg0, arg1, arg2] = do (arg0', arg1', arg2') <- appendSymbols arg0 arg1 arg2 let args' = [arg0', arg1', arg2'] - pure [TypeClassDictionaryInScope [] 0 AppendSymbolInstance [] C.AppendSymbol args' Nothing] - solveAppendSymbol _ = Nothing + pure [TypeClassDictionaryInScope [] 0 SymbolAppendInstance [] C.SymbolAppend args' Nothing] + solveSymbolAppend _ = Nothing -- | Append type level symbols, or, run backwards, strip a prefix or suffix appendSymbols :: Type -> Type -> Type -> Maybe (Type, Type, Type) @@ -409,12 +406,12 @@ entails SolverOptions{..} constraint context hints = pure (TypeLevelString (mkString lhs), arg1, arg2) appendSymbols _ _ _ = Nothing - solveConsSymbol :: [Type] -> Maybe [TypeClassDict] - solveConsSymbol [arg0, arg1, arg2] = do + solveSymbolCons :: [Type] -> Maybe [TypeClassDict] + solveSymbolCons [arg0, arg1, arg2] = do (arg0', arg1', arg2') <- consSymbol arg0 arg1 arg2 let args' = [arg0', arg1', arg2'] - pure [TypeClassDictionaryInScope [] 0 ConsSymbolInstance [] C.ConsSymbol args' Nothing] - solveConsSymbol _ = Nothing + pure [TypeClassDictionaryInScope [] 0 SymbolConsInstance [] C.SymbolCons args' Nothing] + solveSymbolCons _ = Nothing consSymbol :: Type -> Type -> Type -> Maybe (Type, Type, Type) consSymbol _ _ arg@(TypeLevelString s) = do @@ -431,7 +428,7 @@ entails SolverOptions{..} constraint context hints = solveUnion :: [Type] -> Maybe [TypeClassDict] solveUnion [l, r, u] = do (lOut, rOut, uOut, cst) <- unionRows l r u - pure [ TypeClassDictionaryInScope [] 0 UnionInstance [] C.Union [lOut, rOut, uOut] cst ] + pure [ TypeClassDictionaryInScope [] 0 UnionInstance [] C.RowUnion [lOut, rOut, uOut] cst ] solveUnion _ = Nothing -- | Left biased union of two row types @@ -454,7 +451,7 @@ entails SolverOptions{..} constraint context hints = -- Otherwise, the left hand tail might contain the same labels as on -- the right hand side, and we can't be certain we won't reorder the -- types for such labels. - _ -> (not (null fixed), (fixed, rowVar), Just [ Constraint C.Union [rest, r, rowVar] Nothing ]) + _ -> (not (null fixed), (fixed, rowVar), Just [ Constraint C.RowUnion [rest, r, rowVar] Nothing ]) solveRowCons :: [Type] -> Maybe [TypeClassDict] solveRowCons [TypeLevelString sym, ty, r, _] = @@ -482,7 +479,7 @@ entails SolverOptions{..} constraint context hints = solveNub :: [Type] -> Maybe [TypeClassDict] solveNub [r, _] = do r' <- nubRows r - pure [ TypeClassDictionaryInScope [] 0 NubInstance [] C.Nub [r, r'] Nothing ] + pure [ TypeClassDictionaryInScope [] 0 NubInstance [] C.RowNub [r, r'] Nothing ] solveNub _ = Nothing nubRows :: Type -> Maybe Type @@ -495,7 +492,7 @@ entails SolverOptions{..} constraint context hints = solveLacks :: [Type] -> Maybe [TypeClassDict] solveLacks [TypeLevelString sym, r] = do (r', cst) <- rowLacks sym r - pure [ TypeClassDictionaryInScope [] 0 LacksInstance [] C.Lacks [TypeLevelString sym, r'] cst ] + pure [ TypeClassDictionaryInScope [] 0 LacksInstance [] C.RowLacks [TypeLevelString sym, r'] cst ] solveLacks _ = Nothing rowLacks :: PSString -> Type -> Maybe (Type, Maybe [Constraint]) @@ -509,7 +506,7 @@ entails SolverOptions{..} constraint context hints = (canMakeProgress, cst) = case rest of REmpty -> (True, Nothing) - _ -> (not (null fixed), Just [ Constraint C.Lacks [TypeLevelString sym, rest] Nothing ]) + _ -> (not (null fixed), Just [ Constraint C.RowLacks [TypeLevelString sym, rest] Nothing ]) -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index b7c81966da..e03a0aaaab 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -62,7 +62,7 @@ preludeImport, arrayImport, listImport, consoleImport, maybeImport :: Import preludeImport = testParseImport "import Prelude" arrayImport = testParseImport "import Data.Array (head, cons)" listImport = testParseImport "import Data.List as List" -consoleImport = testParseImport "import Control.Monad.Eff.Console (log) as Console" +consoleImport = testParseImport "import Effect.Console (log) as Console" maybeImport = testParseImport "import Data.Maybe (Maybe(Just))" spec :: Spec @@ -103,7 +103,7 @@ spec = do it "pretty prints a qualified import" $ shouldBe (prettyPrintImport' listImport) "import Data.List as List" it "pretty prints a qualified explicit import" $ - shouldBe (prettyPrintImport' consoleImport) "import Control.Monad.Eff.Console (log) as Console" + shouldBe (prettyPrintImport' consoleImport) "import Effect.Console (log) as Console" it "pretty prints an import with a datatype (and PositionedRef's for the dtors)" $ shouldBe (prettyPrintImport' maybeImport) "import Data.Maybe (Maybe(Just))" diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index ca691e5a8a..1eb68d50e8 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -19,8 +19,14 @@ main = do putStrLn "Test that Prim is fully documented" let actualPrimNames = -- note that prim type classes are listed in P.primTypes - (map (P.runProperName . P.disqualify . fst) $ Map.toList (P.primTypes <> P.primTypeErrorTypes <> P.primRowTypes)) ++ - (map (P.runProperName . P.disqualify) $ Set.toList P.primKinds) + (map (P.runProperName . P.disqualify . fst) $ Map.toList + ( P.primTypes <> + P.primOrderingTypes <> + P.primRowTypes <> + P.primRowListTypes <> + P.primTypeErrorTypes <> + P.primSymbolTypes )) ++ + (map (P.runProperName . P.disqualify) $ Set.toList P.allPrimKinds) let documentedPrimNames = map D.declTitle (concatMap D.modDeclarations D.primModules) let undocumentedNames = actualPrimNames \\ documentedPrimNames diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index d71bec59e3..c513cb4c93 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -34,12 +34,12 @@ completionTestData supportModuleNames = , (":b", [":browse"]) -- :browse should complete module names - , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref", ".Ref.Unsafe"]) - , (":b Control.Monad.Eff.", map (":b Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref", ".Ref.Unsafe"]) + , (":b Eff", map (":b Effect" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref"]) + , (":b Effect.", map (":b Effect" ++) [".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref"]) -- import should complete module names - , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref", ".Ref.Unsafe"]) - , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref", ".Ref.Unsafe"]) + , ("import Eff", map ("import Effect" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref"]) + , ("import Effect.", map ("import Effect" ++) [".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref"]) -- :quit, :help, :reload, :clear should not complete , (":help ", []) @@ -55,13 +55,14 @@ completionTestData supportModuleNames = , (":type uni", [":type unit"]) , (":type E", [":type EQ"]) , (":type P.", map (":type P." ++) ["EQ", "GT", "LT", "unit"]) -- import Prelude (unit, Ordering(..)) as P - , (":type Control.Monad.Eff.Console.lo", []) + , (":type Effect.Console.lo", []) , (":type voi", []) -- :kind should complete next word from types in scope , (":kind Str", [":kind String"]) - , (":kind ST.", [":kind ST.ST", ":kind ST.STRef"]) -- import Control.Monad.ST as ST - , (":kind Control.Monad.Eff.", []) + , (":kind ST.", [":kind ST.ST"]) -- import Control.Monad.ST as ST + , (":kind STRef.", [":kind STRef.STRef"]) -- import Control.Monad.ST.Ref as STRef + , (":kind Effect.", []) -- Only one argument for these directives should be completed , (":show import ", []) @@ -86,7 +87,7 @@ completionTestData supportModuleNames = , ("P.G", ["P.GT"]) , ("P.uni", ["P.unit"]) , ("voi", []) -- import Prelude hiding (void) - , ("Control.Monad.Eff.Class.", []) + , ("Effect.Class.", []) -- complete first name after type annotation symbol , ("1 :: I", ["1 :: Int"]) @@ -116,6 +117,10 @@ getPSCiStateForCompletion = do (qualName "Control.Monad.ST" ,P.Implicit ,Just (qualName "ST")) + , -- import Control.Monad.ST.Ref as STRef + (qualName "Control.Monad.ST.Ref" + ,P.Implicit + ,Just (qualName "STRef")) -- import Prelude hiding (void) ,(qualName "Prelude" ,P.Hiding [valName "void"] diff --git a/tests/support/bower.json b/tests/support/bower.json index 9b5b342e07..0b7bc52aa5 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -1,47 +1,79 @@ { "name": "purescript-test-suite-support", "dependencies": { - "purescript-arrays": "4.1.2", - "purescript-assert": "3.0.0", - "purescript-bifunctors": "3.0.0", - "purescript-console": "3.0.0", - "purescript-control": "3.3.0", - "purescript-distributive": "3.0.0", - "purescript-eff": "3.1.0", - "purescript-either": "3.1.0", - "purescript-foldable-traversable": "3.4.0", - "purescript-functions": "3.0.0", - "purescript-gen": "1.1.0", - "purescript-generics": "4.0.0", - "purescript-generics-rep": "5.1.0", - "purescript-globals": "3.0.0", - "purescript-identity": "3.1.0", - "purescript-integers": "3.1.0", - "purescript-invariant": "3.0.0", - "purescript-lazy": "3.0.0", + "purescript-arrays": "purescript/purescript-arrays#compiler/0.12", + "purescript-assert": "purescript/purescript-assert#compiler/0.12", + "purescript-bifunctors": "purescript/purescript-bifunctors#compiler/0.12", + "purescript-console": "purescript/purescript-console#compiler/0.12", + "purescript-control": "purescript/purescript-control#compiler/0.12", + "purescript-distributive": "purescript/purescript-distributive#compiler/0.12", + "purescript-effect": "purescript/purescript-effect#compiler/0.12", + "purescript-either": "purescript/purescript-either#compiler/0.12", + "purescript-foldable-traversable": "purescript/purescript-foldable-traversable#compiler/0.12", + "purescript-functions": "purescript/purescript-functions#compiler/0.12", + "purescript-gen": "purescript/purescript-gen#compiler/0.12", + "purescript-generics-rep": "purescript/purescript-generics-rep#compiler/0.12", + "purescript-globals": "purescript/purescript-globals#compiler/0.12", + "purescript-identity": "purescript/purescript-identity#compiler/0.12", + "purescript-integers": "purescript/purescript-integers#compiler/0.12", + "purescript-invariant": "purescript/purescript-invariant#compiler/0.12", + "purescript-lazy": "purescript/purescript-lazy#compiler/0.12", "purescript-lists": "purescript/purescript-lists#compiler/0.12", - "purescript-math": "2.1.0", - "purescript-maybe": "3.0.0", - "purescript-monoid": "3.1.0", - "purescript-newtype": "2.0.0", - "purescript-nonempty": "4.0.0", - "purescript-partial": "1.2.1", - "purescript-prelude": "3.1.0", - "purescript-proxy": "2.1.0", + "purescript-math": "purescript/purescript-math#compiler/0.12", + "purescript-maybe": "purescript/purescript-maybe#compiler/0.12", + "purescript-newtype": "purescript/purescript-newtype#compiler/0.12", + "purescript-nonempty": "purescript/purescript-nonempty#compiler/0.12", + "purescript-partial": "purescript/purescript-partial#compiler/0.12", + "purescript-prelude": "purescript/purescript-prelude#compiler/0.12", + "purescript-proxy": "purescript/purescript-proxy#compiler/0.12", "purescript-psci-support": "purescript/purescript-psci-support#compiler/0.12", - "purescript-refs": "3.0.0", - "purescript-st": "3.0.0", - "purescript-strings": "3.3.0", + "purescript-refs": "purescript/purescript-refs#compiler/0.12", + "purescript-st": "purescript/purescript-st#compiler/0.12", + "purescript-strings": "purescript/purescript-strings#compiler/0.12", "purescript-symbols": "purescript/purescript-symbols#compiler/0.12", - "purescript-tailrec": "3.3.0", - "purescript-tuples": "4.1.0", - "purescript-type-equality": "2.1.0", + "purescript-tailrec": "purescript/purescript-tailrec#compiler/0.12", + "purescript-tuples": "purescript/purescript-tuples#compiler/0.12", + "purescript-type-equality": "purescript/purescript-type-equality#compiler/0.12", "purescript-typelevel-prelude": "purescript/purescript-typelevel-prelude#compiler/0.12", - "purescript-unfoldable": "3.0.0", - "purescript-unsafe-coerce": "3.0.0" + "purescript-unfoldable": "purescript/purescript-unfoldable#compiler/0.12", + "purescript-unsafe-coerce": "purescript/purescript-unsafe-coerce#compiler/0.12" }, "resolutions": { + "purescript-arrays": "compiler/0.12", + "purescript-assert": "compiler/0.12", + "purescript-bifunctors": "compiler/0.12", + "purescript-console": "compiler/0.12", + "purescript-control": "compiler/0.12", + "purescript-distributive": "compiler/0.12", + "purescript-effect": "compiler/0.12", + "purescript-either": "compiler/0.12", + "purescript-foldable-traversable": "compiler/0.12", + "purescript-functions": "compiler/0.12", + "purescript-gen": "compiler/0.12", + "purescript-generics-rep": "compiler/0.12", + "purescript-globals": "compiler/0.12", + "purescript-identity": "compiler/0.12", + "purescript-integers": "compiler/0.12", + "purescript-invariant": "compiler/0.12", + "purescript-lazy": "compiler/0.12", + "purescript-lists": "compiler/0.12", + "purescript-math": "compiler/0.12", + "purescript-maybe": "compiler/0.12", + "purescript-newtype": "compiler/0.12", + "purescript-nonempty": "compiler/0.12", + "purescript-partial": "compiler/0.12", + "purescript-prelude": "compiler/0.12", + "purescript-proxy": "compiler/0.12", + "purescript-psci-support": "compiler/0.12", + "purescript-refs": "compiler/0.12", + "purescript-st": "compiler/0.12", + "purescript-strings": "compiler/0.12", "purescript-symbols": "compiler/0.12", - "purescript-lists": "compiler/0.12" + "purescript-tailrec": "compiler/0.12", + "purescript-tuples": "compiler/0.12", + "purescript-type-equality": "compiler/0.12", + "purescript-typelevel-prelude": "compiler/0.12", + "purescript-unfoldable": "compiler/0.12", + "purescript-unsafe-coerce": "compiler/0.12" } } From 3d62184cd65402d1a23ac6c26bef6ce97c917d48 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 24 Apr 2018 13:59:24 +0100 Subject: [PATCH 0968/1580] Add real error messages for associativity errors (#3315) * Add real error messages for associativity errors * Factor out repeated code for position annotations * Use a less artificial `MixedAssociativityError` test --- examples/failing/MixedAssociativityError.purs | 6 ++ examples/failing/NonAssociativeError.purs | 8 ++ src/Language/PureScript/AST/Declarations.hs | 2 + src/Language/PureScript/Errors.hs | 23 ++++++ src/Language/PureScript/Names.hs | 5 +- src/Language/PureScript/Sugar/Operators.hs | 12 +-- .../PureScript/Sugar/Operators/Binders.hs | 9 +- .../PureScript/Sugar/Operators/Common.hs | 82 ++++++++++++++++--- .../PureScript/Sugar/Operators/Expr.hs | 8 +- .../PureScript/Sugar/Operators/Types.hs | 8 +- 10 files changed, 140 insertions(+), 23 deletions(-) create mode 100644 examples/failing/MixedAssociativityError.purs create mode 100644 examples/failing/NonAssociativeError.purs diff --git a/examples/failing/MixedAssociativityError.purs b/examples/failing/MixedAssociativityError.purs new file mode 100644 index 0000000000..db583c5478 --- /dev/null +++ b/examples/failing/MixedAssociativityError.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith MixedAssociativityError +module Main where + +import Prelude + +feq f x y = f <$> x == f <$> y diff --git a/examples/failing/NonAssociativeError.purs b/examples/failing/NonAssociativeError.purs new file mode 100644 index 0000000000..6958c6055b --- /dev/null +++ b/examples/failing/NonAssociativeError.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith NonAssociativeError +-- @shouldFailWith NonAssociativeError +module Main where + +import Prelude + +a = true == true == true +b = true == false /= true diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index ac15e46bf1..9f2636dac5 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -174,6 +174,8 @@ data SimpleErrorMessage -- | a declaration couldn't be used because it contained free variables | UnusableDeclaration Ident [[Text]] | CannotDefinePrimModules ModuleName + | MixedAssociativityError (NEL.NonEmpty (Qualified (OpName 'AnyOpName), Associativity)) + | NonAssociativeError (NEL.NonEmpty (Qualified (OpName 'AnyOpName))) deriving (Show) -- | Error message hints, providing more detailed information about failure. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index ab049884e2..e65d0214f7 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -180,6 +180,8 @@ errorCode em = case unwrapErrorMessage em of UserDefinedWarning{} -> "UserDefinedWarning" UnusableDeclaration{} -> "UnusableDeclaration" CannotDefinePrimModules{} -> "CannotDefinePrimModules" + MixedAssociativityError{} -> "MixedAssociativityError" + NonAssociativeError{} -> "NonAssociativeError" -- | A stack trace for an error newtype MultipleErrors = MultipleErrors @@ -997,6 +999,27 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , line $ "The Prim namespace is reserved for compiler-defined terms." ] + renderSimpleErrorMessage (MixedAssociativityError opsWithAssoc) = + paras + [ line "Cannot parse an expression that uses operators of the same precedence but mixed associativity:" + , indent $ paras $ map (\(name, assoc) -> line $ markCode (showQualified showOp name) <> " is " <> markCode (T.pack (showAssoc assoc))) (NEL.toList opsWithAssoc) + , line "Use parentheses to resolve this ambiguity." + ] + + renderSimpleErrorMessage (NonAssociativeError ops) = + if NEL.length ops == 1 + then + paras + [ line $ "Cannot parse an expression that uses multiple instances of the non-associative operator " <> markCode (showQualified showOp (NEL.head ops)) <> "." + , line "Use parentheses to resolve this ambiguity." + ] + else + paras + [ line "Cannot parse an expression that uses multiple non-associative operators of the same precedence:" + , indent $ paras $ map (line . markCode . showQualified showOp) (NEL.toList ops) + , line "Use parentheses to resolve this ambiguity." + ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 77c927d49a..1df6c12c42 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -121,7 +121,10 @@ showOp op = "(" <> runOpName op <> ")" -- | -- The closed set of operator alias types. -- -data OpNameType = ValueOpName | TypeOpName +data OpNameType = ValueOpName | TypeOpName | AnyOpName + +eraseOpName :: OpName a -> OpName 'AnyOpName +eraseOpName = OpName . runOpName -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 99071c1aa1..bbd6489d6a 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -197,19 +197,13 @@ rebracketModule pred_ valueOpTable typeOpTable (Module ss coms mn ds exts) = (f, _, _) = everywhereOnValuesTopDownM goDecl - (goExpr <=< decontextify goExpr') - (goBinder <=< decontextify goBinder') + (matchExprOperators valueOpTable <=< decontextify goExpr') + (matchBinderOperators valueOpTable <=< decontextify goBinder') (goDecl, goExpr', goBinder') = updateTypes (const goType) - goExpr :: Expr -> m Expr - goExpr = return . matchExprOperators valueOpTable - - goBinder :: Binder -> m Binder - goBinder = return . matchBinderOperators valueOpTable - goType :: Type -> m Type - goType = return . matchTypeOperators typeOpTable + goType = matchTypeOperators typeOpTable decontextify :: (Maybe SourceSpan -> a -> m (Maybe SourceSpan, a)) -> a -> m a decontextify ctxf = fmap snd . ctxf Nothing diff --git a/src/Language/PureScript/Sugar/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs index 8906703c03..c3f54e7384 100644 --- a/src/Language/PureScript/Sugar/Operators/Binders.hs +++ b/src/Language/PureScript/Sugar/Operators/Binders.hs @@ -2,11 +2,18 @@ module Language.PureScript.Sugar.Operators.Binders where import Prelude.Compat +import Control.Monad.Except + import Language.PureScript.AST +import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Sugar.Operators.Common -matchBinderOperators :: [[(Qualified (OpName 'ValueOpName), Associativity)]] -> Binder -> Binder +matchBinderOperators + :: MonadError MultipleErrors m + => [[(Qualified (OpName 'ValueOpName), Associativity)]] + -> Binder + -> m Binder matchBinderOperators = matchOperators isBinOp extractOp fromOp reapply id where diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index 34201404d4..5cf68517da 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -3,8 +3,14 @@ module Language.PureScript.Sugar.Operators.Common where import Prelude.Compat import Control.Monad.State +import Control.Monad.Except +import Data.Either (rights) import Data.Functor.Identity +import Data.List (sortOn) +import Data.Maybe (mapMaybe, fromJust) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as M import qualified Text.Parsec as P import qualified Text.Parsec.Pos as P @@ -12,6 +18,7 @@ import qualified Text.Parsec.Expr as P import Language.PureScript.AST import Language.PureScript.Crash +import Language.PureScript.Errors import Language.PureScript.Names type Chain a = [Either a a] @@ -53,8 +60,9 @@ opTable ops fromOp reapply = map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >>= \ss -> return (reapply ss name)) (toAssoc a))) ops matchOperators - :: forall a nameType + :: forall m a nameType . Show a + => MonadError MultipleErrors m => (a -> Bool) -> (a -> Maybe (a, a, a)) -> FromOp nameType a @@ -62,21 +70,75 @@ matchOperators -> ([[P.Operator (Chain a) () Identity a]] -> P.OperatorTable (Chain a) () Identity a) -> [[(Qualified (OpName nameType), Associativity)]] -> a - -> a + -> m a matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains where - parseChains :: a -> a + parseChains :: a -> m a parseChains ty | True <- isBinOp ty = bracketChain (extendChain ty) - | otherwise = ty + | otherwise = pure ty extendChain :: a -> Chain a extendChain ty | Just (op, l, r) <- extractOp ty = Left l : Right op : extendChain r | otherwise = [Left ty] - bracketChain :: Chain a -> a - bracketChain = - either - (\_ -> internalError "matchTypeOperators: cannot reorder operators") - id - . P.parse opParser "operator expression" + bracketChain :: Chain a -> m a + bracketChain chain = + case P.parse opParser "operator expression" chain of + Right a -> pure a + Left _ -> throwError . MultipleErrors $ mkErrors chain + opParser :: P.Parsec (Chain a) () a opParser = P.buildExpressionParser (modOpTable (opTable ops fromOp reapply)) parseValue <* P.eof + + -- Generating a good error message involves a bit of work here, as the parser + -- can't provide one for us. + -- + -- We examine the expression chain, plucking out the operators and then + -- grouping them by shared precedence, then if any of the following conditions + -- are met, we have something to report: + -- 1. any of the groups have mixed associativity + -- 2. there is more than one occurance of a non-associative operator in a + -- precedence group + mkErrors :: Chain a -> [ErrorMessage] + mkErrors chain = + let + opInfo :: M.Map (Qualified (OpName nameType)) (Integer, Associativity) + opInfo = M.fromList $ concatMap (\(n, o) -> map (\(name, assoc) -> (name, (n, assoc))) o) (zip [0..] ops) + opPrec :: Qualified (OpName nameType) -> Integer + opPrec = fromJust . fmap fst . flip M.lookup opInfo + opAssoc :: Qualified (OpName nameType) -> Associativity + opAssoc = fromJust . fmap snd . flip M.lookup opInfo + chainOpSpans :: M.Map (Qualified (OpName nameType)) (NEL.NonEmpty SourceSpan) + chainOpSpans = foldr (\(ss, name) -> M.alter (Just . maybe (pure ss) (NEL.cons ss)) name) M.empty . mapMaybe fromOp $ rights chain + opUsages :: Qualified (OpName nameType) -> Int + opUsages = maybe 0 NEL.length . flip M.lookup chainOpSpans + precGrouped :: [NEL.NonEmpty (Qualified (OpName nameType))] + precGrouped = NEL.groupWith opPrec . sortOn opPrec $ M.keys chainOpSpans + assocGrouped :: [NEL.NonEmpty (NEL.NonEmpty (Qualified (OpName nameType)))] + assocGrouped = fmap (NEL.groupWith1 opAssoc . NEL.sortWith opAssoc) precGrouped + mixedAssoc :: [NEL.NonEmpty (Qualified (OpName nameType))] + mixedAssoc = fmap join . filter (\precGroup -> NEL.length precGroup > 1) $ assocGrouped + nonAssoc :: [NEL.NonEmpty (Qualified (OpName nameType))] + nonAssoc = join $ fmap (NEL.filter (\assocGroup -> opAssoc (NEL.head assocGroup) == Infix && sum (fmap opUsages assocGroup) > 1)) assocGrouped + in + if null (nonAssoc ++ mixedAssoc) + then internalError "matchOperators: cannot reorder operators" + else + map + (\grp -> + mkPositionedError chainOpSpans grp + (MixedAssociativityError (fmap (\name -> (eraseOpName <$> name, opAssoc name)) grp))) + mixedAssoc + ++ map + (\grp -> + mkPositionedError chainOpSpans grp + (NonAssociativeError (fmap (fmap eraseOpName) grp))) + nonAssoc + + mkPositionedError + :: M.Map (Qualified (OpName nameType)) (NEL.NonEmpty SourceSpan) + -> NEL.NonEmpty (Qualified (OpName nameType)) + -> SimpleErrorMessage + -> ErrorMessage + mkPositionedError chainOpSpans grp = + ErrorMessage + [PositionedError (join . fmap (fromJust . flip M.lookup chainOpSpans) $ grp)] diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index 99a0731e24..d01c89e521 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -2,6 +2,7 @@ module Language.PureScript.Sugar.Operators.Expr where import Prelude.Compat +import Control.Monad.Except import Data.Functor.Identity import qualified Text.Parsec as P @@ -10,8 +11,13 @@ import qualified Text.Parsec.Expr as P import Language.PureScript.AST import Language.PureScript.Names import Language.PureScript.Sugar.Operators.Common +import Language.PureScript.Errors -matchExprOperators :: [[(Qualified (OpName 'ValueOpName), Associativity)]] -> Expr -> Expr +matchExprOperators + :: MonadError MultipleErrors m + => [[(Qualified (OpName 'ValueOpName), Associativity)]] + -> Expr + -> m Expr matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable where diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs index a4ef1f8848..3c730651f9 100644 --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -2,13 +2,19 @@ module Language.PureScript.Sugar.Operators.Types where import Prelude.Compat +import Control.Monad.Except import Language.PureScript.AST import Language.PureScript.Crash +import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Sugar.Operators.Common import Language.PureScript.Types -matchTypeOperators :: [[(Qualified (OpName 'TypeOpName), Associativity)]] -> Type -> Type +matchTypeOperators + :: MonadError MultipleErrors m + => [[(Qualified (OpName 'TypeOpName), Associativity)]] + -> Type + -> m Type matchTypeOperators = matchOperators isBinOp extractOp fromOp reapply id where From fcf793ee909effaf7d7529cb020e8fa7cf466f4c Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 24 Apr 2018 22:10:25 +0100 Subject: [PATCH 0969/1580] Add positions for `ScopeConflict` caused by exports (#3318) * Add positions for `ScopeConflict` caused by exports * Use specific `ModuleRef`s for error positions --- src/Language/PureScript/Sugar/Names.hs | 2 +- src/Language/PureScript/Sugar/Names/Env.hs | 13 ++++++------ .../PureScript/Sugar/Names/Exports.hs | 21 ++++++++++--------- 3 files changed, 19 insertions(+), 17 deletions(-) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index ca1ee4cb29..fd59624d1c 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -396,7 +396,7 @@ renameInModule imports (Module modSS coms mn decls exps) = -- re-exports. If there are multiple options for the name to resolve to -- in scope, we throw an error. (Just options, _) -> do - (mnNew, mnOrig) <- checkImportConflicts mn toName options + (mnNew, mnOrig) <- checkImportConflicts pos mn toName options modify $ \usedImports -> M.insertWith (++) mnNew [fmap toName qname] usedImports return $ Qualified (Just mnOrig) name diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index ad004f37c0..88eda55f8f 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -220,7 +220,7 @@ primTypeErrorExports = mkPrimExports primTypeErrorTypes primTypeErrorClasses pri -- | -- Create a set of exports for a Prim module. -- -mkPrimExports +mkPrimExports :: M.Map (Qualified (ProperName 'TypeName)) a -> M.Map (Qualified (ProperName 'ClassName)) b -> S.Set (Qualified (ProperName 'KindName)) @@ -454,11 +454,12 @@ getExports env mn = checkImportConflicts :: forall m a . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => ModuleName + => SourceSpan + -> ModuleName -> (a -> Name) -> [ImportRecord a] -> m (ModuleName, ModuleName) -checkImportConflicts currentModule toName xs = +checkImportConflicts ss currentModule toName xs = let byOrig = sortBy (compare `on` importSourceModule) xs groups = groupBy ((==) `on` importSourceModule) byOrig @@ -468,11 +469,11 @@ checkImportConflicts currentModule toName xs = in if length groups > 1 then case nonImplicit of - [ImportRecord (Qualified (Just mnNew) _) mnOrig ss _] -> do + [ImportRecord (Qualified (Just mnNew) _) mnOrig ss' _] -> do let warningModule = if mnNew == currentModule then Nothing else Just mnNew - tell . errorMessage' ss $ ScopeShadowing name warningModule $ delete mnNew conflictModules + tell . errorMessage' ss' $ ScopeShadowing name warningModule $ delete mnNew conflictModules return (mnNew, mnOrig) - _ -> throwError . errorMessage $ ScopeConflict name conflictModules + _ -> throwError . errorMessage' ss $ ScopeConflict name conflictModules else let ImportRecord (Qualified (Just mnNew) _) mnOrig _ _ = head byOrig in return (mnNew, mnOrig) diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index ed02b81074..18ef78f278 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -103,13 +103,13 @@ resolveExports env ss mn imps exps refs = let isPseudo = isPseudoModule name when (not isPseudo && not (isImportedModule name)) . throwError . errorMessage' ss' . UnknownExport $ ModName name - reTypes <- extract isPseudo name TyName (importedTypes imps) - reTypeOps <- extract isPseudo name TyOpName (importedTypeOps imps) - reDctors <- extract isPseudo name DctorName (importedDataConstructors imps) - reClasses <- extract isPseudo name TyClassName (importedTypeClasses imps) - reValues <- extract isPseudo name IdentName (importedValues imps) - reValueOps <- extract isPseudo name ValOpName (importedValueOps imps) - reKinds <- extract isPseudo name KiName (importedKinds imps) + reTypes <- extract ss' isPseudo name TyName (importedTypes imps) + reTypeOps <- extract ss' isPseudo name TyOpName (importedTypeOps imps) + reDctors <- extract ss' isPseudo name DctorName (importedDataConstructors imps) + reClasses <- extract ss' isPseudo name TyClassName (importedTypeClasses imps) + reValues <- extract ss' isPseudo name IdentName (importedValues imps) + reValueOps <- extract ss' isPseudo name ValOpName (importedValueOps imps) + reKinds <- extract ss' isPseudo name KiName (importedKinds imps) foldM (\exps' ((tctor, dctors), mn') -> exportType ss' ReExport exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors) >>= flip (foldM (uncurry . exportTypeOp ss')) (map resolveTypeOp reTypeOps) >>= flip (foldM (uncurry . exportTypeClass ss' ReExport)) (map resolveClass reClasses) @@ -121,16 +121,17 @@ resolveExports env ss mn imps exps refs = -- Extracts a list of values for a module based on a lookup table. If the -- boolean is true the values are filtered by the qualification extract - :: Bool + :: SourceSpan + -> Bool -> ModuleName -> (a -> Name) -> M.Map (Qualified a) [ImportRecord a] -> m [Qualified a] - extract useQual name toName = fmap (map (importName . head . snd)) . go . M.toList + extract ss' useQual name toName = fmap (map (importName . head . snd)) . go . M.toList where go = filterM $ \(name', options) -> do let isMatch = if useQual then isQualifiedWith name name' else any (checkUnqual name') options - when (isMatch && length options > 1) $ void $ checkImportConflicts mn toName options + when (isMatch && length options > 1) $ void $ checkImportConflicts ss' mn toName options return isMatch checkUnqual name' ir = isUnqualified name' && isQualifiedWith name (importName ir) From 345f6435f2aa23a9403d25a0486596b8b0b4399b Mon Sep 17 00:00:00 2001 From: Hardy Jones Date: Tue, 24 Apr 2018 14:27:45 -0700 Subject: [PATCH 0970/1580] Track where clause metadata (#3317) * Tag let bindings with metadata about their origin When we parsed where clauses, we desugared directly to a let binding. When we did that desugaring, we lost the information about whether a let binding was ever a where clause. We add a bit of metadata to the let bindings we generate so we can track whether it began its life as a where clause or not. This is already showing to be directly useful, as we can pretty print where clauses! Should allow external tools to also benefit from the metadata. * Add where clause metadata to CoreFn Although not explicitly required for tracking where clauses, this seems beneficial to have in the CoreFn. It should help external tools track where clauses. Also, we already had the metadata. Why not pass it along? * Rename to `FromLet` * Extract function --- src/Language/PureScript/AST/Declarations.hs | 16 +++++++++++++++- src/Language/PureScript/AST/Traversals.hs | 14 +++++++------- src/Language/PureScript/CoreFn/Desugar.hs | 9 +++++++-- src/Language/PureScript/CoreFn/FromJSON.hs | 1 + src/Language/PureScript/CoreFn/Meta.hs | 7 ++++++- src/Language/PureScript/CoreFn/ToJSON.hs | 1 + src/Language/PureScript/Linter.hs | 2 +- src/Language/PureScript/Linter/Exhaustive.hs | 3 ++- src/Language/PureScript/Parser/Declarations.hs | 4 ++-- src/Language/PureScript/Pretty/Values.hs | 6 +++++- src/Language/PureScript/Sugar/AdoNotation.hs | 2 +- src/Language/PureScript/Sugar/BindingGroups.hs | 4 ++-- .../PureScript/Sugar/CaseDeclarations.hs | 6 +++--- src/Language/PureScript/Sugar/DoNotation.hs | 2 +- src/Language/PureScript/Sugar/LetPattern.hs | 14 ++++++++------ src/Language/PureScript/Sugar/Names.hs | 4 ++-- src/Language/PureScript/Sugar/ObjectWildcards.hs | 2 +- .../PureScript/Sugar/TypeDeclarations.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 8 ++++---- 19 files changed, 70 insertions(+), 37 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 9f2636dac5..e5b223e9e9 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -770,7 +770,7 @@ data Expr -- | -- A let binding -- - | Let [Declaration] Expr + | Let WhereProvenance [Declaration] Expr -- | -- A do-notation block -- @@ -816,6 +816,20 @@ data Expr | PositionedValue SourceSpan [Comment] Expr deriving (Show) +-- | +-- Metadata that tells where a let binding originated +-- +data WhereProvenance + -- | + -- The let binding was originally a where clause + -- + = FromWhere + -- | + -- The let binding was always a let binding + -- + | FromLet + deriving (Show) + -- | -- An alternative in a case statement -- diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index a7c8297e91..8dfa38da04 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -75,7 +75,7 @@ everywhereOnValues f g h = (f', g', h') g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3)) g' (Case vs alts) = g (Case (fmap g' vs) (fmap handleCaseAlternative alts)) g' (TypedValue check v ty) = g (TypedValue check (g' v) ty) - g' (Let ds v) = g (Let (fmap f' ds) (g' v)) + g' (Let w ds v) = g (Let w (fmap f' ds) (g' v)) g' (Do es) = g (Do (fmap handleDoNotationElement es)) g' (Ado es v) = g (Ado (fmap handleDoNotationElement es) (g' v)) g' (PositionedValue pos com v) = g (PositionedValue pos com (g' v)) @@ -149,7 +149,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g') g' (Case vs alts) = Case <$> traverse (g' <=< g) vs <*> traverse handleCaseAlternative alts g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty - g' (Let ds v) = Let <$> traverse (f' <=< f) ds <*> (g v >>= g') + g' (Let w ds v) = Let w <$> traverse (f' <=< f) ds <*> (g v >>= g') g' (Do es) = Do <$> traverse handleDoNotationElement es g' (Ado es v) = Ado <$> traverse handleDoNotationElement es <*> (g v >>= g') g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g') @@ -218,7 +218,7 @@ everywhereOnValuesM f g h = (f', g', h') g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g g' (Case vs alts) = (Case <$> traverse g' vs <*> traverse handleCaseAlternative alts) >>= g g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g - g' (Let ds v) = (Let <$> traverse f' ds <*> g' v) >>= g + g' (Let w ds v) = (Let w <$> traverse f' ds <*> g' v) >>= g g' (Do es) = (Do <$> traverse handleDoNotationElement es) >>= g g' (Ado es v) = (Ado <$> traverse handleDoNotationElement es <*> g' v) >>= g g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g @@ -290,7 +290,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j') g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3 g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (fmap g' vs)) (fmap i' alts) g' v@(TypedValue _ v1 _) = g v <> g' v1 - g' v@(Let ds v1) = foldl (<>) (g v) (fmap f' ds) <> g' v1 + g' v@(Let _ ds v1) = foldl (<>) (g v) (fmap f' ds) <> g' v1 g' v@(Do es) = foldl (<>) (g v) (fmap j' es) g' v@(Ado es v1) = foldl (<>) (g v) (fmap j' es) <> g' v1 g' v@(PositionedValue _ _ v1) = g v <> g' v1 @@ -371,7 +371,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (fmap (g'' s) vs)) (fmap (i'' s) alts) g' s (TypedValue _ v1 _) = g'' s v1 - g' s (Let ds v1) = foldl (<>) r0 (fmap (f'' s) ds) <> g'' s v1 + g' s (Let _ ds v1) = foldl (<>) r0 (fmap (f'' s) ds) <> g'' s v1 g' s (Do es) = foldl (<>) r0 (fmap (j'' s) es) g' s (Ado es v1) = foldl (<>) r0 (fmap (j'' s) es) <> g'' s v1 g' s (PositionedValue _ _ v1) = g'' s v1 @@ -456,7 +456,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3 g' s (Case vs alts) = Case <$> traverse (g'' s) vs <*> traverse (i'' s) alts g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty - g' s (Let ds v) = Let <$> traverse (f'' s) ds <*> g'' s v + g' s (Let w ds v) = Let w <$> traverse (f'' s) ds <*> g'' s v g' s (Do es) = Do <$> traverse (j'' s) es g' s (Ado es v) = Ado <$> traverse (j'' s) es <*> g'' s v g' s (PositionedValue pos com v) = PositionedValue pos com <$> g'' s v @@ -548,7 +548,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts g' s (TypedValue _ v1 _) = g'' s v1 - g' s (Let ds v1) = + g' s (Let _ ds v1) = let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds)) in foldMap (f'' s') ds <> g'' s' v1 g' s (Do es) = fold . snd . mapAccumL j'' s $ es diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index c28f8c8120..7851570e9d 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -99,8 +99,8 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = Case (ss, com, ty, Nothing) (fmap (exprToCoreFn ss [] Nothing) vs) (fmap (altToCoreFn ss) alts) exprToCoreFn ss com _ (A.TypedValue _ v ty) = exprToCoreFn ss com (Just ty) v - exprToCoreFn ss com ty (A.Let ds v) = - Let (ss, com, ty, Nothing) (concatMap declToCoreFn ds) (exprToCoreFn ss [] Nothing v) + exprToCoreFn ss com ty (A.Let w ds v) = + Let (ss, com, ty, getLetMeta w) (concatMap declToCoreFn ds) (exprToCoreFn ss [] Nothing v) exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal _ (A.ObjectLiteral _)) _)) = exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name lit) exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal _ (A.ObjectLiteral vs))) = @@ -155,6 +155,11 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = binderToCoreFn _ _ A.ParensInBinder{} = internalError "ParensInBinder should have been desugared before binderToCoreFn" + -- | Gets metadata for let bindings. + getLetMeta :: A.WhereProvenance -> Maybe Meta + getLetMeta A.FromWhere = Just IsWhere + getLetMeta A.FromLet = Nothing + -- | Gets metadata for values. getValueMeta :: Qualified Ident -> Maybe Meta getValueMeta name = diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 6cb642aca1..f616a5ba3d 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -43,6 +43,7 @@ metaFromJSON v = withObject "Meta" metaFromObj v "IsTypeClassConstructor" -> return $ Just IsTypeClassConstructor "IsForeign" -> return $ Just IsForeign + "IsWhere" -> return $ Just IsWhere _ -> fail ("not recognized Meta: " ++ T.unpack type_) isConstructorFromJSON o = do diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs index 65e5dcd69a..9a843473bb 100644 --- a/src/Language/PureScript/CoreFn/Meta.hs +++ b/src/Language/PureScript/CoreFn/Meta.hs @@ -26,7 +26,12 @@ data Meta -- | -- The contained reference is for a foreign member -- - | IsForeign deriving (Show, Eq, Ord) + | IsForeign + -- | + -- The contained value is a where clause + -- + | IsWhere + deriving (Show, Eq, Ord) -- | -- Data constructor metadata diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index a832c7f3d3..c6084dda01 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -37,6 +37,7 @@ metaToJSON (IsConstructor t is) metaToJSON IsNewtype = object [ T.pack "metaType" .= "IsNewtype" ] metaToJSON IsTypeClassConstructor = object [ T.pack "metaType" .= "IsTypeClassConstructor" ] metaToJSON IsForeign = object [ T.pack "metaType" .= "IsForeign" ] +metaToJSON IsWhere = object [ T.pack "metaType" .= "IsWhere" ] sourceSpanToJSON :: SourceSpan -> Value sourceSpanToJSON (SourceSpan _ spanStart spanEnd) = diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 9d4917f247..b6b3f7a2e5 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -56,7 +56,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl stepE :: S.Set Ident -> Expr -> MultipleErrors stepE s (Abs (VarBinder ss name) _) | name `S.member` s = errorMessage' ss (ShadowedName name) - stepE s (Let ds' _) = foldMap go ds' + stepE s (Let _ ds' _) = foldMap go ds' where go d | Just i <- getDeclIdent d , i `S.member` s = errorMessage' (declSourceSpan d) (ShadowedName i) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 179497db47..1965925639 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -290,6 +290,7 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' var <- freshName return $ Let + FromLet [ partial var tyVar ] $ App (Var ss (Qualified Nothing UnusedIdent)) e where @@ -349,7 +350,7 @@ checkExhaustiveExpr initSS env mn = onExpr initSS case' <- Case <$> mapM (onExpr ss) es <*> mapM (onCaseAlternative ss) cas checkExhaustive ss env mn (length es) cas case' onExpr ss (TypedValue x e y) = TypedValue x <$> onExpr ss e <*> pure y - onExpr ss (Let ds e) = Let <$> mapM onDecl ds <*> onExpr ss e + onExpr ss (Let w ds e) = Let w <$> mapM onDecl ds <*> onExpr ss e onExpr _ (PositionedValue ss x e) = PositionedValue ss x <$> onExpr ss e onExpr _ expr = return expr diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 1e84c952f1..12fc38f9ab 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -78,7 +78,7 @@ parseValueWithWhereClause = do reserved "where" indented mark $ P.many1 (same *> parseLocalDeclaration) - return $ maybe value (`Let` value) whereClause + return $ maybe value (\ds -> Let FromWhere ds value) whereClause parseValueWithIdentAndBinders :: Ident -> [Binder] -> TokenParser (SourceAnn -> Declaration) parseValueWithIdentAndBinders ident bs = do @@ -433,7 +433,7 @@ parseLet = do indented reserved "in" result <- parseValue - return $ Let ds result + return $ Let FromLet ds result parseValueAtom :: TokenParser Expr parseValueAtom = withSourceSpan PositionedValue $ P.choice diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 89dc52f875..bbabf0821c 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -72,7 +72,11 @@ prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) = prettyPrintValue d (Case values binders) = (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) // moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders)) -prettyPrintValue d (Let ds val) = +prettyPrintValue d (Let FromWhere ds val) = + prettyPrintValue (d - 1) val // + moveRight 2 (text "where" // + vcat left (map (prettyPrintDeclaration (d - 1)) ds)) +prettyPrintValue d (Let FromLet ds val) = text "let" // moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) // (text "in " <> prettyPrintValue (d - 1) val) diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs index 577f99a316..c881fc3996 100644 --- a/src/Language/PureScript/Sugar/AdoNotation.hs +++ b/src/Language/PureScript/Sugar/AdoNotation.hs @@ -58,7 +58,7 @@ desugarAdo d = [CaseAlternative [binder] [MkUnguarded yield]]) return (abs, val : args) go (yield, args) (DoNotationLet ds) = do - return (Let ds yield, args) + return (Let FromLet ds yield, args) go acc (PositionedDoNotationElement pos com el) = rethrowWithPosition pos $ do (yield, args) <- go acc el diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 0c801203ac..f347fa8fd9 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -58,7 +58,7 @@ createBindingGroups moduleName = mapM f <=< handleDecls (f, _, _) = everywhereOnValuesTopDownM return handleExprs return handleExprs :: Expr -> m Expr - handleExprs (Let ds val) = flip Let val <$> handleDecls ds + handleExprs (Let w ds val) = (\ds' -> Let w ds' val) <$> handleDecls ds handleExprs other = return other -- | @@ -102,7 +102,7 @@ collapseBindingGroups = go other = [other] collapseBindingGroupsForValue :: Expr -> Expr -collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val +collapseBindingGroupsForValue (Let w ds val) = Let w (collapseBindingGroups ds) val collapseBindingGroupsForValue other = other usedIdents :: ModuleName -> ValueDeclarationData Expr -> [Ident] diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 7598bedac7..6199de9701 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -68,7 +68,7 @@ desugarGuardedExprs ss (Case scrut alternatives) , ValueDecl (ss, []) scrut_id Private [] [MkUnguarded e] ) ) - Let scrut_decls <$> desugarGuardedExprs ss (Case scrut' alternatives) + Let FromLet scrut_decls <$> desugarGuardedExprs ss (Case scrut' alternatives) where isTrivialExpr (Var _ _) = True isTrivialExpr (Literal _ _) = True @@ -230,7 +230,7 @@ desugarGuardedExprs ss (Case scrut alternatives) = `App` Literal ss (BooleanLiteral True) alt_fail = [CaseAlternative [NullBinder] [MkUnguarded goto_rem_case]] - pure $ Let [ + pure $ Let FromLet [ ValueDecl (ss, []) rem_case_id Private [] [MkUnguarded (Abs (VarBinder ss unused_binder) desugared)] ] (mk_body alt_fail) @@ -333,7 +333,7 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro f' = mapM (\(GuardedExpr gs e) -> GuardedExpr gs <$> f e) in (:) <$> (ValueDecl sa name nameKind bs <$> f' result) <*> desugarRest rest where - go (Let ds val') = Let <$> desugarCases ds <*> pure val' + go (Let w ds val') = Let w <$> desugarCases ds <*> pure val' go other = return other desugarRest (d : ds) = (:) d <$> desugarRest ds desugarRest [] = pure [] diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 95c77cf560..71adaa19de 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -66,5 +66,5 @@ desugarDo d = checkBind _ = pure () mapM_ checkBind ds rest' <- go rest - return $ Let ds rest' + return $ Let FromLet ds rest' go (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go (el : rest) diff --git a/src/Language/PureScript/Sugar/LetPattern.hs b/src/Language/PureScript/Sugar/LetPattern.hs index 69bb7ef07c..58944c67f0 100644 --- a/src/Language/PureScript/Sugar/LetPattern.hs +++ b/src/Language/PureScript/Sugar/LetPattern.hs @@ -24,18 +24,20 @@ desugarLetPattern decl = in f decl where replace :: Expr -> Expr - replace (Let ds e) = go (partitionDecls ds) e + replace (Let w ds e) = go w (partitionDecls ds) e replace other = other - go :: [Either [Declaration] (SourceAnn, Binder, Expr)] + go :: WhereProvenance + -- ^ Metadata about whether the let-in was a where clause + -> [Either [Declaration] (SourceAnn, Binder, Expr)] -- ^ Declarations to desugar -> Expr -- ^ The original let-in result expression -> Expr - go [] e = e - go (Right ((pos, com), binder, boundE) : ds) e = - PositionedValue pos com $ Case [boundE] [CaseAlternative [binder] [MkUnguarded $ go ds e]] - go (Left ds:dss) e = Let ds (go dss e) + go _ [] e = e + go w (Right ((pos, com), binder, boundE) : ds) e = + PositionedValue pos com $ Case [boundE] [CaseAlternative [binder] [MkUnguarded $ go w ds e]] + go w (Left ds:dss) e = Let w ds (go w dss e) partitionDecls :: [Declaration] -> [Either [Declaration] (SourceAnn, Binder, Expr)] partitionDecls = concatMap f . groupBy ((==) `on` isBoundValueDeclaration) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index fd59624d1c..473ec9970a 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -254,11 +254,11 @@ renameInModule imports (Module modSS coms mn decls exps) = return ((pos', bound), v) updateValue (pos, bound) (Abs (VarBinder ss arg) val') = return ((pos, arg : bound), Abs (VarBinder ss arg) val') - updateValue (pos, bound) (Let ds val') = do + updateValue (pos, bound) (Let w ds val') = do let args = mapMaybe letBoundVariable ds unless (length (ordNub args) == length args) . throwError . errorMessage' pos $ OverlappingNamesInLet - return ((pos, args ++ bound), Let ds val') + return ((pos, args ++ bound), Let w ds val') updateValue (_, bound) (Var ss name'@(Qualified Nothing ident)) | ident `notElem` bound = (,) (ss, bound) <$> (Var ss <$> updateValueName name' ss) updateValue (_, bound) (Var ss name'@(Qualified (Just _) _)) = diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index c0bda4e7f1..6c629c0698 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -69,7 +69,7 @@ desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d then Abs (VarBinder nullSourceSpan val) <$> wrapLambda (buildUpdates valExpr) ps else wrapLambda (buildLet val . buildUpdates valExpr) ps where - buildLet val = Let [ValueDecl (declSourceSpan d, []) val Public [] [MkUnguarded obj]] + buildLet val = Let FromLet [ValueDecl (declSourceSpan d, []) val Public [] [MkUnguarded obj]] -- recursively build up the nested `ObjectUpdate` expressions buildUpdates :: Expr -> PathTree Expr -> Expr diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index bb4f99a8e1..37e8d1b3cc 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -46,7 +46,7 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) = (:) <$> (ValueDecl sa name' nameKind bs <$> f' val) <*> desugarTypeDeclarations rest where - go (Let ds' val') = Let <$> desugarTypeDeclarations ds' <*> pure val' + go (Let w ds' val') = Let w <$> desugarTypeDeclarations ds' <*> pure val' go other = return other desugarTypeDeclarations (TypeInstanceDeclaration sa ch idx nm deps cls args (ExplicitInstance ds') : rest) = (:) <$> (TypeInstanceDeclaration sa ch idx nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds') diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index d12e711179..6b402391fe 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -392,9 +392,9 @@ infer' (IfThenElse cond th el) = do (el'', elTy') <- instantiatePolyTypeWithUnknowns el' elTy unifyTypes thTy' elTy' return $ TypedValue True (IfThenElse cond' th'' el'') thTy' -infer' (Let ds val) = do +infer' (Let w ds val) = do (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer - return $ TypedValue True (Let ds' val') valTy + return $ TypedValue True (Let w ds' val') valTy infer' (DeferredDictionary className tys) = do dicts <- getTypeClassDictionaries hints <- getHints @@ -722,9 +722,9 @@ check' v@(Constructor _ c) ty = do ty' <- introduceSkolemScope ty elaborate <- subsumes repl ty' return $ TypedValue True (elaborate v) ty' -check' (Let ds val) ty = do +check' (Let w ds val) ty = do (ds', val') <- inferLetBinding [] ds val (`check` ty) - return $ TypedValue True (Let ds' val') ty + return $ TypedValue True (Let w ds' val') ty check' val kt@(KindedType ty kind) = do checkTypeKind ty kind val' <- check' val ty From 948aafe9284ec066d833b1fdd41905a977363a03 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 24 Apr 2018 23:14:41 +0100 Subject: [PATCH 0971/1580] Check warnings/errors for positions (#3211) * Check warnings/errors for positions --- tests/TestCompiler.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index bd2edae766..af9705d97e 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -227,11 +227,21 @@ checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String checkShouldFailWith expected errs = let actual = map P.errorCode $ P.runMultipleErrors errs in if sort expected == sort (map T.unpack actual) - then Nothing + then checkPositioned errs else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " ++ show actual ++ ", full error messages: \n" ++ unlines (map (P.renderBox . P.prettyPrintSingleError P.defaultPPEOptions) (P.runMultipleErrors errs)) +checkPositioned :: P.MultipleErrors -> Maybe String +checkPositioned errs = + case mapMaybe (\err -> maybe (Just err) (const Nothing) (P.errorSpan err)) (P.runMultipleErrors errs) of + [] -> + Nothing + errs' -> + Just + $ "Found errors with missing source spans:\n" + ++ unlines (map (P.renderBox . P.prettyPrintSingleError P.defaultPPEOptions) errs') + assertCompiles :: [P.Module] -> [P.ExternsFile] From 54ce05d9fef699769855c654c6bfa4197e72742f Mon Sep 17 00:00:00 2001 From: Matthew Leon Date: Wed, 25 Apr 2018 06:32:03 -0400 Subject: [PATCH 0972/1580] add a CoreFn optimization pass (#3319) it does nothing for the moment --- src/Language/PureScript/CoreFn.hs | 1 + src/Language/PureScript/CoreFn/Optimizer.hs | 16 ++++++++++++++++ src/Language/PureScript/Make.hs | 3 ++- 3 files changed, 19 insertions(+), 1 deletion(-) create mode 100644 src/Language/PureScript/CoreFn/Optimizer.hs diff --git a/src/Language/PureScript/CoreFn.hs b/src/Language/PureScript/CoreFn.hs index 7675a8791f..b2b73343b5 100644 --- a/src/Language/PureScript/CoreFn.hs +++ b/src/Language/PureScript/CoreFn.hs @@ -12,4 +12,5 @@ import Language.PureScript.CoreFn.Desugar as C import Language.PureScript.CoreFn.Expr as C import Language.PureScript.CoreFn.Meta as C import Language.PureScript.CoreFn.Module as C +import Language.PureScript.CoreFn.Optimizer as C import Language.PureScript.CoreFn.Traversals as C diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs new file mode 100644 index 0000000000..1721fb1355 --- /dev/null +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -0,0 +1,16 @@ +module Language.PureScript.CoreFn.Optimizer (optimizeCoreFn) where + +import Protolude + +import Data.Function (id) +import Language.PureScript.CoreFn.Expr (Bind) +import Language.PureScript.CoreFn.Module (Module, moduleDecls) + +-- | +-- CoreFn optimization pass. +-- +optimizeCoreFn :: Module a -> Module a +optimizeCoreFn m = m {moduleDecls = optimizeModuleDecls $ moduleDecls m} + +optimizeModuleDecls :: [Bind a] -> [Bind a] +optimizeModuleDecls = id diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 4340cb5c41..200f8abdc6 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -72,7 +72,8 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded let mod' = Module ss coms moduleName regrouped exps corefn = CF.moduleToCoreFn env' mod' - [renamed] = renameInModules [corefn] + optimized = CF.optimizeCoreFn corefn + [renamed] = renameInModules [optimized] exts = moduleToExternsFile mod' env' evalSupplyT nextVar' . codegen ss renamed env' . encode $ exts return exts From 40a4ed8eba96f3e01d53a9857b941843595e22a1 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Wed, 25 Apr 2018 14:37:47 +0100 Subject: [PATCH 0973/1580] Fix errors in binding groups missing source spans (#3278) * Add failing test * Add source spans for errors in binding groups --- examples/failing/3275-BindingGroupErrorPos.purs | 12 ++++++++++++ examples/failing/3275-DataBindingGroupErrorPos.purs | 8 ++++++++ src/Language/PureScript/TypeChecker.hs | 6 ++++-- 3 files changed, 24 insertions(+), 2 deletions(-) create mode 100644 examples/failing/3275-BindingGroupErrorPos.purs create mode 100644 examples/failing/3275-DataBindingGroupErrorPos.purs diff --git a/examples/failing/3275-BindingGroupErrorPos.purs b/examples/failing/3275-BindingGroupErrorPos.purs new file mode 100644 index 0000000000..1717906451 --- /dev/null +++ b/examples/failing/3275-BindingGroupErrorPos.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith KindsDoNotUnify +module BindingGroupErrorPos where + +-- This isn't really about KindsDoNotUnify, it's about positioning errors +-- that occur in binding groups + +import Prelude + +type Result = Array Int + +wrong :: Int -> Result String +wrong n = wrong (n - 1) diff --git a/examples/failing/3275-DataBindingGroupErrorPos.purs b/examples/failing/3275-DataBindingGroupErrorPos.purs new file mode 100644 index 0000000000..fd8e90695f --- /dev/null +++ b/examples/failing/3275-DataBindingGroupErrorPos.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith KindsDoNotUnify +module DataBindingGroupErrorPos where + +-- This isn't really about KindsDoNotUnify, it's about positioning errors +-- that occur in data binding groups + +data Foo a = Foo (Bar a a) +data Bar a = Bar (Foo a) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 005b5b2bd5..a4257e0cc2 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -245,7 +245,8 @@ typeCheckAll moduleName _ = traverse go syns = mapMaybe toTypeSynonym tysList dataDecls = mapMaybe toDataDecl tysList bindingGroupNames = ordNub ((syns^..traverse._1) ++ (dataDecls^..traverse._2)) - warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames)) $ do + sss = fmap declSourceSpan tys + warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames) . addHint (PositionedError sss)) $ do (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls) for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do when (dtype == Newtype) $ checkNewtype name dctors @@ -283,7 +284,8 @@ typeCheckAll moduleName _ = traverse go go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared" go (BindingGroupDeclaration vals) = do env <- getEnv - warnAndRethrow (addHint (ErrorInBindingGroup (fmap (\((_, ident), _, _) -> ident) vals))) $ do + let sss = fmap (\(((ss, _), _), _, _) -> ss) vals + warnAndRethrow (addHint (ErrorInBindingGroup (fmap (\((_, ident), _, _) -> ident) vals)) . addHint (PositionedError sss)) $ do for_ vals $ \((_, ident), _, _) -> valueIsNotDefined moduleName ident vals' <- NEL.toList <$> traverse (\(sai@((ss, _), _), nk, expr) -> (sai, nk,) <$> checkExhaustiveExpr ss env moduleName expr) vals tys <- typesOf RecursiveBindingGroup moduleName $ fmap (\(sai, _, ty) -> (sai, ty)) vals' From b4b3174bcde9d8e2ee2edb377bd04aa5b50b8656 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Wed, 25 Apr 2018 18:45:28 +0100 Subject: [PATCH 0974/1580] Efficient object updates for closed records (#3321) * Efficient object updates for closed records * Add constant for Record name --- src/Language/PureScript/Constants.hs | 3 ++ src/Language/PureScript/CoreFn/Optimizer.hs | 43 ++++++++++++++++--- .../PureScript/Sugar/TypeClasses/Deriving.hs | 2 +- 3 files changed, 41 insertions(+), 7 deletions(-) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index 2e9b144e11..f05d4f7cd6 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -375,6 +375,9 @@ pattern Prim = ModuleName [ProperName "Prim"] pattern Partial :: Qualified (ProperName 'ClassName) pattern Partial = Qualified (Just Prim) (ProperName "Partial") +pattern Record :: Qualified (ProperName 'TypeName) +pattern Record = Qualified (Just Prim) (ProperName "Record") + -- Prim.Ordering pattern PrimOrdering :: ModuleName diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 1721fb1355..9573e1623a 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -2,15 +2,46 @@ module Language.PureScript.CoreFn.Optimizer (optimizeCoreFn) where import Protolude -import Data.Function (id) -import Language.PureScript.CoreFn.Expr (Bind) -import Language.PureScript.CoreFn.Module (Module, moduleDecls) +import Data.List (lookup) +import Language.PureScript.AST.Literals +import Language.PureScript.AST.SourcePos +import Language.PureScript.CoreFn.Ann +import Language.PureScript.CoreFn.Expr +import Language.PureScript.CoreFn.Module +import Language.PureScript.CoreFn.Traversals +import Language.PureScript.Label +import Language.PureScript.Types +import qualified Language.PureScript.Constants as C -- | -- CoreFn optimization pass. -- -optimizeCoreFn :: Module a -> Module a +optimizeCoreFn :: Module Ann -> Module Ann optimizeCoreFn m = m {moduleDecls = optimizeModuleDecls $ moduleDecls m} -optimizeModuleDecls :: [Bind a] -> [Bind a] -optimizeModuleDecls = id +optimizeModuleDecls :: [Bind Ann] -> [Bind Ann] +optimizeModuleDecls = map transformBinds + where + (transformBinds, _, _) = everywhereOnValues identity transformExprs identity + transformExprs = optimizeClosedRecordUpdate + +optimizeClosedRecordUpdate :: Expr Ann -> Expr Ann +optimizeClosedRecordUpdate ou@(ObjectUpdate a@(_, _, Just t, _) r updatedFields) = + case closedRecordFields t of + Nothing -> ou + Just allFields -> Literal a (ObjectLiteral (map f allFields)) + where f (Label l) = case lookup l updatedFields of + Nothing -> (l, Accessor (nullSourceSpan, [], Nothing, Nothing) l r) + Just e -> (l, e) +optimizeClosedRecordUpdate e = e + +-- | Return the labels of a closed record, or Nothing for other types or open records. +closedRecordFields :: Type -> Maybe [Label] +closedRecordFields (TypeApp (TypeConstructor C.Record) row) = + collect row + where + collect :: Type -> Maybe [Label] + collect REmpty = Just [] + collect (RCons l _ r) = collect r >>= return . (l :) + collect _ = Nothing +closedRecordFields _ = Nothing diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 678e6274ed..583ebb2a80 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -666,7 +666,7 @@ isAppliedVar (TypeApp (TypeVar _) _) = True isAppliedVar _ = False objectType :: Type -> Maybe Type -objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec +objectType (TypeApp (TypeConstructor C.Record) rec) = Just rec objectType _ = Nothing decomposeRec :: Type -> Maybe [(Label, Type)] From d66540ec5a4d3b513e45ab68111cafd2ad7f06db Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Wed, 25 Apr 2018 22:02:34 +0100 Subject: [PATCH 0975/1580] Fix tests after merging symbols into prelude (#3322) --- tests/support/bower.json | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/support/bower.json b/tests/support/bower.json index 0b7bc52aa5..cf220647a1 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -30,7 +30,6 @@ "purescript-refs": "purescript/purescript-refs#compiler/0.12", "purescript-st": "purescript/purescript-st#compiler/0.12", "purescript-strings": "purescript/purescript-strings#compiler/0.12", - "purescript-symbols": "purescript/purescript-symbols#compiler/0.12", "purescript-tailrec": "purescript/purescript-tailrec#compiler/0.12", "purescript-tuples": "purescript/purescript-tuples#compiler/0.12", "purescript-type-equality": "purescript/purescript-type-equality#compiler/0.12", From 5363d80d4f73f777393449f13cc5b1aacf079088 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 27 Apr 2018 12:10:05 +0200 Subject: [PATCH 0976/1580] Allow operators shadowed by variables of the same name as the alias (#3320) * Allow operators shadowed by variables of the same name as the alias This is a reimplementation of #2964. It uses a custom `ScopedIdent` type instead of `Qualified Ident`, as the qualifier was effectively used as a boolean, but allowed too many invalid states. Also makes use of the extra information in findUsage for the IDE code. * remove unused code --- examples/passing/2803.purs | 17 +++++ src/Language/PureScript/AST/Traversals.hs | 74 ++++++++++--------- src/Language/PureScript/Ide/Usage.hs | 13 ++-- src/Language/PureScript/Linter.hs | 28 ++++--- .../PureScript/Sugar/BindingGroups.hs | 6 +- tests/Language/PureScript/Ide/UsageSpec.hs | 6 ++ .../src/FindUsage/RecursiveShadowed.purs | 10 +++ 7 files changed, 98 insertions(+), 56 deletions(-) create mode 100644 examples/passing/2803.purs create mode 100644 tests/support/pscide/src/FindUsage/RecursiveShadowed.purs diff --git a/examples/passing/2803.purs b/examples/passing/2803.purs new file mode 100644 index 0000000000..42cbcd7678 --- /dev/null +++ b/examples/passing/2803.purs @@ -0,0 +1,17 @@ +module Main where + +import Prelude ((+), (-), (==)) +import Effect.Console (log) + +f :: Int -> Int -> Int +f = (+) + +infixl 6 f as % + +g :: Int -> Int -> Int +g a b = let f = (-) in a % b + +main = + if g 10 5 == 15 + then log "Done" + else log "Failed" diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 8dfa38da04..f4a35f5f40 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -492,47 +492,53 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j k' s (ConditionGuard e) = ConditionGuard <$> g'' s e k' s (PatternGuard b e) = PatternGuard <$> h'' s b <*> g'' s e +data ScopedIdent = LocalIdent Ident | ToplevelIdent Ident + deriving (Show, Eq, Ord) + +inScope :: Ident -> S.Set ScopedIdent -> Bool +inScope i s = (LocalIdent i `S.member` s) || (ToplevelIdent i `S.member` s) + everythingWithScope :: forall r . (Monoid r) - => (S.Set Ident -> Declaration -> r) - -> (S.Set Ident -> Expr -> r) - -> (S.Set Ident -> Binder -> r) - -> (S.Set Ident -> CaseAlternative -> r) - -> (S.Set Ident -> DoNotationElement -> r) - -> ( S.Set Ident -> Declaration -> r - , S.Set Ident -> Expr -> r - , S.Set Ident -> Binder -> r - , S.Set Ident -> CaseAlternative -> r - , S.Set Ident -> DoNotationElement -> r + => (S.Set ScopedIdent -> Declaration -> r) + -> (S.Set ScopedIdent -> Expr -> r) + -> (S.Set ScopedIdent -> Binder -> r) + -> (S.Set ScopedIdent -> CaseAlternative -> r) + -> (S.Set ScopedIdent -> DoNotationElement -> r) + -> ( S.Set ScopedIdent -> Declaration -> r + , S.Set ScopedIdent -> Expr -> r + , S.Set ScopedIdent -> Binder -> r + , S.Set ScopedIdent -> CaseAlternative -> r + , S.Set ScopedIdent -> DoNotationElement -> r ) everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) where -- Avoid importing Data.Monoid and getting shadowed names above (<>) = mappend - f'' :: S.Set Ident -> Declaration -> r + f'' :: S.Set ScopedIdent -> Declaration -> r f'' s a = f s a <> f' s a - f' :: S.Set Ident -> Declaration -> r + f' :: S.Set ScopedIdent -> Declaration -> r f' s (DataBindingGroupDeclaration ds) = - let s' = S.union s (S.fromList (mapMaybe getDeclIdent (NEL.toList ds))) + let s' = S.union s (S.fromList (map ToplevelIdent (mapMaybe getDeclIdent (NEL.toList ds)))) in foldMap (f'' s') ds f' s (ValueDecl _ name _ bs val) = - let s' = S.insert name s - s'' = S.union s' (S.fromList (concatMap binderNames bs)) + let s' = S.insert (ToplevelIdent name) s + s'' = S.union s' (S.fromList (concatMap localBinderNames bs)) in foldMap (h'' s') bs <> foldMap (l' s'') val f' s (BindingGroupDeclaration ds) = - let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> name) ds))) + let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> ToplevelIdent name) ds))) in foldMap (\(_, _, val) -> g'' s' val) ds f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldMap (f'' s) ds f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds f' _ _ = mempty - g'' :: S.Set Ident -> Expr -> r + g'' :: S.Set ScopedIdent -> Expr -> r g'' s a = g s a <> g' s a - g' :: S.Set Ident -> Expr -> r + g' :: S.Set ScopedIdent -> Expr -> r g' s (Literal _ l) = lit g'' s l g' s (UnaryMinus _ v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 @@ -542,14 +548,14 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s) vs g' s (Abs b v1) = - let s' = S.union (S.fromList (binderNames b)) s + let s' = S.union (S.fromList (localBinderNames b)) s in h'' s b <> g'' s' v1 g' s (App v1 v2) = g'' s v1 <> g'' s v2 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts g' s (TypedValue _ v1 _) = g'' s v1 g' s (Let _ ds v1) = - let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds)) + let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds))) in foldMap (f'' s') ds <> g'' s' v1 g' s (Do es) = fold . snd . mapAccumL j'' s $ es g' s (Ado es v1) = @@ -558,49 +564,49 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' s (PositionedValue _ _ v1) = g'' s v1 g' _ _ = mempty - h'' :: S.Set Ident -> Binder -> r + h'' :: S.Set ScopedIdent -> Binder -> r h'' s a = h s a <> h' s a - h' :: S.Set Ident -> Binder -> r + h' :: S.Set ScopedIdent -> Binder -> r h' s (LiteralBinder _ l) = lit h'' s l h' s (ConstructorBinder _ _ bs) = foldMap (h'' s) bs h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3] h' s (ParensInBinder b) = h'' s b - h' s (NamedBinder _ name b1) = h'' (S.insert name s) b1 + h' s (NamedBinder _ name b1) = h'' (S.insert (LocalIdent name) s) b1 h' s (PositionedBinder _ _ b1) = h'' s b1 h' s (TypedBinder _ b1) = h'' s b1 h' _ _ = mempty - lit :: (S.Set Ident -> a -> r) -> S.Set Ident -> Literal a -> r + lit :: (S.Set ScopedIdent -> a -> r) -> S.Set ScopedIdent -> Literal a -> r lit go s (ArrayLiteral as) = foldMap (go s) as lit go s (ObjectLiteral as) = foldMap (go s . snd) as lit _ _ _ = mempty - i'' :: S.Set Ident -> CaseAlternative -> r + i'' :: S.Set ScopedIdent -> CaseAlternative -> r i'' s a = i s a <> i' s a - i' :: S.Set Ident -> CaseAlternative -> r + i' :: S.Set ScopedIdent -> CaseAlternative -> r i' s (CaseAlternative bs gs) = - let s' = S.union s (S.fromList (concatMap binderNames bs)) + let s' = S.union s (S.fromList (concatMap localBinderNames bs)) in foldMap (h'' s) bs <> foldMap (l' s') gs - j'' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r) + j'' :: S.Set ScopedIdent -> DoNotationElement -> (S.Set ScopedIdent, r) j'' s a = let (s', r) = j' s a in (s', j s a <> r) - j' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r) + j' :: S.Set ScopedIdent -> DoNotationElement -> (S.Set ScopedIdent, r) j' s (DoNotationValue v) = (s, g'' s v) j' s (DoNotationBind b v) = - let s' = S.union (S.fromList (binderNames b)) s + let s' = S.union (S.fromList (localBinderNames b)) s in (s', h'' s b <> g'' s v) j' s (DoNotationLet ds) = - let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds)) + let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds))) in (s', foldMap (f'' s') ds) j' s (PositionedDoNotationElement _ _ e1) = j'' s e1 - k' :: S.Set Ident -> Guard -> (S.Set Ident, r) + k' :: S.Set ScopedIdent -> Guard -> (S.Set ScopedIdent, r) k' s (ConditionGuard e) = (s, g'' s e) k' s (PatternGuard b e) = - let s' = S.union (S.fromList (binderNames b)) s + let s' = S.union (S.fromList (localBinderNames b)) s in (s', h'' s b <> g'' s' e) l' s (GuardedExpr [] e) = g'' s e @@ -613,6 +619,8 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) getDeclIdent (TypeDeclaration td) = Just (tydeclIdent td) getDeclIdent _ = Nothing + localBinderNames = map LocalIdent . binderNames + accumTypes :: (Monoid r) => (Type -> r) diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index 3c64301ad0..9e989800f9 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -131,20 +131,17 @@ applySearch module_ search = foldMap findUsageInDeclaration decls where decls = P.getModuleDeclarations module_ - findUsageInDeclaration decl = + findUsageInDeclaration = let - (extr, _, _, _, _) = P.everythingWithScope mempty (goExpr decl) goBinder mempty mempty + (extr, _, _, _, _) = P.everythingWithScope mempty goExpr goBinder mempty mempty in - extr mempty decl + extr mempty - goExpr decl scope expr = case expr of + goExpr scope expr = case expr of P.Var sp i | Just ideValue <- preview _IdeDeclValue (P.disqualify search) , P.isQualified search - || not (_ideValueIdent ideValue `Set.member` scope) - -- This case means we're looking at a recursive definition for a - -- value, which we count as a usage. - || P.declName decl == Just (P.IdentName (_ideValueIdent ideValue)) -> + || not (P.LocalIdent (_ideValueIdent ideValue) `Set.member` scope) -> [sp | map P.runIdent i == map identifierFromIdeDeclaration search] P.Constructor sp name | Just ideDtor <- traverse (preview _IdeDeclDataConstructor) search -> diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index b6b3f7a2e5..59f936af25 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -28,8 +28,8 @@ import Language.PureScript.Types lint :: forall m. (MonadWriter MultipleErrors m) => Module -> m () lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds where - moduleNames :: S.Set Ident - moduleNames = S.fromList (ordNub (mapMaybe getDeclIdent ds)) + moduleNames :: S.Set ScopedIdent + moduleNames = S.fromList (map ToplevelIdent (mapMaybe getDeclIdent ds)) getDeclIdent :: Declaration -> Maybe Ident getDeclIdent (ValueDeclaration vd) = Just (valdeclIdent vd) @@ -54,26 +54,30 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl addHint (ErrorInTypeDeclaration (tydeclIdent td)) (checkTypeVars ss s (tydeclType td)) f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec - stepE :: S.Set Ident -> Expr -> MultipleErrors - stepE s (Abs (VarBinder ss name) _) | name `S.member` s = errorMessage' ss (ShadowedName name) + stepE :: S.Set ScopedIdent -> Expr -> MultipleErrors + stepE s (Abs (VarBinder ss name) _) | name `inScope` s = errorMessage' ss (ShadowedName name) stepE s (Let _ ds' _) = foldMap go ds' where go d | Just i <- getDeclIdent d - , i `S.member` s = errorMessage' (declSourceSpan d) (ShadowedName i) + , inScope i s = errorMessage' (declSourceSpan d) (ShadowedName i) | otherwise = mempty stepE _ _ = mempty - stepB :: S.Set Ident -> Binder -> MultipleErrors - stepB s (VarBinder ss name) | name `S.member` s = errorMessage' ss (ShadowedName name) - stepB s (NamedBinder ss name _) | name `S.member` s = errorMessage' ss (ShadowedName name) + stepB :: S.Set ScopedIdent -> Binder -> MultipleErrors + stepB s (VarBinder ss name) + | name `inScope` s + = errorMessage' ss (ShadowedName name) + stepB s (NamedBinder ss name _) + | inScope name s + = errorMessage' ss (ShadowedName name) stepB _ _ = mempty - stepDo :: S.Set Ident -> DoNotationElement -> MultipleErrors + stepDo :: S.Set ScopedIdent -> DoNotationElement -> MultipleErrors stepDo s (DoNotationLet ds') = foldMap go ds' where - go d | Just i <- getDeclIdent d - , i `S.member` s = errorMessage' (declSourceSpan d) (ShadowedName i) - | otherwise = mempty + go d + | Just i <- getDeclIdent d, i `inScope` s = errorMessage' (declSourceSpan d) (ShadowedName i) + | otherwise = mempty stepDo _ _ = mempty checkTypeVarsInDecl :: S.Set Text -> Declaration -> MultipleErrors diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index f347fa8fd9..f78c9dd6bd 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -112,11 +112,11 @@ usedIdents moduleName = ordNub . usedIdents' S.empty . valdeclExpression (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def - usedNamesE :: S.Set Ident -> Expr -> [Ident] + usedNamesE :: S.Set ScopedIdent -> Expr -> [Ident] usedNamesE scope (Var _ (Qualified Nothing name)) - | name `S.notMember` scope = [name] + | LocalIdent name `S.notMember` scope = [name] usedNamesE scope (Var _ (Qualified (Just moduleName') name)) - | moduleName == moduleName' && name `S.notMember` scope = [name] + | moduleName == moduleName' && ToplevelIdent name `S.notMember` scope = [name] usedNamesE _ _ = [] usedImmediateIdents :: ModuleName -> Declaration -> [Ident] diff --git a/tests/Language/PureScript/Ide/UsageSpec.hs b/tests/Language/PureScript/Ide/UsageSpec.hs index cce46bbd40..70671ea89e 100644 --- a/tests/Language/PureScript/Ide/UsageSpec.hs +++ b/tests/Language/PureScript/Ide/UsageSpec.hs @@ -53,6 +53,12 @@ spec = describe "Finding Usages" $ do , usage (Test.mn "FindUsage.Recursive") "recursiveUsage" IdeNSValue ] usage1 `shouldBeUsage` ("src" "FindUsage" "Recursive.purs", "7:12-7:26") + it "ignores a locally shadowed recursive usage" $ do + ([_, Right (UsagesResult usageResult)], _) <- Test.inProject $ + Test.runIde [ load ["FindUsage.RecursiveShadowed"] + , usage (Test.mn "FindUsage.RecursiveShadowed") "recursiveUsage" IdeNSValue + ] + usageResult `shouldBe` [] it "finds a constructor usage" $ do ([_, Right (UsagesResult [usage1])], _) <- Test.inProject $ Test.runIde [ load ["FindUsage", "FindUsage.Definition", "FindUsage.Reexport"] diff --git a/tests/support/pscide/src/FindUsage/RecursiveShadowed.purs b/tests/support/pscide/src/FindUsage/RecursiveShadowed.purs new file mode 100644 index 0000000000..3fc0d630bb --- /dev/null +++ b/tests/support/pscide/src/FindUsage/RecursiveShadowed.purs @@ -0,0 +1,10 @@ +module FindUsage.RecursiveShadowed where + +data Nat = Suc Nat | Z + +recursiveUsage :: Nat -> Int +recursiveUsage = case _ of + Suc x -> + let recursiveUsage = 3 + in recursiveUsage + Z -> 0 From c1039af7af5e27de1b554587c00f970043ea5ae9 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Fri, 27 Apr 2018 12:19:26 +0100 Subject: [PATCH 0977/1580] Replace type synonyms earlier when newtype deriving (#3326) --- examples/passing/NewtypeInstance.purs | 4 ++++ .../PureScript/Sugar/TypeClasses/Deriving.hs | 12 +++++++----- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs index 62794c14b0..e16e574360 100644 --- a/examples/passing/NewtypeInstance.purs +++ b/examples/passing/NewtypeInstance.purs @@ -50,6 +50,10 @@ derive newtype instance bindMyWriter :: Semigroup w => Bind (MyWriter w) derive newtype instance monadMyWriter :: Monoid w => Monad (MyWriter w) derive newtype instance monadWriterMyWriter :: Monoid w => MonadWriter w (MyWriter w) +type Syn' w a = MyWriter w a +newtype Syn a = Syn (Syn' (MyArray Int) a) +derive newtype instance functorSyn :: Functor Syn + main = do logShow (X "test") logShow (singleton "test" :: Y String) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 583ebb2a80..a91cbe72fc 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -204,7 +204,7 @@ deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do tyCon <- findTypeDecl tyConNm ds go tyCon where - go (DataDeclaration _ Newtype _ tyArgNames [(_, [wrapped])]) + go (DataDeclaration _ Newtype _ tyArgNames [(_, [wrapped])]) = do -- The newtype might not be applied to all type arguments. -- This is okay as long as the newtype wraps something which ends with -- sufficiently many type applications to variables. @@ -214,10 +214,12 @@ deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do -- -- since Array a is a type application which uses the last -- type argument - | Just wrapped' <- stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped = - do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs - wrapped'' <- replaceAllTypeSynonymsM syns wrapped' - return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped''])) + wrapped' <- replaceAllTypeSynonymsM syns wrapped + case stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped' of + Just wrapped'' -> do + let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs + return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped''])) + Nothing -> throwError . errorMessage' ss $ InvalidNewtypeInstance className tys go _ = throwError . errorMessage' ss $ InvalidNewtypeInstance className tys takeReverse :: Int -> [a] -> [a] From 27ad08affe65f004edfc06f9cdb5501c516f667a Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Fri, 27 Apr 2018 05:23:49 -0600 Subject: [PATCH 0978/1580] restrict base (#3294) --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 080f7da111..b5764b7c4c 100644 --- a/package.yaml +++ b/package.yaml @@ -35,7 +35,7 @@ dependencies: - aeson >=1.0 && <1.3 - aeson-better-errors >=0.8 - ansi-terminal >=0.7.1 && <0.8 - - base >=4.8 && <5 + - base >=4.8 && <4.11 - base-compat >=0.6.0 - blaze-html >=0.8.1 && <0.10 - bower-json >=1.0.0.1 && <1.1 From 2c05613544687b7ce19f6f72fcb19ec354ad9369 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 27 Apr 2018 14:43:39 +0100 Subject: [PATCH 0979/1580] Examples is a silly name for tests (#3328) --- .gitignore | 2 +- CONTRIBUTING.md | 4 +- package.yaml | 6 +- src/Language/PureScript/AST/Binders.hs | 2 +- tests/TestCompiler.hs | 6 +- tests/TestDocs.hs | 2 +- tests/TestPsci/EvalTest.hs | 2 +- {examples => tests/purs}/.gitignore | 0 {examples => tests/purs}/docs/bower.json | 0 .../purescript-prelude/src/Prelude.purs | 0 .../purs}/docs/resolutions.json | 0 .../purs}/docs/src/ChildDeclOrder.purs | 0 {examples => tests/purs}/docs/src/Clash.purs | 0 {examples => tests/purs}/docs/src/Clash1.purs | 0 .../purs}/docs/src/Clash1a.purs | 0 {examples => tests/purs}/docs/src/Clash2.purs | 0 .../purs}/docs/src/Clash2a.purs | 0 .../purs}/docs/src/ConstrainedArgument.purs | 0 .../purs}/docs/src/DeclOrder.purs | 0 .../purs}/docs/src/DeclOrderNoExportList.purs | 0 .../purs}/docs/src/Desugar.purs | 0 .../purs}/docs/src/DocComments.purs | 0 .../purs}/docs/src/DuplicateNames.purs | 0 .../purs}/docs/src/Example.purs | 0 .../purs}/docs/src/Example2.purs | 0 .../purs}/docs/src/ExplicitExport.purs | 0 .../docs/src/ExplicitTypeSignatures.purs | 0 .../purs}/docs/src/ImportedTwice.purs | 0 .../purs}/docs/src/ImportedTwiceA.purs | 0 .../purs}/docs/src/ImportedTwiceB.purs | 0 .../purs}/docs/src/MultiVirtual.purs | 0 .../purs}/docs/src/MultiVirtual1.purs | 0 .../purs}/docs/src/MultiVirtual2.purs | 0 .../purs}/docs/src/MultiVirtual3.purs | 0 .../purs}/docs/src/NewOperators.purs | 0 .../purs}/docs/src/NewOperators2.purs | 0 .../purs}/docs/src/NotAllCtors.purs | 0 .../purs}/docs/src/ReExportedTypeClass.purs | 0 .../docs/src/SolitaryTypeClassMember.purs | 0 .../purs}/docs/src/SomeTypeClass.purs | 0 .../purs}/docs/src/Transitive1.purs | 0 .../purs}/docs/src/Transitive2.purs | 0 .../purs}/docs/src/Transitive3.purs | 0 .../purs}/docs/src/TypeClassWithFunDeps.purs | 0 .../docs/src/TypeClassWithoutMembers.purs | 0 .../TypeClassWithoutMembersIntermediate.purs | 0 .../purs}/docs/src/TypeLevelString.purs | 0 .../purs}/docs/src/TypeOpAliases.purs | 0 {examples => tests/purs}/docs/src/UTF8.purs | 0 .../purs}/docs/src/Virtual.purs | 0 {examples => tests/purs}/failing/1071.purs | 0 {examples => tests/purs}/failing/1169.purs | 0 {examples => tests/purs}/failing/1175.purs | 0 {examples => tests/purs}/failing/1310.purs | 0 {examples => tests/purs}/failing/1570.purs | 0 {examples => tests/purs}/failing/1733.purs | 0 .../purs}/failing/1733/Thingy.purs | 0 {examples => tests/purs}/failing/1825.purs | 0 {examples => tests/purs}/failing/1881.purs | 0 .../purs}/failing/2128-class.purs | 0 .../purs}/failing/2128-instance.purs | 0 .../purs}/failing/2197-shouldFail.purs | 0 .../purs}/failing/2197-shouldFail2.purs | 0 {examples => tests/purs}/failing/2378.purs | 0 .../purs}/failing/2378/Lib.purs | 0 {examples => tests/purs}/failing/2379.purs | 0 .../purs}/failing/2379/Lib.purs | 0 {examples => tests/purs}/failing/2434.purs | 0 {examples => tests/purs}/failing/2534.purs | 0 {examples => tests/purs}/failing/2542.purs | 0 {examples => tests/purs}/failing/2567.purs | 0 {examples => tests/purs}/failing/2601.purs | 0 {examples => tests/purs}/failing/2616.purs | 0 {examples => tests/purs}/failing/2806.purs | 0 .../purs}/failing/2874-forall.purs | 0 .../purs}/failing/2874-forall2.purs | 0 .../purs}/failing/2874-wildcard.purs | 0 {examples => tests/purs}/failing/2947.purs | 0 {examples => tests/purs}/failing/3132.purs | 0 .../failing/3275-BindingGroupErrorPos.purs | 0 .../3275-DataBindingGroupErrorPos.purs | 0 {examples => tests/purs}/failing/365.purs | 0 {examples => tests/purs}/failing/438.purs | 0 {examples => tests/purs}/failing/881.purs | 0 .../purs}/failing/AnonArgument1.purs | 0 .../purs}/failing/AnonArgument2.purs | 0 .../purs}/failing/AnonArgument3.purs | 0 .../purs}/failing/ArgLengthMismatch.purs | 14 ++--- .../purs}/failing/ArrayType.purs | 0 {examples => tests/purs}/failing/Arrays.purs | 0 .../purs}/failing/BindInDo-2.purs | 0 .../purs}/failing/BindInDo.purs | 0 .../failing/CannotDeriveNewtypeForData.purs | 0 .../failing/CaseBinderLengthsDiffer.purs | 0 .../CaseDoesNotMatchAllConstructorArgs.purs | 0 .../purs}/failing/ConflictingExports.purs | 0 .../purs}/failing/ConflictingExports/A.purs | 0 .../purs}/failing/ConflictingExports/B.purs | 0 .../purs}/failing/ConflictingImports.purs | 0 .../purs}/failing/ConflictingImports/A.purs | 0 .../purs}/failing/ConflictingImports/B.purs | 0 .../purs}/failing/ConflictingImports2.purs | 0 .../purs}/failing/ConflictingImports2/A.purs | 0 .../purs}/failing/ConflictingImports2/B.purs | 0 .../failing/ConflictingQualifiedImports.purs | 0 .../ConflictingQualifiedImports/A.purs | 0 .../ConflictingQualifiedImports/B.purs | 0 .../failing/ConflictingQualifiedImports2.purs | 0 .../ConflictingQualifiedImports2/A.purs | 0 .../ConflictingQualifiedImports2/B.purs | 0 .../purs}/failing/ConstraintFailure.purs | 0 .../purs}/failing/ConstraintInference.purs | 0 .../failing/DctorOperatorAliasExport.purs | 0 .../purs}/failing/DeclConflictClassCtor.purs | 0 .../failing/DeclConflictClassSynonym.purs | 0 .../purs}/failing/DeclConflictClassType.purs | 0 .../purs}/failing/DeclConflictCtorClass.purs | 0 .../purs}/failing/DeclConflictCtorCtor.purs | 0 .../failing/DeclConflictDuplicateCtor.purs | 0 .../failing/DeclConflictSynonymClass.purs | 0 .../failing/DeclConflictSynonymType.purs | 0 .../purs}/failing/DeclConflictTypeClass.purs | 0 .../failing/DeclConflictTypeSynonym.purs | 0 .../purs}/failing/DeclConflictTypeType.purs | 0 .../purs}/failing/DiffKindsSameName.purs | 0 .../purs}/failing/DiffKindsSameName/LibA.purs | 0 .../purs}/failing/DiffKindsSameName/LibB.purs | 0 {examples => tests/purs}/failing/Do.purs | 0 .../failing/DoNotSuggestComposition.purs | 0 .../failing/DoNotSuggestComposition2.purs | 0 .../failing/DuplicateDeclarationsInLet.purs | 0 .../purs}/failing/DuplicateInstance.purs | 0 .../purs}/failing/DuplicateModule.purs | 0 .../purs}/failing/DuplicateModule/M1.purs | 0 .../purs}/failing/DuplicateProperties.purs | 0 .../purs}/failing/DuplicateTypeClass.purs | 0 .../purs}/failing/DuplicateTypeVars.purs | 0 .../purs}/failing/EmptyCase.purs | 0 .../purs}/failing/EmptyClass.purs | 0 {examples => tests/purs}/failing/EmptyDo.purs | 0 .../purs}/failing/ExpectedWildcard.purs | 0 .../purs}/failing/ExportConflictClass.purs | 0 .../purs}/failing/ExportConflictClass/A.purs | 0 .../purs}/failing/ExportConflictClass/B.purs | 0 .../purs}/failing/ExportConflictCtor.purs | 0 .../purs}/failing/ExportConflictCtor/A.purs | 0 .../purs}/failing/ExportConflictCtor/B.purs | 0 .../purs}/failing/ExportConflictType.purs | 0 .../purs}/failing/ExportConflictType/A.purs | 0 .../purs}/failing/ExportConflictType/B.purs | 0 .../purs}/failing/ExportConflictTypeOp.purs | 0 .../purs}/failing/ExportConflictTypeOp/A.purs | 0 .../purs}/failing/ExportConflictTypeOp/B.purs | 0 .../purs}/failing/ExportConflictValue.purs | 0 .../purs}/failing/ExportConflictValue/A.purs | 0 .../purs}/failing/ExportConflictValue/B.purs | 0 .../purs}/failing/ExportConflictValueOp.purs | 0 .../failing/ExportConflictValueOp/A.purs | 0 .../failing/ExportConflictValueOp/B.purs | 0 .../purs}/failing/ExportExplicit.purs | 16 ++--- .../purs}/failing/ExportExplicit1.purs | 24 ++++---- .../purs}/failing/ExportExplicit1/M1.purs | 6 +- .../purs}/failing/ExportExplicit2.purs | 16 ++--- .../purs}/failing/ExportExplicit3.purs | 20 +++---- .../purs}/failing/ExportExplicit3/M1.purs | 8 +-- .../purs}/failing/ExtraRecordField.purs | 0 .../purs}/failing/ExtraneousClassMember.purs | 0 .../purs}/failing/Foldable.purs | 0 .../purs}/failing/Generalization1.purs | 0 .../purs}/failing/Generalization2.purs | 0 .../purs}/failing/ImportExplicit.purs | 8 +-- .../purs}/failing/ImportExplicit/M1.purs | 6 +- .../purs}/failing/ImportExplicit2.purs | 8 +-- .../purs}/failing/ImportExplicit2/M1.purs | 6 +- .../purs}/failing/ImportHidingModule.purs | 8 +-- .../purs}/failing/ImportHidingModule/A.purs | 4 +- .../purs}/failing/ImportHidingModule/B.purs | 6 +- .../purs}/failing/ImportModule.purs | 8 +-- .../purs}/failing/ImportModule/M2.purs | 6 +- .../purs}/failing/InfiniteKind.purs | 0 .../purs}/failing/InfiniteKind2.purs | 0 .../purs}/failing/InfiniteType.purs | 0 .../InstanceChainBothUnknownAndMatch.purs | 0 .../InstanceChainSkolemUnknownMatch.purs | 0 .../purs}/failing/InstanceExport.purs | 14 ++--- .../InstanceExport/InstanceExport.purs | 22 +++---- .../failing/InstanceSigsBodyIncorrect.purs | 0 .../failing/InstanceSigsDifferentTypes.purs | 0 .../failing/InstanceSigsIncorrectType.purs | 0 .../InstanceSigsOrphanTypeDeclaration.purs | 0 .../purs}/failing/IntOutOfRange.purs | 0 .../purs}/failing/InvalidDerivedInstance.purs | 0 .../failing/InvalidDerivedInstance2.purs | 0 .../failing/InvalidOperatorInBinder.purs | 0 .../purs}/failing/KindError.purs | 0 .../purs}/failing/KindStar.purs | 0 .../purs}/failing/LeadingZeros1.purs | 0 .../purs}/failing/LeadingZeros2.purs | 0 {examples => tests/purs}/failing/Let.purs | 0 .../purs}/failing/LetPatterns1.purs | 0 .../purs}/failing/LetPatterns2.purs | 0 .../purs}/failing/LetPatterns3.purs | 0 .../purs}/failing/LetPatterns4.purs | 0 {examples => tests/purs}/failing/MPTCs.purs | 0 .../purs}/failing/MissingClassExport.purs | 0 .../purs}/failing/MissingClassMember.purs | 0 .../failing/MissingClassMemberExport.purs | 0 .../failing/MissingFFIImplementations.js | 0 .../failing/MissingFFIImplementations.purs | 0 .../purs}/failing/MissingRecordField.purs | 0 .../failing/MixedAssociativityError.purs | 0 .../purs}/failing/MultipleErrors.purs | 0 .../purs}/failing/MultipleErrors2.purs | 0 .../purs}/failing/MultipleTypeOpFixities.purs | 18 +++--- .../failing/MultipleValueOpFixities.purs | 18 +++--- {examples => tests/purs}/failing/MutRec.purs | 0 {examples => tests/purs}/failing/MutRec2.purs | 0 .../purs}/failing/NewtypeInstance.purs | 0 .../purs}/failing/NewtypeInstance2.purs | 0 .../purs}/failing/NewtypeInstance3.purs | 0 .../purs}/failing/NewtypeInstance4.purs | 0 .../purs}/failing/NewtypeInstance5.purs | 0 .../purs}/failing/NewtypeInstance6.purs | 0 .../purs}/failing/NewtypeMultiArgs.purs | 0 .../purs}/failing/NewtypeMultiCtor.purs | 0 .../purs}/failing/NonAssociativeError.purs | 0 .../purs}/failing/NonExhaustivePatGuard.purs | 0 .../purs}/failing/NullaryAbs.purs | 0 {examples => tests/purs}/failing/Object.purs | 0 .../purs}/failing/OperatorAliasNoExport.purs | 0 .../purs}/failing/OperatorSections.purs | 0 .../purs}/failing/OrphanInstance.purs | 14 ++--- .../purs}/failing/OrphanInstance/Class.purs | 8 +-- .../failing/OrphanInstanceFunDepCycle.purs | 0 .../OrphanInstanceFunDepCycle/Lib.purs | 0 .../purs}/failing/OrphanInstanceNullary.purs | 8 +-- .../failing/OrphanInstanceNullary/Lib.purs | 4 +- .../failing/OrphanInstanceWithDetermined.purs | 0 .../OrphanInstanceWithDetermined/Lib.purs | 0 .../purs}/failing/OrphanTypeDecl.purs | 8 +-- .../purs}/failing/OverlapAcrossModules.purs | 0 .../failing/OverlapAcrossModules/Class.purs | 0 .../purs}/failing/OverlapAcrossModules/X.purs | 0 .../purs}/failing/OverlappingArguments.purs | 0 .../purs}/failing/OverlappingBinders.purs | 0 .../purs}/failing/OverlappingInstances.purs | 0 .../purs}/failing/OverlappingVars.purs | 0 .../purs}/failing/PrimModuleReserved.purs | 0 .../failing/PrimModuleReserved/Prim.purs | 0 {examples => tests/purs}/failing/PrimRow.purs | 0 .../purs}/failing/PrimSubModuleReserved.purs | 0 .../PrimSubModuleReserved/Prim_Foobar.purs | 0 .../purs}/failing/ProgrammableTypeErrors.purs | 0 .../ProgrammableTypeErrorsTypeString.purs | 0 .../purs}/failing/Rank2Types.purs | 0 .../purs}/failing/RequiredHiddenType.purs | 18 +++--- .../purs}/failing/Reserved.purs | 0 .../purs}/failing/RowConstructors1.purs | 0 .../purs}/failing/RowConstructors2.purs | 0 .../purs}/failing/RowConstructors3.purs | 0 .../failing/RowInInstanceNotDetermined0.purs | 0 .../failing/RowInInstanceNotDetermined1.purs | 0 .../failing/RowInInstanceNotDetermined2.purs | 0 .../purs}/failing/RowLacks.purs | 0 .../purs}/failing/SkolemEscape.purs | 0 .../purs}/failing/SkolemEscape2.purs | 0 .../purs}/failing/SuggestComposition.purs | 0 .../purs}/failing/Superclasses1.purs | 0 .../purs}/failing/Superclasses2.purs | 0 .../purs}/failing/Superclasses3.purs | 0 .../purs}/failing/Superclasses5.purs | 0 .../failing/TooFewClassInstanceArgs.purs | 0 .../purs}/failing/TopLevelCaseNoArgs.purs | 0 .../purs}/failing/TransitiveDctorExport.purs | 0 .../failing/TransitiveSynonymExport.purs | 0 .../purs}/failing/TypeClasses2.purs | 0 .../purs}/failing/TypeError.purs | 0 .../failing/TypeOperatorAliasNoExport.purs | 0 .../purs}/failing/TypeSynonyms.purs | 0 .../purs}/failing/TypeSynonyms2.purs | 0 .../purs}/failing/TypeSynonyms3.purs | 0 .../purs}/failing/TypeSynonyms4.purs | 0 .../purs}/failing/TypeSynonyms5.purs | 0 .../purs}/failing/TypeWildcards1.purs | 0 .../purs}/failing/TypeWildcards2.purs | 0 .../purs}/failing/TypeWildcards3.purs | 0 .../purs}/failing/TypedBinders.purs | 0 .../purs}/failing/TypedBinders2.purs | 0 .../purs}/failing/TypedBinders3.purs | 0 .../purs}/failing/TypedHole.purs | 0 .../purs}/failing/UnderscoreModuleName.purs | 0 .../purs}/failing/UnknownType.purs | 0 .../failing/UnusableTypeClassMethod.purs | 0 ...usableTypeClassMethodConflictingIdent.purs | 0 .../UnusableTypeClassMethodSynonym.purs | 0 {examples => tests/purs}/passing/1110.purs | 0 {examples => tests/purs}/passing/1185.purs | 0 {examples => tests/purs}/passing/1335.purs | 0 {examples => tests/purs}/passing/1570.purs | 0 {examples => tests/purs}/passing/1664.purs | 0 {examples => tests/purs}/passing/1697.purs | 0 {examples => tests/purs}/passing/1807.purs | 0 {examples => tests/purs}/passing/1881.purs | 0 {examples => tests/purs}/passing/1991.purs | 0 {examples => tests/purs}/passing/2018.purs | 0 {examples => tests/purs}/passing/2018/A.purs | 0 {examples => tests/purs}/passing/2018/B.purs | 0 {examples => tests/purs}/passing/2049.purs | 0 {examples => tests/purs}/passing/2136.purs | 0 {examples => tests/purs}/passing/2138.purs | 0 .../purs}/passing/2138/Lib.purs | 0 {examples => tests/purs}/passing/2172.js | 0 {examples => tests/purs}/passing/2172.purs | 0 {examples => tests/purs}/passing/2197-1.purs | 0 {examples => tests/purs}/passing/2197-2.purs | 0 {examples => tests/purs}/passing/2252.purs | 0 {examples => tests/purs}/passing/2288.purs | 0 {examples => tests/purs}/passing/2378.purs | 0 {examples => tests/purs}/passing/2438.purs | 0 {examples => tests/purs}/passing/2609.purs | 0 {examples => tests/purs}/passing/2609/Eg.purs | 0 {examples => tests/purs}/passing/2616.purs | 0 {examples => tests/purs}/passing/2626.purs | 0 {examples => tests/purs}/passing/2663.purs | 0 {examples => tests/purs}/passing/2689.purs | 0 {examples => tests/purs}/passing/2756.purs | 0 {examples => tests/purs}/passing/2787.purs | 0 {examples => tests/purs}/passing/2795.purs | 0 {examples => tests/purs}/passing/2806.purs | 0 {examples => tests/purs}/passing/2947.purs | 0 {examples => tests/purs}/passing/2958.purs | 0 {examples => tests/purs}/passing/2972.purs | 0 {examples => tests/purs}/passing/3114.purs | 0 .../purs}/passing/3114/VendoredVariant.purs | 0 {examples => tests/purs}/passing/3125.purs | 0 .../purs}/passing/3187-UnusedNameClash.purs | 0 {examples => tests/purs}/passing/652.purs | 0 {examples => tests/purs}/passing/810.purs | 0 {examples => tests/purs}/passing/862.purs | 0 {examples => tests/purs}/passing/922.purs | 0 {examples => tests/purs}/passing/Ado.purs | 0 .../purs}/passing/AppendInReverse.purs | 0 .../purs}/passing/Applicative.purs | 0 .../purs}/passing/ArrayType.purs | 0 {examples => tests/purs}/passing/Auto.purs | 0 .../purs}/passing/AutoPrelude.purs | 22 +++---- .../purs}/passing/AutoPrelude2.purs | 0 .../purs}/passing/BindersInFunctions.purs | 0 .../purs}/passing/BindingGroups.purs | 0 .../purs}/passing/BlockString.purs | 0 .../purs}/passing/CaseInDo.purs | 0 .../purs}/passing/CaseInputWildcard.purs | 0 .../passing/CaseMultipleExpressions.purs | 0 .../purs}/passing/CaseStatement.purs | 0 .../purs}/passing/CheckFunction.purs | 0 .../purs}/passing/CheckSynonymBug.purs | 0 .../purs}/passing/CheckTypeClass.purs | 0 {examples => tests/purs}/passing/Church.purs | 0 .../purs}/passing/ClassRefSyntax.purs | 0 .../purs}/passing/ClassRefSyntax/Lib.purs | 0 {examples => tests/purs}/passing/Collatz.purs | 0 .../purs}/passing/Comparisons.purs | 30 +++++----- .../purs}/passing/Conditional.purs | 0 {examples => tests/purs}/passing/Console.purs | 0 .../purs}/passing/ConstraintInference.purs | 0 .../purs}/passing/ConstraintParens.purs | 0 .../purs}/passing/ConstraintParsingIssue.purs | 0 .../purs}/passing/ContextSimplification.purs | 0 .../purs}/passing/DataAndType.purs | 0 .../passing/DataConsClassConsOverlapOk.purs | 0 .../purs}/passing/DctorName.purs | 0 .../purs}/passing/DctorOperatorAlias.purs | 0 .../passing/DctorOperatorAlias/List.purs | 0 .../purs}/passing/DeepArrayBinder.purs | 0 .../purs}/passing/DeepCase.purs | 0 .../purs}/passing/DeriveNewtype.purs | 0 .../passing/DeriveWithNestedSynonyms.purs | 0 .../purs}/passing/Deriving.purs | 0 .../purs}/passing/DerivingFunctor.purs | 0 {examples => tests/purs}/passing/Do.purs | 0 {examples => tests/purs}/passing/Dollar.purs | 0 .../purs}/passing/DuplicateProperties.purs | 0 {examples => tests/purs}/passing/EffFn.js | 0 {examples => tests/purs}/passing/EffFn.purs | 0 .../purs}/passing/EmptyDataDecls.purs | 0 .../purs}/passing/EmptyRow.purs | 0 .../purs}/passing/EmptyTypeClass.purs | 0 .../purs}/passing/EntailsKindedType.purs | 0 .../purs}/passing/Eq1Deriving.purs | 0 .../purs}/passing/Eq1InEqDeriving.purs | 0 {examples => tests/purs}/passing/EqOrd.purs | 0 .../purs}/passing/ExplicitImportReExport.purs | 22 +++---- .../passing/ExplicitImportReExport/Bar.purs | 6 +- .../passing/ExplicitImportReExport/Foo.purs | 8 +-- .../passing/ExplicitOperatorSections.purs | 0 .../purs}/passing/ExportExplicit.purs | 20 +++---- .../purs}/passing/ExportExplicit/M1.purs | 20 +++---- .../purs}/passing/ExportExplicit2.purs | 16 ++--- .../purs}/passing/ExportExplicit2/M1.purs | 14 ++--- .../passing/ExportedInstanceDeclarations.purs | 0 .../purs}/passing/ExtendedInfixOperators.purs | 0 {examples => tests/purs}/passing/Fib.purs | 0 .../purs}/passing/FieldConsPuns.purs | 26 ++++---- .../purs}/passing/FieldPuns.purs | 20 +++---- .../purs}/passing/FinalTagless.purs | 0 .../purs}/passing/ForeignKind.purs | 0 .../purs}/passing/ForeignKind/Lib.purs | 0 .../purs}/passing/FunWithFunDeps.js | 0 .../purs}/passing/FunWithFunDeps.purs | 0 .../purs}/passing/FunctionScope.purs | 0 .../purs}/passing/FunctionalDependencies.purs | 0 .../purs}/passing/Functions.purs | 0 .../purs}/passing/Functions2.purs | 0 .../purs}/passing/Generalization1.purs | 0 .../purs}/passing/GenericsRep.purs | 0 {examples => tests/purs}/passing/Guards.purs | 0 .../purs}/passing/HasOwnProperty.purs | 0 .../purs}/passing/HoistError.purs | 0 .../purs}/passing/IfThenElseMaybe.purs | 0 .../purs}/passing/IfWildcard.purs | 0 .../purs}/passing/ImplicitEmptyImport.purs | 0 {examples => tests/purs}/passing/Import.purs | 12 ++-- .../purs}/passing/Import/M1.purs | 16 ++--- .../purs}/passing/Import/M2.purs | 12 ++-- .../purs}/passing/ImportExplicit.purs | 20 +++---- .../purs}/passing/ImportExplicit/M1.purs | 8 +-- .../purs}/passing/ImportHiding.purs | 0 .../purs}/passing/ImportQualified.purs | 16 ++--- .../purs}/passing/ImportQualified/M1.purs | 6 +- .../InferRecFunWithConstrainedArgument.purs | 0 .../purs}/passing/InstanceBeforeClass.purs | 0 .../purs}/passing/InstanceChain.purs | 0 .../purs}/passing/InstanceSigs.purs | 0 .../purs}/passing/InstanceSigsGeneral.purs | 0 .../purs}/passing/IntAndChar.purs | 0 .../purs}/passing/JSReserved.purs | 0 .../purs}/passing/KindedType.purs | 0 .../purs}/passing/LargeSumType.purs | 0 {examples => tests/purs}/passing/Let.purs | 0 {examples => tests/purs}/passing/Let2.purs | 0 .../purs}/passing/LetInInstance.purs | 0 .../purs}/passing/LetPattern.purs | 0 .../purs}/passing/LiberalTypeSynonyms.purs | 0 {examples => tests/purs}/passing/MPTCs.purs | 0 {examples => tests/purs}/passing/Match.purs | 0 {examples => tests/purs}/passing/Module.purs | 0 .../purs}/passing/Module/M1.purs | 0 .../purs}/passing/Module/M2.purs | 0 .../purs}/passing/ModuleDeps.purs | 12 ++-- .../purs}/passing/ModuleDeps/M1.purs | 10 ++-- .../purs}/passing/ModuleDeps/M2.purs | 10 ++-- .../purs}/passing/ModuleDeps/M3.purs | 6 +- .../purs}/passing/ModuleExport.purs | 0 .../purs}/passing/ModuleExport/A.purs | 0 .../purs}/passing/ModuleExportDupes.purs | 0 .../purs}/passing/ModuleExportDupes/A.purs | 0 .../purs}/passing/ModuleExportDupes/B.purs | 0 .../purs}/passing/ModuleExportDupes/C.purs | 0 .../purs}/passing/ModuleExportExcluded.purs | 0 .../purs}/passing/ModuleExportExcluded/A.purs | 0 .../purs}/passing/ModuleExportQualified.purs | 0 .../passing/ModuleExportQualified/A.purs | 0 .../purs}/passing/ModuleExportSelf.purs | 0 .../purs}/passing/ModuleExportSelf/A.purs | 10 ++-- {examples => tests/purs}/passing/Monad.purs | 0 .../purs}/passing/MonadState.purs | 0 .../purs}/passing/MultiArgFunctions.purs | 0 {examples => tests/purs}/passing/MutRec.purs | 0 {examples => tests/purs}/passing/MutRec2.purs | 0 {examples => tests/purs}/passing/MutRec3.purs | 0 .../purs}/passing/NakedConstraint.purs | 0 .../purs}/passing/NamedPatterns.purs | 0 .../purs}/passing/NegativeBinder.purs | 0 .../purs}/passing/NegativeIntInRange.purs | 0 {examples => tests/purs}/passing/Nested.purs | 0 .../purs}/passing/NestedRecordUpdate.purs | 0 .../passing/NestedRecordUpdateWildcards.purs | 0 .../purs}/passing/NestedTypeSynonyms.purs | 0 .../purs}/passing/NestedWhere.purs | 0 .../purs}/passing/NewConsClass.purs | 0 {examples => tests/purs}/passing/Newtype.purs | 0 .../purs}/passing/NewtypeClass.purs | 0 .../purs}/passing/NewtypeEff.purs | 0 .../purs}/passing/NewtypeInstance.purs | 0 .../passing/NewtypeWithRecordUpdate.purs | 0 .../purs}/passing/NonConflictingExports.purs | 0 .../passing/NonConflictingExports/A.purs | 0 .../passing/NonOrphanInstanceFunDepExtra.purs | 0 .../NonOrphanInstanceFunDepExtra/Lib.purs | 0 .../purs}/passing/NonOrphanInstanceMulti.purs | 0 .../passing/NonOrphanInstanceMulti/Lib.purs | 0 .../purs}/passing/NumberLiterals.purs | 0 .../purs}/passing/ObjectGetter.purs | 0 .../purs}/passing/ObjectSynonym.purs | 0 .../purs}/passing/ObjectUpdate.purs | 46 +++++++------- .../purs}/passing/ObjectUpdate2.purs | 0 .../purs}/passing/ObjectUpdater.purs | 0 .../purs}/passing/ObjectWildcards.purs | 0 {examples => tests/purs}/passing/Objects.purs | 0 .../purs}/passing/OneConstructor.purs | 0 .../purs}/passing/OperatorAlias.purs | 0 .../purs}/passing/OperatorAliasElsewhere.purs | 0 .../passing/OperatorAliasElsewhere/Def.purs | 8 +-- .../purs}/passing/OperatorAssociativity.purs | 50 ++++++++-------- .../purs}/passing/OperatorInlining.purs | 0 .../purs}/passing/OperatorSections.purs | 0 .../purs}/passing/Operators.purs | 0 .../purs}/passing/Operators/Other.purs | 0 .../purs}/passing/OptimizerBug.purs | 0 .../purs}/passing/OptionalQualified.purs | 0 .../purs}/passing/Ord1Deriving.purs | 0 .../purs}/passing/Ord1InOrdDeriving.purs | 0 .../purs}/passing/ParensInType.purs | 0 .../purs}/passing/ParensInTypedBinder.purs | 0 .../purs}/passing/PartialFunction.purs | 0 .../purs}/passing/Patterns.purs | 0 .../passing/PendingConflictingImports.purs | 0 .../passing/PendingConflictingImports/A.purs | 0 .../passing/PendingConflictingImports/B.purs | 0 .../passing/PendingConflictingImports2.purs | 0 .../passing/PendingConflictingImports2/A.purs | 0 {examples => tests/purs}/passing/Person.purs | 0 .../purs}/passing/PolyLabels.js | 0 .../purs}/passing/PolyLabels.purs | 0 .../purs}/passing/PrimedTypeName.purs | 0 .../purs}/passing/QualifiedNames.purs | 22 +++---- .../purs}/passing/QualifiedNames/Either.purs | 10 ++-- .../passing/QualifiedQualifiedImports.purs | 0 .../purs}/passing/Rank2Data.purs | 60 +++++++++---------- .../purs}/passing/Rank2Object.purs | 0 .../purs}/passing/Rank2TypeSynonym.purs | 0 .../purs}/passing/Rank2Types.purs | 0 .../purs}/passing/ReExportQualified.purs | 0 .../purs}/passing/ReExportQualified/A.purs | 0 .../purs}/passing/ReExportQualified/B.purs | 0 .../purs}/passing/ReExportQualified/C.purs | 0 .../purs}/passing/RebindableSyntax.purs | 0 .../purs}/passing/Recursion.purs | 0 .../purs}/passing/RedefinedFixity.purs | 12 ++-- .../purs}/passing/RedefinedFixity/M1.purs | 12 ++-- .../purs}/passing/RedefinedFixity/M2.purs | 10 ++-- .../purs}/passing/RedefinedFixity/M3.purs | 12 ++-- .../purs}/passing/ReservedWords.purs | 0 .../passing/ResolvableScopeConflict.purs | 0 .../passing/ResolvableScopeConflict/A.purs | 0 .../passing/ResolvableScopeConflict/B.purs | 0 .../passing/ResolvableScopeConflict2.purs | 0 .../passing/ResolvableScopeConflict2/A.purs | 0 .../passing/ResolvableScopeConflict3.purs | 0 .../passing/ResolvableScopeConflict3/A.purs | 0 .../purs}/passing/RowConstructors.purs | 0 .../passing/RowInInstanceHeadDetermined.purs | 0 .../purs}/passing/RowLacks.purs | 0 {examples => tests/purs}/passing/RowNub.purs | 0 .../purs}/passing/RowPolyInstanceContext.purs | 0 {examples => tests/purs}/passing/RowUnion.js | 0 .../purs}/passing/RowUnion.purs | 0 .../purs}/passing/RowsInInstanceContext.purs | 0 .../purs}/passing/RunFnInline.purs | 0 .../purs}/passing/RuntimeScopeIssue.purs | 0 .../purs}/passing/ScopedTypeVariables.purs | 0 .../purs}/passing/Sequence.purs | 0 .../purs}/passing/SequenceDesugared.purs | 0 .../purs}/passing/ShadowedModuleName.purs | 0 .../passing/ShadowedModuleName/Test.purs | 0 .../purs}/passing/ShadowedName.purs | 22 +++---- .../purs}/passing/ShadowedRename.purs | 0 .../purs}/passing/ShadowedTCO.purs | 42 ++++++------- .../purs}/passing/ShadowedTCOLet.purs | 30 +++++----- .../purs}/passing/SignedNumericLiterals.purs | 0 .../purs}/passing/SolvingAppendSymbol.purs | 0 .../purs}/passing/SolvingCompareSymbol.purs | 0 .../purs}/passing/SolvingIsSymbol.purs | 0 .../purs}/passing/SolvingIsSymbol/Lib.purs | 0 {examples => tests/purs}/passing/Stream.purs | 0 .../purs}/passing/StringEdgeCases.purs | 0 .../passing/StringEdgeCases/Records.purs | 0 .../passing/StringEdgeCases/Symbols.purs | 0 .../purs}/passing/StringEscapes.purs | 0 .../purs}/passing/Superclasses1.purs | 0 .../purs}/passing/Superclasses3.purs | 0 {examples => tests/purs}/passing/TCO.purs | 0 {examples => tests/purs}/passing/TCOCase.purs | 0 .../purs}/passing/TailCall.purs | 0 {examples => tests/purs}/passing/Tick.purs | 0 .../purs}/passing/TopLevelCase.purs | 0 .../purs}/passing/TransitiveImport.purs | 0 .../passing/TransitiveImport/Middle.purs | 0 .../purs}/passing/TransitiveImport/Test.purs | 0 .../passing/TypeClassMemberOrderChange.purs | 32 +++++----- .../purs}/passing/TypeClasses.purs | 0 .../purs}/passing/TypeClassesInOrder.purs | 0 ...peClassesWithOverlappingTypeVariables.purs | 0 .../purs}/passing/TypeDecl.purs | 0 .../purs}/passing/TypeOperators.purs | 0 .../purs}/passing/TypeOperators/A.purs | 0 .../purs}/passing/TypeSynonymInData.purs | 0 .../purs}/passing/TypeSynonyms.purs | 0 .../purs}/passing/TypeWildcards.purs | 0 .../passing/TypeWildcardsRecordExtension.purs | 0 .../purs}/passing/TypeWithoutParens.purs | 0 .../purs}/passing/TypeWithoutParens/Lib.purs | 0 .../purs}/passing/TypedBinders.purs | 0 .../purs}/passing/TypedWhere.purs | 0 .../purs}/passing/UTF8Sourcefile.purs | 16 ++--- .../purs}/passing/UnderscoreIdent.purs | 0 .../purs}/passing/UnicodeIdentifier.purs | 0 .../purs}/passing/UnicodeOperators.purs | 0 .../purs}/passing/UnicodeType.purs | 0 .../passing/UnifyInTypeInstanceLookup.purs | 0 {examples => tests/purs}/passing/Unit.purs | 0 .../passing/UnknownInTypeClassLookup.purs | 0 .../purs}/passing/UnsafeCoerce.purs | 0 .../purs}/passing/UntupledConstraints.purs | 0 .../purs}/passing/UsableTypeClassMethods.purs | 0 {examples => tests/purs}/passing/Where.purs | 0 .../purs}/passing/WildcardInInstance.purs | 0 .../purs}/passing/WildcardType.purs | 24 ++++---- {examples => tests/purs}/passing/iota.purs | 0 {examples => tests/purs}/passing/s.purs | 0 {examples => tests/purs}/psci/BasicEval.purs | 0 {examples => tests/purs}/psci/Multiline.purs | 0 {examples => tests/purs}/warning/2140.purs | 0 {examples => tests/purs}/warning/2383.purs | 0 {examples => tests/purs}/warning/2411.purs | 0 {examples => tests/purs}/warning/2542.purs | 0 .../purs}/warning/CustomWarning.purs | 0 .../purs}/warning/CustomWarning2.purs | 0 .../purs}/warning/CustomWarning3.purs | 0 .../purs}/warning/DuplicateExportRef.purs | 0 .../purs}/warning/DuplicateImport.purs | 0 .../purs}/warning/DuplicateImportRef.purs | 0 .../warning/DuplicateSelectiveImport.purs | 0 .../purs}/warning/HidingImport.purs | 0 .../purs}/warning/ImplicitImport.purs | 0 .../warning/ImplicitQualifiedImport.purs | 0 .../ImplicitQualifiedImportReExport.purs | 0 .../purs}/warning/MissingTypeDeclaration.purs | 0 .../purs}/warning/NewtypeInstance.purs | 0 .../purs}/warning/NewtypeInstance2.purs | 0 .../purs}/warning/NewtypeInstance3.purs | 0 .../purs}/warning/NewtypeInstance4.purs | 0 .../purs}/warning/OverlappingPattern.purs | 0 .../purs}/warning/ScopeShadowing.purs | 0 .../purs}/warning/ScopeShadowing2.purs | 0 .../warning/ShadowedBinderPatternGuard.purs | 0 .../purs}/warning/ShadowedNameParens.purs | 0 .../purs}/warning/ShadowedTypeVar.purs | 0 .../purs}/warning/UnnecessaryFFIModule.js | 0 .../purs}/warning/UnnecessaryFFIModule.purs | 0 .../warning/UnusedDctorExplicitImport.purs | 0 .../purs}/warning/UnusedDctorImportAll.purs | 0 .../warning/UnusedDctorImportExplicit.purs | 0 .../purs}/warning/UnusedExplicitImport.purs | 0 .../warning/UnusedExplicitImportTypeOp.purs | 0 .../UnusedExplicitImportTypeOp/Lib.purs | 0 .../warning/UnusedExplicitImportValOp.purs | 0 .../purs}/warning/UnusedFFIImplementations.js | 0 .../warning/UnusedFFIImplementations.purs | 0 .../purs}/warning/UnusedImport.purs | 0 .../purs}/warning/UnusedTypeVar.purs | 0 .../purs}/warning/WildcardInferredType.purs | 0 662 files changed, 535 insertions(+), 535 deletions(-) rename {examples => tests/purs}/.gitignore (100%) rename {examples => tests/purs}/docs/bower.json (100%) rename {examples => tests/purs}/docs/bower_components/purescript-prelude/src/Prelude.purs (100%) rename {examples => tests/purs}/docs/resolutions.json (100%) rename {examples => tests/purs}/docs/src/ChildDeclOrder.purs (100%) rename {examples => tests/purs}/docs/src/Clash.purs (100%) rename {examples => tests/purs}/docs/src/Clash1.purs (100%) rename {examples => tests/purs}/docs/src/Clash1a.purs (100%) rename {examples => tests/purs}/docs/src/Clash2.purs (100%) rename {examples => tests/purs}/docs/src/Clash2a.purs (100%) rename {examples => tests/purs}/docs/src/ConstrainedArgument.purs (100%) rename {examples => tests/purs}/docs/src/DeclOrder.purs (100%) rename {examples => tests/purs}/docs/src/DeclOrderNoExportList.purs (100%) rename {examples => tests/purs}/docs/src/Desugar.purs (100%) rename {examples => tests/purs}/docs/src/DocComments.purs (100%) rename {examples => tests/purs}/docs/src/DuplicateNames.purs (100%) rename {examples => tests/purs}/docs/src/Example.purs (100%) rename {examples => tests/purs}/docs/src/Example2.purs (100%) rename {examples => tests/purs}/docs/src/ExplicitExport.purs (100%) rename {examples => tests/purs}/docs/src/ExplicitTypeSignatures.purs (100%) rename {examples => tests/purs}/docs/src/ImportedTwice.purs (100%) rename {examples => tests/purs}/docs/src/ImportedTwiceA.purs (100%) rename {examples => tests/purs}/docs/src/ImportedTwiceB.purs (100%) rename {examples => tests/purs}/docs/src/MultiVirtual.purs (100%) rename {examples => tests/purs}/docs/src/MultiVirtual1.purs (100%) rename {examples => tests/purs}/docs/src/MultiVirtual2.purs (100%) rename {examples => tests/purs}/docs/src/MultiVirtual3.purs (100%) rename {examples => tests/purs}/docs/src/NewOperators.purs (100%) rename {examples => tests/purs}/docs/src/NewOperators2.purs (100%) rename {examples => tests/purs}/docs/src/NotAllCtors.purs (100%) rename {examples => tests/purs}/docs/src/ReExportedTypeClass.purs (100%) rename {examples => tests/purs}/docs/src/SolitaryTypeClassMember.purs (100%) rename {examples => tests/purs}/docs/src/SomeTypeClass.purs (100%) rename {examples => tests/purs}/docs/src/Transitive1.purs (100%) rename {examples => tests/purs}/docs/src/Transitive2.purs (100%) rename {examples => tests/purs}/docs/src/Transitive3.purs (100%) rename {examples => tests/purs}/docs/src/TypeClassWithFunDeps.purs (100%) rename {examples => tests/purs}/docs/src/TypeClassWithoutMembers.purs (100%) rename {examples => tests/purs}/docs/src/TypeClassWithoutMembersIntermediate.purs (100%) rename {examples => tests/purs}/docs/src/TypeLevelString.purs (100%) rename {examples => tests/purs}/docs/src/TypeOpAliases.purs (100%) rename {examples => tests/purs}/docs/src/UTF8.purs (100%) rename {examples => tests/purs}/docs/src/Virtual.purs (100%) rename {examples => tests/purs}/failing/1071.purs (100%) rename {examples => tests/purs}/failing/1169.purs (100%) rename {examples => tests/purs}/failing/1175.purs (100%) rename {examples => tests/purs}/failing/1310.purs (100%) rename {examples => tests/purs}/failing/1570.purs (100%) rename {examples => tests/purs}/failing/1733.purs (100%) rename {examples => tests/purs}/failing/1733/Thingy.purs (100%) rename {examples => tests/purs}/failing/1825.purs (100%) rename {examples => tests/purs}/failing/1881.purs (100%) rename {examples => tests/purs}/failing/2128-class.purs (100%) rename {examples => tests/purs}/failing/2128-instance.purs (100%) rename {examples => tests/purs}/failing/2197-shouldFail.purs (100%) rename {examples => tests/purs}/failing/2197-shouldFail2.purs (100%) rename {examples => tests/purs}/failing/2378.purs (100%) rename {examples => tests/purs}/failing/2378/Lib.purs (100%) rename {examples => tests/purs}/failing/2379.purs (100%) rename {examples => tests/purs}/failing/2379/Lib.purs (100%) rename {examples => tests/purs}/failing/2434.purs (100%) rename {examples => tests/purs}/failing/2534.purs (100%) rename {examples => tests/purs}/failing/2542.purs (100%) rename {examples => tests/purs}/failing/2567.purs (100%) rename {examples => tests/purs}/failing/2601.purs (100%) rename {examples => tests/purs}/failing/2616.purs (100%) rename {examples => tests/purs}/failing/2806.purs (100%) rename {examples => tests/purs}/failing/2874-forall.purs (100%) rename {examples => tests/purs}/failing/2874-forall2.purs (100%) rename {examples => tests/purs}/failing/2874-wildcard.purs (100%) rename {examples => tests/purs}/failing/2947.purs (100%) rename {examples => tests/purs}/failing/3132.purs (100%) rename {examples => tests/purs}/failing/3275-BindingGroupErrorPos.purs (100%) rename {examples => tests/purs}/failing/3275-DataBindingGroupErrorPos.purs (100%) rename {examples => tests/purs}/failing/365.purs (100%) rename {examples => tests/purs}/failing/438.purs (100%) rename {examples => tests/purs}/failing/881.purs (100%) rename {examples => tests/purs}/failing/AnonArgument1.purs (100%) rename {examples => tests/purs}/failing/AnonArgument2.purs (100%) rename {examples => tests/purs}/failing/AnonArgument3.purs (100%) rename {examples => tests/purs}/failing/ArgLengthMismatch.purs (94%) rename {examples => tests/purs}/failing/ArrayType.purs (100%) rename {examples => tests/purs}/failing/Arrays.purs (100%) rename {examples => tests/purs}/failing/BindInDo-2.purs (100%) rename {examples => tests/purs}/failing/BindInDo.purs (100%) rename {examples => tests/purs}/failing/CannotDeriveNewtypeForData.purs (100%) rename {examples => tests/purs}/failing/CaseBinderLengthsDiffer.purs (100%) rename {examples => tests/purs}/failing/CaseDoesNotMatchAllConstructorArgs.purs (100%) rename {examples => tests/purs}/failing/ConflictingExports.purs (100%) rename {examples => tests/purs}/failing/ConflictingExports/A.purs (100%) rename {examples => tests/purs}/failing/ConflictingExports/B.purs (100%) rename {examples => tests/purs}/failing/ConflictingImports.purs (100%) rename {examples => tests/purs}/failing/ConflictingImports/A.purs (100%) rename {examples => tests/purs}/failing/ConflictingImports/B.purs (100%) rename {examples => tests/purs}/failing/ConflictingImports2.purs (100%) rename {examples => tests/purs}/failing/ConflictingImports2/A.purs (100%) rename {examples => tests/purs}/failing/ConflictingImports2/B.purs (100%) rename {examples => tests/purs}/failing/ConflictingQualifiedImports.purs (100%) rename {examples => tests/purs}/failing/ConflictingQualifiedImports/A.purs (100%) rename {examples => tests/purs}/failing/ConflictingQualifiedImports/B.purs (100%) rename {examples => tests/purs}/failing/ConflictingQualifiedImports2.purs (100%) rename {examples => tests/purs}/failing/ConflictingQualifiedImports2/A.purs (100%) rename {examples => tests/purs}/failing/ConflictingQualifiedImports2/B.purs (100%) rename {examples => tests/purs}/failing/ConstraintFailure.purs (100%) rename {examples => tests/purs}/failing/ConstraintInference.purs (100%) rename {examples => tests/purs}/failing/DctorOperatorAliasExport.purs (100%) rename {examples => tests/purs}/failing/DeclConflictClassCtor.purs (100%) rename {examples => tests/purs}/failing/DeclConflictClassSynonym.purs (100%) rename {examples => tests/purs}/failing/DeclConflictClassType.purs (100%) rename {examples => tests/purs}/failing/DeclConflictCtorClass.purs (100%) rename {examples => tests/purs}/failing/DeclConflictCtorCtor.purs (100%) rename {examples => tests/purs}/failing/DeclConflictDuplicateCtor.purs (100%) rename {examples => tests/purs}/failing/DeclConflictSynonymClass.purs (100%) rename {examples => tests/purs}/failing/DeclConflictSynonymType.purs (100%) rename {examples => tests/purs}/failing/DeclConflictTypeClass.purs (100%) rename {examples => tests/purs}/failing/DeclConflictTypeSynonym.purs (100%) rename {examples => tests/purs}/failing/DeclConflictTypeType.purs (100%) rename {examples => tests/purs}/failing/DiffKindsSameName.purs (100%) rename {examples => tests/purs}/failing/DiffKindsSameName/LibA.purs (100%) rename {examples => tests/purs}/failing/DiffKindsSameName/LibB.purs (100%) rename {examples => tests/purs}/failing/Do.purs (100%) rename {examples => tests/purs}/failing/DoNotSuggestComposition.purs (100%) rename {examples => tests/purs}/failing/DoNotSuggestComposition2.purs (100%) rename {examples => tests/purs}/failing/DuplicateDeclarationsInLet.purs (100%) rename {examples => tests/purs}/failing/DuplicateInstance.purs (100%) rename {examples => tests/purs}/failing/DuplicateModule.purs (100%) rename {examples => tests/purs}/failing/DuplicateModule/M1.purs (100%) rename {examples => tests/purs}/failing/DuplicateProperties.purs (100%) rename {examples => tests/purs}/failing/DuplicateTypeClass.purs (100%) rename {examples => tests/purs}/failing/DuplicateTypeVars.purs (100%) rename {examples => tests/purs}/failing/EmptyCase.purs (100%) rename {examples => tests/purs}/failing/EmptyClass.purs (100%) rename {examples => tests/purs}/failing/EmptyDo.purs (100%) rename {examples => tests/purs}/failing/ExpectedWildcard.purs (100%) rename {examples => tests/purs}/failing/ExportConflictClass.purs (100%) rename {examples => tests/purs}/failing/ExportConflictClass/A.purs (100%) rename {examples => tests/purs}/failing/ExportConflictClass/B.purs (100%) rename {examples => tests/purs}/failing/ExportConflictCtor.purs (100%) rename {examples => tests/purs}/failing/ExportConflictCtor/A.purs (100%) rename {examples => tests/purs}/failing/ExportConflictCtor/B.purs (100%) rename {examples => tests/purs}/failing/ExportConflictType.purs (100%) rename {examples => tests/purs}/failing/ExportConflictType/A.purs (100%) rename {examples => tests/purs}/failing/ExportConflictType/B.purs (100%) rename {examples => tests/purs}/failing/ExportConflictTypeOp.purs (100%) rename {examples => tests/purs}/failing/ExportConflictTypeOp/A.purs (100%) rename {examples => tests/purs}/failing/ExportConflictTypeOp/B.purs (100%) rename {examples => tests/purs}/failing/ExportConflictValue.purs (100%) rename {examples => tests/purs}/failing/ExportConflictValue/A.purs (100%) rename {examples => tests/purs}/failing/ExportConflictValue/B.purs (100%) rename {examples => tests/purs}/failing/ExportConflictValueOp.purs (100%) rename {examples => tests/purs}/failing/ExportConflictValueOp/A.purs (100%) rename {examples => tests/purs}/failing/ExportConflictValueOp/B.purs (100%) rename {examples => tests/purs}/failing/ExportExplicit.purs (94%) rename {examples => tests/purs}/failing/ExportExplicit1.purs (93%) rename {examples => tests/purs}/failing/ExportExplicit1/M1.purs (92%) rename {examples => tests/purs}/failing/ExportExplicit2.purs (95%) rename {examples => tests/purs}/failing/ExportExplicit3.purs (94%) rename {examples => tests/purs}/failing/ExportExplicit3/M1.purs (92%) rename {examples => tests/purs}/failing/ExtraRecordField.purs (100%) rename {examples => tests/purs}/failing/ExtraneousClassMember.purs (100%) rename {examples => tests/purs}/failing/Foldable.purs (100%) rename {examples => tests/purs}/failing/Generalization1.purs (100%) rename {examples => tests/purs}/failing/Generalization2.purs (100%) rename {examples => tests/purs}/failing/ImportExplicit.purs (94%) rename {examples => tests/purs}/failing/ImportExplicit/M1.purs (90%) rename {examples => tests/purs}/failing/ImportExplicit2.purs (95%) rename {examples => tests/purs}/failing/ImportExplicit2/M1.purs (90%) rename {examples => tests/purs}/failing/ImportHidingModule.purs (95%) rename {examples => tests/purs}/failing/ImportHidingModule/A.purs (91%) rename {examples => tests/purs}/failing/ImportHidingModule/B.purs (94%) rename {examples => tests/purs}/failing/ImportModule.purs (94%) rename {examples => tests/purs}/failing/ImportModule/M2.purs (90%) rename {examples => tests/purs}/failing/InfiniteKind.purs (100%) rename {examples => tests/purs}/failing/InfiniteKind2.purs (100%) rename {examples => tests/purs}/failing/InfiniteType.purs (100%) rename {examples => tests/purs}/failing/InstanceChainBothUnknownAndMatch.purs (100%) rename {examples => tests/purs}/failing/InstanceChainSkolemUnknownMatch.purs (100%) rename {examples => tests/purs}/failing/InstanceExport.purs (94%) rename {examples => tests/purs}/failing/InstanceExport/InstanceExport.purs (93%) rename {examples => tests/purs}/failing/InstanceSigsBodyIncorrect.purs (100%) rename {examples => tests/purs}/failing/InstanceSigsDifferentTypes.purs (100%) rename {examples => tests/purs}/failing/InstanceSigsIncorrectType.purs (100%) rename {examples => tests/purs}/failing/InstanceSigsOrphanTypeDeclaration.purs (100%) rename {examples => tests/purs}/failing/IntOutOfRange.purs (100%) rename {examples => tests/purs}/failing/InvalidDerivedInstance.purs (100%) rename {examples => tests/purs}/failing/InvalidDerivedInstance2.purs (100%) rename {examples => tests/purs}/failing/InvalidOperatorInBinder.purs (100%) rename {examples => tests/purs}/failing/KindError.purs (100%) rename {examples => tests/purs}/failing/KindStar.purs (100%) rename {examples => tests/purs}/failing/LeadingZeros1.purs (100%) rename {examples => tests/purs}/failing/LeadingZeros2.purs (100%) rename {examples => tests/purs}/failing/Let.purs (100%) rename {examples => tests/purs}/failing/LetPatterns1.purs (100%) rename {examples => tests/purs}/failing/LetPatterns2.purs (100%) rename {examples => tests/purs}/failing/LetPatterns3.purs (100%) rename {examples => tests/purs}/failing/LetPatterns4.purs (100%) rename {examples => tests/purs}/failing/MPTCs.purs (100%) rename {examples => tests/purs}/failing/MissingClassExport.purs (100%) rename {examples => tests/purs}/failing/MissingClassMember.purs (100%) rename {examples => tests/purs}/failing/MissingClassMemberExport.purs (100%) rename {examples => tests/purs}/failing/MissingFFIImplementations.js (100%) rename {examples => tests/purs}/failing/MissingFFIImplementations.purs (100%) rename {examples => tests/purs}/failing/MissingRecordField.purs (100%) rename {examples => tests/purs}/failing/MixedAssociativityError.purs (100%) rename {examples => tests/purs}/failing/MultipleErrors.purs (100%) rename {examples => tests/purs}/failing/MultipleErrors2.purs (100%) rename {examples => tests/purs}/failing/MultipleTypeOpFixities.purs (94%) rename {examples => tests/purs}/failing/MultipleValueOpFixities.purs (94%) rename {examples => tests/purs}/failing/MutRec.purs (100%) rename {examples => tests/purs}/failing/MutRec2.purs (100%) rename {examples => tests/purs}/failing/NewtypeInstance.purs (100%) rename {examples => tests/purs}/failing/NewtypeInstance2.purs (100%) rename {examples => tests/purs}/failing/NewtypeInstance3.purs (100%) rename {examples => tests/purs}/failing/NewtypeInstance4.purs (100%) rename {examples => tests/purs}/failing/NewtypeInstance5.purs (100%) rename {examples => tests/purs}/failing/NewtypeInstance6.purs (100%) rename {examples => tests/purs}/failing/NewtypeMultiArgs.purs (100%) rename {examples => tests/purs}/failing/NewtypeMultiCtor.purs (100%) rename {examples => tests/purs}/failing/NonAssociativeError.purs (100%) rename {examples => tests/purs}/failing/NonExhaustivePatGuard.purs (100%) rename {examples => tests/purs}/failing/NullaryAbs.purs (100%) rename {examples => tests/purs}/failing/Object.purs (100%) rename {examples => tests/purs}/failing/OperatorAliasNoExport.purs (100%) rename {examples => tests/purs}/failing/OperatorSections.purs (100%) rename {examples => tests/purs}/failing/OrphanInstance.purs (94%) rename {examples => tests/purs}/failing/OrphanInstance/Class.purs (92%) rename {examples => tests/purs}/failing/OrphanInstanceFunDepCycle.purs (100%) rename {examples => tests/purs}/failing/OrphanInstanceFunDepCycle/Lib.purs (100%) rename {examples => tests/purs}/failing/OrphanInstanceNullary.purs (95%) rename {examples => tests/purs}/failing/OrphanInstanceNullary/Lib.purs (92%) rename {examples => tests/purs}/failing/OrphanInstanceWithDetermined.purs (100%) rename {examples => tests/purs}/failing/OrphanInstanceWithDetermined/Lib.purs (100%) rename {examples => tests/purs}/failing/OrphanTypeDecl.purs (95%) rename {examples => tests/purs}/failing/OverlapAcrossModules.purs (100%) rename {examples => tests/purs}/failing/OverlapAcrossModules/Class.purs (100%) rename {examples => tests/purs}/failing/OverlapAcrossModules/X.purs (100%) rename {examples => tests/purs}/failing/OverlappingArguments.purs (100%) rename {examples => tests/purs}/failing/OverlappingBinders.purs (100%) rename {examples => tests/purs}/failing/OverlappingInstances.purs (100%) rename {examples => tests/purs}/failing/OverlappingVars.purs (100%) rename {examples => tests/purs}/failing/PrimModuleReserved.purs (100%) rename {examples => tests/purs}/failing/PrimModuleReserved/Prim.purs (100%) rename {examples => tests/purs}/failing/PrimRow.purs (100%) rename {examples => tests/purs}/failing/PrimSubModuleReserved.purs (100%) rename {examples => tests/purs}/failing/PrimSubModuleReserved/Prim_Foobar.purs (100%) rename {examples => tests/purs}/failing/ProgrammableTypeErrors.purs (100%) rename {examples => tests/purs}/failing/ProgrammableTypeErrorsTypeString.purs (100%) rename {examples => tests/purs}/failing/Rank2Types.purs (100%) rename {examples => tests/purs}/failing/RequiredHiddenType.purs (94%) rename {examples => tests/purs}/failing/Reserved.purs (100%) rename {examples => tests/purs}/failing/RowConstructors1.purs (100%) rename {examples => tests/purs}/failing/RowConstructors2.purs (100%) rename {examples => tests/purs}/failing/RowConstructors3.purs (100%) rename {examples => tests/purs}/failing/RowInInstanceNotDetermined0.purs (100%) rename {examples => tests/purs}/failing/RowInInstanceNotDetermined1.purs (100%) rename {examples => tests/purs}/failing/RowInInstanceNotDetermined2.purs (100%) rename {examples => tests/purs}/failing/RowLacks.purs (100%) rename {examples => tests/purs}/failing/SkolemEscape.purs (100%) rename {examples => tests/purs}/failing/SkolemEscape2.purs (100%) rename {examples => tests/purs}/failing/SuggestComposition.purs (100%) rename {examples => tests/purs}/failing/Superclasses1.purs (100%) rename {examples => tests/purs}/failing/Superclasses2.purs (100%) rename {examples => tests/purs}/failing/Superclasses3.purs (100%) rename {examples => tests/purs}/failing/Superclasses5.purs (100%) rename {examples => tests/purs}/failing/TooFewClassInstanceArgs.purs (100%) rename {examples => tests/purs}/failing/TopLevelCaseNoArgs.purs (100%) rename {examples => tests/purs}/failing/TransitiveDctorExport.purs (100%) rename {examples => tests/purs}/failing/TransitiveSynonymExport.purs (100%) rename {examples => tests/purs}/failing/TypeClasses2.purs (100%) rename {examples => tests/purs}/failing/TypeError.purs (100%) rename {examples => tests/purs}/failing/TypeOperatorAliasNoExport.purs (100%) rename {examples => tests/purs}/failing/TypeSynonyms.purs (100%) rename {examples => tests/purs}/failing/TypeSynonyms2.purs (100%) rename {examples => tests/purs}/failing/TypeSynonyms3.purs (100%) rename {examples => tests/purs}/failing/TypeSynonyms4.purs (100%) rename {examples => tests/purs}/failing/TypeSynonyms5.purs (100%) rename {examples => tests/purs}/failing/TypeWildcards1.purs (100%) rename {examples => tests/purs}/failing/TypeWildcards2.purs (100%) rename {examples => tests/purs}/failing/TypeWildcards3.purs (100%) rename {examples => tests/purs}/failing/TypedBinders.purs (100%) rename {examples => tests/purs}/failing/TypedBinders2.purs (100%) rename {examples => tests/purs}/failing/TypedBinders3.purs (100%) rename {examples => tests/purs}/failing/TypedHole.purs (100%) rename {examples => tests/purs}/failing/UnderscoreModuleName.purs (100%) rename {examples => tests/purs}/failing/UnknownType.purs (100%) rename {examples => tests/purs}/failing/UnusableTypeClassMethod.purs (100%) rename {examples => tests/purs}/failing/UnusableTypeClassMethodConflictingIdent.purs (100%) rename {examples => tests/purs}/failing/UnusableTypeClassMethodSynonym.purs (100%) rename {examples => tests/purs}/passing/1110.purs (100%) rename {examples => tests/purs}/passing/1185.purs (100%) rename {examples => tests/purs}/passing/1335.purs (100%) rename {examples => tests/purs}/passing/1570.purs (100%) rename {examples => tests/purs}/passing/1664.purs (100%) rename {examples => tests/purs}/passing/1697.purs (100%) rename {examples => tests/purs}/passing/1807.purs (100%) rename {examples => tests/purs}/passing/1881.purs (100%) rename {examples => tests/purs}/passing/1991.purs (100%) rename {examples => tests/purs}/passing/2018.purs (100%) rename {examples => tests/purs}/passing/2018/A.purs (100%) rename {examples => tests/purs}/passing/2018/B.purs (100%) rename {examples => tests/purs}/passing/2049.purs (100%) rename {examples => tests/purs}/passing/2136.purs (100%) rename {examples => tests/purs}/passing/2138.purs (100%) rename {examples => tests/purs}/passing/2138/Lib.purs (100%) rename {examples => tests/purs}/passing/2172.js (100%) rename {examples => tests/purs}/passing/2172.purs (100%) rename {examples => tests/purs}/passing/2197-1.purs (100%) rename {examples => tests/purs}/passing/2197-2.purs (100%) rename {examples => tests/purs}/passing/2252.purs (100%) rename {examples => tests/purs}/passing/2288.purs (100%) rename {examples => tests/purs}/passing/2378.purs (100%) rename {examples => tests/purs}/passing/2438.purs (100%) rename {examples => tests/purs}/passing/2609.purs (100%) rename {examples => tests/purs}/passing/2609/Eg.purs (100%) rename {examples => tests/purs}/passing/2616.purs (100%) rename {examples => tests/purs}/passing/2626.purs (100%) rename {examples => tests/purs}/passing/2663.purs (100%) rename {examples => tests/purs}/passing/2689.purs (100%) rename {examples => tests/purs}/passing/2756.purs (100%) rename {examples => tests/purs}/passing/2787.purs (100%) rename {examples => tests/purs}/passing/2795.purs (100%) rename {examples => tests/purs}/passing/2806.purs (100%) rename {examples => tests/purs}/passing/2947.purs (100%) rename {examples => tests/purs}/passing/2958.purs (100%) rename {examples => tests/purs}/passing/2972.purs (100%) rename {examples => tests/purs}/passing/3114.purs (100%) rename {examples => tests/purs}/passing/3114/VendoredVariant.purs (100%) rename {examples => tests/purs}/passing/3125.purs (100%) rename {examples => tests/purs}/passing/3187-UnusedNameClash.purs (100%) rename {examples => tests/purs}/passing/652.purs (100%) rename {examples => tests/purs}/passing/810.purs (100%) rename {examples => tests/purs}/passing/862.purs (100%) rename {examples => tests/purs}/passing/922.purs (100%) rename {examples => tests/purs}/passing/Ado.purs (100%) rename {examples => tests/purs}/passing/AppendInReverse.purs (100%) rename {examples => tests/purs}/passing/Applicative.purs (100%) rename {examples => tests/purs}/passing/ArrayType.purs (100%) rename {examples => tests/purs}/passing/Auto.purs (100%) rename {examples => tests/purs}/passing/AutoPrelude.purs (93%) rename {examples => tests/purs}/passing/AutoPrelude2.purs (100%) rename {examples => tests/purs}/passing/BindersInFunctions.purs (100%) rename {examples => tests/purs}/passing/BindingGroups.purs (100%) rename {examples => tests/purs}/passing/BlockString.purs (100%) rename {examples => tests/purs}/passing/CaseInDo.purs (100%) rename {examples => tests/purs}/passing/CaseInputWildcard.purs (100%) rename {examples => tests/purs}/passing/CaseMultipleExpressions.purs (100%) rename {examples => tests/purs}/passing/CaseStatement.purs (100%) rename {examples => tests/purs}/passing/CheckFunction.purs (100%) rename {examples => tests/purs}/passing/CheckSynonymBug.purs (100%) rename {examples => tests/purs}/passing/CheckTypeClass.purs (100%) rename {examples => tests/purs}/passing/Church.purs (100%) rename {examples => tests/purs}/passing/ClassRefSyntax.purs (100%) rename {examples => tests/purs}/passing/ClassRefSyntax/Lib.purs (100%) rename {examples => tests/purs}/passing/Collatz.purs (100%) rename {examples => tests/purs}/passing/Comparisons.purs (94%) rename {examples => tests/purs}/passing/Conditional.purs (100%) rename {examples => tests/purs}/passing/Console.purs (100%) rename {examples => tests/purs}/passing/ConstraintInference.purs (100%) rename {examples => tests/purs}/passing/ConstraintParens.purs (100%) rename {examples => tests/purs}/passing/ConstraintParsingIssue.purs (100%) rename {examples => tests/purs}/passing/ContextSimplification.purs (100%) rename {examples => tests/purs}/passing/DataAndType.purs (100%) rename {examples => tests/purs}/passing/DataConsClassConsOverlapOk.purs (100%) rename {examples => tests/purs}/passing/DctorName.purs (100%) rename {examples => tests/purs}/passing/DctorOperatorAlias.purs (100%) rename {examples => tests/purs}/passing/DctorOperatorAlias/List.purs (100%) rename {examples => tests/purs}/passing/DeepArrayBinder.purs (100%) rename {examples => tests/purs}/passing/DeepCase.purs (100%) rename {examples => tests/purs}/passing/DeriveNewtype.purs (100%) rename {examples => tests/purs}/passing/DeriveWithNestedSynonyms.purs (100%) rename {examples => tests/purs}/passing/Deriving.purs (100%) rename {examples => tests/purs}/passing/DerivingFunctor.purs (100%) rename {examples => tests/purs}/passing/Do.purs (100%) rename {examples => tests/purs}/passing/Dollar.purs (100%) rename {examples => tests/purs}/passing/DuplicateProperties.purs (100%) rename {examples => tests/purs}/passing/EffFn.js (100%) rename {examples => tests/purs}/passing/EffFn.purs (100%) rename {examples => tests/purs}/passing/EmptyDataDecls.purs (100%) rename {examples => tests/purs}/passing/EmptyRow.purs (100%) rename {examples => tests/purs}/passing/EmptyTypeClass.purs (100%) rename {examples => tests/purs}/passing/EntailsKindedType.purs (100%) rename {examples => tests/purs}/passing/Eq1Deriving.purs (100%) rename {examples => tests/purs}/passing/Eq1InEqDeriving.purs (100%) rename {examples => tests/purs}/passing/EqOrd.purs (100%) rename {examples => tests/purs}/passing/ExplicitImportReExport.purs (92%) rename {examples => tests/purs}/passing/ExplicitImportReExport/Bar.purs (93%) rename {examples => tests/purs}/passing/ExplicitImportReExport/Foo.purs (90%) rename {examples => tests/purs}/passing/ExplicitOperatorSections.purs (100%) rename {examples => tests/purs}/passing/ExportExplicit.purs (91%) rename {examples => tests/purs}/passing/ExportExplicit/M1.purs (91%) rename {examples => tests/purs}/passing/ExportExplicit2.purs (91%) rename {examples => tests/purs}/passing/ExportExplicit2/M1.purs (90%) rename {examples => tests/purs}/passing/ExportedInstanceDeclarations.purs (100%) rename {examples => tests/purs}/passing/ExtendedInfixOperators.purs (100%) rename {examples => tests/purs}/passing/Fib.purs (100%) rename {examples => tests/purs}/passing/FieldConsPuns.purs (94%) rename {examples => tests/purs}/passing/FieldPuns.purs (95%) rename {examples => tests/purs}/passing/FinalTagless.purs (100%) rename {examples => tests/purs}/passing/ForeignKind.purs (100%) rename {examples => tests/purs}/passing/ForeignKind/Lib.purs (100%) rename {examples => tests/purs}/passing/FunWithFunDeps.js (100%) rename {examples => tests/purs}/passing/FunWithFunDeps.purs (100%) rename {examples => tests/purs}/passing/FunctionScope.purs (100%) rename {examples => tests/purs}/passing/FunctionalDependencies.purs (100%) rename {examples => tests/purs}/passing/Functions.purs (100%) rename {examples => tests/purs}/passing/Functions2.purs (100%) rename {examples => tests/purs}/passing/Generalization1.purs (100%) rename {examples => tests/purs}/passing/GenericsRep.purs (100%) rename {examples => tests/purs}/passing/Guards.purs (100%) rename {examples => tests/purs}/passing/HasOwnProperty.purs (100%) rename {examples => tests/purs}/passing/HoistError.purs (100%) rename {examples => tests/purs}/passing/IfThenElseMaybe.purs (100%) rename {examples => tests/purs}/passing/IfWildcard.purs (100%) rename {examples => tests/purs}/passing/ImplicitEmptyImport.purs (100%) rename {examples => tests/purs}/passing/Import.purs (92%) rename {examples => tests/purs}/passing/Import/M1.purs (91%) rename {examples => tests/purs}/passing/Import/M2.purs (91%) rename {examples => tests/purs}/passing/ImportExplicit.purs (92%) rename {examples => tests/purs}/passing/ImportExplicit/M1.purs (91%) rename {examples => tests/purs}/passing/ImportHiding.purs (100%) rename {examples => tests/purs}/passing/ImportQualified.purs (93%) rename {examples => tests/purs}/passing/ImportQualified/M1.purs (90%) rename {examples => tests/purs}/passing/InferRecFunWithConstrainedArgument.purs (100%) rename {examples => tests/purs}/passing/InstanceBeforeClass.purs (100%) rename {examples => tests/purs}/passing/InstanceChain.purs (100%) rename {examples => tests/purs}/passing/InstanceSigs.purs (100%) rename {examples => tests/purs}/passing/InstanceSigsGeneral.purs (100%) rename {examples => tests/purs}/passing/IntAndChar.purs (100%) rename {examples => tests/purs}/passing/JSReserved.purs (100%) rename {examples => tests/purs}/passing/KindedType.purs (100%) rename {examples => tests/purs}/passing/LargeSumType.purs (100%) rename {examples => tests/purs}/passing/Let.purs (100%) rename {examples => tests/purs}/passing/Let2.purs (100%) rename {examples => tests/purs}/passing/LetInInstance.purs (100%) rename {examples => tests/purs}/passing/LetPattern.purs (100%) rename {examples => tests/purs}/passing/LiberalTypeSynonyms.purs (100%) rename {examples => tests/purs}/passing/MPTCs.purs (100%) rename {examples => tests/purs}/passing/Match.purs (100%) rename {examples => tests/purs}/passing/Module.purs (100%) rename {examples => tests/purs}/passing/Module/M1.purs (100%) rename {examples => tests/purs}/passing/Module/M2.purs (100%) rename {examples => tests/purs}/passing/ModuleDeps.purs (92%) rename {examples => tests/purs}/passing/ModuleDeps/M1.purs (90%) rename {examples => tests/purs}/passing/ModuleDeps/M2.purs (90%) rename {examples => tests/purs}/passing/ModuleDeps/M3.purs (89%) rename {examples => tests/purs}/passing/ModuleExport.purs (100%) rename {examples => tests/purs}/passing/ModuleExport/A.purs (100%) rename {examples => tests/purs}/passing/ModuleExportDupes.purs (100%) rename {examples => tests/purs}/passing/ModuleExportDupes/A.purs (100%) rename {examples => tests/purs}/passing/ModuleExportDupes/B.purs (100%) rename {examples => tests/purs}/passing/ModuleExportDupes/C.purs (100%) rename {examples => tests/purs}/passing/ModuleExportExcluded.purs (100%) rename {examples => tests/purs}/passing/ModuleExportExcluded/A.purs (100%) rename {examples => tests/purs}/passing/ModuleExportQualified.purs (100%) rename {examples => tests/purs}/passing/ModuleExportQualified/A.purs (100%) rename {examples => tests/purs}/passing/ModuleExportSelf.purs (100%) rename {examples => tests/purs}/passing/ModuleExportSelf/A.purs (93%) rename {examples => tests/purs}/passing/Monad.purs (100%) rename {examples => tests/purs}/passing/MonadState.purs (100%) rename {examples => tests/purs}/passing/MultiArgFunctions.purs (100%) rename {examples => tests/purs}/passing/MutRec.purs (100%) rename {examples => tests/purs}/passing/MutRec2.purs (100%) rename {examples => tests/purs}/passing/MutRec3.purs (100%) rename {examples => tests/purs}/passing/NakedConstraint.purs (100%) rename {examples => tests/purs}/passing/NamedPatterns.purs (100%) rename {examples => tests/purs}/passing/NegativeBinder.purs (100%) rename {examples => tests/purs}/passing/NegativeIntInRange.purs (100%) rename {examples => tests/purs}/passing/Nested.purs (100%) rename {examples => tests/purs}/passing/NestedRecordUpdate.purs (100%) rename {examples => tests/purs}/passing/NestedRecordUpdateWildcards.purs (100%) rename {examples => tests/purs}/passing/NestedTypeSynonyms.purs (100%) rename {examples => tests/purs}/passing/NestedWhere.purs (100%) rename {examples => tests/purs}/passing/NewConsClass.purs (100%) rename {examples => tests/purs}/passing/Newtype.purs (100%) rename {examples => tests/purs}/passing/NewtypeClass.purs (100%) rename {examples => tests/purs}/passing/NewtypeEff.purs (100%) rename {examples => tests/purs}/passing/NewtypeInstance.purs (100%) rename {examples => tests/purs}/passing/NewtypeWithRecordUpdate.purs (100%) rename {examples => tests/purs}/passing/NonConflictingExports.purs (100%) rename {examples => tests/purs}/passing/NonConflictingExports/A.purs (100%) rename {examples => tests/purs}/passing/NonOrphanInstanceFunDepExtra.purs (100%) rename {examples => tests/purs}/passing/NonOrphanInstanceFunDepExtra/Lib.purs (100%) rename {examples => tests/purs}/passing/NonOrphanInstanceMulti.purs (100%) rename {examples => tests/purs}/passing/NonOrphanInstanceMulti/Lib.purs (100%) rename {examples => tests/purs}/passing/NumberLiterals.purs (100%) rename {examples => tests/purs}/passing/ObjectGetter.purs (100%) rename {examples => tests/purs}/passing/ObjectSynonym.purs (100%) rename {examples => tests/purs}/passing/ObjectUpdate.purs (95%) rename {examples => tests/purs}/passing/ObjectUpdate2.purs (100%) rename {examples => tests/purs}/passing/ObjectUpdater.purs (100%) rename {examples => tests/purs}/passing/ObjectWildcards.purs (100%) rename {examples => tests/purs}/passing/Objects.purs (100%) rename {examples => tests/purs}/passing/OneConstructor.purs (100%) rename {examples => tests/purs}/passing/OperatorAlias.purs (100%) rename {examples => tests/purs}/passing/OperatorAliasElsewhere.purs (100%) rename {examples => tests/purs}/passing/OperatorAliasElsewhere/Def.purs (94%) rename {examples => tests/purs}/passing/OperatorAssociativity.purs (96%) rename {examples => tests/purs}/passing/OperatorInlining.purs (100%) rename {examples => tests/purs}/passing/OperatorSections.purs (100%) rename {examples => tests/purs}/passing/Operators.purs (100%) rename {examples => tests/purs}/passing/Operators/Other.purs (100%) rename {examples => tests/purs}/passing/OptimizerBug.purs (100%) rename {examples => tests/purs}/passing/OptionalQualified.purs (100%) rename {examples => tests/purs}/passing/Ord1Deriving.purs (100%) rename {examples => tests/purs}/passing/Ord1InOrdDeriving.purs (100%) rename {examples => tests/purs}/passing/ParensInType.purs (100%) rename {examples => tests/purs}/passing/ParensInTypedBinder.purs (100%) rename {examples => tests/purs}/passing/PartialFunction.purs (100%) rename {examples => tests/purs}/passing/Patterns.purs (100%) rename {examples => tests/purs}/passing/PendingConflictingImports.purs (100%) rename {examples => tests/purs}/passing/PendingConflictingImports/A.purs (100%) rename {examples => tests/purs}/passing/PendingConflictingImports/B.purs (100%) rename {examples => tests/purs}/passing/PendingConflictingImports2.purs (100%) rename {examples => tests/purs}/passing/PendingConflictingImports2/A.purs (100%) rename {examples => tests/purs}/passing/Person.purs (100%) rename {examples => tests/purs}/passing/PolyLabels.js (100%) rename {examples => tests/purs}/passing/PolyLabels.purs (100%) rename {examples => tests/purs}/passing/PrimedTypeName.purs (100%) rename {examples => tests/purs}/passing/QualifiedNames.purs (96%) rename {examples => tests/purs}/passing/QualifiedNames/Either.purs (93%) rename {examples => tests/purs}/passing/QualifiedQualifiedImports.purs (100%) rename {examples => tests/purs}/passing/Rank2Data.purs (94%) rename {examples => tests/purs}/passing/Rank2Object.purs (100%) rename {examples => tests/purs}/passing/Rank2TypeSynonym.purs (100%) rename {examples => tests/purs}/passing/Rank2Types.purs (100%) rename {examples => tests/purs}/passing/ReExportQualified.purs (100%) rename {examples => tests/purs}/passing/ReExportQualified/A.purs (100%) rename {examples => tests/purs}/passing/ReExportQualified/B.purs (100%) rename {examples => tests/purs}/passing/ReExportQualified/C.purs (100%) rename {examples => tests/purs}/passing/RebindableSyntax.purs (100%) rename {examples => tests/purs}/passing/Recursion.purs (100%) rename {examples => tests/purs}/passing/RedefinedFixity.purs (92%) rename {examples => tests/purs}/passing/RedefinedFixity/M1.purs (95%) rename {examples => tests/purs}/passing/RedefinedFixity/M2.purs (90%) rename {examples => tests/purs}/passing/RedefinedFixity/M3.purs (90%) rename {examples => tests/purs}/passing/ReservedWords.purs (100%) rename {examples => tests/purs}/passing/ResolvableScopeConflict.purs (100%) rename {examples => tests/purs}/passing/ResolvableScopeConflict/A.purs (100%) rename {examples => tests/purs}/passing/ResolvableScopeConflict/B.purs (100%) rename {examples => tests/purs}/passing/ResolvableScopeConflict2.purs (100%) rename {examples => tests/purs}/passing/ResolvableScopeConflict2/A.purs (100%) rename {examples => tests/purs}/passing/ResolvableScopeConflict3.purs (100%) rename {examples => tests/purs}/passing/ResolvableScopeConflict3/A.purs (100%) rename {examples => tests/purs}/passing/RowConstructors.purs (100%) rename {examples => tests/purs}/passing/RowInInstanceHeadDetermined.purs (100%) rename {examples => tests/purs}/passing/RowLacks.purs (100%) rename {examples => tests/purs}/passing/RowNub.purs (100%) rename {examples => tests/purs}/passing/RowPolyInstanceContext.purs (100%) rename {examples => tests/purs}/passing/RowUnion.js (100%) rename {examples => tests/purs}/passing/RowUnion.purs (100%) rename {examples => tests/purs}/passing/RowsInInstanceContext.purs (100%) rename {examples => tests/purs}/passing/RunFnInline.purs (100%) rename {examples => tests/purs}/passing/RuntimeScopeIssue.purs (100%) rename {examples => tests/purs}/passing/ScopedTypeVariables.purs (100%) rename {examples => tests/purs}/passing/Sequence.purs (100%) rename {examples => tests/purs}/passing/SequenceDesugared.purs (100%) rename {examples => tests/purs}/passing/ShadowedModuleName.purs (100%) rename {examples => tests/purs}/passing/ShadowedModuleName/Test.purs (100%) rename {examples => tests/purs}/passing/ShadowedName.purs (94%) rename {examples => tests/purs}/passing/ShadowedRename.purs (100%) rename {examples => tests/purs}/passing/ShadowedTCO.purs (94%) rename {examples => tests/purs}/passing/ShadowedTCOLet.purs (94%) rename {examples => tests/purs}/passing/SignedNumericLiterals.purs (100%) rename {examples => tests/purs}/passing/SolvingAppendSymbol.purs (100%) rename {examples => tests/purs}/passing/SolvingCompareSymbol.purs (100%) rename {examples => tests/purs}/passing/SolvingIsSymbol.purs (100%) rename {examples => tests/purs}/passing/SolvingIsSymbol/Lib.purs (100%) rename {examples => tests/purs}/passing/Stream.purs (100%) rename {examples => tests/purs}/passing/StringEdgeCases.purs (100%) rename {examples => tests/purs}/passing/StringEdgeCases/Records.purs (100%) rename {examples => tests/purs}/passing/StringEdgeCases/Symbols.purs (100%) rename {examples => tests/purs}/passing/StringEscapes.purs (100%) rename {examples => tests/purs}/passing/Superclasses1.purs (100%) rename {examples => tests/purs}/passing/Superclasses3.purs (100%) rename {examples => tests/purs}/passing/TCO.purs (100%) rename {examples => tests/purs}/passing/TCOCase.purs (100%) rename {examples => tests/purs}/passing/TailCall.purs (100%) rename {examples => tests/purs}/passing/Tick.purs (100%) rename {examples => tests/purs}/passing/TopLevelCase.purs (100%) rename {examples => tests/purs}/passing/TransitiveImport.purs (100%) rename {examples => tests/purs}/passing/TransitiveImport/Middle.purs (100%) rename {examples => tests/purs}/passing/TransitiveImport/Test.purs (100%) rename {examples => tests/purs}/passing/TypeClassMemberOrderChange.purs (93%) rename {examples => tests/purs}/passing/TypeClasses.purs (100%) rename {examples => tests/purs}/passing/TypeClassesInOrder.purs (100%) rename {examples => tests/purs}/passing/TypeClassesWithOverlappingTypeVariables.purs (100%) rename {examples => tests/purs}/passing/TypeDecl.purs (100%) rename {examples => tests/purs}/passing/TypeOperators.purs (100%) rename {examples => tests/purs}/passing/TypeOperators/A.purs (100%) rename {examples => tests/purs}/passing/TypeSynonymInData.purs (100%) rename {examples => tests/purs}/passing/TypeSynonyms.purs (100%) rename {examples => tests/purs}/passing/TypeWildcards.purs (100%) rename {examples => tests/purs}/passing/TypeWildcardsRecordExtension.purs (100%) rename {examples => tests/purs}/passing/TypeWithoutParens.purs (100%) rename {examples => tests/purs}/passing/TypeWithoutParens/Lib.purs (100%) rename {examples => tests/purs}/passing/TypedBinders.purs (100%) rename {examples => tests/purs}/passing/TypedWhere.purs (100%) rename {examples => tests/purs}/passing/UTF8Sourcefile.purs (94%) rename {examples => tests/purs}/passing/UnderscoreIdent.purs (100%) rename {examples => tests/purs}/passing/UnicodeIdentifier.purs (100%) rename {examples => tests/purs}/passing/UnicodeOperators.purs (100%) rename {examples => tests/purs}/passing/UnicodeType.purs (100%) rename {examples => tests/purs}/passing/UnifyInTypeInstanceLookup.purs (100%) rename {examples => tests/purs}/passing/Unit.purs (100%) rename {examples => tests/purs}/passing/UnknownInTypeClassLookup.purs (100%) rename {examples => tests/purs}/passing/UnsafeCoerce.purs (100%) rename {examples => tests/purs}/passing/UntupledConstraints.purs (100%) rename {examples => tests/purs}/passing/UsableTypeClassMethods.purs (100%) rename {examples => tests/purs}/passing/Where.purs (100%) rename {examples => tests/purs}/passing/WildcardInInstance.purs (100%) rename {examples => tests/purs}/passing/WildcardType.purs (92%) rename {examples => tests/purs}/passing/iota.purs (100%) rename {examples => tests/purs}/passing/s.purs (100%) rename {examples => tests/purs}/psci/BasicEval.purs (100%) rename {examples => tests/purs}/psci/Multiline.purs (100%) rename {examples => tests/purs}/warning/2140.purs (100%) rename {examples => tests/purs}/warning/2383.purs (100%) rename {examples => tests/purs}/warning/2411.purs (100%) rename {examples => tests/purs}/warning/2542.purs (100%) rename {examples => tests/purs}/warning/CustomWarning.purs (100%) rename {examples => tests/purs}/warning/CustomWarning2.purs (100%) rename {examples => tests/purs}/warning/CustomWarning3.purs (100%) rename {examples => tests/purs}/warning/DuplicateExportRef.purs (100%) rename {examples => tests/purs}/warning/DuplicateImport.purs (100%) rename {examples => tests/purs}/warning/DuplicateImportRef.purs (100%) rename {examples => tests/purs}/warning/DuplicateSelectiveImport.purs (100%) rename {examples => tests/purs}/warning/HidingImport.purs (100%) rename {examples => tests/purs}/warning/ImplicitImport.purs (100%) rename {examples => tests/purs}/warning/ImplicitQualifiedImport.purs (100%) rename {examples => tests/purs}/warning/ImplicitQualifiedImportReExport.purs (100%) rename {examples => tests/purs}/warning/MissingTypeDeclaration.purs (100%) rename {examples => tests/purs}/warning/NewtypeInstance.purs (100%) rename {examples => tests/purs}/warning/NewtypeInstance2.purs (100%) rename {examples => tests/purs}/warning/NewtypeInstance3.purs (100%) rename {examples => tests/purs}/warning/NewtypeInstance4.purs (100%) rename {examples => tests/purs}/warning/OverlappingPattern.purs (100%) rename {examples => tests/purs}/warning/ScopeShadowing.purs (100%) rename {examples => tests/purs}/warning/ScopeShadowing2.purs (100%) rename {examples => tests/purs}/warning/ShadowedBinderPatternGuard.purs (100%) rename {examples => tests/purs}/warning/ShadowedNameParens.purs (100%) rename {examples => tests/purs}/warning/ShadowedTypeVar.purs (100%) rename {examples => tests/purs}/warning/UnnecessaryFFIModule.js (100%) rename {examples => tests/purs}/warning/UnnecessaryFFIModule.purs (100%) rename {examples => tests/purs}/warning/UnusedDctorExplicitImport.purs (100%) rename {examples => tests/purs}/warning/UnusedDctorImportAll.purs (100%) rename {examples => tests/purs}/warning/UnusedDctorImportExplicit.purs (100%) rename {examples => tests/purs}/warning/UnusedExplicitImport.purs (100%) rename {examples => tests/purs}/warning/UnusedExplicitImportTypeOp.purs (100%) rename {examples => tests/purs}/warning/UnusedExplicitImportTypeOp/Lib.purs (100%) rename {examples => tests/purs}/warning/UnusedExplicitImportValOp.purs (100%) rename {examples => tests/purs}/warning/UnusedFFIImplementations.js (100%) rename {examples => tests/purs}/warning/UnusedFFIImplementations.purs (100%) rename {examples => tests/purs}/warning/UnusedImport.purs (100%) rename {examples => tests/purs}/warning/UnusedTypeVar.purs (100%) rename {examples => tests/purs}/warning/WildcardInferredType.purs (100%) diff --git a/.gitignore b/.gitignore index 6715e434d1..099161cd5b 100644 --- a/.gitignore +++ b/.gitignore @@ -15,7 +15,7 @@ node_modules tmp/ .stack-work/ output -examples/docs/docs/ +tests/purs/docs/docs/ core-tests/full-core-docs.md tests/support/package-lock.json .psc-ide-port diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 8ce80c017b..0cb15ff9a0 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -8,7 +8,7 @@ If you would like to contribute, please consider the issues in the current miles Please follow the following guidelines: -- Add at least a test to `examples/passing/` and possibly to `examples/failing/`. +- Add at least a test to `tests/purs/passing/` and possibly to `tests/purs/failing/`. - Build the binaries and libs with `stack build` - Make sure that all test suites are passing. Run the test suites with `stack test`. - Build the core libraries by running the script in `core-tests`. @@ -21,7 +21,7 @@ You can run individual test suites using `stack test --test-arguments="-p PATTERN"` where `PATTERN` is one of `compiler`, `repl`, `ide`, `docs`, `corefn`, or `hierarchy`. -To build and run a specific test in `examples/passing/` or `examples/failing/`, add test arguments like so: +To build and run a specific test in `tests/purs/passing/` or `tests/purs/failing/`, add test arguments like so: `stack test --fast --test-arguments="-p compiler/**1110.purs*"` diff --git a/package.yaml b/package.yaml index b5764b7c4c..f5bb8786ea 100644 --- a/package.yaml +++ b/package.yaml @@ -16,10 +16,10 @@ license: BSD3 github: purescript/purescript homepage: http://www.purescript.org/ extra-source-files: - - examples/**/*.js - - examples/**/*.purs - - examples/**/*.json - app/static/* + - tests/purs/**/*.js + - tests/purs/**/*.purs + - tests/purs/**/*.json - tests/support/*.json - tests/support/setup-win.cmd - tests/support/psci/*.purs diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index dd31894b52..82d23e03b5 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -68,7 +68,7 @@ data Binder -- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing -- the `SourceSpan` values embedded in some of the data constructors of `Binder` -- was expensive. This made exhaustiveness checking observably slow for code --- such as the `explode` function in `examples/passing/LargeSumTypes.purs`. +-- such as the `explode` function in `test/purs/passing/LargeSumTypes.purs`. -- Custom instances were written to skip comparing the `SourceSpan` values. Only -- the `Ord` instance was needed for the speed-up, but I did not want the `Eq` -- to have mismatched behavior. diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index af9705d97e..9c3bed7a0f 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -63,9 +63,9 @@ spec = do (supportModules, supportExterns, supportForeigns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do cwd <- getCurrentDirectory - let passing = cwd "examples" "passing" - let warning = cwd "examples" "warning" - let failing = cwd "examples" "failing" + let passing = cwd "tests" "purs" "passing" + let warning = cwd "tests" "purs" "warning" + let failing = cwd "tests" "purs" "failing" passingFiles <- getTestFiles passing <$> testGlob passing warningFiles <- getTestFiles warning <$> testGlob warning failingFiles <- getTestFiles failing <$> testGlob failing diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 5d438d86ad..8bd082ef12 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -47,7 +47,7 @@ publishOpts = Publish.defaultPublishOptions getPackage :: IO (Either Publish.PackageError (Docs.Package Docs.NotYetKnown)) getPackage = - pushd "examples/docs" $ + pushd "tests/purs/docs" $ Publish.preparePackage "bower.json" "resolutions.json" publishOpts main :: IO TestTree diff --git a/tests/TestPsci/EvalTest.hs b/tests/TestPsci/EvalTest.hs index 82b566f02e..5aae8ab90a 100644 --- a/tests/TestPsci/EvalTest.hs +++ b/tests/TestPsci/EvalTest.hs @@ -23,7 +23,7 @@ evalTests = context "evalTests" $ do evalTestFiles :: IO [FilePath] evalTestFiles = do cwd <- getCurrentDirectory - let psciExamples = cwd "examples" "psci" + let psciExamples = cwd "tests" "purs" "psci" Glob.globDir1 (Glob.compile "**/*.purs") psciExamples data EvalLine = Line String diff --git a/examples/.gitignore b/tests/purs/.gitignore similarity index 100% rename from examples/.gitignore rename to tests/purs/.gitignore diff --git a/examples/docs/bower.json b/tests/purs/docs/bower.json similarity index 100% rename from examples/docs/bower.json rename to tests/purs/docs/bower.json diff --git a/examples/docs/bower_components/purescript-prelude/src/Prelude.purs b/tests/purs/docs/bower_components/purescript-prelude/src/Prelude.purs similarity index 100% rename from examples/docs/bower_components/purescript-prelude/src/Prelude.purs rename to tests/purs/docs/bower_components/purescript-prelude/src/Prelude.purs diff --git a/examples/docs/resolutions.json b/tests/purs/docs/resolutions.json similarity index 100% rename from examples/docs/resolutions.json rename to tests/purs/docs/resolutions.json diff --git a/examples/docs/src/ChildDeclOrder.purs b/tests/purs/docs/src/ChildDeclOrder.purs similarity index 100% rename from examples/docs/src/ChildDeclOrder.purs rename to tests/purs/docs/src/ChildDeclOrder.purs diff --git a/examples/docs/src/Clash.purs b/tests/purs/docs/src/Clash.purs similarity index 100% rename from examples/docs/src/Clash.purs rename to tests/purs/docs/src/Clash.purs diff --git a/examples/docs/src/Clash1.purs b/tests/purs/docs/src/Clash1.purs similarity index 100% rename from examples/docs/src/Clash1.purs rename to tests/purs/docs/src/Clash1.purs diff --git a/examples/docs/src/Clash1a.purs b/tests/purs/docs/src/Clash1a.purs similarity index 100% rename from examples/docs/src/Clash1a.purs rename to tests/purs/docs/src/Clash1a.purs diff --git a/examples/docs/src/Clash2.purs b/tests/purs/docs/src/Clash2.purs similarity index 100% rename from examples/docs/src/Clash2.purs rename to tests/purs/docs/src/Clash2.purs diff --git a/examples/docs/src/Clash2a.purs b/tests/purs/docs/src/Clash2a.purs similarity index 100% rename from examples/docs/src/Clash2a.purs rename to tests/purs/docs/src/Clash2a.purs diff --git a/examples/docs/src/ConstrainedArgument.purs b/tests/purs/docs/src/ConstrainedArgument.purs similarity index 100% rename from examples/docs/src/ConstrainedArgument.purs rename to tests/purs/docs/src/ConstrainedArgument.purs diff --git a/examples/docs/src/DeclOrder.purs b/tests/purs/docs/src/DeclOrder.purs similarity index 100% rename from examples/docs/src/DeclOrder.purs rename to tests/purs/docs/src/DeclOrder.purs diff --git a/examples/docs/src/DeclOrderNoExportList.purs b/tests/purs/docs/src/DeclOrderNoExportList.purs similarity index 100% rename from examples/docs/src/DeclOrderNoExportList.purs rename to tests/purs/docs/src/DeclOrderNoExportList.purs diff --git a/examples/docs/src/Desugar.purs b/tests/purs/docs/src/Desugar.purs similarity index 100% rename from examples/docs/src/Desugar.purs rename to tests/purs/docs/src/Desugar.purs diff --git a/examples/docs/src/DocComments.purs b/tests/purs/docs/src/DocComments.purs similarity index 100% rename from examples/docs/src/DocComments.purs rename to tests/purs/docs/src/DocComments.purs diff --git a/examples/docs/src/DuplicateNames.purs b/tests/purs/docs/src/DuplicateNames.purs similarity index 100% rename from examples/docs/src/DuplicateNames.purs rename to tests/purs/docs/src/DuplicateNames.purs diff --git a/examples/docs/src/Example.purs b/tests/purs/docs/src/Example.purs similarity index 100% rename from examples/docs/src/Example.purs rename to tests/purs/docs/src/Example.purs diff --git a/examples/docs/src/Example2.purs b/tests/purs/docs/src/Example2.purs similarity index 100% rename from examples/docs/src/Example2.purs rename to tests/purs/docs/src/Example2.purs diff --git a/examples/docs/src/ExplicitExport.purs b/tests/purs/docs/src/ExplicitExport.purs similarity index 100% rename from examples/docs/src/ExplicitExport.purs rename to tests/purs/docs/src/ExplicitExport.purs diff --git a/examples/docs/src/ExplicitTypeSignatures.purs b/tests/purs/docs/src/ExplicitTypeSignatures.purs similarity index 100% rename from examples/docs/src/ExplicitTypeSignatures.purs rename to tests/purs/docs/src/ExplicitTypeSignatures.purs diff --git a/examples/docs/src/ImportedTwice.purs b/tests/purs/docs/src/ImportedTwice.purs similarity index 100% rename from examples/docs/src/ImportedTwice.purs rename to tests/purs/docs/src/ImportedTwice.purs diff --git a/examples/docs/src/ImportedTwiceA.purs b/tests/purs/docs/src/ImportedTwiceA.purs similarity index 100% rename from examples/docs/src/ImportedTwiceA.purs rename to tests/purs/docs/src/ImportedTwiceA.purs diff --git a/examples/docs/src/ImportedTwiceB.purs b/tests/purs/docs/src/ImportedTwiceB.purs similarity index 100% rename from examples/docs/src/ImportedTwiceB.purs rename to tests/purs/docs/src/ImportedTwiceB.purs diff --git a/examples/docs/src/MultiVirtual.purs b/tests/purs/docs/src/MultiVirtual.purs similarity index 100% rename from examples/docs/src/MultiVirtual.purs rename to tests/purs/docs/src/MultiVirtual.purs diff --git a/examples/docs/src/MultiVirtual1.purs b/tests/purs/docs/src/MultiVirtual1.purs similarity index 100% rename from examples/docs/src/MultiVirtual1.purs rename to tests/purs/docs/src/MultiVirtual1.purs diff --git a/examples/docs/src/MultiVirtual2.purs b/tests/purs/docs/src/MultiVirtual2.purs similarity index 100% rename from examples/docs/src/MultiVirtual2.purs rename to tests/purs/docs/src/MultiVirtual2.purs diff --git a/examples/docs/src/MultiVirtual3.purs b/tests/purs/docs/src/MultiVirtual3.purs similarity index 100% rename from examples/docs/src/MultiVirtual3.purs rename to tests/purs/docs/src/MultiVirtual3.purs diff --git a/examples/docs/src/NewOperators.purs b/tests/purs/docs/src/NewOperators.purs similarity index 100% rename from examples/docs/src/NewOperators.purs rename to tests/purs/docs/src/NewOperators.purs diff --git a/examples/docs/src/NewOperators2.purs b/tests/purs/docs/src/NewOperators2.purs similarity index 100% rename from examples/docs/src/NewOperators2.purs rename to tests/purs/docs/src/NewOperators2.purs diff --git a/examples/docs/src/NotAllCtors.purs b/tests/purs/docs/src/NotAllCtors.purs similarity index 100% rename from examples/docs/src/NotAllCtors.purs rename to tests/purs/docs/src/NotAllCtors.purs diff --git a/examples/docs/src/ReExportedTypeClass.purs b/tests/purs/docs/src/ReExportedTypeClass.purs similarity index 100% rename from examples/docs/src/ReExportedTypeClass.purs rename to tests/purs/docs/src/ReExportedTypeClass.purs diff --git a/examples/docs/src/SolitaryTypeClassMember.purs b/tests/purs/docs/src/SolitaryTypeClassMember.purs similarity index 100% rename from examples/docs/src/SolitaryTypeClassMember.purs rename to tests/purs/docs/src/SolitaryTypeClassMember.purs diff --git a/examples/docs/src/SomeTypeClass.purs b/tests/purs/docs/src/SomeTypeClass.purs similarity index 100% rename from examples/docs/src/SomeTypeClass.purs rename to tests/purs/docs/src/SomeTypeClass.purs diff --git a/examples/docs/src/Transitive1.purs b/tests/purs/docs/src/Transitive1.purs similarity index 100% rename from examples/docs/src/Transitive1.purs rename to tests/purs/docs/src/Transitive1.purs diff --git a/examples/docs/src/Transitive2.purs b/tests/purs/docs/src/Transitive2.purs similarity index 100% rename from examples/docs/src/Transitive2.purs rename to tests/purs/docs/src/Transitive2.purs diff --git a/examples/docs/src/Transitive3.purs b/tests/purs/docs/src/Transitive3.purs similarity index 100% rename from examples/docs/src/Transitive3.purs rename to tests/purs/docs/src/Transitive3.purs diff --git a/examples/docs/src/TypeClassWithFunDeps.purs b/tests/purs/docs/src/TypeClassWithFunDeps.purs similarity index 100% rename from examples/docs/src/TypeClassWithFunDeps.purs rename to tests/purs/docs/src/TypeClassWithFunDeps.purs diff --git a/examples/docs/src/TypeClassWithoutMembers.purs b/tests/purs/docs/src/TypeClassWithoutMembers.purs similarity index 100% rename from examples/docs/src/TypeClassWithoutMembers.purs rename to tests/purs/docs/src/TypeClassWithoutMembers.purs diff --git a/examples/docs/src/TypeClassWithoutMembersIntermediate.purs b/tests/purs/docs/src/TypeClassWithoutMembersIntermediate.purs similarity index 100% rename from examples/docs/src/TypeClassWithoutMembersIntermediate.purs rename to tests/purs/docs/src/TypeClassWithoutMembersIntermediate.purs diff --git a/examples/docs/src/TypeLevelString.purs b/tests/purs/docs/src/TypeLevelString.purs similarity index 100% rename from examples/docs/src/TypeLevelString.purs rename to tests/purs/docs/src/TypeLevelString.purs diff --git a/examples/docs/src/TypeOpAliases.purs b/tests/purs/docs/src/TypeOpAliases.purs similarity index 100% rename from examples/docs/src/TypeOpAliases.purs rename to tests/purs/docs/src/TypeOpAliases.purs diff --git a/examples/docs/src/UTF8.purs b/tests/purs/docs/src/UTF8.purs similarity index 100% rename from examples/docs/src/UTF8.purs rename to tests/purs/docs/src/UTF8.purs diff --git a/examples/docs/src/Virtual.purs b/tests/purs/docs/src/Virtual.purs similarity index 100% rename from examples/docs/src/Virtual.purs rename to tests/purs/docs/src/Virtual.purs diff --git a/examples/failing/1071.purs b/tests/purs/failing/1071.purs similarity index 100% rename from examples/failing/1071.purs rename to tests/purs/failing/1071.purs diff --git a/examples/failing/1169.purs b/tests/purs/failing/1169.purs similarity index 100% rename from examples/failing/1169.purs rename to tests/purs/failing/1169.purs diff --git a/examples/failing/1175.purs b/tests/purs/failing/1175.purs similarity index 100% rename from examples/failing/1175.purs rename to tests/purs/failing/1175.purs diff --git a/examples/failing/1310.purs b/tests/purs/failing/1310.purs similarity index 100% rename from examples/failing/1310.purs rename to tests/purs/failing/1310.purs diff --git a/examples/failing/1570.purs b/tests/purs/failing/1570.purs similarity index 100% rename from examples/failing/1570.purs rename to tests/purs/failing/1570.purs diff --git a/examples/failing/1733.purs b/tests/purs/failing/1733.purs similarity index 100% rename from examples/failing/1733.purs rename to tests/purs/failing/1733.purs diff --git a/examples/failing/1733/Thingy.purs b/tests/purs/failing/1733/Thingy.purs similarity index 100% rename from examples/failing/1733/Thingy.purs rename to tests/purs/failing/1733/Thingy.purs diff --git a/examples/failing/1825.purs b/tests/purs/failing/1825.purs similarity index 100% rename from examples/failing/1825.purs rename to tests/purs/failing/1825.purs diff --git a/examples/failing/1881.purs b/tests/purs/failing/1881.purs similarity index 100% rename from examples/failing/1881.purs rename to tests/purs/failing/1881.purs diff --git a/examples/failing/2128-class.purs b/tests/purs/failing/2128-class.purs similarity index 100% rename from examples/failing/2128-class.purs rename to tests/purs/failing/2128-class.purs diff --git a/examples/failing/2128-instance.purs b/tests/purs/failing/2128-instance.purs similarity index 100% rename from examples/failing/2128-instance.purs rename to tests/purs/failing/2128-instance.purs diff --git a/examples/failing/2197-shouldFail.purs b/tests/purs/failing/2197-shouldFail.purs similarity index 100% rename from examples/failing/2197-shouldFail.purs rename to tests/purs/failing/2197-shouldFail.purs diff --git a/examples/failing/2197-shouldFail2.purs b/tests/purs/failing/2197-shouldFail2.purs similarity index 100% rename from examples/failing/2197-shouldFail2.purs rename to tests/purs/failing/2197-shouldFail2.purs diff --git a/examples/failing/2378.purs b/tests/purs/failing/2378.purs similarity index 100% rename from examples/failing/2378.purs rename to tests/purs/failing/2378.purs diff --git a/examples/failing/2378/Lib.purs b/tests/purs/failing/2378/Lib.purs similarity index 100% rename from examples/failing/2378/Lib.purs rename to tests/purs/failing/2378/Lib.purs diff --git a/examples/failing/2379.purs b/tests/purs/failing/2379.purs similarity index 100% rename from examples/failing/2379.purs rename to tests/purs/failing/2379.purs diff --git a/examples/failing/2379/Lib.purs b/tests/purs/failing/2379/Lib.purs similarity index 100% rename from examples/failing/2379/Lib.purs rename to tests/purs/failing/2379/Lib.purs diff --git a/examples/failing/2434.purs b/tests/purs/failing/2434.purs similarity index 100% rename from examples/failing/2434.purs rename to tests/purs/failing/2434.purs diff --git a/examples/failing/2534.purs b/tests/purs/failing/2534.purs similarity index 100% rename from examples/failing/2534.purs rename to tests/purs/failing/2534.purs diff --git a/examples/failing/2542.purs b/tests/purs/failing/2542.purs similarity index 100% rename from examples/failing/2542.purs rename to tests/purs/failing/2542.purs diff --git a/examples/failing/2567.purs b/tests/purs/failing/2567.purs similarity index 100% rename from examples/failing/2567.purs rename to tests/purs/failing/2567.purs diff --git a/examples/failing/2601.purs b/tests/purs/failing/2601.purs similarity index 100% rename from examples/failing/2601.purs rename to tests/purs/failing/2601.purs diff --git a/examples/failing/2616.purs b/tests/purs/failing/2616.purs similarity index 100% rename from examples/failing/2616.purs rename to tests/purs/failing/2616.purs diff --git a/examples/failing/2806.purs b/tests/purs/failing/2806.purs similarity index 100% rename from examples/failing/2806.purs rename to tests/purs/failing/2806.purs diff --git a/examples/failing/2874-forall.purs b/tests/purs/failing/2874-forall.purs similarity index 100% rename from examples/failing/2874-forall.purs rename to tests/purs/failing/2874-forall.purs diff --git a/examples/failing/2874-forall2.purs b/tests/purs/failing/2874-forall2.purs similarity index 100% rename from examples/failing/2874-forall2.purs rename to tests/purs/failing/2874-forall2.purs diff --git a/examples/failing/2874-wildcard.purs b/tests/purs/failing/2874-wildcard.purs similarity index 100% rename from examples/failing/2874-wildcard.purs rename to tests/purs/failing/2874-wildcard.purs diff --git a/examples/failing/2947.purs b/tests/purs/failing/2947.purs similarity index 100% rename from examples/failing/2947.purs rename to tests/purs/failing/2947.purs diff --git a/examples/failing/3132.purs b/tests/purs/failing/3132.purs similarity index 100% rename from examples/failing/3132.purs rename to tests/purs/failing/3132.purs diff --git a/examples/failing/3275-BindingGroupErrorPos.purs b/tests/purs/failing/3275-BindingGroupErrorPos.purs similarity index 100% rename from examples/failing/3275-BindingGroupErrorPos.purs rename to tests/purs/failing/3275-BindingGroupErrorPos.purs diff --git a/examples/failing/3275-DataBindingGroupErrorPos.purs b/tests/purs/failing/3275-DataBindingGroupErrorPos.purs similarity index 100% rename from examples/failing/3275-DataBindingGroupErrorPos.purs rename to tests/purs/failing/3275-DataBindingGroupErrorPos.purs diff --git a/examples/failing/365.purs b/tests/purs/failing/365.purs similarity index 100% rename from examples/failing/365.purs rename to tests/purs/failing/365.purs diff --git a/examples/failing/438.purs b/tests/purs/failing/438.purs similarity index 100% rename from examples/failing/438.purs rename to tests/purs/failing/438.purs diff --git a/examples/failing/881.purs b/tests/purs/failing/881.purs similarity index 100% rename from examples/failing/881.purs rename to tests/purs/failing/881.purs diff --git a/examples/failing/AnonArgument1.purs b/tests/purs/failing/AnonArgument1.purs similarity index 100% rename from examples/failing/AnonArgument1.purs rename to tests/purs/failing/AnonArgument1.purs diff --git a/examples/failing/AnonArgument2.purs b/tests/purs/failing/AnonArgument2.purs similarity index 100% rename from examples/failing/AnonArgument2.purs rename to tests/purs/failing/AnonArgument2.purs diff --git a/examples/failing/AnonArgument3.purs b/tests/purs/failing/AnonArgument3.purs similarity index 100% rename from examples/failing/AnonArgument3.purs rename to tests/purs/failing/AnonArgument3.purs diff --git a/examples/failing/ArgLengthMismatch.purs b/tests/purs/failing/ArgLengthMismatch.purs similarity index 94% rename from examples/failing/ArgLengthMismatch.purs rename to tests/purs/failing/ArgLengthMismatch.purs index 847e293065..0f1abfba19 100644 --- a/examples/failing/ArgLengthMismatch.purs +++ b/tests/purs/failing/ArgLengthMismatch.purs @@ -1,7 +1,7 @@ --- @shouldFailWith ArgListLengthsDiffer -module ArgLengthMismatch where - -import Prelude - -f x y = true -f = false +-- @shouldFailWith ArgListLengthsDiffer +module ArgLengthMismatch where + +import Prelude + +f x y = true +f = false diff --git a/examples/failing/ArrayType.purs b/tests/purs/failing/ArrayType.purs similarity index 100% rename from examples/failing/ArrayType.purs rename to tests/purs/failing/ArrayType.purs diff --git a/examples/failing/Arrays.purs b/tests/purs/failing/Arrays.purs similarity index 100% rename from examples/failing/Arrays.purs rename to tests/purs/failing/Arrays.purs diff --git a/examples/failing/BindInDo-2.purs b/tests/purs/failing/BindInDo-2.purs similarity index 100% rename from examples/failing/BindInDo-2.purs rename to tests/purs/failing/BindInDo-2.purs diff --git a/examples/failing/BindInDo.purs b/tests/purs/failing/BindInDo.purs similarity index 100% rename from examples/failing/BindInDo.purs rename to tests/purs/failing/BindInDo.purs diff --git a/examples/failing/CannotDeriveNewtypeForData.purs b/tests/purs/failing/CannotDeriveNewtypeForData.purs similarity index 100% rename from examples/failing/CannotDeriveNewtypeForData.purs rename to tests/purs/failing/CannotDeriveNewtypeForData.purs diff --git a/examples/failing/CaseBinderLengthsDiffer.purs b/tests/purs/failing/CaseBinderLengthsDiffer.purs similarity index 100% rename from examples/failing/CaseBinderLengthsDiffer.purs rename to tests/purs/failing/CaseBinderLengthsDiffer.purs diff --git a/examples/failing/CaseDoesNotMatchAllConstructorArgs.purs b/tests/purs/failing/CaseDoesNotMatchAllConstructorArgs.purs similarity index 100% rename from examples/failing/CaseDoesNotMatchAllConstructorArgs.purs rename to tests/purs/failing/CaseDoesNotMatchAllConstructorArgs.purs diff --git a/examples/failing/ConflictingExports.purs b/tests/purs/failing/ConflictingExports.purs similarity index 100% rename from examples/failing/ConflictingExports.purs rename to tests/purs/failing/ConflictingExports.purs diff --git a/examples/failing/ConflictingExports/A.purs b/tests/purs/failing/ConflictingExports/A.purs similarity index 100% rename from examples/failing/ConflictingExports/A.purs rename to tests/purs/failing/ConflictingExports/A.purs diff --git a/examples/failing/ConflictingExports/B.purs b/tests/purs/failing/ConflictingExports/B.purs similarity index 100% rename from examples/failing/ConflictingExports/B.purs rename to tests/purs/failing/ConflictingExports/B.purs diff --git a/examples/failing/ConflictingImports.purs b/tests/purs/failing/ConflictingImports.purs similarity index 100% rename from examples/failing/ConflictingImports.purs rename to tests/purs/failing/ConflictingImports.purs diff --git a/examples/failing/ConflictingImports/A.purs b/tests/purs/failing/ConflictingImports/A.purs similarity index 100% rename from examples/failing/ConflictingImports/A.purs rename to tests/purs/failing/ConflictingImports/A.purs diff --git a/examples/failing/ConflictingImports/B.purs b/tests/purs/failing/ConflictingImports/B.purs similarity index 100% rename from examples/failing/ConflictingImports/B.purs rename to tests/purs/failing/ConflictingImports/B.purs diff --git a/examples/failing/ConflictingImports2.purs b/tests/purs/failing/ConflictingImports2.purs similarity index 100% rename from examples/failing/ConflictingImports2.purs rename to tests/purs/failing/ConflictingImports2.purs diff --git a/examples/failing/ConflictingImports2/A.purs b/tests/purs/failing/ConflictingImports2/A.purs similarity index 100% rename from examples/failing/ConflictingImports2/A.purs rename to tests/purs/failing/ConflictingImports2/A.purs diff --git a/examples/failing/ConflictingImports2/B.purs b/tests/purs/failing/ConflictingImports2/B.purs similarity index 100% rename from examples/failing/ConflictingImports2/B.purs rename to tests/purs/failing/ConflictingImports2/B.purs diff --git a/examples/failing/ConflictingQualifiedImports.purs b/tests/purs/failing/ConflictingQualifiedImports.purs similarity index 100% rename from examples/failing/ConflictingQualifiedImports.purs rename to tests/purs/failing/ConflictingQualifiedImports.purs diff --git a/examples/failing/ConflictingQualifiedImports/A.purs b/tests/purs/failing/ConflictingQualifiedImports/A.purs similarity index 100% rename from examples/failing/ConflictingQualifiedImports/A.purs rename to tests/purs/failing/ConflictingQualifiedImports/A.purs diff --git a/examples/failing/ConflictingQualifiedImports/B.purs b/tests/purs/failing/ConflictingQualifiedImports/B.purs similarity index 100% rename from examples/failing/ConflictingQualifiedImports/B.purs rename to tests/purs/failing/ConflictingQualifiedImports/B.purs diff --git a/examples/failing/ConflictingQualifiedImports2.purs b/tests/purs/failing/ConflictingQualifiedImports2.purs similarity index 100% rename from examples/failing/ConflictingQualifiedImports2.purs rename to tests/purs/failing/ConflictingQualifiedImports2.purs diff --git a/examples/failing/ConflictingQualifiedImports2/A.purs b/tests/purs/failing/ConflictingQualifiedImports2/A.purs similarity index 100% rename from examples/failing/ConflictingQualifiedImports2/A.purs rename to tests/purs/failing/ConflictingQualifiedImports2/A.purs diff --git a/examples/failing/ConflictingQualifiedImports2/B.purs b/tests/purs/failing/ConflictingQualifiedImports2/B.purs similarity index 100% rename from examples/failing/ConflictingQualifiedImports2/B.purs rename to tests/purs/failing/ConflictingQualifiedImports2/B.purs diff --git a/examples/failing/ConstraintFailure.purs b/tests/purs/failing/ConstraintFailure.purs similarity index 100% rename from examples/failing/ConstraintFailure.purs rename to tests/purs/failing/ConstraintFailure.purs diff --git a/examples/failing/ConstraintInference.purs b/tests/purs/failing/ConstraintInference.purs similarity index 100% rename from examples/failing/ConstraintInference.purs rename to tests/purs/failing/ConstraintInference.purs diff --git a/examples/failing/DctorOperatorAliasExport.purs b/tests/purs/failing/DctorOperatorAliasExport.purs similarity index 100% rename from examples/failing/DctorOperatorAliasExport.purs rename to tests/purs/failing/DctorOperatorAliasExport.purs diff --git a/examples/failing/DeclConflictClassCtor.purs b/tests/purs/failing/DeclConflictClassCtor.purs similarity index 100% rename from examples/failing/DeclConflictClassCtor.purs rename to tests/purs/failing/DeclConflictClassCtor.purs diff --git a/examples/failing/DeclConflictClassSynonym.purs b/tests/purs/failing/DeclConflictClassSynonym.purs similarity index 100% rename from examples/failing/DeclConflictClassSynonym.purs rename to tests/purs/failing/DeclConflictClassSynonym.purs diff --git a/examples/failing/DeclConflictClassType.purs b/tests/purs/failing/DeclConflictClassType.purs similarity index 100% rename from examples/failing/DeclConflictClassType.purs rename to tests/purs/failing/DeclConflictClassType.purs diff --git a/examples/failing/DeclConflictCtorClass.purs b/tests/purs/failing/DeclConflictCtorClass.purs similarity index 100% rename from examples/failing/DeclConflictCtorClass.purs rename to tests/purs/failing/DeclConflictCtorClass.purs diff --git a/examples/failing/DeclConflictCtorCtor.purs b/tests/purs/failing/DeclConflictCtorCtor.purs similarity index 100% rename from examples/failing/DeclConflictCtorCtor.purs rename to tests/purs/failing/DeclConflictCtorCtor.purs diff --git a/examples/failing/DeclConflictDuplicateCtor.purs b/tests/purs/failing/DeclConflictDuplicateCtor.purs similarity index 100% rename from examples/failing/DeclConflictDuplicateCtor.purs rename to tests/purs/failing/DeclConflictDuplicateCtor.purs diff --git a/examples/failing/DeclConflictSynonymClass.purs b/tests/purs/failing/DeclConflictSynonymClass.purs similarity index 100% rename from examples/failing/DeclConflictSynonymClass.purs rename to tests/purs/failing/DeclConflictSynonymClass.purs diff --git a/examples/failing/DeclConflictSynonymType.purs b/tests/purs/failing/DeclConflictSynonymType.purs similarity index 100% rename from examples/failing/DeclConflictSynonymType.purs rename to tests/purs/failing/DeclConflictSynonymType.purs diff --git a/examples/failing/DeclConflictTypeClass.purs b/tests/purs/failing/DeclConflictTypeClass.purs similarity index 100% rename from examples/failing/DeclConflictTypeClass.purs rename to tests/purs/failing/DeclConflictTypeClass.purs diff --git a/examples/failing/DeclConflictTypeSynonym.purs b/tests/purs/failing/DeclConflictTypeSynonym.purs similarity index 100% rename from examples/failing/DeclConflictTypeSynonym.purs rename to tests/purs/failing/DeclConflictTypeSynonym.purs diff --git a/examples/failing/DeclConflictTypeType.purs b/tests/purs/failing/DeclConflictTypeType.purs similarity index 100% rename from examples/failing/DeclConflictTypeType.purs rename to tests/purs/failing/DeclConflictTypeType.purs diff --git a/examples/failing/DiffKindsSameName.purs b/tests/purs/failing/DiffKindsSameName.purs similarity index 100% rename from examples/failing/DiffKindsSameName.purs rename to tests/purs/failing/DiffKindsSameName.purs diff --git a/examples/failing/DiffKindsSameName/LibA.purs b/tests/purs/failing/DiffKindsSameName/LibA.purs similarity index 100% rename from examples/failing/DiffKindsSameName/LibA.purs rename to tests/purs/failing/DiffKindsSameName/LibA.purs diff --git a/examples/failing/DiffKindsSameName/LibB.purs b/tests/purs/failing/DiffKindsSameName/LibB.purs similarity index 100% rename from examples/failing/DiffKindsSameName/LibB.purs rename to tests/purs/failing/DiffKindsSameName/LibB.purs diff --git a/examples/failing/Do.purs b/tests/purs/failing/Do.purs similarity index 100% rename from examples/failing/Do.purs rename to tests/purs/failing/Do.purs diff --git a/examples/failing/DoNotSuggestComposition.purs b/tests/purs/failing/DoNotSuggestComposition.purs similarity index 100% rename from examples/failing/DoNotSuggestComposition.purs rename to tests/purs/failing/DoNotSuggestComposition.purs diff --git a/examples/failing/DoNotSuggestComposition2.purs b/tests/purs/failing/DoNotSuggestComposition2.purs similarity index 100% rename from examples/failing/DoNotSuggestComposition2.purs rename to tests/purs/failing/DoNotSuggestComposition2.purs diff --git a/examples/failing/DuplicateDeclarationsInLet.purs b/tests/purs/failing/DuplicateDeclarationsInLet.purs similarity index 100% rename from examples/failing/DuplicateDeclarationsInLet.purs rename to tests/purs/failing/DuplicateDeclarationsInLet.purs diff --git a/examples/failing/DuplicateInstance.purs b/tests/purs/failing/DuplicateInstance.purs similarity index 100% rename from examples/failing/DuplicateInstance.purs rename to tests/purs/failing/DuplicateInstance.purs diff --git a/examples/failing/DuplicateModule.purs b/tests/purs/failing/DuplicateModule.purs similarity index 100% rename from examples/failing/DuplicateModule.purs rename to tests/purs/failing/DuplicateModule.purs diff --git a/examples/failing/DuplicateModule/M1.purs b/tests/purs/failing/DuplicateModule/M1.purs similarity index 100% rename from examples/failing/DuplicateModule/M1.purs rename to tests/purs/failing/DuplicateModule/M1.purs diff --git a/examples/failing/DuplicateProperties.purs b/tests/purs/failing/DuplicateProperties.purs similarity index 100% rename from examples/failing/DuplicateProperties.purs rename to tests/purs/failing/DuplicateProperties.purs diff --git a/examples/failing/DuplicateTypeClass.purs b/tests/purs/failing/DuplicateTypeClass.purs similarity index 100% rename from examples/failing/DuplicateTypeClass.purs rename to tests/purs/failing/DuplicateTypeClass.purs diff --git a/examples/failing/DuplicateTypeVars.purs b/tests/purs/failing/DuplicateTypeVars.purs similarity index 100% rename from examples/failing/DuplicateTypeVars.purs rename to tests/purs/failing/DuplicateTypeVars.purs diff --git a/examples/failing/EmptyCase.purs b/tests/purs/failing/EmptyCase.purs similarity index 100% rename from examples/failing/EmptyCase.purs rename to tests/purs/failing/EmptyCase.purs diff --git a/examples/failing/EmptyClass.purs b/tests/purs/failing/EmptyClass.purs similarity index 100% rename from examples/failing/EmptyClass.purs rename to tests/purs/failing/EmptyClass.purs diff --git a/examples/failing/EmptyDo.purs b/tests/purs/failing/EmptyDo.purs similarity index 100% rename from examples/failing/EmptyDo.purs rename to tests/purs/failing/EmptyDo.purs diff --git a/examples/failing/ExpectedWildcard.purs b/tests/purs/failing/ExpectedWildcard.purs similarity index 100% rename from examples/failing/ExpectedWildcard.purs rename to tests/purs/failing/ExpectedWildcard.purs diff --git a/examples/failing/ExportConflictClass.purs b/tests/purs/failing/ExportConflictClass.purs similarity index 100% rename from examples/failing/ExportConflictClass.purs rename to tests/purs/failing/ExportConflictClass.purs diff --git a/examples/failing/ExportConflictClass/A.purs b/tests/purs/failing/ExportConflictClass/A.purs similarity index 100% rename from examples/failing/ExportConflictClass/A.purs rename to tests/purs/failing/ExportConflictClass/A.purs diff --git a/examples/failing/ExportConflictClass/B.purs b/tests/purs/failing/ExportConflictClass/B.purs similarity index 100% rename from examples/failing/ExportConflictClass/B.purs rename to tests/purs/failing/ExportConflictClass/B.purs diff --git a/examples/failing/ExportConflictCtor.purs b/tests/purs/failing/ExportConflictCtor.purs similarity index 100% rename from examples/failing/ExportConflictCtor.purs rename to tests/purs/failing/ExportConflictCtor.purs diff --git a/examples/failing/ExportConflictCtor/A.purs b/tests/purs/failing/ExportConflictCtor/A.purs similarity index 100% rename from examples/failing/ExportConflictCtor/A.purs rename to tests/purs/failing/ExportConflictCtor/A.purs diff --git a/examples/failing/ExportConflictCtor/B.purs b/tests/purs/failing/ExportConflictCtor/B.purs similarity index 100% rename from examples/failing/ExportConflictCtor/B.purs rename to tests/purs/failing/ExportConflictCtor/B.purs diff --git a/examples/failing/ExportConflictType.purs b/tests/purs/failing/ExportConflictType.purs similarity index 100% rename from examples/failing/ExportConflictType.purs rename to tests/purs/failing/ExportConflictType.purs diff --git a/examples/failing/ExportConflictType/A.purs b/tests/purs/failing/ExportConflictType/A.purs similarity index 100% rename from examples/failing/ExportConflictType/A.purs rename to tests/purs/failing/ExportConflictType/A.purs diff --git a/examples/failing/ExportConflictType/B.purs b/tests/purs/failing/ExportConflictType/B.purs similarity index 100% rename from examples/failing/ExportConflictType/B.purs rename to tests/purs/failing/ExportConflictType/B.purs diff --git a/examples/failing/ExportConflictTypeOp.purs b/tests/purs/failing/ExportConflictTypeOp.purs similarity index 100% rename from examples/failing/ExportConflictTypeOp.purs rename to tests/purs/failing/ExportConflictTypeOp.purs diff --git a/examples/failing/ExportConflictTypeOp/A.purs b/tests/purs/failing/ExportConflictTypeOp/A.purs similarity index 100% rename from examples/failing/ExportConflictTypeOp/A.purs rename to tests/purs/failing/ExportConflictTypeOp/A.purs diff --git a/examples/failing/ExportConflictTypeOp/B.purs b/tests/purs/failing/ExportConflictTypeOp/B.purs similarity index 100% rename from examples/failing/ExportConflictTypeOp/B.purs rename to tests/purs/failing/ExportConflictTypeOp/B.purs diff --git a/examples/failing/ExportConflictValue.purs b/tests/purs/failing/ExportConflictValue.purs similarity index 100% rename from examples/failing/ExportConflictValue.purs rename to tests/purs/failing/ExportConflictValue.purs diff --git a/examples/failing/ExportConflictValue/A.purs b/tests/purs/failing/ExportConflictValue/A.purs similarity index 100% rename from examples/failing/ExportConflictValue/A.purs rename to tests/purs/failing/ExportConflictValue/A.purs diff --git a/examples/failing/ExportConflictValue/B.purs b/tests/purs/failing/ExportConflictValue/B.purs similarity index 100% rename from examples/failing/ExportConflictValue/B.purs rename to tests/purs/failing/ExportConflictValue/B.purs diff --git a/examples/failing/ExportConflictValueOp.purs b/tests/purs/failing/ExportConflictValueOp.purs similarity index 100% rename from examples/failing/ExportConflictValueOp.purs rename to tests/purs/failing/ExportConflictValueOp.purs diff --git a/examples/failing/ExportConflictValueOp/A.purs b/tests/purs/failing/ExportConflictValueOp/A.purs similarity index 100% rename from examples/failing/ExportConflictValueOp/A.purs rename to tests/purs/failing/ExportConflictValueOp/A.purs diff --git a/examples/failing/ExportConflictValueOp/B.purs b/tests/purs/failing/ExportConflictValueOp/B.purs similarity index 100% rename from examples/failing/ExportConflictValueOp/B.purs rename to tests/purs/failing/ExportConflictValueOp/B.purs diff --git a/examples/failing/ExportExplicit.purs b/tests/purs/failing/ExportExplicit.purs similarity index 94% rename from examples/failing/ExportExplicit.purs rename to tests/purs/failing/ExportExplicit.purs index 20bdf00269..5132aff436 100644 --- a/examples/failing/ExportExplicit.purs +++ b/tests/purs/failing/ExportExplicit.purs @@ -1,8 +1,8 @@ --- @shouldFailWith UnknownExport --- should fail as z does not exist in the module -module M1 (x, y, z) where - -import Prelude - -x = 1 -y = 2 +-- @shouldFailWith UnknownExport +-- should fail as z does not exist in the module +module M1 (x, y, z) where + +import Prelude + +x = 1 +y = 2 diff --git a/examples/failing/ExportExplicit1.purs b/tests/purs/failing/ExportExplicit1.purs similarity index 93% rename from examples/failing/ExportExplicit1.purs rename to tests/purs/failing/ExportExplicit1.purs index 78044a5cc8..574a12a7c6 100644 --- a/examples/failing/ExportExplicit1.purs +++ b/tests/purs/failing/ExportExplicit1.purs @@ -1,12 +1,12 @@ --- @shouldFailWith UnknownName -module Main where - -import M1 -import Effect.Console (log) - -testX = X - --- should fail as Y constructor is not exported from M1 -testY = Y - -main = log "Done" +-- @shouldFailWith UnknownName +module Main where + +import M1 +import Effect.Console (log) + +testX = X + +-- should fail as Y constructor is not exported from M1 +testY = Y + +main = log "Done" diff --git a/examples/failing/ExportExplicit1/M1.purs b/tests/purs/failing/ExportExplicit1/M1.purs similarity index 92% rename from examples/failing/ExportExplicit1/M1.purs rename to tests/purs/failing/ExportExplicit1/M1.purs index 9bc4f162cf..f20006fb4b 100644 --- a/examples/failing/ExportExplicit1/M1.purs +++ b/tests/purs/failing/ExportExplicit1/M1.purs @@ -1,3 +1,3 @@ -module M1 (X(X)) where - -data X = X | Y +module M1 (X(X)) where + +data X = X | Y diff --git a/examples/failing/ExportExplicit2.purs b/tests/purs/failing/ExportExplicit2.purs similarity index 95% rename from examples/failing/ExportExplicit2.purs rename to tests/purs/failing/ExportExplicit2.purs index e105bff271..503b61ca76 100644 --- a/examples/failing/ExportExplicit2.purs +++ b/tests/purs/failing/ExportExplicit2.purs @@ -1,8 +1,8 @@ --- @shouldFailWith UnknownExportDataConstructor --- should fail as Y is not a data constructor for X -module M1 (X(Y)) where - -import Prelude - -data X = X -data Y = Y +-- @shouldFailWith UnknownExportDataConstructor +-- should fail as Y is not a data constructor for X +module M1 (X(Y)) where + +import Prelude + +data X = X +data Y = Y diff --git a/examples/failing/ExportExplicit3.purs b/tests/purs/failing/ExportExplicit3.purs similarity index 94% rename from examples/failing/ExportExplicit3.purs rename to tests/purs/failing/ExportExplicit3.purs index f52293fc0a..447936b5cb 100644 --- a/examples/failing/ExportExplicit3.purs +++ b/tests/purs/failing/ExportExplicit3.purs @@ -1,10 +1,10 @@ --- @shouldFailWith UnknownName -module Main where - -import M1 as M -import Effect.Console (log) - --- should fail as Z is not exported from M1 -testZ = M.Z - -main = log "Done" +-- @shouldFailWith UnknownName +module Main where + +import M1 as M +import Effect.Console (log) + +-- should fail as Z is not exported from M1 +testZ = M.Z + +main = log "Done" diff --git a/examples/failing/ExportExplicit3/M1.purs b/tests/purs/failing/ExportExplicit3/M1.purs similarity index 92% rename from examples/failing/ExportExplicit3/M1.purs rename to tests/purs/failing/ExportExplicit3/M1.purs index 32dd66771a..b2362dc03f 100644 --- a/examples/failing/ExportExplicit3/M1.purs +++ b/tests/purs/failing/ExportExplicit3/M1.purs @@ -1,4 +1,4 @@ -module M1 (X(..)) where - -data X = X | Y -data Z = Z +module M1 (X(..)) where + +data X = X | Y +data Z = Z diff --git a/examples/failing/ExtraRecordField.purs b/tests/purs/failing/ExtraRecordField.purs similarity index 100% rename from examples/failing/ExtraRecordField.purs rename to tests/purs/failing/ExtraRecordField.purs diff --git a/examples/failing/ExtraneousClassMember.purs b/tests/purs/failing/ExtraneousClassMember.purs similarity index 100% rename from examples/failing/ExtraneousClassMember.purs rename to tests/purs/failing/ExtraneousClassMember.purs diff --git a/examples/failing/Foldable.purs b/tests/purs/failing/Foldable.purs similarity index 100% rename from examples/failing/Foldable.purs rename to tests/purs/failing/Foldable.purs diff --git a/examples/failing/Generalization1.purs b/tests/purs/failing/Generalization1.purs similarity index 100% rename from examples/failing/Generalization1.purs rename to tests/purs/failing/Generalization1.purs diff --git a/examples/failing/Generalization2.purs b/tests/purs/failing/Generalization2.purs similarity index 100% rename from examples/failing/Generalization2.purs rename to tests/purs/failing/Generalization2.purs diff --git a/examples/failing/ImportExplicit.purs b/tests/purs/failing/ImportExplicit.purs similarity index 94% rename from examples/failing/ImportExplicit.purs rename to tests/purs/failing/ImportExplicit.purs index d42df77cb4..c6c30e1228 100644 --- a/examples/failing/ImportExplicit.purs +++ b/tests/purs/failing/ImportExplicit.purs @@ -1,4 +1,4 @@ --- @shouldFailWith UnknownImport -module Main where - -import M1 (X(..)) +-- @shouldFailWith UnknownImport +module Main where + +import M1 (X(..)) diff --git a/examples/failing/ImportExplicit/M1.purs b/tests/purs/failing/ImportExplicit/M1.purs similarity index 90% rename from examples/failing/ImportExplicit/M1.purs rename to tests/purs/failing/ImportExplicit/M1.purs index f3155b81eb..9b75cf2d89 100644 --- a/examples/failing/ImportExplicit/M1.purs +++ b/tests/purs/failing/ImportExplicit/M1.purs @@ -1,3 +1,3 @@ -module M1 where - -foo = "foo" +module M1 where + +foo = "foo" diff --git a/examples/failing/ImportExplicit2.purs b/tests/purs/failing/ImportExplicit2.purs similarity index 95% rename from examples/failing/ImportExplicit2.purs rename to tests/purs/failing/ImportExplicit2.purs index e1b43c6258..584667d578 100644 --- a/examples/failing/ImportExplicit2.purs +++ b/tests/purs/failing/ImportExplicit2.purs @@ -1,4 +1,4 @@ --- @shouldFailWith UnknownImportDataConstructor -module Main where - -import M1 (X(Z, Q)) +-- @shouldFailWith UnknownImportDataConstructor +module Main where + +import M1 (X(Z, Q)) diff --git a/examples/failing/ImportExplicit2/M1.purs b/tests/purs/failing/ImportExplicit2/M1.purs similarity index 90% rename from examples/failing/ImportExplicit2/M1.purs rename to tests/purs/failing/ImportExplicit2/M1.purs index 35fd17c4f0..168e8f20ea 100644 --- a/examples/failing/ImportExplicit2/M1.purs +++ b/tests/purs/failing/ImportExplicit2/M1.purs @@ -1,3 +1,3 @@ -module M1 where - -data X = Y +module M1 where + +data X = Y diff --git a/examples/failing/ImportHidingModule.purs b/tests/purs/failing/ImportHidingModule.purs similarity index 95% rename from examples/failing/ImportHidingModule.purs rename to tests/purs/failing/ImportHidingModule.purs index 5fa1025780..bda20bed92 100644 --- a/examples/failing/ImportHidingModule.purs +++ b/tests/purs/failing/ImportHidingModule.purs @@ -1,4 +1,4 @@ --- @shouldFailWith ImportHidingModule -module Main where - -import B hiding (module A) +-- @shouldFailWith ImportHidingModule +module Main where + +import B hiding (module A) diff --git a/examples/failing/ImportHidingModule/A.purs b/tests/purs/failing/ImportHidingModule/A.purs similarity index 91% rename from examples/failing/ImportHidingModule/A.purs rename to tests/purs/failing/ImportHidingModule/A.purs index e741925669..ec3490fd4e 100644 --- a/examples/failing/ImportHidingModule/A.purs +++ b/tests/purs/failing/ImportHidingModule/A.purs @@ -1,2 +1,2 @@ -module A where -x = 1 +module A where +x = 1 diff --git a/examples/failing/ImportHidingModule/B.purs b/tests/purs/failing/ImportHidingModule/B.purs similarity index 94% rename from examples/failing/ImportHidingModule/B.purs rename to tests/purs/failing/ImportHidingModule/B.purs index e714878ce8..3230bfd4f7 100644 --- a/examples/failing/ImportHidingModule/B.purs +++ b/tests/purs/failing/ImportHidingModule/B.purs @@ -1,3 +1,3 @@ -module B (module B, module A) where -import A -y = 1 +module B (module B, module A) where +import A +y = 1 diff --git a/examples/failing/ImportModule.purs b/tests/purs/failing/ImportModule.purs similarity index 94% rename from examples/failing/ImportModule.purs rename to tests/purs/failing/ImportModule.purs index a996fbcf95..28d61b1887 100644 --- a/examples/failing/ImportModule.purs +++ b/tests/purs/failing/ImportModule.purs @@ -1,4 +1,4 @@ --- @shouldFailWith ModuleNotFound -module Main where - -import M1 +-- @shouldFailWith ModuleNotFound +module Main where + +import M1 diff --git a/examples/failing/ImportModule/M2.purs b/tests/purs/failing/ImportModule/M2.purs similarity index 90% rename from examples/failing/ImportModule/M2.purs rename to tests/purs/failing/ImportModule/M2.purs index c1a472fb1e..e69cb1f64c 100644 --- a/examples/failing/ImportModule/M2.purs +++ b/tests/purs/failing/ImportModule/M2.purs @@ -1,3 +1,3 @@ -module M2 where - -data X = X +module M2 where + +data X = X diff --git a/examples/failing/InfiniteKind.purs b/tests/purs/failing/InfiniteKind.purs similarity index 100% rename from examples/failing/InfiniteKind.purs rename to tests/purs/failing/InfiniteKind.purs diff --git a/examples/failing/InfiniteKind2.purs b/tests/purs/failing/InfiniteKind2.purs similarity index 100% rename from examples/failing/InfiniteKind2.purs rename to tests/purs/failing/InfiniteKind2.purs diff --git a/examples/failing/InfiniteType.purs b/tests/purs/failing/InfiniteType.purs similarity index 100% rename from examples/failing/InfiniteType.purs rename to tests/purs/failing/InfiniteType.purs diff --git a/examples/failing/InstanceChainBothUnknownAndMatch.purs b/tests/purs/failing/InstanceChainBothUnknownAndMatch.purs similarity index 100% rename from examples/failing/InstanceChainBothUnknownAndMatch.purs rename to tests/purs/failing/InstanceChainBothUnknownAndMatch.purs diff --git a/examples/failing/InstanceChainSkolemUnknownMatch.purs b/tests/purs/failing/InstanceChainSkolemUnknownMatch.purs similarity index 100% rename from examples/failing/InstanceChainSkolemUnknownMatch.purs rename to tests/purs/failing/InstanceChainSkolemUnknownMatch.purs diff --git a/examples/failing/InstanceExport.purs b/tests/purs/failing/InstanceExport.purs similarity index 94% rename from examples/failing/InstanceExport.purs rename to tests/purs/failing/InstanceExport.purs index a87b8819ce..e680b22a40 100644 --- a/examples/failing/InstanceExport.purs +++ b/tests/purs/failing/InstanceExport.purs @@ -1,7 +1,7 @@ --- @shouldFailWith TransitiveExportError -module Test where - -import InstanceExport -import Prelude - -test = f $ S "Test" +-- @shouldFailWith TransitiveExportError +module Test where + +import InstanceExport +import Prelude + +test = f $ S "Test" diff --git a/examples/failing/InstanceExport/InstanceExport.purs b/tests/purs/failing/InstanceExport/InstanceExport.purs similarity index 93% rename from examples/failing/InstanceExport/InstanceExport.purs rename to tests/purs/failing/InstanceExport/InstanceExport.purs index 477085750c..e428a5ce14 100644 --- a/examples/failing/InstanceExport/InstanceExport.purs +++ b/tests/purs/failing/InstanceExport/InstanceExport.purs @@ -1,11 +1,11 @@ -module InstanceExport (S(..), f) where - -import Prelude - -newtype S = S String - -class F a where - f :: a -> String - -instance fs :: F S where - f (S s) = s +module InstanceExport (S(..), f) where + +import Prelude + +newtype S = S String + +class F a where + f :: a -> String + +instance fs :: F S where + f (S s) = s diff --git a/examples/failing/InstanceSigsBodyIncorrect.purs b/tests/purs/failing/InstanceSigsBodyIncorrect.purs similarity index 100% rename from examples/failing/InstanceSigsBodyIncorrect.purs rename to tests/purs/failing/InstanceSigsBodyIncorrect.purs diff --git a/examples/failing/InstanceSigsDifferentTypes.purs b/tests/purs/failing/InstanceSigsDifferentTypes.purs similarity index 100% rename from examples/failing/InstanceSigsDifferentTypes.purs rename to tests/purs/failing/InstanceSigsDifferentTypes.purs diff --git a/examples/failing/InstanceSigsIncorrectType.purs b/tests/purs/failing/InstanceSigsIncorrectType.purs similarity index 100% rename from examples/failing/InstanceSigsIncorrectType.purs rename to tests/purs/failing/InstanceSigsIncorrectType.purs diff --git a/examples/failing/InstanceSigsOrphanTypeDeclaration.purs b/tests/purs/failing/InstanceSigsOrphanTypeDeclaration.purs similarity index 100% rename from examples/failing/InstanceSigsOrphanTypeDeclaration.purs rename to tests/purs/failing/InstanceSigsOrphanTypeDeclaration.purs diff --git a/examples/failing/IntOutOfRange.purs b/tests/purs/failing/IntOutOfRange.purs similarity index 100% rename from examples/failing/IntOutOfRange.purs rename to tests/purs/failing/IntOutOfRange.purs diff --git a/examples/failing/InvalidDerivedInstance.purs b/tests/purs/failing/InvalidDerivedInstance.purs similarity index 100% rename from examples/failing/InvalidDerivedInstance.purs rename to tests/purs/failing/InvalidDerivedInstance.purs diff --git a/examples/failing/InvalidDerivedInstance2.purs b/tests/purs/failing/InvalidDerivedInstance2.purs similarity index 100% rename from examples/failing/InvalidDerivedInstance2.purs rename to tests/purs/failing/InvalidDerivedInstance2.purs diff --git a/examples/failing/InvalidOperatorInBinder.purs b/tests/purs/failing/InvalidOperatorInBinder.purs similarity index 100% rename from examples/failing/InvalidOperatorInBinder.purs rename to tests/purs/failing/InvalidOperatorInBinder.purs diff --git a/examples/failing/KindError.purs b/tests/purs/failing/KindError.purs similarity index 100% rename from examples/failing/KindError.purs rename to tests/purs/failing/KindError.purs diff --git a/examples/failing/KindStar.purs b/tests/purs/failing/KindStar.purs similarity index 100% rename from examples/failing/KindStar.purs rename to tests/purs/failing/KindStar.purs diff --git a/examples/failing/LeadingZeros1.purs b/tests/purs/failing/LeadingZeros1.purs similarity index 100% rename from examples/failing/LeadingZeros1.purs rename to tests/purs/failing/LeadingZeros1.purs diff --git a/examples/failing/LeadingZeros2.purs b/tests/purs/failing/LeadingZeros2.purs similarity index 100% rename from examples/failing/LeadingZeros2.purs rename to tests/purs/failing/LeadingZeros2.purs diff --git a/examples/failing/Let.purs b/tests/purs/failing/Let.purs similarity index 100% rename from examples/failing/Let.purs rename to tests/purs/failing/Let.purs diff --git a/examples/failing/LetPatterns1.purs b/tests/purs/failing/LetPatterns1.purs similarity index 100% rename from examples/failing/LetPatterns1.purs rename to tests/purs/failing/LetPatterns1.purs diff --git a/examples/failing/LetPatterns2.purs b/tests/purs/failing/LetPatterns2.purs similarity index 100% rename from examples/failing/LetPatterns2.purs rename to tests/purs/failing/LetPatterns2.purs diff --git a/examples/failing/LetPatterns3.purs b/tests/purs/failing/LetPatterns3.purs similarity index 100% rename from examples/failing/LetPatterns3.purs rename to tests/purs/failing/LetPatterns3.purs diff --git a/examples/failing/LetPatterns4.purs b/tests/purs/failing/LetPatterns4.purs similarity index 100% rename from examples/failing/LetPatterns4.purs rename to tests/purs/failing/LetPatterns4.purs diff --git a/examples/failing/MPTCs.purs b/tests/purs/failing/MPTCs.purs similarity index 100% rename from examples/failing/MPTCs.purs rename to tests/purs/failing/MPTCs.purs diff --git a/examples/failing/MissingClassExport.purs b/tests/purs/failing/MissingClassExport.purs similarity index 100% rename from examples/failing/MissingClassExport.purs rename to tests/purs/failing/MissingClassExport.purs diff --git a/examples/failing/MissingClassMember.purs b/tests/purs/failing/MissingClassMember.purs similarity index 100% rename from examples/failing/MissingClassMember.purs rename to tests/purs/failing/MissingClassMember.purs diff --git a/examples/failing/MissingClassMemberExport.purs b/tests/purs/failing/MissingClassMemberExport.purs similarity index 100% rename from examples/failing/MissingClassMemberExport.purs rename to tests/purs/failing/MissingClassMemberExport.purs diff --git a/examples/failing/MissingFFIImplementations.js b/tests/purs/failing/MissingFFIImplementations.js similarity index 100% rename from examples/failing/MissingFFIImplementations.js rename to tests/purs/failing/MissingFFIImplementations.js diff --git a/examples/failing/MissingFFIImplementations.purs b/tests/purs/failing/MissingFFIImplementations.purs similarity index 100% rename from examples/failing/MissingFFIImplementations.purs rename to tests/purs/failing/MissingFFIImplementations.purs diff --git a/examples/failing/MissingRecordField.purs b/tests/purs/failing/MissingRecordField.purs similarity index 100% rename from examples/failing/MissingRecordField.purs rename to tests/purs/failing/MissingRecordField.purs diff --git a/examples/failing/MixedAssociativityError.purs b/tests/purs/failing/MixedAssociativityError.purs similarity index 100% rename from examples/failing/MixedAssociativityError.purs rename to tests/purs/failing/MixedAssociativityError.purs diff --git a/examples/failing/MultipleErrors.purs b/tests/purs/failing/MultipleErrors.purs similarity index 100% rename from examples/failing/MultipleErrors.purs rename to tests/purs/failing/MultipleErrors.purs diff --git a/examples/failing/MultipleErrors2.purs b/tests/purs/failing/MultipleErrors2.purs similarity index 100% rename from examples/failing/MultipleErrors2.purs rename to tests/purs/failing/MultipleErrors2.purs diff --git a/examples/failing/MultipleTypeOpFixities.purs b/tests/purs/failing/MultipleTypeOpFixities.purs similarity index 94% rename from examples/failing/MultipleTypeOpFixities.purs rename to tests/purs/failing/MultipleTypeOpFixities.purs index b231e5425f..5d1b28146c 100644 --- a/examples/failing/MultipleTypeOpFixities.purs +++ b/tests/purs/failing/MultipleTypeOpFixities.purs @@ -1,9 +1,9 @@ --- @shouldFailWith MultipleTypeOpFixities -module MultipleTypeOpFixities where - -import Prelude - -type Op x y = Op x y - -infix 2 type Op as !? -infix 2 type Op as !? +-- @shouldFailWith MultipleTypeOpFixities +module MultipleTypeOpFixities where + +import Prelude + +type Op x y = Op x y + +infix 2 type Op as !? +infix 2 type Op as !? diff --git a/examples/failing/MultipleValueOpFixities.purs b/tests/purs/failing/MultipleValueOpFixities.purs similarity index 94% rename from examples/failing/MultipleValueOpFixities.purs rename to tests/purs/failing/MultipleValueOpFixities.purs index ac8bfa95d8..f1e4ccfecb 100644 --- a/examples/failing/MultipleValueOpFixities.purs +++ b/tests/purs/failing/MultipleValueOpFixities.purs @@ -1,9 +1,9 @@ --- @shouldFailWith MultipleValueOpFixities -module MultipleValueOpFixities where - -import Prelude - -add x y = x + y - -infix 2 add as !? -infix 2 add as !? +-- @shouldFailWith MultipleValueOpFixities +module MultipleValueOpFixities where + +import Prelude + +add x y = x + y + +infix 2 add as !? +infix 2 add as !? diff --git a/examples/failing/MutRec.purs b/tests/purs/failing/MutRec.purs similarity index 100% rename from examples/failing/MutRec.purs rename to tests/purs/failing/MutRec.purs diff --git a/examples/failing/MutRec2.purs b/tests/purs/failing/MutRec2.purs similarity index 100% rename from examples/failing/MutRec2.purs rename to tests/purs/failing/MutRec2.purs diff --git a/examples/failing/NewtypeInstance.purs b/tests/purs/failing/NewtypeInstance.purs similarity index 100% rename from examples/failing/NewtypeInstance.purs rename to tests/purs/failing/NewtypeInstance.purs diff --git a/examples/failing/NewtypeInstance2.purs b/tests/purs/failing/NewtypeInstance2.purs similarity index 100% rename from examples/failing/NewtypeInstance2.purs rename to tests/purs/failing/NewtypeInstance2.purs diff --git a/examples/failing/NewtypeInstance3.purs b/tests/purs/failing/NewtypeInstance3.purs similarity index 100% rename from examples/failing/NewtypeInstance3.purs rename to tests/purs/failing/NewtypeInstance3.purs diff --git a/examples/failing/NewtypeInstance4.purs b/tests/purs/failing/NewtypeInstance4.purs similarity index 100% rename from examples/failing/NewtypeInstance4.purs rename to tests/purs/failing/NewtypeInstance4.purs diff --git a/examples/failing/NewtypeInstance5.purs b/tests/purs/failing/NewtypeInstance5.purs similarity index 100% rename from examples/failing/NewtypeInstance5.purs rename to tests/purs/failing/NewtypeInstance5.purs diff --git a/examples/failing/NewtypeInstance6.purs b/tests/purs/failing/NewtypeInstance6.purs similarity index 100% rename from examples/failing/NewtypeInstance6.purs rename to tests/purs/failing/NewtypeInstance6.purs diff --git a/examples/failing/NewtypeMultiArgs.purs b/tests/purs/failing/NewtypeMultiArgs.purs similarity index 100% rename from examples/failing/NewtypeMultiArgs.purs rename to tests/purs/failing/NewtypeMultiArgs.purs diff --git a/examples/failing/NewtypeMultiCtor.purs b/tests/purs/failing/NewtypeMultiCtor.purs similarity index 100% rename from examples/failing/NewtypeMultiCtor.purs rename to tests/purs/failing/NewtypeMultiCtor.purs diff --git a/examples/failing/NonAssociativeError.purs b/tests/purs/failing/NonAssociativeError.purs similarity index 100% rename from examples/failing/NonAssociativeError.purs rename to tests/purs/failing/NonAssociativeError.purs diff --git a/examples/failing/NonExhaustivePatGuard.purs b/tests/purs/failing/NonExhaustivePatGuard.purs similarity index 100% rename from examples/failing/NonExhaustivePatGuard.purs rename to tests/purs/failing/NonExhaustivePatGuard.purs diff --git a/examples/failing/NullaryAbs.purs b/tests/purs/failing/NullaryAbs.purs similarity index 100% rename from examples/failing/NullaryAbs.purs rename to tests/purs/failing/NullaryAbs.purs diff --git a/examples/failing/Object.purs b/tests/purs/failing/Object.purs similarity index 100% rename from examples/failing/Object.purs rename to tests/purs/failing/Object.purs diff --git a/examples/failing/OperatorAliasNoExport.purs b/tests/purs/failing/OperatorAliasNoExport.purs similarity index 100% rename from examples/failing/OperatorAliasNoExport.purs rename to tests/purs/failing/OperatorAliasNoExport.purs diff --git a/examples/failing/OperatorSections.purs b/tests/purs/failing/OperatorSections.purs similarity index 100% rename from examples/failing/OperatorSections.purs rename to tests/purs/failing/OperatorSections.purs diff --git a/examples/failing/OrphanInstance.purs b/tests/purs/failing/OrphanInstance.purs similarity index 94% rename from examples/failing/OrphanInstance.purs rename to tests/purs/failing/OrphanInstance.purs index fa7703d054..85c3656c97 100644 --- a/examples/failing/OrphanInstance.purs +++ b/tests/purs/failing/OrphanInstance.purs @@ -1,7 +1,7 @@ --- @shouldFailWith OrphanInstance -module Test where - -import Class - -instance cBoolean :: C Boolean where - op a = a +-- @shouldFailWith OrphanInstance +module Test where + +import Class + +instance cBoolean :: C Boolean where + op a = a diff --git a/examples/failing/OrphanInstance/Class.purs b/tests/purs/failing/OrphanInstance/Class.purs similarity index 92% rename from examples/failing/OrphanInstance/Class.purs rename to tests/purs/failing/OrphanInstance/Class.purs index 6f7d61f4e0..0b482d48a1 100644 --- a/examples/failing/OrphanInstance/Class.purs +++ b/tests/purs/failing/OrphanInstance/Class.purs @@ -1,4 +1,4 @@ -module Class where - -class C a where - op :: a -> a +module Class where + +class C a where + op :: a -> a diff --git a/examples/failing/OrphanInstanceFunDepCycle.purs b/tests/purs/failing/OrphanInstanceFunDepCycle.purs similarity index 100% rename from examples/failing/OrphanInstanceFunDepCycle.purs rename to tests/purs/failing/OrphanInstanceFunDepCycle.purs diff --git a/examples/failing/OrphanInstanceFunDepCycle/Lib.purs b/tests/purs/failing/OrphanInstanceFunDepCycle/Lib.purs similarity index 100% rename from examples/failing/OrphanInstanceFunDepCycle/Lib.purs rename to tests/purs/failing/OrphanInstanceFunDepCycle/Lib.purs diff --git a/examples/failing/OrphanInstanceNullary.purs b/tests/purs/failing/OrphanInstanceNullary.purs similarity index 95% rename from examples/failing/OrphanInstanceNullary.purs rename to tests/purs/failing/OrphanInstanceNullary.purs index cd2e6af653..14c6184b51 100644 --- a/examples/failing/OrphanInstanceNullary.purs +++ b/tests/purs/failing/OrphanInstanceNullary.purs @@ -1,4 +1,4 @@ --- @shouldFailWith OrphanInstance -module Test where -import Lib -instance c :: C +-- @shouldFailWith OrphanInstance +module Test where +import Lib +instance c :: C diff --git a/examples/failing/OrphanInstanceNullary/Lib.purs b/tests/purs/failing/OrphanInstanceNullary/Lib.purs similarity index 92% rename from examples/failing/OrphanInstanceNullary/Lib.purs rename to tests/purs/failing/OrphanInstanceNullary/Lib.purs index b96dc898c5..1ba95def1a 100644 --- a/examples/failing/OrphanInstanceNullary/Lib.purs +++ b/tests/purs/failing/OrphanInstanceNullary/Lib.purs @@ -1,2 +1,2 @@ -module Lib where -class C +module Lib where +class C diff --git a/examples/failing/OrphanInstanceWithDetermined.purs b/tests/purs/failing/OrphanInstanceWithDetermined.purs similarity index 100% rename from examples/failing/OrphanInstanceWithDetermined.purs rename to tests/purs/failing/OrphanInstanceWithDetermined.purs diff --git a/examples/failing/OrphanInstanceWithDetermined/Lib.purs b/tests/purs/failing/OrphanInstanceWithDetermined/Lib.purs similarity index 100% rename from examples/failing/OrphanInstanceWithDetermined/Lib.purs rename to tests/purs/failing/OrphanInstanceWithDetermined/Lib.purs diff --git a/examples/failing/OrphanTypeDecl.purs b/tests/purs/failing/OrphanTypeDecl.purs similarity index 95% rename from examples/failing/OrphanTypeDecl.purs rename to tests/purs/failing/OrphanTypeDecl.purs index b5f15310f9..a178e5da23 100644 --- a/examples/failing/OrphanTypeDecl.purs +++ b/tests/purs/failing/OrphanTypeDecl.purs @@ -1,4 +1,4 @@ --- @shouldFailWith OrphanTypeDeclaration -module OrphanTypeDecl where - -fn :: Number -> Boolean +-- @shouldFailWith OrphanTypeDeclaration +module OrphanTypeDecl where + +fn :: Number -> Boolean diff --git a/examples/failing/OverlapAcrossModules.purs b/tests/purs/failing/OverlapAcrossModules.purs similarity index 100% rename from examples/failing/OverlapAcrossModules.purs rename to tests/purs/failing/OverlapAcrossModules.purs diff --git a/examples/failing/OverlapAcrossModules/Class.purs b/tests/purs/failing/OverlapAcrossModules/Class.purs similarity index 100% rename from examples/failing/OverlapAcrossModules/Class.purs rename to tests/purs/failing/OverlapAcrossModules/Class.purs diff --git a/examples/failing/OverlapAcrossModules/X.purs b/tests/purs/failing/OverlapAcrossModules/X.purs similarity index 100% rename from examples/failing/OverlapAcrossModules/X.purs rename to tests/purs/failing/OverlapAcrossModules/X.purs diff --git a/examples/failing/OverlappingArguments.purs b/tests/purs/failing/OverlappingArguments.purs similarity index 100% rename from examples/failing/OverlappingArguments.purs rename to tests/purs/failing/OverlappingArguments.purs diff --git a/examples/failing/OverlappingBinders.purs b/tests/purs/failing/OverlappingBinders.purs similarity index 100% rename from examples/failing/OverlappingBinders.purs rename to tests/purs/failing/OverlappingBinders.purs diff --git a/examples/failing/OverlappingInstances.purs b/tests/purs/failing/OverlappingInstances.purs similarity index 100% rename from examples/failing/OverlappingInstances.purs rename to tests/purs/failing/OverlappingInstances.purs diff --git a/examples/failing/OverlappingVars.purs b/tests/purs/failing/OverlappingVars.purs similarity index 100% rename from examples/failing/OverlappingVars.purs rename to tests/purs/failing/OverlappingVars.purs diff --git a/examples/failing/PrimModuleReserved.purs b/tests/purs/failing/PrimModuleReserved.purs similarity index 100% rename from examples/failing/PrimModuleReserved.purs rename to tests/purs/failing/PrimModuleReserved.purs diff --git a/examples/failing/PrimModuleReserved/Prim.purs b/tests/purs/failing/PrimModuleReserved/Prim.purs similarity index 100% rename from examples/failing/PrimModuleReserved/Prim.purs rename to tests/purs/failing/PrimModuleReserved/Prim.purs diff --git a/examples/failing/PrimRow.purs b/tests/purs/failing/PrimRow.purs similarity index 100% rename from examples/failing/PrimRow.purs rename to tests/purs/failing/PrimRow.purs diff --git a/examples/failing/PrimSubModuleReserved.purs b/tests/purs/failing/PrimSubModuleReserved.purs similarity index 100% rename from examples/failing/PrimSubModuleReserved.purs rename to tests/purs/failing/PrimSubModuleReserved.purs diff --git a/examples/failing/PrimSubModuleReserved/Prim_Foobar.purs b/tests/purs/failing/PrimSubModuleReserved/Prim_Foobar.purs similarity index 100% rename from examples/failing/PrimSubModuleReserved/Prim_Foobar.purs rename to tests/purs/failing/PrimSubModuleReserved/Prim_Foobar.purs diff --git a/examples/failing/ProgrammableTypeErrors.purs b/tests/purs/failing/ProgrammableTypeErrors.purs similarity index 100% rename from examples/failing/ProgrammableTypeErrors.purs rename to tests/purs/failing/ProgrammableTypeErrors.purs diff --git a/examples/failing/ProgrammableTypeErrorsTypeString.purs b/tests/purs/failing/ProgrammableTypeErrorsTypeString.purs similarity index 100% rename from examples/failing/ProgrammableTypeErrorsTypeString.purs rename to tests/purs/failing/ProgrammableTypeErrorsTypeString.purs diff --git a/examples/failing/Rank2Types.purs b/tests/purs/failing/Rank2Types.purs similarity index 100% rename from examples/failing/Rank2Types.purs rename to tests/purs/failing/Rank2Types.purs diff --git a/examples/failing/RequiredHiddenType.purs b/tests/purs/failing/RequiredHiddenType.purs similarity index 94% rename from examples/failing/RequiredHiddenType.purs rename to tests/purs/failing/RequiredHiddenType.purs index a849ab0776..ee86fe6445 100644 --- a/examples/failing/RequiredHiddenType.purs +++ b/tests/purs/failing/RequiredHiddenType.purs @@ -1,9 +1,9 @@ --- @shouldFailWith TransitiveExportError --- exporting `a` should fail as `A` is hidden -module Foo (B(..), a, b) where - -data A = A -data B = B - -a = A -b = B +-- @shouldFailWith TransitiveExportError +-- exporting `a` should fail as `A` is hidden +module Foo (B(..), a, b) where + +data A = A +data B = B + +a = A +b = B diff --git a/examples/failing/Reserved.purs b/tests/purs/failing/Reserved.purs similarity index 100% rename from examples/failing/Reserved.purs rename to tests/purs/failing/Reserved.purs diff --git a/examples/failing/RowConstructors1.purs b/tests/purs/failing/RowConstructors1.purs similarity index 100% rename from examples/failing/RowConstructors1.purs rename to tests/purs/failing/RowConstructors1.purs diff --git a/examples/failing/RowConstructors2.purs b/tests/purs/failing/RowConstructors2.purs similarity index 100% rename from examples/failing/RowConstructors2.purs rename to tests/purs/failing/RowConstructors2.purs diff --git a/examples/failing/RowConstructors3.purs b/tests/purs/failing/RowConstructors3.purs similarity index 100% rename from examples/failing/RowConstructors3.purs rename to tests/purs/failing/RowConstructors3.purs diff --git a/examples/failing/RowInInstanceNotDetermined0.purs b/tests/purs/failing/RowInInstanceNotDetermined0.purs similarity index 100% rename from examples/failing/RowInInstanceNotDetermined0.purs rename to tests/purs/failing/RowInInstanceNotDetermined0.purs diff --git a/examples/failing/RowInInstanceNotDetermined1.purs b/tests/purs/failing/RowInInstanceNotDetermined1.purs similarity index 100% rename from examples/failing/RowInInstanceNotDetermined1.purs rename to tests/purs/failing/RowInInstanceNotDetermined1.purs diff --git a/examples/failing/RowInInstanceNotDetermined2.purs b/tests/purs/failing/RowInInstanceNotDetermined2.purs similarity index 100% rename from examples/failing/RowInInstanceNotDetermined2.purs rename to tests/purs/failing/RowInInstanceNotDetermined2.purs diff --git a/examples/failing/RowLacks.purs b/tests/purs/failing/RowLacks.purs similarity index 100% rename from examples/failing/RowLacks.purs rename to tests/purs/failing/RowLacks.purs diff --git a/examples/failing/SkolemEscape.purs b/tests/purs/failing/SkolemEscape.purs similarity index 100% rename from examples/failing/SkolemEscape.purs rename to tests/purs/failing/SkolemEscape.purs diff --git a/examples/failing/SkolemEscape2.purs b/tests/purs/failing/SkolemEscape2.purs similarity index 100% rename from examples/failing/SkolemEscape2.purs rename to tests/purs/failing/SkolemEscape2.purs diff --git a/examples/failing/SuggestComposition.purs b/tests/purs/failing/SuggestComposition.purs similarity index 100% rename from examples/failing/SuggestComposition.purs rename to tests/purs/failing/SuggestComposition.purs diff --git a/examples/failing/Superclasses1.purs b/tests/purs/failing/Superclasses1.purs similarity index 100% rename from examples/failing/Superclasses1.purs rename to tests/purs/failing/Superclasses1.purs diff --git a/examples/failing/Superclasses2.purs b/tests/purs/failing/Superclasses2.purs similarity index 100% rename from examples/failing/Superclasses2.purs rename to tests/purs/failing/Superclasses2.purs diff --git a/examples/failing/Superclasses3.purs b/tests/purs/failing/Superclasses3.purs similarity index 100% rename from examples/failing/Superclasses3.purs rename to tests/purs/failing/Superclasses3.purs diff --git a/examples/failing/Superclasses5.purs b/tests/purs/failing/Superclasses5.purs similarity index 100% rename from examples/failing/Superclasses5.purs rename to tests/purs/failing/Superclasses5.purs diff --git a/examples/failing/TooFewClassInstanceArgs.purs b/tests/purs/failing/TooFewClassInstanceArgs.purs similarity index 100% rename from examples/failing/TooFewClassInstanceArgs.purs rename to tests/purs/failing/TooFewClassInstanceArgs.purs diff --git a/examples/failing/TopLevelCaseNoArgs.purs b/tests/purs/failing/TopLevelCaseNoArgs.purs similarity index 100% rename from examples/failing/TopLevelCaseNoArgs.purs rename to tests/purs/failing/TopLevelCaseNoArgs.purs diff --git a/examples/failing/TransitiveDctorExport.purs b/tests/purs/failing/TransitiveDctorExport.purs similarity index 100% rename from examples/failing/TransitiveDctorExport.purs rename to tests/purs/failing/TransitiveDctorExport.purs diff --git a/examples/failing/TransitiveSynonymExport.purs b/tests/purs/failing/TransitiveSynonymExport.purs similarity index 100% rename from examples/failing/TransitiveSynonymExport.purs rename to tests/purs/failing/TransitiveSynonymExport.purs diff --git a/examples/failing/TypeClasses2.purs b/tests/purs/failing/TypeClasses2.purs similarity index 100% rename from examples/failing/TypeClasses2.purs rename to tests/purs/failing/TypeClasses2.purs diff --git a/examples/failing/TypeError.purs b/tests/purs/failing/TypeError.purs similarity index 100% rename from examples/failing/TypeError.purs rename to tests/purs/failing/TypeError.purs diff --git a/examples/failing/TypeOperatorAliasNoExport.purs b/tests/purs/failing/TypeOperatorAliasNoExport.purs similarity index 100% rename from examples/failing/TypeOperatorAliasNoExport.purs rename to tests/purs/failing/TypeOperatorAliasNoExport.purs diff --git a/examples/failing/TypeSynonyms.purs b/tests/purs/failing/TypeSynonyms.purs similarity index 100% rename from examples/failing/TypeSynonyms.purs rename to tests/purs/failing/TypeSynonyms.purs diff --git a/examples/failing/TypeSynonyms2.purs b/tests/purs/failing/TypeSynonyms2.purs similarity index 100% rename from examples/failing/TypeSynonyms2.purs rename to tests/purs/failing/TypeSynonyms2.purs diff --git a/examples/failing/TypeSynonyms3.purs b/tests/purs/failing/TypeSynonyms3.purs similarity index 100% rename from examples/failing/TypeSynonyms3.purs rename to tests/purs/failing/TypeSynonyms3.purs diff --git a/examples/failing/TypeSynonyms4.purs b/tests/purs/failing/TypeSynonyms4.purs similarity index 100% rename from examples/failing/TypeSynonyms4.purs rename to tests/purs/failing/TypeSynonyms4.purs diff --git a/examples/failing/TypeSynonyms5.purs b/tests/purs/failing/TypeSynonyms5.purs similarity index 100% rename from examples/failing/TypeSynonyms5.purs rename to tests/purs/failing/TypeSynonyms5.purs diff --git a/examples/failing/TypeWildcards1.purs b/tests/purs/failing/TypeWildcards1.purs similarity index 100% rename from examples/failing/TypeWildcards1.purs rename to tests/purs/failing/TypeWildcards1.purs diff --git a/examples/failing/TypeWildcards2.purs b/tests/purs/failing/TypeWildcards2.purs similarity index 100% rename from examples/failing/TypeWildcards2.purs rename to tests/purs/failing/TypeWildcards2.purs diff --git a/examples/failing/TypeWildcards3.purs b/tests/purs/failing/TypeWildcards3.purs similarity index 100% rename from examples/failing/TypeWildcards3.purs rename to tests/purs/failing/TypeWildcards3.purs diff --git a/examples/failing/TypedBinders.purs b/tests/purs/failing/TypedBinders.purs similarity index 100% rename from examples/failing/TypedBinders.purs rename to tests/purs/failing/TypedBinders.purs diff --git a/examples/failing/TypedBinders2.purs b/tests/purs/failing/TypedBinders2.purs similarity index 100% rename from examples/failing/TypedBinders2.purs rename to tests/purs/failing/TypedBinders2.purs diff --git a/examples/failing/TypedBinders3.purs b/tests/purs/failing/TypedBinders3.purs similarity index 100% rename from examples/failing/TypedBinders3.purs rename to tests/purs/failing/TypedBinders3.purs diff --git a/examples/failing/TypedHole.purs b/tests/purs/failing/TypedHole.purs similarity index 100% rename from examples/failing/TypedHole.purs rename to tests/purs/failing/TypedHole.purs diff --git a/examples/failing/UnderscoreModuleName.purs b/tests/purs/failing/UnderscoreModuleName.purs similarity index 100% rename from examples/failing/UnderscoreModuleName.purs rename to tests/purs/failing/UnderscoreModuleName.purs diff --git a/examples/failing/UnknownType.purs b/tests/purs/failing/UnknownType.purs similarity index 100% rename from examples/failing/UnknownType.purs rename to tests/purs/failing/UnknownType.purs diff --git a/examples/failing/UnusableTypeClassMethod.purs b/tests/purs/failing/UnusableTypeClassMethod.purs similarity index 100% rename from examples/failing/UnusableTypeClassMethod.purs rename to tests/purs/failing/UnusableTypeClassMethod.purs diff --git a/examples/failing/UnusableTypeClassMethodConflictingIdent.purs b/tests/purs/failing/UnusableTypeClassMethodConflictingIdent.purs similarity index 100% rename from examples/failing/UnusableTypeClassMethodConflictingIdent.purs rename to tests/purs/failing/UnusableTypeClassMethodConflictingIdent.purs diff --git a/examples/failing/UnusableTypeClassMethodSynonym.purs b/tests/purs/failing/UnusableTypeClassMethodSynonym.purs similarity index 100% rename from examples/failing/UnusableTypeClassMethodSynonym.purs rename to tests/purs/failing/UnusableTypeClassMethodSynonym.purs diff --git a/examples/passing/1110.purs b/tests/purs/passing/1110.purs similarity index 100% rename from examples/passing/1110.purs rename to tests/purs/passing/1110.purs diff --git a/examples/passing/1185.purs b/tests/purs/passing/1185.purs similarity index 100% rename from examples/passing/1185.purs rename to tests/purs/passing/1185.purs diff --git a/examples/passing/1335.purs b/tests/purs/passing/1335.purs similarity index 100% rename from examples/passing/1335.purs rename to tests/purs/passing/1335.purs diff --git a/examples/passing/1570.purs b/tests/purs/passing/1570.purs similarity index 100% rename from examples/passing/1570.purs rename to tests/purs/passing/1570.purs diff --git a/examples/passing/1664.purs b/tests/purs/passing/1664.purs similarity index 100% rename from examples/passing/1664.purs rename to tests/purs/passing/1664.purs diff --git a/examples/passing/1697.purs b/tests/purs/passing/1697.purs similarity index 100% rename from examples/passing/1697.purs rename to tests/purs/passing/1697.purs diff --git a/examples/passing/1807.purs b/tests/purs/passing/1807.purs similarity index 100% rename from examples/passing/1807.purs rename to tests/purs/passing/1807.purs diff --git a/examples/passing/1881.purs b/tests/purs/passing/1881.purs similarity index 100% rename from examples/passing/1881.purs rename to tests/purs/passing/1881.purs diff --git a/examples/passing/1991.purs b/tests/purs/passing/1991.purs similarity index 100% rename from examples/passing/1991.purs rename to tests/purs/passing/1991.purs diff --git a/examples/passing/2018.purs b/tests/purs/passing/2018.purs similarity index 100% rename from examples/passing/2018.purs rename to tests/purs/passing/2018.purs diff --git a/examples/passing/2018/A.purs b/tests/purs/passing/2018/A.purs similarity index 100% rename from examples/passing/2018/A.purs rename to tests/purs/passing/2018/A.purs diff --git a/examples/passing/2018/B.purs b/tests/purs/passing/2018/B.purs similarity index 100% rename from examples/passing/2018/B.purs rename to tests/purs/passing/2018/B.purs diff --git a/examples/passing/2049.purs b/tests/purs/passing/2049.purs similarity index 100% rename from examples/passing/2049.purs rename to tests/purs/passing/2049.purs diff --git a/examples/passing/2136.purs b/tests/purs/passing/2136.purs similarity index 100% rename from examples/passing/2136.purs rename to tests/purs/passing/2136.purs diff --git a/examples/passing/2138.purs b/tests/purs/passing/2138.purs similarity index 100% rename from examples/passing/2138.purs rename to tests/purs/passing/2138.purs diff --git a/examples/passing/2138/Lib.purs b/tests/purs/passing/2138/Lib.purs similarity index 100% rename from examples/passing/2138/Lib.purs rename to tests/purs/passing/2138/Lib.purs diff --git a/examples/passing/2172.js b/tests/purs/passing/2172.js similarity index 100% rename from examples/passing/2172.js rename to tests/purs/passing/2172.js diff --git a/examples/passing/2172.purs b/tests/purs/passing/2172.purs similarity index 100% rename from examples/passing/2172.purs rename to tests/purs/passing/2172.purs diff --git a/examples/passing/2197-1.purs b/tests/purs/passing/2197-1.purs similarity index 100% rename from examples/passing/2197-1.purs rename to tests/purs/passing/2197-1.purs diff --git a/examples/passing/2197-2.purs b/tests/purs/passing/2197-2.purs similarity index 100% rename from examples/passing/2197-2.purs rename to tests/purs/passing/2197-2.purs diff --git a/examples/passing/2252.purs b/tests/purs/passing/2252.purs similarity index 100% rename from examples/passing/2252.purs rename to tests/purs/passing/2252.purs diff --git a/examples/passing/2288.purs b/tests/purs/passing/2288.purs similarity index 100% rename from examples/passing/2288.purs rename to tests/purs/passing/2288.purs diff --git a/examples/passing/2378.purs b/tests/purs/passing/2378.purs similarity index 100% rename from examples/passing/2378.purs rename to tests/purs/passing/2378.purs diff --git a/examples/passing/2438.purs b/tests/purs/passing/2438.purs similarity index 100% rename from examples/passing/2438.purs rename to tests/purs/passing/2438.purs diff --git a/examples/passing/2609.purs b/tests/purs/passing/2609.purs similarity index 100% rename from examples/passing/2609.purs rename to tests/purs/passing/2609.purs diff --git a/examples/passing/2609/Eg.purs b/tests/purs/passing/2609/Eg.purs similarity index 100% rename from examples/passing/2609/Eg.purs rename to tests/purs/passing/2609/Eg.purs diff --git a/examples/passing/2616.purs b/tests/purs/passing/2616.purs similarity index 100% rename from examples/passing/2616.purs rename to tests/purs/passing/2616.purs diff --git a/examples/passing/2626.purs b/tests/purs/passing/2626.purs similarity index 100% rename from examples/passing/2626.purs rename to tests/purs/passing/2626.purs diff --git a/examples/passing/2663.purs b/tests/purs/passing/2663.purs similarity index 100% rename from examples/passing/2663.purs rename to tests/purs/passing/2663.purs diff --git a/examples/passing/2689.purs b/tests/purs/passing/2689.purs similarity index 100% rename from examples/passing/2689.purs rename to tests/purs/passing/2689.purs diff --git a/examples/passing/2756.purs b/tests/purs/passing/2756.purs similarity index 100% rename from examples/passing/2756.purs rename to tests/purs/passing/2756.purs diff --git a/examples/passing/2787.purs b/tests/purs/passing/2787.purs similarity index 100% rename from examples/passing/2787.purs rename to tests/purs/passing/2787.purs diff --git a/examples/passing/2795.purs b/tests/purs/passing/2795.purs similarity index 100% rename from examples/passing/2795.purs rename to tests/purs/passing/2795.purs diff --git a/examples/passing/2806.purs b/tests/purs/passing/2806.purs similarity index 100% rename from examples/passing/2806.purs rename to tests/purs/passing/2806.purs diff --git a/examples/passing/2947.purs b/tests/purs/passing/2947.purs similarity index 100% rename from examples/passing/2947.purs rename to tests/purs/passing/2947.purs diff --git a/examples/passing/2958.purs b/tests/purs/passing/2958.purs similarity index 100% rename from examples/passing/2958.purs rename to tests/purs/passing/2958.purs diff --git a/examples/passing/2972.purs b/tests/purs/passing/2972.purs similarity index 100% rename from examples/passing/2972.purs rename to tests/purs/passing/2972.purs diff --git a/examples/passing/3114.purs b/tests/purs/passing/3114.purs similarity index 100% rename from examples/passing/3114.purs rename to tests/purs/passing/3114.purs diff --git a/examples/passing/3114/VendoredVariant.purs b/tests/purs/passing/3114/VendoredVariant.purs similarity index 100% rename from examples/passing/3114/VendoredVariant.purs rename to tests/purs/passing/3114/VendoredVariant.purs diff --git a/examples/passing/3125.purs b/tests/purs/passing/3125.purs similarity index 100% rename from examples/passing/3125.purs rename to tests/purs/passing/3125.purs diff --git a/examples/passing/3187-UnusedNameClash.purs b/tests/purs/passing/3187-UnusedNameClash.purs similarity index 100% rename from examples/passing/3187-UnusedNameClash.purs rename to tests/purs/passing/3187-UnusedNameClash.purs diff --git a/examples/passing/652.purs b/tests/purs/passing/652.purs similarity index 100% rename from examples/passing/652.purs rename to tests/purs/passing/652.purs diff --git a/examples/passing/810.purs b/tests/purs/passing/810.purs similarity index 100% rename from examples/passing/810.purs rename to tests/purs/passing/810.purs diff --git a/examples/passing/862.purs b/tests/purs/passing/862.purs similarity index 100% rename from examples/passing/862.purs rename to tests/purs/passing/862.purs diff --git a/examples/passing/922.purs b/tests/purs/passing/922.purs similarity index 100% rename from examples/passing/922.purs rename to tests/purs/passing/922.purs diff --git a/examples/passing/Ado.purs b/tests/purs/passing/Ado.purs similarity index 100% rename from examples/passing/Ado.purs rename to tests/purs/passing/Ado.purs diff --git a/examples/passing/AppendInReverse.purs b/tests/purs/passing/AppendInReverse.purs similarity index 100% rename from examples/passing/AppendInReverse.purs rename to tests/purs/passing/AppendInReverse.purs diff --git a/examples/passing/Applicative.purs b/tests/purs/passing/Applicative.purs similarity index 100% rename from examples/passing/Applicative.purs rename to tests/purs/passing/Applicative.purs diff --git a/examples/passing/ArrayType.purs b/tests/purs/passing/ArrayType.purs similarity index 100% rename from examples/passing/ArrayType.purs rename to tests/purs/passing/ArrayType.purs diff --git a/examples/passing/Auto.purs b/tests/purs/passing/Auto.purs similarity index 100% rename from examples/passing/Auto.purs rename to tests/purs/passing/Auto.purs diff --git a/examples/passing/AutoPrelude.purs b/tests/purs/passing/AutoPrelude.purs similarity index 93% rename from examples/passing/AutoPrelude.purs rename to tests/purs/passing/AutoPrelude.purs index d7e95b5b40..9dcc474d6a 100644 --- a/examples/passing/AutoPrelude.purs +++ b/tests/purs/passing/AutoPrelude.purs @@ -1,11 +1,11 @@ -module Main where - -import Prelude -import Effect.Console (log) - -f x = x * 10.0 -g y = y - 10.0 - -main = do - log $ show $ (f <<< g) 100.0 - log "Done" +module Main where + +import Prelude +import Effect.Console (log) + +f x = x * 10.0 +g y = y - 10.0 + +main = do + log $ show $ (f <<< g) 100.0 + log "Done" diff --git a/examples/passing/AutoPrelude2.purs b/tests/purs/passing/AutoPrelude2.purs similarity index 100% rename from examples/passing/AutoPrelude2.purs rename to tests/purs/passing/AutoPrelude2.purs diff --git a/examples/passing/BindersInFunctions.purs b/tests/purs/passing/BindersInFunctions.purs similarity index 100% rename from examples/passing/BindersInFunctions.purs rename to tests/purs/passing/BindersInFunctions.purs diff --git a/examples/passing/BindingGroups.purs b/tests/purs/passing/BindingGroups.purs similarity index 100% rename from examples/passing/BindingGroups.purs rename to tests/purs/passing/BindingGroups.purs diff --git a/examples/passing/BlockString.purs b/tests/purs/passing/BlockString.purs similarity index 100% rename from examples/passing/BlockString.purs rename to tests/purs/passing/BlockString.purs diff --git a/examples/passing/CaseInDo.purs b/tests/purs/passing/CaseInDo.purs similarity index 100% rename from examples/passing/CaseInDo.purs rename to tests/purs/passing/CaseInDo.purs diff --git a/examples/passing/CaseInputWildcard.purs b/tests/purs/passing/CaseInputWildcard.purs similarity index 100% rename from examples/passing/CaseInputWildcard.purs rename to tests/purs/passing/CaseInputWildcard.purs diff --git a/examples/passing/CaseMultipleExpressions.purs b/tests/purs/passing/CaseMultipleExpressions.purs similarity index 100% rename from examples/passing/CaseMultipleExpressions.purs rename to tests/purs/passing/CaseMultipleExpressions.purs diff --git a/examples/passing/CaseStatement.purs b/tests/purs/passing/CaseStatement.purs similarity index 100% rename from examples/passing/CaseStatement.purs rename to tests/purs/passing/CaseStatement.purs diff --git a/examples/passing/CheckFunction.purs b/tests/purs/passing/CheckFunction.purs similarity index 100% rename from examples/passing/CheckFunction.purs rename to tests/purs/passing/CheckFunction.purs diff --git a/examples/passing/CheckSynonymBug.purs b/tests/purs/passing/CheckSynonymBug.purs similarity index 100% rename from examples/passing/CheckSynonymBug.purs rename to tests/purs/passing/CheckSynonymBug.purs diff --git a/examples/passing/CheckTypeClass.purs b/tests/purs/passing/CheckTypeClass.purs similarity index 100% rename from examples/passing/CheckTypeClass.purs rename to tests/purs/passing/CheckTypeClass.purs diff --git a/examples/passing/Church.purs b/tests/purs/passing/Church.purs similarity index 100% rename from examples/passing/Church.purs rename to tests/purs/passing/Church.purs diff --git a/examples/passing/ClassRefSyntax.purs b/tests/purs/passing/ClassRefSyntax.purs similarity index 100% rename from examples/passing/ClassRefSyntax.purs rename to tests/purs/passing/ClassRefSyntax.purs diff --git a/examples/passing/ClassRefSyntax/Lib.purs b/tests/purs/passing/ClassRefSyntax/Lib.purs similarity index 100% rename from examples/passing/ClassRefSyntax/Lib.purs rename to tests/purs/passing/ClassRefSyntax/Lib.purs diff --git a/examples/passing/Collatz.purs b/tests/purs/passing/Collatz.purs similarity index 100% rename from examples/passing/Collatz.purs rename to tests/purs/passing/Collatz.purs diff --git a/examples/passing/Comparisons.purs b/tests/purs/passing/Comparisons.purs similarity index 94% rename from examples/passing/Comparisons.purs rename to tests/purs/passing/Comparisons.purs index 08038e9ecf..b2e710ff86 100644 --- a/examples/passing/Comparisons.purs +++ b/tests/purs/passing/Comparisons.purs @@ -1,15 +1,15 @@ -module Main where - -import Prelude -import Effect -import Effect.Console -import Test.Assert - -main = do - assert (1.0 < 2.0) - assert (2.0 == 2.0) - assert (3.0 > 1.0) - assert ("a" < "b") - assert ("a" == "a") - assert ("z" > "a") - log "Done" +module Main where + +import Prelude +import Effect +import Effect.Console +import Test.Assert + +main = do + assert (1.0 < 2.0) + assert (2.0 == 2.0) + assert (3.0 > 1.0) + assert ("a" < "b") + assert ("a" == "a") + assert ("z" > "a") + log "Done" diff --git a/examples/passing/Conditional.purs b/tests/purs/passing/Conditional.purs similarity index 100% rename from examples/passing/Conditional.purs rename to tests/purs/passing/Conditional.purs diff --git a/examples/passing/Console.purs b/tests/purs/passing/Console.purs similarity index 100% rename from examples/passing/Console.purs rename to tests/purs/passing/Console.purs diff --git a/examples/passing/ConstraintInference.purs b/tests/purs/passing/ConstraintInference.purs similarity index 100% rename from examples/passing/ConstraintInference.purs rename to tests/purs/passing/ConstraintInference.purs diff --git a/examples/passing/ConstraintParens.purs b/tests/purs/passing/ConstraintParens.purs similarity index 100% rename from examples/passing/ConstraintParens.purs rename to tests/purs/passing/ConstraintParens.purs diff --git a/examples/passing/ConstraintParsingIssue.purs b/tests/purs/passing/ConstraintParsingIssue.purs similarity index 100% rename from examples/passing/ConstraintParsingIssue.purs rename to tests/purs/passing/ConstraintParsingIssue.purs diff --git a/examples/passing/ContextSimplification.purs b/tests/purs/passing/ContextSimplification.purs similarity index 100% rename from examples/passing/ContextSimplification.purs rename to tests/purs/passing/ContextSimplification.purs diff --git a/examples/passing/DataAndType.purs b/tests/purs/passing/DataAndType.purs similarity index 100% rename from examples/passing/DataAndType.purs rename to tests/purs/passing/DataAndType.purs diff --git a/examples/passing/DataConsClassConsOverlapOk.purs b/tests/purs/passing/DataConsClassConsOverlapOk.purs similarity index 100% rename from examples/passing/DataConsClassConsOverlapOk.purs rename to tests/purs/passing/DataConsClassConsOverlapOk.purs diff --git a/examples/passing/DctorName.purs b/tests/purs/passing/DctorName.purs similarity index 100% rename from examples/passing/DctorName.purs rename to tests/purs/passing/DctorName.purs diff --git a/examples/passing/DctorOperatorAlias.purs b/tests/purs/passing/DctorOperatorAlias.purs similarity index 100% rename from examples/passing/DctorOperatorAlias.purs rename to tests/purs/passing/DctorOperatorAlias.purs diff --git a/examples/passing/DctorOperatorAlias/List.purs b/tests/purs/passing/DctorOperatorAlias/List.purs similarity index 100% rename from examples/passing/DctorOperatorAlias/List.purs rename to tests/purs/passing/DctorOperatorAlias/List.purs diff --git a/examples/passing/DeepArrayBinder.purs b/tests/purs/passing/DeepArrayBinder.purs similarity index 100% rename from examples/passing/DeepArrayBinder.purs rename to tests/purs/passing/DeepArrayBinder.purs diff --git a/examples/passing/DeepCase.purs b/tests/purs/passing/DeepCase.purs similarity index 100% rename from examples/passing/DeepCase.purs rename to tests/purs/passing/DeepCase.purs diff --git a/examples/passing/DeriveNewtype.purs b/tests/purs/passing/DeriveNewtype.purs similarity index 100% rename from examples/passing/DeriveNewtype.purs rename to tests/purs/passing/DeriveNewtype.purs diff --git a/examples/passing/DeriveWithNestedSynonyms.purs b/tests/purs/passing/DeriveWithNestedSynonyms.purs similarity index 100% rename from examples/passing/DeriveWithNestedSynonyms.purs rename to tests/purs/passing/DeriveWithNestedSynonyms.purs diff --git a/examples/passing/Deriving.purs b/tests/purs/passing/Deriving.purs similarity index 100% rename from examples/passing/Deriving.purs rename to tests/purs/passing/Deriving.purs diff --git a/examples/passing/DerivingFunctor.purs b/tests/purs/passing/DerivingFunctor.purs similarity index 100% rename from examples/passing/DerivingFunctor.purs rename to tests/purs/passing/DerivingFunctor.purs diff --git a/examples/passing/Do.purs b/tests/purs/passing/Do.purs similarity index 100% rename from examples/passing/Do.purs rename to tests/purs/passing/Do.purs diff --git a/examples/passing/Dollar.purs b/tests/purs/passing/Dollar.purs similarity index 100% rename from examples/passing/Dollar.purs rename to tests/purs/passing/Dollar.purs diff --git a/examples/passing/DuplicateProperties.purs b/tests/purs/passing/DuplicateProperties.purs similarity index 100% rename from examples/passing/DuplicateProperties.purs rename to tests/purs/passing/DuplicateProperties.purs diff --git a/examples/passing/EffFn.js b/tests/purs/passing/EffFn.js similarity index 100% rename from examples/passing/EffFn.js rename to tests/purs/passing/EffFn.js diff --git a/examples/passing/EffFn.purs b/tests/purs/passing/EffFn.purs similarity index 100% rename from examples/passing/EffFn.purs rename to tests/purs/passing/EffFn.purs diff --git a/examples/passing/EmptyDataDecls.purs b/tests/purs/passing/EmptyDataDecls.purs similarity index 100% rename from examples/passing/EmptyDataDecls.purs rename to tests/purs/passing/EmptyDataDecls.purs diff --git a/examples/passing/EmptyRow.purs b/tests/purs/passing/EmptyRow.purs similarity index 100% rename from examples/passing/EmptyRow.purs rename to tests/purs/passing/EmptyRow.purs diff --git a/examples/passing/EmptyTypeClass.purs b/tests/purs/passing/EmptyTypeClass.purs similarity index 100% rename from examples/passing/EmptyTypeClass.purs rename to tests/purs/passing/EmptyTypeClass.purs diff --git a/examples/passing/EntailsKindedType.purs b/tests/purs/passing/EntailsKindedType.purs similarity index 100% rename from examples/passing/EntailsKindedType.purs rename to tests/purs/passing/EntailsKindedType.purs diff --git a/examples/passing/Eq1Deriving.purs b/tests/purs/passing/Eq1Deriving.purs similarity index 100% rename from examples/passing/Eq1Deriving.purs rename to tests/purs/passing/Eq1Deriving.purs diff --git a/examples/passing/Eq1InEqDeriving.purs b/tests/purs/passing/Eq1InEqDeriving.purs similarity index 100% rename from examples/passing/Eq1InEqDeriving.purs rename to tests/purs/passing/Eq1InEqDeriving.purs diff --git a/examples/passing/EqOrd.purs b/tests/purs/passing/EqOrd.purs similarity index 100% rename from examples/passing/EqOrd.purs rename to tests/purs/passing/EqOrd.purs diff --git a/examples/passing/ExplicitImportReExport.purs b/tests/purs/passing/ExplicitImportReExport.purs similarity index 92% rename from examples/passing/ExplicitImportReExport.purs rename to tests/purs/passing/ExplicitImportReExport.purs index cea31c23f5..798d1c844f 100644 --- a/examples/passing/ExplicitImportReExport.purs +++ b/tests/purs/passing/ExplicitImportReExport.purs @@ -1,11 +1,11 @@ --- from #1244 -module Main where - -import Prelude -import Effect.Console (log) -import Bar (foo) - -baz :: Int -baz = foo - -main = log "Done" +-- from #1244 +module Main where + +import Prelude +import Effect.Console (log) +import Bar (foo) + +baz :: Int +baz = foo + +main = log "Done" diff --git a/examples/passing/ExplicitImportReExport/Bar.purs b/tests/purs/passing/ExplicitImportReExport/Bar.purs similarity index 93% rename from examples/passing/ExplicitImportReExport/Bar.purs rename to tests/purs/passing/ExplicitImportReExport/Bar.purs index 4b1d3d6a36..5f8ef12ae0 100644 --- a/examples/passing/ExplicitImportReExport/Bar.purs +++ b/tests/purs/passing/ExplicitImportReExport/Bar.purs @@ -1,3 +1,3 @@ -module Bar (module Foo) where - -import Foo +module Bar (module Foo) where + +import Foo diff --git a/examples/passing/ExplicitImportReExport/Foo.purs b/tests/purs/passing/ExplicitImportReExport/Foo.purs similarity index 90% rename from examples/passing/ExplicitImportReExport/Foo.purs rename to tests/purs/passing/ExplicitImportReExport/Foo.purs index 69ccbb12ec..d2c06e960d 100644 --- a/examples/passing/ExplicitImportReExport/Foo.purs +++ b/tests/purs/passing/ExplicitImportReExport/Foo.purs @@ -1,4 +1,4 @@ -module Foo where - -foo :: Int -foo = 3 +module Foo where + +foo :: Int +foo = 3 diff --git a/examples/passing/ExplicitOperatorSections.purs b/tests/purs/passing/ExplicitOperatorSections.purs similarity index 100% rename from examples/passing/ExplicitOperatorSections.purs rename to tests/purs/passing/ExplicitOperatorSections.purs diff --git a/examples/passing/ExportExplicit.purs b/tests/purs/passing/ExportExplicit.purs similarity index 91% rename from examples/passing/ExportExplicit.purs rename to tests/purs/passing/ExportExplicit.purs index 97507a6cea..f5c07f9861 100644 --- a/examples/passing/ExportExplicit.purs +++ b/tests/purs/passing/ExportExplicit.purs @@ -1,10 +1,10 @@ -module Main where - -import M1 -import Effect.Console (log) - -testX = X -testZ = Z -testFoo = foo - -main = log "Done" +module Main where + +import M1 +import Effect.Console (log) + +testX = X +testZ = Z +testFoo = foo + +main = log "Done" diff --git a/examples/passing/ExportExplicit/M1.purs b/tests/purs/passing/ExportExplicit/M1.purs similarity index 91% rename from examples/passing/ExportExplicit/M1.purs rename to tests/purs/passing/ExportExplicit/M1.purs index 09d8b4bef7..273f1002fd 100644 --- a/examples/passing/ExportExplicit/M1.purs +++ b/tests/purs/passing/ExportExplicit/M1.purs @@ -1,10 +1,10 @@ -module M1 (X(X), Z(..), foo) where - -data X = X | Y -data Z = Z - -foo :: Int -foo = 0 - -bar :: Int -bar = 1 +module M1 (X(X), Z(..), foo) where + +data X = X | Y +data Z = Z + +foo :: Int +foo = 0 + +bar :: Int +bar = 1 diff --git a/examples/passing/ExportExplicit2.purs b/tests/purs/passing/ExportExplicit2.purs similarity index 91% rename from examples/passing/ExportExplicit2.purs rename to tests/purs/passing/ExportExplicit2.purs index 018c826233..c1c896a8e0 100644 --- a/examples/passing/ExportExplicit2.purs +++ b/tests/purs/passing/ExportExplicit2.purs @@ -1,8 +1,8 @@ -module Main where - -import M1 -import Effect.Console (log) - -testBar = bar - -main = log "Done" +module Main where + +import M1 +import Effect.Console (log) + +testBar = bar + +main = log "Done" diff --git a/examples/passing/ExportExplicit2/M1.purs b/tests/purs/passing/ExportExplicit2/M1.purs similarity index 90% rename from examples/passing/ExportExplicit2/M1.purs rename to tests/purs/passing/ExportExplicit2/M1.purs index 16c27e1007..aa78149f17 100644 --- a/examples/passing/ExportExplicit2/M1.purs +++ b/tests/purs/passing/ExportExplicit2/M1.purs @@ -1,7 +1,7 @@ -module M1 (bar) where - -foo :: Int -foo = 0 - -bar :: Int -bar = foo +module M1 (bar) where + +foo :: Int +foo = 0 + +bar :: Int +bar = foo diff --git a/examples/passing/ExportedInstanceDeclarations.purs b/tests/purs/passing/ExportedInstanceDeclarations.purs similarity index 100% rename from examples/passing/ExportedInstanceDeclarations.purs rename to tests/purs/passing/ExportedInstanceDeclarations.purs diff --git a/examples/passing/ExtendedInfixOperators.purs b/tests/purs/passing/ExtendedInfixOperators.purs similarity index 100% rename from examples/passing/ExtendedInfixOperators.purs rename to tests/purs/passing/ExtendedInfixOperators.purs diff --git a/examples/passing/Fib.purs b/tests/purs/passing/Fib.purs similarity index 100% rename from examples/passing/Fib.purs rename to tests/purs/passing/Fib.purs diff --git a/examples/passing/FieldConsPuns.purs b/tests/purs/passing/FieldConsPuns.purs similarity index 94% rename from examples/passing/FieldConsPuns.purs rename to tests/purs/passing/FieldConsPuns.purs index 2a068df614..7a9d74d5da 100644 --- a/examples/passing/FieldConsPuns.purs +++ b/tests/purs/passing/FieldConsPuns.purs @@ -1,13 +1,13 @@ -module Main where - -import Prelude -import Effect.Console (log, logShow) - -greet { greeting, name } = log $ greeting <> ", " <> name <> "." - -main = do - greet { greeting, name } - log "Done" - where - greeting = "Hello" - name = "World" +module Main where + +import Prelude +import Effect.Console (log, logShow) + +greet { greeting, name } = log $ greeting <> ", " <> name <> "." + +main = do + greet { greeting, name } + log "Done" + where + greeting = "Hello" + name = "World" diff --git a/examples/passing/FieldPuns.purs b/tests/purs/passing/FieldPuns.purs similarity index 95% rename from examples/passing/FieldPuns.purs rename to tests/purs/passing/FieldPuns.purs index 43389e2c8f..84e78fa497 100644 --- a/examples/passing/FieldPuns.purs +++ b/tests/purs/passing/FieldPuns.purs @@ -1,10 +1,10 @@ -module Main where - -import Prelude -import Effect.Console - -greet { greeting, name } = log $ greeting <> ", " <> name <> "." - -main = do - greet { greeting: "Hello", name: "World" } - log "Done" +module Main where + +import Prelude +import Effect.Console + +greet { greeting, name } = log $ greeting <> ", " <> name <> "." + +main = do + greet { greeting: "Hello", name: "World" } + log "Done" diff --git a/examples/passing/FinalTagless.purs b/tests/purs/passing/FinalTagless.purs similarity index 100% rename from examples/passing/FinalTagless.purs rename to tests/purs/passing/FinalTagless.purs diff --git a/examples/passing/ForeignKind.purs b/tests/purs/passing/ForeignKind.purs similarity index 100% rename from examples/passing/ForeignKind.purs rename to tests/purs/passing/ForeignKind.purs diff --git a/examples/passing/ForeignKind/Lib.purs b/tests/purs/passing/ForeignKind/Lib.purs similarity index 100% rename from examples/passing/ForeignKind/Lib.purs rename to tests/purs/passing/ForeignKind/Lib.purs diff --git a/examples/passing/FunWithFunDeps.js b/tests/purs/passing/FunWithFunDeps.js similarity index 100% rename from examples/passing/FunWithFunDeps.js rename to tests/purs/passing/FunWithFunDeps.js diff --git a/examples/passing/FunWithFunDeps.purs b/tests/purs/passing/FunWithFunDeps.purs similarity index 100% rename from examples/passing/FunWithFunDeps.purs rename to tests/purs/passing/FunWithFunDeps.purs diff --git a/examples/passing/FunctionScope.purs b/tests/purs/passing/FunctionScope.purs similarity index 100% rename from examples/passing/FunctionScope.purs rename to tests/purs/passing/FunctionScope.purs diff --git a/examples/passing/FunctionalDependencies.purs b/tests/purs/passing/FunctionalDependencies.purs similarity index 100% rename from examples/passing/FunctionalDependencies.purs rename to tests/purs/passing/FunctionalDependencies.purs diff --git a/examples/passing/Functions.purs b/tests/purs/passing/Functions.purs similarity index 100% rename from examples/passing/Functions.purs rename to tests/purs/passing/Functions.purs diff --git a/examples/passing/Functions2.purs b/tests/purs/passing/Functions2.purs similarity index 100% rename from examples/passing/Functions2.purs rename to tests/purs/passing/Functions2.purs diff --git a/examples/passing/Generalization1.purs b/tests/purs/passing/Generalization1.purs similarity index 100% rename from examples/passing/Generalization1.purs rename to tests/purs/passing/Generalization1.purs diff --git a/examples/passing/GenericsRep.purs b/tests/purs/passing/GenericsRep.purs similarity index 100% rename from examples/passing/GenericsRep.purs rename to tests/purs/passing/GenericsRep.purs diff --git a/examples/passing/Guards.purs b/tests/purs/passing/Guards.purs similarity index 100% rename from examples/passing/Guards.purs rename to tests/purs/passing/Guards.purs diff --git a/examples/passing/HasOwnProperty.purs b/tests/purs/passing/HasOwnProperty.purs similarity index 100% rename from examples/passing/HasOwnProperty.purs rename to tests/purs/passing/HasOwnProperty.purs diff --git a/examples/passing/HoistError.purs b/tests/purs/passing/HoistError.purs similarity index 100% rename from examples/passing/HoistError.purs rename to tests/purs/passing/HoistError.purs diff --git a/examples/passing/IfThenElseMaybe.purs b/tests/purs/passing/IfThenElseMaybe.purs similarity index 100% rename from examples/passing/IfThenElseMaybe.purs rename to tests/purs/passing/IfThenElseMaybe.purs diff --git a/examples/passing/IfWildcard.purs b/tests/purs/passing/IfWildcard.purs similarity index 100% rename from examples/passing/IfWildcard.purs rename to tests/purs/passing/IfWildcard.purs diff --git a/examples/passing/ImplicitEmptyImport.purs b/tests/purs/passing/ImplicitEmptyImport.purs similarity index 100% rename from examples/passing/ImplicitEmptyImport.purs rename to tests/purs/passing/ImplicitEmptyImport.purs diff --git a/examples/passing/Import.purs b/tests/purs/passing/Import.purs similarity index 92% rename from examples/passing/Import.purs rename to tests/purs/passing/Import.purs index b823ab2040..b77cbf7f96 100644 --- a/examples/passing/Import.purs +++ b/tests/purs/passing/Import.purs @@ -1,6 +1,6 @@ -module Main where - -import M2 -import Effect.Console (log) - -main = log "Done" +module Main where + +import M2 +import Effect.Console (log) + +main = log "Done" diff --git a/examples/passing/Import/M1.purs b/tests/purs/passing/Import/M1.purs similarity index 91% rename from examples/passing/Import/M1.purs rename to tests/purs/passing/Import/M1.purs index 144ecdba95..36cdb4ba32 100644 --- a/examples/passing/Import/M1.purs +++ b/tests/purs/passing/Import/M1.purs @@ -1,8 +1,8 @@ -module M1 where - -import Prelude () - -id :: forall a. a -> a -id = \x -> x - -foo = id +module M1 where + +import Prelude () + +id :: forall a. a -> a +id = \x -> x + +foo = id diff --git a/examples/passing/Import/M2.purs b/tests/purs/passing/Import/M2.purs similarity index 91% rename from examples/passing/Import/M2.purs rename to tests/purs/passing/Import/M2.purs index eba01c684d..7b4883a45f 100644 --- a/examples/passing/Import/M2.purs +++ b/tests/purs/passing/Import/M2.purs @@ -1,6 +1,6 @@ -module M2 where - -import Prelude () -import M1 - -main = \_ -> foo 42 +module M2 where + +import Prelude () +import M1 + +main = \_ -> foo 42 diff --git a/examples/passing/ImportExplicit.purs b/tests/purs/passing/ImportExplicit.purs similarity index 92% rename from examples/passing/ImportExplicit.purs rename to tests/purs/passing/ImportExplicit.purs index 0183f00052..18d2dc9a67 100644 --- a/examples/passing/ImportExplicit.purs +++ b/tests/purs/passing/ImportExplicit.purs @@ -1,10 +1,10 @@ -module Main where - -import M1 (X(..)) -import Effect.Console (log) - -testX :: X -testX = X -testY = Y - -main = log "Done" +module Main where + +import M1 (X(..)) +import Effect.Console (log) + +testX :: X +testX = X +testY = Y + +main = log "Done" diff --git a/examples/passing/ImportExplicit/M1.purs b/tests/purs/passing/ImportExplicit/M1.purs similarity index 91% rename from examples/passing/ImportExplicit/M1.purs rename to tests/purs/passing/ImportExplicit/M1.purs index 189ba7cd01..cf27f2df63 100644 --- a/examples/passing/ImportExplicit/M1.purs +++ b/tests/purs/passing/ImportExplicit/M1.purs @@ -1,4 +1,4 @@ -module M1 where - -data X = X | Y -data Z = Z +module M1 where + +data X = X | Y +data Z = Z diff --git a/examples/passing/ImportHiding.purs b/tests/purs/passing/ImportHiding.purs similarity index 100% rename from examples/passing/ImportHiding.purs rename to tests/purs/passing/ImportHiding.purs diff --git a/examples/passing/ImportQualified.purs b/tests/purs/passing/ImportQualified.purs similarity index 93% rename from examples/passing/ImportQualified.purs rename to tests/purs/passing/ImportQualified.purs index c23018c96f..205158429c 100644 --- a/examples/passing/ImportQualified.purs +++ b/tests/purs/passing/ImportQualified.purs @@ -1,8 +1,8 @@ -module Main where - -import Prelude -import Effect -import M1 -import Effect.Console as C - -main = C.log (log "Done") +module Main where + +import Prelude +import Effect +import M1 +import Effect.Console as C + +main = C.log (log "Done") diff --git a/examples/passing/ImportQualified/M1.purs b/tests/purs/passing/ImportQualified/M1.purs similarity index 90% rename from examples/passing/ImportQualified/M1.purs rename to tests/purs/passing/ImportQualified/M1.purs index 6c423fb3f4..719a1a03ec 100644 --- a/examples/passing/ImportQualified/M1.purs +++ b/tests/purs/passing/ImportQualified/M1.purs @@ -1,3 +1,3 @@ -module M1 where - -log x = x +module M1 where + +log x = x diff --git a/examples/passing/InferRecFunWithConstrainedArgument.purs b/tests/purs/passing/InferRecFunWithConstrainedArgument.purs similarity index 100% rename from examples/passing/InferRecFunWithConstrainedArgument.purs rename to tests/purs/passing/InferRecFunWithConstrainedArgument.purs diff --git a/examples/passing/InstanceBeforeClass.purs b/tests/purs/passing/InstanceBeforeClass.purs similarity index 100% rename from examples/passing/InstanceBeforeClass.purs rename to tests/purs/passing/InstanceBeforeClass.purs diff --git a/examples/passing/InstanceChain.purs b/tests/purs/passing/InstanceChain.purs similarity index 100% rename from examples/passing/InstanceChain.purs rename to tests/purs/passing/InstanceChain.purs diff --git a/examples/passing/InstanceSigs.purs b/tests/purs/passing/InstanceSigs.purs similarity index 100% rename from examples/passing/InstanceSigs.purs rename to tests/purs/passing/InstanceSigs.purs diff --git a/examples/passing/InstanceSigsGeneral.purs b/tests/purs/passing/InstanceSigsGeneral.purs similarity index 100% rename from examples/passing/InstanceSigsGeneral.purs rename to tests/purs/passing/InstanceSigsGeneral.purs diff --git a/examples/passing/IntAndChar.purs b/tests/purs/passing/IntAndChar.purs similarity index 100% rename from examples/passing/IntAndChar.purs rename to tests/purs/passing/IntAndChar.purs diff --git a/examples/passing/JSReserved.purs b/tests/purs/passing/JSReserved.purs similarity index 100% rename from examples/passing/JSReserved.purs rename to tests/purs/passing/JSReserved.purs diff --git a/examples/passing/KindedType.purs b/tests/purs/passing/KindedType.purs similarity index 100% rename from examples/passing/KindedType.purs rename to tests/purs/passing/KindedType.purs diff --git a/examples/passing/LargeSumType.purs b/tests/purs/passing/LargeSumType.purs similarity index 100% rename from examples/passing/LargeSumType.purs rename to tests/purs/passing/LargeSumType.purs diff --git a/examples/passing/Let.purs b/tests/purs/passing/Let.purs similarity index 100% rename from examples/passing/Let.purs rename to tests/purs/passing/Let.purs diff --git a/examples/passing/Let2.purs b/tests/purs/passing/Let2.purs similarity index 100% rename from examples/passing/Let2.purs rename to tests/purs/passing/Let2.purs diff --git a/examples/passing/LetInInstance.purs b/tests/purs/passing/LetInInstance.purs similarity index 100% rename from examples/passing/LetInInstance.purs rename to tests/purs/passing/LetInInstance.purs diff --git a/examples/passing/LetPattern.purs b/tests/purs/passing/LetPattern.purs similarity index 100% rename from examples/passing/LetPattern.purs rename to tests/purs/passing/LetPattern.purs diff --git a/examples/passing/LiberalTypeSynonyms.purs b/tests/purs/passing/LiberalTypeSynonyms.purs similarity index 100% rename from examples/passing/LiberalTypeSynonyms.purs rename to tests/purs/passing/LiberalTypeSynonyms.purs diff --git a/examples/passing/MPTCs.purs b/tests/purs/passing/MPTCs.purs similarity index 100% rename from examples/passing/MPTCs.purs rename to tests/purs/passing/MPTCs.purs diff --git a/examples/passing/Match.purs b/tests/purs/passing/Match.purs similarity index 100% rename from examples/passing/Match.purs rename to tests/purs/passing/Match.purs diff --git a/examples/passing/Module.purs b/tests/purs/passing/Module.purs similarity index 100% rename from examples/passing/Module.purs rename to tests/purs/passing/Module.purs diff --git a/examples/passing/Module/M1.purs b/tests/purs/passing/Module/M1.purs similarity index 100% rename from examples/passing/Module/M1.purs rename to tests/purs/passing/Module/M1.purs diff --git a/examples/passing/Module/M2.purs b/tests/purs/passing/Module/M2.purs similarity index 100% rename from examples/passing/Module/M2.purs rename to tests/purs/passing/Module/M2.purs diff --git a/examples/passing/ModuleDeps.purs b/tests/purs/passing/ModuleDeps.purs similarity index 92% rename from examples/passing/ModuleDeps.purs rename to tests/purs/passing/ModuleDeps.purs index 436831809b..79db9e1138 100644 --- a/examples/passing/ModuleDeps.purs +++ b/tests/purs/passing/ModuleDeps.purs @@ -1,6 +1,6 @@ -module Main where - -import M1 -import Effect.Console (log) - -main = log "Done" +module Main where + +import M1 +import Effect.Console (log) + +main = log "Done" diff --git a/examples/passing/ModuleDeps/M1.purs b/tests/purs/passing/ModuleDeps/M1.purs similarity index 90% rename from examples/passing/ModuleDeps/M1.purs rename to tests/purs/passing/ModuleDeps/M1.purs index 5618b41a48..535aa287c3 100644 --- a/examples/passing/ModuleDeps/M1.purs +++ b/tests/purs/passing/ModuleDeps/M1.purs @@ -1,5 +1,5 @@ -module M1 where - -import M2 as M2 - -foo = M2.bar +module M1 where + +import M2 as M2 + +foo = M2.bar diff --git a/examples/passing/ModuleDeps/M2.purs b/tests/purs/passing/ModuleDeps/M2.purs similarity index 90% rename from examples/passing/ModuleDeps/M2.purs rename to tests/purs/passing/ModuleDeps/M2.purs index c6cc0081a4..017e70e3f5 100644 --- a/examples/passing/ModuleDeps/M2.purs +++ b/tests/purs/passing/ModuleDeps/M2.purs @@ -1,5 +1,5 @@ -module M2 where - -import M3 as M3 - -bar = M3.baz +module M2 where + +import M3 as M3 + +bar = M3.baz diff --git a/examples/passing/ModuleDeps/M3.purs b/tests/purs/passing/ModuleDeps/M3.purs similarity index 89% rename from examples/passing/ModuleDeps/M3.purs rename to tests/purs/passing/ModuleDeps/M3.purs index d9b7633d3c..f07167b710 100644 --- a/examples/passing/ModuleDeps/M3.purs +++ b/tests/purs/passing/ModuleDeps/M3.purs @@ -1,3 +1,3 @@ -module M3 where - -baz = 1 +module M3 where + +baz = 1 diff --git a/examples/passing/ModuleExport.purs b/tests/purs/passing/ModuleExport.purs similarity index 100% rename from examples/passing/ModuleExport.purs rename to tests/purs/passing/ModuleExport.purs diff --git a/examples/passing/ModuleExport/A.purs b/tests/purs/passing/ModuleExport/A.purs similarity index 100% rename from examples/passing/ModuleExport/A.purs rename to tests/purs/passing/ModuleExport/A.purs diff --git a/examples/passing/ModuleExportDupes.purs b/tests/purs/passing/ModuleExportDupes.purs similarity index 100% rename from examples/passing/ModuleExportDupes.purs rename to tests/purs/passing/ModuleExportDupes.purs diff --git a/examples/passing/ModuleExportDupes/A.purs b/tests/purs/passing/ModuleExportDupes/A.purs similarity index 100% rename from examples/passing/ModuleExportDupes/A.purs rename to tests/purs/passing/ModuleExportDupes/A.purs diff --git a/examples/passing/ModuleExportDupes/B.purs b/tests/purs/passing/ModuleExportDupes/B.purs similarity index 100% rename from examples/passing/ModuleExportDupes/B.purs rename to tests/purs/passing/ModuleExportDupes/B.purs diff --git a/examples/passing/ModuleExportDupes/C.purs b/tests/purs/passing/ModuleExportDupes/C.purs similarity index 100% rename from examples/passing/ModuleExportDupes/C.purs rename to tests/purs/passing/ModuleExportDupes/C.purs diff --git a/examples/passing/ModuleExportExcluded.purs b/tests/purs/passing/ModuleExportExcluded.purs similarity index 100% rename from examples/passing/ModuleExportExcluded.purs rename to tests/purs/passing/ModuleExportExcluded.purs diff --git a/examples/passing/ModuleExportExcluded/A.purs b/tests/purs/passing/ModuleExportExcluded/A.purs similarity index 100% rename from examples/passing/ModuleExportExcluded/A.purs rename to tests/purs/passing/ModuleExportExcluded/A.purs diff --git a/examples/passing/ModuleExportQualified.purs b/tests/purs/passing/ModuleExportQualified.purs similarity index 100% rename from examples/passing/ModuleExportQualified.purs rename to tests/purs/passing/ModuleExportQualified.purs diff --git a/examples/passing/ModuleExportQualified/A.purs b/tests/purs/passing/ModuleExportQualified/A.purs similarity index 100% rename from examples/passing/ModuleExportQualified/A.purs rename to tests/purs/passing/ModuleExportQualified/A.purs diff --git a/examples/passing/ModuleExportSelf.purs b/tests/purs/passing/ModuleExportSelf.purs similarity index 100% rename from examples/passing/ModuleExportSelf.purs rename to tests/purs/passing/ModuleExportSelf.purs diff --git a/examples/passing/ModuleExportSelf/A.purs b/tests/purs/passing/ModuleExportSelf/A.purs similarity index 93% rename from examples/passing/ModuleExportSelf/A.purs rename to tests/purs/passing/ModuleExportSelf/A.purs index f6c2ecf5a3..4e8742ef9a 100644 --- a/examples/passing/ModuleExportSelf/A.purs +++ b/tests/purs/passing/ModuleExportSelf/A.purs @@ -1,5 +1,5 @@ -module A (module A, module Prelude) where - -import Prelude - -type Foo = Boolean +module A (module A, module Prelude) where + +import Prelude + +type Foo = Boolean diff --git a/examples/passing/Monad.purs b/tests/purs/passing/Monad.purs similarity index 100% rename from examples/passing/Monad.purs rename to tests/purs/passing/Monad.purs diff --git a/examples/passing/MonadState.purs b/tests/purs/passing/MonadState.purs similarity index 100% rename from examples/passing/MonadState.purs rename to tests/purs/passing/MonadState.purs diff --git a/examples/passing/MultiArgFunctions.purs b/tests/purs/passing/MultiArgFunctions.purs similarity index 100% rename from examples/passing/MultiArgFunctions.purs rename to tests/purs/passing/MultiArgFunctions.purs diff --git a/examples/passing/MutRec.purs b/tests/purs/passing/MutRec.purs similarity index 100% rename from examples/passing/MutRec.purs rename to tests/purs/passing/MutRec.purs diff --git a/examples/passing/MutRec2.purs b/tests/purs/passing/MutRec2.purs similarity index 100% rename from examples/passing/MutRec2.purs rename to tests/purs/passing/MutRec2.purs diff --git a/examples/passing/MutRec3.purs b/tests/purs/passing/MutRec3.purs similarity index 100% rename from examples/passing/MutRec3.purs rename to tests/purs/passing/MutRec3.purs diff --git a/examples/passing/NakedConstraint.purs b/tests/purs/passing/NakedConstraint.purs similarity index 100% rename from examples/passing/NakedConstraint.purs rename to tests/purs/passing/NakedConstraint.purs diff --git a/examples/passing/NamedPatterns.purs b/tests/purs/passing/NamedPatterns.purs similarity index 100% rename from examples/passing/NamedPatterns.purs rename to tests/purs/passing/NamedPatterns.purs diff --git a/examples/passing/NegativeBinder.purs b/tests/purs/passing/NegativeBinder.purs similarity index 100% rename from examples/passing/NegativeBinder.purs rename to tests/purs/passing/NegativeBinder.purs diff --git a/examples/passing/NegativeIntInRange.purs b/tests/purs/passing/NegativeIntInRange.purs similarity index 100% rename from examples/passing/NegativeIntInRange.purs rename to tests/purs/passing/NegativeIntInRange.purs diff --git a/examples/passing/Nested.purs b/tests/purs/passing/Nested.purs similarity index 100% rename from examples/passing/Nested.purs rename to tests/purs/passing/Nested.purs diff --git a/examples/passing/NestedRecordUpdate.purs b/tests/purs/passing/NestedRecordUpdate.purs similarity index 100% rename from examples/passing/NestedRecordUpdate.purs rename to tests/purs/passing/NestedRecordUpdate.purs diff --git a/examples/passing/NestedRecordUpdateWildcards.purs b/tests/purs/passing/NestedRecordUpdateWildcards.purs similarity index 100% rename from examples/passing/NestedRecordUpdateWildcards.purs rename to tests/purs/passing/NestedRecordUpdateWildcards.purs diff --git a/examples/passing/NestedTypeSynonyms.purs b/tests/purs/passing/NestedTypeSynonyms.purs similarity index 100% rename from examples/passing/NestedTypeSynonyms.purs rename to tests/purs/passing/NestedTypeSynonyms.purs diff --git a/examples/passing/NestedWhere.purs b/tests/purs/passing/NestedWhere.purs similarity index 100% rename from examples/passing/NestedWhere.purs rename to tests/purs/passing/NestedWhere.purs diff --git a/examples/passing/NewConsClass.purs b/tests/purs/passing/NewConsClass.purs similarity index 100% rename from examples/passing/NewConsClass.purs rename to tests/purs/passing/NewConsClass.purs diff --git a/examples/passing/Newtype.purs b/tests/purs/passing/Newtype.purs similarity index 100% rename from examples/passing/Newtype.purs rename to tests/purs/passing/Newtype.purs diff --git a/examples/passing/NewtypeClass.purs b/tests/purs/passing/NewtypeClass.purs similarity index 100% rename from examples/passing/NewtypeClass.purs rename to tests/purs/passing/NewtypeClass.purs diff --git a/examples/passing/NewtypeEff.purs b/tests/purs/passing/NewtypeEff.purs similarity index 100% rename from examples/passing/NewtypeEff.purs rename to tests/purs/passing/NewtypeEff.purs diff --git a/examples/passing/NewtypeInstance.purs b/tests/purs/passing/NewtypeInstance.purs similarity index 100% rename from examples/passing/NewtypeInstance.purs rename to tests/purs/passing/NewtypeInstance.purs diff --git a/examples/passing/NewtypeWithRecordUpdate.purs b/tests/purs/passing/NewtypeWithRecordUpdate.purs similarity index 100% rename from examples/passing/NewtypeWithRecordUpdate.purs rename to tests/purs/passing/NewtypeWithRecordUpdate.purs diff --git a/examples/passing/NonConflictingExports.purs b/tests/purs/passing/NonConflictingExports.purs similarity index 100% rename from examples/passing/NonConflictingExports.purs rename to tests/purs/passing/NonConflictingExports.purs diff --git a/examples/passing/NonConflictingExports/A.purs b/tests/purs/passing/NonConflictingExports/A.purs similarity index 100% rename from examples/passing/NonConflictingExports/A.purs rename to tests/purs/passing/NonConflictingExports/A.purs diff --git a/examples/passing/NonOrphanInstanceFunDepExtra.purs b/tests/purs/passing/NonOrphanInstanceFunDepExtra.purs similarity index 100% rename from examples/passing/NonOrphanInstanceFunDepExtra.purs rename to tests/purs/passing/NonOrphanInstanceFunDepExtra.purs diff --git a/examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs b/tests/purs/passing/NonOrphanInstanceFunDepExtra/Lib.purs similarity index 100% rename from examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs rename to tests/purs/passing/NonOrphanInstanceFunDepExtra/Lib.purs diff --git a/examples/passing/NonOrphanInstanceMulti.purs b/tests/purs/passing/NonOrphanInstanceMulti.purs similarity index 100% rename from examples/passing/NonOrphanInstanceMulti.purs rename to tests/purs/passing/NonOrphanInstanceMulti.purs diff --git a/examples/passing/NonOrphanInstanceMulti/Lib.purs b/tests/purs/passing/NonOrphanInstanceMulti/Lib.purs similarity index 100% rename from examples/passing/NonOrphanInstanceMulti/Lib.purs rename to tests/purs/passing/NonOrphanInstanceMulti/Lib.purs diff --git a/examples/passing/NumberLiterals.purs b/tests/purs/passing/NumberLiterals.purs similarity index 100% rename from examples/passing/NumberLiterals.purs rename to tests/purs/passing/NumberLiterals.purs diff --git a/examples/passing/ObjectGetter.purs b/tests/purs/passing/ObjectGetter.purs similarity index 100% rename from examples/passing/ObjectGetter.purs rename to tests/purs/passing/ObjectGetter.purs diff --git a/examples/passing/ObjectSynonym.purs b/tests/purs/passing/ObjectSynonym.purs similarity index 100% rename from examples/passing/ObjectSynonym.purs rename to tests/purs/passing/ObjectSynonym.purs diff --git a/examples/passing/ObjectUpdate.purs b/tests/purs/passing/ObjectUpdate.purs similarity index 95% rename from examples/passing/ObjectUpdate.purs rename to tests/purs/passing/ObjectUpdate.purs index bb4bfa7783..80053a4034 100644 --- a/examples/passing/ObjectUpdate.purs +++ b/tests/purs/passing/ObjectUpdate.purs @@ -1,23 +1,23 @@ -module Main where - -import Prelude -import Effect.Console (log) - -update1 = \o -> o { foo = "Foo" } - -update2 :: forall r. { foo :: String | r } -> { foo :: String | r } -update2 = \o -> o { foo = "Foo" } - -replace = \o -> case o of - { foo: "Foo" } -> o { foo = "Bar" } - { foo: "Bar" } -> o { bar = "Baz" } - o -> o - -polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r } -polyUpdate = \o -> o { foo = "Foo" } - -inferPolyUpdate = \o -> o { foo = "Foo" } - -main = do - log ((update1 {foo: ""}).foo) - log "Done" +module Main where + +import Prelude +import Effect.Console (log) + +update1 = \o -> o { foo = "Foo" } + +update2 :: forall r. { foo :: String | r } -> { foo :: String | r } +update2 = \o -> o { foo = "Foo" } + +replace = \o -> case o of + { foo: "Foo" } -> o { foo = "Bar" } + { foo: "Bar" } -> o { bar = "Baz" } + o -> o + +polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r } +polyUpdate = \o -> o { foo = "Foo" } + +inferPolyUpdate = \o -> o { foo = "Foo" } + +main = do + log ((update1 {foo: ""}).foo) + log "Done" diff --git a/examples/passing/ObjectUpdate2.purs b/tests/purs/passing/ObjectUpdate2.purs similarity index 100% rename from examples/passing/ObjectUpdate2.purs rename to tests/purs/passing/ObjectUpdate2.purs diff --git a/examples/passing/ObjectUpdater.purs b/tests/purs/passing/ObjectUpdater.purs similarity index 100% rename from examples/passing/ObjectUpdater.purs rename to tests/purs/passing/ObjectUpdater.purs diff --git a/examples/passing/ObjectWildcards.purs b/tests/purs/passing/ObjectWildcards.purs similarity index 100% rename from examples/passing/ObjectWildcards.purs rename to tests/purs/passing/ObjectWildcards.purs diff --git a/examples/passing/Objects.purs b/tests/purs/passing/Objects.purs similarity index 100% rename from examples/passing/Objects.purs rename to tests/purs/passing/Objects.purs diff --git a/examples/passing/OneConstructor.purs b/tests/purs/passing/OneConstructor.purs similarity index 100% rename from examples/passing/OneConstructor.purs rename to tests/purs/passing/OneConstructor.purs diff --git a/examples/passing/OperatorAlias.purs b/tests/purs/passing/OperatorAlias.purs similarity index 100% rename from examples/passing/OperatorAlias.purs rename to tests/purs/passing/OperatorAlias.purs diff --git a/examples/passing/OperatorAliasElsewhere.purs b/tests/purs/passing/OperatorAliasElsewhere.purs similarity index 100% rename from examples/passing/OperatorAliasElsewhere.purs rename to tests/purs/passing/OperatorAliasElsewhere.purs diff --git a/examples/passing/OperatorAliasElsewhere/Def.purs b/tests/purs/passing/OperatorAliasElsewhere/Def.purs similarity index 94% rename from examples/passing/OperatorAliasElsewhere/Def.purs rename to tests/purs/passing/OperatorAliasElsewhere/Def.purs index 85194c6fee..39448b6a54 100644 --- a/examples/passing/OperatorAliasElsewhere/Def.purs +++ b/tests/purs/passing/OperatorAliasElsewhere/Def.purs @@ -1,4 +1,4 @@ -module Def where - -what :: forall a b. a -> b -> a -what a _ = a +module Def where + +what :: forall a b. a -> b -> a +what a _ = a diff --git a/examples/passing/OperatorAssociativity.purs b/tests/purs/passing/OperatorAssociativity.purs similarity index 96% rename from examples/passing/OperatorAssociativity.purs rename to tests/purs/passing/OperatorAssociativity.purs index bdeca47301..6cf1cd35bb 100644 --- a/examples/passing/OperatorAssociativity.purs +++ b/tests/purs/passing/OperatorAssociativity.purs @@ -1,25 +1,25 @@ -module Main where - -import Prelude -import Effect -import Effect.Console -import Test.Assert - -bug :: Number -> Number -> Number -bug a b = 0.0 - (a - b) - -main = do - assert (bug 0.0 2.0 == 2.0) - assert (0.0 - (0.0 - 2.0) == 2.0) - assert (0.0 - (0.0 + 2.0) == -2.0) - assert (6.0 / (3.0 * 2.0) == 1.0) - assert ((6.0 / 3.0) * 2.0 == 4.0) - assert (not (1.0 < 0.0) == true) - assert (not ((negate 1.0) < 0.0) == false) - assert (negate (1.0 + 10.0) == -11.0) - assert (2.0 * 3.0 / 4.0 == 1.5) - assert (1.0 * 2.0 * 3.0 * 4.0 * 5.0 / 6.0 == 20.0) - assert (1.0 + 10.0 - 5.0 == 6.0) - assert (1.0 + 10.0 * 5.0 == 51.0) - assert (10.0 * 5.0 - 1.0 == 49.0) - log "Done" +module Main where + +import Prelude +import Effect +import Effect.Console +import Test.Assert + +bug :: Number -> Number -> Number +bug a b = 0.0 - (a - b) + +main = do + assert (bug 0.0 2.0 == 2.0) + assert (0.0 - (0.0 - 2.0) == 2.0) + assert (0.0 - (0.0 + 2.0) == -2.0) + assert (6.0 / (3.0 * 2.0) == 1.0) + assert ((6.0 / 3.0) * 2.0 == 4.0) + assert (not (1.0 < 0.0) == true) + assert (not ((negate 1.0) < 0.0) == false) + assert (negate (1.0 + 10.0) == -11.0) + assert (2.0 * 3.0 / 4.0 == 1.5) + assert (1.0 * 2.0 * 3.0 * 4.0 * 5.0 / 6.0 == 20.0) + assert (1.0 + 10.0 - 5.0 == 6.0) + assert (1.0 + 10.0 * 5.0 == 51.0) + assert (10.0 * 5.0 - 1.0 == 49.0) + log "Done" diff --git a/examples/passing/OperatorInlining.purs b/tests/purs/passing/OperatorInlining.purs similarity index 100% rename from examples/passing/OperatorInlining.purs rename to tests/purs/passing/OperatorInlining.purs diff --git a/examples/passing/OperatorSections.purs b/tests/purs/passing/OperatorSections.purs similarity index 100% rename from examples/passing/OperatorSections.purs rename to tests/purs/passing/OperatorSections.purs diff --git a/examples/passing/Operators.purs b/tests/purs/passing/Operators.purs similarity index 100% rename from examples/passing/Operators.purs rename to tests/purs/passing/Operators.purs diff --git a/examples/passing/Operators/Other.purs b/tests/purs/passing/Operators/Other.purs similarity index 100% rename from examples/passing/Operators/Other.purs rename to tests/purs/passing/Operators/Other.purs diff --git a/examples/passing/OptimizerBug.purs b/tests/purs/passing/OptimizerBug.purs similarity index 100% rename from examples/passing/OptimizerBug.purs rename to tests/purs/passing/OptimizerBug.purs diff --git a/examples/passing/OptionalQualified.purs b/tests/purs/passing/OptionalQualified.purs similarity index 100% rename from examples/passing/OptionalQualified.purs rename to tests/purs/passing/OptionalQualified.purs diff --git a/examples/passing/Ord1Deriving.purs b/tests/purs/passing/Ord1Deriving.purs similarity index 100% rename from examples/passing/Ord1Deriving.purs rename to tests/purs/passing/Ord1Deriving.purs diff --git a/examples/passing/Ord1InOrdDeriving.purs b/tests/purs/passing/Ord1InOrdDeriving.purs similarity index 100% rename from examples/passing/Ord1InOrdDeriving.purs rename to tests/purs/passing/Ord1InOrdDeriving.purs diff --git a/examples/passing/ParensInType.purs b/tests/purs/passing/ParensInType.purs similarity index 100% rename from examples/passing/ParensInType.purs rename to tests/purs/passing/ParensInType.purs diff --git a/examples/passing/ParensInTypedBinder.purs b/tests/purs/passing/ParensInTypedBinder.purs similarity index 100% rename from examples/passing/ParensInTypedBinder.purs rename to tests/purs/passing/ParensInTypedBinder.purs diff --git a/examples/passing/PartialFunction.purs b/tests/purs/passing/PartialFunction.purs similarity index 100% rename from examples/passing/PartialFunction.purs rename to tests/purs/passing/PartialFunction.purs diff --git a/examples/passing/Patterns.purs b/tests/purs/passing/Patterns.purs similarity index 100% rename from examples/passing/Patterns.purs rename to tests/purs/passing/Patterns.purs diff --git a/examples/passing/PendingConflictingImports.purs b/tests/purs/passing/PendingConflictingImports.purs similarity index 100% rename from examples/passing/PendingConflictingImports.purs rename to tests/purs/passing/PendingConflictingImports.purs diff --git a/examples/passing/PendingConflictingImports/A.purs b/tests/purs/passing/PendingConflictingImports/A.purs similarity index 100% rename from examples/passing/PendingConflictingImports/A.purs rename to tests/purs/passing/PendingConflictingImports/A.purs diff --git a/examples/passing/PendingConflictingImports/B.purs b/tests/purs/passing/PendingConflictingImports/B.purs similarity index 100% rename from examples/passing/PendingConflictingImports/B.purs rename to tests/purs/passing/PendingConflictingImports/B.purs diff --git a/examples/passing/PendingConflictingImports2.purs b/tests/purs/passing/PendingConflictingImports2.purs similarity index 100% rename from examples/passing/PendingConflictingImports2.purs rename to tests/purs/passing/PendingConflictingImports2.purs diff --git a/examples/passing/PendingConflictingImports2/A.purs b/tests/purs/passing/PendingConflictingImports2/A.purs similarity index 100% rename from examples/passing/PendingConflictingImports2/A.purs rename to tests/purs/passing/PendingConflictingImports2/A.purs diff --git a/examples/passing/Person.purs b/tests/purs/passing/Person.purs similarity index 100% rename from examples/passing/Person.purs rename to tests/purs/passing/Person.purs diff --git a/examples/passing/PolyLabels.js b/tests/purs/passing/PolyLabels.js similarity index 100% rename from examples/passing/PolyLabels.js rename to tests/purs/passing/PolyLabels.js diff --git a/examples/passing/PolyLabels.purs b/tests/purs/passing/PolyLabels.purs similarity index 100% rename from examples/passing/PolyLabels.purs rename to tests/purs/passing/PolyLabels.purs diff --git a/examples/passing/PrimedTypeName.purs b/tests/purs/passing/PrimedTypeName.purs similarity index 100% rename from examples/passing/PrimedTypeName.purs rename to tests/purs/passing/PrimedTypeName.purs diff --git a/examples/passing/QualifiedNames.purs b/tests/purs/passing/QualifiedNames.purs similarity index 96% rename from examples/passing/QualifiedNames.purs rename to tests/purs/passing/QualifiedNames.purs index f6a20ec02f..667c3345c6 100644 --- a/examples/passing/QualifiedNames.purs +++ b/tests/purs/passing/QualifiedNames.purs @@ -1,11 +1,11 @@ -module Main where - -import Prelude -import Either as Either -import Effect.Console (log) - -either :: forall a b c. (a -> c) -> (b -> c) -> Either.Either a b -> c -either f _ (Either.Left x) = f x -either _ g (Either.Right y) = g y - -main = log (either identity identity (Either.Left "Done")) +module Main where + +import Prelude +import Either as Either +import Effect.Console (log) + +either :: forall a b c. (a -> c) -> (b -> c) -> Either.Either a b -> c +either f _ (Either.Left x) = f x +either _ g (Either.Right y) = g y + +main = log (either identity identity (Either.Left "Done")) diff --git a/examples/passing/QualifiedNames/Either.purs b/tests/purs/passing/QualifiedNames/Either.purs similarity index 93% rename from examples/passing/QualifiedNames/Either.purs rename to tests/purs/passing/QualifiedNames/Either.purs index 9fc8a3b473..7a13371b16 100644 --- a/examples/passing/QualifiedNames/Either.purs +++ b/tests/purs/passing/QualifiedNames/Either.purs @@ -1,5 +1,5 @@ -module Either where - -import Prelude - -data Either a b = Left a | Right b +module Either where + +import Prelude + +data Either a b = Left a | Right b diff --git a/examples/passing/QualifiedQualifiedImports.purs b/tests/purs/passing/QualifiedQualifiedImports.purs similarity index 100% rename from examples/passing/QualifiedQualifiedImports.purs rename to tests/purs/passing/QualifiedQualifiedImports.purs diff --git a/examples/passing/Rank2Data.purs b/tests/purs/passing/Rank2Data.purs similarity index 94% rename from examples/passing/Rank2Data.purs rename to tests/purs/passing/Rank2Data.purs index d1b7331036..d8f2cc3021 100644 --- a/examples/passing/Rank2Data.purs +++ b/tests/purs/passing/Rank2Data.purs @@ -1,30 +1,30 @@ -module Main where - -import Prelude hiding (add) -import Effect.Console (log) - -data Id = Id forall a. a -> a - -runId = \id a -> case id of - Id f -> f a - -data Nat = Nat forall r. r -> (r -> r) -> r - -runNat = \nat -> case nat of - Nat f -> f 0.0 (\n -> n + 1.0) - -zero' = Nat (\zero' _ -> zero') - -succ = \n -> case n of - Nat f -> Nat (\zero' succ -> succ (f zero' succ)) - -add = \n m -> case n of - Nat f -> case m of - Nat g -> Nat (\zero' succ -> g (f zero' succ) succ) - -one' = succ zero' -two = succ zero' -four = add two two -fourNumber = runNat four - -main = log "Done" +module Main where + +import Prelude hiding (add) +import Effect.Console (log) + +data Id = Id forall a. a -> a + +runId = \id a -> case id of + Id f -> f a + +data Nat = Nat forall r. r -> (r -> r) -> r + +runNat = \nat -> case nat of + Nat f -> f 0.0 (\n -> n + 1.0) + +zero' = Nat (\zero' _ -> zero') + +succ = \n -> case n of + Nat f -> Nat (\zero' succ -> succ (f zero' succ)) + +add = \n m -> case n of + Nat f -> case m of + Nat g -> Nat (\zero' succ -> g (f zero' succ) succ) + +one' = succ zero' +two = succ zero' +four = add two two +fourNumber = runNat four + +main = log "Done" diff --git a/examples/passing/Rank2Object.purs b/tests/purs/passing/Rank2Object.purs similarity index 100% rename from examples/passing/Rank2Object.purs rename to tests/purs/passing/Rank2Object.purs diff --git a/examples/passing/Rank2TypeSynonym.purs b/tests/purs/passing/Rank2TypeSynonym.purs similarity index 100% rename from examples/passing/Rank2TypeSynonym.purs rename to tests/purs/passing/Rank2TypeSynonym.purs diff --git a/examples/passing/Rank2Types.purs b/tests/purs/passing/Rank2Types.purs similarity index 100% rename from examples/passing/Rank2Types.purs rename to tests/purs/passing/Rank2Types.purs diff --git a/examples/passing/ReExportQualified.purs b/tests/purs/passing/ReExportQualified.purs similarity index 100% rename from examples/passing/ReExportQualified.purs rename to tests/purs/passing/ReExportQualified.purs diff --git a/examples/passing/ReExportQualified/A.purs b/tests/purs/passing/ReExportQualified/A.purs similarity index 100% rename from examples/passing/ReExportQualified/A.purs rename to tests/purs/passing/ReExportQualified/A.purs diff --git a/examples/passing/ReExportQualified/B.purs b/tests/purs/passing/ReExportQualified/B.purs similarity index 100% rename from examples/passing/ReExportQualified/B.purs rename to tests/purs/passing/ReExportQualified/B.purs diff --git a/examples/passing/ReExportQualified/C.purs b/tests/purs/passing/ReExportQualified/C.purs similarity index 100% rename from examples/passing/ReExportQualified/C.purs rename to tests/purs/passing/ReExportQualified/C.purs diff --git a/examples/passing/RebindableSyntax.purs b/tests/purs/passing/RebindableSyntax.purs similarity index 100% rename from examples/passing/RebindableSyntax.purs rename to tests/purs/passing/RebindableSyntax.purs diff --git a/examples/passing/Recursion.purs b/tests/purs/passing/Recursion.purs similarity index 100% rename from examples/passing/Recursion.purs rename to tests/purs/passing/Recursion.purs diff --git a/examples/passing/RedefinedFixity.purs b/tests/purs/passing/RedefinedFixity.purs similarity index 92% rename from examples/passing/RedefinedFixity.purs rename to tests/purs/passing/RedefinedFixity.purs index 57e95d95af..8bee75adef 100644 --- a/examples/passing/RedefinedFixity.purs +++ b/tests/purs/passing/RedefinedFixity.purs @@ -1,6 +1,6 @@ -module Main where - -import M3 -import Effect.Console (log) - -main = log "Done" +module Main where + +import M3 +import Effect.Console (log) + +main = log "Done" diff --git a/examples/passing/RedefinedFixity/M1.purs b/tests/purs/passing/RedefinedFixity/M1.purs similarity index 95% rename from examples/passing/RedefinedFixity/M1.purs rename to tests/purs/passing/RedefinedFixity/M1.purs index 13f7f11ca2..703e37bfbd 100644 --- a/examples/passing/RedefinedFixity/M1.purs +++ b/tests/purs/passing/RedefinedFixity/M1.purs @@ -1,6 +1,6 @@ -module M1 where - -applyFn :: forall a b. (forall c d. c -> d) -> a -> b -applyFn f a = f a - -infixr 1000 applyFn as $ +module M1 where + +applyFn :: forall a b. (forall c d. c -> d) -> a -> b +applyFn f a = f a + +infixr 1000 applyFn as $ diff --git a/examples/passing/RedefinedFixity/M2.purs b/tests/purs/passing/RedefinedFixity/M2.purs similarity index 90% rename from examples/passing/RedefinedFixity/M2.purs rename to tests/purs/passing/RedefinedFixity/M2.purs index cc5c1999eb..359b51485a 100644 --- a/examples/passing/RedefinedFixity/M2.purs +++ b/tests/purs/passing/RedefinedFixity/M2.purs @@ -1,5 +1,5 @@ -module M2 where - -import Prelude () - -import M1 +module M2 where + +import Prelude () + +import M1 diff --git a/examples/passing/RedefinedFixity/M3.purs b/tests/purs/passing/RedefinedFixity/M3.purs similarity index 90% rename from examples/passing/RedefinedFixity/M3.purs rename to tests/purs/passing/RedefinedFixity/M3.purs index a7b0f39948..f7ac4629c8 100644 --- a/examples/passing/RedefinedFixity/M3.purs +++ b/tests/purs/passing/RedefinedFixity/M3.purs @@ -1,6 +1,6 @@ -module M3 where - -import Prelude () - -import M1 -import M2 +module M3 where + +import Prelude () + +import M1 +import M2 diff --git a/examples/passing/ReservedWords.purs b/tests/purs/passing/ReservedWords.purs similarity index 100% rename from examples/passing/ReservedWords.purs rename to tests/purs/passing/ReservedWords.purs diff --git a/examples/passing/ResolvableScopeConflict.purs b/tests/purs/passing/ResolvableScopeConflict.purs similarity index 100% rename from examples/passing/ResolvableScopeConflict.purs rename to tests/purs/passing/ResolvableScopeConflict.purs diff --git a/examples/passing/ResolvableScopeConflict/A.purs b/tests/purs/passing/ResolvableScopeConflict/A.purs similarity index 100% rename from examples/passing/ResolvableScopeConflict/A.purs rename to tests/purs/passing/ResolvableScopeConflict/A.purs diff --git a/examples/passing/ResolvableScopeConflict/B.purs b/tests/purs/passing/ResolvableScopeConflict/B.purs similarity index 100% rename from examples/passing/ResolvableScopeConflict/B.purs rename to tests/purs/passing/ResolvableScopeConflict/B.purs diff --git a/examples/passing/ResolvableScopeConflict2.purs b/tests/purs/passing/ResolvableScopeConflict2.purs similarity index 100% rename from examples/passing/ResolvableScopeConflict2.purs rename to tests/purs/passing/ResolvableScopeConflict2.purs diff --git a/examples/passing/ResolvableScopeConflict2/A.purs b/tests/purs/passing/ResolvableScopeConflict2/A.purs similarity index 100% rename from examples/passing/ResolvableScopeConflict2/A.purs rename to tests/purs/passing/ResolvableScopeConflict2/A.purs diff --git a/examples/passing/ResolvableScopeConflict3.purs b/tests/purs/passing/ResolvableScopeConflict3.purs similarity index 100% rename from examples/passing/ResolvableScopeConflict3.purs rename to tests/purs/passing/ResolvableScopeConflict3.purs diff --git a/examples/passing/ResolvableScopeConflict3/A.purs b/tests/purs/passing/ResolvableScopeConflict3/A.purs similarity index 100% rename from examples/passing/ResolvableScopeConflict3/A.purs rename to tests/purs/passing/ResolvableScopeConflict3/A.purs diff --git a/examples/passing/RowConstructors.purs b/tests/purs/passing/RowConstructors.purs similarity index 100% rename from examples/passing/RowConstructors.purs rename to tests/purs/passing/RowConstructors.purs diff --git a/examples/passing/RowInInstanceHeadDetermined.purs b/tests/purs/passing/RowInInstanceHeadDetermined.purs similarity index 100% rename from examples/passing/RowInInstanceHeadDetermined.purs rename to tests/purs/passing/RowInInstanceHeadDetermined.purs diff --git a/examples/passing/RowLacks.purs b/tests/purs/passing/RowLacks.purs similarity index 100% rename from examples/passing/RowLacks.purs rename to tests/purs/passing/RowLacks.purs diff --git a/examples/passing/RowNub.purs b/tests/purs/passing/RowNub.purs similarity index 100% rename from examples/passing/RowNub.purs rename to tests/purs/passing/RowNub.purs diff --git a/examples/passing/RowPolyInstanceContext.purs b/tests/purs/passing/RowPolyInstanceContext.purs similarity index 100% rename from examples/passing/RowPolyInstanceContext.purs rename to tests/purs/passing/RowPolyInstanceContext.purs diff --git a/examples/passing/RowUnion.js b/tests/purs/passing/RowUnion.js similarity index 100% rename from examples/passing/RowUnion.js rename to tests/purs/passing/RowUnion.js diff --git a/examples/passing/RowUnion.purs b/tests/purs/passing/RowUnion.purs similarity index 100% rename from examples/passing/RowUnion.purs rename to tests/purs/passing/RowUnion.purs diff --git a/examples/passing/RowsInInstanceContext.purs b/tests/purs/passing/RowsInInstanceContext.purs similarity index 100% rename from examples/passing/RowsInInstanceContext.purs rename to tests/purs/passing/RowsInInstanceContext.purs diff --git a/examples/passing/RunFnInline.purs b/tests/purs/passing/RunFnInline.purs similarity index 100% rename from examples/passing/RunFnInline.purs rename to tests/purs/passing/RunFnInline.purs diff --git a/examples/passing/RuntimeScopeIssue.purs b/tests/purs/passing/RuntimeScopeIssue.purs similarity index 100% rename from examples/passing/RuntimeScopeIssue.purs rename to tests/purs/passing/RuntimeScopeIssue.purs diff --git a/examples/passing/ScopedTypeVariables.purs b/tests/purs/passing/ScopedTypeVariables.purs similarity index 100% rename from examples/passing/ScopedTypeVariables.purs rename to tests/purs/passing/ScopedTypeVariables.purs diff --git a/examples/passing/Sequence.purs b/tests/purs/passing/Sequence.purs similarity index 100% rename from examples/passing/Sequence.purs rename to tests/purs/passing/Sequence.purs diff --git a/examples/passing/SequenceDesugared.purs b/tests/purs/passing/SequenceDesugared.purs similarity index 100% rename from examples/passing/SequenceDesugared.purs rename to tests/purs/passing/SequenceDesugared.purs diff --git a/examples/passing/ShadowedModuleName.purs b/tests/purs/passing/ShadowedModuleName.purs similarity index 100% rename from examples/passing/ShadowedModuleName.purs rename to tests/purs/passing/ShadowedModuleName.purs diff --git a/examples/passing/ShadowedModuleName/Test.purs b/tests/purs/passing/ShadowedModuleName/Test.purs similarity index 100% rename from examples/passing/ShadowedModuleName/Test.purs rename to tests/purs/passing/ShadowedModuleName/Test.purs diff --git a/examples/passing/ShadowedName.purs b/tests/purs/passing/ShadowedName.purs similarity index 94% rename from examples/passing/ShadowedName.purs rename to tests/purs/passing/ShadowedName.purs index 3c06295326..3639dc887c 100644 --- a/examples/passing/ShadowedName.purs +++ b/tests/purs/passing/ShadowedName.purs @@ -1,11 +1,11 @@ -module Main where - -import Prelude -import Effect.Console -import Effect.Console (log) - -done :: String -done = let str = "Not yet done" in - let str = "Done" in str - -main = log done +module Main where + +import Prelude +import Effect.Console +import Effect.Console (log) + +done :: String +done = let str = "Not yet done" in + let str = "Done" in str + +main = log done diff --git a/examples/passing/ShadowedRename.purs b/tests/purs/passing/ShadowedRename.purs similarity index 100% rename from examples/passing/ShadowedRename.purs rename to tests/purs/passing/ShadowedRename.purs diff --git a/examples/passing/ShadowedTCO.purs b/tests/purs/passing/ShadowedTCO.purs similarity index 94% rename from examples/passing/ShadowedTCO.purs rename to tests/purs/passing/ShadowedTCO.purs index 54fb9f87ed..f8d6612714 100644 --- a/examples/passing/ShadowedTCO.purs +++ b/tests/purs/passing/ShadowedTCO.purs @@ -1,21 +1,21 @@ -module Main where - -import Prelude hiding (add) -import Effect.Console (log) - -runNat f = f 0.0 (\n -> n + 1.0) - -zero' z _ = z - -succ f zero' succ = succ (f zero' succ) - -add f g zero' succ = g (f zero' succ) succ - -one' = succ zero' -two = succ one' -four = add two two -fourNumber = runNat four - -main = do - log $ show fourNumber - log "Done" +module Main where + +import Prelude hiding (add) +import Effect.Console (log) + +runNat f = f 0.0 (\n -> n + 1.0) + +zero' z _ = z + +succ f zero' succ = succ (f zero' succ) + +add f g zero' succ = g (f zero' succ) succ + +one' = succ zero' +two = succ one' +four = add two two +fourNumber = runNat four + +main = do + log $ show fourNumber + log "Done" diff --git a/examples/passing/ShadowedTCOLet.purs b/tests/purs/passing/ShadowedTCOLet.purs similarity index 94% rename from examples/passing/ShadowedTCOLet.purs rename to tests/purs/passing/ShadowedTCOLet.purs index b154761810..5090d4db28 100644 --- a/examples/passing/ShadowedTCOLet.purs +++ b/tests/purs/passing/ShadowedTCOLet.purs @@ -1,15 +1,15 @@ -module Main where - -import Prelude -import Partial.Unsafe (unsafePartial) -import Effect -import Effect.Console (log) - -f x y z = - let f 1.0 2.0 3.0 = 1.0 - in f x z y - -main :: Effect _ -main = do - log $ show $ unsafePartial f 1.0 3.0 2.0 - log "Done" +module Main where + +import Prelude +import Partial.Unsafe (unsafePartial) +import Effect +import Effect.Console (log) + +f x y z = + let f 1.0 2.0 3.0 = 1.0 + in f x z y + +main :: Effect _ +main = do + log $ show $ unsafePartial f 1.0 3.0 2.0 + log "Done" diff --git a/examples/passing/SignedNumericLiterals.purs b/tests/purs/passing/SignedNumericLiterals.purs similarity index 100% rename from examples/passing/SignedNumericLiterals.purs rename to tests/purs/passing/SignedNumericLiterals.purs diff --git a/examples/passing/SolvingAppendSymbol.purs b/tests/purs/passing/SolvingAppendSymbol.purs similarity index 100% rename from examples/passing/SolvingAppendSymbol.purs rename to tests/purs/passing/SolvingAppendSymbol.purs diff --git a/examples/passing/SolvingCompareSymbol.purs b/tests/purs/passing/SolvingCompareSymbol.purs similarity index 100% rename from examples/passing/SolvingCompareSymbol.purs rename to tests/purs/passing/SolvingCompareSymbol.purs diff --git a/examples/passing/SolvingIsSymbol.purs b/tests/purs/passing/SolvingIsSymbol.purs similarity index 100% rename from examples/passing/SolvingIsSymbol.purs rename to tests/purs/passing/SolvingIsSymbol.purs diff --git a/examples/passing/SolvingIsSymbol/Lib.purs b/tests/purs/passing/SolvingIsSymbol/Lib.purs similarity index 100% rename from examples/passing/SolvingIsSymbol/Lib.purs rename to tests/purs/passing/SolvingIsSymbol/Lib.purs diff --git a/examples/passing/Stream.purs b/tests/purs/passing/Stream.purs similarity index 100% rename from examples/passing/Stream.purs rename to tests/purs/passing/Stream.purs diff --git a/examples/passing/StringEdgeCases.purs b/tests/purs/passing/StringEdgeCases.purs similarity index 100% rename from examples/passing/StringEdgeCases.purs rename to tests/purs/passing/StringEdgeCases.purs diff --git a/examples/passing/StringEdgeCases/Records.purs b/tests/purs/passing/StringEdgeCases/Records.purs similarity index 100% rename from examples/passing/StringEdgeCases/Records.purs rename to tests/purs/passing/StringEdgeCases/Records.purs diff --git a/examples/passing/StringEdgeCases/Symbols.purs b/tests/purs/passing/StringEdgeCases/Symbols.purs similarity index 100% rename from examples/passing/StringEdgeCases/Symbols.purs rename to tests/purs/passing/StringEdgeCases/Symbols.purs diff --git a/examples/passing/StringEscapes.purs b/tests/purs/passing/StringEscapes.purs similarity index 100% rename from examples/passing/StringEscapes.purs rename to tests/purs/passing/StringEscapes.purs diff --git a/examples/passing/Superclasses1.purs b/tests/purs/passing/Superclasses1.purs similarity index 100% rename from examples/passing/Superclasses1.purs rename to tests/purs/passing/Superclasses1.purs diff --git a/examples/passing/Superclasses3.purs b/tests/purs/passing/Superclasses3.purs similarity index 100% rename from examples/passing/Superclasses3.purs rename to tests/purs/passing/Superclasses3.purs diff --git a/examples/passing/TCO.purs b/tests/purs/passing/TCO.purs similarity index 100% rename from examples/passing/TCO.purs rename to tests/purs/passing/TCO.purs diff --git a/examples/passing/TCOCase.purs b/tests/purs/passing/TCOCase.purs similarity index 100% rename from examples/passing/TCOCase.purs rename to tests/purs/passing/TCOCase.purs diff --git a/examples/passing/TailCall.purs b/tests/purs/passing/TailCall.purs similarity index 100% rename from examples/passing/TailCall.purs rename to tests/purs/passing/TailCall.purs diff --git a/examples/passing/Tick.purs b/tests/purs/passing/Tick.purs similarity index 100% rename from examples/passing/Tick.purs rename to tests/purs/passing/Tick.purs diff --git a/examples/passing/TopLevelCase.purs b/tests/purs/passing/TopLevelCase.purs similarity index 100% rename from examples/passing/TopLevelCase.purs rename to tests/purs/passing/TopLevelCase.purs diff --git a/examples/passing/TransitiveImport.purs b/tests/purs/passing/TransitiveImport.purs similarity index 100% rename from examples/passing/TransitiveImport.purs rename to tests/purs/passing/TransitiveImport.purs diff --git a/examples/passing/TransitiveImport/Middle.purs b/tests/purs/passing/TransitiveImport/Middle.purs similarity index 100% rename from examples/passing/TransitiveImport/Middle.purs rename to tests/purs/passing/TransitiveImport/Middle.purs diff --git a/examples/passing/TransitiveImport/Test.purs b/tests/purs/passing/TransitiveImport/Test.purs similarity index 100% rename from examples/passing/TransitiveImport/Test.purs rename to tests/purs/passing/TransitiveImport/Test.purs diff --git a/examples/passing/TypeClassMemberOrderChange.purs b/tests/purs/passing/TypeClassMemberOrderChange.purs similarity index 93% rename from examples/passing/TypeClassMemberOrderChange.purs rename to tests/purs/passing/TypeClassMemberOrderChange.purs index e1957264af..6b7633c195 100644 --- a/examples/passing/TypeClassMemberOrderChange.purs +++ b/tests/purs/passing/TypeClassMemberOrderChange.purs @@ -1,16 +1,16 @@ -module Main where - -import Prelude -import Effect.Console (log) - -class Test a where - fn :: a -> a -> a - val :: a - -instance testBoolean :: Test Boolean where - val = true - fn x y = y - -main = do - log (show (fn true val)) - log "Done" +module Main where + +import Prelude +import Effect.Console (log) + +class Test a where + fn :: a -> a -> a + val :: a + +instance testBoolean :: Test Boolean where + val = true + fn x y = y + +main = do + log (show (fn true val)) + log "Done" diff --git a/examples/passing/TypeClasses.purs b/tests/purs/passing/TypeClasses.purs similarity index 100% rename from examples/passing/TypeClasses.purs rename to tests/purs/passing/TypeClasses.purs diff --git a/examples/passing/TypeClassesInOrder.purs b/tests/purs/passing/TypeClassesInOrder.purs similarity index 100% rename from examples/passing/TypeClassesInOrder.purs rename to tests/purs/passing/TypeClassesInOrder.purs diff --git a/examples/passing/TypeClassesWithOverlappingTypeVariables.purs b/tests/purs/passing/TypeClassesWithOverlappingTypeVariables.purs similarity index 100% rename from examples/passing/TypeClassesWithOverlappingTypeVariables.purs rename to tests/purs/passing/TypeClassesWithOverlappingTypeVariables.purs diff --git a/examples/passing/TypeDecl.purs b/tests/purs/passing/TypeDecl.purs similarity index 100% rename from examples/passing/TypeDecl.purs rename to tests/purs/passing/TypeDecl.purs diff --git a/examples/passing/TypeOperators.purs b/tests/purs/passing/TypeOperators.purs similarity index 100% rename from examples/passing/TypeOperators.purs rename to tests/purs/passing/TypeOperators.purs diff --git a/examples/passing/TypeOperators/A.purs b/tests/purs/passing/TypeOperators/A.purs similarity index 100% rename from examples/passing/TypeOperators/A.purs rename to tests/purs/passing/TypeOperators/A.purs diff --git a/examples/passing/TypeSynonymInData.purs b/tests/purs/passing/TypeSynonymInData.purs similarity index 100% rename from examples/passing/TypeSynonymInData.purs rename to tests/purs/passing/TypeSynonymInData.purs diff --git a/examples/passing/TypeSynonyms.purs b/tests/purs/passing/TypeSynonyms.purs similarity index 100% rename from examples/passing/TypeSynonyms.purs rename to tests/purs/passing/TypeSynonyms.purs diff --git a/examples/passing/TypeWildcards.purs b/tests/purs/passing/TypeWildcards.purs similarity index 100% rename from examples/passing/TypeWildcards.purs rename to tests/purs/passing/TypeWildcards.purs diff --git a/examples/passing/TypeWildcardsRecordExtension.purs b/tests/purs/passing/TypeWildcardsRecordExtension.purs similarity index 100% rename from examples/passing/TypeWildcardsRecordExtension.purs rename to tests/purs/passing/TypeWildcardsRecordExtension.purs diff --git a/examples/passing/TypeWithoutParens.purs b/tests/purs/passing/TypeWithoutParens.purs similarity index 100% rename from examples/passing/TypeWithoutParens.purs rename to tests/purs/passing/TypeWithoutParens.purs diff --git a/examples/passing/TypeWithoutParens/Lib.purs b/tests/purs/passing/TypeWithoutParens/Lib.purs similarity index 100% rename from examples/passing/TypeWithoutParens/Lib.purs rename to tests/purs/passing/TypeWithoutParens/Lib.purs diff --git a/examples/passing/TypedBinders.purs b/tests/purs/passing/TypedBinders.purs similarity index 100% rename from examples/passing/TypedBinders.purs rename to tests/purs/passing/TypedBinders.purs diff --git a/examples/passing/TypedWhere.purs b/tests/purs/passing/TypedWhere.purs similarity index 100% rename from examples/passing/TypedWhere.purs rename to tests/purs/passing/TypedWhere.purs diff --git a/examples/passing/UTF8Sourcefile.purs b/tests/purs/passing/UTF8Sourcefile.purs similarity index 94% rename from examples/passing/UTF8Sourcefile.purs rename to tests/purs/passing/UTF8Sourcefile.purs index 5a589d162e..ecacfd7652 100644 --- a/examples/passing/UTF8Sourcefile.purs +++ b/tests/purs/passing/UTF8Sourcefile.purs @@ -1,8 +1,8 @@ -module Main where - -import Effect.Console - --- '→' is multibyte sequence \u2192. -utf8multibyte = "Hello λ→ world!!" - -main = log "Done" +module Main where + +import Effect.Console + +-- '→' is multibyte sequence \u2192. +utf8multibyte = "Hello λ→ world!!" + +main = log "Done" diff --git a/examples/passing/UnderscoreIdent.purs b/tests/purs/passing/UnderscoreIdent.purs similarity index 100% rename from examples/passing/UnderscoreIdent.purs rename to tests/purs/passing/UnderscoreIdent.purs diff --git a/examples/passing/UnicodeIdentifier.purs b/tests/purs/passing/UnicodeIdentifier.purs similarity index 100% rename from examples/passing/UnicodeIdentifier.purs rename to tests/purs/passing/UnicodeIdentifier.purs diff --git a/examples/passing/UnicodeOperators.purs b/tests/purs/passing/UnicodeOperators.purs similarity index 100% rename from examples/passing/UnicodeOperators.purs rename to tests/purs/passing/UnicodeOperators.purs diff --git a/examples/passing/UnicodeType.purs b/tests/purs/passing/UnicodeType.purs similarity index 100% rename from examples/passing/UnicodeType.purs rename to tests/purs/passing/UnicodeType.purs diff --git a/examples/passing/UnifyInTypeInstanceLookup.purs b/tests/purs/passing/UnifyInTypeInstanceLookup.purs similarity index 100% rename from examples/passing/UnifyInTypeInstanceLookup.purs rename to tests/purs/passing/UnifyInTypeInstanceLookup.purs diff --git a/examples/passing/Unit.purs b/tests/purs/passing/Unit.purs similarity index 100% rename from examples/passing/Unit.purs rename to tests/purs/passing/Unit.purs diff --git a/examples/passing/UnknownInTypeClassLookup.purs b/tests/purs/passing/UnknownInTypeClassLookup.purs similarity index 100% rename from examples/passing/UnknownInTypeClassLookup.purs rename to tests/purs/passing/UnknownInTypeClassLookup.purs diff --git a/examples/passing/UnsafeCoerce.purs b/tests/purs/passing/UnsafeCoerce.purs similarity index 100% rename from examples/passing/UnsafeCoerce.purs rename to tests/purs/passing/UnsafeCoerce.purs diff --git a/examples/passing/UntupledConstraints.purs b/tests/purs/passing/UntupledConstraints.purs similarity index 100% rename from examples/passing/UntupledConstraints.purs rename to tests/purs/passing/UntupledConstraints.purs diff --git a/examples/passing/UsableTypeClassMethods.purs b/tests/purs/passing/UsableTypeClassMethods.purs similarity index 100% rename from examples/passing/UsableTypeClassMethods.purs rename to tests/purs/passing/UsableTypeClassMethods.purs diff --git a/examples/passing/Where.purs b/tests/purs/passing/Where.purs similarity index 100% rename from examples/passing/Where.purs rename to tests/purs/passing/Where.purs diff --git a/examples/passing/WildcardInInstance.purs b/tests/purs/passing/WildcardInInstance.purs similarity index 100% rename from examples/passing/WildcardInInstance.purs rename to tests/purs/passing/WildcardInInstance.purs diff --git a/examples/passing/WildcardType.purs b/tests/purs/passing/WildcardType.purs similarity index 92% rename from examples/passing/WildcardType.purs rename to tests/purs/passing/WildcardType.purs index 92fb8dc3be..893c444569 100644 --- a/examples/passing/WildcardType.purs +++ b/tests/purs/passing/WildcardType.purs @@ -1,12 +1,12 @@ -module Main where - -import Prelude -import Effect.Console (log) - -f1 :: (_ -> _) -> _ -f1 g = g 1 - -f2 :: _ -> _ -f2 _ = "Done" - -main = log $ f1 f2 +module Main where + +import Prelude +import Effect.Console (log) + +f1 :: (_ -> _) -> _ +f1 g = g 1 + +f2 :: _ -> _ +f2 _ = "Done" + +main = log $ f1 f2 diff --git a/examples/passing/iota.purs b/tests/purs/passing/iota.purs similarity index 100% rename from examples/passing/iota.purs rename to tests/purs/passing/iota.purs diff --git a/examples/passing/s.purs b/tests/purs/passing/s.purs similarity index 100% rename from examples/passing/s.purs rename to tests/purs/passing/s.purs diff --git a/examples/psci/BasicEval.purs b/tests/purs/psci/BasicEval.purs similarity index 100% rename from examples/psci/BasicEval.purs rename to tests/purs/psci/BasicEval.purs diff --git a/examples/psci/Multiline.purs b/tests/purs/psci/Multiline.purs similarity index 100% rename from examples/psci/Multiline.purs rename to tests/purs/psci/Multiline.purs diff --git a/examples/warning/2140.purs b/tests/purs/warning/2140.purs similarity index 100% rename from examples/warning/2140.purs rename to tests/purs/warning/2140.purs diff --git a/examples/warning/2383.purs b/tests/purs/warning/2383.purs similarity index 100% rename from examples/warning/2383.purs rename to tests/purs/warning/2383.purs diff --git a/examples/warning/2411.purs b/tests/purs/warning/2411.purs similarity index 100% rename from examples/warning/2411.purs rename to tests/purs/warning/2411.purs diff --git a/examples/warning/2542.purs b/tests/purs/warning/2542.purs similarity index 100% rename from examples/warning/2542.purs rename to tests/purs/warning/2542.purs diff --git a/examples/warning/CustomWarning.purs b/tests/purs/warning/CustomWarning.purs similarity index 100% rename from examples/warning/CustomWarning.purs rename to tests/purs/warning/CustomWarning.purs diff --git a/examples/warning/CustomWarning2.purs b/tests/purs/warning/CustomWarning2.purs similarity index 100% rename from examples/warning/CustomWarning2.purs rename to tests/purs/warning/CustomWarning2.purs diff --git a/examples/warning/CustomWarning3.purs b/tests/purs/warning/CustomWarning3.purs similarity index 100% rename from examples/warning/CustomWarning3.purs rename to tests/purs/warning/CustomWarning3.purs diff --git a/examples/warning/DuplicateExportRef.purs b/tests/purs/warning/DuplicateExportRef.purs similarity index 100% rename from examples/warning/DuplicateExportRef.purs rename to tests/purs/warning/DuplicateExportRef.purs diff --git a/examples/warning/DuplicateImport.purs b/tests/purs/warning/DuplicateImport.purs similarity index 100% rename from examples/warning/DuplicateImport.purs rename to tests/purs/warning/DuplicateImport.purs diff --git a/examples/warning/DuplicateImportRef.purs b/tests/purs/warning/DuplicateImportRef.purs similarity index 100% rename from examples/warning/DuplicateImportRef.purs rename to tests/purs/warning/DuplicateImportRef.purs diff --git a/examples/warning/DuplicateSelectiveImport.purs b/tests/purs/warning/DuplicateSelectiveImport.purs similarity index 100% rename from examples/warning/DuplicateSelectiveImport.purs rename to tests/purs/warning/DuplicateSelectiveImport.purs diff --git a/examples/warning/HidingImport.purs b/tests/purs/warning/HidingImport.purs similarity index 100% rename from examples/warning/HidingImport.purs rename to tests/purs/warning/HidingImport.purs diff --git a/examples/warning/ImplicitImport.purs b/tests/purs/warning/ImplicitImport.purs similarity index 100% rename from examples/warning/ImplicitImport.purs rename to tests/purs/warning/ImplicitImport.purs diff --git a/examples/warning/ImplicitQualifiedImport.purs b/tests/purs/warning/ImplicitQualifiedImport.purs similarity index 100% rename from examples/warning/ImplicitQualifiedImport.purs rename to tests/purs/warning/ImplicitQualifiedImport.purs diff --git a/examples/warning/ImplicitQualifiedImportReExport.purs b/tests/purs/warning/ImplicitQualifiedImportReExport.purs similarity index 100% rename from examples/warning/ImplicitQualifiedImportReExport.purs rename to tests/purs/warning/ImplicitQualifiedImportReExport.purs diff --git a/examples/warning/MissingTypeDeclaration.purs b/tests/purs/warning/MissingTypeDeclaration.purs similarity index 100% rename from examples/warning/MissingTypeDeclaration.purs rename to tests/purs/warning/MissingTypeDeclaration.purs diff --git a/examples/warning/NewtypeInstance.purs b/tests/purs/warning/NewtypeInstance.purs similarity index 100% rename from examples/warning/NewtypeInstance.purs rename to tests/purs/warning/NewtypeInstance.purs diff --git a/examples/warning/NewtypeInstance2.purs b/tests/purs/warning/NewtypeInstance2.purs similarity index 100% rename from examples/warning/NewtypeInstance2.purs rename to tests/purs/warning/NewtypeInstance2.purs diff --git a/examples/warning/NewtypeInstance3.purs b/tests/purs/warning/NewtypeInstance3.purs similarity index 100% rename from examples/warning/NewtypeInstance3.purs rename to tests/purs/warning/NewtypeInstance3.purs diff --git a/examples/warning/NewtypeInstance4.purs b/tests/purs/warning/NewtypeInstance4.purs similarity index 100% rename from examples/warning/NewtypeInstance4.purs rename to tests/purs/warning/NewtypeInstance4.purs diff --git a/examples/warning/OverlappingPattern.purs b/tests/purs/warning/OverlappingPattern.purs similarity index 100% rename from examples/warning/OverlappingPattern.purs rename to tests/purs/warning/OverlappingPattern.purs diff --git a/examples/warning/ScopeShadowing.purs b/tests/purs/warning/ScopeShadowing.purs similarity index 100% rename from examples/warning/ScopeShadowing.purs rename to tests/purs/warning/ScopeShadowing.purs diff --git a/examples/warning/ScopeShadowing2.purs b/tests/purs/warning/ScopeShadowing2.purs similarity index 100% rename from examples/warning/ScopeShadowing2.purs rename to tests/purs/warning/ScopeShadowing2.purs diff --git a/examples/warning/ShadowedBinderPatternGuard.purs b/tests/purs/warning/ShadowedBinderPatternGuard.purs similarity index 100% rename from examples/warning/ShadowedBinderPatternGuard.purs rename to tests/purs/warning/ShadowedBinderPatternGuard.purs diff --git a/examples/warning/ShadowedNameParens.purs b/tests/purs/warning/ShadowedNameParens.purs similarity index 100% rename from examples/warning/ShadowedNameParens.purs rename to tests/purs/warning/ShadowedNameParens.purs diff --git a/examples/warning/ShadowedTypeVar.purs b/tests/purs/warning/ShadowedTypeVar.purs similarity index 100% rename from examples/warning/ShadowedTypeVar.purs rename to tests/purs/warning/ShadowedTypeVar.purs diff --git a/examples/warning/UnnecessaryFFIModule.js b/tests/purs/warning/UnnecessaryFFIModule.js similarity index 100% rename from examples/warning/UnnecessaryFFIModule.js rename to tests/purs/warning/UnnecessaryFFIModule.js diff --git a/examples/warning/UnnecessaryFFIModule.purs b/tests/purs/warning/UnnecessaryFFIModule.purs similarity index 100% rename from examples/warning/UnnecessaryFFIModule.purs rename to tests/purs/warning/UnnecessaryFFIModule.purs diff --git a/examples/warning/UnusedDctorExplicitImport.purs b/tests/purs/warning/UnusedDctorExplicitImport.purs similarity index 100% rename from examples/warning/UnusedDctorExplicitImport.purs rename to tests/purs/warning/UnusedDctorExplicitImport.purs diff --git a/examples/warning/UnusedDctorImportAll.purs b/tests/purs/warning/UnusedDctorImportAll.purs similarity index 100% rename from examples/warning/UnusedDctorImportAll.purs rename to tests/purs/warning/UnusedDctorImportAll.purs diff --git a/examples/warning/UnusedDctorImportExplicit.purs b/tests/purs/warning/UnusedDctorImportExplicit.purs similarity index 100% rename from examples/warning/UnusedDctorImportExplicit.purs rename to tests/purs/warning/UnusedDctorImportExplicit.purs diff --git a/examples/warning/UnusedExplicitImport.purs b/tests/purs/warning/UnusedExplicitImport.purs similarity index 100% rename from examples/warning/UnusedExplicitImport.purs rename to tests/purs/warning/UnusedExplicitImport.purs diff --git a/examples/warning/UnusedExplicitImportTypeOp.purs b/tests/purs/warning/UnusedExplicitImportTypeOp.purs similarity index 100% rename from examples/warning/UnusedExplicitImportTypeOp.purs rename to tests/purs/warning/UnusedExplicitImportTypeOp.purs diff --git a/examples/warning/UnusedExplicitImportTypeOp/Lib.purs b/tests/purs/warning/UnusedExplicitImportTypeOp/Lib.purs similarity index 100% rename from examples/warning/UnusedExplicitImportTypeOp/Lib.purs rename to tests/purs/warning/UnusedExplicitImportTypeOp/Lib.purs diff --git a/examples/warning/UnusedExplicitImportValOp.purs b/tests/purs/warning/UnusedExplicitImportValOp.purs similarity index 100% rename from examples/warning/UnusedExplicitImportValOp.purs rename to tests/purs/warning/UnusedExplicitImportValOp.purs diff --git a/examples/warning/UnusedFFIImplementations.js b/tests/purs/warning/UnusedFFIImplementations.js similarity index 100% rename from examples/warning/UnusedFFIImplementations.js rename to tests/purs/warning/UnusedFFIImplementations.js diff --git a/examples/warning/UnusedFFIImplementations.purs b/tests/purs/warning/UnusedFFIImplementations.purs similarity index 100% rename from examples/warning/UnusedFFIImplementations.purs rename to tests/purs/warning/UnusedFFIImplementations.purs diff --git a/examples/warning/UnusedImport.purs b/tests/purs/warning/UnusedImport.purs similarity index 100% rename from examples/warning/UnusedImport.purs rename to tests/purs/warning/UnusedImport.purs diff --git a/examples/warning/UnusedTypeVar.purs b/tests/purs/warning/UnusedTypeVar.purs similarity index 100% rename from examples/warning/UnusedTypeVar.purs rename to tests/purs/warning/UnusedTypeVar.purs diff --git a/examples/warning/WildcardInferredType.purs b/tests/purs/warning/WildcardInferredType.purs similarity index 100% rename from examples/warning/WildcardInferredType.purs rename to tests/purs/warning/WildcardInferredType.purs From 91e77b78d0b26a1b277b0aae07d892d4d2122815 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 27 Apr 2018 16:39:48 +0100 Subject: [PATCH 0980/1580] Introduce `--codegen` argument so targets can be specified explicitly (#3324) * Prevent codegen when `--dump-corefn` is supplied * Prevent FFI checks when --dump-corefn is used * Add `--codegen` flag to allow exact specification of codegen targets * Trim codgen targets --- CONTRIBUTORS.md | 1 + app/Command/Compile.hs | 57 ++++++++++++---- src/Language/PureScript/CodeGen/JS.hs | 4 +- src/Language/PureScript/Make/Actions.hs | 88 +++++++++++++------------ src/Language/PureScript/Options.hs | 12 ++-- 5 files changed, 100 insertions(+), 62 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index ac47e82975..7b1c853ec7 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -123,6 +123,7 @@ If you would prefer to use different terms, please use the section below instead | [@thimoteus](https://github.com/Thimoteus) | thimoteus | [MIT license](http://opensource.org/licenses/MIT) | | [@sloosch](https://github.com/sloosch) | Simon Looschen | [MIT license](http://opensource.org/licenses/MIT) | | [@rgrinberg](https://github.com/rgrinberg) | Rudi Grinberg | [MIT license](http://opensource.org/licenses/MIT) | +| [@gabejohnson](https://github.com/gabejohnson) | Gabe Johnson | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index b5baa59961..cb91b6173a 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -13,8 +13,12 @@ import qualified Data.Aeson as A import Data.Bool (bool) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.UTF8 as BU8 +import Data.List (intercalate) import qualified Data.Map as M +import qualified Data.Set as S import Data.Text (Text) +import qualified Data.Text as T +import Data.Traversable (for) import qualified Language.PureScript as P import Language.PureScript.Errors.JSON import Language.PureScript.Make @@ -89,7 +93,7 @@ readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8FileT inputFile :: Opts.Parser FilePath inputFile = Opts.strArgument $ Opts.metavar "FILE" - <> Opts.help "The input .purs file(s)" + <> Opts.help "The input .purs file(s)." outputDirectory :: Opts.Parser FilePath outputDirectory = Opts.strOption $ @@ -122,21 +126,46 @@ jsonErrors = Opts.switch $ Opts.long "json-errors" <> Opts.help "Print errors to stderr as JSON" -sourceMaps :: Opts.Parser Bool -sourceMaps = Opts.switch $ - Opts.long "source-maps" - <> Opts.help "Generate source maps" - -dumpCoreFn :: Opts.Parser Bool -dumpCoreFn = Opts.switch $ - Opts.long "dump-corefn" - <> Opts.help "Dump the (functional) core representation of the compiled code at output/*/corefn.json" +codegenTargets :: Opts.Parser [P.CodegenTarget] +codegenTargets = Opts.option targetParser $ + Opts.short 'g' + <> Opts.long "codegen" + <> Opts.value [P.JS] + <> Opts.help + ( "Specifies comma-separated codegen targets to include. " + <> targetsMessage + <> " The default target is 'js', but if this option is used only the targets specified will be used." + ) + +targets :: M.Map String P.CodegenTarget +targets = M.fromList + [ ("js", P.JS) + , ("sourcemaps", P.JSSourceMap) + , ("corefn", P.CoreFn) + ] + +targetsMessage :: String +targetsMessage = "Accepted codegen targets are '" <> intercalate "', '" (M.keys targets) <> "'." + +targetParser :: Opts.ReadM [P.CodegenTarget] +targetParser = + Opts.str >>= \s -> + for (T.split (== ',') s) + $ maybe (Opts.readerError targetsMessage) pure + . flip M.lookup targets + . T.unpack + . T.strip options :: Opts.Parser P.Options -options = P.Options <$> verboseErrors - <*> (not <$> comments) - <*> sourceMaps - <*> dumpCoreFn +options = + P.Options + <$> verboseErrors + <*> (not <$> comments) + <*> (handleTargets <$> codegenTargets) + where + -- Ensure that the JS target is included if sourcemaps are + handleTargets :: [P.CodegenTarget] -> S.Set P.CodegenTarget + handleTargets ts = S.fromList (if elem P.JSSourceMap ts then P.JS : ts else ts) pscMakeOptions :: Opts.Parser PSCMakeOptions pscMakeOptions = PSCMakeOptions <$> many inputFile diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index daac78d7fe..d1afb4a58a 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -54,7 +54,7 @@ moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps - jsImports <- traverse (importToJs mnLookup) + jsImports <- traverse (importToJs mnLookup) . (\\ [mn, C.Prim, C.PrimOrdering, C.PrimRow, C.PrimRowList, C.PrimSymbol, C.PrimTypeError]) $ ordNub $ map snd imps let decls' = renameModules mnLookup decls jsDecls <- mapM bindToJs decls' @@ -150,7 +150,7 @@ moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ = withPos :: SourceSpan -> AST -> m AST withPos ss js = do - withSM <- asks optionsSourceMaps + withSM <- asks (elem JSSourceMap . optionsCodegenTargets) return $ if withSM then withSourceSpan ss js else js diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 3494a29d78..231c9e0ff8 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -20,7 +20,8 @@ import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.UTF8 as BU8 import Data.Either (partitionEithers) -import Data.Foldable (for_) +import Data.Foldable (for_, minimum) +import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) @@ -121,17 +122,23 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns return $ fmap (max fPath) e1 + outputFilename :: ModuleName -> String -> FilePath + outputFilename mn fn = + let filePath = T.unpack (runModuleName mn) + in outputDir filePath fn + + targetFilename :: ModuleName -> CodegenTarget -> FilePath + targetFilename mn = \case + JS -> outputFilename mn "index.js" + JSSourceMap -> outputFilename mn "index.js.map" + CoreFn -> outputFilename mn "corefn.json" + getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) getOutputTimestamp mn = do - dumpCoreFn <- asks optionsDumpCoreFn - let filePath = T.unpack (runModuleName mn) - jsFile = outputDir filePath "index.js" - externsFile = outputDir filePath "externs.json" - coreFnFile = outputDir filePath "corefn.json" - min3 js exts coreFn - | dumpCoreFn = min (min js exts) coreFn - | otherwise = min js exts - min3 <$> getTimestamp jsFile <*> getTimestamp externsFile <*> getTimestamp coreFnFile + codegenTargets <- asks optionsCodegenTargets + let outputPaths = [outputFilename mn "externs.json"] <> fmap (targetFilename mn) (S.toList codegenTargets) + timestamps <- traverse getTimestamp outputPaths + pure $ fmap minimum . NEL.nonEmpty =<< sequence timestamps readExterns :: ModuleName -> Make (FilePath, Externs) readExterns mn = do @@ -141,38 +148,37 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = codegen :: SourceSpan -> CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make () codegen modSS m _ exts = do let mn = CF.moduleName m - foreignInclude <- case mn `M.lookup` foreigns of - Just path - | not $ requiresForeign m -> do - tell $ errorMessage' modSS $ UnnecessaryFFIModule mn path - return Nothing - | otherwise -> do - checkForeignDecls modSS m path - return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign.js"] - Nothing | requiresForeign m -> throwError . errorMessage' modSS $ MissingFFIModule mn - | otherwise -> return Nothing - rawJs <- J.moduleToJs m foreignInclude - dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory - sourceMaps <- lift $ asks optionsSourceMaps - let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, []) - let filePath = T.unpack (runModuleName mn) - jsFile = outputDir filePath "index.js" - mapFile = outputDir filePath "index.js.map" - externsFile = outputDir filePath "externs.json" - foreignFile = outputDir filePath "foreign.js" - prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix] - js = T.unlines $ map ("// " <>) prefix ++ [pjs] - mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else "" - lift $ do - writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef) - for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile) - writeTextFile externsFile exts - lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings - dumpCoreFn <- lift $ asks optionsDumpCoreFn - when dumpCoreFn $ do - let coreFnFile = outputDir filePath "corefn.json" - let json = CFJ.moduleToJSON Paths.version m + lift $ writeTextFile (outputFilename mn "externs.json") exts + codegenTargets <- lift $ asks optionsCodegenTargets + when (S.member CoreFn codegenTargets) $ do + let coreFnFile = targetFilename mn CoreFn + json = CFJ.moduleToJSON Paths.version m lift $ writeTextFile coreFnFile (encode json) + when (S.member JS codegenTargets) $ do + foreignInclude <- case mn `M.lookup` foreigns of + Just path + | not $ requiresForeign m -> do + tell $ errorMessage' modSS $ UnnecessaryFFIModule mn path + return Nothing + | otherwise -> do + checkForeignDecls modSS m path + return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign.js"] + Nothing | requiresForeign m -> throwError . errorMessage' modSS $ MissingFFIModule mn + | otherwise -> return Nothing + rawJs <- J.moduleToJs m foreignInclude + dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory + let sourceMaps = S.member JSSourceMap codegenTargets + (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, []) + foreignFile = outputFilename mn "foreign.js" + jsFile = targetFilename mn JS + mapFile = targetFilename mn JSSourceMap + prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix] + js = T.unlines $ map ("// " <>) prefix ++ [pjs] + mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else "" + lift $ do + writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef) + for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile) + when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index 0e4e6d137c..3055946b4d 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -2,6 +2,7 @@ module Language.PureScript.Options where import Prelude.Compat +import qualified Data.Set as S -- | The data type of compiler options data Options = Options @@ -9,12 +10,13 @@ data Options = Options -- ^ Verbose error message , optionsNoComments :: Bool -- ^ Remove the comments from the generated js - , optionsSourceMaps :: Bool - -- ^ Generate source maps - , optionsDumpCoreFn :: Bool - -- ^ Dump CoreFn + , optionsCodegenTargets :: S.Set CodegenTarget + -- ^ Codegen targets (JS, CoreFn, etc.) } deriving Show -- Default make options defaultOptions :: Options -defaultOptions = Options False False False False +defaultOptions = Options False False (S.singleton JS) + +data CodegenTarget = JS | JSSourceMap | CoreFn + deriving (Eq, Ord, Show) From 02cf84e54606ac19319286b4b0e27cd56ba811e7 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 27 Apr 2018 17:47:56 +0100 Subject: [PATCH 0981/1580] Add a link to the forum in the README (#3330) --- README.md | 1 + 1 file changed, 1 insertion(+) diff --git a/README.md b/README.md index 3ac5df9543..f5db507c08 100644 --- a/README.md +++ b/README.md @@ -20,6 +20,7 @@ A small strongly typed programming language with expressive types that compiles ## Help! - [#purescript @ FP Slack](https://functionalprogramming.slack.com/) +- [PureScript Language Forum](https://purescript-users.ml/) - [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript) - [Google Group](https://groups.google.com/forum/#!forum/purescript) - [Gitter Channel](https://gitter.im/purescript/purescript?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) From 9df1bbef5e0a28e58bc6a014203461bfa79b408e Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 27 Apr 2018 17:49:42 +0100 Subject: [PATCH 0982/1580] Check foreign kinds are exported when used in exported type (#3331) --- src/Language/PureScript/TypeChecker.hs | 16 +++++++++++----- tests/purs/failing/TransitiveKindExport.purs | 6 ++++++ 2 files changed, 17 insertions(+), 5 deletions(-) create mode 100644 tests/purs/failing/TransitiveKindExport.purs diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index a4257e0cc2..3e293e3f07 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -546,15 +546,20 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m () checkMemberExport extract dr@(TypeRef _ name dctors) = do env <- getEnv + for_ (M.lookup (qualify' name) (types env)) $ \(k, _) -> do + let findModuleKinds = everythingOnKinds (++) $ \case + NamedKind (Qualified (Just mn') kindName) | mn' == mn -> [kindName] + _ -> [] + checkExport dr $ KindRef (declRefSourceSpan dr) <$> findModuleKinds k for_ (M.lookup (qualify' name) (typeSynonyms env)) $ \(_, ty) -> - checkExport dr extract ty + checkExport dr (extract ty) for_ dctors $ \dctors' -> for_ dctors' $ \dctor -> for_ (M.lookup (qualify' dctor) (dataConstructors env)) $ \(_, _, ty, _) -> - checkExport dr extract ty + checkExport dr (extract ty) checkMemberExport extract dr@(ValueRef _ name) = do ty <- lookupVariable (qualify' name) - checkExport dr extract ty + checkExport dr (extract ty) checkMemberExport _ _ = return () checkSuperClassExport @@ -578,13 +583,14 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = checkSuperClassExport _ _ _ = return () - checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m () - checkExport dr extract ty = case filter (not . exported) (extract ty) of + checkExport :: DeclarationRef -> [DeclarationRef] -> m () + checkExport dr drs = case filter (not . exported) drs of [] -> return () hidden -> throwError . errorMessage' (declRefSourceSpan dr) $ TransitiveExportError dr (nubBy nubEq hidden) where exported e = any (exports e) exps exports (TypeRef _ pn1 _) (TypeRef _ pn2 _) = pn1 == pn2 + exports (KindRef _ pn1) (KindRef _ pn2) = pn1 == pn2 exports (ValueRef _ id1) (ValueRef _ id2) = id1 == id2 exports (TypeClassRef _ pn1) (TypeClassRef _ pn2) = pn1 == pn2 exports _ _ = False diff --git a/tests/purs/failing/TransitiveKindExport.purs b/tests/purs/failing/TransitiveKindExport.purs new file mode 100644 index 0000000000..7aba655967 --- /dev/null +++ b/tests/purs/failing/TransitiveKindExport.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith TransitiveExportError +module Main (TestProxy(..)) where + +foreign import kind Test + +data TestProxy (p :: Test) = TestProxy From 827c526648ea85d50ff69389572ed9c5c5039b9d Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 27 Apr 2018 18:12:48 +0100 Subject: [PATCH 0983/1580] Move rogue test case from old "examples" location (#3332) --- {examples => tests/purs}/passing/2803.purs | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename {examples => tests/purs}/passing/2803.purs (100%) diff --git a/examples/passing/2803.purs b/tests/purs/passing/2803.purs similarity index 100% rename from examples/passing/2803.purs rename to tests/purs/passing/2803.purs From 95acfb731fa7ddef5852b192eb5cca4dd93a28ea Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sat, 28 Apr 2018 00:08:22 +0100 Subject: [PATCH 0984/1580] Add evidence for solving empty type classes & keep track of sub goals (#3334) --- .../PureScript/TypeChecker/Entailment.hs | 46 +++++++------------ tests/purs/failing/LacksWithSubGoal.purs | 16 +++++++ 2 files changed, 33 insertions(+), 29 deletions(-) create mode 100644 tests/purs/failing/LacksWithSubGoal.purs diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 0cf77a6d44..b11f064f69 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -52,14 +52,7 @@ data Evidence -- | Computed instances | WarnInstance Type -- ^ Warn type class with a user-defined warning message | IsSymbolInstance PSString -- ^ The IsSymbol type class for a given Symbol literal - | SymbolCompareInstance - | SymbolConsInstance - | SymbolAppendInstance - | UnionInstance - | ConsInstance - | NubInstance - | LacksInstance - | RowToListInstance + | EmptyClassInstance -- ^ For any solved type class with no members deriving (Show, Eq) -- | Extract the identifier of a named instance @@ -341,29 +334,24 @@ entails SolverOptions{..} constraint context hints = solveSubgoals subst (Just subgoals) = Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals + -- We need subgoal dictionaries to appear in the term somewhere + -- If there aren't any then the dictionary is just undefined + useEmptyDict :: Maybe [Expr] -> Expr + useEmptyDict args = foldl (App . Abs (VarBinder nullSourceSpan UnusedIdent)) valUndefined (fold args) + -- Make a dictionary from subgoal dictionaries by applying the correct function mkDictionary :: Evidence -> Maybe [Expr] -> m Expr mkDictionary (NamedInstance n) args = return $ foldl App (Var nullSourceSpan n) (fold args) - mkDictionary UnionInstance (Just [e]) = - -- We need the subgoal dictionary to appear in the term somewhere - return $ App (Abs (VarBinder nullSourceSpan UnusedIdent) valUndefined) e - mkDictionary UnionInstance _ = return valUndefined - mkDictionary ConsInstance _ = return valUndefined - mkDictionary NubInstance _ = return valUndefined - mkDictionary LacksInstance _ = return valUndefined - mkDictionary RowToListInstance _ = return valUndefined - mkDictionary (WarnInstance msg) _ = do + mkDictionary EmptyClassInstance args = return (useEmptyDict args) + mkDictionary (WarnInstance msg) args = do tell . errorMessage $ UserDefinedWarning msg -- We cannot call the type class constructor here because Warn is declared in Prim. -- This means that it doesn't have a definition that we can import. -- So pass an empty placeholder (undefined) instead. - return valUndefined + return (useEmptyDict args) mkDictionary (IsSymbolInstance sym) _ = let fields = [ ("reflectSymbol", Abs (VarBinder nullSourceSpan UnusedIdent) (Literal nullSourceSpan (StringLiteral sym))) ] in return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal nullSourceSpan (ObjectLiteral fields)) - mkDictionary SymbolCompareInstance _ = return valUndefined - mkDictionary SymbolConsInstance _ = return valUndefined - mkDictionary SymbolAppendInstance _ = return valUndefined -- Turn a DictionaryValue into a Expr subclassDictionaryValue :: Expr -> Qualified (ProperName 'ClassName) -> Integer -> Expr @@ -381,14 +369,14 @@ entails SolverOptions{..} constraint context hints = EQ -> C.orderingEQ GT -> C.orderingGT args' = [arg0, arg1, TypeConstructor ordering] - in Just [TypeClassDictionaryInScope [] 0 SymbolCompareInstance [] C.SymbolCompare args' Nothing] + in Just [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolCompare args' Nothing] solveSymbolCompare _ = Nothing solveSymbolAppend :: [Type] -> Maybe [TypeClassDict] solveSymbolAppend [arg0, arg1, arg2] = do (arg0', arg1', arg2') <- appendSymbols arg0 arg1 arg2 let args' = [arg0', arg1', arg2'] - pure [TypeClassDictionaryInScope [] 0 SymbolAppendInstance [] C.SymbolAppend args' Nothing] + pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolAppend args' Nothing] solveSymbolAppend _ = Nothing -- | Append type level symbols, or, run backwards, strip a prefix or suffix @@ -410,7 +398,7 @@ entails SolverOptions{..} constraint context hints = solveSymbolCons [arg0, arg1, arg2] = do (arg0', arg1', arg2') <- consSymbol arg0 arg1 arg2 let args' = [arg0', arg1', arg2'] - pure [TypeClassDictionaryInScope [] 0 SymbolConsInstance [] C.SymbolCons args' Nothing] + pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolCons args' Nothing] solveSymbolCons _ = Nothing consSymbol :: Type -> Type -> Type -> Maybe (Type, Type, Type) @@ -428,7 +416,7 @@ entails SolverOptions{..} constraint context hints = solveUnion :: [Type] -> Maybe [TypeClassDict] solveUnion [l, r, u] = do (lOut, rOut, uOut, cst) <- unionRows l r u - pure [ TypeClassDictionaryInScope [] 0 UnionInstance [] C.RowUnion [lOut, rOut, uOut] cst ] + pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowUnion [lOut, rOut, uOut] cst ] solveUnion _ = Nothing -- | Left biased union of two row types @@ -455,13 +443,13 @@ entails SolverOptions{..} constraint context hints = solveRowCons :: [Type] -> Maybe [TypeClassDict] solveRowCons [TypeLevelString sym, ty, r, _] = - Just [ TypeClassDictionaryInScope [] 0 ConsInstance [] C.RowCons [TypeLevelString sym, ty, r, RCons (Label sym) ty r] Nothing ] + Just [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowCons [TypeLevelString sym, ty, r, RCons (Label sym) ty r] Nothing ] solveRowCons _ = Nothing solveRowToList :: [Type] -> Maybe [TypeClassDict] solveRowToList [r, _] = do entries <- rowToRowList r - pure [ TypeClassDictionaryInScope [] 0 RowToListInstance [] C.RowToList [r, entries] Nothing ] + pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowToList [r, entries] Nothing ] solveRowToList _ = Nothing -- | Convert a closed row to a sorted list of entries @@ -479,7 +467,7 @@ entails SolverOptions{..} constraint context hints = solveNub :: [Type] -> Maybe [TypeClassDict] solveNub [r, _] = do r' <- nubRows r - pure [ TypeClassDictionaryInScope [] 0 NubInstance [] C.RowNub [r, r'] Nothing ] + pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowNub [r, r'] Nothing ] solveNub _ = Nothing nubRows :: Type -> Maybe Type @@ -492,7 +480,7 @@ entails SolverOptions{..} constraint context hints = solveLacks :: [Type] -> Maybe [TypeClassDict] solveLacks [TypeLevelString sym, r] = do (r', cst) <- rowLacks sym r - pure [ TypeClassDictionaryInScope [] 0 LacksInstance [] C.RowLacks [TypeLevelString sym, r'] cst ] + pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowLacks [TypeLevelString sym, r'] cst ] solveLacks _ = Nothing rowLacks :: PSString -> Type -> Maybe (Type, Maybe [Constraint]) diff --git a/tests/purs/failing/LacksWithSubGoal.purs b/tests/purs/failing/LacksWithSubGoal.purs new file mode 100644 index 0000000000..40db3afd4f --- /dev/null +++ b/tests/purs/failing/LacksWithSubGoal.purs @@ -0,0 +1,16 @@ +-- @shouldFailWith NoInstanceFound +module LacksWithSubGoal where + +import Prim.Row (class Lacks) + +data S (r :: Symbol) = S + +data R (r :: # Type) = R + +union :: forall s r. Lacks s r => S s -> R r +union S = R + +example :: forall r. R (k :: Int | r) +example = union (S :: S "hello") + + From 4c8f5f4d0c57e3b8d2f6168578aa26c81017b3e5 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 28 Apr 2018 18:05:35 +0100 Subject: [PATCH 0985/1580] Ensure associativity error in type operators doesn't crash (#3337) --- src/Language/PureScript/Sugar/Operators.hs | 95 +++++++++---------- .../PureScript/Sugar/Operators/Types.hs | 10 +- .../3335-TypeOpAssociativityError.purs | 7 ++ 3 files changed, 58 insertions(+), 54 deletions(-) create mode 100644 tests/purs/failing/3335-TypeOpAssociativityError.purs diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index bbd6489d6a..2ca1b1f88a 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -133,17 +133,17 @@ rebracketFiltered pred_ externs modules = do (goDecl', goExpr', goBinder') = updateTypes goType (f', _, _, _, _) = everywhereWithContextOnValuesM - Nothing - (\_ d -> (Just (declSourceSpan d),) <$> goDecl' d) + ss + (\_ d -> (declSourceSpan d,) <$> goDecl' d) (\pos -> uncurry goExpr <=< goExpr' pos) (\pos -> uncurry goBinder <=< goBinder' pos) defS defS - goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) - goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) + goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr) + goExpr _ e@(PositionedValue pos _ _) = return (pos, e) goExpr _ (Op pos op) = - (Just pos, ) <$> case op `M.lookup` valueAliased of + (pos,) <$> case op `M.lookup` valueAliased of Just (Qualified mn' (Left alias)) -> return $ Var pos (Qualified mn' alias) Just (Qualified mn' (Right alias)) -> @@ -152,31 +152,28 @@ rebracketFiltered pred_ externs modules = do throwError . errorMessage' pos . UnknownName $ fmap ValOpName op goExpr pos other = return (pos, other) - goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) - goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b) + goBinder :: SourceSpan -> Binder -> m (SourceSpan, Binder) + goBinder _ b@(PositionedBinder pos _ _) = return (pos, b) goBinder _ (BinaryNoParensBinder (OpBinder pos op) lhs rhs) = case op `M.lookup` valueAliased of Just (Qualified mn' (Left alias)) -> throwError . errorMessage' pos $ InvalidOperatorInBinder op (Qualified mn' alias) Just (Qualified mn' (Right alias)) -> - return (Just pos, ConstructorBinder pos (Qualified mn' alias) [lhs, rhs]) + return (pos, ConstructorBinder pos (Qualified mn' alias) [lhs, rhs]) Nothing -> throwError . errorMessage' pos . UnknownName $ fmap ValOpName op goBinder _ BinaryNoParensBinder{} = internalError "BinaryNoParensBinder has no OpBinder" goBinder pos other = return (pos, other) - goType :: Maybe SourceSpan -> Type -> m Type - goType pos = maybe id rethrowWithPosition pos . go - where - go :: Type -> m Type - go (BinaryNoParensType (TypeOp op) lhs rhs) = - case op `M.lookup` typeAliased of - Just alias -> - return $ TypeApp (TypeApp (TypeConstructor alias) lhs) rhs - Nothing -> - throwError . errorMessage $ UnknownName $ fmap TyOpName op - go other = return other + goType :: SourceSpan -> Type -> m Type + goType pos (BinaryNoParensType (TypeOp op) lhs rhs) = + case op `M.lookup` typeAliased of + Just alias -> + return $ TypeApp (TypeApp (TypeConstructor alias) lhs) rhs + Nothing -> + throwError . errorMessage' pos $ UnknownName $ fmap TyOpName op + goType _ other = return other rebracketModule :: forall m @@ -194,19 +191,22 @@ rebracketModule pred_ valueOpTable typeOpTable (Module ss coms mn ds exts) = fmap (map (\d -> if pred_ d then removeParens d else d)) . flip parU (usingPredicate pred_ f) - (f, _, _) = - everywhereOnValuesTopDownM - goDecl - (matchExprOperators valueOpTable <=< decontextify goExpr') - (matchBinderOperators valueOpTable <=< decontextify goBinder') + (f, _, _, _, _) = + everywhereWithContextOnValuesM + ss + (\_ d -> (declSourceSpan d,) <$> goDecl d) + (\pos -> wrap (matchExprOperators valueOpTable) <=< goExpr' pos) + (\pos -> wrap (matchBinderOperators valueOpTable) <=< goBinder' pos) + defS + defS - (goDecl, goExpr', goBinder') = updateTypes (const goType) + (goDecl, goExpr', goBinder') = updateTypes goType - goType :: Type -> m Type - goType = matchTypeOperators typeOpTable + goType :: SourceSpan -> Type -> m Type + goType = flip matchTypeOperators typeOpTable - decontextify :: (Maybe SourceSpan -> a -> m (Maybe SourceSpan, a)) -> a -> m a - decontextify ctxf = fmap snd . ctxf Nothing + wrap :: (a -> m a) -> (SourceSpan, a) -> m (SourceSpan, a) + wrap go (ss', a) = (ss',) <$> go a removeParens :: Declaration -> Declaration removeParens = f @@ -232,10 +232,10 @@ removeParens = f goType t = t decontextify - :: (Maybe SourceSpan -> a -> Identity (Maybe SourceSpan, a)) + :: (SourceSpan -> a -> Identity (SourceSpan, a)) -> a -> a - decontextify ctxf = snd . runIdentity . ctxf Nothing + decontextify ctxf = snd . runIdentity . ctxf (internalError "attempted to use SourceSpan in removeParens") externsFixities :: ExternsFile -> [Either ValueFixityRecord TypeFixityRecord] externsFixities ExternsFile{..} = @@ -302,41 +302,38 @@ customOperatorTable fixities = updateTypes :: forall m . Monad m - => (Maybe SourceSpan -> Type -> m Type) + => (SourceSpan -> Type -> m Type) -> ( Declaration -> m Declaration - , Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) - , Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) + , SourceSpan -> Expr -> m (SourceSpan, Expr) + , SourceSpan -> Binder -> m (SourceSpan, Binder) ) updateTypes goType = (goDecl, goExpr, goBinder) where - goType' :: Maybe SourceSpan -> Type -> m Type + goType' :: SourceSpan -> Type -> m Type goType' = everywhereOnTypesTopDownM . goType - goType'' :: SourceSpan -> Type -> m Type - goType'' = goType' . Just - goDecl :: Declaration -> m Declaration goDecl (DataDeclaration sa@(ss, _) ddt name args dctors) = - DataDeclaration sa ddt name args <$> traverse (sndM (traverse (goType'' ss))) dctors + DataDeclaration sa ddt name args <$> traverse (sndM (traverse (goType' ss))) dctors goDecl (ExternDeclaration sa@(ss, _) name ty) = - ExternDeclaration sa name <$> goType'' ss ty + ExternDeclaration sa name <$> goType' ss ty goDecl (TypeClassDeclaration sa@(ss, _) name args implies deps decls) = do - implies' <- traverse (overConstraintArgs (traverse (goType'' ss))) implies + implies' <- traverse (overConstraintArgs (traverse (goType' ss))) implies return $ TypeClassDeclaration sa name args implies' deps decls goDecl (TypeInstanceDeclaration sa@(ss, _) ch idx name cs className tys impls) = do - cs' <- traverse (overConstraintArgs (traverse (goType'' ss))) cs - tys' <- traverse (goType'' ss) tys + cs' <- traverse (overConstraintArgs (traverse (goType' ss))) cs + tys' <- traverse (goType' ss) tys return $ TypeInstanceDeclaration sa ch idx name cs' className tys' impls goDecl (TypeSynonymDeclaration sa@(ss, _) name args ty) = - TypeSynonymDeclaration sa name args <$> goType'' ss ty + TypeSynonymDeclaration sa name args <$> goType' ss ty goDecl (TypeDeclaration (TypeDeclarationData sa@(ss, _) expr ty)) = - TypeDeclaration . TypeDeclarationData sa expr <$> goType'' ss ty + TypeDeclaration . TypeDeclarationData sa expr <$> goType' ss ty goDecl other = return other - goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) - goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) + goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr) + goExpr _ e@(PositionedValue pos _ _) = return (pos, e) goExpr pos (TypeClassDictionary (Constraint name tys info) dicts hints) = do tys' <- traverse (goType' pos) tys return (pos, TypeClassDictionary (Constraint name tys' info) dicts hints) @@ -348,8 +345,8 @@ updateTypes goType = (goDecl, goExpr, goBinder) return (pos, TypedValue check v ty') goExpr pos other = return (pos, other) - goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) - goBinder _ e@(PositionedBinder pos _ _) = return (Just pos, e) + goBinder :: SourceSpan -> Binder -> m (SourceSpan, Binder) + goBinder _ e@(PositionedBinder pos _ _) = return (pos, e) goBinder pos (TypedBinder ty b) = do ty' <- goType' pos ty return (pos, TypedBinder ty' b) diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs index 3c730651f9..5022a13cab 100644 --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -4,7 +4,6 @@ import Prelude.Compat import Control.Monad.Except import Language.PureScript.AST -import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Sugar.Operators.Common @@ -12,10 +11,11 @@ import Language.PureScript.Types matchTypeOperators :: MonadError MultipleErrors m - => [[(Qualified (OpName 'TypeOpName), Associativity)]] + => SourceSpan + -> [[(Qualified (OpName 'TypeOpName), Associativity)]] -> Type -> m Type -matchTypeOperators = matchOperators isBinOp extractOp fromOp reapply id +matchTypeOperators ss = matchOperators isBinOp extractOp fromOp reapply id where isBinOp :: Type -> Bool @@ -26,8 +26,8 @@ matchTypeOperators = matchOperators isBinOp extractOp fromOp reapply id extractOp (BinaryNoParensType op l r) = Just (op, l, r) extractOp _ = Nothing - fromOp :: Type -> Maybe (a, Qualified (OpName 'TypeOpName)) - fromOp (TypeOp q@(Qualified _ (OpName _))) = Just (internalError "tried to use type operator source span", q) + fromOp :: Type -> Maybe (SourceSpan, Qualified (OpName 'TypeOpName)) + fromOp (TypeOp q@(Qualified _ (OpName _))) = Just (ss, q) fromOp _ = Nothing reapply :: a -> Qualified (OpName 'TypeOpName) -> Type -> Type -> Type diff --git a/tests/purs/failing/3335-TypeOpAssociativityError.purs b/tests/purs/failing/3335-TypeOpAssociativityError.purs new file mode 100644 index 0000000000..1e104a0886 --- /dev/null +++ b/tests/purs/failing/3335-TypeOpAssociativityError.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith NonAssociativeError +module Main where + +infix 6 type Function as >> + +const :: forall a b. a >> b >> a +const a _ = a From a0059ea9e7a4d8e9b8a458bd6bc224594cf370e4 Mon Sep 17 00:00:00 2001 From: Stefan Fehrenbach Date: Sun, 29 Apr 2018 18:33:37 +0100 Subject: [PATCH 0986/1580] Add myself to CONTRIBUTORS.md (#3341) --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 7b1c853ec7..c786268230 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -45,6 +45,7 @@ If you would prefer to use different terms, please use the section below instead | [@erdeszt](https://github.com/erdeszt) | Tibor Erdesz | [MIT license](http://opensource.org/licenses/MIT) | | [@etrepum](https://github.com/etrepum) | Bob Ippolito | [MIT license](http://opensource.org/licenses/MIT) | | [@faineance](https://github.com/faineance) | faineance | [MIT license](http://opensource.org/licenses/MIT) | +| [@fehrenbach](https://github.com/fehrenbach) | Stefan Fehrenbach | [MIT license](http://opensource.org/licenses/MIT) | | [@felixSchl](https://github.com/felixSchl) | Felix Schlitter | [MIT license](http://opensource.org/licenses/MIT) | | [@FrigoEU](https://github.com/FrigoEU) | Simon Van Casteren | [MIT license](http://opensource.org/licenses/MIT) | | [@garyb](https://github.com/garyb) | Gary Burgess | [MIT license](http://opensource.org/licenses/MIT) | From 939f4bd2f145e243e57b267b439085aae87983f2 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 29 Apr 2018 21:05:30 +0100 Subject: [PATCH 0987/1580] Bump version for v0.12.0-rc1 (#3340) --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index f5bb8786ea..16c3f71004 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.11.7' +version: '0.12.0-rc1' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 8726c88b6e216ec6d80d2e0ceb85f33970624504 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 1 May 2018 20:08:48 +0100 Subject: [PATCH 0988/1580] Update CLI help for `purs docs` (#3343) --- app/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index dcc4a5e578..9073e0e8a7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -55,7 +55,7 @@ main = do (Opts.progDesc "Compile PureScript source files")) , Opts.command "docs" (Opts.info Docs.command - (Opts.progDesc "Generate Markdown documentation from PureScript source files" <> Docs.infoModList)) + (Opts.progDesc "Generate documentation from PureScript source files in a variety of formats, including Markdown and HTML" <> Docs.infoModList)) , Opts.command "hierarchy" (Opts.info Hierarchy.command (Opts.progDesc "Generate a GraphViz directed graph of PureScript type classes")) From dce646ae84e7eb1dc5d1d21410c0d0a593fb6283 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 1 May 2018 20:21:27 +0100 Subject: [PATCH 0989/1580] Add hint to run purs COMMAND --help for command specific help (#3344) --- app/Main.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 9073e0e8a7..1f5ec06ef9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -19,6 +19,7 @@ import Data.Monoid ((<>)) import qualified Options.Applicative as Opts import System.Environment (getArgs) import qualified System.IO as IO +import qualified Text.PrettyPrint.ANSI.Leijen as Doc import Version (versionString) @@ -32,7 +33,20 @@ main = do opts = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList infoModList = Opts.fullDesc <> headerInfo <> footerInfo headerInfo = Opts.progDesc "The PureScript compiler and tools" - footerInfo = Opts.footer $ "purs " ++ versionString + footerInfo = Opts.footerDoc (Just footer) + + footer = + mconcat + [ para $ + "For help using each individual command, run `purs COMMAND --help`. " ++ + "For example, `purs compile --help` displays options specific to the `compile` command." + , Doc.hardline + , Doc.hardline + , Doc.text $ "purs " ++ versionString + ] + + para :: String -> Doc.Doc + para = foldr (Doc.) Doc.empty . map Doc.text . words -- | Displays full command help when invoked with no arguments. execParserPure :: Opts.ParserInfo a -> [String] -> Opts.ParserResult a From 94c33e6ab5378aedf82cfcbf3326d0e6a7ff3734 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 1 May 2018 23:17:32 +0200 Subject: [PATCH 0990/1580] Added SourceSpan to CoreFn.Module (#3342) * Added SourceSpan to CoreFn.Module * Remove SourceSpan argument from It's now a duplicate, since `SourceSpan` was moved to `CoreFn.Module`. --- src/Language/PureScript/CodeGen/JS.hs | 2 +- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- src/Language/PureScript/CoreFn/FromJSON.hs | 12 +++-- src/Language/PureScript/CoreFn/Module.hs | 4 +- src/Language/PureScript/CoreFn/ToJSON.hs | 3 +- src/Language/PureScript/Ide/Rebuild.hs | 2 +- src/Language/PureScript/Make.hs | 2 +- src/Language/PureScript/Make/Actions.hs | 17 +++---- src/Language/PureScript/Renamer.hs | 2 +- tests/TestCoreFn.hs | 53 ++++++++++++---------- 10 files changed, 56 insertions(+), 43 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index d1afb4a58a..60204cebee 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -50,7 +50,7 @@ moduleToJs => Module Ann -> Maybe AST -> m [AST] -moduleToJs (Module coms mn _ imps exps foreigns decls) foreign_ = +moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 7851570e9d..c16c54f5ea 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -39,7 +39,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = exps' = ordNub $ concatMap exportToCoreFn exps externs = ordNub $ mapMaybe externToCoreFn decls decls' = concatMap declToCoreFn decls - in Module coms mn (spanName modSS) imports' exps' externs decls' + in Module modSS coms mn (spanName modSS) imports' exps' externs decls' where diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index f616a5ba3d..0cffaf2ec0 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -55,14 +55,15 @@ annFromJSON :: FilePath -> Value -> Parser Ann annFromJSON modulePath = withObject "Ann" annFromObj where annFromObj o = do - ss <- o .: "sourceSpan" >>= sourceSpanFromJSON + ss <- o .: "sourceSpan" >>= sourceSpanFromJSON modulePath mm <- o .: "meta" >>= metaFromJSON return (ss, [], Nothing, mm) - sourceSpanFromJSON = withObject "SourceSpan" $ \o -> - SourceSpan modulePath <$> - o .: "start" <*> - o .: "end" +sourceSpanFromJSON :: FilePath -> Value -> Parser SourceSpan +sourceSpanFromJSON modulePath = withObject "SourceSpan" $ \o -> + SourceSpan modulePath <$> + o .: "start" <*> + o .: "end" literalFromJSON :: (Value -> Parser a) -> Value -> Parser (Literal a) literalFromJSON t = withObject "Literal" literalFromObj @@ -112,6 +113,7 @@ moduleFromJSON = withObject "Module" moduleFromObj version <- o .: "builtWith" >>= versionFromJSON moduleName <- o .: "moduleName" >>= moduleNameFromJSON modulePath <- o .: "modulePath" + moduleSourceSpan <- o .: "sourceSpan" >>= sourceSpanFromJSON modulePath moduleImports <- o .: "imports" >>= listParser (importFromJSON modulePath) moduleExports <- o .: "exports" >>= listParser identFromJSON moduleDecls <- o .: "decls" >>= listParser (bindFromJSON modulePath) diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index cafa3ef10c..76559af759 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -2,6 +2,7 @@ module Language.PureScript.CoreFn.Module where import Prelude.Compat +import Language.PureScript.AST.SourcePos import Language.PureScript.Comments import Language.PureScript.CoreFn.Expr import Language.PureScript.Names @@ -13,7 +14,8 @@ import Language.PureScript.Names -- parsing it one gets back `ModuleT () Ann` rathern than `ModuleT Type Ann`, -- which is enough for `moduleToJs`. data Module a = Module - { moduleComments :: [Comment] + { moduleSourceSpan :: SourceSpan + , moduleComments :: [Comment] , moduleName :: ModuleName , modulePath :: FilePath , moduleImports :: [(a, ModuleName)] diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index c6084dda01..75e2d56db9 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -104,7 +104,8 @@ moduleNameToJSON (ModuleName pns) = toJSON $ properNameToJSON `map` pns moduleToJSON :: Version -> Module Ann -> Value moduleToJSON v m = object - [ T.pack "moduleName" .= moduleNameToJSON (moduleName m) + [ T.pack "sourceSpan" .= sourceSpanToJSON (moduleSourceSpan m) + , T.pack "moduleName" .= moduleNameToJSON (moduleName m) , T.pack "modulePath" .= toJSON (modulePath m) , T.pack "imports" .= map importToJSON (moduleImports m) , T.pack "exports" .= map identToJSON (moduleExports m) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 6604e2de33..c4f4b204a8 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -158,7 +158,7 @@ shushProgress ma _ = -- files though) shushCodegen :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make shushCodegen ma MakeActionsEnv{..} = - ma { P.codegen = \_ _ _ _ -> pure () } + ma { P.codegen = \_ _ _ -> pure () } -- | Returns a topologically sorted list of dependent ExternsFiles for the given -- module. Throws an error if there is a cyclic dependency within the diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 200f8abdc6..464d6672a8 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -75,7 +75,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do optimized = CF.optimizeCoreFn corefn [renamed] = renameInModules [optimized] exts = moduleToExternsFile mod' env' - evalSupplyT nextVar' . codegen ss renamed env' . encode $ exts + evalSupplyT nextVar' . codegen renamed env' . encode $ exts return exts -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.json@ file. diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 231c9e0ff8..254b83bd5e 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -94,7 +94,7 @@ data MakeActions m = MakeActions , readExterns :: ModuleName -> m (FilePath, Externs) -- ^ Read the externs file for a module as a string and also return the actual -- path for the file. - , codegen :: SourceSpan -> CF.Module CF.Ann -> Environment -> Externs -> SupplyT m () + , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m () -- ^ Run the code generator for the module and write any required output files. , progress :: ProgressMessage -> m () -- ^ Respond to a progress update. @@ -145,8 +145,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = let path = outputDir T.unpack (runModuleName mn) "externs.json" (path, ) <$> readTextFile path - codegen :: SourceSpan -> CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make () - codegen modSS m _ exts = do + codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make () + codegen m _ exts = do let mn = CF.moduleName m lift $ writeTextFile (outputFilename mn "externs.json") exts codegenTargets <- lift $ asks optionsCodegenTargets @@ -158,12 +158,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = foreignInclude <- case mn `M.lookup` foreigns of Just path | not $ requiresForeign m -> do - tell $ errorMessage' modSS $ UnnecessaryFFIModule mn path + tell $ errorMessage' (CF.moduleSourceSpan m) $ UnnecessaryFFIModule mn path return Nothing | otherwise -> do - checkForeignDecls modSS m path + checkForeignDecls m path return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign.js"] - Nothing | requiresForeign m -> throwError . errorMessage' modSS $ MissingFFIModule mn + Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn | otherwise -> return Nothing rawJs <- J.moduleToJs m foreignInclude dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory @@ -227,8 +227,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = -- | Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module. -checkForeignDecls :: SourceSpan -> CF.Module ann -> FilePath -> SupplyT Make () -checkForeignDecls modSS m path = do +checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make () +checkForeignDecls m path = do jsStr <- lift $ readTextFile path js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse (BU8.toString (B.toStrict jsStr)) path @@ -251,6 +251,7 @@ checkForeignDecls modSS m path = do where mname = CF.moduleName m + modSS = CF.moduleSourceSpan m errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a errorParsingModule = throwError . errorMessage' modSS . ErrorParsingFFIModule path . Just diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index 19dad5d08c..b99cd9d2ae 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -110,7 +110,7 @@ renameInModules :: [Module Ann] -> [Module Ann] renameInModules = map go where go :: Module Ann -> Module Ann - go m@(Module _ _ _ _ _ _ decls) = m { moduleDecls = map (renameInDecl' (findDeclIdents decls)) decls } + go m@(Module _ _ _ _ _ _ _ decls) = m { moduleDecls = map (renameInDecl' (findDeclIdents decls)) decls } renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann renameInDecl' scope = runRename scope . renameInDecl True diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index 3f6972b126..7c2722038a 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -48,35 +48,42 @@ spec = context "CoreFnFromJsonTest" $ do ann = ssAnn ss specify "should parse an empty module" $ do - let r = parseMod $ Module [] mn mp [] [] [] [] + let r = parseMod $ Module ss [] mn mp [] [] [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () Success m -> moduleName m `shouldBe` mn + specify "should parse source span" $ do + let r = parseMod $ Module ss [] mn mp [] [] [] [] + r `shouldSatisfy` isSuccess + case r of + Error _ -> return () + Success m -> moduleSourceSpan m `shouldBe` ss + specify "should parse module path" $ do - let r = parseMod $ Module [] mn mp [] [] [] [] + let r = parseMod $ Module ss [] mn mp [] [] [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () Success m -> modulePath m `shouldBe` mp specify "should parse imports" $ do - let r = parseMod $ Module [] mn mp [(ann, mn)] [] [] [] + let r = parseMod $ Module ss [] mn mp [(ann, mn)] [] [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () Success m -> moduleImports m `shouldBe` [(ann, mn)] specify "should parse exports" $ do - let r = parseMod $ Module [] mn mp [] [Ident "exp"] [] [] + let r = parseMod $ Module ss [] mn mp [] [Ident "exp"] [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () Success m -> moduleExports m `shouldBe` [Ident "exp"] specify "should parse foreign" $ do - let r = parseMod $ Module [] mn mp [] [] [Ident "exp"] [] + let r = parseMod $ Module ss [] mn mp [] [] [Ident "exp"] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () @@ -84,7 +91,7 @@ spec = context "CoreFnFromJsonTest" $ do context "Expr" $ do specify "should parse literals" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec ann (Ident "x1") $ Literal ann (NumericLiteral (Left 1)) , NonRec ann (Ident "x2") $ Literal ann (NumericLiteral (Right 1.0)) , NonRec ann (Ident "x3") $ Literal ann (StringLiteral (mkString "abc")) @@ -96,18 +103,18 @@ spec = context "CoreFnFromJsonTest" $ do parseMod m `shouldSatisfy` isSuccess specify "should parse Constructor" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec ann (Ident "constructor") $ Constructor ann (ProperName "Either") (ProperName "Left") [Ident "value0"] ] parseMod m `shouldSatisfy` isSuccess specify "should parse Accessor" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec ann (Ident "x") $ Accessor ann (mkString "field") (Literal ann $ ObjectLiteral [(mkString "field", Literal ann (NumericLiteral (Left 1)))]) ] parseMod m `shouldSatisfy` isSuccess specify "should parse ObjectUpdate" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec ann (Ident "objectUpdate") $ ObjectUpdate ann (Literal ann $ ObjectLiteral [(mkString "field", Literal ann (StringLiteral (mkString "abc")))]) @@ -116,14 +123,14 @@ spec = context "CoreFnFromJsonTest" $ do parseMod m `shouldSatisfy` isSuccess specify "should parse Abs" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec ann (Ident "abs") $ Abs ann (Ident "x") (Var ann (Qualified (Just mn) (Ident "x"))) ] parseMod m `shouldSatisfy` isSuccess specify "should parse App" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec ann (Ident "app") $ App ann (Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "x")))) @@ -132,7 +139,7 @@ spec = context "CoreFnFromJsonTest" $ do parseMod m `shouldSatisfy` isSuccess specify "should parse Case" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec ann (Ident "case") $ Case ann [Var ann (Qualified Nothing (Ident "x"))] [ CaseAlternative @@ -143,7 +150,7 @@ spec = context "CoreFnFromJsonTest" $ do parseMod m `shouldSatisfy` isSuccess specify "should parse Case with guards" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec ann (Ident "case") $ Case ann [Var ann (Qualified Nothing (Ident "x"))] [ CaseAlternative @@ -154,7 +161,7 @@ spec = context "CoreFnFromJsonTest" $ do parseMod m `shouldSatisfy` isSuccess specify "should parse Let" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec ann (Ident "case") $ Let ann [ Rec [((ann, Ident "a"), Var ann (Qualified Nothing (Ident "x")))] ] @@ -164,28 +171,28 @@ spec = context "CoreFnFromJsonTest" $ do context "Meta" $ do specify "should parse IsConstructor" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec (ss, [], Nothing, Just (IsConstructor ProductType [Ident "x"])) (Ident "x") $ Literal (ss, [], Nothing, Just (IsConstructor SumType [])) (CharLiteral 'a') ] parseMod m `shouldSatisfy` isSuccess specify "should parse IsNewtype" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec (ss, [], Nothing, Just IsNewtype) (Ident "x") $ Literal ann (CharLiteral 'a') ] parseMod m `shouldSatisfy` isSuccess specify "should parse IsTypeClassConstructor" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec (ss, [], Nothing, Just IsTypeClassConstructor) (Ident "x") $ Literal ann (CharLiteral 'a') ] parseMod m `shouldSatisfy` isSuccess specify "should parse IsForeign" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec (ss, [], Nothing, Just IsForeign) (Ident "x") $ Literal ann (CharLiteral 'a') ] @@ -193,7 +200,7 @@ spec = context "CoreFnFromJsonTest" $ do context "Binders" $ do specify "should parse LiteralBinder" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec ann (Ident "case") $ Case ann [Var ann (Qualified Nothing (Ident "x"))] [ CaseAlternative @@ -204,7 +211,7 @@ spec = context "CoreFnFromJsonTest" $ do parseMod m `shouldSatisfy` isSuccess specify "should parse VarBinder" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec ann (Ident "case") $ Case ann [Var ann (Qualified Nothing (Ident "x"))] [ CaseAlternative @@ -220,7 +227,7 @@ spec = context "CoreFnFromJsonTest" $ do parseMod m `shouldSatisfy` isSuccess specify "should parse NamedBinder" $ do - let m = Module [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] [] [ NonRec ann (Ident "case") $ Case ann [Var ann (Qualified Nothing (Ident "x"))] [ CaseAlternative @@ -232,9 +239,9 @@ spec = context "CoreFnFromJsonTest" $ do context "Comments" $ do specify "should parse LineComment" $ do - let m = Module [ LineComment "line" ] mn mp [] [] [] [] + let m = Module ss [ LineComment "line" ] mn mp [] [] [] [] parseMod m `shouldSatisfy` isSuccess specify "should parse BlockComment" $ do - let m = Module [ BlockComment "block" ] mn mp [] [] [] [] + let m = Module ss [ BlockComment "block" ] mn mp [] [] [] [] parseMod m `shouldSatisfy` isSuccess From fd12438d2a03a0a10c18c5e119a20f1784a7998f Mon Sep 17 00:00:00 2001 From: Alex Berg Date: Wed, 2 May 2018 14:18:00 -0500 Subject: [PATCH 0991/1580] Add myself to Contributors (#3346) --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index c786268230..78a5abc8ee 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -32,6 +32,7 @@ If you would prefer to use different terms, please use the section below instead | [@brandonhamilton](https://github.com/brandonhamilton) | Brandon Hamilton | [MIT license](http://opensource.org/licenses/MIT) | | [@bsermons](https://github.com/bsermons) | Brian Sermons | [MIT license](http://opensource.org/licenses/MIT) | | [@cdepillabout](https://github.com/cdepillabout) | Dennis Gosnell | [MIT license](http://opensource.org/licenses/MIT) | +| [@chexxor](https://github.com/chexxor) | Alex Berg | [MIT license](http://opensource.org/licenses/MIT) | | [@chrisdone](https://github.com/chrisdone) | Chris Done | MIT license | | [@cmdv](https://github.com/cmdv) | Vincent Orr | MIT license | | [@codedmart](https://github.com/codedmart) | Brandon Martin | [MIT license](http://opensource.org/licenses/MIT) | From 46a5449cb860008ff3b4048a0446415c285eef17 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 4 May 2018 20:24:53 +0100 Subject: [PATCH 0992/1580] Fix handling of Prim submodules with docs (#3349) Fixes #3347 This commit mainly consists of re-export handling so `purs docs` doesn't choke on modules which re-export things from submodules of Prim. It also fixes an issue with the builtin Prim docs which meant that the RowToList class was being considered a type, leading to incorrect information in the rendered HTML docs, as well as internal errors in certain situations. Finally, we fix handling of links to Prim submodules, ensuring that all builtin modules are actually considered builtin, not just Prim. This has no effect on `purs docs` but it will affect Pursuit, once we get around to updating it. This commit also adds a test which ensures that generating docs for a module which re-exports things from Prim works. --- app/Command/Docs.hs | 2 +- src/Language/PureScript/Docs/Convert.hs | 26 ++++++++++++++++--- .../PureScript/Docs/Convert/ReExports.hs | 17 ++++++++++-- src/Language/PureScript/Docs/Prim.hs | 2 +- src/Language/PureScript/Docs/Types.hs | 14 +++++----- src/Language/PureScript/Make.hs | 14 +++++----- src/Language/PureScript/Names.hs | 4 +++ src/Language/PureScript/Sugar/Names.hs | 1 + tests/purs/docs/src/PrimSubmodules.purs | 11 ++++++++ 9 files changed, 69 insertions(+), 22 deletions(-) create mode 100644 tests/purs/docs/src/PrimSubmodules.purs diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index 1a4841f094..048cb646d2 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -62,7 +62,7 @@ docgen (PSCDocsOptions fmt inputGlob output) = do Ctags -> mapM_ putStrLn $ dumpCtags fileMs Html -> do let outputDir = "./generated-docs" -- TODO: make this configurable - let msHtml = map asHtml (D.primDocsModule : ms) + let msHtml = map asHtml (D.primModules ++ ms) createDirectoryIfMissing False outputDir writeHtmlModules outputDir msHtml diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index af3cf067cd..be6db2f908 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -19,6 +19,7 @@ import Data.String (String) import Language.PureScript.Docs.Convert.ReExports (updateReExports) import Language.PureScript.Docs.Convert.Single (convertSingleModule) +import Language.PureScript.Docs.Prim (primModules) import Language.PureScript.Docs.Types import qualified Language.PureScript as P @@ -74,7 +75,9 @@ convertModulesInPackageWithEnv modules modulesDeps = where go = convertModulesWithEnv withPackage - >>> fmap (first (filter (isLocal . modName))) + >>> fmap (first (filter (shouldKeep . modName))) + + shouldKeep mn = isLocal mn && not (P.isBuiltinModuleName mn) withPackage :: P.ModuleName -> InPackage P.ModuleName withPackage mn = @@ -128,10 +131,25 @@ convertSorted withPackage modules = do (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules modulesWithTypes <- typeCheckIfNecessary modules convertedModules - let moduleMap = Map.fromList (map (modName &&& identity) modulesWithTypes) - let traversalOrder = map P.getModuleName modules - pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap), env) + -- We add the Prim docs modules here, so that docs generation is still + -- possible if the modules we are generating docs for re-export things from + -- Prim submodules. Note that the Prim modules do not exist as + -- @Language.PureScript.Module@ values because they do not contain anything + -- that exists at runtime. However, we have pre-constructed + -- @Language.PureScript.Docs.Types.Module@ values for them, which we use + -- here. + let moduleMap = + Map.fromList + (map (modName &&& identity) + (modulesWithTypes ++ primModules)) + + -- Set up the traversal order for re-export handling so that Prim modules + -- come first. + let primModuleNames = Map.keys P.primEnv + let traversalOrder = primModuleNames ++ map P.getModuleName modules + let withReExports = updateReExports env traversalOrder withPackage moduleMap + pure (Map.elems withReExports, env) -- | -- If any exported value declarations have either wildcard type signatures, or diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 370a4bad61..4d48cb14dd 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -182,6 +182,12 @@ findImport imps (name, orig) = -- and B). In this case, we just take its first appearance. (importedFrom:_) -> pure (importedFrom, name) + + -- Builtin modules do not have any Imports in the Env, and therefore must + -- be handled specially here. + [] | P.isBuiltinModuleName orig -> + pure (orig, name) + [] -> internalErrorInModule ("findImport: not found: " ++ show (name, orig)) @@ -269,9 +275,15 @@ lookupTypeDeclaration importedFrom ty = do case ds of [d] -> pure (importedFrom, [d]) + [] | P.isBuiltinModuleName importedFrom -> + -- Type classes in builtin modules (i.e. submodules of Prim) also have + -- corresponding pseudo-types in the primEnv, but since these are an + -- implementation detail they do not exist in the Modules, and hence in + -- this case, `ds` will be empty. + pure (importedFrom, []) other -> internalErrorInModule - ("lookupTypeDeclaration: unexpected result: " ++ show other) + ("lookupTypeDeclaration: unexpected result for " ++ show ty ++ ": " ++ show other) lookupTypeOpDeclaration :: (MonadState (Map P.ModuleName Module) m,MonadReader P.ModuleName m) @@ -305,7 +317,8 @@ lookupTypeClassDeclaration importedFrom tyClass = do pure (importedFrom, [d]) other -> internalErrorInModule - ("lookupTypeClassDeclaration: unexpected result: " + ("lookupTypeClassDeclaration: unexpected result for " + ++ show tyClass ++ ": " ++ (unlines . map show) other) lookupKindDeclaration diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 79889d53ea..ed16e734af 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -394,7 +394,7 @@ rowListNil = primTypeOf (P.primSubName "RowList") "Nil" $ T.unlines ] rowToList :: Declaration -rowToList = primTypeOf (P.primSubName "RowList") "RowToList" $ T.unlines +rowToList = primClassOf (P.primSubName "RowList") "RowToList" $ T.unlines [ "Compiler solved type class for generating a `RowList` from a closed row" , "of types. Entries are sorted by label and duplicates are preserved in" , "the order they appeared in the row." diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index b53f92ba30..9bba522362 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -425,7 +425,8 @@ data LinkLocation -- | A link to a declaration that is built in to the compiler, e.g. the Prim -- module. In this case we only need to store the module that the builtin - -- comes from (at the time of writing, this will only ever be "Prim"). + -- comes from. Note that all builtin modules begin with "Prim", and that the + -- compiler rejects attempts to define modules whose names start with "Prim". | BuiltinModule P.ModuleName deriving (Show, Eq, Ord, Generic) @@ -458,11 +459,12 @@ getLink LinksContext{..} curMn namespace target containingMod = do pkgVersion <- lookup pkgName ctxResolvedDependencies return $ DepsModule curMn pkgName pkgVersion destMn - builtinLinkLocation = do - let primMn = P.moduleNameFromString "Prim" - guard $ containingMod == OtherModule primMn - -- TODO: ensure the declaration exists in the builtin module too - return $ BuiltinModule primMn + builtinLinkLocation = + case containingMod of + OtherModule mn | P.isBuiltinModuleName mn -> + pure $ BuiltinModule mn + _ -> + empty getLinksContext :: Package a -> LinksContext getLinksContext Package{..} = diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 464d6672a8..112ddbdf13 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -119,14 +119,12 @@ make ma@MakeActions{..} ms = do checkNoPrim :: m () checkNoPrim = - for_ ms $ \m -> do - case getModuleName m of - mn@(ModuleName (ProperName "Prim" : _)) -> - throwError - . errorMessage' (getModuleSourceSpan m) - $ CannotDefinePrimModules mn - _ -> - pure () + for_ ms $ \m -> + let mn = getModuleName m + in when (isBuiltinModuleName mn) $ + throwError + . errorMessage' (getModuleSourceSpan m) + $ CannotDefinePrimModules mn checkModuleNamesAreUnique :: m () checkModuleNamesAreUnique = diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 1df6c12c42..16f135f221 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -177,6 +177,10 @@ moduleNameFromString = ModuleName . splitProperNames s' -> ProperName w : splitProperNames s'' where (w, s'') = T.break (== '.') s' +isBuiltinModuleName :: ModuleName -> Bool +isBuiltinModuleName (ModuleName (ProperName "Prim" : _)) = True +isBuiltinModuleName _ = False + -- | -- A qualified name, i.e. a name with an optional module name -- diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 473ec9970a..afa770f2c7 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -2,6 +2,7 @@ module Language.PureScript.Sugar.Names ( desugarImports , desugarImportsWithEnv , Env + , primEnv , ImportRecord(..) , ImportProvenance(..) , Imports(..) diff --git a/tests/purs/docs/src/PrimSubmodules.purs b/tests/purs/docs/src/PrimSubmodules.purs new file mode 100644 index 0000000000..ee3c4fdec0 --- /dev/null +++ b/tests/purs/docs/src/PrimSubmodules.purs @@ -0,0 +1,11 @@ +module PrimSubmodules (Lol(..), x, y, module O) where + +import Prim.Ordering (kind Ordering, LT, EQ, GT) as O + +data Lol (a :: O.Ordering) = Lol Int + +x :: Lol O.LT +x = Lol 0 + +y :: Lol O.EQ +y = Lol 1 From e2cba664ff44a2ade66f7e9ad2764e31cd0d8d7c Mon Sep 17 00:00:00 2001 From: Alex Berg Date: Mon, 7 May 2018 04:40:30 -0500 Subject: [PATCH 0993/1580] Explain --editor-mode intent (#3350) * Explain --editor-mode intent * source files -> externs files --- psc-ide/README.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/psc-ide/README.md b/psc-ide/README.md index b48efb852a..bd05fcdc7c 100644 --- a/psc-ide/README.md +++ b/psc-ide/README.md @@ -27,7 +27,8 @@ It supports the following options: files. This flag is reversed on Windows and polling is the default. - `--log-level`: Can be set to one of "all", "none", "debug" and "perf" - `--no-watch`: Disables the filewatcher -- `--editor-mode`: Only reload on source file changes reported by the editor +- `--editor-mode`: Rather than watch externs files, expect an editor to report + changed source files. - `--version`: Output psc-ide version ## Issuing queries From df07500eca1f0a538474faacba018fafcf1756a4 Mon Sep 17 00:00:00 2001 From: Hardy Jones Date: Mon, 7 May 2018 02:50:30 -0700 Subject: [PATCH 0994/1580] Add arities to `IncorrectConstructorArity` (#3354) * Add arities to `IncorrectConstructorArity` We can carry along the arity we expect and what we get. Then, we provide an error message that tells not only the problem, but also how to fix the problem. * Use `SourceSpan` for error message We want the position of the error message with the error. This should help find where the problem is. --- src/Language/PureScript/AST/Declarations.hs | 3 ++- src/Language/PureScript/Errors.hs | 6 ++++-- src/Language/PureScript/TypeChecker/Types.hs | 4 +++- 3 files changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index e5b223e9e9..9c820071dc 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -127,7 +127,8 @@ data SimpleErrorMessage | MissingClassMember Ident | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName)) | ExpectedType Type Kind - | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName)) + -- | constructor name, expected argument count, actual argument count + | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName)) Int Int | ExprDoesNotHaveType Expr Type | PropertyIsMissing Label | AdditionalProperty Label diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index e65d0214f7..135f98aa2f 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -765,8 +765,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , indent $ line $ markCode $ prettyPrintKind kind , line "instead." ] - renderSimpleErrorMessage (IncorrectConstructorArity nm) = - line $ "Data constructor " <> markCode (showQualified runProperName nm) <> " was given the wrong number of arguments in a case expression." + renderSimpleErrorMessage (IncorrectConstructorArity nm expected actual) = + paras [ line $ "Data constructor " <> markCode (showQualified runProperName nm) <> " was given " <> T.pack (show actual) <> " arguments in a case expression, but expected " <> T.pack (show expected) <> " arguments." + , line $ "This problem can be fixed by giving " <> markCode (showQualified runProperName nm) <> " " <> T.pack (show expected) <> " arguments." + ] renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) = paras [ line "Expression" , markCodeBox $ indent $ prettyPrintValue valueDepth expr diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 6b402391fe..920d159a6b 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -477,7 +477,9 @@ inferBinder val (ConstructorBinder ss ctor binders) = do (_, fn) <- instantiatePolyTypeWithUnknowns (internalError "Data constructor types cannot contain constraints") ty fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn let (args, ret) = peelArgs fn' - unless (length args == length binders) . throwError . errorMessage $ IncorrectConstructorArity ctor + expected = length args + actual = length binders + unless (expected == actual) . throwError . errorMessage' ss $ IncorrectConstructorArity ctor expected actual unifyTypes ret val M.unions <$> zipWithM inferBinder (reverse args) binders _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor From 3847ae00492b73ea2c0761758361ab5b507d0739 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Wed, 9 May 2018 00:35:47 +0200 Subject: [PATCH 0995/1580] [purs ide] Removes Pursuit commands (#3355) * [purs ide] Removes Pursuit support * Update to LTS 11 * [purs ide] removes pursuit command from PROTOCOL --- package.yaml | 7 +-- psc-ide/PROTOCOL.md | 46 -------------- src/Language/PureScript/CoreFn/Optimizer.hs | 2 +- src/Language/PureScript/Ide.hs | 15 ----- src/Language/PureScript/Ide/Command.hs | 10 --- src/Language/PureScript/Ide/Pursuit.hs | 69 --------------------- src/Language/PureScript/Ide/Types.hs | 57 ----------------- stack.yaml | 4 +- 8 files changed, 4 insertions(+), 206 deletions(-) delete mode 100644 src/Language/PureScript/Ide/Pursuit.hs diff --git a/package.yaml b/package.yaml index 16c3f71004..c3d4511f2f 100644 --- a/package.yaml +++ b/package.yaml @@ -34,7 +34,7 @@ extra-source-files: dependencies: - aeson >=1.0 && <1.3 - aeson-better-errors >=0.8 - - ansi-terminal >=0.7.1 && <0.8 + - ansi-terminal >=0.7.1 && <0.9 - base >=4.8 && <4.11 - base-compat >=0.6.0 - blaze-html >=0.8.1 && <0.10 @@ -54,8 +54,6 @@ dependencies: - fsnotify >=0.2.1 - Glob >=0.9 && <0.10 - haskeline >=0.7.0.0 - - http-client >=0.4.30 && <0.6.0 - - http-types - language-javascript >=0.6.0.9 && <0.7 - lens ==4.* - lifted-base >=0.2.3 && <0.2.4 @@ -65,8 +63,6 @@ dependencies: - parallel >=3.2 && <3.3 - parsec >=3.1.10 - pattern-arrows >=0.0.2 && <0.1 - - pipes >=4.0.0 && <4.4.0 - - pipes-http - process >=1.2.0 && <1.7 - protolude >=0.1.6 - regex-tdfa @@ -131,6 +127,7 @@ executables: dependencies: - ansi-wl-pprint - file-embed + - http-types - network - optparse-applicative >=0.13.0 - purescript diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index 2c7b6c2f8f..58d73fd121 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -389,52 +389,6 @@ In the Success case you get a list of warnings in the compilers json format. In the Error case you get the errors in the compilers json format -### Pursuit -The `pursuit` command looks up the packages/completions for a given identifier from Pursuit. - -**Params:** - - `query :: String`: With `type: "package"` this should be a module name. With - `type: "completion"` this can be any string to look up. - - `type :: String`: Takes the following values: - - `package`: Looks for packages that contain the given module name. - - `completion` Looks for declarations for the query from Pursuit. - -```json -{ - "command": "pursuit", - "params": { - "query": "Data.Array", - "type": "package" - } -} -``` - -**Result:** - -`package` returns: - -```json -[ - { - "module": "Module1.Name", - "package": "purescript-packagename" - } -] -``` - -`completion` returns: - -```json -[ - { - "module": "Data.Array", - "identifier": "filter", - "type": "forall a. (a -> Boolean) -> Array a -> Array a", - "package": "purescript-arrays" - } -] -``` - ### List #### Loaded Modules diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 9573e1623a..5adeeb9e90 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -1,6 +1,6 @@ module Language.PureScript.CoreFn.Optimizer (optimizeCoreFn) where -import Protolude +import Protolude hiding (Type) import Data.List (lookup) import Language.PureScript.AST.Literals diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 3a86d64352..5483f2a179 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -33,7 +33,6 @@ import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Imports hiding (Import) import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Prim -import Language.PureScript.Ide.Pursuit import Language.PureScript.Ide.Rebuild import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.State @@ -63,10 +62,6 @@ handleCommand c = case c of findType search filters currentModule Complete filters matcher currentModule complOptions -> findCompletions filters matcher currentModule complOptions - Pursuit query Package -> - findPursuitPackages query - Pursuit query Identifier -> - findPursuitCompletions query List LoadedModules -> printModules List AvailableModules -> @@ -129,16 +124,6 @@ findType search filters currentModule = do let insertPrim = (++) idePrimDeclarations pure (CompletionResult (getExactCompletions search filters (insertPrim modules))) -findPursuitCompletions :: MonadIO m => - PursuitQuery -> m Success -findPursuitCompletions (PursuitQuery q) = - PursuitResult <$> liftIO (searchPursuitForDeclarations q) - -findPursuitPackages :: MonadIO m => - PursuitQuery -> m Success -findPursuitPackages (PursuitQuery q) = - PursuitResult <$> liftIO (findPackagesForModuleIdent q) - printModules :: Ide m => m Success printModules = ModuleList . map P.runModuleName <$> getLoadedModulenames diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 5541814f50..233d8b336f 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -38,10 +38,6 @@ data Command , completeCurrentModule :: Maybe P.ModuleName , completeOptions :: CompletionOptions } - | Pursuit - { pursuitQuery :: PursuitQuery - , pursuitSearchType :: PursuitSearchType - } | CaseSplit { caseSplitLine :: Text , caseSplitBegin :: Int @@ -73,7 +69,6 @@ commandName c = case c of LoadSync{} -> "LoadSync" Type{} -> "Type" Complete{} -> "Complete" - Pursuit{} -> "Pursuit" CaseSplit{} -> "CaseSplit" AddClause{} -> "AddClause" FindUsages{} -> "FindUsages" @@ -146,11 +141,6 @@ instance FromJSON Command where <*> params .:? "matcher" .!= mempty <*> (fmap P.moduleNameFromString <$> params .:? "currentModule") <*> params .:? "options" .!= defaultCompletionOptions - "pursuit" -> do - params <- o .: "params" - Pursuit - <$> params .: "query" - <*> params .: "type" "caseSplit" -> do params <- o .: "params" CaseSplit diff --git a/src/Language/PureScript/Ide/Pursuit.hs b/src/Language/PureScript/Ide/Pursuit.hs deleted file mode 100644 index fd828b8c38..0000000000 --- a/src/Language/PureScript/Ide/Pursuit.hs +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Ide.Pursuit --- Description : Pursuit client for psc-ide --- Copyright : Christoph Hegemann 2016 --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Christoph Hegemann --- Stability : experimental --- --- | --- Pursuit client for psc-ide ------------------------------------------------------------------------------ - -module Language.PureScript.Ide.Pursuit - ( searchPursuitForDeclarations - , findPackagesForModuleIdent - ) where - -import Protolude hiding (fromStrict) - -import qualified Control.Exception as E -import Data.Aeson -import Data.ByteString.Lazy (fromStrict) -import Data.String -import qualified Data.Text as T -import Language.PureScript.Ide.Types -import Network.HTTP.Types.Header (hAccept) -import Pipes.HTTP -import qualified Pipes.Prelude as P - -queryPursuit :: Text -> IO ByteString -queryPursuit q = do - req' <- parseRequest "https://pursuit.purescript.org/search" - let req = req' - { queryString= "q=" <> (fromString . T.unpack) q - , requestHeaders=[(hAccept, "application/json")] - } - m <- newManager tlsManagerSettings - withHTTP req m $ \resp -> - P.fold (<>) "" identity (responseBody resp) - - -handler :: HttpException -> IO [a] -handler _ = pure [] - -searchPursuitForDeclarations :: Text -> IO [PursuitResponse] -searchPursuitForDeclarations query = - (do r <- queryPursuit query - let results' = decode (fromStrict r) :: Maybe Array - case results' of - Nothing -> pure [] - Just results -> pure (mapMaybe (isDeclarationResponse . fromJSON) (toList results))) `E.catch` - handler - where - isDeclarationResponse (Success a@DeclarationResponse{}) = Just a - isDeclarationResponse _ = Nothing - -findPackagesForModuleIdent :: Text -> IO [PursuitResponse] -findPackagesForModuleIdent query = - (do r <- queryPursuit query - let results' = decode (fromStrict r) :: Maybe Array - case results' of - Nothing -> pure [] - Just results -> pure (mapMaybe (isModuleResponse . fromJSON) (toList results))) `E.catch` - handler - where - isModuleResponse (Success a@ModuleResponse{}) = Just a - isModuleResponse _ = Nothing diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 8a6a388c7e..585b59ee9e 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -226,7 +226,6 @@ data Success = | TextResult Text | UsagesResult [P.SourceSpan] | MultilineTextResult [Text] - | PursuitResult [PursuitResponse] | ImportList (P.ModuleName, [(P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)]) | ModuleList [ModuleIdent] | RebuildSuccess P.MultipleErrors @@ -241,7 +240,6 @@ instance ToJSON Success where toJSON (TextResult t) = encodeSuccess t toJSON (UsagesResult ssp) = encodeSuccess ssp toJSON (MultilineTextResult ts) = encodeSuccess ts - toJSON (PursuitResult resp) = encodeSuccess resp toJSON (ImportList (moduleName, imports)) = object [ "resultType" .= ("success" :: Text) , "result" .= object [ "imports" .= map encodeImport imports , "moduleName" .= P.runModuleName moduleName]] @@ -265,61 +263,6 @@ encodeImport (P.runModuleName -> mn, importType, map P.runModuleName -> qualifie , "identifiers" .= (identifierFromDeclarationRef <$> refs) ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) -newtype PursuitQuery = PursuitQuery Text - deriving (Show, Eq) - -data PursuitSearchType = Package | Identifier - deriving (Show, Eq) - -instance FromJSON PursuitSearchType where - parseJSON (String t) = case t of - "package" -> pure Package - "completion" -> pure Identifier - _ -> mzero - parseJSON _ = mzero - -instance FromJSON PursuitQuery where - parseJSON o = PursuitQuery <$> parseJSON o - -data PursuitResponse = - -- | A Pursuit Response for a module. Consists of the modules name and the - -- package it belongs to - ModuleResponse ModuleIdent Text - -- | A Pursuit Response for a declaration. Consist of the declaration's - -- module, name, package, type summary text - | DeclarationResponse Text ModuleIdent Text (Maybe Text) Text - deriving (Show,Eq) - -instance FromJSON PursuitResponse where - parseJSON (Object o) = do - package <- o .: "package" - info <- o .: "info" - (type' :: Text) <- info .: "type" - case type' of - "module" -> do - name <- info .: "module" - pure (ModuleResponse name package) - "declaration" -> do - moduleName <- info .: "module" - ident <- info .: "title" - (text :: Text) <- o .: "text" - typ <- info .:? "typeText" - pure (DeclarationResponse moduleName ident package typ text) - _ -> mzero - parseJSON _ = mzero - -instance ToJSON PursuitResponse where - toJSON (ModuleResponse name package) = - object ["module" .= name, "package" .= package] - toJSON (DeclarationResponse module' ident package type' text) = - object - [ "module" .= module' - , "ident" .= ident - , "type" .= type' - , "package" .= package - , "text" .= text - ] - -- | Denotes the different namespaces a name in PureScript can reside in. data IdeNamespace = IdeNSValue | IdeNSType | IdeNSKind deriving (Show, Eq, Ord, Generic, NFData) diff --git a/stack.yaml b/stack.yaml index e15349401f..54c5cf306b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,4 @@ -resolver: lts-10.3 +resolver: lts-11.7 packages: - '.' extra-deps: -- pipes-http-1.0.5 -- Win32-notify-0.3.0.3 From 792bb7fa183a87fb4f9bfacfccdaacced02b917f Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 8 May 2018 23:49:51 +0100 Subject: [PATCH 0996/1580] Update INSTALL.md and bundle/README for 0.12 (#3357) --- INSTALL.md | 10 ++++------ bundle/README | 15 +++------------ 2 files changed, 7 insertions(+), 18 deletions(-) diff --git a/INSTALL.md b/INSTALL.md index bf42c749e3..9d729f9489 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -6,16 +6,14 @@ alternatively Stack Overflow. ## Using prebuilt binaries -The prebuilt binaries are compiled with GHC 8.0.2 and therefore they should -run on any operating system supported by GHC 8.0.2, such as: +The prebuilt binaries are compiled with GHC 8.2.2 and therefore they should +run on any operating system supported by GHC 8.2.2, such as: * Windows Vista or later, * OS X 10.7 or later, -* Linux ??? (we're not sure what the minimum version is). +* Linux ??? (we're not sure what the minimum version is) -This list is not exhaustive. If your OS is too old or not listed, or if the -binaries fail to run, you may be able to install the compiler by building it -from source; see below. +This list is not exhaustive. If your OS is too old or not listed, or if the binaries fail to run, you may be able to install the compiler by building it from source; see below. See also for more details about the operating systems which GHC 8.2.2 supports. Other prebuilt distributions (eg, Homebrew, AUR, npm) will probably have the same requirements. diff --git a/bundle/README b/bundle/README index 481563c4b6..972cc568d2 100644 --- a/bundle/README +++ b/bundle/README @@ -8,15 +8,6 @@ Installation Instructions ------------------------- -This bundle contains the combined purs executable, and the following scripts: - -- psc The PureScript compiler -- psci The PureScript interactive REPL (requires NodeJS) -- psc-docs A Markdown documentation generator for PureScript code -- psc-bundle Bundles together CommonJS modules produced by `psc` into a - single JavaScript file; useful for running in the browser. -- psc-publish Generates documentation packages for uploading to Pursuit -- psc-ide-server Provides editor support in the form of type information and - autocompletion - -Copy these files anywhere on your PATH. +This bundle contains the `purs` executable; copy this file anywhere on your +PATH. For information about how to use the `purs` executable, run `purs +--help`. From 0bde7ef1ddc37e92323076d6e46576f966682bca Mon Sep 17 00:00:00 2001 From: Vincent Orr Date: Wed, 9 May 2018 01:07:35 +0100 Subject: [PATCH 0997/1580] delete psc-bundle/README.md (#3356) delete psc-bundle/README.md, since all of the information it contains is also available via `purs bundle --help` --- psc-bundle/README.md | 18 ------------------ 1 file changed, 18 deletions(-) delete mode 100644 psc-bundle/README.md diff --git a/psc-bundle/README.md b/psc-bundle/README.md deleted file mode 100644 index 98cd541c17..0000000000 --- a/psc-bundle/README.md +++ /dev/null @@ -1,18 +0,0 @@ -# psc-bundle - -A dead code elimination tool for PureScript-style CommonJS modules. This can be used as an alternative to Browserify. - -## Usage - - psc-bundle FILE (-m|--module ARG) [--main ARG] [--namespace ARG] - -Options: - -- The input .js file(s) -- Entry point module name(s) are specified with `-m` or `--module`. All code which is not a transitive dependency of an entry point module will be removed. -- The main module is (optionally) specified using `--main`. If specified, this will generate code to run the main method in the specified module. -- The browser namespace defaults to `PS`, and can be overridden with `--namespace`. - -For example, to bundle the modules in the `output` directory, with main module `Main`: - - psc-bundle output/**/*.js -m Main --main Main From 00fa47ec6efe74d6aa0cc93063880078ac96253e Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 11 May 2018 15:43:55 +0200 Subject: [PATCH 0998/1580] [purs ide] Allows adding imports from Prim.* modules (#3352) * [purs ide] Allows adding imports from Prim.* modules * naming things * build ci again --- src/Language/PureScript/Ide/Imports.hs | 54 ++++++++++++-------- src/Language/PureScript/Ide/Prim.hs | 15 ++++-- tests/Language/PureScript/Ide/ImportsSpec.hs | 14 +++++ 3 files changed, 57 insertions(+), 26 deletions(-) diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index f1c510a85a..20052d603e 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -37,10 +37,12 @@ import Data.List (findIndex, nubBy, partition import qualified Data.Map as Map import qualified Data.Text as T import qualified Language.PureScript as P +import qualified Language.PureScript.Constants as C import Language.PureScript.Ide.Completion import Language.PureScript.Ide.Error import Language.PureScript.Ide.Filter import Language.PureScript.Ide.State +import Language.PureScript.Ide.Prim import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import System.IO.UTF8 (writeUTF8FileT) @@ -49,7 +51,7 @@ import qualified Text.Parsec as Parsec data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) deriving (Eq, Show) --- | Reads a file and returns the parsed modulename as well as the parsed +-- | Reads a file and returns the parsed module name as well as the parsed -- imports, while ignoring eventual parse errors that aren't relevant to the -- import section parseImportsFromFile @@ -64,8 +66,10 @@ parseImportsFromFile file = do -- | Reads a file and returns the (lines before the imports, the imports, the -- lines after the imports) -parseImportsFromFile' :: (MonadIO m, MonadError IdeError m) => - FilePath -> m (P.ModuleName, [Text], [Import], [Text]) +parseImportsFromFile' + :: (MonadIO m, MonadError IdeError m) + => FilePath + -> m (P.ModuleName, [Text], [Import], [Text]) parseImportsFromFile' fp = do file <- ideReadFile fp case sliceImportSection (T.lines file) of @@ -101,12 +105,13 @@ sliceImportSection :: [Text] -> Either Text (P.ModuleName, [Text], [Import], [Te sliceImportSection fileLines = first show $ do tokens <- P.lexLenient "" file ImportParse{..} <- P.runTokenParser "" parseModuleHeader tokens - pure ( ipModuleName - , sliceFile (P.SourcePos 1 1) (prevPos ipStart) - , ipImports - -- Not sure why I need to drop 1 here, but it makes the tests pass - , drop 1 (sliceFile (nextPos ipEnd) (P.SourcePos (length fileLines) (lineLength (length fileLines)))) - ) + pure + ( ipModuleName + , sliceFile (P.SourcePos 1 1) (prevPos ipStart) + , ipImports + -- Not sure why I need to drop 1 here, but it makes the tests pass + , drop 1 (sliceFile (nextPos ipEnd) (P.SourcePos (length fileLines) (lineLength (length fileLines)))) + ) where prevPos (P.SourcePos l c) | l == 1 && c == 1 = P.SourcePos l c @@ -181,14 +186,20 @@ addExplicitImport' :: IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> [I addExplicitImport' decl moduleName qualifier imports = let isImplicitlyImported = - not . null $ filter (\case - (Import mn P.Implicit qualifier') -> mn == moduleName && qualifier == qualifier' - _ -> False) imports + any (\case + Import mn P.Implicit qualifier' -> mn == moduleName && qualifier == qualifier' + _ -> False) imports + isNotExplicitlyImportedFromPrim = + moduleName == C.Prim && + not (any (\case + Import C.Prim (P.Explicit _) Nothing -> True + _ -> False) imports) + matches (Import mn (P.Explicit _) qualifier') = mn == moduleName && qualifier == qualifier' matches _ = False freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) qualifier in - if isImplicitlyImported + if isImplicitlyImported || isNotExplicitlyImportedFromPrim then imports else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports where @@ -254,16 +265,17 @@ updateAtFirstOrPrepend p t d l = -- -- * If more than one possible imports are found, reports the possibilities as a -- list of completions. -addImportForIdentifier :: (Ide m, MonadError IdeError m) - => FilePath -- ^ The Sourcefile to read from - -> Text -- ^ The identifier to import - -> Maybe P.ModuleName -- ^ The optional qualifier under which to import - -> [Filter] -- ^ Filters to apply before searching for - -- the identifier - -> m (Either [Match IdeDeclaration] [Text]) +addImportForIdentifier + :: (Ide m, MonadError IdeError m) + => FilePath -- ^ The Sourcefile to read from + -> Text -- ^ The identifier to import + -> Maybe P.ModuleName -- ^ The optional qualifier under which to import + -> [Filter] -- ^ Filters to apply before searching for the identifier + -> m (Either [Match IdeDeclaration] [Text]) addImportForIdentifier fp ident qual filters = do + let addPrim = (++) idePrimDeclarations modules <- Map.toList <$> getAllModules Nothing - case map (fmap discardAnn) (getExactMatches ident filters modules) of + case map (fmap discardAnn) (getExactMatches ident filters (addPrim modules)) of [] -> throwError (NotFound "Couldn't find the given identifier. \ \Have you loaded the corresponding module?") diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index 1bd6e4896f..1a14b8b16e 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -35,13 +35,18 @@ idePrimDeclarations = annClass cls = foreach (Map.toList cls) $ \(cn, _) -> -- Dummy kind and instances here, but we primarily care about the name completion IdeDeclarationAnn emptyAnn (IdeDeclTypeClass (IdeTypeClass (P.disqualify cn) P.kindType []) ) + -- The Environment for typechecking holds both a type class as well as a + -- type declaration for every class, but we filter the types out when we + -- load the Externs, so we do the same here + removeClasses types classes = + Map.difference types (Map.mapKeys (map P.coerceProperName) classes) - primTypes = annType PEnv.primTypes + primTypes = annType (removeClasses PEnv.primTypes PEnv.primClasses) primOrderingTypes = annType PEnv.primOrderingTypes - primRowTypes = annType PEnv.primRowTypes - primRowListTypes = annType PEnv.primRowListTypes - primSymbolTypes = annType PEnv.primSymbolTypes - primTypeErrorTypes = annType PEnv.primTypeErrorTypes + primRowTypes = annType (removeClasses PEnv.primRowTypes PEnv.primRowClasses) + primRowListTypes = annType (removeClasses PEnv.primRowListTypes PEnv.primRowListClasses) + primSymbolTypes = annType (removeClasses PEnv.primSymbolTypes PEnv.primSymbolClasses) + primTypeErrorTypes = annType (removeClasses PEnv.primTypeErrorTypes PEnv.primTypeErrorClasses) primClasses = annClass PEnv.primClasses primRowClasses = annClass PEnv.primRowClasses diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index e03a0aaaab..f84d08862d 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -9,6 +9,7 @@ import qualified Language.PureScript as P import Language.PureScript.Ide.Command as Command import Language.PureScript.Ide.Error import Language.PureScript.Ide.Imports +import Language.PureScript.Ide.Filter (moduleFilter) import qualified Language.PureScript.Ide.Test as Test import Language.PureScript.Ide.Types import System.FilePath @@ -343,6 +344,10 @@ addExplicitImport :: Text -> Command addExplicitImport i = Command.Import ("src" "ImportsSpec.purs") Nothing [] (Command.AddImportForIdentifier i Nothing) +addExplicitImportFiltered :: Text -> [P.ModuleName] -> Command +addExplicitImportFiltered i ms = + Command.Import ("src" "ImportsSpec.purs") Nothing [moduleFilter ms] (Command.AddImportForIdentifier i Nothing) + importShouldBe :: [Text] -> [Text] -> Expectation importShouldBe res importSection = res `shouldBe` [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId x = x"] @@ -393,3 +398,12 @@ importFromIdeState = do \write to the output file" $ do result <- runIdeLoaded (addExplicitImport "doesnExist") result `shouldSatisfy` isLeft + it "doesn't import things from the Prim modules" $ do + Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImport "String") + result `importShouldBe` [] + it "imports classes from Prim.* modules" $ do + Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImportFiltered "Cons" [Test.mn "Prim.Row"]) + result `importShouldBe` ["import Prim.Row (class Cons)"] + it "imports types from Prim.* modules" $ do + Right (MultilineTextResult result) <- runIdeLoaded (addExplicitImportFiltered "Cons" [Test.mn "Prim.RowList"]) + result `importShouldBe` ["import Prim.RowList (Cons)"] From 9d483a26a9f682908099708aae9a2740dca68fc4 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 14 May 2018 16:21:13 +0100 Subject: [PATCH 0999/1580] Fix purs bundle to recognise explicit paths (#3361) --- src/Language/PureScript/Bundle.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 19959050a9..5ba1ad5901 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -145,13 +145,20 @@ printErrorMessage (MissingMainModule mName) = -- | Calculate the ModuleIdentifier which a require(...) statement imports. checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier -checkImportPath "./foreign" m _ = +checkImportPath "./foreign.js" m _ = Right (ModuleIdentifier (moduleName m) Foreign) checkImportPath name _ names - | Just name' <- stripPrefix "../" name + | Just name' <- stripSuffix "/index.js" =<< stripPrefix "../" name , name' `S.member` names = Right (ModuleIdentifier name' Regular) checkImportPath name _ _ = Left name +stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] +stripSuffix suffix xs = + case splitAt (length xs - length suffix) xs of + (before, after) + | after == suffix -> Just before + | otherwise -> Nothing + -- | Compute the dependencies of all elements in a module, and add them to the tree. -- -- Members and exports can have dependencies. A dependency is of one of the following forms: From a33f38a1759408136ea3bee805aad0118d8cd583 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 18 May 2018 13:47:03 +0200 Subject: [PATCH 1000/1580] [purs ide] Use absolute paths for source locations (#3363) * [purs ide] Make sure we use absolute paths for source locations This just makes it less error-prone for editors to open locations reported by ide * [purs ide] Use NonEmpty for usage results * formatting/getting rid of toS usages * Update SourceFile.hs --- src/Language/PureScript/Ide.hs | 12 ++++++---- src/Language/PureScript/Ide/Imports.hs | 2 +- src/Language/PureScript/Ide/Rebuild.hs | 2 +- src/Language/PureScript/Ide/SourceFile.hs | 6 ++--- src/Language/PureScript/Ide/Usage.hs | 4 ++-- src/Language/PureScript/Ide/Util.hs | 27 ++++++++++++++-------- tests/Language/PureScript/Ide/Test.hs | 8 ++++++- tests/Language/PureScript/Ide/UsageSpec.hs | 5 ++-- 8 files changed, 43 insertions(+), 23 deletions(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 5483f2a179..0970c07a8c 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -81,7 +81,7 @@ handleCommand c = case c of Nothing -> throwError (GeneralError "Declaration not found") Just declaration -> do let sourceModule = fromMaybe moduleName (declaration & _idaAnnotation & _annExportedFrom) - UsagesResult . fold <$> findUsages (discardAnn declaration) sourceModule + UsagesResult . foldMap toList <$> findUsages (discardAnn declaration) sourceModule Import fp outfp _ (AddImplicitImport mn) -> do rs <- addImplicitImport fp mn answerRequest outfp rs @@ -99,7 +99,7 @@ handleCommand c = case c of RebuildSync file actualFile -> rebuildFileSync file actualFile Cwd -> - TextResult . toS <$> liftIO getCurrentDirectory + TextResult . T.pack <$> liftIO getCurrentDirectory Reset -> resetIdeState $> TextResult "State has been reset." Quit -> @@ -117,8 +117,12 @@ findCompletions filters matcher currentModule complOptions = do let insertPrim = (++) idePrimDeclarations pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules))) -findType :: Ide m => - Text -> [Filter] -> Maybe P.ModuleName -> m Success +findType + :: Ide m + => Text + -> [Filter] + -> Maybe P.ModuleName + -> m Success findType search filters currentModule = do modules <- Map.toList <$> getAllModules currentModule let insertPrim = (++) idePrimDeclarations diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 20052d603e..382523e52a 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -71,7 +71,7 @@ parseImportsFromFile' => FilePath -> m (P.ModuleName, [Text], [Import], [Text]) parseImportsFromFile' fp = do - file <- ideReadFile fp + (_, file) <- ideReadFile fp case sliceImportSection (T.lines file) of Right res -> pure res Left err -> throwError (GeneralError err) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index c4f4b204a8..84555a5413 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -49,7 +49,7 @@ rebuildFile file actualFile runOpenBuild = do input <- ideReadFile file - m <- case snd <$> P.parseModuleFromFile (maybe identity const actualFile) (file, input) of + m <- case snd <$> P.parseModuleFromFile (maybe identity const actualFile) input of Left parseError -> throwError (RebuildError (P.MultipleErrors [P.toPositionedError parseError])) Right m -> pure m diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 7b36e60bdd..c62e26bf8d 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -35,8 +35,8 @@ parseModule => FilePath -> m (Either FilePath (FilePath, P.Module)) parseModule path = do - contents <- ideReadFile path - pure (parseModule' path contents) + (absPath, contents) <- ideReadFile path + pure (parseModule' absPath contents) parseModule' :: FilePath -> Text -> Either FilePath (FilePath, P.Module) parseModule' path file = @@ -49,7 +49,7 @@ parseModulesFromFiles => [FilePath] -> m [Either FilePath (FilePath, P.Module)] parseModulesFromFiles paths = do - files <- traverse (\p -> (p,) <$> ideReadFile p) paths + files <- traverse ideReadFile paths pure (inParallel (map (uncurry parseModule') files)) where inParallel :: [Either e (k, a)] -> [Either e (k, a)] diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index 9e989800f9..9ffa5e9a1a 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -28,13 +28,13 @@ findUsages :: (MonadIO m, Ide m) => IdeDeclaration -> P.ModuleName - -> m (ModuleMap [P.SourceSpan]) + -> m (ModuleMap (NonEmpty P.SourceSpan)) findUsages declaration moduleName = do ms <- getAllModules Nothing asts <- Map.map fst . fsModules <$> getFileState let elig = eligibleModules (moduleName, declaration) ms asts pure - $ Map.filter (not . null) + $ Map.mapMaybe nonEmpty $ Map.mapWithKey (\mn searches -> foldMap (\m -> foldMap (applySearch m) searches) (Map.lookup mn asts)) elig diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 5e84626b70..47489e8df0 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -34,7 +34,6 @@ import Protolude hiding (decodeUtf8, import Control.Lens hiding ((&), op) import Data.Aeson -import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding as TLE import qualified Language.PureScript as P @@ -42,6 +41,7 @@ import Language.PureScript.Ide.Error (IdeError(..)) import Language.PureScript.Ide.Logging import Language.PureScript.Ide.Types import System.IO.UTF8 (readUTF8FileT) +import System.Directory (makeAbsolute) identifierFromIdeDeclaration :: IdeDeclaration -> Text identifierFromIdeDeclaration d = case d of @@ -103,13 +103,22 @@ ideReadFile' :: (MonadIO m, MonadError IdeError m) => (FilePath -> IO Text) -> FilePath - -> m Text + -> m (FilePath, Text) ideReadFile' fileReader fp = do - contents :: Either IOException Text <- liftIO (try (fileReader fp)) - either - (\_ -> throwError (GeneralError ("Couldn't find file at: " <> T.pack fp))) - pure - contents - -ideReadFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m Text + absPath <- liftIO (try (makeAbsolute fp)) >>= \case + Left (err :: IOException) -> + throwError + (GeneralError + ("Couldn't resolve path for: " <> show fp <> ", Error: " <> show err)) + Right absPath -> pure absPath + contents <- liftIO (try (fileReader absPath)) >>= \case + Left (err :: IOException) -> + throwError + (GeneralError + ("Couldn't find file at: " <> show absPath <> ", Error: " <> show err)) + Right contents -> + pure contents + pure (absPath, contents) + +ideReadFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m (FilePath, Text) ideReadFile = ideReadFile' readUTF8FileT diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index 8358ac563e..cca8e99ef9 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -115,10 +115,16 @@ ss x y = P.SourceSpan "Test.purs" (P.SourcePos x y) (P.SourcePos x y) mn :: Text -> P.ModuleName mn = P.moduleNameFromString +projectDir :: FilePath +projectDir = "." "tests" "support" "pscide" + +getProjectDirectory :: IO FilePath +getProjectDirectory = makeAbsolute projectDir + inProject :: IO a -> IO a inProject f = do cwd' <- getCurrentDirectory - setCurrentDirectory ("." "tests" "support" "pscide") + setCurrentDirectory projectDir a <- f setCurrentDirectory cwd' pure a diff --git a/tests/Language/PureScript/Ide/UsageSpec.hs b/tests/Language/PureScript/Ide/UsageSpec.hs index 70671ea89e..d1e83ebaad 100644 --- a/tests/Language/PureScript/Ide/UsageSpec.hs +++ b/tests/Language/PureScript/Ide/UsageSpec.hs @@ -11,7 +11,7 @@ import qualified Language.PureScript.Ide.Test as Test import qualified Language.PureScript as P import Test.Hspec import Data.Text.Read (decimal) -import System.FilePath +import System.FilePath load :: [Text] -> Command load = LoadSync . map Test.mn @@ -28,7 +28,8 @@ shouldBeUsage usage' (fp, range) = [ endLine, endColumn ] = map unsafeReadInt (Text.splitOn ":" end) in do - fp `shouldBe` P.spanName usage' + projectDir <- Test.getProjectDirectory + projectDir fp `shouldBe` P.spanName usage' (P.sourcePosLine (P.spanStart usage'), P.sourcePosColumn (P.spanStart usage')) `shouldBe` From 30cd03188844eec697e6f2b387eff57a12f50def Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Mon, 21 May 2018 14:18:09 +0200 Subject: [PATCH 1001/1580] [purs repl] Allows to :browse Prim.* modules (#3364) --- src/Language/PureScript/CodeGen/JS.hs | 2 +- src/Language/PureScript/Constants.hs | 3 +++ src/Language/PureScript/Interactive.hs | 4 ++-- src/Language/PureScript/ModuleDependencies.hs | 2 +- 4 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 60204cebee..266c560422 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -55,7 +55,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ = let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps jsImports <- traverse (importToJs mnLookup) - . (\\ [mn, C.Prim, C.PrimOrdering, C.PrimRow, C.PrimRowList, C.PrimSymbol, C.PrimTypeError]) $ ordNub $ map snd imps + . (\\ (mn : C.primModules)) $ ordNub $ map snd imps let decls' = renameModules mnLookup decls jsDecls <- mapM bindToJs decls' optimized <- traverse (traverse optimize) jsDecls diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index f05d4f7cd6..fd941374bb 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -448,6 +448,9 @@ pattern Fail = Qualified (Just PrimTypeError) (ProperName "Fail") pattern Warn :: Qualified (ProperName 'ClassName) pattern Warn = Qualified (Just PrimTypeError) (ProperName "Warn") +primModules :: [ModuleName] +primModules = [Prim, PrimOrdering, PrimRow, PrimRowList, PrimSymbol, PrimTypeError] + -- Data.Symbol pattern DataSymbol :: ModuleName diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index ebe3e7d856..6fbfc5dbb8 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -30,6 +30,7 @@ import Control.Monad.Writer.Strict (Writer(), runWriter) import qualified Language.PureScript as P import qualified Language.PureScript.Names as N +import qualified Language.PureScript.Constants as C import Language.PureScript.Interactive.Completion as Interactive import Language.PureScript.Interactive.IO as Interactive @@ -298,8 +299,7 @@ handleBrowse print' moduleName = do where findMod needle externs imports = let qualMod = fromMaybe needle (lookupUnQualifiedModName needle imports) - primMod = P.ModuleName [P.ProperName "Prim"] - modules = S.fromList (primMod : (P.getModuleName . fst <$> externs)) + modules = S.fromList (C.primModules <> (P.getModuleName . fst <$> externs)) in if qualMod `S.member` modules then Just qualMod else Nothing diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index b0aa2b2ed6..1bd39e768f 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -42,7 +42,7 @@ sortModules ms = do toGraphNode mns m@(Module _ _ mn ds _) = do let deps = ordNub (mapMaybe usedModules ds) void . parU deps $ \(dep, pos) -> - when (dep `notElem` [C.Prim, C.PrimOrdering, C.PrimRow, C.PrimRowList, C.PrimSymbol, C.PrimTypeError] && S.notMember dep mns) . + when (dep `notElem` C.primModules && S.notMember dep mns) . throwError . addHint (ErrorInModule mn) . errorMessage' pos From 1c8ec684a0fb308ca8051108afdf922741412733 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 21 May 2018 23:40:59 +0100 Subject: [PATCH 1002/1580] Bump to 0.12.0 (#3365) --- package.yaml | 2 +- tests/support/bower.json | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index c3d4511f2f..16f9ed8722 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.12.0-rc1' +version: '0.12.0' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. diff --git a/tests/support/bower.json b/tests/support/bower.json index cf220647a1..b44fb237b0 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -67,7 +67,6 @@ "purescript-refs": "compiler/0.12", "purescript-st": "compiler/0.12", "purescript-strings": "compiler/0.12", - "purescript-symbols": "compiler/0.12", "purescript-tailrec": "compiler/0.12", "purescript-tuples": "compiler/0.12", "purescript-type-equality": "compiler/0.12", From f8ca834ebe3d8e5d484e5b55b5d1b8b6f0a783a2 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sat, 2 Jun 2018 22:44:31 +0100 Subject: [PATCH 1003/1580] Fix test-support dependency versions and update psci browse test (#3374) --- tests/TestPsci/CompletionTest.hs | 8 +-- tests/support/bower.json | 107 ++++++++++--------------------- 2 files changed, 39 insertions(+), 76 deletions(-) diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index c513cb4c93..13ba6c08cb 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -34,12 +34,12 @@ completionTestData supportModuleNames = , (":b", [":browse"]) -- :browse should complete module names - , (":b Eff", map (":b Effect" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref"]) - , (":b Effect.", map (":b Effect" ++) [".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref"]) + , (":b Eff", map (":b Effect" ++) ["", ".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"]) + , (":b Effect.", map (":b Effect" ++) [".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"]) -- import should complete module names - , ("import Eff", map ("import Effect" ++) ["", ".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref"]) - , ("import Effect.", map ("import Effect" ++) [".Unsafe", ".Class", ".Console", ".Uncurried", ".Ref"]) + , ("import Eff", map ("import Effect" ++) ["", ".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"]) + , ("import Effect.", map ("import Effect" ++) [".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"]) -- :quit, :help, :reload, :clear should not complete , (":help ", []) diff --git a/tests/support/bower.json b/tests/support/bower.json index b44fb237b0..4d66df9c82 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -1,77 +1,40 @@ { "name": "purescript-test-suite-support", "dependencies": { - "purescript-arrays": "purescript/purescript-arrays#compiler/0.12", - "purescript-assert": "purescript/purescript-assert#compiler/0.12", - "purescript-bifunctors": "purescript/purescript-bifunctors#compiler/0.12", - "purescript-console": "purescript/purescript-console#compiler/0.12", - "purescript-control": "purescript/purescript-control#compiler/0.12", - "purescript-distributive": "purescript/purescript-distributive#compiler/0.12", - "purescript-effect": "purescript/purescript-effect#compiler/0.12", - "purescript-either": "purescript/purescript-either#compiler/0.12", - "purescript-foldable-traversable": "purescript/purescript-foldable-traversable#compiler/0.12", - "purescript-functions": "purescript/purescript-functions#compiler/0.12", - "purescript-gen": "purescript/purescript-gen#compiler/0.12", - "purescript-generics-rep": "purescript/purescript-generics-rep#compiler/0.12", - "purescript-globals": "purescript/purescript-globals#compiler/0.12", - "purescript-identity": "purescript/purescript-identity#compiler/0.12", - "purescript-integers": "purescript/purescript-integers#compiler/0.12", - "purescript-invariant": "purescript/purescript-invariant#compiler/0.12", - "purescript-lazy": "purescript/purescript-lazy#compiler/0.12", - "purescript-lists": "purescript/purescript-lists#compiler/0.12", - "purescript-math": "purescript/purescript-math#compiler/0.12", - "purescript-maybe": "purescript/purescript-maybe#compiler/0.12", - "purescript-newtype": "purescript/purescript-newtype#compiler/0.12", - "purescript-nonempty": "purescript/purescript-nonempty#compiler/0.12", - "purescript-partial": "purescript/purescript-partial#compiler/0.12", - "purescript-prelude": "purescript/purescript-prelude#compiler/0.12", - "purescript-proxy": "purescript/purescript-proxy#compiler/0.12", - "purescript-psci-support": "purescript/purescript-psci-support#compiler/0.12", - "purescript-refs": "purescript/purescript-refs#compiler/0.12", - "purescript-st": "purescript/purescript-st#compiler/0.12", - "purescript-strings": "purescript/purescript-strings#compiler/0.12", - "purescript-tailrec": "purescript/purescript-tailrec#compiler/0.12", - "purescript-tuples": "purescript/purescript-tuples#compiler/0.12", - "purescript-type-equality": "purescript/purescript-type-equality#compiler/0.12", - "purescript-typelevel-prelude": "purescript/purescript-typelevel-prelude#compiler/0.12", - "purescript-unfoldable": "purescript/purescript-unfoldable#compiler/0.12", - "purescript-unsafe-coerce": "purescript/purescript-unsafe-coerce#compiler/0.12" - }, - "resolutions": { - "purescript-arrays": "compiler/0.12", - "purescript-assert": "compiler/0.12", - "purescript-bifunctors": "compiler/0.12", - "purescript-console": "compiler/0.12", - "purescript-control": "compiler/0.12", - "purescript-distributive": "compiler/0.12", - "purescript-effect": "compiler/0.12", - "purescript-either": "compiler/0.12", - "purescript-foldable-traversable": "compiler/0.12", - "purescript-functions": "compiler/0.12", - "purescript-gen": "compiler/0.12", - "purescript-generics-rep": "compiler/0.12", - "purescript-globals": "compiler/0.12", - "purescript-identity": "compiler/0.12", - "purescript-integers": "compiler/0.12", - "purescript-invariant": "compiler/0.12", - "purescript-lazy": "compiler/0.12", - "purescript-lists": "compiler/0.12", - "purescript-math": "compiler/0.12", - "purescript-maybe": "compiler/0.12", - "purescript-newtype": "compiler/0.12", - "purescript-nonempty": "compiler/0.12", - "purescript-partial": "compiler/0.12", - "purescript-prelude": "compiler/0.12", - "purescript-proxy": "compiler/0.12", - "purescript-psci-support": "compiler/0.12", - "purescript-refs": "compiler/0.12", - "purescript-st": "compiler/0.12", - "purescript-strings": "compiler/0.12", - "purescript-tailrec": "compiler/0.12", - "purescript-tuples": "compiler/0.12", - "purescript-type-equality": "compiler/0.12", - "purescript-typelevel-prelude": "compiler/0.12", - "purescript-unfoldable": "compiler/0.12", - "purescript-unsafe-coerce": "compiler/0.12" + "purescript-arrays": "5.0.0", + "purescript-assert": "4.0.0", + "purescript-bifunctors": "4.0.0", + "purescript-console": "4.1.0", + "purescript-control": "4.0.0", + "purescript-distributive": "4.0.0", + "purescript-effect": "2.0.0", + "purescript-either": "4.0.0", + "purescript-foldable-traversable": "4.0.0", + "purescript-functions": "4.0.0", + "purescript-gen": "2.0.0", + "purescript-generics-rep": "6.0.0", + "purescript-globals": "4.0.0", + "purescript-identity": "4.0.0", + "purescript-integers": "4.0.0", + "purescript-invariant": "4.0.0", + "purescript-lazy": "4.0.0", + "purescript-lists": "5.0.0", + "purescript-math": "2.1.1", + "purescript-maybe": "4.0.0", + "purescript-newtype": "3.0.0", + "purescript-nonempty": "5.0.0", + "purescript-partial": "2.0.0", + "purescript-prelude": "4.0.0", + "purescript-proxy": "3.0.0", + "purescript-psci-support": "4.0.0", + "purescript-refs": "4.1.0", + "purescript-st": "4.0.0", + "purescript-strings": "4.0.0", + "purescript-tailrec": "4.0.0", + "purescript-tuples": "5.0.0", + "purescript-type-equality": "3.0.0", + "purescript-typelevel-prelude": "3.0.0", + "purescript-unfoldable": "4.0.0", + "purescript-unsafe-coerce": "4.0.0" } } From e184fca6ffd04de45d4d8c4f6747230ae266c6d4 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Thu, 9 Aug 2018 11:20:43 +0200 Subject: [PATCH 1004/1580] Changes necessary to build on GHC 8.4.3 (#3372) * changes necessary to build on GHC 8.4.2 * remove redundant Monoid imports * bumps to a 8.4.3 resolver * Updates for LTS-12 * Work around cabal/stack bug * Update node and stack versions on appveyor * removes spdx dependent code * Revert "removes spdx dependent code" This reverts commit 94327051aa311b369a58214a594eb00109912cd8. * use Cabal's SPDX parsing * use Cabal's Parsec class to parse licenses --- app/Command/Bundle.hs | 1 - app/Command/Compile.hs | 1 - app/Command/Hierarchy.hs | 1 - app/Command/Publish.hs | 1 - app/Command/REPL.hs | 1 - app/Main.hs | 1 - appveyor.yml | 7 +- package.yaml | 6 +- src/Language/PureScript/AST/Binders.hs | 2 - src/Language/PureScript/AST/SourcePos.hs | 1 - src/Language/PureScript/AST/Traversals.hs | 145 +++++++++--------- src/Language/PureScript/CodeGen/JS.hs | 1 - src/Language/PureScript/CodeGen/JS/Common.hs | 1 - src/Language/PureScript/CodeGen/JS/Printer.hs | 1 - src/Language/PureScript/CoreFn/Traversals.hs | 30 ++-- src/Language/PureScript/CoreImp/AST.hs | 40 ++--- .../PureScript/CoreImp/Optimizer/Inliner.hs | 1 - .../PureScript/CoreImp/Optimizer/TCO.hs | 1 - src/Language/PureScript/Docs/AsHtml.hs | 1 - src/Language/PureScript/Docs/AsMarkdown.hs | 1 - .../PureScript/Docs/Convert/ReExports.hs | 8 +- .../PureScript/Docs/Convert/Single.hs | 2 +- src/Language/PureScript/Docs/Prim.hs | 1 - src/Language/PureScript/Docs/Render.hs | 1 - .../Docs/RenderedCode/RenderKind.hs | 1 - .../Docs/RenderedCode/RenderType.hs | 1 - .../PureScript/Docs/RenderedCode/Types.hs | 3 +- .../PureScript/Docs/Utils/MonoidExtras.hs | 1 - src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/Errors/JSON.hs | 1 - src/Language/PureScript/Hierarchy.hs | 1 - src/Language/PureScript/Ide/Filter.hs | 2 +- src/Language/PureScript/Ide/Matcher.hs | 2 +- src/Language/PureScript/Interactive.hs | 1 - .../PureScript/Interactive/Printer.hs | 1 - src/Language/PureScript/Kinds.hs | 6 +- src/Language/PureScript/Label.hs | 2 +- src/Language/PureScript/Linter.hs | 1 - src/Language/PureScript/Linter/Exhaustive.hs | 1 - src/Language/PureScript/Make/Actions.hs | 1 - src/Language/PureScript/Names.hs | 1 - src/Language/PureScript/PSString.hs | 3 +- src/Language/PureScript/Parser/Common.hs | 1 - .../PureScript/Parser/Declarations.hs | 1 - src/Language/PureScript/Parser/Lexer.hs | 1 - src/Language/PureScript/Pretty/Common.hs | 8 +- src/Language/PureScript/Pretty/Kinds.hs | 1 - src/Language/PureScript/Pretty/Types.hs | 2 +- src/Language/PureScript/Pretty/Values.hs | 2 +- src/Language/PureScript/Publish.hs | 9 +- .../PureScript/Publish/ErrorsWarnings.hs | 7 +- src/Language/PureScript/Renamer.hs | 1 - .../PureScript/Sugar/TypeClasses/Deriving.hs | 9 +- src/Language/PureScript/TypeChecker.hs | 1 - .../PureScript/TypeChecker/Entailment.hs | 11 +- .../PureScript/TypeChecker/Skolems.hs | 1 - src/Language/PureScript/TypeChecker/Types.hs | 1 - .../PureScript/TypeClassDictionaries.hs | 1 - src/Language/PureScript/Types.hs | 1 - stack.yaml | 2 +- tests/TestCompiler.hs | 1 - tests/TestCoreFn.hs | 16 +- tests/TestPrimDocs.hs | 1 - 63 files changed, 165 insertions(+), 200 deletions(-) diff --git a/app/Command/Bundle.hs b/app/Command/Bundle.hs index 4ea338a241..115c439a36 100644 --- a/app/Command/Bundle.hs +++ b/app/Command/Bundle.hs @@ -7,7 +7,6 @@ module Command.Bundle (command) where import Data.Traversable (for) -import Data.Monoid ((<>)) import Data.Aeson (encode) import Data.Maybe (isNothing) import Control.Applicative diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index cb91b6173a..713524c595 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -8,7 +8,6 @@ module Command.Compile (command) where import Control.Applicative import Control.Monad -import Control.Monad.Writer.Strict import qualified Data.Aeson as A import Data.Bool (bool) import qualified Data.ByteString.Lazy as B diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs index 1bb9346534..0966c9a7b6 100644 --- a/app/Command/Hierarchy.hs +++ b/app/Command/Hierarchy.hs @@ -22,7 +22,6 @@ import Protolude (catMaybes) import Control.Applicative (optional) import Data.Foldable (for_) -import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Data.Text.IO as T import Options.Applicative (Parser) diff --git a/app/Command/Publish.hs b/app/Command/Publish.hs index 0440bae107..bffb3e838a 100644 --- a/app/Command/Publish.hs +++ b/app/Command/Publish.hs @@ -5,7 +5,6 @@ module Command.Publish (command) where import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Monoid ((<>)) import Data.Time.Clock (getCurrentTime) import Data.Version (Version(..)) import Language.PureScript.Publish diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 04033b57eb..1093733c7b 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -31,7 +31,6 @@ import Control.Monad.Trans.State.Strict (StateT, evalStateT) import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Data.FileEmbed (embedStringFile) import Data.Foldable (for_) -import Data.Monoid ((<>)) import Data.String (IsString(..)) import Data.Text (Text, unpack) import Data.Traversable (for) diff --git a/app/Main.hs b/app/Main.hs index 1f5ec06ef9..f3e72ab68a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -15,7 +15,6 @@ import qualified Command.Ide as Ide import qualified Command.Publish as Publish import qualified Command.REPL as REPL import Data.Foldable (fold) -import Data.Monoid ((<>)) import qualified Options.Applicative as Opts import System.Environment (getArgs) import qualified System.IO as IO diff --git a/appveyor.yml b/appveyor.yml index d2788c2071..a3fa6b1c51 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -3,9 +3,12 @@ version: '{build}' environment: # Keep the path as short as possible, just in case. STACK_ROOT: c:\s - STACK_VER: 1.6.3 + STACK_VER: 1.7.1 RELEASE_USER: purescript RELEASE_REPO: purescript + # See https://github.com/commercialhaskell/stack/issues/3944, might no + # longer be necessary after we've moved to a snapshot with network >= 0.2.7.1 + TMP: "c:\\tmp" branches: # Only build master and tagged versions, i.e. not feature branches; feature # branches already get built after opening a pull request. @@ -19,7 +22,7 @@ cache: - c:\s -> appveyor/cache-buster.txt install: - git submodule update --init -- ps: Install-Product node 6 +- ps: Install-Product node 8 - npm install -g bower - ps: | diff --git a/package.yaml b/package.yaml index 16f9ed8722..01094bf840 100644 --- a/package.yaml +++ b/package.yaml @@ -32,15 +32,16 @@ extra-source-files: - CONTRIBUTORS.md - CONTRIBUTING.md dependencies: - - aeson >=1.0 && <1.3 + - aeson >=1.0 && <1.4 - aeson-better-errors >=0.8 - ansi-terminal >=0.7.1 && <0.9 - - base >=4.8 && <4.11 + - base >=4.8 && <4.12 - base-compat >=0.6.0 - blaze-html >=0.8.1 && <0.10 - bower-json >=1.0.0.1 && <1.1 - boxes >=0.1.4 && <0.2.0 - bytestring + - Cabal >= 2.2 - cheapskate >=0.1 && <0.2 - clock - containers @@ -70,7 +71,6 @@ dependencies: - scientific >=0.3.4.9 && <0.4 - semigroups >=0.16.2 && <0.19 - sourcemap >=0.1.6 - - spdx ==0.2.* - split - stm >=0.2.4.0 - stringsearch diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index 82d23e03b5..19e1d18db8 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -5,8 +5,6 @@ module Language.PureScript.AST.Binders where import Prelude.Compat -import Data.Semigroup - import Language.PureScript.AST.SourcePos import Language.PureScript.AST.Literals import Language.PureScript.Names diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 60605d7aaa..6ad67542d7 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -8,7 +8,6 @@ import Prelude.Compat import Control.DeepSeq (NFData) import Data.Aeson ((.=), (.:)) -import Data.Monoid import Data.Text (Text) import GHC.Generics (Generic) import Language.PureScript.Comments diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index f4a35f5f40..4852488938 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -264,66 +264,66 @@ everythingOnValues , CaseAlternative -> r , DoNotationElement -> r ) -everythingOnValues (<>) f g h i j = (f', g', h', i', j') +everythingOnValues (<>.) f g h i j = (f', g', h', i', j') where f' :: Declaration -> r - f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (fmap f' ds) - f' d@(ValueDeclaration vd) = foldl (<>) (f d) (fmap h' (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) (valdeclExpression vd)) - f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (fmap (\(_, _, val) -> g' val) ds) - f' d@(TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>) (f d) (fmap f' ds) - f' d@(TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (fmap f' ds) - f' d@(BoundValueDeclaration _ b expr) = f d <> h' b <> g' expr + f' d@(DataBindingGroupDeclaration ds) = foldl (<>.) (f d) (fmap f' ds) + f' d@(ValueDeclaration vd) = foldl (<>.) (f d) (fmap h' (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) (valdeclExpression vd)) + f' d@(BindingGroupDeclaration ds) = foldl (<>.) (f d) (fmap (\(_, _, val) -> g' val) ds) + f' d@(TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>.) (f d) (fmap f' ds) + f' d@(TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>.) (f d) (fmap f' ds) + f' d@(BoundValueDeclaration _ b expr) = f d <>. h' b <>. g' expr f' d = f d g' :: Expr -> r g' v@(Literal _ l) = lit (g v) g' l - g' v@(UnaryMinus _ v1) = g v <> g' v1 - g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2 - g' v@(Parens v1) = g v <> g' v1 - g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1 - g' v@(Accessor _ v1) = g v <> g' v1 - g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (fmap (g' . snd) vs) - g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (fmap g' vs) - g' v@(Abs b v1) = g v <> h' b <> g' v1 - g' v@(App v1 v2) = g v <> g' v1 <> g' v2 - g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3 - g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (fmap g' vs)) (fmap i' alts) - g' v@(TypedValue _ v1 _) = g v <> g' v1 - g' v@(Let _ ds v1) = foldl (<>) (g v) (fmap f' ds) <> g' v1 - g' v@(Do es) = foldl (<>) (g v) (fmap j' es) - g' v@(Ado es v1) = foldl (<>) (g v) (fmap j' es) <> g' v1 - g' v@(PositionedValue _ _ v1) = g v <> g' v1 + g' v@(UnaryMinus _ v1) = g v <>. g' v1 + g' v@(BinaryNoParens op v1 v2) = g v <>. g' op <>. g' v1 <>. g' v2 + g' v@(Parens v1) = g v <>. g' v1 + g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <>. g' v1 + g' v@(Accessor _ v1) = g v <>. g' v1 + g' v@(ObjectUpdate obj vs) = foldl (<>.) (g v <>. g' obj) (fmap (g' . snd) vs) + g' v@(ObjectUpdateNested obj vs) = foldl (<>.) (g v <>. g' obj) (fmap g' vs) + g' v@(Abs b v1) = g v <>. h' b <>. g' v1 + g' v@(App v1 v2) = g v <>. g' v1 <>. g' v2 + g' v@(IfThenElse v1 v2 v3) = g v <>. g' v1 <>. g' v2 <>. g' v3 + g' v@(Case vs alts) = foldl (<>.) (foldl (<>.) (g v) (fmap g' vs)) (fmap i' alts) + g' v@(TypedValue _ v1 _) = g v <>. g' v1 + g' v@(Let _ ds v1) = foldl (<>.) (g v) (fmap f' ds) <>. g' v1 + g' v@(Do es) = foldl (<>.) (g v) (fmap j' es) + g' v@(Ado es v1) = foldl (<>.) (g v) (fmap j' es) <>. g' v1 + g' v@(PositionedValue _ _ v1) = g v <>. g' v1 g' v = g v h' :: Binder -> r h' b@(LiteralBinder _ l) = lit (h b) h' l - h' b@(ConstructorBinder _ _ bs) = foldl (<>) (h b) (fmap h' bs) - h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3 - h' b@(ParensInBinder b1) = h b <> h' b1 - h' b@(NamedBinder _ _ b1) = h b <> h' b1 - h' b@(PositionedBinder _ _ b1) = h b <> h' b1 - h' b@(TypedBinder _ b1) = h b <> h' b1 + h' b@(ConstructorBinder _ _ bs) = foldl (<>.) (h b) (fmap h' bs) + h' b@(BinaryNoParensBinder b1 b2 b3) = h b <>. h' b1 <>. h' b2 <>. h' b3 + h' b@(ParensInBinder b1) = h b <>. h' b1 + h' b@(NamedBinder _ _ b1) = h b <>. h' b1 + h' b@(PositionedBinder _ _ b1) = h b <>. h' b1 + h' b@(TypedBinder _ b1) = h b <>. h' b1 h' b = h b lit :: r -> (a -> r) -> Literal a -> r - lit r go (ArrayLiteral as) = foldl (<>) r (fmap go as) - lit r go (ObjectLiteral as) = foldl (<>) r (fmap (go . snd) as) + lit r go (ArrayLiteral as) = foldl (<>.) r (fmap go as) + lit r go (ObjectLiteral as) = foldl (<>.) r (fmap (go . snd) as) lit r _ _ = r i' :: CaseAlternative -> r i' ca@(CaseAlternative bs gs) = - foldl (<>) (i ca) (fmap h' bs ++ concatMap (\(GuardedExpr grd val) -> fmap k' grd ++ [g' val]) gs) + foldl (<>.) (i ca) (fmap h' bs ++ concatMap (\(GuardedExpr grd val) -> fmap k' grd ++ [g' val]) gs) j' :: DoNotationElement -> r - j' e@(DoNotationValue v) = j e <> g' v - j' e@(DoNotationBind b v) = j e <> h' b <> g' v - j' e@(DoNotationLet ds) = foldl (<>) (j e) (fmap f' ds) - j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1 + j' e@(DoNotationValue v) = j e <>. g' v + j' e@(DoNotationBind b v) = j e <>. h' b <>. g' v + j' e@(DoNotationLet ds) = foldl (<>.) (j e) (fmap f' ds) + j' e@(PositionedDoNotationElement _ _ e1) = j e <>. j' e1 k' :: Guard -> r k' (ConditionGuard e) = g' e - k' (PatternGuard b e) = h' b <> g' e + k' (PatternGuard b e) = h' b <>. g' e everythingWithContextOnValues :: forall s r @@ -340,50 +340,50 @@ everythingWithContextOnValues , Binder -> r , CaseAlternative -> r , DoNotationElement -> r) -everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0) +everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0) where f'' :: s -> Declaration -> r - f'' s d = let (s', r) = f s d in r <> f' s' d + f'' s d = let (s', r) = f s d in r <>. f' s' d f' :: s -> Declaration -> r - f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (fmap (f'' s) ds) - f' s (ValueDeclaration vd) = foldl (<>) r0 (fmap (h'' s) (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) (valdeclExpression vd)) - f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (fmap (\(_, _, val) -> g'' s val) ds) - f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>) r0 (fmap (f'' s) ds) - f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (fmap (f'' s) ds) + f' s (DataBindingGroupDeclaration ds) = foldl (<>.) r0 (fmap (f'' s) ds) + f' s (ValueDeclaration vd) = foldl (<>.) r0 (fmap (h'' s) (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) (valdeclExpression vd)) + f' s (BindingGroupDeclaration ds) = foldl (<>.) r0 (fmap (\(_, _, val) -> g'' s val) ds) + f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>.) r0 (fmap (f'' s) ds) + f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>.) r0 (fmap (f'' s) ds) f' _ _ = r0 g'' :: s -> Expr -> r - g'' s v = let (s', r) = g s v in r <> g' s' v + g'' s v = let (s', r) = g s v in r <>. g' s' v g' :: s -> Expr -> r g' s (Literal _ l) = lit g'' s l g' s (UnaryMinus _ v1) = g'' s v1 - g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 + g' s (BinaryNoParens op v1 v2) = g'' s op <>. g'' s v1 <>. g'' s v2 g' s (Parens v1) = g'' s v1 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 - g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s . snd) vs) - g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s) vs) - g' s (Abs binder v1) = h'' s binder <> g'' s v1 - g' s (App v1 v2) = g'' s v1 <> g'' s v2 - g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 - g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (fmap (g'' s) vs)) (fmap (i'' s) alts) + g' s (ObjectUpdate obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s . snd) vs) + g' s (ObjectUpdateNested obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s) vs) + g' s (Abs binder v1) = h'' s binder <>. g'' s v1 + g' s (App v1 v2) = g'' s v1 <>. g'' s v2 + g' s (IfThenElse v1 v2 v3) = g'' s v1 <>. g'' s v2 <>. g'' s v3 + g' s (Case vs alts) = foldl (<>.) (foldl (<>.) r0 (fmap (g'' s) vs)) (fmap (i'' s) alts) g' s (TypedValue _ v1 _) = g'' s v1 - g' s (Let _ ds v1) = foldl (<>) r0 (fmap (f'' s) ds) <> g'' s v1 - g' s (Do es) = foldl (<>) r0 (fmap (j'' s) es) - g' s (Ado es v1) = foldl (<>) r0 (fmap (j'' s) es) <> g'' s v1 + g' s (Let _ ds v1) = foldl (<>.) r0 (fmap (f'' s) ds) <>. g'' s v1 + g' s (Do es) = foldl (<>.) r0 (fmap (j'' s) es) + g' s (Ado es v1) = foldl (<>.) r0 (fmap (j'' s) es) <>. g'' s v1 g' s (PositionedValue _ _ v1) = g'' s v1 g' _ _ = r0 h'' :: s -> Binder -> r - h'' s b = let (s', r) = h s b in r <> h' s' b + h'' s b = let (s', r) = h s b in r <>. h' s' b h' :: s -> Binder -> r h' s (LiteralBinder _ l) = lit h'' s l - h' s (ConstructorBinder _ _ bs) = foldl (<>) r0 (fmap (h'' s) bs) - h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3 + h' s (ConstructorBinder _ _ bs) = foldl (<>.) r0 (fmap (h'' s) bs) + h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <>. h'' s b2 <>. h'' s b3 h' s (ParensInBinder b) = h'' s b h' s (NamedBinder _ _ b1) = h'' s b1 h' s (PositionedBinder _ _ b1) = h'' s b1 @@ -391,28 +391,28 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i' h' _ _ = r0 lit :: (s -> a -> r) -> s -> Literal a -> r - lit go s (ArrayLiteral as) = foldl (<>) r0 (fmap (go s) as) - lit go s (ObjectLiteral as) = foldl (<>) r0 (fmap (go s . snd) as) + lit go s (ArrayLiteral as) = foldl (<>.) r0 (fmap (go s) as) + lit go s (ObjectLiteral as) = foldl (<>.) r0 (fmap (go s . snd) as) lit _ _ _ = r0 i'' :: s -> CaseAlternative -> r - i'' s ca = let (s', r) = i s ca in r <> i' s' ca + i'' s ca = let (s', r) = i s ca in r <>. i' s' ca i' :: s -> CaseAlternative -> r - i' s (CaseAlternative bs gs) = foldl (<>) r0 (fmap (h'' s) bs ++ concatMap (\(GuardedExpr grd val) -> fmap (k' s) grd ++ [g'' s val]) gs) + i' s (CaseAlternative bs gs) = foldl (<>.) r0 (fmap (h'' s) bs ++ concatMap (\(GuardedExpr grd val) -> fmap (k' s) grd ++ [g'' s val]) gs) j'' :: s -> DoNotationElement -> r - j'' s e = let (s', r) = j s e in r <> j' s' e + j'' s e = let (s', r) = j s e in r <>. j' s' e j' :: s -> DoNotationElement -> r j' s (DoNotationValue v) = g'' s v - j' s (DoNotationBind b v) = h'' s b <> g'' s v - j' s (DoNotationLet ds) = foldl (<>) r0 (fmap (f'' s) ds) + j' s (DoNotationBind b v) = h'' s b <>. g'' s v + j' s (DoNotationLet ds) = foldl (<>.) r0 (fmap (f'' s) ds) j' s (PositionedDoNotationElement _ _ e1) = j'' s e1 k' :: s -> Guard -> r k' s (ConditionGuard e) = g'' s e - k' s (PatternGuard b e) = h'' s b <> g'' s e + k' s (PatternGuard b e) = h'' s b <>. g'' s e everywhereWithContextOnValuesM :: forall m s @@ -514,9 +514,6 @@ everythingWithScope ) everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) where - -- Avoid importing Data.Monoid and getting shadowed names above - (<>) = mappend - f'' :: S.Set ScopedIdent -> Declaration -> r f'' s a = f s a <> f' s a @@ -635,7 +632,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con forDecls (DataDeclaration _ _ _ _ dctors) = mconcat (concatMap (fmap f . snd) dctors) forDecls (ExternDeclaration _ _ ty) = f ty forDecls (TypeClassDeclaration _ _ _ implies _ _) = mconcat (concatMap (fmap f . constraintArgs) implies) - forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) `mappend` mconcat (fmap f tys) + forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) <> mconcat (fmap f tys) forDecls (TypeSynonymDeclaration _ _ _ ty) = f ty forDecls (TypeDeclaration td) = f (tydeclType td) forDecls _ = mempty @@ -657,16 +654,16 @@ accumKinds accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) where forDecls (DataDeclaration _ _ _ args dctors) = - foldMap (foldMap f . snd) args `mappend` + foldMap (foldMap f . snd) args <> foldMap (foldMap forTypes . snd) dctors forDecls (TypeClassDeclaration _ _ args implies _ _) = - foldMap (foldMap f . snd) args `mappend` + foldMap (foldMap f . snd) args <> foldMap (foldMap forTypes . constraintArgs) implies forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = - foldMap (foldMap forTypes . constraintArgs) cs `mappend` + foldMap (foldMap forTypes . constraintArgs) cs <> foldMap forTypes tys forDecls (TypeSynonymDeclaration _ _ args ty) = - foldMap (foldMap f . snd) args `mappend` + foldMap (foldMap f . snd) args <> forTypes ty forDecls (TypeDeclaration td) = forTypes (tydeclType td) forDecls (ExternDeclaration _ _ ty) = forTypes ty diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 266c560422..adf235f81e 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -19,7 +19,6 @@ import Data.List ((\\), intersect) import qualified Data.Foldable as F import qualified Data.Map as M import Data.Maybe (fromMaybe, isNothing) -import Data.Monoid ((<>)) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 259cd4afa2..603b75d3c0 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -4,7 +4,6 @@ module Language.PureScript.CodeGen.JS.Common where import Prelude.Compat import Data.Char -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index d8b59dc268..da67fa78eb 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -13,7 +13,6 @@ import Control.PatternArrows import qualified Control.Arrow as A import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs index 20b0cd320f..5415911863 100644 --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -50,27 +50,27 @@ everythingOnValues :: (r -> r -> r) -> (Binder a -> r) -> (CaseAlternative a -> r) -> (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r) -everythingOnValues (<>) f g h i = (f', g', h', i') +everythingOnValues (<>.) f g h i = (f', g', h', i') where - f' b@(NonRec _ _ e) = f b <> g' e - f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es) + f' b@(NonRec _ _ e) = f b <>. g' e + f' b@(Rec es) = foldl (<>.) (f b) (map (g' . snd) es) - g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l)) - g' v@(Accessor _ _ e1) = g v <> g' e1 - g' v@(ObjectUpdate _ obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs) - g' v@(Abs _ _ e1) = g v <> g' e1 - g' v@(App _ e1 e2) = g v <> g' e1 <> g' e2 - g' v@(Case _ vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts) - g' v@(Let _ ds e1) = foldl (<>) (g v) (map f' ds) <> g' e1 + g' v@(Literal _ l) = foldl (<>.) (g v) (map g' (extractLiteral l)) + g' v@(Accessor _ _ e1) = g v <>. g' e1 + g' v@(ObjectUpdate _ obj vs) = foldl (<>.) (g v <>. g' obj) (map (g' . snd) vs) + g' v@(Abs _ _ e1) = g v <>. g' e1 + g' v@(App _ e1 e2) = g v <>. g' e1 <>. g' e2 + g' v@(Case _ vs alts) = foldl (<>.) (foldl (<>.) (g v) (map g' vs)) (map i' alts) + g' v@(Let _ ds e1) = foldl (<>.) (g v) (map f' ds) <>. g' e1 g' v = g v - h' b@(LiteralBinder _ l) = foldl (<>) (h b) (map h' (extractLiteral l)) - h' b@(ConstructorBinder _ _ _ bs) = foldl (<>) (h b) (map h' bs) - h' b@(NamedBinder _ _ b1) = h b <> h' b1 + h' b@(LiteralBinder _ l) = foldl (<>.) (h b) (map h' (extractLiteral l)) + h' b@(ConstructorBinder _ _ _ bs) = foldl (<>.) (h b) (map h' bs) + h' b@(NamedBinder _ _ b1) = h b <>. h' b1 h' b = h b - i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val - i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs) + i' ca@(CaseAlternative bs (Right val)) = foldl (<>.) (i ca) (map h' bs) <>. g' val + i' ca@(CaseAlternative bs (Left gs)) = foldl (<>.) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs) extractLiteral (ArrayLiteral xs) = xs extractLiteral (ObjectLiteral xs) = map snd xs diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs index 36062336ae..b6dcad1446 100644 --- a/src/Language/PureScript/CoreImp/AST.hs +++ b/src/Language/PureScript/CoreImp/AST.hs @@ -201,24 +201,24 @@ everywhereTopDownM f = f >=> go where go other = f other everything :: (r -> r -> r) -> (AST -> r) -> AST -> r -everything (<>) f = go where - go j@(Unary _ _ j1) = f j <> go j1 - go j@(Binary _ _ j1 j2) = f j <> go j1 <> go j2 - go j@(ArrayLiteral _ js) = foldl (<>) (f j) (map go js) - go j@(Indexer _ j1 j2) = f j <> go j1 <> go j2 - go j@(ObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js) - go j@(Function _ _ _ j1) = f j <> go j1 - go j@(App _ j1 js) = foldl (<>) (f j <> go j1) (map go js) - go j@(Block _ js) = foldl (<>) (f j) (map go js) - go j@(VariableIntroduction _ _ (Just j1)) = f j <> go j1 - go j@(Assignment _ j1 j2) = f j <> go j1 <> go j2 - go j@(While _ j1 j2) = f j <> go j1 <> go j2 - go j@(For _ _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3 - go j@(ForIn _ _ j1 j2) = f j <> go j1 <> go j2 - go j@(IfElse _ j1 j2 Nothing) = f j <> go j1 <> go j2 - go j@(IfElse _ j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3 - go j@(Return _ j1) = f j <> go j1 - go j@(Throw _ j1) = f j <> go j1 - go j@(InstanceOf _ j1 j2) = f j <> go j1 <> go j2 - go j@(Comment _ _ j1) = f j <> go j1 +everything (<>.) f = go where + go j@(Unary _ _ j1) = f j <>. go j1 + go j@(Binary _ _ j1 j2) = f j <>. go j1 <>. go j2 + go j@(ArrayLiteral _ js) = foldl (<>.) (f j) (map go js) + go j@(Indexer _ j1 j2) = f j <>. go j1 <>. go j2 + go j@(ObjectLiteral _ js) = foldl (<>.) (f j) (map (go . snd) js) + go j@(Function _ _ _ j1) = f j <>. go j1 + go j@(App _ j1 js) = foldl (<>.) (f j <>. go j1) (map go js) + go j@(Block _ js) = foldl (<>.) (f j) (map go js) + go j@(VariableIntroduction _ _ (Just j1)) = f j <>. go j1 + go j@(Assignment _ j1 j2) = f j <>. go j1 <>. go j2 + go j@(While _ j1 j2) = f j <>. go j1 <>. go j2 + go j@(For _ _ j1 j2 j3) = f j <>. go j1 <>. go j2 <>. go j3 + go j@(ForIn _ _ j1 j2) = f j <>. go j1 <>. go j2 + go j@(IfElse _ j1 j2 Nothing) = f j <>. go j1 <>. go j2 + go j@(IfElse _ j1 j2 (Just j3)) = f j <>. go j1 <>. go j2 <>. go j3 + go j@(Return _ j1) = f j <>. go j1 + go j@(Throw _ j1) = f j <>. go j1 + go j@(InstanceOf _ j1 j2) = f j <>. go j1 <>. go j2 + go j@(Comment _ _ j1) = f j <>. go j1 go other = f other diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index 391f9391d6..96001d3ef5 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -16,7 +16,6 @@ import Prelude.Compat import Control.Monad.Supply.Class (MonadSupply, freshName) import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index 0a5d949668..fcf49fcbef 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -4,7 +4,6 @@ module Language.PureScript.CoreImp.Optimizer.TCO (tco) where import Prelude.Compat import Data.Text (Text) -import Data.Monoid ((<>)) import Language.PureScript.CoreImp.AST import Language.PureScript.AST.SourcePos (SourceSpan) import Safe (headDef, tailSafe) diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index 80856c94cb..adeeab7c54 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -20,7 +20,6 @@ import Control.Monad (unless) import Data.Char (isUpper) import Data.Either (isRight) import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import Data.Foldable (for_) import Data.String (fromString) diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 6cb3b4e47b..13c513baa4 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -13,7 +13,6 @@ import Control.Monad.Error.Class (MonadError) import Control.Monad.Writer (Writer, tell, execWriter) import Data.Foldable (for_) -import Data.Monoid ((<>)) import Data.List (partition) import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 4d48cb14dd..241acaab49 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -14,7 +14,6 @@ import Control.Monad.Trans.State.Strict (execState) import Data.Either import Data.Map (Map) import Data.Maybe (mapMaybe) -import Data.Monoid ((<>)) import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T @@ -415,12 +414,13 @@ data TypeClassEnv = TypeClassEnv } deriving (Show) +instance Semigroup TypeClassEnv where + (TypeClassEnv a1 b1 c1) <> (TypeClassEnv a2 b2 c2) = + TypeClassEnv (a1 <> a2) (b1 <> b2) (c1 <> c2) + instance Monoid TypeClassEnv where mempty = TypeClassEnv mempty mempty mempty - mappend (TypeClassEnv a1 b1 c1) - (TypeClassEnv a2 b2 c2) = - TypeClassEnv (a1 <> a2) (b1 <> b2) (c1 <> c2) -- | -- Take a TypeClassEnv and handle all of the type class members in it, either diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index deaccf2db5..045fe34c4a 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -114,7 +114,7 @@ convertDeclaration (P.ValueDecl sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) convertDeclaration (P.ValueDecl sa _ _ _ _) title = -- If no explicit type declaration was provided, insert a wildcard, so that -- the actual type will be added during type checking. - basicDeclaration sa title (ValueDeclaration P.TypeWildcard{}) + basicDeclaration sa title (ValueDeclaration (P.TypeWildcard (fst sa))) convertDeclaration (P.ExternDeclaration sa _ ty) title = basicDeclaration sa title (ValueDeclaration ty) convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title = diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index ed16e734af..0116788428 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -7,7 +7,6 @@ module Language.PureScript.Docs.Prim ) where import Prelude.Compat hiding (fail) -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Map as Map diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 572449386e..c0c656589f 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -12,7 +12,6 @@ module Language.PureScript.Docs.Render where import Prelude.Compat import Data.Maybe (maybeToList) -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs b/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs index 3539a1244f..bbdbe8ce03 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs @@ -12,7 +12,6 @@ import Prelude.Compat import Control.Arrow (ArrowPlus(..)) import Control.PatternArrows as PA -import Data.Monoid ((<>)) import Data.Maybe (fromMaybe) import qualified Data.Text as T diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index 15f51dc94c..3857dfd171 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -13,7 +13,6 @@ module Language.PureScript.Docs.RenderedCode.RenderType import Prelude.Compat import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import Data.Text (Text) import Control.Arrow ((<+>)) diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 0d64e301b1..ecf1b0a9fb 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -49,7 +49,6 @@ import GHC.Generics (Generic) import Control.DeepSeq (NFData) import Control.Monad.Error.Class (MonadError(..)) -import Data.Monoid ((<>)) import Data.Aeson.BetterErrors (Parse, nth, withText, withValue, toAesonParser, perhaps, asText, eachInArray) import qualified Data.Aeson as A import Data.Text (Text) @@ -248,7 +247,7 @@ asRenderedCodeElement = -- newtype RenderedCode = RC { unRC :: [RenderedCodeElement] } - deriving (Show, Eq, Ord, Monoid) + deriving (Show, Eq, Ord, Semigroup, Monoid) instance A.ToJSON RenderedCode where toJSON (RC elems) = A.toJSON elems diff --git a/src/Language/PureScript/Docs/Utils/MonoidExtras.hs b/src/Language/PureScript/Docs/Utils/MonoidExtras.hs index a9d317e603..0d4d0bfd7f 100644 --- a/src/Language/PureScript/Docs/Utils/MonoidExtras.hs +++ b/src/Language/PureScript/Docs/Utils/MonoidExtras.hs @@ -6,4 +6,3 @@ mintersperse :: (Monoid m) => m -> [m] -> m mintersperse _ [] = mempty mintersperse _ [x] = x mintersperse sep (x:xs) = x <> sep <> mintersperse sep xs - diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 135f98aa2f..0028f3b233 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -186,7 +186,7 @@ errorCode em = case unwrapErrorMessage em of -- | A stack trace for an error newtype MultipleErrors = MultipleErrors { runMultipleErrors :: [ErrorMessage] - } deriving (Show, Monoid) + } deriving (Show, Semigroup, Monoid) -- | Check whether a collection of errors is empty or not. nonEmpty :: MultipleErrors -> Bool diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index 65f872d23b..f552f91f03 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -6,7 +6,6 @@ import Prelude.Compat import qualified Data.Aeson.TH as A import qualified Data.List.NonEmpty as NEL -import Data.Monoid ((<>)) import qualified Data.Text as T import Data.Text (Text) diff --git a/src/Language/PureScript/Hierarchy.hs b/src/Language/PureScript/Hierarchy.hs index 837fd3a33a..db6b9b12f6 100644 --- a/src/Language/PureScript/Hierarchy.hs +++ b/src/Language/PureScript/Hierarchy.hs @@ -19,7 +19,6 @@ import Prelude.Compat import Protolude (ordNub) import Data.List (sort) -import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Language.PureScript as P diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index cdb29f4cbd..b08bb06d0e 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -35,7 +35,7 @@ import Language.PureScript.Ide.Util import qualified Language.PureScript as P newtype Filter = Filter (Endo [Module]) - deriving (Monoid) + deriving (Semigroup, Monoid) type Module = (P.ModuleName, [IdeDeclarationAnn]) diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index 531a29e43c..e5bf21e504 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -35,7 +35,7 @@ import Text.Regex.TDFA ((=~)) type ScoredMatch a = (Match a, Double) -newtype Matcher a = Matcher (Endo [Match a]) deriving (Monoid) +newtype Matcher a = Matcher (Endo [Match a]) deriving (Semigroup, Monoid) instance FromJSON (Matcher IdeDeclarationAnn) where parseJSON = withObject "matcher" $ \o -> do diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 6fbfc5dbb8..efc7a1e44f 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -16,7 +16,6 @@ import Protolude (ordNub) import Data.List (sort, find, foldl') import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M -import Data.Monoid ((<>)) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index 38022a7dc3..608129465e 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -5,7 +5,6 @@ import Prelude.Compat import Data.List (intersperse) import qualified Data.Map as M import Data.Maybe (mapMaybe) -import Data.Monoid ((<>)) import qualified Data.Text as T import Data.Text (Text) import qualified Language.PureScript as P diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 2088a3fb06..01df9dca87 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -102,8 +102,8 @@ everywhereOnKindsM f = go go other = f other everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r -everythingOnKinds (<>) f = go +everythingOnKinds (<>.) f = go where - go k@(Row k1) = f k <> go k1 - go k@(FunKind k1 k2) = f k <> go k1 <> go k2 + go k@(Row k1) = f k <>. go k1 + go k@(FunKind k1 k2) = f k <>. go k1 <>. go k2 go other = f other diff --git a/src/Language/PureScript/Label.hs b/src/Language/PureScript/Label.hs index b00db4fe9b..accd31463e 100644 --- a/src/Language/PureScript/Label.hs +++ b/src/Language/PureScript/Label.hs @@ -17,6 +17,6 @@ import Language.PureScript.PSString (PSString) -- because records are indexable by PureScript strings at runtime. -- newtype Label = Label { runLabel :: PSString } - deriving (Show, Eq, Ord, IsString, Monoid, A.ToJSON, A.FromJSON, Generic) + deriving (Show, Eq, Ord, IsString, Semigroup, Monoid, A.ToJSON, A.FromJSON, Generic) instance NFData Label diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 59f936af25..49ede59811 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -10,7 +10,6 @@ import Control.Monad.Writer.Class import Data.List ((\\)) import Data.Maybe (mapMaybe) -import Data.Monoid import qualified Data.Set as S import Data.Text (Text) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 1965925639..4278f509a3 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -20,7 +20,6 @@ import Control.Monad.Supply.Class (MonadSupply, fresh, freshName) import Data.Function (on) import Data.List (foldl', sortBy) import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 254b83bd5e..53f3aca438 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -24,7 +24,6 @@ import Data.Foldable (for_, minimum) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 16f135f221..e2327c1cc1 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -16,7 +16,6 @@ import Control.DeepSeq (NFData) import GHC.Generics (Generic) import Data.Aeson import Data.Aeson.TH -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index 0dcb3b40cc..f466257f2a 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -21,7 +21,6 @@ import Control.Applicative ((<|>)) import Data.Char (chr) import Data.Bits (shiftR) import Data.List (unfoldr) -import Data.Monoid ((<>)) import Data.Scientific (toBoundedInteger) import Data.String (IsString(..)) import Data.ByteString (ByteString) @@ -52,7 +51,7 @@ import qualified Data.Aeson.Types as A -- and arrays of UTF-16 code units (integers) otherwise. -- newtype PSString = PSString { toUTF16CodeUnits :: [Word16] } - deriving (Eq, Ord, Monoid, Generic) + deriving (Eq, Ord, Semigroup, Monoid, Generic) instance NFData PSString diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index 6f21f9f16d..0b430baabe 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -6,7 +6,6 @@ import Prelude.Compat import Control.Applicative ((<|>)) import Control.Monad (guard) import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.AST.SourcePos diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 12fc38f9ab..bfc77014cb 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -25,7 +25,6 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Parallel.Strategies (withStrategy, parList, rseq) import Data.Functor (($>)) import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import qualified Data.Set as S import Data.Text (Text) import Language.PureScript.AST diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 71812e8977..377d9b18a8 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -70,7 +70,6 @@ import Control.Applicative ((<|>)) import Control.Monad (void, guard) import Control.Monad.Identity (Identity) import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum) -import Data.Monoid ((<>)) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index b7280232e7..e26fa2a3b9 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -10,7 +10,6 @@ import Prelude.Compat import Control.Monad.State (StateT, modify, get) import Data.List (elemIndices, intersperse) -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import Data.Char (isUpper) @@ -55,11 +54,12 @@ newtype StrPos = StrPos (SourcePos, Text, [SMap]) -- appropriately and advancing source mappings on the right hand side to account for -- the length of the left. -- +instance Semigroup StrPos where + StrPos (a,b,c) <> StrPos (a',b',c') = StrPos (a `addPos` a', b <> b', c ++ (bumpPos a <$> c')) + instance Monoid StrPos where mempty = StrPos (SourcePos 0 0, "", []) - StrPos (a,b,c) `mappend` StrPos (a',b',c') = StrPos (a `addPos` a', b <> b', c ++ (bumpPos a <$> c')) - mconcat ms = let s' = foldMap (\(StrPos(_, s, _)) -> s) ms (p, maps) = foldl plus (SourcePos 0 0, []) ms @@ -88,7 +88,7 @@ instance Emit StrPos where mapping = SMap (T.pack file) startPos zeroPos zeroPos = SourcePos 0 0 -newtype PlainString = PlainString Text deriving Monoid +newtype PlainString = PlainString Text deriving (Semigroup, Monoid) runPlainString :: PlainString -> Text runPlainString (PlainString s) = s diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs index 24d4451e78..9f950af9f7 100644 --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -10,7 +10,6 @@ import Prelude.Compat import Control.Arrow (ArrowPlus(..)) import Control.PatternArrows as PA -import Data.Monoid ((<>)) import Data.Maybe (fromMaybe) import qualified Data.Text as T import Data.Text (Text) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index bee62db14c..40c2956eb5 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -14,7 +14,7 @@ module Language.PureScript.Pretty.Types , prettyPrintObjectKey ) where -import Prelude.Compat +import Prelude.Compat hiding ((<>)) import Control.Arrow ((<+>)) import Control.PatternArrows as PA diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index bbabf0821c..7902526c03 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -7,7 +7,7 @@ module Language.PureScript.Pretty.Values , prettyPrintBinderAtom ) where -import Prelude.Compat +import Prelude.Compat hiding ((<>)) import Control.Arrow (second) diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 73545bf488..7d1c6306d0 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -36,7 +36,8 @@ import qualified Data.Text as T import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Version -import qualified Data.SPDX as SPDX +import qualified Distribution.SPDX as SPDX +import qualified Distribution.Parsec.Class as CabalParsec import System.Directory (doesFileExist) import System.FilePath.Glob (globDir1) @@ -230,7 +231,11 @@ checkLicense pkgMeta = -- Check if a string is a valid SPDX license expression. -- isValidSPDX :: String -> Bool -isValidSPDX = (== 1) . length . SPDX.parseExpression +isValidSPDX input = case CabalParsec.simpleParsec input of + Nothing -> False + Just SPDX.NONE -> False + Just _ -> True + extractGithub :: Text -> Maybe (D.GithubUser, D.GithubRepo) extractGithub = stripGitHubPrefixes diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 806739574c..38ebc36aeb 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -311,11 +311,12 @@ data CollectedWarnings = CollectedWarnings } deriving (Show, Eq, Ord) +instance Semigroup CollectedWarnings where + (CollectedWarnings as bs cs d es) <> (CollectedWarnings as' bs' cs' d' es') = + CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') (d <> d') (es <> es') + instance Monoid CollectedWarnings where mempty = CollectedWarnings mempty mempty mempty mempty mempty - mappend (CollectedWarnings as bs cs d es) - (CollectedWarnings as' bs' cs' d' es') = - CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') (d <> d') (es <> es') collectWarnings :: [PackageWarning] -> CollectedWarnings collectWarnings = foldMap singular diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index b99cd9d2ae..4ee82ad0d3 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -10,7 +10,6 @@ import Control.Monad.State import Data.List (find) import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as M -import Data.Monoid ((<>)) import qualified Data.Set as S import qualified Data.Text as T diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index a91cbe72fc..351cb3e0bf 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -12,7 +12,6 @@ import Control.Monad.Supply.Class (MonadSupply) import Data.Foldable (for_) import Data.List (foldl', find, sortBy, unzip5) import qualified Data.Map as M -import Data.Monoid ((<>)) import Data.Maybe (fromMaybe, mapMaybe) import Data.Ord (comparing) import qualified Data.Set as S @@ -42,13 +41,15 @@ data NewtypeDerivedInstances = NewtypeDerivedInstances -- ^ A list of newtype instances which were derived in this module. } deriving Show -instance Monoid NewtypeDerivedInstances where - mempty = NewtypeDerivedInstances mempty mempty - mappend x y = +instance Semigroup NewtypeDerivedInstances where + x <> y = NewtypeDerivedInstances { ndiClasses = ndiClasses x <> ndiClasses y , ndiDerivedInstances = ndiDerivedInstances x <> ndiDerivedInstances y } +instance Monoid NewtypeDerivedInstances where + mempty = NewtypeDerivedInstances mempty mempty + -- | Extract the name of the newtype appearing in the last type argument of -- a derived newtype instance. -- diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 3e293e3f07..dce0b28429 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -22,7 +22,6 @@ import Control.Lens ((^..), _1, _2) import Data.Foldable (for_, traverse_, toList) import Data.List (nub, nubBy, (\\), sort, group) import Data.Maybe -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index b11f064f69..13f8697bfd 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -135,14 +135,15 @@ data Matched t | Unknown deriving (Eq, Show, Functor) +instance Semigroup t => Semigroup (Matched t) where + (Match l) <> (Match r) = Match (l <> r) + Apart <> _ = Apart + _ <> Apart = Apart + _ <> _ = Unknown + instance Monoid t => Monoid (Matched t) where mempty = Match mempty - mappend (Match l) (Match r) = Match (l <> r) - mappend Apart _ = Apart - mappend _ Apart = Apart - mappend _ _ = Unknown - -- | Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. entails diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index f80d87e177..ed7659c92f 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -14,7 +14,6 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets, modify) import Data.Foldable (traverse_) import Data.Functor.Identity (Identity(), runIdentity) -import Data.Monoid import Data.Set (Set, fromList, notMember) import Data.Text (Text) import Language.PureScript.AST diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 920d159a6b..51dac649e6 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -39,7 +39,6 @@ import Data.Either (partitionEithers) import Data.Functor (($>)) import Data.List (transpose, (\\), partition, delete) import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import Data.Traversable (for) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index af00286035..84b569ca80 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -7,7 +7,6 @@ import Prelude.Compat import GHC.Generics (Generic) import Control.DeepSeq (NFData) -import Data.Monoid ((<>)) import Data.Text (Text, pack) import Language.PureScript.Names diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index d600bf47f7..3ec79431a1 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -18,7 +18,6 @@ import qualified Data.Aeson.TH as A import Data.List (sortBy) import Data.Ord (comparing) import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) diff --git a/stack.yaml b/stack.yaml index 54c5cf306b..42dbab2418 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-11.7 +resolver: lts-12.0 packages: - '.' extra-deps: diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 9c3bed7a0f..2585f2507e 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -40,7 +40,6 @@ import Control.Monad import Control.Arrow ((***), (>>>)) import Control.Monad.Reader -import Control.Monad.Writer.Strict import Control.Monad.Trans.Except import System.Exit diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index 7c2722038a..2fcb158291 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -9,7 +9,7 @@ import Prelude () import Prelude.Compat import Data.Aeson -import Data.Aeson.Types +import Data.Aeson.Types as Aeson import Data.Version import Language.PureScript.AST.Literals @@ -37,7 +37,7 @@ parseMod m = in snd <$> parseModule (moduleToJSON v m) isSuccess :: Result a -> Bool -isSuccess (Success _) = True +isSuccess (Aeson.Success _) = True isSuccess _ = False spec :: Spec @@ -52,42 +52,42 @@ spec = context "CoreFnFromJsonTest" $ do r `shouldSatisfy` isSuccess case r of Error _ -> return () - Success m -> moduleName m `shouldBe` mn + Aeson.Success m -> moduleName m `shouldBe` mn specify "should parse source span" $ do let r = parseMod $ Module ss [] mn mp [] [] [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () - Success m -> moduleSourceSpan m `shouldBe` ss + Aeson.Success m -> moduleSourceSpan m `shouldBe` ss specify "should parse module path" $ do let r = parseMod $ Module ss [] mn mp [] [] [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () - Success m -> modulePath m `shouldBe` mp + Aeson.Success m -> modulePath m `shouldBe` mp specify "should parse imports" $ do let r = parseMod $ Module ss [] mn mp [(ann, mn)] [] [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () - Success m -> moduleImports m `shouldBe` [(ann, mn)] + Aeson.Success m -> moduleImports m `shouldBe` [(ann, mn)] specify "should parse exports" $ do let r = parseMod $ Module ss [] mn mp [] [Ident "exp"] [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () - Success m -> moduleExports m `shouldBe` [Ident "exp"] + Aeson.Success m -> moduleExports m `shouldBe` [Ident "exp"] specify "should parse foreign" $ do let r = parseMod $ Module ss [] mn mp [] [] [Ident "exp"] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () - Success m -> moduleForeign m `shouldBe` [Ident "exp"] + Aeson.Success m -> moduleForeign m `shouldBe` [Ident "exp"] context "Expr" $ do specify "should parse literals" $ do diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index 1eb68d50e8..584c8a9681 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -3,7 +3,6 @@ module TestPrimDocs where import Prelude import Control.Monad -import Data.Monoid ((<>)) import Data.List ((\\)) import qualified Data.Map as Map import qualified Data.Set as Set From f6cf990c9f64f272ff84b7577b5a026b832fe036 Mon Sep 17 00:00:00 2001 From: Justin Woo Date: Sat, 11 Aug 2018 12:48:51 +0200 Subject: [PATCH 1005/1580] Set --haddock flag based on BUILD_TYPE per joneshf (#3409) * Set --haddock flag based on BUILD_TYPE per joneshf * set lower timeout --- travis/build.sh | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/travis/build.sh b/travis/build.sh index 5cee10e709..449074ab22 100755 --- a/travis/build.sh +++ b/travis/build.sh @@ -2,11 +2,12 @@ set -e STACK="stack --no-terminal --jobs=1" +[[ "$BUILD_TYPE" == "haddock" ]] && DEPS_HADDOCK="--haddock" # Setup & install dependencies or abort ret=0 -$TIMEOUT 45m $STACK --install-ghc build \ - --only-dependencies --test --haddock \ +$TIMEOUT 40m $STACK --install-ghc build \ + --only-dependencies --test $DEPS_HADDOCK \ || ret=$? case "$ret" in 0) # continue From 6bae3b7fda5e4ef41cac732e73a2c180b0272949 Mon Sep 17 00:00:00 2001 From: Hardy Jones Date: Sat, 11 Aug 2018 03:50:34 -0700 Subject: [PATCH 1006/1580] Use `microlens-platform` instead of `lens` (#3400) `lens` is pretty big of a dependency with many transitive dependencies. Build times with `lens` are kind of long. We use a small subset of `lens`, almost everything we use also exists in `microlens`. The few things we don't use are available in `microlens-ghc`, `microlens-mtl`, and `microlens-th`. And `microlens-platform` bundles all of that stuff together. `microlens-platform` is a much smaller dependency. We _could_ drop down to `microlens` (which purports a 3.5s build time). but that would take some bigger changes. This change was small and quick, and that seems ideal to see if it's a worthwhile change. --- package.yaml | 2 +- src/Language/PureScript/Ide/Completion.hs | 2 +- src/Language/PureScript/Ide/Externs.hs | 2 +- src/Language/PureScript/Ide/Imports.hs | 2 +- src/Language/PureScript/Ide/Reexports.hs | 2 +- src/Language/PureScript/Ide/State.hs | 4 +-- src/Language/PureScript/Ide/Types.hs | 38 ++++++++++++++++++++-- src/Language/PureScript/Ide/Usage.hs | 2 +- src/Language/PureScript/Ide/Util.hs | 16 ++++----- src/Language/PureScript/TypeChecker.hs | 3 +- tests/Language/PureScript/Ide/StateSpec.hs | 4 +-- 11 files changed, 56 insertions(+), 21 deletions(-) diff --git a/package.yaml b/package.yaml index 01094bf840..96793c44e9 100644 --- a/package.yaml +++ b/package.yaml @@ -56,8 +56,8 @@ dependencies: - Glob >=0.9 && <0.10 - haskeline >=0.7.0.0 - language-javascript >=0.6.0.9 && <0.7 - - lens ==4.* - lifted-base >=0.2.3 && <0.2.4 + - microlens-platform >=0.3.9.0 && <0.4 - monad-control >=1.0.0.0 && <1.1 - monad-logger >=0.3 && <0.4 - mtl >=2.1.0 && <2.3.0 diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index eace77b3fa..d03ac6081f 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -11,7 +11,6 @@ module Language.PureScript.Ide.Completion import Protolude hiding ((<&>), moduleName) -import Control.Lens hiding ((&), op) import Data.Aeson import qualified Data.Map as Map import qualified Data.Text as T @@ -21,6 +20,7 @@ import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import Lens.Micro.Platform hiding ((&)) type Module = (P.ModuleName, [IdeDeclarationAnn]) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index ca7a53d5a7..df65a9a0ec 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -21,7 +21,6 @@ module Language.PureScript.Ide.Externs import Protolude hiding (to, from, (&)) -import Control.Lens import "monad-logger" Control.Monad.Logger import Data.Aeson (decodeStrict) import Data.Aeson.Types (withObject, parseMaybe, (.:)) @@ -29,6 +28,7 @@ import qualified Data.ByteString as BS import Data.Version (showVersion) import Language.PureScript.Ide.Error (IdeError (..)) import Language.PureScript.Ide.Types +import Lens.Micro.Platform import qualified Language.PureScript as P diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 382523e52a..f52cd63048 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -32,7 +32,6 @@ module Language.PureScript.Ide.Imports import Protolude hiding (moduleName) -import Control.Lens ((^.), (%~), ix) import Data.List (findIndex, nubBy, partition) import qualified Data.Map as Map import qualified Data.Text as T @@ -45,6 +44,7 @@ import Language.PureScript.Ide.State import Language.PureScript.Ide.Prim import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import Lens.Micro.Platform ((^.), (%~), ix) import System.IO.UTF8 (writeUTF8FileT) import qualified Text.Parsec as Parsec diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 82a639c9cb..71c73d4a1d 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -25,11 +25,11 @@ module Language.PureScript.Ide.Reexports import Protolude hiding (moduleName) -import Control.Lens hiding ((&)) import qualified Data.Map as Map import qualified Language.PureScript as P import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import Lens.Micro.Platform hiding ((&)) -- | Contains the module with resolved reexports, and possible failures data ReexportResult a diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index b34f465d7d..3ab0ece73f 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -41,7 +41,6 @@ import Protolude hiding (moduleName) import Control.Arrow import Control.Concurrent.STM -import Control.Lens hiding (op, (&)) import "monad-logger" Control.Monad.Logger import qualified Data.Map.Lazy as Map import qualified Language.PureScript as P @@ -52,6 +51,7 @@ import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import Lens.Micro.Platform hiding ((&)) -- | Resets all State inside psc-ide resetIdeState :: Ide m => m () @@ -329,7 +329,7 @@ resolveInstances externs declarations = mapIf matchTC (idaDeclaration . _IdeDeclTypeClass . ideTCInstances - %~ cons ideInstance) + %~ (ideInstance :)) in acc' & ix classModule %~ updateDeclaration diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 585b59ee9e..f096769337 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -22,11 +22,11 @@ module Language.PureScript.Ide.Types where import Protolude hiding (moduleName) import Control.Concurrent.STM -import Control.Lens.TH import Data.Aeson import qualified Data.Map.Lazy as M import qualified Language.PureScript as P import qualified Language.PureScript.Errors.JSON as P +import Lens.Micro.Platform hiding ((.=)) type ModuleIdent = Text type ModuleMap a = Map P.ModuleName a @@ -94,7 +94,41 @@ data IdeTypeOperator = IdeTypeOperator , _ideTypeOpKind :: Maybe P.Kind } deriving (Show, Eq, Ord, Generic, NFData) -makePrisms ''IdeDeclaration +_IdeDeclValue :: Traversal' IdeDeclaration IdeValue +_IdeDeclValue f (IdeDeclValue x) = map IdeDeclValue (f x) +_IdeDeclValue _ x = pure x + +_IdeDeclType :: Traversal' IdeDeclaration IdeType +_IdeDeclType f (IdeDeclType x) = map IdeDeclType (f x) +_IdeDeclType _ x = pure x + +_IdeDeclTypeSynonym :: Traversal' IdeDeclaration IdeTypeSynonym +_IdeDeclTypeSynonym f (IdeDeclTypeSynonym x) = map IdeDeclTypeSynonym (f x) +_IdeDeclTypeSynonym _ x = pure x + +_IdeDeclDataConstructor :: Traversal' IdeDeclaration IdeDataConstructor +_IdeDeclDataConstructor f (IdeDeclDataConstructor x) = map IdeDeclDataConstructor (f x) +_IdeDeclDataConstructor _ x = pure x + +_IdeDeclTypeClass :: Traversal' IdeDeclaration IdeTypeClass +_IdeDeclTypeClass f (IdeDeclTypeClass x) = map IdeDeclTypeClass (f x) +_IdeDeclTypeClass _ x = pure x + +_IdeDeclValueOperator :: Traversal' IdeDeclaration IdeValueOperator +_IdeDeclValueOperator f (IdeDeclValueOperator x) = map IdeDeclValueOperator (f x) +_IdeDeclValueOperator _ x = pure x + +_IdeDeclTypeOperator :: Traversal' IdeDeclaration IdeTypeOperator +_IdeDeclTypeOperator f (IdeDeclTypeOperator x) = map IdeDeclTypeOperator (f x) +_IdeDeclTypeOperator _ x = pure x + +_IdeDeclKind :: Traversal' IdeDeclaration (P.ProperName 'P.KindName) +_IdeDeclKind f (IdeDeclKind x) = map IdeDeclKind (f x) +_IdeDeclKind _ x = pure x + +anyOf :: Getting Any s a -> (a -> Bool) -> s -> Bool +anyOf g p = getAny . getConst . g (Const . Any . p) + makeLenses ''IdeValue makeLenses ''IdeType makeLenses ''IdeTypeSynonym diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index 9ffa5e9a1a..189032909e 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -8,13 +8,13 @@ module Language.PureScript.Ide.Usage import Protolude hiding (moduleName) -import Control.Lens (preview) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Language.PureScript as P import Language.PureScript.Ide.State (getAllModules, getFileState) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import Lens.Micro.Platform (preview) -- | -- How we find usages, given an IdeDeclaration and the module it was defined in: diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 47489e8df0..46824c1104 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -30,9 +30,8 @@ module Language.PureScript.Ide.Util ) where import Protolude hiding (decodeUtf8, - encodeUtf8) + encodeUtf8, to) -import Control.Lens hiding ((&), op) import Data.Aeson import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding as TLE @@ -40,6 +39,7 @@ import qualified Language.PureScript as P import Language.PureScript.Ide.Error (IdeError(..)) import Language.PureScript.Ide.Logging import Language.PureScript.Ide.Types +import Lens.Micro.Platform hiding ((&)) import System.IO.UTF8 (readUTF8FileT) import System.Directory (makeAbsolute) @@ -90,14 +90,14 @@ encodeT = TL.toStrict . TLE.decodeUtf8 . encode decodeT :: (FromJSON a) => Text -> Maybe a decodeT = decode . TLE.encodeUtf8 . TL.fromStrict -properNameT :: Iso' (P.ProperName a) Text -properNameT = iso P.runProperName P.ProperName +properNameT :: Getting r (P.ProperName a) Text +properNameT = to P.runProperName -identT :: Iso' P.Ident Text -identT = iso P.runIdent P.Ident +identT :: Getting r P.Ident Text +identT = to P.runIdent -opNameT :: Iso' (P.OpName a) Text -opNameT = iso P.runOpName P.OpName +opNameT :: Getting r (P.OpName a) Text +opNameT = to P.runOpName ideReadFile' :: (MonadIO m, MonadError IdeError m) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index dce0b28429..3a490e3f07 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -17,7 +17,6 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), modify, gets) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Writer.Class (MonadWriter(..)) -import Control.Lens ((^..), _1, _2) import Data.Foldable (for_, traverse_, toList) import Data.List (nub, nubBy, (\\), sort, group) @@ -42,6 +41,8 @@ import Language.PureScript.TypeChecker.Types as T import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types +import Lens.Micro.Platform ((^..), _1, _2) + addDataType :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index 67a66713d8..33d9f3071f 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -3,11 +3,11 @@ module Language.PureScript.Ide.StateSpec where import Protolude -import Control.Lens hiding ((&)) import Language.PureScript.Ide.Types import Language.PureScript.Ide.State import Language.PureScript.Ide.Test import qualified Language.PureScript as P +import Lens.Micro.Platform hiding ((&)) import Test.Hspec import qualified Data.Map as Map @@ -91,7 +91,7 @@ spec = do it "resolves an instance for an existing type class" $ do resolveInstances (Map.singleton (mn "InstanceModule") ef) moduleMap `shouldSatisfy` - elemOf (ix (mn "ClassModule") . ix 0 . idaDeclaration . _IdeDeclTypeClass . ideTCInstances . folded) ideInstance + anyOf (ix (mn "ClassModule") . ix 0 . idaDeclaration . _IdeDeclTypeClass . ideTCInstances . folded) (ideInstance ==) describe "resolving data constructors" $ do it "resolves a constructor" $ do resolveDataConstructorsForModule (snd testModule) From 5bb72bfab88481efd82bd4ac1b31a3a11fd8def5 Mon Sep 17 00:00:00 2001 From: Stefan Fehrenbach Date: Sat, 11 Aug 2018 11:51:42 +0100 Subject: [PATCH 1007/1580] Print types of missing typeclass members (#3398) * Print type of missing typeclass member * Print all missing type class members --- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Errors.hs | 8 ++++++-- src/Language/PureScript/Sugar/TypeClasses.hs | 16 ++++++++++------ tests/purs/failing/MissingClassMember.purs | 3 +-- 4 files changed, 18 insertions(+), 11 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 9c820071dc..2725f5da67 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -124,7 +124,7 @@ data SimpleErrorMessage | DuplicateValueDeclaration Ident | ArgListLengthsDiffer Ident | OverlappingArgNames (Maybe Ident) - | MissingClassMember Ident + | MissingClassMember (NEL.NonEmpty (Ident, Type)) | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName)) | ExpectedType Type Kind -- | constructor name, expected argument count, actual argument count diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 0028f3b233..fe351e4078 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -753,8 +753,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "Argument list lengths differ in declaration " <> markCode (showIdent ident) renderSimpleErrorMessage (OverlappingArgNames ident) = line $ "Overlapping names in function/binder" <> foldMap ((" in declaration " <>) . showIdent) ident - renderSimpleErrorMessage (MissingClassMember ident) = - line $ "Type class member " <> markCode (showIdent ident) <> " has not been implemented." + renderSimpleErrorMessage (MissingClassMember identsAndTypes) = + paras $ [ line "The following type class members have not been implemented:" + , Box.vcat Box.left + [ markCodeBox $ Box.text (T.unpack (showIdent ident)) Box.<> " :: " Box.<> typeAsBox ty + | (ident, ty) <- NEL.toList identsAndTypes ] + ] renderSimpleErrorMessage (ExtraneousClassMember ident className) = line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className) renderSimpleErrorMessage (ExpectedType ty kind) = diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index a6c80750b7..0645bcde7d 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -14,9 +14,11 @@ import Control.Arrow (first, second) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State import Control.Monad.Supply.Class -import Data.List ((\\), find, sortBy) +import Data.List (find, sortBy) import qualified Data.Map as M import Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Set as S import Data.Text (Text) import qualified Language.PureScript.Constants as C import Language.PureScript.Crash @@ -285,12 +287,14 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = maybe (throwError . errorMessage' ss . UnknownName $ fmap TyClassName className) return $ M.lookup (qualify mn className) m - case map fst typeClassMembers \\ mapMaybe declIdent decls of - member : _ -> throwError . errorMessage' ss $ MissingClassMember member - [] -> do - -- Replace the type arguments with the appropriate types in the member types - let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers + -- Replace the type arguments with the appropriate types in the member types + let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers + + let declaredMembers = S.fromList $ mapMaybe declIdent decls + case filter (\(ident, _) -> not $ S.member ident declaredMembers) memberTypes of + hd : tl -> throwError . errorMessage' ss $ MissingClassMember (hd NEL.:| tl) + [] -> do -- Create values for the type instance members members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls diff --git a/tests/purs/failing/MissingClassMember.purs b/tests/purs/failing/MissingClassMember.purs index 488fccfc99..42a06a927f 100644 --- a/tests/purs/failing/MissingClassMember.purs +++ b/tests/purs/failing/MissingClassMember.purs @@ -1,11 +1,10 @@ -- @shouldFailWith MissingClassMember module Main where -import Prelude - class A a where a :: a -> String b :: a -> Number + c :: forall f. a -> f a instance aString :: A String where a s = s From b07042fb7b4f6a68c0fdc68b7e51076b7106cfba Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 28 Aug 2018 13:13:02 +0100 Subject: [PATCH 1008/1580] Update README.md (#3423) --- README.md | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/README.md b/README.md index f5db507c08..f2239f35e0 100644 --- a/README.md +++ b/README.md @@ -20,7 +20,5 @@ A small strongly typed programming language with expressive types that compiles ## Help! - [#purescript @ FP Slack](https://functionalprogramming.slack.com/) -- [PureScript Language Forum](https://purescript-users.ml/) +- [PureScript Language Forum](https://discourse.purescript.org/) - [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript) -- [Google Group](https://groups.google.com/forum/#!forum/purescript) -- [Gitter Channel](https://gitter.im/purescript/purescript?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) From fb8daff44cce61fb404d30695065769fef582401 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Thu, 6 Sep 2018 11:18:28 +0200 Subject: [PATCH 1009/1580] Error spans for CannotFindDerivingType (#3425) * adds a failing test for the CannotFindDericingType error * adds a source span to the CannotFindDerivingType error Fixes #3405 * tasty changed its pattern syntax, so we need to update the example --- CONTRIBUTING.md | 2 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 17 +++++++++-------- tests/purs/failing/3405.purs | 8 ++++++++ 3 files changed, 18 insertions(+), 9 deletions(-) create mode 100644 tests/purs/failing/3405.purs diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 0cb15ff9a0..dc455d66e8 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -23,7 +23,7 @@ or `hierarchy`. To build and run a specific test in `tests/purs/passing/` or `tests/purs/failing/`, add test arguments like so: -`stack test --fast --test-arguments="-p compiler/**1110.purs*"` +`stack test --fast --test-arguments="-p 1110.purs"` This will run whatever test uses the example file `1110.purs`. diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 351cb3e0bf..32398ad956 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -202,7 +202,7 @@ deriveNewtypeInstance -> m Expr deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do verifySuperclasses - tyCon <- findTypeDecl tyConNm ds + tyCon <- findTypeDecl ss tyConNm ds go tyCon where go (DataDeclaration _ Newtype _ tyArgNames [(_, [wrapped])]) = do @@ -288,7 +288,7 @@ deriveGenericRep -> m ([Declaration], Type) deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do checkIsWildcard ss tyConNm repTy - go =<< findTypeDecl tyConNm ds + go =<< findTypeDecl ss tyConNm ds where go :: Declaration -> m ([Declaration], Type) go (DataDeclaration (ss', _) _ _ args dctors) = do @@ -441,7 +441,7 @@ deriveEq -> ProperName 'TypeName -> m [Declaration] deriveEq ss mn syns ds tyConNm = do - tyCon <- findTypeDecl tyConNm ds + tyCon <- findTypeDecl ss tyConNm ds eqFun <- mkEqFunction tyCon return [ ValueDecl (ss, []) (Ident C.eq) Public [] (unguarded eqFun) ] where @@ -509,7 +509,7 @@ deriveOrd -> ProperName 'TypeName -> m [Declaration] deriveOrd ss mn syns ds tyConNm = do - tyCon <- findTypeDecl tyConNm ds + tyCon <- findTypeDecl ss tyConNm ds compareFun <- mkCompareFunction tyCon return [ ValueDecl (ss, []) (Ident C.compare) Public [] (unguarded compareFun) ] where @@ -613,7 +613,7 @@ deriveNewtype -> m ([Declaration], Type) deriveNewtype ss mn syns ds tyConNm tyConArgs unwrappedTy = do checkIsWildcard ss tyConNm unwrappedTy - go =<< findTypeDecl tyConNm ds + go =<< findTypeDecl ss tyConNm ds where go :: Declaration -> m ([Declaration], Type) go (DataDeclaration (ss', _) Data name _ _) = @@ -640,10 +640,11 @@ deriveNewtype ss mn syns ds tyConNm tyConArgs unwrappedTy = do findTypeDecl :: (MonadError MultipleErrors m) - => ProperName 'TypeName + => SourceSpan + -> ProperName 'TypeName -> [Declaration] -> m Declaration -findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl +findTypeDecl ss tyConNm = maybe (throwError . errorMessage' ss $ CannotFindDerivingType tyConNm) return . find isTypeDecl where isTypeDecl :: Declaration -> Bool isTypeDecl (DataDeclaration _ _ nm _ _) | nm == tyConNm = True @@ -693,7 +694,7 @@ deriveFunctor -> ProperName 'TypeName -> m [Declaration] deriveFunctor ss mn syns ds tyConNm = do - tyCon <- findTypeDecl tyConNm ds + tyCon <- findTypeDecl ss tyConNm ds mapFun <- mkMapFunction tyCon return [ ValueDecl (ss, []) (Ident C.map) Public [] (unguarded mapFun) ] where diff --git a/tests/purs/failing/3405.purs b/tests/purs/failing/3405.purs new file mode 100644 index 0000000000..de7ab7ca02 --- /dev/null +++ b/tests/purs/failing/3405.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith CannotFindDerivingType +module Main where + +import Prelude + +type Something = Int + +derive instance eqSomething ∷ Eq Something From 5ab1a792d45ffeff720ff97d8cbdf24e82637adf Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 24 Sep 2018 12:35:47 +0200 Subject: [PATCH 1010/1580] Avoid Data.ByteString.Lazy.toStrict (#3433) --- app/Command/Bundle.hs | 5 ++--- app/Command/Compile.hs | 5 ++--- src/Language/PureScript/Make/Actions.hs | 4 ++-- 3 files changed, 6 insertions(+), 8 deletions(-) diff --git a/app/Command/Bundle.hs b/app/Command/Bundle.hs index 115c439a36..5666a0f915 100644 --- a/app/Command/Bundle.hs +++ b/app/Command/Bundle.hs @@ -20,8 +20,7 @@ import System.Exit (exitFailure) import System.IO (stderr, hPutStr, hPutStrLn) import System.IO.UTF8 (readUTF8File, writeUTF8File) import System.Directory (createDirectoryIfMissing, getCurrentDirectory) -import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString.UTF8 as BU8 +import qualified Data.ByteString.Lazy.UTF8 as LBU8 import Language.PureScript.Bundle import Options.Applicative (Parser) import qualified Options.Applicative as Opts @@ -123,6 +122,6 @@ command = run <$> (Opts.helper <*> options) where case sourcemap of Just sm -> do writeUTF8File outputFile $ js ++ "\n//# sourceMappingURL=" ++ (takeFileName outputFile <.> "map") ++ "\n" - writeUTF8File (outputFile <.> "map") $ BU8.toString . B.toStrict . encode $ generate sm + writeUTF8File (outputFile <.> "map") $ LBU8.toString . encode $ generate sm Nothing -> writeUTF8File outputFile js Nothing -> putStrLn js diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 713524c595..9ef05031e1 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -10,8 +10,7 @@ import Control.Applicative import Control.Monad import qualified Data.Aeson as A import Data.Bool (bool) -import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString.UTF8 as BU8 +import qualified Data.ByteString.Lazy.UTF8 as LBU8 import Data.List (intercalate) import qualified Data.Map as M import qualified Data.Set as S @@ -51,7 +50,7 @@ printWarningsAndErrors verbose False warnings errors = do exitFailure Right _ -> return () printWarningsAndErrors verbose True warnings errors = do - hPutStrLn stderr . BU8.toString . B.toStrict . A.encode $ + hPutStrLn stderr . LBU8.toString . A.encode $ JSONResult (toJSONErrors verbose P.Warning warnings) (either (toJSONErrors verbose P.Error) (const []) errors) either (const exitFailure) (const (return ())) errors diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 53f3aca438..13b50b36f6 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -18,7 +18,7 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Aeson (encode) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy as LB -import qualified Data.ByteString.UTF8 as BU8 +import qualified Data.ByteString.Lazy.UTF8 as LBU8 import Data.Either (partitionEithers) import Data.Foldable (for_, minimum) import qualified Data.List.NonEmpty as NEL @@ -229,7 +229,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make () checkForeignDecls m path = do jsStr <- lift $ readTextFile path - js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse (BU8.toString (B.toStrict jsStr)) path + js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse (LBU8.toString jsStr) path foreignIdentsStrs <- either errorParsingModule pure $ getExps js foreignIdents <- either From a8e0911222f46411776978a13866eb097175162c Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 24 Sep 2018 14:08:53 +0200 Subject: [PATCH 1011/1580] Added ffiCodegen to MakeActions (#3434) * Added ffiCodegen to MakeActions * Silence ffiCodegen in IDE --- src/Language/PureScript/Ide/Rebuild.hs | 7 ++--- src/Language/PureScript/Make.hs | 1 + src/Language/PureScript/Make/Actions.hs | 35 ++++++++++++++++++------- 3 files changed, 30 insertions(+), 13 deletions(-) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 84555a5413..7bd97997c9 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -154,11 +154,12 @@ shushProgress :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make shushProgress ma _ = ma { P.progress = \_ -> pure () } --- | Stops any kind of codegen (also silences errors about missing or unused FFI --- files though) +-- | Stops any kind of codegen shushCodegen :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make shushCodegen ma MakeActionsEnv{..} = - ma { P.codegen = \_ _ _ -> pure () } + ma { P.codegen = \_ _ _ -> pure () + , P.ffiCodegen = \_ -> pure () + } -- | Returns a topologically sorted list of dependent ExternsFiles for the given -- module. Throws an error if there is a cyclic dependency within the diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 112ddbdf13..0341ee25da 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -75,6 +75,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do optimized = CF.optimizeCoreFn corefn [renamed] = renameInModules [optimized] exts = moduleToExternsFile mod' env' + ffiCodegen renamed evalSupplyT nextVar' . codegen renamed env' . encode $ exts return exts diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 13b50b36f6..b5e7743735 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -4,6 +4,7 @@ module Language.PureScript.Make.Actions , Externs() , ProgressMessage(..) , buildMakeActions + , checkForeignDecls ) where import Prelude @@ -95,6 +96,8 @@ data MakeActions m = MakeActions -- path for the file. , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m () -- ^ Run the code generator for the module and write any required output files. + , ffiCodegen :: CF.Module CF.Ann -> m () + -- ^ Check ffi and print it in the output directory. , progress :: ProgressMessage -> m () -- ^ Respond to a progress update. } @@ -111,7 +114,7 @@ buildMakeActions -- ^ Generate a prefix comment? -> MakeActions Make buildMakeActions outputDir filePathMap foreigns usePrefix = - MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress + MakeActions getInputTimestamp getOutputTimestamp readExterns codegen ffiCodegen progress where getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime)) @@ -155,12 +158,10 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = lift $ writeTextFile coreFnFile (encode json) when (S.member JS codegenTargets) $ do foreignInclude <- case mn `M.lookup` foreigns of - Just path + Just _ | not $ requiresForeign m -> do - tell $ errorMessage' (CF.moduleSourceSpan m) $ UnnecessaryFFIModule mn path return Nothing | otherwise -> do - checkForeignDecls m path return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign.js"] Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn | otherwise -> return Nothing @@ -168,7 +169,6 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory let sourceMaps = S.member JSSourceMap codegenTargets (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, []) - foreignFile = outputFilename mn "foreign.js" jsFile = targetFilename mn JS mapFile = targetFilename mn JSSourceMap prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix] @@ -176,9 +176,24 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else "" lift $ do writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef) - for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile) when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings + ffiCodegen :: CF.Module CF.Ann -> Make () + ffiCodegen m = do + codegenTargets <- asks optionsCodegenTargets + when (S.member JS codegenTargets) $ do + let mn = CF.moduleName m + foreignFile = outputFilename mn "foreign.js" + case mn `M.lookup` foreigns of + Just path + | not $ requiresForeign m -> + tell $ errorMessage' (CF.moduleSourceSpan m) $ UnnecessaryFFIModule mn path + | otherwise -> + checkForeignDecls m path + Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn + | otherwise -> return () + for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile) + genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do let pathToDir = iterate (".." ) ".." !! length (splitPath $ normalise outputDir) @@ -226,9 +241,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = -- | Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module. -checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make () +checkForeignDecls :: CF.Module ann -> FilePath -> Make () checkForeignDecls m path = do - jsStr <- lift $ readTextFile path + jsStr <- readTextFile path js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse (LBU8.toString jsStr) path foreignIdentsStrs <- either errorParsingModule pure $ getExps js @@ -252,13 +267,13 @@ checkForeignDecls m path = do mname = CF.moduleName m modSS = CF.moduleSourceSpan m - errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a + errorParsingModule :: Bundle.ErrorMessage -> Make a errorParsingModule = throwError . errorMessage' modSS . ErrorParsingFFIModule path . Just getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String] getExps = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname)) - errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a + errorInvalidForeignIdentifiers :: [String] -> Make a errorInvalidForeignIdentifiers = throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack) From 36aa3f91916703d8641e5950aa3a0953880c3aec Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 4 Oct 2018 02:17:16 -0700 Subject: [PATCH 1012/1580] Fixes #3388 (#3437) * Fixes #3388 Rearranges desugaring phases to avoid leaking `ObjectNestedUpdate`. * Fix traversal --- src/Language/PureScript/AST/Traversals.hs | 2 +- tests/purs/passing/3388.purs | 10 ++++++++++ 2 files changed, 11 insertions(+), 1 deletion(-) create mode 100644 tests/purs/passing/3388.purs diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 4852488938..50bf45d835 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -132,7 +132,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds f' (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f' <=< f) ds f' (TypeInstanceDeclaration sa ch idx name cs className args ds) = TypeInstanceDeclaration sa ch idx name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds - f' (BoundValueDeclaration sa b expr) = BoundValueDeclaration sa <$> h' b <*> g' expr + f' (BoundValueDeclaration sa b expr) = BoundValueDeclaration sa <$> (h' <=< h) b <*> (g' <=< g) expr f' other = f other g' :: Expr -> m Expr diff --git a/tests/purs/passing/3388.purs b/tests/purs/passing/3388.purs new file mode 100644 index 0000000000..71feafb29b --- /dev/null +++ b/tests/purs/passing/3388.purs @@ -0,0 +1,10 @@ +module Main where + +import Prelude +import Effect.Console (log) + +main = do + let + x = { a: 42, b: "foo" } + { a, b } = x { a = 43 } + log "Done" From c89e2f6d96879a91618d2c783c8f677d6bec5661 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Mon, 8 Oct 2018 17:21:31 +0300 Subject: [PATCH 1013/1580] Add nix config to stack.yaml (#3435) The missing `zlib` dependency made stack build fail on NixOS --- stack.yaml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/stack.yaml b/stack.yaml index 42dbab2418..332e29d804 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,3 +2,7 @@ resolver: lts-12.0 packages: - '.' extra-deps: +nix: + enable: false + packages: + - zlib From fdd21482b397f7157e48a3fb56486e0abac98f4d Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 11 Oct 2018 16:04:54 -0700 Subject: [PATCH 1014/1580] Consider type operators when reexporting a pseudo-module (#3442) --- src/Language/PureScript/Sugar/Names/Exports.hs | 1 + tests/purs/passing/3410.purs | 11 +++++++++++ 2 files changed, 12 insertions(+) create mode 100644 tests/purs/passing/3410.purs diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 18ef78f278..8c0600a01a 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -147,6 +147,7 @@ resolveExports env ss mn imps exps refs = -- values if that fails to see whether the value has been imported at all. testQuals :: (forall a b. M.Map (Qualified a) b -> [Qualified a]) -> ModuleName -> Bool testQuals f mn' = any (isQualifiedWith mn') (f (importedTypes imps)) + || any (isQualifiedWith mn') (f (importedTypeOps imps)) || any (isQualifiedWith mn') (f (importedDataConstructors imps)) || any (isQualifiedWith mn') (f (importedTypeClasses imps)) || any (isQualifiedWith mn') (f (importedValues imps)) diff --git a/tests/purs/passing/3410.purs b/tests/purs/passing/3410.purs new file mode 100644 index 0000000000..42e1cfb534 --- /dev/null +++ b/tests/purs/passing/3410.purs @@ -0,0 +1,11 @@ +module Main + ( module Prelude + , module DEN + , main + ) where + +import Prelude +import Data.Either.Nested (type (\/)) as DEN +import Effect.Console (log) + +main = log "Done" From 02ecfe6d10fdc02ff4cf599c040707dab1a7281a Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Mon, 22 Oct 2018 09:09:03 -0700 Subject: [PATCH 1015/1580] Fix ST magic-do and inlining (#3444) --- src/Language/PureScript/Constants.hs | 33 ++++++++++++------- src/Language/PureScript/CoreImp/Optimizer.hs | 5 +-- .../PureScript/CoreImp/Optimizer/MagicDo.hs | 31 +++++++++-------- 3 files changed, 41 insertions(+), 28 deletions(-) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index fd941374bb..b4e3a5e1c8 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -204,29 +204,23 @@ unit = "unit" -- Core lib values -untilE :: forall a. (IsString a) => a -untilE = "untilE" - -whileE :: forall a. (IsString a) => a -whileE = "whileE" - runST :: forall a. (IsString a) => a -runST = "runST" +runST = "run" stRefValue :: forall a. (IsString a) => a stRefValue = "value" newSTRef :: forall a. (IsString a) => a -newSTRef = "newSTRef" +newSTRef = "new" readSTRef :: forall a. (IsString a) => a -readSTRef = "readSTRef" +readSTRef = "read" writeSTRef :: forall a. (IsString a) => a -writeSTRef = "writeSTRef" +writeSTRef = "write" modifySTRef :: forall a. (IsString a) => a -modifySTRef = "modifySTRef" +modifySTRef = "modify" mkFn :: forall a. (IsString a) => a mkFn = "mkFn" @@ -257,6 +251,8 @@ data EffectDictionaries = EffectDictionaries { edApplicativeDict :: PSString , edBindDict :: PSString , edMonadDict :: PSString + , edWhile :: PSString + , edUntil :: PSString } effDictionaries :: EffectDictionaries @@ -264,6 +260,8 @@ effDictionaries = EffectDictionaries { edApplicativeDict = "applicativeEff" , edBindDict = "bindEff" , edMonadDict = "monadEff" + , edWhile = "whileE" + , edUntil = "untilE" } effectDictionaries :: EffectDictionaries @@ -271,6 +269,17 @@ effectDictionaries = EffectDictionaries { edApplicativeDict = "applicativeEffect" , edBindDict = "bindEffect" , edMonadDict = "monadEffect" + , edWhile = "whileE" + , edUntil = "untilE" + } + +stDictionaries :: EffectDictionaries +stDictionaries = EffectDictionaries + { edApplicativeDict = "applicativeST" + , edBindDict = "bindST" + , edMonadDict = "monadST" + , edWhile = "while" + , edUntil = "until" } discardUnitDictionary :: forall a. (IsString a) => a @@ -507,7 +516,7 @@ effect :: forall a. (IsString a) => a effect = "Effect" st :: forall a. (IsString a) => a -st = "Control_Monad_ST" +st = "Control_Monad_ST_Internal" controlApplicative :: forall a. (IsString a) => a controlApplicative = "Control_Applicative" diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs index 9994debf8e..de92116251 100644 --- a/src/Language/PureScript/CoreImp/Optimizer.hs +++ b/src/Language/PureScript/CoreImp/Optimizer.hs @@ -38,8 +38,9 @@ optimize js = do , inlineCommonOperators ]) js untilFixedPoint (return . tidyUp) . tco . inlineST - =<< untilFixedPoint (return . magicDo') - =<< untilFixedPoint (return . magicDo) js' + =<< untilFixedPoint (return . magicDoST) + =<< untilFixedPoint (return . magicDoEff) + =<< untilFixedPoint (return . magicDoEffect) js' where tidyUp :: AST -> AST tidyUp = applyAll diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs index 2067e38d37..1a2cde1327 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs @@ -1,6 +1,6 @@ -- | This module implements the "Magic Do" optimization, which inlines calls to return -- and bind for the Eff monad, as well as some of its actions. -module Language.PureScript.CoreImp.Optimizer.MagicDo (magicDo, magicDo', inlineST) where +module Language.PureScript.CoreImp.Optimizer.MagicDo (magicDoEffect, magicDoEff, magicDoST, inlineST) where import Prelude.Compat import Protolude (ordNub) @@ -27,14 +27,17 @@ import qualified Language.PureScript.Constants as C -- var x = m1(); -- ... -- } -magicDo :: AST -> AST -magicDo = magicDo'' C.eff C.effDictionaries +magicDoEff :: AST -> AST +magicDoEff = magicDo C.eff C.effDictionaries -magicDo' :: AST -> AST -magicDo' = magicDo'' C.effect C.effectDictionaries +magicDoEffect :: AST -> AST +magicDoEffect = magicDo C.effect C.effectDictionaries -magicDo'' :: Text -> C.EffectDictionaries -> AST -> AST -magicDo'' effectModule C.EffectDictionaries{..} = everywhereTopDown convert +magicDoST :: AST -> AST +magicDoST = magicDo C.st C.stDictionaries + +magicDo :: Text -> C.EffectDictionaries -> AST -> AST +magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert where -- The name of the function block which is added to denote a do block fnName = "__do" @@ -49,10 +52,10 @@ magicDo'' effectModule C.EffectDictionaries{..} = everywhereTopDown convert convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 js)]) | isBind bind = Function s1 (Just fnName) [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns js) -- Desugar untilE - convert (App s1 (App _ f [arg]) []) | isEffFunc C.untilE f = + convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f = App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) [] -- Desugar whileE - convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc C.whileE f = + convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc edWhile f = App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) [] -- Inline __do returns convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body @@ -98,12 +101,12 @@ inlineST = everywhere convertBlock -- Look for runST blocks and inline the STRefs there. -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then -- we can be more aggressive about inlining, and actually turn STRefs into local variables. - convertBlock (App _ f [arg]) | isSTFunc C.runST f = + convertBlock (App s1 f [arg]) | isSTFunc C.runST f = let refs = ordNub . findSTRefsIn $ arg usages = findAllSTUsagesIn arg allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs - in everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg + in App s1 (everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg) [] convertBlock other = other -- 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 @@ -112,9 +115,9 @@ inlineST = everywhere convertBlock Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]]) convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f = if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref - convert agg (App _ (App _ (App s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f = + convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f = if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg - convert agg (App _ (App _ (App s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f = + convert agg (App _ (App _ (App s1 f [func]) [ref]) []) | isSTFunc C.modifySTRef f = if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref]) convert _ other = other -- Check if an expression represents a function in the ST module @@ -129,7 +132,7 @@ inlineST = everywhere convertBlock findAllSTUsagesIn = everything (++) isSTUsage where isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref] - isSTUsage (App _ (App _ (App _ f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref] + isSTUsage (App _ (App _ (App _ f [_]) [ref]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref] isSTUsage _ = [] -- Find all uses of a variable appearingIn ref = everything (++) isVar From 5fd81ada75eb0b9661c6f20de62856ab27522dbb Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Tue, 23 Oct 2018 04:27:53 -0700 Subject: [PATCH 1016/1580] Add source spans to desugared do blocks (#3440) --- src/Language/PureScript/Sugar/DoNotation.hs | 57 +++++++++++---------- 1 file changed, 29 insertions(+), 28 deletions(-) diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 71adaa19de..a3d46bfdc4 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -25,46 +25,47 @@ desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desu -- | Desugar a single do statement desugarDo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration desugarDo d = - let (f, _, _) = everywhereOnValuesM return replace return - in rethrowWithPosition (declSourceSpan d) $ f d + let ss = declSourceSpan d + (f, _, _) = everywhereOnValuesM return (replace ss) return + in rethrowWithPosition ss $ f d where - bind :: Expr - bind = Var nullSourceSpan (Qualified Nothing (Ident C.bind)) + bind :: SourceSpan -> Expr + bind = flip Var (Qualified Nothing (Ident C.bind)) - discard :: Expr - discard = Var nullSourceSpan (Qualified Nothing (Ident C.discard)) + discard :: SourceSpan -> Expr + discard = flip Var (Qualified Nothing (Ident C.discard)) - replace :: Expr -> m Expr - replace (Do els) = go els - replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v) - replace other = return other + replace :: SourceSpan -> Expr -> m Expr + replace pos (Do els) = go pos els + replace _ (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace pos v) + replace _ other = return other - go :: [DoNotationElement] -> m Expr - go [] = internalError "The impossible happened in desugarDo" - go [DoNotationValue val] = return val - go (DoNotationValue val : rest) = do - rest' <- go rest - return $ App (App discard val) (Abs (VarBinder nullSourceSpan UnusedIdent) rest') - go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind - go (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) = + go :: SourceSpan -> [DoNotationElement] -> m Expr + go _ [] = internalError "The impossible happened in desugarDo" + go _ [DoNotationValue val] = return val + go pos (DoNotationValue val : rest) = do + rest' <- go pos rest + return $ App (App (discard pos) val) (Abs (VarBinder pos UnusedIdent) rest') + go _ [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind + go _ (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) = throwError . errorMessage $ CannotUseBindWithDo (Ident ident) where fromIdent (Ident i) | i `elem` [ C.bind, C.discard ] = First (Just i) fromIdent _ = mempty - go (DoNotationBind (VarBinder ss ident) val : rest) = do - rest' <- go rest - return $ App (App bind val) (Abs (VarBinder ss ident) rest') - go (DoNotationBind binder val : rest) = do - rest' <- go rest + go pos (DoNotationBind (VarBinder ss ident) val : rest) = do + rest' <- go pos rest + return $ App (App (bind pos) val) (Abs (VarBinder ss ident) rest') + go pos (DoNotationBind binder val : rest) = do + rest' <- go pos rest ident <- freshIdent' - return $ App (App bind val) (Abs (VarBinder nullSourceSpan ident) (Case [Var nullSourceSpan (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']])) - go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet - go (DoNotationLet ds : rest) = do + return $ App (App (bind pos) val) (Abs (VarBinder pos ident) (Case [Var pos (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']])) + go _ [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet + go pos (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () checkBind (ValueDecl (ss, _) i@(Ident name) _ _ _) | name `elem` [ C.bind, C.discard ] = throwError . errorMessage' ss $ CannotUseBindWithDo i checkBind _ = pure () mapM_ checkBind ds - rest' <- go rest + rest' <- go pos rest return $ Let FromLet ds rest' - go (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go (el : rest) + go _ (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go pos (el : rest) From 2bf6ba192b368ea3aa895abb02a5c484cb4e0c27 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Tue, 23 Oct 2018 04:51:29 -0700 Subject: [PATCH 1017/1580] Add a stricter source span check for warnings (#3441) * Add a stricter source span check for warnings * Use implicit import source span for shadowing warning --- src/Language/PureScript/Sugar/Names/Env.hs | 4 +++- tests/TestCompiler.hs | 14 +++++++++++++- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 88eda55f8f..d93933627c 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -32,6 +32,7 @@ import Data.Function (on) import Data.Foldable (find) import Data.List (groupBy, sortBy, delete) import Data.Maybe (fromJust, mapMaybe) +import Safe (headMay) import qualified Data.Map as M import qualified Data.Set as S @@ -469,8 +470,9 @@ checkImportConflicts ss currentModule toName xs = in if length groups > 1 then case nonImplicit of - [ImportRecord (Qualified (Just mnNew) _) mnOrig ss' _] -> do + [ImportRecord (Qualified (Just mnNew) _) mnOrig _ _] -> do let warningModule = if mnNew == currentModule then Nothing else Just mnNew + ss' = maybe nullSourceSpan importSourceSpan . headMay . filter ((== FromImplicit) . importProvenance) $ xs tell . errorMessage' ss' $ ScopeShadowing name warningModule $ delete mnNew conflictModules return (mnNew, mnOrig) _ -> throwError . errorMessage' ss $ ScopeConflict name conflictModules diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 2585f2507e..ddd7eda7d6 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -233,13 +233,25 @@ checkShouldFailWith expected errs = checkPositioned :: P.MultipleErrors -> Maybe String checkPositioned errs = - case mapMaybe (\err -> maybe (Just err) (const Nothing) (P.errorSpan err)) (P.runMultipleErrors errs) of + case mapMaybe guardSpans (P.runMultipleErrors errs) of [] -> Nothing errs' -> Just $ "Found errors with missing source spans:\n" ++ unlines (map (P.renderBox . P.prettyPrintSingleError P.defaultPPEOptions) errs') + where + guardSpans :: P.ErrorMessage -> Maybe P.ErrorMessage + guardSpans err = case P.errorSpan err of + Just ss | any (not . isNonsenseSpan) ss -> Nothing + _ -> Just err + + isNonsenseSpan :: P.SourceSpan -> Bool + isNonsenseSpan (P.SourceSpan spanName spanStart spanEnd) = + spanName == "" || spanName == "" || (spanStart == emptyPos && spanEnd == emptyPos) + + emptyPos :: P.SourcePos + emptyPos = P.SourcePos 0 0 assertCompiles :: [P.Module] From c5c965fd9d051ed456e58f698cb7cac748e4b2fe Mon Sep 17 00:00:00 2001 From: Dario Oddenino Date: Tue, 30 Oct 2018 13:44:23 +0100 Subject: [PATCH 1018/1580] Adding `Prim.TypeError.QuoteLabel` (#3436) --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Docs/Prim.hs | 12 +++++++++- src/Language/PureScript/Environment.hs | 1 + src/Language/PureScript/Errors.hs | 2 ++ tests/purs/warning/CustomWarning4.purs | 31 ++++++++++++++++++++++++++ 5 files changed, 46 insertions(+), 1 deletion(-) create mode 100644 tests/purs/warning/CustomWarning4.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 78a5abc8ee..fdc523bdae 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -126,6 +126,7 @@ If you would prefer to use different terms, please use the section below instead | [@sloosch](https://github.com/sloosch) | Simon Looschen | [MIT license](http://opensource.org/licenses/MIT) | | [@rgrinberg](https://github.com/rgrinberg) | Rudi Grinberg | [MIT license](http://opensource.org/licenses/MIT) | | [@gabejohnson](https://github.com/gabejohnson) | Gabe Johnson | [MIT license](http://opensource.org/licenses/MIT) | +| [@dariooddenino](https://github.com/dariooddenino) | Dario Oddenino | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 0116788428..a6ee336193 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -105,6 +105,7 @@ primTypeErrorDocsModule = Module , kindDoc , textDoc , quoteDoc + , quoteLabelDoc , besideDoc , aboveDoc ] @@ -441,7 +442,7 @@ kindDoc = primKindOf (P.primSubName "TypeError") "Doc" $ T.unlines [ "`Doc` is the kind of type-level documents." , "" , "This kind is used with the `Fail` and `Warn` type clases." - , "Build up a `Doc` with `Text`, `Quote`, `Beside`, and `Above`." + , "Build up a `Doc` with `Text`, `Quote`, `QuoteLabel`, `Beside`, and `Above`." ] textDoc :: Declaration @@ -462,6 +463,15 @@ quoteDoc = primTypeOf (P.primSubName "TypeError") "Quote" $ T.unlines , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." ] +quoteLabelDoc :: Declaration +quoteLabelDoc = primTypeOf (P.primSubName "TypeError") "QuoteLabel" $ T.unlines + [ "The `QuoteLabel` type constructor will produce a `Doc` when given a `Symbol`. When the resulting `Doc` is rendered" + , "for a `Warn` or `Fail` constraint, a syntactically valid label will be produced, escaping with quotes as needed." + , "" + , "For more information, see" + , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." + ] + besideDoc :: Declaration besideDoc = primTypeOf (P.primSubName "TypeError") "Beside" $ T.unlines [ "The Beside type constructor combines two Docs horizontally" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index abb25bcaa8..c806470ea3 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -449,6 +449,7 @@ primTypeErrorTypes = , (primSubName C.typeError "Warn", (kindDoc -:> kindConstraint, ExternData)) , (primSubName C.typeError "Text", (kindSymbol -:> kindDoc, ExternData)) , (primSubName C.typeError "Quote", (kindType -:> kindDoc, ExternData)) + , (primSubName C.typeError "QuoteLabel", (kindSymbol -:> kindDoc, ExternData)) , (primSubName C.typeError "Beside", (kindDoc -:> kindDoc -:> kindDoc, ExternData)) , (primSubName C.typeError "Above", (kindDoc -:> kindDoc -:> kindDoc, ExternData)) ] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index fe351e4078..d4807d650b 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1409,6 +1409,8 @@ toTypelevelString (TypeApp (TypeConstructor f) x) | f == primSubName C.typeError "Text" = toTypelevelString x toTypelevelString (TypeApp (TypeConstructor f) x) | f == primSubName C.typeError "Quote" = Just (typeAsBox x) +toTypelevelString (TypeApp (TypeConstructor f) (TypeLevelString x)) + | f == primSubName C.typeError "QuoteLabel" = Just . line . prettyPrintLabel . Label $ x toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret) | f == primSubName C.typeError "Beside" = (Box.<>) <$> toTypelevelString x <*> toTypelevelString ret diff --git a/tests/purs/warning/CustomWarning4.purs b/tests/purs/warning/CustomWarning4.purs new file mode 100644 index 0000000000..5ab9de6c40 --- /dev/null +++ b/tests/purs/warning/CustomWarning4.purs @@ -0,0 +1,31 @@ +-- @shouldWarnWith UserDefinedWarning +-- @shouldWarnWith UserDefinedWarning +-- @shouldWarnWith UserDefinedWarning +-- @shouldWarnWith UserDefinedWarning +module Main where + +import Prim.TypeError (class Warn, Beside, QuoteLabel, Text) +import Prim +import Type.Row (class RowToList, Cons, Nil) + +data Label (l :: Symbol) = Label + +baz :: + forall row label typ. + RowToList row (Cons label typ Nil) => + Warn (Beside (Text "Custom label ") (QuoteLabel label)) => + Record row -> + String +baz _ = "" + +baz' :: String +baz' = baz { hello: 1 } + +baz'' :: String +baz'' = baz { "hello": 1 } + +baz''' :: String +baz''' = baz { "h e l l o": 1 } + +baz'''' :: String +baz'''' = baz { "hel\"lo": 1 } From 3cc566a29a2b5ca0d2926df75d2ec7d20c82b75b Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sat, 3 Nov 2018 11:18:04 +0100 Subject: [PATCH 1019/1580] [purs ide] Accepts codegen targets for the rebuild command (#3449) --- app/Command/Compile.hs | 11 ++------ psc-ide/PROTOCOL.md | 8 ++++-- src/Language/PureScript/Ide.hs | 8 +++--- src/Language/PureScript/Ide/Command.hs | 10 +++++-- src/Language/PureScript/Ide/Rebuild.hs | 14 +++++----- src/Language/PureScript/Make/Actions.hs | 2 +- src/Language/PureScript/Options.hs | 9 +++++++ .../Language/PureScript/Ide/CompletionSpec.hs | 7 ++--- tests/Language/PureScript/Ide/RebuildSpec.hs | 26 ++++++++++++++++--- 9 files changed, 65 insertions(+), 30 deletions(-) diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 9ef05031e1..555fc5b51c 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -135,22 +135,15 @@ codegenTargets = Opts.option targetParser $ <> " The default target is 'js', but if this option is used only the targets specified will be used." ) -targets :: M.Map String P.CodegenTarget -targets = M.fromList - [ ("js", P.JS) - , ("sourcemaps", P.JSSourceMap) - , ("corefn", P.CoreFn) - ] - targetsMessage :: String -targetsMessage = "Accepted codegen targets are '" <> intercalate "', '" (M.keys targets) <> "'." +targetsMessage = "Accepted codegen targets are '" <> intercalate "', '" (M.keys P.codegenTargets) <> "'." targetParser :: Opts.ReadM [P.CodegenTarget] targetParser = Opts.str >>= \s -> for (T.split (== ',') s) $ maybe (Opts.readerError targetsMessage) pure - . flip M.lookup targets + . flip M.lookup P.codegenTargets . T.unpack . T.strip diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index 58d73fd121..0d22d38e7f 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -372,13 +372,17 @@ Arguments: - `actualFile :: Maybe String` Specifies the path to be used for location information and parse errors. This is useful in case a temp file is used as the source for a rebuild. + - `codegen :: Maybe [String]` Specified the codegen targets the + rebuild should produce. Uses the same target names as the command + line compiler. Defaults to just JS output ```json { "command": "rebuild", "params": { - "file": "/path/to/file.purs" - "actualFile": "/path/to/actualFile.purs" + "file": "/path/to/file.purs", + "actualFile": "/path/to/actualFile.purs", + "codegen": ["js", "corefn"] } } ``` diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 0970c07a8c..c904a495ad 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -94,10 +94,10 @@ handleCommand c = case c of Right rs' -> answerRequest outfp rs' Left question -> pure (CompletionResult (map (completionFromMatch . simpleExport . map withEmptyAnn) question)) - Rebuild file actualFile -> - rebuildFileAsync file actualFile - RebuildSync file actualFile -> - rebuildFileSync file actualFile + Rebuild file actualFile targets -> + rebuildFileAsync file actualFile targets + RebuildSync file actualFile targets -> + rebuildFileSync file actualFile targets Cwd -> TextResult . T.pack <$> liftIO getCurrentDirectory Reset -> diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 233d8b336f..ac6991b694 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -17,6 +17,8 @@ module Language.PureScript.Ide.Command where import Protolude import Data.Aeson +import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Language.PureScript as P import Language.PureScript.Ide.CaseSplit import Language.PureScript.Ide.Completion @@ -57,8 +59,8 @@ data Command -- Import InputFile OutputFile | Import FilePath (Maybe FilePath) [Filter] ImportCommand | List { listType :: ListType } - | Rebuild FilePath (Maybe FilePath) - | RebuildSync FilePath (Maybe FilePath) + | Rebuild FilePath (Maybe FilePath) (Set P.CodegenTarget) + | RebuildSync FilePath (Maybe FilePath) (Set P.CodegenTarget) | Cwd | Reset | Quit @@ -172,7 +174,11 @@ instance FromJSON Command where Rebuild <$> params .: "file" <*> params .:? "actualFile" + <*> (parseCodegenTargets =<< params .:? "codegen" .!= [ "js" ]) _ -> mzero where + parseCodegenTargets = + maybe mzero (pure . Set.fromList) . traverse (flip Map.lookup P.codegenTargets) + mkAnnotations True = explicitAnnotations mkAnnotations False = noAnnotations diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 7bd97997c9..6ad0313f68 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -42,10 +42,12 @@ rebuildFile -- ^ The file to rebuild -> Maybe FilePath -- ^ The file to use as the location for parsing and errors + -> Set P.CodegenTarget + -- ^ The targets to codegen -> (ReaderT IdeEnvironment (LoggingT IO) () -> m ()) -- ^ A runner for the second build with open exports -> m Success -rebuildFile file actualFile runOpenBuild = do +rebuildFile file actualFile codegenTargets runOpenBuild = do input <- ideReadFile file @@ -69,7 +71,7 @@ rebuildFile file actualFile runOpenBuild = do -- Rebuild the single module using the cached externs (result, warnings) <- logPerf (labelTimespec "Rebuilding Module") $ liftIO - . P.runMake P.defaultOptions + . P.runMake (P.defaultOptions { P.optionsCodegenTargets = codegenTargets }) . P.rebuildModule (buildMakeActions >>= shushProgress $ makeEnv) externs $ m case result of @@ -87,8 +89,8 @@ isEditorMode = asks (confEditorMode . ideConfiguration) rebuildFileAsync :: forall m. (Ide m, MonadLogger m, MonadError IdeError m) - => FilePath -> Maybe FilePath -> m Success -rebuildFileAsync fp fp' = rebuildFile fp fp' asyncRun + => FilePath -> Maybe FilePath -> Set P.CodegenTarget -> m Success +rebuildFileAsync fp fp' ts = rebuildFile fp fp' ts asyncRun where asyncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m () asyncRun action = do @@ -98,8 +100,8 @@ rebuildFileAsync fp fp' = rebuildFile fp fp' asyncRun rebuildFileSync :: forall m. (Ide m, MonadLogger m, MonadError IdeError m) - => FilePath -> Maybe FilePath -> m Success -rebuildFileSync fp fp' = rebuildFile fp fp' syncRun + => FilePath -> Maybe FilePath -> Set P.CodegenTarget -> m Success +rebuildFileSync fp fp' ts = rebuildFile fp fp' ts syncRun where syncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m () syncRun action = do diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index b5e7743735..f7c6d5eaee 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -44,7 +44,7 @@ import Language.PureScript.Errors import Language.PureScript.Make.Monad import Language.PureScript.Names import Language.PureScript.Names (runModuleName, ModuleName) -import Language.PureScript.Options +import Language.PureScript.Options hiding (codegenTargets) import qualified Language.PureScript.Parser as PSParser import Language.PureScript.Pretty.Common (SMap(..)) import qualified Paths_purescript as Paths diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index 3055946b4d..1de91c9e5b 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -3,6 +3,8 @@ module Language.PureScript.Options where import Prelude.Compat import qualified Data.Set as S +import Data.Map (Map) +import qualified Data.Map as Map -- | The data type of compiler options data Options = Options @@ -20,3 +22,10 @@ defaultOptions = Options False False (S.singleton JS) data CodegenTarget = JS | JSSourceMap | CoreFn deriving (Eq, Ord, Show) + +codegenTargets :: Map String CodegenTarget +codegenTargets = Map.fromList + [ ("js", JS) + , ("sourcemaps", JSSourceMap) + , ("corefn", CoreFn) + ] diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs index 4df331aad4..c9a84cfd70 100644 --- a/tests/Language/PureScript/Ide/CompletionSpec.hs +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -4,7 +4,8 @@ module Language.PureScript.Ide.CompletionSpec where import Protolude -import Language.PureScript as P +import qualified Data.Set as Set +import qualified Language.PureScript as P import Language.PureScript.Ide.Test as Test import Language.PureScript.Ide.Command as Command import Language.PureScript.Ide.Completion @@ -30,7 +31,7 @@ load :: [Text] -> Command load = LoadSync . map Test.mn rebuildSync :: FilePath -> Command -rebuildSync fp = RebuildSync ("src" fp) Nothing +rebuildSync fp = RebuildSync ("src" fp) Nothing (Set.singleton P.JS) spec :: Spec spec = describe "Applying completion options" $ do @@ -63,4 +64,4 @@ spec = describe "Applying completion options" $ do Test.runIde [ load ["CompletionSpecDocs"] , typ "withType" ] - result `shouldSatisfy` \res -> complDocumentation res == Just "Doc *123*\n" \ No newline at end of file + result `shouldSatisfy` \res -> complDocumentation res == Just "Doc *123*\n" diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index 03ea688ae0..0aea8e2a83 100644 --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -4,6 +4,8 @@ module Language.PureScript.Ide.RebuildSpec where import Protolude +import qualified Data.Set as Set +import qualified Language.PureScript as P import Language.PureScript.AST.SourcePos (spanName) import Language.PureScript.Ide.Command import Language.PureScript.Ide.Completion @@ -11,16 +13,20 @@ import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types import qualified Language.PureScript.Ide.Test as Test import System.FilePath +import System.Directory (doesFileExist, removePathForcibly) import Test.Hspec +defaultTarget :: Set P.CodegenTarget +defaultTarget = Set.singleton P.JS + load :: [Text] -> Command load = LoadSync . map Test.mn rebuild :: FilePath -> Command -rebuild fp = Rebuild ("src" fp) Nothing +rebuild fp = Rebuild ("src" fp) Nothing defaultTarget rebuildSync :: FilePath -> Command -rebuildSync fp = RebuildSync ("src" fp) Nothing +rebuildSync fp = RebuildSync ("src" fp) Nothing defaultTarget spec :: Spec spec = describe "Rebuilding single modules" $ do @@ -67,6 +73,20 @@ spec = describe "Rebuilding single modules" $ do Test.runIde' editorConfig emptyIdeState - [ RebuildSync ("src" "RebuildSpecWithHiddenIdent.purs") (Just "actualFile") + [ RebuildSync ("src" "RebuildSpecWithHiddenIdent.purs") (Just "actualFile") defaultTarget , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent")) defaultCompletionOptions] map spanName (complLocation result) `shouldBe` Just "actualFile" + it "doesn't produce JS when an empty target list is supplied" $ do + exists <- Test.inProject $ do + let indexJs = "output" "RebuildSpecSingleModule" "index.js" + removePathForcibly ("output" "RebuildSpecSingleModule") + _ <- Test.runIde [ RebuildSync ("src" "RebuildSpecSingleModule.purs") Nothing Set.empty ] + doesFileExist indexJs + exists `shouldBe` False + it "does produce corefn if it's a codegen target" $ do + exists <- Test.inProject $ do + let corefn = "output" "RebuildSpecSingleModule" "corefn.json" + removePathForcibly ("output" "RebuildSpecSingleModule") + _ <- Test.runIde [ RebuildSync ("src" "RebuildSpecSingleModule.purs") Nothing (Set.singleton P.CoreFn) ] + doesFileExist corefn + exists `shouldBe` True From 5a47a3039477fc329d7594bca8bbfcd974c6ac3e Mon Sep 17 00:00:00 2001 From: rndnoise <34294193+rndnoise@users.noreply.github.com> Date: Tue, 6 Nov 2018 03:59:34 -0600 Subject: [PATCH 1020/1580] Build psciEnvironment as needed for :print in REPL (#3241) * Improvments to REPL tab-completion - Complete all names that have been imported (transitively or directly) - Do not complete names that haven't been imported - Only recompute list of names after import or adding a let binding rather than after each request for name completion This commit fixes #3227 * Rebuild REPL environment for :browse as needed (Fix #3001) * Fix a bug that didn't reload dependent modules after :reload in psci tests * Cleanup some awkward code * trivial change to force rebuild --- CONTRIBUTORS.md | 2 +- app/Command/REPL.hs | 8 +-- package.yaml | 3 +- src/Language/PureScript/Interactive.hs | 2 +- src/Language/PureScript/Interactive/Types.hs | 13 +++-- tests/TestPsci/CommandTest.hs | 21 ++++++++ tests/TestPsci/TestEnv.hs | 53 ++++++++++++++++---- tests/TestUtils.hs | 10 ++-- tests/support/psci/Reload.edit | 4 ++ tests/support/psci/Reload.purs | 4 ++ tests/support/psci/Sample.purs | 0 11 files changed, 94 insertions(+), 26 deletions(-) create mode 100644 tests/support/psci/Reload.edit create mode 100644 tests/support/psci/Reload.purs delete mode 100644 tests/support/psci/Sample.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index fdc523bdae..17b6b5ad23 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -93,7 +93,7 @@ If you would prefer to use different terms, please use the section below instead | [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license](http://opensource.org/licenses/MIT) | | [@quesebifurcan](https://github.com/quesebifurcan) | Fredrik Wallberg | [MIT license](http://opensource.org/licenses/MIT) | | [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) | -| [@rndnoise](https://github.com/rndnoise) | rndnoise | [MIT license](http://opensource.org/licenses/MIT) | +| [@rndnoise](https://www.github.com/rndnoise) | rndnoise | [MIT license](http://opensource.org/licenses/MIT) | | [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license](http://opensource.org/licenses/MIT) | | [@RossMeikleham](https://github.com/RossMeikleham) | Ross Meikleham | [MIT license](http://opensource.org/licenses/MIT) | | [@Rufflewind](https://github.com/Rufflewind) | Phil Ruffwind | [MIT license](https://opensource.org/licenses/MIT) | diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 1093733c7b..c2ddb695f9 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -318,19 +318,19 @@ command = loop <$> options unless (supportModuleIsDefined (map snd modules)) . liftIO $ do putStr supportModuleMessage exitFailure - (externs, env) <- ExceptT . runMake . make $ modules - return (modules, externs, env) + (externs, _) <- ExceptT . runMake . make $ modules + return (modules, externs) case psciBackend of Backend setup eval reload (shutdown :: state -> IO ()) -> case e of Left errs -> do pwd <- getCurrentDirectory putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd} errs) >> exitFailure - Right (modules, externs, env) -> do + Right (modules, externs) -> do historyFilename <- getHistoryFilename let settings = defaultSettings { historyFile = Just historyFilename } initialState = updateLoadedExterns (const (zip (map snd modules) externs)) initialPSCiState - config = PSCiConfig psciInputGlob env + config = PSCiConfig psciInputGlob runner = flip runReaderT config . flip evalStateT initialState . runInputT (setComplete completion settings) diff --git a/package.yaml b/package.yaml index 96793c44e9..b5393b3ac4 100644 --- a/package.yaml +++ b/package.yaml @@ -22,7 +22,8 @@ extra-source-files: - tests/purs/**/*.json - tests/support/*.json - tests/support/setup-win.cmd - - tests/support/psci/*.purs + - tests/support/psci/**.purs + - tests/support/psci/**.edit - tests/support/pscide/src/**/*.purs - tests/support/pscide/src/**/*.js - tests/support/pscide/src/**/*.fail diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index efc7a1e44f..3205316a44 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -291,7 +291,7 @@ handleBrowse -> m () handleBrowse print' moduleName = do st <- get - env <- asks psciEnvironment + let env = psciEnvironment st case findMod moduleName (psciLoadedExterns st) (psciImportedModules st) of Just qualName -> print' $ printModuleSignatures qualName env Nothing -> failNotInEnv moduleName diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index 15e1427024..521b61dd8a 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -3,6 +3,7 @@ -- module Language.PureScript.Interactive.Types ( PSCiConfig(..) + , psciEnvironment , PSCiState -- constructor is not exported, to prevent psciImports and psciExports from -- becoming inconsistent with importedModules, letBindings and loadedExterns , ImportedModule @@ -29,6 +30,7 @@ import Prelude.Compat import qualified Language.PureScript as P import qualified Data.Map as M +import Data.List (foldl') import Language.PureScript.Sugar.Names.Env (nullImports, primExports) import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Writer.Strict (runWriterT) @@ -38,9 +40,8 @@ import Control.Monad.Writer.Strict (runWriterT) -- -- These configuration values do not change during execution. -- -data PSCiConfig = PSCiConfig - { psciFileGlobs :: [String] - , psciEnvironment :: P.Environment +newtype PSCiConfig = PSCiConfig + { psciFileGlobs :: [String] } deriving Show -- | The PSCI state. @@ -78,6 +79,10 @@ psciExports (PSCiState _ _ _ _ x) = x initialPSCiState :: PSCiState initialPSCiState = PSCiState [] [] [] nullImports primExports +psciEnvironment :: PSCiState -> P.Environment +psciEnvironment st = foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs + where externs = map snd (psciLoadedExterns st) + -- | All of the data that is contained by an ImportDeclaration in the AST. -- That is: -- @@ -137,7 +142,7 @@ updateImportedModules f (PSCiState x a b c d) = -- | Updates the loaded externs files in the state record. updateLoadedExterns :: ([(P.Module, P.ExternsFile)] -> [(P.Module, P.ExternsFile)]) -> PSCiState -> PSCiState updateLoadedExterns f (PSCiState a b x c d) = - PSCiState a b (f x) c d + updateImportExports (PSCiState a b (f x) c d) -- | Updates the let bindings in the state record. updateLets :: ([P.Declaration] -> [P.Declaration]) -> PSCiState -> PSCiState diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs index a84fdcaf16..7de6412968 100644 --- a/tests/TestPsci/CommandTest.hs +++ b/tests/TestPsci/CommandTest.hs @@ -1,10 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} + module TestPsci.CommandTest where import Prelude () import Prelude.Compat +import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.RWS.Strict (get) +import Language.PureScript (moduleNameFromString) import Language.PureScript.Interactive +import System.FilePath (()) +import System.Directory (getCurrentDirectory) import Test.Hspec import TestPsci.TestEnv @@ -42,5 +48,20 @@ commandTests = context "commandTests" $ do ":complete M.a" `prints` unlines ["M.ap", "M.apply"] specPSCi ":browse" $ do + ":browse Data.Void" `printed` flip shouldContain "data Void" + ":browse Data.Void" `printed` flip shouldContain "absurd ::" + + specPSCi ":reload, :browse" $ do + cwd <- liftIO getCurrentDirectory + let new = cwd "tests" "support" "psci" "Reload.edit" + + ":browse Reload" `printed` flip shouldContain "reload ::" + ":browse Reload" `printed` flip shouldNotContain "edited ::" + + simulateModuleEdit (moduleNameFromString "Reload") new $ do + run ":reload" + ":browse Reload" `printed` flip shouldNotContain "reload ::" + ":browse Reload" `printed` flip shouldContain "edited ::" + ":browse Mirp" `printed` flip shouldContain "is not valid" ":browse Prim" `printed` flip shouldContain "class Partial" diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index a41c018871..84cb90fba5 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -1,16 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + module TestPsci.TestEnv where import Prelude () import Prelude.Compat -import Control.Monad (void) +import Control.Exception.Lifted (bracket_) +import Control.Monad (void, when) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.RWS.Strict (evalRWST, RWST) +import Control.Monad.Trans.RWS.Strict (evalRWST, asks, local, RWST) +import Data.List (isSuffixOf) +import qualified Data.Text as T import qualified Language.PureScript as P import Language.PureScript.Interactive -import System.Directory (getCurrentDirectory) +import System.Directory (getCurrentDirectory, doesPathExist, removeFile) import System.Exit -import System.FilePath (()) +import System.FilePath ((), pathSeparator) import qualified System.FilePath.Glob as Glob import System.Process (readProcessWithExitCode) import Test.Hspec (shouldBe, Expectation) @@ -23,9 +28,10 @@ initTestPSCiEnv :: IO (PSCiState, PSCiConfig) initTestPSCiEnv = do -- Load test support packages cwd <- getCurrentDirectory - let supportDir = cwd "tests" "support" "bower_components" - let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir - pursFiles <- supportFiles "purs" + let supportDir = cwd "tests" "support" + psciFiles <- Glob.globDir1 (Glob.compile "**/*.purs") (supportDir "psci") + libraries <- Glob.globDir1 (Glob.compile "purescript-*/src/**/*.purs") (supportDir "bower_components") + let pursFiles = psciFiles ++ libraries modulesOrError <- loadAllModules pursFiles case modulesOrError of Left err -> @@ -35,8 +41,8 @@ initTestPSCiEnv = do makeResultOrError <- runMake . make $ modules case makeResultOrError of Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure - Right (externs, env) -> - return (updateLoadedExterns (const (zip (map snd modules) externs)) initialPSCiState, PSCiConfig pursFiles env) + Right (externs, _) -> + return (updateLoadedExterns (const (zip (map snd modules) externs)) initialPSCiState, PSCiConfig pursFiles) -- | Execute a TestPSCi, returning IO execTestPSCi :: TestPSCi a -> IO a @@ -71,9 +77,8 @@ runAndEval comm jsOutputEval textOutputEval = -- | Run a PSCi command, evaluate compiled JS, and ignore evaluation output and printed output run :: String -> TestPSCi () -run comm = runAndEval comm evalJsAndIgnore ignorePrinted +run comm = runAndEval comm (void jsEval) ignorePrinted where - evalJsAndIgnore = jsEval *> return () ignorePrinted _ = return () -- | A lifted evaluation of Hspec 'shouldBe' for the TestPSCi @@ -95,3 +100,29 @@ prints command expected = printed command (`shouldBe` expected) printed :: String -> (String -> Expectation) -> TestPSCi () printed command f = runAndEval command (void jsEval) (liftIO . f) + +simulateModuleEdit :: P.ModuleName -> FilePath -> TestPSCi a -> TestPSCi a +simulateModuleEdit mn newPath action = do + ms <- asks psciFileGlobs + case replacePath ms of + Nothing -> fail $ "Did not find " ++ inputPath ++ " in psciFileGlobs" + Just xs' -> local (\c -> c { psciFileGlobs = xs' }) temporarily <* rebuild + + where + outputPath = modulesDir T.unpack (P.runModuleName mn) "index.js" + inputPath = T.unpack (T.replace "." slash (P.runModuleName mn)) ++ ".purs" + slash = T.singleton pathSeparator + + replacePath :: [String] -> Maybe [String] + replacePath (x:xs) + | inputPath `isSuffixOf` x = Just (newPath : xs) + | otherwise = fmap (x:) (replacePath xs) + replacePath [] = Nothing + + -- Simply adding the file to `PSCiConfig.fileGlobs` isn't sufficient; running + -- ":reload" might not rebuild because the compiled JS artifact has a more + -- recent timestamp than the "new" source file `newPath`. + temporarily = bracket_ enableRebuild enableRebuild action + enableRebuild = liftIO $ do { b <- doesPathExist outputPath; when b (removeFile outputPath) } + rebuild = handleCommand discard (return ()) discard ReloadState + discard _ = return () diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 9c3a69278f..6c7080705b 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -66,10 +66,12 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do getSupportModuleTuples :: IO [(FilePath, P.Module)] getSupportModuleTuples = do cd <- getCurrentDirectory - let supportDir = cd "tests" "support" "bower_components" - supportPurs <- Glob.globDir1 (Glob.compile "purescript-*/src/**/*.purs") supportDir - supportPursFiles <- readInput supportPurs - modules <- runExceptT $ ExceptT . return $ P.parseModulesFromFiles id supportPursFiles + let supportDir = cd "tests" "support" + psciFiles <- Glob.globDir1 (Glob.compile "**/*.purs") (supportDir "psci") + libraries <- Glob.globDir1 (Glob.compile "purescript-*/src/**/*.purs") (supportDir "bower_components") + let pursFiles = psciFiles ++ libraries + fileContents <- readInput pursFiles + modules <- runExceptT $ ExceptT . return $ P.parseModulesFromFiles id fileContents case modules of Right ms -> return ms Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) diff --git a/tests/support/psci/Reload.edit b/tests/support/psci/Reload.edit new file mode 100644 index 0000000000..21e897862a --- /dev/null +++ b/tests/support/psci/Reload.edit @@ -0,0 +1,4 @@ +module Reload where + +edited :: String +edited = "reload" diff --git a/tests/support/psci/Reload.purs b/tests/support/psci/Reload.purs new file mode 100644 index 0000000000..dae46c4680 --- /dev/null +++ b/tests/support/psci/Reload.purs @@ -0,0 +1,4 @@ +module Reload where + +reload :: Int +reload = 0 diff --git a/tests/support/psci/Sample.purs b/tests/support/psci/Sample.purs deleted file mode 100644 index e69de29bb2..0000000000 From 2cb4a6496052db726e099539be682b87585af494 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 12 Nov 2018 22:03:40 +0000 Subject: [PATCH 1021/1580] Update package.yaml --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index b5393b3ac4..4926c0bcb7 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.12.0' +version: '0.12.1' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 31069b682aa44efef943e5eed70d3a9307d19833 Mon Sep 17 00:00:00 2001 From: Justin Woo Date: Tue, 20 Nov 2018 13:37:03 +0100 Subject: [PATCH 1022/1580] add longer error message for repl (#3456) --- app/Command/REPL.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index c2ddb695f9..07ee153b32 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -292,7 +292,7 @@ nodeBackend nodePath nodeArgs = Backend setup eval reload shutdown case result of Just (ExitSuccess, out, _) -> putStrLn out Just (ExitFailure _, _, err) -> putStrLn err - Nothing -> putStrLn "Couldn't find node.js" + Nothing -> putStrLn "Could not find node.js. Do you have node.js installed and available in your PATH?" reload :: () -> IO () reload _ = return () From b8146c880dd4c816a9e99ff2035bee6d6bd1d34f Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sun, 25 Nov 2018 00:08:09 +0000 Subject: [PATCH 1023/1580] Remove references to previous kinds * and ! (#3458) The kinds * and ! were switched to parse errors in 0.11. Now we're at 0.12 we can remove them. --- src/Language/PureScript/Docs/Prim.hs | 3 +-- src/Language/PureScript/Parser/Kinds.hs | 12 +----------- 2 files changed, 2 insertions(+), 13 deletions(-) diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index a6ee336193..20ffb47245 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -203,8 +203,7 @@ primClassOf gen title comments = Declaration kindType :: Declaration kindType = primKind "Type" $ T.unlines - [ "`Type` (also known as `*`) is the kind of all proper types: those that" - , "classify value-level terms." + [ "`Type` is the kind of all proper types: those that classify value-level terms." , "For example the type `Boolean` has kind `Type`; denoted by `Boolean :: Type`." ] diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs index 06c29f5c3f..bb4cc2ddc1 100644 --- a/src/Language/PureScript/Parser/Kinds.hs +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -12,23 +12,13 @@ import Language.PureScript.Parser.Lexer import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P -parseStar :: TokenParser Kind -parseStar = symbol' "*" *> - P.parserFail "The `*` symbol is no longer used for the kind of types.\n The new equivalent is the named kind `Type`." - -parseBang :: TokenParser Kind -parseBang = symbol' "!" *> - P.parserFail "The `!` symbol is no longer used for the kind of effects.\n The new equivalent is the named kind `Effect`, defined in `Control.Monad.Eff` in the `purescript-eff` library." - parseNamedKind :: TokenParser Kind parseNamedKind = NamedKind <$> parseQualified kindName parseKindAtom :: TokenParser Kind parseKindAtom = indented *> P.choice - [ parseStar - , parseBang - , parseNamedKind + [ parseNamedKind , parens parseKind ] From dcdd70d50194e723be22c7964f47c2458cc9a706 Mon Sep 17 00:00:00 2001 From: Justin Woo Date: Sun, 25 Nov 2018 02:11:19 +0200 Subject: [PATCH 1024/1580] add Boolean kind to Prim.Boolean (#3389) --- src/Language/PureScript/Constants.hs | 19 ++++++++++++- src/Language/PureScript/Docs/Prim.hs | 31 +++++++++++++++++++++- src/Language/PureScript/Environment.hs | 18 +++++++++++++ src/Language/PureScript/Ide/Prim.hs | 7 +++++ src/Language/PureScript/Sugar/Names/Env.hs | 9 +++++++ tests/TestPrimDocs.hs | 1 + 6 files changed, 83 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index b4e3a5e1c8..cd07a9cf26 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -387,6 +387,17 @@ pattern Partial = Qualified (Just Prim) (ProperName "Partial") pattern Record :: Qualified (ProperName 'TypeName) pattern Record = Qualified (Just Prim) (ProperName "Record") +-- Prim.Boolean + +pattern PrimBoolean :: ModuleName +pattern PrimBoolean = ModuleName [ProperName "Prim", ProperName "Boolean"] + +booleanTrue :: Qualified (ProperName 'TypeName) +booleanTrue = Qualified (Just PrimBoolean) (ProperName "True") + +booleanFalse :: Qualified (ProperName 'TypeName) +booleanFalse = Qualified (Just PrimBoolean) (ProperName "False") + -- Prim.Ordering pattern PrimOrdering :: ModuleName @@ -458,7 +469,7 @@ pattern Warn :: Qualified (ProperName 'ClassName) pattern Warn = Qualified (Just PrimTypeError) (ProperName "Warn") primModules :: [ModuleName] -primModules = [Prim, PrimOrdering, PrimRow, PrimRowList, PrimSymbol, PrimTypeError] +primModules = [Prim, PrimBoolean, PrimOrdering, PrimRow, PrimRowList, PrimSymbol, PrimTypeError] -- Data.Symbol @@ -471,6 +482,9 @@ pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol") typ :: forall a. (IsString a) => a typ = "Type" +kindBoolean :: forall a. (IsString a) => a +kindBoolean = "Boolean" + kindOrdering :: forall a. (IsString a) => a kindOrdering = "Ordering" @@ -488,6 +502,9 @@ doc = "Doc" prim :: forall a. (IsString a) => a prim = "Prim" +moduleBoolean :: forall a. (IsString a) => a +moduleBoolean = "Boolean" + moduleOrdering :: forall a. (IsString a) => a moduleOrdering = "Ordering" diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 20ffb47245..ddd7427009 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -17,6 +17,7 @@ import qualified Language.PureScript as P primModules :: [Module] primModules = [ primDocsModule + , primBooleanDocsModule , primOrderingDocsModule , primRowDocsModule , primRowListDocsModule @@ -44,10 +45,22 @@ primDocsModule = Module , modReExports = [] } +primBooleanDocsModule :: Module +primBooleanDocsModule = Module + { modName = P.moduleNameFromString "Prim.Boolean" + , modComments = Just "The Prim.Boolean module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains a type level `Boolean` data structure." + , modDeclarations = + [ kindBoolean + , booleanTrue + , booleanFalse + ] + , modReExports = [] + } + primOrderingDocsModule :: Module primOrderingDocsModule = Module { modName = P.moduleNameFromString "Prim.Ordering" - , modComments = Just "The Prim.Row module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains a type level `Ordering` data structure." + , modComments = Just "The Prim.Ordering module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains a type level `Ordering` data structure." , modDeclarations = [ kindOrdering , orderingLT @@ -153,6 +166,7 @@ lookupPrimTypeKindOf -> P.Kind lookupPrimTypeKindOf k = fst . unsafeLookupOf k ( P.primTypes <> + P.primBooleanTypes <> P.primOrderingTypes <> P.primRowTypes <> P.primRowListTypes <> @@ -329,6 +343,21 @@ partial = primClass "Partial" $ T.unlines , "[the Partial type class guide](https://github.com/purescript/documentation/blob/master/guides/The-Partial-type-class.md)." ] +kindBoolean :: Declaration +kindBoolean = primKindOf (P.primSubName "Boolean") "Boolean" $ T.unlines + [ "The `Boolean` kind provides True/False types at the type level" + ] + +booleanTrue :: Declaration +booleanTrue = primTypeOf (P.primSubName "Boolean") "True" $ T.unlines + [ "The 'True' boolean type." + ] + +booleanFalse :: Declaration +booleanFalse = primTypeOf (P.primSubName "Boolean") "False" $ T.unlines + [ "The 'False' boolean type." + ] + kindOrdering :: Declaration kindOrdering = primKindOf (P.primSubName "Ordering") "Ordering" $ T.unlines [ "The `Ordering` kind represents the three possibilites of comparing two" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index c806470ea3..e385cfd44f 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -290,6 +290,9 @@ kindSymbol = primKind C.symbol kindDoc :: Kind kindDoc = primSubKind C.typeError C.doc +kindBoolean :: Kind +kindBoolean = primSubKind C.moduleBoolean C.kindBoolean + kindOrdering :: Kind kindOrdering = primSubKind C.moduleOrdering C.kindOrdering @@ -355,6 +358,12 @@ primKinds = S.fromList , primName C.symbol ] +-- | Kinds in @Prim.Boolean@ +primBooleanKinds :: S.Set (Qualified (ProperName 'KindName)) +primBooleanKinds = S.fromList + [ primSubName C.moduleBoolean C.kindBoolean + ] + -- | Kinds in @Prim.Ordering@ primOrderingKinds :: S.Set (Qualified (ProperName 'KindName)) primOrderingKinds = S.fromList @@ -377,6 +386,7 @@ primTypeErrorKinds = S.fromList allPrimKinds :: S.Set (Qualified (ProperName 'KindName)) allPrimKinds = fold [ primKinds + , primBooleanKinds , primOrderingKinds , primRowListKinds , primTypeErrorKinds @@ -402,6 +412,7 @@ primTypes = M.fromList allPrimTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) allPrimTypes = M.unions [ primTypes + , primBooleanTypes , primOrderingTypes , primRowTypes , primRowListTypes @@ -409,6 +420,13 @@ allPrimTypes = M.unions , primTypeErrorTypes ] +primBooleanTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +primBooleanTypes = + M.fromList + [ (primSubName C.moduleBoolean "True", (kindBoolean, ExternData)) + , (primSubName C.moduleBoolean "False", (kindBoolean, ExternData)) + ] + primOrderingTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) primOrderingTypes = M.fromList diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index 1a14b8b16e..4430a127fd 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -13,6 +13,9 @@ idePrimDeclarations = [ ( C.Prim , mconcat [primTypes, primKinds, primClasses] ) + , ( C.PrimBoolean + , mconcat [primBooleanTypes, primBooleanKinds] + ) , ( C.PrimOrdering , mconcat [primOrderingTypes, primOrderingKinds] ) @@ -42,6 +45,7 @@ idePrimDeclarations = Map.difference types (Map.mapKeys (map P.coerceProperName) classes) primTypes = annType (removeClasses PEnv.primTypes PEnv.primClasses) + primBooleanTypes = annType PEnv.primBooleanTypes primOrderingTypes = annType PEnv.primOrderingTypes primRowTypes = annType (removeClasses PEnv.primRowTypes PEnv.primRowClasses) primRowListTypes = annType (removeClasses PEnv.primRowListTypes PEnv.primRowListClasses) @@ -57,6 +61,9 @@ idePrimDeclarations = primKinds = foreach (Set.toList PEnv.primKinds) $ \kn -> IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) + primBooleanKinds = foreach (Set.toList PEnv.primBooleanKinds) $ \kn -> + IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) + primOrderingKinds = foreach (Set.toList PEnv.primOrderingKinds) $ \kn -> IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index d93933627c..a378000900 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -188,6 +188,12 @@ envModuleExports (_, _, exps) = exps primExports :: Exports primExports = mkPrimExports primTypes primClasses primKinds +-- | +-- The exported types from the @Prim.Boolean@ module +-- +primBooleanExports :: Exports +primBooleanExports = mkPrimExports primBooleanTypes mempty primBooleanKinds + -- | -- The exported types from the @Prim.Ordering@ module -- @@ -243,6 +249,9 @@ primEnv = M.fromList [ ( C.Prim , (internalModuleSourceSpan "", nullImports, primExports) ) + , ( C.PrimBoolean + , (internalModuleSourceSpan "", nullImports, primBooleanExports) + ) , ( C.PrimOrdering , (internalModuleSourceSpan "", nullImports, primOrderingExports) ) diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index 584c8a9681..ef545dee3d 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -20,6 +20,7 @@ main = do -- note that prim type classes are listed in P.primTypes (map (P.runProperName . P.disqualify . fst) $ Map.toList ( P.primTypes <> + P.primBooleanTypes <> P.primOrderingTypes <> P.primRowTypes <> P.primRowListTypes <> From c7c03fcf684adb77a27ea945c1738de0d369564a Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sun, 2 Dec 2018 09:17:35 -0800 Subject: [PATCH 1025/1580] Link to documentation repo as docs for non-Prim built-in types/kinds (#3460) * Link to documentation repo as docs for non-Prim built-in types/kinds * Resolve issues raised in comments - put row's kind signature (# Type) before its example. - lowercase Row to row to not risk implying that it's a name of something in the language - change `functionTypeSignature` to `f` since the meta-language function name is unneeded - change "click here" link text to more appropriate "purescript language reference" * Don't use 'the' when referring to row kinds as it implies uniqueness * Add self to list of contributors * Replace "i.e." with "e.g." to fully remove incorrect uniquness idea --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Docs/Prim.hs | 7 +++++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 17b6b5ad23..30b7de3c46 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -127,6 +127,7 @@ If you would prefer to use different terms, please use the section below instead | [@rgrinberg](https://github.com/rgrinberg) | Rudi Grinberg | [MIT license](http://opensource.org/licenses/MIT) | | [@gabejohnson](https://github.com/gabejohnson) | Gabe Johnson | [MIT license](http://opensource.org/licenses/MIT) | | [@dariooddenino](https://github.com/dariooddenino) | Dario Oddenino | [MIT license](http://opensource.org/licenses/MIT) | +| [@jordanmartinez](https://github.com/jordanmartinez) | Jordan Martinez | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index ddd7427009..db65ea9a93 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -28,7 +28,11 @@ primModules = primDocsModule :: Module primDocsModule = Module { modName = P.moduleNameFromString "Prim" - , modComments = Just "The Prim module is embedded in the PureScript compiler in order to provide compiler support for certain types — for example, value literals, or syntax sugar. It is implicitly imported unqualified in every module except those that list it as a qualified import." + , modComments = Just $ T.unlines + [ "The `Prim` module is embedded in the PureScript compiler in order to provide compiler support for certain types — for example, value literals, or syntax sugar. It is implicitly imported unqualified in every module except those that list it as a qualified import." + , "" + , "`Prim` does not include additional built-in types and kinds that are defined deeper in the compiler. For example, row kinds (e.g. `# Type`, which is the kind of types such as `(name :: String, age :: Int)`), Type wildcards (e.g. `f :: _ -> Int`), and Quantified Types. Rather, these are documented in [the PureScript language reference](https://github.com/purescript/documentation/blob/master/language/Types.md)." + ] , modDeclarations = [ function , array @@ -517,4 +521,3 @@ aboveDoc = primTypeOf (P.primSubName "TypeError") "Above" $ T.unlines , "For more information, see" , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." ] - From d9b1620bf31b552f55b7944141c743b88b7bd8ad Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sun, 2 Dec 2018 17:19:16 +0000 Subject: [PATCH 1026/1580] Fix linting of unused type variables (#3464) --- src/Language/PureScript/Linter.hs | 50 +++++++++++++++++++++++-------- 1 file changed, 37 insertions(+), 13 deletions(-) diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 49ede59811..1b92f7c7d4 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -4,11 +4,9 @@ module Language.PureScript.Linter (lint, module L) where import Prelude.Compat -import Protolude (ordNub) import Control.Monad.Writer.Class -import Data.List ((\\)) import Data.Maybe (mapMaybe) import qualified Data.Set as S import Data.Text (Text) @@ -83,25 +81,51 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl checkTypeVarsInDecl s d = let (f, _, _, _, _) = accumTypes (checkTypeVars (declSourceSpan d) s) in f d checkTypeVars :: SourceSpan -> S.Set Text -> Type -> MultipleErrors - checkTypeVars ss set ty = everythingWithContextOnTypes set mempty mappend step ty <> findUnused ty + checkTypeVars ss set ty = everythingWithContextOnTypes set mempty mappend step ty <> snd (findUnused ty) where + step :: S.Set Text -> Type -> (S.Set Text, MultipleErrors) step s (ForAll tv _ _) = bindVar s tv step s _ = (s, mempty) + bindVar :: S.Set Text -> Text -> (S.Set Text, MultipleErrors) bindVar = bind ss ShadowedTypeVar - findUnused :: Type -> MultipleErrors - findUnused ty' = - let used = usedTypeVariables ty' - declared = everythingOnTypes (++) go ty' - unused = ordNub declared \\ ordNub used - in foldl (<>) mempty $ map (errorMessage' ss . UnusedTypeVar) unused - where - go :: Type -> [Text] - go (ForAll tv _ _) = [tv] - go _ = [] + + findUnused :: Type -> (S.Set Text, MultipleErrors) + findUnused = go set where + -- Recursively walk the type and prune used variables from `unused` + go :: S.Set Text -> Type -> (S.Set Text, MultipleErrors) + go unused (TypeVar v) = (S.delete v unused, mempty) + go unused (ForAll tv t1 _) = + let (nowUnused, errors) = go (S.insert tv unused) t1 + restoredUnused = if S.member tv unused then S.insert tv nowUnused else nowUnused + combinedErrors = if S.member tv nowUnused then errors <> errorMessage' ss (UnusedTypeVar tv) else errors + in (restoredUnused, combinedErrors) + go unused (TypeApp f x) = go unused f `combine` go unused x + go unused (ConstrainedType c t1) = foldl combine (unused, mempty) $ map (go unused) (constraintArgs c <> [t1]) + go unused (RCons _ t1 rest) = go unused t1 `combine` go unused rest + go unused (KindedType t1 _) = go unused t1 + go unused (ParensInType t1) = go unused t1 + go unused (BinaryNoParensType t1 t2 t3) = go unused t1 `combine` go unused t2 `combine` go unused t3 + go unused TUnknown{} = (unused, mempty) + go unused TypeLevelString{} = (unused, mempty) + go unused TypeWildcard{} = (unused, mempty) + go unused TypeConstructor{} = (unused, mempty) + go unused TypeOp{} = (unused, mempty) + go unused Skolem{} = (unused, mempty) + go unused REmpty = (unused, mempty) + go unused PrettyPrintFunction{} = (unused, mempty) + go unused PrettyPrintObject{} = (unused, mempty) + go unused PrettyPrintForAll{} = (unused, mempty) + + combine :: + (S.Set Text, MultipleErrors) -> + (S.Set Text, MultipleErrors) -> + (S.Set Text, MultipleErrors) + combine (a, b) (c, d) = (S.intersection a c, b <> d) bind :: (Ord a) => SourceSpan -> (a -> SimpleErrorMessage) -> S.Set a -> a -> (S.Set a, MultipleErrors) bind ss mkError s name | name `S.member` s = (s, errorMessage' ss (mkError name)) | otherwise = (S.insert name s, mempty) + From 04d53f293b665715d61788213bd0d714c1d08778 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sun, 2 Dec 2018 17:20:27 +0000 Subject: [PATCH 1027/1580] Avoid dropping super class dicts for the same class (#3461) Fixes #3431 --- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Environment.hs | 3 ++- src/Language/PureScript/Externs.hs | 10 ++++++-- src/Language/PureScript/TypeChecker.hs | 25 ++++++++++--------- .../PureScript/TypeChecker/Entailment.hs | 9 ++++--- src/Language/PureScript/TypeChecker/Monad.hs | 18 +++++++++---- .../passing/InheritMultipleSuperClasses.purs | 25 +++++++++++++++++++ 7 files changed, 67 insertions(+), 25 deletions(-) create mode 100644 tests/purs/passing/InheritMultipleSuperClasses.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 2725f5da67..2631b33c0a 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -793,7 +793,7 @@ data Expr -- instance type, and the type class dictionaries in scope. -- | TypeClassDictionary Constraint - (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict))) + (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))) [ErrorMessageHint] -- | -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring. diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index e385cfd44f..937c58f544 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -17,6 +17,7 @@ import qualified Data.Text as T import Data.Tree (Tree, rootLabel) import qualified Data.Graph as G import Data.Foldable (toList, fold) +import qualified Data.List.NonEmpty as NEL import Language.PureScript.Crash import Language.PureScript.Kinds @@ -36,7 +37,7 @@ data Environment = Environment -- constructor name, argument types and return type. , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type) -- ^ Type synonyms currently in scope - , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)) + , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) -- ^ Available type class dictionaries. When looking up 'Nothing' in the -- outer map, this returns the map of type class dictionaries in local -- scope (ie dictionaries brought in by a constrained type). diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index e76e000936..a7974bde0d 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -25,6 +25,7 @@ import qualified Data.Text as T import Data.Version (showVersion) import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.List.NonEmpty as NEL import Language.PureScript.AST import Language.PureScript.Crash @@ -154,7 +155,11 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps) (typeClasses env) } applyDecl env (EDKind pn) = env { kinds = S.insert (qual pn) (kinds env) } - applyDecl env (EDInstance className ident tys cs ch idx) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) } + applyDecl env (EDInstance className ident tys cs ch idx) = + env { typeClassDictionaries = + updateMap + (updateMap (M.insertWith (<>) (qual ident) (pure dict)) className) + (Just efModuleName) (typeClassDictionaries env) } where dict :: NamedDict dict = TypeClassDictionaryInScope ch idx (qual ident) [] className tys cs @@ -224,7 +229,8 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies tcdChain tcdIndex | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env)) , m2 <- M.elems m1 - , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2) + , nel <- maybeToList (M.lookup (Qualified (Just mn) ident) m2) + , TypeClassDictionaryInScope{..} <- NEL.toList nel ] toExternsDeclaration (KindRef _ pn) | Qualified (Just mn) pn `S.member` kinds env diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 3a490e3f07..90e7917514 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -160,11 +160,11 @@ addTypeClass qualifiedClassName args implies dependencies ds = do addTypeClassDictionaries :: (MonadState CheckState m) => Maybe ModuleName - -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict) + -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)) -> m () addTypeClassDictionaries mn entries = modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } } - where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st) + where insertState st = M.insertWith (M.unionWith (M.unionWith (<>))) mn entries (typeClassDictionaries . checkEnv $ st) checkDuplicateTypeArguments :: (MonadState CheckState m, MonadError MultipleErrors m) @@ -343,7 +343,7 @@ typeCheckAll moduleName _ = traverse go _ <- traverseTypeInstanceBody checkInstanceMembers body deps' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps let dict = TypeClassDictionaryInScope qualifiedChain idx qualifiedDictName [] className tys (Just deps') - addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict + addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict) return d checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m () @@ -422,15 +422,16 @@ typeCheckAll moduleName _ = traverse go for_ nonOrphanModules $ \m -> do dicts <- M.toList <$> lookupTypeClassDictionariesForClass (Just m) className - for_ dicts $ \(ident, dict) -> do - -- ignore instances in the same instance chain - if ch == tcdChain dict || - instancesAreApart (typeClassCoveringSets typeClass) tys' (tcdInstanceTypes dict) - then return () - else throwError . errorMessage $ - OverlappingInstances className - tys' - [ident, Qualified (Just moduleName) dictName] + for_ dicts $ \(ident, dictNel) -> do + for_ dictNel $ \dict -> do + -- ignore instances in the same instance chain + if ch == tcdChain dict || + instancesAreApart (typeClassCoveringSets typeClass) tys' (tcdInstanceTypes dict) + then return () + else throwError . errorMessage $ + OverlappingInstances className + tys' + [ident, Qualified (Just moduleName) dictName] instancesAreApart :: S.Set (S.Set Int) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 13f8697bfd..2f5e754ebe 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -30,6 +30,7 @@ import qualified Data.Set as S import Data.Traversable (for) import Data.Text (Text, stripPrefix, stripSuffix) import qualified Data.Text as T +import qualified Data.List.NonEmpty as NEL import Language.PureScript.AST import Language.PureScript.Crash @@ -66,7 +67,7 @@ type TypeClassDict = TypeClassDictionaryInScope Evidence -- | The 'InstanceContext' tracks those constraints which can be satisfied. type InstanceContext = M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) - (M.Map (Qualified Ident) NamedDict)) + (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) -- | A type substitution which makes an instance head match a list of types. -- @@ -75,7 +76,7 @@ type InstanceContext = M.Map (Maybe ModuleName) type Matching a = M.Map Text a combineContexts :: InstanceContext -> InstanceContext -> InstanceContext -combineContexts = M.unionWith (M.unionWith M.union) +combineContexts = M.unionWith (M.unionWith (M.unionWith (<>))) -- | Replace type class dictionary placeholders with inferred type class dictionaries replaceTypeClassDictionaries @@ -186,7 +187,7 @@ entails SolverOptions{..} constraint context hints = ctorModules _ = Nothing findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDict] - findDicts ctx cn = fmap (fmap NamedInstance) . maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx + findDicts ctx cn = fmap (fmap NamedInstance) . foldMap NEL.toList . foldMap M.elems . (>>= M.lookup cn) . flip M.lookup ctx valUndefined :: Expr valUndefined = Var nullSourceSpan (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) @@ -637,7 +638,7 @@ newDictionaries path name (Constraint className instanceTy _) = do mkContext :: [NamedDict] -> InstanceContext mkContext = foldr combineContexts M.empty . map fromDict where - fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdValue d) d)) + fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdValue d) (pure d))) -- | Check all pairs of values in a list match a predicate pairwiseAll :: Monoid m => (a -> a -> m) -> [a] -> m diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index dcc40cc42f..e85b1af5fd 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -16,6 +16,7 @@ import Control.Monad.Writer.Class (MonadWriter(..), censor) import Data.Maybe import qualified Data.Map as M import Data.Text (Text) +import qualified Data.List.NonEmpty as NEL import Language.PureScript.Environment import Language.PureScript.Errors @@ -144,8 +145,15 @@ withTypeClassDictionaries -> m a withTypeClassDictionaries entries action = do orig <- get - let mentries = M.fromListWith (M.unionWith M.union) [ (mn, M.singleton className (M.singleton (tcdValue entry) entry)) | entry@TypeClassDictionaryInScope{ tcdValue = Qualified mn _, tcdClassName = className } <- entries ] - modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith M.union) (typeClassDictionaries . checkEnv $ st) mentries } } + + let mentries = + M.fromListWith (M.unionWith (M.unionWith (<>))) + [ (mn, M.singleton className (M.singleton (tcdValue entry) (pure entry))) + | entry@TypeClassDictionaryInScope{ tcdValue = Qualified mn _, tcdClassName = className } + <- entries + ] + + modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith (M.unionWith (<>))) (typeClassDictionaries . checkEnv $ st) mentries } } a <- action modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } } return a @@ -153,14 +161,14 @@ withTypeClassDictionaries entries action = do -- | Get the currently available map of type class dictionaries getTypeClassDictionaries :: (MonadState CheckState m) - => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict))) + => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))) getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get -- | Lookup type class dictionaries in a module. lookupTypeClassDictionaries :: (MonadState CheckState m) => Maybe ModuleName - -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict)) + -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get -- | Lookup type class dictionaries in a module. @@ -168,7 +176,7 @@ lookupTypeClassDictionariesForClass :: (MonadState CheckState m) => Maybe ModuleName -> Qualified (ProperName 'ClassName) - -> m (M.Map (Qualified Ident) NamedDict) + -> m (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)) lookupTypeClassDictionariesForClass mn cn = fromMaybe M.empty . M.lookup cn <$> lookupTypeClassDictionaries mn -- | Temporarily bind a collection of names to local variables diff --git a/tests/purs/passing/InheritMultipleSuperClasses.purs b/tests/purs/passing/InheritMultipleSuperClasses.purs new file mode 100644 index 0000000000..8709965bdb --- /dev/null +++ b/tests/purs/passing/InheritMultipleSuperClasses.purs @@ -0,0 +1,25 @@ +module Main where + +import Prelude +import Effect.Console (log) + +class (Functor f, Functor g) <= Eg1 f g + +f1 :: forall f g. Eg1 f g => f ~> f +f1 = map identity -- Err, No type class instance was found for Functor f + +g1 :: forall f g. Eg1 f g => g ~> g +g1 = map identity -- ok + + +class (Functor g, Functor f) <= Eg2 f g + +f2 :: forall f g. Eg2 f g => f ~> f +f2 = map identity -- ok + +g2 :: forall f g. Eg2 f g => g ~> g +g2 = map identity -- Err, No type class instance was found for Functor g + + +main = log "Done" + From 5ff679dc1dca45b07efda0c1f42ad98509a44f87 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Mon, 3 Dec 2018 16:58:36 +0000 Subject: [PATCH 1028/1580] Ignore tags files (#3465) --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 099161cd5b..06ddeaa54b 100644 --- a/.gitignore +++ b/.gitignore @@ -21,6 +21,8 @@ tests/support/package-lock.json .psc-ide-port .psc-package/ purescript.cabal +tags +TAGS # Profiling related *.aux From a12b0e66ef782c28bd4232c72ba03a3e3c263aa1 Mon Sep 17 00:00:00 2001 From: Matthew Leon Grinshpun Date: Tue, 11 Dec 2018 19:49:32 -0500 Subject: [PATCH 1029/1580] Optimize inferred partial constraint fn (#3218) * test case for TCO with Partial constraint * optimize inferred partial constraint fn fixes https://github.com/purescript/purescript/issues/3157 adds a CoreFn optimization pass * add documentation * fix test * review: move and patch test for ps 0.12 --- src/Language/PureScript/CoreFn/Optimizer.hs | 11 ++++++++++- tests/purs/passing/PartialTCO.purs | 13 +++++++++++++ 2 files changed, 23 insertions(+), 1 deletion(-) create mode 100644 tests/purs/passing/PartialTCO.purs diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 5adeeb9e90..28e12757d3 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -9,6 +9,7 @@ import Language.PureScript.CoreFn.Ann import Language.PureScript.CoreFn.Expr import Language.PureScript.CoreFn.Module import Language.PureScript.CoreFn.Traversals +import Language.PureScript.Names (Ident(UnusedIdent), Qualified(Qualified)) import Language.PureScript.Label import Language.PureScript.Types import qualified Language.PureScript.Constants as C @@ -23,7 +24,7 @@ optimizeModuleDecls :: [Bind Ann] -> [Bind Ann] optimizeModuleDecls = map transformBinds where (transformBinds, _, _) = everywhereOnValues identity transformExprs identity - transformExprs = optimizeClosedRecordUpdate + transformExprs = optimizeUnusedPartialFn . optimizeClosedRecordUpdate optimizeClosedRecordUpdate :: Expr Ann -> Expr Ann optimizeClosedRecordUpdate ou@(ObjectUpdate a@(_, _, Just t, _) r updatedFields) = @@ -45,3 +46,11 @@ closedRecordFields (TypeApp (TypeConstructor C.Record) row) = collect (RCons l _ r) = collect r >>= return . (l :) collect _ = Nothing closedRecordFields _ = Nothing + +-- | See https://github.com/purescript/purescript/issues/3157 +optimizeUnusedPartialFn :: Expr a -> Expr a +optimizeUnusedPartialFn (Let _ + [NonRec _ UnusedIdent _] + (App _ (App _ (Var _ (Qualified _ UnusedIdent)) _) originalCoreFn)) = + originalCoreFn +optimizeUnusedPartialFn e = e diff --git a/tests/purs/passing/PartialTCO.purs b/tests/purs/passing/PartialTCO.purs new file mode 100644 index 0000000000..87589e7e85 --- /dev/null +++ b/tests/purs/passing/PartialTCO.purs @@ -0,0 +1,13 @@ +module Main where + +import Prelude +import Effect.Console (log) +import Partial.Unsafe (unsafePartial) + +main = do + let _ = unsafePartial partialTCO true 1000000 + log "Done" + +partialTCO :: Partial => Boolean -> Int -> Int +partialTCO true 0 = 0 +partialTCO true n = partialTCO true (n - 1) From 6976148a42b435b9f4a1652edb7fdcff53683f3c Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 14 Dec 2018 15:09:52 +0000 Subject: [PATCH 1030/1580] Fix `isUnquotedKey`, fixes #3479 (#3480) Fixes labels not being quoted in error messages in some cases where they should have been. For example: Input code: ``` test :: { "Oops" :: Int } test = { } ``` Before: ``` Type of expression lacks required label Oops. while checking that expression {} has type { Oops :: Int } in value declaration test ``` After: ``` Type of expression lacks required label "Oops". while checking that expression {} has type { "Oops" :: Int } in value declaration test ``` At the time of writing, there is just this one use of `isUnquotedKey` throughout the entire compiler, so the refactoring I've done here is safe. --- src/Language/PureScript/Parser/Lexer.hs | 14 ++++++++------ src/Language/PureScript/Pretty/Common.hs | 9 ++------- 2 files changed, 10 insertions(+), 13 deletions(-) diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 377d9b18a8..6125785fbd 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -69,7 +69,7 @@ import Prelude.Compat hiding (lex) import Control.Applicative ((<|>)) import Control.Monad (void, guard) import Control.Monad.Identity (Identity) -import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum) +import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum, isAlpha, isLower) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T @@ -591,7 +591,7 @@ isSymbolChar c = (c `elem` (":!#$%&*+./<=>?@\\^|-~" :: [Char])) || (not (isAscii -- The characters allowed in the head of an unquoted record key -- isUnquotedKeyHeadChar :: Char -> Bool -isUnquotedKeyHeadChar c = (c == '_') || isAlphaNum c +isUnquotedKeyHeadChar c = (c == '_') || (isAlpha c && isLower c) -- | -- The characters allowed in the tail of an unquoted record key @@ -603,7 +603,9 @@ isUnquotedKeyTailChar c = (c `elem` ("_'" :: [Char])) || isAlphaNum c -- Strings allowed to be left unquoted in a record key -- isUnquotedKey :: Text -> Bool -isUnquotedKey t = case T.uncons t of - Nothing -> False - Just (hd, tl) -> isUnquotedKeyHeadChar hd && - T.all isUnquotedKeyTailChar tl +isUnquotedKey t = + t `notElem` reservedPsNames + && case T.uncons t of + Nothing -> False + Just (hd, tl) -> isUnquotedKeyHeadChar hd && + T.all isUnquotedKeyTailChar tl diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index e26fa2a3b9..d284597a3c 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -12,10 +12,9 @@ import Control.Monad.State (StateT, modify, get) import Data.List (elemIndices, intersperse) import Data.Text (Text) import qualified Data.Text as T -import Data.Char (isUpper) import Language.PureScript.AST (SourcePos(..), SourceSpan(..)) -import Language.PureScript.Parser.Lexer (isUnquotedKey, reservedPsNames) +import Language.PureScript.Parser.Lexer (isUnquotedKey) import Text.PrettyPrint.Boxes hiding ((<>)) import qualified Text.PrettyPrint.Boxes as Box @@ -148,11 +147,7 @@ prettyPrintMany f xs = do return $ intercalate (emit "\n") $ map (mappend indentString) ss objectKeyRequiresQuoting :: Text -> Bool -objectKeyRequiresQuoting s = - s `elem` reservedPsNames || not (isUnquotedKey s) || startsUppercase s where - startsUppercase label = case T.uncons label of - Just (c, _) -> isUpper c - _ -> False +objectKeyRequiresQuoting = not . isUnquotedKey -- | Place a box before another, vertically when the first box takes up multiple lines. before :: Box -> Box -> Box From db0eb78366f180870e734850fca4ff8fcb50f1c2 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sat, 15 Dec 2018 14:26:48 +0000 Subject: [PATCH 1031/1580] PSCi: Support multiple command types in paste-mode (#3471) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit E.g. you can paste an import and a declaration together: ``` > :paste … import Prelude … foo = true … ^D > ``` --- app/Command/REPL.hs | 35 ++++++++++--------- src/Language/PureScript/Interactive/Parser.hs | 6 ++-- tests/TestPsci/TestEnv.hs | 5 +-- tests/purs/psci/Multiline.purs | 2 ++ 4 files changed, 27 insertions(+), 21 deletions(-) diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 07ee153b32..df9a66e12d 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -96,15 +96,15 @@ psciOptions = PSCiOptions <$> many inputFile <*> backend -- | Parses the input and returns either a command, or an error as a 'String'. -getCommand :: forall m. MonadException m => InputT m (Either String (Maybe Command)) -getCommand = handleInterrupt (return (Right Nothing)) $ do +getCommand :: forall m. MonadException m => InputT m (Either String [Command]) +getCommand = handleInterrupt (return (Right [])) $ do line <- withInterrupt $ getInputLine "> " case line of - Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty - Just "" -> return (Right Nothing) - Just s -> return . fmap Just $ parseCommand s + Nothing -> return (Right [QuitPSCi]) -- Ctrl-D when input is empty + Just "" -> return (Right []) + Just s -> return (parseCommand s) -pasteMode :: forall m. MonadException m => InputT m (Either String Command) +pasteMode :: forall m. MonadException m => InputT m (Either String [Command]) pasteMode = parseCommand <$> go [] where @@ -343,16 +343,20 @@ command = loop <$> options c <- getCommand case c of Left err -> outputStrLn err >> go state - Right Nothing -> go state - Right (Just PasteLines) -> do + Right xs -> goExec xs + where + goExec :: [Command] -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) () + goExec xs = case xs of + [] -> go state + (PasteLines : rest) -> do c' <- pasteMode case c' of - Left err -> outputStrLn err >> go state - Right c'' -> handleCommandWithInterrupts state c'' - Right (Just QuitPSCi) -> do + Left err -> outputStrLn err >> goExec rest + Right c'' -> handleCommandWithInterrupts state c'' >> goExec rest + (QuitPSCi : _) -> do outputStrLn quitMessage liftIO $ shutdown state - Right (Just c') -> handleCommandWithInterrupts state c' + (c' : rest) -> handleCommandWithInterrupts state [c'] >> goExec rest loadUserConfig :: state -> StateT PSCiState (ReaderT PSCiConfig IO) () loadUserConfig state = do @@ -366,12 +370,11 @@ command = loop <$> options handleCommandWithInterrupts :: state - -> Command + -> [Command] -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) () - handleCommandWithInterrupts state cmd = do + handleCommandWithInterrupts state cmds = do handleInterrupt (outputStrLn "Interrupted.") - (withInterrupt (lift (handleCommand' state cmd))) - go state + (withInterrupt (lift (for_ cmds (handleCommand' state)))) putStrLn prologueMessage backendState <- setup diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index 9d6df35f69..cc12d55e42 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -33,11 +33,11 @@ parseDotFile filePath s = first show $ do -- | -- Parses PSCI metacommands or expressions input from the user. -- -parseCommand :: String -> Either String Command +parseCommand :: String -> Either String [Command] parseCommand cmdString = case cmdString of - (':' : cmd) -> parseDirective cmd - _ -> parseRest psciCommand cmdString + (':' : cmd) -> pure <$> parseDirective cmd + _ -> parseRest (many1 psciCommand) cmdString parseRest :: P.TokenParser a -> String -> Either String a parseRest p s = first show $ do diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 84cb90fba5..646d93bcd6 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -9,6 +9,7 @@ import Control.Exception.Lifted (bracket_) import Control.Monad (void, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.RWS.Strict (evalRWST, asks, local, RWST) +import Data.Foldable (traverse_) import Data.List (isSuffixOf) import qualified Data.Text as T import qualified Language.PureScript as P @@ -70,10 +71,10 @@ runAndEval :: String -> TestPSCi () -> (String -> TestPSCi ()) -> TestPSCi () runAndEval comm jsOutputEval textOutputEval = case parseCommand comm of Left errStr -> liftIO $ putStrLn errStr >> exitFailure - Right command -> + Right commands -> -- The JS result is ignored, as it's already written in a JS source file. -- For the detail, please refer to Interactive.hs - handleCommand (\_ -> jsOutputEval) (return ()) textOutputEval command + traverse_ (handleCommand (\_ -> jsOutputEval) (return ()) textOutputEval) commands -- | Run a PSCi command, evaluate compiled JS, and ignore evaluation output and printed output run :: String -> TestPSCi () diff --git a/tests/purs/psci/Multiline.purs b/tests/purs/psci/Multiline.purs index 86f0dcf420..c12f543732 100644 --- a/tests/purs/psci/Multiline.purs +++ b/tests/purs/psci/Multiline.purs @@ -1,5 +1,7 @@ +-- @paste import Prelude import Data.Array +-- @paste -- @paste fac :: Int -> Int From b0929614ec121f6bca35585bdf9e92a36ac2e577 Mon Sep 17 00:00:00 2001 From: Justin Woo Date: Sat, 15 Dec 2018 22:34:14 +0800 Subject: [PATCH 1032/1580] print clickable links with row:column information (#3473) --- src/Language/PureScript/AST/SourcePos.hs | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 6ad67542d7..0717a4fa1e 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -33,6 +33,11 @@ displaySourcePos sp = "line " <> T.pack (show (sourcePosLine sp)) <> ", column " <> T.pack (show (sourcePosColumn sp)) +displaySourcePosShort :: SourcePos -> Text +displaySourcePosShort sp = + T.pack (show (sourcePosLine sp)) <> + ":" <> T.pack (show (sourcePosColumn sp)) + instance A.ToJSON SourcePos where toJSON SourcePos{..} = A.toJSON [sourcePosLine, sourcePosColumn] @@ -55,12 +60,19 @@ instance NFData SourceSpan displayStartEndPos :: SourceSpan -> Text displayStartEndPos sp = + "(" <> displaySourcePos (spanStart sp) <> " - " <> - displaySourcePos (spanEnd sp) + displaySourcePos (spanEnd sp) <> ")" + +displayStartEndPosShort :: SourceSpan -> Text +displayStartEndPosShort sp = + displaySourcePosShort (spanStart sp) <> " - " <> + displaySourcePosShort (spanEnd sp) displaySourceSpan :: FilePath -> SourceSpan -> Text displaySourceSpan relPath sp = - T.pack (makeRelative relPath (spanName sp)) <> " " <> + T.pack (makeRelative relPath (spanName sp)) <> ":" <> + displayStartEndPosShort sp <> " " <> displayStartEndPos sp instance A.ToJSON SourceSpan where From 91886cbf94fb3fa5219fcdc64dd8e189779f51e1 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 17 Dec 2018 11:57:00 +0000 Subject: [PATCH 1033/1580] Prevent invalid JS being generated from awkward record labels (#3486) * Refactor properToJs Since it is only used for ProperName values at all but one call site, refactor to require that the argument is a ProperName rather than any old Text. * Fix check for valid identifiers during JS codegen Fixes #3481; the check for whether a string represents a valid JS identifier was previously too permissive, i.e. it would allow through some strings are not valid as JS identifiers, leading to invalid syntax in the generated JS. For example, a string beginning with a digit is not a valid JS identifier but it was previously considered to be by the codegen phase of the compiler. --- src/Language/PureScript/CodeGen/JS.hs | 6 +-- src/Language/PureScript/CodeGen/JS/Common.hs | 37 +++++++++++++++---- src/Language/PureScript/CodeGen/JS/Printer.hs | 4 +- tests/purs/passing/3481.purs | 7 ++++ 4 files changed, 41 insertions(+), 13 deletions(-) create mode 100644 tests/purs/passing/3481.purs diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index adf235f81e..59576f00b5 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -233,16 +233,16 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ = ds' <- concat <$> mapM bindToJs ds ret <- valueToJs val return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (ds' ++ [AST.Return Nothing ret]))) [] - valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = + valueToJs' (Constructor (_, _, _, Just IsNewtype) _ ctor _) = return $ AST.VariableIntroduction Nothing (properToJs ctor) (Just $ AST.ObjectLiteral Nothing [("create", AST.Function Nothing Nothing ["value"] (AST.Block Nothing [AST.Return Nothing $ AST.Var Nothing "value"]))]) - valueToJs' (Constructor _ _ (ProperName ctor) []) = + valueToJs' (Constructor _ _ ctor []) = return $ iife (properToJs ctor) [ AST.Function Nothing (Just (properToJs ctor)) [] (AST.Block Nothing []) , AST.Assignment Nothing (accessorString "value" (AST.Var Nothing (properToJs ctor))) (AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing (properToJs ctor)) []) ] - valueToJs' (Constructor _ _ (ProperName ctor) fields) = + valueToJs' (Constructor _ _ ctor fields) = let constructor = let body = [ AST.Assignment Nothing ((accessorString $ mkString $ identToJs f) (AST.Var Nothing "this")) (var f) | f <- fields ] in AST.Function Nothing (Just (properToJs ctor)) (identToJs `map` fields) (AST.Block Nothing body) diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 603b75d3c0..c13a22d985 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -20,21 +20,42 @@ moduleNameToJs (ModuleName pns) = -- * Alphanumeric characters are kept unmodified. -- -- * Reserved javascript identifiers are prefixed with '$$'. --- --- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value. identToJs :: Ident -> Text -identToJs (Ident name) = properToJs name +identToJs (Ident name) = anyNameToJs name identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" identToJs UnusedIdent = "$__unused" -properToJs :: Text -> Text -properToJs name +-- | Convert a 'ProperName' into a valid JavaScript identifier: +-- +-- * Alphanumeric characters are kept unmodified. +-- +-- * Reserved javascript identifiers are prefixed with '$$'. +properToJs :: ProperName a -> Text +properToJs = anyNameToJs . runProperName + +-- | Convert any name into a valid JavaScript identifier. +-- +-- Note that this function assumes that the argument is a valid PureScript +-- identifier (either an 'Ident' or a 'ProperName') to begin with; as such it +-- will not produce valid JavaScript identifiers if the argument e.g. begins +-- with a digit. Prefer 'identToJs' or 'properToJs' where possible. +anyNameToJs :: Text -> Text +anyNameToJs name | nameIsJsReserved name || nameIsJsBuiltIn name = "$$" <> name | otherwise = T.concatMap identCharToText name --- | Test if a string is a valid AST identifier without escaping. -identNeedsEscaping :: Text -> Bool -identNeedsEscaping s = s /= properToJs s || T.null s +-- | Test if a string is a valid JavaScript identifier as-is. Note that, while +-- a return value of 'True' guarantees that the string is a valid JS +-- identifier, a return value of 'False' does not guarantee that the string is +-- not a valid JS identifier. That is, this check is more conservative than +-- absolutely necessary. +isValidJsIdentifier :: Text -> Bool +isValidJsIdentifier s = + and + [ not (T.null s) + , isAlpha (T.head s) + , s == anyNameToJs s + ] -- | Attempts to find a human-readable name for a symbol, if none has been specified returns the -- ordinal value. diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index da67fa78eb..b69270cdac 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -57,7 +57,7 @@ literals = mkPattern' match' objectPropertyToString :: (Emit gen) => PSString -> gen objectPropertyToString s = emit $ case decodeString s of - Just s' | not (identNeedsEscaping s') -> + Just s' | isValidJsIdentifier s' -> s' _ -> prettyPrintStringJS s @@ -154,7 +154,7 @@ accessor = mkPattern match where match (Indexer _ (StringLiteral _ prop) val) = case decodeString prop of - Just s | not (identNeedsEscaping s) -> Just (s, val) + Just s | isValidJsIdentifier s -> Just (s, val) _ -> Nothing match _ = Nothing diff --git a/tests/purs/passing/3481.purs b/tests/purs/passing/3481.purs new file mode 100644 index 0000000000..32d4751ded --- /dev/null +++ b/tests/purs/passing/3481.purs @@ -0,0 +1,7 @@ +module Main where + +import Effect.Console (log) + +message = { "0": { "1": "Done" }} + +main = log message."0"."1" From 8424d521d452c6bed4f101ccab934899f7934a02 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 21 Dec 2018 05:55:18 +0000 Subject: [PATCH 1034/1580] Fix isUnquotedKey check to allow reserved names (#3487) Fixes #3482. We have allowed reserved names (like `data` or `type`) to be used as record labels without being quoted since #699 was resolved. This commit makes the `isUnquotedKey` function aware of this, having the effect that these labels are no longer unnecessarily quoted in error messages. For example, if we enter > {} :: { data :: Int } in the repl, we now receive: Error found: Type of expression lacks required label data. while checking that expression {} has type { data :: Int } whereas previously, `data` would have been quoted. --- src/Language/PureScript/Parser/Lexer.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index 6125785fbd..cc615ff53f 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -604,8 +604,7 @@ isUnquotedKeyTailChar c = (c `elem` ("_'" :: [Char])) || isAlphaNum c -- isUnquotedKey :: Text -> Bool isUnquotedKey t = - t `notElem` reservedPsNames - && case T.uncons t of - Nothing -> False - Just (hd, tl) -> isUnquotedKeyHeadChar hd && - T.all isUnquotedKeyTailChar tl + case T.uncons t of + Nothing -> False + Just (hd, tl) -> isUnquotedKeyHeadChar hd && + T.all isUnquotedKeyTailChar tl From 05744cbf3be0c5e047df685fe0e826f062f478a3 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Fri, 21 Dec 2018 09:43:05 -0800 Subject: [PATCH 1035/1580] Add annotations to Type and Kind (#3484) * Kinds with spans * Types with spans * Add type aliases for source annotated Type/Kind/Constraint * Add constructors applied to null source annotations * Custom Eq/Ord instances for types and kinds * Passing tests * Use () for doc annotations * Use more src constructors * Use min/max for SourcePos * Update comments, add overlapping instance for Kind () * Add missing case for compareKind --- src/Language/PureScript/AST/Binders.hs | 2 +- src/Language/PureScript/AST/Declarations.hs | 98 ++-- src/Language/PureScript/AST/Exported.hs | 4 +- src/Language/PureScript/AST/SourcePos.hs | 23 + src/Language/PureScript/AST/Traversals.hs | 8 +- src/Language/PureScript/Comments.hs | 7 +- src/Language/PureScript/CoreFn/Ann.hs | 50 +- src/Language/PureScript/CoreFn/Desugar.hs | 8 +- src/Language/PureScript/CoreFn/Optimizer.hs | 10 +- src/Language/PureScript/Docs/Convert.hs | 3 +- .../PureScript/Docs/Convert/ReExports.hs | 16 +- .../PureScript/Docs/Convert/Single.hs | 26 +- src/Language/PureScript/Docs/Prim.hs | 9 +- src/Language/PureScript/Docs/Render.hs | 28 +- .../Docs/RenderedCode/RenderKind.hs | 21 +- .../Docs/RenderedCode/RenderType.hs | 93 ++-- src/Language/PureScript/Docs/Types.hs | 41 +- src/Language/PureScript/Environment.hs | 142 ++--- src/Language/PureScript/Errors.hs | 65 +-- src/Language/PureScript/Externs.hs | 20 +- src/Language/PureScript/Hierarchy.hs | 2 +- src/Language/PureScript/Ide/CaseSplit.hs | 26 +- src/Language/PureScript/Ide/Error.hs | 2 +- src/Language/PureScript/Ide/Externs.hs | 2 +- src/Language/PureScript/Ide/SourceFile.hs | 2 +- src/Language/PureScript/Ide/Types.hs | 26 +- src/Language/PureScript/Interactive.hs | 2 +- src/Language/PureScript/Interactive/Module.hs | 8 +- .../PureScript/Interactive/Printer.hs | 18 +- src/Language/PureScript/Interactive/Types.hs | 2 +- src/Language/PureScript/Kinds.hs | 153 ++++-- src/Language/PureScript/Linter.hs | 28 +- src/Language/PureScript/Linter/Exhaustive.hs | 18 +- .../PureScript/Parser/Declarations.hs | 11 +- src/Language/PureScript/Parser/Kinds.hs | 14 +- src/Language/PureScript/Parser/Types.hs | 109 ++-- src/Language/PureScript/Pretty/Kinds.hs | 20 +- src/Language/PureScript/Pretty/Types.hs | 104 ++-- src/Language/PureScript/Pretty/Values.hs | 2 +- .../PureScript/Sugar/BindingGroups.hs | 8 +- src/Language/PureScript/Sugar/Names.hs | 32 +- src/Language/PureScript/Sugar/Operators.hs | 20 +- .../PureScript/Sugar/Operators/Types.hs | 18 +- src/Language/PureScript/Sugar/TypeClasses.hs | 47 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 122 ++--- src/Language/PureScript/TypeChecker.hs | 106 ++-- .../PureScript/TypeChecker/Entailment.hs | 259 +++++----- src/Language/PureScript/TypeChecker/Kinds.hs | 125 ++--- src/Language/PureScript/TypeChecker/Monad.hs | 18 +- .../PureScript/TypeChecker/Skolems.hs | 34 +- .../PureScript/TypeChecker/Subsumption.hs | 36 +- .../PureScript/TypeChecker/Synonyms.hs | 20 +- .../PureScript/TypeChecker/TypeSearch.hs | 27 +- src/Language/PureScript/TypeChecker/Types.hs | 159 +++--- src/Language/PureScript/TypeChecker/Unify.hs | 116 ++--- .../PureScript/TypeClassDictionaries.hs | 4 +- src/Language/PureScript/Types.hs | 486 ++++++++++++------ tests/Language/PureScript/Ide/MatcherSpec.hs | 2 +- .../Language/PureScript/Ide/SourceFileSpec.hs | 10 +- tests/Language/PureScript/Ide/StateSpec.hs | 10 +- tests/Language/PureScript/Ide/Test.hs | 16 +- tests/TestDocs.hs | 18 +- tests/TestHierarchy.hs | 2 +- 63 files changed, 1628 insertions(+), 1290 deletions(-) diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index 19e1d18db8..528ffb0987 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -60,7 +60,7 @@ data Binder -- | -- A binder with a type annotation -- - | TypedBinder Type Binder + | TypedBinder SourceType Binder deriving (Show) -- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 2631b33c0a..6c2d12887a 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -39,16 +39,16 @@ import qualified Language.PureScript.Constants as C import qualified Text.Parsec as P -- | A map of locally-bound names in scope. -type Context = [(Ident, Type)] +type Context = [(Ident, SourceType)] -- | Holds the data necessary to do type directed search for typed holes data TypeSearch = TSBefore Environment -- ^ An Environment captured for later consumption by type directed search | TSAfter - { tsAfterIdentifiers :: [(Qualified Text, Type)] + { tsAfterIdentifiers :: [(Qualified Text, SourceType)] -- ^ The identifiers that fully satisfy the subsumption check - , tsAfterRecordFields :: Maybe [(Label, Type)] + , tsAfterRecordFields :: Maybe [(Label, SourceType)] -- ^ Record fields that are available on the first argument to the typed -- hole } @@ -56,10 +56,10 @@ data TypeSearch -- Environment deriving Show -onTypeSearchTypes :: (Type -> Type) -> TypeSearch -> TypeSearch +onTypeSearchTypes :: (SourceType -> SourceType) -> TypeSearch -> TypeSearch onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f) -onTypeSearchTypesM :: (Applicative m) => (Type -> m Type) -> TypeSearch -> m TypeSearch +onTypeSearchTypesM :: (Applicative m) => (SourceType -> m SourceType) -> TypeSearch -> m TypeSearch onTypeSearchTypesM f (TSAfter i r) = TSAfter <$> traverse (traverse f) i <*> traverse (traverse (traverse f)) r onTypeSearchTypesM _ (TSBefore env) = pure (TSBefore env) @@ -76,8 +76,8 @@ data SimpleErrorMessage | CannotGetFileInfo FilePath | CannotReadFile FilePath | CannotWriteFile FilePath - | InfiniteType Type - | InfiniteKind Kind + | InfiniteType SourceType + | InfiniteKind SourceKind | MultipleValueOpFixities (OpName 'ValueOpName) | MultipleTypeOpFixities (OpName 'TypeOpName) | OrphanTypeDeclaration Ident @@ -104,46 +104,46 @@ data SimpleErrorMessage | NameIsUndefined Ident | UndefinedTypeVariable (ProperName 'TypeName) | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName)) - | EscapedSkolem Text (Maybe SourceSpan) Type - | TypesDoNotUnify Type Type - | KindsDoNotUnify Kind Kind - | ConstrainedTypeUnified Type Type - | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident] - | NoInstanceFound Constraint - | AmbiguousTypeVariables Type Constraint + | EscapedSkolem Text (Maybe SourceSpan) SourceType + | TypesDoNotUnify SourceType SourceType + | KindsDoNotUnify SourceKind SourceKind + | ConstrainedTypeUnified SourceType SourceType + | OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified Ident] + | NoInstanceFound SourceConstraint + | AmbiguousTypeVariables SourceType SourceConstraint | UnknownClass (Qualified (ProperName 'ClassName)) - | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type] - | CannotDerive (Qualified (ProperName 'ClassName)) [Type] - | InvalidDerivedInstance (Qualified (ProperName 'ClassName)) [Type] Int - | ExpectedTypeConstructor (Qualified (ProperName 'ClassName)) [Type] Type - | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type] - | MissingNewtypeSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [Type] - | UnverifiableSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [Type] + | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [SourceType] + | CannotDerive (Qualified (ProperName 'ClassName)) [SourceType] + | InvalidDerivedInstance (Qualified (ProperName 'ClassName)) [SourceType] Int + | ExpectedTypeConstructor (Qualified (ProperName 'ClassName)) [SourceType] SourceType + | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [SourceType] + | MissingNewtypeSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType] + | UnverifiableSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType] | CannotFindDerivingType (ProperName 'TypeName) | DuplicateLabel Label (Maybe Expr) | DuplicateValueDeclaration Ident | ArgListLengthsDiffer Ident | OverlappingArgNames (Maybe Ident) - | MissingClassMember (NEL.NonEmpty (Ident, Type)) + | MissingClassMember (NEL.NonEmpty (Ident, SourceType)) | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName)) - | ExpectedType Type Kind + | ExpectedType SourceType SourceKind -- | constructor name, expected argument count, actual argument count | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName)) Int Int - | ExprDoesNotHaveType Expr Type + | ExprDoesNotHaveType Expr SourceType | PropertyIsMissing Label | AdditionalProperty Label | TypeSynonymInstance - | OrphanInstance Ident (Qualified (ProperName 'ClassName)) (Set ModuleName) [Type] + | OrphanInstance Ident (Qualified (ProperName 'ClassName)) (Set ModuleName) [SourceType] | InvalidNewtype (ProperName 'TypeName) - | InvalidInstanceHead Type + | InvalidInstanceHead SourceType | TransitiveExportError DeclarationRef [DeclarationRef] | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName) | ShadowedName Ident | ShadowedTypeVar Text | UnusedTypeVar Text - | WildcardInferredType Type Context - | HoleInferredType Text Type Context TypeSearch - | MissingTypeDeclaration Ident Type + | WildcardInferredType SourceType Context + | HoleInferredType Text SourceType Context TypeSearch + | MissingTypeDeclaration Ident SourceType | OverlappingPattern [[Binder]] Bool | IncompleteExhaustivityCheck | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName) @@ -164,14 +164,14 @@ data SimpleErrorMessage | CaseBinderLengthDiffers Int [Binder] | IncorrectAnonymousArgument | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident) - | CannotGeneralizeRecursiveFunction Ident Type + | CannotGeneralizeRecursiveFunction Ident SourceType | CannotDeriveNewtypeForData (ProperName 'TypeName) | ExpectedWildcard (ProperName 'TypeName) | CannotUseBindWithDo Ident -- | instance name, type class, expected argument count, actual argument count | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int -- | a user-defined warning raised by using the Warn type class - | UserDefinedWarning Type + | UserDefinedWarning SourceType -- | a declaration couldn't be used because it contained free variables | UnusableDeclaration Ident [[Text]] | CannotDefinePrimModules ModuleName @@ -181,17 +181,17 @@ data SimpleErrorMessage -- | Error message hints, providing more detailed information about failure. data ErrorMessageHint - = ErrorUnifyingTypes Type Type + = ErrorUnifyingTypes SourceType SourceType | ErrorInExpression Expr | ErrorInModule ModuleName - | ErrorInInstance (Qualified (ProperName 'ClassName)) [Type] - | ErrorInSubsumption Type Type + | ErrorInInstance (Qualified (ProperName 'ClassName)) [SourceType] + | ErrorInSubsumption SourceType SourceType | ErrorCheckingAccessor Expr PSString - | ErrorCheckingType Expr Type - | ErrorCheckingKind Type + | ErrorCheckingType Expr SourceType + | ErrorCheckingKind SourceType | ErrorCheckingGuard | ErrorInferringType Expr - | ErrorInApplication Expr Type Expr + | ErrorInApplication Expr SourceType Expr | ErrorInDataConstructor (ProperName 'ConstructorName) | ErrorInTypeConstructor (ProperName 'TypeName) | ErrorInBindingGroup (NEL.NonEmpty Ident) @@ -201,7 +201,7 @@ data ErrorMessageHint | ErrorInTypeDeclaration Ident | ErrorInTypeClassDeclaration (ProperName 'ClassName) | ErrorInForeignImport Ident - | ErrorSolvingConstraint Constraint + | ErrorSolvingConstraint SourceConstraint | PositionedError (NEL.NonEmpty SourceSpan) deriving (Show) @@ -432,7 +432,7 @@ isExplicit _ = False data TypeDeclarationData = TypeDeclarationData { tydeclSourceAnn :: !SourceAnn , tydeclIdent :: !Ident - , tydeclType :: !Type + , tydeclType :: !SourceType } deriving (Show, Eq) overTypeDeclaration :: (TypeDeclarationData -> TypeDeclarationData) -> Declaration -> Declaration @@ -442,7 +442,7 @@ getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData getTypeDeclaration (TypeDeclaration d) = Just d getTypeDeclaration _ = Nothing -unwrapTypeDeclaration :: TypeDeclarationData -> (Ident, Type) +unwrapTypeDeclaration :: TypeDeclarationData -> (Ident, SourceType) unwrapTypeDeclaration td = (tydeclIdent td, tydeclType td) -- | A value declaration assigns a name and potential binders, to an expression (or multiple guarded expressions). @@ -478,7 +478,7 @@ data Declaration -- | -- A data type declaration (data or newtype, name, arguments, data constructors) -- - = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])] + = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceKind)] [(ProperName 'ConstructorName, [SourceType])] -- | -- A minimal mutually recursive set of data type declarations -- @@ -486,7 +486,7 @@ data Declaration -- | -- A type synonym declaration (name, arguments, type) -- - | TypeSynonymDeclaration SourceAnn (ProperName 'TypeName) [(Text, Maybe Kind)] Type + | TypeSynonymDeclaration SourceAnn (ProperName 'TypeName) [(Text, Maybe SourceKind)] SourceType -- | -- A type declaration for a value (name, ty) -- @@ -505,11 +505,11 @@ data Declaration -- | -- A foreign import declaration (name, type) -- - | ExternDeclaration SourceAnn Ident Type + | ExternDeclaration SourceAnn Ident SourceType -- | -- A data type foreign import (name, kind) -- - | ExternDataDeclaration SourceAnn (ProperName 'TypeName) Kind + | ExternDataDeclaration SourceAnn (ProperName 'TypeName) SourceKind -- | -- A foreign kind import (name) -- @@ -525,12 +525,12 @@ data Declaration -- | -- A type class declaration (name, argument, implies, member declarations) -- - | TypeClassDeclaration SourceAnn (ProperName 'ClassName) [(Text, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration] + | TypeClassDeclaration SourceAnn (ProperName 'ClassName) [(Text, Maybe SourceKind)] [SourceConstraint] [FunctionalDependency] [Declaration] -- | -- A type instance declaration (instance chain, chain index, name, -- dependencies, class name, instance types, member declarations) -- - | TypeInstanceDeclaration SourceAnn [Ident] Integer Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody + | TypeInstanceDeclaration SourceAnn [Ident] Integer Ident [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody deriving (Show) data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName) @@ -767,7 +767,7 @@ data Expr -- | -- A value with a type annotation -- - | TypedValue Bool Expr Type + | TypedValue Bool Expr SourceType -- | -- A let binding -- @@ -792,7 +792,7 @@ data Expr -- at superclass implementations when searching for a dictionary, the type class name and -- instance type, and the type class dictionaries in scope. -- - | TypeClassDictionary Constraint + | TypeClassDictionary SourceConstraint (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))) [ErrorMessageHint] -- | @@ -802,7 +802,7 @@ data Expr -- | -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking -- - | DeferredDictionary (Qualified (ProperName 'ClassName)) [Type] + | DeferredDictionary (Qualified (ProperName 'ClassName)) [SourceType] -- | -- A placeholder for an anonymous function argument -- diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index a566773a8d..f24b1dc697 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -110,8 +110,8 @@ typeInstanceConstituents (TypeInstanceDeclaration _ _ _ _ constraints className -- Note that type synonyms are disallowed in instance declarations, so -- we don't need to handle them here. - go (TypeConstructor n) = [Right n] - go (ConstrainedType c _) = fromConstraint c + go (TypeConstructor _ n) = [Right n] + go (ConstrainedType _ c _) = fromConstraint c go _ = [] typeInstanceConstituents _ = [] diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 0717a4fa1e..5b8f27940a 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -94,3 +94,26 @@ internalModuleSourceSpan name = SourceSpan name (SourcePos 0 0) (SourcePos 0 0) nullSourceSpan :: SourceSpan nullSourceSpan = internalModuleSourceSpan "" + +nullSourceAnn :: SourceAnn +nullSourceAnn = (nullSourceSpan, []) + +pattern NullSourceSpan :: SourceSpan +pattern NullSourceSpan = SourceSpan "" (SourcePos 0 0) (SourcePos 0 0) + +pattern NullSourceAnn :: SourceAnn +pattern NullSourceAnn = (NullSourceSpan, []) + +nonEmptySpan :: SourceAnn -> Maybe SourceSpan +nonEmptySpan (NullSourceSpan, _) = Nothing +nonEmptySpan (ss, _) = Just ss + +widenSourceSpan :: SourceSpan -> SourceSpan -> SourceSpan +widenSourceSpan (SourceSpan n1 s1 e1) (SourceSpan n2 s2 e2) = + SourceSpan n (min s1 s2) (max e1 e2) + where + n | n1 == "" = n2 + | otherwise = n1 + +widenSourceAnn :: SourceAnn -> SourceAnn -> SourceAnn +widenSourceAnn (s1, _) (s2, _) = (widenSourceSpan s1 s2, []) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 50bf45d835..3764d2cd95 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -620,7 +620,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) accumTypes :: (Monoid r) - => (Type -> r) + => (SourceType -> r) -> ( Declaration -> r , Expr -> r , Binder -> r @@ -644,7 +644,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con accumKinds :: (Monoid r) - => (Kind -> r) + => (SourceKind -> r) -> ( Declaration -> r , Expr -> r , Binder -> r @@ -675,13 +675,13 @@ accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (con forValues (TypedValue _ _ ty) = forTypes ty forValues _ = mempty - forTypes (KindedType _ k) = f k + forTypes (KindedType _ _ k) = f k forTypes _ = mempty -- | -- Map a function over type annotations appearing inside a value -- -overTypes :: (Type -> Type) -> Expr -> Expr +overTypes :: (SourceType -> SourceType) -> Expr -> Expr overTypes f = let (_, f', _) = everywhereOnValues id g id in f' where g :: Expr -> Expr diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs index fd8f678207..5c5acd82ac 100644 --- a/src/Language/PureScript/Comments.hs +++ b/src/Language/PureScript/Comments.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} -- | -- Defines the types of source code comments @@ -6,13 +7,17 @@ module Language.PureScript.Comments where import Prelude.Compat +import Control.DeepSeq (NFData) import Data.Text (Text) +import GHC.Generics (Generic) import Data.Aeson.TH data Comment = LineComment Text | BlockComment Text - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance NFData Comment $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment) diff --git a/src/Language/PureScript/CoreFn/Ann.hs b/src/Language/PureScript/CoreFn/Ann.hs index 5d5b96fdff..cb536cc2f7 100644 --- a/src/Language/PureScript/CoreFn/Ann.hs +++ b/src/Language/PureScript/CoreFn/Ann.hs @@ -1,25 +1,25 @@ -module Language.PureScript.CoreFn.Ann where - -import Prelude.Compat - -import Language.PureScript.AST.SourcePos -import Language.PureScript.Comments -import Language.PureScript.CoreFn.Meta -import Language.PureScript.Types - --- | --- Type alias for basic annotations --- -type Ann = (SourceSpan, [Comment], Maybe Type, Maybe Meta) - --- | --- An annotation empty of metadata aside from a source span. --- -ssAnn :: SourceSpan -> Ann -ssAnn ss = (ss, [], Nothing, Nothing) - --- | --- Remove the comments from an annotation --- -removeComments :: Ann -> Ann -removeComments (ss, _, ty, meta) = (ss, [], ty, meta) +module Language.PureScript.CoreFn.Ann where + +import Prelude.Compat + +import Language.PureScript.AST.SourcePos +import Language.PureScript.Comments +import Language.PureScript.CoreFn.Meta +import Language.PureScript.Types + +-- | +-- Type alias for basic annotations +-- +type Ann = (SourceSpan, [Comment], Maybe SourceType, Maybe Meta) + +-- | +-- An annotation empty of metadata aside from a source span. +-- +ssAnn :: SourceSpan -> Ann +ssAnn ss = (ss, [], Nothing, Nothing) + +-- | +-- Remove the comments from an annotation +-- +removeComments :: Ann -> Ann +removeComments (ss, _, ty, meta) = (ss, [], ty, meta) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index c16c54f5ea..b404558999 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -72,7 +72,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = declToCoreFn _ = [] -- | Desugars expressions from AST to CoreFn representation. - exprToCoreFn :: SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann + exprToCoreFn :: SourceSpan -> [Comment] -> Maybe SourceType -> A.Expr -> Expr Ann exprToCoreFn _ com ty (A.Literal ss lit) = Literal (ss, com, ty, Nothing) (fmap (exprToCoreFn ss com Nothing) lit) exprToCoreFn ss com ty (A.Accessor name v) = @@ -178,12 +178,12 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = where numConstructors - :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident])) + :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) -> Int numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env typeConstructor - :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, Type, [Ident])) + :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) -> (ModuleName, ProperName 'TypeName) typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) typeConstructor _ = internalError "Invalid argument to typeConstructor" @@ -241,7 +241,7 @@ exportToCoreFn _ = [] -- | Makes a typeclass dictionary constructor function. The returned expression -- is a function that accepts the superclass instances and member -- implementations and returns a record for the instance dictionary. -mkTypeClassConstructor :: SourceAnn -> [Constraint] -> [A.Declaration] -> Expr Ann +mkTypeClassConstructor :: SourceAnn -> [SourceConstraint] -> [A.Declaration] -> Expr Ann mkTypeClassConstructor (ss, com) [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral []) mkTypeClassConstructor (ss, com) supers members = let args@(a:as) = sort $ fmap typeClassMemberName members ++ superClassDictionaryNames supers diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 28e12757d3..44567022d4 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -37,13 +37,13 @@ optimizeClosedRecordUpdate ou@(ObjectUpdate a@(_, _, Just t, _) r updatedFields) optimizeClosedRecordUpdate e = e -- | Return the labels of a closed record, or Nothing for other types or open records. -closedRecordFields :: Type -> Maybe [Label] -closedRecordFields (TypeApp (TypeConstructor C.Record) row) = +closedRecordFields :: Type a -> Maybe [Label] +closedRecordFields (TypeApp _ (TypeConstructor _ C.Record) row) = collect row where - collect :: Type -> Maybe [Label] - collect REmpty = Just [] - collect (RCons l _ r) = collect r >>= return . (l :) + collect :: Type a -> Maybe [Label] + collect (REmpty _) = Just [] + collect (RCons _ l _ r) = collect r >>= return . (l :) collect _ = Nothing closedRecordFields _ = Nothing diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index be6db2f908..1acbadddbd 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -14,6 +14,7 @@ import Protolude hiding (check) import Control.Arrow ((&&&)) import Control.Category ((>>>)) import Control.Monad.Writer.Strict (runWriterT) +import Data.Functor (($>)) import qualified Data.Map as Map import Data.String (String) @@ -213,7 +214,7 @@ insertValueTypes env m = ident = parseIdent (declTitle d) ty = lookupName ident in - d { declInfo = ValueDeclaration ty } + d { declInfo = ValueDeclaration (ty $> ()) } go other = other diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 241acaab49..980af53d4c 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -195,7 +195,7 @@ lookupValueDeclaration :: MonadReader P.ModuleName m) => P.ModuleName -> P.Ident -> - m (P.ModuleName, [Either (Text, P.Constraint, ChildDeclaration) Declaration]) + m (P.ModuleName, [Either (Text, Constraint', ChildDeclaration) Declaration]) lookupValueDeclaration importedFrom ident = do decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom let @@ -360,7 +360,7 @@ lookupModuleDeclarations definedIn moduleName = do handleTypeClassMembers :: (MonadReader P.ModuleName m) => - Map P.ModuleName [Either (Text, P.Constraint, ChildDeclaration) Declaration] -> + Map P.ModuleName [Either (Text, Constraint', ChildDeclaration) Declaration] -> Map P.ModuleName [Declaration] -> m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration]) handleTypeClassMembers valsAndMembers typeClasses = @@ -375,7 +375,7 @@ handleTypeClassMembers valsAndMembers typeClasses = |> fmap splitMap valsAndMembersToEnv :: - [Either (Text, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv + [Either (Text, Constraint', ChildDeclaration) Declaration] -> TypeClassEnv valsAndMembersToEnv xs = let (envUnhandledMembers, envValues) = partitionEithers xs envTypeClasses = [] @@ -400,7 +400,7 @@ data TypeClassEnv = TypeClassEnv -- name of the type class they belong to, and the constraint is used to -- make sure that they have the correct type if they get promoted. -- - envUnhandledMembers :: [(Text, P.Constraint, ChildDeclaration)] + envUnhandledMembers :: [(Text, Constraint', ChildDeclaration)] -- | -- A list of normal value declarations. Type class members will be added to -- this list if their parent type class is not available. @@ -468,7 +468,7 @@ handleEnv TypeClassEnv{..} = ++ T.unpack cdeclTitle) addConstraint constraint = - P.quantify . P.moveQuantifiersToFront . P.ConstrainedType constraint + P.quantify . P.moveQuantifiersToFront . P.ConstrainedType () constraint splitMap :: Map k (v1, v2) -> (Map k v1, Map k v2) splitMap = fmap fst &&& fmap snd @@ -534,12 +534,12 @@ internalErrorInModule msg = do -- If the provided Declaration is a TypeClassDeclaration, construct an -- appropriate Constraint for use with the types of its members. -- -typeClassConstraintFor :: Declaration -> Maybe P.Constraint +typeClassConstraintFor :: Declaration -> Maybe Constraint' typeClassConstraintFor Declaration{..} = case declInfo of TypeClassDeclaration tyArgs _ _ -> - Just (P.Constraint (P.Qualified Nothing (P.ProperName declTitle)) (mkConstraint tyArgs) Nothing) + Just (P.Constraint () (P.Qualified Nothing (P.ProperName declTitle)) (mkConstraint tyArgs) Nothing) _ -> Nothing where - mkConstraint = map (P.TypeVar . fst) + mkConstraint = map (P.TypeVar () . fst) diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 045fe34c4a..e366302375 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -7,6 +7,7 @@ import Protolude hiding (moduleName) import Control.Category ((>>>)) +import Data.Functor (($>)) import qualified Data.Text as T import Language.PureScript.Docs.Types @@ -110,33 +111,34 @@ basicDeclaration sa title = Just . Right . mkDeclaration sa title convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration convertDeclaration (P.ValueDecl sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title = - basicDeclaration sa title (ValueDeclaration ty) + basicDeclaration sa title (ValueDeclaration (ty $> ())) convertDeclaration (P.ValueDecl sa _ _ _ _) title = -- If no explicit type declaration was provided, insert a wildcard, so that -- the actual type will be added during type checking. - basicDeclaration sa title (ValueDeclaration (P.TypeWildcard (fst sa))) + basicDeclaration sa title (ValueDeclaration (P.TypeWildcard ())) convertDeclaration (P.ExternDeclaration sa _ ty) title = - basicDeclaration sa title (ValueDeclaration ty) + basicDeclaration sa title (ValueDeclaration (ty $> ())) convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title = Just (Right (mkDeclaration sa title info) { declChildren = children }) where - info = DataDeclaration dtype args - children = map convertCtor ctors + info = DataDeclaration dtype (fmap (fmap (fmap ($> ()))) args) + children = map convertCtor (fmap (fmap (fmap ($> ()))) ctors) convertCtor (ctor', tys) = ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys) convertDeclaration (P.ExternDataDeclaration sa _ kind') title = - basicDeclaration sa title (ExternDataDeclaration kind') + basicDeclaration sa title (ExternDataDeclaration (kind' $> ())) convertDeclaration (P.ExternKindDeclaration sa _) title = basicDeclaration sa title ExternKindDeclaration convertDeclaration (P.TypeSynonymDeclaration sa _ args ty) title = - basicDeclaration sa title (TypeSynonymDeclaration args ty) + basicDeclaration sa title (TypeSynonymDeclaration (fmap (fmap (fmap ($> ()))) args) (ty $> ())) convertDeclaration (P.TypeClassDeclaration sa _ args implies fundeps ds) title = Just (Right (mkDeclaration sa title info) { declChildren = children }) where - info = TypeClassDeclaration args implies (convertFundepsToStrings args fundeps) + args' = fmap (fmap (fmap ($> ()))) args + info = TypeClassDeclaration args' (fmap ($> ()) implies) (convertFundepsToStrings args' fundeps) children = map convertClassMember ds convertClassMember (P.TypeDeclaration (P.TypeDeclarationData (ss, com) ident' ty)) = - ChildDeclaration (P.showIdent ident') (convertComments com) (Just ss) (ChildTypeClassMember ty) + ChildDeclaration (P.showIdent ident') (convertComments com) (Just ss) (ChildTypeClassMember (ty $> ())) convertClassMember _ = P.internalError "convertDeclaration: Invalid argument to convertClassMember." convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ _ _ constraints className tys _) title = @@ -146,11 +148,11 @@ convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ _ _ constraints classN typeNameStrings = ordNub (concatMap (P.everythingOnTypes (++) extractProperNames) tys) unQual x = let (P.Qualified _ y) = x in P.runProperName y - extractProperNames (P.TypeConstructor n) = [unQual n] + extractProperNames (P.TypeConstructor _ n) = [unQual n] extractProperNames _ = [] - childDecl = ChildDeclaration title (convertComments com) (Just ss) (ChildInstance constraints classApp) - classApp = foldl' P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys + childDecl = ChildDeclaration title (convertComments com) (Just ss) (ChildInstance (fmap ($> ()) constraints) (classApp $> ())) + classApp = foldl' P.srcTypeApp (P.srcTypeConstructor (fmap P.coerceProperName className)) tys convertDeclaration (P.ValueFixityDeclaration sa fixity (P.Qualified mn alias) _) title = Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Right alias))) convertDeclaration (P.TypeFixityDeclaration sa fixity (P.Qualified mn alias) _) title = diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index db65ea9a93..9d1b04df78 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -7,6 +7,7 @@ module Language.PureScript.Docs.Prim ) where import Prelude.Compat hiding (fail) +import Data.Functor (($>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Map as Map @@ -167,8 +168,8 @@ primKind = primKindOf P.primName lookupPrimTypeKindOf :: NameGen 'P.TypeName -> Text - -> P.Kind -lookupPrimTypeKindOf k = fst . unsafeLookupOf k + -> Kind' +lookupPrimTypeKindOf k = ($> ()) . fst . unsafeLookupOf k ( P.primTypes <> P.primBooleanTypes <> P.primOrderingTypes <> @@ -212,8 +213,8 @@ primClassOf gen title comments = Declaration , declInfo = let tcd = lookupPrimClassOf gen title - args = P.typeClassArguments tcd - superclasses = P.typeClassSuperclasses tcd + args = fmap (fmap (fmap ($> ()))) $ P.typeClassArguments tcd + superclasses = fmap ($> ()) $ P.typeClassSuperclasses tcd fundeps = convertFundepsToStrings args (P.typeClassDependencies tcd) in TypeClassDeclaration args superclasses fundeps diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index c0c656589f..c9f1a794d8 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -37,7 +37,7 @@ renderDeclarationWithOptions opts Declaration{..} = ] ExternDataDeclaration kind' -> [ keywordData - , renderType' (P.TypeConstructor (notQualified declTitle)) + , renderType' (P.TypeConstructor () (notQualified declTitle)) , syntax "::" , renderKind kind' ] @@ -85,7 +85,7 @@ renderDeclarationWithOptions opts Declaration{..} = ] where - renderType' :: P.Type -> RenderedCode + renderType' :: Type' -> RenderedCode renderType' = renderTypeWithOptions opts renderChildDeclaration :: ChildDeclaration -> RenderedCode @@ -109,17 +109,17 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} = renderType' = renderTypeWithOptions opts renderTypeAtom' = renderTypeAtomWithOptions opts -renderConstraint :: P.Constraint -> RenderedCode +renderConstraint :: Constraint' -> RenderedCode renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions -renderConstraintWithOptions :: RenderTypeOptions -> P.Constraint -> RenderedCode -renderConstraintWithOptions opts (P.Constraint pn tys _) = - renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName pn)) tys +renderConstraintWithOptions :: RenderTypeOptions -> Constraint' -> RenderedCode +renderConstraintWithOptions opts (P.Constraint ann pn tys _) = + renderTypeWithOptions opts $ foldl (P.TypeApp ann) (P.TypeConstructor ann (fmap P.coerceProperName pn)) tys -renderConstraints :: [P.Constraint] -> Maybe RenderedCode +renderConstraints :: [Constraint'] -> Maybe RenderedCode renderConstraints = renderConstraintsWithOptions defaultRenderTypeOptions -renderConstraintsWithOptions :: RenderTypeOptions -> [P.Constraint] -> Maybe RenderedCode +renderConstraintsWithOptions :: RenderTypeOptions -> [Constraint'] -> Maybe RenderedCode renderConstraintsWithOptions opts constraints | null constraints = Nothing | otherwise = Just $ @@ -140,12 +140,12 @@ ident' = ident . P.Qualified Nothing . P.Ident dataCtor' :: Text -> RenderedCode dataCtor' = dataCtor . notQualified -typeApp :: Text -> [(Text, Maybe P.Kind)] -> P.Type +typeApp :: Text -> [(Text, Maybe Kind')] -> Type' typeApp title typeArgs = - foldl P.TypeApp - (P.TypeConstructor (notQualified title)) + foldl (P.TypeApp ()) + (P.TypeConstructor () (notQualified title)) (map toTypeVar typeArgs) -toTypeVar :: (Text, Maybe P.Kind) -> P.Type -toTypeVar (s, Nothing) = P.TypeVar s -toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k +toTypeVar :: (Text, Maybe Kind') -> Type' +toTypeVar (s, Nothing) = P.TypeVar () s +toTypeVar (s, Just k) = P.KindedType () (P.TypeVar () s) k diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs b/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs index bbdbe8ce03..f4c3862aa7 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} -- | Functions for producing RenderedCode values from PureScript Kind values. -- module Language.PureScript.Docs.RenderedCode.RenderKind @@ -20,37 +21,37 @@ import Language.PureScript.Kinds import Language.PureScript.Docs.RenderedCode.Types -typeLiterals :: Pattern () Kind RenderedCode +typeLiterals :: Pattern () (Kind a) RenderedCode typeLiterals = mkPattern match where - match (KUnknown u) = + match (KUnknown _ u) = Just $ typeVar $ T.cons 'k' (T.pack (show u)) - match (NamedKind n) = + match (NamedKind _ n) = Just $ kind n match _ = Nothing -matchRow :: Pattern () Kind ((), Kind) +matchRow :: Pattern () (Kind a) ((), Kind a) matchRow = mkPattern match where - match (Row k) = Just ((), k) + match (Row _ k) = Just ((), k) match _ = Nothing -funKind :: Pattern () Kind (Kind, Kind) +funKind :: Pattern () (Kind a) (Kind a, Kind a) funKind = mkPattern match where - match (FunKind arg ret) = Just (arg, ret) + match (FunKind _ arg ret) = Just (arg, ret) match _ = Nothing -- | Generate RenderedCode value representing a Kind -renderKind :: Kind -> RenderedCode +renderKind :: forall a. Kind a -> RenderedCode renderKind = fromMaybe (internalError "Incomplete pattern") . PA.pattern matchKind () where - matchKind :: Pattern () Kind RenderedCode + matchKind :: Pattern () (Kind a) RenderedCode matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind) - operators :: OperatorTable () Kind RenderedCode + operators :: OperatorTable () (Kind a) RenderedCode operators = OperatorTable [ [ Wrap matchRow $ \_ k -> syntax "#" <> sp <> k] , [ AssocR funKind $ \arg ret -> arg <> sp <> syntax "->" <> sp <> ret ] ] diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index 3857dfd171..e027db980d 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -24,47 +24,46 @@ import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Pretty.Types import Language.PureScript.Types -import Language.PureScript.Label (Label) import Language.PureScript.PSString (prettyPrintString) import Language.PureScript.Docs.RenderedCode.Types import Language.PureScript.Docs.Utils.MonoidExtras import Language.PureScript.Docs.RenderedCode.RenderKind (renderKind) -typeLiterals :: Pattern () Type RenderedCode +typeLiterals :: Pattern () (Type a) RenderedCode typeLiterals = mkPattern match where match TypeWildcard{} = Just (syntax "_") - match (TypeVar var) = + match (TypeVar _ var) = Just (typeVar var) - match (PrettyPrintObject row) = + match (PrettyPrintObject _ row) = Just $ mintersperse sp [ syntax "{" , renderRow row , syntax "}" ] - match (TypeConstructor n) = + match (TypeConstructor _ n) = Just (typeCtor n) - match REmpty = + match REmpty{} = Just (syntax "()") match row@RCons{} = Just (syntax "(" <> renderRow row <> syntax ")") - match (BinaryNoParensType op l r) = + match (BinaryNoParensType _ op l r) = Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r - match (TypeOp n) = + match (TypeOp _ n) = Just (typeOp n) - match (TypeLevelString str) = + match (TypeLevelString _ str) = Just (syntax (prettyPrintString str)) match _ = Nothing -renderConstraint :: Constraint -> RenderedCode -renderConstraint (Constraint pn tys _) = - let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys +renderConstraint :: Constraint a -> RenderedCode +renderConstraint (Constraint ann pn tys _) = + let instApp = foldl (TypeApp ann) (TypeConstructor ann (fmap coerceProperName pn)) tys in renderType instApp -renderConstraints :: Constraint -> RenderedCode -> RenderedCode +renderConstraints :: Constraint a -> RenderedCode -> RenderedCode renderConstraints con ty = mintersperse sp [ renderConstraint con @@ -75,65 +74,65 @@ renderConstraints con ty = -- | -- Render code representing a Row -- -renderRow :: Type -> RenderedCode +renderRow :: Type a -> RenderedCode renderRow = uncurry renderRow' . rowToList where renderRow' h t = renderHead h <> renderTail t -renderHead :: [(Label, Type)] -> RenderedCode +renderHead :: [RowListItem a] -> RenderedCode renderHead = mintersperse (syntax "," <> sp) . map renderLabel -renderLabel :: (Label, Type) -> RenderedCode -renderLabel (label, ty) = +renderLabel :: RowListItem a -> RenderedCode +renderLabel (RowListItem _ label ty) = mintersperse sp [ typeVar $ prettyPrintLabel label , syntax "::" , renderType ty ] -renderTail :: Type -> RenderedCode -renderTail REmpty = mempty +renderTail :: Type a -> RenderedCode +renderTail REmpty{} = mempty renderTail other = sp <> syntax "|" <> sp <> renderType other -typeApp :: Pattern () Type (Type, Type) +typeApp :: Pattern () (Type a) (Type a, Type a) typeApp = mkPattern match where - match (TypeApp f x) = Just (f, x) + match (TypeApp _ f x) = Just (f, x) match _ = Nothing -appliedFunction :: Pattern () Type (Type, Type) +appliedFunction :: Pattern () (Type a) (Type a, Type a) appliedFunction = mkPattern match where - match (PrettyPrintFunction arg ret) = Just (arg, ret) + match (PrettyPrintFunction _ arg ret) = Just (arg, ret) match _ = Nothing -kinded :: Pattern () Type (Kind, Type) +kinded :: Pattern () (Type a) (Kind a, Type a) kinded = mkPattern match where - match (KindedType t k) = Just (k, t) + match (KindedType _ t k) = Just (k, t) match _ = Nothing -constrained :: Pattern () Type (Constraint, Type) +constrained :: Pattern () (Type a) (Constraint a, Type a) constrained = mkPattern match where - match (ConstrainedType con ty) = Just (con, ty) + match (ConstrainedType _ con ty) = Just (con, ty) match _ = Nothing -explicitParens :: Pattern () Type ((), Type) +explicitParens :: Pattern () (Type a) ((), Type a) explicitParens = mkPattern match where - match (ParensInType ty) = Just ((), ty) + match (ParensInType _ ty) = Just ((), ty) match _ = Nothing -matchTypeAtom :: Pattern () Type RenderedCode +matchTypeAtom :: Pattern () (Type a) RenderedCode matchTypeAtom = typeLiterals <+> fmap parens_ matchType where parens_ x = syntax "(" <> x <> syntax ")" -matchType :: Pattern () Type RenderedCode +matchType :: Pattern () (Type a) RenderedCode matchType = buildPrettyPrinter operators matchTypeAtom where - operators :: OperatorTable () Type RenderedCode + operators :: OperatorTable () (Type a) RenderedCode operators = OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ] , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ] @@ -143,42 +142,42 @@ matchType = buildPrettyPrinter operators matchTypeAtom , [ Wrap explicitParens $ \_ ty -> ty ] ] -forall_ :: Pattern () Type ([Text], Type) +forall_ :: Pattern () (Type a) ([Text], Type a) forall_ = mkPattern match where - match (PrettyPrintForAll idents ty) = Just (idents, ty) + match (PrettyPrintForAll _ idents ty) = Just (idents, ty) match _ = Nothing -insertPlaceholders :: RenderTypeOptions -> Type -> Type +insertPlaceholders :: RenderTypeOptions -> Type a -> Type a insertPlaceholders opts = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes (convert opts) -convert :: RenderTypeOptions -> Type -> Type -convert _ (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret -convert opts (TypeApp o r) | o == tyRecord && prettyPrintObjects opts = PrettyPrintObject r +convert :: RenderTypeOptions -> Type a -> Type a +convert _ (TypeApp a (TypeApp _ f arg) ret) | eqType f tyFunction = PrettyPrintFunction a arg ret +convert opts (TypeApp a o r) | eqType o tyRecord && prettyPrintObjects opts = PrettyPrintObject a r convert _ other = other -convertForAlls :: Type -> Type -convertForAlls (ForAll i ty _) = go [i] ty +convertForAlls :: Type a -> Type a +convertForAlls (ForAll ann i ty _) = go [i] ty where - go idents (ForAll i' ty' _) = go (i' : idents) ty' - go idents other = PrettyPrintForAll idents other + go idents (ForAll _ i' ty' _) = go (i' : idents) ty' + go idents other = PrettyPrintForAll ann idents other convertForAlls other = other -preprocessType :: RenderTypeOptions -> Type -> Type +preprocessType :: RenderTypeOptions -> Type a -> Type a preprocessType opts = insertPlaceholders opts -- | -- Render code representing a Type -- -renderType :: Type -> RenderedCode +renderType :: Type a -> RenderedCode renderType = renderTypeWithOptions defaultRenderTypeOptions -- | -- Render code representing a Type, as it should appear inside parentheses -- -renderTypeAtom :: Type -> RenderedCode +renderTypeAtom :: Type a -> RenderedCode renderTypeAtom = renderTypeAtomWithOptions defaultRenderTypeOptions data RenderTypeOptions = RenderTypeOptions @@ -193,13 +192,13 @@ defaultRenderTypeOptions = , currentModule = Nothing } -renderTypeWithOptions :: RenderTypeOptions -> Type -> RenderedCode +renderTypeWithOptions :: RenderTypeOptions -> Type a -> RenderedCode renderTypeWithOptions opts = fromMaybe (internalError "Incomplete pattern") . PA.pattern matchType () . preprocessType opts -renderTypeAtomWithOptions :: RenderTypeOptions -> Type -> RenderedCode +renderTypeAtomWithOptions :: RenderTypeOptions -> Type a -> RenderedCode renderTypeAtomWithOptions opts = fromMaybe (internalError "Incomplete pattern") . PA.pattern matchTypeAtom () diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 9bba522362..6fd9c1befb 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -39,6 +39,10 @@ import Language.PureScript.Docs.RenderedCode as ReExports RenderedCodeElement(..), asRenderedCodeElement, Namespace(..), FixityAlias) +type Type' = P.Type () +type Kind' = P.Kind () +type Constraint' = P.Constraint () + -------------------- -- Types @@ -147,30 +151,30 @@ data DeclarationInfo -- | -- A value declaration, with its type. -- - = ValueDeclaration P.Type + = ValueDeclaration Type' -- | -- A data/newtype declaration, with the kind of declaration (data or -- newtype) and its type arguments. Constructors are represented as child -- declarations. -- - | DataDeclaration P.DataDeclType [(Text, Maybe P.Kind)] + | DataDeclaration P.DataDeclType [(Text, Maybe Kind')] -- | -- A data type foreign import, with its kind. -- - | ExternDataDeclaration P.Kind + | ExternDataDeclaration Kind' -- | -- A type synonym, with its type arguments and its type. -- - | TypeSynonymDeclaration [(Text, Maybe P.Kind)] P.Type + | TypeSynonymDeclaration [(Text, Maybe Kind')] Type' -- | -- A type class, with its type arguments, its superclasses and functional -- dependencies. Instances and members are represented as child declarations. -- - | TypeClassDeclaration [(Text, Maybe P.Kind)] [P.Constraint] [([Text], [Text])] + | TypeClassDeclaration [(Text, Maybe Kind')] [Constraint'] [([Text], [Text])] -- | -- An operator alias declaration, with the member the alias is for and the @@ -186,7 +190,7 @@ data DeclarationInfo instance NFData DeclarationInfo -convertFundepsToStrings :: [(Text, Maybe P.Kind)] -> [P.FunctionalDependency] -> [([Text], [Text])] +convertFundepsToStrings :: [(Text, Maybe Kind')] -> [P.FunctionalDependency] -> [([Text], [Text])] convertFundepsToStrings args fundeps = map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps where @@ -287,19 +291,19 @@ data ChildDeclarationInfo -- | -- A type instance declaration, with its dependencies and its type. -- - = ChildInstance [P.Constraint] P.Type + = ChildInstance [Constraint'] Type' -- | -- A data constructor, with its type arguments. -- - | ChildDataConstructor [P.Type] + | ChildDataConstructor [Type'] -- | -- A type class member, with its type. Note that the type does not include -- the type class constraint; this may be added manually if desired. For -- example, `pure` from `Applicative` would be `forall a. a -> f a`. -- - | ChildTypeClassMember P.Type + | ChildTypeClassMember Type' deriving (Show, Eq, Ord, Generic) instance NFData ChildDeclarationInfo @@ -652,15 +656,15 @@ asDeclarationInfo = do other -> throwCustomError (InvalidDeclarationType other) -asTypeArguments :: Parse PackageError [(Text, Maybe P.Kind)] +asTypeArguments :: Parse PackageError [(Text, Maybe Kind')] asTypeArguments = eachInArray asTypeArgument where asTypeArgument = (,) <$> nth 0 asText <*> nth 1 (perhaps asKind) -asKind :: Parse PackageError P.Kind -asKind = P.kindFromJSON .! InvalidKind +asKind :: Parse PackageError Kind' +asKind = P.kindFromJSON (pure ()) fromAesonParser .! InvalidKind -asType :: Parse e P.Type +asType :: Parse e Type' asType = fromAesonParser asFunDeps :: Parse PackageError [([Text], [Text])] @@ -700,10 +704,10 @@ asSourcePos :: Parse e P.SourcePos asSourcePos = P.SourcePos <$> nth 0 asIntegral <*> nth 1 asIntegral -asConstraint :: Parse PackageError P.Constraint -asConstraint = P.Constraint <$> key "constraintClass" asQualifiedProperName - <*> key "constraintArgs" (eachInArray asType) - <*> pure Nothing +asConstraint :: Parse PackageError Constraint' +asConstraint = P.Constraint () <$> key "constraintClass" asQualifiedProperName + <*> key "constraintArgs" (eachInArray asType) + <*> pure Nothing asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a)) asQualifiedProperName = fromAesonParser @@ -711,6 +715,9 @@ asQualifiedProperName = fromAesonParser asQualifiedIdent :: Parse e (P.Qualified P.Ident) asQualifiedIdent = fromAesonParser +asSourceAnn :: Parse e (P.SourceAnn) +asSourceAnn = fromAesonParser + asModuleMap :: Parse PackageError (Map P.ModuleName PackageName) asModuleMap = Map.fromList <$> diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 937c58f544..3e9505aab3 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -19,6 +19,7 @@ import qualified Data.Graph as G import Data.Foldable (toList, fold) import qualified Data.List.NonEmpty as NEL +import Language.PureScript.AST.SourcePos import Language.PureScript.Crash import Language.PureScript.Kinds import Language.PureScript.Names @@ -28,14 +29,14 @@ import qualified Language.PureScript.Constants as C -- | The @Environment@ defines all values and types which are currently in scope: data Environment = Environment - { names :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility) + { names :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ Values currently in scope - , types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) + , types :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) -- ^ Type names currently in scope - , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident]) + , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) -- ^ Data constructors currently in scope, along with their associated type -- constructor name, argument types and return type. - , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type) + , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceKind)], SourceType) -- ^ Type synonyms currently in scope , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) -- ^ Available type class dictionaries. When looking up 'Nothing' in the @@ -51,13 +52,13 @@ instance NFData Environment -- | Information about a type class data TypeClassData = TypeClassData - { typeClassArguments :: [(Text, Maybe Kind)] + { typeClassArguments :: [(Text, Maybe SourceKind)] -- ^ A list of type argument names, and their kinds, where kind annotations -- were provided. - , typeClassMembers :: [(Ident, Type)] + , typeClassMembers :: [(Ident, SourceType)] -- ^ A list of type class members and their types. Type arguments listed above -- are considered bound in these types. - , typeClassSuperclasses :: [Constraint] + , typeClassSuperclasses :: [SourceConstraint] -- ^ A list of superclasses of this type class. Type arguments listed above -- are considered bound in the types appearing in these constraints. , typeClassDependencies :: [FunctionalDependency] @@ -120,9 +121,9 @@ initEnvironment = Environment M.empty allPrimTypes M.empty M.empty M.empty allPr -- determine X that X does not determine. This is the same thing: everything X determines includes everything -- in its SCC, and everything determining X is either before it in an SCC path, or in the same SCC. makeTypeClassData - :: [(Text, Maybe Kind)] - -> [(Ident, Type)] - -> [Constraint] + :: [(Text, Maybe SourceKind)] + -> [(Ident, SourceType)] + -> [SourceConstraint] -> [FunctionalDependency] -> TypeClassData makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs coveringSets @@ -197,7 +198,7 @@ instance NFData NameKind -- | The kinds of a type data TypeKind - = DataType [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])] + = DataType [(Text, Maybe SourceKind)] [(ProperName 'ConstructorName, [SourceType])] -- ^ Data type | TypeSynonym -- ^ Type synonym @@ -267,90 +268,97 @@ primSubName :: Text -> Text -> Qualified (ProperName a) primSubName sub = Qualified (Just $ ModuleName [ProperName C.prim, ProperName sub]) . ProperName -primKind :: Text -> Kind -primKind = NamedKind . primName +primKind :: Text -> SourceKind +primKind = NamedKind nullSourceAnn . primName -primSubKind :: Text -> Text -> Kind -primSubKind sub = NamedKind . primSubName sub +primSubKind :: Text -> Text -> SourceKind +primSubKind sub = NamedKind nullSourceAnn . primSubName sub -- | Kind of ground types -kindType :: Kind +kindType :: SourceKind kindType = primKind C.typ --- To make reading the kind signatures below easier -kindConstraint :: Kind +kindConstraint :: SourceKind kindConstraint = kindType -(-:>) :: Kind -> Kind -> Kind -(-:>) = FunKind +isKindType :: Kind a -> Bool +isKindType (NamedKind _ n) = n == primName C.typ +isKindType _ = False + +-- To make reading the kind signatures below easier +(-:>) :: SourceKind -> SourceKind -> SourceKind +(-:>) = FunKind nullSourceAnn infixr 4 -:> -kindSymbol :: Kind +kindSymbol :: SourceKind kindSymbol = primKind C.symbol -kindDoc :: Kind +kindDoc :: SourceKind kindDoc = primSubKind C.typeError C.doc -kindBoolean :: Kind +kindBoolean :: SourceKind kindBoolean = primSubKind C.moduleBoolean C.kindBoolean -kindOrdering :: Kind +kindOrdering :: SourceKind kindOrdering = primSubKind C.moduleOrdering C.kindOrdering -kindRowList :: Kind +kindRowList :: SourceKind kindRowList = primSubKind C.moduleRowList C.kindRowList +kindRow :: SourceKind -> SourceKind +kindRow = Row nullSourceAnn + -- | Construct a type in the Prim module -primTy :: Text -> Type -primTy = TypeConstructor . primName +primTy :: Text -> SourceType +primTy = TypeConstructor nullSourceAnn . primName -- | Type constructor for functions -tyFunction :: Type +tyFunction :: SourceType tyFunction = primTy "Function" -- | Type constructor for strings -tyString :: Type +tyString :: SourceType tyString = primTy "String" -- | Type constructor for strings -tyChar :: Type +tyChar :: SourceType tyChar = primTy "Char" -- | Type constructor for numbers -tyNumber :: Type +tyNumber :: SourceType tyNumber = primTy "Number" -- | Type constructor for integers -tyInt :: Type +tyInt :: SourceType tyInt = primTy "Int" -- | Type constructor for booleans -tyBoolean :: Type +tyBoolean :: SourceType tyBoolean = primTy "Boolean" -- | Type constructor for arrays -tyArray :: Type +tyArray :: SourceType tyArray = primTy "Array" -- | Type constructor for records -tyRecord :: Type +tyRecord :: SourceType tyRecord = primTy "Record" -- | Check whether a type is a record -isObject :: Type -> Bool +isObject :: Type a -> Bool isObject = isTypeOrApplied tyRecord -- | Check whether a type is a function -isFunction :: Type -> Bool +isFunction :: Type a -> Bool isFunction = isTypeOrApplied tyFunction -isTypeOrApplied :: Type -> Type -> Bool -isTypeOrApplied t1 (TypeApp t2 _) = t1 == t2 -isTypeOrApplied t1 t2 = t1 == t2 +isTypeOrApplied :: Type a -> Type b -> Bool +isTypeOrApplied t1 (TypeApp _ t2 _) = eqType t1 t2 +isTypeOrApplied t1 t2 = eqType t1 t2 -- | Smart constructor for function types -function :: Type -> Type -> Type -function t1 = TypeApp (TypeApp tyFunction t1) +function :: SourceType -> SourceType -> SourceType +function t1 t2 = TypeApp nullSourceAnn (TypeApp nullSourceAnn tyFunction t1) t2 -- | Kinds in @Prim@ primKinds :: S.Set (Qualified (ProperName 'KindName)) @@ -396,11 +404,11 @@ allPrimKinds = fold -- | The primitive types in the external javascript environment with their -- associated kinds. There are also pseudo `Fail`, `Warn`, and `Partial` types -- that correspond to the classes with the same names. -primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +primTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) primTypes = M.fromList [ (primName "Function", (kindType -:> kindType -:> kindType, ExternData)) , (primName "Array", (kindType -:> kindType, ExternData)) - , (primName "Record", (Row kindType -:> kindType, ExternData)) + , (primName "Record", (kindRow kindType -:> kindType, ExternData)) , (primName "String", (kindType, ExternData)) , (primName "Char", (kindType, ExternData)) , (primName "Number", (kindType, ExternData)) @@ -410,7 +418,7 @@ primTypes = M.fromList ] -- | This 'Map' contains all of the prim types from all Prim modules. -allPrimTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +allPrimTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) allPrimTypes = M.unions [ primTypes , primBooleanTypes @@ -421,14 +429,14 @@ allPrimTypes = M.unions , primTypeErrorTypes ] -primBooleanTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +primBooleanTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) primBooleanTypes = M.fromList [ (primSubName C.moduleBoolean "True", (kindBoolean, ExternData)) , (primSubName C.moduleBoolean "False", (kindBoolean, ExternData)) ] -primOrderingTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +primOrderingTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) primOrderingTypes = M.fromList [ (primSubName C.moduleOrdering "LT", (kindOrdering, ExternData)) @@ -436,24 +444,24 @@ primOrderingTypes = , (primSubName C.moduleOrdering "GT", (kindOrdering, ExternData)) ] -primRowTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +primRowTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) primRowTypes = M.fromList - [ (primSubName C.moduleRow "Union", (Row kindType -:> Row kindType -:> Row kindType -:> kindConstraint, ExternData)) - , (primSubName C.moduleRow "Nub", (Row kindType -:> Row kindType -:> kindConstraint, ExternData)) - , (primSubName C.moduleRow "Lacks", (kindSymbol -:> Row kindType -:> kindConstraint, ExternData)) - , (primSubName C.moduleRow "Cons", (kindSymbol -:> kindType -:> Row kindType -:> Row kindType -:> kindConstraint, ExternData)) + [ (primSubName C.moduleRow "Union", (kindRow kindType -:> kindRow kindType -:> kindRow kindType -:> kindConstraint, ExternData)) + , (primSubName C.moduleRow "Nub", (kindRow kindType -:> kindRow kindType -:> kindConstraint, ExternData)) + , (primSubName C.moduleRow "Lacks", (kindSymbol -:> kindRow kindType -:> kindConstraint, ExternData)) + , (primSubName C.moduleRow "Cons", (kindSymbol -:> kindType -:> kindRow kindType -:> kindRow kindType -:> kindConstraint, ExternData)) ] -primRowListTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +primRowListTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) primRowListTypes = M.fromList [ (primSubName C.moduleRowList "Cons", (kindSymbol -:> kindType -:> kindRowList -:> kindRowList, ExternData)) , (primSubName C.moduleRowList "Nil", (kindRowList, ExternData)) - , (primSubName C.moduleRowList "RowToList", (Row kindType -:> kindRowList -:> kindConstraint, ExternData)) + , (primSubName C.moduleRowList "RowToList", (kindRow kindType -:> kindRowList -:> kindConstraint, ExternData)) ] -primSymbolTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +primSymbolTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) primSymbolTypes = M.fromList [ (primSubName C.moduleSymbol "Append", (kindSymbol -:> kindSymbol -:> kindSymbol -:> kindConstraint, ExternData)) @@ -461,7 +469,7 @@ primSymbolTypes = , (primSubName C.moduleSymbol "Cons", (kindSymbol -:> kindSymbol -:> kindSymbol -:> kindConstraint, ExternData)) ] -primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) +primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) primTypeErrorTypes = M.fromList [ (primSubName C.typeError "Fail", (kindDoc -:> kindConstraint, ExternData)) @@ -496,9 +504,9 @@ primRowClasses = M.fromList -- class Union (left :: # Type) (right :: # Type) (union :: # Type) | left right -> union, right union -> left, union left -> right [ (primSubName C.moduleRow "Union", makeTypeClassData - [ ("left", Just (Row kindType)) - , ("right", Just (Row kindType)) - , ("union", Just (Row kindType)) + [ ("left", Just (kindRow kindType)) + , ("right", Just (kindRow kindType)) + , ("union", Just (kindRow kindType)) ] [] [] [ FunctionalDependency [0, 1] [2] , FunctionalDependency [1, 2] [0] @@ -507,8 +515,8 @@ primRowClasses = -- class Nub (original :: # Type) (nubbed :: # Type) | i -> o , (primSubName C.moduleRow "Nub", makeTypeClassData - [ ("original", Just (Row kindType)) - , ("nubbed", Just (Row kindType)) + [ ("original", Just (kindRow kindType)) + , ("nubbed", Just (kindRow kindType)) ] [] [] [ FunctionalDependency [0] [1] ]) @@ -516,15 +524,15 @@ primRowClasses = -- class Lacks (label :: Symbol) (row :: # Type) , (primSubName C.moduleRow "Lacks", makeTypeClassData [ ("label", Just kindSymbol) - , ("row", Just (Row kindType)) + , ("row", Just (kindRow kindType)) ] [] [] []) -- class RowCons (label :: Symbol) (a :: Type) (tail :: # Type) (row :: # Type) | label tail a -> row, label row -> tail a , (primSubName C.moduleRow "Cons", makeTypeClassData [ ("label", Just kindSymbol) , ("a", Just kindType) - , ("tail", Just (Row kindType)) - , ("row", Just (Row kindType)) + , ("tail", Just (kindRow kindType)) + , ("row", Just (kindRow kindType)) ] [] [] [ FunctionalDependency [0, 1, 2] [3] , FunctionalDependency [0, 3] [1, 2] @@ -536,7 +544,7 @@ primRowListClasses = M.fromList -- class RowToList (row :: # Type) (list :: RowList) | row -> list [ (primSubName C.moduleRowList "RowToList", makeTypeClassData - [ ("row", Just (Row kindType)) + [ ("row", Just (kindRow kindType)) , ("list", Just kindRowList) ] [] [] [ FunctionalDependency [0] [1] @@ -590,7 +598,7 @@ primTypeErrorClasses = ] -- | Finds information about data constructors from the current environment. -lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, Type, [Ident]) +lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) lookupConstructor env ctor = fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env @@ -601,5 +609,5 @@ isNewtypeConstructor e ctor = case lookupConstructor e ctor of (Data, _, _, _) -> False -- | Finds information about values from the current environment. -lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility) +lookupValue :: Environment -> Qualified Ident -> Maybe (SourceType, NameKind, NameVisibility) lookupValue env ident = ident `M.lookup` names env diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index d4807d650b..8927ed6ba1 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -18,10 +18,11 @@ import Data.Char (isSpace) import Data.Either (partitionEithers) import Data.Foldable (fold) import Data.Functor.Identity (Identity(..)) -import Data.List (transpose, nubBy, sort, partition, dropWhileEnd) +import Data.List (transpose, nubBy, partition, dropWhileEnd, sortBy) import qualified Data.List.NonEmpty as NEL import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import qualified Data.Map as M +import Data.Ord (comparing) import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text) @@ -241,31 +242,31 @@ data Level = Error | Warning deriving Show unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage unwrapErrorMessage (ErrorMessage _ se) = se -replaceUnknowns :: Type -> State TypeMap Type +replaceUnknowns :: SourceType -> State TypeMap SourceType replaceUnknowns = everywhereOnTypesM replaceTypes where - replaceTypes :: Type -> State TypeMap Type - replaceTypes (TUnknown u) = do + replaceTypes :: SourceType -> State TypeMap SourceType + replaceTypes (TUnknown ann u) = do m <- get case M.lookup u (umUnknownMap m) of Nothing -> do let u' = umNextIndex m put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextIndex = u' + 1 } - return (TUnknown u') - Just u' -> return (TUnknown u') - replaceTypes (Skolem name s sko ss) = do + return (TUnknown ann u') + Just u' -> return (TUnknown ann u') + replaceTypes (Skolem ann name s sko) = do m <- get case M.lookup s (umSkolemMap m) of Nothing -> do let s' = umNextIndex m - put $ m { umSkolemMap = M.insert s (T.unpack name, s', ss) (umSkolemMap m), umNextIndex = s' + 1 } - return (Skolem name s' sko ss) - Just (_, s', _) -> return (Skolem name s' sko ss) + put $ m { umSkolemMap = M.insert s (T.unpack name, s', Just (fst ann)) (umSkolemMap m), umNextIndex = s' + 1 } + return (Skolem ann name s' sko) + Just (_, s', _) -> return (Skolem ann name s' sko) replaceTypes other = return other -onTypesInErrorMessage :: (Type -> Type) -> ErrorMessage -> ErrorMessage +onTypesInErrorMessage :: (SourceType -> SourceType) -> ErrorMessage -> ErrorMessage onTypesInErrorMessage f = runIdentity . onTypesInErrorMessageM (Identity . f) -onTypesInErrorMessageM :: Applicative m => (Type -> m Type) -> ErrorMessage -> m ErrorMessage +onTypesInErrorMessageM :: Applicative m => (SourceType -> m SourceType) -> ErrorMessage -> m ErrorMessage onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gHint hints <*> gSimple simple where gSimple (InfiniteType t) = InfiniteType <$> f t @@ -585,17 +586,19 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (TypesDoNotUnify u1 u2) = let (sorted1, sorted2) = sortRows u1 u2 - sortRows :: Type -> Type -> (Type, Type) + sortRows :: Ord a => Type a -> Type a -> (Type a, Type a) sortRows r1@RCons{} r2@RCons{} = sortRows' (rowToList r1) (rowToList r2) sortRows t1 t2 = (t1, t2) -- Put the common labels last - sortRows' :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> (Type, Type) + sortRows' :: Ord a => ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Type a, Type a) sortRows' (s1, r1) (s2, r2) = - let (common1, unique1) = partition (flip elem s2) s1 - (common2, unique2) = partition (flip elem s1) s2 - in ( rowFromList (sort unique1 ++ sort common1, r1) - , rowFromList (sort unique2 ++ sort common2, r2) + let elem' s (RowListItem _ name ty) = any (\(RowListItem _ name' ty') -> name == name' && eqType ty ty') s + sort' = sortBy (comparing $ \(RowListItem _ name ty) -> (name, ty)) + (common1, unique1) = partition (elem' s2) s1 + (common2, unique2) = partition (elem' s1) s2 + in ( rowFromList (sort' unique1 ++ sort' common1, r1) + , rowFromList (sort' unique2 ++ sort' common2, r2) ) in paras [ line "Could not match type" , markCodeBox $ indent $ typeAsBox sorted1 @@ -630,11 +633,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , markCodeBox $ indent $ line (showQualified runProperName nm) , line "because the class was not in scope. Perhaps it was not exported." ] - renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ ty ] _)) | Just box <- toTypelevelString ty = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Fail [ ty ] _)) | Just box <- toTypelevelString ty = paras [ line "A custom type error occurred while solving type class constraints:" , indent box ] - renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial + renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Partial _ (Just (PartialConstraintData bs b)))) = paras [ line "A case expression could not be determined to cover all inputs." @@ -645,13 +648,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl : [line "..." | not b] , line "Alternatively, add a Partial constraint to the type of the enclosing value." ] - renderSimpleErrorMessage (NoInstanceFound (Constraint C.Discard [ty] _)) = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Discard [ty] _)) = paras [ line "A result of type" , markCodeBox $ indent $ typeAsBox ty , line "was implicitly discarded in a do notation block." , line ("You can use " <> markCode "_ <- ..." <> " to explicitly discard the result.") ] - renderSimpleErrorMessage (NoInstanceFound (Constraint nm ts _)) = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ nm ts _)) = paras [ line "No type class instance was found for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) @@ -662,7 +665,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] ] where - containsUnknowns :: Type -> Bool + containsUnknowns :: Type a -> Bool containsUnknowns = everythingOnTypes (||) go where go TUnknown{} = True @@ -1142,7 +1145,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ detail , line $ "in foreign import " <> markCode (showIdent nm) ] - renderHint (ErrorSolvingConstraint (Constraint nm ts _)) detail = + renderHint (ErrorSolvingConstraint (Constraint _ nm ts _)) detail = paras [ detail , line "while solving type class constraint" , markCodeBox $ indent $ Box.hsep 1 Box.left @@ -1402,19 +1405,19 @@ renderBox = unlines where whiteSpace = all isSpace -toTypelevelString :: Type -> Maybe Box.Box -toTypelevelString (TypeLevelString s) = +toTypelevelString :: Type a -> Maybe Box.Box +toTypelevelString (TypeLevelString _ s) = Just . Box.text $ decodeStringWithReplacement s -toTypelevelString (TypeApp (TypeConstructor f) x) +toTypelevelString (TypeApp _ (TypeConstructor _ f) x) | f == primSubName C.typeError "Text" = toTypelevelString x -toTypelevelString (TypeApp (TypeConstructor f) x) +toTypelevelString (TypeApp _ (TypeConstructor _ f) x) | f == primSubName C.typeError "Quote" = Just (typeAsBox x) -toTypelevelString (TypeApp (TypeConstructor f) (TypeLevelString x)) +toTypelevelString (TypeApp _ (TypeConstructor _ f) (TypeLevelString _ x)) | f == primSubName C.typeError "QuoteLabel" = Just . line . prettyPrintLabel . Label $ x -toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret) +toTypelevelString (TypeApp _ (TypeApp _ (TypeConstructor _ f) x) ret) | f == primSubName C.typeError "Beside" = (Box.<>) <$> toTypelevelString x <*> toTypelevelString ret -toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret) +toTypelevelString (TypeApp _ (TypeApp _ (TypeConstructor _ f) x) ret) | f == primSubName C.typeError "Above" = (Box.//) <$> toTypelevelString x <*> toTypelevelString ret toTypelevelString _ = Nothing diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index a7974bde0d..7de92875c2 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -99,42 +99,42 @@ data ExternsDeclaration = -- | A type declaration EDType { edTypeName :: ProperName 'TypeName - , edTypeKind :: Kind + , edTypeKind :: SourceKind , edTypeDeclarationKind :: TypeKind } -- | A type synonym | EDTypeSynonym { edTypeSynonymName :: ProperName 'TypeName - , edTypeSynonymArguments :: [(Text, Maybe Kind)] - , edTypeSynonymType :: Type + , edTypeSynonymArguments :: [(Text, Maybe SourceKind)] + , edTypeSynonymType :: SourceType } -- | A data construtor | EDDataConstructor { edDataCtorName :: ProperName 'ConstructorName , edDataCtorOrigin :: DataDeclType , edDataCtorTypeCtor :: ProperName 'TypeName - , edDataCtorType :: Type + , edDataCtorType :: SourceType , edDataCtorFields :: [Ident] } -- | A value declaration | EDValue { edValueName :: Ident - , edValueType :: Type + , edValueType :: SourceType } -- | A type class declaration | EDClass { edClassName :: ProperName 'ClassName - , edClassTypeArguments :: [(Text, Maybe Kind)] - , edClassMembers :: [(Ident, Type)] - , edClassConstraints :: [Constraint] + , edClassTypeArguments :: [(Text, Maybe SourceKind)] + , edClassMembers :: [(Ident, SourceType)] + , edClassConstraints :: [SourceConstraint] , edFunctionalDependencies :: [FunctionalDependency] } -- | An instance declaration | EDInstance { edInstanceClassName :: Qualified (ProperName 'ClassName) , edInstanceName :: Ident - , edInstanceTypes :: [Type] - , edInstanceConstraints :: Maybe [Constraint] + , edInstanceTypes :: [SourceType] + , edInstanceConstraints :: Maybe [SourceConstraint] , edInstanceChain :: [Qualified Ident] , edInstanceChainIndex :: Integer } diff --git a/src/Language/PureScript/Hierarchy.hs b/src/Language/PureScript/Hierarchy.hs index db6b9b12f6..0bbe7650b9 100644 --- a/src/Language/PureScript/Hierarchy.hs +++ b/src/Language/PureScript/Hierarchy.hs @@ -80,6 +80,6 @@ typeClassEpilogue = "\n}" superClasses :: P.Declaration -> [SuperMap] superClasses (P.TypeClassDeclaration _ sub _ supers@(_:_) _ _) = - fmap (\(P.Constraint (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers + fmap (\(P.Constraint _ (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers superClasses (P.TypeClassDeclaration _ sub _ _ _ _) = [SuperMap (Left sub)] superClasses _ = [] diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 2493374d83..90f1da0adc 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -35,7 +35,7 @@ import Language.PureScript.Ide.Types import Text.Parsec as Parsec import qualified Text.PrettyPrint.Boxes as Box -type Constructor = (P.ProperName 'P.ConstructorName, [P.Type]) +type Constructor = (P.ProperName 'P.ConstructorName, [P.SourceType]) newtype WildcardAnnotations = WildcardAnnotations Bool @@ -75,11 +75,11 @@ findTypeDeclaration' t ExternsFile{..} = _ -> False) efDeclarations splitTypeConstructor :: (MonadError IdeError m) => - P.Type -> m (P.ProperName 'P.TypeName, [P.Type]) + P.Type a -> m (P.ProperName 'P.TypeName, [P.Type a]) splitTypeConstructor = go [] where - go acc (P.TypeApp ty arg) = go (arg : acc) ty - go acc (P.TypeConstructor tc) = pure (P.disqualify tc, acc) + go acc (P.TypeApp _ ty arg) = go (arg : acc) ty + go acc (P.TypeConstructor _ tc) = pure (P.disqualify tc, acc) go _ _ = throwError (GeneralError "Failed to read TypeConstructor") prettyCtor :: WildcardAnnotations -> Constructor -> Text @@ -88,11 +88,11 @@ prettyCtor wsa (ctorName, ctorArgs) = "("<> P.runProperName ctorName <> " " <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")" -prettyPrintWildcard :: WildcardAnnotations -> P.Type -> Text +prettyPrintWildcard :: WildcardAnnotations -> P.Type a -> Text prettyPrintWildcard (WildcardAnnotations True) = prettyWildcard prettyPrintWildcard (WildcardAnnotations False) = const "_" -prettyWildcard :: P.Type -> Text +prettyWildcard :: P.Type a -> Text prettyWildcard t = "( _ :: " <> T.strip (T.pack (P.prettyPrintTypeAtom t)) <> ")" -- | Constructs Patterns to insert into a sourcefile @@ -116,7 +116,7 @@ addClause s wca = do pure [s, template] parseType' :: (MonadError IdeError m) => - Text -> m P.Type + Text -> m P.SourceType parseType' s = case P.lex "" (toS s) >>= P.runTokenParser "" (P.parseType <* Parsec.eof) of Right type' -> pure type' @@ -124,7 +124,7 @@ parseType' s = throwError (GeneralError ("Parsing the splittype failed with:" <> show err)) -parseTypeDeclaration' :: (MonadError IdeError m) => Text -> m (P.Ident, P.Type) +parseTypeDeclaration' :: (MonadError IdeError m) => Text -> m (P.Ident, P.SourceType) parseTypeDeclaration' s = let x = do ts <- P.lex "" (toS s) @@ -137,13 +137,13 @@ parseTypeDeclaration' s = throwError (GeneralError ("Parsing the type signature failed with: " <> toS (Box.render (P.prettyPrintParseError err)))) -splitFunctionType :: P.Type -> [P.Type] +splitFunctionType :: P.Type a -> [P.Type a] splitFunctionType t = fromMaybe [] arguments where arguments = initMay splitted splitted = splitType' t - splitType' (P.ForAll _ t' _) = splitType' t' - splitType' (P.ConstrainedType _ t') = splitType' t' - splitType' (P.TypeApp (P.TypeApp t' lhs) rhs) - | t' == P.tyFunction = lhs : splitType' rhs + splitType' (P.ForAll _ _ t' _) = splitType' t' + splitType' (P.ConstrainedType _ _ t') = splitType' t' + splitType' (P.TypeApp _ (P.TypeApp _ t' lhs) rhs) + | P.eqType t' P.tyFunction = lhs : splitType' rhs splitType' t' = [t'] diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 4f1a453b36..3908fd708b 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -82,5 +82,5 @@ textError (ParseError parseError msg) = let escape = show in msg <> ": " <> escape parseError textError (RebuildError err) = show err -prettyPrintTypeSingleLine :: P.Type -> Text +prettyPrintTypeSingleLine :: P.Type a -> Text prettyPrintTypeSingleLine = T.unwords . map T.strip . T.lines . T.pack . P.prettyPrintTypeWithUnicode diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index df65a9a0ec..0b1c39a5cc 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -116,7 +116,7 @@ findSynonym :: P.ProperName 'P.TypeName -> [IdeDeclaration] -> Maybe IdeTypeSyno -- involved. We collect these and resolve them at the end of the conversion process. data ToResolve = TypeClassToResolve (P.ProperName 'P.ClassName) - | SynonymToResolve (P.ProperName 'P.TypeName) P.Type + | SynonymToResolve (P.ProperName 'P.TypeName) P.SourceType convertExport :: P.DeclarationRef -> Maybe (P.ModuleName, P.DeclarationRef) convertExport (P.ReExportRef _ m r) = Just (m, r) diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index c62e26bf8d..37868eb786 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -65,7 +65,7 @@ extractAstInformation (P.Module _ _ _ decls _) = in (definitions, typeAnnotations) -- | Extracts type annotations for functions from a given Module -extractTypeAnnotations :: [P.Declaration] -> [(P.Ident, P.Type)] +extractTypeAnnotations :: [P.Declaration] -> [(P.Ident, P.SourceType)] extractTypeAnnotations = mapMaybe (map P.unwrapTypeDeclaration . P.getTypeDeclaration) -- | Given a surrounding Sourcespan and a Declaration from the PS AST, extracts diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index f096769337..cb72e17bb8 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -44,38 +44,38 @@ data IdeDeclaration data IdeValue = IdeValue { _ideValueIdent :: P.Ident - , _ideValueType :: P.Type + , _ideValueType :: P.SourceType } deriving (Show, Eq, Ord, Generic, NFData) data IdeType = IdeType { _ideTypeName :: P.ProperName 'P.TypeName - , _ideTypeKind :: P.Kind - , _ideTypeDtors :: [(P.ProperName 'P.ConstructorName, P.Type)] + , _ideTypeKind :: P.SourceKind + , _ideTypeDtors :: [(P.ProperName 'P.ConstructorName, P.SourceType)] } deriving (Show, Eq, Ord, Generic, NFData) data IdeTypeSynonym = IdeTypeSynonym { _ideSynonymName :: P.ProperName 'P.TypeName - , _ideSynonymType :: P.Type - , _ideSynonymKind :: P.Kind + , _ideSynonymType :: P.SourceType + , _ideSynonymKind :: P.SourceKind } deriving (Show, Eq, Ord, Generic, NFData) data IdeDataConstructor = IdeDataConstructor { _ideDtorName :: P.ProperName 'P.ConstructorName , _ideDtorTypeName :: P.ProperName 'P.TypeName - , _ideDtorType :: P.Type + , _ideDtorType :: P.SourceType } deriving (Show, Eq, Ord, Generic, NFData) data IdeTypeClass = IdeTypeClass { _ideTCName :: P.ProperName 'P.ClassName - , _ideTCKind :: P.Kind + , _ideTCKind :: P.SourceKind , _ideTCInstances :: [IdeInstance] } deriving (Show, Eq, Ord, Generic, NFData) data IdeInstance = IdeInstance { _ideInstanceModule :: P.ModuleName , _ideInstanceName :: P.Ident - , _ideInstanceTypes :: [P.Type] - , _ideInstanceConstraints :: Maybe [P.Constraint] + , _ideInstanceTypes :: [P.SourceType] + , _ideInstanceConstraints :: Maybe [P.SourceConstraint] } deriving (Show, Eq, Ord, Generic, NFData) data IdeValueOperator = IdeValueOperator @@ -83,7 +83,7 @@ data IdeValueOperator = IdeValueOperator , _ideValueOpAlias :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) , _ideValueOpPrecedence :: P.Precedence , _ideValueOpAssociativity :: P.Associativity - , _ideValueOpType :: Maybe P.Type + , _ideValueOpType :: Maybe P.SourceType } deriving (Show, Eq, Ord, Generic, NFData) data IdeTypeOperator = IdeTypeOperator @@ -91,7 +91,7 @@ data IdeTypeOperator = IdeTypeOperator , _ideTypeOpAlias :: P.Qualified (P.ProperName 'P.TypeName) , _ideTypeOpPrecedence :: P.Precedence , _ideTypeOpAssociativity :: P.Associativity - , _ideTypeOpKind :: Maybe P.Kind + , _ideTypeOpKind :: Maybe P.SourceKind } deriving (Show, Eq, Ord, Generic, NFData) _IdeDeclValue :: Traversal' IdeDeclaration IdeValue @@ -147,7 +147,7 @@ data Annotation = Annotation { _annLocation :: Maybe P.SourceSpan , _annExportedFrom :: Maybe P.ModuleName - , _annTypeAnnotation :: Maybe P.Type + , _annTypeAnnotation :: Maybe P.SourceType , _annDocumentation :: Maybe Text } deriving (Show, Eq, Ord, Generic, NFData) @@ -158,7 +158,7 @@ emptyAnn :: Annotation emptyAnn = Annotation Nothing Nothing Nothing Nothing type DefinitionSites a = Map IdeNamespaced a -type TypeAnnotations = Map P.Ident P.Type +type TypeAnnotations = Map P.Ident P.SourceType newtype AstData a = AstData (ModuleMap (DefinitionSites a, TypeAnnotations)) -- ^ SourceSpans for the definition sites of values and types as well as type -- annotations found in a module diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 3205316a44..bca6bf278d 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -261,7 +261,7 @@ handleTypeOf print' val = do handleKindOf :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) => (String -> m ()) - -> P.Type + -> P.SourceType -> m () handleKindOf print' typ = do st <- get diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 289ed4c964..a916e619ff 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -56,10 +56,10 @@ createTemporaryModule exec st val = itDecl = P.ValueDecl (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val] typeDecl = P.TypeDeclaration (P.TypeDeclarationData (internalSpan, []) (P.Ident "$main") - (P.TypeApp - (P.TypeConstructor + (P.srcTypeApp + (P.srcTypeConstructor (P.Qualified (Just (P.ModuleName [P.ProperName "$Effect"])) (P.ProperName "Effect"))) - (P.TypeWildcard internalSpan))) + P.srcTypeWildcard)) mainDecl = P.ValueDecl (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] in @@ -72,7 +72,7 @@ createTemporaryModule exec st val = -- | -- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration. -- -createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module +createTemporaryModuleForKind :: PSCiState -> P.SourceType -> P.Module createTemporaryModuleForKind st typ = let imports = psciImportedModules st diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index 608129465e..7d35b08147 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -37,12 +37,12 @@ printModuleSignatures moduleName P.Environment{..} = where printModule's showF = Box.vsep 1 Box.left . showF - findNameType :: M.Map (P.Qualified P.Ident) (P.Type, P.NameKind, P.NameVisibility) + findNameType :: M.Map (P.Qualified P.Ident) (P.SourceType, P.NameKind, P.NameVisibility) -> P.Qualified P.Ident - -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) + -> (P.Ident, Maybe (P.SourceType, P.NameKind, P.NameVisibility)) findNameType envNames m = (P.disqualify m, M.lookup m envNames) - showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box + showNameType :: (P.Ident, Maybe (P.SourceType, P.NameKind, P.NameVisibility)) -> Box.Box showNameType (mIdent, Just (mType, _, _)) = textT (P.showIdent mIdent <> " :: ") Box.<> P.typeAsBox mType showNameType _ = P.internalError "The impossible happened in printModuleSignatures." @@ -61,7 +61,7 @@ printModuleSignatures moduleName P.Environment{..} = if null typeClassSuperclasses then Box.text "" else Box.text "(" - Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint (P.Qualified _ pn) lt _) -> textT (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) typeClassSuperclasses) + Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint _ (P.Qualified _ pn) lt _) -> textT (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) typeClassSuperclasses) Box.<> Box.text ") <= " className = textT (P.runProperName name) @@ -79,16 +79,16 @@ printModuleSignatures moduleName P.Environment{..} = findType - :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind) + :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.SourceKind, P.TypeKind) -> P.Qualified (P.ProperName 'P.TypeName) - -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind)) + -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.SourceKind, P.TypeKind)) findType envTypes name = (name, M.lookup name envTypes) showType :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData - -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident]) - -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(Text, Maybe P.Kind)], P.Type) - -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind)) + -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]) + -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(Text, Maybe P.SourceKind)], P.SourceType) + -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.SourceKind, P.TypeKind)) -> Maybe Box.Box showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) = case (typ, M.lookup n typeSynonymsEnv) of diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index 521b61dd8a..437408fd94 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -174,7 +174,7 @@ data Command -- | Find the type of an expression | TypeOf P.Expr -- | Find the kind of an expression - | KindOf P.Type + | KindOf P.SourceType -- | Shows information about the current state of the REPL | ShowInfo ReplQuery -- | Paste multiple lines diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 01df9dca87..7e843cc86d 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} module Language.PureScript.Kinds where @@ -6,104 +9,158 @@ import Prelude.Compat import GHC.Generics (Generic) import Control.DeepSeq (NFData) +import Data.Function (fix) import Data.Text (Text) import qualified Data.Text as T -import Data.Aeson.BetterErrors (Parse, key, asText, asIntegral, nth, fromAesonParser, toAesonParser, throwCustomError) +import Data.Aeson.BetterErrors (Parse, key, asText, asIntegral, nth, fromAesonParser, toAesonParser, throwCustomError, (<|>)) import Data.Aeson ((.=)) import qualified Data.Aeson as A +import Language.PureScript.AST.SourcePos import Language.PureScript.Names import qualified Language.PureScript.Constants as C +type SourceKind = Kind SourceAnn + -- | The data type of kinds -data Kind +data Kind a -- | Unification variable of type Kind - = KUnknown Int + = KUnknown a Int -- | Kinds for labelled, unordered rows without duplicates - | Row Kind + | Row a (Kind a) -- | Function kinds - | FunKind Kind Kind + | FunKind a (Kind a) (Kind a) -- | A named kind - | NamedKind (Qualified (ProperName 'KindName)) - deriving (Show, Eq, Ord, Generic) + | NamedKind a (Qualified (ProperName 'KindName)) + deriving (Show, Generic, Functor, Foldable, Traversable) + +instance NFData a => NFData (Kind a) + +srcKUnknown :: Int -> SourceKind +srcKUnknown = KUnknown NullSourceAnn + +srcRow :: SourceKind -> SourceKind +srcRow = Row NullSourceAnn -instance NFData Kind +srcFunKind :: SourceKind -> SourceKind -> SourceKind +srcFunKind = FunKind NullSourceAnn --- This is equivalent to the derived Aeson ToJSON instance, except that we --- write it out manually so that we can define a parser which is --- backwards-compatible. -instance A.ToJSON Kind where +srcNamedKind :: Qualified (ProperName 'KindName) -> SourceKind +srcNamedKind = NamedKind NullSourceAnn + +instance A.ToJSON a => A.ToJSON (Kind a) where toJSON kind = case kind of - KUnknown i -> - obj "KUnknown" i - Row k -> - obj "Row" k - FunKind k1 k2 -> - obj "FunKind" [k1, k2] - NamedKind n -> - obj "NamedKind" n + KUnknown a i -> + obj "KUnknown" a i + Row a k -> + obj "Row" a k + FunKind a k1 k2 -> + obj "FunKind" a [k1, k2] + NamedKind a n -> + obj "NamedKind" a n where - obj :: A.ToJSON a => Text -> a -> A.Value - obj tag contents = - A.object [ "tag" .= tag, "contents" .= contents ] + obj :: A.ToJSON b => Text -> a -> b -> A.Value + obj tag ann contents = + A.object [ "tag" .= tag, "annotation" .= ann, "contents" .= contents ] --- This is equivalent to the derived Aeson FromJSON instance, except that it --- also handles JSON generated by compilers up to 0.10.3 and maps them to the +-- This handles JSON generated by compilers up to 0.10.3 and maps them to the -- new representations (i.e. NamedKinds which are defined in the Prim module). -kindFromJSON :: Parse Text Kind -kindFromJSON = do +kindFromJSON :: Parse Text a -> Parse Text a -> Parse Text (Kind a) +kindFromJSON defaultAnn annFromJSON = fix $ \go -> do t <- key "tag" asText + let annFromJSON' = key "annotation" annFromJSON <|> defaultAnn case t of "KUnknown" -> - KUnknown <$> key "contents" (nth 0 asIntegral) + KUnknown <$> annFromJSON' <*> key "contents" (nth 0 asIntegral) "Star" -> - pure kindType + kindType <$> defaultAnn "Row" -> - Row <$> key "contents" kindFromJSON + Row <$> annFromJSON' <*> key "contents" go "FunKind" -> let - kindAt n = key "contents" (nth n kindFromJSON) + kindAt n = key "contents" (nth n go) in - FunKind <$> kindAt 0 <*> kindAt 1 + FunKind <$> annFromJSON' <*> kindAt 0 <*> kindAt 1 "Symbol" -> - pure kindSymbol + kindSymbol <$> defaultAnn "NamedKind" -> - NamedKind <$> key "contents" fromAesonParser + NamedKind <$> annFromJSON' <*> key "contents" fromAesonParser other -> throwCustomError (T.append "Unrecognised tag: " other) where -- The following are copied from Environment and reimplemented to avoid -- circular dependencies. - primName :: Text -> Qualified (ProperName a) + primName :: Text -> Qualified (ProperName b) primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName - primKind :: Text -> Kind - primKind = NamedKind . primName + primKind = flip NamedKind . primName kindType = primKind C.typ kindSymbol = primKind C.symbol -instance A.FromJSON Kind where - parseJSON = toAesonParser id kindFromJSON +-- These overlapping instances exist to preserve compatability for common +-- instances which have a sensible default for missing annotations. +instance {-# OVERLAPPING #-} A.FromJSON (Kind SourceAnn) where + parseJSON = toAesonParser id (kindFromJSON (pure NullSourceAnn) fromAesonParser) + +instance {-# OVERLAPPING #-} A.FromJSON (Kind ()) where + parseJSON = toAesonParser id (kindFromJSON (pure ()) fromAesonParser) -everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind +instance {-# OVERLAPPING #-} A.FromJSON a => A.FromJSON (Kind a) where + parseJSON = toAesonParser id (kindFromJSON (fail "Invalid annotation") fromAesonParser) + +everywhereOnKinds :: (Kind a -> Kind a) -> Kind a -> Kind a everywhereOnKinds f = go where - go (Row k1) = f (Row (go k1)) - go (FunKind k1 k2) = f (FunKind (go k1) (go k2)) + go (Row ann k1) = f (Row ann (go k1)) + go (FunKind ann k1 k2) = f (FunKind ann (go k1) (go k2)) go other = f other -everywhereOnKindsM :: Monad m => (Kind -> m Kind) -> Kind -> m Kind +everywhereOnKindsM :: Monad m => (Kind a -> m (Kind a)) -> Kind a -> m (Kind a) everywhereOnKindsM f = go where - go (Row k1) = (Row <$> go k1) >>= f - go (FunKind k1 k2) = (FunKind <$> go k1 <*> go k2) >>= f + go (Row ann k1) = (Row ann <$> go k1) >>= f + go (FunKind ann k1 k2) = (FunKind ann <$> go k1 <*> go k2) >>= f go other = f other -everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r +everythingOnKinds :: (r -> r -> r) -> (Kind a -> r) -> Kind a -> r everythingOnKinds (<>.) f = go where - go k@(Row k1) = f k <>. go k1 - go k@(FunKind k1 k2) = f k <>. go k1 <>. go k2 + go k@(Row _ k1) = f k <>. go k1 + go k@(FunKind _ k1 k2) = f k <>. go k1 <>. go k2 go other = f other + +annotationForKind :: Kind a -> a +annotationForKind (KUnknown a _) = a +annotationForKind (Row a _) = a +annotationForKind (FunKind a _ _) = a +annotationForKind (NamedKind a _) = a + +instance Eq (Kind a) where + (==) = eqKind + +instance Ord (Kind a) where + compare = compareKind + +eqKind :: Kind a -> Kind b -> Bool +eqKind (KUnknown _ a) (KUnknown _ a') = a == a' +eqKind (Row _ a) (Row _ a') = eqKind a a' +eqKind (FunKind _ a b) (FunKind _ a' b') = eqKind a a' && eqKind b b' +eqKind (NamedKind _ a) (NamedKind _ a') = a == a' +eqKind _ _ = False + +compareKind :: Kind a -> Kind b -> Ordering +compareKind (KUnknown _ a) (KUnknown _ a') = compare a a' +compareKind (KUnknown {}) _ = LT + +compareKind (Row _ a) (Row _ a') = compareKind a a' +compareKind (Row {}) _ = LT +compareKind _ (Row {}) = GT + +compareKind (FunKind _ a b) (FunKind _ a' b') = compareKind a b <> compareKind a' b' +compareKind (FunKind {}) _ = LT +compareKind _ (FunKind {}) = GT + +compareKind (NamedKind _ a) (NamedKind _ a') = compare a a' +compareKind (NamedKind {}) _ = GT diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 1b92f7c7d4..d90c77d96f 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -80,40 +80,40 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl checkTypeVarsInDecl :: S.Set Text -> Declaration -> MultipleErrors checkTypeVarsInDecl s d = let (f, _, _, _, _) = accumTypes (checkTypeVars (declSourceSpan d) s) in f d - checkTypeVars :: SourceSpan -> S.Set Text -> Type -> MultipleErrors + checkTypeVars :: SourceSpan -> S.Set Text -> SourceType -> MultipleErrors checkTypeVars ss set ty = everythingWithContextOnTypes set mempty mappend step ty <> snd (findUnused ty) where - step :: S.Set Text -> Type -> (S.Set Text, MultipleErrors) - step s (ForAll tv _ _) = bindVar s tv + step :: S.Set Text -> SourceType -> (S.Set Text, MultipleErrors) + step s (ForAll _ tv _ _) = bindVar s tv step s _ = (s, mempty) bindVar :: S.Set Text -> Text -> (S.Set Text, MultipleErrors) bindVar = bind ss ShadowedTypeVar - findUnused :: Type -> (S.Set Text, MultipleErrors) + findUnused :: SourceType -> (S.Set Text, MultipleErrors) findUnused = go set where -- Recursively walk the type and prune used variables from `unused` - go :: S.Set Text -> Type -> (S.Set Text, MultipleErrors) - go unused (TypeVar v) = (S.delete v unused, mempty) - go unused (ForAll tv t1 _) = + go :: S.Set Text -> SourceType -> (S.Set Text, MultipleErrors) + go unused (TypeVar _ v) = (S.delete v unused, mempty) + go unused (ForAll _ tv t1 _) = let (nowUnused, errors) = go (S.insert tv unused) t1 restoredUnused = if S.member tv unused then S.insert tv nowUnused else nowUnused combinedErrors = if S.member tv nowUnused then errors <> errorMessage' ss (UnusedTypeVar tv) else errors in (restoredUnused, combinedErrors) - go unused (TypeApp f x) = go unused f `combine` go unused x - go unused (ConstrainedType c t1) = foldl combine (unused, mempty) $ map (go unused) (constraintArgs c <> [t1]) - go unused (RCons _ t1 rest) = go unused t1 `combine` go unused rest - go unused (KindedType t1 _) = go unused t1 - go unused (ParensInType t1) = go unused t1 - go unused (BinaryNoParensType t1 t2 t3) = go unused t1 `combine` go unused t2 `combine` go unused t3 + go unused (TypeApp _ f x) = go unused f `combine` go unused x + go unused (ConstrainedType _ c t1) = foldl combine (unused, mempty) $ map (go unused) (constraintArgs c <> [t1]) + go unused (RCons _ _ t1 rest) = go unused t1 `combine` go unused rest + go unused (KindedType _ t1 _) = go unused t1 + go unused (ParensInType _ t1) = go unused t1 + go unused (BinaryNoParensType _ t1 t2 t3) = go unused t1 `combine` go unused t2 `combine` go unused t3 go unused TUnknown{} = (unused, mempty) go unused TypeLevelString{} = (unused, mempty) go unused TypeWildcard{} = (unused, mempty) go unused TypeConstructor{} = (unused, mempty) go unused TypeOp{} = (unused, mempty) go unused Skolem{} = (unused, mempty) - go unused REmpty = (unused, mempty) + go unused REmpty{} = (unused, mempty) go unused PrettyPrintFunction{} = (unused, mempty) go unused PrettyPrintObject{} = (unused, mempty) go unused PrettyPrintForAll{} = (unused, mempty) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 4278f509a3..ff64b442de 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -63,15 +63,15 @@ qualifyName n defmn qn = Qualified (Just mn) n -- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe) -- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"]) -- -getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'ConstructorName) -> [(ProperName 'ConstructorName, [Type])] +getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'ConstructorName) -> [(ProperName 'ConstructorName, [SourceType])] getConstructors env defmn n = extractConstructors lnte where - extractConstructors :: Maybe (Kind, TypeKind) -> [(ProperName 'ConstructorName, [Type])] + extractConstructors :: Maybe (SourceKind, TypeKind) -> [(ProperName 'ConstructorName, [SourceType])] extractConstructors (Just (_, DataType _ pt)) = pt extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors" - lnte :: Maybe (Kind, TypeKind) + lnte :: Maybe (SourceKind, TypeKind) lnte = M.lookup qpn (types env) qpn :: Qualified (ProperName 'TypeName) @@ -83,7 +83,7 @@ getConstructors env defmn n = extractConstructors lnte Nothing -> internalError $ "Constructor " ++ T.unpack (showQualified runProperName con) ++ " not in the scope of the current environment in getConsDataName." Just (_, pm, _, _) -> qualifyName pm defmn con - getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, Type, [Ident]) + getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) getConsInfo con = M.lookup con (dataConstructors env) -- | @@ -303,12 +303,12 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' (ty tyVar)) ] - ty :: Text -> Type + ty :: Text -> SourceType ty tyVar = - ForAll tyVar - ( ConstrainedType - (Constraint C.Partial [] (Just constraintData)) - $ TypeApp (TypeApp tyFunction (TypeVar tyVar)) (TypeVar tyVar) + srcForAll tyVar + ( srcConstrainedType + (srcConstraint C.Partial [] (Just constraintData)) + $ srcTypeApp (srcTypeApp tyFunction (srcTypeVar tyVar)) (srcTypeVar tyVar) ) Nothing diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index bfc77014cb..39ddadba19 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -41,7 +41,7 @@ import Language.PureScript.Types import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P -kindedIdent :: TokenParser (Text, Maybe Kind) +kindedIdent :: TokenParser (Text, Maybe SourceKind) kindedIdent = (, Nothing) <$> identifier <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind))) @@ -204,10 +204,11 @@ parseTypeClassDeclaration = withSourceAnnF $ do indented *> mark (P.many (same *> parseTypeDeclaration)) return $ \sa -> TypeClassDeclaration sa className idents implies dependencies members -parseConstraint :: TokenParser Constraint -parseConstraint = Constraint <$> parseQualified properName - <*> P.many (noWildcards $ noForAll parseTypeAtom) - <*> pure Nothing +parseConstraint :: TokenParser SourceConstraint +parseConstraint = withSourceAnnF $ do + name <- parseQualified properName + args <- P.many (noWildcards $ noForAll parseTypeAtom) + return $ \ann -> Constraint ann name args Nothing parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) parseInstanceDeclaration = withSourceAnnF $ do diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs index bb4cc2ddc1..abdc810957 100644 --- a/src/Language/PureScript/Parser/Kinds.hs +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -12,10 +12,12 @@ import Language.PureScript.Parser.Lexer import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P -parseNamedKind :: TokenParser Kind -parseNamedKind = NamedKind <$> parseQualified kindName +parseNamedKind :: TokenParser SourceKind +parseNamedKind = withSourceAnnF $ do + name <- parseQualified kindName + return $ \ann -> NamedKind ann name -parseKindAtom :: TokenParser Kind +parseKindAtom :: TokenParser SourceKind parseKindAtom = indented *> P.choice [ parseNamedKind @@ -25,8 +27,8 @@ parseKindAtom = -- | -- Parse a kind -- -parseKind :: TokenParser Kind +parseKind :: TokenParser SourceKind parseKind = P.buildExpressionParser operators parseKindAtom P. "kind" where - operators = [ [ P.Prefix (symbol' "#" >> return Row) ] - , [ P.Infix (rarrow >> return FunKind) P.AssocRight ] ] + operators = [ [ P.Prefix (withSourceAnnF $ symbol' "#" >> return Row) ] + , [ P.Infix (withSourceAnnF $ rarrow >> return FunKind) P.AssocRight ] ] diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 3a9803c7bd..9f27687326 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -15,6 +15,7 @@ import qualified Data.Text as T import Language.PureScript.AST.SourcePos import Language.PureScript.Environment +import Language.PureScript.Kinds import Language.PureScript.Parser.Common import Language.PureScript.Parser.Kinds import Language.PureScript.Parser.Lexer @@ -24,40 +25,41 @@ import Language.PureScript.Label (Label(..)) import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P -parseFunction :: TokenParser Type +parseFunction :: TokenParser SourceType parseFunction = parens rarrow *> return tyFunction -parseObject :: TokenParser Type -parseObject = braces $ TypeApp tyRecord <$> parseRow +parseObject :: TokenParser SourceType +parseObject = withSourceAnnF $ braces $ do + rows <- parseRow + return $ \ann -> TypeApp ann tyRecord rows -parseTypeLevelString :: TokenParser Type -parseTypeLevelString = TypeLevelString <$> stringLiteral +parseTypeLevelString :: TokenParser SourceType +parseTypeLevelString = withSourceAnnF $ flip TypeLevelString <$> stringLiteral -parseTypeWildcard :: TokenParser Type -parseTypeWildcard = do - start <- P.getPosition - let end = P.incSourceColumn start 1 - underscore - return $ TypeWildcard (SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)) +parseTypeWildcard :: TokenParser SourceType +parseTypeWildcard = withSourceAnnF $ underscore $> TypeWildcard -parseTypeVariable :: TokenParser Type -parseTypeVariable = do +parseTypeVariable :: TokenParser SourceType +parseTypeVariable = withSourceAnnF $ do ident <- identifier when (ident `elem` reservedTypeNames) $ P.unexpected (T.unpack ident) - return $ TypeVar ident + return $ \ann -> TypeVar ann ident -parseTypeConstructor :: TokenParser Type -parseTypeConstructor = TypeConstructor <$> parseQualified typeName - -parseForAll :: TokenParser Type -parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") *> P.many1 (indented *> identifier) <* indented <* dot) - <*> parseType +parseTypeConstructor :: TokenParser SourceType +parseTypeConstructor = withSourceAnnF $ flip TypeConstructor <$> parseQualified typeName +parseForAll :: TokenParser SourceType +parseForAll = + mkForAll + <$> ((reserved "forall" <|> reserved "∀") + *> (P.many1 $ indented *> (withSourceAnnF $ flip (,) <$> identifier)) + <* indented <* dot) + <*> parseType -- | -- Parse an atomic type with no `forall` -- -noForAll :: TokenParser Type -> TokenParser Type +noForAll :: TokenParser SourceType -> TokenParser SourceType noForAll p = do ty <- p when (containsForAll ty) $ P.unexpected "forall" @@ -66,7 +68,7 @@ noForAll p = do -- | -- Parse a type as it appears in e.g. a data constructor -- -parseTypeAtom :: TokenParser Type +parseTypeAtom :: TokenParser SourceType parseTypeAtom = indented *> P.choice [ P.try parseFunction , parseTypeLevelString @@ -77,31 +79,34 @@ parseTypeAtom = indented *> P.choice , parseTypeConstructor -- This try is needed due to some unfortunate ambiguities between rows and kinded types , P.try (parens parseRow) - , ParensInType <$> parens parsePolyType + , parseParensInType ] -parseConstrainedType :: TokenParser ([Constraint], Type) -parseConstrainedType = do +parseParensInType :: TokenParser SourceType +parseParensInType = withSourceAnnF $ flip ParensInType <$> parens parsePolyType + +parseConstrainedType :: TokenParser (SourceAnn, [SourceConstraint], SourceType) +parseConstrainedType = withSourceAnnF $ do constraints <- parens (commaSep1 parseConstraint) <|> pure <$> parseConstraint _ <- rfatArrow indented ty <- parseType - return (constraints, ty) + return (, constraints, ty) where - parseConstraint = do + parseConstraint = withSourceAnnF $ do className <- parseQualified properName indented ty <- P.many parseTypeAtom - return (Constraint className ty Nothing) + return $ \ann -> Constraint ann className ty Nothing -- This is here to improve the error message when the user -- tries to use the old style constraint contexts. -- TODO: Remove this before 1.0 -typeOrConstrainedType :: TokenParser Type +typeOrConstrainedType :: TokenParser SourceType typeOrConstrainedType = do e <- P.try (Left <$> parseConstrainedType) <|> Right <$> parseTypeAtom case e of - Left ([c], ty) -> pure (ConstrainedType c ty) + Left (ann, [c], ty) -> pure (ConstrainedType ann c ty) Left _ -> P.unexpected $ unlines [ "comma in constraints." @@ -114,22 +119,34 @@ typeOrConstrainedType = do ] Right ty -> pure ty -parseAnyType :: TokenParser Type +parseAnyType :: TokenParser SourceType parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable typeOrConstrainedType) P. "type" where - operators = [ [ P.Infix (return TypeApp) P.AssocLeft ] - , [ P.Infix (P.try (parseQualified parseOperator) >>= \ident -> - return (BinaryNoParensType (TypeOp ident))) P.AssocRight + operators = [ [ P.Infix (return mkTypeApp) P.AssocLeft ] + , [ P.Infix parseTypeOp P.AssocRight ] , [ P.Infix (rarrow $> function) P.AssocRight ] ] - postfixTable = [ \t -> KindedType t <$> (indented *> doubleColon *> parseKind) + postfixTable = [ parseKindedType ] + mkTypeApp lhs rhs = + TypeApp (widenSourceAnn (annotationForType lhs) (annotationForType rhs)) lhs rhs + + parseTypeOp = withSourceAnnF $ do + ident <- P.try (parseQualified parseOperator) + return $ \ann lhs rhs -> + BinaryNoParensType (widenSourceAnn (annotationForType lhs) (annotationForType rhs)) (TypeOp ann ident) lhs rhs + + parseKindedType ty = do + kind <- indented *> doubleColon *> parseKind + return $ KindedType (widenSourceAnn (annotationForType ty) (annotationForKind kind)) ty kind + + -- | -- Parse a monotype -- -parseType :: TokenParser Type +parseType :: TokenParser SourceType parseType = do ty <- parseAnyType unless (isMonoType ty) $ P.unexpected "polymorphic type" @@ -138,23 +155,27 @@ parseType = do -- | -- Parse a polytype -- -parsePolyType :: TokenParser Type +parsePolyType :: TokenParser SourceType parsePolyType = parseAnyType -- | -- Parse an atomic type with no wildcards -- -noWildcards :: TokenParser Type -> TokenParser Type +noWildcards :: TokenParser SourceType -> TokenParser SourceType noWildcards p = do ty <- p when (containsWildcards ty) $ P.unexpected "type wildcard" return ty -parseNameAndType :: TokenParser t -> TokenParser (Label, t) -parseNameAndType p = (,) <$> (indented *> (Label <$> parseLabel) <* indented <* doubleColon) <*> p +parseRowListItem :: TokenParser SourceType -> TokenParser (RowListItem SourceAnn) +parseRowListItem p = withSourceAnnF $ + (\name ty ann -> RowListItem ann name ty) + <$> (indented *> (Label <$> parseLabel) <* indented <* doubleColon) <*> p -parseRowEnding :: TokenParser Type -parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> parseType +parseRowEnding :: TokenParser SourceType +parseRowEnding = + (indented *> pipe *> indented *> parseType) + <|> withSourceAnnF (return REmpty) -parseRow :: TokenParser Type -parseRow = (curry rowFromList <$> commaSep (parseNameAndType parsePolyType) <*> parseRowEnding) P. "row" +parseRow :: TokenParser SourceType +parseRow = (curry rowFromList <$> commaSep (parseRowListItem parsePolyType) <*> parseRowEnding) P. "row" diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs index 9f950af9f7..275f5e33c9 100644 --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -19,39 +19,39 @@ import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Pretty.Common -typeLiterals :: Pattern () Kind Text +typeLiterals :: Pattern () (Kind a) Text typeLiterals = mkPattern match where - match (KUnknown u) = + match (KUnknown _ u) = Just $ T.cons 'k' (T.pack (show u)) - match (NamedKind name) = + match (NamedKind _ name) = Just $ if isQualifiedWith (moduleNameFromString "Prim") name then runProperName (disqualify name) else showQualified runProperName name match _ = Nothing -matchRow :: Pattern () Kind ((), Kind) +matchRow :: Pattern () (Kind a) ((), Kind a) matchRow = mkPattern match where - match (Row k) = Just ((), k) + match (Row _ k) = Just ((), k) match _ = Nothing -funKind :: Pattern () Kind (Kind, Kind) +funKind :: Pattern () (Kind a) (Kind a, Kind a) funKind = mkPattern match where - match (FunKind arg ret) = Just (arg, ret) + match (FunKind _ arg ret) = Just (arg, ret) match _ = Nothing -- | Generate a pretty-printed string representing a Kind -prettyPrintKind :: Kind -> Text +prettyPrintKind :: Kind a -> Text prettyPrintKind = fromMaybe (internalError "Incomplete pattern") . PA.pattern matchKind () where - matchKind :: Pattern () Kind Text + matchKind :: Pattern () (Kind a) Text matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parensT matchKind) - operators :: OperatorTable () Kind Text + operators :: OperatorTable () (Kind a) Text operators = OperatorTable [ [ Wrap matchRow $ \_ k -> "# " <> k] , [ AssocR funKind $ \arg ret -> arg <> " -> " <> ret ] ] diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 40c2956eb5..9d45c7f9a5 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -37,112 +37,112 @@ import Text.PrettyPrint.Boxes hiding ((<+>)) -- TODO(Christoph): get rid of T.unpack s -constraintsAsBox :: TypeRenderOptions -> Constraint -> Box -> Box +constraintsAsBox :: TypeRenderOptions -> Constraint a -> Box -> Box constraintsAsBox tro con ty = constraintAsBox con `before` (" " <> text doubleRightArrow <> " " <> ty) where doubleRightArrow = if troUnicode tro then "⇒" else "=>" -constraintAsBox :: Constraint -> Box -constraintAsBox (Constraint pn tys _) = typeAsBox (foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys) +constraintAsBox :: Constraint a -> Box +constraintAsBox (Constraint ann pn tys _) = typeAsBox (foldl (TypeApp ann) (TypeConstructor ann (fmap coerceProperName pn)) tys) -- | -- Generate a pretty-printed string representing a Row -- -prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> Type -> Box +prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> Type a -> Box prettyPrintRowWith tro open close = uncurry listToBox . toList [] where - nameAndTypeToPs :: Char -> Label -> Type -> Box + nameAndTypeToPs :: Char -> Label -> Type a -> Box nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " " ++ doubleColon ++ " ") <> typeAsBox ty doubleColon = if troUnicode tro then "∷" else "::" - tailToPs :: Type -> Box - tailToPs REmpty = nullBox + tailToPs :: Type a -> Box + tailToPs (REmpty _) = nullBox tailToPs other = text "| " <> typeAsBox other - listToBox :: [(Label, Type)] -> Type -> Box - listToBox [] REmpty = text [open, close] + listToBox :: [(Label, Type a)] -> Type a -> Box + listToBox [] (REmpty _) = text [open, close] listToBox [] rest = text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ] listToBox ts rest = vcat left $ zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++ [ tailToPs rest, text [close] ] - toList :: [(Label, Type)] -> Type -> ([(Label, Type)], Type) - toList tys (RCons name ty row) = toList ((name, ty):tys) row + toList :: [(Label, Type a)] -> Type a -> ([(Label, Type a)], Type a) + toList tys (RCons _ name ty row) = toList ((name, ty):tys) row toList tys r = (reverse tys, r) -prettyPrintRow :: Type -> String +prettyPrintRow :: Type a -> String prettyPrintRow = render . prettyPrintRowWith defaultOptions '(' ')' -typeApp :: Pattern () Type (Type, Type) +typeApp :: Pattern () (Type a) (Type a, Type a) typeApp = mkPattern match where - match (TypeApp f x) = Just (f, x) + match (TypeApp _ f x) = Just (f, x) match _ = Nothing -appliedFunction :: Pattern () Type (Type, Type) +appliedFunction :: Pattern () (Type a) (Type a, Type a) appliedFunction = mkPattern match where - match (PrettyPrintFunction arg ret) = Just (arg, ret) + match (PrettyPrintFunction _ arg ret) = Just (arg, ret) match _ = Nothing -kinded :: Pattern () Type (Kind, Type) +kinded :: Pattern () (Type a) (Kind a, Type a) kinded = mkPattern match where - match (KindedType t k) = Just (k, t) + match (KindedType _ t k) = Just (k, t) match _ = Nothing -insertPlaceholders :: Type -> Type +insertPlaceholders :: Type a -> Type a insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert where - convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret - convert (TypeApp o r) | o == tyRecord = PrettyPrintObject r + convert (TypeApp _ (TypeApp ann f arg) ret) | eqType f tyFunction = PrettyPrintFunction ann arg ret + convert (TypeApp ann o r) | eqType o tyRecord = PrettyPrintObject ann r convert other = other - convertForAlls (ForAll ident ty _) = go [ident] ty + convertForAlls (ForAll ann ident ty _) = go [ident] ty where - go idents (ForAll ident' ty' _) = go (ident' : idents) ty' - go idents other = PrettyPrintForAll idents other + go idents (ForAll _ ident' ty' _) = go (ident' : idents) ty' + go idents other = PrettyPrintForAll ann idents other convertForAlls other = other -constrained :: Pattern () Type (Constraint, Type) +constrained :: Pattern () (Type a) (Constraint a, Type a) constrained = mkPattern match where - match (ConstrainedType deps ty) = Just (deps, ty) + match (ConstrainedType _ deps ty) = Just (deps, ty) match _ = Nothing -explicitParens :: Pattern () Type ((), Type) +explicitParens :: Pattern () (Type a) ((), Type a) explicitParens = mkPattern match where - match (ParensInType ty) = Just ((), ty) + match (ParensInType _ ty) = Just ((), ty) match _ = Nothing -matchTypeAtom :: TypeRenderOptions -> Pattern () Type Box +matchTypeAtom :: TypeRenderOptions -> Pattern () (Type a) Box matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} = typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType tro) where - typeLiterals :: Pattern () Type Box + typeLiterals :: Pattern () (Type a) Box typeLiterals = mkPattern match where match TypeWildcard{} = Just $ text "_" - match (TypeVar var) = Just $ text $ T.unpack var - match (TypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s - match (PrettyPrintObject row) = Just $ prettyPrintRowWith tro '{' '}' row - match (TypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor - match (TUnknown u) + match (TypeVar _ var) = Just $ text $ T.unpack var + match (TypeLevelString _ s) = Just $ text $ T.unpack $ prettyPrintString s + match (PrettyPrintObject _ row) = Just $ prettyPrintRowWith tro '{' '}' row + match (TypeConstructor _ ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor + match (TUnknown _ u) | suggesting = Just $ text "_" | otherwise = Just $ text $ 't' : show u - match (Skolem name s _ _) + match (Skolem _ name s _) | suggesting = Just $ text $ T.unpack name | otherwise = Just $ text $ T.unpack name ++ show s - match REmpty = Just $ text "()" + match (REmpty _) = Just $ text "()" match row@RCons{} = Just $ prettyPrintRowWith tro '(' ')' row - match (BinaryNoParensType op l r) = + match (BinaryNoParensType _ op l r) = Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r - match (TypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op + match (TypeOp _ op) = Just $ text $ T.unpack $ showQualified runOpName op match _ = Nothing -matchType :: TypeRenderOptions -> Pattern () Type Box +matchType :: TypeRenderOptions -> Pattern () (Type a) Box matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where - operators :: OperatorTable () Type Box + operators :: OperatorTable () (Type a) Box operators = OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ] , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text rightArrow <> " " <> ret) ] @@ -163,26 +163,26 @@ matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where | rows b1 > 1 || rows b2 > 1 = vcat left [ b1, f b2 ] | otherwise = hcat top [ b1, text " ", b2] -forall_ :: Pattern () Type ([String], Type) +forall_ :: Pattern () (Type a) ([String], Type a) forall_ = mkPattern match where - match (PrettyPrintForAll idents ty) = Just (map T.unpack idents, ty) + match (PrettyPrintForAll _ idents ty) = Just (map T.unpack idents, ty) match _ = Nothing -typeAtomAsBox :: Type -> Box +typeAtomAsBox :: Type a -> Box typeAtomAsBox = fromMaybe (internalError "Incomplete pattern") . PA.pattern (matchTypeAtom defaultOptions) () . insertPlaceholders -- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses -prettyPrintTypeAtom :: Type -> String +prettyPrintTypeAtom :: Type a -> String prettyPrintTypeAtom = render . typeAtomAsBox -typeAsBox :: Type -> Box +typeAsBox :: Type a -> Box typeAsBox = typeAsBoxImpl defaultOptions -suggestedTypeAsBox :: Type -> Box +suggestedTypeAsBox :: Type a -> Box suggestedTypeAsBox = typeAsBoxImpl suggestingOptions data TypeRenderOptions = TypeRenderOptions @@ -199,26 +199,26 @@ defaultOptions = TypeRenderOptions False False unicodeOptions :: TypeRenderOptions unicodeOptions = TypeRenderOptions False True -typeAsBoxImpl :: TypeRenderOptions -> Type -> Box +typeAsBoxImpl :: TypeRenderOptions -> Type a -> Box typeAsBoxImpl tro = fromMaybe (internalError "Incomplete pattern") . PA.pattern (matchType tro) () . insertPlaceholders -- | Generate a pretty-printed string representing a 'Type' -prettyPrintType :: Type -> String +prettyPrintType :: Type a -> String prettyPrintType = prettyPrintType' defaultOptions -- | Generate a pretty-printed string representing a 'Type' using unicode -- symbols where applicable -prettyPrintTypeWithUnicode :: Type -> String +prettyPrintTypeWithUnicode :: Type a -> String prettyPrintTypeWithUnicode = prettyPrintType' unicodeOptions -- | Generate a pretty-printed string representing a suggested 'Type' -prettyPrintSuggestedType :: Type -> String +prettyPrintSuggestedType :: Type a -> String prettyPrintSuggestedType = prettyPrintType' suggestingOptions -prettyPrintType' :: TypeRenderOptions -> Type -> String +prettyPrintType' :: TypeRenderOptions -> Type a -> String prettyPrintType' tro = render . typeAsBoxImpl tro prettyPrintLabel :: Label -> Text diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 7902526c03..ad45d2a19a 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -85,7 +85,7 @@ prettyPrintValue d (Do els) = prettyPrintValue d (Ado els yield) = text "ado " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) // (text "in " <> prettyPrintValue (d - 1) yield) -prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map typeAtomAsBox tys +prettyPrintValue _ (TypeClassDictionary (Constraint _ name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map typeAtomAsBox tys prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name)) prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = text "#dict-accessor " <> text (T.unpack (runProperName (disqualify className))) <> text "." <> text (T.unpack (showIdent ident)) <> text ">" diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index f78c9dd6bd..a4efc201d6 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -138,13 +138,13 @@ usedTypeNames moduleName = let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames) in ordNub . f where - usedNames :: Type -> [ProperName 'TypeName] - usedNames (ConstrainedType con _) = + usedNames :: SourceType -> [ProperName 'TypeName] + usedNames (ConstrainedType _ con _) = case con of - (Constraint (Qualified (Just moduleName') name) _ _) + (Constraint _ (Qualified (Just moduleName') name) _ _) | moduleName == moduleName' -> [coerceProperName name] _ -> [] - usedNames (TypeConstructor (Qualified (Just moduleName') name)) + usedNames (TypeConstructor _ (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name] usedNames _ = [] diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index afa770f2c7..22961398d2 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -306,35 +306,35 @@ renameInModule imports (Module modSS coms mn decls exps) = letBoundVariable :: Declaration -> Maybe Ident letBoundVariable = fmap valdeclIdent . getValueDeclaration - updateKindsEverywhere :: SourceSpan -> Kind -> m Kind + updateKindsEverywhere :: SourceSpan -> Kind a -> m (Kind a) updateKindsEverywhere pos = everywhereOnKindsM updateKind where - updateKind :: Kind -> m Kind - updateKind (NamedKind name) = NamedKind <$> updateKindName name pos + updateKind :: Kind a -> m (Kind a) + updateKind (NamedKind ann name) = NamedKind ann <$> updateKindName name pos updateKind k = return k updateTypeArguments :: (Traversable f, Traversable g) => SourceSpan - -> f (a, g Kind) -> m (f (a, g Kind)) + -> f (a, g (Kind ann)) -> m (f (a, g (Kind ann))) updateTypeArguments pos = traverse (sndM (traverse (updateKindsEverywhere pos))) - updateTypesEverywhere :: SourceSpan -> Type -> m Type + updateTypesEverywhere :: SourceSpan -> Type a -> m (Type a) updateTypesEverywhere pos = everywhereOnTypesM updateType where - updateType :: Type -> m Type - updateType (TypeOp name) = TypeOp <$> updateTypeOpName name pos - updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos - updateType (ConstrainedType c t) = ConstrainedType <$> updateInConstraint c <*> pure t - updateType (KindedType t k) = KindedType t <$> updateKindsEverywhere pos k + updateType :: Type a -> m (Type a) + updateType (TypeOp ann name) = TypeOp ann <$> updateTypeOpName name pos + updateType (TypeConstructor ann name) = TypeConstructor ann <$> updateTypeName name pos + updateType (ConstrainedType ann c t) = ConstrainedType ann <$> updateInConstraint c <*> pure t + updateType (KindedType ann t k) = KindedType ann t <$> updateKindsEverywhere pos k updateType t = return t - updateInConstraint :: Constraint -> m Constraint - updateInConstraint (Constraint name ts info) = - Constraint <$> updateClassName name pos <*> pure ts <*> pure info + updateInConstraint :: Constraint a -> m (Constraint a) + updateInConstraint (Constraint ann name ts info) = + Constraint ann <$> updateClassName name pos <*> pure ts <*> pure info - updateConstraints :: SourceSpan -> [Constraint] -> m [Constraint] - updateConstraints pos = traverse $ \(Constraint name ts info) -> - Constraint + updateConstraints :: SourceSpan -> [Constraint a] -> m [Constraint a] + updateConstraints pos = traverse $ \(Constraint ann name ts info) -> + Constraint ann <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts <*> pure info diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 2ca1b1f88a..9a2868f4b3 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -166,11 +166,11 @@ rebracketFiltered pred_ externs modules = do internalError "BinaryNoParensBinder has no OpBinder" goBinder pos other = return (pos, other) - goType :: SourceSpan -> Type -> m Type - goType pos (BinaryNoParensType (TypeOp op) lhs rhs) = + goType :: SourceSpan -> SourceType -> m SourceType + goType pos (BinaryNoParensType ann (TypeOp ann2 op) lhs rhs) = case op `M.lookup` typeAliased of Just alias -> - return $ TypeApp (TypeApp (TypeConstructor alias) lhs) rhs + return $ TypeApp ann (TypeApp ann (TypeConstructor ann2 alias) lhs) rhs Nothing -> throwError . errorMessage' pos $ UnknownName $ fmap TyOpName op goType _ other = return other @@ -202,7 +202,7 @@ rebracketModule pred_ valueOpTable typeOpTable (Module ss coms mn ds exts) = (goDecl, goExpr', goBinder') = updateTypes goType - goType :: SourceSpan -> Type -> m Type + goType :: SourceSpan -> SourceType -> m SourceType goType = flip matchTypeOperators typeOpTable wrap :: (a -> m a) -> (SourceSpan, a) -> m (SourceSpan, a) @@ -227,8 +227,8 @@ removeParens = f goBinder (ParensInBinder b) = goBinder b goBinder b = b - goType :: Type -> Type - goType (ParensInType t) = goType t + goType :: Type a -> Type a + goType (ParensInType _ t) = goType t goType t = t decontextify @@ -302,7 +302,7 @@ customOperatorTable fixities = updateTypes :: forall m . Monad m - => (SourceSpan -> Type -> m Type) + => (SourceSpan -> SourceType -> m SourceType) -> ( Declaration -> m Declaration , SourceSpan -> Expr -> m (SourceSpan, Expr) , SourceSpan -> Binder -> m (SourceSpan, Binder) @@ -310,7 +310,7 @@ updateTypes updateTypes goType = (goDecl, goExpr, goBinder) where - goType' :: SourceSpan -> Type -> m Type + goType' :: SourceSpan -> SourceType -> m SourceType goType' = everywhereOnTypesTopDownM . goType goDecl :: Declaration -> m Declaration @@ -334,9 +334,9 @@ updateTypes goType = (goDecl, goExpr, goBinder) goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (pos, e) - goExpr pos (TypeClassDictionary (Constraint name tys info) dicts hints) = do + goExpr pos (TypeClassDictionary (Constraint ann name tys info) dicts hints) = do tys' <- traverse (goType' pos) tys - return (pos, TypeClassDictionary (Constraint name tys' info) dicts hints) + return (pos, TypeClassDictionary (Constraint ann name tys' info) dicts hints) goExpr pos (DeferredDictionary cls tys) = do tys' <- traverse (goType' pos) tys return (pos, DeferredDictionary cls tys') diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs index 5022a13cab..fd2e1a188d 100644 --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -13,22 +13,22 @@ matchTypeOperators :: MonadError MultipleErrors m => SourceSpan -> [[(Qualified (OpName 'TypeOpName), Associativity)]] - -> Type - -> m Type + -> SourceType + -> m SourceType matchTypeOperators ss = matchOperators isBinOp extractOp fromOp reapply id where - isBinOp :: Type -> Bool + isBinOp :: SourceType -> Bool isBinOp BinaryNoParensType{} = True isBinOp _ = False - extractOp :: Type -> Maybe (Type, Type, Type) - extractOp (BinaryNoParensType op l r) = Just (op, l, r) + extractOp :: SourceType -> Maybe (SourceType, SourceType, SourceType) + extractOp (BinaryNoParensType _ op l r) = Just (op, l, r) extractOp _ = Nothing - fromOp :: Type -> Maybe (SourceSpan, Qualified (OpName 'TypeOpName)) - fromOp (TypeOp q@(Qualified _ (OpName _))) = Just (ss, q) + fromOp :: SourceType -> Maybe (SourceSpan, Qualified (OpName 'TypeOpName)) + fromOp (TypeOp _ q@(Qualified _ (OpName _))) = Just (ss, q) fromOp _ = Nothing - reapply :: a -> Qualified (OpName 'TypeOpName) -> Type -> Type -> Type - reapply _ = BinaryNoParensType . TypeOp + reapply :: a -> Qualified (OpName 'TypeOpName) -> SourceType -> SourceType -> SourceType + reapply _ = srcBinaryNoParensType . srcTypeOp diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 0645bcde7d..08e4af2b92 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -193,12 +193,12 @@ desugarDecl mn exps = go dictDecl <- typeInstanceDictionaryDeclaration sa name mn deps className tys desugared return (expRef name className tys, [d, dictDecl]) go d@(TypeInstanceDeclaration sa _ _ name deps className tys (NewtypeInstanceWithDictionary dict)) = do - let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys - constrainedTy = quantify (foldr ConstrainedType dictTy deps) + let dictTy = foldl srcTypeApp (srcTypeConstructor (fmap coerceProperName className)) tys + constrainedTy = quantify (foldr (srcConstrainedType) dictTy deps) return (expRef name className tys, [d, ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) go other = return (Nothing, [other]) - expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef + expRef :: Ident -> Qualified (ProperName 'ClassName) -> [SourceType] -> Maybe DeclarationRef expRef name className tys | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef genSpan name | otherwise = Nothing @@ -220,39 +220,40 @@ desugarDecl mn exps = go matchesTypeRef pn (TypeRef _ pn' _) = pn == pn' matchesTypeRef _ _ = False - getConstructors :: Type -> [Qualified (ProperName 'TypeName)] + getConstructors :: SourceType -> [Qualified (ProperName 'TypeName)] getConstructors = everythingOnTypes (++) getConstructor where - getConstructor (TypeConstructor tcname) = [tcname] + getConstructor (TypeConstructor _ tcname) = [tcname] getConstructor _ = [] genSpan :: SourceSpan genSpan = internalModuleSourceSpan "" -memberToNameAndType :: Declaration -> (Ident, Type) +memberToNameAndType :: Declaration -> (Ident, SourceType) memberToNameAndType (TypeDeclaration td) = unwrapTypeDeclaration td memberToNameAndType _ = internalError "Invalid declaration in type class definition" typeClassDictionaryDeclaration :: SourceAnn -> ProperName 'ClassName - -> [(Text, Maybe Kind)] - -> [Constraint] + -> [(Text, Maybe SourceKind)] + -> [SourceConstraint] -> [Declaration] -> Declaration typeClassDictionaryDeclaration sa name args implies members = let superclassTypes = superClassDictionaryNames implies `zip` - [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs) - | (Constraint superclass tyArgs _) <- implies + [ function unit (foldl srcTypeApp (srcTypeConstructor (fmap coerceProperName superclass)) tyArgs) + | (Constraint _ superclass tyArgs _) <- implies ] members' = map (first runIdent . memberToNameAndType) members mtys = members' ++ superclassTypes - in TypeSynonymDeclaration sa (coerceProperName name) args (TypeApp tyRecord $ rowFromList (map (first (Label . mkString)) mtys, REmpty)) + toRowListItem (l, t) = srcRowListItem (Label $ mkString l) t + in TypeSynonymDeclaration sa (coerceProperName name) args (srcTypeApp tyRecord $ rowFromList (map toRowListItem mtys, srcREmpty)) typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName 'ClassName - -> [(Text, Maybe Kind)] + -> [(Text, Maybe SourceKind)] -> Declaration -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarationData sa ident ty)) = @@ -260,12 +261,12 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarati in ValueDecl sa ident Private [] $ [MkUnguarded ( TypedValue False (TypeClassDictionaryAccessor className ident) $ - moveQuantifiersToFront (quantify (ConstrainedType (Constraint className (map (TypeVar . fst) args) Nothing) ty)) + moveQuantifiersToFront (quantify (srcConstrainedType (srcConstraint className (map (srcTypeVar . fst) args) Nothing) ty)) )] typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" -unit :: Type -unit = TypeApp tyRecord REmpty +unit :: SourceType +unit = srcTypeApp tyRecord srcREmpty typeInstanceDictionaryDeclaration :: forall m @@ -273,9 +274,9 @@ typeInstanceDictionaryDeclaration => SourceAnn -> Ident -> ModuleName - -> [Constraint] + -> [SourceConstraint] -> Qualified (ProperName 'ClassName) - -> [Type] + -> [SourceType] -> [Declaration] -> Desugar m Declaration typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = @@ -303,20 +304,20 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = -- The dictionary itself is a record literal. let superclasses = superClassDictionaryNames typeClassSuperclasses `zip` [ Abs (VarBinder ss UnusedIdent) (DeferredDictionary superclass tyArgs) - | (Constraint superclass suTyArgs _) <- typeClassSuperclasses + | (Constraint _ superclass suTyArgs _) <- typeClassSuperclasses , let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs ] let props = Literal ss $ ObjectLiteral $ map (first mkString) (members ++ superclasses) - dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys - constrainedTy = quantify (foldr ConstrainedType dictTy deps) + dictTy = foldl srcTypeApp (srcTypeConstructor (fmap coerceProperName className)) tys + constrainedTy = quantify (foldr srcConstrainedType dictTy deps) dict = TypeClassDictionaryConstructorApp className props result = ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)] return result where - memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr + memberToValue :: [(Ident, SourceType)] -> Declaration -> Desugar m Expr memberToValue tys' (ValueDecl (ss', _) ident _ [] [MkUnguarded val]) = do _ <- maybe (throwError . errorMessage' ss' $ ExtraneousClassMember ident className) return $ lookup ident tys' return val @@ -330,8 +331,8 @@ declIdent _ = Nothing typeClassMemberName :: Declaration -> Text typeClassMemberName = fromMaybe (internalError "typeClassMemberName: Invalid declaration in type class definition") . fmap runIdent . declIdent -superClassDictionaryNames :: [Constraint] -> [Text] +superClassDictionaryNames :: [Constraint a] -> [Text] superClassDictionaryNames supers = [ superclassName pn index - | (index, Constraint pn _ _) <- zip [0..] supers + | (index, Constraint _ pn _ _) <- zip [0..] supers ] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 32398ad956..59d38aba82 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -34,7 +34,7 @@ import Language.PureScript.TypeChecker.Synonyms (SynonymMap, replaceAl -- instances were derived in the same way. This data structure is used to ensure -- this property. data NewtypeDerivedInstances = NewtypeDerivedInstances - { ndiClasses :: M.Map (ModuleName, ProperName 'ClassName) ([Text], [Constraint], [FunctionalDependency]) + { ndiClasses :: M.Map (ModuleName, ProperName 'ClassName) ([Text], [SourceConstraint], [FunctionalDependency]) -- ^ A list of superclass constraints for each type class. Since type classes -- have not been desugared here, we need to track this. , ndiDerivedInstances :: S.Set ((ModuleName, ProperName 'ClassName), (ModuleName, ProperName 'TypeName)) @@ -57,11 +57,11 @@ instance Monoid NewtypeDerivedInstances where -- (no flexible instances allowed), we don't need to bother with unification when -- looking for matching superclass instances, which saves us a lot of work. Instead, -- we just match the newtype name. -extractNewtypeName :: ModuleName -> [Type] -> Maybe (ModuleName, ProperName 'TypeName) +extractNewtypeName :: ModuleName -> [SourceType] -> Maybe (ModuleName, ProperName 'TypeName) extractNewtypeName _ [] = Nothing extractNewtypeName mn xs = go (last xs) where - go (TypeApp ty (TypeVar _)) = go ty - go (TypeConstructor name) = Just (qualify mn name) + go (TypeApp _ ty (TypeVar _ _)) = go ty + go (TypeConstructor _ name) = Just (qualify mn name) go _ = Nothing -- | Elaborates deriving instance declarations by code generation. @@ -178,11 +178,11 @@ deriveInstance mn syns ndis ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm dep _ -> throwError . errorMessage' ss $ InvalidNewtypeInstance className tys deriveInstance _ _ _ _ e = return e -unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type]) +unwrapTypeConstructor :: SourceType -> Maybe (Qualified (ProperName 'TypeName), [SourceType]) unwrapTypeConstructor = fmap (second reverse) . go where - go (TypeConstructor tyCon) = Just (tyCon, []) - go (TypeApp ty arg) = do + go (TypeConstructor _ tyCon) = Just (tyCon, []) + go (TypeApp _ ty arg) = do (tyCon, args) <- go ty return (tyCon, arg : args) go _ = Nothing @@ -196,9 +196,9 @@ deriveNewtypeInstance -> NewtypeDerivedInstances -> Qualified (ProperName 'ClassName) -> [Declaration] - -> [Type] + -> [SourceType] -> ProperName 'TypeName - -> [Type] + -> [SourceType] -> m Expr deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do verifySuperclasses @@ -226,9 +226,9 @@ deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do takeReverse :: Int -> [a] -> [a] takeReverse n = take n . reverse - stripRight :: [(Text, Maybe kind)] -> Type -> Maybe Type + stripRight :: [(Text, Maybe kind)] -> SourceType -> Maybe SourceType stripRight [] ty = Just ty - stripRight ((arg, _) : args) (TypeApp t (TypeVar arg')) + stripRight ((arg, _) : args) (TypeApp _ t (TypeVar _ arg')) | arg == arg' = stripRight args t stripRight _ _ = Nothing @@ -246,8 +246,8 @@ deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do -- Everything else raises a UnverifiableSuperclassInstance warning. -- This covers pretty much all cases we're interested in, but later we might want to do -- more work to extend this to other superclass relationships. - let determined = map (TypeVar . (args !!)) . ordNub . concatMap fdDetermined . filter ((== [length args - 1]) . fdDeterminers) $ deps - if last constraintArgs == TypeVar (last args) && all (`elem` determined) (init constraintArgs) + let determined = map (srcTypeVar . (args !!)) . ordNub . concatMap fdDetermined . filter ((== [length args - 1]) . fdDeterminers) $ deps + if eqType (last constraintArgs) (srcTypeVar (last args)) && all (`elem` determined) (init constraintArgs) then do -- Now make sure that a superclass instance was derived. Again, this is not a complete -- check, since the superclass might have multiple type arguments, so overlaps might still @@ -283,14 +283,14 @@ deriveGenericRep -> SynonymMap -> [Declaration] -> ProperName 'TypeName - -> [Type] - -> Type - -> m ([Declaration], Type) + -> [SourceType] + -> SourceType + -> m ([Declaration], SourceType) deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do checkIsWildcard ss tyConNm repTy go =<< findTypeDecl ss tyConNm ds where - go :: Declaration -> m ([Declaration], Type) + go :: Declaration -> m ([Declaration], SourceType) go (DataDeclaration (ss', _) _ _ args dctors) = do x <- freshIdent "x" (reps, to, from) <- unzip3 <$> traverse makeInst dctors @@ -337,13 +337,13 @@ deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do compN n f = f . compN (n - 1) f makeInst - :: (ProperName 'ConstructorName, [Type]) - -> m (Type, CaseAlternative, CaseAlternative) + :: (ProperName 'ConstructorName, [SourceType]) + -> m (SourceType, CaseAlternative, CaseAlternative) makeInst (ctorName, args) = do args' <- mapM (replaceAllTypeSynonymsM syns) args (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args' - return ( TypeApp (TypeApp (TypeConstructor constructor) - (TypeLevelString $ mkString (runProperName ctorName))) + return ( srcTypeApp (srcTypeApp (srcTypeConstructor constructor) + (srcTypeLevelString $ mkString (runProperName ctorName))) ctorTy , CaseAlternative [ ConstructorBinder ss constructor [matchProduct] ] (unguarded (foldl' App (Constructor ss (Qualified (Just mn) ctorName)) ctorArgs)) @@ -352,23 +352,23 @@ deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do ) makeProduct - :: [Type] - -> m (Type, Binder, [Expr], [Binder], Expr) + :: [SourceType] + -> m (SourceType, Binder, [Expr], [Binder], Expr) makeProduct [] = pure (noArgs, NullBinder, [], [], noArgs') makeProduct args = do (tys, bs1, es1, bs2, es2) <- unzip5 <$> traverse makeArg args - pure ( foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) tys + pure ( foldr1 (\f -> srcTypeApp (srcTypeApp (srcTypeConstructor productName) f)) tys , foldr1 (\b1 b2 -> ConstructorBinder ss productName [b1, b2]) bs1 , es1 , bs2 , foldr1 (\e1 -> App (App (Constructor ss productName) e1)) es2 ) - makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr) + makeArg :: SourceType -> m (SourceType, Binder, Expr, Binder, Expr) makeArg arg = do argName <- freshIdent "arg" - pure ( TypeApp (TypeConstructor argument) arg + pure ( srcTypeApp (srcTypeConstructor argument) arg , ConstructorBinder ss argument [ VarBinder ss argName ] , Var ss (Qualified Nothing argName) , VarBinder ss argName @@ -382,10 +382,10 @@ deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do underExpr f (CaseAlternative b [MkUnguarded e]) = CaseAlternative b (unguarded (f e)) underExpr _ _ = internalError "underExpr: expected unguarded alternative" - toRepTy :: [Type] -> Type + toRepTy :: [SourceType] -> SourceType toRepTy [] = noCtors toRepTy [only] = only - toRepTy ctors = foldr1 (\f -> TypeApp (TypeApp sumCtor f)) ctors + toRepTy ctors = foldr1 (\f -> srcTypeApp (srcTypeApp sumCtor f)) ctors toName :: Expr toName = Var ss (Qualified (Just dataGenericRep) (Ident "to")) @@ -393,17 +393,17 @@ deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do fromName :: Expr fromName = Var ss (Qualified (Just dataGenericRep) (Ident "from")) - noCtors :: Type - noCtors = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoConstructors")) + noCtors :: SourceType + noCtors = srcTypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoConstructors")) - noArgs :: Type - noArgs = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoArguments")) + noArgs :: SourceType + noArgs = srcTypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoArguments")) noArgs' :: Expr noArgs' = Constructor ss (Qualified (Just dataGenericRep) (ProperName "NoArguments")) - sumCtor :: Type - sumCtor = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "Sum")) + sumCtor :: SourceType + sumCtor = srcTypeConstructor (Qualified (Just dataGenericRep) (ProperName "Sum")) inl :: Qualified (ProperName 'ConstructorName) inl = Qualified (Just dataGenericRep) (ProperName "Inl") @@ -426,7 +426,7 @@ deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do argument' :: Expr -> Expr argument' = App (Constructor ss argument) -checkIsWildcard :: MonadError MultipleErrors m => SourceSpan -> ProperName 'TypeName -> Type -> m () +checkIsWildcard :: MonadError MultipleErrors m => SourceSpan -> ProperName 'TypeName -> SourceType -> m () checkIsWildcard _ _ (TypeWildcard _) = return () checkIsWildcard ss tyConNm _ = throwError . errorMessage' ss $ ExpectedWildcard tyConNm @@ -468,7 +468,7 @@ deriveEq ss mn syns ds tyConNm = do where catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (Literal ss (BooleanLiteral False))) - mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative + mkCtorClause :: (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative mkCtorClause (ctorName, tys) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") @@ -482,7 +482,7 @@ deriveEq ss mn syns ds tyConNm = do conjAll [] = Literal ss (BooleanLiteral True) conjAll xs = foldl1 preludeConj xs - toEqTest :: Expr -> Expr -> Type -> Expr + toEqTest :: Expr -> Expr -> SourceType -> Expr toEqTest l r ty | Just rec <- objectType ty , Just fields <- decomposeRec rec = @@ -547,7 +547,7 @@ deriveOrd ss mn syns ds tyConNm = do ordCompare1 :: Expr -> Expr -> Expr ordCompare1 = App . App (Var ss (Qualified (Just dataOrd) (Ident C.compare1))) - mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative] + mkCtorClauses :: ((ProperName 'ConstructorName, [SourceType]), Bool) -> m [CaseAlternative] mkCtorClauses ((ctorName, tys), isLast) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") @@ -583,7 +583,7 @@ deriveOrd ss mn syns ds tyConNm = do (unguarded (appendAll xs)) ] - toOrdering :: Expr -> Expr -> Type -> Expr + toOrdering :: Expr -> Expr -> SourceType -> Expr toOrdering l r ty | Just rec <- objectType ty , Just fields <- decomposeRec rec = @@ -608,14 +608,14 @@ deriveNewtype -> SynonymMap -> [Declaration] -> ProperName 'TypeName - -> [Type] - -> Type - -> m ([Declaration], Type) + -> [SourceType] + -> SourceType + -> m ([Declaration], SourceType) deriveNewtype ss mn syns ds tyConNm tyConArgs unwrappedTy = do checkIsWildcard ss tyConNm unwrappedTy go =<< findTypeDecl ss tyConNm ds where - go :: Declaration -> m ([Declaration], Type) + go :: Declaration -> m ([Declaration], SourceType) go (DataDeclaration (ss', _) Data name _ _) = throwError . errorMessage' ss' $ CannotDeriveNewtypeForData name go (DataDeclaration (ss', _) Newtype name args dctors) = do @@ -665,23 +665,23 @@ mkVarMn ss mn = Var ss . Qualified mn mkVar :: SourceSpan -> Ident -> Expr mkVar ss = mkVarMn ss Nothing -isAppliedVar :: Type -> Bool -isAppliedVar (TypeApp (TypeVar _) _) = True +isAppliedVar :: Type a -> Bool +isAppliedVar (TypeApp _ (TypeVar _ _) _) = True isAppliedVar _ = False -objectType :: Type -> Maybe Type -objectType (TypeApp (TypeConstructor C.Record) rec) = Just rec +objectType :: Type a -> Maybe (Type a) +objectType (TypeApp _ (TypeConstructor _ C.Record) rec) = Just rec objectType _ = Nothing -decomposeRec :: Type -> Maybe [(Label, Type)] +decomposeRec :: SourceType -> Maybe [(Label, SourceType)] decomposeRec = fmap (sortBy (comparing fst)) . go - where go (RCons str typ typs) = fmap ((str, typ) :) (go typs) - go REmpty = Just [] + where go (RCons _ str typ typs) = fmap ((str, typ) :) (go typs) + go (REmpty _) = Just [] go _ = Nothing -decomposeRec' :: Type -> [(Label, Type)] +decomposeRec' :: SourceType -> [(Label, SourceType)] decomposeRec' = sortBy (comparing fst) . go - where go (RCons str typ typs) = (str, typ) : go typs + where go (RCons _ str typ typs) = (str, typ) : go typs go _ = [] deriveFunctor @@ -700,14 +700,14 @@ deriveFunctor ss mn syns ds tyConNm = do where mkMapFunction :: Declaration -> m Expr mkMapFunction (DataDeclaration (ss', _) _ _ tys ctors) = case reverse tys of - [] -> throwError . errorMessage' ss' $ KindsDoNotUnify (FunKind kindType kindType) kindType + [] -> throwError . errorMessage' ss' $ KindsDoNotUnify (FunKind nullSourceAnn kindType kindType) kindType ((iTy, _) : _) -> do f <- freshIdent "f" m <- freshIdent "m" lam ss' f . lamCase ss' m <$> mapM (mkCtorClause iTy f) ctors mkMapFunction _ = internalError "mkMapFunction: expected DataDeclaration" - mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [Type]) -> m CaseAlternative + mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative mkCtorClause iTyName f (ctorName, ctorTys) = do idents <- replicateM (length ctorTys) (freshIdent "v") ctorTys' <- mapM (replaceAllTypeSynonymsM syns) ctorTys @@ -721,12 +721,12 @@ deriveFunctor ss mn syns ds tyConNm = do mapVar = mkVarMn ss (Just dataFunctor) (Ident C.map) -- TODO: deal with type synonyms, ala https://github.com/purescript/purescript/pull/2516 - transformArg :: Ident -> Type -> m Expr + transformArg :: Ident -> SourceType -> m Expr transformArg ident = fmap (foldr App (mkVar ss ident)) . goType where - goType :: Type -> m (Maybe Expr) + goType :: SourceType -> m (Maybe Expr) -- argument matches the index type - goType (TypeVar t) | t == iTyName = return (Just fVar) + goType (TypeVar _ t) | t == iTyName = return (Just fVar) -- records goType recTy | Just row <- objectType recTy = @@ -735,7 +735,7 @@ deriveFunctor ss mn syns ds tyConNm = do justUpdates :: [Maybe (Label, Expr)] -> Maybe [(Label, Expr)] justUpdates = foldMap (fmap return) - buildUpdate :: (Label, Type) -> m (Maybe (Label, Expr)) + buildUpdate :: (Label, SourceType) -> m (Maybe (Label, Expr)) buildUpdate (lbl, ty) = do upd <- goType ty return ((lbl,) <$> upd) @@ -747,13 +747,13 @@ deriveFunctor ss mn syns ds tyConNm = do return (lam ss arg (ObjectUpdate argVar (mkAssignment <$> updates))) -- quantifiers - goType (ForAll scopedVar t _) | scopedVar /= iTyName = goType t + goType (ForAll _ scopedVar t _) | scopedVar /= iTyName = goType t -- constraints - goType (ConstrainedType _ t) = goType t + goType (ConstrainedType _ _ t) = goType t -- under a `* -> *`, just assume functor for now - goType (TypeApp _ t) = fmap (App mapVar) <$> goType t + goType (TypeApp _ _ t) = fmap (App mapVar) <$> goType t -- otherwise do nothing - will fail type checking if type does actually contain index goType _ = return Nothing diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 90e7917514..ed4272656c 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -48,9 +48,9 @@ addDataType => ModuleName -> DataDeclType -> ProperName 'TypeName - -> [(Text, Maybe Kind)] - -> [(ProperName 'ConstructorName, [Type])] - -> Kind + -> [(Text, Maybe SourceKind)] + -> [(ProperName 'ConstructorName, [SourceType])] + -> SourceKind -> m () addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv @@ -66,14 +66,14 @@ addDataConstructor -> ProperName 'TypeName -> [Text] -> ProperName 'ConstructorName - -> [Type] + -> [SourceType] -> m () addDataConstructor moduleName dtype name args dctor tys = do env <- getEnv traverse_ checkTypeSynonyms tys - let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args) + let retTy = foldl srcTypeApp (srcTypeConstructor (Qualified (Just moduleName) name)) (map srcTypeVar args) let dctorTy = foldr function retTy tys - let polyType = mkForAll args dctorTy + let polyType = mkForAll (map (NullSourceAnn,) args) dctorTy let fields = [Ident ("value" <> T.pack (show n)) | n <- [0..(length tys - 1)]] putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } @@ -81,9 +81,9 @@ addTypeSynonym :: (MonadState CheckState m, MonadError MultipleErrors m) => ModuleName -> ProperName 'TypeName - -> [(Text, Maybe Kind)] - -> Type - -> Kind + -> [(Text, Maybe SourceKind)] + -> SourceType + -> SourceKind -> m () addTypeSynonym moduleName name args ty kind = do env <- getEnv @@ -106,7 +106,7 @@ addValue :: (MonadState CheckState m) => ModuleName -> Ident - -> Type + -> SourceType -> NameKind -> m () addValue moduleName name ty nameKind = do @@ -117,8 +117,8 @@ addTypeClass :: forall m . (MonadState CheckState m, MonadError MultipleErrors m) => Qualified (ProperName 'ClassName) - -> [(Text, Maybe Kind)] - -> [Constraint] + -> [(Text, Maybe SourceKind)] + -> [SourceConstraint] -> [FunctionalDependency] -> [Declaration] -> m () @@ -127,7 +127,7 @@ addTypeClass qualifiedClassName args implies dependencies ds = do traverse_ (checkMemberIsUsable (typeSynonyms env)) classMembers modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert qualifiedClassName newClass (typeClasses . checkEnv $ st) } } where - classMembers :: [(Ident, Type)] + classMembers :: [(Ident, SourceType)] classMembers = map toPair ds newClass :: TypeClassData @@ -145,7 +145,7 @@ addTypeClass qualifiedClassName args implies dependencies ds = do -- Currently we are only checking usability based on the type class currently -- being defined. If the mentioned arguments don't include a covering set, -- then we won't be able to find a instance. - checkMemberIsUsable :: T.SynonymMap -> (Ident, Type) -> m () + checkMemberIsUsable :: T.SynonymMap -> (Ident, SourceType) -> m () checkMemberIsUsable syns (ident, memberTy) = do memberTy' <- T.replaceAllTypeSynonymsM syns memberTy let mentionedArgIndexes = S.fromList (mapMaybe argToIndex (freeTypeVariables memberTy')) @@ -180,7 +180,7 @@ checkTypeClassInstance :: (MonadState CheckState m, MonadError MultipleErrors m) => TypeClassData -> Int -- ^ index of type class argument - -> Type + -> SourceType -> m () checkTypeClassInstance cls i = check where -- If the argument is determined via fundeps then we are less restrictive in @@ -189,15 +189,15 @@ checkTypeClassInstance cls i = check where -- row types are allowed in determined type class arguments. isFunDepDetermined = S.member i (typeClassDeterminedArguments cls) check = \case - TypeVar _ -> return () - TypeLevelString _ -> return () - TypeConstructor ctor -> do + TypeVar _ _ -> return () + TypeLevelString _ _ -> return () + TypeConstructor _ ctor -> do env <- getEnv when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance return () - TypeApp t1 t2 -> check t1 >> check t2 - REmpty | isFunDepDetermined -> return () - RCons _ hd tl | isFunDepDetermined -> check hd >> check tl + TypeApp _ t1 t2 -> check t1 >> check t2 + REmpty _ | isFunDepDetermined -> return () + RCons _ _ hd tl | isFunDepDetermined -> check hd >> check tl ty -> throwError . errorMessage $ InvalidInstanceHead ty -- | @@ -205,7 +205,7 @@ checkTypeClassInstance cls i = check where -- checkTypeSynonyms :: (MonadState CheckState m, MonadError MultipleErrors m) - => Type + => SourceType -> m () checkTypeSynonyms = void . replaceAllTypeSynonyms @@ -346,7 +346,7 @@ typeCheckAll moduleName _ = traverse go addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict) return d - checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m () + checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [SourceType] -> m () checkInstanceArity dictName className typeClass tys = do let typeClassArity = length (typeClassArguments typeClass) instanceArity = length tys @@ -373,19 +373,19 @@ typeCheckAll moduleName _ = traverse go findNonOrphanModules :: Qualified (ProperName 'ClassName) -> TypeClassData - -> [Type] + -> [SourceType] -> S.Set ModuleName findNonOrphanModules (Qualified (Just mn') _) typeClass tys' = nonOrphanModules where nonOrphanModules :: S.Set ModuleName nonOrphanModules = S.insert mn' nonOrphanModules' - typeModule :: Type -> Maybe ModuleName - typeModule (TypeVar _) = Nothing - typeModule (TypeLevelString _) = Nothing - typeModule (TypeConstructor (Qualified (Just mn'') _)) = Just mn'' - typeModule (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in findNonOrphanModules" - typeModule (TypeApp t1 _) = typeModule t1 + typeModule :: SourceType -> Maybe ModuleName + typeModule (TypeVar _ _) = Nothing + typeModule (TypeLevelString _ _) = Nothing + typeModule (TypeConstructor _ (Qualified (Just mn'') _)) = Just mn'' + typeModule (TypeConstructor _ (Qualified Nothing _)) = internalError "Unqualified type name in findNonOrphanModules" + typeModule (TypeApp _ t1 _) = typeModule t1 typeModule _ = internalError "Invalid type in instance in findNonOrphanModules" modulesByTypeIndex :: M.Map Int (Maybe ModuleName) @@ -415,7 +415,7 @@ typeCheckAll moduleName _ = traverse go -> Ident -> Qualified (ProperName 'ClassName) -> TypeClassData - -> [Type] + -> [SourceType] -> S.Set ModuleName -> m () checkOverlappingInstance ch dictName className typeClass tys' nonOrphanModules = do @@ -435,8 +435,8 @@ typeCheckAll moduleName _ = traverse go instancesAreApart :: S.Set (S.Set Int) - -> [Type] - -> [Type] + -> [SourceType] + -> [SourceType] -> Bool instancesAreApart sets lhs rhs = all (any typesApart . S.toList) (S.toList sets) where @@ -445,19 +445,19 @@ typeCheckAll moduleName _ = traverse go -- Note: implementation doesn't need to care about all possible cases: -- TUnknown, Skolem, etc. - typeHeadsApart :: Type -> Type -> Bool - typeHeadsApart l r | l == r = False - typeHeadsApart (TypeVar _) _ = False - typeHeadsApart _ (TypeVar _) = False - typeHeadsApart (KindedType t1 _) t2 = typeHeadsApart t1 t2 - typeHeadsApart t1 (KindedType t2 _) = typeHeadsApart t1 t2 - typeHeadsApart (TypeApp h1 t1) (TypeApp h2 t2) = typeHeadsApart h1 h2 || typeHeadsApart t1 t2 - typeHeadsApart _ _ = True + typeHeadsApart :: SourceType -> SourceType -> Bool + typeHeadsApart l r | eqType l r = False + typeHeadsApart (TypeVar _ _) _ = False + typeHeadsApart _ (TypeVar _ _) = False + typeHeadsApart (KindedType _ t1 _) t2 = typeHeadsApart t1 t2 + typeHeadsApart t1 (KindedType _ t2 _) = typeHeadsApart t1 t2 + typeHeadsApart (TypeApp _ h1 t1) (TypeApp _ h2 t2) = typeHeadsApart h1 h2 || typeHeadsApart t1 t2 + typeHeadsApart _ _ = True checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) - -> [Type] + -> [SourceType] -> S.Set ModuleName -> m () checkOrphanInstance dictName className tys' nonOrphanModules @@ -468,17 +468,17 @@ typeCheckAll moduleName _ = traverse go -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, -- extracted from the kind of the type constructor itself. -- - withKinds :: [(Text, Maybe Kind)] -> Kind -> [(Text, Maybe Kind)] + withKinds :: [(Text, Maybe SourceKind)] -> SourceKind -> [(Text, Maybe SourceKind)] withKinds [] _ = [] - withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k - withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2 - withKinds _ _ = internalError "Invalid arguments to peelKinds" + withKinds (s@(_, Just _ ):ss) (FunKind _ _ k) = s : withKinds ss k + withKinds ( (s, Nothing):ss) (FunKind _ k1 k2) = (s, Just k1) : withKinds ss k2 + withKinds _ _ = internalError "Invalid arguments to peelKinds" checkNewtype :: forall m . MonadError MultipleErrors m => ProperName 'TypeName - -> [(ProperName 'ConstructorName, [Type])] + -> [(ProperName 'ConstructorName, [SourceType])] -> m () checkNewtype _ [(_, [_])] = return () checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name @@ -544,12 +544,12 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = untilSame :: Eq a => (a -> a) -> a -> a untilSame f a = let a' = f a in if a == a' then a else untilSame f a' - checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m () + checkMemberExport :: (SourceType -> [DeclarationRef]) -> DeclarationRef -> m () checkMemberExport extract dr@(TypeRef _ name dctors) = do env <- getEnv for_ (M.lookup (qualify' name) (types env)) $ \(k, _) -> do let findModuleKinds = everythingOnKinds (++) $ \case - NamedKind (Qualified (Just mn') kindName) | mn' == mn -> [kindName] + NamedKind _ (Qualified (Just mn') kindName) | mn' == mn -> [kindName] _ -> [] checkExport dr $ KindRef (declRefSourceSpan dr) <$> findModuleKinds k for_ (M.lookup (qualify' name) (typeSynonyms env)) $ \(_, ty) -> @@ -606,10 +606,10 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = checkTypesAreExported :: DeclarationRef -> m () checkTypesAreExported ref = checkMemberExport findTcons ref where - findTcons :: Type -> [DeclarationRef] + findTcons :: SourceType -> [DeclarationRef] findTcons = everythingOnTypes (++) go where - go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = + go (TypeConstructor _ (Qualified (Just mn') name)) | mn' == mn = [TypeRef (declRefSourceSpan ref) name (internalError "Data constructors unused in checkTypesAreExported")] go _ = [] @@ -618,10 +618,10 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = checkClassesAreExported :: DeclarationRef -> m () checkClassesAreExported ref = checkMemberExport findClasses ref where - findClasses :: Type -> [DeclarationRef] + findClasses :: SourceType -> [DeclarationRef] findClasses = everythingOnTypes (++) go where - go (ConstrainedType c _) = (fmap (TypeClassRef (declRefSourceSpan ref)) . extractCurrentModuleClass . constraintClass) c + go (ConstrainedType _ c _) = (fmap (TypeClassRef (declRefSourceSpan ref)) . extractCurrentModuleClass . constraintClass) c go _ = [] extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> [ProperName 'ClassName] extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = [name] diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 2f5e754ebe..23f62f9e34 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -51,7 +51,7 @@ data Evidence = NamedInstance (Qualified Ident) -- | Computed instances - | WarnInstance Type -- ^ Warn type class with a user-defined warning message + | WarnInstance SourceType -- ^ Warn type class with a user-defined warning message | IsSymbolInstance PSString -- ^ The IsSymbol type class for a given Symbol literal | EmptyClassInstance -- ^ For any solved type class with no members deriving (Show, Eq) @@ -84,7 +84,7 @@ replaceTypeClassDictionaries . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => Bool -> Expr - -> m (Expr, [(Ident, InstanceContext, Constraint)]) + -> m (Expr, [(Ident, InstanceContext, SourceConstraint)]) replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ do -- Loop, deferring any unsolved constraints, until there are no more -- constraints which can be solved, then make a generalization pass. @@ -98,16 +98,16 @@ replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ d -- This pass solves constraints where possible, deferring constraints if not. deferPass :: Expr -> StateT InstanceContext m (Expr, Any) deferPass = fmap (second fst) . runWriterT . f where - f :: Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr + f :: Expr -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr (_, f, _) = everywhereOnValuesTopDownM return (go True) return -- This pass generalizes any remaining constraints - generalizePass :: Expr -> StateT InstanceContext m (Expr, [(Ident, InstanceContext, Constraint)]) + generalizePass :: Expr -> StateT InstanceContext m (Expr, [(Ident, InstanceContext, SourceConstraint)]) generalizePass = fmap (second snd) . runWriterT . f where - f :: Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr + f :: Expr -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr (_, f, _) = everywhereOnValuesTopDownM return (go False) return - go :: Bool -> Expr -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr + go :: Bool -> Expr -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr go deferErrors (TypeClassDictionary constraint context hints) = rethrow (addHints hints) $ entails (SolverOptions shouldGeneralize deferErrors) constraint context hints go _ other = return other @@ -116,7 +116,7 @@ replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ d data EntailsResult a = Solved a TypeClassDict -- ^ We solved this constraint - | Unsolved Constraint + | Unsolved SourceConstraint -- ^ We couldn't solve this constraint right now, it will be generalized | Deferred -- ^ We couldn't solve this constraint right now, so it has been deferred @@ -152,17 +152,17 @@ entails . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => SolverOptions -- ^ Solver options - -> Constraint + -> SourceConstraint -- ^ The constraint to solve -> InstanceContext -- ^ The contexts in which to solve the constraint -> [ErrorMessageHint] -- ^ Error message hints to apply to any instance errors - -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr + -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr entails SolverOptions{..} constraint context hints = solve constraint where - forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict] + forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [TypeClassDict] forClassName ctx cn@C.Warn [msg] = -- Prefer a warning dictionary in scope if there is one available. -- This allows us to defer a warning by propagating the constraint. @@ -179,11 +179,11 @@ entails SolverOptions{..} constraint context hints = forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) forClassName _ _ _ = internalError "forClassName: expected qualified class name" - ctorModules :: Type -> Maybe ModuleName - ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn - ctorModules (TypeConstructor (Qualified Nothing _)) = internalError "ctorModules: unqualified type name" - ctorModules (TypeApp ty _) = ctorModules ty - ctorModules (KindedType ty _) = ctorModules ty + ctorModules :: SourceType -> Maybe ModuleName + ctorModules (TypeConstructor _ (Qualified (Just mn) _)) = Just mn + ctorModules (TypeConstructor _ (Qualified Nothing _)) = internalError "ctorModules: unqualified type name" + ctorModules (TypeApp _ ty _) = ctorModules ty + ctorModules (KindedType _ ty _) = ctorModules ty ctorModules _ = Nothing findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDict] @@ -192,12 +192,12 @@ entails SolverOptions{..} constraint context hints = valUndefined :: Expr valUndefined = Var nullSourceSpan (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) - solve :: Constraint -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr + solve :: SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr solve con = go 0 con where - go :: Int -> Constraint -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) Expr - go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' - go work con'@(Constraint className' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do + go :: Int -> SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr + go work (Constraint _ className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' + go work con'@(Constraint _ className' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do -- We might have unified types by solving other constraints, so we need to -- apply the latest substitution. latestSubst <- lift . lift $ gets checkSubstitution @@ -265,7 +265,7 @@ entails SolverOptions{..} constraint context hints = Deferred -> -- Constraint was deferred, just return the dictionary unchanged, -- with no unsolved constraints. Hopefully, we can solve this later. - return (TypeClassDictionary (Constraint className' tys'' conInfo) context hints) + return (TypeClassDictionary (srcConstraint className' tys'' conInfo) context hints) where -- | When checking functional dependencies, we need to use unification to make -- sure it is safe to use the selected instance. We will unify the solved type with @@ -280,8 +280,8 @@ entails SolverOptions{..} constraint context hints = -- as necessary, based on the types in the instance head. withFreshTypes :: TypeClassDict - -> Matching Type - -> m (Matching Type) + -> Matching SourceType + -> m (Matching SourceType) withFreshTypes TypeClassDictionaryInScope{..} subst = do let onType = everythingOnTypes S.union fromTypeVar typeVarsInHead = foldMap onType tcdInstanceTypes @@ -291,29 +291,29 @@ entails SolverOptions{..} constraint context hints = newSubst <- traverse withFreshType (S.toList uninstantiatedTypeVars) return (subst <> M.fromList newSubst) where - fromTypeVar (TypeVar v) = S.singleton v + fromTypeVar (TypeVar _ v) = S.singleton v fromTypeVar _ = S.empty withFreshType s = do t <- freshType return (s, t) - unique :: [Type] -> [(a, TypeClassDict)] -> m (EntailsResult a) + unique :: [SourceType] -> [(a, TypeClassDict)] -> m (EntailsResult a) unique tyArgs [] | solverDeferErrors = return Deferred -- We need a special case for nullary type classes, since we want -- to generalize over Partial constraints. - | solverShouldGeneralize && (null tyArgs || any canBeGeneralized tyArgs) = return (Unsolved (Constraint className' tyArgs conInfo)) - | otherwise = throwError . errorMessage $ NoInstanceFound (Constraint className' tyArgs conInfo) + | solverShouldGeneralize && (null tyArgs || any canBeGeneralized tyArgs) = return (Unsolved (srcConstraint className' tyArgs conInfo)) + | otherwise = throwError . errorMessage $ NoInstanceFound (srcConstraint className' tyArgs conInfo) unique _ [(a, dict)] = return $ Solved a dict unique tyArgs tcds | pairwiseAny overlapping (map snd tcds) = throwError . errorMessage $ OverlappingInstances className' tyArgs (tcds >>= (toList . namedInstanceIdentifier . tcdValue . snd)) | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds) - canBeGeneralized :: Type -> Bool + canBeGeneralized :: Type a -> Bool canBeGeneralized TUnknown{} = True - canBeGeneralized (KindedType t _) = canBeGeneralized t + canBeGeneralized (KindedType _ t _) = canBeGeneralized t canBeGeneralized _ = False -- | @@ -331,7 +331,7 @@ entails SolverOptions{..} constraint context hints = -- Create dictionaries for subgoals which still need to be solved by calling go recursively -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively. - solveSubgoals :: Matching Type -> Maybe [Constraint] -> WriterT (Any, [(Ident, InstanceContext, Constraint)]) (StateT InstanceContext m) (Maybe [Expr]) + solveSubgoals :: Matching SourceType -> Maybe [SourceConstraint] -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) (Maybe [Expr]) solveSubgoals _ Nothing = return Nothing solveSubgoals subst (Just subgoals) = Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals @@ -360,21 +360,21 @@ entails SolverOptions{..} constraint context hints = subclassDictionaryValue dict className index = App (Accessor (mkString (superclassName className index)) dict) valUndefined - solveIsSymbol :: [Type] -> Maybe [TypeClassDict] - solveIsSymbol [TypeLevelString sym] = Just [TypeClassDictionaryInScope [] 0 (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing] + solveIsSymbol :: [SourceType] -> Maybe [TypeClassDict] + solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope [] 0 (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString ann sym] Nothing] solveIsSymbol _ = Nothing - solveSymbolCompare :: [Type] -> Maybe [TypeClassDict] - solveSymbolCompare [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = + solveSymbolCompare :: [SourceType] -> Maybe [TypeClassDict] + solveSymbolCompare [arg0@(TypeLevelString _ lhs), arg1@(TypeLevelString _ rhs), _] = let ordering = case compare lhs rhs of LT -> C.orderingLT EQ -> C.orderingEQ GT -> C.orderingGT - args' = [arg0, arg1, TypeConstructor ordering] + args' = [arg0, arg1, srcTypeConstructor ordering] in Just [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolCompare args' Nothing] solveSymbolCompare _ = Nothing - solveSymbolAppend :: [Type] -> Maybe [TypeClassDict] + solveSymbolAppend :: [SourceType] -> Maybe [TypeClassDict] solveSymbolAppend [arg0, arg1, arg2] = do (arg0', arg1', arg2') <- appendSymbols arg0 arg1 arg2 let args' = [arg0', arg1', arg2'] @@ -382,126 +382,127 @@ entails SolverOptions{..} constraint context hints = solveSymbolAppend _ = Nothing -- | Append type level symbols, or, run backwards, strip a prefix or suffix - appendSymbols :: Type -> Type -> Type -> Maybe (Type, Type, Type) - appendSymbols arg0@(TypeLevelString lhs) arg1@(TypeLevelString rhs) _ = Just (arg0, arg1, TypeLevelString (lhs <> rhs)) - appendSymbols arg0@(TypeLevelString lhs) _ arg2@(TypeLevelString out) = do + appendSymbols :: SourceType -> SourceType -> SourceType -> Maybe (SourceType, SourceType, SourceType) + appendSymbols arg0@(TypeLevelString _ lhs) arg1@(TypeLevelString _ rhs) _ = Just (arg0, arg1, srcTypeLevelString (lhs <> rhs)) + appendSymbols arg0@(TypeLevelString _ lhs) _ arg2@(TypeLevelString _ out) = do lhs' <- decodeString lhs out' <- decodeString out rhs <- stripPrefix lhs' out' - pure (arg0, TypeLevelString (mkString rhs), arg2) - appendSymbols _ arg1@(TypeLevelString rhs) arg2@(TypeLevelString out) = do + pure (arg0, srcTypeLevelString (mkString rhs), arg2) + appendSymbols _ arg1@(TypeLevelString _ rhs) arg2@(TypeLevelString _ out) = do rhs' <- decodeString rhs out' <- decodeString out lhs <- stripSuffix rhs' out' - pure (TypeLevelString (mkString lhs), arg1, arg2) + pure (srcTypeLevelString (mkString lhs), arg1, arg2) appendSymbols _ _ _ = Nothing - solveSymbolCons :: [Type] -> Maybe [TypeClassDict] + solveSymbolCons :: [SourceType] -> Maybe [TypeClassDict] solveSymbolCons [arg0, arg1, arg2] = do (arg0', arg1', arg2') <- consSymbol arg0 arg1 arg2 let args' = [arg0', arg1', arg2'] pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolCons args' Nothing] solveSymbolCons _ = Nothing - consSymbol :: Type -> Type -> Type -> Maybe (Type, Type, Type) - consSymbol _ _ arg@(TypeLevelString s) = do + consSymbol :: SourceType -> SourceType -> SourceType -> Maybe (SourceType, SourceType, SourceType) + consSymbol _ _ arg@(TypeLevelString _ s) = do (h, t) <- T.uncons =<< decodeString s pure (mkTLString (T.singleton h), mkTLString t, arg) - where mkTLString = TypeLevelString . mkString - consSymbol arg1@(TypeLevelString h) arg2@(TypeLevelString t) _ = do + where mkTLString = srcTypeLevelString . mkString + consSymbol arg1@(TypeLevelString _ h) arg2@(TypeLevelString _ t) _ = do h' <- decodeString h t' <- decodeString t guard (T.length h' == 1) - pure (arg1, arg2, TypeLevelString (mkString $ h' <> t')) + pure (arg1, arg2, srcTypeLevelString (mkString $ h' <> t')) consSymbol _ _ _ = Nothing - solveUnion :: [Type] -> Maybe [TypeClassDict] + solveUnion :: [SourceType] -> Maybe [TypeClassDict] solveUnion [l, r, u] = do (lOut, rOut, uOut, cst) <- unionRows l r u pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowUnion [lOut, rOut, uOut] cst ] solveUnion _ = Nothing -- | Left biased union of two row types - unionRows :: Type -> Type -> Type -> Maybe (Type, Type, Type, Maybe [Constraint]) + unionRows :: SourceType -> SourceType -> SourceType -> Maybe (SourceType, SourceType, SourceType, Maybe [SourceConstraint]) unionRows l r _ = guard canMakeProgress $> (l, r, rowFromList out, cons) where (fixed, rest) = rowToList l - rowVar = TypeVar "r" + rowVar = srcTypeVar "r" (canMakeProgress, out, cons) = case rest of -- If the left hand side is a closed row, then we can merge -- its labels into the right hand side. - REmpty -> (True, (fixed, r), Nothing) + REmpty _ -> (True, (fixed, r), Nothing) -- If the left hand side is not definitely closed, then the only way we -- can safely make progress is to move any known labels from the left -- input into the output, and add a constraint for any remaining labels. -- Otherwise, the left hand tail might contain the same labels as on -- the right hand side, and we can't be certain we won't reorder the -- types for such labels. - _ -> (not (null fixed), (fixed, rowVar), Just [ Constraint C.RowUnion [rest, r, rowVar] Nothing ]) + _ -> (not (null fixed), (fixed, rowVar), Just [ srcConstraint C.RowUnion [rest, r, rowVar] Nothing ]) - solveRowCons :: [Type] -> Maybe [TypeClassDict] - solveRowCons [TypeLevelString sym, ty, r, _] = - Just [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowCons [TypeLevelString sym, ty, r, RCons (Label sym) ty r] Nothing ] + solveRowCons :: [SourceType] -> Maybe [TypeClassDict] + solveRowCons [TypeLevelString ann sym, ty, r, _] = + Just [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowCons [TypeLevelString ann sym, ty, r, srcRCons (Label sym) ty r] Nothing ] solveRowCons _ = Nothing - solveRowToList :: [Type] -> Maybe [TypeClassDict] + solveRowToList :: [SourceType] -> Maybe [TypeClassDict] solveRowToList [r, _] = do entries <- rowToRowList r pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowToList [r, entries] Nothing ] solveRowToList _ = Nothing -- | Convert a closed row to a sorted list of entries - rowToRowList :: Type -> Maybe Type + rowToRowList :: SourceType -> Maybe SourceType rowToRowList r = - guard (REmpty == rest) $> - foldr rowListCons (TypeConstructor C.RowListNil) fixed + guard (eqType rest $ REmpty ()) $> + foldr rowListCons (srcTypeConstructor C.RowListNil) fixed where (fixed, rest) = rowToSortedList r - rowListCons (lbl, ty) tl = foldl TypeApp (TypeConstructor C.RowListCons) - [ TypeLevelString (runLabel lbl) - , ty - , tl ] + rowListCons (RowListItem _ lbl ty) tl = + foldl srcTypeApp (srcTypeConstructor C.RowListCons) + [ srcTypeLevelString (runLabel lbl) + , ty + , tl ] - solveNub :: [Type] -> Maybe [TypeClassDict] + solveNub :: [SourceType] -> Maybe [TypeClassDict] solveNub [r, _] = do r' <- nubRows r pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowNub [r, r'] Nothing ] solveNub _ = Nothing - nubRows :: Type -> Maybe Type + nubRows :: SourceType -> Maybe SourceType nubRows r = - guard (REmpty == rest) $> - rowFromList (nubBy ((==) `on` fst) fixed, rest) + guard (eqType rest $ REmpty ()) $> + rowFromList (nubBy ((==) `on` rowListLabel) fixed, rest) where (fixed, rest) = rowToSortedList r - solveLacks :: [Type] -> Maybe [TypeClassDict] - solveLacks [TypeLevelString sym, r] = do + solveLacks :: [SourceType] -> Maybe [TypeClassDict] + solveLacks [TypeLevelString ann sym, r] = do (r', cst) <- rowLacks sym r - pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowLacks [TypeLevelString sym, r'] cst ] + pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowLacks [TypeLevelString ann sym, r'] cst ] solveLacks _ = Nothing - rowLacks :: PSString -> Type -> Maybe (Type, Maybe [Constraint]) + rowLacks :: PSString -> SourceType -> Maybe (SourceType, Maybe [SourceConstraint]) rowLacks sym r = guard (lacksSym && canMakeProgress) $> (r, cst) where (fixed, rest) = rowToList r lacksSym = - not $ sym `elem` (runLabel . fst <$> fixed) + not $ sym `elem` (runLabel . rowListLabel <$> fixed) (canMakeProgress, cst) = case rest of - REmpty -> (True, Nothing) - _ -> (not (null fixed), Just [ Constraint C.RowLacks [TypeLevelString sym, rest] Nothing ]) + REmpty _ -> (True, Nothing) + _ -> (not (null fixed), Just [ srcConstraint C.RowLacks [srcTypeLevelString sym, rest] Nothing ]) -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a -- substitution which makes them match. If not, we return 'Nothing'. -matches :: [FunctionalDependency] -> TypeClassDict -> [Type] -> Matched (Matching [Type]) +matches :: [FunctionalDependency] -> TypeClassDict -> [SourceType] -> Matched (Matching [SourceType]) matches deps TypeClassDictionaryInScope{..} tys = -- First, find those types which match exactly let matched = zipWith typeHeadsAreEqual tys tcdInstanceTypes in @@ -542,76 +543,76 @@ matches deps TypeClassDictionaryInScope{..} tys = -- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup), -- and return a substitution from type variables to types which makes the type heads unify. -- - typeHeadsAreEqual :: Type -> Type -> (Matched (), Matching [Type]) - typeHeadsAreEqual (KindedType t1 _) t2 = typeHeadsAreEqual t1 t2 - typeHeadsAreEqual t1 (KindedType t2 _) = typeHeadsAreEqual t1 t2 - typeHeadsAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = (Match (), M.empty) - typeHeadsAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = (Match (), M.empty) - typeHeadsAreEqual t (TypeVar v) = (Match (), M.singleton v [t]) - typeHeadsAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = (Match (), M.empty) - typeHeadsAreEqual (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = (Match (), M.empty) - typeHeadsAreEqual (TypeApp h1 t1) (TypeApp h2 t2) = + typeHeadsAreEqual :: Type a -> Type a -> (Matched (), Matching [Type a]) + typeHeadsAreEqual (KindedType _ t1 _) t2 = typeHeadsAreEqual t1 t2 + typeHeadsAreEqual t1 (KindedType _ t2 _) = typeHeadsAreEqual t1 t2 + typeHeadsAreEqual (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = (Match (), M.empty) + typeHeadsAreEqual (Skolem _ _ s1 _) (Skolem _ _ s2 _) | s1 == s2 = (Match (), M.empty) + typeHeadsAreEqual t (TypeVar _ v) = (Match (), M.singleton v [t]) + typeHeadsAreEqual (TypeConstructor _ c1) (TypeConstructor _ c2) | c1 == c2 = (Match (), M.empty) + typeHeadsAreEqual (TypeLevelString _ s1) (TypeLevelString _ s2) | s1 == s2 = (Match (), M.empty) + typeHeadsAreEqual (TypeApp _ h1 t1) (TypeApp _ h2 t2) = both (typeHeadsAreEqual h1 h2) (typeHeadsAreEqual t1 t2) - typeHeadsAreEqual REmpty REmpty = (Match (), M.empty) + typeHeadsAreEqual (REmpty _) (REmpty _) = (Match (), M.empty) typeHeadsAreEqual r1@RCons{} r2@RCons{} = foldr both (uncurry go rest) common where (common, rest) = alignRowsWith typeHeadsAreEqual r1 r2 - go :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> (Matched (), Matching [Type]) - go (l, KindedType t1 _) (r, t2) = go (l, t1) (r, t2) - go (l, t1) (r, KindedType t2 _) = go (l, t1) (r, t2) - go ([], REmpty) ([], REmpty) = (Match (), M.empty) - go ([], TUnknown u1) ([], TUnknown u2) | u1 == u2 = (Match (), M.empty) - go ([], TypeVar v1) ([], TypeVar v2) | v1 == v2 = (Match (), M.empty) - go ([], Skolem _ sk1 _ _) ([], Skolem _ sk2 _ _) | sk1 == sk2 = (Match (), M.empty) - go ([], TUnknown _) _ = (Unknown, M.empty) - go (sd, r) ([], TypeVar v) = (Match (), M.singleton v [rowFromList (sd, r)]) - go _ _ = (Apart, M.empty) - typeHeadsAreEqual (TUnknown _) _ = (Unknown, M.empty) + go :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Matched (), Matching [Type a]) + go (l, KindedType _ t1 _) (r, t2) = go (l, t1) (r, t2) + go (l, t1) (r, KindedType _ t2 _) = go (l, t1) (r, t2) + go ([], REmpty _) ([], REmpty _) = (Match (), M.empty) + go ([], TUnknown _ u1) ([], TUnknown _ u2) | u1 == u2 = (Match (), M.empty) + go ([], TypeVar _ v1) ([], TypeVar _ v2) | v1 == v2 = (Match (), M.empty) + go ([], Skolem _ _ sk1 _) ([], Skolem _ _ sk2 _) | sk1 == sk2 = (Match (), M.empty) + go ([], TUnknown _ _) _ = (Unknown, M.empty) + go (sd, r) ([], TypeVar _ v) = (Match (), M.singleton v [rowFromList (sd, r)]) + go _ _ = (Apart, M.empty) + typeHeadsAreEqual (TUnknown _ _) _ = (Unknown, M.empty) typeHeadsAreEqual _ _ = (Apart, M.empty) - both :: (Matched (), Matching [Type]) -> (Matched (), Matching [Type]) -> (Matched (), Matching [Type]) + both :: (Matched (), Matching [Type a]) -> (Matched (), Matching [Type a]) -> (Matched (), Matching [Type a]) both (b1, m1) (b2, m2) = (b1 <> b2, M.unionWith (++) m1 m2) -- Ensure that a substitution is valid - verifySubstitution :: Matching [Type] -> Matched (Matching [Type]) + verifySubstitution :: Matching [Type a] -> Matched (Matching [Type a]) verifySubstitution mts = foldMap meet mts $> mts where meet = pairwiseAll typesAreEqual -- Note that unknowns are only allowed to unify if they came from a type -- which was _not_ solved, i.e. one which was inferred by a functional -- dependency. - typesAreEqual :: Type -> Type -> Matched () - typesAreEqual (KindedType t1 _) t2 = typesAreEqual t1 t2 - typesAreEqual t1 (KindedType t2 _) = typesAreEqual t1 t2 - typesAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = Match () - typesAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Match () - typesAreEqual (Skolem _ _ _ _) _ = Unknown - typesAreEqual _ (Skolem _ _ _ _) = Unknown - typesAreEqual (TypeVar v1) (TypeVar v2) | v1 == v2 = Match () - typesAreEqual (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = Match () - typesAreEqual (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Match () - typesAreEqual (TypeApp h1 t1) (TypeApp h2 t2) = typesAreEqual h1 h2 <> typesAreEqual t1 t2 - typesAreEqual REmpty REmpty = Match () - typesAreEqual r1 r2 | isRCons r1 || isRCons r2 = + typesAreEqual :: Type a -> Type a -> Matched () + typesAreEqual (KindedType _ t1 _) t2 = typesAreEqual t1 t2 + typesAreEqual t1 (KindedType _ t2 _) = typesAreEqual t1 t2 + typesAreEqual (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = Match () + typesAreEqual (Skolem _ _ s1 _) (Skolem _ _ s2 _) | s1 == s2 = Match () + typesAreEqual (Skolem _ _ _ _) _ = Unknown + typesAreEqual _ (Skolem _ _ _ _) = Unknown + typesAreEqual (TypeVar _ v1) (TypeVar _ v2) | v1 == v2 = Match () + typesAreEqual (TypeLevelString _ s1) (TypeLevelString _ s2) | s1 == s2 = Match () + typesAreEqual (TypeConstructor _ c1) (TypeConstructor _ c2) | c1 == c2 = Match () + typesAreEqual (TypeApp _ h1 t1) (TypeApp _ h2 t2) = typesAreEqual h1 h2 <> typesAreEqual t1 t2 + typesAreEqual (REmpty _) (REmpty _) = Match () + typesAreEqual r1 r2 | isRCons r1 || isRCons r2 = let (common, rest) = alignRowsWith typesAreEqual r1 r2 in fold common <> uncurry go rest where - go :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> Matched () - go (l, KindedType t1 _) (r, t2) = go (l, t1) (r, t2) - go (l, t1) (r, KindedType t2 _) = go (l, t1) (r, t2) - go ([], TUnknown u1) ([], TUnknown u2) | u1 == u2 = Match () - go ([], Skolem _ s1 _ _) ([], Skolem _ s2 _ _) | s1 == s2 = Match () - go ([], Skolem _ _ _ _) _ = Unknown - go _ ([], Skolem _ _ _ _) = Unknown - go ([], REmpty) ([], REmpty) = Match () - go ([], TypeVar v1) ([], TypeVar v2) | v1 == v2 = Match () - go _ _ = Apart - typesAreEqual _ _ = Apart - - isRCons :: Type -> Bool + go :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> Matched () + go (l, KindedType _ t1 _) (r, t2) = go (l, t1) (r, t2) + go (l, t1) (r, KindedType _ t2 _) = go (l, t1) (r, t2) + go ([], TUnknown _ u1) ([], TUnknown _ u2) | u1 == u2 = Match () + go ([], Skolem _ _ s1 _) ([], Skolem _ _ s2 _) | s1 == s2 = Match () + go ([], Skolem _ _ _ _) _ = Unknown + go _ ([], Skolem _ _ _ _) = Unknown + go ([], REmpty _) ([], REmpty _) = Match () + go ([], TypeVar _ v1) ([], TypeVar _ v2) | v1 == v2 = Match () + go _ _ = Apart + typesAreEqual _ _ = Apart + + isRCons :: Type a -> Bool isRCons RCons{} = True isRCons _ = False @@ -621,19 +622,19 @@ newDictionaries :: MonadState CheckState m => [(Qualified (ProperName 'ClassName), Integer)] -> Qualified Ident - -> Constraint + -> SourceConstraint -> m [NamedDict] -newDictionaries path name (Constraint className instanceTy _) = do +newDictionaries path name (Constraint _ className instanceTy _) = do tcs <- gets (typeClasses . checkEnv) let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs - supDicts <- join <$> zipWithM (\(Constraint supName supArgs _) index -> + supDicts <- join <$> zipWithM (\(Constraint ann supName supArgs _) index -> newDictionaries ((supName, index) : path) name - (Constraint supName (instantiateSuperclass (map fst typeClassArguments) supArgs instanceTy) Nothing) + (Constraint ann supName (instantiateSuperclass (map fst typeClassArguments) supArgs instanceTy) Nothing) ) typeClassSuperclasses [0..] return (TypeClassDictionaryInScope [] 0 name path className instanceTy Nothing : supDicts) where - instantiateSuperclass :: [Text] -> [Type] -> [Type] -> [Type] + instantiateSuperclass :: [Text] -> [SourceType] -> [SourceType] -> [SourceType] instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs mkContext :: [NamedDict] -> InstanceContext diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 58ec2f0fb6..ef6596bb79 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -17,6 +17,7 @@ import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State +import Data.Functor (($>)) import qualified Data.Map as M import Data.Text (Text) @@ -29,17 +30,17 @@ import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types -- | Generate a fresh kind variable -freshKind :: (MonadState CheckState m) => m Kind +freshKind :: (MonadState CheckState m) => m SourceKind freshKind = do k <- gets checkNextKind modify $ \st -> st { checkNextKind = k + 1 } - return $ KUnknown k + return $ KUnknown nullSourceAnn k -- | Update the substitution to solve a kind constraint solveKind :: (MonadError MultipleErrors m, MonadState CheckState m) => Int - -> Kind + -> SourceKind -> m () solveKind u k = do occursCheck u k @@ -50,13 +51,13 @@ solveKind u k = do } -- | Apply a substitution to a kind -substituteKind :: Substitution -> Kind -> Kind +substituteKind :: Substitution -> SourceKind -> SourceKind substituteKind sub = everywhereOnKinds go where - go (KUnknown u) = + go (KUnknown ann u) = case M.lookup u (substKind sub) of - Nothing -> KUnknown u - Just (KUnknown u1) | u1 == u -> KUnknown u1 + Nothing -> KUnknown ann u + Just (KUnknown ann' u1) | u1 == u -> KUnknown ann' u1 Just t -> substituteKind sub t go other = other @@ -64,30 +65,30 @@ substituteKind sub = everywhereOnKinds go occursCheck :: (MonadError MultipleErrors m) => Int - -> Kind + -> SourceKind -> m () occursCheck _ KUnknown{} = return () occursCheck u k = void $ everywhereOnKindsM go k where - go (KUnknown u') | u == u' = throwError . errorMessage . InfiniteKind $ k + go (KUnknown _ u') | u == u' = throwError . errorMessage . InfiniteKind $ k go other = return other -- | Unify two kinds unifyKinds :: (MonadError MultipleErrors m, MonadState CheckState m) - => Kind - -> Kind + => SourceKind + -> SourceKind -> m () unifyKinds k1 k2 = do sub <- gets checkSubstitution go (substituteKind sub k1) (substituteKind sub k2) where - go (KUnknown u1) (KUnknown u2) | u1 == u2 = return () - go (KUnknown u) k = solveKind u k - go k (KUnknown u) = solveKind u k - go (NamedKind k1') (NamedKind k2') | k1' == k2' = return () - go (Row k1') (Row k2') = unifyKinds k1' k2' - go (FunKind k1' k2') (FunKind k3 k4) = do + go (KUnknown _ u1) (KUnknown _ u2) | u1 == u2 = return () + go (KUnknown _ u) k = solveKind u k + go k (KUnknown _ u) = solveKind u k + go (NamedKind _ k1') (NamedKind _ k2') | k1' == k2' = return () + go (Row _ k1') (Row _ k2') = unifyKinds k1' k2' + go (FunKind _ k1' k2') (FunKind _ k3 k4) = do unifyKinds k1' k3 unifyKinds k2' k4 go k1' k2' = throwError . errorMessage $ KindsDoNotUnify k1' k2' @@ -95,15 +96,15 @@ unifyKinds k1 k2 = do -- | Infer the kind of a single type kindOf :: (MonadError MultipleErrors m, MonadState CheckState m) - => Type - -> m Kind + => SourceType + -> m SourceKind kindOf ty = fst <$> kindOfWithScopedVars ty -- | Infer the kind of a single type, returning the kinds of any scoped type variables kindOfWithScopedVars :: (MonadError MultipleErrors m, MonadState CheckState m) => - Type -> - m (Kind, [(Text, Kind)]) + SourceType -> + m (SourceKind, [(Text, SourceKind)]) kindOfWithScopedVars ty = withErrorMessageHint (ErrorCheckingKind ty) $ fmap tidyUp . withFreshSubstitution . captureSubstitution $ infer ty @@ -118,9 +119,9 @@ kindsOf => Bool -> ModuleName -> ProperName 'TypeName - -> [(Text, Maybe Kind)] - -> [Type] - -> m Kind + -> [(Text, Maybe SourceKind)] + -> [SourceType] + -> m SourceKind kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do tyCon <- freshKind kargs <- replicateM (length args) freshKind @@ -133,9 +134,9 @@ kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . c freshKindVar :: (MonadError MultipleErrors m, MonadState CheckState m) - => (Text, Maybe Kind) - -> Kind - -> m (ProperName 'TypeName, Kind) + => (Text, Maybe SourceKind) + -> SourceKind + -> m (ProperName 'TypeName, SourceKind) freshKindVar (arg, Nothing) kind = return (ProperName arg, kind) freshKindVar (arg, Just kind') kind = do unifyKinds kind kind' @@ -145,9 +146,9 @@ freshKindVar (arg, Just kind') kind = do kindsOfAll :: (MonadError MultipleErrors m, MonadState CheckState m) => ModuleName - -> [(ProperName 'TypeName, [(Text, Maybe Kind)], Type)] - -> [(ProperName 'TypeName, [(Text, Maybe Kind)], [Type])] - -> m ([Kind], [Kind]) + -> [(ProperName 'TypeName, [(Text, Maybe SourceKind)], SourceType)] + -> [(ProperName 'TypeName, [(Text, Maybe SourceKind)], [SourceType])] + -> m ([SourceKind], [SourceKind]) kindsOfAll moduleName syns tys = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do synVars <- replicateM (length syns) freshKind let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars @@ -173,91 +174,91 @@ kindsOfAll moduleName syns tys = fmap tidyUp . withFreshSubstitution . captureSu solveTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => Bool - -> [Type] - -> [Kind] - -> Kind - -> m Kind + -> [SourceType] + -> [SourceKind] + -> SourceKind + -> m SourceKind solveTypes isData ts kargs tyCon = do ks <- traverse (fmap fst . infer) ts when isData $ do - unifyKinds tyCon (foldr FunKind kindType kargs) + unifyKinds tyCon (foldr (FunKind nullSourceAnn) kindType kargs) forM_ ks $ \k -> unifyKinds k kindType unless isData $ - unifyKinds tyCon (foldr FunKind (head ks) kargs) + unifyKinds tyCon (foldr (FunKind nullSourceAnn) (head ks) kargs) return tyCon -- | Default all unknown kinds to the kindType kind of types -starIfUnknown :: Kind -> Kind -starIfUnknown (KUnknown _) = kindType -starIfUnknown (Row k) = Row (starIfUnknown k) -starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2) +starIfUnknown :: Kind a -> Kind a +starIfUnknown (KUnknown ann _) = kindType $> ann +starIfUnknown (Row ann k) = Row ann (starIfUnknown k) +starIfUnknown (FunKind ann k1 k2) = FunKind ann (starIfUnknown k1) (starIfUnknown k2) starIfUnknown k = k -- | Infer a kind for a type infer :: (MonadError MultipleErrors m, MonadState CheckState m) - => Type - -> m (Kind, [(Text, Kind)]) + => SourceType + -> m (SourceKind, [(Text, SourceKind)]) infer ty = withErrorMessageHint (ErrorCheckingKind ty) $ infer' ty infer' :: forall m . (MonadError MultipleErrors m, MonadState CheckState m) - => Type - -> m (Kind, [(Text, Kind)]) -infer' (ForAll ident ty _) = do + => SourceType + -> m (SourceKind, [(Text, SourceKind)]) +infer' (ForAll _ ident ty _) = do k1 <- freshKind Just moduleName <- checkCurrentModule <$> get (k2, args) <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty unifyKinds k2 kindType return (kindType, (ident, k1) : args) -infer' (KindedType ty k) = do +infer' (KindedType _ ty k) = do (k', args) <- infer ty unifyKinds k k' return (k', args) infer' other = (, []) <$> go other where - go :: Type -> m Kind - go (ForAll ident ty _) = do + go :: SourceType -> m SourceKind + go (ForAll _ ident ty _) = do k1 <- freshKind Just moduleName <- checkCurrentModule <$> get k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ go ty unifyKinds k2 kindType return kindType - go (KindedType ty k) = do + go (KindedType _ ty k) = do k' <- go ty unifyKinds k k' return k' go TypeWildcard{} = freshKind go TUnknown{} = freshKind - go (TypeLevelString _) = return kindSymbol - go (TypeVar v) = do + go (TypeLevelString {}) = return kindSymbol + go (TypeVar _ v) = do Just moduleName <- checkCurrentModule <$> get lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) - go (Skolem v _ _ _) = do + go (Skolem _ v _ _) = do Just moduleName <- checkCurrentModule <$> get lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) - go (TypeConstructor v) = do + go (TypeConstructor _ v) = do env <- getEnv case M.lookup v (types env) of Nothing -> throwError . errorMessage . UnknownName $ fmap TyName v Just (kind, _) -> return kind - go (TypeApp t1 t2) = do + go (TypeApp _ t1 t2) = do k0 <- freshKind k1 <- go t1 k2 <- go t2 - unifyKinds k1 (FunKind k2 k0) + unifyKinds k1 (FunKind nullSourceAnn k2 k0) return k0 - go REmpty = do + go (REmpty _) = do k <- freshKind - return $ Row k - go (RCons _ ty row) = do + return $ Row nullSourceAnn k + go (RCons _ _ ty row) = do k1 <- go ty k2 <- go row - unifyKinds k2 (Row k1) - return $ Row k1 - go (ConstrainedType (Constraint className tys _) ty) = do - k1 <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys + unifyKinds k2 (Row nullSourceAnn k1) + return $ Row nullSourceAnn k1 + go (ConstrainedType ann2 (Constraint ann1 className tys _) ty) = do + k1 <- go $ foldl (TypeApp ann2) (TypeConstructor ann1 (fmap coerceProperName className)) tys unifyKinds k1 kindType k2 <- go ty unifyKinds k2 kindType diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index e85b1af5fd..7ec603fa7f 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -27,8 +27,8 @@ import Language.PureScript.Types -- | A substitution of unification variables for types or kinds data Substitution = Substitution - { substType :: M.Map Int Type -- ^ Type substitution - , substKind :: M.Map Int Kind -- ^ Kind substitution + { substType :: M.Map Int SourceType -- ^ Type substitution + , substKind :: M.Map Int SourceKind -- ^ Kind substitution } -- | An empty substitution @@ -68,7 +68,7 @@ type Unknown = Int -- | Temporarily bind a collection of names to values bindNames :: MonadState CheckState m - => M.Map (Qualified Ident) (Type, NameKind, NameVisibility) + => M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) -> m a -> m a bindNames newNames action = do @@ -81,7 +81,7 @@ bindNames newNames action = do -- | Temporarily bind a collection of names to types bindTypes :: MonadState CheckState m - => M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) + => M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) -> m a -> m a bindTypes newNames action = do @@ -95,7 +95,7 @@ bindTypes newNames action = do withScopedTypeVars :: (MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName - -> [(Text, Kind)] + -> [(Text, SourceKind)] -> m a -> m a withScopedTypeVars mn ks ma = do @@ -182,7 +182,7 @@ lookupTypeClassDictionariesForClass mn cn = fromMaybe M.empty . M.lookup cn <$> -- | Temporarily bind a collection of names to local variables bindLocalVariables :: (MonadState CheckState m) - => [(Ident, Type, NameVisibility)] + => [(Ident, SourceType, NameVisibility)] -> m a -> m a bindLocalVariables bindings = @@ -192,7 +192,7 @@ bindLocalVariables bindings = bindLocalTypeVariables :: (MonadState CheckState m) => ModuleName - -> [(ProperName 'TypeName, Kind)] + -> [(ProperName 'TypeName, SourceKind)] -> m a -> m a bindLocalTypeVariables moduleName bindings = @@ -218,7 +218,7 @@ preservingNames action = do lookupVariable :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => Qualified Ident - -> m Type + -> m SourceType lookupVariable qual = do env <- getEnv case M.lookup qual (names env) of @@ -252,7 +252,7 @@ lookupTypeVariable :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified (ProperName 'TypeName) - -> m Kind + -> m SourceKind lookupTypeVariable currentModule (Qualified moduleName name) = do env <- getEnv case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index ed7659c92f..76af631635 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -31,10 +31,10 @@ newSkolemConstant = do return s -- | Introduce skolem scope at every occurence of a ForAll -introduceSkolemScope :: MonadState CheckState m => Type -> m Type +introduceSkolemScope :: MonadState CheckState m => Type a -> m (Type a) introduceSkolemScope = everywhereOnTypesM go where - go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope) + go (ForAll ann ident ty Nothing) = ForAll ann ident ty <$> (Just <$> newSkolemScope) go other = return other -- | Generate a new skolem scope @@ -45,14 +45,14 @@ newSkolemScope = do return $ SkolemScope s -- | Skolemize a type variable by replacing its instances with fresh skolem constants -skolemize :: Text -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type -skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss) +skolemize :: a -> Text -> Int -> SkolemScope -> Type a -> Type a +skolemize ann ident sko scope = replaceTypeVars ident (Skolem ann ident sko scope) -- | This function skolemizes type variables appearing in any type signatures or -- 'DeferredDictionary' placeholders. These type variables are the only places -- where scoped type variables can appear in expressions. -skolemizeTypesInValue :: Text -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr -skolemizeTypesInValue ident sko scope ss = +skolemizeTypesInValue :: SourceAnn -> Text -> Int -> SkolemScope -> Expr -> Expr +skolemizeTypesInValue ann ident sko scope = runIdentity . onExpr' where onExpr' :: Expr -> Identity Expr @@ -60,18 +60,18 @@ skolemizeTypesInValue ident sko scope ss = onExpr :: [Text] -> Expr -> Identity ([Text], Expr) onExpr sco (DeferredDictionary c ts) - | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts)) + | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ann ident sko scope) ts)) onExpr sco (TypedValue check val ty) - | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty)) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ann ident sko scope ty)) onExpr sco other = return (sco, other) onBinder :: [Text] -> Binder -> Identity ([Text], Binder) onBinder sco (TypedBinder ty b) - | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ss ty) b) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ann ident sko scope ty) b) onBinder sco other = return (sco, other) - peelTypeVars :: Type -> [Text] - peelTypeVars (ForAll i ty _) = i : peelTypeVars ty + peelTypeVars :: SourceType -> [Text] + peelTypeVars (ForAll _ i ty _) = i : peelTypeVars ty peelTypeVars _ = [] -- | Ensure skolem variables do not escape their scope @@ -100,8 +100,8 @@ skolemEscapeCheck expr@TypedValue{} = go (scopes, ssUsed) val@(TypedValue _ _ ty) = ( (allScopes, ssUsed) , [ ErrorMessage (maybe id ((:) . positionedError) ssUsed [ ErrorInExpression val ]) $ - EscapedSkolem name ssBound ty - | (name, scope, ssBound) <- collectSkolems ty + EscapedSkolem name (nonEmptySpan ssBound) ty + | (ssBound, name, scope) <- collectSkolems ty , notMember scope allScopes ] ) @@ -115,15 +115,15 @@ skolemEscapeCheck expr@TypedValue{} = allScopes = fromList newScopes <> scopes -- Collect any scopes appearing in quantifiers at the top level - collectScopes :: Type -> [SkolemScope] - collectScopes (ForAll _ t (Just sco)) = sco : collectScopes t + collectScopes :: SourceType -> [SkolemScope] + collectScopes (ForAll _ _ t (Just sco)) = sco : collectScopes t collectScopes ForAll{} = internalError "skolemEscapeCheck: No skolem scope" collectScopes _ = [] -- Collect any skolem variables appearing in a type - collectSkolems :: Type -> [(Text, SkolemScope, Maybe SourceSpan)] + collectSkolems :: SourceType -> [(SourceAnn, Text, SkolemScope)] collectSkolems = everythingOnTypes (++) collect where - collect (Skolem name _ scope srcSpan) = [(name, scope, srcSpan)] + collect (Skolem ss name _ scope) = [(ss, name, scope)] collect _ = [] go scos _ = (scos, []) skolemEscapeCheck _ = internalError "skolemEscapeCheck: untyped value" diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 65d6a91ba3..af5275dcca 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -61,8 +61,8 @@ defaultCoercion SNoElaborate = () -- | Check that one type subsumes another, rethrowing errors to provide a better error message subsumes :: (MonadError MultipleErrors m, MonadState CheckState m) - => Type - -> Type + => SourceType + -> SourceType -> m (Expr -> Expr) subsumes ty1 ty2 = withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ @@ -72,46 +72,46 @@ subsumes ty1 ty2 = subsumes' :: (MonadError MultipleErrors m, MonadState CheckState m) => ModeSing mode - -> Type - -> Type + -> SourceType + -> SourceType -> m (Coercion mode) -subsumes' mode (ForAll ident ty1 _) ty2 = do +subsumes' mode (ForAll _ ident ty1 _) ty2 = do replaced <- replaceVarWithUnknown ident ty1 subsumes' mode replaced ty2 -subsumes' mode ty1 (ForAll ident ty2 sco) = +subsumes' mode ty1 (ForAll _ ident ty2 sco) = case sco of Just sco' -> do sko <- newSkolemConstant - let sk = skolemize ident sko sco' Nothing ty2 + let sk = skolemize NullSourceAnn ident sko sco' ty2 subsumes' mode ty1 sk Nothing -> internalError "subsumes: unspecified skolem scope" -subsumes' mode (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do +subsumes' mode (TypeApp _ (TypeApp _ f1 arg1) ret1) (TypeApp _ (TypeApp _ f2 arg2) ret2) | eqType f1 tyFunction && eqType f2 tyFunction = do subsumes' SNoElaborate arg2 arg1 subsumes' SNoElaborate ret1 ret2 -- Nothing was elaborated, return the default coercion return (defaultCoercion mode) -subsumes' mode (KindedType ty1 _) ty2 = +subsumes' mode (KindedType _ ty1 _) ty2 = subsumes' mode ty1 ty2 -subsumes' mode ty1 (KindedType ty2 _) = +subsumes' mode ty1 (KindedType _ ty2 _) = subsumes' mode ty1 ty2 -- Only check subsumption for constrained types when elaborating. -- Otherwise fall back to unification. -subsumes' SElaborate (ConstrainedType con ty1) ty2 = do +subsumes' SElaborate (ConstrainedType _ con ty1) ty2 = do dicts <- getTypeClassDictionaries hints <- getHints elaborate <- subsumes' SElaborate ty1 ty2 let addDicts val = App val (TypeClassDictionary con dicts hints) return (elaborate . addDicts) -subsumes' mode (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecord = do +subsumes' mode (TypeApp _ f1 r1) (TypeApp _ f2 r2) | eqType f1 tyRecord && eqType f2 tyRecord = do let (common, ((ts1', r1'), (ts2', r2'))) = alignRowsWith (subsumes' SNoElaborate) r1 r2 -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row), -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property. -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has -- an additional property which is not allowed. - when (r1' == REmpty) - (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . fst)) - when (r2' == REmpty) - (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . fst)) + when (eqType r1' $ REmpty ()) + (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . rowListLabel)) + when (eqType r2' $ REmpty ()) + (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . rowListLabel)) -- Check subsumption for common labels sequence_ common unifyTypes (rowFromList (ts1', r1')) (rowFromList (ts2', r2')) @@ -119,8 +119,8 @@ subsumes' mode (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyRecord && f2 == tyRecor return (defaultCoercion mode) where -- Find the first property that's in the first list (of tuples) but not in the second - firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing fst) t1 t2) -subsumes' mode ty1 ty2@(TypeApp obj _) | obj == tyRecord = + firstMissingProp t1 t2 = fst <$> uncons (minusBy' (comparing rowListLabel) t1 t2) +subsumes' mode ty1 ty2@(TypeApp _ obj _) | obj == tyRecord = subsumes' mode ty2 ty1 subsumes' mode ty1 ty2 = do unifyTypes ty1 ty2 diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 08016b2315..7d5d250e94 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -24,19 +24,19 @@ import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types -- | Type synonym information (arguments with kinds, aliased type), indexed by name -type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type) +type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceKind)], SourceType) replaceAllTypeSynonyms' :: SynonymMap - -> Type - -> Either MultipleErrors Type + -> SourceType + -> Either MultipleErrors SourceType replaceAllTypeSynonyms' syns = everywhereOnTypesTopDownM try where - try :: Type -> Either MultipleErrors Type + try :: SourceType -> Either MultipleErrors SourceType try t = fromMaybe t <$> go 0 [] t - go :: Int -> [Type] -> Type -> Either MultipleErrors (Maybe Type) - go c args (TypeConstructor ctor) + go :: Int -> [SourceType] -> SourceType -> Either MultipleErrors (Maybe SourceType) + go c args (TypeConstructor _ ctor) | Just (synArgs, body) <- M.lookup ctor syns , c == length synArgs = let repl = replaceAllTypeVars (zip (map fst synArgs) args) body @@ -44,11 +44,11 @@ replaceAllTypeSynonyms' syns = everywhereOnTypesTopDownM try | Just (synArgs, _) <- M.lookup ctor syns , length synArgs > c = throwError . errorMessage $ PartiallyAppliedSynonym ctor - go c args (TypeApp f arg) = go (c + 1) (arg : args) f + go c args (TypeApp _ f arg) = go (c + 1) (arg : args) f go _ _ _ = return Nothing -- | Replace fully applied type synonyms -replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => Type -> m Type +replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => SourceType -> m SourceType replaceAllTypeSynonyms d = do env <- getEnv either throwError return $ replaceAllTypeSynonyms' (typeSynonyms env) d @@ -57,6 +57,6 @@ replaceAllTypeSynonyms d = do replaceAllTypeSynonymsM :: MonadError MultipleErrors m => SynonymMap - -> Type - -> m Type + -> SourceType + -> m SourceType replaceAllTypeSynonymsM syns = either throwError pure . replaceAllTypeSynonyms' syns diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index 225410ab5b..a636e3503f 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -39,17 +39,17 @@ evalWriterT :: Monad m => WriterT b m r -> m r evalWriterT m = liftM fst (runWriterT m) checkSubsume - :: Maybe [(P.Ident, Entailment.InstanceContext, P.Constraint)] + :: Maybe [(P.Ident, Entailment.InstanceContext, P.SourceConstraint)] -- ^ Additional constraints we need to satisfy -> P.Environment -- ^ The Environment which contains the relevant definitions and typeclasses -> TC.CheckState -- ^ The typechecker state - -> P.Type + -> P.SourceType -- ^ The user supplied type - -> P.Type + -> P.SourceType -- ^ The type supplied by the environment - -> Maybe ((P.Expr, [(P.Ident, Entailment.InstanceContext, P.Constraint)]), P.Environment) + -> Maybe ((P.Expr, [(P.Ident, Entailment.InstanceContext, P.SourceConstraint)]), P.Environment) checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do let initializeSkolems = Skolem.introduceSkolemScope @@ -79,11 +79,11 @@ checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do Entailment.replaceTypeClassDictionaries (isJust unsolved) expP accessorSearch - :: Maybe [(P.Ident, Entailment.InstanceContext, P.Constraint)] + :: Maybe [(P.Ident, Entailment.InstanceContext, P.SourceConstraint)] -> P.Environment -> TC.CheckState - -> P.Type - -> ([(Label, P.Type)], [(Label, P.Type)]) + -> P.SourceType + -> ([(Label, P.SourceType)], [(Label, P.SourceType)]) -- ^ (all accessors we found, all accessors we found that match the result type) accessorSearch unsolved env st userT = maybe ([], []) fst $ checkInEnvironment env st $ do let initializeSkolems = @@ -95,28 +95,29 @@ accessorSearch unsolved env st userT = maybe ([], []) fst $ checkInEnvironment e rowType <- freshType resultType <- freshType - let recordFunction = TypeApp (TypeApp tyFunction (TypeApp tyRecord rowType)) resultType + let recordFunction = srcTypeApp (srcTypeApp tyFunction (srcTypeApp tyRecord rowType)) resultType _ <- subsumes recordFunction userT' subst <- gets TC.checkSubstitution - let solvedRow = fst (rowToList (substituteType subst rowType)) + let solvedRow = toRowPair <$> fst (rowToList (substituteType subst rowType)) tcS <- get pure (solvedRow, filter (\x -> checkAccessor tcS (substituteType subst resultType) x) solvedRow) where checkAccessor tcs x (_, type') = isJust (checkSubsume unsolved env tcs x type') + toRowPair (RowListItem _ lbl ty) = (lbl, ty) typeSearch - :: Maybe [(P.Ident, Entailment.InstanceContext, P.Constraint)] + :: Maybe [(P.Ident, Entailment.InstanceContext, P.SourceConstraint)] -- ^ Additional constraints we need to satisfy -> P.Environment -- ^ The Environment which contains the relevant definitions and typeclasses -> TC.CheckState -- ^ The typechecker state - -> P.Type + -> P.SourceType -- ^ The type we are looking for - -> ([(P.Qualified Text, P.Type)], Maybe [(Label, P.Type)]) + -> ([(P.Qualified Text, P.SourceType)], Maybe [(Label, P.SourceType)]) typeSearch unsolved env st type' = let - runTypeSearch :: Map k P.Type -> Map k P.Type + runTypeSearch :: Map k P.SourceType -> Map k P.SourceType runTypeSearch = Map.mapMaybe (\ty -> checkSubsume unsolved env st type' ty $> ty) matchingNames = runTypeSearch (Map.map (\(ty, _, _) -> ty) (P.names env)) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 51dac649e6..6275141a1a 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -75,7 +75,7 @@ typesOf => BindingGroupType -> ModuleName -> [((SourceAnn, Ident), Expr)] - -> m [((SourceAnn, Ident), (Expr, Type))] + -> m [((SourceAnn, Ident), (Expr, SourceType))] typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do (tys, wInfer) <- capturingSubstitution tidyUp $ do (SplitBindingGroup untyped typed dict, w) <- withoutWarnings $ typeDictionaryForBindingGroup (Just moduleName) vals @@ -144,7 +144,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -- | Run type search to complete any typed hole error messages runTypeSearch - :: Maybe [(Ident, InstanceContext, Constraint)] + :: Maybe [(Ident, InstanceContext, SourceConstraint)] -- ^ Any unsolved constraints which we need to continue to satisfy -> CheckState -- ^ The final type checker state @@ -163,7 +163,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do generalize unsolved = varIfUnknown . constrain unsolved -- | Add any unsolved constraints - constrain cs ty = foldr ConstrainedType ty (map (\(_, _, x) -> x) cs) + constrain cs ty = foldr srcConstrainedType ty (map (\(_, _, x) -> x) cs) -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values tidyUp ts sub = first (map (second (first (second (overTypes (substituteType sub) *** substituteType sub))))) ts @@ -177,11 +177,11 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -- -- This structure breaks down a binding group into typed and untyped parts. data SplitBindingGroup = SplitBindingGroup - { _splitBindingGroupUntyped :: [((SourceAnn, Ident), (Expr, Type))] + { _splitBindingGroupUntyped :: [((SourceAnn, Ident), (Expr, SourceType))] -- ^ The untyped expressions - , _splitBindingGroupTyped :: [((SourceAnn, Ident), (Expr, Type, Bool))] + , _splitBindingGroupTyped :: [((SourceAnn, Ident), (Expr, SourceType, Bool))] -- ^ The typed expressions, along with their type annotations - , _splitBindingGroupNames :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility) + , _splitBindingGroupNames :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ A map containing all expressions and their assigned types (which might be -- fresh unification variables). These will be added to the 'Environment' after -- the binding group is checked, so the value type of the 'Map' is chosen to be @@ -218,7 +218,7 @@ typeDictionaryForBindingGroup moduleName vals = do where -- | Check if a value contains a type annotation, and if so, separate it -- from the value itself. - splitTypeAnnotation :: (a, Expr) -> Either (a, Expr) (a, (Expr, Type, Bool)) + splitTypeAnnotation :: (a, Expr) -> Either (a, Expr) (a, (Expr, SourceType, Bool)) splitTypeAnnotation (a, TypedValue checkType value ty) = Right (a, (value, ty, checkType)) splitTypeAnnotation (a, PositionedValue pos c value) = bimap (second (PositionedValue pos c)) @@ -230,11 +230,11 @@ typeDictionaryForBindingGroup moduleName vals = do checkTypedBindingGroupElement :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName - -> ((SourceAnn, Ident), (Expr, Type, Bool)) + -> ((SourceAnn, Ident), (Expr, SourceType, Bool)) -- ^ The identifier we are trying to define, along with the expression and its type annotation - -> M.Map (Qualified Ident) (Type, NameKind, NameVisibility) + -> M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ Names brought into scope in this binding group - -> m ((SourceAnn, Ident), (Expr, Type)) + -> m ((SourceAnn, Ident), (Expr, SourceType)) checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do -- Kind check (kind, args) <- kindOfWithScopedVars ty @@ -251,12 +251,12 @@ checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do -- | Infer a type for a value in a binding group which lacks an annotation. typeForBindingGroupElement :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => ((SourceAnn, Ident), (Expr, Type)) + => ((SourceAnn, Ident), (Expr, SourceType)) -- ^ The identifier we are trying to define, along with the expression and its assigned type -- (at this point, this should be a unification variable) - -> M.Map (Qualified Ident) (Type, NameKind, NameVisibility) + -> M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ Names brought into scope in this binding group - -> m ((SourceAnn, Ident), (Expr, Type)) + -> m ((SourceAnn, Ident), (Expr, SourceType)) typeForBindingGroupElement (ident, (val, ty)) dict = do -- Infer the type with the new names in scope TypedValue _ val' ty' <- bindNames dict $ infer val @@ -267,10 +267,10 @@ typeForBindingGroupElement (ident, (val, ty)) dict = do -- | Check the kind of a type, failing if it is not of kind *. checkTypeKind :: MonadError MultipleErrors m - => Type - -> Kind + => SourceType + -> SourceKind -> m () -checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType +checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ isKindType kind -- | Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns -- or TypeClassDictionary values. @@ -280,12 +280,12 @@ checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind = instantiatePolyTypeWithUnknowns :: (MonadState CheckState m, MonadError MultipleErrors m) => Expr - -> Type - -> m (Expr, Type) -instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do + -> SourceType + -> m (Expr, SourceType) +instantiatePolyTypeWithUnknowns val (ForAll _ ident ty _) = do ty' <- replaceVarWithUnknown ident ty instantiatePolyTypeWithUnknowns val ty' -instantiatePolyTypeWithUnknowns val (ConstrainedType con ty) = do +instantiatePolyTypeWithUnknowns val (ConstrainedType _ con ty) = do dicts <- getTypeClassDictionaries hints <- getHints instantiatePolyTypeWithUnknowns (App val (TypeClassDictionary con dicts hints)) ty @@ -316,7 +316,7 @@ infer' (Literal ss (ArrayLiteral vals)) = do (val', t') <- instantiatePolyTypeWithUnknowns val t unifyTypes els t' return (TypedValue ch val' t') - return $ TypedValue True (Literal ss (ArrayLiteral ts')) (TypeApp tyArray els) + return $ TypedValue True (Literal ss (ArrayLiteral ts')) (srcTypeApp tyArray els) infer' (Literal ss (ObjectLiteral ps)) = do ensureNoDuplicateProperties ps -- We make a special case for Vars in record labels, since these are the @@ -327,29 +327,33 @@ infer' (Literal ss (ObjectLiteral ps)) = do shouldInstantiate (PositionedValue _ _ e) = shouldInstantiate e shouldInstantiate _ = False - inferProperty :: (PSString, Expr) -> m (PSString, (Expr, Type)) + inferProperty :: (PSString, Expr) -> m (PSString, (Expr, SourceType)) inferProperty (name, val) = do TypedValue _ val' ty <- infer val valAndType <- if shouldInstantiate val then instantiatePolyTypeWithUnknowns val' ty else pure (val', ty) pure (name, valAndType) + + toRowListItem (lbl, (_, ty)) = srcRowListItem (Label lbl) ty + fields <- forM ps inferProperty - let ty = TypeApp tyRecord $ rowFromList (map (Label *** snd) fields, REmpty) + let ty = srcTypeApp tyRecord $ rowFromList (map toRowListItem fields, srcREmpty) return $ TypedValue True (Literal ss (ObjectLiteral (map (fmap (uncurry (TypedValue True))) fields))) ty infer' (ObjectUpdate o ps) = do ensureNoDuplicateProperties ps row <- freshType newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps + let toRowListItem = uncurry srcRowListItem let newTys = map (\(name, TypedValue _ _ ty) -> (Label name, ty)) newVals oldTys <- zip (map (Label . fst) ps) <$> replicateM (length ps) freshType - let oldTy = TypeApp tyRecord $ rowFromList (oldTys, row) + let oldTy = srcTypeApp tyRecord $ rowFromList (toRowListItem <$> oldTys, row) o' <- TypedValue True <$> check o oldTy <*> pure oldTy - return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyRecord $ rowFromList (newTys, row) + return $ TypedValue True (ObjectUpdate o' newVals) $ srcTypeApp tyRecord $ rowFromList (toRowListItem <$> newTys, row) infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do field <- freshType rest <- freshType - typed <- check val (TypeApp tyRecord (RCons (Label prop) field rest)) + typed <- check val (srcTypeApp tyRecord (srcRCons (Label prop) field rest)) return $ TypedValue True (Accessor prop typed) field infer' (Abs binder ret) | VarBinder ss arg <- binder = do @@ -367,7 +371,7 @@ infer' (Var ss var) = do checkVisibility var ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable $ var case ty of - ConstrainedType con ty' -> do + ConstrainedType _ con ty' -> do dicts <- getTypeClassDictionaries hints <- getHints return $ TypedValue True (App (Var ss var) (TypeClassDictionary con dicts hints)) ty' @@ -398,8 +402,8 @@ infer' (DeferredDictionary className tys) = do dicts <- getTypeClassDictionaries hints <- getHints return $ TypedValue False - (TypeClassDictionary (Constraint className tys Nothing) dicts hints) - (foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys) + (TypeClassDictionary (srcConstraint className tys Nothing) dicts hints) + (foldl srcTypeApp (srcTypeConstructor (fmap coerceProperName className)) tys) infer' (TypedValue checkType val ty) = do Just moduleName <- checkCurrentModule <$> get (kind, args) <- kindOfWithScopedVars ty @@ -459,9 +463,9 @@ inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding" inferBinder :: forall m . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => Type + => SourceType -> Binder - -> m (M.Map Ident Type) + -> m (M.Map Ident SourceType) inferBinder _ NullBinder = return M.empty inferBinder val (LiteralBinder _ (StringLiteral _)) = unifyTypes val tyString >> return M.empty inferBinder val (LiteralBinder _ (CharLiteral _)) = unifyTypes val tyChar >> return M.empty @@ -483,29 +487,29 @@ inferBinder val (ConstructorBinder ss ctor binders) = do M.unions <$> zipWithM inferBinder (reverse args) binders _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor where - peelArgs :: Type -> ([Type], Type) + peelArgs :: Type a -> ([Type a], Type a) peelArgs = go [] where - go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret + go args (TypeApp _ (TypeApp _ fn arg) ret) | eqType fn tyFunction = go (arg : args) ret go args ret = (args, ret) inferBinder val (LiteralBinder _ (ObjectLiteral props)) = do row <- freshType rest <- freshType m1 <- inferRowProperties row rest props - unifyTypes val (TypeApp tyRecord row) + unifyTypes val (srcTypeApp tyRecord row) return m1 where - inferRowProperties :: Type -> Type -> [(PSString, Binder)] -> m (M.Map Ident Type) + inferRowProperties :: SourceType -> SourceType -> [(PSString, Binder)] -> m (M.Map Ident SourceType) inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty inferRowProperties nrow row ((name, binder):binders) = do propTy <- freshType m1 <- inferBinder propTy binder - m2 <- inferRowProperties nrow (RCons (Label name) propTy row) binders + m2 <- inferRowProperties nrow (srcRCons (Label name) propTy row) binders return $ m1 `M.union` m2 inferBinder val (LiteralBinder _ (ArrayLiteral binders)) = do el <- freshType m1 <- M.unions <$> traverse (inferBinder el) binders - unifyTypes val (TypeApp tyArray el) + unifyTypes val (srcTypeApp tyArray el) return m1 inferBinder val (NamedBinder ss name binder) = warnAndRethrowWithPositionTC ss $ do @@ -541,7 +545,7 @@ instantiateForBinders :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Expr] -> [CaseAlternative] - -> m ([Expr], [Type]) + -> m ([Expr], [SourceType]) instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do TypedValue _ val' ty <- infer val if inst @@ -556,8 +560,8 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do -- checkBinders :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => [Type] - -> Type + => [SourceType] + -> SourceType -> [CaseAlternative] -> m [CaseAlternative] checkBinders _ _ [] = return [] @@ -573,7 +577,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do checkGuardedRhs :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => GuardedExpr - -> Type + -> SourceType -> m GuardedExpr checkGuardedRhs (GuardedExpr [] rhs) ret = do rhs' <- TypedValue True <$> check rhs ret <*> pure ret @@ -597,7 +601,7 @@ checkGuardedRhs (GuardedExpr (PatternGuard binder expr : guards) rhs) ret = do check :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr - -> Type + -> SourceType -> m Expr check val ty = withErrorMessageHint (ErrorCheckingType val ty) $ check' val ty @@ -608,24 +612,24 @@ check' :: forall m . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr - -> Type + -> SourceType -> m Expr -check' val (ForAll ident ty _) = do +check' val (ForAll ann ident ty _) = do scope <- newSkolemScope sko <- newSkolemConstant let ss = case val of - PositionedValue pos _ _ -> Just pos - _ -> Nothing - sk = skolemize ident sko scope ss ty - skVal = skolemizeTypesInValue ident sko scope ss val + PositionedValue pos c _ -> (pos, c) + _ -> NullSourceAnn + sk = skolemize ss ident sko scope ty + skVal = skolemizeTypesInValue ss ident sko scope val val' <- check skVal sk - return $ TypedValue True val' (ForAll ident ty (Just scope)) -check' val t@(ConstrainedType con@(Constraint (Qualified _ (ProperName className)) _ _) ty) = do + return $ TypedValue True val' (ForAll ann ident ty (Just scope)) +check' val t@(ConstrainedType _ con@(Constraint _ (Qualified _ (ProperName className)) _ _) ty) = do dictName <- freshIdent ("dict" <> className) dicts <- newDictionaries [] (Qualified Nothing dictName) con val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty return $ TypedValue True (Abs (VarBinder nullSourceSpan dictName) val') t -check' val u@(TUnknown _) = do +check' val u@(TUnknown _ _) = do val'@(TypedValue _ _ ty) <- infer val -- Don't unify an unknown with an inferred polytype (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty @@ -641,11 +645,11 @@ check' v@(Literal _ (CharLiteral _)) t | t == tyChar = return $ TypedValue True v t check' v@(Literal _ (BooleanLiteral _)) t | t == tyBoolean = return $ TypedValue True v t -check' (Literal ss (ArrayLiteral vals)) t@(TypeApp a ty) = do +check' (Literal ss (ArrayLiteral vals)) t@(TypeApp _ a ty) = do unifyTypes a tyArray array <- Literal ss . ArrayLiteral <$> forM vals (`check` ty) return $ TypedValue True array t -check' (Abs binder ret) ty@(TypeApp (TypeApp t argTy) retTy) +check' (Abs binder ret) ty@(TypeApp _ (TypeApp _ t argTy) retTy) | VarBinder ss arg <- binder = do unifyTypes t tyFunction ret' <- withBindingGroupVisible $ bindLocalVariables [(arg, argTy, Defined)] $ check ret retTy @@ -672,7 +676,7 @@ check' (DeferredDictionary className tys) ty = do dicts <- getTypeClassDictionaries hints <- getHints return $ TypedValue False - (TypeClassDictionary (Constraint className tys Nothing) dicts hints) + (TypeClassDictionary (srcConstraint className tys Nothing) dicts hints) ty check' (TypedValue checkType val ty1) ty2 = do kind <- kindOf ty1 @@ -693,26 +697,26 @@ check' (IfThenElse cond th el) ty = do th' <- check th ty el' <- check el ty return $ TypedValue True (IfThenElse cond' th' el') ty -check' e@(Literal ss (ObjectLiteral ps)) t@(TypeApp obj row) | obj == tyRecord = do +check' e@(Literal ss (ObjectLiteral ps)) t@(TypeApp _ obj row) | obj == tyRecord = do ensureNoDuplicateProperties ps ps' <- checkProperties e ps row False return $ TypedValue True (Literal ss (ObjectLiteral ps')) t check' (TypeClassDictionaryConstructorApp name ps) t = do ps' <- check' ps t return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t -check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyRecord = do +check' e@(ObjectUpdate obj ps) t@(TypeApp _ o row) | o == tyRecord = do ensureNoDuplicateProperties ps -- We need to be careful to avoid duplicate labels here. -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns. let (propsToCheck, rest) = rowToList row - (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map (Label . fst) ps) propsToCheck - us <- zip (map fst removedProps) <$> replicateM (length ps) freshType - obj' <- check obj (TypeApp tyRecord (rowFromList (us ++ remainingProps, rest))) + (removedProps, remainingProps) = partition (\(RowListItem _ p _) -> p `elem` map (Label . fst) ps) propsToCheck + us <- zipWith srcRowListItem (map rowListLabel removedProps) <$> replicateM (length ps) freshType + obj' <- check obj (srcTypeApp tyRecord (rowFromList (us ++ remainingProps, rest))) ps' <- checkProperties e ps row True return $ TypedValue True (ObjectUpdate obj' ps') t check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do rest <- freshType - val' <- check val (TypeApp tyRecord (RCons (Label prop) ty rest)) + val' <- check val (srcTypeApp tyRecord (srcRCons (Label prop) ty rest)) return $ TypedValue True (Accessor prop val') ty check' v@(Constructor _ c) ty = do env <- getEnv @@ -726,7 +730,7 @@ check' v@(Constructor _ c) ty = do check' (Let w ds val) ty = do (ds', val') <- inferLetBinding [] ds val (`check` ty) return $ TypedValue True (Let w ds' val') ty -check' val kt@(KindedType ty kind) = do +check' val kt@(KindedType _ ty kind) = do checkTypeKind ty kind val' <- check' val ty return $ TypedValue True val' kt @@ -747,32 +751,33 @@ checkProperties :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> [(PSString, Expr)] - -> Type + -> SourceType -> Bool -> m [(PSString, Expr)] -checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where - go [] [] REmpty = return [] - go [] [] u@(TUnknown _) +checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps (toRowPair <$> ts) r' where + toRowPair (RowListItem _ lbl ty) = (lbl, ty) + go [] [] (REmpty _) = return [] + go [] [] u@(TUnknown _ _) | lax = return [] - | otherwise = do unifyTypes u REmpty + | otherwise = do unifyTypes u srcREmpty return [] go [] [] Skolem{} | lax = return [] go [] ((p, _): _) _ | lax = return [] | otherwise = throwError . errorMessage $ PropertyIsMissing p - go ((p,_):_) [] REmpty = throwError . errorMessage $ AdditionalProperty $ Label p + go ((p,_):_) [] (REmpty _) = throwError . errorMessage $ AdditionalProperty $ Label p go ((p,v):ps') ts r = case lookup (Label p) ts of Nothing -> do v'@(TypedValue _ _ ty) <- infer v rest <- freshType - unifyTypes r (RCons (Label p) ty rest) + unifyTypes r (srcRCons (Label p) ty rest) ps'' <- go ps' ts rest return $ (p, v') : ps'' Just ty -> do v' <- check v ty ps'' <- go ps' (delete (Label p, ty) ts) r return $ (p, v') : ps'' - go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyRecord row) + go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (srcTypeApp tyRecord row) -- | Check the type of a function application, rethrowing errors to provide a better error message. -- @@ -791,11 +796,11 @@ checkFunctionApplication :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -- ^ The function expression - -> Type + -> SourceType -- ^ The type of the function -> Expr -- ^ The argument expression - -> m (Type, Expr) + -> m (SourceType, Expr) -- ^ The result type, and the elaborated term checkFunctionApplication fn fnTy arg = withErrorMessageHint (ErrorInApplication fn fnTy arg) $ do subst <- gets checkSubstitution @@ -805,19 +810,19 @@ checkFunctionApplication fn fnTy arg = withErrorMessageHint (ErrorInApplication checkFunctionApplication' :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr - -> Type + -> SourceType -> Expr - -> m (Type, Expr) -checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg = do + -> m (SourceType, Expr) +checkFunctionApplication' fn (TypeApp _ (TypeApp _ tyFunction' argTy) retTy) arg = do unifyTypes tyFunction' tyFunction arg' <- check arg argTy return (retTy, App fn arg') -checkFunctionApplication' fn (ForAll ident ty _) arg = do +checkFunctionApplication' fn (ForAll _ ident ty _) arg = do replaced <- replaceVarWithUnknown ident ty checkFunctionApplication fn replaced arg -checkFunctionApplication' fn (KindedType ty _) arg = +checkFunctionApplication' fn (KindedType _ ty _) arg = checkFunctionApplication fn ty arg -checkFunctionApplication' fn (ConstrainedType con fnTy) arg = do +checkFunctionApplication' fn (ConstrainedType _ con fnTy) arg = do dicts <- getTypeClassDictionaries hints <- getHints checkFunctionApplication' (App fn (TypeClassDictionary con dicts hints)) fnTy arg diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 04186dbc93..d53002719a 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -17,7 +17,6 @@ module Language.PureScript.TypeChecker.Unify ) where import Prelude.Compat -import Protolude (ordNub) import Control.Arrow (first, second) import Control.Monad @@ -25,8 +24,10 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets, modify) import Control.Monad.Writer.Class (MonadWriter(..)) -import Data.List (sort) +import Data.Function (on) +import Data.List (sortBy, nubBy) import qualified Data.Map as M +import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T @@ -34,18 +35,17 @@ import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Skolems -import Language.PureScript.Label (Label(..)) import Language.PureScript.Types -- | Generate a fresh type variable -freshType :: (MonadState CheckState m) => m Type +freshType :: (MonadState CheckState m) => m SourceType freshType = do t <- gets checkNextType modify $ \st -> st { checkNextType = t + 1 } - return $ TUnknown t + return $ srcTUnknown t -- | Update the substitution to solve a type constraint -solveType :: (MonadError MultipleErrors m, MonadState CheckState m) => Int -> Type -> m () +solveType :: (MonadError MultipleErrors m, MonadState CheckState m) => Int -> SourceType -> m () solveType u t = do occursCheck u t modify $ \cs -> cs { checkSubstitution = @@ -55,69 +55,69 @@ solveType u t = do } -- | Apply a substitution to a type -substituteType :: Substitution -> Type -> Type +substituteType :: Substitution -> SourceType -> SourceType substituteType sub = everywhereOnTypes go where - go (TUnknown u) = + go (TUnknown ann u) = case M.lookup u (substType sub) of - Nothing -> TUnknown u - Just (TUnknown u1) | u1 == u -> TUnknown u1 + Nothing -> TUnknown ann u + Just (TUnknown ann' u1) | u1 == u -> TUnknown ann' u1 Just t -> substituteType sub t go other = other -- | Make sure that an unknown does not occur in a type -occursCheck :: (MonadError MultipleErrors m) => Int -> Type -> m () +occursCheck :: (MonadError MultipleErrors m) => Int -> SourceType -> m () occursCheck _ TUnknown{} = return () occursCheck u t = void $ everywhereOnTypesM go t where - go (TUnknown u') | u == u' = throwError . errorMessage . InfiniteType $ t + go (TUnknown _ u') | u == u' = throwError . errorMessage . InfiniteType $ t go other = return other -- | Compute a list of all unknowns appearing in a type -unknownsInType :: Type -> [Int] +unknownsInType :: Type a -> [(a, Int)] unknownsInType t = everythingOnTypes (.) go t [] where - go :: Type -> [Int] -> [Int] - go (TUnknown u) = (u :) + go :: Type a -> [(a, Int)] -> [(a, Int)] + go (TUnknown ann u) = ((ann, u) :) go _ = id -- | Unify two types, updating the current substitution -unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m () +unifyTypes :: (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m () unifyTypes t1 t2 = do sub <- gets checkSubstitution withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes' (substituteType sub t1) (substituteType sub t2) where - unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return () - unifyTypes' (TUnknown u) t = solveType u t - unifyTypes' t (TUnknown u) = solveType u t - unifyTypes' (ForAll ident1 ty1 sc1) (ForAll ident2 ty2 sc2) = + unifyTypes' (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = return () + unifyTypes' (TUnknown _ u) t = solveType u t + unifyTypes' t (TUnknown _ u) = solveType u t + unifyTypes' (ForAll ann1 ident1 ty1 sc1) (ForAll ann2 ident2 ty2 sc2) = case (sc1, sc2) of (Just sc1', Just sc2') -> do sko <- newSkolemConstant - let sk1 = skolemize ident1 sko sc1' Nothing ty1 - let sk2 = skolemize ident2 sko sc2' Nothing ty2 + let sk1 = skolemize ann1 ident1 sko sc1' ty1 + let sk2 = skolemize ann2 ident2 sko sc2' ty2 sk1 `unifyTypes` sk2 _ -> internalError "unifyTypes: unspecified skolem scope" - unifyTypes' (ForAll ident ty1 (Just sc)) ty2 = do + unifyTypes' (ForAll ann ident ty1 (Just sc)) ty2 = do sko <- newSkolemConstant - let sk = skolemize ident sko sc Nothing ty1 + let sk = skolemize ann ident sko sc ty1 sk `unifyTypes` ty2 unifyTypes' ForAll{} _ = internalError "unifyTypes: unspecified skolem scope" unifyTypes' ty f@ForAll{} = f `unifyTypes` ty - unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return () - unifyTypes' ty1@(TypeConstructor c1) ty2@(TypeConstructor c2) = + unifyTypes' (TypeVar _ v1) (TypeVar _ v2) | v1 == v2 = return () + unifyTypes' ty1@(TypeConstructor _ c1) ty2@(TypeConstructor _ c2) = guardWith (errorMessage (TypesDoNotUnify ty1 ty2)) (c1 == c2) - unifyTypes' (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = return () - unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do + unifyTypes' (TypeLevelString _ s1) (TypeLevelString _ s2) | s1 == s2 = return () + unifyTypes' (TypeApp _ t3 t4) (TypeApp _ t5 t6) = do t3 `unifyTypes` t5 t4 `unifyTypes` t6 - unifyTypes' (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = return () - unifyTypes' (KindedType ty1 _) ty2 = ty1 `unifyTypes` ty2 - unifyTypes' ty1 (KindedType ty2 _) = ty1 `unifyTypes` ty2 + unifyTypes' (Skolem _ _ s1 _) (Skolem _ _ s2 _) | s1 == s2 = return () + unifyTypes' (KindedType _ ty1 _) ty2 = ty1 `unifyTypes` ty2 + unifyTypes' ty1 (KindedType _ ty2 _) = ty1 `unifyTypes` ty2 unifyTypes' r1@RCons{} r2 = unifyRows r1 r2 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2 - unifyTypes' r1@REmpty r2 = unifyRows r1 r2 - unifyTypes' r1 r2@REmpty = unifyRows r1 r2 + unifyTypes' r1@REmpty{} r2 = unifyRows r1 r2 + unifyTypes' r1 r2@REmpty{} = unifyRows r1 r2 unifyTypes' ty1@ConstrainedType{} ty2 = throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2 unifyTypes' t3 t4@ConstrainedType{} = unifyTypes' t4 t3 @@ -132,38 +132,38 @@ unifyTypes t1 t2 = do -- -- Note: importantly, we preserve the order of the types with a given label. alignRowsWith - :: (Type -> Type -> a) - -> Type - -> Type - -> ([a], (([(Label, Type)], Type), ([(Label, Type)], Type))) + :: (Type a -> Type a -> r) + -> Type a + -> Type a + -> ([r], (([RowListItem a], Type a), ([RowListItem a], Type a))) alignRowsWith f ty1 ty2 = go s1 s2 where (s1, tail1) = rowToSortedList ty1 (s2, tail2) = rowToSortedList ty2 go [] r = ([], (([], tail1), (r, tail2))) go r [] = ([], ((r, tail1), ([], tail2))) - go lhs@((l1, t1) : r1) rhs@((l2, t2) : r2) - | l1 < l2 = (second . first . first) ((l1, t1) :) (go r1 rhs) - | l2 < l1 = (second . second . first) ((l2, t2) :) (go lhs r2) + go lhs@(RowListItem a1 l1 t1 : r1) rhs@(RowListItem a2 l2 t2 : r2) + | l1 < l2 = (second . first . first) (RowListItem a1 l1 t1 :) (go r1 rhs) + | l2 < l1 = (second . second . first) (RowListItem a2 l2 t2 :) (go lhs r2) | otherwise = first (f t1 t2 :) (go r1 r2) -- | Unify two rows, updating the current substitution -- -- Common labels are identified and unified. Remaining labels and types are unified with a -- trailing row unification variable, if appropriate. -unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m () +unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m () unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where (matches, rest) = alignRowsWith unifyTypes r1 r2 - unifyTails :: ([(Label, Type)], Type) -> ([(Label, Type)], Type) -> m () - unifyTails ([], TUnknown u) (sd, r) = solveType u (rowFromList (sd, r)) - unifyTails (sd, r) ([], TUnknown u) = solveType u (rowFromList (sd, r)) - unifyTails ([], REmpty) ([], REmpty) = return () - unifyTails ([], TypeVar v1) ([], TypeVar v2) | v1 == v2 = return () + unifyTails :: ([RowListItem SourceAnn], SourceType) -> ([RowListItem SourceAnn], SourceType) -> m () + unifyTails ([], TUnknown _ u) (sd, r) = solveType u (rowFromList (sd, r)) + unifyTails (sd, r) ([], TUnknown _ u) = solveType u (rowFromList (sd, r)) + unifyTails ([], REmpty _) ([], REmpty _) = return () + unifyTails ([], TypeVar _ v1) ([], TypeVar _ v2) | v1 == v2 = return () unifyTails ([], Skolem _ s1 _ _) ([], Skolem _ s2 _ _) | s1 == s2 = return () - unifyTails (sd1, TUnknown u1) (sd2, TUnknown u2) = do - forM_ sd1 $ \(_, t) -> occursCheck u2 t - forM_ sd2 $ \(_, t) -> occursCheck u1 t + unifyTails (sd1, TUnknown _ u1) (sd2, TUnknown _ u2) = do + forM_ sd1 $ occursCheck u2 . rowListType + forM_ sd2 $ occursCheck u1 . rowListType rest' <- freshType solveType u1 (rowFromList (sd2, rest')) solveType u2 (rowFromList (sd1, rest')) @@ -173,7 +173,7 @@ unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where -- | -- Replace a single type variable with a new unification variable -- -replaceVarWithUnknown :: (MonadState CheckState m) => Text -> Type -> m Type +replaceVarWithUnknown :: (MonadState CheckState m) => Text -> SourceType -> m SourceType replaceVarWithUnknown ident ty = do tu <- freshType return $ replaceTypeVars ident tu ty @@ -181,25 +181,25 @@ replaceVarWithUnknown ident ty = do -- | -- Replace type wildcards with unknowns -- -replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState CheckState m) => Type -> m Type +replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState CheckState m) => SourceType -> m SourceType replaceTypeWildcards = everywhereOnTypesM replace where - replace (TypeWildcard ss) = do + replace (TypeWildcard ann) = do t <- freshType ctx <- getLocalContext - warnWithPosition ss $ tell . errorMessage $ WildcardInferredType t ctx + warnWithPosition (fst ann) $ tell . errorMessage $ WildcardInferredType t ctx return t replace other = return other -- | -- Replace outermost unsolved unification variables with named type variables -- -varIfUnknown :: Type -> Type +varIfUnknown :: SourceType -> SourceType varIfUnknown ty = - let unks = ordNub $ unknownsInType ty + let unks = nubBy ((==) `on` snd) $ unknownsInType ty toName = T.cons 't' . T.pack . show ty' = everywhereOnTypes typeToVar ty - typeToVar :: Type -> Type - typeToVar (TUnknown u) = TypeVar (toName u) + typeToVar :: SourceType -> SourceType + typeToVar (TUnknown ann u) = TypeVar ann (toName u) typeToVar t = t - in mkForAll (sort . map toName $ unks) ty' + in mkForAll (sortBy (comparing snd) . fmap (fmap toName) $ unks) ty' diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 84b569ca80..7f1ad25f09 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -28,9 +28,9 @@ data TypeClassDictionaryInScope v -- | The name of the type class to which this type class instance applies , tcdClassName :: Qualified (ProperName 'ClassName) -- | The types to which this type class instance applies - , tcdInstanceTypes :: [Type] + , tcdInstanceTypes :: [SourceType] -- | Type class dependencies which must be satisfied to construct this dictionary - , tcdDependencies :: Maybe [Constraint] + , tcdDependencies :: Maybe [SourceConstraint] } deriving (Show, Functor, Foldable, Traversable, Generic) diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 3ec79431a1..13d6a30417 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -1,6 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} -- | -- Data types for types @@ -15,6 +17,7 @@ import Control.DeepSeq (NFData) import Control.Monad ((<=<)) import qualified Data.Aeson as A import qualified Data.Aeson.TH as A +import Data.Foldable (fold) import Data.List (sortBy) import Data.Ord (comparing) import Data.Maybe (fromMaybe) @@ -28,6 +31,9 @@ import Language.PureScript.Names import Language.PureScript.Label (Label) import Language.PureScript.PSString (PSString) +type SourceType = Type SourceAnn +type SourceConstraint = Constraint SourceAnn + -- | -- An identifier for the scope of a skolem variable -- @@ -39,52 +45,97 @@ instance NFData SkolemScope -- | -- The type of types -- -data Type +data Type a -- | A unification variable of type Type - = TUnknown Int + = TUnknown a Int -- | A named type variable - | TypeVar Text + | TypeVar a Text -- | A type-level string - | TypeLevelString PSString + | TypeLevelString a PSString -- | A type wildcard, as would appear in a partial type synonym - | TypeWildcard SourceSpan + | TypeWildcard a -- | A type constructor - | TypeConstructor (Qualified (ProperName 'TypeName)) + | TypeConstructor a (Qualified (ProperName 'TypeName)) -- | A type operator. This will be desugared into a type constructor during the -- "operators" phase of desugaring. - | TypeOp (Qualified (OpName 'TypeOpName)) + | TypeOp a (Qualified (OpName 'TypeOpName)) -- | A type application - | TypeApp Type Type + | TypeApp a (Type a) (Type a) -- | Forall quantifier - | ForAll Text Type (Maybe SkolemScope) + | ForAll a Text (Type a) (Maybe SkolemScope) -- | A type with a set of type class constraints - | ConstrainedType Constraint Type + | ConstrainedType a (Constraint a) (Type a) -- | A skolem constant - | Skolem Text Int SkolemScope (Maybe SourceSpan) + | Skolem a Text Int SkolemScope -- | An empty row - | REmpty + | REmpty a -- | A non-empty row - | RCons Label Type Type + | RCons a Label (Type a) (Type a) -- | A type with a kind annotation - | KindedType Type Kind + | KindedType a (Type a) (Kind a) -- | A placeholder used in pretty printing - | PrettyPrintFunction Type Type + | PrettyPrintFunction a (Type a) (Type a) -- | A placeholder used in pretty printing - | PrettyPrintObject Type + | PrettyPrintObject a (Type a) -- | A placeholder used in pretty printing - | PrettyPrintForAll [Text] Type + | PrettyPrintForAll a [Text] (Type a) -- | Binary operator application. During the rebracketing phase of desugaring, -- this data constructor will be removed. - | BinaryNoParensType Type Type Type + | BinaryNoParensType a (Type a) (Type a) (Type a) -- | Explicit parentheses. During the rebracketing phase of desugaring, this -- data constructor will be removed. -- -- Note: although it seems this constructor is not used, it _is_ useful, -- since it prevents certain traversals from matching. - | ParensInType Type - deriving (Show, Eq, Ord, Generic) + | ParensInType a (Type a) + deriving (Show, Generic, Functor, Foldable, Traversable) + +instance NFData a => NFData (Type a) + +srcTUnknown :: Int -> SourceType +srcTUnknown = TUnknown NullSourceAnn + +srcTypeVar :: Text -> SourceType +srcTypeVar = TypeVar NullSourceAnn + +srcTypeLevelString :: PSString -> SourceType +srcTypeLevelString = TypeLevelString NullSourceAnn + +srcTypeWildcard :: SourceType +srcTypeWildcard = TypeWildcard NullSourceAnn + +srcTypeConstructor :: Qualified (ProperName 'TypeName) -> SourceType +srcTypeConstructor = TypeConstructor NullSourceAnn + +srcTypeOp :: Qualified (OpName 'TypeOpName) -> SourceType +srcTypeOp = TypeOp NullSourceAnn + +srcTypeApp :: SourceType -> SourceType -> SourceType +srcTypeApp = TypeApp NullSourceAnn + +srcForAll :: Text -> SourceType -> Maybe SkolemScope -> SourceType +srcForAll = ForAll NullSourceAnn -instance NFData Type +srcConstrainedType :: SourceConstraint -> SourceType -> SourceType +srcConstrainedType = ConstrainedType NullSourceAnn + +srcSkolem :: Text -> Int -> SkolemScope -> SourceType +srcSkolem = Skolem NullSourceAnn + +srcREmpty :: SourceType +srcREmpty = REmpty NullSourceAnn + +srcRCons :: Label -> SourceType -> SourceType -> SourceType +srcRCons = RCons NullSourceAnn + +srcKindedType :: SourceType -> SourceKind -> SourceType +srcKindedType = KindedType NullSourceAnn + +srcBinaryNoParensType :: SourceType -> SourceType -> SourceType -> SourceType +srcBinaryNoParensType = BinaryNoParensType NullSourceAnn + +srcParensInType :: SourceType -> SourceType +srcParensInType = ParensInType NullSourceAnn -- | Additional data relevant to type class constraints data ConstraintData @@ -99,77 +150,92 @@ data ConstraintData instance NFData ConstraintData -- | A typeclass constraint -data Constraint = Constraint - { constraintClass :: Qualified (ProperName 'ClassName) +data Constraint a = Constraint + { constraintAnn :: a + -- ^ constraint annotation + , constraintClass :: Qualified (ProperName 'ClassName) -- ^ constraint class name - , constraintArgs :: [Type] + , constraintArgs :: [Type a] -- ^ type arguments , constraintData :: Maybe ConstraintData -- ^ additional data relevant to this constraint - } deriving (Show, Eq, Ord, Generic) + } deriving (Show, Generic, Functor, Foldable, Traversable) + +instance NFData a => NFData (Constraint a) -instance NFData Constraint +srcConstraint :: Qualified (ProperName 'ClassName) -> [SourceType] -> Maybe ConstraintData -> SourceConstraint +srcConstraint = Constraint NullSourceAnn -mapConstraintArgs :: ([Type] -> [Type]) -> Constraint -> Constraint +mapConstraintArgs :: ([Type a] -> [Type a]) -> Constraint a -> Constraint a mapConstraintArgs f c = c { constraintArgs = f (constraintArgs c) } -overConstraintArgs :: Functor f => ([Type] -> f [Type]) -> Constraint -> f Constraint +overConstraintArgs :: Functor f => ([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a) overConstraintArgs f c = (\args -> c { constraintArgs = args }) <$> f (constraintArgs c) $(A.deriveJSON A.defaultOptions ''Type) $(A.deriveJSON A.defaultOptions ''Constraint) $(A.deriveJSON A.defaultOptions ''ConstraintData) +data RowListItem a = RowListItem + { rowListAnn :: a + , rowListLabel :: Label + , rowListType :: Type a + } deriving (Show, Generic, Functor, Foldable, Traversable) + +srcRowListItem :: Label -> SourceType -> RowListItem SourceAnn +srcRowListItem = RowListItem NullSourceAnn + -- | Convert a row to a list of pairs of labels and types -rowToList :: Type -> ([(Label, Type)], Type) +rowToList :: Type a -> ([RowListItem a], Type a) rowToList = go where - go (RCons name ty row) = - first ((name, ty) :) (rowToList row) + go (RCons ann name ty row) = + first (RowListItem ann name ty :) (rowToList row) go r = ([], r) -- | Convert a row to a list of pairs of labels and types, sorted by the labels. -rowToSortedList :: Type -> ([(Label, Type)], Type) -rowToSortedList = first (sortBy (comparing fst)) . rowToList +rowToSortedList :: Type a -> ([RowListItem a], Type a) +rowToSortedList = first (sortBy (comparing rowListLabel)) . rowToList -- | Convert a list of labels and types to a row -rowFromList :: ([(Label, Type)], Type) -> Type -rowFromList (xs, r) = foldr (uncurry RCons) r xs +rowFromList :: ([RowListItem a], Type a) -> Type a +rowFromList (xs, r) = foldr (\(RowListItem ann name ty) -> RCons ann name ty) r xs -- | Check whether a type is a monotype -isMonoType :: Type -> Bool +isMonoType :: Type a -> Bool isMonoType ForAll{} = False -isMonoType (ParensInType t) = isMonoType t -isMonoType (KindedType t _) = isMonoType t +isMonoType (ParensInType _ t) = isMonoType t +isMonoType (KindedType _ t _) = isMonoType t isMonoType _ = True -- | Universally quantify a type -mkForAll :: [Text] -> Type -> Type -mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args +mkForAll :: [(a, Text)] -> Type a -> Type a +mkForAll args ty = foldl (\t (ann, arg) -> ForAll ann arg t Nothing) ty args -- | Replace a type variable, taking into account variable shadowing -replaceTypeVars :: Text -> Type -> Type -> Type +replaceTypeVars :: Text -> Type a -> Type a -> Type a replaceTypeVars v r = replaceAllTypeVars [(v, r)] -- | Replace named type variables with types -replaceAllTypeVars :: [(Text, Type)] -> Type -> Type +replaceAllTypeVars :: [(Text, Type a)] -> Type a -> Type a replaceAllTypeVars = go [] where - go :: [Text] -> [(Text, Type)] -> Type -> Type - go _ m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m) - go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2) - go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f - | v `elem` usedVars = - let v' = genName v (keys ++ bs ++ usedVars) - t' = go bs [(v, TypeVar v')] t - in ForAll v' (go (v' : bs) m t') sco - | otherwise = ForAll v (go (v : bs) m t) sco + go :: [Text] -> [(Text, Type a)] -> Type a -> Type a + go _ m (TypeVar ann v) = fromMaybe (TypeVar ann v) (v `lookup` m) + go bs m (TypeApp ann t1 t2) = TypeApp ann (go bs m t1) (go bs m t2) + go bs m f@(ForAll ann v t sco) + | v `elem` keys = go bs (filter ((/= v) . fst) m) f + | v `elem` usedVars = + let v' = genName v (keys ++ bs ++ usedVars) + t' = go bs [(v, TypeVar ann v')] t + in ForAll ann v' (go (v' : bs) m t') sco + | otherwise = ForAll ann v (go (v : bs) m t) sco where keys = map fst m usedVars = concatMap (usedTypeVariables . snd) m - go bs m (ConstrainedType c t) = ConstrainedType (mapConstraintArgs (map (go bs m)) c) (go bs m t) - go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r) - go bs m (KindedType t k) = KindedType (go bs m t) k - go bs m (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go bs m t1) (go bs m t2) (go bs m t3) - go bs m (ParensInType t) = ParensInType (go bs m t) + go bs m (ConstrainedType ann c t) = ConstrainedType ann (mapConstraintArgs (map (go bs m)) c) (go bs m t) + go bs m (RCons ann name' t r) = RCons ann name' (go bs m t) (go bs m r) + go bs m (KindedType ann t k) = KindedType ann (go bs m t) k + go bs m (BinaryNoParensType ann t1 t2 t3) = BinaryNoParensType ann (go bs m t1) (go bs m t2) (go bs m t3) + go bs m (ParensInType ann t) = ParensInType ann (go bs m t) go _ _ ty = ty genName orig inUse = try' 0 where @@ -178,131 +244,263 @@ replaceAllTypeVars = go [] where | otherwise = orig <> T.pack (show n) -- | Collect all type variables appearing in a type -usedTypeVariables :: Type -> [Text] +usedTypeVariables :: Type a -> [Text] usedTypeVariables = ordNub . everythingOnTypes (++) go where - go (TypeVar v) = [v] + go (TypeVar _ v) = [v] go _ = [] -- | Collect all free type variables appearing in a type -freeTypeVariables :: Type -> [Text] +freeTypeVariables :: Type a -> [Text] freeTypeVariables = ordNub . go [] where - go :: [Text] -> Type -> [Text] - go bound (TypeVar v) | v `notElem` bound = [v] - go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2 - go bound (ForAll v t _) = go (v : bound) t - go bound (ConstrainedType c t) = concatMap (go bound) (constraintArgs c) ++ go bound t - go bound (RCons _ t r) = go bound t ++ go bound r - go bound (KindedType t _) = go bound t - go bound (BinaryNoParensType t1 t2 t3) = go bound t1 ++ go bound t2 ++ go bound t3 - go bound (ParensInType t) = go bound t + go :: [Text] -> Type a -> [Text] + go bound (TypeVar _ v) | v `notElem` bound = [v] + go bound (TypeApp _ t1 t2) = go bound t1 ++ go bound t2 + go bound (ForAll _ v t _) = go (v : bound) t + go bound (ConstrainedType _ c t) = concatMap (go bound) (constraintArgs c) ++ go bound t + go bound (RCons _ _ t r) = go bound t ++ go bound r + go bound (KindedType _ t _) = go bound t + go bound (BinaryNoParensType _ t1 t2 t3) = go bound t1 ++ go bound t2 ++ go bound t3 + go bound (ParensInType _ t) = go bound t go _ _ = [] -- | Universally quantify over all type variables appearing free in a type -quantify :: Type -> Type -quantify ty = foldr (\arg t -> ForAll arg t Nothing) ty $ freeTypeVariables ty +quantify :: Type a -> Type a +quantify ty = foldr (\arg t -> ForAll ann arg t Nothing) ty $ freeTypeVariables ty + where + ann = annotationForType ty -- | Move all universal quantifiers to the front of a type -moveQuantifiersToFront :: Type -> Type +moveQuantifiersToFront :: Type a -> Type a moveQuantifiersToFront = go [] [] where - go qs cs (ForAll q ty sco) = go ((q, sco) : qs) cs ty - go qs cs (ConstrainedType c ty) = go qs (c : cs) ty - go qs cs ty = foldl (\ty' (q, sco) -> ForAll q ty' sco) (foldl (flip ConstrainedType) ty cs) qs + go qs cs (ForAll ann q ty sco) = go ((ann, q, sco) : qs) cs ty + go qs cs (ConstrainedType ann c ty) = go qs ((ann, c) : cs) ty + go qs cs ty = foldl (\ty' (ann, q, sco) -> ForAll ann q ty' sco) (foldl (\ty' (ann, c) -> ConstrainedType ann c ty') ty cs) qs -- | Check if a type contains wildcards -containsWildcards :: Type -> Bool +containsWildcards :: Type a -> Bool containsWildcards = everythingOnTypes (||) go where - go :: Type -> Bool + go :: Type a -> Bool go TypeWildcard{} = True go _ = False -- | Check if a type contains `forall` -containsForAll :: Type -> Bool +containsForAll :: Type a -> Bool containsForAll = everythingOnTypes (||) go where - go :: Type -> Bool + go :: Type a -> Bool go ForAll{} = True go _ = False -everywhereOnTypes :: (Type -> Type) -> Type -> Type +everywhereOnTypes :: (Type a -> Type a) -> Type a -> Type a everywhereOnTypes f = go where - go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2)) - go (ForAll arg ty sco) = f (ForAll arg (go ty) sco) - go (ConstrainedType c ty) = f (ConstrainedType (mapConstraintArgs (map go) c) (go ty)) - go (RCons name ty rest) = f (RCons name (go ty) (go rest)) - go (KindedType ty k) = f (KindedType (go ty) k) - go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2)) - go (PrettyPrintObject t) = f (PrettyPrintObject (go t)) - go (PrettyPrintForAll args t) = f (PrettyPrintForAll args (go t)) - go (BinaryNoParensType t1 t2 t3) = f (BinaryNoParensType (go t1) (go t2) (go t3)) - go (ParensInType t) = f (ParensInType (go t)) + go (TypeApp ann t1 t2) = f (TypeApp ann (go t1) (go t2)) + go (ForAll ann arg ty sco) = f (ForAll ann arg (go ty) sco) + go (ConstrainedType ann c ty) = f (ConstrainedType ann (mapConstraintArgs (map go) c) (go ty)) + go (RCons ann name ty rest) = f (RCons ann name (go ty) (go rest)) + go (KindedType ann ty k) = f (KindedType ann (go ty) k) + go (PrettyPrintFunction ann t1 t2) = f (PrettyPrintFunction ann (go t1) (go t2)) + go (PrettyPrintObject ann t) = f (PrettyPrintObject ann (go t)) + go (PrettyPrintForAll ann args t) = f (PrettyPrintForAll ann args (go t)) + go (BinaryNoParensType ann t1 t2 t3) = f (BinaryNoParensType ann (go t1) (go t2) (go t3)) + go (ParensInType ann t) = f (ParensInType ann (go t)) go other = f other -everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type +everywhereOnTypesTopDown :: (Type a -> Type a) -> Type a -> Type a everywhereOnTypesTopDown f = go . f where - go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2)) - go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco - go (ConstrainedType c ty) = ConstrainedType (mapConstraintArgs (map (go . f)) c) (go (f ty)) - go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest)) - go (KindedType ty k) = KindedType (go (f ty)) k - go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2)) - go (PrettyPrintObject t) = PrettyPrintObject (go (f t)) - go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t)) - go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go (f t1)) (go (f t2)) (go (f t3)) - go (ParensInType t) = ParensInType (go (f t)) + go (TypeApp ann t1 t2) = TypeApp ann (go (f t1)) (go (f t2)) + go (ForAll ann arg ty sco) = ForAll ann arg (go (f ty)) sco + go (ConstrainedType ann c ty) = ConstrainedType ann (mapConstraintArgs (map (go . f)) c) (go (f ty)) + go (RCons ann name ty rest) = RCons ann name (go (f ty)) (go (f rest)) + go (KindedType ann ty k) = KindedType ann (go (f ty)) k + go (PrettyPrintFunction ann t1 t2) = PrettyPrintFunction ann (go (f t1)) (go (f t2)) + go (PrettyPrintObject ann t) = PrettyPrintObject ann (go (f t)) + go (PrettyPrintForAll ann args t) = PrettyPrintForAll ann args (go (f t)) + go (BinaryNoParensType ann t1 t2 t3) = BinaryNoParensType ann (go (f t1)) (go (f t2)) (go (f t3)) + go (ParensInType ann t) = ParensInType ann (go (f t)) go other = f other -everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type +everywhereOnTypesM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (Type a) everywhereOnTypesM f = go where - go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f - go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f - go (ConstrainedType c ty) = (ConstrainedType <$> overConstraintArgs (mapM go) c <*> go ty) >>= f - go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f - go (KindedType ty k) = (KindedType <$> go ty <*> pure k) >>= f - go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f - go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f - go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f - go (BinaryNoParensType t1 t2 t3) = (BinaryNoParensType <$> go t1 <*> go t2 <*> go t3) >>= f - go (ParensInType t) = (ParensInType <$> go t) >>= f + go (TypeApp ann t1 t2) = (TypeApp ann <$> go t1 <*> go t2) >>= f + go (ForAll ann arg ty sco) = (ForAll ann arg <$> go ty <*> pure sco) >>= f + go (ConstrainedType ann c ty) = (ConstrainedType ann <$> overConstraintArgs (mapM go) c <*> go ty) >>= f + go (RCons ann name ty rest) = (RCons ann name <$> go ty <*> go rest) >>= f + go (KindedType ann ty k) = (KindedType ann <$> go ty <*> pure k) >>= f + go (PrettyPrintFunction ann t1 t2) = (PrettyPrintFunction ann <$> go t1 <*> go t2) >>= f + go (PrettyPrintObject ann t) = (PrettyPrintObject ann <$> go t) >>= f + go (PrettyPrintForAll ann args t) = (PrettyPrintForAll ann args <$> go t) >>= f + go (BinaryNoParensType ann t1 t2 t3) = (BinaryNoParensType ann <$> go t1 <*> go t2 <*> go t3) >>= f + go (ParensInType ann t) = (ParensInType ann <$> go t) >>= f go other = f other -everywhereOnTypesTopDownM :: Monad m => (Type -> m Type) -> Type -> m Type +everywhereOnTypesTopDownM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (Type a) everywhereOnTypesTopDownM f = go <=< f where - go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go) - go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco - go (ConstrainedType c ty) = ConstrainedType <$> overConstraintArgs (mapM (go <=< f)) c <*> (f ty >>= go) - go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go) - go (KindedType ty k) = KindedType <$> (f ty >>= go) <*> pure k - go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go) - go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go) - go (PrettyPrintForAll args t) = PrettyPrintForAll args <$> (f t >>= go) - go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType <$> (f t1 >>= go) <*> (f t2 >>= go) <*> (f t3 >>= go) - go (ParensInType t) = ParensInType <$> (f t >>= go) + go (TypeApp ann t1 t2) = TypeApp ann <$> (f t1 >>= go) <*> (f t2 >>= go) + go (ForAll ann arg ty sco) = ForAll ann arg <$> (f ty >>= go) <*> pure sco + go (ConstrainedType ann c ty) = ConstrainedType ann <$> overConstraintArgs (mapM (go <=< f)) c <*> (f ty >>= go) + go (RCons ann name ty rest) = RCons ann name <$> (f ty >>= go) <*> (f rest >>= go) + go (KindedType ann ty k) = KindedType ann <$> (f ty >>= go) <*> pure k + go (PrettyPrintFunction ann t1 t2) = PrettyPrintFunction ann <$> (f t1 >>= go) <*> (f t2 >>= go) + go (PrettyPrintObject ann t) = PrettyPrintObject ann <$> (f t >>= go) + go (PrettyPrintForAll ann args t) = PrettyPrintForAll ann args <$> (f t >>= go) + go (BinaryNoParensType ann t1 t2 t3) = BinaryNoParensType ann <$> (f t1 >>= go) <*> (f t2 >>= go) <*> (f t3 >>= go) + go (ParensInType ann t) = ParensInType ann <$> (f t >>= go) go other = f other -everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r +everythingOnTypes :: (r -> r -> r) -> (Type a -> r) -> Type a -> r everythingOnTypes (<+>) f = go where - go t@(TypeApp t1 t2) = f t <+> go t1 <+> go t2 - go t@(ForAll _ ty _) = f t <+> go ty - go t@(ConstrainedType c ty) = foldl (<+>) (f t) (map go (constraintArgs c)) <+> go ty - go t@(RCons _ ty rest) = f t <+> go ty <+> go rest - go t@(KindedType ty _) = f t <+> go ty - go t@(PrettyPrintFunction t1 t2) = f t <+> go t1 <+> go t2 - go t@(PrettyPrintObject t1) = f t <+> go t1 - go t@(PrettyPrintForAll _ t1) = f t <+> go t1 - go t@(BinaryNoParensType t1 t2 t3) = f t <+> go t1 <+> go t2 <+> go t3 - go t@(ParensInType t1) = f t <+> go t1 + go t@(TypeApp _ t1 t2) = f t <+> go t1 <+> go t2 + go t@(ForAll _ _ ty _) = f t <+> go ty + go t@(ConstrainedType _ c ty) = foldl (<+>) (f t) (map go (constraintArgs c)) <+> go ty + go t@(RCons _ _ ty rest) = f t <+> go ty <+> go rest + go t@(KindedType _ ty _) = f t <+> go ty + go t@(PrettyPrintFunction _ t1 t2) = f t <+> go t1 <+> go t2 + go t@(PrettyPrintObject _ t1) = f t <+> go t1 + go t@(PrettyPrintForAll _ _ t1) = f t <+> go t1 + go t@(BinaryNoParensType _ t1 t2 t3) = f t <+> go t1 <+> go t2 <+> go t3 + go t@(ParensInType _ t1) = f t <+> go t1 go other = f other -everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type -> (s, r)) -> Type -> r +everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type a -> (s, r)) -> Type a -> r everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 where go' s t = let (s', r) = f s t in r <+> go s' t - go s (TypeApp t1 t2) = go' s t1 <+> go' s t2 - go s (ForAll _ ty _) = go' s ty - go s (ConstrainedType c ty) = foldl (<+>) r0 (map (go' s) (constraintArgs c)) <+> go' s ty - go s (RCons _ ty rest) = go' s ty <+> go' s rest - go s (KindedType ty _) = go' s ty - go s (PrettyPrintFunction t1 t2) = go' s t1 <+> go' s t2 - go s (PrettyPrintObject t1) = go' s t1 - go s (PrettyPrintForAll _ t1) = go' s t1 - go s (BinaryNoParensType t1 t2 t3) = go' s t1 <+> go' s t2 <+> go' s t3 - go s (ParensInType t1) = go' s t1 + go s (TypeApp _ t1 t2) = go' s t1 <+> go' s t2 + go s (ForAll _ _ ty _) = go' s ty + go s (ConstrainedType _ c ty) = foldl (<+>) r0 (map (go' s) (constraintArgs c)) <+> go' s ty + go s (RCons _ _ ty rest) = go' s ty <+> go' s rest + go s (KindedType _ ty _) = go' s ty + go s (PrettyPrintFunction _ t1 t2) = go' s t1 <+> go' s t2 + go s (PrettyPrintObject _ t1) = go' s t1 + go s (PrettyPrintForAll _ _ t1) = go' s t1 + go s (BinaryNoParensType _ t1 t2 t3) = go' s t1 <+> go' s t2 <+> go' s t3 + go s (ParensInType _ t1) = go' s t1 go _ _ = r0 + +annotationForType :: Type a -> a +annotationForType (TUnknown a _) = a +annotationForType (TypeVar a _) = a +annotationForType (TypeLevelString a _) = a +annotationForType (TypeWildcard a) = a +annotationForType (TypeConstructor a _) = a +annotationForType (TypeOp a _) = a +annotationForType (TypeApp a _ _) = a +annotationForType (ForAll a _ _ _) = a +annotationForType (ConstrainedType a _ _) = a +annotationForType (Skolem a _ _ _) = a +annotationForType (REmpty a) = a +annotationForType (RCons a _ _ _) = a +annotationForType (KindedType a _ _) = a +annotationForType (PrettyPrintFunction a _ _) = a +annotationForType (PrettyPrintObject a _) = a +annotationForType (PrettyPrintForAll a _ _) = a +annotationForType (BinaryNoParensType a _ _ _) = a +annotationForType (ParensInType a _) = a + +instance Eq (Type a) where + (==) = eqType + +instance Ord (Type a) where + compare = compareType + +eqType :: Type a -> Type b -> Bool +eqType (TUnknown _ a) (TUnknown _ a') = a == a' +eqType (TypeVar _ a) (TypeVar _ a') = a == a' +eqType (TypeLevelString _ a) (TypeLevelString _ a') = a == a' +eqType (TypeWildcard _) (TypeWildcard _) = True +eqType (TypeConstructor _ a) (TypeConstructor _ a') = a == a' +eqType (TypeOp _ a) (TypeOp _ a') = a == a' +eqType (TypeApp _ a b) (TypeApp _ a' b') = eqType a a' && eqType b b' +eqType (ForAll _ a b c) (ForAll _ a' b' c') = a == a' && eqType b b' && c == c' +eqType (ConstrainedType _ a b) (ConstrainedType _ a' b') = eqConstraint a a' && eqType b b' +eqType (Skolem _ a b c) (Skolem _ a' b' c') = a == a' && b == b' && c == c' +eqType (REmpty _) (REmpty _) = True +eqType (RCons _ a b c) (RCons _ a' b' c') = a == a' && eqType b b' && eqType c c' +eqType (KindedType _ a b) (KindedType _ a' b') = eqType a a' && eqKind b b' +eqType (PrettyPrintFunction _ a b) (PrettyPrintFunction _ a' b') = eqType a a' && eqType b b' +eqType (PrettyPrintObject _ a) (PrettyPrintObject _ a') = eqType a a' +eqType (PrettyPrintForAll _ a b) (PrettyPrintForAll _ a' b') = a == a' && eqType b b' +eqType (BinaryNoParensType _ a b c) (BinaryNoParensType _ a' b' c') = eqType a a' && eqType b b' && eqType c c' +eqType (ParensInType _ a) (ParensInType _ a') = eqType a a' +eqType _ _ = False + +compareType :: Type a -> Type b -> Ordering +compareType (TUnknown _ a) (TUnknown _ a') = compare a a' +compareType (TUnknown {}) _ = LT + +compareType (TypeVar _ a) (TypeVar _ a') = compare a a' +compareType (TypeVar {}) _ = LT +compareType _ (TypeVar {}) = GT + +compareType (TypeLevelString _ a) (TypeLevelString _ a') = compare a a' +compareType (TypeLevelString {}) _ = LT +compareType _ (TypeLevelString {}) = GT + +compareType (TypeWildcard _) (TypeWildcard _) = EQ +compareType (TypeWildcard _) _ = LT +compareType _ (TypeWildcard _) = GT + +compareType (TypeConstructor _ a) (TypeConstructor _ a') = compare a a' +compareType (TypeConstructor {}) _ = LT +compareType _ (TypeConstructor {}) = GT + +compareType (TypeOp _ a) (TypeOp _ a') = compare a a' +compareType (TypeOp {}) _ = LT +compareType _ (TypeOp {}) = GT + +compareType (TypeApp _ a b) (TypeApp _ a' b') = compareType a a' <> compareType b b' +compareType (TypeApp {}) _ = LT +compareType _ (TypeApp {}) = GT + +compareType (ForAll _ a b c) (ForAll _ a' b' c') = compare a a' <> compareType b b' <> compare c c' +compareType (ForAll {}) _ = LT +compareType _ (ForAll {}) = GT + +compareType (ConstrainedType _ a b) (ConstrainedType _ a' b') = compareConstraint a a' <> compareType b b' +compareType (ConstrainedType {}) _ = LT +compareType _ (ConstrainedType {}) = GT + +compareType (Skolem _ a b c) (Skolem _ a' b' c') = compare a a' <> compare b b' <> compare c c' +compareType (Skolem {}) _ = LT +compareType _ (Skolem {}) = GT + +compareType (REmpty _) (REmpty _) = EQ +compareType (REmpty _) _ = LT +compareType _ (REmpty _) = GT + +compareType (RCons _ a b c) (RCons _ a' b' c') = compare a a' <> compareType b b' <> compareType c c' +compareType (RCons {}) _ = LT +compareType _ (RCons {}) = GT + +compareType (KindedType _ a b) (KindedType _ a' b') = compareType a a' <> compareKind b b' +compareType (KindedType {}) _ = LT +compareType _ (KindedType {}) = GT + +compareType (PrettyPrintFunction _ a b) (PrettyPrintFunction _ a' b') = compareType a a' <> compareType b b' +compareType (PrettyPrintFunction {}) _ = LT +compareType _ (PrettyPrintFunction {}) = GT + +compareType (PrettyPrintObject _ a) (PrettyPrintObject _ a') = compareType a a' +compareType (PrettyPrintObject {}) _ = LT +compareType _ (PrettyPrintObject {}) = GT + +compareType (PrettyPrintForAll _ a b) (PrettyPrintForAll _ a' b') = compare a a' <> compareType b b' +compareType (PrettyPrintForAll {}) _ = LT +compareType _ (PrettyPrintForAll {}) = GT + +compareType (BinaryNoParensType _ a b c) (BinaryNoParensType _ a' b' c') = compareType a a' <> compareType b b' <> compareType c c' +compareType (BinaryNoParensType {}) _ = LT +compareType _ (BinaryNoParensType {}) = GT + +compareType (ParensInType _ a) (ParensInType _ a') = compareType a a' +compareType (ParensInType {}) _ = GT + +instance Eq (Constraint a) where + (==) = eqConstraint + +instance Ord (Constraint a) where + compare = compareConstraint + +eqConstraint :: Constraint a -> Constraint b -> Bool +eqConstraint (Constraint _ a b c) (Constraint _ a' b' c') = a == a' && and (zipWith eqType b b') && c == c' + +compareConstraint :: Constraint a -> Constraint b -> Ordering +compareConstraint (Constraint _ a b c) (Constraint _ a' b' c') = compare a a' <> fold (zipWith compareType b b') <> compare c c' diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs index cfb71024a1..22eb860e12 100644 --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -12,7 +12,7 @@ import Language.PureScript.Ide.Util import Test.Hspec value :: Text -> IdeDeclarationAnn -value s = withEmptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.REmpty)) +value s = withEmptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.srcREmpty)) firstResult, secondResult, fiult :: Match IdeDeclarationAnn firstResult = Match (P.moduleNameFromString "Match", value "firstResult") diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index dbcfed91f0..2ef859e00e 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -22,9 +22,9 @@ ann1 = (span1, []) ann2 = (span2, []) typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, foreign1, foreign2, foreign3, member1 :: P.Declaration -typeAnnotation1 = P.TypeDeclaration (P.TypeDeclarationData ann1 (P.Ident "value1") P.REmpty) +typeAnnotation1 = P.TypeDeclaration (P.TypeDeclarationData ann1 (P.Ident "value1") P.srcREmpty) value1 = P.ValueDecl ann1 (P.Ident "value1") P.Public [] [] -synonym1 = P.TypeSynonymDeclaration ann1 (P.ProperName "Synonym1") [] P.REmpty +synonym1 = P.TypeSynonymDeclaration ann1 (P.ProperName "Synonym1") [] P.srcREmpty class1 = P.TypeClassDeclaration ann1 (P.ProperName "Class1") [] [] [] [] class2 = P.TypeClassDeclaration ann1 (P.ProperName "Class2") [] [] [] [member1] data1 = P.DataDeclaration ann1 P.Newtype (P.ProperName "Data1") [] [] @@ -41,10 +41,10 @@ typeFixity = (P.Fixity P.Infix 0) (P.Qualified Nothing (P.ProperName "")) (P.OpName "~>") -foreign1 = P.ExternDeclaration ann1 (P.Ident "foreign1") P.REmpty +foreign1 = P.ExternDeclaration ann1 (P.Ident "foreign1") P.srcREmpty foreign2 = P.ExternDataDeclaration ann1 (P.ProperName "Foreign2") P.kindType foreign3 = P.ExternKindDeclaration ann1 (P.ProperName "Foreign3") -member1 = P.TypeDeclaration (P.TypeDeclarationData ann2 (P.Ident "member1") P.REmpty) +member1 = P.TypeDeclaration (P.TypeDeclarationData ann2 (P.Ident "member1") P.srcREmpty) spec :: Spec spec = do @@ -73,7 +73,7 @@ spec = do extractSpans foreign3 `shouldBe` [(IdeNamespaced IdeNSKind "Foreign3", span1)] describe "Type annotations" $ do it "extracts a type annotation" $ - extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.REmpty)] + extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.srcREmpty)] describe "Finding Source Spans for identifiers" $ do it "finds a value declaration" $ do Just r <- getLocation "sfValue" diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index 33d9f3071f..4775a67fc7 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -11,22 +11,22 @@ import Lens.Micro.Platform hiding ((&)) import Test.Hspec import qualified Data.Map as Map -valueOperator :: Maybe P.Type -> IdeDeclarationAnn +valueOperator :: Maybe P.SourceType -> IdeDeclarationAnn valueOperator = ideValueOp "<$>" (P.Qualified (Just (mn "Test")) (Left "function")) 2 Nothing -ctorOperator :: Maybe P.Type -> IdeDeclarationAnn +ctorOperator :: Maybe P.SourceType -> IdeDeclarationAnn ctorOperator = ideValueOp ":" (P.Qualified (Just (mn "Test")) (Right "Cons")) 2 Nothing -typeOperator :: Maybe P.Kind -> IdeDeclarationAnn +typeOperator :: Maybe P.SourceKind -> IdeDeclarationAnn typeOperator = ideTypeOp ":" (P.Qualified (Just (mn "Test")) "List") 2 Nothing testModule :: (P.ModuleName, [IdeDeclarationAnn]) testModule = (mn "Test", - [ ideValue "function" (Just P.REmpty) + [ ideValue "function" (Just P.srcREmpty) , ideDtor "Cons" "List" (Just P.tyString) , ideType "List" Nothing [] , valueOperator Nothing @@ -82,7 +82,7 @@ spec :: Spec spec = do describe "resolving operators" $ do it "resolves the type for a value operator" $ - resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (valueOperator (Just P.REmpty)) + resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (valueOperator (Just P.srcREmpty)) it "resolves the type for a constructor operator" $ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.tyString)) it "resolves the kind for a type operator" $ diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index cca8e99ef9..5cf613f2c2 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -55,7 +55,7 @@ annLoc (IdeDeclarationAnn a d) loc = IdeDeclarationAnn a {_annLocation = Just lo annExp :: IdeDeclarationAnn -> Text -> IdeDeclarationAnn annExp (IdeDeclarationAnn a d) e = IdeDeclarationAnn a {_annExportedFrom = Just (mn e)} d -annTyp :: IdeDeclarationAnn -> P.Type -> IdeDeclarationAnn +annTyp :: IdeDeclarationAnn -> P.SourceType -> IdeDeclarationAnn annTyp (IdeDeclarationAnn a d) ta = IdeDeclarationAnn a {_annTypeAnnotation = Just ta} d @@ -63,22 +63,22 @@ ida :: IdeDeclaration -> IdeDeclarationAnn ida = IdeDeclarationAnn emptyAnn -- | Builders for Ide declarations -ideValue :: Text -> Maybe P.Type -> IdeDeclarationAnn +ideValue :: Text -> Maybe P.SourceType -> IdeDeclarationAnn ideValue i ty = ida (IdeDeclValue (IdeValue (P.Ident i) (fromMaybe P.tyString ty))) -ideType :: Text -> Maybe P.Kind -> [(P.ProperName 'P.ConstructorName, P.Type)] -> IdeDeclarationAnn +ideType :: Text -> Maybe P.SourceKind -> [(P.ProperName 'P.ConstructorName, P.SourceType)] -> IdeDeclarationAnn ideType pn ki dtors = ida (IdeDeclType (IdeType (P.ProperName pn) (fromMaybe P.kindType ki) dtors)) -ideSynonym :: Text -> Maybe P.Type -> Maybe P.Kind -> IdeDeclarationAnn +ideSynonym :: Text -> Maybe P.SourceType -> Maybe P.SourceKind -> IdeDeclarationAnn ideSynonym pn ty kind = ida (IdeDeclTypeSynonym (IdeTypeSynonym (P.ProperName pn) (fromMaybe P.tyString ty) (fromMaybe P.kindType kind))) -ideTypeClass :: Text -> P.Kind -> [IdeInstance] -> IdeDeclarationAnn +ideTypeClass :: Text -> P.SourceKind -> [IdeInstance] -> IdeDeclarationAnn ideTypeClass pn kind instances = ida (IdeDeclTypeClass (IdeTypeClass (P.ProperName pn) kind instances)) -ideDtor :: Text -> Text -> Maybe P.Type -> IdeDeclarationAnn +ideDtor :: Text -> Text -> Maybe P.SourceType -> IdeDeclarationAnn ideDtor pn tn ty = ida (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName pn) (P.ProperName tn) (fromMaybe P.tyString ty))) -ideValueOp :: Text -> P.Qualified (Either Text Text) -> Integer -> Maybe P.Associativity -> Maybe P.Type -> IdeDeclarationAnn +ideValueOp :: Text -> P.Qualified (Either Text Text) -> Integer -> Maybe P.Associativity -> Maybe P.SourceType -> IdeDeclarationAnn ideValueOp opName ident precedence assoc t = ida (IdeDeclValueOperator (IdeValueOperator @@ -88,7 +88,7 @@ ideValueOp opName ident precedence assoc t = (fromMaybe P.Infix assoc) t)) -ideTypeOp :: Text -> P.Qualified Text -> Integer -> Maybe P.Associativity -> Maybe P.Kind -> IdeDeclarationAnn +ideTypeOp :: Text -> P.Qualified Text -> Integer -> Maybe P.Associativity -> Maybe P.SourceKind -> IdeDeclarationAnn ideTypeOp opName ident precedence assoc k = ida (IdeDeclTypeOperator (IdeTypeOperator diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 8bd082ef12..3ca26f126b 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -133,10 +133,10 @@ data DocsAssertion | ShouldHaveFunDeps P.ModuleName Text [([Text],[Text])] -- | Assert that a particular value declaration exists, and its type -- satisfies the given predicate. - | ValueShouldHaveTypeSignature P.ModuleName Text (P.Type -> Bool) + | ValueShouldHaveTypeSignature P.ModuleName Text (Docs.Type' -> Bool) -- | Assert that a particular instance declaration exists under some class or -- type declaration, and that its type satisfies the given predicate. - | InstanceShouldHaveTypeSignature P.ModuleName Text Text (P.Type -> Bool) + | InstanceShouldHaveTypeSignature P.ModuleName Text Text (Docs.Type' -> Bool) -- | Assert that a particular type alias exists, and its corresponding -- type, when rendered, matches a given string exactly -- fields: module, type synonym name, expected type @@ -225,7 +225,7 @@ data DocsAssertionFailure -- because the inferred type was used when the explicit type should have -- been. -- Fields: module name, declaration name, actual type. - | DeclarationWrongType P.ModuleName Text P.Type + | DeclarationWrongType P.ModuleName Text Docs.Type' -- | A Type synonym has been rendered in an unexpected format -- Fields: module name, declaration name, expected rendering, actual rendering | TypeSynonymMismatch P.ModuleName Text Text Text @@ -500,13 +500,13 @@ runTagsAssertion assertion tags = Just taggedLine -> TagsFail $ Tagged decl taggedLine Nothing -> TagsPass -checkConstrained :: P.Type -> Text -> Bool +checkConstrained :: P.Type a -> Text -> Bool checkConstrained ty tyClass = case ty of - P.ConstrainedType c ty' + P.ConstrainedType _ c ty' | matches tyClass c -> True | otherwise -> checkConstrained ty' tyClass - P.ForAll _ ty' _ -> + P.ForAll _ _ ty' _ -> checkConstrained ty' tyClass _ -> False @@ -593,8 +593,8 @@ testCases = , ("ExplicitTypeSignatures", [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (hasTypeVar "something") - , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (P.tyInt ==) - , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (P.tyNumber ==) + , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (P.tyInt `P.eqType`) + , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (P.tyNumber `P.eqType`) ]) , ("ConstrainedArgument", @@ -652,7 +652,7 @@ testCases = hasTypeVar varName = getAny . P.everythingOnTypes (<>) (Any . isVar varName) - isVar varName (P.TypeVar name) | varName == T.unpack name = True + isVar varName (P.TypeVar _ name) | varName == T.unpack name = True isVar _ _ = False renderedType expected ty = diff --git a/tests/TestHierarchy.hs b/tests/TestHierarchy.hs index 898f869f8f..3cbf612193 100644 --- a/tests/TestHierarchy.hs +++ b/tests/TestHierarchy.hs @@ -53,7 +53,7 @@ main = testSpec "hierarchy" $ do (P.internalModuleSourceSpan "", []) (P.ProperName "B") [] - [P.Constraint (P.Qualified Nothing $ P.ProperName "A") [] Nothing] + [P.srcConstraint (P.Qualified Nothing $ P.ProperName "A") [] Nothing] [] [] ] From cdca9ccd8fa3e992d1d5f2ecc2b7aed93b9079ea Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sun, 23 Dec 2018 11:14:34 -0800 Subject: [PATCH 1036/1580] Use handwritten JSON instances for Type/Kind (#3496) --- src/Language/PureScript/Docs/Types.hs | 2 +- src/Language/PureScript/Kinds.hs | 95 +++++++------ src/Language/PureScript/Types.hs | 186 +++++++++++++++++++++++++- 3 files changed, 229 insertions(+), 54 deletions(-) diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 6fd9c1befb..827fc3550f 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -662,7 +662,7 @@ asTypeArguments = eachInArray asTypeArgument asTypeArgument = (,) <$> nth 0 asText <*> nth 1 (perhaps asKind) asKind :: Parse PackageError Kind' -asKind = P.kindFromJSON (pure ()) fromAesonParser .! InvalidKind +asKind = fromAesonParser .! InvalidKind asType :: Parse e Type' asType = fromAesonParser diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 7e843cc86d..20e5291e89 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -2,23 +2,22 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Kinds where import Prelude.Compat import GHC.Generics (Generic) +import Control.Applicative ((<|>)) import Control.DeepSeq (NFData) -import Data.Function (fix) import Data.Text (Text) -import qualified Data.Text as T -import Data.Aeson.BetterErrors (Parse, key, asText, asIntegral, nth, fromAesonParser, toAesonParser, throwCustomError, (<|>)) -import Data.Aeson ((.=)) +import Data.Aeson (Value, toJSON, (.=), (.:)) +import Data.Aeson.Types (Parser) import qualified Data.Aeson as A import Language.PureScript.AST.SourcePos import Language.PureScript.Names -import qualified Language.PureScript.Constants as C type SourceKind = Kind SourceAnn @@ -48,67 +47,65 @@ srcFunKind = FunKind NullSourceAnn srcNamedKind :: Qualified (ProperName 'KindName) -> SourceKind srcNamedKind = NamedKind NullSourceAnn -instance A.ToJSON a => A.ToJSON (Kind a) where - toJSON kind = case kind of +kindToJSON :: forall a. (a -> Value) -> Kind a -> Value +kindToJSON annToJSON kind = + case kind of KUnknown a i -> - obj "KUnknown" a i + variant "KUnknown" a i Row a k -> - obj "Row" a k + variant "Row" a (go k) FunKind a k1 k2 -> - obj "FunKind" a [k1, k2] + variant "FunKind" a (go k1, go k2) NamedKind a n -> - obj "NamedKind" a n - where - obj :: A.ToJSON b => Text -> a -> b -> A.Value - obj tag ann contents = - A.object [ "tag" .= tag, "annotation" .= ann, "contents" .= contents ] - --- This handles JSON generated by compilers up to 0.10.3 and maps them to the --- new representations (i.e. NamedKinds which are defined in the Prim module). -kindFromJSON :: Parse Text a -> Parse Text a -> Parse Text (Kind a) -kindFromJSON defaultAnn annFromJSON = fix $ \go -> do - t <- key "tag" asText - let annFromJSON' = key "annotation" annFromJSON <|> defaultAnn - case t of + variant "NamedKind" a n + where + go :: Kind a -> Value + go = kindToJSON annToJSON + + variant :: A.ToJSON b => Text -> a -> b -> A.Value + variant tag ann contents = + A.object + [ "tag" .= tag + , "annotation" .= annToJSON ann + , "contents" .= contents + ] + +instance A.ToJSON a => A.ToJSON (Kind a) where + toJSON = kindToJSON toJSON + +kindFromJSON :: forall a. Parser a -> (Value -> Parser a) -> Value -> Parser (Kind a) +kindFromJSON defaultAnn annFromJSON = A.withObject "Kind" $ \o -> do + tag <- o .: "tag" + a <- (o .: "annotation" >>= annFromJSON) <|> defaultAnn + let + contents :: A.FromJSON b => Parser b + contents = o .: "contents" + case tag of "KUnknown" -> - KUnknown <$> annFromJSON' <*> key "contents" (nth 0 asIntegral) - "Star" -> - kindType <$> defaultAnn + KUnknown a <$> contents "Row" -> - Row <$> annFromJSON' <*> key "contents" go - "FunKind" -> - let - kindAt n = key "contents" (nth n go) - in - FunKind <$> annFromJSON' <*> kindAt 0 <*> kindAt 1 - "Symbol" -> - kindSymbol <$> defaultAnn + Row a <$> (go =<< contents) + "FunKind" -> do + (b, c) <- contents + FunKind a <$> go b <*> go c "NamedKind" -> - NamedKind <$> annFromJSON' <*> key "contents" fromAesonParser + NamedKind a <$> contents other -> - throwCustomError (T.append "Unrecognised tag: " other) - + fail $ "Unrecognised tag: " ++ other where - -- The following are copied from Environment and reimplemented to avoid - -- circular dependencies. - primName :: Text -> Qualified (ProperName b) - primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName - - primKind = flip NamedKind . primName - - kindType = primKind C.typ - kindSymbol = primKind C.symbol + go :: Value -> Parser (Kind a) + go = kindFromJSON defaultAnn annFromJSON -- These overlapping instances exist to preserve compatability for common -- instances which have a sensible default for missing annotations. instance {-# OVERLAPPING #-} A.FromJSON (Kind SourceAnn) where - parseJSON = toAesonParser id (kindFromJSON (pure NullSourceAnn) fromAesonParser) + parseJSON = kindFromJSON (pure NullSourceAnn) A.parseJSON instance {-# OVERLAPPING #-} A.FromJSON (Kind ()) where - parseJSON = toAesonParser id (kindFromJSON (pure ()) fromAesonParser) + parseJSON = kindFromJSON (pure ()) A.parseJSON instance {-# OVERLAPPING #-} A.FromJSON a => A.FromJSON (Kind a) where - parseJSON = toAesonParser id (kindFromJSON (fail "Invalid annotation") fromAesonParser) + parseJSON = kindFromJSON (fail "Invalid annotation") A.parseJSON everywhereOnKinds :: (Kind a -> Kind a) -> Kind a -> Kind a everywhereOnKinds f = go diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 13d6a30417..d0c03638b5 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} -- | -- Data types for types @@ -12,11 +13,13 @@ module Language.PureScript.Types where import Prelude.Compat import Protolude (ordNub) +import Control.Applicative ((<|>)) import Control.Arrow (first) import Control.DeepSeq (NFData) import Control.Monad ((<=<)) +import Data.Aeson ((.:), (.=)) import qualified Data.Aeson as A -import qualified Data.Aeson.TH as A +import qualified Data.Aeson.Types as A import Data.Foldable (fold) import Data.List (sortBy) import Data.Ord (comparing) @@ -172,9 +175,184 @@ mapConstraintArgs f c = c { constraintArgs = f (constraintArgs c) } overConstraintArgs :: Functor f => ([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a) overConstraintArgs f c = (\args -> c { constraintArgs = args }) <$> f (constraintArgs c) -$(A.deriveJSON A.defaultOptions ''Type) -$(A.deriveJSON A.defaultOptions ''Constraint) -$(A.deriveJSON A.defaultOptions ''ConstraintData) +constraintDataToJSON :: ConstraintData -> A.Value +constraintDataToJSON (PartialConstraintData bs trunc) = + A.object + [ "contents" .= (bs, trunc) + ] + +constraintToJSON :: (a -> A.Value) -> Constraint a -> A.Value +constraintToJSON annToJSON (Constraint {..}) = + A.object + [ "constraintAnn" .= annToJSON constraintAnn + , "constraintClass" .= constraintClass + , "constraintArgs" .= fmap (typeToJSON annToJSON) constraintArgs + , "constraintData" .= fmap constraintDataToJSON constraintData + ] + +typeToJSON :: forall a. (a -> A.Value) -> Type a -> A.Value +typeToJSON annToJSON ty = + case ty of + TUnknown a b -> + variant "TUnknown" a b + TypeVar a b -> + variant "TypeVar" a b + TypeLevelString a b -> + variant "TypeLevelString" a b + TypeWildcard a -> + nullary "TypeWildcard" a + TypeConstructor a b -> + variant "TypeConstructor" a b + TypeOp a b -> + variant "TypeOp" a b + TypeApp a b c -> + variant "TypeApp" a (go b, go c) + ForAll a b c d -> + variant "ForAll" a (b, go c, d) + ConstrainedType a b c -> + variant "ConstrainedType" a (constraintToJSON annToJSON b, go c) + Skolem a b c d -> + variant "Skolem" a (b, c, d) + REmpty a -> + nullary "REmpty" a + RCons a b c d -> + variant "RCons" a (b, go c, go d) + KindedType a b c -> + variant "KindedType" a (go b, kindToJSON annToJSON c) + PrettyPrintFunction a b c -> + variant "PrettyPrintFunction" a (go b, go c) + PrettyPrintObject a b -> + variant "PrettyPrintObject" a (go b) + PrettyPrintForAll a b c -> + variant "PrettyPrintForAll" a (b, go c) + BinaryNoParensType a b c d -> + variant "BinaryNoParensType" a (go b, go c, go d) + ParensInType a b -> + variant "ParensInType" a (go b) + where + go :: Type a -> A.Value + go = typeToJSON annToJSON + + variant :: A.ToJSON b => String -> a -> b -> A.Value + variant tag ann contents = + A.object + [ "tag" .= tag + , "annotation" .= annToJSON ann + , "contents" .= contents + ] + + nullary :: String -> a -> A.Value + nullary tag ann = + A.object + [ "tag" .= tag + , "annotation" .= annToJSON ann + ] + +instance A.ToJSON a => A.ToJSON (Type a) where + toJSON = typeToJSON A.toJSON + +instance A.ToJSON a => A.ToJSON (Constraint a) where + toJSON = constraintToJSON A.toJSON + +instance A.ToJSON ConstraintData where + toJSON = constraintDataToJSON + +constraintDataFromJSON :: A.Value -> A.Parser ConstraintData +constraintDataFromJSON = A.withObject "PartialConstraintData" $ \o -> do + (bs, trunc) <- o .: "contents" + pure $ PartialConstraintData bs trunc + +constraintFromJSON :: forall a. A.Parser a -> (A.Value -> A.Parser a) -> A.Value -> A.Parser (Constraint a) +constraintFromJSON defaultAnn annFromJSON = A.withObject "Constraint" $ \o -> do + constraintAnn <- (o .: "constraintAnn" >>= annFromJSON) <|> defaultAnn + constraintClass <- o .: "constraintClass" + constraintArgs <- o .: "constraintArgs" >>= traverse (typeFromJSON defaultAnn annFromJSON) + constraintData <- o .: "constraintData" >>= traverse constraintDataFromJSON + pure $ Constraint {..} + +typeFromJSON :: forall a. A.Parser a -> (A.Value -> A.Parser a) -> A.Value -> A.Parser (Type a) +typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do + tag <- o .: "tag" + a <- (o .: "annotation" >>= annFromJSON) <|> defaultAnn + let + contents :: A.FromJSON b => A.Parser b + contents = o .: "contents" + case tag of + "TUnknown" -> + TUnknown a <$> contents + "TypeVar" -> + TypeVar a <$> contents + "TypeLevelString" -> + TypeLevelString a <$> contents + "TypeWildcard" -> + pure $ TypeWildcard a + "TypeConstructor" -> + TypeConstructor a <$> contents + "TypeOp" -> + TypeOp a <$> contents + "TypeApp" -> do + (b, c) <- contents + TypeApp a <$> go b <*> go c + "ForAll" -> do + (b, c, d) <- contents + ForAll a b <$> go c <*> pure d + "ConstrainedType" -> do + (b, c) <- contents + ConstrainedType a <$> constraintFromJSON defaultAnn annFromJSON b <*> go c + "Skolem" -> do + (b, c, d) <- contents + pure $ Skolem a b c d + "REmpty" -> + pure $ REmpty a + "RCons" -> do + (b, c, d) <- contents + RCons a b <$> go c <*> go d + "KindedType" -> do + (b, c) <- contents + KindedType a <$> go b <*> kindFromJSON defaultAnn annFromJSON c + "PrettyPrintFunction" -> do + (b, c) <- contents + PrettyPrintFunction a <$> go b <*> go c + "PrettyPrintObject" -> do + b <- contents + PrettyPrintObject a <$> go b + "PrettyPrintForAll" -> do + (b, c) <- contents + PrettyPrintForAll a b <$> go c + "BinaryNoParensType" -> do + (b, c, d) <- contents + BinaryNoParensType a <$> go b <*> go c <*> go d + "ParensInType" -> do + b <- contents + ParensInType a <$> go b + other -> + fail $ "Unrecognised tag: " ++ other + where + go :: A.Value -> A.Parser (Type a) + go = typeFromJSON defaultAnn annFromJSON + +-- These overlapping instances exist to preserve compatability for common +-- instances which have a sensible default for missing annotations. +instance {-# OVERLAPPING #-} A.FromJSON (Type SourceAnn) where + parseJSON = typeFromJSON (pure NullSourceAnn) A.parseJSON + +instance {-# OVERLAPPING #-} A.FromJSON (Type ()) where + parseJSON = typeFromJSON (pure ()) A.parseJSON + +instance {-# OVERLAPPING #-} A.FromJSON a => A.FromJSON (Type a) where + parseJSON = typeFromJSON (fail "Invalid annotation") A.parseJSON + +instance {-# OVERLAPPING #-} A.FromJSON (Constraint SourceAnn) where + parseJSON = constraintFromJSON (pure NullSourceAnn) A.parseJSON + +instance {-# OVERLAPPING #-} A.FromJSON (Constraint ()) where + parseJSON = constraintFromJSON (pure ()) A.parseJSON + +instance {-# OVERLAPPING #-} A.FromJSON a => A.FromJSON (Constraint a) where + parseJSON = constraintFromJSON (fail "Invalid annotation") A.parseJSON + +instance A.FromJSON ConstraintData where + parseJSON = constraintDataFromJSON data RowListItem a = RowListItem { rowListAnn :: a From 9446c8bb5f6cd5e74b3f1eb787cfded684391400 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Wed, 26 Dec 2018 12:46:53 -0800 Subject: [PATCH 1037/1580] Remove pretty print constructors from Type (#3498) --- src/Language/PureScript/Docs/AsMarkdown.hs | 11 +- src/Language/PureScript/Docs/Render.hs | 49 ++--- .../Docs/RenderedCode/RenderType.hs | 143 ++++++--------- src/Language/PureScript/Linter.hs | 3 - src/Language/PureScript/Pretty/Types.hs | 169 +++++++++++------- src/Language/PureScript/Types.hs | 57 ------ 6 files changed, 181 insertions(+), 251 deletions(-) diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 13c513baa4..6765217ba5 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -42,23 +42,22 @@ moduleAsMarkdown Module{..} = do headerLevel 2 $ "Module " <> P.runModuleName modName spacer for_ modComments tell' - mapM_ (declAsMarkdown modName) modDeclarations + mapM_ declAsMarkdown modDeclarations spacer for_ modReExports $ \(mn', decls) -> do let mn = ignorePackage mn' headerLevel 3 $ "Re-exported from " <> P.runModuleName mn <> ":" spacer - mapM_ (declAsMarkdown mn) decls + mapM_ declAsMarkdown decls -declAsMarkdown :: P.ModuleName -> Declaration -> Docs -declAsMarkdown mn decl@Declaration{..} = do - let options = defaultRenderTypeOptions { currentModule = Just mn } +declAsMarkdown :: Declaration -> Docs +declAsMarkdown decl@Declaration{..} = do headerLevel 4 (ticks declTitle) spacer let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren fencedBlock $ do - tell' (codeToString $ Render.renderDeclarationWithOptions options decl) + tell' (codeToString $ Render.renderDeclaration decl) zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children spacer diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index c9f1a794d8..6e37c202b4 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -21,36 +21,33 @@ import Language.PureScript.Docs.Utils.MonoidExtras import qualified Language.PureScript as P renderDeclaration :: Declaration -> RenderedCode -renderDeclaration = renderDeclarationWithOptions defaultRenderTypeOptions - -renderDeclarationWithOptions :: RenderTypeOptions -> Declaration -> RenderedCode -renderDeclarationWithOptions opts Declaration{..} = +renderDeclaration Declaration{..} = mintersperse sp $ case declInfo of ValueDeclaration ty -> [ ident' declTitle , syntax "::" - , renderType' ty + , renderType ty ] DataDeclaration dtype args -> [ keyword (P.showDataDeclType dtype) - , renderType' (typeApp declTitle args) + , renderType (typeApp declTitle args) ] ExternDataDeclaration kind' -> [ keywordData - , renderType' (P.TypeConstructor () (notQualified declTitle)) + , renderType (P.TypeConstructor () (notQualified declTitle)) , syntax "::" , renderKind kind' ] TypeSynonymDeclaration args ty -> [ keywordType - , renderType' (typeApp declTitle args) + , renderType (typeApp declTitle args) , syntax "=" - , renderType' ty + , renderType ty ] TypeClassDeclaration args implies fundeps -> [ keywordClass ] ++ maybeToList superclasses - ++ [renderType' (typeApp declTitle args)] + ++ [renderType (typeApp declTitle args)] ++ fundepsList ++ [keywordWhere | any isTypeClassMember declChildren] @@ -84,43 +81,27 @@ renderDeclarationWithOptions opts Declaration{..} = , kind (notQualified declTitle) ] - where - renderType' :: Type' -> RenderedCode - renderType' = renderTypeWithOptions opts - renderChildDeclaration :: ChildDeclaration -> RenderedCode -renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions - -renderChildDeclarationWithOptions :: RenderTypeOptions -> ChildDeclaration -> RenderedCode -renderChildDeclarationWithOptions opts ChildDeclaration{..} = +renderChildDeclaration ChildDeclaration{..} = mintersperse sp $ case cdeclInfo of ChildInstance constraints ty -> - maybeToList (renderConstraints constraints) ++ [ renderType' ty ] + maybeToList (renderConstraints constraints) ++ [ renderType ty ] ChildDataConstructor args -> [ dataCtor' cdeclTitle ] - ++ map renderTypeAtom' args + ++ map renderTypeAtom args ChildTypeClassMember ty -> [ ident' cdeclTitle , syntax "::" - , renderType' ty + , renderType ty ] - where - renderType' = renderTypeWithOptions opts - renderTypeAtom' = renderTypeAtomWithOptions opts renderConstraint :: Constraint' -> RenderedCode -renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions - -renderConstraintWithOptions :: RenderTypeOptions -> Constraint' -> RenderedCode -renderConstraintWithOptions opts (P.Constraint ann pn tys _) = - renderTypeWithOptions opts $ foldl (P.TypeApp ann) (P.TypeConstructor ann (fmap P.coerceProperName pn)) tys +renderConstraint (P.Constraint ann pn tys _) = + renderType $ foldl (P.TypeApp ann) (P.TypeConstructor ann (fmap P.coerceProperName pn)) tys renderConstraints :: [Constraint'] -> Maybe RenderedCode -renderConstraints = renderConstraintsWithOptions defaultRenderTypeOptions - -renderConstraintsWithOptions :: RenderTypeOptions -> [Constraint'] -> Maybe RenderedCode -renderConstraintsWithOptions opts constraints +renderConstraints constraints | null constraints = Nothing | otherwise = Just $ syntax "(" @@ -129,7 +110,7 @@ renderConstraintsWithOptions opts constraints where renderedConstraints = mintersperse (syntax "," <> sp) - (map (renderConstraintWithOptions opts) constraints) + (map renderConstraint constraints) notQualified :: Text -> P.Qualified (P.ProperName a) notQualified = P.Qualified Nothing . P.ProperName diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index e027db980d..c874d750ae 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -2,12 +2,10 @@ module Language.PureScript.Docs.RenderedCode.RenderType ( renderType + , renderType' , renderTypeAtom + , renderTypeAtom' , renderRow - , RenderTypeOptions(..) - , defaultRenderTypeOptions - , renderTypeWithOptions - , renderTypeAtomWithOptions ) where import Prelude.Compat @@ -19,8 +17,8 @@ import Control.Arrow ((<+>)) import Control.PatternArrows as PA import Language.PureScript.Crash -import Language.PureScript.Environment import Language.PureScript.Kinds +import Language.PureScript.Label import Language.PureScript.Names import Language.PureScript.Pretty.Types import Language.PureScript.Types @@ -30,40 +28,40 @@ import Language.PureScript.Docs.RenderedCode.Types import Language.PureScript.Docs.Utils.MonoidExtras import Language.PureScript.Docs.RenderedCode.RenderKind (renderKind) -typeLiterals :: Pattern () (Type a) RenderedCode +typeLiterals :: Pattern () PrettyPrintType RenderedCode typeLiterals = mkPattern match where - match TypeWildcard{} = + match PPTypeWildcard = Just (syntax "_") - match (TypeVar _ var) = + match (PPTypeVar var) = Just (typeVar var) - match (PrettyPrintObject _ row) = + match (PPRecord row) = Just $ mintersperse sp [ syntax "{" , renderRow row , syntax "}" ] - match (TypeConstructor _ n) = + match (PPTypeConstructor n) = Just (typeCtor n) - match REmpty{} = + match PPREmpty = Just (syntax "()") - match row@RCons{} = + match row@PPRCons{} = Just (syntax "(" <> renderRow row <> syntax ")") - match (BinaryNoParensType _ op l r) = - Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r - match (TypeOp _ n) = + match (PPBinaryNoParensType op l r) = + Just $ renderTypeAtom' l <> sp <> renderTypeAtom' op <> sp <> renderTypeAtom' r + match (PPTypeOp n) = Just (typeOp n) - match (TypeLevelString _ str) = + match (PPTypeLevelString str) = Just (syntax (prettyPrintString str)) match _ = Nothing -renderConstraint :: Constraint a -> RenderedCode -renderConstraint (Constraint ann pn tys _) = - let instApp = foldl (TypeApp ann) (TypeConstructor ann (fmap coerceProperName pn)) tys - in renderType instApp +renderConstraint :: PrettyPrintConstraint -> RenderedCode +renderConstraint (pn, tys) = + let instApp = foldl PPTypeApp (PPTypeConstructor (fmap coerceProperName pn)) tys + in renderType' instApp -renderConstraints :: Constraint a -> RenderedCode -> RenderedCode +renderConstraints :: PrettyPrintConstraint -> RenderedCode -> RenderedCode renderConstraints con ty = mintersperse sp [ renderConstraint con @@ -74,65 +72,68 @@ renderConstraints con ty = -- | -- Render code representing a Row -- -renderRow :: Type a -> RenderedCode -renderRow = uncurry renderRow' . rowToList +renderRow :: PrettyPrintType -> RenderedCode +renderRow = uncurry renderRow' . go [] where renderRow' h t = renderHead h <> renderTail t -renderHead :: [RowListItem a] -> RenderedCode + go ts (PPRCons l t r) = go ((l, t) : ts) r + go ts t = (reverse ts, t) + +renderHead :: [(Label, PrettyPrintType)] -> RenderedCode renderHead = mintersperse (syntax "," <> sp) . map renderLabel -renderLabel :: RowListItem a -> RenderedCode -renderLabel (RowListItem _ label ty) = +renderLabel :: (Label, PrettyPrintType) -> RenderedCode +renderLabel (label, ty) = mintersperse sp [ typeVar $ prettyPrintLabel label , syntax "::" - , renderType ty + , renderType' ty ] -renderTail :: Type a -> RenderedCode -renderTail REmpty{} = mempty -renderTail other = sp <> syntax "|" <> sp <> renderType other +renderTail :: PrettyPrintType -> RenderedCode +renderTail PPREmpty = mempty +renderTail other = sp <> syntax "|" <> sp <> renderType' other -typeApp :: Pattern () (Type a) (Type a, Type a) +typeApp :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType) typeApp = mkPattern match where - match (TypeApp _ f x) = Just (f, x) + match (PPTypeApp f x) = Just (f, x) match _ = Nothing -appliedFunction :: Pattern () (Type a) (Type a, Type a) +appliedFunction :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType) appliedFunction = mkPattern match where - match (PrettyPrintFunction _ arg ret) = Just (arg, ret) + match (PPFunction arg ret) = Just (arg, ret) match _ = Nothing -kinded :: Pattern () (Type a) (Kind a, Type a) +kinded :: Pattern () PrettyPrintType (Kind (), PrettyPrintType) kinded = mkPattern match where - match (KindedType _ t k) = Just (k, t) + match (PPKindedType t k) = Just (k, t) match _ = Nothing -constrained :: Pattern () (Type a) (Constraint a, Type a) +constrained :: Pattern () PrettyPrintType (PrettyPrintConstraint, PrettyPrintType) constrained = mkPattern match where - match (ConstrainedType _ con ty) = Just (con, ty) + match (PPConstrainedType con ty) = Just (con, ty) match _ = Nothing -explicitParens :: Pattern () (Type a) ((), Type a) +explicitParens :: Pattern () PrettyPrintType ((), PrettyPrintType) explicitParens = mkPattern match where - match (ParensInType _ ty) = Just ((), ty) + match (PPParensInType ty) = Just ((), ty) match _ = Nothing -matchTypeAtom :: Pattern () (Type a) RenderedCode +matchTypeAtom :: Pattern () PrettyPrintType RenderedCode matchTypeAtom = typeLiterals <+> fmap parens_ matchType where parens_ x = syntax "(" <> x <> syntax ")" -matchType :: Pattern () (Type a) RenderedCode +matchType :: Pattern () PrettyPrintType RenderedCode matchType = buildPrettyPrinter operators matchTypeAtom where - operators :: OperatorTable () (Type a) RenderedCode + operators :: OperatorTable () PrettyPrintType RenderedCode operators = OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ] , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ] @@ -142,64 +143,30 @@ matchType = buildPrettyPrinter operators matchTypeAtom , [ Wrap explicitParens $ \_ ty -> ty ] ] -forall_ :: Pattern () (Type a) ([Text], Type a) +forall_ :: Pattern () PrettyPrintType ([Text], PrettyPrintType) forall_ = mkPattern match where - match (PrettyPrintForAll _ idents ty) = Just (idents, ty) + match (PPForAll idents ty) = Just (idents, ty) match _ = Nothing -insertPlaceholders :: RenderTypeOptions -> Type a -> Type a -insertPlaceholders opts = - everywhereOnTypesTopDown convertForAlls . everywhereOnTypes (convert opts) - -convert :: RenderTypeOptions -> Type a -> Type a -convert _ (TypeApp a (TypeApp _ f arg) ret) | eqType f tyFunction = PrettyPrintFunction a arg ret -convert opts (TypeApp a o r) | eqType o tyRecord && prettyPrintObjects opts = PrettyPrintObject a r -convert _ other = other - -convertForAlls :: Type a -> Type a -convertForAlls (ForAll ann i ty _) = go [i] ty - where - go idents (ForAll _ i' ty' _) = go (i' : idents) ty' - go idents other = PrettyPrintForAll ann idents other -convertForAlls other = other - -preprocessType :: RenderTypeOptions -> Type a -> Type a -preprocessType opts = insertPlaceholders opts - - -- | -- Render code representing a Type -- renderType :: Type a -> RenderedCode -renderType = renderTypeWithOptions defaultRenderTypeOptions +renderType = renderType' . convertPrettyPrintType + +renderType' :: PrettyPrintType -> RenderedCode +renderType' + = fromMaybe (internalError "Incomplete pattern") + . PA.pattern matchType () -- | -- Render code representing a Type, as it should appear inside parentheses -- renderTypeAtom :: Type a -> RenderedCode -renderTypeAtom = renderTypeAtomWithOptions defaultRenderTypeOptions - -data RenderTypeOptions = RenderTypeOptions - { prettyPrintObjects :: Bool - , currentModule :: Maybe ModuleName - } - -defaultRenderTypeOptions :: RenderTypeOptions -defaultRenderTypeOptions = - RenderTypeOptions - { prettyPrintObjects = True - , currentModule = Nothing - } - -renderTypeWithOptions :: RenderTypeOptions -> Type a -> RenderedCode -renderTypeWithOptions opts - = fromMaybe (internalError "Incomplete pattern") - . PA.pattern matchType () - . preprocessType opts +renderTypeAtom = renderTypeAtom' . convertPrettyPrintType -renderTypeAtomWithOptions :: RenderTypeOptions -> Type a -> RenderedCode -renderTypeAtomWithOptions opts +renderTypeAtom' :: PrettyPrintType -> RenderedCode +renderTypeAtom' = fromMaybe (internalError "Incomplete pattern") . PA.pattern matchTypeAtom () - . preprocessType opts diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index d90c77d96f..96c11b84e2 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -114,9 +114,6 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl go unused TypeOp{} = (unused, mempty) go unused Skolem{} = (unused, mempty) go unused REmpty{} = (unused, mempty) - go unused PrettyPrintFunction{} = (unused, mempty) - go unused PrettyPrintObject{} = (unused, mempty) - go unused PrettyPrintForAll{} = (unused, mempty) combine :: (S.Set Text, MultipleErrors) -> diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 9d45c7f9a5..5be826b6fe 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -2,12 +2,17 @@ -- Pretty printer for Types -- module Language.PureScript.Pretty.Types - ( typeAsBox + ( PrettyPrintType(..) + , PrettyPrintConstraint + , convertPrettyPrintType + , typeAsBox + , typeAsBox' , suggestedTypeAsBox , prettyPrintType , prettyPrintTypeWithUnicode , prettyPrintSuggestedType , typeAtomAsBox + , typeAtomAsBox' , prettyPrintTypeAtom , prettyPrintRow , prettyPrintLabel @@ -19,6 +24,7 @@ import Prelude.Compat hiding ((<>)) import Control.Arrow ((<+>)) import Control.PatternArrows as PA +import Data.Functor (($>)) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -35,114 +41,147 @@ import Language.PureScript.Label (Label(..)) import Text.PrettyPrint.Boxes hiding ((<+>)) +data PrettyPrintType + = PPTUnknown Int + | PPTypeVar Text + | PPTypeLevelString PSString + | PPTypeWildcard + | PPTypeConstructor (Qualified (ProperName 'TypeName)) + | PPTypeOp (Qualified (OpName 'TypeOpName)) + | PPSkolem Text Int + | PPTypeApp PrettyPrintType PrettyPrintType + | PPConstrainedType PrettyPrintConstraint PrettyPrintType + | PPKindedType PrettyPrintType (Kind ()) + | PPBinaryNoParensType PrettyPrintType PrettyPrintType PrettyPrintType + | PPParensInType PrettyPrintType + | PPForAll [Text] PrettyPrintType + | PPFunction PrettyPrintType PrettyPrintType + | PPRecord PrettyPrintType + | PPRCons Label PrettyPrintType PrettyPrintType + | PPREmpty + +type PrettyPrintConstraint = (Qualified (ProperName 'ClassName), [PrettyPrintType]) + +convertPrettyPrintType :: Type a -> PrettyPrintType +convertPrettyPrintType = go + where + go (TUnknown _ n) = PPTUnknown n + go (TypeVar _ t) = PPTypeVar t + go (TypeLevelString _ s) = PPTypeLevelString s + go (TypeWildcard _) = PPTypeWildcard + go (TypeConstructor _ c) = PPTypeConstructor c + go (TypeOp _ o) = PPTypeOp o + go (Skolem _ t n _) = PPSkolem t n + go (ConstrainedType _ (Constraint _ cls args _) ty) = PPConstrainedType (cls, go <$> args) (go ty) + go (KindedType _ ty k) = PPKindedType (go ty) (k $> ()) + go (BinaryNoParensType _ ty1 ty2 ty3) = PPBinaryNoParensType (go ty1) (go ty2) (go ty3) + go (ParensInType _ ty) = PPParensInType (go ty) + go (REmpty _) = PPREmpty + go (RCons _ l ty1 ty2) = PPRCons l (go ty1) (go ty2) + go (ForAll _ v ty _) = goForAll [v] ty + go (TypeApp _ (TypeApp _ f arg) ret) | eqType f tyFunction = PPFunction (go arg) (go ret) + go (TypeApp _ o r) | eqType o tyRecord = PPRecord (go r) + go (TypeApp _ a b) = PPTypeApp (go a) (go b) + + goForAll vs (ForAll _ v ty _) = goForAll (v : vs) ty + goForAll vs ty = PPForAll vs (go ty) + -- TODO(Christoph): get rid of T.unpack s -constraintsAsBox :: TypeRenderOptions -> Constraint a -> Box -> Box +constraintsAsBox :: TypeRenderOptions -> PrettyPrintConstraint -> Box -> Box constraintsAsBox tro con ty = constraintAsBox con `before` (" " <> text doubleRightArrow <> " " <> ty) where doubleRightArrow = if troUnicode tro then "⇒" else "=>" -constraintAsBox :: Constraint a -> Box -constraintAsBox (Constraint ann pn tys _) = typeAsBox (foldl (TypeApp ann) (TypeConstructor ann (fmap coerceProperName pn)) tys) +constraintAsBox :: PrettyPrintConstraint -> Box +constraintAsBox (pn, tys) = typeAsBox' (foldl PPTypeApp (PPTypeConstructor (fmap coerceProperName pn)) tys) -- | -- Generate a pretty-printed string representing a Row -- -prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> Type a -> Box +prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> PrettyPrintType -> Box prettyPrintRowWith tro open close = uncurry listToBox . toList [] where - nameAndTypeToPs :: Char -> Label -> Type a -> Box - nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " " ++ doubleColon ++ " ") <> typeAsBox ty + nameAndTypeToPs :: Char -> Label -> PrettyPrintType -> Box + nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " " ++ doubleColon ++ " ") <> typeAsBox' ty doubleColon = if troUnicode tro then "∷" else "::" - tailToPs :: Type a -> Box - tailToPs (REmpty _) = nullBox - tailToPs other = text "| " <> typeAsBox other + tailToPs :: PrettyPrintType -> Box + tailToPs PPREmpty = nullBox + tailToPs other = text "| " <> typeAsBox' other - listToBox :: [(Label, Type a)] -> Type a -> Box - listToBox [] (REmpty _) = text [open, close] + listToBox :: [(Label, PrettyPrintType)] -> PrettyPrintType -> Box + listToBox [] PPREmpty = text [open, close] listToBox [] rest = text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ] listToBox ts rest = vcat left $ zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++ [ tailToPs rest, text [close] ] - toList :: [(Label, Type a)] -> Type a -> ([(Label, Type a)], Type a) - toList tys (RCons _ name ty row) = toList ((name, ty):tys) row + toList :: [(Label, PrettyPrintType)] -> PrettyPrintType -> ([(Label, PrettyPrintType)], PrettyPrintType) + toList tys (PPRCons name ty row) = toList ((name, ty):tys) row toList tys r = (reverse tys, r) -prettyPrintRow :: Type a -> String +prettyPrintRow :: PrettyPrintType -> String prettyPrintRow = render . prettyPrintRowWith defaultOptions '(' ')' -typeApp :: Pattern () (Type a) (Type a, Type a) +typeApp :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType) typeApp = mkPattern match where - match (TypeApp _ f x) = Just (f, x) + match (PPTypeApp f x) = Just (f, x) match _ = Nothing -appliedFunction :: Pattern () (Type a) (Type a, Type a) +appliedFunction :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType) appliedFunction = mkPattern match where - match (PrettyPrintFunction _ arg ret) = Just (arg, ret) + match (PPFunction arg ret) = Just (arg, ret) match _ = Nothing -kinded :: Pattern () (Type a) (Kind a, Type a) +kinded :: Pattern () PrettyPrintType (Kind (), PrettyPrintType) kinded = mkPattern match where - match (KindedType _ t k) = Just (k, t) + match (PPKindedType t k) = Just (k, t) match _ = Nothing -insertPlaceholders :: Type a -> Type a -insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert - where - convert (TypeApp _ (TypeApp ann f arg) ret) | eqType f tyFunction = PrettyPrintFunction ann arg ret - convert (TypeApp ann o r) | eqType o tyRecord = PrettyPrintObject ann r - convert other = other - convertForAlls (ForAll ann ident ty _) = go [ident] ty - where - go idents (ForAll _ ident' ty' _) = go (ident' : idents) ty' - go idents other = PrettyPrintForAll ann idents other - convertForAlls other = other - -constrained :: Pattern () (Type a) (Constraint a, Type a) +constrained :: Pattern () PrettyPrintType (PrettyPrintConstraint, PrettyPrintType) constrained = mkPattern match where - match (ConstrainedType _ deps ty) = Just (deps, ty) + match (PPConstrainedType deps ty) = Just (deps, ty) match _ = Nothing -explicitParens :: Pattern () (Type a) ((), Type a) +explicitParens :: Pattern () PrettyPrintType ((), PrettyPrintType) explicitParens = mkPattern match where - match (ParensInType _ ty) = Just ((), ty) + match (PPParensInType ty) = Just ((), ty) match _ = Nothing -matchTypeAtom :: TypeRenderOptions -> Pattern () (Type a) Box +matchTypeAtom :: TypeRenderOptions -> Pattern () PrettyPrintType Box matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} = typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType tro) where - typeLiterals :: Pattern () (Type a) Box + typeLiterals :: Pattern () PrettyPrintType Box typeLiterals = mkPattern match where - match TypeWildcard{} = Just $ text "_" - match (TypeVar _ var) = Just $ text $ T.unpack var - match (TypeLevelString _ s) = Just $ text $ T.unpack $ prettyPrintString s - match (PrettyPrintObject _ row) = Just $ prettyPrintRowWith tro '{' '}' row - match (TypeConstructor _ ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor - match (TUnknown _ u) + match PPTypeWildcard = Just $ text "_" + match (PPTypeVar var) = Just $ text $ T.unpack var + match (PPTypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s + match (PPRecord row) = Just $ prettyPrintRowWith tro '{' '}' row + match (PPTypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor + match (PPTUnknown u) | suggesting = Just $ text "_" | otherwise = Just $ text $ 't' : show u - match (Skolem _ name s _) + match (PPSkolem name s) | suggesting = Just $ text $ T.unpack name | otherwise = Just $ text $ T.unpack name ++ show s - match (REmpty _) = Just $ text "()" - match row@RCons{} = Just $ prettyPrintRowWith tro '(' ')' row - match (BinaryNoParensType _ op l r) = - Just $ typeAsBox l <> text " " <> typeAsBox op <> text " " <> typeAsBox r - match (TypeOp _ op) = Just $ text $ T.unpack $ showQualified runOpName op + match PPREmpty = Just $ text "()" + match row@PPRCons{} = Just $ prettyPrintRowWith tro '(' ')' row + match (PPBinaryNoParensType op l r) = + Just $ typeAsBox' l <> text " " <> typeAsBox' op <> text " " <> typeAsBox' r + match (PPTypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op match _ = Nothing -matchType :: TypeRenderOptions -> Pattern () (Type a) Box +matchType :: TypeRenderOptions -> Pattern () PrettyPrintType Box matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where - operators :: OperatorTable () (Type a) Box + operators :: OperatorTable () PrettyPrintType Box operators = OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ] , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text rightArrow <> " " <> ret) ] @@ -163,26 +202,31 @@ matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where | rows b1 > 1 || rows b2 > 1 = vcat left [ b1, f b2 ] | otherwise = hcat top [ b1, text " ", b2] -forall_ :: Pattern () (Type a) ([String], Type a) +forall_ :: Pattern () PrettyPrintType ([String], PrettyPrintType) forall_ = mkPattern match where - match (PrettyPrintForAll _ idents ty) = Just (map T.unpack idents, ty) + match (PPForAll idents ty) = Just (map T.unpack idents, ty) match _ = Nothing -typeAtomAsBox :: Type a -> Box -typeAtomAsBox +typeAtomAsBox' :: PrettyPrintType -> Box +typeAtomAsBox' = fromMaybe (internalError "Incomplete pattern") . PA.pattern (matchTypeAtom defaultOptions) () - . insertPlaceholders + +typeAtomAsBox :: Type a -> Box +typeAtomAsBox = typeAtomAsBox' . convertPrettyPrintType -- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses prettyPrintTypeAtom :: Type a -> String prettyPrintTypeAtom = render . typeAtomAsBox +typeAsBox' :: PrettyPrintType -> Box +typeAsBox' = typeAsBoxImpl defaultOptions + typeAsBox :: Type a -> Box -typeAsBox = typeAsBoxImpl defaultOptions +typeAsBox = typeAsBox' . convertPrettyPrintType -suggestedTypeAsBox :: Type a -> Box +suggestedTypeAsBox :: PrettyPrintType -> Box suggestedTypeAsBox = typeAsBoxImpl suggestingOptions data TypeRenderOptions = TypeRenderOptions @@ -199,11 +243,10 @@ defaultOptions = TypeRenderOptions False False unicodeOptions :: TypeRenderOptions unicodeOptions = TypeRenderOptions False True -typeAsBoxImpl :: TypeRenderOptions -> Type a -> Box +typeAsBoxImpl :: TypeRenderOptions -> PrettyPrintType -> Box typeAsBoxImpl tro = fromMaybe (internalError "Incomplete pattern") . PA.pattern (matchType tro) () - . insertPlaceholders -- | Generate a pretty-printed string representing a 'Type' prettyPrintType :: Type a -> String @@ -219,7 +262,7 @@ prettyPrintSuggestedType :: Type a -> String prettyPrintSuggestedType = prettyPrintType' suggestingOptions prettyPrintType' :: TypeRenderOptions -> Type a -> String -prettyPrintType' tro = render . typeAsBoxImpl tro +prettyPrintType' tro = render . typeAsBoxImpl tro . convertPrettyPrintType prettyPrintLabel :: Label -> Text prettyPrintLabel (Label s) = diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index d0c03638b5..27e1c1827e 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -76,12 +76,6 @@ data Type a | RCons a Label (Type a) (Type a) -- | A type with a kind annotation | KindedType a (Type a) (Kind a) - -- | A placeholder used in pretty printing - | PrettyPrintFunction a (Type a) (Type a) - -- | A placeholder used in pretty printing - | PrettyPrintObject a (Type a) - -- | A placeholder used in pretty printing - | PrettyPrintForAll a [Text] (Type a) -- | Binary operator application. During the rebracketing phase of desugaring, -- this data constructor will be removed. | BinaryNoParensType a (Type a) (Type a) (Type a) @@ -219,12 +213,6 @@ typeToJSON annToJSON ty = variant "RCons" a (b, go c, go d) KindedType a b c -> variant "KindedType" a (go b, kindToJSON annToJSON c) - PrettyPrintFunction a b c -> - variant "PrettyPrintFunction" a (go b, go c) - PrettyPrintObject a b -> - variant "PrettyPrintObject" a (go b) - PrettyPrintForAll a b c -> - variant "PrettyPrintForAll" a (b, go c) BinaryNoParensType a b c d -> variant "BinaryNoParensType" a (go b, go c, go d) ParensInType a b -> @@ -310,15 +298,6 @@ typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do "KindedType" -> do (b, c) <- contents KindedType a <$> go b <*> kindFromJSON defaultAnn annFromJSON c - "PrettyPrintFunction" -> do - (b, c) <- contents - PrettyPrintFunction a <$> go b <*> go c - "PrettyPrintObject" -> do - b <- contents - PrettyPrintObject a <$> go b - "PrettyPrintForAll" -> do - (b, c) <- contents - PrettyPrintForAll a b <$> go c "BinaryNoParensType" -> do (b, c, d) <- contents BinaryNoParensType a <$> go b <*> go c <*> go d @@ -475,9 +454,6 @@ everywhereOnTypes f = go where go (ConstrainedType ann c ty) = f (ConstrainedType ann (mapConstraintArgs (map go) c) (go ty)) go (RCons ann name ty rest) = f (RCons ann name (go ty) (go rest)) go (KindedType ann ty k) = f (KindedType ann (go ty) k) - go (PrettyPrintFunction ann t1 t2) = f (PrettyPrintFunction ann (go t1) (go t2)) - go (PrettyPrintObject ann t) = f (PrettyPrintObject ann (go t)) - go (PrettyPrintForAll ann args t) = f (PrettyPrintForAll ann args (go t)) go (BinaryNoParensType ann t1 t2 t3) = f (BinaryNoParensType ann (go t1) (go t2) (go t3)) go (ParensInType ann t) = f (ParensInType ann (go t)) go other = f other @@ -489,9 +465,6 @@ everywhereOnTypesTopDown f = go . f where go (ConstrainedType ann c ty) = ConstrainedType ann (mapConstraintArgs (map (go . f)) c) (go (f ty)) go (RCons ann name ty rest) = RCons ann name (go (f ty)) (go (f rest)) go (KindedType ann ty k) = KindedType ann (go (f ty)) k - go (PrettyPrintFunction ann t1 t2) = PrettyPrintFunction ann (go (f t1)) (go (f t2)) - go (PrettyPrintObject ann t) = PrettyPrintObject ann (go (f t)) - go (PrettyPrintForAll ann args t) = PrettyPrintForAll ann args (go (f t)) go (BinaryNoParensType ann t1 t2 t3) = BinaryNoParensType ann (go (f t1)) (go (f t2)) (go (f t3)) go (ParensInType ann t) = ParensInType ann (go (f t)) go other = f other @@ -503,9 +476,6 @@ everywhereOnTypesM f = go where go (ConstrainedType ann c ty) = (ConstrainedType ann <$> overConstraintArgs (mapM go) c <*> go ty) >>= f go (RCons ann name ty rest) = (RCons ann name <$> go ty <*> go rest) >>= f go (KindedType ann ty k) = (KindedType ann <$> go ty <*> pure k) >>= f - go (PrettyPrintFunction ann t1 t2) = (PrettyPrintFunction ann <$> go t1 <*> go t2) >>= f - go (PrettyPrintObject ann t) = (PrettyPrintObject ann <$> go t) >>= f - go (PrettyPrintForAll ann args t) = (PrettyPrintForAll ann args <$> go t) >>= f go (BinaryNoParensType ann t1 t2 t3) = (BinaryNoParensType ann <$> go t1 <*> go t2 <*> go t3) >>= f go (ParensInType ann t) = (ParensInType ann <$> go t) >>= f go other = f other @@ -517,9 +487,6 @@ everywhereOnTypesTopDownM f = go <=< f where go (ConstrainedType ann c ty) = ConstrainedType ann <$> overConstraintArgs (mapM (go <=< f)) c <*> (f ty >>= go) go (RCons ann name ty rest) = RCons ann name <$> (f ty >>= go) <*> (f rest >>= go) go (KindedType ann ty k) = KindedType ann <$> (f ty >>= go) <*> pure k - go (PrettyPrintFunction ann t1 t2) = PrettyPrintFunction ann <$> (f t1 >>= go) <*> (f t2 >>= go) - go (PrettyPrintObject ann t) = PrettyPrintObject ann <$> (f t >>= go) - go (PrettyPrintForAll ann args t) = PrettyPrintForAll ann args <$> (f t >>= go) go (BinaryNoParensType ann t1 t2 t3) = BinaryNoParensType ann <$> (f t1 >>= go) <*> (f t2 >>= go) <*> (f t3 >>= go) go (ParensInType ann t) = ParensInType ann <$> (f t >>= go) go other = f other @@ -531,9 +498,6 @@ everythingOnTypes (<+>) f = go where go t@(ConstrainedType _ c ty) = foldl (<+>) (f t) (map go (constraintArgs c)) <+> go ty go t@(RCons _ _ ty rest) = f t <+> go ty <+> go rest go t@(KindedType _ ty _) = f t <+> go ty - go t@(PrettyPrintFunction _ t1 t2) = f t <+> go t1 <+> go t2 - go t@(PrettyPrintObject _ t1) = f t <+> go t1 - go t@(PrettyPrintForAll _ _ t1) = f t <+> go t1 go t@(BinaryNoParensType _ t1 t2 t3) = f t <+> go t1 <+> go t2 <+> go t3 go t@(ParensInType _ t1) = f t <+> go t1 go other = f other @@ -546,9 +510,6 @@ everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 where go s (ConstrainedType _ c ty) = foldl (<+>) r0 (map (go' s) (constraintArgs c)) <+> go' s ty go s (RCons _ _ ty rest) = go' s ty <+> go' s rest go s (KindedType _ ty _) = go' s ty - go s (PrettyPrintFunction _ t1 t2) = go' s t1 <+> go' s t2 - go s (PrettyPrintObject _ t1) = go' s t1 - go s (PrettyPrintForAll _ _ t1) = go' s t1 go s (BinaryNoParensType _ t1 t2 t3) = go' s t1 <+> go' s t2 <+> go' s t3 go s (ParensInType _ t1) = go' s t1 go _ _ = r0 @@ -567,9 +528,6 @@ annotationForType (Skolem a _ _ _) = a annotationForType (REmpty a) = a annotationForType (RCons a _ _ _) = a annotationForType (KindedType a _ _) = a -annotationForType (PrettyPrintFunction a _ _) = a -annotationForType (PrettyPrintObject a _) = a -annotationForType (PrettyPrintForAll a _ _) = a annotationForType (BinaryNoParensType a _ _ _) = a annotationForType (ParensInType a _) = a @@ -593,9 +551,6 @@ eqType (Skolem _ a b c) (Skolem _ a' b' c') = a == a' && b == b' && c == c' eqType (REmpty _) (REmpty _) = True eqType (RCons _ a b c) (RCons _ a' b' c') = a == a' && eqType b b' && eqType c c' eqType (KindedType _ a b) (KindedType _ a' b') = eqType a a' && eqKind b b' -eqType (PrettyPrintFunction _ a b) (PrettyPrintFunction _ a' b') = eqType a a' && eqType b b' -eqType (PrettyPrintObject _ a) (PrettyPrintObject _ a') = eqType a a' -eqType (PrettyPrintForAll _ a b) (PrettyPrintForAll _ a' b') = a == a' && eqType b b' eqType (BinaryNoParensType _ a b c) (BinaryNoParensType _ a' b' c') = eqType a a' && eqType b b' && eqType c c' eqType (ParensInType _ a) (ParensInType _ a') = eqType a a' eqType _ _ = False @@ -652,18 +607,6 @@ compareType (KindedType _ a b) (KindedType _ a' b') = compareType a a' <> compar compareType (KindedType {}) _ = LT compareType _ (KindedType {}) = GT -compareType (PrettyPrintFunction _ a b) (PrettyPrintFunction _ a' b') = compareType a a' <> compareType b b' -compareType (PrettyPrintFunction {}) _ = LT -compareType _ (PrettyPrintFunction {}) = GT - -compareType (PrettyPrintObject _ a) (PrettyPrintObject _ a') = compareType a a' -compareType (PrettyPrintObject {}) _ = LT -compareType _ (PrettyPrintObject {}) = GT - -compareType (PrettyPrintForAll _ a b) (PrettyPrintForAll _ a' b') = compare a a' <> compareType b b' -compareType (PrettyPrintForAll {}) _ = LT -compareType _ (PrettyPrintForAll {}) = GT - compareType (BinaryNoParensType _ a b c) (BinaryNoParensType _ a' b' c') = compareType a a' <> compareType b b' <> compareType c c' compareType (BinaryNoParensType {}) _ = LT compareType _ (BinaryNoParensType {}) = GT From 880f534b896b444ffc984ad360ed6d9c394254ca Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 27 Dec 2018 19:39:15 +0000 Subject: [PATCH 1038/1580] Json compat tests (#3497) * Switch psc-publish tests to use hspec * Add tests for json compatibility refs #2655, #3494 --- package.yaml | 1 + tests/Main.hs | 4 +- tests/TestPscPublish.hs | 64 +++++++++++++------ tests/json-compat/v0.11.3/generics-4.0.0.json | 1 + tests/json-compat/v0.11.3/symbols-3.0.0.json | 1 + .../v0.12.1/typelevel-prelude-3.0.0.json | 1 + 6 files changed, 51 insertions(+), 21 deletions(-) create mode 100644 tests/json-compat/v0.11.3/generics-4.0.0.json create mode 100644 tests/json-compat/v0.11.3/symbols-3.0.0.json create mode 100644 tests/json-compat/v0.12.1/typelevel-prelude-3.0.0.json diff --git a/package.yaml b/package.yaml index 4926c0bcb7..2c8d2f64ac 100644 --- a/package.yaml +++ b/package.yaml @@ -20,6 +20,7 @@ extra-source-files: - tests/purs/**/*.js - tests/purs/**/*.purs - tests/purs/**/*.json + - tests/json-compat/**/*.json - tests/support/*.json - tests/support/setup-win.cmd - tests/support/psci/**.purs diff --git a/tests/Main.hs b/tests/Main.hs index c026938241..9214ff343f 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -31,14 +31,13 @@ main = do TestUtils.updateSupportCode heading "Prim documentation test suite" TestPrimDocs.main - heading "psc-publish test suite" - TestPscPublish.main ideTests <- TestIde.main compilerTests <- TestCompiler.main psciTests <- TestPsci.main coreFnTests <- TestCoreFn.main docsTests <- TestDocs.main + publishTests <- TestPscPublish.main hierarchyTests <- TestHierarchy.main defaultMain $ @@ -49,6 +48,7 @@ main = do , ideTests , coreFnTests , docsTests + , publishTests , hierarchyTests ] diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 9126d36ced..d32853e7a6 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -7,22 +7,47 @@ module TestPscPublish where import Prelude import Control.Monad.IO.Class (liftIO) -import System.Exit (exitFailure) import Data.ByteString.Lazy (ByteString) import Data.Time.Clock (getCurrentTime) import qualified Data.Aeson as A import Data.Version +import Data.Foldable (forM_) +import qualified Text.PrettyPrint.Boxes as Boxes +import System.Directory (listDirectory) +import System.FilePath (()) import Language.PureScript.Docs import Language.PureScript.Publish import Language.PureScript.Publish.ErrorsWarnings as Publish +import Test.Tasty +import Test.Tasty.Hspec (Spec, Expectation, runIO, context, it, expectationFailure, testSpec) import TestUtils -main :: IO () -main = testPackage - "tests/support/bower_components/purescript-prelude" - "../../prelude-resolutions.json" +main :: IO TestTree +main = testSpec "publish" spec + +spec :: Spec +spec = do + it "roundtrips the json for purescript-prelude" $ do + testPackage + "tests/support/bower_components/purescript-prelude" + "../../prelude-resolutions.json" + + context "json compatibility" $ do + let compatDir = "tests" "json-compat" + versions <- runIO $ listDirectory compatDir + forM_ versions $ \version -> do + context ("json produced by " ++ version) $ do + files <- runIO $ listDirectory (compatDir version) + forM_ files $ \file -> do + it file $ do + result <- A.eitherDecodeFileStrict' (compatDir version file) + case result of + Right (_ :: VerifiedPackage) -> + pure () + Left err -> + expectationFailure ("JSON parsing failed: " ++ err) data TestResult = ParseFailed String @@ -51,18 +76,19 @@ testRunOptions = defaultPublishOptions -- | Given a directory which contains a package, produce JSON from it, and then -- | attempt to parse it again, and ensure that it doesn't change. -testPackage :: FilePath -> FilePath -> IO () -testPackage dir resolutionsFile = pushd dir $ do - res <- preparePackage "bower.json" resolutionsFile testRunOptions +testPackage :: FilePath -> FilePath -> Expectation +testPackage dir resolutionsFile = do + res <- pushd dir (preparePackage "bower.json" resolutionsFile testRunOptions) case res of - Left e -> preparePackageError e - Right package -> case roundTrip package of - Pass _ -> do - putStrLn ("psc-publish test passed for: " ++ dir) - pure () - other -> do - putStrLn ("psc-publish tests failed on " ++ dir ++ ":") - print other - exitFailure - where - preparePackageError e = Publish.printErrorToStdout e >> exitFailure + Left err -> + expectationFailure $ + "Failed to produce JSON from " ++ dir ++ ":\n" ++ + Boxes.render (Publish.renderError err) + Right package -> + case roundTrip package of + Pass _ -> + pure () + ParseFailed msg -> + expectationFailure ("Failed to re-parse: " ++ msg) + Mismatch _ _ -> + expectationFailure "JSON did not match" diff --git a/tests/json-compat/v0.11.3/generics-4.0.0.json b/tests/json-compat/v0.11.3/generics-4.0.0.json new file mode 100644 index 0000000000..9b7d826ff7 --- /dev/null +++ b/tests/json-compat/v0.11.3/generics-4.0.0.json @@ -0,0 +1 @@ +{"uploader":"paf31","packageMeta":{"homepage":"https://github.com/purescript-contrib/purescript-generics","repository":{"url":"git://github.com/purescript/purescript-generics.git","type":"git"},"ignore":["**/.*","bower_components","node_modules","output","test","bower.json","package.json"],"devDependencies":{"purescript-console":"^3.0.0","purescript-assert":"^3.0.0"},"authors":[{"email":"gershomb@gmail.com","name":"Gershom Bazerman"}],"dependencies":{"purescript-proxy":"^2.0.0","purescript-either":"^3.0.0","purescript-arrays":"^4.0.0","purescript-strings":"^3.0.0","purescript-identity":"^3.0.0","purescript-lists":"^4.0.0"},"name":"purescript-generics","license":["MIT"],"description":"Generic programming for PureScript"},"tagTime":"2017-03-26T22:17:38+0000","modules":[{"reExports":[],"name":"Data.Generic","comments":null,"declarations":[{"children":[{"comments":null,"title":"toSpine","info":{"declType":"typeClassMember","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeVar","contents":"a"}]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSpine"]}]}},"sourceSpan":null},{"comments":null,"title":"toSignature","info":{"declType":"typeClassMember","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"a"}]}]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSignature"]}]}},"sourceSpan":null},{"comments":null,"title":"fromSpine","info":{"declType":"typeClassMember","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSpine"]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Maybe"],"Maybe"]},{"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":null},{"comments":null,"title":"genericNumber","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[44,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[48,24]}},{"comments":null,"title":"genericInt","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[50,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[54,24]}},{"comments":null,"title":"genericString","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[56,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[60,24]}},{"comments":null,"title":"genericChar","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"TypeConstructor","contents":[["Prim"],"Char"]}]}},"sourceSpan":{"start":[62,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[66,24]}},{"comments":null,"title":"genericBool","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[68,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[72,24]}},{"comments":null,"title":"genericArray","info":{"declType":"instance","dependencies":[{"constraintClass":[["Data","Generic"],"Generic"],"constraintArgs":[{"tag":"TypeVar","contents":"a"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"tag":"TypeVar","contents":"a"}]}}]}},"sourceSpan":{"start":[74,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[81,24]}},{"comments":null,"title":"genericUnit","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[83,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[87,24]}},{"comments":null,"title":"genericVoid","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"TypeConstructor","contents":[["Data","Void"],"Void"]}]}},"sourceSpan":{"start":[89,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[92,24]}},{"comments":null,"title":"genericTuple","info":{"declType":"instance","dependencies":[{"constraintClass":[["Data","Generic"],"Generic"],"constraintArgs":[{"tag":"TypeVar","contents":"a"}],"constraintData":null},{"constraintClass":[["Data","Generic"],"Generic"],"constraintArgs":[{"tag":"TypeVar","contents":"b"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Tuple"],"Tuple"]},{"tag":"TypeVar","contents":"a"}]},{"tag":"TypeVar","contents":"b"}]}}]}},"sourceSpan":{"start":[94,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[114,24]}},{"comments":null,"title":"genericList","info":{"declType":"instance","dependencies":[{"constraintClass":[["Data","Generic"],"Generic"],"constraintArgs":[{"tag":"TypeVar","contents":"a"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","List","Types"],"List"]},{"tag":"TypeVar","contents":"a"}]}}]}},"sourceSpan":{"start":[116,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[141,24]}},{"comments":null,"title":"genericNonEmptyList","info":{"declType":"instance","dependencies":[{"constraintClass":[["Data","Generic"],"Generic"],"constraintArgs":[{"tag":"TypeVar","contents":"a"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","List","Types"],"NonEmptyList"]},{"tag":"TypeVar","contents":"a"}]}}]}},"sourceSpan":{"start":[143,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[158,24]}},{"comments":null,"title":"genericMaybe","info":{"declType":"instance","dependencies":[{"constraintClass":[["Data","Generic"],"Generic"],"constraintArgs":[{"tag":"TypeVar","contents":"a"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Maybe"],"Maybe"]},{"tag":"TypeVar","contents":"a"}]}}]}},"sourceSpan":{"start":[160,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[178,24]}},{"comments":null,"title":"genericEither","info":{"declType":"instance","dependencies":[{"constraintClass":[["Data","Generic"],"Generic"],"constraintArgs":[{"tag":"TypeVar","contents":"a"}],"constraintData":null},{"constraintClass":[["Data","Generic"],"Generic"],"constraintArgs":[{"tag":"TypeVar","contents":"b"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Either"],"Either"]},{"tag":"TypeVar","contents":"a"}]},{"tag":"TypeVar","contents":"b"}]}}]}},"sourceSpan":{"start":[180,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[200,24]}},{"comments":null,"title":"genericIdentity","info":{"declType":"instance","dependencies":[{"constraintClass":[["Data","Generic"],"Generic"],"constraintArgs":[{"tag":"TypeVar","contents":"a"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Identity"],"Identity"]},{"tag":"TypeVar","contents":"a"}]}}]}},"sourceSpan":{"start":[202,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[215,24]}},{"comments":null,"title":"genericOrdering","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[217,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[233,17]}},{"comments":null,"title":"genericNonEmpty","info":{"declType":"instance","dependencies":[{"constraintClass":[["Data","Generic"],"Generic"],"constraintArgs":[{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeVar","contents":"f"},{"tag":"TypeVar","contents":"a"}]}}],"constraintData":null},{"constraintClass":[["Data","Generic"],"Generic"],"constraintArgs":[{"tag":"TypeVar","contents":"a"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Generic"],"Generic"]},{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","NonEmpty"],"NonEmpty"]},{"tag":"TypeVar","contents":"f"}]},{"tag":"TypeVar","contents":"a"}]}}]}},"sourceSpan":{"start":[235,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[255,24]}}],"comments":"The Generic typeclass provides methods for sending data to/from spine\nrepresentations, as well as querying about the signatures of spine\nrepresentations.\n\nFor standard data structures, you can simply write\n`derive instance genericFoo :: Generic Foo` in the module they are\ndeclared, and the instance methods will be filled in for you.\n","title":"Generic","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[39,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[42,39]}},{"children":[{"comments":null,"title":"SProd","info":{"arguments":[{"tag":"TypeConstructor","contents":[["Prim"],"String"]},{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSpine"]}]}}]}}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SRecord","info":{"arguments":[{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"tag":"RCons","contents":["recLabel",{"tag":"TypeConstructor","contents":[["Prim"],"String"]},{"tag":"RCons","contents":["recValue",{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSpine"]}]},{"tag":"REmpty"}]}]}]}]}}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SNumber","info":{"arguments":[{"tag":"TypeConstructor","contents":[["Prim"],"Number"]}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SBoolean","info":{"arguments":[{"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SInt","info":{"arguments":[{"tag":"TypeConstructor","contents":[["Prim"],"Int"]}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SString","info":{"arguments":[{"tag":"TypeConstructor","contents":[["Prim"],"String"]}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SChar","info":{"arguments":[{"tag":"TypeConstructor","contents":[["Prim"],"Char"]}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SArray","info":{"arguments":[{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSpine"]}]}}]}}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SUnit","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"showGenericSpine","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSpine"]}]}},"sourceSpan":{"start":[270,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[284,97]}},{"comments":null,"title":"eqGenericSpine","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSpine"]}]}},"sourceSpan":{"start":[290,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[301,17]}},{"comments":null,"title":"ordGenericSpine","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSpine"]}]}},"sourceSpan":{"start":[303,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[336,27]}}],"comments":"A GenericSpine is a universal representation of an arbitrary data\nstructure (that does not contain function arrows).\n","title":"GenericSpine","info":{"declType":"data","dataDeclType":"data","typeArguments":[]},"sourceSpan":{"start":[259,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[268,10]}},{"children":[{"comments":null,"title":"SigProd","info":{"arguments":[{"tag":"TypeConstructor","contents":[["Prim"],"String"]},{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"DataConstructor"]}]}}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SigRecord","info":{"arguments":[{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"tag":"RCons","contents":["recLabel",{"tag":"TypeConstructor","contents":[["Prim"],"String"]},{"tag":"RCons","contents":["recValue",{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSignature"]}]},{"tag":"REmpty"}]}]}]}]}}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SigNumber","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SigBoolean","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SigInt","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SigString","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SigChar","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SigArray","info":{"arguments":[{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSignature"]}]}}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"SigUnit","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"eqGenericSignature","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSignature"]}]}},"sourceSpan":{"start":[351,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[362,17]}},{"comments":null,"title":"showGenericSignature","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSignature"]}]}},"sourceSpan":{"start":[364,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[365,23]}}],"comments":"A GenericSignature is a universal representation of the structure of an\narbitrary data structure (that does not contain function arrows).\n","title":"GenericSignature","info":{"declType":"data","dataDeclType":"data","typeArguments":[]},"sourceSpan":{"start":[340,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[349,12]}},{"children":[],"comments":"Identifies a data constructor.\n","title":"DataConstructor","info":{"arguments":[],"declType":"typeSynonym","type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"tag":"RCons","contents":["sigConstructor",{"tag":"TypeConstructor","contents":[["Prim"],"String"]},{"tag":"RCons","contents":["sigValues",{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSignature"]}]}}]},{"tag":"REmpty"}]}]}]}},"sourceSpan":{"start":[368,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[371,4]}},{"children":[],"comments":null,"title":"showDataConstructor","info":{"declType":"value","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"DataConstructor"]}]},{"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[378,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[378,49]}},{"children":[],"comments":null,"title":"showSignature","info":{"declType":"value","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSignature"]}]},{"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[384,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[384,44]}},{"children":[],"comments":"Checks that the spine follows the structure defined by the signature\n","title":"isValidSpine","info":{"declType":"value","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSignature"]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Data","Generic"],"GenericSpine"]}]},{"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}},"sourceSpan":{"start":[429,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[429,60]}},{"children":[],"comments":"This function can be used as the default instance for Show for any\ninstance of Generic\n","title":"gShow","info":{"declType":"value","type":{"tag":"ForAll","contents":["a",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Data","Generic"],"Generic"],"constraintArgs":[{"tag":"TypeVar","contents":"a"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeVar","contents":"a"}]},{"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}]},null]}},"sourceSpan":{"start":[457,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[457,44]}},{"children":[],"comments":"This function can be used as an implementation of the `eq` function of `Eq`\nfor any type with a `Generic` instance.\n\n**Note**: It is preferrable to use `derive instance` for `Eq` instances\nrather than relying on `gEq`, where possible.\n","title":"gEq","info":{"declType":"value","type":{"tag":"ForAll","contents":["a",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Data","Generic"],"Generic"],"constraintArgs":[{"tag":"TypeVar","contents":"a"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeVar","contents":"a"}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeVar","contents":"a"}]},{"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}]},null]}},"sourceSpan":{"start":[487,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[487,48]}},{"children":[],"comments":"This function can be used as an implementation of the `compare` function\nof `Ord` for any type with a `Generic` instance.\n\n**Note**: It is preferrable to use `derive instance` for `Ord` instances\nrather than relying on `gCompare`, where possible.\n","title":"gCompare","info":{"declType":"value","type":{"tag":"ForAll","contents":["a",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Data","Generic"],"Generic"],"constraintArgs":[{"tag":"TypeVar","contents":"a"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeVar","contents":"a"}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeVar","contents":"a"}]},{"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}]}]},null]}},"sourceSpan":{"start":[495,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/generics/v4.0.0/src/Data/Generic.purs","end":[495,54]}}]}],"resolvedDependencies":{"purescript-proxy":"2.0.0","purescript-newtype":"2.0.0","purescript-control":"3.0.0","purescript-either":"3.0.0","purescript-arrays":"4.0.1","purescript-maybe":"3.0.0","purescript-unfoldable":"3.0.0","purescript-invariant":"3.0.0","purescript-lazy":"3.0.0","purescript-monoid":"3.0.0","purescript-foldable-traversable":"3.0.0","purescript-tailrec":"3.0.0","purescript-prelude":"3.0.0","purescript-st":"3.0.0","purescript-bifunctors":"3.0.0","purescript-nonempty":"4.0.0","purescript-unsafe-coerce":"3.0.0","purescript-eff":"3.1.0","purescript-tuples":"4.0.0","purescript-partial":"1.2.0","purescript-strings":"3.0.0","purescript-identity":"3.0.0","purescript-lists":"4.0.1"},"version":"4.0.0","github":["purescript","purescript-generics"],"versionTag":"v4.0.0","moduleMap":{"Data.BooleanAlgebra":"purescript-prelude","Data.Ring":"purescript-prelude","Data.NonEmpty":"purescript-nonempty","Control.Monad.Eff.Unsafe":"purescript-eff","Data.Bifunctor.Flip":"purescript-bifunctors","Data.Ord":"purescript-prelude","Data.Monoid.Dual":"purescript-monoid","Control.Monad.Rec.Class":"purescript-tailrec","Data.Bitraversable":"purescript-foldable-traversable","Data.Boolean":"purescript-prelude","Control.Biapplicative":"purescript-bifunctors","Type.Proxy":"purescript-proxy","Data.Array.ST.Iterator":"purescript-arrays","Data.Bounded":"purescript-prelude","Data.Show":"purescript-prelude","Data.Bifunctor.Clown":"purescript-bifunctors","Data.Foldable":"purescript-foldable-traversable","Control.Apply":"purescript-prelude","Data.Tuple.Nested":"purescript-tuples","Control.Monad":"purescript-prelude","Data.Lazy":"purescript-lazy","Data.Monoid":"purescript-monoid","Control.Monad.Eff.Uncurried":"purescript-eff","Data.Maybe.First":"purescript-maybe","Control.Bind":"purescript-prelude","Data.Monoid.Additive":"purescript-monoid","Data.String.Regex":"purescript-strings","Data.HeytingAlgebra":"purescript-prelude","Control.Alt":"purescript-control","Data.List.ZipList":"purescript-lists","Data.Ord.Unsafe":"purescript-prelude","Data.Semigroup":"purescript-prelude","Control.Monad.Eff":"purescript-eff","Data.Tuple":"purescript-tuples","Control.Biapply":"purescript-bifunctors","Control.Alternative":"purescript-control","Data.Semiring":"purescript-prelude","Data.CommutativeRing":"purescript-prelude","Data.NaturalTransformation":"purescript-prelude","Data.Monoid.Conj":"purescript-monoid","Data.Unfoldable":"purescript-unfoldable","Control.Monad.ST":"purescript-st","Data.List.Types":"purescript-lists","Data.Functor":"purescript-prelude","Unsafe.Coerce":"purescript-unsafe-coerce","Data.List.Lazy.Types":"purescript-lists","Control.Category":"purescript-prelude","Data.Maybe":"purescript-maybe","Data.String.Regex.Unsafe":"purescript-strings","Control.Comonad":"purescript-control","Data.Function":"purescript-prelude","Data.List":"purescript-lists","Data.Field":"purescript-prelude","Data.List.Lazy":"purescript-lists","Data.EuclideanRing":"purescript-prelude","Data.Functor.Invariant":"purescript-invariant","Data.String.Unsafe":"purescript-strings","Prelude":"purescript-prelude","Partial.Unsafe":"purescript-partial","Data.Array":"purescript-arrays","Data.Bifunctor.Product":"purescript-bifunctors","Control.Extend":"purescript-control","Control.Lazy":"purescript-control","Data.Eq":"purescript-prelude","Data.Either.Nested":"purescript-either","Data.Newtype":"purescript-newtype","Data.Bifunctor":"purescript-bifunctors","Data.Monoid.Disj":"purescript-monoid","Data.Array.Partial":"purescript-arrays","Data.String.CaseInsensitive":"purescript-strings","Control.MonadPlus":"purescript-control","Data.Void":"purescript-prelude","Control.MonadZero":"purescript-control","Data.Bifunctor.Joker":"purescript-bifunctors","Data.Bifunctor.Wrap":"purescript-bifunctors","Data.Maybe.Last":"purescript-maybe","Data.Unit":"purescript-prelude","Data.List.NonEmpty":"purescript-lists","Data.List.Lazy.NonEmpty":"purescript-lists","Data.Ordering":"purescript-prelude","Data.Identity":"purescript-identity","Data.String":"purescript-strings","Control.Plus":"purescript-control","Control.Monad.Eff.Class":"purescript-eff","Partial":"purescript-partial","Data.Monoid.Multiplicative":"purescript-monoid","Data.Array.ST":"purescript-arrays","Control.Semigroupoid":"purescript-prelude","Data.Monoid.Alternate":"purescript-monoid","Data.Char":"purescript-strings","Data.Bifunctor.Join":"purescript-bifunctors","Data.Bifoldable":"purescript-foldable-traversable","Data.Monoid.Endo":"purescript-monoid","Data.List.Partial":"purescript-lists","Data.String.Regex.Flags":"purescript-strings","Data.Either":"purescript-either","Control.Applicative":"purescript-prelude","Data.Traversable":"purescript-foldable-traversable"},"compilerVersion":"0.11.3"} \ No newline at end of file diff --git a/tests/json-compat/v0.11.3/symbols-3.0.0.json b/tests/json-compat/v0.11.3/symbols-3.0.0.json new file mode 100644 index 0000000000..c54aa75b1f --- /dev/null +++ b/tests/json-compat/v0.11.3/symbols-3.0.0.json @@ -0,0 +1 @@ +{"uploader":"paf31","packageMeta":{"homepage":"https://github.com/purescript/purescript-symbols","repository":{"url":"git://github.com/purescript/purescript-symbols.git","type":"git"},"ignore":["**/.*","bower_components","node_modules","output","test","bower.json","package.json"],"dependencies":{"purescript-prelude":"^3.0.0","purescript-unsafe-coerce":"^3.0.0"},"name":"purescript-symbols","license":["MIT"],"description":"Utilities for working with type-level strings"},"tagTime":"2017-03-26T00:59:23+0000","modules":[{"reExports":[],"name":"Data.Symbol","comments":null,"declarations":[{"children":[{"comments":null,"title":"SProxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":"A value-level proxy for a type-level symbol.\n","title":"SProxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["sym",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}]]},"sourceSpan":{"start":[12,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/symbols/v3.0.0/src/Data/Symbol.purs","end":[12,37]}},{"children":[{"comments":null,"title":"reflectSymbol","info":{"declType":"typeClassMember","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"sym"}]}]},{"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":null},{"comments":null,"title":"isSymbolTypeConcat","info":{"declType":"instance","dependencies":[{"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"tag":"TypeVar","contents":"left"}],"constraintData":null},{"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"tag":"TypeVar","contents":"right"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"IsSymbol"]},{"tag":"ParensInType","contents":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"TypeConcat"]},{"tag":"TypeVar","contents":"left"}]},{"tag":"TypeVar","contents":"right"}]}}]}},"sourceSpan":{"start":[18,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/symbols/v3.0.0/src/Data/Symbol.purs","end":[19,100]}}],"comments":"A class for known symbols\n","title":"IsSymbol","info":{"fundeps":[],"arguments":[["sym",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[15,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/symbols/v3.0.0/src/Data/Symbol.purs","end":[16,40]}},{"children":[],"comments":null,"title":"reifySymbol","info":{"declType":"value","type":{"tag":"ForAll","contents":["r",{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Prim"],"String"]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"ParensInType","contents":{"tag":"ForAll","contents":["sym",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"tag":"TypeVar","contents":"sym"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"sym"}]}]},{"tag":"TypeVar","contents":"r"}]}]},null]}}]},{"tag":"TypeVar","contents":"r"}]}]},null]}},"sourceSpan":{"start":[21,1],"name":"/private/tmp/pursuit-staging/.psc-package/psc-0.11.3/symbols/v3.0.0/src/Data/Symbol.purs","end":[21,86]}}]}],"resolvedDependencies":{"purescript-prelude":"3.0.0","purescript-unsafe-coerce":"3.0.0"},"version":"3.0.0","github":["purescript","purescript-symbols"],"versionTag":"v3.0.0","moduleMap":{"Data.BooleanAlgebra":"purescript-prelude","Data.Ring":"purescript-prelude","Data.Ord":"purescript-prelude","Data.Boolean":"purescript-prelude","Data.Bounded":"purescript-prelude","Data.Show":"purescript-prelude","Control.Apply":"purescript-prelude","Control.Monad":"purescript-prelude","Control.Bind":"purescript-prelude","Data.HeytingAlgebra":"purescript-prelude","Data.Ord.Unsafe":"purescript-prelude","Data.Semigroup":"purescript-prelude","Data.Semiring":"purescript-prelude","Data.CommutativeRing":"purescript-prelude","Data.NaturalTransformation":"purescript-prelude","Data.Functor":"purescript-prelude","Unsafe.Coerce":"purescript-unsafe-coerce","Control.Category":"purescript-prelude","Data.Function":"purescript-prelude","Data.Field":"purescript-prelude","Data.EuclideanRing":"purescript-prelude","Prelude":"purescript-prelude","Data.Eq":"purescript-prelude","Data.Void":"purescript-prelude","Data.Unit":"purescript-prelude","Data.Ordering":"purescript-prelude","Control.Semigroupoid":"purescript-prelude","Control.Applicative":"purescript-prelude"},"compilerVersion":"0.11.3"} \ No newline at end of file diff --git a/tests/json-compat/v0.12.1/typelevel-prelude-3.0.0.json b/tests/json-compat/v0.12.1/typelevel-prelude-3.0.0.json new file mode 100644 index 0000000000..b6d54ad987 --- /dev/null +++ b/tests/json-compat/v0.12.1/typelevel-prelude-3.0.0.json @@ -0,0 +1 @@ +{"uploader":"hdgarrood","packageMeta":{"homepage":"https://github.com/purescript/purescript-typelevel-prelude","repository":{"url":"git://github.com/purescript/purescript-typelevel-prelude.git","type":"git"},"ignore":["**/.*","bower_components","node_modules","output","bower.json","package.json"],"dependencies":{"purescript-proxy":"^3.0.0","purescript-type-equality":"^3.0.0","purescript-prelude":"^4.0.0"},"name":"purescript-typelevel-prelude","license":["BSD-3-Clause"],"description":"Types and kinds for basic type-level programming"},"tagTime":"2018-05-22T23:33:44+0000","modules":[{"reExports":[],"name":"Type.Data.Boolean","comments":null,"declarations":[{"children":[],"comments":null,"title":"Boolean","info":{"declType":"kind"},"sourceSpan":{"start":[21,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[21,28]}},{"children":[{"comments":null,"title":"isBooleanTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"IsBoolean"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[32,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[32,41]}},{"comments":null,"title":"andTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"And"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeVar","contents":"rhs"}]}},"sourceSpan":{"start":[45,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[45,37]}},{"comments":null,"title":"orTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Or"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[56,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[56,36]}},{"comments":null,"title":"notTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Not"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[66,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[66,35]}},{"comments":null,"title":"notFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Not"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[67,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[67,36]}},{"comments":null,"title":"ifTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"If"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]},{"tag":"TypeVar","contents":"onTrue"}]},{"tag":"TypeVar","contents":"onFalse"}]},{"tag":"TypeVar","contents":"onTrue"}]}},"sourceSpan":{"start":[78,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[78,49]}}],"comments":null,"title":"True","info":{"kind":{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]},"declType":"externData"},"sourceSpan":{"start":[22,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[22,36]}},{"children":[{"comments":null,"title":"isBooleanFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"IsBoolean"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[33,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[33,43]}},{"comments":null,"title":"andFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"And"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[46,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[46,41]}},{"comments":null,"title":"orFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Or"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeVar","contents":"rhs"}]}},"sourceSpan":{"start":[57,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[57,37]}},{"comments":null,"title":"notTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Not"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[66,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[66,35]}},{"comments":null,"title":"notFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Not"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[67,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[67,36]}},{"comments":null,"title":"ifFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"If"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]},{"tag":"TypeVar","contents":"onTrue"}]},{"tag":"TypeVar","contents":"onFalse"}]},{"tag":"TypeVar","contents":"onFalse"}]}},"sourceSpan":{"start":[79,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[79,52]}}],"comments":null,"title":"False","info":{"kind":{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]},"declType":"externData"},"sourceSpan":{"start":[23,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[23,37]}},{"children":[{"comments":null,"title":"BProxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":"Value proxy for `Boolean` types\n","title":"BProxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["bool",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}]]},"sourceSpan":{"start":[26,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[26,39]}},{"children":[{"comments":null,"title":"reflectBoolean","info":{"declType":"typeClassMember","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"bool"}]}]},{"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[30,3],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[30,43]}},{"comments":null,"title":"isBooleanTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"IsBoolean"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[32,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[32,41]}},{"comments":null,"title":"isBooleanFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"IsBoolean"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[33,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[33,43]}}],"comments":"Class for reflecting a type level `Boolean` at the value level\n","title":"IsBoolean","info":{"fundeps":[],"arguments":[["bool",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[29,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[30,43]}},{"children":[],"comments":"Use a value level `Boolean` as a type-level `Boolean`\n","title":"reifyBoolean","info":{"declType":"value","type":{"tag":"ForAll","contents":["r",{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"ParensInType","contents":{"tag":"ForAll","contents":["o",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Type","Data","Boolean"],"IsBoolean"],"constraintArgs":[{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"o"}]}]},{"tag":"TypeVar","contents":"r"}]}]},null]}}]},{"tag":"TypeVar","contents":"r"}]}]},null]}},"sourceSpan":{"start":[36,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[36,83]}},{"children":[{"comments":null,"title":"andTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"And"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeVar","contents":"rhs"}]}},"sourceSpan":{"start":[45,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[45,37]}},{"comments":null,"title":"andFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"And"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[46,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[46,41]}}],"comments":"And two `Boolean` types together\n","title":"And","info":{"fundeps":[[["lhs","rhs"],["output"]]],"arguments":[["lhs",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}],["rhs",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}],["output",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[41,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[44,28]}},{"children":[],"comments":null,"title":"and","info":{"declType":"value","type":{"tag":"ForAll","contents":["o",{"tag":"ForAll","contents":["r",{"tag":"ForAll","contents":["l",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Type","Data","Boolean"],"And"],"constraintArgs":[{"tag":"TypeVar","contents":"l"},{"tag":"TypeVar","contents":"r"},{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"l"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"r"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"o"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[48,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[48,67]}},{"children":[{"comments":null,"title":"orTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Or"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[56,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[56,36]}},{"comments":null,"title":"orFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Or"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeVar","contents":"rhs"}]}},"sourceSpan":{"start":[57,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[57,37]}}],"comments":"Or two `Boolean` types together\n","title":"Or","info":{"fundeps":[[["lhs","rhs"],["output"]]],"arguments":[["lhs",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}],["rhs",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}],["output",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[52,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[55,27]}},{"children":[],"comments":null,"title":"or","info":{"declType":"value","type":{"tag":"ForAll","contents":["o",{"tag":"ForAll","contents":["r",{"tag":"ForAll","contents":["l",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Type","Data","Boolean"],"Or"],"constraintArgs":[{"tag":"TypeVar","contents":"l"},{"tag":"TypeVar","contents":"r"},{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"l"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"r"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"o"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[59,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[59,65]}},{"children":[{"comments":null,"title":"notTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Not"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[66,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[66,35]}},{"comments":null,"title":"notFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Not"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[67,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[67,36]}}],"comments":"Not a `Boolean`\n","title":"Not","info":{"fundeps":[[["bool"],["output"]]],"arguments":[["bool",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}],["output",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[63,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[65,25]}},{"children":[],"comments":null,"title":"not","info":{"declType":"value","type":{"tag":"ForAll","contents":["o",{"tag":"ForAll","contents":["i",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Type","Data","Boolean"],"Not"],"constraintArgs":[{"tag":"TypeVar","contents":"i"},{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"i"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"o"}]}]}]},null]},null]}},"sourceSpan":{"start":[69,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[69,51]}},{"children":[{"comments":null,"title":"ifTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"If"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]},{"tag":"TypeVar","contents":"onTrue"}]},{"tag":"TypeVar","contents":"onFalse"}]},{"tag":"TypeVar","contents":"onTrue"}]}},"sourceSpan":{"start":[78,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[78,49]}},{"comments":null,"title":"ifFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"If"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]},{"tag":"TypeVar","contents":"onTrue"}]},{"tag":"TypeVar","contents":"onFalse"}]},{"tag":"TypeVar","contents":"onFalse"}]}},"sourceSpan":{"start":[79,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[79,52]}}],"comments":"If - dispatch based on a boolean\n","title":"If","info":{"fundeps":[[["bool","onTrue","onFalse"],["output"]]],"arguments":[["bool",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}],["onTrue",{"tag":"NamedKind","contents":[["Prim"],"Type"]}],["onFalse",{"tag":"NamedKind","contents":[["Prim"],"Type"]}],["output",{"tag":"NamedKind","contents":[["Prim"],"Type"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[73,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[77,39]}},{"children":[],"comments":null,"title":"if_","info":{"declType":"value","type":{"tag":"ForAll","contents":["o",{"tag":"ForAll","contents":["e",{"tag":"ForAll","contents":["t",{"tag":"ForAll","contents":["b",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Type","Data","Boolean"],"If"],"constraintArgs":[{"tag":"TypeVar","contents":"b"},{"tag":"TypeVar","contents":"t"},{"tag":"TypeVar","contents":"e"},{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"b"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"t"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"e"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"o"}]}]}]}]}]},null]},null]},null]},null]}},"sourceSpan":{"start":[81,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[81,79]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Prim","Ordering"]},"declarations":[{"children":[],"comments":"The 'less than' ordering type.\n","title":"LT","info":{"kind":{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]},"declType":"externData"},"sourceSpan":null},{"children":[],"comments":"The 'greater than' ordering type.\n","title":"GT","info":{"kind":{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]},"declType":"externData"},"sourceSpan":null},{"children":[],"comments":"The 'equal to' ordering type.\n","title":"EQ","info":{"kind":{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]},"declType":"externData"},"sourceSpan":null},{"children":[],"comments":"The `Ordering` kind represents the three possibilites of comparing two\ntypes of the same kind: `LT` (less than), `EQ` (equal to), and\n`GT` (greater than).\n","title":"Ordering","info":{"declType":"kind"},"sourceSpan":null}]}],"name":"Type.Data.Ordering","comments":null,"declarations":[{"children":[{"comments":null,"title":"OProxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":"Value proxy for `Ordering` types\n","title":"OProxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["ordering",{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]}]]},"sourceSpan":{"start":[20,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[20,44]}},{"children":[{"comments":null,"title":"reflectOrdering","info":{"declType":"typeClassMember","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"OProxy"]},{"tag":"TypeVar","contents":"ordering"}]}]},{"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[24,3],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[24,49]}},{"comments":null,"title":"isOrderingLT","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"IsOrdering"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"LT"]}]}},"sourceSpan":{"start":[26,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[26,39]}},{"comments":null,"title":"isOrderingEQ","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"IsOrdering"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"EQ"]}]}},"sourceSpan":{"start":[27,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[27,39]}},{"comments":null,"title":"isOrderingGT","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"IsOrdering"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"GT"]}]}},"sourceSpan":{"start":[28,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[28,39]}}],"comments":"Class for reflecting a type level `Ordering` at the value level\n","title":"IsOrdering","info":{"fundeps":[],"arguments":[["ordering",{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[23,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[24,49]}},{"children":[],"comments":"Use a value level `Ordering` as a type-level `Ordering`\n","title":"reifyOrdering","info":{"declType":"value","type":{"tag":"ForAll","contents":["r",{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"ParensInType","contents":{"tag":"ForAll","contents":["o",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Type","Data","Ordering"],"IsOrdering"],"constraintArgs":[{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"OProxy"]},{"tag":"TypeVar","contents":"o"}]}]},{"tag":"TypeVar","contents":"r"}]}]},null]}}]},{"tag":"TypeVar","contents":"r"}]}]},null]}},"sourceSpan":{"start":[31,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[31,86]}},{"children":[{"comments":null,"title":"appendOrderingLT","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Append"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"LT"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"LT"]}]}},"sourceSpan":{"start":[42,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[42,46]}},{"comments":null,"title":"appendOrderingEQ","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Append"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"EQ"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeVar","contents":"rhs"}]}},"sourceSpan":{"start":[43,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[43,47]}},{"comments":null,"title":"appendOrderingGT","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Append"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"GT"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"GT"]}]}},"sourceSpan":{"start":[44,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[44,46]}}],"comments":"Append two `Ordering` types together\nReflective of the semigroup for value level `Ordering`\n","title":"Append","info":{"fundeps":[[["lhs"],["rhs","output"]]],"arguments":[["lhs",{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]}],["rhs",{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]}],["output",{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[38,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[41,31]}},{"children":[],"comments":null,"title":"append","info":{"declType":"value","type":{"tag":"ForAll","contents":["o",{"tag":"ForAll","contents":["r",{"tag":"ForAll","contents":["l",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Type","Data","Ordering"],"Append"],"constraintArgs":[{"tag":"TypeVar","contents":"l"},{"tag":"TypeVar","contents":"r"},{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"OProxy"]},{"tag":"TypeVar","contents":"l"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"OProxy"]},{"tag":"TypeVar","contents":"r"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"OProxy"]},{"tag":"TypeVar","contents":"o"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[46,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[46,73]}},{"children":[{"comments":null,"title":"invertOrderingLT","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Invert"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"LT"]}]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"GT"]}]}},"sourceSpan":{"start":[53,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[53,42]}},{"comments":null,"title":"invertOrderingEQ","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Invert"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"EQ"]}]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"EQ"]}]}},"sourceSpan":{"start":[54,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[54,42]}},{"comments":null,"title":"invertOrderingGT","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Invert"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"GT"]}]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"LT"]}]}},"sourceSpan":{"start":[55,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[55,42]}}],"comments":"Invert an `Ordering`\n","title":"Invert","info":{"fundeps":[[["ordering"],["result"]]],"arguments":[["ordering",{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]}],["result",{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[50,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[52,32]}},{"children":[],"comments":null,"title":"invert","info":{"declType":"value","type":{"tag":"ForAll","contents":["o",{"tag":"ForAll","contents":["i",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Type","Data","Ordering"],"Invert"],"constraintArgs":[{"tag":"TypeVar","contents":"i"},{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"OProxy"]},{"tag":"TypeVar","contents":"i"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"OProxy"]},{"tag":"TypeVar","contents":"o"}]}]}]},null]},null]}},"sourceSpan":{"start":[57,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[57,57]}},{"children":[{"comments":null,"title":"equalsEQEQ","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Equals"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"EQ"]}]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"EQ"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[65,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[65,41]}},{"comments":null,"title":"equalsLTLT","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Equals"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"LT"]}]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"LT"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[66,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[66,41]}},{"comments":null,"title":"equalsGTGT","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Equals"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"GT"]}]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"GT"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[67,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[67,41]}},{"comments":null,"title":"equalsEQLT","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Equals"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"EQ"]}]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"LT"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[68,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[68,42]}},{"comments":null,"title":"equalsEQGT","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Equals"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"EQ"]}]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"GT"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[69,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[69,42]}},{"comments":null,"title":"equalsLTEQ","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Equals"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"LT"]}]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"EQ"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[70,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[70,42]}},{"comments":null,"title":"equalsLTGT","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Equals"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"LT"]}]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"GT"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[71,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[71,42]}},{"comments":null,"title":"equalsGTLT","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Equals"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"GT"]}]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"LT"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[72,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[72,42]}},{"comments":null,"title":"equalsGTEQ","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"Equals"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"GT"]}]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"EQ"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[73,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[73,42]}}],"comments":null,"title":"Equals","info":{"fundeps":[[["lhs","rhs"],["out"]]],"arguments":[["lhs",{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]}],["rhs",{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]}],["out",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[60,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[63,28]}},{"children":[],"comments":null,"title":"equals","info":{"declType":"value","type":{"tag":"ForAll","contents":["o",{"tag":"ForAll","contents":["r",{"tag":"ForAll","contents":["l",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Type","Data","Ordering"],"Equals"],"constraintArgs":[{"tag":"TypeVar","contents":"l"},{"tag":"TypeVar","contents":"r"},{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"OProxy"]},{"tag":"TypeVar","contents":"l"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"OProxy"]},{"tag":"TypeVar","contents":"r"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"o"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[75,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[75,73]}}]},{"reExports":[{"moduleName":{"package":"purescript-prelude","item":["Data","Symbol"]},"declarations":[{"children":[{"comments":null,"title":"SProxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":"A value-level proxy for a type-level symbol.\n","title":"SProxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["sym",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}]]},"sourceSpan":{"start":[9,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-prelude/src/Data/Symbol.purs","end":[9,37]}},{"children":[{"comments":null,"title":"reflectSymbol","info":{"declType":"typeClassMember","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"sym"}]}]},{"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[13,3],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-prelude/src/Data/Symbol.purs","end":[13,40]}}],"comments":"A class for known symbols\n","title":"IsSymbol","info":{"fundeps":[],"arguments":[["sym",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[12,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-prelude/src/Data/Symbol.purs","end":[13,40]}},{"children":[],"comments":null,"title":"reifySymbol","info":{"declType":"value","type":{"tag":"ForAll","contents":["r",{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Prim"],"String"]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"ParensInType","contents":{"tag":"ForAll","contents":["sym",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"tag":"TypeVar","contents":"sym"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"sym"}]}]},{"tag":"TypeVar","contents":"r"}]}]},null]}}]},{"tag":"TypeVar","contents":"r"}]}]},null]}},"sourceSpan":{"start":[18,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-prelude/src/Data/Symbol.purs","end":[18,86]}}]},{"moduleName":{"package":null,"item":["Prim","Symbol"]},"declarations":[{"children":[],"comments":"Compiler solved type class for appending `Symbol`s together.\n","title":"Append","info":{"fundeps":[[["left","right"],["appended"]],[["right","appended"],["left"]],[["appended","left"],["right"]]],"arguments":[["left",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["right",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["appended",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":null},{"children":[],"comments":"Compiler solved type class for comparing two `Symbol`s.\nProduces an `Ordering`.\n","title":"Compare","info":{"fundeps":[[["left","right"],["ordering"]]],"arguments":[["left",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["right",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["ordering",{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":null},{"children":[],"comments":"Compiler solved type class for either splitting up a symbol into its\nhead and tail or for combining a head and tail into a new symbol.\nRequires the head to be a single character and the combined string\ncannot be empty.\n","title":"Cons","info":{"fundeps":[[["head","tail"],["symbol"]],[["symbol"],["head","tail"]]],"arguments":[["head",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["tail",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["symbol",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":null}]}],"name":"Type.Data.Symbol","comments":null,"declarations":[{"children":[],"comments":null,"title":"append","info":{"declType":"value","type":{"tag":"ForAll","contents":["o",{"tag":"ForAll","contents":["r",{"tag":"ForAll","contents":["l",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Prim","Symbol"],"Append"],"constraintArgs":[{"tag":"TypeVar","contents":"l"},{"tag":"TypeVar","contents":"r"},{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"l"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"r"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"o"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[20,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Symbol.purs","end":[20,73]}},{"children":[],"comments":null,"title":"compare","info":{"declType":"value","type":{"tag":"ForAll","contents":["o",{"tag":"ForAll","contents":["r",{"tag":"ForAll","contents":["l",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Prim","Symbol"],"Compare"],"constraintArgs":[{"tag":"TypeVar","contents":"l"},{"tag":"TypeVar","contents":"r"},{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"l"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"r"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"OProxy"]},{"tag":"TypeVar","contents":"o"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[17,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Symbol.purs","end":[17,75]}},{"children":[],"comments":null,"title":"uncons","info":{"declType":"value","type":{"tag":"ForAll","contents":["s",{"tag":"ForAll","contents":["t",{"tag":"ForAll","contents":["h",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Prim","Symbol"],"Cons"],"constraintArgs":[{"tag":"TypeVar","contents":"h"},{"tag":"TypeVar","contents":"t"},{"tag":"TypeVar","contents":"s"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"s"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"tag":"RCons","contents":["head",{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"h"}]},{"tag":"RCons","contents":["tail",{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"t"}]},{"tag":"REmpty"}]}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[23,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Symbol.purs","end":[23,87]}},{"children":[{"comments":null,"title":"equalsSymbol","info":{"declType":"instance","dependencies":[{"constraintClass":[["Prim","Symbol"],"Compare"],"constraintArgs":[{"tag":"TypeVar","contents":"lhs"},{"tag":"TypeVar","contents":"rhs"},{"tag":"TypeVar","contents":"ord"}],"constraintData":null},{"constraintClass":[["Type","Data","Ordering"],"Equals"],"constraintArgs":[{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"EQ"]},{"tag":"TypeVar","contents":"ord"},{"tag":"TypeVar","contents":"out"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Symbol"],"Equals"]},{"tag":"TypeVar","contents":"lhs"}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeVar","contents":"out"}]}},"sourceSpan":{"start":[31,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Symbol.purs","end":[34,24]}}],"comments":null,"title":"Equals","info":{"fundeps":[[["lhs","rhs"],["out"]]],"arguments":[["lhs",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["rhs",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["out",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[26,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Symbol.purs","end":[29,28]}},{"children":[],"comments":null,"title":"equals","info":{"declType":"value","type":{"tag":"ForAll","contents":["o",{"tag":"ForAll","contents":["r",{"tag":"ForAll","contents":["l",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Type","Data","Symbol"],"Equals"],"constraintArgs":[{"tag":"TypeVar","contents":"l"},{"tag":"TypeVar","contents":"r"},{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"l"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"r"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"o"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[36,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Symbol.purs","end":[36,73]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Type","Data","Boolean"]},"declarations":[{"children":[{"comments":null,"title":"isBooleanTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"IsBoolean"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[32,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[32,41]}},{"comments":null,"title":"andTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"And"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeVar","contents":"rhs"}]}},"sourceSpan":{"start":[45,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[45,37]}},{"comments":null,"title":"orTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Or"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[56,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[56,36]}},{"comments":null,"title":"notTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Not"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[66,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[66,35]}},{"comments":null,"title":"notFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Not"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[67,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[67,36]}},{"comments":null,"title":"ifTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"If"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]},{"tag":"TypeVar","contents":"onTrue"}]},{"tag":"TypeVar","contents":"onFalse"}]},{"tag":"TypeVar","contents":"onTrue"}]}},"sourceSpan":{"start":[78,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[78,49]}}],"comments":null,"title":"True","info":{"kind":{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]},"declType":"externData"},"sourceSpan":{"start":[22,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[22,36]}},{"children":[{"comments":null,"title":"isBooleanFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"IsBoolean"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[33,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[33,43]}},{"comments":null,"title":"andFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"And"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[46,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[46,41]}},{"comments":null,"title":"orFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Or"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeVar","contents":"rhs"}]}},"sourceSpan":{"start":[57,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[57,37]}},{"comments":null,"title":"notTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Not"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[66,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[66,35]}},{"comments":null,"title":"notFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"Not"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[67,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[67,36]}},{"comments":null,"title":"ifFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"If"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]},{"tag":"TypeVar","contents":"onTrue"}]},{"tag":"TypeVar","contents":"onFalse"}]},{"tag":"TypeVar","contents":"onFalse"}]}},"sourceSpan":{"start":[79,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[79,52]}}],"comments":null,"title":"False","info":{"kind":{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]},"declType":"externData"},"sourceSpan":{"start":[23,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[23,37]}},{"children":[{"comments":null,"title":"BProxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":"Value proxy for `Boolean` types\n","title":"BProxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["bool",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}]]},"sourceSpan":{"start":[26,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[26,39]}},{"children":[{"comments":null,"title":"reflectBoolean","info":{"declType":"typeClassMember","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"bool"}]}]},{"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[30,3],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[30,43]}},{"comments":null,"title":"isBooleanTrue","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"IsBoolean"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"True"]}]}},"sourceSpan":{"start":[32,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[32,41]}},{"comments":null,"title":"isBooleanFalse","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"IsBoolean"]},{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"False"]}]}},"sourceSpan":{"start":[33,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[33,43]}}],"comments":"Class for reflecting a type level `Boolean` at the value level\n","title":"IsBoolean","info":{"fundeps":[],"arguments":[["bool",{"tag":"NamedKind","contents":[["Type","Data","Boolean"],"Boolean"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[29,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[30,43]}},{"children":[],"comments":"Use a value level `Boolean` as a type-level `Boolean`\n","title":"reifyBoolean","info":{"declType":"value","type":{"tag":"ForAll","contents":["r",{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"ParensInType","contents":{"tag":"ForAll","contents":["o",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Type","Data","Boolean"],"IsBoolean"],"constraintArgs":[{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Boolean"],"BProxy"]},{"tag":"TypeVar","contents":"o"}]}]},{"tag":"TypeVar","contents":"r"}]}]},null]}}]},{"tag":"TypeVar","contents":"r"}]}]},null]}},"sourceSpan":{"start":[36,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[36,83]}},{"children":[],"comments":null,"title":"Boolean","info":{"declType":"kind"},"sourceSpan":{"start":[21,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Boolean.purs","end":[21,28]}}]},{"moduleName":{"package":null,"item":["Type","Data","Ordering"]},"declarations":[{"children":[{"comments":null,"title":"OProxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":"Value proxy for `Ordering` types\n","title":"OProxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["ordering",{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]}]]},"sourceSpan":{"start":[20,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[20,44]}},{"children":[],"comments":"The 'less than' ordering type.\n","title":"LT","info":{"kind":{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]},"declType":"externData"},"sourceSpan":null},{"children":[],"comments":"The 'greater than' ordering type.\n","title":"GT","info":{"kind":{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]},"declType":"externData"},"sourceSpan":null},{"children":[],"comments":"The 'equal to' ordering type.\n","title":"EQ","info":{"kind":{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]},"declType":"externData"},"sourceSpan":null},{"children":[{"comments":null,"title":"reflectOrdering","info":{"declType":"typeClassMember","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"OProxy"]},{"tag":"TypeVar","contents":"ordering"}]}]},{"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[24,3],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[24,49]}},{"comments":null,"title":"isOrderingLT","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"IsOrdering"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"LT"]}]}},"sourceSpan":{"start":[26,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[26,39]}},{"comments":null,"title":"isOrderingEQ","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"IsOrdering"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"EQ"]}]}},"sourceSpan":{"start":[27,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[27,39]}},{"comments":null,"title":"isOrderingGT","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"IsOrdering"]},{"tag":"TypeConstructor","contents":[["Prim","Ordering"],"GT"]}]}},"sourceSpan":{"start":[28,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[28,39]}}],"comments":"Class for reflecting a type level `Ordering` at the value level\n","title":"IsOrdering","info":{"fundeps":[],"arguments":[["ordering",{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[23,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[24,49]}},{"children":[],"comments":"Use a value level `Ordering` as a type-level `Ordering`\n","title":"reifyOrdering","info":{"declType":"value","type":{"tag":"ForAll","contents":["r",{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"ParensInType","contents":{"tag":"ForAll","contents":["o",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Type","Data","Ordering"],"IsOrdering"],"constraintArgs":[{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"OProxy"]},{"tag":"TypeVar","contents":"o"}]}]},{"tag":"TypeVar","contents":"r"}]}]},null]}}]},{"tag":"TypeVar","contents":"r"}]}]},null]}},"sourceSpan":{"start":[31,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Ordering.purs","end":[31,86]}},{"children":[],"comments":"The `Ordering` kind represents the three possibilites of comparing two\ntypes of the same kind: `LT` (less than), `EQ` (equal to), and\n`GT` (greater than).\n","title":"Ordering","info":{"declType":"kind"},"sourceSpan":null}]},{"moduleName":{"package":null,"item":["Type","Data","Symbol"]},"declarations":[{"children":[{"comments":null,"title":"SProxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":"A value-level proxy for a type-level symbol.\n","title":"SProxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["sym",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}]]},"sourceSpan":{"start":[9,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-prelude/src/Data/Symbol.purs","end":[9,37]}},{"children":[],"comments":"Compiler solved type class for appending `Symbol`s together.\n","title":"Append","info":{"fundeps":[[["left","right"],["appended"]],[["right","appended"],["left"]],[["appended","left"],["right"]]],"arguments":[["left",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["right",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["appended",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":null},{"children":[],"comments":"Compiler solved type class for comparing two `Symbol`s.\nProduces an `Ordering`.\n","title":"Compare","info":{"fundeps":[[["left","right"],["ordering"]]],"arguments":[["left",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["right",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["ordering",{"tag":"NamedKind","contents":[["Prim","Ordering"],"Ordering"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":null},{"children":[{"comments":null,"title":"reflectSymbol","info":{"declType":"typeClassMember","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"sym"}]}]},{"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[13,3],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-prelude/src/Data/Symbol.purs","end":[13,40]}}],"comments":"A class for known symbols\n","title":"IsSymbol","info":{"fundeps":[],"arguments":[["sym",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[12,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-prelude/src/Data/Symbol.purs","end":[13,40]}},{"children":[],"comments":null,"title":"reifySymbol","info":{"declType":"value","type":{"tag":"ForAll","contents":["r",{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeConstructor","contents":[["Prim"],"String"]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"ParensInType","contents":{"tag":"ForAll","contents":["sym",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"tag":"TypeVar","contents":"sym"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"sym"}]}]},{"tag":"TypeVar","contents":"r"}]}]},null]}}]},{"tag":"TypeVar","contents":"r"}]}]},null]}},"sourceSpan":{"start":[18,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-prelude/src/Data/Symbol.purs","end":[18,86]}},{"children":[],"comments":null,"title":"compare","info":{"declType":"value","type":{"tag":"ForAll","contents":["o",{"tag":"ForAll","contents":["r",{"tag":"ForAll","contents":["l",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Prim","Symbol"],"Compare"],"constraintArgs":[{"tag":"TypeVar","contents":"l"},{"tag":"TypeVar","contents":"r"},{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"l"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"r"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Data","Ordering"],"OProxy"]},{"tag":"TypeVar","contents":"o"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[17,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Symbol.purs","end":[17,75]}},{"children":[],"comments":null,"title":"append","info":{"declType":"value","type":{"tag":"ForAll","contents":["o",{"tag":"ForAll","contents":["r",{"tag":"ForAll","contents":["l",{"tag":"ConstrainedType","contents":[{"constraintClass":[["Prim","Symbol"],"Append"],"constraintArgs":[{"tag":"TypeVar","contents":"l"},{"tag":"TypeVar","contents":"r"},{"tag":"TypeVar","contents":"o"}],"constraintData":null},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"l"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"r"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"o"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[20,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Data/Symbol.purs","end":[20,73]}}]},{"moduleName":{"package":"purescript-type-equality","item":["Type","Equality"]},"declarations":[{"children":[{"comments":null,"title":"to","info":{"declType":"typeClassMember","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeVar","contents":"a"}]},{"tag":"TypeVar","contents":"b"}]}},"sourceSpan":{"start":[18,3],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-type-equality/src/Type/Equality.purs","end":[18,15]}},{"comments":null,"title":"from","info":{"declType":"typeClassMember","type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"tag":"TypeVar","contents":"b"}]},{"tag":"TypeVar","contents":"a"}]}},"sourceSpan":{"start":[19,3],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-type-equality/src/Type/Equality.purs","end":[19,17]}},{"comments":null,"title":"refl","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Equality"],"TypeEquals"]},{"tag":"TypeVar","contents":"a"}]},{"tag":"TypeVar","contents":"a"}]}},"sourceSpan":{"start":[21,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-type-equality/src/Type/Equality.purs","end":[21,32]}}],"comments":"This type class asserts that types `a` and `b`\nare equal.\n\nThe functional dependencies and the single\ninstance below will force the two type arguments\nto unify when either one is known.\n\nNote: any instance will necessarily overlap with\n`refl` below, so instances of this class should\nnot be defined in libraries.\n","title":"TypeEquals","info":{"fundeps":[[["a"],["b"]],[["b"],["a"]]],"arguments":[["a",null],["b",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[17,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-type-equality/src/Type/Equality.purs","end":[19,17]}}]},{"moduleName":{"package":"purescript-proxy","item":["Type","Proxy"]},"declarations":[{"children":[{"comments":null,"title":"Proxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"eqProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[56,8],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[56,40]}},{"comments":null,"title":"functorProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[58,8],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[58,46]}},{"comments":null,"title":"ordProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[60,8],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[60,42]}},{"comments":null,"title":"applicativeProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[62,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[62,47]}},{"comments":null,"title":"applyProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[65,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[65,35]}},{"comments":null,"title":"bindProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[68,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[68,33]}},{"comments":null,"title":"booleanAlgebraProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[71,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[71,57]}},{"comments":null,"title":"boundedProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[73,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[73,43]}},{"comments":null,"title":"commutativeRingProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[77,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[77,59]}},{"comments":null,"title":"discardProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Control","Bind"],"Discard"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[79,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[79,43]}},{"comments":null,"title":"heytingAlgebraProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[82,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[82,57]}},{"comments":null,"title":"monadProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Control","Monad"],"Monad"]},{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[90,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[90,35]}},{"comments":null,"title":"ringProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[92,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[92,37]}},{"comments":null,"title":"semigroupProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[95,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[95,47]}},{"comments":null,"title":"semiringProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[98,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[98,45]}},{"comments":null,"title":"showProxy","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[104,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[104,37]}}],"comments":"Value proxy for kind `Type` types.\n","title":"Proxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["a",null]]},"sourceSpan":{"start":[54,1],"name":"/home/harry/code/purescript-typelevel-prelude/bower_components/purescript-proxy/src/Type/Proxy.purs","end":[54,21]}}]},{"moduleName":{"package":null,"item":["Type","Row"]},"declarations":[{"children":[{"comments":null,"title":"RProxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":null,"title":"RProxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["row",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}]]},"sourceSpan":{"start":[21,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[21,37]}},{"children":[{"comments":null,"title":"RLProxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":null,"title":"RLProxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["rowList",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}]]},"sourceSpan":{"start":[23,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[23,44]}},{"children":[],"comments":"The Lacks type class asserts that a label does not occur in a given row.\n","title":"Lacks","info":{"fundeps":[],"arguments":[["label",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["row",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}]],"declType":"typeClass","superclasses":[]},"sourceSpan":null},{"children":[{"comments":null,"title":"listToRowNil","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"ListToRow"]},{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"tag":"REmpty"}]}},"sourceSpan":{"start":[31,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[32,22]}},{"comments":null,"title":"listToCons","info":{"declType":"instance","dependencies":[{"constraintClass":[["Type","Row"],"ListToRow"],"constraintArgs":[{"tag":"TypeVar","contents":"tail"},{"tag":"TypeVar","contents":"tailRow"}],"constraintData":null},{"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"tag":"TypeVar","contents":"label"},{"tag":"TypeVar","contents":"ty"},{"tag":"TypeVar","contents":"tailRow"},{"tag":"TypeVar","contents":"row"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"ListToRow"]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"tag":"TypeVar","contents":"label"}]},{"tag":"TypeVar","contents":"ty"}]},{"tag":"TypeVar","contents":"tail"}]}]},{"tag":"TypeVar","contents":"row"}]}},"sourceSpan":{"start":[34,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[37,40]}}],"comments":"Convert a RowList to a row of types.\nThe inverse of this operation is `RowToList`.\n","title":"ListToRow","info":{"fundeps":[[["list"],["row"]]],"arguments":[["list",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}],["row",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[27,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[29,28]}},{"children":[],"comments":"Compiler solved type class for generating a `RowList` from a closed row\nof types. Entries are sorted by label and duplicates are preserved in\nthe order they appeared in the row.\n","title":"RowToList","info":{"fundeps":[[["row"],["list"]]],"arguments":[["row",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}],["list",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":null},{"children":[],"comments":"The Union type class is used to compute the union of two rows of types\n(left-biased, including duplicates).\n\nThe third type argument represents the union of the first two.\n","title":"Union","info":{"fundeps":[[["left","right"],["union"]],[["right","union"],["left"]],[["union","left"],["right"]]],"arguments":[["left",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}],["right",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}],["union",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}]],"declType":"typeClass","superclasses":[]},"sourceSpan":null}]}],"name":"Type.Prelude","comments":null,"declarations":[]},{"reExports":[{"moduleName":{"package":null,"item":["Prim","Row"]},"declarations":[{"children":[],"comments":"The Cons type class is a 4-way relation which asserts that one row of\ntypes can be obtained from another by inserting a new label/type pair on\nthe left.\n","title":"Cons","info":{"fundeps":[[["label","a","tail"],["row"]],[["label","row"],["a","tail"]]],"arguments":[["label",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["a",{"tag":"NamedKind","contents":[["Prim"],"Type"]}],["tail",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}],["row",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}]],"declType":"typeClass","superclasses":[]},"sourceSpan":null},{"children":[],"comments":"The Lacks type class asserts that a label does not occur in a given row.\n","title":"Lacks","info":{"fundeps":[],"arguments":[["label",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["row",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}]],"declType":"typeClass","superclasses":[]},"sourceSpan":null},{"children":[],"comments":"The Nub type class is used to remove duplicate labels from rows.\n","title":"Nub","info":{"fundeps":[[["original"],["nubbed"]]],"arguments":[["original",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}],["nubbed",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}]],"declType":"typeClass","superclasses":[]},"sourceSpan":null},{"children":[],"comments":"The Union type class is used to compute the union of two rows of types\n(left-biased, including duplicates).\n\nThe third type argument represents the union of the first two.\n","title":"Union","info":{"fundeps":[[["left","right"],["union"]],[["right","union"],["left"]],[["union","left"],["right"]]],"arguments":[["left",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}],["right",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}],["union",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}]],"declType":"typeClass","superclasses":[]},"sourceSpan":null}]},{"moduleName":{"package":null,"item":["Prim","RowList"]},"declarations":[{"children":[],"comments":"The empty `RowList`.\n","title":"Nil","info":{"kind":{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]},"declType":"externData"},"sourceSpan":null},{"children":[],"comments":"Constructs a new `RowList` from a label, a type, and an existing tail\n`RowList`. E.g: `Cons \"x\" Int (Cons \"y\" Int Nil)`.\n","title":"Cons","info":{"kind":{"tag":"FunKind","contents":[{"tag":"NamedKind","contents":[["Prim"],"Symbol"]},{"tag":"FunKind","contents":[{"tag":"NamedKind","contents":[["Prim"],"Type"]},{"tag":"FunKind","contents":[{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]},{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}]}]}]},"declType":"externData"},"sourceSpan":null},{"children":[],"comments":"Compiler solved type class for generating a `RowList` from a closed row\nof types. Entries are sorted by label and duplicates are preserved in\nthe order they appeared in the row.\n","title":"RowToList","info":{"fundeps":[[["row"],["list"]]],"arguments":[["row",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}],["list",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":null},{"children":[],"comments":"A type level list representation of a row of types.\n","title":"RowList","info":{"declType":"kind"},"sourceSpan":null}]}],"name":"Type.Row","comments":null,"declarations":[{"children":[{"comments":null,"title":"RProxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":null,"title":"RProxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["row",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}]]},"sourceSpan":{"start":[21,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[21,37]}},{"children":[{"comments":null,"title":"RLProxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":null,"title":"RLProxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["rowList",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}]]},"sourceSpan":{"start":[23,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[23,44]}},{"children":[{"comments":null,"title":"listToRowNil","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"ListToRow"]},{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"tag":"REmpty"}]}},"sourceSpan":{"start":[31,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[32,22]}},{"comments":null,"title":"listToCons","info":{"declType":"instance","dependencies":[{"constraintClass":[["Type","Row"],"ListToRow"],"constraintArgs":[{"tag":"TypeVar","contents":"tail"},{"tag":"TypeVar","contents":"tailRow"}],"constraintData":null},{"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"tag":"TypeVar","contents":"label"},{"tag":"TypeVar","contents":"ty"},{"tag":"TypeVar","contents":"tailRow"},{"tag":"TypeVar","contents":"row"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"ListToRow"]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"tag":"TypeVar","contents":"label"}]},{"tag":"TypeVar","contents":"ty"}]},{"tag":"TypeVar","contents":"tail"}]}]},{"tag":"TypeVar","contents":"row"}]}},"sourceSpan":{"start":[34,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[37,40]}}],"comments":"Convert a RowList to a row of types.\nThe inverse of this operation is `RowToList`.\n","title":"ListToRow","info":{"fundeps":[[["list"],["row"]]],"arguments":[["list",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}],["row",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[27,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[29,28]}},{"children":[{"comments":null,"title":"rowListRemoveNil","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RowListRemove"]},{"tag":"TypeVar","contents":"label"}]},{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]}},"sourceSpan":{"start":[45,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[46,33]}},{"comments":null,"title":"rowListRemoveCons","info":{"declType":"instance","dependencies":[{"constraintClass":[["Type","Row"],"RowListRemove"],"constraintArgs":[{"tag":"TypeVar","contents":"label"},{"tag":"TypeVar","contents":"tail"},{"tag":"TypeVar","contents":"tailOutput"}],"constraintData":null},{"constraintClass":[["Type","Data","Symbol"],"Equals"],"constraintArgs":[{"tag":"TypeVar","contents":"label"},{"tag":"TypeVar","contents":"key"},{"tag":"TypeVar","contents":"eq"}],"constraintData":null},{"constraintClass":[["Type","Data","Boolean"],"If"],"constraintArgs":[{"tag":"TypeVar","contents":"eq"},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RLProxy"]},{"tag":"TypeVar","contents":"tailOutput"}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RLProxy"]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"tag":"TypeVar","contents":"key"}]},{"tag":"TypeVar","contents":"head"}]},{"tag":"TypeVar","contents":"tailOutput"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RLProxy"]},{"tag":"TypeVar","contents":"output"}]}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RowListRemove"]},{"tag":"TypeVar","contents":"label"}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"tag":"TypeVar","contents":"key"}]},{"tag":"TypeVar","contents":"head"}]},{"tag":"TypeVar","contents":"tail"}]}]},{"tag":"TypeVar","contents":"output"}]}},"sourceSpan":{"start":[48,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[56,53]}}],"comments":"Remove all occurences of a given label from a RowList\n","title":"RowListRemove","info":{"fundeps":[[["label","input"],["output"]]],"arguments":[["label",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["input",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}],["output",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[40,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[43,44]}},{"children":[{"comments":null,"title":"rowListSetImpl","info":{"declType":"instance","dependencies":[{"constraintClass":[["Type","Equality"],"TypeEquals"],"constraintArgs":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"label"}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"label'"}]}],"constraintData":null},{"constraintClass":[["Type","Equality"],"TypeEquals"],"constraintArgs":[{"tag":"TypeVar","contents":"typ"},{"tag":"TypeVar","contents":"typ'"}],"constraintData":null},{"constraintClass":[["Type","Row"],"RowListRemove"],"constraintArgs":[{"tag":"TypeVar","contents":"label"},{"tag":"TypeVar","contents":"input"},{"tag":"TypeVar","contents":"lacking"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RowListSet"]},{"tag":"TypeVar","contents":"label"}]},{"tag":"TypeVar","contents":"typ"}]},{"tag":"TypeVar","contents":"input"}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"tag":"TypeVar","contents":"label'"}]},{"tag":"TypeVar","contents":"typ'"}]},{"tag":"TypeVar","contents":"lacking"}]}]}},"sourceSpan":{"start":[65,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[69,59]}}],"comments":"Add a label to a RowList after removing other occurences.\n","title":"RowListSet","info":{"fundeps":[[["label","typ","input"],["output"]]],"arguments":[["label",{"tag":"NamedKind","contents":[["Prim"],"Symbol"]}],["typ",{"tag":"NamedKind","contents":[["Prim"],"Type"]}],["input",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}],["output",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[59,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[63,45]}},{"children":[{"comments":null,"title":"rowListNubNil","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RowListNub"]},{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]}},"sourceSpan":{"start":[76,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[77,24]}},{"comments":null,"title":"rowListNubCons","info":{"declType":"instance","dependencies":[{"constraintClass":[["Type","Equality"],"TypeEquals"],"constraintArgs":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"label"}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Data","Symbol"],"SProxy"]},{"tag":"TypeVar","contents":"label'"}]}],"constraintData":null},{"constraintClass":[["Type","Equality"],"TypeEquals"],"constraintArgs":[{"tag":"TypeVar","contents":"head"},{"tag":"TypeVar","contents":"head'"}],"constraintData":null},{"constraintClass":[["Type","Equality"],"TypeEquals"],"constraintArgs":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RLProxy"]},{"tag":"TypeVar","contents":"nubbed"}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RLProxy"]},{"tag":"TypeVar","contents":"nubbed'"}]}],"constraintData":null},{"constraintClass":[["Type","Row"],"RowListRemove"],"constraintArgs":[{"tag":"TypeVar","contents":"label"},{"tag":"TypeVar","contents":"tail"},{"tag":"TypeVar","contents":"removed"}],"constraintData":null},{"constraintClass":[["Type","Row"],"RowListNub"],"constraintArgs":[{"tag":"TypeVar","contents":"removed"},{"tag":"TypeVar","contents":"nubbed"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RowListNub"]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"tag":"TypeVar","contents":"label"}]},{"tag":"TypeVar","contents":"head"}]},{"tag":"TypeVar","contents":"tail"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"tag":"TypeVar","contents":"label'"}]},{"tag":"TypeVar","contents":"head'"}]},{"tag":"TypeVar","contents":"nubbed'"}]}]}},"sourceSpan":{"start":[79,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[85,67]}}],"comments":"Remove label duplicates, keeps earlier occurrences.\n","title":"RowListNub","info":{"fundeps":[[["input"],["output"]]],"arguments":[["input",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}],["output",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[72,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[74,35]}},{"children":[{"comments":null,"title":"rowListAppendNil","info":{"declType":"instance","dependencies":[{"constraintClass":[["Type","Equality"],"TypeEquals"],"constraintArgs":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RLProxy"]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RLProxy"]},{"tag":"TypeVar","contents":"out"}]}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RowListAppend"]},{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeVar","contents":"out"}]}},"sourceSpan":{"start":[93,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[95,31]}},{"comments":null,"title":"rowListAppendCons","info":{"declType":"instance","dependencies":[{"constraintClass":[["Type","Row"],"RowListAppend"],"constraintArgs":[{"tag":"TypeVar","contents":"tail"},{"tag":"TypeVar","contents":"rhs"},{"tag":"TypeVar","contents":"out'"}],"constraintData":null},{"constraintClass":[["Type","Equality"],"TypeEquals"],"constraintArgs":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RLProxy"]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"tag":"TypeVar","contents":"label"}]},{"tag":"TypeVar","contents":"head"}]},{"tag":"TypeVar","contents":"out'"}]}]},{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RLProxy"]},{"tag":"TypeVar","contents":"out"}]}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row"],"RowListAppend"]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"tag":"TypeVar","contents":"label"}]},{"tag":"TypeVar","contents":"head"}]},{"tag":"TypeVar","contents":"tail"}]}]},{"tag":"TypeVar","contents":"rhs"}]},{"tag":"TypeVar","contents":"out"}]}},"sourceSpan":{"start":[97,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[100,50]}}],"comments":null,"title":"RowListAppend","info":{"fundeps":[[["lhs","rhs"],["out"]]],"arguments":[["lhs",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}],["rhs",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}],["out",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[88,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[91,37]}},{"children":[],"comments":"Type application for rows.\n","title":"RowApply","info":{"arguments":[["f",{"tag":"FunKind","contents":[{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}},{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}]}],["a",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}]],"declType":"typeSynonym","type":{"tag":"TypeApp","contents":[{"tag":"TypeVar","contents":"f"},{"tag":"TypeVar","contents":"a"}]}},"sourceSpan":{"start":[103,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[103,58]}},{"children":[],"comments":"Applies a type alias of open rows to a set of rows. The primary use case\nthis operator is as convenient sugar for combining open rows without\nparentheses.\n```purescript\ntype Rows1 r = (a :: Int, b :: String | r)\ntype Rows2 r = (c :: Boolean | r)\ntype Rows3 r = (Rows1 + Rows2 + r)\ntype Rows4 r = (d :: String | Rows1 + Rows2 + r)\n```\n","title":"type (+)","info":{"declType":"alias","alias":[["Type","Row"],{"Left":"RowApply"}],"fixity":{"associativity":"infixr","precedence":0}},"sourceSpan":{"start":[114,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row.purs","end":[114,27]}}]},{"reExports":[],"name":"Type.Row.Homogeneous","comments":null,"declarations":[{"children":[{"comments":null,"title":"homogeneous","info":{"declType":"instance","dependencies":[{"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"tag":"TypeVar","contents":"row"},{"tag":"TypeVar","contents":"fields"}],"constraintData":null},{"constraintClass":[["Type","Row","Homogeneous"],"HomogeneousRowList"],"constraintArgs":[{"tag":"TypeVar","contents":"fields"},{"tag":"TypeVar","contents":"fieldType"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row","Homogeneous"],"Homogeneous"]},{"tag":"TypeVar","contents":"row"}]},{"tag":"TypeVar","contents":"fieldType"}]}},"sourceSpan":{"start":[11,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row/Homogeneous.purs","end":[14,31]}}],"comments":"Ensure that every field in a row has the same type.\n","title":"Homogeneous","info":{"fundeps":[[["row"],["fieldType"]]],"arguments":[["row",{"tag":"Row","contents":{"tag":"NamedKind","contents":[["Prim"],"Type"]}}],["fieldType",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[10,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row/Homogeneous.purs","end":[10,63]}},{"children":[{"comments":null,"title":"homogeneousRowListCons","info":{"declType":"instance","dependencies":[{"constraintClass":[["Type","Row","Homogeneous"],"HomogeneousRowList"],"constraintArgs":[{"tag":"TypeVar","contents":"tail"},{"tag":"TypeVar","contents":"fieldType"}],"constraintData":null},{"constraintClass":[["Type","Equality"],"TypeEquals"],"constraintArgs":[{"tag":"TypeVar","contents":"fieldType"},{"tag":"TypeVar","contents":"fieldType2"}],"constraintData":null}],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row","Homogeneous"],"HomogeneousRowList"]},{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"tag":"TypeVar","contents":"symbol"}]},{"tag":"TypeVar","contents":"fieldType"}]},{"tag":"TypeVar","contents":"tail"}]}]},{"tag":"TypeVar","contents":"fieldType2"}]}},"sourceSpan":{"start":[17,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row/Homogeneous.purs","end":[20,64]}},{"comments":null,"title":"homogeneousRowListNil","info":{"declType":"instance","dependencies":[],"type":{"tag":"TypeApp","contents":[{"tag":"TypeApp","contents":[{"tag":"TypeConstructor","contents":[["Type","Row","Homogeneous"],"HomogeneousRowList"]},{"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"tag":"TypeVar","contents":"fieldType"}]}},"sourceSpan":{"start":[21,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row/Homogeneous.purs","end":[21,58]}}],"comments":null,"title":"HomogeneousRowList","info":{"fundeps":[[["rowList"],["fieldType"]]],"arguments":[["rowList",{"tag":"NamedKind","contents":[["Prim","RowList"],"RowList"]}],["fieldType",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[16,1],"name":"/home/harry/code/purescript-typelevel-prelude/src/Type/Row/Homogeneous.purs","end":[16,79]}}]}],"resolvedDependencies":{"purescript-proxy":"3.0.0","purescript-type-equality":"3.0.0","purescript-prelude":"4.1.0"},"version":"3.0.0","github":["purescript","purescript-typelevel-prelude"],"versionTag":"v3.0.0","moduleMap":{"Data.BooleanAlgebra":"purescript-prelude","Data.Ring":"purescript-prelude","Data.Ord":"purescript-prelude","Type.Data.Row":"purescript-prelude","Data.Monoid.Dual":"purescript-prelude","Data.Boolean":"purescript-prelude","Type.Proxy":"purescript-proxy","Data.Bounded":"purescript-prelude","Data.Show":"purescript-prelude","Control.Apply":"purescript-prelude","Control.Monad":"purescript-prelude","Data.Monoid":"purescript-prelude","Control.Bind":"purescript-prelude","Data.Monoid.Additive":"purescript-prelude","Data.Symbol":"purescript-prelude","Data.HeytingAlgebra":"purescript-prelude","Type.Data.RowList":"purescript-prelude","Data.Ord.Unsafe":"purescript-prelude","Data.Semigroup":"purescript-prelude","Type.Equality":"purescript-type-equality","Data.Semiring":"purescript-prelude","Data.CommutativeRing":"purescript-prelude","Data.NaturalTransformation":"purescript-prelude","Data.Monoid.Conj":"purescript-prelude","Data.Functor":"purescript-prelude","Control.Category":"purescript-prelude","Data.Function":"purescript-prelude","Data.Field":"purescript-prelude","Data.EuclideanRing":"purescript-prelude","Data.Semigroup.Last":"purescript-prelude","Data.Semigroup.First":"purescript-prelude","Prelude":"purescript-prelude","Data.Eq":"purescript-prelude","Data.Monoid.Disj":"purescript-prelude","Data.Void":"purescript-prelude","Data.DivisionRing":"purescript-prelude","Data.Unit":"purescript-prelude","Data.Ordering":"purescript-prelude","Data.Monoid.Multiplicative":"purescript-prelude","Control.Semigroupoid":"purescript-prelude","Data.Monoid.Endo":"purescript-prelude","Control.Applicative":"purescript-prelude","Record.Unsafe":"purescript-prelude"},"compilerVersion":"0.12.1"} From f729a1412369290c78ccfccdc66c5760881de4f1 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 30 Dec 2018 10:22:57 +0000 Subject: [PATCH 1039/1580] Add :print directive for customizable repl printing (#3478) Refs #3177. The command > :print MyModule.print will replace the repl's printing function (by default: PSCI.Support.eval) with MyModule.print, if the latter exists and appears to work. The referenced function should have a type of the form forall a. C a => a -> Effect _ i.e., it should accept a wide variety of input types, and return an `Effect T` for some type `T`, whose effects involve printing the argument to the console. The `T` value is discarded. It is not yet possible to configure the repl's printing function from the .purs-repl file. Entering either `:print` (without arguments) or `:show print` at the repl will display information about the repl's currently configured printing function. I've also removed the (unused) `hasArgument` function. --- src/Language/PureScript/Interactive.hs | 43 ++++++++++++++ .../PureScript/Interactive/Directive.hs | 13 +---- src/Language/PureScript/Interactive/Module.hs | 6 +- src/Language/PureScript/Interactive/Parser.hs | 13 +++++ src/Language/PureScript/Interactive/Types.hs | 57 +++++++++++++------ tests/TestPsci/CommandTest.hs | 15 +++++ tests/TestPsci/CompletionTest.hs | 4 +- tests/support/psci/InteractivePrint.purs | 11 ++++ 8 files changed, 131 insertions(+), 31 deletions(-) create mode 100644 tests/support/psci/InteractivePrint.purs diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index bca6bf278d..856f02803d 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -111,7 +111,9 @@ handleCommand _ _ p (KindOf typ) = handleKindOf p typ handleCommand _ _ p (BrowseModule moduleName) = handleBrowse p moduleName handleCommand _ _ p (ShowInfo QueryLoaded) = handleShowLoadedModules p handleCommand _ _ p (ShowInfo QueryImport) = handleShowImportedModules p +handleCommand _ _ p (ShowInfo QueryPrint) = handleShowPrint p handleCommand _ _ p (CompleteStr prefix) = handleComplete p prefix +handleCommand _ _ p (SetInteractivePrint ip) = handleSetInteractivePrint p ip handleCommand _ _ _ _ = P.internalError "handleCommand: unexpected command" -- | Reload the application state @@ -227,6 +229,24 @@ handleShowImportedModules print' = do commaList :: [Text] -> Text commaList = T.intercalate ", " +handleShowPrint + :: (MonadState PSCiState m, MonadIO m) + => (String -> m ()) + -> m () +handleShowPrint print' = do + current <- psciInteractivePrint <$> get + if current == initialInteractivePrint + then + print' $ + "The interactive print function is currently set to the default (`" ++ showPrint current ++ "`)" + else + print' $ + "The interactive print function is currently set to `" ++ showPrint current ++ "`\n" ++ + "The default can be restored with `:print " ++ showPrint initialInteractivePrint ++ "`" + + where + showPrint (mn, ident) = T.unpack (N.runModuleName mn <> "." <> N.runIdent ident) + -- | Imports a module, preserving the initial state on failure. handleImport :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) @@ -318,3 +338,26 @@ handleComplete print' prefix = do let act = liftCompletionM (completion' (reverse prefix, "")) results <- evalStateT act st print' $ unlines (formatCompletions results) + +-- | Attempt to set the interactive print function. Note that the state will +-- only be updated if the interactive print function exists and appears to +-- work; we test it by attempting to evaluate '0'. +handleSetInteractivePrint + :: (MonadState PSCiState m, MonadIO m) + => (String -> m ()) + -> (P.ModuleName, P.Ident) + -> m () +handleSetInteractivePrint print' new = do + current <- gets psciInteractivePrint + modify (setInteractivePrint new) + st <- get + let expr = P.Literal internalSpan (P.NumericLiteral (Left 0)) + let m = createTemporaryModule True st expr + e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m + case e of + Left errs -> do + modify (setInteractivePrint current) + print' "Unable to set the repl's printing function:" + printErrors errs + Right _ -> + pure () diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs index c99648841c..5538315e40 100644 --- a/src/Language/PureScript/Interactive/Directive.hs +++ b/src/Language/PureScript/Interactive/Directive.hs @@ -33,6 +33,7 @@ directiveStrings = , (Show , ["show"]) , (Paste , ["paste"]) , (Complete , ["complete"]) + , (Print , ["print"]) ] -- | @@ -79,16 +80,6 @@ directiveStringsFor = map snd . directivesFor' parseDirective :: String -> Maybe Directive parseDirective = listToMaybe . directivesFor --- | --- True if the given directive takes an argument, false otherwise. -hasArgument :: Directive -> Bool -hasArgument Help = False -hasArgument Quit = False -hasArgument Reload = False -hasArgument Clear = False -hasArgument Paste = False -hasArgument _ = True - -- | -- The help menu. -- @@ -103,7 +94,9 @@ help = , (Kind, "", "Show the kind of ") , (Show, "import", "Show all imported modules") , (Show, "loaded", "Show all loaded modules") + , (Show, "print", "Show the repl's current printing function") , (Paste, "paste", "Enter multiple lines, terminated by ^D") , (Complete, "", "Show completions for as if pressing tab") + , (Print, "", "Set the repl's printing function to (which must be fully qualified)") ] diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index a916e619ff..0633feaffb 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -13,7 +13,7 @@ import System.IO.UTF8 (readUTF8FileT) -- | The name of the PSCI support module supportModuleName :: P.ModuleName -supportModuleName = P.moduleNameFromString "PSCI.Support" +supportModuleName = fst initialInteractivePrint -- | Checks if the Console module is defined supportModuleIsDefined :: [P.Module] -> Bool @@ -50,8 +50,8 @@ createTemporaryModule exec st val = moduleName = P.ModuleName [P.ProperName "$PSCI"] effModuleName = P.moduleNameFromString "Effect" effImport = (effModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Effect"])) - supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"])) - eval = P.Var internalSpan (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval")) + supportImport = (fst (psciInteractivePrint st), P.Implicit, Just (P.ModuleName [P.ProperName "$Support"])) + eval = P.Var internalSpan (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (snd (psciInteractivePrint st))) mainValue = P.App eval (P.Var internalSpan (P.Qualified Nothing (P.Ident "it"))) itDecl = P.ValueDecl (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val] typeDecl = P.TypeDeclaration diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index cc12d55e42..cefec9ff72 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -84,6 +84,10 @@ parseDirective cmd = Type -> TypeOf <$> parseRest P.parseValue arg Kind -> KindOf <$> parseRest P.parseType arg Complete -> return (CompleteStr arg) + Print -> parseRest + ((eof *> return (ShowInfo QueryPrint)) + <|> (SetInteractivePrint <$> parseFullyQualifiedIdent)) + arg -- | -- Parses expressions entered at the PSCI repl. @@ -136,3 +140,12 @@ psciDeprecatedLet = do _ <- mark (many1 (same *> P.parseLocalDeclaration)) notFollowedBy $ P.reserved "in" fail "Declarations in PSCi no longer require \"let\", as of version 0.11.0" + +parseFullyQualifiedIdent :: P.TokenParser (P.ModuleName, P.Ident) +parseFullyQualifiedIdent = do + qname <- P.parseQualified P.parseIdent + case qname of + P.Qualified (Just mn) ident -> + pure (mn, ident) + P.Qualified Nothing _ -> + fail "Expected a fully-qualified name (eg: PSCI.Support.eval)" diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index 437408fd94..84e926b914 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -10,13 +10,16 @@ module Language.PureScript.Interactive.Types , psciExports , psciImports , psciLoadedExterns + , psciInteractivePrint , psciImportedModules , psciLetBindings , initialPSCiState + , initialInteractivePrint , psciImportedModuleNames , updateImportedModules , updateLoadedExterns , updateLets + , setInteractivePrint , Command(..) , ReplQuery(..) , replQueries @@ -46,7 +49,9 @@ newtype PSCiConfig = PSCiConfig -- | The PSCI state. -- --- Holds a list of imported modules, loaded files, and partial let bindings. +-- Holds a list of imported modules, loaded files, and partial let bindings, +-- plus the currently configured interactive printing function. +-- -- The let bindings are partial, because it makes more sense to apply the -- binding to the final evaluated expression. -- @@ -57,27 +62,35 @@ data PSCiState = PSCiState [ImportedModule] [P.Declaration] [(P.Module, P.ExternsFile)] + (P.ModuleName, P.Ident) P.Imports P.Exports deriving Show psciImportedModules :: PSCiState -> [ImportedModule] -psciImportedModules (PSCiState x _ _ _ _) = x +psciImportedModules (PSCiState x _ _ _ _ _) = x psciLetBindings :: PSCiState -> [P.Declaration] -psciLetBindings (PSCiState _ x _ _ _) = x +psciLetBindings (PSCiState _ x _ _ _ _) = x psciLoadedExterns :: PSCiState -> [(P.Module, P.ExternsFile)] -psciLoadedExterns (PSCiState _ _ x _ _) = x +psciLoadedExterns (PSCiState _ _ x _ _ _) = x + +psciInteractivePrint :: PSCiState -> (P.ModuleName, P.Ident) +psciInteractivePrint (PSCiState _ _ _ x _ _) = x psciImports :: PSCiState -> P.Imports -psciImports (PSCiState _ _ _ x _) = x +psciImports (PSCiState _ _ _ _ x _) = x psciExports :: PSCiState -> P.Exports -psciExports (PSCiState _ _ _ _ x) = x +psciExports (PSCiState _ _ _ _ _ x) = x initialPSCiState :: PSCiState -initialPSCiState = PSCiState [] [] [] nullImports primExports +initialPSCiState = PSCiState [] [] [] initialInteractivePrint nullImports primExports + +-- | The default interactive print function. +initialInteractivePrint :: (P.ModuleName, P.Ident) +initialInteractivePrint = (P.moduleNameFromString "PSCI.Support", P.Ident "eval") psciEnvironment :: PSCiState -> P.Environment psciEnvironment st = foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs @@ -104,12 +117,12 @@ psciImportedModuleNames st = -- handling completions. This function must be called whenever the PSCiState is modified to -- ensure that completions remain accurate. updateImportExports :: PSCiState -> PSCiState -updateImportExports st@(PSCiState modules lets externs _ _) = +updateImportExports st@(PSCiState modules lets externs iprint _ _) = case desugarModule [temporaryModule] of Left _ -> st -- TODO: can this fail and what should we do? Right (env, _) -> case M.lookup temporaryName env of - Just (_, is, es) -> PSCiState modules lets externs is es + Just (_, is, es) -> PSCiState modules lets externs iprint is es _ -> st -- impossible where @@ -136,18 +149,24 @@ updateImportExports st@(PSCiState modules lets externs _ _) = -- | Updates the imported modules in the state record. updateImportedModules :: ([ImportedModule] -> [ImportedModule]) -> PSCiState -> PSCiState -updateImportedModules f (PSCiState x a b c d) = - updateImportExports (PSCiState (f x) a b c d) +updateImportedModules f (PSCiState x a b c d e) = + updateImportExports (PSCiState (f x) a b c d e) -- | Updates the loaded externs files in the state record. updateLoadedExterns :: ([(P.Module, P.ExternsFile)] -> [(P.Module, P.ExternsFile)]) -> PSCiState -> PSCiState -updateLoadedExterns f (PSCiState a b x c d) = - updateImportExports (PSCiState a b (f x) c d) +updateLoadedExterns f (PSCiState a b x c d e) = + updateImportExports (PSCiState a b (f x) c d e) -- | Updates the let bindings in the state record. updateLets :: ([P.Declaration] -> [P.Declaration]) -> PSCiState -> PSCiState -updateLets f (PSCiState a x b c d) = - updateImportExports (PSCiState a (f x) b c d) +updateLets f (PSCiState a x b c d e) = + updateImportExports (PSCiState a (f x) b c d e) + +-- | Replaces the interactive printing function in the state record with a new +-- one. +setInteractivePrint :: (P.ModuleName, P.Ident) -> PSCiState -> PSCiState +setInteractivePrint iprint (PSCiState a b c _ d e) = + PSCiState a b c iprint d e -- * Commands @@ -181,16 +200,19 @@ data Command | PasteLines -- | Return auto-completion output as if pressing | CompleteStr String + -- | Set the interactive printing function + | SetInteractivePrint (P.ModuleName, P.Ident) deriving Show data ReplQuery = QueryLoaded | QueryImport + | QueryPrint deriving (Eq, Show) -- | A list of all ReplQuery values. replQueries :: [ReplQuery] -replQueries = [QueryLoaded, QueryImport] +replQueries = [QueryLoaded, QueryImport, QueryPrint] replQueryStrings :: [String] replQueryStrings = map showReplQuery replQueries @@ -198,10 +220,12 @@ replQueryStrings = map showReplQuery replQueries showReplQuery :: ReplQuery -> String showReplQuery QueryLoaded = "loaded" showReplQuery QueryImport = "import" +showReplQuery QueryPrint = "print" parseReplQuery :: String -> Maybe ReplQuery parseReplQuery "loaded" = Just QueryLoaded parseReplQuery "import" = Just QueryImport +parseReplQuery "print" = Just QueryPrint parseReplQuery _ = Nothing data Directive @@ -215,4 +239,5 @@ data Directive | Show | Paste | Complete + | Print deriving (Eq, Show) diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs index 7de6412968..758cfbc982 100644 --- a/tests/TestPsci/CommandTest.hs +++ b/tests/TestPsci/CommandTest.hs @@ -65,3 +65,18 @@ commandTests = context "commandTests" $ do ":browse Mirp" `printed` flip shouldContain "is not valid" ":browse Prim" `printed` flip shouldContain "class Partial" + + specPSCi ":print" $ do + let failMsg = "Unable to set the repl's printing function" + let interactivePrintModuleShouldBe modName = do + modName' <- (fst . psciInteractivePrint) <$> get + modName' `equalsTo` modName + + run "import Prelude" + ":print Prelude.show" `printed` flip shouldContain failMsg + interactivePrintModuleShouldBe (moduleNameFromString "PSCI.Support") + + ":print InteractivePrint.unsafeEval" `printed` flip shouldNotContain failMsg + "(identity :: _ -> _)" `printed` flip shouldContain "[Function]" + interactivePrintModuleShouldBe (moduleNameFromString "InteractivePrint") + ":print" `printed` flip shouldContain "InteractivePrint" diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index 13ba6c08cb..7cf9ba7dcb 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -47,8 +47,8 @@ completionTestData supportModuleNames = , (":reload ", []) , (":clear ", []) - -- :show should complete to "loaded" and "import" - , (":show ", [":show import", ":show loaded"]) + -- :show should complete its available arguments + , (":show ", [":show import", ":show loaded", ":show print"]) , (":show a", []) -- :type should complete next word from values and constructors in scope diff --git a/tests/support/psci/InteractivePrint.purs b/tests/support/psci/InteractivePrint.purs new file mode 100644 index 0000000000..4dc364fc4f --- /dev/null +++ b/tests/support/psci/InteractivePrint.purs @@ -0,0 +1,11 @@ +-- A module for testing the :print feature for configuring the function used +-- for printing repl results +module InteractivePrint where + +import Prelude +import Effect (Effect) +import Effect.Console (log) +import Unsafe.Coerce (unsafeCoerce) + +unsafeEval :: forall a. a -> Effect Unit +unsafeEval = log <<< unsafeCoerce From 6189770e3d5db25cb490cb273cc334ca99bcc6e9 Mon Sep 17 00:00:00 2001 From: Philip Kamenarsky Date: Sun, 30 Dec 2018 18:36:36 +0200 Subject: [PATCH 1040/1580] Implement QualifiedDo (#3373) * Implement QualifiedDo * Improve QualifiedDo tests * Implement QualifiedAdo * Trigger CI * Backtrack only while parsing the do/ado keywords * >>= pure . k is just fmap * Clean up tests --- src/Language/PureScript/AST/Declarations.hs | 4 +- src/Language/PureScript/AST/Traversals.hs | 28 +++++------ .../PureScript/Parser/Declarations.hs | 8 ++-- src/Language/PureScript/Pretty/Values.hs | 9 ++-- src/Language/PureScript/Sugar/AdoNotation.hs | 18 ++++---- src/Language/PureScript/Sugar/DoNotation.hs | 46 +++++++++---------- tests/purs/passing/QualifiedAdo.purs | 19 ++++++++ .../passing/QualifiedAdo/IxApplicative.purs | 8 ++++ tests/purs/passing/QualifiedDo.purs | 19 ++++++++ tests/purs/passing/QualifiedDo/IxMonad.purs | 5 ++ 10 files changed, 108 insertions(+), 56 deletions(-) create mode 100644 tests/purs/passing/QualifiedAdo.purs create mode 100644 tests/purs/passing/QualifiedAdo/IxApplicative.purs create mode 100644 tests/purs/passing/QualifiedDo.purs create mode 100644 tests/purs/passing/QualifiedDo/IxMonad.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 6c2d12887a..75144ad466 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -775,11 +775,11 @@ data Expr -- | -- A do-notation block -- - | Do [DoNotationElement] + | Do (Maybe ModuleName) [DoNotationElement] -- | -- An ado-notation block -- - | Ado [DoNotationElement] Expr + | Ado (Maybe ModuleName) [DoNotationElement] Expr -- | -- An application of a typeclass dictionary constructor. The value should be -- an ObjectLiteral. diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 3764d2cd95..a6ede54534 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -76,8 +76,8 @@ everywhereOnValues f g h = (f', g', h') g' (Case vs alts) = g (Case (fmap g' vs) (fmap handleCaseAlternative alts)) g' (TypedValue check v ty) = g (TypedValue check (g' v) ty) g' (Let w ds v) = g (Let w (fmap f' ds) (g' v)) - g' (Do es) = g (Do (fmap handleDoNotationElement es)) - g' (Ado es v) = g (Ado (fmap handleDoNotationElement es) (g' v)) + g' (Do m es) = g (Do m (fmap handleDoNotationElement es)) + g' (Ado m es v) = g (Ado m (fmap handleDoNotationElement es) (g' v)) g' (PositionedValue pos com v) = g (PositionedValue pos com (g' v)) g' other = g other @@ -150,8 +150,8 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (Case vs alts) = Case <$> traverse (g' <=< g) vs <*> traverse handleCaseAlternative alts g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty g' (Let w ds v) = Let w <$> traverse (f' <=< f) ds <*> (g v >>= g') - g' (Do es) = Do <$> traverse handleDoNotationElement es - g' (Ado es v) = Ado <$> traverse handleDoNotationElement es <*> (g v >>= g') + g' (Do m es) = Do m <$> traverse handleDoNotationElement es + g' (Ado m es v) = Ado m <$> traverse handleDoNotationElement es <*> (g v >>= g') g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g') g' other = g other @@ -219,8 +219,8 @@ everywhereOnValuesM f g h = (f', g', h') g' (Case vs alts) = (Case <$> traverse g' vs <*> traverse handleCaseAlternative alts) >>= g g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g g' (Let w ds v) = (Let w <$> traverse f' ds <*> g' v) >>= g - g' (Do es) = (Do <$> traverse handleDoNotationElement es) >>= g - g' (Ado es v) = (Ado <$> traverse handleDoNotationElement es <*> g' v) >>= g + g' (Do m es) = (Do m <$> traverse handleDoNotationElement es) >>= g + g' (Ado m es v) = (Ado m <$> traverse handleDoNotationElement es <*> g' v) >>= g g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g g' other = g other @@ -291,8 +291,8 @@ everythingOnValues (<>.) f g h i j = (f', g', h', i', j') g' v@(Case vs alts) = foldl (<>.) (foldl (<>.) (g v) (fmap g' vs)) (fmap i' alts) g' v@(TypedValue _ v1 _) = g v <>. g' v1 g' v@(Let _ ds v1) = foldl (<>.) (g v) (fmap f' ds) <>. g' v1 - g' v@(Do es) = foldl (<>.) (g v) (fmap j' es) - g' v@(Ado es v1) = foldl (<>.) (g v) (fmap j' es) <>. g' v1 + g' v@(Do _ es) = foldl (<>.) (g v) (fmap j' es) + g' v@(Ado _ es v1) = foldl (<>.) (g v) (fmap j' es) <>. g' v1 g' v@(PositionedValue _ _ v1) = g v <>. g' v1 g' v = g v @@ -372,8 +372,8 @@ everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i g' s (Case vs alts) = foldl (<>.) (foldl (<>.) r0 (fmap (g'' s) vs)) (fmap (i'' s) alts) g' s (TypedValue _ v1 _) = g'' s v1 g' s (Let _ ds v1) = foldl (<>.) r0 (fmap (f'' s) ds) <>. g'' s v1 - g' s (Do es) = foldl (<>.) r0 (fmap (j'' s) es) - g' s (Ado es v1) = foldl (<>.) r0 (fmap (j'' s) es) <>. g'' s v1 + g' s (Do _ es) = foldl (<>.) r0 (fmap (j'' s) es) + g' s (Ado _ es v1) = foldl (<>.) r0 (fmap (j'' s) es) <>. g'' s v1 g' s (PositionedValue _ _ v1) = g'' s v1 g' _ _ = r0 @@ -457,8 +457,8 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g' s (Case vs alts) = Case <$> traverse (g'' s) vs <*> traverse (i'' s) alts g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty g' s (Let w ds v) = Let w <$> traverse (f'' s) ds <*> g'' s v - g' s (Do es) = Do <$> traverse (j'' s) es - g' s (Ado es v) = Ado <$> traverse (j'' s) es <*> g'' s v + g' s (Do m es) = Do m <$> traverse (j'' s) es + g' s (Ado m es v) = Ado m <$> traverse (j'' s) es <*> g'' s v g' s (PositionedValue pos com v) = PositionedValue pos com <$> g'' s v g' _ other = return other @@ -554,8 +554,8 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' s (Let _ ds v1) = let s' = S.union s (S.fromList (map LocalIdent (mapMaybe getDeclIdent ds))) in foldMap (f'' s') ds <> g'' s' v1 - g' s (Do es) = fold . snd . mapAccumL j'' s $ es - g' s (Ado es v1) = + g' s (Do _ es) = fold . snd . mapAccumL j'' s $ es + g' s (Ado _ es v1) = let s' = S.union s (foldMap (fst . j'' s) es) in g'' s' v1 g' s (PositionedValue _ _ v1) = g'' s v1 diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 39ddadba19..c7b1408575 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -484,17 +484,17 @@ parseAccessor obj = P.try $ Accessor <$> (indented *> dot *> indented *> parseLa parseDo :: TokenParser Expr parseDo = do - reserved "do" + m <- P.try (getQual <$> parseQualified (reserved "do")) <|> (reserved "do" *> pure Nothing) indented - Do <$> mark (P.many1 (same *> mark parseDoNotationElement)) + Do m <$> mark (P.many1 (same *> mark parseDoNotationElement)) parseAdo :: TokenParser Expr parseAdo = do - reserved "ado" + m <- P.try (getQual <$> parseQualified (reserved "ado")) <|> (reserved "ado" *> pure Nothing) indented elements <- mark (P.many (same *> mark parseDoNotationElement)) yield <- mark (reserved "in" *> parseValue) - pure $ Ado elements yield + pure $ Ado m elements yield parseDoNotationLet :: TokenParser DoNotationElement parseDoNotationLet = DoNotationLet <$> (reserved "let" *> indented *> mark (P.many1 (same *> parseLocalDeclaration))) diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index ad45d2a19a..104fca9a8d 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -11,6 +11,7 @@ import Prelude.Compat hiding ((<>)) import Control.Arrow (second) +import Data.Maybe (maybe) import Data.Text (Text) import qualified Data.List.NonEmpty as NEL import qualified Data.Monoid as Monoid ((<>)) @@ -80,10 +81,10 @@ prettyPrintValue d (Let FromLet ds val) = text "let" // moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) // (text "in " <> prettyPrintValue (d - 1) val) -prettyPrintValue d (Do els) = - text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) -prettyPrintValue d (Ado els yield) = - text "ado " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) // +prettyPrintValue d (Do m els) = + textT (maybe "" ((Monoid.<> ".") . runModuleName) m) <> text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) +prettyPrintValue d (Ado m els yield) = + textT (maybe "" ((Monoid.<> ".") . runModuleName) m) <> text "ado " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) // (text "in " <> prettyPrintValue (d - 1) yield) prettyPrintValue _ (TypeClassDictionary (Constraint _ name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map typeAtomAsBox tys prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name)) diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs index c881fc3996..f7e84bccc2 100644 --- a/src/Language/PureScript/Sugar/AdoNotation.hs +++ b/src/Language/PureScript/Sugar/AdoNotation.hs @@ -28,21 +28,21 @@ desugarAdo d = let (f, _, _) = everywhereOnValuesM return replace return in f d where - pure' :: Expr - pure' = Var nullSourceSpan (Qualified Nothing (Ident C.pure')) + pure' :: Maybe ModuleName -> Expr + pure' m = Var nullSourceSpan (Qualified m (Ident C.pure')) - map' :: Expr - map' = Var nullSourceSpan (Qualified Nothing (Ident C.map)) + map' :: Maybe ModuleName -> Expr + map' m = Var nullSourceSpan (Qualified m (Ident C.map)) - apply :: Expr - apply = Var nullSourceSpan (Qualified Nothing (Ident C.apply)) + apply :: Maybe ModuleName -> Expr + apply m = Var nullSourceSpan (Qualified m (Ident C.apply)) replace :: Expr -> m Expr - replace (Ado els yield) = do + replace (Ado m els yield) = do (func, args) <- foldM go (yield, []) (reverse els) return $ case args of - [] -> App pure' func - hd : tl -> foldl' (\a b -> App (App apply a) b) (App (App map' func) hd) tl + [] -> App (pure' m) func + hd : tl -> foldl' (\a b -> App (App (apply m) a) b) (App (App (map' m) func) hd) tl replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v) replace other = return other diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index a3d46bfdc4..003580c15d 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -29,43 +29,43 @@ desugarDo d = (f, _, _) = everywhereOnValuesM return (replace ss) return in rethrowWithPosition ss $ f d where - bind :: SourceSpan -> Expr - bind = flip Var (Qualified Nothing (Ident C.bind)) + bind :: SourceSpan -> Maybe ModuleName -> Expr + bind ss m = Var ss (Qualified m (Ident C.bind)) - discard :: SourceSpan -> Expr - discard = flip Var (Qualified Nothing (Ident C.discard)) + discard :: SourceSpan -> Maybe ModuleName -> Expr + discard ss m = Var ss (Qualified m (Ident C.discard)) replace :: SourceSpan -> Expr -> m Expr - replace pos (Do els) = go pos els + replace pos (Do m els) = go pos m els replace _ (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace pos v) replace _ other = return other - go :: SourceSpan -> [DoNotationElement] -> m Expr - go _ [] = internalError "The impossible happened in desugarDo" - go _ [DoNotationValue val] = return val - go pos (DoNotationValue val : rest) = do - rest' <- go pos rest - return $ App (App (discard pos) val) (Abs (VarBinder pos UnusedIdent) rest') - go _ [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind - go _ (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) = + go :: SourceSpan -> Maybe ModuleName -> [DoNotationElement] -> m Expr + go _ _ [] = internalError "The impossible happened in desugarDo" + go _ _ [DoNotationValue val] = return val + go pos m (DoNotationValue val : rest) = do + rest' <- go pos m rest + return $ App (App (discard pos m) val) (Abs (VarBinder pos UnusedIdent) rest') + go _ _ [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind + go _ _ (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) = throwError . errorMessage $ CannotUseBindWithDo (Ident ident) where fromIdent (Ident i) | i `elem` [ C.bind, C.discard ] = First (Just i) fromIdent _ = mempty - go pos (DoNotationBind (VarBinder ss ident) val : rest) = do - rest' <- go pos rest - return $ App (App (bind pos) val) (Abs (VarBinder ss ident) rest') - go pos (DoNotationBind binder val : rest) = do - rest' <- go pos rest + go pos m (DoNotationBind (VarBinder ss ident) val : rest) = do + rest' <- go pos m rest + return $ App (App (bind pos m) val) (Abs (VarBinder ss ident) rest') + go pos m (DoNotationBind binder val : rest) = do + rest' <- go pos m rest ident <- freshIdent' - return $ App (App (bind pos) val) (Abs (VarBinder pos ident) (Case [Var pos (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']])) - go _ [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet - go pos (DoNotationLet ds : rest) = do + return $ App (App (bind pos m) val) (Abs (VarBinder pos ident) (Case [Var pos (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']])) + go _ _ [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet + go pos m (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () checkBind (ValueDecl (ss, _) i@(Ident name) _ _ _) | name `elem` [ C.bind, C.discard ] = throwError . errorMessage' ss $ CannotUseBindWithDo i checkBind _ = pure () mapM_ checkBind ds - rest' <- go pos rest + rest' <- go pos m rest return $ Let FromLet ds rest' - go _ (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go pos (el : rest) + go _ m (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go pos m (el : rest) diff --git a/tests/purs/passing/QualifiedAdo.purs b/tests/purs/passing/QualifiedAdo.purs new file mode 100644 index 0000000000..5764abf38a --- /dev/null +++ b/tests/purs/passing/QualifiedAdo.purs @@ -0,0 +1,19 @@ +module Main where + +import Prelude +import Effect.Console (log) +import IxApplicative as Ix + +testIApplicative :: forall f a. Ix.IxApplicative f => f a a String +testIApplicative = Ix.ado + a <- Ix.pure "test" + b <- Ix.pure "test" + in (a <> b) + +testApplicative :: forall f. Applicative f => f String +testApplicative = ado + a <- pure "test" + b <- pure "test" + in (a <> b) + +main = log "Done" diff --git a/tests/purs/passing/QualifiedAdo/IxApplicative.purs b/tests/purs/passing/QualifiedAdo/IxApplicative.purs new file mode 100644 index 0000000000..656cb9c2b5 --- /dev/null +++ b/tests/purs/passing/QualifiedAdo/IxApplicative.purs @@ -0,0 +1,8 @@ +module IxApplicative where + +class IxFunctor f where + map ∷ forall a b x y. (a -> b) -> f x y a -> f x y b + +class IxFunctor f <= IxApplicative f where + pure ∷ forall a x y. a -> f x y a + apply ∷ forall a b x y z. f x y (a -> b) -> f y z a -> f x z b diff --git a/tests/purs/passing/QualifiedDo.purs b/tests/purs/passing/QualifiedDo.purs new file mode 100644 index 0000000000..5395138e16 --- /dev/null +++ b/tests/purs/passing/QualifiedDo.purs @@ -0,0 +1,19 @@ +module Main where + +import Prelude +import Effect.Console (log) +import IxMonad as Ix + +testIMonad :: forall m a. Ix.IxMonad m => m a a String +testIMonad = Ix.do + a <- Ix.pure "test" + b <- Ix.pure "test" + Ix.pure (a <> b) + +testMonad :: forall m. Monad m => m String +testMonad = do + a <- pure "test" + b <- pure "test" + pure (a <> b) + +main = log "Done" diff --git a/tests/purs/passing/QualifiedDo/IxMonad.purs b/tests/purs/passing/QualifiedDo/IxMonad.purs new file mode 100644 index 0000000000..8caf015198 --- /dev/null +++ b/tests/purs/passing/QualifiedDo/IxMonad.purs @@ -0,0 +1,5 @@ +module IxMonad where + +class IxMonad m where + pure ∷ forall a x y. a -> m x y a + bind ∷ forall a b x y z. m x y a -> (a -> m y z b) -> m x z b From 1dc385e0d2fdf25e3fd445ab3d2c60442ac958de Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Fri, 4 Jan 2019 08:18:08 -0800 Subject: [PATCH 1041/1580] Add better source positions to kind errors (#3495) * Add lenses for annotations * Add better source positions to kind errors * Throw possibly multiple source spans * Extract to error utility * Remove unused imports * Revert unnecessary rethrowWithPosition * Add positions to kindsForAll vars --- src/Language/PureScript/AST/SourcePos.hs | 2 + src/Language/PureScript/Errors.hs | 12 ++- src/Language/PureScript/Kinds.hs | 18 +++- src/Language/PureScript/Parser/Types.hs | 6 +- src/Language/PureScript/TypeChecker.hs | 14 +-- src/Language/PureScript/TypeChecker/Kinds.hs | 98 +++++++++++--------- src/Language/PureScript/Types.hs | 44 +++++---- 7 files changed, 115 insertions(+), 79 deletions(-) diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 5b8f27940a..d47de81a50 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -109,6 +109,8 @@ nonEmptySpan (NullSourceSpan, _) = Nothing nonEmptySpan (ss, _) = Just ss widenSourceSpan :: SourceSpan -> SourceSpan -> SourceSpan +widenSourceSpan NullSourceSpan b = b +widenSourceSpan a NullSourceSpan = a widenSourceSpan (SourceSpan n1 s1 e1) (SourceSpan n2 s2 e2) = SourceSpan n (min s1 s2) (max e1 e2) where diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8927ed6ba1..e3f3698a05 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -18,7 +18,7 @@ import Data.Char (isSpace) import Data.Either (partitionEithers) import Data.Foldable (fold) import Data.Functor.Identity (Identity(..)) -import Data.List (transpose, nubBy, partition, dropWhileEnd, sortBy) +import Data.List (transpose, nubBy, partition, dropWhileEnd, sort, sortBy) import qualified Data.List.NonEmpty as NEL import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import qualified Data.Map as M @@ -205,6 +205,15 @@ errorMessage' ss err = MultipleErrors [ErrorMessage [positionedError ss] err] errorMessage'' :: NEL.NonEmpty SourceSpan -> SimpleErrorMessage -> MultipleErrors errorMessage'' sss err = MultipleErrors [ErrorMessage [PositionedError sss] err] +-- | Create an error from multiple (possibly empty) source spans, reversed sorted. +errorMessage''' :: [SourceSpan] -> SimpleErrorMessage -> MultipleErrors +errorMessage''' sss err = + maybe (errorMessage err) (flip errorMessage'' err) + . NEL.nonEmpty + . reverse + . sort + $ filter (/= NullSourceSpan) sss + -- | Create an error set from a single error message singleError :: ErrorMessage -> MultipleErrors singleError = MultipleErrors . pure @@ -1446,6 +1455,7 @@ warnAndRethrowWithPosition :: (MonadError MultipleErrors m, MonadWriter Multiple warnAndRethrowWithPosition pos = rethrowWithPosition pos . warnWithPosition pos withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage +withPosition NullSourceSpan err = err withPosition pos (ErrorMessage hints se) = ErrorMessage (positionedError pos : hints) se positionedError :: SourceSpan -> ErrorMessageHint diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 20e5291e89..f58cceeed8 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -19,6 +19,8 @@ import qualified Data.Aeson as A import Language.PureScript.AST.SourcePos import Language.PureScript.Names +import Lens.Micro.Platform (Lens', (^.), set) + type SourceKind = Kind SourceAnn -- | The data type of kinds @@ -128,11 +130,17 @@ everythingOnKinds (<>.) f = go go k@(FunKind _ k1 k2) = f k <>. go k1 <>. go k2 go other = f other -annotationForKind :: Kind a -> a -annotationForKind (KUnknown a _) = a -annotationForKind (Row a _) = a -annotationForKind (FunKind a _ _) = a -annotationForKind (NamedKind a _) = a +annForKind :: Lens' (Kind a) a +annForKind k (KUnknown a b) = (\z -> KUnknown z b) <$> k a +annForKind k (Row a b) = (\z -> Row z b) <$> k a +annForKind k (FunKind a b c) = (\z -> FunKind z b c) <$> k a +annForKind k (NamedKind a b) = (\z -> NamedKind z b) <$> k a + +getAnnForKind :: Kind a -> a +getAnnForKind = (^. annForKind) + +setAnnForKind :: a -> Kind a -> Kind a +setAnnForKind = set annForKind instance Eq (Kind a) where (==) = eqKind diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 9f27687326..b2623bd549 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -131,16 +131,16 @@ parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTabl ] mkTypeApp lhs rhs = - TypeApp (widenSourceAnn (annotationForType lhs) (annotationForType rhs)) lhs rhs + TypeApp (widenSourceAnn (getAnnForType lhs) (getAnnForType rhs)) lhs rhs parseTypeOp = withSourceAnnF $ do ident <- P.try (parseQualified parseOperator) return $ \ann lhs rhs -> - BinaryNoParensType (widenSourceAnn (annotationForType lhs) (annotationForType rhs)) (TypeOp ann ident) lhs rhs + BinaryNoParensType (widenSourceAnn (getAnnForType lhs) (getAnnForType rhs)) (TypeOp ann ident) lhs rhs parseKindedType ty = do kind <- indented *> doubleColon *> parseKind - return $ KindedType (widenSourceAnn (annotationForType ty) (annotationForKind kind)) ty kind + return $ KindedType (widenSourceAnn (getAnnForType ty) (getAnnForKind kind)) ty kind -- | diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index ed4272656c..752184d4f0 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -41,7 +41,7 @@ import Language.PureScript.TypeChecker.Types as T import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types -import Lens.Micro.Platform ((^..), _1, _2) +import Lens.Micro.Platform ((^..), _2, _3) addDataType :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) @@ -244,24 +244,24 @@ typeCheckAll moduleName _ = traverse go let tysList = NEL.toList tys syns = mapMaybe toTypeSynonym tysList dataDecls = mapMaybe toDataDecl tysList - bindingGroupNames = ordNub ((syns^..traverse._1) ++ (dataDecls^..traverse._2)) + bindingGroupNames = ordNub ((syns^..traverse._2) ++ (dataDecls^..traverse._3)) sss = fmap declSourceSpan tys warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames) . addHint (PositionedError sss)) $ do - (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls) - for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do + (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(sa, _, name, args, dctors) -> (sa, name, args, concatMap snd dctors)) dataDecls) + for_ (zip dataDecls data_ks) $ \((_, dtype, name, args, dctors), ctorKind) -> do when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args let args' = args `withKinds` ctorKind addDataType moduleName dtype name args' dctors ctorKind - for_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do + for_ (zip syns syn_ks) $ \((_, name, args, ty), kind) -> do checkDuplicateTypeArguments $ map fst args let args' = args `withKinds` kind addTypeSynonym moduleName name args' ty kind return d where - toTypeSynonym (TypeSynonymDeclaration _ nm args ty) = Just (nm, args, ty) + toTypeSynonym (TypeSynonymDeclaration sa nm args ty) = Just (sa, nm, args, ty) toTypeSynonym _ = Nothing - toDataDecl (DataDeclaration _ dtype nm args dctors) = Just (dtype, nm, args, dctors) + toDataDecl (DataDeclaration sa dtype nm args dctors) = Just (sa, dtype, nm, args, dctors) toDataDecl _ = Nothing go (TypeSynonymDeclaration sa@(ss, _) name args ty) = do warnAndRethrow (addHint (ErrorInTypeSynonym name) . addHint (positionedError ss) ) $ do diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index ef6596bb79..fcb73d5d19 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -20,6 +20,7 @@ import Control.Monad.State import Data.Functor (($>)) import qualified Data.Map as M import Data.Text (Text) +import Data.Traversable (for) import Language.PureScript.Crash import Language.PureScript.Environment @@ -30,11 +31,14 @@ import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types -- | Generate a fresh kind variable -freshKind :: (MonadState CheckState m) => m SourceKind -freshKind = do +freshKind :: (MonadState CheckState m) => SourceAnn -> m SourceKind +freshKind ann = do k <- gets checkNextKind modify $ \st -> st { checkNextKind = k + 1 } - return $ KUnknown nullSourceAnn k + return $ KUnknown ann k + +freshKind' :: (MonadState CheckState m) => m SourceKind +freshKind' = freshKind NullSourceAnn -- | Update the substitution to solve a kind constraint solveKind @@ -91,7 +95,10 @@ unifyKinds k1 k2 = do go (FunKind _ k1' k2') (FunKind _ k3 k4) = do unifyKinds k1' k3 unifyKinds k2' k4 - go k1' k2' = throwError . errorMessage $ KindsDoNotUnify k1' k2' + go k1' k2' = + throwError + . errorMessage''' (fst . getAnnForKind <$> [k1', k2']) + $ KindsDoNotUnify k1' k2' -- | Infer the kind of a single type kindOf @@ -123,8 +130,8 @@ kindsOf -> [SourceType] -> m SourceKind kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do - tyCon <- freshKind - kargs <- replicateM (length args) freshKind + tyCon <- freshKind' + kargs <- replicateM (length args) $ freshKind' rest <- zipWithM freshKindVar args kargs let dict = (name, tyCon) : rest bindLocalTypeVariables moduleName dict $ @@ -146,23 +153,23 @@ freshKindVar (arg, Just kind') kind = do kindsOfAll :: (MonadError MultipleErrors m, MonadState CheckState m) => ModuleName - -> [(ProperName 'TypeName, [(Text, Maybe SourceKind)], SourceType)] - -> [(ProperName 'TypeName, [(Text, Maybe SourceKind)], [SourceType])] + -> [(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceKind)], SourceType)] + -> [(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceKind)], [SourceType])] -> m ([SourceKind], [SourceKind]) kindsOfAll moduleName syns tys = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do - synVars <- replicateM (length syns) freshKind - let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars + synVars <- for syns $ \(sa, _, _, _) -> freshKind sa + let dict = zipWith (\(_, name, _, _) var -> (name, var)) syns synVars bindLocalTypeVariables moduleName dict $ do - tyCons <- replicateM (length tys) freshKind - let dict' = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons + tyCons <- for tys $ \(sa, _, _, _) -> freshKind sa + let dict' = zipWith (\(_, name, _, _) tyCon -> (name, tyCon)) tys tyCons bindLocalTypeVariables moduleName dict' $ do - data_ks <- zipWithM (\tyCon (_, args, ts) -> do - kargs <- replicateM (length args) freshKind + data_ks <- zipWithM (\tyCon (_, _, args, ts) -> do + kargs <- for args $ \(_, kind) -> maybe freshKind' (freshKind . getAnnForKind) kind argDict <- zipWithM freshKindVar args kargs bindLocalTypeVariables moduleName argDict $ solveTypes True ts kargs tyCon) tyCons tys - syn_ks <- zipWithM (\synVar (_, args, ty) -> do - kargs <- replicateM (length args) freshKind + syn_ks <- zipWithM (\synVar (_, _, args, ty) -> do + kargs <- for args $ \(_, kind) -> maybe freshKind' (freshKind . getAnnForKind) kind argDict <- zipWithM freshKindVar args kargs bindLocalTypeVariables moduleName argDict $ solveTypes False [ty] kargs synVar) synVars syns @@ -181,10 +188,10 @@ solveTypes solveTypes isData ts kargs tyCon = do ks <- traverse (fmap fst . infer) ts when isData $ do - unifyKinds tyCon (foldr (FunKind nullSourceAnn) kindType kargs) + unifyKinds tyCon (foldr srcFunKind kindType kargs) forM_ ks $ \k -> unifyKinds k kindType unless isData $ - unifyKinds tyCon (foldr (FunKind nullSourceAnn) (head ks) kargs) + unifyKinds tyCon (foldr srcFunKind (head ks) kargs) return tyCon -- | Default all unknown kinds to the kindType kind of types @@ -199,15 +206,18 @@ infer :: (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> m (SourceKind, [(Text, SourceKind)]) -infer ty = withErrorMessageHint (ErrorCheckingKind ty) $ infer' ty +infer ty = + withErrorMessageHint (ErrorCheckingKind ty) + . rethrowWithPosition (fst $ getAnnForType ty) + $ infer' ty infer' :: forall m . (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> m (SourceKind, [(Text, SourceKind)]) -infer' (ForAll _ ident ty _) = do - k1 <- freshKind +infer' (ForAll ann ident ty _) = do + k1 <- freshKind ann Just moduleName <- checkCurrentModule <$> get (k2, args) <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty unifyKinds k2 kindType @@ -219,48 +229,48 @@ infer' (KindedType _ ty k) = do infer' other = (, []) <$> go other where go :: SourceType -> m SourceKind - go (ForAll _ ident ty _) = do - k1 <- freshKind + go (ForAll ann ident ty _) = do + k1 <- freshKind ann Just moduleName <- checkCurrentModule <$> get k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ go ty unifyKinds k2 kindType - return kindType + return $ kindType $> ann go (KindedType _ ty k) = do k' <- go ty unifyKinds k k' return k' - go TypeWildcard{} = freshKind - go TUnknown{} = freshKind - go (TypeLevelString {}) = return kindSymbol - go (TypeVar _ v) = do + go (TypeWildcard ann) = freshKind ann + go (TUnknown ann _) = freshKind ann + go (TypeLevelString ann _) = return $ kindSymbol $> ann + go (TypeVar ann v) = do Just moduleName <- checkCurrentModule <$> get - lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) - go (Skolem _ v _ _) = do + ($> ann) <$> lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) + go (Skolem ann v _ _) = do Just moduleName <- checkCurrentModule <$> get - lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) - go (TypeConstructor _ v) = do + ($> ann) <$> lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) + go (TypeConstructor ann v) = do env <- getEnv case M.lookup v (types env) of - Nothing -> throwError . errorMessage . UnknownName $ fmap TyName v - Just (kind, _) -> return kind - go (TypeApp _ t1 t2) = do - k0 <- freshKind + Nothing -> throwError . errorMessage' (fst ann) . UnknownName $ fmap TyName v + Just (kind, _) -> return $ kind $> ann + go (TypeApp ann t1 t2) = do + k0 <- freshKind ann k1 <- go t1 k2 <- go t2 - unifyKinds k1 (FunKind nullSourceAnn k2 k0) + unifyKinds k1 (FunKind ann k2 k0) return k0 - go (REmpty _) = do - k <- freshKind - return $ Row nullSourceAnn k - go (RCons _ _ ty row) = do + go (REmpty ann) = do + k <- freshKind ann + return $ Row ann k + go (RCons ann _ ty row) = do k1 <- go ty k2 <- go row - unifyKinds k2 (Row nullSourceAnn k1) - return $ Row nullSourceAnn k1 + unifyKinds k2 (Row ann k1) + return $ Row ann k1 go (ConstrainedType ann2 (Constraint ann1 className tys _) ty) = do k1 <- go $ foldl (TypeApp ann2) (TypeConstructor ann1 (fmap coerceProperName className)) tys unifyKinds k1 kindType k2 <- go ty unifyKinds k2 kindType - return kindType + return $ kindType $> ann2 go ty = internalError $ "Invalid argument to infer: " ++ show ty diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 27e1c1827e..367318c93f 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -34,6 +34,8 @@ import Language.PureScript.Names import Language.PureScript.Label (Label) import Language.PureScript.PSString (PSString) +import Lens.Micro.Platform (Lens', (^.), set) + type SourceType = Type SourceAnn type SourceConstraint = Constraint SourceAnn @@ -422,9 +424,7 @@ freeTypeVariables = ordNub . go [] where -- | Universally quantify over all type variables appearing free in a type quantify :: Type a -> Type a -quantify ty = foldr (\arg t -> ForAll ann arg t Nothing) ty $ freeTypeVariables ty - where - ann = annotationForType ty +quantify ty = foldr (\arg t -> ForAll (getAnnForType ty) arg t Nothing) ty $ freeTypeVariables ty -- | Move all universal quantifiers to the front of a type moveQuantifiersToFront :: Type a -> Type a @@ -514,22 +514,28 @@ everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 where go s (ParensInType _ t1) = go' s t1 go _ _ = r0 -annotationForType :: Type a -> a -annotationForType (TUnknown a _) = a -annotationForType (TypeVar a _) = a -annotationForType (TypeLevelString a _) = a -annotationForType (TypeWildcard a) = a -annotationForType (TypeConstructor a _) = a -annotationForType (TypeOp a _) = a -annotationForType (TypeApp a _ _) = a -annotationForType (ForAll a _ _ _) = a -annotationForType (ConstrainedType a _ _) = a -annotationForType (Skolem a _ _ _) = a -annotationForType (REmpty a) = a -annotationForType (RCons a _ _ _) = a -annotationForType (KindedType a _ _) = a -annotationForType (BinaryNoParensType a _ _ _) = a -annotationForType (ParensInType a _) = a +annForType :: Lens' (Type a) a +annForType k (TUnknown a b) = (\z -> TUnknown z b) <$> k a +annForType k (TypeVar a b) = (\z -> TypeVar z b) <$> k a +annForType k (TypeLevelString a b) = (\z -> TypeLevelString z b) <$> k a +annForType k (TypeWildcard a) = TypeWildcard <$> k a +annForType k (TypeConstructor a b) = (\z -> TypeConstructor z b) <$> k a +annForType k (TypeOp a b) = (\z -> TypeOp z b) <$> k a +annForType k (TypeApp a b c) = (\z -> TypeApp z b c) <$> k a +annForType k (ForAll a b c d) = (\z -> ForAll z b c d) <$> k a +annForType k (ConstrainedType a b c) = (\z -> ConstrainedType z b c) <$> k a +annForType k (Skolem a b c d) = (\z -> Skolem z b c d) <$> k a +annForType k (REmpty a) = REmpty <$> k a +annForType k (RCons a b c d) = (\z -> RCons z b c d) <$> k a +annForType k (KindedType a b c) = (\z -> KindedType z b c) <$> k a +annForType k (BinaryNoParensType a b c d) = (\z -> BinaryNoParensType z b c d) <$> k a +annForType k (ParensInType a b) = (\z -> ParensInType z b) <$> k a + +getAnnForType :: Type a -> a +getAnnForType = (^. annForType) + +setAnnForType :: a -> Type a -> Type a +setAnnForType = set annForType instance Eq (Type a) where (==) = eqType From 913b46fd25ee7b954b23a964eaa09725dcac4801 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 7 Jan 2019 14:07:44 +0000 Subject: [PATCH 1042/1580] Remove the concept of the 'current module' in Docs (#3506) The concept of the current module is unnecessary (we aren't using it anywhere either in the compiler or in Pursuit) as well as potentially confusing; for example, what is the 'current module' when we are rendering re-exported declarations? Additionally, since the information is not used, it would be easy for it to become incorrect without anyone noticing. This commit refactors the Docs related code, removing the concept of the current module. Specifically, the following have been removed: - the SameModule constructor from the LinkLocation data type; wherever we previously would have used that, we can now use the LocalModule constructor, which encodes precisely the same information. - the 'current module' field from the constructors LocalModule and DepsModule of the data type LinkLocation, which was unused. - the 'currentModuleName' field of the HtmlRenderContext data type, which was also unused. I came across this refactoring opportunity while looking into #3504. --- app/Command/Docs/Html.hs | 11 +++----- src/Language/PureScript/Docs/AsHtml.hs | 36 ++++++++++++-------------- src/Language/PureScript/Docs/Types.hs | 23 +++++++--------- 3 files changed, 30 insertions(+), 40 deletions(-) diff --git a/app/Command/Docs/Html.hs b/app/Command/Docs/Html.hs index 0352fce7f3..1e4a176e46 100644 --- a/app/Command/Docs/Html.hs +++ b/app/Command/Docs/Html.hs @@ -48,8 +48,7 @@ writeHtmlFile filepath = getHtmlRenderContext :: P.ModuleName -> D.HtmlRenderContext getHtmlRenderContext mn = D.HtmlRenderContext - { D.currentModuleName = mn - , D.buildDocLink = getLink mn + { D.buildDocLink = getLink mn , D.renderDocLink = renderLink , D.renderSourceLink = const Nothing } @@ -70,11 +69,11 @@ getLink curMn namespace target containingMod = do normalLinkLocation = do case containingMod of D.ThisModule -> - return D.SameModule + return $ D.LocalModule curMn D.OtherModule destMn -> -- This is OK because all modules count as 'local' for purs docs in -- html mode - return $ D.LocalModule curMn destMn + return $ D.LocalModule destMn builtinLinkLocation = do let primMn = P.moduleNameFromString "Prim" @@ -84,9 +83,7 @@ getLink curMn namespace target containingMod = do renderLink :: D.DocLink -> Text renderLink l = case D.linkLocation l of - D.SameModule -> - "" - D.LocalModule _ dest -> + D.LocalModule dest -> P.runModuleName dest <> ".html" D.DepsModule{} -> P.internalError "DepsModule: not implemented" diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index adeeab7c54..cc9c3b7302 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -53,18 +53,16 @@ data HtmlOutputModule a = HtmlOutputModule deriving (Show, Functor) data HtmlRenderContext = HtmlRenderContext - { currentModuleName :: P.ModuleName - , buildDocLink :: Namespace -> Text -> ContainingModule -> Maybe DocLink + { buildDocLink :: Namespace -> Text -> ContainingModule -> Maybe DocLink , renderDocLink :: DocLink -> Text , renderSourceLink :: P.SourceSpan -> Maybe Text } -- | -- An HtmlRenderContext for when you don't want to render any links. -nullRenderContext :: P.ModuleName -> HtmlRenderContext -nullRenderContext mn = HtmlRenderContext - { currentModuleName = mn - , buildDocLink = const (const (const Nothing)) +nullRenderContext :: HtmlRenderContext +nullRenderContext = HtmlRenderContext + { buildDocLink = const (const (const Nothing)) , renderDocLink = const "" , renderSourceLink = const Nothing } @@ -83,16 +81,16 @@ moduleAsHtml :: (InPackage P.ModuleName -> Maybe HtmlRenderContext) -> Module -> (P.ModuleName, HtmlOutputModule Html) -moduleAsHtml getR Module{..} = (modName, HtmlOutputModule modHtml reexports) +moduleAsHtml getHtmlCtx Module{..} = (modName, HtmlOutputModule modHtml reexports) where modHtml = do - let r = fromMaybe (nullRenderContext modName) $ getR (Local modName) + let r = fromMaybe nullRenderContext $ getHtmlCtx (Local modName) in do for_ modComments renderMarkdown for_ modDeclarations (declAsHtml r) reexports = flip map modReExports $ \(pkg, decls) -> - let r = fromMaybe (nullRenderContext modName) $ getR pkg + let r = fromMaybe nullRenderContext $ getHtmlCtx pkg in (pkg, foldMap (declAsHtml r) decls) -- renderIndex :: LinksContext -> [(Maybe Char, Html)] @@ -101,17 +99,17 @@ moduleAsHtml getR Module{..} = (modName, HtmlOutputModule modHtml reexports) -- go = takeLocals -- >>> groupIndex getIndex renderEntry -- >>> map (second (ul . mconcat)) --- +-- -- getIndex (_, title_) = do -- c <- textHeadMay title_ -- guard (toUpper c `elem` ['A'..'Z']) -- pure c --- +-- -- textHeadMay t = -- case T.length t of -- 0 -> Nothing -- _ -> Just (T.index t 0) --- +-- -- renderEntry (mn, title_) = -- li $ do -- let url = T.pack (filePathFor mn `relativeTo` "index") <> "#" <> title_ @@ -119,7 +117,7 @@ moduleAsHtml getR Module{..} = (modName, HtmlOutputModule modHtml reexports) -- a ! A.href (v url) $ text title_ -- sp -- text ("(" <> P.runModuleName mn <> ")") --- +-- -- groupIndex :: Ord i => (a -> Maybe i) -> (a -> b) -> [a] -> [(Maybe i, [b])] -- groupIndex f g = -- map (second DList.toList) . M.toList . foldr go' M.empty . sortBy (comparing f) @@ -233,13 +231,13 @@ renderLink r link_@DocLink{..} = a ! A.href (v (renderDocLink r link_ <> fragmentFor link_)) ! A.title (v fullyQualifiedName) where - fullyQualifiedName = case linkLocation of - SameModule -> fq (currentModuleName r) linkTitle - LocalModule _ modName -> fq modName linkTitle - DepsModule _ _ _ modName -> fq modName linkTitle - BuiltinModule modName -> fq modName linkTitle + fullyQualifiedName = + P.runModuleName modName <> "." <> linkTitle - fq mn str = P.runModuleName mn <> "." <> str + modName = case linkLocation of + LocalModule m -> m + DepsModule _ _ m -> m + BuiltinModule m -> m makeFragment :: Namespace -> Text -> Text makeFragment ns = (prefix <>) . escape diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 827fc3550f..16a18d54a8 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -414,18 +414,13 @@ data DocLink = DocLink instance NFData DocLink data LinkLocation - -- | A link to a declaration in the same module. - = SameModule + -- | A link to a declaration in the current package. + = LocalModule P.ModuleName - -- | A link to a declaration in a different module, but still in the current - -- package; we need to store the current module and the other declaration's - -- module. - | LocalModule P.ModuleName P.ModuleName - - -- | A link to a declaration in a different package. We store: current module - -- name, name of the other package, version of the other package, and name of - -- the module in the other package that the declaration is in. - | DepsModule P.ModuleName PackageName Version P.ModuleName + -- | A link to a declaration in a different package. The arguments represent + -- the name of the other package, the version of the other package, and the + -- name of the module in the other package that the declaration is in. + | DepsModule PackageName Version P.ModuleName -- | A link to a declaration that is built in to the compiler, e.g. the Prim -- module. In this case we only need to store the module that the builtin @@ -454,14 +449,14 @@ getLink LinksContext{..} curMn namespace target containingMod = do normalLinkLocation = do case containingMod of ThisModule -> - return SameModule + return $ LocalModule curMn OtherModule destMn -> case Map.lookup destMn ctxModuleMap of Nothing -> - return $ LocalModule curMn destMn + return $ LocalModule destMn Just pkgName -> do pkgVersion <- lookup pkgName ctxResolvedDependencies - return $ DepsModule curMn pkgName pkgVersion destMn + return $ DepsModule pkgName pkgVersion destMn builtinLinkLocation = case containingMod of From 2beb8c8775fa4fd6062929922e42c8425bbffd7f Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Thu, 10 Jan 2019 20:53:36 +0000 Subject: [PATCH 1043/1580] Fix source spans for binding groups (#3462) Moves the recursive call out of each previous item's source span. Fixes #3452 --- src/Language/PureScript/TypeChecker/Types.hs | 26 ++++++++++---------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 6275141a1a..b7991e2189 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -430,24 +430,24 @@ inferLetBinding -> (Expr -> m Expr) -> m ([Declaration], Expr) inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) -inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)] : rest) ret j = - warnAndRethrowWithPositionTC ss $ do - Just moduleName <- checkCurrentModule <$> get +inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)] : rest) ret j = do + Just moduleName <- checkCurrentModule <$> get + TypedValue _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do (kind, args) <- kindOfWithScopedVars ty checkTypeKind ty kind let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined) ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty - TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv - bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) - $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j -inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = - warnAndRethrowWithPositionTC ss $ do - valTy <- freshType + if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv + bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) + $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j +inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = do + valTy <- freshType + TypedValue _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined) - TypedValue _ val' valTy' <- bindNames dict $ infer val - unifyTypes valTy valTy' - bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) - $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j + bindNames dict $ infer val + warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' + bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) + $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do Just moduleName <- checkCurrentModule <$> get SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds From 73fee56ac2adc17b66dd1df27e5693746c80173f Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sun, 13 Jan 2019 07:57:55 -0800 Subject: [PATCH 1044/1580] Add named type wildcards (#3500) * Add named type wildcards * Remove debug * Use HoleInferredType for named type wildcards --- src/Language/PureScript/AST/Declarations.hs | 2 +- .../PureScript/Docs/Convert/Single.hs | 2 +- .../Docs/RenderedCode/RenderType.hs | 4 ++-- src/Language/PureScript/Errors.hs | 7 ++++-- src/Language/PureScript/Ide/Error.hs | 2 +- src/Language/PureScript/Parser/Types.hs | 5 +++- src/Language/PureScript/Pretty/Types.hs | 6 ++--- .../PureScript/Sugar/TypeClasses/Deriving.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 22 +++++++++++++++--- src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 6 ++--- src/Language/PureScript/TypeChecker/Unify.hs | 5 ++-- src/Language/PureScript/Types.hs | 23 ++++++++++--------- tests/purs/failing/TypedHole2.purs | 8 +++++++ tests/purs/warning/WildcardInferredType.purs | 9 -------- tests/purs/warning/WildcardInferredType2.purs | 14 +++++++++++ 16 files changed, 78 insertions(+), 41 deletions(-) create mode 100644 tests/purs/failing/TypedHole2.purs create mode 100644 tests/purs/warning/WildcardInferredType2.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 75144ad466..8dab6dee15 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -142,7 +142,7 @@ data SimpleErrorMessage | ShadowedTypeVar Text | UnusedTypeVar Text | WildcardInferredType SourceType Context - | HoleInferredType Text SourceType Context TypeSearch + | HoleInferredType Text SourceType Context (Maybe TypeSearch) | MissingTypeDeclaration Ident SourceType | OverlappingPattern [[Binder]] Bool | IncompleteExhaustivityCheck diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index e366302375..608c02f70c 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -115,7 +115,7 @@ convertDeclaration (P.ValueDecl sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) convertDeclaration (P.ValueDecl sa _ _ _ _) title = -- If no explicit type declaration was provided, insert a wildcard, so that -- the actual type will be added during type checking. - basicDeclaration sa title (ValueDeclaration (P.TypeWildcard ())) + basicDeclaration sa title (ValueDeclaration (P.TypeWildcard () Nothing)) convertDeclaration (P.ExternDeclaration sa _ ty) title = basicDeclaration sa title (ValueDeclaration (ty $> ())) convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title = diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index c874d750ae..be5753dd2e 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -31,8 +31,8 @@ import Language.PureScript.Docs.RenderedCode.RenderKind (renderKind) typeLiterals :: Pattern () PrettyPrintType RenderedCode typeLiterals = mkPattern match where - match PPTypeWildcard = - Just (syntax "_") + match (PPTypeWildcard name) = + Just $ maybe (syntax "_") (syntax . ("?" <>)) name match (PPTypeVar var) = Just (typeVar var) match (PPRecord row) = diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index e3f3698a05..f730b600ef 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -296,7 +296,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k gSimple (OrphanInstance nm cl noms ts) = OrphanInstance nm cl noms <$> traverse f ts gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx - gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx <*> onTypeSearchTypesM f env + gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx <*> traverse (onTypeSearchTypesM f) env gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty gSimple other = pure other @@ -852,7 +852,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl let maxTSResults = 15 tsResult = case ts of - (TSAfter{tsAfterIdentifiers=idents}) | not (null idents) -> + Just (TSAfter{tsAfterIdentifiers=idents}) | not (null idents) -> let formatTS (names, types) = let @@ -1461,6 +1461,9 @@ withPosition pos (ErrorMessage hints se) = ErrorMessage (positionedError pos : h positionedError :: SourceSpan -> ErrorMessageHint positionedError = PositionedError . pure +filterErrors :: (ErrorMessage -> Bool) -> MultipleErrors -> MultipleErrors +filterErrors f = MultipleErrors . filter f . runMultipleErrors + -- | Runs a computation listening for warnings and then escalating any warnings -- that match the predicate to error status. escalateWarningWhen diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 3908fd708b..93d8be989a 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -52,7 +52,7 @@ encodeRebuildErrors = toJSON . map encodeRebuildError . P.runMultipleErrors encodeRebuildError err = case err of (P.ErrorMessage _ ((P.HoleInferredType name _ _ - (P.TSAfter{tsAfterIdentifiers=idents, tsAfterRecordFields=fields})))) -> + (Just (P.TSAfter{tsAfterIdentifiers=idents, tsAfterRecordFields=fields}))))) -> insertTSCompletions name idents (fromMaybe [] fields) (toJSON (toJSONError False P.Error err)) _ -> (toJSON . toJSONError False P.Error) err diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index b2623bd549..2bd34f6672 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -37,7 +37,10 @@ parseTypeLevelString :: TokenParser SourceType parseTypeLevelString = withSourceAnnF $ flip TypeLevelString <$> stringLiteral parseTypeWildcard :: TokenParser SourceType -parseTypeWildcard = withSourceAnnF $ underscore $> TypeWildcard +parseTypeWildcard = withSourceAnnF $ do + name <- Just <$> holeLit + <|> Nothing <$ underscore + return $ flip TypeWildcard name parseTypeVariable :: TokenParser SourceType parseTypeVariable = withSourceAnnF $ do diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 5be826b6fe..531bffd8e3 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -45,7 +45,7 @@ data PrettyPrintType = PPTUnknown Int | PPTypeVar Text | PPTypeLevelString PSString - | PPTypeWildcard + | PPTypeWildcard (Maybe Text) | PPTypeConstructor (Qualified (ProperName 'TypeName)) | PPTypeOp (Qualified (OpName 'TypeOpName)) | PPSkolem Text Int @@ -68,7 +68,7 @@ convertPrettyPrintType = go go (TUnknown _ n) = PPTUnknown n go (TypeVar _ t) = PPTypeVar t go (TypeLevelString _ s) = PPTypeLevelString s - go (TypeWildcard _) = PPTypeWildcard + go (TypeWildcard _ n) = PPTypeWildcard n go (TypeConstructor _ c) = PPTypeConstructor c go (TypeOp _ o) = PPTypeOp o go (Skolem _ t n _) = PPSkolem t n @@ -161,7 +161,7 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} = where typeLiterals :: Pattern () PrettyPrintType Box typeLiterals = mkPattern match where - match PPTypeWildcard = Just $ text "_" + match (PPTypeWildcard name) = Just $ maybe (text "_") (text . ('?' :) . T.unpack) name match (PPTypeVar var) = Just $ text $ T.unpack var match (PPTypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s match (PPRecord row) = Just $ prettyPrintRowWith tro '{' '}' row diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 59d38aba82..8851d9d763 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -427,7 +427,7 @@ deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do argument' = App (Constructor ss argument) checkIsWildcard :: MonadError MultipleErrors m => SourceSpan -> ProperName 'TypeName -> SourceType -> m () -checkIsWildcard _ _ (TypeWildcard _) = return () +checkIsWildcard _ _ (TypeWildcard _ Nothing) = return () checkIsWildcard ss tyConNm _ = throwError . errorMessage' ss $ ExpectedWildcard tyConNm diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 752184d4f0..58a05a4be9 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -16,10 +16,10 @@ import Control.Monad (when, unless, void, forM) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), modify, gets) import Control.Monad.Supply.Class (MonadSupply) -import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Writer.Class (MonadWriter(..), censor) import Data.Foldable (for_, traverse_, toList) -import Data.List (nub, nubBy, (\\), sort, group) +import Data.List (nub, nubBy, (\\), sort, group, intersect) import Data.Maybe import Data.Text (Text) import qualified Data.List.NonEmpty as NEL @@ -274,12 +274,13 @@ typeCheckAll moduleName _ = traverse go internalError "Type declarations should have been removed before typeCheckAlld" go (ValueDecl sa@(ss, _) name nameKind [] [MkUnguarded val]) = do env <- getEnv - warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (positionedError ss)) $ do + warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (positionedError ss)) . censorLocalUnnamedWildcards val $ do val' <- checkExhaustiveExpr ss env moduleName val valueIsNotDefined moduleName name [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] addValue moduleName name ty nameKind return $ ValueDecl sa name nameKind [] [MkUnguarded val''] + where go ValueDeclaration{} = internalError "Binders were not desugared" go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared" go (BindingGroupDeclaration vals) = do @@ -464,6 +465,21 @@ typeCheckAll moduleName _ = traverse go | moduleName `S.member` nonOrphanModules = return () | otherwise = throwError . errorMessage $ OrphanInstance dictName className nonOrphanModules tys' + censorLocalUnnamedWildcards :: Expr -> m a -> m a + censorLocalUnnamedWildcards (TypedValue _ _ ty) = censor (filterErrors (not . isLocalUnnamedWildcardError ty)) + censorLocalUnnamedWildcards _ = id + + isLocalUnnamedWildcardError :: SourceType -> ErrorMessage -> Bool + isLocalUnnamedWildcardError ty err@(ErrorMessage _ (WildcardInferredType _ _)) = + let + ssWildcard (TypeWildcard (ss', _) Nothing) = [ss'] + ssWildcard _ = [] + sssWildcards = everythingOnTypes (<>) ssWildcard ty + sss = maybe [] NEL.toList $ errorSpan err + in + null $ intersect sss sssWildcards + isLocalUnnamedWildcardError _ _ = False + -- | -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, -- extracted from the kind of the type constructor itself. diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index fcb73d5d19..35c5dfd8ab 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -239,7 +239,7 @@ infer' other = (, []) <$> go other k' <- go ty unifyKinds k k' return k' - go (TypeWildcard ann) = freshKind ann + go (TypeWildcard ann _) = freshKind ann go (TUnknown ann _) = freshKind ann go (TypeLevelString ann _) = return $ kindSymbol $> ann go (TypeVar ann v) = do diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index b7991e2189..f372a698f2 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -151,12 +151,12 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -> ErrorMessage -> ErrorMessage runTypeSearch cons st = \case - ErrorMessage hints (HoleInferredType x ty y (TSBefore env)) -> + ErrorMessage hints (HoleInferredType x ty y (Just (TSBefore env))) -> let subst = checkSubstitution st searchResult = onTypeSearchTypes (substituteType subst) (uncurry TSAfter (typeSearch cons env st (substituteType subst ty))) - in ErrorMessage hints (HoleInferredType x ty y searchResult) + in ErrorMessage hints (HoleInferredType x ty y (Just searchResult)) other -> other -- | Generalize type vars using forall and add inferred constraints @@ -415,7 +415,7 @@ infer' (Hole name) = do ty <- freshType ctx <- getLocalContext env <- getEnv - tell . errorMessage $ HoleInferredType name ty ctx (TSBefore env) + tell . errorMessage $ HoleInferredType name ty ctx . Just $ TSBefore env return $ TypedValue True (Hole name) ty infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do TypedValue t v ty <- infer' val diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index d53002719a..19bf3e641c 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -184,10 +184,11 @@ replaceVarWithUnknown ident ty = do replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState CheckState m) => SourceType -> m SourceType replaceTypeWildcards = everywhereOnTypesM replace where - replace (TypeWildcard ann) = do + replace (TypeWildcard ann name) = do t <- freshType ctx <- getLocalContext - warnWithPosition (fst ann) $ tell . errorMessage $ WildcardInferredType t ctx + let err = maybe (WildcardInferredType t ctx) (\n -> HoleInferredType n t ctx Nothing) name + warnWithPosition (fst ann) $ tell $ errorMessage err return t replace other = return other diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 367318c93f..56f963bfd3 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -58,7 +58,7 @@ data Type a -- | A type-level string | TypeLevelString a PSString -- | A type wildcard, as would appear in a partial type synonym - | TypeWildcard a + | TypeWildcard a (Maybe Text) -- | A type constructor | TypeConstructor a (Qualified (ProperName 'TypeName)) -- | A type operator. This will be desugared into a type constructor during the @@ -101,7 +101,7 @@ srcTypeLevelString :: PSString -> SourceType srcTypeLevelString = TypeLevelString NullSourceAnn srcTypeWildcard :: SourceType -srcTypeWildcard = TypeWildcard NullSourceAnn +srcTypeWildcard = TypeWildcard NullSourceAnn Nothing srcTypeConstructor :: Qualified (ProperName 'TypeName) -> SourceType srcTypeConstructor = TypeConstructor NullSourceAnn @@ -195,8 +195,8 @@ typeToJSON annToJSON ty = variant "TypeVar" a b TypeLevelString a b -> variant "TypeLevelString" a b - TypeWildcard a -> - nullary "TypeWildcard" a + TypeWildcard a b -> + variant "TypeWildcard" a b TypeConstructor a b -> variant "TypeConstructor" a b TypeOp a b -> @@ -274,8 +274,9 @@ typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do TypeVar a <$> contents "TypeLevelString" -> TypeLevelString a <$> contents - "TypeWildcard" -> - pure $ TypeWildcard a + "TypeWildcard" -> do + b <- contents <|> pure Nothing + pure $ TypeWildcard a b "TypeConstructor" -> TypeConstructor a <$> contents "TypeOp" -> @@ -518,7 +519,7 @@ annForType :: Lens' (Type a) a annForType k (TUnknown a b) = (\z -> TUnknown z b) <$> k a annForType k (TypeVar a b) = (\z -> TypeVar z b) <$> k a annForType k (TypeLevelString a b) = (\z -> TypeLevelString z b) <$> k a -annForType k (TypeWildcard a) = TypeWildcard <$> k a +annForType k (TypeWildcard a b) = (\z -> TypeWildcard z b) <$> k a annForType k (TypeConstructor a b) = (\z -> TypeConstructor z b) <$> k a annForType k (TypeOp a b) = (\z -> TypeOp z b) <$> k a annForType k (TypeApp a b c) = (\z -> TypeApp z b c) <$> k a @@ -547,7 +548,7 @@ eqType :: Type a -> Type b -> Bool eqType (TUnknown _ a) (TUnknown _ a') = a == a' eqType (TypeVar _ a) (TypeVar _ a') = a == a' eqType (TypeLevelString _ a) (TypeLevelString _ a') = a == a' -eqType (TypeWildcard _) (TypeWildcard _) = True +eqType (TypeWildcard _ a) (TypeWildcard _ a') = a == a' eqType (TypeConstructor _ a) (TypeConstructor _ a') = a == a' eqType (TypeOp _ a) (TypeOp _ a') = a == a' eqType (TypeApp _ a b) (TypeApp _ a' b') = eqType a a' && eqType b b' @@ -573,9 +574,9 @@ compareType (TypeLevelString _ a) (TypeLevelString _ a') = compare a a' compareType (TypeLevelString {}) _ = LT compareType _ (TypeLevelString {}) = GT -compareType (TypeWildcard _) (TypeWildcard _) = EQ -compareType (TypeWildcard _) _ = LT -compareType _ (TypeWildcard _) = GT +compareType (TypeWildcard _ a) (TypeWildcard _ a') = compare a a' +compareType (TypeWildcard {}) _ = LT +compareType _ (TypeWildcard {}) = GT compareType (TypeConstructor _ a) (TypeConstructor _ a') = compare a a' compareType (TypeConstructor {}) _ = LT diff --git a/tests/purs/failing/TypedHole2.purs b/tests/purs/failing/TypedHole2.purs new file mode 100644 index 0000000000..2e6cd66d59 --- /dev/null +++ b/tests/purs/failing/TypedHole2.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith HoleInferredType +module Main where + +import Prelude +import Effect (Effect) + +main :: Effect ?ummm +main = pure unit diff --git a/tests/purs/warning/WildcardInferredType.purs b/tests/purs/warning/WildcardInferredType.purs index 3662384dea..da42213319 100644 --- a/tests/purs/warning/WildcardInferredType.purs +++ b/tests/purs/warning/WildcardInferredType.purs @@ -1,10 +1,7 @@ -- @shouldWarnWith WildcardInferredType -- @shouldWarnWith WildcardInferredType --- @shouldWarnWith WildcardInferredType --- @shouldWarnWith WildcardInferredType module Main where -x :: Int x = 0 :: _ y :: _ @@ -15,9 +12,3 @@ z = let n :: _ n = 0 in n - -w :: Int -w = n - where - n :: _ - n = 0 diff --git a/tests/purs/warning/WildcardInferredType2.purs b/tests/purs/warning/WildcardInferredType2.purs new file mode 100644 index 0000000000..441a326c18 --- /dev/null +++ b/tests/purs/warning/WildcardInferredType2.purs @@ -0,0 +1,14 @@ +-- @shouldWarnWith WildcardInferredType +module Main where + +x :: _ +x = 42 + +y :: Int +y = 42 :: _ + +z :: Int +z = n + where + n :: _ + n = 42 \ No newline at end of file From 0807b9919c6bcd07d6ebcba5edd6b70cf414c055 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sun, 13 Jan 2019 10:42:48 -0800 Subject: [PATCH 1045/1580] Fix kind error for recursive data type (#3511) --- src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 35c5dfd8ab..0e6792c27b 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -189,7 +189,7 @@ solveTypes isData ts kargs tyCon = do ks <- traverse (fmap fst . infer) ts when isData $ do unifyKinds tyCon (foldr srcFunKind kindType kargs) - forM_ ks $ \k -> unifyKinds k kindType + forM_ ks $ \k -> unifyKinds k (kindType $> getAnnForKind k) unless isData $ unifyKinds tyCon (foldr srcFunKind (head ks) kargs) return tyCon From 0d08831d85cf3037fe0a345f31a83723022dd145 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 13 Jan 2019 21:03:01 +0000 Subject: [PATCH 1046/1580] Add a template release checklist, refs #3185 (#3509) * Add a template release checklist, refs #3185 The intention is that this file can serve as a template / starting point for each future release. --- RELEASE_CHECKLIST.md | 62 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) create mode 100644 RELEASE_CHECKLIST.md diff --git a/RELEASE_CHECKLIST.md b/RELEASE_CHECKLIST.md new file mode 100644 index 0000000000..f3ec657f6e --- /dev/null +++ b/RELEASE_CHECKLIST.md @@ -0,0 +1,62 @@ +# Release Checklist + +## For every release + +- [ ] Regenerate LICENSE (see `license-generator/`) +- [ ] Release notes +- [ ] Publish to Hackage +- [ ] Update npm package +- [ ] Try PureScript? — need to decide whether we want to continue + officially supporting this + +## Libraries + +Are there breaking changes to the language? Or alternatively, are there +language changes which require breaking changes in the relevant libraries to +make use of? If so: + +- [ ] Update core libraries +- [ ] Update contrib libraries +- [ ] Update node bindings +- [ ] Create a new package set + +## Tools + +Has the compiler CLI changed at all? If so, the following may need updates: + +- [ ] psc-package +- [ ] Pulp +- [ ] purs-loader +- [ ] ide plugins + +## JSON formats + +Have any of the following JSON formats changed? If so, it may be worth +considering what effects this may have: + +- [ ] Corefn +- [ ] Ide protocol +- [ ] JSON produced by `purs publish` + - [ ] check whether this affects Pursuit + +## Documentation + +- [ ] Check that purescript.org is up-to-date +- [ ] Check that INSTALL.md is up-to-date + +Have there been any changes or additions to the language which should be +documented? + +- [ ] Document any language changes in the documentation repo + +Have there been additions or changes to `Prim` (including documentation +changes?) If so, + +- [ ] Update Pursuit to depend on the latest compiler so that these docs appear + on pursuit.purescript.org + +## Announcements + +- [ ] Discourse +- [ ] Twitter +- [ ] /r/purescript From 62f9b7f46f9caa3e4bec84d6df3ed50867503820 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 13 Jan 2019 23:40:07 +0000 Subject: [PATCH 1047/1580] Bump version to 0.12.2 (#3512) * Bump version to 0.12.2 * Update license file --- LICENSE | 1876 +++++++++++++++++++------------------------------- package.yaml | 2 +- 2 files changed, 702 insertions(+), 1176 deletions(-) diff --git a/LICENSE b/LICENSE index b25d9b37a8..a29686db88 100644 --- a/LICENSE +++ b/LICENSE @@ -14,20 +14,15 @@ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND PureScript uses the following Haskell library packages. Their license files follow. + Cabal Glob SHA - StateVar - adjunctions aeson aeson-better-errors - aeson-pretty ansi-terminal ansi-wl-pprint appar array - asn1-encoding - asn1-parse - asn1-types async attoparsec auto-update @@ -35,14 +30,14 @@ PureScript uses the following Haskell library packages. Their license files foll base-compat base-orphans base64-bytestring - bifunctors + basement binary blaze-builder blaze-html blaze-markup bower-json boxes - byteable + bsb-http-chunked byteorder bytestring bytestring-builder @@ -50,61 +45,57 @@ PureScript uses the following Haskell library packages. Their license files foll cereal cheapskate clock - cmdargs - comonad + colour conduit conduit-extra - connection containers - contravariant cookie cryptonite css-text data-default data-default-class - data-default-instances-base data-default-instances-containers data-default-instances-dlist data-default-instances-old-locale data-ordlist deepseq directory - distributive dlist easy-file edit-distance entropy exceptions - fail fast-logger file-embed filepath - free + foundation fsnotify + ghc-boot-th ghc-prim hashable haskeline - hex - hinotify - hourglass - http-client - http-client-tls + hfsevents http-date http-types http2 integer-gmp + integer-logarithms iproute - kan-extensions language-javascript - lens lifted-base memory + microlens + microlens-ghc + microlens-mtl + microlens-platform + microlens-th mime-types - mmorph monad-control monad-logger monad-loops + mono-traversable mtl + mtl-compat network network-uri old-locale @@ -113,28 +104,21 @@ PureScript uses the following Haskell library packages. Their license files foll parallel parsec pattern-arrows - pem - pipes - pipes-http - prelude-extras + pretty primitive process - profunctors protolude psqueues random - reflection regex-base regex-tdfa resourcet + rts safe scientific - semigroupoids semigroups simple-sendfile - socks sourcemap - spdx split stm stm-chans @@ -146,19 +130,24 @@ PureScript uses the following Haskell library packages. Their license files foll template-haskell terminfo text + th-abstraction time - tls + time-locale-compat transformers transformers-base transformers-compat + typed-process uniplate unix unix-compat unix-time + unliftio-core unordered-containers utf8-string + uuid-types vault vector + vector-algorithms void wai wai-app-static @@ -168,20 +157,50 @@ PureScript uses the following Haskell library packages. Their license files foll warp websockets word8 - x509 - x509-store - x509-system - x509-validation xss-sanitize zlib +Cabal LICENSE file: + + Copyright (c) 2003-2017, Cabal Development Team. + See the AUTHORS file for the full list of copyright holders. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + Glob LICENSE file: The code in Glob is released under the license below. Copyrights to parts of the code are held by whoever wrote the code in question: see CREDITS.txt for a list of authors. - Copyright (c) 2008-2016 + Copyright (c) 2008-2018 All rights reserved. Redistribution and use in source and binary forms, with or without @@ -238,67 +257,6 @@ SHA LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -StateVar LICENSE file: - - Copyright (c) 2014-2015, Edward Kmett - Copyright (c) 2009-2016, Sven Panne - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - 1. Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - 3. Neither the name of the author nor the names of its contributors may be - used to endorse or promote products derived from this software without - specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS - INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN - CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - -adjunctions LICENSE file: - - Copyright 2011-2014 Edward Kmett - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - aeson LICENSE file: Copyright (c) 2011, MailRank, Inc. @@ -355,39 +313,6 @@ aeson-better-errors LICENSE file: TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -aeson-pretty LICENSE file: - - Copyright (c)2011, Falko Peters - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Falko Peters nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - ansi-terminal LICENSE file: Copyright (c) 2008, Maximilian Bolingbroke @@ -559,96 +484,6 @@ array LICENSE file: ----------------------------------------------------------------------------- -asn1-encoding LICENSE file: - - Copyright (c) 2010-2013 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - -asn1-parse LICENSE file: - - Copyright (c) 2010-2013 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - -asn1-types LICENSE file: - - Copyright (c) 2010-2013 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - async LICENSE file: Copyright (c) 2012, Simon Marlow @@ -826,7 +661,7 @@ base LICENSE file: base-compat LICENSE file: - Copyright (c) 2012-2016 Simon Hengel and Ryan Scott + Copyright (c) 2012-2018 Simon Hengel and Ryan Scott Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -848,7 +683,7 @@ base-compat LICENSE file: base-orphans LICENSE file: - Copyright (c) 2015-2016 Simon Hengel , João Cristóvão , Ryan Scott + Copyright (c) 2015-2017 Simon Hengel , João Cristóvão , Ryan Scott Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the @@ -902,34 +737,36 @@ base64-bytestring LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -bifunctors LICENSE file: +basement LICENSE file: - Copyright 2008-2016 Edward Kmett + Copyright (c) 2015-2017 Vincent Hanquez + Copyright (c) 2017 Foundation Maintainers All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. binary LICENSE file: @@ -1116,39 +953,9 @@ boxes LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -byteable LICENSE file: - - Copyright (c) 2013 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - -byteorder LICENSE file: +bsb-http-chunked LICENSE file: - Copyright 2009, Antoine Latter + Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 2011 All rights reserved. @@ -1163,7 +970,7 @@ byteorder LICENSE file: disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of the author nor the names of other + * Neither the name of Jasper Van der Jeugt nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. @@ -1179,9 +986,42 @@ byteorder LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -bytestring LICENSE file: +byteorder LICENSE file: - Copyright (c) Don Stewart 2005-2009 + Copyright 2009, Antoine Latter + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the author nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +bytestring LICENSE file: + + Copyright (c) Don Stewart 2005-2009 (c) Duncan Coutts 2006-2015 (c) David Roundy 2003-2005 (c) Simon Meier 2010-2011 @@ -1380,68 +1220,28 @@ clock LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -cmdargs LICENSE file: - - Copyright Neil Mitchell 2009-2016. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are - met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Neil Mitchell nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -comonad LICENSE file: - - Copyright 2008-2014 Edward Kmett - Copyright 2004-2008 Dave Menendez - - All rights reserved. +colour LICENSE file: - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: + Copyright (c) 2008, 2009 + Russell O'Connor - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. - THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + THE SOFTWARE. conduit LICENSE file: @@ -1489,36 +1289,6 @@ conduit-extra LICENSE file: OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -connection LICENSE file: - - Copyright (c) 2012 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - containers LICENSE file: The Glasgow Haskell Compiler License @@ -1553,39 +1323,6 @@ containers LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -contravariant LICENSE file: - - Copyright 2007-2015 Edward Kmett - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - cookie LICENSE file: Copyright (c) 2010 Michael Snoyman, http://www.yesodweb.com/ @@ -1642,31 +1379,26 @@ cryptonite LICENSE file: css-text LICENSE file: - The following license covers this documentation, and the source code, except - where otherwise indicated. - - Copyright 2010, Michael Snoyman. All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: + Copyright (c) 2010 Michael Snoyman, http://www.yesodweb.com/ - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF - MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO - EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT - NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, - OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE - OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF - ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. data-default LICENSE file: @@ -1706,35 +1438,6 @@ data-default-class LICENSE file: Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY LUKAS MAI AND CONTRIBUTORS "AS IS" AND ANY - EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY - DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -data-default-instances-base LICENSE file: - - Copyright (c) 2013 Lukas Mai - - All rights reserved. - - Redistribution and use in source and binary forms, with or without modification, - are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, @@ -1963,38 +1666,9 @@ directory LICENSE file: ----------------------------------------------------------------------------- -distributive LICENSE file: - - Copyright 2011-2016 Edward Kmett - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - dlist LICENSE file: - Copyright (c) 2006-2009 Don Stewart, 2013-2014 Sean Leather + Copyright (c) 2006-2009 Don Stewart, 2013-2016 Sean Leather All rights reserved. @@ -2150,40 +1824,7 @@ exceptions LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -fail LICENSE file: - - Copyright (c) 2015, David Luposchainsky & Herbert Valerio Riedel - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Herbert Valerio Riedel nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -fast-logger LICENSE file: +fast-logger LICENSE file: Copyright (c) 2009, IIJ Innovation Institute Inc. All rights reserved. @@ -2245,7 +1886,7 @@ file-embed LICENSE file: filepath LICENSE file: - Copyright Neil Mitchell 2005-2015. + Copyright Neil Mitchell 2005-2018. All rights reserved. Redistribution and use in source and binary forms, with or without @@ -2276,38 +1917,36 @@ filepath LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -free LICENSE file: +foundation LICENSE file: - Copyright 2008-2013 Edward Kmett + Copyright (c) 2015-2017 Vincent Hanquez + Copyright (c) 2017-2018 Foundation Maintainers All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. fsnotify LICENSE file: @@ -2342,6 +1981,40 @@ fsnotify LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +ghc-boot-th LICENSE file: + + The Glasgow Haskell Compiler License + + Copyright 2002, The University Court of the University of Glasgow. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. + ghc-prim LICENSE file: This library (libraries/ghc-prim) is derived from code from several @@ -2466,146 +2139,38 @@ haskeline LICENSE file: OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -hex LICENSE file: +hfsevents LICENSE file: + + Copyright (c) 2012, Luite Stegeman - Copyright (c) 2008, Taru Karttunen All rights reserved. Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: + modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. - Neither the name of the Taru Karttunen; nor the names of its contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + * Neither the name of Luite Stegeman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR - CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, - EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, - PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR - PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING - NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -hinotify LICENSE file: - - Copyright (c) Lennart Kolmodin - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS - OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - -hourglass LICENSE file: - - Copyright (c) 2014 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - -http-client LICENSE file: - - The MIT License (MIT) - - Copyright (c) 2013 Michael Snoyman - - Permission is hereby granted, free of charge, to any person obtaining a copy of - this software and associated documentation files (the "Software"), to deal in - the Software without restriction, including without limitation the rights to - use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of - the Software, and to permit persons to whom the Software is furnished to do so, - subject to the following conditions: - - The above copyright notice and this permission notice shall be included in all - copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS - FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR - COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER - IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN - CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -http-client-tls LICENSE file: - - The MIT License (MIT) - - Copyright (c) 2013 Michael Snoyman - - Permission is hereby granted, free of charge, to any person obtaining a copy of - this software and associated documentation files (the "Software"), to deal in - the Software without restriction, including without limitation the rights to - use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of - the Software, and to permit persons to whom the Software is furnished to do so, - subject to the following conditions: - - The above copyright notice and this permission notice shall be included in all - copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS - FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR - COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER - IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN - CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. http-date LICENSE file: @@ -2738,6 +2303,25 @@ integer-gmp LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +integer-logarithms LICENSE file: + + Copyright (c) 2011 Daniel Fischer, 2017 Oleg Grenrus + + Permission is hereby granted, free of charge, to any person obtaining a copy of this software and + associated documentation files (the "Software"), to deal in the Software without restriction, + including without limitation the rights to use, copy, modify, merge, publish, distribute, + sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all copies or + substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT + LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + iproute LICENSE file: Copyright (c) 2009, IIJ Innovation Institute Inc. @@ -2770,39 +2354,6 @@ iproute LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -kan-extensions LICENSE file: - - Copyright 2008-2013 Edward Kmett - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - language-javascript LICENSE file: Copyright (c)2010, Alan Zimmerman @@ -2836,42 +2387,9 @@ language-javascript LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -lens LICENSE file: - - Copyright 2012-2015 Edward Kmett +lifted-base LICENSE file: - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - -lifted-base LICENSE file: - - Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg + Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg All rights reserved. Redistribution and use in source and binary forms, with or without @@ -2932,6 +2450,175 @@ memory LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +microlens LICENSE file: + + Copyright (c) 2013-2016 Edward Kmett, + 2015-2016 Artyom + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Artyom nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +microlens-ghc LICENSE file: + + Copyright (c) 2013-2016 Edward Kmett, + 2015-2016 Artyom + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Artyom nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +microlens-mtl LICENSE file: + + Copyright (c) 2013-2016 Edward Kmett, + 2015-2016 Artyom + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Artyom nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +microlens-platform LICENSE file: + + Copyright (c) 2012-2016 Edward Kmett, + 2015-2016 Artyom + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Artyom nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +microlens-th LICENSE file: + + Copyright (c) 2013-2016 Eric Mertens, Edward Kmett, Artyom + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Artyom nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + mime-types LICENSE file: Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ @@ -2955,34 +2642,6 @@ mime-types LICENSE file: OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -mmorph LICENSE file: - - Copyright (c) 2013, Gabriel Gonzalez - All rights reserved. - - Redistribution and use in source and binary forms, with or without modification, - are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, this - list of conditions and the following disclaimer in the documentation and/or - other materials provided with the distribution. - * Neither the name of Gabriel Gonzalez nor the names of other contributors may - be used to endorse or promote products derived from this software without - specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - monad-control LICENSE file: Copyright © 2010, Bas van Dijk, Anders Kaseorg @@ -3038,6 +2697,29 @@ monad-logger LICENSE file: OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +mono-traversable LICENSE file: + + Copyright (c) 2013 Michael Snoyman, http://www.fpcomplete.com/ + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + mtl LICENSE file: The Glasgow Haskell Compiler License @@ -3072,6 +2754,39 @@ mtl LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +mtl-compat LICENSE file: + + Copyright (c) 2015, Ryan Scott + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ryan Scott nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + network LICENSE file: Copyright (c) 2002-2010, The University Court of the University of Glasgow. @@ -3371,141 +3086,66 @@ pattern-arrows LICENSE file: The MIT License (MIT) - Copyright (c) 2013 Phil Freeman - - Permission is hereby granted, free of charge, to any person obtaining a copy of - this software and associated documentation files (the "Software"), to deal in - the Software without restriction, including without limitation the rights to - use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of - the Software, and to permit persons to whom the Software is furnished to do so, - subject to the following conditions: - - The above copyright notice and this permission notice shall be included in all - copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS - FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR - COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER - IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN - CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -pem LICENSE file: - - Copyright (c) 2010-2012 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - -pipes LICENSE file: - - Copyright (c) 2012-2014 Gabriel Gonzalez - All rights reserved. - - Redistribution and use in source and binary forms, with or without modification, - are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of Gabriel Gonzalez nor the names of other contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + Copyright (c) 2013 Phil Freeman - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + Permission is hereby granted, free of charge, to any person obtaining a copy of + this software and associated documentation files (the "Software"), to deal in + the Software without restriction, including without limitation the rights to + use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of + the Software, and to permit persons to whom the Software is furnished to do so, + subject to the following conditions: -pipes-http LICENSE file: + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. - Copyright (c) 2016 Gabriel Gonzalez - All rights reserved. + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS + FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR + COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER + IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - Redistribution and use in source and binary forms, with or without modification, - are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of Gabriel Gonzalez nor the names of other contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. +pretty LICENSE file: - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + This library (libraries/pretty) is derived from code from + the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below). -prelude-extras LICENSE file: + ----------------------------------------------------------------------------- - Copyright 2011-2016 Edward Kmett + The Glasgow Haskell Compiler License + Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: + modification, are permitted provided that the following conditions are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. + + ----------------------------------------------------------------------------- primitive LICENSE file: @@ -3606,42 +3246,9 @@ process LICENSE file: ----------------------------------------------------------------------------- -profunctors LICENSE file: - - Copyright 2011-2015 Edward Kmett - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - protolude LICENSE file: - Copyright (c) 2016, Stephen Diehl + Copyright (c) 2016-2017, Stephen Diehl Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to @@ -3761,40 +3368,6 @@ random LICENSE file: ----------------------------------------------------------------------------- -reflection LICENSE file: - - Copyright (c) 2009-2013 Edward Kmett - Copyright (c) 2004 Oleg Kiselyov and Chung-chieh Shan - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are - met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Edward Kmett nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - regex-base LICENSE file: This modile is under this "3 clause" BSD license: @@ -3860,7 +3433,7 @@ resourcet LICENSE file: safe LICENSE file: - Copyright Neil Mitchell 2007-2016. + Copyright Neil Mitchell 2007-2018. All rights reserved. Redistribution and use in source and binary forms, with or without @@ -3924,35 +3497,6 @@ scientific LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -semigroupoids LICENSE file: - - Copyright 2011-2015 Edward Kmett - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - semigroups LICENSE file: Copyright 2011-2015 Edward Kmett @@ -4014,36 +3558,6 @@ simple-sendfile LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -socks LICENSE file: - - Copyright (c) 2010-2011 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - sourcemap LICENSE file: Copyright (c) 2012, Chris Done @@ -4077,39 +3591,6 @@ sourcemap LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -spdx LICENSE file: - - Copyright (c) 2015, Oleg Grenrus - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Oleg Grenrus nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - split LICENSE file: Copyright (c) 2008 Brent Yorgey, Louis Wasserman @@ -4390,7 +3871,7 @@ tagged LICENSE file: tagsoup LICENSE file: - Copyright Neil Mitchell 2006-2016. + Copyright Neil Mitchell 2006-2018. All rights reserved. Redistribution and use in source and binary forms, with or without @@ -4512,6 +3993,22 @@ text LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +th-abstraction LICENSE file: + + Copyright (c) 2017 Eric Mertens + + Permission to use, copy, modify, and/or distribute this software for any purpose + with or without fee is hereby granted, provided that the above copyright notice + and this permission notice appear in all copies. + + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH + REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, + INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS + OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER + TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF + THIS SOFTWARE. + time LICENSE file: TimeLib is Copyright (c) Ashley Yakeley, 2004-2014. All rights reserved. @@ -4525,35 +4022,38 @@ time LICENSE file: THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -tls LICENSE file: +time-locale-compat LICENSE file: - Copyright (c) 2010-2015 Vincent Hanquez + Copyright (c) 2014, Kei Hibino All rights reserved. Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Kei Hibino nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. transformers LICENSE file: @@ -4621,7 +4121,7 @@ transformers-base LICENSE file: transformers-compat LICENSE file: - Copyright 2012 Edward Kmett + Copyright 2012-2015 Edward Kmett All rights reserved. @@ -4652,6 +4152,29 @@ transformers-compat LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +typed-process LICENSE file: + + Copyright (c) 2016 FP Complete, https://www.fpcomplete.com/ + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + uniplate LICENSE file: Copyright Neil Mitchell 2006-2013. @@ -4783,6 +4306,29 @@ unix-time LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +unliftio-core LICENSE file: + + Copyright (c) 2017 FP Complete + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be included + in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY + CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, + TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE + SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + unordered-containers LICENSE file: Copyright (c) 2010, Johan Tibell @@ -4843,6 +4389,37 @@ utf8-string LICENSE file: * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +uuid-types LICENSE file: + + Copyright (c) 2008, Antoine Latter + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * The names of the authors may not be used to endorse or promote + products derived from this software without specific prior written + permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED + TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + vault LICENSE file: Copyright (c)2011, Heinrich Apfelmus @@ -4909,6 +4486,75 @@ vector LICENSE file: DAMAGE. +vector-algorithms LICENSE file: + + Copyright (c) 2015 Dan Doel + Copyright (c) 2015 Tim Baumann + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + + ------------------------------------------------------------------------------ + + The code in Data.Array.Vector.Algorithms.Mutable.Optimal is adapted from a C + algorithm for the same purpose. The folowing is the copyright notice for said + C code: + + Copyright (c) 2004 Paul Hsieh + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + Neither the name of sorttest nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + void LICENSE file: Copyright 2015 Edward Kmett @@ -5154,126 +4800,6 @@ word8 LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -x509 LICENSE file: - - Copyright (c) 2010-2013 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - -x509-store LICENSE file: - - Copyright (c) 2010-2013 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - -x509-system LICENSE file: - - Copyright (c) 2010-2013 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - -x509-validation LICENSE file: - - Copyright (c) 2010-2013 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - xss-sanitize LICENSE file: The following license covers this documentation, and the source code, except diff --git a/package.yaml b/package.yaml index 2c8d2f64ac..2dbdece388 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.12.1' +version: '0.12.2' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 3fb37ee34df9a9327f1dbcd8642ab025d5f5c771 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 14 Jan 2019 16:34:37 +0000 Subject: [PATCH 1048/1580] Fix: ado notation breaks docs generation (#3514) Fixes #3414 --- src/Language/PureScript/Docs/Convert.hs | 1 + tests/TestDocs.hs | 5 +++++ tests/purs/docs/src/Ado.purs | 9 +++++++++ 3 files changed, 15 insertions(+) create mode 100644 tests/purs/docs/src/Ado.purs diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 1acbadddbd..e3c102fb3f 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -249,6 +249,7 @@ partiallyDesugar = P.evalSupplyT 0 . desugar' where desugar' = traverse P.desugarDoModule + >=> traverse P.desugarAdoModule >=> map P.desugarLetPatternModule >>> traverse P.desugarCasesModule >=> traverse P.desugarTypeDeclarationsModule diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 3ca26f126b..7a2ba813b0 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -643,6 +643,11 @@ testCases = , ("DeclOrderNoExportList", shouldBeOrdered (n "DeclOrderNoExportList") [ "x1", "x3", "X2", "X4", "A", "B" ]) + + , ("Ado", + [ ValueShouldHaveTypeSignature (n "Ado") "test" (renderedType "Int") + ] + ) ] where diff --git a/tests/purs/docs/src/Ado.purs b/tests/purs/docs/src/Ado.purs new file mode 100644 index 0000000000..8b8a1af223 --- /dev/null +++ b/tests/purs/docs/src/Ado.purs @@ -0,0 +1,9 @@ +-- See https://github.com/purescript/purescript/issues/3414 +module Ado where + +test = + ado x <- 1 + in x + + where + map f x = f x From 1067d84d0119de3a5d17452b49a2a612d8b7c052 Mon Sep 17 00:00:00 2001 From: Colin Wahl Date: Fri, 18 Jan 2019 09:07:24 -0800 Subject: [PATCH 1049/1580] add better positions for UnknownName errors for types/kinds (#3516) --- src/Language/PureScript/Sugar/Names.hs | 71 +++++++++++++------------- 1 file changed, 35 insertions(+), 36 deletions(-) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 22961398d2..0c2fe4d9a7 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -193,20 +193,20 @@ renameInModule imports (Module modSS coms mn decls exps) = :: [Ident] -> Declaration -> m ([Ident], Declaration) - updateDecl bound (DataDeclaration sa@(ss, _) dtype name args dctors) = + updateDecl bound (DataDeclaration sa dtype name args dctors) = fmap (bound,) $ DataDeclaration sa dtype name - <$> updateTypeArguments ss args - <*> traverse (sndM (traverse (updateTypesEverywhere ss))) dctors - updateDecl bound (TypeSynonymDeclaration sa@(ss, _) name ps ty) = + <$> updateTypeArguments args + <*> traverse (sndM (traverse updateTypesEverywhere)) dctors + updateDecl bound (TypeSynonymDeclaration sa name ps ty) = fmap (bound,) $ TypeSynonymDeclaration sa name - <$> updateTypeArguments ss ps - <*> updateTypesEverywhere ss ty + <$> updateTypeArguments ps + <*> updateTypesEverywhere ty updateDecl bound (TypeClassDeclaration sa@(ss, _) className args implies deps ds) = fmap (bound,) $ TypeClassDeclaration sa className - <$> updateTypeArguments ss args + <$> updateTypeArguments args <*> updateConstraints ss implies <*> pure deps <*> pure ds @@ -215,20 +215,20 @@ renameInModule imports (Module modSS coms mn decls exps) = TypeInstanceDeclaration sa ch idx name <$> updateConstraints ss cs <*> updateClassName cn ss - <*> traverse (updateTypesEverywhere ss) ts + <*> traverse updateTypesEverywhere ts <*> pure ds - updateDecl bound (TypeDeclaration (TypeDeclarationData sa@(ss, _) name ty)) = + updateDecl bound (TypeDeclaration (TypeDeclarationData sa name ty)) = fmap (bound,) $ TypeDeclaration . TypeDeclarationData sa name - <$> updateTypesEverywhere ss ty - updateDecl bound (ExternDeclaration sa@(ss, _) name ty) = + <$> updateTypesEverywhere ty + updateDecl bound (ExternDeclaration sa name ty) = fmap (name : bound,) $ ExternDeclaration sa name - <$> updateTypesEverywhere ss ty - updateDecl bound (ExternDataDeclaration sa@(ss, _) name ki) = + <$> updateTypesEverywhere ty + updateDecl bound (ExternDataDeclaration sa name ki) = fmap (bound,) $ ExternDataDeclaration sa name - <$> updateKindsEverywhere ss ki + <$> updateKindsEverywhere ki updateDecl bound (TypeFixityDeclaration sa@(ss, _) fixity alias op) = fmap (bound,) $ TypeFixityDeclaration sa fixity @@ -268,8 +268,8 @@ renameInModule imports (Module modSS coms mn decls exps) = (,) (ss, bound) <$> (Op ss <$> updateValueOpName op ss) updateValue (_, bound) (Constructor ss name) = (,) (ss, bound) <$> (Constructor ss <$> updateDataConstructorName name ss) - updateValue s@(pos, _) (TypedValue check val ty) = - (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty) + updateValue s (TypedValue check val ty) = + (,) s <$> (TypedValue check val <$> updateTypesEverywhere ty) updateValue s v = return (s, v) updateBinder @@ -282,8 +282,8 @@ renameInModule imports (Module modSS coms mn decls exps) = (,) (ss, bound) <$> (ConstructorBinder ss <$> updateDataConstructorName name ss <*> pure b) updateBinder (_, bound) (OpBinder ss op) = (,) (ss, bound) <$> (OpBinder ss <$> updateValueOpName op ss) - updateBinder s@(pos, _) (TypedBinder t b) = do - t' <- updateTypesEverywhere pos t + updateBinder s (TypedBinder t b) = do + t' <- updateTypesEverywhere t return (s, TypedBinder t' b) updateBinder s v = return (s, v) @@ -306,37 +306,36 @@ renameInModule imports (Module modSS coms mn decls exps) = letBoundVariable :: Declaration -> Maybe Ident letBoundVariable = fmap valdeclIdent . getValueDeclaration - updateKindsEverywhere :: SourceSpan -> Kind a -> m (Kind a) - updateKindsEverywhere pos = everywhereOnKindsM updateKind + updateKindsEverywhere :: SourceKind -> m SourceKind + updateKindsEverywhere = everywhereOnKindsM updateKind where - updateKind :: Kind a -> m (Kind a) - updateKind (NamedKind ann name) = NamedKind ann <$> updateKindName name pos + updateKind :: SourceKind -> m SourceKind + updateKind (NamedKind ann@(ss, _) name) = NamedKind ann <$> updateKindName name ss updateKind k = return k updateTypeArguments :: (Traversable f, Traversable g) - => SourceSpan - -> f (a, g (Kind ann)) -> m (f (a, g (Kind ann))) - updateTypeArguments pos = traverse (sndM (traverse (updateKindsEverywhere pos))) + => f (a, g SourceKind) -> m (f (a, g SourceKind)) + updateTypeArguments = traverse (sndM (traverse updateKindsEverywhere)) - updateTypesEverywhere :: SourceSpan -> Type a -> m (Type a) - updateTypesEverywhere pos = everywhereOnTypesM updateType + updateTypesEverywhere :: SourceType -> m SourceType + updateTypesEverywhere = everywhereOnTypesM updateType where - updateType :: Type a -> m (Type a) - updateType (TypeOp ann name) = TypeOp ann <$> updateTypeOpName name pos - updateType (TypeConstructor ann name) = TypeConstructor ann <$> updateTypeName name pos + updateType :: SourceType -> m SourceType + updateType (TypeOp ann@(ss, _) name) = TypeOp ann <$> updateTypeOpName name ss + updateType (TypeConstructor ann@(ss, _) name) = TypeConstructor ann <$> updateTypeName name ss updateType (ConstrainedType ann c t) = ConstrainedType ann <$> updateInConstraint c <*> pure t - updateType (KindedType ann t k) = KindedType ann t <$> updateKindsEverywhere pos k + updateType (KindedType ann t k) = KindedType ann t <$> updateKindsEverywhere k updateType t = return t - updateInConstraint :: Constraint a -> m (Constraint a) - updateInConstraint (Constraint ann name ts info) = - Constraint ann <$> updateClassName name pos <*> pure ts <*> pure info + updateInConstraint :: SourceConstraint -> m SourceConstraint + updateInConstraint (Constraint ann@(ss, _) name ts info) = + Constraint ann <$> updateClassName name ss <*> pure ts <*> pure info - updateConstraints :: SourceSpan -> [Constraint a] -> m [Constraint a] + updateConstraints :: SourceSpan -> [SourceConstraint] -> m [SourceConstraint] updateConstraints pos = traverse $ \(Constraint ann name ts info) -> Constraint ann <$> updateClassName name pos - <*> traverse (updateTypesEverywhere pos) ts + <*> traverse updateTypesEverywhere ts <*> pure info updateTypeName From 5a5a9190b89cd11eb86556c96f85de88df9b5880 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Thu, 31 Jan 2019 00:58:40 +0100 Subject: [PATCH 1050/1580] Turn License generator into a proper stack script (#3513) * ignore the rts "library" for licenses * make license generator into a proper stack script * stack ls dependencies instead of stack list-dependencies --- license-generator/generate.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/license-generator/generate.hs b/license-generator/generate.hs index e9c2a29fc1..1fa427cc18 100644 --- a/license-generator/generate.hs +++ b/license-generator/generate.hs @@ -1,3 +1,6 @@ +#!/usr/bin/env stack +-- stack --resolver lts-12.0 script + {-# LANGUAGE TupleSections #-} -- | -- A small script which regenerates the LICENSE file with all @@ -6,7 +9,7 @@ -- -- It is recommended to run this as follows: -- --- stack list-dependencies --flag purescript:RELEASE | stack exec runhaskell license-generator/generate.hs > LICENSE +-- stack ls dependencies --flag purescript:RELEASE | stack license-generator/generate.hs > LICENSE -- module Main (main) where @@ -56,7 +59,7 @@ depsNamesAndVersions :: IO [(String, String)] depsNamesAndVersions = do contents <- lines <$> getContents deps <- traverse parse contents - pure (filter ((/= "purescript") . fst) deps) + pure (filter (\(name, _) -> name /= "purescript" && name /= "rts") deps) where parse line = From a74fa7b51081abe22f5c9568a9eebc5d9f46ddfe Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 7 Feb 2019 18:25:09 +0000 Subject: [PATCH 1051/1580] Add the module from which something was imported to ReExportRefs (#3521) Implements what was discussed in #2191 by adding the module from which something was imported to the `ReExportRef` in the externs files. This is a first step towards #3503 (and also removing Docs.Convert.ReExports), but might also be useful for purs repl and/or purs ide? --- src/Language/PureScript/AST/Declarations.hs | 10 +- .../PureScript/Docs/Convert/ReExports.hs | 4 +- src/Language/PureScript/Ide/Externs.hs | 2 +- src/Language/PureScript/Linter/Imports.hs | 2 +- src/Language/PureScript/Sugar/Names.hs | 38 ++++--- src/Language/PureScript/Sugar/Names/Env.hs | 90 +++++++++------- .../PureScript/Sugar/Names/Exports.hs | 101 +++++++++--------- .../PureScript/Sugar/Names/Imports.hs | 14 +-- 8 files changed, 146 insertions(+), 115 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 8dab6dee15..53bb061486 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -308,7 +308,7 @@ data DeclarationRef -- A value re-exported from another module. These will be inserted during -- elaboration in name desugaring. -- - | ReExportRef SourceSpan ModuleName DeclarationRef + | ReExportRef SourceSpan ExportSource DeclarationRef deriving (Show, Generic, NFData) instance Eq DeclarationRef where @@ -323,6 +323,13 @@ instance Eq DeclarationRef where (ReExportRef _ mn ref) == (ReExportRef _ mn' ref') = mn == mn' && ref == ref' _ == _ = False +data ExportSource = + ExportSource + { exportSourceImportedFrom :: Maybe ModuleName + , exportSourceDefinedIn :: ModuleName + } + deriving (Eq, Ord, Show, Generic, NFData) + -- enable sorting lists of explicitly imported refs when suggesting imports in linting, IDE, etc. -- not an Ord because this implementation is not consistent with its Eq instance. -- think of it as a notion of contextual, not inherent, ordering. @@ -902,6 +909,7 @@ newtype AssocList k t = AssocList { runAssocList :: [(k, t)] } $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExportSource) isTrueExpr :: Expr -> Bool isTrueExpr (Literal _ (BooleanLiteral True)) = True diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 980af53d4c..0410e84b78 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -124,10 +124,10 @@ collectDeclarations imports exports = do :: (Eq a, Show a) => (P.ModuleName -> a -> m (P.ModuleName, [b])) -> [P.ImportRecord a] - -> Map a P.ModuleName + -> Map a P.ExportSource -> m (Map P.ModuleName [b]) collect lookup' imps exps = do - imps' <- traverse (findImport imps) $ Map.toList exps + imps' <- traverse (findImport imps) $ Map.toList $ fmap P.exportSourceDefinedIn exps Map.fromListWith (<>) <$> traverse (uncurry lookup') imps' expVals = P.exportedValues exports diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 0b1c39a5cc..8fcee52b0e 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -119,7 +119,7 @@ data ToResolve | SynonymToResolve (P.ProperName 'P.TypeName) P.SourceType convertExport :: P.DeclarationRef -> Maybe (P.ModuleName, P.DeclarationRef) -convertExport (P.ReExportRef _ m r) = Just (m, r) +convertExport (P.ReExportRef _ src r) = Just (P.exportSourceDefinedIn src, r) convertExport _ = Nothing convertDecl :: P.ExternsDeclaration -> Either ToResolve (Maybe IdeDeclaration) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index bfb0f9dbc3..3aa8bf6787 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -299,7 +299,7 @@ lintImportDecl env mni qualifierName names ss declType allowImplicit = dtys :: ModuleName - -> M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) + -> M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource) dtys mn = maybe M.empty exportedTypes $ envModuleExports <$> mn `M.lookup` env dctorsForType diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 0c2fe4d9a7..8348563390 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -73,34 +73,42 @@ desugarImportsWithEnv externs modules = do return $ M.insert efModuleName (efSourceSpan, imps, exps) env where - exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) + -- An ExportSource for declarations local to the module which the given + -- ExternsFile corresponds to. + localExportSource = + ExportSource { exportSourceDefinedIn = efModuleName + , exportSourceImportedFrom = Nothing + } + + exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource) exportedTypes = M.fromList $ mapMaybe toExportedType efExports where - toExportedType (TypeRef _ tyCon dctors) = Just (tyCon, (fromMaybe (mapMaybe forTyCon efDeclarations) dctors, efModuleName)) + toExportedType (TypeRef _ tyCon dctors) = Just (tyCon, (fromMaybe (mapMaybe forTyCon efDeclarations) dctors, localExportSource)) where forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName) forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn forTyCon _ = Nothing toExportedType _ = Nothing - exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName + exportedTypeOps :: M.Map (OpName 'TypeOpName) ExportSource exportedTypeOps = exportedRefs getTypeOpRef - exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName + exportedTypeClasses :: M.Map (ProperName 'ClassName) ExportSource exportedTypeClasses = exportedRefs getTypeClassRef - exportedValues :: M.Map Ident ModuleName + exportedValues :: M.Map Ident ExportSource exportedValues = exportedRefs getValueRef - exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName + exportedValueOps :: M.Map (OpName 'ValueOpName) ExportSource exportedValueOps = exportedRefs getValueOpRef - exportedRefs :: Ord a => (DeclarationRef -> Maybe a) -> M.Map a ModuleName - exportedRefs f = M.fromList $ (, efModuleName) <$> mapMaybe f efExports - - exportedKinds :: M.Map (ProperName 'KindName) ModuleName + exportedKinds :: M.Map (ProperName 'KindName) ExportSource exportedKinds = exportedRefs getKindRef + exportedRefs :: Ord a => (DeclarationRef -> Maybe a) -> M.Map a ExportSource + exportedRefs f = + M.fromList $ (, localExportSource) <$> mapMaybe f efExports + updateEnv :: ([Module], Env) -> Module -> m ([Module], Env) updateEnv (ms, env) m@(Module ss _ mn _ refs) = do members <- findExportable m @@ -141,14 +149,14 @@ elaborateExports exps (Module ss coms mn decls refs) = elaboratedTypeRefs :: [DeclarationRef] elaboratedTypeRefs = - flip map (M.toList (exportedTypes exps)) $ \(tctor, (dctors, mn')) -> + flip map (M.toList (exportedTypes exps)) $ \(tctor, (dctors, src)) -> let ref = TypeRef ss tctor (Just dctors) - in if mn == mn' then ref else ReExportRef ss mn' ref + in if mn == exportSourceDefinedIn src then ref else ReExportRef ss src ref - go :: (a -> DeclarationRef) -> (Exports -> M.Map a ModuleName) -> [DeclarationRef] + go :: (a -> DeclarationRef) -> (Exports -> M.Map a ExportSource) -> [DeclarationRef] go toRef select = - flip map (M.toList (select exps)) $ \(export, mn') -> - if mn == mn' then toRef export else ReExportRef ss mn' (toRef export) + flip map (M.toList (select exps)) $ \(export, src) -> + if mn == exportSourceDefinedIn src then toRef export else ReExportRef ss src (toRef export) -- | -- Given a list of declarations, an original exports list, and an elaborated diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index a378000900..bdfa99155d 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -126,29 +126,29 @@ data Exports = Exports -- | -- The exported types along with the module they originally came from. -- - exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) + exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource) -- | -- The exported type operators along with the module they originally came -- from. -- - , exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName + , exportedTypeOps :: M.Map (OpName 'TypeOpName) ExportSource -- | -- The exported classes along with the module they originally came from. -- - , exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName + , exportedTypeClasses :: M.Map (ProperName 'ClassName) ExportSource -- | -- The exported values along with the module they originally came from. -- - , exportedValues :: M.Map Ident ModuleName + , exportedValues :: M.Map Ident ExportSource -- | -- The exported value operators along with the module they originally came -- from. -- - , exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName + , exportedValueOps :: M.Map (OpName 'ValueOpName) ExportSource -- | -- The exported kinds along with the module they originally came from. -- - , exportedKinds :: M.Map (ProperName 'KindName) ModuleName + , exportedKinds :: M.Map (ProperName 'KindName) ExportSource } deriving (Show) -- | @@ -239,9 +239,15 @@ mkPrimExports ts cs ks = , exportedKinds = M.fromList $ mkKindEntry `map` S.toList ks } where - mkTypeEntry (Qualified mn name) = (name, ([], fromJust mn)) - mkClassEntry (Qualified mn name) = (name, fromJust mn) - mkKindEntry (Qualified mn name) = (name, fromJust mn) + mkTypeEntry (Qualified mn name) = (name, ([], primExportSource mn)) + mkClassEntry (Qualified mn name) = (name, primExportSource mn) + mkKindEntry (Qualified mn name) = (name, primExportSource mn) + + primExportSource mn = + ExportSource + { exportSourceImportedFrom = Nothing + , exportSourceDefinedIn = fromJust mn + } -- | Environment which only contains the Prim modules. primEnv :: Env @@ -289,9 +295,9 @@ exportType -> Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] - -> ModuleName + -> ExportSource -> m Exports -exportType ss exportMode exps name dctors mn = do +exportType ss exportMode exps name dctors src = do let exTypes = exportedTypes exps exClasses = exportedTypeClasses exps dctorNameCounts :: [(ProperName 'ConstructorName, Int)] @@ -311,17 +317,20 @@ exportType ss exportMode exps name dctors mn = do when (coerceProperName dctor `M.member` exClasses) $ throwDeclConflict (DctorName dctor) (TyClassName (coerceProperName dctor)) ReExport -> do - forM_ (name `M.lookup` exTypes) $ \(_, mn') -> + let mn = exportSourceDefinedIn src + forM_ (name `M.lookup` exTypes) $ \(_, src') -> + let mn' = exportSourceDefinedIn src' in when (mn /= mn') $ throwExportConflict ss mn mn' (TyName name) forM_ dctors $ \dctor -> - forM_ ((elem dctor . fst) `find` exTypes) $ \(_, mn') -> + forM_ ((elem dctor . fst) `find` exTypes) $ \(_, src') -> + let mn' = exportSourceDefinedIn src' in when (mn /= mn') $ throwExportConflict ss mn mn' (DctorName dctor) return $ exps { exportedTypes = M.alter updateOrInsert name exTypes } where - updateOrInsert Nothing = Just (dctors, mn) - updateOrInsert (Just (dctors', _)) = Just (dctors ++ dctors', mn) + updateOrInsert Nothing = Just (dctors, src) + updateOrInsert (Just (dctors', _)) = Just (dctors ++ dctors', src) -- | -- Safely adds a type operator to some exports, returning an error if a @@ -332,10 +341,10 @@ exportTypeOp => SourceSpan -> Exports -> OpName 'TypeOpName - -> ModuleName + -> ExportSource -> m Exports -exportTypeOp ss exps op mn = do - typeOps <- addExport ss TyOpName op mn (exportedTypeOps exps) +exportTypeOp ss exps op src = do + typeOps <- addExport ss TyOpName op src (exportedTypeOps exps) return $ exps { exportedTypeOps = typeOps } -- | @@ -347,16 +356,16 @@ exportTypeClass -> ExportMode -> Exports -> ProperName 'ClassName - -> ModuleName + -> ExportSource -> m Exports -exportTypeClass ss exportMode exps name mn = do +exportTypeClass ss exportMode exps name src = do let exTypes = exportedTypes exps when (exportMode == Internal) $ do when (coerceProperName name `M.member` exTypes) $ throwDeclConflict (TyClassName name) (TyName (coerceProperName name)) when ((elem (coerceProperName name) . fst) `any` exTypes) $ throwDeclConflict (TyClassName name) (DctorName (coerceProperName name)) - classes <- addExport ss TyClassName name mn (exportedTypeClasses exps) + classes <- addExport ss TyClassName name src (exportedTypeClasses exps) return $ exps { exportedTypeClasses = classes } -- | @@ -367,10 +376,10 @@ exportValue => SourceSpan -> Exports -> Ident - -> ModuleName + -> ExportSource -> m Exports -exportValue ss exps name mn = do - values <- addExport ss IdentName name mn (exportedValues exps) +exportValue ss exps name src = do + values <- addExport ss IdentName name src (exportedValues exps) return $ exps { exportedValues = values } -- | @@ -382,10 +391,10 @@ exportValueOp => SourceSpan -> Exports -> OpName 'ValueOpName - -> ModuleName + -> ExportSource -> m Exports -exportValueOp ss exps op mn = do - valueOps <- addExport ss ValOpName op mn (exportedValueOps exps) +exportValueOp ss exps op src = do + valueOps <- addExport ss ValOpName op src (exportedValueOps exps) return $ exps { exportedValueOps = valueOps } -- | @@ -396,10 +405,10 @@ exportKind => SourceSpan -> Exports -> ProperName 'KindName - -> ModuleName + -> ExportSource -> m Exports -exportKind ss exps name mn = do - kinds <- addExport ss KiName name mn (exportedKinds exps) +exportKind ss exps name src = do + kinds <- addExport ss KiName name src (exportedKinds exps) return $ exps { exportedKinds = kinds } -- | @@ -411,16 +420,21 @@ addExport => SourceSpan -> (a -> Name) -> a - -> ModuleName - -> M.Map a ModuleName - -> m (M.Map a ModuleName) -addExport ss toName name mn exports = + -> ExportSource + -> M.Map a ExportSource + -> m (M.Map a ExportSource) +addExport ss toName name src exports = case M.lookup name exports of - Just mn' - | mn == mn' -> return exports - | otherwise -> throwExportConflict ss mn mn' (toName name) + Just src' -> + let + mn = exportSourceDefinedIn src + mn' = exportSourceDefinedIn src' + in + if mn == mn' + then return exports + else throwExportConflict ss mn mn' (toName name) Nothing -> - return $ M.insert name mn exports + return $ M.insert name src exports -- | -- Raises an error for when there is more than one definition for something. diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 8c0600a01a..7480ecc07f 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -32,29 +32,35 @@ findExportable (Module _ _ mn ds _) = updateExports' :: Exports -> Declaration -> m Exports updateExports' exps decl = rethrowWithPosition (declSourceSpan decl) $ updateExports exps decl + source = + ExportSource + { exportSourceDefinedIn = mn + , exportSourceImportedFrom = Nothing + } + updateExports :: Exports -> Declaration -> m Exports updateExports exps (TypeClassDeclaration (ss, _) tcn _ _ _ ds') = do - exps' <- rethrowWithPosition ss $ exportTypeClass ss Internal exps tcn mn + exps' <- rethrowWithPosition ss $ exportTypeClass ss Internal exps tcn source foldM go exps' ds' where - go exps'' (TypeDeclaration (TypeDeclarationData (ss', _) name _)) = exportValue ss' exps'' name mn + go exps'' (TypeDeclaration (TypeDeclarationData (ss', _) name _)) = exportValue ss' exps'' name source go _ _ = internalError "Invalid declaration in TypeClassDeclaration" updateExports exps (DataDeclaration (ss, _) _ tn _ dcs) = - exportType ss Internal exps tn (map fst dcs) mn + exportType ss Internal exps tn (map fst dcs) source updateExports exps (TypeSynonymDeclaration (ss, _) tn _ _) = - exportType ss Internal exps tn [] mn + exportType ss Internal exps tn [] source updateExports exps (ExternDataDeclaration (ss, _) tn _) = - exportType ss Internal exps tn [] mn + exportType ss Internal exps tn [] source updateExports exps (ValueDeclaration vd) = - exportValue (fst (valdeclSourceAnn vd)) exps (valdeclIdent vd) mn + exportValue (fst (valdeclSourceAnn vd)) exps (valdeclIdent vd) source updateExports exps (ValueFixityDeclaration (ss, _) _ _ op) = - exportValueOp ss exps op mn + exportValueOp ss exps op source updateExports exps (TypeFixityDeclaration (ss, _) _ _ op) = - exportTypeOp ss exps op mn + exportTypeOp ss exps op source updateExports exps (ExternDeclaration (ss, _) name _) = - exportValue ss exps name mn + exportValue ss exps name source updateExports exps (ExternKindDeclaration (ss, _) pn) = - exportKind ss exps pn mn + exportKind ss exps pn source updateExports exps _ = return exps -- | @@ -110,7 +116,7 @@ resolveExports env ss mn imps exps refs = reValues <- extract ss' isPseudo name IdentName (importedValues imps) reValueOps <- extract ss' isPseudo name ValOpName (importedValueOps imps) reKinds <- extract ss' isPseudo name KiName (importedKinds imps) - foldM (\exps' ((tctor, dctors), mn') -> exportType ss' ReExport exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors) + foldM (\exps' ((tctor, dctors), src) -> exportType ss' ReExport exps' tctor dctors src) result (resolveTypeExports reTypes reDctors) >>= flip (foldM (uncurry . exportTypeOp ss')) (map resolveTypeOp reTypeOps) >>= flip (foldM (uncurry . exportTypeClass ss' ReExport)) (map resolveClass reClasses) >>= flip (foldM (uncurry . exportValue ss')) (map resolveValue reValues) @@ -164,77 +170,69 @@ resolveExports env ss mn imps exps refs = resolveTypeExports :: [Qualified (ProperName 'TypeName)] -> [Qualified (ProperName 'ConstructorName)] - -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)] + -> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ExportSource)] resolveTypeExports tctors dctors = map go tctors where go :: Qualified (ProperName 'TypeName) - -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName) + -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ExportSource) go (Qualified (Just mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do exps' <- envModuleExports <$> mn'' `M.lookup` env - (dctors', mnOrig) <- name `M.lookup` exportedTypes exps' + (dctors', src) <- name `M.lookup` exportedTypes exps' let relevantDctors = mapMaybe (disqualifyFor (Just mn'')) dctors - return ((name, relevantDctors `intersect` dctors'), mnOrig) + return + ( (name, relevantDctors `intersect` dctors') + , src { exportSourceImportedFrom = Just mn'' } + ) go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports" -- Looks up an imported type operator and re-qualifies it with the original -- module it came from. - resolveTypeOp :: Qualified (OpName 'TypeOpName) -> (OpName 'TypeOpName, ModuleName) + resolveTypeOp :: Qualified (OpName 'TypeOpName) -> (OpName 'TypeOpName, ExportSource) resolveTypeOp op - = splitQual - . fromMaybe (internalError "Missing value in resolveValue") + = fromMaybe (internalError "Missing value in resolveValue") $ resolve exportedTypeOps op -- Looks up an imported class and re-qualifies it with the original module it -- came from. - resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ModuleName) + resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ExportSource) resolveClass className - = splitQual - . fromMaybe (internalError "Missing value in resolveClass") + = fromMaybe (internalError "Missing value in resolveClass") $ resolve exportedTypeClasses className -- Looks up an imported value and re-qualifies it with the original module it -- came from. - resolveValue :: Qualified Ident -> (Ident, ModuleName) + resolveValue :: Qualified Ident -> (Ident, ExportSource) resolveValue ident - = splitQual - . fromMaybe (internalError "Missing value in resolveValue") + = fromMaybe (internalError "Missing value in resolveValue") $ resolve exportedValues ident -- Looks up an imported operator and re-qualifies it with the original -- module it came from. - resolveValueOp :: Qualified (OpName 'ValueOpName) -> (OpName 'ValueOpName, ModuleName) + resolveValueOp :: Qualified (OpName 'ValueOpName) -> (OpName 'ValueOpName, ExportSource) resolveValueOp op - = splitQual - . fromMaybe (internalError "Missing value in resolveValueOp") + = fromMaybe (internalError "Missing value in resolveValueOp") $ resolve exportedValueOps op -- Looks up an imported kind and re-qualifies it with the original -- module it came from. - resolveKind :: Qualified (ProperName 'KindName) -> (ProperName 'KindName, ModuleName) + resolveKind :: Qualified (ProperName 'KindName) -> (ProperName 'KindName, ExportSource) resolveKind kind - = splitQual - . fromMaybe (internalError "Missing value in resolveKind") + = fromMaybe (internalError "Missing value in resolveKind") $ resolve exportedKinds kind resolve :: Ord a - => (Exports -> M.Map a ModuleName) + => (Exports -> M.Map a ExportSource) -> Qualified a - -> Maybe (Qualified a) + -> Maybe (a, ExportSource) resolve f (Qualified (Just mn'') a) = do exps' <- envModuleExports <$> mn'' `M.lookup` env - mn''' <- a `M.lookup` f exps' - return $ Qualified (Just mn''') a + src <- a `M.lookup` f exps' + return $ (a, src { exportSourceImportedFrom = Just mn'' }) resolve _ _ = internalError "Unqualified value in resolve" - -- A partial function that takes a qualified value and extracts the value and - -- qualified module components. - splitQual :: Qualified a -> (a, ModuleName) - splitQual (Qualified (Just mn'') a) = (a, mn'') - splitQual _ = internalError "Unqualified value in splitQual" - -- | -- Filters the full list of exportable values, types, and classes for a module -- based on a list of export declaration references. @@ -277,16 +275,16 @@ filterModule mn exps refs = do . mapMaybe (\ref -> (declRefSourceSpan ref,) <$> getTypeRef ref) filterTypes - :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) + :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource) -> DeclarationRef - -> m (M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)) + -> m (M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)) filterTypes result (TypeRef ss name expDcons) = case name `M.lookup` exportedTypes exps of Nothing -> throwError . errorMessage' ss . UnknownExport $ TyName name - Just (dcons, _) -> do + Just (dcons, src) -> do let expDcons' = fromMaybe dcons expDcons traverse_ (checkDcon name dcons) expDcons' - return $ M.insert name (expDcons', mn) result + return $ M.insert name (expDcons', src) result where -- Ensures a data constructor is exportable for a given type. Takes a type -- name, a list of exportable data constructors for the type, and the name of @@ -305,14 +303,17 @@ filterModule mn exps refs = do :: Ord a => (a -> Name) -> (DeclarationRef -> Maybe a) - -> (Exports -> M.Map a ModuleName) - -> M.Map a ModuleName + -> (Exports -> M.Map a ExportSource) + -> M.Map a ExportSource -> DeclarationRef - -> m (M.Map a ModuleName) + -> m (M.Map a ExportSource) filterExport toName get fromExps result ref | Just name <- get ref = case name `M.lookup` fromExps exps of - -- TODO: I'm not sure if we actually need to check mn == mn' here -gb - Just mn' | mn == mn' -> return $ M.insert name mn result - _ -> throwError . errorMessage' (declRefSourceSpan ref) . UnknownExport $ toName name + -- TODO: I'm not sure if we actually need to check that these modules + -- are the same here -gb + Just source' | mn == exportSourceDefinedIn source' -> + return $ M.insert name source' result + _ -> + throwError . errorMessage' (declRefSourceSpan ref) . UnknownExport $ toName name filterExport _ _ _ result _ = return result diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 3db7d5a3ec..4253709055 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -188,9 +188,9 @@ resolveImport importModule exps imps impQual = resolveByType return $ imp { importedValueOps = valueOps' } importRef prov imp (TypeRef ss name dctors) = do let types' = updateImports (importedTypes imp) (exportedTypes exps) snd name ss prov - let (dctorNames, mn) = allExportedDataConstructors name - dctorLookup :: M.Map (ProperName 'ConstructorName) ModuleName - dctorLookup = M.fromList $ map (, mn) dctorNames + let (dctorNames, src) = allExportedDataConstructors name + dctorLookup :: M.Map (ProperName 'ConstructorName) ExportSource + dctorLookup = M.fromList $ map (, src) dctorNames traverse_ (traverse_ $ checkDctorExists ss name dctorNames) dctors let dctors' = foldl (\m d -> updateImports m dctorLookup id d ss prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors) return $ imp { importedTypes = types', importedDataConstructors = dctors' } @@ -210,7 +210,7 @@ resolveImport importModule exps imps impQual = resolveByType -- Find all exported data constructors for a given type allExportedDataConstructors :: ProperName 'TypeName - -> ([ProperName 'ConstructorName], ModuleName) + -> ([ProperName 'ConstructorName], ExportSource) allExportedDataConstructors name = fromMaybe (internalError "Invalid state in allExportedDataConstructors") $ name `M.lookup` exportedTypes exps @@ -220,15 +220,15 @@ resolveImport importModule exps imps impQual = resolveByType :: Ord a => M.Map (Qualified a) [ImportRecord a] -> M.Map a b - -> (b -> ModuleName) + -> (b -> ExportSource) -> a -> SourceSpan -> ImportProvenance -> M.Map (Qualified a) [ImportRecord a] updateImports imps' exps' expName name ss prov = let - mnOrig = maybe (internalError "Invalid state in updateImports") expName (name `M.lookup` exps') - rec = ImportRecord (Qualified (Just importModule) name) mnOrig ss prov + src = maybe (internalError "Invalid state in updateImports") expName (name `M.lookup` exps') + rec = ImportRecord (Qualified (Just importModule) name) (exportSourceDefinedIn src) ss prov in M.alter (\currNames -> Just $ rec : fromMaybe [] currNames) From 194d8645a61001094cab5faa26c350af55709d45 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 7 Feb 2019 20:59:17 +0000 Subject: [PATCH 1052/1580] Empty commit for Travis CI From 4fffdd67a3fc351808e23adc13f70354cf3aa43b Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 10 Feb 2019 15:02:06 +0000 Subject: [PATCH 1053/1580] Simplify docs re-export handling (#3534) Follows on from #3521 by removing the use of the Env's imports and instead obtaining the same information from the Env's exports. By removing the need for the Imports values, this paves the way for using externs files to speed up docs generation and make it more resilient (see #3503). Additionally, it should offer a small performance boost immediately. This code can probably still be simplified and optimised a bit more. For example, we could use a more sensible data structure for storing Declaration values as they are constructured, in preparation for later lookups while we are adding re-exports. --- .../PureScript/Docs/Convert/ReExports.hs | 79 +++---------------- 1 file changed, 13 insertions(+), 66 deletions(-) diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 0410e84b78..1ad897ecd9 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -72,8 +72,8 @@ getReExports env mn = case Map.lookup mn env of Nothing -> internalError ("Module missing: " ++ T.unpack (P.runModuleName mn)) - Just (_, imports, exports) -> do - allExports <- runReaderT (collectDeclarations imports exports) mn + Just (_, _, exports) -> do + allExports <- runReaderT (collectDeclarations exports) mn pure (filter notLocal allExports) where @@ -100,16 +100,15 @@ getReExports env mn = -- collectDeclarations :: forall m. (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) => - P.Imports -> P.Exports -> m [(P.ModuleName, [Declaration])] -collectDeclarations imports exports = do - valsAndMembers <- collect lookupValueDeclaration impVals expVals - valOps <- collect lookupValueOpDeclaration impValOps expValOps - typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs - types <- collect lookupTypeDeclaration impTypes expTypes - typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps - kinds <- collect lookupKindDeclaration impKinds expKinds +collectDeclarations exports = do + valsAndMembers <- collect lookupValueDeclaration expVals + valOps <- collect lookupValueOpDeclaration expValOps + typeClasses <- collect lookupTypeClassDeclaration expTCs + types <- collect lookupTypeDeclaration expTypes + typeOps <- collect lookupTypeOpDeclaration expTypeOps + kinds <- collect lookupKindDeclaration expKinds (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses @@ -123,72 +122,20 @@ collectDeclarations imports exports = do collect :: (Eq a, Show a) => (P.ModuleName -> a -> m (P.ModuleName, [b])) - -> [P.ImportRecord a] -> Map a P.ExportSource -> m (Map P.ModuleName [b]) - collect lookup' imps exps = do - imps' <- traverse (findImport imps) $ Map.toList $ fmap P.exportSourceDefinedIn exps - Map.fromListWith (<>) <$> traverse (uncurry lookup') imps' + collect lookup' exps = do + let reExps = Map.toList $ Map.mapMaybe P.exportSourceImportedFrom exps + decls <- traverse (uncurry (flip lookup')) reExps + return $ Map.fromListWith (<>) decls expVals = P.exportedValues exports - impVals = concat (Map.elems (P.importedValues imports)) - expValOps = P.exportedValueOps exports - impValOps = concat (Map.elems (P.importedValueOps imports)) - expTypes = Map.map snd (P.exportedTypes exports) - impTypes = concat (Map.elems (P.importedTypes imports)) - expTypeOps = P.exportedTypeOps exports - impTypeOps = concat (Map.elems (P.importedTypeOps imports)) - expCtors = concatMap fst (Map.elems (P.exportedTypes exports)) - expTCs = P.exportedTypeClasses exports - impTCs = concat (Map.elems (P.importedTypeClasses imports)) - expKinds = P.exportedKinds exports - impKinds = concat (Map.elems (P.importedKinds imports)) - --- | --- Given a list of imported declarations (of a particular kind, ie. type, data, --- class, value, etc), and the name of an exported declaration of the same --- kind, together with the module it was originally defined in, return a tuple --- of: --- --- * the module that exported declaration was imported from (note that --- this can be different from the module it was originally defined in, if --- it is a re-export), --- * that same declaration's name. --- --- This function uses a type variable for names because we want to be able to --- instantiate @name@ as both 'P.Ident' and 'P.ProperName'. --- -findImport :: - (Show name, Eq name, MonadReader P.ModuleName m) => - [P.ImportRecord name] -> - (name, P.ModuleName) -> - m (P.ModuleName, name) -findImport imps (name, orig) = - let - matches (P.ImportRecord qual mn _ _) = P.disqualify qual == name && mn == orig - matching = filter matches imps - getQualified (P.Qualified mname _) = mname - in - case mapMaybe (getQualified . P.importName) matching of - -- A value can occur more than once if it is imported twice (eg, if it is - -- exported by A, re-exported from A by B, and C imports it from both A - -- and B). In this case, we just take its first appearance. - (importedFrom:_) -> - pure (importedFrom, name) - - -- Builtin modules do not have any Imports in the Env, and therefore must - -- be handled specially here. - [] | P.isBuiltinModuleName orig -> - pure (orig, name) - - [] -> - internalErrorInModule ("findImport: not found: " ++ show (name, orig)) lookupValueDeclaration :: (MonadState (Map P.ModuleName Module) m, From a59861782f1c6aee81efef6b6aeae437baed37bd Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 17 Feb 2019 15:16:30 +0000 Subject: [PATCH 1054/1580] Add AppVeyor build status to README.md (#3536) --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index f2239f35e0..273a88ccfe 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ A small strongly typed programming language with expressive types that compiles to JavaScript, written in and inspired by Haskell. -[![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript) +[![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript) [![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/purescript/purescript?branch=master&svg=true)](https://ci.appveyor.com/project/hdgarrood/purescript-lfgff/history) ## Language info From 22be9a7b242fd896b03bcb66aacf8ac168fc6a00 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 17 Feb 2019 15:22:13 +0000 Subject: [PATCH 1055/1580] Fix browser repl backend, fixes #3387 (#3535) Thanks to @dariooddenino for tracking down what the problem was. Co-authored-by: Dario Oddenino --- app/static/index.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/static/index.js b/app/static/index.js index e6ea3eac2b..1d0714fd71 100644 --- a/app/static/index.js +++ b/app/static/index.js @@ -18,7 +18,7 @@ var evaluate = function evaluate(js) { }; // Replace any require(...) statements with lookups on the PSCI object. var replaced = js.replace(/require\("[^"]*"\)/g, function(s) { - return "PSCI['" + s.substring(12, s.length - 2) + "']"; + return "PSCI['" + s.split('/')[1] + "']"; }); // Wrap the module and evaluate it. var wrapped = From 159b51c0afeb2c5aeedd058209308b21923def6d Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 24 Feb 2019 19:48:20 +0000 Subject: [PATCH 1056/1580] Update LICENSE (#3538) --- LICENSE | 325 ++++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 266 insertions(+), 59 deletions(-) diff --git a/LICENSE b/LICENSE index a29686db88..140efcd259 100644 --- a/LICENSE +++ b/LICENSE @@ -19,6 +19,7 @@ PureScript uses the following Haskell library packages. Their license files foll SHA aeson aeson-better-errors + alex ansi-terminal ansi-wl-pprint appar @@ -42,12 +43,12 @@ PureScript uses the following Haskell library packages. Their license files foll bytestring bytestring-builder case-insensitive - cereal cheapskate clock colour conduit conduit-extra + constraints containers cookie cryptonite @@ -63,6 +64,7 @@ PureScript uses the following Haskell library packages. Their license files foll dlist easy-file edit-distance + enclosed-exceptions entropy exceptions fast-logger @@ -72,9 +74,10 @@ PureScript uses the following Haskell library packages. Their license files foll fsnotify ghc-boot-th ghc-prim + happy hashable haskeline - hfsevents + hinotify http-date http-types http2 @@ -82,6 +85,7 @@ PureScript uses the following Haskell library packages. Their license files foll integer-logarithms iproute language-javascript + lifted-async lifted-base memory microlens @@ -113,10 +117,10 @@ PureScript uses the following Haskell library packages. Their license files foll regex-base regex-tdfa resourcet - rts safe scientific semigroups + shelly simple-sendfile sourcemap split @@ -125,6 +129,8 @@ PureScript uses the following Haskell library packages. Their license files foll streaming-commons stringsearch syb + system-fileio + system-filepath tagged tagsoup template-haskell @@ -313,6 +319,39 @@ aeson-better-errors LICENSE file: TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +alex LICENSE file: + + Copyright (c) 1995-2011, Chris Dornan and Simon Marlow + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holders, nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ansi-terminal LICENSE file: Copyright (c) 2008, Maximilian Bolingbroke @@ -1119,39 +1158,6 @@ case-insensitive LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -cereal LICENSE file: - - Copyright (c) Lennart Kolmodin, Galois, Inc. - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS - OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - cheapskate LICENSE file: Copyright (c) 2013, John MacFarlane @@ -1289,6 +1295,35 @@ conduit-extra LICENSE file: OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +constraints LICENSE file: + + Copyright 2011-2015 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + containers LICENSE file: The Glasgow Haskell Compiler License @@ -1757,6 +1792,29 @@ edit-distance LICENSE file: IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +enclosed-exceptions LICENSE file: + + Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + entropy LICENSE file: Copyright (c) Thomas DuBuisson @@ -2080,6 +2138,39 @@ ghc-prim LICENSE file: be a definition of the Haskell 98 Language. +happy LICENSE file: + + The Happy License + ----------------- + + Copyright 2001, Simon Marlow and Andy Gill. All rights reserved. + + Extensions to implement Tomita's Generalized LR parsing: + Copyright 2004, University of Durham, Paul Callaghan and Ben Medlock. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY + EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR + PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR + BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE + OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN + IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + hashable LICENSE file: Copyright Milan Straka 2010 @@ -2139,38 +2230,38 @@ haskeline LICENSE file: OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -hfsevents LICENSE file: +hinotify LICENSE file: - Copyright (c) 2012, Luite Stegeman + Copyright (c) Lennart Kolmodin All rights reserved. Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: + modification, are permitted provided that the following conditions + are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. - * Neither the name of Luite Stegeman nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. http-date LICENSE file: @@ -2387,6 +2478,39 @@ language-javascript LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +lifted-async LICENSE file: + + Copyright (c) 2012-2017, Mitsutoshi Aoe + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Mitsutoshi Aoe nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + lifted-base LICENSE file: Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg @@ -3526,6 +3650,39 @@ semigroups LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +shelly LICENSE file: + + Copyright (c) 2017, Petr Rockai + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Petr Rockai nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + simple-sendfile LICENSE file: Copyright (c) 2009, IIJ Innovation Institute Inc. @@ -3836,6 +3993,56 @@ syb LICENSE file: ----------------------------------------------------------------------------- +system-fileio LICENSE file: + + Copyright (c) 2011 John Millikin + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation + files (the "Software"), to deal in the Software without + restriction, including without limitation the rights to use, + copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following + conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES + OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT + HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, + WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + +system-filepath LICENSE file: + + Copyright (c) 2010 John Millikin + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation + files (the "Software"), to deal in the Software without + restriction, including without limitation the rights to use, + copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following + conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES + OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT + HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, + WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + tagged LICENSE file: Copyright (c) 2009-2015 Edward Kmett From b35412a9ea49a46d315a0214cd2c3908442ab7a7 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 24 Feb 2019 21:34:33 +0000 Subject: [PATCH 1057/1580] v0.12.3 --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 2dbdece388..33c3bee5b2 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.12.2' +version: '0.12.3' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From eed02fb0c1cf5ca870b473347c5449e07c5c7563 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Thu, 28 Feb 2019 21:31:35 +0100 Subject: [PATCH 1058/1580] [purs ide] Treat module declarations like any other (#3541) This means we can now complete module names with the completion API as well as being able to query for module level documentation and goto-defintion for module names --- src/Language/PureScript/Ide/Completion.hs | 1 + src/Language/PureScript/Ide/Externs.hs | 3 +- .../PureScript/Ide/Filter/Declaration.hs | 6 +++- src/Language/PureScript/Ide/Imports.hs | 6 ++-- src/Language/PureScript/Ide/SourceFile.hs | 7 +++-- src/Language/PureScript/Ide/State.hs | 29 +++++++++++++------ src/Language/PureScript/Ide/Types.hs | 12 ++++++-- src/Language/PureScript/Ide/Usage.hs | 3 ++ src/Language/PureScript/Ide/Util.hs | 2 ++ .../Language/PureScript/Ide/CompletionSpec.hs | 7 +++++ .../Language/PureScript/Ide/SourceFileSpec.hs | 6 +++- tests/Language/PureScript/Ide/Test.hs | 6 +++- .../pscide/src/CompletionSpecDocs.purs | 1 + 13 files changed, 69 insertions(+), 20 deletions(-) diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index d03ac6081f..9d49c9433e 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -121,6 +121,7 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl), mns) = IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) -> (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) P.prettyPrintKind kind) IdeDeclKind k -> (P.runProperName k, "kind") + IdeDeclModule mn -> (P.runModuleName mn, "module") complExportedFrom = mns diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 8fcee52b0e..ae5d2b5aa9 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -61,12 +61,13 @@ convertExterns :: P.ExternsFile -> ([IdeDeclarationAnn], [(P.ModuleName, P.Decla convertExterns ef = (decls, exportDecls) where - decls = map + decls = moduleDecl : map (IdeDeclarationAnn emptyAnn) (resolvedDeclarations <> operatorDecls <> tyOperatorDecls) exportDecls = mapMaybe convertExport (P.efExports ef) operatorDecls = convertOperator <$> P.efFixities ef tyOperatorDecls = convertTypeOperator <$> P.efTypeFixities ef + moduleDecl = IdeDeclarationAnn emptyAnn (IdeDeclModule (P.efModuleName ef)) (toResolve, declarations) = second catMaybes (partitionEithers (map convertDecl (P.efDeclarations ef))) diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs index f92b51e1be..f0e1bce8ba 100644 --- a/src/Language/PureScript/Ide/Filter/Declaration.hs +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -11,7 +11,8 @@ import Protolude hiding (isPrefixOf) import Data.Aeson import qualified Language.PureScript.Ide.Types as PI -data DeclarationType = Value +data DeclarationType + = Value | Type | Synonym | DataConstructor @@ -19,6 +20,7 @@ data DeclarationType = Value | ValueOperator | TypeOperator | Kind + | Module deriving (Show, Eq, Ord) instance FromJSON DeclarationType where @@ -32,6 +34,7 @@ instance FromJSON DeclarationType where "valueoperator" -> pure ValueOperator "typeoperator" -> pure TypeOperator "kind" -> pure Kind + "module" -> pure Module _ -> mzero newtype IdeDeclaration = IdeDeclaration @@ -53,3 +56,4 @@ typeDeclarationForDeclaration decl = case decl of PI.IdeDeclValueOperator _ -> IdeDeclaration ValueOperator PI.IdeDeclTypeOperator _ -> IdeDeclaration TypeOperator PI.IdeDeclKind _ -> IdeDeclaration Kind + PI.IdeDeclModule _ -> IdeDeclaration Module diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index f52cd63048..209a53e0ab 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -44,7 +44,7 @@ import Language.PureScript.Ide.State import Language.PureScript.Ide.Prim import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import Lens.Micro.Platform ((^.), (%~), ix) +import Lens.Micro.Platform ((^.), (%~), ix, has) import System.IO.UTF8 (writeUTF8FileT) import qualified Text.Parsec as Parsec @@ -194,12 +194,14 @@ addExplicitImport' decl moduleName qualifier imports = not (any (\case Import C.Prim (P.Explicit _) Nothing -> True _ -> False) imports) + -- We can't import Modules from other modules + isModule = has _IdeDeclModule decl matches (Import mn (P.Explicit _) qualifier') = mn == moduleName && qualifier == qualifier' matches _ = False freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) qualifier in - if isImplicitlyImported || isNotExplicitlyImportedFromPrim + if isImplicitlyImported || isNotExplicitlyImportedFromPrim || isModule then imports else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports where diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 37868eb786..27a1725f1d 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -59,8 +59,11 @@ parseModulesFromFiles paths = do extractAstInformation :: P.Module -> (DefinitionSites P.SourceSpan, TypeAnnotations) -extractAstInformation (P.Module _ _ _ decls _) = - let definitions = Map.fromList (concatMap extractSpans decls) +extractAstInformation (P.Module moduleSpan _ mn decls _) = + let definitions = + Map.insert + (IdeNamespaced IdeNSModule (P.runModuleName mn)) moduleSpan + (Map.fromList (concatMap extractSpans decls)) typeAnnotations = Map.fromList (extractTypeAnnotations decls) in (definitions, typeAnnotations) diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 3ab0ece73f..d29f44634c 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -224,7 +224,13 @@ resolveLocationsForModule (defs, types) decls = map convertDeclaration decls where convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn - convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' annotateFunction annotateValue annotateType annotateKind d + convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' + annotateFunction + annotateValue + annotateType + annotateKind + annotateModule + d where annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs , _annTypeAnnotation = Map.lookup x types @@ -232,15 +238,17 @@ resolveLocationsForModule (defs, types) decls = annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs}) annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSKind x) defs}) + annotateModule x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSModule x) defs}) convertDeclaration' :: (P.Ident -> IdeDeclaration -> IdeDeclarationAnn) -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> IdeDeclaration -> IdeDeclarationAnn -convertDeclaration' annotateFunction annotateValue annotateType annotateKind d = +convertDeclaration' annotateFunction annotateValue annotateType annotateKind annotateModule d = case d of IdeDeclValue v -> annotateFunction (v ^. ideValueIdent) d @@ -258,6 +266,8 @@ convertDeclaration' annotateFunction annotateValue annotateType annotateKind d = annotateType (operator ^. ideTypeOpName . opNameT) d IdeDeclKind i -> annotateKind (i ^. properNameT) d + IdeDeclModule mn -> + annotateModule (P.runModuleName mn) d resolveDocumentation :: ModuleMap P.Module @@ -271,26 +281,27 @@ resolveDocumentationForModule :: P.Module -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] -resolveDocumentationForModule (P.Module _ _ _ sdecls _) decls = map convertDecl decls - where +resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) decls = map convertDecl decls + where comments :: Map P.Name [P.Comment] - comments = Map.fromListWith (flip (<>)) $ mapMaybe (\d -> - case name d of + comments = Map.insert (P.ModName moduleName) moduleComments $ Map.fromListWith (flip (<>)) $ mapMaybe (\d -> + case name d of Just name' -> Just (name', snd $ P.declSourceAnn d) _ -> Nothing) - sdecls + sdecls name :: P.Declaration -> Maybe P.Name name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d name decl = P.declName decl convertDecl :: IdeDeclarationAnn -> IdeDeclarationAnn - convertDecl (IdeDeclarationAnn ann d) = + convertDecl (IdeDeclarationAnn ann d) = convertDeclaration' (annotateValue . P.IdentName) - (annotateValue . P.IdentName . P.Ident) + (annotateValue . P.IdentName . P.Ident) (annotateValue . P.TyName . P.ProperName) (annotateValue . P.KiName . P.ProperName) + (annotateValue . P.ModName . P.moduleNameFromString) d where docs :: P.Name -> Text diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index cb72e17bb8..82cfed9b03 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -39,6 +39,7 @@ data IdeDeclaration | IdeDeclTypeClass IdeTypeClass | IdeDeclValueOperator IdeValueOperator | IdeDeclTypeOperator IdeTypeOperator + | IdeDeclModule P.ModuleName | IdeDeclKind (P.ProperName 'P.KindName) deriving (Show, Eq, Ord, Generic, NFData) @@ -126,6 +127,10 @@ _IdeDeclKind :: Traversal' IdeDeclaration (P.ProperName 'P.KindName) _IdeDeclKind f (IdeDeclKind x) = map IdeDeclKind (f x) _IdeDeclKind _ x = pure x +_IdeDeclModule :: Traversal' IdeDeclaration P.ModuleName +_IdeDeclModule f (IdeDeclModule x) = map IdeDeclModule (f x) +_IdeDeclModule _ x = pure x + anyOf :: Getting Any s a -> (a -> Bool) -> s -> Bool anyOf g p = getAny . getConst . g (Const . Any . p) @@ -298,14 +303,15 @@ encodeImport (P.runModuleName -> mn, importType, map P.runModuleName -> qualifie ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) -- | Denotes the different namespaces a name in PureScript can reside in. -data IdeNamespace = IdeNSValue | IdeNSType | IdeNSKind +data IdeNamespace = IdeNSValue | IdeNSType | IdeNSKind | IdeNSModule deriving (Show, Eq, Ord, Generic, NFData) instance FromJSON IdeNamespace where parseJSON (String s) = case s of "value" -> pure IdeNSValue - "type" -> pure IdeNSType - "kind" -> pure IdeNSKind + "type" -> pure IdeNSType + "kind" -> pure IdeNSKind + "module" -> pure IdeNSModule _ -> mzero parseJSON _ = mzero diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index 189032909e..8db7f36f5b 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -112,6 +112,9 @@ matchesRef declaration ref = case declaration of IdeDeclKind kind -> case ref of P.KindRef _ kindName -> kindName == kind _ -> False + IdeDeclModule m -> case ref of + P.ModuleRef _ mn -> m == mn + _ -> False eligibleModules :: (P.ModuleName, IdeDeclaration) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 46824c1104..d25a8708d7 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -53,6 +53,7 @@ identifierFromIdeDeclaration d = case d of IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName IdeDeclKind name -> P.runProperName name + IdeDeclModule name -> P.runModuleName name namespaceForDeclaration :: IdeDeclaration -> IdeNamespace namespaceForDeclaration d = case d of @@ -64,6 +65,7 @@ namespaceForDeclaration d = case d of IdeDeclValueOperator _ -> IdeNSValue IdeDeclTypeOperator _ -> IdeNSType IdeDeclKind _ -> IdeNSKind + IdeDeclModule _ -> IdeNSModule discardAnn :: IdeDeclarationAnn -> IdeDeclaration discardAnn (IdeDeclarationAnn _ d) = d diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs index c9a84cfd70..0a85fda69b 100644 --- a/tests/Language/PureScript/Ide/CompletionSpec.hs +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -65,3 +65,10 @@ spec = describe "Applying completion options" $ do , typ "withType" ] result `shouldSatisfy` \res -> complDocumentation res == Just "Doc *123*\n" + + it "gets docs on module declaration" $ do + ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpecDocs"] + , typ "CompletionSpecDocs" + ] + result `shouldSatisfy` \res -> complDocumentation res == Just "Module Documentation\n" diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 2ef859e00e..20a625856c 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -93,6 +93,9 @@ spec = do it "finds a type operator declaration" $ do Just r <- getLocation "~>" r `shouldBe` typeOpSS + it "finds a module declaration" $ do + Just r <- getLocation "SfModule" + r `shouldBe` moduleSS getLocation :: Text -> IO (Maybe P.SourceSpan) getLocation s = do @@ -102,7 +105,8 @@ getLocation s = do where ideState = emptyIdeState `volatileState` [ ("Test", - [ ideValue "sfValue" Nothing `annLoc` valueSS + [ ideModule "SfModule" `annLoc` moduleSS + , ideValue "sfValue" Nothing `annLoc` valueSS , ideSynonym "SFType" Nothing Nothing `annLoc` synonymSS , ideType "SFData" Nothing [] `annLoc` typeSS , ideDtor "SFOne" "SFData" Nothing `annLoc` typeSS diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index 5cf613f2c2..6164e02722 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -101,7 +101,11 @@ ideTypeOp opName ident precedence assoc k = ideKind :: Text -> IdeDeclarationAnn ideKind pn = ida (IdeDeclKind (P.ProperName pn)) -valueSS, synonymSS, typeSS, classSS, valueOpSS, typeOpSS :: P.SourceSpan +ideModule :: Text -> IdeDeclarationAnn +ideModule name = ida (IdeDeclModule (mn name)) + +moduleSS, valueSS, synonymSS, typeSS, classSS, valueOpSS, typeOpSS :: P.SourceSpan +moduleSS = ss 1 1 valueSS = ss 3 1 synonymSS = ss 5 1 typeSS = ss 7 1 diff --git a/tests/support/pscide/src/CompletionSpecDocs.purs b/tests/support/pscide/src/CompletionSpecDocs.purs index 1c92a37752..dae3fc43c4 100644 --- a/tests/support/pscide/src/CompletionSpecDocs.purs +++ b/tests/support/pscide/src/CompletionSpecDocs.purs @@ -1,3 +1,4 @@ +-- | Module Documentation module CompletionSpecDocs where -- | Doc x From 1b626c7aeb3ea0a8df2d3bbb8c1c4f964528aa48 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 7 Mar 2019 22:43:46 +0000 Subject: [PATCH 1059/1580] Truncate types in errors, fixes #3401 (#3543) This commit truncates types in error messages below a depth of 3 levels in the type AST. If the --verbose-errors flag is provided, the truncation depth is instead set to 1000 (the same as with pretty-printing of values). Suggestions and docs code is not affected, since in both of these cases, we always want to print the entire type. In the process, I've done a minor refactoring of the PrettyPrintType type to change how rows and records are represented, to make them a little easier to deal with. --- .../Docs/RenderedCode/RenderType.hs | 29 ++-- src/Language/PureScript/Errors.hs | 104 +++++++-------- src/Language/PureScript/Ide/CaseSplit.hs | 2 +- src/Language/PureScript/Ide/Error.hs | 2 +- src/Language/PureScript/Interactive.hs | 2 +- .../PureScript/Interactive/Printer.hs | 10 +- src/Language/PureScript/Pretty/Types.hs | 125 +++++++++--------- src/Language/PureScript/Pretty/Values.hs | 6 +- tests/TestDocs.hs | 2 +- 9 files changed, 139 insertions(+), 143 deletions(-) diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index be5753dd2e..25837ecba4 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -35,18 +35,16 @@ typeLiterals = mkPattern match Just $ maybe (syntax "_") (syntax . ("?" <>)) name match (PPTypeVar var) = Just (typeVar var) - match (PPRecord row) = + match (PPRecord labels tail_) = Just $ mintersperse sp [ syntax "{" - , renderRow row + , renderRow labels tail_ , syntax "}" ] match (PPTypeConstructor n) = Just (typeCtor n) - match PPREmpty = - Just (syntax "()") - match row@PPRCons{} = - Just (syntax "(" <> renderRow row <> syntax ")") + match (PPRow labels tail_) = + Just (syntax "(" <> renderRow labels tail_ <> syntax ")") match (PPBinaryNoParensType op l r) = Just $ renderTypeAtom' l <> sp <> renderTypeAtom' op <> sp <> renderTypeAtom' r match (PPTypeOp n) = @@ -72,13 +70,8 @@ renderConstraints con ty = -- | -- Render code representing a Row -- -renderRow :: PrettyPrintType -> RenderedCode -renderRow = uncurry renderRow' . go [] - where - renderRow' h t = renderHead h <> renderTail t - - go ts (PPRCons l t r) = go ((l, t) : ts) r - go ts t = (reverse ts, t) +renderRow :: [(Label, PrettyPrintType)] -> Maybe PrettyPrintType -> RenderedCode +renderRow h t = renderHead h <> renderTail t renderHead :: [(Label, PrettyPrintType)] -> RenderedCode renderHead = mintersperse (syntax "," <> sp) . map renderLabel @@ -91,9 +84,9 @@ renderLabel (label, ty) = , renderType' ty ] -renderTail :: PrettyPrintType -> RenderedCode -renderTail PPREmpty = mempty -renderTail other = sp <> syntax "|" <> sp <> renderType' other +renderTail :: Maybe PrettyPrintType -> RenderedCode +renderTail Nothing = mempty +renderTail (Just other) = sp <> syntax "|" <> sp <> renderType' other typeApp :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType) typeApp = mkPattern match @@ -153,7 +146,7 @@ forall_ = mkPattern match -- Render code representing a Type -- renderType :: Type a -> RenderedCode -renderType = renderType' . convertPrettyPrintType +renderType = renderType' . convertPrettyPrintType maxBound renderType' :: PrettyPrintType -> RenderedCode renderType' @@ -164,7 +157,7 @@ renderType' -- Render code representing a Type, as it should appear inside parentheses -- renderTypeAtom :: Type a -> RenderedCode -renderTypeAtom = renderTypeAtom' . convertPrettyPrintType +renderTypeAtom = renderTypeAtom' . convertPrettyPrintType maxBound renderTypeAtom' :: PrettyPrintType -> RenderedCode renderTypeAtom' diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index f730b600ef..f9065bdc29 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -508,7 +508,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line "The same name was used more than once in a let binding." renderSimpleErrorMessage (InfiniteType ty) = paras [ line "An infinite type was inferred for an expression: " - , markCodeBox $ indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox prettyDepth ty ] renderSimpleErrorMessage (InfiniteKind ki) = paras [ line "An infinite kind was inferred for a type: " @@ -584,13 +584,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderSimpleErrorMessage (EscapedSkolem name Nothing ty) = paras [ line $ "The type variable " <> markCode name <> " has escaped its scope, appearing in the type" - , markCodeBox $ indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox prettyDepth ty ] renderSimpleErrorMessage (EscapedSkolem name (Just srcSpan) ty) = paras [ line $ "The type variable " <> markCode name <> ", bound at" , indent $ line $ displaySourceSpan relPath srcSpan , line "has escaped its scope, appearing in the type" - , markCodeBox $ indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox prettyDepth ty ] renderSimpleErrorMessage (TypesDoNotUnify u1 u2) = let (sorted1, sorted2) = sortRows u1 u2 @@ -610,9 +610,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , rowFromList (sort' unique2 ++ sort' common2, r2) ) in paras [ line "Could not match type" - , markCodeBox $ indent $ typeAsBox sorted1 + , markCodeBox $ indent $ typeAsBox prettyDepth sorted1 , line "with type" - , markCodeBox $ indent $ typeAsBox sorted2 + , markCodeBox $ indent $ typeAsBox prettyDepth sorted2 ] renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = @@ -623,16 +623,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) = paras [ line "Could not match constrained type" - , markCodeBox $ indent $ typeAsBox t1 + , markCodeBox $ indent $ typeAsBox prettyDepth t1 , line "with type" - , markCodeBox $ indent $ typeAsBox t2 + , markCodeBox $ indent $ typeAsBox prettyDepth t2 ] renderSimpleErrorMessage (OverlappingInstances _ _ []) = internalError "OverlappingInstances: empty instance list" renderSimpleErrorMessage (OverlappingInstances nm ts ds) = paras [ line "Overlapping type class instances found for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] , line "The following instances were found:" , indent $ paras (map (line . showQualified showIdent) ds) @@ -659,7 +659,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Discard [ty] _)) = paras [ line "A result of type" - , markCodeBox $ indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox prettyDepth ty , line "was implicitly discarded in a do notation block." , line ("You can use " <> markCode "_ <- ..." <> " to explicitly discard the result.") ] @@ -667,7 +667,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "No type class instance was found for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation." | any containsUnknowns ts @@ -681,14 +681,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl go _ = False renderSimpleErrorMessage (AmbiguousTypeVariables t _) = paras [ line "The inferred type" - , markCodeBox $ indent $ typeAsBox t + , markCodeBox $ indent $ typeAsBox prettyDepth t , line "has type variables which are not mentioned in the body of the type. Consider adding a type annotation." ] renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) = paras [ line "Type class instance for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] , line "is possibly infinite." ] @@ -696,7 +696,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "Cannot derive a type class instance for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] , line "since instances of this type class are not derivable." ] @@ -704,7 +704,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "Cannot derive newtype instance for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] , line "Make sure this is a newtype." ] @@ -712,7 +712,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "The derived newtype instance for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cl) - , Box.vcat Box.left (map typeAtomAsBox ts) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] , line $ "does not include a derived superclass instance for " <> markCode (showQualified runProperName su) <> "." ] @@ -720,7 +720,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "The derived newtype instance for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cl) - , Box.vcat Box.left (map typeAtomAsBox ts) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] , line $ "implies an superclass instance for " <> markCode (showQualified runProperName su) <> " which could not be verified." ] @@ -728,7 +728,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "Cannot derive the type class instance" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] , line $ fold $ [ "because the " @@ -744,10 +744,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "Cannot derive the type class instance" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] , "because the type" - , markCodeBox $ indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox prettyDepth ty , line "is not of the required form T a_1 ... a_n, where T is a type constructor defined in the same module." ] renderSimpleErrorMessage (CannotFindDerivingType nm) = @@ -755,7 +755,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (DuplicateLabel l expr) = paras $ [ line $ "Label " <> markCode (prettyPrintLabel l) <> " appears more than once in a row type." ] <> foldMap (\expr' -> [ line "Relevant expression: " - , markCodeBox $ indent $ prettyPrintValue valueDepth expr' + , markCodeBox $ indent $ prettyPrintValue prettyDepth expr' ]) expr renderSimpleErrorMessage (DuplicateTypeArgument name) = line $ "Type argument " <> markCode name <> " appears more than once." @@ -768,7 +768,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (MissingClassMember identsAndTypes) = paras $ [ line "The following type class members have not been implemented:" , Box.vcat Box.left - [ markCodeBox $ Box.text (T.unpack (showIdent ident)) Box.<> " :: " Box.<> typeAsBox ty + [ markCodeBox $ Box.text (T.unpack (showIdent ident)) Box.<> " :: " Box.<> typeAsBox prettyDepth ty | (ident, ty) <- NEL.toList identsAndTypes ] ] renderSimpleErrorMessage (ExtraneousClassMember ident className) = @@ -776,7 +776,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (ExpectedType ty kind) = paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode (prettyPrintKind kindType) <> "." , line "The error arises from the type" - , markCodeBox $ indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox prettyDepth ty , line "having the kind" , indent $ line $ markCode $ prettyPrintKind kind , line "instead." @@ -787,9 +787,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) = paras [ line "Expression" - , markCodeBox $ indent $ prettyPrintValue valueDepth expr + , markCodeBox $ indent $ prettyPrintValue prettyDepth expr , line "does not have type" - , markCodeBox $ indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox prettyDepth ty ] renderSimpleErrorMessage (PropertyIsMissing prop) = line $ "Type of expression lacks required label " <> markCode (prettyPrintLabel prop) <> "." @@ -801,7 +801,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line $ "Orphan instance " <> markCode (showIdent nm) <> " found for " , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm) - , Box.vcat Box.left (map typeAtomAsBox ts) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] , Box.vcat Box.left $ case modulesToList of [] -> [ line "There is nowhere this instance can be placed without being an orphan." @@ -821,7 +821,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderSimpleErrorMessage (InvalidInstanceHead ty) = paras [ line "Type class instance head is invalid due to use of type" - , markCodeBox $ indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox prettyDepth ty , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form, unless the type is fully determined by other type class arguments via functional dependencies." ] renderSimpleErrorMessage (TransitiveExportError x ys) = @@ -846,7 +846,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderSimpleErrorMessage (WildcardInferredType ty ctx) = paras $ [ line "Wildcard type definition has the inferred type " - , markCodeBox $ indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox prettyDepth ty ] <> renderContext ctx renderSimpleErrorMessage (HoleInferredType name ty ctx ts) = let @@ -858,7 +858,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl let idBoxes = Box.text . T.unpack . showQualified id <$> names tyBoxes = (\t -> BoxHelpers.indented - (Box.text ":: " Box.<> typeAsBox t)) <$> types + (Box.text ":: " Box.<> typeAsBox prettyDepth t)) <$> types longestId = maximum (map Box.cols idBoxes) in Box.vcat Box.top $ @@ -871,13 +871,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl _ -> [] in paras $ [ line $ "Hole '" <> markCode name <> "' has the inferred type " - , markCodeBox (indent (typeAsBox ty)) + , markCodeBox (indent (typeAsBox prettyDepth ty)) ] ++ tsResult ++ renderContext ctx renderSimpleErrorMessage (MissingTypeDeclaration ident ty) = paras [ line $ "No type declaration was provided for the top-level declaration of " <> markCode (showIdent ident) <> "." , line "It is good practice to provide type declarations as a form of documentation." , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:" - , markCodeBox $ indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox prettyDepth ty ] renderSimpleErrorMessage (OverlappingPattern bs b) = paras $ [ line "A case expression contains unreachable cases:\n" @@ -964,7 +964,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) = paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "." , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:" - , markCodeBox $ indent $ typeAsBox ty + , markCodeBox $ indent $ typeAsBox prettyDepth ty , line "Try adding a type signature." ] @@ -990,7 +990,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl argsMsg = if expected > 1 then "arguments" else "argument" renderSimpleErrorMessage (UserDefinedWarning msgTy) = - let msg = fromMaybe (typeAsBox msgTy) (toTypelevelString msgTy) in + let msg = fromMaybe (typeAsBox prettyDepth msgTy) (toTypelevelString msgTy) in paras [ line "A custom warning occurred while solving type class constraints:" , indent msg ] @@ -1042,16 +1042,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail , Box.hsep 1 Box.top [ line "while trying to match type" - , markCodeBox $ typeAsBox t1 + , markCodeBox $ typeAsBox prettyDepth t1 ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type" - , markCodeBox $ typeAsBox t2 + , markCodeBox $ typeAsBox prettyDepth t2 ] ] renderHint (ErrorInExpression expr) detail = paras [ detail , Box.hsep 1 Box.top [ Box.text "in the expression" - , markCodeBox $ markCodeBox $ prettyPrintValue valueDepth expr + , markCodeBox $ markCodeBox $ prettyPrintValue prettyDepth expr ] ] renderHint (ErrorInModule mn) detail = @@ -1061,10 +1061,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderHint (ErrorInSubsumption t1 t2) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking that type" - , markCodeBox $ typeAsBox t1 + , markCodeBox $ typeAsBox prettyDepth t1 ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "is at least as general as type" - , markCodeBox $ typeAsBox t2 + , markCodeBox $ typeAsBox prettyDepth t2 ] ] renderHint (ErrorInInstance nm ts) detail = @@ -1072,13 +1072,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , line "in type class instance" , markCodeBox $ indent $ Box.hsep 1 Box.top [ line $ showQualified runProperName nm - , Box.vcat Box.left (map typeAtomAsBox ts) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] ] renderHint (ErrorCheckingKind ty) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking the kind of" - , markCodeBox $ typeAsBox ty + , markCodeBox $ typeAsBox prettyDepth ty ] ] renderHint ErrorCheckingGuard detail = @@ -1088,34 +1088,34 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderHint (ErrorInferringType expr) detail = paras [ detail , Box.hsep 1 Box.top [ line "while inferring the type of" - , markCodeBox $ prettyPrintValue valueDepth expr + , markCodeBox $ prettyPrintValue prettyDepth expr ] ] renderHint (ErrorCheckingType expr ty) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking that expression" - , markCodeBox $ prettyPrintValue valueDepth expr + , markCodeBox $ prettyPrintValue prettyDepth expr ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type" - , markCodeBox $ typeAsBox ty + , markCodeBox $ typeAsBox prettyDepth ty ] ] renderHint (ErrorCheckingAccessor expr prop) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking type of property accessor" - , markCodeBox $ prettyPrintValue valueDepth (Accessor prop expr) + , markCodeBox $ prettyPrintValue prettyDepth (Accessor prop expr) ] ] renderHint (ErrorInApplication f t a) detail = paras [ detail , Box.hsep 1 Box.top [ line "while applying a function" - , markCodeBox $ prettyPrintValue valueDepth f + , markCodeBox $ prettyPrintValue prettyDepth f ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type" - , markCodeBox $ typeAsBox t + , markCodeBox $ typeAsBox prettyDepth t ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument" - , markCodeBox $ prettyPrintValue valueDepth a + , markCodeBox $ prettyPrintValue prettyDepth a ] ] renderHint (ErrorInDataConstructor nm) detail = @@ -1159,7 +1159,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , line "while solving type class constraint" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map typeAtomAsBox ts) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] ] renderHint (PositionedError srcSpan) detail = @@ -1173,7 +1173,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl [ line "in the following context:" , indent $ paras [ Box.hcat Box.left [ Box.text (T.unpack (showIdent ident) ++ " :: ") - , markCodeBox $ typeAsBox ty' + , markCodeBox $ typeAsBox prettyDepth ty' ] | (ident, ty') <- take 5 ctx ] @@ -1212,9 +1212,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl runName (Qualified _ ModName{}) = internalError "qualified ModName in runName" - valueDepth :: Int - valueDepth | full = 1000 - | otherwise = 3 + prettyDepth :: Int + prettyDepth | full = 1000 + | otherwise = 3 levelText :: Text levelText = case level of @@ -1420,7 +1420,7 @@ toTypelevelString (TypeLevelString _ s) = toTypelevelString (TypeApp _ (TypeConstructor _ f) x) | f == primSubName C.typeError "Text" = toTypelevelString x toTypelevelString (TypeApp _ (TypeConstructor _ f) x) - | f == primSubName C.typeError "Quote" = Just (typeAsBox x) + | f == primSubName C.typeError "Quote" = Just (typeAsBox maxBound x) toTypelevelString (TypeApp _ (TypeConstructor _ f) (TypeLevelString _ x)) | f == primSubName C.typeError "QuoteLabel" = Just . line . prettyPrintLabel . Label $ x toTypelevelString (TypeApp _ (TypeApp _ (TypeConstructor _ f) x) ret) diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 90f1da0adc..7596c5e396 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -93,7 +93,7 @@ prettyPrintWildcard (WildcardAnnotations True) = prettyWildcard prettyPrintWildcard (WildcardAnnotations False) = const "_" prettyWildcard :: P.Type a -> Text -prettyWildcard t = "( _ :: " <> T.strip (T.pack (P.prettyPrintTypeAtom t)) <> ")" +prettyWildcard t = "( _ :: " <> T.strip (T.pack (P.prettyPrintTypeAtom maxBound t)) <> ")" -- | Constructs Patterns to insert into a sourcefile makePattern :: Text -- ^ Current line diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 93d8be989a..3a3645a804 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -83,4 +83,4 @@ textError (ParseError parseError msg) = let escape = show textError (RebuildError err) = show err prettyPrintTypeSingleLine :: P.Type a -> Text -prettyPrintTypeSingleLine = T.unwords . map T.strip . T.lines . T.pack . P.prettyPrintTypeWithUnicode +prettyPrintTypeSingleLine = T.unwords . map T.strip . T.lines . T.pack . P.prettyPrintTypeWithUnicode maxBound diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 856f02803d..fb4f45aaa9 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -274,7 +274,7 @@ handleTypeOf print' val = do Left errs -> printErrors errs Right (_, env') -> case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName [P.ProperName "$PSCI"])) (P.names env') of - Just (ty, _, _) -> print' . P.prettyPrintType $ ty + Just (ty, _, _) -> print' . P.prettyPrintType maxBound $ ty Nothing -> print' "Could not find type" -- | Takes a type and prints its kind diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index 7d35b08147..8a7dce4db6 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -43,7 +43,7 @@ printModuleSignatures moduleName P.Environment{..} = findNameType envNames m = (P.disqualify m, M.lookup m envNames) showNameType :: (P.Ident, Maybe (P.SourceType, P.NameKind, P.NameVisibility)) -> Box.Box - showNameType (mIdent, Just (mType, _, _)) = textT (P.showIdent mIdent <> " :: ") Box.<> P.typeAsBox mType + showNameType (mIdent, Just (mType, _, _)) = textT (P.showIdent mIdent <> " :: ") Box.<> P.typeAsBox maxBound mType showNameType _ = P.internalError "The impossible happened in printModuleSignatures." findTypeClass @@ -61,13 +61,13 @@ printModuleSignatures moduleName P.Environment{..} = if null typeClassSuperclasses then Box.text "" else Box.text "(" - Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint _ (P.Qualified _ pn) lt _) -> textT (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) typeClassSuperclasses) + Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint _ (P.Qualified _ pn) lt _) -> textT (P.runProperName pn) Box.<+> Box.hcat Box.left (map (P.typeAtomAsBox maxBound) lt)) typeClassSuperclasses) Box.<> Box.text ") <= " className = textT (P.runProperName name) Box.<> textT (foldMap ((" " <>) . fst) typeClassArguments) classBody = - Box.vcat Box.top (map (\(i, t) -> textT (P.showIdent i <> " ::") Box.<+> P.typeAsBox t) typeClassMembers) + Box.vcat Box.top (map (\(i, t) -> textT (P.showIdent i <> " ::") Box.<+> P.typeAsBox maxBound t) typeClassMembers) in Just $ @@ -99,7 +99,7 @@ printModuleSignatures moduleName P.Environment{..} = else Just $ textT ("type " <> P.runProperName name <> foldMap ((" " <>) . fst) typevars) - Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType) + Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox maxBound dtType) (Just (_, P.DataType typevars pt), _) -> let prefix = @@ -122,7 +122,7 @@ printModuleSignatures moduleName P.Environment{..} = mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $ map (\(cons,idents) -> (textT (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt - prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t + prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox maxBound t mapFirstRest _ _ [] = [] mapFirstRest f g (x:xs) = f x : map g xs diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 531bffd8e3..dc6f84cdd2 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -6,15 +6,12 @@ module Language.PureScript.Pretty.Types , PrettyPrintConstraint , convertPrettyPrintType , typeAsBox - , typeAsBox' , suggestedTypeAsBox , prettyPrintType , prettyPrintTypeWithUnicode , prettyPrintSuggestedType , typeAtomAsBox - , typeAtomAsBox' , prettyPrintTypeAtom - , prettyPrintRow , prettyPrintLabel , prettyPrintObjectKey ) where @@ -56,35 +53,44 @@ data PrettyPrintType | PPParensInType PrettyPrintType | PPForAll [Text] PrettyPrintType | PPFunction PrettyPrintType PrettyPrintType - | PPRecord PrettyPrintType - | PPRCons Label PrettyPrintType PrettyPrintType - | PPREmpty + | PPRecord [(Label, PrettyPrintType)] (Maybe PrettyPrintType) + | PPRow [(Label, PrettyPrintType)] (Maybe PrettyPrintType) + | PPTruncated type PrettyPrintConstraint = (Qualified (ProperName 'ClassName), [PrettyPrintType]) -convertPrettyPrintType :: Type a -> PrettyPrintType +convertPrettyPrintType :: Int -> Type a -> PrettyPrintType convertPrettyPrintType = go where - go (TUnknown _ n) = PPTUnknown n - go (TypeVar _ t) = PPTypeVar t - go (TypeLevelString _ s) = PPTypeLevelString s - go (TypeWildcard _ n) = PPTypeWildcard n - go (TypeConstructor _ c) = PPTypeConstructor c - go (TypeOp _ o) = PPTypeOp o - go (Skolem _ t n _) = PPSkolem t n - go (ConstrainedType _ (Constraint _ cls args _) ty) = PPConstrainedType (cls, go <$> args) (go ty) - go (KindedType _ ty k) = PPKindedType (go ty) (k $> ()) - go (BinaryNoParensType _ ty1 ty2 ty3) = PPBinaryNoParensType (go ty1) (go ty2) (go ty3) - go (ParensInType _ ty) = PPParensInType (go ty) - go (REmpty _) = PPREmpty - go (RCons _ l ty1 ty2) = PPRCons l (go ty1) (go ty2) - go (ForAll _ v ty _) = goForAll [v] ty - go (TypeApp _ (TypeApp _ f arg) ret) | eqType f tyFunction = PPFunction (go arg) (go ret) - go (TypeApp _ o r) | eqType o tyRecord = PPRecord (go r) - go (TypeApp _ a b) = PPTypeApp (go a) (go b) - - goForAll vs (ForAll _ v ty _) = goForAll (v : vs) ty - goForAll vs ty = PPForAll vs (go ty) + go d _ | d < 0 = PPTruncated + go _ (TUnknown _ n) = PPTUnknown n + go _ (TypeVar _ t) = PPTypeVar t + go _ (TypeLevelString _ s) = PPTypeLevelString s + go _ (TypeWildcard _ n) = PPTypeWildcard n + go _ (TypeConstructor _ c) = PPTypeConstructor c + go _ (TypeOp _ o) = PPTypeOp o + go _ (Skolem _ t n _) = PPSkolem t n + go d (ConstrainedType _ (Constraint _ cls args _) ty) = PPConstrainedType (cls, go (d-1) <$> args) (go (d-1) ty) + go d (KindedType _ ty k) = PPKindedType (go (d-1) ty) (k $> ()) + go d (BinaryNoParensType _ ty1 ty2 ty3) = PPBinaryNoParensType (go (d-1) ty1) (go (d-1) ty2) (go (d-1) ty3) + go d (ParensInType _ ty) = PPParensInType (go (d-1) ty) + go _ (REmpty _) = PPRow [] Nothing + go d ty@RCons{} = uncurry PPRow (goRow d ty) + go d (ForAll _ v ty _) = goForAll d [v] ty + go d (TypeApp _ (TypeApp _ f arg) ret) | eqType f tyFunction = PPFunction (go (d-1) arg) (go (d-1) ret) + go d (TypeApp _ o ty@RCons{}) | eqType o tyRecord = uncurry PPRecord (goRow d ty) + go d (TypeApp _ a b) = PPTypeApp (go (d-1) a) (go (d-1) b) + + goForAll d vs (ForAll _ v ty _) = goForAll d (v : vs) ty + goForAll d vs ty = PPForAll vs (go (d-1) ty) + + goRow d ty = + let (items, tail_) = rowToSortedList ty + in ( map (\item -> (rowListLabel item, go (d-1) (rowListType item))) items + , case tail_ of + REmpty _ -> Nothing + _ -> Just (go (d-1) tail_) + ) -- TODO(Christoph): get rid of T.unpack s @@ -100,30 +106,27 @@ constraintAsBox (pn, tys) = typeAsBox' (foldl PPTypeApp (PPTypeConstructor (fmap -- | -- Generate a pretty-printed string representing a Row -- -prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> PrettyPrintType -> Box -prettyPrintRowWith tro open close = uncurry listToBox . toList [] +prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> [(Label, PrettyPrintType)] -> Maybe PrettyPrintType -> Box +prettyPrintRowWith tro open close labels rest = + case (labels, rest) of + ([], Nothing) -> + text [open, close] + ([], Just _) -> + text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ] + _ -> + vcat left $ + zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) labels [0 :: Int ..] ++ + [ tailToPs rest, text [close] ] + where nameAndTypeToPs :: Char -> Label -> PrettyPrintType -> Box nameAndTypeToPs start name ty = text (start : ' ' : T.unpack (prettyPrintLabel name) ++ " " ++ doubleColon ++ " ") <> typeAsBox' ty doubleColon = if troUnicode tro then "∷" else "::" - tailToPs :: PrettyPrintType -> Box - tailToPs PPREmpty = nullBox - tailToPs other = text "| " <> typeAsBox' other - - listToBox :: [(Label, PrettyPrintType)] -> PrettyPrintType -> Box - listToBox [] PPREmpty = text [open, close] - listToBox [] rest = text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ] - listToBox ts rest = vcat left $ - zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) ts [0 :: Int ..] ++ - [ tailToPs rest, text [close] ] - toList :: [(Label, PrettyPrintType)] -> PrettyPrintType -> ([(Label, PrettyPrintType)], PrettyPrintType) - toList tys (PPRCons name ty row) = toList ((name, ty):tys) row - toList tys r = (reverse tys, r) - -prettyPrintRow :: PrettyPrintType -> String -prettyPrintRow = render . prettyPrintRowWith defaultOptions '(' ')' + tailToPs :: Maybe PrettyPrintType -> Box + tailToPs Nothing = nullBox + tailToPs (Just other) = text "| " <> typeAsBox' other typeApp :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType) typeApp = mkPattern match @@ -164,7 +167,6 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} = match (PPTypeWildcard name) = Just $ maybe (text "_") (text . ('?' :) . T.unpack) name match (PPTypeVar var) = Just $ text $ T.unpack var match (PPTypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s - match (PPRecord row) = Just $ prettyPrintRowWith tro '{' '}' row match (PPTypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor match (PPTUnknown u) | suggesting = Just $ text "_" @@ -172,11 +174,12 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} = match (PPSkolem name s) | suggesting = Just $ text $ T.unpack name | otherwise = Just $ text $ T.unpack name ++ show s - match PPREmpty = Just $ text "()" - match row@PPRCons{} = Just $ prettyPrintRowWith tro '(' ')' row + match (PPRecord labels tail_) = Just $ prettyPrintRowWith tro '{' '}' labels tail_ + match (PPRow labels tail_) = Just $ prettyPrintRowWith tro '(' ')' labels tail_ match (PPBinaryNoParensType op l r) = Just $ typeAsBox' l <> text " " <> typeAsBox' op <> text " " <> typeAsBox' r match (PPTypeOp op) = Just $ text $ T.unpack $ showQualified runOpName op + match PPTruncated = Just $ text "..." match _ = Nothing matchType :: TypeRenderOptions -> Pattern () PrettyPrintType Box @@ -213,18 +216,18 @@ typeAtomAsBox' = fromMaybe (internalError "Incomplete pattern") . PA.pattern (matchTypeAtom defaultOptions) () -typeAtomAsBox :: Type a -> Box -typeAtomAsBox = typeAtomAsBox' . convertPrettyPrintType +typeAtomAsBox :: Int -> Type a -> Box +typeAtomAsBox maxDepth = typeAtomAsBox' . convertPrettyPrintType maxDepth -- | Generate a pretty-printed string representing a Type, as it should appear inside parentheses -prettyPrintTypeAtom :: Type a -> String -prettyPrintTypeAtom = render . typeAtomAsBox +prettyPrintTypeAtom :: Int -> Type a -> String +prettyPrintTypeAtom maxDepth = render . typeAtomAsBox maxDepth typeAsBox' :: PrettyPrintType -> Box typeAsBox' = typeAsBoxImpl defaultOptions -typeAsBox :: Type a -> Box -typeAsBox = typeAsBox' . convertPrettyPrintType +typeAsBox :: Int -> Type a -> Box +typeAsBox maxDepth = typeAsBox' . convertPrettyPrintType maxDepth suggestedTypeAsBox :: PrettyPrintType -> Box suggestedTypeAsBox = typeAsBoxImpl suggestingOptions @@ -249,20 +252,20 @@ typeAsBoxImpl tro . PA.pattern (matchType tro) () -- | Generate a pretty-printed string representing a 'Type' -prettyPrintType :: Type a -> String -prettyPrintType = prettyPrintType' defaultOptions +prettyPrintType :: Int -> Type a -> String +prettyPrintType = flip prettyPrintType' defaultOptions -- | Generate a pretty-printed string representing a 'Type' using unicode -- symbols where applicable -prettyPrintTypeWithUnicode :: Type a -> String -prettyPrintTypeWithUnicode = prettyPrintType' unicodeOptions +prettyPrintTypeWithUnicode :: Int -> Type a -> String +prettyPrintTypeWithUnicode = flip prettyPrintType' unicodeOptions -- | Generate a pretty-printed string representing a suggested 'Type' prettyPrintSuggestedType :: Type a -> String -prettyPrintSuggestedType = prettyPrintType' suggestingOptions +prettyPrintSuggestedType = prettyPrintType' maxBound suggestingOptions -prettyPrintType' :: TypeRenderOptions -> Type a -> String -prettyPrintType' tro = render . typeAsBoxImpl tro . convertPrettyPrintType +prettyPrintType' :: Int -> TypeRenderOptions -> Type a -> String +prettyPrintType' maxDepth tro = render . typeAsBoxImpl tro . convertPrettyPrintType maxDepth prettyPrintLabel :: Label -> Text prettyPrintLabel (Label s) = diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 104fca9a8d..fe9592d7b4 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -86,7 +86,7 @@ prettyPrintValue d (Do m els) = prettyPrintValue d (Ado m els yield) = textT (maybe "" ((Monoid.<> ".") . runModuleName) m) <> text "ado " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) // (text "in " <> prettyPrintValue (d - 1) yield) -prettyPrintValue _ (TypeClassDictionary (Constraint _ name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map typeAtomAsBox tys +prettyPrintValue d (TypeClassDictionary (Constraint _ name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map (typeAtomAsBox d) tys prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name)) prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = text "#dict-accessor " <> text (T.unpack (runProperName (disqualify className))) <> text "." <> text (T.unpack (showIdent ident)) <> text ">" @@ -130,8 +130,8 @@ prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ secon prettyPrintDeclaration :: Int -> Declaration -> Box prettyPrintDeclaration d _ | d < 0 = ellipsis -prettyPrintDeclaration _ (TypeDeclaration td) = - text (T.unpack (showIdent (tydeclIdent td)) ++ " :: ") <> typeAsBox (tydeclType td) +prettyPrintDeclaration d (TypeDeclaration td) = + text (T.unpack (showIdent (tydeclIdent td)) ++ " :: ") <> typeAsBox d (tydeclType td) prettyPrintDeclaration d (ValueDecl _ ident _ [] [GuardedExpr [] val]) = text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val prettyPrintDeclaration d (BindingGroupDeclaration ds) = diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 7a2ba813b0..ef5e130502 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -275,7 +275,7 @@ displayAssertionFailure = \case "expected " <> decl <> " to be a " <> expected <> " declaration, but it" <> " was a " <> actual <> " declaration" DeclarationWrongType _ decl actual -> - decl <> " had the wrong type; got " <> T.pack (P.prettyPrintType actual) + decl <> " had the wrong type; got " <> T.pack (P.prettyPrintType maxBound actual) TypeSynonymMismatch _ decl expected actual -> "expected the RHS of " <> decl <> " to be " <> expected <> "; got " <> actual From ac2e896927a8224df8041ddeea15c251125e5ad9 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 7 Mar 2019 22:46:52 +0000 Subject: [PATCH 1060/1580] Don't generate unused imports (#3545) This commit prevents CodeGen from emitting any JS imports for modules whose use sites have all been optimized out. Partial fix for #2177. --- CONTRIBUTORS.md | 1 + src/Language/PureScript/CodeGen/JS.hs | 17 +++++++++++++++-- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 30b7de3c46..dffc5a2198 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -92,6 +92,7 @@ If you would prefer to use different terms, please use the section below instead | [@philopon](https://github.com/philopon) | Hirotomo Moriwaki | [MIT license](http://opensource.org/licenses/MIT) | | [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license](http://opensource.org/licenses/MIT) | | [@quesebifurcan](https://github.com/quesebifurcan) | Fredrik Wallberg | [MIT license](http://opensource.org/licenses/MIT) | +| [@rhendric](https://github.com/rhendric) | Ryan Hendrickson | [MIT license](http://opensource.org/licenses/MIT) | | [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) | | [@rndnoise](https://www.github.com/rndnoise) | rndnoise | [MIT license](http://opensource.org/licenses/MIT) | | [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 59576f00b5..4153fbbf44 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -18,6 +18,7 @@ import Control.Monad.Supply.Class import Data.List ((\\), intersect) import qualified Data.Foldable as F import qualified Data.Map as M +import qualified Data.Set as S import Data.Maybe (fromMaybe, isNothing) import Data.String (fromString) import Data.Text (Text) @@ -53,11 +54,14 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps - jsImports <- traverse (importToJs mnLookup) - . (\\ (mn : C.primModules)) $ ordNub $ map snd imps let decls' = renameModules mnLookup decls jsDecls <- mapM bindToJs decls' optimized <- traverse (traverse optimize) jsDecls + let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup + let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized + jsImports <- traverse (importToJs mnLookup) + . filter (flip S.member usedModuleNames) + . (\\ (mn : C.primModules)) $ ordNub $ map snd imps F.traverse_ (F.traverse_ checkIntegers) optimized comments <- not <$> asks optionsNoComments let strict = AST.StringLiteral Nothing "use strict" @@ -126,6 +130,15 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ = in Qualified (Just mnSafe) a renameQual q = q + -- | + -- Find the set of ModuleNames referenced by an AST. + -- + findModules :: M.Map Text ModuleName -> AST -> S.Set ModuleName + findModules mnReverseLookup = AST.everything mappend go + where + go (AST.Var _ name) = foldMap S.singleton $ M.lookup name mnReverseLookup + go _ = mempty + -- | -- Generate code in the simplified JavaScript intermediate representation for a declaration -- From 6b909dca32f7d9bf5ad39119dbb7c539bb2e9117 Mon Sep 17 00:00:00 2001 From: jacereda Date: Thu, 7 Mar 2019 23:47:17 +0100 Subject: [PATCH 1061/1580] Raise upper bound on aeson in package.yaml (#3537) --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 33c3bee5b2..9ffd4a517e 100644 --- a/package.yaml +++ b/package.yaml @@ -34,7 +34,7 @@ extra-source-files: - CONTRIBUTORS.md - CONTRIBUTING.md dependencies: - - aeson >=1.0 && <1.4 + - aeson >=1.0 && <1.5 - aeson-better-errors >=0.8 - ansi-terminal >=0.7.1 && <0.9 - base >=4.8 && <4.12 From 1d701b0b5570a9ad967d292f91ed17504713a76c Mon Sep 17 00:00:00 2001 From: Jordan Mackie Date: Thu, 7 Mar 2019 23:38:02 +0000 Subject: [PATCH 1062/1580] Add Nix test dependencies to stack.yaml (#3525) Fixes `make test` on NixOS. --- stack.yaml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/stack.yaml b/stack.yaml index 332e29d804..a9982a62b0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,3 +6,7 @@ nix: enable: false packages: - zlib + # Test dependencies + - nodejs + - nodePackages.npm + - nodePackages.bower From a9ce38e9d1bee90e8f13545805239d118cb86a59 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 12 Mar 2019 07:18:14 +0100 Subject: [PATCH 1063/1580] [purs ide] Deprecates the list loadedModules command (#3548) --- psc-ide/PROTOCOL.md | 5 ++++- src/Language/PureScript/Ide.hs | 4 +++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index 0d22d38e7f..2d9673c1e3 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -395,7 +395,10 @@ In the Error case you get the errors in the compilers json format ### List -#### Loaded Modules +#### DEPRECATED Loaded Modules + +This command will be removed in the next breaking release after 0.13, +use the completion command with a filter for modules instead. `list` of type `loadedModules` lists all loaded modules (This means they can be searched for completions etc) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index c904a495ad..d74f9f0ab6 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -62,7 +62,9 @@ handleCommand c = case c of findType search filters currentModule Complete filters matcher currentModule complOptions -> findCompletions filters matcher currentModule complOptions - List LoadedModules -> + List LoadedModules -> do + logWarnN + "Listing the loaded modules command is DEPRECATED, use the completion command and filter it to modules instead" printModules List AvailableModules -> listAvailableModules From 029e222fea3c3a17b1e18d153a57bf1bc9a14b8a Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Tue, 12 Mar 2019 08:32:37 +0100 Subject: [PATCH 1064/1580] [purs ide] Represent Filters as a datatype rather than functions (#3547) * remove excessive wrapping from DeclarationType * [purs ide] Represent Filters as data rather than functions This allows us to do some reordering and optimizing on the order in which filters are applied * fixes the DeclarationTypeFilter tests * make idePrimDeclarations a Map * remove unnecessary conversions to List * use nicer filter constructor * doc strings, use nicer constructors * Updates docs * hide Filter constructors again --- psc-ide/DESIGN.org | 8 +- psc-ide/PROTOCOL.md | 39 ++--- src/Language/PureScript/Ide.hs | 8 +- src/Language/PureScript/Ide/Completion.hs | 16 +- src/Language/PureScript/Ide/Filter.hs | 154 ++++++++++-------- .../PureScript/Ide/Filter/Declaration.hs | 36 ++-- src/Language/PureScript/Ide/Imports.hs | 4 +- src/Language/PureScript/Ide/Prim.hs | 4 +- tests/Language/PureScript/Ide/FilterSpec.hs | 96 +++++------ tests/Language/PureScript/Ide/ImportsSpec.hs | 7 +- 10 files changed, 178 insertions(+), 194 deletions(-) diff --git a/psc-ide/DESIGN.org b/psc-ide/DESIGN.org index af4e023e08..ec63e5d747 100644 --- a/psc-ide/DESIGN.org +++ b/psc-ide/DESIGN.org @@ -165,9 +165,11 @@ the PROTOCOL.md file. *** Filters - Filters are functions of type =Map ModuleName [IdeDeclaration] -> Map - ModuleName [IdeDeclaration]=. We keep the =Map= structure around to make the - common case of filtering by module names fast. + Filters are functions of type =Map ModuleName [IdeDeclaration] -> + Map ModuleName [IdeDeclaration]=. They only ever keep or remove + declarations, they never modify or add them. We keep the =Map= + structure around to make the common case of filtering by module + names fast. Filters are commutative. *** Matchers Matchers operate on individual declarations rather than a =Map=. They also diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index 2d9673c1e3..d64bfbc78b 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -601,37 +601,22 @@ Valid namespaces are `value`, `type` and `kind`. ### Declaration type filter A filter which allows to filter type declarations. Valid type declarations are `value`, `type`, `synonym`, `dataconstructor`, `typeclass`, `valueoperator`, -`typeoperator` and `kind`. +`typeoperator`, `kind`, and `module`. ```json { "filter": "declarations", - "params": [ - { - "declarationtype": "value" - }, - { - "declarationtype": "type" - }, - { - "declarationtype": "synonym" - }, - { - "declarationtype": "dataconstructor" - } - { - "declarationtype": "typeclass" - }, - { - "declarationtype": "valueoperator" - }, - { - "declarationtype": "typeoperator" - }, - { - "declarationtype": "kind" - } - ] + "params": + [ "value" + , "type" + , "synonym" + , "dataconstructor" + , "typeclass" + , "valueoperator" + , "typeoperator" + , "kind" + , "module" + ] } ``` diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index d74f9f0ab6..58aafac16f 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -115,8 +115,8 @@ findCompletions -> CompletionOptions -> m Success findCompletions filters matcher currentModule complOptions = do - modules <- Map.toList <$> getAllModules currentModule - let insertPrim = (++) idePrimDeclarations + modules <- getAllModules currentModule + let insertPrim = Map.union idePrimDeclarations pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules))) findType @@ -126,8 +126,8 @@ findType -> Maybe P.ModuleName -> m Success findType search filters currentModule = do - modules <- Map.toList <$> getAllModules currentModule - let insertPrim = (++) idePrimDeclarations + modules <- getAllModules currentModule + let insertPrim = Map.union idePrimDeclarations pure (CompletionResult (getExactCompletions search filters (insertPrim modules))) printModules :: Ide m => m Success diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 9d49c9433e..56affea2dd 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -22,15 +22,13 @@ import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import Lens.Micro.Platform hiding ((&)) -type Module = (P.ModuleName, [IdeDeclarationAnn]) - -- | Applies the CompletionFilters and the Matcher to the given Modules -- and sorts the found Completions according to the Matching Score getCompletions :: [Filter] -> Matcher IdeDeclarationAnn -> CompletionOptions - -> [Module] + -> ModuleMap [IdeDeclarationAnn] -> [Completion] getCompletions filters matcher options modules = modules @@ -40,23 +38,23 @@ getCompletions filters matcher options modules = & applyCompletionOptions options <&> completionFromMatch -getExactMatches :: Text -> [Filter] -> [Module] -> [Match IdeDeclarationAnn] +getExactMatches :: Text -> [Filter] -> ModuleMap [IdeDeclarationAnn] -> [Match IdeDeclarationAnn] getExactMatches search filters modules = modules - & applyFilters (equalityFilter search : filters) + & applyFilters (exactFilter search : filters) & matchesFromModules -getExactCompletions :: Text -> [Filter] -> [Module] -> [Completion] +getExactCompletions :: Text -> [Filter] -> ModuleMap [IdeDeclarationAnn] -> [Completion] getExactCompletions search filters modules = modules & getExactMatches search filters <&> simpleExport <&> completionFromMatch -matchesFromModules :: [Module] -> [Match IdeDeclarationAnn] -matchesFromModules = foldMap completionFromModule +matchesFromModules :: ModuleMap [IdeDeclarationAnn] -> [Match IdeDeclarationAnn] +matchesFromModules = Map.foldMapWithKey completionFromModule where - completionFromModule (moduleName, decls) = + completionFromModule moduleName decls = map (\x -> Match (moduleName, x)) decls data CompletionOptions = CompletionOptions diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index b08bb06d0e..83829a75d8 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -16,111 +16,129 @@ module Language.PureScript.Ide.Filter ( Filter - , declarationTypeFilter - , namespaceFilter , moduleFilter + , namespaceFilter + , exactFilter , prefixFilter - , equalityFilter + , declarationTypeFilter , applyFilters ) where -import Protolude hiding (isPrefixOf) +import Protolude hiding (isPrefixOf, Prefix) +import Data.Bifunctor (first) import Data.Aeson -import Data.List.NonEmpty (NonEmpty) import Data.Text (isPrefixOf) -import qualified Language.PureScript.Ide.Filter.Declaration as D +import qualified Data.Set as Set +import qualified Data.Map as Map +import Language.PureScript.Ide.Filter.Declaration (DeclarationType, declarationType) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import qualified Language.PureScript as P -newtype Filter = Filter (Endo [Module]) - deriving (Semigroup, Monoid) +newtype Filter = Filter (Either (Set P.ModuleName) DeclarationFilter) + deriving Show -type Module = (P.ModuleName, [IdeDeclarationAnn]) +unFilter :: Filter -> Either (Set P.ModuleName) DeclarationFilter +unFilter (Filter f) = f -mkFilter :: ([Module] -> [Module]) -> Filter -mkFilter = Filter . Endo +data DeclarationFilter + = Prefix Text + | Exact Text + | Namespace (Set IdeNamespace) + | DeclType (Set DeclarationType) + deriving Show --- | Only keeps Identifiers in the given Namespaces -namespaceFilter :: NonEmpty IdeNamespace -> Filter -namespaceFilter namespaces = - mkFilter (filterModuleDecls filterNamespaces) - where - filterNamespaces :: IdeDeclaration -> Bool - filterNamespaces decl = elem (namespaceForDeclaration decl) namespaces +-- | Only keeps Declarations in the given modules +moduleFilter :: Set P.ModuleName -> Filter +moduleFilter = Filter . Left --- | Only keeps the given Modules -moduleFilter :: [P.ModuleName] -> Filter -moduleFilter = - mkFilter . moduleFilter' +-- | Only keeps Identifiers in the given Namespaces +namespaceFilter :: Set IdeNamespace -> Filter +namespaceFilter nss = Filter (Right (Namespace nss)) -moduleFilter' :: [P.ModuleName] -> [Module] -> [Module] -moduleFilter' moduleIdents = filter (flip elem moduleIdents . fst) +-- | Only keeps Identifiers that are equal to the search string +exactFilter :: Text -> Filter +exactFilter t = Filter (Right (Exact t)) -- | Only keeps Identifiers that start with the given prefix prefixFilter :: Text -> Filter -prefixFilter "" = mkFilter identity -prefixFilter t = - mkFilter $ declarationFilter prefix t - where - prefix :: IdeDeclaration -> Text -> Bool - prefix ed search = search `isPrefixOf` identifierFromIdeDeclaration ed - --- | Only keeps Identifiers that are equal to the search string -equalityFilter :: Text -> Filter -equalityFilter = - mkFilter . declarationFilter equality - where - equality :: IdeDeclaration -> Text -> Bool - equality ed search = identifierFromIdeDeclaration ed == search - -declarationFilter :: (IdeDeclaration -> Text -> Bool) -> Text -> [Module] -> [Module] -declarationFilter predicate search = - filterModuleDecls (flip predicate search) +prefixFilter t = Filter (Right (Prefix t)) -- | Only keeps Identifiers in the given type declarations -declarationTypeFilter :: [D.IdeDeclaration] -> Filter -declarationTypeFilter [] = mkFilter identity -declarationTypeFilter decls = - mkFilter $ filterModuleDecls filterDecls - where - filterDecls :: IdeDeclaration -> Bool - filterDecls decl = D.typeDeclarationForDeclaration decl `elem` decls - -filterModuleDecls :: (IdeDeclaration -> Bool) -> [Module] -> [Module] -filterModuleDecls predicate = - filter (not . null . snd) . fmap filterDecls - where - filterDecls (moduleIdent, decls) = (moduleIdent, filter (predicate . discardAnn) decls) +declarationTypeFilter :: Set DeclarationType -> Filter +declarationTypeFilter dts = Filter (Right (DeclType dts)) -runFilter :: Filter -> [Module] -> [Module] -runFilter (Filter f) = appEndo f - -applyFilters :: [Filter] -> [Module] -> [Module] -applyFilters = runFilter . fold +optimizeFilters :: [Filter] -> (Maybe (Set P.ModuleName), [DeclarationFilter]) +optimizeFilters = first smashModuleFilters . partitionEithers . map unFilter + where + smashModuleFilters [] = + Nothing + smashModuleFilters (x:xs) = + Just (foldr Set.intersection x xs) + +applyFilters :: [Filter] -> ModuleMap [IdeDeclarationAnn] -> ModuleMap [IdeDeclarationAnn] +applyFilters fs modules = case optimizeFilters fs of + (Nothing, declarationFilters) -> + applyDeclarationFilters declarationFilters modules + (Just moduleFilter', declarationFilters) -> + applyDeclarationFilters declarationFilters (Map.restrictKeys modules moduleFilter') + +applyDeclarationFilters + :: [DeclarationFilter] + -> ModuleMap [IdeDeclarationAnn] + -> ModuleMap [IdeDeclarationAnn] +applyDeclarationFilters fs = + Map.filter (not . null) + . Map.map (foldr (.) identity (map applyDeclarationFilter fs)) + +applyDeclarationFilter + :: DeclarationFilter + -> [IdeDeclarationAnn] + -> [IdeDeclarationAnn] +applyDeclarationFilter f = case f of + Prefix prefix -> prefixFilter' prefix + Exact t -> exactFilter' t + Namespace namespaces -> namespaceFilter' namespaces + DeclType dts -> declarationTypeFilter' dts + +namespaceFilter' :: Set IdeNamespace -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] +namespaceFilter' namespaces = + filter (\decl -> elem (namespaceForDeclaration (discardAnn decl)) namespaces) + +exactFilter' :: Text -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] +exactFilter' search = + filter (\decl -> identifierFromIdeDeclaration (discardAnn decl) == search) + +prefixFilter' :: Text -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] +prefixFilter' prefix = + filter (\decl -> prefix `isPrefixOf` identifierFromIdeDeclaration (discardAnn decl)) + +declarationTypeFilter' :: Set DeclarationType -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] +declarationTypeFilter' declTypes = + filter (\decl -> declarationType (discardAnn decl) `Set.member` declTypes) instance FromJSON Filter where parseJSON = withObject "filter" $ \o -> do (filter' :: Text) <- o .: "filter" case filter' of + "modules" -> do + params <- o .: "params" + modules <- map P.moduleNameFromString <$> params .: "modules" + pure (moduleFilter (Set.fromList modules)) "exact" -> do params <- o .: "params" search <- params .: "search" - return $ equalityFilter search + pure (exactFilter search) "prefix" -> do params <- o.: "params" search <- params .: "search" - return $ prefixFilter search - "modules" -> do - params <- o .: "params" - modules <- map P.moduleNameFromString <$> params .: "modules" - return $ moduleFilter modules + pure (prefixFilter search) "namespace" -> do params <- o .: "params" namespaces <- params .: "namespaces" - return $ namespaceFilter namespaces + pure (namespaceFilter (Set.fromList namespaces)) "declarations" -> do declarations <- o.: "params" - return $ declarationTypeFilter declarations + pure (declarationTypeFilter (Set.fromList declarations)) _ -> mzero diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs index f0e1bce8ba..5c04fd3512 100644 --- a/src/Language/PureScript/Ide/Filter/Declaration.hs +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -1,9 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Language.PureScript.Ide.Filter.Declaration - ( IdeDeclaration(..) - , DeclarationType(..) - , typeDeclarationForDeclaration + ( DeclarationType(..) + , declarationType ) where import Protolude hiding (isPrefixOf) @@ -37,23 +36,14 @@ instance FromJSON DeclarationType where "module" -> pure Module _ -> mzero -newtype IdeDeclaration = IdeDeclaration - { declarationtype :: DeclarationType - } deriving (Show, Eq, Ord) - -instance FromJSON IdeDeclaration where - parseJSON (Object o) = - IdeDeclaration <$> o .: "declarationtype" - parseJSON _ = mzero - -typeDeclarationForDeclaration :: PI.IdeDeclaration -> IdeDeclaration -typeDeclarationForDeclaration decl = case decl of - PI.IdeDeclValue _ -> IdeDeclaration Value - PI.IdeDeclType _ -> IdeDeclaration Type - PI.IdeDeclTypeSynonym _ -> IdeDeclaration Synonym - PI.IdeDeclDataConstructor _ -> IdeDeclaration DataConstructor - PI.IdeDeclTypeClass _ -> IdeDeclaration TypeClass - PI.IdeDeclValueOperator _ -> IdeDeclaration ValueOperator - PI.IdeDeclTypeOperator _ -> IdeDeclaration TypeOperator - PI.IdeDeclKind _ -> IdeDeclaration Kind - PI.IdeDeclModule _ -> IdeDeclaration Module +declarationType :: PI.IdeDeclaration -> DeclarationType +declarationType decl = case decl of + PI.IdeDeclValue _ -> Value + PI.IdeDeclType _ -> Type + PI.IdeDeclTypeSynonym _ -> Synonym + PI.IdeDeclDataConstructor _ -> DataConstructor + PI.IdeDeclTypeClass _ -> TypeClass + PI.IdeDeclValueOperator _ -> ValueOperator + PI.IdeDeclTypeOperator _ -> TypeOperator + PI.IdeDeclKind _ -> Kind + PI.IdeDeclModule _ -> Module diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 209a53e0ab..c8af2ac2a1 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -275,8 +275,8 @@ addImportForIdentifier -> [Filter] -- ^ Filters to apply before searching for the identifier -> m (Either [Match IdeDeclaration] [Text]) addImportForIdentifier fp ident qual filters = do - let addPrim = (++) idePrimDeclarations - modules <- Map.toList <$> getAllModules Nothing + let addPrim = Map.union idePrimDeclarations + modules <- getAllModules Nothing case map (fmap discardAnn) (getExactMatches ident filters (addPrim modules)) of [] -> throwError (NotFound "Couldn't find the given identifier. \ diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index 4430a127fd..c58550c918 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -8,8 +8,8 @@ import qualified Language.PureScript.Constants as C import qualified Language.PureScript.Environment as PEnv import Language.PureScript.Ide.Types -idePrimDeclarations :: [(P.ModuleName, [IdeDeclarationAnn])] -idePrimDeclarations = +idePrimDeclarations :: ModuleMap [IdeDeclarationAnn] +idePrimDeclarations = Map.fromList [ ( C.Prim , mconcat [primTypes, primKinds, primClasses] ) diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index ed0e376b60..84a0e50747 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -3,7 +3,8 @@ module Language.PureScript.Ide.FilterSpec where import Protolude -import Data.List.NonEmpty +import qualified Data.Map as Map +import qualified Data.Set as Set import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Filter.Declaration as D import Language.PureScript.Ide.Types @@ -24,23 +25,23 @@ moduleG = (P.moduleNameFromString "Module.G", [T.ideTypeClass "MyClass" P.kindTy moduleH = (P.moduleNameFromString "Module.H", [T.ideValueOp "<$>" (P.Qualified Nothing (Left "")) 0 Nothing Nothing]) moduleI = (P.moduleNameFromString "Module.I", [T.ideTypeOp "~>" (P.Qualified Nothing "") 0 Nothing Nothing]) -modules :: [Module] -modules = [moduleA, moduleB] +modules :: ModuleMap [IdeDeclarationAnn] +modules = Map.fromList [moduleA, moduleB] runEq :: Text -> [Module] -runEq s = applyFilters [equalityFilter s] modules +runEq s = Map.toList (applyFilters [exactFilter s] modules) runPrefix :: Text -> [Module] -runPrefix s = applyFilters [prefixFilter s] modules +runPrefix s = Map.toList $ applyFilters [prefixFilter s] modules runModule :: [P.ModuleName] -> [Module] -runModule ms = applyFilters [moduleFilter ms] modules +runModule ms = Map.toList $ applyFilters [moduleFilter (Set.fromList ms)] modules -runNamespace :: NonEmpty IdeNamespace -> [Module] -> [Module] -runNamespace namespaces = applyFilters [namespaceFilter namespaces] +runNamespace :: Set IdeNamespace -> [Module] -> [Module] +runNamespace namespaces = Map.toList . applyFilters [namespaceFilter namespaces] . Map.fromList -runDeclaration :: [D.IdeDeclaration] -> [Module] -> [Module] -runDeclaration decls = applyFilters [declarationTypeFilter decls] +runDeclaration :: [D.DeclarationType] -> [Module] -> [Module] +runDeclaration decls = Map.toList . applyFilters [declarationTypeFilter (Set.fromList decls)] . Map.fromList spec :: Spec spec = do @@ -53,7 +54,7 @@ spec = do runEq "data1" `shouldBe` [moduleB] describe "prefixFilter" $ do it "keeps everything on empty string" $ - runPrefix "" `shouldBe` modules + runPrefix "" `shouldBe` Map.toList modules it "keeps functionname prefix matches" $ runPrefix "fun" `shouldBe` [moduleA] it "keeps data decls prefix matches" $ @@ -67,102 +68,91 @@ spec = do runModule (P.moduleNameFromString <$> ["Module.A", "Unknown"]) `shouldBe` [moduleA] describe "namespaceFilter" $ do it "extracts modules by filtering `value` namespaces" $ - runNamespace (fromList [IdeNSValue]) + runNamespace (Set.fromList [IdeNSValue]) [moduleA, moduleB, moduleD] `shouldBe` [moduleA, moduleB] it "extracts no modules by filtering `value` namespaces" $ - runNamespace (fromList [IdeNSValue]) + runNamespace (Set.fromList [IdeNSValue]) [moduleD] `shouldBe` [] it "extracts modules by filtering `type` namespaces" $ - runNamespace (fromList [IdeNSType]) + runNamespace (Set.fromList [IdeNSType]) [moduleA, moduleB, moduleC] `shouldBe` [moduleC] it "extracts no modules by filtering `type` namespaces" $ - runNamespace (fromList [IdeNSType]) + runNamespace (Set.fromList [IdeNSType]) [moduleA, moduleB] `shouldBe` [] it "extracts modules by filtering `kind` namespaces" $ - runNamespace (fromList [IdeNSKind]) + runNamespace (Set.fromList [IdeNSKind]) [moduleA, moduleB, moduleD] `shouldBe` [moduleD] it "extracts no modules by filtering `kind` namespaces" $ - runNamespace (fromList [IdeNSKind]) + runNamespace (Set.fromList [IdeNSKind]) [moduleA, moduleB] `shouldBe` [] it "extracts modules by filtering `value` and `type` namespaces" $ - runNamespace (fromList [ IdeNSValue, IdeNSType]) + runNamespace (Set.fromList [ IdeNSValue, IdeNSType]) [moduleA, moduleB, moduleC, moduleD] `shouldBe` [moduleA, moduleB, moduleC] it "extracts modules by filtering `value` and `kind` namespaces" $ - runNamespace (fromList [ IdeNSValue, IdeNSKind]) + runNamespace (Set.fromList [ IdeNSValue, IdeNSKind]) [moduleA, moduleB, moduleC, moduleD] `shouldBe` [moduleA, moduleB, moduleD] it "extracts modules by filtering `type` and `kind` namespaces" $ - runNamespace (fromList [ IdeNSType, IdeNSKind]) + runNamespace (Set.fromList [ IdeNSType, IdeNSKind]) [moduleA, moduleB, moduleC, moduleD] `shouldBe` [moduleC, moduleD] it "extracts modules by filtering `value`, `type` and `kind` namespaces" $ - runNamespace (fromList [ IdeNSValue, IdeNSType, IdeNSKind]) + runNamespace (Set.fromList [ IdeNSValue, IdeNSType, IdeNSKind]) [moduleA, moduleB, moduleC, moduleD] `shouldBe` [moduleA, moduleB, moduleC, moduleD] describe "declarationTypeFilter" $ do - let moduleADecl = D.IdeDeclaration D.Value - moduleCDecl = D.IdeDeclaration D.Type - moduleDDecl = D.IdeDeclaration D.Kind - moduleEDecl = D.IdeDeclaration D.Synonym - moduleFDecl = D.IdeDeclaration D.DataConstructor - moduleGDecl = D.IdeDeclaration D.TypeClass - moduleHDecl = D.IdeDeclaration D.ValueOperator - moduleIDecl = D.IdeDeclaration D.TypeOperator - it "keeps everything on empty list of declarations" $ - runDeclaration [] - [moduleA, moduleB, moduleD] `shouldBe` [moduleA, moduleB, moduleD] it "extracts modules by filtering `value` declarations" $ - runDeclaration [moduleADecl] + runDeclaration [D.Value] [moduleA, moduleB, moduleD] `shouldBe` [moduleA, moduleB] it "removes everything if no `value` declarations has been found" $ - runDeclaration [moduleADecl] + runDeclaration [D.Value] [moduleD, moduleG, moduleE, moduleH] `shouldBe` [] it "extracts module by filtering `type` declarations" $ - runDeclaration [moduleCDecl] + runDeclaration [D.Type] [moduleA, moduleB, moduleC, moduleD, moduleE] `shouldBe` [moduleC] it "removes everything if a `type` declaration have not been found" $ - runDeclaration [moduleCDecl] + runDeclaration [D.Type] [moduleA, moduleG, moduleE, moduleH] `shouldBe` [] it "extracts module by filtering `synonym` declarations" $ - runDeclaration [moduleEDecl] + runDeclaration [D.Synonym] [moduleA, moduleB, moduleD, moduleE] `shouldBe` [moduleE] it "removes everything if a `synonym` declaration have not been found" $ - runDeclaration [moduleEDecl] + runDeclaration [D.Synonym] [moduleA, moduleB, moduleC, moduleH] `shouldBe` [] it "extracts module by filtering `constructor` declarations" $ - runDeclaration [moduleFDecl] + runDeclaration [D.DataConstructor] [moduleA, moduleB, moduleC, moduleF] `shouldBe` [moduleF] it "removes everything if a `constructor` declaration have not been found" $ - runDeclaration [moduleFDecl] + runDeclaration [D.DataConstructor] [moduleA, moduleB, moduleC, moduleH] `shouldBe` [] it "extracts module by filtering `typeclass` declarations" $ - runDeclaration [moduleGDecl] + runDeclaration [D.TypeClass] [moduleA, moduleC, moduleG] `shouldBe` [moduleG] it "removes everything if a `typeclass` declaration have not been found" $ - runDeclaration [moduleGDecl] + runDeclaration [D.TypeClass] [moduleA, moduleB, moduleC, moduleH] `shouldBe` [] it "extracts modules by filtering `valueoperator` declarations" $ - runDeclaration [moduleHDecl] + runDeclaration [D.ValueOperator] [moduleA, moduleC, moduleG, moduleH, moduleF] `shouldBe` [moduleH] it "removes everything if a `valueoperator` declaration have not been found" $ - runDeclaration [moduleHDecl] + runDeclaration [D.ValueOperator] [moduleA, moduleB, moduleC, moduleD] `shouldBe` [] it "extracts modules by filtering `typeoperator` declarations" $ - runDeclaration [moduleIDecl] + runDeclaration [D.TypeOperator] [moduleA, moduleC, moduleG, moduleI, moduleF] `shouldBe` [moduleI] it "removes everything if a `typeoperator` declaration have not been found" $ - runDeclaration [moduleIDecl] + runDeclaration [D.TypeOperator] [moduleA, moduleD] `shouldBe` [] it "extracts module by filtering `kind` declarations" $ - runDeclaration [moduleCDecl] - [moduleA, moduleC, moduleG, moduleI, moduleF] `shouldBe` [moduleC] + runDeclaration [D.Kind] + [moduleA, moduleD, moduleG, moduleI, moduleF] `shouldBe` [moduleD] it "removes everything if a `kind` declaration have not been found" $ - runDeclaration [moduleCDecl] - [moduleA, moduleD] `shouldBe` [] + runDeclaration [D.Kind] + [moduleA, moduleC] `shouldBe` [] it "extracts modules by filtering `value` and `synonym` declarations" $ - runDeclaration [moduleADecl, moduleEDecl] + runDeclaration [D.Value, D.Synonym] [moduleA, moduleB, moduleD, moduleE] `shouldBe` [moduleA, moduleB, moduleE] - it "extracts modules by filtering `kind`, `synonym` and `valueoperator` declarations" $ - runDeclaration [moduleADecl, moduleDDecl, moduleHDecl] + it "extracts modules by filtering `value`, `kind`, and `valueoperator` declarations" $ + runDeclaration [D.Value, D.Kind, D.ValueOperator] [moduleA, moduleB, moduleD, moduleG, moduleE, moduleH] `shouldBe` [moduleA, moduleB, moduleD, moduleH] diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index f84d08862d..928a01c22d 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -3,9 +3,10 @@ module Language.PureScript.Ide.ImportsSpec where import Protolude hiding (moduleName) -import Data.Maybe (fromJust) +import Data.Maybe (fromJust) +import qualified Data.Set as Set -import qualified Language.PureScript as P +import qualified Language.PureScript as P import Language.PureScript.Ide.Command as Command import Language.PureScript.Ide.Error import Language.PureScript.Ide.Imports @@ -346,7 +347,7 @@ addExplicitImport i = addExplicitImportFiltered :: Text -> [P.ModuleName] -> Command addExplicitImportFiltered i ms = - Command.Import ("src" "ImportsSpec.purs") Nothing [moduleFilter ms] (Command.AddImportForIdentifier i Nothing) + Command.Import ("src" "ImportsSpec.purs") Nothing [moduleFilter (Set.fromList ms)] (Command.AddImportForIdentifier i Nothing) importShouldBe :: [Text] -> [Text] -> Expectation importShouldBe res importSection = From 676d3a9dc5803d99a9414795641e71d4f42a18da Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Fri, 15 Mar 2019 12:42:42 +0000 Subject: [PATCH 1065/1580] Filter unused imports during dead code elimination (#3546) Fixes #2177. --- package.yaml | 1 + src/Language/PureScript/Bundle.hs | 16 +++++++++++++++- 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 9ffd4a517e..4e41f35fce 100644 --- a/package.yaml +++ b/package.yaml @@ -37,6 +37,7 @@ dependencies: - aeson >=1.0 && <1.5 - aeson-better-errors >=0.8 - ansi-terminal >=0.7.1 && <0.9 + - array - base >=4.8 && <4.12 - base-compat >=0.6.0 - blaze-html >=0.8.1 && <0.10 diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 5ba1ad5901..2943ef3114 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -23,12 +23,15 @@ import Control.Monad import Control.Monad.Error.Class import Control.Arrow ((&&&)) +import Data.Array ((!)) import Data.Char (chr, digitToInt) +import Data.Foldable (fold) import Data.Generics (everything, everywhere, mkQ, mkT) import Data.Graph import Data.List (stripPrefix) import Data.Maybe (mapMaybe, catMaybes) import Data.Version (showVersion) +import qualified Data.Map as M import qualified Data.Set as S import Language.JavaScript.Parser @@ -398,7 +401,7 @@ compile :: [Module] -> [ModuleIdentifier] -> [Module] compile modules [] = modules compile modules entryPoints = filteredModules where - (graph, _, vertexFor) = graphFromEdges verts + (graph, vertexToNode, vertexFor) = graphFromEdges verts -- | The vertex set verts :: [(ModuleElement, Key, [Key])] @@ -435,6 +438,13 @@ compile modules entryPoints = filteredModules reachableSet :: S.Set Vertex reachableSet = S.fromList (concatMap (reachable graph) entryPointVertices) + -- | A map from modules to the modules that are used by its reachable members. + moduleReferenceMap :: M.Map ModuleIdentifier (S.Set ModuleIdentifier) + moduleReferenceMap = M.fromAscListWith mappend $ map (vertToModule &&& vertToModuleRefs) $ S.toList reachableSet + where + vertToModuleRefs v = foldMap (S.singleton . vertToModule) $ graph ! v + vertToModule v = m where (_, (m, _), _) = vertexToNode v + filteredModules :: [Module] filteredModules = map filterUsed modules where @@ -461,6 +471,7 @@ compile modules entryPoints = filteredModules isDeclUsed :: ModuleElement -> Bool isDeclUsed (Member _ _ nm _ _) = isKeyUsed (mid, nm) + isDeclUsed (Require _ _ (Right midRef)) = midRef `S.member` modulesReferenced isDeclUsed _ = True isKeyUsed :: Key -> Bool @@ -468,6 +479,9 @@ compile modules entryPoints = filteredModules | Just me <- vertexFor k = me `S.member` reachableSet | otherwise = False + modulesReferenced :: S.Set ModuleIdentifier + modulesReferenced = fold $ M.lookup mid moduleReferenceMap + -- | Topologically sort the module dependency graph, so that when we generate code, modules can be -- defined in the right order. sortModules :: [Module] -> [Module] From b4f24ab1f3f6d6f239888126285c50e2196d3ec6 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 18 Mar 2019 00:00:34 +0000 Subject: [PATCH 1066/1580] Carry data constructor field names in the AST (#3566) --- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/AST/Traversals.hs | 4 ++-- .../PureScript/Docs/Convert/Single.hs | 5 +++-- .../PureScript/Parser/Declarations.hs | 10 +++++++-- src/Language/PureScript/Sugar/Names.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 2 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 20 +++++++++--------- src/Language/PureScript/TypeChecker.hs | 21 ++++++++++--------- 8 files changed, 37 insertions(+), 29 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 53bb061486..4603d5063b 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -485,7 +485,7 @@ data Declaration -- | -- A data type declaration (data or newtype, name, arguments, data constructors) -- - = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceKind)] [(ProperName 'ConstructorName, [SourceType])] + = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceKind)] [(ProperName 'ConstructorName, [(Ident, SourceType)])] -- | -- A minimal mutually recursive set of data type declarations -- diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index a6ede54534..536792595e 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -629,7 +629,7 @@ accumTypes ) accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) where - forDecls (DataDeclaration _ _ _ _ dctors) = mconcat (concatMap (fmap f . snd) dctors) + forDecls (DataDeclaration _ _ _ _ dctors) = mconcat (concatMap (fmap (f . snd) . snd) dctors) forDecls (ExternDeclaration _ _ ty) = f ty forDecls (TypeClassDeclaration _ _ _ implies _ _) = mconcat (concatMap (fmap f . constraintArgs) implies) forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) <> mconcat (fmap f tys) @@ -655,7 +655,7 @@ accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (con where forDecls (DataDeclaration _ _ _ args dctors) = foldMap (foldMap f . snd) args <> - foldMap (foldMap forTypes . snd) dctors + foldMap (foldMap (forTypes . snd) . snd) dctors forDecls (TypeClassDeclaration _ _ args implies _ _) = foldMap (foldMap f . snd) args <> foldMap (foldMap forTypes . constraintArgs) implies diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 608c02f70c..b4ed0b3b03 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -122,9 +122,10 @@ convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title = Just (Right (mkDeclaration sa title info) { declChildren = children }) where info = DataDeclaration dtype (fmap (fmap (fmap ($> ()))) args) - children = map convertCtor (fmap (fmap (fmap ($> ()))) ctors) + children = map convertCtor ctors + convertCtor :: (P.ProperName 'P.ConstructorName, [(P.Ident, P.SourceType)]) -> ChildDeclaration convertCtor (ctor', tys) = - ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys) + ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor (fmap (($> ()) . snd) tys)) convertDeclaration (P.ExternDataDeclaration sa _ kind') title = basicDeclaration sa title (ExternDataDeclaration (kind' $> ())) convertDeclaration (P.ExternKindDeclaration sa _) title = diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index c7b1408575..33b9c0b2ed 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -26,7 +26,7 @@ import Control.Parallel.Strategies (withStrategy, parList, rseq) import Data.Functor (($>)) import Data.Maybe (fromMaybe) import qualified Data.Set as S -import Data.Text (Text) +import Data.Text (Text, pack) import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Errors @@ -45,6 +45,9 @@ kindedIdent :: TokenParser (Text, Maybe SourceKind) kindedIdent = (, Nothing) <$> identifier <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind))) +fields :: [Ident] +fields = [ Ident ("value" <> pack (show (n :: Integer))) | n <- [0..] ] + parseDataDeclaration :: TokenParser Declaration parseDataDeclaration = withSourceAnnF $ do dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype) @@ -52,7 +55,10 @@ parseDataDeclaration = withSourceAnnF $ do tyArgs <- many (indented *> kindedIdent) ctors <- P.option [] $ do indented *> equals - P.sepBy1 ((,) <$> dataConstructorName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe + flip P.sepBy1 pipe $ do + ctorName <- dataConstructorName + tys <- P.many (indented *> noWildcards parseTypeAtom) + return (ctorName, zip fields tys) return $ \sa -> DataDeclaration sa dtype name tyArgs ctors parseTypeDeclaration :: TokenParser Declaration diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 8348563390..54370a4a04 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -205,7 +205,7 @@ renameInModule imports (Module modSS coms mn decls exps) = fmap (bound,) $ DataDeclaration sa dtype name <$> updateTypeArguments args - <*> traverse (sndM (traverse updateTypesEverywhere)) dctors + <*> traverse (sndM (traverse (sndM updateTypesEverywhere))) dctors updateDecl bound (TypeSynonymDeclaration sa name ps ty) = fmap (bound,) $ TypeSynonymDeclaration sa name diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 9a2868f4b3..20a2e04272 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -315,7 +315,7 @@ updateTypes goType = (goDecl, goExpr, goBinder) goDecl :: Declaration -> m Declaration goDecl (DataDeclaration sa@(ss, _) ddt name args dctors) = - DataDeclaration sa ddt name args <$> traverse (sndM (traverse (goType' ss))) dctors + DataDeclaration sa ddt name args <$> traverse (sndM (traverse (sndM (goType' ss)))) dctors goDecl (ExternDeclaration sa@(ss, _) name ty) = ExternDeclaration sa name <$> goType' ss ty goDecl (TypeClassDeclaration sa@(ss, _) name args implies deps decls) = do diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 8851d9d763..25c380f068 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -205,7 +205,7 @@ deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do tyCon <- findTypeDecl ss tyConNm ds go tyCon where - go (DataDeclaration _ Newtype _ tyArgNames [(_, [wrapped])]) = do + go (DataDeclaration _ Newtype _ tyArgNames [(_, [(_, wrapped)])]) = do -- The newtype might not be applied to all type arguments. -- This is okay as long as the newtype wraps something which ends with -- sufficiently many type applications to variables. @@ -337,10 +337,10 @@ deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do compN n f = f . compN (n - 1) f makeInst - :: (ProperName 'ConstructorName, [SourceType]) + :: (ProperName 'ConstructorName, [(Ident, SourceType)]) -> m (SourceType, CaseAlternative, CaseAlternative) makeInst (ctorName, args) = do - args' <- mapM (replaceAllTypeSynonymsM syns) args + args' <- mapM (replaceAllTypeSynonymsM syns . snd) args (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args' return ( srcTypeApp (srcTypeApp (srcTypeConstructor constructor) (srcTypeLevelString $ mkString (runProperName ctorName))) @@ -468,11 +468,11 @@ deriveEq ss mn syns ds tyConNm = do where catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (Literal ss (BooleanLiteral False))) - mkCtorClause :: (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative + mkCtorClause :: (ProperName 'ConstructorName, [(Ident, SourceType)]) -> m CaseAlternative mkCtorClause (ctorName, tys) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") - tys' <- mapM (replaceAllTypeSynonymsM syns) tys + tys' <- mapM (replaceAllTypeSynonymsM syns . snd) tys let tests = zipWith3 toEqTest (map (Var ss . Qualified Nothing) identsL) (map (Var ss . Qualified Nothing) identsR) tys' return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (unguarded (conjAll tests)) where @@ -547,11 +547,11 @@ deriveOrd ss mn syns ds tyConNm = do ordCompare1 :: Expr -> Expr -> Expr ordCompare1 = App . App (Var ss (Qualified (Just dataOrd) (Ident C.compare1))) - mkCtorClauses :: ((ProperName 'ConstructorName, [SourceType]), Bool) -> m [CaseAlternative] + mkCtorClauses :: ((ProperName 'ConstructorName, [(Ident, SourceType)]), Bool) -> m [CaseAlternative] mkCtorClauses ((ctorName, tys), isLast) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") - tys' <- mapM (replaceAllTypeSynonymsM syns) tys + tys' <- mapM (replaceAllTypeSynonymsM syns . snd) tys let tests = zipWith3 toOrdering (map (Var ss . Qualified Nothing) identsL) (map (Var ss . Qualified Nothing) identsR) tys' extras | not isLast = [ CaseAlternative [ ConstructorBinder ss (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) , NullBinder @@ -622,7 +622,7 @@ deriveNewtype ss mn syns ds tyConNm tyConArgs unwrappedTy = do checkNewtype name dctors wrappedIdent <- freshIdent "n" unwrappedIdent <- freshIdent "a" - let (ctorName, [ty]) = head dctors + let (ctorName, [(_, ty)]) = head dctors ty' <- replaceAllTypeSynonymsM syns ty let inst = [ ValueDecl (ss', []) (Ident "wrap") Public [] $ unguarded $ @@ -707,10 +707,10 @@ deriveFunctor ss mn syns ds tyConNm = do lam ss' f . lamCase ss' m <$> mapM (mkCtorClause iTy f) ctors mkMapFunction _ = internalError "mkMapFunction: expected DataDeclaration" - mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative + mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [(Ident, SourceType)]) -> m CaseAlternative mkCtorClause iTyName f (ctorName, ctorTys) = do idents <- replicateM (length ctorTys) (freshIdent "v") - ctorTys' <- mapM (replaceAllTypeSynonymsM syns) ctorTys + ctorTys' <- mapM (replaceAllTypeSynonymsM syns . snd) ctorTys args <- zipWithM transformArg idents ctorTys' let ctor = Constructor ss (Qualified (Just mn) ctorName) rebuilt = foldl' App ctor args diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 58a05a4be9..5bacf63dfb 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -12,6 +12,7 @@ module Language.PureScript.TypeChecker import Prelude.Compat import Protolude (ordNub) +import Control.Arrow (second) import Control.Monad (when, unless, void, forM) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), modify, gets) @@ -49,15 +50,15 @@ addDataType -> DataDeclType -> ProperName 'TypeName -> [(Text, Maybe SourceKind)] - -> [(ProperName 'ConstructorName, [SourceType])] + -> [(ProperName 'ConstructorName, [(Ident, SourceType)])] -> SourceKind -> m () addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv - putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) } - for_ dctors $ \(dctor, tys) -> + putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args (map (second (map snd)) dctors)) (types env) } + for_ dctors $ \(dctor, fields) -> warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $ - addDataConstructor moduleName dtype name (map fst args) dctor tys + addDataConstructor moduleName dtype name (map fst args) dctor fields addDataConstructor :: (MonadState CheckState m, MonadError MultipleErrors m) @@ -66,15 +67,15 @@ addDataConstructor -> ProperName 'TypeName -> [Text] -> ProperName 'ConstructorName - -> [SourceType] + -> [(Ident, SourceType)] -> m () -addDataConstructor moduleName dtype name args dctor tys = do +addDataConstructor moduleName dtype name args dctor dctorArgs = do + let (fields, tys) = unzip dctorArgs env <- getEnv traverse_ checkTypeSynonyms tys let retTy = foldl srcTypeApp (srcTypeConstructor (Qualified (Just moduleName) name)) (map srcTypeVar args) let dctorTy = foldr function retTy tys let polyType = mkForAll (map (NullSourceAnn,) args) dctorTy - let fields = [Ident ("value" <> T.pack (show n)) | n <- [0..(length tys - 1)]] putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } addTypeSynonym @@ -236,7 +237,7 @@ typeCheckAll moduleName _ = traverse go warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (positionedError ss)) $ do when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args - ctorKind <- kindsOf True moduleName name args (concatMap snd dctors) + ctorKind <- kindsOf True moduleName name args (concatMap (fmap snd . snd) dctors) let args' = args `withKinds` ctorKind addDataType moduleName dtype name args' dctors ctorKind return $ DataDeclaration sa dtype name args dctors @@ -247,7 +248,7 @@ typeCheckAll moduleName _ = traverse go bindingGroupNames = ordNub ((syns^..traverse._2) ++ (dataDecls^..traverse._3)) sss = fmap declSourceSpan tys warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames) . addHint (PositionedError sss)) $ do - (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(sa, _, name, args, dctors) -> (sa, name, args, concatMap snd dctors)) dataDecls) + (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(sa, _, name, args, dctors) -> (sa, name, args, concatMap (fmap snd . snd) dctors)) dataDecls) for_ (zip dataDecls data_ks) $ \((_, dtype, name, args, dctors), ctorKind) -> do when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args @@ -494,7 +495,7 @@ checkNewtype :: forall m . MonadError MultipleErrors m => ProperName 'TypeName - -> [(ProperName 'ConstructorName, [SourceType])] + -> [(ProperName 'ConstructorName, [(Ident, SourceType)])] -> m () checkNewtype _ [(_, [_])] = return () checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name From 7e186a29e663d3664046450410bb288882970783 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 19 Mar 2019 00:39:40 +0000 Subject: [PATCH 1067/1580] Convert prim docs tests to use tasty (#3568) --- tests/Main.hs | 4 ++-- tests/TestPrimDocs.hs | 54 ++++++++++++++++++++++--------------------- 2 files changed, 30 insertions(+), 28 deletions(-) diff --git a/tests/Main.hs b/tests/Main.hs index 9214ff343f..9179573b3d 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -29,14 +29,13 @@ main = do heading "Updating support code" TestUtils.updateSupportCode - heading "Prim documentation test suite" - TestPrimDocs.main ideTests <- TestIde.main compilerTests <- TestCompiler.main psciTests <- TestPsci.main coreFnTests <- TestCoreFn.main docsTests <- TestDocs.main + primDocsTests <- TestPrimDocs.main publishTests <- TestPscPublish.main hierarchyTests <- TestHierarchy.main @@ -48,6 +47,7 @@ main = do , ideTests , coreFnTests , docsTests + , primDocsTests , publishTests , hierarchyTests ] diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index ef545dee3d..03d94d891a 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -2,38 +2,40 @@ module TestPrimDocs where import Prelude -import Control.Monad -import Data.List ((\\)) +import Data.List (sort) +import Control.Exception (evaluate) +import Control.DeepSeq (force) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Language.PureScript as P import qualified Language.PureScript.Docs as D -import qualified Language.PureScript.Docs.AsMarkdown as D -main :: IO () -main = do - putStrLn "Test that there are no bottoms hiding in primDocsModule" - seq (D.runDocs (D.modulesAsMarkdown D.primModules)) (return ()) +import Test.Tasty +import Test.Tasty.Hspec (Spec, testSpec, it) +import Test.Hspec (shouldBe) - putStrLn "Test that Prim is fully documented" - let actualPrimNames = - -- note that prim type classes are listed in P.primTypes - (map (P.runProperName . P.disqualify . fst) $ Map.toList - ( P.primTypes <> - P.primBooleanTypes <> - P.primOrderingTypes <> - P.primRowTypes <> - P.primRowListTypes <> - P.primTypeErrorTypes <> - P.primSymbolTypes )) ++ - (map (P.runProperName . P.disqualify) $ Set.toList P.allPrimKinds) - let documentedPrimNames = map D.declTitle (concatMap D.modDeclarations D.primModules) +main :: IO TestTree +main = testSpec "prim docs" spec - let undocumentedNames = actualPrimNames \\ documentedPrimNames - let extraNames = documentedPrimNames \\ actualPrimNames +spec :: Spec +spec = do + it "there are no bottoms hiding in primModules" $ do + _ <- evaluate (force D.primModules) + return () - when (not (null undocumentedNames)) $ - error $ "Undocumented Prim names: " ++ show undocumentedNames + it "all Prim modules are fully documented" $ do + let actualPrimNames = + -- note that prim type classes are listed in P.primTypes + (map (P.runProperName . P.disqualify . fst) $ Map.toList + ( P.primTypes <> + P.primBooleanTypes <> + P.primOrderingTypes <> + P.primRowTypes <> + P.primRowListTypes <> + P.primTypeErrorTypes <> + P.primSymbolTypes )) ++ + (map (P.runProperName . P.disqualify) $ Set.toList P.allPrimKinds) + let documentedPrimNames = + map D.declTitle (concatMap D.modDeclarations D.primModules) - when (not (null extraNames)) $ - error $ "Extra Prim names: " ++ show extraNames + sort documentedPrimNames `shouldBe` sort actualPrimNames From 22308f3dc112915b9ce3563e425a5f31f029607d Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Tue, 19 Mar 2019 19:59:08 +0000 Subject: [PATCH 1068/1580] Bump bower version used in tests (#3570) --- tests/support/package.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/support/package.json b/tests/support/package.json index 18aa9a7449..0e54c5ed3a 100644 --- a/tests/support/package.json +++ b/tests/support/package.json @@ -1,7 +1,7 @@ { "private": true, "dependencies": { - "bower": "^1.4.1", + "bower": "^1.8.8", "glob": "^5.0.14", "rimraf": "^2.5.2" } From e976f90671389456219a77e681719dd295f6297c Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 22 Mar 2019 12:57:08 +0000 Subject: [PATCH 1069/1580] Simplify `purs publish` resolutions format (#3565) Fixes #3499. Simplifies the format for resolutions files passed via the CLI to `purs publish`. A new-style resolutions file should look something like this: ``` { "purescript-prelude": { "version": "4.0.0", "path": "bower_components/purescript-prelude" }, "purescript-lists": { "version": "6.0.0", "path": "bower_components/purescript-lists" }, ... } ``` The version field is used for generating links between packages on Pursuit, and the path field is used to obtain the source files while generating documentation: all files matching the glob "src/**/*.purs" relative to the `path` directory will be picked up. The "version" field is optional, but omitting it will mean that no links will be generated for any declarations from that package on Pursuit. The "path" field is required. We continue to permit the old-style format (i.e. the output of `bower list --json`), but eventually we will want to start warning when we encounter it, and eventually drop support for it entirely. Some other smaller changes which were made in the process of implementing the above: - Use a new directory `tests/purs/publish` for packages for testing `purs publish`, as opposed to using packages from the `tests/support/bower_components` directory. This is necessary if we want to be able to test packages which have any dependencies (previously we were only testing with prelude, which has none). The new directory contains copies of the prelude and console libraries with dependencies pre-installed. - Stop emitting warnings about extraneous or undeclared dependencies; we no longer have enough information to be able to do this. --- src/Language/PureScript/Publish.hs | 234 ++++++++------- .../PureScript/Publish/ErrorsWarnings.hs | 75 +---- tests/TestPscPublish.hs | 19 +- tests/purs/publish/basic-example/README.md | 5 + tests/purs/publish/basic-example/bower.json | 13 + .../basic-example/resolutions-legacy.json | 269 ++++++++++++++++++ .../publish/basic-example/resolutions.json | 14 + .../purs/publish/basic-example/src/Main.purs | 8 + tests/support/prelude-resolutions.json | 8 +- 9 files changed, 466 insertions(+), 179 deletions(-) create mode 100644 tests/purs/publish/basic-example/README.md create mode 100644 tests/purs/publish/basic-example/bower.json create mode 100644 tests/purs/publish/basic-example/resolutions-legacy.json create mode 100644 tests/purs/publish/basic-example/resolutions.json create mode 100644 tests/purs/publish/basic-example/src/Main.purs diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 7d1c6306d0..e02e713d08 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -17,7 +17,6 @@ module Language.PureScript.Publish , getVersionFromGitTag , getManifestRepositoryInfo , getModules - , getResolvedDependencies ) where import Protolude hiding (stdin) @@ -27,6 +26,7 @@ import Control.Category ((>>>)) import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell) import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asString, asText) +import Data.Aeson.BetterErrors as ABE import qualified Data.ByteString.Lazy as BL import Data.Char (isSpace) import Data.String (String, lines) @@ -43,7 +43,7 @@ import System.Directory (doesFileExist) import System.FilePath.Glob (globDir1) import System.Process (readProcess) -import Web.Bower.PackageMeta (PackageMeta(..), PackageName, parsePackageName, Repository(..)) +import Web.Bower.PackageMeta (PackageMeta(..), PackageName, Repository(..)) import qualified Web.Bower.PackageMeta as Bower import Language.PureScript.Publish.ErrorsWarnings @@ -124,22 +124,25 @@ preparePackage' manifestFile resolutionsFile opts = do checkCleanWorkingTree opts pkgMeta <- liftIO (Bower.decodeFile manifestFile) - >>= flip catchLeft (userError . CouldntDecodePackageManifest) + >>= flip catchLeft (userError . CouldntDecodePackageManifest) checkLicense pkgMeta (pkgVersionTag, pkgVersion) <- publishGetVersion opts - pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag - pkgGithub <- getManifestRepositoryInfo pkgMeta + pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag + pkgGithub <- getManifestRepositoryInfo pkgMeta - let declaredDeps = map fst (bowerDependencies pkgMeta ++ - bowerDevDependencies pkgMeta) - resolvedDeps <- getResolvedDependencies resolutionsFile declaredDeps + resolvedDeps <- parseResolutionsFile resolutionsFile (pkgModules, pkgModuleMap) <- getModules (map (second fst) resolvedDeps) + let declaredDeps = map fst $ + Bower.bowerDependencies pkgMeta + ++ Bower.bowerDevDependencies pkgMeta + pkgResolvedDependencies <- handleDeps declaredDeps (map (second snd) resolvedDeps) + let pkgUploader = D.NotYetKnown let pkgCompilerVersion = P.version - let pkgResolvedDependencies = map (second snd) resolvedDeps + return D.Package{..} @@ -269,124 +272,139 @@ readProcess' prog args stdin = do either (otherError . ProcessFailed prog args) return out data DependencyStatus - = Missing - -- ^ Listed in package manifest, but not installed. - | NoResolution + = NoResolution -- ^ In the resolutions file, there was no _resolution key. | ResolvedOther Text -- ^ Resolved, but to something other than a version. The Text argument -- is the resolution type. The values it can take that I'm aware of are - -- "commit" and "branch". - | ResolvedVersion Text - -- ^ Resolved to a version. The Text argument is the resolution tag (eg, - -- "v0.1.0"). + -- "commit" and "branch". Note: this constructor is deprecated, and is only + -- used when parsing legacy resolutions files. + | ResolvedVersion Version + -- ^ Resolved to a version. deriving (Show, Eq) --- Go through all dependencies which contain purescript code, and --- extract their versions. --- --- In the case where a dependency is taken from a particular version, --- that's easy; take that version. In any other case (eg, a branch, or a commit --- sha) we print a warning that documentation links will not work, and avoid --- linking to documentation for any types from that package. --- --- The rationale for this is: people will prefer to use a released version --- where possible. If they are not using a released version, then this is --- probably for a reason. However, docs are only ever available for released --- versions. Therefore there will probably be no version of the docs which is --- appropriate to link to, and we should omit links. -getResolvedDependencies :: FilePath -> [PackageName] -> PrepareM [(PackageName, (FilePath, Version))] -getResolvedDependencies resolutionsFile declaredDeps = do +parseResolutionsFile :: FilePath -> PrepareM [(PackageName, (FilePath, DependencyStatus))] +parseResolutionsFile resolutionsFile = do unlessM (liftIO (doesFileExist resolutionsFile)) (userError ResolutionsFileNotFound) depsBS <- liftIO (BL.readFile resolutionsFile) - -- Check for undeclared dependencies - toplevels <- catchJSON (parse asToplevelDependencies depsBS) - warnUndeclared declaredDeps toplevels - - deps <- catchJSON (parse asResolvedDependencies depsBS) - handleDeps deps + -- We use the legacy resolutions parser on the left of <|>, because if both + -- fail, <|> gives us the error from the parser on the right (i.e. from the + -- new-style parser). + -- + -- Note that the legacy parser is pretty much guaranteed to fail in the case + -- where we have been provided a new-style resolutions file because it always + -- has a few keys such as `canonicalDir` or `endpoint` which do not conform + -- to the format expected of new-style resolutions files. + catchJSON (parse (asLegacyResolutions ABE.<|> asResolutions) depsBS) where - catchJSON = flip catchLeft (internalError . JSONError FromResolutions) + catchJSON = flip catchLeft (userError . ResolutionsFileError resolutionsFile) --- | Extracts all dependencies and their versions from a "resolutions" file, which --- is based on the output of `bower list --json --offline` -asResolvedDependencies :: Parse D.ManifestError [(PackageName, (Maybe FilePath, DependencyStatus))] -asResolvedDependencies = nubBy ((==) `on` fst) <$> go +-- | Parser for resolutions files, which contain information about the packages +-- which this package depends on. A resolutions file should look something like +-- this: +-- +-- { +-- "purescript-prelude": { +-- "version": "4.0.0", +-- "path": "bower_components/purescript-prelude" +-- }, +-- "purescript-lists": { +-- "version": "6.0.0", +-- "path": "bower_components/purescript-lists" +-- }, +-- ... +-- } +-- +-- where the version is used for generating links between packages on Pursuit, +-- and the path is used to obtain the source files while generating +-- documentation: all files matching the glob "src/**/*.purs" relative to the +-- `path` directory will be picked up. +-- +-- The "version" field is optional, but omitting it will mean that no links +-- will be generated for any declarations from that package on Pursuit. The +-- "path" field is required. +asResolutions :: Parse D.PackageError [(PackageName, (FilePath, DependencyStatus))] +asResolutions = + eachInObjectWithKey parsePackageName $ + (,) <$> key "path" asString + <*> (maybe NoResolution ResolvedVersion <$> keyMay "version" asVersion) + +asVersion :: Parse D.PackageError Version +asVersion = + withString (note D.InvalidVersion . D.parseVersion') + +-- | Extracts all dependencies and their versions from a legacy resolutions +-- file, which is based on the output of `bower list --json --offline`. +asLegacyResolutions :: Parse D.PackageError [(PackageName, (FilePath, DependencyStatus))] +asLegacyResolutions = + nubBy ((==) `on` fst) <$> go True where - go = - fmap (fromMaybe []) $ - keyMay "dependencies" $ - (++) <$> eachInObjectWithKey parsePackageName asDirectoryAndDependencyStatus - <*> (concatMap snd <$> eachInObject asResolvedDependencies) - --- | Extracts only the top level dependency names from a resolutions file. -asToplevelDependencies :: Parse D.ManifestError [PackageName] -asToplevelDependencies = - fmap (map fst) $ - key "dependencies" $ - eachInObjectWithKey parsePackageName (return ()) - -asDirectoryAndDependencyStatus :: Parse e (Maybe FilePath, DependencyStatus) -asDirectoryAndDependencyStatus = do - isMissing <- keyOrDefault "missing" False asBool - if isMissing - then - return (Nothing, Missing) - else do - directory <- key "canonicalDir" asString - status <- key "pkgMeta" $ - keyOrDefault "_resolution" NoResolution $ do - type_ <- key "type" asText - case type_ of - "version" -> ResolvedVersion <$> key "tag" asText - other -> return (ResolvedOther other) - return (Just directory, status) - -warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM () -warnUndeclared declared actual = - traverse_ (warn . UndeclaredDependency) (actual \\ declared) + go isToplevel = + keyDependencies isToplevel $ + (++) <$> (takeJusts <$> eachInObjectWithKey parsePackageName asDirectoryAndDependencyStatus) + <*> (concatMap snd <$> eachInObject (go False)) + + + keyDependencies isToplevel = + if isToplevel + then key "dependencies" + else fmap (fromMaybe []) . keyMay "dependencies" + + takeJusts :: [(a, Maybe b)] -> [(a,b)] + takeJusts = mapMaybe $ \(x,y) -> (x,) <$> y + + asDirectoryAndDependencyStatus :: Parse D.PackageError (Maybe (FilePath, DependencyStatus)) + asDirectoryAndDependencyStatus = do + isMissing <- keyOrDefault "missing" False asBool + if isMissing + then return Nothing + else do + directory <- key "canonicalDir" asString + status <- key "pkgMeta" $ + keyOrDefault "_resolution" NoResolution $ do + type_ <- key "type" asText + case type_ of + "version" -> + key "tag" $ fmap ResolvedVersion $ withText $ \tag -> + let + tag' = fromMaybe tag (T.stripPrefix "v" tag) + in + note D.InvalidVersion (D.parseVersion' (T.unpack tag')) + other -> + return (ResolvedOther other) + return $ Just (directory, status) + +parsePackageName :: Text -> Either D.PackageError PackageName +parsePackageName = first D.ErrorInPackageMeta . Bower.parsePackageName handleDeps - :: [(PackageName, (Maybe FilePath, DependencyStatus))] - -> PrepareM [(PackageName, (FilePath, Version))] -handleDeps deps = do - let (missing, noVersion, installed, missingPath) = partitionDeps deps + :: [PackageName] + -- ^ dependencies declared in package manifest file; we should emit + -- warnings for any package name in this list which is not in the + -- resolutions file. + -> [(PackageName, DependencyStatus)] + -- ^ Contents of resolutions file + -> PrepareM [(PackageName, Version)] +handleDeps declared resolutions = do + let missing = declared \\ map fst resolutions case missing of (x:xs) -> userError (MissingDependencies (x :| xs)) [] -> do - traverse_ (warn . NoResolvedVersion) noVersion - traverse_ (warn . MissingPath) missingPath - catMaybes <$> traverse tryExtractVersion' installed - - where - partitionDeps = foldr go ([], [], [], []) - go (pkgName, (Nothing, _)) (ms, os, is, mp) = - (ms, os, is, pkgName : mp) - go (pkgName, (Just path, d)) (ms, os, is, mp) = - case d of - Missing -> (pkgName : ms, os, is, mp) - NoResolution -> (ms, pkgName : os, is, mp) - ResolvedOther _ -> (ms, pkgName : os, is, mp) - ResolvedVersion v -> (ms, os, (pkgName, (path, v)) : is, mp) - - -- Try to extract a version, and warn if unsuccessful. - tryExtractVersion' - :: (PackageName, (extra, Text)) - -> PrepareM (Maybe (PackageName, (extra, Version))) - tryExtractVersion' pair = - maybe (warn (UnacceptableVersion (fmap snd pair)) >> return Nothing) - (return . Just) - (tryExtractVersion pair) - -tryExtractVersion - :: (PackageName, (extra, Text)) - -> Maybe (PackageName, (extra, Version)) -tryExtractVersion (pkgName, (extra, tag)) = - let tag' = fromMaybe tag (T.stripPrefix "v" tag) - in (pkgName,) . (extra,) <$> D.parseVersion' (T.unpack tag') + pkgs <- + for resolutions $ \(pkgName, status) -> + case status of + NoResolution -> do + warn (NoResolvedVersion pkgName) + pure Nothing + ResolvedOther other -> do + warn (UnacceptableVersion (pkgName, other)) + pure Nothing + ResolvedVersion version -> + pure (Just (pkgName, version)) + pure (catMaybes pkgs) getInputAndDepsFiles :: [(PackageName, FilePath)] diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 38ebc36aeb..183fe2c639 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -27,12 +27,11 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) import qualified Data.Text as T -import Language.PureScript.Docs.Types (ManifestError) -import Language.PureScript.Publish.BoxesHelpers +import qualified Language.PureScript.Docs.Types as D import qualified Language.PureScript as P +import Language.PureScript.Publish.BoxesHelpers import Web.Bower.PackageMeta (PackageName, runPackageName, showBowerError) -import qualified Web.Bower.PackageMeta as Bower -- | An error which meant that it was not possible to retrieve metadata for a -- package. @@ -44,17 +43,15 @@ data PackageError data PackageWarning = NoResolvedVersion PackageName - | UndeclaredDependency PackageName | UnacceptableVersion (PackageName, Text) | DirtyWorkingTree_Warn - | MissingPath PackageName deriving (Show) -- | An error that should be fixed by the user. data UserError = PackageManifestNotFound | ResolutionsFileNotFound - | CouldntDecodePackageManifest (ParseError ManifestError) + | CouldntDecodePackageManifest (ParseError D.ManifestError) | TagMustBeCheckedOut | AmbiguousVersions [Version] -- Invariant: should contain at least two elements | BadRepositoryField RepositoryFieldError @@ -63,6 +60,7 @@ data UserError | MissingDependencies (NonEmpty PackageName) | CompileError P.MultipleErrors | DirtyWorkingTree + | ResolutionsFileError FilePath (ParseError D.PackageError) deriving (Show) data RepositoryFieldError @@ -71,11 +69,9 @@ data RepositoryFieldError | NotOnGithub deriving (Show) - -- | An error that probably indicates a bug in this module. data InternalError - = JSONError JSONSource (ParseError ManifestError) - | CouldntParseGitTagDate Text + = CouldntParseGitTagDate Text deriving (Show) data JSONSource @@ -221,6 +217,10 @@ displayUserError e = case e of "Your git working tree is dirty. Please commit, discard, or stash " ++ "your changes first." ) + ResolutionsFileError path err -> + successivelyIndented $ + [ "Error in resolutions file (" ++ path ++ "):" ] + ++ map T.unpack (displayError D.displayPackageError err) spdxExamples :: [Box] spdxExamples = @@ -276,21 +276,10 @@ displayRepositoryError err = case err of displayInternalError :: InternalError -> [String] displayInternalError e = case e of - JSONError src r -> - [ "Error in JSON " ++ displayJSONSource src ++ ":" - , T.unpack (Bower.displayError r) - ] CouldntParseGitTagDate tag -> [ "Unable to parse the date for a git tag: " ++ T.unpack tag ] -displayJSONSource :: JSONSource -> String -displayJSONSource s = case s of - FromFile fp -> - "in file " ++ show fp - FromResolutions -> - "in resolutions file" - displayOtherError :: OtherError -> Box displayOtherError e = case e of ProcessFailed prog args exc -> @@ -304,41 +293,35 @@ displayOtherError e = case e of data CollectedWarnings = CollectedWarnings { noResolvedVersions :: [PackageName] - , undeclaredDependencies :: [PackageName] , unacceptableVersions :: [(PackageName, Text)] , dirtyWorkingTree :: Any - , missingPaths :: [PackageName] } deriving (Show, Eq, Ord) instance Semigroup CollectedWarnings where - (CollectedWarnings as bs cs d es) <> (CollectedWarnings as' bs' cs' d' es') = - CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') (d <> d') (es <> es') + (<>) (CollectedWarnings a b c) (CollectedWarnings a' b' c') = + CollectedWarnings (a <> a') (b <> b') (c <> c') instance Monoid CollectedWarnings where - mempty = CollectedWarnings mempty mempty mempty mempty mempty + mempty = CollectedWarnings mempty mempty mempty collectWarnings :: [PackageWarning] -> CollectedWarnings collectWarnings = foldMap singular where singular w = case w of - NoResolvedVersion pn -> CollectedWarnings [pn] mempty mempty mempty mempty - UndeclaredDependency pn -> CollectedWarnings mempty [pn] mempty mempty mempty - UnacceptableVersion t -> CollectedWarnings mempty mempty [t] mempty mempty - DirtyWorkingTree_Warn -> CollectedWarnings mempty mempty mempty (Any True) mempty - MissingPath pn -> CollectedWarnings mempty mempty mempty mempty [pn] + NoResolvedVersion pn -> mempty { noResolvedVersions = [pn] } + UnacceptableVersion t -> mempty { unacceptableVersions = [t] } + DirtyWorkingTree_Warn -> mempty { dirtyWorkingTree = Any True } renderWarnings :: [PackageWarning] -> Box renderWarnings warns = let CollectedWarnings{..} = collectWarnings warns go toBox warns' = toBox <$> NonEmpty.nonEmpty warns' mboxes = [ go warnNoResolvedVersions noResolvedVersions - , go warnUndeclaredDependencies undeclaredDependencies , go warnUnacceptableVersions unacceptableVersions , if getAny dirtyWorkingTree then Just warnDirtyWorkingTree else Nothing - , go warnMissingPaths missingPaths ] in case catMaybes mboxes of [] -> nullBox @@ -369,21 +352,6 @@ warnNoResolvedVersions pkgNames = ]) ] -warnUndeclaredDependencies :: NonEmpty PackageName -> Box -warnUndeclaredDependencies pkgNames = - let singular = NonEmpty.length pkgNames == 1 - pl a b = if singular then b else a - - packages = pl "packages" "package" - are = pl "are" "is" - dependencies = pl "dependencies" "a dependency" - in vcat $ - para (concat - [ "The following ", packages, " ", are, " installed, but not " - , "declared as ", dependencies, " in your package manifest file:" - ]) - : bulletedListT runPackageName (NonEmpty.toList pkgNames) - warnUnacceptableVersions :: NonEmpty (PackageName, Text) -> Box warnUnacceptableVersions pkgs = let singular = NonEmpty.length pkgs == 1 @@ -419,18 +387,5 @@ warnDirtyWorkingTree = ++ "were not a dry run)" ) -warnMissingPaths :: NonEmpty PackageName -> Box -warnMissingPaths pkgs = - let singular = NonEmpty.length pkgs == 1 - pl a b = if singular then b else a - - packages = pl "packages" "package" - in vcat $ - para (concat - [ "The following installed ", packages, " were " - , "missing path information in the resolutions file:" - ]) - : bulletedListT runPackageName (NonEmpty.toList pkgs) - printWarnings :: [PackageWarning] -> IO () printWarnings = printToStderr . renderWarnings diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index d32853e7a6..866f3d018d 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -29,10 +29,21 @@ main = testSpec "publish" spec spec :: Spec spec = do - it "roundtrips the json for purescript-prelude" $ do - testPackage - "tests/support/bower_components/purescript-prelude" - "../../prelude-resolutions.json" + context "preparePackage with json roundtrips" $ do + it "purescript-prelude" $ do + testPackage + "tests/support/bower_components/purescript-prelude" + "../../prelude-resolutions.json" + + it "basic example" $ do + testPackage + "tests/purs/publish/basic-example" + "resolutions.json" + + it "basic example with legacy resolutions file" $ do + testPackage + "tests/purs/publish/basic-example" + "resolutions-legacy.json" context "json compatibility" $ do let compatDir = "tests" "json-compat" diff --git a/tests/purs/publish/basic-example/README.md b/tests/purs/publish/basic-example/README.md new file mode 100644 index 0000000000..5b441e1ca7 --- /dev/null +++ b/tests/purs/publish/basic-example/README.md @@ -0,0 +1,5 @@ +This directory contains a basic synthetic example project for testing `purs +publish` with. Although it claims to depend upon `purescript-prelude`, +`purescript-console`, and `purescript-effect`, we don't reproduce the real +libraries here; instead, we just provide a couple of declarations for the +purpose of testing. diff --git a/tests/purs/publish/basic-example/bower.json b/tests/purs/publish/basic-example/bower.json new file mode 100644 index 0000000000..23962c2c94 --- /dev/null +++ b/tests/purs/publish/basic-example/bower.json @@ -0,0 +1,13 @@ +{ + "name": "basic-example", + "repository": { + "type": "git", + "url": "https://github.com/purescript/test.git" + }, + "license": "MIT", + "dependencies": { + "purescript-console": "^1.0.0", + "purescript-prelude": "^1.0.0", + "purescript-effect": "^1.0.0" + } +} diff --git a/tests/purs/publish/basic-example/resolutions-legacy.json b/tests/purs/publish/basic-example/resolutions-legacy.json new file mode 100644 index 0000000000..460522aaeb --- /dev/null +++ b/tests/purs/publish/basic-example/resolutions-legacy.json @@ -0,0 +1,269 @@ +{ + "endpoint": { + "name": "basic-example", + "source": ".", + "target": "*" + }, + "canonicalDir": ".", + "pkgMeta": { + "name": "basic-example", + "ignore": [ + "**/.*", + "node_modules", + "bower_components", + "output" + ], + "dependencies": { + "purescript-prelude": "^4.1.0", + "purescript-console": "^4.2.0", + "purescript-effect": "^2.0.1" + } + }, + "dependencies": { + "purescript-console": { + "endpoint": { + "name": "purescript-console", + "source": "purescript-console", + "target": "^4.2.0" + }, + "canonicalDir": "../../../support/bower_components/purescript-console", + "pkgMeta": { + "name": "purescript-console", + "homepage": "https://github.com/purescript/purescript-console", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-console.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "dependencies": { + "purescript-effect": "^2.0.0", + "purescript-prelude": "^4.0.0" + }, + "version": "4.2.0", + "_release": "4.2.0", + "_resolution": { + "type": "version", + "tag": "v4.2.0", + "commit": "add2bdb8a4af2213d993b728805f1f2a5e76deb8" + }, + "_source": "https://github.com/purescript/purescript-console.git", + "_target": "^4.2.0", + "_originalSource": "purescript-console", + "_direct": true + }, + "dependencies": { + "purescript-effect": { + "endpoint": { + "name": "purescript-effect", + "source": "purescript-effect", + "target": "^2.0.0" + }, + "canonicalDir": "../../../support/bower_components/purescript-effect", + "pkgMeta": { + "name": "purescript-effect", + "homepage": "https://github.com/purescript/purescript-effect", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-effect.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "dependencies": { + "purescript-prelude": "^4.0.0" + }, + "version": "2.0.1", + "_release": "2.0.1", + "_resolution": { + "type": "version", + "tag": "v2.0.1", + "commit": "d2a11e69abcda3b81c750e86e8746cda278f47bf" + }, + "_source": "https://github.com/purescript/purescript-effect.git", + "_target": "^2.0.0", + "_originalSource": "purescript-effect" + }, + "dependencies": { + "purescript-prelude": { + "endpoint": { + "name": "purescript-prelude", + "source": "purescript-prelude", + "target": "^4.0.0" + }, + "canonicalDir": "../../../support/bower_components/purescript-prelude", + "pkgMeta": { + "name": "purescript-prelude", + "homepage": "https://github.com/purescript/purescript-prelude", + "description": "The PureScript Prelude", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-prelude.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "version": "4.1.0", + "_release": "4.1.0", + "_resolution": { + "type": "version", + "tag": "v4.1.0", + "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" + }, + "_source": "https://github.com/purescript/purescript-prelude.git", + "_target": "^4.0.0", + "_originalSource": "purescript-prelude" + }, + "dependencies": {}, + "nrDependants": 3 + } + }, + "nrDependants": 2 + }, + "purescript-prelude": { + "endpoint": { + "name": "purescript-prelude", + "source": "purescript-prelude", + "target": "^4.0.0" + }, + "canonicalDir": "../../../support/bower_components/purescript-prelude", + "pkgMeta": { + "name": "purescript-prelude", + "homepage": "https://github.com/purescript/purescript-prelude", + "description": "The PureScript Prelude", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-prelude.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "version": "4.1.0", + "_release": "4.1.0", + "_resolution": { + "type": "version", + "tag": "v4.1.0", + "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" + }, + "_source": "https://github.com/purescript/purescript-prelude.git", + "_target": "^4.0.0", + "_originalSource": "purescript-prelude" + }, + "dependencies": {}, + "nrDependants": 3 + } + }, + "nrDependants": 1 + }, + "purescript-effect": { + "endpoint": { + "name": "purescript-effect", + "source": "purescript-effect", + "target": "^2.0.1" + }, + "canonicalDir": "../../../support/bower_components/purescript-effect", + "pkgMeta": { + "name": "purescript-effect", + "homepage": "https://github.com/purescript/purescript-effect", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-effect.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "dependencies": { + "purescript-prelude": "^4.0.0" + }, + "version": "2.0.1", + "_release": "2.0.1", + "_resolution": { + "type": "version", + "tag": "v2.0.1", + "commit": "d2a11e69abcda3b81c750e86e8746cda278f47bf" + }, + "_source": "https://github.com/purescript/purescript-effect.git", + "_target": "^2.0.0", + "_originalSource": "purescript-effect" + }, + "dependencies": {}, + "nrDependants": 1 + }, + "purescript-prelude": { + "endpoint": { + "name": "purescript-prelude", + "source": "purescript-prelude", + "target": "^4.1.0" + }, + "canonicalDir": "../../../support/bower_components/purescript-prelude", + "pkgMeta": { + "name": "purescript-prelude", + "homepage": "https://github.com/purescript/purescript-prelude", + "description": "The PureScript Prelude", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-prelude.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "version": "4.1.0", + "_release": "4.1.0", + "_resolution": { + "type": "version", + "tag": "v4.1.0", + "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" + }, + "_source": "https://github.com/purescript/purescript-prelude.git", + "_target": "^4.0.0", + "_originalSource": "purescript-prelude" + }, + "dependencies": {}, + "nrDependants": 1 + } + }, + "nrDependants": 0 +} diff --git a/tests/purs/publish/basic-example/resolutions.json b/tests/purs/publish/basic-example/resolutions.json new file mode 100644 index 0000000000..88b665b02a --- /dev/null +++ b/tests/purs/publish/basic-example/resolutions.json @@ -0,0 +1,14 @@ +{ + "purescript-console": { + "version": "1.0.0", + "path": "../../../support/bower_components/purescript-console" + }, + "purescript-effect": { + "version": "1.0.0", + "path": "../../../support/bower_components/purescript-effect" + }, + "purescript-prelude": { + "version": "1.0.0", + "path": "../../../support/bower_components/purescript-prelude" + } +} diff --git a/tests/purs/publish/basic-example/src/Main.purs b/tests/purs/publish/basic-example/src/Main.purs new file mode 100644 index 0000000000..87e47b003a --- /dev/null +++ b/tests/purs/publish/basic-example/src/Main.purs @@ -0,0 +1,8 @@ +module Main where + +import Prelude +import Effect (Effect) +import Effect.Console (log) + +main :: Effect Unit +main = log ("hello, " <> "world!") diff --git a/tests/support/prelude-resolutions.json b/tests/support/prelude-resolutions.json index a5704c44b1..0967ef424b 100644 --- a/tests/support/prelude-resolutions.json +++ b/tests/support/prelude-resolutions.json @@ -1,7 +1 @@ -{ - "canonicalDir": "bower_components/purescript-prelude", - "pkgMeta": { - "dependencies": {} - }, - "dependencies": {} -} +{} From 48bf49632595f62e87c30ec069436ae47dc765cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Mateusz=20Cury=C5=82o?= Date: Tue, 26 Mar 2019 16:07:34 +0000 Subject: [PATCH 1070/1580] Naming a constructor PS brakes the javascript no more. (#3533) Introduced test for psc-bundle. reference --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Bundle.hs | 28 +++-- tests/Main.hs | 3 + tests/TestBundle.hs | 94 ++++++++++++++++ tests/TestCompiler.hs | 142 ++----------------------- tests/TestUtils.hs | 141 +++++++++++++++++++++++- tests/purs/bundle/PSasConstructor.purs | 11 ++ 7 files changed, 275 insertions(+), 145 deletions(-) create mode 100644 tests/TestBundle.hs create mode 100644 tests/purs/bundle/PSasConstructor.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index dffc5a2198..82b280eaaf 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -68,6 +68,7 @@ If you would prefer to use different terms, please use the section below instead | [@lukerandall](https://github.com/lukerandall) | Luke Randall | [MIT license](http://opensource.org/licenses/MIT) | | [@matthewleon](https://github.com/matthewleon) | Matthew Leon | [MIT license](http://opensource.org/licenses/MIT) | | [@mcoffin](https://github.com/mcoffin) | Matt Coffin | [MIT license](http://opensource.org/licenses/MIT) | +| [@mhcurylo](https://github.com/mhcurylo) | Mateusz Curylo | [MIT license](http://opensource.org/licenses/MIT) | | [@MiracleBlue](https://github.com/MiracleBlue) | Nicholas Kircher | [MIT license](http://opensource.org/licenses/MIT) | | [@mrkgnao](https://github.com/mrkgnao) | Soham Chowdhury | [MIT license](http://opensource.org/licenses/MIT) | | [@mgmeier](https://github.com/mgmeier) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 2943ef3114..30121823ca 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -586,7 +586,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o JSVariable lfsp (cList [ JSVarInitExpression (JSIdentifier sp nm) - (JSVarInit sp $ either require (moduleReference sp . moduleName) req ) + (JSVarInit sp $ either require (innerModuleReference sp . moduleName) req ) ]) (JSSemi JSNoAnnot) ] declToJS (ExportsList exps) = withLength $ map toExport exps @@ -642,6 +642,12 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o JSMemberSquare (JSIdentifier a optionsNamespace) JSNoAnnot (str mn) JSNoAnnot + innerModuleReference :: JSAnnot -> String -> JSExpression + innerModuleReference a mn = + JSMemberSquare (JSIdentifier a "$PS") JSNoAnnot + (str mn) JSNoAnnot + + str :: String -> JSExpression str s = JSStringLiteral JSNoAnnot $ "\"" ++ s ++ "\"" @@ -652,17 +658,27 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o wrap :: String -> [JSStatement] -> [JSStatement] wrap mn ds = [ - JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot - (JSLOne (JSIdentName JSNoAnnot "exports")) JSNoAnnot - (JSBlock sp (lfHead ds) lf)) -- \n not quite in right place + JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot (JSLOne (JSIdentName JSNoAnnot "$PS")) JSNoAnnot + (JSBlock sp (addModuleExports ds) lf)) -- \n not quite in right place JSNoAnnot) JSNoAnnot - (JSLOne (JSAssignExpression (moduleReference JSNoAnnot mn) (JSAssign sp) - (JSExpressionBinary (moduleReference sp mn) (JSBinOpOr sp) (emptyObj sp)))) + (JSLOne (JSIdentifier JSNoAnnot optionsNamespace)) JSNoAnnot (JSSemi JSNoAnnot) ] where + addModuleExports :: [JSStatement] -> [JSStatement] + addModuleExports [] = lfHead moduleExports + addModuleExports (x:xs) = lfHead [x] ++ moduleExports ++ xs + moduleExports = + [ + JSExpressionStatement (JSAssignExpression (innerModuleReference lfsp mn) + (JSAssign sp) + (JSExpressionBinary (innerModuleReference sp mn) (JSBinOpOr sp) (emptyObj sp))) + (JSSemi JSAnnotSpace), + JSVariable lfsp (JSLOne $ JSVarInitExpression (JSIdentifier sp "exports") $ JSVarInit sp (innerModuleReference sp mn)) + (JSSemi JSNoAnnot) + ] lfHead (h:t) = addAnn (WhiteSpace tokenPosnEmpty "\n ") h : t lfHead x = x diff --git a/tests/Main.hs b/tests/Main.hs index 9179573b3d..e7c29b4094 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -18,6 +18,7 @@ import qualified TestPrimDocs import qualified TestPsci import qualified TestIde import qualified TestPscPublish +import qualified TestBundle import qualified TestUtils import System.IO (hSetEncoding, stdout, stderr, utf8) @@ -33,6 +34,7 @@ main = do ideTests <- TestIde.main compilerTests <- TestCompiler.main psciTests <- TestPsci.main + pscBundleTests <- TestBundle.main coreFnTests <- TestCoreFn.main docsTests <- TestDocs.main primDocsTests <- TestPrimDocs.main @@ -44,6 +46,7 @@ main = do "Tests" [ compilerTests , psciTests + , pscBundleTests , ideTests , coreFnTests , docsTests diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs new file mode 100644 index 0000000000..bdf017c504 --- /dev/null +++ b/tests/TestBundle.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module TestBundle where + +import Prelude () +import Prelude.Compat + +import qualified Language.PureScript as P +import Language.PureScript.Bundle + +import Data.Function (on) +import Data.List (minimumBy) + +import qualified Data.Map as M + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Except + +import System.Exit +import System.Process +import System.FilePath +import System.IO +import System.IO.UTF8 +import qualified System.FilePath.Glob as Glob + +import TestUtils +import Test.Tasty +import Test.Tasty.Hspec + +main :: IO TestTree +main = testSpec "bundle" spec + +spec :: Spec +spec = do + (supportModules, supportExterns, supportForeigns, [bundleTestCases]) <- runIO $ setUpTests ["bundle"] + outputFile <- runIO $ createOutputFile logfile + + context "Bundle examples" $ + forM_ bundleTestCases $ \testPurs -> do + it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile, bundle and run without error") $ + assertBundles supportModules supportExterns supportForeigns testPurs outputFile + where + + -- Takes the test entry point from a group of purs files - this is determined + -- by the file with the shortest path name, as everything but the main file + -- will be under a subdirectory. + getTestMain :: [FilePath] -> FilePath + getTestMain = minimumBy (compare `on` length) + +assertBundles + :: [P.Module] + -> [P.ExternsFile] + -> M.Map P.ModuleName FilePath + -> [FilePath] + -> Handle + -> Expectation +assertBundles supportModules supportExterns supportForeigns inputFiles outputFile = + assert supportModules supportExterns supportForeigns inputFiles checkMain $ \e -> + case e of + Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs + Right _ -> do + process <- findNodeProcess + jsFiles <- Glob.globDir1 (Glob.compile "**/*.js") modulesDir + let entryPoint = modulesDir "index.js" + let entryModule = map (`ModuleIdentifier` Regular) ["Main"] + bundled <- runExceptT $ do + input <- forM jsFiles $ \filename -> do + js <- liftIO $ readUTF8File filename + mid <- guessModuleIdentifier filename + length js `seq` return (mid, Just filename, js) + bundleSM input entryModule (Just $ "Main") "PS" (Just entryPoint) + case bundled of + Right (_, js) -> do + writeUTF8File entryPoint js + result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process + hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" + case result of + Just (ExitSuccess, out, err) + | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err + | not (null out) && trim (last (lines out)) == "Done" -> do + hPutStr outputFile out + return Nothing + | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out + Just (ExitFailure _, _, err) -> return $ Just err + Nothing -> return $ Just "Couldn't find node.js executable" + Left err -> return . Just $ "Coud not bundle: " ++ show err + +logfile :: FilePath +logfile = "bundle-tests.out" diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index ddd7eda7d6..24748ee030 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -26,29 +26,21 @@ import Prelude.Compat import qualified Language.PureScript as P -import Data.Char (isSpace) +import Control.Arrow ((>>>)) import Data.Function (on) -import Data.List (sort, stripPrefix, intercalate, groupBy, sortBy, minimumBy) +import Data.List (sort, stripPrefix, intercalate, minimumBy) import Data.Maybe (mapMaybe) -import Data.Time.Clock (UTCTime()) import qualified Data.Text as T -import Data.Tuple (swap) import qualified Data.Map as M import Control.Monad -import Control.Arrow ((***), (>>>)) - -import Control.Monad.Reader -import Control.Monad.Trans.Except import System.Exit -import System.Process hiding (cwd) +import System.Process import System.FilePath -import System.Directory import System.IO -import System.IO.UTF8 -import qualified System.FilePath.Glob as Glob +import System.IO.UTF8 (readUTF8File) import TestUtils import Test.Tasty @@ -59,29 +51,8 @@ main = testSpec "compiler" spec spec :: Spec spec = do - - (supportModules, supportExterns, supportForeigns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do - cwd <- getCurrentDirectory - let passing = cwd "tests" "purs" "passing" - let warning = cwd "tests" "purs" "warning" - let failing = cwd "tests" "purs" "failing" - passingFiles <- getTestFiles passing <$> testGlob passing - warningFiles <- getTestFiles warning <$> testGlob warning - failingFiles <- getTestFiles failing <$> testGlob failing - ms <- getSupportModuleTuples - let modules = map snd ms - supportExterns <- runExceptT $ do - foreigns <- inferForeignModules ms - externs <- ExceptT . fmap fst . runTest $ P.make (makeActions modules foreigns) modules - return (externs, foreigns) - case supportExterns of - Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) - Right (externs, foreigns) -> return (modules, externs, foreigns, passingFiles, warningFiles, failingFiles) - - outputFile <- runIO $ do - tmp <- getTemporaryDirectory - createDirectoryIfMissing False (tmp logpath) - openFile (tmp logpath logfile) WriteMode + (supportModules, supportExterns, supportForeigns, [passingTestCases, warningTestCases, failingTestCases]) <- runIO $ setUpTests ["passing", "warning", "failing"] + outputFile <- runIO $ createOutputFile logfile context "Passing examples" $ forM_ passingTestCases $ \testPurs -> @@ -104,36 +75,12 @@ spec = do where - -- A glob for all purs and js files within a test directory - testGlob :: FilePath -> IO [FilePath] - testGlob = Glob.globDir1 (Glob.compile "**/*.purs") - - -- Groups the test files so that a top-level file can have dependencies in a - -- subdirectory of the same name. The inner tuple contains a list of the - -- .purs files and the .js files for the test case. - getTestFiles :: FilePath -> [FilePath] -> [[FilePath]] - getTestFiles baseDir - = map (filter ((== ".purs") . takeExtensions) . map (baseDir )) - . groupBy ((==) `on` extractPrefix) - . sortBy (compare `on` extractPrefix) - . map (makeRelative baseDir) - -- Takes the test entry point from a group of purs files - this is determined -- by the file with the shortest path name, as everything but the main file -- will be under a subdirectory. getTestMain :: [FilePath] -> FilePath getTestMain = minimumBy (compare `on` length) - -- Extracts the filename part of a .purs file, or if the file is in a - -- subdirectory, the first part of that directory path. - extractPrefix :: FilePath -> FilePath - extractPrefix fp = - let dir = takeDirectory fp - ext = reverse ".purs" - in if dir == "." - then maybe fp reverse $ stripPrefix ext $ reverse fp - else dir - -- Scans a file for @shouldFailWith directives in the comments, used to -- determine expected failures getShouldFailWith :: FilePath -> IO [String] @@ -147,80 +94,8 @@ spec = do extractPragma :: String -> FilePath -> IO [String] extractPragma pragma = fmap go . readUTF8File where - go = lines >>> mapMaybe (stripPrefix ("-- @" ++ pragma ++ " ")) >>> map trim - -inferForeignModules - :: MonadIO m - => [(FilePath, P.Module)] - -> m (M.Map P.ModuleName FilePath) -inferForeignModules = P.inferForeignModules . fromList - where - fromList :: [(FilePath, P.Module)] -> M.Map P.ModuleName (Either P.RebuildPolicy FilePath) - fromList = M.fromList . map ((P.getModuleName *** Right) . swap) - -trim :: String -> String -trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse - -modulesDir :: FilePath -modulesDir = ".test_modules" "node_modules" - -makeActions :: [P.Module] -> M.Map P.ModuleName FilePath -> P.MakeActions P.Make -makeActions modules foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False) - { P.getInputTimestamp = getInputTimestamp - , P.getOutputTimestamp = getOutputTimestamp - , P.progress = const (pure ()) - } - where - getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime)) - getInputTimestamp mn - | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever) - | otherwise = return (Left P.RebuildAlways) - where - isSupportModule = flip elem (map (P.runModuleName . P.getModuleName) modules) - - getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime) - getOutputTimestamp mn = do - let filePath = modulesDir T.unpack (P.runModuleName mn) - exists <- liftIO $ doesDirectoryExist filePath - return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing) + go = lines >>> mapMaybe (stripPrefix ("-- @" ++ pragma ++ " ")) >>> map trim -runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors) -runTest = P.runMake P.defaultOptions - -compile - :: [P.Module] - -> [P.ExternsFile] - -> M.Map P.ModuleName FilePath - -> [FilePath] - -> ([P.Module] -> IO ()) - -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) -compile supportModules supportExterns supportForeigns inputFiles check = runTest $ do - fs <- liftIO $ readInput inputFiles - ms <- P.parseModulesFromFiles id fs - foreigns <- inferForeignModules ms - liftIO (check (map snd ms)) - let actions = makeActions supportModules (foreigns `M.union` supportForeigns) - case ms of - [singleModule] -> pure <$> P.rebuildModule actions supportExterns (snd singleModule) - _ -> P.make actions (supportModules ++ map snd ms) - -assert - :: [P.Module] - -> [P.ExternsFile] - -> M.Map P.ModuleName FilePath - -> [FilePath] - -> ([P.Module] -> IO ()) - -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String)) - -> Expectation -assert supportModules supportExterns supportForeigns inputFiles check f = do - (e, w) <- compile supportModules supportExterns supportForeigns inputFiles check - maybeErr <- f (const w <$> e) - maybe (return ()) expectationFailure maybeErr - -checkMain :: [P.Module] -> IO () -checkMain ms = - unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms) - (fail "Main module missing") checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String checkShouldFailWith expected errs = @@ -323,8 +198,5 @@ assertDoesNotCompile supportModules supportExterns supportForeigns inputFiles sh where noPreCheck = const (return ()) -logpath :: FilePath -logpath = "purescript-output" - logfile :: FilePath logfile = "psc-tests.out" diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 6c7080705b..2505ee6f6f 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + module TestUtils where @@ -7,20 +9,29 @@ import Prelude.Compat import qualified Language.PureScript as P +import Control.Arrow ((***), (>>>)) import Control.Monad +import Control.Monad.Reader import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Exception -import Data.List (sort) +import Data.Char (isSpace) +import Data.Function (on) +import Data.List (sort, sortBy, stripPrefix, groupBy) +import qualified Data.Map as M import qualified Data.Text as T -import System.Process +import Data.Time.Clock (UTCTime()) +import Data.Tuple (swap) +import System.Process hiding (cwd) import System.Directory import System.Info import System.IO.UTF8 (readUTF8FileT) import System.Exit (exitFailure) -import System.FilePath (()) +import System.FilePath import qualified System.FilePath.Glob as Glob -import System.IO (stderr, hPutStrLn) +import System.IO +import Test.Tasty.Hspec + findNodeProcess :: IO (Maybe String) findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names @@ -86,3 +97,125 @@ pushd dir act = do result <- try act :: IO (Either IOException a) setCurrentDirectory original either throwIO return result + + +createOutputFile :: FilePath -> IO Handle +createOutputFile logfileName = do + tmp <- getTemporaryDirectory + createDirectoryIfMissing False (tmp logpath) + openFile (tmp logpath logfileName) WriteMode + +setUpTests :: [FilePath] -> IO ([P.Module], [P.ExternsFile], M.Map P.ModuleName FilePath, [[[FilePath]]]) +setUpTests testDirs = do + cwd <- getCurrentDirectory + let testPaths = map (\p -> cwd "tests" "purs" p) testDirs + testFiles <- mapM (\p -> getTestFiles p <$> testGlob p) testPaths + ms <- getSupportModuleTuples + let modules = map snd ms + supportExterns <- runExceptT $ do + foreigns <- inferForeignModules ms + externs <- ExceptT . fmap fst . runTest $ P.make (makeActions modules foreigns) modules + return (externs, foreigns) + case supportExterns of + Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) + Right (externs, foreigns) -> return (modules, externs, foreigns, testFiles) + where + -- A glob for all purs and js files within a test directory + testGlob :: FilePath -> IO [FilePath] + testGlob = Glob.globDir1 (Glob.compile "**/*.purs") + -- Groups the test files so that a top-level file can have dependencies in a + -- subdirectory of the same name. The inner tuple contains a list of the + -- .purs files and the .js files for the test case. + getTestFiles :: FilePath -> [FilePath] -> [[FilePath]] + getTestFiles baseDir + = map (filter ((== ".purs") . takeExtensions) . map (baseDir )) + . groupBy ((==) `on` extractPrefix) + . sortBy (compare `on` extractPrefix) + . map (makeRelative baseDir) + -- Extracts the filename part of a .purs file, or if the file is in a + -- subdirectory, the first part of that directory path. + extractPrefix :: FilePath -> FilePath + extractPrefix fp = + let dir = takeDirectory fp + ext = reverse ".purs" + in if dir == "." + then maybe fp reverse $ stripPrefix ext $ reverse fp + else dir + +compile + :: [P.Module] + -> [P.ExternsFile] + -> M.Map P.ModuleName FilePath + -> [FilePath] + -> ([P.Module] -> IO ()) + -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) +compile supportModules supportExterns supportForeigns inputFiles check = runTest $ do + fs <- liftIO $ readInput inputFiles + ms <- P.parseModulesFromFiles id fs + foreigns <- inferForeignModules ms + liftIO (check (map snd ms)) + let actions = makeActions supportModules (foreigns `M.union` supportForeigns) + case ms of + [singleModule] -> pure <$> P.rebuildModule actions supportExterns (snd singleModule) + _ -> P.make actions (supportModules ++ map snd ms) + +assert + :: [P.Module] + -> [P.ExternsFile] + -> M.Map P.ModuleName FilePath + -> [FilePath] + -> ([P.Module] -> IO ()) + -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String)) + -> Expectation +assert supportModules supportExterns supportForeigns inputFiles check f = do + (e, w) <- compile supportModules supportExterns supportForeigns inputFiles check + maybeErr <- f (const w <$> e) + maybe (return ()) expectationFailure maybeErr + +checkMain :: [P.Module] -> IO () +checkMain ms = + unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms) + (fail "Main module missing") + + +makeActions :: [P.Module] -> M.Map P.ModuleName FilePath -> P.MakeActions P.Make +makeActions modules foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False) + { P.getInputTimestamp = getInputTimestamp + , P.getOutputTimestamp = getOutputTimestamp + , P.progress = const (pure ()) + } + where + getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime)) + getInputTimestamp mn + | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever) + | otherwise = return (Left P.RebuildAlways) + where + isSupportModule = flip elem (map (P.runModuleName . P.getModuleName) modules) + + getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime) + getOutputTimestamp mn = do + let filePath = modulesDir T.unpack (P.runModuleName mn) + exists <- liftIO $ doesDirectoryExist filePath + return (if exists then Just (P.internalError "getOutputTimestamp: read timestamp") else Nothing) + + +runTest :: P.Make a -> IO (Either P.MultipleErrors a, P.MultipleErrors) +runTest = P.runMake P.defaultOptions + +inferForeignModules + :: MonadIO m + => [(FilePath, P.Module)] + -> m (M.Map P.ModuleName FilePath) +inferForeignModules = P.inferForeignModules . fromList + where + fromList :: [(FilePath, P.Module)] -> M.Map P.ModuleName (Either P.RebuildPolicy FilePath) + fromList = M.fromList . map ((P.getModuleName *** Right) . swap) + +trim :: String -> String +trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse + +modulesDir :: FilePath +modulesDir = ".test_modules" "node_modules" + +logpath :: FilePath +logpath = "purescript-output" diff --git a/tests/purs/bundle/PSasConstructor.purs b/tests/purs/bundle/PSasConstructor.purs new file mode 100644 index 0000000000..d30721ae39 --- /dev/null +++ b/tests/purs/bundle/PSasConstructor.purs @@ -0,0 +1,11 @@ +module Main where + +import Prelude +import Effect (Effect) +import Effect.Console (log) + +data P = PS + +main :: Effect Unit +main = do + log "Done" From b83fb18c214cb24fce1a85dbfa1ce9503abaddd5 Mon Sep 17 00:00:00 2001 From: Saulius Skliutas Date: Tue, 26 Mar 2019 18:16:36 +0200 Subject: [PATCH 1071/1580] Error message for cyclic type class (#3381) * Add check for cycles in type class declarations * More informative error messages * Remove unnecessary pattern --- CONTRIBUTORS.md | 1 + src/Language/PureScript/AST/Declarations.hs | 1 + src/Language/PureScript/Errors.hs | 8 +++++ src/Language/PureScript/Sugar/TypeClasses.hs | 34 +++++++++++++++----- tests/purs/failing/Superclasses2.purs | 3 +- 5 files changed, 37 insertions(+), 10 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 82b280eaaf..eee955bb97 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -130,6 +130,7 @@ If you would prefer to use different terms, please use the section below instead | [@gabejohnson](https://github.com/gabejohnson) | Gabe Johnson | [MIT license](http://opensource.org/licenses/MIT) | | [@dariooddenino](https://github.com/dariooddenino) | Dario Oddenino | [MIT license](http://opensource.org/licenses/MIT) | | [@jordanmartinez](https://github.com/jordanmartinez) | Jordan Martinez | [MIT license](http://opensource.org/licenses/MIT) | +| [@Saulukass](https://github.com/Saulukass) | Saulius Skliutas | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 4603d5063b..f2e6a2e3c6 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -100,6 +100,7 @@ data SimpleErrorMessage | InvalidDoLet | CycleInDeclaration Ident | CycleInTypeSynonym (Maybe (ProperName 'TypeName)) + | CycleInTypeClassDeclaration [(ProperName 'ClassName)] | CycleInModules [ModuleName] | NameIsUndefined Ident | UndefinedTypeVariable (ProperName 'TypeName) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index f9065bdc29..3bc5a6bf76 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -110,6 +110,7 @@ errorCode em = case unwrapErrorMessage em of InvalidDoLet -> "InvalidDoLet" CycleInDeclaration{} -> "CycleInDeclaration" CycleInTypeSynonym{} -> "CycleInTypeSynonym" + CycleInTypeClassDeclaration{} -> "CycleInTypeClassDeclaration" CycleInModules{} -> "CycleInModules" NameIsUndefined{} -> "NameIsUndefined" UndefinedTypeVariable{} -> "UndefinedTypeVariable" @@ -574,6 +575,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , line "Cycles are disallowed because they can lead to loops in the type checker." , line "Consider using a 'newtype' instead." ] + renderSimpleErrorMessage (CycleInTypeClassDeclaration [name]) = + paras [ line $ "A type class '" <> markCode (runProperName name) <> "' may not have itself as a superclass." ] + renderSimpleErrorMessage (CycleInTypeClassDeclaration names) = + paras [ line $ "A cycle appears in a set of type class definitions:" + , indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName) names)) <> "}" + , line "Cycles are disallowed because they can lead to loops in the type checker." + ] renderSimpleErrorMessage (NameIsUndefined ident) = line $ "Value " <> markCode (showIdent ident) <> " is undefined." renderSimpleErrorMessage (UndefinedTypeVariable name) = diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 08e4af2b92..734a98aca0 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -14,7 +14,8 @@ import Control.Arrow (first, second) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State import Control.Monad.Supply.Class -import Data.List (find, sortBy) +import Data.Graph +import Data.List (find, partition) import qualified Data.Map as M import Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe) import qualified Data.List.NonEmpty as NEL @@ -72,14 +73,31 @@ desugarModule => Module -> Desugar m Module desugarModule (Module ss coms name decls (Just exps)) = do - (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps) - return $ Module ss coms name (concat declss) $ Just (exps ++ catMaybes newExpss) + let (classDecls, restDecls) = partition isTypeClassDeclaration decls + classVerts = fmap (\d -> (d, classDeclName d, superClassesNames d)) classDecls + (classNewExpss, classDeclss) <- unzip <$> parU (stronglyConnComp classVerts) (desugarClassDecl name exps) + (restNewExpss, restDeclss) <- unzip <$> parU restDecls (desugarDecl name exps) + return $ Module ss coms name (concat restDeclss ++ concat classDeclss) $ Just (exps ++ catMaybes restNewExpss ++ catMaybes classNewExpss) where - classesFirst :: Declaration -> Declaration -> Ordering - classesFirst d1 d2 - | isTypeClassDeclaration d1 && not (isTypeClassDeclaration d2) = LT - | not (isTypeClassDeclaration d1) && isTypeClassDeclaration d2 = GT - | otherwise = EQ + desugarClassDecl :: (MonadSupply m, MonadError MultipleErrors m) + => ModuleName + -> [DeclarationRef] + -> SCC Declaration + -> Desugar m (Maybe DeclarationRef, [Declaration]) + desugarClassDecl name' exps' (AcyclicSCC d) = desugarDecl name' exps' d + desugarClassDecl _ _ (CyclicSCC ds') = throwError . errorMessage' (declSourceSpan (head ds')) $ CycleInTypeClassDeclaration (map classDeclName ds') + + superClassesNames :: Declaration -> [ProperName 'ClassName] + superClassesNames (TypeClassDeclaration _ _ _ implies _ _) = fmap superClassName implies + superClassesNames _ = [] + + superClassName :: SourceConstraint -> ProperName 'ClassName + superClassName (Constraint _ (Qualified _ cName) _ _) = cName + + classDeclName :: Declaration -> ProperName 'ClassName + classDeclName (TypeClassDeclaration _ pn _ _ _ _) = pn + classDeclName _ = internalError "Expected TypeClassDeclaration" + desugarModule _ = internalError "Exports should have been elaborated in name desugaring" {- Desugar type class and type class instance declarations diff --git a/tests/purs/failing/Superclasses2.purs b/tests/purs/failing/Superclasses2.purs index 0c503494a9..3c86b7f6b7 100644 --- a/tests/purs/failing/Superclasses2.purs +++ b/tests/purs/failing/Superclasses2.purs @@ -1,5 +1,4 @@ --- @shouldFailWith CycleInTypeSynonym --- TODO: Should this have its own error, perhaps CycleInTypeClassDeclaration? +-- @shouldFailWith CycleInTypeClassDeclaration module CycleInSuperclasses where import Prelude From b3fcec93b7f37aaf9d7c594746eb02e64049d6b6 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 26 Mar 2019 22:12:27 +0000 Subject: [PATCH 1072/1580] Add test for resolved dependencies with no version (#3575) Previously, purs publish would fail when given any dependencies which did not resolve to a version (#3061). This bug was fixed by #3565. This commit just adds a test to verify that the bug has been fixed. --- .../basic-example/resolutions-legacy.json | 393 +++++++++++++++++- .../publish/basic-example/resolutions.json | 3 + .../purs/publish/basic-example/src/Main.purs | 10 +- 3 files changed, 394 insertions(+), 12 deletions(-) diff --git a/tests/purs/publish/basic-example/resolutions-legacy.json b/tests/purs/publish/basic-example/resolutions-legacy.json index 460522aaeb..c08e4d9fac 100644 --- a/tests/purs/publish/basic-example/resolutions-legacy.json +++ b/tests/purs/publish/basic-example/resolutions-legacy.json @@ -16,7 +16,11 @@ "dependencies": { "purescript-prelude": "^4.1.0", "purescript-console": "^4.2.0", - "purescript-effect": "^2.0.1" + "purescript-effect": "^2.0.1", + "purescript-newtype": "#master" + }, + "devDependencies": { + "purescript-psci-support": "^4.0.0" } }, "dependencies": { @@ -57,8 +61,7 @@ }, "_source": "https://github.com/purescript/purescript-console.git", "_target": "^4.2.0", - "_originalSource": "purescript-console", - "_direct": true + "_originalSource": "purescript-console" }, "dependencies": { "purescript-effect": { @@ -96,7 +99,7 @@ "commit": "d2a11e69abcda3b81c750e86e8746cda278f47bf" }, "_source": "https://github.com/purescript/purescript-effect.git", - "_target": "^2.0.0", + "_target": "^2.0.1", "_originalSource": "purescript-effect" }, "dependencies": { @@ -133,14 +136,14 @@ "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" }, "_source": "https://github.com/purescript/purescript-prelude.git", - "_target": "^4.0.0", + "_target": "^4.1.0", "_originalSource": "purescript-prelude" }, "dependencies": {}, - "nrDependants": 3 + "nrDependants": 1 } }, - "nrDependants": 2 + "nrDependants": 1 }, "purescript-prelude": { "endpoint": { @@ -175,11 +178,11 @@ "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" }, "_source": "https://github.com/purescript/purescript-prelude.git", - "_target": "^4.0.0", + "_target": "^4.1.0", "_originalSource": "purescript-prelude" }, "dependencies": {}, - "nrDependants": 3 + "nrDependants": 1 } }, "nrDependants": 1 @@ -219,12 +222,93 @@ "commit": "d2a11e69abcda3b81c750e86e8746cda278f47bf" }, "_source": "https://github.com/purescript/purescript-effect.git", - "_target": "^2.0.0", + "_target": "^2.0.1", "_originalSource": "purescript-effect" }, "dependencies": {}, "nrDependants": 1 }, + "purescript-newtype": { + "endpoint": { + "name": "purescript-newtype", + "source": "purescript-newtype", + "target": "master" + }, + "canonicalDir": "../../../support/bower_components/purescript-newtype", + "pkgMeta": { + "name": "purescript-newtype", + "homepage": "https://github.com/purescript/purescript-newtype", + "description": "Type class and functions for working with newtypes", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-newtype.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "dependencies": { + "purescript-prelude": "^4.0.0" + }, + "_release": "7d85fa6a04", + "_resolution": { + "type": "branch", + "branch": "master", + "commit": "7d85fa6a040208c010b05f7c23af6a943ba08763" + }, + "_source": "https://github.com/garyb/purescript-newtype.git", + "_target": "master", + "_originalSource": "purescript-newtype" + }, + "dependencies": { + "purescript-prelude": { + "endpoint": { + "name": "purescript-prelude", + "source": "purescript-prelude", + "target": "^4.0.0" + }, + "canonicalDir": "../../../support/bower_components/purescript-prelude", + "pkgMeta": { + "name": "purescript-prelude", + "homepage": "https://github.com/purescript/purescript-prelude", + "description": "The PureScript Prelude", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-prelude.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "version": "4.1.0", + "_release": "4.1.0", + "_resolution": { + "type": "version", + "tag": "v4.1.0", + "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" + }, + "_source": "https://github.com/purescript/purescript-prelude.git", + "_target": "^4.1.0", + "_originalSource": "purescript-prelude" + }, + "dependencies": {}, + "nrDependants": 1 + } + }, + "nrDependants": 1 + }, "purescript-prelude": { "endpoint": { "name": "purescript-prelude", @@ -258,11 +342,298 @@ "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" }, "_source": "https://github.com/purescript/purescript-prelude.git", - "_target": "^4.0.0", + "_target": "^4.1.0", "_originalSource": "purescript-prelude" }, "dependencies": {}, "nrDependants": 1 + }, + "purescript-psci-support": { + "endpoint": { + "name": "purescript-psci-support", + "source": "purescript-psci-support", + "target": "^4.0.0" + }, + "canonicalDir": "../../../support/bower_components/purescript-psci-support", + "pkgMeta": { + "name": "purescript-psci-support", + "homepage": "https://github.com/purescript/purescript-psci-support", + "description": "Support module for the PSCI interactive mode", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-psci-support.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "bower.json", + "package.json" + ], + "dependencies": { + "purescript-console": "^4.0.0", + "purescript-effect": "^2.0.0", + "purescript-prelude": "^4.0.0" + }, + "version": "4.0.0", + "_release": "4.0.0", + "_resolution": { + "type": "version", + "tag": "v4.0.0", + "commit": "a66a0fa8661eb8b5fe75cc862f4e2df2835c058d" + }, + "_source": "https://github.com/purescript/purescript-psci-support.git", + "_target": "^4.0.0", + "_originalSource": "purescript-psci-support" + }, + "dependencies": { + "purescript-console": { + "endpoint": { + "name": "purescript-console", + "source": "purescript-console", + "target": "^4.0.0" + }, + "canonicalDir": "../../../support/bower_components/purescript-console", + "pkgMeta": { + "name": "purescript-console", + "homepage": "https://github.com/purescript/purescript-console", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-console.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "dependencies": { + "purescript-effect": "^2.0.0", + "purescript-prelude": "^4.0.0" + }, + "version": "4.2.0", + "_release": "4.2.0", + "_resolution": { + "type": "version", + "tag": "v4.2.0", + "commit": "add2bdb8a4af2213d993b728805f1f2a5e76deb8" + }, + "_source": "https://github.com/purescript/purescript-console.git", + "_target": "^4.2.0", + "_originalSource": "purescript-console" + }, + "dependencies": { + "purescript-effect": { + "endpoint": { + "name": "purescript-effect", + "source": "purescript-effect", + "target": "^2.0.0" + }, + "canonicalDir": "../../../support/bower_components/purescript-effect", + "pkgMeta": { + "name": "purescript-effect", + "homepage": "https://github.com/purescript/purescript-effect", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-effect.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "dependencies": { + "purescript-prelude": "^4.0.0" + }, + "version": "2.0.1", + "_release": "2.0.1", + "_resolution": { + "type": "version", + "tag": "v2.0.1", + "commit": "d2a11e69abcda3b81c750e86e8746cda278f47bf" + }, + "_source": "https://github.com/purescript/purescript-effect.git", + "_target": "^2.0.1", + "_originalSource": "purescript-effect" + }, + "dependencies": { + "purescript-prelude": { + "endpoint": { + "name": "purescript-prelude", + "source": "purescript-prelude", + "target": "^4.0.0" + }, + "canonicalDir": "../../../support/bower_components/purescript-prelude", + "pkgMeta": { + "name": "purescript-prelude", + "homepage": "https://github.com/purescript/purescript-prelude", + "description": "The PureScript Prelude", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-prelude.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "version": "4.1.0", + "_release": "4.1.0", + "_resolution": { + "type": "version", + "tag": "v4.1.0", + "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" + }, + "_source": "https://github.com/purescript/purescript-prelude.git", + "_target": "^4.1.0", + "_originalSource": "purescript-prelude" + }, + "dependencies": {}, + "nrDependants": 1 + } + }, + "nrDependants": 1 + }, + "purescript-prelude": { + "endpoint": { + "name": "purescript-prelude", + "source": "purescript-prelude", + "target": "^4.0.0" + }, + "canonicalDir": "../../../support/bower_components/purescript-prelude", + "pkgMeta": { + "name": "purescript-prelude", + "homepage": "https://github.com/purescript/purescript-prelude", + "description": "The PureScript Prelude", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-prelude.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "version": "4.1.0", + "_release": "4.1.0", + "_resolution": { + "type": "version", + "tag": "v4.1.0", + "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" + }, + "_source": "https://github.com/purescript/purescript-prelude.git", + "_target": "^4.1.0", + "_originalSource": "purescript-prelude" + }, + "dependencies": {}, + "nrDependants": 1 + } + }, + "nrDependants": 1 + }, + "purescript-effect": { + "endpoint": { + "name": "purescript-effect", + "source": "purescript-effect", + "target": "^2.0.0" + }, + "canonicalDir": "../../../support/bower_components/purescript-effect", + "pkgMeta": { + "name": "purescript-effect", + "homepage": "https://github.com/purescript/purescript-effect", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-effect.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "dependencies": { + "purescript-prelude": "^4.0.0" + }, + "version": "2.0.1", + "_release": "2.0.1", + "_resolution": { + "type": "version", + "tag": "v2.0.1", + "commit": "d2a11e69abcda3b81c750e86e8746cda278f47bf" + }, + "_source": "https://github.com/purescript/purescript-effect.git", + "_target": "^2.0.1", + "_originalSource": "purescript-effect" + }, + "dependencies": {}, + "nrDependants": 1 + }, + "purescript-prelude": { + "endpoint": { + "name": "purescript-prelude", + "source": "purescript-prelude", + "target": "^4.0.0" + }, + "canonicalDir": "../../../support/bower_components/purescript-prelude", + "pkgMeta": { + "name": "purescript-prelude", + "homepage": "https://github.com/purescript/purescript-prelude", + "description": "The PureScript Prelude", + "license": "BSD-3-Clause", + "repository": { + "type": "git", + "url": "git://github.com/purescript/purescript-prelude.git" + }, + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "test", + "bower.json", + "package.json" + ], + "version": "4.1.0", + "_release": "4.1.0", + "_resolution": { + "type": "version", + "tag": "v4.1.0", + "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" + }, + "_source": "https://github.com/purescript/purescript-prelude.git", + "_target": "^4.1.0", + "_originalSource": "purescript-prelude" + }, + "dependencies": {}, + "nrDependants": 1 + } + }, + "nrDependants": 1 } }, "nrDependants": 0 diff --git a/tests/purs/publish/basic-example/resolutions.json b/tests/purs/publish/basic-example/resolutions.json index 88b665b02a..2e92161913 100644 --- a/tests/purs/publish/basic-example/resolutions.json +++ b/tests/purs/publish/basic-example/resolutions.json @@ -10,5 +10,8 @@ "purescript-prelude": { "version": "1.0.0", "path": "../../../support/bower_components/purescript-prelude" + }, + "purescript-newtype": { + "path": "../../../support/bower_components/purescript-newtype" } } diff --git a/tests/purs/publish/basic-example/src/Main.purs b/tests/purs/publish/basic-example/src/Main.purs index 87e47b003a..085a2dda35 100644 --- a/tests/purs/publish/basic-example/src/Main.purs +++ b/tests/purs/publish/basic-example/src/Main.purs @@ -3,6 +3,14 @@ module Main where import Prelude import Effect (Effect) import Effect.Console (log) +import Data.Newtype (class Newtype, un) + +newtype Target = Target String + +derive instance newtypeTarget :: Newtype Target _ + +greetingTarget :: Target +greetingTarget = Target "world" main :: Effect Unit -main = log ("hello, " <> "world!") +main = log ("hello, " <> un Target greetingTarget <> "!") From 5b0cf5894e8f39fd554f59f99c7ea642dcf066b0 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 26 Mar 2019 22:13:20 +0000 Subject: [PATCH 1073/1580] Warn when consuming the legacy resolutions file format (#3574) Implements the first part of #3573 --- src/Language/PureScript/Publish.hs | 25 +++++----- .../PureScript/Publish/ErrorsWarnings.hs | 48 ++++++++++++++----- 2 files changed, 47 insertions(+), 26 deletions(-) diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index e02e713d08..fc149595c8 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -25,8 +25,7 @@ import Control.Arrow ((***)) import Control.Category ((>>>)) import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell) -import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asString, asText) -import Data.Aeson.BetterErrors as ABE +import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asString, withString, asText, withText) import qualified Data.ByteString.Lazy as BL import Data.Char (isSpace) import Data.String (String, lines) @@ -288,18 +287,16 @@ parseResolutionsFile resolutionsFile = do unlessM (liftIO (doesFileExist resolutionsFile)) (userError ResolutionsFileNotFound) depsBS <- liftIO (BL.readFile resolutionsFile) - -- We use the legacy resolutions parser on the left of <|>, because if both - -- fail, <|> gives us the error from the parser on the right (i.e. from the - -- new-style parser). - -- - -- Note that the legacy parser is pretty much guaranteed to fail in the case - -- where we have been provided a new-style resolutions file because it always - -- has a few keys such as `canonicalDir` or `endpoint` which do not conform - -- to the format expected of new-style resolutions files. - catchJSON (parse (asLegacyResolutions ABE.<|> asResolutions) depsBS) - - where - catchJSON = flip catchLeft (userError . ResolutionsFileError resolutionsFile) + case parse asResolutions depsBS of + Right res -> + pure res + Left err -> + case parse asLegacyResolutions depsBS of + Right res -> do + warn $ LegacyResolutionsFormat resolutionsFile + pure res + Left _ -> + userError $ ResolutionsFileError resolutionsFile err -- | Parser for resolutions files, which contain information about the packages -- which this package depends on. A resolutions file should look something like diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 183fe2c639..84ec99957d 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -21,7 +21,8 @@ import Data.Aeson.BetterErrors (ParseError, displayError) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe -import Data.Monoid +import Data.Monoid hiding (First, getFirst) +import Data.Semigroup (First(..)) import Data.Version import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) @@ -45,6 +46,7 @@ data PackageWarning = NoResolvedVersion PackageName | UnacceptableVersion (PackageName, Text) | DirtyWorkingTree_Warn + | LegacyResolutionsFormat FilePath deriving (Show) -- | An error that should be fixed by the user. @@ -292,36 +294,43 @@ displayOtherError e = case e of [ "An IO exception occurred:", show exc ] data CollectedWarnings = CollectedWarnings - { noResolvedVersions :: [PackageName] - , unacceptableVersions :: [(PackageName, Text)] - , dirtyWorkingTree :: Any + { noResolvedVersions :: [PackageName] + , unacceptableVersions :: [(PackageName, Text)] + , dirtyWorkingTree :: Any + , legacyResolutionsFormat :: Maybe (First FilePath) } deriving (Show, Eq, Ord) instance Semigroup CollectedWarnings where - (<>) (CollectedWarnings a b c) (CollectedWarnings a' b' c') = - CollectedWarnings (a <> a') (b <> b') (c <> c') + (<>) (CollectedWarnings a b c d) (CollectedWarnings a' b' c' d') = + CollectedWarnings (a <> a') (b <> b') (c <> c') (d <> d') instance Monoid CollectedWarnings where - mempty = CollectedWarnings mempty mempty mempty + mempty = CollectedWarnings mempty mempty mempty mempty collectWarnings :: [PackageWarning] -> CollectedWarnings collectWarnings = foldMap singular where singular w = case w of - NoResolvedVersion pn -> mempty { noResolvedVersions = [pn] } - UnacceptableVersion t -> mempty { unacceptableVersions = [t] } - DirtyWorkingTree_Warn -> mempty { dirtyWorkingTree = Any True } + NoResolvedVersion pn -> + mempty { noResolvedVersions = [pn] } + UnacceptableVersion t -> + mempty { unacceptableVersions = [t] } + DirtyWorkingTree_Warn -> + mempty { dirtyWorkingTree = Any True } + LegacyResolutionsFormat path -> + mempty { legacyResolutionsFormat = Just (First path) } renderWarnings :: [PackageWarning] -> Box renderWarnings warns = let CollectedWarnings{..} = collectWarnings warns go toBox warns' = toBox <$> NonEmpty.nonEmpty warns' - mboxes = [ go warnNoResolvedVersions noResolvedVersions - , go warnUnacceptableVersions unacceptableVersions + mboxes = [ go warnNoResolvedVersions noResolvedVersions + , go warnUnacceptableVersions unacceptableVersions , if getAny dirtyWorkingTree then Just warnDirtyWorkingTree else Nothing + , fmap (warnLegacyResolutions . getFirst) legacyResolutionsFormat ] in case catMaybes mboxes of [] -> nullBox @@ -387,5 +396,20 @@ warnDirtyWorkingTree = ++ "were not a dry run)" ) +warnLegacyResolutions :: FilePath -> Box +warnLegacyResolutions path = + vcat $ + [ para (concat + [ "Your resolutions file (" ++ path ++ ") is using the deprecated " + , "legacy format. Support for this format will be dropped in a future " + , "version." + ]) + , spacer + , para (concat + [ "In most cases, all you need to do to use the new format and silence " + , "this warning is to upgrade Pulp." + ]) + ] + printWarnings :: [PackageWarning] -> IO () printWarnings = printToStderr . renderWarnings From fe4a13139b2dfdd92985af3dfe44d583b5d5ad6b Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sun, 31 Mar 2019 16:39:33 +0200 Subject: [PATCH 1074/1580] Updates for GHC 8.6.4 (#3560) * Updates for GHC 8.6.4 * updates for the newest "network" version * Enable -XNoMonadFailDesugaring This enables us to remove all references to MonadFail * Update tests to avoid using failable patterns * Revert changes to Interactive and Publish * Revert change to Prelude import in Control.Monad.Logger --- app/Command/Ide.hs | 49 ++++++++++---------- package.yaml | 3 +- src/Language/PureScript/Ide/CaseSplit.hs | 29 +++++++----- stack.yaml | 2 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 4 +- tests/TestBundle.hs | 3 +- tests/TestCompiler.hs | 10 +++- tests/TestDocs.hs | 12 ++--- tests/TestPscPublish.hs | 6 +-- tests/TestUtils.hs | 19 ++++---- 10 files changed, 78 insertions(+), 59 deletions(-) diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index a33c33d90a..73d7ecc927 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -37,10 +37,7 @@ import Language.PureScript.Ide.Util import Language.PureScript.Ide.Error import Language.PureScript.Ide.Types import Language.PureScript.Ide.Watcher -import Network hiding (socketPort, accept) -import Network.BSD (getProtocolNumber) -import Network.Socket hiding (PortNumber, Type, - sClose) +import qualified Network.Socket as Network import qualified Options.Applicative as Opts import System.Directory import System.Info as SysInfo @@ -48,24 +45,23 @@ import System.FilePath import System.IO hiding (putStrLn, print) import System.IO.Error (isEOFError) -listenOnLocalhost :: PortNumber -> IO Socket +listenOnLocalhost :: Network.PortNumber -> IO Network.Socket listenOnLocalhost port = do - proto <- getProtocolNumber "tcp" - localhost <- inet_addr "127.0.0.1" + addr:_ <- Network.getAddrInfo Nothing (Just "127.0.0.1") (Just (show port)) bracketOnError - (socket AF_INET Stream proto) - sClose + (Network.socket (Network.addrFamily addr) (Network.addrSocketType addr) (Network.addrProtocol addr)) + Network.close (\sock -> do - setSocketOption sock ReuseAddr 1 - bind sock (SockAddrInet port localhost) - listen sock maxListenQueue + Network.setSocketOption sock Network.ReuseAddr 1 + Network.bind sock (Network.addrAddress addr) + Network.listen sock Network.maxListenQueue pure sock) data ServerOptions = ServerOptions { _serverDirectory :: Maybe FilePath , _serverGlobs :: [FilePath] , _serverOutputPath :: FilePath - , _serverPort :: PortNumber + , _serverPort :: Network.PortNumber , _serverNoWatch :: Bool , _serverPolling :: Bool , _serverLoglevel :: IdeLogLevel @@ -73,7 +69,7 @@ data ServerOptions = ServerOptions } deriving (Show) data ClientOptions = ClientOptions - { clientPort :: PortID + { clientPort :: Network.PortNumber } command :: Opts.Parser (IO ()) @@ -96,15 +92,18 @@ command = Opts.helper <*> subcommands where T.putStrLn ("Couldn't connect to purs ide server on port " <> show clientPort <> ":") print e exitFailure - h <- connectTo "127.0.0.1" clientPort `catch` handler + addr:_ <- Network.getAddrInfo Nothing (Just "127.0.0.1") (Just (show clientPort)) + sock <- Network.socket (Network.addrFamily addr) (Network.addrSocketType addr) (Network.addrProtocol addr) + Network.connect sock (Network.addrAddress addr) `catch` handler + h <- Network.socketToHandle sock ReadWriteMode T.hPutStrLn h =<< T.getLine BS8.putStrLn =<< BS8.hGetLine h hFlush stdout hClose h clientOptions :: Opts.Parser ClientOptions - clientOptions = ClientOptions . PortNumber . fromIntegral <$> - Opts.option Opts.auto (Opts.long "port" <> Opts.short 'p' <> Opts.value (4242 :: Integer)) + clientOptions = ClientOptions . fromIntegral <$> + Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer)) server :: ServerOptions -> IO () server opts'@(ServerOptions dir globs outputPath port noWatch polling logLevel editorMode) = do @@ -159,12 +158,12 @@ command = Opts.helper <*> subcommands where -- #2209 and #2414 for explanations flipIfWindows = map (if SysInfo.os == "mingw32" then not else identity) -startServer :: PortNumber -> IdeEnvironment -> IO () -startServer port env = withSocketsDo $ do +startServer :: Network.PortNumber -> IdeEnvironment -> IO () +startServer port env = Network.withSocketsDo $ do sock <- listenOnLocalhost port runLogger (confLogLevel (ideConfiguration env)) (runReaderT (forever (loop sock)) env) where - loop :: (Ide m, MonadLogger m) => Socket -> m () + loop :: (Ide m, MonadLogger m) => Network.Socket -> m () loop sock = do accepted <- runExceptT (acceptCommand sock) case accepted of @@ -197,8 +196,10 @@ catchGoneHandle = putText ("[Error] psc-ide-server tried interact with the handle, but the connection was already gone.") _ -> throwIO e) -acceptCommand :: (MonadIO m, MonadLogger m, MonadError Text m) - => Socket -> m (Text, Handle) +acceptCommand + :: (MonadIO m, MonadLogger m, MonadError Text m) + => Network.Socket + -> m (Text, Handle) acceptCommand sock = do h <- acceptConnection $(logDebug) "Accepted a connection" @@ -216,8 +217,8 @@ acceptCommand sock = do where acceptConnection = liftIO $ do -- Use low level accept to prevent accidental reverse name resolution - (s,_) <- accept sock - h <- socketToHandle s ReadWriteMode + (s,_) <- Network.accept sock + h <- Network.socketToHandle s ReadWriteMode hSetEncoding h utf8 hSetBuffering h LineBuffering pure h diff --git a/package.yaml b/package.yaml index 4e41f35fce..43ffda4030 100644 --- a/package.yaml +++ b/package.yaml @@ -38,7 +38,7 @@ dependencies: - aeson-better-errors >=0.8 - ansi-terminal >=0.7.1 && <0.9 - array - - base >=4.8 && <4.12 + - base >=4.8 && <4.13 - base-compat >=0.6.0 - blaze-html >=0.8.1 && <0.10 - bower-json >=1.0.0.1 && <1.1 @@ -109,6 +109,7 @@ library: - ScopedTypeVariables - TupleSections - ViewPatterns + - NoMonadFailDesugaring executables: purs: diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 7596c5e396..253ef530e0 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -45,18 +45,24 @@ explicitAnnotations = WildcardAnnotations True noAnnotations :: WildcardAnnotations noAnnotations = WildcardAnnotations False -caseSplit :: (Ide m, MonadError IdeError m) => - Text -> m [Constructor] +type DataType = ([(Text, Maybe P.SourceKind)], [(P.ProperName 'P.ConstructorName, [P.SourceType])]) + +caseSplit + :: (Ide m, MonadError IdeError m) + => Text + -> m [Constructor] caseSplit q = do type' <- parseType' q (tc, args) <- splitTypeConstructor type' - (EDType _ _ (P.DataType typeVars ctors)) <- findTypeDeclaration tc + (typeVars, ctors) <- findTypeDeclaration tc let applyTypeVars = P.everywhereOnTypes (P.replaceAllTypeVars (zip (map fst typeVars) args)) let appliedCtors = map (second (map applyTypeVars)) ctors pure appliedCtors -findTypeDeclaration :: (Ide m, MonadError IdeError m) => - P.ProperName 'P.TypeName -> m ExternsDeclaration +findTypeDeclaration + :: (Ide m, MonadError IdeError m) + => P.ProperName 'P.TypeName + -> m DataType findTypeDeclaration q = do efs <- getExternFiles efs' <- maybe efs (flip (uncurry M.insert) efs) <$> cachedRebuild @@ -65,14 +71,15 @@ findTypeDeclaration q = do Just mn -> pure mn Nothing -> throwError (GeneralError "Not Found") -findTypeDeclaration' :: - P.ProperName 'P.TypeName +findTypeDeclaration' + :: P.ProperName 'P.TypeName -> ExternsFile - -> First ExternsDeclaration + -> First DataType findTypeDeclaration' t ExternsFile{..} = - First $ find (\case - EDType tn _ _ -> tn == t - _ -> False) efDeclarations + First $ head $ mapMaybe (\case + EDType tn _ (P.DataType typeVars ctors) + | tn == t -> Just (typeVars, ctors) + _ -> Nothing) efDeclarations splitTypeConstructor :: (MonadError IdeError m) => P.Type a -> m (P.ProperName 'P.TypeName, [P.Type a]) diff --git a/stack.yaml b/stack.yaml index a9982a62b0..ac8c3aa78f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-12.0 +resolver: lts-13.12 packages: - '.' extra-deps: diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 928a01c22d..5c29c86ac8 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -49,9 +49,9 @@ syntaxErrorFile = ] testSliceImportSection :: [Text] -> (P.ModuleName, [Text], [Import], [Text]) -testSliceImportSection = fromRight . sliceImportSection +testSliceImportSection = unsafeFromRight . sliceImportSection where - fromRight = fromJust . rightToMaybe + unsafeFromRight = fromJust . rightToMaybe withImports :: [Text] -> [Text] withImports is = diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs index bdf017c504..cbdcf68e1c 100644 --- a/tests/TestBundle.hs +++ b/tests/TestBundle.hs @@ -37,7 +37,8 @@ main = testSpec "bundle" spec spec :: Spec spec = do - (supportModules, supportExterns, supportForeigns, [bundleTestCases]) <- runIO $ setUpTests ["bundle"] + (supportModules, supportExterns, supportForeigns) <- runIO $ setupSupportModules + bundleTestCases <- runIO $ getTestFiles "bundle" outputFile <- runIO $ createOutputFile logfile context "Bundle examples" $ diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 24748ee030..5c082dafa3 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -51,8 +51,14 @@ main = testSpec "compiler" spec spec :: Spec spec = do - (supportModules, supportExterns, supportForeigns, [passingTestCases, warningTestCases, failingTestCases]) <- runIO $ setUpTests ["passing", "warning", "failing"] - outputFile <- runIO $ createOutputFile logfile + (supportModules, supportExterns, supportForeigns) <- runIO $ setupSupportModules + + (passingTestCases, warningTestCases, failingTestCases) <- runIO $ + (,,) <$> getTestFiles "passing" + <*> getTestFiles "warning" + <*> getTestFiles "failing" + + outputFile <- runIO $ createOutputFile logfile context "Passing examples" $ forM_ passingTestCases $ \testPurs -> diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index ef5e130502..9c7bdfbc9f 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -294,8 +294,8 @@ displayAssertionFailure = \case "in rendered code for " <> decl <> ", bad link location for " <> target <> ": expected " <> T.pack (show expected) <> " got " <> T.pack (show actual) - WrongOrder _ before after -> - "expected to see " <> before <> " before " <> after + WrongOrder _ before after' -> + "expected to see " <> before <> " before " <> after' displayTagsAssertionFailure :: TagsAssertionFailure -> Text displayTagsAssertionFailure = \case @@ -438,22 +438,22 @@ runAssertion assertion linksCtx Docs.Module{..} = Nothing -> Fail (LinkedDeclarationMissing mn decl destTitle) - ShouldComeBefore mn before after -> + ShouldComeBefore mn before after' -> let decls = declarationsFor mn indexOf :: Text -> Maybe Int indexOf title = findIndex ((==) title . Docs.declTitle) decls in - case (indexOf before, indexOf after) of + case (indexOf before, indexOf after') of (Just i, Just j) -> if i < j then Pass - else Fail (WrongOrder mn before after) + else Fail (WrongOrder mn before after') (Nothing, _) -> Fail (NotDocumented mn before) (_, Nothing) -> - Fail (NotDocumented mn after) + Fail (NotDocumented mn after') where declarationsFor mn = diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 866f3d018d..64dda760b9 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -72,10 +72,10 @@ roundTrip pkg = in case A.eitherDecode before of Left err -> ParseFailed err Right parsed -> do - let after = A.encode (parsed :: UploadedPackage) - if before == after + let after' = A.encode (parsed :: UploadedPackage) + if before == after' then Pass before - else Mismatch before after + else Mismatch before after' testRunOptions :: PublishOptions testRunOptions = defaultPublishOptions diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 2505ee6f6f..59540d503f 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -105,11 +105,8 @@ createOutputFile logfileName = do createDirectoryIfMissing False (tmp logpath) openFile (tmp logpath logfileName) WriteMode -setUpTests :: [FilePath] -> IO ([P.Module], [P.ExternsFile], M.Map P.ModuleName FilePath, [[[FilePath]]]) -setUpTests testDirs = do - cwd <- getCurrentDirectory - let testPaths = map (\p -> cwd "tests" "purs" p) testDirs - testFiles <- mapM (\p -> getTestFiles p <$> testGlob p) testPaths +setupSupportModules :: IO ([P.Module], [P.ExternsFile], M.Map P.ModuleName FilePath) +setupSupportModules = do ms <- getSupportModuleTuples let modules = map snd ms supportExterns <- runExceptT $ do @@ -118,7 +115,13 @@ setUpTests testDirs = do return (externs, foreigns) case supportExterns of Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) - Right (externs, foreigns) -> return (modules, externs, foreigns, testFiles) + Right (externs, foreigns) -> return (modules, externs, foreigns) + +getTestFiles :: FilePath -> IO [[FilePath]] +getTestFiles testDir = do + cwd <- getCurrentDirectory + let dir = cwd "tests" "purs" testDir + getFiles dir <$> testGlob dir where -- A glob for all purs and js files within a test directory testGlob :: FilePath -> IO [FilePath] @@ -126,8 +129,8 @@ setUpTests testDirs = do -- Groups the test files so that a top-level file can have dependencies in a -- subdirectory of the same name. The inner tuple contains a list of the -- .purs files and the .js files for the test case. - getTestFiles :: FilePath -> [FilePath] -> [[FilePath]] - getTestFiles baseDir + getFiles :: FilePath -> [FilePath] -> [[FilePath]] + getFiles baseDir = map (filter ((== ".purs") . takeExtensions) . map (baseDir )) . groupBy ((==) `on` extractPrefix) . sortBy (compare `on` extractPrefix) From 03f3e1888901738d5113deb6cdf6cd1027b84be2 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 31 Mar 2019 21:13:10 +0100 Subject: [PATCH 1075/1580] Empty commit to help CI From c1f1ec89f625de96c46a9e8b76443a91c1805bbe Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 1 Apr 2019 07:47:34 +0000 Subject: [PATCH 1076/1580] Make bundle tests rerun some compile tests (#3579) --- tests/TestUtils.hs | 16 +++++++++++++- tests/purs/bundle/RerunCompilerTests.txt | 27 ++++++++++++++++++++++++ 2 files changed, 42 insertions(+), 1 deletion(-) create mode 100644 tests/purs/bundle/RerunCompilerTests.txt diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 59540d503f..f2c477f648 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -121,7 +121,21 @@ getTestFiles :: FilePath -> IO [[FilePath]] getTestFiles testDir = do cwd <- getCurrentDirectory let dir = cwd "tests" "purs" testDir - getFiles dir <$> testGlob dir + testsInPath <- getFiles dir <$> testGlob dir + let rerunPath = dir "RerunCompilerTests.txt" + hasRerunFile <- doesFileExist rerunPath + rerunTests <- + if hasRerunFile + then let compilerTestDir = cwd "tests" "purs" "passing" + textToTestFiles + = mapM (\path -> ((path ++ ".purs") :) <$> testGlob path) + . map ((compilerTestDir ) . T.unpack) + . filter (not . T.null) + . map (T.strip . fst . T.breakOn "--") + . T.lines + in readUTF8FileT rerunPath >>= textToTestFiles + else return [] + return $ testsInPath ++ rerunTests where -- A glob for all purs and js files within a test directory testGlob :: FilePath -> IO [FilePath] diff --git a/tests/purs/bundle/RerunCompilerTests.txt b/tests/purs/bundle/RerunCompilerTests.txt new file mode 100644 index 0000000000..c50aa55068 --- /dev/null +++ b/tests/purs/bundle/RerunCompilerTests.txt @@ -0,0 +1,27 @@ +-- Each line in this file that doesn't start with "--" is the name of a test +-- in purs/passing which should be rerun during bundle testing. Rerunning +-- every test in purs/passing would take more time than it's worth, so these +-- tests have been cherry-picked for having moderately complex imports. + +Collatz +DctorOperatorAlias +--EffFn +ExtendedInfixOperators +Fib +ForeignKind +--FunWithFunDeps +GenericsRep +Import +ImportExplicit +ImportQualified +Let +Operators +QualifiedAdo +QualifiedDo +SolvingAppendSymbol +SolvingCompareSymbol +SolvingIsSymbol +TCO +TransitiveImport +TypeOperators +TypeWithoutParens From b28e429087c7c45898452ca14148ec48991e3e60 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Wed, 3 Apr 2019 17:39:49 +0000 Subject: [PATCH 1077/1580] Handle "use strict" better in bundler (#3581) In foreign modules, go back to using `exports` as the parameter of the IIFE and not inserting any code into the module body. In PureScript modules, actually detect "use strict" and other directives (as defined in the ECMAScript 5.1 spec) prior to moving those statements before the inserted code. --- src/Language/PureScript/Bundle.hs | 83 ++++++++++++++---------- tests/purs/bundle/RerunCompilerTests.txt | 4 +- 2 files changed, 50 insertions(+), 37 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 30121823ca..d92d5662d7 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -26,10 +26,10 @@ import Control.Arrow ((&&&)) import Data.Array ((!)) import Data.Char (chr, digitToInt) import Data.Foldable (fold) -import Data.Generics (everything, everywhere, mkQ, mkT) +import Data.Generics (GenericM, everything, everywhere, gmapMo, mkMp, mkQ, mkT) import Data.Graph import Data.List (stripPrefix) -import Data.Maybe (mapMaybe, catMaybes) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Version (showVersion) import qualified Data.Map as M import qualified Data.Set as S @@ -570,7 +570,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o modulesJS = map moduleToJS ms moduleToJS :: Module -> ([JSStatement], [Either Int Int]) - moduleToJS (Module mn _ ds) = (wrap (moduleName mn) (indent (concat jsDecls)), lengths) + moduleToJS (Module mid _ ds) = (wrap mid (indent (concat jsDecls)), lengths) where (jsDecls, lengths) = unzip $ map declToJS ds @@ -655,41 +655,54 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o emptyObj :: JSAnnot -> JSExpression emptyObj a = JSObjectLiteral a (JSCTLNone JSLNil) JSNoAnnot - wrap :: String -> [JSStatement] -> [JSStatement] - wrap mn ds = - [ - JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot (JSLOne (JSIdentName JSNoAnnot "$PS")) JSNoAnnot - (JSBlock sp (addModuleExports ds) lf)) -- \n not quite in right place + initializeObject :: JSAnnot -> (JSAnnot -> String -> JSExpression) -> String -> JSExpression + initializeObject a makeReference mn = + JSAssignExpression (makeReference a mn) (JSAssign sp) + $ JSExpressionBinary (makeReference sp mn) (JSBinOpOr sp) + $ emptyObj sp + + -- Like `somewhere`, but stops after the first successful transformation + firstwhere :: MonadPlus m => GenericM m -> GenericM m + firstwhere f x = f x `mplus` gmapMo (firstwhere f) x + + prependWhitespace :: String -> [JSStatement] -> [JSStatement] + prependWhitespace val = fromMaybe <*> firstwhere (mkMp $ Just . reannotate) + where + reannotate (JSAnnot rpos annots) = JSAnnot rpos (ws : annots) + reannotate _ = JSAnnot tokenPosnEmpty [ws] + + ws = WhiteSpace tokenPosnEmpty val + + iife :: [JSStatement] -> String -> JSExpression -> JSStatement + iife body param arg = + JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot (JSLOne (JSIdentName JSNoAnnot param)) JSNoAnnot + (JSBlock sp (prependWhitespace "\n " body) lf)) JSNoAnnot) - JSNoAnnot - (JSLOne (JSIdentifier JSNoAnnot optionsNamespace)) - JSNoAnnot - (JSSemi JSNoAnnot) - ] + JSNoAnnot + (JSLOne arg) + JSNoAnnot + (JSSemi JSNoAnnot) + + wrap :: ModuleIdentifier -> [JSStatement] -> [JSStatement] + wrap (ModuleIdentifier mn mtype) ds = + case mtype of + Regular -> [iife (addModuleExports ds) "$PS" (JSIdentifier JSNoAnnot optionsNamespace)] + Foreign -> [iife ds "exports" (initializeObject JSNoAnnot moduleReference mn)] where + -- Insert the exports var after a directive prologue, if one is present. + -- Per ECMA-262 5.1, "A Directive Prologue is the longest sequence of + -- ExpressionStatement productions [...] where each ExpressionStatement + -- [...] consists entirely of a StringLiteral [...]." + -- (http://ecma-international.org/ecma-262/5.1/#sec-14.1) addModuleExports :: [JSStatement] -> [JSStatement] - addModuleExports [] = lfHead moduleExports - addModuleExports (x:xs) = lfHead [x] ++ moduleExports ++ xs - moduleExports = - [ - JSExpressionStatement (JSAssignExpression (innerModuleReference lfsp mn) - (JSAssign sp) - (JSExpressionBinary (innerModuleReference sp mn) (JSBinOpOr sp) (emptyObj sp))) - (JSSemi JSAnnotSpace), - JSVariable lfsp (JSLOne $ JSVarInitExpression (JSIdentifier sp "exports") $ JSVarInit sp (innerModuleReference sp mn)) - (JSSemi JSNoAnnot) - ] - lfHead (h:t) = addAnn (WhiteSpace tokenPosnEmpty "\n ") h : t - lfHead x = x - - addAnn :: CommentAnnotation -> JSStatement -> JSStatement - addAnn a (JSExpressionStatement (JSStringLiteral ann s) _) = - JSExpressionStatement (JSStringLiteral (appendAnn a ann) s) (JSSemi JSNoAnnot) - addAnn _ x = x - - appendAnn a JSNoAnnot = JSAnnot tokenPosnEmpty [a] - appendAnn a (JSAnnot _ anns) = JSAnnot tokenPosnEmpty (a:anns ++ [WhiteSpace tokenPosnEmpty " "]) - appendAnn a JSAnnotSpace = JSAnnot tokenPosnEmpty [a] + addModuleExports (x:xs) | isDirective x = x : addModuleExports xs + addModuleExports xs + = JSExpressionStatement (initializeObject lfsp innerModuleReference mn) (JSSemi JSNoAnnot) + : JSVariable lfsp (JSLOne $ JSVarInitExpression (JSIdentifier sp "exports") $ JSVarInit sp (innerModuleReference sp mn)) (JSSemi JSNoAnnot) + : xs + + isDirective (JSExpressionStatement (JSStringLiteral _ _) _) = True + isDirective _ = False runMain :: String -> [JSStatement] runMain mn = diff --git a/tests/purs/bundle/RerunCompilerTests.txt b/tests/purs/bundle/RerunCompilerTests.txt index c50aa55068..ab8991352a 100644 --- a/tests/purs/bundle/RerunCompilerTests.txt +++ b/tests/purs/bundle/RerunCompilerTests.txt @@ -5,11 +5,11 @@ Collatz DctorOperatorAlias ---EffFn +EffFn ExtendedInfixOperators Fib ForeignKind ---FunWithFunDeps +FunWithFunDeps GenericsRep Import ImportExplicit From b7158cb20e58a10177861b5928e09bb10b3bf4b7 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 7 Apr 2019 15:57:09 +0100 Subject: [PATCH 1078/1580] Shrink types less aggressively, fixes #3577 (#3585) * Shrink types less aggressively, fixes #3577 Shrink types less aggressively by treating nested type applications as all being at the same level. Now, given the following module: module Main where import Data.Tuple.Nested (Tuple4) something :: Tuple4 Int String Int String something = ?y the error we get is displayed as: Hole 'y' has the inferred type Tuple Int (Tuple String (Tuple Int (... ... ...))) You could substitute the hole with one of these values: Main.something :: Tuple4 Int String Int String in value declaration something * Don't truncate hole inferred types --- src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/Pretty/Types.hs | 11 ++++++++--- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 3bc5a6bf76..b511c4cc91 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -879,7 +879,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl _ -> [] in paras $ [ line $ "Hole '" <> markCode name <> "' has the inferred type " - , markCodeBox (indent (typeAsBox prettyDepth ty)) + , markCodeBox (indent (typeAsBox maxBound ty)) ] ++ tsResult ++ renderContext ctx renderSimpleErrorMessage (MissingTypeDeclaration ident ty) = paras [ line $ "No type declaration was provided for the top-level declaration of " <> markCode (showIdent ident) <> "." diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index dc6f84cdd2..35445c35c6 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -77,9 +77,7 @@ convertPrettyPrintType = go go _ (REmpty _) = PPRow [] Nothing go d ty@RCons{} = uncurry PPRow (goRow d ty) go d (ForAll _ v ty _) = goForAll d [v] ty - go d (TypeApp _ (TypeApp _ f arg) ret) | eqType f tyFunction = PPFunction (go (d-1) arg) (go (d-1) ret) - go d (TypeApp _ o ty@RCons{}) | eqType o tyRecord = uncurry PPRecord (goRow d ty) - go d (TypeApp _ a b) = PPTypeApp (go (d-1) a) (go (d-1) b) + go d (TypeApp _ a b) = goTypeApp d a b goForAll d vs (ForAll _ v ty _) = goForAll d (v : vs) ty goForAll d vs ty = PPForAll vs (go (d-1) ty) @@ -92,6 +90,13 @@ convertPrettyPrintType = go _ -> Just (go (d-1) tail_) ) + goTypeApp d (TypeApp _ f a) b + | eqType f tyFunction = PPFunction (go (d-1) a) (go (d-1) b) + | otherwise = PPTypeApp (goTypeApp d f a) (go (d-1) b) + goTypeApp d o ty@RCons{} + | eqType o tyRecord = uncurry PPRecord (goRow d ty) + goTypeApp d a b = PPTypeApp (go (d-1) a) (go (d-1) b) + -- TODO(Christoph): get rid of T.unpack s constraintsAsBox :: TypeRenderOptions -> PrettyPrintConstraint -> Box -> Box From 5f9ac285e9ef7c5b0b2116a2c9469f8244a36437 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 7 Apr 2019 21:19:39 +0100 Subject: [PATCH 1079/1580] Use one build script for all CI builds (#3587) This should allow us to get appveyor working again. Since we upgraded to GHC 8.6.4, all appyeyor builds seem to have failed because we need to recompile all of the compiler's Haskell dependencies, which takes too long. Using the existing Travis script on AppVeyor too means that we can reuse the timeout mechanism to allow us to pick up where we left off if builds do time out. --- .travis.yml | 20 ++++---- appveyor.yml | 45 ++++++++---------- .../appveyor-cache-buster.txt | 0 {travis => ci}/build.sh | 47 +++++++++++++++++-- {travis => ci}/convert-os-name.sh | 0 5 files changed, 70 insertions(+), 42 deletions(-) rename appveyor/cache-buster.txt => ci/appveyor-cache-buster.txt (100%) rename {travis => ci}/build.sh (60%) rename {travis => ci}/convert-os-name.sh (100%) diff --git a/.travis.yml b/.travis.yml index 9e3e9b785d..95001e51a5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -66,22 +66,18 @@ install: mv stack "$HOME/.local/bin/" fi - npm install -g bower # for psc-docs / psc-publish tests -- export OS_NAME=$(./travis/convert-os-name.sh) -# Install 'timeout' +- export OS_NAME=$(./ci/convert-os-name.sh) +# Install 'gtimeout' if we need it - | - if [ "$TRAVIS_OS_NAME" == "osx" ] + if [ "$TRAVIS_OS_NAME" == "osx" ] && ! which gtimeout >/dev/null then - if ! which gtimeout >/dev/null - then - brew update - brew install coreutils - fi - export TIMEOUT=gtimeout - else - export TIMEOUT=timeout + brew update + brew install coreutils fi script: -- travis/build.sh +- | + [ -n "$TRAVIS_TAG" ] && export CI_RELEASE=true || true +- ci/build.sh before_deploy: - ./bundle/build.sh $OS_NAME deploy: diff --git a/appveyor.yml b/appveyor.yml index a3fa6b1c51..4fdbb4501a 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -6,7 +6,16 @@ environment: STACK_VER: 1.7.1 RELEASE_USER: purescript RELEASE_REPO: purescript - # See https://github.com/commercialhaskell/stack/issues/3944, might no + # We want to save the build cache on all builds, including those that failed, + # because this allows us to pick up where we left off in subsequent builds + # (in particular, compiling all of the Haskell dependencies of the compiler + # can take long enough that the build is terminated before we can finish). + # By default AppVeyor only saves the build cache on builds which succeed, so + # we ask to save the cache on failures too by setting this environment + # variable; see + # https://www.appveyor.com/docs/build-cache/#saving-cache-for-failed-build + APPVEYOR_SAVE_CACHE_ON_ERROR: true + # See https://github.com/commercialhaskell/stack/issues/3944, might no # longer be necessary after we've moved to a snapshot with network >= 0.2.7.1 TMP: "c:\\tmp" branches: @@ -19,10 +28,14 @@ branches: only: - master cache: -- c:\s -> appveyor/cache-buster.txt +# appveyor/cache-buster.txt is a file which, if modified, invalidates the +# cached version of "c:\\s" (i.e. stack's cache). If bad data gets into the +# cache for any reason, the cache can be invalidated by committing a change to +# this file. See https://www.appveyor.com/docs/build-cache/ for more +# information. +- c:\s -> ci/appveyor-cache-buster.txt install: -- git submodule update --init -- ps: Install-Product node 8 +- ps: Install-Product node 10 - npm install -g bower - ps: | @@ -35,28 +48,10 @@ install: 7z x c:\tools\stack.zip stack.exe popd -- stack --no-terminal --verbosity=error setup 1>stack-setup.log 2>&1 || type stack-setup.log - build_script: -# Override the default build script. -# In PowerShell it seems to be necessary to redirect stderr to stdout because -# any text sent to stderr seems to cause appveyor to think the build has -# failed. -- echo "" -test_script: -- ps: | - $stack_extra_flags="" - if ($env:APPVEYOR_REPO_TAG_NAME) - { - $stack_extra_flags+="--flag purescript:RELEASE" - } - echo "stack_extra_flags = $stack_extra_flags" - - # This is an incredibly stupid workaround for a bizarre PowerShell - # 'feature' where any text printed to stderr is treated as the command - # having failed; see - # https://stackoverflow.com/questions/10666101/lastexitcode-0-but-false-in-powershell-redirecting-stderr-to-stdout-gives-n - cmd /c "stack --jobs=1 --no-terminal test --pedantic $stack_extra_flags 2>&1" +- set BUILD_TYPE=normal +- if defined APPVEYOR_REPO_TAG_NAME ( set CI_RELEASE=true ) +- c:\msys64\usr\bin\bash ci\build.sh on_success: - ps: | function UploadFile diff --git a/appveyor/cache-buster.txt b/ci/appveyor-cache-buster.txt similarity index 100% rename from appveyor/cache-buster.txt rename to ci/appveyor-cache-buster.txt diff --git a/travis/build.sh b/ci/build.sh similarity index 60% rename from travis/build.sh rename to ci/build.sh index 449074ab22..7df3d7083c 100755 --- a/travis/build.sh +++ b/ci/build.sh @@ -1,12 +1,49 @@ #!/bin/bash set -e +# This is the main CI build script. It is intended to run on all platforms we +# run CI on: linux, mac os, and windows (via msys). It makes use of the +# following environment variables: +# +# BUILD_TYPE +# Must be one of the following: +# - "normal": Compile & run tests normally +# - "sdist": Create a source distribution and check that everything still +# compiles and works +# - "haddock": Check that haddock documentation builds correctly. +# +# CI_RELEASE +# If set to "true", passes the RELEASE flag to the compiler and enables +# optimizations. + STACK="stack --no-terminal --jobs=1" [[ "$BUILD_TYPE" == "haddock" ]] && DEPS_HADDOCK="--haddock" +# This command is ludicrously verbose on Windows, so we pipe the output to a +# file and only display it if the command fails. +if ! $STACK --verbosity=error setup 1>stack-setup.log 2>&1 +then + cat stack-setup.log + echo "Failed to run 'stack setup'" + exit 1 +fi + # Setup & install dependencies or abort ret=0 -$TIMEOUT 40m $STACK --install-ghc build \ +if [ -x "C:\\msys64\\usr\\bin\\timeout.exe" ] +then + TIMEOUT=C:\\msys64\\usr\\bin\\timeout.exe +elif which timeout >/dev/null +then + TIMEOUT=timeout +elif which gtimeout >/dev/null +then + TIMEOUT=gtimeout +else + echo "timeout command not found (nor gtimeout)" + exit 1 +fi +$TIMEOUT 40m $STACK build \ --only-dependencies --test $DEPS_HADDOCK \ || ret=$? case "$ret" in @@ -25,13 +62,13 @@ esac # Set up configuration STACK_EXTRA_FLAGS="" -if [ -z "$TRAVIS_TAG" ] +if [ "$CI_RELEASE" = "true" ] then - # On non-release builds, disable optimizations. - STACK_EXTRA_FLAGS="--fast" -else # On release builds, set the 'release' cabal flag. STACK_EXTRA_FLAGS="--flag purescript:RELEASE" +else + # On non-release builds, disable optimizations. + STACK_EXTRA_FLAGS="--fast" fi if [ "$STACKAGE_NIGHTLY" = "true" ] diff --git a/travis/convert-os-name.sh b/ci/convert-os-name.sh similarity index 100% rename from travis/convert-os-name.sh rename to ci/convert-os-name.sh From a7aa146c6d44366efb0cd5dcd67762cdd1c56093 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 7 Apr 2019 22:14:09 +0100 Subject: [PATCH 1080/1580] Empty commit for appveyor ci From 35038c7ef472d7ae27bf9f31a9155ba32bada812 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 7 Apr 2019 23:25:51 +0100 Subject: [PATCH 1081/1580] Bump to v0.12.4 --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 43ffda4030..1171e491b8 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.12.3' +version: '0.12.4' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From ef7d69dfe52a07e2f299969ff9c83dbd422a1a18 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 8 Apr 2019 13:08:19 +0100 Subject: [PATCH 1082/1580] Rerun license generator --- LICENSE | 152 +++++++++++++++++++++++++++++--------------------------- 1 file changed, 79 insertions(+), 73 deletions(-) diff --git a/LICENSE b/LICENSE index 140efcd259..adb19a883a 100644 --- a/LICENSE +++ b/LICENSE @@ -42,6 +42,7 @@ PureScript uses the following Haskell library packages. Their license files foll byteorder bytestring bytestring-builder + cabal-doctest case-insensitive cheapskate clock @@ -70,7 +71,6 @@ PureScript uses the following Haskell library packages. Their license files foll fast-logger file-embed filepath - foundation fsnotify ghc-boot-th ghc-prim @@ -101,6 +101,7 @@ PureScript uses the following Haskell library packages. Their license files foll mtl mtl-compat network + network-byte-order network-uri old-locale old-time @@ -1124,6 +1125,39 @@ bytestring-builder LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +cabal-doctest LICENSE file: + + Copyright (c) 2017, Oleg Grenrus + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + case-insensitive LICENSE file: Copyright (c) 2011-2013 Bas van Dijk @@ -1975,37 +2009,6 @@ filepath LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -foundation LICENSE file: - - Copyright (c) 2015-2017 Vincent Hanquez - Copyright (c) 2017-2018 Foundation Maintainers - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - fsnotify LICENSE file: Copyright (c) 2012, Mark Dittmer @@ -2039,40 +2042,6 @@ fsnotify LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -ghc-boot-th LICENSE file: - - The Glasgow Haskell Compiler License - - Copyright 2002, The University Court of the University of Glasgow. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - - Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - - - Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - - - Neither name of the University nor the names of its contributors may be - used to endorse or promote products derived from this software without - specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF - GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - DAMAGE. - ghc-prim LICENSE file: This library (libraries/ghc-prim) is derived from code from several @@ -2545,7 +2514,8 @@ lifted-base LICENSE file: memory LICENSE file: - Copyright (c) 2015 Vincent Hanquez + Copyright (c) 2015-2018 Vincent Hanquez + Copyright (c) 2017-2018 Nicolas Di Prima All rights reserved. @@ -2577,7 +2547,8 @@ memory LICENSE file: microlens LICENSE file: Copyright (c) 2013-2016 Edward Kmett, - 2015-2016 Artyom + 2015-2016 Artyom Kazak, + 2018 Monadfix All rights reserved. @@ -2592,7 +2563,7 @@ microlens LICENSE file: disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Artyom nor the names of other + * Neither the name of Monadfix nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. @@ -2611,7 +2582,8 @@ microlens LICENSE file: microlens-ghc LICENSE file: Copyright (c) 2013-2016 Edward Kmett, - 2015-2016 Artyom + 2015-2016 Artyom Kazak, + 2018 Monadfix All rights reserved. @@ -2626,7 +2598,7 @@ microlens-ghc LICENSE file: disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Artyom nor the names of other + * Neither the name of Monadfix nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. @@ -2679,7 +2651,8 @@ microlens-mtl LICENSE file: microlens-platform LICENSE file: Copyright (c) 2012-2016 Edward Kmett, - 2015-2016 Artyom + 2015-2016 Artyom Kazak, + 2018 Monadfix All rights reserved. @@ -2694,7 +2667,7 @@ microlens-platform LICENSE file: disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Artyom nor the names of other + * Neither the name of Monadfix nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. @@ -2943,6 +2916,39 @@ network LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +network-byte-order LICENSE file: + + Copyright (c) 2017, Kazu Yamamoto + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Kazu Yamamoto nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + network-uri LICENSE file: Copyright (c) 2002-2010, The University Court of the University of Glasgow. From b09144bc68637bf6657e4147567a3e9185221594 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 8 Apr 2019 13:49:15 +0100 Subject: [PATCH 1083/1580] Update INSTALL.md (#3593) --- INSTALL.md | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/INSTALL.md b/INSTALL.md index 9d729f9489..232b5a658f 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -6,14 +6,13 @@ alternatively Stack Overflow. ## Using prebuilt binaries -The prebuilt binaries are compiled with GHC 8.2.2 and therefore they should -run on any operating system supported by GHC 8.2.2, such as: +The prebuilt binaries are compiled with GHC 8.6.4 and therefore they should run on any operating system supported by GHC 8.6.4, such as: * Windows Vista or later, * OS X 10.7 or later, * Linux ??? (we're not sure what the minimum version is) -This list is not exhaustive. If your OS is too old or not listed, or if the binaries fail to run, you may be able to install the compiler by building it from source; see below. See also for more details about the operating systems which GHC 8.2.2 supports. +This list is not exhaustive. If your OS is too old or not listed, or if the binaries fail to run, you may be able to install the compiler by building it from source; see below. See also for more details about the operating systems which GHC 8.6.4 supports. Other prebuilt distributions (eg, Homebrew, AUR, npm) will probably have the same requirements. @@ -24,10 +23,7 @@ There are several options available for aquiring a pre-built binary of the PureS * NPM: `npm install -g purescript` * Homebrew (for OS X): `brew install purescript` -* [PSVM](https://github.com/ThomasCrevoisier/psvm-js) (PS Version Manager): - 1) `psvm install-latest` will install the latest version available - 2) `psvm latest` will print the latest version number available - 3) `psvm use ` will enable the version we just installed. For example, if the version is `v0.11.7`, you'd run `psvm use v0.11.7` +* [PSVM](https://github.com/ThomasCrevoisier/psvm-js): `npm install -g psvm` ## Compiling from source From 05d42c8c84ef0518643918d0fc20954ca03ec7aa Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 13 Apr 2019 21:55:03 +0100 Subject: [PATCH 1084/1580] Use qualified names for detecting cycles in type classes (#3599) Fixes #3595 --- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Errors.hs | 4 ++-- src/Language/PureScript/Sugar/TypeClasses.hs | 12 ++++++------ tests/purs/passing/3595.purs | 14 ++++++++++++++ 4 files changed, 23 insertions(+), 9 deletions(-) create mode 100644 tests/purs/passing/3595.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index f2e6a2e3c6..ea2feccddd 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -100,7 +100,7 @@ data SimpleErrorMessage | InvalidDoLet | CycleInDeclaration Ident | CycleInTypeSynonym (Maybe (ProperName 'TypeName)) - | CycleInTypeClassDeclaration [(ProperName 'ClassName)] + | CycleInTypeClassDeclaration [Qualified (ProperName 'ClassName)] | CycleInModules [ModuleName] | NameIsUndefined Ident | UndefinedTypeVariable (ProperName 'TypeName) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index b511c4cc91..2521884f78 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -576,10 +576,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , line "Consider using a 'newtype' instead." ] renderSimpleErrorMessage (CycleInTypeClassDeclaration [name]) = - paras [ line $ "A type class '" <> markCode (runProperName name) <> "' may not have itself as a superclass." ] + paras [ line $ "A type class '" <> markCode (runProperName (disqualify name)) <> "' may not have itself as a superclass." ] renderSimpleErrorMessage (CycleInTypeClassDeclaration names) = paras [ line $ "A cycle appears in a set of type class definitions:" - , indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName) names)) <> "}" + , indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName . disqualify) names)) <> "}" , line "Cycles are disallowed because they can lead to loops in the type checker." ] renderSimpleErrorMessage (NameIsUndefined ident) = diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 734a98aca0..7686e710e4 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -87,15 +87,15 @@ desugarModule (Module ss coms name decls (Just exps)) = do desugarClassDecl name' exps' (AcyclicSCC d) = desugarDecl name' exps' d desugarClassDecl _ _ (CyclicSCC ds') = throwError . errorMessage' (declSourceSpan (head ds')) $ CycleInTypeClassDeclaration (map classDeclName ds') - superClassesNames :: Declaration -> [ProperName 'ClassName] - superClassesNames (TypeClassDeclaration _ _ _ implies _ _) = fmap superClassName implies + superClassesNames :: Declaration -> [Qualified (ProperName 'ClassName)] + superClassesNames (TypeClassDeclaration _ _ _ implies _ _) = fmap constraintName implies superClassesNames _ = [] - superClassName :: SourceConstraint -> ProperName 'ClassName - superClassName (Constraint _ (Qualified _ cName) _ _) = cName + constraintName :: SourceConstraint -> Qualified (ProperName 'ClassName) + constraintName (Constraint _ cName _ _) = cName - classDeclName :: Declaration -> ProperName 'ClassName - classDeclName (TypeClassDeclaration _ pn _ _ _ _) = pn + classDeclName :: Declaration -> Qualified (ProperName 'ClassName) + classDeclName (TypeClassDeclaration _ pn _ _ _ _) = Qualified (Just name) pn classDeclName _ = internalError "Expected TypeClassDeclaration" desugarModule _ = internalError "Exports should have been elaborated in name desugaring" diff --git a/tests/purs/passing/3595.purs b/tests/purs/passing/3595.purs new file mode 100644 index 0000000000..f5c7941535 --- /dev/null +++ b/tests/purs/passing/3595.purs @@ -0,0 +1,14 @@ +module Main where + +import Prelude as P +import Effect (Effect) +import Effect.Console (log) + +class P.Show a <= Show a where + id :: a -> a + +instance showString :: Show String where + id x = x + +main :: Effect P.Unit +main = log (id "Done") From 10f66eef231e912f871743234201b1f94976af4c Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Sat, 13 Apr 2019 23:56:14 +0300 Subject: [PATCH 1085/1580] Fix "purs ide server" crash on macOS by providing connection hints (#3597) Fixes #3594 * Fix "purs ide server" crash on macOS by providing connection hints * Upgrade to network 3.0.1.1 --- app/Command/Ide.hs | 12 ++++++++++-- package.yaml | 2 +- stack.yaml | 1 + 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index 73d7ecc927..30adccc71b 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -47,7 +47,11 @@ import System.IO.Error (isEOFError) listenOnLocalhost :: Network.PortNumber -> IO Network.Socket listenOnLocalhost port = do - addr:_ <- Network.getAddrInfo Nothing (Just "127.0.0.1") (Just (show port)) + let hints = Network.defaultHints + { Network.addrFamily = Network.AF_INET + , Network.addrSocketType = Network.Stream + } + addr:_ <- Network.getAddrInfo (Just hints) (Just "127.0.0.1") (Just (show port)) bracketOnError (Network.socket (Network.addrFamily addr) (Network.addrSocketType addr) (Network.addrProtocol addr)) Network.close @@ -92,7 +96,11 @@ command = Opts.helper <*> subcommands where T.putStrLn ("Couldn't connect to purs ide server on port " <> show clientPort <> ":") print e exitFailure - addr:_ <- Network.getAddrInfo Nothing (Just "127.0.0.1") (Just (show clientPort)) + let hints = Network.defaultHints + { Network.addrFamily = Network.AF_INET + , Network.addrSocketType = Network.Stream + } + addr:_ <- Network.getAddrInfo (Just hints) (Just "127.0.0.1") (Just (show clientPort)) sock <- Network.socket (Network.addrFamily addr) (Network.addrSocketType addr) (Network.addrProtocol addr) Network.connect sock (Network.addrAddress addr) `catch` handler h <- Network.socketToHandle sock ReadWriteMode diff --git a/package.yaml b/package.yaml index 1171e491b8..769673521a 100644 --- a/package.yaml +++ b/package.yaml @@ -132,7 +132,7 @@ executables: - ansi-wl-pprint - file-embed - http-types - - network + - network >= 3.0.1.1 - optparse-applicative >=0.13.0 - purescript - wai ==3.* diff --git a/stack.yaml b/stack.yaml index ac8c3aa78f..09abdb9be9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,7 @@ resolver: lts-13.12 packages: - '.' extra-deps: +- network-3.0.1.1 nix: enable: false packages: From ba22c7cce4f20b68552276f755baf4273cd33b4c Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Sat, 13 Apr 2019 22:56:43 +0200 Subject: [PATCH 1086/1580] [purs ide] Filters out module declarations before suggesting imports (#3598) Fixes #3591 --- src/Language/PureScript/Ide/Imports.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index c8af2ac2a1..e880248323 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -277,7 +277,13 @@ addImportForIdentifier addImportForIdentifier fp ident qual filters = do let addPrim = Map.union idePrimDeclarations modules <- getAllModules Nothing - case map (fmap discardAnn) (getExactMatches ident filters (addPrim modules)) of + let + matches = + getExactMatches ident filters (addPrim modules) + & map (fmap discardAnn) + & filter (\(Match (_, d)) -> not (has _IdeDeclModule d)) + + case matches of [] -> throwError (NotFound "Couldn't find the given identifier. \ \Have you loaded the corresponding module?") From 88b0010bde294b08e16d79adb64ca2d51bf935ed Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 14 Apr 2019 22:15:17 +0100 Subject: [PATCH 1087/1580] still trying to get windows CI working (#3606) * Port CI build script to Haskell * Clean up travis script & update appveyor stack version * Invalidate appveyor cache * Move `stack setup` outside of ci build script * Better docs for CI script + fix sdist builds * d'oh * more tweaks * Cache stack AppData directory * AppData cache should be subject to appveyor-cache-buster.txt * Empty commit for appveyor * Another empty commit for appveyor * Try Travis on windows * trying to get travis working on windows * tweak again * Workaround for travis windows failures * Download stack to a separate directory * Echo path * Add .local/bin to PATH * Use language:node_js to make node available * Use a more recent node + fix install script * More windows tweaks * Set stack_root on windows and cache it * use if statements * Avoid backslashes in paths * Cache stack's ghc install location on Windows * use travis_wait for build script * Back to a bash build script * Use travis_wait for timeouts * Don't build haddocks for dependencies * Empty commit for travis * Fix stack detection on windows (was missing due to .exe) * Only install snapshot deps at first * . * skip-msys globally on windows * Fuck haddock * Switch to gnu timeout * hopefully having 2 jobs will prevent stalling * Empty commit for travis * Use a relative directory for cached stack root on windows * try to revive appveyor in the meantime? * Address Appveyor cygwin dll mismatch issue * Overwrite config.yaml on travis on windows We don't want to end up with duplicate keys * Slightly longer timeout * Re-enable installing msys, and try again to cache the compiler * Empty commit for travis * Empty commit for travis * Reduce verbosity of `stack setup` Also remove useless cache directory (GHC/msys caching doesn't appear to work) * Remove appveyor related files --- .travis.yml | 131 +++++++++++++++++++++----------- appveyor.yml | 76 ------------------- ci/appveyor-cache-buster.txt | 8 -- ci/build.sh | 133 ++++++++------------------------- ci/convert-os-name.sh | 2 + ci/disable-windows-defender.sh | 23 ++++++ 6 files changed, 146 insertions(+), 227 deletions(-) delete mode 100644 appveyor.yml delete mode 100644 ci/appveyor-cache-buster.txt create mode 100755 ci/disable-windows-defender.sh diff --git a/.travis.yml b/.travis.yml index 95001e51a5..3defb20086 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,6 @@ -language: c -dist: trusty # because of perf issues -sudo: required +language: node_js +node_js: + - "10" branches: # Only build master and tagged versions, i.e. not feature branches; feature # branches already get built after opening a pull request. @@ -13,71 +13,119 @@ matrix: - os: linux dist: trusty sudo: required - env: BUILD_TYPE=normal DEPLOY=true - - # - os: linux - # dist: trusty - # sudo: required - # env: BUILD_TYPE=normal STACKAGE_NIGHTLY=true - # allow_failures: true - - - os: linux - dist: trusty - sudo: required - env: BUILD_TYPE=normal - - # - os: linux - # dist: trusty - # sudo: required - # env: BUILD_TYPE=sdist COVERAGE=true - - - os: linux - dist: trusty - sudo: required - env: BUILD_TYPE=haddock - os: osx - env: BUILD_TYPE=normal DEPLOY=true - - os: osx - env: BUILD_TYPE=sdist + - os: windows + # Workaround for a Travis caching bug on Windows where absolute paths + # are not restored from caches properly: + # https://github.com/travis-ci/casher/pull/38 + env: STACK_ROOT=$TRAVIS_BUILD_DIR/.stack_root RELEASE_KEY= + # workaround for https://travis-ci.community/t/windows-instances-hanging-before-install/250/15 + # We also zero out the RELEASE_KEY environment variable above to reduce + # the risk of accidentally leaking it. + filter_secrets: false addons: apt: packages: - libgmp-dev cache: +# Travis CI's build cache mechanism allows you to cache compiled artifacts in +# order to speed subsequent builds up; this is essential for us, because +# installing all of the compiler's Haskell dependencies takes longer than the +# allotted time for a single build. +# +# Unfortunately, if we allow a build to reach the Travis timeout limit, we +# don't get the opportunity to upload a cache (since uploading is included in +# the time limit, and we've already run out of time). Therefore, if we want +# the progress we have made in a build to be saved to the build cache, we need +# to make sure we abort the build early to allow time to upload the cache. +# Then, the next commit can pick up where the previous commit left off. +# +# If a CI build times out, you need to push a new commit. Amending and +# force-pushing DOES NOT WORK. I suspect this is because Travis will only +# consider a particular build cache to be appropriate to use when building a +# given commit with if the cache was created by a parent of the commit being +# built (which is sensible of them). directories: - $HOME/.local/bin - $HOME/.stack + + # Workaround for a Travis caching bug on Windows where absolute paths + # are not restored from caches properly: + # https://github.com/travis-ci/casher/pull/38 + - .stack_root # Maximum amount of time in seconds spent attempting to upload a new cache # before aborting. Since our cache can get rather large, increasing this # value helps avoid situations where caches fail to be stored. The default # value is 180 (at the time of writing). timeout: 1000 install: +- | + if [ "$TRAVIS_OS_NAME" = "windows" ] + then + ci/disable-windows-defender.sh + fi +- mkdir -p "$HOME/.local/bin" +- export PATH="$PATH:$HOME/.local/bin" - | # Install stack. - if test ! -f "$HOME/.local/bin/stack" + if ! which stack >/dev/null then URL="https://www.stackage.org/stack/$TRAVIS_OS_NAME-x86_64" - curl --location "$URL" > stack.tar.gz - gunzip stack.tar.gz - tar -x -f stack.tar --strip-components 1 - mkdir -p "$HOME/.local/bin" - mv stack "$HOME/.local/bin/" + mkdir "$HOME/stack" + pushd "$HOME/stack" + if [ "$TRAVIS_OS_NAME" = "windows" ] + then + curl --location "$URL" > stack.zip + unzip stack.zip + mv stack.exe "$HOME/.local/bin/" + else + curl --location "$URL" > stack.tar.gz + tar -xzf stack.tar.gz --strip-components=1 + mv stack "$HOME/.local/bin/" + fi + popd fi +- | # Set up the timeout command + if which timeout >/dev/null + then + TIMEOUT=timeout + elif [ "$TRAVIS_OS_NAME" == "osx" ] + then + if ! which gtimeout >/dev/null + then + brew update + brew install coreutils + fi + TIMEOUT=gtimeout + else + echo "Unable to set up timeout command" + exit 1 + fi +- | + if ! stack --no-terminal setup 2>&1 > stack-setup.log + then + cat stack-setup.log + exit 1 + else + # stack setup is very verbose on windows + tail stack-setup.log + fi +- head stack-setup.log +- stack --version +- stack path - npm install -g bower # for psc-docs / psc-publish tests - export OS_NAME=$(./ci/convert-os-name.sh) -# Install 'gtimeout' if we need it - | - if [ "$TRAVIS_OS_NAME" == "osx" ] && ! which gtimeout >/dev/null + if [ -n "$TRAVIS_TAG" ] then - brew update - brew install coreutils + export CI_RELEASE=true fi script: -- | - [ -n "$TRAVIS_TAG" ] && export CI_RELEASE=true || true -- ci/build.sh +# Set a timeout of 35 minutes. We could use travis_wait here, but travis_wait +# doesn't produce any output until the command finishes, and also doesn't +# always show all of the command's output. +- $TIMEOUT 35m ci/build.sh before_deploy: - ./bundle/build.sh $OS_NAME deploy: @@ -90,4 +138,3 @@ deploy: on: all_branches: true tags: true - condition: "$DEPLOY = true" diff --git a/appveyor.yml b/appveyor.yml deleted file mode 100644 index 4fdbb4501a..0000000000 --- a/appveyor.yml +++ /dev/null @@ -1,76 +0,0 @@ -platform: x64 -version: '{build}' -environment: - # Keep the path as short as possible, just in case. - STACK_ROOT: c:\s - STACK_VER: 1.7.1 - RELEASE_USER: purescript - RELEASE_REPO: purescript - # We want to save the build cache on all builds, including those that failed, - # because this allows us to pick up where we left off in subsequent builds - # (in particular, compiling all of the Haskell dependencies of the compiler - # can take long enough that the build is terminated before we can finish). - # By default AppVeyor only saves the build cache on builds which succeed, so - # we ask to save the cache on failures too by setting this environment - # variable; see - # https://www.appveyor.com/docs/build-cache/#saving-cache-for-failed-build - APPVEYOR_SAVE_CACHE_ON_ERROR: true - # See https://github.com/commercialhaskell/stack/issues/3944, might no - # longer be necessary after we've moved to a snapshot with network >= 0.2.7.1 - TMP: "c:\\tmp" -branches: - # Only build master and tagged versions, i.e. not feature branches; feature - # branches already get built after opening a pull request. - # - # Note that, unlike Travis CI, there is no need for a semver tag regexp - # here, as AppVeyor seems to build all tags which are reachable from any - # of the branches listed below. - only: - - master -cache: -# appveyor/cache-buster.txt is a file which, if modified, invalidates the -# cached version of "c:\\s" (i.e. stack's cache). If bad data gets into the -# cache for any reason, the cache can be invalidated by committing a change to -# this file. See https://www.appveyor.com/docs/build-cache/ for more -# information. -- c:\s -> ci/appveyor-cache-buster.txt -install: -- ps: Install-Product node 10 -- npm install -g bower - -- ps: | - New-Item -ItemType Directory -Force -Path C:\tools - $env:Path += ";C:\tools" - $stackRelease = "stack-$env:STACK_VER-windows-x86_64" - $downloadUrl = "https://github.com/commercialhaskell/stack/releases/download/v$env:STACK_VER/$stackRelease.zip" - (New-Object Net.WebClient).DownloadFile($downloadUrl, 'c:\tools\stack.zip') - pushd c:\tools - 7z x c:\tools\stack.zip stack.exe - popd - -build_script: -- set BUILD_TYPE=normal -- if defined APPVEYOR_REPO_TAG_NAME ( set CI_RELEASE=true ) -- c:\msys64\usr\bin\bash ci\build.sh -on_success: -- ps: | - function UploadFile - { - github-release upload --user $env:RELEASE_USER --repo $env:RELEASE_REPO --tag $env:APPVEYOR_REPO_TAG_NAME --file $args[0] --name $args[0] - } - - if ($env:APPVEYOR_REPO_TAG_NAME) - { - bash ./bundle/build.sh win64 - - (New-Object Net.WebClient).DownloadFile('https://github.com/aktau/github-release/releases/download/v0.6.2/windows-amd64-github-release.zip', 'c:\tools\github-release.zip') - pushd c:\tools - 7z x github-release.zip bin/windows/amd64/github-release.exe - Copy-Item bin/windows/amd64/github-release.exe github-release.exe - popd - - pushd bundle - UploadFile win64.tar.gz - UploadFile win64.sha - popd - } diff --git a/ci/appveyor-cache-buster.txt b/ci/appveyor-cache-buster.txt deleted file mode 100644 index 8512adaf07..0000000000 --- a/ci/appveyor-cache-buster.txt +++ /dev/null @@ -1,8 +0,0 @@ -This file acts as a cache buster for the AppVeyor (Windows CI) build -cache. In order to invalidate the AppVeyor build cache, simply make a -change to the number at the end of this file and commit. - -See http://www.appveyor.com/docs/build-cache#cache-dependencies for more -information. - -Increment me to invalidate the cache: 0 diff --git a/ci/build.sh b/ci/build.sh index 7df3d7083c..c798ec900b 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -1,118 +1,49 @@ #!/bin/bash -set -e + +set -ex # This is the main CI build script. It is intended to run on all platforms we -# run CI on: linux, mac os, and windows (via msys). It makes use of the -# following environment variables: +# run CI on: linux, mac os, and windows. It makes use of the following +# environment variables: # -# BUILD_TYPE -# Must be one of the following: -# - "normal": Compile & run tests normally -# - "sdist": Create a source distribution and check that everything still -# compiles and works -# - "haddock": Check that haddock documentation builds correctly. +# - CI_RELEASE # -# CI_RELEASE -# If set to "true", passes the RELEASE flag to the compiler and enables -# optimizations. - -STACK="stack --no-terminal --jobs=1" -[[ "$BUILD_TYPE" == "haddock" ]] && DEPS_HADDOCK="--haddock" +# If set to "true", passes the RELEASE flag to the compiler, and enables +# optimizations. Otherwise, we disable optimizations (to speed builds up). +# +# = Source distributions +# +# During a normal build, we create a source distribution with `stack sdist`, +# and then compile and run tests inside that. The reason for this is that it +# helps catch issues arising from forgetting to list files which are necessary +# for compilation or for tests in our package.yaml file (these sorts of issues +# don't test to get noticed until after releasing otherwise). -# This command is ludicrously verbose on Windows, so we pipe the output to a -# file and only display it if the command fails. -if ! $STACK --verbosity=error setup 1>stack-setup.log 2>&1 -then - cat stack-setup.log - echo "Failed to run 'stack setup'" - exit 1 -fi +STACK="stack --no-terminal --jobs=2" -# Setup & install dependencies or abort -ret=0 -if [ -x "C:\\msys64\\usr\\bin\\timeout.exe" ] +if [ -f "c:\\msys64\\usr\\bin\\tar.exe" ] then - TIMEOUT=C:\\msys64\\usr\\bin\\timeout.exe -elif which timeout >/dev/null -then - TIMEOUT=timeout -elif which gtimeout >/dev/null -then - TIMEOUT=gtimeout + # Workaround for appveyor cygwin dll mismatch issue + TAR="c:\\msys64\\usr\\bin\\tar.exe" else - echo "timeout command not found (nor gtimeout)" - exit 1 + TAR=tar fi -$TIMEOUT 40m $STACK build \ - --only-dependencies --test $DEPS_HADDOCK \ - || ret=$? -case "$ret" in - 0) # continue - ;; - 124) - echo "Timed out while installing dependencies." - echo "Try pushing a new commit to build again." - exit 1 - ;; - *) - echo "Failed to install dependencies." - exit 1 - ;; -esac -# Set up configuration -STACK_EXTRA_FLAGS="" +STACK_OPTS="--test" if [ "$CI_RELEASE" = "true" ] then - # On release builds, set the 'release' cabal flag. - STACK_EXTRA_FLAGS="--flag purescript:RELEASE" + STACK_OPTS="$STACK_OPTS --flag=purescript:RELEASE" else - # On non-release builds, disable optimizations. - STACK_EXTRA_FLAGS="--fast" -fi - -if [ "$STACKAGE_NIGHTLY" = "true" ] -then - STACK_EXTRA_FLAGS="$STACK_EXTRA_FLAGS --resolver=nightly" -fi - -if [ "$COVERAGE" = "true" ] -then - STACK_EXTRA_FLAGS="$STACK_EXTRA_FLAGS --coverage" + STACK_OPTS="$STACK_OPTS --fast" fi -echo "STACK_EXTRA_FLAGS=\"$STACK_EXTRA_FLAGS\"" -BUILD_COMMAND="$STACK build --pedantic --test $STACK_EXTRA_FLAGS" - -if [ "$BUILD_TYPE" = "normal" ] -then - echo ">>> Building & testing..." - echo "> $BUILD_COMMAND" - $BUILD_COMMAND - -elif [ "$BUILD_TYPE" = "sdist" ] -then - echo ">>> Testing the source distribution..." - $STACK sdist - mkdir sdist-test - tar -xzf $(stack path --dist-dir)/purescript-*.tar.gz -C sdist-test --strip-components=1 - pushd sdist-test - echo "> $BUILD_COMMAND" - $BUILD_COMMAND - popd - -elif [ "$BUILD_TYPE" = "haddock" ] -then - echo ">>> Checking haddock documentation..." - $STACK haddock --fast -else - echo "Unrecognised BUILD_TYPE: $BUILD_TYPE" - exit 1 -fi +# Install snapshot dependencies (since these will be cached globally and thus +# can be reused during the sdist build step) +$STACK build --only-snapshot $STACK_OPTS -if [ "$COVERAGE" = "true" ] -then - echo ">>> Uploading test coverage report..." - which shc || $STACK install stack-hpc-coveralls - shc purescript tests || echo "Failed to upload coverage" -fi +# Test in a source distribution (see above) +$STACK sdist --tar-dir sdist-test; +$TAR -xzf sdist-test/purescript-*.tar.gz -C sdist-test --strip-components=1 +pushd sdist-test +$STACK build --pedantic $STACK_OPTS +popd diff --git a/ci/convert-os-name.sh b/ci/convert-os-name.sh index c3abbf2970..a2e0574ad3 100755 --- a/ci/convert-os-name.sh +++ b/ci/convert-os-name.sh @@ -8,6 +8,8 @@ case "$TRAVIS_OS_NAME" in echo linux64;; "osx") echo macos;; + "windows") + echo win64;; *) echo "Unknown TRAVIS_OS_NAME: $TRAVIS_OS_NAME"; exit 1;; diff --git a/ci/disable-windows-defender.sh b/ci/disable-windows-defender.sh new file mode 100755 index 0000000000..a344b3bf6e --- /dev/null +++ b/ci/disable-windows-defender.sh @@ -0,0 +1,23 @@ +#!/bin/bash + +# Intended to speed up builds by disabling Windows Defender. +# See https://travis-ci.community/t/current-known-issues-please-read-this-before-posting-a-new-topic/264/15 + +export NODEPATH=$(where.exe node.exe) +export PROJECTDIR=$(pwd) +export TEMPDIR=$LOCALAPPDATA\\Temp + +powershell Add-MpPreference -ExclusionProcess ${NODEPATH} +powershell Add-MpPreference -ExclusionPath ${PROJECTDIR} +powershell Add-MpPreference -ExclusionPath ${TEMPDIR} + +echo "DisableArchiveScanning..." +powershell Start-Process -PassThru -Wait PowerShell -ArgumentList "'-Command Set-MpPreference -DisableArchiveScanning \$true'" + +echo "DisableBehaviorMonitoring..." +powershell Start-Process -PassThru -Wait PowerShell -ArgumentList "'-Command Set-MpPreference -DisableBehaviorMonitoring \$true'" + +echo "DisableRealtimeMonitoring..." +powershell Start-Process -PassThru -Wait PowerShell -ArgumentList "'-Command Set-MpPreference -DisableRealtimeMonitoring \$true'" + + From bb15592efff9cec313527a55d62193f9f03d973d Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 14 Apr 2019 22:24:34 +0100 Subject: [PATCH 1088/1580] Final tweaks to ci/travis config - Remove appveyor badge from readme - Allow release key to be used from Travis --- .travis.yml | 2 +- README.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 3defb20086..97e94e3e32 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,7 +20,7 @@ matrix: # Workaround for a Travis caching bug on Windows where absolute paths # are not restored from caches properly: # https://github.com/travis-ci/casher/pull/38 - env: STACK_ROOT=$TRAVIS_BUILD_DIR/.stack_root RELEASE_KEY= + env: STACK_ROOT=$TRAVIS_BUILD_DIR/.stack_root # workaround for https://travis-ci.community/t/windows-instances-hanging-before-install/250/15 # We also zero out the RELEASE_KEY environment variable above to reduce # the risk of accidentally leaking it. diff --git a/README.md b/README.md index 273a88ccfe..f2239f35e0 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ A small strongly typed programming language with expressive types that compiles to JavaScript, written in and inspired by Haskell. -[![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript) [![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/purescript/purescript?branch=master&svg=true)](https://ci.appveyor.com/project/hdgarrood/purescript-lfgff/history) +[![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript) ## Language info From 2629ef7ec137e8577f0b27bf23cc8a583931bc1d Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 14 Apr 2019 23:15:36 +0100 Subject: [PATCH 1089/1580] Remove unnecessary appveyor workaround --- ci/build.sh | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/ci/build.sh b/ci/build.sh index c798ec900b..c6695b3c98 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -21,14 +21,6 @@ set -ex STACK="stack --no-terminal --jobs=2" -if [ -f "c:\\msys64\\usr\\bin\\tar.exe" ] -then - # Workaround for appveyor cygwin dll mismatch issue - TAR="c:\\msys64\\usr\\bin\\tar.exe" -else - TAR=tar -fi - STACK_OPTS="--test" if [ "$CI_RELEASE" = "true" ] then @@ -43,7 +35,7 @@ $STACK build --only-snapshot $STACK_OPTS # Test in a source distribution (see above) $STACK sdist --tar-dir sdist-test; -$TAR -xzf sdist-test/purescript-*.tar.gz -C sdist-test --strip-components=1 +tar -xzf sdist-test/purescript-*.tar.gz -C sdist-test --strip-components=1 pushd sdist-test $STACK build --pedantic $STACK_OPTS popd From 92cc0570a21e46d2593e36e87f23d98b68ca1f85 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 15 Apr 2019 00:43:43 +0100 Subject: [PATCH 1090/1580] Update resolver for license generator & rerun --- LICENSE | 34 ++++++++++++++++++++++++++++++++++ license-generator/generate.hs | 2 +- 2 files changed, 35 insertions(+), 1 deletion(-) diff --git a/LICENSE b/LICENSE index adb19a883a..b81d5fcbd7 100644 --- a/LICENSE +++ b/LICENSE @@ -2042,6 +2042,40 @@ fsnotify LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +ghc-boot-th LICENSE file: + + The Glasgow Haskell Compiler License + + Copyright 2002, The University Court of the University of Glasgow. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. + ghc-prim LICENSE file: This library (libraries/ghc-prim) is derived from code from several diff --git a/license-generator/generate.hs b/license-generator/generate.hs index 1fa427cc18..f2e389c113 100644 --- a/license-generator/generate.hs +++ b/license-generator/generate.hs @@ -1,5 +1,5 @@ #!/usr/bin/env stack --- stack --resolver lts-12.0 script +-- stack --resolver lts-13.12 script {-# LANGUAGE TupleSections #-} -- | From d46451362e6cc5d2d25acf25b56f1b54168bbb27 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 15 Apr 2019 00:58:17 +0100 Subject: [PATCH 1091/1580] v0.12.5 --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 769673521a..4e84be003f 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.12.4' +version: '0.12.5' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 99a53decf3561b199d483ee689fe83a22da4298c Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 15 Apr 2019 02:21:40 +0100 Subject: [PATCH 1092/1580] Fix making releases on Travis CI - Allow the bundle creation script to run inside a source distribution - Run the bundle creation script inside a source distribution on CI - A couple of other minor CI tweaks - Don't cache ~/.local/bin, it just makes downloading and upload caches take more time - Remove a misleading comment --- .travis.yml | 9 +++------ bundle/build.sh | 31 +++++++++++++++---------------- package.yaml | 2 ++ 3 files changed, 20 insertions(+), 22 deletions(-) diff --git a/.travis.yml b/.travis.yml index 97e94e3e32..9f32af7770 100644 --- a/.travis.yml +++ b/.travis.yml @@ -22,8 +22,6 @@ matrix: # https://github.com/travis-ci/casher/pull/38 env: STACK_ROOT=$TRAVIS_BUILD_DIR/.stack_root # workaround for https://travis-ci.community/t/windows-instances-hanging-before-install/250/15 - # We also zero out the RELEASE_KEY environment variable above to reduce - # the risk of accidentally leaking it. filter_secrets: false addons: apt: @@ -48,7 +46,6 @@ cache: # given commit with if the cache was created by a parent of the commit being # built (which is sensible of them). directories: - - $HOME/.local/bin - $HOME/.stack # Workaround for a Travis caching bug on Windows where absolute paths @@ -127,13 +124,13 @@ script: # always show all of the command's output. - $TIMEOUT 35m ci/build.sh before_deploy: -- ./bundle/build.sh $OS_NAME +- ./sdist-test/bundle/build.sh $OS_NAME deploy: provider: releases api_key: $RELEASE_KEY file: - - bundle/$OS_NAME.tar.gz - - bundle/$OS_NAME.sha + - sdist-test/bundle/$OS_NAME.tar.gz + - sdist-test/bundle/$OS_NAME.sha skip_cleanup: true on: all_branches: true diff --git a/bundle/build.sh b/bundle/build.sh index 5a9ed9712c..4402c6baa9 100755 --- a/bundle/build.sh +++ b/bundle/build.sh @@ -1,7 +1,10 @@ -## This script can be run on any supported OS to create a binary .tar.gz -## bundle. -## For Windows, msysgit contains all of the pieces needed to run this script. -set -e +#!/bin/bash + +# This script can be run on any supported OS to create a binary .tar.gz +# bundle. For Windows, msysgit contains all of the pieces needed to run this +# script. + +set -ex OS=$1 @@ -13,21 +16,17 @@ fi pushd $(stack path --project-root) -LOCAL_INSTALL_ROOT=$(stack path --local-install-root) +# Make the staging directory +mkdir -p bundle/build/purescript +# Strip the binary, and copy it to the staging directory if [ "$OS" = "win64" ] then - BIN_EXT=".exe" + BIN="purs.exe" else - BIN_EXT="" + BIN="purs" fi - -# Make the staging directory -mkdir -p bundle/build/purescript - -# Strip the binaries, and copy them to the staging directory -BIN=purs -FULL_BIN="$LOCAL_INSTALL_ROOT/bin/${BIN}${BIN_EXT}" +FULL_BIN="$(stack path --local-install-root)/bin/$BIN" if [ "$OS" != "win64" ] then strip "$FULL_BIN" @@ -39,7 +38,7 @@ cp bundle/README bundle/build/purescript/ cp LICENSE bundle/build/purescript/ cp INSTALL.md bundle/build/purescript/ -stack list-dependencies >bundle/build/purescript/dependencies.txt +stack ls dependencies >bundle/build/purescript/dependencies.txt # Make the binary bundle pushd bundle/build > /dev/null @@ -58,6 +57,6 @@ fi $SHASUM bundle/${OS}.tar.gz > bundle/${OS}.sha # Remove the staging directory -rm -rf build/ +rm -r bundle/build popd > /dev/null diff --git a/package.yaml b/package.yaml index 4e84be003f..650eb88793 100644 --- a/package.yaml +++ b/package.yaml @@ -17,6 +17,8 @@ github: purescript/purescript homepage: http://www.purescript.org/ extra-source-files: - app/static/* + - bundle/build.sh + - bundle/README - tests/purs/**/*.js - tests/purs/**/*.purs - tests/purs/**/*.json From 674089385ee44ac596d13b7c7b29b45369b823ad Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 15 Apr 2019 02:43:35 +0100 Subject: [PATCH 1093/1580] Fix travis deploy --- .travis.yml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 9f32af7770..ae31a4d547 100644 --- a/.travis.yml +++ b/.travis.yml @@ -124,7 +124,9 @@ script: # always show all of the command's output. - $TIMEOUT 35m ci/build.sh before_deploy: -- ./sdist-test/bundle/build.sh $OS_NAME +- pushd sdist-test +- bundle/build.sh $OS_NAME +- popd deploy: provider: releases api_key: $RELEASE_KEY From 0069b31eefcceda455b40a42776763483d67e1ec Mon Sep 17 00:00:00 2001 From: Colin Wahl Date: Thu, 18 Apr 2019 11:40:17 -0700 Subject: [PATCH 1094/1580] Allow kind annotations in `forall` contexts (#3576) * Allow kind signatures in forall contexts. Still need to propagate kind information through type/kind checking * use parsed kind in kind inference * pretty print kinds signatures in forall contexts * code cleanup * update kind names in ForAll blocks * consider kind annotations in forall contexts in ord instance for Type * remove duplicated kindedIdent and parseKindedIdent * add compareMaybeKind * add eqMaybeKind, make tests compile * fix type to/from json functions * add tests * Break renderTypeVars and renderTypeVar into separate functions * woops extra spacing --- .../Docs/RenderedCode/RenderType.hs | 14 ++++- src/Language/PureScript/Ide/CaseSplit.hs | 2 +- src/Language/PureScript/Kinds.hs | 12 ++++ src/Language/PureScript/Linter.hs | 4 +- src/Language/PureScript/Linter/Exhaustive.hs | 1 + .../PureScript/Parser/Declarations.hs | 5 -- src/Language/PureScript/Parser/Types.hs | 9 ++- src/Language/PureScript/Pretty/Types.hs | 13 +++-- src/Language/PureScript/Sugar/Names.hs | 3 + .../PureScript/Sugar/TypeClasses/Deriving.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 2 +- src/Language/PureScript/TypeChecker/Kinds.hs | 8 +-- .../PureScript/TypeChecker/Skolems.hs | 6 +- .../PureScript/TypeChecker/Subsumption.hs | 4 +- src/Language/PureScript/TypeChecker/Types.hs | 8 +-- src/Language/PureScript/TypeChecker/Unify.hs | 7 ++- src/Language/PureScript/Types.hs | 56 +++++++++++-------- tests/TestDocs.hs | 2 +- tests/purs/failing/3549-a.purs | 10 ++++ tests/purs/failing/3549.purs | 11 ++++ tests/purs/passing/3549.purs | 13 +++++ 21 files changed, 130 insertions(+), 62 deletions(-) create mode 100644 tests/purs/failing/3549-a.purs create mode 100644 tests/purs/failing/3549.purs create mode 100644 tests/purs/passing/3549.purs diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index 25837ecba4..242f8a4685 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -131,15 +131,15 @@ matchType = buildPrettyPrinter operators matchTypeAtom OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ] , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ] , [ Wrap constrained $ \deps ty -> renderConstraints deps ty ] - , [ Wrap forall_ $ \tyVars ty -> mconcat [keywordForall, sp, mintersperse sp (map typeVar tyVars), syntax ".", sp, ty] ] + , [ Wrap forall_ $ \tyVars ty -> mconcat [ keywordForall, sp, renderTypeVars tyVars, syntax ".", sp, ty ] ] , [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ] , [ Wrap explicitParens $ \_ ty -> ty ] ] -forall_ :: Pattern () PrettyPrintType ([Text], PrettyPrintType) +forall_ :: Pattern () PrettyPrintType ([(Text, Maybe (Kind ()))], PrettyPrintType) forall_ = mkPattern match where - match (PPForAll idents ty) = Just (idents, ty) + match (PPForAll mbKindedIdents ty) = Just (mbKindedIdents, ty) match _ = Nothing -- | @@ -153,6 +153,14 @@ renderType' = fromMaybe (internalError "Incomplete pattern") . PA.pattern matchType () +renderTypeVars :: [(Text, Maybe (Kind a))] -> RenderedCode +renderTypeVars tyVars = mintersperse sp (map renderTypeVar tyVars) + +renderTypeVar :: (Text, Maybe (Kind a)) -> RenderedCode +renderTypeVar (v, mbK) = case mbK of + Nothing -> typeVar v + Just k -> mintersperse sp [ mconcat [syntax "(", typeVar v], syntax "::", mconcat [renderKind k, syntax ")"] ] + -- | -- Render code representing a Type, as it should appear inside parentheses -- diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 253ef530e0..a617ba08ef 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -149,7 +149,7 @@ splitFunctionType t = fromMaybe [] arguments where arguments = initMay splitted splitted = splitType' t - splitType' (P.ForAll _ _ t' _) = splitType' t' + splitType' (P.ForAll _ _ _ t' _) = splitType' t' splitType' (P.ConstrainedType _ _ t') = splitType' t' splitType' (P.TypeApp _ (P.TypeApp _ t' lhs) rhs) | P.eqType t' P.tyFunction = lhs : splitType' rhs diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index f58cceeed8..86686d65d0 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -155,6 +155,12 @@ eqKind (FunKind _ a b) (FunKind _ a' b') = eqKind a a' && eqKind b b' eqKind (NamedKind _ a) (NamedKind _ a') = a == a' eqKind _ _ = False +eqMaybeKind :: Maybe (Kind a) -> Maybe (Kind b) -> Bool +eqMaybeKind Nothing (Just _) = False +eqMaybeKind (Just _) Nothing = False +eqMaybeKind Nothing Nothing = True +eqMaybeKind (Just a) (Just b) = eqKind a b + compareKind :: Kind a -> Kind b -> Ordering compareKind (KUnknown _ a) (KUnknown _ a') = compare a a' compareKind (KUnknown {}) _ = LT @@ -169,3 +175,9 @@ compareKind _ (FunKind {}) = GT compareKind (NamedKind _ a) (NamedKind _ a') = compare a a' compareKind (NamedKind {}) _ = GT + +compareMaybeKind :: Maybe (Kind a) -> Maybe (Kind b) -> Ordering +compareMaybeKind Nothing Nothing = EQ +compareMaybeKind Nothing (Just _) = LT +compareMaybeKind (Just _) Nothing = GT +compareMaybeKind (Just a) (Just b) = compareKind a b diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 96c11b84e2..fefed909ad 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -85,7 +85,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl where step :: S.Set Text -> SourceType -> (S.Set Text, MultipleErrors) - step s (ForAll _ tv _ _) = bindVar s tv + step s (ForAll _ tv _ _ _) = bindVar s tv step s _ = (s, mempty) bindVar :: S.Set Text -> Text -> (S.Set Text, MultipleErrors) @@ -96,7 +96,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl -- Recursively walk the type and prune used variables from `unused` go :: S.Set Text -> SourceType -> (S.Set Text, MultipleErrors) go unused (TypeVar _ v) = (S.delete v unused, mempty) - go unused (ForAll _ tv t1 _) = + go unused (ForAll _ tv _ t1 _) = let (nowUnused, errors) = go (S.insert tv unused) t1 restoredUnused = if S.member tv unused then S.insert tv nowUnused else nowUnused combinedErrors = if S.member tv nowUnused then errors <> errorMessage' ss (UnusedTypeVar tv) else errors diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index ff64b442de..27562b435a 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -306,6 +306,7 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' ty :: Text -> SourceType ty tyVar = srcForAll tyVar + Nothing ( srcConstrainedType (srcConstraint C.Partial [] (Just constraintData)) $ srcTypeApp (srcTypeApp tyFunction (srcTypeVar tyVar)) (srcTypeVar tyVar) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 33b9c0b2ed..c7c3a945d8 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -30,7 +30,6 @@ import Data.Text (Text, pack) import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Errors -import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Parser.Common import Language.PureScript.Parser.Kinds @@ -41,10 +40,6 @@ import Language.PureScript.Types import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P -kindedIdent :: TokenParser (Text, Maybe SourceKind) -kindedIdent = (, Nothing) <$> identifier - <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind))) - fields :: [Ident] fields = [ Ident ("value" <> pack (show (n :: Integer))) | n <- [0..] ] diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index 2bd34f6672..a83ecdc9c6 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -1,5 +1,6 @@ module Language.PureScript.Parser.Types - ( parseType + ( kindedIdent + , parseType , parsePolyType , noForAll , noWildcards @@ -51,11 +52,15 @@ parseTypeVariable = withSourceAnnF $ do parseTypeConstructor :: TokenParser SourceType parseTypeConstructor = withSourceAnnF $ flip TypeConstructor <$> parseQualified typeName +kindedIdent :: TokenParser (T.Text, Maybe SourceKind) +kindedIdent = (, Nothing) <$> identifier + <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind))) + parseForAll :: TokenParser SourceType parseForAll = mkForAll <$> ((reserved "forall" <|> reserved "∀") - *> (P.many1 $ indented *> (withSourceAnnF $ flip (,) <$> identifier)) + *> (P.many1 $ indented *> (withSourceAnnF $ flip (,) <$> kindedIdent)) <* indented <* dot) <*> parseType diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 35445c35c6..46cf552e87 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -51,7 +51,7 @@ data PrettyPrintType | PPKindedType PrettyPrintType (Kind ()) | PPBinaryNoParensType PrettyPrintType PrettyPrintType PrettyPrintType | PPParensInType PrettyPrintType - | PPForAll [Text] PrettyPrintType + | PPForAll [(Text, Maybe (Kind ()))] PrettyPrintType | PPFunction PrettyPrintType PrettyPrintType | PPRecord [(Label, PrettyPrintType)] (Maybe PrettyPrintType) | PPRow [(Label, PrettyPrintType)] (Maybe PrettyPrintType) @@ -76,10 +76,10 @@ convertPrettyPrintType = go go d (ParensInType _ ty) = PPParensInType (go (d-1) ty) go _ (REmpty _) = PPRow [] Nothing go d ty@RCons{} = uncurry PPRow (goRow d ty) - go d (ForAll _ v ty _) = goForAll d [v] ty + go d (ForAll _ v mbK ty _) = goForAll d [(v, fmap ($> ()) mbK)] ty go d (TypeApp _ a b) = goTypeApp d a b - goForAll d vs (ForAll _ v ty _) = goForAll d (v : vs) ty + goForAll d vs (ForAll _ v mbK ty _) = goForAll d ((v, fmap ($> ()) mbK) : vs) ty goForAll d vs ty = PPForAll vs (go (d-1) ty) goRow d ty = @@ -194,7 +194,7 @@ matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ] , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text rightArrow <> " " <> ret) ] , [ Wrap constrained $ \deps ty -> constraintsAsBox tro deps ty ] - , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text (forall' ++ " " ++ unwords idents ++ ".")) ty ] + , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text (forall' ++ " " ++ unwords (fmap printMbKindedType idents) ++ ".")) ty ] , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (doubleColon ++ " " ++ T.unpack (prettyPrintKind k))) ] , [ Wrap explicitParens $ \_ ty -> ty ] ] @@ -202,6 +202,7 @@ matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where rightArrow = if troUnicode tro then "→" else "->" forall' = if troUnicode tro then "∀" else "forall" doubleColon = if troUnicode tro then "∷" else "::" + printMbKindedType (v, mbK) = maybe v (\k -> unwords ["(" ++ v, doubleColon, T.unpack (prettyPrintKind k) ++ ")"]) mbK -- If both boxes span a single line, keep them on the same line, or else -- use the specified function to modify the second box, then combine vertically. @@ -210,10 +211,10 @@ matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where | rows b1 > 1 || rows b2 > 1 = vcat left [ b1, f b2 ] | otherwise = hcat top [ b1, text " ", b2] -forall_ :: Pattern () PrettyPrintType ([String], PrettyPrintType) +forall_ :: Pattern () PrettyPrintType ([(String, Maybe (Kind ()))], PrettyPrintType) forall_ = mkPattern match where - match (PPForAll idents ty) = Just (map T.unpack idents, ty) + match (PPForAll idents ty) = Just (map (\(v, mbK) -> (T.unpack v, mbK)) idents, ty) match _ = Nothing typeAtomAsBox' :: PrettyPrintType -> Box diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 54370a4a04..063979a8d7 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -333,6 +333,9 @@ renameInModule imports (Module modSS coms mn decls exps) = updateType (TypeOp ann@(ss, _) name) = TypeOp ann <$> updateTypeOpName name ss updateType (TypeConstructor ann@(ss, _) name) = TypeConstructor ann <$> updateTypeName name ss updateType (ConstrainedType ann c t) = ConstrainedType ann <$> updateInConstraint c <*> pure t + updateType (ForAll ann v mbK t sco) = case mbK of + Nothing -> pure $ ForAll ann v Nothing t sco + Just k -> ForAll ann v <$> fmap pure (updateKindsEverywhere k) <*> pure t <*> pure sco updateType (KindedType ann t k) = KindedType ann t <$> updateKindsEverywhere k updateType t = return t updateInConstraint :: SourceConstraint -> m SourceConstraint diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 25c380f068..fa10eb6693 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -747,7 +747,7 @@ deriveFunctor ss mn syns ds tyConNm = do return (lam ss arg (ObjectUpdate argVar (mkAssignment <$> updates))) -- quantifiers - goType (ForAll _ scopedVar t _) | scopedVar /= iTyName = goType t + goType (ForAll _ scopedVar _ t _) | scopedVar /= iTyName = goType t -- constraints goType (ConstrainedType _ _ t) = goType t diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 5bacf63dfb..4d6e098128 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -75,7 +75,7 @@ addDataConstructor moduleName dtype name args dctor dctorArgs = do traverse_ checkTypeSynonyms tys let retTy = foldl srcTypeApp (srcTypeConstructor (Qualified (Just moduleName) name)) (map srcTypeVar args) let dctorTy = foldr function retTy tys - let polyType = mkForAll (map (NullSourceAnn,) args) dctorTy + let polyType = mkForAll (map (\i -> (NullSourceAnn, (i, Nothing))) args) dctorTy putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } addTypeSynonym diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 0e6792c27b..854181b81c 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -216,8 +216,8 @@ infer' . (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> m (SourceKind, [(Text, SourceKind)]) -infer' (ForAll ann ident ty _) = do - k1 <- freshKind ann +infer' (ForAll ann ident mbK ty _) = do + k1 <- maybe (freshKind ann) pure mbK Just moduleName <- checkCurrentModule <$> get (k2, args) <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty unifyKinds k2 kindType @@ -229,8 +229,8 @@ infer' (KindedType _ ty k) = do infer' other = (, []) <$> go other where go :: SourceType -> m SourceKind - go (ForAll ann ident ty _) = do - k1 <- freshKind ann + go (ForAll ann ident mbK ty _) = do + k1 <- maybe (freshKind ann) pure mbK Just moduleName <- checkCurrentModule <$> get k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ go ty unifyKinds k2 kindType diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 76af631635..170ea7ebcd 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -34,7 +34,7 @@ newSkolemConstant = do introduceSkolemScope :: MonadState CheckState m => Type a -> m (Type a) introduceSkolemScope = everywhereOnTypesM go where - go (ForAll ann ident ty Nothing) = ForAll ann ident ty <$> (Just <$> newSkolemScope) + go (ForAll ann ident mbK ty Nothing) = ForAll ann ident mbK ty <$> (Just <$> newSkolemScope) go other = return other -- | Generate a new skolem scope @@ -71,7 +71,7 @@ skolemizeTypesInValue ann ident sko scope = onBinder sco other = return (sco, other) peelTypeVars :: SourceType -> [Text] - peelTypeVars (ForAll _ i ty _) = i : peelTypeVars ty + peelTypeVars (ForAll _ i _ ty _) = i : peelTypeVars ty peelTypeVars _ = [] -- | Ensure skolem variables do not escape their scope @@ -116,7 +116,7 @@ skolemEscapeCheck expr@TypedValue{} = -- Collect any scopes appearing in quantifiers at the top level collectScopes :: SourceType -> [SkolemScope] - collectScopes (ForAll _ _ t (Just sco)) = sco : collectScopes t + collectScopes (ForAll _ _ _ t (Just sco)) = sco : collectScopes t collectScopes ForAll{} = internalError "skolemEscapeCheck: No skolem scope" collectScopes _ = [] diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index af5275dcca..d85d905144 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -75,10 +75,10 @@ subsumes' -> SourceType -> SourceType -> m (Coercion mode) -subsumes' mode (ForAll _ ident ty1 _) ty2 = do +subsumes' mode (ForAll _ ident _ ty1 _) ty2 = do replaced <- replaceVarWithUnknown ident ty1 subsumes' mode replaced ty2 -subsumes' mode ty1 (ForAll _ ident ty2 sco) = +subsumes' mode ty1 (ForAll _ ident _ ty2 sco) = case sco of Just sco' -> do sko <- newSkolemConstant diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index f372a698f2..3b862794c0 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -282,7 +282,7 @@ instantiatePolyTypeWithUnknowns => Expr -> SourceType -> m (Expr, SourceType) -instantiatePolyTypeWithUnknowns val (ForAll _ ident ty _) = do +instantiatePolyTypeWithUnknowns val (ForAll _ ident _ ty _) = do ty' <- replaceVarWithUnknown ident ty instantiatePolyTypeWithUnknowns val ty' instantiatePolyTypeWithUnknowns val (ConstrainedType _ con ty) = do @@ -614,7 +614,7 @@ check' => Expr -> SourceType -> m Expr -check' val (ForAll ann ident ty _) = do +check' val (ForAll ann ident mbK ty _) = do scope <- newSkolemScope sko <- newSkolemConstant let ss = case val of @@ -623,7 +623,7 @@ check' val (ForAll ann ident ty _) = do sk = skolemize ss ident sko scope ty skVal = skolemizeTypesInValue ss ident sko scope val val' <- check skVal sk - return $ TypedValue True val' (ForAll ann ident ty (Just scope)) + return $ TypedValue True val' (ForAll ann ident mbK ty (Just scope)) check' val t@(ConstrainedType _ con@(Constraint _ (Qualified _ (ProperName className)) _ _) ty) = do dictName <- freshIdent ("dict" <> className) dicts <- newDictionaries [] (Qualified Nothing dictName) con @@ -817,7 +817,7 @@ checkFunctionApplication' fn (TypeApp _ (TypeApp _ tyFunction' argTy) retTy) arg unifyTypes tyFunction' tyFunction arg' <- check arg argTy return (retTy, App fn arg') -checkFunctionApplication' fn (ForAll _ ident ty _) arg = do +checkFunctionApplication' fn (ForAll _ ident _ ty _) arg = do replaced <- replaceVarWithUnknown ident ty checkFunctionApplication fn replaced arg checkFunctionApplication' fn (KindedType _ ty _) arg = diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 19bf3e641c..e5bf87e87f 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -90,7 +90,7 @@ unifyTypes t1 t2 = do unifyTypes' (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = return () unifyTypes' (TUnknown _ u) t = solveType u t unifyTypes' t (TUnknown _ u) = solveType u t - unifyTypes' (ForAll ann1 ident1 ty1 sc1) (ForAll ann2 ident2 ty2 sc2) = + unifyTypes' (ForAll ann1 ident1 _ ty1 sc1) (ForAll ann2 ident2 _ ty2 sc2) = case (sc1, sc2) of (Just sc1', Just sc2') -> do sko <- newSkolemConstant @@ -98,7 +98,7 @@ unifyTypes t1 t2 = do let sk2 = skolemize ann2 ident2 sko sc2' ty2 sk1 `unifyTypes` sk2 _ -> internalError "unifyTypes: unspecified skolem scope" - unifyTypes' (ForAll ann ident ty1 (Just sc)) ty2 = do + unifyTypes' (ForAll ann ident _ ty1 (Just sc)) ty2 = do sko <- newSkolemConstant let sk = skolemize ann ident sko sc ty1 sk `unifyTypes` ty2 @@ -199,8 +199,9 @@ varIfUnknown :: SourceType -> SourceType varIfUnknown ty = let unks = nubBy ((==) `on` snd) $ unknownsInType ty toName = T.cons 't' . T.pack . show + addKind a = (a, Nothing) ty' = everywhereOnTypes typeToVar ty typeToVar :: SourceType -> SourceType typeToVar (TUnknown ann u) = TypeVar ann (toName u) typeToVar t = t - in mkForAll (sortBy (comparing snd) . fmap (fmap toName) $ unks) ty' + in mkForAll (fmap (fmap addKind) . sortBy (comparing snd) . fmap (fmap toName) $ unks) ty' diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 56f963bfd3..ae22b11b65 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -67,7 +67,7 @@ data Type a -- | A type application | TypeApp a (Type a) (Type a) -- | Forall quantifier - | ForAll a Text (Type a) (Maybe SkolemScope) + | ForAll a Text (Maybe (Kind a)) (Type a) (Maybe SkolemScope) -- | A type with a set of type class constraints | ConstrainedType a (Constraint a) (Type a) -- | A skolem constant @@ -112,7 +112,7 @@ srcTypeOp = TypeOp NullSourceAnn srcTypeApp :: SourceType -> SourceType -> SourceType srcTypeApp = TypeApp NullSourceAnn -srcForAll :: Text -> SourceType -> Maybe SkolemScope -> SourceType +srcForAll :: Text -> Maybe SourceKind -> SourceType -> Maybe SkolemScope -> SourceType srcForAll = ForAll NullSourceAnn srcConstrainedType :: SourceConstraint -> SourceType -> SourceType @@ -203,8 +203,10 @@ typeToJSON annToJSON ty = variant "TypeOp" a b TypeApp a b c -> variant "TypeApp" a (go b, go c) - ForAll a b c d -> - variant "ForAll" a (b, go c, d) + ForAll a b c d e -> + case c of + Nothing -> variant "ForAll" a (b, go d, e) + Just k -> variant "ForAll" a (b, kindToJSON annToJSON k, go d, e) ConstrainedType a b c -> variant "ConstrainedType" a (constraintToJSON annToJSON b, go c) Skolem a b c d -> @@ -285,8 +287,14 @@ typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do (b, c) <- contents TypeApp a <$> go b <*> go c "ForAll" -> do - (b, c, d) <- contents - ForAll a b <$> go c <*> pure d + let + withoutMbKind = do + (b, c, d) <- contents + ForAll a b Nothing <$> go c <*> pure d + withMbKind = do + (b, c, d, e) <- contents + ForAll a b <$> (Just <$> kindFromJSON defaultAnn annFromJSON c) <*> go d <*> pure e + withMbKind <|> withoutMbKind "ConstrainedType" -> do (b, c) <- contents ConstrainedType a <$> constraintFromJSON defaultAnn annFromJSON b <*> go c @@ -368,8 +376,8 @@ isMonoType (KindedType _ t _) = isMonoType t isMonoType _ = True -- | Universally quantify a type -mkForAll :: [(a, Text)] -> Type a -> Type a -mkForAll args ty = foldl (\t (ann, arg) -> ForAll ann arg t Nothing) ty args +mkForAll :: [(a, (Text, Maybe (Kind a)))] -> Type a -> Type a +mkForAll args ty = foldl (\t (ann, (arg, mbK)) -> ForAll ann arg mbK t Nothing) ty args -- | Replace a type variable, taking into account variable shadowing replaceTypeVars :: Text -> Type a -> Type a -> Type a @@ -381,13 +389,13 @@ replaceAllTypeVars = go [] where go :: [Text] -> [(Text, Type a)] -> Type a -> Type a go _ m (TypeVar ann v) = fromMaybe (TypeVar ann v) (v `lookup` m) go bs m (TypeApp ann t1 t2) = TypeApp ann (go bs m t1) (go bs m t2) - go bs m f@(ForAll ann v t sco) + go bs m f@(ForAll ann v mbK t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f | v `elem` usedVars = let v' = genName v (keys ++ bs ++ usedVars) t' = go bs [(v, TypeVar ann v')] t - in ForAll ann v' (go (v' : bs) m t') sco - | otherwise = ForAll ann v (go (v : bs) m t) sco + in ForAll ann v' mbK (go (v' : bs) m t') sco + | otherwise = ForAll ann v mbK (go (v : bs) m t) sco where keys = map fst m usedVars = concatMap (usedTypeVariables . snd) m @@ -415,7 +423,7 @@ freeTypeVariables = ordNub . go [] where go :: [Text] -> Type a -> [Text] go bound (TypeVar _ v) | v `notElem` bound = [v] go bound (TypeApp _ t1 t2) = go bound t1 ++ go bound t2 - go bound (ForAll _ v t _) = go (v : bound) t + go bound (ForAll _ v _ t _) = go (v : bound) t go bound (ConstrainedType _ c t) = concatMap (go bound) (constraintArgs c) ++ go bound t go bound (RCons _ _ t r) = go bound t ++ go bound r go bound (KindedType _ t _) = go bound t @@ -425,14 +433,14 @@ freeTypeVariables = ordNub . go [] where -- | Universally quantify over all type variables appearing free in a type quantify :: Type a -> Type a -quantify ty = foldr (\arg t -> ForAll (getAnnForType ty) arg t Nothing) ty $ freeTypeVariables ty +quantify ty = foldr (\arg t -> ForAll (getAnnForType ty) arg Nothing t Nothing) ty $ freeTypeVariables ty -- | Move all universal quantifiers to the front of a type moveQuantifiersToFront :: Type a -> Type a moveQuantifiersToFront = go [] [] where - go qs cs (ForAll ann q ty sco) = go ((ann, q, sco) : qs) cs ty + go qs cs (ForAll ann q mbK ty sco) = go ((ann, q, sco, mbK) : qs) cs ty go qs cs (ConstrainedType ann c ty) = go qs ((ann, c) : cs) ty - go qs cs ty = foldl (\ty' (ann, q, sco) -> ForAll ann q ty' sco) (foldl (\ty' (ann, c) -> ConstrainedType ann c ty') ty cs) qs + go qs cs ty = foldl (\ty' (ann, q, sco, mbK) -> ForAll ann q mbK ty' sco) (foldl (\ty' (ann, c) -> ConstrainedType ann c ty') ty cs) qs -- | Check if a type contains wildcards containsWildcards :: Type a -> Bool @@ -451,7 +459,7 @@ containsForAll = everythingOnTypes (||) go where everywhereOnTypes :: (Type a -> Type a) -> Type a -> Type a everywhereOnTypes f = go where go (TypeApp ann t1 t2) = f (TypeApp ann (go t1) (go t2)) - go (ForAll ann arg ty sco) = f (ForAll ann arg (go ty) sco) + go (ForAll ann arg mbK ty sco) = f (ForAll ann arg mbK (go ty) sco) go (ConstrainedType ann c ty) = f (ConstrainedType ann (mapConstraintArgs (map go) c) (go ty)) go (RCons ann name ty rest) = f (RCons ann name (go ty) (go rest)) go (KindedType ann ty k) = f (KindedType ann (go ty) k) @@ -462,7 +470,7 @@ everywhereOnTypes f = go where everywhereOnTypesTopDown :: (Type a -> Type a) -> Type a -> Type a everywhereOnTypesTopDown f = go . f where go (TypeApp ann t1 t2) = TypeApp ann (go (f t1)) (go (f t2)) - go (ForAll ann arg ty sco) = ForAll ann arg (go (f ty)) sco + go (ForAll ann arg mbK ty sco) = ForAll ann arg mbK (go (f ty)) sco go (ConstrainedType ann c ty) = ConstrainedType ann (mapConstraintArgs (map (go . f)) c) (go (f ty)) go (RCons ann name ty rest) = RCons ann name (go (f ty)) (go (f rest)) go (KindedType ann ty k) = KindedType ann (go (f ty)) k @@ -473,7 +481,7 @@ everywhereOnTypesTopDown f = go . f where everywhereOnTypesM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (Type a) everywhereOnTypesM f = go where go (TypeApp ann t1 t2) = (TypeApp ann <$> go t1 <*> go t2) >>= f - go (ForAll ann arg ty sco) = (ForAll ann arg <$> go ty <*> pure sco) >>= f + go (ForAll ann arg mbK ty sco) = (ForAll ann arg mbK <$> go ty <*> pure sco) >>= f go (ConstrainedType ann c ty) = (ConstrainedType ann <$> overConstraintArgs (mapM go) c <*> go ty) >>= f go (RCons ann name ty rest) = (RCons ann name <$> go ty <*> go rest) >>= f go (KindedType ann ty k) = (KindedType ann <$> go ty <*> pure k) >>= f @@ -484,7 +492,7 @@ everywhereOnTypesM f = go where everywhereOnTypesTopDownM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (Type a) everywhereOnTypesTopDownM f = go <=< f where go (TypeApp ann t1 t2) = TypeApp ann <$> (f t1 >>= go) <*> (f t2 >>= go) - go (ForAll ann arg ty sco) = ForAll ann arg <$> (f ty >>= go) <*> pure sco + go (ForAll ann arg mbK ty sco) = ForAll ann arg mbK <$> (f ty >>= go) <*> pure sco go (ConstrainedType ann c ty) = ConstrainedType ann <$> overConstraintArgs (mapM (go <=< f)) c <*> (f ty >>= go) go (RCons ann name ty rest) = RCons ann name <$> (f ty >>= go) <*> (f rest >>= go) go (KindedType ann ty k) = KindedType ann <$> (f ty >>= go) <*> pure k @@ -495,7 +503,7 @@ everywhereOnTypesTopDownM f = go <=< f where everythingOnTypes :: (r -> r -> r) -> (Type a -> r) -> Type a -> r everythingOnTypes (<+>) f = go where go t@(TypeApp _ t1 t2) = f t <+> go t1 <+> go t2 - go t@(ForAll _ _ ty _) = f t <+> go ty + go t@(ForAll _ _ _ ty _) = f t <+> go ty go t@(ConstrainedType _ c ty) = foldl (<+>) (f t) (map go (constraintArgs c)) <+> go ty go t@(RCons _ _ ty rest) = f t <+> go ty <+> go rest go t@(KindedType _ ty _) = f t <+> go ty @@ -507,7 +515,7 @@ everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type a -> (s, r everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 where go' s t = let (s', r) = f s t in r <+> go s' t go s (TypeApp _ t1 t2) = go' s t1 <+> go' s t2 - go s (ForAll _ _ ty _) = go' s ty + go s (ForAll _ _ _ ty _) = go' s ty go s (ConstrainedType _ c ty) = foldl (<+>) r0 (map (go' s) (constraintArgs c)) <+> go' s ty go s (RCons _ _ ty rest) = go' s ty <+> go' s rest go s (KindedType _ ty _) = go' s ty @@ -523,7 +531,7 @@ annForType k (TypeWildcard a b) = (\z -> TypeWildcard z b) <$> k a annForType k (TypeConstructor a b) = (\z -> TypeConstructor z b) <$> k a annForType k (TypeOp a b) = (\z -> TypeOp z b) <$> k a annForType k (TypeApp a b c) = (\z -> TypeApp z b c) <$> k a -annForType k (ForAll a b c d) = (\z -> ForAll z b c d) <$> k a +annForType k (ForAll a b c d e) = (\z -> ForAll z b c d e) <$> k a annForType k (ConstrainedType a b c) = (\z -> ConstrainedType z b c) <$> k a annForType k (Skolem a b c d) = (\z -> Skolem z b c d) <$> k a annForType k (REmpty a) = REmpty <$> k a @@ -552,7 +560,7 @@ eqType (TypeWildcard _ a) (TypeWildcard _ a') = a == a' eqType (TypeConstructor _ a) (TypeConstructor _ a') = a == a' eqType (TypeOp _ a) (TypeOp _ a') = a == a' eqType (TypeApp _ a b) (TypeApp _ a' b') = eqType a a' && eqType b b' -eqType (ForAll _ a b c) (ForAll _ a' b' c') = a == a' && eqType b b' && c == c' +eqType (ForAll _ a b c d) (ForAll _ a' b' c' d') = a == a' && eqMaybeKind b b' && eqType c c' && d == d' eqType (ConstrainedType _ a b) (ConstrainedType _ a' b') = eqConstraint a a' && eqType b b' eqType (Skolem _ a b c) (Skolem _ a' b' c') = a == a' && b == b' && c == c' eqType (REmpty _) (REmpty _) = True @@ -590,7 +598,7 @@ compareType (TypeApp _ a b) (TypeApp _ a' b') = compareType a a' <> compareType compareType (TypeApp {}) _ = LT compareType _ (TypeApp {}) = GT -compareType (ForAll _ a b c) (ForAll _ a' b' c') = compare a a' <> compareType b b' <> compare c c' +compareType (ForAll _ a b c d) (ForAll _ a' b' c' d') = compare a a' <> compareMaybeKind b b' <> compareType c c' <> compare d d' compareType (ForAll {}) _ = LT compareType _ (ForAll {}) = GT diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 9c7bdfbc9f..aa9e55cf25 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -506,7 +506,7 @@ checkConstrained ty tyClass = P.ConstrainedType _ c ty' | matches tyClass c -> True | otherwise -> checkConstrained ty' tyClass - P.ForAll _ _ ty' _ -> + P.ForAll _ _ _ ty' _ -> checkConstrained ty' tyClass _ -> False diff --git a/tests/purs/failing/3549-a.purs b/tests/purs/failing/3549-a.purs new file mode 100644 index 0000000000..00a295dfd0 --- /dev/null +++ b/tests/purs/failing/3549-a.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith UnknownName +module Main where + +import Effect.Console (log) + +identity :: forall (a :: Typ) . a -> a +identity x = x + +main = log "Done" + diff --git a/tests/purs/failing/3549.purs b/tests/purs/failing/3549.purs new file mode 100644 index 0000000000..1088aa265c --- /dev/null +++ b/tests/purs/failing/3549.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +import Prelude + +import Effect.Console (log) + +map' :: forall (f :: Type -> Type -> Type) (a :: Type) (b :: Type) . Functor f => (a -> b) -> f a -> f b +map' = map + +main = log "Done" diff --git a/tests/purs/passing/3549.purs b/tests/purs/passing/3549.purs new file mode 100644 index 0000000000..69bdcbfb77 --- /dev/null +++ b/tests/purs/passing/3549.purs @@ -0,0 +1,13 @@ +module Main where + +import Prelude + +import Effect.Console (log) + +identity :: forall (a :: Type) . a -> a +identity x = x + +map' :: forall (f :: Type -> Type) (a :: Type) (b :: Type) . Functor f => (a -> b) -> f a -> f b +map' = map + +main = log "Done" From 3cdc98748c1b7097c3702b3289066a21fd9aa448 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sat, 20 Apr 2019 14:42:58 -0700 Subject: [PATCH 1095/1580] Fix sharing in function composition inlining (#3439) --- .../PureScript/CoreImp/Optimizer/Inliner.hs | 31 ++++++++++++++----- 1 file changed, 24 insertions(+), 7 deletions(-) diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index 96001d3ef5..4b627abd06 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -15,6 +15,7 @@ import Prelude.Compat import Control.Monad.Supply.Class (MonadSupply, freshName) +import Data.Either (rights) import Data.Maybe (fromMaybe) import Data.String (IsString, fromString) import Data.Text (Text) @@ -264,20 +265,36 @@ inlineFnComposition = everywhereTopDownM convert where convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z]) | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]] | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]] - convert (App ss (App _ (App _ fn [dict']) [x]) [y]) - | isFnCompose dict' fn = do - arg <- freshName - return $ Function ss Nothing [arg] (Block ss [Return Nothing $ App Nothing x [App Nothing y [Var Nothing arg]]]) - | isFnComposeFlipped dict' fn = do - arg <- freshName - return $ Function ss Nothing [arg] (Block ss [Return Nothing $ App Nothing y [App Nothing x [Var Nothing arg]]]) + convert app@(App ss (App _ (App _ fn [dict']) _) _) + | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName convert other = return other + + mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST + mkApps ss fns a = App ss (Function ss Nothing [] (Block ss $ vars <> [Return Nothing comp])) [] + where + vars = uncurry (VariableIntroduction ss) . fmap Just <$> rights fns + comp = Function ss Nothing [a] (Block ss [Return Nothing apps]) + apps = foldr (\fn acc -> App ss (mkApp fn) [acc]) (Var ss a) fns + + mkApp :: Either AST (Text, AST) -> AST + mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name + + goApps :: AST -> m [Either AST (Text, AST)] + goApps (App _ (App _ (App _ fn [dict']) [x]) [y]) + | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y + | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x + goApps app@(App {}) = pure . Right . (,app) <$> freshName + goApps other = pure [Left other] + isFnCompose :: AST -> AST -> Bool isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn + isFnComposeFlipped :: AST -> AST -> Bool isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn + fnCompose :: forall a b. (IsString a, IsString b) => (a, b) fnCompose = (C.controlSemigroupoid, C.compose) + fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b) fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped) From dfbd19da85c92d82ed4c3184f950f74da5332e3f Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 20 Apr 2019 22:43:42 +0100 Subject: [PATCH 1096/1580] Fail compilation when a module imports itself (#3586) Fixes #3079, fixes #3118. This is a breaking change so we should wait until after 0.12.4 is released to merge. I have used the CycleInModules error to indicate this; previously we only emitted this error for cycles containing two or more modules, but now we also emit it for singleton cycles (which occur precisely when modules import themselves). This commit also fixes a separate issue where the CycleInModules error was not printing one of the modules in a cycle (specifically, the module which happened to come first in the cycle), presumably due to accidentally using the tail rather than the whole list while constructing the error message. I've made this problem easier to avoid here by using `nonEmpty` instead of `:|` to construct the non-empty list, which means that we don't need to bind a reference to the tail at all. --- src/Language/PureScript/Errors.hs | 10 +++++++--- src/Language/PureScript/ModuleDependencies.hs | 17 +++++++++-------- tests/purs/failing/SelfImport.purs | 9 +++++++++ tests/purs/failing/SelfImport/Dummy.purs | 5 +++++ 4 files changed, 30 insertions(+), 11 deletions(-) create mode 100644 tests/purs/failing/SelfImport.purs create mode 100644 tests/purs/failing/SelfImport/Dummy.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 2521884f78..02accb831c 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -565,9 +565,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (CycleInDeclaration nm) = line $ "The value of " <> markCode (showIdent nm) <> " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = - paras [ line "There is a cycle in module dependencies in these modules: " - , indent $ paras (map (line . markCode . runModuleName) mns) - ] + case mns of + [mn] -> + line $ "Module " <> markCode (runModuleName mn) <> " imports itself." + _ -> + paras [ line "There is a cycle in module dependencies in these modules: " + , indent $ paras (map (line . markCode . runModuleName) mns) + ] renderSimpleErrorMessage (CycleInTypeSynonym name) = paras [ line $ case name of Just pn -> "A cycle appears in the definition of type synonym " <> markCode (runProperName pn) diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 1bd39e768f..f2d0669a43 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -7,12 +7,11 @@ module Language.PureScript.ModuleDependencies import Protolude hiding (head) import Data.Graph -import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.Set as S import Language.PureScript.AST import qualified Language.PureScript.Constants as C import Language.PureScript.Crash -import Language.PureScript.Errors +import Language.PureScript.Errors hiding (nonEmpty) import Language.PureScript.Names -- | A list of modules with their transitive dependencies @@ -59,9 +58,11 @@ usedModules _ = Nothing -- | Convert a strongly connected component of the module graph to a module toModule :: MonadError MultipleErrors m => SCC Module -> m Module toModule (AcyclicSCC m) = return m -toModule (CyclicSCC []) = internalError "toModule: empty CyclicSCC" -toModule (CyclicSCC [m]) = return m -toModule (CyclicSCC (m : ms)) = - throwError - . errorMessage'' (fmap getModuleSourceSpan (m :| ms)) - $ CycleInModules (map getModuleName ms) +toModule (CyclicSCC ms) = + case nonEmpty ms of + Nothing -> + internalError "toModule: empty CyclicSCC" + Just ms' -> + throwError + . errorMessage'' (fmap getModuleSourceSpan ms') + $ CycleInModules (map getModuleName ms) diff --git a/tests/purs/failing/SelfImport.purs b/tests/purs/failing/SelfImport.purs new file mode 100644 index 0000000000..0a07e3573a --- /dev/null +++ b/tests/purs/failing/SelfImport.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith CycleInModules + +module Main where + +import Main as M + +foo = 0 + +bar = M.foo diff --git a/tests/purs/failing/SelfImport/Dummy.purs b/tests/purs/failing/SelfImport/Dummy.purs new file mode 100644 index 0000000000..eb3f59a9af --- /dev/null +++ b/tests/purs/failing/SelfImport/Dummy.purs @@ -0,0 +1,5 @@ +-- This module only exists so that we perform a full build for the +-- SelfImport.purs module. If this module didn't exist, we would perform a +-- single-module fast rebuild, which doesn't perform the `sortModules` step, +-- and so the error we want to see wouldn't be emitted. +module Dummy where From 462b4f6550a19bc310f2d429c05ccfa0af081d2d Mon Sep 17 00:00:00 2001 From: Colin Wahl Date: Sat, 27 Apr 2019 03:15:02 -0700 Subject: [PATCH 1097/1580] only display class members that are not exported from the module when throwing a TransitiveExportError for a class (#3612) --- src/Language/PureScript/TypeChecker.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 4d6e098128..95bf137884 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -648,7 +648,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = checkClassMembersAreExported dr@(TypeClassRef ss' name) = do let members = ValueRef ss' `map` head (mapMaybe findClassMembers decls) let missingMembers = members \\ exps - unless (null missingMembers) . throwError . errorMessage' ss' $ TransitiveExportError dr members + unless (null missingMembers) . throwError . errorMessage' ss' $ TransitiveExportError dr missingMembers where findClassMembers :: Declaration -> Maybe [Ident] findClassMembers (TypeClassDeclaration _ name' _ _ _ ds) | name == name' = Just $ map extractMemberName ds From 812e2ccb1d0f0ba4e1cb1c19f74abdaded529000 Mon Sep 17 00:00:00 2001 From: Allen Nelson Date: Sat, 27 Apr 2019 13:07:03 -0500 Subject: [PATCH 1098/1580] Remove failable patterns and NoMonadFailDesugaring extension (#3610) * create Inferred type to avoid failable patterns * remove monadfail extension * clean up warnings * add to contributors file * respond to comments * code style tweak * no need to export internal type --- CONTRIBUTORS.md | 1 + package.yaml | 1 - src/Language/PureScript/Make.hs | 5 +- src/Language/PureScript/TypeChecker.hs | 8 +- src/Language/PureScript/TypeChecker/Kinds.hs | 8 +- src/Language/PureScript/TypeChecker/Monad.hs | 9 + src/Language/PureScript/TypeChecker/Types.hs | 229 ++++++++++--------- 7 files changed, 142 insertions(+), 119 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index eee955bb97..a48aa20373 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -131,6 +131,7 @@ If you would prefer to use different terms, please use the section below instead | [@dariooddenino](https://github.com/dariooddenino) | Dario Oddenino | [MIT license](http://opensource.org/licenses/MIT) | | [@jordanmartinez](https://github.com/jordanmartinez) | Jordan Martinez | [MIT license](http://opensource.org/licenses/MIT) | | [@Saulukass](https://github.com/Saulukass) | Saulius Skliutas | [MIT license](http://opensource.org/licenses/MIT) | +| [@adnelson](https://github.com/adnelson) | Allen Nelson | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/package.yaml b/package.yaml index 650eb88793..93d827bd50 100644 --- a/package.yaml +++ b/package.yaml @@ -111,7 +111,6 @@ library: - ScopedTypeVariables - TupleSections - ViewPatterns - - NoMonadFailDesugaring executables: purs: diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 0341ee25da..1d7c0e4e92 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -60,8 +60,9 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do withPrim = importPrim m lint withPrim ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do - [desugared] <- desugar externs [withPrim] - runCheck' (emptyCheckState env) $ typeCheckModule desugared + desugar externs [withPrim] >>= \case + [desugared] -> runCheck' (emptyCheckState env) $ typeCheckModule desugared + _ -> internalError "desugar did not return a singleton" -- desugar case declarations *after* type- and exhaustiveness checking -- since pattern guards introduces cases which the exhaustiveness checker diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 95bf137884..ecfdeb9b79 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -278,9 +278,11 @@ typeCheckAll moduleName _ = traverse go warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (positionedError ss)) . censorLocalUnnamedWildcards val $ do val' <- checkExhaustiveExpr ss env moduleName val valueIsNotDefined moduleName name - [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] - addValue moduleName name ty nameKind - return $ ValueDecl sa name nameKind [] [MkUnguarded val''] + typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] >>= \case + [(_, (val'', ty))] -> do + addValue moduleName name ty nameKind + return $ ValueDecl sa name nameKind [] [MkUnguarded val''] + _ -> internalError "typesOf did not return a singleton" where go ValueDeclaration{} = internalError "Binders were not desugared" go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared" diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 854181b81c..28a4009b52 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -218,7 +218,7 @@ infer' -> m (SourceKind, [(Text, SourceKind)]) infer' (ForAll ann ident mbK ty _) = do k1 <- maybe (freshKind ann) pure mbK - Just moduleName <- checkCurrentModule <$> get + moduleName <- unsafeCheckCurrentModule (k2, args) <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty unifyKinds k2 kindType return (kindType, (ident, k1) : args) @@ -231,7 +231,7 @@ infer' other = (, []) <$> go other go :: SourceType -> m SourceKind go (ForAll ann ident mbK ty _) = do k1 <- maybe (freshKind ann) pure mbK - Just moduleName <- checkCurrentModule <$> get + moduleName <- unsafeCheckCurrentModule k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ go ty unifyKinds k2 kindType return $ kindType $> ann @@ -243,10 +243,10 @@ infer' other = (, []) <$> go other go (TUnknown ann _) = freshKind ann go (TypeLevelString ann _) = return $ kindSymbol $> ann go (TypeVar ann v) = do - Just moduleName <- checkCurrentModule <$> get + moduleName <- unsafeCheckCurrentModule ($> ann) <$> lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) go (Skolem ann v _ _) = do - Just moduleName <- checkCurrentModule <$> get + moduleName <- unsafeCheckCurrentModule ($> ann) <$> lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) go (TypeConstructor ann v) = do env <- getEnv diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 7ec603fa7f..2933173d5b 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -18,6 +18,7 @@ import qualified Data.Map as M import Data.Text (Text) import qualified Data.List.NonEmpty as NEL +import Language.PureScript.Crash (internalError) import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Kinds @@ -323,3 +324,11 @@ withoutWarnings => m a -> m (a, w) withoutWarnings = censor (const mempty) . listen + +unsafeCheckCurrentModule + :: forall m + . (MonadError MultipleErrors m, MonadState CheckState m) + => m ModuleName +unsafeCheckCurrentModule = checkCurrentModule <$> get >>= \case + Nothing -> internalError "No module name set in scope" + Just name -> pure name diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 3b862794c0..e4491359f2 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -68,6 +68,13 @@ data BindingGroupType | NonRecursiveBindingGroup deriving (Show, Eq, Ord) +-- | The result of a successful type check. +data TypedValue' = TypedValue' Bool Expr SourceType + +-- | Convert an type checked value into an expression. +tvToExpr :: TypedValue' -> Expr +tvToExpr (TypedValue' c e t) = TypedValue c e t + -- | Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. typesOf @@ -245,8 +252,8 @@ checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do -- Check the type with the new names in scope val' <- if checkType then withScopedTypeVars mn args $ bindNames dict $ check val ty' - else return (TypedValue False val ty') - return (ident, (val', ty')) + else return (TypedValue' False val ty') + return (ident, (tvToExpr val', ty')) -- | Infer a type for a value in a binding group which lacks an annotation. typeForBindingGroupElement @@ -259,7 +266,7 @@ typeForBindingGroupElement -> m ((SourceAnn, Ident), (Expr, SourceType)) typeForBindingGroupElement (ident, (val, ty)) dict = do -- Infer the type with the new names in scope - TypedValue _ val' ty' <- bindNames dict $ infer val + TypedValue' _ val' ty' <- bindNames dict $ infer val -- Unify the type with the unification variable we chose for this definition unifyTypes ty ty' return (ident, (TypedValue True val' ty', ty')) @@ -295,7 +302,7 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty) infer :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr - -> m Expr + -> m TypedValue' infer val = withErrorMessageHint (ErrorInferringType val) $ infer' val -- | Infer a type for a value @@ -303,20 +310,20 @@ infer' :: forall m . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr - -> m Expr -infer' v@(Literal _ (NumericLiteral (Left _))) = return $ TypedValue True v tyInt -infer' v@(Literal _ (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber -infer' v@(Literal _ (StringLiteral _)) = return $ TypedValue True v tyString -infer' v@(Literal _ (CharLiteral _)) = return $ TypedValue True v tyChar -infer' v@(Literal _ (BooleanLiteral _)) = return $ TypedValue True v tyBoolean + -> m TypedValue' +infer' v@(Literal _ (NumericLiteral (Left _))) = return $ TypedValue' True v tyInt +infer' v@(Literal _ (NumericLiteral (Right _))) = return $ TypedValue' True v tyNumber +infer' v@(Literal _ (StringLiteral _)) = return $ TypedValue' True v tyString +infer' v@(Literal _ (CharLiteral _)) = return $ TypedValue' True v tyChar +infer' v@(Literal _ (BooleanLiteral _)) = return $ TypedValue' True v tyBoolean infer' (Literal ss (ArrayLiteral vals)) = do ts <- traverse infer vals els <- freshType - ts' <- forM ts $ \(TypedValue ch val t) -> do + ts' <- forM ts $ \(TypedValue' ch val t) -> do (val', t') <- instantiatePolyTypeWithUnknowns val t unifyTypes els t' return (TypedValue ch val' t') - return $ TypedValue True (Literal ss (ArrayLiteral ts')) (srcTypeApp tyArray els) + return $ TypedValue' True (Literal ss (ArrayLiteral ts')) (srcTypeApp tyArray els) infer' (Literal ss (ObjectLiteral ps)) = do ensureNoDuplicateProperties ps -- We make a special case for Vars in record labels, since these are the @@ -329,7 +336,7 @@ infer' (Literal ss (ObjectLiteral ps)) = do inferProperty :: (PSString, Expr) -> m (PSString, (Expr, SourceType)) inferProperty (name, val) = do - TypedValue _ val' ty <- infer val + TypedValue' _ val' ty <- infer val valAndType <- if shouldInstantiate val then instantiatePolyTypeWithUnknowns val' ty else pure (val', ty) @@ -339,34 +346,35 @@ infer' (Literal ss (ObjectLiteral ps)) = do fields <- forM ps inferProperty let ty = srcTypeApp tyRecord $ rowFromList (map toRowListItem fields, srcREmpty) - return $ TypedValue True (Literal ss (ObjectLiteral (map (fmap (uncurry (TypedValue True))) fields))) ty + return $ TypedValue' True (Literal ss (ObjectLiteral (map (fmap (uncurry (TypedValue True))) fields))) ty infer' (ObjectUpdate o ps) = do ensureNoDuplicateProperties ps row <- freshType - newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps + typedVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps let toRowListItem = uncurry srcRowListItem - let newTys = map (\(name, TypedValue _ _ ty) -> (Label name, ty)) newVals + let newTys = map (\(name, TypedValue' _ _ ty) -> (Label name, ty)) typedVals oldTys <- zip (map (Label . fst) ps) <$> replicateM (length ps) freshType let oldTy = srcTypeApp tyRecord $ rowFromList (toRowListItem <$> oldTys, row) - o' <- TypedValue True <$> check o oldTy <*> pure oldTy - return $ TypedValue True (ObjectUpdate o' newVals) $ srcTypeApp tyRecord $ rowFromList (toRowListItem <$> newTys, row) + o' <- TypedValue True <$> (tvToExpr <$> check o oldTy) <*> pure oldTy + let newVals = map (fmap tvToExpr) typedVals + return $ TypedValue' True (ObjectUpdate o' newVals) $ srcTypeApp tyRecord $ rowFromList (toRowListItem <$> newTys, row) infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do field <- freshType rest <- freshType - typed <- check val (srcTypeApp tyRecord (srcRCons (Label prop) field rest)) - return $ TypedValue True (Accessor prop typed) field + typed <- tvToExpr <$> check val (srcTypeApp tyRecord (srcRCons (Label prop) field rest)) + return $ TypedValue' True (Accessor prop typed) field infer' (Abs binder ret) | VarBinder ss arg <- binder = do ty <- freshType withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do - body@(TypedValue _ _ bodyTy) <- infer' ret - (body', bodyTy') <- instantiatePolyTypeWithUnknowns body bodyTy - return $ TypedValue True (Abs (VarBinder ss arg) body') (function ty bodyTy') + body@(TypedValue' _ _ bodyTy) <- infer' ret + (body', bodyTy') <- instantiatePolyTypeWithUnknowns (tvToExpr body) bodyTy + return $ TypedValue' True (Abs (VarBinder ss arg) body') (function ty bodyTy') | otherwise = internalError "Binder was not desugared" infer' (App f arg) = do - f'@(TypedValue _ _ ft) <- infer f - (ret, app) <- checkFunctionApplication f' ft arg - return $ TypedValue True app ret + f'@(TypedValue' _ _ ft) <- infer f + (ret, app) <- checkFunctionApplication (tvToExpr f') ft arg + return $ TypedValue' True app ret infer' (Var ss var) = do checkVisibility var ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable $ var @@ -374,52 +382,52 @@ infer' (Var ss var) = do ConstrainedType _ con ty' -> do dicts <- getTypeClassDictionaries hints <- getHints - return $ TypedValue True (App (Var ss var) (TypeClassDictionary con dicts hints)) ty' - _ -> return $ TypedValue True (Var ss var) ty + return $ TypedValue' True (App (Var ss var) (TypeClassDictionary con dicts hints)) ty' + _ -> return $ TypedValue' True (Var ss var) ty infer' v@(Constructor _ c) = do env <- getEnv case M.lookup c (dataConstructors env) of Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty - return $ TypedValue True v' ty' + return $ TypedValue' True v' ty' infer' (Case vals binders) = do (vals', ts) <- instantiateForBinders vals binders ret <- freshType binders' <- checkBinders ts ret binders - return $ TypedValue True (Case vals' binders') ret + return $ TypedValue' True (Case vals' binders') ret infer' (IfThenElse cond th el) = do - cond' <- check cond tyBoolean - th'@(TypedValue _ _ thTy) <- infer th - el'@(TypedValue _ _ elTy) <- infer el - (th'', thTy') <- instantiatePolyTypeWithUnknowns th' thTy - (el'', elTy') <- instantiatePolyTypeWithUnknowns el' elTy + cond' <- tvToExpr <$> check cond tyBoolean + th'@(TypedValue' _ _ thTy) <- infer th + el'@(TypedValue' _ _ elTy) <- infer el + (th'', thTy') <- instantiatePolyTypeWithUnknowns (tvToExpr th') thTy + (el'', elTy') <- instantiatePolyTypeWithUnknowns (tvToExpr el') elTy unifyTypes thTy' elTy' - return $ TypedValue True (IfThenElse cond' th'' el'') thTy' + return $ TypedValue' True (IfThenElse cond' th'' el'') thTy' infer' (Let w ds val) = do - (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer - return $ TypedValue True (Let w ds' val') valTy + (ds', tv@(TypedValue' _ _ valTy)) <- inferLetBinding [] ds val infer + return $ TypedValue' True (Let w ds' (tvToExpr tv)) valTy infer' (DeferredDictionary className tys) = do dicts <- getTypeClassDictionaries hints <- getHints - return $ TypedValue False + return $ TypedValue' False (TypeClassDictionary (srcConstraint className tys Nothing) dicts hints) (foldl srcTypeApp (srcTypeConstructor (fmap coerceProperName className)) tys) infer' (TypedValue checkType val ty) = do - Just moduleName <- checkCurrentModule <$> get + moduleName <- unsafeCheckCurrentModule (kind, args) <- kindOfWithScopedVars ty checkTypeKind ty kind ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty - val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val - return $ TypedValue True val' ty' + tv <- if checkType then withScopedTypeVars moduleName args (check val ty') else return (TypedValue' False val ty) + return $ TypedValue' True (tvToExpr tv) ty' infer' (Hole name) = do ty <- freshType ctx <- getLocalContext env <- getEnv tell . errorMessage $ HoleInferredType name ty ctx . Just $ TSBefore env - return $ TypedValue True (Hole name) ty + return $ TypedValue' True (Hole name) ty infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do - TypedValue t v ty <- infer' val - return $ TypedValue t (PositionedValue pos c v) ty + TypedValue' t v ty <- infer' val + return $ TypedValue' t (PositionedValue pos c v) ty infer' v = internalError $ "Invalid argument to infer: " ++ show v inferLetBinding @@ -427,29 +435,31 @@ inferLetBinding => [Declaration] -> [Declaration] -> Expr - -> (Expr -> m Expr) - -> m ([Declaration], Expr) + -> (Expr -> m TypedValue') + -> m ([Declaration], TypedValue') inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) -inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)] : rest) ret j = do - Just moduleName <- checkCurrentModule <$> get - TypedValue _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do +inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (TypedValue checkType val ty)] : rest) ret j = do + moduleName <- unsafeCheckCurrentModule + TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do (kind, args) <- kindOfWithScopedVars ty checkTypeKind ty kind let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined) ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty - if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv + if checkType + then withScopedTypeVars moduleName args (bindNames dict (check val ty')) + else return (TypedValue' checkType val ty) bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = do valTy <- freshType - TypedValue _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do + TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined) bindNames dict $ infer val warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do - Just moduleName <- checkCurrentModule <$> get + moduleName <- unsafeCheckCurrentModule SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict @@ -547,7 +557,7 @@ instantiateForBinders -> [CaseAlternative] -> m ([Expr], [SourceType]) instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do - TypedValue _ val' ty <- infer val + TypedValue' _ val' ty <- infer val if inst then instantiatePolyTypeWithUnknowns val' ty else return (val', ty)) vals shouldInstantiate @@ -580,20 +590,20 @@ checkGuardedRhs -> SourceType -> m GuardedExpr checkGuardedRhs (GuardedExpr [] rhs) ret = do - rhs' <- TypedValue True <$> check rhs ret <*> pure ret + rhs' <- TypedValue True <$> (tvToExpr <$> check rhs ret) <*> pure ret return $ GuardedExpr [] rhs' checkGuardedRhs (GuardedExpr (ConditionGuard cond : guards) rhs) ret = do cond' <- withErrorMessageHint ErrorCheckingGuard $ check cond tyBoolean GuardedExpr guards' rhs' <- checkGuardedRhs (GuardedExpr guards rhs) ret - return $ GuardedExpr (ConditionGuard cond' : guards') rhs' + return $ GuardedExpr (ConditionGuard (tvToExpr cond') : guards') rhs' checkGuardedRhs (GuardedExpr (PatternGuard binder expr : guards) rhs) ret = do - expr'@(TypedValue _ _ ty) <- infer expr + tv@(TypedValue' _ _ ty) <- infer expr variables <- inferBinder ty binder GuardedExpr guards' rhs' <- bindLocalVariables [ (name, bty, Defined) | (name, bty) <- M.toList variables ] $ checkGuardedRhs (GuardedExpr guards rhs) ret - return $ GuardedExpr (PatternGuard binder expr' : guards') rhs' + return $ GuardedExpr (PatternGuard binder (tvToExpr tv) : guards') rhs' -- | -- Check the type of a value, rethrowing errors to provide a better error message @@ -602,7 +612,7 @@ check :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> SourceType - -> m Expr + -> m TypedValue' check val ty = withErrorMessageHint (ErrorCheckingType val ty) $ check' val ty -- | @@ -613,7 +623,7 @@ check' . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Expr -> SourceType - -> m Expr + -> m TypedValue' check' val (ForAll ann ident mbK ty _) = do scope <- newSkolemScope sko <- newSkolemConstant @@ -622,50 +632,50 @@ check' val (ForAll ann ident mbK ty _) = do _ -> NullSourceAnn sk = skolemize ss ident sko scope ty skVal = skolemizeTypesInValue ss ident sko scope val - val' <- check skVal sk - return $ TypedValue True val' (ForAll ann ident mbK ty (Just scope)) + val' <- tvToExpr <$> check skVal sk + return $ TypedValue' True val' (ForAll ann ident mbK ty (Just scope)) check' val t@(ConstrainedType _ con@(Constraint _ (Qualified _ (ProperName className)) _ _) ty) = do dictName <- freshIdent ("dict" <> className) dicts <- newDictionaries [] (Qualified Nothing dictName) con val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty - return $ TypedValue True (Abs (VarBinder nullSourceSpan dictName) val') t + return $ TypedValue' True (Abs (VarBinder nullSourceSpan dictName) (tvToExpr val')) t check' val u@(TUnknown _ _) = do - val'@(TypedValue _ _ ty) <- infer val + val'@(TypedValue' _ _ ty) <- infer val -- Don't unify an unknown with an inferred polytype - (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty + (val'', ty') <- instantiatePolyTypeWithUnknowns (tvToExpr val') ty unifyTypes ty' u - return $ TypedValue True val'' ty' + return $ TypedValue' True val'' ty' check' v@(Literal _ (NumericLiteral (Left _))) t | t == tyInt = - return $ TypedValue True v t + return $ TypedValue' True v t check' v@(Literal _ (NumericLiteral (Right _))) t | t == tyNumber = - return $ TypedValue True v t + return $ TypedValue' True v t check' v@(Literal _ (StringLiteral _)) t | t == tyString = - return $ TypedValue True v t + return $ TypedValue' True v t check' v@(Literal _ (CharLiteral _)) t | t == tyChar = - return $ TypedValue True v t + return $ TypedValue' True v t check' v@(Literal _ (BooleanLiteral _)) t | t == tyBoolean = - return $ TypedValue True v t + return $ TypedValue' True v t check' (Literal ss (ArrayLiteral vals)) t@(TypeApp _ a ty) = do unifyTypes a tyArray - array <- Literal ss . ArrayLiteral <$> forM vals (`check` ty) - return $ TypedValue True array t + array <- Literal ss . ArrayLiteral . map tvToExpr <$> forM vals (`check` ty) + return $ TypedValue' True array t check' (Abs binder ret) ty@(TypeApp _ (TypeApp _ t argTy) retTy) | VarBinder ss arg <- binder = do unifyTypes t tyFunction ret' <- withBindingGroupVisible $ bindLocalVariables [(arg, argTy, Defined)] $ check ret retTy - return $ TypedValue True (Abs (VarBinder ss arg) ret') ty + return $ TypedValue' True (Abs (VarBinder ss arg) (tvToExpr ret')) ty | otherwise = internalError "Binder was not desugared" check' (App f arg) ret = do - f'@(TypedValue _ _ ft) <- infer f - (retTy, app) <- checkFunctionApplication f' ft arg + f'@(TypedValue' _ _ ft) <- infer f + (retTy, app) <- checkFunctionApplication (tvToExpr f') ft arg elaborate <- subsumes retTy ret - return $ TypedValue True (elaborate app) ret + return $ TypedValue' True (elaborate app) ret check' v@(Var _ var) ty = do checkVisibility var repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty elaborate <- subsumes repl ty' - return $ TypedValue True (elaborate v) ty' + return $ TypedValue' True (elaborate v) ty' check' (DeferredDictionary className tys) ty = do {- -- Here, we replace a placeholder for a superclass dictionary with a regular @@ -675,7 +685,7 @@ check' (DeferredDictionary className tys) ty = do -} dicts <- getTypeClassDictionaries hints <- getHints - return $ TypedValue False + return $ TypedValue' False (TypeClassDictionary (srcConstraint className tys Nothing) dicts hints) ty check' (TypedValue checkType val ty1) ty2 = do @@ -685,25 +695,25 @@ check' (TypedValue checkType val ty1) ty2 = do ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2 elaborate <- subsumes ty1' ty2' val' <- if checkType - then check val ty1' + then tvToExpr <$> check val ty1' else pure val - return $ TypedValue True (TypedValue checkType (elaborate val') ty1') ty2' + return $ TypedValue' True (TypedValue checkType (elaborate val') ty1') ty2' check' (Case vals binders) ret = do (vals', ts) <- instantiateForBinders vals binders binders' <- checkBinders ts ret binders - return $ TypedValue True (Case vals' binders') ret + return $ TypedValue' True (Case vals' binders') ret check' (IfThenElse cond th el) ty = do - cond' <- check cond tyBoolean - th' <- check th ty - el' <- check el ty - return $ TypedValue True (IfThenElse cond' th' el') ty + cond' <- tvToExpr <$> check cond tyBoolean + th' <- tvToExpr <$> check th ty + el' <- tvToExpr <$> check el ty + return $ TypedValue' True (IfThenElse cond' th' el') ty check' e@(Literal ss (ObjectLiteral ps)) t@(TypeApp _ obj row) | obj == tyRecord = do ensureNoDuplicateProperties ps ps' <- checkProperties e ps row False - return $ TypedValue True (Literal ss (ObjectLiteral ps')) t + return $ TypedValue' True (Literal ss (ObjectLiteral ps')) t check' (TypeClassDictionaryConstructorApp name ps) t = do - ps' <- check' ps t - return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t + ps' <- tvToExpr <$> check' ps t + return $ TypedValue' True (TypeClassDictionaryConstructorApp name ps') t check' e@(ObjectUpdate obj ps) t@(TypeApp _ o row) | o == tyRecord = do ensureNoDuplicateProperties ps -- We need to be careful to avoid duplicate labels here. @@ -711,13 +721,13 @@ check' e@(ObjectUpdate obj ps) t@(TypeApp _ o row) | o == tyRecord = do let (propsToCheck, rest) = rowToList row (removedProps, remainingProps) = partition (\(RowListItem _ p _) -> p `elem` map (Label . fst) ps) propsToCheck us <- zipWith srcRowListItem (map rowListLabel removedProps) <$> replicateM (length ps) freshType - obj' <- check obj (srcTypeApp tyRecord (rowFromList (us ++ remainingProps, rest))) + obj' <- tvToExpr <$> check obj (srcTypeApp tyRecord (rowFromList (us ++ remainingProps, rest))) ps' <- checkProperties e ps row True - return $ TypedValue True (ObjectUpdate obj' ps') t + return $ TypedValue' True (ObjectUpdate obj' ps') t check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do rest <- freshType - val' <- check val (srcTypeApp tyRecord (srcRCons (Label prop) ty rest)) - return $ TypedValue True (Accessor prop val') ty + val' <- tvToExpr <$> check val (srcTypeApp tyRecord (srcRCons (Label prop) ty rest)) + return $ TypedValue' True (Accessor prop val') ty check' v@(Constructor _ c) ty = do env <- getEnv case M.lookup c (dataConstructors env) of @@ -726,21 +736,21 @@ check' v@(Constructor _ c) ty = do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 ty' <- introduceSkolemScope ty elaborate <- subsumes repl ty' - return $ TypedValue True (elaborate v) ty' + return $ TypedValue' True (elaborate v) ty' check' (Let w ds val) ty = do (ds', val') <- inferLetBinding [] ds val (`check` ty) - return $ TypedValue True (Let w ds' val') ty + return $ TypedValue' True (Let w ds' (tvToExpr val')) ty check' val kt@(KindedType _ ty kind) = do checkTypeKind ty kind - val' <- check' val ty - return $ TypedValue True val' kt + val' <- tvToExpr <$> check' val ty + return $ TypedValue' True val' kt check' (PositionedValue pos c val) ty = warnAndRethrowWithPositionTC pos $ do - TypedValue t v ty' <- check' val ty - return $ TypedValue t (PositionedValue pos c v) ty' + TypedValue' t v ty' <- check' val ty + return $ TypedValue' t (PositionedValue pos c v) ty' check' val ty = do - TypedValue _ val' ty' <- infer val + TypedValue' _ val' ty' <- infer val elaborate <- subsumes ty' ty - return $ TypedValue True (elaborate val') ty + return $ TypedValue' True (elaborate val') ty -- | -- Check the type of a collection of named record fields @@ -754,7 +764,9 @@ checkProperties -> SourceType -> Bool -> m [(PSString, Expr)] -checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps (toRowPair <$> ts) r' where +checkProperties expr ps row lax = convert <$> go ps (toRowPair <$> ts') r' where + convert = fmap (fmap tvToExpr) + (ts', r') = rowToList row toRowPair (RowListItem _ lbl ty) = (lbl, ty) go [] [] (REmpty _) = return [] go [] [] u@(TUnknown _ _) @@ -768,7 +780,7 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps (toRowPa go ((p,v):ps') ts r = case lookup (Label p) ts of Nothing -> do - v'@(TypedValue _ _ ty) <- infer v + v'@(TypedValue' _ _ ty) <- infer v rest <- freshType unifyTypes r (srcRCons (Label p) ty rest) ps'' <- go ps' ts rest @@ -815,7 +827,7 @@ checkFunctionApplication' -> m (SourceType, Expr) checkFunctionApplication' fn (TypeApp _ (TypeApp _ tyFunction' argTy) retTy) arg = do unifyTypes tyFunction' tyFunction - arg' <- check arg argTy + arg' <- tvToExpr <$> check arg argTy return (retTy, App fn arg') checkFunctionApplication' fn (ForAll _ ident _ ty _) arg = do replaced <- replaceVarWithUnknown ident ty @@ -829,14 +841,13 @@ checkFunctionApplication' fn (ConstrainedType _ con fnTy) arg = do checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} = return (fnTy, App fn dict) checkFunctionApplication' fn u arg = do - arg' <- do - TypedValue _ arg' t <- infer arg + tv@(TypedValue' _ _ ty) <- do + TypedValue' _ arg' t <- infer arg (arg'', t') <- instantiatePolyTypeWithUnknowns arg' t - return $ TypedValue True arg'' t' - let ty = (\(TypedValue _ _ t) -> t) arg' + return $ TypedValue' True arg'' t' ret <- freshType unifyTypes u (function ty ret) - return (ret, App fn arg') + return (ret, App fn (tvToExpr tv)) -- | -- Ensure a set of property names and value does not contain duplicate labels From f5c722730b38ec8fa2db527e0722ac73cd9a430a Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Mon, 29 Apr 2019 23:07:02 +0100 Subject: [PATCH 1099/1580] Tweaks to type pretty printing (#3616) * Tweaks to type pretty printing * Add comment and restore depth reduction on constraint type --- src/Language/PureScript/Pretty/Types.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 46cf552e87..aabd707b12 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -62,7 +62,6 @@ type PrettyPrintConstraint = (Qualified (ProperName 'ClassName), [PrettyPrintTyp convertPrettyPrintType :: Int -> Type a -> PrettyPrintType convertPrettyPrintType = go where - go d _ | d < 0 = PPTruncated go _ (TUnknown _ n) = PPTUnknown n go _ (TypeVar _ t) = PPTypeVar t go _ (TypeLevelString _ s) = PPTypeLevelString s @@ -70,11 +69,15 @@ convertPrettyPrintType = go go _ (TypeConstructor _ c) = PPTypeConstructor c go _ (TypeOp _ o) = PPTypeOp o go _ (Skolem _ t n _) = PPSkolem t n - go d (ConstrainedType _ (Constraint _ cls args _) ty) = PPConstrainedType (cls, go (d-1) <$> args) (go (d-1) ty) + go _ (REmpty _) = PPRow [] Nothing + -- Guard the remaining "complex" type atoms on the current depth value. The + -- prior constructors can all be printed simply so it's not really helpful to + -- truncate them. + go d _ | d < 0 = PPTruncated + go d (ConstrainedType _ (Constraint _ cls args _) ty) = PPConstrainedType (cls, go (d-1) <$> args) (go d ty) go d (KindedType _ ty k) = PPKindedType (go (d-1) ty) (k $> ()) go d (BinaryNoParensType _ ty1 ty2 ty3) = PPBinaryNoParensType (go (d-1) ty1) (go (d-1) ty2) (go (d-1) ty3) go d (ParensInType _ ty) = PPParensInType (go (d-1) ty) - go _ (REmpty _) = PPRow [] Nothing go d ty@RCons{} = uncurry PPRow (goRow d ty) go d (ForAll _ v mbK ty _) = goForAll d [(v, fmap ($> ()) mbK)] ty go d (TypeApp _ a b) = goTypeApp d a b From 317dce29b9df25e1bcddf9fb046db72d98b666a2 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sun, 5 May 2019 08:36:25 -0700 Subject: [PATCH 1100/1580] Integrate purescript-cst (#3608) * Import purescript-cst * Use cst parse in compile command * Get purs compile to use new parser * Remove old module parsers * Fix some failing tests * Fix more test failures * Use PSString for CST literals and labels * Add cst tests * Move module unwrapping under buildModule to prevent an unreported error * Add more tests * Add module comments * Remove TODO which is no longer relevant --- app/Command/Compile.hs | 5 +- app/Command/Hierarchy.hs | 3 +- app/Command/REPL.hs | 5 +- package.yaml | 5 + src/Language/PureScript/AST/Declarations.hs | 2 + src/Language/PureScript/CST.hs | 89 +++ src/Language/PureScript/CST/Convert.hs | 630 +++++++++++++++ src/Language/PureScript/CST/Errors.hs | 154 ++++ src/Language/PureScript/CST/Layout.hs | 388 +++++++++ src/Language/PureScript/CST/Lexer.hs | 679 ++++++++++++++++ src/Language/PureScript/CST/Monad.hs | 123 +++ src/Language/PureScript/CST/Parser.y | 746 ++++++++++++++++++ src/Language/PureScript/CST/Positions.hs | 352 +++++++++ src/Language/PureScript/CST/Print.hs | 82 ++ src/Language/PureScript/CST/Traversals.hs | 11 + .../PureScript/CST/Traversals/Type.hs | 39 + src/Language/PureScript/CST/Types.hs | 437 ++++++++++ src/Language/PureScript/CST/Utils.hs | 306 +++++++ src/Language/PureScript/Docs/Convert.hs | 2 +- .../PureScript/Docs/ParseInPackage.hs | 3 +- src/Language/PureScript/Errors.hs | 8 +- src/Language/PureScript/Ide/Rebuild.hs | 12 +- src/Language/PureScript/Ide/SourceFile.hs | 5 +- src/Language/PureScript/Interactive.hs | 7 +- src/Language/PureScript/Interactive/Module.hs | 9 +- src/Language/PureScript/Make.hs | 32 +- src/Language/PureScript/Make/BuildPlan.hs | 11 +- src/Language/PureScript/ModuleDependencies.hs | 43 +- .../PureScript/Parser/Declarations.hs | 45 +- tests/Language/PureScript/Ide/UsageSpec.hs | 6 +- tests/Main.hs | 5 +- tests/TestCst.hs | 223 ++++++ tests/TestPsci/TestEnv.hs | 3 +- tests/TestUtils.hs | 11 +- tests/purs/failing/2616.purs | 2 +- tests/purs/failing/ImportHidingModule.purs | 2 +- tests/purs/failing/NewtypeMultiArgs.purs | 2 +- tests/purs/failing/NewtypeMultiCtor.purs | 2 +- tests/purs/failing/NonExhaustivePatGuard.purs | 2 +- tests/purs/failing/OperatorAt.purs | 8 + tests/purs/failing/OperatorBackslash.purs | 8 + tests/purs/failing/PrimRow.purs | 2 - tests/purs/failing/TypeClasses2.purs | 2 - tests/purs/failing/Whitespace1.purs | 5 + tests/purs/layout/AdoIn.out | 9 + tests/purs/layout/AdoIn.purs | 8 + tests/purs/layout/CaseGuards.out | 54 ++ tests/purs/layout/CaseGuards.purs | 53 ++ tests/purs/layout/CaseWhere.out | 13 + tests/purs/layout/CaseWhere.purs | 12 + tests/purs/layout/ClassHead.out | 11 + tests/purs/layout/ClassHead.purs | 10 + tests/purs/layout/Commas.out | 23 + tests/purs/layout/Commas.purs | 22 + tests/purs/layout/Delimiter.out | 14 + tests/purs/layout/Delimiter.purs | 13 + tests/purs/layout/DoOperator.out | 9 + tests/purs/layout/DoOperator.purs | 8 + tests/purs/layout/DoWhere.out | 7 + tests/purs/layout/DoWhere.purs | 6 + tests/purs/layout/IfThenElseDo.out | 11 + tests/purs/layout/IfThenElseDo.purs | 10 + tests/purs/layout/InstanceChainElse.out | 5 + tests/purs/layout/InstanceChainElse.purs | 4 + tests/purs/passing/1110.purs | 2 +- tests/purs/passing/2252.purs | 4 +- .../purs/passing/ConstraintOutsideForall.purs | 12 + tests/purs/passing/DeepCase.purs | 2 +- .../passing/DeriveWithNestedSynonyms.purs | 2 +- tests/purs/passing/DerivingFunctor.purs | 2 +- tests/purs/passing/GenericsRep.purs | 2 +- tests/purs/passing/Import/M1.purs | 2 - tests/purs/passing/Import/M2.purs | 1 - tests/purs/passing/KindedType.purs | 7 + tests/purs/passing/Monad.purs | 6 +- tests/purs/passing/Rank2Data.purs | 4 +- tests/purs/passing/RedefinedFixity/M2.purs | 2 - tests/purs/passing/RedefinedFixity/M3.purs | 2 - tests/purs/passing/StringEscapes.purs | 6 +- .../warning/ShadowedBinderPatternGuard.purs | 4 +- tests/purs/warning/UnusedImport.purs | 2 - 81 files changed, 4734 insertions(+), 146 deletions(-) create mode 100644 src/Language/PureScript/CST.hs create mode 100644 src/Language/PureScript/CST/Convert.hs create mode 100644 src/Language/PureScript/CST/Errors.hs create mode 100644 src/Language/PureScript/CST/Layout.hs create mode 100644 src/Language/PureScript/CST/Lexer.hs create mode 100644 src/Language/PureScript/CST/Monad.hs create mode 100644 src/Language/PureScript/CST/Parser.y create mode 100644 src/Language/PureScript/CST/Positions.hs create mode 100644 src/Language/PureScript/CST/Print.hs create mode 100644 src/Language/PureScript/CST/Traversals.hs create mode 100644 src/Language/PureScript/CST/Traversals/Type.hs create mode 100644 src/Language/PureScript/CST/Types.hs create mode 100644 src/Language/PureScript/CST/Utils.hs create mode 100644 tests/TestCst.hs create mode 100644 tests/purs/failing/OperatorAt.purs create mode 100644 tests/purs/failing/OperatorBackslash.purs create mode 100644 tests/purs/failing/Whitespace1.purs create mode 100644 tests/purs/layout/AdoIn.out create mode 100644 tests/purs/layout/AdoIn.purs create mode 100644 tests/purs/layout/CaseGuards.out create mode 100644 tests/purs/layout/CaseGuards.purs create mode 100644 tests/purs/layout/CaseWhere.out create mode 100644 tests/purs/layout/CaseWhere.purs create mode 100644 tests/purs/layout/ClassHead.out create mode 100644 tests/purs/layout/ClassHead.purs create mode 100644 tests/purs/layout/Commas.out create mode 100644 tests/purs/layout/Commas.purs create mode 100644 tests/purs/layout/Delimiter.out create mode 100644 tests/purs/layout/Delimiter.purs create mode 100644 tests/purs/layout/DoOperator.out create mode 100644 tests/purs/layout/DoOperator.purs create mode 100644 tests/purs/layout/DoWhere.out create mode 100644 tests/purs/layout/DoWhere.purs create mode 100644 tests/purs/layout/IfThenElseDo.out create mode 100644 tests/purs/layout/IfThenElseDo.purs create mode 100644 tests/purs/layout/InstanceChainElse.out create mode 100644 tests/purs/layout/InstanceChainElse.purs create mode 100644 tests/purs/passing/ConstraintOutsideForall.purs diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 555fc5b51c..461985f6b1 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -18,6 +18,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Traversable (for) import qualified Language.PureScript as P +import qualified Language.PureScript.CST as CST import Language.PureScript.Errors.JSON import Language.PureScript.Make import qualified Options.Applicative as Opts @@ -65,8 +66,8 @@ compile PSCMakeOptions{..} = do exitFailure moduleFiles <- readInput input (makeErrors, makeWarnings) <- runMake pscmOpts $ do - ms <- P.parseModulesFromFiles id moduleFiles - let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, Right fp)) ms + ms <- CST.parseModulesFromFiles id moduleFiles + let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms foreigns <- inferForeignModules filePathMap let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix P.make makeActions (map snd ms) diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs index 0966c9a7b6..9e0b26e9fc 100644 --- a/app/Command/Hierarchy.hs +++ b/app/Command/Hierarchy.hs @@ -33,6 +33,7 @@ import System.Exit (exitFailure, exitSuccess) import System.IO (hPutStr, stderr) import System.IO.UTF8 (readUTF8FileT) import qualified Language.PureScript as P +import qualified Language.PureScript.CST as CST import Language.PureScript.Hierarchy (Graph(..), _unDigraph, _unGraphName, typeClasses) data HierarchyOptions = HierarchyOptions @@ -43,7 +44,7 @@ data HierarchyOptions = HierarchyOptions readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module]) readInput paths = do content <- mapM (\path -> (path, ) <$> readUTF8FileT path) paths - return $ map snd <$> P.parseModulesFromFiles id content + return $ map snd <$> CST.parseFromFiles id content compile :: HierarchyOptions -> IO () compile (HierarchyOptions inputGlob mOutput) = do diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index df9a66e12d..f44c1e8abe 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -36,6 +36,7 @@ import Data.Text (Text, unpack) import Data.Traversable (for) import qualified Language.PureScript as P import qualified Language.PureScript.Bundle as Bundle +import qualified Language.PureScript.CST as CST import Language.PureScript.Interactive import Network.HTTP.Types.Header (hContentType, hCacheControl, hPragma, hExpires) @@ -315,10 +316,10 @@ command = loop <$> options when (null modules) . liftIO $ do putStr noInputMessage exitFailure - unless (supportModuleIsDefined (map snd modules)) . liftIO $ do + unless (supportModuleIsDefined (map (P.getModuleName . snd) modules)) . liftIO $ do putStr supportModuleMessage exitFailure - (externs, _) <- ExceptT . runMake . make $ modules + (externs, _) <- ExceptT . runMake . make $ fmap CST.pureResult <$> modules return (modules, externs) case psciBackend of Backend setup eval reload (shutdown :: state -> IO ()) -> diff --git a/package.yaml b/package.yaml index 93d827bd50..7e62bb0f01 100644 --- a/package.yaml +++ b/package.yaml @@ -97,6 +97,9 @@ library: - ConstraintKinds - DataKinds - DeriveFunctor + - DeriveFoldable + - DeriveTraversable + - DeriveGeneric - EmptyDataDecls - FlexibleContexts - KindSignatures @@ -156,7 +159,9 @@ tests: dependencies: - purescript - tasty + - tasty-golden - tasty-hspec + - tasty-quickcheck - hspec - hspec-discover - HUnit diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index ea2feccddd..4de31e2565 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -35,6 +35,7 @@ import Language.PureScript.Comments import Language.PureScript.Environment import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.CST.Errors as CST import qualified Text.Parsec as P @@ -68,6 +69,7 @@ data SimpleErrorMessage = ModuleNotFound ModuleName | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) | ErrorParsingModule P.ParseError + | ErrorParsingCSTModule CST.ParserError | MissingFFIModule ModuleName | UnnecessaryFFIModule ModuleName FilePath | MissingFFIImplementations ModuleName [Ident] diff --git a/src/Language/PureScript/CST.hs b/src/Language/PureScript/CST.hs new file mode 100644 index 0000000000..5d1712ee57 --- /dev/null +++ b/src/Language/PureScript/CST.hs @@ -0,0 +1,89 @@ +module Language.PureScript.CST + ( parseFromFile + , parseFromFiles + , parseModuleFromFile + , parseModulesFromFiles + , unwrapParserError + , toMultipleErrors + , toPositionedError + , pureResult + , module Language.PureScript.CST.Convert + , module Language.PureScript.CST.Errors + , module Language.PureScript.CST.Parser + , module Language.PureScript.CST.Types + ) where + +import Prelude + +import Control.Monad.Error.Class (MonadError(..)) +import Control.Parallel.Strategies (withStrategy, parList, evalTuple2, r0, rseq) +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import qualified Language.PureScript.AST as AST +import qualified Language.PureScript.Errors as E +import Language.PureScript.CST.Convert +import Language.PureScript.CST.Errors +import Language.PureScript.CST.Parser +import Language.PureScript.CST.Types + +pureResult :: a -> PartialResult a +pureResult a = PartialResult a (pure a) + +parseModulesFromFiles + :: forall m k + . MonadError E.MultipleErrors m + => (k -> FilePath) + -> [(k, Text)] + -> m [(k, PartialResult AST.Module)] +parseModulesFromFiles toFilePath input = + flip E.parU (handleParserError toFilePath) + . inParallel + . flip fmap input + $ \(k, a) -> (k, parseModuleFromFile (toFilePath k) a) + +parseFromFiles + :: forall m k + . MonadError E.MultipleErrors m + => (k -> FilePath) + -> [(k, Text)] + -> m [(k, AST.Module)] +parseFromFiles toFilePath input = + flip E.parU (handleParserError toFilePath) + . inParallel + . flip fmap input + $ \(k, a) -> (k, parseFromFile (toFilePath k) a) + +parseModuleFromFile :: FilePath -> Text -> Either (NE.NonEmpty ParserError) (PartialResult AST.Module) +parseModuleFromFile fp content = fmap (convertModule fp) <$> parseModule content + +parseFromFile :: FilePath -> Text -> Either (NE.NonEmpty ParserError) AST.Module +parseFromFile fp content = convertModule fp <$> parse content + +handleParserError + :: forall m k a + . MonadError E.MultipleErrors m + => (k -> FilePath) + -> (k, Either (NE.NonEmpty ParserError) a) + -> m (k, a) +handleParserError toFilePath (k, res) = + (k,) <$> unwrapParserError (toFilePath k) res + +unwrapParserError + :: forall m a + . MonadError E.MultipleErrors m + => FilePath + -> Either (NE.NonEmpty ParserError) a + -> m a +unwrapParserError fp = + either (throwError . toMultipleErrors fp) pure + +toMultipleErrors :: FilePath -> NE.NonEmpty ParserError -> E.MultipleErrors +toMultipleErrors fp = + E.MultipleErrors . NE.toList . fmap (toPositionedError fp) + +toPositionedError :: FilePath -> ParserError -> E.ErrorMessage +toPositionedError name perr = + E.ErrorMessage [E.positionedError $ sourceSpan name $ errRange perr] (E.ErrorParsingCSTModule perr) + +inParallel :: [(k, Either (NE.NonEmpty ParserError) a)] -> [(k, Either (NE.NonEmpty ParserError) a)] +inParallel = withStrategy (parList (evalTuple2 r0 rseq)) diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs new file mode 100644 index 0000000000..ee13244881 --- /dev/null +++ b/src/Language/PureScript/CST/Convert.hs @@ -0,0 +1,630 @@ +-- | This module contains functions for converting the CST into the core AST. It +-- is mostly boilerplate, and does the job of resolving ranges for all the nodes +-- and attaching comments. + +module Language.PureScript.CST.Convert + ( convertKind + , convertType + , convertExpr + , convertBinder + , convertDeclaration + , convertModule + , sourcePos + , sourceSpan + , comment + , comments + ) where + +import Prelude + +import Data.Bifunctor (bimap, first) +import Data.Foldable (foldl', toList) +import Data.Functor (($>)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (isJust, fromJust, mapMaybe) +import qualified Data.Text as Text +import qualified Language.PureScript.AST as AST +import qualified Language.PureScript.AST.SourcePos as Pos +import qualified Language.PureScript.Comments as C +import qualified Language.PureScript.Environment as Env +import qualified Language.PureScript.Kinds as K +import qualified Language.PureScript.Label as L +import qualified Language.PureScript.Names as N +import Language.PureScript.PSString (mkString) +import qualified Language.PureScript.Types as T +import Language.PureScript.CST.Positions +import Language.PureScript.CST.Types + +comment :: Comment a -> Maybe C.Comment +comment = \case + Comment t + | Text.isPrefixOf "{-" t -> Just $ C.BlockComment $ Text.drop 2 $ Text.dropEnd 2 t + | Text.isPrefixOf "--" t -> Just $ C.LineComment $ Text.drop 2 t + _ -> Nothing + +comments :: [Comment a] -> [C.Comment] +comments = mapMaybe comment + +sourcePos :: SourcePos -> Pos.SourcePos +sourcePos (SourcePos line col) = Pos.SourcePos line col + +sourceSpan :: String -> SourceRange -> Pos.SourceSpan +sourceSpan name (SourceRange start end) = Pos.SourceSpan name (sourcePos start) (sourcePos end) + +widenLeft :: TokenAnn -> Pos.SourceAnn -> Pos.SourceAnn +widenLeft ann (sp, _) = + ( Pos.widenSourceSpan (sourceSpan (Pos.spanName sp) $ tokRange ann) sp + , comments $ tokLeadingComments ann + ) + +sourceAnnCommented :: String -> SourceToken -> SourceToken -> Pos.SourceAnn +sourceAnnCommented fileName (SourceToken ann1 _) (SourceToken ann2 _) = + ( Pos.SourceSpan fileName (sourcePos $ srcStart $ tokRange ann1) (sourcePos $ srcEnd $ tokRange ann2) + , comments $ tokLeadingComments ann1 + ) + +sourceAnn :: String -> SourceToken -> SourceToken -> Pos.SourceAnn +sourceAnn fileName (SourceToken ann1 _) (SourceToken ann2 _) = + ( Pos.SourceSpan fileName (sourcePos $ srcStart $ tokRange ann1) (sourcePos $ srcEnd $ tokRange ann2) + , [] + ) + +sourceName :: String -> Name a -> Pos.SourceAnn +sourceName fileName a = sourceAnnCommented fileName (nameTok a) (nameTok a) + +sourceQualName :: String -> QualifiedName a -> Pos.SourceAnn +sourceQualName fileName a = sourceAnnCommented fileName (qualTok a) (qualTok a) + +moduleName :: Token -> Maybe N.ModuleName +moduleName = \case + TokLowerName as _ -> go as + TokUpperName as _ -> go as + TokSymbolName as _ -> go as + TokOperator as _ -> go as + _ -> Nothing + where + go [] = Nothing + go ns = Just $ N.ModuleName $ N.ProperName <$> ns + +qualified :: QualifiedName a -> N.Qualified a +qualified q = N.Qualified (qualModule q) (qualName q) + +ident :: Ident -> N.Ident +ident = N.Ident . getIdent + +convertKind :: String -> Kind a -> K.SourceKind +convertKind fileName = go + where + go = \case + KindName _ a -> + K.NamedKind (sourceQualName fileName a) $ qualified a + KindArr _ a _ b -> do + let + lhs = go a + rhs = go b + ann = Pos.widenSourceAnn (K.getAnnForKind lhs) (K.getAnnForKind rhs) + K.FunKind ann lhs rhs + KindRow _ tok a -> do + let + kind = go a + ann = widenLeft (tokAnn tok) $ K.getAnnForKind kind + K.Row ann kind + KindParens _ (Wrapped _ a _) -> + go a + +convertType :: String -> Type a -> T.SourceType +convertType fileName = go + where + goRow (Row labels tl) b = do + let + rowTail = case tl of + Just (_, ty) -> go ty + Nothing -> T.REmpty $ sourceAnnCommented fileName b b + rowCons (Labeled a _ ty) c = do + let ann = sourceAnnCommented fileName (lblTok a) (snd $ typeRange ty) + T.RCons ann (L.Label $ lblName a) (go ty) c + case labels of + Just (Separated h t) -> + rowCons h $ foldr (rowCons . snd) rowTail t + Nothing -> + rowTail + + go = \case + TypeVar _ a -> + T.TypeVar (sourceName fileName a) . getIdent $ nameValue a + TypeConstructor _ a -> + T.TypeConstructor (sourceQualName fileName a) $ qualified a + TypeWildcard _ a -> + T.TypeWildcard (sourceAnnCommented fileName a a) Nothing + TypeHole _ a -> + T.TypeWildcard (sourceName fileName a) . Just . getIdent $ nameValue a + TypeString _ a b -> + T.TypeLevelString (sourceAnnCommented fileName a a) $ b + TypeRow _ (Wrapped _ row b) -> + goRow row b + TypeRecord _ (Wrapped a row b) -> do + let + ann = sourceAnnCommented fileName a b + annRec = sourceAnn fileName a a + T.TypeApp ann (Env.tyRecord $> annRec) $ goRow row b + TypeForall _ kw bindings _ ty -> do + let + mkForAll a b t = do + let ann' = widenLeft (tokAnn $ nameTok a) $ T.getAnnForType t + T.ForAll ann' (getIdent $ nameValue a) b t Nothing + k t (TypeVarKinded (Wrapped _ (Labeled a _ b) _)) = mkForAll a (Just (convertKind fileName b)) t + k t (TypeVarName a) = mkForAll a Nothing t + -- The existing parser builds variables in reverse order + ty' = foldl k (go ty) bindings + ann = widenLeft (tokAnn kw) $ T.getAnnForType ty' + T.setAnnForType ann ty' + TypeKinded _ ty _ kd -> do + let + ty' = go ty + kd' = convertKind fileName kd + ann = Pos.widenSourceAnn (T.getAnnForType ty') (K.getAnnForKind kd') + T.KindedType ann ty' kd' + TypeApp _ a b -> do + let + a' = go a + b' = go b + ann = Pos.widenSourceAnn (T.getAnnForType a') (T.getAnnForType b') + T.TypeApp ann a' b' + ty@(TypeOp _ _ _ _) -> do + let + reassoc op b' a = do + let + a' = go a + op' = T.TypeOp (sourceQualName fileName op) $ qualified op + ann = Pos.widenSourceAnn (T.getAnnForType a') (T.getAnnForType b') + T.BinaryNoParensType ann op' (go a) b' + loop k = \case + TypeOp _ a op b -> loop (reassoc op (k b)) a + expr' -> k expr' + loop go ty + TypeOpName _ op -> do + let rng = qualRange op + T.TypeOp (uncurry (sourceAnnCommented fileName) rng) (qualified op) + TypeArr _ a arr b -> do + let + a' = go a + b' = go b + arr' = Env.tyFunction $> sourceAnnCommented fileName arr arr + ann = Pos.widenSourceAnn (T.getAnnForType a') (T.getAnnForType b') + T.TypeApp ann (T.TypeApp ann arr' a') b' + TypeArrName _ a -> + Env.tyFunction $> sourceAnnCommented fileName a a + TypeConstrained _ a _ b -> do + let + a' = convertConstraint fileName a + b' = go b + ann = Pos.widenSourceAnn (T.constraintAnn a') (T.getAnnForType b') + T.ConstrainedType ann a' b' + TypeParens _ (Wrapped a ty b) -> + T.ParensInType (sourceAnnCommented fileName a b) $ go ty + +convertConstraint :: String -> Constraint a -> T.SourceConstraint +convertConstraint fileName = go + where + go = \case + cst@(Constraint _ name args) -> do + let ann = uncurry (sourceAnnCommented fileName) $ constraintRange cst + T.Constraint ann (qualified name) (convertType fileName <$> args) Nothing + ConstraintParens _ (Wrapped _ c _) -> go c + +convertGuarded :: String -> Guarded a -> [AST.GuardedExpr] +convertGuarded fileName = \case + Unconditional _ x -> [AST.GuardedExpr [] (convertWhere fileName x)] + Guarded gs -> (\(GuardedExpr _ ps _ x) -> AST.GuardedExpr (p <$> toList ps) (convertWhere fileName x)) <$> NE.toList gs + where + go = convertExpr fileName + p (PatternGuard Nothing x) = AST.ConditionGuard (go x) + p (PatternGuard (Just (b, _)) x) = AST.PatternGuard (convertBinder fileName b) (go x) + +convertWhere :: String -> Where a -> AST.Expr +convertWhere fileName = \case + Where expr Nothing -> convertExpr fileName expr + Where expr (Just (_, bs)) -> do + let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr + uncurry AST.PositionedValue ann . AST.Let AST.FromWhere (convertLetBinding fileName <$> NE.toList bs) $ convertExpr fileName expr + +convertLetBinding :: String -> LetBinding a -> AST.Declaration +convertLetBinding fileName = \case + LetBindingSignature _ lbl -> + convertSignature fileName lbl + binding@(LetBindingName _ fields) -> do + let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding + convertValueBindingFields fileName ann fields + binding@(LetBindingPattern _ a _ b) -> do + let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding + AST.BoundValueDeclaration ann (convertBinder fileName a) (convertWhere fileName b) + +convertExpr :: forall a. String -> Expr a -> AST.Expr +convertExpr fileName = go + where + positioned = + uncurry AST.PositionedValue + + goDoStatement = \case + stmt@(DoLet _ as) -> do + let ann = uncurry (sourceAnnCommented fileName) $ doStatementRange stmt + uncurry AST.PositionedDoNotationElement ann . AST.DoNotationLet $ convertLetBinding fileName <$> NE.toList as + stmt@(DoDiscard a) -> do + let ann = uncurry (sourceAnn fileName) $ doStatementRange stmt + uncurry AST.PositionedDoNotationElement ann . AST.DoNotationValue $ go a + stmt@(DoBind a _ b) -> do + let + ann = uncurry (sourceAnn fileName) $ doStatementRange stmt + a' = convertBinder fileName a + b' = go b + uncurry AST.PositionedDoNotationElement ann $ AST.DoNotationBind a' b' + + go = \case + ExprHole _ a -> + positioned (sourceName fileName a) . AST.Hole . getIdent $ nameValue a + ExprSection _ a -> + positioned (sourceAnnCommented fileName a a) AST.AnonymousArgument + ExprIdent _ a -> do + let ann = sourceQualName fileName a + positioned ann . AST.Var (fst ann) . qualified $ fmap ident a + ExprConstructor _ a -> do + let ann = sourceQualName fileName a + positioned ann . AST.Constructor (fst ann) $ qualified a + ExprBoolean _ a b -> do + let ann = sourceAnnCommented fileName a a + positioned ann . AST.Literal (fst ann) $ AST.BooleanLiteral b + ExprChar _ a b -> do + let ann = sourceAnnCommented fileName a a + positioned ann . AST.Literal (fst ann) $ AST.CharLiteral b + ExprString _ a b -> do + let ann = sourceAnnCommented fileName a a + positioned ann . AST.Literal (fst ann) . AST.StringLiteral $ b + ExprNumber _ a b -> do + let ann = sourceAnnCommented fileName a a + positioned ann . AST.Literal (fst ann) $ AST.NumericLiteral b + ExprArray _ (Wrapped a bs c) -> do + let + ann = sourceAnnCommented fileName a c + vals = case bs of + Just (Separated x xs) -> go x : (go . snd <$> xs) + Nothing -> [] + positioned ann . AST.Literal (fst ann) $ AST.ArrayLiteral vals + ExprRecord z (Wrapped a bs c) -> do + let + ann = sourceAnnCommented fileName a c + lbl = \case + RecordPun f -> (mkString . getIdent $ nameValue f, go . ExprIdent z $ QualifiedName (nameTok f) Nothing (nameValue f)) + RecordField f _ v -> (lblName f, go v) + vals = case bs of + Just (Separated x xs) -> lbl x : (lbl . snd <$> xs) + Nothing -> [] + positioned ann . AST.Literal (fst ann) $ AST.ObjectLiteral vals + ExprParens _ (Wrapped a b c) -> + positioned (sourceAnnCommented fileName a c) . AST.Parens $ go b + expr@(ExprTyped _ a _ b) -> do + let + a' = go a + b' = convertType fileName b + ann = (sourceSpan fileName . toSourceRange $ exprRange expr, []) + positioned ann $ AST.TypedValue True a' b' + expr@(ExprInfix _ a (Wrapped _ b _) c) -> do + let ann = (sourceSpan fileName . toSourceRange $ exprRange expr, []) + positioned ann $ AST.BinaryNoParens (go b) (go a) (go c) + expr@(ExprOp _ _ _ _) -> do + let + ann = uncurry (sourceAnn fileName) $ exprRange expr + reassoc op b a = do + let op' = AST.Op (sourceSpan fileName . toSourceRange $ qualRange op) $ qualified op + AST.BinaryNoParens op' (go a) b + loop k = \case + ExprOp _ a op b -> loop (reassoc op (k b)) a + expr' -> k expr' + positioned ann $ loop go expr + ExprOpName _ op -> do + let + rng = qualRange op + op' = AST.Op (sourceSpan fileName $ toSourceRange rng) $ qualified op + positioned (uncurry (sourceAnnCommented fileName) rng) op' + expr@(ExprNegate _ _ b) -> do + let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr + positioned ann . AST.UnaryMinus (fst ann) $ go b + expr@(ExprRecordAccessor _ (RecordAccessor a _ (Separated h t))) -> do + let + ann = uncurry (sourceAnnCommented fileName) $ exprRange expr + field x f = AST.Accessor (lblName f) x + positioned ann $ foldl' (\x (_, f) -> field x f) (field (go a) h) t + expr@(ExprRecordUpdate _ a b) -> do + let + ann = uncurry (sourceAnnCommented fileName) $ exprRange expr + k (RecordUpdateLeaf f _ x) = (lblName f, AST.Leaf $ go x) + k (RecordUpdateBranch f xs) = (lblName f, AST.Branch $ toTree xs) + toTree (Wrapped _ xs _) = AST.PathTree . AST.AssocList . map k $ toList xs + positioned ann . AST.ObjectUpdateNested (go a) $ toTree b + expr@(ExprApp _ a b) -> do + let ann = uncurry (sourceAnn fileName) $ exprRange expr + positioned ann $ AST.App (go a) (go b) + expr@(ExprLambda _ (Lambda _ as _ b)) -> do + let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr + positioned ann + . AST.Abs (convertBinder fileName (NE.head as)) + . foldr (AST.Abs . convertBinder fileName) (go b) + $ NE.tail as + expr@(ExprIf _ (IfThenElse _ a _ b _ c)) -> do + let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr + positioned ann $ AST.IfThenElse (go a) (go b) (go c) + expr@(ExprCase _ (CaseOf _ as _ bs)) -> do + let + ann = uncurry (sourceAnnCommented fileName) $ exprRange expr + as' = go <$> toList as + bs' = uncurry AST.CaseAlternative . bimap (map (convertBinder fileName) . toList) (convertGuarded fileName) <$> NE.toList bs + positioned ann $ AST.Case as' bs' + expr@(ExprLet _ (LetIn _ as _ b)) -> do + let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr + positioned ann . AST.Let AST.FromLet (convertLetBinding fileName <$> NE.toList as) $ go b + -- expr@(ExprWhere _ (Where a _ bs)) -> do + -- let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr + -- positioned ann . AST.Let AST.FromWhere (goLetBinding <$> bs) $ go a + expr@(ExprDo _ (DoBlock kw stmts)) -> do + let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr + positioned ann . AST.Do (moduleName $ tokValue kw) $ goDoStatement <$> NE.toList stmts + expr@(ExprAdo _ (AdoBlock kw stms _ a)) -> do + let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr + positioned ann . AST.Ado (moduleName $ tokValue kw) (goDoStatement <$> stms) $ go a + +convertBinder :: String -> Binder a -> AST.Binder +convertBinder fileName = go + where + positioned = + uncurry AST.PositionedBinder + + go = \case + BinderWildcard _ a -> + positioned (sourceAnnCommented fileName a a) AST.NullBinder + BinderVar _ a -> do + let ann = sourceName fileName a + positioned ann . AST.VarBinder (fst ann) . ident $ nameValue a + binder@(BinderNamed _ a _ b) -> do + let ann = uncurry (sourceAnnCommented fileName) $ binderRange binder + positioned ann . AST.NamedBinder (fst ann) (ident $ nameValue a) $ go b + binder@(BinderConstructor _ a bs) -> do + let ann = uncurry (sourceAnnCommented fileName) $ binderRange binder + positioned ann . AST.ConstructorBinder (fst ann) (qualified a) $ go <$> bs + BinderBoolean _ a b -> do + let ann = sourceAnnCommented fileName a a + positioned ann . AST.LiteralBinder (fst ann) $ AST.BooleanLiteral b + BinderChar _ a b -> do + let ann = sourceAnnCommented fileName a a + positioned ann . AST.LiteralBinder (fst ann) $ AST.CharLiteral b + BinderString _ a b -> do + let ann = sourceAnnCommented fileName a a + positioned ann . AST.LiteralBinder (fst ann) . AST.StringLiteral $ b + BinderNumber _ n a b -> do + let + ann = sourceAnnCommented fileName a a + b' + | isJust n = bimap negate negate b + | otherwise = b + positioned ann . AST.LiteralBinder (fst ann) $ AST.NumericLiteral b' + BinderArray _ (Wrapped a bs c) -> do + let + ann = sourceAnnCommented fileName a c + vals = case bs of + Just (Separated x xs) -> go x : (go . snd <$> xs) + Nothing -> [] + positioned ann . AST.LiteralBinder (fst ann) $ AST.ArrayLiteral vals + BinderRecord z (Wrapped a bs c) -> do + let + ann = sourceAnnCommented fileName a c + lbl = \case + RecordPun f -> (mkString . getIdent $ nameValue f, go $ BinderVar z f) + RecordField f _ v -> (lblName f, go v) + vals = case bs of + Just (Separated x xs) -> lbl x : (lbl . snd <$> xs) + Nothing -> [] + positioned ann . AST.LiteralBinder (fst ann) $ AST.ObjectLiteral vals + BinderParens _ (Wrapped a b c) -> + positioned (sourceAnnCommented fileName a c) . AST.ParensInBinder $ go b + binder@(BinderTyped _ a _ b) -> do + let + a' = go a + b' = convertType fileName b + ann = (sourceSpan fileName . toSourceRange $ binderRange binder, []) + positioned ann $ AST.TypedBinder b' a' + binder@(BinderOp _ _ _ _) -> do + let + ann = uncurry (sourceAnn fileName) $ binderRange binder + reassoc op b a = do + let op' = AST.OpBinder (sourceSpan fileName . toSourceRange $ qualRange op) $ qualified op + AST.BinaryNoParensBinder op' (go a) b + loop k = \case + BinderOp _ a op b -> loop (reassoc op (k b)) a + binder' -> k binder' + positioned ann $ loop go binder + +convertDeclaration :: String -> Declaration a -> [AST.Declaration] +convertDeclaration fileName decl = case decl of + DeclData _ (DataHead _ a vars) bd -> do + let + ctr (DataCtor _ x ys) = (nameValue x, zip ctrFields $ convertType fileName <$> ys) + ctrs = case bd of + Nothing -> [] + Just (_, cs) -> ctr <$> toList cs + pure $ AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) ctrs + DeclType _ (DataHead _ a vars) _ bd -> + pure $ AST.TypeSynonymDeclaration ann + (nameValue a) + (goTypeVar <$> vars) + (convertType fileName bd) + DeclNewtype _ (DataHead _ a vars) _ x ys -> do + let ctrs = [(nameValue x, [(head ctrFields, convertType fileName ys)])] + pure $ AST.DataDeclaration ann Env.Newtype (nameValue a) (goTypeVar <$> vars) ctrs + DeclClass _ (ClassHead _ sup name vars fdeps) bd -> do + let + goTyVar (TypeVarKinded (Wrapped _ (Labeled a _ _) _)) = nameValue a + goTyVar (TypeVarName a) = nameValue a + vars' = zip (toList $ goTyVar <$> vars) [0..] + goName = fromJust . flip lookup vars' . nameValue + goFundep (FundepDetermined _ bs) = Env.FunctionalDependency [] (goName <$> NE.toList bs) + goFundep (FundepDetermines as _ bs) = Env.FunctionalDependency (goName <$> NE.toList as) (goName <$> NE.toList bs) + goSig (Labeled n _ ty) = do + let + ty' = convertType fileName ty + ann' = widenLeft (tokAnn $ nameTok n) $ T.getAnnForType ty' + AST.TypeDeclaration $ AST.TypeDeclarationData ann' (ident $ nameValue n) ty' + pure $ AST.TypeClassDeclaration ann + (nameValue name) + (goTypeVar <$> vars) + (convertConstraint fileName <$> maybe [] (toList . fst) sup) + (goFundep <$> maybe [] (toList . snd) fdeps) + (goSig <$> maybe [] (NE.toList . snd) bd) + DeclInstanceChain _ insts -> do + let + instName (Instance (InstanceHead _ a _ _ _ _) _) = ident $ nameValue a + chainId = instName <$> toList insts + goInst ix inst@(Instance (InstanceHead _ name _ ctrs cls args) bd) = do + let ann' = uncurry (sourceAnnCommented fileName) $ instanceRange inst + AST.TypeInstanceDeclaration ann' chainId ix + (ident $ nameValue name) + (convertConstraint fileName <$> maybe [] (toList . fst) ctrs) + (qualified cls) + (convertType fileName <$> args) + (AST.ExplicitInstance $ goInstanceBinding <$> maybe [] (NE.toList . snd) bd) + uncurry goInst <$> zip [0..] (toList insts) + DeclDerive _ _ new (InstanceHead _ name _ ctrs cls args) -> do + let + name' = ident $ nameValue name + instTy + | isJust new = AST.NewtypeInstance + | otherwise = AST.DerivedInstance + pure $ AST.TypeInstanceDeclaration ann [name'] 0 name' + (convertConstraint fileName <$> maybe [] (toList . fst) ctrs) + (qualified cls) + (convertType fileName <$> args) + instTy + DeclSignature _ lbl -> + pure $ convertSignature fileName lbl + DeclValue _ fields -> + pure $ convertValueBindingFields fileName ann fields + DeclFixity _ (FixityFields (_, kw) (_, prec) fxop) -> do + let + assoc = case kw of + Infix -> AST.Infix + Infixr -> AST.Infixr + Infixl -> AST.Infixl + fixity = AST.Fixity assoc prec + pure $ AST.FixityDeclaration ann $ case fxop of + FixityValue name _ op -> do + Left $ AST.ValueFixity fixity (first ident <$> qualified name) (nameValue op) + FixityType _ name _ op -> + Right $ AST.TypeFixity fixity (qualified name) (nameValue op) + DeclForeign _ _ _ frn -> + pure $ case frn of + ForeignValue (Labeled a _ b) -> + AST.ExternDeclaration ann (ident $ nameValue a) $ convertType fileName b + ForeignData _ (Labeled a _ b) -> + AST.ExternDataDeclaration ann (nameValue a) $ convertKind fileName b + ForeignKind _ a -> + AST.ExternKindDeclaration ann (nameValue a) + where + ann = + uncurry (sourceAnnCommented fileName) $ declRange decl + + goTypeVar = \case + TypeVarKinded (Wrapped _ (Labeled x _ y) _) -> (getIdent $ nameValue x, Just $ convertKind fileName y) + TypeVarName x -> (getIdent $ nameValue x, Nothing) + + goInstanceBinding = \case + InstanceBindingSignature _ lbl -> + convertSignature fileName lbl + binding@(InstanceBindingName _ fields) -> do + let ann' = uncurry (sourceAnnCommented fileName) $ instanceBindingRange binding + convertValueBindingFields fileName ann' fields + +convertSignature :: String -> Labeled (Name Ident) (Type a) -> AST.Declaration +convertSignature fileName (Labeled a _ b) = do + let + b' = convertType fileName b + ann = widenLeft (tokAnn $ nameTok a) $ T.getAnnForType b' + AST.TypeDeclaration $ AST.TypeDeclarationData ann (ident $ nameValue a) b' + +convertValueBindingFields :: String -> Pos.SourceAnn -> ValueBindingFields a -> AST.Declaration +convertValueBindingFields fileName ann (ValueBindingFields a bs c) = do + let + bs' = convertBinder fileName <$> bs + cs' = convertGuarded fileName c + AST.ValueDeclaration $ AST.ValueDeclarationData ann (ident $ nameValue a) Env.Public bs' cs' + +convertImportDecl :: String -> ImportDecl a -> AST.Declaration +convertImportDecl fileName decl@(ImportDecl _ _ modName mbNames mbQual) = do + let + ann = uncurry (sourceAnnCommented fileName) $ importDeclRange decl + importTy = case mbNames of + Nothing -> AST.Implicit + Just (hiding, (Wrapped _ imps _)) -> do + let imps' = convertImport fileName <$> toList imps + if isJust hiding + then AST.Hiding imps' + else AST.Explicit imps' + AST.ImportDeclaration ann (nameValue modName) importTy (nameValue . snd <$> mbQual) + +convertImport :: String -> Import a -> AST.DeclarationRef +convertImport fileName imp = case imp of + ImportValue _ a -> + AST.ValueRef ann . ident $ nameValue a + ImportOp _ a -> + AST.ValueOpRef ann $ nameValue a + ImportType _ a mb -> do + let + ctrs = case mb of + Nothing -> Just [] + Just (DataAll _ _) -> Nothing + Just (DataEnumerated _ (Wrapped _ Nothing _)) -> Just [] + Just (DataEnumerated _ (Wrapped _ (Just idents) _)) -> + Just . map nameValue $ toList idents + AST.TypeRef ann (nameValue a) ctrs + ImportTypeOp _ _ a -> + AST.TypeOpRef ann $ nameValue a + ImportClass _ _ a -> + AST.TypeClassRef ann $ nameValue a + ImportKind _ _ a -> + AST.KindRef ann $ nameValue a + where + ann = sourceSpan fileName . toSourceRange $ importRange imp + +convertExport :: String -> Export a -> AST.DeclarationRef +convertExport fileName export = case export of + ExportValue _ a -> + AST.ValueRef ann . ident $ nameValue a + ExportOp _ a -> + AST.ValueOpRef ann $ nameValue a + ExportType _ a mb -> do + let + ctrs = case mb of + Nothing -> Just [] + Just (DataAll _ _) -> Nothing + Just (DataEnumerated _ (Wrapped _ Nothing _)) -> Just [] + Just (DataEnumerated _ (Wrapped _ (Just idents) _)) -> + Just . map nameValue $ toList idents + AST.TypeRef ann (nameValue a) ctrs + ExportTypeOp _ _ a -> + AST.TypeOpRef ann $ nameValue a + ExportClass _ _ a -> + AST.TypeClassRef ann $ nameValue a + ExportKind _ _ a -> + AST.KindRef ann $ nameValue a + ExportModule _ _ a -> + AST.ModuleRef ann (nameValue a) + where + ann = sourceSpan fileName . toSourceRange $ exportRange export + +convertModule :: String -> Module a -> AST.Module +convertModule fileName module'@(Module _ _ modName exps _ imps decls _) = do + let + ann = uncurry (sourceAnnCommented fileName) $ moduleRange module' + imps' = convertImportDecl fileName <$> imps + decls' = convertDeclaration fileName =<< decls + exps' = map (convertExport fileName) . toList . wrpValue <$> exps + uncurry AST.Module ann (nameValue modName) (imps' <> decls') exps' + +ctrFields :: [N.Ident] +ctrFields = [N.Ident ("value" <> Text.pack (show (n :: Integer))) | n <- [0..]] diff --git a/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs new file mode 100644 index 0000000000..0dcfa7bf0a --- /dev/null +++ b/src/Language/PureScript/CST/Errors.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Language.PureScript.CST.Errors + ( ParserError(..) + , ParserErrorType(..) + , prettyPrintError + , prettyPrintErrorMessage + ) where + +import Prelude + +import qualified Data.Text as Text +import Data.Char (isSpace) +import Language.PureScript.CST.Layout +import Language.PureScript.CST.Print +import Language.PureScript.CST.Types + +data ParserErrorType + = ErrWildcardInType + | ErrHoleInType + | ErrExprInBinder + | ErrExprInDeclOrBinder + | ErrExprInDecl + | ErrBinderInDecl + | ErrRecordUpdateInCtr + | ErrRecordPunInUpdate + | ErrRecordCtrInUpdate + | ErrTypeInConstraint + | ErrElseInDecl + | ErrInstanceNameMismatch + | ErrUnknownFundep + | ErrImportInDecl + | ErrGuardInLetBinder + | ErrKeywordVar + | ErrKeywordSymbol + | ErrToken + | ErrLineFeedInString + | ErrAstralCodePointInChar + | ErrCharEscape + | ErrNumberOutOfRange + | ErrLeadingZero + | ErrExpectedFraction + | ErrExpectedExponent + | ErrExpectedHex + | ErrReservedSymbol + | ErrCharInGap Char + | ErrModuleName + | ErrQualifiedName + | ErrEmptyDo + | ErrLexeme (Maybe String) [String] + | ErrEof + deriving (Show, Eq, Ord) + +data ParserError = ParserError + { errRange :: SourceRange + , errToks :: [SourceToken] + , errStack :: LayoutStack + , errType :: ParserErrorType + } deriving (Show, Eq) + +prettyPrintError :: ParserError -> String +prettyPrintError pe@(ParserError { errRange }) = + prettyPrintErrorMessage pe <> " at " <> errPos + where + errPos = case errRange of + SourceRange (SourcePos line col) _ -> + "line " <> show line <> ", column " <> show col + +prettyPrintErrorMessage :: ParserError -> String +prettyPrintErrorMessage (ParserError {..}) = case errType of + ErrWildcardInType -> + "Unexpected wildcard in type; type wildcards are only allowed in value annotations" + ErrHoleInType -> + "Unexpected hole in type; type holes are only allowed in value annotations" + ErrExprInBinder -> + "Expected pattern, saw expression" + ErrExprInDeclOrBinder -> + "Expected declaration or pattern, saw expression" + ErrExprInDecl -> + "Expected declaration, saw expression" + ErrBinderInDecl -> + "Expected declaration, saw pattern" + ErrRecordUpdateInCtr -> + "Expected ':', saw '='" + ErrRecordPunInUpdate -> + "Expected record update, saw pun" + ErrRecordCtrInUpdate -> + "Expected '=', saw ':'" + ErrTypeInConstraint -> + "Expected constraint, saw type" + ErrElseInDecl -> + "Expected declaration, saw 'else'" + ErrInstanceNameMismatch -> + "All instances in a chain must implement the same type class" + ErrUnknownFundep -> + "Unknown type variable in functional dependency" + ErrImportInDecl -> + "Expected declaration, saw 'import'" + ErrGuardInLetBinder -> + "Unexpected guard in let pattern" + ErrKeywordVar -> + "Expected variable, saw keyword" + ErrKeywordSymbol -> + "Expected symbol, saw reserved symbol" + ErrEof -> + "Unexpected end of input" + ErrLexeme (Just (hd : _)) _ | isSpace hd -> + "Illegal whitespace character " <> show hd + ErrLexeme (Just a) _ -> + "Unexpected " <> a + ErrLineFeedInString -> + "Unexpected line feed in string literal" + ErrAstralCodePointInChar -> + "Illegal astral code point in character literal" + ErrCharEscape -> + "Illegal character escape code" + ErrNumberOutOfRange -> + "Number literal is out of range" + ErrLeadingZero -> + "Unexpected leading zeros" + ErrExpectedFraction -> + "Expected fraction" + ErrExpectedExponent -> + "Expected exponent" + ErrExpectedHex -> + "Expected hex digit" + ErrReservedSymbol -> + "Unexpected reserved symbol" + ErrCharInGap ch -> + "Unexpected character '" <> [ch] <> "' in gap" + ErrModuleName -> + "Invalid module name; underscores and primes are not allowed in module names" + ErrQualifiedName -> + "Unexpected qualified name" + ErrEmptyDo -> + "Expected do statement" + ErrLexeme _ _ -> + basicError + ErrToken + | SourceToken _ (TokLeftArrow _) : _ <- errToks -> + "Unexpected \"<-\" in expression, perhaps due to a missing 'do' or 'ado' keyword" + ErrToken -> + basicError + + where + basicError = case errToks of + tok : _ -> basicTokError (tokValue tok) + [] -> "Unexpected input" + + basicTokError = \case + TokLayoutStart -> "Unexpected or mismatched indentation" + TokLayoutSep -> "Unexpected or mismatched indentation" + TokLayoutEnd -> "Unexpected or mismatched indentation" + TokEof -> "Unexpected end of input" + tok -> "Unexpected token '" <> Text.unpack (printToken tok) <> "'" diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs new file mode 100644 index 0000000000..9baf8bfd7e --- /dev/null +++ b/src/Language/PureScript/CST/Layout.hs @@ -0,0 +1,388 @@ +-- | The parser itself is unaware of indentation, and instead only parses explicit +-- delimiters which are inserted by this layout algorithm (much like Haskell). +-- This is convenient because the actual grammar can be specified apart from the +-- indentation rules. Haskell has a few problematic productions which make it +-- impossible to implement a purely lexical layout algorithm, so it also has an +-- additional (and somewhat contentious) parser error side condition. PureScript +-- does not have these problematic productions (particularly foo, bar :: +-- SomeType syntax in declarations), but it does have a few gotchas of it's own. +-- The algorithm is "non-trivial" to say the least, but it is implemented as a +-- purely lexical delimiter parser on a token-by-token basis, which is highly +-- convenient, since it can be replicated in any language or toolchain. There is +-- likely room to simplify it, but there are some seemingly innocuous things +-- that complicate it. +-- +-- "Naked" commas (case, patterns, guards, fundeps) are a constant source of +-- complexity, and indeed too much of this is what prevents Haskell from having +-- such an algorithm. Unquoted properties for layout keywords introduce a domino +-- effect of complexity since we have to mask and unmask any usage of . (also in +-- foralls!) or labels in record literals. + +module Language.PureScript.CST.Layout where + +import Prelude + +import Data.DList (snoc) +import qualified Data.DList as DList +import Data.Foldable (find) +import Data.Function ((&)) +import Language.PureScript.CST.Types + +type LayoutStack = [(SourcePos, LayoutDelim)] + +data LayoutDelim + = LytRoot + | LytTopDecl + | LytTopDeclHead + | LytDeclGuard + | LytCase + | LytCaseBinders + | LytCaseGuard + | LytLambdaBinders + | LytParen + | LytBrace + | LytSquare + | LytIf + | LytThen + | LytProperty + | LytForall + | LytTick + | LytLet + | LytWhere + | LytOf + | LytDo + | LytAdo + deriving (Show, Eq, Ord) + +isIndented :: LayoutDelim -> Bool +isIndented = \case + LytLet -> True + LytWhere -> True + LytOf -> True + LytDo -> True + LytAdo -> True + _ -> False + +isTopDecl :: SourcePos -> LayoutStack -> Bool +isTopDecl tokPos = \case + [(lytPos, LytWhere), (_, LytRoot)] + | srcColumn tokPos == srcColumn lytPos -> True + _ -> False + +lytToken :: SourcePos -> Token -> SourceToken +lytToken pos = SourceToken ann + where + ann = TokenAnn + { tokRange = SourceRange pos pos + , tokLeadingComments = [] + , tokTrailingComments = [] + } + +insertLayout :: SourceToken -> SourcePos -> LayoutStack -> (LayoutStack, [SourceToken]) +insertLayout src@(SourceToken tokAnn tok) nextPos stack = + DList.toList <$> insert (stack, mempty) + where + tokPos = + srcStart $ tokRange tokAnn + + insert state@(stk, acc) = case tok of + -- `data` declarations need masking (LytTopDecl) because the usage of `|` + -- should not introduce a LytDeclGard context. + TokLowerName [] "data" -> + case state & insertDefault of + state'@(stk', _) | isTopDecl tokPos stk' -> + state' & pushStack tokPos LytTopDecl + state' -> + state' & popStack (== LytProperty) + + -- `class` declaration heads need masking (LytTopDeclHead) because the + -- usage of commas in functional dependencies. + TokLowerName [] "class" -> + case state & insertDefault of + state'@(stk', _) | isTopDecl tokPos stk' -> + state' & pushStack tokPos LytTopDeclHead + state' -> + state' & popStack (== LytProperty) + + TokLowerName [] "where" -> + case stk of + (_, LytTopDeclHead) : stk' -> + (stk', acc) & insertToken src & insertStart LytWhere + (_, LytProperty) : stk' -> + (stk', acc) & insertToken src + _ -> + state & collapse whereP & insertToken src & insertStart LytWhere + where + -- `where` always closes do blocks: + -- example = do do do do foo where foo = ... + -- + -- `where` closes layout contexts even when indented at the same level: + -- example = case + -- Foo -> ... + -- Bar -> ... + -- where foo = ... + whereP _ LytDo = True + whereP lytPos lyt = offsideEndP lytPos lyt + + TokLowerName [] "in" -> + case collapse inP state of + -- `let/in` is not allowed in `ado` syntax. `in` is treated as a + -- delimiter and must always close the `ado`. + -- example = ado + -- foo <- ... + -- let bar = ... + -- in ... + ((_, LytLet) : (_, LytAdo) : stk', acc') -> + (stk', acc') & insertEnd & insertEnd & insertToken src + ((_, lyt) : stk', acc') | isIndented lyt -> + (stk', acc') & insertEnd & insertToken src + _ -> + state & insertDefault & popStack (== LytProperty) + where + inP _ LytLet = False + inP _ LytAdo = False + inP _ lyt = isIndented lyt + + TokLowerName [] "let" -> + state & insertKwProperty (insertStart LytLet) + + TokLowerName _ "do" -> + state & insertKwProperty (insertStart LytDo) + + TokLowerName _ "ado" -> + state & insertKwProperty (insertStart LytAdo) + + -- `case` heads need masking due to commas. + TokLowerName [] "case" -> + state & insertKwProperty (pushStack tokPos LytCase) + + TokLowerName [] "of" -> + case collapse indentedP state of + -- When `of` is matched with a `case`, we are in a case block, and we + -- need to mask additional contexts (LytCaseBinders, LytCaseGuards) + -- due to commas. + ((_, LytCase) : stk', acc') -> + (stk', acc') & insertToken src & insertStart LytOf & pushStack nextPos LytCaseBinders + state' -> + state' & insertDefault & popStack (== LytProperty) + + -- `if/then/else` is considered a delimiter context. This allows us to + -- write chained expressions in `do` blocks without stair-stepping: + -- example = do + -- foo + -- if ... then + -- ... + -- else if ... then + -- ... + -- else + -- ... + TokLowerName [] "if" -> + state & insertKwProperty (pushStack tokPos LytIf) + + TokLowerName [] "then" -> + case state & collapse indentedP of + ((_, LytIf) : stk', acc') -> + (stk', acc') & insertToken src & pushStack tokPos LytThen + _ -> + state & insertDefault & popStack (== LytProperty) + + TokLowerName [] "else" -> + case state & collapse indentedP of + ((_, LytThen) : stk', acc') -> + (stk', acc') & insertToken src + _ -> + -- We don't want to insert a layout separator for top-level `else` in + -- instance chains. + case state & collapse offsideP of + state'@(stk', _) | isTopDecl tokPos stk' -> + state' & insertToken src + state' -> + state' & insertSep & insertToken src & popStack (== LytProperty) + + -- `forall` binders need masking because the usage of `.` should not + -- introduce a LytProperty context. + TokForall _ -> + state & insertKwProperty (pushStack tokPos LytForall) + + -- Lambdas need masking because the usage of `->` should not close a + -- LytDeclGaurd or LytCaseGuard context. + TokBackslash -> + state & insertDefault & pushStack tokPos LytLambdaBinders + + TokRightArrow _ -> + state & collapse arrowP & popStack guardP & insertToken src + where + arrowP _ LytDo = True + arrowP _ LytOf = False + arrowP lytPos lyt = offsideEndP lytPos lyt + + guardP LytCaseBinders = True + guardP LytCaseGuard = True + guardP LytLambdaBinders = True + guardP _ = False + + TokEquals -> + case state & collapse equalsP of + ((_, LytDeclGuard) : stk', acc') -> + (stk', acc') & insertToken src + _ -> + state & insertDefault + where + equalsP _ LytWhere = True + equalsP _ LytLet = True + equalsP _ _ = False + + -- Guards need masking because of commas. + TokPipe -> + case collapse offsideEndP state of + state'@((_, LytOf) : _, _) -> + state' & pushStack tokPos LytCaseGuard & insertToken src + state'@((_, LytLet) : _, _) -> + state' & pushStack tokPos LytDeclGuard & insertToken src + state'@((_, LytWhere) : _, _) -> + state' & pushStack tokPos LytDeclGuard & insertToken src + _ -> + state & insertDefault + + -- Ticks can either start or end an infix expression. We preemptively + -- collapse all indentation contexts in search of a starting delimiter, + -- and backtrack if we don't find one. + TokTick -> + case state & collapse indentedP of + ((_, LytTick) : stk', acc') -> + (stk', acc') & insertToken src + _ -> + state & insertDefault & pushStack tokPos LytTick + + -- In gneral, commas should close all indented contexts. + -- example = [ do foo + -- bar, baz ] + TokComma -> + case state & collapse indentedP of + -- If we see a LytBrace, then we are in a record type or literal. + -- Record labels need masking so we can use unquoted keywords as labels + -- without accidentally littering layout delimiters. + state'@((_, LytBrace) : _, _) -> + state' & insertToken src & pushStack tokPos LytProperty + state' -> + state' & insertToken src + + -- TokDot tokens usually entail property access, which need masking so we + -- can use unquoted keywords as labels. + TokDot -> + case state & insertDefault of + ((_, LytForall) : stk', acc') -> + (stk', acc') + state' -> + state' & pushStack tokPos LytProperty + + TokLeftParen -> + state & insertDefault & pushStack tokPos LytParen + + TokLeftBrace -> + state & insertDefault & pushStack tokPos LytBrace & pushStack tokPos LytProperty + + TokLeftSquare -> + state & insertDefault & pushStack tokPos LytSquare + + TokRightParen -> + state & collapse indentedP & popStack (== LytParen) & insertToken src + + TokRightBrace -> + state & collapse indentedP & popStack (== LytProperty) & popStack (== LytBrace) & insertToken src + + TokRightSquare -> + state & collapse indentedP & popStack (== LytSquare) & insertToken src + + TokString _ _ -> + state & insertDefault & popStack (== LytProperty) + + TokLowerName [] _ -> + state & insertDefault & popStack (== LytProperty) + + TokOperator _ _ -> + state & collapse offsideEndP & insertSep & insertToken src + + _ -> + state & insertDefault + + insertDefault state = + state & collapse offsideP & insertSep & insertToken src + + insertStart lyt state@(stk, _) = + -- We only insert a new layout start when it's going to increase indentation. + -- This prevents things like the following from parsing: + -- instance foo :: Foo where + -- foo = 42 + case find (isIndented . snd) stk of + Just (pos, _) | srcColumn nextPos <= srcColumn pos -> state + _ -> state & pushStack nextPos lyt & insertToken (lytToken nextPos TokLayoutStart) + + insertSep state@(stk, acc) = case stk of + -- LytTopDecl is closed by a separator. + (lytPos, LytTopDecl) : stk' | sepP lytPos -> + (stk', acc) & insertToken sepTok + -- LytTopDeclHead can be closed by a separator if there is no `where`. + (lytPos, LytTopDeclHead) : stk' | sepP lytPos -> + (stk', acc) & insertToken sepTok + (lytPos, lyt) : _ | indentSepP lytPos lyt -> + case lyt of + -- If a separator is inserted in a case block, we need to push an + -- additional LytCaseBinders context for comma masking. + LytOf -> state & insertToken sepTok & pushStack tokPos LytCaseBinders + _ -> state & insertToken sepTok + _ -> state + where + sepTok = lytToken tokPos TokLayoutSep + + insertKwProperty k state = + case state & insertDefault of + ((_, LytProperty) : stk', acc') -> + (stk', acc') + state' -> + k state' + + insertEnd = + insertToken (lytToken tokPos TokLayoutEnd) + + insertToken token (stk, acc) = + (stk, acc `snoc` token) + + pushStack lytPos lyt (stk, acc) = + ((lytPos, lyt) : stk, acc) + + popStack p ((_, lyt) : stk', acc) + | p lyt = (stk', acc) + popStack _ state = state + + collapse p = uncurry go + where + go ((lytPos, lyt) : stk) acc + | p lytPos lyt = + go stk $ if isIndented lyt + then acc `snoc` lytToken tokPos TokLayoutEnd + else acc + go stk acc = (stk, acc) + + indentedP = + const isIndented + + offsideP lytPos lyt = + isIndented lyt && srcColumn tokPos < srcColumn lytPos + + offsideEndP lytPos lyt = + isIndented lyt && srcColumn tokPos <= srcColumn lytPos + + indentSepP lytPos lyt = + isIndented lyt && sepP lytPos + + sepP lytPos = + srcColumn tokPos == srcColumn lytPos && srcLine tokPos /= srcLine lytPos + +unwindLayout :: SourcePos -> [Comment LineFeed] -> LayoutStack -> [SourceToken] +unwindLayout pos leading = go + where + go [] = [] + go ((_, LytRoot) : _) = [SourceToken (TokenAnn (SourceRange pos pos) leading []) TokEof] + go ((_, lyt) : stk) | isIndented lyt = lytToken pos TokLayoutEnd : go stk + go (_ : stk) = go stk diff --git a/src/Language/PureScript/CST/Lexer.hs b/src/Language/PureScript/CST/Lexer.hs new file mode 100644 index 0000000000..b1e9d83733 --- /dev/null +++ b/src/Language/PureScript/CST/Lexer.hs @@ -0,0 +1,679 @@ +{-# LANGUAGE BangPatterns #-} +module Language.PureScript.CST.Lexer + ( lex + , munch + ) where + +import Prelude hiding (lex, exp, exponent, lines) + +import Control.Monad (join) +import qualified Data.Char as Char +import qualified Data.DList as DList +import Data.Foldable (foldl') +import Data.Functor (($>)) +import qualified Data.Scientific as Sci +import Data.String (fromString) +import Data.Text (Text) +import qualified Data.Text as Text +import Language.PureScript.CST.Errors +import Language.PureScript.CST.Monad +import Language.PureScript.CST.Layout +import Language.PureScript.CST.Positions +import Language.PureScript.CST.Types + +lex :: Text -> [LexResult] +lex = go1 + where + Parser lexK = + tokenAndComments + + go1 src = do + let (leading, src') = comments src + go2 $ LexState + { lexPos = advanceLeading (SourcePos 1 1) leading + , lexLeading = leading + , lexSource = src' + , lexStack = [(SourcePos 0 0, LytRoot)] + } + + go2 state@(LexState {..}) = + lexK lexSource onError onSuccess + where + onError lexSource' err = do + let + len1 = Text.length lexSource + len2 = Text.length lexSource' + chunk = Text.take (max 0 (len1 - len2)) lexSource + chunkDelta = textDelta chunk + pos = applyDelta lexPos chunkDelta + pure $ Left + ( state { lexSource = lexSource' } + , ParserError (SourceRange pos $ applyDelta pos (0, 1)) [] lexStack err + ) + + onSuccess _ (TokEof, _) = + Right <$> unwindLayout lexPos lexLeading lexStack + onSuccess lexSource' (tok, (trailing, lexLeading')) = do + let + endPos = advanceToken lexPos tok + lexPos' = advanceLeading (advanceTrailing endPos trailing) lexLeading' + tokenAnn = TokenAnn + { tokRange = SourceRange lexPos endPos + , tokLeadingComments = lexLeading + , tokTrailingComments = trailing + } + (lexStack', toks) = + insertLayout (SourceToken tokenAnn tok) lexPos' lexStack + state' = LexState + { lexPos = lexPos' + , lexLeading = lexLeading' + , lexSource = lexSource' + , lexStack = lexStack' + } + go3 state' toks + + go3 state [] = go2 state + go3 state (t : ts) = Right t : go3 state ts + +munch :: Parser SourceToken +munch = Parser $ \state@(ParserState {..}) kerr ksucc -> + case parserBuff of + Right tok : parserBuff' -> + ksucc (state { parserBuff = parserBuff' }) tok + Left (_, err) : _ -> + kerr state err + [] -> + error "Empty input" + +type Lexer = ParserM ParserErrorType Text + +{-# INLINE next #-} +next :: Lexer () +next = Parser $ \inp _ ksucc -> + ksucc (Text.drop 1 inp) () + +{-# INLINE nextWhile #-} +nextWhile :: (Char -> Bool) -> Lexer Text +nextWhile p = Parser $ \inp _ ksucc -> do + let (chs, inp') = Text.span p inp + ksucc inp' chs + +{-# INLINE peek #-} +peek :: Lexer (Maybe Char) +peek = Parser $ \inp _ ksucc -> + if Text.null inp + then ksucc inp Nothing + else ksucc inp $ Just $ Text.head inp + +{-# INLINE restore #-} +restore :: (ParserErrorType -> Bool) -> Lexer a -> Lexer a +restore p (Parser k) = Parser $ \inp kerr ksucc -> + k inp (\inp' err -> kerr (if p err then inp else inp') err) ksucc + +tokenAndComments :: Lexer (Token, ([Comment void], [Comment LineFeed])) +tokenAndComments = (,) <$> token <*> breakComments + +comments :: Text -> ([Comment LineFeed], Text) +comments = \src -> k src (\_ _ -> ([], src)) (\inp (a, b) -> (a <> b, inp)) + where + Parser k = breakComments + +breakComments :: Lexer ([Comment void], [Comment LineFeed]) +breakComments = k0 [] + where + k0 acc = do + spaces <- nextWhile (== ' ') + lines <- nextWhile isLineFeed + let + acc' + | Text.null spaces = acc + | otherwise = Space (Text.length spaces) : acc + if Text.null lines + then do + mbComm <- comment + case mbComm of + Just comm -> k0 (comm : acc') + Nothing -> pure (reverse acc', []) + else + k1 acc' (goWs [] $ Text.unpack lines) + + k1 trl acc = do + ws <- nextWhile (\c -> c == ' ' || isLineFeed c) + let acc' = goWs acc $ Text.unpack ws + mbComm <- comment + case mbComm of + Just comm -> k1 trl (comm : acc') + Nothing -> pure (reverse trl, reverse acc') + + goWs a ('\r' : '\n' : ls) = goWs (Line CRLF : a) ls + goWs a ('\r' : ls) = goWs (Line CRLF : a) ls + goWs a ('\n' : ls) = goWs (Line LF : a) ls + goWs a (' ' : ls) = goSpace a 1 ls + goWs a _ = a + + goSpace a !n (' ' : ls) = goSpace a (n + 1) ls + goSpace a !n ls = goWs (Space n : a) ls + + isBlockComment = Parser $ \inp _ ksucc -> + case Text.uncons inp of + Just ('-', inp2) -> + case Text.uncons inp2 of + Just ('-', inp3) -> + ksucc inp3 $ Just False + _ -> + ksucc inp Nothing + Just ('{', inp2) -> + case Text.uncons inp2 of + Just ('-', inp3) -> + ksucc inp3 $ Just True + _ -> + ksucc inp Nothing + _ -> + ksucc inp Nothing + + comment = isBlockComment >>= \case + Just True -> Just <$> blockComment "{-" + Just False -> Just <$> lineComment "--" + Nothing -> pure $ Nothing + + lineComment acc = do + comm <- nextWhile (\c -> c /= '\r' && c /= '\n') + pure $ Comment (acc <> comm) + + blockComment acc = do + chs <- nextWhile (/= '-') + dashes <- nextWhile (== '-') + if Text.null dashes + then pure $ Comment $ acc <> chs + else peek >>= \case + Just '}' -> next $> Comment (acc <> chs <> dashes <> "}") + _ -> blockComment (acc <> chs <> dashes) + +token :: Lexer Token +token = peek >>= maybe (pure TokEof) k0 + where + k0 ch1 = case ch1 of + '(' -> next *> leftParen + ')' -> next $> TokRightParen + '{' -> next $> TokLeftBrace + '}' -> next $> TokRightBrace + '[' -> next $> TokLeftSquare + ']' -> next $> TokRightSquare + '`' -> next $> TokTick + ',' -> next $> TokComma + '∷' -> next *> orOperator1 (TokDoubleColon Unicode) ch1 + '←' -> next *> orOperator1 (TokLeftArrow Unicode) ch1 + '→' -> next *> orOperator1 (TokRightArrow Unicode) ch1 + '⇒' -> next *> orOperator1 (TokRightFatArrow Unicode) ch1 + '∀' -> next *> orOperator1 (TokForall Unicode) ch1 + '|' -> next *> orOperator1 TokPipe ch1 + '.' -> next *> orOperator1 TokDot ch1 + '\\' -> next *> orOperator1 TokBackslash ch1 + '<' -> next *> orOperator2 (TokLeftArrow ASCII) ch1 '-' + '-' -> next *> orOperator2 (TokRightArrow ASCII) ch1 '>' + '=' -> next *> orOperator2' TokEquals (TokRightFatArrow ASCII) ch1 '>' + ':' -> next *> orOperator2' (TokOperator [] ":") (TokDoubleColon ASCII) ch1 ':' + '?' -> next *> hole + '\'' -> next *> char + '"' -> next *> string + _ | Char.isDigit ch1 -> restore (== ErrNumberOutOfRange) (next *> number ch1) + | Char.isUpper ch1 -> next *> upper [] ch1 + | isIdentStart ch1 -> next *> lower [] ch1 + | isSymbolChar ch1 -> next *> operator [] [ch1] + | otherwise -> throw $ ErrLexeme (Just [ch1]) [] + + {-# INLINE orOperator1 #-} + orOperator1 :: Token -> Char -> Lexer Token + orOperator1 tok ch1 = join $ Parser $ \inp _ ksucc -> + case Text.uncons inp of + Just (ch2, inp2) | isSymbolChar ch2 -> + ksucc inp2 $ operator [] [ch1, ch2] + _ -> + ksucc inp $ pure tok + + {-# INLINE orOperator2 #-} + orOperator2 :: Token -> Char -> Char -> Lexer Token + orOperator2 tok ch1 ch2 = join $ Parser $ \inp _ ksucc -> + case Text.uncons inp of + Just (ch2', inp2) | ch2 == ch2' -> + case Text.uncons inp2 of + Just (ch3, inp3) | isSymbolChar ch3 -> + ksucc inp3 $ operator [] [ch1, ch2, ch3] + _ -> + ksucc inp2 $ pure tok + _ -> + ksucc inp $ operator [] [ch1] + + {-# INLINE orOperator2' #-} + orOperator2' :: Token -> Token -> Char -> Char -> Lexer Token + orOperator2' tok1 tok2 ch1 ch2 = join $ Parser $ \inp _ ksucc -> + case Text.uncons inp of + Just (ch2', inp2) | ch2 == ch2' -> + case Text.uncons inp2 of + Just (ch3, inp3) | isSymbolChar ch3 -> + ksucc inp3 $ operator [] [ch1, ch2, ch3] + _ -> + ksucc inp2 $ pure tok2 + Just (ch2', inp2) | isSymbolChar ch2' -> + ksucc inp2 $ operator [] [ch1, ch2'] + _ -> + ksucc inp $ pure tok1 + + {- + leftParen + : '(' '→' ')' + | '(' '->' ')' + | '(' symbolChar+ ')' + | '(' + -} + leftParen :: Lexer Token + leftParen = Parser $ \inp kerr ksucc -> + case Text.span isSymbolChar inp of + (chs, inp2) + | Text.null chs -> ksucc inp TokLeftParen + | otherwise -> + case Text.uncons inp2 of + Just (')', inp3) -> + case chs of + "→" -> ksucc inp3 $ TokSymbolArr Unicode + "->" -> ksucc inp3 $ TokSymbolArr ASCII + _ | isReservedSymbol chs -> kerr inp ErrReservedSymbol + | otherwise -> ksucc inp3 $ TokSymbolName [] chs + _ -> ksucc inp TokLeftParen + + {- + symbol + : '(' symbolChar+ ')' + -} + symbol :: [Text] -> Lexer Token + symbol qual = restore isReservedSymbolError $ peek >>= \case + Just ch | isSymbolChar ch -> + nextWhile isSymbolChar >>= \chs -> + peek >>= \case + Just ')' + | isReservedSymbol chs -> throw ErrReservedSymbol + | otherwise -> next $> TokSymbolName qual chs + Just ch2 -> throw $ ErrLexeme (Just [ch2]) [] + Nothing -> throw ErrEof + Just ch -> throw $ ErrLexeme (Just [ch]) [] + Nothing -> throw ErrEof + + {- + operator + : symbolChar+ + -} + operator :: [Text] -> [Char] -> Lexer Token + operator qual pre = do + rest <- nextWhile isSymbolChar + pure . TokOperator (reverse qual) $ Text.pack pre <> rest + + {- + moduleName + : upperChar alphaNumChar* + + qualifier + : (moduleName '.')* moduleName + + upper + : (qualifier '.')? upperChar identChar* + | qualifier '.' lowerQualified + | qualifier '.' operator + | qualifier '.' symbol + -} + upper :: [Text] -> Char -> Lexer Token + upper qual pre = do + rest <- nextWhile isIdentChar + ch1 <- peek + let name = Text.cons pre rest + case ch1 of + Just '.' -> do + let qual' = name : qual + next *> peek >>= \case + Just '(' -> next *> symbol qual' + Just ch2 + | Char.isUpper ch2 -> next *> upper qual' ch2 + | isIdentStart ch2 -> next *> lower qual' ch2 + | isSymbolChar ch2 -> next *> operator qual' [ch2] + | otherwise -> throw $ ErrLexeme (Just [ch2]) [] + Nothing -> + throw ErrEof + _ -> + pure $ TokUpperName (reverse qual) name + + {- + lower + : '_' + | 'forall' + | lowerChar identChar* + + lowerQualified + : lowerChar identChar* + -} + lower :: [Text] -> Char -> Lexer Token + lower qual pre = do + rest <- nextWhile isIdentChar + case pre of + '_' | Text.null rest -> + if null qual + then pure TokUnderscore + else throw $ ErrLexeme (Just [pre]) [] + _ -> + case Text.cons pre rest of + "forall" | null qual -> pure $ TokForall ASCII + name -> pure $ TokLowerName (reverse qual) name + + {- + hole + : '?' identChar+ + -} + hole :: Lexer Token + hole = do + name <- nextWhile isIdentChar + if Text.null name + then operator [] ['?'] + else pure $ TokHole name + + {- + char + : "'" '\' escape "'" + | "'" [^'] "'" + -} + char :: Lexer Token + char = do + (raw, ch) <- peek >>= \case + Just '\\' -> do + (raw, ch2) <- next *> escape + pure (Text.cons '\\' raw, ch2) + Just ch -> + next $> (Text.singleton ch, ch) + Nothing -> + throw $ ErrEof + peek >>= \case + Just '\'' + | fromEnum ch > 0xFFFF -> throw ErrAstralCodePointInChar + | otherwise -> next $> TokChar raw ch + Just ch2 -> + throw $ ErrLexeme (Just [ch2]) [] + _ -> + throw $ ErrEof + + {- + stringPart + : '\' escape + | '\' [ \r\n]+ '\' + | [^"] + + string + : '"' stringPart* '"' + | '"""' .* '"""' + + This assumes maximal munch for quotes. A raw string literal can end with + any number of quotes, where the last 3 are considered the closing + delimiter. + -} + string :: Lexer Token + string = do + quotes1 <- nextWhile (== '"') + case Text.length quotes1 of + 0 -> do + let + go raw acc = do + chs <- nextWhile isNormalStringChar + let + raw' = raw <> chs + acc' = acc <> DList.fromList (Text.unpack chs) + peek >>= \case + Just '"' -> next $> TokString raw' (fromString (DList.toList acc')) + Just '\\' -> next *> goEscape (raw' <> "\\") acc' + Just _ -> throw ErrLineFeedInString + Nothing -> throw ErrEof + + goEscape raw acc = do + mbCh <- peek + case mbCh of + Just ch1 | isStringGapChar ch1 -> do + gap <- nextWhile isStringGapChar + peek >>= \case + Just '"' -> next $> TokString (raw <> gap) (fromString (DList.toList acc)) + Just '\\' -> next *> go (raw <> gap <> "\\") acc + Just ch -> throw $ ErrCharInGap ch + Nothing -> throw ErrEof + _ -> do + (raw', ch) <- escape + go (raw <> raw') (acc <> DList.singleton ch) + go "" mempty + 1 -> + pure $ TokString "" "" + n | n >= 5 -> do + let str = Text.take 5 quotes1 + pure $ TokString str (fromString (Text.unpack str)) + _ -> do + let + go acc = do + chs <- nextWhile (/= '"') + quotes2 <- nextWhile (== '"') + case Text.length quotes2 of + 0 -> throw ErrEof + n | n >= 3 -> pure $ TokRawString $ acc <> chs <> Text.drop 3 quotes2 + _ -> go (acc <> chs <> quotes2) + go "" + + {- + escape + : 't' + | 'r' + | 'n' + | "'" + | '"' + | 'x' [0-9a-fA-F]{0,6} + -} + escape :: Lexer (Text, Char) + escape = do + ch <- peek + case ch of + Just 't' -> next $> ("\t", '\t') + Just 'r' -> next $> ("\\r", '\r') + Just 'n' -> next $> ("\\n", '\n') + Just '"' -> next $> ("\"", '"') + Just '\'' -> next $> ("'", '\'') + Just '\\' -> next $> ("\\", '\\') + Just 'x' -> (*>) next $ Parser $ \inp kerr ksucc -> do + let + go n acc (ch' : chs) + | Char.isHexDigit ch' = go (n * 16 + Char.digitToInt ch') (ch' : acc) chs + go n acc _ + | n <= 0x10FFFF = + ksucc (Text.drop (length acc) inp) + (Text.pack $ reverse acc, Char.chr n) + | otherwise = + kerr inp ErrCharEscape -- TODO + go 0 [] $ Text.unpack $ Text.take 6 inp + _ -> throw ErrCharEscape + + {- + number + : hexadecimal + | integer ('.' fraction)? exponent? + -} + number :: Char -> Lexer Token + number ch1 = peek >>= \ch2 -> case (ch1, ch2) of + ('0', Just 'x') -> next *> hexadecimal + (_, _) -> do + mbInt <- integer1 ch1 + mbFraction <- fraction + case (mbInt, mbFraction) of + (Just (raw, int), Nothing) -> do + let int' = digitsToInteger int + exponent >>= \case + Just (raw', exp) -> + sciDouble (raw <> raw') $ Sci.scientific int' exp + Nothing -> + pure $ TokInt raw int' + (Just (raw, int), Just (raw', frac)) -> do + let sci = digitsToScientific int frac + exponent >>= \case + Just (raw'', exp) -> + sciDouble (raw <> raw' <> raw'') $ uncurry Sci.scientific $ (+ exp) <$> sci + Nothing -> + sciDouble (raw <> raw') $ uncurry Sci.scientific sci + (Nothing, Just (raw, frac)) -> do + let sci = digitsToScientific [] frac + exponent >>= \case + Just (raw', exp) -> + sciDouble (raw <> raw') $ uncurry Sci.scientific $ (+ exp) <$> sci + Nothing -> + sciDouble raw $ uncurry Sci.scientific sci + (Nothing, Nothing) -> + peek >>= \ch -> throw $ ErrLexeme (pure <$> ch) [] + + sciDouble :: Text -> Sci.Scientific -> Lexer Token + sciDouble raw sci = case Sci.toBoundedRealFloat sci of + Left _ -> throw ErrNumberOutOfRange + Right n -> pure $ TokNumber raw n + + {- + integer + : '0' + | [1-9] digits + -} + integer :: Lexer (Maybe (Text, String)) + integer = peek >>= \case + Just '0' -> next *> peek >>= \case + Just ch | isNumberChar ch -> throw ErrLeadingZero + _ -> pure $ Just ("0", "0") + Just ch | isDigitChar ch -> Just <$> digits + _ -> pure $ Nothing + + {- + integer1 + : '0' + | [1-9] digits + + This is the same as 'integer', the only difference is that this expects the + first char to be consumed during dispatch. + -} + integer1 :: Char -> Lexer (Maybe (Text, String)) + integer1 = \case + '0' -> peek >>= \case + Just ch | isNumberChar ch -> throw ErrLeadingZero + _ -> pure $ Just ("0", "0") + ch | isDigitChar ch -> do + (raw, chs) <- digits + pure $ Just (Text.cons ch raw, ch : chs) + _ -> pure $ Nothing + + {- + fraction + : '.' [0-9_]+ + -} + fraction :: Lexer (Maybe (Text, String)) + fraction = Parser $ \inp _ ksucc -> + -- We need more than a single char lookahead for things like `1..10`. + case Text.uncons inp of + Just ('.', inp') + | (raw, inp'') <- Text.span isNumberChar inp' + , not (Text.null raw) -> + ksucc inp'' $ Just ("." <> raw, filter (/= '_') $ Text.unpack raw) + _ -> + ksucc inp Nothing + + {- + digits + : [0-9_]* + + Digits can contain underscores, which are ignored. + -} + digits :: Lexer (Text, String) + digits = do + raw <- nextWhile isNumberChar + pure (raw, filter (/= '_') $ Text.unpack raw) + + {- + exponent + : 'e' ('+' | '-')? integer + -} + exponent :: Lexer (Maybe (Text, Int)) + exponent = peek >>= \case + Just 'e' -> do + (neg, sign) <- next *> peek >>= \case + Just '-' -> next $> (True, "-") + Just '+' -> next $> (False, "+") + _ -> pure (False, "") + integer >>= \case + Just (raw, chs) -> do + let + int | neg = negate $ digitsToInteger chs + | otherwise = digitsToInteger chs + pure $ Just ("e" <> sign <> raw, fromInteger int) + Nothing -> throw ErrExpectedExponent + _ -> + pure Nothing + + {- + hexadecimal + : '0x' [0-9a-fA-F]+ + -} + hexadecimal :: Lexer Token + hexadecimal = do + chs <- nextWhile Char.isHexDigit + if Text.null chs + then throw ErrExpectedHex + else pure $ TokInt ("0x" <> chs) $ digitsToIntegerBase 16 $ Text.unpack chs + +digitsToInteger :: [Char] -> Integer +digitsToInteger = digitsToIntegerBase 10 + +digitsToIntegerBase :: Integer -> [Char] -> Integer +digitsToIntegerBase b = foldl' (\n c -> n * b + (toInteger (Char.digitToInt c))) 0 + +digitsToScientific :: [Char] -> [Char] -> (Integer, Int) +digitsToScientific = go 0 . reverse + where + go !exp is [] = (digitsToInteger (reverse is), exp) + go !exp is (f : fs) = go (exp - 1) (f : is) fs + +isSymbolChar :: Char -> Bool +isSymbolChar c = (c `elem` (":!#$%&*+./<=>?@\\^|-~" :: [Char])) || (not (Char.isAscii c) && Char.isSymbol c) + +isReservedSymbolError :: ParserErrorType -> Bool +isReservedSymbolError = (== ErrReservedSymbol) + +isReservedSymbol :: Text -> Bool +isReservedSymbol = flip elem symbols + where + symbols = + [ "::" + , "∷" + , "<-" + , "←" + , "->" + , "→" + , "=>" + , "⇒" + , "∀" + , "|" + , "." + , "\\" + , "=" + ] + +isIdentStart :: Char -> Bool +isIdentStart c = Char.isLower c || c == '_' + +isIdentChar :: Char -> Bool +isIdentChar c = Char.isAlphaNum c || c == '_' || c == '\'' + +isDigitChar :: Char -> Bool +isDigitChar c = c >= '0' && c <= '9' + +isNumberChar :: Char -> Bool +isNumberChar c = (c >= '0' && c <= '9') || c == '_' + +isNormalStringChar :: Char -> Bool +isNormalStringChar c = c /= '"' && c /= '\\' && c /= '\r' && c /= '\n' + +isStringGapChar :: Char -> Bool +isStringGapChar c = c == ' ' || c == '\r' || c == '\n' + +isLineFeed :: Char -> Bool +isLineFeed c = c == '\r' || c == '\n' diff --git a/src/Language/PureScript/CST/Monad.hs b/src/Language/PureScript/CST/Monad.hs new file mode 100644 index 0000000000..49da019cad --- /dev/null +++ b/src/Language/PureScript/CST/Monad.hs @@ -0,0 +1,123 @@ +module Language.PureScript.CST.Monad where + +import Prelude + +import Data.List (sortBy) +import qualified Data.List.NonEmpty as NE +import Data.Ord (comparing) +import Data.Text (Text) +import Language.PureScript.CST.Errors +import Language.PureScript.CST.Layout +import Language.PureScript.CST.Positions +import Language.PureScript.CST.Types + +type LexResult = Either (LexState, ParserError) SourceToken + +data LexState = LexState + { lexPos :: SourcePos + , lexLeading :: [Comment LineFeed] + , lexSource :: Text + , lexStack :: LayoutStack + } deriving (Show) + +data ParserState = ParserState + { parserBuff :: [LexResult] + , parserErrors :: [ParserError] + } deriving (Show) + +-- | A bare bones, CPS'ed `StateT s (Except e) a`. +newtype ParserM e s a = + Parser (forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r) + +type Parser = ParserM ParserError ParserState + +instance Functor (ParserM e s) where + {-# INLINE fmap #-} + fmap f (Parser k) = + Parser $ \st kerr ksucc -> + k st kerr (\st' a -> ksucc st' (f a)) + +instance Applicative (ParserM e s) where + {-# INLINE pure #-} + pure a = Parser $ \st _ k -> k st a + {-# INLINE (<*>) #-} + Parser k1 <*> Parser k2 = + Parser $ \st kerr ksucc -> + k1 st kerr $ \st' f -> + k2 st' kerr $ \st'' a -> + ksucc st'' (f a) + +instance Monad (ParserM e s) where + {-# INLINE return #-} + return = pure + {-# INLINE (>>=) #-} + Parser k1 >>= k2 = + Parser $ \st kerr ksucc -> + k1 st kerr $ \st' a -> do + let Parser k3 = k2 a + k3 st' kerr ksucc + +runParser :: ParserState -> Parser a -> (ParserState, Either (NE.NonEmpty ParserError) a) +runParser st (Parser k) = k st left right + where + left st'@(ParserState {..}) err = + (st', Left $ NE.sortBy (comparing errRange) $ err NE.:| parserErrors) + + right st'@(ParserState {..}) res + | null parserErrors = (st', Right res) + | otherwise = (st', Left $ NE.fromList $ sortBy (comparing errRange) parserErrors) + +{-# INLINE throw #-} +throw :: e -> ParserM e s a +throw e = Parser $ \st kerr _ -> kerr st e + +parseError :: SourceToken -> Parser a +parseError tok = Parser $ \st kerr _ -> + kerr st $ ParserError + { errRange = tokRange . tokAnn $ tok + , errToks = [tok] + , errStack = [] -- TODO parserStack st + , errType = ErrToken + } + +mkParserError :: LayoutStack -> [SourceToken] -> ParserErrorType -> ParserError +mkParserError stack toks ty = + ParserError + { errRange = range + , errToks = toks + , errStack = stack + , errType = ty + } + where + range = case toks of + [] -> SourceRange (SourcePos 0 0) (SourcePos 0 0) + _ -> widen (tokRange . tokAnn $ head toks) (tokRange . tokAnn $ last toks) + +addFailure :: [SourceToken] -> ParserErrorType -> Parser () +addFailure toks ty = Parser $ \st _ ksucc -> + ksucc (st { parserErrors = mkParserError [] toks ty : parserErrors st }) () + +addFailures :: [ParserError] -> Parser () +addFailures errs = Parser $ \st _ ksucc -> + ksucc (st { parserErrors = errs <> parserErrors st }) () + +parseFail' :: [SourceToken] -> ParserErrorType -> Parser a +parseFail' toks msg = Parser $ \st kerr _ -> kerr st (mkParserError [] toks msg) + +parseFail :: SourceToken -> ParserErrorType -> Parser a +parseFail = parseFail' . pure + +pushBack :: SourceToken -> Parser () +pushBack tok = Parser $ \st _ ksucc -> + ksucc (st { parserBuff = Right tok : parserBuff st }) () + +{-# INLINE tryPrefix #-} +tryPrefix :: Parser a -> Parser b -> Parser (Maybe a, b) +tryPrefix (Parser lhs) rhs = Parser $ \st kerr ksucc -> + lhs st + (\_ _ -> do + let Parser k = (Nothing,) <$> rhs + k st kerr ksucc) + (\st' res -> do + let Parser k = (Just res,) <$> rhs + k st' kerr ksucc) diff --git a/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y new file mode 100644 index 0000000000..6cea62c6ab --- /dev/null +++ b/src/Language/PureScript/CST/Parser.y @@ -0,0 +1,746 @@ +{ +module Language.PureScript.CST.Parser + ( parseType + , parseKind + , parseExpr + , parseModule + , parse + , PartialResult(..) + ) where + +import Prelude hiding (lex) + +import Control.Monad ((>=>), when) +import Data.Foldable (foldl', for_) +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import Data.Traversable (for) +import Language.PureScript.CST.Errors +import Language.PureScript.CST.Lexer +import Language.PureScript.CST.Monad +import Language.PureScript.CST.Positions +import Language.PureScript.CST.Types +import Language.PureScript.CST.Utils +import qualified Language.PureScript.Names as N +import Language.PureScript.PSString (PSString) +} + +%expect 98 + +%name parseKind kind +%name parseType type +%name parseExpr expr +%name parseModuleBody moduleBody +%partial parseModuleHeader moduleHeader +%partial parseDoStatement doStatement +%partial parseDoExpr doExpr +%partial parseDoNext doNext +%partial parseGuardExpr guardExpr +%partial parseGuardNext guardNext +%partial parseGuardStatement guardStatement +%partial parseClassSuper classSuper +%partial parseClassNameAndFundeps classNameAndFundeps +%partial parseBinderAndArrow binderAndArrow +%tokentype { SourceToken } +%monad { Parser } +%error { parseError } +%lexer { lexer } { SourceToken _ TokEof } + +%token + '(' { SourceToken _ TokLeftParen } + ')' { SourceToken _ TokRightParen } + '{' { SourceToken _ TokLeftBrace } + '}' { SourceToken _ TokRightBrace } + '[' { SourceToken _ TokLeftSquare } + ']' { SourceToken _ TokRightSquare } + '\{' { SourceToken _ TokLayoutStart } + '\}' { SourceToken _ TokLayoutEnd } + '\;' { SourceToken _ TokLayoutSep } + '<-' { SourceToken _ (TokLeftArrow _) } + '->' { SourceToken _ (TokRightArrow _) } + '<=' { SourceToken _ (TokOperator [] sym) | sym == "<=" || sym == "⇐" } + '=>' { SourceToken _ (TokRightFatArrow _) } + ':' { SourceToken _ (TokOperator [] ":") } + '::' { SourceToken _ (TokDoubleColon _) } + '=' { SourceToken _ TokEquals } + '|' { SourceToken _ TokPipe } + '`' { SourceToken _ TokTick } + '.' { SourceToken _ TokDot } + ',' { SourceToken _ TokComma } + '_' { SourceToken _ TokUnderscore } + '\\' { SourceToken _ TokBackslash } + '-' { SourceToken _ (TokOperator [] "-") } + '@' { SourceToken _ (TokOperator [] "@") } + '#' { SourceToken _ (TokOperator [] "#") } + 'ado' { SourceToken _ (TokLowerName _ "ado") } + 'as' { SourceToken _ (TokLowerName [] "as") } + 'case' { SourceToken _ (TokLowerName [] "case") } + 'class' { SourceToken _ (TokLowerName [] "class") } + 'data' { SourceToken _ (TokLowerName [] "data") } + 'derive' { SourceToken _ (TokLowerName [] "derive") } + 'do' { SourceToken _ (TokLowerName _ "do") } + 'else' { SourceToken _ (TokLowerName [] "else") } + 'false' { SourceToken _ (TokLowerName [] "false") } + 'forall' { SourceToken _ (TokForall ASCII) } + 'forallu' { SourceToken _ (TokForall Unicode) } + 'foreign' { SourceToken _ (TokLowerName [] "foreign") } + 'hiding' { SourceToken _ (TokLowerName [] "hiding") } + 'import' { SourceToken _ (TokLowerName [] "import") } + 'if' { SourceToken _ (TokLowerName [] "if") } + 'in' { SourceToken _ (TokLowerName [] "in") } + 'infix' { SourceToken _ (TokLowerName [] "infix") } + 'infixl' { SourceToken _ (TokLowerName [] "infixl") } + 'infixr' { SourceToken _ (TokLowerName [] "infixr") } + 'instance' { SourceToken _ (TokLowerName [] "instance") } + 'kind' { SourceToken _ (TokLowerName [] "kind") } + 'let' { SourceToken _ (TokLowerName [] "let") } + 'module' { SourceToken _ (TokLowerName [] "module") } + 'newtype' { SourceToken _ (TokLowerName [] "newtype") } + 'of' { SourceToken _ (TokLowerName [] "of") } + 'then' { SourceToken _ (TokLowerName [] "then") } + 'true' { SourceToken _ (TokLowerName [] "true") } + 'type' { SourceToken _ (TokLowerName [] "type") } + 'where' { SourceToken _ (TokLowerName [] "where") } + '(->)' { SourceToken _ (TokSymbolArr _) } + '(..)' { SourceToken _ (TokSymbolName [] "..") } + LOWER { SourceToken _ (TokLowerName [] _) } + QUAL_LOWER { SourceToken _ (TokLowerName _ _) } + UPPER { SourceToken _ (TokUpperName [] _) } + QUAL_UPPER { SourceToken _ (TokUpperName _ _) } + SYMBOL { SourceToken _ (TokSymbolName [] _) } + QUAL_SYMBOL { SourceToken _ (TokSymbolName _ _) } + OPERATOR { SourceToken _ (TokOperator [] _) } + QUAL_OPERATOR { SourceToken _ (TokOperator _ _) } + LIT_HOLE { SourceToken _ (TokHole _) } + LIT_CHAR { SourceToken _ (TokChar _ _) } + LIT_STRING { SourceToken _ (TokString _ _) } + LIT_RAW_STRING { SourceToken _ (TokRawString _) } + LIT_INT { SourceToken _ (TokInt _ _) } + LIT_NUMBER { SourceToken _ (TokNumber _ _) } + +%% + +many(a) :: { NE.NonEmpty _ } + : many1(a) { NE.reverse $1 } + +many1(a) :: { NE.NonEmpty _ } + : a { pure $1 } + | many1(a) a { NE.cons $2 $1 } + +manySep(a, sep) :: { NE.NonEmpty _ } + : manySep1(a, sep) { NE.reverse $1 } + +manySep1(a, sep) :: { NE.NonEmpty _ } + : a { pure $1 } + | manySep1(a, sep) sep a { NE.cons $3 $1 } + +manySepOrEmpty(a, sep) :: { [_] } + : {- empty -} { [] } + | manySep(a, sep) { NE.toList $1 } + +manyOrEmpty(a) :: { [_] } + : {- empty -} { [] } + | many(a) { NE.toList $1 } + +sep(a, s) :: { Separated _ } + : sep1(a, s) { separated $1 } + +sep1(a, s) :: { [(SourceToken, _)] } + : a { [(placeholder, $1)] } + | sep1(a, s) s a { ($2, $3) : $1 } + +delim(a, b, c, d) :: { Delimited _ } + : a d { Wrapped $1 Nothing $2 } + | a sep(b, c) d { Wrapped $1 (Just $2) $3 } + +moduleName :: { Name N.ModuleName } + : UPPER {% upperToModuleName $1 } + | QUAL_UPPER {% upperToModuleName $1 } + +qualProperName :: { QualifiedName (N.ProperName a) } + : UPPER {% toQualifiedName N.ProperName $1 } + | QUAL_UPPER {% toQualifiedName N.ProperName $1 } + +properName :: { Name (N.ProperName a) } + : UPPER {% toName N.ProperName $1 } + +qualIdent :: { QualifiedName Ident } + : LOWER {% toQualifiedName Ident $1 } + | QUAL_LOWER {% toQualifiedName Ident $1 } + | 'as' {% toQualifiedName Ident $1 } + | 'hiding' {% toQualifiedName Ident $1 } + | 'kind' {% toQualifiedName Ident $1 } + +ident :: { Name Ident } + : LOWER {% toName Ident $1 } + | 'as' {% toName Ident $1 } + | 'hiding' {% toName Ident $1 } + | 'kind' {% toName Ident $1 } + +qualOp :: { QualifiedName (N.OpName a) } + : OPERATOR {% toQualifiedName N.OpName $1 } + | QUAL_OPERATOR {% toQualifiedName N.OpName $1 } + | '<=' {% toQualifiedName N.OpName $1 } + | '-' {% toQualifiedName N.OpName $1 } + | '#' {% toQualifiedName N.OpName $1 } + | ':' {% toQualifiedName N.OpName $1 } + +op :: { Name (N.OpName a) } + : OPERATOR {% toName N.OpName $1 } + | '<=' {% toName N.OpName $1 } + | '-' {% toName N.OpName $1 } + | '#' {% toName N.OpName $1 } + | ':' {% toName N.OpName $1 } + +qualSymbol :: { QualifiedName (N.OpName a) } + : SYMBOL {% toQualifiedName N.OpName $1 } + | QUAL_SYMBOL {% toQualifiedName N.OpName $1 } + | '(..)' {% toQualifiedName N.OpName $1 } + +symbol :: { Name (N.OpName a) } + : SYMBOL {% toName N.OpName $1 } + | '(..)' {% toName N.OpName $1 } + +label :: { Label } + : LOWER { toLabel $1 } + | LIT_STRING { toLabel $1 } + | LIT_RAW_STRING { toLabel $1 } + | 'ado' { toLabel $1 } + | 'as' { toLabel $1 } + | 'case' { toLabel $1 } + | 'class' { toLabel $1 } + | 'data' { toLabel $1 } + | 'derive' { toLabel $1 } + | 'do' { toLabel $1 } + | 'else' { toLabel $1 } + | 'false' { toLabel $1 } + | 'forall' { toLabel $1 } + | 'foreign' { toLabel $1 } + | 'hiding' { toLabel $1 } + | 'import' { toLabel $1 } + | 'if' { toLabel $1 } + | 'in' { toLabel $1 } + | 'infix' { toLabel $1 } + | 'infixl' { toLabel $1 } + | 'infixr' { toLabel $1 } + | 'instance' { toLabel $1 } + | 'kind' { toLabel $1 } + | 'let' { toLabel $1 } + | 'module' { toLabel $1 } + | 'newtype' { toLabel $1 } + | 'of' { toLabel $1 } + | 'then' { toLabel $1 } + | 'true' { toLabel $1 } + | 'type' { toLabel $1 } + | 'where' { toLabel $1 } + +hole :: { Name Ident } + : LIT_HOLE {% toName Ident $1 } + +string :: { (SourceToken, PSString) } + : LIT_STRING { toString $1 } + | LIT_RAW_STRING { toString $1 } + +char :: { (SourceToken, Char) } + : LIT_CHAR { toChar $1 } + +number :: { (SourceToken, Either Integer Double) } + : LIT_INT { toNumber $1 } + | LIT_NUMBER { toNumber $1 } + +int :: { (SourceToken, Integer) } + : LIT_INT { toInt $1 } + +boolean :: { (SourceToken, Bool) } + : 'true' { toBoolean $1 } + | 'false' { toBoolean $1 } + +kind :: { Kind () } + : kind1 { $1 } + | kind1 '->' kind { KindArr () $1 $2 $3 } + +kind1 :: { Kind () } + : qualProperName { KindName () $1 } + | '#' kind1 { KindRow () $1 $2 } + | '(' kind ')' { KindParens () (Wrapped $1 $2 $3) } + +type :: { Type () } + : type1 { $1 } + | type1 '::' kind { TypeKinded () $1 $2 $3 } + +type1 :: { Type () } + : type2 { $1 } + | forall many(typeVarBinding) '.' type1 { TypeForall () $1 $2 $3 $4 } + +type2 :: { Type () } + : type3 { $1 } + | type3 '->' type1 { TypeArr () $1 $2 $3 } + | type3 '=>' type1 {% do cs <- toConstraint $1; pure $ TypeConstrained () cs $2 $3 } + +type3 :: { Type () } + : type4 { $1 } + | type3 qualOp type4 { TypeOp () $1 $2 $3 } + +type4 :: { Type () } + : typeAtom { $1 } + | type4 typeAtom { TypeApp () $1 $2 } + +typeAtom :: { Type ()} + : '_' { TypeWildcard () $1 } + | ident { TypeVar () $1 } + | qualProperName { TypeConstructor () $1 } + | qualSymbol { TypeOpName () $1 } + | string { uncurry (TypeString ()) $1 } + | hole { TypeHole () $1 } + | '(->)' { TypeArrName () $1 } + | '{' row '}' { TypeRecord () (Wrapped $1 $2 $3) } + | '(' row ')' { TypeRow () (Wrapped $1 $2 $3) } + | '(' type1 ')' { TypeParens () (Wrapped $1 $2 $3) } + | '(' typeKindedAtom '::' kind ')' { TypeParens () (Wrapped $1 (TypeKinded () $2 $3 $4) $5) } + +-- Due to a conflict between row syntax and kinded type syntax, we require +-- kinded type variables to be wrapped in parens. Thus `(a :: Foo)` is always a +-- row, and to annotate `a` with kind `Foo`, one must use `((a) :: Foo)`. +typeKindedAtom :: { Type () } + : '_' { TypeWildcard () $1 } + | qualProperName { TypeConstructor () $1 } + | qualSymbol { TypeOpName () $1 } + | hole { TypeHole () $1 } + | '{' row '}' { TypeRecord () (Wrapped $1 $2 $3) } + | '(' row ')' { TypeRow () (Wrapped $1 $2 $3) } + | '(' type1 ')' { TypeParens () (Wrapped $1 $2 $3) } + | '(' typeKindedAtom '::' kind ')' { TypeParens () (Wrapped $1 (TypeKinded () $2 $3 $4) $5) } + +row :: { Row () } + : {- empty -} { Row Nothing Nothing } + | '|' type { Row Nothing (Just ($1, $2)) } + | sep(rowLabel, ',') { Row (Just $1) Nothing } + | sep(rowLabel, ',') '|' type { Row (Just $1) (Just ($2, $3)) } + +rowLabel :: { Labeled Label (Type ()) } + : label '::' type { Labeled $1 $2 $3 } + +typeVarBinding :: { TypeVarBinding () } + : ident { TypeVarName $1 } + | '(' ident '::' kind ')' { TypeVarKinded (Wrapped $1 (Labeled $2 $3 $4) $5) } + +forall :: { SourceToken } + : 'forall' { $1 } + | 'forallu' { $1 } + +exprWhere :: { Where () } + : expr { Where $1 Nothing } + | expr 'where' '\{' manySep(letBinding, '\;') '\}' { Where $1 (Just ($2, $4)) } + +expr :: { Expr () } + : expr1 { $1 } + | expr1 '::' type { ExprTyped () $1 $2 $3 } + +expr1 :: { Expr () } + : expr2 { $1 } + | expr1 qualOp expr2 { ExprOp () $1 $2 $3 } + +expr2 :: { Expr () } + : expr3 { $1 } + | expr2 '`' exprBacktick '`' expr3 { ExprInfix () $1 (Wrapped $2 $3 $4) $5 } + +exprBacktick :: { Expr () } + : expr3 { $1 } + | exprBacktick qualOp expr3 { ExprOp () $1 $2 $3 } + +expr3 :: { Expr () } + : expr4 { $1 } + | '-' expr3 { ExprNegate () $1 $2 } + +expr4 :: { Expr () } + : expr5 { $1 } + | expr4 expr5 + { -- Record application/updates can introduce a function application + -- associated to the right, so we need to correct it. + case $2 of + ExprApp _ lhs rhs -> + ExprApp () (ExprApp () $1 lhs) rhs + _ -> ExprApp () $1 $2 + } + +expr5 :: { Expr () } + : expr6 { $1 } + | 'if' expr 'then' expr 'else' expr { ExprIf () (IfThenElse $1 $2 $3 $4 $5 $6) } + | doBlock { ExprDo () $1 } + | adoBlock 'in' expr { ExprAdo () $ uncurry AdoBlock $1 $2 $3 } + | '\\' many(binderAtom) '->' expr { ExprLambda () (Lambda $1 $2 $3 $4) } + | 'let' '\{' manySep(letBinding, '\;') '\}' 'in' expr { ExprLet () (LetIn $1 $3 $5 $6) } + | 'case' sep(expr, ',') 'of' '\{' manySep(caseBranch, '\;') '\}' { ExprCase () (CaseOf $1 $2 $3 $5) } + -- These special cases handle some idiosynchratic syntax that the current + -- parser allows. Technically the parser allows the rhs of a case branch to be + -- at any level, but this is ambiguous. We allow it in the case of a singleton + -- case, since this is used in the wild. + | 'case' sep(expr, ',') 'of' '\{' sep(binder1, ',') '->' '\}' exprWhere + { ExprCase () (CaseOf $1 $2 $3 (pure ($5, Unconditional $6 $8))) } + | 'case' sep(expr, ',') 'of' '\{' sep(binder1, ',') '\}' guarded('->') + { ExprCase () (CaseOf $1 $2 $3 (pure ($5, $7))) } + +expr6 :: { Expr () } + : expr7 { $1 } + | expr7 '{' '}' { ExprApp () $1 (ExprRecord () (Wrapped $2 Nothing $3)) } + | expr7 '{' sep(recordUpdateOrLabel, ',') '}' + {% toRecordFields $3 >>= \case + Left xs -> pure $ ExprApp () $1 (ExprRecord () (Wrapped $2 (Just xs) $4)) + Right xs -> pure $ ExprRecordUpdate () $1 (Wrapped $2 xs $4) + } + +expr7 :: { Expr () } + : exprAtom { $1 } + | exprAtom '.' sep(label, '.') { ExprRecordAccessor () (RecordAccessor $1 $2 $3) } + +exprAtom :: { Expr () } + : '_' { ExprSection () $1 } + | hole { ExprHole () $1 } + | qualIdent { ExprIdent () $1 } + | qualProperName { ExprConstructor () $1 } + | qualSymbol { ExprOpName () $1 } + | boolean { uncurry (ExprBoolean ()) $1 } + | char { uncurry (ExprChar ()) $1 } + | string { uncurry (ExprString ()) $1 } + | number { uncurry (ExprNumber ()) $1 } + | delim('[', expr, ',', ']') { ExprArray () $1 } + | delim('{', recordLabel, ',', '}') { ExprRecord () $1 } + | '(' expr ')' { ExprParens () (Wrapped $1 $2 $3) } + +recordLabel :: { RecordLabeled (Expr ()) } + : label {% fmap RecordPun . toName Ident $ lblTok $1 } + | label '=' expr {% addFailure [$2] ErrRecordUpdateInCtr *> pure (RecordPun $ unexpectedName $ lblTok $1) } + | label ':' expr { RecordField $1 $2 $3 } + +recordUpdateOrLabel :: { Either (RecordLabeled (Expr ())) (RecordUpdate ()) } + : label ':' expr { Left (RecordField $1 $2 $3) } + | label {% fmap (Left . RecordPun) . toName Ident $ lblTok $1 } + | label '=' expr { Right (RecordUpdateLeaf $1 $2 $3) } + | label '{' sep(recordUpdate, ',') '}' { Right (RecordUpdateBranch $1 (Wrapped $2 $3 $4)) } + +recordUpdate :: { RecordUpdate () } + : label '=' expr { RecordUpdateLeaf $1 $2 $3 } + | label '{' sep(recordUpdate, ',') '}' { RecordUpdateBranch $1 (Wrapped $2 $3 $4) } + +letBinding :: { LetBinding () } + : ident '::' type { LetBindingSignature () (Labeled $1 $2 $3) } + | ident guarded('=') { LetBindingName () (ValueBindingFields $1 [] $2) } + | ident many(binderAtom) guarded('=') { LetBindingName () (ValueBindingFields $1 (NE.toList $2) $3) } + | binder1 '=' exprWhere { LetBindingPattern () $1 $2 $3 } + +caseBranch :: { (Separated (Binder ()), Guarded ()) } + : sep(binder1, ',') guarded('->') { ($1, $2) } + +guarded(a) :: { Guarded () } + : a exprWhere { Unconditional $1 $2 } + | many(guardedExpr(a)) { Guarded $1 } + +guardedExpr(a) :: { GuardedExpr () } + : guard a exprWhere { uncurry GuardedExpr $1 $2 $3 } + +-- Do/Ado statements and pattern guards require unbounded lookahead due to many +-- conflicts between `binder` and `expr` syntax. For example `Foo a b c` can +-- either be a constructor `binder` or several `expr` applications, and we won't +-- know until we see a `<-` or layout separator. +-- +-- One way to resolve this would be to parse a `binder` as an `expr` and then +-- reassociate it after the fact. However this means we can't use the `binder` +-- productions to parse it, so we'd have to maintain an ad-hoc handwritten +-- parser which is very difficult to audit. +-- +-- As an alternative we introduce some backtracking. Using %partial parsers and +-- monadic reductions, we can invoke productions manually and use the +-- backtracking `tryPrefix` combinator. Binders are generally very short in +-- comparison to expressions, so the cost is modest. +-- +-- doBlock +-- : 'do' '\{' manySep(doStatement, '\;') '\}' +-- +-- doStatement +-- : 'let' '\{' manySep(letBinding, '\;') '\}' +-- | expr +-- | binder '<-' expr +-- +-- guard +-- : '|' sep(patternGuard, ',') +-- +-- patternGuard +-- : expr1 +-- | binder '<-' expr1 +-- +doBlock :: { DoBlock () } + : 'do' '\{' + {%% revert $ do + res <- parseDoStatement + when (null res) $ addFailure [$2] ErrEmptyDo + pure $ DoBlock $1 $ NE.fromList res + } + +adoBlock :: { (SourceToken, [DoStatement ()]) } + : 'ado' '\{' '\}' { ($1, []) } + | 'ado' '\{' + {%% revert $ fmap ($1,) parseDoStatement } + +doStatement :: { [DoStatement ()] } + : 'let' '\{' manySep(letBinding, '\;') '\}' + {%^ revert $ fmap (DoLet $1 $3 :) parseDoNext } + | {- empty -} + {%^ revert $ do + stmt <- tryPrefix parseBinderAndArrow parseDoExpr + let + ctr = case stmt of + (Just (binder, sep), expr) -> + (DoBind binder sep expr :) + (Nothing, expr) -> + (DoDiscard expr :) + fmap ctr parseDoNext + } + +doExpr :: { Expr () } + : expr {%^ revert $ pure $1 } + +doNext :: { [DoStatement ()] } + : '\;' {%^ revert parseDoStatement } + | '\}' {%^ revert $ pure [] } + +guard :: { (SourceToken, Separated (PatternGuard ())) } + : '|' {%% revert $ fmap (($1,) . uncurry Separated) parseGuardStatement } + +guardStatement :: { (PatternGuard (), [(SourceToken, PatternGuard ())]) } + : {- empty -} + {%^ revert $ do + grd <- fmap (uncurry PatternGuard) $ tryPrefix parseBinderAndArrow parseGuardExpr + fmap (grd,) parseGuardNext + } + +guardExpr :: { Expr() } + : expr1 {%^ revert $ pure $1 } + +guardNext :: { [(SourceToken, PatternGuard ())] } + : ',' {%^ revert $ fmap (\(g, gs) -> ($1, g) : gs) parseGuardStatement } + | {- empty -} {%^ revert $ pure [] } + +binderAndArrow :: { (Binder (), SourceToken) } + : binder '<-' {%^ revert $ pure ($1, $2) } + +binder :: { Binder () } + : binder1 { $1 } + | binder1 '::' type { BinderTyped () $1 $2 $3 } + +binder1 :: { Binder () } + : binder2 { $1 } + | binder1 qualOp binder2 { BinderOp () $1 $2 $3 } + +binder2 :: { Binder () } + : many(binderAtom) {% toBinderConstructor $1 } + +binderAtom :: { Binder () } + : '_' { BinderWildcard () $1 } + | ident { BinderVar () $1 } + | ident '@' binderAtom { BinderNamed () $1 $2 $3 } + | qualProperName { BinderConstructor () $1 [] } + | boolean { uncurry (BinderBoolean ()) $1 } + | char { uncurry (BinderChar ()) $1 } + | string { uncurry (BinderString ()) $1 } + | number { uncurry (BinderNumber () Nothing) $1 } + | '-' number { uncurry (BinderNumber () (Just $1)) $2 } + | delim('[', binder, ',', ']') { BinderArray () $1 } + | delim('{', recordBinder, ',', '}') { BinderRecord () $1 } + | '(' binder ')' { BinderParens () (Wrapped $1 $2 $3) } + +recordBinder :: { RecordLabeled (Binder ()) } + : label {% fmap RecordPun . toName Ident $ lblTok $1 } + | label '=' binder {% addFailure [$2] ErrRecordUpdateInCtr *> pure (RecordPun $ unexpectedName $ lblTok $1) } + | label ':' binder { RecordField $1 $2 $3 } + +-- By splitting up the module header from the body, we can incrementally parse +-- just the header, and then continue parsing the body while still sharing work. +moduleHeader :: { Module () } + : 'module' moduleName exports 'where' '\{' moduleImports + { (Module () $1 $2 $3 $4 $6 [] []) } + +moduleBody :: { ([Declaration ()], [Comment LineFeed]) } + : moduleDecls '\}' + {%^ \(SourceToken ann _) -> pure (snd $1, tokLeadingComments ann) } + +moduleImports :: { [ImportDecl ()] } + : importDecls importDecl '\}' + {%^ revert $ pushBack $3 *> pure (reverse ($2 : $1)) } + | importDecls + {%^ revert $ pure (reverse $1) } + +importDecls :: { [ImportDecl ()] } + : importDecls importDecl '\;' { $2 : $1 } + | {- empty -} { [] } + +moduleDecls :: { ([ImportDecl ()], [Declaration ()]) } + : manySep(moduleDecl, '\;') {% toModuleDecls $ NE.toList $1 } + | {- empty -} { ([], []) } + +moduleDecl :: { TmpModuleDecl a } + : importDecl { TmpImport $1 } + | sep(decl, declElse) { TmpChain $1 } + +declElse :: { SourceToken } + : 'else' { $1 } + | 'else' '\;' { $1 } + +exports :: { Maybe (DelimitedNonEmpty (Export ())) } + : {- empty -} { Nothing } + | '(' sep(export, ',') ')' { Just (Wrapped $1 $2 $3) } + +export :: { Export () } + : ident { ExportValue () $1 } + | symbol { ExportOp () $1 } + | properName { ExportType () $1 Nothing } + | properName dataMembers { ExportType () $1 (Just $2) } + | 'type' symbol { ExportTypeOp () $1 $2 } + | 'class' properName { ExportClass () $1 $2 } + | 'kind' properName { ExportKind () $1 $2 } + | 'module' moduleName { ExportModule () $1 $2 } + +dataMembers :: { (DataMembers ()) } + : '(..)' { DataAll () $1 } + | '(' ')' { DataEnumerated () (Wrapped $1 Nothing $2) } + | '(' sep(properName, ',') ')' { DataEnumerated () (Wrapped $1 (Just $2) $3) } + +importDecl :: { ImportDecl () } + : 'import' moduleName imports { ImportDecl () $1 $2 $3 Nothing } + | 'import' moduleName imports 'as' moduleName { ImportDecl () $1 $2 $3 (Just ($4, $5)) } + +imports :: { Maybe (Maybe SourceToken, DelimitedNonEmpty (Import ())) } + : {- empty -} { Nothing } + | '(' sep(import, ',') ')' { Just (Nothing, Wrapped $1 $2 $3) } + | 'hiding' '(' sep(import, ',') ')' { Just (Just $1, Wrapped $2 $3 $4) } + +import :: { Import () } + : ident { ImportValue () $1 } + | symbol { ImportOp () $1 } + | properName { ImportType () $1 Nothing } + | properName dataMembers { ImportType () $1 (Just $2) } + | 'type' symbol { ImportTypeOp () $1 $2 } + | 'class' properName { ImportClass () $1 $2 } + | 'kind' properName { ImportKind () $1 $2 } + +decl :: { Declaration () } + : dataHead { DeclData () $1 Nothing } + | dataHead '=' sep(dataCtor, '|') { DeclData () $1 (Just ($2, $3)) } + | typeHead '=' type {% checkNoWildcards $3 *> pure (DeclType () $1 $2 $3) } + | newtypeHead '=' properName typeAtom {% checkNoWildcards $4 *> pure (DeclNewtype () $1 $2 $3 $4) } + | classHead {% checkFundeps $1 *> pure (DeclClass () $1 Nothing) } + | classHead 'where' '\{' manySep(classMember, '\;') '\}' {% checkFundeps $1 *> pure (DeclClass () $1 (Just ($2, $4))) } + | instHead { DeclInstanceChain () (Separated (Instance $1 Nothing) []) } + | instHead 'where' '\{' manySep(instBinding, '\;') '\}' { DeclInstanceChain () (Separated (Instance $1 (Just ($2, $4))) []) } + | 'derive' instHead { DeclDerive () $1 Nothing $2 } + | 'derive' 'newtype' instHead { DeclDerive () $1 (Just $2) $3 } + | ident '::' type { DeclSignature () (Labeled $1 $2 $3) } + | ident manyOrEmpty(binderAtom) guarded('=') { DeclValue () (ValueBindingFields $1 $2 $3) } + | fixity { DeclFixity () $1 } + | 'foreign' 'import' foreign { DeclForeign () $1 $2 $3 } + +dataHead :: { DataHead () } + : 'data' properName manyOrEmpty(typeVarBinding) { DataHead $1 $2 $3 } + +typeHead :: { DataHead () } + : 'type' properName manyOrEmpty(typeVarBinding) { DataHead $1 $2 $3 } + +newtypeHead :: { DataHead () } + : 'newtype' properName manyOrEmpty(typeVarBinding) { DataHead $1 $2 $3 } + +dataCtor :: { DataCtor () } + : properName manyOrEmpty(typeAtom) + {% for_ $2 checkNoWildcards *> pure (DataCtor () $1 $2) } + +-- Class head syntax requires unbounded lookahead due to a conflict between +-- row syntax and `typeVarBinding`. `(a :: B)` is either a row in `constraint` +-- where `B` is a type or a `typeVarBinding` where `B` is a kind. We must see +-- either a `<=`, `where`, or layout delimiter before deciding which it is. +-- +-- classHead +-- : 'class' classNameAndFundeps +-- | 'class' constraints '<=' classNameAndFundeps +-- +classHead :: { ClassHead () } + : 'class' + {%% revert $ do + let + ctr (super, (name, vars, fundeps)) = + ClassHead $1 super name vars fundeps + fmap ctr $ tryPrefix parseClassSuper parseClassNameAndFundeps + } + +classSuper + : constraints '<=' {%^ revert $ pure ($1, $2) } + +classNameAndFundeps :: { (Name (N.ProperName 'N.ClassName), [TypeVarBinding ()], Maybe (SourceToken, Separated ClassFundep)) } + : properName manyOrEmpty(typeVarBinding) fundeps {%^ revert $ pure ($1, $2, $3) } + +fundeps :: { Maybe (SourceToken, Separated ClassFundep) } + : {- empty -} { Nothing } + | '|' sep(fundep, ',') { Just ($1, $2) } + +fundep :: { ClassFundep } + : '->' many(ident) { FundepDetermined $1 $2 } + | many(ident) '->' many(ident) { FundepDetermines $1 $2 $3 } + +classMember :: { Labeled (Name Ident) (Type ()) } + : ident '::' type {% checkNoWildcards $3 *> pure (Labeled $1 $2 $3) } + +instHead :: { InstanceHead () } + : 'instance' ident '::' constraints '=>' qualProperName manyOrEmpty(typeAtom) + { InstanceHead $1 $2 $3 (Just ($4, $5)) $6 $7 } + | 'instance' ident '::' qualProperName manyOrEmpty(typeAtom) + { InstanceHead $1 $2 $3 Nothing $4 $5 } + +constraints :: { OneOrDelimited (Constraint ()) } + : constraint { One $1 } + | '(' sep(constraint, ',') ')' { Many (Wrapped $1 $2 $3) } + +constraint :: { Constraint () } + : qualProperName manyOrEmpty(typeAtom) {% for_ $2 checkNoWildcards *> for_ $2 checkNoForalls *> pure (Constraint () $1 $2) } + | '(' constraint ')' { ConstraintParens () (Wrapped $1 $2 $3) } + +instBinding :: { InstanceBinding () } + : ident '::' type { InstanceBindingSignature () (Labeled $1 $2 $3) } + | ident manyOrEmpty(binderAtom) guarded('=') { InstanceBindingName () (ValueBindingFields $1 $2 $3) } + +fixity :: { FixityFields } + : infix int qualIdent 'as' op { FixityFields $1 $2 (FixityValue (fmap Left $3) $4 $5) } + | infix int qualProperName 'as' op { FixityFields $1 $2 (FixityValue (fmap Right $3) $4 $5) } + | infix int 'type' qualProperName 'as' op { FixityFields $1 $2 (FixityType $3 $4 $5 $6) } + +infix :: { (SourceToken, Fixity) } + : 'infix' { ($1, Infix) } + | 'infixl' { ($1, Infixl) } + | 'infixr' { ($1, Infixr) } + +foreign :: { Foreign () } + : ident '::' type { ForeignValue (Labeled $1 $2 $3) } + | 'data' properName '::' kind { ForeignData $1 (Labeled $2 $3 $4) } + | 'kind' properName { ForeignKind $1 $2 } + +{ +lexer :: (SourceToken -> Parser a) -> Parser a +lexer k = munch >>= k + +parse :: Text -> Either (NE.NonEmpty ParserError) (Module ()) +parse = parseModule >=> resFull + +data PartialResult a = PartialResult + { resPartial :: a + , resFull :: Either (NE.NonEmpty ParserError) a + } deriving (Functor) + +parseModule :: Text -> Either (NE.NonEmpty ParserError) (PartialResult (Module ())) +parseModule src = fmap (\header -> PartialResult header (parseFull header)) headerRes + where + (st, headerRes) = + runParser (ParserState (lex src) []) parseModuleHeader + + parseFull header = do + (decls, trailing) <- snd $ runParser st parseModuleBody + pure $ header + { modDecls = decls + , modTrailingComments = trailing + } +} diff --git a/src/Language/PureScript/CST/Positions.hs b/src/Language/PureScript/CST/Positions.hs new file mode 100644 index 0000000000..67f03a0870 --- /dev/null +++ b/src/Language/PureScript/CST/Positions.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} + +-- | This module contains utilities for calculating positions and offsets. While +-- tokens are annotated with ranges, CST nodes are not, but they can be +-- dynamically derived with the functions in this module, which will return the +-- first and last tokens for a given node. + +module Language.PureScript.CST.Positions where + +import Prelude + +import Data.Foldable (foldl') +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import Data.Void (Void) +import qualified Data.Text as Text +import Language.PureScript.CST.Types + +advanceToken :: SourcePos -> Token -> SourcePos +advanceToken pos = applyDelta pos . tokenDelta + +advanceLeading :: SourcePos -> [Comment LineFeed] -> SourcePos +advanceLeading pos = foldl' (\a -> applyDelta a . commentDelta lineDelta) pos + +advanceTrailing :: SourcePos -> [Comment Void] -> SourcePos +advanceTrailing pos = foldl' (\a -> applyDelta a . commentDelta (const (0, 0))) pos + +tokenDelta :: Token -> (Int, Int) +tokenDelta = \case + TokLeftParen -> (0, 1) + TokRightParen -> (0, 1) + TokLeftBrace -> (0, 1) + TokRightBrace -> (0, 1) + TokLeftSquare -> (0, 1) + TokRightSquare -> (0, 1) + TokLeftArrow ASCII -> (0, 2) + TokLeftArrow Unicode -> (0, 1) + TokRightArrow ASCII -> (0, 2) + TokRightArrow Unicode -> (0, 1) + TokRightFatArrow ASCII -> (0, 2) + TokRightFatArrow Unicode -> (0, 1) + TokDoubleColon ASCII -> (0, 2) + TokDoubleColon Unicode -> (0, 1) + TokForall ASCII -> (0, 6) + TokForall Unicode -> (0, 1) + TokEquals -> (0, 1) + TokPipe -> (0, 1) + TokTick -> (0, 1) + TokDot -> (0, 1) + TokComma -> (0, 1) + TokUnderscore -> (0, 1) + TokBackslash -> (0, 1) + TokLowerName qual name -> (0, qualDelta qual + Text.length name) + TokUpperName qual name -> (0, qualDelta qual + Text.length name) + TokOperator qual sym -> (0, qualDelta qual + Text.length sym) + TokSymbolName qual sym -> (0, qualDelta qual + Text.length sym + 2) + TokSymbolArr Unicode -> (0, 3) + TokSymbolArr ASCII -> (0, 4) + TokHole hole -> (0, Text.length hole + 1) + TokChar raw _ -> (0, Text.length raw + 2) + TokInt raw _ -> (0, Text.length raw) + TokNumber raw _ -> (0, Text.length raw) + TokString raw _ -> multiLine 1 $ textDelta raw + TokRawString raw -> multiLine 3 $ textDelta raw + TokLayoutStart -> (0, 0) + TokLayoutSep -> (0, 0) + TokLayoutEnd -> (0, 0) + TokEof -> (0, 0) + +qualDelta :: [Text] -> Int +qualDelta = foldr ((+) . (+ 1) . Text.length) 0 + +multiLine :: Int -> (Int, Int) -> (Int, Int) +multiLine n (0, c) = (0, c + n + n) +multiLine n (l, c) = (l, c + n) + +commentDelta :: (a -> (Int, Int)) -> Comment a -> (Int, Int) +commentDelta k = \case + Comment raw -> textDelta raw + Space n -> (0, n) + Line a -> k a + +lineDelta :: LineFeed -> (Int, Int) +lineDelta _ = (1, 1) + +textDelta :: Text -> (Int, Int) +textDelta = Text.foldl' go (0, 0) + where + go (!l, !c) = \case + '\n' -> (l + 1, 1) + _ -> (l, c + 1) + +applyDelta :: SourcePos -> (Int, Int) -> SourcePos +applyDelta (SourcePos l c) = \case + (0, n) -> SourcePos l (c + n) + (k, d) -> SourcePos (l + k) d + +sepLast :: Separated a -> a +sepLast (Separated hd []) = hd +sepLast (Separated _ tl) = snd $ last tl + +type TokenRange = (SourceToken, SourceToken) + +toSourceRange :: TokenRange -> SourceRange +toSourceRange (a, b) = widen (srcRange a) (srcRange b) + +widen :: SourceRange -> SourceRange -> SourceRange +widen (SourceRange s1 _) (SourceRange _ e2) = SourceRange s1 e2 + +srcRange :: SourceToken -> SourceRange +srcRange = tokRange . tokAnn + +nameRange :: Name a -> TokenRange +nameRange a = (nameTok a, nameTok a) + +qualRange :: QualifiedName a -> TokenRange +qualRange a = (qualTok a, qualTok a) + +labelRange :: Label -> TokenRange +labelRange a = (lblTok a, lblTok a) + +wrappedRange :: Wrapped a -> TokenRange +wrappedRange (Wrapped { wrpOpen, wrpClose }) = (wrpOpen, wrpClose) + +moduleRange :: Module a -> TokenRange +moduleRange (Module { modKeyword, modWhere, modImports, modDecls }) = + case (modImports, modDecls) of + ([], []) -> (modKeyword, modWhere) + (is, []) -> (modKeyword, snd . importDeclRange $ last is) + (_, ds) -> (modKeyword, snd . declRange $ last ds) + +exportRange :: Export a -> TokenRange +exportRange = \case + ExportValue _ a -> nameRange a + ExportOp _ a -> nameRange a + ExportType _ a b + | Just b' <- b -> (nameTok a, snd $ dataMembersRange b') + | otherwise -> nameRange a + ExportTypeOp _ a b -> (a, nameTok b) + ExportClass _ a b -> (a, nameTok b) + ExportKind _ a b -> (a, nameTok b) + ExportModule _ a b -> (a, nameTok b) + +importDeclRange :: ImportDecl a -> TokenRange +importDeclRange (ImportDecl { impKeyword, impModule, impNames, impQual }) + | Just (_, modName) <- impQual = (impKeyword, nameTok modName) + | Just (_, imports) <- impNames = (impKeyword, wrpClose imports) + | otherwise = (impKeyword, nameTok impModule) + +importRange :: Import a -> TokenRange +importRange = \case + ImportValue _ a -> nameRange a + ImportOp _ a -> nameRange a + ImportType _ a b + | Just b' <- b -> (nameTok a, snd $ dataMembersRange b') + | otherwise -> nameRange a + ImportTypeOp _ a b -> (a, nameTok b) + ImportClass _ a b -> (a, nameTok b) + ImportKind _ a b -> (a, nameTok b) + +dataMembersRange :: DataMembers a -> TokenRange +dataMembersRange = \case + DataAll _ a -> (a, a) + DataEnumerated _ (Wrapped a _ b) -> (a, b) + +declRange :: Declaration a -> TokenRange +declRange = \case + DeclData _ hd ctors + | Just (_, cs) <- ctors -> (fst start, snd . dataCtorRange $ sepLast cs) + | otherwise -> start + where start = dataHeadRange hd + DeclType _ a _ b -> (fst $ dataHeadRange a, snd $ typeRange b) + DeclNewtype _ a _ _ b -> (fst $ dataHeadRange a, snd $ typeRange b) + DeclClass _ hd body + | Just (_, ts) <- body -> (fst start, snd . typeRange . lblValue $ NE.last ts) + | otherwise -> start + where start = classHeadRange hd + DeclInstanceChain _ a -> (fst . instanceRange $ sepHead a, snd . instanceRange $ sepLast a) + DeclDerive _ a _ b -> (a, snd $ instanceHeadRange b) + DeclSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b) + DeclValue _ a -> valueBindingFieldsRange a + DeclFixity _ (FixityFields a _ (FixityValue _ _ b)) -> (fst a, nameTok b) + DeclFixity _ (FixityFields a _ (FixityType _ _ _ b)) -> (fst a, nameTok b) + DeclForeign _ a _ b -> (a, snd $ foreignRange b) + +dataHeadRange :: DataHead a -> TokenRange +dataHeadRange (DataHead kw name vars) + | [] <- vars = (kw, nameTok name) + | otherwise = (kw, snd . typeVarBindingRange $ last vars) + +dataCtorRange :: DataCtor a -> TokenRange +dataCtorRange (DataCtor _ name fields) + | [] <- fields = nameRange name + | otherwise = (nameTok name, snd . typeRange $ last fields) + +classHeadRange :: ClassHead a -> TokenRange +classHeadRange (ClassHead kw _ name vars fdeps) + | Just (_, fs) <- fdeps = (kw, snd .classFundepRange $ sepLast fs) + | [] <- vars = (kw, snd $ nameRange name) + | otherwise = (kw, snd . typeVarBindingRange $ last vars) + +classFundepRange :: ClassFundep -> TokenRange +classFundepRange = \case + FundepDetermined arr bs -> (arr, nameTok $ NE.last bs) + FundepDetermines as _ bs -> (nameTok $ NE.head as, nameTok $ NE.last bs) + +instanceRange :: Instance a -> TokenRange +instanceRange (Instance hd bd) + | Just (_, ts) <- bd = (fst start, snd . instanceBindingRange $ NE.last ts) + | otherwise = start + where start = instanceHeadRange hd + +instanceHeadRange :: InstanceHead a -> TokenRange +instanceHeadRange (InstanceHead kw _ _ _ cls types) + | [] <- types = (kw, qualTok cls) + | otherwise = (kw, snd . typeRange $ last types) + +instanceBindingRange :: InstanceBinding a -> TokenRange +instanceBindingRange = \case + InstanceBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b) + InstanceBindingName _ a -> valueBindingFieldsRange a + +foreignRange :: Foreign a -> TokenRange +foreignRange = \case + ForeignValue (Labeled a _ b) -> (nameTok a, snd $ typeRange b) + ForeignData a (Labeled _ _ b) -> (a, snd $ kindRange b) + ForeignKind a b -> (a, nameTok b) + +valueBindingFieldsRange :: ValueBindingFields a -> TokenRange +valueBindingFieldsRange (ValueBindingFields a _ b) = (nameTok a, snd $ guardedRange b) + +guardedRange :: Guarded a -> TokenRange +guardedRange = \case + Unconditional a b -> (a, snd $ whereRange b) + Guarded as -> (fst . guardedExprRange $ NE.head as, snd . guardedExprRange $ NE.last as) + +guardedExprRange :: GuardedExpr a -> TokenRange +guardedExprRange (GuardedExpr a _ _ b) = (a, snd $ whereRange b) + +whereRange :: Where a -> TokenRange +whereRange (Where a bs) + | Just (_, ls) <- bs = (fst $ exprRange a, snd . letBindingRange $ NE.last ls) + | otherwise = exprRange a + +kindRange :: Kind a -> TokenRange +kindRange = \case + KindName _ a -> qualRange a + KindArr _ a _ b -> (fst $ kindRange a, snd $ kindRange b) + KindRow _ a b -> (a, snd $ kindRange b) + KindParens _ a -> wrappedRange a + +typeRange :: Type a -> TokenRange +typeRange = \case + TypeVar _ a -> nameRange a + TypeConstructor _ a -> qualRange a + TypeWildcard _ a -> (a, a) + TypeHole _ a -> nameRange a + TypeString _ a _ -> (a, a) + TypeRow _ a -> wrappedRange a + TypeRecord _ a -> wrappedRange a + TypeForall _ a _ _ b -> (a, snd $ typeRange b) + TypeKinded _ a _ b -> (fst $ typeRange a, snd $ kindRange b) + TypeApp _ a b -> (fst $ typeRange a, snd $ typeRange b) + TypeOp _ a _ b -> (fst $ typeRange a, snd $ typeRange b) + TypeOpName _ a -> qualRange a + TypeArr _ a _ b -> (fst $ typeRange a, snd $ typeRange b) + TypeArrName _ a -> (a, a) + TypeConstrained _ a _ b -> (fst $ constraintRange a, snd $ typeRange b) + TypeParens _ a -> wrappedRange a + +constraintRange :: Constraint a -> TokenRange +constraintRange = \case + Constraint _ name args + | [] <- args -> qualRange name + | otherwise -> (qualTok name, snd . typeRange $ last args) + ConstraintParens _ wrp -> wrappedRange wrp + +typeVarBindingRange :: TypeVarBinding a -> TokenRange +typeVarBindingRange = \case + TypeVarKinded a -> wrappedRange a + TypeVarName a -> nameRange a + +exprRange :: Expr a -> TokenRange +exprRange = \case + ExprHole _ a -> nameRange a + ExprSection _ a -> (a, a) + ExprIdent _ a -> qualRange a + ExprConstructor _ a -> qualRange a + ExprBoolean _ a _ -> (a, a) + ExprChar _ a _ -> (a, a) + ExprString _ a _ -> (a, a) + ExprNumber _ a _ -> (a, a) + ExprArray _ a -> wrappedRange a + ExprRecord _ a -> wrappedRange a + ExprParens _ a -> wrappedRange a + ExprTyped _ a _ b -> (fst $ exprRange a, snd $ typeRange b) + ExprInfix _ a _ b -> (fst $ exprRange a, snd $ exprRange b) + ExprOp _ a _ b -> (fst $ exprRange a, snd $ exprRange b) + ExprOpName _ a -> qualRange a + ExprNegate _ a b -> (a, snd $ exprRange b) + ExprRecordAccessor _ (RecordAccessor a _ b) -> (fst $ exprRange a, lblTok $ sepLast b) + ExprRecordUpdate _ a b -> (fst $ exprRange a, snd $ wrappedRange b) + ExprApp _ a b -> (fst $ exprRange a, snd $ exprRange b) + ExprLambda _ (Lambda a _ _ b) -> (a, snd $ exprRange b) + ExprIf _ (IfThenElse a _ _ _ _ b) -> (a, snd $ exprRange b) + ExprCase _ (CaseOf a _ _ c) -> (a, snd . guardedRange . snd $ NE.last c) + ExprLet _ (LetIn a _ _ b) -> (a, snd $ exprRange b) + ExprDo _ (DoBlock a b) -> (a, snd . doStatementRange $ NE.last b) + ExprAdo _ (AdoBlock a _ _ b) -> (a, snd $ exprRange b) + +letBindingRange :: LetBinding a -> TokenRange +letBindingRange = \case + LetBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b) + LetBindingName _ a -> valueBindingFieldsRange a + LetBindingPattern _ a _ b -> (fst $ binderRange a, snd $ whereRange b) + +doStatementRange :: DoStatement a -> TokenRange +doStatementRange = \case + DoLet a bs -> (a, snd . letBindingRange $ NE.last bs) + DoDiscard a -> exprRange a + DoBind a _ b -> (fst $ binderRange a, snd $ exprRange b) + +binderRange :: Binder a -> TokenRange +binderRange = \case + BinderWildcard _ a -> (a, a) + BinderVar _ a -> nameRange a + BinderNamed _ a _ b -> (nameTok a, snd $ binderRange b) + BinderConstructor _ a bs + | [] <- bs -> qualRange a + | otherwise -> (qualTok a, snd . binderRange $ last bs) + BinderBoolean _ a _ -> (a, a) + BinderChar _ a _ -> (a, a) + BinderString _ a _ -> (a, a) + BinderNumber _ a b _ + | Just a' <- a -> (a', b) + | otherwise -> (b, b) + BinderArray _ a -> wrappedRange a + BinderRecord _ a -> wrappedRange a + BinderParens _ a -> wrappedRange a + BinderTyped _ a _ b -> (fst $ binderRange a, snd $ typeRange b) + BinderOp _ a _ b -> (fst $ binderRange a, snd $ binderRange b) + +recordUpdateRange :: RecordUpdate a -> TokenRange +recordUpdateRange = \case + RecordUpdateLeaf a _ b -> (lblTok a, snd $ exprRange b) + RecordUpdateBranch a (Wrapped _ _ b) -> (lblTok a, b) + +recordLabeledExprRange :: RecordLabeled (Expr a) -> TokenRange +recordLabeledExprRange = \case + RecordPun a -> nameRange a + RecordField a _ b -> (fst $ labelRange a, snd $ exprRange b) diff --git a/src/Language/PureScript/CST/Print.hs b/src/Language/PureScript/CST/Print.hs new file mode 100644 index 0000000000..16aac588dc --- /dev/null +++ b/src/Language/PureScript/CST/Print.hs @@ -0,0 +1,82 @@ +-- | This is just a simple token printer. It's not a full fledged formatter, but +-- it is used by the layout golden tests. Printing each token in the tree with +-- this printer will result in the exact input that was given to the lexer. + +module Language.PureScript.CST.Print + ( printToken + , printTokens + , printLeadingComment + , printTrailingComment + ) where + +import Prelude + +import Data.Text (Text) +import qualified Data.Text as Text +import Language.PureScript.CST.Types + +printToken :: Token -> Text +printToken = \case + TokLeftParen -> "(" + TokRightParen -> ")" + TokLeftBrace -> "{" + TokRightBrace -> "}" + TokLeftSquare -> "[" + TokRightSquare -> "]" + TokLeftArrow ASCII -> "<-" + TokLeftArrow Unicode -> "←" + TokRightArrow ASCII -> "->" + TokRightArrow Unicode -> "→" + TokRightFatArrow ASCII -> "=>" + TokRightFatArrow Unicode -> "⇒" + TokDoubleColon ASCII -> "::" + TokDoubleColon Unicode -> "∷" + TokForall ASCII -> "forall" + TokForall Unicode -> "∀" + TokEquals -> "=" + TokPipe -> "|" + TokTick -> "`" + TokDot -> "." + TokComma -> "," + TokUnderscore -> "_" + TokBackslash -> "\\" + TokLowerName qual name -> printQual qual <> name + TokUpperName qual name -> printQual qual <> name + TokOperator qual sym -> printQual qual <> sym + TokSymbolName qual sym -> printQual qual <> "(" <> sym <> ")" + TokSymbolArr Unicode -> "(→)" + TokSymbolArr ASCII -> "(->)" + TokHole hole -> "?" <> hole + TokChar raw _ -> "'" <> raw <> "'" + TokString raw _ -> "\"" <> raw <> "\"" + TokRawString raw -> "\"\"\"" <> raw <> "\"\"\"" + TokInt raw _ -> raw + TokNumber raw _ -> raw + TokLayoutStart -> "{" + TokLayoutSep -> ";" + TokLayoutEnd -> "}" + TokEof -> "" + +printQual :: [Text] -> Text +printQual = Text.concat . map (<> ".") + +printTokens :: [SourceToken] -> Text +printTokens toks = Text.concat (map pp toks) + where + pp (SourceToken (TokenAnn _ leading trailing) tok) = + Text.concat (map printLeadingComment leading) + <> printToken tok + <> Text.concat (map printTrailingComment trailing) + +printLeadingComment :: Comment LineFeed -> Text +printLeadingComment = \case + Comment raw -> raw + Space n -> Text.replicate n " " + Line LF -> "\n" + Line CRLF -> "\r\n" + +printTrailingComment :: Comment void -> Text +printTrailingComment = \case + Comment raw -> raw + Space n -> Text.replicate n " " + Line _ -> "" diff --git a/src/Language/PureScript/CST/Traversals.hs b/src/Language/PureScript/CST/Traversals.hs new file mode 100644 index 0000000000..6d5627f8ac --- /dev/null +++ b/src/Language/PureScript/CST/Traversals.hs @@ -0,0 +1,11 @@ +module Language.PureScript.CST.Traversals where + +import Prelude + +import Language.PureScript.CST.Types + +everythingOnSeparated :: (r -> r -> r) -> (a -> r) -> Separated a -> r +everythingOnSeparated op k (Separated hd tl) = go hd tl + where + go a [] = k a + go a (b : bs) = k a `op` go (snd b) bs diff --git a/src/Language/PureScript/CST/Traversals/Type.hs b/src/Language/PureScript/CST/Traversals/Type.hs new file mode 100644 index 0000000000..9e84718ee0 --- /dev/null +++ b/src/Language/PureScript/CST/Traversals/Type.hs @@ -0,0 +1,39 @@ +module Language.PureScript.CST.Traversals.Type where + +import Prelude + +import Language.PureScript.CST.Types +import Language.PureScript.CST.Traversals + +everythingOnTypes :: (r -> r -> r) -> (Type a -> r) -> Type a -> r +everythingOnTypes op k = goTy + where + goTy ty = case ty of + TypeVar _ _ -> k ty + TypeConstructor _ _ -> k ty + TypeWildcard _ _ -> k ty + TypeHole _ _ -> k ty + TypeString _ _ _ -> k ty + TypeRow _ (Wrapped _ row _) -> goRow ty row + TypeRecord _ (Wrapped _ row _) -> goRow ty row + TypeForall _ _ _ _ ty2 -> k ty `op` goTy ty2 + TypeKinded _ ty2 _ _ -> k ty `op` goTy ty2 + TypeApp _ ty2 ty3 -> k ty `op` (goTy ty2 `op` goTy ty3) + TypeOp _ ty2 _ ty3 -> k ty `op` (goTy ty2 `op` goTy ty3) + TypeOpName _ _ -> k ty + TypeArr _ ty2 _ ty3 -> k ty `op` (goTy ty2 `op` goTy ty3) + TypeArrName _ _ -> k ty + TypeConstrained _ (constraintTys -> ty2) _ ty3 + | null ty2 -> k ty `op` goTy ty3 + | otherwise -> k ty `op` (foldr1 op (k <$> ty2) `op` goTy ty3) + TypeParens _ (Wrapped _ ty2 _) -> k ty `op` goTy ty2 + + goRow ty = \case + Row Nothing Nothing -> k ty + Row Nothing (Just (_, ty2)) -> k ty `op` goTy ty2 + Row (Just lbls) Nothing -> k ty `op` everythingOnSeparated op (goTy . lblValue) lbls + Row (Just lbls) (Just (_, ty2)) -> k ty `op` (everythingOnSeparated op (goTy . lblValue) lbls `op` goTy ty2) + + constraintTys = \case + Constraint _ _ tys -> tys + ConstraintParens _ (Wrapped _ c _) -> constraintTys c diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs new file mode 100644 index 0000000000..7768b960b3 --- /dev/null +++ b/src/Language/PureScript/CST/Types.hs @@ -0,0 +1,437 @@ +-- | This module contains data types for the entire PureScript surface language. Every +-- token is represented in the tree, and every token is annotated with +-- whitespace and comments (both leading and trailing). This means one can write +-- an exact printer so that `print . parse = id`. Every constructor is laid out +-- with tokens in left-to-right order. The core productions are given a slot for +-- arbitrary annotations, however this is not used by the parser. + +module Language.PureScript.CST.Types where + +import Prelude + +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Data.Void (Void) +import GHC.Generics (Generic) +import qualified Language.PureScript.Names as N +import Language.PureScript.PSString (PSString) + +data SourcePos = SourcePos + { srcLine :: {-# UNPACK #-} !Int + , srcColumn :: {-# UNPACK #-} !Int + } deriving (Show, Eq, Ord, Generic) + +data SourceRange = SourceRange + { srcStart :: !SourcePos + , srcEnd :: !SourcePos + } deriving (Show, Eq, Ord, Generic) + +data Comment l + = Comment !Text + | Space {-# UNPACK #-} !Int + | Line !l + deriving (Show, Eq, Ord, Generic, Functor) + +data LineFeed = LF | CRLF + deriving (Show, Eq, Ord, Generic) + +data TokenAnn = TokenAnn + { tokRange :: !SourceRange + , tokLeadingComments :: ![Comment LineFeed] + , tokTrailingComments :: ![Comment Void] + } deriving (Show, Eq, Ord, Generic) + +data SourceStyle = ASCII | Unicode + deriving (Show, Eq, Ord, Generic) + +data Token + = TokLeftParen + | TokRightParen + | TokLeftBrace + | TokRightBrace + | TokLeftSquare + | TokRightSquare + | TokLeftArrow !SourceStyle + | TokRightArrow !SourceStyle + | TokRightFatArrow !SourceStyle + | TokDoubleColon !SourceStyle + | TokForall !SourceStyle + | TokEquals + | TokPipe + | TokTick + | TokDot + | TokComma + | TokUnderscore + | TokBackslash + | TokLowerName ![Text] !Text + | TokUpperName ![Text] !Text + | TokOperator ![Text] !Text + | TokSymbolName ![Text] !Text + | TokSymbolArr !SourceStyle + | TokHole !Text + | TokChar !Text !Char + | TokString !Text !PSString + | TokRawString !Text + | TokInt !Text !Integer + | TokNumber !Text !Double + | TokLayoutStart + | TokLayoutSep + | TokLayoutEnd + | TokEof + deriving (Show, Eq, Ord, Generic) + +data SourceToken = SourceToken + { tokAnn :: !TokenAnn + , tokValue :: !Token + } deriving (Show, Eq, Ord, Generic) + +data Ident = Ident + { getIdent :: Text + } deriving (Show, Eq, Ord, Generic) + +data Name a = Name + { nameTok :: SourceToken + , nameValue :: a + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data QualifiedName a = QualifiedName + { qualTok :: SourceToken + , qualModule :: Maybe N.ModuleName + , qualName :: a + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Label = Label + { lblTok :: SourceToken + , lblName :: PSString + } deriving (Show, Eq, Ord, Generic) + +data Wrapped a = Wrapped + { wrpOpen :: SourceToken + , wrpValue :: a + , wrpClose :: SourceToken + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Separated a = Separated + { sepHead :: a + , sepTail :: [(SourceToken, a)] + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Labeled a b = Labeled + { lblLabel :: a + , lblSep :: SourceToken + , lblValue :: b + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +type Delimited a = Wrapped (Maybe (Separated a)) +type DelimitedNonEmpty a = Wrapped (Separated a) + +data OneOrDelimited a + = One a + | Many (DelimitedNonEmpty a) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Kind a + = KindName a (QualifiedName (N.ProperName 'N.KindName)) + | KindArr a (Kind a) SourceToken (Kind a) + | KindRow a SourceToken (Kind a) + | KindParens a (Wrapped (Kind a)) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Type a + = TypeVar a (Name Ident) + | TypeConstructor a (QualifiedName (N.ProperName 'N.TypeName)) + | TypeWildcard a SourceToken + | TypeHole a (Name Ident) + | TypeString a SourceToken PSString + | TypeRow a (Wrapped (Row a)) + | TypeRecord a (Wrapped (Row a)) + | TypeForall a SourceToken (NonEmpty (TypeVarBinding a)) SourceToken (Type a) + | TypeKinded a (Type a) SourceToken (Kind a) + | TypeApp a (Type a) (Type a) + | TypeOp a (Type a) (QualifiedName (N.OpName 'N.TypeOpName)) (Type a) + | TypeOpName a (QualifiedName (N.OpName 'N.TypeOpName)) + | TypeArr a (Type a) SourceToken (Type a) + | TypeArrName a SourceToken + | TypeConstrained a (Constraint a) SourceToken (Type a) + | TypeParens a (Wrapped (Type a)) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data TypeVarBinding a + = TypeVarKinded (Wrapped (Labeled (Name Ident) (Kind a))) + | TypeVarName (Name Ident) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Constraint a + = Constraint a (QualifiedName (N.ProperName 'N.ClassName)) [Type a] + | ConstraintParens a (Wrapped (Constraint a)) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Row a = Row + { rowLabels :: Maybe (Separated (Labeled Label (Type a))) + , rowTail :: Maybe (SourceToken, Type a) + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Module a = Module + { modAnn :: a + , modKeyword :: SourceToken + , modNamespace :: Name N.ModuleName + , modExports :: Maybe (DelimitedNonEmpty (Export a)) + , modWhere :: SourceToken + , modImports :: [ImportDecl a] + , modDecls :: [Declaration a] + , modTrailingComments :: [Comment LineFeed] + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Export a + = ExportValue a (Name Ident) + | ExportOp a (Name (N.OpName 'N.ValueOpName)) + | ExportType a (Name (N.ProperName 'N.TypeName)) (Maybe (DataMembers a)) + | ExportTypeOp a SourceToken (Name (N.OpName 'N.TypeOpName)) + | ExportClass a SourceToken (Name (N.ProperName 'N.ClassName)) + | ExportKind a SourceToken (Name (N.ProperName 'N.KindName)) + | ExportModule a SourceToken (Name N.ModuleName) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data DataMembers a + = DataAll a SourceToken + | DataEnumerated a (Delimited (Name (N.ProperName 'N.ConstructorName))) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Declaration a + = DeclData a (DataHead a) (Maybe (SourceToken, Separated (DataCtor a))) + | DeclType a (DataHead a) SourceToken (Type a) + | DeclNewtype a (DataHead a) SourceToken (Name (N.ProperName 'N.ConstructorName)) (Type a) + | DeclClass a (ClassHead a) (Maybe (SourceToken, NonEmpty (Labeled (Name Ident) (Type a)))) + | DeclInstanceChain a (Separated (Instance a)) + | DeclDerive a SourceToken (Maybe SourceToken) (InstanceHead a) + | DeclSignature a (Labeled (Name Ident) (Type a)) + | DeclValue a (ValueBindingFields a) + | DeclFixity a FixityFields + | DeclForeign a SourceToken SourceToken (Foreign a) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Instance a = Instance + { instHead :: InstanceHead a + , instBody :: Maybe (SourceToken, NonEmpty (InstanceBinding a)) + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data InstanceBinding a + = InstanceBindingSignature a (Labeled (Name Ident) (Type a)) + | InstanceBindingName a (ValueBindingFields a) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data ImportDecl a = ImportDecl + { impAnn :: a + , impKeyword :: SourceToken + , impModule :: Name N.ModuleName + , impNames :: Maybe (Maybe SourceToken, DelimitedNonEmpty (Import a)) + , impQual :: Maybe (SourceToken, Name N.ModuleName) + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Import a + = ImportValue a (Name Ident) + | ImportOp a (Name (N.OpName 'N.ValueOpName)) + | ImportType a (Name (N.ProperName 'N.TypeName)) (Maybe (DataMembers a)) + | ImportTypeOp a SourceToken (Name (N.OpName 'N.TypeOpName)) + | ImportClass a SourceToken (Name (N.ProperName 'N.ClassName)) + | ImportKind a SourceToken (Name (N.ProperName 'N.KindName)) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data DataHead a = DataHead + { dataHdKeyword :: SourceToken + , dataHdName :: Name (N.ProperName 'N.TypeName) + , dataHdVars :: [TypeVarBinding a] + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data DataCtor a = DataCtor + { dataCtorAnn :: a + , dataCtorName :: Name (N.ProperName 'N.ConstructorName) + , dataCtorFields :: [Type a] + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data ClassHead a = ClassHead + { clsKeyword :: SourceToken + , clsSuper :: Maybe (OneOrDelimited (Constraint a), SourceToken) + , clsName :: Name (N.ProperName 'N.ClassName) + , clsVars :: [TypeVarBinding a] + , clsFundeps :: Maybe (SourceToken, Separated ClassFundep) + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data ClassFundep + = FundepDetermined SourceToken (NonEmpty (Name Ident)) + | FundepDetermines (NonEmpty (Name Ident)) SourceToken (NonEmpty (Name Ident)) + deriving (Show, Eq, Ord, Generic) + +data InstanceHead a = InstanceHead + { instKeyword :: SourceToken + , instName :: Name Ident + , instSep :: SourceToken + , instConstraints :: Maybe (OneOrDelimited (Constraint a), SourceToken) + , instClass :: QualifiedName (N.ProperName 'N.ClassName) + , instTypes :: [Type a] + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Fixity + = Infix + | Infixl + | Infixr + deriving (Show, Eq, Ord, Generic) + +data FixityOp + = FixityValue (QualifiedName (Either Ident (N.ProperName 'N.ConstructorName))) SourceToken (Name (N.OpName 'N.ValueOpName)) + | FixityType SourceToken (QualifiedName (N.ProperName 'N.TypeName)) SourceToken (Name (N.OpName 'N.TypeOpName)) + deriving (Show, Eq, Ord, Generic) + +data FixityFields = FixityFields + { fxtKeyword :: (SourceToken, Fixity) + , fxtPrec :: (SourceToken, Integer) + , fxtOp :: FixityOp + } deriving (Show, Eq, Ord, Generic) + +data ValueBindingFields a = ValueBindingFields + { valName :: Name Ident + , valBinders :: [Binder a] + , valGuarded :: Guarded a + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Guarded a + = Unconditional SourceToken (Where a) + | Guarded (NonEmpty (GuardedExpr a)) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data GuardedExpr a = GuardedExpr + { grdBar :: SourceToken + , grdPatterns :: Separated (PatternGuard a) + , grdSep :: SourceToken + , grdWhere :: Where a + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data PatternGuard a = PatternGuard + { patBinder :: Maybe (Binder a, SourceToken) + , patExpr :: Expr a + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Foreign a + = ForeignValue (Labeled (Name Ident) (Type a)) + | ForeignData SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Kind a)) + | ForeignKind SourceToken (Name (N.ProperName 'N.KindName)) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Expr a + = ExprHole a (Name Ident) + | ExprSection a SourceToken + | ExprIdent a (QualifiedName Ident) + | ExprConstructor a (QualifiedName (N.ProperName 'N.ConstructorName)) + | ExprBoolean a SourceToken Bool + | ExprChar a SourceToken Char + | ExprString a SourceToken PSString + | ExprNumber a SourceToken (Either Integer Double) + | ExprArray a (Delimited (Expr a)) + | ExprRecord a (Delimited (RecordLabeled (Expr a))) + | ExprParens a (Wrapped (Expr a)) + | ExprTyped a (Expr a) SourceToken (Type a) + | ExprInfix a (Expr a) (Wrapped (Expr a)) (Expr a) + | ExprOp a (Expr a) (QualifiedName (N.OpName 'N.ValueOpName)) (Expr a) + | ExprOpName a (QualifiedName (N.OpName 'N.ValueOpName)) + | ExprNegate a SourceToken (Expr a) + | ExprRecordAccessor a (RecordAccessor a) + | ExprRecordUpdate a (Expr a) (DelimitedNonEmpty (RecordUpdate a)) + | ExprApp a (Expr a) (Expr a) + | ExprLambda a (Lambda a) + | ExprIf a (IfThenElse a) + | ExprCase a (CaseOf a) + | ExprLet a (LetIn a) + | ExprDo a (DoBlock a) + | ExprAdo a (AdoBlock a) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data RecordLabeled a + = RecordPun (Name Ident) + | RecordField Label SourceToken a + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data RecordUpdate a + = RecordUpdateLeaf Label SourceToken (Expr a) + | RecordUpdateBranch Label (DelimitedNonEmpty (RecordUpdate a)) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data RecordAccessor a = RecordAccessor + { recExpr :: Expr a + , recDot :: SourceToken + , recPath :: Separated Label + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Lambda a = Lambda + { lmbSymbol :: SourceToken + , lmbBinders :: NonEmpty (Binder a) + , lmbArr :: SourceToken + , lmbBody :: Expr a + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data IfThenElse a = IfThenElse + { iteIf :: SourceToken + , iteCond :: Expr a + , iteThen :: SourceToken + , iteTrue :: Expr a + , iteElse :: SourceToken + , iteFalse :: Expr a + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data CaseOf a = CaseOf + { caseKeyword :: SourceToken + , caseHead :: Separated (Expr a) + , caseOf :: SourceToken + , caseBranches :: NonEmpty (Separated (Binder a), Guarded a) + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data LetIn a = LetIn + { letKeyword :: SourceToken + , letBindings :: NonEmpty (LetBinding a) + , letIn :: SourceToken + , letBody :: Expr a + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Where a = Where + { whereExpr :: Expr a + , whereBindings :: Maybe (SourceToken, NonEmpty (LetBinding a)) + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data LetBinding a + = LetBindingSignature a (Labeled (Name Ident) (Type a)) + | LetBindingName a (ValueBindingFields a) + | LetBindingPattern a (Binder a) SourceToken (Where a) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data DoBlock a = DoBlock + { doKeyword :: SourceToken + , doStatements :: NonEmpty (DoStatement a) + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data DoStatement a + = DoLet SourceToken (NonEmpty (LetBinding a)) + | DoDiscard (Expr a) + | DoBind (Binder a) SourceToken (Expr a) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data AdoBlock a = AdoBlock + { adoKeyword :: SourceToken + , adoStatements :: [DoStatement a] + , adoIn :: SourceToken + , adoResult :: Expr a + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + +data Binder a + = BinderWildcard a SourceToken + | BinderVar a (Name Ident) + | BinderNamed a (Name Ident) SourceToken (Binder a) + | BinderConstructor a (QualifiedName (N.ProperName 'N.ConstructorName)) [Binder a] + | BinderBoolean a SourceToken Bool + | BinderChar a SourceToken Char + | BinderString a SourceToken PSString + | BinderNumber a (Maybe SourceToken) SourceToken (Either Integer Double) + | BinderArray a (Delimited (Binder a)) + | BinderRecord a (Delimited (RecordLabeled (Binder a))) + | BinderParens a (Wrapped (Binder a)) + | BinderTyped a (Binder a) SourceToken (Type a) + | BinderOp a (Binder a) (QualifiedName (N.OpName 'N.ValueOpName)) (Binder a) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) diff --git a/src/Language/PureScript/CST/Utils.hs b/src/Language/PureScript/CST/Utils.hs new file mode 100644 index 0000000000..d7113f8372 --- /dev/null +++ b/src/Language/PureScript/CST/Utils.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE MonoLocalBinds #-} +module Language.PureScript.CST.Utils where + +import Prelude + +import Control.Monad (when) +import Data.Coerce (coerce) +import Data.Foldable (for_) +import Data.Functor (($>)) +import qualified Data.List.NonEmpty as NE +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text +import Language.PureScript.CST.Errors +import Language.PureScript.CST.Monad +import Language.PureScript.CST.Positions +import Language.PureScript.CST.Traversals.Type +import Language.PureScript.CST.Types +import qualified Language.PureScript.Names as N +import Language.PureScript.PSString (PSString, mkString) + +placeholder :: SourceToken +placeholder = SourceToken + { tokAnn = TokenAnn (SourceRange (SourcePos 0 0) (SourcePos 0 0)) [] [] + , tokValue = TokLowerName [] "" + } + +unexpectedName :: SourceToken -> Name Ident +unexpectedName tok = Name tok (Ident "") + +unexpectedQual :: SourceToken -> QualifiedName Ident +unexpectedQual tok = QualifiedName tok Nothing (Ident "") + +unexpectedLabel :: SourceToken -> Label +unexpectedLabel tok = Label tok "" + +unexpectedExpr :: Monoid a => [SourceToken] -> Expr a +unexpectedExpr toks = ExprIdent mempty (unexpectedQual (head toks)) + +unexpectedDecl :: Monoid a => [SourceToken] -> Declaration a +unexpectedDecl toks = DeclValue mempty (ValueBindingFields (unexpectedName (head toks)) [] (error " [SourceToken] -> Binder a +unexpectedBinder toks = BinderVar mempty (unexpectedName (head toks)) + +unexpectedLetBinding :: Monoid a => [SourceToken] -> LetBinding a +unexpectedLetBinding toks = LetBindingName mempty (ValueBindingFields (unexpectedName (head toks)) [] (error "")) + +unexpectedInstBinding :: Monoid a => [SourceToken] -> InstanceBinding a +unexpectedInstBinding toks = InstanceBindingName mempty (ValueBindingFields (unexpectedName (head toks)) [] (error "")) + +unexpectedRecordUpdate :: Monoid a => [SourceToken] -> RecordUpdate a +unexpectedRecordUpdate toks = RecordUpdateLeaf (unexpectedLabel (head toks)) (head toks) (unexpectedExpr toks) + +unexpectedRecordLabeled :: [SourceToken] -> RecordLabeled a +unexpectedRecordLabeled toks = RecordPun (unexpectedName (head toks)) + +rangeToks :: TokenRange -> [SourceToken] +rangeToks (a, b) = [a, b] + +unexpectedToks :: (a -> TokenRange) -> ([SourceToken] -> b) -> ParserErrorType -> (a -> Parser b) +unexpectedToks toRange toCst err old = do + let toks = rangeToks $ toRange old + addFailure toks err + pure $ toCst toks + +separated :: [(SourceToken, a)] -> Separated a +separated = go [] + where + go accum ((_, a) : []) = Separated a accum + go accum (x : xs) = go (x : accum) xs + go _ [] = internalError "Separated should not be empty" + +consSeparated :: a -> SourceToken -> Separated a -> Separated a +consSeparated x sep (Separated {..}) = Separated x ((sep, sepHead) : sepTail) + +internalError :: String -> a +internalError = error . ("Internal parser error: " <>) + +toModuleName :: SourceToken -> [Text] -> Parser (Maybe N.ModuleName) +toModuleName _ [] = pure Nothing +toModuleName tok ns = do + when (not (all isValidModuleNamespace ns)) $ addFailure [tok] ErrModuleName + pure . Just . N.ModuleName $ N.ProperName <$> ns + +upperToModuleName :: SourceToken -> Parser (Name N.ModuleName) +upperToModuleName tok = case tokValue tok of + TokUpperName q a -> do + let ns = q <> [a] + when (not (all isValidModuleNamespace ns)) $ addFailure [tok] ErrModuleName + pure . Name tok . N.ModuleName $ N.ProperName <$> ns + _ -> internalError $ "Invalid upper name: " <> show tok + +toQualifiedName :: (Text -> a) -> SourceToken -> Parser (QualifiedName a) +toQualifiedName k tok = case tokValue tok of + TokLowerName q a + | not (Set.member a reservedNames) -> flip (QualifiedName tok) (k a) <$> toModuleName tok q + | otherwise -> addFailure [tok] ErrKeywordVar $> QualifiedName tok Nothing (k "") + TokUpperName q a -> flip (QualifiedName tok) (k a) <$> toModuleName tok q + TokSymbolName q a -> flip (QualifiedName tok) (k a) <$> toModuleName tok q + TokOperator q a -> flip (QualifiedName tok) (k a) <$> toModuleName tok q + _ -> internalError $ "Invalid qualified name: " <> show tok + +toName :: (Text -> a) -> SourceToken -> Parser (Name a) +toName k tok = case tokValue tok of + TokLowerName [] a + | not (Set.member a reservedNames) -> pure $ Name tok (k a) + | otherwise -> addFailure [tok] ErrKeywordVar $> Name tok (k "") + TokUpperName [] a -> pure $ Name tok (k a) + TokSymbolName [] a -> pure $ Name tok (k a) + TokOperator [] a -> pure $ Name tok (k a) + TokHole a -> pure $ Name tok (k a) + _ -> internalError $ "Invalid name: " <> show tok + +toLabel :: SourceToken -> Label +toLabel tok = case tokValue tok of + TokLowerName [] a -> Label tok $ mkString a + TokString _ a -> Label tok a + TokRawString a -> Label tok $ mkString a + TokForall ASCII -> Label tok $ mkString "forall" + _ -> internalError $ "Invalid label: " <> show tok + +labelToIdent :: Label -> Parser (Name Ident) +labelToIdent (Label tok _) = toName Ident tok + +toString :: SourceToken -> (SourceToken, PSString) +toString tok = case tokValue tok of + TokString _ a -> (tok, a) + TokRawString a -> (tok, mkString a) + _ -> internalError $ "Invalid string literal: " <> show tok + +toChar :: SourceToken -> (SourceToken, Char) +toChar tok = case tokValue tok of + TokChar _ a -> (tok, a) + _ -> internalError $ "Invalid char literal: " <> show tok + +toNumber :: SourceToken -> (SourceToken, Either Integer Double) +toNumber tok = case tokValue tok of + TokInt _ a -> (tok, Left a) + TokNumber _ a -> (tok, Right a) + _ -> internalError $ "Invalid number literal: " <> show tok + +toInt :: SourceToken -> (SourceToken, Integer) +toInt tok = case tokValue tok of + TokInt _ a -> (tok, a) + _ -> internalError $ "Invalid integer literal: " <> show tok + +toBoolean :: SourceToken -> (SourceToken, Bool) +toBoolean tok = case tokValue tok of + TokLowerName [] "true" -> (tok, True) + TokLowerName [] "false" -> (tok, False) + _ -> internalError $ "Invalid boolean literal: " <> show tok + +toConstraint :: forall a. Monoid a => Type a -> Parser (Constraint a) +toConstraint = convertParens + where + convertParens :: Type a -> Parser (Constraint a) + convertParens = \case + TypeParens a (Wrapped b c d) -> do + c' <- convertParens c + pure $ ConstraintParens a (Wrapped b c' d) + ty -> convert mempty [] ty + + convert :: a -> [Type a] -> Type a -> Parser (Constraint a) + convert ann acc = \case + TypeApp a lhs rhs -> convert (a <> ann) (rhs : acc) lhs + TypeConstructor a name -> do + for_ acc checkNoForalls + pure $ Constraint (a <> ann) (coerce name) acc + ty -> do + let (tok1, tok2) = typeRange ty + addFailure [tok1, tok2] ErrTypeInConstraint + pure $ Constraint mempty (QualifiedName tok1 Nothing (N.ProperName " NE.NonEmpty (Binder a) -> Parser (Binder a) +toBinderConstructor = \case + BinderConstructor a name [] NE.:| bs -> + pure $ BinderConstructor a name bs + a NE.:| [] -> pure a + a NE.:| _ -> unexpectedToks binderRange (unexpectedBinder) ErrExprInBinder a + +toRecordFields + :: Monoid a + => Separated (Either (RecordLabeled (Expr a)) (RecordUpdate a)) + -> Parser (Either (Separated (RecordLabeled (Expr a))) (Separated (RecordUpdate a))) +toRecordFields = \case + Separated (Left a) as -> + Left . Separated a <$> traverse (traverse unLeft) as + Separated (Right a) as -> + Right . Separated a <$> traverse (traverse unRight) as + where + unLeft (Left tok) = pure tok + unLeft (Right tok) = + unexpectedToks recordUpdateRange unexpectedRecordLabeled ErrRecordUpdateInCtr tok + + unRight (Right tok) = pure tok + unRight (Left (RecordPun (Name tok _))) = do + addFailure [tok] ErrRecordPunInUpdate + pure $ unexpectedRecordUpdate [tok] + unRight (Left (RecordField _ tok _)) = do + addFailure [tok] ErrRecordCtrInUpdate + pure $ unexpectedRecordUpdate [tok] + +checkFundeps :: ClassHead a -> Parser () +checkFundeps (ClassHead _ _ _ _ Nothing) = pure () +checkFundeps (ClassHead _ _ _ vars (Just (_, fundeps))) = do + let + k (TypeVarKinded (Wrapped _ (Labeled a _ _) _)) = getIdent $ nameValue a + k (TypeVarName a) = getIdent $ nameValue a + names = k <$> vars + check a + | getIdent (nameValue a) `elem` names = pure () + | otherwise = addFailure [nameTok a] ErrUnknownFundep + for_ fundeps $ \case + FundepDetermined _ bs -> for_ bs check + FundepDetermines as _ bs -> do + for_ as check + for_ bs check + +data TmpModuleDecl a + = TmpImport (ImportDecl a) + | TmpChain (Separated (Declaration a)) + deriving (Show) + +toModuleDecls :: Monoid a => [TmpModuleDecl a] -> Parser ([ImportDecl a], [Declaration a]) +toModuleDecls = goImport [] + where + goImport acc (TmpImport x : xs) = goImport (x : acc) xs + goImport acc xs = (reverse acc,) <$> goDecl [] xs + + goDecl acc [] = pure $ reverse acc + goDecl acc (TmpChain (Separated x []) : xs) = goDecl (x : acc) xs + goDecl acc (TmpChain (Separated (DeclInstanceChain a (Separated h t)) t') : xs) = do + (a', instances) <- goChain (getName h) a [] t' + goDecl (DeclInstanceChain a' (Separated h (t <> instances)) : acc) xs + goDecl acc (TmpChain (Separated _ t) : xs) = do + for_ t $ \(tok, _) -> addFailure [tok] ErrElseInDecl + goDecl acc xs + goDecl acc (TmpImport imp : xs) = do + unexpectedToks importDeclRange (const ()) ErrImportInDecl imp + goDecl acc xs + + goChain _ ann acc [] = pure (ann, reverse acc) + goChain name ann acc ((tok, DeclInstanceChain a (Separated h t)) : xs) + | eqName (getName h) name = goChain name (ann <> a) (reverse ((tok, h) : t) <> acc) xs + | otherwise = do + addFailure [qualTok $ getName h] ErrInstanceNameMismatch + goChain name ann acc xs + goChain name ann acc ((tok, _) : xs) = do + addFailure [tok] ErrElseInDecl + goChain name ann acc xs + + getName = instClass . instHead + eqName (QualifiedName _ a b) (QualifiedName _ c d) = a == c && b == d + +checkNoWildcards :: Type a -> Parser () +checkNoWildcards ty = do + let + k = \case + TypeWildcard _ a -> [addFailure [a] ErrWildcardInType] + TypeHole _ a -> [addFailure [nameTok a] ErrHoleInType] + _ -> [] + sequence_ $ everythingOnTypes (<>) k ty + +checkNoForalls :: Type a -> Parser () +checkNoForalls ty = do + let + k = \case + TypeForall _ a _ _ _ -> [addFailure [a] ErrToken] + _ -> [] + sequence_ $ everythingOnTypes (<>) k ty + +revert :: Parser a -> SourceToken -> Parser a +revert p lk = pushBack lk *> p + +reservedNames :: Set Text +reservedNames = Set.fromList + [ "ado" + , "case" + , "class" + , "data" + , "derive" + , "do" + , "else" + , "false" + , "forall" + , "foreign" + , "import" + , "if" + , "in" + , "infix" + , "infixl" + , "infixr" + , "instance" + , "let" + , "module" + , "newtype" + , "of" + , "true" + , "type" + , "where" + ] + +isValidModuleNamespace :: Text -> Bool +isValidModuleNamespace = Text.null . snd . Text.span (\c -> c /= '_' && c /= '\'') diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index e3c102fb3f..79d7160e9a 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -115,7 +115,7 @@ convertModulesWithEnv :: [P.Module] -> m ([Module], P.Env) convertModulesWithEnv withPackage = - P.sortModules + P.sortModules P.moduleSignature >>> fmap (fst >>> map P.importPrim) >=> convertSorted withPackage diff --git a/src/Language/PureScript/Docs/ParseInPackage.hs b/src/Language/PureScript/Docs/ParseInPackage.hs index 7a90a84067..86ea0dc745 100644 --- a/src/Language/PureScript/Docs/ParseInPackage.hs +++ b/src/Language/PureScript/Docs/ParseInPackage.hs @@ -8,6 +8,7 @@ import qualified Data.Map as M import Language.PureScript.Docs.Types import qualified Language.PureScript as P +import qualified Language.PureScript.CST as CST import System.IO.UTF8 (readUTF8FileT) import Web.Bower.PackageMeta (PackageName) @@ -48,7 +49,7 @@ parseFilesInPackages inputFiles depsFiles = do [(FileInfo, Text)] -> m [(FileInfo, P.Module)] parse = - throwLeft . P.parseModulesFromFiles fileInfoToString + throwLeft . CST.parseFromFiles fileInfoToString inPkgToMaybe = \case Local _ -> Nothing diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 02accb831c..1677d63915 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -30,6 +30,7 @@ import Language.PureScript.AST import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.Constants as C import Language.PureScript.Crash +import qualified Language.PureScript.CST.Errors as CST import Language.PureScript.Environment import Language.PureScript.Label (Label(..)) import Language.PureScript.Names @@ -78,6 +79,7 @@ errorCode em = case unwrapErrorMessage em of ModuleNotFound{} -> "ModuleNotFound" ErrorParsingFFIModule{} -> "ErrorParsingFFIModule" ErrorParsingModule{} -> "ErrorParsingModule" + ErrorParsingCSTModule{} -> "ErrorParsingModule" MissingFFIModule{} -> "MissingFFIModule" UnnecessaryFFIModule{} -> "UnnecessaryFFIModule" MissingFFIImplementations{} -> "MissingFFIImplementations" @@ -479,6 +481,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "Unable to parse module: " , prettyPrintParseError err ] + renderSimpleErrorMessage (ErrorParsingCSTModule err) = + paras [ line "Unable to parse module: " + , line $ T.pack $ CST.prettyPrintErrorMessage err + ] renderSimpleErrorMessage (MissingFFIModule mn) = line $ "The foreign module implementation for module " <> markCode (runModuleName mn) <> " is missing." renderSimpleErrorMessage (UnnecessaryFFIModule mn path) = @@ -585,7 +591,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line $ "A cycle appears in a set of type class definitions:" , indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName . disqualify) names)) <> "}" , line "Cycles are disallowed because they can lead to loops in the type checker." - ] + ] renderSimpleErrorMessage (NameIsUndefined ident) = line $ "Value " <> markCode (showIdent ident) <> " is undefined." renderSimpleErrorMessage (UndefinedTypeVariable name) = diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 6ad0313f68..9e38117de3 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -15,6 +15,7 @@ import qualified Data.Map.Lazy as M import Data.Maybe (fromJust) import qualified Data.Set as S import qualified Language.PureScript as P +import qualified Language.PureScript.CST as CST import Language.PureScript.Ide.Error import Language.PureScript.Ide.Logging import Language.PureScript.Ide.State @@ -48,12 +49,11 @@ rebuildFile -- ^ A runner for the second build with open exports -> m Success rebuildFile file actualFile codegenTargets runOpenBuild = do - - input <- ideReadFile file - - m <- case snd <$> P.parseModuleFromFile (maybe identity const actualFile) input of + (fp, input) <- ideReadFile file + let fp' = fromMaybe fp actualFile + m <- case CST.parseFromFile fp' input of Left parseError -> - throwError (RebuildError (P.MultipleErrors [P.toPositionedError parseError])) + throwError $ RebuildError $ CST.toMultipleErrors fp' parseError Right m -> pure m -- Externs files must be sorted ahead of time, so that they get applied @@ -173,7 +173,7 @@ sortExterns -> m [P.ExternsFile] sortExterns m ex = do sorted' <- runExceptT - . P.sortModules + . P.sortModules P.moduleSignature . (:) m . map mkShallowModule . M.elems diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 27a1725f1d..bda321206c 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -26,6 +26,7 @@ import Protolude import Control.Parallel.Strategies (withStrategy, parList, rseq) import qualified Data.Map as Map import qualified Language.PureScript as P +import qualified Language.PureScript.CST as CST import Language.PureScript.Ide.Error import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util @@ -40,9 +41,9 @@ parseModule path = do parseModule' :: FilePath -> Text -> Either FilePath (FilePath, P.Module) parseModule' path file = - case P.parseModuleFromFile identity (path, file) of + case CST.parseFromFile path file of Left _ -> Left path - Right m -> Right m + Right m -> Right (path, m) parseModulesFromFiles :: (MonadIO m, MonadError IdeError m) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index fb4f45aaa9..c4b2f8e2f6 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -28,6 +28,7 @@ import Control.Monad.Trans.State.Strict (StateT, runStateT, evalStateT import Control.Monad.Writer.Strict (Writer(), runWriter) import qualified Language.PureScript as P +import qualified Language.PureScript.CST as CST import qualified Language.PureScript.Names as N import qualified Language.PureScript.Constants as C @@ -75,7 +76,7 @@ rebuild loadedExterns m = do -- | Build the collection of modules from scratch. This is usually done on startup. make - :: [(FilePath, P.Module)] + :: [(FilePath, CST.PartialResult P.Module)] -> P.Make ([P.ExternsFile], P.Environment) make ms = do foreignFiles <- P.inferForeignModules filePathMap @@ -90,7 +91,7 @@ make ms = do False filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath) - filePathMap = M.fromList $ map (\(fp, m) -> (P.getModuleName m, Right fp)) ms + filePathMap = M.fromList $ map (\(fp, m) -> (P.getModuleName $ CST.resPartial m, Right fp)) ms -- | Performs a PSCi command handleCommand @@ -127,7 +128,7 @@ handleReloadState reload = do files <- liftIO $ concat <$> traverse glob globs e <- runExceptT $ do modules <- ExceptT . liftIO $ loadAllModules files - (externs, _) <- ExceptT . liftIO . runMake . make $ modules + (externs, _) <- ExceptT . liftIO . runMake . make $ fmap CST.pureResult <$> modules return (map snd modules, externs) case e of Left errs -> printErrors errs diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 0633feaffb..a2bf230ea9 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -4,6 +4,7 @@ import Prelude.Compat import Control.Monad import qualified Language.PureScript as P +import qualified Language.PureScript.CST as CST import Language.PureScript.Interactive.Types import System.Directory (getCurrentDirectory) import System.FilePath (pathSeparator, makeRelative) @@ -16,8 +17,8 @@ supportModuleName :: P.ModuleName supportModuleName = fst initialInteractivePrint -- | Checks if the Console module is defined -supportModuleIsDefined :: [P.Module] -> Bool -supportModuleIsDefined = any ((== supportModuleName) . P.getModuleName) +supportModuleIsDefined :: [P.ModuleName] -> Bool +supportModuleIsDefined = any ((== supportModuleName)) -- * Module Management @@ -28,7 +29,7 @@ loadModule filename = do content <- readUTF8FileT filename return $ either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd}) (Right . map snd) $ - P.parseModulesFromFiles id [(filename, content)] + CST.parseFromFiles id [(filename, content)] -- | Load all modules. loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)]) @@ -37,7 +38,7 @@ loadAllModules files = do filesAndContent <- forM files $ \filename -> do content <- readUTF8FileT filename return (filename, content) - return $ P.parseModulesFromFiles (makeRelative pwd) filesAndContent + return $ CST.parseFromFiles (makeRelative pwd) filesAndContent -- | -- Makes a volatile module to execute the current expression. diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 1d7c0e4e92..abc2914ef5 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -27,6 +27,7 @@ import qualified Data.Map as M import qualified Data.Set as S import Language.PureScript.AST import Language.PureScript.Crash +import qualified Language.PureScript.CST as CST import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Externs @@ -86,19 +87,23 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do -- having to typecheck the module again. make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m - -> [Module] + -> [CST.PartialResult Module] -> m [ExternsFile] make ma@MakeActions{..} ms = do checkModuleNames - (sorted, graph) <- sortModules ms + (sorted, graph) <- sortModules (moduleSignature . CST.resPartial) ms buildPlan <- BuildPlan.construct ma (sorted, graph) - let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName) sorted + let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted for_ toBeRebuilt $ \m -> fork $ do - let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph) - buildModule buildPlan (importPrim m) (deps `inOrderOf` map getModuleName sorted) + let moduleName = getModuleName . CST.resPartial $ m + let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph) + buildModule buildPlan moduleName + (spanName . getModuleSourceSpan . CST.resPartial $ m) + (importPrim <$> CST.resFull m) + (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted) -- Wait for all threads to complete, and collect errors. errors <- BuildPlan.collectErrors buildPlan @@ -113,7 +118,7 @@ make ma@MakeActions{..} ms = do -- so they can be folded into an Environment. This result is used in the tests -- and in PSCI. let lookupResult mn = fromMaybe (internalError "make: module not found in results") (M.lookup mn results) - return (map (lookupResult . getModuleName) sorted) + return (map (lookupResult . getModuleName . CST.resPartial) sorted) where checkModuleNames :: m () @@ -122,18 +127,18 @@ make ma@MakeActions{..} ms = do checkNoPrim :: m () checkNoPrim = for_ ms $ \m -> - let mn = getModuleName m + let mn = getModuleName $ CST.resPartial m in when (isBuiltinModuleName mn) $ throwError - . errorMessage' (getModuleSourceSpan m) + . errorMessage' (getModuleSourceSpan $ CST.resPartial m) $ CannotDefinePrimModules mn checkModuleNamesAreUnique :: m () checkModuleNamesAreUnique = - for_ (findDuplicates getModuleName ms) $ \mss -> + for_ (findDuplicates (getModuleName . CST.resPartial) ms) $ \mss -> throwError . flip foldMap mss $ \ms' -> - let mn = getModuleName (NEL.head ms') - in errorMessage'' (fmap getModuleSourceSpan ms') $ DuplicateModule mn + let mn = getModuleName . CST.resPartial . NEL.head $ ms' + in errorMessage'' (fmap (getModuleSourceSpan . CST.resPartial) ms') $ DuplicateModule mn -- Find all groups of duplicate values in a list based on a projection. findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [NEL.NonEmpty a] @@ -146,8 +151,9 @@ make ma@MakeActions{..} ms = do inOrderOf :: (Ord a) => [a] -> [a] -> [a] inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys - buildModule :: BuildPlan -> Module -> [ModuleName] -> m () - buildModule buildPlan m@(Module _ _ moduleName _ _) deps = flip catchError (complete Nothing . Just) $ do + buildModule :: BuildPlan -> ModuleName -> FilePath -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m () + buildModule buildPlan moduleName fp mres deps = flip catchError (complete Nothing . Just) $ do + m <- CST.unwrapParserError fp mres -- We need to wait for dependencies to be built, before checking if the current -- module should be rebuilt, so the first thing to do is to wait on the -- MVars for the module's dependencies. diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index a60bcd3c10..126ed44aa9 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -21,6 +21,7 @@ import Data.Time.Clock (UTCTime) import Data.Version (showVersion) import Language.PureScript.AST import Language.PureScript.Crash +import qualified Language.PureScript.CST as CST import Language.PureScript.Errors import Language.PureScript.Externs import Language.PureScript.Make.Actions as Actions @@ -105,20 +106,20 @@ getResult buildPlan moduleName = construct :: forall m. (Monad m, MonadBaseControl IO m) => MakeActions m - -> ([Module], [(ModuleName, [ModuleName])]) + -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])]) -> m BuildPlan construct MakeActions{..} (sorted, graph) = do prebuilt <- foldM findExistingExtern M.empty sorted - let toBeRebuilt = filter (not . flip M.member prebuilt . getModuleName) sorted - buildJobs <- foldM makeBuildJob M.empty (map getModuleName toBeRebuilt) + let toBeRebuilt = filter (not . flip M.member prebuilt . getModuleName . CST.resPartial) sorted + buildJobs <- foldM makeBuildJob M.empty (map (getModuleName . CST.resPartial) toBeRebuilt) pure $ BuildPlan prebuilt buildJobs where makeBuildJob prev moduleName = do buildJob <- BuildJob <$> C.newEmptyMVar <*> C.newEmptyMVar pure (M.insert moduleName buildJob prev) - findExistingExtern :: M.Map ModuleName Prebuilt -> Module -> m (M.Map ModuleName Prebuilt) - findExistingExtern prev (getModuleName -> moduleName) = do + findExistingExtern :: M.Map ModuleName Prebuilt -> CST.PartialResult Module -> m (M.Map ModuleName Prebuilt) + findExistingExtern prev (getModuleName . CST.resPartial -> moduleName) = do outputTimestamp <- getOutputTimestamp moduleName let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph) case traverse (fmap pbModificationTime . flip M.lookup prev) deps of diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index f2d0669a43..1152de2527 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -2,6 +2,8 @@ module Language.PureScript.ModuleDependencies ( sortModules , ModuleGraph + , ModuleSignature(..) + , moduleSignature ) where import Protolude hiding (head) @@ -17,28 +19,38 @@ import Language.PureScript.Names -- | A list of modules with their transitive dependencies type ModuleGraph = [(ModuleName, [ModuleName])] +-- | A module signature for sorting dependencies. +data ModuleSignature = ModuleSignature + { sigSourceSpan :: SourceSpan + , sigModuleName :: ModuleName + , sigDecls :: [Declaration] + } + -- | Sort a collection of modules based on module dependencies. -- -- Reports an error if the module graph contains a cycle. sortModules - :: forall m + :: forall m a . MonadError MultipleErrors m - => [Module] - -> m ([Module], ModuleGraph) -sortModules ms = do - let mns = S.fromList $ map getModuleName ms - verts <- parU ms (toGraphNode mns) - ms' <- parU (stronglyConnComp verts) toModule + => (a -> ModuleSignature) + -> [a] + -> m ([a], ModuleGraph) +sortModules toSig ms = do + let + ms' = (\m -> (m, toSig m)) <$> ms + mns = S.fromList $ map (sigModuleName . snd) ms' + verts <- parU ms' (toGraphNode mns) + ms'' <- parU (stronglyConnComp verts) toModule let (graph, fromVertex, toVertex) = graphFromEdges verts moduleGraph = do (_, mn, _) <- verts let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn) deps = reachable graph v toKey i = case fromVertex i of (_, key, _) -> key return (mn, filter (/= mn) (map toKey deps)) - return (ms', moduleGraph) + return (fst <$> ms'', moduleGraph) where - toGraphNode :: S.Set ModuleName -> Module -> m (Module, ModuleName, [ModuleName]) - toGraphNode mns m@(Module _ _ mn ds _) = do + toGraphNode :: S.Set ModuleName -> (a, ModuleSignature) -> m ((a, ModuleSignature), ModuleName, [ModuleName]) + toGraphNode mns m@(_, ModuleSignature _ mn ds) = do let deps = ordNub (mapMaybe usedModules ds) void . parU deps $ \(dep, pos) -> when (dep `notElem` C.primModules && S.notMember dep mns) . @@ -46,7 +58,7 @@ sortModules ms = do . addHint (ErrorInModule mn) . errorMessage' pos $ ModuleNotFound dep - pure (m, getModuleName m, map fst deps) + pure (m, mn, map fst deps) -- | Calculate a list of used modules based on explicit imports and qualified names. usedModules :: Declaration -> Maybe (ModuleName, SourceSpan) @@ -56,7 +68,7 @@ usedModules (ImportDeclaration (ss, _) mn _ _) = pure (mn, ss) usedModules _ = Nothing -- | Convert a strongly connected component of the module graph to a module -toModule :: MonadError MultipleErrors m => SCC Module -> m Module +toModule :: MonadError MultipleErrors m => SCC (a, ModuleSignature) -> m (a, ModuleSignature) toModule (AcyclicSCC m) = return m toModule (CyclicSCC ms) = case nonEmpty ms of @@ -64,5 +76,8 @@ toModule (CyclicSCC ms) = internalError "toModule: empty CyclicSCC" Just ms' -> throwError - . errorMessage'' (fmap getModuleSourceSpan ms') - $ CycleInModules (map getModuleName ms) + . errorMessage'' (fmap (sigSourceSpan . snd) ms') + $ CycleInModules (map (sigModuleName . snd) ms) + +moduleSignature :: Module -> ModuleSignature +moduleSignature (Module ss _ mn ds _) = ModuleSignature ss mn ds diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index c7c3a945d8..f1cf76eda3 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -4,15 +4,12 @@ module Language.PureScript.Parser.Declarations , parseDeclarationRef , parseModule , parseModuleDeclaration - , parseModulesFromFiles - , parseModuleFromFile , parseValue , parseGuard , parseBinder , parseBinderNoParens , parseImportDeclaration' , parseLocalDeclaration - , toPositionedError ) where import Prelude hiding (lex) @@ -21,15 +18,12 @@ import Protolude (ordNub) import Control.Applicative import Control.Arrow ((+++)) import Control.Monad (foldM, join, zipWithM) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Parallel.Strategies (withStrategy, parList, rseq) import Data.Functor (($>)) import Data.Maybe (fromMaybe) import qualified Data.Set as S -import Data.Text (Text, pack) +import Data.Text (pack) import Language.PureScript.AST import Language.PureScript.Environment -import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Parser.Common import Language.PureScript.Parser.Kinds @@ -321,43 +315,6 @@ parseModule = do let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end) return $ Module ss comments name decls exports --- | Parse a collection of modules in parallel -parseModulesFromFiles - :: forall m k - . MonadError MultipleErrors m - => (k -> FilePath) - -> [(k, Text)] - -> m [(k, Module)] -parseModulesFromFiles toFilePath input = - flip parU wrapError . inParallel . flip fmap input $ parseModuleFromFile toFilePath - where - wrapError :: Either P.ParseError a -> m a - wrapError = either (throwError . MultipleErrors . pure . toPositionedError) return - -- It is enough to force each parse result to WHNF, since success or failure can't be - -- determined until the end of the file, so this effectively distributes parsing of each file - -- to a different spark. - inParallel :: [Either P.ParseError (k, a)] -> [Either P.ParseError (k, a)] - inParallel = withStrategy (parList rseq) - --- | Parses a single module with FilePath for eventual parsing errors -parseModuleFromFile - :: (k -> FilePath) - -> (k, Text) - -> Either P.ParseError (k, Module) -parseModuleFromFile toFilePath (k, content) = do - let filename = toFilePath k - ts <- lex filename content - m <- runTokenParser filename parseModule ts - pure (k, m) - --- | Converts a 'ParseError' into a 'PositionedError' -toPositionedError :: P.ParseError -> ErrorMessage -toPositionedError perr = ErrorMessage [ positionedError (SourceSpan name start end) ] (ErrorParsingModule perr) - where - name = (P.sourceName . P.errorPos) perr - start = (toSourcePos . P.errorPos) perr - end = start - booleanLiteral :: TokenParser Bool booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False) diff --git a/tests/Language/PureScript/Ide/UsageSpec.hs b/tests/Language/PureScript/Ide/UsageSpec.hs index d1e83ebaad..3c619dce3b 100644 --- a/tests/Language/PureScript/Ide/UsageSpec.hs +++ b/tests/Language/PureScript/Ide/UsageSpec.hs @@ -47,7 +47,7 @@ spec = describe "Finding Usages" $ do , usage (Test.mn "FindUsage.Definition") "usageId" IdeNSValue ] usage1 `shouldBeUsage` ("src" "FindUsage.purs", "12:11-12:18") - usage2 `shouldBeUsage` ("src" "FindUsage" "Definition.purs", "13:18-13:18") + usage2 `shouldBeUsage` ("src" "FindUsage" "Definition.purs", "13:18-13:25") it "finds a simple recursive usage" $ do ([_, Right (UsagesResult [usage1])], _) <- Test.inProject $ Test.runIde [ load ["FindUsage.Recursive"] @@ -77,6 +77,4 @@ spec = describe "Finding Usages" $ do Test.runIde [ load ["FindUsage", "FindUsage.Definition", "FindUsage.Reexport"] , usage (Test.mn "FindUsage.Reexport") "toBeReexported" IdeNSValue ] - -- TODO(Christoph): Interesting parser bug here. It seems the position - -- of the last token in the file has the wrong ending span - usage1 `shouldBeUsage` ("src" "FindUsage.purs", "12:19-12:19") + usage1 `shouldBeUsage` ("src" "FindUsage.purs", "12:19-12:33") diff --git a/tests/Main.hs b/tests/Main.hs index e7c29b4094..37bf70b20a 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -10,6 +10,7 @@ import Prelude.Compat import Test.Tasty +import qualified TestCst import qualified TestCompiler import qualified TestCoreFn import qualified TestDocs @@ -31,6 +32,7 @@ main = do heading "Updating support code" TestUtils.updateSupportCode + cstTests <- TestCst.main ideTests <- TestIde.main compilerTests <- TestCompiler.main psciTests <- TestPsci.main @@ -44,7 +46,8 @@ main = do defaultMain $ testGroup "Tests" - [ compilerTests + [ cstTests + , compilerTests , psciTests , pscBundleTests , ideTests diff --git a/tests/TestCst.hs b/tests/TestCst.hs new file mode 100644 index 0000000000..abaddc07c1 --- /dev/null +++ b/tests/TestCst.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module TestCst where + +import Prelude + +import Control.Monad (when) +import qualified Data.ByteString.Lazy as BS +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.IO as Text +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Golden (goldenVsString, findByExtension) +import Test.Tasty.QuickCheck +import Text.Read (readMaybe) +import Language.PureScript.CST.Errors as CST +import Language.PureScript.CST.Lexer as CST +import Language.PureScript.CST.Print as CST +import Language.PureScript.CST.Types +import System.FilePath (takeBaseName, replaceExtension) + +main :: IO TestTree +main = do + lytTests <- layoutTests + pure $ testGroup "cst" + [ lytTests + , litTests + ] + +layoutTests :: IO TestTree +layoutTests = do + pursFiles <- findByExtension [".purs"] "./tests/purs/layout" + return $ testGroup "Layout golden tests" $ do + file <- pursFiles + pure $ goldenVsString + (takeBaseName file) + (replaceExtension file ".out") + (BS.fromStrict . Text.encodeUtf8 <$> runLexer file) + where + runLexer file = do + src <- Text.readFile file + case sequence $ CST.lex src of + Left (_, err) -> + pure $ Text.pack $ CST.prettyPrintError err + Right toks -> do + pure $ CST.printTokens toks + +litTests :: TestTree +litTests = testGroup "Literals" + [ testProperty "Integer" $ + checkTok checkReadNum (\case TokInt _ a -> Just a; _ -> Nothing) . unInt + , testProperty "Hex" $ + checkTok checkReadNum (\case TokInt _ a -> Just a; _ -> Nothing) . unHex + , testProperty "Number" $ + checkTok checkReadNum (\case TokNumber _ a -> Just a; _ -> Nothing) . unFloat + , testProperty "Exponent" $ + checkTok checkReadNum (\case TokNumber _ a -> Just a; _ -> Nothing) . unExponent + + , testProperty "Integer (round trip)" $ roundTripTok . unInt + , testProperty "Hex (round trip)" $ roundTripTok . unHex + , testProperty "Number (round trip)" $ roundTripTok . unFloat + , testProperty "Exponent (round trip)" $ roundTripTok . unExponent + , testProperty "Char (round trip)" $ roundTripTok . unChar + , testProperty "String (round trip)" $ roundTripTok . unString + , testProperty "Raw String (round trip)" $ roundTripTok . unRawString + ] + +readTok :: Text -> Gen SourceToken +readTok t = case CST.lex t of + Right tok : _ -> + pure tok + Left (_, err) : _ -> + fail $ "Failed to parse: " <> CST.prettyPrintError err + [] -> + fail "Empty token stream" + +checkTok + :: (Text -> a -> Gen Bool) + -> (Token -> Maybe a) + -> Text + -> Gen Bool +checkTok p f t = do + SourceToken _ tok <- readTok t + case f tok of + Just a -> p t a + Nothing -> fail $ "Failed to lex correctly: " <> show tok + +roundTripTok :: Text -> Gen Bool +roundTripTok t = do + tok <- readTok t + let t' = CST.printTokens [tok] + tok' <- readTok t' + pure $ tok == tok' + +checkReadNum :: (Eq a, Read a) => Text -> a -> Gen Bool +checkReadNum t a = do + let + chs = case Text.unpack $ Text.replace ".e" ".0e" $ Text.replace "_" "" t of + chs' | last chs' == '.' -> chs' <> "0" + chs' -> chs' + case (== a) <$> readMaybe chs of + Just a' -> pure a' + Nothing -> fail "Failed to `read`" + +newtype PSSourceInt = PSSourceInt { unInt :: Text } + deriving (Show, Eq) + +instance Arbitrary PSSourceInt where + arbitrary = resize 16 genInt + +newtype PSSourceFloat = PSSourceFloat { unFloat :: Text } + deriving (Show, Eq) + +instance Arbitrary PSSourceFloat where + arbitrary = resize 16 genFloat + +newtype PSSourceExponent = PSSourceExponent { unExponent :: Text } + deriving (Show, Eq) + +instance Arbitrary PSSourceExponent where + arbitrary = PSSourceExponent <$> do + floatPart <- unFloat <$> resize 5 genFloat + signPart <- fromMaybe "" <$> elements [ Just "+", Just "-", Nothing ] + expPart <- unInt <$> resize 1 genInt + pure $ floatPart <> "e" <> signPart <> expPart + +newtype PSSourceHex = PSSourceHex { unHex :: Text } + deriving (Show, Eq) + +instance Arbitrary PSSourceHex where + arbitrary = resize 16 genHex + +newtype PSSourceChar = PSSourceChar { unChar :: Text } + deriving (Show, Eq) + +instance Arbitrary PSSourceChar where + arbitrary = genChar + +newtype PSSourceString = PSSourceString { unString :: Text } + deriving (Show, Eq) + +instance Arbitrary PSSourceString where + arbitrary = resize 256 genString + +newtype PSSourceRawString = PSSourceRawString { unRawString :: Text } + deriving (Show, Eq) + +instance Arbitrary PSSourceRawString where + arbitrary = resize 256 genRawString + +genInt :: Gen PSSourceInt +genInt = PSSourceInt . Text.pack <$> do + (:) <$> nonZeroChar + <*> listOf numChar + +genFloat :: Gen PSSourceFloat +genFloat = PSSourceFloat <$> do + intPart <- unInt <$> genInt + floatPart <- Text.pack <$> listOf1 numChar + pure $ intPart <> "." <> floatPart + +genHex :: Gen PSSourceHex +genHex = PSSourceHex <$> do + nums <- listOf1 hexDigit + pure $ "0x" <> Text.pack nums + +genChar :: Gen PSSourceChar +genChar = PSSourceChar <$> do + ch <- (toEnum :: Int -> Char) <$> resize 0xFFFF arbitrarySizedNatural + ch' <- case ch of + '\'' -> discard + '\\' -> genCharEscape + c -> pure $ Text.singleton c + pure $ "'" <> ch' <> "'" + +genString :: Gen PSSourceString +genString = PSSourceString <$> do + chs <- listOf $ arbitraryUnicodeChar >>= \case + '"' -> discard + '\n' -> discard + '\r' -> discard + '\\' -> genCharEscape + c -> pure $ Text.singleton c + pure $ "\"" <> Text.concat chs <> "\"" + +genRawString :: Gen PSSourceRawString +genRawString = PSSourceRawString <$> do + chs <- listOf $ arbitraryUnicodeChar + let + k1 acc qs cs = do + let (cs', q) = span (/= '"') cs + k2 (acc <> cs') qs q + k2 acc qs [] = acc <> qs + k2 acc qs cs = do + let (q, cs') = span (== '"') cs + k1 (acc <> take 2 q) (qs <> drop 2 q) cs' + chs' = k1 [] [] chs + when (all (== '"') chs') discard + pure $ "\"\"\"" <> Text.pack chs' <> "\"\"\"" + +genCharEscape :: Gen Text +genCharEscape = oneof + [ pure "\\t" + , pure "\\r" + , pure "\\n" + , pure "\\\"" + , pure "\\'" + , pure "\\\\" + , do + chs <- resize 4 $ listOf1 hexDigit + pure $ "\\x" <> Text.pack chs + ] + +numChar :: Gen Char +numChar = elements "0123456789_" + +nonZeroChar :: Gen Char +nonZeroChar = elements "123456789" + +hexDigit :: Gen Char +hexDigit = elements $ ['a'..'f'] <> ['A'..'F'] <> ['0'..'9'] diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 646d93bcd6..31d5fdc591 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -13,6 +13,7 @@ import Data.Foldable (traverse_) import Data.List (isSuffixOf) import qualified Data.Text as T import qualified Language.PureScript as P +import qualified Language.PureScript.CST as CST import Language.PureScript.Interactive import System.Directory (getCurrentDirectory, doesPathExist, removeFile) import System.Exit @@ -39,7 +40,7 @@ initTestPSCiEnv = do print err >> exitFailure Right modules -> do -- Make modules - makeResultOrError <- runMake . make $ modules + makeResultOrError <- runMake . make $ fmap CST.pureResult <$> modules case makeResultOrError of Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure Right (externs, _) -> diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index f2c477f648..fe0c14d41d 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -8,6 +8,7 @@ import Prelude () import Prelude.Compat import qualified Language.PureScript as P +import qualified Language.PureScript.CST as CST import Control.Arrow ((***), (>>>)) import Control.Monad @@ -29,7 +30,7 @@ import System.IO.UTF8 (readUTF8FileT) import System.Exit (exitFailure) import System.FilePath import qualified System.FilePath.Glob as Glob -import System.IO +import System.IO import Test.Tasty.Hspec @@ -82,7 +83,7 @@ getSupportModuleTuples = do libraries <- Glob.globDir1 (Glob.compile "purescript-*/src/**/*.purs") (supportDir "bower_components") let pursFiles = psciFiles ++ libraries fileContents <- readInput pursFiles - modules <- runExceptT $ ExceptT . return $ P.parseModulesFromFiles id fileContents + modules <- runExceptT $ ExceptT . return $ CST.parseFromFiles id fileContents case modules of Right ms -> return ms Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) @@ -111,7 +112,7 @@ setupSupportModules = do let modules = map snd ms supportExterns <- runExceptT $ do foreigns <- inferForeignModules ms - externs <- ExceptT . fmap fst . runTest $ P.make (makeActions modules foreigns) modules + externs <- ExceptT . fmap fst . runTest $ P.make (makeActions modules foreigns) (CST.pureResult <$> modules) return (externs, foreigns) case supportExterns of Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) @@ -168,13 +169,13 @@ compile -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) compile supportModules supportExterns supportForeigns inputFiles check = runTest $ do fs <- liftIO $ readInput inputFiles - ms <- P.parseModulesFromFiles id fs + ms <- CST.parseFromFiles id fs foreigns <- inferForeignModules ms liftIO (check (map snd ms)) let actions = makeActions supportModules (foreigns `M.union` supportForeigns) case ms of [singleModule] -> pure <$> P.rebuildModule actions supportExterns (snd singleModule) - _ -> P.make actions (supportModules ++ map snd ms) + _ -> P.make actions (CST.pureResult <$> supportModules ++ map snd ms) assert :: [P.Module] diff --git a/tests/purs/failing/2616.purs b/tests/purs/failing/2616.purs index 55ff1887bb..94663b988f 100644 --- a/tests/purs/failing/2616.purs +++ b/tests/purs/failing/2616.purs @@ -1,6 +1,6 @@ -- @shouldFailWith NoInstanceFound module Main where - + import Prelude newtype Foo r = Foo { | r } diff --git a/tests/purs/failing/ImportHidingModule.purs b/tests/purs/failing/ImportHidingModule.purs index bda20bed92..1fa49ce9b8 100644 --- a/tests/purs/failing/ImportHidingModule.purs +++ b/tests/purs/failing/ImportHidingModule.purs @@ -1,4 +1,4 @@ --- @shouldFailWith ImportHidingModule +-- @shouldFailWith ErrorParsingModule module Main where import B hiding (module A) diff --git a/tests/purs/failing/NewtypeMultiArgs.purs b/tests/purs/failing/NewtypeMultiArgs.purs index b3ceed3a80..cf5b57dc38 100644 --- a/tests/purs/failing/NewtypeMultiArgs.purs +++ b/tests/purs/failing/NewtypeMultiArgs.purs @@ -1,4 +1,4 @@ --- @shouldFailWith InvalidNewtype +-- @shouldFailWith ErrorParsingModule module Main where import Prelude diff --git a/tests/purs/failing/NewtypeMultiCtor.purs b/tests/purs/failing/NewtypeMultiCtor.purs index 04b4cee943..b5eaefd8d5 100644 --- a/tests/purs/failing/NewtypeMultiCtor.purs +++ b/tests/purs/failing/NewtypeMultiCtor.purs @@ -1,4 +1,4 @@ --- @shouldFailWith InvalidNewtype +-- @shouldFailWith ErrorParsingModule module Main where import Prelude diff --git a/tests/purs/failing/NonExhaustivePatGuard.purs b/tests/purs/failing/NonExhaustivePatGuard.purs index cdcfc2f1e0..b49a87c2bd 100644 --- a/tests/purs/failing/NonExhaustivePatGuard.purs +++ b/tests/purs/failing/NonExhaustivePatGuard.purs @@ -2,4 +2,4 @@ module Main where f :: Int -> Int -f x | 1 <- x = x \ No newline at end of file +f x | 1 <- x = x diff --git a/tests/purs/failing/OperatorAt.purs b/tests/purs/failing/OperatorAt.purs new file mode 100644 index 0000000000..b32cfc00e5 --- /dev/null +++ b/tests/purs/failing/OperatorAt.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +import Prelude + +infix 1 const as @ + +test = 1 @ 2 diff --git a/tests/purs/failing/OperatorBackslash.purs b/tests/purs/failing/OperatorBackslash.purs new file mode 100644 index 0000000000..7a6333ff95 --- /dev/null +++ b/tests/purs/failing/OperatorBackslash.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +import Prelude + +infix 1 const as \ + +test = 1 \ 2 diff --git a/tests/purs/failing/PrimRow.purs b/tests/purs/failing/PrimRow.purs index e9dfe05373..13a966fa16 100644 --- a/tests/purs/failing/PrimRow.purs +++ b/tests/purs/failing/PrimRow.purs @@ -5,8 +5,6 @@ import Prelude -- The 'Cons' class is not imported here, so we should not be able to refer to -- it in the module. -import Prim.Row () - x :: Cons "hello" Int () ("hello" :: Int) => Unit x = unit diff --git a/tests/purs/failing/TypeClasses2.purs b/tests/purs/failing/TypeClasses2.purs index 16f6175b5f..df5cb329c2 100644 --- a/tests/purs/failing/TypeClasses2.purs +++ b/tests/purs/failing/TypeClasses2.purs @@ -1,8 +1,6 @@ -- @shouldFailWith NoInstanceFound module Main where -import Prelude () - class Show a where show :: a -> String diff --git a/tests/purs/failing/Whitespace1.purs b/tests/purs/failing/Whitespace1.purs new file mode 100644 index 0000000000..b73805a0c7 --- /dev/null +++ b/tests/purs/failing/Whitespace1.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +test = do + test diff --git a/tests/purs/layout/AdoIn.out b/tests/purs/layout/AdoIn.out new file mode 100644 index 0000000000..0a9436e059 --- /dev/null +++ b/tests/purs/layout/AdoIn.out @@ -0,0 +1,9 @@ +module Test where{ + +test = ado{ + baz; + let {foo = bar}} + in bar; + +test = ado {}in foo} + \ No newline at end of file diff --git a/tests/purs/layout/AdoIn.purs b/tests/purs/layout/AdoIn.purs new file mode 100644 index 0000000000..1fffa4dc93 --- /dev/null +++ b/tests/purs/layout/AdoIn.purs @@ -0,0 +1,8 @@ +module Test where + +test = ado + baz + let foo = bar + in bar + +test = ado in foo diff --git a/tests/purs/layout/CaseGuards.out b/tests/purs/layout/CaseGuards.out new file mode 100644 index 0000000000..c86e4b02a2 --- /dev/null +++ b/tests/purs/layout/CaseGuards.out @@ -0,0 +1,54 @@ +module Test where{ + +-- Including data because of `|` masking +data Foo + = Foo + | Bar + | Baz; + +test = + case foo of{ + a | b, c -> + d; + a | b, c -> d}; + +test = case a, b of{ + c, d + | e -> + case e of{ + f | true -> bar + | false -> baz} + | f -> g}; + +test a + | false = + case false of{ + true | a > 12 -> true} + | otherwise = true; + +test = case a of {foo | foo \a -> a -> true}; + +test = a `case _ of {x | unit # \_ -> true, true -> const}` b; + +test = case a of{ + 12 | do {that; + that }-> this + | otherwise -> this}; + +test a b = [ case _ of{ + 12 | case a, b of{ + _, 42 -> b; + _, 12 -> false}, b -> true + | case a, b of{ + _, 42 -> b; + _, 12 -> false}, b -> true}, false ]; + +test a + | case a, b of{ + _, 42 -> b; + _, 12 -> false}, b = true + | case a, b of{ + _, 42 -> b; + _, 12 -> false}, b = true} + + \ No newline at end of file diff --git a/tests/purs/layout/CaseGuards.purs b/tests/purs/layout/CaseGuards.purs new file mode 100644 index 0000000000..6c328ea3b9 --- /dev/null +++ b/tests/purs/layout/CaseGuards.purs @@ -0,0 +1,53 @@ +module Test where + +-- Including data because of `|` masking +data Foo + = Foo + | Bar + | Baz + +test = + case foo of + a | b, c -> + d + a | b, c -> d + +test = case a, b of + c, d + | e -> + case e of + f | true -> bar + | false -> baz + | f -> g + +test a + | false = + case false of + true | a > 12 -> true + | otherwise = true + +test = case a of foo | foo \a -> a -> true + +test = a `case _ of x | unit # \_ -> true, true -> const` b + +test = case a of + 12 | do that + that -> this + | otherwise -> this + +test a b = [ case _ of + 12 | case a, b of + _, 42 -> b + _, 12 -> false, b -> true + | case a, b of + _, 42 -> b + _, 12 -> false, b -> true, false ] + +test a + | case a, b of + _, 42 -> b + _, 12 -> false, b = true + | case a, b of + _, 42 -> b + _, 12 -> false, b = true + diff --git a/tests/purs/layout/CaseWhere.out b/tests/purs/layout/CaseWhere.out new file mode 100644 index 0000000000..657b2545d3 --- /dev/null +++ b/tests/purs/layout/CaseWhere.out @@ -0,0 +1,13 @@ +module Test where{ + +test = case foo of{ + Nothing -> a + where {a = 12}; + Just a -> do{ + what}} + where{ + foo = bar}; + +test = case f of {Foo -> do {that} + where {foo = 12}}} + \ No newline at end of file diff --git a/tests/purs/layout/CaseWhere.purs b/tests/purs/layout/CaseWhere.purs new file mode 100644 index 0000000000..8af0a6eb8c --- /dev/null +++ b/tests/purs/layout/CaseWhere.purs @@ -0,0 +1,12 @@ +module Test where + +test = case foo of + Nothing -> a + where a = 12 + Just a -> do + what + where + foo = bar + +test = case f of Foo -> do that + where foo = 12 diff --git a/tests/purs/layout/ClassHead.out b/tests/purs/layout/ClassHead.out new file mode 100644 index 0000000000..63388dabf6 --- /dev/null +++ b/tests/purs/layout/ClassHead.out @@ -0,0 +1,11 @@ +module Test where{ + +import Foo (class Foo); + +class Foo a b c d | a -> b, c -> d where{ + foo :: Foo}; + +class Foo a b c d | a -> b, c -> d; + +instance foo :: Foo} + \ No newline at end of file diff --git a/tests/purs/layout/ClassHead.purs b/tests/purs/layout/ClassHead.purs new file mode 100644 index 0000000000..92275e2848 --- /dev/null +++ b/tests/purs/layout/ClassHead.purs @@ -0,0 +1,10 @@ +module Test where + +import Foo (class Foo) + +class Foo a b c d | a -> b, c -> d where + foo :: Foo + +class Foo a b c d | a -> b, c -> d + +instance foo :: Foo diff --git a/tests/purs/layout/Commas.out b/tests/purs/layout/Commas.out new file mode 100644 index 0000000000..4125e3d2d7 --- /dev/null +++ b/tests/purs/layout/Commas.out @@ -0,0 +1,23 @@ +module Test where{ + +test = + [ case do {foo}, bar of{ + a | b, c -> d}, bar + ]; + +test = + [ case do {foo}, bar of {a | b, c -> d}, bar ]; + +test = + [ do {do {do {foo}}}, bar ]; + +test = + [ \foo -> foo, bar ]; + +test = foo where{ + bar = + case a, b of{ + c, d | d == [case true, w of {1, a -> true}, false ] -> d; + e, d | do {what}, do {that }-> d}}} + + \ No newline at end of file diff --git a/tests/purs/layout/Commas.purs b/tests/purs/layout/Commas.purs new file mode 100644 index 0000000000..6d70b72e70 --- /dev/null +++ b/tests/purs/layout/Commas.purs @@ -0,0 +1,22 @@ +module Test where + +test = + [ case do foo, bar of + a | b, c -> d, bar + ] + +test = + [ case do foo, bar of a | b, c -> d, bar ] + +test = + [ do do do foo, bar ] + +test = + [ \foo -> foo, bar ] + +test = foo where + bar = + case a, b of + c, d | d == [case true, w of 1, a -> true, false ] -> d + e, d | do what, do that -> d + diff --git a/tests/purs/layout/Delimiter.out b/tests/purs/layout/Delimiter.out new file mode 100644 index 0000000000..e7a7417c5d --- /dev/null +++ b/tests/purs/layout/Delimiter.out @@ -0,0 +1,14 @@ +module Test where{ + +test1 = a; +test2 = { + b +}; +test3 = do{ + foo; + bar ( + baz + ) == 12; + baz}; +test4 = c} + \ No newline at end of file diff --git a/tests/purs/layout/Delimiter.purs b/tests/purs/layout/Delimiter.purs new file mode 100644 index 0000000000..537a1cb81a --- /dev/null +++ b/tests/purs/layout/Delimiter.purs @@ -0,0 +1,13 @@ +module Test where + +test1 = a +test2 = { + b +} +test3 = do + foo + bar ( + baz + ) == 12 + baz +test4 = c diff --git a/tests/purs/layout/DoOperator.out b/tests/purs/layout/DoOperator.out new file mode 100644 index 0000000000..0c511a26cf --- /dev/null +++ b/tests/purs/layout/DoOperator.out @@ -0,0 +1,9 @@ +module Test where{ + +test = do{ + foo; + foo do{ + bar}} + <|> bar} + + \ No newline at end of file diff --git a/tests/purs/layout/DoOperator.purs b/tests/purs/layout/DoOperator.purs new file mode 100644 index 0000000000..1d9a82c53f --- /dev/null +++ b/tests/purs/layout/DoOperator.purs @@ -0,0 +1,8 @@ +module Test where + +test = do + foo + foo do + bar + <|> bar + diff --git a/tests/purs/layout/DoWhere.out b/tests/purs/layout/DoWhere.out new file mode 100644 index 0000000000..270124b57b --- /dev/null +++ b/tests/purs/layout/DoWhere.out @@ -0,0 +1,7 @@ +module Test where{ + +test = + do{ + do {do{ + foo }}}where {bar = baz}} + \ No newline at end of file diff --git a/tests/purs/layout/DoWhere.purs b/tests/purs/layout/DoWhere.purs new file mode 100644 index 0000000000..d76cbe7f91 --- /dev/null +++ b/tests/purs/layout/DoWhere.purs @@ -0,0 +1,6 @@ +module Test where + +test = + do + do do + foo where bar = baz diff --git a/tests/purs/layout/IfThenElseDo.out b/tests/purs/layout/IfThenElseDo.out new file mode 100644 index 0000000000..dd4c5a613c --- /dev/null +++ b/tests/purs/layout/IfThenElseDo.out @@ -0,0 +1,11 @@ +module Test where{ + +foo = do{ + if true then + false + else if false then do{ + that} + else do{ + what}; + that}} + \ No newline at end of file diff --git a/tests/purs/layout/IfThenElseDo.purs b/tests/purs/layout/IfThenElseDo.purs new file mode 100644 index 0000000000..ec824858e2 --- /dev/null +++ b/tests/purs/layout/IfThenElseDo.purs @@ -0,0 +1,10 @@ +module Test where + +foo = do + if true then + false + else if false then do + that + else do + what + that diff --git a/tests/purs/layout/InstanceChainElse.out b/tests/purs/layout/InstanceChainElse.out new file mode 100644 index 0000000000..9f796326ab --- /dev/null +++ b/tests/purs/layout/InstanceChainElse.out @@ -0,0 +1,5 @@ +module Test where{ + +instance foo :: Foo Int else bar :: Foo String +else baz :: Foo Boolean} + \ No newline at end of file diff --git a/tests/purs/layout/InstanceChainElse.purs b/tests/purs/layout/InstanceChainElse.purs new file mode 100644 index 0000000000..b0b80b8138 --- /dev/null +++ b/tests/purs/layout/InstanceChainElse.purs @@ -0,0 +1,4 @@ +module Test where + +instance foo :: Foo Int else bar :: Foo String +else baz :: Foo Boolean diff --git a/tests/purs/passing/1110.purs b/tests/purs/passing/1110.purs index 32ecebcec9..047adc0462 100644 --- a/tests/purs/passing/1110.purs +++ b/tests/purs/passing/1110.purs @@ -7,7 +7,7 @@ data X a = X x :: forall a. X a x = X - + type Y = { x :: X Int } test :: forall m. Monad m => m Y diff --git a/tests/purs/passing/2252.purs b/tests/purs/passing/2252.purs index 598b37960b..c551e802cc 100644 --- a/tests/purs/passing/2252.purs +++ b/tests/purs/passing/2252.purs @@ -1,9 +1,9 @@ module Main where - + import Effect.Console (log) data T a = T - + ti :: T Int ti = T diff --git a/tests/purs/passing/ConstraintOutsideForall.purs b/tests/purs/passing/ConstraintOutsideForall.purs new file mode 100644 index 0000000000..8542461bb4 --- /dev/null +++ b/tests/purs/passing/ConstraintOutsideForall.purs @@ -0,0 +1,12 @@ +module Main where + +import Effect.Console + +class Test a + +instance testUnit :: Test Int + +test :: Test Int => forall a. a -> a +test a = a + +main = log (test "Done") diff --git a/tests/purs/passing/DeepCase.purs b/tests/purs/passing/DeepCase.purs index 687993f1f5..2eb2155857 100644 --- a/tests/purs/passing/DeepCase.purs +++ b/tests/purs/passing/DeepCase.purs @@ -6,7 +6,7 @@ import Effect.Console (log, logShow) f x y = let g = case y of - 0.0 -> x + 0.0 -> x x -> 1.0 + x * x in g + x + y diff --git a/tests/purs/passing/DeriveWithNestedSynonyms.purs b/tests/purs/passing/DeriveWithNestedSynonyms.purs index 56a7b45f3e..4f86776a15 100644 --- a/tests/purs/passing/DeriveWithNestedSynonyms.purs +++ b/tests/purs/passing/DeriveWithNestedSynonyms.purs @@ -1,5 +1,5 @@ module Main where - + import Prelude import Effect.Console (log) diff --git a/tests/purs/passing/DerivingFunctor.purs b/tests/purs/passing/DerivingFunctor.purs index e931483df5..f46c7c8d5f 100644 --- a/tests/purs/passing/DerivingFunctor.purs +++ b/tests/purs/passing/DerivingFunctor.purs @@ -27,7 +27,7 @@ main = do assert $ map show (M1 0 :: MA Int) == M1 0 assert $ map show (M2 [0, 1] :: MA Int) == M2 ["0", "1"] assert $ map show (M3 {foo: 0, bar: 1, baz: [2, 3]} :: MA Int) == M3 {foo: 0, bar: "1", baz: ["2", "3"]} - assert $ map show (M4 { myField: 42 }) == M4 { myField: "42" } :: MA String + assert $ map show (M4 { myField: 42 }) == (M4 { myField: "42" } :: MA String) case map show (T \_ -> 42) of T f -> assert $ f "hello" == "42" diff --git a/tests/purs/passing/GenericsRep.purs b/tests/purs/passing/GenericsRep.purs index a7e974882a..3126768cf9 100644 --- a/tests/purs/passing/GenericsRep.purs +++ b/tests/purs/passing/GenericsRep.purs @@ -39,5 +39,5 @@ main = do logShow (X 1 == X 1) logShow (Z 1 Y == Z 1 Y) logShow (Z 1 Y == Y) - logShow (Y == Y :: Y Z) + logShow (Y == (Y :: Y Z)) log "Done" diff --git a/tests/purs/passing/Import/M1.purs b/tests/purs/passing/Import/M1.purs index 36cdb4ba32..ec53585501 100644 --- a/tests/purs/passing/Import/M1.purs +++ b/tests/purs/passing/Import/M1.purs @@ -1,7 +1,5 @@ module M1 where -import Prelude () - id :: forall a. a -> a id = \x -> x diff --git a/tests/purs/passing/Import/M2.purs b/tests/purs/passing/Import/M2.purs index 7b4883a45f..a6a9846e72 100644 --- a/tests/purs/passing/Import/M2.purs +++ b/tests/purs/passing/Import/M2.purs @@ -1,6 +1,5 @@ module M2 where -import Prelude () import M1 main = \_ -> foo 42 diff --git a/tests/purs/passing/KindedType.purs b/tests/purs/passing/KindedType.purs index 13b9817bf8..5898614d53 100644 --- a/tests/purs/passing/KindedType.purs +++ b/tests/purs/passing/KindedType.purs @@ -31,4 +31,11 @@ class Clazz (a :: Type) where instance clazzString :: Clazz String where def = "test" +type Type a = ((a) :: Type) + +type TestRecord a = Record (a :: Type a) + +test5 :: Test TestRecord +test5 = { a: "test" } + main = log "Done" diff --git a/tests/purs/passing/Monad.purs b/tests/purs/passing/Monad.purs index 8bf3c33b0e..de29e7cceb 100644 --- a/tests/purs/passing/Monad.purs +++ b/tests/purs/passing/Monad.purs @@ -3,7 +3,7 @@ module Main where import Effect.Console (log) type Monad m = { return :: forall a. a -> m a - , bind :: forall a b. m a -> (a -> m b) -> m b } + , bind :: forall a b. m a -> (a -> m b) -> m b } data Id a = Id a @@ -22,8 +22,8 @@ maybe = { return : Just test :: forall m. Monad m -> m Number test = \m -> m.bind (m.return 1.0) (\n1 -> - m.bind (m.return "Test") (\n2 -> - m.return n1)) + m.bind (m.return "Test") (\n2 -> + m.return n1)) test1 = test id diff --git a/tests/purs/passing/Rank2Data.purs b/tests/purs/passing/Rank2Data.purs index d8f2cc3021..b35bbd8001 100644 --- a/tests/purs/passing/Rank2Data.purs +++ b/tests/purs/passing/Rank2Data.purs @@ -3,12 +3,12 @@ module Main where import Prelude hiding (add) import Effect.Console (log) -data Id = Id forall a. a -> a +data Id = Id (forall a. a -> a) runId = \id a -> case id of Id f -> f a -data Nat = Nat forall r. r -> (r -> r) -> r +data Nat = Nat (forall r. r -> (r -> r) -> r) runNat = \nat -> case nat of Nat f -> f 0.0 (\n -> n + 1.0) diff --git a/tests/purs/passing/RedefinedFixity/M2.purs b/tests/purs/passing/RedefinedFixity/M2.purs index 359b51485a..f7ddf19469 100644 --- a/tests/purs/passing/RedefinedFixity/M2.purs +++ b/tests/purs/passing/RedefinedFixity/M2.purs @@ -1,5 +1,3 @@ module M2 where -import Prelude () - import M1 diff --git a/tests/purs/passing/RedefinedFixity/M3.purs b/tests/purs/passing/RedefinedFixity/M3.purs index f7ac4629c8..cd62cc115d 100644 --- a/tests/purs/passing/RedefinedFixity/M3.purs +++ b/tests/purs/passing/RedefinedFixity/M3.purs @@ -1,6 +1,4 @@ module M3 where -import Prelude () - import M1 import M2 diff --git a/tests/purs/passing/StringEscapes.purs b/tests/purs/passing/StringEscapes.purs index 9194ce7937..a40348c21a 100644 --- a/tests/purs/passing/StringEscapes.purs +++ b/tests/purs/passing/StringEscapes.purs @@ -4,9 +4,8 @@ import Prelude ((==), (/=), (<>), discard) import Test.Assert (assert, assert') import Effect.Console (log) -singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C" -hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0" -decimal = "\119558\9731\966\224\0" == "𝌆☃φà\0" +singleCharacter = "\t\n\r\"\\" == "\x9\xA\xD\x22\x5C" +hex = "\x1D306\x2603\x3C6\xE0" == "𝌆☃φà" surrogatePair = "\xD834\xDF06" == "\x1D306" highSurrogate = "\xD834" lowSurrogate = "\xDF06" @@ -18,7 +17,6 @@ notReplacing = replacement /= highSurrogate main = do assert' "single-character escape sequences" singleCharacter assert' "hex escape sequences" hex - assert' "decimal escape sequences" decimal assert' "astral code points are represented as a UTF-16 surrogate pair" surrogatePair assert' "lone surrogates may be combined into a surrogate pair" loneSurrogates assert' "lone surrogates may be combined out of order to remain lone surrogates" outOfOrderSurrogates diff --git a/tests/purs/warning/ShadowedBinderPatternGuard.purs b/tests/purs/warning/ShadowedBinderPatternGuard.purs index f4bb85d938..fa91eaec1e 100644 --- a/tests/purs/warning/ShadowedBinderPatternGuard.purs +++ b/tests/purs/warning/ShadowedBinderPatternGuard.purs @@ -3,5 +3,5 @@ module Main where f :: Int -> Int f n | i <- true -- this i is shadowed - , i <- 1234 - = i \ No newline at end of file + , i <- 1234 + = i diff --git a/tests/purs/warning/UnusedImport.purs b/tests/purs/warning/UnusedImport.purs index 1ecd4a3641..03e5fb105e 100644 --- a/tests/purs/warning/UnusedImport.purs +++ b/tests/purs/warning/UnusedImport.purs @@ -1,6 +1,5 @@ -- @shouldWarnWith UnusedImport -- @shouldWarnWith UnusedImport --- @shouldWarnWith UnusedImport module Main where import Data.Unit (Unit, unit) @@ -8,7 +7,6 @@ import Data.Unit (Unit, unit) -- All of the below are unused import Effect import Effect.Console as Console -import Test.Assert () main :: Unit main = unit From ba37ff258a5fe7b10c946ecf619bd7137b832cbd Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Mon, 6 May 2019 04:41:02 -0700 Subject: [PATCH 1101/1580] Load externs concurrently (#3609) * Load externs concurrently * Don't compare RebuildNever modules --- package.yaml | 1 + src/Language/PureScript/Make/BuildPlan.hs | 68 ++++++++++++----------- 2 files changed, 37 insertions(+), 32 deletions(-) diff --git a/package.yaml b/package.yaml index 7e62bb0f01..d18104e122 100644 --- a/package.yaml +++ b/package.yaml @@ -61,6 +61,7 @@ dependencies: - Glob >=0.9 && <0.10 - haskeline >=0.7.0.0 - language-javascript >=0.6.0.9 && <0.7 + - lifted-async >=0.10.0.3 && <0.10.1 - lifted-base >=0.2.3 && <0.2.4 - microlens-platform >=0.3.9.0 && <0.4 - monad-control >=1.0.0.0 && <1.1 diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 126ed44aa9..d2bb88cdbc 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -10,10 +10,14 @@ module Language.PureScript.Make.BuildPlan import Prelude +import Control.Concurrent.Async.Lifted as A import Control.Concurrent.Lifted as C import Control.Monad hiding (sequence) +import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.Aeson (decode) +import Data.Foldable (foldl') import qualified Data.Map as M import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Text as T @@ -109,7 +113,7 @@ construct -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])]) -> m BuildPlan construct MakeActions{..} (sorted, graph) = do - prebuilt <- foldM findExistingExtern M.empty sorted + prebuilt <- foldl' collectPrebuiltModules M.empty . catMaybes <$> A.forConcurrently sorted findExistingExtern let toBeRebuilt = filter (not . flip M.member prebuilt . getModuleName . CST.resPartial) sorted buildJobs <- foldM makeBuildJob M.empty (map (getModuleName . CST.resPartial) toBeRebuilt) pure $ BuildPlan prebuilt buildJobs @@ -118,37 +122,37 @@ construct MakeActions{..} (sorted, graph) = do buildJob <- BuildJob <$> C.newEmptyMVar <*> C.newEmptyMVar pure (M.insert moduleName buildJob prev) - findExistingExtern :: M.Map ModuleName Prebuilt -> CST.PartialResult Module -> m (M.Map ModuleName Prebuilt) - findExistingExtern prev (getModuleName . CST.resPartial -> moduleName) = do - outputTimestamp <- getOutputTimestamp moduleName - let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph) - case traverse (fmap pbModificationTime . flip M.lookup prev) deps of - Nothing -> - -- If we end up here, one of the dependencies didn't exist in the - -- prebuilt map and so we know a dependency needs to be rebuilt, which - -- means we need to be rebuilt in turn. - pure prev - Just modTimes -> do - let dependencyTimestamp = maximumMaybe modTimes - inputTimestamp <- getInputTimestamp moduleName - let - existingExtern = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of - (Right (Just t1), Just t3, Just t2) -> - if t1 > t2 || t3 > t2 then Nothing else Just t2 - (Right (Just t1), Nothing, Just t2) -> - if t1 > t2 then Nothing else Just t2 - (Left RebuildNever, _, Just t2) -> - Just t2 - _ -> - Nothing - case existingExtern of - Nothing -> pure prev - Just outputTime -> do - mexts <- decodeExterns . snd <$> readExterns moduleName - case mexts of - Just exts -> - pure (M.insert moduleName (Prebuilt outputTime exts) prev) - Nothing -> pure prev + findExistingExtern :: CST.PartialResult Module -> m (Maybe (ModuleName, Bool, Prebuilt)) + findExistingExtern (getModuleName . CST.resPartial -> moduleName) = runMaybeT $ do + inputTimestamp <- lift $ getInputTimestamp moduleName + (rebuildNever, existingTimestamp) <- + case inputTimestamp of + Left RebuildNever -> + fmap (True,) $ MaybeT $ getOutputTimestamp moduleName + Right (Just t1) -> do + outputTimestamp <- MaybeT $ getOutputTimestamp moduleName + guard (t1 < outputTimestamp) + pure (False, outputTimestamp) + _ -> mzero + externsFile <- MaybeT $ decodeExterns . snd <$> readExterns moduleName + pure (moduleName, rebuildNever, Prebuilt existingTimestamp externsFile) + + collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt + collectPrebuiltModules prev (moduleName, rebuildNever, pb) + | rebuildNever = M.insert moduleName pb prev + | otherwise = do + let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph) + case traverse (fmap pbModificationTime . flip M.lookup prev) deps of + Nothing -> + -- If we end up here, one of the dependencies didn't exist in the + -- prebuilt map and so we know a dependency needs to be rebuilt, which + -- means we need to be rebuilt in turn. + prev + Just modTimes -> + case maximumMaybe modTimes of + Just depModTime | pbModificationTime pb < depModTime -> + prev + _ -> M.insert moduleName pb prev maximumMaybe :: Ord a => [a] -> Maybe a maximumMaybe [] = Nothing From 315759e9e72116d8066faefcc348dc8f69bff233 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 7 May 2019 23:54:25 +0100 Subject: [PATCH 1102/1580] Add tests for grammar fixes addressed by CST (#3629) Closes #3554, closes #3443, closes #3601, by adding tests for these issues. I've verified that the `passing` test fails to compile and that the `failing` test does compile on v0.12.5. --- tests/purs/failing/ApostropheModuleName.purs | 7 +++++++ tests/purs/passing/FunctionAndCaseGuards.purs | 21 +++++++++++++++++++ .../passing/TypeAnnotationPrecedence.purs | 11 ++++++++++ 3 files changed, 39 insertions(+) create mode 100644 tests/purs/failing/ApostropheModuleName.purs create mode 100644 tests/purs/passing/FunctionAndCaseGuards.purs create mode 100644 tests/purs/passing/TypeAnnotationPrecedence.purs diff --git a/tests/purs/failing/ApostropheModuleName.purs b/tests/purs/failing/ApostropheModuleName.purs new file mode 100644 index 0000000000..1530e9cfd7 --- /dev/null +++ b/tests/purs/failing/ApostropheModuleName.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith ErrorParsingModule +-- see #3601 +module Bad'Module where + +import Effect.Console (log) + +main = log "Done" diff --git a/tests/purs/passing/FunctionAndCaseGuards.purs b/tests/purs/passing/FunctionAndCaseGuards.purs new file mode 100644 index 0000000000..ca949acf17 --- /dev/null +++ b/tests/purs/passing/FunctionAndCaseGuards.purs @@ -0,0 +1,21 @@ +-- See #3443 +module Main where + +import Prelude +import Effect (Effect) +import Effect.Console (log) + +-- this is just a really convoluted `const true` +test :: Int -> Boolean +test a + | false = + case false of + true | a > 0 -> true + _ -> true + | otherwise = true + +main :: Effect Unit +main = do + if test 0 + then log "Done" + else pure unit diff --git a/tests/purs/passing/TypeAnnotationPrecedence.purs b/tests/purs/passing/TypeAnnotationPrecedence.purs new file mode 100644 index 0000000000..d5433bf22d --- /dev/null +++ b/tests/purs/passing/TypeAnnotationPrecedence.purs @@ -0,0 +1,11 @@ +-- See #3554 +module Main where + +import Prelude +import Effect (Effect) +import Effect.Console (log) +import Data.Tuple (Tuple(..), uncurry) + +appendAndLog = log <<< uncurry append :: Tuple String String -> Effect Unit + +main = appendAndLog (Tuple "Do" "ne") From 4ffe70f3c464904610a0b1f8e6f51061a16c2da2 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Tue, 7 May 2019 20:21:22 -0700 Subject: [PATCH 1103/1580] Fixes let/in expressions within ado (#3628) An `in` keyword should only close a `let` _and_ `ado` block if it is part of an `ado` let statement. This introduces `LytLetStmt` as it's own delimiter which is determined by it's column in relation to an existing `ado` or `do` block. --- src/Language/PureScript/CST/Layout.hs | 24 ++++++++++++++++-------- tests/purs/layout/AdoIn.out | 7 ++++++- tests/purs/layout/AdoIn.purs | 5 +++++ tests/purs/layout/DoLet.out | 16 ++++++++++++++++ tests/purs/layout/DoLet.purs | 15 +++++++++++++++ 5 files changed, 58 insertions(+), 9 deletions(-) create mode 100644 tests/purs/layout/DoLet.out create mode 100644 tests/purs/layout/DoLet.purs diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs index 9baf8bfd7e..bf533ff9aa 100644 --- a/src/Language/PureScript/CST/Layout.hs +++ b/src/Language/PureScript/CST/Layout.hs @@ -48,6 +48,7 @@ data LayoutDelim | LytForall | LytTick | LytLet + | LytLetStmt | LytWhere | LytOf | LytDo @@ -56,12 +57,13 @@ data LayoutDelim isIndented :: LayoutDelim -> Bool isIndented = \case - LytLet -> True - LytWhere -> True - LytOf -> True - LytDo -> True - LytAdo -> True - _ -> False + LytLet -> True + LytLetStmt -> True + LytWhere -> True + LytOf -> True + LytDo -> True + LytAdo -> True + _ -> False isTopDecl :: SourcePos -> LayoutStack -> Bool isTopDecl tokPos = \case @@ -132,7 +134,7 @@ insertLayout src@(SourceToken tokAnn tok) nextPos stack = -- foo <- ... -- let bar = ... -- in ... - ((_, LytLet) : (_, LytAdo) : stk', acc') -> + ((_, LytLetStmt) : (_, LytAdo) : stk', acc') -> (stk', acc') & insertEnd & insertEnd & insertToken src ((_, lyt) : stk', acc') | isIndented lyt -> (stk', acc') & insertEnd & insertToken src @@ -144,7 +146,13 @@ insertLayout src@(SourceToken tokAnn tok) nextPos stack = inP _ lyt = isIndented lyt TokLowerName [] "let" -> - state & insertKwProperty (insertStart LytLet) + case stk of + (p, LytDo) : _ | srcColumn p == srcColumn tokPos -> + state & insertKwProperty (insertStart LytLetStmt) + (p, LytAdo) : _ | srcColumn p == srcColumn tokPos -> + state & insertKwProperty (insertStart LytLetStmt) + _ -> + state & insertKwProperty (insertStart LytLet) TokLowerName _ "do" -> state & insertKwProperty (insertStart LytDo) diff --git a/tests/purs/layout/AdoIn.out b/tests/purs/layout/AdoIn.out index 0a9436e059..134ef8fc61 100644 --- a/tests/purs/layout/AdoIn.out +++ b/tests/purs/layout/AdoIn.out @@ -5,5 +5,10 @@ test = ado{ let {foo = bar}} in bar; -test = ado {}in foo} +test = ado {}in foo; + +test = ado{ + foo <- bar $ let {a = 42 }in a; + baz <- b} + in bar} \ No newline at end of file diff --git a/tests/purs/layout/AdoIn.purs b/tests/purs/layout/AdoIn.purs index 1fffa4dc93..ba7a736619 100644 --- a/tests/purs/layout/AdoIn.purs +++ b/tests/purs/layout/AdoIn.purs @@ -6,3 +6,8 @@ test = ado in bar test = ado in foo + +test = ado + foo <- bar $ let a = 42 in a + baz <- b + in bar diff --git a/tests/purs/layout/DoLet.out b/tests/purs/layout/DoLet.out new file mode 100644 index 0000000000..a2066a456d --- /dev/null +++ b/tests/purs/layout/DoLet.out @@ -0,0 +1,16 @@ +module Test where{ + +test = do{ + let {foo = bar}; + foo}; + +test = do{ + let {foo = bar}; + in baz; + foo}; + +test = do{ + let {foo = bar} + in baz; + foo}} + \ No newline at end of file diff --git a/tests/purs/layout/DoLet.purs b/tests/purs/layout/DoLet.purs new file mode 100644 index 0000000000..a6420ec42f --- /dev/null +++ b/tests/purs/layout/DoLet.purs @@ -0,0 +1,15 @@ +module Test where + +test = do + let foo = bar + foo + +test = do + let foo = bar + in baz + foo + +test = do + let foo = bar + in baz + foo From 789e6ff0aa4a853ff858237828e47e9d177bf6f3 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 8 May 2019 11:25:55 +0100 Subject: [PATCH 1104/1580] Better illegal whitespace errors (#3627) Use usual Unicode format for illegal whitespace errors For example, if you have a non-breaking space in a source file: Before Unable to parse module: Illegal whitespace character '\160' After Unable to parse module: Illegal whitespace character U+00A0 The latter is a much more common format for presenting this information, and therefore should be e.g. easier to google. Text.Printf is in base now so using it shouldn't lead to any dependency difficulties. --- src/Language/PureScript/CST/Errors.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs index 0dcfa7bf0a..01c9879e5e 100644 --- a/src/Language/PureScript/CST/Errors.hs +++ b/src/Language/PureScript/CST/Errors.hs @@ -9,10 +9,11 @@ module Language.PureScript.CST.Errors import Prelude import qualified Data.Text as Text -import Data.Char (isSpace) +import Data.Char (isSpace, toUpper) import Language.PureScript.CST.Layout import Language.PureScript.CST.Print import Language.PureScript.CST.Types +import Text.Printf (printf) data ParserErrorType = ErrWildcardInType @@ -104,7 +105,7 @@ prettyPrintErrorMessage (ParserError {..}) = case errType of ErrEof -> "Unexpected end of input" ErrLexeme (Just (hd : _)) _ | isSpace hd -> - "Illegal whitespace character " <> show hd + "Illegal whitespace character " <> displayCodePoint hd ErrLexeme (Just a) _ -> "Unexpected " <> a ErrLineFeedInString -> @@ -152,3 +153,7 @@ prettyPrintErrorMessage (ParserError {..}) = case errType of TokLayoutEnd -> "Unexpected or mismatched indentation" TokEof -> "Unexpected end of input" tok -> "Unexpected token '" <> Text.unpack (printToken tok) <> "'" + + displayCodePoint :: Char -> String + displayCodePoint x = + "U+" <> map toUpper (printf "%0.4x" (fromEnum x)) From 8c1a12c3109a28a33d801a0d397a788afb44a28f Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 8 May 2019 11:30:30 +0100 Subject: [PATCH 1105/1580] Update INSTALL.md (#3607) - Clarify architecture targeted by prebuilt binaries, refs #3544 - Separate operating system requirements from prebuilt binaries section - Explain how to install an official binary bundle - Clarify difference between official binary bundles and other compiler distributions - Remove outdated reference to "other utilities" included in an official binary bundle (now it's just `purs`) - Use proper link text for stack install documentation link - Remove outdated sentence about `stack setup`, since stack now installs the appropriate GHC for you automatically by default. --- INSTALL.md | 33 +++++++++++++++------------------ 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/INSTALL.md b/INSTALL.md index 232b5a658f..7b4fe9f777 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -4,25 +4,27 @@ If you are having difficulty installing the PureScript compiler, feel free to ask for help! A good place is the #purescript IRC channel on Freenode, the #purescript channel on [FPChat Slack](https://fpchat-invite.herokuapp.com/), or alternatively Stack Overflow. -## Using prebuilt binaries +## Requirements -The prebuilt binaries are compiled with GHC 8.6.4 and therefore they should run on any operating system supported by GHC 8.6.4, such as: +The PureScript compiler is built using GHC 8.6.4, and should be able to run on any operating system supported by GHC 8.6.4. In particular: -* Windows Vista or later, -* OS X 10.7 or later, -* Linux ??? (we're not sure what the minimum version is) +* for Windows users, versions predating Vista are not officially supported, +* for macOS / OS X users, versions predating Mac OS X 10.7 (Lion) are not officially supported. -This list is not exhaustive. If your OS is too old or not listed, or if the binaries fail to run, you may be able to install the compiler by building it from source; see below. See also for more details about the operating systems which GHC 8.6.4 supports. +See also for more details about the operating systems which GHC 8.6.4 supports. -Other prebuilt distributions (eg, Homebrew, AUR, npm) will probably have the -same requirements. +## Official prebuilt binaries -## Installing a pre-built distribution +Each release comes with prebuilt x86-64 binary bundles for Linux, mac OS, and Windows. Users of other operating systems or architectures will likely need to build the compiler from source; see below. -There are several options available for aquiring a pre-built binary of the PureScript compiler. This is by no means an exhaustive list, and is presented in no particular order. Each example is expected to install the latest available compiler version at the time of running the command. Many of these are provided and maintained by the community, and may not be immediately up to date. +To install a binary bundle, simply extract it and place the `purs` executable somewhere on your PATH. + +## Other distributions + +There are several other distributions of the PureScript compiler available, which may be more convenient to use in certain setups. This is by no means an exhaustive list, and is presented in no particular order. Many of these distributions are provided and maintained by the community, and may not be immediately up to date following a new release. * NPM: `npm install -g purescript` -* Homebrew (for OS X): `brew install purescript` +* Homebrew (for macOS): `brew install purescript` * [PSVM](https://github.com/ThomasCrevoisier/psvm-js): `npm install -g psvm` ## Compiling from source @@ -36,14 +38,9 @@ $ cd purescript-x.y.z # (replace x.y.z with whichever version you just download $ stack install --flag purescript:RELEASE ``` -This will then copy the compiler and utilities into `~/.local/bin`. - - -If you don't have stack installed, there are install instructions -[here](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md). +This will then copy the compiler executable (`purs`) into `~/.local/bin`. -If you don't have GHC installed, stack will prompt you to run `stack setup` -which will install the correct version of GHC for you. +If you don't have stack installed, please see the [stack install documentation](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md). ## The "curses" library From ffd0731c1d15c0d7b8d89756ee87b17e026403ac Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 8 May 2019 13:49:08 +0100 Subject: [PATCH 1106/1580] Add a test for @-pattern precedence (#3631) Closes #3532 --- tests/purs/failing/AtPatternPrecedence.purs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 tests/purs/failing/AtPatternPrecedence.purs diff --git a/tests/purs/failing/AtPatternPrecedence.purs b/tests/purs/failing/AtPatternPrecedence.purs new file mode 100644 index 0000000000..9f21935b71 --- /dev/null +++ b/tests/purs/failing/AtPatternPrecedence.purs @@ -0,0 +1,14 @@ +-- See #3532 +-- @shouldFailWith ArgListLengthsDiffer +module Main where + +import Effect.Console (log) + +data X = X String | Y + +oops :: X -> String +-- previously this was parsed as x@(X s) +oops x@X s = s +oops Y = "Y" + +main = log (oops (X "Done")) From bd30494a07f5f34bd2a2bd2eda463a75c1688474 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sat, 11 May 2019 14:52:34 +0100 Subject: [PATCH 1107/1580] Unify matching constraints (#3620) --- src/Language/PureScript/TypeChecker/Unify.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index e5bf87e87f..65625f4b96 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -24,6 +24,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets, modify) import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Foldable (traverse_) import Data.Function (on) import Data.List (sortBy, nubBy) import qualified Data.Map as M @@ -118,6 +119,10 @@ unifyTypes t1 t2 = do unifyTypes' r1 r2@RCons{} = unifyRows r1 r2 unifyTypes' r1@REmpty{} r2 = unifyRows r1 r2 unifyTypes' r1 r2@REmpty{} = unifyRows r1 r2 + unifyTypes' (ConstrainedType _ c1 ty1) (ConstrainedType _ c2 ty2) + | constraintClass c1 == constraintClass c2 && constraintData c1 == constraintData c2 = do + traverse_ (uncurry unifyTypes) (constraintArgs c1 `zip` constraintArgs c2) + ty1 `unifyTypes` ty2 unifyTypes' ty1@ConstrainedType{} ty2 = throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2 unifyTypes' t3 t4@ConstrainedType{} = unifyTypes' t4 t3 From 3b337ae9e56300d61661b1c45957ba07553fae89 Mon Sep 17 00:00:00 2001 From: Emilio Almansi Date: Tue, 14 May 2019 18:26:44 +0200 Subject: [PATCH 1108/1580] Improve error message on ModuleNotFound error for Prim modules. (#3637) * Improve error message on ModuleNotFound error for Prim modules. * Improved wording. Updated CONTRIBUTORS.md. --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Errors.hs | 7 ++++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index a48aa20373..ab5a25a6a4 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -41,6 +41,7 @@ If you would prefer to use different terms, please use the section below instead | [@DavidLindbom](https://github.com/DavidLindbom) | David Lindbom | [MIT license](http://opensource.org/licenses/MIT) | | [@dckc](https://github.com/dckc) | Dan Connolly | [MIT license](http://opensource.org/licenses/MIT) | | [@kleeneplus](https://github.com/dgendill) | Dominick Gendill | [MIT license](http://opensource.org/licenses/MIT) | +| [@ealmansi](https://github.com/ealmansi) | Emilio Almansi | MIT license | | [@eamelink](https://github.com/eamelink) | Erik Bakker | MIT license | | [@epost](https://github.com/epost) | Erik Post | MIT license | | [@erdeszt](https://github.com/erdeszt) | Tibor Erdesz | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 1677d63915..7157f0db72 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -458,7 +458,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box renderSimpleErrorMessage (ModuleNotFound mn) = paras [ line $ "Module " <> markCode (runModuleName mn) <> " was not found." - , line "Make sure the source file exists, and that it has been provided as an input to the compiler." + , line $ + if isBuiltinModuleName mn + then + "Module names in the Prim namespace are reserved for built-in modules, but this version of the compiler does not provide module " <> markCode (runModuleName mn) <> ". You may be able to fix this by updating your compiler to a newer version." + else + "Make sure the source file exists, and that it has been provided as an input to the compiler." ] renderSimpleErrorMessage (CannotGetFileInfo path) = paras [ line "Unable to read file info: " From ec5bdc77e42439368a595907488c0120a65f9c9b Mon Sep 17 00:00:00 2001 From: Jordan Mackie Date: Tue, 14 May 2019 17:28:58 +0100 Subject: [PATCH 1109/1580] Keep Parser.y ASCII to avoid locale issues with happy (#3640) --- src/Language/PureScript/CST/Parser.y | 2 +- src/Language/PureScript/CST/Utils.hs | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y index 6cea62c6ab..35b40667e1 100644 --- a/src/Language/PureScript/CST/Parser.y +++ b/src/Language/PureScript/CST/Parser.y @@ -58,7 +58,7 @@ import Language.PureScript.PSString (PSString) '\;' { SourceToken _ TokLayoutSep } '<-' { SourceToken _ (TokLeftArrow _) } '->' { SourceToken _ (TokRightArrow _) } - '<=' { SourceToken _ (TokOperator [] sym) | sym == "<=" || sym == "⇐" } + '<=' { SourceToken _ (TokOperator [] sym) | isLeftFatArrow sym } '=>' { SourceToken _ (TokRightFatArrow _) } ':' { SourceToken _ (TokOperator [] ":") } '::' { SourceToken _ (TokDoubleColon _) } diff --git a/src/Language/PureScript/CST/Utils.hs b/src/Language/PureScript/CST/Utils.hs index d7113f8372..656de2315d 100644 --- a/src/Language/PureScript/CST/Utils.hs +++ b/src/Language/PureScript/CST/Utils.hs @@ -304,3 +304,10 @@ reservedNames = Set.fromList isValidModuleNamespace :: Text -> Bool isValidModuleNamespace = Text.null . snd . Text.span (\c -> c /= '_' && c /= '\'') + +-- | This is to keep the @Parser.y@ file ASCII, otherwise @happy@ will break +-- in non-unicode locales. +-- +-- Related GHC issue: https://gitlab.haskell.org/ghc/ghc/issues/8167 +isLeftFatArrow :: Text -> Bool +isLeftFatArrow str = str == "<=" || str == "⇐" From b0dd86e3de57d7e3172ab7884efc24340a8d13a0 Mon Sep 17 00:00:00 2001 From: Emilio Almansi Date: Thu, 16 May 2019 21:55:51 +0200 Subject: [PATCH 1110/1580] Docs: make markdown format behave like html. Remove --docgen opt. (#3641) * Docs: make markdown format behave like html. Remove --docgen opt. * Separate directories for html and markdown docs. --- app/Command/Docs.hs | 170 +++------------------ app/Command/Docs/Html.hs | 3 - app/Command/Docs/Markdown.hs | 24 +++ package.yaml | 1 + src/Language/PureScript/Docs/AsMarkdown.hs | 1 + 5 files changed, 50 insertions(+), 149 deletions(-) create mode 100644 app/Command/Docs/Markdown.hs diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index 048cb646d2..46e73bce38 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -1,30 +1,20 @@ -{-# LANGUAGE TupleSections #-} module Command.Docs (command, infoModList) where import Command.Docs.Html +import Command.Docs.Markdown import Control.Applicative -import Control.Arrow (first, second) -import Control.Category ((>>>)) import Control.Monad.Writer import Control.Monad.Trans.Except (runExceptT) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Function (on) -import Data.List -import Data.Tuple (swap) import qualified Language.PureScript as P import qualified Language.PureScript.Docs as D -import qualified Language.PureScript.Docs.AsMarkdown as D import Language.PureScript.Docs.Tags (dumpCtags, dumpEtags) import qualified Options.Applicative as Opts import qualified Text.PrettyPrint.ANSI.Leijen as PP -import System.Directory (createDirectoryIfMissing) +import System.Directory (createDirectoryIfMissing, removeFile) import System.Exit (exitFailure) -import System.FilePath (takeDirectory) -import System.FilePath.Glob (glob) +import System.FilePath.Glob (compile, glob, globDir1) import System.IO (hPutStrLn, stderr) -import System.IO.UTF8 (writeUTF8FileT) -- | Available output formats data Format @@ -34,67 +24,40 @@ data Format | Etags -- Output etags symbol index suitable for use with emacs deriving (Show, Eq, Ord) --- | Available methods of outputting Markdown documentation -data DocgenOutput - = EverythingToStdOut - | ToStdOut [P.ModuleName] - | ToFiles [(P.ModuleName, FilePath)] - deriving (Show) - data PSCDocsOptions = PSCDocsOptions { _pscdFormat :: Format , _pscdInputFiles :: [FilePath] - , _pscdDocgen :: DocgenOutput } deriving (Show) docgen :: PSCDocsOptions -> IO () -docgen (PSCDocsOptions fmt inputGlob output) = do +docgen (PSCDocsOptions fmt inputGlob) = do input <- concat <$> mapM glob inputGlob when (null input) $ do hPutStrLn stderr "purs docs: no input files." exitFailure fileMs <- parseAndConvert input - let ms = map snd fileMs + let ms = D.primModules ++ map snd fileMs case fmt of Etags -> mapM_ putStrLn $ dumpEtags fileMs Ctags -> mapM_ putStrLn $ dumpCtags fileMs Html -> do - let outputDir = "./generated-docs" -- TODO: make this configurable - let msHtml = map asHtml (D.primModules ++ ms) - createDirectoryIfMissing False outputDir + let outputDir = "./generated-docs/html" -- TODO: make this configurable + let ext = compile "*.html" + let msHtml = map asHtml ms + createDirectoryIfMissing True outputDir + globDir1 ext outputDir >>= mapM_ removeFile writeHtmlModules outputDir msHtml - - Markdown -> - case output of - EverythingToStdOut -> - T.putStrLn (D.runDocs (D.modulesAsMarkdown ms)) - ToStdOut names -> do - let (ms', missing) = takeByName ms names - guardMissing missing - T.putStrLn (D.runDocs (D.modulesAsMarkdown ms')) - ToFiles names -> do - let (ms', missing) = takeByName' ms names - guardMissing missing - - let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms' - forM_ ms'' $ \grp -> do - let fp = fst (head grp) - createDirectoryIfMissing True (takeDirectory fp) - writeUTF8FileT fp (D.runDocs (D.modulesAsMarkdown (map snd grp))) + Markdown -> do + let outputDir = "./generated-docs/md" -- TODO: make this configurable + let ext = compile "*.md" + let msMarkdown = map asMarkdown ms + createDirectoryIfMissing True outputDir + globDir1 ext outputDir >>= mapM_ removeFile + writeMarkdownModules outputDir msMarkdown where - guardMissing [] = return () - guardMissing [mn] = do - hPutStrLn stderr ("purs docs: error: unknown module \"" ++ T.unpack (P.runModuleName mn) ++ "\"") - exitFailure - guardMissing mns = do - hPutStrLn stderr "purs docs: error: unknown modules:" - forM_ mns $ \mn -> - hPutStrLn stderr (" * " ++ T.unpack (P.runModuleName mn)) - exitFailure - successOrExit :: Either P.MultipleErrors a -> IO a successOrExit act = case act of @@ -104,35 +67,11 @@ docgen (PSCDocsOptions fmt inputGlob output) = do hPutStrLn stderr $ P.prettyPrintMultipleErrors P.defaultPPEOptions err exitFailure - takeByName = takeModulesByName D.modName - takeByName' = takeModulesByName' D.modName - parseAndConvert input = runExceptT (D.parseFilesInPackages input [] >>= uncurry D.convertTaggedModulesInPackage) >>= successOrExit --- | --- Given a list of module names and a list of modules, return a list of modules --- whose names appeared in the given name list, together with a list of names --- for which no module could be found in the module list. --- -takeModulesByName :: (Eq n) => (m -> n) -> [m] -> [n] -> ([m], [n]) -takeModulesByName getModuleName modules names = - first (map fst) (takeModulesByName' getModuleName modules (map (,()) names)) - --- | --- Like takeModulesByName, but also keeps some extra information with each --- module. --- -takeModulesByName' :: (Eq n) => (m -> n) -> [m] -> [(n, a)] -> ([(m, a)], [n]) -takeModulesByName' getModuleName modules = foldl go ([], []) - where - go (ms, missing) (name, x) = - case find ((== name) . getModuleName) modules of - Just m -> ((m, x) : ms, missing) - Nothing -> (ms, name : missing) - inputFile :: Opts.Parser FilePath inputFile = Opts.strArgument $ Opts.metavar "FILE" @@ -151,64 +90,11 @@ format = Opts.option Opts.auto $ Opts.value Markdown <> Opts.metavar "FORMAT" <> Opts.help "Set output FORMAT (markdown | html | etags | ctags)" -docgenModule :: Opts.Parser String -docgenModule = Opts.strOption $ - Opts.long "docgen" - <> Opts.help "A list of module names which should appear in the output. This can optionally include file paths to write individual modules to, by separating with a colon ':'. For example, Prelude:docs/Prelude.md. This option may be specified multiple times." - -pscDocsOptions :: Opts.Parser (Format, [FilePath], [String]) -pscDocsOptions = (,,) <$> format <*> many inputFile <*> many docgenModule - -parseDocgen :: [String] -> Either String DocgenOutput -parseDocgen [] = Right EverythingToStdOut -parseDocgen xs = go xs - where - go = intersperse " " - >>> concat - >>> words - >>> map parseItem - >>> combine - -data DocgenOutputItem - = IToStdOut P.ModuleName - | IToFile (P.ModuleName, FilePath) - -parseItem :: String -> DocgenOutputItem -parseItem s = case elemIndex ':' s of - Just i -> - s # splitAt i - >>> first (P.moduleNameFromString . T.pack) - >>> second (drop 1) - >>> IToFile - Nothing -> - IToStdOut (P.moduleNameFromString (T.pack s)) - - where - infixr 1 # - (#) = flip ($) - -combine :: [DocgenOutputItem] -> Either String DocgenOutput -combine [] = Right EverythingToStdOut -combine (x:xs) = foldM go (initial x) xs - where - initial (IToStdOut m) = ToStdOut [m] - initial (IToFile m) = ToFiles [m] - - go (ToStdOut ms) (IToStdOut m) = Right (ToStdOut (m:ms)) - go (ToFiles ms) (IToFile m) = Right (ToFiles (m:ms)) - go _ _ = Left "Can't mix module names and module name/file path pairs in the same invocation." - -buildOptions :: (Format, [FilePath], [String]) -> IO PSCDocsOptions -buildOptions (fmt, input, mapping) = - case parseDocgen mapping of - Right mapping' -> return (PSCDocsOptions fmt input mapping') - Left err -> do - hPutStrLn stderr "purs docs: error in --docgen option:" - hPutStrLn stderr (" " ++ err) - exitFailure +pscDocsOptions :: Opts.Parser PSCDocsOptions +pscDocsOptions = PSCDocsOptions <$> format <*> many inputFile command :: Opts.Parser (IO ()) -command = (buildOptions >=> docgen) <$> (Opts.helper <*> pscDocsOptions) +command = docgen <$> (Opts.helper <*> pscDocsOptions) infoModList :: Opts.InfoMod a infoModList = Opts.fullDesc <> footerInfo where @@ -218,17 +104,9 @@ examples :: PP.Doc examples = PP.vcat $ map PP.text [ "Examples:" - , " print documentation for Data.List to stdout:" - , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\" - , " --docgen Data.List" - , "" - , " write documentation for Data.List to docs/Data.List.md:" - , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\" - , " --docgen Data.List:docs/Data.List.md" + , " write documentation for all modules to ./generated-docs:" + , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\"" , "" - , " write documentation for Data.List to docs/Data.List.md, and" - , " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:" - , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\" - , " --docgen Data.List:docs/Data.List.md \\" - , " --docgen Data.List.Lazy:docs/Data.List.Lazy.md" + , " write documentation in HTML format for all modules to ./generated-docs:" + , " purs docs --format html \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\"" ] diff --git a/app/Command/Docs/Html.hs b/app/Command/Docs/Html.hs index 1e4a176e46..dbb009fa50 100644 --- a/app/Command/Docs/Html.hs +++ b/app/Command/Docs/Html.hs @@ -23,13 +23,10 @@ import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A import qualified Text.Blaze.Html.Renderer.Text as Blaze import System.IO.UTF8 (writeUTF8FileT) -import System.FilePath.Glob (glob) -import System.Directory (removeFile) import Version (versionString) writeHtmlModules :: FilePath -> [(P.ModuleName, D.HtmlOutputModule Html)] -> IO () writeHtmlModules outputDir modules = do - glob (outputDir <> "/*.html") >>= mapM_ removeFile let moduleList = sort $ map fst modules writeHtmlFile (outputDir ++ "/index.html") (renderIndexModule moduleList) mapM_ (writeHtmlModule outputDir . (fst &&& layout moduleList)) modules diff --git a/app/Command/Docs/Markdown.hs b/app/Command/Docs/Markdown.hs new file mode 100644 index 0000000000..60d509892c --- /dev/null +++ b/app/Command/Docs/Markdown.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Command.Docs.Markdown + ( asMarkdown + , writeMarkdownModules + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Language.PureScript as P +import qualified Language.PureScript.Docs as D +import qualified Language.PureScript.Docs.AsMarkdown as D +import System.IO.UTF8 (writeUTF8FileT) + +asMarkdown :: D.Module -> (P.ModuleName, Text) +asMarkdown m = (D.modName m, D.runDocs . D.moduleAsMarkdown $ m) + +writeMarkdownModules :: FilePath -> [(P.ModuleName, Text)] -> IO () +writeMarkdownModules outputDir = mapM_ $ writeMarkdownModule outputDir + +writeMarkdownModule :: FilePath -> (P.ModuleName, Text) -> IO () +writeMarkdownModule outputDir (mn, text) = do + let filepath = outputDir ++ "/" ++ T.unpack (P.runModuleName mn) ++ ".md" + writeUTF8FileT filepath text diff --git a/package.yaml b/package.yaml index d18104e122..c1ae0375c6 100644 --- a/package.yaml +++ b/package.yaml @@ -126,6 +126,7 @@ executables: - Command.Compile - Command.Docs - Command.Docs.Html + - Command.Docs.Markdown - Command.Hierarchy - Command.Ide - Command.Publish diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 6765217ba5..36b2e5bb59 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -3,6 +3,7 @@ module Language.PureScript.Docs.AsMarkdown , Docs , runDocs , modulesAsMarkdown + , moduleAsMarkdown , codeToString ) where From 8661acc1c5867ef327357f789b4452bb5b78e89a Mon Sep 17 00:00:00 2001 From: Emilio Almansi Date: Sat, 18 May 2019 17:07:25 +0200 Subject: [PATCH 1111/1580] Docs: make html the default output format. (#3643) --- app/Command/Docs.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index 46e73bce38..868029cbf7 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -85,7 +85,7 @@ instance Read Format where readsPrec _ _ = [] format :: Opts.Parser Format -format = Opts.option Opts.auto $ Opts.value Markdown +format = Opts.option Opts.auto $ Opts.value Html <> Opts.long "format" <> Opts.metavar "FORMAT" <> Opts.help "Set output FORMAT (markdown | html | etags | ctags)" @@ -107,6 +107,6 @@ examples = , " write documentation for all modules to ./generated-docs:" , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\"" , "" - , " write documentation in HTML format for all modules to ./generated-docs:" - , " purs docs --format html \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\"" + , " write documentation in Markdown format for all modules to ./generated-docs:" + , " purs docs --format markdown \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\"" ] From c7f6d2d78ae5a585a91d0edc1762722fccb0a38f Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 22 May 2019 21:59:13 +0100 Subject: [PATCH 1112/1580] Improve display of internal errors (#3634) There is no need to `show` error messages, since they are already strings. Example: Before: purs: An internal error occurred during compilation: "Failed to produce docs for Data.Bifunctor; details:\nError found:\nin module \ESC[33mData.Bifunctor\ESC[0m\nat ../../../support/bower_components/purescript-bifunctors/src/Data/Bifunctor.purs:3:1 - 3:35 (line 3, column 1 - line 3, column 35)\n\n Unknown module \ESC[33mControl.Category\ESC[0m\n\n\nSee https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information,\nor to contribute content related to this error.\n\n" Please report this at https://github.com/purescript/purescript/issues CallStack (from HasCallStack): error, called at src/Language/PureScript/Crash.hs:24:3 in purescript-0.12.5-3daYxGi6wB3EfBqURAef82:Language.PureScript.Crash internalError, called at src/Language/PureScript/Make.hs:92:29 in purescript-0.12.5-3daYxGi6wB3EfBqURAef82:Language.PureScript.Make purs: thread blocked indefinitely in an MVar operation After: purs: An internal error occurred during compilation: Failed to produce docs for Data.Show; details: Error found: in module Data.Show at ../../../support/bower_components/purescript-prelude/src/Data/Show.purs:6:1 - 6:63 (line 6, column 1 - line 6, column 63) Unknown module Data.Symbol See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, or to contribute content related to this error. Please report this at https://github.com/purescript/purescript/issues CallStack (from HasCallStack): error, called at src/Language/PureScript/Crash.hs:24:3 in purescript-0.12.5-3daYxGi6wB3EfBqURAef82:Language.PureScript.Crash internalError, called at src/Language/PureScript/Make.hs:92:29 in purescript-0.12.5-3daYxGi6wB3EfBqURAef82:Language.PureScript.Make purs: thread blocked indefinitely in an MVar operation --- src/Language/PureScript/Crash.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Language/PureScript/Crash.hs b/src/Language/PureScript/Crash.hs index 1ce2f09f60..fe72169bb0 100644 --- a/src/Language/PureScript/Crash.hs +++ b/src/Language/PureScript/Crash.hs @@ -24,4 +24,3 @@ internalError = error . ("An internal error occurred during compilation: " ++) . (++ "\nPlease report this at https://github.com/purescript/purescript/issues") - . show From cd3596df8dbe9651c5f409388faf190ccf165251 Mon Sep 17 00:00:00 2001 From: Emilio Almansi Date: Sun, 26 May 2019 17:33:49 +0200 Subject: [PATCH 1113/1580] Docs: Write ctags and etags to filesystem instead of stdout. (#3644) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes #3642. When running purs docs with ctags or etags formats, write to the filesystem instead of writing to standard output. CTags format will generate a file tags, while ETags format will generate a file TAGS. The naming convention is taken from the default filenames generated by the ctags and etags commands (see http://ctags.sourceforge.net/ctags.html). Example output: → purs docs --format ctags example.purs → purs docs --format etags example.purs → ls tags TAGS > tags TAGS → cat tags > Bar /home/ealmansi/dev/ealmansi/purescript/example.purs 6 > Foo /home/ealmansi/dev/ealmansi/purescript/example.purs 5 --- app/Command/Docs.hs | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index 868029cbf7..fdaa51c582 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -6,15 +6,18 @@ import Command.Docs.Markdown import Control.Applicative import Control.Monad.Writer import Control.Monad.Trans.Except (runExceptT) +import qualified Data.Text as T import qualified Language.PureScript as P import qualified Language.PureScript.Docs as D import Language.PureScript.Docs.Tags (dumpCtags, dumpEtags) import qualified Options.Applicative as Opts import qualified Text.PrettyPrint.ANSI.Leijen as PP -import System.Directory (createDirectoryIfMissing, removeFile) +import System.Directory (getCurrentDirectory, createDirectoryIfMissing, removeFile) import System.Exit (exitFailure) +import System.FilePath (()) import System.FilePath.Glob (compile, glob, globDir1) import System.IO (hPutStrLn, stderr) +import System.IO.UTF8 (writeUTF8FileT) -- | Available output formats data Format @@ -40,8 +43,8 @@ docgen (PSCDocsOptions fmt inputGlob) = do fileMs <- parseAndConvert input let ms = D.primModules ++ map snd fileMs case fmt of - Etags -> mapM_ putStrLn $ dumpEtags fileMs - Ctags -> mapM_ putStrLn $ dumpCtags fileMs + Etags -> writeTagsToFile "TAGS" $ dumpEtags fileMs + Ctags -> writeTagsToFile "tags" $ dumpCtags fileMs Html -> do let outputDir = "./generated-docs/html" -- TODO: make this configurable let ext = compile "*.html" @@ -72,6 +75,13 @@ docgen (PSCDocsOptions fmt inputGlob) = do >>= uncurry D.convertTaggedModulesInPackage) >>= successOrExit + writeTagsToFile :: String -> [String] -> IO () + writeTagsToFile outputFilename tags = do + currentDir <- getCurrentDirectory + let outputFile = currentDir outputFilename + let text = T.pack . unlines $ tags + writeUTF8FileT outputFile text + inputFile :: Opts.Parser FilePath inputFile = Opts.strArgument $ Opts.metavar "FILE" @@ -109,4 +119,10 @@ examples = , "" , " write documentation in Markdown format for all modules to ./generated-docs:" , " purs docs --format markdown \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\"" + , "" + , " write CTags to ./tags:" + , " purs docs --format ctags \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\"" + , "" + , " write ETags to ./TAGS:" + , " purs docs --format etags \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\"" ] From 8b561eb083f4d66b908549392553a9491158db6b Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 26 May 2019 18:28:53 +0100 Subject: [PATCH 1114/1580] Add --output option for purs docs (#3647) To control where output gets written to. Also say where output was written. Raised as part of review feedback in #3644 --- app/Command/Docs.hs | 64 +++++++++++++++++++++++++++++---------------- 1 file changed, 42 insertions(+), 22 deletions(-) diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index fdaa51c582..9d6b498d36 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -6,6 +6,7 @@ import Command.Docs.Markdown import Control.Applicative import Control.Monad.Writer import Control.Monad.Trans.Except (runExceptT) +import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Language.PureScript as P import qualified Language.PureScript.Docs as D @@ -29,36 +30,39 @@ data Format data PSCDocsOptions = PSCDocsOptions { _pscdFormat :: Format + , _pscdOutput :: Maybe FilePath , _pscdInputFiles :: [FilePath] } deriving (Show) docgen :: PSCDocsOptions -> IO () -docgen (PSCDocsOptions fmt inputGlob) = do +docgen (PSCDocsOptions fmt moutput inputGlob) = do input <- concat <$> mapM glob inputGlob when (null input) $ do hPutStrLn stderr "purs docs: no input files." exitFailure + let output = fromMaybe (defaultOutputForFormat fmt) moutput + fileMs <- parseAndConvert input let ms = D.primModules ++ map snd fileMs case fmt of - Etags -> writeTagsToFile "TAGS" $ dumpEtags fileMs - Ctags -> writeTagsToFile "tags" $ dumpCtags fileMs + Etags -> writeTagsToFile output $ dumpEtags fileMs + Ctags -> writeTagsToFile output $ dumpCtags fileMs Html -> do - let outputDir = "./generated-docs/html" -- TODO: make this configurable let ext = compile "*.html" let msHtml = map asHtml ms - createDirectoryIfMissing True outputDir - globDir1 ext outputDir >>= mapM_ removeFile - writeHtmlModules outputDir msHtml + createDirectoryIfMissing True output + globDir1 ext output >>= mapM_ removeFile + writeHtmlModules output msHtml Markdown -> do - let outputDir = "./generated-docs/md" -- TODO: make this configurable let ext = compile "*.md" let msMarkdown = map asMarkdown ms - createDirectoryIfMissing True outputDir - globDir1 ext outputDir >>= mapM_ removeFile - writeMarkdownModules outputDir msMarkdown + createDirectoryIfMissing True output + globDir1 ext output >>= mapM_ removeFile + writeMarkdownModules output msMarkdown + + putStrLn $ "Documentation written to: " ++ output where successOrExit :: Either P.MultipleErrors a -> IO a @@ -82,11 +86,6 @@ docgen (PSCDocsOptions fmt inputGlob) = do let text = T.pack . unlines $ tags writeUTF8FileT outputFile text -inputFile :: Opts.Parser FilePath -inputFile = Opts.strArgument $ - Opts.metavar "FILE" - <> Opts.help "The input .purs file(s)" - instance Read Format where readsPrec _ "etags" = [(Etags, "")] readsPrec _ "ctags" = [(Ctags, "")] @@ -94,14 +93,35 @@ instance Read Format where readsPrec _ "html" = [(Html, "")] readsPrec _ _ = [] -format :: Opts.Parser Format -format = Opts.option Opts.auto $ Opts.value Html - <> Opts.long "format" - <> Opts.metavar "FORMAT" - <> Opts.help "Set output FORMAT (markdown | html | etags | ctags)" +defaultOutputForFormat :: Format -> FilePath +defaultOutputForFormat fmt = + case fmt of + Markdown -> "generated-docs/md" + Html -> "generated-docs/html" + Etags -> "TAGS" + Ctags -> "tags" pscDocsOptions :: Opts.Parser PSCDocsOptions -pscDocsOptions = PSCDocsOptions <$> format <*> many inputFile +pscDocsOptions = PSCDocsOptions <$> format <*> output <*> many inputFile + where + format :: Opts.Parser Format + format = Opts.option Opts.auto $ + Opts.value Html + <> Opts.long "format" + <> Opts.metavar "FORMAT" + <> Opts.help "Set output FORMAT (markdown | html | etags | ctags)" + + output :: Opts.Parser (Maybe FilePath) + output = optional $ Opts.option Opts.auto $ + Opts.long "output" + <> Opts.short 'o' + <> Opts.metavar "DEST" + <> Opts.help "File/directory path for docs to be written to" + + inputFile :: Opts.Parser FilePath + inputFile = Opts.strArgument $ + Opts.metavar "FILE" + <> Opts.help "The input .purs file(s)" command :: Opts.Parser (IO ()) command = docgen <$> (Opts.helper <*> pscDocsOptions) From 2ac4de1eae9a5c13189d1d1c2b7321adbce7b4cd Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sun, 26 May 2019 10:56:05 -0700 Subject: [PATCH 1115/1580] Remove old parser (#3646) This PR updates all usages of the old parser to use the new CST parser and removes the old parser. The trickiest part is probably the purs-repl parser. I added a few parser combinators so we that we could assemble an ad-hoc parser from different productions. It handles multiple repl statements by lexing as if in a top-declaration context. I've also adjusted purs-ide import handling to only insert newlines around the import section if necessary, so that you don't get double blank lines in some cases. --- src/Language/PureScript.hs | 1 - src/Language/PureScript/CST.hs | 10 +- src/Language/PureScript/CST/Convert.hs | 12 +- src/Language/PureScript/CST/Errors.hs | 3 + src/Language/PureScript/CST/Lexer.hs | 85 ++- src/Language/PureScript/CST/Monad.hs | 51 ++ src/Language/PureScript/CST/Parser.y | 50 +- src/Language/PureScript/Docs/AsHtml.hs | 15 +- src/Language/PureScript/Docs/Convert.hs | 19 +- src/Language/PureScript/Ide/CaseSplit.hs | 21 +- src/Language/PureScript/Ide/Imports.hs | 65 +- src/Language/PureScript/Interactive/Parser.hs | 134 ++-- src/Language/PureScript/Make/Actions.hs | 14 +- src/Language/PureScript/Parser.hs | 23 - src/Language/PureScript/Parser/Common.hs | 160 ----- .../PureScript/Parser/Declarations.hs | 617 ------------------ src/Language/PureScript/Parser/Kinds.hs | 34 - src/Language/PureScript/Parser/Lexer.hs | 610 ----------------- src/Language/PureScript/Parser/State.hs | 18 - src/Language/PureScript/Parser/Types.hs | 189 ------ src/Language/PureScript/Pretty/Common.hs | 2 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 11 +- 22 files changed, 338 insertions(+), 1806 deletions(-) delete mode 100644 src/Language/PureScript/Parser.hs delete mode 100644 src/Language/PureScript/Parser/Common.hs delete mode 100644 src/Language/PureScript/Parser/Declarations.hs delete mode 100644 src/Language/PureScript/Parser/Kinds.hs delete mode 100644 src/Language/PureScript/Parser/Lexer.hs delete mode 100644 src/Language/PureScript/Parser/State.hs delete mode 100644 src/Language/PureScript/Parser/Types.hs diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index a2c7554c2a..eeb0ebd4c1 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -23,7 +23,6 @@ import Language.PureScript.Make as P import Language.PureScript.ModuleDependencies as P import Language.PureScript.Names as P import Language.PureScript.Options as P -import Language.PureScript.Parser as P import Language.PureScript.Pretty as P import Language.PureScript.Renamer as P import Language.PureScript.Sugar as P diff --git a/src/Language/PureScript/CST.hs b/src/Language/PureScript/CST.hs index 5d1712ee57..1503f18d27 100644 --- a/src/Language/PureScript/CST.hs +++ b/src/Language/PureScript/CST.hs @@ -9,11 +9,14 @@ module Language.PureScript.CST , pureResult , module Language.PureScript.CST.Convert , module Language.PureScript.CST.Errors + , module Language.PureScript.CST.Lexer + , module Language.PureScript.CST.Monad , module Language.PureScript.CST.Parser + , module Language.PureScript.CST.Print , module Language.PureScript.CST.Types ) where -import Prelude +import Prelude hiding (lex) import Control.Monad.Error.Class (MonadError(..)) import Control.Parallel.Strategies (withStrategy, parList, evalTuple2, r0, rseq) @@ -23,7 +26,10 @@ import qualified Language.PureScript.AST as AST import qualified Language.PureScript.Errors as E import Language.PureScript.CST.Convert import Language.PureScript.CST.Errors +import Language.PureScript.CST.Lexer +import Language.PureScript.CST.Monad (Parser, ParserM(..), ParserState(..), LexResult, runParser, runTokenParser) import Language.PureScript.CST.Parser +import Language.PureScript.CST.Print import Language.PureScript.CST.Types pureResult :: a -> PartialResult a @@ -54,7 +60,7 @@ parseFromFiles toFilePath input = $ \(k, a) -> (k, parseFromFile (toFilePath k) a) parseModuleFromFile :: FilePath -> Text -> Either (NE.NonEmpty ParserError) (PartialResult AST.Module) -parseModuleFromFile fp content = fmap (convertModule fp) <$> parseModule content +parseModuleFromFile fp content = fmap (convertModule fp) <$> parseModule (lex content) parseFromFile :: FilePath -> Text -> Either (NE.NonEmpty ParserError) AST.Module parseFromFile fp content = convertModule fp <$> parse content diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index ee13244881..80e8cc45e3 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -8,6 +8,7 @@ module Language.PureScript.CST.Convert , convertExpr , convertBinder , convertDeclaration + , convertImportDecl , convertModule , sourcePos , sourceSpan @@ -554,7 +555,10 @@ convertValueBindingFields fileName ann (ValueBindingFields a bs c) = do cs' = convertGuarded fileName c AST.ValueDeclaration $ AST.ValueDeclarationData ann (ident $ nameValue a) Env.Public bs' cs' -convertImportDecl :: String -> ImportDecl a -> AST.Declaration +convertImportDecl + :: String + -> ImportDecl a + -> (Pos.SourceAnn, N.ModuleName, AST.ImportDeclarationType, Maybe N.ModuleName) convertImportDecl fileName decl@(ImportDecl _ _ modName mbNames mbQual) = do let ann = uncurry (sourceAnnCommented fileName) $ importDeclRange decl @@ -565,7 +569,7 @@ convertImportDecl fileName decl@(ImportDecl _ _ modName mbNames mbQual) = do if isJust hiding then AST.Hiding imps' else AST.Explicit imps' - AST.ImportDeclaration ann (nameValue modName) importTy (nameValue . snd <$> mbQual) + (ann, nameValue modName, importTy, nameValue . snd <$> mbQual) convertImport :: String -> Import a -> AST.DeclarationRef convertImport fileName imp = case imp of @@ -621,10 +625,12 @@ convertModule :: String -> Module a -> AST.Module convertModule fileName module'@(Module _ _ modName exps _ imps decls _) = do let ann = uncurry (sourceAnnCommented fileName) $ moduleRange module' - imps' = convertImportDecl fileName <$> imps + imps' = importCtr. convertImportDecl fileName <$> imps decls' = convertDeclaration fileName =<< decls exps' = map (convertExport fileName) . toList . wrpValue <$> exps uncurry AST.Module ann (nameValue modName) (imps' <> decls') exps' + where + importCtr (a, b, c, d) = AST.ImportDeclaration a b c d ctrFields :: [N.Ident] ctrFields = [N.Ident ("value" <> Text.pack (show (n :: Integer))) | n <- [0..]] diff --git a/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs index 01c9879e5e..7d20a372eb 100644 --- a/src/Language/PureScript/CST/Errors.hs +++ b/src/Language/PureScript/CST/Errors.hs @@ -49,6 +49,7 @@ data ParserErrorType | ErrEmptyDo | ErrLexeme (Maybe String) [String] | ErrEof + | ErrCustom String deriving (Show, Eq, Ord) data ParserError = ParserError @@ -141,6 +142,8 @@ prettyPrintErrorMessage (ParserError {..}) = case errType of "Unexpected \"<-\" in expression, perhaps due to a missing 'do' or 'ado' keyword" ErrToken -> basicError + ErrCustom err -> + err where basicError = case errToks of diff --git a/src/Language/PureScript/CST/Lexer.hs b/src/Language/PureScript/CST/Lexer.hs index b1e9d83733..b17a586227 100644 --- a/src/Language/PureScript/CST/Lexer.hs +++ b/src/Language/PureScript/CST/Lexer.hs @@ -1,7 +1,10 @@ {-# LANGUAGE BangPatterns #-} module Language.PureScript.CST.Lexer - ( lex - , munch + ( lenient + , lex + , lexTopLevel + , lexWithState + , isUnquotedKey ) where import Prelude hiding (lex, exp, exponent, lines) @@ -16,27 +19,58 @@ import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as Text import Language.PureScript.CST.Errors -import Language.PureScript.CST.Monad +import Language.PureScript.CST.Monad hiding (token) import Language.PureScript.CST.Layout import Language.PureScript.CST.Positions import Language.PureScript.CST.Types -lex :: Text -> [LexResult] -lex = go1 +-- | Stops at the first lexing error and replaces it with TokEof. Otherwise, +-- the parser will fail when it attempts to draw a lookahead token. +lenient :: [LexResult] -> [LexResult] +lenient = go where - Parser lexK = - tokenAndComments + go [] = [] + go (Right a : as) = Right a : go as + go (Left (st, _) : _) = do + let + pos = lexPos st + ann = TokenAnn (SourceRange pos pos) (lexLeading st) [] + [Right (SourceToken ann TokEof)] - go1 src = do - let (leading, src') = comments src - go2 $ LexState - { lexPos = advanceLeading (SourcePos 1 1) leading +-- | Lexes according to root layout rules. +lex :: Text -> [LexResult] +lex src = do + let (leading, src') = comments src + lexWithState $ LexState + { lexPos = advanceLeading (SourcePos 1 1) leading + , lexLeading = leading + , lexSource = src' + , lexStack = [(SourcePos 0 0, LytRoot)] + } + +-- | Lexes according to top-level declaration context rules. +lexTopLevel :: Text -> [LexResult] +lexTopLevel src = do + let + (leading, src') = comments src + lexPos = advanceLeading (SourcePos 1 1) leading + hd = Right $ lytToken lexPos TokLayoutStart + tl = lexWithState $ LexState + { lexPos = lexPos , lexLeading = leading , lexSource = src' - , lexStack = [(SourcePos 0 0, LytRoot)] + , lexStack = [(lexPos, LytWhere), (SourcePos 0 0, LytRoot)] } + hd : tl - go2 state@(LexState {..}) = +-- | Lexes according to some LexState. +lexWithState :: LexState -> [LexResult] +lexWithState = go + where + Parser lexK = + tokenAndComments + + go state@(LexState {..}) = lexK lexSource onError onSuccess where onError lexSource' err = do @@ -70,20 +104,10 @@ lex = go1 , lexSource = lexSource' , lexStack = lexStack' } - go3 state' toks + go2 state' toks - go3 state [] = go2 state - go3 state (t : ts) = Right t : go3 state ts - -munch :: Parser SourceToken -munch = Parser $ \state@(ParserState {..}) kerr ksucc -> - case parserBuff of - Right tok : parserBuff' -> - ksucc (state { parserBuff = parserBuff' }) tok - Left (_, err) : _ -> - kerr state err - [] -> - error "Empty input" + go2 state [] = go state + go2 state (t : ts) = Right t : go2 state ts type Lexer = ParserM ParserErrorType Text @@ -677,3 +701,12 @@ isStringGapChar c = c == ' ' || c == '\r' || c == '\n' isLineFeed :: Char -> Bool isLineFeed c = c == '\r' || c == '\n' + +-- | Checks if some identifier is a valid unquoted key. +isUnquotedKey :: Text -> Bool +isUnquotedKey t = + case Text.uncons t of + Nothing -> + False + Just (hd, tl) -> + isIdentStart hd && Text.all isIdentChar tl diff --git a/src/Language/PureScript/CST/Monad.hs b/src/Language/PureScript/CST/Monad.hs index 49da019cad..eb7a3be456 100644 --- a/src/Language/PureScript/CST/Monad.hs +++ b/src/Language/PureScript/CST/Monad.hs @@ -67,6 +67,9 @@ runParser st (Parser k) = k st left right | null parserErrors = (st', Right res) | otherwise = (st', Left $ NE.fromList $ sortBy (comparing errRange) parserErrors) +runTokenParser :: Parser a -> [LexResult] -> Either (NE.NonEmpty ParserError) a +runTokenParser p = snd . flip runParser p . flip ParserState [] + {-# INLINE throw #-} throw :: e -> ParserM e s a throw e = Parser $ \st kerr _ -> kerr st e @@ -121,3 +124,51 @@ tryPrefix (Parser lhs) rhs = Parser $ \st kerr ksucc -> (\st' res -> do let Parser k = (Just res,) <$> rhs k st' kerr ksucc) + +oneOf :: NE.NonEmpty (Parser a) -> Parser a +oneOf parsers = Parser $ \st kerr ksucc -> do + let + go (st', Right a) _ = (st', Right a) + go _ (st', Right a) = (st', Right a) + go (st1, Left errs1) (st2, Left errs2) + | errRange (NE.last errs2) > errRange (NE.last errs1) = (st2, Left errs2) + | otherwise = (st1, Left errs1) + case foldr1 go $ runParser st <$> parsers of + (st', Left errs) -> kerr (st' { parserErrors = NE.tail errs }) $ NE.head errs + (st', Right res) -> ksucc st' res + +manyDelimited :: Token -> Token -> Token -> Parser a -> Parser [a] +manyDelimited open close sep p = do + _ <- token open + res <- go1 + _ <- token close + pure $ res + where + go1 = + oneOf $ NE.fromList + [ go2 . pure =<< p + , pure [] + ] + + go2 acc = + oneOf $ NE.fromList + [ token sep *> (go2 . (: acc) =<< p) + , pure (reverse acc) + ] + +token :: Token -> Parser SourceToken +token t = do + t' <- munch + if t == tokValue t' + then pure t' + else parseError t' + +munch :: Parser SourceToken +munch = Parser $ \state@(ParserState {..}) kerr ksucc -> + case parserBuff of + Right tok : parserBuff' -> + ksucc (state { parserBuff = parserBuff' }) tok + Left (_, err) : _ -> + kerr state err + [] -> + error "Empty input" diff --git a/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y index 35b40667e1..2585d15438 100644 --- a/src/Language/PureScript/CST/Parser.y +++ b/src/Language/PureScript/CST/Parser.y @@ -3,14 +3,23 @@ module Language.PureScript.CST.Parser ( parseType , parseKind , parseExpr + , parseDecl + , parseIdent + , parseOperator , parseModule + , parseImportDeclP + , parseDeclP + , parseExprP + , parseTypeP + , parseModuleNameP + , parseQualIdentP , parse , PartialResult(..) ) where import Prelude hiding (lex) -import Control.Monad ((>=>), when) +import Control.Monad ((<=<), when) import Data.Foldable (foldl', for_) import qualified Data.List.NonEmpty as NE import Data.Text (Text) @@ -30,7 +39,16 @@ import Language.PureScript.PSString (PSString) %name parseKind kind %name parseType type %name parseExpr expr +%name parseIdent ident +%name parseOperator op %name parseModuleBody moduleBody +%name parseDecl decl +%partial parseImportDeclP importDeclP +%partial parseDeclP declP +%partial parseExprP exprP +%partial parseTypeP typeP +%partial parseModuleNameP moduleNameP +%partial parseQualIdentP qualIdentP %partial parseModuleHeader moduleHeader %partial parseDoStatement doStatement %partial parseDoExpr doExpr @@ -719,23 +737,45 @@ foreign :: { Foreign () } | 'data' properName '::' kind { ForeignData $1 (Labeled $2 $3 $4) } | 'kind' properName { ForeignKind $1 $2 } +-- Partial parsers which can be combined with combinators for adhoc use. We need +-- to revert the lookahead token so that it doesn't consume an extra token +-- before succeeding. + +importDeclP :: { ImportDecl () } + : importDecl {%^ revert $ pure $1 } + +declP :: { Declaration () } + : decl {%^ revert $ pure $1 } + +exprP :: { Expr () } + : expr {%^ revert $ pure $1 } + +typeP :: { Type () } + : type {%^ revert $ pure $1 } + +moduleNameP :: { Name N.ModuleName } + : moduleName {%^ revert $ pure $1 } + +qualIdentP :: { QualifiedName Ident } + : qualIdent {%^ revert $ pure $1 } + { lexer :: (SourceToken -> Parser a) -> Parser a lexer k = munch >>= k parse :: Text -> Either (NE.NonEmpty ParserError) (Module ()) -parse = parseModule >=> resFull +parse = resFull <=< parseModule . lex data PartialResult a = PartialResult { resPartial :: a , resFull :: Either (NE.NonEmpty ParserError) a } deriving (Functor) -parseModule :: Text -> Either (NE.NonEmpty ParserError) (PartialResult (Module ())) -parseModule src = fmap (\header -> PartialResult header (parseFull header)) headerRes +parseModule :: [LexResult] -> Either (NE.NonEmpty ParserError) (PartialResult (Module ())) +parseModule toks = fmap (\header -> PartialResult header (parseFull header)) headerRes where (st, headerRes) = - runParser (ParserState (lex src) []) parseModuleHeader + runParser (ParserState (toks) []) parseModuleHeader parseFull header = do (decls, trailing) <- snd $ runParser st parseModuleBody diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index cc9c3b7302..563de1ee1e 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -17,8 +17,10 @@ module Language.PureScript.Docs.AsHtml ( import Prelude import Control.Category ((>>>)) import Control.Monad (unless) +import Data.Bifunctor (first) import Data.Char (isUpper) import Data.Either (isRight) +import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe) import Data.Foldable (for_) import Data.String (fromString) @@ -29,13 +31,13 @@ import qualified Data.Text as T import Text.Blaze.Html5 as H hiding (map) import qualified Text.Blaze.Html5.Attributes as A import qualified Cheapskate -import Text.Parsec (eof) import qualified Language.PureScript as P import Language.PureScript.Docs.Types import Language.PureScript.Docs.RenderedCode hiding (sp) import qualified Language.PureScript.Docs.Render as Render +import qualified Language.PureScript.CST as CST declNamespace :: Declaration -> Namespace declNamespace = declInfoNamespace . declInfo @@ -219,12 +221,13 @@ codeAsHtml r = outputWith elemAsHtml then False else isUpper (T.index str 0) - isOp = isRight . runParser P.symbol + isOp = isRight . runParser CST.parseOperator - runParser :: P.TokenParser a -> Text -> Either String a - runParser p' s = either (Left . show) Right $ do - ts <- P.lex "" s - P.runTokenParser "" (p' <* eof) ts + runParser :: CST.Parser a -> Text -> Either String a + runParser p' = + first (CST.prettyPrintError . NE.head) + . CST.runTokenParser p' + . CST.lex renderLink :: HtmlRenderContext -> DocLink -> Html -> Html renderLink r link_@DocLink{..} = diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 79d7160e9a..39a37ff5b9 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -15,19 +15,19 @@ import Control.Arrow ((&&&)) import Control.Category ((>>>)) import Control.Monad.Writer.Strict (runWriterT) import Data.Functor (($>)) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Data.String (String) +import qualified Language.PureScript as P import Language.PureScript.Docs.Convert.ReExports (updateReExports) import Language.PureScript.Docs.Convert.Single (convertSingleModule) import Language.PureScript.Docs.Prim (primModules) import Language.PureScript.Docs.Types -import qualified Language.PureScript as P +import qualified Language.PureScript.CST as CST import Web.Bower.PackageMeta (PackageName) -import Text.Parsec (eof) - -- | -- Like convertModuleInPackage, but with the modules tagged by their -- file paths. @@ -211,7 +211,7 @@ insertValueTypes env m = where go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard{} }) = let - ident = parseIdent (declTitle d) + ident = P.Ident . CST.getIdent . CST.nameValue . parseIdent $ declTitle d ty = lookupName ident in d { declInfo = ValueDeclaration (ty $> ()) } @@ -219,7 +219,7 @@ insertValueTypes env m = other parseIdent = - either (err . ("failed to parse Ident: " ++)) identity . runParser P.parseIdent + either (err . ("failed to parse Ident: " ++)) identity . runParser CST.parseIdent lookupName name = let key = P.Qualified (Just (modName m)) name @@ -232,10 +232,11 @@ insertValueTypes env m = err msg = P.internalError ("Docs.Convert.insertValueTypes: " ++ msg) -runParser :: P.TokenParser a -> Text -> Either String a -runParser p s = either (Left . show) Right $ do - ts <- P.lex "" s - P.runTokenParser "" (p <* eof) ts +runParser :: CST.Parser a -> Text -> Either String a +runParser p = + first (CST.prettyPrintError . NE.head) + . CST.runTokenParser p + . CST.lex -- | -- Partially desugar modules so that they are suitable for extracting diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index a617ba08ef..0cc2aa607b 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -23,18 +23,17 @@ module Language.PureScript.Ide.CaseSplit import Protolude hiding (Constructor) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import qualified Data.Text as T import qualified Language.PureScript as P +import qualified Language.PureScript.CST as CST import Language.PureScript.Externs import Language.PureScript.Ide.Error import Language.PureScript.Ide.State import Language.PureScript.Ide.Types -import Text.Parsec as Parsec -import qualified Text.PrettyPrint.Boxes as Box - type Constructor = (P.ProperName 'P.ConstructorName, [P.SourceType]) newtype WildcardAnnotations = WildcardAnnotations Bool @@ -125,24 +124,24 @@ addClause s wca = do parseType' :: (MonadError IdeError m) => Text -> m P.SourceType parseType' s = - case P.lex "" (toS s) >>= P.runTokenParser "" (P.parseType <* Parsec.eof) of - Right type' -> pure type' + case CST.runTokenParser CST.parseType $ CST.lex s of + Right type' -> pure $ CST.convertType "" type' Left err -> throwError (GeneralError ("Parsing the splittype failed with:" <> show err)) parseTypeDeclaration' :: (MonadError IdeError m) => Text -> m (P.Ident, P.SourceType) parseTypeDeclaration' s = - let x = do - ts <- P.lex "" (toS s) - P.runTokenParser "" (P.parseDeclaration <* Parsec.eof) ts + let x = fmap (CST.convertDeclaration "") + $ CST.runTokenParser CST.parseDecl + $ CST.lex s in case x of - Right (P.TypeDeclaration td : _) -> pure (P.unwrapTypeDeclaration td) + Right [P.TypeDeclaration td] -> pure (P.unwrapTypeDeclaration td) Right _ -> throwError (GeneralError "Found a non-type-declaration") - Left err -> + Left errs -> throwError (GeneralError ("Parsing the type signature failed with: " - <> toS (Box.render (P.prettyPrintParseError err)))) + <> toS (CST.prettyPrintErrorMessage $ NE.head errs))) splitFunctionType :: P.Type a -> [P.Type a] splitFunctionType t = fromMaybe [] arguments diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index e880248323..6af718b929 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -33,10 +33,12 @@ module Language.PureScript.Ide.Imports import Protolude hiding (moduleName) import Data.List (findIndex, nubBy, partition) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Text as T import qualified Language.PureScript as P import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.CST as CST import Language.PureScript.Ide.Completion import Language.PureScript.Ide.Error import Language.PureScript.Ide.Filter @@ -46,7 +48,6 @@ import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import Lens.Micro.Platform ((^.), (%~), ix, has) import System.IO.UTF8 (writeUTF8FileT) -import qualified Text.Parsec as Parsec data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) deriving (Eq, Show) @@ -90,21 +91,27 @@ data ImportParse = ImportParse -- ^ the extracted import declarations } -parseModuleHeader :: P.TokenParser ImportParse -parseModuleHeader = do - _ <- P.readComments - (mn, _) <- P.parseModuleDeclaration - (ipStart, ipEnd, decls) <- P.withSourceSpan (\(P.SourceSpan _ start end) _ -> (start, end,)) - (P.mark (Parsec.many (P.same *> P.parseImportDeclaration'))) - pure (ImportParse mn ipStart ipEnd (map mkImport decls)) - where - mkImport (mn, (P.Explicit refs), qual) = Import mn (P.Explicit refs) qual - mkImport (mn, it, qual) = Import mn it qual +parseModuleHeader :: Text -> Either (NE.NonEmpty CST.ParserError) ImportParse +parseModuleHeader src = do + CST.PartialResult md _ <- CST.parseModule $ CST.lenient $ CST.lex src + let + mn = CST.nameValue $ CST.modNamespace md + decls = flip fmap (CST.modImports md) $ \decl -> do + let ((ss, _), mn', it, qual) = CST.convertImportDecl "" decl + (ss, Import mn' it qual) + case (head decls, lastMay decls) of + (Just hd, Just ls) -> do + let + ipStart = P.spanStart $ fst hd + ipEnd = P.spanEnd $ fst ls + pure $ ImportParse mn ipStart ipEnd $ snd <$> decls + _ -> do + let pos = CST.sourcePos . CST.srcEnd . CST.tokRange . CST.tokAnn $ CST.modWhere md + pure $ ImportParse mn pos pos [] sliceImportSection :: [Text] -> Either Text (P.ModuleName, [Text], [Import], [Text]) -sliceImportSection fileLines = first show $ do - tokens <- P.lexLenient "" file - ImportParse{..} <- P.runTokenParser "" parseModuleHeader tokens +sliceImportSection fileLines = first (toS . CST.prettyPrintError . NE.head) $ do + ImportParse{..} <- parseModuleHeader file pure ( ipModuleName , sliceFile (P.SourcePos 1 1) (prevPos ipStart) @@ -138,7 +145,7 @@ addImplicitImport addImplicitImport fp mn = do (_, pre, imports, post) <- parseImportsFromFile' fp let newImportSection = addImplicitImport' imports mn - pure (pre ++ newImportSection ++ post) + pure $ joinSections (pre, newImportSection, post) addImplicitImport' :: [Import] -> P.ModuleName -> [Text] addImplicitImport' imports mn = @@ -157,7 +164,7 @@ addQualifiedImport addQualifiedImport fp mn qualifier = do (_, pre, imports, post) <- parseImportsFromFile' fp let newImportSection = addQualifiedImport' imports mn qualifier - pure (pre ++ newImportSection ++ post) + pure $ joinSections (pre, newImportSection, post) addQualifiedImport' :: [Import] -> P.ModuleName -> P.ModuleName -> [Text] addQualifiedImport' imports mn qualifier = @@ -180,7 +187,7 @@ addExplicitImport fp decl moduleName qualifier = do if mn == moduleName then imports else addExplicitImport' decl moduleName qualifier imports - pure (pre ++ prettyPrintImportSection newImportSection ++ post) + pure $ joinSections (pre, prettyPrintImportSection newImportSection, post) addExplicitImport' :: IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> [Import] -> [Import] addExplicitImport' decl moduleName qualifier imports = @@ -364,9 +371,21 @@ answerRequest outfp rs = -- | Test and ghci helper parseImport :: Text -> Maybe Import parseImport t = - case P.lex "" t - >>= P.runTokenParser "" P.parseImportDeclaration' of - Right (mn, P.Explicit refs, mmn) -> - Just (Import mn (P.Explicit refs) mmn) - Right (mn, idt, mmn) -> Just (Import mn idt mmn) - Left _ -> Nothing + case fmap (CST.convertImportDecl "") + $ CST.runTokenParser CST.parseImportDeclP + $ CST.lex t of + Right (_, mn, idt, mmn) -> + Just (Import mn idt mmn) + _ -> Nothing + +joinSections :: ([Text], [Text], [Text]) -> [Text] +joinSections (pre, decls, post) = pre `joinLine` (decls `joinLine` post) + where + isBlank = T.all (== ' ') + joinLine as bs + | Just ln1 <- lastMay as + , Just ln2 <- head bs + , not (isBlank ln1) && not (isBlank ln2) = + as ++ [""] ++ bs + | otherwise = + as ++ bs diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index cefec9ff72..33a0ed7ea8 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -8,27 +8,35 @@ module Language.PureScript.Interactive.Parser import Prelude.Compat hiding (lex) -import Control.Applicative ((<|>)) -import Control.Monad (join) +import Control.Monad (join, unless) import Data.Bifunctor (first) import Data.Char (isSpace) import Data.List (intercalate) +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T -import Text.Parsec hiding ((<|>)) import qualified Language.PureScript as P +import qualified Language.PureScript.CST as CST +import qualified Language.PureScript.CST.Monad as CSTM +import qualified Language.PureScript.CST.Positions as CST import qualified Language.PureScript.Interactive.Directive as D import Language.PureScript.Interactive.Types -import Language.PureScript.Parser.Common (mark, same) -- | -- Parses a limited set of commands from from .purs-repl -- parseDotFile :: FilePath -> String -> Either String [Command] -parseDotFile filePath s = first show $ do - ts <- P.lex filePath (T.pack s) - P.runTokenParser filePath (many parser <* eof) ts +parseDotFile filePath = + first (CST.prettyPrintError . NE.head) + . CST.runTokenParser (parseMany parser <* CSTM.token CST.TokEof) + . CST.lexTopLevel + . T.pack where - parser = psciImport <|> fail "The .purs-repl file only supports import declarations" + parser = CSTM.oneOf $ NE.fromList + [ psciImport filePath + , do + tok <- CSTM.munch + CSTM.parseFail tok $ CST.ErrCustom "The .purs-repl file only supports import declarations" + ] -- | -- Parses PSCI metacommands or expressions input from the user. @@ -37,21 +45,37 @@ parseCommand :: String -> Either String [Command] parseCommand cmdString = case cmdString of (':' : cmd) -> pure <$> parseDirective cmd - _ -> parseRest (many1 psciCommand) cmdString - -parseRest :: P.TokenParser a -> String -> Either String a -parseRest p s = first show $ do - ts <- P.lex "" (T.pack s) - P.runTokenParser "" (p <* eof) ts - -psciCommand :: P.TokenParser Command -psciCommand = choice (map try parsers) + _ -> parseRest (mergeDecls <$> parseMany psciCommand) cmdString where - parsers = - [ psciImport + mergeDecls (Decls as : bs) = + case mergeDecls bs of + Decls bs' : cs' -> + Decls (as <> bs') : cs' + cs' -> + Decls as : cs' + mergeDecls (a : bs) = + a : mergeDecls bs + mergeDecls [] = [] + +parseMany :: CST.Parser a -> CST.Parser [a] +parseMany = CSTM.manyDelimited CST.TokLayoutStart CST.TokLayoutEnd CST.TokLayoutSep + +parseOne :: CST.Parser a -> CST.Parser a +parseOne p = CSTM.token CST.TokLayoutStart *> p <* CSTM.token CST.TokLayoutEnd + +parseRest :: CST.Parser a -> String -> Either String a +parseRest p = + first (CST.prettyPrintError . NE.head) + . CST.runTokenParser (p <* CSTM.token CST.TokEof) + . CST.lexTopLevel + . T.pack + +psciCommand :: CST.Parser Command +psciCommand = + CSTM.oneOf $ NE.fromList + [ psciImport "" , psciDeclaration , psciExpression - , psciDeprecatedLet ] trim :: String -> String @@ -79,38 +103,41 @@ parseDirective cmd = Reload -> return ReloadState Clear -> return ClearState Paste -> return PasteLines - Browse -> BrowseModule <$> parseRest P.moduleName arg + Browse -> BrowseModule . CST.nameValue <$> parseRest (parseOne CST.parseModuleNameP) arg Show -> ShowInfo <$> parseReplQuery' arg - Type -> TypeOf <$> parseRest P.parseValue arg - Kind -> KindOf <$> parseRest P.parseType arg + Type -> TypeOf . CST.convertExpr "" <$> parseRest (parseOne CST.parseExprP) arg + Kind -> KindOf . CST.convertType "" <$> parseRest (parseOne CST.parseTypeP) arg Complete -> return (CompleteStr arg) - Print -> parseRest - ((eof *> return (ShowInfo QueryPrint)) - <|> (SetInteractivePrint <$> parseFullyQualifiedIdent)) - arg + Print + | arg == "" -> return $ ShowInfo QueryPrint + | otherwise -> SetInteractivePrint <$> parseRest (parseOne parseFullyQualifiedIdent) arg -- | -- Parses expressions entered at the PSCI repl. -- -psciExpression :: P.TokenParser Command -psciExpression = Expression <$> P.parseValue +psciExpression :: CST.Parser Command +psciExpression = Expression . CST.convertExpr "" <$> CST.parseExprP -- | Imports must be handled separately from other declarations, so that -- :show import works, for example. -psciImport :: P.TokenParser Command -psciImport = do - (mn, declType, asQ) <- P.parseImportDeclaration' - return $ Import (mn, declType, asQ) +psciImport :: FilePath -> CST.Parser Command +psciImport filePath = do + (_, mn, declType, asQ) <- CST.convertImportDecl filePath <$> CST.parseImportDeclP + pure $ Import (mn, declType, asQ) -- | Any declaration that we don't need a 'special case' parser for -- (like import declarations). -psciDeclaration :: P.TokenParser Command -psciDeclaration = fmap Decls $ mark $ fmap join (many1 $ same *> - (traverse accept =<< P.parseDeclaration)) - where - accept decl - | acceptable decl = return decl - | otherwise = fail "this kind of declaration is not supported in psci" +psciDeclaration :: CST.Parser Command +psciDeclaration = do + decl <- CST.parseDeclP + let decl' = CST.convertDeclaration "" decl + unless (all acceptable decl') $ do + let + tok = fst $ CST.declRange decl + tok' = T.unpack $ CST.printToken $ CST.tokValue tok + msg = tok' <> "; this kind of declaration is not supported in psci" + CSTM.parseFail tok $ CST.ErrLexeme (Just msg) [] + pure $ Decls decl' acceptable :: P.Declaration -> Bool acceptable P.DataDeclaration{} = True @@ -131,21 +158,12 @@ parseReplQuery' str = intercalate ", " replQueryStrings ++ ".") Just query -> Right query --- | To show error message when 'let' is used for declaration in PSCI, --- which is deprecated. -psciDeprecatedLet :: P.TokenParser Command -psciDeprecatedLet = do - P.reserved "let" - P.indented - _ <- mark (many1 (same *> P.parseLocalDeclaration)) - notFollowedBy $ P.reserved "in" - fail "Declarations in PSCi no longer require \"let\", as of version 0.11.0" - -parseFullyQualifiedIdent :: P.TokenParser (P.ModuleName, P.Ident) -parseFullyQualifiedIdent = do - qname <- P.parseQualified P.parseIdent - case qname of - P.Qualified (Just mn) ident -> - pure (mn, ident) - P.Qualified Nothing _ -> - fail "Expected a fully-qualified name (eg: PSCI.Support.eval)" +parseFullyQualifiedIdent :: CST.Parser (P.ModuleName, P.Ident) +parseFullyQualifiedIdent = join $ CST.Parser $ \st _ ksucc -> + case CST.runParser st CST.parseQualIdentP of + (st', Right (CST.QualifiedName _ (Just mn) ident)) -> + ksucc st' $ pure (mn, P.Ident $ CST.getIdent ident) + _ -> + ksucc st $ do + tok <- CSTM.munch + CSTM.parseFail tok $ CST.ErrCustom "Expected a fully-qualified name (eg: PSCI.Support.eval)" diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index f7c6d5eaee..eb59ba55a6 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -17,6 +17,7 @@ import Control.Monad.Supply import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Aeson (encode) +import Data.Bifunctor (bimap) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy.UTF8 as LBU8 @@ -39,20 +40,19 @@ import qualified Language.PureScript.CoreFn as CF import qualified Language.PureScript.CoreFn.ToJSON as CFJ import qualified Language.PureScript.CoreImp.AST as Imp import Language.PureScript.Crash +import qualified Language.PureScript.CST as CST import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Make.Monad import Language.PureScript.Names import Language.PureScript.Names (runModuleName, ModuleName) import Language.PureScript.Options hiding (codegenTargets) -import qualified Language.PureScript.Parser as PSParser import Language.PureScript.Pretty.Common (SMap(..)) import qualified Paths_purescript as Paths import SourceMap import SourceMap.Types import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise) -import qualified Text.Parsec as Parsec -- | Determines when to rebuild a module data RebuildPolicy @@ -288,8 +288,8 @@ checkForeignDecls m path = do -- We ignore the error message here, just being told it's an invalid -- identifier should be enough. parseIdent :: String -> Either String Ident - parseIdent str = try (T.pack str) - where - try s = either (const (Left str)) Right $ do - ts <- PSParser.lex "" s - PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts + parseIdent str = + bimap (const str) (Ident . CST.getIdent . CST.nameValue) + . CST.runTokenParser CST.parseIdent + . CST.lex + $ T.pack str diff --git a/src/Language/PureScript/Parser.hs b/src/Language/PureScript/Parser.hs deleted file mode 100644 index c7ac55a3dd..0000000000 --- a/src/Language/PureScript/Parser.hs +++ /dev/null @@ -1,23 +0,0 @@ --- | --- A collection of parsers for core data types: --- --- [@Language.PureScript.Parser.Kinds@] Parser for kinds --- --- [@Language.PureScript.Parser.Values@] Parser for values --- --- [@Language.PureScript.Parser.Types@] Parser for types --- --- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules --- --- [@Language.PureScript.Parser.State@] Parser state, including indentation --- --- [@Language.PureScript.Parser.Common@] Common parsing utility functions --- -module Language.PureScript.Parser (module P) where - -import Language.PureScript.Parser.Common as P -import Language.PureScript.Parser.Declarations as P -import Language.PureScript.Parser.Kinds as P -import Language.PureScript.Parser.Lexer as P -import Language.PureScript.Parser.State as P -import Language.PureScript.Parser.Types as P diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs deleted file mode 100644 index 0b430baabe..0000000000 --- a/src/Language/PureScript/Parser/Common.hs +++ /dev/null @@ -1,160 +0,0 @@ --- | Useful common functions for building parsers -module Language.PureScript.Parser.Common where - -import Prelude.Compat - -import Control.Applicative ((<|>)) -import Control.Monad (guard) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Language.PureScript.AST.SourcePos -import Language.PureScript.Comments -import Language.PureScript.Names -import Language.PureScript.Parser.Lexer -import Language.PureScript.Parser.State -import Language.PureScript.PSString (PSString, mkString) -import qualified Text.Parsec as P - --- | Parse a general proper name. -properName :: TokenParser (ProperName a) -properName = ProperName <$> uname - --- | Parse a proper name for a type. -typeName :: TokenParser (ProperName 'TypeName) -typeName = ProperName <$> tyname - --- | Parse a proper name for a kind. -kindName :: TokenParser (ProperName 'KindName) -kindName = ProperName <$> kiname - --- | Parse a proper name for a data constructor. -dataConstructorName :: TokenParser (ProperName 'ConstructorName) -dataConstructorName = ProperName <$> dconsname - --- | Parse a module name -moduleName :: TokenParser ModuleName -moduleName = part [] - where - part path = (do name <- ProperName <$> P.try qualifier - part (path `snoc` name)) - <|> (ModuleName . snoc path . ProperName <$> mname) - snoc path name = path ++ [name] - --- | Parse a qualified name, i.e. M.name or just name -parseQualified :: TokenParser a -> TokenParser (Qualified a) -parseQualified parser = part [] - where - part path = (do name <- ProperName <$> P.try qualifier - part (updatePath path name)) - <|> (Qualified (qual path) <$> P.try parser) - updatePath path name = path ++ [name] - qual path = if null path then Nothing else Just $ ModuleName path - --- | Parse an identifier. -parseIdent :: TokenParser Ident -parseIdent = Ident <$> identifier - --- | Parse a label, which may look like an identifier or a string -parseLabel :: TokenParser PSString -parseLabel = (mkString <$> lname) <|> stringLiteral - --- | Parse an operator. -parseOperator :: TokenParser (OpName a) -parseOperator = OpName <$> symbol - --- | Run the first parser, then match the second if possible, applying the specified function on a successful match -augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a -augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q - --- | Run the first parser, then match the second zero or more times, applying the specified function for each match -fold :: P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a -fold first' more combine = do - a <- first' - bs <- P.many more - return $ foldl combine a bs - --- | Build a parser from a smaller parser and a list of parsers for postfix operators -buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a -buildPostfixParser fs first' = do - a <- first' - go a - where - go a = do - maybeA <- P.optionMaybe $ P.choice (map ($ a) fs) - case maybeA of - Nothing -> return a - Just a' -> go a' - --- | Mark the current indentation level -mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a -mark p = do - current <- indentationLevel <$> P.getState - pos <- P.sourceColumn <$> P.getPosition - P.modifyState $ \st -> st { indentationLevel = pos } - a <- p - P.modifyState $ \st -> st { indentationLevel = current } - return a - --- | Check that the current identation level matches a predicate -checkIndentation - :: (P.Column -> Text) - -> (P.Column -> P.Column -> Bool) - -> P.Parsec s ParseState () -checkIndentation mkMsg rel = do - col <- P.sourceColumn <$> P.getPosition - current <- indentationLevel <$> P.getState - guard (col `rel` current) P. T.unpack (mkMsg current) - --- | Check that the current indentation level is past the current mark -indented :: P.Parsec s ParseState () -indented = checkIndentation (("indentation past column " <>) . (T.pack . show)) (>) - --- | Check that the current indentation level is at the same indentation as the current mark -same :: P.Parsec s ParseState () -same = checkIndentation (("indentation at column " <>) . (T.pack . show)) (==) - --- | Read the comments from the the next token, without consuming it -readComments :: P.Parsec [PositionedToken] u [Comment] -readComments = P.lookAhead $ ptComments <$> P.anyToken - --- | Run a parser -runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a -runTokenParser filePath p = P.runParser p (ParseState 0) filePath - --- | Convert from Parsec sourcepos -toSourcePos :: P.SourcePos -> SourcePos -toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos) - --- | Read source position information and comments -withSourceSpan - :: (SourceSpan -> [Comment] -> a -> b) - -> P.Parsec [PositionedToken] u a - -> P.Parsec [PositionedToken] u b -withSourceSpan f p = do - comments <- readComments - start <- P.getPosition - x <- p - end <- P.getPosition - input <- P.getInput - let end' = case input of - pt:_ -> ptPrevEndPos pt - _ -> Nothing - let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos $ fromMaybe end end') - return $ f sp comments x - -withSourceAnnF - :: P.Parsec [PositionedToken] u (SourceAnn -> a) - -> P.Parsec [PositionedToken] u a -withSourceAnnF = withSourceSpan (\ss com f -> f (ss, com)) - -withSourceSpan' - :: (SourceSpan -> a -> b) - -> P.Parsec [PositionedToken] u a - -> P.Parsec [PositionedToken] u b -withSourceSpan' f = withSourceSpan (\ss _ -> f ss) - -withSourceSpanF - :: P.Parsec [PositionedToken] u (SourceSpan -> a) - -> P.Parsec [PositionedToken] u a -withSourceSpanF = withSourceSpan (\ss _ f -> f ss) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs deleted file mode 100644 index f1cf76eda3..0000000000 --- a/src/Language/PureScript/Parser/Declarations.hs +++ /dev/null @@ -1,617 +0,0 @@ --- | Parsers for module definitions and declarations -module Language.PureScript.Parser.Declarations - ( parseDeclaration - , parseDeclarationRef - , parseModule - , parseModuleDeclaration - , parseValue - , parseGuard - , parseBinder - , parseBinderNoParens - , parseImportDeclaration' - , parseLocalDeclaration - ) where - -import Prelude hiding (lex) -import Protolude (ordNub) - -import Control.Applicative -import Control.Arrow ((+++)) -import Control.Monad (foldM, join, zipWithM) -import Data.Functor (($>)) -import Data.Maybe (fromMaybe) -import qualified Data.Set as S -import Data.Text (pack) -import Language.PureScript.AST -import Language.PureScript.Environment -import Language.PureScript.Names -import Language.PureScript.Parser.Common -import Language.PureScript.Parser.Kinds -import Language.PureScript.Parser.Lexer -import Language.PureScript.Parser.Types -import Language.PureScript.PSString (PSString, mkString) -import Language.PureScript.Types -import qualified Text.Parsec as P -import qualified Text.Parsec.Expr as P - -fields :: [Ident] -fields = [ Ident ("value" <> pack (show (n :: Integer))) | n <- [0..] ] - -parseDataDeclaration :: TokenParser Declaration -parseDataDeclaration = withSourceAnnF $ do - dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype) - name <- indented *> typeName - tyArgs <- many (indented *> kindedIdent) - ctors <- P.option [] $ do - indented *> equals - flip P.sepBy1 pipe $ do - ctorName <- dataConstructorName - tys <- P.many (indented *> noWildcards parseTypeAtom) - return (ctorName, zip fields tys) - return $ \sa -> DataDeclaration sa dtype name tyArgs ctors - -parseTypeDeclaration :: TokenParser Declaration -parseTypeDeclaration = withSourceAnnF $ do - name <- P.try (parseIdent <* indented <* doubleColon) - ty <- parsePolyType - return $ \sa -> TypeDeclaration (TypeDeclarationData sa name ty) - -parseTypeSynonymDeclaration :: TokenParser Declaration -parseTypeSynonymDeclaration = withSourceAnnF $ do - name <- reserved "type" *> indented *> typeName - vars <- many (indented *> kindedIdent) - ty <- indented *> equals *> noWildcards parsePolyType - return $ \sa -> TypeSynonymDeclaration sa name vars ty - -parseValueWithWhereClause :: TokenParser Expr -parseValueWithWhereClause = do - indented - value <- parseValue - whereClause <- P.optionMaybe $ do - indented - reserved "where" - indented - mark $ P.many1 (same *> parseLocalDeclaration) - return $ maybe value (\ds -> Let FromWhere ds value) whereClause - -parseValueWithIdentAndBinders :: Ident -> [Binder] -> TokenParser (SourceAnn -> Declaration) -parseValueWithIdentAndBinders ident bs = do - value <- indented *> ( - (\v -> [MkUnguarded v]) <$> (equals *> withSourceSpan PositionedValue parseValueWithWhereClause) <|> - P.many1 (GuardedExpr <$> parseGuard - <*> (indented *> equals - *> withSourceSpan PositionedValue parseValueWithWhereClause)) - ) - return $ \sa -> ValueDecl sa ident Public bs value - -parseValueDeclaration :: TokenParser Declaration -parseValueDeclaration = withSourceAnnF $ do - ident <- parseIdent - binders <- P.many parseBinderNoParens - parseValueWithIdentAndBinders ident binders - -parseLocalValueDeclaration :: TokenParser Declaration -parseLocalValueDeclaration = withSourceAnnF . - join $ go <$> parseBinder <*> P.many parseBinderNoParens - where - go :: Binder -> [Binder] -> TokenParser (SourceAnn -> Declaration) - go (VarBinder _ ident) bs = parseValueWithIdentAndBinders ident bs - go (PositionedBinder _ _ b) bs = go b bs - go binder [] = do - boot <- indented *> equals *> parseValueWithWhereClause - return $ \sa -> BoundValueDeclaration sa binder boot - go _ _ = P.unexpected "patterns in local value declaration" - -parseExternDeclaration :: TokenParser Declaration -parseExternDeclaration = withSourceAnnF $ - reserved "foreign" *> - indented *> reserved "import" *> - indented *> (parseExternData <|> P.try parseExternKind <|> parseExternTerm) - where - parseExternData = - (\name kind sa -> ExternDataDeclaration sa name kind) - <$> (reserved "data" *> indented *> typeName) - <*> (indented *> doubleColon *> parseKind) - parseExternKind = - flip ExternKindDeclaration - <$> (reserved "kind" *> indented *> kindName) - parseExternTerm = - (\name ty sa -> ExternDeclaration sa name ty) - <$> parseIdent - <*> (indented *> doubleColon *> noWildcards parsePolyType) - -parseAssociativity :: TokenParser Associativity -parseAssociativity = - (reserved "infixl" *> return Infixl) <|> - (reserved "infixr" *> return Infixr) <|> - (reserved "infix" *> return Infix) - -parseFixity :: TokenParser Fixity -parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural) - -parseFixityDeclaration :: TokenParser Declaration -parseFixityDeclaration = withSourceAnnF $ do - fixity <- parseFixity - indented - def <- (Right <$> typeFixity fixity) <|> (Left <$> valueFixity fixity) - return $ \sa -> FixityDeclaration sa def - where - typeFixity fixity = - TypeFixity fixity - <$> (reserved "type" *> parseQualified typeName) - <*> (reserved "as" *> parseOperator) - valueFixity fixity = - ValueFixity fixity - <$> parseQualified ((Left <$> parseIdent) <|> (Right <$> dataConstructorName)) - <*> (reserved "as" *> parseOperator) - -parseImportDeclaration :: TokenParser Declaration -parseImportDeclaration = withSourceAnnF $ do - (mn, declType, asQ) <- parseImportDeclaration' - return $ \sa -> ImportDeclaration sa mn declType asQ - -parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName) -parseImportDeclaration' = do - reserved "import" - indented - moduleName' <- moduleName - declType <- reserved "hiding" *> qualifyingList Hiding <|> qualifyingList Explicit - qName <- P.optionMaybe qualifiedName - return (moduleName', declType, qName) - where - qualifiedName = reserved "as" *> moduleName - qualifyingList expectedType = do - declType <- P.optionMaybe (expectedType <$> (indented *> parens (commaSep parseDeclarationRef))) - return $ fromMaybe Implicit declType - -parseDeclarationRef :: TokenParser DeclarationRef -parseDeclarationRef = - withSourceSpan' KindRef (P.try (reserved "kind" *> kindName)) - <|> withSourceSpan' ValueRef parseIdent - <|> withSourceSpan' ValueOpRef (parens parseOperator) - <|> withSourceSpan' (\sa -> ($ TypeRef sa)) parseTypeRef - <|> withSourceSpan' TypeClassRef (reserved "class" *> properName) - <|> withSourceSpan' ModuleRef (indented *> reserved "module" *> moduleName) - <|> withSourceSpan' TypeOpRef (indented *> reserved "type" *> parens parseOperator) - where - parseTypeRef = do - name <- typeName - dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep dataConstructorName) - return $ \f -> f name (fromMaybe (Just []) dctors) - -parseTypeClassDeclaration :: TokenParser Declaration -parseTypeClassDeclaration = withSourceAnnF $ do - reserved "class" - implies <- P.option [] . P.try $ do - indented - implies <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint) - lfatArrow - return implies - className <- indented *> properName - idents <- P.many (indented *> kindedIdent) - let parseNamedIdent = foldl (<|>) empty (zipWith (\(name, _) index -> lname' name $> index) idents [0..]) - parseFunctionalDependency = - FunctionalDependency <$> P.many parseNamedIdent <* rarrow - <*> P.many parseNamedIdent - dependencies <- P.option [] (indented *> pipe *> commaSep1 parseFunctionalDependency) - members <- P.option [] $ do - indented *> reserved "where" - indented *> mark (P.many (same *> parseTypeDeclaration)) - return $ \sa -> TypeClassDeclaration sa className idents implies dependencies members - -parseConstraint :: TokenParser SourceConstraint -parseConstraint = withSourceAnnF $ do - name <- parseQualified properName - args <- P.many (noWildcards $ noForAll parseTypeAtom) - return $ \ann -> Constraint ann name args Nothing - -parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) -parseInstanceDeclaration = withSourceAnnF $ do - reserved "instance" - name <- parseIdent <* indented <* doubleColon - deps <- P.optionMaybe . P.try $ do - deps <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint) - indented - rfatArrow - return deps - className <- indented *> parseQualified properName - ty <- P.many (indented *> parseTypeAtom) - return $ \sa -> TypeInstanceDeclaration sa [] 0 name (fromMaybe [] deps) className ty - -parseTypeInstanceDeclaration :: TokenParser Declaration -parseTypeInstanceDeclaration = do - instanceDecl <- parseInstanceDeclaration - members <- P.option [] $ do - indented *> reserved "where" - indented *> mark (P.many (same *> declsInInstance)) - return $ instanceDecl (ExplicitInstance members) - where - declsInInstance :: TokenParser Declaration - declsInInstance = P.choice - [ parseTypeDeclaration - , parseValueDeclaration - ] P. "type declaration or value declaration in instance" - -parseTypeInstanceChainDeclaration :: TokenParser [Declaration] -parseTypeInstanceChainDeclaration = do - instances <- P.sepBy1 parseTypeInstanceDeclaration (reserved "else") - ensureSameTypeClass instances - chainId <- traverse getTypeInstanceName instances - zipWithM (setTypeInstanceChain chainId) instances [0..] - where - getTypeInstanceName :: Declaration -> TokenParser Ident - getTypeInstanceName (TypeInstanceDeclaration _ _ _ name _ _ _ _) = return name - getTypeInstanceName _ = P.unexpected "Found non-instance in chain declaration." - - setTypeInstanceChain :: [Ident] -> Declaration -> Integer -> TokenParser Declaration - setTypeInstanceChain chain (TypeInstanceDeclaration sa _ _ n d c t b) index = return (TypeInstanceDeclaration sa chain index n d c t b) - setTypeInstanceChain _ _ _ = P.unexpected "Found non-instance in chain declaration." - - getTypeInstanceClass :: Declaration -> TokenParser (Qualified (ProperName 'ClassName)) - getTypeInstanceClass (TypeInstanceDeclaration _ _ _ _ _ tc _ _) = return tc - getTypeInstanceClass _ = P.unexpected "Found non-instance in chain declaration." - - ensureSameTypeClass :: [Declaration] -> TokenParser () - ensureSameTypeClass xs = do - classNames <- ordNub <$> traverse getTypeInstanceClass xs - case classNames of - [_] -> return () - _ -> P.unexpected "All instances in a chain must implement the same type class." - -parseDerivingInstanceDeclaration :: TokenParser Declaration -parseDerivingInstanceDeclaration = do - reserved "derive" - ty <- P.option DerivedInstance (reserved "newtype" $> NewtypeInstance) - instanceDecl <- parseInstanceDeclaration - return $ instanceDecl ty - --- | Parse a single declaration. May include a collection of instances in a chain. -parseDeclaration :: TokenParser [Declaration] -parseDeclaration = - P.choice - [ pure <$> parseDataDeclaration - , pure <$> parseTypeDeclaration - , pure <$> parseTypeSynonymDeclaration - , pure <$> parseValueDeclaration - , pure <$> parseExternDeclaration - , pure <$> parseFixityDeclaration - , pure <$> parseTypeClassDeclaration - , parseTypeInstanceChainDeclaration - , pure <$> parseDerivingInstanceDeclaration - ] P. "declaration" - -parseLocalDeclaration :: TokenParser Declaration -parseLocalDeclaration = - P.choice - [ parseTypeDeclaration - , parseLocalValueDeclaration - ] P. "local declaration" - --- | Parse a module declaration and its export declarations -parseModuleDeclaration :: TokenParser (ModuleName, Maybe [DeclarationRef]) -parseModuleDeclaration = do - reserved "module" - indented - name <- moduleName - exports <- P.optionMaybe . parens $ commaSep1 parseDeclarationRef - reserved "where" - pure (name, exports) - --- | Parse a module header and a collection of declarations -parseModule :: TokenParser Module -parseModule = do - comments <- readComments - start <- P.getPosition - (name, exports) <- parseModuleDeclaration - decls <- mark $ do - -- TODO: extract a module header structure here, and provide a - -- parseModuleHeader function. This should allow us to speed up rebuilds - -- by only parsing as far as the module header. See PR #2054. - imports <- P.many (same *> parseImportDeclaration) - decls <- join <$> P.many (same *> parseDeclaration) - return (imports <> decls) - _ <- P.eof - end <- P.getPosition - let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end) - return $ Module ss comments name decls exports - -booleanLiteral :: TokenParser Bool -booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False) - -parseNumericLiteral :: TokenParser (Literal a) -parseNumericLiteral = NumericLiteral <$> number - -parseCharLiteral :: TokenParser (Literal a) -parseCharLiteral = CharLiteral <$> charLiteral - -parseStringLiteral :: TokenParser (Literal a) -parseStringLiteral = StringLiteral <$> stringLiteral - -parseBooleanLiteral :: TokenParser (Literal a) -parseBooleanLiteral = BooleanLiteral <$> booleanLiteral - -parseArrayLiteral :: TokenParser a -> TokenParser (Literal a) -parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p) - -parseObjectLiteral :: TokenParser (PSString, a) -> TokenParser (Literal a) -parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p) - -parseIdentifierAndValue :: TokenParser (PSString, Expr) -parseIdentifierAndValue = - do - (ss, name) <- indented *> withSourceSpan' (,) lname - b <- P.option (Var ss $ Qualified Nothing (Ident name)) rest - return (mkString name, b) - <|> (,) <$> (indented *> stringLiteral) <*> rest - where - rest = indented *> colon *> indented *> parseValue - -parseAbs :: TokenParser Expr -parseAbs = do - symbol' "\\" - args <- P.many1 (indented *> (Abs <$> parseBinderNoParens)) - indented *> rarrow - value <- parseValue - return $ toFunction args value - where - toFunction :: [Expr -> Expr] -> Expr -> Expr - toFunction args value = foldr ($) value args - -parseVar :: TokenParser Expr -parseVar = withSourceSpan' Var $ parseQualified parseIdent - -parseConstructor :: TokenParser Expr -parseConstructor = withSourceSpan' Constructor $ parseQualified dataConstructorName - -parseCase :: TokenParser Expr -parseCase = Case <$> P.between (reserved "case") (indented *> reserved "of") (commaSep1 parseValue) - <*> (indented *> mark (P.many1 (same *> mark parseCaseAlternative))) - -parseCaseAlternative :: TokenParser CaseAlternative -parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder - <*> (indented *> ( - (pure . MkUnguarded) <$> (rarrow *> parseValue) - <|> (P.many1 (GuardedExpr <$> parseGuard - <*> (indented - *> rarrow - *> parseValue) - )))) - P. "case alternative" - -parseIfThenElse :: TokenParser Expr -parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> indented *> parseValue) - <*> (indented *> reserved "then" *> indented *> parseValue) - <*> (indented *> reserved "else" *> indented *> parseValue) - -parseLet :: TokenParser Expr -parseLet = do - reserved "let" - indented - ds <- mark $ P.many1 (same *> parseLocalDeclaration) - indented - reserved "in" - result <- parseValue - return $ Let FromLet ds result - -parseValueAtom :: TokenParser Expr -parseValueAtom = withSourceSpan PositionedValue $ P.choice - [ parseAnonymousArgument - , withSourceSpan' Literal $ parseNumericLiteral - , withSourceSpan' Literal $ parseCharLiteral - , withSourceSpan' Literal $ parseStringLiteral - , withSourceSpan' Literal $ parseBooleanLiteral - , withSourceSpan' Literal $ parseArrayLiteral parseValue - , withSourceSpan' Literal $ parseObjectLiteral parseIdentifierAndValue - , parseAbs - , P.try parseConstructor - , P.try parseVar - , parseCase - , parseIfThenElse - , parseDo - , parseAdo - , parseLet - , P.try $ Parens <$> parens parseValue - , withSourceSpan' Op $ parseQualified (parens parseOperator) - , parseHole - ] - --- | Parse an expression in backticks or an operator -parseInfixExpr :: TokenParser Expr -parseInfixExpr - = P.between tick tick parseValue - <|> withSourceSpan' Op (parseQualified parseOperator) - -parseHole :: TokenParser Expr -parseHole = Hole <$> holeLit - -parsePropertyUpdate :: TokenParser (PSString, PathNode Expr) -parsePropertyUpdate = do - name <- parseLabel - updates <- parseShallowUpdate <|> parseNestedUpdate - return (name, updates) - where - parseShallowUpdate :: TokenParser (PathNode Expr) - parseShallowUpdate = Leaf <$> (indented *> equals *> indented *> parseValue) - - parseNestedUpdate :: TokenParser (PathNode Expr) - parseNestedUpdate = Branch <$> parseUpdaterBodyFields - -parseAccessor :: Expr -> TokenParser Expr -parseAccessor (Constructor _ _) = P.unexpected "constructor" -parseAccessor obj = P.try $ Accessor <$> (indented *> dot *> indented *> parseLabel) <*> pure obj - -parseDo :: TokenParser Expr -parseDo = do - m <- P.try (getQual <$> parseQualified (reserved "do")) <|> (reserved "do" *> pure Nothing) - indented - Do m <$> mark (P.many1 (same *> mark parseDoNotationElement)) - -parseAdo :: TokenParser Expr -parseAdo = do - m <- P.try (getQual <$> parseQualified (reserved "ado")) <|> (reserved "ado" *> pure Nothing) - indented - elements <- mark (P.many (same *> mark parseDoNotationElement)) - yield <- mark (reserved "in" *> parseValue) - pure $ Ado m elements yield - -parseDoNotationLet :: TokenParser DoNotationElement -parseDoNotationLet = DoNotationLet <$> (reserved "let" *> indented *> mark (P.many1 (same *> parseLocalDeclaration))) - -parseDoNotationBind :: TokenParser DoNotationElement -parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* indented <* larrow) <*> parseValue - -parseDoNotationElement :: TokenParser DoNotationElement -parseDoNotationElement = withSourceSpan PositionedDoNotationElement $ P.choice - [ parseDoNotationBind - , parseDoNotationLet - , DoNotationValue <$> parseValue - ] - --- | Expressions including indexers and record updates -indexersAndAccessors :: TokenParser Expr -indexersAndAccessors = buildPostfixParser postfixTable parseValueAtom - where - postfixTable = [ parseAccessor - , P.try . parseUpdaterBody - ] - --- | Parse an expression -parseValue :: TokenParser Expr -parseValue = - P.buildExpressionParser operators - (buildPostfixParser postfixTable indexersAndAccessors) - P. "expression" - where - postfixTable = [ \v -> P.try (flip App <$> (indented *> indexersAndAccessors)) <*> pure v - , \v -> flip (TypedValue True) <$> (indented *> doubleColon *> parsePolyType) <*> pure v - ] - operators = [ [ P.Prefix (indented *> withSourceSpan' (\ss _ -> UnaryMinus ss) (symbol' "-")) - ] - , [ P.Infix (P.try (indented *> parseInfixExpr P. "infix expression") >>= \ident -> - return (BinaryNoParens ident)) P.AssocRight - ] - ] - -parseUpdaterBodyFields :: TokenParser (PathTree Expr) -parseUpdaterBodyFields = do - updates <- indented *> braces (commaSep1 (indented *> parsePropertyUpdate)) - (_, tree) <- foldM insertUpdate (S.empty, []) updates - return (PathTree (AssocList (reverse tree))) - where - insertUpdate (seen, xs) (key, node) - | S.member key seen = P.unexpected ("Duplicate key in record update: " <> show key) - | otherwise = return (S.insert key seen, (key, node) : xs) - -parseUpdaterBody :: Expr -> TokenParser Expr -parseUpdaterBody v = ObjectUpdateNested v <$> parseUpdaterBodyFields - -parseAnonymousArgument :: TokenParser Expr -parseAnonymousArgument = underscore *> pure AnonymousArgument - -parseNumberLiteral :: TokenParser Binder -parseNumberLiteral = withSourceSpanF $ - (\n ss -> LiteralBinder ss (NumericLiteral n)) <$> (sign <*> number) - where - sign :: TokenParser (Either Integer Double -> Either Integer Double) - sign = (symbol' "-" >> return (negate +++ negate)) - <|> (symbol' "+" >> return id) - <|> return id - -parseNullaryConstructorBinder :: TokenParser Binder -parseNullaryConstructorBinder = withSourceSpanF $ - (\name ss -> ConstructorBinder ss name []) - <$> parseQualified dataConstructorName - -parseConstructorBinder :: TokenParser Binder -parseConstructorBinder = withSourceSpanF $ - (\name args ss -> ConstructorBinder ss name args) - <$> parseQualified dataConstructorName - <*> many (indented *> parseBinderNoParens) - -parseObjectBinder:: TokenParser Binder -parseObjectBinder = withSourceSpanF $ - flip LiteralBinder <$> parseObjectLiteral (indented *> parseEntry) - where - parseEntry :: TokenParser (PSString, Binder) - parseEntry = var <|> (,) <$> stringLiteral <*> rest - where - var = withSourceSpanF $ do - name <- lname - b <- P.option (\ss -> VarBinder ss (Ident name)) (const <$> rest) - return $ \ss -> (mkString name, b ss) - rest = indented *> colon *> indented *> parseBinder - -parseArrayBinder :: TokenParser Binder -parseArrayBinder = withSourceSpanF $ - flip LiteralBinder <$> parseArrayLiteral (indented *> parseBinder) - -parseVarOrNamedBinder :: TokenParser Binder -parseVarOrNamedBinder = withSourceSpanF $ do - name <- parseIdent - let parseNamedBinder = (\b ss -> NamedBinder ss name b) <$> (at *> indented *> parseBinderAtom) - parseNamedBinder <|> return (`VarBinder` name) - -parseNullBinder :: TokenParser Binder -parseNullBinder = underscore *> return NullBinder - --- | Parse a binder -parseBinder :: TokenParser Binder -parseBinder = - withSourceSpan - PositionedBinder - ( P.buildExpressionParser operators - . buildPostfixParser postfixTable - $ parseBinderAtom - ) - where - operators = - [ [ P.Infix (P.try (indented *> parseOpBinder P. "binder operator") >>= \op -> - return (BinaryNoParensBinder op)) P.AssocRight - ] - ] - - postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parsePolyType) ] - - parseOpBinder :: TokenParser Binder - parseOpBinder = withSourceSpan' OpBinder $ parseQualified parseOperator - -parseBinderAtom :: TokenParser Binder -parseBinderAtom = withSourceSpan PositionedBinder - (P.choice - [ parseNullBinder - , withSourceSpanF $ flip LiteralBinder <$> parseCharLiteral - , withSourceSpanF $ flip LiteralBinder <$> parseStringLiteral - , withSourceSpanF $ flip LiteralBinder <$> parseBooleanLiteral - , parseNumberLiteral - , parseVarOrNamedBinder - , parseConstructorBinder - , parseObjectBinder - , parseArrayBinder - , ParensInBinder <$> parens parseBinder - ] P. "binder") - --- | Parse a binder as it would appear in a top level declaration -parseBinderNoParens :: TokenParser Binder -parseBinderNoParens = withSourceSpan PositionedBinder - (P.choice - [ parseNullBinder - , withSourceSpanF $ flip LiteralBinder <$> parseCharLiteral - , withSourceSpanF $ flip LiteralBinder <$> parseStringLiteral - , withSourceSpanF $ flip LiteralBinder <$> parseBooleanLiteral - , parseNumberLiteral - , parseVarOrNamedBinder - , parseNullaryConstructorBinder - , parseObjectBinder - , parseArrayBinder - , ParensInBinder <$> parens parseBinder - ] P. "binder") - --- | Parse a guard -parseGuard :: TokenParser [Guard] -parseGuard = - pipe *> indented *> P.sepBy1 (parsePatternGuard <|> parseConditionGuard) comma - where - parsePatternGuard = - PatternGuard <$> P.try (parseBinder <* indented <* larrow) <*> parseValue - parseConditionGuard = - ConditionGuard <$> parseValue diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs deleted file mode 100644 index abdc810957..0000000000 --- a/src/Language/PureScript/Parser/Kinds.hs +++ /dev/null @@ -1,34 +0,0 @@ --- | --- A parser for kinds --- -module Language.PureScript.Parser.Kinds (parseKind) where - -import Prelude.Compat - -import Language.PureScript.Kinds -import Language.PureScript.Parser.Common -import Language.PureScript.Parser.Lexer - -import qualified Text.Parsec as P -import qualified Text.Parsec.Expr as P - -parseNamedKind :: TokenParser SourceKind -parseNamedKind = withSourceAnnF $ do - name <- parseQualified kindName - return $ \ann -> NamedKind ann name - -parseKindAtom :: TokenParser SourceKind -parseKindAtom = - indented *> P.choice - [ parseNamedKind - , parens parseKind - ] - --- | --- Parse a kind --- -parseKind :: TokenParser SourceKind -parseKind = P.buildExpressionParser operators parseKindAtom P. "kind" - where - operators = [ [ P.Prefix (withSourceAnnF $ symbol' "#" >> return Row) ] - , [ P.Infix (withSourceAnnF $ rarrow >> return FunKind) P.AssocRight ] ] diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs deleted file mode 100644 index cc615ff53f..0000000000 --- a/src/Language/PureScript/Parser/Lexer.hs +++ /dev/null @@ -1,610 +0,0 @@ --- | --- The first step in the parsing process - turns source code into a list of lexemes --- -module Language.PureScript.Parser.Lexer - ( PositionedToken(..) - , Token() - , TokenParser() - , lex - , lexLenient - , anyToken - , token - , match - , lparen - , rparen - , parens - , lbrace - , rbrace - , braces - , lsquare - , rsquare - , squares - , indent - , indentAt - , larrow - , rarrow - , lfatArrow - , rfatArrow - , colon - , doubleColon - , equals - , pipe - , tick - , dot - , comma - , semi - , at - , underscore - , holeLit - , semiSep - , semiSep1 - , commaSep - , commaSep1 - , lname - , lname' - , qualifier - , tyname - , kiname - , dconsname - , uname - , uname' - , mname - , reserved - , symbol - , symbol' - , identifier - , charLiteral - , stringLiteral - , number - , natural - , reservedPsNames - , reservedTypeNames - , isSymbolChar - , isUnquotedKey - ) - where - -import Prelude.Compat hiding (lex) - -import Control.Applicative ((<|>)) -import Control.Monad (void, guard) -import Control.Monad.Identity (Identity) -import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum, isAlpha, isLower) -import Data.String (fromString) -import Data.Text (Text) -import qualified Data.Text as T - -import Language.PureScript.Comments -import Language.PureScript.Parser.State -import Language.PureScript.PSString (PSString) - -import qualified Text.Parsec as P -import qualified Text.Parsec.Token as PT - -data Token - = LParen - | RParen - | LBrace - | RBrace - | LSquare - | RSquare - | Indent Int - | LArrow - | RArrow - | LFatArrow - | RFatArrow - | Colon - | DoubleColon - | Equals - | Pipe - | Tick - | Dot - | Comma - | Semi - | At - | Underscore - | LName Text - | UName Text - | Qualifier Text - | Symbol Text - | CharLiteral Char - | StringLiteral PSString - | Number (Either Integer Double) - | HoleLit Text - deriving (Show, Eq, Ord) - -prettyPrintToken :: Token -> Text -prettyPrintToken LParen = "(" -prettyPrintToken RParen = ")" -prettyPrintToken LBrace = "{" -prettyPrintToken RBrace = "}" -prettyPrintToken LSquare = "[" -prettyPrintToken RSquare = "]" -prettyPrintToken LArrow = "<-" -prettyPrintToken RArrow = "->" -prettyPrintToken LFatArrow = "<=" -prettyPrintToken RFatArrow = "=>" -prettyPrintToken Colon = ":" -prettyPrintToken DoubleColon = "::" -prettyPrintToken Equals = "=" -prettyPrintToken Pipe = "|" -prettyPrintToken Tick = "`" -prettyPrintToken Dot = "." -prettyPrintToken Comma = "," -prettyPrintToken Semi = ";" -prettyPrintToken At = "@" -prettyPrintToken Underscore = "_" -prettyPrintToken (Indent n) = "indentation at level " <> T.pack (show n) -prettyPrintToken (LName s) = T.pack (show s) -prettyPrintToken (UName s) = T.pack (show s) -prettyPrintToken (Qualifier _) = "qualifier" -prettyPrintToken (Symbol s) = s -prettyPrintToken (CharLiteral c) = T.pack (show c) -prettyPrintToken (StringLiteral s) = T.pack (show s) -prettyPrintToken (Number n) = T.pack (either show show n) -prettyPrintToken (HoleLit name) = "?" <> name - -data PositionedToken = PositionedToken - { -- | Start position of this token - ptSourcePos :: P.SourcePos - -- | End position of this token (not including whitespace) - , ptEndPos :: P.SourcePos - -- | End position of the previous token - , ptPrevEndPos :: Maybe P.SourcePos - , ptToken :: Token - , ptComments :: [Comment] - } deriving (Eq) - --- Parsec requires this instance for various token-level combinators -instance Show PositionedToken where - show = T.unpack . prettyPrintToken . ptToken - -type Lexer u a = P.Parsec Text u a - -lex :: FilePath -> Text -> Either P.ParseError [PositionedToken] -lex f s = updatePositions <$> P.parse parseTokens f s - -updatePositions :: [PositionedToken] -> [PositionedToken] -updatePositions [] = [] -updatePositions (x:xs) = x : zipWith update (x:xs) xs - where - update PositionedToken { ptEndPos = pos } pt = pt { ptPrevEndPos = Just pos } - -parseTokens :: Lexer u [PositionedToken] -parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof - --- | Lexes the given file, and on encountering a parse error, returns the --- progress made up to that point, instead of returning an error -lexLenient :: FilePath -> Text -> Either P.ParseError [PositionedToken] -lexLenient f s = updatePositions <$> P.parse parseTokensLenient f s - -parseTokensLenient :: Lexer u [PositionedToken] -parseTokensLenient = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment - -whitespace :: Lexer u () -whitespace = P.skipMany (P.satisfy isSpace) - -parseComment :: Lexer u Comment -parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace - where - blockComment :: Lexer u Text - blockComment = P.try $ P.string "{-" *> (T.pack <$> P.manyTill P.anyChar (P.try (P.string "-}"))) - - lineComment :: Lexer u Text - lineComment = P.try $ P.string "--" *> (T.pack <$> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof))) - -parsePositionedToken :: Lexer u PositionedToken -parsePositionedToken = P.try $ do - comments <- P.many parseComment - pos <- P.getPosition - tok <- parseToken - pos' <- P.getPosition - whitespace - return $ PositionedToken pos pos' Nothing tok comments - -parseToken :: Lexer u Token -parseToken = P.choice - [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow - , P.try $ P.string "←" *> P.notFollowedBy symbolChar *> pure LArrow - , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow - , P.try $ P.string "⇐" *> P.notFollowedBy symbolChar *> pure LFatArrow - , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow - , P.try $ P.string "→" *> P.notFollowedBy symbolChar *> pure RArrow - , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow - , P.try $ P.string "⇒" *> P.notFollowedBy symbolChar *> pure RFatArrow - , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon - , P.try $ P.string "∷" *> P.notFollowedBy symbolChar *> pure DoubleColon - , P.try $ P.char '(' *> pure LParen - , P.try $ P.char ')' *> pure RParen - , P.try $ P.char '{' *> pure LBrace - , P.try $ P.char '}' *> pure RBrace - , P.try $ P.char '[' *> pure LSquare - , P.try $ P.char ']' *> pure RSquare - , P.try $ P.char '`' *> pure Tick - , P.try $ P.char ',' *> pure Comma - , P.try $ P.char '=' *> P.notFollowedBy symbolChar *> pure Equals - , P.try $ P.char ':' *> P.notFollowedBy symbolChar *> pure Colon - , P.try $ P.char '|' *> P.notFollowedBy symbolChar *> pure Pipe - , P.try $ P.char '.' *> P.notFollowedBy symbolChar *> pure Dot - , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi - , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At - , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore - , HoleLit <$> P.try (P.char '?' *> (T.pack <$> P.many1 identLetter)) - , LName <$> parseLName - , parseUName >>= \uName -> - guard (validModuleName uName) *> (Qualifier uName <$ P.char '.') - <|> pure (UName uName) - , Symbol <$> parseSymbol - , CharLiteral <$> parseCharLiteral - , StringLiteral <$> parseStringLiteral - , Number <$> parseNumber - ] - - where - parseLName :: Lexer u Text - parseLName = T.cons <$> identStart <*> (T.pack <$> P.many identLetter) - - parseUName :: Lexer u Text - parseUName = T.cons <$> P.upper <*> (T.pack <$> P.many identLetter) - - parseSymbol :: Lexer u Text - parseSymbol = T.pack <$> P.many1 symbolChar - - identStart :: Lexer u Char - identStart = P.lower <|> P.oneOf "_" - - identLetter :: Lexer u Char - identLetter = P.alphaNum <|> P.oneOf "_'" - - symbolChar :: Lexer u Char - symbolChar = P.satisfy isSymbolChar - - parseCharLiteral :: Lexer u Char - parseCharLiteral = P.try $ do { - c <- PT.charLiteral tokenParser; - if fromEnum c > 0xFFFF - then P.unexpected "astral code point in character literal; characters must be valid UTF-16 code units" - else return c - } - - parseStringLiteral :: Lexer u PSString - parseStringLiteral = fromString <$> (blockString <|> PT.stringLiteral tokenParser) - where - delimiter = P.try (P.string "\"\"\"") - blockString = delimiter *> P.manyTill P.anyChar delimiter - - parseNumber :: Lexer u (Either Integer Double) - parseNumber = (consumeLeadingZero *> P.parserZero) <|> - (Right <$> P.try (PT.float tokenParser) <|> - Left <$> P.try (PT.natural tokenParser)) - P. "number" - where - -- lookAhead doesn't consume any input if its parser succeeds - -- if notFollowedBy fails though, the consumed '0' will break the choice chain - consumeLeadingZero = P.lookAhead (P.char '0' *> - (P.notFollowedBy P.digit P. "no leading zero in number literal")) - --- | --- We use Text.Parsec.Token to implement the string and number lexemes --- -langDef :: PT.GenLanguageDef Text u Identity -langDef = PT.LanguageDef - { PT.reservedNames = [] - , PT.reservedOpNames = [] - , PT.commentStart = "" - , PT.commentEnd = "" - , PT.commentLine = "" - , PT.nestedComments = True - , PT.identStart = P.parserFail "Identifiers not supported" - , PT.identLetter = P.parserFail "Identifiers not supported" - , PT.opStart = P.parserFail "Operators not supported" - , PT.opLetter = P.parserFail "Operators not supported" - , PT.caseSensitive = True - } - --- | --- A token parser based on the language definition --- -tokenParser :: PT.GenTokenParser Text u Identity -tokenParser = PT.makeTokenParser langDef - -type TokenParser a = P.Parsec [PositionedToken] ParseState a - -anyToken :: TokenParser PositionedToken -anyToken = P.token (T.unpack . prettyPrintToken . ptToken) ptSourcePos Just - -token :: (Token -> Maybe a) -> TokenParser a -token f = P.token (T.unpack . prettyPrintToken . ptToken) ptSourcePos (f . ptToken) - -match :: Token -> TokenParser () -match tok = token (\tok' -> if tok == tok' then Just () else Nothing) P. T.unpack (prettyPrintToken tok) - -lparen :: TokenParser () -lparen = match LParen - -rparen :: TokenParser () -rparen = match RParen - -parens :: TokenParser a -> TokenParser a -parens = P.between lparen rparen - -lbrace :: TokenParser () -lbrace = match LBrace - -rbrace :: TokenParser () -rbrace = match RBrace - -braces :: TokenParser a -> TokenParser a -braces = P.between lbrace rbrace - -lsquare :: TokenParser () -lsquare = match LSquare - -rsquare :: TokenParser () -rsquare = match RSquare - -squares :: TokenParser a -> TokenParser a -squares = P.between lsquare rsquare - -indent :: TokenParser Int -indent = token go P. "indentation" - where - go (Indent n) = Just n - go _ = Nothing - -indentAt :: P.Column -> TokenParser () -indentAt n = token go P. "indentation at level " ++ show n - where - go (Indent n') | n == n' = Just () - go _ = Nothing - -larrow :: TokenParser () -larrow = match LArrow - -rarrow :: TokenParser () -rarrow = match RArrow - -lfatArrow :: TokenParser () -lfatArrow = match LFatArrow - -rfatArrow :: TokenParser () -rfatArrow = match RFatArrow - -colon :: TokenParser () -colon = match Colon - -doubleColon :: TokenParser () -doubleColon = match DoubleColon - -equals :: TokenParser () -equals = match Equals - -pipe :: TokenParser () -pipe = match Pipe - -tick :: TokenParser () -tick = match Tick - -dot :: TokenParser () -dot = match Dot - -comma :: TokenParser () -comma = match Comma - -semi :: TokenParser () -semi = match Semi - -at :: TokenParser () -at = match At - -underscore :: TokenParser () -underscore = match Underscore - -holeLit :: TokenParser Text -holeLit = token go P. "hole literal" - where - go (HoleLit n) = Just n - go _ = Nothing - --- | --- Parse zero or more values separated by semicolons --- -semiSep :: TokenParser a -> TokenParser [a] -semiSep = flip P.sepBy semi - --- | --- Parse one or more values separated by semicolons --- -semiSep1 :: TokenParser a -> TokenParser [a] -semiSep1 = flip P.sepBy1 semi - --- | --- Parse zero or more values separated by commas --- -commaSep :: TokenParser a -> TokenParser [a] -commaSep = flip P.sepBy comma - --- | --- Parse one or more values separated by commas --- -commaSep1 :: TokenParser a -> TokenParser [a] -commaSep1 = flip P.sepBy1 comma - -lname :: TokenParser Text -lname = token go P. "identifier" - where - go (LName s) = Just s - go _ = Nothing - -lname' :: Text -> TokenParser () -lname' s = token go P. show s - where - go (LName s') | s == s' = Just () - go _ = Nothing - -qualifier :: TokenParser Text -qualifier = token go P. "qualifier" - where - go (Qualifier s) = Just s - go _ = Nothing - -reserved :: Text -> TokenParser () -reserved s = token go P. show s - where - go (LName s') | s == s' = Just () - go (Symbol s') | s == s' = Just () - go _ = Nothing - -uname :: TokenParser Text -uname = token go P. "proper name" - where - go (UName s) | validUName s = Just s - go _ = Nothing - -uname' :: Text -> TokenParser () -uname' s = token go P. "proper name" - where - go (UName s') | s == s' = Just () - go _ = Nothing - -tyname :: TokenParser Text -tyname = token go P. "type name" - where - go (UName s) = Just s - go _ = Nothing - -kiname :: TokenParser Text -kiname = token go P. "kind name" - where - go (UName s) = Just s - go _ = Nothing - -dconsname :: TokenParser Text -dconsname = token go P. "data constructor name" - where - go (UName s) = Just s - go _ = Nothing - -mname :: TokenParser Text -mname = token go P. "module name" - where - go (UName s) | validModuleName s = Just s - go _ = Nothing - -symbol :: TokenParser Text -symbol = token go P. "symbol" - where - go (Symbol s) = Just s - go Colon = Just ":" - go LFatArrow = Just "<=" - go At = Just "@" - go _ = Nothing - -symbol' :: Text -> TokenParser () -symbol' s = token go P. show s - where - go (Symbol s') | s == s' = Just () - go Colon | s == ":" = Just () - go LFatArrow | s == "<=" = Just () - go _ = Nothing - -charLiteral :: TokenParser Char -charLiteral = token go P. "char literal" - where - go (CharLiteral c) = Just c - go _ = Nothing - -stringLiteral :: TokenParser PSString -stringLiteral = token go P. "string literal" - where - go (StringLiteral s) = Just s - go _ = Nothing - -number :: TokenParser (Either Integer Double) -number = token go P. "number" - where - go (Number n) = Just n - go _ = Nothing - -natural :: TokenParser Integer -natural = token go P. "natural" - where - go (Number (Left n)) = Just n - go _ = Nothing - -identifier :: TokenParser Text -identifier = token go P. "identifier" - where - go (LName s) | s `notElem` reservedPsNames = Just s - go _ = Nothing - -validModuleName :: Text -> Bool -validModuleName s = '_' `notElemT` s - -validUName :: Text -> Bool -validUName s = '\'' `notElemT` s - -notElemT :: Char -> Text -> Bool -notElemT c = not . T.any (== c) - --- | --- A list of purescript reserved identifiers --- -reservedPsNames :: [Text] -reservedPsNames = [ "data" - , "newtype" - , "type" - , "foreign" - , "import" - , "infixl" - , "infixr" - , "infix" - , "class" - , "instance" - , "derive" - , "module" - , "case" - , "of" - , "if" - , "then" - , "else" - , "do" - , "ado" - , "let" - , "true" - , "false" - , "in" - , "where" - ] - -reservedTypeNames :: [Text] -reservedTypeNames = [ "forall", "where" ] - --- | --- The characters allowed for use in operators --- -isSymbolChar :: Char -> Bool -isSymbolChar c = (c `elem` (":!#$%&*+./<=>?@\\^|-~" :: [Char])) || (not (isAscii c) && isSymbol c) - - --- | --- The characters allowed in the head of an unquoted record key --- -isUnquotedKeyHeadChar :: Char -> Bool -isUnquotedKeyHeadChar c = (c == '_') || (isAlpha c && isLower c) - --- | --- The characters allowed in the tail of an unquoted record key --- -isUnquotedKeyTailChar :: Char -> Bool -isUnquotedKeyTailChar c = (c `elem` ("_'" :: [Char])) || isAlphaNum c - --- | --- Strings allowed to be left unquoted in a record key --- -isUnquotedKey :: Text -> Bool -isUnquotedKey t = - case T.uncons t of - Nothing -> False - Just (hd, tl) -> isUnquotedKeyHeadChar hd && - T.all isUnquotedKeyTailChar tl diff --git a/src/Language/PureScript/Parser/State.hs b/src/Language/PureScript/Parser/State.hs deleted file mode 100644 index e72903f16d..0000000000 --- a/src/Language/PureScript/Parser/State.hs +++ /dev/null @@ -1,18 +0,0 @@ --- | --- State for the parser monad --- -module Language.PureScript.Parser.State where - -import Prelude.Compat - -import qualified Text.Parsec as P - --- | --- State for the parser monad --- -data ParseState = ParseState { - -- | - -- The most recently marked indentation level - -- - indentationLevel :: P.Column - } deriving Show diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs deleted file mode 100644 index a83ecdc9c6..0000000000 --- a/src/Language/PureScript/Parser/Types.hs +++ /dev/null @@ -1,189 +0,0 @@ -module Language.PureScript.Parser.Types - ( kindedIdent - , parseType - , parsePolyType - , noForAll - , noWildcards - , parseTypeAtom - ) where - -import Prelude.Compat - -import Control.Monad (when, unless) -import Control.Applicative ((<|>)) -import Data.Functor (($>)) -import qualified Data.Text as T - -import Language.PureScript.AST.SourcePos -import Language.PureScript.Environment -import Language.PureScript.Kinds -import Language.PureScript.Parser.Common -import Language.PureScript.Parser.Kinds -import Language.PureScript.Parser.Lexer -import Language.PureScript.Types -import Language.PureScript.Label (Label(..)) - -import qualified Text.Parsec as P -import qualified Text.Parsec.Expr as P - -parseFunction :: TokenParser SourceType -parseFunction = parens rarrow *> return tyFunction - -parseObject :: TokenParser SourceType -parseObject = withSourceAnnF $ braces $ do - rows <- parseRow - return $ \ann -> TypeApp ann tyRecord rows - -parseTypeLevelString :: TokenParser SourceType -parseTypeLevelString = withSourceAnnF $ flip TypeLevelString <$> stringLiteral - -parseTypeWildcard :: TokenParser SourceType -parseTypeWildcard = withSourceAnnF $ do - name <- Just <$> holeLit - <|> Nothing <$ underscore - return $ flip TypeWildcard name - -parseTypeVariable :: TokenParser SourceType -parseTypeVariable = withSourceAnnF $ do - ident <- identifier - when (ident `elem` reservedTypeNames) $ P.unexpected (T.unpack ident) - return $ \ann -> TypeVar ann ident - -parseTypeConstructor :: TokenParser SourceType -parseTypeConstructor = withSourceAnnF $ flip TypeConstructor <$> parseQualified typeName - -kindedIdent :: TokenParser (T.Text, Maybe SourceKind) -kindedIdent = (, Nothing) <$> identifier - <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind))) - -parseForAll :: TokenParser SourceType -parseForAll = - mkForAll - <$> ((reserved "forall" <|> reserved "∀") - *> (P.many1 $ indented *> (withSourceAnnF $ flip (,) <$> kindedIdent)) - <* indented <* dot) - <*> parseType - --- | --- Parse an atomic type with no `forall` --- -noForAll :: TokenParser SourceType -> TokenParser SourceType -noForAll p = do - ty <- p - when (containsForAll ty) $ P.unexpected "forall" - return ty - --- | --- Parse a type as it appears in e.g. a data constructor --- -parseTypeAtom :: TokenParser SourceType -parseTypeAtom = indented *> P.choice - [ P.try parseFunction - , parseTypeLevelString - , parseObject - , parseTypeWildcard - , parseForAll - , parseTypeVariable - , parseTypeConstructor - -- This try is needed due to some unfortunate ambiguities between rows and kinded types - , P.try (parens parseRow) - , parseParensInType - ] - -parseParensInType :: TokenParser SourceType -parseParensInType = withSourceAnnF $ flip ParensInType <$> parens parsePolyType - -parseConstrainedType :: TokenParser (SourceAnn, [SourceConstraint], SourceType) -parseConstrainedType = withSourceAnnF $ do - constraints <- parens (commaSep1 parseConstraint) <|> pure <$> parseConstraint - _ <- rfatArrow - indented - ty <- parseType - return (, constraints, ty) - where - parseConstraint = withSourceAnnF $ do - className <- parseQualified properName - indented - ty <- P.many parseTypeAtom - return $ \ann -> Constraint ann className ty Nothing - --- This is here to improve the error message when the user --- tries to use the old style constraint contexts. --- TODO: Remove this before 1.0 -typeOrConstrainedType :: TokenParser SourceType -typeOrConstrainedType = do - e <- P.try (Left <$> parseConstrainedType) <|> Right <$> parseTypeAtom - case e of - Left (ann, [c], ty) -> pure (ConstrainedType ann c ty) - Left _ -> - P.unexpected $ - unlines [ "comma in constraints." - , "" - , "Class constraints in type annotations can no longer be grouped in parentheses." - , "Each constraint should now be separated by `=>`, for example:" - , " `(Applicative f, Semigroup a) => a -> f a -> f a`" - , " would now be written as:" - , " `Applicative f => Semigroup a => a -> f a -> f a`." - ] - Right ty -> pure ty - -parseAnyType :: TokenParser SourceType -parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable typeOrConstrainedType) P. "type" - where - operators = [ [ P.Infix (return mkTypeApp) P.AssocLeft ] - , [ P.Infix parseTypeOp P.AssocRight - ] - , [ P.Infix (rarrow $> function) P.AssocRight ] - ] - postfixTable = [ parseKindedType - ] - - mkTypeApp lhs rhs = - TypeApp (widenSourceAnn (getAnnForType lhs) (getAnnForType rhs)) lhs rhs - - parseTypeOp = withSourceAnnF $ do - ident <- P.try (parseQualified parseOperator) - return $ \ann lhs rhs -> - BinaryNoParensType (widenSourceAnn (getAnnForType lhs) (getAnnForType rhs)) (TypeOp ann ident) lhs rhs - - parseKindedType ty = do - kind <- indented *> doubleColon *> parseKind - return $ KindedType (widenSourceAnn (getAnnForType ty) (getAnnForKind kind)) ty kind - - --- | --- Parse a monotype --- -parseType :: TokenParser SourceType -parseType = do - ty <- parseAnyType - unless (isMonoType ty) $ P.unexpected "polymorphic type" - return ty - --- | --- Parse a polytype --- -parsePolyType :: TokenParser SourceType -parsePolyType = parseAnyType - --- | --- Parse an atomic type with no wildcards --- -noWildcards :: TokenParser SourceType -> TokenParser SourceType -noWildcards p = do - ty <- p - when (containsWildcards ty) $ P.unexpected "type wildcard" - return ty - -parseRowListItem :: TokenParser SourceType -> TokenParser (RowListItem SourceAnn) -parseRowListItem p = withSourceAnnF $ - (\name ty ann -> RowListItem ann name ty) - <$> (indented *> (Label <$> parseLabel) <* indented <* doubleColon) <*> p - -parseRowEnding :: TokenParser SourceType -parseRowEnding = - (indented *> pipe *> indented *> parseType) - <|> withSourceAnnF (return REmpty) - -parseRow :: TokenParser SourceType -parseRow = (curry rowFromList <$> commaSep (parseRowListItem parsePolyType) <*> parseRowEnding) P. "row" diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index d284597a3c..87adc6f3a5 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -14,7 +14,7 @@ import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.AST (SourcePos(..), SourceSpan(..)) -import Language.PureScript.Parser.Lexer (isUnquotedKey) +import Language.PureScript.CST.Lexer (isUnquotedKey) import Text.PrettyPrint.Boxes hiding ((<>)) import qualified Text.PrettyPrint.Boxes as Box diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 5c29c86ac8..040ad3665b 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -72,9 +72,9 @@ spec = do describe "determining the importsection" $ do let moduleSkeleton imports = Right (P.moduleNameFromString "Main", take 1 simpleFile, imports, drop 2 simpleFile) - it "slices a file without imports and adds a newline after the module declaration" $ + it "slices a file without imports" $ shouldBe (sliceImportSection noImportsFile) - (Right (P.moduleNameFromString "Main", take 1 noImportsFile ++ [""], [], drop 1 noImportsFile)) + (Right (P.moduleNameFromString "Main", take 1 noImportsFile, [], drop 1 noImportsFile)) it "handles a file with syntax errors just fine" $ shouldBe (sliceImportSection syntaxErrorFile) @@ -351,7 +351,12 @@ addExplicitImportFiltered i ms = importShouldBe :: [Text] -> [Text] -> Expectation importShouldBe res importSection = - res `shouldBe` [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId x = x"] + res `shouldBe` + [ "module ImportsSpec where" ] + ++ (if null importSection then [] else "" : importSection) + ++ [ "" + , "myId x = x" + ] runIdeLoaded :: Command -> IO (Either IdeError Success) runIdeLoaded c = do From b7b47b236e9892675c2e7854630f1ae5e219479c Mon Sep 17 00:00:00 2001 From: Hardy Jones Date: Sun, 26 May 2019 16:30:17 -0700 Subject: [PATCH 1116/1580] Disallow re-exporting class and type with the same name (#3648) * Add failing test for conflicting re-exports (#3502) Within a module, we cannot define a class and a data type with the same name. The issue here is that we can define a class and a data type with the same name in different modules, then re-export them both from one module. We don't want to allow this behavior. We add a failing test to codify that this should not work. * Disallow re-exporting same class/type name (#3502) As mentioned in the previous commit (09bfea484ff6e0d77c028f11314763c794df8c47), we don't want to allow re-exporting a class and a type that have the same name. The changes here make that a reality. The majority of the tests are breaking because we're dependent on `purescript-typelevel-prelude` and it violates the changes here. See: https://github.com/purescript/purescript-typelevel-prelude/issues/43 for more information. * Print the type of the conflicting name (#3502) Before, we only had conflicting exports for the same types of things. Now that we disallow exports of different types, we'll want to be a bit more explict in what the problem is. Errors we'd get before looked like: ``` Export for type B.X conflicts with A.X ``` While that does convey what the problem is, we can do a bit better. Errors now look like: ``` Export for type B.X conflicts with type class A.X ``` * Update dependencies (#3502) The changes to `purescript-typelevel-prelude` allow us to pass tests. The transitive dependency on `purescript-prelude` required an update. --- src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/Sugar/Names/Env.hs | 20 ++++++++++++++++++- .../failing/ExportConflictClassAndType.purs | 5 +++++ .../failing/ExportConflictClassAndType/A.purs | 3 +++ .../failing/ExportConflictClassAndType/B.purs | 3 +++ tests/support/bower.json | 4 ++-- 6 files changed, 33 insertions(+), 4 deletions(-) create mode 100644 tests/purs/failing/ExportConflictClassAndType.purs create mode 100644 tests/purs/failing/ExportConflictClassAndType/A.purs create mode 100644 tests/purs/failing/ExportConflictClassAndType/B.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 7157f0db72..08bee197e6 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -562,7 +562,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (DeclConflict new existing) = line $ "Declaration for " <> printName (Qualified Nothing new) <> " conflicts with an existing " <> nameType existing <> " of the same name." renderSimpleErrorMessage (ExportConflict new existing) = - line $ "Export for " <> printName new <> " conflicts with " <> runName existing + line $ "Export for " <> printName new <> " conflicts with " <> printName existing renderSimpleErrorMessage (DuplicateModule mn) = line $ "Module " <> markCode (runModuleName mn) <> " has been defined multiple times" renderSimpleErrorMessage (DuplicateTypeClass pn ss) = diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index bdfa99155d..31a109ba0e 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -318,6 +318,9 @@ exportType ss exportMode exps name dctors src = do throwDeclConflict (DctorName dctor) (TyClassName (coerceProperName dctor)) ReExport -> do let mn = exportSourceDefinedIn src + forM_ (coerceProperName name `M.lookup` exClasses) $ \src' -> + let mn' = exportSourceDefinedIn src' in + throwExportConflict' ss mn mn' (TyName name) (TyClassName (coerceProperName name)) forM_ (name `M.lookup` exTypes) $ \(_, src') -> let mn' = exportSourceDefinedIn src' in when (mn /= mn') $ @@ -458,8 +461,23 @@ throwExportConflict -> Name -> m a throwExportConflict ss new existing name = + throwExportConflict' ss new existing name name + +-- | +-- Raises an error for when there are conflicting names in the exports. Allows +-- different categories of names. E.g. class and type names conflicting. +-- +throwExportConflict' + :: MonadError MultipleErrors m + => SourceSpan + -> ModuleName + -> ModuleName + -> Name + -> Name + -> m a +throwExportConflict' ss new existing newName existingName = throwError . errorMessage' ss $ - ExportConflict (Qualified (Just new) name) (Qualified (Just existing) name) + ExportConflict (Qualified (Just new) newName) (Qualified (Just existing) existingName) -- | -- Gets the exports for a module, or raise an error if the module doesn't exist. diff --git a/tests/purs/failing/ExportConflictClassAndType.purs b/tests/purs/failing/ExportConflictClassAndType.purs new file mode 100644 index 0000000000..fa6e746ade --- /dev/null +++ b/tests/purs/failing/ExportConflictClassAndType.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith ExportConflict +module C (module A, module B) where + +import A as A +import B as B diff --git a/tests/purs/failing/ExportConflictClassAndType/A.purs b/tests/purs/failing/ExportConflictClassAndType/A.purs new file mode 100644 index 0000000000..48354f7b1b --- /dev/null +++ b/tests/purs/failing/ExportConflictClassAndType/A.purs @@ -0,0 +1,3 @@ +module A where + +class X diff --git a/tests/purs/failing/ExportConflictClassAndType/B.purs b/tests/purs/failing/ExportConflictClassAndType/B.purs new file mode 100644 index 0000000000..3a594f220c --- /dev/null +++ b/tests/purs/failing/ExportConflictClassAndType/B.purs @@ -0,0 +1,3 @@ +module B where + +data X diff --git a/tests/support/bower.json b/tests/support/bower.json index 4d66df9c82..49a7349137 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -24,7 +24,7 @@ "purescript-newtype": "3.0.0", "purescript-nonempty": "5.0.0", "purescript-partial": "2.0.0", - "purescript-prelude": "4.0.0", + "purescript-prelude": "4.1.0", "purescript-proxy": "3.0.0", "purescript-psci-support": "4.0.0", "purescript-refs": "4.1.0", @@ -33,7 +33,7 @@ "purescript-tailrec": "4.0.0", "purescript-tuples": "5.0.0", "purescript-type-equality": "3.0.0", - "purescript-typelevel-prelude": "3.0.0", + "purescript-typelevel-prelude": "4.0.1", "purescript-unfoldable": "4.0.0", "purescript-unsafe-coerce": "4.0.0" } From 6fdcf8a79cd36a93955cfe0016a26736bdf3910e Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 29 May 2019 23:53:55 +0100 Subject: [PATCH 1117/1580] Use externs files when producing docs (#3645) Resolves #3503, fixes #3624. This commit does a few related things: **Docs codegen target** Adds a `docs` codegen target for `purs compile`. When supplied, a `docs.json` file is written for each module alongside the other files in that module's directory within the output directory. The file contains a JSON-serialized Docs.Types.Module, which is the same as the one which will be produced by `purs publish` for that module, except that the re-exports field will be empty; this is because computing re-exports requires access to documentation for all of the upstream modules, and we don't have an easy way of getting hold of all of these (which won't adversely affect memory consumption / performance for the regular compilation path). Since we are producing docs during `purs compile`, we now have easy access to the relevant externs files, which we can use to fill in type signatures of any declarations which don't already have their own. This means that no module within the `Language.PureScript.Docs` namespace needs to call into the type checker any more in order to get accurate and useful type signatures in docs, regardless of whether annotations have been given or not, which both speeds up docs generation significantly and eradicates the possibility of bugs like #3624 arising. **Use docs.json files in purs docs and purs publish** The subcommands `purs docs` and `purs publish` now each accept a `--compile-output` option, which should point to a compiler output directory, with default value `"output"`. With this information, we can reach into the compiler output directory to grab the information in each of the required `docs.json` files, perform one final pass over them to fill in re-exports, and then produce documentation in whatever format is requested. If the `docs.json` files are not up-to-date with respect to the source files which have been provided to `purs docs`, we produce them (just as if we had run `purs compile --codegen docs`). In effect, `purs docs` and `purs publish` now behave a little more like `purs bundle` does, in the sense of getting their input data from the output of `purs compile`, rather than from a collection of source files. **Refactor Docs library API** The Docs library API has been refactored and simplified; now, the `purs docs` CLI and the `Language.PureScript.Publish` module only really need to use one function for getting hold of docs: the function `collectDocs` from the module `Language.PureScript.Docs.Collect`. This function implements the behaviour described above for reading `docs.json` files, making sure they are up-to-date, and filling in re-exports. With this new `collectDocs` function, a number of other functions no longer need to be exposed as part of the compiler library API. In particular, the module `Language.PureScript.Docs.ParseInPackage` has been removed entirely. --- app/Command/Docs.hs | 18 +- app/Command/Publish.hs | 65 +++-- src/Language/PureScript/Docs.hs | 8 +- src/Language/PureScript/Docs/AsMarkdown.hs | 16 +- src/Language/PureScript/Docs/Collect.hs | 233 ++++++++++++++++++ src/Language/PureScript/Docs/Convert.hs | 214 +++------------- .../PureScript/Docs/Convert/ReExports.hs | 97 ++++++-- .../PureScript/Docs/Convert/Single.hs | 7 +- .../PureScript/Docs/ParseInPackage.hs | 75 ------ src/Language/PureScript/Docs/Prim.hs | 5 +- src/Language/PureScript/Docs/Render.hs | 6 +- src/Language/PureScript/Docs/Types.hs | 10 +- src/Language/PureScript/Externs.hs | 11 + src/Language/PureScript/Make.hs | 18 +- src/Language/PureScript/Make/Actions.hs | 11 +- src/Language/PureScript/Make/BuildPlan.hs | 10 - src/Language/PureScript/ModuleDependencies.hs | 7 +- src/Language/PureScript/Options.hs | 3 +- src/Language/PureScript/Publish.hs | 57 +++-- tests/TestDocs.hs | 44 ++-- tests/TestPscPublish.hs | 41 ++- .../purescript-newtype/src/Data/Newtype.purs | 5 + tests/purs/docs/resolutions.json | 23 +- tests/purs/docs/src/TypeSynonym.purs | 3 + tests/purs/docs/src/TypeSynonymInstance.purs | 11 + 25 files changed, 564 insertions(+), 434 deletions(-) create mode 100644 src/Language/PureScript/Docs/Collect.hs delete mode 100644 src/Language/PureScript/Docs/ParseInPackage.hs create mode 100644 tests/purs/docs/bower_components/purescript-newtype/src/Data/Newtype.purs create mode 100644 tests/purs/docs/src/TypeSynonym.purs create mode 100644 tests/purs/docs/src/TypeSynonymInstance.purs diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index 9d6b498d36..f6bf57c9b3 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -31,12 +31,13 @@ data Format data PSCDocsOptions = PSCDocsOptions { _pscdFormat :: Format , _pscdOutput :: Maybe FilePath + , _pscdCompileOutputDir :: FilePath , _pscdInputFiles :: [FilePath] } deriving (Show) docgen :: PSCDocsOptions -> IO () -docgen (PSCDocsOptions fmt moutput inputGlob) = do +docgen (PSCDocsOptions fmt moutput compileOutput inputGlob) = do input <- concat <$> mapM glob inputGlob when (null input) $ do hPutStrLn stderr "purs docs: no input files." @@ -75,8 +76,7 @@ docgen (PSCDocsOptions fmt moutput inputGlob) = do exitFailure parseAndConvert input = - runExceptT (D.parseFilesInPackages input [] - >>= uncurry D.convertTaggedModulesInPackage) + runExceptT (fmap fst (D.collectDocs compileOutput input [])) >>= successOrExit writeTagsToFile :: String -> [String] -> IO () @@ -102,7 +102,7 @@ defaultOutputForFormat fmt = Ctags -> "tags" pscDocsOptions :: Opts.Parser PSCDocsOptions -pscDocsOptions = PSCDocsOptions <$> format <*> output <*> many inputFile +pscDocsOptions = PSCDocsOptions <$> format <*> output <*> compileOutputDir <*> many inputFile where format :: Opts.Parser Format format = Opts.option Opts.auto $ @@ -112,12 +112,20 @@ pscDocsOptions = PSCDocsOptions <$> format <*> output <*> many inputFile <> Opts.help "Set output FORMAT (markdown | html | etags | ctags)" output :: Opts.Parser (Maybe FilePath) - output = optional $ Opts.option Opts.auto $ + output = optional $ Opts.strOption $ Opts.long "output" <> Opts.short 'o' <> Opts.metavar "DEST" <> Opts.help "File/directory path for docs to be written to" + compileOutputDir :: Opts.Parser FilePath + compileOutputDir = Opts.strOption $ + Opts.value "output" + <> Opts.showDefault + <> Opts.long "compile-output" + <> Opts.metavar "DIR" + <> Opts.help "Compiler output directory" + inputFile :: Opts.Parser FilePath inputFile = Opts.strArgument $ Opts.metavar "FILE" diff --git a/app/Command/Publish.hs b/app/Command/Publish.hs index bffb3e838a..43a9f6ae43 100644 --- a/app/Command/Publish.hs +++ b/app/Command/Publish.hs @@ -12,6 +12,13 @@ import Language.PureScript.Publish.ErrorsWarnings import Options.Applicative (Parser) import qualified Options.Applicative as Opts +data PublishOptionsCLI = PublishOptionsCLI + { cliManifestPath :: FilePath + , cliResolutionsPath :: FilePath + , cliCompileOutputDir :: FilePath + , cliDryRun :: Bool + } + manifestPath :: Parser FilePath manifestPath = Opts.strOption $ Opts.long "manifest" @@ -29,23 +36,45 @@ dryRun = Opts.switch $ Opts.long "dry-run" <> Opts.help "Produce no output, and don't require a tagged version to be checked out." -dryRunOptions :: PublishOptions -dryRunOptions = defaultPublishOptions - { publishGetVersion = return dummyVersion - , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn - , publishGetTagTime = const (liftIO getCurrentTime) - } - where dummyVersion = ("0.0.0", Version [0,0,0] []) +compileOutputDir :: Opts.Parser FilePath +compileOutputDir = Opts.option Opts.auto $ + Opts.value "output" + <> Opts.showDefault + <> Opts.long "compile-output" + <> Opts.metavar "DIR" + <> Opts.help "Compiler output directory" + +cliOptions :: Opts.Parser PublishOptionsCLI +cliOptions = + PublishOptionsCLI <$> manifestPath <*> resolutionsPath <*> compileOutputDir <*> dryRun + +mkPublishOptions :: PublishOptionsCLI -> PublishOptions +mkPublishOptions cliOpts = + let + opts = + defaultPublishOptions + { publishManifestFile = cliManifestPath cliOpts + , publishResolutionsFile = cliResolutionsPath cliOpts + , publishCompileOutputDir = cliCompileOutputDir cliOpts + } + in + if cliDryRun cliOpts + then + opts + { publishGetVersion = return ("0.0.0", Version [0,0,0] []) + , publishGetTagTime = const (liftIO getCurrentTime) + , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn + } + else + opts command :: Opts.Parser (IO ()) -command = publish <$> manifestPath <*> resolutionsPath <*> (Opts.helper <*> dryRun) - -publish :: FilePath -> FilePath -> Bool -> IO () -publish manifestFile resolutionsFile isDryRun = - if isDryRun - then do - _ <- unsafePreparePackage manifestFile resolutionsFile dryRunOptions - putStrLn "Dry run completed, no errors." - else do - pkg <- unsafePreparePackage manifestFile resolutionsFile defaultPublishOptions - BL.putStrLn (A.encode pkg) +command = publish <$> (Opts.helper <*> cliOptions) + +publish :: PublishOptionsCLI -> IO () +publish cliOpts = do + let opts = mkPublishOptions cliOpts + pkg <- unsafePreparePackage opts + if cliDryRun cliOpts + then putStrLn "Dry run completed, no errors." + else BL.putStrLn (A.encode pkg) diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs index 16673c053e..417c98f3d3 100644 --- a/src/Language/PureScript/Docs.hs +++ b/src/Language/PureScript/Docs.hs @@ -2,13 +2,13 @@ -- | Data types and functions for rendering generated documentation from -- PureScript code, in a variety of formats. -module Language.PureScript.Docs ( - module Docs -) where +module Language.PureScript.Docs + ( module Docs + ) where +import Language.PureScript.Docs.Collect as Docs import Language.PureScript.Docs.Convert as Docs import Language.PureScript.Docs.Prim as Docs -import Language.PureScript.Docs.ParseInPackage as Docs import Language.PureScript.Docs.Render as Docs import Language.PureScript.Docs.RenderedCode as Docs import Language.PureScript.Docs.Tags as Docs diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 36b2e5bb59..1177de0026 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -1,6 +1,5 @@ module Language.PureScript.Docs.AsMarkdown - ( renderModulesAsMarkdown - , Docs + ( Docs , runDocs , modulesAsMarkdown , moduleAsMarkdown @@ -10,7 +9,6 @@ module Language.PureScript.Docs.AsMarkdown import Prelude.Compat import Control.Monad (unless, zipWithM_) -import Control.Monad.Error.Class (MonadError) import Control.Monad.Writer (Writer, tell, execWriter) import Data.Foldable (for_) @@ -21,20 +19,8 @@ import qualified Data.Text as T import Language.PureScript.Docs.RenderedCode import Language.PureScript.Docs.Types import qualified Language.PureScript as P -import qualified Language.PureScript.Docs.Convert as Convert import qualified Language.PureScript.Docs.Render as Render --- | --- Take a list of modules and render them all in order, returning a single --- Markdown-formatted Text. --- -renderModulesAsMarkdown :: - (MonadError P.MultipleErrors m) => - [P.Module] -> - m Text -renderModulesAsMarkdown = - fmap (runDocs . modulesAsMarkdown) . Convert.convertModules Local - modulesAsMarkdown :: [Module] -> Docs modulesAsMarkdown = mapM_ moduleAsMarkdown diff --git a/src/Language/PureScript/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs new file mode 100644 index 0000000000..d7dd7f7485 --- /dev/null +++ b/src/Language/PureScript/Docs/Collect.hs @@ -0,0 +1,233 @@ + +module Language.PureScript.Docs.Collect + ( collectDocs + ) where + +import Protolude hiding (check) + +import Control.Arrow ((&&&)) +import qualified Data.Aeson.BetterErrors as ABE +import qualified Data.ByteString as BS +import qualified Data.Map as Map +import Data.String (String) +import qualified Data.Set as Set +import qualified Data.Text as T +import System.FilePath (()) +import System.IO.UTF8 (readUTF8FileT) + +import Language.PureScript.Docs.Convert.ReExports (updateReExports) +import Language.PureScript.Docs.Prim (primModules) +import Language.PureScript.Docs.Types + +import qualified Language.PureScript.AST as P +import qualified Language.PureScript.CST as P +import qualified Language.PureScript.Crash as P +import qualified Language.PureScript.Errors as P +import qualified Language.PureScript.Externs as P +import qualified Language.PureScript.Make as P +import qualified Language.PureScript.Names as P +import qualified Language.PureScript.Options as P + +import Web.Bower.PackageMeta (PackageName) + +-- | +-- Given a compiler output directory, a list of input PureScript source files, +-- and a list of dependency PureScript source files, produce documentation for +-- the input files in the intermediate documentation format. Note that +-- dependency files are not included in the result. +-- +-- If the output directory is not up to date with respect to the provided input +-- and dependency files, the files will be built as if with just the "docs" +-- codegen target, i.e. "purs compile --codegen docs". +-- +collectDocs :: + forall m. + (MonadError P.MultipleErrors m, MonadIO m) => + FilePath -> + [FilePath] -> + [(PackageName, FilePath)] -> + m ([(FilePath, Module)], Map P.ModuleName PackageName) +collectDocs outputDir inputFiles depsFiles = do + (modulePaths, modulesDeps) <- getModulePackageInfo inputFiles depsFiles + externs <- compileForDocs outputDir (map fst modulePaths) + + let (withPackage, shouldKeep) = + packageDiscriminators modulesDeps + let go = + operateAndRetag identity modName $ \mns -> do + docsModules <- traverse (liftIO . parseDocsJsonFile outputDir) mns + addReExports withPackage docsModules externs + + docsModules <- go modulePaths + pure ((filter (shouldKeep . modName . snd) docsModules), modulesDeps) + + where + packageDiscriminators modulesDeps = + let + shouldKeep mn = isLocal mn && not (P.isBuiltinModuleName mn) + + withPackage :: P.ModuleName -> InPackage P.ModuleName + withPackage mn = + case Map.lookup mn modulesDeps of + Just pkgName -> FromDep pkgName mn + Nothing -> Local mn + + isLocal :: P.ModuleName -> Bool + isLocal = not . flip Map.member modulesDeps + in + (withPackage, shouldKeep) + +-- | +-- Compile with just the 'docs' codegen target, writing results into the given +-- output directory. +-- +compileForDocs :: + forall m. + (MonadError P.MultipleErrors m, MonadIO m) => + FilePath -> + [FilePath] -> + m [P.ExternsFile] +compileForDocs outputDir inputFiles = do + result <- liftIO $ do + moduleFiles <- readInput inputFiles + fmap fst $ P.runMake testOptions $ do + ms <- P.parseModulesFromFiles identity moduleFiles + let filePathMap = Map.fromList $ map (\(fp, pm) -> (P.getModuleName $ P.resPartial pm, Right fp)) ms + foreigns <- P.inferForeignModules filePathMap + let makeActions = + (P.buildMakeActions outputDir filePathMap foreigns False) + { P.progress = liftIO . putStrLn . renderProgressMessage + } + P.make makeActions (map snd ms) + either throwError return result + + where + renderProgressMessage :: P.ProgressMessage -> String + renderProgressMessage (P.CompilingModule mn) = + "Compiling documentation for " ++ T.unpack (P.runModuleName mn) + + readInput :: [FilePath] -> IO [(FilePath, Text)] + readInput files = + forM files $ \inFile -> (inFile, ) <$> readUTF8FileT inFile + + testOptions :: P.Options + testOptions = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.Docs } + +parseDocsJsonFile :: FilePath -> P.ModuleName -> IO Module +parseDocsJsonFile outputDir mn = + let + filePath = outputDir T.unpack (P.runModuleName mn) "docs.json" + in do + str <- BS.readFile filePath + case ABE.parseStrict asModule str of + Right m -> pure m + Left err -> P.internalError $ + "Failed to decode: " ++ filePath ++ + intercalate "\n" (map T.unpack (ABE.displayError displayPackageError err)) + +addReExports :: + (MonadError P.MultipleErrors m) => + (P.ModuleName -> InPackage P.ModuleName) -> + [Module] -> + [P.ExternsFile] -> + m [Module] +addReExports withPackage docsModules externs = do + -- We add the Prim docs modules here, so that docs generation is still + -- possible if the modules we are generating docs for re-export things from + -- Prim submodules. Note that the Prim modules do not exist as + -- @Language.PureScript.Module@ values because they do not contain anything + -- that exists at runtime. However, we have pre-constructed + -- @Language.PureScript.Docs.Types.Module@ values for them, which we use + -- here. + let moduleMap = + Map.fromList + (map (modName &&& identity) + (docsModules ++ primModules)) + + let withReExports = updateReExports externs withPackage moduleMap + pure (Map.elems withReExports) + +-- | +-- Perform an operation on a list of things which are tagged, and reassociate +-- the things with their tags afterwards. +-- +operateAndRetag :: + forall m a b key tag. + Monad m => + Ord key => + Show key => + (a -> key) -> + (b -> key) -> + ([a] -> m [b]) -> + [(tag, a)] -> + m [(tag, b)] +operateAndRetag keyA keyB operation input = + fmap (map retag) $ operation (map snd input) + where + tags :: Map key tag + tags = Map.fromList $ map (\(tag, a) -> (keyA a, tag)) input + + findTag :: key -> tag + findTag key = + case Map.lookup key tags of + Just tag -> tag + Nothing -> P.internalError ("Missing tag for: " ++ show key) + + retag :: b -> (tag, b) + retag b = (findTag (keyB b), b) + +-- | +-- Given: +-- +-- * A list of local source files +-- * A list of source files from external dependencies, together with their +-- package names +-- +-- This function does the following: +-- +-- * Partially parse all of the input and dependency source files to get +-- the module name of each module +-- * Associate each dependency module with its package name, thereby +-- distinguishing these from local modules +-- * Return the file paths paired with the names of the modules they +-- contain, and a Map of module names to package names for modules which +-- come from dependencies. If a module does not exist in the map, it can +-- safely be +-- assumed to be local. +getModulePackageInfo :: + (MonadError P.MultipleErrors m, MonadIO m) => + [FilePath] + -> [(PackageName, FilePath)] + -> m ([(FilePath, P.ModuleName)], Map P.ModuleName PackageName) +getModulePackageInfo inputFiles depsFiles = do + inputFiles' <- traverse (readFileAs . Local) inputFiles + depsFiles' <- traverse (readFileAs . uncurry FromDep) depsFiles + + moduleNames <- getModuleNames (inputFiles' ++ depsFiles') + + let mnMap = + Map.fromList $ + mapMaybe (\(pkgPath, mn) -> (mn,) <$> getPkgName pkgPath) moduleNames + + pure (map (first ignorePackage) moduleNames, mnMap) + + where + getModuleNames :: + (MonadError P.MultipleErrors m) => + [(InPackage FilePath, Text)] + -> m [(InPackage FilePath, P.ModuleName)] + getModuleNames = + fmap (map (second (P.getModuleName . P.resPartial))) + . either throwError return + . P.parseModulesFromFiles ignorePackage + + getPkgName = \case + Local _ -> Nothing + FromDep pkgName _ -> Just pkgName + + readFileAs :: + (MonadIO m) => + InPackage FilePath -> + m (InPackage FilePath, Text) + readFileAs fi = + liftIO . fmap ((fi,)) $ readUTF8FileT (ignorePackage fi) diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 39a37ff5b9..c2f8a7556d 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -2,203 +2,46 @@ -- from Language.PureScript.Docs. module Language.PureScript.Docs.Convert - ( convertModules - , convertModulesWithEnv - , convertTaggedModulesInPackage - , convertModulesInPackage - , convertModulesInPackageWithEnv + ( convertModule ) where import Protolude hiding (check) -import Control.Arrow ((&&&)) import Control.Category ((>>>)) import Control.Monad.Writer.Strict (runWriterT) +import Control.Monad.Supply (evalSupplyT) import Data.Functor (($>)) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Data.String (String) -import qualified Language.PureScript as P -import Language.PureScript.Docs.Convert.ReExports (updateReExports) import Language.PureScript.Docs.Convert.Single (convertSingleModule) -import Language.PureScript.Docs.Prim (primModules) import Language.PureScript.Docs.Types import qualified Language.PureScript.CST as CST - -import Web.Bower.PackageMeta (PackageName) +import qualified Language.PureScript.AST as P +import qualified Language.PureScript.Crash as P +import qualified Language.PureScript.Errors as P +import qualified Language.PureScript.Externs as P +import qualified Language.PureScript.Environment as P +import qualified Language.PureScript.Names as P +import qualified Language.PureScript.Sugar as P +import qualified Language.PureScript.Types as P -- | --- Like convertModuleInPackage, but with the modules tagged by their --- file paths. +-- Convert a single module to a Docs.Module, making use of a pre-existing +-- type-checking environment in order to fill in any missing types. Note that +-- re-exports will not be included. -- -convertTaggedModulesInPackage :: - (MonadError P.MultipleErrors m) => - [(FilePath, P.Module)] -> - Map P.ModuleName PackageName -> - m [(FilePath, Module)] -convertTaggedModulesInPackage taggedModules modulesDeps = - traverse pairDocModule =<< convertModulesInPackage modules modulesDeps - where - modules = map snd taggedModules - - moduleNameToFileMap = - Map.fromList $ swap . fmap P.getModuleName <$> taggedModules - - getModuleFile docModule = - case Map.lookup (modName docModule) moduleNameToFileMap of - Just filePath -> pure filePath - Nothing -> throwError . P.errorMessage $ - P.ModuleNotFound $ modName docModule - - pairDocModule docModule = (, docModule) <$> getModuleFile docModule - --- | --- Like convertModules, except that it takes a list of modules, together with --- their dependency status, and discards dependency modules in the resulting --- documentation. --- -convertModulesInPackage :: - (MonadError P.MultipleErrors m) => - [P.Module] -> - Map P.ModuleName PackageName -> - m [Module] -convertModulesInPackage modules modulesDeps = - fmap fst (convertModulesInPackageWithEnv modules modulesDeps) - -convertModulesInPackageWithEnv :: - (MonadError P.MultipleErrors m) => - [P.Module] -> - Map P.ModuleName PackageName -> - m ([Module], P.Env) -convertModulesInPackageWithEnv modules modulesDeps = - go modules - where - go = - convertModulesWithEnv withPackage - >>> fmap (first (filter (shouldKeep . modName))) - - shouldKeep mn = isLocal mn && not (P.isBuiltinModuleName mn) - - withPackage :: P.ModuleName -> InPackage P.ModuleName - withPackage mn = - case Map.lookup mn modulesDeps of - Just pkgName -> FromDep pkgName mn - Nothing -> Local mn - - isLocal :: P.ModuleName -> Bool - isLocal = not . flip Map.member modulesDeps - --- | --- Convert a group of modules to the intermediate format, designed for --- producing documentation from. --- --- Note that the whole module dependency graph must be included in the list; if --- some modules import things from other modules, then those modules must also --- be included. --- --- For value declarations, if explicit type signatures are omitted, or a --- wildcard type is used, then we typecheck the modules and use the inferred --- types. --- -convertModules :: - (MonadError P.MultipleErrors m) => - (P.ModuleName -> InPackage P.ModuleName) -> - [P.Module] -> - m [Module] -convertModules withPackage = - fmap fst . convertModulesWithEnv withPackage - -convertModulesWithEnv :: - (MonadError P.MultipleErrors m) => - (P.ModuleName -> InPackage P.ModuleName) -> - [P.Module] -> - m ([Module], P.Env) -convertModulesWithEnv withPackage = - P.sortModules P.moduleSignature - >>> fmap (fst >>> map P.importPrim) - >=> convertSorted withPackage - --- | --- Convert a sorted list of modules, returning both the list of converted --- modules and the Env produced during desugaring. --- -convertSorted :: - (MonadError P.MultipleErrors m) => - (P.ModuleName -> InPackage P.ModuleName) -> - [P.Module] -> - m ([Module], P.Env) -convertSorted withPackage modules = do - (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules - - modulesWithTypes <- typeCheckIfNecessary modules convertedModules - - -- We add the Prim docs modules here, so that docs generation is still - -- possible if the modules we are generating docs for re-export things from - -- Prim submodules. Note that the Prim modules do not exist as - -- @Language.PureScript.Module@ values because they do not contain anything - -- that exists at runtime. However, we have pre-constructed - -- @Language.PureScript.Docs.Types.Module@ values for them, which we use - -- here. - let moduleMap = - Map.fromList - (map (modName &&& identity) - (modulesWithTypes ++ primModules)) - - -- Set up the traversal order for re-export handling so that Prim modules - -- come first. - let primModuleNames = Map.keys P.primEnv - let traversalOrder = primModuleNames ++ map P.getModuleName modules - let withReExports = updateReExports env traversalOrder withPackage moduleMap - pure (Map.elems withReExports, env) - --- | --- If any exported value declarations have either wildcard type signatures, or --- none at all, then typecheck in order to fill them in with the inferred --- types. --- -typeCheckIfNecessary :: - (MonadError P.MultipleErrors m) => - [P.Module] -> - [Module] -> - m [Module] -typeCheckIfNecessary modules convertedModules = - if any hasWildcards convertedModules - then go - else pure convertedModules - - where - hasWildcards = any (isWild . declInfo) . modDeclarations - isWild (ValueDeclaration P.TypeWildcard{}) = True - isWild _ = False - - go = do - checkEnv <- snd <$> typeCheck modules - pure (map (insertValueTypes checkEnv) convertedModules) - --- | --- Typechecks all the modules together. Also returns the final 'P.Environment', --- which is useful for adding in inferred types where explicit declarations --- were not provided. --- -typeCheck :: - (MonadError P.MultipleErrors m) => - [P.Module] -> - m ([P.Module], P.Environment) -typeCheck = - (P.desugar [] >=> check) - >>> fmap (second P.checkEnv) - >>> P.evalSupplyT 0 - >>> ignoreWarnings - - where - check ms = - runStateT - (traverse P.typeCheckModule ms) - (P.emptyCheckState P.initEnvironment) - - ignoreWarnings = - fmap fst . runWriterT +convertModule :: + MonadError P.MultipleErrors m => + [P.ExternsFile] -> + P.Environment -> + P.Module -> + m Module +convertModule externs checkEnv m = + partiallyDesugar externs [m] >>= \case + [m'] -> pure (insertValueTypes checkEnv (convertSingleModule m')) + _ -> P.internalError "partiallyDesugar did not return a singleton" -- | -- Updates all the types of the ValueDeclarations inside the module based on @@ -244,9 +87,10 @@ runParser p = -- partiallyDesugar :: (MonadError P.MultipleErrors m) => - [P.Module] - -> m (P.Env, [P.Module]) -partiallyDesugar = P.evalSupplyT 0 . desugar' + [P.ExternsFile] -> + [P.Module] -> + m [P.Module] +partiallyDesugar externs = evalSupplyT 0 . desugar' where desugar' = traverse P.desugarDoModule @@ -254,8 +98,8 @@ partiallyDesugar = P.evalSupplyT 0 . desugar' >=> map P.desugarLetPatternModule >>> traverse P.desugarCasesModule >=> traverse P.desugarTypeDeclarationsModule - >=> ignoreWarnings . P.desugarImportsWithEnv [] - >=> traverse (P.rebracketFiltered isInstanceDecl []) + >=> ignoreWarnings . P.desugarImports externs + >=> P.rebracketFiltered isInstanceDecl externs ignoreWarnings = fmap fst . runWriterT diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 1ad897ecd9..9651bfb96c 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -13,38 +13,45 @@ import Control.Monad.Trans.State.Strict (execState) import Data.Either import Data.Map (Map) -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, fromMaybe) import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Docs.Types -import qualified Language.PureScript as P + +import qualified Language.PureScript.AST as P +import qualified Language.PureScript.Crash as P +import qualified Language.PureScript.Errors as P +import qualified Language.PureScript.Externs as P +import qualified Language.PureScript.ModuleDependencies as P +import qualified Language.PureScript.Names as P +import qualified Language.PureScript.Types as P + -- | -- Given: -- --- * The Imports/Exports Env --- * An order to traverse the modules (which must be topological) +-- * A list of externs files +-- * A function for tagging a module with the package it comes from -- * A map of modules, indexed by their names, which are assumed to not -- have their re-exports listed yet -- -- This function adds all the missing re-exports. -- updateReExports :: - P.Env -> - [P.ModuleName] -> + [P.ExternsFile] -> (P.ModuleName -> InPackage P.ModuleName) -> Map P.ModuleName Module -> Map P.ModuleName Module -updateReExports env order withPackage = execState action +updateReExports externs withPackage = execState action where action = - void (traverse go order) + void (traverse go traversalOrder) go mn = do mdl <- lookup' mn - reExports <- getReExports env mn + reExports <- getReExports externsEnv mn let mdl' = mdl { modReExports = map (first withPackage) reExports } modify (Map.insert mn mdl') @@ -56,6 +63,25 @@ updateReExports env order withPackage = execState action Nothing -> internalError ("Module missing: " ++ T.unpack (P.runModuleName mn)) + externsEnv :: Map P.ModuleName P.ExternsFile + externsEnv = Map.fromList $ map (P.efModuleName &&& id) externs + + traversalOrder :: [P.ModuleName] + traversalOrder = + case P.sortModules externsSignature externs of + Right (es, _) -> map P.efModuleName es + Left errs -> internalError $ + "failed to sortModules: " ++ + P.prettyPrintMultipleErrors P.defaultPPEOptions errs + + externsSignature :: P.ExternsFile -> P.ModuleSignature + externsSignature ef = + P.ModuleSignature + { P.sigSourceSpan = P.efSourceSpan ef + , P.sigModuleName = P.efModuleName ef + , P.sigImports = map (\ei -> (P.eiModule ei, P.nullSourceSpan)) (P.efImports ef) + } + -- | -- Collect all of the re-exported declarations for a single module. -- @@ -65,19 +91,20 @@ updateReExports env order withPackage = execState action -- getReExports :: (MonadState (Map P.ModuleName Module) m) => - P.Env -> + Map P.ModuleName P.ExternsFile -> P.ModuleName -> m [(P.ModuleName, [Declaration])] -getReExports env mn = - case Map.lookup mn env of +getReExports externsEnv mn = + case Map.lookup mn externsEnv of Nothing -> internalError ("Module missing: " ++ T.unpack (P.runModuleName mn)) - Just (_, _, exports) -> do - allExports <- runReaderT (collectDeclarations exports) mn - pure (filter notLocal allExports) + Just (P.ExternsFile { P.efExports = refs }) -> do + let reExpRefs = mapMaybe toReExportRef refs + runReaderT (collectDeclarations reExpRefs) mn - where - notLocal = (/= mn) . fst +toReExportRef :: P.DeclarationRef -> Maybe (P.ExportSource, P.DeclarationRef) +toReExportRef (P.ReExportRef _ source ref) = Just (source, ref) +toReExportRef _ = Nothing -- | -- Assemble a list of declarations re-exported from a particular module, based @@ -100,9 +127,9 @@ getReExports env mn = -- collectDeclarations :: forall m. (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) => - P.Exports -> + [(P.ExportSource, P.DeclarationRef)] -> m [(P.ModuleName, [Declaration])] -collectDeclarations exports = do +collectDeclarations reExports = do valsAndMembers <- collect lookupValueDeclaration expVals valOps <- collect lookupValueOpDeclaration expValOps typeClasses <- collect lookupTypeClassDeclaration expTCs @@ -129,13 +156,31 @@ collectDeclarations exports = do decls <- traverse (uncurry (flip lookup')) reExps return $ Map.fromListWith (<>) decls - expVals = P.exportedValues exports - expValOps = P.exportedValueOps exports - expTypes = Map.map snd (P.exportedTypes exports) - expTypeOps = P.exportedTypeOps exports - expCtors = concatMap fst (Map.elems (P.exportedTypes exports)) - expTCs = P.exportedTypeClasses exports - expKinds = P.exportedKinds exports + expVals :: Map P.Ident P.ExportSource + expVals = mkExportMap P.getValueRef + + expValOps :: Map (P.OpName 'P.ValueOpName) P.ExportSource + expValOps = mkExportMap P.getValueOpRef + + expTCs :: Map (P.ProperName 'P.ClassName) P.ExportSource + expTCs = mkExportMap P.getTypeClassRef + + expTypes :: Map (P.ProperName 'P.TypeName) P.ExportSource + expTypes = mkExportMap (fmap fst . P.getTypeRef) + + expTypeOps :: Map (P.OpName 'P.TypeOpName) P.ExportSource + expTypeOps = mkExportMap P.getTypeOpRef + + expKinds :: Map (P.ProperName 'P.KindName) P.ExportSource + expKinds = mkExportMap P.getKindRef + + mkExportMap :: Ord name => (P.DeclarationRef -> Maybe name) -> Map name P.ExportSource + mkExportMap f = + Map.fromList $ + mapMaybe (\(exportSrc, ref) -> (,exportSrc) <$> f ref) reExports + + expCtors :: [P.ProperName 'P.ConstructorName] + expCtors = concatMap (fromMaybe [] . (>>= snd) . P.getTypeRef . snd) reExports lookupValueDeclaration :: (MonadState (Map P.ModuleName Module) m, diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index b4ed0b3b03..1ab7188634 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -11,7 +11,12 @@ import Data.Functor (($>)) import qualified Data.Text as T import Language.PureScript.Docs.Types -import qualified Language.PureScript as P + +import qualified Language.PureScript.AST as P +import qualified Language.PureScript.Comments as P +import qualified Language.PureScript.Crash as P +import qualified Language.PureScript.Names as P +import qualified Language.PureScript.Types as P -- | -- Convert a single Module, but ignore re-exports; any re-exported types or diff --git a/src/Language/PureScript/Docs/ParseInPackage.hs b/src/Language/PureScript/Docs/ParseInPackage.hs deleted file mode 100644 index 86ea0dc745..0000000000 --- a/src/Language/PureScript/Docs/ParseInPackage.hs +++ /dev/null @@ -1,75 +0,0 @@ -module Language.PureScript.Docs.ParseInPackage - ( parseFilesInPackages - ) where - -import Protolude - -import qualified Data.Map as M - -import Language.PureScript.Docs.Types -import qualified Language.PureScript as P -import qualified Language.PureScript.CST as CST -import System.IO.UTF8 (readUTF8FileT) -import Web.Bower.PackageMeta (PackageName) - --- | --- Given: --- --- * A list of local source files --- * A list of source files from external dependencies, together with their --- package names --- --- This function does the following: --- --- * Parse all of the input and dependency source files --- * Associate each dependency module with its package name, thereby --- distinguishing these from local modules --- * Return the paths paired with parsed modules, and a Map of module names --- to package names for modules which come from dependencies. --- If a module does not exist in the map, it can safely be assumed to be --- local. -parseFilesInPackages :: - (MonadError P.MultipleErrors m, MonadIO m) => - [FilePath] - -> [(PackageName, FilePath)] - -> m ([(FilePath, P.Module)], Map P.ModuleName PackageName) -parseFilesInPackages inputFiles depsFiles = do - inputFiles' <- traverse (readFileAs . Local) inputFiles - depsFiles' <- traverse (readFileAs . uncurry FromDep) depsFiles - - modules <- parse (inputFiles' ++ depsFiles') - - let mnMap = M.fromList (mapMaybe (\(inpkg, m) -> (P.getModuleName m,) <$> inPkgToMaybe inpkg) modules) - - pure (map (first fileInfoToString) modules, mnMap) - - where - parse :: - (MonadError P.MultipleErrors m) => - [(FileInfo, Text)] - -> m [(FileInfo, P.Module)] - parse = - throwLeft . CST.parseFromFiles fileInfoToString - - inPkgToMaybe = \case - Local _ -> Nothing - FromDep pkgName _ -> Just pkgName - -throwLeft :: (MonadError l m) => Either l r -> m r -throwLeft = either throwError return - --- | Specifies whether a PureScript source file is considered as: --- --- 1) with the `Local` constructor, a target source file, i.e., we want to see --- its modules in the output --- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do --- not want its modules in the output; it is there to enable desugaring, and --- to ensure that links between modules are constructed correctly. -type FileInfo = InPackage FilePath - -fileInfoToString :: FileInfo -> FilePath -fileInfoToString (Local fn) = fn -fileInfoToString (FromDep _ fn) = fn - -readFileAs :: (MonadIO m) => FileInfo -> m (FileInfo, Text) -readFileAs fi = liftIO . fmap ((fi,)) $ readUTF8FileT (ignorePackage fi) diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 9d1b04df78..6fc925314e 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -13,7 +13,10 @@ import qualified Data.Text as T import qualified Data.Map as Map import qualified Data.Set as Set import Language.PureScript.Docs.Types -import qualified Language.PureScript as P + +import qualified Language.PureScript.Crash as P +import qualified Language.PureScript.Environment as P +import qualified Language.PureScript.Names as P primModules :: [Module] primModules = diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 6e37c202b4..603aadf335 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -18,7 +18,11 @@ import qualified Data.Text as T import Language.PureScript.Docs.RenderedCode import Language.PureScript.Docs.Types import Language.PureScript.Docs.Utils.MonoidExtras -import qualified Language.PureScript as P + +import qualified Language.PureScript.AST as P +import qualified Language.PureScript.Environment as P +import qualified Language.PureScript.Names as P +import qualified Language.PureScript.Types as P renderDeclaration :: Declaration -> RenderedCode renderDeclaration Declaration{..} = diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 16a18d54a8..89c3e39252 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -27,7 +27,13 @@ import qualified Data.Aeson as A import qualified Data.Text as T import qualified Data.Vector as V -import qualified Language.PureScript as P +import qualified Language.PureScript.AST as P +import qualified Language.PureScript.Crash as P +import qualified Language.PureScript.Environment as P +import qualified Language.PureScript.Kinds as P +import qualified Language.PureScript.Names as P +import qualified Language.PureScript.Types as P +import qualified Paths_purescript as Paths import Text.ParserCombinators.ReadP (readP_to_S) @@ -773,7 +779,7 @@ instance A.ToJSON a => A.ToJSON (Package a) where pkgResolvedDependencies , "github" .= pkgGithub , "uploader" .= pkgUploader - , "compilerVersion" .= showVersion P.version + , "compilerVersion" .= showVersion Paths.version ] ++ fmap (\t -> "tagTime" .= formatTime t) (maybeToList pkgTagTime) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 7de92875c2..0953ea2532 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -12,11 +12,15 @@ module Language.PureScript.Externs , ExternsDeclaration(..) , moduleToExternsFile , applyExternsFileToEnvironment + , decodeExterns ) where import Prelude.Compat +import Control.Monad (guard) +import Data.Aeson (decode) import Data.Aeson.TH +import Data.ByteString.Lazy (ByteString) import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.List (foldl', find) import Data.Foldable (fold) @@ -242,3 +246,10 @@ $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsF $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsTypeFixity) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile) + + +decodeExterns :: ByteString -> Maybe ExternsFile +decodeExterns bs = do + externs <- decode bs + guard $ T.unpack (efVersion externs) == showVersion Paths.version + return externs diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index abc2914ef5..f60f565b2e 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -25,9 +25,11 @@ import qualified Data.List.NonEmpty as NEL import Data.Maybe (fromMaybe) import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.Text as T import Language.PureScript.AST import Language.PureScript.Crash import qualified Language.PureScript.CST as CST +import qualified Language.PureScript.Docs.Convert as Docs import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Externs @@ -78,7 +80,21 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do [renamed] = renameInModules [optimized] exts = moduleToExternsFile mod' env' ffiCodegen renamed - evalSupplyT nextVar' . codegen renamed env' . encode $ exts + + -- It may seem more obvious to write `docs <- Docs.convertModule m env' here, + -- but I have not done so for two reasons: + -- 1. This should never fail; any genuine errors in the code should have been + -- caught earlier in this function. Therefore if we do fail here it indicates + -- a bug in the compiler, which should be reported as such. + -- 2. We do not want to perform any extra work generating docs unless the + -- user has asked for docs to be generated. + let docs = case Docs.convertModule externs env' m of + Left errs -> internalError $ + "Failed to produce docs for " ++ T.unpack (runModuleName moduleName) + ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs + Right d -> d + + evalSupplyT nextVar' . codegen renamed docs . encode $ exts return exts -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.json@ file. diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index eb59ba55a6..8b54765eaf 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -41,7 +41,7 @@ import qualified Language.PureScript.CoreFn.ToJSON as CFJ import qualified Language.PureScript.CoreImp.AST as Imp import Language.PureScript.Crash import qualified Language.PureScript.CST as CST -import Language.PureScript.Environment +import qualified Language.PureScript.Docs.Types as Docs import Language.PureScript.Errors import Language.PureScript.Make.Monad import Language.PureScript.Names @@ -94,7 +94,7 @@ data MakeActions m = MakeActions , readExterns :: ModuleName -> m (FilePath, Externs) -- ^ Read the externs file for a module as a string and also return the actual -- path for the file. - , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m () + , codegen :: CF.Module CF.Ann -> Docs.Module -> Externs -> SupplyT m () -- ^ Run the code generator for the module and write any required output files. , ffiCodegen :: CF.Module CF.Ann -> m () -- ^ Check ffi and print it in the output directory. @@ -134,6 +134,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = JS -> outputFilename mn "index.js" JSSourceMap -> outputFilename mn "index.js.map" CoreFn -> outputFilename mn "corefn.json" + Docs -> outputFilename mn "docs.json" getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) getOutputTimestamp mn = do @@ -147,8 +148,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = let path = outputDir T.unpack (runModuleName mn) "externs.json" (path, ) <$> readTextFile path - codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make () - codegen m _ exts = do + codegen :: CF.Module CF.Ann -> Docs.Module -> Externs -> SupplyT Make () + codegen m docs exts = do let mn = CF.moduleName m lift $ writeTextFile (outputFilename mn "externs.json") exts codegenTargets <- lift $ asks optionsCodegenTargets @@ -177,6 +178,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = lift $ do writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef) when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings + when (S.member Docs codegenTargets) $ do + lift $ writeTextFile (outputFilename mn "docs.json") (encode docs) ffiCodegen :: CF.Module CF.Ann -> Make () ffiCodegen m = do diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index d2bb88cdbc..7f728f2c52 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -16,13 +16,10 @@ import Control.Monad hiding (sequence) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) -import Data.Aeson (decode) import Data.Foldable (foldl') import qualified Data.Map as M import Data.Maybe (catMaybes, fromMaybe) -import qualified Data.Text as T import Data.Time.Clock (UTCTime) -import Data.Version (showVersion) import Language.PureScript.AST import Language.PureScript.Crash import qualified Language.PureScript.CST as CST @@ -30,7 +27,6 @@ import Language.PureScript.Errors import Language.PureScript.Externs import Language.PureScript.Make.Actions as Actions import Language.PureScript.Names (ModuleName) -import qualified Paths_purescript as Paths -- | The BuildPlan tracks information about our build progress, and holds all -- prebuilt modules for incremental builds. @@ -157,9 +153,3 @@ construct MakeActions{..} (sorted, graph) = do maximumMaybe :: Ord a => [a] -> Maybe a maximumMaybe [] = Nothing maximumMaybe xs = Just $ maximum xs - -decodeExterns :: Externs -> Maybe ExternsFile -decodeExterns bs = do - externs <- decode bs - guard $ T.unpack (efVersion externs) == showVersion Paths.version - return externs diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 1152de2527..5a5d12f1e7 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -23,7 +23,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])] data ModuleSignature = ModuleSignature { sigSourceSpan :: SourceSpan , sigModuleName :: ModuleName - , sigDecls :: [Declaration] + , sigImports :: [(ModuleName, SourceSpan)] } -- | Sort a collection of modules based on module dependencies. @@ -50,8 +50,7 @@ sortModules toSig ms = do return (fst <$> ms'', moduleGraph) where toGraphNode :: S.Set ModuleName -> (a, ModuleSignature) -> m ((a, ModuleSignature), ModuleName, [ModuleName]) - toGraphNode mns m@(_, ModuleSignature _ mn ds) = do - let deps = ordNub (mapMaybe usedModules ds) + toGraphNode mns m@(_, ModuleSignature _ mn deps) = do void . parU deps $ \(dep, pos) -> when (dep `notElem` C.primModules && S.notMember dep mns) . throwError @@ -80,4 +79,4 @@ toModule (CyclicSCC ms) = $ CycleInModules (map (sigModuleName . snd) ms) moduleSignature :: Module -> ModuleSignature -moduleSignature (Module ss _ mn ds _) = ModuleSignature ss mn ds +moduleSignature (Module ss _ mn ds _) = ModuleSignature ss mn (ordNub (mapMaybe usedModules ds)) diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index 1de91c9e5b..323cdcc504 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -20,7 +20,7 @@ data Options = Options defaultOptions :: Options defaultOptions = Options False False (S.singleton JS) -data CodegenTarget = JS | JSSourceMap | CoreFn +data CodegenTarget = JS | JSSourceMap | CoreFn | Docs deriving (Eq, Ord, Show) codegenTargets :: Map String CodegenTarget @@ -28,4 +28,5 @@ codegenTargets = Map.fromList [ ("js", JS) , ("sourcemaps", JSSourceMap) , ("corefn", CoreFn) + , ("docs", Docs) ] diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index fc149595c8..812e0b4540 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -57,6 +57,15 @@ data PublishOptions = PublishOptions , publishGetTagTime :: Text -> PrepareM UTCTime , -- | What to do when the working tree is dirty publishWorkingTreeDirty :: PrepareM () + , -- | Compiler output directory (which must include up-to-date docs.json + -- files for any modules we are producing docs for). + publishCompileOutputDir :: FilePath + , -- | Path to the manifest file; a JSON file including information about the + -- package, such as name, author, dependency version bounds. + publishManifestFile :: FilePath + , -- | Path to the resolutions file; a JSON file containing all of the + -- package's dependencies, their versions, and their paths on the disk. + publishResolutionsFile :: FilePath } defaultPublishOptions :: PublishOptions @@ -64,20 +73,23 @@ defaultPublishOptions = PublishOptions { publishGetVersion = getVersionFromGitTag , publishGetTagTime = getTagTime , publishWorkingTreeDirty = userError DirtyWorkingTree + , publishCompileOutputDir = "output" + , publishManifestFile = "bower.json" + , publishResolutionsFile = "resolutions.json" } -- | Attempt to retrieve package metadata from the current directory. -- Calls exitFailure if no package metadata could be retrieved. -unsafePreparePackage :: FilePath -> FilePath -> PublishOptions -> IO D.UploadedPackage -unsafePreparePackage manifestFile resolutionsFile opts = +unsafePreparePackage :: PublishOptions -> IO D.UploadedPackage +unsafePreparePackage opts = either (\e -> printError e >> exitFailure) pure - =<< preparePackage manifestFile resolutionsFile opts + =<< preparePackage opts -- | Attempt to retrieve package metadata from the current directory. -- Returns a PackageError on failure -preparePackage :: FilePath -> FilePath -> PublishOptions -> IO (Either PackageError D.UploadedPackage) -preparePackage manifestFile resolutionsFile opts = - runPrepareM (preparePackage' manifestFile resolutionsFile opts) +preparePackage :: PublishOptions -> IO (Either PackageError D.UploadedPackage) +preparePackage opts = + runPrepareM (preparePackage' opts) >>= either (pure . Left) (fmap Right . handleWarnings) where @@ -117,12 +129,12 @@ otherError = throwError . OtherError catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b catchLeft a f = either f pure a -preparePackage' :: FilePath -> FilePath -> PublishOptions -> PrepareM D.UploadedPackage -preparePackage' manifestFile resolutionsFile opts = do - unlessM (liftIO (doesFileExist manifestFile)) (userError PackageManifestNotFound) +preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage +preparePackage' opts = do + unlessM (liftIO (doesFileExist (publishManifestFile opts))) (userError PackageManifestNotFound) checkCleanWorkingTree opts - pkgMeta <- liftIO (Bower.decodeFile manifestFile) + pkgMeta <- liftIO (Bower.decodeFile (publishManifestFile opts)) >>= flip catchLeft (userError . CouldntDecodePackageManifest) checkLicense pkgMeta @@ -130,9 +142,9 @@ preparePackage' manifestFile resolutionsFile opts = do pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag pkgGithub <- getManifestRepositoryInfo pkgMeta - resolvedDeps <- parseResolutionsFile resolutionsFile + resolvedDeps <- parseResolutionsFile (publishResolutionsFile opts) - (pkgModules, pkgModuleMap) <- getModules (map (second fst) resolvedDeps) + (pkgModules, pkgModuleMap) <- getModules opts (map (second fst) resolvedDeps) let declaredDeps = map fst $ Bower.bowerDependencies pkgMeta @@ -146,24 +158,17 @@ preparePackage' manifestFile resolutionsFile opts = do return D.Package{..} getModules - :: [(PackageName, FilePath)] + :: PublishOptions + -> [(PackageName, FilePath)] -> PrepareM ([D.Module], Map P.ModuleName PackageName) -getModules paths = do +getModules opts paths = do (inputFiles, depsFiles) <- liftIO (getInputAndDepsFiles paths) - (modules', moduleMap) <- parseFilesInPackages inputFiles depsFiles - case runExcept (D.convertModulesInPackage (map snd modules') moduleMap) of - Right modules -> return (modules, moduleMap) - Left err -> userError (CompileError err) + (modules, moduleMap) <- + (liftIO (runExceptT (D.collectDocs (publishCompileOutputDir opts) inputFiles depsFiles))) + >>= either (userError . CompileError) return - where - parseFilesInPackages inputFiles depsFiles = do - r <- liftIO . runExceptT $ D.parseFilesInPackages inputFiles depsFiles - case r of - Right r' -> - return r' - Left err -> - userError (CompileError err) + pure (map snd modules, moduleMap) data TreeStatus = Clean | Dirty deriving (Show, Eq, Ord, Enum) diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index aa9e55cf25..07a0c5219c 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -10,8 +10,6 @@ import Prelude () import Prelude.Compat import Control.Arrow (first) -import Control.Monad.IO.Class (liftIO) - import Data.List (findIndex) import Data.Foldable import Safe (headMay) @@ -20,49 +18,36 @@ import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Clock (getCurrentTime) -import Data.Version (Version(..)) -import System.Exit +import qualified Text.PrettyPrint.Boxes as Boxes import qualified Language.PureScript as P import qualified Language.PureScript.Docs as Docs import Language.PureScript.Docs.AsMarkdown (codeToString) -import qualified Language.PureScript.Publish as Publish import qualified Language.PureScript.Publish.ErrorsWarnings as Publish import Web.Bower.PackageMeta (parsePackageName, runPackageName) -import TestUtils +import TestPscPublish (preparePackage) import Test.Tasty import Test.Tasty.Hspec (Spec, it, context, expectationFailure, runIO, testSpec) -publishOpts :: Publish.PublishOptions -publishOpts = Publish.defaultPublishOptions - { Publish.publishGetVersion = return testVersion - , Publish.publishGetTagTime = const (liftIO getCurrentTime) - , Publish.publishWorkingTreeDirty = return () - } - where testVersion = ("v999.0.0", Version [999,0,0] []) - -getPackage :: IO (Either Publish.PackageError (Docs.Package Docs.NotYetKnown)) -getPackage = - pushd "tests/purs/docs" $ - Publish.preparePackage "bower.json" "resolutions.json" publishOpts - main :: IO TestTree main = testSpec "docs" spec spec :: Spec spec = do - pkg@Docs.Package{..} <- runIO $ do - res <- getPackage - case res of - Left e -> - Publish.printErrorToStdout e >> exitFailure - Right p -> - pure p + packageResult <- runIO (preparePackage "tests/purs/docs" "resolutions.json") + + case packageResult of + Left e -> + it "failed to produce docs" $ do + expectationFailure (Boxes.render (Publish.renderError e)) + Right pkg -> + mkSpec pkg +mkSpec :: Docs.Package Docs.NotYetKnown -> Spec +mkSpec pkg@Docs.Package{..} = do let linksCtx = Docs.getLinksContext pkg context "Language.PureScript.Docs" $ do @@ -648,6 +633,11 @@ testCases = [ ValueShouldHaveTypeSignature (n "Ado") "test" (renderedType "Int") ] ) + + , ("TypeSynonymInstance", + [ ShouldBeDocumented (n "TypeSynonymInstance") "MyNT" ["MyNT", "ntMyNT"] + ] + ) ] where diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 64dda760b9..b91e9cdc7b 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -1,11 +1,13 @@ -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} module TestPscPublish where import Prelude +import Control.Exception (tryJust) +import Control.Monad (void, guard) import Control.Monad.IO.Class (liftIO) import Data.ByteString.Lazy (ByteString) import Data.Time.Clock (getCurrentTime) @@ -13,16 +15,18 @@ import qualified Data.Aeson as A import Data.Version import Data.Foldable (forM_) import qualified Text.PrettyPrint.Boxes as Boxes -import System.Directory (listDirectory) +import System.Directory (listDirectory, removeDirectoryRecursive) import System.FilePath (()) +import System.IO.Error (isDoesNotExistError) import Language.PureScript.Docs -import Language.PureScript.Publish -import Language.PureScript.Publish.ErrorsWarnings as Publish +import Language.PureScript.Publish (PublishOptions(..), defaultPublishOptions) +import qualified Language.PureScript.Publish as Publish +import qualified Language.PureScript.Publish.ErrorsWarnings as Publish import Test.Tasty import Test.Tasty.Hspec (Spec, Expectation, runIO, context, it, expectationFailure, testSpec) -import TestUtils +import TestUtils hiding (inferForeignModules, makeActions) main :: IO TestTree main = testSpec "publish" spec @@ -77,9 +81,10 @@ roundTrip pkg = then Pass before else Mismatch before after' -testRunOptions :: PublishOptions -testRunOptions = defaultPublishOptions - { publishGetVersion = return testVersion +testRunOptions :: FilePath -> PublishOptions +testRunOptions resolutionsFile = defaultPublishOptions + { publishResolutionsFile = resolutionsFile + , publishGetVersion = return testVersion , publishGetTagTime = const (liftIO getCurrentTime) , publishWorkingTreeDirty = return () } @@ -88,12 +93,12 @@ testRunOptions = defaultPublishOptions -- | Given a directory which contains a package, produce JSON from it, and then -- | attempt to parse it again, and ensure that it doesn't change. testPackage :: FilePath -> FilePath -> Expectation -testPackage dir resolutionsFile = do - res <- pushd dir (preparePackage "bower.json" resolutionsFile testRunOptions) +testPackage packageDir resolutionsFile = do + res <- preparePackage packageDir resolutionsFile case res of Left err -> expectationFailure $ - "Failed to produce JSON from " ++ dir ++ ":\n" ++ + "Failed to produce JSON from " ++ packageDir ++ ":\n" ++ Boxes.render (Publish.renderError err) Right package -> case roundTrip package of @@ -103,3 +108,17 @@ testPackage dir resolutionsFile = do expectationFailure ("Failed to re-parse: " ++ msg) Mismatch _ _ -> expectationFailure "JSON did not match" + +-- A version of Publish.preparePackage suitable for use in tests. We remove the +-- output directory each time to ensure that we are actually testing the docs +-- code in the working tree as it is now (as opposed to how it was at some +-- point in the past when the tests were previously successfully run). +preparePackage :: FilePath -> FilePath -> IO (Either Publish.PackageError UploadedPackage) +preparePackage packageDir resolutionsFile = + pushd packageDir $ do + removeDirectoryRecursiveIfPresent "output" + Publish.preparePackage (testRunOptions resolutionsFile) + +removeDirectoryRecursiveIfPresent :: FilePath -> IO () +removeDirectoryRecursiveIfPresent = + void . tryJust (guard . isDoesNotExistError) . removeDirectoryRecursive diff --git a/tests/purs/docs/bower_components/purescript-newtype/src/Data/Newtype.purs b/tests/purs/docs/bower_components/purescript-newtype/src/Data/Newtype.purs new file mode 100644 index 0000000000..6c17d64784 --- /dev/null +++ b/tests/purs/docs/bower_components/purescript-newtype/src/Data/Newtype.purs @@ -0,0 +1,5 @@ +module Data.Newtype where + +class Newtype t a | t -> a where + wrap :: a -> t + unwrap :: t -> a diff --git a/tests/purs/docs/resolutions.json b/tests/purs/docs/resolutions.json index c3fced5666..dbfb5eaf21 100644 --- a/tests/purs/docs/resolutions.json +++ b/tests/purs/docs/resolutions.json @@ -1,21 +1,10 @@ { - "canonicalDir": ".", - "pkgMeta": { - "dependencies": { - "purescript-prelude": "./bower_components/purescript-prelude" - } + "purescript-prelude": { + "version": "1.0.0", + "path": "bower_components/purescript-prelude" }, - "dependencies": { - "purescript-prelude": { - "canonicalDir": "bower_components/purescript-prelude", - "pkgMeta": { - "_resolution": { - "type": "version", - "tag": "v2.4.0", - "commit": "21067a4c782f42d08bc877214f85b92ce6769b21" - } - }, - "dependencies": {} - } + "purescript-newtype": { + "version": "1.0.0", + "path": "bower_components/purescript-newtype" } } diff --git a/tests/purs/docs/src/TypeSynonym.purs b/tests/purs/docs/src/TypeSynonym.purs new file mode 100644 index 0000000000..a67fb59a88 --- /dev/null +++ b/tests/purs/docs/src/TypeSynonym.purs @@ -0,0 +1,3 @@ +module TypeSynonym where + +type MyInt = Int diff --git a/tests/purs/docs/src/TypeSynonymInstance.purs b/tests/purs/docs/src/TypeSynonymInstance.purs new file mode 100644 index 0000000000..d832d7eba7 --- /dev/null +++ b/tests/purs/docs/src/TypeSynonymInstance.purs @@ -0,0 +1,11 @@ +-- see #3624 +module TypeSynonymInstance where + +import Data.Newtype (class Newtype) +import TypeSynonym (MyInt) + +newtype MyNT = MyNT MyInt + +derive instance ntMyNT :: Newtype MyNT _ + +foo = 0 From 738aaa2f21097c7f18aa8100b16ae52316addb04 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 30 May 2019 00:48:44 +0100 Subject: [PATCH 1118/1580] Bump version to 0.13.0 (#3651) --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index c1ae0375c6..3d7d0d6df8 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.12.5' +version: '0.13.0' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 9e2caf62df625ccfe4db6c322e327991a3701756 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann Date: Fri, 31 May 2019 08:21:00 +0200 Subject: [PATCH 1119/1580] make git consider *.out files as binary for the golden tests (#3656) --- tests/purs/layout/.gitattributes | 1 + 1 file changed, 1 insertion(+) create mode 100644 tests/purs/layout/.gitattributes diff --git a/tests/purs/layout/.gitattributes b/tests/purs/layout/.gitattributes new file mode 100644 index 0000000000..d0b673f439 --- /dev/null +++ b/tests/purs/layout/.gitattributes @@ -0,0 +1 @@ +*.out -merge -text From b39d6160f94c254931014e9fb37c6138d3cb8f9d Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 1 Jun 2019 16:25:05 +0100 Subject: [PATCH 1120/1580] Tighten base lower bound (#3659) Refs #3654. The PureScript compiler does not build on earlier versions of `base`; see e.g. https://matrix.hackage.haskell.org/#/package/purescript/0.12.5/ghc-8.2.2@1559223206 --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 3d7d0d6df8..ef42227331 100644 --- a/package.yaml +++ b/package.yaml @@ -40,7 +40,7 @@ dependencies: - aeson-better-errors >=0.8 - ansi-terminal >=0.7.1 && <0.9 - array - - base >=4.8 && <4.13 + - base >=4.11 && <4.13 - base-compat >=0.6.0 - blaze-html >=0.8.1 && <0.10 - bower-json >=1.0.0.1 && <1.1 From 34f96652125aafea80ca4316546d2994d12e54e6 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 1 Jun 2019 18:21:31 +0100 Subject: [PATCH 1121/1580] Fixes to allow building with Cabal (#3660) Fixes #3654 by specifying the same version of happy that we are using via the Stack snapshot. Also add .gitignore entries for new-style cabal projects. --- .gitignore | 2 ++ package.yaml | 2 ++ 2 files changed, 4 insertions(+) diff --git a/.gitignore b/.gitignore index 06ddeaa54b..56c18312d4 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,8 @@ dist cabal-dev .cabal-sandbox cabal.sandbox.config +dist-newstyle/ +cabal.project.local* *.o *.hi *.chi diff --git a/package.yaml b/package.yaml index ef42227331..028924e2d6 100644 --- a/package.yaml +++ b/package.yaml @@ -89,6 +89,8 @@ dependencies: - unordered-containers - utf8-string >=1 && <2 - vector +build-tools: + - happy ==1.19.9 library: source-dirs: src From a49b1de62da2c16212c26c3ceba107fbedf4fd16 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 1 Jun 2019 19:30:42 +0100 Subject: [PATCH 1122/1580] Add upper bounds when producing source distributions (#3661) This change means that stack will add upper bounds to our cabal file when producing source distributions (e.g. for uploading to Hackage), which means that we are less likely to run into solving/building difficulties if new versions of our dependencies get released in the meantime. Comparing a `build-depends` section of the purescript.cabal file in a source distribution before and after this change: Before ``` Cabal >=2.2 , Glob >=0.9 && <0.10 , aeson >=1.0 && <1.5 , aeson-better-errors >=0.8 , ansi-terminal >=0.7.1 && <0.9 , array , base >=4.11 && <4.13 , base-compat >=0.6.0 , blaze-html >=0.8.1 && <0.10 , bower-json >=1.0.0.1 && <1.1 , boxes >=0.1.4 && <0.2.0 , bytestring , cheapskate >=0.1 && <0.2 , clock , containers , data-ordlist >=0.4.7.0 , deepseq , directory >=1.2.3 , dlist ``` After ``` Cabal >=2.2 && <2.5, Glob ==0.9.*, aeson >=1.0 && <1.5, aeson-better-errors >=0.8 && <0.10, ansi-terminal >=0.7.1 && <0.9, array <0.6, base >=4.11 && <4.13, base-compat >=0.6.0 && <0.11, blaze-html >=0.8.1 && <0.10, bower-json >=1.0.0.1 && <1.1, boxes >=0.1.4 && <0.2.0, bytestring <0.11, cheapskate ==0.1.*, clock <0.8, containers <0.7, data-ordlist >=0.4.7.0 && <0.5, deepseq <1.5, directory >=1.2.3 && <1.4, dlist <0.9, ``` Note in particular that e.g. `array` (no bounds) becomes `array <0.6`, and `Cabal >=2.2` becomes `Cabal >=2.2 && <2.5`. The `purescript.cabal` file generated by hpack for local development is unchanged. I think this is fine, because if our version bounds turn out to be wrong during local development we can just fix them then and there. --- stack.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/stack.yaml b/stack.yaml index 09abdb9be9..bd7bd40bde 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,5 @@ resolver: lts-13.12 +pvp-bounds: upper packages: - '.' extra-deps: From 24888c7f5d9912ae8b8cfd2fb798d78427444694 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 2 Jun 2019 16:45:13 +0100 Subject: [PATCH 1123/1580] Update test dependency on typelevel-prelude (#3649) --- tests/purs/warning/CustomWarning4.purs | 2 +- tests/support/bower.json | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/purs/warning/CustomWarning4.purs b/tests/purs/warning/CustomWarning4.purs index 5ab9de6c40..c3511ca2ac 100644 --- a/tests/purs/warning/CustomWarning4.purs +++ b/tests/purs/warning/CustomWarning4.purs @@ -6,7 +6,7 @@ module Main where import Prim.TypeError (class Warn, Beside, QuoteLabel, Text) import Prim -import Type.Row (class RowToList, Cons, Nil) +import Type.RowList (class RowToList, Cons, Nil) data Label (l :: Symbol) = Label diff --git a/tests/support/bower.json b/tests/support/bower.json index 49a7349137..56c8cc200e 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -33,7 +33,7 @@ "purescript-tailrec": "4.0.0", "purescript-tuples": "5.0.0", "purescript-type-equality": "3.0.0", - "purescript-typelevel-prelude": "4.0.1", + "purescript-typelevel-prelude": "5.0.0", "purescript-unfoldable": "4.0.0", "purescript-unsafe-coerce": "4.0.0" } From 668cc2e1a22b4e2ef8c6a58dbe00b263da910bd1 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 2 Jun 2019 16:45:39 +0100 Subject: [PATCH 1124/1580] Fix printing of tokens with string escapes (#3665) - Modify generators so that string escapes are more likely to appear - Clarify error message when a roundtrip fails (so that we can distinguish whether parsing failed the first or second time) - Fix a bug where the lexer would include extra slashes in the raw component of string and char tokens --- src/Language/PureScript/CST/Lexer.hs | 8 +++---- tests/TestCst.hs | 35 +++++++++++++++------------- 2 files changed, 23 insertions(+), 20 deletions(-) diff --git a/src/Language/PureScript/CST/Lexer.hs b/src/Language/PureScript/CST/Lexer.hs index b17a586227..91faa20ce3 100644 --- a/src/Language/PureScript/CST/Lexer.hs +++ b/src/Language/PureScript/CST/Lexer.hs @@ -495,9 +495,9 @@ token = peek >>= maybe (pure TokEof) k0 escape = do ch <- peek case ch of - Just 't' -> next $> ("\t", '\t') - Just 'r' -> next $> ("\\r", '\r') - Just 'n' -> next $> ("\\n", '\n') + Just 't' -> next $> ("t", '\t') + Just 'r' -> next $> ("r", '\r') + Just 'n' -> next $> ("n", '\n') Just '"' -> next $> ("\"", '"') Just '\'' -> next $> ("'", '\'') Just '\\' -> next $> ("\\", '\\') @@ -508,7 +508,7 @@ token = peek >>= maybe (pure TokEof) k0 go n acc _ | n <= 0x10FFFF = ksucc (Text.drop (length acc) inp) - (Text.pack $ reverse acc, Char.chr n) + ("x" <> Text.pack (reverse acc), Char.chr n) | otherwise = kerr inp ErrCharEscape -- TODO go 0 [] $ Text.unpack $ Text.take 6 inp diff --git a/tests/TestCst.hs b/tests/TestCst.hs index abaddc07c1..b05bbee630 100644 --- a/tests/TestCst.hs +++ b/tests/TestCst.hs @@ -67,15 +67,18 @@ litTests = testGroup "Literals" , testProperty "Raw String (round trip)" $ roundTripTok . unRawString ] -readTok :: Text -> Gen SourceToken -readTok t = case CST.lex t of +readTok' :: String -> Text -> Gen SourceToken +readTok' failMsg t = case CST.lex t of Right tok : _ -> pure tok Left (_, err) : _ -> - fail $ "Failed to parse: " <> CST.prettyPrintError err + fail $ failMsg <> ": " <> CST.prettyPrintError err [] -> fail "Empty token stream" +readTok :: Text -> Gen SourceToken +readTok = readTok' "Failed to parse" + checkTok :: (Text -> a -> Gen Bool) -> (Token -> Maybe a) @@ -91,7 +94,7 @@ roundTripTok :: Text -> Gen Bool roundTripTok t = do tok <- readTok t let t' = CST.printTokens [tok] - tok' <- readTok t' + tok' <- readTok' "Failed to re-parse" t' pure $ tok == tok' checkReadNum :: (Eq a, Read a) => Text -> a -> Gen Bool @@ -168,23 +171,23 @@ genHex = PSSourceHex <$> do genChar :: Gen PSSourceChar genChar = PSSourceChar <$> do - ch <- (toEnum :: Int -> Char) <$> resize 0xFFFF arbitrarySizedNatural - ch' <- case ch of - '\'' -> discard - '\\' -> genCharEscape - c -> pure $ Text.singleton c - pure $ "'" <> ch' <> "'" + ch <- resize 0xFFFF arbitrarySizedNatural >>= (genStringChar '\'' . toEnum) + pure $ "'" <> ch <> "'" genString :: Gen PSSourceString genString = PSSourceString <$> do - chs <- listOf $ arbitraryUnicodeChar >>= \case - '"' -> discard - '\n' -> discard - '\r' -> discard - '\\' -> genCharEscape - c -> pure $ Text.singleton c + chs <- listOf $ arbitraryUnicodeChar >>= genStringChar '"' pure $ "\"" <> Text.concat chs <> "\"" +genStringChar :: Char -> Char -> Gen Text +genStringChar delimiter ch = frequency + [ (1, genCharEscape) + , (10, if ch `elem` [delimiter, '\n', '\r', '\\'] + then discard + else pure $ Text.singleton ch + ) + ] + genRawString :: Gen PSSourceRawString genRawString = PSSourceRawString <$> do chs <- listOf $ arbitraryUnicodeChar From 7fffaa33e48fd05da62212d6f9ac7dbcd6e3ed1a Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 3 Jun 2019 20:02:11 +0100 Subject: [PATCH 1125/1580] Update author & maintainer sections of cabal file (#3663) - Add @natefaubion, @liamgoodacre - Remove Phil as maintainer (just have him as the author) - Update copyright info --- package.yaml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/package.yaml b/package.yaml index 028924e2d6..548f10b880 100644 --- a/package.yaml +++ b/package.yaml @@ -4,14 +4,15 @@ synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language -author: > - Phil Freeman , +author: Phil Freeman +maintainer: > Gary Burgess , Hardy Jones , Harry Garrood , - Christoph Hegemann -maintainer: Phil Freeman -copyright: (c) 2013-17 Phil Freeman, (c) 2014-17 Gary Burgess + Christoph Hegemann , + Liam Goodacre , + Nathan Faubion +copyright: (c) 2013-17 Phil Freeman, (c) 2014-19 Gary Burgess, (c) other contributors (see CONTRIBUTORS.md) license: BSD3 github: purescript/purescript homepage: http://www.purescript.org/ From e0910da84f58b988b1271b2c8e5e926b342c8925 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Tue, 4 Jun 2019 08:11:56 -0700 Subject: [PATCH 1126/1580] Remove partial type signatures from parameterized productions (#3667) --- src/Language/PureScript/CST/Parser.y | 47 ++++++++++++++++------------ 1 file changed, 27 insertions(+), 20 deletions(-) diff --git a/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y index 2585d15438..d63619ce0b 100644 --- a/src/Language/PureScript/CST/Parser.y +++ b/src/Language/PureScript/CST/Parser.y @@ -138,36 +138,36 @@ import Language.PureScript.PSString (PSString) %% -many(a) :: { NE.NonEmpty _ } +many(a) :: { NE.NonEmpty a } : many1(a) { NE.reverse $1 } -many1(a) :: { NE.NonEmpty _ } +many1(a) :: { NE.NonEmpty a } : a { pure $1 } | many1(a) a { NE.cons $2 $1 } -manySep(a, sep) :: { NE.NonEmpty _ } +manySep(a, sep) :: { NE.NonEmpty a } : manySep1(a, sep) { NE.reverse $1 } -manySep1(a, sep) :: { NE.NonEmpty _ } +manySep1(a, sep) :: { NE.NonEmpty a } : a { pure $1 } | manySep1(a, sep) sep a { NE.cons $3 $1 } -manySepOrEmpty(a, sep) :: { [_] } +manySepOrEmpty(a, sep) :: { [a] } : {- empty -} { [] } | manySep(a, sep) { NE.toList $1 } -manyOrEmpty(a) :: { [_] } +manyOrEmpty(a) :: { [a] } : {- empty -} { [] } | many(a) { NE.toList $1 } -sep(a, s) :: { Separated _ } +sep(a, s) :: { Separated a } : sep1(a, s) { separated $1 } -sep1(a, s) :: { [(SourceToken, _)] } +sep1(a, s) :: { [(SourceToken, a)] } : a { [(placeholder, $1)] } | sep1(a, s) s a { ($2, $3) : $1 } -delim(a, b, c, d) :: { Delimited _ } +delim(a, b, c, d) :: { Delimited b } : a d { Wrapped $1 Nothing $2 } | a sep(b, c) d { Wrapped $1 (Just $2) $3 } @@ -395,7 +395,7 @@ expr5 :: { Expr () } -- case, since this is used in the wild. | 'case' sep(expr, ',') 'of' '\{' sep(binder1, ',') '->' '\}' exprWhere { ExprCase () (CaseOf $1 $2 $3 (pure ($5, Unconditional $6 $8))) } - | 'case' sep(expr, ',') 'of' '\{' sep(binder1, ',') '\}' guarded('->') + | 'case' sep(expr, ',') 'of' '\{' sep(binder1, ',') '\}' guardedCase { ExprCase () (CaseOf $1 $2 $3 (pure ($5, $7))) } expr6 :: { Expr () } @@ -442,19 +442,26 @@ recordUpdate :: { RecordUpdate () } letBinding :: { LetBinding () } : ident '::' type { LetBindingSignature () (Labeled $1 $2 $3) } - | ident guarded('=') { LetBindingName () (ValueBindingFields $1 [] $2) } - | ident many(binderAtom) guarded('=') { LetBindingName () (ValueBindingFields $1 (NE.toList $2) $3) } + | ident guardedDecl { LetBindingName () (ValueBindingFields $1 [] $2) } + | ident many(binderAtom) guardedDecl { LetBindingName () (ValueBindingFields $1 (NE.toList $2) $3) } | binder1 '=' exprWhere { LetBindingPattern () $1 $2 $3 } caseBranch :: { (Separated (Binder ()), Guarded ()) } - : sep(binder1, ',') guarded('->') { ($1, $2) } + : sep(binder1, ',') guardedCase { ($1, $2) } -guarded(a) :: { Guarded () } - : a exprWhere { Unconditional $1 $2 } - | many(guardedExpr(a)) { Guarded $1 } +guardedDecl :: { Guarded () } + : '=' exprWhere { Unconditional $1 $2 } + | many(guardedDeclExpr) { Guarded $1 } -guardedExpr(a) :: { GuardedExpr () } - : guard a exprWhere { uncurry GuardedExpr $1 $2 $3 } +guardedDeclExpr :: { GuardedExpr () } + : guard '=' exprWhere { uncurry GuardedExpr $1 $2 $3 } + +guardedCase :: { Guarded () } + : '->' exprWhere { Unconditional $1 $2 } + | many(guardedCaseExpr) { Guarded $1 } + +guardedCaseExpr :: { GuardedExpr () } + : guard '->' exprWhere { uncurry GuardedExpr $1 $2 $3 } -- Do/Ado statements and pattern guards require unbounded lookahead due to many -- conflicts between `binder` and `expr` syntax. For example `Foo a b c` can @@ -652,7 +659,7 @@ decl :: { Declaration () } | 'derive' instHead { DeclDerive () $1 Nothing $2 } | 'derive' 'newtype' instHead { DeclDerive () $1 (Just $2) $3 } | ident '::' type { DeclSignature () (Labeled $1 $2 $3) } - | ident manyOrEmpty(binderAtom) guarded('=') { DeclValue () (ValueBindingFields $1 $2 $3) } + | ident manyOrEmpty(binderAtom) guardedDecl { DeclValue () (ValueBindingFields $1 $2 $3) } | fixity { DeclFixity () $1 } | 'foreign' 'import' foreign { DeclForeign () $1 $2 $3 } @@ -720,7 +727,7 @@ constraint :: { Constraint () } instBinding :: { InstanceBinding () } : ident '::' type { InstanceBindingSignature () (Labeled $1 $2 $3) } - | ident manyOrEmpty(binderAtom) guarded('=') { InstanceBindingName () (ValueBindingFields $1 $2 $3) } + | ident manyOrEmpty(binderAtom) guardedDecl { InstanceBindingName () (ValueBindingFields $1 $2 $3) } fixity :: { FixityFields } : infix int qualIdent 'as' op { FixityFields $1 $2 (FixityValue (fmap Left $3) $4 $5) } From 135533f2ab5d5658078cce3db50a3c986726985a Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sun, 9 Jun 2019 22:38:15 +0000 Subject: [PATCH 1127/1580] Add --debug flag to bundle command (#3666) * Add --debug flag to bundle command This flag causes an optimized-for-humans JSON representation of the modules being bundled to be dumped to stderr, prior to dead code elimination. This feature was requested in the review of #3562. * Add JS fragments to bundle --debug --- app/Command/Bundle.hs | 22 ++++++++- package.yaml | 1 + src/Language/PureScript/Bundle.hs | 80 ++++++++++++++++++++++++++++++- stack.yaml | 3 ++ tests/TestBundle.hs | 2 +- 5 files changed, 104 insertions(+), 4 deletions(-) diff --git a/app/Command/Bundle.hs b/app/Command/Bundle.hs index 5666a0f915..c030a2b974 100644 --- a/app/Command/Bundle.hs +++ b/app/Command/Bundle.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} @@ -8,7 +9,9 @@ module Command.Bundle (command) where import Data.Traversable (for) import Data.Aeson (encode) +import Data.Aeson.Encode.Pretty (confCompare, defConfig, encodePretty', keyOrder) import Data.Maybe (isNothing) +import Data.Text (Text) import Control.Applicative import Control.Monad import Control.Monad.Error.Class @@ -35,6 +38,7 @@ data Options = Options , optionsMainModule :: Maybe String , optionsNamespace :: String , optionsSourceMaps :: Bool + , optionsDebug :: Bool } deriving Show -- | The main application function. @@ -59,7 +63,17 @@ app Options{..} = do currentDir <- liftIO getCurrentDirectory let outFile = if optionsSourceMaps then fmap (currentDir ) optionsOutputFile else Nothing - bundleSM input entryIds optionsMainModule optionsNamespace outFile + let withRawModules = if optionsDebug then Just bundleDebug else Nothing + bundleSM input entryIds optionsMainModule optionsNamespace outFile withRawModules + +-- | Print a JSON representation of a list of modules to stderr. +bundleDebug :: (MonadIO m) => [Module] -> m () +bundleDebug = liftIO . hPutStrLn stderr . LBU8.toString . encodePretty' (defConfig { confCompare = keyComparer }) + where + -- | Some key order hints for improved readability. + keyComparer :: Text -> Text -> Ordering + keyComparer = keyOrder ["type", "name", "moduleId"] -- keys to put first + <> flip (keyOrder ["dependsOn", "elements"]) -- keys to put last -- | Command line options parser. options :: Parser Options @@ -69,6 +83,7 @@ options = Options <$> some inputFile <*> optional mainModule <*> namespace <*> sourceMaps + <*> debug where inputFile :: Parser FilePath inputFile = Opts.strArgument $ @@ -105,6 +120,11 @@ options = Options <$> some inputFile Opts.long "source-maps" <> Opts.help "Whether to generate source maps for the bundle (requires --output)." + debug :: Parser Bool + debug = Opts.switch $ + Opts.long "debug" + <> Opts.help "Whether to emit a JSON representation of all parsed modules to stderr." + -- | Make it go. command :: Opts.Parser (IO ()) command = run <$> (Opts.helper <*> options) where diff --git a/package.yaml b/package.yaml index 548f10b880..2c66f893e4 100644 --- a/package.yaml +++ b/package.yaml @@ -39,6 +39,7 @@ extra-source-files: dependencies: - aeson >=1.0 && <1.5 - aeson-better-errors >=0.8 + - aeson-pretty - ansi-terminal >=0.7.1 && <0.9 - array - base >=4.11 && <4.13 diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index d92d5662d7..24abfb9191 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -14,6 +14,7 @@ module Language.PureScript.Bundle , ErrorMessage(..) , printErrorMessage , getExportedIdentifiers + , Module ) where import Prelude.Compat @@ -23,6 +24,7 @@ import Control.Monad import Control.Monad.Error.Class import Control.Arrow ((&&&)) +import Data.Aeson ((.=)) import Data.Array ((!)) import Data.Char (chr, digitToInt) import Data.Foldable (fold) @@ -31,11 +33,14 @@ import Data.Graph import Data.List (stripPrefix) import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Version (showVersion) +import qualified Data.Aeson as A import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.Text.Lazy as T import Language.JavaScript.Parser import Language.JavaScript.Parser.AST +import Language.JavaScript.Process.Minify import qualified Paths_purescript as Paths @@ -69,6 +74,12 @@ showModuleType Foreign = "Foreign" -- | A module is identified by its module name and its type. data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord) +instance A.ToJSON ModuleIdentifier where + toJSON (ModuleIdentifier name mt) = + A.object [ "name" .= name + , "type" .= show mt + ] + moduleName :: ModuleIdentifier -> String moduleName (ModuleIdentifier name _) = name @@ -110,9 +121,71 @@ data ModuleElement | Skip JSStatement deriving (Show) +instance A.ToJSON ModuleElement where + toJSON = \case + (Require _ name (Right target)) -> + A.object [ "type" .= A.String "Require" + , "name" .= name + , "target" .= target + ] + (Require _ name (Left targetPath)) -> + A.object [ "type" .= A.String "Require" + , "name" .= name + , "targetPath" .= targetPath + ] + (Member _ public name _ dependsOn) -> + A.object [ "type" .= A.String "Member" + , "name" .= name + , "visibility" .= A.String (if public then "Public" else "Internal") + , "dependsOn" .= map keyToJSON dependsOn + ] + (ExportsList exports) -> + A.object [ "type" .= A.String "ExportsList" + , "exports" .= map exportToJSON exports + ] + (Other stmt) -> + A.object [ "type" .= A.String "Other" + , "js" .= getFragment stmt + ] + (Skip stmt) -> + A.object [ "type" .= A.String "Skip" + , "js" .= getFragment stmt + ] + + where + + keyToJSON (mid, member) = + A.object [ "module" .= mid + , "member" .= member + ] + + exportToJSON (RegularExport sourceName, name, _, dependsOn) = + A.object [ "type" .= A.String "RegularExport" + , "name" .= name + , "sourceName" .= sourceName + , "dependsOn" .= map keyToJSON dependsOn + ] + exportToJSON (ForeignReexport, name, _, dependsOn) = + A.object [ "type" .= A.String "ForeignReexport" + , "name" .= name + , "dependsOn" .= map keyToJSON dependsOn + ] + + getFragment = ellipsize . renderToText . minifyJS . flip JSAstStatement JSNoAnnot + where + ellipsize text = if T.compareLength text 20 == GT then T.take 19 text `T.snoc` ellipsis else text + ellipsis = '\x2026' + -- | A module is just a list of elements of the types listed above. data Module = Module ModuleIdentifier (Maybe FilePath) [ModuleElement] deriving (Show) +instance A.ToJSON Module where + toJSON (Module moduleId filePath elements) = + A.object [ "moduleId" .= moduleId + , "filePath" .= filePath + , "elements" .= elements + ] + -- | Prepare an error message for consumption by humans. printErrorMessage :: ErrorMessage -> [String] printErrorMessage (UnsupportedModulePath s) = @@ -730,8 +803,9 @@ bundleSM :: (MonadError ErrorMessage m) -> Maybe String -- ^ An optional main module. -> String -- ^ The namespace (e.g. PS). -> Maybe FilePath -- ^ The output file name (if there is one - in which case generate source map) + -> Maybe ([Module] -> m ()) -- ^ Optionally report the parsed modules prior to DCE -- used by "bundle --debug" -> m (Maybe SourceMapping, String) -bundleSM inputStrs entryPoints mainModule namespace outFilename = do +bundleSM inputStrs entryPoints mainModule namespace outFilename reportRawModules = do let mid (a,_,_) = a forM_ mainModule $ \mname -> when (mname `notElem` map (moduleName . mid) inputStrs) (throwError (MissingMainModule mname)) @@ -745,6 +819,8 @@ bundleSM inputStrs entryPoints mainModule namespace outFilename = do modules <- traverse (fmap withDeps . (\(a,fn,c) -> toModule mids a fn c)) input + forM_ reportRawModules ($ modules) + let compiled = compile modules entryPoints sorted = sortModules (filter (not . isModuleEmpty) compiled) @@ -759,4 +835,4 @@ bundle :: (MonadError ErrorMessage m) -> Maybe String -- ^ An optional main module. -> String -- ^ The namespace (e.g. PS). -> m String -bundle inputStrs entryPoints mainModule namespace = snd <$> bundleSM (map (\(a,b) -> (a,Nothing,b)) inputStrs) entryPoints mainModule namespace Nothing +bundle inputStrs entryPoints mainModule namespace = snd <$> bundleSM (map (\(a,b) -> (a,Nothing,b)) inputStrs) entryPoints mainModule namespace Nothing Nothing diff --git a/stack.yaml b/stack.yaml index bd7bd40bde..192a169424 100644 --- a/stack.yaml +++ b/stack.yaml @@ -12,3 +12,6 @@ nix: - nodejs - nodePackages.npm - nodePackages.bower +flags: + aeson-pretty: + lib-only: true diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs index cbdcf68e1c..ab209d5989 100644 --- a/tests/TestBundle.hs +++ b/tests/TestBundle.hs @@ -74,7 +74,7 @@ assertBundles supportModules supportExterns supportForeigns inputFiles outputFil js <- liftIO $ readUTF8File filename mid <- guessModuleIdentifier filename length js `seq` return (mid, Just filename, js) - bundleSM input entryModule (Just $ "Main") "PS" (Just entryPoint) + bundleSM input entryModule (Just $ "Main") "PS" (Just entryPoint) Nothing case bundled of Right (_, js) -> do writeUTF8File entryPoint js From e873d3403db6e698ed80d13a0fff956ccbb77463 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sun, 16 Jun 2019 05:48:43 -0700 Subject: [PATCH 1128/1580] Fix multiple "let"s in ado before the final "in" (#3679) This failed because we were checking the layout stack before collapsing it. Subsequent let statements were tagged as a normal LytLet context instead of a LytLetStmt context because the previous LytLetStmt was on top of the stack instead of LytAdo/LytDo. By collapsing first, it pops the previous LytLetStmt, and we get the LytAdo/LytDo on top again. --- src/Language/PureScript/CST/Layout.hs | 10 ++++++---- tests/purs/layout/AdoIn.out | 6 ++++++ tests/purs/layout/AdoIn.purs | 6 ++++++ 3 files changed, 18 insertions(+), 4 deletions(-) diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs index bf533ff9aa..2785e06604 100644 --- a/src/Language/PureScript/CST/Layout.hs +++ b/src/Language/PureScript/CST/Layout.hs @@ -146,13 +146,15 @@ insertLayout src@(SourceToken tokAnn tok) nextPos stack = inP _ lyt = isIndented lyt TokLowerName [] "let" -> - case stk of + state & insertKwProperty next + where + next state'@(stk', _) = case stk' of (p, LytDo) : _ | srcColumn p == srcColumn tokPos -> - state & insertKwProperty (insertStart LytLetStmt) + state' & insertStart LytLetStmt (p, LytAdo) : _ | srcColumn p == srcColumn tokPos -> - state & insertKwProperty (insertStart LytLetStmt) + state' & insertStart LytLetStmt _ -> - state & insertKwProperty (insertStart LytLet) + state' & insertStart LytLet TokLowerName _ "do" -> state & insertKwProperty (insertStart LytDo) diff --git a/tests/purs/layout/AdoIn.out b/tests/purs/layout/AdoIn.out index 134ef8fc61..b089bd6b59 100644 --- a/tests/purs/layout/AdoIn.out +++ b/tests/purs/layout/AdoIn.out @@ -10,5 +10,11 @@ test = ado {}in foo; test = ado{ foo <- bar $ let {a = 42 }in a; baz <- b} + in bar; + +test = ado{ + foo; + let {bar = let {a = 42 }in a}; + let {baz = 42}} in bar} \ No newline at end of file diff --git a/tests/purs/layout/AdoIn.purs b/tests/purs/layout/AdoIn.purs index ba7a736619..6513ee8e0d 100644 --- a/tests/purs/layout/AdoIn.purs +++ b/tests/purs/layout/AdoIn.purs @@ -11,3 +11,9 @@ test = ado foo <- bar $ let a = 42 in a baz <- b in bar + +test = ado + foo + let bar = let a = 42 in a + let baz = 42 + in bar From 39c067c340720c9b2ff09856047eef53c6c8304d Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 23 Jun 2019 19:44:14 +0100 Subject: [PATCH 1129/1580] CI tweaks (#3687) * Remove obselete workaround for now-fixed Travis caching bug on Windows * Pin stack version (this is what broke our caches) * Fix travis stack download on windows * Remove workaround to address verbosity of `stack setup` (fixed as of stack 2) --- .travis.yml | 56 ++++++++++++++++------------------------------------- 1 file changed, 17 insertions(+), 39 deletions(-) diff --git a/.travis.yml b/.travis.yml index ae31a4d547..c8b543d8f7 100644 --- a/.travis.yml +++ b/.travis.yml @@ -7,6 +7,9 @@ branches: only: - master - /^v\d+\.\d+(\.\d+)?(-\S*)?$/ +env: + global: + - STACK_VERSION=2.1.1 matrix: include: # We use trusty boxes because they seem to be a bit faster. @@ -17,21 +20,19 @@ matrix: - os: osx - os: windows - # Workaround for a Travis caching bug on Windows where absolute paths - # are not restored from caches properly: - # https://github.com/travis-ci/casher/pull/38 - env: STACK_ROOT=$TRAVIS_BUILD_DIR/.stack_root + # Override the default stack root directory to ensure that it will be + # cached + env: STACK_ROOT=$HOME/.stack # workaround for https://travis-ci.community/t/windows-instances-hanging-before-install/250/15 filter_secrets: false addons: apt: packages: - libgmp-dev -cache: # Travis CI's build cache mechanism allows you to cache compiled artifacts in # order to speed subsequent builds up; this is essential for us, because -# installing all of the compiler's Haskell dependencies takes longer than the -# allotted time for a single build. +# installing all of the compiler's Haskell dependencies can take longer than +# the allotted time for a single build. # # Unfortunately, if we allow a build to reach the Travis timeout limit, we # don't get the opportunity to upload a cache (since uploading is included in @@ -45,13 +46,9 @@ cache: # consider a particular build cache to be appropriate to use when building a # given commit with if the cache was created by a parent of the commit being # built (which is sensible of them). +cache: directories: - $HOME/.stack - - # Workaround for a Travis caching bug on Windows where absolute paths - # are not restored from caches properly: - # https://github.com/travis-ci/casher/pull/38 - - .stack_root # Maximum amount of time in seconds spent attempting to upload a new cache # before aborting. Since our cache can get rather large, increasing this # value helps avoid situations where caches fail to be stored. The default @@ -66,23 +63,13 @@ install: - mkdir -p "$HOME/.local/bin" - export PATH="$PATH:$HOME/.local/bin" - | # Install stack. - if ! which stack >/dev/null - then - URL="https://www.stackage.org/stack/$TRAVIS_OS_NAME-x86_64" - mkdir "$HOME/stack" - pushd "$HOME/stack" - if [ "$TRAVIS_OS_NAME" = "windows" ] - then - curl --location "$URL" > stack.zip - unzip stack.zip - mv stack.exe "$HOME/.local/bin/" - else - curl --location "$URL" > stack.tar.gz - tar -xzf stack.tar.gz --strip-components=1 - mv stack "$HOME/.local/bin/" - fi - popd - fi + URL="https://github.com/commercialhaskell/stack/releases/download/v${STACK_VERSION}/stack-${STACK_VERSION}-${TRAVIS_OS_NAME}-x86_64.tar.gz" + mkdir "$HOME/stack" + pushd "$HOME/stack" + curl --location "$URL" > stack.tar.gz + tar -xzf stack.tar.gz --strip-components=1 + mv stack "$HOME/.local/bin/" + popd - | # Set up the timeout command if which timeout >/dev/null then @@ -99,17 +86,8 @@ install: echo "Unable to set up timeout command" exit 1 fi -- | - if ! stack --no-terminal setup 2>&1 > stack-setup.log - then - cat stack-setup.log - exit 1 - else - # stack setup is very verbose on windows - tail stack-setup.log - fi -- head stack-setup.log - stack --version +- stack --no-terminal setup - stack path - npm install -g bower # for psc-docs / psc-publish tests - export OS_NAME=$(./ci/convert-os-name.sh) From b210a1cb901962122114621b490de2bb171d2c6d Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 23 Jun 2019 20:39:38 +0100 Subject: [PATCH 1130/1580] Empty commit for Travis From 8a4c049add5ff2c00a9ed6733f6bb5ab0af63b70 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 27 Jun 2019 14:01:02 +0100 Subject: [PATCH 1131/1580] Update to GHC 8.6.5, lts 13.26 (#3688) * Update to GHC 8.6.5, lts 13.26 I'm hoping this will fix an access violation seen in Windows CI: but updating things is probably a good idea in general anyway. I've tightened the lower bound on language-javascript to 0.6.0.13, because version 0.6.0.12 (the version in the snapshot we're now using) has a bug where it does not consider `as` to be a valid identifier. * Pin happy 1.19.9 Turns out we can't update just yet. --- package.yaml | 2 +- stack.yaml | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index 2c66f893e4..52a678f32e 100644 --- a/package.yaml +++ b/package.yaml @@ -62,7 +62,7 @@ dependencies: - fsnotify >=0.2.1 - Glob >=0.9 && <0.10 - haskeline >=0.7.0.0 - - language-javascript >=0.6.0.9 && <0.7 + - language-javascript >=0.6.0.13 - lifted-async >=0.10.0.3 && <0.10.1 - lifted-base >=0.2.3 && <0.2.4 - microlens-platform >=0.3.9.0 && <0.4 diff --git a/stack.yaml b/stack.yaml index 192a169424..3187ac98be 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,8 +1,10 @@ -resolver: lts-13.12 +resolver: lts-13.26 pvp-bounds: upper packages: - '.' extra-deps: +- happy-1.19.9 +- language-javascript-0.6.0.13 - network-3.0.1.1 nix: enable: false From 28a86a8d0a4edac4ff3035388521e97084a4ab8d Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 27 Jun 2019 15:22:14 +0100 Subject: [PATCH 1132/1580] Empty commit for travis From e2480ecd8f7320d9e93833679f6cbeddfbb69b76 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 27 Jun 2019 08:44:39 -0700 Subject: [PATCH 1133/1580] Throw a parse error (not internal error) when using quoted labels as puns (#3690) --- src/Language/PureScript/CST/Errors.hs | 3 +++ src/Language/PureScript/CST/Utils.hs | 2 ++ tests/purs/failing/3689.purs | 6 ++++++ 3 files changed, 11 insertions(+) create mode 100644 tests/purs/failing/3689.purs diff --git a/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs index 7d20a372eb..1b6bfdb091 100644 --- a/src/Language/PureScript/CST/Errors.hs +++ b/src/Language/PureScript/CST/Errors.hs @@ -33,6 +33,7 @@ data ParserErrorType | ErrGuardInLetBinder | ErrKeywordVar | ErrKeywordSymbol + | ErrQuotedPun | ErrToken | ErrLineFeedInString | ErrAstralCodePointInChar @@ -103,6 +104,8 @@ prettyPrintErrorMessage (ParserError {..}) = case errType of "Expected variable, saw keyword" ErrKeywordSymbol -> "Expected symbol, saw reserved symbol" + ErrQuotedPun -> + "Unexpected quoted label in record pun, perhaps due to a missing ':'" ErrEof -> "Unexpected end of input" ErrLexeme (Just (hd : _)) _ | isSpace hd -> diff --git a/src/Language/PureScript/CST/Utils.hs b/src/Language/PureScript/CST/Utils.hs index 656de2315d..1d4c9d453a 100644 --- a/src/Language/PureScript/CST/Utils.hs +++ b/src/Language/PureScript/CST/Utils.hs @@ -107,6 +107,8 @@ toName k tok = case tokValue tok of TokLowerName [] a | not (Set.member a reservedNames) -> pure $ Name tok (k a) | otherwise -> addFailure [tok] ErrKeywordVar $> Name tok (k "") + TokString _ _ -> parseFail tok ErrQuotedPun + TokRawString _ -> parseFail tok ErrQuotedPun TokUpperName [] a -> pure $ Name tok (k a) TokSymbolName [] a -> pure $ Name tok (k a) TokOperator [] a -> pure $ Name tok (k a) diff --git a/tests/purs/failing/3689.purs b/tests/purs/failing/3689.purs new file mode 100644 index 0000000000..f11a5816e0 --- /dev/null +++ b/tests/purs/failing/3689.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +test = + { "bad" + } From f76578ad527ff88c5ec6912d6190dadcd89fe579 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 28 Jun 2019 10:08:03 +0100 Subject: [PATCH 1134/1580] Add npm package (#3691) * Add the npm package into the repo As suggested by @joneshf. This means we can bump the versions at the same time more easily. Thoughts? * Tidy up readme - remove broken image links - remove (now incorrect) paragraph stating that caches are inside the npm cache directory --- npm-package/.gitignore | 2 ++ npm-package/LICENSE | 6 ++++ npm-package/README.md | 62 ++++++++++++++++++++++++++++++++++++++++ npm-package/index.js | 1 + npm-package/package.json | 48 +++++++++++++++++++++++++++++++ 5 files changed, 119 insertions(+) create mode 100644 npm-package/.gitignore create mode 100644 npm-package/LICENSE create mode 100644 npm-package/README.md create mode 100644 npm-package/index.js create mode 100644 npm-package/package.json diff --git a/npm-package/.gitignore b/npm-package/.gitignore new file mode 100644 index 0000000000..059fb4c540 --- /dev/null +++ b/npm-package/.gitignore @@ -0,0 +1,2 @@ +purs.bin +package-lock.json diff --git a/npm-package/LICENSE b/npm-package/LICENSE new file mode 100644 index 0000000000..d99869e6a1 --- /dev/null +++ b/npm-package/LICENSE @@ -0,0 +1,6 @@ +ISC License (ISC) +Copyright 2017 - 2019 Watanabe Shinnosuke + +Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. diff --git a/npm-package/README.md b/npm-package/README.md new file mode 100644 index 0000000000..de54955987 --- /dev/null +++ b/npm-package/README.md @@ -0,0 +1,62 @@ +# PureScript npm package + +[![npm version](http://img.shields.io/npm/v/purescript.svg)](https://www.npmjs.com/package/purescript) +[![Build Status](https://travis-ci.org/purescript-contrib/node-purescript.svg?branch=master)](https://travis-ci.org/purescript-contrib/node-purescript) + +[PureScript](https://github.com/purescript/purescript) binary wrapper that makes it seamlessly available via [npm](https://www.npmjs.com/) + +## Prerequisites + +This package makes maximum use of `postinstall` [script](https://docs.npmjs.com/misc/scripts), so please make sure that [`ignore-scripts` npm-config](https://docs.npmjs.com/misc/config#ignore-scripts) is not enabled before installation. + +```console +$ npm config get ignore-scripts +false +``` + +## Installation + +[Use](https://docs.npmjs.com/cli/install) [npm](https://docs.npmjs.com/about-npm/). + +``` +npm install purescript +``` + +Once the command above is executed, + +__1.__ First, it checks if a PureScript binary has been already cached, and restores that if available. + +__2.__ The second plan: if no cache is available, it downloads a prebuilt binary from [the PureScript release page](https://github.com/purescript/purescript/releases). + +__3.__ The last resort: if no prebuilt binary is provided for your platform or the downloaded binary doesn't work correctly, it downloads [the PureScript source code](https://github.com/purescript/purescript/tree/master) and compile it with [Stack](https://docs.haskellstack.org/). + +## API + +### `require('purescript')` + +Type: `string` + +An absolute path to the installed PureScript binary, which can be used with [`child_process`](https://nodejs.org/api/child_process.html) functions. + +```javascript +const {execFile} = require('child_process'); +const purs = require('purescript'); //=> '/Users/you/example/node_modules/purescript/purs.bin' + +execFile(purs, ['compile', 'input.purs', '--output', 'output.purs'], () => { + console.log('Compiled.'); +}); +``` + +## CLI + +You can use it via CLI by installing it [globally](https://docs.npmjs.com/files/folders#global-installation). + +``` +npm install --global purescript + +purs --help +``` + +## License + +[ISC License](./LICENSE) © 2017 - 2019 Watanabe Shinnosuke diff --git a/npm-package/index.js b/npm-package/index.js new file mode 100644 index 0000000000..b4fec3cf51 --- /dev/null +++ b/npm-package/index.js @@ -0,0 +1 @@ +module.exports = require.resolve('./purs.bin'); diff --git a/npm-package/package.json b/npm-package/package.json new file mode 100644 index 0000000000..5efba3fb3a --- /dev/null +++ b/npm-package/package.json @@ -0,0 +1,48 @@ +{ + "name": "purescript", + "version": "0.13.0", + "license": "ISC", + "description": "PureScript wrapper that makes it available as a local dependency", + "author": { + "name": "Watanabe Shinnosuke", + "url": "http://github.com/shinnn" + }, + "files": [ + "index.js", + "purs.bin" + ], + "bin": { + "purs": "purs.bin" + }, + "dependencies": { + "purescript-installer": "^0.2.0" + }, + "homepage": "https://github.com/purescript/purescript", + "repository": { + "type": "git", + "url": "git+https://github.com/purescript/purescript.git" + }, + "bugs": { + "url": "https://github.com/purescript/npm-installer/issues" + }, + "keywords": [ + "cli", + "build", + "install", + "installation", + "fallback", + "purs", + "purescript", + "haskell", + "language", + "compile", + "compiler", + "bin", + "binary", + "wrapper" + ], + "scripts": { + "postinstall": "install-purescript --purs-ver=0.13.0", + "test": "echo 'Error: no test specified' && exit 1" + } +} From 4949b0428522b001c99c14d4d755aa6b9d237355 Mon Sep 17 00:00:00 2001 From: Liam Dyer Date: Tue, 2 Jul 2019 05:59:30 -0500 Subject: [PATCH 1135/1580] Ignore duplicate file inputs to compile command (#3653) (#3676) * Ignore duplicate file inputs to compile command (#3653) * Create readUTF8FilesTUnique and replace duplicative logic, add self to CONTRIBUTORS.md * Implement review feedback - Use ordNub from Protolude, drop extra dependency - Remove readUTF8FilesTUnique, just provide readUTF8FilesT --- CONTRIBUTORS.md | 1 + app/Command/Compile.hs | 11 +++-------- app/Command/Hierarchy.hs | 11 +++++------ src/Language/PureScript/Docs/Collect.hs | 8 ++------ src/Language/PureScript/Interactive/Module.hs | 7 ++----- src/System/IO/UTF8.hs | 7 +++++++ 6 files changed, 20 insertions(+), 25 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index ab5a25a6a4..f60b75ad64 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -133,6 +133,7 @@ If you would prefer to use different terms, please use the section below instead | [@jordanmartinez](https://github.com/jordanmartinez) | Jordan Martinez | [MIT license](http://opensource.org/licenses/MIT) | | [@Saulukass](https://github.com/Saulukass) | Saulius Skliutas | [MIT license](http://opensource.org/licenses/MIT) | | [@adnelson](https://github.com/adnelson) | Allen Nelson | [MIT license](http://opensource.org/licenses/MIT) | +| [@dyerw](https://github.com/dyerw) | Liam Dyer | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 461985f6b1..9246748e1c 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} module Command.Compile (command) where @@ -14,7 +13,6 @@ import qualified Data.ByteString.Lazy.UTF8 as LBU8 import Data.List (intercalate) import qualified Data.Map as M import qualified Data.Set as S -import Data.Text (Text) import qualified Data.Text as T import Data.Traversable (for) import qualified Language.PureScript as P @@ -27,7 +25,7 @@ import System.Exit (exitSuccess, exitFailure) import System.Directory (getCurrentDirectory) import System.FilePath.Glob (glob) import System.IO (hPutStr, hPutStrLn, stderr) -import System.IO.UTF8 (readUTF8FileT) +import System.IO.UTF8 (readUTF8FilesT) data PSCMakeOptions = PSCMakeOptions { pscmInput :: [FilePath] @@ -37,7 +35,7 @@ data PSCMakeOptions = PSCMakeOptions , pscmJSONErrors :: Bool } --- | Argumnets: verbose, use JSON, warnings, errors +-- | Arguments: verbose, use JSON, warnings, errors printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO () printWarningsAndErrors verbose False warnings errors = do pwd <- getCurrentDirectory @@ -64,7 +62,7 @@ compile PSCMakeOptions{..} = do , "Usage: For basic information, try the `--help' option." ] exitFailure - moduleFiles <- readInput input + moduleFiles <- readUTF8FilesT input (makeErrors, makeWarnings) <- runMake pscmOpts $ do ms <- CST.parseModulesFromFiles id moduleFiles let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms @@ -86,9 +84,6 @@ globWarningOnMisses warn = concatMapM globWithWarning return paths concatMapM f = fmap concat . mapM f -readInput :: [FilePath] -> IO [(FilePath, Text)] -readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8FileT inFile - inputFile :: Opts.Parser FilePath inputFile = Opts.strArgument $ Opts.metavar "FILE" diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs index 9e0b26e9fc..30e8ae8750 100644 --- a/app/Command/Hierarchy.hs +++ b/app/Command/Hierarchy.hs @@ -13,7 +13,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE TupleSections #-} {-# LANGUAGE DataKinds #-} module Command.Hierarchy (command) where @@ -31,7 +30,7 @@ import System.FilePath (()) import System.FilePath.Glob (glob) import System.Exit (exitFailure, exitSuccess) import System.IO (hPutStr, stderr) -import System.IO.UTF8 (readUTF8FileT) +import System.IO.UTF8 (readUTF8FilesT) import qualified Language.PureScript as P import qualified Language.PureScript.CST as CST import Language.PureScript.Hierarchy (Graph(..), _unDigraph, _unGraphName, typeClasses) @@ -41,15 +40,15 @@ data HierarchyOptions = HierarchyOptions , _hierarchyOutput :: Maybe FilePath } -readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module]) -readInput paths = do - content <- mapM (\path -> (path, ) <$> readUTF8FileT path) paths +parseInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module]) +parseInput paths = do + content <- readUTF8FilesT paths return $ map snd <$> CST.parseFromFiles id content compile :: HierarchyOptions -> IO () compile (HierarchyOptions inputGlob mOutput) = do input <- glob inputGlob - modules <- readInput input + modules <- parseInput input case modules of Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure Right ms -> do diff --git a/src/Language/PureScript/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs index d7dd7f7485..2c64384d61 100644 --- a/src/Language/PureScript/Docs/Collect.hs +++ b/src/Language/PureScript/Docs/Collect.hs @@ -13,7 +13,7 @@ import Data.String (String) import qualified Data.Set as Set import qualified Data.Text as T import System.FilePath (()) -import System.IO.UTF8 (readUTF8FileT) +import System.IO.UTF8 (readUTF8FileT, readUTF8FilesT) import Language.PureScript.Docs.Convert.ReExports (updateReExports) import Language.PureScript.Docs.Prim (primModules) @@ -89,7 +89,7 @@ compileForDocs :: m [P.ExternsFile] compileForDocs outputDir inputFiles = do result <- liftIO $ do - moduleFiles <- readInput inputFiles + moduleFiles <- readUTF8FilesT inputFiles fmap fst $ P.runMake testOptions $ do ms <- P.parseModulesFromFiles identity moduleFiles let filePathMap = Map.fromList $ map (\(fp, pm) -> (P.getModuleName $ P.resPartial pm, Right fp)) ms @@ -106,10 +106,6 @@ compileForDocs outputDir inputFiles = do renderProgressMessage (P.CompilingModule mn) = "Compiling documentation for " ++ T.unpack (P.runModuleName mn) - readInput :: [FilePath] -> IO [(FilePath, Text)] - readInput files = - forM files $ \inFile -> (inFile, ) <$> readUTF8FileT inFile - testOptions :: P.Options testOptions = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.Docs } diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index a2bf230ea9..7bc01c5617 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -2,13 +2,12 @@ module Language.PureScript.Interactive.Module where import Prelude.Compat -import Control.Monad import qualified Language.PureScript as P import qualified Language.PureScript.CST as CST import Language.PureScript.Interactive.Types import System.Directory (getCurrentDirectory) import System.FilePath (pathSeparator, makeRelative) -import System.IO.UTF8 (readUTF8FileT) +import System.IO.UTF8 (readUTF8FileT, readUTF8FilesT) -- * Support Module @@ -35,9 +34,7 @@ loadModule filename = do loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)]) loadAllModules files = do pwd <- getCurrentDirectory - filesAndContent <- forM files $ \filename -> do - content <- readUTF8FileT filename - return (filename, content) + filesAndContent <- readUTF8FilesT files return $ CST.parseFromFiles (makeRelative pwd) filesAndContent -- | diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs index f3c1838d43..6bb0187262 100644 --- a/src/System/IO/UTF8.hs +++ b/src/System/IO/UTF8.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TupleSections #-} + module System.IO.UTF8 where import Prelude.Compat @@ -8,12 +10,17 @@ import qualified Data.ByteString.Search as BSS import qualified Data.ByteString.UTF8 as UTF8 import Data.Text (Text) import qualified Data.Text.Encoding as TE +import Protolude (ordNub) -- | Unfortunately ByteString's readFile does not convert line endings on -- Windows, so we have to do it ourselves fixCRLF :: BS.ByteString -> BS.ByteString fixCRLF = BSL.toStrict . BSS.replace "\r\n" ("\n" :: BS.ByteString) +readUTF8FilesT :: [FilePath] -> IO [(FilePath, Text)] +readUTF8FilesT = + traverse (\inFile -> (inFile, ) <$> readUTF8FileT inFile) . ordNub + readUTF8FileT :: FilePath -> IO Text readUTF8FileT inFile = fmap (TE.decodeUtf8 . fixCRLF) (BS.readFile inFile) From 4824a24f7a06721063604513fd52c5d6ba8454dc Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 4 Jul 2019 12:24:55 +0100 Subject: [PATCH 1136/1580] Bump to v0.13.1 (#3692) --- npm-package/package.json | 4 ++-- package.yaml | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/npm-package/package.json b/npm-package/package.json index 5efba3fb3a..b0b376f6d0 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.13.0", + "version": "0.13.1", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -42,7 +42,7 @@ "wrapper" ], "scripts": { - "postinstall": "install-purescript --purs-ver=0.13.0", + "postinstall": "install-purescript --purs-ver=0.13.1", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/package.yaml b/package.yaml index 52a678f32e..65cb8065d9 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.13.0' +version: '0.13.1' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 467871d743e23e1b7861124cdc019eb5d4683cd7 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 4 Jul 2019 13:34:40 +0100 Subject: [PATCH 1137/1580] Regenerate LICENSE file --- LICENSE | 38 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 36 insertions(+), 2 deletions(-) diff --git a/LICENSE b/LICENSE index b81d5fcbd7..65cfa9e9b1 100644 --- a/LICENSE +++ b/LICENSE @@ -19,6 +19,7 @@ PureScript uses the following Haskell library packages. Their license files foll SHA aeson aeson-better-errors + aeson-pretty alex ansi-terminal ansi-wl-pprint @@ -320,6 +321,39 @@ aeson-better-errors LICENSE file: TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +aeson-pretty LICENSE file: + + Copyright (c)2011, Falko Peters + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Falko Peters nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + alex LICENSE file: Copyright (c) 1995-2011, Chris Dornan and Simon Marlow @@ -2887,7 +2921,7 @@ mtl LICENSE file: mtl-compat LICENSE file: - Copyright (c) 2015, Ryan Scott + Copyright (c) 2015-2017, Ryan Scott All rights reserved. @@ -4118,7 +4152,7 @@ tagged LICENSE file: tagsoup LICENSE file: - Copyright Neil Mitchell 2006-2018. + Copyright Neil Mitchell 2006-2019. All rights reserved. Redistribution and use in source and binary forms, with or without From 44397e5107dad601a52e0888a24993bec33e8fc0 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 5 Jul 2019 14:10:10 +0100 Subject: [PATCH 1138/1580] v0.13.2 --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 65cb8065d9..b5b9f64126 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.13.1' +version: '0.13.2' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 32b0c1fb451a58c5e1f3d8ed3acbfb905b1ff155 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 5 Jul 2019 20:51:17 +0100 Subject: [PATCH 1139/1580] Add placeholder purs.bin to fix npm installs (#3695) * Add a placeholder purs.bin file to the repo This is necessary for successful publishing, because the npm cli will attempt to read this file once before the postinstall script is run (at which point it will be replaced with the actual binary). I've also made this file produce a sensible error if you try to execute it, which wasn't previously the case (the current one is just a text file). * Bump npm package to 0.13.2-pre.1 ... in order to allow another npm publish attempt * wip * bump npm package to 0.13.2-pre.2 also copy purs.bin.placeholder to purs.bin before publish * Remove shebang in placeholder for windows support * Bump npm package to 0.13.2 --- npm-package/package.json | 5 +++-- npm-package/purs.bin.placeholder | 7 +++++++ 2 files changed, 10 insertions(+), 2 deletions(-) create mode 100755 npm-package/purs.bin.placeholder diff --git a/npm-package/package.json b/npm-package/package.json index b0b376f6d0..bb1e7d2dee 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.13.1", + "version": "0.13.2", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -42,7 +42,8 @@ "wrapper" ], "scripts": { - "postinstall": "install-purescript --purs-ver=0.13.1", + "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", + "postinstall": "install-purescript --purs-ver=0.13.2", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/npm-package/purs.bin.placeholder b/npm-package/purs.bin.placeholder new file mode 100755 index 0000000000..ca25a635fd --- /dev/null +++ b/npm-package/purs.bin.placeholder @@ -0,0 +1,7 @@ +# This is a placeholder file of a PureScript binary installed with npm. If you +# see this file, that means the installation has failed and the placeholder has +# not been replaced with a valid binary. Try installing the `purescript` npm +# package again. + +echo >&2 "purescript npm installer: installation failed; please try installing again" +exit 1 From 90ee25bacc1c94a40cc74d0f8fb03f38314d08f1 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 15 Jul 2019 15:14:34 -0400 Subject: [PATCH 1140/1580] Remove more dead code during bundling (#3562) Fixes #3551. --- src/Language/PureScript/Bundle.hs | 97 ++++++++++--------- tests/purs/bundle/3551.purs | 21 ++++ tests/purs/bundle/3551/ModuleWithDeadCode.js | 12 +++ .../purs/bundle/3551/ModuleWithDeadCode.purs | 16 +++ 4 files changed, 102 insertions(+), 44 deletions(-) create mode 100644 tests/purs/bundle/3551.purs create mode 100644 tests/purs/bundle/3551/ModuleWithDeadCode.js create mode 100644 tests/purs/bundle/3551/ModuleWithDeadCode.purs diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 24abfb9191..2fd4165940 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -28,9 +28,9 @@ import Data.Aeson ((.=)) import Data.Array ((!)) import Data.Char (chr, digitToInt) import Data.Foldable (fold) -import Data.Generics (GenericM, everything, everywhere, gmapMo, mkMp, mkQ, mkT) +import Data.Generics (GenericM, everything, everythingWithContext, everywhere, gmapMo, mkMp, mkQ, mkT) import Data.Graph -import Data.List (stripPrefix) +import Data.List (stripPrefix, (\\)) import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Version (showVersion) import qualified Data.Aeson as A @@ -91,9 +91,14 @@ guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory f guessModuleType "foreign.js" = pure Foreign guessModuleType name = throwError $ UnsupportedModulePath name --- | A piece of code is identified by its module and its name. These keys are used to label vertices --- in the dependency graph. -type Key = (ModuleIdentifier, String) +data Visibility + = Public + | Internal + deriving (Show, Eq, Ord) + +-- | A piece of code is identified by its module, its name, and whether it is an internal variable +-- or a public member. These keys are used to label vertices in the dependency graph. +type Key = (ModuleIdentifier, String, Visibility) -- | An export is either a "regular export", which exports a name from the regular module we are in, -- or a reexport of a declaration in the corresponding foreign module. @@ -115,7 +120,7 @@ data ExportType -- into the output during codegen. data ModuleElement = Require JSStatement String (Either String ModuleIdentifier) - | Member JSStatement Bool String JSExpression [Key] + | Member JSStatement Visibility String JSExpression [Key] | ExportsList [(ExportType, String, JSExpression, [Key])] | Other JSStatement | Skip JSStatement @@ -133,10 +138,10 @@ instance A.ToJSON ModuleElement where , "name" .= name , "targetPath" .= targetPath ] - (Member _ public name _ dependsOn) -> + (Member _ visibility name _ dependsOn) -> A.object [ "type" .= A.String "Member" , "name" .= name - , "visibility" .= A.String (if public then "Public" else "Internal") + , "visibility" .= show visibility , "dependsOn" .= map keyToJSON dependsOn ] (ExportsList exports) -> @@ -154,9 +159,10 @@ instance A.ToJSON ModuleElement where where - keyToJSON (mid, member) = - A.object [ "module" .= mid - , "member" .= member + keyToJSON (mid, member, visibility) = + A.object [ "module" .= mid + , "member" .= member + , "visibility" .= show visibility ] exportToJSON (RegularExport sourceName, name, _, dependsOn) = @@ -275,24 +281,33 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) expand (ty, nm, n1, _) = (ty, nm, n1, ordNub (dependencies modulePath n1)) expandDeps other = other - dependencies :: ModuleIdentifier -> JSExpression -> [(ModuleIdentifier, String)] - dependencies m = everything (++) (mkQ [] toReference) + dependencies :: ModuleIdentifier -> JSExpression -> [Key] + dependencies m = everythingWithContext boundNames (++) (mkQ (const [] &&& id) toReference) where - toReference :: JSExpression -> [(ModuleIdentifier, String)] - toReference (JSMemberDot mn _ nm) + toReference :: JSExpression -> [String] -> ([Key], [String]) + toReference (JSMemberDot mn _ nm) bn | JSIdentifier _ mn' <- mn , JSIdentifier _ nm' <- nm , Just mid <- lookup mn' imports - = [(mid, nm')] - toReference (JSMemberSquare mn _ nm _) + = ([(mid, nm', Public)], bn) + toReference (JSMemberSquare mn _ nm _) bn | JSIdentifier _ mn' <- mn , Just nm' <- fromStringLiteral nm , Just mid <- lookup mn' imports - = [(mid, nm')] - toReference (JSIdentifier _ nm) - | nm `elem` boundNames - = [(m, nm)] - toReference _ = [] + = ([(mid, nm', Public)], bn) + toReference (JSIdentifier _ nm) bn + | nm `elem` bn + -- ^ only add a dependency if this name is still in the list of names + -- bound to the module level (i.e., hasn't been shadowed by a function + -- parameter) + = ([(m, nm, Internal)], bn) + toReference (JSFunctionExpression _ _ _ params _ _) bn + = ([], bn \\ (mapMaybe unIdent $ commaList params)) + toReference _ bn = ([], bn) + + unIdent :: JSIdent -> Maybe String + unIdent (JSIdentName _ name) = Just name + unIdent _ = Nothing -- String literals include the quote chars fromStringLiteral :: JSExpression -> Maybe String @@ -350,8 +365,8 @@ toModule mids mid filename top | Just (importName, importPath) <- matchRequire mids mid stmt = pure (Require stmt importName importPath) toModuleElement stmt - | Just (exported, name, decl) <- matchMember stmt - = pure (Member stmt exported name decl []) + | Just (visibility, name, decl) <- matchMember stmt + = pure (Member stmt visibility name decl []) toModuleElement stmt | Just props <- matchExportsAssignment stmt = ExportsList <$> traverse toExport (trailingCommaList props) @@ -393,7 +408,7 @@ getExportedIdentifiers mname top go stmt | Just props <- matchExportsAssignment stmt = traverse toIdent (trailingCommaList props) - | Just (True, name, _) <- matchMember stmt + | Just (Public, name, _) <- matchMember stmt = pure [name] | otherwise = pure [] @@ -425,18 +440,18 @@ matchRequire mids mid stmt = Nothing -- Matches JS member declarations. -matchMember :: JSStatement -> Maybe (Bool, String, JSExpression) +matchMember :: JSStatement -> Maybe (Visibility, String, JSExpression) matchMember stmt -- var foo = expr; | JSVariable _ jsInit _ <- stmt , [JSVarInitExpression var varInit] <- commaList jsInit , JSIdentifier _ name <- var , JSVarInit _ decl <- varInit - = Just (False, name, decl) + = Just (Internal, name, decl) -- exports.foo = expr; exports["foo"] = expr; | JSAssignStatement e (JSAssign _) decl _ <- stmt , Just name <- accessor e - = Just (True, name, decl) + = Just (Public, name, decl) | otherwise = Nothing where @@ -484,26 +499,20 @@ compile modules entryPoints = filteredModules where -- | Create a set of vertices for a module element. -- - -- Some special cases worth commenting on: - -- - -- 1) Regular exports which simply export their own name do not count as dependencies. - -- Regular exports which rename and reexport an operator do count, however. - -- - -- 2) Require statements don't contribute towards dependencies, since they effectively get - -- inlined wherever they are used inside other module elements. + -- Require statements don't contribute towards dependencies, since they effectively get + -- inlined wherever they are used inside other module elements. toVertices :: ModuleIdentifier -> ModuleElement -> [(ModuleElement, Key, [Key])] - toVertices p m@(Member _ _ nm _ deps) = [(m, (p, nm), deps)] - toVertices p m@(ExportsList exps) = mapMaybe toVertex exps + toVertices p m@(Member _ visibility nm _ deps) = [(m, (p, nm, visibility), deps)] + toVertices p m@(ExportsList exps) = map toVertex exps where - toVertex (ForeignReexport, nm, _, ks) = Just (m, (p, nm), ks) - toVertex (RegularExport nm, nm1, _, ks) | nm /= nm1 = Just (m, (p, nm1), ks) - toVertex _ = Nothing + toVertex (ForeignReexport, nm, _, ks) = (m, (p, nm, Public), ks) + toVertex (RegularExport _, nm, _, ks) = (m, (p, nm, Public), ks) toVertices _ _ = [] -- | The set of vertices whose connected components we are interested in keeping. entryPointVertices :: [Vertex] entryPointVertices = catMaybes $ do - (_, k@(mid, _), _) <- verts + (_, k@(mid, _, Public), _) <- verts guard $ mid `elem` entryPoints return (vertexFor k) @@ -516,7 +525,7 @@ compile modules entryPoints = filteredModules moduleReferenceMap = M.fromAscListWith mappend $ map (vertToModule &&& vertToModuleRefs) $ S.toList reachableSet where vertToModuleRefs v = foldMap (S.singleton . vertToModule) $ graph ! v - vertToModule v = m where (_, (m, _), _) = vertexToNode v + vertToModule v = m where (_, (m, _, _), _) = vertexToNode v filteredModules :: [Module] filteredModules = map filterUsed modules @@ -539,11 +548,11 @@ compile modules entryPoints = filteredModules -- | Filter out the exports for members which aren't used. filterExports :: ModuleElement -> ModuleElement - filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm)) exps) + filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm, Public)) exps) filterExports me = me isDeclUsed :: ModuleElement -> Bool - isDeclUsed (Member _ _ nm _ _) = isKeyUsed (mid, nm) + isDeclUsed (Member _ visibility nm _ _) = isKeyUsed (mid, nm, visibility) isDeclUsed (Require _ _ (Right midRef)) = midRef `S.member` modulesReferenced isDeclUsed _ = True diff --git a/tests/purs/bundle/3551.purs b/tests/purs/bundle/3551.purs new file mode 100644 index 0000000000..4600967da5 --- /dev/null +++ b/tests/purs/bundle/3551.purs @@ -0,0 +1,21 @@ +module Main where + +import Prelude +import Effect (Effect) +import Effect.Console (error, log) + +import ModuleWithDeadCode (class FooBar, exportThatUsesBar, results) + +main :: Effect Unit +main = do + when results.barIsExported $ error "bar is exported" + when results.fooIsNotEliminated $ error "foo is not eliminated" + + -- These are brittleness canaries; if they fail, then the compiler output has + -- probably changed such that the above checks are not doing their job. + unless results.exportThatUsesBarIsExported $ + error "likely test error: check that barIsExported is working" + unless results.barIsNotEliminated $ + error "likely test error: check that fooIsNotEliminated is working" + + when (exportThatUsesBar 0) $ log "Done" diff --git a/tests/purs/bundle/3551/ModuleWithDeadCode.js b/tests/purs/bundle/3551/ModuleWithDeadCode.js new file mode 100644 index 0000000000..ab7965286f --- /dev/null +++ b/tests/purs/bundle/3551/ModuleWithDeadCode.js @@ -0,0 +1,12 @@ +"use strict"; + +var fs = require('fs'); + +var source = fs.readFileSync(__filename, 'utf-8'); + +exports.results = { + fooIsNotEliminated: /^ *var foo =/m.test(source), + barIsExported: /^ *exports\["bar"\] =/m.test(source), + barIsNotEliminated: /^ *var bar =/m.test(source), + exportThatUsesBarIsExported: /^ *exports\["exportThatUsesBar"\] =/m.test(source), +}; diff --git a/tests/purs/bundle/3551/ModuleWithDeadCode.purs b/tests/purs/bundle/3551/ModuleWithDeadCode.purs new file mode 100644 index 0000000000..a67ff7bf41 --- /dev/null +++ b/tests/purs/bundle/3551/ModuleWithDeadCode.purs @@ -0,0 +1,16 @@ +module ModuleWithDeadCode (class FooBar, bar, exportThatUsesBar, foo, results) where + +import Prelude + +class FooBar a where + foo :: a + bar :: a -> Boolean + +instance intFooBar :: FooBar Int where + foo = 0 + bar _ = true + +exportThatUsesBar :: forall a. (FooBar a) => a -> Boolean +exportThatUsesBar = bar + +foreign import results :: { fooIsNotEliminated :: Boolean, barIsExported :: Boolean, barIsNotEliminated :: Boolean, exportThatUsesBarIsExported :: Boolean } From 063aeb9c4890a99d27cbb5e4dbd0a38266df1ed7 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Tue, 16 Jul 2019 16:12:38 +0100 Subject: [PATCH 1141/1580] Eliminate built type class dicts when necessarily empty (#3416) --- src/Language/PureScript/AST/Declarations.hs | 6 ++ src/Language/PureScript/AST/Traversals.hs | 7 ++ src/Language/PureScript/CoreFn/Desugar.hs | 3 + .../PureScript/CoreImp/Optimizer/TCO.hs | 4 + src/Language/PureScript/Environment.hs | 27 ++++--- src/Language/PureScript/Externs.hs | 5 +- src/Language/PureScript/Pretty/Values.hs | 1 + src/Language/PureScript/Sugar/TypeClasses.hs | 6 +- src/Language/PureScript/TypeChecker.hs | 22 ++++-- .../PureScript/TypeChecker/Entailment.hs | 18 +++-- tests/purs/passing/EmptyDicts.purs | 77 +++++++++++++++++++ 11 files changed, 146 insertions(+), 30 deletions(-) create mode 100644 tests/purs/passing/EmptyDicts.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 4de31e2565..999eda9611 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -753,6 +753,12 @@ data Expr -- | App Expr Expr -- | + -- Hint that an expression is unused. + -- This is used to ignore type class dictionaries that are necessarily empty. + -- The inner expression lets us solve subgoals before eliminating the whole expression. + -- The code gen will render this as `undefined`, regardless of what the inner expression is. + | Unused Expr + -- | -- Variable -- | Var SourceSpan (Qualified Ident) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 536792595e..ef2cc26042 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -72,6 +72,7 @@ everywhereOnValues f g h = (f', g', h') g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs)) g' (Abs binder v) = g (Abs (h' binder) (g' v)) g' (App v1 v2) = g (App (g' v1) (g' v2)) + g' (Unused v) = g (Unused (g' v)) g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3)) g' (Case vs alts) = g (Case (fmap g' vs) (fmap handleCaseAlternative alts)) g' (TypedValue check v ty) = g (TypedValue check (g' v) ty) @@ -146,6 +147,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (g' <=< g) vs g' (Abs binder v) = Abs <$> (h binder >>= h') <*> (g v >>= g') g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g') + g' (Unused v) = Unused <$> (g v >>= g') g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g') g' (Case vs alts) = Case <$> traverse (g' <=< g) vs <*> traverse handleCaseAlternative alts g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty @@ -215,6 +217,7 @@ everywhereOnValuesM f g h = (f', g', h') g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse g' vs) >>= g g' (Abs binder v) = (Abs <$> h' binder <*> g' v) >>= g g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g + g' (Unused v) = (Unused <$> g' v) >>= g g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g g' (Case vs alts) = (Case <$> traverse g' vs <*> traverse handleCaseAlternative alts) >>= g g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g @@ -287,6 +290,7 @@ everythingOnValues (<>.) f g h i j = (f', g', h', i', j') g' v@(ObjectUpdateNested obj vs) = foldl (<>.) (g v <>. g' obj) (fmap g' vs) g' v@(Abs b v1) = g v <>. h' b <>. g' v1 g' v@(App v1 v2) = g v <>. g' v1 <>. g' v2 + g' v@(Unused v1) = g v <>. g' v1 g' v@(IfThenElse v1 v2 v3) = g v <>. g' v1 <>. g' v2 <>. g' v3 g' v@(Case vs alts) = foldl (<>.) (foldl (<>.) (g v) (fmap g' vs)) (fmap i' alts) g' v@(TypedValue _ v1 _) = g v <>. g' v1 @@ -368,6 +372,7 @@ everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i g' s (ObjectUpdateNested obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s) vs) g' s (Abs binder v1) = h'' s binder <>. g'' s v1 g' s (App v1 v2) = g'' s v1 <>. g'' s v2 + g' s (Unused v) = g'' s v g' s (IfThenElse v1 v2 v3) = g'' s v1 <>. g'' s v2 <>. g'' s v3 g' s (Case vs alts) = foldl (<>.) (foldl (<>.) r0 (fmap (g'' s) vs)) (fmap (i'' s) alts) g' s (TypedValue _ v1 _) = g'' s v1 @@ -453,6 +458,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (g'' s) vs g' s (Abs binder v) = Abs <$> h' s binder <*> g'' s v g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2 + g' s (Unused v) = Unused <$> g'' s v g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3 g' s (Case vs alts) = Case <$> traverse (g'' s) vs <*> traverse (i'' s) alts g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty @@ -548,6 +554,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) let s' = S.union (S.fromList (localBinderNames b)) s in h'' s b <> g'' s' v1 g' s (App v1 v2) = g'' s v1 <> g'' s v2 + g' s (Unused v) = g'' s v g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts g' s (TypedValue _ v1 _) = g'' s v1 diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index b404558999..c9fb334ed7 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -28,6 +28,7 @@ import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDic import Language.PureScript.Types import Language.PureScript.PSString (mkString) import qualified Language.PureScript.AST as A +import qualified Language.PureScript.Constants as C -- | Desugars a module from AST to CoreFn representation. moduleToCoreFn :: Environment -> A.Module -> Module Ann @@ -85,6 +86,8 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = internalError "Abs with Binder argument was not desugared before exprToCoreFn mn" exprToCoreFn ss com ty (A.App v1 v2) = App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2) + exprToCoreFn ss com ty (A.Unused _) = + Var (ss, com, ty, Nothing) (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) exprToCoreFn _ com ty (A.Var ss ident) = Var (ss, com, ty, getValueMeta ident) ident exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) = diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index fcf49fcbef..2b0f077a06 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -4,6 +4,7 @@ module Language.PureScript.CoreImp.Optimizer.TCO (tco) where import Prelude.Compat import Data.Text (Text) +import qualified Language.PureScript.Constants as C import Language.PureScript.CoreImp.AST import Language.PureScript.AST.SourcePos (SourceSpan) import Safe (headDef, tailSafe) @@ -120,6 +121,9 @@ tco = everywhere convert where markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True) collectArgs :: [[AST]] -> AST -> [[AST]] + collectArgs acc (App _ fn []) = + -- count 0-argument applications as single-argument so we get the correct number of args + collectArgs ([Var Nothing C.undefined] : acc) fn collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn collectArgs acc _ = acc diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 3e9505aab3..f6bea0e9dc 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -69,6 +69,8 @@ data TypeClassData = TypeClassData -- typeClassArguments and typeClassDependencies. , typeClassCoveringSets :: S.Set (S.Set Int) -- ^ A sets of arguments that can be used to infer all other arguments. + , typeClassIsEmpty :: Bool + -- ^ Whether or not dictionaries for this type class are necessarily empty. } deriving (Show, Generic) instance NFData TypeClassData @@ -125,8 +127,9 @@ makeTypeClassData -> [(Ident, SourceType)] -> [SourceConstraint] -> [FunctionalDependency] + -> Bool -> TypeClassData -makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs coveringSets +makeTypeClassData args m s deps tcIsEmpty = TypeClassData args m s deps determinedArgs coveringSets tcIsEmpty where argumentIndicies = [0 .. length args - 1] @@ -486,7 +489,7 @@ primTypeErrorTypes = primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses = M.fromList - [ (primName "Partial", (makeTypeClassData [] [] [] [])) + [ (primName "Partial", (makeTypeClassData [] [] [] [] True)) ] -- | This contains all of the type classes from all Prim modules. @@ -511,7 +514,7 @@ primRowClasses = [ FunctionalDependency [0, 1] [2] , FunctionalDependency [1, 2] [0] , FunctionalDependency [2, 0] [1] - ]) + ] True) -- class Nub (original :: # Type) (nubbed :: # Type) | i -> o , (primSubName C.moduleRow "Nub", makeTypeClassData @@ -519,13 +522,13 @@ primRowClasses = , ("nubbed", Just (kindRow kindType)) ] [] [] [ FunctionalDependency [0] [1] - ]) + ] True) -- class Lacks (label :: Symbol) (row :: # Type) , (primSubName C.moduleRow "Lacks", makeTypeClassData [ ("label", Just kindSymbol) , ("row", Just (kindRow kindType)) - ] [] [] []) + ] [] [] [] True) -- class RowCons (label :: Symbol) (a :: Type) (tail :: # Type) (row :: # Type) | label tail a -> row, label row -> tail a , (primSubName C.moduleRow "Cons", makeTypeClassData @@ -536,7 +539,7 @@ primRowClasses = ] [] [] [ FunctionalDependency [0, 1, 2] [3] , FunctionalDependency [0, 3] [1, 2] - ]) + ] True) ] primRowListClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData @@ -548,7 +551,7 @@ primRowListClasses = , ("list", Just kindRowList) ] [] [] [ FunctionalDependency [0] [1] - ]) + ] True) ] primSymbolClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData @@ -563,7 +566,7 @@ primSymbolClasses = [ FunctionalDependency [0, 1] [2] , FunctionalDependency [1, 2] [0] , FunctionalDependency [2, 0] [1] - ]) + ] True) -- class Compare (left :: Symbol) (right :: Symbol) (ordering :: Ordering) | left right -> ordering , (primSubName C.moduleSymbol "Compare", makeTypeClassData @@ -572,7 +575,7 @@ primSymbolClasses = , ("ordering", Just kindOrdering) ] [] [] [ FunctionalDependency [0, 1] [2] - ]) + ] True) -- class Cons (head :: Symbol) (tail :: Symbol) (symbol :: Symbol) | head tail -> symbol, symbol -> head tail , (primSubName C.moduleSymbol "Cons", makeTypeClassData @@ -582,7 +585,7 @@ primSymbolClasses = ] [] [] [ FunctionalDependency [0, 1] [2] , FunctionalDependency [2] [0, 1] - ]) + ] True) ] primTypeErrorClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData @@ -590,11 +593,11 @@ primTypeErrorClasses = M.fromList -- class Fail (message :: Symbol) [ (primSubName C.typeError "Fail", makeTypeClassData - [("message", Just kindDoc)] [] [] []) + [("message", Just kindDoc)] [] [] [] True) -- class Warn (message :: Symbol) , (primSubName C.typeError "Warn", makeTypeClassData - [("message", Just kindDoc)] [] [] []) + [("message", Just kindDoc)] [] [] [] True) ] -- | Finds information about data constructors from the current environment. diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 0953ea2532..31d24b2c1c 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -132,6 +132,7 @@ data ExternsDeclaration = , edClassMembers :: [(Ident, SourceType)] , edClassConstraints :: [SourceConstraint] , edFunctionalDependencies :: [FunctionalDependency] + , edIsEmpty :: Bool } -- | An instance declaration | EDInstance @@ -157,7 +158,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) } applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } - applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps) (typeClasses env) } + applyDecl env (EDClass pn args members cs deps tcIsEmpty) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) } applyDecl env (EDKind pn) = env { kinds = S.insert (qual pn) (kinds env) } applyDecl env (EDInstance className ident tys cs ch idx) = env { typeClassDictionaries = @@ -227,7 +228,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env = [ EDType (coerceProperName className) kind TypeSynonym , EDTypeSynonym (coerceProperName className) typeClassArguments synTy - , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies + , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies typeClassIsEmpty ] toExternsDeclaration (TypeInstanceRef _ ident) = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies tcdChain tcdIndex diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index fe9592d7b4..99ddaf0b38 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -67,6 +67,7 @@ prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintValueAtom (d - 1) o `b printNode (key, Leaf val) = prettyPrintUpdateEntry d key val printNode (key, Branch val) = textT (prettyPrintObjectKey key) `beforeWithSpace` prettyPrintUpdate val prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg +prettyPrintValue d (Unused val) = prettyPrintValue d val prettyPrintValue d (Abs arg val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) = text (T.unpack (runProperName (disqualify className)) ++ " ") <> prettyPrintValueAtom (d - 1) ps diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 7686e710e4..761de6f631 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -64,8 +64,8 @@ desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModu :: ModuleName -> ExternsDeclaration -> Maybe ((ModuleName, ProperName 'ClassName), TypeClassData) - fromExternsDecl mn (EDClass name args members implies deps) = Just ((mn, name), typeClass) where - typeClass = makeTypeClassData args members implies deps + fromExternsDecl mn (EDClass name args members implies deps tcIsEmpty) = Just ((mn, name), typeClass) where + typeClass = makeTypeClassData args members implies deps tcIsEmpty fromExternsDecl _ _ = Nothing desugarModule @@ -203,7 +203,7 @@ desugarDecl desugarDecl mn exps = go where go d@(TypeClassDeclaration sa name args implies deps members) = do - modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps)) + modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False)) return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) go (TypeInstanceDeclaration _ _ _ _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" go d@(TypeInstanceDeclaration sa _ _ name deps className tys (ExplicitInstance members)) = do diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index ecfdeb9b79..bb66bc3205 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -125,17 +125,23 @@ addTypeClass -> m () addTypeClass qualifiedClassName args implies dependencies ds = do env <- getEnv - traverse_ (checkMemberIsUsable (typeSynonyms env)) classMembers + let newClass = mkNewClass env + traverse_ (checkMemberIsUsable newClass (typeSynonyms env)) classMembers modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert qualifiedClassName newClass (typeClasses . checkEnv $ st) } } where classMembers :: [(Ident, SourceType)] classMembers = map toPair ds - newClass :: TypeClassData - newClass = makeTypeClassData args classMembers implies dependencies + mkNewClass :: Environment -> TypeClassData + mkNewClass env = makeTypeClassData args classMembers implies dependencies ctIsEmpty + where + ctIsEmpty = null classMembers && all (typeClassIsEmpty . findSuperClass) implies + findSuperClass c = case M.lookup (constraintClass c) (typeClasses env) of + Just tcd -> tcd + Nothing -> internalError "Unknown super class in TypeClassDeclaration" - coveringSets :: [S.Set Int] - coveringSets = S.toList (typeClassCoveringSets newClass) + coveringSets :: TypeClassData -> [S.Set Int] + coveringSets = S.toList . typeClassCoveringSets argToIndex :: Text -> Maybe Int argToIndex = flip M.lookup $ M.fromList (zipWith ((,) . fst) args [0..]) @@ -146,11 +152,11 @@ addTypeClass qualifiedClassName args implies dependencies ds = do -- Currently we are only checking usability based on the type class currently -- being defined. If the mentioned arguments don't include a covering set, -- then we won't be able to find a instance. - checkMemberIsUsable :: T.SynonymMap -> (Ident, SourceType) -> m () - checkMemberIsUsable syns (ident, memberTy) = do + checkMemberIsUsable :: TypeClassData -> T.SynonymMap -> (Ident, SourceType) -> m () + checkMemberIsUsable newClass syns (ident, memberTy) = do memberTy' <- T.replaceAllTypeSynonymsM syns memberTy let mentionedArgIndexes = S.fromList (mapMaybe argToIndex (freeTypeVariables memberTy')) - let leftovers = map (`S.difference` mentionedArgIndexes) coveringSets + let leftovers = map (`S.difference` mentionedArgIndexes) (coveringSets newClass) unless (any null leftovers) . throwError . errorMessage $ let diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 23f62f9e34..dee68a97e4 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -207,9 +207,14 @@ entails SolverOptions{..} constraint context hints = -- We need information about functional dependencies, so we have to look up the class -- name in the environment: classesInScope <- lift . lift $ gets (typeClasses . checkEnv) - TypeClassData{ typeClassDependencies } <- case M.lookup className' classesInScope of - Nothing -> throwError . errorMessage $ UnknownClass className' - Just tcd -> pure tcd + + TypeClassData + { typeClassDependencies + , typeClassIsEmpty + } <- case M.lookup className' classesInScope of + Nothing -> throwError . errorMessage $ UnknownClass className' + Just tcd -> pure tcd + let instances = do chain <- groupBy ((==) `on` tcdChain) $ sortBy (compare `on` (tcdChain &&& tcdIndex)) $ @@ -245,11 +250,14 @@ entails SolverOptions{..} constraint context hints = let subst'' = fmap (substituteType currentSubst') subst' -- Solve any necessary subgoals args <- solveSubgoals subst'' (tcdDependencies tcd) + initDict <- lift . lift $ mkDictionary (tcdValue tcd) args + let match = foldr (\(className, index) dict -> subclassDictionaryValue dict className index) initDict (tcdPath tcd) - return match + + return (if typeClassIsEmpty then Unused match else match) Unsolved unsolved -> do -- Generate a fresh name for the unsolved constraint's new dictionary ident <- freshIdent ("dict" <> runProperName (disqualify (constraintClass unsolved))) @@ -339,7 +347,7 @@ entails SolverOptions{..} constraint context hints = -- We need subgoal dictionaries to appear in the term somewhere -- If there aren't any then the dictionary is just undefined useEmptyDict :: Maybe [Expr] -> Expr - useEmptyDict args = foldl (App . Abs (VarBinder nullSourceSpan UnusedIdent)) valUndefined (fold args) + useEmptyDict args = Unused (foldl (App . Abs (VarBinder nullSourceSpan UnusedIdent)) valUndefined (fold args)) -- Make a dictionary from subgoal dictionaries by applying the correct function mkDictionary :: Evidence -> Maybe [Expr] -> m Expr diff --git a/tests/purs/passing/EmptyDicts.purs b/tests/purs/passing/EmptyDicts.purs new file mode 100644 index 0000000000..157af7bc52 --- /dev/null +++ b/tests/purs/passing/EmptyDicts.purs @@ -0,0 +1,77 @@ +-- | +-- The purpose of this test is to make sure that the empty type class +-- dictionary elimination code doesn't change semantics. +module Main where + +import Prelude +import Effect.Console (log) + +-- | +-- Data type to check that the result of expressions with eliminated +-- dictionaries are as expected. +data Check = Check +derive instance eqCheck :: Eq Check + +-- | +-- This type class has no constraints and no members. +-- Is is therefore considered empty. +class EmptyClass +instance emptyDictInst :: EmptyClass + +-- | +-- This type class is not empty as it has members, but it has an empty super +-- class. +class EmptyClass <= HasEmptySuper where + hasEmptySuper :: Check +instance hasEmptySuperInst :: HasEmptySuper where + hasEmptySuper = Check + +-- | +-- This type class has no members, but has a non-empty super class. +-- It is therefore not empty. +class HasEmptySuper <= HasNonEmptySuper +instance hasNonEmptySuperInst :: HasEmptySuper => HasNonEmptySuper + +-- | +-- This type class is empty because all it's super classes are empty and it +-- has no members. +class EmptyClass <= AliasEmptyClass +instance aliasEmptyClassInst :: AliasEmptyClass + +whenEmpty :: Check +whenEmpty = Check :: EmptyClass => Check + +whenHasEmptySuper :: Check +whenHasEmptySuper = Check :: HasEmptySuper => Check + +whenHasNonEmptySuper :: Check +whenHasNonEmptySuper = Check :: HasNonEmptySuper => Check + +whenAliasEmptyClass :: Check +whenAliasEmptyClass = Check :: AliasEmptyClass => Check + +class WithArgEmpty t +instance withArgEmptyCheck :: WithArgEmpty Check +class WithArgEmpty t <= WithArgHasEmptySuper t where + withArgHasEmptySuper :: t +instance withArgHasEmptySuperCheck :: WithArgHasEmptySuper Check where + withArgHasEmptySuper = Check + +whenAccessingSuperDict :: Check +whenAccessingSuperDict = foo Check where + + bar :: forall t . WithArgEmpty t => t -> t + bar x = x + + foo :: forall t . WithArgHasEmptySuper t => t -> t + foo x = bar x + +main = + if Check == whenEmpty && + Check == whenHasEmptySuper && + Check == whenHasNonEmptySuper && + Check == whenAliasEmptyClass && + Check == whenAccessingSuperDict + then log "Done" + else pure unit + From ed5fbfb75eb7d85431591d0c889fa8ada7174fd6 Mon Sep 17 00:00:00 2001 From: Marco Perone Date: Sun, 21 Jul 2019 14:24:40 +0200 Subject: [PATCH 1142/1580] Add data constructor docs (#3683) * collect data constructor comments on conversion from CST to AST * expose data constructor comments in docs.json * rename DataConstructorDeclaration data type * use DataConstructorDeclaration in tests * remove Show from PartialResult * add test for doc comments on data constructor * [purs ide] Extracts spans and doc comments for Dtors * pattern match instead of using fst and snd * rename DataConstructorDeclaration fields * add myself to contributors * add more tests for data constructor doc-comments * data constructor doc-comments work also for newtypes * test doc-comments generation for class methods * rename `traverseDataCtorVars` to `traverseDataCtorFields` --- CONTRIBUTORS.md | 1 + src/Language/PureScript/AST/Declarations.hs | 11 ++- src/Language/PureScript/AST/Exported.hs | 2 +- src/Language/PureScript/AST/Traversals.hs | 4 +- src/Language/PureScript/CST/Convert.hs | 17 +++-- src/Language/PureScript/CoreFn/Desugar.hs | 10 ++- .../PureScript/Docs/Convert/Single.hs | 6 +- src/Language/PureScript/Ide/SourceFile.hs | 6 +- src/Language/PureScript/Ide/State.hs | 20 +++-- src/Language/PureScript/Sugar/Names.hs | 2 +- .../PureScript/Sugar/Names/Exports.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 3 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 20 ++--- src/Language/PureScript/TypeChecker.hs | 16 ++-- .../Language/PureScript/Ide/SourceFileSpec.hs | 4 +- tests/TestDocs.hs | 74 ++++++++++++++++++- .../purs/docs/src/DocCommentsClassMethod.purs | 6 ++ .../docs/src/DocCommentsDataConstructor.purs | 15 ++++ 18 files changed, 169 insertions(+), 50 deletions(-) create mode 100644 tests/purs/docs/src/DocCommentsClassMethod.purs create mode 100644 tests/purs/docs/src/DocCommentsDataConstructor.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index f60b75ad64..1ecc5a4e05 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -134,6 +134,7 @@ If you would prefer to use different terms, please use the section below instead | [@Saulukass](https://github.com/Saulukass) | Saulius Skliutas | [MIT license](http://opensource.org/licenses/MIT) | | [@adnelson](https://github.com/adnelson) | Allen Nelson | [MIT license](http://opensource.org/licenses/MIT) | | [@dyerw](https://github.com/dyerw) | Liam Dyer | [MIT license](http://opensource.org/licenses/MIT) | +| [@marcosh](https://github.com/marcosh) | Marco Perone | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 999eda9611..93f8d879e5 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -481,6 +481,15 @@ pattern ValueDecl :: SourceAnn -> Ident -> NameKind -> [Binder] -> [GuardedExpr] pattern ValueDecl sann ident name binders expr = ValueDeclaration (ValueDeclarationData sann ident name binders expr) +data DataConstructorDeclaration = DataConstructorDeclaration + { dataCtorAnn :: !SourceAnn + , dataCtorName :: !(ProperName 'ConstructorName) + , dataCtorFields :: ![(Ident, SourceType)] + } deriving (Show, Eq) + +traverseDataCtorFields :: Monad m => ([(Ident, SourceType)] -> m [(Ident, SourceType)]) -> DataConstructorDeclaration -> m DataConstructorDeclaration +traverseDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration dataCtorAnn dataCtorName <$> f dataCtorFields + -- | -- The data type of declarations -- @@ -488,7 +497,7 @@ data Declaration -- | -- A data type declaration (data or newtype, name, arguments, data constructors) -- - = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceKind)] [(ProperName 'ConstructorName, [(Ident, SourceType)])] + = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceKind)] [DataConstructorDeclaration] -- | -- A minimal mutually recursive set of data type declarations -- diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index f24b1dc697..9cf015e0bc 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -47,7 +47,7 @@ exportedDeclarations (Module _ _ mn decls exps) = go decls filterDataConstructors :: Maybe [DeclarationRef] -> Declaration -> Declaration filterDataConstructors exps (DataDeclaration sa dType tyName tyArgs dctors) = DataDeclaration sa dType tyName tyArgs $ - filter (isDctorExported tyName exps . fst) dctors + filter (isDctorExported tyName exps . dataCtorName) dctors filterDataConstructors _ other = other -- | diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index ef2cc26042..70543f8621 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -636,7 +636,7 @@ accumTypes ) accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) where - forDecls (DataDeclaration _ _ _ _ dctors) = mconcat (concatMap (fmap (f . snd) . snd) dctors) + forDecls (DataDeclaration _ _ _ _ dctors) = mconcat (concatMap (fmap (f . snd) . dataCtorFields) dctors) forDecls (ExternDeclaration _ _ ty) = f ty forDecls (TypeClassDeclaration _ _ _ implies _ _) = mconcat (concatMap (fmap f . constraintArgs) implies) forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) <> mconcat (fmap f tys) @@ -662,7 +662,7 @@ accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (con where forDecls (DataDeclaration _ _ _ args dctors) = foldMap (foldMap f . snd) args <> - foldMap (foldMap (forTypes . snd) . snd) dctors + foldMap (foldMap (forTypes . snd) . dataCtorFields) dctors forDecls (TypeClassDeclaration _ _ args implies _ _) = foldMap (foldMap f . snd) args <> foldMap (foldMap forTypes . constraintArgs) implies diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index 80e8cc45e3..6f250506c7 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -446,18 +446,21 @@ convertDeclaration :: String -> Declaration a -> [AST.Declaration] convertDeclaration fileName decl = case decl of DeclData _ (DataHead _ a vars) bd -> do let - ctr (DataCtor _ x ys) = (nameValue x, zip ctrFields $ convertType fileName <$> ys) - ctrs = case bd of - Nothing -> [] - Just (_, cs) -> ctr <$> toList cs - pure $ AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) ctrs + ctrs :: SourceToken -> DataCtor a -> [(SourceToken, DataCtor a)] -> [AST.DataConstructorDeclaration] + ctrs st (DataCtor _ name fields) tl + = AST.DataConstructorDeclaration (sourceAnnCommented fileName st (nameTok name)) (nameValue name) (zip ctrFields $ convertType fileName <$> fields) + : (case tl of + [] -> [] + (st', ctor) : tl' -> ctrs st' ctor tl' + ) + pure $ AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) (maybe [] (\(st, Separated hd tl) -> ctrs st hd tl) bd) DeclType _ (DataHead _ a vars) _ bd -> pure $ AST.TypeSynonymDeclaration ann (nameValue a) (goTypeVar <$> vars) (convertType fileName bd) - DeclNewtype _ (DataHead _ a vars) _ x ys -> do - let ctrs = [(nameValue x, [(head ctrFields, convertType fileName ys)])] + DeclNewtype _ (DataHead _ a vars) st x ys -> do + let ctrs = [AST.DataConstructorDeclaration (sourceAnnCommented fileName st (snd $ declRange decl)) (nameValue x) [(head ctrFields, convertType fileName ys)]] pure $ AST.DataDeclaration ann Env.Newtype (nameValue a) (goTypeVar <$> vars) ctrs DeclClass _ (ClassHead _ sup name vars fdeps) bd -> do let diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index c9fb334ed7..3ab44b09be 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -53,14 +53,16 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = -- | Desugars member declarations from AST to CoreFn representation. declToCoreFn :: A.Declaration -> [Bind Ann] - declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [(ctor, _)]) = - [NonRec (ssA ss) (properToIdent ctor) $ + declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [ctor]) = + [NonRec (ssA ss) (properToIdent $ A.dataCtorName ctor) $ Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ Qualified Nothing (Ident "x"))] declToCoreFn d@(A.DataDeclaration _ Newtype _ _ _) = error $ "Found newtype with multiple constructors: " ++ show d declToCoreFn (A.DataDeclaration (ss, com) Data tyName _ ctors) = - flip fmap ctors $ \(ctor, _) -> - let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor) + flip fmap ctors $ \ctorDecl -> + let + ctor = A.dataCtorName ctorDecl + (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor) in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields declToCoreFn (A.DataBindingGroupDeclaration ds) = concatMap declToCoreFn ds diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 1ab7188634..60e2ddb051 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -128,9 +128,9 @@ convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title = where info = DataDeclaration dtype (fmap (fmap (fmap ($> ()))) args) children = map convertCtor ctors - convertCtor :: (P.ProperName 'P.ConstructorName, [(P.Ident, P.SourceType)]) -> ChildDeclaration - convertCtor (ctor', tys) = - ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor (fmap (($> ()) . snd) tys)) + convertCtor :: P.DataConstructorDeclaration -> ChildDeclaration + convertCtor P.DataConstructorDeclaration{..} = + ChildDeclaration (P.runProperName dataCtorName) (convertComments $ snd dataCtorAnn) Nothing (ChildDataConstructor (fmap (($> ()) . snd) dataCtorFields)) convertDeclaration (P.ExternDataDeclaration sa _ kind') title = basicDeclaration sa title (ExternDataDeclaration (kind' $> ())) convertDeclaration (P.ExternKindDeclaration sa _) title = diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index bda321206c..726478af12 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -87,8 +87,7 @@ extractSpans d = case d of P.TypeClassDeclaration (ss, _) name _ _ _ members -> (IdeNamespaced IdeNSType (P.runProperName name), ss) : concatMap extractSpans' members P.DataDeclaration (ss, _) _ name _ ctors -> - (IdeNamespaced IdeNSType (P.runProperName name), ss) - : map (\(cname, _) -> (IdeNamespaced IdeNSValue (P.runProperName cname), ss)) ctors + (IdeNamespaced IdeNSType (P.runProperName name), ss) : map dtorSpan ctors P.FixityDeclaration (ss, _) (Left (P.ValueFixity _ _ opName)) -> [(IdeNamespaced IdeNSValue (P.runOpName opName), ss)] P.FixityDeclaration (ss, _) (Right (P.TypeFixity _ _ opName)) -> @@ -101,6 +100,9 @@ extractSpans d = case d of [(IdeNamespaced IdeNSKind (P.runProperName name), ss)] _ -> [] where + dtorSpan :: P.DataConstructorDeclaration -> (IdeNamespaced, P.SourceSpan) + dtorSpan P.DataConstructorDeclaration{ P.dataCtorName = name, P.dataCtorAnn = (ss, _) } = + (IdeNamespaced IdeNSValue (P.runProperName name), ss) -- We need this special case to be able to also get the position info for -- typeclass member functions. Typedeclarations would clash with value -- declarations for non-typeclass members, which is why we can't handle them diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index d29f44634c..419b529175 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -227,6 +227,7 @@ resolveLocationsForModule (defs, types) decls = convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' annotateFunction annotateValue + annotateDataConstructor annotateType annotateKind annotateModule @@ -236,6 +237,7 @@ resolveLocationsForModule (defs, types) decls = , _annTypeAnnotation = Map.lookup x types }) annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) + annotateDataConstructor x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs}) annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSKind x) defs}) annotateModule x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSModule x) defs}) @@ -246,9 +248,10 @@ convertDeclaration' -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> IdeDeclaration -> IdeDeclarationAnn -convertDeclaration' annotateFunction annotateValue annotateType annotateKind annotateModule d = +convertDeclaration' annotateFunction annotateValue annotateDataConstructor annotateType annotateKind annotateModule d = case d of IdeDeclValue v -> annotateFunction (v ^. ideValueIdent) d @@ -257,7 +260,7 @@ convertDeclaration' annotateFunction annotateValue annotateType annotateKind ann IdeDeclTypeSynonym s -> annotateType (s ^. ideSynonymName . properNameT) d IdeDeclDataConstructor dtor -> - annotateValue (dtor ^. ideDtorName . properNameT) d + annotateDataConstructor (dtor ^. ideDtorName . properNameT) d IdeDeclTypeClass tc -> annotateType (tc ^. ideTCName . properNameT) d IdeDeclValueOperator operator -> @@ -284,12 +287,16 @@ resolveDocumentationForModule resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) decls = map convertDecl decls where comments :: Map P.Name [P.Comment] - comments = Map.insert (P.ModName moduleName) moduleComments $ Map.fromListWith (flip (<>)) $ mapMaybe (\d -> - case name d of - Just name' -> Just (name', snd $ P.declSourceAnn d) - _ -> Nothing) + comments = Map.insert (P.ModName moduleName) moduleComments $ Map.fromListWith (flip (<>)) $ concatMap (\case + P.DataDeclaration (_, cs) _ ctorName _ ctors -> + (P.TyName ctorName, cs) : map dtorComments ctors + decl -> + maybe [] (\name' -> [(name', snd (P.declSourceAnn decl))]) (name decl)) sdecls + dtorComments :: P.DataConstructorDeclaration -> (P.Name, [P.Comment]) + dtorComments dcd = (P.DctorName (P.dataCtorName dcd), snd (P.dataCtorAnn dcd)) + name :: P.Declaration -> Maybe P.Name name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d name decl = P.declName decl @@ -299,6 +306,7 @@ resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) de convertDeclaration' (annotateValue . P.IdentName) (annotateValue . P.IdentName . P.Ident) + (annotateValue . P.DctorName . P.ProperName) (annotateValue . P.TyName . P.ProperName) (annotateValue . P.KiName . P.ProperName) (annotateValue . P.ModName . P.moduleNameFromString) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 063979a8d7..fcf7f469d3 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -205,7 +205,7 @@ renameInModule imports (Module modSS coms mn decls exps) = fmap (bound,) $ DataDeclaration sa dtype name <$> updateTypeArguments args - <*> traverse (sndM (traverse (sndM updateTypesEverywhere))) dctors + <*> traverse (traverseDataCtorFields (traverse (sndM updateTypesEverywhere))) dctors updateDecl bound (TypeSynonymDeclaration sa name ps ty) = fmap (bound,) $ TypeSynonymDeclaration sa name diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 7480ecc07f..57fdb72f7f 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -46,7 +46,7 @@ findExportable (Module _ _ mn ds _) = go exps'' (TypeDeclaration (TypeDeclarationData (ss', _) name _)) = exportValue ss' exps'' name source go _ _ = internalError "Invalid declaration in TypeClassDeclaration" updateExports exps (DataDeclaration (ss, _) _ tn _ dcs) = - exportType ss Internal exps tn (map fst dcs) source + exportType ss Internal exps tn (map dataCtorName dcs) source updateExports exps (TypeSynonymDeclaration (ss, _) tn _ _) = exportType ss Internal exps tn [] source updateExports exps (ExternDataDeclaration (ss, _) tn _) = diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 20a2e04272..1d0bb8aec4 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -315,7 +315,8 @@ updateTypes goType = (goDecl, goExpr, goBinder) goDecl :: Declaration -> m Declaration goDecl (DataDeclaration sa@(ss, _) ddt name args dctors) = - DataDeclaration sa ddt name args <$> traverse (sndM (traverse (sndM (goType' ss)))) dctors + DataDeclaration sa ddt name args + <$> traverse (traverseDataCtorFields (traverse (sndM (goType' ss)))) dctors goDecl (ExternDeclaration sa@(ss, _) name ty) = ExternDeclaration sa name <$> goType' ss ty goDecl (TypeClassDeclaration sa@(ss, _) name args implies deps decls) = do diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index fa10eb6693..82e11a732e 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -205,7 +205,7 @@ deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do tyCon <- findTypeDecl ss tyConNm ds go tyCon where - go (DataDeclaration _ Newtype _ tyArgNames [(_, [(_, wrapped)])]) = do + go (DataDeclaration _ Newtype _ tyArgNames [(DataConstructorDeclaration _ _ [(_, wrapped)])]) = do -- The newtype might not be applied to all type arguments. -- This is okay as long as the newtype wraps something which ends with -- sufficiently many type applications to variables. @@ -337,9 +337,9 @@ deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do compN n f = f . compN (n - 1) f makeInst - :: (ProperName 'ConstructorName, [(Ident, SourceType)]) + :: DataConstructorDeclaration -> m (SourceType, CaseAlternative, CaseAlternative) - makeInst (ctorName, args) = do + makeInst (DataConstructorDeclaration _ ctorName args) = do args' <- mapM (replaceAllTypeSynonymsM syns . snd) args (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args' return ( srcTypeApp (srcTypeApp (srcTypeConstructor constructor) @@ -468,8 +468,8 @@ deriveEq ss mn syns ds tyConNm = do where catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (Literal ss (BooleanLiteral False))) - mkCtorClause :: (ProperName 'ConstructorName, [(Ident, SourceType)]) -> m CaseAlternative - mkCtorClause (ctorName, tys) = do + mkCtorClause :: DataConstructorDeclaration -> m CaseAlternative + mkCtorClause (DataConstructorDeclaration _ ctorName tys) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") tys' <- mapM (replaceAllTypeSynonymsM syns . snd) tys @@ -547,8 +547,8 @@ deriveOrd ss mn syns ds tyConNm = do ordCompare1 :: Expr -> Expr -> Expr ordCompare1 = App . App (Var ss (Qualified (Just dataOrd) (Ident C.compare1))) - mkCtorClauses :: ((ProperName 'ConstructorName, [(Ident, SourceType)]), Bool) -> m [CaseAlternative] - mkCtorClauses ((ctorName, tys), isLast) = do + mkCtorClauses :: (DataConstructorDeclaration, Bool) -> m [CaseAlternative] + mkCtorClauses ((DataConstructorDeclaration _ ctorName tys), isLast) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") tys' <- mapM (replaceAllTypeSynonymsM syns . snd) tys @@ -622,7 +622,7 @@ deriveNewtype ss mn syns ds tyConNm tyConArgs unwrappedTy = do checkNewtype name dctors wrappedIdent <- freshIdent "n" unwrappedIdent <- freshIdent "a" - let (ctorName, [(_, ty)]) = head dctors + let (DataConstructorDeclaration _ ctorName [(_, ty)]) = head dctors ty' <- replaceAllTypeSynonymsM syns ty let inst = [ ValueDecl (ss', []) (Ident "wrap") Public [] $ unguarded $ @@ -707,8 +707,8 @@ deriveFunctor ss mn syns ds tyConNm = do lam ss' f . lamCase ss' m <$> mapM (mkCtorClause iTy f) ctors mkMapFunction _ = internalError "mkMapFunction: expected DataDeclaration" - mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [(Ident, SourceType)]) -> m CaseAlternative - mkCtorClause iTyName f (ctorName, ctorTys) = do + mkCtorClause :: Text -> Ident -> DataConstructorDeclaration -> m CaseAlternative + mkCtorClause iTyName f (DataConstructorDeclaration _ ctorName ctorTys) = do idents <- replicateM (length ctorTys) (freshIdent "v") ctorTys' <- mapM (replaceAllTypeSynonymsM syns . snd) ctorTys args <- zipWithM transformArg idents ctorTys' diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index bb66bc3205..b9ae232e8f 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -12,7 +12,6 @@ module Language.PureScript.TypeChecker import Prelude.Compat import Protolude (ordNub) -import Control.Arrow (second) import Control.Monad (when, unless, void, forM) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), modify, gets) @@ -50,13 +49,14 @@ addDataType -> DataDeclType -> ProperName 'TypeName -> [(Text, Maybe SourceKind)] - -> [(ProperName 'ConstructorName, [(Ident, SourceType)])] + -> [DataConstructorDeclaration] -> SourceKind -> m () addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv - putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args (map (second (map snd)) dctors)) (types env) } - for_ dctors $ \(dctor, fields) -> + let mapDataCtor (DataConstructorDeclaration _ ctorName vars) = (ctorName, snd <$> vars) + putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args (map mapDataCtor dctors)) (types env) } + for_ dctors $ \(DataConstructorDeclaration _ dctor fields) -> warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $ addDataConstructor moduleName dtype name (map fst args) dctor fields @@ -243,7 +243,7 @@ typeCheckAll moduleName _ = traverse go warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (positionedError ss)) $ do when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args - ctorKind <- kindsOf True moduleName name args (concatMap (fmap snd . snd) dctors) + ctorKind <- kindsOf True moduleName name args (concatMap (fmap snd . dataCtorFields) dctors) let args' = args `withKinds` ctorKind addDataType moduleName dtype name args' dctors ctorKind return $ DataDeclaration sa dtype name args dctors @@ -254,7 +254,7 @@ typeCheckAll moduleName _ = traverse go bindingGroupNames = ordNub ((syns^..traverse._2) ++ (dataDecls^..traverse._3)) sss = fmap declSourceSpan tys warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames) . addHint (PositionedError sss)) $ do - (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(sa, _, name, args, dctors) -> (sa, name, args, concatMap (fmap snd . snd) dctors)) dataDecls) + (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(sa, _, name, args, dctors) -> (sa, name, args, concatMap (fmap snd . dataCtorFields) dctors)) dataDecls) for_ (zip dataDecls data_ks) $ \((_, dtype, name, args, dctors), ctorKind) -> do when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args @@ -503,9 +503,9 @@ checkNewtype :: forall m . MonadError MultipleErrors m => ProperName 'TypeName - -> [(ProperName 'ConstructorName, [(Ident, SourceType)])] + -> [DataConstructorDeclaration] -> m () -checkNewtype _ [(_, [_])] = return () +checkNewtype _ [(DataConstructorDeclaration _ _ [_])] = return () checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name -- | diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 20a625856c..e046e23061 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -28,7 +28,7 @@ synonym1 = P.TypeSynonymDeclaration ann1 (P.ProperName "Synonym1") [] P.srcREmpt class1 = P.TypeClassDeclaration ann1 (P.ProperName "Class1") [] [] [] [] class2 = P.TypeClassDeclaration ann1 (P.ProperName "Class2") [] [] [] [member1] data1 = P.DataDeclaration ann1 P.Newtype (P.ProperName "Data1") [] [] -data2 = P.DataDeclaration ann1 P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])] +data2 = P.DataDeclaration ann1 P.Data (P.ProperName "Data2") [] [P.DataConstructorDeclaration ann2 (P.ProperName "Cons1") []] valueFixity = P.ValueFixityDeclaration ann1 @@ -60,7 +60,7 @@ spec = do it "extracts a span for a data declaration" $ extractSpans data1 `shouldBe` [(IdeNamespaced IdeNSType "Data1", span1)] it "extracts spans for a data declaration and its constructors" $ - extractSpans data2 `shouldBe` [(IdeNamespaced IdeNSType "Data2", span1), (IdeNamespaced IdeNSValue "Cons1", span1)] + extractSpans data2 `shouldBe` [(IdeNamespaced IdeNSType "Data2", span1), (IdeNamespaced IdeNSValue "Cons1", span2)] it "extracts a span for a value operator fixity declaration" $ extractSpans valueFixity `shouldBe` [(IdeNamespaced IdeNSValue "<$>", span1)] it "extracts a span for a type operator fixity declaration" $ diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 07a0c5219c..2ccfea318f 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -14,7 +14,7 @@ import Data.List (findIndex) import Data.Foldable import Safe (headMay) import qualified Data.Map as Map -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, isNothing, mapMaybe) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T @@ -129,6 +129,16 @@ data DocsAssertion -- | Assert that a documented declaration includes a documentation comment -- containing a particular string | ShouldHaveDocComment P.ModuleName Text Text + -- | Assert that a documented data declaration includes a documentation comment + -- | containing a particular string + | ShouldHaveDataConstructorDocComment P.ModuleName Text Text Text + -- | Assert that a documented data declaration has no documentation comment + | ShouldHaveNoDataConstructorDocComment P.ModuleName Text Text + -- | Assert that a documented class method includes a documentation comment + -- | containing a particular string + | ShouldHaveClassMethodDocComment P.ModuleName Text Text Text + -- | Assert that a class method has no documentation comment + | ShouldNotHaveClassMethodDocComment P.ModuleName Text Text -- | Assert that there should be some declarations re-exported from a -- particular module in a particular package. | ShouldHaveReExport (Docs.InPackage P.ModuleName) @@ -173,6 +183,18 @@ displayAssertion = \case ShouldHaveDocComment mn decl excerpt -> "the string " <> T.pack (show excerpt) <> " should appear in the" <> " doc-comments for " <> showQual mn decl + ShouldHaveDataConstructorDocComment mn decl constr excerpt -> + "the string " <> T.pack (show excerpt) <> " should appear in the" <> + " doc-comments for data constructor " <> T.pack (show constr) <> " for " <> showQual mn decl + ShouldHaveNoDataConstructorDocComment mn decl constr -> + "Doc-comments for data constructor " <> T.pack (show constr) <> " for " <> showQual mn decl <> + " should be empty" + ShouldHaveClassMethodDocComment mn decl method excerpt -> + "the string " <> T.pack (show excerpt) <> " should appear in the" <> + " doc-comment for class method " <> T.pack (show method) <> " for " <> showQual mn decl + ShouldNotHaveClassMethodDocComment mn decl method -> + "Doc-comments for class method " <> T.pack (show method) <> " for " <> showQual mn decl <> + " should be empty" ShouldHaveReExport inPkg -> "there should be some re-exports from " <> showInPkg P.runModuleName inPkg @@ -217,6 +239,9 @@ data DocsAssertionFailure -- | A doc comment was not found or did not match what was expected -- Fields: module name, declaration, actual comments | DocCommentMissing P.ModuleName Text (Maybe Text) + -- | A doc comment was found where none was expected + -- Fields: module name, declaration, actual comments + | DocCommentPresent P.ModuleName Text (Maybe Text) -- | A module was missing re-exports from a particular module. -- Fields: module name, expected re-export, actual re-exports. | ReExportMissing P.ModuleName (Docs.InPackage P.ModuleName) [Docs.InPackage P.ModuleName] @@ -267,6 +292,8 @@ displayAssertionFailure = \case DocCommentMissing _ decl actual -> "the doc-comment for " <> decl <> " did not contain the expected substring;" <> " got " <> T.pack (show actual) + DocCommentPresent _ decl actual -> + "the doc-comment for " <> decl <> " was not empty. Got " <> T.pack (show actual) ReExportMissing _ expected actuals -> "expected to see some re-exports from " <> showInPkg P.runModuleName expected <> @@ -402,6 +429,18 @@ runAssertion assertion linksCtx Docs.Module{..} = then Pass else Fail (DocCommentMissing mn decl declComments) + ShouldHaveDataConstructorDocComment mn decl constr expected -> + findDeclChildrenComment mn decl constr expected + + ShouldHaveNoDataConstructorDocComment mn decl constr -> + findDeclChildrenNoComment mn decl constr + + ShouldHaveClassMethodDocComment mn decl constr expected -> + findDeclChildrenComment mn decl constr expected + + ShouldNotHaveClassMethodDocComment mn decl method -> + findDeclChildrenNoComment mn decl method + ShouldHaveReExport reExp -> let reExps = map fst modReExports @@ -456,6 +495,26 @@ runAssertion assertion linksCtx Docs.Module{..} = Just decl -> f decl + findDeclChildren mn title child f = + findDecl mn title $ \Docs.Declaration{..} -> + case find ((==) child . Docs.cdeclTitle) declChildren of + Nothing -> + Fail (NotDocumented mn child) + Just decl -> + f decl + + findDeclChildrenComment mn decl constr expected = + findDeclChildren mn decl constr $ \Docs.ChildDeclaration{..} -> + if maybe False (expected `T.isInfixOf`) cdeclComments + then Pass + else Fail (DocCommentMissing mn constr cdeclComments) + + findDeclChildrenNoComment mn decl constr = + findDeclChildren mn decl constr $ \Docs.ChildDeclaration{..} -> + if isNothing cdeclComments + then Pass + else Fail (DocCommentPresent mn constr cdeclComments) + childrenTitles = map Docs.cdeclTitle . Docs.declChildren extract :: Docs.RenderedCode -> Docs.Namespace -> Text -> Maybe Docs.DocLink @@ -608,6 +667,19 @@ testCases = [ ShouldHaveDocComment (n "DocComments") "example" " example == 0" ]) + , ("DocCommentsDataConstructor", + [ ShouldHaveDataConstructorDocComment (n "DocCommentsDataConstructor") "Foo" "Bar" "data constructor comment" + , ShouldHaveNoDataConstructorDocComment (n "DocCommentsDataConstructor") "Foo" "Baz" + , ShouldHaveNoDataConstructorDocComment (n "DocCommentsDataConstructor") "ComplexFoo" "ComplexBar" + , ShouldHaveDataConstructorDocComment (n "DocCommentsDataConstructor") "ComplexFoo" "ComplexBaz" "another data constructor comment" + , ShouldHaveDataConstructorDocComment (n "DocCommentsDataConstructor") "NewtypeFoo" "NewtypeFoo" "newtype data constructor comment" + ]) + + , ("DocCommentsClassMethod", + [ ShouldHaveClassMethodDocComment (n "DocCommentsClassMethod") "Foo" "bar" "class method comment" + , ShouldNotHaveClassMethodDocComment (n "DocCommentsClassMethod") "Foo" "baz" + ]) + , ("TypeLevelString", [ ShouldBeDocumented (n "TypeLevelString") "Foo" ["fooBar"] ]) diff --git a/tests/purs/docs/src/DocCommentsClassMethod.purs b/tests/purs/docs/src/DocCommentsClassMethod.purs new file mode 100644 index 0000000000..99d1375628 --- /dev/null +++ b/tests/purs/docs/src/DocCommentsClassMethod.purs @@ -0,0 +1,6 @@ +module DocCommentsClassMethod where + +class Foo a where + -- | class method comment + bar :: a + baz :: String -> a diff --git a/tests/purs/docs/src/DocCommentsDataConstructor.purs b/tests/purs/docs/src/DocCommentsDataConstructor.purs new file mode 100644 index 0000000000..34823bccc4 --- /dev/null +++ b/tests/purs/docs/src/DocCommentsDataConstructor.purs @@ -0,0 +1,15 @@ +module DocCommentsDataConstructor where + +data Foo + -- | data constructor comment + = Bar + | Baz + +data ComplexFoo a b + = ComplexBar a + -- | another data constructor comment + | ComplexBaz a b + +newtype NewtypeFoo + -- | newtype data constructor comment + = NewtypeFoo { newtypeBar :: String } From c2c5f509ba3438b902f7774220b6eb3e73e8354d Mon Sep 17 00:00:00 2001 From: Dario Oddenino Date: Mon, 22 Jul 2019 12:45:23 +0200 Subject: [PATCH 1143/1580] row diffs on errors and hints (#3477) --- src/Language/PureScript/Errors.hs | 53 +++++++++++++------- src/Language/PureScript/Pretty/Types.hs | 25 ++++++--- src/Language/PureScript/TypeChecker/Unify.hs | 3 +- 3 files changed, 56 insertions(+), 25 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 08bee197e6..cb4f460952 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -616,26 +616,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , markCodeBox $ indent $ typeAsBox prettyDepth ty ] renderSimpleErrorMessage (TypesDoNotUnify u1 u2) - = let (sorted1, sorted2) = sortRows u1 u2 - - sortRows :: Ord a => Type a -> Type a -> (Type a, Type a) - sortRows r1@RCons{} r2@RCons{} = sortRows' (rowToList r1) (rowToList r2) - sortRows t1 t2 = (t1, t2) - - -- Put the common labels last - sortRows' :: Ord a => ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Type a, Type a) - sortRows' (s1, r1) (s2, r2) = - let elem' s (RowListItem _ name ty) = any (\(RowListItem _ name' ty') -> name == name' && eqType ty ty') s - sort' = sortBy (comparing $ \(RowListItem _ name ty) -> (name, ty)) - (common1, unique1) = partition (elem' s2) s1 - (common2, unique2) = partition (elem' s1) s2 - in ( rowFromList (sort' unique1 ++ sort' common1, r1) - , rowFromList (sort' unique2 ++ sort' common2, r2) - ) + = let (row1Box, row2Box) = printRows u1 u2 + in paras [ line "Could not match type" - , markCodeBox $ indent $ typeAsBox prettyDepth sorted1 + , row1Box , line "with type" - , markCodeBox $ indent $ typeAsBox prettyDepth sorted2 + , row2Box ] renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = @@ -1062,6 +1048,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderHint :: ErrorMessageHint -> Box.Box -> Box.Box + renderHint (ErrorUnifyingTypes t1@RCons{} t2@RCons{}) detail = + let (row1Box, row2Box) = printRows t1 t2 + in paras [ detail + , Box.hsep 1 Box.top [ line "while trying to match type" + , row1Box + ] + , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "with type" + , row2Box + ] + ] renderHint (ErrorUnifyingTypes t1 t2) detail = paras [ detail , Box.hsep 1 Box.top [ line "while trying to match type" @@ -1190,6 +1186,27 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , detail ] + printRow :: (Int -> Type a -> Box.Box) -> Type a -> Box.Box + printRow f t = markCodeBox $ indent $ f prettyDepth t + + -- If both rows are not empty, print them as diffs + printRows :: Type a -> Type a -> (Box.Box, Box.Box) + printRows r1@RCons{} r2@RCons{} = let + (sorted1, sorted2) = filterRows (rowToList r1) (rowToList r2) + in (printRow typeDiffAsBox sorted1, printRow typeDiffAsBox sorted2) + printRows r1 r2 = (printRow typeAsBox r1, printRow typeAsBox r2) + + -- Keep the unique labels only + filterRows :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Type a, Type a) + filterRows (s1, r1) (s2, r2) = + let sort' = sortBy (comparing $ \(RowListItem _ name ty) -> (name, ty)) + notElem' s (RowListItem _ name ty) = all (\(RowListItem _ name' ty') -> name /= name' || not (eqType ty ty')) s + unique1 = filter (notElem' s2) s1 + unique2 = filter (notElem' s1) s2 + in ( rowFromList (sort' unique1, r1) + , rowFromList (sort' unique2, r2) + ) + renderContext :: Context -> [Box.Box] renderContext [] = [] renderContext ctx = diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index aabd707b12..0047b231ab 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -6,6 +6,7 @@ module Language.PureScript.Pretty.Types , PrettyPrintConstraint , convertPrettyPrintType , typeAsBox + , typeDiffAsBox , suggestedTypeAsBox , prettyPrintType , prettyPrintTypeWithUnicode @@ -22,7 +23,7 @@ import Control.Arrow ((<+>)) import Control.PatternArrows as PA import Data.Functor (($>)) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) import Data.Text (Text) import qualified Data.Text as T @@ -118,13 +119,13 @@ prettyPrintRowWith :: TypeRenderOptions -> Char -> Char -> [(Label, PrettyPrintT prettyPrintRowWith tro open close labels rest = case (labels, rest) of ([], Nothing) -> - text [open, close] + if troRowAsDiff tro then text [ open, ' ' ] <> text "..." <> text [ ' ', close ] else text [ open, close ] ([], Just _) -> text [ open, ' ' ] <> tailToPs rest <> text [ ' ', close ] _ -> vcat left $ zipWith (\(nm, ty) i -> nameAndTypeToPs (if i == 0 then open else ',') nm ty) labels [0 :: Int ..] ++ - [ tailToPs rest, text [close] ] + catMaybes [ rowDiff, pure $ tailToPs rest, pure $ text [close] ] where nameAndTypeToPs :: Char -> Label -> PrettyPrintType -> Box @@ -132,6 +133,8 @@ prettyPrintRowWith tro open close labels rest = doubleColon = if troUnicode tro then "∷" else "::" + rowDiff = if troRowAsDiff tro then Just (text "...") else Nothing + tailToPs :: Maybe PrettyPrintType -> Box tailToPs Nothing = nullBox tailToPs (Just other) = text "| " <> typeAsBox' other @@ -238,22 +241,32 @@ typeAsBox' = typeAsBoxImpl defaultOptions typeAsBox :: Int -> Type a -> Box typeAsBox maxDepth = typeAsBox' . convertPrettyPrintType maxDepth +typeDiffAsBox' :: PrettyPrintType -> Box +typeDiffAsBox' = typeAsBoxImpl diffOptions + +typeDiffAsBox :: Int -> Type a -> Box +typeDiffAsBox maxDepth = typeDiffAsBox' . convertPrettyPrintType maxDepth + suggestedTypeAsBox :: PrettyPrintType -> Box suggestedTypeAsBox = typeAsBoxImpl suggestingOptions data TypeRenderOptions = TypeRenderOptions { troSuggesting :: Bool , troUnicode :: Bool + , troRowAsDiff :: Bool } suggestingOptions :: TypeRenderOptions -suggestingOptions = TypeRenderOptions True False +suggestingOptions = TypeRenderOptions True False False defaultOptions :: TypeRenderOptions -defaultOptions = TypeRenderOptions False False +defaultOptions = TypeRenderOptions False False False + +diffOptions :: TypeRenderOptions +diffOptions = TypeRenderOptions False False True unicodeOptions :: TypeRenderOptions -unicodeOptions = TypeRenderOptions False True +unicodeOptions = TypeRenderOptions False True False typeAsBoxImpl :: TypeRenderOptions -> PrettyPrintType -> Box typeAsBoxImpl tro diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 65625f4b96..a9afdc6eed 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -173,7 +173,8 @@ unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where solveType u1 (rowFromList (sd2, rest')) solveType u2 (rowFromList (sd1, rest')) unifyTails _ _ = - throwError . errorMessage $ TypesDoNotUnify r1 r2 + withErrorMessageHint (ErrorUnifyingTypes r1 r2) $ + throwError . errorMessage $ TypesDoNotUnify r1 r2 -- | -- Replace a single type variable with a new unification variable From 05b1949b31749ca5df3a78b30dee782b3694cc01 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 27 Jul 2019 18:42:44 +0100 Subject: [PATCH 1144/1580] Refactor and simplify BuildPlan a little (#3699) Instead of having two separate MVars for build job results and errors, just have one, which contains a sum type, to indicate if and how a build job has completed with a little more clarity and safety (in the sense that this makes some invalid states unrepresentable). Additionally, rather than having two separate functions for consuming the result of a build plan, namely `collectErrors` and `collectResults`, and requiring that the first is called before the second, unify them both into `collectResults`. This will help for #3145, as for that I need the BuildPlan to be able to expose which build jobs succeeded before their errors are rethrown, so that we can store their timestamps and hashes in preparation for the next build. I haven't done any performance tests on this just yet, but I don't anticipate any drastic changes. --- src/Language/PureScript/Make.hs | 47 ++++++++-------- src/Language/PureScript/Make/BuildPlan.hs | 67 +++++++++++++---------- 2 files changed, 63 insertions(+), 51 deletions(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index f60f565b2e..f983266420 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -22,7 +22,7 @@ import Data.Function (on) import Data.Foldable (for_) import Data.List (foldl', sortBy) import qualified Data.List.NonEmpty as NEL -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T @@ -121,19 +121,22 @@ make ma@MakeActions{..} ms = do (importPrim <$> CST.resFull m) (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted) - -- Wait for all threads to complete, and collect errors. - errors <- BuildPlan.collectErrors buildPlan + -- Wait for all threads to complete, and collect results (and errors). + results <- BuildPlan.collectResults buildPlan -- All threads have completed, rethrow any caught errors. + let errors = mapMaybe buildJobFailure $ M.elems results unless (null errors) $ throwError (mconcat errors) - -- Collect all ExternsFiles - results <- BuildPlan.collectResults buildPlan - -- Here we return all the ExternsFile in the ordering of the topological sort, -- so they can be folded into an Environment. This result is used in the tests -- and in PSCI. - let lookupResult mn = fromMaybe (internalError "make: module not found in results") (M.lookup mn results) + let lookupResult mn = + snd + . fromMaybe (internalError "make: module's build job did not succeed") + . buildJobSuccess + . fromMaybe (internalError "make: module not found in results") + $ M.lookup mn results return (map (lookupResult . getModuleName . CST.resPartial) sorted) where @@ -168,21 +171,21 @@ make ma@MakeActions{..} ms = do inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys buildModule :: BuildPlan -> ModuleName -> FilePath -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m () - buildModule buildPlan moduleName fp mres deps = flip catchError (complete Nothing . Just) $ do - m <- CST.unwrapParserError fp mres - -- We need to wait for dependencies to be built, before checking if the current - -- module should be rebuilt, so the first thing to do is to wait on the - -- MVars for the module's dependencies. - mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps - - case mexterns of - Just (_, externs) -> do - (exts, warnings) <- listen $ rebuildModule ma externs m - complete (Just (warnings, exts)) Nothing - Nothing -> complete Nothing Nothing - where - complete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m () - complete = BuildPlan.markComplete buildPlan moduleName + buildModule buildPlan moduleName fp mres deps = do + result <- flip catchError (return . BuildJobFailed) $ do + m <- CST.unwrapParserError fp mres + -- We need to wait for dependencies to be built, before checking if the current + -- module should be rebuilt, so the first thing to do is to wait on the + -- MVars for the module's dependencies. + mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps + + case mexterns of + Just (_, externs) -> do + (exts, warnings) <- listen $ rebuildModule ma externs m + return $ BuildJobSucceeded warnings exts + Nothing -> return BuildJobSkipped + + BuildPlan.markComplete buildPlan moduleName result -- | Infer the module name for a module by looking for the same filename with -- a .js extension. diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 7f728f2c52..7e4d81e613 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -1,8 +1,10 @@ module Language.PureScript.Make.BuildPlan ( BuildPlan() + , BuildJobResult(..) + , buildJobSuccess + , buildJobFailure , construct , getResult - , collectErrors , collectResults , markComplete , needsRebuild @@ -40,50 +42,56 @@ data Prebuilt = Prebuilt , pbExternsFile :: ExternsFile } -data BuildJob = BuildJob - { bjResult :: C.MVar (Maybe (MultipleErrors, ExternsFile)) - , bjErrors :: C.MVar (Maybe MultipleErrors) +newtype BuildJob = BuildJob + { bjResult :: C.MVar BuildJobResult + -- ^ Note: an empty MVar indicates that the build job has not yet finished. } +data BuildJobResult + = BuildJobSucceeded !MultipleErrors !ExternsFile + -- ^ Succeeded, with warnings and externs + -- + | BuildJobFailed !MultipleErrors + -- ^ Failed, with errors + + | BuildJobSkipped + -- ^ The build job was not run, because an upstream build job failed + +buildJobSuccess :: BuildJobResult -> Maybe (MultipleErrors, ExternsFile) +buildJobSuccess (BuildJobSucceeded warnings externs) = Just (warnings, externs) +buildJobSuccess _ = Nothing + +buildJobFailure :: BuildJobResult -> Maybe MultipleErrors +buildJobFailure (BuildJobFailed errors) = Just errors +buildJobFailure _ = Nothing + -- | Called when we finished compiling a module and want to report back the -- compilation result, as well as any potential errors that were thrown. markComplete :: (MonadBaseControl IO m) => BuildPlan -> ModuleName - -> Maybe (MultipleErrors, ExternsFile) - -> Maybe MultipleErrors + -> BuildJobResult -> m () -markComplete buildPlan moduleName result errors = do - let BuildJob rVar eVar = fromMaybe (internalError "make: markComplete no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) +markComplete buildPlan moduleName result = do + let BuildJob rVar = fromMaybe (internalError "make: markComplete no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) putMVar rVar result - putMVar eVar errors -- | Whether or not the module with the given ModuleName needs to be rebuilt needsRebuild :: BuildPlan -> ModuleName -> Bool needsRebuild bp moduleName = M.member moduleName (bpBuildJobs bp) --- | Collects errors for all modules that have been rebuilt. This will block --- until all outstanding build jobs are finished. -collectErrors - :: (MonadBaseControl IO m) - => BuildPlan - -> m [MultipleErrors] -collectErrors buildPlan = do - errors <- traverse readMVar $ map bjErrors $ M.elems (bpBuildJobs buildPlan) - pure (catMaybes errors) - --- | Collects ExternsFiles for all prebuilt as well as rebuilt modules. Panics --- if any build job returned an error. +-- | Collects results for all prebuilt as well as rebuilt modules. This will +-- block until all build jobs are finished. Prebuilt modules always return no +-- warnings. collectResults :: (MonadBaseControl IO m) => BuildPlan - -> m (M.Map ModuleName ExternsFile) + -> m (M.Map ModuleName BuildJobResult) collectResults buildPlan = do - let externs = M.map pbExternsFile (bpPrebuilt buildPlan) - barrierResults <- traverse (takeMVar . bjResult) $ bpBuildJobs buildPlan - let barrierExterns = M.map (snd . fromMaybe (internalError "make: externs were missing but no errors reported.")) barrierResults - pure (M.union externs barrierExterns) + let prebuiltResults = M.map (BuildJobSucceeded (MultipleErrors []) . pbExternsFile) (bpPrebuilt buildPlan) + barrierResults <- traverse (readMVar . bjResult) $ bpBuildJobs buildPlan + pure (M.union prebuiltResults barrierResults) -- | Gets the the build result for a given module name independent of whether it -- was rebuilt or prebuilt. Prebuilt modules always return no warnings. @@ -96,8 +104,9 @@ getResult buildPlan moduleName = case M.lookup moduleName (bpPrebuilt buildPlan) of Just es -> pure (Just (MultipleErrors [], pbExternsFile es)) - Nothing -> - readMVar $ bjResult $ fromMaybe (internalError "make: no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) + Nothing -> do + r <- readMVar $ bjResult $ fromMaybe (internalError "make: no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) + pure $ buildJobSuccess r -- | Constructs a BuildPlan for the given module graph. -- @@ -115,7 +124,7 @@ construct MakeActions{..} (sorted, graph) = do pure $ BuildPlan prebuilt buildJobs where makeBuildJob prev moduleName = do - buildJob <- BuildJob <$> C.newEmptyMVar <*> C.newEmptyMVar + buildJob <- BuildJob <$> C.newEmptyMVar pure (M.insert moduleName buildJob prev) findExistingExtern :: CST.PartialResult Module -> m (Maybe (ModuleName, Bool, Prebuilt)) From ed8e661b499dd57cd55e408d17335f7c3b338f56 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 8 Aug 2019 16:21:41 -0700 Subject: [PATCH 1145/1580] Fix parsing of comma-separated guards in let statements (#3713) --- src/Language/PureScript/CST/Layout.hs | 9 +++++--- tests/purs/layout/LetGuards.out | 30 +++++++++++++++++++++++++++ tests/purs/layout/LetGuards.purs | 29 ++++++++++++++++++++++++++ 3 files changed, 65 insertions(+), 3 deletions(-) create mode 100644 tests/purs/layout/LetGuards.out create mode 100644 tests/purs/layout/LetGuards.purs diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs index 2785e06604..39b38fb54e 100644 --- a/src/Language/PureScript/CST/Layout.hs +++ b/src/Language/PureScript/CST/Layout.hs @@ -238,9 +238,10 @@ insertLayout src@(SourceToken tokAnn tok) nextPos stack = _ -> state & insertDefault where - equalsP _ LytWhere = True - equalsP _ LytLet = True - equalsP _ _ = False + equalsP _ LytWhere = True + equalsP _ LytLet = True + equalsP _ LytLetStmt = True + equalsP _ _ = False -- Guards need masking because of commas. TokPipe -> @@ -249,6 +250,8 @@ insertLayout src@(SourceToken tokAnn tok) nextPos stack = state' & pushStack tokPos LytCaseGuard & insertToken src state'@((_, LytLet) : _, _) -> state' & pushStack tokPos LytDeclGuard & insertToken src + state'@((_, LytLetStmt) : _, _) -> + state' & pushStack tokPos LytDeclGuard & insertToken src state'@((_, LytWhere) : _, _) -> state' & pushStack tokPos LytDeclGuard & insertToken src _ -> diff --git a/tests/purs/layout/LetGuards.out b/tests/purs/layout/LetGuards.out new file mode 100644 index 0000000000..9c01aeb0ee --- /dev/null +++ b/tests/purs/layout/LetGuards.out @@ -0,0 +1,30 @@ +module Test where{ + +test = + let{ + foo + | bar + , baz = + 42 + | otherwise = 100} + in + foo; + +test = do{ + let{ + foo + | bar + , baz = + 42 + | otherwise = 100}; + foo}; + +test = ado{ + let{ + foo + | bar + , baz = + 42 + | otherwise = 100}; + foo}} + \ No newline at end of file diff --git a/tests/purs/layout/LetGuards.purs b/tests/purs/layout/LetGuards.purs new file mode 100644 index 0000000000..8555a75e81 --- /dev/null +++ b/tests/purs/layout/LetGuards.purs @@ -0,0 +1,29 @@ +module Test where + +test = + let + foo + | bar + , baz = + 42 + | otherwise = 100 + in + foo + +test = do + let + foo + | bar + , baz = + 42 + | otherwise = 100 + foo + +test = ado + let + foo + | bar + , baz = + 42 + | otherwise = 100 + foo From 19824d0c907a79239881e4083bd98a04587ba8b8 Mon Sep 17 00:00:00 2001 From: Alexander Tesfamichael Date: Sun, 18 Aug 2019 14:34:32 +0200 Subject: [PATCH 1146/1580] Update link to moved resource (#3717) Updates the link previously pointing to a guide on dealing with the Partial type class to point at the docs for purescript-partial where the resource moved. --- src/Language/PureScript/Docs/Prim.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 6fc925314e..3fabafa12a 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -348,7 +348,7 @@ partial = primClass "Partial" $ T.unlines , "a partial function with a bad input will usually cause an error to be" , "thrown, although it is not safe to assume that this will happen in all" , "cases. For more information, see" - , "[the Partial type class guide](https://github.com/purescript/documentation/blob/master/guides/The-Partial-type-class.md)." + , "[purescript-partial](https://pursuit.purescript.org/packages/purescript-partial/)." ] kindBoolean :: Declaration From b3ac96c21a25f31d92a00d1787bb7fe6d8ebf130 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 18 Aug 2019 14:09:05 +0100 Subject: [PATCH 1147/1580] v0.13.3 --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index b5b9f64126..86db18ca44 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.13.2' +version: '0.13.3' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 5d746e92b36e2440b84cbcc5719590cca0cc43d7 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 19 Aug 2019 11:59:54 +0100 Subject: [PATCH 1148/1580] Update the npm package for 0.13.3 (#3719) --- npm-package/package.json | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/npm-package/package.json b/npm-package/package.json index bb1e7d2dee..724e264122 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.13.2", + "version": "0.13.3", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.13.2", + "postinstall": "install-purescript --purs-ver=0.13.3", "test": "echo 'Error: no test specified' && exit 1" } } From 86e646d7d015e931d4ecc5eee969bd0cabc2387a Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 19 Aug 2019 12:00:13 +0100 Subject: [PATCH 1149/1580] Add Makefile command to run license generator (#3718) --- Makefile | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 8316136b5f..43da7cc048 100644 --- a/Makefile +++ b/Makefile @@ -56,4 +56,8 @@ bench: ## Run benchmarks for PureScript dev-deps: ## Install helpful development tools. stack install ghcid ghc-prof-aeson-flamegraph -.PHONY : build build-dirty run install ghci test test-ghci test-profiling ghcid dev-deps +license-generator: ## Update dependencies in LICENSE + $(stack) ls dependencies --flag purescript:RELEASE | stack license-generator/generate.hs > LICENSE + + +.PHONY : build build-dirty run install ghci test test-ghci test-profiling ghcid dev-deps license-generator From 2bf5ef73bfd8320db35267703d8f70e6de5de350 Mon Sep 17 00:00:00 2001 From: Matthew Hilty Date: Sun, 25 Aug 2019 11:39:36 -0400 Subject: [PATCH 1150/1580] Fix #3558 (#3682) * Fix #3558 Use the substitution state after typechecking to update the dicts in an expr before typeclass resolution. * Amend definition of 'updateContextsInExpr' per suggestions. * Refactor the 'overTypes' traversal per suggestion. --- src/Language/PureScript/AST/Traversals.hs | 11 ++++++- src/Language/PureScript/TypeChecker/Types.hs | 1 + .../3558-UpToDateDictsForHigherOrderFns.purs | 33 +++++++++++++++++++ 3 files changed, 44 insertions(+), 1 deletion(-) create mode 100644 tests/purs/passing/3558-UpToDateDictsForHigherOrderFns.purs diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 70543f8621..4aaeeecad7 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -11,6 +11,7 @@ import Data.Foldable (fold) import Data.List (mapAccumL) import Data.Maybe (mapMaybe) import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as M import qualified Data.Set as S import Language.PureScript.AST.Binders @@ -19,6 +20,7 @@ import Language.PureScript.AST.Literals import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Traversals +import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..)) import Language.PureScript.Types guardedExprM :: Applicative m @@ -693,5 +695,12 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' where g :: Expr -> Expr g (TypedValue checkTy val t) = TypedValue checkTy val (f t) - g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (fmap f) c) sco hints + g (TypeClassDictionary c sco hints) = + TypeClassDictionary + (mapConstraintArgs (fmap f) c) + (updateCtx sco) + hints g other = other + updateDict fn dict = dict { tcdInstanceTypes = fn (tcdInstanceTypes dict) } + updateScope = fmap . fmap . fmap . fmap $ updateDict $ fmap f + updateCtx = M.alter updateScope Nothing diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index e4491359f2..b0bc93d71a 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -173,6 +173,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do constrain cs ty = foldr srcConstrainedType ty (map (\(_, _, x) -> x) cs) -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values + tidyUp ts sub = first (map (second (first (second (overTypes (substituteType sub) *** substituteType sub))))) ts isHoleError :: ErrorMessage -> Bool diff --git a/tests/purs/passing/3558-UpToDateDictsForHigherOrderFns.purs b/tests/purs/passing/3558-UpToDateDictsForHigherOrderFns.purs new file mode 100644 index 0000000000..8515fc9d76 --- /dev/null +++ b/tests/purs/passing/3558-UpToDateDictsForHigherOrderFns.purs @@ -0,0 +1,33 @@ +module Main where + +import Prelude (Unit) +import Effect (Effect) +import Effect.Console (log) +import Record.Unsafe (unsafeGet) +import Type.Data.Symbol (class IsSymbol, SProxy, reflectSymbol) +import Type.Row (class Cons) as Row + +newtype LBox row a = LBox (∀ r. (∀ lbl _1. Row.Cons lbl a _1 row ⇒ IsSymbol lbl ⇒ SProxy lbl → r) → r) + +unLBox ∷ ∀ row a r. (∀ lbl _1. Row.Cons lbl a _1 row ⇒ IsSymbol lbl ⇒ SProxy lbl → r) → LBox row a → r +unLBox g (LBox f) = f g + +-- Example 1 +lboxIdentity ∷ ∀ row a. LBox row a → LBox row a +lboxIdentity = unLBox \lbl → LBox \f → f lbl + +-- Example 2 +read ∷ ∀ row a. Record row → LBox row a → a +read rec = unLBox \lbl → get lbl rec + +get + :: forall r r' l a + . IsSymbol l + => Row.Cons l a r' r + => SProxy l + -> Record r + -> a +get l r = unsafeGet (reflectSymbol l) r + +main :: Effect Unit +main = log "Done" From 8a14cc0f23a6e749c852dd202df91edb2cd8df08 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 27 Aug 2019 17:20:15 +0100 Subject: [PATCH 1151/1580] Improved build cache invalidation with content hashes (#3705) Fixes #3145. The current build cache invalidation algorithm compares the input timestamps to the output timestamps, and only triggers a rebuild if the input timestamps are newer than the output timestamps. However, this does not appear to be sufficient: as discussed in #3145, we think that the reason that doing `rm -r output` often fixes weird compile errors is that we should really be considering the input file to have changed if its timestamp is _different_ to what it was at the last successful build, regardless of whether it is before or after the output timestamp. Essentially, timestamps on input files can't be trusted to the extent that we do for cache invalidation, because of things like switching between different versions of dependencies or switching branches; sometimes you can have an input file's contents and timestamp both change, but have the timestamp still be older than the output timestamp. This commit implements a slightly different cache invalidation algorithm, where we make a note of the timestamps of all input files at the start of each build, and we consider files to have changed in subsequent builds if their input timestamps have changed at all (regardless of whether the new input timestamps are before or after the output timestamps). The timestamps are stored in a json file `cache-db.json` in the output directory; I also considered putting the timestamps in the externs files, but I think having them stored separately is preferable because then we don't have to update the module's externs file if its input file timestamp changes but its hash doesn't, which means that we don't force a rebuild for downstream modules. As an additional enhancement, we also make note of file content hashes and store them in the `cache-db.json` file. On subsequent builds, if timestamps have changed, we compare the previous hash to the new hash, and if they are identical, we can skip rebuilding the module. This means that e.g. touching a file no longer forces a rebuild. Note that we only compute hashes in the case where timestamps differ to avoid doing extra unnecessary work. This scheme of checking timestamps and then hashes was inspired by Shake, which provides this mechanism as one of its options for Change; see https://github.com/purescript/purescript/issues/3145#issuecomment-491639339 I've also added some tests so that we can make changes to this part of the compiler a little more confidently. I'm using the latest version of `these` (which is not in our Stack snapshot) because it doesn't incur a `lens` dependency, whereas earlier versions do. --- .gitignore | 1 + LICENSE | 256 ++++++++++++++++++++++ package.yaml | 7 + src/Language/PureScript/Make.hs | 34 ++- src/Language/PureScript/Make/Actions.hs | 79 +++++-- src/Language/PureScript/Make/BuildPlan.hs | 93 ++++++-- src/Language/PureScript/Make/Cache.hs | 130 +++++++++++ src/Language/PureScript/Names.hs | 7 + stack.yaml | 5 + tests/Main.hs | 3 + tests/TestMake.hs | 216 ++++++++++++++++++ tests/TestUtils.hs | 6 +- 12 files changed, 783 insertions(+), 54 deletions(-) create mode 100644 src/Language/PureScript/Make/Cache.hs create mode 100644 tests/TestMake.hs diff --git a/.gitignore b/.gitignore index 56c18312d4..2c6f7ff578 100644 --- a/.gitignore +++ b/.gitignore @@ -32,3 +32,4 @@ TAGS *.prof *.ps *.svg +tests/purs/make/ diff --git a/LICENSE b/LICENSE index 65cfa9e9b1..362b1f16a5 100644 --- a/LICENSE +++ b/LICENSE @@ -17,6 +17,7 @@ PureScript uses the following Haskell library packages. Their license files foll Cabal Glob SHA + StateVar aeson aeson-better-errors aeson-pretty @@ -33,6 +34,7 @@ PureScript uses the following Haskell library packages. Their license files foll base-orphans base64-bytestring basement + bifunctors binary blaze-builder blaze-html @@ -48,10 +50,12 @@ PureScript uses the following Haskell library packages. Their license files foll cheapskate clock colour + comonad conduit conduit-extra constraints containers + contravariant cookie cryptonite css-text @@ -63,6 +67,7 @@ PureScript uses the following Haskell library packages. Their license files foll data-ordlist deepseq directory + distributive dlist easy-file edit-distance @@ -121,6 +126,8 @@ PureScript uses the following Haskell library packages. Their license files foll resourcet safe scientific + semialign + semigroupoids semigroups shelly simple-sendfile @@ -139,6 +146,7 @@ PureScript uses the following Haskell library packages. Their license files foll terminfo text th-abstraction + these time time-locale-compat transformers @@ -265,6 +273,38 @@ SHA LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +StateVar LICENSE file: + + Copyright (c) 2014-2015, Edward Kmett + Copyright (c) 2009-2018, Sven Panne + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + aeson LICENSE file: Copyright (c) 2011, MailRank, Inc. @@ -842,6 +882,35 @@ basement LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +bifunctors LICENSE file: + + Copyright 2008-2016 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + binary LICENSE file: Copyright (c) Lennart Kolmodin @@ -1317,6 +1386,36 @@ colour LICENSE file: OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +comonad LICENSE file: + + Copyright 2008-2014 Edward Kmett + Copyright 2004-2008 Dave Menendez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + conduit LICENSE file: Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ @@ -1426,6 +1525,39 @@ containers LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +contravariant LICENSE file: + + Copyright 2007-2015 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + cookie LICENSE file: Copyright (c) 2010 Michael Snoyman, http://www.yesodweb.com/ @@ -1769,6 +1901,35 @@ directory LICENSE file: ----------------------------------------------------------------------------- +distributive LICENSE file: + + Copyright 2011-2016 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + dlist LICENSE file: Copyright (c) 2006-2009 Don Stewart, 2013-2016 Sean Leather @@ -3695,6 +3856,68 @@ scientific LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +semialign LICENSE file: + + Copyright (c) 2012, C. McCann, 2015-2019 Oleg Grenrus + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of C. McCann nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +semigroupoids LICENSE file: + + Copyright 2011-2015 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + semigroups LICENSE file: Copyright 2011-2015 Edward Kmett @@ -4290,6 +4513,39 @@ th-abstraction LICENSE file: TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +these LICENSE file: + + Copyright (c) 2012, C. McCann, 2015-2019 Oleg Grenrus + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of C. McCann nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + time LICENSE file: TimeLib is Copyright (c) Ashley Yakeley, 2004-2014. All rights reserved. diff --git a/package.yaml b/package.yaml index 86db18ca44..67d1dc7ee1 100644 --- a/package.yaml +++ b/package.yaml @@ -52,6 +52,7 @@ dependencies: - cheapskate >=0.1 && <0.2 - clock - containers + - cryptonite >=0.25 - data-ordlist >=0.4.7.0 - deepseq - directory >=1.2.3 @@ -65,6 +66,7 @@ dependencies: - language-javascript >=0.6.0.13 - lifted-async >=0.10.0.3 && <0.10.1 - lifted-base >=0.2.3 && <0.2.4 + - memory >=0.14 && <0.15 - microlens-platform >=0.3.9.0 && <0.4 - monad-control >=1.0.0.0 && <1.1 - monad-logger >=0.3 && <0.4 @@ -78,12 +80,14 @@ dependencies: - safe >=0.3.9 && <0.4 - scientific >=0.3.4.9 && <0.4 - semigroups >=0.16.2 && <0.19 + - semialign >=1 && <1.1 - sourcemap >=0.1.6 - split - stm >=0.2.4.0 - stringsearch - syb - text + - these >= 1 && <1.1 - time - transformers >=0.3.0 && <0.6 - transformers-base >=0.4.0 && <0.5 @@ -105,6 +109,7 @@ library: - DeriveFoldable - DeriveTraversable - DeriveGeneric + - DerivingStrategies - EmptyDataDecls - FlexibleContexts - KindSignatures @@ -173,6 +178,8 @@ tests: - HUnit default-extensions: - NoImplicitPrelude + - LambdaCase + - OverloadedStrings flags: release: diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index f983266420..3008930d02 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -22,7 +22,7 @@ import Data.Function (on) import Data.Foldable (for_) import Data.List (foldl', sortBy) import qualified Data.List.NonEmpty as NEL -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T @@ -41,6 +41,7 @@ import Language.PureScript.Sugar import Language.PureScript.TypeChecker import Language.PureScript.Make.BuildPlan import qualified Language.PureScript.Make.BuildPlan as BuildPlan +import qualified Language.PureScript.Make.Cache as Cache import Language.PureScript.Make.Actions as Actions import Language.PureScript.Make.Monad as Monad import qualified Language.PureScript.CoreFn as CF @@ -99,18 +100,19 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.json@ file. -- --- If timestamps have not changed, the externs file can be used to provide the module's types without --- having to typecheck the module again. +-- If timestamps or hashes have not changed, existing externs files can be used to provide upstream modules' types without +-- having to typecheck those modules again. make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [CST.PartialResult Module] -> m [ExternsFile] make ma@MakeActions{..} ms = do checkModuleNames + cacheDb <- readCacheDb (sorted, graph) <- sortModules (moduleSignature . CST.resPartial) ms - buildPlan <- BuildPlan.construct ma (sorted, graph) + (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph) let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted for_ toBeRebuilt $ \m -> fork $ do @@ -122,21 +124,31 @@ make ma@MakeActions{..} ms = do (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted) -- Wait for all threads to complete, and collect results (and errors). - results <- BuildPlan.collectResults buildPlan + (failures, successes) <- + let + splitResults = \case + BuildJobSucceeded _ exts -> + Right exts + BuildJobFailed errs -> + Left errs + BuildJobSkipped -> + Left mempty + in + M.mapEither splitResults <$> BuildPlan.collectResults buildPlan + + -- Write the updated build cache database to disk + writeCacheDb $ Cache.removeModules (M.keysSet failures) newCacheDb -- All threads have completed, rethrow any caught errors. - let errors = mapMaybe buildJobFailure $ M.elems results + let errors = M.elems failures unless (null errors) $ throwError (mconcat errors) -- Here we return all the ExternsFile in the ordering of the topological sort, -- so they can be folded into an Environment. This result is used in the tests -- and in PSCI. let lookupResult mn = - snd - . fromMaybe (internalError "make: module's build job did not succeed") - . buildJobSuccess - . fromMaybe (internalError "make: module not found in results") - $ M.lookup mn results + fromMaybe (internalError "make: module not found in results") + $ M.lookup mn successes return (map (lookupResult . getModuleName . CST.resPartial) sorted) where diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 8b54765eaf..90ec644b13 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -9,6 +9,7 @@ module Language.PureScript.Make.Actions import Prelude +import Control.Exception (tryJust) import Control.Monad hiding (sequence) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class @@ -16,7 +17,7 @@ import Control.Monad.Reader (asks) import Control.Monad.Supply import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Writer.Class (MonadWriter(..)) -import Data.Aeson (encode) +import qualified Data.Aeson as Aeson import Data.Bifunctor (bimap) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy as LB @@ -25,7 +26,7 @@ import Data.Either (partitionEithers) import Data.Foldable (for_, minimum) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, maybeToList) import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -44,6 +45,7 @@ import qualified Language.PureScript.CST as CST import qualified Language.PureScript.Docs.Types as Docs import Language.PureScript.Errors import Language.PureScript.Make.Monad +import Language.PureScript.Make.Cache import Language.PureScript.Names import Language.PureScript.Names (runModuleName, ModuleName) import Language.PureScript.Options hiding (codegenTargets) @@ -53,6 +55,7 @@ import SourceMap import SourceMap.Types import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise) +import System.IO.Error (isDoesNotExistError) -- | Determines when to rebuild a module data RebuildPolicy @@ -83,10 +86,10 @@ renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModule -- -- * The details of how files are read/written etc. data MakeActions m = MakeActions - { getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime)) - -- ^ Get the timestamp for the input file(s) for a module. If there are multiple - -- files (@.purs@ and foreign files, for example) the timestamp should be for - -- the most recently modified file. + { getInputTimestampsAndHashes :: ModuleName -> m (Either RebuildPolicy (M.Map FilePath (UTCTime, m ContentHash))) + -- ^ Get the timestamps and content hashes for the input files for a module. + -- The content hash is returned as a monadic action so that the file does not + -- have to be read if it's not necessary. , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime) -- ^ Get the timestamp for the output files for a module. This should be the -- timestamp for the oldest modified file, or 'Nothing' if any of the required @@ -100,6 +103,12 @@ data MakeActions m = MakeActions -- ^ Check ffi and print it in the output directory. , progress :: ProgressMessage -> m () -- ^ Respond to a progress update. + , readCacheDb :: m CacheDb + -- ^ Read the cache database (which contains timestamps and hashes for input + -- files) from some external source, e.g. a file on disk. + , writeCacheDb :: CacheDb -> m () + -- ^ Write the given cache database to some external source (e.g. a file on + -- disk). } -- | A set of make actions that read and write modules from the given directory. @@ -114,15 +123,24 @@ buildMakeActions -- ^ Generate a prefix comment? -> MakeActions Make buildMakeActions outputDir filePathMap foreigns usePrefix = - MakeActions getInputTimestamp getOutputTimestamp readExterns codegen ffiCodegen progress + MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb where - getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime)) - getInputTimestamp mn = do + getInputTimestampsAndHashes + :: ModuleName + -> Make (Either RebuildPolicy (M.Map FilePath (UTCTime, Make ContentHash))) + getInputTimestampsAndHashes mn = do let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap - e1 <- traverse getTimestamp path - fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns - return $ fmap (max fPath) e1 + case path of + Left policy -> + return (Left policy) + Right filePath -> do + let inputPaths = filePath : maybeToList (M.lookup mn foreigns) + getInfo fp = do + ts <- getTimestamp fp >>= maybe (throwError (singleError (cannotReadFile fp))) pure + return (ts, hash <$> readTextFile fp) + pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths + return $ Right $ M.fromList pathsWithInfo outputFilename :: ModuleName -> String -> FilePath outputFilename mn fn = @@ -156,7 +174,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = when (S.member CoreFn codegenTargets) $ do let coreFnFile = targetFilename mn CoreFn json = CFJ.moduleToJSON Paths.version m - lift $ writeTextFile coreFnFile (encode json) + lift $ writeTextFile coreFnFile (Aeson.encode json) when (S.member JS codegenTargets) $ do foreignInclude <- case mn `M.lookup` foreigns of Just _ @@ -167,7 +185,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn | otherwise -> return Nothing rawJs <- J.moduleToJs m foreignInclude - dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory + dir <- lift $ makeIO (const (cannotGetFileInfo ".")) getCurrentDirectory let sourceMaps = S.member JSSourceMap codegenTargets (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, []) jsFile = targetFilename mn JS @@ -179,7 +197,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef) when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings when (S.member Docs codegenTargets) $ do - lift $ writeTextFile (outputFilename mn "docs.json") (encode docs) + lift $ writeTextFile (outputFilename mn "docs.json") (Aeson.encode docs) ffiCodegen :: CF.Module CF.Ann -> Make () ffiCodegen m = do @@ -212,7 +230,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = }) mappings } let mapping = generate rawMapping - writeTextFile mapFile (encode mapping) + writeTextFile mapFile (Aeson.encode mapping) where add :: Int -> Int -> SourcePos -> SourcePos add n m (SourcePos n' m') = SourcePos (n+n') (m+m') @@ -225,14 +243,14 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = requiresForeign = not . null . CF.moduleForeign getTimestamp :: FilePath -> Make (Maybe UTCTime) - getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do + getTimestamp path = makeIO (const (cannotReadFile path)) $ do exists <- doesFileExist path if exists then Just <$> getModificationTime path else pure Nothing writeTextFile :: FilePath -> B.ByteString -> Make () - writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do + writeTextFile path text = makeIO (const (cannotWriteFile path)) $ do mkdirp path B.writeFile path text where @@ -242,6 +260,31 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = progress :: ProgressMessage -> Make () progress = liftIO . putStrLn . renderProgressMessage + readCacheDb :: Make CacheDb + readCacheDb = do + let path = outputDir cacheDbFile + makeIO (const (cannotReadFile path)) $ do + r <- tryJust + (guard . isDoesNotExistError) + (Aeson.decodeFileStrict' path) + case r of + Left () -> + pure mempty + Right mdb -> + pure (fromMaybe mempty mdb) + + writeCacheDb :: CacheDb -> Make () + writeCacheDb db = do + let path = outputDir cacheDbFile + makeIO (const (cannotWriteFile path)) $ + Aeson.encodeFile path db + + cannotWriteFile = ErrorMessage [] . CannotWriteFile + cannotReadFile = ErrorMessage [] . CannotReadFile + cannotGetFileInfo = ErrorMessage [] . CannotGetFileInfo + + cacheDbFile = "cache-db.json" + -- | Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module. checkForeignDecls :: CF.Module ann -> FilePath -> Make () diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 7e4d81e613..ebbe50d645 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -15,12 +15,11 @@ import Prelude import Control.Concurrent.Async.Lifted as A import Control.Concurrent.Lifted as C import Control.Monad hiding (sequence) -import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.Foldable (foldl') import qualified Data.Map as M -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Time.Clock (UTCTime) import Language.PureScript.AST import Language.PureScript.Crash @@ -28,6 +27,7 @@ import qualified Language.PureScript.CST as CST import Language.PureScript.Errors import Language.PureScript.Externs import Language.PureScript.Make.Actions as Actions +import Language.PureScript.Make.Cache import Language.PureScript.Names (ModuleName) -- | The BuildPlan tracks information about our build progress, and holds all @@ -65,6 +65,20 @@ buildJobFailure :: BuildJobResult -> Maybe MultipleErrors buildJobFailure (BuildJobFailed errors) = Just errors buildJobFailure _ = Nothing +-- | Information obtained about a particular module while constructing a build +-- plan; used to decide whether a module needs rebuilding. +data RebuildStatus = RebuildStatus + { statusModuleName :: ModuleName + , statusRebuildNever :: Bool + , statusNewCacheInfo :: Maybe CacheInfo + -- ^ New cache info for this module which should be stored for subsequent + -- incremental builds. A value of Nothing indicates that cache info for + -- this module should not be stored in the build cache, because it is being + -- rebuilt according to a RebuildPolicy instead. + , statusPrebuilt :: Maybe Prebuilt + -- ^ Prebuilt externs and timestamp for this module, if any. + } + -- | Called when we finished compiling a module and want to report back the -- compilation result, as well as any potential errors that were thrown. markComplete @@ -115,32 +129,67 @@ getResult buildPlan moduleName = construct :: forall m. (Monad m, MonadBaseControl IO m) => MakeActions m + -> CacheDb -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])]) - -> m BuildPlan -construct MakeActions{..} (sorted, graph) = do - prebuilt <- foldl' collectPrebuiltModules M.empty . catMaybes <$> A.forConcurrently sorted findExistingExtern - let toBeRebuilt = filter (not . flip M.member prebuilt . getModuleName . CST.resPartial) sorted - buildJobs <- foldM makeBuildJob M.empty (map (getModuleName . CST.resPartial) toBeRebuilt) - pure $ BuildPlan prebuilt buildJobs + -> m (BuildPlan, CacheDb) +construct MakeActions{..} cacheDb (sorted, graph) = do + let sortedModuleNames = map (getModuleName . CST.resPartial) sorted + rebuildStatuses <- A.forConcurrently sortedModuleNames getRebuildStatus + let prebuilt = + foldl' collectPrebuiltModules M.empty $ + mapMaybe (\s -> (statusModuleName s, statusRebuildNever s,) <$> statusPrebuilt s) rebuildStatuses + let toBeRebuilt = filter (not . flip M.member prebuilt) sortedModuleNames + buildJobs <- foldM makeBuildJob M.empty toBeRebuilt + pure + ( BuildPlan prebuilt buildJobs + , let + update = flip $ \s -> + M.alter (const (statusNewCacheInfo s)) (statusModuleName s) + in + foldl' update cacheDb rebuildStatuses + ) where makeBuildJob prev moduleName = do buildJob <- BuildJob <$> C.newEmptyMVar pure (M.insert moduleName buildJob prev) - findExistingExtern :: CST.PartialResult Module -> m (Maybe (ModuleName, Bool, Prebuilt)) - findExistingExtern (getModuleName . CST.resPartial -> moduleName) = runMaybeT $ do - inputTimestamp <- lift $ getInputTimestamp moduleName - (rebuildNever, existingTimestamp) <- - case inputTimestamp of - Left RebuildNever -> - fmap (True,) $ MaybeT $ getOutputTimestamp moduleName - Right (Just t1) -> do - outputTimestamp <- MaybeT $ getOutputTimestamp moduleName - guard (t1 < outputTimestamp) - pure (False, outputTimestamp) - _ -> mzero - externsFile <- MaybeT $ decodeExterns . snd <$> readExterns moduleName - pure (moduleName, rebuildNever, Prebuilt existingTimestamp externsFile) + getRebuildStatus :: ModuleName -> m RebuildStatus + getRebuildStatus moduleName = do + inputInfo <- getInputTimestampsAndHashes moduleName + case inputInfo of + Left RebuildNever -> do + prebuilt <- findExistingExtern moduleName + pure (RebuildStatus + { statusModuleName = moduleName + , statusRebuildNever = True + , statusPrebuilt = prebuilt + , statusNewCacheInfo = Nothing + }) + Left RebuildAlways -> do + pure (RebuildStatus + { statusModuleName = moduleName + , statusRebuildNever = False + , statusPrebuilt = Nothing + , statusNewCacheInfo = Nothing + }) + Right cacheInfo -> do + (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cacheInfo + prebuilt <- + if isUpToDate + then findExistingExtern moduleName + else pure Nothing + pure (RebuildStatus + { statusModuleName = moduleName + , statusRebuildNever = False + , statusPrebuilt = prebuilt + , statusNewCacheInfo = Just newCacheInfo + }) + + findExistingExtern :: ModuleName -> m (Maybe Prebuilt) + findExistingExtern moduleName = runMaybeT $ do + timestamp <- MaybeT $ getOutputTimestamp moduleName + externs <- MaybeT $ decodeExterns . snd <$> readExterns moduleName + pure (Prebuilt timestamp externs) collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt collectPrebuiltModules prev (moduleName, rebuildNever, pb) diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs new file mode 100644 index 0000000000..337ee2d262 --- /dev/null +++ b/src/Language/PureScript/Make/Cache.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Language.PureScript.Make.Cache + ( ContentHash + , hash + , CacheDb + , CacheInfo + , checkChanged + , removeModules + ) where + +import Prelude + +import Control.Category ((>>>)) +import Control.Monad ((>=>)) +import Crypto.Hash (hashlazy, HashAlgorithm, Digest, SHA512, digestFromByteString) +import qualified Data.Aeson as Aeson +import Data.Align (align) +import Data.ByteArray.Encoding (Base(Base16), convertToBase, convertFromBase) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Monoid (All(..)) +import Data.Set (Set) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.These (These(..)) +import Data.Time.Clock (UTCTime) +import Data.Traversable (for) + +import Language.PureScript.Names (ModuleName) + +digestToHex :: Digest a -> Text +digestToHex = decodeUtf8 . convertToBase Base16 + +digestFromHex :: forall a. HashAlgorithm a => Text -> Maybe (Digest a) +digestFromHex = + encodeUtf8 + >>> either (const Nothing) Just . convertFromBase Base16 + >=> (digestFromByteString :: BS.ByteString -> Maybe (Digest a)) + +-- | Defines the hash algorithm we use for cache invalidation of input files. +newtype ContentHash = ContentHash + { unContentHash :: Digest SHA512 } + deriving (Show, Eq, Ord) + +instance Aeson.ToJSON ContentHash where + toJSON = Aeson.toJSON . digestToHex . unContentHash + +instance Aeson.FromJSON ContentHash where + parseJSON x = do + str <- Aeson.parseJSON x + case digestFromHex str of + Just digest -> + pure $ ContentHash digest + Nothing -> + fail "Unable to decode ContentHash" + +hash :: BSL.ByteString -> ContentHash +hash = ContentHash . hashlazy + +type CacheDb = Map ModuleName CacheInfo + +-- | A CacheInfo contains all of the information we need to store about a +-- particular module in the cache database. +newtype CacheInfo = CacheInfo + { unCacheInfo :: Map FilePath (UTCTime, ContentHash) } + deriving stock (Show) + deriving newtype (Eq, Ord, Semigroup, Monoid, Aeson.FromJSON, Aeson.ToJSON) + +-- | Given a module name, and a map containing the associated input files +-- together with current metadata i.e. timestamps and hashes, check whether the +-- input files have changed, based on comparing with the database stored in the +-- monadic state. +-- +-- The CacheInfo in the return value should be stored in the cache for future +-- builds. +-- +-- The Bool in the return value indicates whether it is safe to use existing +-- build artifacts for this module, at least based on the timestamps and hashes +-- of the module's input files. +-- +-- If the timestamps are the same as those in the database, assume the file is +-- unchanged, and return True without checking hashes. +-- +-- If any of the timestamps differ from what is in the database, check the +-- hashes of those files. In this case, update the database with any changed +-- timestamps and hashes, and return True if and only if all of the hashes are +-- unchanged. +checkChanged + :: Monad m + => CacheDb + -> ModuleName + -> Map FilePath (UTCTime, m ContentHash) + -> m (CacheInfo, Bool) +checkChanged cacheDb mn currentInfo = do + let dbInfo = unCacheInfo $ fromMaybe mempty (Map.lookup mn cacheDb) + (newInfo, isUpToDate) <- + fmap mconcat $ + for (Map.toList (align dbInfo currentInfo)) $ \(fp, aligned) -> do + case aligned of + This _ -> do + -- One of the input files listed in the cache no longer exists; + -- remove that file from the cache and note that the module needs + -- rebuilding + pure (Map.empty, All False) + That (timestamp, getHash) -> do + -- The module has a new input file; add it to the cache and + -- note that the module needs rebuilding. + newHash <- getHash + pure (Map.singleton fp (timestamp, newHash), All False) + These db@(dbTimestamp, _) (newTimestamp, _) | dbTimestamp == newTimestamp -> do + -- This file exists both currently and in the cache database, + -- and the timestamp is unchanged, so we skip checking the + -- hash. + pure (Map.singleton fp db, mempty) + These (_, dbHash) (newTimestamp, getHash) -> do + -- This file exists both currently and in the cache database, + -- but the timestamp has changed, so we need to check the hash. + newHash <- getHash + pure (Map.singleton fp (newTimestamp, newHash), All (dbHash == newHash)) + + pure (CacheInfo newInfo, getAll isUpToDate) + +-- | Remove any modules from the given set from the cache database; used when +-- they failed to build. +removeModules :: Set ModuleName -> CacheDb -> CacheDb +removeModules moduleNames = flip Map.withoutKeys moduleNames diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index e2327c1cc1..5f8afd75b2 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -12,6 +12,7 @@ import Prelude.Compat import Control.Monad.Supply.Class import Control.DeepSeq (NFData) +import Data.Functor.Contravariant (contramap) import GHC.Generics (Generic) import Data.Aeson @@ -243,3 +244,9 @@ isQualifiedWith _ _ = False $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName) + +instance ToJSONKey ModuleName where + toJSONKey = contramap runModuleName toJSONKey + +instance FromJSONKey ModuleName where + fromJSONKey = fmap moduleNameFromString fromJSONKey diff --git a/stack.yaml b/stack.yaml index 3187ac98be..380a8e0df7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,6 +6,8 @@ extra-deps: - happy-1.19.9 - language-javascript-0.6.0.13 - network-3.0.1.1 +- these-1.0.1 +- semialign-1 nix: enable: false packages: @@ -17,3 +19,6 @@ nix: flags: aeson-pretty: lib-only: true + these: + assoc: false + quickcheck: false diff --git a/tests/Main.hs b/tests/Main.hs index 37bf70b20a..3c7d5e031a 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -20,6 +20,7 @@ import qualified TestPsci import qualified TestIde import qualified TestPscPublish import qualified TestBundle +import qualified TestMake import qualified TestUtils import System.IO (hSetEncoding, stdout, stderr, utf8) @@ -35,6 +36,7 @@ main = do cstTests <- TestCst.main ideTests <- TestIde.main compilerTests <- TestCompiler.main + makeTests <- TestMake.main psciTests <- TestPsci.main pscBundleTests <- TestBundle.main coreFnTests <- TestCoreFn.main @@ -48,6 +50,7 @@ main = do "Tests" [ cstTests , compilerTests + , makeTests , psciTests , pscBundleTests , ideTests diff --git a/tests/TestMake.hs b/tests/TestMake.hs new file mode 100644 index 0000000000..dadee27fd7 --- /dev/null +++ b/tests/TestMake.hs @@ -0,0 +1,216 @@ +-- Tests for the compiler's handling of incremental builds, i.e. the code in +-- Language.PureScript.Make. + +module TestMake where + +import Prelude () +import Prelude.Compat + +import qualified Language.PureScript as P +import qualified Language.PureScript.CST as CST + +import Control.Monad +import Control.Exception (tryJust) +import Control.Monad.IO.Class (liftIO) +import Control.Concurrent.MVar (readMVar, newMVar, modifyMVar_) +import Data.Time.Calendar +import Data.Time.Clock +import qualified Data.Text as T +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Map as M + +import System.FilePath +import System.Directory +import System.IO.Error (isDoesNotExistError) +import System.IO.UTF8 (readUTF8FilesT, writeUTF8FileT) + +import Test.Tasty +import Test.Tasty.Hspec + +utcMidnightOnDate :: Integer -> Int -> Int -> UTCTime +utcMidnightOnDate day month year = UTCTime (fromGregorian day month year) (secondsToDiffTime 0) + +timestampA, timestampB, timestampC, timestampD, timestampE, timestampF :: UTCTime +timestampA = utcMidnightOnDate 2019 1 1 +timestampB = utcMidnightOnDate 2019 1 2 +timestampC = utcMidnightOnDate 2019 1 3 +timestampD = utcMidnightOnDate 2019 1 4 +timestampE = utcMidnightOnDate 2019 1 5 +timestampF = utcMidnightOnDate 2019 1 6 + +main :: IO TestTree +main = testSpec "make" spec + +spec :: Spec +spec = do + let sourcesDir = "tests/purs/make" + let moduleNames = Set.fromList . map P.moduleNameFromString + before_ (rimraf modulesDir >> rimraf sourcesDir >> createDirectory sourcesDir) $ do + it "does not recompile if there are no changes" $ do + let modulePath = sourcesDir "Module.purs" + + writeFileWithTimestamp modulePath timestampA "module Module where\nfoo = 0\n" + compile [modulePath] `shouldReturn` moduleNames ["Module"] + compile [modulePath] `shouldReturn` moduleNames [] + + it "recompiles if files have changed" $ do + let modulePath = sourcesDir "Module.purs" + + writeFileWithTimestamp modulePath timestampA "module Module where\nfoo = 0\n" + compile [modulePath] `shouldReturn` moduleNames ["Module"] + writeFileWithTimestamp modulePath timestampB "module Module where\nfoo = 1\n" + compile [modulePath] `shouldReturn` moduleNames ["Module"] + + it "does not recompile if hashes have not changed" $ do + let modulePath = sourcesDir "Module.purs" + moduleContent = "module Module where\nfoo = 0\n" + + writeFileWithTimestamp modulePath timestampA moduleContent + compile [modulePath] `shouldReturn` moduleNames ["Module"] + writeFileWithTimestamp modulePath timestampB moduleContent + compile [modulePath] `shouldReturn` moduleNames [] + + it "recompiles if the file path for a module has changed" $ do + let modulePath1 = sourcesDir "Module1.purs" + modulePath2 = sourcesDir "Module2.purs" + moduleContent = "module Module where\nfoo = 0\n" + + writeFileWithTimestamp modulePath1 timestampA moduleContent + writeFileWithTimestamp modulePath2 timestampA moduleContent + + compile [modulePath1] `shouldReturn` moduleNames ["Module"] + compile [modulePath2] `shouldReturn` moduleNames ["Module"] + + it "recompiles if an FFI file was added" $ do + let moduleBasePath = sourcesDir "Module" + modulePath = moduleBasePath ++ ".purs" + moduleFFIPath = moduleBasePath ++ ".js" + moduleContent = "module Module where\nfoo = 0\n" + + writeFileWithTimestamp modulePath timestampA moduleContent + compile [modulePath] `shouldReturn` moduleNames ["Module"] + + writeFileWithTimestamp moduleFFIPath timestampB "exports.bar = 1;\n" + compile [modulePath] `shouldReturn` moduleNames ["Module"] + + it "recompiles if an FFI file was removed" $ do + let moduleBasePath = sourcesDir "Module" + modulePath = moduleBasePath ++ ".purs" + moduleFFIPath = moduleBasePath ++ ".js" + moduleContent = "module Module where\nfoo = 0\n" + + writeFileWithTimestamp modulePath timestampA moduleContent + writeFileWithTimestamp moduleFFIPath timestampB "exports.bar = 1;\n" + compile [modulePath] `shouldReturn` moduleNames ["Module"] + + removeFile moduleFFIPath + compile [modulePath] `shouldReturn` moduleNames ["Module"] + + it "recompiles downstream modules when a module is rebuilt" $ do + let moduleAPath = sourcesDir "A.purs" + moduleBPath = sourcesDir "B.purs" + moduleAContent1 = "module A where\nfoo = 0\n" + moduleAContent2 = "module A where\nfoo = 1\n" + moduleBContent = "module B where\nimport A (foo)\nbar = foo\n" + + writeFileWithTimestamp moduleAPath timestampA moduleAContent1 + writeFileWithTimestamp moduleBPath timestampB moduleBContent + compile [moduleAPath, moduleBPath] `shouldReturn` moduleNames ["A", "B"] + + writeFileWithTimestamp moduleAPath timestampC moduleAContent2 + compile [moduleAPath, moduleBPath] `shouldReturn` moduleNames ["A", "B"] + + it "only recompiles downstream modules when a module is rebuilt" $ do + let moduleAPath = sourcesDir "A.purs" + moduleBPath = sourcesDir "B.purs" + moduleCPath = sourcesDir "C.purs" + modulePaths = [moduleAPath, moduleBPath, moduleCPath] + moduleAContent1 = "module A where\nfoo = 0\n" + moduleAContent2 = "module A where\nfoo = 1\n" + moduleBContent = "module B where\nimport A (foo)\nbar = foo\n" + moduleCContent = "module C where\nbaz = 3\n" + + writeFileWithTimestamp moduleAPath timestampA moduleAContent1 + writeFileWithTimestamp moduleBPath timestampB moduleBContent + writeFileWithTimestamp moduleCPath timestampC moduleCContent + compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] + + writeFileWithTimestamp moduleAPath timestampD moduleAContent2 + compile modulePaths `shouldReturn` moduleNames ["A", "B"] + + it "does not necessarily recompile modules which were not part of the previous batch" $ do + let moduleAPath = sourcesDir "A.purs" + moduleBPath = sourcesDir "B.purs" + moduleCPath = sourcesDir "C.purs" + modulePaths = [moduleAPath, moduleBPath, moduleCPath] + batch1 = [moduleAPath, moduleBPath] + batch2 = [moduleAPath, moduleCPath] + moduleAContent = "module A where\nfoo = 0\n" + moduleBContent = "module B where\nimport A (foo)\nbar = foo\n" + moduleCContent = "module C where\nbaz = 3\n" + + writeFileWithTimestamp moduleAPath timestampA moduleAContent + writeFileWithTimestamp moduleBPath timestampB moduleBContent + writeFileWithTimestamp moduleCPath timestampC moduleCContent + compile modulePaths `shouldReturn` moduleNames ["A", "B", "C"] + + compile batch1 `shouldReturn` moduleNames [] + compile batch2 `shouldReturn` moduleNames [] + + it "recompiles if a module fails to compile" $ do + let modulePath = sourcesDir "Module.purs" + moduleContent = "module Module where\nfoo :: Int\nfoo = \"not an int\"\n" + + writeFileWithTimestamp modulePath timestampA moduleContent + compileAllowingFailures [modulePath] `shouldReturn` moduleNames ["Module"] + compileAllowingFailures [modulePath] `shouldReturn` moduleNames ["Module"] + +rimraf :: FilePath -> IO () +rimraf = + void . tryJust (guard . isDoesNotExistError) . removeDirectoryRecursive + +-- | Returns a set of the modules for which a rebuild was attempted, including +-- the make result. +compileWithResult :: [FilePath] -> IO (Either P.MultipleErrors [P.ExternsFile], Set P.ModuleName) +compileWithResult input = do + recompiled <- newMVar Set.empty + moduleFiles <- readUTF8FilesT input + (makeResult, _) <- P.runMake P.defaultOptions $ do + ms <- CST.parseModulesFromFiles id moduleFiles + let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms + foreigns <- P.inferForeignModules filePathMap + let makeActions = + (P.buildMakeActions modulesDir filePathMap foreigns True) + { P.progress = \(P.CompilingModule mn) -> + liftIO $ modifyMVar_ recompiled (return . Set.insert mn) + } + P.make makeActions (map snd ms) + + recompiledModules <- readMVar recompiled + pure (makeResult, recompiledModules) + +-- | Compile, returning the set of modules which were rebuilt, and failing if +-- any errors occurred. +compile :: [FilePath] -> IO (Set P.ModuleName) +compile input = do + (result, recompiled) <- compileWithResult input + case result of + Left errs -> + fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) + Right _ -> + pure recompiled + +compileAllowingFailures :: [FilePath] -> IO (Set P.ModuleName) +compileAllowingFailures input = fmap snd (compileWithResult input) + +writeFileWithTimestamp :: FilePath -> UTCTime -> T.Text -> IO () +writeFileWithTimestamp path mtime contents = do + writeUTF8FileT path contents + setModificationTime path mtime + +-- | Use a different output directory to ensure that we don't get interference +-- from other test results +modulesDir :: FilePath +modulesDir = ".test_modules" "make" + diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index fe0c14d41d..78ba841c09 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -198,13 +198,13 @@ checkMain ms = makeActions :: [P.Module] -> M.Map P.ModuleName FilePath -> P.MakeActions P.Make makeActions modules foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False) - { P.getInputTimestamp = getInputTimestamp + { P.getInputTimestampsAndHashes = getInputTimestampsAndHashes , P.getOutputTimestamp = getOutputTimestamp , P.progress = const (pure ()) } where - getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime)) - getInputTimestamp mn + getInputTimestampsAndHashes :: P.ModuleName -> P.Make (Either P.RebuildPolicy a) + getInputTimestampsAndHashes mn | isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever) | otherwise = return (Left P.RebuildAlways) where From 4ba1b2a6b4451aeb0908926898328cc346dece06 Mon Sep 17 00:00:00 2001 From: Matthew Hilty Date: Thu, 29 Aug 2019 07:25:25 -0400 Subject: [PATCH 1152/1580] Add to the CONTRIBUTORS.md list for #3682. (#3725) --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 1ecc5a4e05..63565a74e8 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -135,6 +135,7 @@ If you would prefer to use different terms, please use the section below instead | [@adnelson](https://github.com/adnelson) | Allen Nelson | [MIT license](http://opensource.org/licenses/MIT) | | [@dyerw](https://github.com/dyerw) | Liam Dyer | [MIT license](http://opensource.org/licenses/MIT) | | [@marcosh](https://github.com/marcosh) | Marco Perone | [MIT license](http://opensource.org/licenses/MIT) | +| [@matthew-hilty](https://github.com/matthew-hilty) | Matthew Hilty | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms From 219aa11861357b7c9b206824a1ad95e029cf34a0 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 13 Sep 2019 12:36:14 +0100 Subject: [PATCH 1153/1580] Create output directory if necessary when writing cache db file (#3729) Fixes #3728. I've also renamed `mkdirp` because that name is misleading; it doesn't behave in quite the same way as `mkdir -p` would. --- src/Language/PureScript/Make/Actions.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 90ec644b13..c1fae53f0a 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -251,11 +251,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = writeTextFile :: FilePath -> B.ByteString -> Make () writeTextFile path text = makeIO (const (cannotWriteFile path)) $ do - mkdirp path + createParentDirectory path B.writeFile path text - where - mkdirp :: FilePath -> IO () - mkdirp = createDirectoryIfMissing True . takeDirectory progress :: ProgressMessage -> Make () progress = liftIO . putStrLn . renderProgressMessage @@ -276,9 +273,13 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = writeCacheDb :: CacheDb -> Make () writeCacheDb db = do let path = outputDir cacheDbFile - makeIO (const (cannotWriteFile path)) $ + makeIO (const (cannotWriteFile path)) $ do + createParentDirectory path Aeson.encodeFile path db + createParentDirectory :: FilePath -> IO () + createParentDirectory = createDirectoryIfMissing True . takeDirectory + cannotWriteFile = ErrorMessage [] . CannotWriteFile cannotReadFile = ErrorMessage [] . CannotReadFile cannotGetFileInfo = ErrorMessage [] . CannotGetFileInfo From 3189d931471e88368f3d78b4435a9a96dfb9f312 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 14 Sep 2019 08:54:48 -0400 Subject: [PATCH 1154/1580] Fix #3727 (#3731) The bundler needs to track internal dependencies on exported symbols during dead code elimination, not just on internal declarations. --- src/Language/PureScript/Bundle.hs | 32 ++++++++++++++++++------------- tests/purs/bundle/3727.js | 4 ++++ tests/purs/bundle/3727.purs | 13 +++++++++++++ 3 files changed, 36 insertions(+), 13 deletions(-) create mode 100644 tests/purs/bundle/3727.js create mode 100644 tests/purs/bundle/3727.purs diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 2fd4165940..174b95e1bf 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -270,7 +270,7 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) boundNames = mapMaybe toBoundName es where toBoundName :: ModuleElement -> Maybe String - toBoundName (Member _ _ nm _ _) = Just nm + toBoundName (Member _ Internal nm _ _) = Just nm toBoundName _ = Nothing -- | Calculate dependencies and add them to the current element. @@ -303,6 +303,11 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) = ([(m, nm, Internal)], bn) toReference (JSFunctionExpression _ _ _ params _ _) bn = ([], bn \\ (mapMaybe unIdent $ commaList params)) + toReference e bn + | Just nm <- exportsAccessor e + -- ^ exports.foo means there's a dependency on the public member "foo" of + -- this module. + = ([(m, nm, Public)], bn) toReference _ bn = ([], bn) unIdent :: JSIdent -> Maybe String @@ -450,21 +455,22 @@ matchMember stmt = Just (Internal, name, decl) -- exports.foo = expr; exports["foo"] = expr; | JSAssignStatement e (JSAssign _) decl _ <- stmt - , Just name <- accessor e + , Just name <- exportsAccessor e = Just (Public, name, decl) | otherwise = Nothing - where - accessor :: JSExpression -> Maybe String - accessor (JSMemberDot exports _ nm) - | JSIdentifier _ "exports" <- exports - , JSIdentifier _ name <- nm - = Just name - accessor (JSMemberSquare exports _ nm _) - | JSIdentifier _ "exports" <- exports - , Just name <- fromStringLiteral nm - = Just name - accessor _ = Nothing + +-- Matches exports.* or exports["*"] expressions and returns the property name. +exportsAccessor :: JSExpression -> Maybe String +exportsAccessor (JSMemberDot exports _ nm) + | JSIdentifier _ "exports" <- exports + , JSIdentifier _ name <- nm + = Just name +exportsAccessor (JSMemberSquare exports _ nm _) + | JSIdentifier _ "exports" <- exports + , Just name <- fromStringLiteral nm + = Just name +exportsAccessor _ = Nothing -- Matches assignments to module.exports, like this: -- module.exports = { ... } diff --git a/tests/purs/bundle/3727.js b/tests/purs/bundle/3727.js new file mode 100644 index 0000000000..02e18d2982 --- /dev/null +++ b/tests/purs/bundle/3727.js @@ -0,0 +1,4 @@ +'use strict'; + +exports.foo = 1; +exports.bar = exports.foo; diff --git a/tests/purs/bundle/3727.purs b/tests/purs/bundle/3727.purs new file mode 100644 index 0000000000..2bdf512a28 --- /dev/null +++ b/tests/purs/bundle/3727.purs @@ -0,0 +1,13 @@ +module Main (main) where + +import Prelude +import Effect (Effect) +import Effect.Console (log) +import Test.Assert (assert) + +main :: Effect Unit +main = do + assert (bar == 1) + log "Done" + +foreign import bar :: Int From 0f4abe450c6efdd23f8e3c0d3f7a020cf665545f Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Wed, 9 Oct 2019 14:59:23 -0400 Subject: [PATCH 1155/1580] Update language-javascript to 0.6.0.14 (#3736) --- package.yaml | 2 +- src/Language/PureScript/Bundle.hs | 10 +++++----- stack.yaml | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/package.yaml b/package.yaml index 67d1dc7ee1..742f4816b8 100644 --- a/package.yaml +++ b/package.yaml @@ -63,7 +63,7 @@ dependencies: - fsnotify >=0.2.1 - Glob >=0.9 && <0.10 - haskeline >=0.7.0.0 - - language-javascript >=0.6.0.13 + - language-javascript >=0.6.0.14 - lifted-async >=0.10.0.3 && <0.10.1 - lifted-base >=0.2.3 && <0.2.4 - memory >=0.14 && <0.15 diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 174b95e1bf..6f8d1964d7 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -302,7 +302,7 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) -- parameter) = ([(m, nm, Internal)], bn) toReference (JSFunctionExpression _ _ _ params _ _) bn - = ([], bn \\ (mapMaybe unIdent $ commaList params)) + = ([], bn \\ (mapMaybe unIdentifier $ commaList params)) toReference e bn | Just nm <- exportsAccessor e -- ^ exports.foo means there's a dependency on the public member "foo" of @@ -310,9 +310,9 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) = ([(m, nm, Public)], bn) toReference _ bn = ([], bn) - unIdent :: JSIdent -> Maybe String - unIdent (JSIdentName _ name) = Just name - unIdent _ = Nothing + unIdentifier :: JSExpression -> Maybe String + unIdentifier (JSIdentifier _ name) = Just name + unIdentifier _ = Nothing -- String literals include the quote chars fromStringLiteral :: JSExpression -> Maybe String @@ -763,7 +763,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o iife :: [JSStatement] -> String -> JSExpression -> JSStatement iife body param arg = - JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot (JSLOne (JSIdentName JSNoAnnot param)) JSNoAnnot + JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot (JSLOne (JSIdentifier JSNoAnnot param)) JSNoAnnot (JSBlock sp (prependWhitespace "\n " body) lf)) JSNoAnnot) JSNoAnnot diff --git a/stack.yaml b/stack.yaml index 380a8e0df7..1d85737ca8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,7 +4,7 @@ packages: - '.' extra-deps: - happy-1.19.9 -- language-javascript-0.6.0.13 +- language-javascript-0.6.0.14 - network-3.0.1.1 - these-1.0.1 - semialign-1 From ae141237d13ae2baee00347d85e8c4d5c413005f Mon Sep 17 00:00:00 2001 From: Matthew Hilty Date: Sat, 12 Oct 2019 12:44:09 -0400 Subject: [PATCH 1156/1580] Improve lint import warnings (#3685) * Improve linter import warnings - Include qualifier in UnusedImport warning so to distinguish between multiple import declarations for the same module. - Include kind imports with other imports for relevance checking. * Tweak redundant-import warnings per suggestion. --- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Errors.hs | 10 ++++++++-- src/Language/PureScript/Linter/Imports.hs | 3 ++- src/Language/PureScript/Sugar/Names/Imports.hs | 7 +++---- tests/purs/warning/Kind-UnusedExplicitImport-1.purs | 11 +++++++++++ tests/purs/warning/Kind-UnusedExplicitImport-2.purs | 12 ++++++++++++ tests/purs/warning/Kind-UnusedImport.purs | 9 +++++++++ 7 files changed, 46 insertions(+), 8 deletions(-) create mode 100644 tests/purs/warning/Kind-UnusedExplicitImport-1.purs create mode 100644 tests/purs/warning/Kind-UnusedExplicitImport-2.purs create mode 100644 tests/purs/warning/Kind-UnusedImport.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 93f8d879e5..cf8485426b 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -151,7 +151,7 @@ data SimpleErrorMessage | IncompleteExhaustivityCheck | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName) | ImportHidingModule ModuleName - | UnusedImport ModuleName + | UnusedImport ModuleName (Maybe ModuleName) | UnusedExplicitImport ModuleName [Name] (Maybe ModuleName) [DeclarationRef] | UnusedDctorImport ModuleName (ProperName 'TypeName) (Maybe ModuleName) [DeclarationRef] | UnusedDctorExplicitImport ModuleName (ProperName 'TypeName) [ProperName 'ConstructorName] (Maybe ModuleName) [DeclarationRef] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index cb4f460952..c767c55515 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -897,8 +897,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "An exhaustivity check was abandoned due to too many possible cases." , line "You may want to decompose your data types into smaller types." ] - renderSimpleErrorMessage (UnusedImport name) = - line $ "The import of module " <> markCode (runModuleName name) <> " is redundant" + + renderSimpleErrorMessage (UnusedImport mn qualifier) = + let + mark = markCode . runModuleName + unqualified = "The import of " <> mark mn <> " is redundant" + msg' q = "The qualified import of " <> mark mn <> " as " <> mark q <> " is redundant" + msg = maybe unqualified msg' + in line $ msg qualifier renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) = paras [ line $ "The import of module " <> markCode (runModuleName mn) <> " contains the following unused references:" diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 3aa8bf6787..7b1bbf0ca3 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -279,7 +279,7 @@ lintImportDecl env mni qualifierName names ss declType allowImplicit = isMatch _ _ = False unused :: m Bool - unused = warn (UnusedImport mni) + unused = warn (UnusedImport mni qualifierName) warn :: SimpleErrorMessage -> m Bool warn err = tell (errorMessage' ss err) >> return True @@ -373,6 +373,7 @@ runDeclRef (ValueOpRef _ op) = Just $ ValOpName op runDeclRef (TypeRef _ pn _) = Just $ TyName pn runDeclRef (TypeOpRef _ op) = Just $ TyOpName op runDeclRef (TypeClassRef _ pn) = Just $ TyClassName pn +runDeclRef (KindRef _ pn) = Just $ KiName pn runDeclRef _ = Nothing checkDuplicateImports diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 4253709055..f4e52984bb 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -32,10 +32,9 @@ findImports -> M.Map ModuleName [ImportDef] findImports = foldr go M.empty where - go (ImportDeclaration (pos, _) mn typ qual) result = - let imp = (pos, typ, qual) - in M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result - go _ result = result + go (ImportDeclaration (pos, _) mn typ qual) = + M.alter (return . ((pos, typ, qual) :) . fromMaybe []) mn + go _ = id -- | -- Constructs a set of imports for a module. diff --git a/tests/purs/warning/Kind-UnusedExplicitImport-1.purs b/tests/purs/warning/Kind-UnusedExplicitImport-1.purs new file mode 100644 index 0000000000..e5c9ba506a --- /dev/null +++ b/tests/purs/warning/Kind-UnusedExplicitImport-1.purs @@ -0,0 +1,11 @@ +-- @shouldWarnWith UnusedExplicitImport +module Main where + +import Prelude (Unit, unit, pure) +import Effect (Effect) +import Type.RowList (RLProxy, kind RowList) + +class A (a :: RowList) + +main :: Effect Unit +main = pure unit diff --git a/tests/purs/warning/Kind-UnusedExplicitImport-2.purs b/tests/purs/warning/Kind-UnusedExplicitImport-2.purs new file mode 100644 index 0000000000..0c8623e6b6 --- /dev/null +++ b/tests/purs/warning/Kind-UnusedExplicitImport-2.purs @@ -0,0 +1,12 @@ +-- @shouldWarnWith UnusedExplicitImport +module Main where + +import Prelude (Unit, unit, pure) +import Effect (Effect) +import Type.RowList (RLProxy, kind RowList) + +f :: forall l. RLProxy l -> Int +f _ = 0 + +main :: Effect Unit +main = pure unit diff --git a/tests/purs/warning/Kind-UnusedImport.purs b/tests/purs/warning/Kind-UnusedImport.purs new file mode 100644 index 0000000000..07ad87fd38 --- /dev/null +++ b/tests/purs/warning/Kind-UnusedImport.purs @@ -0,0 +1,9 @@ +-- @shouldWarnWith UnusedImport +module Main where + +import Prelude (Unit, unit, pure) +import Effect (Effect) +import Type.RowList (kind RowList) + +main :: Effect Unit +main = pure unit From 3e40a51ce0d83d5e6a30141c4da2389e0bf41a4b Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 12 Oct 2019 18:03:43 +0100 Subject: [PATCH 1157/1580] Better reporting of IO errors (#3730) This commit fixes two issues with the way we read and write files inside Language.PureScript.Make: 1. We use `doesFileExist` to check for file existence before attempting to do something with a file. This can cause race conditions; it's better to just attempt to do the thing and catch the "does not exist" error if we get one. 2. We discard the IOException which actually tells you what has gone wrong before we print the error message. This means that the error message often does not include the most important information. For example, here's the error I get when I try to build a project on a disk which does not have enough remaining space to accommodate all of the compiler output: Before: ``` Compiling Data.Ord Compiling Data.DivisionRing [1/2 CannotWriteFile] (unknown module) Unable to write file: ./output/Data.DivisionRing/externs.json [2/2 CannotWriteFile] (unknown module) Unable to write file: ./output/Data.Ord/foreign.js ``` After: ``` Compiling Data.Ord Compiling Data.DivisionRing [1/1 FileIOError] (unknown module) I/O error while trying to write JSON file: ./output/cache-db.json ./output/cache-db.json: hClose: resource exhausted (No space left on device) ``` We will need to update the documentation repo appropriately, because the `CannotReadFile`, `CannotWriteFile`, and `CannotGetFileInfo` error codes have been removed. --- src/Language/PureScript/AST/Declarations.hs | 4 +- src/Language/PureScript/Errors.hs | 19 ++--- src/Language/PureScript/Make/Actions.hs | 51 ++----------- src/Language/PureScript/Make/Monad.hs | 85 +++++++++++++++++++-- 4 files changed, 92 insertions(+), 67 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index cf8485426b..557cb51ea4 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -75,9 +75,7 @@ data SimpleErrorMessage | MissingFFIImplementations ModuleName [Ident] | UnusedFFIImplementations ModuleName [Ident] | InvalidFFIIdentifier ModuleName Text - | CannotGetFileInfo FilePath - | CannotReadFile FilePath - | CannotWriteFile FilePath + | FileIOError Text IOError -- ^ A description of what we were trying to do, and the error which occurred | InfiniteType SourceType | InfiniteKind SourceKind | MultipleValueOpFixities (OpName 'ValueOpName) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index c767c55515..72faa2bc73 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -10,6 +10,7 @@ import Prelude.Compat import Protolude (ordNub) import Control.Arrow ((&&&)) +import Control.Exception (displayException) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.State.Lazy @@ -85,9 +86,7 @@ errorCode em = case unwrapErrorMessage em of MissingFFIImplementations{} -> "MissingFFIImplementations" UnusedFFIImplementations{} -> "UnusedFFIImplementations" InvalidFFIIdentifier{} -> "InvalidFFIIdentifier" - CannotGetFileInfo{} -> "CannotGetFileInfo" - CannotReadFile{} -> "CannotReadFile" - CannotWriteFile{} -> "CannotWriteFile" + FileIOError{} -> "FileIOError" InfiniteType{} -> "InfiniteType" InfiniteKind{} -> "InfiniteKind" MultipleValueOpFixities{} -> "MultipleValueOpFixities" @@ -465,17 +464,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl else "Make sure the source file exists, and that it has been provided as an input to the compiler." ] - renderSimpleErrorMessage (CannotGetFileInfo path) = - paras [ line "Unable to read file info: " - , indent . lineS $ path - ] - renderSimpleErrorMessage (CannotReadFile path) = - paras [ line "Unable to read file: " - , indent . lineS $ path - ] - renderSimpleErrorMessage (CannotWriteFile path) = - paras [ line "Unable to write file: " - , indent . lineS $ path + renderSimpleErrorMessage (FileIOError doWhat err) = + paras [ line $ "I/O error while trying to " <> doWhat + , indent . lineS $ displayException err ] renderSimpleErrorMessage (ErrorParsingFFIModule path extra) = paras $ [ line "Unable to parse foreign module:" diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index c1fae53f0a..a8f6318fae 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -9,7 +9,6 @@ module Language.PureScript.Make.Actions import Prelude -import Control.Exception (tryJust) import Control.Monad hiding (sequence) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class @@ -53,9 +52,8 @@ import Language.PureScript.Pretty.Common (SMap(..)) import qualified Paths_purescript as Paths import SourceMap import SourceMap.Types -import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory) -import System.FilePath ((), takeDirectory, makeRelative, splitPath, normalise) -import System.IO.Error (isDoesNotExistError) +import System.Directory (getCurrentDirectory) +import System.FilePath ((), makeRelative, splitPath, normalise) -- | Determines when to rebuild a module data RebuildPolicy @@ -137,7 +135,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = Right filePath -> do let inputPaths = filePath : maybeToList (M.lookup mn foreigns) getInfo fp = do - ts <- getTimestamp fp >>= maybe (throwError (singleError (cannotReadFile fp))) pure + ts <- getTimestamp fp return (ts, hash <$> readTextFile fp) pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths return $ Right $ M.fromList pathsWithInfo @@ -158,7 +156,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = getOutputTimestamp mn = do codegenTargets <- asks optionsCodegenTargets let outputPaths = [outputFilename mn "externs.json"] <> fmap (targetFilename mn) (S.toList codegenTargets) - timestamps <- traverse getTimestamp outputPaths + timestamps <- traverse getTimestampMaybe outputPaths pure $ fmap minimum . NEL.nonEmpty =<< sequence timestamps readExterns :: ModuleName -> Make (FilePath, Externs) @@ -185,7 +183,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn | otherwise -> return Nothing rawJs <- J.moduleToJs m foreignInclude - dir <- lift $ makeIO (const (cannotGetFileInfo ".")) getCurrentDirectory + dir <- lift $ makeIO "get the current directory" getCurrentDirectory let sourceMaps = S.member JSSourceMap codegenTargets (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, []) jsFile = targetFilename mn JS @@ -242,49 +240,16 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = requiresForeign :: CF.Module a -> Bool requiresForeign = not . null . CF.moduleForeign - getTimestamp :: FilePath -> Make (Maybe UTCTime) - getTimestamp path = makeIO (const (cannotReadFile path)) $ do - exists <- doesFileExist path - if exists - then Just <$> getModificationTime path - else pure Nothing - - writeTextFile :: FilePath -> B.ByteString -> Make () - writeTextFile path text = makeIO (const (cannotWriteFile path)) $ do - createParentDirectory path - B.writeFile path text - progress :: ProgressMessage -> Make () progress = liftIO . putStrLn . renderProgressMessage readCacheDb :: Make CacheDb - readCacheDb = do - let path = outputDir cacheDbFile - makeIO (const (cannotReadFile path)) $ do - r <- tryJust - (guard . isDoesNotExistError) - (Aeson.decodeFileStrict' path) - case r of - Left () -> - pure mempty - Right mdb -> - pure (fromMaybe mempty mdb) + readCacheDb = fmap (fromMaybe mempty) $ readJSONFile cacheDbFile writeCacheDb :: CacheDb -> Make () - writeCacheDb db = do - let path = outputDir cacheDbFile - makeIO (const (cannotWriteFile path)) $ do - createParentDirectory path - Aeson.encodeFile path db - - createParentDirectory :: FilePath -> IO () - createParentDirectory = createDirectoryIfMissing True . takeDirectory - - cannotWriteFile = ErrorMessage [] . CannotWriteFile - cannotReadFile = ErrorMessage [] . CannotReadFile - cannotGetFileInfo = ErrorMessage [] . CannotGetFileInfo + writeCacheDb = writeJSONFile cacheDbFile - cacheDbFile = "cache-db.json" + cacheDbFile = outputDir "cache-db.json" -- | Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module. diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index bbc737e7b3..6fe38f35be 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -5,11 +5,19 @@ module Language.PureScript.Make.Monad Make(..) , runMake , makeIO + , getTimestamp + , getTimestampMaybe , readTextFile + , readTextFileMaybe + , readJSONFile + , writeTextFile + , writeJSONFile ) where import Prelude +import Control.Exception (tryJust) +import Control.Monad (join, guard) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class @@ -18,11 +26,17 @@ import Control.Monad.Reader (MonadReader(..), ReaderT(..)) import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Trans.Except import Control.Monad.Writer.Class (MonadWriter(..)) +import qualified Data.Aeson as Aeson import qualified Data.ByteString.Lazy as B +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time.Clock (UTCTime) import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Options -import System.IO.Error (tryIOError) +import System.Directory (createDirectoryIfMissing, getModificationTime) +import System.FilePath (takeDirectory) +import System.IO.Error (tryIOError, isDoesNotExistError) -- | A monad for running make actions newtype Make a = Make @@ -41,14 +55,71 @@ instance MonadBaseControl IO Make where runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors) runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake --- | Run an 'IO' action in the 'Make' monad, by specifying how IO errors should --- be rendered as 'ErrorMessage' values. -makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a -makeIO f io = do +-- | Run an 'IO' action in the 'Make' monad. The 'String' argument should +-- describe what we were trying to do; it is used for rendering errors in the +-- case that an IOException is thrown. +makeIO :: Text -> IO a -> Make a +makeIO description io = do e <- liftIO $ tryIOError io - either (throwError . singleError . f) return e + either (throwError . singleError . ErrorMessage [] . FileIOError description) return e + +-- | Get a file's modification time in the 'Make' monad, capturing any errors +-- using the 'MonadError' instance. +getTimestamp :: FilePath -> Make UTCTime +getTimestamp path = + makeIO ("get a timestamp for file: " <> Text.pack path) $ getModificationTime path + +-- | Get a file's modification time in the 'Make' monad, returning Nothing if +-- the file does not exist. +getTimestampMaybe :: FilePath -> Make (Maybe UTCTime) +getTimestampMaybe path = + makeIO ("get a timestamp for file: " <> Text.pack path) $ catchDoesNotExist $ getModificationTime path -- | Read a text file in the 'Make' monad, capturing any errors using the -- 'MonadError' instance. readTextFile :: FilePath -> Make B.ByteString -readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path +readTextFile path = + makeIO ("read file: " <> Text.pack path) $ B.readFile path + +-- | Read a text file in the 'Make' monad, or return 'Nothing' if the file does +-- not exist. Errors are captured using the 'MonadError' instance. +readTextFileMaybe :: FilePath -> Make (Maybe B.ByteString) +readTextFileMaybe path = + makeIO ("read file: " <> Text.pack path) $ catchDoesNotExist $ B.readFile path + +-- | Read a JSON file in the 'Make' monad, returning 'Nothing' if the file does +-- not exist or could not be parsed. Errors are captured using the 'MonadError' +-- instance. +readJSONFile :: Aeson.FromJSON a => FilePath -> Make (Maybe a) +readJSONFile path = + makeIO ("read JSON file: " <> Text.pack path) $ do + r <- catchDoesNotExist $ Aeson.decodeFileStrict' path + return $ join r + +-- | If the provided action threw an 'isDoesNotExist' error, catch it and +-- return Nothing. Otherwise return Just the result of the inner action. +catchDoesNotExist :: IO a -> IO (Maybe a) +catchDoesNotExist inner = do + r <- tryJust (guard . isDoesNotExistError) inner + case r of + Left () -> + return Nothing + Right x -> + return (Just x) + +-- | Write a text file in the 'Make' monad, capturing any errors using the +-- 'MonadError' instance. +writeTextFile :: FilePath -> B.ByteString -> Make () +writeTextFile path text = makeIO ("write file: " <> Text.pack path) $ do + createParentDirectory path + B.writeFile path text + +-- | Write a JSON file in the 'Make' monad, capturing any errors using the +-- 'MonadError' instance. +writeJSONFile :: Aeson.ToJSON a => FilePath -> a -> Make () +writeJSONFile path value = makeIO ("write JSON file: " <> Text.pack path) $ do + createParentDirectory path + Aeson.encodeFile path value + +createParentDirectory :: FilePath -> IO () +createParentDirectory = createDirectoryIfMissing True . takeDirectory From c7c922bba7e89cb379c1db7398cdf2aa0b43cb6b Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 12 Oct 2019 19:21:26 +0100 Subject: [PATCH 1158/1580] Update language-javascript to 0.7.0.0 (#3738) 0.7.0.0 is the same as 0.6.0.14 (which is currently in our package configuration), except the latter has been deprecated, because it contained breaking changes but was released as a patch level change. --- package.yaml | 2 +- stack.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index 742f4816b8..abaceb9c78 100644 --- a/package.yaml +++ b/package.yaml @@ -63,7 +63,7 @@ dependencies: - fsnotify >=0.2.1 - Glob >=0.9 && <0.10 - haskeline >=0.7.0.0 - - language-javascript >=0.6.0.14 + - language-javascript >=0.7.0.0 - lifted-async >=0.10.0.3 && <0.10.1 - lifted-base >=0.2.3 && <0.2.4 - memory >=0.14 && <0.15 diff --git a/stack.yaml b/stack.yaml index 1d85737ca8..85af85f65a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,7 +4,7 @@ packages: - '.' extra-deps: - happy-1.19.9 -- language-javascript-0.6.0.14 +- language-javascript-0.7.0.0 - network-3.0.1.1 - these-1.0.1 - semialign-1 From aa9af2e0e735c82f441230cd8f712063a5e5a45a Mon Sep 17 00:00:00 2001 From: Woodson Delhia Date: Sun, 20 Oct 2019 23:52:21 +0900 Subject: [PATCH 1159/1580] Fix #3722, shows entire row with --verbose-errors flag (#3733) * Fix #3722, show entire row with --verbose-errors flag * Adjust printRows function based on @hdgarrood review * Fixed case branch --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Errors.hs | 14 ++++++++++---- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 63565a74e8..42f8195216 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -136,6 +136,7 @@ If you would prefer to use different terms, please use the section below instead | [@dyerw](https://github.com/dyerw) | Liam Dyer | [MIT license](http://opensource.org/licenses/MIT) | | [@marcosh](https://github.com/marcosh) | Marco Perone | [MIT license](http://opensource.org/licenses/MIT) | | [@matthew-hilty](https://github.com/matthew-hilty) | Matthew Hilty | [MIT license](http://opensource.org/licenses/MIT) | +| [@woody88](https://github.com/woody88) | Woodson Delhia | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 72faa2bc73..1386ce6eab 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1187,11 +1187,17 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl printRow f t = markCodeBox $ indent $ f prettyDepth t -- If both rows are not empty, print them as diffs + -- If verbose print all rows else only print unique rows printRows :: Type a -> Type a -> (Box.Box, Box.Box) - printRows r1@RCons{} r2@RCons{} = let - (sorted1, sorted2) = filterRows (rowToList r1) (rowToList r2) - in (printRow typeDiffAsBox sorted1, printRow typeDiffAsBox sorted2) - printRows r1 r2 = (printRow typeAsBox r1, printRow typeAsBox r2) + printRows r1 r2 = case (full, r1, r2) of + (True, _ , _) -> (printRow typeAsBox r1, printRow typeAsBox r2) + + (_, RCons{}, RCons{}) -> + let (sorted1, sorted2) = filterRows (rowToList r1) (rowToList r2) + in (printRow typeDiffAsBox sorted1, printRow typeDiffAsBox sorted2) + + (_, _, _) -> (printRow typeAsBox r1, printRow typeAsBox r2) + -- Keep the unique labels only filterRows :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Type a, Type a) From e381b7fe862a9035a563c264ad4b8586f3047f3d Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 20 Oct 2019 21:15:12 +0100 Subject: [PATCH 1160/1580] Fix for ES object shorthand in purs bundle (#3742) * Add test for ES object property shorthand syntax * Handle object property shorthand in purs bundle Fixes #3714 * Test for local variable shadowing * Fix for local variable shadowing --- src/Language/PureScript/Bundle.hs | 15 +++++++++++++++ tests/purs/bundle/ObjectShorthand.js | 15 +++++++++++++++ tests/purs/bundle/ObjectShorthand.purs | 18 ++++++++++++++++++ 3 files changed, 48 insertions(+) create mode 100644 tests/purs/bundle/ObjectShorthand.js create mode 100644 tests/purs/bundle/ObjectShorthand.purs diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 6f8d1964d7..df746f31d3 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -301,6 +301,17 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) -- bound to the module level (i.e., hasn't been shadowed by a function -- parameter) = ([(m, nm, Internal)], bn) + toReference (JSObjectLiteral _ props _) bn + = let + shorthandNames = + filter (`elem` bn) $ + -- ^ only add a dependency if this name is still in the list of + -- names bound to the module level (i.e., hasn't been shadowed by a + -- function parameter) + mapMaybe unPropertyIdentRef $ + trailingCommaList props + in + (map (\name -> (m, name, Internal)) shorthandNames, bn) toReference (JSFunctionExpression _ _ _ params _ _) bn = ([], bn \\ (mapMaybe unIdentifier $ commaList params)) toReference e bn @@ -314,6 +325,10 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) unIdentifier (JSIdentifier _ name) = Just name unIdentifier _ = Nothing + unPropertyIdentRef :: JSObjectProperty -> Maybe String + unPropertyIdentRef (JSPropertyIdentRef _ name) = Just name + unPropertyIdentRef _ = Nothing + -- String literals include the quote chars fromStringLiteral :: JSExpression -> Maybe String fromStringLiteral (JSStringLiteral _ str) = Just $ strValue str diff --git a/tests/purs/bundle/ObjectShorthand.js b/tests/purs/bundle/ObjectShorthand.js new file mode 100644 index 0000000000..156ff0c9da --- /dev/null +++ b/tests/purs/bundle/ObjectShorthand.js @@ -0,0 +1,15 @@ +"use strict"; + +var foo = 1; + +exports.bar = { foo }; + +var baz = 2; + +exports.quux = function(baz) { + return { baz }; +}; + +var fs = require('fs'); +var source = fs.readFileSync(__filename, 'utf-8'); +exports.bazIsEliminated = !/^ *var baz =/m.test(source); diff --git a/tests/purs/bundle/ObjectShorthand.purs b/tests/purs/bundle/ObjectShorthand.purs new file mode 100644 index 0000000000..6914845ecb --- /dev/null +++ b/tests/purs/bundle/ObjectShorthand.purs @@ -0,0 +1,18 @@ +-- See issue #3741 +module Main (main) where + +import Prelude +import Effect (Effect) +import Effect.Console (log) +import Test.Assert (assert') + +main :: Effect Unit +main = do + assert' "bar" (bar.foo == 1) + assert' "quux" (quux 3 == { baz: 3 }) + assert' "baz" bazIsEliminated + log "Done" + +foreign import bar :: { foo :: Int } +foreign import quux :: forall a. a -> { baz :: a } +foreign import bazIsEliminated :: Boolean From dc0f4879d20e25a01ff206cc04858ba946d9391a Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 20 Oct 2019 22:01:24 +0100 Subject: [PATCH 1161/1580] v0.13.4 --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index abaceb9c78..06ae342e67 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.13.3' +version: '0.13.4' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 432accc3ea69cb4555e2b3305fae8a29e4e17dde Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 20 Oct 2019 22:33:20 +0100 Subject: [PATCH 1162/1580] Update npm package for 0.13.4 --- npm-package/package.json | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/npm-package/package.json b/npm-package/package.json index 724e264122..79b039533f 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.13.3", + "version": "0.13.4", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.13.3", + "postinstall": "install-purescript --purs-ver=0.13.4", "test": "echo 'Error: no test specified' && exit 1" } } From be635427f34776a7d2229bf35d953ec2ed38e31f Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Fri, 8 Nov 2019 08:07:11 +0900 Subject: [PATCH 1163/1580] Fix error with using Haddock markings in comments where they should not belong (#3745) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Haddock doesn't like markups like `-- |` or `-- ^` in comments that aren't top-level function comments. When building with `stack build --haddock`, I would get the following errors: ``` src/Language/PureScript/Bundle.hs:300:7: error: parse error on input ‘-- ^ only add a dependency if this name is still in the list of names -- bound to the module level (i.e., hasn't been shadowed by a function -- parameter)’ | 300 | -- ^ only add a dependency if this name is still in the list of names | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ``` This commit fixes these stray markups, and makes `stack build --haddock` work again. --- src/Language/PureScript/Bundle.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index df746f31d3..cf90d2e0ae 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -297,7 +297,7 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) = ([(mid, nm', Public)], bn) toReference (JSIdentifier _ nm) bn | nm `elem` bn - -- ^ only add a dependency if this name is still in the list of names + -- only add a dependency if this name is still in the list of names -- bound to the module level (i.e., hasn't been shadowed by a function -- parameter) = ([(m, nm, Internal)], bn) @@ -305,7 +305,7 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) = let shorthandNames = filter (`elem` bn) $ - -- ^ only add a dependency if this name is still in the list of + -- only add a dependency if this name is still in the list of -- names bound to the module level (i.e., hasn't been shadowed by a -- function parameter) mapMaybe unPropertyIdentRef $ @@ -316,7 +316,7 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) = ([], bn \\ (mapMaybe unIdentifier $ commaList params)) toReference e bn | Just nm <- exportsAccessor e - -- ^ exports.foo means there's a dependency on the public member "foo" of + -- exports.foo means there's a dependency on the public member "foo" of -- this module. = ([(m, nm, Public)], bn) toReference _ bn = ([], bn) From bca0ba7a3a9629f1edefaf3652e685b3c86c7194 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 13 Nov 2019 11:00:16 +0000 Subject: [PATCH 1164/1580] Banish lazy I/O from Make (#3747) * Use Aeson's encodeFile (fixes #3371) * Fix warnings * use copyFile instead of reading and writing * Banish the last uses of lazy IO from Make (fixes #3743) --- src/Language/PureScript/Externs.hs | 18 ++++----- src/Language/PureScript/Make.hs | 3 +- src/Language/PureScript/Make/Actions.hs | 39 ++++++++---------- src/Language/PureScript/Make/BuildPlan.hs | 2 +- src/Language/PureScript/Make/Cache.hs | 10 ++--- src/Language/PureScript/Make/Monad.hs | 49 +++++++++++++++++------ 6 files changed, 67 insertions(+), 54 deletions(-) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 31d24b2c1c..d4785a4c10 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -10,17 +10,14 @@ module Language.PureScript.Externs , ExternsFixity(..) , ExternsTypeFixity(..) , ExternsDeclaration(..) + , externsIsCurrentVersion , moduleToExternsFile , applyExternsFileToEnvironment - , decodeExterns ) where import Prelude.Compat -import Control.Monad (guard) -import Data.Aeson (decode) import Data.Aeson.TH -import Data.ByteString.Lazy (ByteString) import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.List (foldl', find) import Data.Foldable (fold) @@ -149,6 +146,12 @@ data ExternsDeclaration = } deriving Show +-- | Check whether the version in an externs file matches the currently running +-- version. +externsIsCurrentVersion :: ExternsFile -> Bool +externsIsCurrentVersion ef = + T.unpack (efVersion ef) == showVersion Paths.version + -- | Convert an externs file back into a module applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclarations @@ -247,10 +250,3 @@ $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsF $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsTypeFixity) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile) - - -decodeExterns :: ByteString -> Maybe ExternsFile -decodeExterns bs = do - externs <- decode bs - guard $ T.unpack (efVersion externs) == showVersion Paths.version - return externs diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 3008930d02..55b3ebf26d 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -17,7 +17,6 @@ import Control.Monad.IO.Class import Control.Monad.Supply import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Writer.Class (MonadWriter(..)) -import Data.Aeson (encode) import Data.Function (on) import Data.Foldable (for_) import Data.List (foldl', sortBy) @@ -95,7 +94,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs Right d -> d - evalSupplyT nextVar' . codegen renamed docs . encode $ exts + evalSupplyT nextVar' $ codegen renamed docs exts return exts -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.json@ file. diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index a8f6318fae..77374b140b 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -1,7 +1,6 @@ module Language.PureScript.Make.Actions ( MakeActions(..) , RebuildPolicy(..) - , Externs() , ProgressMessage(..) , buildMakeActions , checkForeignDecls @@ -16,11 +15,7 @@ import Control.Monad.Reader (asks) import Control.Monad.Supply import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Writer.Class (MonadWriter(..)) -import qualified Data.Aeson as Aeson import Data.Bifunctor (bimap) -import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString.Lazy as LB -import qualified Data.ByteString.Lazy.UTF8 as LBU8 import Data.Either (partitionEithers) import Data.Foldable (for_, minimum) import qualified Data.List.NonEmpty as NEL @@ -43,6 +38,7 @@ import Language.PureScript.Crash import qualified Language.PureScript.CST as CST import qualified Language.PureScript.Docs.Types as Docs import Language.PureScript.Errors +import Language.PureScript.Externs (ExternsFile) import Language.PureScript.Make.Monad import Language.PureScript.Make.Cache import Language.PureScript.Names @@ -69,9 +65,6 @@ data ProgressMessage -- ^ Compilation started for the specified module deriving (Show, Eq, Ord) --- | Generated code for an externs file. -type Externs = LB.ByteString - -- | Render a progress message renderProgressMessage :: ProgressMessage -> String renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModuleName mn) @@ -92,10 +85,10 @@ data MakeActions m = MakeActions -- ^ Get the timestamp for the output files for a module. This should be the -- timestamp for the oldest modified file, or 'Nothing' if any of the required -- output files are missing. - , readExterns :: ModuleName -> m (FilePath, Externs) + , readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile) -- ^ Read the externs file for a module as a string and also return the actual -- path for the file. - , codegen :: CF.Module CF.Ann -> Docs.Module -> Externs -> SupplyT m () + , codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m () -- ^ Run the code generator for the module and write any required output files. , ffiCodegen :: CF.Module CF.Ann -> m () -- ^ Check ffi and print it in the output directory. @@ -136,7 +129,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = let inputPaths = filePath : maybeToList (M.lookup mn foreigns) getInfo fp = do ts <- getTimestamp fp - return (ts, hash <$> readTextFile fp) + return (ts, hashFile fp) pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths return $ Right $ M.fromList pathsWithInfo @@ -159,20 +152,20 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = timestamps <- traverse getTimestampMaybe outputPaths pure $ fmap minimum . NEL.nonEmpty =<< sequence timestamps - readExterns :: ModuleName -> Make (FilePath, Externs) + readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile) readExterns mn = do let path = outputDir T.unpack (runModuleName mn) "externs.json" - (path, ) <$> readTextFile path + (path, ) <$> readExternsFile path - codegen :: CF.Module CF.Ann -> Docs.Module -> Externs -> SupplyT Make () + codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make () codegen m docs exts = do let mn = CF.moduleName m - lift $ writeTextFile (outputFilename mn "externs.json") exts + lift $ writeJSONFile (outputFilename mn "externs.json") exts codegenTargets <- lift $ asks optionsCodegenTargets when (S.member CoreFn codegenTargets) $ do let coreFnFile = targetFilename mn CoreFn json = CFJ.moduleToJSON Paths.version m - lift $ writeTextFile coreFnFile (Aeson.encode json) + lift $ writeJSONFile coreFnFile json when (S.member JS codegenTargets) $ do foreignInclude <- case mn `M.lookup` foreigns of Just _ @@ -192,17 +185,16 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = js = T.unlines $ map ("// " <>) prefix ++ [pjs] mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else "" lift $ do - writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef) + writeTextFile jsFile (TE.encodeUtf8 $ js <> mapRef) when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings when (S.member Docs codegenTargets) $ do - lift $ writeTextFile (outputFilename mn "docs.json") (Aeson.encode docs) + lift $ writeJSONFile (outputFilename mn "docs.json") docs ffiCodegen :: CF.Module CF.Ann -> Make () ffiCodegen m = do codegenTargets <- asks optionsCodegenTargets when (S.member JS codegenTargets) $ do let mn = CF.moduleName m - foreignFile = outputFilename mn "foreign.js" case mn `M.lookup` foreigns of Just path | not $ requiresForeign m -> @@ -211,7 +203,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = checkForeignDecls m path Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn | otherwise -> return () - for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile) + for_ (mn `M.lookup` foreigns) $ \path -> + copyFile path (outputFilename mn "foreign.js") genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do @@ -228,7 +221,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = }) mappings } let mapping = generate rawMapping - writeTextFile mapFile (Aeson.encode mapping) + writeJSONFile mapFile mapping where add :: Int -> Int -> SourcePos -> SourcePos add n m (SourcePos n' m') = SourcePos (n+n') (m+m') @@ -255,8 +248,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = -- in its corresponding foreign module. checkForeignDecls :: CF.Module ann -> FilePath -> Make () checkForeignDecls m path = do - jsStr <- readTextFile path - js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse (LBU8.toString jsStr) path + jsStr <- T.unpack <$> readTextFile path + js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path foreignIdentsStrs <- either errorParsingModule pure $ getExps js foreignIdents <- either diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index ebbe50d645..14f5181952 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -188,7 +188,7 @@ construct MakeActions{..} cacheDb (sorted, graph) = do findExistingExtern :: ModuleName -> m (Maybe Prebuilt) findExistingExtern moduleName = runMaybeT $ do timestamp <- MaybeT $ getOutputTimestamp moduleName - externs <- MaybeT $ decodeExterns . snd <$> readExterns moduleName + externs <- MaybeT $ snd <$> readExterns moduleName pure (Prebuilt timestamp externs) collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs index 337ee2d262..47f7f0e94b 100644 --- a/src/Language/PureScript/Make/Cache.hs +++ b/src/Language/PureScript/Make/Cache.hs @@ -13,12 +13,12 @@ import Prelude import Control.Category ((>>>)) import Control.Monad ((>=>)) -import Crypto.Hash (hashlazy, HashAlgorithm, Digest, SHA512, digestFromByteString) +import Crypto.Hash (HashAlgorithm, Digest, SHA512) +import qualified Crypto.Hash as Hash import qualified Data.Aeson as Aeson import Data.Align (align) import Data.ByteArray.Encoding (Base(Base16), convertToBase, convertFromBase) import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe) @@ -39,7 +39,7 @@ digestFromHex :: forall a. HashAlgorithm a => Text -> Maybe (Digest a) digestFromHex = encodeUtf8 >>> either (const Nothing) Just . convertFromBase Base16 - >=> (digestFromByteString :: BS.ByteString -> Maybe (Digest a)) + >=> (Hash.digestFromByteString :: BS.ByteString -> Maybe (Digest a)) -- | Defines the hash algorithm we use for cache invalidation of input files. newtype ContentHash = ContentHash @@ -58,8 +58,8 @@ instance Aeson.FromJSON ContentHash where Nothing -> fail "Unable to decode ContentHash" -hash :: BSL.ByteString -> ContentHash -hash = ContentHash . hashlazy +hash :: BS.ByteString -> ContentHash +hash = ContentHash . Hash.hash type CacheDb = Map ModuleName CacheInfo diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index 6fe38f35be..ed2a2dc4d4 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -8,10 +8,12 @@ module Language.PureScript.Make.Monad , getTimestamp , getTimestampMaybe , readTextFile - , readTextFileMaybe , readJSONFile + , readExternsFile + , hashFile , writeTextFile , writeJSONFile + , copyFile ) where import Prelude @@ -27,16 +29,20 @@ import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Trans.Except import Control.Monad.Writer.Class (MonadWriter(..)) import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString as B import Data.Text (Text) import qualified Data.Text as Text import Data.Time.Clock (UTCTime) import Language.PureScript.AST import Language.PureScript.Errors +import Language.PureScript.Externs (ExternsFile, externsIsCurrentVersion) +import Language.PureScript.Make.Cache (ContentHash, hash) import Language.PureScript.Options import System.Directory (createDirectoryIfMissing, getModificationTime) +import qualified System.Directory as Directory import System.FilePath (takeDirectory) import System.IO.Error (tryIOError, isDoesNotExistError) +import System.IO.UTF8 (readUTF8FileT) -- | A monad for running make actions newtype Make a = Make @@ -75,17 +81,12 @@ getTimestampMaybe :: FilePath -> Make (Maybe UTCTime) getTimestampMaybe path = makeIO ("get a timestamp for file: " <> Text.pack path) $ catchDoesNotExist $ getModificationTime path --- | Read a text file in the 'Make' monad, capturing any errors using the --- 'MonadError' instance. -readTextFile :: FilePath -> Make B.ByteString +-- | Read a text file strictly in the 'Make' monad, capturing any errors using +-- the 'MonadError' instance. +readTextFile :: FilePath -> Make Text readTextFile path = - makeIO ("read file: " <> Text.pack path) $ B.readFile path - --- | Read a text file in the 'Make' monad, or return 'Nothing' if the file does --- not exist. Errors are captured using the 'MonadError' instance. -readTextFileMaybe :: FilePath -> Make (Maybe B.ByteString) -readTextFileMaybe path = - makeIO ("read file: " <> Text.pack path) $ catchDoesNotExist $ B.readFile path + makeIO ("read file: " <> Text.pack path) $ + readUTF8FileT path -- | Read a JSON file in the 'Make' monad, returning 'Nothing' if the file does -- not exist or could not be parsed. Errors are captured using the 'MonadError' @@ -96,6 +97,22 @@ readJSONFile path = r <- catchDoesNotExist $ Aeson.decodeFileStrict' path return $ join r +-- | Read an externs file, returning 'Nothing' if the file does not exist, +-- could not be parsed, or was generated by a different version of the +-- compiler. +readExternsFile :: FilePath -> Make (Maybe ExternsFile) +readExternsFile path = do + mexterns <- readJSONFile path + return $ do + externs <- mexterns + guard $ externsIsCurrentVersion externs + return externs + +hashFile :: FilePath -> Make ContentHash +hashFile path = do + makeIO ("hash file: " <> Text.pack path) + (hash <$> B.readFile path) + -- | If the provided action threw an 'isDoesNotExist' error, catch it and -- return Nothing. Otherwise return Just the result of the inner action. catchDoesNotExist :: IO a -> IO (Maybe a) @@ -121,5 +138,13 @@ writeJSONFile path value = makeIO ("write JSON file: " <> Text.pack path) $ do createParentDirectory path Aeson.encodeFile path value +-- | Copy a file in the 'Make' monad, capturing any errors using the +-- 'MonadError' instance. +copyFile :: FilePath -> FilePath -> Make () +copyFile src dest = + makeIO ("copy file: " <> Text.pack src <> " -> " <> Text.pack dest) $ do + createParentDirectory dest + Directory.copyFile src dest + createParentDirectory :: FilePath -> IO () createParentDirectory = createDirectoryIfMissing True . takeDirectory From 677c1a28780f637e1754fee9f818ecdccb84b308 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 13 Nov 2019 14:06:03 +0000 Subject: [PATCH 1165/1580] Consider re-exports in unused kind warnings (#3748) Fixes #3744 --- src/Language/PureScript/Linter/Imports.hs | 1 + tests/purs/warning/KindReExport.purs | 11 +++++++++++ 2 files changed, 12 insertions(+) create mode 100644 tests/purs/warning/KindReExport.purs diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 7b1bbf0ca3..5396328a85 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -178,6 +178,7 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do ++ extractByQual mne (importedDataConstructors scope) DctorName ++ extractByQual mne (importedValues scope) IdentName ++ extractByQual mne (importedValueOps scope) ValOpName + ++ extractByQual mne (importedKinds scope) KiName where go :: (ModuleName, Qualified Name) -> UsedImports -> UsedImports go (q, name) = M.alter (Just . maybe [name] (name :)) q diff --git a/tests/purs/warning/KindReExport.purs b/tests/purs/warning/KindReExport.purs new file mode 100644 index 0000000000..b255c8498c --- /dev/null +++ b/tests/purs/warning/KindReExport.purs @@ -0,0 +1,11 @@ +-- | This test is to ensure that we do not get an incorrect 'unused kind' +-- | warning. See #3744 +module Main (main, module X) where + +import Prelude +import Effect (Effect) +import Effect.Console (log) +import Prim.Ordering (kind Ordering) as X + +main :: Effect Unit +main = log "Done" From cc736f62d41cb8b10b89d5baa45245243809efa6 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 13 Nov 2019 22:02:18 +0000 Subject: [PATCH 1166/1580] Add upper bound on Protolude (#3752) The compiler does not currently compile with Protolude 0.2.4, because of an import conflict. This commit addresses the issue by adding an upper bound which prevents Protolude 0.2.4 from being selected. --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 06ae342e67..d54022800b 100644 --- a/package.yaml +++ b/package.yaml @@ -75,7 +75,7 @@ dependencies: - parsec >=3.1.10 - pattern-arrows >=0.0.2 && <0.1 - process >=1.2.0 && <1.7 - - protolude >=0.1.6 + - protolude >=0.1.6 && <0.2.4 - regex-tdfa - safe >=0.3.9 && <0.4 - scientific >=0.3.4.9 && <0.4 From 3b8c0768a0cffde6a43924f22b4f9d30e916f389 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 13 Nov 2019 22:25:50 +0000 Subject: [PATCH 1167/1580] Update package.yml for 0.13.5 --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index d54022800b..b4f51defd0 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.13.4' +version: '0.13.5' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From f820a295c8a1d0c6173e6438faf6acc095ac4650 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 13 Nov 2019 22:55:26 +0000 Subject: [PATCH 1168/1580] Update package.json for 0.13.5 --- npm-package/package.json | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/npm-package/package.json b/npm-package/package.json index 79b039533f..b4cb5bbed0 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.13.4", + "version": "0.13.5", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.13.4", + "postinstall": "install-purescript --purs-ver=0.13.5", "test": "echo 'Error: no test specified' && exit 1" } } From 90d315e63147c4ad88480f6858cceda9625b6b5d Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 13 Nov 2019 23:39:47 +0000 Subject: [PATCH 1169/1580] Use PureScript escapes in string pretty-printing (#3751) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes #3740 As of this PR, pretty-printed Strings will try use the literal code points when pretty-printing strings where sensible, including for non-ASCII strings. For example, "Fuß", "¡Hola!", and "🐱" now appear as such in error messages (whereas previously they would have used escapes). --- src/Language/PureScript/PSString.hs | 70 ++++++++++++++++++++++------- 1 file changed, 54 insertions(+), 16 deletions(-) diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index f466257f2a..48a042fe1b 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -18,7 +18,7 @@ import GHC.Generics (Generic) import Control.DeepSeq (NFData) import Control.Exception (try, evaluate) import Control.Applicative ((<|>)) -import Data.Char (chr) +import qualified Data.Char as Char import Data.Bits (shiftR) import Data.List (unfoldr) import Data.Scientific (toBoundedInteger) @@ -67,7 +67,7 @@ instance Show PSString where -- we do not export it. -- codePoints :: PSString -> String -codePoints = map (either (chr . fromIntegral) id) . decodeStringEither +codePoints = map (either (Char.chr . fromIntegral) id) . decodeStringEither -- | -- Decode a PSString as UTF-16 text. Lone surrogates will be replaced with @@ -93,14 +93,6 @@ decodeStringEither = unfoldr decode . toUTF16CodeUnits unsurrogate :: Word16 -> Word16 -> Char unsurrogate h l = toEnum ((toInt h - 0xD800) * 0x400 + (toInt l - 0xDC00) + 0x10000) --- | --- Pretty print a PSString, using Haskell/PureScript escape sequences. --- This is identical to the Show instance except that we get a Text out instead --- of a String. --- -prettyPrintString :: PSString -> Text -prettyPrintString = T.pack . show - -- | -- Attempt to decode a PSString as UTF-16 text. This will fail (returning -- Nothing) if the argument contains lone surrogates. @@ -155,6 +147,52 @@ instance A.FromJSON PSString where parseCodeUnit :: A.Value -> A.Parser Word16 parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b +-- | +-- Pretty print a PSString, using PureScript escape sequences. +-- +prettyPrintString :: PSString -> Text +prettyPrintString s = "\"" <> foldMap encodeChar (decodeStringEither s) <> "\"" + where + encodeChar :: Either Word16 Char -> Text + encodeChar (Left c) = "\\x" <> showHex' 6 c + encodeChar (Right c) + | c == '\t' = "\\t" + | c == '\r' = "\\r" + | c == '\n' = "\\n" + | c == '"' = "\\\"" + | c == '\'' = "\\\'" + | c == '\\' = "\\\\" + | shouldPrint c = T.singleton c + | otherwise = "\\x" <> showHex' 6 (Char.ord c) + + -- Note we do not use Data.Char.isPrint here because that includes things + -- like zero-width spaces and combining punctuation marks, which could be + -- confusing to print unescaped. + shouldPrint :: Char -> Bool + -- The standard space character, U+20 SPACE, is the only space char we should + -- print without escaping + shouldPrint ' ' = True + shouldPrint c = + Char.generalCategory c `elem` + [ Char.UppercaseLetter + , Char.LowercaseLetter + , Char.TitlecaseLetter + , Char.OtherLetter + , Char.DecimalNumber + , Char.LetterNumber + , Char.OtherNumber + , Char.ConnectorPunctuation + , Char.DashPunctuation + , Char.OpenPunctuation + , Char.InitialQuote + , Char.FinalQuote + , Char.OtherPunctuation + , Char.MathSymbol + , Char.CurrencySymbol + , Char.ModifierSymbol + , Char.OtherSymbol + ] + -- | -- Pretty print a PSString, using JavaScript escape sequences. Intended for -- use in compiled JS output. @@ -163,8 +201,8 @@ prettyPrintStringJS :: PSString -> Text prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\"" where encodeChar :: Word16 -> Text - encodeChar c | c > 0xFF = "\\u" <> hex 4 c - encodeChar c | c > 0x7E || c < 0x20 = "\\x" <> hex 2 c + encodeChar c | c > 0xFF = "\\u" <> showHex' 4 c + encodeChar c | c > 0x7E || c < 0x20 = "\\x" <> showHex' 2 c encodeChar c | toChar c == '\b' = "\\b" encodeChar c | toChar c == '\t' = "\\t" encodeChar c | toChar c == '\n' = "\\n" @@ -175,10 +213,10 @@ prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\"" encodeChar c | toChar c == '\\' = "\\\\" encodeChar c = T.singleton $ toChar c - hex :: (Enum a) => Int -> a -> Text - hex width c = - let hs = showHex (fromEnum c) "" in - T.pack (replicate (width - length hs) '0' <> hs) +showHex' :: Enum a => Int -> a -> Text +showHex' width c = + let hs = showHex (fromEnum c) "" in + T.pack (replicate (width - length hs) '0' <> hs) isLead :: Word16 -> Bool isLead h = h >= 0xD800 && h <= 0xDBFF From d62373fe16eaa7e620939f6d716727c55dac1e0b Mon Sep 17 00:00:00 2001 From: Brian Wignall Date: Sat, 30 Nov 2019 11:15:39 -0500 Subject: [PATCH 1170/1580] Fix typos (#3760) --- LICENSE | 2 +- src/Language/PureScript/Ide/Imports.hs | 2 +- src/Language/PureScript/Ide/Matcher.hs | 2 +- src/Language/PureScript/Interactive/Directive.hs | 2 +- src/Language/PureScript/Kinds.hs | 2 +- src/Language/PureScript/Sugar/Operators/Common.hs | 2 +- src/Language/PureScript/TypeChecker/Skolems.hs | 2 +- src/Language/PureScript/Types.hs | 2 +- tests/purs/warning/ScopeShadowing.purs | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) diff --git a/LICENSE b/LICENSE index 362b1f16a5..43c2285b5d 100644 --- a/LICENSE +++ b/LICENSE @@ -5060,7 +5060,7 @@ vector-algorithms LICENSE file: ------------------------------------------------------------------------------ The code in Data.Array.Vector.Algorithms.Mutable.Optimal is adapted from a C - algorithm for the same purpose. The folowing is the copyright notice for said + algorithm for the same purpose. The following is the copyright notice for said C code: Copyright (c) 2004 Paul Hsieh diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 6af718b929..46e55f44cd 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -303,7 +303,7 @@ addImportForIdentifier fp ident qual filters = do -- This case comes up for newtypes and dataconstructors. Because values and -- types don't share a namespace we can get multiple matches from the same -- module. This also happens for parameterized types, as these generate both - -- a type aswell as a type synonym. + -- a type as well as a type synonym. ms@[Match (m1, d1), Match (m2, d2)] -> if m1 /= m2 diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index e5bf21e504..1baf898e2c 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -52,7 +52,7 @@ instance FromJSON (Matcher IdeDeclarationAnn) where Just _ -> mzero Nothing -> return mempty --- | Matches any occurence of the search string with intersections +-- | Matches any occurrence of the search string with intersections -- -- The scoring measures how far the matches span the string where -- closer is better. diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs index 5538315e40..cee68efd35 100644 --- a/src/Language/PureScript/Interactive/Directive.hs +++ b/src/Language/PureScript/Interactive/Directive.hs @@ -12,7 +12,7 @@ import Data.Tuple (swap) import Language.PureScript.Interactive.Types -- | --- List of all avaliable directives. +-- List of all available directives. -- directives :: [Directive] directives = map fst directiveStrings diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 86686d65d0..0e7d19ce1a 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -98,7 +98,7 @@ kindFromJSON defaultAnn annFromJSON = A.withObject "Kind" $ \o -> do go :: Value -> Parser (Kind a) go = kindFromJSON defaultAnn annFromJSON --- These overlapping instances exist to preserve compatability for common +-- These overlapping instances exist to preserve compatibility for common -- instances which have a sensible default for missing annotations. instance {-# OVERLAPPING #-} A.FromJSON (Kind SourceAnn) where parseJSON = kindFromJSON (pure NullSourceAnn) A.parseJSON diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index 5cf68517da..a038d384e5 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -96,7 +96,7 @@ matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains -- grouping them by shared precedence, then if any of the following conditions -- are met, we have something to report: -- 1. any of the groups have mixed associativity - -- 2. there is more than one occurance of a non-associative operator in a + -- 2. there is more than one occurrence of a non-associative operator in a -- precedence group mkErrors :: Chain a -> [ErrorMessage] mkErrors chain = diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 170ea7ebcd..bfd47dde20 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -30,7 +30,7 @@ newSkolemConstant = do modify $ \st -> st { checkNextSkolem = s + 1 } return s --- | Introduce skolem scope at every occurence of a ForAll +-- | Introduce skolem scope at every occurrence of a ForAll introduceSkolemScope :: MonadState CheckState m => Type a -> m (Type a) introduceSkolemScope = everywhereOnTypesM go where diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index ae22b11b65..06c752a6f0 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -321,7 +321,7 @@ typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do go :: A.Value -> A.Parser (Type a) go = typeFromJSON defaultAnn annFromJSON --- These overlapping instances exist to preserve compatability for common +-- These overlapping instances exist to preserve compatibility for common -- instances which have a sensible default for missing annotations. instance {-# OVERLAPPING #-} A.FromJSON (Type SourceAnn) where parseJSON = typeFromJSON (pure NullSourceAnn) A.parseJSON diff --git a/tests/purs/warning/ScopeShadowing.purs b/tests/purs/warning/ScopeShadowing.purs index 380a4eef03..848eaf93c9 100644 --- a/tests/purs/warning/ScopeShadowing.purs +++ b/tests/purs/warning/ScopeShadowing.purs @@ -7,7 +7,7 @@ import Prelude data Unit = Unit -- This is only a warning as the `Prelude` import is implicit. If `Unit` was --- named explicitly in an import list, then this refernce to `Unit` +-- named explicitly in an import list, then this reference to `Unit` -- would be a `ScopeConflict` error instead. test :: Unit test = const Unit unit From c8418616e5d07a27f09cf8c67a93bc2018cb7113 Mon Sep 17 00:00:00 2001 From: Brian Wignall Date: Sat, 30 Nov 2019 12:35:48 -0500 Subject: [PATCH 1171/1580] Undo spelling change to LICENSE file (#3761) --- LICENSE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/LICENSE b/LICENSE index 43c2285b5d..362b1f16a5 100644 --- a/LICENSE +++ b/LICENSE @@ -5060,7 +5060,7 @@ vector-algorithms LICENSE file: ------------------------------------------------------------------------------ The code in Data.Array.Vector.Algorithms.Mutable.Optimal is adapted from a C - algorithm for the same purpose. The following is the copyright notice for said + algorithm for the same purpose. The folowing is the copyright notice for said C code: Copyright (c) 2004 Paul Hsieh From a647f07e9c7ced431ed5e48e4379e321c657710c Mon Sep 17 00:00:00 2001 From: Christoph Hegemann <6189397+kritzcreek@users.noreply.github.com> Date: Sun, 29 Dec 2019 19:21:36 +0100 Subject: [PATCH 1172/1580] [purs ide] Resets IDE state before performing a full reload (#3766) This way we're avoiding a space leak. (There might be more but this is good enough for the common case) --- src/Language/PureScript/Ide.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 58aafac16f..8e6e72246e 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -51,7 +51,8 @@ handleCommand -> m Success handleCommand c = case c of Load [] -> - findAvailableExterns >>= loadModulesAsync + -- Clearing the State before populating it to avoid a space leak + resetIdeState *> findAvailableExterns >>= loadModulesAsync Load modules -> loadModulesAsync modules LoadSync [] -> From 4ed2b1b36a5a0c9dc2bb59172fcb9829f658e027 Mon Sep 17 00:00:00 2001 From: Nicholas Scheel Date: Sun, 29 Dec 2019 12:22:20 -0600 Subject: [PATCH 1173/1580] Ambiguous variable check: take closure of fundeps across constraints (#3721) Previously the check when generalizing types only took into account each class individually and would miss variables that were determined from the interaction of multiple constraints. --- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Errors.hs | 12 +++- src/Language/PureScript/TypeChecker/Types.hs | 63 +++++++++++++++----- tests/purs/passing/3238.purs | 14 +++++ 4 files changed, 73 insertions(+), 18 deletions(-) create mode 100644 tests/purs/passing/3238.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 557cb51ea4..e4f6d0ed72 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -111,7 +111,7 @@ data SimpleErrorMessage | ConstrainedTypeUnified SourceType SourceType | OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified Ident] | NoInstanceFound SourceConstraint - | AmbiguousTypeVariables SourceType SourceConstraint + | AmbiguousTypeVariables SourceType [Int] | UnknownClass (Qualified (ProperName 'ClassName)) | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [SourceType] | CannotDerive (Qualified (ProperName 'ClassName)) [SourceType] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 1386ce6eab..19b2ab7fe2 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -286,7 +286,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con - gSimple (AmbiguousTypeVariables t con) = AmbiguousTypeVariables <$> f t <*> pure con + gSimple (AmbiguousTypeVariables t us) = AmbiguousTypeVariables <$> f t <*> pure us gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts @@ -679,10 +679,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl where go TUnknown{} = True go _ = False - renderSimpleErrorMessage (AmbiguousTypeVariables t _) = + renderSimpleErrorMessage (AmbiguousTypeVariables t us) = paras [ line "The inferred type" , markCodeBox $ indent $ typeAsBox prettyDepth t - , line "has type variables which are not mentioned in the body of the type. Consider adding a type annotation." + , line "has type variables which are not determined by those mentioned in the body of the type:" + , indent $ Box.hsep 1 Box.left + [ Box.vcat Box.left + [ line $ markCode ("t" <> T.pack (show u)) <> " could not be determined" + | u <- us ] + ] + , line "Consider adding a type annotation." ] renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) = paras [ line "Type class instance for" diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index b0bc93d71a..24e1d9710a 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -25,7 +25,7 @@ module Language.PureScript.TypeChecker.Types -} import Prelude.Compat -import Protolude (ordNub) +import Protolude (ordNub, fold, atMay) import Control.Arrow (first, second, (***)) import Control.Monad @@ -110,21 +110,56 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do . throwError . errorMessage' ss $ CannotGeneralizeRecursiveFunction ident generalized - -- Make sure any unsolved type constraints only use type variables which appear - -- unknown in the inferred type. - forM_ unsolved $ \(_, _, con) -> do - -- We need information about functional dependencies, since we allow - -- ambiguous types to be inferred if they can be solved by some functional - -- dependency. + -- We need information about functional dependencies, since we allow + -- ambiguous types to be inferred if they can be solved by some functional + -- dependency. + conData <- forM unsolved $ \(_, _, con) -> do let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup (constraintClass con) TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv) - let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies - let constraintTypeVars = ordNub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..] - when (any (`notElem` unsolvedTypeVars) constraintTypeVars) . - throwError - . onErrorMessages (replaceTypes currentSubst) - . errorMessage' ss - $ AmbiguousTypeVariables generalized con + let + -- The set of unknowns mentioned in each argument. + unknownsForArg :: [S.Set Int] + unknownsForArg = + map (S.fromList . map snd . unknownsInType) (constraintArgs con) + pure (typeClassDependencies, unknownsForArg) + -- Make sure any unsolved type constraints are determined by the + -- type variables which appear unknown in the inferred type. + let + -- Take the closure of fundeps across constraints, to get more + -- and more solved variables until reaching a fixpoint. + solveFrom :: S.Set Int -> S.Set Int + solveFrom determined = do + let solved = solve1 determined + if solved `S.isSubsetOf` determined + then determined + else solveFrom (determined <> solved) + solve1 :: S.Set Int -> S.Set Int + solve1 determined = fold $ do + (tcDeps, conArgUnknowns) <- conData + let + lookupUnknowns :: Int -> Maybe (S.Set Int) + lookupUnknowns = atMay conArgUnknowns + unknownsDetermined :: Maybe (S.Set Int) -> Bool + unknownsDetermined Nothing = False + unknownsDetermined (Just unknowns) = + unknowns `S.isSubsetOf` determined + -- If all of the determining arguments of a particular fundep are + -- already determined, add the determined arguments from the fundep + tcDep <- tcDeps + guard $ all (unknownsDetermined . lookupUnknowns) (fdDeterminers tcDep) + map (fromMaybe S.empty . lookupUnknowns) (fdDetermined tcDep) + -- These unknowns can be determined from the body of the inferred + -- type (i.e. excluding the unknowns mentioned in the constraints) + let determinedFromType = S.fromList . map snd $ unsolvedTypeVars + -- These are all the unknowns mentioned in the constraints + let constraintTypeVars = fold (conData >>= snd) + let solved = solveFrom determinedFromType + let unsolvedVars = S.difference constraintTypeVars solved + when (not (S.null unsolvedVars)) . + throwError + . onErrorMessages (replaceTypes currentSubst) + . errorMessage' ss + $ AmbiguousTypeVariables generalized (S.toList unsolvedVars) -- Check skolem variables did not escape their scope skolemEscapeCheck val' diff --git a/tests/purs/passing/3238.purs b/tests/purs/passing/3238.purs new file mode 100644 index 0000000000..5c40f2379f --- /dev/null +++ b/tests/purs/passing/3238.purs @@ -0,0 +1,14 @@ +module Main where + +import Effect.Console (log) + +class C a + +class FD a b | a -> b + +fn1 :: forall a b. FD a b => C b => a -> String +fn1 _ = "" + +fn2 x = fn1 x + +main = log "Done" From 8b1690e3bcb657d4aabbb5852d438f5a32f0d509 Mon Sep 17 00:00:00 2001 From: Dario Oddenino Date: Sun, 29 Dec 2019 19:23:16 +0100 Subject: [PATCH 1174/1580] Added spans to ado desugaring (#3758) Fixes #3754 --- src/Language/PureScript/Sugar/AdoNotation.hs | 49 ++++++++++---------- 1 file changed, 25 insertions(+), 24 deletions(-) diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs index f7e84bccc2..46f12a1839 100644 --- a/src/Language/PureScript/Sugar/AdoNotation.hs +++ b/src/Language/PureScript/Sugar/AdoNotation.hs @@ -25,43 +25,44 @@ desugarAdoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds des -- | Desugar a single ado statement desugarAdo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration desugarAdo d = - let (f, _, _) = everywhereOnValuesM return replace return - in f d + let ss = declSourceSpan d + (f, _, _) = everywhereOnValuesM return (replace ss) return + in rethrowWithPosition ss $ f d where - pure' :: Maybe ModuleName -> Expr - pure' m = Var nullSourceSpan (Qualified m (Ident C.pure')) + pure' :: SourceSpan -> Maybe ModuleName -> Expr + pure' ss m = Var ss (Qualified m (Ident C.pure')) - map' :: Maybe ModuleName -> Expr - map' m = Var nullSourceSpan (Qualified m (Ident C.map)) + map' :: SourceSpan -> Maybe ModuleName -> Expr + map' ss m = Var ss (Qualified m (Ident C.map)) - apply :: Maybe ModuleName -> Expr - apply m = Var nullSourceSpan (Qualified m (Ident C.apply)) + apply :: SourceSpan -> Maybe ModuleName -> Expr + apply ss m = Var ss (Qualified m (Ident C.apply)) - replace :: Expr -> m Expr - replace (Ado m els yield) = do - (func, args) <- foldM go (yield, []) (reverse els) + replace :: SourceSpan -> Expr -> m Expr + replace pos (Ado m els yield) = do + (func, args) <- foldM (go pos) (yield, []) (reverse els) return $ case args of - [] -> App (pure' m) func - hd : tl -> foldl' (\a b -> App (App (apply m) a) b) (App (App (map' m) func) hd) tl - replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v) - replace other = return other + [] -> App (pure' pos m) func + hd : tl -> foldl' (\a b -> App (App (apply pos m) a) b) (App (App (map' pos m) func) hd) tl + replace _ (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace pos v) + replace _ other = return other - go :: (Expr, [Expr]) -> DoNotationElement -> m (Expr, [Expr]) - go (yield, args) (DoNotationValue val) = + go :: SourceSpan -> (Expr, [Expr]) -> DoNotationElement -> m (Expr, [Expr]) + go _ (yield, args) (DoNotationValue val) = return (Abs NullBinder yield, val : args) - go (yield, args) (DoNotationBind (VarBinder ss ident) val) = + go _ (yield, args) (DoNotationBind (VarBinder ss ident) val) = return (Abs (VarBinder ss ident) yield, val : args) - go (yield, args) (DoNotationBind binder val) = do + go ss (yield, args) (DoNotationBind binder val) = do ident <- freshIdent' - let abs = Abs (VarBinder nullSourceSpan ident) - (Case [Var nullSourceSpan (Qualified Nothing ident)] + let abs = Abs (VarBinder ss ident) + (Case [Var ss (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded yield]]) return (abs, val : args) - go (yield, args) (DoNotationLet ds) = do + go _ (yield, args) (DoNotationLet ds) = do return (Let FromLet ds yield, args) - go acc (PositionedDoNotationElement pos com el) = + go _ acc (PositionedDoNotationElement pos com el) = rethrowWithPosition pos $ do - (yield, args) <- go acc el + (yield, args) <- go pos acc el return $ case args of [] -> (PositionedValue pos com yield, args) (a : as) -> (yield, PositionedValue pos com a : as) From 92fb47bf63394b824f9daa007a20d8a328e12f9e Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 29 Dec 2019 18:24:30 +0000 Subject: [PATCH 1175/1580] Generate correct arity failure case for some guarded matches (#3763) Specifically when a multi-way case contains a pattern guard or multiple guard expressions, the desugared case expression may contain a guard with a different arity to the matched expressions. --- .../PureScript/Sugar/CaseDeclarations.hs | 19 ++++++++++--------- tests/purs/passing/Guards.purs | 6 ++++++ 2 files changed, 16 insertions(+), 9 deletions(-) diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 6199de9701..a03457b61a 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -171,8 +171,8 @@ desugarGuardedExprs ss (Case scrut alternatives) = -- if the binder is a var binder we must not add -- the fail case as it results in unreachable -- alternative - alt_fail' | all isIrrefutable vb = [] - | otherwise = alt_fail + alt_fail' n | all isIrrefutable vb = [] + | otherwise = alt_fail n -- we are here: @@ -186,18 +186,18 @@ desugarGuardedExprs ss (Case scrut alternatives) = -- in Case scrut (CaseAlternative vb [MkUnguarded (desugarGuard gs e alt_fail)] - : alt_fail') + : (alt_fail' (length scrut))) return [ CaseAlternative scrut_nullbinder [MkUnguarded rhs]] - desugarGuard :: [Guard] -> Expr -> [CaseAlternative] -> Expr + desugarGuard :: [Guard] -> Expr -> (Int ->[CaseAlternative]) -> Expr desugarGuard [] e _ = e desugarGuard (ConditionGuard c : gs) e match_failed | isTrueExpr c = desugarGuard gs e match_failed | otherwise = Case [c] (CaseAlternative [LiteralBinder ss (BooleanLiteral True)] - [MkUnguarded (desugarGuard gs e match_failed)] : match_failed) + [MkUnguarded (desugarGuard gs e match_failed)] : match_failed 1) desugarGuard (PatternGuard vb g : gs) e match_failed = Case [g] @@ -206,7 +206,7 @@ desugarGuardedExprs ss (Case scrut alternatives) = where -- don't consider match_failed case if the binder is irrefutable match_failed' | isIrrefutable vb = [] - | otherwise = match_failed + | otherwise = match_failed 1 -- we generate a let-binding for the remaining guards -- and alternatives. A CaseAlternative is passed (or in @@ -215,7 +215,7 @@ desugarGuardedExprs ss (Case scrut alternatives) = desugarAltOutOfLine :: [Binder] -> [GuardedExpr] -> [CaseAlternative] - -> ([CaseAlternative] -> Expr) + -> ((Int -> [CaseAlternative]) -> Expr) -> m Expr desugarAltOutOfLine alt_binder rem_guarded rem_alts mk_body | Just rem_case <- mkCaseOfRemainingGuardsAndAlts = do @@ -228,7 +228,8 @@ desugarGuardedExprs ss (Case scrut alternatives) = goto_rem_case :: Expr goto_rem_case = Var ss (Qualified Nothing rem_case_id) `App` Literal ss (BooleanLiteral True) - alt_fail = [CaseAlternative [NullBinder] [MkUnguarded goto_rem_case]] + alt_fail :: Int -> [CaseAlternative] + alt_fail n = [CaseAlternative (replicate n NullBinder) [MkUnguarded goto_rem_case]] pure $ Let FromLet [ ValueDecl (ss, []) rem_case_id Private [] @@ -236,7 +237,7 @@ desugarGuardedExprs ss (Case scrut alternatives) = ] (mk_body alt_fail) | otherwise - = pure $ mk_body [] + = pure $ mk_body (const []) where mkCaseOfRemainingGuardsAndAlts | not (null rem_guarded) diff --git a/tests/purs/passing/Guards.purs b/tests/purs/passing/Guards.purs index 2894d2e9c8..c62c0bd424 100644 --- a/tests/purs/passing/Guards.purs +++ b/tests/purs/passing/Guards.purs @@ -34,6 +34,12 @@ clunky1 a b | x <- max a b = x clunky1 a _ = a +clunky1_refutable :: Int -> Int -> Int +clunky1_refutable 0 a | x <- max a a + , x > 5 + = x +clunky1_refutable a _ = a + clunky2 :: Int -> Int -> Int clunky2 a b | x <- max a b , x > 5 From 25afff7f05d0ebe4930216a1f8879ee4d1ed76af Mon Sep 17 00:00:00 2001 From: Colin Wahl Date: Sat, 11 Jan 2020 14:08:10 -0800 Subject: [PATCH 1176/1580] optimize import desugaring for full builds (#3768) * WIP * WIP * lint * dont add current module to env until it is a dependency of another module * cleanup * a bit more cleanup * remove stack.yaml.lock * inline various hush/ignore/silenceWarnings helpers --- src/Language/PureScript/Docs/Convert.hs | 12 +- src/Language/PureScript/Interactive/Types.hs | 11 +- src/Language/PureScript/Make.hs | 31 ++++- src/Language/PureScript/Make/BuildPlan.hs | 7 +- src/Language/PureScript/Sugar.hs | 7 +- src/Language/PureScript/Sugar/Names.hs | 118 ++++++++++--------- 6 files changed, 109 insertions(+), 77 deletions(-) diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index c2f8a7556d..a7af1137c4 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -35,11 +35,12 @@ import qualified Language.PureScript.Types as P convertModule :: MonadError P.MultipleErrors m => [P.ExternsFile] -> + P.Env -> P.Environment -> P.Module -> m Module -convertModule externs checkEnv m = - partiallyDesugar externs [m] >>= \case +convertModule externs env checkEnv m = + partiallyDesugar externs env [m] >>= \case [m'] -> pure (insertValueTypes checkEnv (convertSingleModule m')) _ -> P.internalError "partiallyDesugar did not return a singleton" @@ -88,9 +89,10 @@ runParser p = partiallyDesugar :: (MonadError P.MultipleErrors m) => [P.ExternsFile] -> + P.Env -> [P.Module] -> m [P.Module] -partiallyDesugar externs = evalSupplyT 0 . desugar' +partiallyDesugar externs env = evalSupplyT 0 . desugar' where desugar' = traverse P.desugarDoModule @@ -98,10 +100,8 @@ partiallyDesugar externs = evalSupplyT 0 . desugar' >=> map P.desugarLetPatternModule >>> traverse P.desugarCasesModule >=> traverse P.desugarTypeDeclarationsModule - >=> ignoreWarnings . P.desugarImports externs + >=> fmap fst . runWriterT . P.desugarImports env >=> P.rebracketFiltered isInstanceDecl externs - ignoreWarnings = fmap fst . runWriterT - isInstanceDecl (P.TypeInstanceDeclaration {}) = True isInstanceDecl _ = False diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index 84e926b914..cb4693e77c 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -35,6 +35,7 @@ import qualified Language.PureScript as P import qualified Data.Map as M import Data.List (foldl') import Language.PureScript.Sugar.Names.Env (nullImports, primExports) +import Control.Monad (foldM) import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Writer.Strict (runWriterT) @@ -118,7 +119,7 @@ psciImportedModuleNames st = -- ensure that completions remain accurate. updateImportExports :: PSCiState -> PSCiState updateImportExports st@(PSCiState modules lets externs iprint _ _) = - case desugarModule [temporaryModule] of + case createEnv (map snd externs) >>= flip desugarModule [temporaryModule] of Left _ -> st -- TODO: can this fail and what should we do? Right (env, _) -> case M.lookup temporaryName env of @@ -126,9 +127,11 @@ updateImportExports st@(PSCiState modules lets externs iprint _ _) = _ -> st -- impossible where - desugarModule :: [P.Module] -> Either P.MultipleErrors (P.Env, [P.Module]) - desugarModule = runExceptT =<< hushWarnings . P.desugarImportsWithEnv (map snd externs) - hushWarnings = fmap fst . runWriterT + desugarModule :: P.Env -> [P.Module] -> Either P.MultipleErrors (P.Env, [P.Module]) + desugarModule e = runExceptT =<< fmap fst . runWriterT . P.desugarImportsWithEnv e + + createEnv :: [P.ExternsFile] -> Either P.MultipleErrors P.Env + createEnv = runExceptT =<< fmap fst . runWriterT . foldM P.externsEnv P.primEnv temporaryName :: P.ModuleName temporaryName = P.ModuleName [P.ProperName "$PSCI"] diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 55b3ebf26d..5fb02a5159 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -17,6 +17,7 @@ import Control.Monad.IO.Class import Control.Monad.Supply import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Writer.Strict (runWriterT) import Data.Function (on) import Data.Foldable (for_) import Data.List (foldl', sortBy) @@ -57,13 +58,25 @@ rebuildModule -> [ExternsFile] -> Module -> m ExternsFile -rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do +rebuildModule actions externs m = do + env <- fmap fst . runWriterT $ foldM externsEnv primEnv externs + rebuildModule' actions env externs m + +rebuildModule' + :: forall m + . (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => MakeActions m + -> Env + -> [ExternsFile] + -> Module + -> m ExternsFile +rebuildModule' MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) = do progress $ CompilingModule moduleName let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs withPrim = importPrim m lint withPrim ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do - desugar externs [withPrim] >>= \case + desugar exEnv externs [withPrim] >>= \case [desugared] -> runCheck' (emptyCheckState env) $ typeCheckModule desugared _ -> internalError "desugar did not return a singleton" @@ -88,7 +101,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do -- a bug in the compiler, which should be reported as such. -- 2. We do not want to perform any extra work generating docs unless the -- user has asked for docs to be generated. - let docs = case Docs.convertModule externs env' m of + let docs = case Docs.convertModule externs exEnv env' m of Left errs -> internalError $ "Failed to produce docs for " ++ T.unpack (runModuleName moduleName) ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs @@ -192,7 +205,17 @@ make ma@MakeActions{..} ms = do case mexterns of Just (_, externs) -> do - (exts, warnings) <- listen $ rebuildModule ma externs m + -- We need to ensure that all dependencies have been included in Env + C.modifyMVar_ (bpEnv buildPlan) $ \env -> do + let + go :: Env -> ModuleName -> m Env + go e dep = case lookup dep (zip deps externs) of + Just exts + | not (M.member dep e) -> externsEnv e exts + _ -> return e + foldM go env deps + env <- C.readMVar (bpEnv buildPlan) + (exts, warnings) <- listen $ rebuildModule' ma env externs m return $ BuildJobSucceeded warnings exts Nothing -> return BuildJobSkipped diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 14f5181952..8d409f6699 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -1,5 +1,5 @@ module Language.PureScript.Make.BuildPlan - ( BuildPlan() + ( BuildPlan(bpEnv) , BuildJobResult(..) , buildJobSuccess , buildJobFailure @@ -29,12 +29,14 @@ import Language.PureScript.Externs import Language.PureScript.Make.Actions as Actions import Language.PureScript.Make.Cache import Language.PureScript.Names (ModuleName) +import Language.PureScript.Sugar.Names.Env -- | The BuildPlan tracks information about our build progress, and holds all -- prebuilt modules for incremental builds. data BuildPlan = BuildPlan { bpPrebuilt :: M.Map ModuleName Prebuilt , bpBuildJobs :: M.Map ModuleName BuildJob + , bpEnv :: C.MVar Env } data Prebuilt = Prebuilt @@ -140,8 +142,9 @@ construct MakeActions{..} cacheDb (sorted, graph) = do mapMaybe (\s -> (statusModuleName s, statusRebuildNever s,) <$> statusPrebuilt s) rebuildStatuses let toBeRebuilt = filter (not . flip M.member prebuilt) sortedModuleNames buildJobs <- foldM makeBuildJob M.empty toBeRebuilt + env <- C.newMVar primEnv pure - ( BuildPlan prebuilt buildJobs + ( BuildPlan prebuilt buildJobs env , let update = flip $ \s -> M.alter (const (statusNewCacheInfo s)) (statusModuleName s) diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 99d422c76c..da0d10bc1a 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -54,10 +54,11 @@ import Language.PureScript.Sugar.TypeDeclarations as S -- desugar :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => [ExternsFile] + => Env + -> [ExternsFile] -> [Module] -> m [Module] -desugar externs = +desugar env externs = map desugarSignedLiterals >>> traverse desugarObjectConstructors >=> traverse desugarDoModule @@ -65,7 +66,7 @@ desugar externs = >=> map desugarLetPatternModule >>> traverse desugarCasesModule >=> traverse desugarTypeDeclarationsModule - >=> desugarImports externs + >=> desugarImports env >=> rebracket externs >=> traverse checkFixityExports >=> traverse (deriveInstances externs) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index fcf7f469d3..5aa7cb89d4 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -2,6 +2,7 @@ module Language.PureScript.Sugar.Names ( desugarImports , desugarImportsWithEnv , Env + , externsEnv , primEnv , ImportRecord(..) , ImportProvenance(..) @@ -16,7 +17,7 @@ import Control.Arrow (first) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Lazy -import Control.Monad.Writer (MonadWriter(..), censor) +import Control.Monad.Writer (MonadWriter(..)) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M @@ -42,73 +43,22 @@ import Language.PureScript.Types desugarImports :: forall m . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => [ExternsFile] + => Env -> [Module] -> m [Module] -desugarImports externs modules = - fmap snd (desugarImportsWithEnv externs modules) +desugarImports env modules = + fmap snd (desugarImportsWithEnv env modules) desugarImportsWithEnv :: forall m . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => [ExternsFile] + => Env -> [Module] -> m (Env, [Module]) -desugarImportsWithEnv externs modules = do - env <- silence $ foldM externsEnv primEnv externs - (modules', env') <- first reverse <$> foldM updateEnv ([], env) modules +desugarImportsWithEnv e modules = do + (modules', env') <- first reverse <$> foldM updateEnv ([], e) modules (env',) <$> traverse (renameInModule' env') modules' where - silence :: m a -> m a - silence = censor (const mempty) - - -- | Create an environment from a collection of externs files - externsEnv :: Env -> ExternsFile -> m Env - externsEnv env ExternsFile{..} = do - let members = Exports{..} - env' = M.insert efModuleName (efSourceSpan, nullImports, members) env - fromEFImport (ExternsImport mn mt qmn) = (mn, [(efSourceSpan, Just mt, qmn)]) - imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports) - exps <- resolveExports env' efSourceSpan efModuleName imps members efExports - return $ M.insert efModuleName (efSourceSpan, imps, exps) env - where - - -- An ExportSource for declarations local to the module which the given - -- ExternsFile corresponds to. - localExportSource = - ExportSource { exportSourceDefinedIn = efModuleName - , exportSourceImportedFrom = Nothing - } - - exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource) - exportedTypes = M.fromList $ mapMaybe toExportedType efExports - where - toExportedType (TypeRef _ tyCon dctors) = Just (tyCon, (fromMaybe (mapMaybe forTyCon efDeclarations) dctors, localExportSource)) - where - forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName) - forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn - forTyCon _ = Nothing - toExportedType _ = Nothing - - exportedTypeOps :: M.Map (OpName 'TypeOpName) ExportSource - exportedTypeOps = exportedRefs getTypeOpRef - - exportedTypeClasses :: M.Map (ProperName 'ClassName) ExportSource - exportedTypeClasses = exportedRefs getTypeClassRef - - exportedValues :: M.Map Ident ExportSource - exportedValues = exportedRefs getValueRef - - exportedValueOps :: M.Map (OpName 'ValueOpName) ExportSource - exportedValueOps = exportedRefs getValueOpRef - - exportedKinds :: M.Map (ProperName 'KindName) ExportSource - exportedKinds = exportedRefs getKindRef - - exportedRefs :: Ord a => (DeclarationRef -> Maybe a) -> M.Map a ExportSource - exportedRefs f = - M.fromList $ (, localExportSource) <$> mapMaybe f efExports - updateEnv :: ([Module], Env) -> Module -> m ([Module], Env) updateEnv (ms, env) m@(Module ss _ mn _ refs) = do members <- findExportable m @@ -126,6 +76,58 @@ desugarImportsWithEnv externs modules = do lintImports m'' env used return m'' +-- | Create an environment from a collection of externs files +externsEnv + :: forall m + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Env + -> ExternsFile + -> m Env +externsEnv env ExternsFile{..} = do + let members = Exports{..} + env' = M.insert efModuleName (efSourceSpan, nullImports, members) env + fromEFImport (ExternsImport mn mt qmn) = (mn, [(efSourceSpan, Just mt, qmn)]) + imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports) + exps <- resolveExports env' efSourceSpan efModuleName imps members efExports + return $ M.insert efModuleName (efSourceSpan, imps, exps) env + where + + -- An ExportSource for declarations local to the module which the given + -- ExternsFile corresponds to. + localExportSource = + ExportSource { exportSourceDefinedIn = efModuleName + , exportSourceImportedFrom = Nothing + } + + exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource) + exportedTypes = M.fromList $ mapMaybe toExportedType efExports + where + toExportedType (TypeRef _ tyCon dctors) = Just (tyCon, (fromMaybe (mapMaybe forTyCon efDeclarations) dctors, localExportSource)) + where + forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName) + forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn + forTyCon _ = Nothing + toExportedType _ = Nothing + + exportedTypeOps :: M.Map (OpName 'TypeOpName) ExportSource + exportedTypeOps = exportedRefs getTypeOpRef + + exportedTypeClasses :: M.Map (ProperName 'ClassName) ExportSource + exportedTypeClasses = exportedRefs getTypeClassRef + + exportedValues :: M.Map Ident ExportSource + exportedValues = exportedRefs getValueRef + + exportedValueOps :: M.Map (OpName 'ValueOpName) ExportSource + exportedValueOps = exportedRefs getValueOpRef + + exportedKinds :: M.Map (ProperName 'KindName) ExportSource + exportedKinds = exportedRefs getKindRef + + exportedRefs :: Ord a => (DeclarationRef -> Maybe a) -> M.Map a ExportSource + exportedRefs f = + M.fromList $ (, localExportSource) <$> mapMaybe f efExports + -- | -- Make all exports for a module explicit. This may still affect modules that -- have an exports list, as it will also make all data constructor exports From 08bc0864870577460a6c037f7238f18a5f4f209d Mon Sep 17 00:00:00 2001 From: Matthew Leon Grinshpun Date: Sun, 12 Jan 2020 13:10:16 -0500 Subject: [PATCH 1177/1580] optimize away binds to wildcards in Do notation (#3220) * optimize away binds to wildcards in Do notation fixes https://github.com/purescript/purescript/issues/3192 * Better generated code for do notation - Preserve variable names from source code where possible - Avoid generating variable assignments in output where not necessary Co-authored-by: Harry Garrood --- .../PureScript/CoreImp/Optimizer/MagicDo.hs | 4 ++++ src/Language/PureScript/Sugar/DoNotation.hs | 24 +++++++++++++++---- 2 files changed, 23 insertions(+), 5 deletions(-) diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs index 1a2cde1327..c14988f50a 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs @@ -48,6 +48,10 @@ magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert -- Desugar discard convert (App _ (App _ bind [m]) [Function s1 Nothing [] (Block s2 js)]) | isDiscard bind = Function s1 (Just fnName) [] $ Block s2 (App s2 m [] : map applyReturns js ) + -- Desugar bind to wildcard + convert (App _ (App _ bind [m]) [Function s1 Nothing [] (Block s2 js)]) + | isBind bind = + Function s1 (Just fnName) [] $ Block s2 (App s2 m [] : map applyReturns js ) -- Desugar bind convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 js)]) | isBind bind = Function s1 (Just fnName) [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns js) diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 003580c15d..d7a9f7194e 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -7,8 +7,10 @@ module Language.PureScript.Sugar.DoNotation (desugarDoModule) where import Prelude.Compat +import Control.Applicative ((<|>)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class +import Data.Maybe (fromMaybe) import Data.Monoid (First(..)) import Language.PureScript.AST import Language.PureScript.Crash @@ -40,6 +42,13 @@ desugarDo d = replace _ (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace pos v) replace _ other = return other + stripPositionedBinder :: Binder -> (Maybe SourceSpan, Binder) + stripPositionedBinder (PositionedBinder ss _ b) = + let (ss', b') = stripPositionedBinder b + in (ss' <|> Just ss, b') + stripPositionedBinder b = + (Nothing, b) + go :: SourceSpan -> Maybe ModuleName -> [DoNotationElement] -> m Expr go _ _ [] = internalError "The impossible happened in desugarDo" go _ _ [DoNotationValue val] = return val @@ -52,13 +61,18 @@ desugarDo d = where fromIdent (Ident i) | i `elem` [ C.bind, C.discard ] = First (Just i) fromIdent _ = mempty - go pos m (DoNotationBind (VarBinder ss ident) val : rest) = do - rest' <- go pos m rest - return $ App (App (bind pos m) val) (Abs (VarBinder ss ident) rest') go pos m (DoNotationBind binder val : rest) = do rest' <- go pos m rest - ident <- freshIdent' - return $ App (App (bind pos m) val) (Abs (VarBinder pos ident) (Case [Var pos (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']])) + let (mss, binder') = stripPositionedBinder binder + let ss = fromMaybe pos mss + case binder' of + NullBinder -> + return $ App (App (bind pos m) val) (Abs (VarBinder ss UnusedIdent) rest') + VarBinder _ ident -> + return $ App (App (bind pos m) val) (Abs (VarBinder ss ident) rest') + _ -> do + ident <- freshIdent' + return $ App (App (bind pos m) val) (Abs (VarBinder pos ident) (Case [Var pos (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']])) go _ _ [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet go pos m (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () From 523422a602b8619cc5d8589d748259d79b065f0d Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Fri, 17 Jan 2020 01:11:41 +0100 Subject: [PATCH 1178/1580] Output docs.json files for Prim modules too (#3769) --- src/Language/PureScript/Make.hs | 3 +++ src/Language/PureScript/Make/Actions.hs | 11 ++++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 5fb02a5159..ec4b6254b6 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -151,6 +151,9 @@ make ma@MakeActions{..} ms = do -- Write the updated build cache database to disk writeCacheDb $ Cache.removeModules (M.keysSet failures) newCacheDb + -- If generating docs, also generate them for the Prim modules + outputPrimDocs + -- All threads have completed, rethrow any caught errors. let errors = M.elems failures unless (null errors) $ throwError (mconcat errors) diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 77374b140b..b3fe5ee0d7 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -36,6 +36,7 @@ import qualified Language.PureScript.CoreFn.ToJSON as CFJ import qualified Language.PureScript.CoreImp.AST as Imp import Language.PureScript.Crash import qualified Language.PureScript.CST as CST +import qualified Language.PureScript.Docs.Prim as Docs.Prim import qualified Language.PureScript.Docs.Types as Docs import Language.PureScript.Errors import Language.PureScript.Externs (ExternsFile) @@ -100,6 +101,8 @@ data MakeActions m = MakeActions , writeCacheDb :: CacheDb -> m () -- ^ Write the given cache database to some external source (e.g. a file on -- disk). + , outputPrimDocs :: m () + -- ^ If generating docs, output the documentation for the Prim modules } -- | A set of make actions that read and write modules from the given directory. @@ -114,7 +117,7 @@ buildMakeActions -- ^ Generate a prefix comment? -> MakeActions Make buildMakeActions outputDir filePathMap foreigns usePrefix = - MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb + MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb outputPrimDocs where getInputTimestampsAndHashes @@ -157,6 +160,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = let path = outputDir T.unpack (runModuleName mn) "externs.json" (path, ) <$> readExternsFile path + outputPrimDocs :: Make () + outputPrimDocs = do + codegenTargets <- asks optionsCodegenTargets + when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module{..} -> + writeJSONFile (outputFilename modName "docs.json") docsMod + codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make () codegen m docs exts = do let mn = CF.moduleName m From 1cd8de3ed411d343d3ee67e5f2b7fb825b51aecc Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 16 Jan 2020 17:06:03 -0800 Subject: [PATCH 1179/1580] Bump versions for 0.13.6 (#3770) --- npm-package/package.json | 4 ++-- package.yaml | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/npm-package/package.json b/npm-package/package.json index b4cb5bbed0..d050c7a146 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.13.5", + "version": "0.13.6", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.13.5", + "postinstall": "install-purescript --purs-ver=0.13.6", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/package.yaml b/package.yaml index b4f51defd0..4de1f6e30c 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.13.5' +version: '0.13.6' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 3a5e5d3c6713aa0410bffc28df7ac2b42229db00 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 16 Jan 2020 17:25:39 -0800 Subject: [PATCH 1180/1580] Run license-generator (#3771) --- LICENSE | 192 +++++++++++++++++--------------------------------------- 1 file changed, 58 insertions(+), 134 deletions(-) diff --git a/LICENSE b/LICENSE index 362b1f16a5..52d6ce7166 100644 --- a/LICENSE +++ b/LICENSE @@ -47,6 +47,7 @@ PureScript uses the following Haskell library packages. Their license files foll bytestring-builder cabal-doctest case-insensitive + cereal cheapskate clock colour @@ -71,7 +72,6 @@ PureScript uses the following Haskell library packages. Their license files foll dlist easy-file edit-distance - enclosed-exceptions entropy exceptions fast-logger @@ -83,7 +83,7 @@ PureScript uses the following Haskell library packages. Their license files foll happy hashable haskeline - hinotify + hfsevents http-date http-types http2 @@ -129,7 +129,6 @@ PureScript uses the following Haskell library packages. Their license files foll semialign semigroupoids semigroups - shelly simple-sendfile sourcemap split @@ -138,8 +137,6 @@ PureScript uses the following Haskell library packages. Their license files foll streaming-commons stringsearch syb - system-fileio - system-filepath tagged tagsoup template-haskell @@ -1295,6 +1292,39 @@ case-insensitive LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +cereal LICENSE file: + + Copyright (c) Lennart Kolmodin, Galois, Inc. + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + cheapskate LICENSE file: Copyright (c) 2013, John MacFarlane @@ -2021,29 +2051,6 @@ edit-distance LICENSE file: IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -enclosed-exceptions LICENSE file: - - Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ - - Permission is hereby granted, free of charge, to any person obtaining - a copy of this software and associated documentation files (the - "Software"), to deal in the Software without restriction, including - without limitation the rights to use, copy, modify, merge, publish, - distribute, sublicense, and/or sell copies of the Software, and to - permit persons to whom the Software is furnished to do so, subject to - the following conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE - LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION - OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - entropy LICENSE file: Copyright (c) Thomas DuBuisson @@ -2428,38 +2435,38 @@ haskeline LICENSE file: OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -hinotify LICENSE file: +hfsevents LICENSE file: - Copyright (c) Lennart Kolmodin + Copyright (c) 2012, Luite Stegeman All rights reserved. Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: + modification, are permitted provided that the following conditions are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + * Neither the name of Luite Stegeman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS - OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. http-date LICENSE file: @@ -3947,39 +3954,6 @@ semigroups LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -shelly LICENSE file: - - Copyright (c) 2017, Petr Rockai - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Petr Rockai nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - simple-sendfile LICENSE file: Copyright (c) 2009, IIJ Innovation Institute Inc. @@ -4290,56 +4264,6 @@ syb LICENSE file: ----------------------------------------------------------------------------- -system-fileio LICENSE file: - - Copyright (c) 2011 John Millikin - - Permission is hereby granted, free of charge, to any person - obtaining a copy of this software and associated documentation - files (the "Software"), to deal in the Software without - restriction, including without limitation the rights to use, - copy, modify, merge, publish, distribute, sublicense, and/or sell - copies of the Software, and to permit persons to whom the - Software is furnished to do so, subject to the following - conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES - OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT - HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, - WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING - FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR - OTHER DEALINGS IN THE SOFTWARE. - -system-filepath LICENSE file: - - Copyright (c) 2010 John Millikin - - Permission is hereby granted, free of charge, to any person - obtaining a copy of this software and associated documentation - files (the "Software"), to deal in the Software without - restriction, including without limitation the rights to use, - copy, modify, merge, publish, distribute, sublicense, and/or sell - copies of the Software, and to permit persons to whom the - Software is furnished to do so, subject to the following - conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES - OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT - HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, - WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING - FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR - OTHER DEALINGS IN THE SOFTWARE. - tagged LICENSE file: Copyright (c) 2009-2015 Edward Kmett From 4dd32c48a372bb8a5250140d19af8aa18a6358d7 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 17 Jan 2020 01:25:50 +0000 Subject: [PATCH 1181/1580] Update RELEASE_GUIDE.md (#3772) Renamed from RELEASE_CHECKLIST.md because it's more of a guide than a checklist now. --- RELEASE_CHECKLIST.md | 62 ------------------------------------ RELEASE_GUIDE.md | 75 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 75 insertions(+), 62 deletions(-) delete mode 100644 RELEASE_CHECKLIST.md create mode 100644 RELEASE_GUIDE.md diff --git a/RELEASE_CHECKLIST.md b/RELEASE_CHECKLIST.md deleted file mode 100644 index f3ec657f6e..0000000000 --- a/RELEASE_CHECKLIST.md +++ /dev/null @@ -1,62 +0,0 @@ -# Release Checklist - -## For every release - -- [ ] Regenerate LICENSE (see `license-generator/`) -- [ ] Release notes -- [ ] Publish to Hackage -- [ ] Update npm package -- [ ] Try PureScript? — need to decide whether we want to continue - officially supporting this - -## Libraries - -Are there breaking changes to the language? Or alternatively, are there -language changes which require breaking changes in the relevant libraries to -make use of? If so: - -- [ ] Update core libraries -- [ ] Update contrib libraries -- [ ] Update node bindings -- [ ] Create a new package set - -## Tools - -Has the compiler CLI changed at all? If so, the following may need updates: - -- [ ] psc-package -- [ ] Pulp -- [ ] purs-loader -- [ ] ide plugins - -## JSON formats - -Have any of the following JSON formats changed? If so, it may be worth -considering what effects this may have: - -- [ ] Corefn -- [ ] Ide protocol -- [ ] JSON produced by `purs publish` - - [ ] check whether this affects Pursuit - -## Documentation - -- [ ] Check that purescript.org is up-to-date -- [ ] Check that INSTALL.md is up-to-date - -Have there been any changes or additions to the language which should be -documented? - -- [ ] Document any language changes in the documentation repo - -Have there been additions or changes to `Prim` (including documentation -changes?) If so, - -- [ ] Update Pursuit to depend on the latest compiler so that these docs appear - on pursuit.purescript.org - -## Announcements - -- [ ] Discourse -- [ ] Twitter -- [ ] /r/purescript diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md new file mode 100644 index 0000000000..7b0d6acdb8 --- /dev/null +++ b/RELEASE_GUIDE.md @@ -0,0 +1,75 @@ +# Release Guide (for maintainers) + +## Before making a release + +- Check that INSTALL.md is up-to-date +- Regenerate LICENSE: `make license-generator` (see `license-generator/` for + details) +- Write release notes + +Additionally, if there are any breaking changes, there are number of downstream +projects who we should probably at least notify: + +### Libraries + +Are there breaking changes to the language? Or alternatively, are there +language changes which require breaking changes in the relevant libraries to +make use of? If so: + +- Update core libraries +- Update contrib libraries +- Update node bindings +- Update web bindings + +### Tools + +Has the compiler CLI changed at all? If so, the following may need updates: + +- spago +- pulp +- psc-package +- purs-loader +- ide plugins + +### JSON formats + +Have any of the following JSON formats changed? If so, it may be worth +considering what effects this may have: + +- Corefn +- Ide protocol +- JSON produced by `purs publish` + - this might affect Pursuit + +## Making a release + +- Make a commit bumping versions. The following should be updated: + - The `version` field in `package.yaml` + - The `version` field in `npm-package/package.json` + - The version to install in the `postinstall` script in `package.json` +- Create a release from the releases tab in GitHub and copy in the release + notes. This will also create a tag, which will kick off a CI build, which + will upload prebuilt compiler binaries to the release on GitHub when it + completes. (If the CI build fails, binaries can also be built locally and + manually uploaded to the release on GitHub) +- Publish to Hackage: change to the compiler directory and run `stack upload .`. + It's a good idea to check that the package can be installed from Hackage at + this point. +- After all of the prebuilt binaries are present on the GitHub releases page, + publish to npm: change to the `npm-package` directory and run `npm publish`. + It's a good idea to check that the package can be installed from npm at this + point. + +## After making a release + +- Document any language changes in the documentation repo + - In particular, it's worth checking that the getting started guide in the + documentation repo still works +- If there have been changes to any `Prim` modules (even if they are just + documentation changes), update Pursuit to depend on the latest compiler so + that these docs appear on pursuit.purescript.org +- Update Try PureScript +- Make release announcements: + - Discourse + - Twitter + - /r/purescript From 0e1c024849572c309ff89a8b9fe22f4fda9fef4d Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 30 Jan 2020 21:55:48 +0100 Subject: [PATCH 1182/1580] Add versions bounds (#3777) The version bounds are too permisive. Cabal needs to be constraint with <3.0 and haskeline with <0.8 version bounds. --- package.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/package.yaml b/package.yaml index 4de1f6e30c..9ef2fbebbd 100644 --- a/package.yaml +++ b/package.yaml @@ -48,7 +48,7 @@ dependencies: - bower-json >=1.0.0.1 && <1.1 - boxes >=0.1.4 && <0.2.0 - bytestring - - Cabal >= 2.2 + - Cabal >= 2.2 && <3.0 - cheapskate >=0.1 && <0.2 - clock - containers @@ -62,7 +62,7 @@ dependencies: - filepath - fsnotify >=0.2.1 - Glob >=0.9 && <0.10 - - haskeline >=0.7.0.0 + - haskeline >=0.7.0.0 && <0.8.0.0 - language-javascript >=0.7.0.0 - lifted-async >=0.10.0.3 && <0.10.1 - lifted-base >=0.2.3 && <0.2.4 From 27f6cf05e4eb22a6421bdd274942d53ba825f45f Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Sat, 1 Feb 2020 20:01:46 +0100 Subject: [PATCH 1183/1580] Add `graph` command for graphing module dependencies (#3781) * First draft * Add tests for the graph command * Apply review suggestions * Remove redundant case Co-authored-by: Jordan Mackie --- app/Command/Graph.hs | 101 ++++++++++++++++++++++++ app/Main.hs | 4 + package.yaml | 1 + src/Language/PureScript.hs | 1 + src/Language/PureScript/Graph.hs | 57 +++++++++++++ tests/Main.hs | 3 + tests/TestGraph.hs | 39 +++++++++ tests/purs/graph/graph.json | 1 + tests/purs/graph/src/Module.purs | 9 +++ tests/purs/graph/src/Module2.purs | 4 + tests/purs/graph/src/ModuleFailing.purs | 5 ++ 11 files changed, 225 insertions(+) create mode 100644 app/Command/Graph.hs create mode 100644 src/Language/PureScript/Graph.hs create mode 100644 tests/TestGraph.hs create mode 100644 tests/purs/graph/graph.json create mode 100644 tests/purs/graph/src/Module.purs create mode 100644 tests/purs/graph/src/Module2.purs create mode 100644 tests/purs/graph/src/ModuleFailing.purs diff --git a/app/Command/Graph.hs b/app/Command/Graph.hs new file mode 100644 index 0000000000..b1bf505b13 --- /dev/null +++ b/app/Command/Graph.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Command.Graph (command) where + +import Control.Applicative (many) +import Control.Monad (unless, when) +import qualified Data.Aeson as Json +import Data.Bool (bool) +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Lazy.UTF8 as LBU8 +import qualified Language.PureScript as P +import Language.PureScript.Errors.JSON +import qualified Options.Applicative as Opts +import qualified System.Console.ANSI as ANSI +import System.Exit (exitFailure) +import System.Directory (getCurrentDirectory) +import System.FilePath.Glob (glob) +import System.IO (hPutStr, hPutStrLn, stderr) + +data GraphOptions = GraphOptions + { graphInput :: [FilePath] + , graphJSONErrors :: Bool + } + +graph :: GraphOptions -> IO () +graph GraphOptions{..} = do + input <- globWarningOnMisses (unless graphJSONErrors . warnFileTypeNotFound) graphInput + when (null input && not graphJSONErrors) $ do + hPutStr stderr $ unlines + [ "purs graph: No input files." + , "Usage: For basic information, try the `--help' option." + ] + exitFailure + + (makeResult, makeWarnings) <- P.graph input + + printWarningsAndErrors graphJSONErrors makeWarnings makeResult + >>= (LB.putStr . Json.encode) + + where + warnFileTypeNotFound :: String -> IO () + warnFileTypeNotFound = + hPutStrLn stderr . ("purs graph: No files found using pattern: " <>) + + +command :: Opts.Parser (IO ()) +command = graph <$> (Opts.helper <*> graphOptions) + where + graphOptions :: Opts.Parser GraphOptions + graphOptions = + GraphOptions <$> many inputFile + <*> jsonErrors + + inputFile :: Opts.Parser FilePath + inputFile = + Opts.strArgument $ + Opts.metavar "FILE" <> + Opts.help "The input .purs file(s)." + + jsonErrors :: Opts.Parser Bool + jsonErrors = + Opts.switch $ + Opts.long "json-errors" <> + Opts.help "Print errors to stderr as JSON" + +-- | Arguments: use JSON, warnings, errors +printWarningsAndErrors :: Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO a +printWarningsAndErrors False warnings errors = do + pwd <- getCurrentDirectory + cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stderr + let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = True, P.ppeRelativeDirectory = pwd } + when (P.nonEmpty warnings) $ + hPutStrLn stderr (P.prettyPrintMultipleWarnings ppeOpts warnings) + case errors of + Left errs -> do + hPutStrLn stderr (P.prettyPrintMultipleErrors ppeOpts errs) + exitFailure + Right res -> pure res +printWarningsAndErrors True warnings errors = do + let verbose = True + hPutStrLn stderr . LBU8.toString . Json.encode $ + JSONResult (toJSONErrors verbose P.Warning warnings) + (either (toJSONErrors verbose P.Error) (const []) errors) + case errors of + Left _errs -> exitFailure + Right res -> pure res + + +globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath] +globWarningOnMisses warn = concatMapM globWithWarning + where + globWithWarning :: String -> IO [FilePath] + globWithWarning pattern' = do + paths <- glob pattern' + when (null paths) $ warn pattern' + return paths + + concatMapM :: (a -> IO [b]) -> [a] -> IO [b] + concatMapM f = fmap concat . mapM f diff --git a/app/Main.hs b/app/Main.hs index f3e72ab68a..4b5b7df5d8 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,6 +10,7 @@ module Main where import qualified Command.Bundle as Bundle import qualified Command.Compile as Compile import qualified Command.Docs as Docs +import qualified Command.Graph as Graph import qualified Command.Hierarchy as Hierarchy import qualified Command.Ide as Ide import qualified Command.Publish as Publish @@ -69,6 +70,9 @@ main = do , Opts.command "docs" (Opts.info Docs.command (Opts.progDesc "Generate documentation from PureScript source files in a variety of formats, including Markdown and HTML" <> Docs.infoModList)) + , Opts.command "graph" + (Opts.info Graph.command + (Opts.progDesc "Module dependency graph")) , Opts.command "hierarchy" (Opts.info Hierarchy.command (Opts.progDesc "Generate a GraphViz directed graph of PureScript type classes")) diff --git a/package.yaml b/package.yaml index 9ef2fbebbd..16dc5ba741 100644 --- a/package.yaml +++ b/package.yaml @@ -136,6 +136,7 @@ executables: - Command.Docs - Command.Docs.Html - Command.Docs.Markdown + - Command.Graph - Command.Hierarchy - Command.Ide - Command.Publish diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index eeb0ebd4c1..40c843ea5e 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -17,6 +17,7 @@ import Language.PureScript.Crash as P import Language.PureScript.Environment as P import Language.PureScript.Errors as P hiding (indent) import Language.PureScript.Externs as P +import Language.PureScript.Graph as P import Language.PureScript.Kinds as P import Language.PureScript.Linter as P import Language.PureScript.Make as P diff --git a/src/Language/PureScript/Graph.hs b/src/Language/PureScript/Graph.hs new file mode 100644 index 0000000000..af79555ebc --- /dev/null +++ b/src/Language/PureScript/Graph.hs @@ -0,0 +1,57 @@ +module Language.PureScript.Graph (graph) where + +import Prelude.Compat + +import qualified Data.Aeson as Json +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map as Map + +import Control.Monad (forM) +import Data.Aeson ((.=)) +import Data.Foldable (foldl') +import Data.Map (Map) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import System.IO.UTF8 (readUTF8FileT) + +import qualified Language.PureScript.Crash as Crash +import qualified Language.PureScript.CST as CST +import qualified Language.PureScript.Make as Make +import qualified Language.PureScript.ModuleDependencies as Dependencies +import qualified Language.PureScript.Options as Options + +import Language.PureScript.Errors (MultipleErrors) +import Language.PureScript.Names (ModuleName, runModuleName) + + +-- | Given a set of filepaths, try to build the dependency graph and return +-- that as its JSON representation (or a bunch of errors, if any) +graph :: [FilePath] -> IO (Either MultipleErrors Json.Value, MultipleErrors) +graph input = do + moduleFiles <- readInput input + Make.runMake Options.defaultOptions $ do + ms <- CST.parseModulesFromFiles id moduleFiles + let parsedModuleSig = Dependencies.moduleSignature . CST.resPartial + (_sorted, moduleGraph) <- Dependencies.sortModules (parsedModuleSig . snd) ms + let pathMap = Map.fromList $ + map (\(p, m) -> (Dependencies.sigModuleName (parsedModuleSig m), p)) ms + pure (moduleGraphToJSON pathMap moduleGraph) + +moduleGraphToJSON + :: Map ModuleName FilePath + -> Dependencies.ModuleGraph + -> Json.Value +moduleGraphToJSON paths = Json.Object . foldl' insert mempty + where + insert :: Json.Object -> (ModuleName, [ModuleName]) -> Json.Object + insert obj (mn, depends) = HashMap.insert (runModuleName mn) value obj + where + path = fromMaybe (Crash.internalError "missing module name in graph") $ Map.lookup mn paths + value = Json.object + [ "path" .= path + , "depends" .= fmap runModuleName depends + ] + +readInput :: [FilePath] -> IO [(FilePath, Text)] +readInput inputFiles = + forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8FileT inFile diff --git a/tests/Main.hs b/tests/Main.hs index 3c7d5e031a..1f2ccdc902 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -22,6 +22,7 @@ import qualified TestPscPublish import qualified TestBundle import qualified TestMake import qualified TestUtils +import qualified TestGraph import System.IO (hSetEncoding, stdout, stderr, utf8) @@ -44,6 +45,7 @@ main = do primDocsTests <- TestPrimDocs.main publishTests <- TestPscPublish.main hierarchyTests <- TestHierarchy.main + graphTests <- TestGraph.main defaultMain $ testGroup @@ -59,6 +61,7 @@ main = do , primDocsTests , publishTests , hierarchyTests + , graphTests ] where diff --git a/tests/TestGraph.hs b/tests/TestGraph.hs new file mode 100644 index 0000000000..ef53d554f1 --- /dev/null +++ b/tests/TestGraph.hs @@ -0,0 +1,39 @@ +module TestGraph where + +import Prelude () +import Prelude.Compat + +import Test.Tasty +import Test.Tasty.Hspec +import System.IO.UTF8 (readUTF8FileT) +import Data.Either (isLeft) + +import qualified Data.ByteString.Lazy as ByteString +import qualified Data.Text.Encoding as Text +import qualified Data.Aeson as Json +import qualified Language.PureScript as P + + +main :: IO TestTree +main = testSpec "graph" spec + +spec :: Spec +spec = do + let baseDir = "tests/purs/graph/" + let sourcesDir = baseDir <> "src/" + it "should match the graph fixture" $ do + let modulePaths = (sourcesDir <>) <$> ["Module.purs", "Module2.purs"] + let graphFixtureName = "graph.json" + + graphFixture <- readUTF8FileT (baseDir <> graphFixtureName) + eitherGraph <- fst <$> P.graph modulePaths + case eitherGraph of + Left err -> error $ "Graph creation failed. Errors: " <> show err + Right res -> + let textRes = Text.decodeUtf8 $ ByteString.toStrict $ Json.encode res + in graphFixture `shouldBe` textRes + + it "should fail when trying to include non-existing modules in the graph" $ do + let modulePath = sourcesDir <> "ModuleFailing.purs" + graph <- fst <$> P.graph [modulePath] + graph `shouldSatisfy` isLeft diff --git a/tests/purs/graph/graph.json b/tests/purs/graph/graph.json new file mode 100644 index 0000000000..2f27a3a37a --- /dev/null +++ b/tests/purs/graph/graph.json @@ -0,0 +1 @@ +{"Module2":{"path":"tests/purs/graph/src/Module2.purs","depends":[]},"Module":{"path":"tests/purs/graph/src/Module.purs","depends":["Module2"]}} \ No newline at end of file diff --git a/tests/purs/graph/src/Module.purs b/tests/purs/graph/src/Module.purs new file mode 100644 index 0000000000..567c661a41 --- /dev/null +++ b/tests/purs/graph/src/Module.purs @@ -0,0 +1,9 @@ +module Module (foo) where + +import Module2 (bar) + +foo :: Int +foo = 0 + +baz :: Int +baz = foo + bar diff --git a/tests/purs/graph/src/Module2.purs b/tests/purs/graph/src/Module2.purs new file mode 100644 index 0000000000..27b2053f36 --- /dev/null +++ b/tests/purs/graph/src/Module2.purs @@ -0,0 +1,4 @@ +module Module2 (bar) where + +bar :: Int +bar = 1 diff --git a/tests/purs/graph/src/ModuleFailing.purs b/tests/purs/graph/src/ModuleFailing.purs new file mode 100644 index 0000000000..3346af5f70 --- /dev/null +++ b/tests/purs/graph/src/ModuleFailing.purs @@ -0,0 +1,5 @@ +module ModuleFailing where + +import NonExistent as M + +bat = M.nonExistent From ed130c78b708ff55cf4a80b126a1bd3ba5d80eb9 Mon Sep 17 00:00:00 2001 From: Will Jones Date: Sat, 8 Feb 2020 13:42:15 +0000 Subject: [PATCH 1184/1580] Implement `Coercible` for safe zero-cost coercions (#3351) * Implement `Coercible` for safe zero-cost coercions * Define a new built-in module, `Prim.Coerce` which exports a single type class, `Coercible a b`, which relates types with identical runtime representations. * Extend the type checker's class solver to solve constraints of the form `Coercible a b` automatically, as per the rules in the paper "Safe Zero-Cost Coercions for Haskell" (though simpler due to the absence of some of Haskell's features like type families). * As part of the above, introduce the notion of roles to the compiler. Roles will be inferred for all PureScript types but can also be declared explicitly. * Fix role inference for constructors with higher-rank fields * Support nominal roles * Clean up implementation of roles * Role inference no longer needs to talk about variable/formal parameter names, so remove dead code. * Make sure that `nominal`, `representational` and `phantom` are contextual keywords that can be used as identifiers when not in a role signature. * Fix role inference in the presence of `Nominal` * Clean up some documentation * Fix role inference for built-in types * Add cases to `walk` to deal with row types and other recursive constructors that matter. Add both expected-passing and expected-failing tests to catch these cases if they crop up again. * Move primitive roles into the initial environment, rather than having a special lookup case in the inference function. * Add a missing word * Remove line noise * Get it compiling again * Add purescript-safe-coerce to test dependencies Co-authored-by: Harry Garrood --- CONTRIBUTORS.md | 1 + src/Language/PureScript/AST/Declarations.hs | 27 +++ src/Language/PureScript/CST/Convert.hs | 3 + src/Language/PureScript/CST/Parser.y | 161 ++++++++++-------- src/Language/PureScript/CST/Positions.hs | 1 + src/Language/PureScript/CST/Types.hs | 7 + src/Language/PureScript/Constants.hs | 13 +- src/Language/PureScript/Docs/Prim.hs | 50 ++++++ src/Language/PureScript/Environment.hs | 47 ++++- src/Language/PureScript/Externs.hs | 13 +- src/Language/PureScript/Ide/Externs.hs | 2 + src/Language/PureScript/Roles.hs | 34 ++++ .../PureScript/Sugar/BindingGroups.hs | 1 + src/Language/PureScript/Sugar/Names/Env.hs | 9 + src/Language/PureScript/Sugar/TypeClasses.hs | 1 + src/Language/PureScript/TypeChecker.hs | 14 ++ .../PureScript/TypeChecker/Entailment.hs | 110 ++++++++++-- src/Language/PureScript/TypeChecker/Roles.hs | 149 ++++++++++++++++ src/Language/PureScript/Types.hs | 19 +++ tests/TestPrimDocs.hs | 1 + tests/purs/failing/CoercibleForeign.purs | 11 ++ tests/purs/failing/CoercibleNominal.purs | 11 ++ .../purs/failing/CoercibleNominalTypeApp.purs | 13 ++ .../purs/failing/CoercibleNominalWrapped.purs | 15 ++ .../failing/CoercibleRepresentational.purs | 11 ++ .../failing/CoercibleRepresentational2.purs | 9 + .../failing/CoercibleRepresentational3.purs | 9 + tests/purs/passing/Coercible.purs | 155 +++++++++++++++++ tests/purs/passing/Coercible/Lib.purs | 5 + tests/support/bower.json | 1 + 30 files changed, 813 insertions(+), 90 deletions(-) create mode 100644 src/Language/PureScript/Roles.hs create mode 100644 src/Language/PureScript/TypeChecker/Roles.hs create mode 100644 tests/purs/failing/CoercibleForeign.purs create mode 100644 tests/purs/failing/CoercibleNominal.purs create mode 100644 tests/purs/failing/CoercibleNominalTypeApp.purs create mode 100644 tests/purs/failing/CoercibleNominalWrapped.purs create mode 100644 tests/purs/failing/CoercibleRepresentational.purs create mode 100644 tests/purs/failing/CoercibleRepresentational2.purs create mode 100644 tests/purs/failing/CoercibleRepresentational3.purs create mode 100644 tests/purs/passing/Coercible.purs create mode 100644 tests/purs/passing/Coercible/Lib.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 42f8195216..d956af5b9c 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -67,6 +67,7 @@ If you would prefer to use different terms, please use the section below instead | [@legrostdg](https://github.com/legrostdg) | Félix Sipma | [MIT license](http://opensource.org/licenses/MIT) | | [@LiamGoodacre](https://github.com/LiamGoodacre) | Liam Goodacre | [MIT license](http://opensource.org/licenses/MIT) | | [@lukerandall](https://github.com/lukerandall) | Luke Randall | [MIT license](http://opensource.org/licenses/MIT) | +| [@lunaris](https://github.com/lunaris) | Will Jones | [MIT license](http://opensource.org/licenses/MIT) | | [@matthewleon](https://github.com/matthewleon) | Matthew Leon | [MIT license](http://opensource.org/licenses/MIT) | | [@mcoffin](https://github.com/mcoffin) | Matt Coffin | [MIT license](http://opensource.org/licenses/MIT) | | [@mhcurylo](https://github.com/mhcurylo) | Mateusz Curylo | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index e4f6d0ed72..eeb4c1b016 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -30,6 +30,7 @@ import Language.PureScript.PSString (PSString) import Language.PureScript.Label (Label) import Language.PureScript.Names import Language.PureScript.Kinds +import Language.PureScript.Roles import Language.PureScript.TypeClassDictionaries import Language.PureScript.Comments import Language.PureScript.Environment @@ -432,6 +433,19 @@ isExplicit :: ImportDeclarationType -> Bool isExplicit (Explicit _) = True isExplicit _ = False +-- | A role declaration assigns a list of roles to a type constructor's +-- parameters, e.g.: +-- +-- @type role T representational phantom@ +-- +-- In this example, @T@ is the identifier and @[representational, phantom]@ is +-- the list of roles (@T@ presumably having two parameters). +data RoleDeclarationData = RoleDeclarationData + { rdeclSourceAnn :: !SourceAnn + , rdeclIdent :: !(ProperName 'TypeName) + , rdeclRoles :: ![Role] + } deriving (Show, Eq) + -- | A type declaration assigns a type to an identifier, eg: -- -- @identity :: forall a. a -> a@ @@ -505,6 +519,10 @@ data Declaration -- | TypeSynonymDeclaration SourceAnn (ProperName 'TypeName) [(Text, Maybe SourceKind)] SourceType -- | + -- A role declaration (name, roles) + -- + | RoleDeclaration {-# UNPACK #-} !RoleDeclarationData + -- | -- A type declaration for a value (name, ty) -- | TypeDeclaration {-# UNPACK #-} !TypeDeclarationData @@ -587,6 +605,7 @@ declSourceAnn :: Declaration -> SourceAnn declSourceAnn (DataDeclaration sa _ _ _ _) = sa declSourceAnn (DataBindingGroupDeclaration ds) = declSourceAnn (NEL.head ds) declSourceAnn (TypeSynonymDeclaration sa _ _ _) = sa +declSourceAnn (RoleDeclaration rd) = rdeclSourceAnn rd declSourceAnn (TypeDeclaration td) = tydeclSourceAnn td declSourceAnn (ValueDeclaration vd) = valdeclSourceAnn vd declSourceAnn (BoundValueDeclaration sa _ _) = sa @@ -618,6 +637,7 @@ declName BindingGroupDeclaration{} = Nothing declName DataBindingGroupDeclaration{} = Nothing declName BoundValueDeclaration{} = Nothing declName TypeDeclaration{} = Nothing +declName RoleDeclaration{} = Nothing -- | -- Test if a declaration is a value declaration @@ -641,6 +661,13 @@ isImportDecl :: Declaration -> Bool isImportDecl ImportDeclaration{} = True isImportDecl _ = False +-- | +-- Test if a declaration is a role declaration +-- +isRoleDecl :: Declaration -> Bool +isRoleDecl RoleDeclaration{} = True +isRoleDecl _ = False + -- | -- Test if a declaration is a data type foreign import -- diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index 6f250506c7..e4501a5642 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -529,6 +529,9 @@ convertDeclaration fileName decl = case decl of AST.ExternDataDeclaration ann (nameValue a) $ convertKind fileName b ForeignKind _ a -> AST.ExternKindDeclaration ann (nameValue a) + DeclRole _ _ _ name roles -> + pure $ AST.RoleDeclaration $ + AST.RoleDeclarationData ann (nameValue name) (roleValue <$> NE.toList roles) where ann = uncurry (sourceAnnCommented fileName) $ declRange decl diff --git a/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y index d63619ce0b..4082d4472e 100644 --- a/src/Language/PureScript/CST/Parser.y +++ b/src/Language/PureScript/CST/Parser.y @@ -31,10 +31,11 @@ import Language.PureScript.CST.Positions import Language.PureScript.CST.Types import Language.PureScript.CST.Utils import qualified Language.PureScript.Names as N +import qualified Language.PureScript.Roles as R import Language.PureScript.PSString (PSString) } -%expect 98 +%expect 114 %name parseKind kind %name parseType type @@ -65,76 +66,80 @@ import Language.PureScript.PSString (PSString) %lexer { lexer } { SourceToken _ TokEof } %token - '(' { SourceToken _ TokLeftParen } - ')' { SourceToken _ TokRightParen } - '{' { SourceToken _ TokLeftBrace } - '}' { SourceToken _ TokRightBrace } - '[' { SourceToken _ TokLeftSquare } - ']' { SourceToken _ TokRightSquare } - '\{' { SourceToken _ TokLayoutStart } - '\}' { SourceToken _ TokLayoutEnd } - '\;' { SourceToken _ TokLayoutSep } - '<-' { SourceToken _ (TokLeftArrow _) } - '->' { SourceToken _ (TokRightArrow _) } - '<=' { SourceToken _ (TokOperator [] sym) | isLeftFatArrow sym } - '=>' { SourceToken _ (TokRightFatArrow _) } - ':' { SourceToken _ (TokOperator [] ":") } - '::' { SourceToken _ (TokDoubleColon _) } - '=' { SourceToken _ TokEquals } - '|' { SourceToken _ TokPipe } - '`' { SourceToken _ TokTick } - '.' { SourceToken _ TokDot } - ',' { SourceToken _ TokComma } - '_' { SourceToken _ TokUnderscore } - '\\' { SourceToken _ TokBackslash } - '-' { SourceToken _ (TokOperator [] "-") } - '@' { SourceToken _ (TokOperator [] "@") } - '#' { SourceToken _ (TokOperator [] "#") } - 'ado' { SourceToken _ (TokLowerName _ "ado") } - 'as' { SourceToken _ (TokLowerName [] "as") } - 'case' { SourceToken _ (TokLowerName [] "case") } - 'class' { SourceToken _ (TokLowerName [] "class") } - 'data' { SourceToken _ (TokLowerName [] "data") } - 'derive' { SourceToken _ (TokLowerName [] "derive") } - 'do' { SourceToken _ (TokLowerName _ "do") } - 'else' { SourceToken _ (TokLowerName [] "else") } - 'false' { SourceToken _ (TokLowerName [] "false") } - 'forall' { SourceToken _ (TokForall ASCII) } - 'forallu' { SourceToken _ (TokForall Unicode) } - 'foreign' { SourceToken _ (TokLowerName [] "foreign") } - 'hiding' { SourceToken _ (TokLowerName [] "hiding") } - 'import' { SourceToken _ (TokLowerName [] "import") } - 'if' { SourceToken _ (TokLowerName [] "if") } - 'in' { SourceToken _ (TokLowerName [] "in") } - 'infix' { SourceToken _ (TokLowerName [] "infix") } - 'infixl' { SourceToken _ (TokLowerName [] "infixl") } - 'infixr' { SourceToken _ (TokLowerName [] "infixr") } - 'instance' { SourceToken _ (TokLowerName [] "instance") } - 'kind' { SourceToken _ (TokLowerName [] "kind") } - 'let' { SourceToken _ (TokLowerName [] "let") } - 'module' { SourceToken _ (TokLowerName [] "module") } - 'newtype' { SourceToken _ (TokLowerName [] "newtype") } - 'of' { SourceToken _ (TokLowerName [] "of") } - 'then' { SourceToken _ (TokLowerName [] "then") } - 'true' { SourceToken _ (TokLowerName [] "true") } - 'type' { SourceToken _ (TokLowerName [] "type") } - 'where' { SourceToken _ (TokLowerName [] "where") } - '(->)' { SourceToken _ (TokSymbolArr _) } - '(..)' { SourceToken _ (TokSymbolName [] "..") } - LOWER { SourceToken _ (TokLowerName [] _) } - QUAL_LOWER { SourceToken _ (TokLowerName _ _) } - UPPER { SourceToken _ (TokUpperName [] _) } - QUAL_UPPER { SourceToken _ (TokUpperName _ _) } - SYMBOL { SourceToken _ (TokSymbolName [] _) } - QUAL_SYMBOL { SourceToken _ (TokSymbolName _ _) } - OPERATOR { SourceToken _ (TokOperator [] _) } - QUAL_OPERATOR { SourceToken _ (TokOperator _ _) } - LIT_HOLE { SourceToken _ (TokHole _) } - LIT_CHAR { SourceToken _ (TokChar _ _) } - LIT_STRING { SourceToken _ (TokString _ _) } - LIT_RAW_STRING { SourceToken _ (TokRawString _) } - LIT_INT { SourceToken _ (TokInt _ _) } - LIT_NUMBER { SourceToken _ (TokNumber _ _) } + '(' { SourceToken _ TokLeftParen } + ')' { SourceToken _ TokRightParen } + '{' { SourceToken _ TokLeftBrace } + '}' { SourceToken _ TokRightBrace } + '[' { SourceToken _ TokLeftSquare } + ']' { SourceToken _ TokRightSquare } + '\{' { SourceToken _ TokLayoutStart } + '\}' { SourceToken _ TokLayoutEnd } + '\;' { SourceToken _ TokLayoutSep } + '<-' { SourceToken _ (TokLeftArrow _) } + '->' { SourceToken _ (TokRightArrow _) } + '<=' { SourceToken _ (TokOperator [] sym) | isLeftFatArrow sym } + '=>' { SourceToken _ (TokRightFatArrow _) } + ':' { SourceToken _ (TokOperator [] ":") } + '::' { SourceToken _ (TokDoubleColon _) } + '=' { SourceToken _ TokEquals } + '|' { SourceToken _ TokPipe } + '`' { SourceToken _ TokTick } + '.' { SourceToken _ TokDot } + ',' { SourceToken _ TokComma } + '_' { SourceToken _ TokUnderscore } + '\\' { SourceToken _ TokBackslash } + '-' { SourceToken _ (TokOperator [] "-") } + '@' { SourceToken _ (TokOperator [] "@") } + '#' { SourceToken _ (TokOperator [] "#") } + 'ado' { SourceToken _ (TokLowerName _ "ado") } + 'as' { SourceToken _ (TokLowerName [] "as") } + 'case' { SourceToken _ (TokLowerName [] "case") } + 'class' { SourceToken _ (TokLowerName [] "class") } + 'data' { SourceToken _ (TokLowerName [] "data") } + 'derive' { SourceToken _ (TokLowerName [] "derive") } + 'do' { SourceToken _ (TokLowerName _ "do") } + 'else' { SourceToken _ (TokLowerName [] "else") } + 'false' { SourceToken _ (TokLowerName [] "false") } + 'forall' { SourceToken _ (TokForall ASCII) } + 'forallu' { SourceToken _ (TokForall Unicode) } + 'foreign' { SourceToken _ (TokLowerName [] "foreign") } + 'hiding' { SourceToken _ (TokLowerName [] "hiding") } + 'import' { SourceToken _ (TokLowerName [] "import") } + 'if' { SourceToken _ (TokLowerName [] "if") } + 'in' { SourceToken _ (TokLowerName [] "in") } + 'infix' { SourceToken _ (TokLowerName [] "infix") } + 'infixl' { SourceToken _ (TokLowerName [] "infixl") } + 'infixr' { SourceToken _ (TokLowerName [] "infixr") } + 'instance' { SourceToken _ (TokLowerName [] "instance") } + 'kind' { SourceToken _ (TokLowerName [] "kind") } + 'let' { SourceToken _ (TokLowerName [] "let") } + 'module' { SourceToken _ (TokLowerName [] "module") } + 'newtype' { SourceToken _ (TokLowerName [] "newtype") } + 'nominal' { SourceToken _ (TokLowerName [] "nominal") } + 'phantom' { SourceToken _ (TokLowerName [] "phantom") } + 'of' { SourceToken _ (TokLowerName [] "of") } + 'representational' { SourceToken _ (TokLowerName [] "representational") } + 'role' { SourceToken _ (TokLowerName [] "role") } + 'then' { SourceToken _ (TokLowerName [] "then") } + 'true' { SourceToken _ (TokLowerName [] "true") } + 'type' { SourceToken _ (TokLowerName [] "type") } + 'where' { SourceToken _ (TokLowerName [] "where") } + '(->)' { SourceToken _ (TokSymbolArr _) } + '(..)' { SourceToken _ (TokSymbolName [] "..") } + LOWER { SourceToken _ (TokLowerName [] _) } + QUAL_LOWER { SourceToken _ (TokLowerName _ _) } + UPPER { SourceToken _ (TokUpperName [] _) } + QUAL_UPPER { SourceToken _ (TokUpperName _ _) } + SYMBOL { SourceToken _ (TokSymbolName [] _) } + QUAL_SYMBOL { SourceToken _ (TokSymbolName _ _) } + OPERATOR { SourceToken _ (TokOperator [] _) } + QUAL_OPERATOR { SourceToken _ (TokOperator _ _) } + LIT_HOLE { SourceToken _ (TokHole _) } + LIT_CHAR { SourceToken _ (TokChar _ _) } + LIT_STRING { SourceToken _ (TokString _ _) } + LIT_RAW_STRING { SourceToken _ (TokRawString _) } + LIT_INT { SourceToken _ (TokInt _ _) } + LIT_NUMBER { SourceToken _ (TokNumber _ _) } %% @@ -188,12 +193,20 @@ qualIdent :: { QualifiedName Ident } | 'as' {% toQualifiedName Ident $1 } | 'hiding' {% toQualifiedName Ident $1 } | 'kind' {% toQualifiedName Ident $1 } + | 'role' {% toQualifiedName Ident $1 } + | 'nominal' {% toQualifiedName Ident $1 } + | 'representational' {% toQualifiedName Ident $1 } + | 'phantom' {% toQualifiedName Ident $1 } ident :: { Name Ident } : LOWER {% toName Ident $1 } | 'as' {% toName Ident $1 } | 'hiding' {% toName Ident $1 } | 'kind' {% toName Ident $1 } + | 'role' {% toName Ident $1 } + | 'nominal' {% toName Ident $1 } + | 'representational' {% toName Ident $1 } + | 'phantom' {% toName Ident $1 } qualOp :: { QualifiedName (N.OpName a) } : OPERATOR {% toQualifiedName N.OpName $1 } @@ -662,6 +675,7 @@ decl :: { Declaration () } | ident manyOrEmpty(binderAtom) guardedDecl { DeclValue () (ValueBindingFields $1 $2 $3) } | fixity { DeclFixity () $1 } | 'foreign' 'import' foreign { DeclForeign () $1 $2 $3 } + | 'type' 'role' properName many(role) { DeclRole () $1 $2 $3 $4 } dataHead :: { DataHead () } : 'data' properName manyOrEmpty(typeVarBinding) { DataHead $1 $2 $3 } @@ -744,6 +758,11 @@ foreign :: { Foreign () } | 'data' properName '::' kind { ForeignData $1 (Labeled $2 $3 $4) } | 'kind' properName { ForeignKind $1 $2 } +role :: { Role } + : 'nominal' { Role $1 R.Nominal } + | 'representational' { Role $1 R.Representational } + | 'phantom' { Role $1 R.Phantom } + -- Partial parsers which can be combined with combinators for adhoc use. We need -- to revert the lookahead token so that it doesn't consume an extra token -- before succeeding. diff --git a/src/Language/PureScript/CST/Positions.hs b/src/Language/PureScript/CST/Positions.hs index 67f03a0870..12c5361993 100644 --- a/src/Language/PureScript/CST/Positions.hs +++ b/src/Language/PureScript/CST/Positions.hs @@ -183,6 +183,7 @@ declRange = \case DeclFixity _ (FixityFields a _ (FixityValue _ _ b)) -> (fst a, nameTok b) DeclFixity _ (FixityFields a _ (FixityType _ _ _ b)) -> (fst a, nameTok b) DeclForeign _ a _ b -> (a, snd $ foreignRange b) + DeclRole _ a _ _ b -> (a, roleTok $ NE.last b) dataHeadRange :: DataHead a -> TokenRange dataHeadRange (DataHead kw name vars) diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs index 7768b960b3..49dd13407e 100644 --- a/src/Language/PureScript/CST/Types.hs +++ b/src/Language/PureScript/CST/Types.hs @@ -14,6 +14,7 @@ import Data.Text (Text) import Data.Void (Void) import GHC.Generics (Generic) import qualified Language.PureScript.Names as N +import qualified Language.PureScript.Roles as R import Language.PureScript.PSString (PSString) data SourcePos = SourcePos @@ -208,6 +209,7 @@ data Declaration a | DeclValue a (ValueBindingFields a) | DeclFixity a FixityFields | DeclForeign a SourceToken SourceToken (Foreign a) + | DeclRole a SourceToken SourceToken (Name (N.ProperName 'N.TypeName)) (NonEmpty Role) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) data Instance a = Instance @@ -317,6 +319,11 @@ data Foreign a | ForeignKind SourceToken (Name (N.ProperName 'N.KindName)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +data Role = Role + { roleTok :: SourceToken + , roleValue :: R.Role + } deriving (Show, Eq, Ord, Generic) + data Expr a = ExprHole a (Name Ident) | ExprSection a SourceToken diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index cd07a9cf26..d2b01ed7fe 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -398,6 +398,14 @@ booleanTrue = Qualified (Just PrimBoolean) (ProperName "True") booleanFalse :: Qualified (ProperName 'TypeName) booleanFalse = Qualified (Just PrimBoolean) (ProperName "False") +-- Prim.Coerce + +pattern PrimCoerce :: ModuleName +pattern PrimCoerce = ModuleName [ProperName "Prim", ProperName "Coerce"] + +pattern Coercible :: Qualified (ProperName 'ClassName) +pattern Coercible = Qualified (Just PrimCoerce) (ProperName "Coercible") + -- Prim.Ordering pattern PrimOrdering :: ModuleName @@ -469,7 +477,7 @@ pattern Warn :: Qualified (ProperName 'ClassName) pattern Warn = Qualified (Just PrimTypeError) (ProperName "Warn") primModules :: [ModuleName] -primModules = [Prim, PrimBoolean, PrimOrdering, PrimRow, PrimRowList, PrimSymbol, PrimTypeError] +primModules = [Prim, PrimBoolean, PrimCoerce, PrimOrdering, PrimRow, PrimRowList, PrimSymbol, PrimTypeError] -- Data.Symbol @@ -505,6 +513,9 @@ prim = "Prim" moduleBoolean :: forall a. (IsString a) => a moduleBoolean = "Boolean" +moduleCoerce :: forall a. (IsString a) => a +moduleCoerce = "Coerce" + moduleOrdering :: forall a. (IsString a) => a moduleOrdering = "Ordering" diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 3fabafa12a..d9cc71419a 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -22,6 +22,7 @@ primModules :: [Module] primModules = [ primDocsModule , primBooleanDocsModule + , primCoerceDocsModule , primOrderingDocsModule , primRowDocsModule , primRowListDocsModule @@ -65,6 +66,16 @@ primBooleanDocsModule = Module , modReExports = [] } +primCoerceDocsModule :: Module +primCoerceDocsModule = Module + { modName = P.moduleNameFromString "Prim.Coerce" + , modComments = Just "The Prim.Coerce module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains automatically solved type classes for working with types that have provably-identical runtime representations." + , modDeclarations = + [ coercible + ] + , modReExports = [] + } + primOrderingDocsModule :: Module primOrderingDocsModule = Module { modName = P.moduleNameFromString "Prim.Ordering" @@ -198,6 +209,7 @@ primTypeOf gen title comments = Declaration lookupPrimClassOf :: NameGen 'P.ClassName -> Text -> P.TypeClassData lookupPrimClassOf g = unsafeLookupOf g ( P.primClasses <> + P.primCoerceClasses <> P.primRowClasses <> P.primRowListClasses <> P.primSymbolClasses <> @@ -366,6 +378,44 @@ booleanFalse = primTypeOf (P.primSubName "Boolean") "False" $ T.unlines [ "The 'False' boolean type." ] +coercible :: Declaration +coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines + [ "Coercible is a two-parameter type class that has instances for types `a`" + , "and `b` if the compiler can infer that they have the same representation." + , "This class does not have regular instances; instead they are created" + , "on-the-fly during type-checking according to a set of rules." + , "" + , "First, as a trivial base-case, reflexivity - any type has the same" + , "representation as itself:" + , "" + , " instance coercibleReflexive :: Coercible a a" + , "" + , "Second, for every type constructor there is an instance that allows one" + , "to coerce under the type constructor (`data` or `newtype`). For example," + , "given a definition:" + , "" + , "data D a b = D a" + , "" + , "there is an instance:" + , "" + , " coercibleConstructor :: Coercible a a' => Coercible (D a b) (D a' b')" + , "" + , "Note that, since the type variable `a` plays a role in `D`'s representation," + , "we require that the types `a` and `a'` are themselves `Coercible`. However," + , "since the variable `b` does not play a part in `D`'s representation (a type" + , "such as `b` is thus typically referred to as a \"phantom\" type), `b` and `b'`" + , "can differ arbitrarily." + , "" + , "Third, for every `newtype NT = MkNT T`, there is a pair of instances which" + , "permit coercion in and out of the `newtype`:" + , "" + , " instance coercibleNewtypeLeft :: Coercible a T => Coercible a NT" + , " instance coercibleNewtypeRight :: Coercible T b => Coercible NT b" + , "" + , "To prevent breaking abstractions, these instances are only usable if the" + , "constructor `MkNT` is in scope." + ] + kindOrdering :: Declaration kindOrdering = primKindOf (P.primSubName "Ordering") "Ordering" $ T.unlines [ "The `Ordering` kind represents the three possibilites of comparing two" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index f6bea0e9dc..2511317e64 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -23,6 +23,7 @@ import Language.PureScript.AST.SourcePos import Language.PureScript.Crash import Language.PureScript.Kinds import Language.PureScript.Names +import Language.PureScript.Roles import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types import qualified Language.PureScript.Constants as C @@ -36,6 +37,8 @@ data Environment = Environment , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) -- ^ Data constructors currently in scope, along with their associated type -- constructor name, argument types and return type. + , roleDeclarations :: M.Map (Qualified (ProperName 'TypeName)) [Role] + -- ^ Explicit role declarations currently in scope. , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceKind)], SourceType) -- ^ Type synonyms currently in scope , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) @@ -100,7 +103,17 @@ instance A.ToJSON FunctionalDependency where -- | The initial environment with no values and only the default javascript types defined initEnvironment :: Environment -initEnvironment = Environment M.empty allPrimTypes M.empty M.empty M.empty allPrimClasses allPrimKinds +initEnvironment = Environment M.empty allPrimTypes M.empty primRoles M.empty M.empty allPrimClasses allPrimKinds + +-- | +-- A lookup table of role definitions for primitive types whose constructors +-- won't be present in any environment. +primRoles :: M.Map (Qualified (ProperName 'TypeName)) [Role] +primRoles = M.fromList + [ (primName "Function", [Representational, Representational]) + , (primName "Array", [Representational]) + , (primName "Record", [Representational]) + ] -- | A constructor for TypeClassData that computes which type class arguments are fully determined -- and argument covering sets. @@ -425,6 +438,7 @@ allPrimTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) allPrimTypes = M.unions [ primTypes , primBooleanTypes + , primCoerceTypes , primOrderingTypes , primRowTypes , primRowListTypes @@ -439,6 +453,12 @@ primBooleanTypes = , (primSubName C.moduleBoolean "False", (kindBoolean, ExternData)) ] +primCoerceTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) +primCoerceTypes = + M.fromList + [ (primSubName C.moduleCoerce "Coercible", (kindType -:> kindType -:> kindConstraint, ExternData)) + ] + primOrderingTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) primOrderingTypes = M.fromList @@ -496,12 +516,22 @@ primClasses = allPrimClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData allPrimClasses = M.unions [ primClasses + , primCoerceClasses , primRowClasses , primRowListClasses , primSymbolClasses , primTypeErrorClasses ] +primCoerceClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primCoerceClasses = + M.fromList + [ (primSubName C.moduleCoerce "Coercible", makeTypeClassData + [ ("a", Just kindType) + , ("b", Just kindType) + ] [] [] [] True) + ] + primRowClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primRowClasses = M.fromList @@ -600,6 +630,21 @@ primTypeErrorClasses = [("message", Just kindDoc)] [] [] [] True) ] +-- | Looks up a given name and, if it names a newtype, returns the names of the +-- type's parameters, the type the newtype wraps and the names of the type's +-- fields. +lookupNewtypeConstructor :: Environment -> Qualified (ProperName 'TypeName) -> Maybe ([Text], SourceType, [Ident]) +lookupNewtypeConstructor env ty@(Qualified mn _) = + M.lookup ty (types env) >>= \case + (_, DataType tvs [(ctor, [wrappedTy])]) -> + M.lookup (Qualified mn ctor) (dataConstructors env) >>= \case + (Newtype, _, _, ids) -> + pure (map fst tvs, wrappedTy, ids) + _ -> + Nothing + _ -> + Nothing + -- | Finds information about data constructors from the current environment. lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) lookupConstructor env ctor = diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index d4785a4c10..c27703e719 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -33,6 +33,7 @@ import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Kinds import Language.PureScript.Names +import Language.PureScript.Roles import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types @@ -103,6 +104,11 @@ data ExternsDeclaration = , edTypeKind :: SourceKind , edTypeDeclarationKind :: TypeKind } + -- | A role declaration + | EDRole + { edRoleTypeName :: ProperName 'TypeName + , edRoleRoles :: [Role] + } -- | A type synonym | EDTypeSynonym { edTypeSynonymName :: ProperName 'TypeName @@ -158,6 +164,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar where applyDecl :: Environment -> ExternsDeclaration -> Environment applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) } + applyDecl env (EDRole pn roles) = env { roleDeclarations = M.insert (qual pn) roles (roleDeclarations env) } applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) } applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } @@ -189,7 +196,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} efImports = mapMaybe importDecl ds efFixities = mapMaybe fixityDecl ds efTypeFixities = mapMaybe typeFixityDecl ds - efDeclarations = concatMap toExternsDeclaration efExports + efDeclarations = concatMap toExternsDeclaration efExports ++ mapMaybe roleDecl ds efSourceSpan = ss fixityDecl :: Declaration -> Maybe ExternsFixity @@ -209,6 +216,10 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} importDecl (ImportDeclaration _ m mt qmn) = Just (ExternsImport m mt qmn) importDecl _ = Nothing + roleDecl :: Declaration -> Maybe ExternsDeclaration + roleDecl (RoleDeclaration (RoleDeclarationData _ name roles)) = Just (EDRole name roles) + roleDecl _ = Nothing + toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration] toExternsDeclaration (TypeRef _ pn dctors) = case Qualified (Just mn) pn `M.lookup` types env of diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index ae5d2b5aa9..bc107c955c 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -134,6 +134,8 @@ convertDecl ed = case ed of (Just (IdeDeclDataConstructor (IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType))) + P.EDRole{..} -> + Right Nothing P.EDValue{..} -> Right (Just (IdeDeclValue (IdeValue edValueName edValueType))) P.EDClass{..} -> diff --git a/src/Language/PureScript/Roles.hs b/src/Language/PureScript/Roles.hs new file mode 100644 index 0000000000..ab807f046b --- /dev/null +++ b/src/Language/PureScript/Roles.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Data types for roles. +-- +module Language.PureScript.Roles + ( Role(..) + ) where + +import Prelude.Compat + +import Control.DeepSeq (NFData) +import qualified Data.Aeson as A +import qualified Data.Aeson.TH as A +import GHC.Generics (Generic) + +-- | +-- The role of a type constructor's parameter. +data Role + = Nominal + -- ^ This parameter's identity affects the representation of the type it is + -- parameterising. + | Representational + -- ^ This parameter's representation affects the representation of the type it + -- is parameterising. + | Phantom + -- ^ This parameter has no effect on the representation of the type it is + -- parameterising. + deriving (Show, Eq, Ord, Generic) + +instance NFData Role + +$(A.deriveJSON A.defaultOptions ''Role) diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index a4efc201d6..c6e058c649 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -75,6 +75,7 @@ createBindingGroups moduleName = mapM f <=< handleDecls valueVerts = fmap (\d -> (d, valdeclIdent d, usedIdents moduleName d `intersect` allIdents)) values bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName) return $ filter isImportDecl ds ++ + filter isRoleDecl ds ++ filter isExternKindDecl ds ++ filter isExternDataDecl ds ++ dataBindingGroupDecls ++ diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 31a109ba0e..163402b014 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -194,6 +194,12 @@ primExports = mkPrimExports primTypes primClasses primKinds primBooleanExports :: Exports primBooleanExports = mkPrimExports primBooleanTypes mempty primBooleanKinds +-- | +-- The exported types from the @Prim.Coerce@ module +-- +primCoerceExports :: Exports +primCoerceExports = mkPrimExports primCoerceTypes primCoerceClasses mempty + -- | -- The exported types from the @Prim.Ordering@ module -- @@ -258,6 +264,9 @@ primEnv = M.fromList , ( C.PrimBoolean , (internalModuleSourceSpan "", nullImports, primBooleanExports) ) + , ( C.PrimCoerce + , (internalModuleSourceSpan "", nullImports, primCoerceExports) + ) , ( C.PrimOrdering , (internalModuleSourceSpan "", nullImports, primOrderingExports) ) diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 761de6f631..5b6f40522f 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -53,6 +53,7 @@ desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModu initialState = mconcat [ M.mapKeys (qualify (ModuleName [ProperName C.prim])) primClasses + , M.mapKeys (qualify C.PrimCoerce) primCoerceClasses , M.mapKeys (qualify C.PrimRow) primRowClasses , M.mapKeys (qualify C.PrimRowList) primRowListClasses , M.mapKeys (qualify C.PrimSymbol) primSymbolClasses diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index b9ae232e8f..5064847903 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -34,6 +34,7 @@ import Language.PureScript.Errors import Language.PureScript.Kinds import Language.PureScript.Linter import Language.PureScript.Names +import Language.PureScript.Roles import Language.PureScript.TypeChecker.Kinds as T import Language.PureScript.TypeChecker.Monad as T import Language.PureScript.TypeChecker.Synonyms as T @@ -78,6 +79,16 @@ addDataConstructor moduleName dtype name args dctor dctorArgs = do let polyType = mkForAll (map (\i -> (NullSourceAnn, (i, Nothing))) args) dctorTy putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } +addRoleDeclaration + :: (MonadState CheckState m, MonadError MultipleErrors m) + => ModuleName + -> ProperName 'TypeName + -> [Role] + -> m () +addRoleDeclaration moduleName name roles = do + env <- getEnv + putEnv $ env { roleDeclarations = M.insert (Qualified (Just moduleName) name) roles (roleDeclarations env) } + addTypeSynonym :: (MonadState CheckState m, MonadError MultipleErrors m) => ModuleName @@ -277,6 +288,9 @@ typeCheckAll moduleName _ = traverse go let args' = args `withKinds` kind addTypeSynonym moduleName name args' ty kind return $ TypeSynonymDeclaration sa name args ty + go d@(RoleDeclaration (RoleDeclarationData _sa name roles)) = do + addRoleDeclaration moduleName name roles + return d go TypeDeclaration{} = internalError "Type declarations should have been removed before typeCheckAlld" go (ValueDecl sa@(ss, _) name nameKind [] [MkUnguarded val]) = do diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index dee68a97e4..625f038479 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -14,6 +14,7 @@ module Language.PureScript.TypeChecker.Entailment import Prelude.Compat import Protolude (ordNub) +import Control.Applicative ((<|>)) import Control.Arrow (second, (&&&)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State @@ -37,7 +38,10 @@ import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Names +import Language.PureScript.Roles import Language.PureScript.TypeChecker.Monad +import Language.PureScript.TypeChecker.Roles +import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types @@ -162,22 +166,23 @@ entails entails SolverOptions{..} constraint context hints = solve constraint where - forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [TypeClassDict] - forClassName ctx cn@C.Warn [msg] = + forClassName :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [TypeClassDict] + forClassName _ ctx cn@C.Warn [msg] = -- Prefer a warning dictionary in scope if there is one available. -- This allows us to defer a warning by propagating the constraint. findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope [] 0 (WarnInstance msg) [] C.Warn [msg] Nothing] - forClassName _ C.IsSymbol args | Just dicts <- solveIsSymbol args = dicts - forClassName _ C.SymbolCompare args | Just dicts <- solveSymbolCompare args = dicts - forClassName _ C.SymbolAppend args | Just dicts <- solveSymbolAppend args = dicts - forClassName _ C.SymbolCons args | Just dicts <- solveSymbolCons args = dicts - forClassName _ C.RowUnion args | Just dicts <- solveUnion args = dicts - forClassName _ C.RowNub args | Just dicts <- solveNub args = dicts - forClassName _ C.RowLacks args | Just dicts <- solveLacks args = dicts - forClassName _ C.RowCons args | Just dicts <- solveRowCons args = dicts - forClassName _ C.RowToList args | Just dicts <- solveRowToList args = dicts - forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) - forClassName _ _ _ = internalError "forClassName: expected qualified class name" + forClassName env _ C.Coercible args | Just dicts <- solveCoercible env args = dicts + forClassName _ _ C.IsSymbol args | Just dicts <- solveIsSymbol args = dicts + forClassName _ _ C.SymbolCompare args | Just dicts <- solveSymbolCompare args = dicts + forClassName _ _ C.SymbolAppend args | Just dicts <- solveSymbolAppend args = dicts + forClassName _ _ C.SymbolCons args | Just dicts <- solveSymbolCons args = dicts + forClassName _ _ C.RowUnion args | Just dicts <- solveUnion args = dicts + forClassName _ _ C.RowNub args | Just dicts <- solveNub args = dicts + forClassName _ _ C.RowLacks args | Just dicts <- solveLacks args = dicts + forClassName _ _ C.RowCons args | Just dicts <- solveRowCons args = dicts + forClassName _ _ C.RowToList args | Just dicts <- solveRowToList args = dicts + forClassName _ ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) + forClassName _ _ _ _ = internalError "forClassName: expected qualified class name" ctorModules :: SourceType -> Maybe ModuleName ctorModules (TypeConstructor _ (Qualified (Just mn) _)) = Just mn @@ -206,8 +211,8 @@ entails SolverOptions{..} constraint context hints = inferred <- lift get -- We need information about functional dependencies, so we have to look up the class -- name in the environment: - classesInScope <- lift . lift $ gets (typeClasses . checkEnv) - + env <- lift . lift $ gets checkEnv + let classesInScope = typeClasses env TypeClassData { typeClassDependencies , typeClassIsEmpty @@ -218,7 +223,7 @@ entails SolverOptions{..} constraint context hints = let instances = do chain <- groupBy ((==) `on` tcdChain) $ sortBy (compare `on` (tcdChain &&& tcdIndex)) $ - forClassName (combineContexts context inferred) className' tys'' + forClassName env (combineContexts context inferred) className' tys'' -- process instances in a chain in index order let found = for chain $ \tcd -> -- Make sure the type unifies with the type in the type instance definition @@ -368,6 +373,79 @@ entails SolverOptions{..} constraint context hints = subclassDictionaryValue dict className index = App (Accessor (mkString (superclassName className index)) dict) valUndefined + solveCoercible :: Environment -> [SourceType] -> Maybe [TypeClassDict] + solveCoercible env [a, b] = do + let tySynMap = typeSynonyms env + replaceTySyns = either (const Nothing) Just . replaceAllTypeSynonymsM tySynMap + a' <- replaceTySyns a + b' <- replaceTySyns b + -- Solving terminates when the two arguments are the same. Since we + -- currently don't support higher-rank arguments in instance heads, term + -- equality is a sufficient notion of "the same". + if a' == b' + then pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [a, b] Nothing] + else do + -- When solving must reduce and recurse, it doesn't matter whether we + -- reduce the first or second argument -- if the constraint is + -- solvable, either path will yield the same outcome. Consequently we + -- just try the first argument first and the second argument second. + ws <- coercibleWanteds env a' b' <|> coercibleWanteds env b' a' + pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [a, b] (Just ws)] + solveCoercible _ _ = Nothing + + -- | Take two types, @a@ and @b@ representing a desired constraint + -- @Coercible a b@ and reduce them to a set of simpler wanted constraints + -- whose satisfaction will yield the goal. + coercibleWanteds :: Environment -> SourceType -> SourceType -> Maybe [SourceConstraint] + coercibleWanteds env a b = case a of + TypeConstructor _ tyName -> do + -- If the first argument is a plain newtype (e.g. @newtype T = T U@ and + -- the constraint @Coercible T b@), look up the type of its wrapped + -- field and yield a new wanted constraint in terms of that type + -- (@Coercible U b@ in the example). + (_, wrappedTy, _) <- lookupNewtypeConstructor env tyName + pure [Constraint nullSourceAnn C.Coercible [wrappedTy, b] Nothing] + t + | Just (TypeConstructor _ aTyName, axs) <- splitTypeApp a + , Just (TypeConstructor _ bTyName, bxs) <- splitTypeApp b + , aTyName == bTyName + , tyRoles <- inferRoles env aTyName -> do + -- If both arguments are applications of the same type constructor + -- (e.g. @data D a b = D a@ in the constraint + -- @Coercible (D a b) (D a' b')@), infer the roles of the type + -- constructor's arguments and generate wanted constraints + -- appropriately (e.g. here @a@ is representational and @b@ is + -- phantom, yielding @Coercible a a'@). + let k role ax bx = case role of + Nominal + -- If we had first-class equality constraints, we'd just + -- emit one of the form @(a ~ b)@ here and let the solver + -- recurse. Since we don't we must compare the types at + -- this point and fail if they don't match. This likely + -- means there are cases we should be able to handle that + -- we currently can't, but is at least sound. + | ax == bx -> + Just [] + | otherwise -> + Nothing + Representational -> + Just [Constraint nullSourceAnn C.Coercible [ax, bx] Nothing] + Phantom -> + Just [] + fmap concat $ sequence $ zipWith3 k tyRoles axs bxs + | Just (TypeConstructor _ tyName, xs) <- splitTypeApp t + , Just (tvs, wrappedTy, _) <- lookupNewtypeConstructor env tyName -> do + -- If the first argument is a newtype applied to some other types + -- (e.g. @newtype T a = T a@ in @Coercible (T X) b@), look up the + -- type of its wrapped field and yield a new wanted constraint in + -- terms of that type with the type arguments substituted in (e.g. + -- @Coercible (T[X/a]) b = Coercible X b@ in the example). + let wrappedTySub = replaceAllTypeVars (zip tvs xs) wrappedTy + pure [Constraint nullSourceAnn C.Coercible [wrappedTySub, b] Nothing] + _ -> + -- In all other cases we can't solve the constraint. + Nothing + solveIsSymbol :: [SourceType] -> Maybe [TypeClassDict] solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope [] 0 (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString ann sym] Nothing] solveIsSymbol _ = Nothing diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs new file mode 100644 index 0000000000..43ac7f742c --- /dev/null +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Role inference +-- +module Language.PureScript.TypeChecker.Roles + ( inferRoles + ) where + +import Prelude.Compat + +import Data.Coerce (coerce) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import qualified Data.Set as S +import Data.Text (Text) + +import Language.PureScript.Environment +import Language.PureScript.Kinds +import Language.PureScript.Names +import Language.PureScript.Roles +import Language.PureScript.Types + +-- | +-- A map of a type's formal parameter names to their roles. This type's +-- @Semigroup@ and @Monoid@ instances preserve the least-permissive role +-- ascribed to any given variable, as defined by the @Role@ type's @Ord@ +-- instance. That is, a variable that has been marked as @Nominal@ can not +-- later be marked @Representational@, and so on. +newtype RoleMap = RoleMap { getRoleMap :: M.Map Text Role } + +instance Semigroup RoleMap where + (<>) = + coerce @(M.Map Text Role -> _ -> _) @(RoleMap -> _ -> _) (M.unionWith min) + +instance Monoid RoleMap where + mempty = + RoleMap M.empty + +-- | +-- Given an environment and the qualified name of a type constructor in that +-- environment, returns a list of roles, in the order they are defined in the +-- type definition. +inferRoles :: Environment -> Qualified (ProperName 'TypeName) -> [Role] +inferRoles env tyName + | Just roles <- M.lookup tyName (roleDeclarations env) = + roles + | Just (_, DataType tvs ctors) <- envMeta = + -- A plain data type. For each constructor the type has, walk its list of + -- field types and accumulate a list of (formal parameter name, role) + -- pairs. Then, walk the list of defined parameters, ensuring both that + -- every parameter appears (with a default role of phantom) and that they + -- appear in the right order. + let ctorRoles = getRoleMap $ foldMap (foldMap (walk mempty) . snd) ctors + in map (\(tv, _) -> fromMaybe Phantom (M.lookup tv ctorRoles)) tvs + | Just (k, ExternData) <- envMeta = + -- A foreign data type. Since the type will have no defined constructors + -- nor associated data types, infer the set of type parameters from its + -- kind and assume in the absence of role signatures that all such + -- parameters are nominal. + rolesFromForeignTypeKind k + | otherwise = + [] + where + envTypes = types env + envMeta = M.lookup tyName envTypes + -- This function is named walk to match the specification given in the "Role + -- inference" section of the paper "Safe Zero-cost Coercions for Haskell". + walk :: S.Set Text -> SourceType -> RoleMap + walk btvs (TypeVar _ v) + -- A type variable standing alone (e.g. @a@ in @data D a b = D a@) is + -- representational, _unless_ it has been bound by a quantifier, in which + -- case it is not actually a parameter to the type (e.g. @z@ in + -- @data T z = T (forall z. z -> z)@). + | S.member v btvs = + mempty + | otherwise = + RoleMap $ M.singleton v Representational + walk btvs (ForAll _ tv _ t _) = + -- We can walk under universal quantifiers as long as we make note of the + -- variables that they bind. For instance, given a definition + -- @data T z = T (forall z. z -> z)@, we will make note that @z@ is bound + -- by a quantifier so that we do not mark @T@'s parameter as + -- representational later on. Similarly, given a definition like + -- @data D a = D (forall r. r -> a)@, we'll mark @r@ as bound so that it + -- doesn't appear as a spurious parameter to @D@ when we complete + -- inference. + walk (S.insert tv btvs) t + walk btvs (RCons _ _ thead ttail) = + -- For row types, we just walk along them and collect the results. + walk btvs thead <> walk btvs ttail + walk btvs (KindedType _ t _k) = + -- For kind-annotated types, discard the annotation and recurse on the + -- type beneath. + walk btvs t + walk btvs t + | Just (t1, t2s) <- splitTypeApp t = + case t1 of + -- If the type is an application of a type constructor to some + -- arguments, recursively infer the roles of the type constructor's + -- arguments. For each (role, argument) pair: + -- + -- * If the role is nominal, mark all free variables in the + -- argument as nominal also, since they cannot be coerced if the + -- argument's nominality is to be preserved. + -- * If the role is representational, recurse on the argument, since + -- its use of our parameters is important. + -- * If the role is phantom, terminate, since the argument's use of + -- our parameters is unimportant. + TypeConstructor _ t1Name -> + let t1Roles = inferRoles env t1Name + k role ti = case role of + Nominal -> + freeNominals ti + Representational -> + go ti + Phantom -> + mempty + in mconcat (zipWith k t1Roles t2s) + -- If the type is an application of any other type-level term, walk + -- that term to collect its roles and mark all free variables in + -- its argument as nominal. + _ -> + go t1 <> foldMap freeNominals t2s + | otherwise = + mempty + where + go = walk btvs + -- Given a type, computes the list of free variables in that type + -- (taking into account those bound in @walk@) and returns a @RoleMap@ + -- ascribing a nominal role to each of those variables. + freeNominals x = + let ftvs = filter (flip S.notMember btvs) (freeTypeVariables x) + in RoleMap (M.fromList $ map (, Nominal) ftvs) + +-- | +-- Given the kind of a foreign type, generate a list @Nominal@ roles which, in +-- the absence of a role signature, provides the safest default for a type whose +-- constructors are opaque to us. +rolesFromForeignTypeKind :: SourceKind -> [Role] +rolesFromForeignTypeKind + = go [] + where + go acc = \case + FunKind _ k1 _k2 -> + go (Nominal : acc) k1 + _k -> + Nominal : acc diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 06c752a6f0..54fdaf27b3 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -353,6 +353,25 @@ data RowListItem a = RowListItem srcRowListItem :: Label -> SourceType -> RowListItem SourceAnn srcRowListItem = RowListItem NullSourceAnn +-- | Split a type application into a function/constructor and a list of +-- arguments. +splitTypeApp :: SourceType -> Maybe (SourceType, [SourceType]) +splitTypeApp + = \case + TypeApp _ f x -> + go [x] f + _ -> + Nothing + where + go xs + = \case + TypeApp _ f x -> + go (x : xs) f + KindedType _ t _ -> + go xs t + f -> + Just (f, xs) + -- | Convert a row to a list of pairs of labels and types rowToList :: Type a -> ([RowListItem a], Type a) rowToList = go where diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index 03d94d891a..d7cd1b7957 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -29,6 +29,7 @@ spec = do (map (P.runProperName . P.disqualify . fst) $ Map.toList ( P.primTypes <> P.primBooleanTypes <> + P.primCoerceTypes <> P.primOrderingTypes <> P.primRowTypes <> P.primRowListTypes <> diff --git a/tests/purs/failing/CoercibleForeign.purs b/tests/purs/failing/CoercibleForeign.purs new file mode 100644 index 0000000000..eb157bf332 --- /dev/null +++ b/tests/purs/failing/CoercibleForeign.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +foreign import data Foreign :: Type -> Type -> Type + +newtype Id a = Id a + +foreignToForeign :: forall a b. Foreign a b -> Foreign (Id a) (Id b) +foreignToForeign = coerce diff --git a/tests/purs/failing/CoercibleNominal.purs b/tests/purs/failing/CoercibleNominal.purs new file mode 100644 index 0000000000..479bdef759 --- /dev/null +++ b/tests/purs/failing/CoercibleNominal.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +data Nominal a b = Nominal a b + +type role Nominal nominal phantom + +nominalToNominal :: forall a b c. Nominal a c -> Nominal b c +nominalToNominal = coerce diff --git a/tests/purs/failing/CoercibleNominalTypeApp.purs b/tests/purs/failing/CoercibleNominalTypeApp.purs new file mode 100644 index 0000000000..b7eb0c2ace --- /dev/null +++ b/tests/purs/failing/CoercibleNominalTypeApp.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +data Phantom a = Phantom + +data Maybe a = Nothing | Just a + +data G a b = G (a (Phantom b)) + +gToG :: G Maybe Int -> G Maybe String +gToG = coerce diff --git a/tests/purs/failing/CoercibleNominalWrapped.purs b/tests/purs/failing/CoercibleNominalWrapped.purs new file mode 100644 index 0000000000..c79451e125 --- /dev/null +++ b/tests/purs/failing/CoercibleNominalWrapped.purs @@ -0,0 +1,15 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +data Nominal a b = Nominal a b + +type role Nominal nominal phantom + +newtype Id a = Id a + +data Wrap a b = Wrap (Nominal a b) + +wrapToWrap :: forall a b. Wrap a b -> Wrap (Id a) b +wrapToWrap = coerce diff --git a/tests/purs/failing/CoercibleRepresentational.purs b/tests/purs/failing/CoercibleRepresentational.purs new file mode 100644 index 0000000000..5ba2c08179 --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +data Phantom a = Phantom + +type role Phantom representational + +phantomToPhantom :: forall a b. Phantom a -> Phantom b +phantomToPhantom = coerce diff --git a/tests/purs/failing/CoercibleRepresentational2.purs b/tests/purs/failing/CoercibleRepresentational2.purs new file mode 100644 index 0000000000..e74d5a0093 --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational2.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +data Arr1 a = Arr1 (Array a) + +arr1ToArr1 :: Arr1 Int -> Arr1 String +arr1ToArr1 = coerce diff --git a/tests/purs/failing/CoercibleRepresentational3.purs b/tests/purs/failing/CoercibleRepresentational3.purs new file mode 100644 index 0000000000..5265b7987b --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational3.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +data Rec1 a = Rec1 { f :: a } + +arr1ToArr1 :: Rec1 Int -> Rec1 String +arr1ToArr1 = coerce diff --git a/tests/purs/passing/Coercible.purs b/tests/purs/passing/Coercible.purs new file mode 100644 index 0000000000..090468d791 --- /dev/null +++ b/tests/purs/passing/Coercible.purs @@ -0,0 +1,155 @@ +module Main where + +import Coercible.Lib + +import Effect.Console (log) +import Safe.Coerce (coerce) + +type SynString = String + +newtype NTString1 = NTString1 SynString + +nt1ToString :: NTString1 -> String +nt1ToString = coerce + +newtype NTString2 = NTString2 String + +nt2ToNT1 :: NTString2 -> NTString1 +nt2ToNT1 = coerce + +newtype Id1 a = Id1 a +newtype Id2 a = Id2 a + +id1ToId2 :: forall a. Id1 a -> Id2 a +id1ToId2 = coerce + +id12ToId21 :: forall b. Id1 (Id2 b) -> Id2 (Id1 b) +id12ToId21 = coerce + +newtype Phantom1 a b = Phantom1 a + +phantom1ToId12 :: forall x y. Phantom1 x y -> Id1 (Id2 x) +phantom1ToId12 = coerce + +nested :: forall x y z. Phantom1 (Id1 (Phantom1 x y)) y -> Id2 (Phantom1 x (Phantom1 z z)) +nested = coerce + +id1IntToInt :: Id1 Int -> Int +id1IntToInt = coerce + +id2IntToId1Int :: Id2 Int -> Id1 Int +id2IntToId1Int = coerce + +newtype NTInt1 = NTInt1 Int + +id2NTToId1Nt :: Id2 NTInt1 -> Id1 NTInt1 +id2NTToId1Nt = coerce + +id2NTToId1Int :: Id2 NTInt1 -> Id1 Int +id2NTToId1Int = coerce + +newtype NTFn1 a b = NTFn1 (a -> Int -> b) +newtype NTFn2 x a b = NTFn2 (a -> x -> b) + +ntFn1ToNTFn2 :: forall a b. NTFn1 a b -> NTFn2 Int a b +ntFn1ToNTFn2 = coerce + +libExposedCtorToId2 :: forall z. NTLib z -> Id2 z +libExposedCtorToId2 = coerce + +newtype Roles1 a b c = Roles1 (Phantom1 b c) + +roles1ToSecond :: forall r s t. Roles1 r s t -> s +roles1ToSecond = coerce + +data D a b = D a + +underD :: D NTString1 Boolean -> D NTString2 Int +underD = coerce + +newtype NTD a b c d = NTD (D b d) + +dToNTD :: forall i j k l. D j l -> NTD i (Id1 j) k (Phantom1 l k) +dToNTD = coerce + +ntdToNTD :: forall i j k l. NTD i j k l -> NTD (Id1 k) (Phantom1 j k) Int Boolean +ntdToNTD = coerce + +newtype RankN1 a b = RankN1 (forall r. r -> a) + +rankN1ToRankN1 :: RankN1 NTString1 Int -> RankN1 String Boolean +rankN1ToRankN1 = coerce + +data RankN2 a = RankN2 (forall a. a -> a) + +rankN2ToRankN2 :: forall x y. RankN2 x -> RankN2 y +rankN2ToRankN2 = coerce + +data RankN3 c = RankN3 (forall c. (forall c. c -> c) -> c) + +rankN3ToRankN3 :: forall x y. RankN3 x -> RankN3 y +rankN3ToRankN3 = coerce + +data RankN4 z = RankN4 (forall c. (forall z. c -> z) -> c) + +rankN4ToRankN4 :: forall x y. RankN4 x -> RankN4 y +rankN4ToRankN4 = coerce + +data Phantom2 a = Phantom + +data Rec1 a = Rec1 { f :: a } + +rec1ToRec1 :: Rec1 Int -> Rec1 (Id1 Int) +rec1ToRec1 = coerce + +data Rec2 a b = Rec2 { f :: a, g :: Int, h :: b } + +rec2ToRec2 :: Rec2 Int (Phantom2 String) -> Rec2 (Id1 Int) (Phantom2 Int) +rec2ToRec2 = coerce + +data Rec3 a = Rec3 {} + +rec3ToRec3 :: forall m n. Rec3 m -> Rec3 n +rec3ToRec3 = coerce + +data Arr1 a b = Arr1 (Array a) (Array b) + +arr1ToArr1 :: Arr1 Int String -> Arr1 (Id1 Int) (Id2 String) +arr1ToArr1 = coerce + +arr1ToArr1Phantom :: forall a. Arr1 (Phantom2 Int) String -> Arr1 (Phantom2 a) (Id2 String) +arr1ToArr1Phantom = coerce + +foreign import data Foreign1 :: Type -> Type -> Type + +type role Foreign1 representational representational + +foreign1ToForeign1 :: Foreign1 NTString1 (Phantom2 Int) -> Foreign1 String (Phantom2 Boolean) +foreign1ToForeign1 = coerce + +foreign import data Foreign2 :: Type -> Type -> Type + +type role Foreign2 phantom representational + +foreign2ToForeign2 :: Foreign2 NTString2 (Phantom2 Int) -> Foreign2 Int (Phantom2 Boolean) +foreign2ToForeign2 = coerce + +data MyMap k v = MyMap k v + +type role MyMap nominal representational + +mapToMap :: MyMap String String -> MyMap String NTString1 +mapToMap = coerce + +-- "role" should only be a reserved word after "type" +testRoleNotReserved :: String -> String +testRoleNotReserved role = role + +-- "nominal", "representational" and "phantom" should only be reserved when in +-- role signatures +testRolesNotReserved :: String -> String -> String -> String +testRolesNotReserved nominal representational phantom = "" + +data RoleNotReserved role = RoleNotReserved role + +main = log (coerce (NTString1 "Done") :: String) diff --git a/tests/purs/passing/Coercible/Lib.purs b/tests/purs/passing/Coercible/Lib.purs new file mode 100644 index 0000000000..6abd3c7b4e --- /dev/null +++ b/tests/purs/passing/Coercible/Lib.purs @@ -0,0 +1,5 @@ +module Coercible.Lib + ( NTLib (..) + ) where + +newtype NTLib a = NTLib a diff --git a/tests/support/bower.json b/tests/support/bower.json index 56c8cc200e..4bfed584d9 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -28,6 +28,7 @@ "purescript-proxy": "3.0.0", "purescript-psci-support": "4.0.0", "purescript-refs": "4.1.0", + "purescript-safe-coerce": "0.0.2", "purescript-st": "4.0.0", "purescript-strings": "4.0.0", "purescript-tailrec": "4.0.0", From 2b9175fe320053d78f02bf365373a678e4186491 Mon Sep 17 00:00:00 2001 From: Dario Oddenino Date: Sat, 22 Feb 2020 18:19:54 +0100 Subject: [PATCH 1185/1580] Golden tests for `purs/failing` and `purs/warning` (#3774) * Golden tests for failing and warning cases * generated golden files for failing tests * Added back directives tests --- tests/TestCompiler.hs | 143 ++++++++++++------ tests/TestUtils.hs | 2 +- tests/purs/failing/.gitattributes | 1 + tests/purs/failing/1071.out | 19 +++ tests/purs/failing/1169.out | 15 ++ tests/purs/failing/1175.out | 22 +++ tests/purs/failing/1310.out | 24 +++ tests/purs/failing/1570.out | 23 +++ tests/purs/failing/1733.out | 10 ++ tests/purs/failing/1825.out | 10 ++ tests/purs/failing/1881.out | 10 ++ tests/purs/failing/2128-class.out | 10 ++ tests/purs/failing/2128-instance.out | 10 ++ tests/purs/failing/2197-shouldFail.out | 14 ++ tests/purs/failing/2197-shouldFail2.out | 10 ++ tests/purs/failing/2378.out | 18 +++ tests/purs/failing/2379.out | 31 ++++ tests/purs/failing/2434.out | 10 ++ tests/purs/failing/2534.out | 21 +++ tests/purs/failing/2542.out | 19 +++ tests/purs/failing/2567.out | 18 +++ tests/purs/failing/2601.out | 19 +++ tests/purs/failing/2616.out | 25 +++ tests/purs/failing/2806.out | 28 ++++ tests/purs/failing/2874-forall.out | 10 ++ tests/purs/failing/2874-forall2.out | 10 ++ tests/purs/failing/2874-wildcard.out | 10 ++ tests/purs/failing/2947.out | 10 ++ tests/purs/failing/3132.out | 14 ++ .../failing/3275-BindingGroupErrorPos.out | 19 +++ .../failing/3275-DataBindingGroupErrorPos.out | 19 +++ .../failing/3335-TypeOpAssociativityError.out | 10 ++ tests/purs/failing/3405.out | 9 ++ tests/purs/failing/3549-a.out | 10 ++ tests/purs/failing/3549.out | 19 +++ tests/purs/failing/365.out | 9 ++ tests/purs/failing/3689.out | 10 ++ tests/purs/failing/438.out | 25 +++ tests/purs/failing/881.out | 14 ++ tests/purs/failing/AnonArgument1.out | 9 ++ tests/purs/failing/AnonArgument2.out | 9 ++ tests/purs/failing/AnonArgument3.out | 9 ++ tests/purs/failing/ApostropheModuleName.out | 10 ++ tests/purs/failing/ArgLengthMismatch.out | 10 ++ tests/purs/failing/ArrayType.out | 22 +++ tests/purs/failing/Arrays.out | 24 +++ tests/purs/failing/AtPatternPrecedence.out | 10 ++ tests/purs/failing/BindInDo-2.out | 9 ++ tests/purs/failing/BindInDo.out | 9 ++ .../failing/CannotDeriveNewtypeForData.out | 9 ++ .../purs/failing/CaseBinderLengthsDiffer.out | 14 ++ .../CaseDoesNotMatchAllConstructorArgs.out | 16 ++ tests/purs/failing/ConflictingExports.out | 14 ++ tests/purs/failing/ConflictingImports.out | 14 ++ tests/purs/failing/ConflictingImports/B.out | 14 ++ tests/purs/failing/ConflictingImports2.out | 14 ++ tests/purs/failing/ConflictingImports2/B.out | 14 ++ .../failing/ConflictingQualifiedImports.out | 14 ++ .../failing/ConflictingQualifiedImports2.out | 14 ++ .../ConflictingQualifiedImports2/B.out | 14 ++ tests/purs/failing/ConstraintFailure.out | 22 +++ tests/purs/failing/ConstraintInference.out | 19 +++ .../purs/failing/DctorOperatorAliasExport.out | 13 ++ tests/purs/failing/DeclConflictClassCtor.out | 10 ++ .../purs/failing/DeclConflictClassSynonym.out | 10 ++ tests/purs/failing/DeclConflictClassType.out | 10 ++ tests/purs/failing/DeclConflictCtorClass.out | 10 ++ tests/purs/failing/DeclConflictCtorCtor.out | 10 ++ .../failing/DeclConflictDuplicateCtor.out | 10 ++ .../purs/failing/DeclConflictSynonymClass.out | 10 ++ .../purs/failing/DeclConflictSynonymType.out | 10 ++ tests/purs/failing/DeclConflictTypeClass.out | 10 ++ .../purs/failing/DeclConflictTypeSynonym.out | 10 ++ tests/purs/failing/DeclConflictTypeType.out | 10 ++ tests/purs/failing/DiffKindsSameName.out | 19 +++ tests/purs/failing/DiffKindsSameName/LibA.out | 19 +++ tests/purs/failing/Do.out | 20 +++ .../purs/failing/DoNotSuggestComposition.out | 24 +++ .../purs/failing/DoNotSuggestComposition2.out | 24 +++ .../failing/DuplicateDeclarationsInLet.out | 10 ++ tests/purs/failing/DuplicateInstance.out | 17 +++ tests/purs/failing/DuplicateModule.out | 9 ++ tests/purs/failing/DuplicateProperties.out | 41 +++++ tests/purs/failing/DuplicateTypeClass.out | 14 ++ tests/purs/failing/DuplicateTypeVars.out | 11 ++ tests/purs/failing/EmptyCase.out | 10 ++ tests/purs/failing/EmptyClass.out | 10 ++ tests/purs/failing/EmptyDo.out | 10 ++ tests/purs/failing/ExpectedWildcard.out | 9 ++ tests/purs/failing/ExportConflictClass.out | 10 ++ tests/purs/failing/ExportConflictClass/B.out | 10 ++ .../failing/ExportConflictClassAndType.out | 10 ++ .../failing/ExportConflictClassAndType/B.out | 10 ++ tests/purs/failing/ExportConflictCtor.out | 10 ++ tests/purs/failing/ExportConflictType.out | 10 ++ tests/purs/failing/ExportConflictType/B.out | 10 ++ tests/purs/failing/ExportConflictTypeOp.out | 10 ++ tests/purs/failing/ExportConflictValue.out | 10 ++ tests/purs/failing/ExportConflictValueOp.out | 10 ++ .../purs/failing/ExportConflictValueOp/B.out | 10 ++ tests/purs/failing/ExportExplicit.out | 10 ++ tests/purs/failing/ExportExplicit1.out | 10 ++ tests/purs/failing/ExportExplicit1/M1.out | 10 ++ tests/purs/failing/ExportExplicit2.out | 10 ++ tests/purs/failing/ExportExplicit3.out | 10 ++ tests/purs/failing/ExtraRecordField.out | 27 ++++ tests/purs/failing/ExtraneousClassMember.out | 13 ++ tests/purs/failing/Foldable.out | 9 ++ tests/purs/failing/Generalization1.out | 16 ++ tests/purs/failing/Generalization2.out | 16 ++ tests/purs/failing/ImportExplicit.out | 11 ++ tests/purs/failing/ImportExplicit/M1.out | 11 ++ tests/purs/failing/ImportExplicit2.out | 10 ++ tests/purs/failing/ImportHidingModule.out | 10 ++ tests/purs/failing/ImportModule.out | 11 ++ tests/purs/failing/InfiniteKind.out | 15 ++ tests/purs/failing/InfiniteKind2.out | 14 ++ tests/purs/failing/InfiniteType.out | 21 +++ .../InstanceChainBothUnknownAndMatch.out | 36 +++++ .../InstanceChainSkolemUnknownMatch.out | 28 ++++ tests/purs/failing/InstanceExport.out | 13 ++ .../failing/InstanceSigsBodyIncorrect.out | 22 +++ .../failing/InstanceSigsDifferentTypes.out | 22 +++ .../failing/InstanceSigsIncorrectType.out | 22 +++ .../InstanceSigsOrphanTypeDeclaration.out | 10 ++ tests/purs/failing/IntOutOfRange.out | 11 ++ tests/purs/failing/InvalidDerivedInstance.out | 14 ++ .../purs/failing/InvalidDerivedInstance2.out | 17 +++ .../purs/failing/InvalidOperatorInBinder.out | 10 ++ tests/purs/failing/KindError.out | 18 +++ tests/purs/failing/KindStar.out | 20 +++ tests/purs/failing/LacksWithSubGoal.out | 28 ++++ tests/purs/failing/LeadingZeros1.out | 10 ++ tests/purs/failing/LeadingZeros2.out | 10 ++ tests/purs/failing/Let.out | 9 ++ tests/purs/failing/LetPatterns1.out | 10 ++ tests/purs/failing/LetPatterns2.out | 10 ++ tests/purs/failing/LetPatterns3.out | 16 ++ tests/purs/failing/LetPatterns4.out | 10 ++ tests/purs/failing/MPTCs.out | 16 ++ tests/purs/failing/MissingClassExport.out | 13 ++ tests/purs/failing/MissingClassMember.out | 15 ++ .../purs/failing/MissingClassMemberExport.out | 13 ++ .../failing/MissingFFIImplementations.out | 12 ++ tests/purs/failing/MissingRecordField.out | 23 +++ .../purs/failing/MixedAssociativityError.out | 14 ++ tests/purs/failing/MultipleErrors.out | 46 ++++++ tests/purs/failing/MultipleErrors2.out | 22 +++ tests/purs/failing/MultipleTypeOpFixities.out | 10 ++ .../purs/failing/MultipleValueOpFixities.out | 10 ++ tests/purs/failing/MutRec.out | 20 +++ tests/purs/failing/MutRec2.out | 9 ++ tests/purs/failing/NewtypeInstance.out | 13 ++ tests/purs/failing/NewtypeInstance2.out | 13 ++ tests/purs/failing/NewtypeInstance3.out | 13 ++ tests/purs/failing/NewtypeInstance4.out | 13 ++ tests/purs/failing/NewtypeInstance5.out | 13 ++ tests/purs/failing/NewtypeInstance6.out | 13 ++ tests/purs/failing/NewtypeMultiArgs.out | 10 ++ tests/purs/failing/NewtypeMultiCtor.out | 10 ++ tests/purs/failing/NonAssociativeError.out | 26 ++++ tests/purs/failing/NonExhaustivePatGuard.out | 26 ++++ tests/purs/failing/NullaryAbs.out | 10 ++ tests/purs/failing/Object.out | 24 +++ tests/purs/failing/OperatorAliasNoExport.out | 13 ++ tests/purs/failing/OperatorAt.out | 10 ++ tests/purs/failing/OperatorBackslash.out | 10 ++ tests/purs/failing/OperatorSections.out | 27 ++++ tests/purs/failing/OrphanInstance.out | 18 +++ tests/purs/failing/OrphanInstance/Class.out | 18 +++ .../failing/OrphanInstanceFunDepCycle.out | 20 +++ .../failing/OrphanInstanceFunDepCycle/Lib.out | 20 +++ tests/purs/failing/OrphanInstanceNullary.out | 18 +++ .../failing/OrphanInstanceNullary/Lib.out | 18 +++ .../failing/OrphanInstanceWithDetermined.out | 22 +++ .../OrphanInstanceWithDetermined/Lib.out | 22 +++ tests/purs/failing/OrphanTypeDecl.out | 10 ++ tests/purs/failing/OverlapAcrossModules.out | 24 +++ .../failing/OverlapAcrossModules/Class.out | 24 +++ tests/purs/failing/OverlappingArguments.out | 10 ++ tests/purs/failing/OverlappingBinders.out | 14 ++ tests/purs/failing/OverlappingInstances.out | 22 +++ tests/purs/failing/OverlappingVars.out | 20 +++ tests/purs/failing/PrimModuleReserved.out | 10 ++ tests/purs/failing/PrimRow.out | 10 ++ tests/purs/failing/PrimSubModuleReserved.out | 10 ++ .../PrimSubModuleReserved/Prim_Foobar.out | 10 ++ tests/purs/failing/ProgrammableTypeErrors.out | 24 +++ .../ProgrammableTypeErrorsTypeString.out | 21 +++ tests/purs/failing/Rank2Types.out | 25 +++ tests/purs/failing/RequiredHiddenType.out | 13 ++ tests/purs/failing/Reserved.out | 10 ++ tests/purs/failing/RowConstructors1.out | 19 +++ tests/purs/failing/RowConstructors2.out | 19 +++ tests/purs/failing/RowConstructors3.out | 19 +++ .../failing/RowInInstanceNotDetermined0.out | 19 +++ .../failing/RowInInstanceNotDetermined1.out | 20 +++ .../failing/RowInInstanceNotDetermined2.out | 19 +++ tests/purs/failing/RowLacks.out | 25 +++ tests/purs/failing/SelfImport.out | 9 ++ tests/purs/failing/SelfImport/Dummy.out | 9 ++ tests/purs/failing/SkolemEscape.out | 20 +++ tests/purs/failing/SkolemEscape2.out | 22 +++ tests/purs/failing/SuggestComposition.out | 32 ++++ tests/purs/failing/Superclasses1.out | 17 +++ tests/purs/failing/Superclasses2.out | 13 ++ tests/purs/failing/Superclasses3.out | 13 ++ tests/purs/failing/Superclasses5.out | 30 ++++ .../purs/failing/TooFewClassInstanceArgs.out | 15 ++ tests/purs/failing/TopLevelCaseNoArgs.out | 10 ++ tests/purs/failing/TransitiveDctorExport.out | 13 ++ tests/purs/failing/TransitiveKindExport.out | 13 ++ .../purs/failing/TransitiveSynonymExport.out | 13 ++ tests/purs/failing/TypeClasses2.out | 20 +++ tests/purs/failing/TypeError.out | 22 +++ .../failing/TypeOperatorAliasNoExport.out | 13 ++ tests/purs/failing/TypeSynonyms.out | 11 ++ tests/purs/failing/TypeSynonyms2.out | 14 ++ tests/purs/failing/TypeSynonyms3.out | 14 ++ tests/purs/failing/TypeSynonyms4.out | 12 ++ tests/purs/failing/TypeSynonyms5.out | 11 ++ tests/purs/failing/TypeWildcards1.out | 10 ++ tests/purs/failing/TypeWildcards2.out | 10 ++ tests/purs/failing/TypeWildcards3.out | 18 +++ tests/purs/failing/TypedBinders.out | 10 ++ tests/purs/failing/TypedBinders2.out | 30 ++++ tests/purs/failing/TypedBinders3.out | 21 +++ tests/purs/failing/TypedHole.out | 19 +++ tests/purs/failing/TypedHole2.out | 14 ++ tests/purs/failing/UnderscoreModuleName.out | 10 ++ tests/purs/failing/UnknownType.out | 10 ++ .../purs/failing/UnusableTypeClassMethod.out | 12 ++ ...nusableTypeClassMethodConflictingIdent.out | 12 ++ .../UnusableTypeClassMethodSynonym.out | 12 ++ tests/purs/failing/Whitespace1.out | 10 ++ tests/purs/warning/.gitattributes | 1 + tests/purs/warning/2140.out | 12 ++ tests/purs/warning/2383.out | 0 tests/purs/warning/2411.out | 11 ++ tests/purs/warning/2542.out | 16 ++ tests/purs/warning/CustomWarning.out | 14 ++ tests/purs/warning/CustomWarning2.out | 14 ++ tests/purs/warning/CustomWarning3.out | 30 ++++ tests/purs/warning/CustomWarning4.out | 60 ++++++++ tests/purs/warning/DuplicateExportRef.out | 77 ++++++++++ tests/purs/warning/DuplicateImport.out | 10 ++ tests/purs/warning/DuplicateImportRef.out | 44 ++++++ .../purs/warning/DuplicateSelectiveImport.out | 10 ++ tests/purs/warning/HidingImport.out | 28 ++++ tests/purs/warning/ImplicitImport.out | 28 ++++ .../purs/warning/ImplicitQualifiedImport.out | 30 ++++ .../ImplicitQualifiedImportReExport.out | 30 ++++ .../warning/Kind-UnusedExplicitImport-1.out | 17 +++ .../warning/Kind-UnusedExplicitImport-2.out | 17 +++ tests/purs/warning/Kind-UnusedImport.out | 10 ++ tests/purs/warning/KindReExport.out | 0 tests/purs/warning/MissingTypeDeclaration.out | 16 ++ tests/purs/warning/NewtypeInstance.out | 13 ++ tests/purs/warning/NewtypeInstance2.out | 14 ++ tests/purs/warning/NewtypeInstance3.out | 14 ++ tests/purs/warning/NewtypeInstance4.out | 14 ++ tests/purs/warning/OverlappingPattern.out | 28 ++++ tests/purs/warning/ScopeShadowing.out | 14 ++ tests/purs/warning/ScopeShadowing2.out | 14 ++ .../warning/ShadowedBinderPatternGuard.out | 11 ++ tests/purs/warning/ShadowedNameParens.out | 11 ++ tests/purs/warning/ShadowedTypeVar.out | 11 ++ tests/purs/warning/UnnecessaryFFIModule.out | 13 ++ .../warning/UnusedDctorExplicitImport.out | 17 +++ tests/purs/warning/UnusedDctorImportAll.out | 14 ++ .../warning/UnusedDctorImportExplicit.out | 14 ++ tests/purs/warning/UnusedExplicitImport.out | 17 +++ .../warning/UnusedExplicitImportTypeOp.out | 17 +++ .../warning/UnusedExplicitImportValOp.out | 17 +++ .../purs/warning/UnusedFFIImplementations.out | 12 ++ tests/purs/warning/UnusedImport.out | 22 +++ tests/purs/warning/UnusedTypeVar.out | 11 ++ tests/purs/warning/WildcardInferredType.out | 30 ++++ tests/purs/warning/WildcardInferredType2.out | 14 ++ 279 files changed, 4418 insertions(+), 46 deletions(-) create mode 100644 tests/purs/failing/.gitattributes create mode 100644 tests/purs/failing/1071.out create mode 100644 tests/purs/failing/1169.out create mode 100644 tests/purs/failing/1175.out create mode 100644 tests/purs/failing/1310.out create mode 100644 tests/purs/failing/1570.out create mode 100644 tests/purs/failing/1733.out create mode 100644 tests/purs/failing/1825.out create mode 100644 tests/purs/failing/1881.out create mode 100644 tests/purs/failing/2128-class.out create mode 100644 tests/purs/failing/2128-instance.out create mode 100644 tests/purs/failing/2197-shouldFail.out create mode 100644 tests/purs/failing/2197-shouldFail2.out create mode 100644 tests/purs/failing/2378.out create mode 100644 tests/purs/failing/2379.out create mode 100644 tests/purs/failing/2434.out create mode 100644 tests/purs/failing/2534.out create mode 100644 tests/purs/failing/2542.out create mode 100644 tests/purs/failing/2567.out create mode 100644 tests/purs/failing/2601.out create mode 100644 tests/purs/failing/2616.out create mode 100644 tests/purs/failing/2806.out create mode 100644 tests/purs/failing/2874-forall.out create mode 100644 tests/purs/failing/2874-forall2.out create mode 100644 tests/purs/failing/2874-wildcard.out create mode 100644 tests/purs/failing/2947.out create mode 100644 tests/purs/failing/3132.out create mode 100644 tests/purs/failing/3275-BindingGroupErrorPos.out create mode 100644 tests/purs/failing/3275-DataBindingGroupErrorPos.out create mode 100644 tests/purs/failing/3335-TypeOpAssociativityError.out create mode 100644 tests/purs/failing/3405.out create mode 100644 tests/purs/failing/3549-a.out create mode 100644 tests/purs/failing/3549.out create mode 100644 tests/purs/failing/365.out create mode 100644 tests/purs/failing/3689.out create mode 100644 tests/purs/failing/438.out create mode 100644 tests/purs/failing/881.out create mode 100644 tests/purs/failing/AnonArgument1.out create mode 100644 tests/purs/failing/AnonArgument2.out create mode 100644 tests/purs/failing/AnonArgument3.out create mode 100644 tests/purs/failing/ApostropheModuleName.out create mode 100644 tests/purs/failing/ArgLengthMismatch.out create mode 100644 tests/purs/failing/ArrayType.out create mode 100644 tests/purs/failing/Arrays.out create mode 100644 tests/purs/failing/AtPatternPrecedence.out create mode 100644 tests/purs/failing/BindInDo-2.out create mode 100644 tests/purs/failing/BindInDo.out create mode 100644 tests/purs/failing/CannotDeriveNewtypeForData.out create mode 100644 tests/purs/failing/CaseBinderLengthsDiffer.out create mode 100644 tests/purs/failing/CaseDoesNotMatchAllConstructorArgs.out create mode 100644 tests/purs/failing/ConflictingExports.out create mode 100644 tests/purs/failing/ConflictingImports.out create mode 100644 tests/purs/failing/ConflictingImports/B.out create mode 100644 tests/purs/failing/ConflictingImports2.out create mode 100644 tests/purs/failing/ConflictingImports2/B.out create mode 100644 tests/purs/failing/ConflictingQualifiedImports.out create mode 100644 tests/purs/failing/ConflictingQualifiedImports2.out create mode 100644 tests/purs/failing/ConflictingQualifiedImports2/B.out create mode 100644 tests/purs/failing/ConstraintFailure.out create mode 100644 tests/purs/failing/ConstraintInference.out create mode 100644 tests/purs/failing/DctorOperatorAliasExport.out create mode 100644 tests/purs/failing/DeclConflictClassCtor.out create mode 100644 tests/purs/failing/DeclConflictClassSynonym.out create mode 100644 tests/purs/failing/DeclConflictClassType.out create mode 100644 tests/purs/failing/DeclConflictCtorClass.out create mode 100644 tests/purs/failing/DeclConflictCtorCtor.out create mode 100644 tests/purs/failing/DeclConflictDuplicateCtor.out create mode 100644 tests/purs/failing/DeclConflictSynonymClass.out create mode 100644 tests/purs/failing/DeclConflictSynonymType.out create mode 100644 tests/purs/failing/DeclConflictTypeClass.out create mode 100644 tests/purs/failing/DeclConflictTypeSynonym.out create mode 100644 tests/purs/failing/DeclConflictTypeType.out create mode 100644 tests/purs/failing/DiffKindsSameName.out create mode 100644 tests/purs/failing/DiffKindsSameName/LibA.out create mode 100644 tests/purs/failing/Do.out create mode 100644 tests/purs/failing/DoNotSuggestComposition.out create mode 100644 tests/purs/failing/DoNotSuggestComposition2.out create mode 100644 tests/purs/failing/DuplicateDeclarationsInLet.out create mode 100644 tests/purs/failing/DuplicateInstance.out create mode 100644 tests/purs/failing/DuplicateModule.out create mode 100644 tests/purs/failing/DuplicateProperties.out create mode 100644 tests/purs/failing/DuplicateTypeClass.out create mode 100644 tests/purs/failing/DuplicateTypeVars.out create mode 100644 tests/purs/failing/EmptyCase.out create mode 100644 tests/purs/failing/EmptyClass.out create mode 100644 tests/purs/failing/EmptyDo.out create mode 100644 tests/purs/failing/ExpectedWildcard.out create mode 100644 tests/purs/failing/ExportConflictClass.out create mode 100644 tests/purs/failing/ExportConflictClass/B.out create mode 100644 tests/purs/failing/ExportConflictClassAndType.out create mode 100644 tests/purs/failing/ExportConflictClassAndType/B.out create mode 100644 tests/purs/failing/ExportConflictCtor.out create mode 100644 tests/purs/failing/ExportConflictType.out create mode 100644 tests/purs/failing/ExportConflictType/B.out create mode 100644 tests/purs/failing/ExportConflictTypeOp.out create mode 100644 tests/purs/failing/ExportConflictValue.out create mode 100644 tests/purs/failing/ExportConflictValueOp.out create mode 100644 tests/purs/failing/ExportConflictValueOp/B.out create mode 100644 tests/purs/failing/ExportExplicit.out create mode 100644 tests/purs/failing/ExportExplicit1.out create mode 100644 tests/purs/failing/ExportExplicit1/M1.out create mode 100644 tests/purs/failing/ExportExplicit2.out create mode 100644 tests/purs/failing/ExportExplicit3.out create mode 100644 tests/purs/failing/ExtraRecordField.out create mode 100644 tests/purs/failing/ExtraneousClassMember.out create mode 100644 tests/purs/failing/Foldable.out create mode 100644 tests/purs/failing/Generalization1.out create mode 100644 tests/purs/failing/Generalization2.out create mode 100644 tests/purs/failing/ImportExplicit.out create mode 100644 tests/purs/failing/ImportExplicit/M1.out create mode 100644 tests/purs/failing/ImportExplicit2.out create mode 100644 tests/purs/failing/ImportHidingModule.out create mode 100644 tests/purs/failing/ImportModule.out create mode 100644 tests/purs/failing/InfiniteKind.out create mode 100644 tests/purs/failing/InfiniteKind2.out create mode 100644 tests/purs/failing/InfiniteType.out create mode 100644 tests/purs/failing/InstanceChainBothUnknownAndMatch.out create mode 100644 tests/purs/failing/InstanceChainSkolemUnknownMatch.out create mode 100644 tests/purs/failing/InstanceExport.out create mode 100644 tests/purs/failing/InstanceSigsBodyIncorrect.out create mode 100644 tests/purs/failing/InstanceSigsDifferentTypes.out create mode 100644 tests/purs/failing/InstanceSigsIncorrectType.out create mode 100644 tests/purs/failing/InstanceSigsOrphanTypeDeclaration.out create mode 100644 tests/purs/failing/IntOutOfRange.out create mode 100644 tests/purs/failing/InvalidDerivedInstance.out create mode 100644 tests/purs/failing/InvalidDerivedInstance2.out create mode 100644 tests/purs/failing/InvalidOperatorInBinder.out create mode 100644 tests/purs/failing/KindError.out create mode 100644 tests/purs/failing/KindStar.out create mode 100644 tests/purs/failing/LacksWithSubGoal.out create mode 100644 tests/purs/failing/LeadingZeros1.out create mode 100644 tests/purs/failing/LeadingZeros2.out create mode 100644 tests/purs/failing/Let.out create mode 100644 tests/purs/failing/LetPatterns1.out create mode 100644 tests/purs/failing/LetPatterns2.out create mode 100644 tests/purs/failing/LetPatterns3.out create mode 100644 tests/purs/failing/LetPatterns4.out create mode 100644 tests/purs/failing/MPTCs.out create mode 100644 tests/purs/failing/MissingClassExport.out create mode 100644 tests/purs/failing/MissingClassMember.out create mode 100644 tests/purs/failing/MissingClassMemberExport.out create mode 100644 tests/purs/failing/MissingFFIImplementations.out create mode 100644 tests/purs/failing/MissingRecordField.out create mode 100644 tests/purs/failing/MixedAssociativityError.out create mode 100644 tests/purs/failing/MultipleErrors.out create mode 100644 tests/purs/failing/MultipleErrors2.out create mode 100644 tests/purs/failing/MultipleTypeOpFixities.out create mode 100644 tests/purs/failing/MultipleValueOpFixities.out create mode 100644 tests/purs/failing/MutRec.out create mode 100644 tests/purs/failing/MutRec2.out create mode 100644 tests/purs/failing/NewtypeInstance.out create mode 100644 tests/purs/failing/NewtypeInstance2.out create mode 100644 tests/purs/failing/NewtypeInstance3.out create mode 100644 tests/purs/failing/NewtypeInstance4.out create mode 100644 tests/purs/failing/NewtypeInstance5.out create mode 100644 tests/purs/failing/NewtypeInstance6.out create mode 100644 tests/purs/failing/NewtypeMultiArgs.out create mode 100644 tests/purs/failing/NewtypeMultiCtor.out create mode 100644 tests/purs/failing/NonAssociativeError.out create mode 100644 tests/purs/failing/NonExhaustivePatGuard.out create mode 100644 tests/purs/failing/NullaryAbs.out create mode 100644 tests/purs/failing/Object.out create mode 100644 tests/purs/failing/OperatorAliasNoExport.out create mode 100644 tests/purs/failing/OperatorAt.out create mode 100644 tests/purs/failing/OperatorBackslash.out create mode 100644 tests/purs/failing/OperatorSections.out create mode 100644 tests/purs/failing/OrphanInstance.out create mode 100644 tests/purs/failing/OrphanInstance/Class.out create mode 100644 tests/purs/failing/OrphanInstanceFunDepCycle.out create mode 100644 tests/purs/failing/OrphanInstanceFunDepCycle/Lib.out create mode 100644 tests/purs/failing/OrphanInstanceNullary.out create mode 100644 tests/purs/failing/OrphanInstanceNullary/Lib.out create mode 100644 tests/purs/failing/OrphanInstanceWithDetermined.out create mode 100644 tests/purs/failing/OrphanInstanceWithDetermined/Lib.out create mode 100644 tests/purs/failing/OrphanTypeDecl.out create mode 100644 tests/purs/failing/OverlapAcrossModules.out create mode 100644 tests/purs/failing/OverlapAcrossModules/Class.out create mode 100644 tests/purs/failing/OverlappingArguments.out create mode 100644 tests/purs/failing/OverlappingBinders.out create mode 100644 tests/purs/failing/OverlappingInstances.out create mode 100644 tests/purs/failing/OverlappingVars.out create mode 100644 tests/purs/failing/PrimModuleReserved.out create mode 100644 tests/purs/failing/PrimRow.out create mode 100644 tests/purs/failing/PrimSubModuleReserved.out create mode 100644 tests/purs/failing/PrimSubModuleReserved/Prim_Foobar.out create mode 100644 tests/purs/failing/ProgrammableTypeErrors.out create mode 100644 tests/purs/failing/ProgrammableTypeErrorsTypeString.out create mode 100644 tests/purs/failing/Rank2Types.out create mode 100644 tests/purs/failing/RequiredHiddenType.out create mode 100644 tests/purs/failing/Reserved.out create mode 100644 tests/purs/failing/RowConstructors1.out create mode 100644 tests/purs/failing/RowConstructors2.out create mode 100644 tests/purs/failing/RowConstructors3.out create mode 100644 tests/purs/failing/RowInInstanceNotDetermined0.out create mode 100644 tests/purs/failing/RowInInstanceNotDetermined1.out create mode 100644 tests/purs/failing/RowInInstanceNotDetermined2.out create mode 100644 tests/purs/failing/RowLacks.out create mode 100644 tests/purs/failing/SelfImport.out create mode 100644 tests/purs/failing/SelfImport/Dummy.out create mode 100644 tests/purs/failing/SkolemEscape.out create mode 100644 tests/purs/failing/SkolemEscape2.out create mode 100644 tests/purs/failing/SuggestComposition.out create mode 100644 tests/purs/failing/Superclasses1.out create mode 100644 tests/purs/failing/Superclasses2.out create mode 100644 tests/purs/failing/Superclasses3.out create mode 100644 tests/purs/failing/Superclasses5.out create mode 100644 tests/purs/failing/TooFewClassInstanceArgs.out create mode 100644 tests/purs/failing/TopLevelCaseNoArgs.out create mode 100644 tests/purs/failing/TransitiveDctorExport.out create mode 100644 tests/purs/failing/TransitiveKindExport.out create mode 100644 tests/purs/failing/TransitiveSynonymExport.out create mode 100644 tests/purs/failing/TypeClasses2.out create mode 100644 tests/purs/failing/TypeError.out create mode 100644 tests/purs/failing/TypeOperatorAliasNoExport.out create mode 100644 tests/purs/failing/TypeSynonyms.out create mode 100644 tests/purs/failing/TypeSynonyms2.out create mode 100644 tests/purs/failing/TypeSynonyms3.out create mode 100644 tests/purs/failing/TypeSynonyms4.out create mode 100644 tests/purs/failing/TypeSynonyms5.out create mode 100644 tests/purs/failing/TypeWildcards1.out create mode 100644 tests/purs/failing/TypeWildcards2.out create mode 100644 tests/purs/failing/TypeWildcards3.out create mode 100644 tests/purs/failing/TypedBinders.out create mode 100644 tests/purs/failing/TypedBinders2.out create mode 100644 tests/purs/failing/TypedBinders3.out create mode 100644 tests/purs/failing/TypedHole.out create mode 100644 tests/purs/failing/TypedHole2.out create mode 100644 tests/purs/failing/UnderscoreModuleName.out create mode 100644 tests/purs/failing/UnknownType.out create mode 100644 tests/purs/failing/UnusableTypeClassMethod.out create mode 100644 tests/purs/failing/UnusableTypeClassMethodConflictingIdent.out create mode 100644 tests/purs/failing/UnusableTypeClassMethodSynonym.out create mode 100644 tests/purs/failing/Whitespace1.out create mode 100644 tests/purs/warning/.gitattributes create mode 100644 tests/purs/warning/2140.out create mode 100644 tests/purs/warning/2383.out create mode 100644 tests/purs/warning/2411.out create mode 100644 tests/purs/warning/2542.out create mode 100644 tests/purs/warning/CustomWarning.out create mode 100644 tests/purs/warning/CustomWarning2.out create mode 100644 tests/purs/warning/CustomWarning3.out create mode 100644 tests/purs/warning/CustomWarning4.out create mode 100644 tests/purs/warning/DuplicateExportRef.out create mode 100644 tests/purs/warning/DuplicateImport.out create mode 100644 tests/purs/warning/DuplicateImportRef.out create mode 100644 tests/purs/warning/DuplicateSelectiveImport.out create mode 100644 tests/purs/warning/HidingImport.out create mode 100644 tests/purs/warning/ImplicitImport.out create mode 100644 tests/purs/warning/ImplicitQualifiedImport.out create mode 100644 tests/purs/warning/ImplicitQualifiedImportReExport.out create mode 100644 tests/purs/warning/Kind-UnusedExplicitImport-1.out create mode 100644 tests/purs/warning/Kind-UnusedExplicitImport-2.out create mode 100644 tests/purs/warning/Kind-UnusedImport.out create mode 100644 tests/purs/warning/KindReExport.out create mode 100644 tests/purs/warning/MissingTypeDeclaration.out create mode 100644 tests/purs/warning/NewtypeInstance.out create mode 100644 tests/purs/warning/NewtypeInstance2.out create mode 100644 tests/purs/warning/NewtypeInstance3.out create mode 100644 tests/purs/warning/NewtypeInstance4.out create mode 100644 tests/purs/warning/OverlappingPattern.out create mode 100644 tests/purs/warning/ScopeShadowing.out create mode 100644 tests/purs/warning/ScopeShadowing2.out create mode 100644 tests/purs/warning/ShadowedBinderPatternGuard.out create mode 100644 tests/purs/warning/ShadowedNameParens.out create mode 100644 tests/purs/warning/ShadowedTypeVar.out create mode 100644 tests/purs/warning/UnnecessaryFFIModule.out create mode 100644 tests/purs/warning/UnusedDctorExplicitImport.out create mode 100644 tests/purs/warning/UnusedDctorImportAll.out create mode 100644 tests/purs/warning/UnusedDctorImportExplicit.out create mode 100644 tests/purs/warning/UnusedExplicitImport.out create mode 100644 tests/purs/warning/UnusedExplicitImportTypeOp.out create mode 100644 tests/purs/warning/UnusedExplicitImportValOp.out create mode 100644 tests/purs/warning/UnusedFFIImplementations.out create mode 100644 tests/purs/warning/UnusedImport.out create mode 100644 tests/purs/warning/UnusedTypeVar.out create mode 100644 tests/purs/warning/WildcardInferredType.out create mode 100644 tests/purs/warning/WildcardInferredType2.out diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 5c082dafa3..af523b2e44 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -20,6 +20,10 @@ module TestCompiler where -- -- @shouldFailWith TypesDoNotUnify -- -- @shouldFailWith TypesDoNotUnify -- -- @shouldFailWith TransitiveExportError +-- +-- Failing tests also check their output against the relative golden files (`.out`). +-- The golden files are generated automatically when missing, and can be updated +-- by passing `--accept` to `--test-arguments.` import Prelude () import Prelude.Compat @@ -31,9 +35,12 @@ import Data.Function (on) import Data.List (sort, stripPrefix, intercalate, minimumBy) import Data.Maybe (mapMaybe) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified Data.Map as M +import qualified Data.ByteString.Lazy as BS + import Control.Monad import System.Exit @@ -45,63 +52,71 @@ import System.IO.UTF8 (readUTF8File) import TestUtils import Test.Tasty import Test.Tasty.Hspec +import Test.Tasty (testGroup) +import Test.Tasty.Golden (goldenVsString) main :: IO TestTree -main = testSpec "compiler" spec - -spec :: Spec -spec = do - (supportModules, supportExterns, supportForeigns) <- runIO $ setupSupportModules - - (passingTestCases, warningTestCases, failingTestCases) <- runIO $ - (,,) <$> getTestFiles "passing" - <*> getTestFiles "warning" - <*> getTestFiles "failing" +main = do + (supportModules, supportExterns, supportForeigns) <- setupSupportModules + passing <- passingTests supportModules supportExterns supportForeigns + warning <- warningTests supportModules supportExterns supportForeigns + failing <- failingTests supportModules supportExterns supportForeigns + return . testGroup "compiler" $ [passing, warning, failing] + +passingTests + :: [P.Module] + -> [P.ExternsFile] + -> M.Map P.ModuleName FilePath + -> IO TestTree +passingTests supportModules supportExterns supportForeigns = do + passingTestCases <- getTestFiles "passing" - outputFile <- runIO $ createOutputFile logfile + outputFile <- createOutputFile logfile - context "Passing examples" $ + testSpec "Passing examples" $ forM_ passingTestCases $ \testPurs -> it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ assertCompiles supportModules supportExterns supportForeigns testPurs outputFile - context "Warning examples" $ - forM_ warningTestCases $ \testPurs -> do - let mainPath = getTestMain testPurs - expectedWarnings <- runIO $ getShouldWarnWith mainPath +warningTests + :: [P.Module] + -> [P.ExternsFile] + -> M.Map P.ModuleName FilePath + -> IO TestTree +warningTests supportModules supportExterns supportForeigns = do + warningTestCases <- getTestFiles "warning" + tests <- forM warningTestCases $ \testPurs -> do + let mainPath = getTestMain testPurs + expectedWarnings <- getShouldWarnWith mainPath + wTc <- testSpecs $ it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $ assertCompilesWithWarnings supportModules supportExterns supportForeigns testPurs expectedWarnings - - context "Failing examples" $ - forM_ failingTestCases $ \testPurs -> do - let mainPath = getTestMain testPurs - expectedFailures <- runIO $ getShouldFailWith mainPath + return $ wTc ++ [ goldenVsString + ("'" <> takeFileName mainPath <> "' golden test") + (replaceExtension mainPath ".out") + (BS.fromStrict . T.encodeUtf8 . T.pack <$> printErrorOrWarning supportModules supportExterns supportForeigns testPurs) + ] + return $ testGroup "Warning examples" $ concat tests + +failingTests + :: [P.Module] + -> [P.ExternsFile] + -> M.Map P.ModuleName FilePath + -> IO TestTree +failingTests supportModules supportExterns supportForeigns = do + failingTestCases <- getTestFiles "failing" + tests <- forM failingTestCases $ \testPurs -> do + let mainPath = getTestMain testPurs + expectedFailures <- getShouldFailWith mainPath + fTc <- testSpecs $ it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ assertDoesNotCompile supportModules supportExterns supportForeigns testPurs expectedFailures - - where - - -- Takes the test entry point from a group of purs files - this is determined - -- by the file with the shortest path name, as everything but the main file - -- will be under a subdirectory. - getTestMain :: [FilePath] -> FilePath - getTestMain = minimumBy (compare `on` length) - - -- Scans a file for @shouldFailWith directives in the comments, used to - -- determine expected failures - getShouldFailWith :: FilePath -> IO [String] - getShouldFailWith = extractPragma "shouldFailWith" - - -- Scans a file for @shouldWarnWith directives in the comments, used to - -- determine expected warnings - getShouldWarnWith :: FilePath -> IO [String] - getShouldWarnWith = extractPragma "shouldWarnWith" - - extractPragma :: String -> FilePath -> IO [String] - extractPragma pragma = fmap go . readUTF8File - where - go = lines >>> mapMaybe (stripPrefix ("-- @" ++ pragma ++ " ")) >>> map trim - + return $ fTc ++ [ goldenVsString + ("'" <> takeFileName mainPath <> "' golden test") + (replaceExtension mainPath ".out") + (BS.fromStrict . T.encodeUtf8 . T.pack <$> printErrorOrWarning supportModules supportExterns supportForeigns testPurs) + ] + return $ testGroup "Failing examples" $ concat tests checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String checkShouldFailWith expected errs = @@ -204,5 +219,43 @@ assertDoesNotCompile supportModules supportExterns supportForeigns inputFiles sh where noPreCheck = const (return ()) +printErrorOrWarning + :: [P.Module] + -> [P.ExternsFile] + -> M.Map P.ModuleName FilePath + -> [FilePath] + -> IO String +printErrorOrWarning supportModules supportExterns supportForeigns inputFiles = do + (e, w) <- compile supportModules supportExterns supportForeigns inputFiles noPreCheck + case (const w <$> e) of + Left errs -> + return $ P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs + Right warnings -> + return $ P.prettyPrintMultipleErrors P.defaultPPEOptions $ warnings + where + noPreCheck = const (return ()) + +-- Takes the test entry point from a group of purs files - this is determined +-- by the file with the shortest path name, as everything but the main file +-- will be under a subdirectory. +getTestMain :: [FilePath] -> FilePath +getTestMain = minimumBy (compare `on` length) + +-- Scans a file for @shouldFailWith directives in the comments, used to +-- determine expected failures +getShouldFailWith :: FilePath -> IO [String] +getShouldFailWith = extractPragma "shouldFailWith" + +-- Scans a file for @shouldWarnWith directives in the comments, used to +-- determine expected warnings +getShouldWarnWith :: FilePath -> IO [String] +getShouldWarnWith = extractPragma "shouldWarnWith" + +extractPragma :: String -> FilePath -> IO [String] +extractPragma pragma = fmap go . readUTF8File + where + go = lines >>> mapMaybe (stripPrefix ("-- @" ++ pragma ++ " ")) >>> map trim + + logfile :: FilePath logfile = "psc-tests.out" diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 78ba841c09..86f6d70b17 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -121,7 +121,7 @@ setupSupportModules = do getTestFiles :: FilePath -> IO [[FilePath]] getTestFiles testDir = do cwd <- getCurrentDirectory - let dir = cwd "tests" "purs" testDir + let dir = "tests" "purs" testDir testsInPath <- getFiles dir <$> testGlob dir let rerunPath = dir "RerunCompilerTests.txt" hasRerunFile <- doesFileExist rerunPath diff --git a/tests/purs/failing/.gitattributes b/tests/purs/failing/.gitattributes new file mode 100644 index 0000000000..d0b673f439 --- /dev/null +++ b/tests/purs/failing/.gitattributes @@ -0,0 +1 @@ +*.out -merge -text diff --git a/tests/purs/failing/1071.out b/tests/purs/failing/1071.out new file mode 100644 index 0000000000..620693fdde --- /dev/null +++ b/tests/purs/failing/1071.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/1071.purs:7:18 - 7:23 (line 7, column 18 - line 7, column 23) + + Could not match kind + + Type -> Type + + with kind + + Type + + +while checking the kind of Foo a => a -> a +in value declaration bar + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/1169.out b/tests/purs/failing/1169.out new file mode 100644 index 0000000000..cce63555c0 --- /dev/null +++ b/tests/purs/failing/1169.out @@ -0,0 +1,15 @@ +Error found: +in module Test +at tests/purs/failing/1169.purs:12:8 - 12:15 (line 12, column 8 - line 12, column 15) + + Data constructor Test.Inner was given 1 arguments in a case expression, but expected 2 arguments. + This problem can be fixed by giving Test.Inner 2 arguments. + +while checking that expression case $1 of  +  (Inner _) -> true + has type Boolean +in value declaration test2 + +See https://github.com/purescript/documentation/blob/master/errors/IncorrectConstructorArity.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/1175.out b/tests/purs/failing/1175.out new file mode 100644 index 0000000000..5d8ca2447e --- /dev/null +++ b/tests/purs/failing/1175.out @@ -0,0 +1,22 @@ +Error found: +in module X +at tests/purs/failing/1175.purs:11:11 - 11:12 (line 11, column 11 - line 11, column 12) + + Could not match type +   +  Int +   + with type +   +  String +   + +while checking that type Int + is at least as general as type String +while checking that expression 1 + has type String +in value declaration f + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/1310.out b/tests/purs/failing/1310.out new file mode 100644 index 0000000000..c24a9f5d8d --- /dev/null +++ b/tests/purs/failing/1310.out @@ -0,0 +1,24 @@ +Error found: +in module Issue1310 +at tests/purs/failing/1310.purs:18:8 - 18:31 (line 18, column 8 - line 18, column 31) + + No type class instance was found for +   +  Issue1310.Inject Oops  +  Effect +   + +while applying a function inj + of type Inject t0 t1 => t0 t2 -> t1 t2 + to argument Oops (log "Oops") +while checking that expression inj (Oops (log "Oops")) + has type Effect Unit +in value declaration main + +where t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/1570.out b/tests/purs/failing/1570.out new file mode 100644 index 0000000000..834a64bbd8 --- /dev/null +++ b/tests/purs/failing/1570.out @@ -0,0 +1,23 @@ +Error found: +in module M +at tests/purs/failing/1570.purs:6:10 - 6:16 (line 6, column 10 - line 6, column 16) + + In a type-annotated expression x :: t, the type t must have kind Type. + The error arises from the type +   +  F +   + having the kind + + Type -> Type + + instead. + +while inferring the type of \$0 ->  +  case $0 of +  x -> x  +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/ExpectedType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/1733.out b/tests/purs/failing/1733.out new file mode 100644 index 0000000000..0410a74fc3 --- /dev/null +++ b/tests/purs/failing/1733.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/1733.purs:6:8 - 6:25 (line 6, column 8 - line 6, column 25) + + Unknown value Thing.doesntExist + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/1825.out b/tests/purs/failing/1825.out new file mode 100644 index 0000000000..94b78a5ec7 --- /dev/null +++ b/tests/purs/failing/1825.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/1825.purs:8:11 - 8:12 (line 8, column 11 - line 8, column 12) + + Unknown value a + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/1881.out b/tests/purs/failing/1881.out new file mode 100644 index 0000000000..709ba17aed --- /dev/null +++ b/tests/purs/failing/1881.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/1881.purs:5:1 - 5:1 (line 5, column 1 - line 5, column 1) + + Unable to parse module: + Unexpected or mismatched indentation + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2128-class.out b/tests/purs/failing/2128-class.out new file mode 100644 index 0000000000..63e230a84f --- /dev/null +++ b/tests/purs/failing/2128-class.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/2128-class.purs:5:15 - 5:18 (line 5, column 15 - line 5, column 18) + + Unable to parse module: + Unexpected token '!!!' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2128-instance.out b/tests/purs/failing/2128-instance.out new file mode 100644 index 0000000000..9b90fd6fba --- /dev/null +++ b/tests/purs/failing/2128-instance.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/2128-instance.purs:8:9 - 8:12 (line 8, column 9 - line 8, column 12) + + Unable to parse module: + Unexpected token '!!!' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2197-shouldFail.out b/tests/purs/failing/2197-shouldFail.out new file mode 100644 index 0000000000..21a39aeb3d --- /dev/null +++ b/tests/purs/failing/2197-shouldFail.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/2197-shouldFail.purs:9:6 - 9:12 (line 9, column 6 - line 9, column 12) + + Conflicting definitions are in scope for type Number from the following modules: + + Main + Prim + + + +See https://github.com/purescript/documentation/blob/master/errors/ScopeConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2197-shouldFail2.out b/tests/purs/failing/2197-shouldFail2.out new file mode 100644 index 0000000000..6036f08bfb --- /dev/null +++ b/tests/purs/failing/2197-shouldFail2.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/2197-shouldFail2.purs:6:6 - 6:12 (line 6, column 6 - line 6, column 12) + + Unknown type Number + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2378.out b/tests/purs/failing/2378.out new file mode 100644 index 0000000000..445fc10d01 --- /dev/null +++ b/tests/purs/failing/2378.out @@ -0,0 +1,18 @@ +Error found: +in module Main +at tests/purs/failing/2378.purs:6:1 - 6:25 (line 6, column 1 - line 6, column 25) + + Orphan instance fooX found for +   +  Lib.Foo "x" +   + This problem can be resolved by declaring the instance in Lib, or by defining the instance on a newtype wrapper. + +in type class instance +  + Lib.Foo "x" +  + +See https://github.com/purescript/documentation/blob/master/errors/OrphanInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2379.out b/tests/purs/failing/2379.out new file mode 100644 index 0000000000..96e9e7b248 --- /dev/null +++ b/tests/purs/failing/2379.out @@ -0,0 +1,31 @@ +Error found: +in module Main +at tests/purs/failing/2379.purs:6:8 - 6:19 (line 6, column 8 - line 6, column 19) + + No type class instance was found for class +   +  Lib.Y +   + because the class was not in scope. Perhaps it was not exported. + +while solving type class constraint +  + Lib.Y Int +  +while applying a function x + of type X t0 => t0 -> String + to argument [ 1 + , 2 + , 3 + ]  +while inferring the type of x [ 1 +  , 2 +  , 3 +  ]  +in value declaration test + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/UnknownClass.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2434.out b/tests/purs/failing/2434.out new file mode 100644 index 0000000000..d2e2671399 --- /dev/null +++ b/tests/purs/failing/2434.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/2434.purs:5:13 - 5:14 (line 5, column 13 - line 5, column 14) + + Unable to parse module: + Illegal astral code point in character literal + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2534.out b/tests/purs/failing/2534.out new file mode 100644 index 0000000000..14b4ad800d --- /dev/null +++ b/tests/purs/failing/2534.out @@ -0,0 +1,21 @@ +Error found: +in module Main +at tests/purs/failing/2534.purs:8:14 - 8:18 (line 8, column 14 - line 8, column 18) + + An infinite type was inferred for an expression: +   +  Array t0 +   + +while trying to match type Array t1 + with type t0 +while checking that expression xs + has type t0 +in value declaration foo + +where t1 is an unknown type + t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/InfiniteType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2542.out b/tests/purs/failing/2542.out new file mode 100644 index 0000000000..1d06484c00 --- /dev/null +++ b/tests/purs/failing/2542.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/2542.purs:8:10 - 8:17 (line 8, column 10 - line 8, column 17) + + Type variable a is undefined. + +while checking the kind of Array a0 +while checking that expression bar  +  where  +  bar = [] + has type Array a0 +in value declaration foo + +where a0 is a rigid type variable + bound at (line 7, column 7 - line 7, column 10) + +See https://github.com/purescript/documentation/blob/master/errors/UndefinedTypeVariable.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2567.out b/tests/purs/failing/2567.out new file mode 100644 index 0000000000..04258502a7 --- /dev/null +++ b/tests/purs/failing/2567.out @@ -0,0 +1,18 @@ +Error found: +in module Main +at tests/purs/failing/2567.purs:7:8 - 7:67 (line 7, column 8 - line 7, column 67) + + A custom type error occurred while solving type class constraints: + + This constraint should be checked + + +while checking that type Fail (Text "This constraint should be checked") => Int + is at least as general as type Int +while checking that expression 0 + has type Int +in value declaration foo + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2601.out b/tests/purs/failing/2601.out new file mode 100644 index 0000000000..060db15d84 --- /dev/null +++ b/tests/purs/failing/2601.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/2601.purs:6:12 - 6:15 (line 6, column 12 - line 6, column 15) + + Could not match kind + + Type -> Type + + with kind + + Type + + +while checking the kind of Syn Int +in value declaration val + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2616.out b/tests/purs/failing/2616.out new file mode 100644 index 0000000000..340de0daeb --- /dev/null +++ b/tests/purs/failing/2616.out @@ -0,0 +1,25 @@ +Error found: +in module Main +at tests/purs/failing/2616.purs:9:1 - 9:38 (line 9, column 1 - line 9, column 38) + + No type class instance was found for +   +  Prim.RowList.RowToList r1 +  t2 +   + The instance head contains unknown type variables. Consider adding a type annotation. + +while applying a function compare + of type Ord t0 => t0 -> t0 -> Ordering + to argument $l6 +while inferring the type of compare $l6 +in value declaration ordFoo + +where r1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t0 is an unknown type + t2 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2806.out b/tests/purs/failing/2806.out new file mode 100644 index 0000000000..b089ac5a1b --- /dev/null +++ b/tests/purs/failing/2806.out @@ -0,0 +1,28 @@ +Error found: +in module X +at tests/purs/failing/2806.purs:6:1 - 6:29 (line 6, column 1 - line 6, column 29) + + A case expression could not be determined to cover all inputs. + The following additional cases are required to cover all inputs: + + _ + + Alternatively, add a Partial constraint to the type of the enclosing value. + +while applying a function $__unused + of type Partial => t1 -> t1 + to argument case e of  +  e | L x <- e -> x +while checking that expression $__unused (case e of  +  e | L x <- e -> x +  )  + has type a0 +in value declaration g + +where a0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2874-forall.out b/tests/purs/failing/2874-forall.out new file mode 100644 index 0000000000..d6e86aff7d --- /dev/null +++ b/tests/purs/failing/2874-forall.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/2874-forall.purs:5:24 - 5:30 (line 5, column 24 - line 5, column 30) + + Unable to parse module: + Unexpected token 'forall' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2874-forall2.out b/tests/purs/failing/2874-forall2.out new file mode 100644 index 0000000000..60a5d2be68 --- /dev/null +++ b/tests/purs/failing/2874-forall2.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/2874-forall2.purs:5:12 - 5:18 (line 5, column 12 - line 5, column 18) + + Unable to parse module: + Unexpected token 'forall' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2874-wildcard.out b/tests/purs/failing/2874-wildcard.out new file mode 100644 index 0000000000..6298b37122 --- /dev/null +++ b/tests/purs/failing/2874-wildcard.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/2874-wildcard.purs:10:25 - 10:26 (line 10, column 25 - line 10, column 26) + + Unable to parse module: + Unexpected wildcard in type; type wildcards are only allowed in value annotations + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2947.out b/tests/purs/failing/2947.out new file mode 100644 index 0000000000..f6019f6390 --- /dev/null +++ b/tests/purs/failing/2947.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/2947.purs:10:1 - 10:1 (line 10, column 1 - line 10, column 1) + + Unable to parse module: + Unexpected or mismatched indentation + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3132.out b/tests/purs/failing/3132.out new file mode 100644 index 0000000000..22643d23e5 --- /dev/null +++ b/tests/purs/failing/3132.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/3132.purs:2:1 - 18:13 (line 2, column 1 - line 18, column 13) + + An export for class C3 requires the following to also be exported: + + class C1 + class C2 + + + +See https://github.com/purescript/documentation/blob/master/errors/TransitiveExportError.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3275-BindingGroupErrorPos.out b/tests/purs/failing/3275-BindingGroupErrorPos.out new file mode 100644 index 0000000000..1e951ccddb --- /dev/null +++ b/tests/purs/failing/3275-BindingGroupErrorPos.out @@ -0,0 +1,19 @@ +Error found: +in module BindingGroupErrorPos +at tests/purs/failing/3275-BindingGroupErrorPos.purs:11:17 - 11:30 (line 11, column 17 - line 11, column 30) + + Could not match kind + + Type + + with kind + + Type -> k4 + + +while checking the kind of Int -> Result String +in binding group wrong + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3275-DataBindingGroupErrorPos.out b/tests/purs/failing/3275-DataBindingGroupErrorPos.out new file mode 100644 index 0000000000..19733fb78e --- /dev/null +++ b/tests/purs/failing/3275-DataBindingGroupErrorPos.out @@ -0,0 +1,19 @@ +Error found: +in module DataBindingGroupErrorPos +at tests/purs/failing/3275-DataBindingGroupErrorPos.purs:7:19 - 7:26 (line 7, column 19 - line 7, column 26) + + Could not match kind + + Type + + with kind + + k4 -> k5 + + +while checking the kind of Bar a a +in data binding group Bar, Foo + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3335-TypeOpAssociativityError.out b/tests/purs/failing/3335-TypeOpAssociativityError.out new file mode 100644 index 0000000000..7d6ecb7891 --- /dev/null +++ b/tests/purs/failing/3335-TypeOpAssociativityError.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/3335-TypeOpAssociativityError.purs:6:1 - 6:33 (line 6, column 1 - line 6, column 33) + + Cannot parse an expression that uses multiple instances of the non-associative operator Main.(>>). + Use parentheses to resolve this ambiguity. + + +See https://github.com/purescript/documentation/blob/master/errors/NonAssociativeError.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3405.out b/tests/purs/failing/3405.out new file mode 100644 index 0000000000..ea38286820 --- /dev/null +++ b/tests/purs/failing/3405.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/3405.purs:8:1 - 8:43 (line 8, column 1 - line 8, column 43) + + Cannot derive a type class instance, because the type declaration for Something could not be found. + + +See https://github.com/purescript/documentation/blob/master/errors/CannotFindDerivingType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3549-a.out b/tests/purs/failing/3549-a.out new file mode 100644 index 0000000000..60543750b7 --- /dev/null +++ b/tests/purs/failing/3549-a.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/3549-a.purs:6:26 - 6:29 (line 6, column 26 - line 6, column 29) + + Unknown kind Typ + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3549.out b/tests/purs/failing/3549.out new file mode 100644 index 0000000000..b3dae2d21d --- /dev/null +++ b/tests/purs/failing/3549.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/3549.purs:8:78 - 8:79 (line 8, column 78 - line 8, column 79) + + Could not match kind + + Type + + with kind + + Type -> Type + + +while checking the kind of Functor f => (a -> b) -> f a -> f b +in value declaration map' + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/365.out b/tests/purs/failing/365.out new file mode 100644 index 0000000000..c24e5e19d0 --- /dev/null +++ b/tests/purs/failing/365.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/365.purs:10:1 - 12:8 (line 10, column 1 - line 12, column 8) + + The value of cS is undefined here, so this reference is not allowed. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3689.out b/tests/purs/failing/3689.out new file mode 100644 index 0000000000..aa542205e3 --- /dev/null +++ b/tests/purs/failing/3689.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/3689.purs:5:5 - 5:10 (line 5, column 5 - line 5, column 10) + + Unable to parse module: + Unexpected quoted label in record pun, perhaps due to a missing ':' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/438.out b/tests/purs/failing/438.out new file mode 100644 index 0000000000..cb02bdfa01 --- /dev/null +++ b/tests/purs/failing/438.out @@ -0,0 +1,25 @@ +Error found: +in module Main +at tests/purs/failing/438.purs:15:11 - 15:25 (line 15, column 11 - line 15, column 25) + + Type class instance for +   +  Data.Eq.Eq (Array (Fix Array)) +   + is possibly infinite. + +while solving type class constraint +  + Data.Eq.Eq (Fix Array) +  +while applying a function eq + of type Eq t0 => t0 -> t0 -> Boolean + to argument In [] +while inferring the type of eq (In []) +in value declaration example + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/PossiblyInfiniteInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/881.out b/tests/purs/failing/881.out new file mode 100644 index 0000000000..1ee0d7d23c --- /dev/null +++ b/tests/purs/failing/881.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/881.purs:10:1 - 13:12 (line 10, column 1 - line 13, column 12) + + Multiple value declarations exist for foo. + +in type class instance +  + Main.Foo X +  + +See https://github.com/purescript/documentation/blob/master/errors/DuplicateValueDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/AnonArgument1.out b/tests/purs/failing/AnonArgument1.out new file mode 100644 index 0000000000..92f2727b80 --- /dev/null +++ b/tests/purs/failing/AnonArgument1.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/AnonArgument1.purs:5:1 - 5:9 (line 5, column 1 - line 5, column 9) + + An anonymous function argument appears in an invalid context. + + +See https://github.com/purescript/documentation/blob/master/errors/IncorrectAnonymousArgument.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/AnonArgument2.out b/tests/purs/failing/AnonArgument2.out new file mode 100644 index 0000000000..faa84312db --- /dev/null +++ b/tests/purs/failing/AnonArgument2.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/AnonArgument2.purs:7:1 - 7:17 (line 7, column 1 - line 7, column 17) + + An anonymous function argument appears in an invalid context. + + +See https://github.com/purescript/documentation/blob/master/errors/IncorrectAnonymousArgument.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/AnonArgument3.out b/tests/purs/failing/AnonArgument3.out new file mode 100644 index 0000000000..2466eddbbd --- /dev/null +++ b/tests/purs/failing/AnonArgument3.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/AnonArgument3.purs:5:1 - 5:13 (line 5, column 1 - line 5, column 13) + + An anonymous function argument appears in an invalid context. + + +See https://github.com/purescript/documentation/blob/master/errors/IncorrectAnonymousArgument.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ApostropheModuleName.out b/tests/purs/failing/ApostropheModuleName.out new file mode 100644 index 0000000000..06e1774bc6 --- /dev/null +++ b/tests/purs/failing/ApostropheModuleName.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/ApostropheModuleName.purs:3:8 - 3:18 (line 3, column 8 - line 3, column 18) + + Unable to parse module: + Invalid module name; underscores and primes are not allowed in module names + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ArgLengthMismatch.out b/tests/purs/failing/ArgLengthMismatch.out new file mode 100644 index 0000000000..f146af501f --- /dev/null +++ b/tests/purs/failing/ArgLengthMismatch.out @@ -0,0 +1,10 @@ +Error found: +in module ArgLengthMismatch +at tests/purs/failing/ArgLengthMismatch.purs:6:1 - 6:13 (line 6, column 1 - line 6, column 13) + + Argument list lengths differ in declaration f + + +See https://github.com/purescript/documentation/blob/master/errors/ArgListLengthsDiffer.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ArrayType.out b/tests/purs/failing/ArrayType.out new file mode 100644 index 0000000000..3c892bd842 --- /dev/null +++ b/tests/purs/failing/ArrayType.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/ArrayType.purs:10:7 - 10:8 (line 10, column 7 - line 10, column 8) + + Could not match type +   +  Int +   + with type +   +  Number +   + +while checking that type Int + is at least as general as type Number +while checking that expression x + has type Number +in value declaration foo + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/Arrays.out b/tests/purs/failing/Arrays.out new file mode 100644 index 0000000000..276ed08504 --- /dev/null +++ b/tests/purs/failing/Arrays.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/Arrays.purs:6:26 - 6:27 (line 6, column 26 - line 6, column 27) + + Could not match type +   +  Int +   + with type +   +  Array t0 +   + +while checking that type Int + is at least as general as type Array t0 +while checking that expression 0 + has type Array t0 +in value declaration test + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/AtPatternPrecedence.out b/tests/purs/failing/AtPatternPrecedence.out new file mode 100644 index 0000000000..5db798b828 --- /dev/null +++ b/tests/purs/failing/AtPatternPrecedence.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/AtPatternPrecedence.purs:11:1 - 11:15 (line 11, column 1 - line 11, column 15) + + Argument list lengths differ in declaration oops + + +See https://github.com/purescript/documentation/blob/master/errors/ArgListLengthsDiffer.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/BindInDo-2.out b/tests/purs/failing/BindInDo-2.out new file mode 100644 index 0000000000..7379090786 --- /dev/null +++ b/tests/purs/failing/BindInDo-2.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/BindInDo-2.purs:7:7 - 7:16 (line 7, column 7 - line 7, column 16) + + The name bind cannot be brought into scope in a do notation block, since do notation uses the same name. + + +See https://github.com/purescript/documentation/blob/master/errors/CannotUseBindWithDo.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/BindInDo.out b/tests/purs/failing/BindInDo.out new file mode 100644 index 0000000000..87be256e78 --- /dev/null +++ b/tests/purs/failing/BindInDo.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/BindInDo.purs:7:3 - 7:18 (line 7, column 3 - line 7, column 18) + + The name bind cannot be brought into scope in a do notation block, since do notation uses the same name. + + +See https://github.com/purescript/documentation/blob/master/errors/CannotUseBindWithDo.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CannotDeriveNewtypeForData.out b/tests/purs/failing/CannotDeriveNewtypeForData.out new file mode 100644 index 0000000000..2b78aebc75 --- /dev/null +++ b/tests/purs/failing/CannotDeriveNewtypeForData.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/CannotDeriveNewtypeForData.purs:6:1 - 6:24 (line 6, column 1 - line 6, column 24) + + Cannot derive an instance of the Newtype class for non-newtype Test. + + +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveNewtypeForData.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CaseBinderLengthsDiffer.out b/tests/purs/failing/CaseBinderLengthsDiffer.out new file mode 100644 index 0000000000..8fcae58ff1 --- /dev/null +++ b/tests/purs/failing/CaseBinderLengthsDiffer.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/CaseBinderLengthsDiffer.purs:5:3 - 5:10 (line 5, column 3 - line 5, column 10) + + Binder list length differs in case alternative: + + 1, 2, 3 + + Expecting 2 binders. + + +See https://github.com/purescript/documentation/blob/master/errors/CaseBinderLengthDiffers.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CaseDoesNotMatchAllConstructorArgs.out b/tests/purs/failing/CaseDoesNotMatchAllConstructorArgs.out new file mode 100644 index 0000000000..5a060f27a5 --- /dev/null +++ b/tests/purs/failing/CaseDoesNotMatchAllConstructorArgs.out @@ -0,0 +1,16 @@ +Error found: +in module Main +at tests/purs/failing/CaseDoesNotMatchAllConstructorArgs.purs:11:9 - 11:17 (line 11, column 9 - line 11, column 17) + + Data constructor Main.Person was given 1 arguments in a case expression, but expected 2 arguments. + This problem can be fixed by giving Main.Person 2 arguments. + +while inferring the type of \p ->  +  case p of  +  (Two (Person n) (Person n2 a2)) -> n +  _ -> "Unknown"  +in value declaration getName + +See https://github.com/purescript/documentation/blob/master/errors/IncorrectConstructorArity.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ConflictingExports.out b/tests/purs/failing/ConflictingExports.out new file mode 100644 index 0000000000..daea92c591 --- /dev/null +++ b/tests/purs/failing/ConflictingExports.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/ConflictingExports.purs:3:14 - 3:22 (line 3, column 14 - line 3, column 22) + + Conflicting definitions are in scope for value thing from the following modules: + + A + B + + + +See https://github.com/purescript/documentation/blob/master/errors/ScopeConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ConflictingImports.out b/tests/purs/failing/ConflictingImports.out new file mode 100644 index 0000000000..7fc2a98d51 --- /dev/null +++ b/tests/purs/failing/ConflictingImports.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/ConflictingImports.purs:9:8 - 9:13 (line 9, column 8 - line 9, column 13) + + Conflicting definitions are in scope for value thing from the following modules: + + A + B + + + +See https://github.com/purescript/documentation/blob/master/errors/ScopeConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ConflictingImports/B.out b/tests/purs/failing/ConflictingImports/B.out new file mode 100644 index 0000000000..7fc2a98d51 --- /dev/null +++ b/tests/purs/failing/ConflictingImports/B.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/ConflictingImports.purs:9:8 - 9:13 (line 9, column 8 - line 9, column 13) + + Conflicting definitions are in scope for value thing from the following modules: + + A + B + + + +See https://github.com/purescript/documentation/blob/master/errors/ScopeConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ConflictingImports2.out b/tests/purs/failing/ConflictingImports2.out new file mode 100644 index 0000000000..626414bbcd --- /dev/null +++ b/tests/purs/failing/ConflictingImports2.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/ConflictingImports2.purs:10:8 - 10:13 (line 10, column 8 - line 10, column 13) + + Conflicting definitions are in scope for value thing from the following modules: + + A + B + + + +See https://github.com/purescript/documentation/blob/master/errors/ScopeConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ConflictingImports2/B.out b/tests/purs/failing/ConflictingImports2/B.out new file mode 100644 index 0000000000..626414bbcd --- /dev/null +++ b/tests/purs/failing/ConflictingImports2/B.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/ConflictingImports2.purs:10:8 - 10:13 (line 10, column 8 - line 10, column 13) + + Conflicting definitions are in scope for value thing from the following modules: + + A + B + + + +See https://github.com/purescript/documentation/blob/master/errors/ScopeConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ConflictingQualifiedImports.out b/tests/purs/failing/ConflictingQualifiedImports.out new file mode 100644 index 0000000000..9b97c8aa64 --- /dev/null +++ b/tests/purs/failing/ConflictingQualifiedImports.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/ConflictingQualifiedImports.purs:7:7 - 7:14 (line 7, column 7 - line 7, column 14) + + Conflicting definitions are in scope for value thing from the following modules: + + A + B + + + +See https://github.com/purescript/documentation/blob/master/errors/ScopeConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ConflictingQualifiedImports2.out b/tests/purs/failing/ConflictingQualifiedImports2.out new file mode 100644 index 0000000000..cbac1abae7 --- /dev/null +++ b/tests/purs/failing/ConflictingQualifiedImports2.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/ConflictingQualifiedImports2.purs:2:14 - 2:22 (line 2, column 14 - line 2, column 22) + + Conflicting definitions are in scope for value thing from the following modules: + + A + B + + + +See https://github.com/purescript/documentation/blob/master/errors/ScopeConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ConflictingQualifiedImports2/B.out b/tests/purs/failing/ConflictingQualifiedImports2/B.out new file mode 100644 index 0000000000..cbac1abae7 --- /dev/null +++ b/tests/purs/failing/ConflictingQualifiedImports2/B.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/ConflictingQualifiedImports2.purs:2:14 - 2:22 (line 2, column 14 - line 2, column 22) + + Conflicting definitions are in scope for value thing from the following modules: + + A + B + + + +See https://github.com/purescript/documentation/blob/master/errors/ScopeConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ConstraintFailure.out b/tests/purs/failing/ConstraintFailure.out new file mode 100644 index 0000000000..6a952a9a07 --- /dev/null +++ b/tests/purs/failing/ConstraintFailure.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/ConstraintFailure.purs:12:8 - 12:12 (line 12, column 8 - line 12, column 12) + + No type class instance was found for +   +  Data.Show.Show Foo +   + +while checking that type forall a. Show a => a -> String + is at least as general as type t0 t1 t2 +while checking that expression show + has type t0 t1 t2 +in value declaration main + +where t0 is an unknown type + t2 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ConstraintInference.out b/tests/purs/failing/ConstraintInference.out new file mode 100644 index 0000000000..54eeedc7d4 --- /dev/null +++ b/tests/purs/failing/ConstraintInference.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/ConstraintInference.purs:10:1 - 10:21 (line 10, column 1 - line 10, column 21) + + The inferred type +   +  forall t5 t9. Show t5 => t9 -> String +   + has type variables which are not determined by those mentioned in the body of the type: + + t5 could not be determined + + Consider adding a type annotation. + +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/AmbiguousTypeVariables.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DctorOperatorAliasExport.out b/tests/purs/failing/DctorOperatorAliasExport.out new file mode 100644 index 0000000000..166409aee7 --- /dev/null +++ b/tests/purs/failing/DctorOperatorAliasExport.out @@ -0,0 +1,13 @@ +Error found: +in module Data.List +at tests/purs/failing/DctorOperatorAliasExport.purs:2:1 - 6:21 (line 2, column 1 - line 6, column 21) + + An export for (:) requires the following data constructor to also be exported: + + Cons + + + +See https://github.com/purescript/documentation/blob/master/errors/TransitiveDctorExportError.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeclConflictClassCtor.out b/tests/purs/failing/DeclConflictClassCtor.out new file mode 100644 index 0000000000..1255cf83fd --- /dev/null +++ b/tests/purs/failing/DeclConflictClassCtor.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DeclConflictClassCtor.purs:6:1 - 6:11 (line 6, column 1 - line 6, column 11) + + Declaration for type class Fail conflicts with an existing data constructor of the same name. + + +See https://github.com/purescript/documentation/blob/master/errors/DeclConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeclConflictClassSynonym.out b/tests/purs/failing/DeclConflictClassSynonym.out new file mode 100644 index 0000000000..d702725c8e --- /dev/null +++ b/tests/purs/failing/DeclConflictClassSynonym.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DeclConflictClassSynonym.purs:8:1 - 8:11 (line 8, column 1 - line 8, column 11) + + Declaration for type class Fail conflicts with an existing type of the same name. + + +See https://github.com/purescript/documentation/blob/master/errors/DeclConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeclConflictClassType.out b/tests/purs/failing/DeclConflictClassType.out new file mode 100644 index 0000000000..c7d9bcc3e3 --- /dev/null +++ b/tests/purs/failing/DeclConflictClassType.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DeclConflictClassType.purs:6:1 - 6:10 (line 6, column 1 - line 6, column 10) + + Declaration for type Fail conflicts with an existing type class of the same name. + + +See https://github.com/purescript/documentation/blob/master/errors/DeclConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeclConflictCtorClass.out b/tests/purs/failing/DeclConflictCtorClass.out new file mode 100644 index 0000000000..6154617500 --- /dev/null +++ b/tests/purs/failing/DeclConflictCtorClass.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DeclConflictCtorClass.purs:6:1 - 6:14 (line 6, column 1 - line 6, column 14) + + Declaration for data constructor Fail conflicts with an existing type class of the same name. + + +See https://github.com/purescript/documentation/blob/master/errors/DeclConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeclConflictCtorCtor.out b/tests/purs/failing/DeclConflictCtorCtor.out new file mode 100644 index 0000000000..eb449fd223 --- /dev/null +++ b/tests/purs/failing/DeclConflictCtorCtor.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DeclConflictCtorCtor.purs:6:1 - 6:15 (line 6, column 1 - line 6, column 15) + + Declaration for data constructor Fail conflicts with an existing data constructor of the same name. + + +See https://github.com/purescript/documentation/blob/master/errors/DeclConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeclConflictDuplicateCtor.out b/tests/purs/failing/DeclConflictDuplicateCtor.out new file mode 100644 index 0000000000..dd1e822bee --- /dev/null +++ b/tests/purs/failing/DeclConflictDuplicateCtor.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DeclConflictDuplicateCtor.purs:4:1 - 4:21 (line 4, column 1 - line 4, column 21) + + Declaration for data constructor Fail conflicts with an existing data constructor of the same name. + + +See https://github.com/purescript/documentation/blob/master/errors/DeclConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeclConflictSynonymClass.out b/tests/purs/failing/DeclConflictSynonymClass.out new file mode 100644 index 0000000000..a2c7f59b2e --- /dev/null +++ b/tests/purs/failing/DeclConflictSynonymClass.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DeclConflictSynonymClass.purs:8:1 - 8:17 (line 8, column 1 - line 8, column 17) + + Declaration for type Fail conflicts with an existing type class of the same name. + + +See https://github.com/purescript/documentation/blob/master/errors/DeclConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeclConflictSynonymType.out b/tests/purs/failing/DeclConflictSynonymType.out new file mode 100644 index 0000000000..a4d2112e19 --- /dev/null +++ b/tests/purs/failing/DeclConflictSynonymType.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DeclConflictSynonymType.purs:8:1 - 8:17 (line 8, column 1 - line 8, column 17) + + Declaration for type Fail conflicts with an existing type of the same name. + + +See https://github.com/purescript/documentation/blob/master/errors/DeclConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeclConflictTypeClass.out b/tests/purs/failing/DeclConflictTypeClass.out new file mode 100644 index 0000000000..1e1c9edb98 --- /dev/null +++ b/tests/purs/failing/DeclConflictTypeClass.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DeclConflictTypeClass.purs:6:1 - 6:10 (line 6, column 1 - line 6, column 10) + + Declaration for type Fail conflicts with an existing type class of the same name. + + +See https://github.com/purescript/documentation/blob/master/errors/DeclConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeclConflictTypeSynonym.out b/tests/purs/failing/DeclConflictTypeSynonym.out new file mode 100644 index 0000000000..a80b3db1c6 --- /dev/null +++ b/tests/purs/failing/DeclConflictTypeSynonym.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DeclConflictTypeSynonym.purs:8:1 - 8:10 (line 8, column 1 - line 8, column 10) + + Declaration for type Fail conflicts with an existing type of the same name. + + +See https://github.com/purescript/documentation/blob/master/errors/DeclConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeclConflictTypeType.out b/tests/purs/failing/DeclConflictTypeType.out new file mode 100644 index 0000000000..33ee9ea366 --- /dev/null +++ b/tests/purs/failing/DeclConflictTypeType.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DeclConflictTypeType.purs:6:1 - 6:10 (line 6, column 1 - line 6, column 10) + + Declaration for type Fail conflicts with an existing type of the same name. + + +See https://github.com/purescript/documentation/blob/master/errors/DeclConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DiffKindsSameName.out b/tests/purs/failing/DiffKindsSameName.out new file mode 100644 index 0000000000..89355c1062 --- /dev/null +++ b/tests/purs/failing/DiffKindsSameName.out @@ -0,0 +1,19 @@ +Error found: +in module DiffKindsSameName +at tests/purs/failing/DiffKindsSameName.purs:13:18 - 13:31 (line 13, column 18 - line 13, column 31) + + Could not match kind + + DiffKindsSameName.LibA.DemoKind + + with kind + + DiffKindsSameName.LibB.DemoKind + + +while checking the kind of AProxy DemoData +in value declaration bProxy + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DiffKindsSameName/LibA.out b/tests/purs/failing/DiffKindsSameName/LibA.out new file mode 100644 index 0000000000..89355c1062 --- /dev/null +++ b/tests/purs/failing/DiffKindsSameName/LibA.out @@ -0,0 +1,19 @@ +Error found: +in module DiffKindsSameName +at tests/purs/failing/DiffKindsSameName.purs:13:18 - 13:31 (line 13, column 18 - line 13, column 31) + + Could not match kind + + DiffKindsSameName.LibA.DemoKind + + with kind + + DiffKindsSameName.LibB.DemoKind + + +while checking the kind of AProxy DemoData +in value declaration bProxy + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/Do.out b/tests/purs/failing/Do.out new file mode 100644 index 0000000000..1305beb431 --- /dev/null +++ b/tests/purs/failing/Do.out @@ -0,0 +1,20 @@ +Error 1 of 2: + + at tests/purs/failing/Do.purs:7:12 - 7:21 (line 7, column 12 - line 7, column 21) + + The last statement in a 'do' block must be an expression, but this block ends with a let binding. + + + See https://github.com/purescript/documentation/blob/master/errors/InvalidDoLet.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + at tests/purs/failing/Do.purs:9:14 - 9:20 (line 9, column 14 - line 9, column 20) + + The last statement in a 'do' block must be an expression, but this block ends with a binder. + + + See https://github.com/purescript/documentation/blob/master/errors/InvalidDoBind.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/failing/DoNotSuggestComposition.out b/tests/purs/failing/DoNotSuggestComposition.out new file mode 100644 index 0000000000..3f9019412d --- /dev/null +++ b/tests/purs/failing/DoNotSuggestComposition.out @@ -0,0 +1,24 @@ +Error found: +in module DoNotSuggestComposition +at tests/purs/failing/DoNotSuggestComposition.purs:13:11 - 13:12 (line 13, column 11 - line 13, column 12) + + Could not match type +   +  { y :: Int +  }  +   + with type +   +  String +   + +while checking that type { y :: Int + }  + is at least as general as type String +while checking that expression x + has type String +in value declaration bar + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DoNotSuggestComposition2.out b/tests/purs/failing/DoNotSuggestComposition2.out new file mode 100644 index 0000000000..5126c8a650 --- /dev/null +++ b/tests/purs/failing/DoNotSuggestComposition2.out @@ -0,0 +1,24 @@ +Error found: +in module DoNotSuggestComposition2 +at tests/purs/failing/DoNotSuggestComposition2.purs:7:27 - 7:30 (line 7, column 27 - line 7, column 30) + + Could not match type +   +  Record +   + with type +   +  Function Int +   + +while trying to match type { y :: Int + }  + with type Int -> t0 +while inferring the type of x 2 +in value declaration foo + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DuplicateDeclarationsInLet.out b/tests/purs/failing/DuplicateDeclarationsInLet.out new file mode 100644 index 0000000000..831dad6fc2 --- /dev/null +++ b/tests/purs/failing/DuplicateDeclarationsInLet.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DuplicateDeclarationsInLet.purs:6:7 - 6:8 (line 6, column 7 - line 6, column 8) + + The same name was used more than once in a let binding. + + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingNamesInLet.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DuplicateInstance.out b/tests/purs/failing/DuplicateInstance.out new file mode 100644 index 0000000000..8125e48b55 --- /dev/null +++ b/tests/purs/failing/DuplicateInstance.out @@ -0,0 +1,17 @@ +Error found: +in module Main +at tests/purs/failing/DuplicateInstance.purs:6:1 - 6:16 (line 6, column 1 - line 6, column 16) + + Instance i has been defined multiple times: + + tests/purs/failing/DuplicateInstance.purs:6:1 - 6:16 (line 6, column 1 - line 6, column 16) + + +in type class instance +  + Main.Y  +  + +See https://github.com/purescript/documentation/blob/master/errors/DuplicateInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DuplicateModule.out b/tests/purs/failing/DuplicateModule.out new file mode 100644 index 0000000000..7e66ff75bd --- /dev/null +++ b/tests/purs/failing/DuplicateModule.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/DuplicateModule.purs:2:1 - 2:16 (line 2, column 1 - line 2, column 16) + + Module M1 has been defined multiple times + + +See https://github.com/purescript/documentation/blob/master/errors/DuplicateModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DuplicateProperties.out b/tests/purs/failing/DuplicateProperties.out new file mode 100644 index 0000000000..6ed0c05e2f --- /dev/null +++ b/tests/purs/failing/DuplicateProperties.out @@ -0,0 +1,41 @@ +Error found: +in module DuplicateProperties +at tests/purs/failing/DuplicateProperties.purs:12:18 - 12:32 (line 12, column 18 - line 12, column 32) + + Could not match type +   +  ( y :: Unit +  ...  +  )  +   + with type +   +  ( x :: Unit +  ...  +  | t0  +  )  +   + +while trying to match type   +  ( y :: Unit +  ...  +  )  +   + with type   +  ( x :: Unit +  ...  +  | t0  +  )  +   +while checking that expression subtractX hasX + has type Test  +  ( x :: Unit +  | t0  +  )  +in value declaration baz + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DuplicateTypeClass.out b/tests/purs/failing/DuplicateTypeClass.out new file mode 100644 index 0000000000..07720698ac --- /dev/null +++ b/tests/purs/failing/DuplicateTypeClass.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/DuplicateTypeClass.purs:3:1 - 3:8 (line 3, column 1 - line 3, column 8) + + Type class C has been defined multiple times: + + tests/purs/failing/DuplicateTypeClass.purs:3:1 - 3:8 (line 3, column 1 - line 3, column 8) + + +in type class declaration for C + +See https://github.com/purescript/documentation/blob/master/errors/DuplicateTypeClass.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DuplicateTypeVars.out b/tests/purs/failing/DuplicateTypeVars.out new file mode 100644 index 0000000000..7fe945070b --- /dev/null +++ b/tests/purs/failing/DuplicateTypeVars.out @@ -0,0 +1,11 @@ +Error found: +in module Main +at tests/purs/failing/DuplicateTypeVars.purs:6:1 - 6:17 (line 6, column 1 - line 6, column 17) + + Type argument a appears more than once. + +in type synonym Foo + +See https://github.com/purescript/documentation/blob/master/errors/DuplicateTypeArgument.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/EmptyCase.out b/tests/purs/failing/EmptyCase.out new file mode 100644 index 0000000000..8cd02d79ef --- /dev/null +++ b/tests/purs/failing/EmptyCase.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/EmptyCase.purs:4:25 - 4:26 (line 4, column 25 - line 4, column 26) + + Unable to parse module: + Unexpected token '\' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/EmptyClass.out b/tests/purs/failing/EmptyClass.out new file mode 100644 index 0000000000..6c85282245 --- /dev/null +++ b/tests/purs/failing/EmptyClass.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/EmptyClass.purs:6:1 - 6:1 (line 6, column 1 - line 6, column 1) + + Unable to parse module: + Unexpected or mismatched indentation + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/EmptyDo.out b/tests/purs/failing/EmptyDo.out new file mode 100644 index 0000000000..fbedcb0d6f --- /dev/null +++ b/tests/purs/failing/EmptyDo.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/EmptyDo.purs:7:1 - 7:1 (line 7, column 1 - line 7, column 1) + + Unable to parse module: + Unexpected or mismatched indentation + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExpectedWildcard.out b/tests/purs/failing/ExpectedWildcard.out new file mode 100644 index 0000000000..d450d19332 --- /dev/null +++ b/tests/purs/failing/ExpectedWildcard.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/ExpectedWildcard.purs:8:1 - 8:51 (line 8, column 1 - line 8, column 51) + + Expected a type wildcard (_) when deriving an instance for Test. + + +See https://github.com/purescript/documentation/blob/master/errors/ExpectedWildcard.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportConflictClass.out b/tests/purs/failing/ExportConflictClass.out new file mode 100644 index 0000000000..42d80e6017 --- /dev/null +++ b/tests/purs/failing/ExportConflictClass.out @@ -0,0 +1,10 @@ +Error found: +in module C +at tests/purs/failing/ExportConflictClass.purs:2:21 - 2:29 (line 2, column 21 - line 2, column 29) + + Export for type class B.X conflicts with type class A.X + + +See https://github.com/purescript/documentation/blob/master/errors/ExportConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportConflictClass/B.out b/tests/purs/failing/ExportConflictClass/B.out new file mode 100644 index 0000000000..42d80e6017 --- /dev/null +++ b/tests/purs/failing/ExportConflictClass/B.out @@ -0,0 +1,10 @@ +Error found: +in module C +at tests/purs/failing/ExportConflictClass.purs:2:21 - 2:29 (line 2, column 21 - line 2, column 29) + + Export for type class B.X conflicts with type class A.X + + +See https://github.com/purescript/documentation/blob/master/errors/ExportConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportConflictClassAndType.out b/tests/purs/failing/ExportConflictClassAndType.out new file mode 100644 index 0000000000..ed620fa4c7 --- /dev/null +++ b/tests/purs/failing/ExportConflictClassAndType.out @@ -0,0 +1,10 @@ +Error found: +in module C +at tests/purs/failing/ExportConflictClassAndType.purs:2:21 - 2:29 (line 2, column 21 - line 2, column 29) + + Export for type B.X conflicts with type class A.X + + +See https://github.com/purescript/documentation/blob/master/errors/ExportConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportConflictClassAndType/B.out b/tests/purs/failing/ExportConflictClassAndType/B.out new file mode 100644 index 0000000000..ed620fa4c7 --- /dev/null +++ b/tests/purs/failing/ExportConflictClassAndType/B.out @@ -0,0 +1,10 @@ +Error found: +in module C +at tests/purs/failing/ExportConflictClassAndType.purs:2:21 - 2:29 (line 2, column 21 - line 2, column 29) + + Export for type B.X conflicts with type class A.X + + +See https://github.com/purescript/documentation/blob/master/errors/ExportConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportConflictCtor.out b/tests/purs/failing/ExportConflictCtor.out new file mode 100644 index 0000000000..05fbfaf7b2 --- /dev/null +++ b/tests/purs/failing/ExportConflictCtor.out @@ -0,0 +1,10 @@ +Error found: +in module C +at tests/purs/failing/ExportConflictCtor.purs:2:21 - 2:29 (line 2, column 21 - line 2, column 29) + + Export for data constructor B.X conflicts with data constructor A.X + + +See https://github.com/purescript/documentation/blob/master/errors/ExportConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportConflictType.out b/tests/purs/failing/ExportConflictType.out new file mode 100644 index 0000000000..742d37d744 --- /dev/null +++ b/tests/purs/failing/ExportConflictType.out @@ -0,0 +1,10 @@ +Error found: +in module C +at tests/purs/failing/ExportConflictType.purs:2:21 - 2:29 (line 2, column 21 - line 2, column 29) + + Export for type B.T conflicts with type A.T + + +See https://github.com/purescript/documentation/blob/master/errors/ExportConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportConflictType/B.out b/tests/purs/failing/ExportConflictType/B.out new file mode 100644 index 0000000000..742d37d744 --- /dev/null +++ b/tests/purs/failing/ExportConflictType/B.out @@ -0,0 +1,10 @@ +Error found: +in module C +at tests/purs/failing/ExportConflictType.purs:2:21 - 2:29 (line 2, column 21 - line 2, column 29) + + Export for type B.T conflicts with type A.T + + +See https://github.com/purescript/documentation/blob/master/errors/ExportConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportConflictTypeOp.out b/tests/purs/failing/ExportConflictTypeOp.out new file mode 100644 index 0000000000..109b5fa317 --- /dev/null +++ b/tests/purs/failing/ExportConflictTypeOp.out @@ -0,0 +1,10 @@ +Error found: +in module C +at tests/purs/failing/ExportConflictTypeOp.purs:2:21 - 2:29 (line 2, column 21 - line 2, column 29) + + Export for type operator B.(??) conflicts with type operator A.(??) + + +See https://github.com/purescript/documentation/blob/master/errors/ExportConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportConflictValue.out b/tests/purs/failing/ExportConflictValue.out new file mode 100644 index 0000000000..1a4c14908b --- /dev/null +++ b/tests/purs/failing/ExportConflictValue.out @@ -0,0 +1,10 @@ +Error found: +in module C +at tests/purs/failing/ExportConflictValue.purs:2:21 - 2:29 (line 2, column 21 - line 2, column 29) + + Export for value B.x conflicts with value A.x + + +See https://github.com/purescript/documentation/blob/master/errors/ExportConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportConflictValueOp.out b/tests/purs/failing/ExportConflictValueOp.out new file mode 100644 index 0000000000..2a75e447a5 --- /dev/null +++ b/tests/purs/failing/ExportConflictValueOp.out @@ -0,0 +1,10 @@ +Error found: +in module C +at tests/purs/failing/ExportConflictValueOp.purs:2:21 - 2:29 (line 2, column 21 - line 2, column 29) + + Export for operator B.(!!) conflicts with operator A.(!!) + + +See https://github.com/purescript/documentation/blob/master/errors/ExportConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportConflictValueOp/B.out b/tests/purs/failing/ExportConflictValueOp/B.out new file mode 100644 index 0000000000..2a75e447a5 --- /dev/null +++ b/tests/purs/failing/ExportConflictValueOp/B.out @@ -0,0 +1,10 @@ +Error found: +in module C +at tests/purs/failing/ExportConflictValueOp.purs:2:21 - 2:29 (line 2, column 21 - line 2, column 29) + + Export for operator B.(!!) conflicts with operator A.(!!) + + +See https://github.com/purescript/documentation/blob/master/errors/ExportConflict.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportExplicit.out b/tests/purs/failing/ExportExplicit.out new file mode 100644 index 0000000000..13bc578507 --- /dev/null +++ b/tests/purs/failing/ExportExplicit.out @@ -0,0 +1,10 @@ +Error found: +in module M1 +at tests/purs/failing/ExportExplicit.purs:3:18 - 3:19 (line 3, column 18 - line 3, column 19) + + Cannot export unknown value z + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownExport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportExplicit1.out b/tests/purs/failing/ExportExplicit1.out new file mode 100644 index 0000000000..309c407aeb --- /dev/null +++ b/tests/purs/failing/ExportExplicit1.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/ExportExplicit1.purs:10:9 - 10:10 (line 10, column 9 - line 10, column 10) + + Unknown data constructor Y + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportExplicit1/M1.out b/tests/purs/failing/ExportExplicit1/M1.out new file mode 100644 index 0000000000..309c407aeb --- /dev/null +++ b/tests/purs/failing/ExportExplicit1/M1.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/ExportExplicit1.purs:10:9 - 10:10 (line 10, column 9 - line 10, column 10) + + Unknown data constructor Y + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportExplicit2.out b/tests/purs/failing/ExportExplicit2.out new file mode 100644 index 0000000000..c251493c37 --- /dev/null +++ b/tests/purs/failing/ExportExplicit2.out @@ -0,0 +1,10 @@ +Error found: +in module M1 +at tests/purs/failing/ExportExplicit2.purs:3:12 - 3:16 (line 3, column 12 - line 3, column 16) + + Cannot export data constructor Y for type X, as it has not been declared. + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownExportDataConstructor.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExportExplicit3.out b/tests/purs/failing/ExportExplicit3.out new file mode 100644 index 0000000000..51b722c39b --- /dev/null +++ b/tests/purs/failing/ExportExplicit3.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/ExportExplicit3.purs:8:9 - 8:12 (line 8, column 9 - line 8, column 12) + + Unknown data constructor M.Z + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExtraRecordField.out b/tests/purs/failing/ExtraRecordField.out new file mode 100644 index 0000000000..a4b1ed0d1a --- /dev/null +++ b/tests/purs/failing/ExtraRecordField.out @@ -0,0 +1,27 @@ +Error found: +in module ExtraRecordField +at tests/purs/failing/ExtraRecordField.purs:9:13 - 9:54 (line 9, column 13 - line 9, column 54) + + Type of expression contains additional label age. + +while checking that expression { first: "Jane" + , last: "Smith" + , age: 29  + }  + has type { first :: String + , last :: String  + }  +while applying a function full + of type { first :: String + , last :: String  + }  + -> String  + to argument { first: "Jane" + , last: "Smith" + , age: 29  + }  +in value declaration oops + +See https://github.com/purescript/documentation/blob/master/errors/AdditionalProperty.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ExtraneousClassMember.out b/tests/purs/failing/ExtraneousClassMember.out new file mode 100644 index 0000000000..75c34372d9 --- /dev/null +++ b/tests/purs/failing/ExtraneousClassMember.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/ExtraneousClassMember.purs:11:3 - 11:10 (line 11, column 3 - line 11, column 10) + + b is not a member of type class Main.A + +in type class instance +  + Main.A String +  + +See https://github.com/purescript/documentation/blob/master/errors/ExtraneousClassMember.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/Foldable.out b/tests/purs/failing/Foldable.out new file mode 100644 index 0000000000..5ddfefcc76 --- /dev/null +++ b/tests/purs/failing/Foldable.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/Foldable.purs:12:1 - 15:36 (line 12, column 1 - line 15, column 36) + + The value of foldableL is undefined here, so this reference is not allowed. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/Generalization1.out b/tests/purs/failing/Generalization1.out new file mode 100644 index 0000000000..1f41f27288 --- /dev/null +++ b/tests/purs/failing/Generalization1.out @@ -0,0 +1,16 @@ +Error found: +in module Main +at tests/purs/failing/Generalization1.purs:6:1 - 6:14 (line 6, column 1 - line 6, column 14) + + Unable to generalize the type of the recursive function foo. + The inferred type of foo was: +   +  forall t4. Semigroup t4 => Int -> t4 -> t4 -> t4 +   + Try adding a type signature. + +in binding group foo, bar + +See https://github.com/purescript/documentation/blob/master/errors/CannotGeneralizeRecursiveFunction.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/Generalization2.out b/tests/purs/failing/Generalization2.out new file mode 100644 index 0000000000..d87ab6757f --- /dev/null +++ b/tests/purs/failing/Generalization2.out @@ -0,0 +1,16 @@ +Error found: +in module Main +at tests/purs/failing/Generalization2.purs:6:1 - 7:45 (line 6, column 1 - line 7, column 45) + + Unable to generalize the type of the recursive function test. + The inferred type of test was: +   +  forall t7. Semigroup t7 => Int -> t7 -> t7 +   + Try adding a type signature. + +in binding group test + +See https://github.com/purescript/documentation/blob/master/errors/CannotGeneralizeRecursiveFunction.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ImportExplicit.out b/tests/purs/failing/ImportExplicit.out new file mode 100644 index 0000000000..d130697ebf --- /dev/null +++ b/tests/purs/failing/ImportExplicit.out @@ -0,0 +1,11 @@ +Error found: +in module Main +at tests/purs/failing/ImportExplicit.purs:4:12 - 4:17 (line 4, column 12 - line 4, column 17) + + Cannot import type X from module M1 + It either does not exist or the module does not export it. + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownImport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ImportExplicit/M1.out b/tests/purs/failing/ImportExplicit/M1.out new file mode 100644 index 0000000000..d130697ebf --- /dev/null +++ b/tests/purs/failing/ImportExplicit/M1.out @@ -0,0 +1,11 @@ +Error found: +in module Main +at tests/purs/failing/ImportExplicit.purs:4:12 - 4:17 (line 4, column 12 - line 4, column 17) + + Cannot import type X from module M1 + It either does not exist or the module does not export it. + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownImport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ImportExplicit2.out b/tests/purs/failing/ImportExplicit2.out new file mode 100644 index 0000000000..2647d0a0c9 --- /dev/null +++ b/tests/purs/failing/ImportExplicit2.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/ImportExplicit2.purs:4:12 - 4:19 (line 4, column 12 - line 4, column 19) + + Module M1 does not export data constructor Z for type X + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownImportDataConstructor.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ImportHidingModule.out b/tests/purs/failing/ImportHidingModule.out new file mode 100644 index 0000000000..bc493691da --- /dev/null +++ b/tests/purs/failing/ImportHidingModule.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/ImportHidingModule.purs:4:18 - 4:24 (line 4, column 18 - line 4, column 24) + + Unable to parse module: + Unexpected token 'module' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ImportModule.out b/tests/purs/failing/ImportModule.out new file mode 100644 index 0000000000..76e22a6dc0 --- /dev/null +++ b/tests/purs/failing/ImportModule.out @@ -0,0 +1,11 @@ +Error found: +in module Main +at tests/purs/failing/ImportModule.purs:4:1 - 4:10 (line 4, column 1 - line 4, column 10) + + Module M1 was not found. + Make sure the source file exists, and that it has been provided as an input to the compiler. + + +See https://github.com/purescript/documentation/blob/master/errors/ModuleNotFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InfiniteKind.out b/tests/purs/failing/InfiniteKind.out new file mode 100644 index 0000000000..03dcf11f2c --- /dev/null +++ b/tests/purs/failing/InfiniteKind.out @@ -0,0 +1,15 @@ +Error found: +in module Main +at tests/purs/failing/InfiniteKind.purs:5:15 - 5:18 (line 5, column 15 - line 5, column 18) + + An infinite kind was inferred for a type: + + k1 -> k2 + + +while checking the kind of a a +in type constructor F + +See https://github.com/purescript/documentation/blob/master/errors/InfiniteKind.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InfiniteKind2.out b/tests/purs/failing/InfiniteKind2.out new file mode 100644 index 0000000000..efaf0e18b0 --- /dev/null +++ b/tests/purs/failing/InfiniteKind2.out @@ -0,0 +1,14 @@ +Error found: +in module InfiniteKind2 +at tests/purs/failing/InfiniteKind2.purs:5:1 - 5:36 (line 5, column 1 - line 5, column 36) + + An infinite kind was inferred for a type: + + (k4 -> k3) -> Type + + +in type constructor Tree + +See https://github.com/purescript/documentation/blob/master/errors/InfiniteKind.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InfiniteType.out b/tests/purs/failing/InfiniteType.out new file mode 100644 index 0000000000..996bfc9272 --- /dev/null +++ b/tests/purs/failing/InfiniteType.out @@ -0,0 +1,21 @@ +Error found: +in module Main +at tests/purs/failing/InfiniteType.purs:5:7 - 5:10 (line 5, column 7 - line 5, column 10) + + An infinite type was inferred for an expression: +   +  t0 -> t1 +   + +while trying to match type t0 + with type t0 -> t1 +while inferring the type of \a ->  +  a a  +in value declaration f + +where t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/InfiniteType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InstanceChainBothUnknownAndMatch.out b/tests/purs/failing/InstanceChainBothUnknownAndMatch.out new file mode 100644 index 0000000000..4284b97d1e --- /dev/null +++ b/tests/purs/failing/InstanceChainBothUnknownAndMatch.out @@ -0,0 +1,36 @@ +Error found: +in module InstanceChains.BothUnknownAndMatch +at tests/purs/failing/InstanceChainBothUnknownAndMatch.purs:17:13 - 17:55 (line 17, column 13 - line 17, column 55) + + No type class instance was found for +   +  InstanceChains.BothUnknownAndMatch.Same (RProxy  +  ( m :: Int +  , u :: t3  +  )  +  )  +  (RProxy  +  ( m :: Int +  , u :: Int +  )  +  )  +  t4  +   + The instance head contains unknown type variables. Consider adding a type annotation. + +while applying a function same + of type Same t0 t1 t2 => t0 -> t1 -> SProxy t2 + to argument RProxy +while inferring the type of same RProxy +in value declaration example + +where t3 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t4 is an unknown type + t2 is an unknown type + t1 is an unknown type + t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out new file mode 100644 index 0000000000..d7cd4af230 --- /dev/null +++ b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out @@ -0,0 +1,28 @@ +Error found: +in module InstanceChainSkolemUnknownMatch +at tests/purs/failing/InstanceChainSkolemUnknownMatch.purs:14:13 - 14:36 (line 14, column 13 - line 14, column 36) + + No type class instance was found for +   +  InstanceChainSkolemUnknownMatch.Same (Proxy t3)  +  (Proxy Int) +  t4  +   + The instance head contains unknown type variables. Consider adding a type annotation. + +while applying a function same + of type Same t0 t1 t2 => t0 -> t1 -> SProxy t2 + to argument Proxy +while inferring the type of same Proxy +in value declaration example + +where t3 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t4 is an unknown type + t2 is an unknown type + t1 is an unknown type + t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InstanceExport.out b/tests/purs/failing/InstanceExport.out new file mode 100644 index 0000000000..a7a57f49b8 --- /dev/null +++ b/tests/purs/failing/InstanceExport.out @@ -0,0 +1,13 @@ +Error found: +in module InstanceExport +at tests/purs/failing/InstanceExport/InstanceExport.purs:1:1 - 11:14 (line 1, column 1 - line 11, column 14) + + An export for f requires the following to also be exported: + + class F + + + +See https://github.com/purescript/documentation/blob/master/errors/TransitiveExportError.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InstanceSigsBodyIncorrect.out b/tests/purs/failing/InstanceSigsBodyIncorrect.out new file mode 100644 index 0000000000..d29e6cddbc --- /dev/null +++ b/tests/purs/failing/InstanceSigsBodyIncorrect.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/InstanceSigsBodyIncorrect.purs:10:9 - 10:13 (line 10, column 9 - line 10, column 13) + + Could not match type +   +  Boolean +   + with type +   +  Number +   + +while checking that type Boolean + is at least as general as type Number +while checking that expression true + has type Number +in value declaration fooNumber + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InstanceSigsDifferentTypes.out b/tests/purs/failing/InstanceSigsDifferentTypes.out new file mode 100644 index 0000000000..cbcc24c362 --- /dev/null +++ b/tests/purs/failing/InstanceSigsDifferentTypes.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/InstanceSigsDifferentTypes.purs:8:1 - 10:12 (line 8, column 1 - line 10, column 12) + + Could not match type +   +  Int +   + with type +   +  Number +   + +while checking that type Int + is at least as general as type Number +while checking that expression 0.0 + has type Number +in value declaration fooNumber + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InstanceSigsIncorrectType.out b/tests/purs/failing/InstanceSigsIncorrectType.out new file mode 100644 index 0000000000..bd5bc19196 --- /dev/null +++ b/tests/purs/failing/InstanceSigsIncorrectType.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/InstanceSigsIncorrectType.purs:8:1 - 10:13 (line 8, column 1 - line 10, column 13) + + Could not match type +   +  Boolean +   + with type +   +  Number +   + +while checking that type Boolean + is at least as general as type Number +while checking that expression true + has type Number +in value declaration fooNumber + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InstanceSigsOrphanTypeDeclaration.out b/tests/purs/failing/InstanceSigsOrphanTypeDeclaration.out new file mode 100644 index 0000000000..5acb034332 --- /dev/null +++ b/tests/purs/failing/InstanceSigsOrphanTypeDeclaration.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/InstanceSigsOrphanTypeDeclaration.purs:10:3 - 10:12 (line 10, column 3 - line 10, column 12) + + The type declaration for bar should be followed by its definition. + + +See https://github.com/purescript/documentation/blob/master/errors/OrphanTypeDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/IntOutOfRange.out b/tests/purs/failing/IntOutOfRange.out new file mode 100644 index 0000000000..da5a10b480 --- /dev/null +++ b/tests/purs/failing/IntOutOfRange.out @@ -0,0 +1,11 @@ +Error found: +in module Main +at tests/purs/failing/IntOutOfRange.purs:6:5 - 6:15 (line 6, column 5 - line 6, column 15) + + Integer value 2147483648 is out of range for the JavaScript backend. + Acceptable values fall within the range -2147483648 to 2147483647 (inclusive). + + +See https://github.com/purescript/documentation/blob/master/errors/IntOutOfRange.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InvalidDerivedInstance.out b/tests/purs/failing/InvalidDerivedInstance.out new file mode 100644 index 0000000000..5377cb056b --- /dev/null +++ b/tests/purs/failing/InvalidDerivedInstance.out @@ -0,0 +1,14 @@ +Error found: +at tests/purs/failing/InvalidDerivedInstance.purs:8:1 - 8:30 (line 8, column 1 - line 8, column 30) + + Cannot derive the type class instance +   +  Data.Eq.Eq X +  X +   + because the Data.Eq.Eq type class has 1 type argument, but the declaration specifies 2. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidDerivedInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InvalidDerivedInstance2.out b/tests/purs/failing/InvalidDerivedInstance2.out new file mode 100644 index 0000000000..385bace2f4 --- /dev/null +++ b/tests/purs/failing/InvalidDerivedInstance2.out @@ -0,0 +1,17 @@ +Error found: +at tests/purs/failing/InvalidDerivedInstance2.purs:6:1 - 6:34 (line 6, column 1 - line 6, column 34) + + Cannot derive the type class instance +   +  Data.Eq.Eq (Record ()) +   + because the type +   +  Record () +   + is not of the required form T a_1 ... a_n, where T is a type constructor defined in the same module. + + +See https://github.com/purescript/documentation/blob/master/errors/ExpectedTypeConstructor.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InvalidOperatorInBinder.out b/tests/purs/failing/InvalidOperatorInBinder.out new file mode 100644 index 0000000000..0b0541276d --- /dev/null +++ b/tests/purs/failing/InvalidOperatorInBinder.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/InvalidOperatorInBinder.purs:12:12 - 12:13 (line 12, column 12 - line 12, column 13) + + Operator Main.(:) cannot be used in a pattern as it is an alias for function Main.cons. + Only aliases for data constructors may be used in patterns. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidOperatorInBinder.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/KindError.out b/tests/purs/failing/KindError.out new file mode 100644 index 0000000000..4fbd07da7e --- /dev/null +++ b/tests/purs/failing/KindError.out @@ -0,0 +1,18 @@ +Error found: +in module Main +at tests/purs/failing/KindError.purs:6:35 - 6:38 (line 6, column 35 - line 6, column 38) + + Could not match kind + + k2 -> k3 + + with kind + + Type + + +in type constructor KindError + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/KindStar.out b/tests/purs/failing/KindStar.out new file mode 100644 index 0000000000..a4926ef8b2 --- /dev/null +++ b/tests/purs/failing/KindStar.out @@ -0,0 +1,20 @@ +Error found: +in module X +at tests/purs/failing/KindStar.purs:7:1 - 7:13 (line 7, column 1 - line 7, column 13) + + In a type-annotated expression x :: t, the type t must have kind Type. + The error arises from the type +   +  List +   + having the kind + + Type -> Type + + instead. + +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/ExpectedType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LacksWithSubGoal.out b/tests/purs/failing/LacksWithSubGoal.out new file mode 100644 index 0000000000..3ad9219517 --- /dev/null +++ b/tests/purs/failing/LacksWithSubGoal.out @@ -0,0 +1,28 @@ +Error found: +in module LacksWithSubGoal +at tests/purs/failing/LacksWithSubGoal.purs:14:11 - 14:33 (line 14, column 11 - line 14, column 33) + + No type class instance was found for +   +  Prim.Row.Lacks "hello" +  r0  +   + +while applying a function union + of type Lacks t1 t2 => S t1 -> R t2 + to argument S +while checking that expression union S + has type R  +  ( k :: Int +  | r0  +  )  +in value declaration example + +where r0 is a rigid type variable + bound at (line 14, column 11 - line 14, column 33) + t2 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LeadingZeros1.out b/tests/purs/failing/LeadingZeros1.out new file mode 100644 index 0000000000..c383f62eac --- /dev/null +++ b/tests/purs/failing/LeadingZeros1.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/LeadingZeros1.purs:6:6 - 6:7 (line 6, column 6 - line 6, column 7) + + Unable to parse module: + Unexpected leading zeros + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LeadingZeros2.out b/tests/purs/failing/LeadingZeros2.out new file mode 100644 index 0000000000..276c4a4f65 --- /dev/null +++ b/tests/purs/failing/LeadingZeros2.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/LeadingZeros2.purs:6:6 - 6:7 (line 6, column 6 - line 6, column 7) + + Unable to parse module: + Unexpected leading zeros + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/Let.out b/tests/purs/failing/Let.out new file mode 100644 index 0000000000..1cb58cd24e --- /dev/null +++ b/tests/purs/failing/Let.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/Let.purs:6:12 - 6:17 (line 6, column 12 - line 6, column 17) + + The value of x is undefined here, so this reference is not allowed. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LetPatterns1.out b/tests/purs/failing/LetPatterns1.out new file mode 100644 index 0000000000..c5ad32edb2 --- /dev/null +++ b/tests/purs/failing/LetPatterns1.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/LetPatterns1.purs:8:7 - 8:14 (line 8, column 7 - line 8, column 14) + + Unable to parse module: + Expected pattern, saw expression + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LetPatterns2.out b/tests/purs/failing/LetPatterns2.out new file mode 100644 index 0000000000..b68af65d9f --- /dev/null +++ b/tests/purs/failing/LetPatterns2.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/LetPatterns2.purs:11:9 - 11:10 (line 11, column 9 - line 11, column 10) + + Unknown value a + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LetPatterns3.out b/tests/purs/failing/LetPatterns3.out new file mode 100644 index 0000000000..e778d9a3f4 --- /dev/null +++ b/tests/purs/failing/LetPatterns3.out @@ -0,0 +1,16 @@ +Error found: +in module Main +at tests/purs/failing/LetPatterns3.purs:11:7 - 11:8 (line 11, column 7 - line 11, column 8) + + Data constructor Main.X was given 0 arguments in a case expression, but expected 1 arguments. + This problem can be fixed by giving Main.X 1 arguments. + +while inferring the type of \$0 ->  +  \b ->  +  case $0 b of +  X b -> ... +in value declaration x + +See https://github.com/purescript/documentation/blob/master/errors/IncorrectConstructorArity.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/LetPatterns4.out b/tests/purs/failing/LetPatterns4.out new file mode 100644 index 0000000000..7fbf0354a2 --- /dev/null +++ b/tests/purs/failing/LetPatterns4.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/LetPatterns4.purs:6:1 - 6:2 (line 6, column 1 - line 6, column 2) + + Unable to parse module: + Unexpected token 'X' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/MPTCs.out b/tests/purs/failing/MPTCs.out new file mode 100644 index 0000000000..477771d4ab --- /dev/null +++ b/tests/purs/failing/MPTCs.out @@ -0,0 +1,16 @@ +Error found: +in module Main +at tests/purs/failing/MPTCs.purs:9:1 - 10:10 (line 9, column 1 - line 10, column 10) + + The type class Main.Foo expects 1 argument. + But the instance fooStringString provided 2. + +in type class instance +  + Main.Foo String + String +  + +See https://github.com/purescript/documentation/blob/master/errors/ClassInstanceArityMismatch.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/MissingClassExport.out b/tests/purs/failing/MissingClassExport.out new file mode 100644 index 0000000000..ffee75853b --- /dev/null +++ b/tests/purs/failing/MissingClassExport.out @@ -0,0 +1,13 @@ +Error found: +in module Test +at tests/purs/failing/MissingClassExport.purs:2:1 - 7:16 (line 2, column 1 - line 7, column 16) + + An export for bar requires the following to also be exported: + + class Foo + + + +See https://github.com/purescript/documentation/blob/master/errors/TransitiveExportError.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/MissingClassMember.out b/tests/purs/failing/MissingClassMember.out new file mode 100644 index 0000000000..fcbd3dcf19 --- /dev/null +++ b/tests/purs/failing/MissingClassMember.out @@ -0,0 +1,15 @@ +Error found: +at tests/purs/failing/MissingClassMember.purs:9:1 - 10:10 (line 9, column 1 - line 10, column 10) + + The following type class members have not been implemented: + b :: String -> Number + c :: forall f. String -> f String + +in type class instance +  + Main.A String +  + +See https://github.com/purescript/documentation/blob/master/errors/MissingClassMember.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/MissingClassMemberExport.out b/tests/purs/failing/MissingClassMemberExport.out new file mode 100644 index 0000000000..3b15f091fa --- /dev/null +++ b/tests/purs/failing/MissingClassMemberExport.out @@ -0,0 +1,13 @@ +Error found: +in module Test +at tests/purs/failing/MissingClassMemberExport.purs:2:1 - 7:16 (line 2, column 1 - line 7, column 16) + + An export for class Foo requires the following to also be exported: + + bar + + + +See https://github.com/purescript/documentation/blob/master/errors/TransitiveExportError.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/MissingFFIImplementations.out b/tests/purs/failing/MissingFFIImplementations.out new file mode 100644 index 0000000000..1dd5b4f2f0 --- /dev/null +++ b/tests/purs/failing/MissingFFIImplementations.out @@ -0,0 +1,12 @@ +Error found: +at tests/purs/failing/MissingFFIImplementations.purs:2:1 - 5:29 (line 2, column 1 - line 5, column 29) + + The following values are not defined in the foreign module for module Main: + + no + + + +See https://github.com/purescript/documentation/blob/master/errors/MissingFFIImplementations.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/MissingRecordField.out b/tests/purs/failing/MissingRecordField.out new file mode 100644 index 0000000000..c6aff99a3e --- /dev/null +++ b/tests/purs/failing/MissingRecordField.out @@ -0,0 +1,23 @@ +Error found: +in module MissingRecordField +at tests/purs/failing/MissingRecordField.purs:10:19 - 10:23 (line 10, column 19 - line 10, column 23) + + Type of expression lacks required label age. + +while checking that type { first :: String + , last :: String  + }  + is at least as general as type { age :: Number + | t0  + }  +while checking that expression john + has type { age :: Number + | t0  + }  +in value declaration result + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/PropertyIsMissing.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/MixedAssociativityError.out b/tests/purs/failing/MixedAssociativityError.out new file mode 100644 index 0000000000..d0076650b7 --- /dev/null +++ b/tests/purs/failing/MixedAssociativityError.out @@ -0,0 +1,14 @@ +Error found: +at tests/purs/failing/MixedAssociativityError.purs:6:15 - 6:18 (line 6, column 15 - line 6, column 18) + + Cannot parse an expression that uses operators of the same precedence but mixed associativity: + + Data.Functor.(<$>) is infixl + Data.Eq.(==) is infix + + Use parentheses to resolve this ambiguity. + + +See https://github.com/purescript/documentation/blob/master/errors/MixedAssociativityError.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/MultipleErrors.out b/tests/purs/failing/MultipleErrors.out new file mode 100644 index 0000000000..b33b1ad362 --- /dev/null +++ b/tests/purs/failing/MultipleErrors.out @@ -0,0 +1,46 @@ +Error 1 of 2: + + in module MultipleErrors + at tests/purs/failing/MultipleErrors.purs:8:9 - 8:15 (line 8, column 9 - line 8, column 15) + + Could not match type +   +  String +   + with type +   +  Int +   + + while checking that type String + is at least as general as type Int + while checking that expression "Test" + has type Int + in binding group foo, bar + + See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module MultipleErrors + at tests/purs/failing/MultipleErrors.purs:12:9 - 12:15 (line 12, column 9 - line 12, column 15) + + Could not match type +   +  String +   + with type +   +  Int +   + + while checking that type String + is at least as general as type Int + while checking that expression "Test" + has type Int + in binding group foo, bar + + See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/failing/MultipleErrors2.out b/tests/purs/failing/MultipleErrors2.out new file mode 100644 index 0000000000..73bc7e58a3 --- /dev/null +++ b/tests/purs/failing/MultipleErrors2.out @@ -0,0 +1,22 @@ +Error 1 of 2: + + in module MultipleErrors2 + at tests/purs/failing/MultipleErrors2.purs:7:7 - 7:20 (line 7, column 7 - line 7, column 20) + + Unknown value itDoesntExist + + + See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module MultipleErrors2 + at tests/purs/failing/MultipleErrors2.purs:9:7 - 9:22 (line 9, column 7 - line 9, column 22) + + Unknown value neitherDoesThis + + + See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/failing/MultipleTypeOpFixities.out b/tests/purs/failing/MultipleTypeOpFixities.out new file mode 100644 index 0000000000..dde78d37cd --- /dev/null +++ b/tests/purs/failing/MultipleTypeOpFixities.out @@ -0,0 +1,10 @@ +Error found: +in module MultipleTypeOpFixities +at tests/purs/failing/MultipleTypeOpFixities.purs:9:1 - 9:22 (line 9, column 1 - line 9, column 22) + + There are multiple fixity/precedence declarations for type operator (!?) + + +See https://github.com/purescript/documentation/blob/master/errors/MultipleTypeOpFixities.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/MultipleValueOpFixities.out b/tests/purs/failing/MultipleValueOpFixities.out new file mode 100644 index 0000000000..6a6fbbb290 --- /dev/null +++ b/tests/purs/failing/MultipleValueOpFixities.out @@ -0,0 +1,10 @@ +Error found: +in module MultipleValueOpFixities +at tests/purs/failing/MultipleValueOpFixities.purs:9:1 - 9:18 (line 9, column 1 - line 9, column 18) + + There are multiple fixity/precedence declarations for operator (!?) + + +See https://github.com/purescript/documentation/blob/master/errors/MultipleValueOpFixities.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/MutRec.out b/tests/purs/failing/MutRec.out new file mode 100644 index 0000000000..3fbe1496c3 --- /dev/null +++ b/tests/purs/failing/MutRec.out @@ -0,0 +1,20 @@ +Error 1 of 2: + + at tests/purs/failing/MutRec.purs:7:1 - 7:6 (line 7, column 1 - line 7, column 6) + + The value of x is undefined here, so this reference is not allowed. + + + See https://github.com/purescript/documentation/blob/master/errors/CycleInDeclaration.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + at tests/purs/failing/MutRec.purs:9:1 - 9:6 (line 9, column 1 - line 9, column 6) + + The value of y is undefined here, so this reference is not allowed. + + + See https://github.com/purescript/documentation/blob/master/errors/CycleInDeclaration.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/failing/MutRec2.out b/tests/purs/failing/MutRec2.out new file mode 100644 index 0000000000..e76435f4df --- /dev/null +++ b/tests/purs/failing/MutRec2.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/MutRec2.purs:6:1 - 6:6 (line 6, column 1 - line 6, column 6) + + The value of x is undefined here, so this reference is not allowed. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/NewtypeInstance.out b/tests/purs/failing/NewtypeInstance.out new file mode 100644 index 0000000000..044059b267 --- /dev/null +++ b/tests/purs/failing/NewtypeInstance.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/NewtypeInstance.purs:8:1 - 8:40 (line 8, column 1 - line 8, column 40) + + Cannot derive newtype instance for +   +  Data.Show.Show X +   + Make sure this is a newtype. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidNewtypeInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/NewtypeInstance2.out b/tests/purs/failing/NewtypeInstance2.out new file mode 100644 index 0000000000..b0ef43daee --- /dev/null +++ b/tests/purs/failing/NewtypeInstance2.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/NewtypeInstance2.purs:8:1 - 8:54 (line 8, column 1 - line 8, column 54) + + Cannot derive newtype instance for +   +  Data.Show.Show (X a) +   + Make sure this is a newtype. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidNewtypeInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/NewtypeInstance3.out b/tests/purs/failing/NewtypeInstance3.out new file mode 100644 index 0000000000..d5ed7a8c4c --- /dev/null +++ b/tests/purs/failing/NewtypeInstance3.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/NewtypeInstance3.purs:8:1 - 8:43 (line 8, column 1 - line 8, column 43) + + Cannot derive newtype instance for +   +  Main.Nullary  +   + Make sure this is a newtype. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidNewtypeInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/NewtypeInstance4.out b/tests/purs/failing/NewtypeInstance4.out new file mode 100644 index 0000000000..cc3e7abc0c --- /dev/null +++ b/tests/purs/failing/NewtypeInstance4.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/NewtypeInstance4.purs:8:1 - 8:40 (line 8, column 1 - line 8, column 40) + + Cannot derive newtype instance for +   +  Data.Show.Show X +   + Make sure this is a newtype. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidNewtypeInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/NewtypeInstance5.out b/tests/purs/failing/NewtypeInstance5.out new file mode 100644 index 0000000000..911ea2b6bd --- /dev/null +++ b/tests/purs/failing/NewtypeInstance5.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/NewtypeInstance5.purs:8:1 - 8:46 (line 8, column 1 - line 8, column 46) + + Cannot derive newtype instance for +   +  Data.Functor.Functor X +   + Make sure this is a newtype. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidNewtypeInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/NewtypeInstance6.out b/tests/purs/failing/NewtypeInstance6.out new file mode 100644 index 0000000000..a3a0989b20 --- /dev/null +++ b/tests/purs/failing/NewtypeInstance6.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/NewtypeInstance6.purs:8:1 - 8:46 (line 8, column 1 - line 8, column 46) + + Cannot derive newtype instance for +   +  Data.Functor.Functor X +   + Make sure this is a newtype. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidNewtypeInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/NewtypeMultiArgs.out b/tests/purs/failing/NewtypeMultiArgs.out new file mode 100644 index 0000000000..c193cb6bc3 --- /dev/null +++ b/tests/purs/failing/NewtypeMultiArgs.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/NewtypeMultiArgs.purs:6:30 - 6:37 (line 6, column 30 - line 6, column 37) + + Unable to parse module: + Unexpected token 'Boolean' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/NewtypeMultiCtor.out b/tests/purs/failing/NewtypeMultiCtor.out new file mode 100644 index 0000000000..49419a338f --- /dev/null +++ b/tests/purs/failing/NewtypeMultiCtor.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/NewtypeMultiCtor.purs:6:30 - 6:31 (line 6, column 30 - line 6, column 31) + + Unable to parse module: + Unexpected token '|' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/NonAssociativeError.out b/tests/purs/failing/NonAssociativeError.out new file mode 100644 index 0000000000..7d7e56c1c6 --- /dev/null +++ b/tests/purs/failing/NonAssociativeError.out @@ -0,0 +1,26 @@ +Error 1 of 2: + + at tests/purs/failing/NonAssociativeError.purs:7:10 - 7:12 (line 7, column 10 - line 7, column 12) + + Cannot parse an expression that uses multiple instances of the non-associative operator Data.Eq.(==). + Use parentheses to resolve this ambiguity. + + + See https://github.com/purescript/documentation/blob/master/errors/NonAssociativeError.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + at tests/purs/failing/NonAssociativeError.purs:8:19 - 8:21 (line 8, column 19 - line 8, column 21) + + Cannot parse an expression that uses multiple non-associative operators of the same precedence: + + Data.Eq.(/=) + Data.Eq.(==) + + Use parentheses to resolve this ambiguity. + + + See https://github.com/purescript/documentation/blob/master/errors/NonAssociativeError.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/failing/NonExhaustivePatGuard.out b/tests/purs/failing/NonExhaustivePatGuard.out new file mode 100644 index 0000000000..51b24a58fd --- /dev/null +++ b/tests/purs/failing/NonExhaustivePatGuard.out @@ -0,0 +1,26 @@ +Error found: +in module Main +at tests/purs/failing/NonExhaustivePatGuard.purs:4:1 - 4:16 (line 4, column 1 - line 4, column 16) + + A case expression could not be determined to cover all inputs. + The following additional cases are required to cover all inputs: + + _ + + Alternatively, add a Partial constraint to the type of the enclosing value. + +while applying a function $__unused + of type Partial => t0 -> t0 + to argument case x of  +  x | 1 <- x -> x +while checking that expression $__unused (case x of  +  x | 1 <- x -> x +  )  + has type Int +in value declaration f + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/NullaryAbs.out b/tests/purs/failing/NullaryAbs.out new file mode 100644 index 0000000000..41bc8cbb89 --- /dev/null +++ b/tests/purs/failing/NullaryAbs.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/NullaryAbs.purs:6:10 - 6:12 (line 6, column 10 - line 6, column 12) + + Unable to parse module: + Unexpected token '->' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/Object.out b/tests/purs/failing/Object.out new file mode 100644 index 0000000000..1360fd08bc --- /dev/null +++ b/tests/purs/failing/Object.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/Object.purs:8:14 - 8:16 (line 8, column 14 - line 8, column 16) + + Type of expression lacks required label foo. + +while checking that expression {} + has type { foo :: t0 + | t1  + }  +while applying a function test + of type { foo :: t0 + | t1  + }  + -> t0  + to argument {} +in value declaration test1 + +where t1 is an unknown type + t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/PropertyIsMissing.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OperatorAliasNoExport.out b/tests/purs/failing/OperatorAliasNoExport.out new file mode 100644 index 0000000000..2607f55955 --- /dev/null +++ b/tests/purs/failing/OperatorAliasNoExport.out @@ -0,0 +1,13 @@ +Error found: +in module Test +at tests/purs/failing/OperatorAliasNoExport.purs:2:1 - 7:13 (line 2, column 1 - line 7, column 13) + + An export for (?!) requires the following to also be exported: + + what + + + +See https://github.com/purescript/documentation/blob/master/errors/TransitiveExportError.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OperatorAt.out b/tests/purs/failing/OperatorAt.out new file mode 100644 index 0000000000..4be88f6432 --- /dev/null +++ b/tests/purs/failing/OperatorAt.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/OperatorAt.purs:6:18 - 6:19 (line 6, column 18 - line 6, column 19) + + Unable to parse module: + Unexpected token '@' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OperatorBackslash.out b/tests/purs/failing/OperatorBackslash.out new file mode 100644 index 0000000000..5759b77042 --- /dev/null +++ b/tests/purs/failing/OperatorBackslash.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/OperatorBackslash.purs:6:18 - 6:19 (line 6, column 18 - line 6, column 19) + + Unable to parse module: + Unexpected token '\' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OperatorSections.out b/tests/purs/failing/OperatorSections.out new file mode 100644 index 0000000000..38b55b7111 --- /dev/null +++ b/tests/purs/failing/OperatorSections.out @@ -0,0 +1,27 @@ +Error found: +in module Main +at tests/purs/failing/OperatorSections.purs:7:3 - 7:17 (line 7, column 3 - line 7, column 17) + + Could not match type +   +  Boolean +   + with type +   +  t1 -> t2 +   + +while applying a function (not (#dict HeytingAlgebra t2)) true + of type t0 + to argument $0 +while inferring the type of \$0 ->  +  (not true) $0 +in value declaration main + +where t1 is an unknown type + t0 is an unknown type + t2 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OrphanInstance.out b/tests/purs/failing/OrphanInstance.out new file mode 100644 index 0000000000..356d84cb09 --- /dev/null +++ b/tests/purs/failing/OrphanInstance.out @@ -0,0 +1,18 @@ +Error found: +in module Test +at tests/purs/failing/OrphanInstance.purs:6:1 - 7:11 (line 6, column 1 - line 7, column 11) + + Orphan instance cBoolean found for +   +  Class.C Boolean +   + This problem can be resolved by declaring the instance in Class, or by defining the instance on a newtype wrapper. + +in type class instance +  + Class.C Boolean +  + +See https://github.com/purescript/documentation/blob/master/errors/OrphanInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OrphanInstance/Class.out b/tests/purs/failing/OrphanInstance/Class.out new file mode 100644 index 0000000000..356d84cb09 --- /dev/null +++ b/tests/purs/failing/OrphanInstance/Class.out @@ -0,0 +1,18 @@ +Error found: +in module Test +at tests/purs/failing/OrphanInstance.purs:6:1 - 7:11 (line 6, column 1 - line 7, column 11) + + Orphan instance cBoolean found for +   +  Class.C Boolean +   + This problem can be resolved by declaring the instance in Class, or by defining the instance on a newtype wrapper. + +in type class instance +  + Class.C Boolean +  + +See https://github.com/purescript/documentation/blob/master/errors/OrphanInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OrphanInstanceFunDepCycle.out b/tests/purs/failing/OrphanInstanceFunDepCycle.out new file mode 100644 index 0000000000..617efc66f6 --- /dev/null +++ b/tests/purs/failing/OrphanInstanceFunDepCycle.out @@ -0,0 +1,20 @@ +Error found: +in module Main +at tests/purs/failing/OrphanInstanceFunDepCycle.purs:5:1 - 5:22 (line 5, column 1 - line 5, column 22) + + Orphan instance clr found for +   +  Lib.C L +  R +   + This problem can be resolved by declaring the instance in Lib, or by defining the instance on a newtype wrapper. + +in type class instance +  + Lib.C L + R +  + +See https://github.com/purescript/documentation/blob/master/errors/OrphanInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OrphanInstanceFunDepCycle/Lib.out b/tests/purs/failing/OrphanInstanceFunDepCycle/Lib.out new file mode 100644 index 0000000000..617efc66f6 --- /dev/null +++ b/tests/purs/failing/OrphanInstanceFunDepCycle/Lib.out @@ -0,0 +1,20 @@ +Error found: +in module Main +at tests/purs/failing/OrphanInstanceFunDepCycle.purs:5:1 - 5:22 (line 5, column 1 - line 5, column 22) + + Orphan instance clr found for +   +  Lib.C L +  R +   + This problem can be resolved by declaring the instance in Lib, or by defining the instance on a newtype wrapper. + +in type class instance +  + Lib.C L + R +  + +See https://github.com/purescript/documentation/blob/master/errors/OrphanInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OrphanInstanceNullary.out b/tests/purs/failing/OrphanInstanceNullary.out new file mode 100644 index 0000000000..abc12fbc63 --- /dev/null +++ b/tests/purs/failing/OrphanInstanceNullary.out @@ -0,0 +1,18 @@ +Error found: +in module Test +at tests/purs/failing/OrphanInstanceNullary.purs:4:1 - 4:16 (line 4, column 1 - line 4, column 16) + + Orphan instance c found for +   +  Lib.C  +   + This problem can be resolved by declaring the instance in Lib, or by defining the instance on a newtype wrapper. + +in type class instance +  + Lib.C  +  + +See https://github.com/purescript/documentation/blob/master/errors/OrphanInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OrphanInstanceNullary/Lib.out b/tests/purs/failing/OrphanInstanceNullary/Lib.out new file mode 100644 index 0000000000..abc12fbc63 --- /dev/null +++ b/tests/purs/failing/OrphanInstanceNullary/Lib.out @@ -0,0 +1,18 @@ +Error found: +in module Test +at tests/purs/failing/OrphanInstanceNullary.purs:4:1 - 4:16 (line 4, column 1 - line 4, column 16) + + Orphan instance c found for +   +  Lib.C  +   + This problem can be resolved by declaring the instance in Lib, or by defining the instance on a newtype wrapper. + +in type class instance +  + Lib.C  +  + +See https://github.com/purescript/documentation/blob/master/errors/OrphanInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OrphanInstanceWithDetermined.out b/tests/purs/failing/OrphanInstanceWithDetermined.out new file mode 100644 index 0000000000..c5bbe45254 --- /dev/null +++ b/tests/purs/failing/OrphanInstanceWithDetermined.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/OrphanInstanceWithDetermined.purs:5:1 - 5:25 (line 5, column 1 - line 5, column 25) + + Orphan instance cflr found for +   +  Lib.C F +  L +  R +   + This problem can be resolved by declaring the instance in Lib, or by defining the instance on a newtype wrapper. + +in type class instance +  + Lib.C F + L + R +  + +See https://github.com/purescript/documentation/blob/master/errors/OrphanInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OrphanInstanceWithDetermined/Lib.out b/tests/purs/failing/OrphanInstanceWithDetermined/Lib.out new file mode 100644 index 0000000000..c5bbe45254 --- /dev/null +++ b/tests/purs/failing/OrphanInstanceWithDetermined/Lib.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/OrphanInstanceWithDetermined.purs:5:1 - 5:25 (line 5, column 1 - line 5, column 25) + + Orphan instance cflr found for +   +  Lib.C F +  L +  R +   + This problem can be resolved by declaring the instance in Lib, or by defining the instance on a newtype wrapper. + +in type class instance +  + Lib.C F + L + R +  + +See https://github.com/purescript/documentation/blob/master/errors/OrphanInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OrphanTypeDecl.out b/tests/purs/failing/OrphanTypeDecl.out new file mode 100644 index 0000000000..8ecc69800b --- /dev/null +++ b/tests/purs/failing/OrphanTypeDecl.out @@ -0,0 +1,10 @@ +Error found: +in module OrphanTypeDecl +at tests/purs/failing/OrphanTypeDecl.purs:4:1 - 4:24 (line 4, column 1 - line 4, column 24) + + The type declaration for fn should be followed by its definition. + + +See https://github.com/purescript/documentation/blob/master/errors/OrphanTypeDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OverlapAcrossModules.out b/tests/purs/failing/OverlapAcrossModules.out new file mode 100644 index 0000000000..ae7c7037f3 --- /dev/null +++ b/tests/purs/failing/OverlapAcrossModules.out @@ -0,0 +1,24 @@ +Error found: +in module OverlapAcrossModules +at tests/purs/failing/OverlapAcrossModules.purs:6:1 - 6:22 (line 6, column 1 - line 6, column 22) + + Overlapping type class instances found for +   +  OverlapAcrossModules.Class.C X +  Y +   + The following instances were found: + + OverlapAcrossModules.X.cxy + OverlapAcrossModules.cxy + + +in type class instance +  + OverlapAcrossModules.Class.C X + Y +  + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingInstances.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OverlapAcrossModules/Class.out b/tests/purs/failing/OverlapAcrossModules/Class.out new file mode 100644 index 0000000000..ae7c7037f3 --- /dev/null +++ b/tests/purs/failing/OverlapAcrossModules/Class.out @@ -0,0 +1,24 @@ +Error found: +in module OverlapAcrossModules +at tests/purs/failing/OverlapAcrossModules.purs:6:1 - 6:22 (line 6, column 1 - line 6, column 22) + + Overlapping type class instances found for +   +  OverlapAcrossModules.Class.C X +  Y +   + The following instances were found: + + OverlapAcrossModules.X.cxy + OverlapAcrossModules.cxy + + +in type class instance +  + OverlapAcrossModules.Class.C X + Y +  + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingInstances.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OverlappingArguments.out b/tests/purs/failing/OverlappingArguments.out new file mode 100644 index 0000000000..cbb05dd064 --- /dev/null +++ b/tests/purs/failing/OverlappingArguments.out @@ -0,0 +1,10 @@ +Error found: +in module OverlappingArguments +at tests/purs/failing/OverlappingArguments.purs:6:1 - 6:10 (line 6, column 1 - line 6, column 10) + + Overlapping names in function/binder in declaration f + + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingArgNames.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OverlappingBinders.out b/tests/purs/failing/OverlappingBinders.out new file mode 100644 index 0000000000..bc02334154 --- /dev/null +++ b/tests/purs/failing/OverlappingBinders.out @@ -0,0 +1,14 @@ +Error found: +in module OverlappingBinders +at tests/purs/failing/OverlappingBinders.purs:8:7 - 9:28 (line 8, column 7 - line 9, column 28) + + Overlapping names in function/binder + +while inferring the type of \x ->  +  case x of  +  (S y (S y@S z zs)) -> y +in value declaration f + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingArgNames.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OverlappingInstances.out b/tests/purs/failing/OverlappingInstances.out new file mode 100644 index 0000000000..19b0cfc556 --- /dev/null +++ b/tests/purs/failing/OverlappingInstances.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/OverlappingInstances.purs:10:1 - 11:13 (line 10, column 1 - line 11, column 13) + + Overlapping type class instances found for +   +  Main.Test Int +   + The following instances were found: + + Main.testRefl + Main.testInt + + +in type class instance +  + Main.Test Int +  + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingInstances.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OverlappingVars.out b/tests/purs/failing/OverlappingVars.out new file mode 100644 index 0000000000..8f49802299 --- /dev/null +++ b/tests/purs/failing/OverlappingVars.out @@ -0,0 +1,20 @@ +Error found: +in module Main +at tests/purs/failing/OverlappingVars.purs:14:8 - 14:20 (line 14, column 8 - line 14, column 20) + + No type class instance was found for +   +  Main.OverlappingVars (Foo String Int) +   + +while applying a function f + of type OverlappingVars t0 => t0 -> t0 + to argument (Foo "") 0 +while inferring the type of f ((Foo "") 0) +in value declaration test + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PrimModuleReserved.out b/tests/purs/failing/PrimModuleReserved.out new file mode 100644 index 0000000000..67794c66d5 --- /dev/null +++ b/tests/purs/failing/PrimModuleReserved.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/PrimModuleReserved/Prim.purs:1:1 - 1:18 (line 1, column 1 - line 1, column 18) + + The module name Prim is in the Prim namespace. + The Prim namespace is reserved for compiler-defined terms. + + +See https://github.com/purescript/documentation/blob/master/errors/CannotDefinePrimModules.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PrimRow.out b/tests/purs/failing/PrimRow.out new file mode 100644 index 0000000000..dab89b6ec1 --- /dev/null +++ b/tests/purs/failing/PrimRow.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/PrimRow.purs:8:6 - 8:42 (line 8, column 6 - line 8, column 42) + + Unknown type class Cons + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PrimSubModuleReserved.out b/tests/purs/failing/PrimSubModuleReserved.out new file mode 100644 index 0000000000..75c385feea --- /dev/null +++ b/tests/purs/failing/PrimSubModuleReserved.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/PrimSubModuleReserved/Prim_Foobar.purs:1:1 - 1:25 (line 1, column 1 - line 1, column 25) + + The module name Prim.Foobar is in the Prim namespace. + The Prim namespace is reserved for compiler-defined terms. + + +See https://github.com/purescript/documentation/blob/master/errors/CannotDefinePrimModules.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PrimSubModuleReserved/Prim_Foobar.out b/tests/purs/failing/PrimSubModuleReserved/Prim_Foobar.out new file mode 100644 index 0000000000..75c385feea --- /dev/null +++ b/tests/purs/failing/PrimSubModuleReserved/Prim_Foobar.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/PrimSubModuleReserved/Prim_Foobar.purs:1:1 - 1:25 (line 1, column 1 - line 1, column 25) + + The module name Prim.Foobar is in the Prim namespace. + The Prim namespace is reserved for compiler-defined terms. + + +See https://github.com/purescript/documentation/blob/master/errors/CannotDefinePrimModules.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ProgrammableTypeErrors.out b/tests/purs/failing/ProgrammableTypeErrors.out new file mode 100644 index 0000000000..094744f26b --- /dev/null +++ b/tests/purs/failing/ProgrammableTypeErrors.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/ProgrammableTypeErrors.purs:17:13 - 17:27 (line 17, column 13 - line 17, column 27) + + A custom type error occurred while solving type class constraints: + + Cannot show functions + + +while applying a function myShow + of type MyShow t0 => t0 -> String + to argument \$0 ->  +  (add $0) 1 +while checking that expression myShow (\$0 ->  +  (add $0) 1 +  )  + has type String +in value declaration main + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ProgrammableTypeErrorsTypeString.out b/tests/purs/failing/ProgrammableTypeErrorsTypeString.out new file mode 100644 index 0000000000..16df92cca2 --- /dev/null +++ b/tests/purs/failing/ProgrammableTypeErrorsTypeString.out @@ -0,0 +1,21 @@ +Error found: +in module Main +at tests/purs/failing/ProgrammableTypeErrorsTypeString.purs:24:9 - 24:24 (line 24, column 9 - line 24, column 24) + + A custom type error occurred while solving type class constraints: + + Don't want to show MyType Int because. + + +while applying a function show + of type Show t0 => t0 -> String + to argument MyType 2 +while checking that expression show (MyType 2) + has type String +in value declaration main + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/Rank2Types.out b/tests/purs/failing/Rank2Types.out new file mode 100644 index 0000000000..07ee13d5af --- /dev/null +++ b/tests/purs/failing/Rank2Types.out @@ -0,0 +1,25 @@ +Error found: +in module Main +at tests/purs/failing/Rank2Types.purs:8:25 - 8:26 (line 8, column 25 - line 8, column 26) + + Could not match type +   +  Int +   + with type +   +  a0 +   + +while checking that type Int + is at least as general as type a0 +while checking that expression 1 + has type a0 +in value declaration test1 + +where a0 is a rigid type variable + bound at (line 8, column 14 - line 8, column 27) + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RequiredHiddenType.out b/tests/purs/failing/RequiredHiddenType.out new file mode 100644 index 0000000000..aa8d284345 --- /dev/null +++ b/tests/purs/failing/RequiredHiddenType.out @@ -0,0 +1,13 @@ +Error found: +in module Foo +at tests/purs/failing/RequiredHiddenType.purs:3:1 - 9:6 (line 3, column 1 - line 9, column 6) + + An export for a requires the following to also be exported: + + A + + + +See https://github.com/purescript/documentation/blob/master/errors/TransitiveExportError.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/Reserved.out b/tests/purs/failing/Reserved.out new file mode 100644 index 0000000000..36fa33d773 --- /dev/null +++ b/tests/purs/failing/Reserved.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/Reserved.purs:6:1 - 6:4 (line 6, column 1 - line 6, column 4) + + Unable to parse module: + Unexpected token '(<)' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RowConstructors1.out b/tests/purs/failing/RowConstructors1.out new file mode 100644 index 0000000000..92124fcd1b --- /dev/null +++ b/tests/purs/failing/RowConstructors1.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/RowConstructors1.purs:7:16 - 7:19 (line 7, column 16 - line 7, column 19) + + Could not match kind + + # Type + + with kind + + Type + + +while checking the kind of Record Foo +in type synonym Baz + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RowConstructors2.out b/tests/purs/failing/RowConstructors2.out new file mode 100644 index 0000000000..813c598204 --- /dev/null +++ b/tests/purs/failing/RowConstructors2.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/RowConstructors2.purs:7:16 - 7:19 (line 7, column 16 - line 7, column 19) + + Could not match kind + + # Type + + with kind + + # Type -> # Type + + +while checking the kind of Record Foo +in type synonym Bar + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RowConstructors3.out b/tests/purs/failing/RowConstructors3.out new file mode 100644 index 0000000000..082738bc86 --- /dev/null +++ b/tests/purs/failing/RowConstructors3.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/RowConstructors3.purs:7:16 - 7:19 (line 7, column 16 - line 7, column 19) + + Could not match kind + + # Type + + with kind + + Type + + +while checking the kind of Record Foo +in type synonym Bar + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RowInInstanceNotDetermined0.out b/tests/purs/failing/RowInInstanceNotDetermined0.out new file mode 100644 index 0000000000..9a99061579 --- /dev/null +++ b/tests/purs/failing/RowInInstanceNotDetermined0.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/RowInInstanceNotDetermined0.purs:8:1 - 8:24 (line 8, column 1 - line 8, column 24) + + Type class instance head is invalid due to use of type +   +  () +   + All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form, unless the type is fully determined by other type class arguments via functional dependencies. + +in type class instance +  + Main.C Unit  + (Record ()) +  + +See https://github.com/purescript/documentation/blob/master/errors/InvalidInstanceHead.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RowInInstanceNotDetermined1.out b/tests/purs/failing/RowInInstanceNotDetermined1.out new file mode 100644 index 0000000000..96d6ae3512 --- /dev/null +++ b/tests/purs/failing/RowInInstanceNotDetermined1.out @@ -0,0 +1,20 @@ +Error found: +in module Main +at tests/purs/failing/RowInInstanceNotDetermined1.purs:8:1 - 8:29 (line 8, column 1 - line 8, column 29) + + Type class instance head is invalid due to use of type +   +  () +   + All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form, unless the type is fully determined by other type class arguments via functional dependencies. + +in type class instance +  + Main.C Unit  + Unit  + (Record ()) +  + +See https://github.com/purescript/documentation/blob/master/errors/InvalidInstanceHead.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RowInInstanceNotDetermined2.out b/tests/purs/failing/RowInInstanceNotDetermined2.out new file mode 100644 index 0000000000..bd54f1bb10 --- /dev/null +++ b/tests/purs/failing/RowInInstanceNotDetermined2.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/RowInInstanceNotDetermined2.purs:8:1 - 8:24 (line 8, column 1 - line 8, column 24) + + Type class instance head is invalid due to use of type +   +  () +   + All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form, unless the type is fully determined by other type class arguments via functional dependencies. + +in type class instance +  + Main.C Unit  + (Record ()) +  + +See https://github.com/purescript/documentation/blob/master/errors/InvalidInstanceHead.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RowLacks.out b/tests/purs/failing/RowLacks.out new file mode 100644 index 0000000000..4532d97542 --- /dev/null +++ b/tests/purs/failing/RowLacks.out @@ -0,0 +1,25 @@ +Error found: +in module Main +at tests/purs/failing/RowLacks.purs:16:9 - 16:68 (line 16, column 9 - line 16, column 68) + + No type class instance was found for +   +  Prim.Row.Lacks "x"  +  ( x :: Int  +  , y :: Int  +  , z :: String +  )  +   + +while applying a function lacksX + of type Lacks "x" t0 => RProxy t0 -> RProxy () + to argument RProxy +while checking that expression lacksX RProxy + has type RProxy () +in value declaration test1 + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/SelfImport.out b/tests/purs/failing/SelfImport.out new file mode 100644 index 0000000000..333f985641 --- /dev/null +++ b/tests/purs/failing/SelfImport.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/SelfImport.purs:3:1 - 9:12 (line 3, column 1 - line 9, column 12) + + Module Main imports itself. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInModules.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/SelfImport/Dummy.out b/tests/purs/failing/SelfImport/Dummy.out new file mode 100644 index 0000000000..333f985641 --- /dev/null +++ b/tests/purs/failing/SelfImport/Dummy.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/SelfImport.purs:3:1 - 9:12 (line 3, column 1 - line 9, column 12) + + Module Main imports itself. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInModules.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/SkolemEscape.out b/tests/purs/failing/SkolemEscape.out new file mode 100644 index 0000000000..8217eff0aa --- /dev/null +++ b/tests/purs/failing/SkolemEscape.out @@ -0,0 +1,20 @@ +Error found: +in module Main +at tests/purs/failing/SkolemEscape.purs:8:1 - 8:19 (line 8, column 1 - line 8, column 19) + + The type variable a, bound at + + tests/purs/failing/SkolemEscape.purs:8:18 - 8:19 (line 8, column 18 - line 8, column 19) + + has escaped its scope, appearing in the type +   +  (a0 -> a0) -> Number +   + +in the expression \x ->  +  foo x +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/EscapedSkolem.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/SkolemEscape2.out b/tests/purs/failing/SkolemEscape2.out new file mode 100644 index 0000000000..98f7d3ad24 --- /dev/null +++ b/tests/purs/failing/SkolemEscape2.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/SkolemEscape2.purs:9:1 - 11:9 (line 9, column 1 - line 11, column 9) + + The type variable r, bound at + + tests/purs/failing/SkolemEscape2.purs:10:21 - 10:34 (line 10, column 21 - line 10, column 34) + + has escaped its scope, appearing in the type +   +  t1 -> t2 (STRef r0 Int) +   + +in the expression \$0 ->  +  ((bind $dictBind1) ((...) (...))) (\r ->  +  (...) r +  )  +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/EscapedSkolem.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/SuggestComposition.out b/tests/purs/failing/SuggestComposition.out new file mode 100644 index 0000000000..a588608250 --- /dev/null +++ b/tests/purs/failing/SuggestComposition.out @@ -0,0 +1,32 @@ +Error found: +in module SuggestComposition +at tests/purs/failing/SuggestComposition.purs:7:5 - 7:6 (line 7, column 5 - line 7, column 6) + + Could not match type +   +  Record +   + with type +   +  Function Int +   + +while trying to match type { g :: t0 + | t1  + }  + with type t2 -> t3 +while checking that expression g + has type { g :: t0 + | t1  + }  +while checking type of property accessor g.g +in value declaration f + +where t2 is an unknown type + t3 is an unknown type + t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/Superclasses1.out b/tests/purs/failing/Superclasses1.out new file mode 100644 index 0000000000..3d43a5ec77 --- /dev/null +++ b/tests/purs/failing/Superclasses1.out @@ -0,0 +1,17 @@ +Error found: +in module Main +at tests/purs/failing/Superclasses1.purs:12:1 - 13:17 (line 12, column 1 - line 13, column 17) + + No type class instance was found for +   +  Main.Su Number +   + +while checking that expression #dict Su + has type { su :: Number -> Number + }  +in value declaration clNumber + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/Superclasses2.out b/tests/purs/failing/Superclasses2.out new file mode 100644 index 0000000000..e5b35b5221 --- /dev/null +++ b/tests/purs/failing/Superclasses2.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/Superclasses2.purs:6:1 - 6:23 (line 6, column 1 - line 6, column 23) + + A cycle appears in a set of type class definitions: + + {Bar, Foo} + + Cycles are disallowed because they can lead to loops in the type checker. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInTypeClassDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/Superclasses3.out b/tests/purs/failing/Superclasses3.out new file mode 100644 index 0000000000..d7146780cd --- /dev/null +++ b/tests/purs/failing/Superclasses3.out @@ -0,0 +1,13 @@ +Error found: +in module UnknownSuperclassTypeVar +at tests/purs/failing/Superclasses3.purs:8:1 - 8:23 (line 8, column 1 - line 8, column 23) + + Type variable b is undefined. + +while checking the kind of { "Foo0" :: Record () -> Foo b + }  +in type synonym Bar + +See https://github.com/purescript/documentation/blob/master/errors/UndefinedTypeVariable.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/Superclasses5.out b/tests/purs/failing/Superclasses5.out new file mode 100644 index 0000000000..b05d814439 --- /dev/null +++ b/tests/purs/failing/Superclasses5.out @@ -0,0 +1,30 @@ +Error found: +in module Main +at tests/purs/failing/Superclasses5.purs:17:1 - 18:18 (line 17, column 1 - line 18, column 18) + + A case expression could not be determined to cover all inputs. + The following additional cases are required to cover all inputs: + + _ + + Alternatively, add a Partial constraint to the type of the enclosing value. + +while applying a function $__unused + of type Partial => t1 -> t1 + to argument case $0 of  +  [ x ] -> [ su x +  ]  +while checking that expression $__unused (case $0 of  +  [ x ] -> [ ... +  ]  +  )  + has type Array a0 +in value declaration suArray + +where a0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TooFewClassInstanceArgs.out b/tests/purs/failing/TooFewClassInstanceArgs.out new file mode 100644 index 0000000000..459c13ccaa --- /dev/null +++ b/tests/purs/failing/TooFewClassInstanceArgs.out @@ -0,0 +1,15 @@ +Error found: +in module Main +at tests/purs/failing/TooFewClassInstanceArgs.purs:8:1 - 8:33 (line 8, column 1 - line 8, column 33) + + The type class Main.Foo expects 2 arguments. + But the instance fooString only provided 1. + +in type class instance +  + Main.Foo String +  + +See https://github.com/purescript/documentation/blob/master/errors/ClassInstanceArityMismatch.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TopLevelCaseNoArgs.out b/tests/purs/failing/TopLevelCaseNoArgs.out new file mode 100644 index 0000000000..d4d17e9b8f --- /dev/null +++ b/tests/purs/failing/TopLevelCaseNoArgs.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/TopLevelCaseNoArgs.purs:7:1 - 7:8 (line 7, column 1 - line 7, column 8) + + Multiple value declarations exist for foo. + + +See https://github.com/purescript/documentation/blob/master/errors/DuplicateValueDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TransitiveDctorExport.out b/tests/purs/failing/TransitiveDctorExport.out new file mode 100644 index 0000000000..5fb3502987 --- /dev/null +++ b/tests/purs/failing/TransitiveDctorExport.out @@ -0,0 +1,13 @@ +Error found: +in module Main +at tests/purs/failing/TransitiveDctorExport.purs:2:1 - 5:13 (line 2, column 1 - line 5, column 13) + + An export for Y requires the following to also be exported: + + X + + + +See https://github.com/purescript/documentation/blob/master/errors/TransitiveExportError.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TransitiveKindExport.out b/tests/purs/failing/TransitiveKindExport.out new file mode 100644 index 0000000000..c22d035610 --- /dev/null +++ b/tests/purs/failing/TransitiveKindExport.out @@ -0,0 +1,13 @@ +Error found: +in module Main +at tests/purs/failing/TransitiveKindExport.purs:2:1 - 6:39 (line 2, column 1 - line 6, column 39) + + An export for TestProxy requires the following to also be exported: + + kind Test + + + +See https://github.com/purescript/documentation/blob/master/errors/TransitiveExportError.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TransitiveSynonymExport.out b/tests/purs/failing/TransitiveSynonymExport.out new file mode 100644 index 0000000000..4275828e31 --- /dev/null +++ b/tests/purs/failing/TransitiveSynonymExport.out @@ -0,0 +1,13 @@ +Error found: +in module Main +at tests/purs/failing/TransitiveSynonymExport.purs:2:1 - 5:11 (line 2, column 1 - line 5, column 11) + + An export for Y requires the following to also be exported: + + X + + + +See https://github.com/purescript/documentation/blob/master/errors/TransitiveExportError.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeClasses2.out b/tests/purs/failing/TypeClasses2.out new file mode 100644 index 0000000000..799aff9e9d --- /dev/null +++ b/tests/purs/failing/TypeClasses2.out @@ -0,0 +1,20 @@ +Error found: +in module Main +at tests/purs/failing/TypeClasses2.purs:7:8 - 7:22 (line 7, column 8 - line 7, column 22) + + No type class instance was found for +   +  Main.Show String +   + +while applying a function show + of type Show t0 => t0 -> String + to argument "testing" +while inferring the type of show "testing" +in value declaration test + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeError.out b/tests/purs/failing/TypeError.out new file mode 100644 index 0000000000..0cc707d1bd --- /dev/null +++ b/tests/purs/failing/TypeError.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/TypeError.purs:6:13 - 6:16 (line 6, column 13 - line 6, column 16) + + Could not match type +   +  String +   + with type +   +  Int +   + +while checking that type String + is at least as general as type Int +while checking that expression "A" + has type Int +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeOperatorAliasNoExport.out b/tests/purs/failing/TypeOperatorAliasNoExport.out new file mode 100644 index 0000000000..b339e348fb --- /dev/null +++ b/tests/purs/failing/TypeOperatorAliasNoExport.out @@ -0,0 +1,13 @@ +Error found: +in module Test +at tests/purs/failing/TypeOperatorAliasNoExport.purs:2:1 - 6:25 (line 2, column 1 - line 6, column 25) + + An export for type (×) requires the following to also be exported: + + Tuple + + + +See https://github.com/purescript/documentation/blob/master/errors/TransitiveExportError.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeSynonyms.out b/tests/purs/failing/TypeSynonyms.out new file mode 100644 index 0000000000..c135379f7b --- /dev/null +++ b/tests/purs/failing/TypeSynonyms.out @@ -0,0 +1,11 @@ +Error found: +at tests/purs/failing/TypeSynonyms.purs:6:1 - 6:19 (line 6, column 1 - line 6, column 19) + + A cycle appears in a set of type synonym definitions. + Cycles are disallowed because they can lead to loops in the type checker. + Consider using a 'newtype' instead. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInTypeSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeSynonyms2.out b/tests/purs/failing/TypeSynonyms2.out new file mode 100644 index 0000000000..9526a9425d --- /dev/null +++ b/tests/purs/failing/TypeSynonyms2.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/TypeSynonyms2.purs:11:1 - 12:12 (line 11, column 1 - line 12, column 12) + + Type class instances for type synonyms are disallowed. + +in type class instance +  + Main.Foo Bar +  + +See https://github.com/purescript/documentation/blob/master/errors/TypeSynonymInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeSynonyms3.out b/tests/purs/failing/TypeSynonyms3.out new file mode 100644 index 0000000000..32851ec208 --- /dev/null +++ b/tests/purs/failing/TypeSynonyms3.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/TypeSynonyms3.purs:11:1 - 12:12 (line 11, column 1 - line 12, column 12) + + Type class instances for type synonyms are disallowed. + +in type class instance +  + Main.Foo Bar +  + +See https://github.com/purescript/documentation/blob/master/errors/TypeSynonymInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeSynonyms4.out b/tests/purs/failing/TypeSynonyms4.out new file mode 100644 index 0000000000..20fabba5ef --- /dev/null +++ b/tests/purs/failing/TypeSynonyms4.out @@ -0,0 +1,12 @@ +Error found: +in module TypeSynonyms4 +at tests/purs/failing/TypeSynonyms4.purs:8:1 - 8:15 (line 8, column 1 - line 8, column 15) + + Type synonym TypeSynonyms4.F is partially applied. + Type synonyms must be applied to all of their type arguments. + +in type synonym G + +See https://github.com/purescript/documentation/blob/master/errors/PartiallyAppliedSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeSynonyms5.out b/tests/purs/failing/TypeSynonyms5.out new file mode 100644 index 0000000000..4c8b93fcfc --- /dev/null +++ b/tests/purs/failing/TypeSynonyms5.out @@ -0,0 +1,11 @@ +Error found: +at tests/purs/failing/TypeSynonyms5.purs:6:1 - 6:11 (line 6, column 1 - line 6, column 11) + + A cycle appears in the definition of type synonym T + Cycles are disallowed because they can lead to loops in the type checker. + Consider using a 'newtype' instead. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInTypeSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeWildcards1.out b/tests/purs/failing/TypeWildcards1.out new file mode 100644 index 0000000000..89282731f6 --- /dev/null +++ b/tests/purs/failing/TypeWildcards1.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/TypeWildcards1.purs:6:13 - 6:14 (line 6, column 13 - line 6, column 14) + + Unable to parse module: + Unexpected wildcard in type; type wildcards are only allowed in value annotations + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeWildcards2.out b/tests/purs/failing/TypeWildcards2.out new file mode 100644 index 0000000000..2c97acab5a --- /dev/null +++ b/tests/purs/failing/TypeWildcards2.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/TypeWildcards2.purs:6:18 - 6:19 (line 6, column 18 - line 6, column 19) + + Unable to parse module: + Unexpected wildcard in type; type wildcards are only allowed in value annotations + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeWildcards3.out b/tests/purs/failing/TypeWildcards3.out new file mode 100644 index 0000000000..989e062934 --- /dev/null +++ b/tests/purs/failing/TypeWildcards3.out @@ -0,0 +1,18 @@ +Error found: +in module TypeWildcards +at tests/purs/failing/TypeWildcards3.purs:8:1 - 9:19 (line 8, column 1 - line 9, column 19) + + Type class instance head is invalid due to use of type +   +  _ +   + All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form, unless the type is fully determined by other type class arguments via functional dependencies. + +in type class instance +  + Data.Show.Show (Foo _) +  + +See https://github.com/purescript/documentation/blob/master/errors/InvalidInstanceHead.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypedBinders.out b/tests/purs/failing/TypedBinders.out new file mode 100644 index 0000000000..e8832ec5e7 --- /dev/null +++ b/tests/purs/failing/TypedBinders.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/TypedBinders.purs:6:12 - 6:14 (line 6, column 12 - line 6, column 14) + + Unable to parse module: + Unexpected token '::' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypedBinders2.out b/tests/purs/failing/TypedBinders2.out new file mode 100644 index 0000000000..8a94de7e6e --- /dev/null +++ b/tests/purs/failing/TypedBinders2.out @@ -0,0 +1,30 @@ +Error found: +in module Main +at tests/purs/failing/TypedBinders2.purs:8:3 - 8:14 (line 8, column 3 - line 8, column 14) + + Could not match type +   +  Unit +   + with type +   +  String +   + +while checking that expression case $0 of  +  s -> log "Done" + has type Effect t2 +while applying a function (bind (#dict Bind t1)) (log "Foo") + of type (t0 -> t1 t2) -> t1 t2 + to argument \$0 ->  +  case $0 of  +  s -> log "Done" +in value declaration main + +where t1 is an unknown type + t2 is an unknown type + t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypedBinders3.out b/tests/purs/failing/TypedBinders3.out new file mode 100644 index 0000000000..0d061f3555 --- /dev/null +++ b/tests/purs/failing/TypedBinders3.out @@ -0,0 +1,21 @@ +Error found: +in module Main +at tests/purs/failing/TypedBinders3.purs:8:4 - 8:15 (line 8, column 4 - line 8, column 15) + + Could not match type +   +  Int +   + with type +   +  String +   + +while inferring the type of case 1 of  +  0 -> true  +  _ -> false +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypedHole.out b/tests/purs/failing/TypedHole.out new file mode 100644 index 0000000000..8f0dbc26d7 --- /dev/null +++ b/tests/purs/failing/TypedHole.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/TypedHole.purs:8:8 - 8:13 (line 8, column 8 - line 8, column 13) + + Hole 'ummm' has the inferred type +   +  Effect Unit +   + You could substitute the hole with one of these values: +   +  Data.Monoid.mempty :: forall m. Monoid m => m +  Main.main :: Effect Unit  +   + +in value declaration main + +See https://github.com/purescript/documentation/blob/master/errors/HoleInferredType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypedHole2.out b/tests/purs/failing/TypedHole2.out new file mode 100644 index 0000000000..e8ef3673df --- /dev/null +++ b/tests/purs/failing/TypedHole2.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/TypedHole2.purs:7:16 - 7:21 (line 7, column 16 - line 7, column 21) + + Hole 'ummm' has the inferred type +   +  Unit +   + +in value declaration main + +See https://github.com/purescript/documentation/blob/master/errors/HoleInferredType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnderscoreModuleName.out b/tests/purs/failing/UnderscoreModuleName.out new file mode 100644 index 0000000000..47ccfd2f0c --- /dev/null +++ b/tests/purs/failing/UnderscoreModuleName.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/UnderscoreModuleName.purs:2:8 - 2:18 (line 2, column 8 - line 2, column 18) + + Unable to parse module: + Invalid module name; underscores and primes are not allowed in module names + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnknownType.out b/tests/purs/failing/UnknownType.out new file mode 100644 index 0000000000..2393965238 --- /dev/null +++ b/tests/purs/failing/UnknownType.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/UnknownType.purs:6:19 - 6:28 (line 6, column 19 - line 6, column 28) + + Unknown type Something + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnusableTypeClassMethod.out b/tests/purs/failing/UnusableTypeClassMethod.out new file mode 100644 index 0000000000..62924705dd --- /dev/null +++ b/tests/purs/failing/UnusableTypeClassMethod.out @@ -0,0 +1,12 @@ +Error found: +in module Main +at tests/purs/failing/UnusableTypeClassMethod.purs:4:1 - 6:9 (line 4, column 1 - line 6, column 9) + + The declaration c contains arguments that couldn't be determined. + These arguments are: { a } + +in type class declaration for C + +See https://github.com/purescript/documentation/blob/master/errors/UnusableDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnusableTypeClassMethodConflictingIdent.out b/tests/purs/failing/UnusableTypeClassMethodConflictingIdent.out new file mode 100644 index 0000000000..f7acded5fc --- /dev/null +++ b/tests/purs/failing/UnusableTypeClassMethodConflictingIdent.out @@ -0,0 +1,12 @@ +Error found: +in module Main +at tests/purs/failing/UnusableTypeClassMethodConflictingIdent.purs:4:1 - 6:19 (line 4, column 1 - line 6, column 19) + + The declaration c contains arguments that couldn't be determined. + These arguments are: { a } + +in type class declaration for C + +See https://github.com/purescript/documentation/blob/master/errors/UnusableDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnusableTypeClassMethodSynonym.out b/tests/purs/failing/UnusableTypeClassMethodSynonym.out new file mode 100644 index 0000000000..6adb687c04 --- /dev/null +++ b/tests/purs/failing/UnusableTypeClassMethodSynonym.out @@ -0,0 +1,12 @@ +Error found: +in module Main +at tests/purs/failing/UnusableTypeClassMethodSynonym.purs:6:1 - 8:11 (line 6, column 1 - line 8, column 11) + + The declaration c contains arguments that couldn't be determined. + These arguments are: { a } + +in type class declaration for C + +See https://github.com/purescript/documentation/blob/master/errors/UnusableDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/Whitespace1.out b/tests/purs/failing/Whitespace1.out new file mode 100644 index 0000000000..299c3ddb53 --- /dev/null +++ b/tests/purs/failing/Whitespace1.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/Whitespace1.purs:5:1 - 5:2 (line 5, column 1 - line 5, column 2) + + Unable to parse module: + Illegal whitespace character U+0009 + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/.gitattributes b/tests/purs/warning/.gitattributes new file mode 100644 index 0000000000..d0b673f439 --- /dev/null +++ b/tests/purs/warning/.gitattributes @@ -0,0 +1 @@ +*.out -merge -text diff --git a/tests/purs/warning/2140.out b/tests/purs/warning/2140.out new file mode 100644 index 0000000000..9de35dd2b7 --- /dev/null +++ b/tests/purs/warning/2140.out @@ -0,0 +1,12 @@ +Error found: +in module Main +at tests/purs/warning/2140.purs:5:3 - 5:36 (line 5, column 3 - line 5, column 36) + + Type variable a was shadowed. + +in type declaration for f +in type class declaration for Test + +See https://github.com/purescript/documentation/blob/master/errors/ShadowedTypeVar.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/2383.out b/tests/purs/warning/2383.out new file mode 100644 index 0000000000..e69de29bb2 diff --git a/tests/purs/warning/2411.out b/tests/purs/warning/2411.out new file mode 100644 index 0000000000..796505c5c5 --- /dev/null +++ b/tests/purs/warning/2411.out @@ -0,0 +1,11 @@ +Error found: +in module Main +at tests/purs/warning/2411.purs:10:7 - 10:15 (line 10, column 7 - line 10, column 15) + + Name x was shadowed. + +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/ShadowedName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/2542.out b/tests/purs/warning/2542.out new file mode 100644 index 0000000000..340bc3dbb0 --- /dev/null +++ b/tests/purs/warning/2542.out @@ -0,0 +1,16 @@ +Error found: +in module Main +at tests/purs/warning/2542.purs:16:1 - 16:18 (line 16, column 1 - line 16, column 18) + + No type declaration was provided for the top-level declaration of main. + It is good practice to provide type declarations as a form of documentation. + The inferred type of main was: +   +  Effect Unit +   + +in value declaration main + +See https://github.com/purescript/documentation/blob/master/errors/MissingTypeDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/CustomWarning.out b/tests/purs/warning/CustomWarning.out new file mode 100644 index 0000000000..9b0fd1f884 --- /dev/null +++ b/tests/purs/warning/CustomWarning.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/warning/CustomWarning.purs:9:1 - 9:11 (line 9, column 1 - line 9, column 11) + + A custom warning occurred while solving type class constraints: + + Custom warning Int + + +in value declaration bar + +See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/CustomWarning2.out b/tests/purs/warning/CustomWarning2.out new file mode 100644 index 0000000000..938cc3a6b5 --- /dev/null +++ b/tests/purs/warning/CustomWarning2.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/warning/CustomWarning2.purs:12:1 - 12:11 (line 12, column 1 - line 12, column 11) + + A custom warning occurred while solving type class constraints: + + foo + + +in value declaration baz + +See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/CustomWarning3.out b/tests/purs/warning/CustomWarning3.out new file mode 100644 index 0000000000..75d151064d --- /dev/null +++ b/tests/purs/warning/CustomWarning3.out @@ -0,0 +1,30 @@ +Error 1 of 2: + + in module Main + at tests/purs/warning/CustomWarning3.purs:14:1 - 14:11 (line 14, column 1 - line 14, column 11) + + A custom warning occurred while solving type class constraints: + + foo + + + in value declaration baz + + See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module Main + at tests/purs/warning/CustomWarning3.purs:14:1 - 14:11 (line 14, column 1 - line 14, column 11) + + A custom warning occurred while solving type class constraints: + + bar + + + in value declaration baz + + See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/warning/CustomWarning4.out b/tests/purs/warning/CustomWarning4.out new file mode 100644 index 0000000000..ea2e306962 --- /dev/null +++ b/tests/purs/warning/CustomWarning4.out @@ -0,0 +1,60 @@ +Error 1 of 4: + + in module Main + at tests/purs/warning/CustomWarning4.purs:21:1 - 21:15 (line 21, column 1 - line 21, column 15) + + A custom warning occurred while solving type class constraints: + + Custom label hello + + + in value declaration baz' + + See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, + or to contribute content related to this error. + +Error 2 of 4: + + in module Main + at tests/purs/warning/CustomWarning4.purs:24:1 - 24:16 (line 24, column 1 - line 24, column 16) + + A custom warning occurred while solving type class constraints: + + Custom label hello + + + in value declaration baz'' + + See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, + or to contribute content related to this error. + +Error 3 of 4: + + in module Main + at tests/purs/warning/CustomWarning4.purs:27:1 - 27:17 (line 27, column 1 - line 27, column 17) + + A custom warning occurred while solving type class constraints: + + Custom label "h e l l o" + + + in value declaration baz''' + + See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, + or to contribute content related to this error. + +Error 4 of 4: + + in module Main + at tests/purs/warning/CustomWarning4.purs:30:1 - 30:18 (line 30, column 1 - line 30, column 18) + + A custom warning occurred while solving type class constraints: + + Custom label "hel\"lo" + + + in value declaration baz'''' + + See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/warning/DuplicateExportRef.out b/tests/purs/warning/DuplicateExportRef.out new file mode 100644 index 0000000000..649b5c06ea --- /dev/null +++ b/tests/purs/warning/DuplicateExportRef.out @@ -0,0 +1,77 @@ +Error 1 of 7: + + in module Main + at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) + + Export list contains multiple references to type X + + + See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, + or to contribute content related to this error. + +Error 2 of 7: + + in module Main + at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) + + Export list contains multiple references to value fn + + + See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, + or to contribute content related to this error. + +Error 3 of 7: + + in module Main + at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) + + Export list contains multiple references to operator (!) + + + See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, + or to contribute content related to this error. + +Error 4 of 7: + + in module Main + at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) + + Export list contains multiple references to type class Y + + + See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, + or to contribute content related to this error. + +Error 5 of 7: + + in module Main + at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) + + Export list contains multiple references to type operator (~>) + + + See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, + or to contribute content related to this error. + +Error 6 of 7: + + in module Main + at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) + + Export list contains multiple references to module Prelude + + + See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, + or to contribute content related to this error. + +Error 7 of 7: + + in module Main + at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) + + Export list contains multiple references to data constructor X + + + See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/warning/DuplicateImport.out b/tests/purs/warning/DuplicateImport.out new file mode 100644 index 0000000000..089403fb97 --- /dev/null +++ b/tests/purs/warning/DuplicateImport.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/warning/DuplicateImport.purs:5:1 - 5:34 (line 5, column 1 - line 5, column 34) + + Duplicate import of Prelude (Unit, unit, pure) + + +See https://github.com/purescript/documentation/blob/master/errors/DuplicateImport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/DuplicateImportRef.out b/tests/purs/warning/DuplicateImportRef.out new file mode 100644 index 0000000000..e361bc5894 --- /dev/null +++ b/tests/purs/warning/DuplicateImportRef.out @@ -0,0 +1,44 @@ +Error 1 of 4: + + in module Main + at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) + + Import list contains multiple references to type Unit + + + See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, + or to contribute content related to this error. + +Error 2 of 4: + + in module Main + at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) + + Import list contains multiple references to value unit + + + See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, + or to contribute content related to this error. + +Error 3 of 4: + + in module Main + at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) + + Import list contains multiple references to type class Functor + + + See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, + or to contribute content related to this error. + +Error 4 of 4: + + in module Main + at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) + + Import list contains multiple references to operator (<>) + + + See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/warning/DuplicateSelectiveImport.out b/tests/purs/warning/DuplicateSelectiveImport.out new file mode 100644 index 0000000000..3acb83ee71 --- /dev/null +++ b/tests/purs/warning/DuplicateSelectiveImport.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/warning/DuplicateSelectiveImport.purs:5:1 - 5:22 (line 5, column 1 - line 5, column 22) + + There is an existing import of Prelude, consider merging the import lists + + +See https://github.com/purescript/documentation/blob/master/errors/DuplicateSelectiveImport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/HidingImport.out b/tests/purs/warning/HidingImport.out new file mode 100644 index 0000000000..c66ab99ff5 --- /dev/null +++ b/tests/purs/warning/HidingImport.out @@ -0,0 +1,28 @@ +Error 1 of 2: + + in module Main + at tests/purs/warning/HidingImport.purs:6:1 - 6:30 (line 6, column 1 - line 6, column 30) + + Module Effect has unspecified imports, consider using the inclusive form: + + import Effect (Effect) + + + + See https://github.com/purescript/documentation/blob/master/errors/HidingImport.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module Main + at tests/purs/warning/HidingImport.purs:5:1 - 5:28 (line 5, column 1 - line 5, column 28) + + Module Prelude has unspecified imports, consider using the inclusive form: + + import Prelude (Unit, pure, unit) + + + + See https://github.com/purescript/documentation/blob/master/errors/HidingImport.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/warning/ImplicitImport.out b/tests/purs/warning/ImplicitImport.out new file mode 100644 index 0000000000..79326fe44f --- /dev/null +++ b/tests/purs/warning/ImplicitImport.out @@ -0,0 +1,28 @@ +Error 1 of 2: + + in module Main + at tests/purs/warning/ImplicitImport.purs:6:1 - 6:14 (line 6, column 1 - line 6, column 14) + + Module Effect has unspecified imports, consider using the explicit form: + + import Effect (Effect) + + + + See https://github.com/purescript/documentation/blob/master/errors/ImplicitImport.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module Main + at tests/purs/warning/ImplicitImport.purs:5:1 - 5:15 (line 5, column 1 - line 5, column 15) + + Module Prelude has unspecified imports, consider using the explicit form: + + import Prelude (Unit, pure, unit) + + + + See https://github.com/purescript/documentation/blob/master/errors/ImplicitImport.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/warning/ImplicitQualifiedImport.out b/tests/purs/warning/ImplicitQualifiedImport.out new file mode 100644 index 0000000000..b85569c87e --- /dev/null +++ b/tests/purs/warning/ImplicitQualifiedImport.out @@ -0,0 +1,30 @@ +Error 1 of 2: + + in module Main + at tests/purs/warning/ImplicitQualifiedImport.purs:7:1 - 7:19 (line 7, column 1 - line 7, column 19) + + Module Effect was imported as E with unspecified imports. + As there are multiple modules being imported as E, consider using the explicit form: + + import Effect (Effect) as E + + + + See https://github.com/purescript/documentation/blob/master/errors/ImplicitQualifiedImport.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module Main + at tests/purs/warning/ImplicitQualifiedImport.purs:8:1 - 8:27 (line 8, column 1 - line 8, column 27) + + Module Effect.Console was imported as E with unspecified imports. + As there are multiple modules being imported as E, consider using the explicit form: + + import Effect.Console (log) as E + + + + See https://github.com/purescript/documentation/blob/master/errors/ImplicitQualifiedImport.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/warning/ImplicitQualifiedImportReExport.out b/tests/purs/warning/ImplicitQualifiedImportReExport.out new file mode 100644 index 0000000000..30b19933f1 --- /dev/null +++ b/tests/purs/warning/ImplicitQualifiedImportReExport.out @@ -0,0 +1,30 @@ +Error 1 of 2: + + in module Main + at tests/purs/warning/ImplicitQualifiedImportReExport.purs:9:1 - 9:23 (line 9, column 1 - line 9, column 23) + + Module Data.Maybe was imported as X with unspecified imports. + As this module is being re-exported, consider using the explicit form: + + import Data.Maybe (Maybe(..), fromJust, fromMaybe, fromMaybe', isJust, isNothing, maybe, maybe', optional) as X + + + + See https://github.com/purescript/documentation/blob/master/errors/ImplicitQualifiedImportReExport.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module Main + at tests/purs/warning/ImplicitQualifiedImportReExport.purs:10:1 - 10:24 (line 10, column 1 - line 10, column 24) + + Module Data.Either was imported as Y with unspecified imports. + As this module is being re-exported, consider using the explicit form: + + import Data.Either (Either(..), choose, either, fromLeft, fromRight, hush, isLeft, isRight, note, note') as Y + + + + See https://github.com/purescript/documentation/blob/master/errors/ImplicitQualifiedImportReExport.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/warning/Kind-UnusedExplicitImport-1.out b/tests/purs/warning/Kind-UnusedExplicitImport-1.out new file mode 100644 index 0000000000..7944527578 --- /dev/null +++ b/tests/purs/warning/Kind-UnusedExplicitImport-1.out @@ -0,0 +1,17 @@ +Error found: +in module Main +at tests/purs/warning/Kind-UnusedExplicitImport-1.purs:6:1 - 6:44 (line 6, column 1 - line 6, column 44) + + The import of module Type.RowList contains the following unused references: + + RLProxy + + It could be replaced with: + + import Type.RowList (kind RowList) + + + +See https://github.com/purescript/documentation/blob/master/errors/UnusedExplicitImport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/Kind-UnusedExplicitImport-2.out b/tests/purs/warning/Kind-UnusedExplicitImport-2.out new file mode 100644 index 0000000000..508a580bd6 --- /dev/null +++ b/tests/purs/warning/Kind-UnusedExplicitImport-2.out @@ -0,0 +1,17 @@ +Error found: +in module Main +at tests/purs/warning/Kind-UnusedExplicitImport-2.purs:6:1 - 6:44 (line 6, column 1 - line 6, column 44) + + The import of module Type.RowList contains the following unused references: + + RowList + + It could be replaced with: + + import Type.RowList (RLProxy) + + + +See https://github.com/purescript/documentation/blob/master/errors/UnusedExplicitImport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/Kind-UnusedImport.out b/tests/purs/warning/Kind-UnusedImport.out new file mode 100644 index 0000000000..d5e9823522 --- /dev/null +++ b/tests/purs/warning/Kind-UnusedImport.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/warning/Kind-UnusedImport.purs:6:1 - 6:35 (line 6, column 1 - line 6, column 35) + + The import of Type.RowList is redundant + + +See https://github.com/purescript/documentation/blob/master/errors/UnusedImport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/KindReExport.out b/tests/purs/warning/KindReExport.out new file mode 100644 index 0000000000..e69de29bb2 diff --git a/tests/purs/warning/MissingTypeDeclaration.out b/tests/purs/warning/MissingTypeDeclaration.out new file mode 100644 index 0000000000..22aa2b1c55 --- /dev/null +++ b/tests/purs/warning/MissingTypeDeclaration.out @@ -0,0 +1,16 @@ +Error found: +in module Main +at tests/purs/warning/MissingTypeDeclaration.purs:4:1 - 4:6 (line 4, column 1 - line 4, column 6) + + No type declaration was provided for the top-level declaration of x. + It is good practice to provide type declarations as a form of documentation. + The inferred type of x was: +   +  Int +   + +in value declaration x + +See https://github.com/purescript/documentation/blob/master/errors/MissingTypeDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/NewtypeInstance.out b/tests/purs/warning/NewtypeInstance.out new file mode 100644 index 0000000000..e42f4cc9c4 --- /dev/null +++ b/tests/purs/warning/NewtypeInstance.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/warning/NewtypeInstance.purs:8:1 - 8:38 (line 8, column 1 - line 8, column 38) + + The derived newtype instance for +   +  Data.Ord.Ord X +   + does not include a derived superclass instance for Data.Eq.Eq. + + +See https://github.com/purescript/documentation/blob/master/errors/MissingNewtypeSuperclassInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/NewtypeInstance2.out b/tests/purs/warning/NewtypeInstance2.out new file mode 100644 index 0000000000..e781d97f75 --- /dev/null +++ b/tests/purs/warning/NewtypeInstance2.out @@ -0,0 +1,14 @@ +Error found: +at tests/purs/warning/NewtypeInstance2.purs:15:1 - 15:86 (line 15, column 1 - line 15, column 86) + + The derived newtype instance for +   +  Main.MonadWriter w  +  (MyWriter w) +   + does not include a derived superclass instance for Control.Monad.Monad. + + +See https://github.com/purescript/documentation/blob/master/errors/MissingNewtypeSuperclassInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/NewtypeInstance3.out b/tests/purs/warning/NewtypeInstance3.out new file mode 100644 index 0000000000..5a7cad6a0d --- /dev/null +++ b/tests/purs/warning/NewtypeInstance3.out @@ -0,0 +1,14 @@ +Error found: +at tests/purs/warning/NewtypeInstance3.purs:21:1 - 21:86 (line 21, column 1 - line 21, column 86) + + The derived newtype instance for +   +  Main.MonadWriter w  +  (MyWriter w) +   + does not include a derived superclass instance for Main.MonadTell. + + +See https://github.com/purescript/documentation/blob/master/errors/MissingNewtypeSuperclassInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/NewtypeInstance4.out b/tests/purs/warning/NewtypeInstance4.out new file mode 100644 index 0000000000..ebf2d4b882 --- /dev/null +++ b/tests/purs/warning/NewtypeInstance4.out @@ -0,0 +1,14 @@ +Error found: +at tests/purs/warning/NewtypeInstance4.purs:23:1 - 23:86 (line 23, column 1 - line 23, column 86) + + The derived newtype instance for +   +  Main.MonadWriter w  +  (MyWriter w) +   + implies an superclass instance for Main.MonadTell which could not be verified. + + +See https://github.com/purescript/documentation/blob/master/errors/UnverifiableSuperclassInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/OverlappingPattern.out b/tests/purs/warning/OverlappingPattern.out new file mode 100644 index 0000000000..48534b5de3 --- /dev/null +++ b/tests/purs/warning/OverlappingPattern.out @@ -0,0 +1,28 @@ +Error 1 of 2: + + in module Main + at tests/purs/warning/OverlappingPattern.purs:12:1 - 12:21 (line 12, column 1 - line 12, column 21) + + A case expression contains unreachable cases: + + B + + in value declaration pat2 + + See https://github.com/purescript/documentation/blob/master/errors/OverlappingPattern.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module Main + at tests/purs/warning/OverlappingPattern.purs:7:1 - 7:21 (line 7, column 1 - line 7, column 21) + + A case expression contains unreachable cases: + + A + + in value declaration pat1 + + See https://github.com/purescript/documentation/blob/master/errors/OverlappingPattern.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/warning/ScopeShadowing.out b/tests/purs/warning/ScopeShadowing.out new file mode 100644 index 0000000000..5c0f99763c --- /dev/null +++ b/tests/purs/warning/ScopeShadowing.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/warning/ScopeShadowing.purs:4:1 - 4:15 (line 4, column 1 - line 4, column 15) + + Shadowed definitions are in scope for type Unit from the following open imports: + + import Prelude + + These will be ignored and the local declaration will be used. + + +See https://github.com/purescript/documentation/blob/master/errors/ScopeShadowing.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/ScopeShadowing2.out b/tests/purs/warning/ScopeShadowing2.out new file mode 100644 index 0000000000..5bb1bf07ca --- /dev/null +++ b/tests/purs/warning/ScopeShadowing2.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/warning/ScopeShadowing2.purs:7:1 - 7:22 (line 7, column 1 - line 7, column 22) + + Shadowed definitions are in scope for value append from the following open imports: + + import Data.Semigroup + + These will be ignored and the local declaration will be used. + + +See https://github.com/purescript/documentation/blob/master/errors/ScopeShadowing.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/ShadowedBinderPatternGuard.out b/tests/purs/warning/ShadowedBinderPatternGuard.out new file mode 100644 index 0000000000..8ae2dfd83e --- /dev/null +++ b/tests/purs/warning/ShadowedBinderPatternGuard.out @@ -0,0 +1,11 @@ +Error found: +in module Main +at tests/purs/warning/ShadowedBinderPatternGuard.purs:6:7 - 6:8 (line 6, column 7 - line 6, column 8) + + Name i was shadowed. + +in value declaration f + +See https://github.com/purescript/documentation/blob/master/errors/ShadowedName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/ShadowedNameParens.out b/tests/purs/warning/ShadowedNameParens.out new file mode 100644 index 0000000000..4864b84ff3 --- /dev/null +++ b/tests/purs/warning/ShadowedNameParens.out @@ -0,0 +1,11 @@ +Error found: +in module Main +at tests/purs/warning/ShadowedNameParens.purs:5:9 - 5:10 (line 5, column 9 - line 5, column 10) + + Name n was shadowed. + +in value declaration f + +See https://github.com/purescript/documentation/blob/master/errors/ShadowedName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/ShadowedTypeVar.out b/tests/purs/warning/ShadowedTypeVar.out new file mode 100644 index 0000000000..b2a01fea7d --- /dev/null +++ b/tests/purs/warning/ShadowedTypeVar.out @@ -0,0 +1,11 @@ +Error found: +in module Main +at tests/purs/warning/ShadowedTypeVar.purs:4:1 - 4:44 (line 4, column 1 - line 4, column 44) + + Type variable a was shadowed. + +in type declaration for f + +See https://github.com/purescript/documentation/blob/master/errors/ShadowedTypeVar.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/UnnecessaryFFIModule.out b/tests/purs/warning/UnnecessaryFFIModule.out new file mode 100644 index 0000000000..1399274611 --- /dev/null +++ b/tests/purs/warning/UnnecessaryFFIModule.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/warning/UnnecessaryFFIModule.purs:2:1 - 5:9 (line 2, column 1 - line 5, column 9) + + An unnecessary foreign module implementation was provided for module Main: + + tests/purs/warning/UnnecessaryFFIModule.js + + Module Main does not contain any foreign import declarations, so a foreign module is not necessary. + + +See https://github.com/purescript/documentation/blob/master/errors/UnnecessaryFFIModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/UnusedDctorExplicitImport.out b/tests/purs/warning/UnusedDctorExplicitImport.out new file mode 100644 index 0000000000..8fc0fccce4 --- /dev/null +++ b/tests/purs/warning/UnusedDctorExplicitImport.out @@ -0,0 +1,17 @@ +Error found: +in module Main +at tests/purs/warning/UnusedDctorExplicitImport.purs:4:1 - 4:40 (line 4, column 1 - line 4, column 40) + + The import of type Ordering from module Data.Ordering includes the following unused data constructors: + + LT + + It could be replaced with: + + import Data.Ordering (Ordering(EQ)) + + + +See https://github.com/purescript/documentation/blob/master/errors/UnusedDctorExplicitImport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/UnusedDctorImportAll.out b/tests/purs/warning/UnusedDctorImportAll.out new file mode 100644 index 0000000000..b22de09b8d --- /dev/null +++ b/tests/purs/warning/UnusedDctorImportAll.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/warning/UnusedDctorImportAll.purs:4:1 - 4:36 (line 4, column 1 - line 4, column 36) + + The import of type Ordering from module Data.Ordering includes data constructors but only the type is used + It could be replaced with: + + import Data.Ordering (Ordering) + + + +See https://github.com/purescript/documentation/blob/master/errors/UnusedDctorImport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/UnusedDctorImportExplicit.out b/tests/purs/warning/UnusedDctorImportExplicit.out new file mode 100644 index 0000000000..a2acb53b26 --- /dev/null +++ b/tests/purs/warning/UnusedDctorImportExplicit.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/warning/UnusedDctorImportExplicit.purs:4:1 - 4:36 (line 4, column 1 - line 4, column 36) + + The import of type Ordering from module Data.Ordering includes data constructors but only the type is used + It could be replaced with: + + import Data.Ordering (Ordering) + + + +See https://github.com/purescript/documentation/blob/master/errors/UnusedDctorImport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/UnusedExplicitImport.out b/tests/purs/warning/UnusedExplicitImport.out new file mode 100644 index 0000000000..ac0a868b36 --- /dev/null +++ b/tests/purs/warning/UnusedExplicitImport.out @@ -0,0 +1,17 @@ +Error found: +in module Main +at tests/purs/warning/UnusedExplicitImport.purs:4:1 - 4:40 (line 4, column 1 - line 4, column 40) + + The import of module Prelude contains the following unused references: + + bind + + It could be replaced with: + + import Prelude (Unit, pure, unit) + + + +See https://github.com/purescript/documentation/blob/master/errors/UnusedExplicitImport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/UnusedExplicitImportTypeOp.out b/tests/purs/warning/UnusedExplicitImportTypeOp.out new file mode 100644 index 0000000000..5f2686d4fa --- /dev/null +++ b/tests/purs/warning/UnusedExplicitImportTypeOp.out @@ -0,0 +1,17 @@ +Error found: +in module Main +at tests/purs/warning/UnusedExplicitImportTypeOp.purs:6:1 - 6:30 (line 6, column 1 - line 6, column 30) + + The import of module Lib contains the following unused references: + + (~>) + + It could be replaced with: + + import Lib (natId) + + + +See https://github.com/purescript/documentation/blob/master/errors/UnusedExplicitImport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/UnusedExplicitImportValOp.out b/tests/purs/warning/UnusedExplicitImportValOp.out new file mode 100644 index 0000000000..a629b72ebf --- /dev/null +++ b/tests/purs/warning/UnusedExplicitImportValOp.out @@ -0,0 +1,17 @@ +Error found: +in module Main +at tests/purs/warning/UnusedExplicitImportValOp.purs:4:1 - 4:39 (line 4, column 1 - line 4, column 39) + + The import of module Prelude contains the following unused references: + + (+) + + It could be replaced with: + + import Prelude (Unit, pure, unit) + + + +See https://github.com/purescript/documentation/blob/master/errors/UnusedExplicitImport.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/UnusedFFIImplementations.out b/tests/purs/warning/UnusedFFIImplementations.out new file mode 100644 index 0000000000..32b024c69b --- /dev/null +++ b/tests/purs/warning/UnusedFFIImplementations.out @@ -0,0 +1,12 @@ +Error found: +at tests/purs/warning/UnusedFFIImplementations.purs:2:1 - 4:30 (line 2, column 1 - line 4, column 30) + + The following definitions in the foreign module for module Main are unused: + + no + + + +See https://github.com/purescript/documentation/blob/master/errors/UnusedFFIImplementations.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/UnusedImport.out b/tests/purs/warning/UnusedImport.out new file mode 100644 index 0000000000..c1138dacd7 --- /dev/null +++ b/tests/purs/warning/UnusedImport.out @@ -0,0 +1,22 @@ +Error 1 of 2: + + in module Main + at tests/purs/warning/UnusedImport.purs:8:1 - 8:14 (line 8, column 1 - line 8, column 14) + + The import of Effect is redundant + + + See https://github.com/purescript/documentation/blob/master/errors/UnusedImport.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module Main + at tests/purs/warning/UnusedImport.purs:9:1 - 9:33 (line 9, column 1 - line 9, column 33) + + The qualified import of Effect.Console as Console is redundant + + + See https://github.com/purescript/documentation/blob/master/errors/UnusedImport.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/warning/UnusedTypeVar.out b/tests/purs/warning/UnusedTypeVar.out new file mode 100644 index 0000000000..9e8ca511cd --- /dev/null +++ b/tests/purs/warning/UnusedTypeVar.out @@ -0,0 +1,11 @@ +Error found: +in module Main +at tests/purs/warning/UnusedTypeVar.purs:4:1 - 4:24 (line 4, column 1 - line 4, column 24) + + Type variable b is ambiguous, since it is unused in the polymorphic type which introduces it. + +in type declaration for f + +See https://github.com/purescript/documentation/blob/master/errors/UnusedTypeVar.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/WildcardInferredType.out b/tests/purs/warning/WildcardInferredType.out new file mode 100644 index 0000000000..bcbceb452f --- /dev/null +++ b/tests/purs/warning/WildcardInferredType.out @@ -0,0 +1,30 @@ +Error 1 of 2: + + in module Main + at tests/purs/warning/WildcardInferredType.purs:7:6 - 7:7 (line 7, column 6 - line 7, column 7) + + Wildcard type definition has the inferred type +   +  Int +   + + in value declaration y + + See https://github.com/purescript/documentation/blob/master/errors/WildcardInferredType.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module Main + at tests/purs/warning/WildcardInferredType.purs:5:10 - 5:11 (line 5, column 10 - line 5, column 11) + + Wildcard type definition has the inferred type +   +  Int +   + + in value declaration x + + See https://github.com/purescript/documentation/blob/master/errors/WildcardInferredType.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/warning/WildcardInferredType2.out b/tests/purs/warning/WildcardInferredType2.out new file mode 100644 index 0000000000..89efd26d58 --- /dev/null +++ b/tests/purs/warning/WildcardInferredType2.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/warning/WildcardInferredType2.purs:4:6 - 4:7 (line 4, column 6 - line 4, column 7) + + Wildcard type definition has the inferred type +   +  Int +   + +in value declaration x + +See https://github.com/purescript/documentation/blob/master/errors/WildcardInferredType.md for more information, +or to contribute content related to this error. + From fcc7a08a21a8de1dafb8624de02bfc94f81341b9 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann <6189397+kritzcreek@users.noreply.github.com> Date: Mon, 24 Feb 2020 02:16:27 +0100 Subject: [PATCH 1186/1580] [purs ide] Updates the cache-db.json file on rebuilds (#3789) * generalizes and extracts CacheDb accessors from Make This is so they can be used from within the IDE as well, which doesn't run in Make * overwrites ContentHashes and Timestamps for rebuilt modules * removes a whole lot of "Christoph didn't know what he was doing" * reorganizes the cache info building * normalises filepaths before inserting them into the Cache * normalise file paths when rebuilding from the IDE * extracts the logic that updates the Cache * inlines function that I didn't up using in the IDE code * cleaner diff * more simplifications * Update src/Language/PureScript/Make/Cache.hs --- src/Language/PureScript/Ide/Rebuild.hs | 110 +++++++++++++--------- src/Language/PureScript/Make/Actions.hs | 33 ++++++- src/Language/PureScript/Make/BuildPlan.hs | 5 +- src/Language/PureScript/Make/Cache.hs | 27 +++++- src/Language/PureScript/Make/Monad.hs | 22 ++--- 5 files changed, 130 insertions(+), 67 deletions(-) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 9e38117de3..14ab0f3578 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TemplateHaskell #-} +{-# language PackageImports, TemplateHaskell, BlockArguments #-} module Language.PureScript.Ide.Rebuild ( rebuildFileSync @@ -7,20 +6,23 @@ module Language.PureScript.Ide.Rebuild , rebuildFile ) where -import Protolude +import Protolude hiding (moduleName) import "monad-logger" Control.Monad.Logger import qualified Data.List as List import qualified Data.Map.Lazy as M import Data.Maybe (fromJust) import qualified Data.Set as S +import qualified Data.Time as Time import qualified Language.PureScript as P +import Language.PureScript.Make.Cache (CacheInfo(..), normaliseForCache) import qualified Language.PureScript.CST as CST import Language.PureScript.Ide.Error import Language.PureScript.Ide.Logging import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import System.Directory (getCurrentDirectory) -- | Given a filepath performs the following steps: -- @@ -55,35 +57,72 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do Left parseError -> throwError $ RebuildError $ CST.toMultipleErrors fp' parseError Right m -> pure m - + let moduleName = P.getModuleName m -- Externs files must be sorted ahead of time, so that they get applied -- in the right order (bottom up) to the 'Environment'. externs <- logPerf (labelTimespec "Sorting externs") (sortExterns m =<< getExternFiles) - outputDirectory <- confOutputPath . ideConfiguration <$> ask - -- For rebuilding, we want to 'RebuildAlways', but for inferring foreign -- modules using their file paths, we need to specify the path in the 'Map'. - let filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways) - foreigns <- P.inferForeignModules (M.singleton (P.getModuleName m) (Right file)) - - let makeEnv = MakeActionsEnv outputDirectory filePathMap foreigns False + let filePathMap = M.singleton moduleName (Left P.RebuildAlways) + foreigns <- P.inferForeignModules (M.singleton moduleName (Right file)) + let makeEnv = P.buildMakeActions outputDirectory filePathMap foreigns False -- Rebuild the single module using the cached externs (result, warnings) <- logPerf (labelTimespec "Rebuilding Module") $ - liftIO - . P.runMake (P.defaultOptions { P.optionsCodegenTargets = codegenTargets }) - . P.rebuildModule (buildMakeActions - >>= shushProgress $ makeEnv) externs $ m + liftIO $ P.runMake (P.defaultOptions { P.optionsCodegenTargets = codegenTargets }) do + newExterns <- P.rebuildModule (shushProgress makeEnv) externs m + updateCacheDb codegenTargets outputDirectory file actualFile moduleName + pure newExterns case result of - Left errors -> throwError (RebuildError errors) + Left errors -> + throwError (RebuildError errors) Right newExterns -> do - whenM isEditorMode $ do + whenM isEditorMode do insertModule (fromMaybe file actualFile, m) insertExterns newExterns void populateVolatileState runOpenBuild (rebuildModuleOpen makeEnv externs m) pure (RebuildSuccess warnings) +-- | When adjusting the cache db file after a rebuild we always pick a +-- non-sensical timestamp ("1858-11-17T00:00:00Z"), and rely on the +-- content hash to tell whether the module needs rebuilding. This is +-- because IDE rebuilds may be triggered on temporary files to not +-- force editors to save the actual source file to get at diagnostics +dayZero :: Time.UTCTime +dayZero = Time.UTCTime (Time.ModifiedJulianDay 0) 0 + +updateCacheDb + :: MonadIO m + => MonadError P.MultipleErrors m + => Set P.CodegenTarget + -> FilePath + -- ^ The output directory + -> FilePath + -- ^ The file to read the content hash from + -> Maybe FilePath + -- ^ The file name to update in the cache + -> P.ModuleName + -- ^ The module name to update in the cache + -> m () +updateCacheDb codegenTargets outputDirectory file actualFile moduleName = do + cwd <- liftIO getCurrentDirectory + contentHash <- P.hashFile file + let moduleCacheInfo = (normaliseForCache cwd (fromMaybe file actualFile), (dayZero, contentHash)) + + foreignCacheInfo <- + if S.member P.JS codegenTargets then do + foreigns' <- P.inferForeignModules (M.singleton moduleName (Right (fromMaybe file actualFile))) + for (M.lookup moduleName foreigns') \foreignPath -> do + foreignHash <- P.hashFile foreignPath + pure (normaliseForCache cwd foreignPath, (dayZero, foreignHash)) + else + pure Nothing + + let cacheInfo = M.fromList (moduleCacheInfo : maybeToList foreignCacheInfo) + cacheDb <- P.readCacheDb' outputDirectory + P.writeCacheDb' outputDirectory (M.insert moduleName (CacheInfo cacheInfo) cacheDb) + isEditorMode :: Ide m => m Bool isEditorMode = asks (confEditorMode . ideConfiguration) @@ -109,22 +148,17 @@ rebuildFileSync fp fp' ts = rebuildFile fp fp' ts syncRun let ll = confLogLevel (ideConfiguration env) void (liftIO (runLogger ll (runReaderT action env))) - -- | Rebuilds a module but opens up its export list first and stores the result -- inside the rebuild cache rebuildModuleOpen :: (Ide m, MonadLogger m) - => MakeActionsEnv + => P.MakeActions P.Make -> [P.ExternsFile] -> P.Module -> m () -rebuildModuleOpen makeEnv externs m = void $ runExceptT $ do - (openResult, _) <- liftIO - . P.runMake P.defaultOptions - . P.rebuildModule (buildMakeActions - >>= shushProgress - >>= shushCodegen - $ makeEnv) externs $ openModuleExports m +rebuildModuleOpen makeEnv externs m = void $ runExceptT do + (openResult, _) <- liftIO $ P.runMake P.defaultOptions $ + P.rebuildModule (shushProgress (shushCodegen makeEnv)) externs (openModuleExports m) case openResult of Left _ -> throwError (GeneralError "Failed when rebuilding with open exports") @@ -133,32 +167,14 @@ rebuildModuleOpen makeEnv externs m = void $ runExceptT $ do ("Setting Rebuild cache: " <> P.runModuleName (P.efModuleName result)) cacheRebuild result --- | Parameters we can access while building our @MakeActions@ -data MakeActionsEnv = - MakeActionsEnv - { maeOutputDirectory :: FilePath - , maeFilePathMap :: ModuleMap (Either P.RebuildPolicy FilePath) - , maeForeignPathMap :: ModuleMap FilePath - , maePrefixComment :: Bool - } - --- | Builds the default @MakeActions@ from a @MakeActionsEnv@ -buildMakeActions :: MakeActionsEnv -> P.MakeActions P.Make -buildMakeActions MakeActionsEnv{..} = - P.buildMakeActions - maeOutputDirectory - maeFilePathMap - maeForeignPathMap - maePrefixComment - -- | Shuts the compiler up about progress messages -shushProgress :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make -shushProgress ma _ = +shushProgress :: Monad m => P.MakeActions m -> P.MakeActions m +shushProgress ma = ma { P.progress = \_ -> pure () } -- | Stops any kind of codegen -shushCodegen :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make -shushCodegen ma MakeActionsEnv{..} = +shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m +shushCodegen ma = ma { P.codegen = \_ _ _ -> pure () , P.ffiCodegen = \_ -> pure () } diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index b3fe5ee0d7..d2a1774f45 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -4,6 +4,8 @@ module Language.PureScript.Make.Actions , ProgressMessage(..) , buildMakeActions , checkForeignDecls + , readCacheDb' + , writeCacheDb' ) where import Prelude @@ -105,6 +107,28 @@ data MakeActions m = MakeActions -- ^ If generating docs, output the documentation for the Prim modules } +-- | Given the output directory, determines the location for the +-- CacheDb file +cacheDbFile :: FilePath -> FilePath +cacheDbFile = ( "cache-db.json") + +readCacheDb' + :: (MonadIO m, MonadError MultipleErrors m) + => FilePath + -- ^ The path to the output directory + -> m CacheDb +readCacheDb' outputDir = + fromMaybe mempty <$> readJSONFile (cacheDbFile outputDir) + +writeCacheDb' + :: (MonadIO m, MonadError MultipleErrors m) + => FilePath + -- ^ The path to the output directory + -> CacheDb + -- ^ The CacheDb to be written + -> m () +writeCacheDb' = writeJSONFile . cacheDbFile + -- | A set of make actions that read and write modules from the given directory. buildMakeActions :: FilePath @@ -129,7 +153,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = Left policy -> return (Left policy) Right filePath -> do - let inputPaths = filePath : maybeToList (M.lookup mn foreigns) + cwd <- makeIO "Getting the current directory" getCurrentDirectory + let inputPaths = map (normaliseForCache cwd) (filePath : maybeToList (M.lookup mn foreigns)) getInfo fp = do ts <- getTimestamp fp return (ts, hashFile fp) @@ -246,12 +271,10 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = progress = liftIO . putStrLn . renderProgressMessage readCacheDb :: Make CacheDb - readCacheDb = fmap (fromMaybe mempty) $ readJSONFile cacheDbFile + readCacheDb = readCacheDb' outputDir writeCacheDb :: CacheDb -> Make () - writeCacheDb = writeJSONFile cacheDbFile - - cacheDbFile = outputDir "cache-db.json" + writeCacheDb = writeCacheDb' outputDir -- | Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module. diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 8d409f6699..a8b0bfbab8 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -14,6 +14,7 @@ import Prelude import Control.Concurrent.Async.Lifted as A import Control.Concurrent.Lifted as C +import Control.Monad.Base (liftBase) import Control.Monad hiding (sequence) import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) @@ -30,6 +31,7 @@ import Language.PureScript.Make.Actions as Actions import Language.PureScript.Make.Cache import Language.PureScript.Names (ModuleName) import Language.PureScript.Sugar.Names.Env +import System.Directory (getCurrentDirectory) -- | The BuildPlan tracks information about our build progress, and holds all -- prebuilt modules for incremental builds. @@ -176,7 +178,8 @@ construct MakeActions{..} cacheDb (sorted, graph) = do , statusNewCacheInfo = Nothing }) Right cacheInfo -> do - (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cacheInfo + cwd <- liftBase getCurrentDirectory + (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cwd cacheInfo prebuilt <- if isUpToDate then findExistingExtern moduleName diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs index 47f7f0e94b..bfc3e4c7f8 100644 --- a/src/Language/PureScript/Make/Cache.hs +++ b/src/Language/PureScript/Make/Cache.hs @@ -4,9 +4,10 @@ module Language.PureScript.Make.Cache ( ContentHash , hash , CacheDb - , CacheInfo + , CacheInfo(..) , checkChanged , removeModules + , normaliseForCache ) where import Prelude @@ -29,6 +30,7 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.These (These(..)) import Data.Time.Clock (UTCTime) import Data.Traversable (for) +import qualified System.FilePath as FilePath import Language.PureScript.Names (ModuleName) @@ -93,13 +95,15 @@ checkChanged :: Monad m => CacheDb -> ModuleName + -> FilePath -> Map FilePath (UTCTime, m ContentHash) -> m (CacheInfo, Bool) -checkChanged cacheDb mn currentInfo = do +checkChanged cacheDb mn basePath currentInfo = do + let dbInfo = unCacheInfo $ fromMaybe mempty (Map.lookup mn cacheDb) (newInfo, isUpToDate) <- fmap mconcat $ - for (Map.toList (align dbInfo currentInfo)) $ \(fp, aligned) -> do + for (Map.toList (align dbInfo currentInfo)) $ \(normaliseForCache basePath -> fp, aligned) -> do case aligned of This _ -> do -- One of the input files listed in the cache no longer exists; @@ -128,3 +132,20 @@ checkChanged cacheDb mn currentInfo = do -- they failed to build. removeModules :: Set ModuleName -> CacheDb -> CacheDb removeModules moduleNames = flip Map.withoutKeys moduleNames + +-- | 1. Any path that is beneath our current working directory will be +-- stored as a normalised relative path +-- 2. Any path that isn't will be stored as an absolute path +normaliseForCache :: FilePath -> FilePath -> FilePath +normaliseForCache basePath fp = + if FilePath.isRelative fp then + FilePath.normalise fp + else + let relativePath = FilePath.makeRelative basePath fp in + if FilePath.isRelative relativePath then + FilePath.normalise relativePath + else + -- If the path is still absolute after trying to make it + -- relative to the base that means it is not underneath + -- the base path + FilePath.normalise fp diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index ed2a2dc4d4..289ecbbe7b 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -64,26 +64,26 @@ runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake -- | Run an 'IO' action in the 'Make' monad. The 'String' argument should -- describe what we were trying to do; it is used for rendering errors in the -- case that an IOException is thrown. -makeIO :: Text -> IO a -> Make a +makeIO :: (MonadIO m, MonadError MultipleErrors m) => Text -> IO a -> m a makeIO description io = do - e <- liftIO $ tryIOError io - either (throwError . singleError . ErrorMessage [] . FileIOError description) return e + res <- liftIO (tryIOError io) + either (throwError . singleError . ErrorMessage [] . FileIOError description) pure res -- | Get a file's modification time in the 'Make' monad, capturing any errors -- using the 'MonadError' instance. -getTimestamp :: FilePath -> Make UTCTime +getTimestamp :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m UTCTime getTimestamp path = makeIO ("get a timestamp for file: " <> Text.pack path) $ getModificationTime path -- | Get a file's modification time in the 'Make' monad, returning Nothing if -- the file does not exist. -getTimestampMaybe :: FilePath -> Make (Maybe UTCTime) +getTimestampMaybe :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m (Maybe UTCTime) getTimestampMaybe path = makeIO ("get a timestamp for file: " <> Text.pack path) $ catchDoesNotExist $ getModificationTime path -- | Read a text file strictly in the 'Make' monad, capturing any errors using -- the 'MonadError' instance. -readTextFile :: FilePath -> Make Text +readTextFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m Text readTextFile path = makeIO ("read file: " <> Text.pack path) $ readUTF8FileT path @@ -91,7 +91,7 @@ readTextFile path = -- | Read a JSON file in the 'Make' monad, returning 'Nothing' if the file does -- not exist or could not be parsed. Errors are captured using the 'MonadError' -- instance. -readJSONFile :: Aeson.FromJSON a => FilePath -> Make (Maybe a) +readJSONFile :: (MonadIO m, MonadError MultipleErrors m) => Aeson.FromJSON a => FilePath -> m (Maybe a) readJSONFile path = makeIO ("read JSON file: " <> Text.pack path) $ do r <- catchDoesNotExist $ Aeson.decodeFileStrict' path @@ -100,7 +100,7 @@ readJSONFile path = -- | Read an externs file, returning 'Nothing' if the file does not exist, -- could not be parsed, or was generated by a different version of the -- compiler. -readExternsFile :: FilePath -> Make (Maybe ExternsFile) +readExternsFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m (Maybe ExternsFile) readExternsFile path = do mexterns <- readJSONFile path return $ do @@ -108,7 +108,7 @@ readExternsFile path = do guard $ externsIsCurrentVersion externs return externs -hashFile :: FilePath -> Make ContentHash +hashFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m ContentHash hashFile path = do makeIO ("hash file: " <> Text.pack path) (hash <$> B.readFile path) @@ -133,14 +133,14 @@ writeTextFile path text = makeIO ("write file: " <> Text.pack path) $ do -- | Write a JSON file in the 'Make' monad, capturing any errors using the -- 'MonadError' instance. -writeJSONFile :: Aeson.ToJSON a => FilePath -> a -> Make () +writeJSONFile :: (MonadIO m, MonadError MultipleErrors m) => Aeson.ToJSON a => FilePath -> a -> m () writeJSONFile path value = makeIO ("write JSON file: " <> Text.pack path) $ do createParentDirectory path Aeson.encodeFile path value -- | Copy a file in the 'Make' monad, capturing any errors using the -- 'MonadError' instance. -copyFile :: FilePath -> FilePath -> Make () +copyFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> FilePath -> m () copyFile src dest = makeIO ("copy file: " <> Text.pack src <> " -> " <> Text.pack dest) $ do createParentDirectory dest From 94857d8dfd229c136eae7f8662a960cb761c1e56 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 5 Mar 2020 15:02:21 +0100 Subject: [PATCH 1187/1580] Fix typos (#3795) * Fix typos * Add @mhmdanas to contributors --- CONTRIBUTORS.md | 1 + app/Command/Hierarchy.hs | 2 +- psc-ide/DESIGN.org | 4 ++-- psc-ide/PROTOCOL.md | 6 +++--- src/Language/PureScript/CST/Layout.hs | 4 ++-- src/Language/PureScript/CoreFn/Meta.hs | 4 ++-- src/Language/PureScript/CoreFn/Module.hs | 2 +- src/Language/PureScript/Docs/Prim.hs | 4 ++-- src/Language/PureScript/Environment.hs | 8 ++++---- src/Language/PureScript/Errors.hs | 18 +++++++++--------- src/Language/PureScript/Externs.hs | 2 +- src/Language/PureScript/Ide.hs | 2 +- src/Language/PureScript/Ide/Reexports.hs | 2 +- src/Language/PureScript/Linter/Imports.hs | 2 +- src/Language/PureScript/Pretty/Common.hs | 2 +- .../PureScript/Publish/ErrorsWarnings.hs | 2 +- .../PureScript/Sugar/CaseDeclarations.hs | 10 +++++----- src/Language/PureScript/Sugar/Names.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 2 +- .../PureScript/TypeChecker/Entailment.hs | 2 +- tests/purs/passing/Guards.purs | 2 +- 21 files changed, 42 insertions(+), 41 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index d956af5b9c..34b9b2e768 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -138,6 +138,7 @@ If you would prefer to use different terms, please use the section below instead | [@marcosh](https://github.com/marcosh) | Marco Perone | [MIT license](http://opensource.org/licenses/MIT) | | [@matthew-hilty](https://github.com/matthew-hilty) | Matthew Hilty | [MIT license](http://opensource.org/licenses/MIT) | | [@woody88](https://github.com/woody88) | Woodson Delhia | [MIT license](http://opensource.org/licenses/MIT) | +| [@mhmdanas](https://github.com/mhmdanas) | Mohammed Anas | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs index 30e8ae8750..bf08168ee6 100644 --- a/app/Command/Hierarchy.hs +++ b/app/Command/Hierarchy.hs @@ -36,7 +36,7 @@ import qualified Language.PureScript.CST as CST import Language.PureScript.Hierarchy (Graph(..), _unDigraph, _unGraphName, typeClasses) data HierarchyOptions = HierarchyOptions - { _hierachyInput :: FilePath + { _hierarchyInput :: FilePath , _hierarchyOutput :: Maybe FilePath } diff --git a/psc-ide/DESIGN.org b/psc-ide/DESIGN.org index ec63e5d747..30cf3aa1b1 100644 --- a/psc-ide/DESIGN.org +++ b/psc-ide/DESIGN.org @@ -50,7 +50,7 @@ - MonadLogger purs ide uses the =MonadLogger= constraint to defer the choice of logging - to the exeutable. This constraint can be fulfilled with a console based + to the executable. This constraint can be fulfilled with a console based logger, a file-based one or the log messages can just be discarded (helpful during testing) @@ -285,7 +285,7 @@ Language.PureScript.Ide.RebuildSpec) - All data is regenerated on starting ide = no cache invalidation necessary - Things are fast, without any effort spent on optimizing things - Simple model, keeps complexity low -- We don't polute projects with ide artifacts +- We don't pollute projects with ide artifacts *** Cons - Imposes a limit on how big of a project we can handle - Means we need to be careful about what information we denormalize, since it diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index d64bfbc78b..a9981fe1d4 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -107,7 +107,7 @@ The `complete` command looks up possible completions/corrections. The following format is returned as the Result: -Both the `definedAt` aswell as the `documentation` field might be `null` if they +Both the `definedAt` as well as the `documentation` field might be `null` if they couldn't be extracted from a source file. ```json @@ -435,7 +435,7 @@ The list availableModules command returns a list of strings. #### Imports -The list commmand can also list the imports for a given file. +The list command can also list the imports for a given file. ```json { @@ -623,7 +623,7 @@ A filter which allows to filter type declarations. Valid type declarations are ## Matcher: ### Flex matcher -Matches any occurence of the search string with intersections +Matches any occurrence of the search string with intersections The scoring measures how far the matches span the string, where closer is better. The matches then get sorted with highest score first. diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs index 39b38fb54e..12df99ee8f 100644 --- a/src/Language/PureScript/CST/Layout.hs +++ b/src/Language/PureScript/CST/Layout.hs @@ -215,7 +215,7 @@ insertLayout src@(SourceToken tokAnn tok) nextPos stack = state & insertKwProperty (pushStack tokPos LytForall) -- Lambdas need masking because the usage of `->` should not close a - -- LytDeclGaurd or LytCaseGuard context. + -- LytDeclGuard or LytCaseGuard context. TokBackslash -> state & insertDefault & pushStack tokPos LytLambdaBinders @@ -267,7 +267,7 @@ insertLayout src@(SourceToken tokAnn tok) nextPos stack = _ -> state & insertDefault & pushStack tokPos LytTick - -- In gneral, commas should close all indented contexts. + -- In general, commas should close all indented contexts. -- example = [ do foo -- bar, baz ] TokComma -> diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs index 9a843473bb..a656c92df3 100644 --- a/src/Language/PureScript/CoreFn/Meta.hs +++ b/src/Language/PureScript/CoreFn/Meta.hs @@ -38,10 +38,10 @@ data Meta -- data ConstructorType -- | - -- The constructor is for a type with a single construcor + -- The constructor is for a type with a single constructor -- = ProductType -- | - -- The constructor is for a type with multiple construcors + -- The constructor is for a type with multiple constructors -- | SumType deriving (Show, Eq, Ord) diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index 76559af759..d4212ea56f 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -11,7 +11,7 @@ import Language.PureScript.Names -- The CoreFn module representation -- -- The json CoreFn representation does not contain type information. When --- parsing it one gets back `ModuleT () Ann` rathern than `ModuleT Type Ann`, +-- parsing it one gets back `ModuleT () Ann` rather than `ModuleT Type Ann`, -- which is enough for `moduleToJs`. data Module a = Module { moduleSourceSpan :: SourceSpan diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index d9cc71419a..ce528975c8 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -418,7 +418,7 @@ coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines kindOrdering :: Declaration kindOrdering = primKindOf (P.primSubName "Ordering") "Ordering" $ T.unlines - [ "The `Ordering` kind represents the three possibilites of comparing two" + [ "The `Ordering` kind represents the three possibilities of comparing two" , "types of the same kind: `LT` (less than), `EQ` (equal to), and" , "`GT` (greater than)." ] @@ -527,7 +527,7 @@ kindDoc :: Declaration kindDoc = primKindOf (P.primSubName "TypeError") "Doc" $ T.unlines [ "`Doc` is the kind of type-level documents." , "" - , "This kind is used with the `Fail` and `Warn` type clases." + , "This kind is used with the `Fail` and `Warn` type classes." , "Build up a `Doc` with `Text`, `Quote`, `QuoteLabel`, `Beside`, and `Above`." ] diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 2511317e64..08aad2acf9 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -144,10 +144,10 @@ makeTypeClassData -> TypeClassData makeTypeClassData args m s deps tcIsEmpty = TypeClassData args m s deps determinedArgs coveringSets tcIsEmpty where - argumentIndicies = [0 .. length args - 1] + argumentIndices = [0 .. length args - 1] -- each argument determines themselves - identities = (\i -> (i, [i])) <$> argumentIndicies + identities = (\i -> (i, [i])) <$> argumentIndices -- list all the edges in the graph: for each fundep an edge exists for each determiner to each determined contributingDeps = M.fromListWith (++) $ identities ++ do @@ -168,7 +168,7 @@ makeTypeClassData args m s deps tcIsEmpty = TypeClassData args m s deps determin -- find all the arguments that are determined determinedArgs :: S.Set Int - determinedArgs = S.fromList $ filter isFunDepDetermined argumentIndicies + determinedArgs = S.fromList $ filter isFunDepDetermined argumentIndices argFromVertex :: G.Vertex -> Int argFromVertex index = let (_, arg, _) = fromVertex index in arg @@ -205,7 +205,7 @@ data NameKind -- ^ A private value introduced as an artifact of code generation (class instances, class member -- accessors, etc.) | Public - -- ^ A public value for a module member or foreing import declaration + -- ^ A public value for a module member or foreign import declaration | External -- ^ A name for member introduced by foreign import deriving (Show, Eq, Generic) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 19b2ab7fe2..d7c8c3b5ab 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -365,8 +365,8 @@ showSuggestion suggestion = case errorSuggestion suggestion of _ -> "" ansiColor :: (ANSI.ColorIntensity, ANSI.Color) -> String -ansiColor (intesity, color) = - ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground intesity color] +ansiColor (intensity, color) = + ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground intensity color] ansiColorReset :: String ansiColorReset = @@ -391,7 +391,7 @@ colorCodeBox codeColor b = case codeColor of ] --- | Default color intesity and color for code +-- | Default color intensity and color for code defaultCodeColor :: (ANSI.ColorIntensity, ANSI.Color) defaultCodeColor = (ANSI.Dull, ANSI.Yellow) @@ -1279,7 +1279,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl where -- Take the last instance of each "hint category" simplifyHints :: [ErrorMessageHint] -> [ErrorMessageHint] - simplifyHints = reverse . nubBy categoriesEqual . stripRedudantHints simple . reverse + simplifyHints = reverse . nubBy categoriesEqual . stripRedundantHints simple . reverse -- Don't remove hints in the "other" category categoriesEqual :: ErrorMessageHint -> ErrorMessageHint -> Bool @@ -1290,20 +1290,20 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl (c1, c2) -> c1 == c2 -- | See https://github.com/purescript/purescript/issues/1802 - stripRedudantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint] - stripRedudantHints ExprDoesNotHaveType{} = stripFirst isCheckHint + stripRedundantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint] + stripRedundantHints ExprDoesNotHaveType{} = stripFirst isCheckHint where isCheckHint ErrorCheckingType{} = True isCheckHint _ = False - stripRedudantHints TypesDoNotUnify{} = stripFirst isUnifyHint + stripRedundantHints TypesDoNotUnify{} = stripFirst isUnifyHint where isUnifyHint ErrorUnifyingTypes{} = True isUnifyHint _ = False - stripRedudantHints NoInstanceFound{} = stripFirst isSolverHint + stripRedundantHints NoInstanceFound{} = stripFirst isSolverHint where isSolverHint ErrorSolvingConstraint{} = True isSolverHint _ = False - stripRedudantHints _ = id + stripRedundantHints _ = id stripFirst :: (ErrorMessageHint -> Bool) -> [ErrorMessageHint] -> [ErrorMessageHint] stripFirst p (PositionedError pos : hs) = PositionedError pos : stripFirst p hs diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index c27703e719..86647190d3 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -115,7 +115,7 @@ data ExternsDeclaration = , edTypeSynonymArguments :: [(Text, Maybe SourceKind)] , edTypeSynonymType :: SourceType } - -- | A data construtor + -- | A data constructor | EDDataConstructor { edDataCtorName :: ProperName 'ConstructorName , edDataCtorOrigin :: DataDeclType diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 8e6e72246e..210b821acf 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -43,7 +43,7 @@ import System.Directory (getCurrentDirectory, getDirectoryContents, do import System.FilePath ((), normalise) import System.FilePath.Glob (glob) --- | Accepts a Commmand and runs it against psc-ide's State. This is the main +-- | Accepts a Command and runs it against psc-ide's State. This is the main -- entry point for the server. handleCommand :: (Ide m, MonadLogger m, MonadError IdeError m) diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 71c73d4a1d..63602cc22a 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -104,7 +104,7 @@ resolveRef decls ref = case ref of Nothing -> -- If the dataconstructor field inside the TypeRef is Nothing, that -- means that all data constructors are exported, so we need to look - -- those up ourselfes + -- those up ourselves findDtors tn Just dtors -> mapMaybe lookupDtor dtors P.ValueRef _ i -> diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 5396328a85..77a292abd5 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -203,7 +203,7 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do -- Replace explicit type refs with data constructor lists from listing the --- used constructors explicity `T(X, Y, [...])` to `T(..)` for suggestion +-- used constructors explicitly `T(X, Y, [...])` to `T(..)` for suggestion -- message. -- Done everywhere when suggesting a completely new explicit imports list, otherwise -- maintain the existing form. diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 87adc6f3a5..8ced1e3e9e 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -114,7 +114,7 @@ emptyPrinterState :: PrinterState emptyPrinterState = PrinterState { indent = 0 } -- | --- Number of characters per identation level +-- Number of characters per indentation level -- blockIndent :: Int blockIndent = 4 diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 84ec99957d..99fa4178ee 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -159,7 +159,7 @@ displayUserError e = case e of [ "The currently checked out commit seems to have been tagged with " , "more than 1 version, and I don't know which one should be used. " , "Please either delete some of the tags, or create a new commit " - , "to tag the desired verson with." + , "to tag the desired version with." ]) , spacer , para "Tags for the currently checked out commit:" diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index a03457b61a..7326ba96d3 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -60,7 +60,7 @@ desugarGuardedExprs desugarGuardedExprs ss (Case scrut alternatives) | any (not . isTrivialExpr) scrut = do -- in case the scrutinee is non trivial (e.g. not a Var or Literal) - -- we may evaluate the scrutinee more than once when a guard occurrs. + -- we may evaluate the scrutinee more than once when a guard occurs. -- We bind the scrutinee to Vars here to mitigate this case. (scrut', scrut_decls) <- unzip <$> forM scrut (\e -> do scrut_id <- freshIdent' @@ -252,7 +252,7 @@ desugarGuardedExprs ss (Case scrut alternatives) = -- case expressions with a single alternative which have -- a NullBinder occur frequently after desugaring - -- complex guards. This function removes these superflous + -- complex guards. This function removes these superfluous -- cases. optimize :: Expr -> Expr optimize (Case _ [CaseAlternative vb [MkUnguarded v]]) @@ -267,8 +267,8 @@ desugarGuardedExprs ss (Case scrut alternatives) = alts' <- desugarAlternatives alternatives return $ optimize (Case scrut alts') -desugarGuardedExprs ss (TypedValue infered e ty) = - TypedValue infered <$> desugarGuardedExprs ss e <*> pure ty +desugarGuardedExprs ss (TypedValue inferred e ty) = + TypedValue inferred <$> desugarGuardedExprs ss e <*> pure ty desugarGuardedExprs _ (PositionedValue ss comms e) = PositionedValue ss comms <$> desugarGuardedExprs ss e @@ -406,7 +406,7 @@ makeCaseDeclaration ss ident alternatives = do argName _ = freshIdent' -- Combine two lists of potential names from two case alternatives - -- by zipping correspoding columns. + -- by zipping corresponding columns. resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident] resolveNames = zipWith resolveName diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 5aa7cb89d4..0e4eb360e1 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -391,7 +391,7 @@ renameInModule imports (Module modSS coms mn decls exps) = updateKindName = update (importedKinds imports) KiName -- Update names so unqualified references become qualified, and locally - -- qualified references are replaced with their canoncial qualified names + -- qualified references are replaced with their canonical qualified names -- (e.g. M.Map -> Data.Map.Map). update :: (Ord a) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 5064847903..f0e90f7b60 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -431,7 +431,7 @@ typeCheckAll moduleName _ = traverse go -- Check that the instance currently being declared doesn't overlap with any -- other instance in any module that this instance wouldn't be considered an -- orphan in. There are overlapping instance situations that won't be caught - -- by this, for example when combining multiparametr type classes with + -- by this, for example when combining multiparameter type classes with -- flexible instances: the instances `Cls X y` and `Cls x Y` overlap and -- could live in different modules but won't be caught here. checkOverlappingInstance diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 625f038479..e37549962a 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -282,7 +282,7 @@ entails SolverOptions{..} constraint context hints = where -- | When checking functional dependencies, we need to use unification to make -- sure it is safe to use the selected instance. We will unify the solved type with - -- the type in the instance head under the substition inferred from its instantiation. + -- the type in the instance head under the substitution inferred from its instantiation. -- As an example, when solving MonadState t0 (State Int), we choose the -- MonadState s (State s) instance, and we unify t0 with Int, since the functional -- dependency from MonadState dictates that t0 should unify with s\[s -> Int], which is diff --git a/tests/purs/passing/Guards.purs b/tests/purs/passing/Guards.purs index c62c0bd424..8e3a20e233 100644 --- a/tests/purs/passing/Guards.purs +++ b/tests/purs/passing/Guards.purs @@ -47,7 +47,7 @@ clunky2 a b | x <- max a b | otherwise = a + b --- pattern guards on case epxressions +-- pattern guards on case expressions clunky_case1 :: Int -> Int -> Int clunky_case1 a b = case unit of From 281eb3cad88a26865472c4dad37e9aa30c485204 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann <6189397+kritzcreek@users.noreply.github.com> Date: Sun, 8 Mar 2020 10:44:41 +0100 Subject: [PATCH 1188/1580] [purs ide] Tracks the cache-db.json timestamp (#3799) * [purs ide] Tracks the cache-db.json timestamp This allows us to trigger a full reload when someone other than the IDE invoked the compiler * fixes tests * [purs ide] removes editor mode flag and the file watcher The editor mode functionality is the default now, and we're checking the cache-db.json timestamp to invalidate our externs store instead. This means we can get rid of the flaky file watcher * Formats the Ide.Types module into how I'd write Haskell today makes the formatting consistent within this file at least --- app/Command/Ide.hs | 71 +++++--- psc-ide/DESIGN.org | 14 +- psc-ide/README.md | 5 - src/Language/PureScript/Ide/Rebuild.hs | 11 +- src/Language/PureScript/Ide/State.hs | 38 +++- src/Language/PureScript/Ide/Types.hs | 176 +++++++++---------- src/Language/PureScript/Ide/Watcher.hs | 56 ------ src/Language/PureScript/Make/Actions.hs | 1 + tests/Language/PureScript/Ide/RebuildSpec.hs | 5 +- tests/Language/PureScript/Ide/Test.hs | 5 +- 10 files changed, 188 insertions(+), 194 deletions(-) delete mode 100644 src/Language/PureScript/Ide/Watcher.hs diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index 30adccc71b..4c50f5ef16 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -12,13 +12,14 @@ -- The server accepting commands for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} module Command.Ide (command) where @@ -27,6 +28,7 @@ import Protolude import qualified Data.Aeson as Aeson import Control.Concurrent.STM import "monad-logger" Control.Monad.Logger +import Data.IORef import qualified Data.Text.IO as T import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy.Char8 as BSL8 @@ -35,12 +37,11 @@ import Language.PureScript.Ide import Language.PureScript.Ide.Command import Language.PureScript.Ide.Util import Language.PureScript.Ide.Error +import Language.PureScript.Ide.State (updateCacheTimestamp) import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Watcher import qualified Network.Socket as Network import qualified Options.Applicative as Opts import System.Directory -import System.Info as SysInfo import System.FilePath import System.IO hiding (putStrLn, print) import System.IO.Error (isEOFError) @@ -66,10 +67,11 @@ data ServerOptions = ServerOptions , _serverGlobs :: [FilePath] , _serverOutputPath :: FilePath , _serverPort :: Network.PortNumber - , _serverNoWatch :: Bool - , _serverPolling :: Bool , _serverLoglevel :: IdeLogLevel + -- TODO(Christoph) Deprecated , _serverEditorMode :: Bool + , _serverPolling :: Bool + , _serverNoWatch :: Bool } deriving (Show) data ClientOptions = ClientOptions @@ -114,7 +116,7 @@ command = Opts.helper <*> subcommands where Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer)) server :: ServerOptions -> IO () - server opts'@(ServerOptions dir globs outputPath port noWatch polling logLevel editorMode) = do + server opts'@(ServerOptions dir globs outputPath port logLevel editorMode polling noWatch) = do when (logLevel == LogDebug || logLevel == LogAll) (putText "Parsed Options:" *> print opts') maybe (pure ()) setCurrentDirectory dir @@ -122,20 +124,32 @@ command = Opts.helper <*> subcommands where cwd <- getCurrentDirectory let fullOutputPath = cwd outputPath + when editorMode + (putText "The --editor-mode flag is deprecated and ignored. It's now the default behaviour and the flag will be removed in a future version") + + when polling + (putText "The --polling flag is deprecated and ignored. purs ide no longer uses a file system watcher, instead it relies on its clients to notify it about updates and checks timestamps to invalidate itself") + + when noWatch + (putText "The --no-watch flag is deprecated and ignored. purs ide no longer uses a file system watcher, instead it relies on its clients to notify it about updates and checks timestamps to invalidate itself") + unlessM (doesDirectoryExist fullOutputPath) $ do putText "Your output directory didn't exist. This usually means you didn't compile your project yet." putText "psc-ide needs you to compile your project (for example by running pulp build)" - unless (noWatch || editorMode) $ - void (forkFinally (watcher polling logLevel ideState fullOutputPath) print) let conf = IdeConfiguration { confLogLevel = logLevel , confOutputPath = outputPath , confGlobs = globs - , confEditorMode = editorMode } - let env = IdeEnvironment {ideStateVar = ideState, ideConfiguration = conf} + ts <- newIORef Nothing + let + env = IdeEnvironment + { ideStateVar = ideState + , ideConfiguration = conf + , ideCacheDbTimestamp = ts + } startServer port env serverOptions :: Opts.Parser ServerOptions @@ -146,13 +160,14 @@ command = Opts.helper <*> subcommands where <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/") <*> (fromIntegral <$> Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer))) - <*> Opts.switch (Opts.long "no-watch") - <*> flipIfWindows (Opts.switch (Opts.long "polling")) <*> (parseLogLevel <$> Opts.strOption (Opts.long "log-level" `mappend` Opts.value "" `mappend` Opts.help "One of \"debug\", \"perf\", \"all\" or \"none\"")) + -- TODO(Christoph): Deprecated <*> Opts.switch (Opts.long "editor-mode") + <*> Opts.switch (Opts.long "no-watch") + <*> Opts.switch (Opts.long "polling") parseLogLevel :: Text -> IdeLogLevel parseLogLevel s = case s of @@ -162,10 +177,6 @@ command = Opts.helper <*> subcommands where "none" -> LogNone _ -> LogDefault - -- polling is the default on Windows and the flag turns it off. See - -- #2209 and #2414 for explanations - flipIfWindows = map (if SysInfo.os == "mingw32" then not else identity) - startServer :: Network.PortNumber -> IdeEnvironment -> IO () startServer port env = Network.withSocketsDo $ do sock <- listenOnLocalhost port @@ -185,7 +196,16 @@ startServer port env = Network.withSocketsDo $ do <> " took " <> displayTimeSpec duration logPerf message $ do - result <- runExceptT (handleCommand cmd') + result <- runExceptT $ do + updateCacheTimestamp >>= \case + Nothing -> pure () + Just (before, after) -> do + -- If the cache db file was changed outside of the IDE + -- we trigger a reset before processing the command + $(logInfo) ("cachedb was changed from: " <> show before <> ", to: " <> show after) + unless (isLoadAll cmd') $ + void (handleCommand Reset *> handleCommand (LoadSync [])) + handleCommand cmd' liftIO $ catchGoneHandle $ BSL8.hPutStrLn h $ case result of Right r -> Aeson.encode r Left err -> Aeson.encode err @@ -197,11 +217,16 @@ startServer port env = Network.withSocketsDo $ do hFlush stdout liftIO $ catchGoneHandle (hClose h) +isLoadAll :: Command -> Bool +isLoadAll = \case + Load [] -> True + _ -> False + catchGoneHandle :: IO () -> IO () catchGoneHandle = handle (\e -> case e of IOError { ioe_type = ResourceVanished } -> - putText ("[Error] psc-ide-server tried interact with the handle, but the connection was already gone.") + putText ("[Error] psc-ide-server tried to interact with the handle, but the connection was already gone.") _ -> throwIO e) acceptCommand diff --git a/psc-ide/DESIGN.org b/psc-ide/DESIGN.org index 30cf3aa1b1..432d40bcad 100644 --- a/psc-ide/DESIGN.org +++ b/psc-ide/DESIGN.org @@ -15,10 +15,10 @@ =purs ide= is split into a library and an executable. The library code lives inside =src/Language/PureScript/Ide=. The executable, which is invoked by the editors is located inside =app/Command/Ide.hs=. - + The =purs ide= library is unopinionated about: - - Protocol + - Protocol - Concurrency Model - Logging - File watchers @@ -33,7 +33,7 @@ Break down the type signature: =handleCommand :: (Ide m, MonadLogger m, MonadError IdeError m) => Command -> m Success= - + Ide m expands to (MonadReader IdeEnvironment m, MonadIO m) and so we end up with 4 constraints/capabilities handleCommand needs to be provided with by the caller. @@ -48,7 +48,7 @@ gets to decide how to handle them. - MonadLogger - + purs ide uses the =MonadLogger= constraint to defer the choice of logging to the executable. This constraint can be fulfilled with a console based logger, a file-based one or the log messages can just be discarded (helpful @@ -96,7 +96,7 @@ let environment = IdeEnvironment {ideStateVar = stateVar, ideConfiguration = defConfig} -- It's easiest to read the next line inside out: - -- 1. apply =handleCommand= to the command + -- 1. apply =handleCommand= to the command -- 2. Satisfy the MonadReader IdeEnvironment constraint by passing -- =environment= to =runReaderT= @@ -144,7 +144,7 @@ plugins. *** The Query Pipeline - + When fulfilling completion requests or other queries, `ide` runs the stored declarations through the following pipeline: @@ -163,7 +163,7 @@ All the different filters, matchers and completion options are documented in the PROTOCOL.md file. - + *** Filters Filters are functions of type =Map ModuleName [IdeDeclaration] -> Map ModuleName [IdeDeclaration]=. They only ever keep or remove diff --git a/psc-ide/README.md b/psc-ide/README.md index bd05fcdc7c..a97d1a2a71 100644 --- a/psc-ide/README.md +++ b/psc-ide/README.md @@ -23,12 +23,7 @@ It supports the following options: - `--output-directory`: Specify where to look for compiled output inside your project directory. Defaults to `output/`, relative to either the current directory or the directory specified by `-d`. -- `--polling`: Uses polling instead of file system events to watch the externs - files. This flag is reversed on Windows and polling is the default. - `--log-level`: Can be set to one of "all", "none", "debug" and "perf" -- `--no-watch`: Disables the filewatcher -- `--editor-mode`: Rather than watch externs files, expect an editor to report - changed source files. - `--version`: Output psc-ide version ## Issuing queries diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 14ab0f3578..556c003517 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -77,10 +77,10 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do Left errors -> throwError (RebuildError errors) Right newExterns -> do - whenM isEditorMode do - insertModule (fromMaybe file actualFile, m) - insertExterns newExterns - void populateVolatileState + insertModule (fromMaybe file actualFile, m) + insertExterns newExterns + void populateVolatileState + _ <- updateCacheTimestamp runOpenBuild (rebuildModuleOpen makeEnv externs m) pure (RebuildSuccess warnings) @@ -123,9 +123,6 @@ updateCacheDb codegenTargets outputDirectory file actualFile moduleName = do cacheDb <- P.readCacheDb' outputDirectory P.writeCacheDb' outputDirectory (M.insert moduleName (CacheInfo cacheInfo) cacheDb) -isEditorMode :: Ide m => m Bool -isEditorMode = asks (confEditorMode . ideConfiguration) - rebuildFileAsync :: forall m. (Ide m, MonadLogger m, MonadError IdeError m) => FilePath -> Maybe FilePath -> Set P.CodegenTarget -> m Success diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 419b529175..4d3ccaaf31 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -12,10 +12,11 @@ -- Functions to access psc-ide's state ----------------------------------------------------------------------------- -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeApplications #-} module Language.PureScript.Ide.State ( getLoadedModulenames @@ -31,6 +32,8 @@ module Language.PureScript.Ide.State , populateVolatileState , populateVolatileStateSync , populateVolatileStateSTM + , getOutputDirectory + , updateCacheTimestamp -- for tests , resolveOperatorsForModule , resolveInstances @@ -42,16 +45,20 @@ import Protolude hiding (moduleName) import Control.Arrow import Control.Concurrent.STM import "monad-logger" Control.Monad.Logger +import Data.IORef import qualified Data.Map.Lazy as Map +import Data.Time.Clock (UTCTime) import qualified Language.PureScript as P import Language.PureScript.Docs.Convert.Single (convertComments) import Language.PureScript.Externs +import Language.PureScript.Make.Actions (cacheDbFile) import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import Lens.Micro.Platform hiding ((&)) +import System.Directory (getModificationTime) -- | Resets all State inside psc-ide resetIdeState :: Ide m => m () @@ -59,6 +66,31 @@ resetIdeState = do ideVar <- ideStateVar <$> ask liftIO (atomically (writeTVar ideVar emptyIdeState)) +getOutputDirectory :: Ide m => m FilePath +getOutputDirectory = do + confOutputPath . ideConfiguration <$> ask + +getCacheTimestamp :: Ide m => m (Maybe UTCTime) +getCacheTimestamp = do + x <- ideCacheDbTimestamp <$> ask + liftIO (readIORef x) + +readCacheTimestamp :: Ide m => m (Maybe UTCTime) +readCacheTimestamp = do + cacheDb <- cacheDbFile <$> getOutputDirectory + liftIO (hush <$> try @SomeException (getModificationTime cacheDb)) + +updateCacheTimestamp :: Ide m => m (Maybe (Maybe UTCTime, Maybe UTCTime)) +updateCacheTimestamp = do + old <- getCacheTimestamp + new <- readCacheTimestamp + if old == new + then pure Nothing + else do + ts <- ideCacheDbTimestamp <$> ask + liftIO (writeIORef ts new) + pure (Just (old, new)) + -- | Gets the loaded Modulenames getLoadedModulenames :: Ide m => m [P.ModuleName] getLoadedModulenames = Map.keys <$> getExternFiles diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 82cfed9b03..2fb106aad8 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -1,28 +1,17 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Ide.Types --- Description : Type definitions for psc-ide --- Copyright : Christoph Hegemann 2016 --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Christoph Hegemann --- Stability : experimental --- -- | -- Type definitions for psc-ide ------------------------------------------------------------------------------ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE TemplateHaskell #-} +{-# language DeriveGeneric, DeriveAnyClass, DeriveFoldable, TemplateHaskell #-} module Language.PureScript.Ide.Types where import Protolude hiding (moduleName) -import Control.Concurrent.STM -import Data.Aeson +import Control.Concurrent.STM (TVar) +import Data.Aeson (ToJSON, FromJSON, (.=)) +import qualified Data.Aeson as Aeson +import Data.IORef (IORef) +import Data.Time.Clock (UTCTime) import qualified Data.Map.Lazy as M import qualified Language.PureScript as P import qualified Language.PureScript.Errors.JSON as P @@ -45,7 +34,7 @@ data IdeDeclaration data IdeValue = IdeValue { _ideValueIdent :: P.Ident - , _ideValueType :: P.SourceType + , _ideValueType :: P.SourceType } deriving (Show, Eq, Ord, Generic, NFData) data IdeType = IdeType @@ -61,9 +50,9 @@ data IdeTypeSynonym = IdeTypeSynonym } deriving (Show, Eq, Ord, Generic, NFData) data IdeDataConstructor = IdeDataConstructor - { _ideDtorName :: P.ProperName 'P.ConstructorName + { _ideDtorName :: P.ProperName 'P.ConstructorName , _ideDtorTypeName :: P.ProperName 'P.TypeName - , _ideDtorType :: P.SourceType + , _ideDtorType :: P.SourceType } deriving (Show, Eq, Ord, Generic, NFData) data IdeTypeClass = IdeTypeClass @@ -73,26 +62,26 @@ data IdeTypeClass = IdeTypeClass } deriving (Show, Eq, Ord, Generic, NFData) data IdeInstance = IdeInstance - { _ideInstanceModule :: P.ModuleName - , _ideInstanceName :: P.Ident - , _ideInstanceTypes :: [P.SourceType] + { _ideInstanceModule :: P.ModuleName + , _ideInstanceName :: P.Ident + , _ideInstanceTypes :: [P.SourceType] , _ideInstanceConstraints :: Maybe [P.SourceConstraint] } deriving (Show, Eq, Ord, Generic, NFData) data IdeValueOperator = IdeValueOperator - { _ideValueOpName :: P.OpName 'P.ValueOpName - , _ideValueOpAlias :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) - , _ideValueOpPrecedence :: P.Precedence + { _ideValueOpName :: P.OpName 'P.ValueOpName + , _ideValueOpAlias :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) + , _ideValueOpPrecedence :: P.Precedence , _ideValueOpAssociativity :: P.Associativity - , _ideValueOpType :: Maybe P.SourceType + , _ideValueOpType :: Maybe P.SourceType } deriving (Show, Eq, Ord, Generic, NFData) data IdeTypeOperator = IdeTypeOperator - { _ideTypeOpName :: P.OpName 'P.TypeOpName - , _ideTypeOpAlias :: P.Qualified (P.ProperName 'P.TypeName) - , _ideTypeOpPrecedence :: P.Precedence + { _ideTypeOpName :: P.OpName 'P.TypeOpName + , _ideTypeOpAlias :: P.Qualified (P.ProperName 'P.TypeName) + , _ideTypeOpPrecedence :: P.Precedence , _ideTypeOpAssociativity :: P.Associativity - , _ideTypeOpKind :: Maybe P.SourceKind + , _ideTypeOpKind :: Maybe P.SourceKind } deriving (Show, Eq, Ord, Generic, NFData) _IdeDeclValue :: Traversal' IdeDeclaration IdeValue @@ -144,16 +133,16 @@ makeLenses ''IdeValueOperator makeLenses ''IdeTypeOperator data IdeDeclarationAnn = IdeDeclarationAnn - { _idaAnnotation :: Annotation + { _idaAnnotation :: Annotation , _idaDeclaration :: IdeDeclaration } deriving (Show, Eq, Ord, Generic, NFData) data Annotation = Annotation - { _annLocation :: Maybe P.SourceSpan - , _annExportedFrom :: Maybe P.ModuleName + { _annLocation :: Maybe P.SourceSpan + , _annExportedFrom :: Maybe P.ModuleName , _annTypeAnnotation :: Maybe P.SourceType - , _annDocumentation :: Maybe Text + , _annDocumentation :: Maybe Text } deriving (Show, Eq, Ord, Generic, NFData) makeLenses ''Annotation @@ -175,21 +164,21 @@ data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone data IdeConfiguration = IdeConfiguration { confOutputPath :: FilePath - , confLogLevel :: IdeLogLevel - , confGlobs :: [FilePath] - , confEditorMode :: Bool + , confLogLevel :: IdeLogLevel + , confGlobs :: [FilePath] } data IdeEnvironment = IdeEnvironment - { ideStateVar :: TVar IdeState + { ideStateVar :: TVar IdeState , ideConfiguration :: IdeConfiguration + , ideCacheDbTimestamp :: IORef (Maybe UTCTime) } type Ide m = (MonadIO m, MonadReader IdeEnvironment m) data IdeState = IdeState - { ideFileState :: IdeFileState + { ideFileState :: IdeFileState , ideVolatileState :: IdeVolatileState } deriving (Show) @@ -221,8 +210,8 @@ data IdeFileState = IdeFileState -- with open imports which is used to provide completions for module private -- declarations data IdeVolatileState = IdeVolatileState - { vsAstData :: AstData P.SourceSpan - , vsDeclarations :: ModuleMap [IdeDeclarationAnn] + { vsAstData :: AstData P.SourceSpan + , vsDeclarations :: ModuleMap [IdeDeclarationAnn] , vsCachedRebuild :: Maybe (P.ModuleName, P.ExternsFile) } deriving (Show) @@ -231,34 +220,36 @@ newtype Match a = Match (P.ModuleName, a) -- | A completion as it gets sent to the editors data Completion = Completion - { complModule :: Text - , complIdentifier :: Text - , complType :: Text - , complExpandedType :: Text - , complLocation :: Maybe P.SourceSpan + { complModule :: Text + , complIdentifier :: Text + , complType :: Text + , complExpandedType :: Text + , complLocation :: Maybe P.SourceSpan , complDocumentation :: Maybe Text - , complExportedFrom :: [P.ModuleName] + , complExportedFrom :: [P.ModuleName] } deriving (Show, Eq, Ord) instance ToJSON Completion where toJSON (Completion {..}) = - object [ "module" .= complModule - , "identifier" .= complIdentifier - , "type" .= complType - , "expandedType" .= complExpandedType - , "definedAt" .= complLocation - , "documentation" .= complDocumentation - , "exportedFrom" .= map P.runModuleName complExportedFrom - ] + Aeson.object + [ "module" .= complModule + , "identifier" .= complIdentifier + , "type" .= complType + , "expandedType" .= complExpandedType + , "definedAt" .= complLocation + , "documentation" .= complDocumentation + , "exportedFrom" .= map P.runModuleName complExportedFrom + ] identifierFromDeclarationRef :: P.DeclarationRef -> Text -identifierFromDeclarationRef (P.TypeRef _ name _) = P.runProperName name -identifierFromDeclarationRef (P.ValueRef _ ident) = P.runIdent ident -identifierFromDeclarationRef (P.TypeClassRef _ name) = P.runProperName name -identifierFromDeclarationRef (P.KindRef _ name) = P.runProperName name -identifierFromDeclarationRef (P.ValueOpRef _ op) = P.showOp op -identifierFromDeclarationRef (P.TypeOpRef _ op) = P.showOp op -identifierFromDeclarationRef _ = "" +identifierFromDeclarationRef = \case + P.TypeRef _ name _ -> P.runProperName name + P.ValueRef _ ident -> P.runIdent ident + P.TypeClassRef _ name -> P.runProperName name + P.KindRef _ name -> P.runProperName name + P.ValueOpRef _ op -> P.showOp op + P.TypeOpRef _ op -> P.showOp op + _ -> "" data Success = CompletionResult [Completion] @@ -270,44 +261,53 @@ data Success = | RebuildSuccess P.MultipleErrors deriving (Show) -encodeSuccess :: (ToJSON a) => a -> Value +encodeSuccess :: ToJSON a => a -> Aeson.Value encodeSuccess res = - object ["resultType" .= ("success" :: Text), "result" .= res] + Aeson.object ["resultType" .= ("success" :: Text), "result" .= res] instance ToJSON Success where - toJSON (CompletionResult cs) = encodeSuccess cs - toJSON (TextResult t) = encodeSuccess t - toJSON (UsagesResult ssp) = encodeSuccess ssp - toJSON (MultilineTextResult ts) = encodeSuccess ts - toJSON (ImportList (moduleName, imports)) = object [ "resultType" .= ("success" :: Text) - , "result" .= object [ "imports" .= map encodeImport imports - , "moduleName" .= P.runModuleName moduleName]] - toJSON (ModuleList modules) = encodeSuccess modules - toJSON (RebuildSuccess warnings) = encodeSuccess (P.toJSONErrors False P.Warning warnings) - -encodeImport :: (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName) -> Value + toJSON = \case + CompletionResult cs -> encodeSuccess cs + TextResult t -> encodeSuccess t + UsagesResult ssp -> encodeSuccess ssp + MultilineTextResult ts -> encodeSuccess ts + ImportList (moduleName, imports) -> + Aeson.object + [ "resultType" .= ("success" :: Text) + , "result" .= Aeson.object + [ "imports" .= map encodeImport imports + , "moduleName" .= P.runModuleName moduleName + ] + ] + ModuleList modules -> encodeSuccess modules + RebuildSuccess warnings -> encodeSuccess (P.toJSONErrors False P.Warning warnings) + +encodeImport :: (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName) -> Aeson.Value encodeImport (P.runModuleName -> mn, importType, map P.runModuleName -> qualifier) = case importType of P.Implicit -> - object $ [ "module" .= mn - , "importType" .= ("implicit" :: Text) - ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) + Aeson.object $ + [ "module" .= mn + , "importType" .= ("implicit" :: Text) + ] ++ map ("qualifier" .=) (maybeToList qualifier) P.Explicit refs -> - object $ [ "module" .= mn - , "importType" .= ("explicit" :: Text) - , "identifiers" .= (identifierFromDeclarationRef <$> refs) - ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) + Aeson.object $ + [ "module" .= mn + , "importType" .= ("explicit" :: Text) + , "identifiers" .= (identifierFromDeclarationRef <$> refs) + ] ++ map ("qualifier" .=) (maybeToList qualifier) P.Hiding refs -> - object $ [ "module" .= mn - , "importType" .= ("hiding" :: Text) - , "identifiers" .= (identifierFromDeclarationRef <$> refs) - ] ++ map (\x -> "qualifier" .= x) (maybeToList qualifier) + Aeson.object $ + [ "module" .= mn + , "importType" .= ("hiding" :: Text) + , "identifiers" .= (identifierFromDeclarationRef <$> refs) + ] ++ map ("qualifier" .=) (maybeToList qualifier) -- | Denotes the different namespaces a name in PureScript can reside in. data IdeNamespace = IdeNSValue | IdeNSType | IdeNSKind | IdeNSModule deriving (Show, Eq, Ord, Generic, NFData) instance FromJSON IdeNamespace where - parseJSON (String s) = case s of + parseJSON (Aeson.String s) = case s of "value" -> pure IdeNSValue "type" -> pure IdeNSType "kind" -> pure IdeNSKind diff --git a/src/Language/PureScript/Ide/Watcher.hs b/src/Language/PureScript/Ide/Watcher.hs deleted file mode 100644 index 9d42ef9e38..0000000000 --- a/src/Language/PureScript/Ide/Watcher.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE PackageImports #-} ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Ide.Watcher --- Description : File watcher for externs files --- Copyright : Christoph Hegemann 2016 --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Christoph Hegemann --- Stability : experimental --- --- | --- File watcher for externs files ------------------------------------------------------------------------------ - -module Language.PureScript.Ide.Watcher - ( watcher - ) where - -import Protolude - -import Control.Concurrent.STM -import "monad-logger" Control.Monad.Logger -import Language.PureScript.Ide.Externs -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util -import System.FSNotify -import System.FilePath - --- | Reloads an ExternsFile from Disc. If the Event indicates the ExternsFile --- was deleted we don't do anything. -reloadFile :: IdeLogLevel -> TVar IdeState -> Event -> IO () -reloadFile _ _ Removed{} = pure () -reloadFile logLevel ref ev = runLogger logLevel $ do - let fp = eventPath ev - ef' <- runExceptT (readExternFile fp) - case ef' of - Left err -> - logErrorN ("Failed to reload file at: " <> toS fp <> " with error: " <> show err) - Right ef -> do - lift $ void $ atomically (insertExternsSTM ref ef *> populateVolatileStateSTM ref) - logDebugN ("Reloaded File at: " <> toS fp) - --- | Installs filewatchers for the given directory and reloads ExternsFiles when --- they change on disc -watcher :: Bool -> IdeLogLevel -> TVar IdeState -> FilePath -> IO () -watcher polling logLevel stateVar fp = - withManagerConf - (defaultConfig { confDebounce = NoDebounce - , confUsePolling = polling - }) $ \mgr -> do - _ <- watchTree mgr fp - (\ev -> takeFileName (eventPath ev) == "externs.json") - (reloadFile logLevel stateVar) - forever (threadDelay 100000) diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index d2a1774f45..678643aec4 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -4,6 +4,7 @@ module Language.PureScript.Make.Actions , ProgressMessage(..) , buildMakeActions , checkForeignDecls + , cacheDbFile , readCacheDb' , writeCacheDb' ) where diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index 0aea8e2a83..f7f1d827cb 100644 --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -67,11 +67,10 @@ spec = describe "Rebuilding single modules" $ do Test.runIde [ rebuildSync "RebuildSpecWithHiddenIdent.purs" , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent")) defaultCompletionOptions] complIdentifier result `shouldBe` "hidden" - it "uses the specified `actualFile` for location information (in editor mode)" $ do - let editorConfig = Test.defConfig { confEditorMode = True } + it "uses the specified `actualFile` for location information" $ do ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ Test.runIde' - editorConfig + Test.defConfig emptyIdeState [ RebuildSync ("src" "RebuildSpecWithHiddenIdent.purs") (Just "actualFile") defaultTarget , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent")) defaultCompletionOptions] diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index 6164e02722..c0db826c89 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -6,6 +6,7 @@ module Language.PureScript.Ide.Test where import Control.Concurrent.STM import "monad-logger" Control.Monad.Logger +import Data.IORef import qualified Data.Map as Map import Language.PureScript.Ide import Language.PureScript.Ide.Command @@ -24,13 +25,13 @@ defConfig = { confLogLevel = LogNone , confOutputPath = "output/" , confGlobs = ["src/**/*.purs"] - , confEditorMode = False } runIde' :: IdeConfiguration -> IdeState -> [Command] -> IO ([Either IdeError Success], IdeState) runIde' conf s cs = do stateVar <- newTVarIO s - let env' = IdeEnvironment {ideStateVar = stateVar, ideConfiguration = conf} + ts <- newIORef Nothing + let env' = IdeEnvironment {ideStateVar = stateVar, ideConfiguration = conf, ideCacheDbTimestamp = ts} r <- runNoLoggingT (runReaderT (traverse (runExceptT . handleCommand) cs) env') newState <- readTVarIO stateVar pure (r, newState) From 183fc22549011804d973e01654e354b728f2bc70 Mon Sep 17 00:00:00 2001 From: Hardy Jones Date: Wed, 11 Mar 2020 17:40:10 -0700 Subject: [PATCH 1189/1580] Split into packages (#3793) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Move `SimpleErrorMessage` to `Errors` In 4828b5d3fa078361e03dd0f3dbbfa46dd4ee6b20, we moved `Language.PureScript.Errors.SimpleErrorMessage` to `Language.PureScript.AST.Declarations`. Per the comment in the Pull Request: https://github.com/purescript/purescript/pull/2230#issuecomment-233145477, we did this because we wanted to move `Language.PureScript.Errors.ErrorMessageHint` into `Language.PureScript.AST.Declarations.Expr`. Thing is, we didn't have to move everything just to move `Language.PureScript.Errors.ErrorMessageHint`. In fact, by making this move, we forced the AST to require knowledge about every type of error that can be created. For example, the AST has to know about parse errors (something that should happen before creating an AST) and code generation errors (something that should happen after creating an AST). In an ideal world, the AST would only know about errors that come about from modifications to the AST itself. The real issue that this led to was that the AST had to know about the errors that came about from the CST. Given that the CST is the surface syntax of the AST, that requirement seems a bit off. With the dependencies inverted this way, it's hard to decouple the AST from the CST. We take a step towards the ideal world by moving `Language.PureScript.AST.Declarations.SimpleErrorMessage` back into `Language.PureScript.Errors`. This should allow us to extract the AST from the `purescript` package itself such that it can be built upon in isolation from the rest of the package. We should revisit why `Language.PureScript.AST.Declarations.SimpleErrorMessage` is so massive in the future. It will probably make sense to separate the data type into the different categories of errors so those errors can live closer to where they should be constructed. * Split the constants based on Prim and Prelude Prim stuff is part of PureScript the language, Prelude is part of the PureScript conventions. PureScript the language doesn't require an existence of Prelude in order to work properly. Instead of mixing these two levels, we separate the constants so we can pull the Prim constants out with the AST. In order to not break everything, we re-export the constants from the original module. We should put a timer on this and remove the re-exports after that point so we don't wind up with a bunch of cruft like the other re-export modules. * Extract AST to its own package We've gone quite a ways with a sinle package for everything PureScript related. This has led to incredibly long compile times if you want to consume PureScript the library, as you have to compile everything no matter how much you want to really use. To help with downstream consumers, we start splitting into packages of useful functionality. We start with the AST as this _should_ be the very basis of everything PureScript related. From the AST, someone ought to be able to build packages atop it that add more functionality to the PureScript language. For instance, we can split out the CST as a package that builds atop the AST and adds more functionality (namely, parsing). It's maybe a little disheartening that there don't appear to be any tests around the AST. Maybe with things separated out a bit more, it'll be more inviting to write some tests. The modules we move here might not be all that intuitive, but they seem to be the core of what the PureScript AST is all about. The only questionable modules are the `Control.Monad.Supply` and `Control.Monad.Supply.Class` modules. We could flip the dependency in `Language.PureScript.Names` and move those values into the `Control.Monad.Supply.Class` module. It's unclear which way to go. Since the `Control.Monad.Supply.Class` module isn't in the `Language.PureScript` hierarchy, it might make sense for it to stay in the top-level. However, it might be too general for that and should ideally live in its own package (maybe even outside the project?). We also use PackageImports judiciously. When trying to figure out which dependencies went where, it was much harder than it should have been to figure this stuff out. When trying to figure out which dependencies were used and necessary, it was even harder to figure what the situation was. Finally, when trying to figure out where `Control.Monad.Supply.Class` came from, it took a frustratingly long amount of time to realize it was a module we had defined in the project. For all of these reasons, we use PackageImports to help future us know which dependencies are used, and where. Of course there are tools like weeder (https://github.com/ndmitchell/weeder) to help with finding unused dependencies and whatnot. But, it's also good to know statically what is being used and to allow other tools to be used. Finally, we update the license-generator to work with this split off package. We might have to do more work before we're done, but we can at least generate the license file in a similar manner to how we do at the top-level. * Extract the CST to a package We extract out the CST to its own package that builds atop the AST. This should make it a bit easier to build other tooling atop the CST. In particular, anything that might need to parse PureScript files can now depend on this package to do so. Since this new package only depends on `purescript-ast` (and its transitive dependencies), it can be built in a reasonable amount of time. It's important to note that we don't pull out `Language.PureScript.CST`. That module is straddling the line between a re-exporting "prelude" and an adapter between `purescript-ast` and `purescript`. Since it deals with errors, and errors currently exist at the top-level, we cannot yet move this module down into `purescript-cst`. Probably what needs to happen is that we make a split between `Language.PureScript.CST` being a re-exporter and `Language.PureScript.CST` doing adapter work. Not clear which way to go on this one as both seem viable avenues. It's really great to see a test suite around some of this deep down functionality. Maybe we can use this example to feed back into the AST and make a test suite there. * Move sensible extensions into `default-extensions` Per review, we want our extension strategy to be that we have a uniform language across the codebase with the exception of questionable extensions like `TemplateHaskell`. We move as many sensible extensions to the `default-extensions` field in `package.yaml` so we start building up our uniform language. There are three other extensions we don't move at the moment: `CPP`, `DeriveAnyClass`, and `ImplicitParams`. * `CPP` - This extension is just as questionable (if not more so) as `TemplateHaskell`. Following a similar reasoning, we force people to turn it on explicitly. It's only used in the `Language.PureScript.Crash` module. That module might be better off if we stopped casing on the compiler version. It doesn't seem like we support older versions of GHC anymore, so we might be better off dumping the extension outright. * `DeriveAnyClass` - This extension is known to interact weirdly with `GeneralizedNewtypeDeriving`: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies. Since we use `GeneralizedNewtypeDeriving` in more places, and `DerivingStrategies` exists to address the issues with `DeriveAnyClass`, we don't turn this on across the entire codebase. * `ImplicitParams` - Similar to `CPP`, this extension is only used in the `Language.PureScript.Crash` module. And similarly, if we don't support older versions of GHC, we can drop this extension outright. If any of this is the wrong decision, we can always change it. * Move sensible extensions to `default-extensions` Similar to the motivation behind moving `purescript-ast`s extensions to the `default-extensions` field of its `package.yaml`, we follow suit and move the sensible extensions to `purescript-cst`s `default-extensions` field of its `package.yaml`. We ended up dropping `MonoLocalBinds`, as the module compiles without the extension. * Only generate license for `purescript` package The license generator exists for the sake of distributing the licenses that the `purescript` binary uses. We don't need to use the generator for the other packages. We want the other packages to have a normal license file. We also roll back the changes to the `Makefile`. * Move `purescript-ast` to version 0.1.0.0 Per review, this seems like a way to go that should foster each package being able to evolve in a way that isn't hindered by the rest of the packages at large. * Move `purescript-cst` to version 0.1.0.0 Per review, this seems like a way to go that should foster each package being able to evolve in a way that isn't hindered by the rest of the packages at large. * Remove re-export compatibility module We only kept `Language.PureScript.Constants` around so we could figure out the changes while we were splitting out `purescript-ast`. Now that things have settled down a bit, we remove the module and use the other imports directly. * Setup sdists for each package Now that we have more than one package, we have to do things a little different. `stack sdist` will create an sdist for each package. This means we end up with a directory that looks like: ```console $ tree sdist-test sdist-test ├── purescript-0.13.6.tar.gz ├── purescript-ast-0.1.0.0.tar.gz └── purescript-cst-0.1.0.0.tar.gz 0 directories, 3 files ``` If we try to use `tar -xzf sdist-test/purescript-*.tar.gz -C sdist-test --strip-components=1`, the glob will expand to all three sdists and fail with a cryptic error: ```console $ tar -xzf sdist-test/purescript-0.13.6.tar.gz sdist-test/purescript-ast-0.1.0.0.tar.gz sdist-test/purescript-cst-0.1.0.0.tar.gz -C sdist-test --strip-components=1 tar: sdist-test/purescript-ast-0.1.0.0.tar.gz: Not found in archive tar: sdist-test/purescript-cst-0.1.0.0.tar.gz: Not found in archive tar: Exiting with failure status due to previous errors ``` We change to mirroring the directory structure within the `sdist-test` directory, and running that way. It's a bit unfortunate that the top-level package has to be handled differently, but this should help us move forward. --- Makefile | 3 +- ci/build.sh | 6 +- lib/purescript-ast/.gitignore | 1 + lib/purescript-ast/LICENSE | 13 ++ lib/purescript-ast/README.md | 11 ++ lib/purescript-ast/Setup.hs | 6 + lib/purescript-ast/package.yaml | 66 +++++++ .../src}/Control/Monad/Supply.hs | 16 +- .../src}/Control/Monad/Supply/Class.hs | 13 +- .../src/Language/PureScript/AST.hs | 14 ++ .../src}/Language/PureScript/AST/Binders.hs | 12 +- .../Language/PureScript/AST/Declarations.hs | 181 +++--------------- .../src}/Language/PureScript/AST/Exported.hs | 16 +- .../src}/Language/PureScript/AST/Literals.hs | 4 +- .../src}/Language/PureScript/AST/Operators.hs | 13 +- .../src}/Language/PureScript/AST/SourcePos.hs | 19 +- .../Language/PureScript/AST/Traversals.hs | 38 ++-- .../src}/Language/PureScript/Comments.hs | 11 +- .../src/Language/PureScript/Constants/Prim.hs | 162 ++++++++++++++++ .../src}/Language/PureScript/Crash.hs | 6 +- .../src}/Language/PureScript/Environment.hs | 52 +++-- .../src}/Language/PureScript/Kinds.hs | 28 ++- .../src}/Language/PureScript/Label.hs | 17 +- .../src}/Language/PureScript/Names.hs | 21 +- .../src}/Language/PureScript/PSString.hs | 48 +++-- .../src}/Language/PureScript/Roles.hs | 11 +- .../src}/Language/PureScript/Traversals.hs | 2 +- .../PureScript/TypeClassDictionaries.hs | 15 +- .../src}/Language/PureScript/Types.hs | 57 +++--- lib/purescript-cst/.gitignore | 1 + lib/purescript-cst/LICENSE | 13 ++ lib/purescript-cst/README.md | 11 ++ lib/purescript-cst/Setup.hs | 6 + lib/purescript-cst/package.yaml | 80 ++++++++ .../src}/Language/PureScript/CST/Convert.hs | 38 ++-- .../src}/Language/PureScript/CST/Errors.hs | 15 +- .../src}/Language/PureScript/CST/Layout.hs | 12 +- .../src}/Language/PureScript/CST/Lexer.hs | 33 ++-- .../src}/Language/PureScript/CST/Monad.hs | 20 +- .../src}/Language/PureScript/CST/Parser.y | 32 ++-- .../src}/Language/PureScript/CST/Positions.hs | 17 +- .../src}/Language/PureScript/CST/Print.hs | 8 +- .../Language/PureScript/CST/Traversals.hs | 4 +- .../PureScript/CST/Traversals/Type.hs | 6 +- .../src}/Language/PureScript/CST/Types.hs | 14 +- .../src}/Language/PureScript/CST/Utils.hs | 37 ++-- lib/purescript-cst/tests/Main.hs | 28 +++ .../purescript-cst/tests}/TestCst.hs | 37 ++-- .../tests}/purs/layout/.gitattributes | 0 .../tests}/purs/layout/AdoIn.out | 0 .../tests}/purs/layout/AdoIn.purs | 0 .../tests}/purs/layout/CaseGuards.out | 0 .../tests}/purs/layout/CaseGuards.purs | 0 .../tests}/purs/layout/CaseWhere.out | 0 .../tests}/purs/layout/CaseWhere.purs | 0 .../tests}/purs/layout/ClassHead.out | 0 .../tests}/purs/layout/ClassHead.purs | 0 .../tests}/purs/layout/Commas.out | 0 .../tests}/purs/layout/Commas.purs | 0 .../tests}/purs/layout/Delimiter.out | 0 .../tests}/purs/layout/Delimiter.purs | 0 .../tests}/purs/layout/DoLet.out | 0 .../tests}/purs/layout/DoLet.purs | 0 .../tests}/purs/layout/DoOperator.out | 0 .../tests}/purs/layout/DoOperator.purs | 0 .../tests}/purs/layout/DoWhere.out | 0 .../tests}/purs/layout/DoWhere.purs | 0 .../tests}/purs/layout/IfThenElseDo.out | 0 .../tests}/purs/layout/IfThenElseDo.purs | 0 .../tests}/purs/layout/InstanceChainElse.out | 0 .../tests}/purs/layout/InstanceChainElse.purs | 0 .../tests}/purs/layout/LetGuards.out | 0 .../tests}/purs/layout/LetGuards.purs | 0 license-generator/generate.hs | 6 +- package.yaml | 4 +- src/Language/PureScript/AST.hs | 14 -- src/Language/PureScript/CodeGen/JS.hs | 2 +- .../{Constants.hs => Constants/Prelude.hs} | 157 +-------------- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- src/Language/PureScript/CoreFn/Optimizer.hs | 2 +- .../PureScript/CoreImp/Optimizer/Inliner.hs | 3 +- .../PureScript/CoreImp/Optimizer/MagicDo.hs | 2 +- .../PureScript/CoreImp/Optimizer/TCO.hs | 2 +- .../PureScript/CoreImp/Optimizer/Unused.hs | 2 +- src/Language/PureScript/Errors.hs | 125 +++++++++++- src/Language/PureScript/Ide/Imports.hs | 2 +- src/Language/PureScript/Ide/Prim.hs | 2 +- src/Language/PureScript/Interactive.hs | 2 +- src/Language/PureScript/Linter/Exhaustive.hs | 2 +- src/Language/PureScript/Linter/Imports.hs | 2 +- src/Language/PureScript/Make/Monad.hs | 1 - src/Language/PureScript/ModuleDependencies.hs | 2 +- src/Language/PureScript/Sugar/AdoNotation.hs | 2 +- src/Language/PureScript/Sugar/DoNotation.hs | 2 +- src/Language/PureScript/Sugar/Names/Env.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 3 +- .../PureScript/TypeChecker/Entailment.hs | 3 +- stack.yaml | 2 + tests/Main.hs | 5 +- 101 files changed, 917 insertions(+), 714 deletions(-) create mode 100644 lib/purescript-ast/.gitignore create mode 100644 lib/purescript-ast/LICENSE create mode 100644 lib/purescript-ast/README.md create mode 100644 lib/purescript-ast/Setup.hs create mode 100644 lib/purescript-ast/package.yaml rename {src => lib/purescript-ast/src}/Control/Monad/Supply.hs (71%) rename {src => lib/purescript-ast/src}/Control/Monad/Supply/Class.hs (77%) create mode 100644 lib/purescript-ast/src/Language/PureScript/AST.hs rename {src => lib/purescript-ast/src}/Language/PureScript/AST/Binders.hs (96%) rename {src => lib/purescript-ast/src}/Language/PureScript/AST/Declarations.hs (80%) rename {src => lib/purescript-ast/src}/Language/PureScript/AST/Exported.hs (94%) rename {src => lib/purescript-ast/src}/Language/PureScript/AST/Literals.hs (87%) rename {src => lib/purescript-ast/src}/Language/PureScript/AST/Operators.hs (82%) rename {src => lib/purescript-ast/src}/Language/PureScript/AST/SourcePos.hs (89%) rename {src => lib/purescript-ast/src}/Language/PureScript/AST/Traversals.hs (97%) rename {src => lib/purescript-ast/src}/Language/PureScript/Comments.hs (65%) create mode 100644 lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs rename {src => lib/purescript-ast/src}/Language/PureScript/Crash.hs (86%) rename {src => lib/purescript-ast/src}/Language/PureScript/Environment.hs (96%) rename {src => lib/purescript-ast/src}/Language/PureScript/Kinds.hs (90%) rename {src => lib/purescript-ast/src}/Language/PureScript/Label.hs (54%) rename {src => lib/purescript-ast/src}/Language/PureScript/Names.hs (94%) rename {src => lib/purescript-ast/src}/Language/PureScript/PSString.hs (88%) rename {src => lib/purescript-ast/src}/Language/PureScript/Roles.hs (75%) rename {src => lib/purescript-ast/src}/Language/PureScript/Traversals.hs (93%) rename {src => lib/purescript-ast/src}/Language/PureScript/TypeClassDictionaries.hs (82%) rename {src => lib/purescript-ast/src}/Language/PureScript/Types.hs (96%) create mode 100644 lib/purescript-cst/.gitignore create mode 100644 lib/purescript-cst/LICENSE create mode 100644 lib/purescript-cst/README.md create mode 100644 lib/purescript-cst/Setup.hs create mode 100644 lib/purescript-cst/package.yaml rename {src => lib/purescript-cst/src}/Language/PureScript/CST/Convert.hs (96%) rename {src => lib/purescript-cst/src}/Language/PureScript/CST/Errors.hs (94%) rename {src => lib/purescript-cst/src}/Language/PureScript/CST/Layout.hs (98%) rename {src => lib/purescript-cst/src}/Language/PureScript/CST/Lexer.hs (96%) rename {src => lib/purescript-cst/src}/Language/PureScript/CST/Monad.hs (93%) rename {src => lib/purescript-cst/src}/Language/PureScript/CST/Parser.y (97%) rename {src => lib/purescript-cst/src}/Language/PureScript/CST/Positions.hs (97%) rename {src => lib/purescript-cst/src}/Language/PureScript/CST/Print.hs (94%) rename {src => lib/purescript-cst/src}/Language/PureScript/CST/Traversals.hs (78%) rename {src => lib/purescript-cst/src}/Language/PureScript/CST/Traversals/Type.hs (92%) rename {src => lib/purescript-cst/src}/Language/PureScript/CST/Types.hs (98%) rename {src => lib/purescript-cst/src}/Language/PureScript/CST/Utils.hs (93%) create mode 100644 lib/purescript-cst/tests/Main.hs rename {tests => lib/purescript-cst/tests}/TestCst.hs (87%) rename {tests => lib/purescript-cst/tests}/purs/layout/.gitattributes (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/AdoIn.out (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/AdoIn.purs (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/CaseGuards.out (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/CaseGuards.purs (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/CaseWhere.out (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/CaseWhere.purs (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/ClassHead.out (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/ClassHead.purs (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/Commas.out (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/Commas.purs (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/Delimiter.out (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/Delimiter.purs (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/DoLet.out (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/DoLet.purs (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/DoOperator.out (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/DoOperator.purs (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/DoWhere.out (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/DoWhere.purs (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/IfThenElseDo.out (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/IfThenElseDo.purs (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/InstanceChainElse.out (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/InstanceChainElse.purs (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/LetGuards.out (100%) rename {tests => lib/purescript-cst/tests}/purs/layout/LetGuards.purs (100%) delete mode 100644 src/Language/PureScript/AST.hs rename src/Language/PureScript/{Constants.hs => Constants/Prelude.hs} (68%) diff --git a/Makefile b/Makefile index 43da7cc048..2502363910 100644 --- a/Makefile +++ b/Makefile @@ -57,7 +57,6 @@ dev-deps: ## Install helpful development tools. stack install ghcid ghc-prof-aeson-flamegraph license-generator: ## Update dependencies in LICENSE - $(stack) ls dependencies --flag purescript:RELEASE | stack license-generator/generate.hs > LICENSE - + $(stack) ls dependencies purescript --flag purescript:RELEASE | stack license-generator/generate.hs > LICENSE .PHONY : build build-dirty run install ghci test test-ghci test-profiling ghcid dev-deps license-generator diff --git a/ci/build.sh b/ci/build.sh index c6695b3c98..85b326a095 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -34,7 +34,11 @@ fi $STACK build --only-snapshot $STACK_OPTS # Test in a source distribution (see above) -$STACK sdist --tar-dir sdist-test; +$STACK sdist lib/purescript-ast --tar-dir sdist-test/lib/purescript-ast +tar -xzf sdist-test/lib/purescript-ast/purescript-ast-*.tar.gz -C sdist-test/lib/purescript-ast --strip-components=1 +$STACK sdist lib/purescript-cst --tar-dir sdist-test/lib/purescript-cst +tar -xzf sdist-test/lib/purescript-cst/purescript-cst-*.tar.gz -C sdist-test/lib/purescript-cst --strip-components=1 +$STACK sdist . --tar-dir sdist-test; tar -xzf sdist-test/purescript-*.tar.gz -C sdist-test --strip-components=1 pushd sdist-test $STACK build --pedantic $STACK_OPTS diff --git a/lib/purescript-ast/.gitignore b/lib/purescript-ast/.gitignore new file mode 100644 index 0000000000..e0c0575d9f --- /dev/null +++ b/lib/purescript-ast/.gitignore @@ -0,0 +1 @@ +purescript-ast.cabal diff --git a/lib/purescript-ast/LICENSE b/lib/purescript-ast/LICENSE new file mode 100644 index 0000000000..7904c3e262 --- /dev/null +++ b/lib/purescript-ast/LICENSE @@ -0,0 +1,13 @@ +Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other +contributors +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/lib/purescript-ast/README.md b/lib/purescript-ast/README.md new file mode 100644 index 0000000000..dd8b6fe610 --- /dev/null +++ b/lib/purescript-ast/README.md @@ -0,0 +1,11 @@ +# purescript-ast + +Defines the underlying syntax of the PureScript Programming Language. + +## Compiler compatibility + +We provide a table to make it a bit easier to map between versions of `purescript` and `purescript-ast`. + +| `purescript` | `purescript-ast` | +| --- | --- | +| `0.13.6` | `0.1.0.0` | diff --git a/lib/purescript-ast/Setup.hs b/lib/purescript-ast/Setup.hs new file mode 100644 index 0000000000..cd7b151a59 --- /dev/null +++ b/lib/purescript-ast/Setup.hs @@ -0,0 +1,6 @@ +module Main where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/lib/purescript-ast/package.yaml b/lib/purescript-ast/package.yaml new file mode 100644 index 0000000000..1373f58e27 --- /dev/null +++ b/lib/purescript-ast/package.yaml @@ -0,0 +1,66 @@ +name: purescript-ast +version: '0.1.0.0' +synopsis: PureScript Programming Language Abstract Syntax Tree +description: Defines the underlying syntax of the PureScript Programming Language. +category: Language +author: Phil Freeman +maintainer: > + Gary Burgess , + Hardy Jones , + Harry Garrood , + Christoph Hegemann , + Liam Goodacre , + Nathan Faubion +copyright: (c) 2013-17 Phil Freeman, (c) 2014-19 Gary Burgess, (c) other contributors (see CONTRIBUTORS.md) +license: BSD3 +github: purescript/purescript +homepage: http://www.purescript.org/ +extra-source-files: + - README.md +dependencies: + - aeson >=1.0 && <1.5 + - base >=4.11 && <4.13 + - base-compat >=0.6.0 + - bytestring + - containers + - deepseq + - filepath + - microlens-platform >=0.3.9.0 && <0.4 + - mtl >=2.1.0 && <2.3.0 + - protolude >=0.1.6 && <0.2.4 + - scientific >=0.3.4.9 && <0.4 + - text + - vector + +library: + source-dirs: src + ghc-options: -Wall -O2 + default-extensions: + - ConstraintKinds + - DataKinds + - DefaultSignatures + - DeriveFunctor + - DeriveFoldable + - DeriveTraversable + - DeriveGeneric + - DerivingStrategies + - EmptyDataDecls + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - KindSignatures + - LambdaCase + - MultiParamTypeClasses + - NoImplicitPrelude + - PackageImports + - PatternGuards + - PatternSynonyms + - RankNTypes + - RecordWildCards + - OverloadedStrings + - ScopedTypeVariables + - TupleSections + - TypeFamilies + - ViewPatterns + +stability: experimental diff --git a/src/Control/Monad/Supply.hs b/lib/purescript-ast/src/Control/Monad/Supply.hs similarity index 71% rename from src/Control/Monad/Supply.hs rename to lib/purescript-ast/src/Control/Monad/Supply.hs index 49df7d4fb7..66ab8a372b 100644 --- a/src/Control/Monad/Supply.hs +++ b/lib/purescript-ast/src/Control/Monad/Supply.hs @@ -1,19 +1,17 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- | -- Fresh variable supply -- module Control.Monad.Supply where -import Prelude.Compat +import "base-compat" Prelude.Compat -import Control.Applicative -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer +import "base" Control.Applicative +import "mtl" Control.Monad.Error.Class (MonadError(..)) +import "mtl" Control.Monad.Reader +import "mtl" Control.Monad.State +import "mtl" Control.Monad.Writer -import Data.Functor.Identity +import "base" Data.Functor.Identity newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus) diff --git a/src/Control/Monad/Supply/Class.hs b/lib/purescript-ast/src/Control/Monad/Supply/Class.hs similarity index 77% rename from src/Control/Monad/Supply/Class.hs rename to lib/purescript-ast/src/Control/Monad/Supply/Class.hs index 64038a6aac..43b01fca1b 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/lib/purescript-ast/src/Control/Monad/Supply/Class.hs @@ -2,17 +2,14 @@ -- A class for monads supporting a supply of fresh names -- -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeFamilies #-} - module Control.Monad.Supply.Class where -import Prelude.Compat +import "base-compat" Prelude.Compat -import Control.Monad.Supply -import Control.Monad.State -import Control.Monad.Writer -import Data.Text (Text, pack) +import "this" Control.Monad.Supply +import "mtl" Control.Monad.State +import "mtl" Control.Monad.Writer +import "text" Data.Text (Text, pack) class Monad m => MonadSupply m where fresh :: m Integer diff --git a/lib/purescript-ast/src/Language/PureScript/AST.hs b/lib/purescript-ast/src/Language/PureScript/AST.hs new file mode 100644 index 0000000000..b912f98cde --- /dev/null +++ b/lib/purescript-ast/src/Language/PureScript/AST.hs @@ -0,0 +1,14 @@ +-- | +-- The initial PureScript AST +-- +module Language.PureScript.AST ( + module AST +) where + +import "this" Language.PureScript.AST.Binders as AST +import "this" Language.PureScript.AST.Declarations as AST +import "this" Language.PureScript.AST.Exported as AST +import "this" Language.PureScript.AST.Literals as AST +import "this" Language.PureScript.AST.Operators as AST +import "this" Language.PureScript.AST.SourcePos as AST +import "this" Language.PureScript.AST.Traversals as AST diff --git a/src/Language/PureScript/AST/Binders.hs b/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs similarity index 96% rename from src/Language/PureScript/AST/Binders.hs rename to lib/purescript-ast/src/Language/PureScript/AST/Binders.hs index 528ffb0987..6518b646e3 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs @@ -3,13 +3,13 @@ -- module Language.PureScript.AST.Binders where -import Prelude.Compat +import "base-compat" Prelude.Compat -import Language.PureScript.AST.SourcePos -import Language.PureScript.AST.Literals -import Language.PureScript.Names -import Language.PureScript.Comments -import Language.PureScript.Types +import "this" Language.PureScript.AST.SourcePos +import "this" Language.PureScript.AST.Literals +import "this" Language.PureScript.Names +import "this" Language.PureScript.Comments +import "this" Language.PureScript.Types -- | -- Data type for binders diff --git a/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs similarity index 80% rename from src/Language/PureScript/AST/Declarations.hs rename to lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs index eeb4c1b016..817132bc02 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs @@ -1,44 +1,36 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} -- | -- Data types for modules and declarations -- module Language.PureScript.AST.Declarations where -import Prelude.Compat - -import Control.DeepSeq (NFData) -import Control.Monad.Identity - -import Data.Aeson.TH -import qualified Data.Map as M -import Data.Set (Set) -import Data.Text (Text) -import qualified Data.List.NonEmpty as NEL -import GHC.Generics (Generic) - -import Language.PureScript.AST.Binders -import Language.PureScript.AST.Literals -import Language.PureScript.AST.Operators -import Language.PureScript.AST.SourcePos -import Language.PureScript.Types -import Language.PureScript.PSString (PSString) -import Language.PureScript.Label (Label) -import Language.PureScript.Names -import Language.PureScript.Kinds -import Language.PureScript.Roles -import Language.PureScript.TypeClassDictionaries -import Language.PureScript.Comments -import Language.PureScript.Environment -import qualified Language.PureScript.Bundle as Bundle -import qualified Language.PureScript.Constants as C -import qualified Language.PureScript.CST.Errors as CST - -import qualified Text.Parsec as P +import "base-compat" Prelude.Compat + +import "deepseq" Control.DeepSeq (NFData) +import "base" Data.Functor.Identity + +import "aeson" Data.Aeson.TH +import qualified "containers" Data.Map as M +import "text" Data.Text (Text) +import qualified "base" Data.List.NonEmpty as NEL +import "base" GHC.Generics (Generic) + +import "this" Language.PureScript.AST.Binders +import "this" Language.PureScript.AST.Literals +import "this" Language.PureScript.AST.Operators +import "this" Language.PureScript.AST.SourcePos +import "this" Language.PureScript.Types +import "this" Language.PureScript.PSString (PSString) +import "this" Language.PureScript.Label (Label) +import "this" Language.PureScript.Names +import "this" Language.PureScript.Kinds +import "this" Language.PureScript.Roles +import "this" Language.PureScript.TypeClassDictionaries +import "this" Language.PureScript.Comments +import "this" Language.PureScript.Environment +import qualified "this" Language.PureScript.Constants.Prim as C -- | A map of locally-bound names in scope. type Context = [(Ident, SourceType)] @@ -65,122 +57,6 @@ onTypeSearchTypesM :: (Applicative m) => (SourceType -> m SourceType) -> TypeSea onTypeSearchTypesM f (TSAfter i r) = TSAfter <$> traverse (traverse f) i <*> traverse (traverse (traverse f)) r onTypeSearchTypesM _ (TSBefore env) = pure (TSBefore env) --- | A type of error messages -data SimpleErrorMessage - = ModuleNotFound ModuleName - | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) - | ErrorParsingModule P.ParseError - | ErrorParsingCSTModule CST.ParserError - | MissingFFIModule ModuleName - | UnnecessaryFFIModule ModuleName FilePath - | MissingFFIImplementations ModuleName [Ident] - | UnusedFFIImplementations ModuleName [Ident] - | InvalidFFIIdentifier ModuleName Text - | FileIOError Text IOError -- ^ A description of what we were trying to do, and the error which occurred - | InfiniteType SourceType - | InfiniteKind SourceKind - | MultipleValueOpFixities (OpName 'ValueOpName) - | MultipleTypeOpFixities (OpName 'TypeOpName) - | OrphanTypeDeclaration Ident - | RedefinedIdent Ident - | OverlappingNamesInLet - | UnknownName (Qualified Name) - | UnknownImport ModuleName Name - | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName) - | UnknownExport Name - | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName) - | ScopeConflict Name [ModuleName] - | ScopeShadowing Name (Maybe ModuleName) [ModuleName] - | DeclConflict Name Name - | ExportConflict (Qualified Name) (Qualified Name) - | DuplicateModule ModuleName - | DuplicateTypeClass (ProperName 'ClassName) SourceSpan - | DuplicateInstance Ident SourceSpan - | DuplicateTypeArgument Text - | InvalidDoBind - | InvalidDoLet - | CycleInDeclaration Ident - | CycleInTypeSynonym (Maybe (ProperName 'TypeName)) - | CycleInTypeClassDeclaration [Qualified (ProperName 'ClassName)] - | CycleInModules [ModuleName] - | NameIsUndefined Ident - | UndefinedTypeVariable (ProperName 'TypeName) - | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName)) - | EscapedSkolem Text (Maybe SourceSpan) SourceType - | TypesDoNotUnify SourceType SourceType - | KindsDoNotUnify SourceKind SourceKind - | ConstrainedTypeUnified SourceType SourceType - | OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified Ident] - | NoInstanceFound SourceConstraint - | AmbiguousTypeVariables SourceType [Int] - | UnknownClass (Qualified (ProperName 'ClassName)) - | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [SourceType] - | CannotDerive (Qualified (ProperName 'ClassName)) [SourceType] - | InvalidDerivedInstance (Qualified (ProperName 'ClassName)) [SourceType] Int - | ExpectedTypeConstructor (Qualified (ProperName 'ClassName)) [SourceType] SourceType - | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [SourceType] - | MissingNewtypeSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType] - | UnverifiableSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType] - | CannotFindDerivingType (ProperName 'TypeName) - | DuplicateLabel Label (Maybe Expr) - | DuplicateValueDeclaration Ident - | ArgListLengthsDiffer Ident - | OverlappingArgNames (Maybe Ident) - | MissingClassMember (NEL.NonEmpty (Ident, SourceType)) - | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName)) - | ExpectedType SourceType SourceKind - -- | constructor name, expected argument count, actual argument count - | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName)) Int Int - | ExprDoesNotHaveType Expr SourceType - | PropertyIsMissing Label - | AdditionalProperty Label - | TypeSynonymInstance - | OrphanInstance Ident (Qualified (ProperName 'ClassName)) (Set ModuleName) [SourceType] - | InvalidNewtype (ProperName 'TypeName) - | InvalidInstanceHead SourceType - | TransitiveExportError DeclarationRef [DeclarationRef] - | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName) - | ShadowedName Ident - | ShadowedTypeVar Text - | UnusedTypeVar Text - | WildcardInferredType SourceType Context - | HoleInferredType Text SourceType Context (Maybe TypeSearch) - | MissingTypeDeclaration Ident SourceType - | OverlappingPattern [[Binder]] Bool - | IncompleteExhaustivityCheck - | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName) - | ImportHidingModule ModuleName - | UnusedImport ModuleName (Maybe ModuleName) - | UnusedExplicitImport ModuleName [Name] (Maybe ModuleName) [DeclarationRef] - | UnusedDctorImport ModuleName (ProperName 'TypeName) (Maybe ModuleName) [DeclarationRef] - | UnusedDctorExplicitImport ModuleName (ProperName 'TypeName) [ProperName 'ConstructorName] (Maybe ModuleName) [DeclarationRef] - | DuplicateSelectiveImport ModuleName - | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) - | DuplicateImportRef Name - | DuplicateExportRef Name - | IntOutOfRange Integer Text Integer Integer - | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef] - | ImplicitQualifiedImportReExport ModuleName ModuleName [DeclarationRef] - | ImplicitImport ModuleName [DeclarationRef] - | HidingImport ModuleName [DeclarationRef] - | CaseBinderLengthDiffers Int [Binder] - | IncorrectAnonymousArgument - | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident) - | CannotGeneralizeRecursiveFunction Ident SourceType - | CannotDeriveNewtypeForData (ProperName 'TypeName) - | ExpectedWildcard (ProperName 'TypeName) - | CannotUseBindWithDo Ident - -- | instance name, type class, expected argument count, actual argument count - | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int - -- | a user-defined warning raised by using the Warn type class - | UserDefinedWarning SourceType - -- | a declaration couldn't be used because it contained free variables - | UnusableDeclaration Ident [[Text]] - | CannotDefinePrimModules ModuleName - | MixedAssociativityError (NEL.NonEmpty (Qualified (OpName 'AnyOpName), Associativity)) - | NonAssociativeError (NEL.NonEmpty (Qualified (OpName 'AnyOpName))) - deriving (Show) - -- | Error message hints, providing more detailed information about failure. data ErrorMessageHint = ErrorUnifyingTypes SourceType SourceType @@ -217,11 +93,6 @@ data HintCategory | OtherHint deriving (Show, Eq) -data ErrorMessage = ErrorMessage - [ErrorMessageHint] - SimpleErrorMessage - deriving (Show) - -- | -- A module declaration, consisting of comments about the module, a module name, -- a list of declarations, and a list of the declarations that are diff --git a/src/Language/PureScript/AST/Exported.hs b/lib/purescript-ast/src/Language/PureScript/AST/Exported.hs similarity index 94% rename from src/Language/PureScript/AST/Exported.hs rename to lib/purescript-ast/src/Language/PureScript/AST/Exported.hs index 9cf015e0bc..7c6db77a0c 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Exported.hs @@ -3,17 +3,17 @@ module Language.PureScript.AST.Exported , isExported ) where -import Prelude.Compat -import Protolude (sortBy, on) +import "base-compat" Prelude.Compat +import "protolude" Protolude (sortBy, on) -import Control.Category ((>>>)) +import "base" Control.Category ((>>>)) -import Data.Maybe (mapMaybe) -import qualified Data.Map as M +import "base" Data.Maybe (mapMaybe) +import qualified "containers" Data.Map as M -import Language.PureScript.AST.Declarations -import Language.PureScript.Types -import Language.PureScript.Names +import "this" Language.PureScript.AST.Declarations +import "this" Language.PureScript.Types +import "this" Language.PureScript.Names -- | -- Return a list of all declarations which are exported from a module. diff --git a/src/Language/PureScript/AST/Literals.hs b/lib/purescript-ast/src/Language/PureScript/AST/Literals.hs similarity index 87% rename from src/Language/PureScript/AST/Literals.hs rename to lib/purescript-ast/src/Language/PureScript/AST/Literals.hs index a161fd82ab..f6ffbb3ed2 100644 --- a/src/Language/PureScript/AST/Literals.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Literals.hs @@ -3,8 +3,8 @@ -- module Language.PureScript.AST.Literals where -import Prelude.Compat -import Language.PureScript.PSString (PSString) +import "base-compat" Prelude.Compat +import "this" Language.PureScript.PSString (PSString) -- | -- Data type for literal values. Parameterised so it can be used for Exprs and diff --git a/src/Language/PureScript/AST/Operators.hs b/lib/purescript-ast/src/Language/PureScript/AST/Operators.hs similarity index 82% rename from src/Language/PureScript/AST/Operators.hs rename to lib/purescript-ast/src/Language/PureScript/AST/Operators.hs index ffe53771d0..e4755d3067 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Operators.hs @@ -1,17 +1,16 @@ -{-# LANGUAGE DeriveGeneric #-} -- | -- Operators fixity and associativity -- module Language.PureScript.AST.Operators where -import Prelude.Compat +import "base-compat" Prelude.Compat -import GHC.Generics (Generic) -import Control.DeepSeq (NFData) -import Data.Aeson ((.=)) -import qualified Data.Aeson as A +import "base" GHC.Generics (Generic) +import "deepseq" Control.DeepSeq (NFData) +import "aeson" Data.Aeson ((.=)) +import qualified "aeson" Data.Aeson as A -import Language.PureScript.Crash +import "this" Language.PureScript.Crash -- | -- A precedence level for an infix operator diff --git a/src/Language/PureScript/AST/SourcePos.hs b/lib/purescript-ast/src/Language/PureScript/AST/SourcePos.hs similarity index 89% rename from src/Language/PureScript/AST/SourcePos.hs rename to lib/purescript-ast/src/Language/PureScript/AST/SourcePos.hs index d47de81a50..864ac5b1a2 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/SourcePos.hs @@ -1,19 +1,18 @@ -{-# LANGUAGE DeriveGeneric #-} -- | -- Source position information -- module Language.PureScript.AST.SourcePos where -import Prelude.Compat +import "base-compat" Prelude.Compat -import Control.DeepSeq (NFData) -import Data.Aeson ((.=), (.:)) -import Data.Text (Text) -import GHC.Generics (Generic) -import Language.PureScript.Comments -import qualified Data.Aeson as A -import qualified Data.Text as T -import System.FilePath (makeRelative) +import "deepseq" Control.DeepSeq (NFData) +import "aeson" Data.Aeson ((.=), (.:)) +import "text" Data.Text (Text) +import "base" GHC.Generics (Generic) +import "this" Language.PureScript.Comments +import qualified "aeson" Data.Aeson as A +import qualified "text" Data.Text as T +import "filepath" System.FilePath (makeRelative) -- | Source annotation - position information and comments. type SourceAnn = (SourceSpan, [Comment]) diff --git a/src/Language/PureScript/AST/Traversals.hs b/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs similarity index 97% rename from src/Language/PureScript/AST/Traversals.hs rename to lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs index 4aaeeecad7..32e580727f 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs @@ -3,25 +3,25 @@ -- module Language.PureScript.AST.Traversals where -import Prelude.Compat - -import Control.Monad - -import Data.Foldable (fold) -import Data.List (mapAccumL) -import Data.Maybe (mapMaybe) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as M -import qualified Data.Set as S - -import Language.PureScript.AST.Binders -import Language.PureScript.AST.Declarations -import Language.PureScript.AST.Literals -import Language.PureScript.Kinds -import Language.PureScript.Names -import Language.PureScript.Traversals -import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..)) -import Language.PureScript.Types +import "base-compat" Prelude.Compat + +import "base" Control.Monad + +import "base" Data.Foldable (fold) +import "base" Data.List (mapAccumL) +import "base" Data.Maybe (mapMaybe) +import qualified "base" Data.List.NonEmpty as NEL +import qualified "containers" Data.Map as M +import qualified "containers" Data.Set as S + +import "this" Language.PureScript.AST.Binders +import "this" Language.PureScript.AST.Declarations +import "this" Language.PureScript.AST.Literals +import "this" Language.PureScript.Kinds +import "this" Language.PureScript.Names +import "this" Language.PureScript.Traversals +import "this" Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..)) +import "this" Language.PureScript.Types guardedExprM :: Applicative m => (Guard -> m Guard) diff --git a/src/Language/PureScript/Comments.hs b/lib/purescript-ast/src/Language/PureScript/Comments.hs similarity index 65% rename from src/Language/PureScript/Comments.hs rename to lib/purescript-ast/src/Language/PureScript/Comments.hs index 5c5acd82ac..9635faa9e4 100644 --- a/src/Language/PureScript/Comments.hs +++ b/lib/purescript-ast/src/Language/PureScript/Comments.hs @@ -1,17 +1,16 @@ {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -- | -- Defines the types of source code comments -- module Language.PureScript.Comments where -import Prelude.Compat -import Control.DeepSeq (NFData) -import Data.Text (Text) -import GHC.Generics (Generic) +import "base-compat" Prelude.Compat +import "deepseq" Control.DeepSeq (NFData) +import "text" Data.Text (Text) +import "base" GHC.Generics (Generic) -import Data.Aeson.TH +import "aeson" Data.Aeson.TH data Comment = LineComment Text diff --git a/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs b/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs new file mode 100644 index 0000000000..35fc51a499 --- /dev/null +++ b/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs @@ -0,0 +1,162 @@ +-- | Various constants which refer to things in Prim +module Language.PureScript.Constants.Prim where + +import "base-compat" Prelude.Compat + +import "base" Data.String (IsString) +import "this" Language.PureScript.Names + +-- Prim values + +undefined :: forall a. (IsString a) => a +undefined = "undefined" + +-- Prim + +partial :: forall a. (IsString a) => a +partial = "Partial" + +pattern Prim :: ModuleName +pattern Prim = ModuleName [ProperName "Prim"] + +pattern Partial :: Qualified (ProperName 'ClassName) +pattern Partial = Qualified (Just Prim) (ProperName "Partial") + +pattern Record :: Qualified (ProperName 'TypeName) +pattern Record = Qualified (Just Prim) (ProperName "Record") + +-- Prim.Boolean + +pattern PrimBoolean :: ModuleName +pattern PrimBoolean = ModuleName [ProperName "Prim", ProperName "Boolean"] + +booleanTrue :: Qualified (ProperName 'TypeName) +booleanTrue = Qualified (Just PrimBoolean) (ProperName "True") + +booleanFalse :: Qualified (ProperName 'TypeName) +booleanFalse = Qualified (Just PrimBoolean) (ProperName "False") + +-- Prim.Coerce + +pattern PrimCoerce :: ModuleName +pattern PrimCoerce = ModuleName [ProperName "Prim", ProperName "Coerce"] + +pattern Coercible :: Qualified (ProperName 'ClassName) +pattern Coercible = Qualified (Just PrimCoerce) (ProperName "Coercible") + +-- Prim.Ordering + +pattern PrimOrdering :: ModuleName +pattern PrimOrdering = ModuleName [ProperName "Prim", ProperName "Ordering"] + +orderingLT :: Qualified (ProperName 'TypeName) +orderingLT = Qualified (Just PrimOrdering) (ProperName "LT") + +orderingEQ :: Qualified (ProperName 'TypeName) +orderingEQ = Qualified (Just PrimOrdering) (ProperName "EQ") + +orderingGT :: Qualified (ProperName 'TypeName) +orderingGT = Qualified (Just PrimOrdering) (ProperName "GT") + +-- Prim.Row + +pattern PrimRow :: ModuleName +pattern PrimRow = ModuleName [ProperName "Prim", ProperName "Row"] + +pattern RowUnion :: Qualified (ProperName 'ClassName) +pattern RowUnion = Qualified (Just PrimRow) (ProperName "Union") + +pattern RowNub :: Qualified (ProperName 'ClassName) +pattern RowNub = Qualified (Just PrimRow) (ProperName "Nub") + +pattern RowCons :: Qualified (ProperName 'ClassName) +pattern RowCons = Qualified (Just PrimRow) (ProperName "Cons") + +pattern RowLacks :: Qualified (ProperName 'ClassName) +pattern RowLacks = Qualified (Just PrimRow) (ProperName "Lacks") + +-- Prim.RowList + +pattern PrimRowList :: ModuleName +pattern PrimRowList = ModuleName [ProperName "Prim", ProperName "RowList"] + +pattern RowToList :: Qualified (ProperName 'ClassName) +pattern RowToList = Qualified (Just PrimRowList) (ProperName "RowToList") + +pattern RowListNil :: Qualified (ProperName 'TypeName) +pattern RowListNil = Qualified (Just PrimRowList) (ProperName "Nil") + +pattern RowListCons :: Qualified (ProperName 'TypeName) +pattern RowListCons = Qualified (Just PrimRowList) (ProperName "Cons") + +-- Prim.Symbol + +pattern PrimSymbol :: ModuleName +pattern PrimSymbol = ModuleName [ProperName "Prim", ProperName "Symbol"] + +pattern SymbolCompare :: Qualified (ProperName 'ClassName) +pattern SymbolCompare = Qualified (Just PrimSymbol) (ProperName "Compare") + +pattern SymbolAppend :: Qualified (ProperName 'ClassName) +pattern SymbolAppend = Qualified (Just PrimSymbol) (ProperName "Append") + +pattern SymbolCons :: Qualified (ProperName 'ClassName) +pattern SymbolCons = Qualified (Just PrimSymbol) (ProperName "Cons") + +-- Prim.TypeError + +pattern PrimTypeError :: ModuleName +pattern PrimTypeError = ModuleName [ProperName "Prim", ProperName "TypeError"] + +pattern Fail :: Qualified (ProperName 'ClassName) +pattern Fail = Qualified (Just PrimTypeError) (ProperName "Fail") + +pattern Warn :: Qualified (ProperName 'ClassName) +pattern Warn = Qualified (Just PrimTypeError) (ProperName "Warn") + +primModules :: [ModuleName] +primModules = [Prim, PrimBoolean, PrimCoerce, PrimOrdering, PrimRow, PrimRowList, PrimSymbol, PrimTypeError] + +typ :: forall a. (IsString a) => a +typ = "Type" + +kindBoolean :: forall a. (IsString a) => a +kindBoolean = "Boolean" + +kindOrdering :: forall a. (IsString a) => a +kindOrdering = "Ordering" + +kindRowList :: forall a. (IsString a) => a +kindRowList = "RowList" + +symbol :: forall a. (IsString a) => a +symbol = "Symbol" + +doc :: forall a. (IsString a) => a +doc = "Doc" + +-- Modules + +prim :: forall a. (IsString a) => a +prim = "Prim" + +moduleBoolean :: forall a. (IsString a) => a +moduleBoolean = "Boolean" + +moduleCoerce :: forall a. (IsString a) => a +moduleCoerce = "Coerce" + +moduleOrdering :: forall a. (IsString a) => a +moduleOrdering = "Ordering" + +moduleRow :: forall a. (IsString a) => a +moduleRow = "Row" + +moduleRowList :: forall a. (IsString a) => a +moduleRowList = "RowList" + +moduleSymbol :: forall a. (IsString a) => a +moduleSymbol = "Symbol" + +typeError :: forall a. (IsString a) => a +typeError = "TypeError" diff --git a/src/Language/PureScript/Crash.hs b/lib/purescript-ast/src/Language/PureScript/Crash.hs similarity index 86% rename from src/Language/PureScript/Crash.hs rename to lib/purescript-ast/src/Language/PureScript/Crash.hs index fe72169bb0..9edacd4b5b 100644 --- a/src/Language/PureScript/Crash.hs +++ b/lib/purescript-ast/src/Language/PureScript/Crash.hs @@ -3,9 +3,9 @@ module Language.PureScript.Crash where -import Prelude.Compat +import "base-compat" Prelude.Compat -import qualified GHC.Stack +import qualified "base" GHC.Stack -- | A compatibility wrapper for the @GHC.Stack.HasCallStack@ constraint. #if __GLASGOW_HASKELL__ >= 800 @@ -13,7 +13,7 @@ type HasCallStack = GHC.Stack.HasCallStack #elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) type HasCallStack = (?callStack :: GHC.Stack.CallStack) #else -import GHC.Exts (Constraint) +import "base" GHC.Exts (Constraint) -- CallStack wasn't present in GHC 7.10.1 type HasCallStack = (() :: Constraint) #endif diff --git a/src/Language/PureScript/Environment.hs b/lib/purescript-ast/src/Language/PureScript/Environment.hs similarity index 96% rename from src/Language/PureScript/Environment.hs rename to lib/purescript-ast/src/Language/PureScript/Environment.hs index 08aad2acf9..845b4d93d6 100644 --- a/src/Language/PureScript/Environment.hs +++ b/lib/purescript-ast/src/Language/PureScript/Environment.hs @@ -1,32 +1,30 @@ -{-# LANGUAGE DeriveGeneric #-} - module Language.PureScript.Environment where -import Prelude.Compat -import Protolude (ordNub) - -import GHC.Generics (Generic) -import Control.DeepSeq (NFData) -import Data.Aeson ((.=), (.:)) -import qualified Data.Aeson as A -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Tree (Tree, rootLabel) -import qualified Data.Graph as G -import Data.Foldable (toList, fold) -import qualified Data.List.NonEmpty as NEL - -import Language.PureScript.AST.SourcePos -import Language.PureScript.Crash -import Language.PureScript.Kinds -import Language.PureScript.Names -import Language.PureScript.Roles -import Language.PureScript.TypeClassDictionaries -import Language.PureScript.Types -import qualified Language.PureScript.Constants as C +import "base-compat" Prelude.Compat +import "protolude" Protolude (ordNub) + +import "base" GHC.Generics (Generic) +import "deepseq" Control.DeepSeq (NFData) +import "aeson" Data.Aeson ((.=), (.:)) +import qualified "aeson" Data.Aeson as A +import qualified "containers" Data.Map as M +import qualified "containers" Data.Set as S +import "base" Data.Maybe (fromMaybe, mapMaybe) +import "text" Data.Text (Text) +import qualified "text" Data.Text as T +import "containers" Data.Tree (Tree, rootLabel) +import qualified "containers" Data.Graph as G +import "base" Data.Foldable (toList, fold) +import qualified "base" Data.List.NonEmpty as NEL + +import "this" Language.PureScript.AST.SourcePos +import "this" Language.PureScript.Crash +import "this" Language.PureScript.Kinds +import "this" Language.PureScript.Names +import "this" Language.PureScript.Roles +import "this" Language.PureScript.TypeClassDictionaries +import "this" Language.PureScript.Types +import qualified "this" Language.PureScript.Constants.Prim as C -- | The @Environment@ defines all values and types which are currently in scope: data Environment = Environment diff --git a/src/Language/PureScript/Kinds.hs b/lib/purescript-ast/src/Language/PureScript/Kinds.hs similarity index 90% rename from src/Language/PureScript/Kinds.hs rename to lib/purescript-ast/src/Language/PureScript/Kinds.hs index 0e7d19ce1a..6e4f49a3e8 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/lib/purescript-ast/src/Language/PureScript/Kinds.hs @@ -1,25 +1,19 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Language.PureScript.Kinds where -import Prelude.Compat +import "base-compat" Prelude.Compat -import GHC.Generics (Generic) -import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData) -import Data.Text (Text) -import Data.Aeson (Value, toJSON, (.=), (.:)) -import Data.Aeson.Types (Parser) -import qualified Data.Aeson as A +import "base" GHC.Generics (Generic) +import "base" Control.Applicative ((<|>)) +import "deepseq" Control.DeepSeq (NFData) +import "text" Data.Text (Text) +import "aeson" Data.Aeson (Value, toJSON, (.=), (.:)) +import "aeson" Data.Aeson.Types (Parser) +import qualified "aeson" Data.Aeson as A -import Language.PureScript.AST.SourcePos -import Language.PureScript.Names +import "this" Language.PureScript.AST.SourcePos +import "this" Language.PureScript.Names -import Lens.Micro.Platform (Lens', (^.), set) +import "microlens-platform" Lens.Micro.Platform (Lens', (^.), set) type SourceKind = Kind SourceAnn diff --git a/src/Language/PureScript/Label.hs b/lib/purescript-ast/src/Language/PureScript/Label.hs similarity index 54% rename from src/Language/PureScript/Label.hs rename to lib/purescript-ast/src/Language/PureScript/Label.hs index accd31463e..8be2067d1f 100644 --- a/src/Language/PureScript/Label.hs +++ b/lib/purescript-ast/src/Language/PureScript/Label.hs @@ -1,16 +1,13 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveGeneric #-} - module Language.PureScript.Label (Label(..)) where -import Prelude.Compat hiding (lex) -import GHC.Generics (Generic) -import Control.DeepSeq (NFData) -import Data.Monoid () -import Data.String (IsString(..)) -import qualified Data.Aeson as A +import "base-compat" Prelude.Compat hiding (lex) +import "base" GHC.Generics (Generic) +import "deepseq" Control.DeepSeq (NFData) +import "base" Data.Monoid () +import "base" Data.String (IsString(..)) +import qualified "aeson" Data.Aeson as A -import Language.PureScript.PSString (PSString) +import "this" Language.PureScript.PSString (PSString) -- | -- Labels are used as record keys and row entry names. Labels newtype PSString diff --git a/src/Language/PureScript/Names.hs b/lib/purescript-ast/src/Language/PureScript/Names.hs similarity index 94% rename from src/Language/PureScript/Names.hs rename to lib/purescript-ast/src/Language/PureScript/Names.hs index 5f8afd75b2..7c27876b56 100644 --- a/src/Language/PureScript/Names.hs +++ b/lib/purescript-ast/src/Language/PureScript/Names.hs @@ -1,24 +1,21 @@ {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} -- | -- Data types for names -- module Language.PureScript.Names where -import Prelude.Compat +import "base-compat" Prelude.Compat -import Control.Monad.Supply.Class -import Control.DeepSeq (NFData) -import Data.Functor.Contravariant (contramap) +import "this" Control.Monad.Supply.Class +import "deepseq" Control.DeepSeq (NFData) +import "base" Data.Functor.Contravariant (contramap) -import GHC.Generics (Generic) -import Data.Aeson -import Data.Aeson.TH -import Data.Text (Text) -import qualified Data.Text as T +import "base" GHC.Generics (Generic) +import "aeson" Data.Aeson +import "aeson" Data.Aeson.TH +import "text" Data.Text (Text) +import qualified "text" Data.Text as T -- | A sum of the possible name types, useful for error and lint messages. data Name diff --git a/src/Language/PureScript/PSString.hs b/lib/purescript-ast/src/Language/PureScript/PSString.hs similarity index 88% rename from src/Language/PureScript/PSString.hs rename to lib/purescript-ast/src/Language/PureScript/PSString.hs index 48a042fe1b..3f07db6a53 100644 --- a/src/Language/PureScript/PSString.hs +++ b/lib/purescript-ast/src/Language/PureScript/PSString.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric #-} - module Language.PureScript.PSString ( PSString , toUTF16CodeUnits @@ -13,28 +9,28 @@ module Language.PureScript.PSString , mkString ) where -import Prelude.Compat -import GHC.Generics (Generic) -import Control.DeepSeq (NFData) -import Control.Exception (try, evaluate) -import Control.Applicative ((<|>)) -import qualified Data.Char as Char -import Data.Bits (shiftR) -import Data.List (unfoldr) -import Data.Scientific (toBoundedInteger) -import Data.String (IsString(..)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf16BE) -import Data.Text.Encoding.Error (UnicodeException) -import qualified Data.Vector as V -import Data.Word (Word16, Word8) -import Numeric (showHex) -import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Aeson as A -import qualified Data.Aeson.Types as A +import "base-compat" Prelude.Compat +import "base" GHC.Generics (Generic) +import "deepseq" Control.DeepSeq (NFData) +import "base" Control.Exception (try, evaluate) +import "base" Control.Applicative ((<|>)) +import qualified "base" Data.Char as Char +import "base" Data.Bits (shiftR) +import "base" Data.List (unfoldr) +import "scientific" Data.Scientific (toBoundedInteger) +import "base" Data.String (IsString(..)) +import "bytestring" Data.ByteString (ByteString) +import qualified "bytestring" Data.ByteString as BS +import "text" Data.Text (Text) +import qualified "text" Data.Text as T +import "text" Data.Text.Encoding (decodeUtf16BE) +import "text" Data.Text.Encoding.Error (UnicodeException) +import qualified "vector" Data.Vector as V +import "base" Data.Word (Word16, Word8) +import "base" Numeric (showHex) +import "base" System.IO.Unsafe (unsafePerformIO) +import qualified "aeson" Data.Aeson as A +import qualified "aeson" Data.Aeson.Types as A -- | -- Strings in PureScript are sequences of UTF-16 code units, which do not diff --git a/src/Language/PureScript/Roles.hs b/lib/purescript-ast/src/Language/PureScript/Roles.hs similarity index 75% rename from src/Language/PureScript/Roles.hs rename to lib/purescript-ast/src/Language/PureScript/Roles.hs index ab807f046b..b521848b22 100644 --- a/src/Language/PureScript/Roles.hs +++ b/lib/purescript-ast/src/Language/PureScript/Roles.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} -- | @@ -8,12 +7,12 @@ module Language.PureScript.Roles ( Role(..) ) where -import Prelude.Compat +import "base-compat" Prelude.Compat -import Control.DeepSeq (NFData) -import qualified Data.Aeson as A -import qualified Data.Aeson.TH as A -import GHC.Generics (Generic) +import "deepseq" Control.DeepSeq (NFData) +import qualified "aeson" Data.Aeson as A +import qualified "aeson" Data.Aeson.TH as A +import "base" GHC.Generics (Generic) -- | -- The role of a type constructor's parameter. diff --git a/src/Language/PureScript/Traversals.hs b/lib/purescript-ast/src/Language/PureScript/Traversals.hs similarity index 93% rename from src/Language/PureScript/Traversals.hs rename to lib/purescript-ast/src/Language/PureScript/Traversals.hs index c40f91c04e..302102f332 100644 --- a/src/Language/PureScript/Traversals.hs +++ b/lib/purescript-ast/src/Language/PureScript/Traversals.hs @@ -1,7 +1,7 @@ -- | Common functions for implementing generic traversals module Language.PureScript.Traversals where -import Prelude.Compat +import "base-compat" Prelude.Compat fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b) fstM f (a, b) = flip (,) b <$> f a diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs similarity index 82% rename from src/Language/PureScript/TypeClassDictionaries.hs rename to lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs index 7f1ad25f09..82854c9b1b 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs @@ -1,16 +1,13 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveGeneric #-} module Language.PureScript.TypeClassDictionaries where -import Prelude.Compat +import "base-compat" Prelude.Compat -import GHC.Generics (Generic) -import Control.DeepSeq (NFData) -import Data.Text (Text, pack) +import "base" GHC.Generics (Generic) +import "deepseq" Control.DeepSeq (NFData) +import "text" Data.Text (Text, pack) -import Language.PureScript.Names -import Language.PureScript.Types +import "this" Language.PureScript.Names +import "this" Language.PureScript.Types -- | -- Data representing a type class dictionary which is in scope diff --git a/src/Language/PureScript/Types.hs b/lib/purescript-ast/src/Language/PureScript/Types.hs similarity index 96% rename from src/Language/PureScript/Types.hs rename to lib/purescript-ast/src/Language/PureScript/Types.hs index 54fdaf27b3..d753e3a1e1 100644 --- a/src/Language/PureScript/Types.hs +++ b/lib/purescript-ast/src/Language/PureScript/Types.hs @@ -1,40 +1,33 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} - -- | -- Data types for types -- module Language.PureScript.Types where -import Prelude.Compat -import Protolude (ordNub) - -import Control.Applicative ((<|>)) -import Control.Arrow (first) -import Control.DeepSeq (NFData) -import Control.Monad ((<=<)) -import Data.Aeson ((.:), (.=)) -import qualified Data.Aeson as A -import qualified Data.Aeson.Types as A -import Data.Foldable (fold) -import Data.List (sortBy) -import Data.Ord (comparing) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics (Generic) - -import Language.PureScript.AST.SourcePos -import Language.PureScript.Kinds -import Language.PureScript.Names -import Language.PureScript.Label (Label) -import Language.PureScript.PSString (PSString) - -import Lens.Micro.Platform (Lens', (^.), set) +import "base-compat" Prelude.Compat +import "protolude" Protolude (ordNub) + +import "base" Control.Applicative ((<|>)) +import "base" Control.Arrow (first) +import "deepseq" Control.DeepSeq (NFData) +import "base" Control.Monad ((<=<)) +import "aeson" Data.Aeson ((.:), (.=)) +import qualified "aeson" Data.Aeson as A +import qualified "aeson" Data.Aeson.Types as A +import "base" Data.Foldable (fold) +import "base" Data.List (sortBy) +import "base" Data.Ord (comparing) +import "base" Data.Maybe (fromMaybe) +import "text" Data.Text (Text) +import qualified "text" Data.Text as T +import "base" GHC.Generics (Generic) + +import "this" Language.PureScript.AST.SourcePos +import "this" Language.PureScript.Kinds +import "this" Language.PureScript.Names +import "this" Language.PureScript.Label (Label) +import "this" Language.PureScript.PSString (PSString) + +import "microlens-platform" Lens.Micro.Platform (Lens', (^.), set) type SourceType = Type SourceAnn type SourceConstraint = Constraint SourceAnn diff --git a/lib/purescript-cst/.gitignore b/lib/purescript-cst/.gitignore new file mode 100644 index 0000000000..aaa2fe2fd1 --- /dev/null +++ b/lib/purescript-cst/.gitignore @@ -0,0 +1 @@ +purescript-cst.cabal diff --git a/lib/purescript-cst/LICENSE b/lib/purescript-cst/LICENSE new file mode 100644 index 0000000000..7904c3e262 --- /dev/null +++ b/lib/purescript-cst/LICENSE @@ -0,0 +1,13 @@ +Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other +contributors +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/lib/purescript-cst/README.md b/lib/purescript-cst/README.md new file mode 100644 index 0000000000..f72863acbd --- /dev/null +++ b/lib/purescript-cst/README.md @@ -0,0 +1,11 @@ +# purescript-cst + +Defines the surface syntax of the PureScript Programming Language. + +## Compiler compatibility + +We provide a table to make it a bit easier to map between versions of `purescript` and `purescript-cst`. + +| `purescript` | `purescript-cst` | +| --- | --- | +| `0.13.6` | `0.1.0.0` | diff --git a/lib/purescript-cst/Setup.hs b/lib/purescript-cst/Setup.hs new file mode 100644 index 0000000000..cd7b151a59 --- /dev/null +++ b/lib/purescript-cst/Setup.hs @@ -0,0 +1,6 @@ +module Main where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/lib/purescript-cst/package.yaml b/lib/purescript-cst/package.yaml new file mode 100644 index 0000000000..dfdc500673 --- /dev/null +++ b/lib/purescript-cst/package.yaml @@ -0,0 +1,80 @@ +name: purescript-cst +version: '0.1.0.0' +synopsis: PureScript Programming Language Concrete Syntax Tree +description: The surface syntax of the PureScript Programming Language. +category: Language +author: Phil Freeman +maintainer: > + Gary Burgess , + Hardy Jones , + Harry Garrood , + Christoph Hegemann , + Liam Goodacre , + Nathan Faubion +copyright: (c) 2013-17 Phil Freeman, (c) 2014-19 Gary Burgess, (c) other contributors (see CONTRIBUTORS.md) +license: BSD3 +github: purescript/purescript +homepage: http://www.purescript.org/ +extra-source-files: + - tests/purs/layout/*.purs + - README.md +dependencies: + - array + - base >=4.11 && <4.13 + - containers + - dlist + - purescript-ast + - scientific >=0.3.4.9 && <0.4 + - semigroups >=0.16.2 && <0.19 + - text +build-tools: + - happy ==1.19.9 + +library: + source-dirs: src + ghc-options: -Wall -O2 + default-extensions: + - BangPatterns + - ConstraintKinds + - DataKinds + - DeriveFunctor + - DeriveFoldable + - DeriveTraversable + - DeriveGeneric + - DerivingStrategies + - EmptyDataDecls + - FlexibleContexts + - KindSignatures + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - NoImplicitPrelude + - PackageImports + - PatternGuards + - PatternSynonyms + - RankNTypes + - RecordWildCards + - OverloadedStrings + - ScopedTypeVariables + - TupleSections + - ViewPatterns + +tests: + tests: + main: Main.hs + source-dirs: tests + ghc-options: -Wall + dependencies: + - base-compat >=0.6.0 + - bytestring + - filepath + - purescript-cst + - tasty + - tasty-golden + - tasty-quickcheck + default-extensions: + - NoImplicitPrelude + - LambdaCase + - OverloadedStrings + +stability: experimental diff --git a/src/Language/PureScript/CST/Convert.hs b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs similarity index 96% rename from src/Language/PureScript/CST/Convert.hs rename to lib/purescript-cst/src/Language/PureScript/CST/Convert.hs index e4501a5642..9ee107b6bb 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs @@ -16,25 +16,25 @@ module Language.PureScript.CST.Convert , comments ) where -import Prelude - -import Data.Bifunctor (bimap, first) -import Data.Foldable (foldl', toList) -import Data.Functor (($>)) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (isJust, fromJust, mapMaybe) -import qualified Data.Text as Text -import qualified Language.PureScript.AST as AST -import qualified Language.PureScript.AST.SourcePos as Pos -import qualified Language.PureScript.Comments as C -import qualified Language.PureScript.Environment as Env -import qualified Language.PureScript.Kinds as K -import qualified Language.PureScript.Label as L -import qualified Language.PureScript.Names as N -import Language.PureScript.PSString (mkString) -import qualified Language.PureScript.Types as T -import Language.PureScript.CST.Positions -import Language.PureScript.CST.Types +import "base" Prelude + +import "base" Data.Bifunctor (bimap, first) +import "base" Data.Foldable (foldl', toList) +import "base" Data.Functor (($>)) +import qualified "base" Data.List.NonEmpty as NE +import "base" Data.Maybe (isJust, fromJust, mapMaybe) +import qualified "text" Data.Text as Text +import qualified "purescript-ast" Language.PureScript.AST as AST +import qualified "purescript-ast" Language.PureScript.AST.SourcePos as Pos +import qualified "purescript-ast" Language.PureScript.Comments as C +import qualified "purescript-ast" Language.PureScript.Environment as Env +import qualified "purescript-ast" Language.PureScript.Kinds as K +import qualified "purescript-ast" Language.PureScript.Label as L +import qualified "purescript-ast" Language.PureScript.Names as N +import "purescript-ast" Language.PureScript.PSString (mkString) +import qualified "purescript-ast" Language.PureScript.Types as T +import "this" Language.PureScript.CST.Positions +import "this" Language.PureScript.CST.Types comment :: Comment a -> Maybe C.Comment comment = \case diff --git a/src/Language/PureScript/CST/Errors.hs b/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs similarity index 94% rename from src/Language/PureScript/CST/Errors.hs rename to lib/purescript-cst/src/Language/PureScript/CST/Errors.hs index 1b6bfdb091..cbc01d3264 100644 --- a/src/Language/PureScript/CST/Errors.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} module Language.PureScript.CST.Errors ( ParserError(..) , ParserErrorType(..) @@ -6,14 +5,14 @@ module Language.PureScript.CST.Errors , prettyPrintErrorMessage ) where -import Prelude +import "base" Prelude -import qualified Data.Text as Text -import Data.Char (isSpace, toUpper) -import Language.PureScript.CST.Layout -import Language.PureScript.CST.Print -import Language.PureScript.CST.Types -import Text.Printf (printf) +import qualified "text" Data.Text as Text +import "base" Data.Char (isSpace, toUpper) +import "this" Language.PureScript.CST.Layout +import "this" Language.PureScript.CST.Print +import "this" Language.PureScript.CST.Types +import "base" Text.Printf (printf) data ParserErrorType = ErrWildcardInType diff --git a/src/Language/PureScript/CST/Layout.hs b/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs similarity index 98% rename from src/Language/PureScript/CST/Layout.hs rename to lib/purescript-cst/src/Language/PureScript/CST/Layout.hs index 12df99ee8f..89e431c735 100644 --- a/src/Language/PureScript/CST/Layout.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs @@ -20,13 +20,13 @@ module Language.PureScript.CST.Layout where -import Prelude +import "base" Prelude -import Data.DList (snoc) -import qualified Data.DList as DList -import Data.Foldable (find) -import Data.Function ((&)) -import Language.PureScript.CST.Types +import "dlist" Data.DList (snoc) +import qualified "dlist" Data.DList as DList +import "base" Data.Foldable (find) +import "base" Data.Function ((&)) +import "this" Language.PureScript.CST.Types type LayoutStack = [(SourcePos, LayoutDelim)] diff --git a/src/Language/PureScript/CST/Lexer.hs b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs similarity index 96% rename from src/Language/PureScript/CST/Lexer.hs rename to lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs index 91faa20ce3..274040f893 100644 --- a/src/Language/PureScript/CST/Lexer.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} module Language.PureScript.CST.Lexer ( lenient , lex @@ -7,22 +6,22 @@ module Language.PureScript.CST.Lexer , isUnquotedKey ) where -import Prelude hiding (lex, exp, exponent, lines) - -import Control.Monad (join) -import qualified Data.Char as Char -import qualified Data.DList as DList -import Data.Foldable (foldl') -import Data.Functor (($>)) -import qualified Data.Scientific as Sci -import Data.String (fromString) -import Data.Text (Text) -import qualified Data.Text as Text -import Language.PureScript.CST.Errors -import Language.PureScript.CST.Monad hiding (token) -import Language.PureScript.CST.Layout -import Language.PureScript.CST.Positions -import Language.PureScript.CST.Types +import "base" Prelude hiding (lex, exp, exponent, lines) + +import "base" Control.Monad (join) +import qualified "base" Data.Char as Char +import qualified "dlist" Data.DList as DList +import "base" Data.Foldable (foldl') +import "base" Data.Functor (($>)) +import qualified "scientific" Data.Scientific as Sci +import "base" Data.String (fromString) +import "text" Data.Text (Text) +import qualified "text" Data.Text as Text +import "this" Language.PureScript.CST.Errors +import "this" Language.PureScript.CST.Monad hiding (token) +import "this" Language.PureScript.CST.Layout +import "this" Language.PureScript.CST.Positions +import "this" Language.PureScript.CST.Types -- | Stops at the first lexing error and replaces it with TokEof. Otherwise, -- the parser will fail when it attempts to draw a lookahead token. diff --git a/src/Language/PureScript/CST/Monad.hs b/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs similarity index 93% rename from src/Language/PureScript/CST/Monad.hs rename to lib/purescript-cst/src/Language/PureScript/CST/Monad.hs index eb7a3be456..33416125ed 100644 --- a/src/Language/PureScript/CST/Monad.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs @@ -1,15 +1,15 @@ module Language.PureScript.CST.Monad where -import Prelude - -import Data.List (sortBy) -import qualified Data.List.NonEmpty as NE -import Data.Ord (comparing) -import Data.Text (Text) -import Language.PureScript.CST.Errors -import Language.PureScript.CST.Layout -import Language.PureScript.CST.Positions -import Language.PureScript.CST.Types +import "base" Prelude + +import "base" Data.List (sortBy) +import qualified "base" Data.List.NonEmpty as NE +import "base" Data.Ord (comparing) +import "text" Data.Text (Text) +import "this" Language.PureScript.CST.Errors +import "this" Language.PureScript.CST.Layout +import "this" Language.PureScript.CST.Positions +import "this" Language.PureScript.CST.Types type LexResult = Either (LexState, ParserError) SourceToken diff --git a/src/Language/PureScript/CST/Parser.y b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y similarity index 97% rename from src/Language/PureScript/CST/Parser.y rename to lib/purescript-cst/src/Language/PureScript/CST/Parser.y index 4082d4472e..8e888a2c40 100644 --- a/src/Language/PureScript/CST/Parser.y +++ b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y @@ -17,22 +17,22 @@ module Language.PureScript.CST.Parser , PartialResult(..) ) where -import Prelude hiding (lex) - -import Control.Monad ((<=<), when) -import Data.Foldable (foldl', for_) -import qualified Data.List.NonEmpty as NE -import Data.Text (Text) -import Data.Traversable (for) -import Language.PureScript.CST.Errors -import Language.PureScript.CST.Lexer -import Language.PureScript.CST.Monad -import Language.PureScript.CST.Positions -import Language.PureScript.CST.Types -import Language.PureScript.CST.Utils -import qualified Language.PureScript.Names as N -import qualified Language.PureScript.Roles as R -import Language.PureScript.PSString (PSString) +import "base" Prelude hiding (lex) + +import "base" Control.Monad ((<=<), when) +import "base" Data.Foldable (foldl', for_) +import qualified "base" Data.List.NonEmpty as NE +import "text" Data.Text (Text) +import "base" Data.Traversable (for) +import "this" Language.PureScript.CST.Errors +import "this" Language.PureScript.CST.Lexer +import "this" Language.PureScript.CST.Monad +import "this" Language.PureScript.CST.Positions +import "this" Language.PureScript.CST.Types +import "this" Language.PureScript.CST.Utils +import qualified "purescript-ast" Language.PureScript.Names as N +import qualified "purescript-ast" Language.PureScript.Roles as R +import "purescript-ast" Language.PureScript.PSString (PSString) } %expect 114 diff --git a/src/Language/PureScript/CST/Positions.hs b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs similarity index 97% rename from src/Language/PureScript/CST/Positions.hs rename to lib/purescript-cst/src/Language/PureScript/CST/Positions.hs index 12c5361993..1d5defa043 100644 --- a/src/Language/PureScript/CST/Positions.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} - -- | This module contains utilities for calculating positions and offsets. While -- tokens are annotated with ranges, CST nodes are not, but they can be -- dynamically derived with the functions in this module, which will return the @@ -8,14 +5,14 @@ module Language.PureScript.CST.Positions where -import Prelude +import "base" Prelude -import Data.Foldable (foldl') -import qualified Data.List.NonEmpty as NE -import Data.Text (Text) -import Data.Void (Void) -import qualified Data.Text as Text -import Language.PureScript.CST.Types +import "base" Data.Foldable (foldl') +import qualified "base" Data.List.NonEmpty as NE +import "text" Data.Text (Text) +import "base" Data.Void (Void) +import qualified "text" Data.Text as Text +import "this" Language.PureScript.CST.Types advanceToken :: SourcePos -> Token -> SourcePos advanceToken pos = applyDelta pos . tokenDelta diff --git a/src/Language/PureScript/CST/Print.hs b/lib/purescript-cst/src/Language/PureScript/CST/Print.hs similarity index 94% rename from src/Language/PureScript/CST/Print.hs rename to lib/purescript-cst/src/Language/PureScript/CST/Print.hs index 16aac588dc..4e2d7560f1 100644 --- a/src/Language/PureScript/CST/Print.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Print.hs @@ -9,11 +9,11 @@ module Language.PureScript.CST.Print , printTrailingComment ) where -import Prelude +import "base" Prelude -import Data.Text (Text) -import qualified Data.Text as Text -import Language.PureScript.CST.Types +import "text" Data.Text (Text) +import qualified "text" Data.Text as Text +import "this" Language.PureScript.CST.Types printToken :: Token -> Text printToken = \case diff --git a/src/Language/PureScript/CST/Traversals.hs b/lib/purescript-cst/src/Language/PureScript/CST/Traversals.hs similarity index 78% rename from src/Language/PureScript/CST/Traversals.hs rename to lib/purescript-cst/src/Language/PureScript/CST/Traversals.hs index 6d5627f8ac..ea3f1278e7 100644 --- a/src/Language/PureScript/CST/Traversals.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Traversals.hs @@ -1,8 +1,8 @@ module Language.PureScript.CST.Traversals where -import Prelude +import "base" Prelude -import Language.PureScript.CST.Types +import "this" Language.PureScript.CST.Types everythingOnSeparated :: (r -> r -> r) -> (a -> r) -> Separated a -> r everythingOnSeparated op k (Separated hd tl) = go hd tl diff --git a/src/Language/PureScript/CST/Traversals/Type.hs b/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs similarity index 92% rename from src/Language/PureScript/CST/Traversals/Type.hs rename to lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs index 9e84718ee0..c206e409e3 100644 --- a/src/Language/PureScript/CST/Traversals/Type.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs @@ -1,9 +1,9 @@ module Language.PureScript.CST.Traversals.Type where -import Prelude +import "base" Prelude -import Language.PureScript.CST.Types -import Language.PureScript.CST.Traversals +import "this" Language.PureScript.CST.Types +import "this" Language.PureScript.CST.Traversals everythingOnTypes :: (r -> r -> r) -> (Type a -> r) -> Type a -> r everythingOnTypes op k = goTy diff --git a/src/Language/PureScript/CST/Types.hs b/lib/purescript-cst/src/Language/PureScript/CST/Types.hs similarity index 98% rename from src/Language/PureScript/CST/Types.hs rename to lib/purescript-cst/src/Language/PureScript/CST/Types.hs index 49dd13407e..90a92d876f 100644 --- a/src/Language/PureScript/CST/Types.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Types.hs @@ -7,15 +7,15 @@ module Language.PureScript.CST.Types where -import Prelude +import "base" Prelude -import Data.List.NonEmpty (NonEmpty) -import Data.Text (Text) -import Data.Void (Void) -import GHC.Generics (Generic) -import qualified Language.PureScript.Names as N +import "base" Data.List.NonEmpty (NonEmpty) +import "text" Data.Text (Text) +import "base" Data.Void (Void) +import "base" GHC.Generics (Generic) +import qualified "purescript-ast" Language.PureScript.Names as N import qualified Language.PureScript.Roles as R -import Language.PureScript.PSString (PSString) +import "purescript-ast" Language.PureScript.PSString (PSString) data SourcePos = SourcePos { srcLine :: {-# UNPACK #-} !Int diff --git a/src/Language/PureScript/CST/Utils.hs b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs similarity index 93% rename from src/Language/PureScript/CST/Utils.hs rename to lib/purescript-cst/src/Language/PureScript/CST/Utils.hs index 1d4c9d453a..e91a007d3a 100644 --- a/src/Language/PureScript/CST/Utils.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs @@ -1,24 +1,23 @@ -{-# LANGUAGE MonoLocalBinds #-} module Language.PureScript.CST.Utils where -import Prelude - -import Control.Monad (when) -import Data.Coerce (coerce) -import Data.Foldable (for_) -import Data.Functor (($>)) -import qualified Data.List.NonEmpty as NE -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as Text -import Language.PureScript.CST.Errors -import Language.PureScript.CST.Monad -import Language.PureScript.CST.Positions -import Language.PureScript.CST.Traversals.Type -import Language.PureScript.CST.Types -import qualified Language.PureScript.Names as N -import Language.PureScript.PSString (PSString, mkString) +import "base" Prelude + +import "base" Control.Monad (when) +import "base" Data.Coerce (coerce) +import "base" Data.Foldable (for_) +import "base" Data.Functor (($>)) +import qualified "base" Data.List.NonEmpty as NE +import "containers" Data.Set (Set) +import qualified "containers" Data.Set as Set +import "text" Data.Text (Text) +import qualified "text" Data.Text as Text +import "this" Language.PureScript.CST.Errors +import "this" Language.PureScript.CST.Monad +import "this" Language.PureScript.CST.Positions +import "this" Language.PureScript.CST.Traversals.Type +import "this" Language.PureScript.CST.Types +import qualified "purescript-ast" Language.PureScript.Names as N +import "purescript-ast" Language.PureScript.PSString (PSString, mkString) placeholder :: SourceToken placeholder = SourceToken diff --git a/lib/purescript-cst/tests/Main.hs b/lib/purescript-cst/tests/Main.hs new file mode 100644 index 0000000000..4e6da7007f --- /dev/null +++ b/lib/purescript-cst/tests/Main.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TupleSections #-} + +module Main (main) where + +import "base-compat" Prelude.Compat + +import "tasty" Test.Tasty + +import qualified "this" TestCst + +import "base" System.IO (hSetEncoding, stdout, stderr, utf8) + +main :: IO () +main = do + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + + cstTests <- TestCst.main + + defaultMain $ + testGroup + "Tests" + [ cstTests + ] diff --git a/tests/TestCst.hs b/lib/purescript-cst/tests/TestCst.hs similarity index 87% rename from tests/TestCst.hs rename to lib/purescript-cst/tests/TestCst.hs index b05bbee630..a885f3b426 100644 --- a/tests/TestCst.hs +++ b/lib/purescript-cst/tests/TestCst.hs @@ -1,25 +1,26 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} module TestCst where -import Prelude - -import Control.Monad (when) -import qualified Data.ByteString.Lazy as BS -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Text.IO as Text -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Golden (goldenVsString, findByExtension) -import Test.Tasty.QuickCheck -import Text.Read (readMaybe) -import Language.PureScript.CST.Errors as CST -import Language.PureScript.CST.Lexer as CST -import Language.PureScript.CST.Print as CST -import Language.PureScript.CST.Types -import System.FilePath (takeBaseName, replaceExtension) +import "base" Prelude + +import "base" Control.Monad (when) +import qualified "bytestring" Data.ByteString.Lazy as BS +import "base" Data.Maybe (fromMaybe) +import "text" Data.Text (Text) +import qualified "text" Data.Text as Text +import qualified "text" Data.Text.Encoding as Text +import qualified "text" Data.Text.IO as Text +import "tasty" Test.Tasty (TestTree, testGroup) +import "tasty-golden" Test.Tasty.Golden (goldenVsString, findByExtension) +import "tasty-quickcheck" Test.Tasty.QuickCheck +import "base" Text.Read (readMaybe) +import "purescript-cst" Language.PureScript.CST.Errors as CST +import "purescript-cst" Language.PureScript.CST.Lexer as CST +import "purescript-cst" Language.PureScript.CST.Print as CST +import "purescript-cst" Language.PureScript.CST.Types +import "filepath" System.FilePath (takeBaseName, replaceExtension) main :: IO TestTree main = do diff --git a/tests/purs/layout/.gitattributes b/lib/purescript-cst/tests/purs/layout/.gitattributes similarity index 100% rename from tests/purs/layout/.gitattributes rename to lib/purescript-cst/tests/purs/layout/.gitattributes diff --git a/tests/purs/layout/AdoIn.out b/lib/purescript-cst/tests/purs/layout/AdoIn.out similarity index 100% rename from tests/purs/layout/AdoIn.out rename to lib/purescript-cst/tests/purs/layout/AdoIn.out diff --git a/tests/purs/layout/AdoIn.purs b/lib/purescript-cst/tests/purs/layout/AdoIn.purs similarity index 100% rename from tests/purs/layout/AdoIn.purs rename to lib/purescript-cst/tests/purs/layout/AdoIn.purs diff --git a/tests/purs/layout/CaseGuards.out b/lib/purescript-cst/tests/purs/layout/CaseGuards.out similarity index 100% rename from tests/purs/layout/CaseGuards.out rename to lib/purescript-cst/tests/purs/layout/CaseGuards.out diff --git a/tests/purs/layout/CaseGuards.purs b/lib/purescript-cst/tests/purs/layout/CaseGuards.purs similarity index 100% rename from tests/purs/layout/CaseGuards.purs rename to lib/purescript-cst/tests/purs/layout/CaseGuards.purs diff --git a/tests/purs/layout/CaseWhere.out b/lib/purescript-cst/tests/purs/layout/CaseWhere.out similarity index 100% rename from tests/purs/layout/CaseWhere.out rename to lib/purescript-cst/tests/purs/layout/CaseWhere.out diff --git a/tests/purs/layout/CaseWhere.purs b/lib/purescript-cst/tests/purs/layout/CaseWhere.purs similarity index 100% rename from tests/purs/layout/CaseWhere.purs rename to lib/purescript-cst/tests/purs/layout/CaseWhere.purs diff --git a/tests/purs/layout/ClassHead.out b/lib/purescript-cst/tests/purs/layout/ClassHead.out similarity index 100% rename from tests/purs/layout/ClassHead.out rename to lib/purescript-cst/tests/purs/layout/ClassHead.out diff --git a/tests/purs/layout/ClassHead.purs b/lib/purescript-cst/tests/purs/layout/ClassHead.purs similarity index 100% rename from tests/purs/layout/ClassHead.purs rename to lib/purescript-cst/tests/purs/layout/ClassHead.purs diff --git a/tests/purs/layout/Commas.out b/lib/purescript-cst/tests/purs/layout/Commas.out similarity index 100% rename from tests/purs/layout/Commas.out rename to lib/purescript-cst/tests/purs/layout/Commas.out diff --git a/tests/purs/layout/Commas.purs b/lib/purescript-cst/tests/purs/layout/Commas.purs similarity index 100% rename from tests/purs/layout/Commas.purs rename to lib/purescript-cst/tests/purs/layout/Commas.purs diff --git a/tests/purs/layout/Delimiter.out b/lib/purescript-cst/tests/purs/layout/Delimiter.out similarity index 100% rename from tests/purs/layout/Delimiter.out rename to lib/purescript-cst/tests/purs/layout/Delimiter.out diff --git a/tests/purs/layout/Delimiter.purs b/lib/purescript-cst/tests/purs/layout/Delimiter.purs similarity index 100% rename from tests/purs/layout/Delimiter.purs rename to lib/purescript-cst/tests/purs/layout/Delimiter.purs diff --git a/tests/purs/layout/DoLet.out b/lib/purescript-cst/tests/purs/layout/DoLet.out similarity index 100% rename from tests/purs/layout/DoLet.out rename to lib/purescript-cst/tests/purs/layout/DoLet.out diff --git a/tests/purs/layout/DoLet.purs b/lib/purescript-cst/tests/purs/layout/DoLet.purs similarity index 100% rename from tests/purs/layout/DoLet.purs rename to lib/purescript-cst/tests/purs/layout/DoLet.purs diff --git a/tests/purs/layout/DoOperator.out b/lib/purescript-cst/tests/purs/layout/DoOperator.out similarity index 100% rename from tests/purs/layout/DoOperator.out rename to lib/purescript-cst/tests/purs/layout/DoOperator.out diff --git a/tests/purs/layout/DoOperator.purs b/lib/purescript-cst/tests/purs/layout/DoOperator.purs similarity index 100% rename from tests/purs/layout/DoOperator.purs rename to lib/purescript-cst/tests/purs/layout/DoOperator.purs diff --git a/tests/purs/layout/DoWhere.out b/lib/purescript-cst/tests/purs/layout/DoWhere.out similarity index 100% rename from tests/purs/layout/DoWhere.out rename to lib/purescript-cst/tests/purs/layout/DoWhere.out diff --git a/tests/purs/layout/DoWhere.purs b/lib/purescript-cst/tests/purs/layout/DoWhere.purs similarity index 100% rename from tests/purs/layout/DoWhere.purs rename to lib/purescript-cst/tests/purs/layout/DoWhere.purs diff --git a/tests/purs/layout/IfThenElseDo.out b/lib/purescript-cst/tests/purs/layout/IfThenElseDo.out similarity index 100% rename from tests/purs/layout/IfThenElseDo.out rename to lib/purescript-cst/tests/purs/layout/IfThenElseDo.out diff --git a/tests/purs/layout/IfThenElseDo.purs b/lib/purescript-cst/tests/purs/layout/IfThenElseDo.purs similarity index 100% rename from tests/purs/layout/IfThenElseDo.purs rename to lib/purescript-cst/tests/purs/layout/IfThenElseDo.purs diff --git a/tests/purs/layout/InstanceChainElse.out b/lib/purescript-cst/tests/purs/layout/InstanceChainElse.out similarity index 100% rename from tests/purs/layout/InstanceChainElse.out rename to lib/purescript-cst/tests/purs/layout/InstanceChainElse.out diff --git a/tests/purs/layout/InstanceChainElse.purs b/lib/purescript-cst/tests/purs/layout/InstanceChainElse.purs similarity index 100% rename from tests/purs/layout/InstanceChainElse.purs rename to lib/purescript-cst/tests/purs/layout/InstanceChainElse.purs diff --git a/tests/purs/layout/LetGuards.out b/lib/purescript-cst/tests/purs/layout/LetGuards.out similarity index 100% rename from tests/purs/layout/LetGuards.out rename to lib/purescript-cst/tests/purs/layout/LetGuards.out diff --git a/tests/purs/layout/LetGuards.purs b/lib/purescript-cst/tests/purs/layout/LetGuards.purs similarity index 100% rename from tests/purs/layout/LetGuards.purs rename to lib/purescript-cst/tests/purs/layout/LetGuards.purs diff --git a/license-generator/generate.hs b/license-generator/generate.hs index f2e389c113..a439175eb6 100644 --- a/license-generator/generate.hs +++ b/license-generator/generate.hs @@ -59,9 +59,13 @@ depsNamesAndVersions :: IO [(String, String)] depsNamesAndVersions = do contents <- lines <$> getContents deps <- traverse parse contents - pure (filter (\(name, _) -> name /= "purescript" && name /= "rts") deps) + pure (filter (\(name, _) -> not (excluded name)) deps) where + excluded name = + name == "purescript" + || name == "rts" + parse line = case splitOn " " line of [pkg, vers] -> pure (pkg, vers) diff --git a/package.yaml b/package.yaml index 16dc5ba741..773e2087d4 100644 --- a/package.yaml +++ b/package.yaml @@ -56,7 +56,6 @@ dependencies: - data-ordlist >=0.4.7.0 - deepseq - directory >=1.2.3 - - dlist - edit-distance - file-embed - filepath @@ -76,9 +75,10 @@ dependencies: - pattern-arrows >=0.0.2 && <0.1 - process >=1.2.0 && <1.7 - protolude >=0.1.6 && <0.2.4 + - purescript-ast + - purescript-cst - regex-tdfa - safe >=0.3.9 && <0.4 - - scientific >=0.3.4.9 && <0.4 - semigroups >=0.16.2 && <0.19 - semialign >=1 && <1.1 - sourcemap >=0.1.6 diff --git a/src/Language/PureScript/AST.hs b/src/Language/PureScript/AST.hs deleted file mode 100644 index fe82e27200..0000000000 --- a/src/Language/PureScript/AST.hs +++ /dev/null @@ -1,14 +0,0 @@ --- | --- The initial PureScript AST --- -module Language.PureScript.AST ( - module AST -) where - -import Language.PureScript.AST.Binders as AST -import Language.PureScript.AST.Declarations as AST -import Language.PureScript.AST.Exported as AST -import Language.PureScript.AST.Literals as AST -import Language.PureScript.AST.Operators as AST -import Language.PureScript.AST.SourcePos as AST -import Language.PureScript.AST.Traversals as AST diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 4153fbbf44..3f4344b94b 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -38,7 +38,7 @@ import Language.PureScript.Names import Language.PureScript.Options import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Traversals (sndM) -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prim as C import System.FilePath.Posix (()) diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants/Prelude.hs similarity index 68% rename from src/Language/PureScript/Constants.hs rename to src/Language/PureScript/Constants/Prelude.hs index d2b01ed7fe..a816c8f79a 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -1,5 +1,5 @@ -- | Various constants which refer to things in the Prelude -module Language.PureScript.Constants where +module Language.PureScript.Constants.Prelude where import Prelude.Compat @@ -240,11 +240,6 @@ mkEffectFn = "mkEffectFn" runEffectFn :: forall a. (IsString a) => a runEffectFn = "runEffectFn" --- Prim values - -undefined :: forall a. (IsString a) => a -undefined = "undefined" - -- Type Class Dictionary Names data EffectDictionaries = EffectDictionaries @@ -373,112 +368,6 @@ toSignature = "toSignature" main :: forall a. (IsString a) => a main = "main" --- Prim - -partial :: forall a. (IsString a) => a -partial = "Partial" - -pattern Prim :: ModuleName -pattern Prim = ModuleName [ProperName "Prim"] - -pattern Partial :: Qualified (ProperName 'ClassName) -pattern Partial = Qualified (Just Prim) (ProperName "Partial") - -pattern Record :: Qualified (ProperName 'TypeName) -pattern Record = Qualified (Just Prim) (ProperName "Record") - --- Prim.Boolean - -pattern PrimBoolean :: ModuleName -pattern PrimBoolean = ModuleName [ProperName "Prim", ProperName "Boolean"] - -booleanTrue :: Qualified (ProperName 'TypeName) -booleanTrue = Qualified (Just PrimBoolean) (ProperName "True") - -booleanFalse :: Qualified (ProperName 'TypeName) -booleanFalse = Qualified (Just PrimBoolean) (ProperName "False") - --- Prim.Coerce - -pattern PrimCoerce :: ModuleName -pattern PrimCoerce = ModuleName [ProperName "Prim", ProperName "Coerce"] - -pattern Coercible :: Qualified (ProperName 'ClassName) -pattern Coercible = Qualified (Just PrimCoerce) (ProperName "Coercible") - --- Prim.Ordering - -pattern PrimOrdering :: ModuleName -pattern PrimOrdering = ModuleName [ProperName "Prim", ProperName "Ordering"] - -orderingLT :: Qualified (ProperName 'TypeName) -orderingLT = Qualified (Just PrimOrdering) (ProperName "LT") - -orderingEQ :: Qualified (ProperName 'TypeName) -orderingEQ = Qualified (Just PrimOrdering) (ProperName "EQ") - -orderingGT :: Qualified (ProperName 'TypeName) -orderingGT = Qualified (Just PrimOrdering) (ProperName "GT") - --- Prim.Row - -pattern PrimRow :: ModuleName -pattern PrimRow = ModuleName [ProperName "Prim", ProperName "Row"] - -pattern RowUnion :: Qualified (ProperName 'ClassName) -pattern RowUnion = Qualified (Just PrimRow) (ProperName "Union") - -pattern RowNub :: Qualified (ProperName 'ClassName) -pattern RowNub = Qualified (Just PrimRow) (ProperName "Nub") - -pattern RowCons :: Qualified (ProperName 'ClassName) -pattern RowCons = Qualified (Just PrimRow) (ProperName "Cons") - -pattern RowLacks :: Qualified (ProperName 'ClassName) -pattern RowLacks = Qualified (Just PrimRow) (ProperName "Lacks") - --- Prim.RowList - -pattern PrimRowList :: ModuleName -pattern PrimRowList = ModuleName [ProperName "Prim", ProperName "RowList"] - -pattern RowToList :: Qualified (ProperName 'ClassName) -pattern RowToList = Qualified (Just PrimRowList) (ProperName "RowToList") - -pattern RowListNil :: Qualified (ProperName 'TypeName) -pattern RowListNil = Qualified (Just PrimRowList) (ProperName "Nil") - -pattern RowListCons :: Qualified (ProperName 'TypeName) -pattern RowListCons = Qualified (Just PrimRowList) (ProperName "Cons") - --- Prim.Symbol - -pattern PrimSymbol :: ModuleName -pattern PrimSymbol = ModuleName [ProperName "Prim", ProperName "Symbol"] - -pattern SymbolCompare :: Qualified (ProperName 'ClassName) -pattern SymbolCompare = Qualified (Just PrimSymbol) (ProperName "Compare") - -pattern SymbolAppend :: Qualified (ProperName 'ClassName) -pattern SymbolAppend = Qualified (Just PrimSymbol) (ProperName "Append") - -pattern SymbolCons :: Qualified (ProperName 'ClassName) -pattern SymbolCons = Qualified (Just PrimSymbol) (ProperName "Cons") - --- Prim.TypeError - -pattern PrimTypeError :: ModuleName -pattern PrimTypeError = ModuleName [ProperName "Prim", ProperName "TypeError"] - -pattern Fail :: Qualified (ProperName 'ClassName) -pattern Fail = Qualified (Just PrimTypeError) (ProperName "Fail") - -pattern Warn :: Qualified (ProperName 'ClassName) -pattern Warn = Qualified (Just PrimTypeError) (ProperName "Warn") - -primModules :: [ModuleName] -primModules = [Prim, PrimBoolean, PrimCoerce, PrimOrdering, PrimRow, PrimRowList, PrimSymbol, PrimTypeError] - -- Data.Symbol pattern DataSymbol :: ModuleName @@ -487,50 +376,6 @@ pattern DataSymbol = ModuleName [ProperName "Data", ProperName "Symbol"] pattern IsSymbol :: Qualified (ProperName 'ClassName) pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol") -typ :: forall a. (IsString a) => a -typ = "Type" - -kindBoolean :: forall a. (IsString a) => a -kindBoolean = "Boolean" - -kindOrdering :: forall a. (IsString a) => a -kindOrdering = "Ordering" - -kindRowList :: forall a. (IsString a) => a -kindRowList = "RowList" - -symbol :: forall a. (IsString a) => a -symbol = "Symbol" - -doc :: forall a. (IsString a) => a -doc = "Doc" - --- Modules - -prim :: forall a. (IsString a) => a -prim = "Prim" - -moduleBoolean :: forall a. (IsString a) => a -moduleBoolean = "Boolean" - -moduleCoerce :: forall a. (IsString a) => a -moduleCoerce = "Coerce" - -moduleOrdering :: forall a. (IsString a) => a -moduleOrdering = "Ordering" - -moduleRow :: forall a. (IsString a) => a -moduleRow = "Row" - -moduleRowList :: forall a. (IsString a) => a -moduleRowList = "RowList" - -moduleSymbol :: forall a. (IsString a) => a -moduleSymbol = "Symbol" - -typeError :: forall a. (IsString a) => a -typeError = "TypeError" - prelude :: forall a. (IsString a) => a prelude = "Prelude" diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 3ab44b09be..7d060f734f 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -28,7 +28,7 @@ import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDic import Language.PureScript.Types import Language.PureScript.PSString (mkString) import qualified Language.PureScript.AST as A -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prim as C -- | Desugars a module from AST to CoreFn representation. moduleToCoreFn :: Environment -> A.Module -> Module Ann diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 44567022d4..07437a5d24 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -12,7 +12,7 @@ import Language.PureScript.CoreFn.Traversals import Language.PureScript.Names (Ident(UnusedIdent), Qualified(Qualified)) import Language.PureScript.Label import Language.PureScript.Types -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prim as C -- | -- CoreFn optimization pass. diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index 4b627abd06..6c367e99a0 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -25,7 +25,8 @@ import Language.PureScript.PSString (PSString) import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Common import Language.PureScript.AST (SourceSpan(..)) -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Prim as C -- TODO: Potential bug: -- Shouldn't just inline this case: { var x = 0; x.toFixed(10); } diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs index c14988f50a..59dc7bc2c8 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs @@ -11,7 +11,7 @@ import Data.Text (Text) import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Common import Language.PureScript.PSString (mkString) -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prelude as C -- | Inline type class dictionaries for >>= and return for the Eff monad -- diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index 2b0f077a06..6aa53905b6 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -4,7 +4,7 @@ module Language.PureScript.CoreImp.Optimizer.TCO (tco) where import Prelude.Compat import Data.Text (Text) -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.CoreImp.AST import Language.PureScript.AST.SourcePos (SourceSpan) import Safe (headDef, tailSafe) diff --git a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs index 4dc5ceb0cf..54ef0fc832 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs @@ -8,7 +8,7 @@ import Prelude.Compat import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Common -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prim as C removeCodeAfterReturnStatements :: AST -> AST removeCodeAfterReturnStatements = everywhere (removeFromBlock go) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index d7c8c3b5ab..ff87023deb 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -29,10 +29,12 @@ import qualified Data.Text as T import Data.Text (Text) import Language.PureScript.AST import qualified Language.PureScript.Bundle as Bundle -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.Crash import qualified Language.PureScript.CST.Errors as CST import Language.PureScript.Environment +import qualified Language.PureScript.Kinds as Kinds import Language.PureScript.Label (Label(..)) import Language.PureScript.Names import Language.PureScript.Pretty @@ -47,6 +49,127 @@ import qualified Text.Parsec.Error as PE import Text.Parsec.Error (Message(..)) import qualified Text.PrettyPrint.Boxes as Box +-- | A type of error messages +data SimpleErrorMessage + = ModuleNotFound ModuleName + | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) + | ErrorParsingModule P.ParseError + | ErrorParsingCSTModule CST.ParserError + | MissingFFIModule ModuleName + | UnnecessaryFFIModule ModuleName FilePath + | MissingFFIImplementations ModuleName [Ident] + | UnusedFFIImplementations ModuleName [Ident] + | InvalidFFIIdentifier ModuleName Text + | FileIOError Text IOError -- ^ A description of what we were trying to do, and the error which occurred + | InfiniteType SourceType + | InfiniteKind Kinds.SourceKind + | MultipleValueOpFixities (OpName 'ValueOpName) + | MultipleTypeOpFixities (OpName 'TypeOpName) + | OrphanTypeDeclaration Ident + | RedefinedIdent Ident + | OverlappingNamesInLet + | UnknownName (Qualified Name) + | UnknownImport ModuleName Name + | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName) + | UnknownExport Name + | UnknownExportDataConstructor (ProperName 'TypeName) (ProperName 'ConstructorName) + | ScopeConflict Name [ModuleName] + | ScopeShadowing Name (Maybe ModuleName) [ModuleName] + | DeclConflict Name Name + | ExportConflict (Qualified Name) (Qualified Name) + | DuplicateModule ModuleName + | DuplicateTypeClass (ProperName 'ClassName) SourceSpan + | DuplicateInstance Ident SourceSpan + | DuplicateTypeArgument Text + | InvalidDoBind + | InvalidDoLet + | CycleInDeclaration Ident + | CycleInTypeSynonym (Maybe (ProperName 'TypeName)) + | CycleInTypeClassDeclaration [Qualified (ProperName 'ClassName)] + | CycleInModules [ModuleName] + | NameIsUndefined Ident + | UndefinedTypeVariable (ProperName 'TypeName) + | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName)) + | EscapedSkolem Text (Maybe SourceSpan) SourceType + | TypesDoNotUnify SourceType SourceType + | KindsDoNotUnify Kinds.SourceKind Kinds.SourceKind + | ConstrainedTypeUnified SourceType SourceType + | OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified Ident] + | NoInstanceFound SourceConstraint + | AmbiguousTypeVariables SourceType [Int] + | UnknownClass (Qualified (ProperName 'ClassName)) + | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [SourceType] + | CannotDerive (Qualified (ProperName 'ClassName)) [SourceType] + | InvalidDerivedInstance (Qualified (ProperName 'ClassName)) [SourceType] Int + | ExpectedTypeConstructor (Qualified (ProperName 'ClassName)) [SourceType] SourceType + | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [SourceType] + | MissingNewtypeSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType] + | UnverifiableSuperclassInstance (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'ClassName)) [SourceType] + | CannotFindDerivingType (ProperName 'TypeName) + | DuplicateLabel Label (Maybe Expr) + | DuplicateValueDeclaration Ident + | ArgListLengthsDiffer Ident + | OverlappingArgNames (Maybe Ident) + | MissingClassMember (NEL.NonEmpty (Ident, SourceType)) + | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName)) + | ExpectedType SourceType Kinds.SourceKind + -- | constructor name, expected argument count, actual argument count + | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName)) Int Int + | ExprDoesNotHaveType Expr SourceType + | PropertyIsMissing Label + | AdditionalProperty Label + | TypeSynonymInstance + | OrphanInstance Ident (Qualified (ProperName 'ClassName)) (S.Set ModuleName) [SourceType] + | InvalidNewtype (ProperName 'TypeName) + | InvalidInstanceHead SourceType + | TransitiveExportError DeclarationRef [DeclarationRef] + | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName) + | ShadowedName Ident + | ShadowedTypeVar Text + | UnusedTypeVar Text + | WildcardInferredType SourceType Context + | HoleInferredType Text SourceType Context (Maybe TypeSearch) + | MissingTypeDeclaration Ident SourceType + | OverlappingPattern [[Binder]] Bool + | IncompleteExhaustivityCheck + | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName) + | ImportHidingModule ModuleName + | UnusedImport ModuleName (Maybe ModuleName) + | UnusedExplicitImport ModuleName [Name] (Maybe ModuleName) [DeclarationRef] + | UnusedDctorImport ModuleName (ProperName 'TypeName) (Maybe ModuleName) [DeclarationRef] + | UnusedDctorExplicitImport ModuleName (ProperName 'TypeName) [ProperName 'ConstructorName] (Maybe ModuleName) [DeclarationRef] + | DuplicateSelectiveImport ModuleName + | DuplicateImport ModuleName ImportDeclarationType (Maybe ModuleName) + | DuplicateImportRef Name + | DuplicateExportRef Name + | IntOutOfRange Integer Text Integer Integer + | ImplicitQualifiedImport ModuleName ModuleName [DeclarationRef] + | ImplicitQualifiedImportReExport ModuleName ModuleName [DeclarationRef] + | ImplicitImport ModuleName [DeclarationRef] + | HidingImport ModuleName [DeclarationRef] + | CaseBinderLengthDiffers Int [Binder] + | IncorrectAnonymousArgument + | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident) + | CannotGeneralizeRecursiveFunction Ident SourceType + | CannotDeriveNewtypeForData (ProperName 'TypeName) + | ExpectedWildcard (ProperName 'TypeName) + | CannotUseBindWithDo Ident + -- | instance name, type class, expected argument count, actual argument count + | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int + -- | a user-defined warning raised by using the Warn type class + | UserDefinedWarning SourceType + -- | a declaration couldn't be used because it contained free variables + | UnusableDeclaration Ident [[Text]] + | CannotDefinePrimModules ModuleName + | MixedAssociativityError (NEL.NonEmpty (Qualified (OpName 'AnyOpName), Associativity)) + | NonAssociativeError (NEL.NonEmpty (Qualified (OpName 'AnyOpName))) + deriving (Show) + +data ErrorMessage = ErrorMessage + [ErrorMessageHint] + SimpleErrorMessage + deriving (Show) + newtype ErrorSuggestion = ErrorSuggestion Text -- | Get the source span for an error diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 46e55f44cd..89111daf55 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -37,7 +37,7 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Text as T import qualified Language.PureScript as P -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prim as C import qualified Language.PureScript.CST as CST import Language.PureScript.Ide.Completion import Language.PureScript.Ide.Error diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index c58550c918..8b904d22fd 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -4,7 +4,7 @@ import Protolude import qualified Data.Map as Map import qualified Data.Set as Set import qualified Language.PureScript as P -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prim as C import qualified Language.PureScript.Environment as PEnv import Language.PureScript.Ide.Types diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index c4b2f8e2f6..6d26bf1655 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -30,7 +30,7 @@ import Control.Monad.Writer.Strict (Writer(), runWriter) import qualified Language.PureScript as P import qualified Language.PureScript.CST as CST import qualified Language.PureScript.Names as N -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.Interactive.Completion as Interactive import Language.PureScript.Interactive.IO as Interactive diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 27562b435a..ad4bc5da72 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -35,7 +35,7 @@ import Language.PureScript.Names as P import Language.PureScript.Pretty.Values (prettyPrintBinderAtom) import Language.PureScript.Traversals import Language.PureScript.Types as P -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prim as C -- | There are two modes of failure for the redundancy check: -- diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 77a292abd5..09321d0f57 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -27,7 +27,7 @@ import Language.PureScript.Names import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) import Language.PureScript.Sugar.Names.Env import Language.PureScript.Sugar.Names.Imports -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prim as C -- | -- Map of module name to list of imported names from that module which have diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index 289ecbbe7b..8050e2e483 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -33,7 +33,6 @@ import qualified Data.ByteString as B import Data.Text (Text) import qualified Data.Text as Text import Data.Time.Clock (UTCTime) -import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Externs (ExternsFile, externsIsCurrentVersion) import Language.PureScript.Make.Cache (ContentHash, hash) diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 5a5d12f1e7..d57497f040 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -11,7 +11,7 @@ import Protolude hiding (head) import Data.Graph import qualified Data.Set as S import Language.PureScript.AST -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.Crash import Language.PureScript.Errors hiding (nonEmpty) import Language.PureScript.Names diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs index 46f12a1839..496b0e7e01 100644 --- a/src/Language/PureScript/Sugar/AdoNotation.hs +++ b/src/Language/PureScript/Sugar/AdoNotation.hs @@ -14,7 +14,7 @@ import Data.List (foldl') import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Names -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prelude as C -- | Replace all @AdoNotationBind@ and @AdoNotationValue@ constructors with -- applications of the pure and apply functions in scope, and all @AdoNotationLet@ diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index d7a9f7194e..2b253169f3 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -16,7 +16,7 @@ import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.Names -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prelude as C -- | Replace all @DoNotationBind@ and @DoNotationValue@ constructors with -- applications of the bind function in scope, and all @DoNotationLet@ diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 163402b014..55bd26c973 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -36,7 +36,7 @@ import Safe (headMay) import qualified Data.Map as M import qualified Data.Set as S -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.AST import Language.PureScript.Environment import Language.PureScript.Errors diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 1d0bb8aec4..1e0f6b9775 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -37,7 +37,7 @@ import Data.Maybe (mapMaybe, listToMaybe) import Data.Traversable (for) import qualified Data.Map as M -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prelude as C -- | -- Removes unary negation operators and replaces them with calls to `negate`. diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 5b6f40522f..af71afc9e7 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -21,7 +21,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe) import qualified Data.List.NonEmpty as NEL import qualified Data.Set as S import Data.Text (Text) -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors hiding (isExported) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 82e11a732e..9cb3f9f42e 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -17,7 +17,8 @@ import Data.Ord (comparing) import qualified Data.Set as S import Data.Text (Text) import Language.PureScript.AST -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index e37549962a..9168b09738 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -47,7 +47,8 @@ import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types import Language.PureScript.Label (Label(..)) import Language.PureScript.PSString (PSString, mkString, decodeString) -import qualified Language.PureScript.Constants as C +import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Prim as C -- | Describes what sort of dictionary to generate for type class instances data Evidence diff --git a/stack.yaml b/stack.yaml index 85af85f65a..1c83932f7e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,8 @@ resolver: lts-13.26 pvp-bounds: upper packages: - '.' +- lib/purescript-ast +- lib/purescript-cst extra-deps: - happy-1.19.9 - language-javascript-0.7.0.0 diff --git a/tests/Main.hs b/tests/Main.hs index 1f2ccdc902..2617d33e9e 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -10,7 +10,6 @@ import Prelude.Compat import Test.Tasty -import qualified TestCst import qualified TestCompiler import qualified TestCoreFn import qualified TestDocs @@ -34,7 +33,6 @@ main = do heading "Updating support code" TestUtils.updateSupportCode - cstTests <- TestCst.main ideTests <- TestIde.main compilerTests <- TestCompiler.main makeTests <- TestMake.main @@ -50,8 +48,7 @@ main = do defaultMain $ testGroup "Tests" - [ cstTests - , compilerTests + [ compilerTests , makeTests , psciTests , pscBundleTests From 3a8e2e260c4065426ab2c86ccb881299f9cc4ef2 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Fri, 13 Mar 2020 10:05:57 -0400 Subject: [PATCH 1190/1580] Add golden tests for Coercible (#3810) --- tests/purs/failing/CoercibleForeign.out | 24 +++++++++++++++++ tests/purs/failing/CoercibleNominal.out | 26 +++++++++++++++++++ .../purs/failing/CoercibleNominalTypeApp.out | 19 ++++++++++++++ .../purs/failing/CoercibleNominalWrapped.out | 24 +++++++++++++++++ .../failing/CoercibleRepresentational.out | 24 +++++++++++++++++ .../failing/CoercibleRepresentational2.out | 19 ++++++++++++++ .../failing/CoercibleRepresentational3.out | 19 ++++++++++++++ 7 files changed, 155 insertions(+) create mode 100644 tests/purs/failing/CoercibleForeign.out create mode 100644 tests/purs/failing/CoercibleNominal.out create mode 100644 tests/purs/failing/CoercibleNominalTypeApp.out create mode 100644 tests/purs/failing/CoercibleNominalWrapped.out create mode 100644 tests/purs/failing/CoercibleRepresentational.out create mode 100644 tests/purs/failing/CoercibleRepresentational2.out create mode 100644 tests/purs/failing/CoercibleRepresentational3.out diff --git a/tests/purs/failing/CoercibleForeign.out b/tests/purs/failing/CoercibleForeign.out new file mode 100644 index 0000000000..0e4fcad418 --- /dev/null +++ b/tests/purs/failing/CoercibleForeign.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleForeign.purs:11:20 - 11:26 (line 11, column 20 - line 11, column 26) + + No type class instance was found for +   +  Prim.Coerce.Coercible (Foreign a0 b1)  +  (Foreign (Id a0) (Id b1)) +   + +while checking that type forall a b. Coercible a b => a -> b + is at least as general as type Foreign a0 b1 -> Foreign (Id a0) (Id b1) +while checking that expression coerce + has type Foreign a0 b1 -> Foreign (Id a0) (Id b1) +in value declaration foreignToForeign + +where b1 is a rigid type variable + bound at (line 11, column 20 - line 11, column 26) + a0 is a rigid type variable + bound at (line 11, column 20 - line 11, column 26) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleNominal.out b/tests/purs/failing/CoercibleNominal.out new file mode 100644 index 0000000000..9a2dc1f70f --- /dev/null +++ b/tests/purs/failing/CoercibleNominal.out @@ -0,0 +1,26 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleNominal.purs:11:20 - 11:26 (line 11, column 20 - line 11, column 26) + + No type class instance was found for +   +  Prim.Coerce.Coercible (Nominal a0 c1) +  (Nominal b2 c1) +   + +while checking that type forall a b. Coercible a b => a -> b + is at least as general as type Nominal a0 c1 -> Nominal b2 c1 +while checking that expression coerce + has type Nominal a0 c1 -> Nominal b2 c1 +in value declaration nominalToNominal + +where c1 is a rigid type variable + bound at (line 11, column 20 - line 11, column 26) + b2 is a rigid type variable + bound at (line 11, column 20 - line 11, column 26) + a0 is a rigid type variable + bound at (line 11, column 20 - line 11, column 26) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleNominalTypeApp.out b/tests/purs/failing/CoercibleNominalTypeApp.out new file mode 100644 index 0000000000..8f97e980c1 --- /dev/null +++ b/tests/purs/failing/CoercibleNominalTypeApp.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleNominalTypeApp.purs:13:8 - 13:14 (line 13, column 8 - line 13, column 14) + + No type class instance was found for +   +  Prim.Coerce.Coercible (G Maybe Int)  +  (G Maybe String) +   + +while checking that type forall a b. Coercible a b => a -> b + is at least as general as type G Maybe Int -> G Maybe String +while checking that expression coerce + has type G Maybe Int -> G Maybe String +in value declaration gToG + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleNominalWrapped.out b/tests/purs/failing/CoercibleNominalWrapped.out new file mode 100644 index 0000000000..e3204cb43d --- /dev/null +++ b/tests/purs/failing/CoercibleNominalWrapped.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleNominalWrapped.purs:15:14 - 15:20 (line 15, column 14 - line 15, column 20) + + No type class instance was found for +   +  Prim.Coerce.Coercible (Wrap a0 b1)  +  (Wrap (Id a0) b1) +   + +while checking that type forall a b. Coercible a b => a -> b + is at least as general as type Wrap a0 b1 -> Wrap (Id a0) b1 +while checking that expression coerce + has type Wrap a0 b1 -> Wrap (Id a0) b1 +in value declaration wrapToWrap + +where b1 is a rigid type variable + bound at (line 15, column 14 - line 15, column 20) + a0 is a rigid type variable + bound at (line 15, column 14 - line 15, column 20) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleRepresentational.out b/tests/purs/failing/CoercibleRepresentational.out new file mode 100644 index 0000000000..a29e257444 --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleRepresentational.purs:11:20 - 11:26 (line 11, column 20 - line 11, column 26) + + No type class instance was found for +   +  Prim.Coerce.Coercible a0 +  b1 +   + +while checking that type forall a b. Coercible a b => a -> b + is at least as general as type Phantom a0 -> Phantom b1 +while checking that expression coerce + has type Phantom a0 -> Phantom b1 +in value declaration phantomToPhantom + +where b1 is a rigid type variable + bound at (line 11, column 20 - line 11, column 26) + a0 is a rigid type variable + bound at (line 11, column 20 - line 11, column 26) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleRepresentational2.out b/tests/purs/failing/CoercibleRepresentational2.out new file mode 100644 index 0000000000..a6a3b6754c --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational2.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleRepresentational2.purs:9:14 - 9:20 (line 9, column 14 - line 9, column 20) + + No type class instance was found for +   +  Prim.Coerce.Coercible Int  +  String +   + +while checking that type forall a b. Coercible a b => a -> b + is at least as general as type Arr1 Int -> Arr1 String +while checking that expression coerce + has type Arr1 Int -> Arr1 String +in value declaration arr1ToArr1 + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleRepresentational3.out b/tests/purs/failing/CoercibleRepresentational3.out new file mode 100644 index 0000000000..bb9e963db7 --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational3.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleRepresentational3.purs:9:14 - 9:20 (line 9, column 14 - line 9, column 20) + + No type class instance was found for +   +  Prim.Coerce.Coercible Int  +  String +   + +while checking that type forall a b. Coercible a b => a -> b + is at least as general as type Rec1 Int -> Rec1 String +while checking that expression coerce + has type Rec1 Int -> Rec1 String +in value declaration arr1ToArr1 + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + From b20aa4c46108eb83f5c92810644f8187389b4642 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sat, 14 Mar 2020 08:38:46 -0700 Subject: [PATCH 1191/1580] Polykinds (#3779) * WIP Kinds are Types * Remove more kind stuff, add polymorphic signatures to env * WIP kind checker * WIP * Kind elaborate instance heads, fix row kind checking * Fix parsing, make a pass at kind args in type synonyms * WIP Most tests passing * Fix extern kind args for constraints * Throw unification error instead of internal error * Fix more tests * Better InfiniteKind2 test * Some doc test fixes * Fix up doc tests, printer, ambiguity check * Add a kind for constraints * Add kind signatures * Replace type synonyms in kinds * Add parser warnings * Add check/infer hints to kinds checker * Wildcard check for ty var bindings * Wildcard check for kind signatures * Cleanup errors * Cleanup non-verbose errors, fix forall order * WIP * More tests and fixes * Generalize kinds in kind declarations, support rows in kinds * Apply provided ty var annotations, cleanup * Generalize kinds in type synonym bodies * Generalize type synonym bodies after generalizing for the binding group * Add subsumption and skolem check for higher rank kinds * Add fix suggestions for syntax warnings * Derived ord instance was incorrect * Remove unused code * Fix traversals for kinds in constraints * Fresh names for scoped vars * Add better quantification checks, fix synonym hygiene * Throw unsupported error in elaborateKind * Fix cst traversal for types * Fixes the Externs extraction process for the IDE (#2) * Fix quantification check failure in doc test * Quantification check for constraint kind args * Add internal compiler error type * Backwards compatible json parser * Add check for visible dependent quantification * Generalize kinds in foreign imports * Update test deps to branches * Add better quantification check error * Fix test * Fix some traversals that will likely cause problems * Fix generalization issues with data binding groups * Carry more kinds around in solver, solve Lacks for empty rows * Add prim dict synonyms to environment * Fix synonym check for data constructors * Less kind inference for unknowns * Kind inference during generalization doesn't appear to be necessary * Use faster instantiateKind instead of checkKind during type unification * Update Coercible to work with PolyKinds * Move constraint check to parser * Add test for contextual keyword labels * Move constraint check to only foreign data decls * Missing withFreshSubstitution * Fix warning * Use emtpty data for foreign import kind * Updated golden tests for errors * Generalize type class data, unify kinds during solving * Add please report to internal compiler error * Use internalCompilerError for solveType * Remove todo * Remove old kind code * Add warning and suggestion for polykinds * Fix tests, and test for polykind warning * Fix doc * Fix todo with internalError * Add test for polykinded row cons * Corrected comment for elaborateKind Co-authored-by: Christoph Hegemann <6189397+kritzcreek@users.noreply.github.com> Co-authored-by: joneshf --- app/Command/Hierarchy.hs | 2 +- .../Language/PureScript/AST/Declarations.hs | 82 +- .../src/Language/PureScript/AST/Traversals.hs | 55 +- .../src/Language/PureScript/Constants/Prim.hs | 21 + .../src/Language/PureScript/Environment.hs | 246 ++-- .../src/Language/PureScript/Kinds.hs | 177 --- .../src/Language/PureScript/Names.hs | 6 - .../PureScript/TypeClassDictionaries.hs | 6 +- .../src/Language/PureScript/Types.hs | 321 +++-- .../src/Language/PureScript/CST/Convert.hs | 64 +- .../src/Language/PureScript/CST/Errors.hs | 38 +- .../src/Language/PureScript/CST/Flatten.hs | 50 + .../src/Language/PureScript/CST/Lexer.hs | 2 +- .../src/Language/PureScript/CST/Monad.hs | 31 +- .../src/Language/PureScript/CST/Parser.y | 92 +- .../src/Language/PureScript/CST/Positions.hs | 13 +- .../PureScript/CST/Traversals/Type.hs | 3 +- .../src/Language/PureScript/CST/Types.hs | 21 +- src/Language/PureScript.hs | 1 - src/Language/PureScript/CST.hs | 20 +- src/Language/PureScript/CoreFn/Optimizer.hs | 2 +- src/Language/PureScript/Docs/AsHtml.hs | 5 +- src/Language/PureScript/Docs/Convert.hs | 2 +- .../PureScript/Docs/Convert/ReExports.hs | 26 +- .../PureScript/Docs/Convert/Single.hs | 3 - src/Language/PureScript/Docs/Prim.hs | 63 +- src/Language/PureScript/Docs/Render.hs | 15 +- src/Language/PureScript/Docs/RenderedCode.hs | 1 - .../Docs/RenderedCode/RenderKind.hs | 57 - .../Docs/RenderedCode/RenderType.hs | 29 +- .../PureScript/Docs/RenderedCode/Types.hs | 12 - src/Language/PureScript/Docs/Types.hs | 40 +- src/Language/PureScript/Errors.hs | 224 +++- src/Language/PureScript/Errors/JSON.hs | 4 +- src/Language/PureScript/Externs.hs | 37 +- src/Language/PureScript/Hierarchy.hs | 2 +- src/Language/PureScript/Ide/CaseSplit.hs | 6 +- src/Language/PureScript/Ide/Completion.hs | 7 +- src/Language/PureScript/Ide/Externs.hs | 110 +- .../PureScript/Ide/Filter/Declaration.hs | 3 - src/Language/PureScript/Ide/Imports.hs | 4 +- src/Language/PureScript/Ide/Prim.hs | 26 +- src/Language/PureScript/Ide/Rebuild.hs | 4 +- src/Language/PureScript/Ide/Reexports.hs | 2 - src/Language/PureScript/Ide/SourceFile.hs | 4 +- src/Language/PureScript/Ide/State.hs | 8 +- src/Language/PureScript/Ide/Types.hs | 17 +- src/Language/PureScript/Ide/Usage.hs | 3 - src/Language/PureScript/Ide/Util.hs | 2 - src/Language/PureScript/Interactive.hs | 6 +- src/Language/PureScript/Interactive/Module.hs | 4 +- src/Language/PureScript/Interactive/Parser.hs | 7 +- .../PureScript/Interactive/Printer.hs | 10 +- src/Language/PureScript/Linter.hs | 7 +- src/Language/PureScript/Linter/Exhaustive.hs | 9 +- src/Language/PureScript/Linter/Imports.hs | 5 +- src/Language/PureScript/Make.hs | 11 +- src/Language/PureScript/Make/Actions.hs | 2 +- src/Language/PureScript/Pretty.hs | 1 - src/Language/PureScript/Pretty/Kinds.hs | 57 - src/Language/PureScript/Pretty/Types.hs | 50 +- src/Language/PureScript/Pretty/Values.hs | 3 +- .../PureScript/Sugar/BindingGroups.hs | 56 +- src/Language/PureScript/Sugar/Names.hs | 39 +- src/Language/PureScript/Sugar/Names/Env.hs | 44 +- .../PureScript/Sugar/Names/Exports.hs | 15 - .../PureScript/Sugar/Names/Imports.hs | 6 - src/Language/PureScript/Sugar/Operators.hs | 5 +- src/Language/PureScript/Sugar/TypeClasses.hs | 25 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 61 +- .../PureScript/Sugar/TypeDeclarations.hs | 20 +- src/Language/PureScript/TypeChecker.hs | 173 ++- .../PureScript/TypeChecker/Entailment.hs | 250 ++-- src/Language/PureScript/TypeChecker/Kinds.hs | 1155 +++++++++++++---- src/Language/PureScript/TypeChecker/Monad.hs | 147 ++- src/Language/PureScript/TypeChecker/Roles.hs | 8 +- .../PureScript/TypeChecker/Skolems.hs | 16 +- .../PureScript/TypeChecker/Subsumption.hs | 13 +- .../PureScript/TypeChecker/Synonyms.hs | 32 +- .../PureScript/TypeChecker/TypeSearch.hs | 4 +- src/Language/PureScript/TypeChecker/Types.hs | 150 ++- src/Language/PureScript/TypeChecker/Unify.hs | 124 +- tests/Language/PureScript/Ide/FilterSpec.hs | 34 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 16 - .../Language/PureScript/Ide/ReexportsSpec.hs | 1 - .../Language/PureScript/Ide/SourceFileSpec.hs | 5 +- tests/Language/PureScript/Ide/StateSpec.hs | 6 +- tests/Language/PureScript/Ide/Test.hs | 10 +- tests/TestDocs.hs | 4 +- tests/TestHierarchy.hs | 2 +- tests/TestPrimDocs.hs | 7 +- tests/TestPsci/CompletionTest.hs | 2 +- tests/TestUtils.hs | 7 +- tests/purs/docs/src/Clash1a.purs | 2 +- tests/purs/docs/src/Clash2a.purs | 2 +- tests/purs/docs/src/ConstrainedArgument.purs | 2 +- tests/purs/failing/1071.out | 19 +- tests/purs/failing/1310.out | 3 +- tests/purs/failing/1570.out | 6 +- tests/purs/failing/2542.out | 7 +- tests/purs/failing/2601.out | 16 +- tests/purs/failing/3077.out | 25 + tests/purs/failing/3077.purs | 11 + .../failing/3275-BindingGroupErrorPos.out | 23 +- .../failing/3275-DataBindingGroupErrorPos.out | 24 +- tests/purs/failing/3549-a.out | 2 +- tests/purs/failing/3549.out | 22 +- tests/purs/failing/CoercibleForeign.out | 6 +- tests/purs/failing/CoercibleNominal.out | 6 +- .../purs/failing/CoercibleNominalTypeApp.out | 14 +- .../purs/failing/CoercibleNominalWrapped.out | 6 +- .../failing/CoercibleRepresentational.out | 16 +- .../failing/CoercibleRepresentational2.out | 2 +- .../failing/CoercibleRepresentational3.out | 2 +- tests/purs/failing/ConstraintFailure.out | 4 +- tests/purs/failing/ConstraintInference.out | 8 +- tests/purs/failing/CycleInKindDeclaration.out | 13 + .../purs/failing/CycleInKindDeclaration.purs | 8 + tests/purs/failing/DiffKindsSameName.out | 16 +- tests/purs/failing/DuplicateModule.out | 2 +- tests/purs/failing/DuplicateTypeClass.out | 4 +- tests/purs/failing/InfiniteKind.out | 15 +- tests/purs/failing/InfiniteKind2.out | 14 +- tests/purs/failing/InfiniteKind2.purs | 2 +- .../InstanceChainBothUnknownAndMatch.out | 6 +- .../InstanceChainSkolemUnknownMatch.out | 16 +- .../InstanceChainSkolemUnknownMatch.purs | 2 +- tests/purs/failing/KindError.out | 23 +- tests/purs/failing/KindStar.out | 6 +- tests/purs/failing/LacksWithSubGoal.out | 4 +- .../purs/failing/MonoKindDataBindingGroup.out | 21 + .../failing/MonoKindDataBindingGroup.purs | 8 + tests/purs/failing/Object.out | 4 +- tests/purs/failing/OrphanKindDeclaration1.out | 10 + .../purs/failing/OrphanKindDeclaration1.purs | 4 + tests/purs/failing/OrphanKindDeclaration2.out | 10 + .../purs/failing/OrphanKindDeclaration2.purs | 5 + .../failing/PolykindGeneralizationLet.out | 24 + .../failing/PolykindGeneralizationLet.purs | 14 + .../failing/PolykindInstanceOverlapping.out | 22 + .../failing/PolykindInstanceOverlapping.purs | 13 + .../failing/PolykindInstantiatedInstance.out | 25 + .../failing/PolykindInstantiatedInstance.purs | 12 + tests/purs/failing/PolykindInstantiation.out | 22 + tests/purs/failing/PolykindInstantiation.purs | 8 + .../failing/QuantificationCheckFailure.out | 12 + .../failing/QuantificationCheckFailure.purs | 14 + .../failing/QuantificationCheckFailure2.out | 16 + .../failing/QuantificationCheckFailure2.purs | 6 + .../failing/QuantificationCheckFailure3.out | 12 + .../failing/QuantificationCheckFailure3.purs | 7 + tests/purs/failing/QuantifiedKind.out | 15 + tests/purs/failing/QuantifiedKind.purs | 7 + tests/purs/failing/RowConstructors1.out | 16 +- tests/purs/failing/RowConstructors2.out | 16 +- tests/purs/failing/RowConstructors3.out | 16 +- tests/purs/failing/RowLacks.out | 4 +- tests/purs/failing/RowsInKinds.out | 28 + tests/purs/failing/RowsInKinds.purs | 15 + .../failing/ScopedKindVariableSynonym.out | 12 + .../failing/ScopedKindVariableSynonym.purs | 7 + tests/purs/failing/SkolemEscapeKinds.out | 18 + tests/purs/failing/SkolemEscapeKinds.purs | 8 + .../failing/StandaloneKindSignatures1.out | 21 + .../failing/StandaloneKindSignatures1.purs | 7 + .../failing/StandaloneKindSignatures2.out | 22 + .../failing/StandaloneKindSignatures2.purs | 8 + .../failing/StandaloneKindSignatures3.out | 21 + .../failing/StandaloneKindSignatures3.purs | 7 + .../failing/StandaloneKindSignatures4.out | 25 + .../failing/StandaloneKindSignatures4.purs | 7 + tests/purs/failing/Superclasses3.out | 17 +- tests/purs/failing/TransitiveKindExport.out | 2 +- tests/purs/failing/TypeWildcards4.out | 10 + tests/purs/failing/TypeWildcards4.purs | 4 + tests/purs/failing/TypedBinders2.out | 2 +- tests/purs/failing/UnsupportedTypeInKind.out | 14 + tests/purs/failing/UnsupportedTypeInKind.purs | 7 + tests/purs/passing/Coercible.purs | 11 + .../purs/passing/KindUnificationInSolver.purs | 21 + tests/purs/passing/KindedType.purs | 4 +- tests/purs/passing/PolykindBindingGroup1.purs | 13 + tests/purs/passing/PolykindBindingGroup2.purs | 16 + .../purs/passing/PolykindGeneralization.purs | 15 + .../PolykindGeneralizationHygiene.purs | 11 + .../PolykindGeneralizedTypeSynonym.purs | 12 + .../passing/PolykindInstanceDispatch.purs | 21 + .../passing/PolykindInstantiatedInstance.purs | 22 + tests/purs/passing/PolykindInstantiation.purs | 17 + tests/purs/passing/PolykindRowCons.purs | 51 + tests/purs/passing/QuantifiedKind.purs | 10 + tests/purs/passing/Rank2Kinds.purs | 21 + tests/purs/passing/RowLacks.purs | 12 + tests/purs/passing/RowsInKinds.purs | 15 + tests/purs/passing/RowsInKinds2.purs | 11 + .../passing/StandaloneKindSignatures.purs | 27 + tests/purs/passing/TypeSynonymsInKinds.purs | 25 + .../warning/DeprecatedForeignImportKind.out | 9 + .../warning/DeprecatedForeignImportKind.purs | 4 + .../warning/DeprecatedImportExportKinds.out | 30 + .../warning/DeprecatedImportExportKinds.purs | 8 + .../DeprecatedImportExportKinds/Lib.purs | 5 + .../purs/warning/DeprecatedRowKindSyntax.out | 9 + .../purs/warning/DeprecatedRowKindSyntax.purs | 4 + tests/purs/warning/DuplicateExportRef.purs | 4 +- .../warning/Kind-UnusedExplicitImport-1.out | 4 +- .../warning/Kind-UnusedExplicitImport-1.purs | 4 +- .../warning/Kind-UnusedExplicitImport-2.out | 2 +- .../warning/Kind-UnusedExplicitImport-2.purs | 2 +- tests/purs/warning/Kind-UnusedImport.out | 2 +- tests/purs/warning/Kind-UnusedImport.purs | 2 +- tests/purs/warning/KindReExport.purs | 2 +- tests/purs/warning/MissingKindDeclaration.out | 64 + .../purs/warning/MissingKindDeclaration.purs | 13 + .../warning/UnambiguousQuantifiedKind.out | 16 + .../warning/UnambiguousQuantifiedKind.purs | 12 + .../UnusedExplicitImportTypeOp/Lib.purs | 1 + tests/support/bower.json | 8 +- 218 files changed, 4003 insertions(+), 2079 deletions(-) delete mode 100644 lib/purescript-ast/src/Language/PureScript/Kinds.hs create mode 100644 lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs delete mode 100644 src/Language/PureScript/Docs/RenderedCode/RenderKind.hs delete mode 100644 src/Language/PureScript/Pretty/Kinds.hs create mode 100644 tests/purs/failing/3077.out create mode 100644 tests/purs/failing/3077.purs create mode 100644 tests/purs/failing/CycleInKindDeclaration.out create mode 100644 tests/purs/failing/CycleInKindDeclaration.purs create mode 100644 tests/purs/failing/MonoKindDataBindingGroup.out create mode 100644 tests/purs/failing/MonoKindDataBindingGroup.purs create mode 100644 tests/purs/failing/OrphanKindDeclaration1.out create mode 100644 tests/purs/failing/OrphanKindDeclaration1.purs create mode 100644 tests/purs/failing/OrphanKindDeclaration2.out create mode 100644 tests/purs/failing/OrphanKindDeclaration2.purs create mode 100644 tests/purs/failing/PolykindGeneralizationLet.out create mode 100644 tests/purs/failing/PolykindGeneralizationLet.purs create mode 100644 tests/purs/failing/PolykindInstanceOverlapping.out create mode 100644 tests/purs/failing/PolykindInstanceOverlapping.purs create mode 100644 tests/purs/failing/PolykindInstantiatedInstance.out create mode 100644 tests/purs/failing/PolykindInstantiatedInstance.purs create mode 100644 tests/purs/failing/PolykindInstantiation.out create mode 100644 tests/purs/failing/PolykindInstantiation.purs create mode 100644 tests/purs/failing/QuantificationCheckFailure.out create mode 100644 tests/purs/failing/QuantificationCheckFailure.purs create mode 100644 tests/purs/failing/QuantificationCheckFailure2.out create mode 100644 tests/purs/failing/QuantificationCheckFailure2.purs create mode 100644 tests/purs/failing/QuantificationCheckFailure3.out create mode 100644 tests/purs/failing/QuantificationCheckFailure3.purs create mode 100644 tests/purs/failing/QuantifiedKind.out create mode 100644 tests/purs/failing/QuantifiedKind.purs create mode 100644 tests/purs/failing/RowsInKinds.out create mode 100644 tests/purs/failing/RowsInKinds.purs create mode 100644 tests/purs/failing/ScopedKindVariableSynonym.out create mode 100644 tests/purs/failing/ScopedKindVariableSynonym.purs create mode 100644 tests/purs/failing/SkolemEscapeKinds.out create mode 100644 tests/purs/failing/SkolemEscapeKinds.purs create mode 100644 tests/purs/failing/StandaloneKindSignatures1.out create mode 100644 tests/purs/failing/StandaloneKindSignatures1.purs create mode 100644 tests/purs/failing/StandaloneKindSignatures2.out create mode 100644 tests/purs/failing/StandaloneKindSignatures2.purs create mode 100644 tests/purs/failing/StandaloneKindSignatures3.out create mode 100644 tests/purs/failing/StandaloneKindSignatures3.purs create mode 100644 tests/purs/failing/StandaloneKindSignatures4.out create mode 100644 tests/purs/failing/StandaloneKindSignatures4.purs create mode 100644 tests/purs/failing/TypeWildcards4.out create mode 100644 tests/purs/failing/TypeWildcards4.purs create mode 100644 tests/purs/failing/UnsupportedTypeInKind.out create mode 100644 tests/purs/failing/UnsupportedTypeInKind.purs create mode 100644 tests/purs/passing/KindUnificationInSolver.purs create mode 100644 tests/purs/passing/PolykindBindingGroup1.purs create mode 100644 tests/purs/passing/PolykindBindingGroup2.purs create mode 100644 tests/purs/passing/PolykindGeneralization.purs create mode 100644 tests/purs/passing/PolykindGeneralizationHygiene.purs create mode 100644 tests/purs/passing/PolykindGeneralizedTypeSynonym.purs create mode 100644 tests/purs/passing/PolykindInstanceDispatch.purs create mode 100644 tests/purs/passing/PolykindInstantiatedInstance.purs create mode 100644 tests/purs/passing/PolykindInstantiation.purs create mode 100644 tests/purs/passing/PolykindRowCons.purs create mode 100644 tests/purs/passing/QuantifiedKind.purs create mode 100644 tests/purs/passing/Rank2Kinds.purs create mode 100644 tests/purs/passing/RowsInKinds.purs create mode 100644 tests/purs/passing/RowsInKinds2.purs create mode 100644 tests/purs/passing/StandaloneKindSignatures.purs create mode 100644 tests/purs/passing/TypeSynonymsInKinds.purs create mode 100644 tests/purs/warning/DeprecatedForeignImportKind.out create mode 100644 tests/purs/warning/DeprecatedForeignImportKind.purs create mode 100644 tests/purs/warning/DeprecatedImportExportKinds.out create mode 100644 tests/purs/warning/DeprecatedImportExportKinds.purs create mode 100644 tests/purs/warning/DeprecatedImportExportKinds/Lib.purs create mode 100644 tests/purs/warning/DeprecatedRowKindSyntax.out create mode 100644 tests/purs/warning/DeprecatedRowKindSyntax.purs create mode 100644 tests/purs/warning/MissingKindDeclaration.out create mode 100644 tests/purs/warning/MissingKindDeclaration.purs create mode 100644 tests/purs/warning/UnambiguousQuantifiedKind.out create mode 100644 tests/purs/warning/UnambiguousQuantifiedKind.purs diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs index bf08168ee6..142bd2d4ab 100644 --- a/app/Command/Hierarchy.hs +++ b/app/Command/Hierarchy.hs @@ -43,7 +43,7 @@ data HierarchyOptions = HierarchyOptions parseInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module]) parseInput paths = do content <- readUTF8FilesT paths - return $ map snd <$> CST.parseFromFiles id content + return $ map (snd . snd) <$> CST.parseFromFiles id content compile :: HierarchyOptions -> IO () compile (HierarchyOptions inputGlob mOutput) = do diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs index 817132bc02..af551efd93 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs @@ -25,7 +25,6 @@ import "this" Language.PureScript.Types import "this" Language.PureScript.PSString (PSString) import "this" Language.PureScript.Label (Label) import "this" Language.PureScript.Names -import "this" Language.PureScript.Kinds import "this" Language.PureScript.Roles import "this" Language.PureScript.TypeClassDictionaries import "this" Language.PureScript.Comments @@ -66,9 +65,10 @@ data ErrorMessageHint | ErrorInSubsumption SourceType SourceType | ErrorCheckingAccessor Expr PSString | ErrorCheckingType Expr SourceType - | ErrorCheckingKind SourceType + | ErrorCheckingKind SourceType SourceType | ErrorCheckingGuard | ErrorInferringType Expr + | ErrorInferringKind SourceType | ErrorInApplication Expr SourceType Expr | ErrorInDataConstructor (ProperName 'ConstructorName) | ErrorInTypeConstructor (ProperName 'TypeName) @@ -78,6 +78,7 @@ data ErrorMessageHint | ErrorInValueDeclaration Ident | ErrorInTypeDeclaration Ident | ErrorInTypeClassDeclaration (ProperName 'ClassName) + | ErrorInKindDeclaration (ProperName 'TypeName) | ErrorInForeignImport Ident | ErrorSolvingConstraint SourceConstraint | PositionedError (NEL.NonEmpty SourceSpan) @@ -174,10 +175,6 @@ data DeclarationRef -- | ModuleRef SourceSpan ModuleName -- | - -- A named kind - -- - | KindRef SourceSpan (ProperName 'KindName) - -- | -- A value re-exported from another module. These will be inserted during -- elaboration in name desugaring. -- @@ -192,7 +189,6 @@ instance Eq DeclarationRef where (TypeClassRef _ name) == (TypeClassRef _ name') = name == name' (TypeInstanceRef _ name) == (TypeInstanceRef _ name') = name == name' (ModuleRef _ name) == (ModuleRef _ name') = name == name' - (KindRef _ name) == (KindRef _ name') = name == name' (ReExportRef _ mn ref) == (ReExportRef _ mn' ref') = mn == mn' && ref == ref' _ == _ = False @@ -214,7 +210,6 @@ compDecRef (ValueOpRef _ name) (ValueOpRef _ name') = compare name name' compDecRef (TypeClassRef _ name) (TypeClassRef _ name') = compare name name' compDecRef (TypeInstanceRef _ ident) (TypeInstanceRef _ ident') = compare ident ident' compDecRef (ModuleRef _ name) (ModuleRef _ name') = compare name name' -compDecRef (KindRef _ name) (KindRef _ name') = compare name name' compDecRef (ReExportRef _ name _) (ReExportRef _ name' _) = compare name name' compDecRef ref ref' = compare (orderOf ref) (orderOf ref') @@ -225,7 +220,6 @@ compDecRef ref ref' = compare orderOf TypeRef{} = 2 orderOf ValueRef{} = 3 orderOf ValueOpRef{} = 4 - orderOf KindRef{} = 5 orderOf _ = 6 declRefSourceSpan :: DeclarationRef -> SourceSpan @@ -236,7 +230,6 @@ declRefSourceSpan (ValueOpRef ss _) = ss declRefSourceSpan (TypeClassRef ss _) = ss declRefSourceSpan (TypeInstanceRef ss _) = ss declRefSourceSpan (ModuleRef ss _) = ss -declRefSourceSpan (KindRef ss _) = ss declRefSourceSpan (ReExportRef ss _ _) = ss declRefName :: DeclarationRef -> Name @@ -247,7 +240,6 @@ declRefName (ValueOpRef _ n) = ValOpName n declRefName (TypeClassRef _ n) = TyClassName n declRefName (TypeInstanceRef _ n) = IdentName n declRefName (ModuleRef _ n) = ModName n -declRefName (KindRef _ n) = KiName n declRefName (ReExportRef _ _ ref) = declRefName ref getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) @@ -270,10 +262,6 @@ getTypeClassRef :: DeclarationRef -> Maybe (ProperName 'ClassName) getTypeClassRef (TypeClassRef _ name) = Just name getTypeClassRef _ = Nothing -getKindRef :: DeclarationRef -> Maybe (ProperName 'KindName) -getKindRef (KindRef _ name) = Just name -getKindRef _ = Nothing - isModuleRef :: DeclarationRef -> Bool isModuleRef ModuleRef{} = True isModuleRef _ = False @@ -380,7 +368,7 @@ data Declaration -- | -- A data type declaration (data or newtype, name, arguments, data constructors) -- - = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceKind)] [DataConstructorDeclaration] + = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe SourceType)] [DataConstructorDeclaration] -- | -- A minimal mutually recursive set of data type declarations -- @@ -388,7 +376,11 @@ data Declaration -- | -- A type synonym declaration (name, arguments, type) -- - | TypeSynonymDeclaration SourceAnn (ProperName 'TypeName) [(Text, Maybe SourceKind)] SourceType + | TypeSynonymDeclaration SourceAnn (ProperName 'TypeName) [(Text, Maybe SourceType)] SourceType + -- | + -- A kind signature declaration + -- + | KindDeclaration SourceAnn KindSignatureFor (ProperName 'TypeName) SourceType -- | -- A role declaration (name, roles) -- @@ -415,11 +407,7 @@ data Declaration -- | -- A data type foreign import (name, kind) -- - | ExternDataDeclaration SourceAnn (ProperName 'TypeName) SourceKind - -- | - -- A foreign kind import (name) - -- - | ExternKindDeclaration SourceAnn (ProperName 'KindName) + | ExternDataDeclaration SourceAnn (ProperName 'TypeName) SourceType -- | -- A fixity declaration -- @@ -431,7 +419,7 @@ data Declaration -- | -- A type class declaration (name, argument, implies, member declarations) -- - | TypeClassDeclaration SourceAnn (ProperName 'ClassName) [(Text, Maybe SourceKind)] [SourceConstraint] [FunctionalDependency] [Declaration] + | TypeClassDeclaration SourceAnn (ProperName 'ClassName) [(Text, Maybe SourceType)] [SourceConstraint] [FunctionalDependency] [Declaration] -- | -- A type instance declaration (instance chain, chain index, name, -- dependencies, class name, instance types, member declarations) @@ -472,10 +460,19 @@ traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration] traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds traverseTypeInstanceBody _ other = pure other +-- | What sort of declaration the kind signature applies to. +data KindSignatureFor + = DataSig + | NewtypeSig + | TypeSynonymSig + | ClassSig + deriving (Eq, Ord, Show) + declSourceAnn :: Declaration -> SourceAnn declSourceAnn (DataDeclaration sa _ _ _ _) = sa declSourceAnn (DataBindingGroupDeclaration ds) = declSourceAnn (NEL.head ds) declSourceAnn (TypeSynonymDeclaration sa _ _ _) = sa +declSourceAnn (KindDeclaration sa _ _ _) = sa declSourceAnn (RoleDeclaration rd) = rdeclSourceAnn rd declSourceAnn (TypeDeclaration td) = tydeclSourceAnn td declSourceAnn (ValueDeclaration vd) = valdeclSourceAnn vd @@ -483,7 +480,6 @@ declSourceAnn (BoundValueDeclaration sa _ _) = sa declSourceAnn (BindingGroupDeclaration ds) = let ((sa, _), _, _) = NEL.head ds in sa declSourceAnn (ExternDeclaration sa _ _) = sa declSourceAnn (ExternDataDeclaration sa _ _) = sa -declSourceAnn (ExternKindDeclaration sa _) = sa declSourceAnn (FixityDeclaration sa _) = sa declSourceAnn (ImportDeclaration sa _ _ _) = sa declSourceAnn (TypeClassDeclaration sa _ _ _ _ _) = sa @@ -498,7 +494,6 @@ declName (TypeSynonymDeclaration _ n _ _) = Just (TyName n) declName (ValueDeclaration vd) = Just (IdentName (valdeclIdent vd)) declName (ExternDeclaration _ n _) = Just (IdentName n) declName (ExternDataDeclaration _ n _) = Just (TyName n) -declName (ExternKindDeclaration _ n) = Just (KiName n) declName (FixityDeclaration _ (Left (ValueFixity _ _ n))) = Just (ValOpName n) declName (FixityDeclaration _ (Right (TypeFixity _ _ n))) = Just (TyOpName n) declName (TypeClassDeclaration _ n _ _ _ _) = Just (TyClassName n) @@ -507,6 +502,7 @@ declName ImportDeclaration{} = Nothing declName BindingGroupDeclaration{} = Nothing declName DataBindingGroupDeclaration{} = Nothing declName BoundValueDeclaration{} = Nothing +declName KindDeclaration{} = Nothing declName TypeDeclaration{} = Nothing declName RoleDeclaration{} = Nothing @@ -518,13 +514,19 @@ isValueDecl ValueDeclaration{} = True isValueDecl _ = False -- | --- Test if a declaration is a data type or type synonym declaration +-- Test if a declaration is a data type declaration -- isDataDecl :: Declaration -> Bool isDataDecl DataDeclaration{} = True -isDataDecl TypeSynonymDeclaration{} = True isDataDecl _ = False +-- | +-- Test if a declaration is a type synonym declaration +-- +isTypeSynonymDecl :: Declaration -> Bool +isTypeSynonymDecl TypeSynonymDeclaration{} = True +isTypeSynonymDecl _ = False + -- | -- Test if a declaration is a module import -- @@ -546,13 +548,6 @@ isExternDataDecl :: Declaration -> Bool isExternDataDecl ExternDataDeclaration{} = True isExternDataDecl _ = False --- | --- Test if a declaration is a foreign kind import --- -isExternKindDecl :: Declaration -> Bool -isExternKindDecl ExternKindDeclaration{} = True -isExternKindDecl _ = False - -- | -- Test if a declaration is a fixity declaration -- @@ -574,16 +569,23 @@ isExternDecl _ = False -- | -- Test if a declaration is a type class instance declaration -- -isTypeClassInstanceDeclaration :: Declaration -> Bool -isTypeClassInstanceDeclaration TypeInstanceDeclaration{} = True -isTypeClassInstanceDeclaration _ = False +isTypeClassInstanceDecl :: Declaration -> Bool +isTypeClassInstanceDecl TypeInstanceDeclaration{} = True +isTypeClassInstanceDecl _ = False -- | -- Test if a declaration is a type class declaration -- -isTypeClassDeclaration :: Declaration -> Bool -isTypeClassDeclaration TypeClassDeclaration{} = True -isTypeClassDeclaration _ = False +isTypeClassDecl :: Declaration -> Bool +isTypeClassDecl TypeClassDeclaration{} = True +isTypeClassDecl _ = False + +-- | +-- Test if a declaration is a kind signature declaration. +-- +isKindDecl :: Declaration -> Bool +isKindDecl KindDeclaration{} = True +isKindDecl _ = False -- | -- Recursively flatten data binding groups in the list of declarations diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs b/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs index 32e580727f..63b87296f6 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs @@ -17,7 +17,6 @@ import qualified "containers" Data.Set as S import "this" Language.PureScript.AST.Binders import "this" Language.PureScript.AST.Declarations import "this" Language.PureScript.AST.Literals -import "this" Language.PureScript.Kinds import "this" Language.PureScript.Names import "this" Language.PureScript.Traversals import "this" Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..)) @@ -636,56 +635,32 @@ accumTypes , CaseAlternative -> r , DoNotationElement -> r ) -accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) - where - forDecls (DataDeclaration _ _ _ _ dctors) = mconcat (concatMap (fmap (f . snd) . dataCtorFields) dctors) - forDecls (ExternDeclaration _ _ ty) = f ty - forDecls (TypeClassDeclaration _ _ _ implies _ _) = mconcat (concatMap (fmap f . constraintArgs) implies) - forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) <> mconcat (fmap f tys) - forDecls (TypeSynonymDeclaration _ _ _ ty) = f ty - forDecls (TypeDeclaration td) = f (tydeclType td) - forDecls _ = mempty - - forValues (TypeClassDictionary c _ _) = mconcat (fmap f (constraintArgs c)) - forValues (DeferredDictionary _ tys) = mconcat (fmap f tys) - forValues (TypedValue _ _ ty) = f ty - forValues _ = mempty - -accumKinds - :: (Monoid r) - => (SourceKind -> r) - -> ( Declaration -> r - , Expr -> r - , Binder -> r - , CaseAlternative -> r - , DoNotationElement -> r - ) -accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) +accumTypes f = everythingOnValues mappend forDecls forValues forBinders (const mempty) (const mempty) where forDecls (DataDeclaration _ _ _ args dctors) = foldMap (foldMap f . snd) args <> - foldMap (foldMap (forTypes . snd) . dataCtorFields) dctors + foldMap (foldMap (f . snd) . dataCtorFields) dctors + forDecls (ExternDataDeclaration _ _ ty) = f ty + forDecls (ExternDeclaration _ _ ty) = f ty forDecls (TypeClassDeclaration _ _ args implies _ _) = - foldMap (foldMap f . snd) args <> - foldMap (foldMap forTypes . constraintArgs) implies + foldMap (foldMap (foldMap f)) args <> + foldMap (foldMap f . constraintArgs) implies forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = - foldMap (foldMap forTypes . constraintArgs) cs <> - foldMap forTypes tys + foldMap (foldMap f . constraintArgs) cs <> foldMap f tys forDecls (TypeSynonymDeclaration _ _ args ty) = foldMap (foldMap f . snd) args <> - forTypes ty - forDecls (TypeDeclaration td) = forTypes (tydeclType td) - forDecls (ExternDeclaration _ _ ty) = forTypes ty - forDecls (ExternDataDeclaration _ _ kn) = f kn + f ty + forDecls (KindDeclaration _ _ _ ty) = f ty + forDecls (TypeDeclaration td) = f (tydeclType td) forDecls _ = mempty - forValues (TypeClassDictionary c _ _) = foldMap forTypes (constraintArgs c) - forValues (DeferredDictionary _ tys) = foldMap forTypes tys - forValues (TypedValue _ _ ty) = forTypes ty + forValues (TypeClassDictionary c _ _) = foldMap f (constraintArgs c) + forValues (DeferredDictionary _ tys) = foldMap f tys + forValues (TypedValue _ _ ty) = f ty forValues _ = mempty - forTypes (KindedType _ _ k) = f k - forTypes _ = mempty + forBinders (TypedBinder ty _) = f ty + forBinders _ = mempty -- | -- Map a function over type annotations appearing inside a value diff --git a/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs b/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs index 35fc51a499..ac52d94c83 100644 --- a/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs +++ b/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs @@ -25,6 +25,21 @@ pattern Partial = Qualified (Just Prim) (ProperName "Partial") pattern Record :: Qualified (ProperName 'TypeName) pattern Record = Qualified (Just Prim) (ProperName "Record") +pattern Type :: Qualified (ProperName 'TypeName) +pattern Type = Qualified (Just Prim) (ProperName "Type") + +pattern Constraint :: Qualified (ProperName 'TypeName) +pattern Constraint = Qualified (Just Prim) (ProperName "Constraint") + +pattern Function :: Qualified (ProperName 'TypeName) +pattern Function = Qualified (Just Prim) (ProperName "Function") + +pattern Array :: Qualified (ProperName 'TypeName) +pattern Array = Qualified (Just Prim) (ProperName "Array") + +pattern Row :: Qualified (ProperName 'TypeName) +pattern Row = Qualified (Just Prim) (ProperName "Row") + -- Prim.Boolean pattern PrimBoolean :: ModuleName @@ -135,6 +150,12 @@ symbol = "Symbol" doc :: forall a. (IsString a) => a doc = "Doc" +row :: forall a. (IsString a) => a +row = "Row" + +constraint :: forall a. (IsString a) => a +constraint = "Constraint" + -- Modules prim :: forall a. (IsString a) => a diff --git a/lib/purescript-ast/src/Language/PureScript/Environment.hs b/lib/purescript-ast/src/Language/PureScript/Environment.hs index 845b4d93d6..d84536daa3 100644 --- a/lib/purescript-ast/src/Language/PureScript/Environment.hs +++ b/lib/purescript-ast/src/Language/PureScript/Environment.hs @@ -14,12 +14,11 @@ import "text" Data.Text (Text) import qualified "text" Data.Text as T import "containers" Data.Tree (Tree, rootLabel) import qualified "containers" Data.Graph as G -import "base" Data.Foldable (toList, fold) +import "base" Data.Foldable (toList) import qualified "base" Data.List.NonEmpty as NEL import "this" Language.PureScript.AST.SourcePos import "this" Language.PureScript.Crash -import "this" Language.PureScript.Kinds import "this" Language.PureScript.Names import "this" Language.PureScript.Roles import "this" Language.PureScript.TypeClassDictionaries @@ -30,14 +29,14 @@ import qualified "this" Language.PureScript.Constants.Prim as C data Environment = Environment { names :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ Values currently in scope - , types :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) + , types :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) -- ^ Type names currently in scope , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) -- ^ Data constructors currently in scope, along with their associated type -- constructor name, argument types and return type. , roleDeclarations :: M.Map (Qualified (ProperName 'TypeName)) [Role] -- ^ Explicit role declarations currently in scope. - , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceKind)], SourceType) + , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType) -- ^ Type synonyms currently in scope , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) -- ^ Available type class dictionaries. When looking up 'Nothing' in the @@ -45,15 +44,13 @@ data Environment = Environment -- scope (ie dictionaries brought in by a constrained type). , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData -- ^ Type classes - , kinds :: S.Set (Qualified (ProperName 'KindName)) - -- ^ Kinds in scope } deriving (Show, Generic) instance NFData Environment -- | Information about a type class data TypeClassData = TypeClassData - { typeClassArguments :: [(Text, Maybe SourceKind)] + { typeClassArguments :: [(Text, Maybe SourceType)] -- ^ A list of type argument names, and their kinds, where kind annotations -- were provided. , typeClassMembers :: [(Ident, SourceType)] @@ -101,7 +98,7 @@ instance A.ToJSON FunctionalDependency where -- | The initial environment with no values and only the default javascript types defined initEnvironment :: Environment -initEnvironment = Environment M.empty allPrimTypes M.empty primRoles M.empty M.empty allPrimClasses allPrimKinds +initEnvironment = Environment M.empty allPrimTypes M.empty primRoles M.empty M.empty allPrimClasses -- | -- A lookup table of role definitions for primitive types whose constructors @@ -134,7 +131,7 @@ primRoles = M.fromList -- determine X that X does not determine. This is the same thing: everything X determines includes everything -- in its SCC, and everything determining X is either before it in an SCC path, or in the same SCC. makeTypeClassData - :: [(Text, Maybe SourceKind)] + :: [(Text, Maybe SourceType)] -> [(Ident, SourceType)] -> [SourceConstraint] -> [FunctionalDependency] @@ -212,7 +209,7 @@ instance NFData NameKind -- | The kinds of a type data TypeKind - = DataType [(Text, Maybe SourceKind)] [(ProperName 'ConstructorName, [SourceType])] + = DataType [(Text, Maybe SourceType)] [(ProperName 'ConstructorName, [SourceType])] -- ^ Data type | TypeSynonym -- ^ Type synonym @@ -282,45 +279,43 @@ primSubName :: Text -> Text -> Qualified (ProperName a) primSubName sub = Qualified (Just $ ModuleName [ProperName C.prim, ProperName sub]) . ProperName -primKind :: Text -> SourceKind -primKind = NamedKind nullSourceAnn . primName +primKind :: Text -> SourceType +primKind = primTy -primSubKind :: Text -> Text -> SourceKind -primSubKind sub = NamedKind nullSourceAnn . primSubName sub +primSubKind :: Text -> Text -> SourceType +primSubKind sub = TypeConstructor nullSourceAnn . primSubName sub -- | Kind of ground types -kindType :: SourceKind +kindType :: SourceType kindType = primKind C.typ -kindConstraint :: SourceKind -kindConstraint = kindType +kindConstraint :: SourceType +kindConstraint = primKind C.constraint -isKindType :: Kind a -> Bool -isKindType (NamedKind _ n) = n == primName C.typ +isKindType :: Type a -> Bool +isKindType (TypeConstructor _ n) = n == primName C.typ isKindType _ = False --- To make reading the kind signatures below easier -(-:>) :: SourceKind -> SourceKind -> SourceKind -(-:>) = FunKind nullSourceAnn -infixr 4 -:> - -kindSymbol :: SourceKind +kindSymbol :: SourceType kindSymbol = primKind C.symbol -kindDoc :: SourceKind +kindDoc :: SourceType kindDoc = primSubKind C.typeError C.doc -kindBoolean :: SourceKind +kindBoolean :: SourceType kindBoolean = primSubKind C.moduleBoolean C.kindBoolean -kindOrdering :: SourceKind +kindOrdering :: SourceType kindOrdering = primSubKind C.moduleOrdering C.kindOrdering -kindRowList :: SourceKind -kindRowList = primSubKind C.moduleRowList C.kindRowList +kindRowList :: SourceType -> SourceType +kindRowList = TypeApp nullSourceAnn (primSubKind C.moduleRowList C.kindRowList) + +kindRow :: SourceType -> SourceType +kindRow = TypeApp nullSourceAnn (primKind C.row) -kindRow :: SourceKind -> SourceKind -kindRow = Row nullSourceAnn +kindOfREmpty :: SourceType +kindOfREmpty = tyForall "k" kindType (kindRow (tyVar "k")) -- | Construct a type in the Prim module primTy :: Text -> SourceType @@ -358,6 +353,12 @@ tyArray = primTy "Array" tyRecord :: SourceType tyRecord = primTy "Record" +tyVar :: Text -> SourceType +tyVar = TypeVar nullSourceAnn + +tyForall :: Text -> SourceType -> SourceType -> SourceType +tyForall var k ty = ForAll nullSourceAnn var (Just k) ty Nothing + -- | Check whether a type is a record isObject :: Type a -> Bool isObject = isTypeOrApplied tyRecord @@ -374,65 +375,40 @@ isTypeOrApplied t1 t2 = eqType t1 t2 function :: SourceType -> SourceType -> SourceType function t1 t2 = TypeApp nullSourceAnn (TypeApp nullSourceAnn tyFunction t1) t2 --- | Kinds in @Prim@ -primKinds :: S.Set (Qualified (ProperName 'KindName)) -primKinds = S.fromList - [ primName C.typ - , primName C.symbol - ] - --- | Kinds in @Prim.Boolean@ -primBooleanKinds :: S.Set (Qualified (ProperName 'KindName)) -primBooleanKinds = S.fromList - [ primSubName C.moduleBoolean C.kindBoolean - ] - --- | Kinds in @Prim.Ordering@ -primOrderingKinds :: S.Set (Qualified (ProperName 'KindName)) -primOrderingKinds = S.fromList - [ primSubName C.moduleOrdering C.kindOrdering - ] - --- | Kinds in @Prim.RowList@ -primRowListKinds :: S.Set (Qualified (ProperName 'KindName)) -primRowListKinds = S.fromList - [ primSubName C.moduleRowList C.kindRowList - ] - --- | Kinds in @Prim.TypeError@ -primTypeErrorKinds :: S.Set (Qualified (ProperName 'KindName)) -primTypeErrorKinds = S.fromList - [ primSubName C.typeError C.doc - ] +-- To make reading the kind signatures below easier +(-:>) :: SourceType -> SourceType -> SourceType +(-:>) = function +infixr 4 -:> --- | All primitive kinds -allPrimKinds :: S.Set (Qualified (ProperName 'KindName)) -allPrimKinds = fold - [ primKinds - , primBooleanKinds - , primOrderingKinds - , primRowListKinds - , primTypeErrorKinds +primClass :: Qualified (ProperName 'TypeName) -> (SourceType -> SourceType) -> [(Qualified (ProperName 'TypeName), (SourceType, TypeKind))] +primClass name mkTy = + [ (name, (mkTy kindConstraint, ExternData)) + , (dictSynonymName <$> name, (mkTy kindType, TypeSynonym)) ] --- | The primitive types in the external javascript environment with their +-- | The primitive types in the external environment with their -- associated kinds. There are also pseudo `Fail`, `Warn`, and `Partial` types -- that correspond to the classes with the same names. -primTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) -primTypes = M.fromList - [ (primName "Function", (kindType -:> kindType -:> kindType, ExternData)) - , (primName "Array", (kindType -:> kindType, ExternData)) - , (primName "Record", (kindRow kindType -:> kindType, ExternData)) - , (primName "String", (kindType, ExternData)) - , (primName "Char", (kindType, ExternData)) - , (primName "Number", (kindType, ExternData)) - , (primName "Int", (kindType, ExternData)) - , (primName "Boolean", (kindType, ExternData)) - , (primName "Partial", (kindConstraint, ExternData)) - ] +primTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +primTypes = + M.fromList + [ (primName "Type", (kindType, ExternData)) + , (primName "Constraint", (kindType, ExternData)) + , (primName "Symbol", (kindType, ExternData)) + , (primName "Row", (kindType -:> kindType, ExternData)) + , (primName "Function", (kindType -:> kindType -:> kindType, ExternData)) + , (primName "Array", (kindType -:> kindType, ExternData)) + , (primName "Record", (kindRow kindType -:> kindType, ExternData)) + , (primName "String", (kindType, ExternData)) + , (primName "Char", (kindType, ExternData)) + , (primName "Number", (kindType, ExternData)) + , (primName "Int", (kindType, ExternData)) + , (primName "Boolean", (kindType, ExternData)) + , (primName "Partial", (kindConstraint, ExternData)) + ] -- | This 'Map' contains all of the prim types from all Prim modules. -allPrimTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) +allPrimTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) allPrimTypes = M.unions [ primTypes , primBooleanTypes @@ -444,62 +420,69 @@ allPrimTypes = M.unions , primTypeErrorTypes ] -primBooleanTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) +primBooleanTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primBooleanTypes = M.fromList - [ (primSubName C.moduleBoolean "True", (kindBoolean, ExternData)) - , (primSubName C.moduleBoolean "False", (kindBoolean, ExternData)) + [ (primSubName C.moduleBoolean "True", (tyBoolean, ExternData)) + , (primSubName C.moduleBoolean "False", (tyBoolean, ExternData)) ] -primCoerceTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) +primCoerceTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primCoerceTypes = - M.fromList - [ (primSubName C.moduleCoerce "Coercible", (kindType -:> kindType -:> kindConstraint, ExternData)) + M.fromList $ mconcat + [ primClass (primSubName C.moduleCoerce "Coercible") (\kind -> kindType -:> kindType -:> kind) ] -primOrderingTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) +primOrderingTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primOrderingTypes = M.fromList - [ (primSubName C.moduleOrdering "LT", (kindOrdering, ExternData)) + [ (primSubName C.moduleOrdering "Ordering", (kindType, ExternData)) + , (primSubName C.moduleOrdering "LT", (kindOrdering, ExternData)) , (primSubName C.moduleOrdering "EQ", (kindOrdering, ExternData)) , (primSubName C.moduleOrdering "GT", (kindOrdering, ExternData)) ] -primRowTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) +primRowTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primRowTypes = - M.fromList - [ (primSubName C.moduleRow "Union", (kindRow kindType -:> kindRow kindType -:> kindRow kindType -:> kindConstraint, ExternData)) - , (primSubName C.moduleRow "Nub", (kindRow kindType -:> kindRow kindType -:> kindConstraint, ExternData)) - , (primSubName C.moduleRow "Lacks", (kindSymbol -:> kindRow kindType -:> kindConstraint, ExternData)) - , (primSubName C.moduleRow "Cons", (kindSymbol -:> kindType -:> kindRow kindType -:> kindRow kindType -:> kindConstraint, ExternData)) + M.fromList $ mconcat + [ primClass (primSubName C.moduleRow "Union") (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) + , primClass (primSubName C.moduleRow "Nub") (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) + , primClass (primSubName C.moduleRow "Lacks") (\kind -> tyForall "k" kindType $ kindSymbol -:> kindRow (tyVar "k") -:> kind) + , primClass (primSubName C.moduleRow "Cons") (\kind -> tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) ] -primRowListTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) +primRowListTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primRowListTypes = - M.fromList - [ (primSubName C.moduleRowList "Cons", (kindSymbol -:> kindType -:> kindRowList -:> kindRowList, ExternData)) - , (primSubName C.moduleRowList "Nil", (kindRowList, ExternData)) - , (primSubName C.moduleRowList "RowToList", (kindRow kindType -:> kindRowList -:> kindConstraint, ExternData)) + M.fromList $ + [ (primSubName C.moduleRowList "RowList", (kindType -:> kindType, ExternData)) + , (primSubName C.moduleRowList "Cons", (tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRowList (tyVar "k") -:> kindRowList (tyVar "k"), ExternData)) + , (primSubName C.moduleRowList "Nil", (tyForall "k" kindType $ kindRowList (tyVar "k"), ExternData)) + ] <> mconcat + [ primClass (primSubName C.moduleRowList "RowToList") (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRowList (tyVar "k") -:> kind) ] -primSymbolTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) +primSymbolTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primSymbolTypes = - M.fromList - [ (primSubName C.moduleSymbol "Append", (kindSymbol -:> kindSymbol -:> kindSymbol -:> kindConstraint, ExternData)) - , (primSubName C.moduleSymbol "Compare", (kindSymbol -:> kindSymbol -:> kindOrdering -:> kindConstraint, ExternData)) - , (primSubName C.moduleSymbol "Cons", (kindSymbol -:> kindSymbol -:> kindSymbol -:> kindConstraint, ExternData)) + M.fromList $ mconcat + [ primClass (primSubName C.moduleSymbol "Append") (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind) + , primClass (primSubName C.moduleSymbol "Compare") (\kind -> kindSymbol -:> kindSymbol -:> kindOrdering -:> kind) + , primClass (primSubName C.moduleSymbol "Cons") (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind) ] -primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) +primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primTypeErrorTypes = - M.fromList - [ (primSubName C.typeError "Fail", (kindDoc -:> kindConstraint, ExternData)) + M.fromList $ + [ (primSubName C.typeError "Doc", (kindType, ExternData)) + , (primSubName C.typeError "Fail", (kindDoc -:> kindConstraint, ExternData)) , (primSubName C.typeError "Warn", (kindDoc -:> kindConstraint, ExternData)) , (primSubName C.typeError "Text", (kindSymbol -:> kindDoc, ExternData)) , (primSubName C.typeError "Quote", (kindType -:> kindDoc, ExternData)) , (primSubName C.typeError "QuoteLabel", (kindSymbol -:> kindDoc, ExternData)) , (primSubName C.typeError "Beside", (kindDoc -:> kindDoc -:> kindDoc, ExternData)) , (primSubName C.typeError "Above", (kindDoc -:> kindDoc -:> kindDoc, ExternData)) + ] <> mconcat + [ primClass (primSubName C.typeError "Fail") (\kind -> kindDoc -:> kind) + , primClass (primSubName C.typeError "Warn") (\kind -> kindDoc -:> kind) ] -- | The primitive class map. This just contains the `Partial` class. @@ -533,37 +516,37 @@ primCoerceClasses = primRowClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primRowClasses = M.fromList - -- class Union (left :: # Type) (right :: # Type) (union :: # Type) | left right -> union, right union -> left, union left -> right + -- class Union (left :: Row k) (right :: Row k) (union :: Row k) | left right -> union, right union -> left, union left -> right [ (primSubName C.moduleRow "Union", makeTypeClassData - [ ("left", Just (kindRow kindType)) - , ("right", Just (kindRow kindType)) - , ("union", Just (kindRow kindType)) + [ ("left", Just (kindRow (tyVar "k"))) + , ("right", Just (kindRow (tyVar "k"))) + , ("union", Just (kindRow (tyVar "k"))) ] [] [] [ FunctionalDependency [0, 1] [2] , FunctionalDependency [1, 2] [0] , FunctionalDependency [2, 0] [1] ] True) - -- class Nub (original :: # Type) (nubbed :: # Type) | i -> o + -- class Nub (original :: Row k) (nubbed :: Row k) | original -> nubbed , (primSubName C.moduleRow "Nub", makeTypeClassData - [ ("original", Just (kindRow kindType)) - , ("nubbed", Just (kindRow kindType)) + [ ("original", Just (kindRow (tyVar "k"))) + , ("nubbed", Just (kindRow (tyVar "k"))) ] [] [] [ FunctionalDependency [0] [1] ] True) - -- class Lacks (label :: Symbol) (row :: # Type) + -- class Lacks (label :: Symbol) (row :: Row k) , (primSubName C.moduleRow "Lacks", makeTypeClassData [ ("label", Just kindSymbol) - , ("row", Just (kindRow kindType)) + , ("row", Just (kindRow (tyVar "k"))) ] [] [] [] True) - -- class RowCons (label :: Symbol) (a :: Type) (tail :: # Type) (row :: # Type) | label tail a -> row, label row -> tail a + -- class RowCons (label :: Symbol) (a :: k) (tail :: Row k) (row :: Row k) | label tail a -> row, label row -> tail a , (primSubName C.moduleRow "Cons", makeTypeClassData [ ("label", Just kindSymbol) - , ("a", Just kindType) - , ("tail", Just (kindRow kindType)) - , ("row", Just (kindRow kindType)) + , ("a", Just (tyVar "k")) + , ("tail", Just (kindRow (tyVar "k"))) + , ("row", Just (kindRow (tyVar "k"))) ] [] [] [ FunctionalDependency [0, 1, 2] [3] , FunctionalDependency [0, 3] [1, 2] @@ -573,10 +556,10 @@ primRowClasses = primRowListClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primRowListClasses = M.fromList - -- class RowToList (row :: # Type) (list :: RowList) | row -> list + -- class RowToList (row :: Row k) (list :: RowList k) | row -> list [ (primSubName C.moduleRowList "RowToList", makeTypeClassData - [ ("row", Just (kindRow kindType)) - , ("list", Just kindRowList) + [ ("row", Just (kindRow (tyVar "k"))) + , ("list", Just (kindRowList (tyVar "k"))) ] [] [] [ FunctionalDependency [0] [1] ] True) @@ -657,3 +640,12 @@ isNewtypeConstructor e ctor = case lookupConstructor e ctor of -- | Finds information about values from the current environment. lookupValue :: Environment -> Qualified Ident -> Maybe (SourceType, NameKind, NameVisibility) lookupValue env ident = ident `M.lookup` names env + +dictSynonymName' :: Text -> Text +dictSynonymName' = (<> "$Dict") + +dictSynonymName :: ProperName a -> ProperName a +dictSynonymName = ProperName . dictSynonymName' . runProperName + +isDictSynonym :: ProperName a -> Bool +isDictSynonym = T.isSuffixOf "$Dict" . runProperName diff --git a/lib/purescript-ast/src/Language/PureScript/Kinds.hs b/lib/purescript-ast/src/Language/PureScript/Kinds.hs deleted file mode 100644 index 6e4f49a3e8..0000000000 --- a/lib/purescript-ast/src/Language/PureScript/Kinds.hs +++ /dev/null @@ -1,177 +0,0 @@ -module Language.PureScript.Kinds where - -import "base-compat" Prelude.Compat - -import "base" GHC.Generics (Generic) -import "base" Control.Applicative ((<|>)) -import "deepseq" Control.DeepSeq (NFData) -import "text" Data.Text (Text) -import "aeson" Data.Aeson (Value, toJSON, (.=), (.:)) -import "aeson" Data.Aeson.Types (Parser) -import qualified "aeson" Data.Aeson as A - -import "this" Language.PureScript.AST.SourcePos -import "this" Language.PureScript.Names - -import "microlens-platform" Lens.Micro.Platform (Lens', (^.), set) - -type SourceKind = Kind SourceAnn - --- | The data type of kinds -data Kind a - -- | Unification variable of type Kind - = KUnknown a Int - -- | Kinds for labelled, unordered rows without duplicates - | Row a (Kind a) - -- | Function kinds - | FunKind a (Kind a) (Kind a) - -- | A named kind - | NamedKind a (Qualified (ProperName 'KindName)) - deriving (Show, Generic, Functor, Foldable, Traversable) - -instance NFData a => NFData (Kind a) - -srcKUnknown :: Int -> SourceKind -srcKUnknown = KUnknown NullSourceAnn - -srcRow :: SourceKind -> SourceKind -srcRow = Row NullSourceAnn - -srcFunKind :: SourceKind -> SourceKind -> SourceKind -srcFunKind = FunKind NullSourceAnn - -srcNamedKind :: Qualified (ProperName 'KindName) -> SourceKind -srcNamedKind = NamedKind NullSourceAnn - -kindToJSON :: forall a. (a -> Value) -> Kind a -> Value -kindToJSON annToJSON kind = - case kind of - KUnknown a i -> - variant "KUnknown" a i - Row a k -> - variant "Row" a (go k) - FunKind a k1 k2 -> - variant "FunKind" a (go k1, go k2) - NamedKind a n -> - variant "NamedKind" a n - where - go :: Kind a -> Value - go = kindToJSON annToJSON - - variant :: A.ToJSON b => Text -> a -> b -> A.Value - variant tag ann contents = - A.object - [ "tag" .= tag - , "annotation" .= annToJSON ann - , "contents" .= contents - ] - -instance A.ToJSON a => A.ToJSON (Kind a) where - toJSON = kindToJSON toJSON - -kindFromJSON :: forall a. Parser a -> (Value -> Parser a) -> Value -> Parser (Kind a) -kindFromJSON defaultAnn annFromJSON = A.withObject "Kind" $ \o -> do - tag <- o .: "tag" - a <- (o .: "annotation" >>= annFromJSON) <|> defaultAnn - let - contents :: A.FromJSON b => Parser b - contents = o .: "contents" - case tag of - "KUnknown" -> - KUnknown a <$> contents - "Row" -> - Row a <$> (go =<< contents) - "FunKind" -> do - (b, c) <- contents - FunKind a <$> go b <*> go c - "NamedKind" -> - NamedKind a <$> contents - other -> - fail $ "Unrecognised tag: " ++ other - where - go :: Value -> Parser (Kind a) - go = kindFromJSON defaultAnn annFromJSON - --- These overlapping instances exist to preserve compatibility for common --- instances which have a sensible default for missing annotations. -instance {-# OVERLAPPING #-} A.FromJSON (Kind SourceAnn) where - parseJSON = kindFromJSON (pure NullSourceAnn) A.parseJSON - -instance {-# OVERLAPPING #-} A.FromJSON (Kind ()) where - parseJSON = kindFromJSON (pure ()) A.parseJSON - -instance {-# OVERLAPPING #-} A.FromJSON a => A.FromJSON (Kind a) where - parseJSON = kindFromJSON (fail "Invalid annotation") A.parseJSON - -everywhereOnKinds :: (Kind a -> Kind a) -> Kind a -> Kind a -everywhereOnKinds f = go - where - go (Row ann k1) = f (Row ann (go k1)) - go (FunKind ann k1 k2) = f (FunKind ann (go k1) (go k2)) - go other = f other - -everywhereOnKindsM :: Monad m => (Kind a -> m (Kind a)) -> Kind a -> m (Kind a) -everywhereOnKindsM f = go - where - go (Row ann k1) = (Row ann <$> go k1) >>= f - go (FunKind ann k1 k2) = (FunKind ann <$> go k1 <*> go k2) >>= f - go other = f other - -everythingOnKinds :: (r -> r -> r) -> (Kind a -> r) -> Kind a -> r -everythingOnKinds (<>.) f = go - where - go k@(Row _ k1) = f k <>. go k1 - go k@(FunKind _ k1 k2) = f k <>. go k1 <>. go k2 - go other = f other - -annForKind :: Lens' (Kind a) a -annForKind k (KUnknown a b) = (\z -> KUnknown z b) <$> k a -annForKind k (Row a b) = (\z -> Row z b) <$> k a -annForKind k (FunKind a b c) = (\z -> FunKind z b c) <$> k a -annForKind k (NamedKind a b) = (\z -> NamedKind z b) <$> k a - -getAnnForKind :: Kind a -> a -getAnnForKind = (^. annForKind) - -setAnnForKind :: a -> Kind a -> Kind a -setAnnForKind = set annForKind - -instance Eq (Kind a) where - (==) = eqKind - -instance Ord (Kind a) where - compare = compareKind - -eqKind :: Kind a -> Kind b -> Bool -eqKind (KUnknown _ a) (KUnknown _ a') = a == a' -eqKind (Row _ a) (Row _ a') = eqKind a a' -eqKind (FunKind _ a b) (FunKind _ a' b') = eqKind a a' && eqKind b b' -eqKind (NamedKind _ a) (NamedKind _ a') = a == a' -eqKind _ _ = False - -eqMaybeKind :: Maybe (Kind a) -> Maybe (Kind b) -> Bool -eqMaybeKind Nothing (Just _) = False -eqMaybeKind (Just _) Nothing = False -eqMaybeKind Nothing Nothing = True -eqMaybeKind (Just a) (Just b) = eqKind a b - -compareKind :: Kind a -> Kind b -> Ordering -compareKind (KUnknown _ a) (KUnknown _ a') = compare a a' -compareKind (KUnknown {}) _ = LT - -compareKind (Row _ a) (Row _ a') = compareKind a a' -compareKind (Row {}) _ = LT -compareKind _ (Row {}) = GT - -compareKind (FunKind _ a b) (FunKind _ a' b') = compareKind a b <> compareKind a' b' -compareKind (FunKind {}) _ = LT -compareKind _ (FunKind {}) = GT - -compareKind (NamedKind _ a) (NamedKind _ a') = compare a a' -compareKind (NamedKind {}) _ = GT - -compareMaybeKind :: Maybe (Kind a) -> Maybe (Kind b) -> Ordering -compareMaybeKind Nothing Nothing = EQ -compareMaybeKind Nothing (Just _) = LT -compareMaybeKind (Just _) Nothing = GT -compareMaybeKind (Just a) (Just b) = compareKind a b diff --git a/lib/purescript-ast/src/Language/PureScript/Names.hs b/lib/purescript-ast/src/Language/PureScript/Names.hs index 7c27876b56..00c243cf92 100644 --- a/lib/purescript-ast/src/Language/PureScript/Names.hs +++ b/lib/purescript-ast/src/Language/PureScript/Names.hs @@ -26,7 +26,6 @@ data Name | DctorName (ProperName 'ConstructorName) | TyClassName (ProperName 'ClassName) | ModName ModuleName - | KiName (ProperName 'KindName) deriving (Eq, Ord, Show, Generic) instance NFData Name @@ -43,10 +42,6 @@ getTypeName :: Name -> Maybe (ProperName 'TypeName) getTypeName (TyName name) = Just name getTypeName _ = Nothing -getKindName :: Name -> Maybe (ProperName 'KindName) -getKindName (KiName name) = Just name -getKindName _ = Nothing - getTypeOpName :: Name -> Maybe (OpName 'TypeOpName) getTypeOpName (TyOpName name) = Just name getTypeOpName _ = Nothing @@ -144,7 +139,6 @@ data ProperNameType = TypeName | ConstructorName | ClassName - | KindName | Namespace -- | diff --git a/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs b/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs index 82854c9b1b..1ddc55c5e5 100644 --- a/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs +++ b/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs @@ -9,7 +9,7 @@ import "text" Data.Text (Text, pack) import "this" Language.PureScript.Names import "this" Language.PureScript.Types --- | +-- -- Data representing a type class dictionary which is in scope -- data TypeClassDictionaryInScope v @@ -24,6 +24,10 @@ data TypeClassDictionaryInScope v , tcdPath :: [(Qualified (ProperName 'ClassName), Integer)] -- | The name of the type class to which this type class instance applies , tcdClassName :: Qualified (ProperName 'ClassName) + -- | Quantification of type variables in the instance head and dependencies + , tcdForAll :: [(Text, SourceType)] + -- | The kinds to which this type class instance applies + , tcdInstanceKinds :: [SourceType] -- | The types to which this type class instance applies , tcdInstanceTypes :: [SourceType] -- | Type class dependencies which must be satisfied to construct this dictionary diff --git a/lib/purescript-ast/src/Language/PureScript/Types.hs b/lib/purescript-ast/src/Language/PureScript/Types.hs index d753e3a1e1..e015979362 100644 --- a/lib/purescript-ast/src/Language/PureScript/Types.hs +++ b/lib/purescript-ast/src/Language/PureScript/Types.hs @@ -7,22 +7,24 @@ import "base-compat" Prelude.Compat import "protolude" Protolude (ordNub) import "base" Control.Applicative ((<|>)) -import "base" Control.Arrow (first) +import "base" Control.Arrow (first, second) import "deepseq" Control.DeepSeq (NFData) -import "base" Control.Monad ((<=<)) -import "aeson" Data.Aeson ((.:), (.=)) +import "base" Control.Monad ((<=<), (>=>)) +import "aeson" Data.Aeson ((.:), (.:?), (.!=), (.=)) import qualified "aeson" Data.Aeson as A import qualified "aeson" Data.Aeson.Types as A import "base" Data.Foldable (fold) -import "base" Data.List (sortBy) +import qualified "containers" Data.IntSet as IS +import "base" Data.List (sort, sortBy) import "base" Data.Ord (comparing) -import "base" Data.Maybe (fromMaybe) +import "base" Data.Maybe (fromMaybe, isJust) +import qualified "containers" Data.Set as S import "text" Data.Text (Text) import qualified "text" Data.Text as T import "base" GHC.Generics (Generic) import "this" Language.PureScript.AST.SourcePos -import "this" Language.PureScript.Kinds +import qualified "this" Language.PureScript.Constants.Prim as C import "this" Language.PureScript.Names import "this" Language.PureScript.Label (Label) import "this" Language.PureScript.PSString (PSString) @@ -59,18 +61,20 @@ data Type a | TypeOp a (Qualified (OpName 'TypeOpName)) -- | A type application | TypeApp a (Type a) (Type a) + -- | Explicit kind application + | KindApp a (Type a) (Type a) -- | Forall quantifier - | ForAll a Text (Maybe (Kind a)) (Type a) (Maybe SkolemScope) + | ForAll a Text (Maybe (Type a)) (Type a) (Maybe SkolemScope) -- | A type with a set of type class constraints | ConstrainedType a (Constraint a) (Type a) -- | A skolem constant - | Skolem a Text Int SkolemScope + | Skolem a Text (Maybe (Type a)) Int SkolemScope -- | An empty row | REmpty a -- | A non-empty row | RCons a Label (Type a) (Type a) -- | A type with a kind annotation - | KindedType a (Type a) (Kind a) + | KindedType a (Type a) (Type a) -- | Binary operator application. During the rebracketing phase of desugaring, -- this data constructor will be removed. | BinaryNoParensType a (Type a) (Type a) (Type a) @@ -105,22 +109,22 @@ srcTypeOp = TypeOp NullSourceAnn srcTypeApp :: SourceType -> SourceType -> SourceType srcTypeApp = TypeApp NullSourceAnn -srcForAll :: Text -> Maybe SourceKind -> SourceType -> Maybe SkolemScope -> SourceType +srcKindApp :: SourceType -> SourceType -> SourceType +srcKindApp = KindApp NullSourceAnn + +srcForAll :: Text -> Maybe SourceType -> SourceType -> Maybe SkolemScope -> SourceType srcForAll = ForAll NullSourceAnn srcConstrainedType :: SourceConstraint -> SourceType -> SourceType srcConstrainedType = ConstrainedType NullSourceAnn -srcSkolem :: Text -> Int -> SkolemScope -> SourceType -srcSkolem = Skolem NullSourceAnn - srcREmpty :: SourceType srcREmpty = REmpty NullSourceAnn srcRCons :: Label -> SourceType -> SourceType -> SourceType srcRCons = RCons NullSourceAnn -srcKindedType :: SourceType -> SourceKind -> SourceType +srcKindedType :: SourceType -> SourceType -> SourceType srcKindedType = KindedType NullSourceAnn srcBinaryNoParensType :: SourceType -> SourceType -> SourceType -> SourceType @@ -129,6 +133,17 @@ srcBinaryNoParensType = BinaryNoParensType NullSourceAnn srcParensInType :: SourceType -> SourceType srcParensInType = ParensInType NullSourceAnn +pattern REmptyKinded :: forall a. a -> Maybe (Type a) -> Type a +pattern REmptyKinded ann mbK <- (toREmptyKinded -> Just (ann, mbK)) + +toREmptyKinded :: forall a. Type a -> Maybe (a, Maybe (Type a)) +toREmptyKinded (REmpty ann) = Just (ann, Nothing) +toREmptyKinded (KindApp _ (REmpty ann) k) = Just (ann, Just k) +toREmptyKinded _ = Nothing + +isREmpty :: forall a. Type a -> Bool +isREmpty = isJust . toREmptyKinded + -- | Additional data relevant to type class constraints data ConstraintData = PartialConstraintData [[Text]] Bool @@ -147,6 +162,8 @@ data Constraint a = Constraint -- ^ constraint annotation , constraintClass :: Qualified (ProperName 'ClassName) -- ^ constraint class name + , constraintKindArgs :: [Type a] + -- ^ kind arguments , constraintArgs :: [Type a] -- ^ type arguments , constraintData :: Maybe ConstraintData @@ -155,7 +172,7 @@ data Constraint a = Constraint instance NFData a => NFData (Constraint a) -srcConstraint :: Qualified (ProperName 'ClassName) -> [SourceType] -> Maybe ConstraintData -> SourceConstraint +srcConstraint :: Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> Maybe ConstraintData -> SourceConstraint srcConstraint = Constraint NullSourceAnn mapConstraintArgs :: ([Type a] -> [Type a]) -> Constraint a -> Constraint a @@ -164,6 +181,24 @@ mapConstraintArgs f c = c { constraintArgs = f (constraintArgs c) } overConstraintArgs :: Functor f => ([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a) overConstraintArgs f c = (\args -> c { constraintArgs = args }) <$> f (constraintArgs c) +mapConstraintKindArgs :: ([Type a] -> [Type a]) -> Constraint a -> Constraint a +mapConstraintKindArgs f c = c { constraintKindArgs = f (constraintKindArgs c) } + +overConstraintKindArgs :: Functor f => ([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a) +overConstraintKindArgs f c = (\args -> c { constraintKindArgs = args }) <$> f (constraintKindArgs c) + +mapConstraintArgsAll :: ([Type a] -> [Type a]) -> Constraint a -> Constraint a +mapConstraintArgsAll f c = + c { constraintKindArgs = f (constraintKindArgs c) + , constraintArgs = f (constraintArgs c) + } + +overConstraintArgsAll :: Applicative f => ([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a) +overConstraintArgsAll f c = + (\a b -> c { constraintKindArgs = a, constraintArgs = b }) + <$> f (constraintKindArgs c) + <*> f (constraintArgs c) + constraintDataToJSON :: ConstraintData -> A.Value constraintDataToJSON (PartialConstraintData bs trunc) = A.object @@ -175,6 +210,7 @@ constraintToJSON annToJSON (Constraint {..}) = A.object [ "constraintAnn" .= annToJSON constraintAnn , "constraintClass" .= constraintClass + , "constraintKindArgs" .= fmap (typeToJSON annToJSON) constraintKindArgs , "constraintArgs" .= fmap (typeToJSON annToJSON) constraintArgs , "constraintData" .= fmap constraintDataToJSON constraintData ] @@ -196,20 +232,22 @@ typeToJSON annToJSON ty = variant "TypeOp" a b TypeApp a b c -> variant "TypeApp" a (go b, go c) + KindApp a b c -> + variant "KindApp" a (go b, go c) ForAll a b c d e -> case c of Nothing -> variant "ForAll" a (b, go d, e) - Just k -> variant "ForAll" a (b, kindToJSON annToJSON k, go d, e) + Just k -> variant "ForAll" a (b, go k, go d, e) ConstrainedType a b c -> variant "ConstrainedType" a (constraintToJSON annToJSON b, go c) - Skolem a b c d -> - variant "Skolem" a (b, c, d) + Skolem a b c d e -> + variant "Skolem" a (b, go <$> c, d, e) REmpty a -> nullary "REmpty" a RCons a b c d -> variant "RCons" a (b, go c, go d) KindedType a b c -> - variant "KindedType" a (go b, kindToJSON annToJSON c) + variant "KindedType" a (go b, go c) BinaryNoParensType a b c d -> variant "BinaryNoParensType" a (go b, go c, go d) ParensInType a b -> @@ -251,6 +289,7 @@ constraintFromJSON :: forall a. A.Parser a -> (A.Value -> A.Parser a) -> A.Value constraintFromJSON defaultAnn annFromJSON = A.withObject "Constraint" $ \o -> do constraintAnn <- (o .: "constraintAnn" >>= annFromJSON) <|> defaultAnn constraintClass <- o .: "constraintClass" + constraintKindArgs <- o .:? "constraintKindArgs" .!= [] >>= traverse (typeFromJSON defaultAnn annFromJSON) constraintArgs <- o .: "constraintArgs" >>= traverse (typeFromJSON defaultAnn annFromJSON) constraintData <- o .: "constraintData" >>= traverse constraintDataFromJSON pure $ Constraint {..} @@ -279,6 +318,9 @@ typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do "TypeApp" -> do (b, c) <- contents TypeApp a <$> go b <*> go c + "KindApp" -> do + (b, c) <- contents + KindApp a <$> go b <*> go c "ForAll" -> do let withoutMbKind = do @@ -286,14 +328,15 @@ typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do ForAll a b Nothing <$> go c <*> pure d withMbKind = do (b, c, d, e) <- contents - ForAll a b <$> (Just <$> kindFromJSON defaultAnn annFromJSON c) <*> go d <*> pure e + ForAll a b <$> (Just <$> go c) <*> go d <*> pure e withMbKind <|> withoutMbKind "ConstrainedType" -> do (b, c) <- contents ConstrainedType a <$> constraintFromJSON defaultAnn annFromJSON b <*> go c "Skolem" -> do - (b, c, d) <- contents - pure $ Skolem a b c d + (b, c, d, e) <- contents + c' <- traverse go c + pure $ Skolem a b c' d e "REmpty" -> pure $ REmpty a "RCons" -> do @@ -301,13 +344,23 @@ typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do RCons a b <$> go c <*> go d "KindedType" -> do (b, c) <- contents - KindedType a <$> go b <*> kindFromJSON defaultAnn annFromJSON c + KindedType a <$> go b <*> go c "BinaryNoParensType" -> do (b, c, d) <- contents BinaryNoParensType a <$> go b <*> go c <*> go d "ParensInType" -> do b <- contents ParensInType a <$> go b + -- Backwards compatability for kinds + "KUnknown" -> + TUnknown a <$> contents + "Row" -> + TypeApp a (TypeConstructor a C.Row) <$> (go =<< contents) + "FunKind" -> do + (b, c) <- contents + TypeApp a . TypeApp a (TypeConstructor a C.Function) <$> go b <*> go c + "NamedKind" -> + TypeConstructor a <$> contents other -> fail $ "Unrecognised tag: " ++ other where @@ -346,25 +399,6 @@ data RowListItem a = RowListItem srcRowListItem :: Label -> SourceType -> RowListItem SourceAnn srcRowListItem = RowListItem NullSourceAnn --- | Split a type application into a function/constructor and a list of --- arguments. -splitTypeApp :: SourceType -> Maybe (SourceType, [SourceType]) -splitTypeApp - = \case - TypeApp _ f x -> - go [x] f - _ -> - Nothing - where - go xs - = \case - TypeApp _ f x -> - go (x : xs) f - KindedType _ t _ -> - go xs t - f -> - Just (f, xs) - -- | Convert a row to a list of pairs of labels and types rowToList :: Type a -> ([RowListItem a], Type a) rowToList = go where @@ -380,6 +414,29 @@ rowToSortedList = first (sortBy (comparing rowListLabel)) . rowToList rowFromList :: ([RowListItem a], Type a) -> Type a rowFromList (xs, r) = foldr (\(RowListItem ann name ty) -> RCons ann name ty) r xs +-- | Align two rows of types, splitting them into three parts: +-- +-- * Those types which appear in both rows +-- * Those which appear only on the left +-- * Those which appear only on the right +-- +-- Note: importantly, we preserve the order of the types with a given label. +alignRowsWith + :: (Type a -> Type a -> r) + -> Type a + -> Type a + -> ([r], (([RowListItem a], Type a), ([RowListItem a], Type a))) +alignRowsWith f ty1 ty2 = go s1 s2 where + (s1, tail1) = rowToSortedList ty1 + (s2, tail2) = rowToSortedList ty2 + + go [] r = ([], (([], tail1), (r, tail2))) + go r [] = ([], ((r, tail1), ([], tail2))) + go lhs@(RowListItem a1 l1 t1 : r1) rhs@(RowListItem a2 l2 t2 : r2) + | l1 < l2 = (second . first . first) (RowListItem a1 l1 t1 :) (go r1 rhs) + | l2 < l1 = (second . second . first) (RowListItem a2 l2 t2 :) (go lhs r2) + | otherwise = first (f t1 t2 :) (go r1 r2) + -- | Check whether a type is a monotype isMonoType :: Type a -> Bool isMonoType ForAll{} = False @@ -388,8 +445,8 @@ isMonoType (KindedType _ t _) = isMonoType t isMonoType _ = True -- | Universally quantify a type -mkForAll :: [(a, (Text, Maybe (Kind a)))] -> Type a -> Type a -mkForAll args ty = foldl (\t (ann, (arg, mbK)) -> ForAll ann arg mbK t Nothing) ty args +mkForAll :: [(a, (Text, Maybe (Type a)))] -> Type a -> Type a +mkForAll args ty = foldr (\(ann, (arg, mbK)) t -> ForAll ann arg mbK t Nothing) ty args -- | Replace a type variable, taking into account variable shadowing replaceTypeVars :: Text -> Type a -> Type a -> Type a @@ -401,19 +458,21 @@ replaceAllTypeVars = go [] where go :: [Text] -> [(Text, Type a)] -> Type a -> Type a go _ m (TypeVar ann v) = fromMaybe (TypeVar ann v) (v `lookup` m) go bs m (TypeApp ann t1 t2) = TypeApp ann (go bs m t1) (go bs m t2) - go bs m f@(ForAll ann v mbK t sco) - | v `elem` keys = go bs (filter ((/= v) . fst) m) f + go bs m (KindApp ann t1 t2) = KindApp ann (go bs m t1) (go bs m t2) + go bs m (ForAll ann v mbK t sco) + | v `elem` keys = go bs (filter ((/= v) . fst) m) $ ForAll ann v mbK' t sco | v `elem` usedVars = let v' = genName v (keys ++ bs ++ usedVars) t' = go bs [(v, TypeVar ann v')] t - in ForAll ann v' mbK (go (v' : bs) m t') sco - | otherwise = ForAll ann v mbK (go (v : bs) m t) sco + in ForAll ann v' mbK' (go (v' : bs) m t') sco + | otherwise = ForAll ann v mbK' (go (v : bs) m t) sco where + mbK' = go bs m <$> mbK keys = map fst m usedVars = concatMap (usedTypeVariables . snd) m - go bs m (ConstrainedType ann c t) = ConstrainedType ann (mapConstraintArgs (map (go bs m)) c) (go bs m t) + go bs m (ConstrainedType ann c t) = ConstrainedType ann (mapConstraintArgsAll (map (go bs m)) c) (go bs m t) go bs m (RCons ann name' t r) = RCons ann name' (go bs m t) (go bs m r) - go bs m (KindedType ann t k) = KindedType ann (go bs m t) k + go bs m (KindedType ann t k) = KindedType ann (go bs m t) (go bs m k) go bs m (BinaryNoParensType ann t1 t2 t3) = BinaryNoParensType ann (go bs m t1) (go bs m t2) (go bs m t3) go bs m (ParensInType ann t) = ParensInType ann (go bs m t) go _ _ ty = ty @@ -431,17 +490,28 @@ usedTypeVariables = ordNub . everythingOnTypes (++) go where -- | Collect all free type variables appearing in a type freeTypeVariables :: Type a -> [Text] -freeTypeVariables = ordNub . go [] where - go :: [Text] -> Type a -> [Text] - go bound (TypeVar _ v) | v `notElem` bound = [v] - go bound (TypeApp _ t1 t2) = go bound t1 ++ go bound t2 - go bound (ForAll _ v _ t _) = go (v : bound) t - go bound (ConstrainedType _ c t) = concatMap (go bound) (constraintArgs c) ++ go bound t - go bound (RCons _ _ t r) = go bound t ++ go bound r - go bound (KindedType _ t _) = go bound t - go bound (BinaryNoParensType _ t1 t2 t3) = go bound t1 ++ go bound t2 ++ go bound t3 - go bound (ParensInType _ t) = go bound t - go _ _ = [] +freeTypeVariables = ordNub . fmap snd . sort . go 0 [] where + -- Tracks kind levels so that variables appearing in kind annotations are listed first. + go :: Int -> [Text] -> Type a -> [(Int, Text)] + go lvl bound (TypeVar _ v) | v `notElem` bound = [(lvl, v)] + go lvl bound (TypeApp _ t1 t2) = go lvl bound t1 ++ go lvl bound t2 + go lvl bound (KindApp _ t1 t2) = go lvl bound t1 ++ go (lvl - 1) bound t2 + go lvl bound (ForAll _ v mbK t _) = foldMap (go (lvl - 1) bound) mbK ++ go lvl (v : bound) t + go lvl bound (ConstrainedType _ c t) = foldMap (go (lvl - 1) bound) (constraintKindArgs c) ++ foldMap (go lvl bound) (constraintArgs c) ++ go lvl bound t + go lvl bound (RCons _ _ t r) = go lvl bound t ++ go lvl bound r + go lvl bound (KindedType _ t k) = go lvl bound t ++ go (lvl - 1) bound k + go lvl bound (BinaryNoParensType _ t1 t2 t3) = go lvl bound t1 ++ go lvl bound t2 ++ go lvl bound t3 + go lvl bound (ParensInType _ t) = go lvl bound t + go _ _ _ = [] + +-- | Collect a complete set of kind-annotated quantifiers at the front of a type. +completeBinderList :: Type a -> Maybe ([(a, (Text, Type a))], Type a) +completeBinderList = go [] + where + go acc = \case + ForAll _ _ Nothing _ _ -> Nothing + ForAll ann var (Just k) ty _ -> go ((ann, (var, k)) : acc) ty + ty -> Just (reverse acc, ty) -- | Universally quantify over all type variables appearing free in a type quantify :: Type a -> Type a @@ -468,13 +538,56 @@ containsForAll = everythingOnTypes (||) go where go ForAll{} = True go _ = False +unknowns :: Type a -> IS.IntSet +unknowns = everythingOnTypes (<>) go where + go :: Type a -> IS.IntSet + go (TUnknown _ u) = IS.singleton u + go _ = mempty + +eraseKindApps :: Type a -> Type a +eraseKindApps = everywhereOnTypes $ \case + KindApp _ ty _ -> ty + ConstrainedType ann con ty -> + ConstrainedType ann (con { constraintKindArgs = [] }) ty + other -> other + +eraseForAllKindAnnotations :: Type a -> Type a +eraseForAllKindAnnotations = removeAmbiguousVars . removeForAllKinds + where + removeForAllKinds = everywhereOnTypes $ \case + ForAll ann arg _ ty sco -> + ForAll ann arg Nothing ty sco + other -> other + + removeAmbiguousVars = everywhereOnTypes $ \case + fa@(ForAll _ arg _ ty _) + | arg `elem` freeTypeVariables ty -> fa + | otherwise -> ty + other -> other + +unapplyTypes :: Type a -> (Type a, [Type a], [Type a]) +unapplyTypes = goTypes [] + where + goTypes acc (TypeApp _ a b) = goTypes (b : acc) a + goTypes acc a = let (ty, kinds) = goKinds [] a in (ty, kinds, acc) + + goKinds acc (KindApp _ a b) = goKinds (b : acc) a + goKinds acc a = (a, acc) + +unapplyConstraints :: Type a -> ([Constraint a], Type a) +unapplyConstraints = go [] + where + go acc (ConstrainedType _ con ty) = go (con : acc) ty + go acc ty = (reverse acc, ty) + everywhereOnTypes :: (Type a -> Type a) -> Type a -> Type a everywhereOnTypes f = go where go (TypeApp ann t1 t2) = f (TypeApp ann (go t1) (go t2)) - go (ForAll ann arg mbK ty sco) = f (ForAll ann arg mbK (go ty) sco) - go (ConstrainedType ann c ty) = f (ConstrainedType ann (mapConstraintArgs (map go) c) (go ty)) + go (KindApp ann t1 t2) = f (KindApp ann (go t1) (go t2)) + go (ForAll ann arg mbK ty sco) = f (ForAll ann arg (go <$> mbK) (go ty) sco) + go (ConstrainedType ann c ty) = f (ConstrainedType ann (mapConstraintArgsAll (map go) $ c) (go ty)) go (RCons ann name ty rest) = f (RCons ann name (go ty) (go rest)) - go (KindedType ann ty k) = f (KindedType ann (go ty) k) + go (KindedType ann ty k) = f (KindedType ann (go ty) (go k)) go (BinaryNoParensType ann t1 t2 t3) = f (BinaryNoParensType ann (go t1) (go t2) (go t3)) go (ParensInType ann t) = f (ParensInType ann (go t)) go other = f other @@ -482,10 +595,11 @@ everywhereOnTypes f = go where everywhereOnTypesTopDown :: (Type a -> Type a) -> Type a -> Type a everywhereOnTypesTopDown f = go . f where go (TypeApp ann t1 t2) = TypeApp ann (go (f t1)) (go (f t2)) - go (ForAll ann arg mbK ty sco) = ForAll ann arg mbK (go (f ty)) sco - go (ConstrainedType ann c ty) = ConstrainedType ann (mapConstraintArgs (map (go . f)) c) (go (f ty)) + go (KindApp ann t1 t2) = KindApp ann (go (f t1)) (go (f t2)) + go (ForAll ann arg mbK ty sco) = ForAll ann arg (go . f <$> mbK) (go (f ty)) sco + go (ConstrainedType ann c ty) = ConstrainedType ann (mapConstraintArgsAll (map (go . f)) c) (go (f ty)) go (RCons ann name ty rest) = RCons ann name (go (f ty)) (go (f rest)) - go (KindedType ann ty k) = KindedType ann (go (f ty)) k + go (KindedType ann ty k) = KindedType ann (go (f ty)) (go (f k)) go (BinaryNoParensType ann t1 t2 t3) = BinaryNoParensType ann (go (f t1)) (go (f t2)) (go (f t3)) go (ParensInType ann t) = ParensInType ann (go (f t)) go other = f other @@ -493,21 +607,35 @@ everywhereOnTypesTopDown f = go . f where everywhereOnTypesM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (Type a) everywhereOnTypesM f = go where go (TypeApp ann t1 t2) = (TypeApp ann <$> go t1 <*> go t2) >>= f - go (ForAll ann arg mbK ty sco) = (ForAll ann arg mbK <$> go ty <*> pure sco) >>= f - go (ConstrainedType ann c ty) = (ConstrainedType ann <$> overConstraintArgs (mapM go) c <*> go ty) >>= f + go (KindApp ann t1 t2) = (KindApp ann <$> go t1 <*> go t2) >>= f + go (ForAll ann arg mbK ty sco) = (ForAll ann arg <$> traverse go mbK <*> go ty <*> pure sco) >>= f + go (ConstrainedType ann c ty) = (ConstrainedType ann <$> overConstraintArgsAll (mapM go) c <*> go ty) >>= f go (RCons ann name ty rest) = (RCons ann name <$> go ty <*> go rest) >>= f - go (KindedType ann ty k) = (KindedType ann <$> go ty <*> pure k) >>= f + go (KindedType ann ty k) = (KindedType ann <$> go ty <*> go k) >>= f go (BinaryNoParensType ann t1 t2 t3) = (BinaryNoParensType ann <$> go t1 <*> go t2 <*> go t3) >>= f go (ParensInType ann t) = (ParensInType ann <$> go t) >>= f go other = f other +everywhereWithScopeOnTypesM :: Monad m => S.Set Text -> (S.Set Text -> Type a -> m (Type a)) -> Type a -> m (Type a) +everywhereWithScopeOnTypesM s0 f = go s0 where + go s (TypeApp ann t1 t2) = (TypeApp ann <$> go s t1 <*> go s t2) >>= f s + go s (KindApp ann t1 t2) = (KindApp ann <$> go s t1 <*> go s t2) >>= f s + go s (ForAll ann arg mbK ty sco) = (ForAll ann arg <$> traverse (go s) mbK <*> go (S.insert arg s) ty <*> pure sco) >>= f s + go s (ConstrainedType ann c ty) = (ConstrainedType ann <$> overConstraintArgsAll (traverse (go s)) c <*> go s ty) >>= f s + go s (RCons ann name ty rest) = (RCons ann name <$> go s ty <*> go s rest) >>= f s + go s (KindedType ann ty k) = (KindedType ann <$> go s ty <*> go s k) >>= f s + go s (BinaryNoParensType ann t1 t2 t3) = (BinaryNoParensType ann <$> go s t1 <*> go s t2 <*> go s t3) >>= f s + go s (ParensInType ann t) = (ParensInType ann <$> go s t) >>= f s + go s other = f s other + everywhereOnTypesTopDownM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (Type a) everywhereOnTypesTopDownM f = go <=< f where go (TypeApp ann t1 t2) = TypeApp ann <$> (f t1 >>= go) <*> (f t2 >>= go) - go (ForAll ann arg mbK ty sco) = ForAll ann arg mbK <$> (f ty >>= go) <*> pure sco - go (ConstrainedType ann c ty) = ConstrainedType ann <$> overConstraintArgs (mapM (go <=< f)) c <*> (f ty >>= go) + go (KindApp ann t1 t2) = KindApp ann <$> (f t1 >>= go) <*> (f t2 >>= go) + go (ForAll ann arg mbK ty sco) = ForAll ann arg <$> (traverse (f >=> go) mbK) <*> (f ty >>= go) <*> pure sco + go (ConstrainedType ann c ty) = ConstrainedType ann <$> overConstraintArgsAll (mapM (go <=< f)) c <*> (f ty >>= go) go (RCons ann name ty rest) = RCons ann name <$> (f ty >>= go) <*> (f rest >>= go) - go (KindedType ann ty k) = KindedType ann <$> (f ty >>= go) <*> pure k + go (KindedType ann ty k) = KindedType ann <$> (f ty >>= go) <*> (f k >>= go) go (BinaryNoParensType ann t1 t2 t3) = BinaryNoParensType ann <$> (f t1 >>= go) <*> (f t2 >>= go) <*> (f t3 >>= go) go (ParensInType ann t) = ParensInType ann <$> (f t >>= go) go other = f other @@ -515,10 +643,12 @@ everywhereOnTypesTopDownM f = go <=< f where everythingOnTypes :: (r -> r -> r) -> (Type a -> r) -> Type a -> r everythingOnTypes (<+>) f = go where go t@(TypeApp _ t1 t2) = f t <+> go t1 <+> go t2 + go t@(KindApp _ t1 t2) = f t <+> go t1 <+> go t2 + go t@(ForAll _ _ (Just k) ty _) = f t <+> go k <+> go ty go t@(ForAll _ _ _ ty _) = f t <+> go ty - go t@(ConstrainedType _ c ty) = foldl (<+>) (f t) (map go (constraintArgs c)) <+> go ty + go t@(ConstrainedType _ c ty) = foldl (<+>) (f t) (map go (constraintKindArgs c) ++ map go (constraintArgs c)) <+> go ty go t@(RCons _ _ ty rest) = f t <+> go ty <+> go rest - go t@(KindedType _ ty _) = f t <+> go ty + go t@(KindedType _ ty k) = f t <+> go ty <+> go k go t@(BinaryNoParensType _ t1 t2 t3) = f t <+> go t1 <+> go t2 <+> go t3 go t@(ParensInType _ t1) = f t <+> go t1 go other = f other @@ -527,10 +657,12 @@ everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type a -> (s, r everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 where go' s t = let (s', r) = f s t in r <+> go s' t go s (TypeApp _ t1 t2) = go' s t1 <+> go' s t2 + go s (KindApp _ t1 t2) = go' s t1 <+> go' s t2 + go s (ForAll _ _ (Just k) ty _) = go' s k <+> go' s ty go s (ForAll _ _ _ ty _) = go' s ty - go s (ConstrainedType _ c ty) = foldl (<+>) r0 (map (go' s) (constraintArgs c)) <+> go' s ty + go s (ConstrainedType _ c ty) = foldl (<+>) r0 (map (go' s) (constraintKindArgs c) ++ map (go' s) (constraintArgs c)) <+> go' s ty go s (RCons _ _ ty rest) = go' s ty <+> go' s rest - go s (KindedType _ ty _) = go' s ty + go s (KindedType _ ty k) = go' s ty <+> go' s k go s (BinaryNoParensType _ t1 t2 t3) = go' s t1 <+> go' s t2 <+> go' s t3 go s (ParensInType _ t1) = go' s t1 go _ _ = r0 @@ -543,9 +675,10 @@ annForType k (TypeWildcard a b) = (\z -> TypeWildcard z b) <$> k a annForType k (TypeConstructor a b) = (\z -> TypeConstructor z b) <$> k a annForType k (TypeOp a b) = (\z -> TypeOp z b) <$> k a annForType k (TypeApp a b c) = (\z -> TypeApp z b c) <$> k a +annForType k (KindApp a b c) = (\z -> KindApp z b c) <$> k a annForType k (ForAll a b c d e) = (\z -> ForAll z b c d e) <$> k a annForType k (ConstrainedType a b c) = (\z -> ConstrainedType z b c) <$> k a -annForType k (Skolem a b c d) = (\z -> Skolem z b c d) <$> k a +annForType k (Skolem a b c d e) = (\z -> Skolem z b c d e) <$> k a annForType k (REmpty a) = REmpty <$> k a annForType k (RCons a b c d) = (\z -> RCons z b c d) <$> k a annForType k (KindedType a b c) = (\z -> KindedType z b c) <$> k a @@ -572,16 +705,22 @@ eqType (TypeWildcard _ a) (TypeWildcard _ a') = a == a' eqType (TypeConstructor _ a) (TypeConstructor _ a') = a == a' eqType (TypeOp _ a) (TypeOp _ a') = a == a' eqType (TypeApp _ a b) (TypeApp _ a' b') = eqType a a' && eqType b b' -eqType (ForAll _ a b c d) (ForAll _ a' b' c' d') = a == a' && eqMaybeKind b b' && eqType c c' && d == d' +eqType (KindApp _ a b) (KindApp _ a' b') = eqType a a' && eqType b b' +eqType (ForAll _ a b c d) (ForAll _ a' b' c' d') = a == a' && eqMaybeType b b' && eqType c c' && d == d' eqType (ConstrainedType _ a b) (ConstrainedType _ a' b') = eqConstraint a a' && eqType b b' -eqType (Skolem _ a b c) (Skolem _ a' b' c') = a == a' && b == b' && c == c' +eqType (Skolem _ a b c d) (Skolem _ a' b' c' d') = a == a' && eqMaybeType b b' && c == c' && d == d' eqType (REmpty _) (REmpty _) = True eqType (RCons _ a b c) (RCons _ a' b' c') = a == a' && eqType b b' && eqType c c' -eqType (KindedType _ a b) (KindedType _ a' b') = eqType a a' && eqKind b b' +eqType (KindedType _ a b) (KindedType _ a' b') = eqType a a' && eqType b b' eqType (BinaryNoParensType _ a b c) (BinaryNoParensType _ a' b' c') = eqType a a' && eqType b b' && eqType c c' eqType (ParensInType _ a) (ParensInType _ a') = eqType a a' eqType _ _ = False +eqMaybeType :: Maybe (Type a) -> Maybe (Type b) -> Bool +eqMaybeType (Just a) (Just b) = eqType a b +eqMaybeType Nothing Nothing = True +eqMaybeType _ _ = False + compareType :: Type a -> Type b -> Ordering compareType (TUnknown _ a) (TUnknown _ a') = compare a a' compareType (TUnknown {}) _ = LT @@ -610,7 +749,11 @@ compareType (TypeApp _ a b) (TypeApp _ a' b') = compareType a a' <> compareType compareType (TypeApp {}) _ = LT compareType _ (TypeApp {}) = GT -compareType (ForAll _ a b c d) (ForAll _ a' b' c' d') = compare a a' <> compareMaybeKind b b' <> compareType c c' <> compare d d' +compareType (KindApp _ a b) (KindApp _ a' b') = compareType a a' <> compareType b b' +compareType (KindApp {}) _ = LT +compareType _ (KindApp {}) = GT + +compareType (ForAll _ a b c d) (ForAll _ a' b' c' d') = compare a a' <> compareMaybeType b b' <> compareType c c' <> compare d d' compareType (ForAll {}) _ = LT compareType _ (ForAll {}) = GT @@ -618,7 +761,7 @@ compareType (ConstrainedType _ a b) (ConstrainedType _ a' b') = compareConstrain compareType (ConstrainedType {}) _ = LT compareType _ (ConstrainedType {}) = GT -compareType (Skolem _ a b c) (Skolem _ a' b' c') = compare a a' <> compare b b' <> compare c c' +compareType (Skolem _ a b c d) (Skolem _ a' b' c' d') = compare a a' <> compareMaybeType b b' <> compare c c' <> compare d d' compareType (Skolem {}) _ = LT compareType _ (Skolem {}) = GT @@ -630,7 +773,7 @@ compareType (RCons _ a b c) (RCons _ a' b' c') = compare a a' <> compareType b b compareType (RCons {}) _ = LT compareType _ (RCons {}) = GT -compareType (KindedType _ a b) (KindedType _ a' b') = compareType a a' <> compareKind b b' +compareType (KindedType _ a b) (KindedType _ a' b') = compareType a a' <> compareType b b' compareType (KindedType {}) _ = LT compareType _ (KindedType {}) = GT @@ -641,6 +784,12 @@ compareType _ (BinaryNoParensType {}) = GT compareType (ParensInType _ a) (ParensInType _ a') = compareType a a' compareType (ParensInType {}) _ = GT +compareMaybeType :: Maybe (Type a) -> Maybe (Type b) -> Ordering +compareMaybeType (Just a) (Just b) = compareType a b +compareMaybeType Nothing Nothing = EQ +compareMaybeType Nothing _ = LT +compareMaybeType _ _ = GT + instance Eq (Constraint a) where (==) = eqConstraint @@ -648,7 +797,7 @@ instance Ord (Constraint a) where compare = compareConstraint eqConstraint :: Constraint a -> Constraint b -> Bool -eqConstraint (Constraint _ a b c) (Constraint _ a' b' c') = a == a' && and (zipWith eqType b b') && c == c' +eqConstraint (Constraint _ a b c d) (Constraint _ a' b' c' d') = a == a' && and (zipWith eqType b b') && and (zipWith eqType c c') && d == d' compareConstraint :: Constraint a -> Constraint b -> Ordering -compareConstraint (Constraint _ a b c) (Constraint _ a' b' c') = compare a a' <> fold (zipWith compareType b b') <> compare c c' +compareConstraint (Constraint _ a b c d) (Constraint _ a' b' c' d') = compare a a' <> fold (zipWith compareType b b') <> fold (zipWith compareType c c') <> compare d d' diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs index 9ee107b6bb..4599ee0b0a 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs @@ -3,8 +3,7 @@ -- and attaching comments. module Language.PureScript.CST.Convert - ( convertKind - , convertType + ( convertType , convertExpr , convertBinder , convertDeclaration @@ -27,13 +26,14 @@ import qualified "text" Data.Text as Text import qualified "purescript-ast" Language.PureScript.AST as AST import qualified "purescript-ast" Language.PureScript.AST.SourcePos as Pos import qualified "purescript-ast" Language.PureScript.Comments as C +import "purescript-ast" Language.PureScript.Crash (internalError) import qualified "purescript-ast" Language.PureScript.Environment as Env -import qualified "purescript-ast" Language.PureScript.Kinds as K import qualified "purescript-ast" Language.PureScript.Label as L import qualified "purescript-ast" Language.PureScript.Names as N import "purescript-ast" Language.PureScript.PSString (mkString) import qualified "purescript-ast" Language.PureScript.Types as T import "this" Language.PureScript.CST.Positions +import "this" Language.PureScript.CST.Print (printToken) import "this" Language.PureScript.CST.Types comment :: Comment a -> Maybe C.Comment @@ -93,26 +93,6 @@ qualified q = N.Qualified (qualModule q) (qualName q) ident :: Ident -> N.Ident ident = N.Ident . getIdent -convertKind :: String -> Kind a -> K.SourceKind -convertKind fileName = go - where - go = \case - KindName _ a -> - K.NamedKind (sourceQualName fileName a) $ qualified a - KindArr _ a _ b -> do - let - lhs = go a - rhs = go b - ann = Pos.widenSourceAnn (K.getAnnForKind lhs) (K.getAnnForKind rhs) - K.FunKind ann lhs rhs - KindRow _ tok a -> do - let - kind = go a - ann = widenLeft (tokAnn tok) $ K.getAnnForKind kind - K.Row ann kind - KindParens _ (Wrapped _ a _) -> - go a - convertType :: String -> Type a -> T.SourceType convertType fileName = go where @@ -153,17 +133,16 @@ convertType fileName = go mkForAll a b t = do let ann' = widenLeft (tokAnn $ nameTok a) $ T.getAnnForType t T.ForAll ann' (getIdent $ nameValue a) b t Nothing - k t (TypeVarKinded (Wrapped _ (Labeled a _ b) _)) = mkForAll a (Just (convertKind fileName b)) t - k t (TypeVarName a) = mkForAll a Nothing t - -- The existing parser builds variables in reverse order - ty' = foldl k (go ty) bindings + k (TypeVarKinded (Wrapped _ (Labeled a _ b) _)) = mkForAll a (Just (go b)) + k (TypeVarName a) = mkForAll a Nothing + ty' = foldr k (go ty) bindings ann = widenLeft (tokAnn kw) $ T.getAnnForType ty' T.setAnnForType ann ty' TypeKinded _ ty _ kd -> do let ty' = go ty - kd' = convertKind fileName kd - ann = Pos.widenSourceAnn (T.getAnnForType ty') (K.getAnnForKind kd') + kd' = go kd + ann = Pos.widenSourceAnn (T.getAnnForType ty') (T.getAnnForType kd') T.KindedType ann ty' kd' TypeApp _ a b -> do let @@ -203,6 +182,12 @@ convertType fileName = go T.ConstrainedType ann a' b' TypeParens _ (Wrapped a ty b) -> T.ParensInType (sourceAnnCommented fileName a b) $ go ty + ty@(TypeUnaryRow _ _ a) -> do + let + a' = go a + rng = typeRange ty + ann = uncurry (sourceAnnCommented fileName) rng + T.setAnnForType ann $ Env.kindRow a' convertConstraint :: String -> Constraint a -> T.SourceConstraint convertConstraint fileName = go @@ -210,7 +195,7 @@ convertConstraint fileName = go go = \case cst@(Constraint _ name args) -> do let ann = uncurry (sourceAnnCommented fileName) $ constraintRange cst - T.Constraint ann (qualified name) (convertType fileName <$> args) Nothing + T.Constraint ann (qualified name) [] (convertType fileName <$> args) Nothing ConstraintParens _ (Wrapped _ c _) -> go c convertGuarded :: String -> Guarded a -> [AST.GuardedExpr] @@ -505,6 +490,15 @@ convertDeclaration fileName decl = case decl of (qualified cls) (convertType fileName <$> args) instTy + DeclKindSignature _ kw (Labeled name _ ty) -> do + let + kindFor = case tokValue kw of + TokLowerName [] "data" -> AST.DataSig + TokLowerName [] "newtype" -> AST.NewtypeSig + TokLowerName [] "type" -> AST.TypeSynonymSig + TokLowerName [] "class" -> AST.ClassSig + tok -> internalError $ "Invalid kind signature keyword " <> Text.unpack (printToken tok) + pure . AST.KindDeclaration ann kindFor (nameValue name) $ convertType fileName ty DeclSignature _ lbl -> pure $ convertSignature fileName lbl DeclValue _ fields -> @@ -526,9 +520,9 @@ convertDeclaration fileName decl = case decl of ForeignValue (Labeled a _ b) -> AST.ExternDeclaration ann (ident $ nameValue a) $ convertType fileName b ForeignData _ (Labeled a _ b) -> - AST.ExternDataDeclaration ann (nameValue a) $ convertKind fileName b + AST.ExternDataDeclaration ann (nameValue a) $ convertType fileName b ForeignKind _ a -> - AST.ExternKindDeclaration ann (nameValue a) + AST.DataDeclaration ann Env.Data (nameValue a) [] [] DeclRole _ _ _ name roles -> pure $ AST.RoleDeclaration $ AST.RoleDeclarationData ann (nameValue name) (roleValue <$> NE.toList roles) @@ -537,7 +531,7 @@ convertDeclaration fileName decl = case decl of uncurry (sourceAnnCommented fileName) $ declRange decl goTypeVar = \case - TypeVarKinded (Wrapped _ (Labeled x _ y) _) -> (getIdent $ nameValue x, Just $ convertKind fileName y) + TypeVarKinded (Wrapped _ (Labeled x _ y) _) -> (getIdent $ nameValue x, Just $ convertType fileName y) TypeVarName x -> (getIdent $ nameValue x, Nothing) goInstanceBinding = \case @@ -597,7 +591,7 @@ convertImport fileName imp = case imp of ImportClass _ _ a -> AST.TypeClassRef ann $ nameValue a ImportKind _ _ a -> - AST.KindRef ann $ nameValue a + AST.TypeRef ann (nameValue a) (Just []) where ann = sourceSpan fileName . toSourceRange $ importRange imp @@ -621,7 +615,7 @@ convertExport fileName export = case export of ExportClass _ _ a -> AST.TypeClassRef ann $ nameValue a ExportKind _ _ a -> - AST.KindRef ann $ nameValue a + AST.TypeRef ann (nameValue a) Nothing ExportModule _ _ a -> AST.ModuleRef ann (nameValue a) where diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs b/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs index cbc01d3264..83387a9324 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs @@ -1,8 +1,12 @@ module Language.PureScript.CST.Errors - ( ParserError(..) + ( ParserErrorInfo(..) , ParserErrorType(..) + , ParserWarningType(..) + , ParserError + , ParserWarning , prettyPrintError , prettyPrintErrorMessage + , prettyPrintWarningMessage ) where import "base" Prelude @@ -16,6 +20,7 @@ import "base" Text.Printf (printf) data ParserErrorType = ErrWildcardInType + | ErrConstraintInKind | ErrHoleInType | ErrExprInBinder | ErrExprInDeclOrBinder @@ -52,15 +57,25 @@ data ParserErrorType | ErrCustom String deriving (Show, Eq, Ord) -data ParserError = ParserError +data ParserWarningType + = WarnDeprecatedRowSyntax + | WarnDeprecatedForeignKindSyntax + | WarnDeprecatedKindImportSyntax + | WarnDeprecatedKindExportSyntax + deriving (Show, Eq, Ord) + +data ParserErrorInfo a = ParserErrorInfo { errRange :: SourceRange , errToks :: [SourceToken] , errStack :: LayoutStack - , errType :: ParserErrorType + , errType :: a } deriving (Show, Eq) +type ParserError = ParserErrorInfo ParserErrorType +type ParserWarning = ParserErrorInfo ParserWarningType + prettyPrintError :: ParserError -> String -prettyPrintError pe@(ParserError { errRange }) = +prettyPrintError pe@(ParserErrorInfo { errRange }) = prettyPrintErrorMessage pe <> " at " <> errPos where errPos = case errRange of @@ -68,9 +83,11 @@ prettyPrintError pe@(ParserError { errRange }) = "line " <> show line <> ", column " <> show col prettyPrintErrorMessage :: ParserError -> String -prettyPrintErrorMessage (ParserError {..}) = case errType of +prettyPrintErrorMessage (ParserErrorInfo {..}) = case errType of ErrWildcardInType -> "Unexpected wildcard in type; type wildcards are only allowed in value annotations" + ErrConstraintInKind -> + "Unsupported constraint in kind; constraints are only allowed in value annotations" ErrHoleInType -> "Unexpected hole in type; type holes are only allowed in value annotations" ErrExprInBinder -> @@ -162,3 +179,14 @@ prettyPrintErrorMessage (ParserError {..}) = case errType of displayCodePoint :: Char -> String displayCodePoint x = "U+" <> map toUpper (printf "%0.4x" (fromEnum x)) + +prettyPrintWarningMessage :: ParserWarning -> String +prettyPrintWarningMessage (ParserErrorInfo {..}) = case errType of + WarnDeprecatedRowSyntax -> + "Unary '#' syntax for row kinds is deprecated and will be removed in a future release. Use the 'Row' kind instead." + WarnDeprecatedForeignKindSyntax -> + "Foreign kind imports are deprecated and will be removed in a future release. Use empty 'data' instead." + WarnDeprecatedKindImportSyntax -> + "Kind imports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead." + WarnDeprecatedKindExportSyntax -> + "Kind exports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead." diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs b/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs new file mode 100644 index 0000000000..91609f1205 --- /dev/null +++ b/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs @@ -0,0 +1,50 @@ +module Language.PureScript.CST.Flatten where + +import "base" Prelude + +import "dlist" Data.DList (DList) +import "this" Language.PureScript.CST.Types + +flattenWrapped :: (a -> DList SourceToken) -> Wrapped a -> DList SourceToken +flattenWrapped k (Wrapped a b c) = pure a <> k b <> pure c + +flattenSeparated :: (a -> DList SourceToken) -> Separated a -> DList SourceToken +flattenSeparated k (Separated a b) = k a <> foldMap (\(c, d) -> pure c <> k d) b + +flattenLabeled :: (a -> DList SourceToken) -> (b -> DList SourceToken) -> Labeled a b -> DList SourceToken +flattenLabeled ka kc (Labeled a b c) = ka a <> pure b <> kc c + +flattenType :: Type a -> DList SourceToken +flattenType = \case + TypeVar _ a -> pure $ nameTok a + TypeConstructor _ a -> pure $ qualTok a + TypeWildcard _ a -> pure a + TypeHole _ a -> pure $ nameTok a + TypeString _ a _ -> pure a + TypeRow _ a -> flattenWrapped flattenRow a + TypeRecord _ a -> flattenWrapped flattenRow a + TypeForall _ a b c d -> pure a <> foldMap flattenTypeVarBinding b <> pure c <> flattenType d + TypeKinded _ a b c -> flattenType a <> pure b <> flattenType c + TypeApp _ a b -> flattenType a <> flattenType b + TypeOp _ a b c -> flattenType a <> pure (qualTok b) <> flattenType c + TypeOpName _ a -> pure $ qualTok a + TypeArr _ a b c -> flattenType a <> pure b <> flattenType c + TypeArrName _ a -> pure a + TypeConstrained _ a b c -> flattenConstraint a <> pure b <> flattenType c + TypeParens _ a -> flattenWrapped flattenType a + TypeUnaryRow _ a b -> pure a <> flattenType b + +flattenRow :: Row a -> DList SourceToken +flattenRow (Row lbls tl) = + foldMap (flattenSeparated (flattenLabeled (pure . lblTok) flattenType)) lbls + <> foldMap (\(a, b) -> pure a <> flattenType b) tl + +flattenTypeVarBinding :: TypeVarBinding a -> DList SourceToken +flattenTypeVarBinding = \case + TypeVarKinded a -> flattenWrapped (flattenLabeled (pure . nameTok) flattenType) a + TypeVarName a -> pure $ nameTok a + +flattenConstraint :: Constraint a -> DList SourceToken +flattenConstraint = \case + Constraint _ a b -> pure (qualTok a) <> foldMap flattenType b + ConstraintParens _ a -> flattenWrapped flattenConstraint a diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs index 274040f893..e6f73f7635 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs @@ -81,7 +81,7 @@ lexWithState = go pos = applyDelta lexPos chunkDelta pure $ Left ( state { lexSource = lexSource' } - , ParserError (SourceRange pos $ applyDelta pos (0, 1)) [] lexStack err + , ParserErrorInfo (SourceRange pos $ applyDelta pos (0, 1)) [] lexStack err ) onSuccess _ (TokEof, _) = diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs b/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs index 33416125ed..b87dd3d288 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs @@ -23,6 +23,7 @@ data LexState = LexState data ParserState = ParserState { parserBuff :: [LexResult] , parserErrors :: [ParserError] + , parserWarnings :: [ParserWarning] } deriving (Show) -- | A bare bones, CPS'ed `StateT s (Except e) a`. @@ -67,8 +68,17 @@ runParser st (Parser k) = k st left right | null parserErrors = (st', Right res) | otherwise = (st', Left $ NE.fromList $ sortBy (comparing errRange) parserErrors) -runTokenParser :: Parser a -> [LexResult] -> Either (NE.NonEmpty ParserError) a -runTokenParser p = snd . flip runParser p . flip ParserState [] +runTokenParser :: Parser a -> [LexResult] -> Either (NE.NonEmpty ParserError) ([ParserWarning], a) +runTokenParser p buff = fmap (warnings,) res + where + (ParserState _ _ warnings, res) = + runParser initialState p + + initialState = ParserState + { parserBuff = buff + , parserErrors = [] + , parserWarnings = [] + } {-# INLINE throw #-} throw :: e -> ParserM e s a @@ -76,16 +86,16 @@ throw e = Parser $ \st kerr _ -> kerr st e parseError :: SourceToken -> Parser a parseError tok = Parser $ \st kerr _ -> - kerr st $ ParserError + kerr st $ ParserErrorInfo { errRange = tokRange . tokAnn $ tok , errToks = [tok] , errStack = [] -- TODO parserStack st , errType = ErrToken } -mkParserError :: LayoutStack -> [SourceToken] -> ParserErrorType -> ParserError +mkParserError :: LayoutStack -> [SourceToken] -> a -> ParserErrorInfo a mkParserError stack toks ty = - ParserError + ParserErrorInfo { errRange = range , errToks = toks , errStack = stack @@ -110,6 +120,10 @@ parseFail' toks msg = Parser $ \st kerr _ -> kerr st (mkParserError [] toks msg) parseFail :: SourceToken -> ParserErrorType -> Parser a parseFail = parseFail' . pure +addWarning :: [SourceToken] -> ParserWarningType -> Parser () +addWarning toks ty = Parser $ \st _ ksucc -> + ksucc (st { parserWarnings = mkParserError [] toks ty : parserWarnings st }) () + pushBack :: SourceToken -> Parser () pushBack tok = Parser $ \st _ ksucc -> ksucc (st { parserBuff = Right tok : parserBuff st }) () @@ -128,14 +142,15 @@ tryPrefix (Parser lhs) rhs = Parser $ \st kerr ksucc -> oneOf :: NE.NonEmpty (Parser a) -> Parser a oneOf parsers = Parser $ \st kerr ksucc -> do let + prevErrs = parserErrors st go (st', Right a) _ = (st', Right a) go _ (st', Right a) = (st', Right a) go (st1, Left errs1) (st2, Left errs2) | errRange (NE.last errs2) > errRange (NE.last errs1) = (st2, Left errs2) | otherwise = (st1, Left errs1) - case foldr1 go $ runParser st <$> parsers of - (st', Left errs) -> kerr (st' { parserErrors = NE.tail errs }) $ NE.head errs - (st', Right res) -> ksucc st' res + case foldr1 go $ runParser (st { parserErrors = [] }) <$> parsers of + (st', Left errs) -> kerr (st' { parserErrors = prevErrs <> NE.tail errs}) $ NE.head errs + (st', Right res) -> ksucc (st' { parserErrors = prevErrs }) res manyDelimited :: Token -> Token -> Token -> Parser a -> Parser [a] manyDelimited open close sep p = do diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y index 8e888a2c40..54a412956c 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y +++ b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y @@ -1,7 +1,6 @@ { module Language.PureScript.CST.Parser ( parseType - , parseKind , parseExpr , parseDecl , parseIdent @@ -20,11 +19,12 @@ module Language.PureScript.CST.Parser import "base" Prelude hiding (lex) import "base" Control.Monad ((<=<), when) -import "base" Data.Foldable (foldl', for_) +import "base" Data.Foldable (foldl', for_, toList) import qualified "base" Data.List.NonEmpty as NE import "text" Data.Text (Text) -import "base" Data.Traversable (for) +import "base" Data.Traversable (for, sequence) import "this" Language.PureScript.CST.Errors +import "this" Language.PureScript.CST.Flatten (flattenType) import "this" Language.PureScript.CST.Lexer import "this" Language.PureScript.CST.Monad import "this" Language.PureScript.CST.Positions @@ -35,9 +35,8 @@ import qualified "purescript-ast" Language.PureScript.Roles as R import "purescript-ast" Language.PureScript.PSString (PSString) } -%expect 114 +%expect 95 -%name parseKind kind %name parseType type %name parseExpr expr %name parseIdent ident @@ -57,6 +56,7 @@ import "purescript-ast" Language.PureScript.PSString (PSString) %partial parseGuardExpr guardExpr %partial parseGuardNext guardNext %partial parseGuardStatement guardStatement +%partial parseClassSignature classSignature %partial parseClassSuper classSuper %partial parseClassNameAndFundeps classNameAndFundeps %partial parseBinderAndArrow binderAndArrow @@ -259,7 +259,11 @@ label :: { Label } | 'let' { toLabel $1 } | 'module' { toLabel $1 } | 'newtype' { toLabel $1 } + | 'nominal' { toLabel $1 } | 'of' { toLabel $1 } + | 'phantom' { toLabel $1 } + | 'representational' { toLabel $1 } + | 'role' { toLabel $1 } | 'then' { toLabel $1 } | 'true' { toLabel $1 } | 'type' { toLabel $1 } @@ -286,18 +290,9 @@ boolean :: { (SourceToken, Bool) } : 'true' { toBoolean $1 } | 'false' { toBoolean $1 } -kind :: { Kind () } - : kind1 { $1 } - | kind1 '->' kind { KindArr () $1 $2 $3 } - -kind1 :: { Kind () } - : qualProperName { KindName () $1 } - | '#' kind1 { KindRow () $1 $2 } - | '(' kind ')' { KindParens () (Wrapped $1 $2 $3) } - type :: { Type () } : type1 { $1 } - | type1 '::' kind { TypeKinded () $1 $2 $3 } + | type1 '::' type { TypeKinded () $1 $2 $3 } type1 :: { Type () } : type2 { $1 } @@ -313,8 +308,12 @@ type3 :: { Type () } | type3 qualOp type4 { TypeOp () $1 $2 $3 } type4 :: { Type () } + : type5 { $1 } + | '#' type4 {% addWarning ($1 : toList (flattenType $2)) WarnDeprecatedRowSyntax *> pure (TypeUnaryRow () $1 $2) } + +type5 :: { Type () } : typeAtom { $1 } - | type4 typeAtom { TypeApp () $1 $2 } + | type5 typeAtom { TypeApp () $1 $2 } typeAtom :: { Type ()} : '_' { TypeWildcard () $1 } @@ -327,7 +326,7 @@ typeAtom :: { Type ()} | '{' row '}' { TypeRecord () (Wrapped $1 $2 $3) } | '(' row ')' { TypeRow () (Wrapped $1 $2 $3) } | '(' type1 ')' { TypeParens () (Wrapped $1 $2 $3) } - | '(' typeKindedAtom '::' kind ')' { TypeParens () (Wrapped $1 (TypeKinded () $2 $3 $4) $5) } + | '(' typeKindedAtom '::' type ')' { TypeParens () (Wrapped $1 (TypeKinded () $2 $3 $4) $5) } -- Due to a conflict between row syntax and kinded type syntax, we require -- kinded type variables to be wrapped in parens. Thus `(a :: Foo)` is always a @@ -340,7 +339,7 @@ typeKindedAtom :: { Type () } | '{' row '}' { TypeRecord () (Wrapped $1 $2 $3) } | '(' row ')' { TypeRow () (Wrapped $1 $2 $3) } | '(' type1 ')' { TypeParens () (Wrapped $1 $2 $3) } - | '(' typeKindedAtom '::' kind ')' { TypeParens () (Wrapped $1 (TypeKinded () $2 $3 $4) $5) } + | '(' typeKindedAtom '::' type ')' { TypeParens () (Wrapped $1 (TypeKinded () $2 $3 $4) $5) } row :: { Row () } : {- empty -} { Row Nothing Nothing } @@ -353,7 +352,7 @@ rowLabel :: { Labeled Label (Type ()) } typeVarBinding :: { TypeVarBinding () } : ident { TypeVarName $1 } - | '(' ident '::' kind ')' { TypeVarKinded (Wrapped $1 (Labeled $2 $3 $4) $5) } + | '(' ident '::' type ')' {% checkNoWildcards $4 *> pure (TypeVarKinded (Wrapped $1 (Labeled $2 $3 $4) $5)) } forall :: { SourceToken } : 'forall' { $1 } @@ -634,7 +633,7 @@ export :: { Export () } | properName dataMembers { ExportType () $1 (Just $2) } | 'type' symbol { ExportTypeOp () $1 $2 } | 'class' properName { ExportClass () $1 $2 } - | 'kind' properName { ExportKind () $1 $2 } + | 'kind' properName {% addWarning [$1, nameTok $2] WarnDeprecatedKindExportSyntax *> pure (ExportKind () $1 $2) } | 'module' moduleName { ExportModule () $1 $2 } dataMembers :: { (DataMembers ()) } @@ -658,23 +657,28 @@ import :: { Import () } | properName dataMembers { ImportType () $1 (Just $2) } | 'type' symbol { ImportTypeOp () $1 $2 } | 'class' properName { ImportClass () $1 $2 } - | 'kind' properName { ImportKind () $1 $2 } + | 'kind' properName {% addWarning [$1, nameTok $2] WarnDeprecatedKindImportSyntax *> pure (ImportKind () $1 $2) } decl :: { Declaration () } : dataHead { DeclData () $1 Nothing } | dataHead '=' sep(dataCtor, '|') { DeclData () $1 (Just ($2, $3)) } | typeHead '=' type {% checkNoWildcards $3 *> pure (DeclType () $1 $2 $3) } | newtypeHead '=' properName typeAtom {% checkNoWildcards $4 *> pure (DeclNewtype () $1 $2 $3 $4) } - | classHead {% checkFundeps $1 *> pure (DeclClass () $1 Nothing) } - | classHead 'where' '\{' manySep(classMember, '\;') '\}' {% checkFundeps $1 *> pure (DeclClass () $1 (Just ($2, $4))) } + | classHead { either id (\h -> DeclClass () h Nothing) $1 } + | classHead 'where' '\{' manySep(classMember, '\;') '\}' {% either (const (parseError $2)) (\h -> pure $ DeclClass () h (Just ($2, $4))) $1 } | instHead { DeclInstanceChain () (Separated (Instance $1 Nothing) []) } | instHead 'where' '\{' manySep(instBinding, '\;') '\}' { DeclInstanceChain () (Separated (Instance $1 (Just ($2, $4))) []) } + | 'data' properName '::' type {% checkNoWildcards $4 *> pure (DeclKindSignature () $1 (Labeled $2 $3 $4)) } + | 'newtype' properName '::' type {% checkNoWildcards $4 *> pure (DeclKindSignature () $1 (Labeled $2 $3 $4)) } + | 'type' properName '::' type {% checkNoWildcards $4 *> pure (DeclKindSignature () $1 (Labeled $2 $3 $4)) } | 'derive' instHead { DeclDerive () $1 Nothing $2 } | 'derive' 'newtype' instHead { DeclDerive () $1 (Just $2) $3 } | ident '::' type { DeclSignature () (Labeled $1 $2 $3) } | ident manyOrEmpty(binderAtom) guardedDecl { DeclValue () (ValueBindingFields $1 $2 $3) } | fixity { DeclFixity () $1 } - | 'foreign' 'import' foreign { DeclForeign () $1 $2 $3 } + | 'foreign' 'import' ident '::' type { DeclForeign () $1 $2 (ForeignValue (Labeled $3 $4 $5)) } + | 'foreign' 'import' 'data' properName '::' type { DeclForeign () $1 $2 (ForeignData $3 (Labeled $4 $5 $6)) } + | 'foreign' 'import' 'kind' properName {% addWarning [$1, $2, $3, nameTok $4] WarnDeprecatedForeignKindSyntax *> pure (DeclForeign () $1 $2 (ForeignKind $3 $4)) } | 'type' 'role' properName many(role) { DeclRole () $1 $2 $3 $4 } dataHead :: { DataHead () } @@ -699,16 +703,22 @@ dataCtor :: { DataCtor () } -- : 'class' classNameAndFundeps -- | 'class' constraints '<=' classNameAndFundeps -- -classHead :: { ClassHead () } +classHead :: { Either (Declaration ()) (ClassHead ()) } : 'class' - {%% revert $ do - let - ctr (super, (name, vars, fundeps)) = - ClassHead $1 super name vars fundeps - fmap ctr $ tryPrefix parseClassSuper parseClassNameAndFundeps + {%% revert $ oneOf $ NE.fromList + [ fmap (Left . DeclKindSignature () $1) parseClassSignature + , do + (super, (name, vars, fundeps)) <- tryPrefix parseClassSuper parseClassNameAndFundeps + let hd = ClassHead $1 super name vars fundeps + checkFundeps hd + pure $ Right hd + ] } -classSuper +classSignature :: { Labeled (Name (N.ProperName 'N.TypeName)) (Type ()) } + : properName '::' type {%^ revert $ checkNoWildcards $3 *> pure (Labeled $1 $2 $3) } + +classSuper :: { (OneOrDelimited (Constraint ()), SourceToken) } : constraints '<=' {%^ revert $ pure ($1, $2) } classNameAndFundeps :: { (Name (N.ProperName 'N.ClassName), [TypeVarBinding ()], Maybe (SourceToken, Separated ClassFundep)) } @@ -753,11 +763,6 @@ infix :: { (SourceToken, Fixity) } | 'infixl' { ($1, Infixl) } | 'infixr' { ($1, Infixr) } -foreign :: { Foreign () } - : ident '::' type { ForeignValue (Labeled $1 $2 $3) } - | 'data' properName '::' kind { ForeignData $1 (Labeled $2 $3 $4) } - | 'kind' properName { ForeignKind $1 $2 } - role :: { Role } : 'nominal' { Role $1 R.Nominal } | 'representational' { Role $1 R.Representational } @@ -789,24 +794,21 @@ qualIdentP :: { QualifiedName Ident } lexer :: (SourceToken -> Parser a) -> Parser a lexer k = munch >>= k -parse :: Text -> Either (NE.NonEmpty ParserError) (Module ()) -parse = resFull <=< parseModule . lex +parse :: Text -> ([ParserWarning], Either (NE.NonEmpty ParserError) (Module ())) +parse = either (([],) . Left) resFull . parseModule . lex data PartialResult a = PartialResult { resPartial :: a - , resFull :: Either (NE.NonEmpty ParserError) a + , resFull :: ([ParserWarning], Either (NE.NonEmpty ParserError) a) } deriving (Functor) parseModule :: [LexResult] -> Either (NE.NonEmpty ParserError) (PartialResult (Module ())) parseModule toks = fmap (\header -> PartialResult header (parseFull header)) headerRes where (st, headerRes) = - runParser (ParserState (toks) []) parseModuleHeader + runParser (ParserState toks [] []) parseModuleHeader parseFull header = do - (decls, trailing) <- snd $ runParser st parseModuleBody - pure $ header - { modDecls = decls - , modTrailingComments = trailing - } + let (ParserState _ _ warnings, res) = runParser st parseModuleBody + (warnings, (\(decls, trailing) -> header { modDecls = decls, modTrailingComments = trailing }) <$> res) } diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs index 1d5defa043..cafd2428f7 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs @@ -175,6 +175,7 @@ declRange = \case where start = classHeadRange hd DeclInstanceChain _ a -> (fst . instanceRange $ sepHead a, snd . instanceRange $ sepLast a) DeclDerive _ a _ b -> (a, snd $ instanceHeadRange b) + DeclKindSignature _ a (Labeled _ _ b) -> (a, snd $ typeRange b) DeclSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b) DeclValue _ a -> valueBindingFieldsRange a DeclFixity _ (FixityFields a _ (FixityValue _ _ b)) -> (fst a, nameTok b) @@ -222,7 +223,7 @@ instanceBindingRange = \case foreignRange :: Foreign a -> TokenRange foreignRange = \case ForeignValue (Labeled a _ b) -> (nameTok a, snd $ typeRange b) - ForeignData a (Labeled _ _ b) -> (a, snd $ kindRange b) + ForeignData a (Labeled _ _ b) -> (a, snd $ typeRange b) ForeignKind a b -> (a, nameTok b) valueBindingFieldsRange :: ValueBindingFields a -> TokenRange @@ -241,13 +242,6 @@ whereRange (Where a bs) | Just (_, ls) <- bs = (fst $ exprRange a, snd . letBindingRange $ NE.last ls) | otherwise = exprRange a -kindRange :: Kind a -> TokenRange -kindRange = \case - KindName _ a -> qualRange a - KindArr _ a _ b -> (fst $ kindRange a, snd $ kindRange b) - KindRow _ a b -> (a, snd $ kindRange b) - KindParens _ a -> wrappedRange a - typeRange :: Type a -> TokenRange typeRange = \case TypeVar _ a -> nameRange a @@ -258,7 +252,7 @@ typeRange = \case TypeRow _ a -> wrappedRange a TypeRecord _ a -> wrappedRange a TypeForall _ a _ _ b -> (a, snd $ typeRange b) - TypeKinded _ a _ b -> (fst $ typeRange a, snd $ kindRange b) + TypeKinded _ a _ b -> (fst $ typeRange a, snd $ typeRange b) TypeApp _ a b -> (fst $ typeRange a, snd $ typeRange b) TypeOp _ a _ b -> (fst $ typeRange a, snd $ typeRange b) TypeOpName _ a -> qualRange a @@ -266,6 +260,7 @@ typeRange = \case TypeArrName _ a -> (a, a) TypeConstrained _ a _ b -> (fst $ constraintRange a, snd $ typeRange b) TypeParens _ a -> wrappedRange a + TypeUnaryRow _ a b -> (a, snd $ typeRange b) constraintRange :: Constraint a -> TokenRange constraintRange = \case diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs b/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs index c206e409e3..1bce8e8c91 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs @@ -17,7 +17,7 @@ everythingOnTypes op k = goTy TypeRow _ (Wrapped _ row _) -> goRow ty row TypeRecord _ (Wrapped _ row _) -> goRow ty row TypeForall _ _ _ _ ty2 -> k ty `op` goTy ty2 - TypeKinded _ ty2 _ _ -> k ty `op` goTy ty2 + TypeKinded _ ty2 _ ty3 -> k ty `op` (goTy ty2 `op` goTy ty3) TypeApp _ ty2 ty3 -> k ty `op` (goTy ty2 `op` goTy ty3) TypeOp _ ty2 _ ty3 -> k ty `op` (goTy ty2 `op` goTy ty3) TypeOpName _ _ -> k ty @@ -27,6 +27,7 @@ everythingOnTypes op k = goTy | null ty2 -> k ty `op` goTy ty3 | otherwise -> k ty `op` (foldr1 op (k <$> ty2) `op` goTy ty3) TypeParens _ (Wrapped _ ty2 _) -> k ty `op` goTy ty2 + TypeUnaryRow _ _ ty2 -> k ty `op` goTy ty2 goRow ty = \case Row Nothing Nothing -> k ty diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Types.hs b/lib/purescript-cst/src/Language/PureScript/CST/Types.hs index 90a92d876f..9b676ae00f 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Types.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Types.hs @@ -131,13 +131,6 @@ data OneOrDelimited a | Many (DelimitedNonEmpty a) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) -data Kind a - = KindName a (QualifiedName (N.ProperName 'N.KindName)) - | KindArr a (Kind a) SourceToken (Kind a) - | KindRow a SourceToken (Kind a) - | KindParens a (Wrapped (Kind a)) - deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) - data Type a = TypeVar a (Name Ident) | TypeConstructor a (QualifiedName (N.ProperName 'N.TypeName)) @@ -147,7 +140,7 @@ data Type a | TypeRow a (Wrapped (Row a)) | TypeRecord a (Wrapped (Row a)) | TypeForall a SourceToken (NonEmpty (TypeVarBinding a)) SourceToken (Type a) - | TypeKinded a (Type a) SourceToken (Kind a) + | TypeKinded a (Type a) SourceToken (Type a) | TypeApp a (Type a) (Type a) | TypeOp a (Type a) (QualifiedName (N.OpName 'N.TypeOpName)) (Type a) | TypeOpName a (QualifiedName (N.OpName 'N.TypeOpName)) @@ -155,10 +148,11 @@ data Type a | TypeArrName a SourceToken | TypeConstrained a (Constraint a) SourceToken (Type a) | TypeParens a (Wrapped (Type a)) + | TypeUnaryRow a SourceToken (Type a) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) data TypeVarBinding a - = TypeVarKinded (Wrapped (Labeled (Name Ident) (Kind a))) + = TypeVarKinded (Wrapped (Labeled (Name Ident) (Type a))) | TypeVarName (Name Ident) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) @@ -189,7 +183,7 @@ data Export a | ExportType a (Name (N.ProperName 'N.TypeName)) (Maybe (DataMembers a)) | ExportTypeOp a SourceToken (Name (N.OpName 'N.TypeOpName)) | ExportClass a SourceToken (Name (N.ProperName 'N.ClassName)) - | ExportKind a SourceToken (Name (N.ProperName 'N.KindName)) + | ExportKind a SourceToken (Name (N.ProperName 'N.TypeName)) | ExportModule a SourceToken (Name N.ModuleName) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) @@ -205,6 +199,7 @@ data Declaration a | DeclClass a (ClassHead a) (Maybe (SourceToken, NonEmpty (Labeled (Name Ident) (Type a)))) | DeclInstanceChain a (Separated (Instance a)) | DeclDerive a SourceToken (Maybe SourceToken) (InstanceHead a) + | DeclKindSignature a SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Type a)) | DeclSignature a (Labeled (Name Ident) (Type a)) | DeclValue a (ValueBindingFields a) | DeclFixity a FixityFields @@ -236,7 +231,7 @@ data Import a | ImportType a (Name (N.ProperName 'N.TypeName)) (Maybe (DataMembers a)) | ImportTypeOp a SourceToken (Name (N.OpName 'N.TypeOpName)) | ImportClass a SourceToken (Name (N.ProperName 'N.ClassName)) - | ImportKind a SourceToken (Name (N.ProperName 'N.KindName)) + | ImportKind a SourceToken (Name (N.ProperName 'N.TypeName)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) data DataHead a = DataHead @@ -315,8 +310,8 @@ data PatternGuard a = PatternGuard data Foreign a = ForeignValue (Labeled (Name Ident) (Type a)) - | ForeignData SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Kind a)) - | ForeignKind SourceToken (Name (N.ProperName 'N.KindName)) + | ForeignData SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Type a)) + | ForeignKind SourceToken (Name (N.ProperName 'N.TypeName)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) data Role = Role diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index 40c843ea5e..23549a5653 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -18,7 +18,6 @@ import Language.PureScript.Environment as P import Language.PureScript.Errors as P hiding (indent) import Language.PureScript.Externs as P import Language.PureScript.Graph as P -import Language.PureScript.Kinds as P import Language.PureScript.Linter as P import Language.PureScript.Make as P import Language.PureScript.ModuleDependencies as P diff --git a/src/Language/PureScript/CST.hs b/src/Language/PureScript/CST.hs index 1503f18d27..4fe672e9a8 100644 --- a/src/Language/PureScript/CST.hs +++ b/src/Language/PureScript/CST.hs @@ -5,7 +5,9 @@ module Language.PureScript.CST , parseModulesFromFiles , unwrapParserError , toMultipleErrors + , toMultipleWarnings , toPositionedError + , toPositionedWarning , pureResult , module Language.PureScript.CST.Convert , module Language.PureScript.CST.Errors @@ -33,7 +35,7 @@ import Language.PureScript.CST.Print import Language.PureScript.CST.Types pureResult :: a -> PartialResult a -pureResult a = PartialResult a (pure a) +pureResult a = PartialResult a ([], pure a) parseModulesFromFiles :: forall m k @@ -52,18 +54,18 @@ parseFromFiles . MonadError E.MultipleErrors m => (k -> FilePath) -> [(k, Text)] - -> m [(k, AST.Module)] + -> m [(k, ([ParserWarning], AST.Module))] parseFromFiles toFilePath input = flip E.parU (handleParserError toFilePath) . inParallel . flip fmap input - $ \(k, a) -> (k, parseFromFile (toFilePath k) a) + $ \(k, a) -> (k, sequence $ parseFromFile (toFilePath k) a) parseModuleFromFile :: FilePath -> Text -> Either (NE.NonEmpty ParserError) (PartialResult AST.Module) parseModuleFromFile fp content = fmap (convertModule fp) <$> parseModule (lex content) -parseFromFile :: FilePath -> Text -> Either (NE.NonEmpty ParserError) AST.Module -parseFromFile fp content = convertModule fp <$> parse content +parseFromFile :: FilePath -> Text -> ([ParserWarning], Either (NE.NonEmpty ParserError) AST.Module) +parseFromFile fp content = fmap (convertModule fp) <$> parse content handleParserError :: forall m k a @@ -87,9 +89,17 @@ toMultipleErrors :: FilePath -> NE.NonEmpty ParserError -> E.MultipleErrors toMultipleErrors fp = E.MultipleErrors . NE.toList . fmap (toPositionedError fp) +toMultipleWarnings :: FilePath -> [ParserWarning] -> E.MultipleErrors +toMultipleWarnings fp = + E.MultipleErrors . fmap (toPositionedWarning fp) + toPositionedError :: FilePath -> ParserError -> E.ErrorMessage toPositionedError name perr = E.ErrorMessage [E.positionedError $ sourceSpan name $ errRange perr] (E.ErrorParsingCSTModule perr) +toPositionedWarning :: FilePath -> ParserWarning -> E.ErrorMessage +toPositionedWarning name perr = + E.ErrorMessage [E.positionedError $ sourceSpan name $ errRange perr] (E.WarningParsingCSTModule perr) + inParallel :: [(k, Either (NE.NonEmpty ParserError) a)] -> [(k, Either (NE.NonEmpty ParserError) a)] inParallel = withStrategy (parList (evalTuple2 r0 rseq)) diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 07437a5d24..e28870ccbf 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -42,7 +42,7 @@ closedRecordFields (TypeApp _ (TypeConstructor _ C.Record) row) = collect row where collect :: Type a -> Maybe [Label] - collect (REmpty _) = Just [] + collect (REmptyKinded _ _) = Just [] collect (RCons _ l _ r) = collect r >>= return . (l :) collect _ = Nothing closedRecordFields _ = Nothing diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index 563de1ee1e..3fc7074c76 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -17,7 +17,7 @@ module Language.PureScript.Docs.AsHtml ( import Prelude import Control.Category ((>>>)) import Control.Monad (unless) -import Data.Bifunctor (first) +import Data.Bifunctor (bimap) import Data.Char (isUpper) import Data.Either (isRight) import qualified Data.List.NonEmpty as NE @@ -225,7 +225,7 @@ codeAsHtml r = outputWith elemAsHtml runParser :: CST.Parser a -> Text -> Either String a runParser p' = - first (CST.prettyPrintError . NE.head) + bimap (CST.prettyPrintError . NE.head) snd . CST.runTokenParser p' . CST.lex @@ -248,7 +248,6 @@ makeFragment ns = (prefix <>) . escape prefix = case ns of TypeLevel -> "#t:" ValueLevel -> "#v:" - KindLevel -> "#k:" -- TODO escape = id diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index a7af1137c4..3b2d3fdbbb 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -78,7 +78,7 @@ insertValueTypes env m = runParser :: CST.Parser a -> Text -> Either String a runParser p = - first (CST.prettyPrintError . NE.head) + bimap (CST.prettyPrintError . NE.head) snd . CST.runTokenParser p . CST.lex diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 9651bfb96c..d3b23c36e1 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -135,14 +135,13 @@ collectDeclarations reExports = do typeClasses <- collect lookupTypeClassDeclaration expTCs types <- collect lookupTypeDeclaration expTypes typeOps <- collect lookupTypeOpDeclaration expTypeOps - kinds <- collect lookupKindDeclaration expKinds (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses let filteredTypes = filterDataConstructors expCtors types let filteredClasses = filterTypeClassMembers (Map.keys expVals) classes - pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps, kinds])) + pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps])) where @@ -171,9 +170,6 @@ collectDeclarations reExports = do expTypeOps :: Map (P.OpName 'P.TypeOpName) P.ExportSource expTypeOps = mkExportMap P.getTypeOpRef - expKinds :: Map (P.ProperName 'P.KindName) P.ExportSource - expKinds = mkExportMap P.getKindRef - mkExportMap :: Ord name => (P.DeclarationRef -> Maybe name) -> Map name P.ExportSource mkExportMap f = Map.fromList $ @@ -312,24 +308,6 @@ lookupTypeClassDeclaration importedFrom tyClass = do ++ show tyClass ++ ": " ++ (unlines . map show) other) -lookupKindDeclaration - :: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) - => P.ModuleName - -> P.ProperName 'P.KindName - -> m (P.ModuleName, [Declaration]) -lookupKindDeclaration importedFrom kind = do - decls <- lookupModuleDeclarations "lookupKindDeclaration" importedFrom - let - ds = filter (\d -> declTitle d == P.runProperName kind - && isKind d) - decls - case ds of - [d] -> - pure (importedFrom, [d]) - other -> - internalErrorInModule - ("lookupKindDeclaration: unexpected result: " ++ show other) - -- | -- Get the full list of declarations for a particular module out of the -- state, or raise an internal error if it is not there. @@ -530,7 +508,7 @@ typeClassConstraintFor :: Declaration -> Maybe Constraint' typeClassConstraintFor Declaration{..} = case declInfo of TypeClassDeclaration tyArgs _ _ -> - Just (P.Constraint () (P.Qualified Nothing (P.ProperName declTitle)) (mkConstraint tyArgs) Nothing) + Just (P.Constraint () (P.Qualified Nothing (P.ProperName declTitle)) [] (mkConstraint tyArgs) Nothing) _ -> Nothing where diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 60e2ddb051..6300ae9990 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -93,7 +93,6 @@ getDeclarationTitle (P.ValueDeclaration vd) = Just (P.showIdent (P.valdeclIdent getDeclarationTitle (P.ExternDeclaration _ name _) = Just (P.showIdent name) getDeclarationTitle (P.DataDeclaration _ _ name _ _) = Just (P.runProperName name) getDeclarationTitle (P.ExternDataDeclaration _ name _) = Just (P.runProperName name) -getDeclarationTitle (P.ExternKindDeclaration _ name) = Just (P.runProperName name) getDeclarationTitle (P.TypeSynonymDeclaration _ name _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeClassDeclaration _ name _ _ _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ name _ _ _ _) = Just (P.showIdent name) @@ -133,8 +132,6 @@ convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title = ChildDeclaration (P.runProperName dataCtorName) (convertComments $ snd dataCtorAnn) Nothing (ChildDataConstructor (fmap (($> ()) . snd) dataCtorFields)) convertDeclaration (P.ExternDataDeclaration sa _ kind') title = basicDeclaration sa title (ExternDataDeclaration (kind' $> ())) -convertDeclaration (P.ExternKindDeclaration sa _) title = - basicDeclaration sa title ExternKindDeclaration convertDeclaration (P.TypeSynonymDeclaration sa _ args ty) title = basicDeclaration sa title (TypeSynonymDeclaration (fmap (fmap (fmap ($> ()))) args) (ty $> ())) convertDeclaration (P.TypeClassDeclaration sa _ args implies fundeps ds) title = diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index ce528975c8..f06a5dce74 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -11,7 +11,6 @@ import Data.Functor (($>)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Map as Map -import qualified Data.Set as Set import Language.PureScript.Docs.Types import qualified Language.PureScript.Crash as P @@ -36,7 +35,7 @@ primDocsModule = Module , modComments = Just $ T.unlines [ "The `Prim` module is embedded in the PureScript compiler in order to provide compiler support for certain types — for example, value literals, or syntax sugar. It is implicitly imported unqualified in every module except those that list it as a qualified import." , "" - , "`Prim` does not include additional built-in types and kinds that are defined deeper in the compiler. For example, row kinds (e.g. `# Type`, which is the kind of types such as `(name :: String, age :: Int)`), Type wildcards (e.g. `f :: _ -> Int`), and Quantified Types. Rather, these are documented in [the PureScript language reference](https://github.com/purescript/documentation/blob/master/language/Types.md)." + , "`Prim` does not include additional built-in types and kinds that are defined deeper in the compiler such as Type wildcards (e.g. `f :: _ -> Int`) and Quantified Types. Rather, these are documented in [the PureScript language reference](https://github.com/purescript/documentation/blob/master/language/Types.md)." ] , modDeclarations = [ function @@ -49,7 +48,9 @@ primDocsModule = Module , boolean , partial , kindType + , kindConstraint , kindSymbol + , kindRow ] , modReExports = [] } @@ -59,8 +60,7 @@ primBooleanDocsModule = Module { modName = P.moduleNameFromString "Prim.Boolean" , modComments = Just "The Prim.Boolean module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains a type level `Boolean` data structure." , modDeclarations = - [ kindBoolean - , booleanTrue + [ booleanTrue , booleanFalse ] , modReExports = [] @@ -160,29 +160,10 @@ unsafeLookupOf k m errorMsg name = go name fromJust' (Just x) = x fromJust' _ = P.internalError $ errorMsg ++ show name -primKindOf - :: NameGen 'P.KindName - -> Text - -> Text - -> Declaration -primKindOf g title comments = - if Set.member (g title) P.allPrimKinds - then Declaration - { declTitle = title - , declComments = Just comments - , declSourceSpan = Nothing - , declChildren = [] - , declInfo = ExternKindDeclaration - } - else P.internalError $ "Docs.Prim: No such Prim kind: " ++ T.unpack title - -primKind :: Text -> Text -> Declaration -primKind = primKindOf P.primName - lookupPrimTypeKindOf :: NameGen 'P.TypeName -> Text - -> Kind' + -> Type' lookupPrimTypeKindOf k = ($> ()) . fst . unsafeLookupOf k ( P.primTypes <> P.primBooleanTypes <> @@ -236,19 +217,38 @@ primClassOf gen title comments = Declaration } kindType :: Declaration -kindType = primKind "Type" $ T.unlines +kindType = primType "Type" $ T.unlines [ "`Type` is the kind of all proper types: those that classify value-level terms." , "For example the type `Boolean` has kind `Type`; denoted by `Boolean :: Type`." ] +kindConstraint :: Declaration +kindConstraint = primType "Constraint" $ T.unlines + [ "`Constraint` is the kind of type class constraints." + , "For example, a type class declaration like this:" + , "" + , " class Semigroup a where" + , " append :: a -> a -> a" + , "" + , "has the kind signature:" + , "" + , " class Semigroup :: Type -> Constraint" + ] + kindSymbol :: Declaration -kindSymbol = primKind "Symbol" $ T.unlines +kindSymbol = primType "Symbol" $ T.unlines [ "`Symbol` is the kind of type-level strings." , "" , "Construct types of this kind using the same literal syntax as documented" , "for strings." ] +kindRow :: Declaration +kindRow = primType "Row" $ T.unlines + [ "`Row` is the kind constructor of label-indexed types which map type-level strings to other types." + , "For example, the kind of `Record` is `Row Type -> Type`, mapping field names to values." + ] + function :: Declaration function = primType "Function" $ T.unlines [ "A function, which takes values of the type specified by the first type" @@ -363,11 +363,6 @@ partial = primClass "Partial" $ T.unlines , "[purescript-partial](https://pursuit.purescript.org/packages/purescript-partial/)." ] -kindBoolean :: Declaration -kindBoolean = primKindOf (P.primSubName "Boolean") "Boolean" $ T.unlines - [ "The `Boolean` kind provides True/False types at the type level" - ] - booleanTrue :: Declaration booleanTrue = primTypeOf (P.primSubName "Boolean") "True" $ T.unlines [ "The 'True' boolean type." @@ -417,7 +412,7 @@ coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines ] kindOrdering :: Declaration -kindOrdering = primKindOf (P.primSubName "Ordering") "Ordering" $ T.unlines +kindOrdering = primTypeOf (P.primSubName "Ordering") "Ordering" $ T.unlines [ "The `Ordering` kind represents the three possibilities of comparing two" , "types of the same kind: `LT` (less than), `EQ` (equal to), and" , "`GT` (greater than)." @@ -464,7 +459,7 @@ rowCons = primClassOf (P.primSubName "Row") "Cons" $ T.unlines ] kindRowList :: Declaration -kindRowList = primKindOf (P.primSubName "RowList") "RowList" $ T.unlines +kindRowList = primTypeOf (P.primSubName "RowList") "RowList" $ T.unlines [ "A type level list representation of a row of types." ] @@ -524,7 +519,7 @@ warn = primClassOf (P.primSubName "TypeError") "Warn" $ T.unlines ] kindDoc :: Declaration -kindDoc = primKindOf (P.primSubName "TypeError") "Doc" $ T.unlines +kindDoc = primTypeOf (P.primSubName "TypeError") "Doc" $ T.unlines [ "`Doc` is the kind of type-level documents." , "" , "This kind is used with the `Fail` and `Warn` type classes." diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 603aadf335..46c2fc7693 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -40,7 +40,7 @@ renderDeclaration Declaration{..} = [ keywordData , renderType (P.TypeConstructor () (notQualified declTitle)) , syntax "::" - , renderKind kind' + , renderType kind' ] TypeSynonymDeclaration args ty -> [ keywordType @@ -80,11 +80,6 @@ renderDeclaration Declaration{..} = , aliasName for declTitle ] - ExternKindDeclaration -> - [ keywordKind - , kind (notQualified declTitle) - ] - renderChildDeclaration :: ChildDeclaration -> RenderedCode renderChildDeclaration ChildDeclaration{..} = mintersperse sp $ case cdeclInfo of @@ -101,8 +96,8 @@ renderChildDeclaration ChildDeclaration{..} = ] renderConstraint :: Constraint' -> RenderedCode -renderConstraint (P.Constraint ann pn tys _) = - renderType $ foldl (P.TypeApp ann) (P.TypeConstructor ann (fmap P.coerceProperName pn)) tys +renderConstraint (P.Constraint ann pn kinds tys _) = + renderType $ foldl (P.TypeApp ann) (foldl (P.KindApp ann) (P.TypeConstructor ann (fmap P.coerceProperName pn)) kinds) tys renderConstraints :: [Constraint'] -> Maybe RenderedCode renderConstraints constraints @@ -125,12 +120,12 @@ ident' = ident . P.Qualified Nothing . P.Ident dataCtor' :: Text -> RenderedCode dataCtor' = dataCtor . notQualified -typeApp :: Text -> [(Text, Maybe Kind')] -> Type' +typeApp :: Text -> [(Text, Maybe Type')] -> Type' typeApp title typeArgs = foldl (P.TypeApp ()) (P.TypeConstructor () (notQualified title)) (map toTypeVar typeArgs) -toTypeVar :: (Text, Maybe Kind') -> Type' +toTypeVar :: (Text, Maybe Type') -> Type' toTypeVar (s, Nothing) = P.TypeVar () s toTypeVar (s, Just k) = P.KindedType () (P.TypeVar () s) k diff --git a/src/Language/PureScript/Docs/RenderedCode.hs b/src/Language/PureScript/Docs/RenderedCode.hs index 216eba39ba..2d8d0253e8 100644 --- a/src/Language/PureScript/Docs/RenderedCode.hs +++ b/src/Language/PureScript/Docs/RenderedCode.hs @@ -6,4 +6,3 @@ module Language.PureScript.Docs.RenderedCode (module RenderedCode) where import Language.PureScript.Docs.RenderedCode.Types as RenderedCode import Language.PureScript.Docs.RenderedCode.RenderType as RenderedCode -import Language.PureScript.Docs.RenderedCode.RenderKind as RenderedCode diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs b/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs deleted file mode 100644 index f4c3862aa7..0000000000 --- a/src/Language/PureScript/Docs/RenderedCode/RenderKind.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- | Functions for producing RenderedCode values from PureScript Kind values. --- -module Language.PureScript.Docs.RenderedCode.RenderKind - ( renderKind - ) where - --- TODO: This is pretty much copied from Language.PureScript.Pretty.Kinds. --- Ideally we would unify the two. - -import Prelude.Compat - -import Control.Arrow (ArrowPlus(..)) -import Control.PatternArrows as PA - -import Data.Maybe (fromMaybe) -import qualified Data.Text as T - -import Language.PureScript.Crash -import Language.PureScript.Kinds - -import Language.PureScript.Docs.RenderedCode.Types - -typeLiterals :: Pattern () (Kind a) RenderedCode -typeLiterals = mkPattern match - where - match (KUnknown _ u) = - Just $ typeVar $ T.cons 'k' (T.pack (show u)) - match (NamedKind _ n) = - Just $ kind n - match _ = Nothing - -matchRow :: Pattern () (Kind a) ((), Kind a) -matchRow = mkPattern match - where - match (Row _ k) = Just ((), k) - match _ = Nothing - -funKind :: Pattern () (Kind a) (Kind a, Kind a) -funKind = mkPattern match - where - match (FunKind _ arg ret) = Just (arg, ret) - match _ = Nothing - --- | Generate RenderedCode value representing a Kind -renderKind :: forall a. Kind a -> RenderedCode -renderKind - = fromMaybe (internalError "Incomplete pattern") - . PA.pattern matchKind () - where - matchKind :: Pattern () (Kind a) RenderedCode - matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind) - - operators :: OperatorTable () (Kind a) RenderedCode - operators = - OperatorTable [ [ Wrap matchRow $ \_ k -> syntax "#" <> sp <> k] - , [ AssocR funKind $ \arg ret -> arg <> sp <> syntax "->" <> sp <> ret ] ] diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index 242f8a4685..4eed8478e3 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -17,7 +17,6 @@ import Control.Arrow ((<+>)) import Control.PatternArrows as PA import Language.PureScript.Crash -import Language.PureScript.Kinds import Language.PureScript.Label import Language.PureScript.Names import Language.PureScript.Pretty.Types @@ -26,7 +25,6 @@ import Language.PureScript.PSString (prettyPrintString) import Language.PureScript.Docs.RenderedCode.Types import Language.PureScript.Docs.Utils.MonoidExtras -import Language.PureScript.Docs.RenderedCode.RenderKind (renderKind) typeLiterals :: Pattern () PrettyPrintType RenderedCode typeLiterals = mkPattern match @@ -55,8 +53,8 @@ typeLiterals = mkPattern match Nothing renderConstraint :: PrettyPrintConstraint -> RenderedCode -renderConstraint (pn, tys) = - let instApp = foldl PPTypeApp (PPTypeConstructor (fmap coerceProperName pn)) tys +renderConstraint (pn, ks, tys) = + let instApp = foldl PPTypeApp (foldl (\a b -> PPTypeApp a (PPKindArg b)) (PPTypeConstructor (fmap coerceProperName pn)) ks) tys in renderType' instApp renderConstraints :: PrettyPrintConstraint -> RenderedCode -> RenderedCode @@ -94,16 +92,22 @@ typeApp = mkPattern match match (PPTypeApp f x) = Just (f, x) match _ = Nothing +kindArg :: Pattern () PrettyPrintType ((), PrettyPrintType) +kindArg = mkPattern match + where + match (PPKindArg ty) = Just ((), ty) + match _ = Nothing + appliedFunction :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType) appliedFunction = mkPattern match where match (PPFunction arg ret) = Just (arg, ret) match _ = Nothing -kinded :: Pattern () PrettyPrintType (Kind (), PrettyPrintType) +kinded :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType) kinded = mkPattern match where - match (PPKindedType t k) = Just (k, t) + match (PPKindedType t k) = Just (t, k) match _ = Nothing constrained :: Pattern () PrettyPrintType (PrettyPrintConstraint, PrettyPrintType) @@ -128,15 +132,16 @@ matchType = buildPrettyPrinter operators matchTypeAtom where operators :: OperatorTable () PrettyPrintType RenderedCode operators = - OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ] + OperatorTable [ [ Wrap kindArg $ \_ ty -> syntax "@" <> ty ] + , [ AssocL typeApp $ \f x -> f <> sp <> x ] , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ] , [ Wrap constrained $ \deps ty -> renderConstraints deps ty ] , [ Wrap forall_ $ \tyVars ty -> mconcat [ keywordForall, sp, renderTypeVars tyVars, syntax ".", sp, ty ] ] - , [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ] + , [ Wrap kinded $ \ty k -> mintersperse sp [renderType' ty, syntax "::", k] ] , [ Wrap explicitParens $ \_ ty -> ty ] ] -forall_ :: Pattern () PrettyPrintType ([(Text, Maybe (Kind ()))], PrettyPrintType) +forall_ :: Pattern () PrettyPrintType ([(Text, Maybe PrettyPrintType)], PrettyPrintType) forall_ = mkPattern match where match (PPForAll mbKindedIdents ty) = Just (mbKindedIdents, ty) @@ -153,13 +158,13 @@ renderType' = fromMaybe (internalError "Incomplete pattern") . PA.pattern matchType () -renderTypeVars :: [(Text, Maybe (Kind a))] -> RenderedCode +renderTypeVars :: [(Text, Maybe PrettyPrintType)] -> RenderedCode renderTypeVars tyVars = mintersperse sp (map renderTypeVar tyVars) -renderTypeVar :: (Text, Maybe (Kind a)) -> RenderedCode +renderTypeVar :: (Text, Maybe PrettyPrintType) -> RenderedCode renderTypeVar (v, mbK) = case mbK of Nothing -> typeVar v - Just k -> mintersperse sp [ mconcat [syntax "(", typeVar v], syntax "::", mconcat [renderKind k, syntax ")"] ] + Just k -> mintersperse sp [ mconcat [syntax "(", typeVar v], syntax "::", mconcat [renderType' k, syntax ")"] ] -- | -- Render code representing a Type, as it should appear inside parentheses diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index ecf1b0a9fb..8eefbe1ad9 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -38,7 +38,6 @@ module Language.PureScript.Docs.RenderedCode.Types , typeCtor , typeOp , typeVar - , kind , alias , aliasName ) where @@ -58,7 +57,6 @@ import qualified Data.Text.Encoding as TE import Language.PureScript.Names import Language.PureScript.AST (Associativity(..)) -import Language.PureScript.Crash (internalError) -- | Given a list of actions, attempt them all, returning the first success. -- If all the actions fail, 'tryAll' returns the first argument. @@ -170,7 +168,6 @@ instance A.FromJSON Link where data Namespace = ValueLevel | TypeLevel - | KindLevel deriving (Show, Eq, Ord, Generic) instance NFData Namespace @@ -184,7 +181,6 @@ asNamespace = [ withText $ \case "ValueLevel" -> Right ValueLevel "TypeLevel" -> Right TypeLevel - "KindLevel" -> Right KindLevel _ -> Left "" ] @@ -234,12 +230,10 @@ asRenderedCodeElement = backwardsCompat = [ oldAsIdent , oldAsCtor - , oldAsKind ] oldAsIdent = firstEq "ident" (Symbol ValueLevel <$> nth 1 asText <*> nth 2 (Link <$> asContainingModule)) oldAsCtor = firstEq "ctor" (Symbol TypeLevel <$> nth 1 asText <*> nth 2 (Link <$> asContainingModule)) - oldAsKind = firstEq "kind" (Symbol KindLevel <$> nth 1 asText <*> pure (Link ThisModule)) -- | -- A type representing a highly simplified version of PureScript code, intended @@ -335,10 +329,6 @@ typeOp (fromQualified -> (mn, name)) = typeVar :: Text -> RenderedCode typeVar x = RC [Symbol TypeLevel x NoLink] -kind :: Qualified (ProperName 'KindName) -> RenderedCode -kind (fromQualified -> (mn, name)) = - RC [Symbol KindLevel (runProperName name) (Link mn)] - type FixityAlias = Qualified (Either (ProperName 'TypeName) (Either Ident (ProperName 'ConstructorName))) alias :: FixityAlias -> RenderedCode @@ -364,8 +354,6 @@ aliasName for name' = ident (Qualified Nothing (Ident name)) TypeLevel -> typeCtor (Qualified Nothing (ProperName name)) - KindLevel -> - internalError "Kind aliases are not supported" -- | Converts a FixityAlias into a different representation which is more -- useful to other functions in this module. diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 89c3e39252..6792d9048f 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -30,7 +30,6 @@ import qualified Data.Vector as V import qualified Language.PureScript.AST as P import qualified Language.PureScript.Crash as P import qualified Language.PureScript.Environment as P -import qualified Language.PureScript.Kinds as P import qualified Language.PureScript.Names as P import qualified Language.PureScript.Types as P import qualified Paths_purescript as Paths @@ -46,7 +45,6 @@ import Language.PureScript.Docs.RenderedCode as ReExports Namespace(..), FixityAlias) type Type' = P.Type () -type Kind' = P.Kind () type Constraint' = P.Constraint () -------------------- @@ -164,39 +162,34 @@ data DeclarationInfo -- newtype) and its type arguments. Constructors are represented as child -- declarations. -- - | DataDeclaration P.DataDeclType [(Text, Maybe Kind')] + | DataDeclaration P.DataDeclType [(Text, Maybe Type')] -- | -- A data type foreign import, with its kind. -- - | ExternDataDeclaration Kind' + | ExternDataDeclaration Type' -- | -- A type synonym, with its type arguments and its type. -- - | TypeSynonymDeclaration [(Text, Maybe Kind')] Type' + | TypeSynonymDeclaration [(Text, Maybe Type')] Type' -- | -- A type class, with its type arguments, its superclasses and functional -- dependencies. Instances and members are represented as child declarations. -- - | TypeClassDeclaration [(Text, Maybe Kind')] [Constraint'] [([Text], [Text])] + | TypeClassDeclaration [(Text, Maybe Type')] [Constraint'] [([Text], [Text])] -- | -- An operator alias declaration, with the member the alias is for and the -- operator's fixity. -- | AliasDeclaration P.Fixity FixityAlias - - -- | - -- A kind declaration - -- - | ExternKindDeclaration deriving (Show, Eq, Ord, Generic) instance NFData DeclarationInfo -convertFundepsToStrings :: [(Text, Maybe Kind')] -> [P.FunctionalDependency] -> [([Text], [Text])] +convertFundepsToStrings :: [(Text, Maybe Type')] -> [P.FunctionalDependency] -> [([Text], [Text])] convertFundepsToStrings args fundeps = map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps where @@ -221,7 +214,6 @@ declInfoToString (ExternDataDeclaration _) = "externData" declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym" declInfoToString (TypeClassDeclaration _ _ _) = "typeClass" declInfoToString (AliasDeclaration _ _) = "alias" -declInfoToString ExternKindDeclaration = "kind" declInfoNamespace :: DeclarationInfo -> Namespace declInfoNamespace = \case @@ -237,8 +229,6 @@ declInfoNamespace = \case TypeLevel AliasDeclaration _ alias -> either (const TypeLevel) (const ValueLevel) (P.disqualify alias) - ExternKindDeclaration{} -> - KindLevel isTypeClass :: Declaration -> Bool isTypeClass Declaration{..} = @@ -272,12 +262,6 @@ isTypeAlias Declaration{..} = AliasDeclaration _ (P.Qualified _ d) -> isLeft d _ -> False -isKind :: Declaration -> Bool -isKind Declaration{..} = - case declInfo of - ExternKindDeclaration{} -> True - _ -> False - -- | Discard any children which do not satisfy the given predicate. filterChildren :: (ChildDeclaration -> Bool) -> Declaration -> Declaration filterChildren p decl = @@ -641,7 +625,7 @@ asDeclarationInfo = do DataDeclaration <$> key "dataDeclType" asDataDeclType <*> key "typeArguments" asTypeArguments "externData" -> - ExternDataDeclaration <$> key "kind" asKind + ExternDataDeclaration <$> key "kind" asType "typeSynonym" -> TypeSynonymDeclaration <$> key "arguments" asTypeArguments <*> key "type" asType @@ -652,18 +636,16 @@ asDeclarationInfo = do "alias" -> AliasDeclaration <$> key "fixity" asFixity <*> key "alias" asFixityAlias + -- Backwards compat: kinds are extern data "kind" -> - pure ExternKindDeclaration + pure $ ExternDataDeclaration (P.kindType $> ()) other -> throwCustomError (InvalidDeclarationType other) -asTypeArguments :: Parse PackageError [(Text, Maybe Kind')] +asTypeArguments :: Parse PackageError [(Text, Maybe Type')] asTypeArguments = eachInArray asTypeArgument where - asTypeArgument = (,) <$> nth 0 asText <*> nth 1 (perhaps asKind) - -asKind :: Parse PackageError Kind' -asKind = fromAesonParser .! InvalidKind + asTypeArgument = (,) <$> nth 0 asText <*> nth 1 (perhaps asType) asType :: Parse e Type' asType = fromAesonParser @@ -707,6 +689,7 @@ asSourcePos = P.SourcePos <$> nth 0 asIntegral asConstraint :: Parse PackageError Constraint' asConstraint = P.Constraint () <$> key "constraintClass" asQualifiedProperName + <*> keyOrDefault "constraintKindArgs" [] (eachInArray asType) <*> key "constraintArgs" (eachInArray asType) <*> pure Nothing @@ -825,7 +808,6 @@ instance A.ToJSON DeclarationInfo where TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty] TypeClassDeclaration args super fundeps -> ["arguments" .= args, "superclasses" .= super, "fundeps" .= fundeps] AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias] - ExternKindDeclaration -> [] instance A.ToJSON ChildDeclarationInfo where toJSON info = A.object $ "declType" .= childDeclInfoToString info : props diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index ff87023deb..5e6260d83b 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -27,14 +27,15 @@ import Data.Ord (comparing) import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text) +import qualified GHC.Stack import Language.PureScript.AST import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.Constants.Prelude as C import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.Crash import qualified Language.PureScript.CST.Errors as CST +import qualified Language.PureScript.CST.Print as CST import Language.PureScript.Environment -import qualified Language.PureScript.Kinds as Kinds import Language.PureScript.Label (Label(..)) import Language.PureScript.Names import Language.PureScript.Pretty @@ -51,10 +52,12 @@ import qualified Text.PrettyPrint.Boxes as Box -- | A type of error messages data SimpleErrorMessage - = ModuleNotFound ModuleName + = InternalCompilerError Text Text + | ModuleNotFound ModuleName | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) | ErrorParsingModule P.ParseError | ErrorParsingCSTModule CST.ParserError + | WarningParsingCSTModule CST.ParserWarning | MissingFFIModule ModuleName | UnnecessaryFFIModule ModuleName FilePath | MissingFFIImplementations ModuleName [Ident] @@ -62,10 +65,11 @@ data SimpleErrorMessage | InvalidFFIIdentifier ModuleName Text | FileIOError Text IOError -- ^ A description of what we were trying to do, and the error which occurred | InfiniteType SourceType - | InfiniteKind Kinds.SourceKind + | InfiniteKind SourceType | MultipleValueOpFixities (OpName 'ValueOpName) | MultipleTypeOpFixities (OpName 'TypeOpName) | OrphanTypeDeclaration Ident + | OrphanKindDeclaration (ProperName 'TypeName) | RedefinedIdent Ident | OverlappingNamesInLet | UnknownName (Qualified Name) @@ -86,13 +90,14 @@ data SimpleErrorMessage | CycleInDeclaration Ident | CycleInTypeSynonym (Maybe (ProperName 'TypeName)) | CycleInTypeClassDeclaration [Qualified (ProperName 'ClassName)] + | CycleInKindDeclaration [Qualified (ProperName 'TypeName)] | CycleInModules [ModuleName] | NameIsUndefined Ident | UndefinedTypeVariable (ProperName 'TypeName) | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName)) | EscapedSkolem Text (Maybe SourceSpan) SourceType | TypesDoNotUnify SourceType SourceType - | KindsDoNotUnify Kinds.SourceKind Kinds.SourceKind + | KindsDoNotUnify SourceType SourceType | ConstrainedTypeUnified SourceType SourceType | OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified Ident] | NoInstanceFound SourceConstraint @@ -112,7 +117,7 @@ data SimpleErrorMessage | OverlappingArgNames (Maybe Ident) | MissingClassMember (NEL.NonEmpty (Ident, SourceType)) | ExtraneousClassMember Ident (Qualified (ProperName 'ClassName)) - | ExpectedType SourceType Kinds.SourceKind + | ExpectedType SourceType SourceType -- | constructor name, expected argument count, actual argument count | IncorrectConstructorArity (Qualified (ProperName 'ConstructorName)) Int Int | ExprDoesNotHaveType Expr SourceType @@ -130,6 +135,7 @@ data SimpleErrorMessage | WildcardInferredType SourceType Context | HoleInferredType Text SourceType Context (Maybe TypeSearch) | MissingTypeDeclaration Ident SourceType + | MissingKindDeclaration KindSignatureFor (ProperName 'TypeName) SourceType | OverlappingPattern [[Binder]] Bool | IncompleteExhaustivityCheck | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName) @@ -163,6 +169,10 @@ data SimpleErrorMessage | CannotDefinePrimModules ModuleName | MixedAssociativityError (NEL.NonEmpty (Qualified (OpName 'AnyOpName), Associativity)) | NonAssociativeError (NEL.NonEmpty (Qualified (OpName 'AnyOpName))) + | QuantificationCheckFailureInKind Text + | QuantificationCheckFailureInType [Int] SourceType + | VisibleQuantificationCheckFailureInType Text + | UnsupportedTypeInKind SourceType deriving (Show) data ErrorMessage = ErrorMessage @@ -200,10 +210,12 @@ stripModuleAndSpan (ErrorMessage hints e) = ErrorMessage (filter (not . shouldSt -- | Get the error code for a particular error type errorCode :: ErrorMessage -> Text errorCode em = case unwrapErrorMessage em of + InternalCompilerError{} -> "InternalCompilerError" ModuleNotFound{} -> "ModuleNotFound" ErrorParsingFFIModule{} -> "ErrorParsingFFIModule" ErrorParsingModule{} -> "ErrorParsingModule" ErrorParsingCSTModule{} -> "ErrorParsingModule" + WarningParsingCSTModule{} -> "WarningParsingModule" MissingFFIModule{} -> "MissingFFIModule" UnnecessaryFFIModule{} -> "UnnecessaryFFIModule" MissingFFIImplementations{} -> "MissingFFIImplementations" @@ -215,6 +227,7 @@ errorCode em = case unwrapErrorMessage em of MultipleValueOpFixities{} -> "MultipleValueOpFixities" MultipleTypeOpFixities{} -> "MultipleTypeOpFixities" OrphanTypeDeclaration{} -> "OrphanTypeDeclaration" + OrphanKindDeclaration{} -> "OrphanKindDeclaration" RedefinedIdent{} -> "RedefinedIdent" OverlappingNamesInLet -> "OverlappingNamesInLet" UnknownName{} -> "UnknownName" @@ -235,6 +248,7 @@ errorCode em = case unwrapErrorMessage em of CycleInDeclaration{} -> "CycleInDeclaration" CycleInTypeSynonym{} -> "CycleInTypeSynonym" CycleInTypeClassDeclaration{} -> "CycleInTypeClassDeclaration" + CycleInKindDeclaration{} -> "CycleInKindDeclaration" CycleInModules{} -> "CycleInModules" NameIsUndefined{} -> "NameIsUndefined" UndefinedTypeVariable{} -> "UndefinedTypeVariable" @@ -278,6 +292,7 @@ errorCode em = case unwrapErrorMessage em of WildcardInferredType{} -> "WildcardInferredType" HoleInferredType{} -> "HoleInferredType" MissingTypeDeclaration{} -> "MissingTypeDeclaration" + MissingKindDeclaration{} -> "MissingKindDeclaration" OverlappingPattern{} -> "OverlappingPattern" IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck" MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport" @@ -308,6 +323,10 @@ errorCode em = case unwrapErrorMessage em of CannotDefinePrimModules{} -> "CannotDefinePrimModules" MixedAssociativityError{} -> "MixedAssociativityError" NonAssociativeError{} -> "NonAssociativeError" + QuantificationCheckFailureInKind {} -> "QuantificationCheckFailureInKind" + QuantificationCheckFailureInType {} -> "QuantificationCheckFailureInType" + VisibleQuantificationCheckFailureInType {} -> "VisibleQuantificationCheckFailureInType" + UnsupportedTypeInKind {} -> "UnsupportedTypeInKind" -- | A stack trace for an error newtype MultipleErrors = MultipleErrors @@ -387,14 +406,14 @@ replaceUnknowns = everywhereOnTypesM replaceTypes where put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextIndex = u' + 1 } return (TUnknown ann u') Just u' -> return (TUnknown ann u') - replaceTypes (Skolem ann name s sko) = do + replaceTypes (Skolem ann name mbK s sko) = do m <- get case M.lookup s (umSkolemMap m) of Nothing -> do let s' = umNextIndex m put $ m { umSkolemMap = M.insert s (T.unpack name, s', Just (fst ann)) (umSkolemMap m), umNextIndex = s' + 1 } - return (Skolem ann name s' sko) - Just (_, s', _) -> return (Skolem ann name s' sko) + return (Skolem ann name mbK s' sko) + Just (_, s', _) -> return (Skolem ann name mbK s' sko) replaceTypes other = return other onTypesInErrorMessage :: (SourceType -> SourceType) -> ErrorMessage -> ErrorMessage @@ -423,13 +442,15 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx gSimple (HoleInferredType name ty ctx env) = HoleInferredType name <$> f ty <*> traverse (sndM f) ctx <*> traverse (onTypeSearchTypesM f) env gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty + gSimple (MissingKindDeclaration sig nm ty) = MissingKindDeclaration sig nm <$> f ty gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty gSimple other = pure other gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2 gHint (ErrorUnifyingTypes t1 t2) = ErrorUnifyingTypes <$> f t1 <*> f t2 gHint (ErrorCheckingType e t) = ErrorCheckingType e <$> f t - gHint (ErrorCheckingKind t) = ErrorCheckingKind <$> f t + gHint (ErrorCheckingKind t k) = ErrorCheckingKind <$> f t <*> f k + gHint (ErrorInferringKind t) = ErrorInferringKind <$> f t gHint (ErrorInApplication e1 t1 e2) = ErrorInApplication e1 <$> f t1 <*> pure e2 gHint (ErrorInInstance cl ts) = ErrorInInstance cl <$> traverse f ts gHint (ErrorSolvingConstraint con) = ErrorSolvingConstraint <$> overConstraintArgs (traverse f) con @@ -453,8 +474,20 @@ errorSuggestion err = ImplicitQualifiedImport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) ImplicitQualifiedImportReExport mn asModule refs -> suggest $ importSuggestion mn refs (Just asModule) HidingImport mn refs -> suggest $ importSuggestion mn refs Nothing - MissingTypeDeclaration ident ty -> suggest $ showIdent ident <> " :: " <> T.pack (prettyPrintSuggestedType ty) - WildcardInferredType ty _ -> suggest $ T.pack (prettyPrintSuggestedType ty) + MissingTypeDeclaration ident ty -> suggest $ showIdent ident <> " :: " <> T.pack (prettyPrintSuggestedTypeSimplified ty) <> "\n" + MissingKindDeclaration sig name ty -> suggest $ prettyPrintKindSignatureFor sig <> " " <> runProperName name <> " :: " <> T.pack (prettyPrintSuggestedTypeSimplified ty) <> "\n" + WildcardInferredType ty _ -> suggest $ T.pack (prettyPrintSuggestedTypeSimplified ty) + WarningParsingCSTModule pe -> do + let toks = CST.errToks pe + case CST.errType pe of + CST.WarnDeprecatedRowSyntax -> do + let kind = CST.printTokens $ drop 1 toks + sugg | T.isPrefixOf " " kind = "Row" <> kind + | otherwise = "Row " <> kind + suggest sugg + CST.WarnDeprecatedForeignKindSyntax -> suggest $ "data " <> CST.printTokens (drop 3 toks) + CST.WarnDeprecatedKindImportSyntax -> suggest $ CST.printTokens $ drop 1 toks + CST.WarnDeprecatedKindExportSyntax -> suggest $ CST.printTokens $ drop 1 toks _ -> Nothing where emptySuggestion = Just $ ErrorSuggestion "" @@ -480,6 +513,7 @@ suggestionSpan e = getSpan simple ss = case simple of MissingTypeDeclaration{} -> startOnly ss + MissingKindDeclaration{} -> startOnly ss _ -> ss showSuggestion :: SimpleErrorMessage -> Text @@ -578,6 +612,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl unknownInfo u = line $ markCode ("t" <> T.pack (show u)) <> " is an unknown type" renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box + renderSimpleErrorMessage (InternalCompilerError ctx err) = + paras [ line "Internal compiler error:" + , indent $ line err + , line ctx + , line "Please report this at https://github.com/purescript/purescript/issues" + ] renderSimpleErrorMessage (ModuleNotFound mn) = paras [ line $ "Module " <> markCode (runModuleName mn) <> " was not found." , line $ @@ -604,6 +644,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "Unable to parse module: " , line $ T.pack $ CST.prettyPrintErrorMessage err ] + renderSimpleErrorMessage (WarningParsingCSTModule err) = + paras [ line $ T.pack $ CST.prettyPrintWarningMessage err + ] renderSimpleErrorMessage (MissingFFIModule mn) = line $ "The foreign module implementation for module " <> markCode (runModuleName mn) <> " is missing." renderSimpleErrorMessage (UnnecessaryFFIModule mn path) = @@ -634,11 +677,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line "The same name was used more than once in a let binding." renderSimpleErrorMessage (InfiniteType ty) = paras [ line "An infinite type was inferred for an expression: " - , markCodeBox $ indent $ typeAsBox prettyDepth ty + , markCodeBox $ indent $ prettyType ty ] renderSimpleErrorMessage (InfiniteKind ki) = paras [ line "An infinite kind was inferred for a type: " - , indent $ line $ markCode $ prettyPrintKind ki + , markCodeBox $ indent $ prettyType ki ] renderSimpleErrorMessage (MultipleValueOpFixities op) = line $ "There are multiple fixity/precedence declarations for operator " <> markCode (showOp op) @@ -646,6 +689,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "There are multiple fixity/precedence declarations for type operator " <> markCode (showOp op) renderSimpleErrorMessage (OrphanTypeDeclaration nm) = line $ "The type declaration for " <> markCode (showIdent nm) <> " should be followed by its definition." + renderSimpleErrorMessage (OrphanKindDeclaration nm) = + line $ "The kind declaration for " <> markCode (runProperName nm) <> " should be followed by its definition." renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident i)))) | i `elem` [ C.bind, C.discard ] = @@ -711,6 +756,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName . disqualify) names)) <> "}" , line "Cycles are disallowed because they can lead to loops in the type checker." ] + renderSimpleErrorMessage (CycleInKindDeclaration [name]) = + paras [ line $ "A kind declaration '" <> markCode (runProperName (disqualify name)) <> "' may not refer to itself in its own signature." ] + renderSimpleErrorMessage (CycleInKindDeclaration names) = + paras [ line $ "A cycle appears in a set of kind declarations:" + , indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName . disqualify) names)) <> "}" + , line "Kind declarations may not refer to themselves in their own signatures." + ] renderSimpleErrorMessage (NameIsUndefined ident) = line $ "Value " <> markCode (showIdent ident) <> " is undefined." renderSimpleErrorMessage (UndefinedTypeVariable name) = @@ -721,13 +773,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderSimpleErrorMessage (EscapedSkolem name Nothing ty) = paras [ line $ "The type variable " <> markCode name <> " has escaped its scope, appearing in the type" - , markCodeBox $ indent $ typeAsBox prettyDepth ty + , markCodeBox $ indent $ prettyType ty ] renderSimpleErrorMessage (EscapedSkolem name (Just srcSpan) ty) = paras [ line $ "The type variable " <> markCode name <> ", bound at" , indent $ line $ displaySourceSpan relPath srcSpan , line "has escaped its scope, appearing in the type" - , markCodeBox $ indent $ typeAsBox prettyDepth ty + , markCodeBox $ indent $ prettyType ty ] renderSimpleErrorMessage (TypesDoNotUnify u1 u2) = let (row1Box, row2Box) = printRows u1 u2 @@ -740,15 +792,15 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = paras [ line "Could not match kind" - , indent $ line $ markCode $ prettyPrintKind k1 + , markCodeBox $ indent $ prettyType k1 , line "with kind" - , indent $ line $ markCode $ prettyPrintKind k2 + , markCodeBox $ indent $ prettyType k2 ] renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) = paras [ line "Could not match constrained type" - , markCodeBox $ indent $ typeAsBox prettyDepth t1 + , markCodeBox $ indent $ prettyType t1 , line "with type" - , markCodeBox $ indent $ typeAsBox prettyDepth t2 + , markCodeBox $ indent $ prettyType t2 ] renderSimpleErrorMessage (OverlappingInstances _ _ []) = internalError "OverlappingInstances: empty instance list" renderSimpleErrorMessage (OverlappingInstances nm ts ds) = @@ -765,11 +817,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , markCodeBox $ indent $ line (showQualified runProperName nm) , line "because the class was not in scope. Perhaps it was not exported." ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Fail [ ty ] _)) | Just box <- toTypelevelString ty = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Fail _ [ ty ] _)) | Just box <- toTypelevelString ty = paras [ line "A custom type error occurred while solving type class constraints:" , indent box ] renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Partial + _ _ (Just (PartialConstraintData bs b)))) = paras [ line "A case expression could not be determined to cover all inputs." @@ -780,13 +833,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl : [line "..." | not b] , line "Alternatively, add a Partial constraint to the type of the enclosing value." ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Discard [ty] _)) = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Discard _ [ty] _)) = paras [ line "A result of type" - , markCodeBox $ indent $ typeAsBox prettyDepth ty + , markCodeBox $ indent $ prettyType ty , line "was implicitly discarded in a do notation block." , line ("You can use " <> markCode "_ <- ..." <> " to explicitly discard the result.") ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ nm ts _)) = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ nm _ ts _)) = paras [ line "No type class instance was found for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) @@ -804,7 +857,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl go _ = False renderSimpleErrorMessage (AmbiguousTypeVariables t us) = paras [ line "The inferred type" - , markCodeBox $ indent $ typeAsBox prettyDepth t + , markCodeBox $ indent $ prettyType t , line "has type variables which are not determined by those mentioned in the body of the type:" , indent $ Box.hsep 1 Box.left [ Box.vcat Box.left @@ -876,7 +929,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] , "because the type" - , markCodeBox $ indent $ typeAsBox prettyDepth ty + , markCodeBox $ indent $ prettyType ty , line "is not of the required form T a_1 ... a_n, where T is a type constructor defined in the same module." ] renderSimpleErrorMessage (CannotFindDerivingType nm) = @@ -897,17 +950,17 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (MissingClassMember identsAndTypes) = paras $ [ line "The following type class members have not been implemented:" , Box.vcat Box.left - [ markCodeBox $ Box.text (T.unpack (showIdent ident)) Box.<> " :: " Box.<> typeAsBox prettyDepth ty + [ markCodeBox $ Box.text (T.unpack (showIdent ident)) Box.<> " :: " Box.<> prettyType ty | (ident, ty) <- NEL.toList identsAndTypes ] ] renderSimpleErrorMessage (ExtraneousClassMember ident className) = line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className) renderSimpleErrorMessage (ExpectedType ty kind) = - paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode (prettyPrintKind kindType) <> "." + paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode C.typ <> "." , line "The error arises from the type" - , markCodeBox $ indent $ typeAsBox prettyDepth ty + , markCodeBox $ indent $ prettyType ty , line "having the kind" - , indent $ line $ markCode $ prettyPrintKind kind + , markCodeBox $ indent $ prettyType kind , line "instead." ] renderSimpleErrorMessage (IncorrectConstructorArity nm expected actual) = @@ -918,7 +971,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "Expression" , markCodeBox $ indent $ prettyPrintValue prettyDepth expr , line "does not have type" - , markCodeBox $ indent $ typeAsBox prettyDepth ty + , markCodeBox $ indent $ prettyType ty ] renderSimpleErrorMessage (PropertyIsMissing prop) = line $ "Type of expression lacks required label " <> markCode (prettyPrintLabel prop) <> "." @@ -950,7 +1003,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderSimpleErrorMessage (InvalidInstanceHead ty) = paras [ line "Type class instance head is invalid due to use of type" - , markCodeBox $ indent $ typeAsBox prettyDepth ty + , markCodeBox $ indent $ prettyType ty , line "All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form, unless the type is fully determined by other type class arguments via functional dependencies." ] renderSimpleErrorMessage (TransitiveExportError x ys) = @@ -975,7 +1028,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderSimpleErrorMessage (WildcardInferredType ty ctx) = paras $ [ line "Wildcard type definition has the inferred type " - , markCodeBox $ indent $ typeAsBox prettyDepth ty + , markCodeBox $ indent $ prettyType ty ] <> renderContext ctx renderSimpleErrorMessage (HoleInferredType name ty ctx ts) = let @@ -987,7 +1040,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl let idBoxes = Box.text . T.unpack . showQualified id <$> names tyBoxes = (\t -> BoxHelpers.indented - (Box.text ":: " Box.<> typeAsBox prettyDepth t)) <$> types + (Box.text ":: " Box.<> prettyType t)) <$> types longestId = maximum (map Box.cols idBoxes) in Box.vcat Box.top $ @@ -1000,13 +1053,22 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl _ -> [] in paras $ [ line $ "Hole '" <> markCode name <> "' has the inferred type " - , markCodeBox (indent (typeAsBox maxBound ty)) + , markCodeBox (indent (prettyTypeWithDepth maxBound ty)) ] ++ tsResult ++ renderContext ctx renderSimpleErrorMessage (MissingTypeDeclaration ident ty) = paras [ line $ "No type declaration was provided for the top-level declaration of " <> markCode (showIdent ident) <> "." , line "It is good practice to provide type declarations as a form of documentation." , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:" - , markCodeBox $ indent $ typeAsBox prettyDepth ty + , markCodeBox $ indent $ prettyTypeWithDepth maxBound ty + ] + renderSimpleErrorMessage (MissingKindDeclaration sig name ty) = + let sigKw = prettyPrintKindSignatureFor sig in + paras [ line $ "The inferred kind for the " <> sigKw <> " declaration " <> markCode (runProperName name) <> " contains polymorphic kinds." + , line $ "Consider adding a top-level kind signature as a form of documentation." + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line $ sigKw <> " " <> runProperName name <> " ::" + , prettyTypeWithDepth maxBound ty + ] ] renderSimpleErrorMessage (OverlappingPattern bs b) = paras $ [ line "A case expression contains unreachable cases:\n" @@ -1099,7 +1161,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) = paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "." , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:" - , markCodeBox $ indent $ typeAsBox prettyDepth ty + , markCodeBox $ indent $ prettyType ty , line "Try adding a type signature." ] @@ -1125,7 +1187,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl argsMsg = if expected > 1 then "arguments" else "argument" renderSimpleErrorMessage (UserDefinedWarning msgTy) = - let msg = fromMaybe (typeAsBox prettyDepth msgTy) (toTypelevelString msgTy) in + let msg = fromMaybe (prettyType msgTy) (toTypelevelString msgTy) in paras [ line "A custom warning occurred while solving type class constraints:" , indent msg ] @@ -1173,6 +1235,38 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , line "Use parentheses to resolve this ambiguity." ] + renderSimpleErrorMessage (QuantificationCheckFailureInKind var) = + paras + [ line $ "Cannot generalize the kind of type variable " <> markCode var <> " since it would not be well-scoped." + , line "Try adding a kind annotation." + ] + + renderSimpleErrorMessage (QuantificationCheckFailureInType us ty) = + let unks = + fmap (\u -> Box.hsep 1 Box.top [ "where" + , markCodeBox (prettyType (srcTUnknown u)) + , "is an unknown kind." + ]) us + in paras + [ line "Cannot unambiguously generalize kinds appearing in the elaborated type:" + , indent $ markCodeBox $ typeAsBox prettyDepth ty + , paras unks + , line "Try adding additional kind signatures or polymorphic kind variables." + ] + + renderSimpleErrorMessage (VisibleQuantificationCheckFailureInType var) = + paras + [ line $ "Visible dependent quantification of type variable " <> markCode var <> " is not supported." + , line $ "If you would like this feature supported, please bother Liam Goodacre (@LiamGoodacre)." + ] + + renderSimpleErrorMessage (UnsupportedTypeInKind ty) = + paras + [ line "The type:" + , indent $ markCodeBox $ prettyType ty + , line "is not supported in kinds." + ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1@RCons{} t2@RCons{}) detail = let (row1Box, row2Box) = printRows t1 t2 @@ -1220,9 +1314,18 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] ] - renderHint (ErrorCheckingKind ty) detail = + renderHint (ErrorCheckingKind ty kd) detail = paras [ detail - , Box.hsep 1 Box.top [ line "while checking the kind of" + , Box.hsep 1 Box.top [ line "while checking that type" + , markCodeBox $ typeAsBox prettyDepth ty + ] + , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has kind" + , markCodeBox $ typeAsBox prettyDepth kd + ] + ] + renderHint (ErrorInferringKind ty) detail = + paras [ detail + , Box.hsep 1 Box.top [ line "while inferring the kind of" , markCodeBox $ typeAsBox prettyDepth ty ] ] @@ -1295,11 +1398,15 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ detail , line $ "in type class declaration for " <> markCode (runProperName name) ] + renderHint (ErrorInKindDeclaration name) detail = + paras [ detail + , line $ "in kind declaration for " <> markCode (runProperName name) + ] renderHint (ErrorInForeignImport nm) detail = paras [ detail , line $ "in foreign import " <> markCode (showIdent nm) ] - renderHint (ErrorSolvingConstraint (Constraint _ nm ts _)) detail = + renderHint (ErrorSolvingConstraint (Constraint _ nm _ ts _)) detail = paras [ detail , line "while solving type class constraint" , markCodeBox $ indent $ Box.hsep 1 Box.left @@ -1318,13 +1425,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl -- If both rows are not empty, print them as diffs -- If verbose print all rows else only print unique rows printRows :: Type a -> Type a -> (Box.Box, Box.Box) - printRows r1 r2 = case (full, r1, r2) of + printRows r1 r2 = case (full, r1, r2) of (True, _ , _) -> (printRow typeAsBox r1, printRow typeAsBox r2) - (_, RCons{}, RCons{}) -> + (_, RCons{}, RCons{}) -> let (sorted1, sorted2) = filterRows (rowToList r1) (rowToList r2) in (printRow typeDiffAsBox sorted1, printRow typeDiffAsBox sorted2) - + (_, _, _) -> (printRow typeAsBox r1, printRow typeAsBox r2) @@ -1362,7 +1469,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl nameType (DctorName _) = "data constructor" nameType (TyClassName _) = "type class" nameType (ModName _) = "module" - nameType (KiName _) = "kind" runName :: Qualified Name -> Text runName (Qualified mn (IdentName name)) = @@ -1377,8 +1483,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl showQualified runProperName (Qualified mn name) runName (Qualified mn (TyClassName name)) = showQualified runProperName (Qualified mn name) - runName (Qualified mn (KiName name)) = - showQualified runProperName (Qualified mn name) runName (Qualified Nothing (ModName name)) = runModuleName name runName (Qualified _ ModName{}) = @@ -1388,6 +1492,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl prettyDepth | full = 1000 | otherwise = 3 + prettyType :: Type a -> Box.Box + prettyType = prettyTypeWithDepth prettyDepth + + prettyTypeWithDepth :: Int -> Type a -> Box.Box + prettyTypeWithDepth depth + | full = typeAsBox depth + | otherwise = typeAsBox depth . eraseForAllKindAnnotations . eraseKindApps + levelText :: Text levelText = case level of Error -> "error" @@ -1483,11 +1595,18 @@ prettyPrintRef (TypeInstanceRef _ ident) = Just $ showIdent ident prettyPrintRef (ModuleRef _ name) = Just $ "module " <> runModuleName name -prettyPrintRef (KindRef _ pn) = - Just $ "kind " <> runProperName pn prettyPrintRef ReExportRef{} = Nothing +prettyPrintKindSignatureFor :: KindSignatureFor -> Text +prettyPrintKindSignatureFor DataSig = "data" +prettyPrintKindSignatureFor NewtypeSig = "newtype" +prettyPrintKindSignatureFor TypeSynonymSig = "type" +prettyPrintKindSignatureFor ClassSig = "class" + +prettyPrintSuggestedTypeSimplified :: Type a -> String +prettyPrintSuggestedTypeSimplified = prettyPrintSuggestedType . eraseForAllKindAnnotations . eraseKindApps + -- | Pretty print multiple errors prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String prettyPrintMultipleErrors ppeOptions = unlines . map renderBox . prettyPrintMultipleErrorsBox ppeOptions @@ -1667,3 +1786,12 @@ parU xs f = collectErrors es = case partitionEithers es of ([], rs) -> return rs (errs, _) -> throwError $ fold errs + +internalCompilerError + :: (MonadError MultipleErrors m, GHC.Stack.HasCallStack) + => Text + -> m a +internalCompilerError = + throwError + . errorMessage + . InternalCompilerError (T.pack (GHC.Stack.prettyCallStack GHC.Stack.callStack)) diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index f552f91f03..ced1f7b1cf 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -6,7 +6,6 @@ import Prelude.Compat import qualified Data.Aeson.TH as A import qualified Data.List.NonEmpty as NEL -import qualified Data.Text as T import Data.Text (Text) import qualified Language.PureScript as P @@ -73,5 +72,4 @@ toJSONError verbose level e = Nothing -> Nothing Just s -> Just $ ErrorSuggestion (suggestionText s) (toErrorPosition <$> P.suggestionSpan em) - -- TODO: Adding a newline because source spans chomp everything up to the next character - suggestionText (P.ErrorSuggestion s) = if T.null s then s else s <> "\n" + suggestionText (P.ErrorSuggestion s) = s diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 86647190d3..9c802bd643 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -25,13 +25,11 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Version (showVersion) import qualified Data.Map as M -import qualified Data.Set as S import qualified Data.List.NonEmpty as NEL import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Environment -import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Roles import Language.PureScript.TypeClassDictionaries @@ -101,7 +99,7 @@ data ExternsDeclaration = -- | A type declaration EDType { edTypeName :: ProperName 'TypeName - , edTypeKind :: SourceKind + , edTypeKind :: SourceType , edTypeDeclarationKind :: TypeKind } -- | A role declaration @@ -112,7 +110,7 @@ data ExternsDeclaration = -- | A type synonym | EDTypeSynonym { edTypeSynonymName :: ProperName 'TypeName - , edTypeSynonymArguments :: [(Text, Maybe SourceKind)] + , edTypeSynonymArguments :: [(Text, Maybe SourceType)] , edTypeSynonymType :: SourceType } -- | A data constructor @@ -131,7 +129,7 @@ data ExternsDeclaration = -- | A type class declaration | EDClass { edClassName :: ProperName 'ClassName - , edClassTypeArguments :: [(Text, Maybe SourceKind)] + , edClassTypeArguments :: [(Text, Maybe SourceType)] , edClassMembers :: [(Ident, SourceType)] , edClassConstraints :: [SourceConstraint] , edFunctionalDependencies :: [FunctionalDependency] @@ -141,15 +139,13 @@ data ExternsDeclaration = | EDInstance { edInstanceClassName :: Qualified (ProperName 'ClassName) , edInstanceName :: Ident + , edInstanceForAll :: [(Text, SourceType)] + , edInstanceKinds :: [SourceType] , edInstanceTypes :: [SourceType] , edInstanceConstraints :: Maybe [SourceConstraint] , edInstanceChain :: [Qualified Ident] , edInstanceChainIndex :: Integer } - -- | A kind declaration - | EDKind - { edKindName :: ProperName 'KindName - } deriving Show -- | Check whether the version in an externs file matches the currently running @@ -169,15 +165,14 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } applyDecl env (EDClass pn args members cs deps tcIsEmpty) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) } - applyDecl env (EDKind pn) = env { kinds = S.insert (qual pn) (kinds env) } - applyDecl env (EDInstance className ident tys cs ch idx) = + applyDecl env (EDInstance className ident vars kinds tys cs ch idx) = env { typeClassDictionaries = updateMap (updateMap (M.insertWith (<>) (qual ident) (pure dict)) className) (Just efModuleName) (typeClassDictionaries env) } where dict :: NamedDict - dict = TypeClassDictionaryInScope ch idx (qual ident) [] className tys cs + dict = TypeClassDictionaryInScope ch idx (qual ident) [] className vars kinds tys cs updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a updateMap f = M.alter (Just . f . fold) @@ -237,23 +232,23 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env = [ EDValue ident ty ] toExternsDeclaration (TypeClassRef _ className) - | Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env - , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env - , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env - = [ EDType (coerceProperName className) kind TypeSynonym - , EDTypeSynonym (coerceProperName className) typeClassArguments synTy + | let dictName = dictSynonymName . coerceProperName $ className + , Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env + , Just (kind, ExternData) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env + , Just (synKind, TypeSynonym) <- Qualified (Just mn) dictName `M.lookup` types env + , Just (synArgs, synTy) <- Qualified (Just mn) dictName `M.lookup` typeSynonyms env + = [ EDType (coerceProperName className) kind ExternData + , EDType dictName synKind TypeSynonym + , EDTypeSynonym dictName synArgs synTy , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies typeClassIsEmpty ] toExternsDeclaration (TypeInstanceRef _ ident) - = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies tcdChain tcdIndex + = [ EDInstance tcdClassName ident tcdForAll tcdInstanceKinds tcdInstanceTypes tcdDependencies tcdChain tcdIndex | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env)) , m2 <- M.elems m1 , nel <- maybeToList (M.lookup (Qualified (Just mn) ident) m2) , TypeClassDictionaryInScope{..} <- NEL.toList nel ] - toExternsDeclaration (KindRef _ pn) - | Qualified (Just mn) pn `S.member` kinds env - = [ EDKind pn ] toExternsDeclaration _ = [] $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport) diff --git a/src/Language/PureScript/Hierarchy.hs b/src/Language/PureScript/Hierarchy.hs index 0bbe7650b9..b48e95f5b5 100644 --- a/src/Language/PureScript/Hierarchy.hs +++ b/src/Language/PureScript/Hierarchy.hs @@ -80,6 +80,6 @@ typeClassEpilogue = "\n}" superClasses :: P.Declaration -> [SuperMap] superClasses (P.TypeClassDeclaration _ sub _ supers@(_:_) _ _) = - fmap (\(P.Constraint _ (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers + fmap (\(P.Constraint _ (P.Qualified _ super) _ _ _) -> SuperMap (Right (super, sub))) supers superClasses (P.TypeClassDeclaration _ sub _ _ _ _) = [SuperMap (Left sub)] superClasses _ = [] diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 0cc2aa607b..993bf1fa4f 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -44,7 +44,7 @@ explicitAnnotations = WildcardAnnotations True noAnnotations :: WildcardAnnotations noAnnotations = WildcardAnnotations False -type DataType = ([(Text, Maybe P.SourceKind)], [(P.ProperName 'P.ConstructorName, [P.SourceType])]) +type DataType = ([(Text, Maybe P.SourceType)], [(P.ProperName 'P.ConstructorName, [P.SourceType])]) caseSplit :: (Ide m, MonadError IdeError m) @@ -125,14 +125,14 @@ parseType' :: (MonadError IdeError m) => Text -> m P.SourceType parseType' s = case CST.runTokenParser CST.parseType $ CST.lex s of - Right type' -> pure $ CST.convertType "" type' + Right type' -> pure $ CST.convertType "" $ snd type' Left err -> throwError (GeneralError ("Parsing the splittype failed with:" <> show err)) parseTypeDeclaration' :: (MonadError IdeError m) => Text -> m (P.Ident, P.SourceType) parseTypeDeclaration' s = - let x = fmap (CST.convertDeclaration "") + let x = fmap (CST.convertDeclaration "" . snd) $ CST.runTokenParser CST.parseDecl $ CST.lex s in diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 56affea2dd..d62dacb3ef 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -110,15 +110,14 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl), mns) = where (complIdentifier, complExpandedType) = case decl of IdeDeclValue v -> (v ^. ideValueIdent . identT, v ^. ideValueType & prettyPrintTypeSingleLine) - IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & P.prettyPrintKind) + IdeDeclType t -> (t ^. ideTypeName . properNameT, t ^. ideTypeKind & prettyPrintTypeSingleLine) IdeDeclTypeSynonym s -> (s ^. ideSynonymName . properNameT, s ^. ideSynonymType & prettyPrintTypeSingleLine) IdeDeclDataConstructor d -> (d ^. ideDtorName . properNameT, d ^. ideDtorType & prettyPrintTypeSingleLine) - IdeDeclTypeClass d -> (d ^. ideTCName . properNameT, d ^. ideTCKind & P.prettyPrintKind) + IdeDeclTypeClass d -> (d ^. ideTCName . properNameT, d ^. ideTCKind & prettyPrintTypeSingleLine) IdeDeclValueOperator (IdeValueOperator op ref precedence associativity typeP) -> (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyPrintTypeSingleLine typeP) IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) -> - (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) P.prettyPrintKind kind) - IdeDeclKind k -> (P.runProperName k, "kind") + (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) prettyPrintTypeSingleLine kind) IdeDeclModule mn -> (P.runModuleName mn, "module") complExportedFrom = mns diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index bc107c955c..607848361e 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -1,18 +1,4 @@ ------------------------------------------------------------------------------ --- --- Module : Language.PureScript.Ide.Externs --- Description : Handles externs files for psc-ide --- Copyright : Christoph Hegemann 2016 --- License : MIT (http://opensource.org/licenses/MIT) --- --- Maintainer : Christoph Hegemann --- Stability : experimental --- --- | --- Handles externs files for psc-ide ------------------------------------------------------------------------------ - -{-# LANGUAGE PackageImports #-} +{-# language PackageImports, BlockArguments #-} module Language.PureScript.Ide.Externs ( readExternFile @@ -26,12 +12,13 @@ import Data.Aeson (decodeStrict) import Data.Aeson.Types (withObject, parseMaybe, (.:)) import qualified Data.ByteString as BS import Data.Version (showVersion) +import qualified Data.Text as Text +import qualified Language.PureScript as P import Language.PureScript.Ide.Error (IdeError (..)) import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util (properNameT) import Lens.Micro.Platform -import qualified Language.PureScript as P - readExternFile :: (MonadIO m, MonadError IdeError m, MonadLogger m) => FilePath @@ -40,12 +27,12 @@ readExternFile fp = do externsFile <- liftIO (BS.readFile fp) case decodeStrict externsFile of Nothing -> - let parser = withObject "ExternsFileVersion" $ \o -> o .: "efVersion" - maybeEFVersion = parseMaybe parser =<< decodeStrict externsFile + let + parser = withObject "ExternsFileVersion" (.: "efVersion") + maybeEFVersion = parseMaybe parser =<< decodeStrict externsFile in case maybeEFVersion of Nothing -> - throwError (GeneralError - ("Parsing the extern at: " <> toS fp <> " failed")) + throwError (GeneralError ("Parsing the extern at: " <> toS fp <> " failed")) Just efVersion -> do let errMsg = "Version mismatch for the externs at: " <> toS fp <> " Expected: " <> version @@ -70,51 +57,40 @@ convertExterns ef = moduleDecl = IdeDeclarationAnn emptyAnn (IdeDeclModule (P.efModuleName ef)) (toResolve, declarations) = second catMaybes (partitionEithers (map convertDecl (P.efDeclarations ef))) + resolvedDeclarations = resolveSynonymsAndClasses toResolve declarations - -- It's important that we resolve synonyms first, because that resolving - -- process removes the corresponding type declarations. This way we don't - -- leave any stray type declarations for type classes around since they have - -- already been cleaned up in the type synonym pass. - resolver = resolveTypeClasses toResolve <> resolveSynonyms toResolve - resolvedDeclarations = appEndo resolver declarations - -resolveSynonyms :: [ToResolve] -> Endo [IdeDeclaration] -resolveSynonyms = foldMap resolveSynonym +resolveSynonymsAndClasses + :: [ToResolve] + -> [IdeDeclaration] + -> [IdeDeclaration] +resolveSynonymsAndClasses trs decls = foldr go decls trs where - resolveSynonym tr = case tr of - TypeClassToResolve _ -> mempty - SynonymToResolve tn ty -> Endo $ \decls -> - case findType tn decls of - Nothing -> decls + go tr acc = case tr of + TypeClassToResolve tcn -> + case findType (P.coerceProperName tcn) acc of + Nothing -> + acc + Just tyDecl -> IdeDeclTypeClass + (IdeTypeClass tcn (tyDecl^.ideTypeKind) []) + : filter (not . anyOf (_IdeDeclType.ideTypeName) (== P.coerceProperName tcn)) acc + SynonymToResolve tn ty -> + case findType tn acc of + Nothing -> + acc Just tyDecl -> IdeDeclTypeSynonym (IdeTypeSynonym tn ty (tyDecl^.ideTypeKind)) - : filter (not . anyOf (_IdeDeclType.ideTypeName) (== tn)) decls - -resolveTypeClasses :: [ToResolve] -> Endo [IdeDeclaration] -resolveTypeClasses = foldMap resolveTypeClass - where - resolveTypeClass tr = case tr of - SynonymToResolve _ _ -> mempty - TypeClassToResolve tcn -> Endo $ \decls -> - case findSynonym (P.coerceProperName tcn) decls of - Nothing -> decls - Just tySyn -> IdeDeclTypeClass - (IdeTypeClass tcn (tySyn^.ideSynonymKind) []) - : filter (not . anyOf (_IdeDeclTypeSynonym.ideSynonymName) (== P.coerceProperName tcn)) decls + : filter (not . anyOf (_IdeDeclType.ideTypeName) (== tn)) acc findType :: P.ProperName 'P.TypeName -> [IdeDeclaration] -> Maybe IdeType -findSynonym :: P.ProperName 'P.TypeName -> [IdeDeclaration] -> Maybe IdeTypeSynonym -(findType, findSynonym) = ( findDecl _IdeDeclType ideTypeName - , findDecl _IdeDeclTypeSynonym ideSynonymName - ) - where - findDecl p l tn decls = decls - & mapMaybe (preview p) - & find ((==) tn . view l) - --- The Externs format splits information about synonyms across EDType and --- EDTypeSynonym declarations. For type classes there are three declarations --- involved. We collect these and resolve them at the end of the conversion process. +findType tn decls = + decls + & mapMaybe (preview _IdeDeclType) + & find ((==) tn . view ideTypeName) + +-- The Externs format splits information about synonyms across EDType +-- and EDTypeSynonym declarations. For type classes it split them +-- across an EDType and an EDClass . We collect these and resolve them +-- at the end of the conversion process. data ToResolve = TypeClassToResolve (P.ProperName 'P.ClassName) | SynonymToResolve (P.ProperName 'P.TypeName) P.SourceType @@ -125,10 +101,16 @@ convertExport _ = Nothing convertDecl :: P.ExternsDeclaration -> Either ToResolve (Maybe IdeDeclaration) convertDecl ed = case ed of - P.EDType{..} -> - Right (Just (IdeDeclType (IdeType edTypeName edTypeKind []))) + -- We need to filter all types and synonyms that contain a '$' + -- because those are typechecker internal definitions that shouldn't + -- be user facing + P.EDType{..} -> Right do + guard (isNothing (Text.find (== '$') (edTypeName^.properNameT))) + Just (IdeDeclType (IdeType edTypeName edTypeKind [])) P.EDTypeSynonym{..} -> - Left (SynonymToResolve edTypeSynonymName edTypeSynonymType) + if isNothing (Text.find (== '$') (edTypeSynonymName^.properNameT)) + then Left (SynonymToResolve edTypeSynonymName edTypeSynonymType) + else Right Nothing P.EDDataConstructor{..} -> Right (Just @@ -140,8 +122,6 @@ convertDecl ed = case ed of Right (Just (IdeDeclValue (IdeValue edValueName edValueType))) P.EDClass{..} -> Left (TypeClassToResolve edClassName) - P.EDKind{..} -> - Right (Just (IdeDeclKind edKindName)) P.EDInstance{} -> Right Nothing diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs index 5c04fd3512..96eda65312 100644 --- a/src/Language/PureScript/Ide/Filter/Declaration.hs +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -18,7 +18,6 @@ data DeclarationType | TypeClass | ValueOperator | TypeOperator - | Kind | Module deriving (Show, Eq, Ord) @@ -32,7 +31,6 @@ instance FromJSON DeclarationType where "typeclass" -> pure TypeClass "valueoperator" -> pure ValueOperator "typeoperator" -> pure TypeOperator - "kind" -> pure Kind "module" -> pure Module _ -> mzero @@ -45,5 +43,4 @@ declarationType decl = case decl of PI.IdeDeclTypeClass _ -> TypeClass PI.IdeDeclValueOperator _ -> ValueOperator PI.IdeDeclTypeOperator _ -> TypeOperator - PI.IdeDeclKind _ -> Kind PI.IdeDeclModule _ -> Module diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 89111daf55..5afc7ccde6 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -222,8 +222,6 @@ addExplicitImport' decl moduleName qualifier imports = P.ValueOpRef ideSpan (op ^. ideValueOpName) refFromDeclaration (IdeDeclTypeOperator op) = P.TypeOpRef ideSpan (op ^. ideTypeOpName) - refFromDeclaration (IdeDeclKind kn) = - P.KindRef ideSpan kn refFromDeclaration d = P.ValueRef ideSpan (P.Ident (identifierFromIdeDeclaration d)) @@ -371,7 +369,7 @@ answerRequest outfp rs = -- | Test and ghci helper parseImport :: Text -> Maybe Import parseImport t = - case fmap (CST.convertImportDecl "") + case fmap (CST.convertImportDecl "" . snd) $ CST.runTokenParser CST.parseImportDeclP $ CST.lex t of Right (_, mn, idt, mmn) -> diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index 8b904d22fd..f9b2e5ae78 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -2,7 +2,6 @@ module Language.PureScript.Ide.Prim (idePrimDeclarations) where import Protolude import qualified Data.Map as Map -import qualified Data.Set as Set import qualified Language.PureScript as P import qualified Language.PureScript.Constants.Prim as C import qualified Language.PureScript.Environment as PEnv @@ -11,25 +10,25 @@ import Language.PureScript.Ide.Types idePrimDeclarations :: ModuleMap [IdeDeclarationAnn] idePrimDeclarations = Map.fromList [ ( C.Prim - , mconcat [primTypes, primKinds, primClasses] + , mconcat [primTypes, primClasses] ) , ( C.PrimBoolean - , mconcat [primBooleanTypes, primBooleanKinds] + , mconcat [primBooleanTypes] ) , ( C.PrimOrdering - , mconcat [primOrderingTypes, primOrderingKinds] + , mconcat [primOrderingTypes] ) , ( C.PrimRow , mconcat [primRowTypes, primRowClasses] ) , ( C.PrimRowList - , mconcat [primRowListTypes, primRowListClasses, primRowListKinds] + , mconcat [primRowListTypes, primRowListClasses] ) , ( C.PrimSymbol , mconcat [primSymbolTypes, primSymbolClasses] ) , ( C.PrimTypeError - , mconcat [primTypeErrorTypes, primTypeErrorClasses, primTypeErrorKinds] + , mconcat [primTypeErrorTypes, primTypeErrorClasses] ) ] where @@ -57,18 +56,3 @@ idePrimDeclarations = Map.fromList primRowListClasses = annClass PEnv.primRowListClasses primSymbolClasses = annClass PEnv.primSymbolClasses primTypeErrorClasses = annClass PEnv.primTypeErrorClasses - - primKinds = foreach (Set.toList PEnv.primKinds) $ \kn -> - IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) - - primBooleanKinds = foreach (Set.toList PEnv.primBooleanKinds) $ \kn -> - IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) - - primOrderingKinds = foreach (Set.toList PEnv.primOrderingKinds) $ \kn -> - IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) - - primRowListKinds = foreach (Set.toList PEnv.primRowListKinds) $ \kn -> - IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) - - primTypeErrorKinds = foreach (Set.toList PEnv.primTypeErrorKinds) $ \kn -> - IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 556c003517..1cf9bd0695 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -53,7 +53,7 @@ rebuildFile rebuildFile file actualFile codegenTargets runOpenBuild = do (fp, input) <- ideReadFile file let fp' = fromMaybe fp actualFile - m <- case CST.parseFromFile fp' input of + (pwarnings, m) <- case sequence $ CST.parseFromFile fp' input of Left parseError -> throwError $ RebuildError $ CST.toMultipleErrors fp' parseError Right m -> pure m @@ -82,7 +82,7 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do void populateVolatileState _ <- updateCacheTimestamp runOpenBuild (rebuildModuleOpen makeEnv externs m) - pure (RebuildSuccess warnings) + pure (RebuildSuccess (CST.toMultipleWarnings fp pwarnings <> warnings)) -- | When adjusting the cache db file after a rebuild we always pick a -- non-sensical timestamp ("1858-11-17T00:00:00Z"), and rely on the diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 63602cc22a..b66b887678 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -115,8 +115,6 @@ resolveRef decls ref = case ref of findWrapped (anyOf (_IdeDeclTypeOperator . ideTypeOpName) (== name)) P.TypeClassRef _ name -> findWrapped (anyOf (_IdeDeclTypeClass . ideTCName) (== name)) - P.KindRef _ name -> - findWrapped (anyOf _IdeDeclKind (== name)) _ -> Left ref where diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 726478af12..723981455a 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -41,7 +41,7 @@ parseModule path = do parseModule' :: FilePath -> Text -> Either FilePath (FilePath, P.Module) parseModule' path file = - case CST.parseFromFile path file of + case snd $ CST.parseFromFile path file of Left _ -> Left path Right m -> Right (path, m) @@ -96,8 +96,6 @@ extractSpans d = case d of [(IdeNamespaced IdeNSValue (P.runIdent ident), ss)] P.ExternDataDeclaration (ss, _) name _ -> [(IdeNamespaced IdeNSType (P.runProperName name), ss)] - P.ExternKindDeclaration (ss, _) name -> - [(IdeNamespaced IdeNSKind (P.runProperName name), ss)] _ -> [] where dtorSpan :: P.DataConstructorDeclaration -> (IdeNamespaced, P.SourceSpan) diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 4d3ccaaf31..c397988a77 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -261,7 +261,6 @@ resolveLocationsForModule (defs, types) decls = annotateValue annotateDataConstructor annotateType - annotateKind annotateModule d where @@ -271,7 +270,6 @@ resolveLocationsForModule (defs, types) decls = annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) annotateDataConstructor x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs}) annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs}) - annotateKind x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSKind x) defs}) annotateModule x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSModule x) defs}) convertDeclaration' @@ -280,10 +278,9 @@ convertDeclaration' -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> (Text -> IdeDeclaration -> IdeDeclarationAnn) - -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> IdeDeclaration -> IdeDeclarationAnn -convertDeclaration' annotateFunction annotateValue annotateDataConstructor annotateType annotateKind annotateModule d = +convertDeclaration' annotateFunction annotateValue annotateDataConstructor annotateType annotateModule d = case d of IdeDeclValue v -> annotateFunction (v ^. ideValueIdent) d @@ -299,8 +296,6 @@ convertDeclaration' annotateFunction annotateValue annotateDataConstructor annot annotateValue (operator ^. ideValueOpName . opNameT) d IdeDeclTypeOperator operator -> annotateType (operator ^. ideTypeOpName . opNameT) d - IdeDeclKind i -> - annotateKind (i ^. properNameT) d IdeDeclModule mn -> annotateModule (P.runModuleName mn) d @@ -340,7 +335,6 @@ resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) de (annotateValue . P.IdentName . P.Ident) (annotateValue . P.DctorName . P.ProperName) (annotateValue . P.TyName . P.ProperName) - (annotateValue . P.KiName . P.ProperName) (annotateValue . P.ModName . P.moduleNameFromString) d where diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 2fb106aad8..f566f2b40c 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -29,7 +29,6 @@ data IdeDeclaration | IdeDeclValueOperator IdeValueOperator | IdeDeclTypeOperator IdeTypeOperator | IdeDeclModule P.ModuleName - | IdeDeclKind (P.ProperName 'P.KindName) deriving (Show, Eq, Ord, Generic, NFData) data IdeValue = IdeValue @@ -39,14 +38,14 @@ data IdeValue = IdeValue data IdeType = IdeType { _ideTypeName :: P.ProperName 'P.TypeName - , _ideTypeKind :: P.SourceKind + , _ideTypeKind :: P.SourceType , _ideTypeDtors :: [(P.ProperName 'P.ConstructorName, P.SourceType)] } deriving (Show, Eq, Ord, Generic, NFData) data IdeTypeSynonym = IdeTypeSynonym { _ideSynonymName :: P.ProperName 'P.TypeName , _ideSynonymType :: P.SourceType - , _ideSynonymKind :: P.SourceKind + , _ideSynonymKind :: P.SourceType } deriving (Show, Eq, Ord, Generic, NFData) data IdeDataConstructor = IdeDataConstructor @@ -57,7 +56,7 @@ data IdeDataConstructor = IdeDataConstructor data IdeTypeClass = IdeTypeClass { _ideTCName :: P.ProperName 'P.ClassName - , _ideTCKind :: P.SourceKind + , _ideTCKind :: P.SourceType , _ideTCInstances :: [IdeInstance] } deriving (Show, Eq, Ord, Generic, NFData) @@ -81,7 +80,7 @@ data IdeTypeOperator = IdeTypeOperator , _ideTypeOpAlias :: P.Qualified (P.ProperName 'P.TypeName) , _ideTypeOpPrecedence :: P.Precedence , _ideTypeOpAssociativity :: P.Associativity - , _ideTypeOpKind :: Maybe P.SourceKind + , _ideTypeOpKind :: Maybe P.SourceType } deriving (Show, Eq, Ord, Generic, NFData) _IdeDeclValue :: Traversal' IdeDeclaration IdeValue @@ -112,10 +111,6 @@ _IdeDeclTypeOperator :: Traversal' IdeDeclaration IdeTypeOperator _IdeDeclTypeOperator f (IdeDeclTypeOperator x) = map IdeDeclTypeOperator (f x) _IdeDeclTypeOperator _ x = pure x -_IdeDeclKind :: Traversal' IdeDeclaration (P.ProperName 'P.KindName) -_IdeDeclKind f (IdeDeclKind x) = map IdeDeclKind (f x) -_IdeDeclKind _ x = pure x - _IdeDeclModule :: Traversal' IdeDeclaration P.ModuleName _IdeDeclModule f (IdeDeclModule x) = map IdeDeclModule (f x) _IdeDeclModule _ x = pure x @@ -246,7 +241,6 @@ identifierFromDeclarationRef = \case P.TypeRef _ name _ -> P.runProperName name P.ValueRef _ ident -> P.runIdent ident P.TypeClassRef _ name -> P.runProperName name - P.KindRef _ name -> P.runProperName name P.ValueOpRef _ op -> P.showOp op P.TypeOpRef _ op -> P.showOp op _ -> "" @@ -303,14 +297,13 @@ encodeImport (P.runModuleName -> mn, importType, map P.runModuleName -> qualifie ] ++ map ("qualifier" .=) (maybeToList qualifier) -- | Denotes the different namespaces a name in PureScript can reside in. -data IdeNamespace = IdeNSValue | IdeNSType | IdeNSKind | IdeNSModule +data IdeNamespace = IdeNSValue | IdeNSType | IdeNSModule deriving (Show, Eq, Ord, Generic, NFData) instance FromJSON IdeNamespace where parseJSON (Aeson.String s) = case s of "value" -> pure IdeNSValue "type" -> pure IdeNSType - "kind" -> pure IdeNSKind "module" -> pure IdeNSModule _ -> mzero parseJSON _ = mzero diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index 8db7f36f5b..81ccee3542 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -109,9 +109,6 @@ matchesRef declaration ref = case declaration of IdeDeclTypeOperator typeOperator -> case ref of P.TypeOpRef _ opName -> opName == _ideTypeOpName typeOperator _ -> False - IdeDeclKind kind -> case ref of - P.KindRef _ kindName -> kindName == kind - _ -> False IdeDeclModule m -> case ref of P.ModuleRef _ mn -> m == mn _ -> False diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index d25a8708d7..56474f8aef 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -52,7 +52,6 @@ identifierFromIdeDeclaration d = case d of IdeDeclTypeClass tc -> tc ^. ideTCName . properNameT IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName - IdeDeclKind name -> P.runProperName name IdeDeclModule name -> P.runModuleName name namespaceForDeclaration :: IdeDeclaration -> IdeNamespace @@ -64,7 +63,6 @@ namespaceForDeclaration d = case d of IdeDeclTypeClass _ -> IdeNSType IdeDeclValueOperator _ -> IdeNSValue IdeDeclTypeOperator _ -> IdeNSType - IdeDeclKind _ -> IdeNSKind IdeDeclModule _ -> IdeNSModule discardAnn :: IdeDeclarationAnn -> IdeDeclaration diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 6d26bf1655..b74f107a94 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -222,8 +222,6 @@ handleShowImportedModules print' = do Just $ N.runIdent ident showRef (P.ModuleRef _ name) = Just $ "module " <> N.runModuleName name - showRef (P.KindRef _ pn) = - Just $ "kind " <> N.runProperName pn showRef (P.ReExportRef _ _ _) = Nothing @@ -295,13 +293,13 @@ handleKindOf print' typ = do case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of Just (_, typ') -> do let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName } - k = check (P.kindOf typ') chk + k = check (snd <$> P.kindOf typ') chk check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState) check sew = fst . runWriter . runExceptT . runStateT sew case k of Left err -> printErrors err - Right (kind, _) -> print' . T.unpack . P.prettyPrintKind $ kind + Right (kind, _) -> print' . P.prettyPrintType 1024 $ kind Nothing -> print' "Could not find kind" -- | Browse a module and displays its signature diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 7bc01c5617..31e9b48338 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -27,7 +27,7 @@ loadModule filename = do pwd <- getCurrentDirectory content <- readUTF8FileT filename return $ - either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd}) (Right . map snd) $ + either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd}) (Right . map (snd . snd)) $ CST.parseFromFiles id [(filename, content)] -- | Load all modules. @@ -35,7 +35,7 @@ loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module loadAllModules files = do pwd <- getCurrentDirectory filesAndContent <- readUTF8FilesT files - return $ CST.parseFromFiles (makeRelative pwd) filesAndContent + return $ fmap (fmap snd) <$> CST.parseFromFiles (makeRelative pwd) filesAndContent -- | -- Makes a volatile module to execute the current expression. diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index 33a0ed7ea8..9d3ff1cb2c 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -9,7 +9,7 @@ module Language.PureScript.Interactive.Parser import Prelude.Compat hiding (lex) import Control.Monad (join, unless) -import Data.Bifunctor (first) +import Data.Bifunctor (bimap) import Data.Char (isSpace) import Data.List (intercalate) import qualified Data.List.NonEmpty as NE @@ -26,7 +26,7 @@ import Language.PureScript.Interactive.Types -- parseDotFile :: FilePath -> String -> Either String [Command] parseDotFile filePath = - first (CST.prettyPrintError . NE.head) + bimap (CST.prettyPrintError . NE.head) snd . CST.runTokenParser (parseMany parser <* CSTM.token CST.TokEof) . CST.lexTopLevel . T.pack @@ -65,7 +65,7 @@ parseOne p = CSTM.token CST.TokLayoutStart *> p <* CSTM.token CST.TokLayoutEnd parseRest :: CST.Parser a -> String -> Either String a parseRest p = - first (CST.prettyPrintError . NE.head) + bimap (CST.prettyPrintError . NE.head) snd . CST.runTokenParser (p <* CSTM.token CST.TokEof) . CST.lexTopLevel . T.pack @@ -146,7 +146,6 @@ acceptable P.ExternDeclaration{} = True acceptable P.ExternDataDeclaration{} = True acceptable P.TypeClassDeclaration{} = True acceptable P.TypeInstanceDeclaration{} = True -acceptable P.ExternKindDeclaration{} = True acceptable P.TypeDeclaration{} = True acceptable P.ValueDeclaration{} = True acceptable _ = False diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index 8a7dce4db6..e42759610f 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -61,7 +61,7 @@ printModuleSignatures moduleName P.Environment{..} = if null typeClassSuperclasses then Box.text "" else Box.text "(" - Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint _ (P.Qualified _ pn) lt _) -> textT (P.runProperName pn) Box.<+> Box.hcat Box.left (map (P.typeAtomAsBox maxBound) lt)) typeClassSuperclasses) + Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint _ (P.Qualified _ pn) _ lt _) -> textT (P.runProperName pn) Box.<+> Box.hcat Box.left (map (P.typeAtomAsBox maxBound) lt)) typeClassSuperclasses) Box.<> Box.text ") <= " className = textT (P.runProperName name) @@ -79,16 +79,16 @@ printModuleSignatures moduleName P.Environment{..} = findType - :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.SourceKind, P.TypeKind) + :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.SourceType, P.TypeKind) -> P.Qualified (P.ProperName 'P.TypeName) - -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.SourceKind, P.TypeKind)) + -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.SourceType, P.TypeKind)) findType envTypes name = (name, M.lookup name envTypes) showType :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]) - -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(Text, Maybe P.SourceKind)], P.SourceType) - -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.SourceKind, P.TypeKind)) + -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(Text, Maybe P.SourceType)], P.SourceType) + -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.SourceType, P.TypeKind)) -> Maybe Box.Box showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) = case (typ, M.lookup n typeSynonymsEnv) of diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index fefed909ad..68f9eaae10 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -96,12 +96,15 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl -- Recursively walk the type and prune used variables from `unused` go :: S.Set Text -> SourceType -> (S.Set Text, MultipleErrors) go unused (TypeVar _ v) = (S.delete v unused, mempty) - go unused (ForAll _ tv _ t1 _) = - let (nowUnused, errors) = go (S.insert tv unused) t1 + go unused (ForAll _ tv mbK t1 _) = + let (nowUnused, errors) + | Just k <- mbK = go unused k `combine` go (S.insert tv unused) t1 + | otherwise = go (S.insert tv unused) t1 restoredUnused = if S.member tv unused then S.insert tv nowUnused else nowUnused combinedErrors = if S.member tv nowUnused then errors <> errorMessage' ss (UnusedTypeVar tv) else errors in (restoredUnused, combinedErrors) go unused (TypeApp _ f x) = go unused f `combine` go unused x + go unused (KindApp _ f x) = go unused f `combine` go unused x go unused (ConstrainedType _ c t1) = foldl combine (unused, mempty) $ map (go unused) (constraintArgs c <> [t1]) go unused (RCons _ _ t1 rest) = go unused t1 `combine` go unused rest go unused (KindedType _ t1 _) = go unused t1 diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index ad4bc5da72..ffa3d8663c 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -28,9 +28,8 @@ import Language.PureScript.AST.Binders import Language.PureScript.AST.Declarations import Language.PureScript.AST.Literals import Language.PureScript.Crash -import Language.PureScript.Environment +import Language.PureScript.Environment hiding (tyVar) import Language.PureScript.Errors -import Language.PureScript.Kinds import Language.PureScript.Names as P import Language.PureScript.Pretty.Values (prettyPrintBinderAtom) import Language.PureScript.Traversals @@ -67,11 +66,11 @@ getConstructors :: Environment -> ModuleName -> Qualified (ProperName 'Construct getConstructors env defmn n = extractConstructors lnte where - extractConstructors :: Maybe (SourceKind, TypeKind) -> [(ProperName 'ConstructorName, [SourceType])] + extractConstructors :: Maybe (SourceType, TypeKind) -> [(ProperName 'ConstructorName, [SourceType])] extractConstructors (Just (_, DataType _ pt)) = pt extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors" - lnte :: Maybe (SourceKind, TypeKind) + lnte :: Maybe (SourceType, TypeKind) lnte = M.lookup qpn (types env) qpn :: Qualified (ProperName 'TypeName) @@ -308,7 +307,7 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' srcForAll tyVar Nothing ( srcConstrainedType - (srcConstraint C.Partial [] (Just constraintData)) + (srcConstraint C.Partial [] [] (Just constraintData)) $ srcTypeApp (srcTypeApp tyFunction (srcTypeVar tyVar)) (srcTypeVar tyVar) ) Nothing diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 09321d0f57..de55f7cf89 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -178,7 +178,6 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do ++ extractByQual mne (importedDataConstructors scope) DctorName ++ extractByQual mne (importedValues scope) IdentName ++ extractByQual mne (importedValueOps scope) ValOpName - ++ extractByQual mne (importedKinds scope) KiName where go :: (ModuleName, Qualified Name) -> UsedImports -> UsedImports go (q, name) = M.alter (Just . maybe [name] (name :)) q @@ -329,14 +328,13 @@ findUsedRefs ss env mni qn names = valueOpRefs = ValueOpRef ss <$> mapMaybe (getValOpName <=< disqualifyFor qn) names typeOpRefs = TypeOpRef ss <$> mapMaybe (getTypeOpName <=< disqualifyFor qn) names types = mapMaybe (getTypeName <=< disqualifyFor qn) names - kindRefs = KindRef ss <$> mapMaybe (getKindName <=< disqualifyFor qn) names dctors = mapMaybe (getDctorName <=< disqualifyFor qn) names typesWithDctors = reconstructTypeRefs dctors typesWithoutDctors = filter (`M.notMember` typesWithDctors) types typesRefs = map (flip (TypeRef ss) (Just [])) typesWithoutDctors ++ map (\(ty, ds) -> TypeRef ss ty (Just ds)) (M.toList typesWithDctors) - in sortBy compDecRef $ classRefs ++ typeOpRefs ++ typesRefs ++ kindRefs ++ valueRefs ++ valueOpRefs + in sortBy compDecRef $ classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs where @@ -374,7 +372,6 @@ runDeclRef (ValueOpRef _ op) = Just $ ValOpName op runDeclRef (TypeRef _ pn _) = Just $ TyName pn runDeclRef (TypeOpRef _ op) = Just $ TyOpName op runDeclRef (TypeClassRef _ pn) = Just $ TyClassName pn -runDeclRef (KindRef _ pn) = Just $ KiName pn runDeclRef _ = Nothing checkDuplicateImports diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index ec4b6254b6..c07e486d6f 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -132,7 +132,8 @@ make ma@MakeActions{..} ms = do let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph) buildModule buildPlan moduleName (spanName . getModuleSourceSpan . CST.resPartial $ m) - (importPrim <$> CST.resFull m) + (fst $ CST.resFull m) + (fmap importPrim . snd $ CST.resFull m) (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted) -- Wait for all threads to complete, and collect results (and errors). @@ -197,9 +198,11 @@ make ma@MakeActions{..} ms = do inOrderOf :: (Ord a) => [a] -> [a] -> [a] inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys - buildModule :: BuildPlan -> ModuleName -> FilePath -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m () - buildModule buildPlan moduleName fp mres deps = do + buildModule :: BuildPlan -> ModuleName -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m () + buildModule buildPlan moduleName fp pwarnings mres deps = do result <- flip catchError (return . BuildJobFailed) $ do + let pwarnings' = CST.toMultipleWarnings fp pwarnings + tell pwarnings' m <- CST.unwrapParserError fp mres -- We need to wait for dependencies to be built, before checking if the current -- module should be rebuilt, so the first thing to do is to wait on the @@ -219,7 +222,7 @@ make ma@MakeActions{..} ms = do foldM go env deps env <- C.readMVar (bpEnv buildPlan) (exts, warnings) <- listen $ rebuildModule' ma env externs m - return $ BuildJobSucceeded warnings exts + return $ BuildJobSucceeded (pwarnings' <> warnings) exts Nothing -> return BuildJobSkipped BuildPlan.markComplete buildPlan moduleName result diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 678643aec4..c3a0d2fab5 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -327,7 +327,7 @@ checkForeignDecls m path = do -- identifier should be enough. parseIdent :: String -> Either String Ident parseIdent str = - bimap (const str) (Ident . CST.getIdent . CST.nameValue) + bimap (const str) (Ident . CST.getIdent . CST.nameValue . snd) . CST.runTokenParser CST.parseIdent . CST.lex $ T.pack str diff --git a/src/Language/PureScript/Pretty.hs b/src/Language/PureScript/Pretty.hs index b993595121..87c42cf754 100644 --- a/src/Language/PureScript/Pretty.hs +++ b/src/Language/PureScript/Pretty.hs @@ -7,7 +7,6 @@ -- * [@Language.PureScript.Pretty.Types@] Pretty printer for types module Language.PureScript.Pretty (module P) where -import Language.PureScript.Pretty.Kinds as P import Language.PureScript.Pretty.Types as P import Language.PureScript.Pretty.Values as P import Language.PureScript.PSString as P (prettyPrintString) diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs deleted file mode 100644 index 275f5e33c9..0000000000 --- a/src/Language/PureScript/Pretty/Kinds.hs +++ /dev/null @@ -1,57 +0,0 @@ --- | --- Pretty printer for kinds --- -module Language.PureScript.Pretty.Kinds - ( prettyPrintKind - ) where - -import Prelude.Compat - -import Control.Arrow (ArrowPlus(..)) -import Control.PatternArrows as PA - -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Data.Text (Text) - -import Language.PureScript.Crash -import Language.PureScript.Kinds -import Language.PureScript.Names -import Language.PureScript.Pretty.Common - -typeLiterals :: Pattern () (Kind a) Text -typeLiterals = mkPattern match - where - match (KUnknown _ u) = - Just $ T.cons 'k' (T.pack (show u)) - match (NamedKind _ name) = - Just $ if isQualifiedWith (moduleNameFromString "Prim") name - then runProperName (disqualify name) - else showQualified runProperName name - match _ = Nothing - -matchRow :: Pattern () (Kind a) ((), Kind a) -matchRow = mkPattern match - where - match (Row _ k) = Just ((), k) - match _ = Nothing - -funKind :: Pattern () (Kind a) (Kind a, Kind a) -funKind = mkPattern match - where - match (FunKind _ arg ret) = Just (arg, ret) - match _ = Nothing - --- | Generate a pretty-printed string representing a Kind -prettyPrintKind :: Kind a -> Text -prettyPrintKind - = fromMaybe (internalError "Incomplete pattern") - . PA.pattern matchKind () - where - matchKind :: Pattern () (Kind a) Text - matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parensT matchKind) - - operators :: OperatorTable () (Kind a) Text - operators = - OperatorTable [ [ Wrap matchRow $ \_ k -> "# " <> k] - , [ AssocR funKind $ \arg ret -> arg <> " -> " <> ret ] ] diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 0047b231ab..b8e2e768dc 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -22,17 +22,14 @@ import Prelude.Compat hiding ((<>)) import Control.Arrow ((<+>)) import Control.PatternArrows as PA -import Data.Functor (($>)) import Data.Maybe (fromMaybe, catMaybes) import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Crash import Language.PureScript.Environment -import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Pretty.Common -import Language.PureScript.Pretty.Kinds import Language.PureScript.Types import Language.PureScript.PSString (PSString, prettyPrintString, decodeString) import Language.PureScript.Label (Label(..)) @@ -48,17 +45,18 @@ data PrettyPrintType | PPTypeOp (Qualified (OpName 'TypeOpName)) | PPSkolem Text Int | PPTypeApp PrettyPrintType PrettyPrintType + | PPKindArg PrettyPrintType | PPConstrainedType PrettyPrintConstraint PrettyPrintType - | PPKindedType PrettyPrintType (Kind ()) + | PPKindedType PrettyPrintType PrettyPrintType | PPBinaryNoParensType PrettyPrintType PrettyPrintType PrettyPrintType | PPParensInType PrettyPrintType - | PPForAll [(Text, Maybe (Kind ()))] PrettyPrintType + | PPForAll [(Text, Maybe PrettyPrintType)] PrettyPrintType | PPFunction PrettyPrintType PrettyPrintType | PPRecord [(Label, PrettyPrintType)] (Maybe PrettyPrintType) | PPRow [(Label, PrettyPrintType)] (Maybe PrettyPrintType) | PPTruncated -type PrettyPrintConstraint = (Qualified (ProperName 'ClassName), [PrettyPrintType]) +type PrettyPrintConstraint = (Qualified (ProperName 'ClassName), [PrettyPrintType], [PrettyPrintType]) convertPrettyPrintType :: Int -> Type a -> PrettyPrintType convertPrettyPrintType = go @@ -69,28 +67,29 @@ convertPrettyPrintType = go go _ (TypeWildcard _ n) = PPTypeWildcard n go _ (TypeConstructor _ c) = PPTypeConstructor c go _ (TypeOp _ o) = PPTypeOp o - go _ (Skolem _ t n _) = PPSkolem t n + go _ (Skolem _ t _ n _) = PPSkolem t n go _ (REmpty _) = PPRow [] Nothing -- Guard the remaining "complex" type atoms on the current depth value. The -- prior constructors can all be printed simply so it's not really helpful to -- truncate them. go d _ | d < 0 = PPTruncated - go d (ConstrainedType _ (Constraint _ cls args _) ty) = PPConstrainedType (cls, go (d-1) <$> args) (go d ty) - go d (KindedType _ ty k) = PPKindedType (go (d-1) ty) (k $> ()) + go d (ConstrainedType _ (Constraint _ cls kargs args _) ty) = PPConstrainedType (cls, go (d-1) <$> kargs, go (d-1) <$> args) (go d ty) + go d (KindedType _ ty k) = PPKindedType (go (d-1) ty) (go (d-1) k) go d (BinaryNoParensType _ ty1 ty2 ty3) = PPBinaryNoParensType (go (d-1) ty1) (go (d-1) ty2) (go (d-1) ty3) go d (ParensInType _ ty) = PPParensInType (go (d-1) ty) go d ty@RCons{} = uncurry PPRow (goRow d ty) - go d (ForAll _ v mbK ty _) = goForAll d [(v, fmap ($> ()) mbK)] ty + go d (ForAll _ v mbK ty _) = goForAll d [(v, fmap (go (d-1)) mbK)] ty go d (TypeApp _ a b) = goTypeApp d a b + go d (KindApp _ a b) = PPTypeApp (go (d-1) a) (PPKindArg (go (d-1) b)) - goForAll d vs (ForAll _ v mbK ty _) = goForAll d ((v, fmap ($> ()) mbK) : vs) ty - goForAll d vs ty = PPForAll vs (go (d-1) ty) + goForAll d vs (ForAll _ v mbK ty _) = goForAll d ((v, fmap (go (d-1)) mbK) : vs) ty + goForAll d vs ty = PPForAll (reverse vs) (go (d-1) ty) goRow d ty = let (items, tail_) = rowToSortedList ty in ( map (\item -> (rowListLabel item, go (d-1) (rowListType item))) items , case tail_ of - REmpty _ -> Nothing + REmptyKinded _ _ -> Nothing _ -> Just (go (d-1) tail_) ) @@ -110,7 +109,7 @@ constraintsAsBox tro con ty = doubleRightArrow = if troUnicode tro then "⇒" else "=>" constraintAsBox :: PrettyPrintConstraint -> Box -constraintAsBox (pn, tys) = typeAsBox' (foldl PPTypeApp (PPTypeConstructor (fmap coerceProperName pn)) tys) +constraintAsBox (pn, ks, tys) = typeAsBox' (foldl PPTypeApp (foldl (\a b -> PPTypeApp a (PPKindArg b)) (PPTypeConstructor (fmap coerceProperName pn)) ks) tys) -- | -- Generate a pretty-printed string representing a Row @@ -145,16 +144,22 @@ typeApp = mkPattern match match (PPTypeApp f x) = Just (f, x) match _ = Nothing +kindArg :: Pattern () PrettyPrintType ((), PrettyPrintType) +kindArg = mkPattern match + where + match (PPKindArg ty) = Just ((), ty) + match _ = Nothing + appliedFunction :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType) appliedFunction = mkPattern match where match (PPFunction arg ret) = Just (arg, ret) match _ = Nothing -kinded :: Pattern () PrettyPrintType (Kind (), PrettyPrintType) +kinded :: Pattern () PrettyPrintType (PrettyPrintType, PrettyPrintType) kinded = mkPattern match where - match (PPKindedType t k) = Just (k, t) + match (PPKindedType t k) = Just (t, k) match _ = Nothing constrained :: Pattern () PrettyPrintType (PrettyPrintConstraint, PrettyPrintType) @@ -197,18 +202,21 @@ matchType :: TypeRenderOptions -> Pattern () PrettyPrintType Box matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where operators :: OperatorTable () PrettyPrintType Box operators = - OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ] + OperatorTable [ [ Wrap kindArg $ \_ ty -> text "@" <> ty ] + , [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ] , [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text rightArrow <> " " <> ret) ] , [ Wrap constrained $ \deps ty -> constraintsAsBox tro deps ty ] - , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text (forall' ++ " " ++ unwords (fmap printMbKindedType idents) ++ ".")) ty ] - , [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (doubleColon ++ " " ++ T.unpack (prettyPrintKind k))) ] + , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (hsep 1 top (text forall' : fmap printMbKindedType idents) <> text ".") ty ] + , [ Wrap kinded $ \ty k -> keepSingleLinesOr (moveRight 2) (typeAsBox' ty) (text (doubleColon ++ " ") <> k) ] , [ Wrap explicitParens $ \_ ty -> ty ] ] rightArrow = if troUnicode tro then "→" else "->" forall' = if troUnicode tro then "∀" else "forall" doubleColon = if troUnicode tro then "∷" else "::" - printMbKindedType (v, mbK) = maybe v (\k -> unwords ["(" ++ v, doubleColon, T.unpack (prettyPrintKind k) ++ ")"]) mbK + + printMbKindedType (v, Nothing) = text v + printMbKindedType (v, Just k) = text ("(" ++ v ++ " " ++ doubleColon ++ " ") <> typeAsBox' k <> text ")" -- If both boxes span a single line, keep them on the same line, or else -- use the specified function to modify the second box, then combine vertically. @@ -217,7 +225,7 @@ matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where | rows b1 > 1 || rows b2 > 1 = vcat left [ b1, f b2 ] | otherwise = hcat top [ b1, text " ", b2] -forall_ :: Pattern () PrettyPrintType ([(String, Maybe (Kind ()))], PrettyPrintType) +forall_ :: Pattern () PrettyPrintType ([(String, Maybe PrettyPrintType)], PrettyPrintType) forall_ = mkPattern match where match (PPForAll idents ty) = Just (map (\(v, mbK) -> (T.unpack v, mbK)) idents, ty) diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 99ddaf0b38..0ab244e570 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -87,7 +87,8 @@ prettyPrintValue d (Do m els) = prettyPrintValue d (Ado m els yield) = textT (maybe "" ((Monoid.<> ".") . runModuleName) m) <> text "ado " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) // (text "in " <> prettyPrintValue (d - 1) yield) -prettyPrintValue d (TypeClassDictionary (Constraint _ name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map (typeAtomAsBox d) tys +-- TODO: constraint kind args +prettyPrintValue d (TypeClassDictionary (Constraint _ name _ tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map (typeAtomAsBox d) tys prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name)) prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = text "#dict-accessor " <> text (T.unpack (runProperName (disqualify className))) <> text "." <> text (T.unpack (showIdent ident)) <> text ">" diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index c6e058c649..0d57c3ea3f 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -67,20 +67,31 @@ createBindingGroups moduleName = mapM f <=< handleDecls handleDecls :: [Declaration] -> m [Declaration] handleDecls ds = do let values = mapMaybe (fmap (fmap extractGuardedExpr) . getValueDeclaration) ds - dataDecls = filter isDataDecl ds - allProperNames = fmap declTypeName dataDecls - dataVerts = fmap (\d -> (d, declTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls + kindDecls = fmap (,True) $ filter isKindDecl ds + dataDecls = fmap (,False) $ filter (\a -> isDataDecl a || isExternDataDecl a || isTypeSynonymDecl a || isTypeClassDecl a) ds + kindSigs = fmap (declTypeName . fst) kindDecls + typeSyns = fmap declTypeName $ filter isTypeSynonymDecl ds + allProperNames = fmap (declTypeName . fst) dataDecls + allDecls = kindDecls ++ dataDecls + mkVert (d, isSig) = + let names = usedTypeNames moduleName d `intersect` allProperNames + name = declTypeName d + -- If a dependency has a kind signature, than that's all we need to depend on, except + -- in the case that we are defining a kind signature and using a type synonym. In order + -- to expand the type synonym, we must depend on the synonym declaration itself. + deps = fmap (\n -> (n, n `elem` kindSigs && (isSig && not (n `elem` typeSyns)))) names + self | not isSig && name `elem` kindSigs = [(name, True)] + | otherwise = [] + in (d, (name, isSig), self ++ deps) + dataVerts = fmap mkVert allDecls dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup let allIdents = fmap valdeclIdent values valueVerts = fmap (\d -> (d, valdeclIdent d, usedIdents moduleName d `intersect` allIdents)) values bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName) return $ filter isImportDecl ds ++ filter isRoleDecl ds ++ - filter isExternKindDecl ds ++ - filter isExternDataDecl ds ++ dataBindingGroupDecls ++ - filter isTypeClassDeclaration ds ++ - filter isTypeClassInstanceDeclaration ds ++ + filter isTypeClassInstanceDecl ds ++ filter isFixityDecl ds ++ filter isExternDecl ds ++ bindingGroupDecls @@ -135,23 +146,34 @@ usedImmediateIdents moduleName = usedNamesE scope _ = (scope, []) usedTypeNames :: ModuleName -> Declaration -> [ProperName 'TypeName] -usedTypeNames moduleName = - let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames) - in ordNub . f +usedTypeNames moduleName = go where + (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames) + + go :: Declaration -> [ProperName 'TypeName] + go decl = ordNub (f decl <> usedNamesForTypeClassDeps decl) + usedNames :: SourceType -> [ProperName 'TypeName] - usedNames (ConstrainedType _ con _) = - case con of - (Constraint _ (Qualified (Just moduleName') name) _ _) - | moduleName == moduleName' -> [coerceProperName name] - _ -> [] + usedNames (ConstrainedType _ con _) = usedConstraint con usedNames (TypeConstructor _ (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name] usedNames _ = [] + usedConstraint :: SourceConstraint -> [ProperName 'TypeName] + usedConstraint (Constraint _ (Qualified (Just moduleName') name) _ _ _) + | moduleName == moduleName' = [coerceProperName name] + usedConstraint _ = [] + + usedNamesForTypeClassDeps :: Declaration -> [ProperName 'TypeName] + usedNamesForTypeClassDeps (TypeClassDeclaration _ _ _ deps _ _) = foldMap usedConstraint deps + usedNamesForTypeClassDeps _ = [] + declTypeName :: Declaration -> ProperName 'TypeName declTypeName (DataDeclaration _ _ pn _ _) = pn +declTypeName (ExternDataDeclaration _ pn _) = pn declTypeName (TypeSynonymDeclaration _ pn _ _) = pn +declTypeName (TypeClassDeclaration _ pn _ _ _ _) = coerceProperName pn +declTypeName (KindDeclaration _ _ pn _) = pn declTypeName _ = internalError "Expected DataDeclaration" -- | @@ -200,7 +222,11 @@ toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of _ -> return d toDataBindingGroup (CyclicSCC ds') | all (isJust . isTypeSynonym) ds' = throwError . errorMessage' (declSourceSpan (head ds')) $ CycleInTypeSynonym Nothing + | kds@((ss, _):_) <- concatMap kindDecl ds' = throwError . errorMessage' ss . CycleInKindDeclaration $ fmap snd kds | otherwise = return . DataBindingGroupDeclaration $ NEL.fromList ds' + where + kindDecl (KindDeclaration sa _ pn _) = [(fst sa, Qualified Nothing pn)] + kindDecl _ = [] isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName) isTypeSynonym (TypeSynonymDeclaration _ pn _ _) = Just pn diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 0e4eb360e1..ae1c2de5e7 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -27,7 +27,6 @@ import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.Externs -import Language.PureScript.Kinds import Language.PureScript.Linter.Imports import Language.PureScript.Names import Language.PureScript.Sugar.Names.Env @@ -121,9 +120,6 @@ externsEnv env ExternsFile{..} = do exportedValueOps :: M.Map (OpName 'ValueOpName) ExportSource exportedValueOps = exportedRefs getValueOpRef - exportedKinds :: M.Map (ProperName 'KindName) ExportSource - exportedKinds = exportedRefs getKindRef - exportedRefs :: Ord a => (DeclarationRef -> Maybe a) -> M.Map a ExportSource exportedRefs f = M.fromList $ (, localExportSource) <$> mapMaybe f efExports @@ -145,7 +141,6 @@ elaborateExports exps (Module ss coms mn decls refs) = ++ go (TypeClassRef ss) exportedTypeClasses ++ go (ValueRef ss) exportedValues ++ go (ValueOpRef ss) exportedValueOps - ++ go (KindRef ss) exportedKinds ++ maybe [] (filter isModuleRef) refs where @@ -227,6 +222,10 @@ renameInModule imports (Module modSS coms mn decls exps) = <*> updateClassName cn ss <*> traverse updateTypesEverywhere ts <*> pure ds + updateDecl bound (KindDeclaration sa kindFor name ty) = + fmap (bound,) $ + KindDeclaration sa kindFor name + <$> updateTypesEverywhere ty updateDecl bound (TypeDeclaration (TypeDeclarationData sa name ty)) = fmap (bound,) $ TypeDeclaration . TypeDeclarationData sa name @@ -238,7 +237,7 @@ renameInModule imports (Module modSS coms mn decls exps) = updateDecl bound (ExternDataDeclaration sa name ki) = fmap (bound,) $ ExternDataDeclaration sa name - <$> updateKindsEverywhere ki + <$> updateTypesEverywhere ki updateDecl bound (TypeFixityDeclaration sa@(ss, _) fixity alias op) = fmap (bound,) $ TypeFixityDeclaration sa fixity @@ -316,17 +315,10 @@ renameInModule imports (Module modSS coms mn decls exps) = letBoundVariable :: Declaration -> Maybe Ident letBoundVariable = fmap valdeclIdent . getValueDeclaration - updateKindsEverywhere :: SourceKind -> m SourceKind - updateKindsEverywhere = everywhereOnKindsM updateKind - where - updateKind :: SourceKind -> m SourceKind - updateKind (NamedKind ann@(ss, _) name) = NamedKind ann <$> updateKindName name ss - updateKind k = return k - updateTypeArguments :: (Traversable f, Traversable g) - => f (a, g SourceKind) -> m (f (a, g SourceKind)) - updateTypeArguments = traverse (sndM (traverse updateKindsEverywhere)) + => f (a, g SourceType) -> m (f (a, g SourceType)) + updateTypeArguments = traverse (sndM (traverse updateTypesEverywhere)) updateTypesEverywhere :: SourceType -> m SourceType updateTypesEverywhere = everywhereOnTypesM updateType @@ -335,19 +327,16 @@ renameInModule imports (Module modSS coms mn decls exps) = updateType (TypeOp ann@(ss, _) name) = TypeOp ann <$> updateTypeOpName name ss updateType (TypeConstructor ann@(ss, _) name) = TypeConstructor ann <$> updateTypeName name ss updateType (ConstrainedType ann c t) = ConstrainedType ann <$> updateInConstraint c <*> pure t - updateType (ForAll ann v mbK t sco) = case mbK of - Nothing -> pure $ ForAll ann v Nothing t sco - Just k -> ForAll ann v <$> fmap pure (updateKindsEverywhere k) <*> pure t <*> pure sco - updateType (KindedType ann t k) = KindedType ann t <$> updateKindsEverywhere k updateType t = return t updateInConstraint :: SourceConstraint -> m SourceConstraint - updateInConstraint (Constraint ann@(ss, _) name ts info) = - Constraint ann <$> updateClassName name ss <*> pure ts <*> pure info + updateInConstraint (Constraint ann@(ss, _) name ks ts info) = + Constraint ann <$> updateClassName name ss <*> pure ks <*> pure ts <*> pure info updateConstraints :: SourceSpan -> [SourceConstraint] -> m [SourceConstraint] - updateConstraints pos = traverse $ \(Constraint ann name ts info) -> + updateConstraints pos = traverse $ \(Constraint ann name ks ts info) -> Constraint ann <$> updateClassName name pos + <*> traverse updateTypesEverywhere ks <*> traverse updateTypesEverywhere ts <*> pure info @@ -384,12 +373,6 @@ renameInModule imports (Module modSS coms mn decls exps) = -> m (Qualified (OpName 'ValueOpName)) updateValueOpName = update (importedValueOps imports) ValOpName - updateKindName - :: Qualified (ProperName 'KindName) - -> SourceSpan - -> m (Qualified (ProperName 'KindName)) - updateKindName = update (importedKinds imports) KiName - -- Update names so unqualified references become qualified, and locally -- qualified references are replaced with their canonical qualified names -- (e.g. M.Map -> Data.Map.Map). diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 55bd26c973..4471b13923 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -17,7 +17,6 @@ module Language.PureScript.Sugar.Names.Env , exportTypeClass , exportValue , exportValueOp - , exportKind , getExports , checkImportConflicts ) where @@ -112,7 +111,7 @@ data Imports = Imports -- | -- Local names for kinds within a module mapped to their qualified names -- - , importedKinds :: ImportMap (ProperName 'KindName) + , importedKinds :: ImportMap (ProperName 'TypeName) } deriving (Show) nullImports :: Imports @@ -145,17 +144,13 @@ data Exports = Exports -- from. -- , exportedValueOps :: M.Map (OpName 'ValueOpName) ExportSource - -- | - -- The exported kinds along with the module they originally came from. - -- - , exportedKinds :: M.Map (ProperName 'KindName) ExportSource } deriving (Show) -- | -- An empty 'Exports' value. -- nullExports :: Exports -nullExports = Exports M.empty M.empty M.empty M.empty M.empty M.empty +nullExports = Exports M.empty M.empty M.empty M.empty M.empty -- | -- The imports and exports for a collection of modules. The 'SourceSpan' is used @@ -186,49 +181,49 @@ envModuleExports (_, _, exps) = exps -- The exported types from the @Prim@ module -- primExports :: Exports -primExports = mkPrimExports primTypes primClasses primKinds +primExports = mkPrimExports primTypes primClasses -- | -- The exported types from the @Prim.Boolean@ module -- primBooleanExports :: Exports -primBooleanExports = mkPrimExports primBooleanTypes mempty primBooleanKinds +primBooleanExports = mkPrimExports primBooleanTypes mempty -- | -- The exported types from the @Prim.Coerce@ module -- primCoerceExports :: Exports -primCoerceExports = mkPrimExports primCoerceTypes primCoerceClasses mempty +primCoerceExports = mkPrimExports primCoerceTypes primCoerceClasses -- | -- The exported types from the @Prim.Ordering@ module -- primOrderingExports :: Exports -primOrderingExports = mkPrimExports primOrderingTypes mempty primOrderingKinds +primOrderingExports = mkPrimExports primOrderingTypes mempty -- | -- The exported types from the @Prim.Row@ module -- primRowExports :: Exports -primRowExports = mkPrimExports primRowTypes primRowClasses mempty +primRowExports = mkPrimExports primRowTypes primRowClasses -- | -- The exported types from the @Prim.RowList@ module -- primRowListExports :: Exports -primRowListExports = mkPrimExports primRowListTypes primRowListClasses primRowListKinds +primRowListExports = mkPrimExports primRowListTypes primRowListClasses -- | -- The exported types from the @Prim.Symbol@ module -- primSymbolExports :: Exports -primSymbolExports = mkPrimExports primSymbolTypes primSymbolClasses mempty +primSymbolExports = mkPrimExports primSymbolTypes primSymbolClasses -- | -- The exported types from the @Prim.TypeError@ module -- primTypeErrorExports :: Exports -primTypeErrorExports = mkPrimExports primTypeErrorTypes primTypeErrorClasses primTypeErrorKinds +primTypeErrorExports = mkPrimExports primTypeErrorTypes primTypeErrorClasses -- | -- Create a set of exports for a Prim module. @@ -236,18 +231,15 @@ primTypeErrorExports = mkPrimExports primTypeErrorTypes primTypeErrorClasses pri mkPrimExports :: M.Map (Qualified (ProperName 'TypeName)) a -> M.Map (Qualified (ProperName 'ClassName)) b - -> S.Set (Qualified (ProperName 'KindName)) -> Exports -mkPrimExports ts cs ks = +mkPrimExports ts cs = nullExports { exportedTypes = M.fromList $ mkTypeEntry `map` M.keys ts , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys cs - , exportedKinds = M.fromList $ mkKindEntry `map` S.toList ks } where mkTypeEntry (Qualified mn name) = (name, ([], primExportSource mn)) mkClassEntry (Qualified mn name) = (name, primExportSource mn) - mkKindEntry (Qualified mn name) = (name, primExportSource mn) primExportSource mn = ExportSource @@ -409,20 +401,6 @@ exportValueOp ss exps op src = do valueOps <- addExport ss ValOpName op src (exportedValueOps exps) return $ exps { exportedValueOps = valueOps } --- | --- Safely adds a kind to some exports, returning an error if a conflict occurs. --- -exportKind - :: MonadError MultipleErrors m - => SourceSpan - -> Exports - -> ProperName 'KindName - -> ExportSource - -> m Exports -exportKind ss exps name src = do - kinds <- addExport ss KiName name src (exportedKinds exps) - return $ exps { exportedKinds = kinds } - -- | -- Adds an entry to a list of exports unless it is already present, in which -- case an error is returned. diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 57fdb72f7f..c0236f05b9 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -59,8 +59,6 @@ findExportable (Module _ _ mn ds _) = exportTypeOp ss exps op source updateExports exps (ExternDeclaration (ss, _) name _) = exportValue ss exps name source - updateExports exps (ExternKindDeclaration (ss, _) pn) = - exportKind ss exps pn source updateExports exps _ = return exps -- | @@ -96,14 +94,12 @@ resolveExports env ss mn imps exps refs = let classes' = exportedTypeClasses result `M.union` exportedTypeClasses exps let values' = exportedValues result `M.union` exportedValues exps let valueOps' = exportedValueOps result `M.union` exportedValueOps exps - let kinds' = exportedKinds result `M.union` exportedKinds exps return result { exportedTypes = types' , exportedTypeOps = typeOps' , exportedTypeClasses = classes' , exportedValues = values' , exportedValueOps = valueOps' - , exportedKinds = kinds' } elaborateModuleExports result (ModuleRef ss' name) = do let isPseudo = isPseudoModule name @@ -115,13 +111,11 @@ resolveExports env ss mn imps exps refs = reClasses <- extract ss' isPseudo name TyClassName (importedTypeClasses imps) reValues <- extract ss' isPseudo name IdentName (importedValues imps) reValueOps <- extract ss' isPseudo name ValOpName (importedValueOps imps) - reKinds <- extract ss' isPseudo name KiName (importedKinds imps) foldM (\exps' ((tctor, dctors), src) -> exportType ss' ReExport exps' tctor dctors src) result (resolveTypeExports reTypes reDctors) >>= flip (foldM (uncurry . exportTypeOp ss')) (map resolveTypeOp reTypeOps) >>= flip (foldM (uncurry . exportTypeClass ss' ReExport)) (map resolveClass reClasses) >>= flip (foldM (uncurry . exportValue ss')) (map resolveValue reValues) >>= flip (foldM (uncurry . exportValueOp ss')) (map resolveValueOp reValueOps) - >>= flip (foldM (uncurry . exportKind ss')) (map resolveKind reKinds) elaborateModuleExports result _ = return result -- Extracts a list of values for a module based on a lookup table. If the @@ -215,13 +209,6 @@ resolveExports env ss mn imps exps refs = = fromMaybe (internalError "Missing value in resolveValueOp") $ resolve exportedValueOps op - -- Looks up an imported kind and re-qualifies it with the original - -- module it came from. - resolveKind :: Qualified (ProperName 'KindName) -> (ProperName 'KindName, ExportSource) - resolveKind kind - = fromMaybe (internalError "Missing value in resolveKind") - $ resolve exportedKinds kind - resolve :: Ord a => (Exports -> M.Map a ExportSource) @@ -250,14 +237,12 @@ filterModule mn exps refs = do classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) M.empty refs values <- foldM (filterExport IdentName getValueRef exportedValues) M.empty refs valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) M.empty refs - kinds <- foldM (filterExport KiName getKindRef exportedKinds) M.empty refs return Exports { exportedTypes = types , exportedTypeOps = typeOps , exportedTypeClasses = classes , exportedValues = values , exportedValueOps = valueOps - , exportedKinds = kinds } where diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index f4e52984bb..d82745bc37 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -123,8 +123,6 @@ resolveImport importModule exps imps impQual = resolveByType checkImportExists ss TyClassName (exportedTypeClasses exps) name check (ModuleRef ss name) | isHiding = throwError . errorMessage' ss $ ImportHidingModule name - check (KindRef ss name) = - checkImportExists ss KiName (exportedKinds exps) name check r = internalError $ "Invalid argument to checkRefs: " ++ show r -- Check that an explicitly imported item exists in the module it is being imported from @@ -176,7 +174,6 @@ resolveImport importModule exps imps impQual = resolveByType >>= flip (foldM (\m (name, _) -> importer m (ValueRef ss name))) (M.toList (exportedValues exps)) >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef ss name))) (M.toList (exportedValueOps exps)) >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef ss name))) (M.toList (exportedTypeClasses exps)) - >>= flip (foldM (\m (name, _) -> importer m (KindRef ss name))) (M.toList (exportedKinds exps)) importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports importRef prov imp (ValueRef ss name) = do @@ -199,9 +196,6 @@ resolveImport importModule exps imps impQual = resolveByType importRef prov imp (TypeClassRef ss name) = do let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) id name ss prov return $ imp { importedTypeClasses = typeClasses' } - importRef prov imp (KindRef ss name) = do - let kinds' = updateImports (importedKinds imp) (exportedKinds exps) id name ss prov - return $ imp { importedKinds = kinds' } importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef" importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef" importRef _ _ ReExportRef{} = internalError "ReExportRef in importRef" diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 1e0f6b9775..d79e88a070 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -335,9 +335,10 @@ updateTypes goType = (goDecl, goExpr, goBinder) goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (pos, e) - goExpr pos (TypeClassDictionary (Constraint ann name tys info) dicts hints) = do + goExpr pos (TypeClassDictionary (Constraint ann name kinds tys info) dicts hints) = do + kinds' <- traverse (goType' pos) kinds tys' <- traverse (goType' pos) tys - return (pos, TypeClassDictionary (Constraint ann name tys' info) dicts hints) + return (pos, TypeClassDictionary (Constraint ann name kinds' tys' info) dicts hints) goExpr pos (DeferredDictionary cls tys) = do tys' <- traverse (goType' pos) tys return (pos, DeferredDictionary cls tys') diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index af71afc9e7..6850dac0ba 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -26,7 +26,6 @@ import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors hiding (isExported) import Language.PureScript.Externs -import Language.PureScript.Kinds import Language.PureScript.Label (Label(..)) import Language.PureScript.Names import Language.PureScript.PSString (mkString) @@ -74,7 +73,7 @@ desugarModule => Module -> Desugar m Module desugarModule (Module ss coms name decls (Just exps)) = do - let (classDecls, restDecls) = partition isTypeClassDeclaration decls + let (classDecls, restDecls) = partition isTypeClassDecl decls classVerts = fmap (\d -> (d, classDeclName d, superClassesNames d)) classDecls (classNewExpss, classDeclss) <- unzip <$> parU (stronglyConnComp classVerts) (desugarClassDecl name exps) (restNewExpss, restDeclss) <- unzip <$> parU restDecls (desugarDecl name exps) @@ -93,7 +92,7 @@ desugarModule (Module ss coms name decls (Just exps)) = do superClassesNames _ = [] constraintName :: SourceConstraint -> Qualified (ProperName 'ClassName) - constraintName (Constraint _ cName _ _) = cName + constraintName (Constraint _ cName _ _ _) = cName classDeclName :: Declaration -> Qualified (ProperName 'ClassName) classDeclName (TypeClassDeclaration _ pn _ _ _ _) = Qualified (Just name) pn @@ -212,7 +211,7 @@ desugarDecl mn exps = go dictDecl <- typeInstanceDictionaryDeclaration sa name mn deps className tys desugared return (expRef name className tys, [d, dictDecl]) go d@(TypeInstanceDeclaration sa _ _ name deps className tys (NewtypeInstanceWithDictionary dict)) = do - let dictTy = foldl srcTypeApp (srcTypeConstructor (fmap coerceProperName className)) tys + let dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictSynonymName) className)) tys constrainedTy = quantify (foldr (srcConstrainedType) dictTy deps) return (expRef name className tys, [d, ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) go other = return (Nothing, [other]) @@ -255,24 +254,24 @@ memberToNameAndType _ = internalError "Invalid declaration in type class definit typeClassDictionaryDeclaration :: SourceAnn -> ProperName 'ClassName - -> [(Text, Maybe SourceKind)] + -> [(Text, Maybe SourceType)] -> [SourceConstraint] -> [Declaration] -> Declaration typeClassDictionaryDeclaration sa name args implies members = let superclassTypes = superClassDictionaryNames implies `zip` - [ function unit (foldl srcTypeApp (srcTypeConstructor (fmap coerceProperName superclass)) tyArgs) - | (Constraint _ superclass tyArgs _) <- implies + [ function unit (foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictSynonymName) superclass)) tyArgs) + | (Constraint _ superclass _ tyArgs _) <- implies ] members' = map (first runIdent . memberToNameAndType) members mtys = members' ++ superclassTypes toRowListItem (l, t) = srcRowListItem (Label $ mkString l) t - in TypeSynonymDeclaration sa (coerceProperName name) args (srcTypeApp tyRecord $ rowFromList (map toRowListItem mtys, srcREmpty)) + in TypeSynonymDeclaration sa (coerceProperName $ dictSynonymName name) args (srcTypeApp tyRecord $ rowFromList (map toRowListItem mtys, srcREmpty)) typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName 'ClassName - -> [(Text, Maybe SourceKind)] + -> [(Text, Maybe SourceType)] -> Declaration -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarationData sa ident ty)) = @@ -280,7 +279,7 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarati in ValueDecl sa ident Private [] $ [MkUnguarded ( TypedValue False (TypeClassDictionaryAccessor className ident) $ - moveQuantifiersToFront (quantify (srcConstrainedType (srcConstraint className (map (srcTypeVar . fst) args) Nothing) ty)) + moveQuantifiersToFront (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty)) )] typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" @@ -323,12 +322,12 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = -- The dictionary itself is a record literal. let superclasses = superClassDictionaryNames typeClassSuperclasses `zip` [ Abs (VarBinder ss UnusedIdent) (DeferredDictionary superclass tyArgs) - | (Constraint _ superclass suTyArgs _) <- typeClassSuperclasses + | (Constraint _ superclass _ suTyArgs _) <- typeClassSuperclasses , let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs ] let props = Literal ss $ ObjectLiteral $ map (first mkString) (members ++ superclasses) - dictTy = foldl srcTypeApp (srcTypeConstructor (fmap coerceProperName className)) tys + dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictSynonymName) className)) tys constrainedTy = quantify (foldr srcConstrainedType dictTy deps) dict = TypeClassDictionaryConstructorApp className props result = ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)] @@ -353,5 +352,5 @@ typeClassMemberName = fromMaybe (internalError "typeClassMemberName: Invalid dec superClassDictionaryNames :: [Constraint a] -> [Text] superClassDictionaryNames supers = [ superclassName pn index - | (index, Constraint _ pn _ _) <- zip [0..] supers + | (index, Constraint _ pn _ _ _) <- zip [0..] supers ] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 9cb3f9f42e..bd6cf26530 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -23,13 +23,12 @@ import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Externs -import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Label (Label(..)) import Language.PureScript.PSString (mkString) import Language.PureScript.Types import Language.PureScript.TypeChecker (checkNewtype) -import Language.PureScript.TypeChecker.Synonyms (SynonymMap, replaceAllTypeSynonymsM) +import Language.PureScript.TypeChecker.Synonyms (SynonymMap, KindMap, replaceAllTypeSynonymsM) -- | When deriving an instance for a newtype, we must ensure that all superclass -- instances were derived in the same way. This data structure is used to ensure @@ -73,8 +72,11 @@ deriveInstances -> Module -> m Module deriveInstances externs (Module ss coms mn ds exts) = - Module ss coms mn <$> mapM (deriveInstance mn synonyms instanceData ds) ds <*> pure exts + Module ss coms mn <$> mapM (deriveInstance mn synonyms kinds instanceData ds) ds <*> pure exts where + kinds :: KindMap + kinds = mempty + -- We need to collect type synonym information, since synonyms will not be -- removed until later, during type checking. synonyms :: SynonymMap @@ -111,16 +113,17 @@ deriveInstance :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => ModuleName -> SynonymMap + -> KindMap -> NewtypeDerivedInstances -> [Declaration] -> Declaration -> m Declaration -deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys DerivedInstance) +deriveInstance mn syns kinds _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys DerivedInstance) | className == Qualified (Just dataEq) (ProperName "Eq") = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveEq ss mn syns ds tyCon + -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveEq ss mn syns kinds ds tyCon | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataEq) (ProperName "Eq1") @@ -134,7 +137,7 @@ deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps c = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveOrd ss mn syns ds tyCon + -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveOrd ss mn syns kinds ds tyCon | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataOrd) (ProperName "Ord1") @@ -148,7 +151,7 @@ deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps c = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveFunctor ss mn syns ds tyCon + -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveFunctor ss mn syns kinds ds tyCon | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataNewtype) (ProperName "Newtype") @@ -156,7 +159,7 @@ deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps c [wrappedTy, unwrappedTy] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy , mn == fromMaybe mn mn' - -> do (inst, actualUnwrappedTy) <- deriveNewtype ss mn syns ds tyCon args unwrappedTy + -> do (inst, actualUnwrappedTy) <- deriveNewtype ss mn syns kinds ds tyCon args unwrappedTy return $ TypeInstanceDeclaration sa ch idx nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys wrappedTy _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 @@ -165,19 +168,19 @@ deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps c [actualTy, repTy] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy , mn == fromMaybe mn mn' - -> do (inst, inferredRepTy) <- deriveGenericRep ss mn syns ds tyCon args repTy + -> do (inst, inferredRepTy) <- deriveGenericRep ss mn syns kinds ds tyCon args repTy return $ TypeInstanceDeclaration sa ch idx nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys actualTy _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 | otherwise = throwError . errorMessage' ss $ CannotDerive className tys -deriveInstance mn syns ndis ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys NewtypeInstance) = +deriveInstance mn syns kinds ndis ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys NewtypeInstance) = case tys of _ : _ | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys) , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa ch idx nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance ss mn syns ndis className ds tys tyCon args + -> TypeInstanceDeclaration sa ch idx nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance ss mn syns kinds ndis className ds tys tyCon args | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys (last tys) _ -> throwError . errorMessage' ss $ InvalidNewtypeInstance className tys -deriveInstance _ _ _ _ e = return e +deriveInstance _ _ _ _ _ e = return e unwrapTypeConstructor :: SourceType -> Maybe (Qualified (ProperName 'TypeName), [SourceType]) unwrapTypeConstructor = fmap (second reverse) . go @@ -194,6 +197,7 @@ deriveNewtypeInstance => SourceSpan -> ModuleName -> SynonymMap + -> KindMap -> NewtypeDerivedInstances -> Qualified (ProperName 'ClassName) -> [Declaration] @@ -201,7 +205,7 @@ deriveNewtypeInstance -> ProperName 'TypeName -> [SourceType] -> m Expr -deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do +deriveNewtypeInstance ss mn syns kinds ndis className ds tys tyConNm dargs = do verifySuperclasses tyCon <- findTypeDecl ss tyConNm ds go tyCon @@ -216,7 +220,7 @@ deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do -- -- since Array a is a type application which uses the last -- type argument - wrapped' <- replaceAllTypeSynonymsM syns wrapped + wrapped' <- replaceAllTypeSynonymsM syns kinds wrapped case stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped' of Just wrapped'' -> do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs @@ -282,12 +286,13 @@ deriveGenericRep => SourceSpan -> ModuleName -> SynonymMap + -> KindMap -> [Declaration] -> ProperName 'TypeName -> [SourceType] -> SourceType -> m ([Declaration], SourceType) -deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do +deriveGenericRep ss mn syns kinds ds tyConNm tyConArgs repTy = do checkIsWildcard ss tyConNm repTy go =<< findTypeDecl ss tyConNm ds where @@ -341,7 +346,7 @@ deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do :: DataConstructorDeclaration -> m (SourceType, CaseAlternative, CaseAlternative) makeInst (DataConstructorDeclaration _ ctorName args) = do - args' <- mapM (replaceAllTypeSynonymsM syns . snd) args + args' <- mapM (replaceAllTypeSynonymsM syns kinds . snd) args (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args' return ( srcTypeApp (srcTypeApp (srcTypeConstructor constructor) (srcTypeLevelString $ mkString (runProperName ctorName))) @@ -438,10 +443,11 @@ deriveEq => SourceSpan -> ModuleName -> SynonymMap + -> KindMap -> [Declaration] -> ProperName 'TypeName -> m [Declaration] -deriveEq ss mn syns ds tyConNm = do +deriveEq ss mn syns kinds ds tyConNm = do tyCon <- findTypeDecl ss tyConNm ds eqFun <- mkEqFunction tyCon return [ ValueDecl (ss, []) (Ident C.eq) Public [] (unguarded eqFun) ] @@ -473,7 +479,7 @@ deriveEq ss mn syns ds tyConNm = do mkCtorClause (DataConstructorDeclaration _ ctorName tys) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") - tys' <- mapM (replaceAllTypeSynonymsM syns . snd) tys + tys' <- mapM (replaceAllTypeSynonymsM syns kinds . snd) tys let tests = zipWith3 toEqTest (map (Var ss . Qualified Nothing) identsL) (map (Var ss . Qualified Nothing) identsR) tys' return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (unguarded (conjAll tests)) where @@ -506,10 +512,11 @@ deriveOrd => SourceSpan -> ModuleName -> SynonymMap + -> KindMap -> [Declaration] -> ProperName 'TypeName -> m [Declaration] -deriveOrd ss mn syns ds tyConNm = do +deriveOrd ss mn syns kinds ds tyConNm = do tyCon <- findTypeDecl ss tyConNm ds compareFun <- mkCompareFunction tyCon return [ ValueDecl (ss, []) (Ident C.compare) Public [] (unguarded compareFun) ] @@ -552,7 +559,7 @@ deriveOrd ss mn syns ds tyConNm = do mkCtorClauses ((DataConstructorDeclaration _ ctorName tys), isLast) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") - tys' <- mapM (replaceAllTypeSynonymsM syns . snd) tys + tys' <- mapM (replaceAllTypeSynonymsM syns kinds . snd) tys let tests = zipWith3 toOrdering (map (Var ss . Qualified Nothing) identsL) (map (Var ss . Qualified Nothing) identsR) tys' extras | not isLast = [ CaseAlternative [ ConstructorBinder ss (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) , NullBinder @@ -607,12 +614,13 @@ deriveNewtype => SourceSpan -> ModuleName -> SynonymMap + -> KindMap -> [Declaration] -> ProperName 'TypeName -> [SourceType] -> SourceType -> m ([Declaration], SourceType) -deriveNewtype ss mn syns ds tyConNm tyConArgs unwrappedTy = do +deriveNewtype ss mn syns kinds ds tyConNm tyConArgs unwrappedTy = do checkIsWildcard ss tyConNm unwrappedTy go =<< findTypeDecl ss tyConNm ds where @@ -624,7 +632,7 @@ deriveNewtype ss mn syns ds tyConNm tyConArgs unwrappedTy = do wrappedIdent <- freshIdent "n" unwrappedIdent <- freshIdent "a" let (DataConstructorDeclaration _ ctorName [(_, ty)]) = head dctors - ty' <- replaceAllTypeSynonymsM syns ty + ty' <- replaceAllTypeSynonymsM syns kinds ty let inst = [ ValueDecl (ss', []) (Ident "wrap") Public [] $ unguarded $ Constructor ss' (Qualified (Just mn) ctorName) @@ -677,7 +685,7 @@ objectType _ = Nothing decomposeRec :: SourceType -> Maybe [(Label, SourceType)] decomposeRec = fmap (sortBy (comparing fst)) . go where go (RCons _ str typ typs) = fmap ((str, typ) :) (go typs) - go (REmpty _) = Just [] + go (REmptyKinded _ _) = Just [] go _ = Nothing decomposeRec' :: SourceType -> [(Label, SourceType)] @@ -691,17 +699,18 @@ deriveFunctor => SourceSpan -> ModuleName -> SynonymMap + -> KindMap -> [Declaration] -> ProperName 'TypeName -> m [Declaration] -deriveFunctor ss mn syns ds tyConNm = do +deriveFunctor ss mn syns kinds ds tyConNm = do tyCon <- findTypeDecl ss tyConNm ds mapFun <- mkMapFunction tyCon return [ ValueDecl (ss, []) (Ident C.map) Public [] (unguarded mapFun) ] where mkMapFunction :: Declaration -> m Expr mkMapFunction (DataDeclaration (ss', _) _ _ tys ctors) = case reverse tys of - [] -> throwError . errorMessage' ss' $ KindsDoNotUnify (FunKind nullSourceAnn kindType kindType) kindType + [] -> throwError . errorMessage' ss' $ KindsDoNotUnify (kindType -:> kindType) kindType ((iTy, _) : _) -> do f <- freshIdent "f" m <- freshIdent "m" @@ -711,7 +720,7 @@ deriveFunctor ss mn syns ds tyConNm = do mkCtorClause :: Text -> Ident -> DataConstructorDeclaration -> m CaseAlternative mkCtorClause iTyName f (DataConstructorDeclaration _ ctorName ctorTys) = do idents <- replicateM (length ctorTys) (freshIdent "v") - ctorTys' <- mapM (replaceAllTypeSynonymsM syns . snd) ctorTys + ctorTys' <- mapM (replaceAllTypeSynonymsM syns kinds . snd) ctorTys args <- zipWithM transformArg idents ctorTys' let ctor = Constructor ss (Qualified (Just mn) ctorName) rebuilt = foldl' App ctor args diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 37e8d1b3cc..709eafec8b 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -8,6 +8,7 @@ module Language.PureScript.Sugar.TypeDeclarations import Prelude.Compat +import Control.Monad (unless) import Control.Monad.Error.Class (MonadError(..)) import Language.PureScript.AST @@ -24,7 +25,8 @@ desugarTypeDeclarationsModule => Module -> m Module desugarTypeDeclarationsModule (Module modSS coms name ds exps) = - rethrow (addHint (ErrorInModule name)) $ + rethrow (addHint (ErrorInModule name)) $ do + checkKindDeclarations ds Module modSS coms name <$> desugarTypeDeclarations ds <*> pure exps where @@ -53,3 +55,19 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) = <*> desugarTypeDeclarations rest desugarTypeDeclarations (d:rest) = (:) d <$> desugarTypeDeclarations rest desugarTypeDeclarations [] = return [] + + checkKindDeclarations :: [Declaration] -> m () + checkKindDeclarations (KindDeclaration sa kindFor name' _ : d : rest) = do + unless (matchesDeclaration d) . throwError . errorMessage' (fst sa) $ OrphanKindDeclaration name' + checkKindDeclarations rest + where + matchesDeclaration :: Declaration -> Bool + matchesDeclaration (DataDeclaration _ Data name'' _ _) = kindFor == DataSig && name' == name'' + matchesDeclaration (DataDeclaration _ Newtype name'' _ _) = kindFor == NewtypeSig && name' == name'' + matchesDeclaration (TypeSynonymDeclaration _ name'' _ _) = kindFor == TypeSynonymSig && name' == name'' + matchesDeclaration (TypeClassDeclaration _ name'' _ _ _ _) = kindFor == ClassSig && name' == coerceProperName name'' + matchesDeclaration _ = False + checkKindDeclarations (KindDeclaration sa _ name' _ : _) = do + throwError . errorMessage' (fst sa) $ OrphanKindDeclaration name' + checkKindDeclarations (_ : rest) = checkKindDeclarations rest + checkKindDeclarations [] = return () diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index f0e90f7b60..36a616b330 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -10,9 +10,9 @@ module Language.PureScript.TypeChecker ) where import Prelude.Compat -import Protolude (ordNub) +import Protolude (headMay, ordNub) -import Control.Monad (when, unless, void, forM) +import Control.Monad (when, unless, void, forM,) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), modify, gets) import Control.Monad.Supply.Class (MonadSupply) @@ -31,7 +31,6 @@ import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors -import Language.PureScript.Kinds import Language.PureScript.Linter import Language.PureScript.Names import Language.PureScript.Roles @@ -39,44 +38,46 @@ import Language.PureScript.TypeChecker.Kinds as T import Language.PureScript.TypeChecker.Monad as T import Language.PureScript.TypeChecker.Synonyms as T import Language.PureScript.TypeChecker.Types as T +import Language.PureScript.TypeChecker.Unify (varIfUnknown) import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types -import Lens.Micro.Platform ((^..), _2, _3) +import Lens.Micro.Platform ((^..), _2) addDataType :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> DataDeclType -> ProperName 'TypeName - -> [(Text, Maybe SourceKind)] - -> [DataConstructorDeclaration] - -> SourceKind + -> [(Text, Maybe SourceType)] + -> [(DataConstructorDeclaration, SourceType)] + -> SourceType -> m () addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv let mapDataCtor (DataConstructorDeclaration _ ctorName vars) = (ctorName, snd <$> vars) - putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args (map mapDataCtor dctors)) (types env) } - for_ dctors $ \(DataConstructorDeclaration _ dctor fields) -> + qualName = (Qualified (Just moduleName) name) + hasSig = qualName `M.member` types env + putEnv $ env { types = M.insert qualName (ctorKind, DataType args (map (mapDataCtor . fst) dctors)) (types env) } + unless (hasSig || not (containsForAll ctorKind)) $ do + tell . errorMessage $ MissingKindDeclaration (if dtype == Newtype then NewtypeSig else DataSig) name ctorKind + for_ dctors $ \(DataConstructorDeclaration _ dctor fields, polyType) -> warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $ - addDataConstructor moduleName dtype name (map fst args) dctor fields + addDataConstructor moduleName dtype name dctor fields polyType addDataConstructor :: (MonadState CheckState m, MonadError MultipleErrors m) => ModuleName -> DataDeclType -> ProperName 'TypeName - -> [Text] -> ProperName 'ConstructorName -> [(Ident, SourceType)] + -> SourceType -> m () -addDataConstructor moduleName dtype name args dctor dctorArgs = do - let (fields, tys) = unzip dctorArgs +addDataConstructor moduleName dtype name dctor dctorArgs polyType = do + let fields = fst <$> dctorArgs env <- getEnv - traverse_ checkTypeSynonyms tys - let retTy = foldl srcTypeApp (srcTypeConstructor (Qualified (Just moduleName) name)) (map srcTypeVar args) - let dctorTy = foldr function retTy tys - let polyType = mkForAll (map (\i -> (NullSourceAnn, (i, Nothing))) args) dctorTy + checkTypeSynonyms polyType putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } addRoleDeclaration @@ -90,18 +91,22 @@ addRoleDeclaration moduleName name roles = do putEnv $ env { roleDeclarations = M.insert (Qualified (Just moduleName) name) roles (roleDeclarations env) } addTypeSynonym - :: (MonadState CheckState m, MonadError MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName -> ProperName 'TypeName - -> [(Text, Maybe SourceKind)] + -> [(Text, Maybe SourceType)] + -> SourceType -> SourceType - -> SourceKind -> m () addTypeSynonym moduleName name args ty kind = do env <- getEnv checkTypeSynonyms ty - putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env) - , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) } + let qualName = (Qualified (Just moduleName) name) + hasSig = qualName `M.member` types env + unless (hasSig || isDictSynonym name || not (containsForAll kind)) $ do + tell . errorMessage $ MissingKindDeclaration TypeSynonymSig name kind + putEnv $ env { types = M.insert qualName (kind, TypeSynonym) (types env) + , typeSynonyms = M.insert qualName (args, ty) (typeSynonyms env) } valueIsNotDefined :: (MonadState CheckState m, MonadError MultipleErrors m) @@ -127,18 +132,25 @@ addValue moduleName name ty nameKind = do addTypeClass :: forall m - . (MonadState CheckState m, MonadError MultipleErrors m) - => Qualified (ProperName 'ClassName) - -> [(Text, Maybe SourceKind)] + . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => ModuleName + -> Qualified (ProperName 'ClassName) + -> [(Text, Maybe SourceType)] -> [SourceConstraint] -> [FunctionalDependency] -> [Declaration] + -> SourceType -> m () -addTypeClass qualifiedClassName args implies dependencies ds = do +addTypeClass _ qualifiedClassName args implies dependencies ds kind = do env <- getEnv let newClass = mkNewClass env - traverse_ (checkMemberIsUsable newClass (typeSynonyms env)) classMembers - modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert qualifiedClassName newClass (typeClasses . checkEnv $ st) } } + qualName = fmap coerceProperName qualifiedClassName + hasSig = qualName `M.member` types env + unless (hasSig || not (containsForAll kind)) $ do + tell . errorMessage $ MissingKindDeclaration ClassSig (disqualify qualName) kind + traverse_ (checkMemberIsUsable newClass (typeSynonyms env) (types env)) classMembers + putEnv $ env { types = M.insert qualName (kind, ExternData) (types env) + , typeClasses = M.insert qualifiedClassName newClass (typeClasses env) } where classMembers :: [(Ident, SourceType)] classMembers = map toPair ds @@ -163,9 +175,9 @@ addTypeClass qualifiedClassName args implies dependencies ds = do -- Currently we are only checking usability based on the type class currently -- being defined. If the mentioned arguments don't include a covering set, -- then we won't be able to find a instance. - checkMemberIsUsable :: TypeClassData -> T.SynonymMap -> (Ident, SourceType) -> m () - checkMemberIsUsable newClass syns (ident, memberTy) = do - memberTy' <- T.replaceAllTypeSynonymsM syns memberTy + checkMemberIsUsable :: TypeClassData -> T.SynonymMap -> T.KindMap -> (Ident, SourceType) -> m () + checkMemberIsUsable newClass syns kinds (ident, memberTy) = do + memberTy' <- T.replaceAllTypeSynonymsM syns kinds memberTy let mentionedArgIndexes = S.fromList (mapMaybe argToIndex (freeTypeVariables memberTy')) let leftovers = map (`S.difference` mentionedArgIndexes) (coveringSets newClass) @@ -214,6 +226,8 @@ checkTypeClassInstance cls i = check where when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance return () TypeApp _ t1 t2 -> check t1 >> check t2 + KindApp _ t k -> check t >> check k + KindedType _ t _ -> check t REmpty _ | isFunDepDetermined -> return () RCons _ _ hd tl | isFunDepDetermined -> check hd >> check tl ty -> throwError . errorMessage $ InvalidInstanceHead ty @@ -254,40 +268,55 @@ typeCheckAll moduleName _ = traverse go warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (positionedError ss)) $ do when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args - ctorKind <- kindsOf True moduleName name args (concatMap (fmap snd . dataCtorFields) dctors) + (dataCtors, ctorKind) <- kindOfData moduleName (sa, name, args, dctors) let args' = args `withKinds` ctorKind - addDataType moduleName dtype name args' dctors ctorKind + addDataType moduleName dtype name args' dataCtors ctorKind return $ DataDeclaration sa dtype name args dctors go (d@(DataBindingGroupDeclaration tys)) = do let tysList = NEL.toList tys syns = mapMaybe toTypeSynonym tysList dataDecls = mapMaybe toDataDecl tysList - bindingGroupNames = ordNub ((syns^..traverse._2) ++ (dataDecls^..traverse._3)) + clss = mapMaybe toClassDecl tysList + bindingGroupNames = ordNub ((syns^..traverse._2) ++ (dataDecls^..traverse._2._2) ++ (fmap coerceProperName (clss^..traverse._2._2))) sss = fmap declSourceSpan tys warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames) . addHint (PositionedError sss)) $ do - (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(sa, _, name, args, dctors) -> (sa, name, args, concatMap (fmap snd . dataCtorFields) dctors)) dataDecls) - for_ (zip dataDecls data_ks) $ \((_, dtype, name, args, dctors), ctorKind) -> do + (syn_ks, data_ks, cls_ks) <- kindsOfAll moduleName syns (fmap snd dataDecls) (fmap snd clss) + for_ (zip dataDecls data_ks) $ \((dtype, (_, name, args, dctors)), (dataCtors, ctorKind)) -> do when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args let args' = args `withKinds` ctorKind - addDataType moduleName dtype name args' dctors ctorKind - for_ (zip syns syn_ks) $ \((_, name, args, ty), kind) -> do + addDataType moduleName dtype name args' dataCtors ctorKind + for_ (zip syns syn_ks) $ \((_, name, args, _), (elabTy, kind)) -> do checkDuplicateTypeArguments $ map fst args let args' = args `withKinds` kind - addTypeSynonym moduleName name args' ty kind + addTypeSynonym moduleName name args' elabTy kind + for_ (zip clss cls_ks) $ \((deps, (sa, pn, _, _, _)), (args', implies', tys', kind)) -> do + env <- getEnv + let qualifiedClassName = Qualified (Just moduleName) pn + guardWith (errorMessage (DuplicateTypeClass pn (fst sa))) $ + not (M.member qualifiedClassName (typeClasses env)) + addTypeClass moduleName qualifiedClassName (fmap Just <$> args') implies' deps tys' kind return d where toTypeSynonym (TypeSynonymDeclaration sa nm args ty) = Just (sa, nm, args, ty) toTypeSynonym _ = Nothing - toDataDecl (DataDeclaration sa dtype nm args dctors) = Just (sa, dtype, nm, args, dctors) + toDataDecl (DataDeclaration sa dtype nm args dctors) = Just (dtype, (sa, nm, args, dctors)) toDataDecl _ = Nothing + toClassDecl (TypeClassDeclaration sa nm args implies deps decls) = Just (deps, (sa, nm, args, implies, decls)) + toClassDecl _ = Nothing go (TypeSynonymDeclaration sa@(ss, _) name args ty) = do warnAndRethrow (addHint (ErrorInTypeSynonym name) . addHint (positionedError ss) ) $ do checkDuplicateTypeArguments $ map fst args - kind <- kindsOf False moduleName name args [ty] + (elabTy, kind) <- kindOfTypeSynonym moduleName (sa, name, args, ty) let args' = args `withKinds` kind - addTypeSynonym moduleName name args' ty kind + addTypeSynonym moduleName name args' elabTy kind return $ TypeSynonymDeclaration sa name args ty + go (KindDeclaration sa@(ss, _) kindFor name ty) = do + warnAndRethrow (addHint (ErrorInKindDeclaration name) . addHint (positionedError ss)) $ do + elabTy <- withFreshSubstitution $ checkKindDeclaration moduleName ty + env <- getEnv + putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (elabTy, LocalTypeVariable) (types env) } + return $ KindDeclaration sa kindFor name elabTy go d@(RoleDeclaration (RoleDeclarationData _sa name roles)) = do addRoleDeclaration moduleName name roles return d @@ -303,7 +332,6 @@ typeCheckAll moduleName _ = traverse go addValue moduleName name ty nameKind return $ ValueDecl sa name nameKind [] [MkUnguarded val''] _ -> internalError "typesOf did not return a singleton" - where go ValueDeclaration{} = internalError "Binders were not desugared" go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared" go (BindingGroupDeclaration vals) = do @@ -322,33 +350,33 @@ typeCheckAll moduleName _ = traverse go return (sai, nameKind, val) return . BindingGroupDeclaration $ NEL.fromList vals'' go (d@(ExternDataDeclaration _ name kind)) = do + elabKind <- withFreshSubstitution $ checkKindDeclaration moduleName kind env <- getEnv - putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) } - return d - go (d@(ExternKindDeclaration _ name)) = do - env <- getEnv - putEnv $ env { kinds = S.insert (Qualified (Just moduleName) name) (kinds env) } + putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (elabKind, ExternData) (types env) } return d go (d@(ExternDeclaration (ss, _) name ty)) = do warnAndRethrow (addHint (ErrorInForeignImport name) . addHint (positionedError ss)) $ do env <- getEnv - kind <- kindOf ty - guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType + (elabTy, kind) <- withFreshSubstitution $ do + ((unks, ty'), kind) <- kindOfWithUnknowns ty + pure (varIfUnknown unks ty', kind) + checkTypeKind elabTy kind case M.lookup (Qualified (Just moduleName) name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name - Nothing -> putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, External, Defined) (names env) }) + Nothing -> putEnv (env { names = M.insert (Qualified (Just moduleName) name) (elabTy, External, Defined) (names env) }) return d go d@FixityDeclaration{} = return d go d@ImportDeclaration{} = return d - go d@(TypeClassDeclaration (ss, _) pn args implies deps tys) = do + go d@(TypeClassDeclaration sa@(ss, _) pn args implies deps tys) = do warnAndRethrow (addHint (ErrorInTypeClassDeclaration pn) . addHint (positionedError ss)) $ do env <- getEnv let qualifiedClassName = Qualified (Just moduleName) pn guardWith (errorMessage (DuplicateTypeClass pn ss)) $ not (M.member qualifiedClassName (typeClasses env)) - addTypeClass qualifiedClassName args implies deps tys + (args', implies', tys', kind) <- kindOfClass moduleName (sa, pn, args, implies, tys) + addTypeClass moduleName qualifiedClassName (fmap Just <$> args') implies' deps tys' kind return d - go (d@(TypeInstanceDeclaration (ss, _) ch idx dictName deps className tys body)) = + go (d@(TypeInstanceDeclaration sa@(ss, _) ch idx dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys) . addHint (positionedError ss)) $ do env <- getEnv let qualifiedDictName = Qualified (Just moduleName) dictName @@ -359,14 +387,15 @@ typeCheckAll moduleName _ = traverse go Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" Just typeClass -> do checkInstanceArity dictName className typeClass tys - sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys) - let nonOrphanModules = findNonOrphanModules className typeClass tys - checkOrphanInstance dictName className tys nonOrphanModules + (deps', kinds', tys', vars) <- withFreshSubstitution $ checkInstanceDeclaration moduleName (sa, deps, className, tys) + sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys') + let nonOrphanModules = findNonOrphanModules className typeClass tys' + checkOrphanInstance dictName className tys' nonOrphanModules let qualifiedChain = Qualified (Just moduleName) <$> ch - checkOverlappingInstance qualifiedChain dictName className typeClass tys nonOrphanModules + checkOverlappingInstance qualifiedChain dictName className typeClass tys' nonOrphanModules _ <- traverseTypeInstanceBody checkInstanceMembers body - deps' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps - let dict = TypeClassDictionaryInScope qualifiedChain idx qualifiedDictName [] className tys (Just deps') + deps'' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps' + let dict = TypeClassDictionaryInScope qualifiedChain idx qualifiedDictName [] className vars kinds' tys' (Just deps'') addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict) return d @@ -410,6 +439,8 @@ typeCheckAll moduleName _ = traverse go typeModule (TypeConstructor _ (Qualified (Just mn'') _)) = Just mn'' typeModule (TypeConstructor _ (Qualified Nothing _)) = internalError "Unqualified type name in findNonOrphanModules" typeModule (TypeApp _ t1 _) = typeModule t1 + typeModule (KindApp _ t1 _) = typeModule t1 + typeModule (KindedType _ t1 _) = typeModule t1 typeModule _ = internalError "Invalid type in instance in findNonOrphanModules" modulesByTypeIndex :: M.Map Int (Maybe ModuleName) @@ -507,11 +538,12 @@ typeCheckAll moduleName _ = traverse go -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, -- extracted from the kind of the type constructor itself. -- - withKinds :: [(Text, Maybe SourceKind)] -> SourceKind -> [(Text, Maybe SourceKind)] - withKinds [] _ = [] - withKinds (s@(_, Just _ ):ss) (FunKind _ _ k) = s : withKinds ss k - withKinds ( (s, Nothing):ss) (FunKind _ k1 k2) = (s, Just k1) : withKinds ss k2 - withKinds _ _ = internalError "Invalid arguments to peelKinds" + withKinds :: [(Text, Maybe SourceType)] -> SourceType -> [(Text, Maybe SourceType)] + withKinds [] _ = [] + withKinds ss (ForAll _ _ _ k _) = withKinds ss k + withKinds (s@(_, Just _):ss) (TypeApp _ (TypeApp _ tyFn _) k2) | eqType tyFn tyFunction = s : withKinds ss k2 + withKinds ((s, Nothing):ss) (TypeApp _ (TypeApp _ tyFn k1) k2) | eqType tyFn tyFunction = (s, Just k1) : withKinds ss k2 + withKinds _ _ = internalError "Invalid arguments to withKinds" checkNewtype :: forall m @@ -587,10 +619,11 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = checkMemberExport extract dr@(TypeRef _ name dctors) = do env <- getEnv for_ (M.lookup (qualify' name) (types env)) $ \(k, _) -> do - let findModuleKinds = everythingOnKinds (++) $ \case - NamedKind _ (Qualified (Just mn') kindName) | mn' == mn -> [kindName] - _ -> [] - checkExport dr $ KindRef (declRefSourceSpan dr) <$> findModuleKinds k + -- TODO: remove? + -- let findModuleKinds = everythingOnTypes (++) $ \case + -- TypeConstructor _ (Qualified (Just mn') kindName) | mn' == mn -> [kindName] + -- _ -> [] + checkExport dr (extract k) for_ (M.lookup (qualify' name) (typeSynonyms env)) $ \(_, ty) -> checkExport dr (extract ty) for_ dctors $ \dctors' -> @@ -630,7 +663,6 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = where exported e = any (exports e) exps exports (TypeRef _ pn1 _) (TypeRef _ pn2 _) = pn1 == pn2 - exports (KindRef _ pn1) (KindRef _ pn2) = pn1 == pn2 exports (ValueRef _ id1) (ValueRef _ id2) = id1 == id2 exports (TypeClassRef _ pn1) (TypeClassRef _ pn2) = pn1 == pn2 exports _ _ = False @@ -674,6 +706,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = where findClassMembers :: Declaration -> Maybe [Ident] findClassMembers (TypeClassDeclaration _ name' _ _ _ ds) | name == name' = Just $ map extractMemberName ds + findClassMembers (DataBindingGroupDeclaration decls') = headMay . mapMaybe findClassMembers $ NEL.toList decls' findClassMembers _ = Nothing extractMemberName :: Declaration -> Ident extractMemberName (TypeDeclaration td) = tydeclIdent td diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 9168b09738..0ff121a811 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -39,6 +39,7 @@ import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Roles +import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds) import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Roles import Language.PureScript.TypeChecker.Synonyms @@ -167,28 +168,29 @@ entails entails SolverOptions{..} constraint context hints = solve constraint where - forClassName :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [TypeClassDict] - forClassName _ ctx cn@C.Warn [msg] = + forClassName :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> [TypeClassDict] + forClassName _ ctx cn@C.Warn _ [msg] = -- Prefer a warning dictionary in scope if there is one available. -- This allows us to defer a warning by propagating the constraint. - findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope [] 0 (WarnInstance msg) [] C.Warn [msg] Nothing] - forClassName env _ C.Coercible args | Just dicts <- solveCoercible env args = dicts - forClassName _ _ C.IsSymbol args | Just dicts <- solveIsSymbol args = dicts - forClassName _ _ C.SymbolCompare args | Just dicts <- solveSymbolCompare args = dicts - forClassName _ _ C.SymbolAppend args | Just dicts <- solveSymbolAppend args = dicts - forClassName _ _ C.SymbolCons args | Just dicts <- solveSymbolCons args = dicts - forClassName _ _ C.RowUnion args | Just dicts <- solveUnion args = dicts - forClassName _ _ C.RowNub args | Just dicts <- solveNub args = dicts - forClassName _ _ C.RowLacks args | Just dicts <- solveLacks args = dicts - forClassName _ _ C.RowCons args | Just dicts <- solveRowCons args = dicts - forClassName _ _ C.RowToList args | Just dicts <- solveRowToList args = dicts - forClassName _ ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) - forClassName _ _ _ _ = internalError "forClassName: expected qualified class name" + findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope [] 0 (WarnInstance msg) [] C.Warn [] [] [msg] Nothing] + forClassName env _ C.Coercible _ args | Just dicts <- solveCoercible env args = dicts + forClassName _ _ C.IsSymbol _ args | Just dicts <- solveIsSymbol args = dicts + forClassName _ _ C.SymbolCompare _ args | Just dicts <- solveSymbolCompare args = dicts + forClassName _ _ C.SymbolAppend _ args | Just dicts <- solveSymbolAppend args = dicts + forClassName _ _ C.SymbolCons _ args | Just dicts <- solveSymbolCons args = dicts + forClassName _ _ C.RowUnion kinds args | Just dicts <- solveUnion kinds args = dicts + forClassName _ _ C.RowNub kinds args | Just dicts <- solveNub kinds args = dicts + forClassName _ _ C.RowLacks kinds args | Just dicts <- solveLacks kinds args = dicts + forClassName _ _ C.RowCons kinds args | Just dicts <- solveRowCons kinds args = dicts + forClassName _ _ C.RowToList kinds args | Just dicts <- solveRowToList kinds args = dicts + forClassName _ ctx cn@(Qualified (Just mn) _) _ tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) + forClassName _ _ _ _ _ = internalError "forClassName: expected qualified class name" ctorModules :: SourceType -> Maybe ModuleName ctorModules (TypeConstructor _ (Qualified (Just mn) _)) = Just mn ctorModules (TypeConstructor _ (Qualified Nothing _)) = internalError "ctorModules: unqualified type name" ctorModules (TypeApp _ ty _) = ctorModules ty + ctorModules (KindApp _ ty _) = ctorModules ty ctorModules (KindedType _ ty _) = ctorModules ty ctorModules _ = Nothing @@ -202,12 +204,14 @@ entails SolverOptions{..} constraint context hints = solve con = go 0 con where go :: Int -> SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr - go work (Constraint _ className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' - go work con'@(Constraint _ className' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do + go work (Constraint _ className' _ tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' + go work con'@(Constraint _ className' kinds' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do -- We might have unified types by solving other constraints, so we need to -- apply the latest substitution. latestSubst <- lift . lift $ gets checkSubstitution - let tys'' = map (substituteType latestSubst) tys' + let kinds'' = map (substituteType latestSubst) kinds' + tys'' = map (substituteType latestSubst) tys' + -- Get the inferred constraint context so far, and merge it with the global context inferred <- lift get -- We need information about functional dependencies, so we have to look up the class @@ -224,7 +228,7 @@ entails SolverOptions{..} constraint context hints = let instances = do chain <- groupBy ((==) `on` tcdChain) $ sortBy (compare `on` (tcdChain &&& tcdIndex)) $ - forClassName env (combineContexts context inferred) className' tys'' + forClassName env (combineContexts context inferred) className' kinds'' tys'' -- process instances in a chain in index order let found = for chain $ \tcd -> -- Make sure the type unifies with the type in the type instance definition @@ -236,7 +240,7 @@ entails SolverOptions{..} constraint context hints = Right _ -> [] -- all apart Left Nothing -> [] -- last unknown Left (Just substsTcd) -> [substsTcd] -- found a match - solution <- lift . lift $ unique tys'' instances + solution <- lift . lift $ unique kinds'' tys'' instances case solution of Solved substs tcd -> do -- Note that we solved something. @@ -279,7 +283,7 @@ entails SolverOptions{..} constraint context hints = Deferred -> -- Constraint was deferred, just return the dictionary unchanged, -- with no unsolved constraints. Hopefully, we can solve this later. - return (TypeClassDictionary (srcConstraint className' tys'' conInfo) context hints) + return (TypeClassDictionary (srcConstraint className' kinds'' tys'' conInfo) context hints) where -- | When checking functional dependencies, we need to use unification to make -- sure it is safe to use the selected instance. We will unify the solved type with @@ -291,36 +295,39 @@ entails SolverOptions{..} constraint context hints = -- from the type, so we end up with a unification error. So, any type arguments which -- appear in the instance head, but not in the substitution need to be replaced with -- fresh type variables. This function extends a substitution with fresh type variables - -- as necessary, based on the types in the instance head. + -- as necessary, based on the types in the instance head. It also unifies kinds based on + -- the substitution so kind information propagates correctly through the solver. withFreshTypes :: TypeClassDict -> Matching SourceType -> m (Matching SourceType) - withFreshTypes TypeClassDictionaryInScope{..} subst = do - let onType = everythingOnTypes S.union fromTypeVar - typeVarsInHead = foldMap onType tcdInstanceTypes - <> foldMap (foldMap (foldMap onType . constraintArgs)) tcdDependencies - typeVarsInSubst = S.fromList (M.keys subst) - uninstantiatedTypeVars = typeVarsInHead S.\\ typeVarsInSubst - newSubst <- traverse withFreshType (S.toList uninstantiatedTypeVars) - return (subst <> M.fromList newSubst) + withFreshTypes TypeClassDictionaryInScope{..} initSubst = do + subst <- foldM withFreshType initSubst $ filter (flip M.notMember initSubst . fst) tcdForAll + for_ (M.toList initSubst) $ unifySubstKind subst + pure subst where - fromTypeVar (TypeVar _ v) = S.singleton v - fromTypeVar _ = S.empty - - withFreshType s = do - t <- freshType - return (s, t) - - unique :: [SourceType] -> [(a, TypeClassDict)] -> m (EntailsResult a) - unique tyArgs [] + withFreshType subst (var, kind) = do + ty <- freshTypeWithKind $ replaceAllTypeVars (M.toList subst) kind + pure $ M.insert var ty subst + + unifySubstKind subst (var, ty) = + for_ (lookup var tcdForAll) $ \instKind -> do + tyKind <- elaborateKind ty + currentSubst <- gets checkSubstitution + unifyKinds + (substituteType currentSubst . replaceAllTypeVars (M.toList subst) $ instKind) + (substituteType currentSubst tyKind) + + unique :: [SourceType] -> [SourceType] -> [(a, TypeClassDict)] -> m (EntailsResult a) + unique kindArgs tyArgs [] | solverDeferErrors = return Deferred -- We need a special case for nullary type classes, since we want -- to generalize over Partial constraints. - | solverShouldGeneralize && (null tyArgs || any canBeGeneralized tyArgs) = return (Unsolved (srcConstraint className' tyArgs conInfo)) - | otherwise = throwError . errorMessage $ NoInstanceFound (srcConstraint className' tyArgs conInfo) - unique _ [(a, dict)] = return $ Solved a dict - unique tyArgs tcds + | solverShouldGeneralize && ((null kindArgs && null tyArgs) || any canBeGeneralized kindArgs || any canBeGeneralized tyArgs) = + return (Unsolved (srcConstraint className' kindArgs tyArgs conInfo)) + | otherwise = throwError . errorMessage $ NoInstanceFound (srcConstraint className' kindArgs tyArgs conInfo) + unique _ _ [(a, dict)] = return $ Solved a dict + unique _ tyArgs tcds | pairwiseAny overlapping (map snd tcds) = throwError . errorMessage $ OverlappingInstances className' tyArgs (tcds >>= (toList . namedInstanceIdentifier . tcdValue . snd)) | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds) @@ -348,7 +355,7 @@ entails SolverOptions{..} constraint context hints = solveSubgoals :: Matching SourceType -> Maybe [SourceConstraint] -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) (Maybe [Expr]) solveSubgoals _ Nothing = return Nothing solveSubgoals subst (Just subgoals) = - Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals + Just <$> traverse (go (work + 1) . mapConstraintArgsAll (map (replaceAllTypeVars (M.toList subst)))) subgoals -- We need subgoal dictionaries to appear in the term somewhere -- If there aren't any then the dictionary is just undefined @@ -377,21 +384,22 @@ entails SolverOptions{..} constraint context hints = solveCoercible :: Environment -> [SourceType] -> Maybe [TypeClassDict] solveCoercible env [a, b] = do let tySynMap = typeSynonyms env - replaceTySyns = either (const Nothing) Just . replaceAllTypeSynonymsM tySynMap + kindMap = types env + replaceTySyns = either (const Nothing) Just . replaceAllTypeSynonymsM tySynMap kindMap a' <- replaceTySyns a b' <- replaceTySyns b -- Solving terminates when the two arguments are the same. Since we -- currently don't support higher-rank arguments in instance heads, term -- equality is a sufficient notion of "the same". if a' == b' - then pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [a, b] Nothing] + then pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [] [] [a, b] Nothing] else do -- When solving must reduce and recurse, it doesn't matter whether we -- reduce the first or second argument -- if the constraint is -- solvable, either path will yield the same outcome. Consequently we -- just try the first argument first and the second argument second. ws <- coercibleWanteds env a' b' <|> coercibleWanteds env b' a' - pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [a, b] (Just ws)] + pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [] [] [a, b] (Just ws)] solveCoercible _ _ = Nothing -- | Take two types, @a@ and @b@ representing a desired constraint @@ -405,11 +413,11 @@ entails SolverOptions{..} constraint context hints = -- field and yield a new wanted constraint in terms of that type -- (@Coercible U b@ in the example). (_, wrappedTy, _) <- lookupNewtypeConstructor env tyName - pure [Constraint nullSourceAnn C.Coercible [wrappedTy, b] Nothing] + pure [Constraint nullSourceAnn C.Coercible [] [wrappedTy, b] Nothing] t - | Just (TypeConstructor _ aTyName, axs) <- splitTypeApp a - , Just (TypeConstructor _ bTyName, bxs) <- splitTypeApp b - , aTyName == bTyName + | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a + , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b + , not (null axs) && not (null bxs) && aTyName == bTyName , tyRoles <- inferRoles env aTyName -> do -- If both arguments are applications of the same type constructor -- (e.g. @data D a b = D a@ in the constraint @@ -430,11 +438,12 @@ entails SolverOptions{..} constraint context hints = | otherwise -> Nothing Representational -> - Just [Constraint nullSourceAnn C.Coercible [ax, bx] Nothing] + Just [Constraint nullSourceAnn C.Coercible [] [ax, bx] Nothing] Phantom -> Just [] fmap concat $ sequence $ zipWith3 k tyRoles axs bxs - | Just (TypeConstructor _ tyName, xs) <- splitTypeApp t + | (TypeConstructor _ tyName, _, xs) <- unapplyTypes t + , not $ null xs , Just (tvs, wrappedTy, _) <- lookupNewtypeConstructor env tyName -> do -- If the first argument is a newtype applied to some other types -- (e.g. @newtype T a = T a@ in @Coercible (T X) b@), look up the @@ -442,13 +451,13 @@ entails SolverOptions{..} constraint context hints = -- terms of that type with the type arguments substituted in (e.g. -- @Coercible (T[X/a]) b = Coercible X b@ in the example). let wrappedTySub = replaceAllTypeVars (zip tvs xs) wrappedTy - pure [Constraint nullSourceAnn C.Coercible [wrappedTySub, b] Nothing] + pure [Constraint nullSourceAnn C.Coercible [] [wrappedTySub, b] Nothing] _ -> -- In all other cases we can't solve the constraint. Nothing solveIsSymbol :: [SourceType] -> Maybe [TypeClassDict] - solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope [] 0 (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString ann sym] Nothing] + solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope [] 0 (IsSymbolInstance sym) [] C.IsSymbol [] [] [TypeLevelString ann sym] Nothing] solveIsSymbol _ = Nothing solveSymbolCompare :: [SourceType] -> Maybe [TypeClassDict] @@ -458,14 +467,14 @@ entails SolverOptions{..} constraint context hints = EQ -> C.orderingEQ GT -> C.orderingGT args' = [arg0, arg1, srcTypeConstructor ordering] - in Just [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolCompare args' Nothing] + in Just [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolCompare [] [] args' Nothing] solveSymbolCompare _ = Nothing solveSymbolAppend :: [SourceType] -> Maybe [TypeClassDict] solveSymbolAppend [arg0, arg1, arg2] = do (arg0', arg1', arg2') <- appendSymbols arg0 arg1 arg2 let args' = [arg0', arg1', arg2'] - pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolAppend args' Nothing] + pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolAppend [] [] args' Nothing] solveSymbolAppend _ = Nothing -- | Append type level symbols, or, run backwards, strip a prefix or suffix @@ -487,7 +496,7 @@ entails SolverOptions{..} constraint context hints = solveSymbolCons [arg0, arg1, arg2] = do (arg0', arg1', arg2') <- consSymbol arg0 arg1 arg2 let args' = [arg0', arg1', arg2'] - pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolCons args' Nothing] + pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolCons [] [] args' Nothing] solveSymbolCons _ = Nothing consSymbol :: SourceType -> SourceType -> SourceType -> Maybe (SourceType, SourceType, SourceType) @@ -502,79 +511,85 @@ entails SolverOptions{..} constraint context hints = pure (arg1, arg2, srcTypeLevelString (mkString $ h' <> t')) consSymbol _ _ _ = Nothing - solveUnion :: [SourceType] -> Maybe [TypeClassDict] - solveUnion [l, r, u] = do - (lOut, rOut, uOut, cst) <- unionRows l r u - pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowUnion [lOut, rOut, uOut] cst ] - solveUnion _ = Nothing + solveUnion :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] + solveUnion kinds [l, r, u] = do + (lOut, rOut, uOut, cst, vars) <- unionRows kinds l r u + pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowUnion vars kinds [lOut, rOut, uOut] cst ] + solveUnion _ _ = Nothing -- | Left biased union of two row types - unionRows :: SourceType -> SourceType -> SourceType -> Maybe (SourceType, SourceType, SourceType, Maybe [SourceConstraint]) - unionRows l r _ = - guard canMakeProgress $> (l, r, rowFromList out, cons) + unionRows :: [SourceType] -> SourceType -> SourceType -> SourceType -> Maybe (SourceType, SourceType, SourceType, Maybe [SourceConstraint], [(Text, SourceType)]) + unionRows kinds l r _ = + guard canMakeProgress $> (l, r, rowFromList out, cons, vars) where (fixed, rest) = rowToList l rowVar = srcTypeVar "r" - (canMakeProgress, out, cons) = + (canMakeProgress, out, cons, vars) = case rest of -- If the left hand side is a closed row, then we can merge -- its labels into the right hand side. - REmpty _ -> (True, (fixed, r), Nothing) + REmptyKinded _ _ -> (True, (fixed, r), Nothing, []) -- If the left hand side is not definitely closed, then the only way we -- can safely make progress is to move any known labels from the left -- input into the output, and add a constraint for any remaining labels. -- Otherwise, the left hand tail might contain the same labels as on -- the right hand side, and we can't be certain we won't reorder the -- types for such labels. - _ -> (not (null fixed), (fixed, rowVar), Just [ srcConstraint C.RowUnion [rest, r, rowVar] Nothing ]) - - solveRowCons :: [SourceType] -> Maybe [TypeClassDict] - solveRowCons [TypeLevelString ann sym, ty, r, _] = - Just [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowCons [TypeLevelString ann sym, ty, r, srcRCons (Label sym) ty r] Nothing ] - solveRowCons _ = Nothing - - solveRowToList :: [SourceType] -> Maybe [TypeClassDict] - solveRowToList [r, _] = do - entries <- rowToRowList r - pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowToList [r, entries] Nothing ] - solveRowToList _ = Nothing + _ -> ( not (null fixed) + , (fixed, rowVar) + , Just [ srcConstraint C.RowUnion kinds [rest, r, rowVar] Nothing ] + , [("r", kindRow (head kinds))] + ) + + solveRowCons :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] + solveRowCons kinds [TypeLevelString ann sym, ty, r, _] = + Just [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowCons [] kinds [TypeLevelString ann sym, ty, r, srcRCons (Label sym) ty r] Nothing ] + solveRowCons _ _ = Nothing + + solveRowToList :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] + solveRowToList [kind] [r, _] = do + entries <- rowToRowList kind r + pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowToList [] [kind] [r, entries] Nothing ] + solveRowToList _ _ = Nothing -- | Convert a closed row to a sorted list of entries - rowToRowList :: SourceType -> Maybe SourceType - rowToRowList r = - guard (eqType rest $ REmpty ()) $> - foldr rowListCons (srcTypeConstructor C.RowListNil) fixed + rowToRowList :: SourceType -> SourceType -> Maybe SourceType + rowToRowList kind r = + guard (isREmpty rest) $> + foldr rowListCons (srcKindApp (srcTypeConstructor C.RowListNil) kind) fixed where (fixed, rest) = rowToSortedList r rowListCons (RowListItem _ lbl ty) tl = - foldl srcTypeApp (srcTypeConstructor C.RowListCons) + foldl srcTypeApp (srcKindApp (srcTypeConstructor C.RowListCons) kind) [ srcTypeLevelString (runLabel lbl) , ty , tl ] - solveNub :: [SourceType] -> Maybe [TypeClassDict] - solveNub [r, _] = do + solveNub :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] + solveNub kinds [r, _] = do r' <- nubRows r - pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowNub [r, r'] Nothing ] - solveNub _ = Nothing + pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowNub [] kinds [r, r'] Nothing ] + solveNub _ _ = Nothing nubRows :: SourceType -> Maybe SourceType nubRows r = - guard (eqType rest $ REmpty ()) $> + guard (isREmpty rest) $> rowFromList (nubBy ((==) `on` rowListLabel) fixed, rest) where (fixed, rest) = rowToSortedList r - solveLacks :: [SourceType] -> Maybe [TypeClassDict] - solveLacks [TypeLevelString ann sym, r] = do - (r', cst) <- rowLacks sym r - pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowLacks [TypeLevelString ann sym, r'] cst ] - solveLacks _ = Nothing + solveLacks :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] + solveLacks kinds tys@[_, REmptyKinded _ _] = + pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowLacks [] kinds tys Nothing ] + solveLacks kinds [TypeLevelString ann sym, r] = do + (r', cst) <- rowLacks kinds sym r + pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowLacks [] kinds [TypeLevelString ann sym, r'] cst ] + solveLacks _ _ = Nothing - rowLacks :: PSString -> SourceType -> Maybe (SourceType, Maybe [SourceConstraint]) - rowLacks sym r = + rowLacks :: [SourceType] -> PSString -> SourceType -> Maybe (SourceType, Maybe [SourceConstraint]) + rowLacks kinds sym r = guard (lacksSym && canMakeProgress) $> (r, cst) where (fixed, rest) = rowToList r @@ -583,8 +598,8 @@ entails SolverOptions{..} constraint context hints = not $ sym `elem` (runLabel . rowListLabel <$> fixed) (canMakeProgress, cst) = case rest of - REmpty _ -> (True, Nothing) - _ -> (not (null fixed), Just [ srcConstraint C.RowLacks [srcTypeLevelString sym, rest] Nothing ]) + REmptyKinded _ _ -> (True, Nothing) + _ -> (not (null fixed), Just [ srcConstraint C.RowLacks kinds [srcTypeLevelString sym, rest] Nothing ]) -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a @@ -634,12 +649,14 @@ matches deps TypeClassDictionaryInScope{..} tys = typeHeadsAreEqual (KindedType _ t1 _) t2 = typeHeadsAreEqual t1 t2 typeHeadsAreEqual t1 (KindedType _ t2 _) = typeHeadsAreEqual t1 t2 typeHeadsAreEqual (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = (Match (), M.empty) - typeHeadsAreEqual (Skolem _ _ s1 _) (Skolem _ _ s2 _) | s1 == s2 = (Match (), M.empty) + typeHeadsAreEqual (Skolem _ _ _ s1 _) (Skolem _ _ _ s2 _) | s1 == s2 = (Match (), M.empty) typeHeadsAreEqual t (TypeVar _ v) = (Match (), M.singleton v [t]) typeHeadsAreEqual (TypeConstructor _ c1) (TypeConstructor _ c2) | c1 == c2 = (Match (), M.empty) typeHeadsAreEqual (TypeLevelString _ s1) (TypeLevelString _ s2) | s1 == s2 = (Match (), M.empty) typeHeadsAreEqual (TypeApp _ h1 t1) (TypeApp _ h2 t2) = both (typeHeadsAreEqual h1 h2) (typeHeadsAreEqual t1 t2) + typeHeadsAreEqual (KindApp _ h1 t1) (KindApp _ h2 t2) = + both (typeHeadsAreEqual h1 h2) (typeHeadsAreEqual t1 t2) typeHeadsAreEqual (REmpty _) (REmpty _) = (Match (), M.empty) typeHeadsAreEqual r1@RCons{} r2@RCons{} = foldr both (uncurry go rest) common @@ -649,17 +666,17 @@ matches deps TypeClassDictionaryInScope{..} tys = go :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Matched (), Matching [Type a]) go (l, KindedType _ t1 _) (r, t2) = go (l, t1) (r, t2) go (l, t1) (r, KindedType _ t2 _) = go (l, t1) (r, t2) + go (l, KindApp _ t1 k1) (r, KindApp _ t2 k2) | eqType k1 k2 = go (l, t1) (r, t2) go ([], REmpty _) ([], REmpty _) = (Match (), M.empty) go ([], TUnknown _ u1) ([], TUnknown _ u2) | u1 == u2 = (Match (), M.empty) go ([], TypeVar _ v1) ([], TypeVar _ v2) | v1 == v2 = (Match (), M.empty) - go ([], Skolem _ _ sk1 _) ([], Skolem _ _ sk2 _) | sk1 == sk2 = (Match (), M.empty) + go ([], Skolem _ _ _ sk1 _) ([], Skolem _ _ _ sk2 _) | sk1 == sk2 = (Match (), M.empty) go ([], TUnknown _ _) _ = (Unknown, M.empty) go (sd, r) ([], TypeVar _ v) = (Match (), M.singleton v [rowFromList (sd, r)]) go _ _ = (Apart, M.empty) typeHeadsAreEqual (TUnknown _ _) _ = (Unknown, M.empty) typeHeadsAreEqual _ _ = (Apart, M.empty) - both :: (Matched (), Matching [Type a]) -> (Matched (), Matching [Type a]) -> (Matched (), Matching [Type a]) both (b1, m1) (b2, m2) = (b1 <> b2, M.unionWith (++) m1 m2) @@ -675,13 +692,14 @@ matches deps TypeClassDictionaryInScope{..} tys = typesAreEqual (KindedType _ t1 _) t2 = typesAreEqual t1 t2 typesAreEqual t1 (KindedType _ t2 _) = typesAreEqual t1 t2 typesAreEqual (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = Match () - typesAreEqual (Skolem _ _ s1 _) (Skolem _ _ s2 _) | s1 == s2 = Match () - typesAreEqual (Skolem _ _ _ _) _ = Unknown - typesAreEqual _ (Skolem _ _ _ _) = Unknown + typesAreEqual (Skolem _ _ _ s1 _) (Skolem _ _ _ s2 _) | s1 == s2 = Match () + typesAreEqual (Skolem _ _ _ _ _) _ = Unknown + typesAreEqual _ (Skolem _ _ _ _ _) = Unknown typesAreEqual (TypeVar _ v1) (TypeVar _ v2) | v1 == v2 = Match () typesAreEqual (TypeLevelString _ s1) (TypeLevelString _ s2) | s1 == s2 = Match () typesAreEqual (TypeConstructor _ c1) (TypeConstructor _ c2) | c1 == c2 = Match () typesAreEqual (TypeApp _ h1 t1) (TypeApp _ h2 t2) = typesAreEqual h1 h2 <> typesAreEqual t1 t2 + typesAreEqual (KindApp _ h1 t1) (KindApp _ h2 t2) = typesAreEqual h1 h2 <> typesAreEqual t1 t2 typesAreEqual (REmpty _) (REmpty _) = Match () typesAreEqual r1 r2 | isRCons r1 || isRCons r2 = let (common, rest) = alignRowsWith typesAreEqual r1 r2 @@ -690,10 +708,11 @@ matches deps TypeClassDictionaryInScope{..} tys = go :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> Matched () go (l, KindedType _ t1 _) (r, t2) = go (l, t1) (r, t2) go (l, t1) (r, KindedType _ t2 _) = go (l, t1) (r, t2) + go ([], KindApp _ t1 k1) ([], KindApp _ t2 k2) = typesAreEqual t1 t2 <> typesAreEqual k1 k2 go ([], TUnknown _ u1) ([], TUnknown _ u2) | u1 == u2 = Match () - go ([], Skolem _ _ s1 _) ([], Skolem _ _ s2 _) | s1 == s2 = Match () - go ([], Skolem _ _ _ _) _ = Unknown - go _ ([], Skolem _ _ _ _) = Unknown + go ([], Skolem _ _ _ s1 _) ([], Skolem _ _ _ s2 _) | s1 == s2 = Match () + go ([], Skolem _ _ _ _ _) _ = Unknown + go _ ([], Skolem _ _ _ _ _) = Unknown go ([], REmpty _) ([], REmpty _) = Match () go ([], TypeVar _ v1) ([], TypeVar _ v2) | v1 == v2 = Match () go _ _ = Apart @@ -711,18 +730,19 @@ newDictionaries -> Qualified Ident -> SourceConstraint -> m [NamedDict] -newDictionaries path name (Constraint _ className instanceTy _) = do +newDictionaries path name (Constraint _ className instanceKinds instanceTy _) = do tcs <- gets (typeClasses . checkEnv) let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs - supDicts <- join <$> zipWithM (\(Constraint ann supName supArgs _) index -> + supDicts <- join <$> zipWithM (\(Constraint ann supName supKinds supArgs _) index -> + let sub = zip (map fst typeClassArguments) instanceTy in newDictionaries ((supName, index) : path) name - (Constraint ann supName (instantiateSuperclass (map fst typeClassArguments) supArgs instanceTy) Nothing) + (Constraint ann supName + (replaceAllTypeVars sub <$> supKinds) + (replaceAllTypeVars sub <$> supArgs) + Nothing) ) typeClassSuperclasses [0..] - return (TypeClassDictionaryInScope [] 0 name path className instanceTy Nothing : supDicts) - where - instantiateSuperclass :: [Text] -> [SourceType] -> [SourceType] -> [SourceType] - instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs + return (TypeClassDictionaryInScope [] 0 name path className [] instanceKinds instanceTy Nothing : supDicts) mkContext :: [NamedDict] -> InstanceContext mkContext = foldr combineContexts M.empty . map fromDict where diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 28a4009b52..dd4c90ed33 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -1,276 +1,967 @@ -{-# LANGUAGE FlexibleInstances #-} - -- | -- This module implements the kind checker -- module Language.PureScript.TypeChecker.Kinds ( kindOf + , kindOfWithUnknowns , kindOfWithScopedVars - , kindsOf + , kindOfData + , kindOfTypeSynonym + , kindOfClass , kindsOfAll + , unifyKinds + , subsumesKind + , instantiateKind + , checkKind + , inferKind + , elaborateKind + , checkConstraint + , checkInstanceDeclaration + , checkKindDeclaration + , checkTypeKind + , unknownsWithKinds ) where import Prelude.Compat -import Control.Arrow (second) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State +import Control.Monad.Supply.Class +import Data.Bifunctor (first) +import Data.Bitraversable (bitraverse) +import Data.Foldable (for_, traverse_) +import Data.Function (on) import Data.Functor (($>)) +import qualified Data.IntSet as IS +import Data.List (nubBy, sortBy, (\\)) import qualified Data.Map as M +import Data.Maybe (fromJust) +import Data.Ord (comparing) import Data.Text (Text) +import qualified Data.Text as T import Data.Traversable (for) import Language.PureScript.Crash -import Language.PureScript.Environment +import qualified Language.PureScript.Environment as E import Language.PureScript.Errors -import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.TypeChecker.Monad +import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScope, skolemize) +import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.Types +import Language.PureScript.Pretty.Types +import Lens.Micro.Platform ((^.), _1, _2, _3) --- | Generate a fresh kind variable -freshKind :: (MonadState CheckState m) => SourceAnn -> m SourceKind -freshKind ann = do - k <- gets checkNextKind - modify $ \st -> st { checkNextKind = k + 1 } - return $ KUnknown ann k - -freshKind' :: (MonadState CheckState m) => m SourceKind -freshKind' = freshKind NullSourceAnn - --- | Update the substitution to solve a kind constraint -solveKind - :: (MonadError MultipleErrors m, MonadState CheckState m) - => Int - -> SourceKind - -> m () -solveKind u k = do - occursCheck u k - modify $ \cs -> cs { checkSubstitution = - (checkSubstitution cs) { substKind = - M.insert u k $ substKind $ checkSubstitution cs - } - } - --- | Apply a substitution to a kind -substituteKind :: Substitution -> SourceKind -> SourceKind -substituteKind sub = everywhereOnKinds go +generalizeUnknowns :: [(Unknown, SourceType)] -> SourceType -> SourceType +generalizeUnknowns unks ty = + generalizeUnknownsWithVars (unknownVarNames (usedTypeVariables ty) unks) ty + +generalizeUnknownsWithVars :: [(Unknown, (Text, SourceType))] -> SourceType -> SourceType +generalizeUnknownsWithVars binders ty = + mkForAll ((getAnnForType ty,) . fmap Just . snd <$> binders) . replaceUnknownsWithVars binders $ ty + +replaceUnknownsWithVars :: [(Unknown, (Text, a))] -> SourceType -> SourceType +replaceUnknownsWithVars binders ty + | null binders = ty + | otherwise = go ty + where + go :: SourceType -> SourceType + go = everywhereOnTypes $ \case + TUnknown ann unk | Just (name, _) <- lookup unk binders -> TypeVar ann name + other -> other + +unknownVarNames :: [Text] -> [(Unknown, SourceType)] -> [(Unknown, (Text, SourceType))] +unknownVarNames used unks = + zipWith (\(a, b) n -> (a, (n, b))) unks $ allVars \\ used + where + allVars :: [Text] + allVars + | [_] <- unks = "k" : vars + | otherwise = vars + + vars :: [Text] + vars = fmap (("k" <>) . T.pack . show) ([1..] :: [Int]) + +apply :: (MonadState CheckState m) => SourceType -> m SourceType +apply ty = flip substituteType ty <$> gets checkSubstitution + +substituteType :: Substitution -> SourceType -> SourceType +substituteType sub = everywhereOnTypes $ \case + TUnknown ann u -> + case M.lookup u (substType sub) of + Nothing -> TUnknown ann u + Just (TUnknown ann' u1) | u1 == u -> TUnknown ann' u1 + Just t -> substituteType sub t + other -> + other + +freshUnknown :: (MonadState CheckState m) => m Unknown +freshUnknown = do + k <- gets checkNextType + modify $ \st -> st { checkNextType = k + 1 } + pure k + +freshKind :: (MonadState CheckState m) => SourceSpan -> m SourceType +freshKind ss = freshKindWithKind ss E.kindType + +freshKindWithKind :: (MonadState CheckState m) => SourceSpan -> SourceType -> m SourceType +freshKindWithKind ss kind = do + u <- freshUnknown + addUnsolved Nothing u kind + pure $ TUnknown (ss, []) u + +addUnsolved :: (MonadState CheckState m) => Maybe UnkLevel -> Unknown -> SourceType -> m () +addUnsolved lvl unk kind = modify $ \st -> do + let + newLvl = UnkLevel $ case lvl of + Nothing -> pure unk + Just (UnkLevel lvl') -> lvl' <> pure unk + subs = checkSubstitution st + uns = M.insert unk (newLvl, kind) $ substUnsolved subs + st { checkSubstitution = subs { substUnsolved = uns } } + +solve :: (MonadState CheckState m) => Unknown -> SourceType -> m () +solve unk solution = modify $ \st -> do + let + subs = checkSubstitution st + tys = M.insert unk solution $ substType subs + st { checkSubstitution = subs { substType = tys } } + +lookupUnsolved + :: (MonadState CheckState m, MonadError MultipleErrors m, HasCallStack) + => Unknown + -> m (UnkLevel, SourceType) +lookupUnsolved u = do + uns <- gets (substUnsolved . checkSubstitution) + case M.lookup u uns of + Nothing -> internalCompilerError $ "Unsolved unification variable ?" <> T.pack (show u) <> " is not bound" + Just res -> return res + +unknownsWithKinds + :: forall m. (MonadState CheckState m, MonadError MultipleErrors m, HasCallStack) + => [Unknown] + -> m [(Unknown, SourceType)] +unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortBy (comparing fst) . join) . traverse go + where + go u = do + (lvl, ty) <- traverse apply =<< lookupUnsolved u + rest <- fmap join . traverse go . IS.toList . unknowns $ ty + pure $ (lvl, (u, ty)) : rest + +inferKind + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => SourceType + -> m (SourceType, SourceType) +inferKind = \tyToInfer -> + withErrorMessageHint (ErrorInferringKind tyToInfer) + . rethrowWithPosition (fst $ getAnnForType tyToInfer) + $ go tyToInfer + where + go = \case + ty@(TypeConstructor ann v) -> do + env <- getEnv + case M.lookup v (E.types env) of + Nothing -> + throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v + Just (kind, E.LocalTypeVariable) -> do + kind' <- apply kind + pure (ty, kind' $> ann) + Just (kind, _) -> do + pure (ty, kind $> ann) + ConstrainedType ann' con@(Constraint ann v _ _ _) ty -> do + env <- getEnv + con' <- case M.lookup (coerceProperName <$> v) (E.types env) of + Nothing -> + throwError . errorMessage' (fst ann) . UnknownName . fmap TyClassName $ v + Just _ -> + checkConstraint con + ty' <- checkKind ty E.kindType + con'' <- applyConstraint con' + pure (ConstrainedType ann' con'' ty', E.kindType $> ann') + ty@(TypeLevelString ann _) -> + pure (ty, E.kindSymbol $> ann) + ty@(TypeVar ann v) -> do + moduleName <- unsafeCheckCurrentModule + kind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing $ ProperName v) + pure (ty, kind $> ann) + ty@(Skolem ann _ mbK _ _) -> do + kind <- apply $ maybe (internalError "Skolem has no kind") id mbK + pure (ty, kind $> ann) + ty@(TUnknown ann u) -> do + kind <- apply . snd =<< lookupUnsolved u + pure (ty, kind $> ann) + ty@(TypeWildcard ann _) -> do + k <- freshKind (fst ann) + pure (ty, k $> ann) + ty@(REmpty ann) -> do + pure (ty, E.kindOfREmpty $> ann) + ty@(RCons ann _ _ _) | (rowList, rowTail) <- rowToList ty -> do + kr <- freshKind (fst ann) + rowList' <- for rowList $ \(RowListItem a lbl t) -> + RowListItem a lbl <$> checkKind t kr + rowTail' <- checkKind rowTail $ E.kindRow kr + kr' <- apply kr + pure (rowFromList (rowList', rowTail'), E.kindRow kr' $> ann) + TypeApp ann t1 t2 -> do + (t1', k1) <- go t1 + inferAppKind ann (t1', k1) t2 + KindApp ann t1 t2 -> do + (t1', kind) <- bitraverse pure apply =<< go t1 + case kind of + ForAll _ arg (Just argKind) resKind _ -> do + t2' <- checkKind t2 argKind + pure (KindApp ann t1' t2', replaceTypeVars arg t2' resKind) + _ -> + internalError $ "inferKind: unkinded forall binder" + KindedType _ t1 t2 -> do + t2' <- replaceAllTypeSynonyms . fst =<< go t2 + t1' <- checkKind t1 t2' + t2'' <- apply t2' + pure (t1', t2'') + ForAll ann arg mbKind ty sc -> do + moduleName <- unsafeCheckCurrentModule + kind <- case mbKind of + Just k -> replaceAllTypeSynonyms =<< checkKind k E.kindType + Nothing -> freshKind (fst ann) + (ty', unks) <- bindLocalTypeVariables moduleName [(ProperName arg, kind)] $ do + ty' <- apply =<< checkKind ty E.kindType + unks <- unknownsWithKinds . IS.toList $ unknowns ty' + pure (ty', unks) + for_ unks . uncurry $ addUnsolved Nothing + pure (ForAll ann arg (Just kind) ty' sc, E.kindType $> ann) + ParensInType _ ty -> + go ty + ty -> + internalError $ "inferKind: Unimplemented case \n" <> prettyPrintType 100 ty + +inferAppKind + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => SourceAnn + -> (SourceType, SourceType) + -> SourceType + -> m (SourceType, SourceType) +inferAppKind ann (fn, fnKind) arg = case fnKind of + TypeApp _ (TypeApp _ arrKind argKind) resKind | eqType arrKind E.tyFunction -> do + arg' <- checkKind arg argKind + (TypeApp ann fn arg',) <$> apply resKind + TUnknown _ u -> do + (lvl, _) <- lookupUnsolved u + u1 <- freshUnknown + u2 <- freshUnknown + addUnsolved (Just lvl) u1 E.kindType + addUnsolved (Just lvl) u2 E.kindType + solve u $ (TUnknown ann u1 E.-:> TUnknown ann u2) $> ann + arg' <- checkKind arg $ TUnknown ann u1 + pure (TypeApp ann fn arg', TUnknown ann u2) + ForAll _ a (Just k) ty _ -> do + u <- freshUnknown + addUnsolved Nothing u k + inferAppKind ann (KindApp ann fn (TUnknown ann u), replaceTypeVars a (TUnknown ann u) ty) arg + _ -> + cannotApplyTypeToType fn arg + +cannotApplyTypeToType + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => SourceType + -> SourceType + -> m a +cannotApplyTypeToType fn arg = do + argKind <- snd <$> inferKind arg + _ <- checkKind fn . srcTypeApp (srcTypeApp E.tyFunction argKind) =<< freshKind nullSourceSpan + internalCompilerError . T.pack $ "Cannot apply type to type: " <> debugType (srcTypeApp fn arg) + +cannotApplyKindToType + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => SourceType + -> SourceType + -> m a +cannotApplyKindToType poly arg = do + let ann = getAnnForType arg + argKind <- snd <$> inferKind arg + _ <- checkKind poly . mkForAll [(ann, ("k", Just argKind))] =<< freshKind nullSourceSpan + internalCompilerError . T.pack $ "Cannot apply kind to type: " <> debugType (srcKindApp poly arg) + +checkKind + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => SourceType + -> SourceType + -> m SourceType +checkKind ty kind2 = + withErrorMessageHint (ErrorCheckingKind ty kind2) + . rethrowWithPosition (fst $ getAnnForType ty) $ do + (ty', kind1) <- inferKind ty + kind1' <- apply kind1 + kind2' <- apply kind2 + instantiateKind (ty', kind1') kind2' + +instantiateKind + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => (SourceType, SourceType) + -> SourceType + -> m SourceType +instantiateKind (ty, kind1) kind2 = case kind1 of + ForAll _ a (Just k) t _ | shouldInstantiate kind2 -> do + let ann = getAnnForType ty + u <- freshKindWithKind (fst ann) k + instantiateKind (KindApp ann ty u, replaceTypeVars a u t) kind2 + _ -> do + subsumesKind kind1 kind2 + pure ty where - go (KUnknown ann u) = - case M.lookup u (substKind sub) of - Nothing -> KUnknown ann u - Just (KUnknown ann' u1) | u1 == u -> KUnknown ann' u1 - Just t -> substituteKind sub t - go other = other - --- | Make sure that an unknown does not occur in a kind -occursCheck - :: (MonadError MultipleErrors m) - => Int - -> SourceKind + shouldInstantiate = not . \case + ForAll _ _ _ _ _ -> True + _ -> False + +subsumesKind + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => SourceType + -> SourceType -> m () -occursCheck _ KUnknown{} = return () -occursCheck u k = void $ everywhereOnKindsM go k +subsumesKind = go where - go (KUnknown _ u') | u == u' = throwError . errorMessage . InfiniteKind $ k - go other = return other + go = curry $ \case + (TypeApp _ (TypeApp _ arr1 a1) a2, TypeApp _ (TypeApp _ arr2 b1) b2) + | eqType arr1 E.tyFunction + , eqType arr2 E.tyFunction -> do + go b1 a1 + join $ go <$> apply a2 <*> apply b2 + (a, ForAll ann var mbKind b mbScope) -> do + scope <- maybe newSkolemScope pure mbScope + skolc <- newSkolemConstant + go a $ skolemize ann var mbKind skolc scope b + (ForAll ann var (Just kind) a _, b) -> do + a' <- freshKindWithKind (fst ann) kind + go (replaceTypeVars var a' a) b + (TUnknown ann u, b@(TypeApp _ (TypeApp _ arr _) _)) + | eqType arr E.tyFunction + , IS.notMember u (unknowns b) -> + join $ go <$> solveUnknownAsFunction ann u <*> pure b + (a@(TypeApp _ (TypeApp _ arr _) _), TUnknown ann u) + | eqType arr E.tyFunction + , IS.notMember u (unknowns a) -> + join $ go <$> pure a <*> solveUnknownAsFunction ann u + (a, b) -> + unifyKinds a b --- | Unify two kinds unifyKinds - :: (MonadError MultipleErrors m, MonadState CheckState m) - => SourceKind - -> SourceKind + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => SourceType + -> SourceType + -> m () +unifyKinds = unifyKindsWithFailure $ \w1 w2 -> + throwError + . errorMessage''' (fst . getAnnForType <$> [w1, w2]) + $ KindsDoNotUnify w1 w2 + +-- | Check the kind of a type, failing if it is not of kind *. +checkTypeKind + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => SourceType + -> SourceType + -> m () +checkTypeKind ty kind = + unifyKindsWithFailure (\_ _ -> throwError . errorMessage $ ExpectedType ty kind) kind E.kindType + +unifyKindsWithFailure + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => (SourceType -> SourceType -> m ()) + -> SourceType + -> SourceType + -> m () +unifyKindsWithFailure onFailure = go + where + go = curry $ \case + (TypeApp _ p1 p2, TypeApp _ p3 p4) -> do + go p1 p3 + join $ go <$> apply p2 <*> apply p4 + (KindApp _ p1 p2, KindApp _ p3 p4) -> do + go p1 p3 + join $ go <$> apply p2 <*> apply p4 + (r1@(RCons _ _ _ _), r2) -> + unifyRows r1 r2 + (r1, r2@(RCons _ _ _ _)) -> + unifyRows r1 r2 + (r1@(REmpty _), r2) -> + unifyRows r1 r2 + (r1, r2@(REmpty _)) -> + unifyRows r1 r2 + (w1, w2) | eqType w1 w2 -> + pure () + (TUnknown _ a', p1) -> + solveUnknown a' p1 + (p1, TUnknown _ a') -> + solveUnknown a' p1 + (w1, w2) -> + onFailure w1 w2 + + unifyRows r1 r2 = do + let (matches, rest) = alignRowsWith go r1 r2 + sequence_ matches + unifyTails rest + + unifyTails = \case + (([], TUnknown _ a'), (rs, p1)) -> + solveUnknown a' $ rowFromList (rs, p1) + ((rs, p1), ([], TUnknown _ a')) -> + solveUnknown a' $ rowFromList (rs, p1) + (([], w1), ([], w2)) | eqType w1 w2 -> + pure () + ((rs1, TUnknown _ u1), (rs2, TUnknown _ u2)) -> do + rest <- freshKind nullSourceSpan + solveUnknown u1 $ rowFromList (rs2, rest) + solveUnknown u2 $ rowFromList (rs1, rest) + (w1, w2) -> + onFailure (rowFromList w1) (rowFromList w2) + +solveUnknown + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => Unknown + -> SourceType -> m () -unifyKinds k1 k2 = do - sub <- gets checkSubstitution - go (substituteKind sub k1) (substituteKind sub k2) +solveUnknown a' p1 = do + p2 <- promoteKind a' p1 + w1 <- snd <$> lookupUnsolved a' + join $ unifyKinds <$> apply w1 <*> elaborateKind p2 + solve a' p2 + +solveUnknownAsFunction + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => SourceAnn + -> Unknown + -> m SourceType +solveUnknownAsFunction ann u = do + lvl <- fst <$> lookupUnsolved u + u1 <- freshUnknown + u2 <- freshUnknown + addUnsolved (Just lvl) u1 E.kindType + addUnsolved (Just lvl) u2 E.kindType + let uarr = (TUnknown ann u1 E.-:> TUnknown ann u2) $> ann + solve u uarr + pure uarr + +promoteKind + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => Unknown + -> SourceType + -> m SourceType +promoteKind u2 ty = do + lvl2 <- fst <$> lookupUnsolved u2 + flip everywhereOnTypesM ty $ \case + ty'@(TUnknown ann u1) -> do + when (u1 == u2) . throwError . errorMessage . InfiniteKind $ ty + (lvl1, k) <- lookupUnsolved u1 + if lvl1 < lvl2 then + pure ty' + else do + k' <- promoteKind u2 =<< apply k + u1' <- freshUnknown + addUnsolved (Just lvl2) u1' k' + solve u1 $ TUnknown ann u1' + pure $ TUnknown ann u1' + ty' -> + pure ty' + +elaborateKind + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => SourceType + -> m SourceType +elaborateKind = \case + TypeLevelString ann _ -> + pure $ E.kindSymbol $> ann + TypeConstructor ann v -> do + env <- getEnv + case M.lookup v (E.types env) of + Nothing -> + throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v + Just (kind, _) -> + ($> ann) <$> apply kind + TypeVar ann a -> do + moduleName <- unsafeCheckCurrentModule + kind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing $ ProperName a) + pure (kind $> ann) + (Skolem ann _ mbK _ _) -> do + kind <- apply $ maybe (internalError "Skolem has no kind") id mbK + pure $ kind $> ann + TUnknown ann a' -> do + kind <- snd <$> lookupUnsolved a' + ($> ann) <$> apply kind + REmpty ann -> do + pure $ E.kindOfREmpty $> ann + RCons ann _ t1 _ -> do + k1 <- elaborateKind t1 + pure $ E.kindRow k1 $> ann + ty@(TypeApp ann t1 t2) -> do + k1 <- elaborateKind t1 + case k1 of + TypeApp _ (TypeApp _ k _) w2 | eqType k E.tyFunction -> do + pure $ w2 $> ann + -- Normally we wouldn't unify in `elaborateKind`, since an unknown should + -- always have a known kind. However, since type holes are fully inference + -- driven, they are unknowns with unknown kinds, which may require some + -- late unification here. + TUnknown a u -> do + _ <- solveUnknownAsFunction a u + elaborateKind ty + _ -> + cannotApplyTypeToType t1 t2 + KindApp ann t1 t2 -> do + k1 <- elaborateKind t1 + case k1 of + ForAll _ a _ n _ -> do + flip (replaceTypeVars a) n . ($> ann) <$> apply t2 + _ -> + cannotApplyKindToType t1 t2 + ForAll ann _ _ _ _ -> do + pure $ E.kindType $> ann + ConstrainedType ann _ _ -> + pure $ E.kindType $> ann + KindedType ann _ k -> + pure $ k $> ann + ty -> + throwError . errorMessage' (fst (getAnnForType ty)) $ UnsupportedTypeInKind ty + +checkEscapedSkolems :: MonadError MultipleErrors m => SourceType -> m () +checkEscapedSkolems ty = + traverse_ (throwError . toSkolemError) + . everythingWithContextOnTypes ty [] (<>) go + $ ty where - go (KUnknown _ u1) (KUnknown _ u2) | u1 == u2 = return () - go (KUnknown _ u) k = solveKind u k - go k (KUnknown _ u) = solveKind u k - go (NamedKind _ k1') (NamedKind _ k2') | k1' == k2' = return () - go (Row _ k1') (Row _ k2') = unifyKinds k1' k2' - go (FunKind _ k1' k2') (FunKind _ k3 k4) = do - unifyKinds k1' k3 - unifyKinds k2' k4 - go k1' k2' = - throwError - . errorMessage''' (fst . getAnnForKind <$> [k1', k2']) - $ KindsDoNotUnify k1' k2' + go :: SourceType -> SourceType -> (SourceType, [(SourceSpan, Text, SourceType)]) + go ty' = \case + Skolem ss name _ _ _ -> (ty', [(fst ss, name, ty')]) + ty''@(KindApp _ _ _) -> (ty'', []) + _ -> (ty', []) + + toSkolemError (ss, name, ty') = + errorMessage' (fst $ getAnnForType ty') $ EscapedSkolem name (Just ss) ty' + +kindOfWithUnknowns + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => SourceType + -> m (([(Unknown, SourceType)], SourceType), SourceType) +kindOfWithUnknowns ty = do + (ty', kind) <- kindOf ty + unks <- unknownsWithKinds . IS.toList $ unknowns ty' + pure ((unks, ty'), kind) -- | Infer the kind of a single type kindOf - :: (MonadError MultipleErrors m, MonadState CheckState m) + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) => SourceType - -> m SourceKind -kindOf ty = fst <$> kindOfWithScopedVars ty + -> m (SourceType, SourceType) +kindOf = fmap (first snd) . kindOfWithScopedVars -- | Infer the kind of a single type, returning the kinds of any scoped type variables -kindOfWithScopedVars :: - (MonadError MultipleErrors m, MonadState CheckState m) => - SourceType -> - m (SourceKind, [(Text, SourceKind)]) -kindOfWithScopedVars ty = - withErrorMessageHint (ErrorCheckingKind ty) $ - fmap tidyUp . withFreshSubstitution . captureSubstitution $ infer ty - where - tidyUp ((k, args), sub) = ( starIfUnknown (substituteKind sub k) - , map (second (starIfUnknown . substituteKind sub)) args - ) - --- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors -kindsOf - :: (MonadError MultipleErrors m, MonadState CheckState m) - => Bool - -> ModuleName - -> ProperName 'TypeName - -> [(Text, Maybe SourceKind)] - -> [SourceType] - -> m SourceKind -kindsOf isData moduleName name args ts = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do - tyCon <- freshKind' - kargs <- replicateM (length args) $ freshKind' - rest <- zipWithM freshKindVar args kargs - let dict = (name, tyCon) : rest - bindLocalTypeVariables moduleName dict $ - solveTypes isData ts kargs tyCon - where - tidyUp (k, sub) = starIfUnknown $ substituteKind sub k - -freshKindVar - :: (MonadError MultipleErrors m, MonadState CheckState m) - => (Text, Maybe SourceKind) - -> SourceKind - -> m (ProperName 'TypeName, SourceKind) -freshKindVar (arg, Nothing) kind = return (ProperName arg, kind) -freshKindVar (arg, Just kind') kind = do - unifyKinds kind kind' - return (ProperName arg, kind') - --- | Simultaneously infer the kinds of several mutually recursive type constructors -kindsOfAll - :: (MonadError MultipleErrors m, MonadState CheckState m) +kindOfWithScopedVars + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => SourceType + -> m (([(Text, SourceType)], SourceType), SourceType) +kindOfWithScopedVars ty = do + (ty', kind) <- bitraverse apply (replaceAllTypeSynonyms <=< apply) =<< inferKind ty + let binders = fst . fromJust $ completeBinderList ty' + pure ((snd <$> binders, ty'), kind) + +type DataDeclarationArgs = + ( SourceAnn + , ProperName 'TypeName + , [(Text, Maybe SourceType)] + , [DataConstructorDeclaration] + ) + +type DataDeclarationResult = + ( [(DataConstructorDeclaration, SourceType)] + -- ^ The infered type signatures of data constructors + , SourceType + -- ^ The inferred kind of the declaration + ) + +kindOfData + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + => ModuleName + -> DataDeclarationArgs + -> m DataDeclarationResult +kindOfData moduleName dataDecl = + head . (^. _2) <$> kindsOfAll moduleName [] [dataDecl] [] + +inferDataDeclaration + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + => ModuleName + -> DataDeclarationArgs + -> m [(DataConstructorDeclaration, SourceType)] +inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do + tyKind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing tyName) + let (sigBinders, tyKind') = fromJust . completeBinderList $ tyKind + bindLocalTypeVariables moduleName (first ProperName . snd <$> sigBinders) $ do + tyArgs' <- for tyArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< flip checkKind E.kindType + subsumesKind (foldr ((E.-:>) . snd) E.kindType tyArgs') tyKind' + bindLocalTypeVariables moduleName (first ProperName <$> tyArgs') $ do + let tyCtorName = srcTypeConstructor $ mkQualified tyName moduleName + tyCtor = foldl (\ty -> srcKindApp ty . srcTypeVar . fst . snd) tyCtorName sigBinders + tyCtor' = foldl (\ty -> srcTypeApp ty . srcTypeVar . fst) tyCtor tyArgs' + ctorBinders = fmap (fmap (fmap Just)) $ sigBinders <> fmap (nullSourceAnn,) tyArgs' + for ctors $ \ctor -> + fmap ((ctor,) . mkForAll ctorBinders) $ inferDataConstructor tyCtor' ctor + +inferDataConstructor + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + => SourceType + -> DataConstructorDeclaration + -> m SourceType +inferDataConstructor tyCtor = + flip checkKind E.kindType . foldr ((E.-:>) . snd) tyCtor . dataCtorFields + +type TypeDeclarationArgs = + ( SourceAnn + , ProperName 'TypeName + , [(Text, Maybe SourceType)] + , SourceType + ) + +type TypeDeclarationResult = + ( SourceType + -- ^ The elaborated rhs of the declaration + , SourceType + -- ^ The inferred kind of the declaration + ) + +kindOfTypeSynonym + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + => ModuleName + -> TypeDeclarationArgs + -> m TypeDeclarationResult +kindOfTypeSynonym moduleName typeDecl = + head . (^. _1) <$> kindsOfAll moduleName [typeDecl] [] [] + +inferTypeSynonym + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => ModuleName - -> [(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceKind)], SourceType)] - -> [(SourceAnn, ProperName 'TypeName, [(Text, Maybe SourceKind)], [SourceType])] - -> m ([SourceKind], [SourceKind]) -kindsOfAll moduleName syns tys = fmap tidyUp . withFreshSubstitution . captureSubstitution $ do - synVars <- for syns $ \(sa, _, _, _) -> freshKind sa - let dict = zipWith (\(_, name, _, _) var -> (name, var)) syns synVars - bindLocalTypeVariables moduleName dict $ do - tyCons <- for tys $ \(sa, _, _, _) -> freshKind sa - let dict' = zipWith (\(_, name, _, _) tyCon -> (name, tyCon)) tys tyCons - bindLocalTypeVariables moduleName dict' $ do - data_ks <- zipWithM (\tyCon (_, _, args, ts) -> do - kargs <- for args $ \(_, kind) -> maybe freshKind' (freshKind . getAnnForKind) kind - argDict <- zipWithM freshKindVar args kargs - bindLocalTypeVariables moduleName argDict $ - solveTypes True ts kargs tyCon) tyCons tys - syn_ks <- zipWithM (\synVar (_, _, args, ty) -> do - kargs <- for args $ \(_, kind) -> maybe freshKind' (freshKind . getAnnForKind) kind - argDict <- zipWithM freshKindVar args kargs - bindLocalTypeVariables moduleName argDict $ - solveTypes False [ty] kargs synVar) synVars syns - return (syn_ks, data_ks) + -> TypeDeclarationArgs + -> m SourceType +inferTypeSynonym moduleName (ann, tyName, tyArgs, tyBody) = do + tyKind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing tyName) + let (sigBinders, tyKind') = fromJust . completeBinderList $ tyKind + bindLocalTypeVariables moduleName (first ProperName . snd <$> sigBinders) $ do + kindRes <- freshKind (fst ann) + tyArgs' <- for tyArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< flip checkKind E.kindType + unifyKinds tyKind' $ foldr ((E.-:>) . snd) kindRes tyArgs' + bindLocalTypeVariables moduleName (first ProperName <$> tyArgs') $ do + tyBodyAndKind <- inferKind tyBody + instantiateKind tyBodyAndKind =<< apply kindRes + +-- | Checks that a particular generalization is valid and well-scoped. +-- | Implicitly generalized kinds are always elaborated before explicitly +-- | quantified type variables. It's possible that such a kind can be +-- | inserted before other variables that it depends on, making it +-- | ill-scoped. We require that users explicitly generalize this kind +-- | in such a case. +checkQuantification + :: forall m. (MonadError MultipleErrors m) + => SourceType + -> m () +checkQuantification ty = + collectErrors . go [] [] . fst . fromJust . completeBinderList $ ty where - tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . substituteKind sub) ks1, map (starIfUnknown . substituteKind sub) ks2) - --- | Solve the set of kind constraints associated with the data constructors for a type constructor -solveTypes - :: (MonadError MultipleErrors m, MonadState CheckState m) - => Bool - -> [SourceType] - -> [SourceKind] - -> SourceKind - -> m SourceKind -solveTypes isData ts kargs tyCon = do - ks <- traverse (fmap fst . infer) ts - when isData $ do - unifyKinds tyCon (foldr srcFunKind kindType kargs) - forM_ ks $ \k -> unifyKinds k (kindType $> getAnnForKind k) - unless isData $ - unifyKinds tyCon (foldr srcFunKind (head ks) kargs) - return tyCon - --- | Default all unknown kinds to the kindType kind of types -starIfUnknown :: Kind a -> Kind a -starIfUnknown (KUnknown ann _) = kindType $> ann -starIfUnknown (Row ann k) = Row ann (starIfUnknown k) -starIfUnknown (FunKind ann k1 k2) = FunKind ann (starIfUnknown k1) (starIfUnknown k2) -starIfUnknown k = k - --- | Infer a kind for a type -infer - :: (MonadError MultipleErrors m, MonadState CheckState m) + collectErrors vars = + unless (null vars) + . throwError + . foldMap (\(ann, arg) -> errorMessage' (fst ann) $ QuantificationCheckFailureInKind arg) + $ vars + + go acc _ [] = reverse acc + go acc sco ((_, (arg, k)) : rest) + | any (not . flip elem sco) $ freeTypeVariables k = goDeps acc arg rest + | otherwise = go acc (arg : sco) rest + + goDeps acc _ [] = acc + goDeps acc karg ((ann, (arg, k)) : rest) + | isDep && arg == karg = (ann, arg) : acc + | isDep = goDeps ((ann, arg) : acc) karg rest + | otherwise = goDeps acc karg rest + where + isDep = + elem karg $ freeTypeVariables k + +checkVisibleTypeQuantification + :: forall m. (MonadError MultipleErrors m) => SourceType - -> m (SourceKind, [(Text, SourceKind)]) -infer ty = - withErrorMessageHint (ErrorCheckingKind ty) - . rethrowWithPosition (fst $ getAnnForType ty) - $ infer' ty - -infer' - :: forall m - . (MonadError MultipleErrors m, MonadState CheckState m) + -> m () +checkVisibleTypeQuantification = + collectErrors . freeTypeVariables + where + collectErrors vars = + unless (null vars) + . throwError + . foldMap (errorMessage . VisibleQuantificationCheckFailureInType) + $ vars + +-- | Checks that there are no remaining unknowns in a type, and if so +-- | throws an error. This is necessary for contexts where we can't +-- | implicitly generalize unknowns, such as on the right-hand-side of +-- | a type synonym, or in arguments to data constructors. +checkTypeQuantification + :: forall m. (MonadError MultipleErrors m) => SourceType - -> m (SourceKind, [(Text, SourceKind)]) -infer' (ForAll ann ident mbK ty _) = do - k1 <- maybe (freshKind ann) pure mbK - moduleName <- unsafeCheckCurrentModule - (k2, args) <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty - unifyKinds k2 kindType - return (kindType, (ident, k1) : args) -infer' (KindedType _ ty k) = do - (k', args) <- infer ty - unifyKinds k k' - return (k', args) -infer' other = (, []) <$> go other + -> m () +checkTypeQuantification = + collectErrors . everythingWithContextOnTypes True [] (<>) unknownsInKinds where - go :: SourceType -> m SourceKind - go (ForAll ann ident mbK ty _) = do - k1 <- maybe (freshKind ann) pure mbK - moduleName <- unsafeCheckCurrentModule - k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ go ty - unifyKinds k2 kindType - return $ kindType $> ann - go (KindedType _ ty k) = do - k' <- go ty - unifyKinds k k' - return k' - go (TypeWildcard ann _) = freshKind ann - go (TUnknown ann _) = freshKind ann - go (TypeLevelString ann _) = return $ kindSymbol $> ann - go (TypeVar ann v) = do - moduleName <- unsafeCheckCurrentModule - ($> ann) <$> lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) - go (Skolem ann v _ _) = do - moduleName <- unsafeCheckCurrentModule - ($> ann) <$> lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) - go (TypeConstructor ann v) = do - env <- getEnv - case M.lookup v (types env) of - Nothing -> throwError . errorMessage' (fst ann) . UnknownName $ fmap TyName v - Just (kind, _) -> return $ kind $> ann - go (TypeApp ann t1 t2) = do - k0 <- freshKind ann - k1 <- go t1 - k2 <- go t2 - unifyKinds k1 (FunKind ann k2 k0) - return k0 - go (REmpty ann) = do - k <- freshKind ann - return $ Row ann k - go (RCons ann _ ty row) = do - k1 <- go ty - k2 <- go row - unifyKinds k2 (Row ann k1) - return $ Row ann k1 - go (ConstrainedType ann2 (Constraint ann1 className tys _) ty) = do - k1 <- go $ foldl (TypeApp ann2) (TypeConstructor ann1 (fmap coerceProperName className)) tys - unifyKinds k1 kindType - k2 <- go ty - unifyKinds k2 kindType - return $ kindType $> ann2 - go ty = internalError $ "Invalid argument to infer: " ++ show ty + collectErrors tysWithUnks = + unless (null tysWithUnks) . throwError . foldMap toMultipleErrors $ tysWithUnks + + toMultipleErrors (ss, unks, ty) = + errorMessage' ss $ QuantificationCheckFailureInType (IS.toList unks) ty + + unknownsInKinds False _ = (False, []) + unknownsInKinds _ ty = case ty of + ForAll sa _ _ _ _ | unks <- unknowns ty, not (IS.null unks) -> + (False, [(fst sa, unks, ty)]) + KindApp sa _ _ | unks <- unknowns ty, not (IS.null unks) -> + (False, [(fst sa, unks, ty)]) + ConstrainedType sa _ _ | unks <- unknowns ty, not (IS.null unks) -> + (False, [(fst sa, unks, ty)]) + _ -> + (True, []) + +type ClassDeclarationArgs = + ( SourceAnn + , ProperName 'ClassName + , [(Text, Maybe SourceType)] + , [SourceConstraint] + , [Declaration] + ) + +type ClassDeclarationResult = + ( [(Text, SourceType)] + -- ^ The kind annotated class arguments + , [SourceConstraint] + -- ^ The kind annotated superclass constraints + , [Declaration] + -- ^ The kind annotated declarations + , SourceType + -- ^ The inferred kind of the declaration + ) + +kindOfClass + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + => ModuleName + -> ClassDeclarationArgs + -> m ClassDeclarationResult +kindOfClass moduleName clsDecl = + head . (^. _3) <$> kindsOfAll moduleName [] [] [clsDecl] + +inferClassDeclaration + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + => ModuleName + -> ClassDeclarationArgs + -> m ([(Text, SourceType)], [SourceConstraint], [Declaration]) +inferClassDeclaration moduleName (ann, clsName, clsArgs, superClasses, decls) = do + clsKind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing $ coerceProperName clsName) + let (sigBinders, clsKind') = fromJust . completeBinderList $ clsKind + bindLocalTypeVariables moduleName (first ProperName . snd <$> sigBinders) $ do + clsArgs' <- for clsArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< flip checkKind E.kindType + unifyKinds clsKind' $ foldr ((E.-:>) . snd) E.kindConstraint clsArgs' + bindLocalTypeVariables moduleName (first ProperName <$> clsArgs') $ do + (clsArgs',,) + <$> for superClasses checkConstraint + <*> for decls checkClassMemberDeclaration + +checkClassMemberDeclaration + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + => Declaration + -> m Declaration +checkClassMemberDeclaration = \case + TypeDeclaration (TypeDeclarationData ann ident ty) -> + TypeDeclaration . TypeDeclarationData ann ident <$> checkKind ty E.kindType + _ -> internalError "Invalid class member declaration" + +applyClassMemberDeclaration + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + => Declaration + -> m Declaration +applyClassMemberDeclaration = \case + TypeDeclaration (TypeDeclarationData ann ident ty) -> + TypeDeclaration . TypeDeclarationData ann ident <$> apply ty + _ -> internalError "Invalid class member declaration" + +mapTypeDeclaration :: (SourceType -> SourceType) -> Declaration -> Declaration +mapTypeDeclaration f = \case + TypeDeclaration (TypeDeclarationData ann ident ty) -> + TypeDeclaration . TypeDeclarationData ann ident $ f ty + other -> + other + +checkConstraint + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + => SourceConstraint + -> m SourceConstraint +checkConstraint (Constraint ann clsName kinds args dat) = do + let ty = foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) kinds) args + (_, kinds', args') <- unapplyTypes <$> checkKind ty E.kindConstraint + pure $ Constraint ann clsName kinds' args' dat + +applyConstraint + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + => SourceConstraint + -> m SourceConstraint +applyConstraint (Constraint ann clsName kinds args dat) = do + let ty = foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) kinds) args + (_, kinds', args') <- unapplyTypes <$> apply ty + pure $ Constraint ann clsName kinds' args' dat + +type InstanceDeclarationArgs = + ( SourceAnn + , [SourceConstraint] + , Qualified (ProperName 'ClassName) + , [SourceType] + ) + +type InstanceDeclarationResult = + ( [SourceConstraint] + , [SourceType] + , [SourceType] + , [(Text, SourceType)] + ) + +checkInstanceDeclaration + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + => ModuleName + -> InstanceDeclarationArgs + -> m InstanceDeclarationResult +checkInstanceDeclaration moduleName (ann, constraints, clsName, args) = do + let ty = foldl (TypeApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) args + tyWithConstraints = foldr srcConstrainedType ty constraints + freeVars = freeTypeVariables tyWithConstraints + freeVarsDict <- for freeVars $ \v -> (ProperName v,) <$> freshKind (fst ann) + bindLocalTypeVariables moduleName freeVarsDict $ do + ty' <- checkKind ty E.kindConstraint + constraints' <- for constraints checkConstraint + allTy <- apply $ foldr srcConstrainedType ty' constraints' + allUnknowns <- unknownsWithKinds . IS.toList $ unknowns allTy + let unknownVars = unknownVarNames (usedTypeVariables allTy) allUnknowns + let allWithVars = replaceUnknownsWithVars unknownVars allTy + let (allConstraints, (_, allKinds, allArgs)) = unapplyTypes <$> unapplyConstraints allWithVars + varKinds <- traverse (traverse (fmap (replaceUnknownsWithVars unknownVars) . apply)) $ (snd <$> unknownVars) <> (first runProperName <$> freeVarsDict) + pure (allConstraints, allKinds, allArgs, varKinds) + +checkKindDeclaration + :: forall m. (MonadSupply m, MonadError MultipleErrors m, MonadState CheckState m) + => ModuleName + -> SourceType + -> m SourceType +checkKindDeclaration _ ty = do + (ty', kind) <- kindOf ty + checkTypeKind kind E.kindType + ty'' <- replaceAllTypeSynonyms ty' + unks <- unknownsWithKinds . IS.toList $ unknowns ty'' + freshUnks <- traverse (traverse (\k -> (,k) <$> freshVar "k")) unks + finalTy <- generalizeUnknownsWithVars freshUnks <$> freshenForAlls ty' ty'' + checkQuantification finalTy + checkValidKind finalTy + where + -- When expanding type synoyms and generalizing, we need to generate more + -- unique names so that they don't clash or shadow other names, or can + -- be referenced (easily). + freshVar arg = (arg <>) . T.pack . show <$> fresh + freshenForAlls = curry $ \case + (ForAll _ v1 _ ty1 _, ForAll a2 v2 k2 ty2 sc2) | v1 == v2 -> do + ty2' <- freshenForAlls ty1 ty2 + pure $ ForAll a2 v2 k2 ty2' sc2 + (_, ty2) -> go ty2 where + go = \case + ForAll a' v' k' ty' sc' -> do + v'' <- freshVar v' + ty'' <- go (replaceTypeVars v' (TypeVar a' v'') ty') + pure $ ForAll a' v'' k' ty'' sc' + other -> pure other + + checkValidKind = everywhereOnTypesM $ \case + ty'@(ConstrainedType ann _ _) -> + throwError . errorMessage' (fst ann) $ UnsupportedTypeInKind ty' + other -> pure other + +existingSignatureOrFreshKind + :: forall m. MonadState CheckState m + => ModuleName + -> SourceSpan + -> ProperName 'TypeName + -> m SourceType +existingSignatureOrFreshKind moduleName ss name = do + env <- getEnv + case M.lookup (Qualified (Just moduleName) name) (E.types env) of + Nothing -> freshKind ss + Just (kind, _) -> pure kind + +kindsOfAll + :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) + => ModuleName + -> [TypeDeclarationArgs] + -> [DataDeclarationArgs] + -> [ClassDeclarationArgs] + -> m ([TypeDeclarationResult], [DataDeclarationResult], [ClassDeclarationResult]) +kindsOfAll moduleName syns dats clss = withFreshSubstitution $ do + synDict <- for syns $ \(sa, synName, _, _) -> fmap (synName,) $ existingSignatureOrFreshKind moduleName (fst sa) synName + datDict <- for dats $ \(sa, datName, _, _) -> fmap (datName,) $ existingSignatureOrFreshKind moduleName (fst sa) datName + clsDict <- for clss $ \(sa, clsName, _, _, _) -> fmap (coerceProperName clsName,) $ existingSignatureOrFreshKind moduleName (fst sa) $ coerceProperName clsName + let bindingGroup = synDict <> datDict <> clsDict + bindLocalTypeVariables moduleName bindingGroup $ do + synResults <- for syns (inferTypeSynonym moduleName) + datResults <- for dats (inferDataDeclaration moduleName) + clsResults <- for clss (inferClassDeclaration moduleName) + synResultsWithUnks <- for (zip synDict synResults) $ \((synName, synKind), synBody) -> do + synKind' <- apply synKind + synBody' <- apply synBody + pure (((synName, synKind'), synBody'), unknowns synKind') + datResultsWithUnks <- for (zip datDict datResults) $ \((datName, datKind), ctors) -> do + datKind' <- apply datKind + ctors' <- traverse (traverse apply) ctors + pure (((datName, datKind'), ctors'), unknowns datKind') + clsResultsWithUnks <- for (zip clsDict clsResults) $ \((clsName, clsKind), (args, supers, decls)) -> do + clsKind' <- apply clsKind + args' <- traverse (traverse apply) args + supers' <- traverse applyConstraint supers + decls' <- traverse applyClassMemberDeclaration decls + pure (((clsName, clsKind'), (args', supers', decls')), unknowns clsKind') + let synUnks = fmap (\(((synName, _), _), unks) -> (synName, unks)) synResultsWithUnks + datUnks = fmap (\(((datName, _), _), unks) -> (datName, unks)) datResultsWithUnks + clsUnks = fmap (\(((clsName, _), _), unks) -> (clsName, unks)) clsResultsWithUnks + tysUnks = synUnks <> datUnks <> clsUnks + allUnks <- unknownsWithKinds . IS.toList $ foldMap snd tysUnks + let mkTySub (name, unks) = do + let tyCtorName = mkQualified name moduleName + tyUnks = filter (flip IS.member unks . fst) allUnks + tyCtor = foldl (\ty -> srcKindApp ty . TUnknown nullSourceAnn . fst) (srcTypeConstructor tyCtorName) tyUnks + (tyCtorName, (tyCtor, tyUnks)) + tySubs = fmap mkTySub tysUnks + replaceTypeCtors = everywhereOnTypes $ \case + TypeConstructor _ name + | Just (tyCtor, _) <- lookup name tySubs -> tyCtor + other -> other + clsResultsWithKinds = flip fmap clsResultsWithUnks $ \(((clsName, clsKind), (args, supers, decls)), _) -> do + let tyUnks = snd . fromJust $ lookup (mkQualified clsName moduleName) tySubs + (usedTypeVariablesInDecls, _, _, _, _) = accumTypes usedTypeVariables + usedVars = usedTypeVariables clsKind + <> foldMap (usedTypeVariables . snd) args + <> foldMap (foldMap usedTypeVariables . (\c -> constraintKindArgs c <> constraintArgs c)) supers + <> foldMap usedTypeVariablesInDecls decls + unkBinders = unknownVarNames usedVars tyUnks + args' = fmap (replaceUnknownsWithVars unkBinders . replaceTypeCtors) <$> args + supers' = mapConstraintArgsAll (fmap (replaceUnknownsWithVars unkBinders . replaceTypeCtors)) <$> supers + decls' = mapTypeDeclaration (replaceUnknownsWithVars unkBinders . replaceTypeCtors) <$> decls + (args', supers', decls', generalizeUnknownsWithVars unkBinders clsKind) + datResultsWithKinds <- for datResultsWithUnks $ \(((datName, datKind), ctors), _) -> do + let tyUnks = snd . fromJust $ lookup (mkQualified datName moduleName) tySubs + ctors' = fmap (fmap (generalizeUnknowns tyUnks . replaceTypeCtors)) ctors + traverse_ (traverse_ checkTypeQuantification) ctors' + pure (ctors', generalizeUnknowns tyUnks datKind) + synResultsWithKinds <- for synResultsWithUnks $ \(((synName, synKind), synBody), _) -> do + let tyUnks = snd . fromJust $ lookup (mkQualified synName moduleName) tySubs + unkBinders = unknownVarNames (usedTypeVariables synKind <> usedTypeVariables synBody) tyUnks + genBody = replaceUnknownsWithVars unkBinders $ replaceTypeCtors synBody + genSig = generalizeUnknownsWithVars unkBinders synKind + checkEscapedSkolems genBody + checkTypeQuantification genBody + checkVisibleTypeQuantification genSig + pure (genBody, genSig) + pure (synResultsWithKinds, datResultsWithKinds, clsResultsWithKinds) diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 2933173d5b..26daaf5903 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -13,23 +13,43 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State import Control.Monad.Writer.Class (MonadWriter(..), censor) +import Data.List (intercalate) import Data.Maybe import qualified Data.Map as M -import Data.Text (Text) +import Data.Text (Text, isPrefixOf, unpack) import qualified Data.List.NonEmpty as NEL import Language.PureScript.Crash (internalError) import Language.PureScript.Environment import Language.PureScript.Errors -import Language.PureScript.Kinds import Language.PureScript.Names +import Language.PureScript.Pretty.Types +import Language.PureScript.Pretty.Values import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types - --- | A substitution of unification variables for types or kinds +import Text.PrettyPrint.Boxes (render) + +newtype UnkLevel = UnkLevel (NEL.NonEmpty Unknown) + deriving (Eq, Show) + +-- This instance differs from the NEL instance in that longer but otherwise +-- equal paths are LT rather than GT. An extended path puts it *before* its root. +instance Ord UnkLevel where + compare (UnkLevel a) (UnkLevel b) = + go (NEL.toList a) (NEL.toList b) + where + go [] [] = EQ + go _ [] = LT + go [] _ = GT + go (x:xs) (y:ys) = + compare x y <> go xs ys + +-- | A substitution of unification variables for types. data Substitution = Substitution - { substType :: M.Map Int SourceType -- ^ Type substitution - , substKind :: M.Map Int SourceKind -- ^ Kind substitution + { substType :: M.Map Int SourceType + -- ^ Type substitution + , substUnsolved :: M.Map Int (UnkLevel, SourceType) + -- ^ Unsolved unification variables with their level (scope ordering) and kind } -- | An empty substitution @@ -42,8 +62,6 @@ data CheckState = CheckState -- ^ The current @Environment@ , checkNextType :: Int -- ^ The next type unification variable - , checkNextKind :: Int - -- ^ The next kind unification variable , checkNextSkolem :: Int -- ^ The next skolem variable , checkNextSkolemScope :: Int @@ -61,7 +79,7 @@ data CheckState = CheckState -- | Create an empty @CheckState@ emptyCheckState :: Environment -> CheckState -emptyCheckState env = CheckState env 0 0 0 0 Nothing emptySubstitution [] +emptyCheckState env = CheckState env 0 0 0 Nothing emptySubstitution [] -- | Unification variables type Unknown = Int @@ -82,7 +100,7 @@ bindNames newNames action = do -- | Temporarily bind a collection of names to types bindTypes :: MonadState CheckState m - => M.Map (Qualified (ProperName 'TypeName)) (SourceKind, TypeKind) + => M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) -> m a -> m a bindTypes newNames action = do @@ -96,7 +114,7 @@ bindTypes newNames action = do withScopedTypeVars :: (MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName - -> [(Text, SourceKind)] + -> [(Text, SourceType)] -> m a -> m a withScopedTypeVars mn ks ma = do @@ -193,7 +211,7 @@ bindLocalVariables bindings = bindLocalTypeVariables :: (MonadState CheckState m) => ModuleName - -> [(ProperName 'TypeName, SourceKind)] + -> [(ProperName 'TypeName, SourceType)] -> m a -> m a bindLocalTypeVariables moduleName bindings = @@ -253,7 +271,7 @@ lookupTypeVariable :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified (ProperName 'TypeName) - -> m SourceKind + -> m SourceType lookupTypeVariable currentModule (Qualified moduleName name) = do env <- getEnv case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of @@ -332,3 +350,106 @@ unsafeCheckCurrentModule unsafeCheckCurrentModule = checkCurrentModule <$> get >>= \case Nothing -> internalError "No module name set in scope" Just name -> pure name + +debugEnv :: Environment -> [String] +debugEnv env = join + [ debugTypes env + , debugTypeSynonyms env + , debugTypeClasses env + , debugTypeClassDictionaries env + , debugDataConstructors env + , debugNames env + ] + +debugType :: Type a -> String +debugType = init . prettyPrintType 100 + +debugConstraint :: Constraint a -> String +debugConstraint (Constraint ann clsName kinds args _) = + debugType $ foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) kinds) args + +debugTypes :: Environment -> [String] +debugTypes = go <=< M.toList . types + where + go (qual, (srcTy, which)) = do + let + ppTy = prettyPrintType 100 srcTy + name = showQualified runProperName qual + decl = case which of + DataType _ _ -> "data" + TypeSynonym -> "type" + ExternData -> "extern" + LocalTypeVariable -> "local" + ScopedTypeVar -> "scoped" + guard (not (isPrefixOf "Prim" name)) + pure $ decl <> " " <> unpack name <> " :: " <> init ppTy + +debugNames :: Environment -> [String] +debugNames = fmap go . M.toList . names + where + go (qual, (srcTy, _, _)) = do + let + ppTy = prettyPrintType 100 srcTy + name = showQualified runIdent qual + unpack name <> " :: " <> init ppTy + +debugDataConstructors :: Environment -> [String] +debugDataConstructors = fmap go . M.toList . dataConstructors + where + go (qual, (_, _, ty, _)) = do + let + ppTy = prettyPrintType 100 ty + name = showQualified runProperName qual + unpack name <> " :: " <> init ppTy + +debugTypeSynonyms :: Environment -> [String] +debugTypeSynonyms = fmap go . M.toList . typeSynonyms + where + go (qual, (binders, subTy)) = do + let + vars = intercalate " " $ flip fmap binders $ \case + (v, Just k) -> "(" <> unpack v <> " :: " <> init (prettyPrintType 100 k) <> ")" + (v, Nothing) -> unpack v + ppTy = prettyPrintType 100 subTy + name = showQualified runProperName qual + "type " <> unpack name <> " " <> vars <> " = " <> init ppTy + +debugTypeClassDictionaries :: Environment -> [String] +debugTypeClassDictionaries = go . typeClassDictionaries + where + go tcds = do + (mbModuleName, classes) <- M.toList tcds + (className, instances) <- M.toList classes + (ident, dicts) <- M.toList instances + let + moduleName = maybe "" (\m -> "[" <> runModuleName m <> "] ") mbModuleName + className' = showQualified runProperName className + ident' = showQualified runIdent ident + kds = intercalate " " $ fmap ((\a -> "@(" <> a <> ")") . debugType) $ tcdInstanceKinds $ NEL.head dicts + tys = intercalate " " $ fmap ((\a -> "(" <> a <> ")") . debugType) $ tcdInstanceTypes $ NEL.head dicts + pure $ "dict " <> unpack moduleName <> unpack className' <> " " <> unpack ident' <> " (" <> show (length dicts) <> ")" <> " " <> kds <> " " <> tys + +debugTypeClasses :: Environment -> [String] +debugTypeClasses = fmap go . M.toList . typeClasses + where + go (className, tc) = do + let + className' = showQualified runProperName className + args = intercalate " " $ fmap (\(a, b) -> "(" <> debugType (maybe (srcTypeVar a) (srcKindedType (srcTypeVar a)) b) <> ")") $ typeClassArguments tc + "class " <> unpack className' <> " " <> args + +debugValue :: Expr -> String +debugValue = init . render . prettyPrintValue 100 + +debugSubstitution :: Substitution -> [String] +debugSubstitution (Substitution solved unsolved) = + fmap go1 (M.toList solved) <> fmap go2 (M.toList unsolved') + where + unsolved' = + M.filterWithKey (\k _ -> M.notMember k solved) unsolved + + go1 (u, ty) = + "?" <> show u <> " = " <> debugType ty + + go2 (u, (_, k)) = + "?" <> show u <> " :: " <> debugType k diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index 43ac7f742c..5edbad4b80 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -17,7 +17,6 @@ import qualified Data.Set as S import Data.Text (Text) import Language.PureScript.Environment -import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Roles import Language.PureScript.Types @@ -95,7 +94,8 @@ inferRoles env tyName -- type beneath. walk btvs t walk btvs t - | Just (t1, t2s) <- splitTypeApp t = + | (t1, _, t2s) <- unapplyTypes t + , not $ null t2s = case t1 of -- If the type is an application of a type constructor to some -- arguments, recursively infer the roles of the type constructor's @@ -138,12 +138,12 @@ inferRoles env tyName -- Given the kind of a foreign type, generate a list @Nominal@ roles which, in -- the absence of a role signature, provides the safest default for a type whose -- constructors are opaque to us. -rolesFromForeignTypeKind :: SourceKind -> [Role] +rolesFromForeignTypeKind :: SourceType -> [Role] rolesFromForeignTypeKind = go [] where go acc = \case - FunKind _ k1 _k2 -> + TypeApp _ (TypeApp _ fn k1) _k2 | eqType fn tyFunction -> go (Nominal : acc) k1 _k -> Nominal : acc diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index bfd47dde20..89ba0262d8 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -45,14 +45,14 @@ newSkolemScope = do return $ SkolemScope s -- | Skolemize a type variable by replacing its instances with fresh skolem constants -skolemize :: a -> Text -> Int -> SkolemScope -> Type a -> Type a -skolemize ann ident sko scope = replaceTypeVars ident (Skolem ann ident sko scope) +skolemize :: a -> Text -> Maybe (Type a) -> Int -> SkolemScope -> Type a -> Type a +skolemize ann ident mbK sko scope = replaceTypeVars ident (Skolem ann ident mbK sko scope) -- | This function skolemizes type variables appearing in any type signatures or -- 'DeferredDictionary' placeholders. These type variables are the only places -- where scoped type variables can appear in expressions. -skolemizeTypesInValue :: SourceAnn -> Text -> Int -> SkolemScope -> Expr -> Expr -skolemizeTypesInValue ann ident sko scope = +skolemizeTypesInValue :: SourceAnn -> Text -> Maybe SourceType -> Int -> SkolemScope -> Expr -> Expr +skolemizeTypesInValue ann ident mbK sko scope = runIdentity . onExpr' where onExpr' :: Expr -> Identity Expr @@ -60,14 +60,14 @@ skolemizeTypesInValue ann ident sko scope = onExpr :: [Text] -> Expr -> Identity ([Text], Expr) onExpr sco (DeferredDictionary c ts) - | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ann ident sko scope) ts)) + | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ann ident mbK sko scope) ts)) onExpr sco (TypedValue check val ty) - | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ann ident sko scope ty)) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ann ident mbK sko scope ty)) onExpr sco other = return (sco, other) onBinder :: [Text] -> Binder -> Identity ([Text], Binder) onBinder sco (TypedBinder ty b) - | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ann ident sko scope ty) b) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ann ident mbK sko scope ty) b) onBinder sco other = return (sco, other) peelTypeVars :: SourceType -> [Text] @@ -123,7 +123,7 @@ skolemEscapeCheck expr@TypedValue{} = -- Collect any skolem variables appearing in a type collectSkolems :: SourceType -> [(SourceAnn, Text, SkolemScope)] collectSkolems = everythingOnTypes (++) collect where - collect (Skolem ss name _ scope) = [(ss, name, scope)] + collect (Skolem ss name _ _ scope) = [(ss, name, scope)] collect _ = [] go scos _ = (scos, []) skolemEscapeCheck _ = internalError "skolemEscapeCheck: untyped value" diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index d85d905144..ae7d22868c 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -75,14 +75,15 @@ subsumes' -> SourceType -> SourceType -> m (Coercion mode) -subsumes' mode (ForAll _ ident _ ty1 _) ty2 = do - replaced <- replaceVarWithUnknown ident ty1 +subsumes' mode (ForAll _ ident mbK ty1 _) ty2 = do + u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK + let replaced = replaceTypeVars ident u ty1 subsumes' mode replaced ty2 -subsumes' mode ty1 (ForAll _ ident _ ty2 sco) = +subsumes' mode ty1 (ForAll _ ident mbK ty2 sco) = case sco of Just sco' -> do sko <- newSkolemConstant - let sk = skolemize NullSourceAnn ident sko sco' ty2 + let sk = skolemize NullSourceAnn ident mbK sko sco' ty2 subsumes' mode ty1 sk Nothing -> internalError "subsumes: unspecified skolem scope" subsumes' mode (TypeApp _ (TypeApp _ f1 arg1) ret1) (TypeApp _ (TypeApp _ f2 arg2) ret2) | eqType f1 tyFunction && eqType f2 tyFunction = do @@ -108,9 +109,9 @@ subsumes' mode (TypeApp _ f1 r1) (TypeApp _ f2 r2) | eqType f1 tyRecord && eqTyp -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property. -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has -- an additional property which is not allowed. - when (eqType r1' $ REmpty ()) + when (isREmpty r1') (for_ (firstMissingProp ts2' ts1') (throwError . errorMessage . PropertyIsMissing . rowListLabel)) - when (eqType r2' $ REmpty ()) + when (isREmpty r2') (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . rowListLabel)) -- Check subsumption for common labels sequence_ common diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 7d5d250e94..cbc3a9a83a 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -5,6 +5,7 @@ -- module Language.PureScript.TypeChecker.Synonyms ( SynonymMap + , KindMap , replaceAllTypeSynonyms , replaceAllTypeSynonymsM ) where @@ -18,45 +19,54 @@ import qualified Data.Map as M import Data.Text (Text) import Language.PureScript.Environment import Language.PureScript.Errors -import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types -- | Type synonym information (arguments with kinds, aliased type), indexed by name -type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceKind)], SourceType) +type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType) + +type KindMap = M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) replaceAllTypeSynonyms' :: SynonymMap + -> KindMap -> SourceType -> Either MultipleErrors SourceType -replaceAllTypeSynonyms' syns = everywhereOnTypesTopDownM try +replaceAllTypeSynonyms' syns kinds = everywhereOnTypesTopDownM try where try :: SourceType -> Either MultipleErrors SourceType - try t = fromMaybe t <$> go 0 [] t + try t = fromMaybe t <$> go 0 [] [] t - go :: Int -> [SourceType] -> SourceType -> Either MultipleErrors (Maybe SourceType) - go c args (TypeConstructor _ ctor) + go :: Int -> [SourceType] -> [SourceType] -> SourceType -> Either MultipleErrors (Maybe SourceType) + go c kargs args (TypeConstructor _ ctor) | Just (synArgs, body) <- M.lookup ctor syns , c == length synArgs - = let repl = replaceAllTypeVars (zip (map fst synArgs) args) body + , kindArgs <- lookupKindArgs ctor + , length kargs == length kindArgs + = let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body in Just <$> try repl | Just (synArgs, _) <- M.lookup ctor syns , length synArgs > c = throwError . errorMessage $ PartiallyAppliedSynonym ctor - go c args (TypeApp _ f arg) = go (c + 1) (arg : args) f - go _ _ _ = return Nothing + go c kargs args (TypeApp _ f arg) = go (c + 1) kargs (arg : args) f + go c kargs args (KindApp _ f arg) = go c (arg : kargs) args f + go _ _ _ _ = return Nothing + + lookupKindArgs :: Qualified (ProperName 'TypeName) -> [Text] + lookupKindArgs ctor = fromMaybe [] $ fmap (fmap (fst . snd) . fst) . completeBinderList . fst =<< M.lookup ctor kinds -- | Replace fully applied type synonyms replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => SourceType -> m SourceType replaceAllTypeSynonyms d = do env <- getEnv - either throwError return $ replaceAllTypeSynonyms' (typeSynonyms env) d + either throwError return $ replaceAllTypeSynonyms' (typeSynonyms env) (types env) d -- | Replace fully applied type synonyms by explicitly providing a 'SynonymMap'. replaceAllTypeSynonymsM :: MonadError MultipleErrors m => SynonymMap + -> KindMap -> SourceType -> m SourceType -replaceAllTypeSynonymsM syns = either throwError pure . replaceAllTypeSynonyms' syns +replaceAllTypeSynonymsM syns kinds = either throwError pure . replaceAllTypeSynonyms' syns kinds diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index a636e3503f..1e05fbd4f5 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -93,8 +93,8 @@ accessorSearch unsolved env st userT = maybe ([], []) fst $ checkInEnvironment e userT' <- initializeSkolems userT - rowType <- freshType - resultType <- freshType + rowType <- freshTypeWithKind (P.kindRow P.kindType) + resultType <- freshTypeWithKind P.kindType let recordFunction = srcTypeApp (srcTypeApp tyFunction (srcTypeApp tyRecord rowType)) resultType _ <- subsumes recordFunction userT' subst <- gets TC.checkSubstitution diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 24e1d9710a..4196d0e7d9 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -6,6 +6,7 @@ module Language.PureScript.TypeChecker.Types ( BindingGroupType(..) , typesOf + , checkTypeKind ) where {- @@ -39,16 +40,17 @@ import Data.Either (partitionEithers) import Data.Functor (($>)) import Data.List (transpose, (\\), partition, delete) import Data.Maybe (fromMaybe) +import Data.Text (Text) import Data.Traversable (for) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.IntSet as IS import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors -import Language.PureScript.Kinds import Language.PureScript.Names import Language.PureScript.Traversals import Language.PureScript.TypeChecker.Entailment @@ -96,8 +98,10 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -- Generalize and constrain the type currentSubst <- gets checkSubstitution let ty' = substituteType currentSubst ty - unsolvedTypeVars = ordNub $ unknownsInType ty' - generalized = generalize unsolved ty' + ty'' = constrain unsolved ty' + unsolvedTypeVarsWithKinds <- unknownsWithKinds . IS.toList . unknowns $ constrain unsolved ty'' + let unsolvedTypeVars = IS.toList $ unknowns ty' + generalized = varIfUnknown unsolvedTypeVarsWithKinds ty'' when shouldGeneralize $ do -- Show the inferred type in a warning @@ -141,8 +145,8 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do lookupUnknowns = atMay conArgUnknowns unknownsDetermined :: Maybe (S.Set Int) -> Bool unknownsDetermined Nothing = False - unknownsDetermined (Just unknowns) = - unknowns `S.isSubsetOf` determined + unknownsDetermined (Just unks) = + unks `S.isSubsetOf` determined -- If all of the determining arguments of a particular fundep are -- already determined, add the determined arguments from the fundep tcDep <- tcDeps @@ -150,7 +154,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do map (fromMaybe S.empty . lookupUnknowns) (fdDetermined tcDep) -- These unknowns can be determined from the body of the inferred -- type (i.e. excluding the unknowns mentioned in the constraints) - let determinedFromType = S.fromList . map snd $ unsolvedTypeVars + let determinedFromType = S.fromList unsolvedTypeVars -- These are all the unknowns mentioned in the constraints let constraintTypeVars = fold (conData >>= snd) let solved = solveFrom determinedFromType @@ -201,9 +205,6 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do in ErrorMessage hints (HoleInferredType x ty y (Just searchResult)) other -> other - -- | Generalize type vars using forall and add inferred constraints - generalize unsolved = varIfUnknown . constrain unsolved - -- | Add any unsolved constraints constrain cs ty = foldr srcConstrainedType ty (map (\(_, _, x) -> x) cs) @@ -222,7 +223,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do data SplitBindingGroup = SplitBindingGroup { _splitBindingGroupUntyped :: [((SourceAnn, Ident), (Expr, SourceType))] -- ^ The untyped expressions - , _splitBindingGroupTyped :: [((SourceAnn, Ident), (Expr, SourceType, Bool))] + , _splitBindingGroupTyped :: [((SourceAnn, Ident), (Expr, [(Text, SourceType)], SourceType, Bool))] -- ^ The typed expressions, along with their type annotations , _splitBindingGroupNames :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ A map containing all expressions and their assigned types (which might be @@ -236,7 +237,7 @@ data SplitBindingGroup = SplitBindingGroup -- This function also generates fresh unification variables for the types of -- declarations without type annotations, returned in the 'UntypedData' structure. typeDictionaryForBindingGroup - :: (MonadState CheckState m, MonadWriter MultipleErrors m) + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Maybe ModuleName -> [((SourceAnn, Ident), Expr)] -> m SplitBindingGroup @@ -246,11 +247,13 @@ typeDictionaryForBindingGroup moduleName vals = do -- fully expanded types. let (untyped, typed) = partitionEithers (map splitTypeAnnotation vals) (typedDict, typed') <- fmap unzip . for typed $ \(sai, (expr, ty, checkType)) -> do - ty' <- replaceTypeWildcards ty - return ((sai, ty'), (sai, (expr, ty', checkType))) + ((args, elabTy), kind) <- kindOfWithScopedVars ty + checkTypeKind ty kind + elabTy' <- replaceTypeWildcards elabTy + return ((sai, elabTy'), (sai, (expr, args, elabTy', checkType))) -- Create fresh unification variables for the types of untyped declarations (untypedDict, untyped') <- fmap unzip . for untyped $ \(sai, expr) -> do - ty <- freshType + ty <- freshTypeWithKind kindType return ((sai, ty), (sai, (expr, ty))) -- Create the dictionary of all name/type pairs, which will be added to the -- environment during type checking @@ -273,15 +276,12 @@ typeDictionaryForBindingGroup moduleName vals = do checkTypedBindingGroupElement :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName - -> ((SourceAnn, Ident), (Expr, SourceType, Bool)) + -> ((SourceAnn, Ident), (Expr, [(Text, SourceType)], SourceType, Bool)) -- ^ The identifier we are trying to define, along with the expression and its type annotation -> M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ Names brought into scope in this binding group -> m ((SourceAnn, Ident), (Expr, SourceType)) -checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do - -- Kind check - (kind, args) <- kindOfWithScopedVars ty - checkTypeKind ty kind +checkTypedBindingGroupElement mn (ident, (val, args, ty, checkType)) dict = do -- We replace type synonyms _after_ kind-checking, since we don't want type -- synonym expansion to bring type variables into scope. See #2542. ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty @@ -307,14 +307,6 @@ typeForBindingGroupElement (ident, (val, ty)) dict = do unifyTypes ty ty' return (ident, (TypedValue True val' ty', ty')) --- | Check the kind of a type, failing if it is not of kind *. -checkTypeKind - :: MonadError MultipleErrors m - => SourceType - -> SourceKind - -> m () -checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ isKindType kind - -- | Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns -- or TypeClassDictionary values. -- @@ -325,13 +317,13 @@ instantiatePolyTypeWithUnknowns => Expr -> SourceType -> m (Expr, SourceType) -instantiatePolyTypeWithUnknowns val (ForAll _ ident _ ty _) = do - ty' <- replaceVarWithUnknown ident ty - instantiatePolyTypeWithUnknowns val ty' +instantiatePolyTypeWithUnknowns val (ForAll _ ident mbK ty _) = do + u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK + instantiatePolyTypeWithUnknowns val $ replaceTypeVars ident u ty instantiatePolyTypeWithUnknowns val (ConstrainedType _ con ty) = do - dicts <- getTypeClassDictionaries - hints <- getHints - instantiatePolyTypeWithUnknowns (App val (TypeClassDictionary con dicts hints)) ty + dicts <- getTypeClassDictionaries + hints <- getHints + instantiatePolyTypeWithUnknowns (App val (TypeClassDictionary con dicts hints)) ty instantiatePolyTypeWithUnknowns val ty = return (val, ty) -- | Infer a type for a value, rethrowing any error to provide a more useful error message @@ -354,7 +346,7 @@ infer' v@(Literal _ (CharLiteral _)) = return $ TypedValue' True v tyChar infer' v@(Literal _ (BooleanLiteral _)) = return $ TypedValue' True v tyBoolean infer' (Literal ss (ArrayLiteral vals)) = do ts <- traverse infer vals - els <- freshType + els <- freshTypeWithKind kindType ts' <- forM ts $ \(TypedValue' ch val t) -> do (val', t') <- instantiatePolyTypeWithUnknowns val t unifyTypes els t' @@ -381,27 +373,27 @@ infer' (Literal ss (ObjectLiteral ps)) = do toRowListItem (lbl, (_, ty)) = srcRowListItem (Label lbl) ty fields <- forM ps inferProperty - let ty = srcTypeApp tyRecord $ rowFromList (map toRowListItem fields, srcREmpty) + let ty = srcTypeApp tyRecord $ rowFromList (map toRowListItem fields, srcKindApp srcREmpty kindType) return $ TypedValue' True (Literal ss (ObjectLiteral (map (fmap (uncurry (TypedValue True))) fields))) ty infer' (ObjectUpdate o ps) = do ensureNoDuplicateProperties ps - row <- freshType + row <- freshTypeWithKind (kindRow kindType) typedVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps let toRowListItem = uncurry srcRowListItem let newTys = map (\(name, TypedValue' _ _ ty) -> (Label name, ty)) typedVals - oldTys <- zip (map (Label . fst) ps) <$> replicateM (length ps) freshType + oldTys <- zip (map (Label . fst) ps) <$> replicateM (length ps) (freshTypeWithKind kindType) let oldTy = srcTypeApp tyRecord $ rowFromList (toRowListItem <$> oldTys, row) o' <- TypedValue True <$> (tvToExpr <$> check o oldTy) <*> pure oldTy let newVals = map (fmap tvToExpr) typedVals return $ TypedValue' True (ObjectUpdate o' newVals) $ srcTypeApp tyRecord $ rowFromList (toRowListItem <$> newTys, row) infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do - field <- freshType - rest <- freshType + field <- freshTypeWithKind kindType + rest <- freshTypeWithKind (kindRow kindType) typed <- tvToExpr <$> check val (srcTypeApp tyRecord (srcRCons (Label prop) field rest)) return $ TypedValue' True (Accessor prop typed) field infer' (Abs binder ret) | VarBinder ss arg <- binder = do - ty <- freshType + ty <- freshTypeWithKind kindType withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do body@(TypedValue' _ _ bodyTy) <- infer' ret (body', bodyTy') <- instantiatePolyTypeWithUnknowns (tvToExpr body) bodyTy @@ -428,7 +420,7 @@ infer' v@(Constructor _ c) = do return $ TypedValue' True v' ty' infer' (Case vals binders) = do (vals', ts) <- instantiateForBinders vals binders - ret <- freshType + ret <- freshTypeWithKind kindType binders' <- checkBinders ts ret binders return $ TypedValue' True (Case vals' binders') ret infer' (IfThenElse cond th el) = do @@ -445,18 +437,19 @@ infer' (Let w ds val) = do infer' (DeferredDictionary className tys) = do dicts <- getTypeClassDictionaries hints <- getHints + con <- checkConstraint (srcConstraint className [] tys Nothing) return $ TypedValue' False - (TypeClassDictionary (srcConstraint className tys Nothing) dicts hints) + (TypeClassDictionary con dicts hints) (foldl srcTypeApp (srcTypeConstructor (fmap coerceProperName className)) tys) infer' (TypedValue checkType val ty) = do moduleName <- unsafeCheckCurrentModule - (kind, args) <- kindOfWithScopedVars ty + ((args, elabTy), kind) <- kindOfWithScopedVars ty checkTypeKind ty kind - ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty + ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy tv <- if checkType then withScopedTypeVars moduleName args (check val ty') else return (TypedValue' False val ty) return $ TypedValue' True (tvToExpr tv) ty' infer' (Hole name) = do - ty <- freshType + ty <- freshTypeWithKind kindType ctx <- getLocalContext env <- getEnv tell . errorMessage $ HoleInferredType name ty ctx . Just $ TSBefore env @@ -477,17 +470,17 @@ inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (TypedValue checkType val ty)] : rest) ret j = do moduleName <- unsafeCheckCurrentModule TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do - (kind, args) <- kindOfWithScopedVars ty + ((args, elabTy), kind) <- kindOfWithScopedVars ty checkTypeKind ty kind - let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined) - ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty + let dict = M.singleton (Qualified Nothing ident) (elabTy, nameKind, Undefined) + ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) - else return (TypedValue' checkType val ty) + else return (TypedValue' checkType val elabTy) bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = do - valTy <- freshType + valTy <- freshTypeWithKind kindType TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined) bindNames dict $ infer val @@ -539,8 +532,8 @@ inferBinder val (ConstructorBinder ss ctor binders) = do go args (TypeApp _ (TypeApp _ fn arg) ret) | eqType fn tyFunction = go (arg : args) ret go args ret = (args, ret) inferBinder val (LiteralBinder _ (ObjectLiteral props)) = do - row <- freshType - rest <- freshType + row <- freshTypeWithKind (kindRow kindType) + rest <- freshTypeWithKind (kindRow kindType) m1 <- inferRowProperties row rest props unifyTypes val (srcTypeApp tyRecord row) return m1 @@ -548,12 +541,12 @@ inferBinder val (LiteralBinder _ (ObjectLiteral props)) = do inferRowProperties :: SourceType -> SourceType -> [(PSString, Binder)] -> m (M.Map Ident SourceType) inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty inferRowProperties nrow row ((name, binder):binders) = do - propTy <- freshType + propTy <- freshTypeWithKind kindType m1 <- inferBinder propTy binder m2 <- inferRowProperties nrow (srcRCons (Label name) propTy row) binders return $ m1 `M.union` m2 inferBinder val (LiteralBinder _ (ArrayLiteral binders)) = do - el <- freshType + el <- freshTypeWithKind kindType m1 <- M.unions <$> traverse (inferBinder el) binders unifyTypes val (srcTypeApp tyArray el) return m1 @@ -564,9 +557,9 @@ inferBinder val (NamedBinder ss name binder) = inferBinder val (PositionedBinder pos _ binder) = warnAndRethrowWithPositionTC pos $ inferBinder val binder inferBinder val (TypedBinder ty binder) = do - kind <- kindOf ty + (elabTy, kind) <- kindOf ty checkTypeKind ty kind - ty1 <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty + ty1 <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy unifyTypes val ty1 inferBinder ty1 binder inferBinder _ OpBinder{} = @@ -661,16 +654,25 @@ check' -> SourceType -> m TypedValue' check' val (ForAll ann ident mbK ty _) = do + env <- getEnv + mn <- gets checkCurrentModule scope <- newSkolemScope sko <- newSkolemConstant let ss = case val of PositionedValue pos c _ -> (pos, c) _ -> NullSourceAnn - sk = skolemize ss ident sko scope ty - skVal = skolemizeTypesInValue ss ident sko scope val + sk = skolemize ss ident mbK sko scope ty + -- We should only skolemize types in values when the type variable + -- was actually brought into scope. Otherwise we can end up skolemizing + -- an undefined type variable that happens to clash with the variable we + -- want to skolemize. This can happen due to synonym expansion (see 2542). + skVal + | Just _ <- M.lookup (Qualified mn (ProperName ident)) $ types env = + skolemizeTypesInValue ss ident mbK sko scope val + | otherwise = val val' <- tvToExpr <$> check skVal sk return $ TypedValue' True val' (ForAll ann ident mbK ty (Just scope)) -check' val t@(ConstrainedType _ con@(Constraint _ (Qualified _ (ProperName className)) _ _) ty) = do +check' val t@(ConstrainedType _ con@(Constraint _ (Qualified _ (ProperName className)) _ _ _) ty) = do dictName <- freshIdent ("dict" <> className) dicts <- newDictionaries [] (Qualified Nothing dictName) con val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty @@ -721,14 +723,17 @@ check' (DeferredDictionary className tys) ty = do -} dicts <- getTypeClassDictionaries hints <- getHints + con <- checkConstraint (srcConstraint className [] tys Nothing) return $ TypedValue' False - (TypeClassDictionary (srcConstraint className tys Nothing) dicts hints) + (TypeClassDictionary con dicts hints) ty check' (TypedValue checkType val ty1) ty2 = do - kind <- kindOf ty1 - checkTypeKind ty1 kind - ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1 - ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2 + (elabTy1, kind1) <- kindOf ty1 + (elabTy2, kind2) <- kindOf ty2 + unifyKinds kind1 kind2 + checkTypeKind ty1 kind1 + ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy1 + ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy2 elaborate <- subsumes ty1' ty2' val' <- if checkType then tvToExpr <$> check val ty1' @@ -756,12 +761,12 @@ check' e@(ObjectUpdate obj ps) t@(TypeApp _ o row) | o == tyRecord = do -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns. let (propsToCheck, rest) = rowToList row (removedProps, remainingProps) = partition (\(RowListItem _ p _) -> p `elem` map (Label . fst) ps) propsToCheck - us <- zipWith srcRowListItem (map rowListLabel removedProps) <$> replicateM (length ps) freshType + us <- zipWith srcRowListItem (map rowListLabel removedProps) <$> replicateM (length ps) (freshTypeWithKind kindType) obj' <- tvToExpr <$> check obj (srcTypeApp tyRecord (rowFromList (us ++ remainingProps, rest))) ps' <- checkProperties e ps row True return $ TypedValue' True (ObjectUpdate obj' ps') t check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do - rest <- freshType + rest <- freshTypeWithKind (kindRow kindType) val' <- tvToExpr <$> check val (srcTypeApp tyRecord (srcRCons (Label prop) ty rest)) return $ TypedValue' True (Accessor prop val') ty check' v@(Constructor _ c) ty = do @@ -804,7 +809,7 @@ checkProperties expr ps row lax = convert <$> go ps (toRowPair <$> ts') r' where convert = fmap (fmap tvToExpr) (ts', r') = rowToList row toRowPair (RowListItem _ lbl ty) = (lbl, ty) - go [] [] (REmpty _) = return [] + go [] [] (REmptyKinded _ _) = return [] go [] [] u@(TUnknown _ _) | lax = return [] | otherwise = do unifyTypes u srcREmpty @@ -812,12 +817,12 @@ checkProperties expr ps row lax = convert <$> go ps (toRowPair <$> ts') r' where go [] [] Skolem{} | lax = return [] go [] ((p, _): _) _ | lax = return [] | otherwise = throwError . errorMessage $ PropertyIsMissing p - go ((p,_):_) [] (REmpty _) = throwError . errorMessage $ AdditionalProperty $ Label p + go ((p,_):_) [] (REmptyKinded _ _) = throwError . errorMessage $ AdditionalProperty $ Label p go ((p,v):ps') ts r = case lookup (Label p) ts of Nothing -> do v'@(TypedValue' _ _ ty) <- infer v - rest <- freshType + rest <- freshTypeWithKind (kindRow kindType) unifyTypes r (srcRCons (Label p) ty rest) ps'' <- go ps' ts rest return $ (p, v') : ps'' @@ -865,8 +870,9 @@ checkFunctionApplication' fn (TypeApp _ (TypeApp _ tyFunction' argTy) retTy) arg unifyTypes tyFunction' tyFunction arg' <- tvToExpr <$> check arg argTy return (retTy, App fn arg') -checkFunctionApplication' fn (ForAll _ ident _ ty _) arg = do - replaced <- replaceVarWithUnknown ident ty +checkFunctionApplication' fn (ForAll _ ident mbK ty _) arg = do + u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK + let replaced = replaceTypeVars ident u ty checkFunctionApplication fn replaced arg checkFunctionApplication' fn (KindedType _ ty _) arg = checkFunctionApplication fn ty arg @@ -881,7 +887,7 @@ checkFunctionApplication' fn u arg = do TypedValue' _ arg' t <- infer arg (arg'', t') <- instantiatePolyTypeWithUnknowns arg' t return $ TypedValue' True arg'' t' - ret <- freshType + ret <- freshTypeWithKind kindType unifyTypes u (function ty ret) return (ret, App fn (tvToExpr tv)) diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index a9afdc6eed..e68eae2c20 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -5,53 +5,73 @@ -- module Language.PureScript.TypeChecker.Unify ( freshType + , freshTypeWithKind , solveType , substituteType , unknownsInType , unifyTypes , unifyRows , alignRowsWith - , replaceVarWithUnknown , replaceTypeWildcards , varIfUnknown ) where import Prelude.Compat -import Control.Arrow (first, second) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State.Class (MonadState(..), gets, modify) +import Control.Monad.State.Class (MonadState(..), gets, modify, state) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Foldable (traverse_) -import Data.Function (on) -import Data.List (sortBy, nubBy) import qualified Data.Map as M -import Data.Ord (comparing) -import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Crash +import qualified Language.PureScript.Environment as E import Language.PureScript.Errors +import Language.PureScript.TypeChecker.Kinds (elaborateKind, instantiateKind, unifyKinds) import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Skolems import Language.PureScript.Types --- | Generate a fresh type variable +-- | Generate a fresh type variable with an unknown kind. Avoid this if at all possible. freshType :: (MonadState CheckState m) => m SourceType -freshType = do - t <- gets checkNextType - modify $ \st -> st { checkNextType = t + 1 } - return $ srcTUnknown t +freshType = state $ \st -> do + let + t = checkNextType st + st' = st { checkNextType = t + 2 + , checkSubstitution = + (checkSubstitution st) { substUnsolved = M.insert t (UnkLevel (pure t), E.kindType) + . M.insert (t + 1) (UnkLevel (pure (t + 1)), srcTUnknown t) + . substUnsolved + $ checkSubstitution st + } + } + (srcTUnknown (t + 1), st') + +-- | Generate a fresh type variable with a known kind. +freshTypeWithKind :: (MonadState CheckState m) => SourceType -> m SourceType +freshTypeWithKind kind = state $ \st -> do + let + t = checkNextType st + st' = st { checkNextType = t + 1 + , checkSubstitution = + (checkSubstitution st) { substUnsolved = M.insert t (UnkLevel (pure t), kind) (substUnsolved (checkSubstitution st)) } + } + (srcTUnknown t, st') -- | Update the substitution to solve a type constraint solveType :: (MonadError MultipleErrors m, MonadState CheckState m) => Int -> SourceType -> m () solveType u t = do occursCheck u t + k1 <- elaborateKind t + subst <- gets checkSubstitution + k2 <- maybe (internalCompilerError ("No kind for unification variable ?" <> T.pack (show u))) (pure . substituteType subst . snd) . M.lookup u . substUnsolved $ subst + t' <- instantiateKind (t, k1) k2 modify $ \cs -> cs { checkSubstitution = (checkSubstitution cs) { substType = - M.insert u t $ substType $ checkSubstitution cs + M.insert u t' $ substType $ checkSubstitution cs } } @@ -91,17 +111,17 @@ unifyTypes t1 t2 = do unifyTypes' (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = return () unifyTypes' (TUnknown _ u) t = solveType u t unifyTypes' t (TUnknown _ u) = solveType u t - unifyTypes' (ForAll ann1 ident1 _ ty1 sc1) (ForAll ann2 ident2 _ ty2 sc2) = + unifyTypes' (ForAll ann1 ident1 mbK1 ty1 sc1) (ForAll ann2 ident2 mbK2 ty2 sc2) = case (sc1, sc2) of (Just sc1', Just sc2') -> do sko <- newSkolemConstant - let sk1 = skolemize ann1 ident1 sko sc1' ty1 - let sk2 = skolemize ann2 ident2 sko sc2' ty2 + let sk1 = skolemize ann1 ident1 mbK1 sko sc1' ty1 + let sk2 = skolemize ann2 ident2 mbK2 sko sc2' ty2 sk1 `unifyTypes` sk2 _ -> internalError "unifyTypes: unspecified skolem scope" - unifyTypes' (ForAll ann ident _ ty1 (Just sc)) ty2 = do + unifyTypes' (ForAll ann ident mbK ty1 (Just sc)) ty2 = do sko <- newSkolemConstant - let sk = skolemize ann ident sko sc ty1 + let sk = skolemize ann ident mbK sko sc ty1 sk `unifyTypes` ty2 unifyTypes' ForAll{} _ = internalError "unifyTypes: unspecified skolem scope" unifyTypes' ty f@ForAll{} = f `unifyTypes` ty @@ -112,13 +132,16 @@ unifyTypes t1 t2 = do unifyTypes' (TypeApp _ t3 t4) (TypeApp _ t5 t6) = do t3 `unifyTypes` t5 t4 `unifyTypes` t6 - unifyTypes' (Skolem _ _ s1 _) (Skolem _ _ s2 _) | s1 == s2 = return () + unifyTypes' (KindApp _ t3 t4) (KindApp _ t5 t6) = do + t3 `unifyKinds` t5 + t4 `unifyTypes` t6 + unifyTypes' (Skolem _ _ _ s1 _) (Skolem _ _ _ s2 _) | s1 == s2 = return () unifyTypes' (KindedType _ ty1 _) ty2 = ty1 `unifyTypes` ty2 unifyTypes' ty1 (KindedType _ ty2 _) = ty1 `unifyTypes` ty2 unifyTypes' r1@RCons{} r2 = unifyRows r1 r2 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2 - unifyTypes' r1@REmpty{} r2 = unifyRows r1 r2 - unifyTypes' r1 r2@REmpty{} = unifyRows r1 r2 + unifyTypes' r1@REmptyKinded{} r2 = unifyRows r1 r2 + unifyTypes' r1 r2@REmptyKinded{} = unifyRows r1 r2 unifyTypes' (ConstrainedType _ c1 ty1) (ConstrainedType _ c2 ty2) | constraintClass c1 == constraintClass c2 && constraintData c1 == constraintData c2 = do traverse_ (uncurry unifyTypes) (constraintArgs c1 `zip` constraintArgs c2) @@ -129,29 +152,6 @@ unifyTypes t1 t2 = do unifyTypes' t3 t4 = throwError . errorMessage $ TypesDoNotUnify t3 t4 --- | Align two rows of types, splitting them into three parts: --- --- * Those types which appear in both rows --- * Those which appear only on the left --- * Those which appear only on the right --- --- Note: importantly, we preserve the order of the types with a given label. -alignRowsWith - :: (Type a -> Type a -> r) - -> Type a - -> Type a - -> ([r], (([RowListItem a], Type a), ([RowListItem a], Type a))) -alignRowsWith f ty1 ty2 = go s1 s2 where - (s1, tail1) = rowToSortedList ty1 - (s2, tail2) = rowToSortedList ty2 - - go [] r = ([], (([], tail1), (r, tail2))) - go r [] = ([], ((r, tail1), ([], tail2))) - go lhs@(RowListItem a1 l1 t1 : r1) rhs@(RowListItem a2 l2 t2 : r2) - | l1 < l2 = (second . first . first) (RowListItem a1 l1 t1 :) (go r1 rhs) - | l2 < l1 = (second . second . first) (RowListItem a2 l2 t2 :) (go lhs r2) - | otherwise = first (f t1 t2 :) (go r1 r2) - -- | Unify two rows, updating the current substitution -- -- Common labels are identified and unified. Remaining labels and types are unified with a @@ -163,27 +163,19 @@ unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where unifyTails :: ([RowListItem SourceAnn], SourceType) -> ([RowListItem SourceAnn], SourceType) -> m () unifyTails ([], TUnknown _ u) (sd, r) = solveType u (rowFromList (sd, r)) unifyTails (sd, r) ([], TUnknown _ u) = solveType u (rowFromList (sd, r)) - unifyTails ([], REmpty _) ([], REmpty _) = return () + unifyTails ([], REmptyKinded _ _) ([], REmptyKinded _ _) = return () unifyTails ([], TypeVar _ v1) ([], TypeVar _ v2) | v1 == v2 = return () - unifyTails ([], Skolem _ s1 _ _) ([], Skolem _ s2 _ _) | s1 == s2 = return () - unifyTails (sd1, TUnknown _ u1) (sd2, TUnknown _ u2) = do + unifyTails ([], Skolem _ _ s1 _ _) ([], Skolem _ _ s2 _ _) | s1 == s2 = return () + unifyTails (sd1, TUnknown a u1) (sd2, TUnknown _ u2) = do forM_ sd1 $ occursCheck u2 . rowListType forM_ sd2 $ occursCheck u1 . rowListType - rest' <- freshType + rest' <- freshTypeWithKind =<< elaborateKind (TUnknown a u1) solveType u1 (rowFromList (sd2, rest')) solveType u2 (rowFromList (sd1, rest')) unifyTails _ _ = withErrorMessageHint (ErrorUnifyingTypes r1 r2) $ throwError . errorMessage $ TypesDoNotUnify r1 r2 --- | --- Replace a single type variable with a new unification variable --- -replaceVarWithUnknown :: (MonadState CheckState m) => Text -> SourceType -> m SourceType -replaceVarWithUnknown ident ty = do - tu <- freshType - return $ replaceTypeVars ident tu ty - -- | -- Replace type wildcards with unknowns -- @@ -201,13 +193,13 @@ replaceTypeWildcards = everywhereOnTypesM replace -- | -- Replace outermost unsolved unification variables with named type variables -- -varIfUnknown :: SourceType -> SourceType -varIfUnknown ty = - let unks = nubBy ((==) `on` snd) $ unknownsInType ty - toName = T.cons 't' . T.pack . show - addKind a = (a, Nothing) - ty' = everywhereOnTypes typeToVar ty - typeToVar :: SourceType -> SourceType - typeToVar (TUnknown ann u) = TypeVar ann (toName u) - typeToVar t = t - in mkForAll (fmap (fmap addKind) . sortBy (comparing snd) . fmap (fmap toName) $ unks) ty' +varIfUnknown :: [(Unknown, SourceType)] -> SourceType -> SourceType +varIfUnknown unks ty = + mkForAll (toBinding <$> unks) $ go ty + where + toName = T.cons 't' . T.pack . show + toBinding (a, k) = (getAnnForType ty, (toName a, Just $ go k)) + go = everywhereOnTypes $ \case + (TUnknown ann u) + | Just _ <- lookup u unks -> TypeVar ann (toName u) + t -> t diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index 84a0e50747..c721c217b7 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -18,7 +18,7 @@ moduleA, moduleB, moduleC, moduleD, moduleE, moduleF, moduleG, moduleH, moduleI moduleA = (P.moduleNameFromString "Module.A", [T.ideValue "function1" Nothing]) moduleB = (P.moduleNameFromString "Module.B", [T.ideValue "data1" Nothing]) moduleC = (P.moduleNameFromString "Module.C", [T.ideType "List" Nothing []]) -moduleD = (P.moduleNameFromString "Module.D", [T.ideKind "kind1"]) +moduleD = (P.moduleNameFromString "Module.D", [T.ideType "kind1" Nothing []]) moduleE = (P.moduleNameFromString "Module.E", [T.ideSynonym "SFType" Nothing Nothing `annLoc` synonymSS]) moduleF = (P.moduleNameFromString "Module.F", [T.ideDtor "DtorA" "TypeA" Nothing]) moduleG = (P.moduleNameFromString "Module.G", [T.ideTypeClass "MyClass" P.kindType []]) @@ -79,26 +79,8 @@ spec = do it "extracts no modules by filtering `type` namespaces" $ runNamespace (Set.fromList [IdeNSType]) [moduleA, moduleB] `shouldBe` [] - it "extracts modules by filtering `kind` namespaces" $ - runNamespace (Set.fromList [IdeNSKind]) - [moduleA, moduleB, moduleD] `shouldBe` [moduleD] - it "extracts no modules by filtering `kind` namespaces" $ - runNamespace (Set.fromList [IdeNSKind]) - [moduleA, moduleB] `shouldBe` [] it "extracts modules by filtering `value` and `type` namespaces" $ runNamespace (Set.fromList [ IdeNSValue, IdeNSType]) - [moduleA, moduleB, moduleC, moduleD] - `shouldBe` [moduleA, moduleB, moduleC] - it "extracts modules by filtering `value` and `kind` namespaces" $ - runNamespace (Set.fromList [ IdeNSValue, IdeNSKind]) - [moduleA, moduleB, moduleC, moduleD] - `shouldBe` [moduleA, moduleB, moduleD] - it "extracts modules by filtering `type` and `kind` namespaces" $ - runNamespace (Set.fromList [ IdeNSType, IdeNSKind]) - [moduleA, moduleB, moduleC, moduleD] - `shouldBe` [moduleC, moduleD] - it "extracts modules by filtering `value`, `type` and `kind` namespaces" $ - runNamespace (Set.fromList [ IdeNSValue, IdeNSType, IdeNSKind]) [moduleA, moduleB, moduleC, moduleD] `shouldBe` [moduleA, moduleB, moduleC, moduleD] describe "declarationTypeFilter" $ do @@ -110,7 +92,7 @@ spec = do [moduleD, moduleG, moduleE, moduleH] `shouldBe` [] it "extracts module by filtering `type` declarations" $ runDeclaration [D.Type] - [moduleA, moduleB, moduleC, moduleD, moduleE] `shouldBe` [moduleC] + [moduleA, moduleB, moduleC, moduleD, moduleE] `shouldBe` [moduleC, moduleD] it "removes everything if a `type` declaration have not been found" $ runDeclaration [D.Type] [moduleA, moduleG, moduleE, moduleH] `shouldBe` [] @@ -144,15 +126,9 @@ spec = do it "removes everything if a `typeoperator` declaration have not been found" $ runDeclaration [D.TypeOperator] [moduleA, moduleD] `shouldBe` [] - it "extracts module by filtering `kind` declarations" $ - runDeclaration [D.Kind] - [moduleA, moduleD, moduleG, moduleI, moduleF] `shouldBe` [moduleD] - it "removes everything if a `kind` declaration have not been found" $ - runDeclaration [D.Kind] - [moduleA, moduleC] `shouldBe` [] it "extracts modules by filtering `value` and `synonym` declarations" $ runDeclaration [D.Value, D.Synonym] [moduleA, moduleB, moduleD, moduleE] `shouldBe` [moduleA, moduleB, moduleE] - it "extracts modules by filtering `value`, `kind`, and `valueoperator` declarations" $ - runDeclaration [D.Value, D.Kind, D.ValueOperator] - [moduleA, moduleB, moduleD, moduleG, moduleE, moduleH] `shouldBe` [moduleA, moduleB, moduleD, moduleH] + it "extracts modules by filtering `value`, and `valueoperator` declarations" $ + runDeclaration [D.Value, D.ValueOperator] + [moduleA, moduleB, moduleD, moduleG, moduleE, moduleH] `shouldBe` [moduleA, moduleB, moduleH] diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 040ad3665b..c9c549edb5 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -120,8 +120,6 @@ spec = do prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideDtor i t Nothing)) mn q is) addTypeImport i mn q is = prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideType i Nothing [])) mn q is) - addKindImport i mn q is = - prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideKind i)) mn q is) qualify s = Just (Test.mn s) it "adds an implicit unqualified import to a file without any imports" $ shouldBe @@ -197,20 +195,6 @@ spec = do , "" , "import Data.Array (head, tail) as Array" ] - it "adds a kind to an explicit import list" $ - shouldBe - (addKindImport "Effect" (P.moduleNameFromString "Control.Monad.Eff") Nothing simpleFileImports) - [ "import Prelude" - , "" - , "import Control.Monad.Eff (kind Effect)" - ] - it "adds a kind to an explicit qualified import list" $ - shouldBe - (addKindImport "Effect" (P.moduleNameFromString "Control.Monad.Eff") (qualify "Eff") simpleFileImports) - [ "import Prelude" - , "" - , "import Control.Monad.Eff (kind Effect) as Eff" - ] it "adds an operator to an explicit import list" $ shouldBe (addOpImport "<~>" (P.moduleNameFromString "Data.Array") Nothing explicitImports) diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index 731672a58c..51e700e7e2 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -40,7 +40,6 @@ succTestCases = , ("resolves a synonym reexport" , [(mn "A", P.TypeRef testSpan (P.ProperName "SynonymA") Nothing)], [synonymA `annExp` "A"]) , ("resolves a class reexport", [(mn "A", P.TypeClassRef testSpan (P.ProperName "ClassA"))], [classA `annExp` "A"]) - , ("resolves a kind reexport", [(mn "A", P.KindRef testSpan (P.ProperName "KindA"))], [kindA `annExp` "A"]) ] failTestCases :: [(Text, Refs)] diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index e046e23061..aba2370e2b 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -21,7 +21,7 @@ ann0 = (span0, []) ann1 = (span1, []) ann2 = (span2, []) -typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, foreign1, foreign2, foreign3, member1 :: P.Declaration +typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, foreign1, foreign2, member1 :: P.Declaration typeAnnotation1 = P.TypeDeclaration (P.TypeDeclarationData ann1 (P.Ident "value1") P.srcREmpty) value1 = P.ValueDecl ann1 (P.Ident "value1") P.Public [] [] synonym1 = P.TypeSynonymDeclaration ann1 (P.ProperName "Synonym1") [] P.srcREmpty @@ -43,7 +43,6 @@ typeFixity = (P.OpName "~>") foreign1 = P.ExternDeclaration ann1 (P.Ident "foreign1") P.srcREmpty foreign2 = P.ExternDataDeclaration ann1 (P.ProperName "Foreign2") P.kindType -foreign3 = P.ExternKindDeclaration ann1 (P.ProperName "Foreign3") member1 = P.TypeDeclaration (P.TypeDeclarationData ann2 (P.Ident "member1") P.srcREmpty) spec :: Spec @@ -69,8 +68,6 @@ spec = do extractSpans foreign1 `shouldBe` [(IdeNamespaced IdeNSValue "foreign1", span1)] it "extracts a span for a data foreign declaration" $ extractSpans foreign2 `shouldBe` [(IdeNamespaced IdeNSType "Foreign2", span1)] - it "extracts a span for a foreign kind declaration" $ - extractSpans foreign3 `shouldBe` [(IdeNamespaced IdeNSKind "Foreign3", span1)] describe "Type annotations" $ do it "extracts a type annotation" $ extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.srcREmpty)] diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index 4775a67fc7..a5465e4881 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -19,7 +19,7 @@ ctorOperator :: Maybe P.SourceType -> IdeDeclarationAnn ctorOperator = ideValueOp ":" (P.Qualified (Just (mn "Test")) (Right "Cons")) 2 Nothing -typeOperator :: Maybe P.SourceKind -> IdeDeclarationAnn +typeOperator :: Maybe P.SourceType -> IdeDeclarationAnn typeOperator = ideTypeOp ":" (P.Qualified (Just (mn "Test")) "List") 2 Nothing @@ -58,6 +58,10 @@ ef = P.ExternsFile (P.Qualified (Just (mn "ClassModule")) (P.ProperName "MyClass")) -- , edInstanceName = (P.Ident "myClassInstance") + -- . edInstanceForAll = + [] + -- , edInstanceKinds = + mempty -- , edInstanceTypes = mempty -- , edInstanceConstraints = diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index c0db826c89..178e926257 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -67,13 +67,13 @@ ida = IdeDeclarationAnn emptyAnn ideValue :: Text -> Maybe P.SourceType -> IdeDeclarationAnn ideValue i ty = ida (IdeDeclValue (IdeValue (P.Ident i) (fromMaybe P.tyString ty))) -ideType :: Text -> Maybe P.SourceKind -> [(P.ProperName 'P.ConstructorName, P.SourceType)] -> IdeDeclarationAnn +ideType :: Text -> Maybe P.SourceType -> [(P.ProperName 'P.ConstructorName, P.SourceType)] -> IdeDeclarationAnn ideType pn ki dtors = ida (IdeDeclType (IdeType (P.ProperName pn) (fromMaybe P.kindType ki) dtors)) -ideSynonym :: Text -> Maybe P.SourceType -> Maybe P.SourceKind -> IdeDeclarationAnn +ideSynonym :: Text -> Maybe P.SourceType -> Maybe P.SourceType -> IdeDeclarationAnn ideSynonym pn ty kind = ida (IdeDeclTypeSynonym (IdeTypeSynonym (P.ProperName pn) (fromMaybe P.tyString ty) (fromMaybe P.kindType kind))) -ideTypeClass :: Text -> P.SourceKind -> [IdeInstance] -> IdeDeclarationAnn +ideTypeClass :: Text -> P.SourceType -> [IdeInstance] -> IdeDeclarationAnn ideTypeClass pn kind instances = ida (IdeDeclTypeClass (IdeTypeClass (P.ProperName pn) kind instances)) ideDtor :: Text -> Text -> Maybe P.SourceType -> IdeDeclarationAnn @@ -89,7 +89,7 @@ ideValueOp opName ident precedence assoc t = (fromMaybe P.Infix assoc) t)) -ideTypeOp :: Text -> P.Qualified Text -> Integer -> Maybe P.Associativity -> Maybe P.SourceKind -> IdeDeclarationAnn +ideTypeOp :: Text -> P.Qualified Text -> Integer -> Maybe P.Associativity -> Maybe P.SourceType -> IdeDeclarationAnn ideTypeOp opName ident precedence assoc k = ida (IdeDeclTypeOperator (IdeTypeOperator @@ -100,7 +100,7 @@ ideTypeOp opName ident precedence assoc k = k)) ideKind :: Text -> IdeDeclarationAnn -ideKind pn = ida (IdeDeclKind (P.ProperName pn)) +ideKind pn = ideType pn (Just P.kindType) [] ideModule :: Text -> IdeDeclarationAnn ideModule name = ida (IdeDeclModule (mn name)) diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 2ccfea318f..013dc7d9c5 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -191,7 +191,7 @@ displayAssertion = \case " should be empty" ShouldHaveClassMethodDocComment mn decl method excerpt -> "the string " <> T.pack (show excerpt) <> " should appear in the" <> - " doc-comment for class method " <> T.pack (show method) <> " for " <> showQual mn decl + " doc-comment for class method " <> T.pack (show method) <> " for " <> showQual mn decl ShouldNotHaveClassMethodDocComment mn decl method -> "Doc-comments for class method " <> T.pack (show method) <> " for " <> showQual mn decl <> " should be empty" @@ -608,7 +608,7 @@ testCases = , ("Clash", [ ShouldBeDocumented (n "Clash1") "value" [] - , ShouldBeDocumented (n "Clash1") "Type" [] + , ShouldBeDocumented (n "Clash1") "Type'" [] , ShouldBeDocumented (n "Clash1") "TypeClass" ["typeClassMember"] ]) diff --git a/tests/TestHierarchy.hs b/tests/TestHierarchy.hs index 3cbf612193..01557ff2eb 100644 --- a/tests/TestHierarchy.hs +++ b/tests/TestHierarchy.hs @@ -53,7 +53,7 @@ main = testSpec "hierarchy" $ do (P.internalModuleSourceSpan "", []) (P.ProperName "B") [] - [P.srcConstraint (P.Qualified Nothing $ P.ProperName "A") [] Nothing] + [P.srcConstraint (P.Qualified Nothing $ P.ProperName "A") [] [] Nothing] [] [] ] diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index d7cd1b7957..d7690635ba 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -6,7 +6,7 @@ import Data.List (sort) import Control.Exception (evaluate) import Control.DeepSeq (force) import qualified Data.Map as Map -import qualified Data.Set as Set +import qualified Data.Text as Text import qualified Language.PureScript as P import qualified Language.PureScript.Docs as D @@ -26,7 +26,7 @@ spec = do it "all Prim modules are fully documented" $ do let actualPrimNames = -- note that prim type classes are listed in P.primTypes - (map (P.runProperName . P.disqualify . fst) $ Map.toList + (filter (not . Text.any (== '$')) . map (P.runProperName . P.disqualify . fst) $ Map.toList ( P.primTypes <> P.primBooleanTypes <> P.primCoerceTypes <> @@ -34,8 +34,7 @@ spec = do P.primRowTypes <> P.primRowListTypes <> P.primTypeErrorTypes <> - P.primSymbolTypes )) ++ - (map (P.runProperName . P.disqualify) $ Set.toList P.allPrimKinds) + P.primSymbolTypes )) let documentedPrimNames = map D.declTitle (concatMap D.modDeclarations D.primModules) diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index 7cf9ba7dcb..a9f059e1ba 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -60,7 +60,7 @@ completionTestData supportModuleNames = -- :kind should complete next word from types in scope , (":kind Str", [":kind String"]) - , (":kind ST.", [":kind ST.ST"]) -- import Control.Monad.ST as ST + , (":kind ST.", [":kind ST.Region", ":kind ST.ST"]) -- import Control.Monad.ST as ST , (":kind STRef.", [":kind STRef.STRef"]) -- import Control.Monad.ST.Ref as STRef , (":kind Effect.", []) diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 86f6d70b17..dfacc8a107 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -15,6 +15,7 @@ import Control.Monad import Control.Monad.Reader import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe +import Control.Monad.Writer.Class (tell) import Control.Exception import Data.Char (isSpace) import Data.Function (on) @@ -85,7 +86,7 @@ getSupportModuleTuples = do fileContents <- readInput pursFiles modules <- runExceptT $ ExceptT . return $ CST.parseFromFiles id fileContents case modules of - Right ms -> return ms + Right ms -> return (fmap (fmap snd) ms) Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) getSupportModuleNames :: IO [T.Text] @@ -169,7 +170,9 @@ compile -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) compile supportModules supportExterns supportForeigns inputFiles check = runTest $ do fs <- liftIO $ readInput inputFiles - ms <- CST.parseFromFiles id fs + msWithWarnings <- CST.parseFromFiles id fs + tell $ foldMap (\(fp, (ws, _)) -> CST.toMultipleWarnings fp ws) msWithWarnings + let ms = fmap snd <$> msWithWarnings foreigns <- inferForeignModules ms liftIO (check (map snd ms)) let actions = makeActions supportModules (foreigns `M.union` supportForeigns) diff --git a/tests/purs/docs/src/Clash1a.purs b/tests/purs/docs/src/Clash1a.purs index c21260f562..77804573c7 100644 --- a/tests/purs/docs/src/Clash1a.purs +++ b/tests/purs/docs/src/Clash1a.purs @@ -3,7 +3,7 @@ module Clash1a where value :: Int value = 0 -type Type = Int +type Type' = Int class TypeClass a where typeClassMember :: a diff --git a/tests/purs/docs/src/Clash2a.purs b/tests/purs/docs/src/Clash2a.purs index 5405daf9ed..8c394a7c69 100644 --- a/tests/purs/docs/src/Clash2a.purs +++ b/tests/purs/docs/src/Clash2a.purs @@ -3,7 +3,7 @@ module Clash2a where value :: String value = "hello" -type Type = String +type Type' = String class TypeClass a b where typeClassMember :: a -> b diff --git a/tests/purs/docs/src/ConstrainedArgument.purs b/tests/purs/docs/src/ConstrainedArgument.purs index 00bc5be0bc..d56ef76225 100644 --- a/tests/purs/docs/src/ConstrainedArgument.purs +++ b/tests/purs/docs/src/ConstrainedArgument.purs @@ -1,6 +1,6 @@ module ConstrainedArgument where -class Foo t +class Foo (t :: Type) type WithoutArgs = forall a. (Partial => a) -> a type WithArgs = forall a. (Foo a => a) -> a diff --git a/tests/purs/failing/1071.out b/tests/purs/failing/1071.out index 620693fdde..48744d8fb7 100644 --- a/tests/purs/failing/1071.out +++ b/tests/purs/failing/1071.out @@ -3,15 +3,18 @@ in module Main at tests/purs/failing/1071.purs:7:18 - 7:23 (line 7, column 18 - line 7, column 23) Could not match kind - - Type -> Type - +   +  Type -> Constraint +   with kind - - Type - - -while checking the kind of Foo a => a -> a +   +  Constraint +   + +while checking that type Foo a + has kind Constraint +while inferring the kind of Foo a => a -> a +while inferring the kind of forall a. Foo a => a -> a in value declaration bar See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, diff --git a/tests/purs/failing/1310.out b/tests/purs/failing/1310.out index c24a9f5d8d..4e558ad248 100644 --- a/tests/purs/failing/1310.out +++ b/tests/purs/failing/1310.out @@ -9,7 +9,7 @@ at tests/purs/failing/1310.purs:18:8 - 18:31 (line 18, column 8 - line 18, colum   while applying a function inj - of type Inject t0 t1 => t0 t2 -> t1 t2 + of type Inject @t0 t1 t2 => t1 t3 -> t2 t3 to argument Oops (log "Oops") while checking that expression inj (Oops (log "Oops")) has type Effect Unit @@ -18,6 +18,7 @@ in value declaration main where t0 is an unknown type t1 is an unknown type t2 is an unknown type + t3 is an unknown type See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/1570.out b/tests/purs/failing/1570.out index 834a64bbd8..1b1a0fde57 100644 --- a/tests/purs/failing/1570.out +++ b/tests/purs/failing/1570.out @@ -8,9 +8,9 @@ at tests/purs/failing/1570.purs:6:10 - 6:16 (line 6, column 10 - line 6, column  F   having the kind - - Type -> Type - +   +  Type -> Type +   instead. while inferring the type of \$0 ->  diff --git a/tests/purs/failing/2542.out b/tests/purs/failing/2542.out index 1d06484c00..29c9769f23 100644 --- a/tests/purs/failing/2542.out +++ b/tests/purs/failing/2542.out @@ -1,10 +1,13 @@ Error found: in module Main -at tests/purs/failing/2542.purs:8:10 - 8:17 (line 8, column 10 - line 8, column 17) +at tests/purs/failing/2542.purs:8:16 - 8:17 (line 8, column 16 - line 8, column 17) Type variable a is undefined. -while checking the kind of Array a0 +while inferring the kind of a +while checking that type a + has kind Type +while inferring the kind of Array a while checking that expression bar   where   bar = [] diff --git a/tests/purs/failing/2601.out b/tests/purs/failing/2601.out index 060db15d84..3c5e3d4270 100644 --- a/tests/purs/failing/2601.out +++ b/tests/purs/failing/2601.out @@ -3,15 +3,17 @@ in module Main at tests/purs/failing/2601.purs:6:12 - 6:15 (line 6, column 12 - line 6, column 15) Could not match kind - - Type -> Type - +   +  Type +   with kind +   +  Type -> Type +   - Type - - -while checking the kind of Syn Int +while checking that type Int + has kind Type -> Type +while inferring the kind of Syn Int in value declaration val See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, diff --git a/tests/purs/failing/3077.out b/tests/purs/failing/3077.out new file mode 100644 index 0000000000..3cc9b55af5 --- /dev/null +++ b/tests/purs/failing/3077.out @@ -0,0 +1,25 @@ +Error found: +in module Main +at tests/purs/failing/3077.purs:11:24 - 11:30 (line 11, column 24 - line 11, column 30) + + Could not match kind +   +  Type +   + with kind +   +  Symbol +   + +while trying to match type SProxy + with type t0 +while checking that expression SProxy + has type t0 t1 +in value declaration wrong + +where t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3077.purs b/tests/purs/failing/3077.purs new file mode 100644 index 0000000000..b1564d73b6 --- /dev/null +++ b/tests/purs/failing/3077.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +data TProxy (t :: Type) = TProxy +data SProxy (s :: Symbol) = SProxy + +put :: forall proxy a. proxy a -> TProxy a +put _ = TProxy + +--wrong :: TProxy "apple" +wrong = put (SProxy :: SProxy "apple") diff --git a/tests/purs/failing/3275-BindingGroupErrorPos.out b/tests/purs/failing/3275-BindingGroupErrorPos.out index 1e951ccddb..99207ba3b2 100644 --- a/tests/purs/failing/3275-BindingGroupErrorPos.out +++ b/tests/purs/failing/3275-BindingGroupErrorPos.out @@ -1,19 +1,24 @@ Error found: in module BindingGroupErrorPos -at tests/purs/failing/3275-BindingGroupErrorPos.purs:11:17 - 11:30 (line 11, column 17 - line 11, column 30) +at tests/purs/failing/3275-BindingGroupErrorPos.purs:11:17 - 11:23 (line 11, column 17 - line 11, column 23) Could not match kind - - Type - +   +  Type +   with kind - - Type -> k4 - - -while checking the kind of Int -> Result String +   +  Type -> t3 +   + +while checking that type Result + has kind Type -> t0 +while inferring the kind of Result String +while inferring the kind of Int -> Result String in binding group wrong +where t0 is an unknown type + See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/3275-DataBindingGroupErrorPos.out b/tests/purs/failing/3275-DataBindingGroupErrorPos.out index 19733fb78e..f20c51e038 100644 --- a/tests/purs/failing/3275-DataBindingGroupErrorPos.out +++ b/tests/purs/failing/3275-DataBindingGroupErrorPos.out @@ -1,19 +1,25 @@ Error found: in module DataBindingGroupErrorPos -at tests/purs/failing/3275-DataBindingGroupErrorPos.purs:7:19 - 7:26 (line 7, column 19 - line 7, column 26) +at tests/purs/failing/3275-DataBindingGroupErrorPos.purs:7:19 - 7:22 (line 7, column 19 - line 7, column 22) Could not match kind - - Type - +   +  Type +   with kind - - k4 -> k5 - - -while checking the kind of Bar a a +   +  t10 -> t11 +   + +while checking that type Bar a + has kind t0 -> t1 +while inferring the kind of Bar a a +while inferring the kind of Bar a a -> Foo a in data binding group Bar, Foo +where t0 is an unknown type + t1 is an unknown type + See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/3549-a.out b/tests/purs/failing/3549-a.out index 60543750b7..f8062ff3d1 100644 --- a/tests/purs/failing/3549-a.out +++ b/tests/purs/failing/3549-a.out @@ -2,7 +2,7 @@ Error found: in module Main at tests/purs/failing/3549-a.purs:6:26 - 6:29 (line 6, column 26 - line 6, column 29) - Unknown kind Typ + Unknown type Typ See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, diff --git a/tests/purs/failing/3549.out b/tests/purs/failing/3549.out index b3dae2d21d..da4a38f2ab 100644 --- a/tests/purs/failing/3549.out +++ b/tests/purs/failing/3549.out @@ -3,15 +3,21 @@ in module Main at tests/purs/failing/3549.purs:8:78 - 8:79 (line 8, column 78 - line 8, column 79) Could not match kind - - Type - +   +  Type -> Type +   with kind - - Type -> Type - - -while checking the kind of Functor f => (a -> b) -> f a -> f b +   +  Type +   + +while checking that type f + has kind Type -> Type +while inferring the kind of Functor f +while inferring the kind of Functor f => (a -> b) -> f a -> f b +while inferring the kind of forall (b :: Type). Functor f => (a -> b) -> f a -> f b +while inferring the kind of forall (a :: Type) (b :: Type). Functor f => (a -> b) -> f a -> f b +while inferring the kind of forall (f :: Type -> Type -> Type) (a :: Type) (b :: Type). Functor f => (a -> b) -> f a -> f b in value declaration map' See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, diff --git a/tests/purs/failing/CoercibleForeign.out b/tests/purs/failing/CoercibleForeign.out index 0e4fcad418..78b9536a51 100644 --- a/tests/purs/failing/CoercibleForeign.out +++ b/tests/purs/failing/CoercibleForeign.out @@ -8,15 +8,15 @@ at tests/purs/failing/CoercibleForeign.purs:11:20 - 11:26 (line 11, column 20 -  (Foreign (Id a0) (Id b1))   -while checking that type forall a b. Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b is at least as general as type Foreign a0 b1 -> Foreign (Id a0) (Id b1) while checking that expression coerce has type Foreign a0 b1 -> Foreign (Id a0) (Id b1) in value declaration foreignToForeign -where b1 is a rigid type variable +where a0 is a rigid type variable bound at (line 11, column 20 - line 11, column 26) - a0 is a rigid type variable + b1 is a rigid type variable bound at (line 11, column 20 - line 11, column 26) See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, diff --git a/tests/purs/failing/CoercibleNominal.out b/tests/purs/failing/CoercibleNominal.out index 9a2dc1f70f..e84c6ee6a6 100644 --- a/tests/purs/failing/CoercibleNominal.out +++ b/tests/purs/failing/CoercibleNominal.out @@ -8,17 +8,17 @@ at tests/purs/failing/CoercibleNominal.purs:11:20 - 11:26 (line 11, column 20 -  (Nominal b2 c1)   -while checking that type forall a b. Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b is at least as general as type Nominal a0 c1 -> Nominal b2 c1 while checking that expression coerce has type Nominal a0 c1 -> Nominal b2 c1 in value declaration nominalToNominal -where c1 is a rigid type variable +where a0 is a rigid type variable bound at (line 11, column 20 - line 11, column 26) b2 is a rigid type variable bound at (line 11, column 20 - line 11, column 26) - a0 is a rigid type variable + c1 is a rigid type variable bound at (line 11, column 20 - line 11, column 26) See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, diff --git a/tests/purs/failing/CoercibleNominalTypeApp.out b/tests/purs/failing/CoercibleNominalTypeApp.out index 8f97e980c1..d99972caef 100644 --- a/tests/purs/failing/CoercibleNominalTypeApp.out +++ b/tests/purs/failing/CoercibleNominalTypeApp.out @@ -3,15 +3,15 @@ in module Main at tests/purs/failing/CoercibleNominalTypeApp.purs:13:8 - 13:14 (line 13, column 8 - line 13, column 14) No type class instance was found for -   -  Prim.Coerce.Coercible (G Maybe Int)  -  (G Maybe String) -   +   +  Prim.Coerce.Coercible (G @Type Maybe Int)  +  (G @Type Maybe String) +   -while checking that type forall a b. Coercible a b => a -> b - is at least as general as type G Maybe Int -> G Maybe String +while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b + is at least as general as type G @Type Maybe Int -> G @Type Maybe String while checking that expression coerce - has type G Maybe Int -> G Maybe String + has type G @Type Maybe Int -> G @Type Maybe String in value declaration gToG See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, diff --git a/tests/purs/failing/CoercibleNominalWrapped.out b/tests/purs/failing/CoercibleNominalWrapped.out index e3204cb43d..781959f8a0 100644 --- a/tests/purs/failing/CoercibleNominalWrapped.out +++ b/tests/purs/failing/CoercibleNominalWrapped.out @@ -8,15 +8,15 @@ at tests/purs/failing/CoercibleNominalWrapped.purs:15:14 - 15:20 (line 15, colum  (Wrap (Id a0) b1)   -while checking that type forall a b. Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b is at least as general as type Wrap a0 b1 -> Wrap (Id a0) b1 while checking that expression coerce has type Wrap a0 b1 -> Wrap (Id a0) b1 in value declaration wrapToWrap -where b1 is a rigid type variable +where a0 is a rigid type variable bound at (line 15, column 14 - line 15, column 20) - a0 is a rigid type variable + b1 is a rigid type variable bound at (line 15, column 14 - line 15, column 20) See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, diff --git a/tests/purs/failing/CoercibleRepresentational.out b/tests/purs/failing/CoercibleRepresentational.out index a29e257444..90ef1ae9b6 100644 --- a/tests/purs/failing/CoercibleRepresentational.out +++ b/tests/purs/failing/CoercibleRepresentational.out @@ -4,20 +4,22 @@ at tests/purs/failing/CoercibleRepresentational.purs:11:20 - 11:26 (line 11, col No type class instance was found for   -  Prim.Coerce.Coercible a0 -  b1 +  Prim.Coerce.Coercible a1 +  b3   -while checking that type forall a b. Coercible a b => a -> b - is at least as general as type Phantom a0 -> Phantom b1 +while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b + is at least as general as type Phantom @t0 a1 -> Phantom @t2 b3 while checking that expression coerce - has type Phantom a0 -> Phantom b1 + has type Phantom @t0 a1 -> Phantom @t2 b3 in value declaration phantomToPhantom -where b1 is a rigid type variable +where a1 is a rigid type variable bound at (line 11, column 20 - line 11, column 26) - a0 is a rigid type variable + b3 is a rigid type variable bound at (line 11, column 20 - line 11, column 26) + t0 is an unknown type + t2 is an unknown type See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/CoercibleRepresentational2.out b/tests/purs/failing/CoercibleRepresentational2.out index a6a3b6754c..b2b1d38004 100644 --- a/tests/purs/failing/CoercibleRepresentational2.out +++ b/tests/purs/failing/CoercibleRepresentational2.out @@ -8,7 +8,7 @@ at tests/purs/failing/CoercibleRepresentational2.purs:9:14 - 9:20 (line 9, colum  String   -while checking that type forall a b. Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b is at least as general as type Arr1 Int -> Arr1 String while checking that expression coerce has type Arr1 Int -> Arr1 String diff --git a/tests/purs/failing/CoercibleRepresentational3.out b/tests/purs/failing/CoercibleRepresentational3.out index bb9e963db7..529edab386 100644 --- a/tests/purs/failing/CoercibleRepresentational3.out +++ b/tests/purs/failing/CoercibleRepresentational3.out @@ -8,7 +8,7 @@ at tests/purs/failing/CoercibleRepresentational3.purs:9:14 - 9:20 (line 9, colum  String   -while checking that type forall a b. Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b is at least as general as type Rec1 Int -> Rec1 String while checking that expression coerce has type Rec1 Int -> Rec1 String diff --git a/tests/purs/failing/ConstraintFailure.out b/tests/purs/failing/ConstraintFailure.out index 6a952a9a07..17d2c94bad 100644 --- a/tests/purs/failing/ConstraintFailure.out +++ b/tests/purs/failing/ConstraintFailure.out @@ -7,15 +7,15 @@ at tests/purs/failing/ConstraintFailure.purs:12:8 - 12:12 (line 12, column 8 - l  Data.Show.Show Foo   -while checking that type forall a. Show a => a -> String +while checking that type forall (a :: Type). Show a => a -> String is at least as general as type t0 t1 t2 while checking that expression show has type t0 t1 t2 in value declaration main where t0 is an unknown type - t2 is an unknown type t1 is an unknown type + t2 is an unknown type See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/ConstraintInference.out b/tests/purs/failing/ConstraintInference.out index 54eeedc7d4..4e72d8345f 100644 --- a/tests/purs/failing/ConstraintInference.out +++ b/tests/purs/failing/ConstraintInference.out @@ -3,12 +3,12 @@ in module Main at tests/purs/failing/ConstraintInference.purs:10:1 - 10:21 (line 10, column 1 - line 10, column 21) The inferred type -   -  forall t5 t9. Show t5 => t9 -> String -   +   +  forall t8 t11. Show t8 => t11 -> String +   has type variables which are not determined by those mentioned in the body of the type: - t5 could not be determined + t8 could not be determined Consider adding a type annotation. diff --git a/tests/purs/failing/CycleInKindDeclaration.out b/tests/purs/failing/CycleInKindDeclaration.out new file mode 100644 index 0000000000..9c532d4c92 --- /dev/null +++ b/tests/purs/failing/CycleInKindDeclaration.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/CycleInKindDeclaration.purs:7:1 - 7:24 (line 7, column 1 - line 7, column 24) + + A cycle appears in a set of kind declarations: + + {Bar, Foo} + + Kind declarations may not refer to themselves in their own signatures. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInKindDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CycleInKindDeclaration.purs b/tests/purs/failing/CycleInKindDeclaration.purs new file mode 100644 index 0000000000..04c46e56f4 --- /dev/null +++ b/tests/purs/failing/CycleInKindDeclaration.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith CycleInKindDeclaration +module Main where + +data Foo :: Bar -> Type +data Foo a = Foo + +data Bar :: Foo -> Type +data Bar a = Bar diff --git a/tests/purs/failing/DiffKindsSameName.out b/tests/purs/failing/DiffKindsSameName.out index 89355c1062..13f180f524 100644 --- a/tests/purs/failing/DiffKindsSameName.out +++ b/tests/purs/failing/DiffKindsSameName.out @@ -3,15 +3,17 @@ in module DiffKindsSameName at tests/purs/failing/DiffKindsSameName.purs:13:18 - 13:31 (line 13, column 18 - line 13, column 31) Could not match kind - - DiffKindsSameName.LibA.DemoKind - +   +  DemoKind +   with kind +   +  DemoKind +   - DiffKindsSameName.LibB.DemoKind - - -while checking the kind of AProxy DemoData +while checking that type DemoData + has kind DemoKind +while inferring the kind of AProxy DemoData in value declaration bProxy See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, diff --git a/tests/purs/failing/DuplicateModule.out b/tests/purs/failing/DuplicateModule.out index 7e66ff75bd..06a97ebd1f 100644 --- a/tests/purs/failing/DuplicateModule.out +++ b/tests/purs/failing/DuplicateModule.out @@ -1,5 +1,5 @@ Error found: -at tests/purs/failing/DuplicateModule.purs:2:1 - 2:16 (line 2, column 1 - line 2, column 16) +at tests/purs/failing/DuplicateModule/M1.purs:1:1 - 1:16 (line 1, column 1 - line 1, column 16) Module M1 has been defined multiple times diff --git a/tests/purs/failing/DuplicateTypeClass.out b/tests/purs/failing/DuplicateTypeClass.out index 07720698ac..ddc9e92c1a 100644 --- a/tests/purs/failing/DuplicateTypeClass.out +++ b/tests/purs/failing/DuplicateTypeClass.out @@ -1,10 +1,10 @@ Error found: in module Main -at tests/purs/failing/DuplicateTypeClass.purs:3:1 - 3:8 (line 3, column 1 - line 3, column 8) +at tests/purs/failing/DuplicateTypeClass.purs:4:1 - 4:8 (line 4, column 1 - line 4, column 8) Type class C has been defined multiple times: - tests/purs/failing/DuplicateTypeClass.purs:3:1 - 3:8 (line 3, column 1 - line 3, column 8) + tests/purs/failing/DuplicateTypeClass.purs:4:1 - 4:8 (line 4, column 1 - line 4, column 8) in type class declaration for C diff --git a/tests/purs/failing/InfiniteKind.out b/tests/purs/failing/InfiniteKind.out index 03dcf11f2c..69e5eb4b9a 100644 --- a/tests/purs/failing/InfiniteKind.out +++ b/tests/purs/failing/InfiniteKind.out @@ -1,15 +1,20 @@ Error found: in module Main -at tests/purs/failing/InfiniteKind.purs:5:15 - 5:18 (line 5, column 15 - line 5, column 18) +at tests/purs/failing/InfiniteKind.purs:5:17 - 5:18 (line 5, column 17 - line 5, column 18) An infinite kind was inferred for a type: +   +  t5 -> t6 +   - k1 -> k2 - - -while checking the kind of a a +while checking that type a + has kind t0 +while inferring the kind of a a +while inferring the kind of a a -> F a in type constructor F +where t0 is an unknown type + See https://github.com/purescript/documentation/blob/master/errors/InfiniteKind.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/InfiniteKind2.out b/tests/purs/failing/InfiniteKind2.out index efaf0e18b0..0153bcc434 100644 --- a/tests/purs/failing/InfiniteKind2.out +++ b/tests/purs/failing/InfiniteKind2.out @@ -1,14 +1,20 @@ Error found: in module InfiniteKind2 -at tests/purs/failing/InfiniteKind2.purs:5:1 - 5:36 (line 5, column 1 - line 5, column 36) +at tests/purs/failing/InfiniteKind2.purs:5:23 - 5:27 (line 5, column 23 - line 5, column 27) An infinite kind was inferred for a type: +   +  (t5 -> t6) -> Type +   - (k4 -> k3) -> Type - - +while checking that type Tree + has kind t0 +while inferring the kind of m Tree +while inferring the kind of m Tree -> Tree m in type constructor Tree +where t0 is an unknown type + See https://github.com/purescript/documentation/blob/master/errors/InfiniteKind.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/InfiniteKind2.purs b/tests/purs/failing/InfiniteKind2.purs index 63c910400a..170cd8576b 100644 --- a/tests/purs/failing/InfiniteKind2.purs +++ b/tests/purs/failing/InfiniteKind2.purs @@ -2,4 +2,4 @@ module InfiniteKind2 where -data Tree m a = Tree a (m (Tree a)) +data Tree m = Tree (m Tree) diff --git a/tests/purs/failing/InstanceChainBothUnknownAndMatch.out b/tests/purs/failing/InstanceChainBothUnknownAndMatch.out index 4284b97d1e..0fb050630d 100644 --- a/tests/purs/failing/InstanceChainBothUnknownAndMatch.out +++ b/tests/purs/failing/InstanceChainBothUnknownAndMatch.out @@ -19,7 +19,7 @@ at tests/purs/failing/InstanceChainBothUnknownAndMatch.purs:17:13 - 17:55 (line The instance head contains unknown type variables. Consider adding a type annotation. while applying a function same - of type Same t0 t1 t2 => t0 -> t1 -> SProxy t2 + of type Same @Type @Type t0 t1 t2 => t0 -> t1 -> SProxy t2 to argument RProxy while inferring the type of same RProxy in value declaration example @@ -27,9 +27,9 @@ in value declaration example where t3 is a rigid type variable bound at (line 0, column 0 - line 0, column 0) t4 is an unknown type - t2 is an unknown type - t1 is an unknown type t0 is an unknown type + t1 is an unknown type + t2 is an unknown type See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out index d7cd4af230..cdb227c97b 100644 --- a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out +++ b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out @@ -3,15 +3,15 @@ in module InstanceChainSkolemUnknownMatch at tests/purs/failing/InstanceChainSkolemUnknownMatch.purs:14:13 - 14:36 (line 14, column 13 - line 14, column 36) No type class instance was found for -   -  InstanceChainSkolemUnknownMatch.Same (Proxy t3)  -  (Proxy Int) -  t4  -   +   +  InstanceChainSkolemUnknownMatch.Same (Proxy @Type t3)  +  (Proxy @Type Int) +  t4  +   The instance head contains unknown type variables. Consider adding a type annotation. while applying a function same - of type Same t0 t1 t2 => t0 -> t1 -> SProxy t2 + of type Same @Type @Type t0 t1 t2 => t0 -> t1 -> SProxy t2 to argument Proxy while inferring the type of same Proxy in value declaration example @@ -19,9 +19,9 @@ in value declaration example where t3 is a rigid type variable bound at (line 0, column 0 - line 0, column 0) t4 is an unknown type - t2 is an unknown type - t1 is an unknown type t0 is an unknown type + t1 is an unknown type + t2 is an unknown type See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/InstanceChainSkolemUnknownMatch.purs b/tests/purs/failing/InstanceChainSkolemUnknownMatch.purs index a3111f307b..9968ed3b4c 100644 --- a/tests/purs/failing/InstanceChainSkolemUnknownMatch.purs +++ b/tests/purs/failing/InstanceChainSkolemUnknownMatch.purs @@ -10,6 +10,6 @@ same :: forall l r o. Same l r o => l -> r -> SProxy o same _ _ = SProxy -- shouldn't discard sameY as Apart -example :: forall t. Proxy t -> SProxy _ +example :: forall (t :: Type). Proxy t -> SProxy _ example _ = same (Proxy :: Proxy t) (Proxy :: Proxy Int) diff --git a/tests/purs/failing/KindError.out b/tests/purs/failing/KindError.out index 4fbd07da7e..1339a8890d 100644 --- a/tests/purs/failing/KindError.out +++ b/tests/purs/failing/KindError.out @@ -1,18 +1,25 @@ Error found: in module Main -at tests/purs/failing/KindError.purs:6:35 - 6:38 (line 6, column 35 - line 6, column 38) +at tests/purs/failing/KindError.purs:6:35 - 6:36 (line 6, column 35 - line 6, column 36) Could not match kind - - k2 -> k3 - +   +  Type +   with kind - - Type - - +   +  t8 -> t9 +   + +while checking that type f + has kind t0 -> t1 +while inferring the kind of f a +while inferring the kind of f a -> KindError f a in type constructor KindError +where t0 is an unknown type + t1 is an unknown type + See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/KindStar.out b/tests/purs/failing/KindStar.out index a4926ef8b2..03dc0acb69 100644 --- a/tests/purs/failing/KindStar.out +++ b/tests/purs/failing/KindStar.out @@ -8,9 +8,9 @@ at tests/purs/failing/KindStar.purs:7:1 - 7:13 (line 7, column 1 - line 7, colum  List   having the kind - - Type -> Type - +   +  Type -> Type +   instead. in value declaration test diff --git a/tests/purs/failing/LacksWithSubGoal.out b/tests/purs/failing/LacksWithSubGoal.out index 3ad9219517..2602362d23 100644 --- a/tests/purs/failing/LacksWithSubGoal.out +++ b/tests/purs/failing/LacksWithSubGoal.out @@ -9,7 +9,7 @@ at tests/purs/failing/LacksWithSubGoal.purs:14:11 - 14:33 (line 14, column 11 -   while applying a function union - of type Lacks t1 t2 => S t1 -> R t2 + of type Lacks @Type t1 t2 => S t1 -> R t2 to argument S while checking that expression union S has type R  @@ -20,8 +20,8 @@ in value declaration example where r0 is a rigid type variable bound at (line 14, column 11 - line 14, column 33) - t2 is an unknown type t1 is an unknown type + t2 is an unknown type See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/MonoKindDataBindingGroup.out b/tests/purs/failing/MonoKindDataBindingGroup.out new file mode 100644 index 0000000000..d83be0b41a --- /dev/null +++ b/tests/purs/failing/MonoKindDataBindingGroup.out @@ -0,0 +1,21 @@ +Error found: +in module Main +at tests/purs/failing/MonoKindDataBindingGroup.purs:8:12 - 8:17 (line 8, column 12 - line 8, column 17) + + Could not match kind +   +  Symbol +   + with kind +   +  Type +   + +while checking that type "bad" + has kind Type +while inferring the kind of A "bad" +in type synonym X + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/MonoKindDataBindingGroup.purs b/tests/purs/failing/MonoKindDataBindingGroup.purs new file mode 100644 index 0000000000..3060e6e9b5 --- /dev/null +++ b/tests/purs/failing/MonoKindDataBindingGroup.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +data F (a :: Type -> Type) = F +data A a = A (B a) +type B a = F A + +type X = A "bad" diff --git a/tests/purs/failing/Object.out b/tests/purs/failing/Object.out index 1360fd08bc..ef5e99d965 100644 --- a/tests/purs/failing/Object.out +++ b/tests/purs/failing/Object.out @@ -16,8 +16,8 @@ while applying a function test to argument {} in value declaration test1 -where t1 is an unknown type - t0 is an unknown type +where t0 is an unknown type + t1 is an unknown type See https://github.com/purescript/documentation/blob/master/errors/PropertyIsMissing.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/OrphanKindDeclaration1.out b/tests/purs/failing/OrphanKindDeclaration1.out new file mode 100644 index 0000000000..2aab0aa74a --- /dev/null +++ b/tests/purs/failing/OrphanKindDeclaration1.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/OrphanKindDeclaration1.purs:4:1 - 4:17 (line 4, column 1 - line 4, column 17) + + The kind declaration for Foo should be followed by its definition. + + +See https://github.com/purescript/documentation/blob/master/errors/OrphanKindDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OrphanKindDeclaration1.purs b/tests/purs/failing/OrphanKindDeclaration1.purs new file mode 100644 index 0000000000..6760f449e8 --- /dev/null +++ b/tests/purs/failing/OrphanKindDeclaration1.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith OrphanKindDeclaration +module Main where + +type Foo :: Type diff --git a/tests/purs/failing/OrphanKindDeclaration2.out b/tests/purs/failing/OrphanKindDeclaration2.out new file mode 100644 index 0000000000..f8ac604975 --- /dev/null +++ b/tests/purs/failing/OrphanKindDeclaration2.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/OrphanKindDeclaration2.purs:4:1 - 4:17 (line 4, column 1 - line 4, column 17) + + The kind declaration for Foo should be followed by its definition. + + +See https://github.com/purescript/documentation/blob/master/errors/OrphanKindDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OrphanKindDeclaration2.purs b/tests/purs/failing/OrphanKindDeclaration2.purs new file mode 100644 index 0000000000..3c8599f5d5 --- /dev/null +++ b/tests/purs/failing/OrphanKindDeclaration2.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith OrphanKindDeclaration +module Main where + +type Foo :: Type +data Foo = Foo Int diff --git a/tests/purs/failing/PolykindGeneralizationLet.out b/tests/purs/failing/PolykindGeneralizationLet.out new file mode 100644 index 0000000000..7547a0b8ea --- /dev/null +++ b/tests/purs/failing/PolykindGeneralizationLet.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/PolykindGeneralizationLet.purs:14:10 - 14:26 (line 14, column 10 - line 14, column 26) + + Could not match type +   +  "foo" +   + with type +   +  Int +   + +while trying to match type t0 "foo" + with type Proxy @Type Int +while checking that expression Proxy + has type Proxy @Type Int +in value declaration test + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PolykindGeneralizationLet.purs b/tests/purs/failing/PolykindGeneralizationLet.purs new file mode 100644 index 0000000000..9192f096c1 --- /dev/null +++ b/tests/purs/failing/PolykindGeneralizationLet.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +data Proxy a = Proxy +data F f a = F (f a) + +fproxy :: forall f a. Proxy f -> Proxy a -> Proxy (F f a) +fproxy _ _ = Proxy + +test = c + where + a = fproxy (Proxy :: _ Proxy) + b = a (Proxy :: _ Int) + c = a (Proxy :: _ "foo") diff --git a/tests/purs/failing/PolykindInstanceOverlapping.out b/tests/purs/failing/PolykindInstanceOverlapping.out new file mode 100644 index 0000000000..f9a97817ea --- /dev/null +++ b/tests/purs/failing/PolykindInstanceOverlapping.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/PolykindInstanceOverlapping.purs:12:1 - 13:19 (line 12, column 1 - line 13, column 19) + + Overlapping type class instances found for +   +  Main.ShowP (Proxy @k a) +   + The following instances were found: + + Main.test1 + Main.test2 + + +in type class instance +  + Main.ShowP (Proxy (a :: k)) +  + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingInstances.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PolykindInstanceOverlapping.purs b/tests/purs/failing/PolykindInstanceOverlapping.purs new file mode 100644 index 0000000000..0625e65d44 --- /dev/null +++ b/tests/purs/failing/PolykindInstanceOverlapping.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith OverlappingInstances +module Main where + +data Proxy a = Proxy + +class ShowP a where + showP :: a -> String + +instance test1 :: ShowP (Proxy ((a) :: k)) where + showP _ = "Type" + +instance test2 :: ShowP (Proxy ((a) :: k)) where + showP _ = "Type" diff --git a/tests/purs/failing/PolykindInstantiatedInstance.out b/tests/purs/failing/PolykindInstantiatedInstance.out new file mode 100644 index 0000000000..6cad82ab29 --- /dev/null +++ b/tests/purs/failing/PolykindInstantiatedInstance.out @@ -0,0 +1,25 @@ +Error found: +in module Main +at tests/purs/failing/PolykindInstantiatedInstance.purs:12:37 - 12:42 (line 12, column 37 - line 12, column 42) + + Could not match kind +   +  Symbol +   + with kind +   +  Type +   + +while trying to match type "foo" + with type t1 +while checking that expression Proxy + has type t0 t1 +in value declaration test1 + +where t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PolykindInstantiatedInstance.purs b/tests/purs/failing/PolykindInstantiatedInstance.purs new file mode 100644 index 0000000000..5304fcaaed --- /dev/null +++ b/tests/purs/failing/PolykindInstantiatedInstance.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +data Proxy a = Proxy + +class F f where + f :: forall a b. (a -> b) -> f a -> f b + +instance fProxy :: F Proxy where + f _ _ = Proxy + +test1 = f (\a -> "foo") (Proxy :: _ "foo") diff --git a/tests/purs/failing/PolykindInstantiation.out b/tests/purs/failing/PolykindInstantiation.out new file mode 100644 index 0000000000..bf95fdc892 --- /dev/null +++ b/tests/purs/failing/PolykindInstantiation.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/PolykindInstantiation.purs:8:33 - 8:38 (line 8, column 33 - line 8, column 38) + + Could not match kind +   +  Symbol +   + with kind +   +  Type +   + +while checking that type "foo" + has kind Type +while inferring the kind of F Proxy "foo" +while inferring the kind of Proxy (F Proxy "foo") +in value declaration test2 + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PolykindInstantiation.purs b/tests/purs/failing/PolykindInstantiation.purs new file mode 100644 index 0000000000..207423eb1b --- /dev/null +++ b/tests/purs/failing/PolykindInstantiation.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +data Proxy a = Proxy +data F f (a :: Type) = F (f a) + +test1 = Proxy :: Proxy (F Proxy Int) +test2 = Proxy :: Proxy (F Proxy "foo") diff --git a/tests/purs/failing/QuantificationCheckFailure.out b/tests/purs/failing/QuantificationCheckFailure.out new file mode 100644 index 0000000000..de7b5fcc30 --- /dev/null +++ b/tests/purs/failing/QuantificationCheckFailure.out @@ -0,0 +1,12 @@ +Error found: +in module Main +at tests/purs/failing/QuantificationCheckFailure.purs:13:48 - 13:69 (line 13, column 48 - line 13, column 69) + + Cannot generalize the kind of type variable d since it would not be well-scoped. + Try adding a kind annotation. + +in kind declaration for T + +See https://github.com/purescript/documentation/blob/master/errors/QuantificationCheckFailureInKind.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/QuantificationCheckFailure.purs b/tests/purs/failing/QuantificationCheckFailure.purs new file mode 100644 index 0000000000..4a600ff119 --- /dev/null +++ b/tests/purs/failing/QuantificationCheckFailure.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith QuantificationCheckFailureInKind +module Main where + +data Proxy :: forall k. k -> Type +data Proxy a = Proxy + +data Relate :: forall a (b :: a). a -> Proxy b -> Type +data Relate x y = Relate + +-- Inferring and generalizing the kind of `d` such that implicitly generalized +-- variables appear first would result in a reference to `a` before `a` is +-- declared. See "Kind Inference for Datatypes" Section 7.2 +data T :: forall (a :: Type) (b :: a) (c :: a) d. Relate b d -> Type +data T a = T diff --git a/tests/purs/failing/QuantificationCheckFailure2.out b/tests/purs/failing/QuantificationCheckFailure2.out new file mode 100644 index 0000000000..09e3c6177a --- /dev/null +++ b/tests/purs/failing/QuantificationCheckFailure2.out @@ -0,0 +1,16 @@ +Error found: +in module Main +at tests/purs/failing/QuantificationCheckFailure2.purs:6:13 - 6:30 (line 6, column 13 - line 6, column 30) + + Cannot unambiguously generalize kinds appearing in the elaborated type: + + forall (a :: t8). Proxy @t8 a + + where t8 is an unknown kind. + Try adding additional kind signatures or polymorphic kind variables. + +in type constructor P + +See https://github.com/purescript/documentation/blob/master/errors/QuantificationCheckFailureInType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/QuantificationCheckFailure2.purs b/tests/purs/failing/QuantificationCheckFailure2.purs new file mode 100644 index 0000000000..d38a9088ef --- /dev/null +++ b/tests/purs/failing/QuantificationCheckFailure2.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith QuantificationCheckFailureInType +module Main where + +data Proxy a = Proxy + +data P = P (forall a. Proxy a) diff --git a/tests/purs/failing/QuantificationCheckFailure3.out b/tests/purs/failing/QuantificationCheckFailure3.out new file mode 100644 index 0000000000..a713fc6a2a --- /dev/null +++ b/tests/purs/failing/QuantificationCheckFailure3.out @@ -0,0 +1,12 @@ +Error found: +in module Main +at tests/purs/failing/QuantificationCheckFailure3.purs:7:1 - 7:34 (line 7, column 1 - line 7, column 34) + + Visible dependent quantification of type variable k is not supported. + If you would like this feature supported, please bother Liam Goodacre (@LiamGoodacre). + +in type synonym Hmm + +See https://github.com/purescript/documentation/blob/master/errors/VisibleQuantificationCheckFailureInType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/QuantificationCheckFailure3.purs b/tests/purs/failing/QuantificationCheckFailure3.purs new file mode 100644 index 0000000000..c5fc58f743 --- /dev/null +++ b/tests/purs/failing/QuantificationCheckFailure3.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith VisibleQuantificationCheckFailureInType +module Main where + +foreign import data KProxy :: forall (k :: Type) . k -> Type +foreign import data TProxy :: forall (k :: Type) (t :: k) . KProxy t + +type Hmm k = (TProxy :: KProxy k) diff --git a/tests/purs/failing/QuantifiedKind.out b/tests/purs/failing/QuantifiedKind.out new file mode 100644 index 0000000000..420c85ab12 --- /dev/null +++ b/tests/purs/failing/QuantifiedKind.out @@ -0,0 +1,15 @@ +Error found: +in module Main +at tests/purs/failing/QuantifiedKind.purs:6:22 - 6:23 (line 6, column 22 - line 6, column 23) + + Type variable k is undefined. + +while inferring the kind of k +while checking that type k + has kind Type +while inferring the kind of forall (a :: k) k. Proxy a +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/UndefinedTypeVariable.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/QuantifiedKind.purs b/tests/purs/failing/QuantifiedKind.purs new file mode 100644 index 0000000000..bd46b3621c --- /dev/null +++ b/tests/purs/failing/QuantifiedKind.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith UndefinedTypeVariable +module Main where + +data Proxy a = Proxy + +test :: forall (a :: k) k. Proxy a +test = Proxy diff --git a/tests/purs/failing/RowConstructors1.out b/tests/purs/failing/RowConstructors1.out index 92124fcd1b..5558dec917 100644 --- a/tests/purs/failing/RowConstructors1.out +++ b/tests/purs/failing/RowConstructors1.out @@ -3,15 +3,17 @@ in module Main at tests/purs/failing/RowConstructors1.purs:7:16 - 7:19 (line 7, column 16 - line 7, column 19) Could not match kind - - # Type - +   +  Type +   with kind +   +  Row Type +   - Type - - -while checking the kind of Record Foo +while checking that type Foo + has kind Row Type +while inferring the kind of Record Foo in type synonym Baz See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, diff --git a/tests/purs/failing/RowConstructors2.out b/tests/purs/failing/RowConstructors2.out index 813c598204..03f17dfcfb 100644 --- a/tests/purs/failing/RowConstructors2.out +++ b/tests/purs/failing/RowConstructors2.out @@ -3,15 +3,17 @@ in module Main at tests/purs/failing/RowConstructors2.purs:7:16 - 7:19 (line 7, column 16 - line 7, column 19) Could not match kind - - # Type - +   +  Function (Row Type) +   with kind +   +  Row +   - # Type -> # Type - - -while checking the kind of Record Foo +while checking that type Foo + has kind Row Type +while inferring the kind of Record Foo in type synonym Bar See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, diff --git a/tests/purs/failing/RowConstructors3.out b/tests/purs/failing/RowConstructors3.out index 082738bc86..f359a21d4f 100644 --- a/tests/purs/failing/RowConstructors3.out +++ b/tests/purs/failing/RowConstructors3.out @@ -3,15 +3,17 @@ in module Main at tests/purs/failing/RowConstructors3.purs:7:16 - 7:19 (line 7, column 16 - line 7, column 19) Could not match kind - - # Type - +   +  Type +   with kind +   +  Row Type +   - Type - - -while checking the kind of Record Foo +while checking that type Foo + has kind Row Type +while inferring the kind of Record Foo in type synonym Bar See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, diff --git a/tests/purs/failing/RowLacks.out b/tests/purs/failing/RowLacks.out index 4532d97542..a4565012f6 100644 --- a/tests/purs/failing/RowLacks.out +++ b/tests/purs/failing/RowLacks.out @@ -12,10 +12,10 @@ at tests/purs/failing/RowLacks.purs:16:9 - 16:68 (line 16, column 9 - line 16, c   while applying a function lacksX - of type Lacks "x" t0 => RProxy t0 -> RProxy () + of type Lacks @Type "x" t0 => RProxy t0 -> RProxy (() @Type) to argument RProxy while checking that expression lacksX RProxy - has type RProxy () + has type RProxy (() @Type) in value declaration test1 where t0 is an unknown type diff --git a/tests/purs/failing/RowsInKinds.out b/tests/purs/failing/RowsInKinds.out new file mode 100644 index 0000000000..a226e71125 --- /dev/null +++ b/tests/purs/failing/RowsInKinds.out @@ -0,0 +1,28 @@ +Error found: +in module Main +at tests/purs/failing/RowsInKinds.purs:14:16 - 14:17 (line 14, column 16 - line 14, column 17) + + Could not match kind +   +  ( z :: Type +  | t25  +  )  +   + with kind +   +  ( x :: Type +  , y :: Type +  )  +   + +while checking that type Z + has kind R @Type  +  ( x :: Type +  , y :: Type +  )  +while inferring the kind of P Z +in type synonym Test3 + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RowsInKinds.purs b/tests/purs/failing/RowsInKinds.purs new file mode 100644 index 0000000000..0853fa0487 --- /dev/null +++ b/tests/purs/failing/RowsInKinds.purs @@ -0,0 +1,15 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +foreign import data R :: forall k. Row k -> Type +foreign import data X :: forall r. R (x :: Type | r) +foreign import data Y :: forall r. R (y :: Type | r) +foreign import data Z :: forall r. R (z :: Type | r) + +data P :: R (x :: Type, y :: Type) -> Type +data P a = P + +type Test1 = P X +type Test2 = P Y +type Test3 = P Z + diff --git a/tests/purs/failing/ScopedKindVariableSynonym.out b/tests/purs/failing/ScopedKindVariableSynonym.out new file mode 100644 index 0000000000..096a622818 --- /dev/null +++ b/tests/purs/failing/ScopedKindVariableSynonym.out @@ -0,0 +1,12 @@ +Error found: +in module Main +at tests/purs/failing/ScopedKindVariableSynonym.purs:7:14 - 7:15 (line 7, column 14 - line 7, column 15) + + Type variable a is undefined. + +while inferring the kind of a +in type synonym B + +See https://github.com/purescript/documentation/blob/master/errors/UndefinedTypeVariable.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ScopedKindVariableSynonym.purs b/tests/purs/failing/ScopedKindVariableSynonym.purs new file mode 100644 index 0000000000..8eeefcf08f --- /dev/null +++ b/tests/purs/failing/ScopedKindVariableSynonym.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith UndefinedTypeVariable +module Main where + +type A x = forall a. a -> x -> Type + +type B :: forall x. A x +type B y z = a diff --git a/tests/purs/failing/SkolemEscapeKinds.out b/tests/purs/failing/SkolemEscapeKinds.out new file mode 100644 index 0000000000..a1732cc381 --- /dev/null +++ b/tests/purs/failing/SkolemEscapeKinds.out @@ -0,0 +1,18 @@ +Error found: +in module Main +at tests/purs/failing/SkolemEscapeKinds.purs:8:10 - 8:17 (line 8, column 10 - line 8, column 17) + + The type variable k, bound at + + tests/purs/failing/SkolemEscapeKinds.purs:8:16 - 8:17 (line 8, column 16 - line 8, column 17) + + has escaped its scope, appearing in the type +   +  Proxy +   + +in type synonym B + +See https://github.com/purescript/documentation/blob/master/errors/EscapedSkolem.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/SkolemEscapeKinds.purs b/tests/purs/failing/SkolemEscapeKinds.purs new file mode 100644 index 0000000000..3b838657dd --- /dev/null +++ b/tests/purs/failing/SkolemEscapeKinds.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith EscapedSkolem +module Main where + +data Proxy a = Proxy + +data A (a :: forall k. k -> Type) = A + +type B = Proxy A diff --git a/tests/purs/failing/StandaloneKindSignatures1.out b/tests/purs/failing/StandaloneKindSignatures1.out new file mode 100644 index 0000000000..ea8a49861e --- /dev/null +++ b/tests/purs/failing/StandaloneKindSignatures1.out @@ -0,0 +1,21 @@ +Error found: +in module Main +at tests/purs/failing/StandaloneKindSignatures1.purs:7:25 - 7:30 (line 7, column 25 - line 7, column 30) + + Could not match kind +   +  Symbol +   + with kind +   +  Type +   + +while checking that type "foo" + has kind Type +while inferring the kind of Pair Int "foo" +in value declaration test + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/StandaloneKindSignatures1.purs b/tests/purs/failing/StandaloneKindSignatures1.purs new file mode 100644 index 0000000000..55689cd929 --- /dev/null +++ b/tests/purs/failing/StandaloneKindSignatures1.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +data Pair :: forall k. k -> k -> Type +data Pair a b = Pair + +test = Pair :: Pair Int "foo" diff --git a/tests/purs/failing/StandaloneKindSignatures2.out b/tests/purs/failing/StandaloneKindSignatures2.out new file mode 100644 index 0000000000..9e9df4a898 --- /dev/null +++ b/tests/purs/failing/StandaloneKindSignatures2.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/StandaloneKindSignatures2.purs:8:35 - 8:36 (line 8, column 35 - line 8, column 36) + + Could not match kind +   +  k2 +   + with kind +   +  k1 +   + +while checking that type b + has kind k1 +while inferring the kind of Pair a b +while inferring the kind of Pair a b -> Pair' @k1 @k2 a b +in type constructor Pair' + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/StandaloneKindSignatures2.purs b/tests/purs/failing/StandaloneKindSignatures2.purs new file mode 100644 index 0000000000..26ae48bd6c --- /dev/null +++ b/tests/purs/failing/StandaloneKindSignatures2.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +data Pair :: forall k. k -> k -> Type +data Pair a b = Pair + +newtype Pair' :: forall k1 k2. k1 -> k2 -> Type +newtype Pair' a b = Pair' (Pair a b) diff --git a/tests/purs/failing/StandaloneKindSignatures3.out b/tests/purs/failing/StandaloneKindSignatures3.out new file mode 100644 index 0000000000..db86c16e24 --- /dev/null +++ b/tests/purs/failing/StandaloneKindSignatures3.out @@ -0,0 +1,21 @@ +Error found: +in module Main +at tests/purs/failing/StandaloneKindSignatures3.purs:7:18 - 7:23 (line 7, column 18 - line 7, column 23) + + Could not match kind +   +  Symbol +   + with kind +   +  Type +   + +while checking that type "foo" + has kind Type +while inferring the kind of Fst Int "foo" +in type synonym F + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/StandaloneKindSignatures3.purs b/tests/purs/failing/StandaloneKindSignatures3.purs new file mode 100644 index 0000000000..c3f2f3ea9d --- /dev/null +++ b/tests/purs/failing/StandaloneKindSignatures3.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +type Fst :: forall k. k -> k -> k +type Fst a b = a + +type F = Fst Int "foo" diff --git a/tests/purs/failing/StandaloneKindSignatures4.out b/tests/purs/failing/StandaloneKindSignatures4.out new file mode 100644 index 0000000000..a1fa795428 --- /dev/null +++ b/tests/purs/failing/StandaloneKindSignatures4.out @@ -0,0 +1,25 @@ +Error found: +in module Main +at tests/purs/failing/StandaloneKindSignatures4.purs:7:24 - 7:29 (line 7, column 24 - line 7, column 29) + + Could not match kind +   +  Symbol +   + with kind +   +  Type +   + +while checking that type "foo" + has kind Type +while inferring the kind of To Int "foo" +in type class instance +  + Main.To Int  + "foo" +  + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/StandaloneKindSignatures4.purs b/tests/purs/failing/StandaloneKindSignatures4.purs new file mode 100644 index 0000000000..4ae1bb8e88 --- /dev/null +++ b/tests/purs/failing/StandaloneKindSignatures4.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +class To :: forall k. k -> k -> Constraint +class To a b | a -> b + +instance to1 :: To Int "foo" diff --git a/tests/purs/failing/Superclasses3.out b/tests/purs/failing/Superclasses3.out index d7146780cd..d3abf7268a 100644 --- a/tests/purs/failing/Superclasses3.out +++ b/tests/purs/failing/Superclasses3.out @@ -1,12 +1,21 @@ Error found: in module UnknownSuperclassTypeVar -at tests/purs/failing/Superclasses3.purs:8:1 - 8:23 (line 8, column 1 - line 8, column 23) +at tests/purs/failing/Superclasses3.purs:8:12 - 8:13 (line 8, column 12 - line 8, column 13) Type variable b is undefined. -while checking the kind of { "Foo0" :: Record () -> Foo b - }  -in type synonym Bar +while inferring the kind of b +while checking that type b + has kind t0 +while inferring the kind of Foo$Dict b +while inferring the kind of Record () -> Foo$Dict b +while inferring the kind of ( "Foo0" :: Record () -> Foo$Dict b + )  +while inferring the kind of { "Foo0" :: Record () -> Foo$Dict b + }  +in type synonym Bar$Dict + +where t0 is an unknown type See https://github.com/purescript/documentation/blob/master/errors/UndefinedTypeVariable.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/TransitiveKindExport.out b/tests/purs/failing/TransitiveKindExport.out index c22d035610..620e552b12 100644 --- a/tests/purs/failing/TransitiveKindExport.out +++ b/tests/purs/failing/TransitiveKindExport.out @@ -4,7 +4,7 @@ at tests/purs/failing/TransitiveKindExport.purs:2:1 - 6:39 (line 2, column 1 - l An export for TestProxy requires the following to also be exported: - kind Test + Test diff --git a/tests/purs/failing/TypeWildcards4.out b/tests/purs/failing/TypeWildcards4.out new file mode 100644 index 0000000000..7aa287990f --- /dev/null +++ b/tests/purs/failing/TypeWildcards4.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/TypeWildcards4.purs:4:23 - 4:24 (line 4, column 23 - line 4, column 24) + + Unable to parse module: + Unexpected wildcard in type; type wildcards are only allowed in value annotations + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeWildcards4.purs b/tests/purs/failing/TypeWildcards4.purs new file mode 100644 index 0000000000..674c2f3f0c --- /dev/null +++ b/tests/purs/failing/TypeWildcards4.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +type OhNo = ((Int) :: _) diff --git a/tests/purs/failing/TypedBinders2.out b/tests/purs/failing/TypedBinders2.out index 8a94de7e6e..ca46c046b8 100644 --- a/tests/purs/failing/TypedBinders2.out +++ b/tests/purs/failing/TypedBinders2.out @@ -22,8 +22,8 @@ while applying a function (bind (#dict Bind t1)) (log "Foo") in value declaration main where t1 is an unknown type - t2 is an unknown type t0 is an unknown type + t2 is an unknown type See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/UnsupportedTypeInKind.out b/tests/purs/failing/UnsupportedTypeInKind.out new file mode 100644 index 0000000000..c26bebaa2c --- /dev/null +++ b/tests/purs/failing/UnsupportedTypeInKind.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/UnsupportedTypeInKind.purs:7:28 - 7:38 (line 7, column 28 - line 7, column 38) + + The type: + + Ok => Type + + is not supported in kinds. + + +See https://github.com/purescript/documentation/blob/master/errors/UnsupportedTypeInKind.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnsupportedTypeInKind.purs b/tests/purs/failing/UnsupportedTypeInKind.purs new file mode 100644 index 0000000000..46198033f3 --- /dev/null +++ b/tests/purs/failing/UnsupportedTypeInKind.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith UnsupportedTypeInKind +module Main where + +class Ok +instance ok :: Ok + +foreign import data Bad :: Ok => Type diff --git a/tests/purs/passing/Coercible.purs b/tests/purs/passing/Coercible.purs index 090468d791..bffa099eb7 100644 --- a/tests/purs/passing/Coercible.purs +++ b/tests/purs/passing/Coercible.purs @@ -28,6 +28,9 @@ id12ToId21 = coerce newtype Phantom1 a b = Phantom1 a +phantom1TypeToPhantom1Symbol :: forall x (y :: Type) (z :: Symbol). Phantom1 x y -> Phantom1 x z +phantom1TypeToPhantom1Symbol = coerce + phantom1ToId12 :: forall x y. Phantom1 x y -> Id1 (Id2 x) phantom1ToId12 = coerce @@ -152,4 +155,12 @@ testRolesNotReserved nominal representational phantom = "" data RoleNotReserved role = RoleNotReserved role +-- Contextual keywords should be allowed unquoted in rows. +type ContextualKeywords = + ( nominal :: String + , phantom :: String + , representational :: String + , role :: String + ) + main = log (coerce (NTString1 "Done") :: String) diff --git a/tests/purs/passing/KindUnificationInSolver.purs b/tests/purs/passing/KindUnificationInSolver.purs new file mode 100644 index 0000000000..74850311f3 --- /dev/null +++ b/tests/purs/passing/KindUnificationInSolver.purs @@ -0,0 +1,21 @@ +module Main where + +import Effect.Console (log) + +data Proxy a = Proxy + +class CtorKind ctor (kind :: Type) | ctor -> kind + +instance ctorKind0 :: CtorKind f z => CtorKind (f a) z +else instance ctorKind1 :: CtorKind ((a) :: t) t + +data Test a b + +ctorKind :: forall t k. CtorKind t k => Proxy t -> Proxy k +ctorKind _ = Proxy + +testCtor1 = ctorKind (Proxy :: Proxy (Test Int String)) +testCtor2 = ctorKind (Proxy :: Proxy (Test Int "What")) +testCtor3 = ctorKind (Proxy :: Proxy (Test Int)) + +main = log "Done" diff --git a/tests/purs/passing/KindedType.purs b/tests/purs/passing/KindedType.purs index 5898614d53..709c6a7181 100644 --- a/tests/purs/passing/KindedType.purs +++ b/tests/purs/passing/KindedType.purs @@ -31,9 +31,9 @@ class Clazz (a :: Type) where instance clazzString :: Clazz String where def = "test" -type Type a = ((a) :: Type) +type IsType a = ((a) :: Type) -type TestRecord a = Record (a :: Type a) +type TestRecord a = Record (a :: IsType a) test5 :: Test TestRecord test5 = { a: "test" } diff --git a/tests/purs/passing/PolykindBindingGroup1.purs b/tests/purs/passing/PolykindBindingGroup1.purs new file mode 100644 index 0000000000..51db49e420 --- /dev/null +++ b/tests/purs/passing/PolykindBindingGroup1.purs @@ -0,0 +1,13 @@ +module Main where + +import Effect.Console (log) + +data X a = X (Y a) | Z +data Y a = Y (X a) + +test1 = X (Y Z) :: X Int +test2 = X (Y Z) :: X "foo" +test3 = Y (X (Y Z)) :: Y Int +test4 = Y (X (Y Z)) :: Y "foo" + +main = log "Done" diff --git a/tests/purs/passing/PolykindBindingGroup2.purs b/tests/purs/passing/PolykindBindingGroup2.purs new file mode 100644 index 0000000000..d7d24e75d9 --- /dev/null +++ b/tests/purs/passing/PolykindBindingGroup2.purs @@ -0,0 +1,16 @@ +module Main where + +import Effect.Console (log) + +data Proxy a = Proxy + +data X a = X (Y a => Proxy a) + +class Z (X a) <= Y a + +class Z a + +test1 = X (Proxy :: _ Int) +test2 = X (Proxy :: _ "foo") + +main = log "Done" diff --git a/tests/purs/passing/PolykindGeneralization.purs b/tests/purs/passing/PolykindGeneralization.purs new file mode 100644 index 0000000000..c9b0d59fc8 --- /dev/null +++ b/tests/purs/passing/PolykindGeneralization.purs @@ -0,0 +1,15 @@ +module Main where + +import Effect.Console (log) + +data Proxy a = Proxy +data F f a = F (f a) + +fproxy :: forall f a. Proxy f -> Proxy a -> Proxy (F f a) +fproxy _ _ = Proxy + +a = fproxy (Proxy :: _ Proxy) +b = a (Proxy :: _ Int) +c = a (Proxy :: _ "foo") + +main = log "Done" diff --git a/tests/purs/passing/PolykindGeneralizationHygiene.purs b/tests/purs/passing/PolykindGeneralizationHygiene.purs new file mode 100644 index 0000000000..75eadbef75 --- /dev/null +++ b/tests/purs/passing/PolykindGeneralizationHygiene.purs @@ -0,0 +1,11 @@ +module Main where + +import Effect.Console (log) + +-- First argument needs to be `k`. +type F k t = forall proxy. proxy k -> t + +test :: F Symbol Int +test _ = 42 + +main = log "Done" diff --git a/tests/purs/passing/PolykindGeneralizedTypeSynonym.purs b/tests/purs/passing/PolykindGeneralizedTypeSynonym.purs new file mode 100644 index 0000000000..d89ec1e9f8 --- /dev/null +++ b/tests/purs/passing/PolykindGeneralizedTypeSynonym.purs @@ -0,0 +1,12 @@ +module Main where + +import Effect.Console (log) + +data Proxy a = Proxy + +type Prozy = Proxy + +test1 = Proxy :: Prozy Int +test2 = Proxy :: Prozy "foo" + +main = log "Done" diff --git a/tests/purs/passing/PolykindInstanceDispatch.purs b/tests/purs/passing/PolykindInstanceDispatch.purs new file mode 100644 index 0000000000..eeae303a8a --- /dev/null +++ b/tests/purs/passing/PolykindInstanceDispatch.purs @@ -0,0 +1,21 @@ +module Main where + +import Prelude +import Effect.Console (log) +import Test.Assert + +data Proxy a = Proxy + +class ShowP a where + showP :: a -> String + +instance test1 :: ShowP (Proxy ((a) :: Type)) where + showP _ = "Type" + +instance test2 :: ShowP (Proxy ((a) :: Symbol)) where + showP _ = "Symbol" + +main = do + assert (showP (Proxy :: _ Int) == "Type") + assert (showP (Proxy :: _ "foo") == "Symbol") + log "Done" diff --git a/tests/purs/passing/PolykindInstantiatedInstance.purs b/tests/purs/passing/PolykindInstantiatedInstance.purs new file mode 100644 index 0000000000..f499c5eb78 --- /dev/null +++ b/tests/purs/passing/PolykindInstantiatedInstance.purs @@ -0,0 +1,22 @@ +module Main where + +import Effect.Console (log) + +data Proxy a = Proxy + +class F f where + f :: forall a b. (a -> b) -> f a -> f b + +instance fProxy :: F Proxy where + f _ _ = Proxy + +test1 :: forall a. Proxy a +test1 = f (\a -> a) Proxy + +test2 :: Proxy Int +test2 = f (\a -> a) (Proxy :: Proxy Int) + +test3 :: Proxy String +test3 = f (\a -> "foo") Proxy + +main = log "Done" diff --git a/tests/purs/passing/PolykindInstantiation.purs b/tests/purs/passing/PolykindInstantiation.purs new file mode 100644 index 0000000000..1b83b7600d --- /dev/null +++ b/tests/purs/passing/PolykindInstantiation.purs @@ -0,0 +1,17 @@ +module Main where + +import Effect.Console (log) + +data Proxy a = Proxy +data F f a = F (f a) + +test1 = Proxy :: Proxy Int +test2 = Proxy :: Proxy "foo" +test3 = Proxy :: Proxy Proxy +test4 = Proxy :: Proxy F +test5 = Proxy :: Proxy (F Proxy) +test6 = Proxy :: Proxy (F (F Proxy)) +test7 = Proxy :: Proxy (F Proxy Int) +test8 = Proxy :: Proxy (F Proxy "foo") + +main = log "Done" diff --git a/tests/purs/passing/PolykindRowCons.purs b/tests/purs/passing/PolykindRowCons.purs new file mode 100644 index 0000000000..54448c64c8 --- /dev/null +++ b/tests/purs/passing/PolykindRowCons.purs @@ -0,0 +1,51 @@ +module Main where + +import Effect.Console (log) +import Prim.Row + +data Proxy a = Proxy +data Identity a = Identity a +data App f a = App (f a) + +type RowType = + ( a :: Int + , b :: String + , c :: Boolean + ) + +type RowTypeType = + ( a :: Proxy + , b :: Identity + , c :: App Identity + ) + +type RowSymbol = + ( a :: "a" + , b :: "b" + , c :: "c" + ) + +lookup :: forall sym v rx r. Cons sym v rx r => Proxy sym -> Proxy r -> Proxy v +lookup _ _ = Proxy + +lookup1 = lookup (Proxy :: _ "a") (Proxy :: _ RowType) +lookup2 = lookup (Proxy :: _ "b") (Proxy :: _ RowType) +lookup3 = lookup (Proxy :: _ "c") (Proxy :: _ RowType) +lookup4 = lookup (Proxy :: _ "a") (Proxy :: _ RowTypeType) +lookup5 = lookup (Proxy :: _ "b") (Proxy :: _ RowTypeType) +lookup6 = lookup (Proxy :: _ "c") (Proxy :: _ RowTypeType) +lookup7 = lookup (Proxy :: _ "a") (Proxy :: _ RowSymbol) +lookup8 = lookup (Proxy :: _ "b") (Proxy :: _ RowSymbol) +lookup9 = lookup (Proxy :: _ "c") (Proxy :: _ RowSymbol) + +test1 = lookup1 :: Proxy Int +test2 = lookup2 :: Proxy String +test3 = lookup3 :: Proxy Boolean +test4 = lookup4 :: Proxy Proxy +test5 = lookup5 :: Proxy Identity +test6 = lookup6 :: Proxy (App Identity) +test7 = lookup7 :: Proxy "a" +test8 = lookup8 :: Proxy "b" +test9 = lookup9 :: Proxy "c" + +main = log "Done" diff --git a/tests/purs/passing/QuantifiedKind.purs b/tests/purs/passing/QuantifiedKind.purs new file mode 100644 index 0000000000..b8b107356a --- /dev/null +++ b/tests/purs/passing/QuantifiedKind.purs @@ -0,0 +1,10 @@ +module Main where + +import Effect.Console (log) + +data Proxy a = Proxy + +test :: forall k (a :: k). Proxy a +test = Proxy + +main = log "Done" diff --git a/tests/purs/passing/Rank2Kinds.purs b/tests/purs/passing/Rank2Kinds.purs new file mode 100644 index 0000000000..38d29641d8 --- /dev/null +++ b/tests/purs/passing/Rank2Kinds.purs @@ -0,0 +1,21 @@ +module Main where + +import Effect.Console (log) + +data A (a :: forall k. k -> Type) = A + +data B :: (forall k. k -> Type) -> Type +data B a = B + +data Pair a b = Pair +data Proxy a = Proxy + +type Id a = a +type MkP (f :: forall k. k -> k) = Pair (f Int) (f "foo") + +k :: forall a b. Proxy (Pair Int "foo") -> Int +k _ = 42 + +test = k (Proxy :: Proxy (MkP Id)) + +main = log "Done" diff --git a/tests/purs/passing/RowLacks.purs b/tests/purs/passing/RowLacks.purs index 06e7b91d09..34d664ce11 100644 --- a/tests/purs/passing/RowLacks.purs +++ b/tests/purs/passing/RowLacks.purs @@ -4,6 +4,8 @@ import Effect.Console (log) import Prim.Row (class Lacks) import Type.Row (RProxy(..)) +data SProxy (a :: Symbol) = SProxy + lacksX :: forall r . Lacks "x" r @@ -11,6 +13,13 @@ lacksX -> RProxy () lacksX _ = RProxy +lacksSym + :: forall sym (to :: Row Type) + . Lacks sym to + => SProxy sym + -> RProxy to +lacksSym _ = RProxy + test1 :: RProxy () test1 = lacksX (RProxy :: RProxy (y :: Int, z :: String)) @@ -20,4 +29,7 @@ test2 _ = lacksX (RProxy :: RProxy (y :: Int, z :: String | r)) test3 :: RProxy () test3 = test2 (RProxy :: RProxy (a :: String)) +test4 :: forall sym. SProxy sym -> RProxy () +test4 = lacksSym + main = log "Done" diff --git a/tests/purs/passing/RowsInKinds.purs b/tests/purs/passing/RowsInKinds.purs new file mode 100644 index 0000000000..e49a687a82 --- /dev/null +++ b/tests/purs/passing/RowsInKinds.purs @@ -0,0 +1,15 @@ +module Main where + +import Effect.Console (log) + +foreign import data R :: forall k. Row k -> Type +foreign import data X :: forall r. R (x :: Type | r) +foreign import data Y :: forall r. R (y :: Type | r) + +data P :: R (x :: Type, y :: Type) -> Type +data P a = P + +type Test1 = P X +type Test2 = P Y + +main = log "Done" diff --git a/tests/purs/passing/RowsInKinds2.purs b/tests/purs/passing/RowsInKinds2.purs new file mode 100644 index 0000000000..c046a1fee2 --- /dev/null +++ b/tests/purs/passing/RowsInKinds2.purs @@ -0,0 +1,11 @@ +module Main where + +import Effect.Console (log) + +foreign import data R :: forall k. Row k -> Type +foreign import data X :: R () + +data P :: R () -> Type +data P a = P + +main = log "Done" diff --git a/tests/purs/passing/StandaloneKindSignatures.purs b/tests/purs/passing/StandaloneKindSignatures.purs new file mode 100644 index 0000000000..2e15f560ee --- /dev/null +++ b/tests/purs/passing/StandaloneKindSignatures.purs @@ -0,0 +1,27 @@ +module Main where + +import Effect.Console (log) + +data Pair :: forall k. k -> k -> Type +data Pair a b = Pair + +newtype Pair' :: forall k. k -> k -> Type +newtype Pair' a b = Pair' (Pair a b) + +type Fst :: forall k. k -> k -> k +type Fst a b = a + +class To :: forall k. k -> k -> Constraint +class To a b | a -> b + +test1 = Pair :: Pair Int String +test2 = Pair :: Pair "foo" "bar" +test3 = Pair' Pair :: Pair' Int String +test4 = Pair' Pair :: Pair' "foo" "bar" +test5 = 42 :: Fst Int String +test6 = Pair :: Pair (Fst "foo" "bar") "baz" + +instance to1 :: To Int String +instance to2 :: To "foo" "bar" + +main = log "Done" diff --git a/tests/purs/passing/TypeSynonymsInKinds.purs b/tests/purs/passing/TypeSynonymsInKinds.purs new file mode 100644 index 0000000000..4516593293 --- /dev/null +++ b/tests/purs/passing/TypeSynonymsInKinds.purs @@ -0,0 +1,25 @@ +module Main where + +import Effect.Console (log) + +type Id a = a + +data Proxy :: forall (k :: Id Type). k -> (Id Type) +data Proxy a = Proxy + +data P (a :: Id Type) = P + +class Test (a :: Id Type) + +instance testClass1 :: Test Int +instance testClass2 :: Test (Proxy "foo") + +test1 = Proxy :: Proxy Int +test2 = Proxy :: Proxy "foo" + +test3 :: forall k (a :: Id k). Proxy a +test3 = Proxy + +test4 = P :: P Int + +main = log "Done" diff --git a/tests/purs/warning/DeprecatedForeignImportKind.out b/tests/purs/warning/DeprecatedForeignImportKind.out new file mode 100644 index 0000000000..5f840f7a42 --- /dev/null +++ b/tests/purs/warning/DeprecatedForeignImportKind.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/warning/DeprecatedForeignImportKind.purs:4:1 - 4:24 (line 4, column 1 - line 4, column 24) + + Foreign kind imports are deprecated and will be removed in a future release. Use empty 'data' instead. + + +See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/DeprecatedForeignImportKind.purs b/tests/purs/warning/DeprecatedForeignImportKind.purs new file mode 100644 index 0000000000..0a12f8ac1e --- /dev/null +++ b/tests/purs/warning/DeprecatedForeignImportKind.purs @@ -0,0 +1,4 @@ +-- @shouldWarnWith WarningParsingModule +module Main where + +foreign import kind Foo diff --git a/tests/purs/warning/DeprecatedImportExportKinds.out b/tests/purs/warning/DeprecatedImportExportKinds.out new file mode 100644 index 0000000000..9a1ece0306 --- /dev/null +++ b/tests/purs/warning/DeprecatedImportExportKinds.out @@ -0,0 +1,30 @@ +Error 1 of 3: + + at tests/purs/warning/DeprecatedImportExportKinds.purs:6:13 - 6:21 (line 6, column 13 - line 6, column 21) + + Kind imports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead. + + + See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, + or to contribute content related to this error. + +Error 2 of 3: + + at tests/purs/warning/DeprecatedImportExportKinds/Lib.purs:5:1 - 5:24 (line 5, column 1 - line 5, column 24) + + Foreign kind imports are deprecated and will be removed in a future release. Use empty 'data' instead. + + + See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, + or to contribute content related to this error. + +Error 3 of 3: + + at tests/purs/warning/DeprecatedImportExportKinds/Lib.purs:2:5 - 2:13 (line 2, column 5 - line 2, column 13) + + Kind exports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead. + + + See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/warning/DeprecatedImportExportKinds.purs b/tests/purs/warning/DeprecatedImportExportKinds.purs new file mode 100644 index 0000000000..b52d729146 --- /dev/null +++ b/tests/purs/warning/DeprecatedImportExportKinds.purs @@ -0,0 +1,8 @@ +-- @shouldWarnWith WarningParsingModule +-- @shouldWarnWith WarningParsingModule +-- @shouldWarnWith WarningParsingModule +module Main where + +import Lib (kind Foo) + +foreign import data Bar :: Foo diff --git a/tests/purs/warning/DeprecatedImportExportKinds/Lib.purs b/tests/purs/warning/DeprecatedImportExportKinds/Lib.purs new file mode 100644 index 0000000000..8cc65ed21f --- /dev/null +++ b/tests/purs/warning/DeprecatedImportExportKinds/Lib.purs @@ -0,0 +1,5 @@ +module Lib + ( kind Foo + ) where + +foreign import kind Foo diff --git a/tests/purs/warning/DeprecatedRowKindSyntax.out b/tests/purs/warning/DeprecatedRowKindSyntax.out new file mode 100644 index 0000000000..4cc108c290 --- /dev/null +++ b/tests/purs/warning/DeprecatedRowKindSyntax.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/warning/DeprecatedRowKindSyntax.purs:4:15 - 4:21 (line 4, column 15 - line 4, column 21) + + Unary '#' syntax for row kinds is deprecated and will be removed in a future release. Use the 'Row' kind instead. + + +See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/DeprecatedRowKindSyntax.purs b/tests/purs/warning/DeprecatedRowKindSyntax.purs new file mode 100644 index 0000000000..c1e21a3190 --- /dev/null +++ b/tests/purs/warning/DeprecatedRowKindSyntax.purs @@ -0,0 +1,4 @@ +-- @shouldWarnWith WarningParsingModule +module Main where + +class R (a :: # Type) diff --git a/tests/purs/warning/DuplicateExportRef.purs b/tests/purs/warning/DuplicateExportRef.purs index aa70f7a732..27c075a07a 100644 --- a/tests/purs/warning/DuplicateExportRef.purs +++ b/tests/purs/warning/DuplicateExportRef.purs @@ -23,8 +23,8 @@ fn _ _ = X infix 2 fn as ! -class Y a +class Y (a :: Type) -type Natural f g = forall a. f a -> g a +type Natural f g = forall (a :: Type). f a -> g a infixl 1 type Natural as ~> diff --git a/tests/purs/warning/Kind-UnusedExplicitImport-1.out b/tests/purs/warning/Kind-UnusedExplicitImport-1.out index 7944527578..e969f3f52c 100644 --- a/tests/purs/warning/Kind-UnusedExplicitImport-1.out +++ b/tests/purs/warning/Kind-UnusedExplicitImport-1.out @@ -1,6 +1,6 @@ Error found: in module Main -at tests/purs/warning/Kind-UnusedExplicitImport-1.purs:6:1 - 6:44 (line 6, column 1 - line 6, column 44) +at tests/purs/warning/Kind-UnusedExplicitImport-1.purs:6:1 - 6:39 (line 6, column 1 - line 6, column 39) The import of module Type.RowList contains the following unused references: @@ -8,7 +8,7 @@ at tests/purs/warning/Kind-UnusedExplicitImport-1.purs:6:1 - 6:44 (line 6, colum It could be replaced with: - import Type.RowList (kind RowList) + import Type.RowList (RowList) diff --git a/tests/purs/warning/Kind-UnusedExplicitImport-1.purs b/tests/purs/warning/Kind-UnusedExplicitImport-1.purs index e5c9ba506a..d2895c2290 100644 --- a/tests/purs/warning/Kind-UnusedExplicitImport-1.purs +++ b/tests/purs/warning/Kind-UnusedExplicitImport-1.purs @@ -3,9 +3,9 @@ module Main where import Prelude (Unit, unit, pure) import Effect (Effect) -import Type.RowList (RLProxy, kind RowList) +import Type.RowList (RLProxy, RowList) -class A (a :: RowList) +class A (a :: RowList Type) main :: Effect Unit main = pure unit diff --git a/tests/purs/warning/Kind-UnusedExplicitImport-2.out b/tests/purs/warning/Kind-UnusedExplicitImport-2.out index 508a580bd6..7edd8ffdd1 100644 --- a/tests/purs/warning/Kind-UnusedExplicitImport-2.out +++ b/tests/purs/warning/Kind-UnusedExplicitImport-2.out @@ -1,6 +1,6 @@ Error found: in module Main -at tests/purs/warning/Kind-UnusedExplicitImport-2.purs:6:1 - 6:44 (line 6, column 1 - line 6, column 44) +at tests/purs/warning/Kind-UnusedExplicitImport-2.purs:6:1 - 6:39 (line 6, column 1 - line 6, column 39) The import of module Type.RowList contains the following unused references: diff --git a/tests/purs/warning/Kind-UnusedExplicitImport-2.purs b/tests/purs/warning/Kind-UnusedExplicitImport-2.purs index 0c8623e6b6..480dcfca9f 100644 --- a/tests/purs/warning/Kind-UnusedExplicitImport-2.purs +++ b/tests/purs/warning/Kind-UnusedExplicitImport-2.purs @@ -3,7 +3,7 @@ module Main where import Prelude (Unit, unit, pure) import Effect (Effect) -import Type.RowList (RLProxy, kind RowList) +import Type.RowList (RLProxy, RowList) f :: forall l. RLProxy l -> Int f _ = 0 diff --git a/tests/purs/warning/Kind-UnusedImport.out b/tests/purs/warning/Kind-UnusedImport.out index d5e9823522..f6a0d54f18 100644 --- a/tests/purs/warning/Kind-UnusedImport.out +++ b/tests/purs/warning/Kind-UnusedImport.out @@ -1,6 +1,6 @@ Error found: in module Main -at tests/purs/warning/Kind-UnusedImport.purs:6:1 - 6:35 (line 6, column 1 - line 6, column 35) +at tests/purs/warning/Kind-UnusedImport.purs:6:1 - 6:30 (line 6, column 1 - line 6, column 30) The import of Type.RowList is redundant diff --git a/tests/purs/warning/Kind-UnusedImport.purs b/tests/purs/warning/Kind-UnusedImport.purs index 07ad87fd38..35881a0884 100644 --- a/tests/purs/warning/Kind-UnusedImport.purs +++ b/tests/purs/warning/Kind-UnusedImport.purs @@ -3,7 +3,7 @@ module Main where import Prelude (Unit, unit, pure) import Effect (Effect) -import Type.RowList (kind RowList) +import Type.RowList (RowList) main :: Effect Unit main = pure unit diff --git a/tests/purs/warning/KindReExport.purs b/tests/purs/warning/KindReExport.purs index b255c8498c..88c8255ea0 100644 --- a/tests/purs/warning/KindReExport.purs +++ b/tests/purs/warning/KindReExport.purs @@ -5,7 +5,7 @@ module Main (main, module X) where import Prelude import Effect (Effect) import Effect.Console (log) -import Prim.Ordering (kind Ordering) as X +import Prim.Ordering (Ordering) as X main :: Effect Unit main = log "Done" diff --git a/tests/purs/warning/MissingKindDeclaration.out b/tests/purs/warning/MissingKindDeclaration.out new file mode 100644 index 0000000000..997fc5d473 --- /dev/null +++ b/tests/purs/warning/MissingKindDeclaration.out @@ -0,0 +1,64 @@ +Error 1 of 4: + + in module Main + at tests/purs/warning/MissingKindDeclaration.purs:7:1 - 7:21 (line 7, column 1 - line 7, column 21) + + The inferred kind for the data declaration Proxy contains polymorphic kinds. + Consider adding a top-level kind signature as a form of documentation. +   +  data Proxy :: forall k. k -> Type +   + + in type constructor Proxy + + See https://github.com/purescript/documentation/blob/master/errors/MissingKindDeclaration.md for more information, + or to contribute content related to this error. + +Error 2 of 4: + + in module Main + at tests/purs/warning/MissingKindDeclaration.purs:11:1 - 11:40 (line 11, column 1 - line 11, column 40) + + The inferred kind for the type declaration Natural contains polymorphic kinds. + Consider adding a top-level kind signature as a form of documentation. +   +  type Natural :: forall k. (k -> Type) -> (k -> Type) -> Type +   + + in type synonym Natural + + See https://github.com/purescript/documentation/blob/master/errors/MissingKindDeclaration.md for more information, + or to contribute content related to this error. + +Error 3 of 4: + + in module Main + at tests/purs/warning/MissingKindDeclaration.purs:9:1 - 9:20 (line 9, column 1 - line 9, column 20) + + The inferred kind for the newtype declaration F contains polymorphic kinds. + Consider adding a top-level kind signature as a form of documentation. +   +  newtype F :: forall k. k -> Type -> Type +   + + in type constructor F + + See https://github.com/purescript/documentation/blob/master/errors/MissingKindDeclaration.md for more information, + or to contribute content related to this error. + +Error 4 of 4: + + in module Main + at tests/purs/warning/MissingKindDeclaration.purs:13:1 - 13:18 (line 13, column 1 - line 13, column 18) + + The inferred kind for the class declaration Clazz contains polymorphic kinds. + Consider adding a top-level kind signature as a form of documentation. +   +  class Clazz :: forall k1 k2 k3. k1 -> k2 -> k3 -> Constraint +   + + in type class declaration for Clazz + + See https://github.com/purescript/documentation/blob/master/errors/MissingKindDeclaration.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/warning/MissingKindDeclaration.purs b/tests/purs/warning/MissingKindDeclaration.purs new file mode 100644 index 0000000000..843b28f870 --- /dev/null +++ b/tests/purs/warning/MissingKindDeclaration.purs @@ -0,0 +1,13 @@ +-- @shouldWarnWith MissingKindDeclaration +-- @shouldWarnWith MissingKindDeclaration +-- @shouldWarnWith MissingKindDeclaration +-- @shouldWarnWith MissingKindDeclaration +module Main where + +data Proxy a = Proxy + +newtype F a b = F b + +type Natural f g = forall a. f a -> g a + +class Clazz a b c diff --git a/tests/purs/warning/UnambiguousQuantifiedKind.out b/tests/purs/warning/UnambiguousQuantifiedKind.out new file mode 100644 index 0000000000..c3048a18e6 --- /dev/null +++ b/tests/purs/warning/UnambiguousQuantifiedKind.out @@ -0,0 +1,16 @@ +Error found: +in module Main +at tests/purs/warning/UnambiguousQuantifiedKind.purs:12:1 - 12:11 (line 12, column 1 - line 12, column 11) + + No type declaration was provided for the top-level declaration of test2. + It is good practice to provide type declarations as a form of documentation. + The inferred type of test2 was: +   +  Int +   + +in value declaration test2 + +See https://github.com/purescript/documentation/blob/master/errors/MissingTypeDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/UnambiguousQuantifiedKind.purs b/tests/purs/warning/UnambiguousQuantifiedKind.purs new file mode 100644 index 0000000000..864bed7d26 --- /dev/null +++ b/tests/purs/warning/UnambiguousQuantifiedKind.purs @@ -0,0 +1,12 @@ +-- @shouldWarnWith MissingTypeDeclaration +module Main where + +data Proxy :: forall k. k -> Type +data Proxy a = Proxy + +-- Should not trigger a warning +test1 :: forall k (a :: k). Proxy a +test1 = Proxy + +-- Should trigger a warning +test2 = 42 diff --git a/tests/purs/warning/UnusedExplicitImportTypeOp/Lib.purs b/tests/purs/warning/UnusedExplicitImportTypeOp/Lib.purs index 7a2d5239d3..18393bd6a3 100644 --- a/tests/purs/warning/UnusedExplicitImportTypeOp/Lib.purs +++ b/tests/purs/warning/UnusedExplicitImportTypeOp/Lib.purs @@ -1,5 +1,6 @@ module Lib where +type Nat ∷ ∀ k. (k → Type) → (k → Type) → Type type Nat f g = ∀ x. f x → g x infixr 4 type Nat as ~> diff --git a/tests/support/bower.json b/tests/support/bower.json index 4bfed584d9..850a61c429 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -24,7 +24,7 @@ "purescript-newtype": "3.0.0", "purescript-nonempty": "5.0.0", "purescript-partial": "2.0.0", - "purescript-prelude": "4.1.0", + "purescript-prelude": "#c932361d008379958f14ca8cc2fe32e06cc2647d", "purescript-proxy": "3.0.0", "purescript-psci-support": "4.0.0", "purescript-refs": "4.1.0", @@ -34,8 +34,12 @@ "purescript-tailrec": "4.0.0", "purescript-tuples": "5.0.0", "purescript-type-equality": "3.0.0", - "purescript-typelevel-prelude": "5.0.0", + "purescript-typelevel-prelude": "#52ac4bcf9a38941606b3d928127089bd363ee946", "purescript-unfoldable": "4.0.0", "purescript-unsafe-coerce": "4.0.0" + }, + "resolutions": { + "purescript-prelude": "c932361d008379958f14ca8cc2fe32e06cc2647d", + "purescript-typelevel-prelude": "52ac4bcf9a38941606b3d928127089bd363ee946" } } From 2963edd9e9c02b7284f1809ff09b62f4a8c1b128 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 14 Mar 2020 12:35:03 -0400 Subject: [PATCH 1192/1580] Fix DuplicateModule.purs golden test (#3811) System.FilePath.Glob explicitly states that the results of a glob are not in any defined order. However, the order of the files provided to L.P.Make.make determines which file is reported as having a duplicate module. So in order to make the output of DuplicateModule.purs deterministic (and possibly other error messages as well), the test framework sorts the input files passed to make when testing the text of warnings and errors. --- tests/TestCompiler.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index af523b2e44..66704385ec 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -226,7 +226,8 @@ printErrorOrWarning -> [FilePath] -> IO String printErrorOrWarning supportModules supportExterns supportForeigns inputFiles = do - (e, w) <- compile supportModules supportExterns supportForeigns inputFiles noPreCheck + -- Sorting the input files makes some messages (e.g., duplicate module) deterministic + (e, w) <- compile supportModules supportExterns supportForeigns (sort inputFiles) noPreCheck case (const w <$> e) of Left errs -> return $ P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs From 8766ec039fc6b7a8876e6910ae16570bcd1080f2 Mon Sep 17 00:00:00 2001 From: Hardy Jones Date: Mon, 23 Mar 2020 07:01:04 -0700 Subject: [PATCH 1193/1580] Relax dependency to `microlens` (#3817) `microlens-platform` brings in quite a bit of extra dependencies. To thin out what `purescript-ast` depends on, we move from `microlens-platform` to `microlens`. --- lib/purescript-ast/package.yaml | 2 +- lib/purescript-ast/src/Language/PureScript/Types.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/purescript-ast/package.yaml b/lib/purescript-ast/package.yaml index 1373f58e27..fae047223d 100644 --- a/lib/purescript-ast/package.yaml +++ b/lib/purescript-ast/package.yaml @@ -25,7 +25,7 @@ dependencies: - containers - deepseq - filepath - - microlens-platform >=0.3.9.0 && <0.4 + - microlens >=0.4.10 && <0.5 - mtl >=2.1.0 && <2.3.0 - protolude >=0.1.6 && <0.2.4 - scientific >=0.3.4.9 && <0.4 diff --git a/lib/purescript-ast/src/Language/PureScript/Types.hs b/lib/purescript-ast/src/Language/PureScript/Types.hs index e015979362..e5979789c4 100644 --- a/lib/purescript-ast/src/Language/PureScript/Types.hs +++ b/lib/purescript-ast/src/Language/PureScript/Types.hs @@ -29,7 +29,7 @@ import "this" Language.PureScript.Names import "this" Language.PureScript.Label (Label) import "this" Language.PureScript.PSString (PSString) -import "microlens-platform" Lens.Micro.Platform (Lens', (^.), set) +import "microlens" Lens.Micro (Lens', (^.), set) type SourceType = Type SourceAnn type SourceConstraint = Constraint SourceAnn From ab72a72ffa842d5e220e9c97c1f0f8da828a69a0 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Fri, 27 Mar 2020 07:21:31 -0700 Subject: [PATCH 1194/1580] Remove PackageImports (#3821) * Remove PackageImports * Fix bad import --- lib/purescript-ast/package.yaml | 1 - .../src/Control/Monad/Supply.hs | 14 ++--- .../src/Control/Monad/Supply/Class.hs | 10 ++-- .../src/Language/PureScript/AST.hs | 14 ++--- .../src/Language/PureScript/AST/Binders.hs | 12 ++--- .../Language/PureScript/AST/Declarations.hs | 48 ++++++++--------- .../src/Language/PureScript/AST/Exported.hs | 16 +++--- .../src/Language/PureScript/AST/Literals.hs | 4 +- .../src/Language/PureScript/AST/Operators.hs | 12 ++--- .../src/Language/PureScript/AST/SourcePos.hs | 20 +++---- .../src/Language/PureScript/AST/Traversals.hs | 36 ++++++------- .../src/Language/PureScript/Comments.hs | 10 ++-- .../src/Language/PureScript/Constants/Prim.hs | 6 +-- .../src/Language/PureScript/Crash.hs | 6 +-- .../src/Language/PureScript/Environment.hs | 48 ++++++++--------- .../src/Language/PureScript/Label.hs | 14 ++--- .../src/Language/PureScript/Names.hs | 18 +++---- .../src/Language/PureScript/PSString.hs | 44 +++++++-------- .../src/Language/PureScript/Roles.hs | 10 ++-- .../src/Language/PureScript/Traversals.hs | 54 +++++++++---------- .../PureScript/TypeClassDictionaries.hs | 12 ++--- .../src/Language/PureScript/Types.hs | 54 +++++++++---------- lib/purescript-cst/package.yaml | 1 - .../src/Language/PureScript/CST/Convert.hs | 40 +++++++------- .../src/Language/PureScript/CST/Errors.hs | 14 ++--- .../src/Language/PureScript/CST/Flatten.hs | 6 +-- .../src/Language/PureScript/CST/Layout.hs | 12 ++--- .../src/Language/PureScript/CST/Lexer.hs | 32 +++++------ .../src/Language/PureScript/CST/Monad.hs | 20 +++---- .../src/Language/PureScript/CST/Parser.y | 34 ++++++------ .../src/Language/PureScript/CST/Positions.hs | 16 +++--- .../src/Language/PureScript/CST/Print.hs | 8 +-- .../src/Language/PureScript/CST/Traversals.hs | 4 +- .../PureScript/CST/Traversals/Type.hs | 6 +-- .../src/Language/PureScript/CST/Types.hs | 14 ++--- .../src/Language/PureScript/CST/Utils.hs | 36 ++++++------- lib/purescript-cst/tests/Main.hs | 8 +-- lib/purescript-cst/tests/TestCst.hs | 36 ++++++------- 38 files changed, 374 insertions(+), 376 deletions(-) diff --git a/lib/purescript-ast/package.yaml b/lib/purescript-ast/package.yaml index fae047223d..00ff0335b7 100644 --- a/lib/purescript-ast/package.yaml +++ b/lib/purescript-ast/package.yaml @@ -52,7 +52,6 @@ library: - LambdaCase - MultiParamTypeClasses - NoImplicitPrelude - - PackageImports - PatternGuards - PatternSynonyms - RankNTypes diff --git a/lib/purescript-ast/src/Control/Monad/Supply.hs b/lib/purescript-ast/src/Control/Monad/Supply.hs index 66ab8a372b..dd9e2f74a6 100644 --- a/lib/purescript-ast/src/Control/Monad/Supply.hs +++ b/lib/purescript-ast/src/Control/Monad/Supply.hs @@ -3,15 +3,15 @@ -- module Control.Monad.Supply where -import "base-compat" Prelude.Compat +import Prelude.Compat -import "base" Control.Applicative -import "mtl" Control.Monad.Error.Class (MonadError(..)) -import "mtl" Control.Monad.Reader -import "mtl" Control.Monad.State -import "mtl" Control.Monad.Writer +import Control.Applicative +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer -import "base" Data.Functor.Identity +import Data.Functor.Identity newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus) diff --git a/lib/purescript-ast/src/Control/Monad/Supply/Class.hs b/lib/purescript-ast/src/Control/Monad/Supply/Class.hs index 43b01fca1b..409340b6e9 100644 --- a/lib/purescript-ast/src/Control/Monad/Supply/Class.hs +++ b/lib/purescript-ast/src/Control/Monad/Supply/Class.hs @@ -4,12 +4,12 @@ module Control.Monad.Supply.Class where -import "base-compat" Prelude.Compat +import Prelude.Compat -import "this" Control.Monad.Supply -import "mtl" Control.Monad.State -import "mtl" Control.Monad.Writer -import "text" Data.Text (Text, pack) +import Control.Monad.Supply +import Control.Monad.State +import Control.Monad.Writer +import Data.Text (Text, pack) class Monad m => MonadSupply m where fresh :: m Integer diff --git a/lib/purescript-ast/src/Language/PureScript/AST.hs b/lib/purescript-ast/src/Language/PureScript/AST.hs index b912f98cde..fe82e27200 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST.hs @@ -5,10 +5,10 @@ module Language.PureScript.AST ( module AST ) where -import "this" Language.PureScript.AST.Binders as AST -import "this" Language.PureScript.AST.Declarations as AST -import "this" Language.PureScript.AST.Exported as AST -import "this" Language.PureScript.AST.Literals as AST -import "this" Language.PureScript.AST.Operators as AST -import "this" Language.PureScript.AST.SourcePos as AST -import "this" Language.PureScript.AST.Traversals as AST +import Language.PureScript.AST.Binders as AST +import Language.PureScript.AST.Declarations as AST +import Language.PureScript.AST.Exported as AST +import Language.PureScript.AST.Literals as AST +import Language.PureScript.AST.Operators as AST +import Language.PureScript.AST.SourcePos as AST +import Language.PureScript.AST.Traversals as AST diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs b/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs index 6518b646e3..528ffb0987 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs @@ -3,13 +3,13 @@ -- module Language.PureScript.AST.Binders where -import "base-compat" Prelude.Compat +import Prelude.Compat -import "this" Language.PureScript.AST.SourcePos -import "this" Language.PureScript.AST.Literals -import "this" Language.PureScript.Names -import "this" Language.PureScript.Comments -import "this" Language.PureScript.Types +import Language.PureScript.AST.SourcePos +import Language.PureScript.AST.Literals +import Language.PureScript.Names +import Language.PureScript.Comments +import Language.PureScript.Types -- | -- Data type for binders diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs index af551efd93..1c5472207c 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs @@ -6,30 +6,30 @@ -- module Language.PureScript.AST.Declarations where -import "base-compat" Prelude.Compat - -import "deepseq" Control.DeepSeq (NFData) -import "base" Data.Functor.Identity - -import "aeson" Data.Aeson.TH -import qualified "containers" Data.Map as M -import "text" Data.Text (Text) -import qualified "base" Data.List.NonEmpty as NEL -import "base" GHC.Generics (Generic) - -import "this" Language.PureScript.AST.Binders -import "this" Language.PureScript.AST.Literals -import "this" Language.PureScript.AST.Operators -import "this" Language.PureScript.AST.SourcePos -import "this" Language.PureScript.Types -import "this" Language.PureScript.PSString (PSString) -import "this" Language.PureScript.Label (Label) -import "this" Language.PureScript.Names -import "this" Language.PureScript.Roles -import "this" Language.PureScript.TypeClassDictionaries -import "this" Language.PureScript.Comments -import "this" Language.PureScript.Environment -import qualified "this" Language.PureScript.Constants.Prim as C +import Prelude.Compat + +import Control.DeepSeq (NFData) +import Data.Functor.Identity + +import Data.Aeson.TH +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.List.NonEmpty as NEL +import GHC.Generics (Generic) + +import Language.PureScript.AST.Binders +import Language.PureScript.AST.Literals +import Language.PureScript.AST.Operators +import Language.PureScript.AST.SourcePos +import Language.PureScript.Types +import Language.PureScript.PSString (PSString) +import Language.PureScript.Label (Label) +import Language.PureScript.Names +import Language.PureScript.Roles +import Language.PureScript.TypeClassDictionaries +import Language.PureScript.Comments +import Language.PureScript.Environment +import qualified Language.PureScript.Constants.Prim as C -- | A map of locally-bound names in scope. type Context = [(Ident, SourceType)] diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Exported.hs b/lib/purescript-ast/src/Language/PureScript/AST/Exported.hs index 7c6db77a0c..9cf015e0bc 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Exported.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Exported.hs @@ -3,17 +3,17 @@ module Language.PureScript.AST.Exported , isExported ) where -import "base-compat" Prelude.Compat -import "protolude" Protolude (sortBy, on) +import Prelude.Compat +import Protolude (sortBy, on) -import "base" Control.Category ((>>>)) +import Control.Category ((>>>)) -import "base" Data.Maybe (mapMaybe) -import qualified "containers" Data.Map as M +import Data.Maybe (mapMaybe) +import qualified Data.Map as M -import "this" Language.PureScript.AST.Declarations -import "this" Language.PureScript.Types -import "this" Language.PureScript.Names +import Language.PureScript.AST.Declarations +import Language.PureScript.Types +import Language.PureScript.Names -- | -- Return a list of all declarations which are exported from a module. diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Literals.hs b/lib/purescript-ast/src/Language/PureScript/AST/Literals.hs index f6ffbb3ed2..a161fd82ab 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Literals.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Literals.hs @@ -3,8 +3,8 @@ -- module Language.PureScript.AST.Literals where -import "base-compat" Prelude.Compat -import "this" Language.PureScript.PSString (PSString) +import Prelude.Compat +import Language.PureScript.PSString (PSString) -- | -- Data type for literal values. Parameterised so it can be used for Exprs and diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Operators.hs b/lib/purescript-ast/src/Language/PureScript/AST/Operators.hs index e4755d3067..bad560c078 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Operators.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Operators.hs @@ -3,14 +3,14 @@ -- module Language.PureScript.AST.Operators where -import "base-compat" Prelude.Compat +import Prelude.Compat -import "base" GHC.Generics (Generic) -import "deepseq" Control.DeepSeq (NFData) -import "aeson" Data.Aeson ((.=)) -import qualified "aeson" Data.Aeson as A +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) +import Data.Aeson ((.=)) +import qualified Data.Aeson as A -import "this" Language.PureScript.Crash +import Language.PureScript.Crash -- | -- A precedence level for an infix operator diff --git a/lib/purescript-ast/src/Language/PureScript/AST/SourcePos.hs b/lib/purescript-ast/src/Language/PureScript/AST/SourcePos.hs index 864ac5b1a2..58ad616c27 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/SourcePos.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/SourcePos.hs @@ -3,16 +3,16 @@ -- module Language.PureScript.AST.SourcePos where -import "base-compat" Prelude.Compat - -import "deepseq" Control.DeepSeq (NFData) -import "aeson" Data.Aeson ((.=), (.:)) -import "text" Data.Text (Text) -import "base" GHC.Generics (Generic) -import "this" Language.PureScript.Comments -import qualified "aeson" Data.Aeson as A -import qualified "text" Data.Text as T -import "filepath" System.FilePath (makeRelative) +import Prelude.Compat + +import Control.DeepSeq (NFData) +import Data.Aeson ((.=), (.:)) +import Data.Text (Text) +import GHC.Generics (Generic) +import Language.PureScript.Comments +import qualified Data.Aeson as A +import qualified Data.Text as T +import System.FilePath (makeRelative) -- | Source annotation - position information and comments. type SourceAnn = (SourceSpan, [Comment]) diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs b/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs index 63b87296f6..6738363112 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs @@ -3,24 +3,24 @@ -- module Language.PureScript.AST.Traversals where -import "base-compat" Prelude.Compat - -import "base" Control.Monad - -import "base" Data.Foldable (fold) -import "base" Data.List (mapAccumL) -import "base" Data.Maybe (mapMaybe) -import qualified "base" Data.List.NonEmpty as NEL -import qualified "containers" Data.Map as M -import qualified "containers" Data.Set as S - -import "this" Language.PureScript.AST.Binders -import "this" Language.PureScript.AST.Declarations -import "this" Language.PureScript.AST.Literals -import "this" Language.PureScript.Names -import "this" Language.PureScript.Traversals -import "this" Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..)) -import "this" Language.PureScript.Types +import Prelude.Compat + +import Control.Monad + +import Data.Foldable (fold) +import Data.List (mapAccumL) +import Data.Maybe (mapMaybe) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as M +import qualified Data.Set as S + +import Language.PureScript.AST.Binders +import Language.PureScript.AST.Declarations +import Language.PureScript.AST.Literals +import Language.PureScript.Names +import Language.PureScript.Traversals +import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..)) +import Language.PureScript.Types guardedExprM :: Applicative m => (Guard -> m Guard) diff --git a/lib/purescript-ast/src/Language/PureScript/Comments.hs b/lib/purescript-ast/src/Language/PureScript/Comments.hs index 9635faa9e4..082fedb62f 100644 --- a/lib/purescript-ast/src/Language/PureScript/Comments.hs +++ b/lib/purescript-ast/src/Language/PureScript/Comments.hs @@ -5,12 +5,12 @@ -- module Language.PureScript.Comments where -import "base-compat" Prelude.Compat -import "deepseq" Control.DeepSeq (NFData) -import "text" Data.Text (Text) -import "base" GHC.Generics (Generic) +import Prelude.Compat +import Control.DeepSeq (NFData) +import Data.Text (Text) +import GHC.Generics (Generic) -import "aeson" Data.Aeson.TH +import Data.Aeson.TH data Comment = LineComment Text diff --git a/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs b/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs index ac52d94c83..4367271831 100644 --- a/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs +++ b/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs @@ -1,10 +1,10 @@ -- | Various constants which refer to things in Prim module Language.PureScript.Constants.Prim where -import "base-compat" Prelude.Compat +import Prelude.Compat -import "base" Data.String (IsString) -import "this" Language.PureScript.Names +import Data.String (IsString) +import Language.PureScript.Names -- Prim values diff --git a/lib/purescript-ast/src/Language/PureScript/Crash.hs b/lib/purescript-ast/src/Language/PureScript/Crash.hs index 9edacd4b5b..fe72169bb0 100644 --- a/lib/purescript-ast/src/Language/PureScript/Crash.hs +++ b/lib/purescript-ast/src/Language/PureScript/Crash.hs @@ -3,9 +3,9 @@ module Language.PureScript.Crash where -import "base-compat" Prelude.Compat +import Prelude.Compat -import qualified "base" GHC.Stack +import qualified GHC.Stack -- | A compatibility wrapper for the @GHC.Stack.HasCallStack@ constraint. #if __GLASGOW_HASKELL__ >= 800 @@ -13,7 +13,7 @@ type HasCallStack = GHC.Stack.HasCallStack #elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) type HasCallStack = (?callStack :: GHC.Stack.CallStack) #else -import "base" GHC.Exts (Constraint) +import GHC.Exts (Constraint) -- CallStack wasn't present in GHC 7.10.1 type HasCallStack = (() :: Constraint) #endif diff --git a/lib/purescript-ast/src/Language/PureScript/Environment.hs b/lib/purescript-ast/src/Language/PureScript/Environment.hs index d84536daa3..bcd3c9cff8 100644 --- a/lib/purescript-ast/src/Language/PureScript/Environment.hs +++ b/lib/purescript-ast/src/Language/PureScript/Environment.hs @@ -1,29 +1,29 @@ module Language.PureScript.Environment where -import "base-compat" Prelude.Compat -import "protolude" Protolude (ordNub) - -import "base" GHC.Generics (Generic) -import "deepseq" Control.DeepSeq (NFData) -import "aeson" Data.Aeson ((.=), (.:)) -import qualified "aeson" Data.Aeson as A -import qualified "containers" Data.Map as M -import qualified "containers" Data.Set as S -import "base" Data.Maybe (fromMaybe, mapMaybe) -import "text" Data.Text (Text) -import qualified "text" Data.Text as T -import "containers" Data.Tree (Tree, rootLabel) -import qualified "containers" Data.Graph as G -import "base" Data.Foldable (toList) -import qualified "base" Data.List.NonEmpty as NEL - -import "this" Language.PureScript.AST.SourcePos -import "this" Language.PureScript.Crash -import "this" Language.PureScript.Names -import "this" Language.PureScript.Roles -import "this" Language.PureScript.TypeClassDictionaries -import "this" Language.PureScript.Types -import qualified "this" Language.PureScript.Constants.Prim as C +import Prelude.Compat +import Protolude (ordNub) + +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) +import Data.Aeson ((.=), (.:)) +import qualified Data.Aeson as A +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Tree (Tree, rootLabel) +import qualified Data.Graph as G +import Data.Foldable (toList) +import qualified Data.List.NonEmpty as NEL + +import Language.PureScript.AST.SourcePos +import Language.PureScript.Crash +import Language.PureScript.Names +import Language.PureScript.Roles +import Language.PureScript.TypeClassDictionaries +import Language.PureScript.Types +import qualified Language.PureScript.Constants.Prim as C -- | The @Environment@ defines all values and types which are currently in scope: data Environment = Environment diff --git a/lib/purescript-ast/src/Language/PureScript/Label.hs b/lib/purescript-ast/src/Language/PureScript/Label.hs index 8be2067d1f..4aab084503 100644 --- a/lib/purescript-ast/src/Language/PureScript/Label.hs +++ b/lib/purescript-ast/src/Language/PureScript/Label.hs @@ -1,13 +1,13 @@ module Language.PureScript.Label (Label(..)) where -import "base-compat" Prelude.Compat hiding (lex) -import "base" GHC.Generics (Generic) -import "deepseq" Control.DeepSeq (NFData) -import "base" Data.Monoid () -import "base" Data.String (IsString(..)) -import qualified "aeson" Data.Aeson as A +import Prelude.Compat hiding (lex) +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) +import Data.Monoid () +import Data.String (IsString(..)) +import qualified Data.Aeson as A -import "this" Language.PureScript.PSString (PSString) +import Language.PureScript.PSString (PSString) -- | -- Labels are used as record keys and row entry names. Labels newtype PSString diff --git a/lib/purescript-ast/src/Language/PureScript/Names.hs b/lib/purescript-ast/src/Language/PureScript/Names.hs index 00c243cf92..1e1408d48d 100644 --- a/lib/purescript-ast/src/Language/PureScript/Names.hs +++ b/lib/purescript-ast/src/Language/PureScript/Names.hs @@ -5,17 +5,17 @@ -- module Language.PureScript.Names where -import "base-compat" Prelude.Compat +import Prelude.Compat -import "this" Control.Monad.Supply.Class -import "deepseq" Control.DeepSeq (NFData) -import "base" Data.Functor.Contravariant (contramap) +import Control.Monad.Supply.Class +import Control.DeepSeq (NFData) +import Data.Functor.Contravariant (contramap) -import "base" GHC.Generics (Generic) -import "aeson" Data.Aeson -import "aeson" Data.Aeson.TH -import "text" Data.Text (Text) -import qualified "text" Data.Text as T +import GHC.Generics (Generic) +import Data.Aeson +import Data.Aeson.TH +import Data.Text (Text) +import qualified Data.Text as T -- | A sum of the possible name types, useful for error and lint messages. data Name diff --git a/lib/purescript-ast/src/Language/PureScript/PSString.hs b/lib/purescript-ast/src/Language/PureScript/PSString.hs index 3f07db6a53..bf677c5c83 100644 --- a/lib/purescript-ast/src/Language/PureScript/PSString.hs +++ b/lib/purescript-ast/src/Language/PureScript/PSString.hs @@ -9,28 +9,28 @@ module Language.PureScript.PSString , mkString ) where -import "base-compat" Prelude.Compat -import "base" GHC.Generics (Generic) -import "deepseq" Control.DeepSeq (NFData) -import "base" Control.Exception (try, evaluate) -import "base" Control.Applicative ((<|>)) -import qualified "base" Data.Char as Char -import "base" Data.Bits (shiftR) -import "base" Data.List (unfoldr) -import "scientific" Data.Scientific (toBoundedInteger) -import "base" Data.String (IsString(..)) -import "bytestring" Data.ByteString (ByteString) -import qualified "bytestring" Data.ByteString as BS -import "text" Data.Text (Text) -import qualified "text" Data.Text as T -import "text" Data.Text.Encoding (decodeUtf16BE) -import "text" Data.Text.Encoding.Error (UnicodeException) -import qualified "vector" Data.Vector as V -import "base" Data.Word (Word16, Word8) -import "base" Numeric (showHex) -import "base" System.IO.Unsafe (unsafePerformIO) -import qualified "aeson" Data.Aeson as A -import qualified "aeson" Data.Aeson.Types as A +import Prelude.Compat +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) +import Control.Exception (try, evaluate) +import Control.Applicative ((<|>)) +import qualified Data.Char as Char +import Data.Bits (shiftR) +import Data.List (unfoldr) +import Data.Scientific (toBoundedInteger) +import Data.String (IsString(..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf16BE) +import Data.Text.Encoding.Error (UnicodeException) +import qualified Data.Vector as V +import Data.Word (Word16, Word8) +import Numeric (showHex) +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A -- | -- Strings in PureScript are sequences of UTF-16 code units, which do not diff --git a/lib/purescript-ast/src/Language/PureScript/Roles.hs b/lib/purescript-ast/src/Language/PureScript/Roles.hs index b521848b22..e06e382c31 100644 --- a/lib/purescript-ast/src/Language/PureScript/Roles.hs +++ b/lib/purescript-ast/src/Language/PureScript/Roles.hs @@ -7,12 +7,12 @@ module Language.PureScript.Roles ( Role(..) ) where -import "base-compat" Prelude.Compat +import Prelude.Compat -import "deepseq" Control.DeepSeq (NFData) -import qualified "aeson" Data.Aeson as A -import qualified "aeson" Data.Aeson.TH as A -import "base" GHC.Generics (Generic) +import Control.DeepSeq (NFData) +import qualified Data.Aeson as A +import qualified Data.Aeson.TH as A +import GHC.Generics (Generic) -- | -- The role of a type constructor's parameter. diff --git a/lib/purescript-ast/src/Language/PureScript/Traversals.hs b/lib/purescript-ast/src/Language/PureScript/Traversals.hs index 302102f332..b4621d1a03 100644 --- a/lib/purescript-ast/src/Language/PureScript/Traversals.hs +++ b/lib/purescript-ast/src/Language/PureScript/Traversals.hs @@ -1,27 +1,27 @@ --- | Common functions for implementing generic traversals -module Language.PureScript.Traversals where - -import "base-compat" Prelude.Compat - -fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b) -fstM f (a, b) = flip (,) b <$> f a - -sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c) -sndM f (a, b) = (,) a <$> f b - -thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d) -thirdM f (a, b, c) = (,,) a b <$> f c - -pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d) -pairM f g (a, b) = (,) <$> f a <*> g b - -maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b) -maybeM _ Nothing = pure Nothing -maybeM f (Just a) = Just <$> f a - -eitherM :: (Applicative f) => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d) -eitherM f _ (Left a) = Left <$> f a -eitherM _ g (Right b) = Right <$> g b - -defS :: (Monad m) => st -> val -> m (st, val) -defS s val = return (s, val) +-- | Common functions for implementing generic traversals +module Language.PureScript.Traversals where + +import Prelude.Compat + +fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b) +fstM f (a, b) = flip (,) b <$> f a + +sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c) +sndM f (a, b) = (,) a <$> f b + +thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d) +thirdM f (a, b, c) = (,,) a b <$> f c + +pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d) +pairM f g (a, b) = (,) <$> f a <*> g b + +maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b) +maybeM _ Nothing = pure Nothing +maybeM f (Just a) = Just <$> f a + +eitherM :: (Applicative f) => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d) +eitherM f _ (Left a) = Left <$> f a +eitherM _ g (Right b) = Right <$> g b + +defS :: (Monad m) => st -> val -> m (st, val) +defS s val = return (s, val) diff --git a/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs b/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs index 1ddc55c5e5..deb3915f05 100644 --- a/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs +++ b/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs @@ -1,13 +1,13 @@ module Language.PureScript.TypeClassDictionaries where -import "base-compat" Prelude.Compat +import Prelude.Compat -import "base" GHC.Generics (Generic) -import "deepseq" Control.DeepSeq (NFData) -import "text" Data.Text (Text, pack) +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) +import Data.Text (Text, pack) -import "this" Language.PureScript.Names -import "this" Language.PureScript.Types +import Language.PureScript.Names +import Language.PureScript.Types -- -- Data representing a type class dictionary which is in scope diff --git a/lib/purescript-ast/src/Language/PureScript/Types.hs b/lib/purescript-ast/src/Language/PureScript/Types.hs index e5979789c4..4338e547a4 100644 --- a/lib/purescript-ast/src/Language/PureScript/Types.hs +++ b/lib/purescript-ast/src/Language/PureScript/Types.hs @@ -3,33 +3,33 @@ -- module Language.PureScript.Types where -import "base-compat" Prelude.Compat -import "protolude" Protolude (ordNub) - -import "base" Control.Applicative ((<|>)) -import "base" Control.Arrow (first, second) -import "deepseq" Control.DeepSeq (NFData) -import "base" Control.Monad ((<=<), (>=>)) -import "aeson" Data.Aeson ((.:), (.:?), (.!=), (.=)) -import qualified "aeson" Data.Aeson as A -import qualified "aeson" Data.Aeson.Types as A -import "base" Data.Foldable (fold) -import qualified "containers" Data.IntSet as IS -import "base" Data.List (sort, sortBy) -import "base" Data.Ord (comparing) -import "base" Data.Maybe (fromMaybe, isJust) -import qualified "containers" Data.Set as S -import "text" Data.Text (Text) -import qualified "text" Data.Text as T -import "base" GHC.Generics (Generic) - -import "this" Language.PureScript.AST.SourcePos -import qualified "this" Language.PureScript.Constants.Prim as C -import "this" Language.PureScript.Names -import "this" Language.PureScript.Label (Label) -import "this" Language.PureScript.PSString (PSString) - -import "microlens" Lens.Micro (Lens', (^.), set) +import Prelude.Compat +import Protolude (ordNub) + +import Control.Applicative ((<|>)) +import Control.Arrow (first, second) +import Control.DeepSeq (NFData) +import Control.Monad ((<=<), (>=>)) +import Data.Aeson ((.:), (.:?), (.!=), (.=)) +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A +import Data.Foldable (fold) +import qualified Data.IntSet as IS +import Data.List (sort, sortBy) +import Data.Ord (comparing) +import Data.Maybe (fromMaybe, isJust) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) + +import Language.PureScript.AST.SourcePos +import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.Names +import Language.PureScript.Label (Label) +import Language.PureScript.PSString (PSString) + +import Lens.Micro (Lens', (^.), set) type SourceType = Type SourceAnn type SourceConstraint = Constraint SourceAnn diff --git a/lib/purescript-cst/package.yaml b/lib/purescript-cst/package.yaml index dfdc500673..34d457c6b0 100644 --- a/lib/purescript-cst/package.yaml +++ b/lib/purescript-cst/package.yaml @@ -49,7 +49,6 @@ library: - MultiParamTypeClasses - NamedFieldPuns - NoImplicitPrelude - - PackageImports - PatternGuards - PatternSynonyms - RankNTypes diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs index 4599ee0b0a..e386b4df85 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs @@ -15,26 +15,26 @@ module Language.PureScript.CST.Convert , comments ) where -import "base" Prelude - -import "base" Data.Bifunctor (bimap, first) -import "base" Data.Foldable (foldl', toList) -import "base" Data.Functor (($>)) -import qualified "base" Data.List.NonEmpty as NE -import "base" Data.Maybe (isJust, fromJust, mapMaybe) -import qualified "text" Data.Text as Text -import qualified "purescript-ast" Language.PureScript.AST as AST -import qualified "purescript-ast" Language.PureScript.AST.SourcePos as Pos -import qualified "purescript-ast" Language.PureScript.Comments as C -import "purescript-ast" Language.PureScript.Crash (internalError) -import qualified "purescript-ast" Language.PureScript.Environment as Env -import qualified "purescript-ast" Language.PureScript.Label as L -import qualified "purescript-ast" Language.PureScript.Names as N -import "purescript-ast" Language.PureScript.PSString (mkString) -import qualified "purescript-ast" Language.PureScript.Types as T -import "this" Language.PureScript.CST.Positions -import "this" Language.PureScript.CST.Print (printToken) -import "this" Language.PureScript.CST.Types +import Prelude + +import Data.Bifunctor (bimap, first) +import Data.Foldable (foldl', toList) +import Data.Functor (($>)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (isJust, fromJust, mapMaybe) +import qualified Data.Text as Text +import qualified Language.PureScript.AST as AST +import qualified Language.PureScript.AST.SourcePos as Pos +import qualified Language.PureScript.Comments as C +import Language.PureScript.Crash (internalError) +import qualified Language.PureScript.Environment as Env +import qualified Language.PureScript.Label as L +import qualified Language.PureScript.Names as N +import Language.PureScript.PSString (mkString) +import qualified Language.PureScript.Types as T +import Language.PureScript.CST.Positions +import Language.PureScript.CST.Print (printToken) +import Language.PureScript.CST.Types comment :: Comment a -> Maybe C.Comment comment = \case diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs b/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs index 83387a9324..18ed7079ee 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs @@ -9,14 +9,14 @@ module Language.PureScript.CST.Errors , prettyPrintWarningMessage ) where -import "base" Prelude +import Prelude -import qualified "text" Data.Text as Text -import "base" Data.Char (isSpace, toUpper) -import "this" Language.PureScript.CST.Layout -import "this" Language.PureScript.CST.Print -import "this" Language.PureScript.CST.Types -import "base" Text.Printf (printf) +import qualified Data.Text as Text +import Data.Char (isSpace, toUpper) +import Language.PureScript.CST.Layout +import Language.PureScript.CST.Print +import Language.PureScript.CST.Types +import Text.Printf (printf) data ParserErrorType = ErrWildcardInType diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs b/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs index 91609f1205..fa32c32a80 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs @@ -1,9 +1,9 @@ module Language.PureScript.CST.Flatten where -import "base" Prelude +import Prelude -import "dlist" Data.DList (DList) -import "this" Language.PureScript.CST.Types +import Data.DList (DList) +import Language.PureScript.CST.Types flattenWrapped :: (a -> DList SourceToken) -> Wrapped a -> DList SourceToken flattenWrapped k (Wrapped a b c) = pure a <> k b <> pure c diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs b/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs index 89e431c735..12df99ee8f 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs @@ -20,13 +20,13 @@ module Language.PureScript.CST.Layout where -import "base" Prelude +import Prelude -import "dlist" Data.DList (snoc) -import qualified "dlist" Data.DList as DList -import "base" Data.Foldable (find) -import "base" Data.Function ((&)) -import "this" Language.PureScript.CST.Types +import Data.DList (snoc) +import qualified Data.DList as DList +import Data.Foldable (find) +import Data.Function ((&)) +import Language.PureScript.CST.Types type LayoutStack = [(SourcePos, LayoutDelim)] diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs index e6f73f7635..2ad7646479 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs @@ -6,22 +6,22 @@ module Language.PureScript.CST.Lexer , isUnquotedKey ) where -import "base" Prelude hiding (lex, exp, exponent, lines) - -import "base" Control.Monad (join) -import qualified "base" Data.Char as Char -import qualified "dlist" Data.DList as DList -import "base" Data.Foldable (foldl') -import "base" Data.Functor (($>)) -import qualified "scientific" Data.Scientific as Sci -import "base" Data.String (fromString) -import "text" Data.Text (Text) -import qualified "text" Data.Text as Text -import "this" Language.PureScript.CST.Errors -import "this" Language.PureScript.CST.Monad hiding (token) -import "this" Language.PureScript.CST.Layout -import "this" Language.PureScript.CST.Positions -import "this" Language.PureScript.CST.Types +import Prelude hiding (lex, exp, exponent, lines) + +import Control.Monad (join) +import qualified Data.Char as Char +import qualified Data.DList as DList +import Data.Foldable (foldl') +import Data.Functor (($>)) +import qualified Data.Scientific as Sci +import Data.String (fromString) +import Data.Text (Text) +import qualified Data.Text as Text +import Language.PureScript.CST.Errors +import Language.PureScript.CST.Monad hiding (token) +import Language.PureScript.CST.Layout +import Language.PureScript.CST.Positions +import Language.PureScript.CST.Types -- | Stops at the first lexing error and replaces it with TokEof. Otherwise, -- the parser will fail when it attempts to draw a lookahead token. diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs b/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs index b87dd3d288..e123738d2e 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs @@ -1,15 +1,15 @@ module Language.PureScript.CST.Monad where -import "base" Prelude - -import "base" Data.List (sortBy) -import qualified "base" Data.List.NonEmpty as NE -import "base" Data.Ord (comparing) -import "text" Data.Text (Text) -import "this" Language.PureScript.CST.Errors -import "this" Language.PureScript.CST.Layout -import "this" Language.PureScript.CST.Positions -import "this" Language.PureScript.CST.Types +import Prelude + +import Data.List (sortBy) +import qualified Data.List.NonEmpty as NE +import Data.Ord (comparing) +import Data.Text (Text) +import Language.PureScript.CST.Errors +import Language.PureScript.CST.Layout +import Language.PureScript.CST.Positions +import Language.PureScript.CST.Types type LexResult = Either (LexState, ParserError) SourceToken diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y index 54a412956c..8ba4807ce1 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y +++ b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y @@ -16,23 +16,23 @@ module Language.PureScript.CST.Parser , PartialResult(..) ) where -import "base" Prelude hiding (lex) - -import "base" Control.Monad ((<=<), when) -import "base" Data.Foldable (foldl', for_, toList) -import qualified "base" Data.List.NonEmpty as NE -import "text" Data.Text (Text) -import "base" Data.Traversable (for, sequence) -import "this" Language.PureScript.CST.Errors -import "this" Language.PureScript.CST.Flatten (flattenType) -import "this" Language.PureScript.CST.Lexer -import "this" Language.PureScript.CST.Monad -import "this" Language.PureScript.CST.Positions -import "this" Language.PureScript.CST.Types -import "this" Language.PureScript.CST.Utils -import qualified "purescript-ast" Language.PureScript.Names as N -import qualified "purescript-ast" Language.PureScript.Roles as R -import "purescript-ast" Language.PureScript.PSString (PSString) +import Prelude hiding (lex) + +import Control.Monad ((<=<), when) +import Data.Foldable (foldl', for_, toList) +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import Data.Traversable (for, sequence) +import Language.PureScript.CST.Errors +import Language.PureScript.CST.Flatten (flattenType) +import Language.PureScript.CST.Lexer +import Language.PureScript.CST.Monad +import Language.PureScript.CST.Positions +import Language.PureScript.CST.Types +import Language.PureScript.CST.Utils +import qualified Language.PureScript.Names as N +import qualified Language.PureScript.Roles as R +import Language.PureScript.PSString (PSString) } %expect 95 diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs index cafd2428f7..0d49fc7624 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs @@ -5,14 +5,14 @@ module Language.PureScript.CST.Positions where -import "base" Prelude - -import "base" Data.Foldable (foldl') -import qualified "base" Data.List.NonEmpty as NE -import "text" Data.Text (Text) -import "base" Data.Void (Void) -import qualified "text" Data.Text as Text -import "this" Language.PureScript.CST.Types +import Prelude + +import Data.Foldable (foldl') +import qualified Data.List.NonEmpty as NE +import Data.Text (Text) +import Data.Void (Void) +import qualified Data.Text as Text +import Language.PureScript.CST.Types advanceToken :: SourcePos -> Token -> SourcePos advanceToken pos = applyDelta pos . tokenDelta diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Print.hs b/lib/purescript-cst/src/Language/PureScript/CST/Print.hs index 4e2d7560f1..16aac588dc 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Print.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Print.hs @@ -9,11 +9,11 @@ module Language.PureScript.CST.Print , printTrailingComment ) where -import "base" Prelude +import Prelude -import "text" Data.Text (Text) -import qualified "text" Data.Text as Text -import "this" Language.PureScript.CST.Types +import Data.Text (Text) +import qualified Data.Text as Text +import Language.PureScript.CST.Types printToken :: Token -> Text printToken = \case diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Traversals.hs b/lib/purescript-cst/src/Language/PureScript/CST/Traversals.hs index ea3f1278e7..6d5627f8ac 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Traversals.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Traversals.hs @@ -1,8 +1,8 @@ module Language.PureScript.CST.Traversals where -import "base" Prelude +import Prelude -import "this" Language.PureScript.CST.Types +import Language.PureScript.CST.Types everythingOnSeparated :: (r -> r -> r) -> (a -> r) -> Separated a -> r everythingOnSeparated op k (Separated hd tl) = go hd tl diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs b/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs index 1bce8e8c91..9d4fd7195c 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs @@ -1,9 +1,9 @@ module Language.PureScript.CST.Traversals.Type where -import "base" Prelude +import Prelude -import "this" Language.PureScript.CST.Types -import "this" Language.PureScript.CST.Traversals +import Language.PureScript.CST.Types +import Language.PureScript.CST.Traversals everythingOnTypes :: (r -> r -> r) -> (Type a -> r) -> Type a -> r everythingOnTypes op k = goTy diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Types.hs b/lib/purescript-cst/src/Language/PureScript/CST/Types.hs index 9b676ae00f..c35c3e9d07 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Types.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Types.hs @@ -7,15 +7,15 @@ module Language.PureScript.CST.Types where -import "base" Prelude +import Prelude -import "base" Data.List.NonEmpty (NonEmpty) -import "text" Data.Text (Text) -import "base" Data.Void (Void) -import "base" GHC.Generics (Generic) -import qualified "purescript-ast" Language.PureScript.Names as N +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Data.Void (Void) +import GHC.Generics (Generic) +import qualified Language.PureScript.Names as N import qualified Language.PureScript.Roles as R -import "purescript-ast" Language.PureScript.PSString (PSString) +import Language.PureScript.PSString (PSString) data SourcePos = SourcePos { srcLine :: {-# UNPACK #-} !Int diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs index e91a007d3a..54feed5734 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs @@ -1,23 +1,23 @@ module Language.PureScript.CST.Utils where -import "base" Prelude - -import "base" Control.Monad (when) -import "base" Data.Coerce (coerce) -import "base" Data.Foldable (for_) -import "base" Data.Functor (($>)) -import qualified "base" Data.List.NonEmpty as NE -import "containers" Data.Set (Set) -import qualified "containers" Data.Set as Set -import "text" Data.Text (Text) -import qualified "text" Data.Text as Text -import "this" Language.PureScript.CST.Errors -import "this" Language.PureScript.CST.Monad -import "this" Language.PureScript.CST.Positions -import "this" Language.PureScript.CST.Traversals.Type -import "this" Language.PureScript.CST.Types -import qualified "purescript-ast" Language.PureScript.Names as N -import "purescript-ast" Language.PureScript.PSString (PSString, mkString) +import Prelude + +import Control.Monad (when) +import Data.Coerce (coerce) +import Data.Foldable (for_) +import Data.Functor (($>)) +import qualified Data.List.NonEmpty as NE +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text +import Language.PureScript.CST.Errors +import Language.PureScript.CST.Monad +import Language.PureScript.CST.Positions +import Language.PureScript.CST.Traversals.Type +import Language.PureScript.CST.Types +import qualified Language.PureScript.Names as N +import Language.PureScript.PSString (PSString, mkString) placeholder :: SourceToken placeholder = SourceToken diff --git a/lib/purescript-cst/tests/Main.hs b/lib/purescript-cst/tests/Main.hs index 4e6da7007f..8a044fd81a 100644 --- a/lib/purescript-cst/tests/Main.hs +++ b/lib/purescript-cst/tests/Main.hs @@ -6,13 +6,13 @@ module Main (main) where -import "base-compat" Prelude.Compat +import Prelude.Compat -import "tasty" Test.Tasty +import Test.Tasty -import qualified "this" TestCst +import qualified TestCst -import "base" System.IO (hSetEncoding, stdout, stderr, utf8) +import System.IO (hSetEncoding, stdout, stderr, utf8) main :: IO () main = do diff --git a/lib/purescript-cst/tests/TestCst.hs b/lib/purescript-cst/tests/TestCst.hs index a885f3b426..f4561a1535 100644 --- a/lib/purescript-cst/tests/TestCst.hs +++ b/lib/purescript-cst/tests/TestCst.hs @@ -3,24 +3,24 @@ {-# LANGUAGE PackageImports #-} module TestCst where -import "base" Prelude - -import "base" Control.Monad (when) -import qualified "bytestring" Data.ByteString.Lazy as BS -import "base" Data.Maybe (fromMaybe) -import "text" Data.Text (Text) -import qualified "text" Data.Text as Text -import qualified "text" Data.Text.Encoding as Text -import qualified "text" Data.Text.IO as Text -import "tasty" Test.Tasty (TestTree, testGroup) -import "tasty-golden" Test.Tasty.Golden (goldenVsString, findByExtension) -import "tasty-quickcheck" Test.Tasty.QuickCheck -import "base" Text.Read (readMaybe) -import "purescript-cst" Language.PureScript.CST.Errors as CST -import "purescript-cst" Language.PureScript.CST.Lexer as CST -import "purescript-cst" Language.PureScript.CST.Print as CST -import "purescript-cst" Language.PureScript.CST.Types -import "filepath" System.FilePath (takeBaseName, replaceExtension) +import Prelude + +import Control.Monad (when) +import qualified Data.ByteString.Lazy as BS +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.IO as Text +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Golden (goldenVsString, findByExtension) +import Test.Tasty.QuickCheck +import Text.Read (readMaybe) +import Language.PureScript.CST.Errors as CST +import Language.PureScript.CST.Lexer as CST +import Language.PureScript.CST.Print as CST +import Language.PureScript.CST.Types +import System.FilePath (takeBaseName, replaceExtension) main :: IO TestTree main = do From 323df38b5fffcabd219f72cd8efd706750e2ac90 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 28 Mar 2020 11:45:36 -0400 Subject: [PATCH 1195/1580] Run golden tests in CI (#3808) * Run golden tests in CI This commit adds the golden test expected output files to the source distributions, and fails tests in CI if an expected output file doesn't exist (instead of automatically creating it like a local build would). * Revert b20aa4c change to DuplicateModule.out * Normalize paths for golden test output The warning/failure golden test files assume POSIX paths, but the paths that appear in warning and error messages are platform-dependent. This commit normalizes any Windows-style paths to POSIX-style before checking the output against the golden test files. --- ci/build.sh | 6 ++++++ lib/purescript-cst/package.yaml | 1 + package.yaml | 2 ++ tests/TestCompiler.hs | 29 +++++++++++++++++++++----- tests/purs/failing/DuplicateModule.out | 2 +- 5 files changed, 34 insertions(+), 6 deletions(-) diff --git a/ci/build.sh b/ci/build.sh index 85b326a095..1c46b0315d 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -29,6 +29,12 @@ else STACK_OPTS="$STACK_OPTS --fast" fi +# Fail the build instead of creating missing golden test files. Note that using +# the environment variable as opposed to the command line flag version of this +# option prevents test executables that don't contain golden tests from failing +# with an invalid option error. +export TASTY_NO_CREATE=true + # Install snapshot dependencies (since these will be cached globally and thus # can be reused during the sdist build step) $STACK build --only-snapshot $STACK_OPTS diff --git a/lib/purescript-cst/package.yaml b/lib/purescript-cst/package.yaml index 34d457c6b0..7eeb0f424c 100644 --- a/lib/purescript-cst/package.yaml +++ b/lib/purescript-cst/package.yaml @@ -16,6 +16,7 @@ license: BSD3 github: purescript/purescript homepage: http://www.purescript.org/ extra-source-files: + - tests/purs/layout/*.out - tests/purs/layout/*.purs - README.md dependencies: diff --git a/package.yaml b/package.yaml index 773e2087d4..39b3f22dc0 100644 --- a/package.yaml +++ b/package.yaml @@ -23,6 +23,7 @@ extra-source-files: - tests/purs/**/*.js - tests/purs/**/*.purs - tests/purs/**/*.json + - tests/purs/**/*.out - tests/json-compat/**/*.json - tests/support/*.json - tests/support/setup-win.cmd @@ -177,6 +178,7 @@ tests: - hspec - hspec-discover - HUnit + - regex-base default-extensions: - NoImplicitPrelude - LambdaCase diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 66704385ec..183b5b67c5 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -49,6 +49,9 @@ import System.FilePath import System.IO import System.IO.UTF8 (readUTF8File) +import Text.Regex.Base +import Text.Regex.TDFA (Regex) + import TestUtils import Test.Tasty import Test.Tasty.Hspec @@ -228,14 +231,30 @@ printErrorOrWarning printErrorOrWarning supportModules supportExterns supportForeigns inputFiles = do -- Sorting the input files makes some messages (e.g., duplicate module) deterministic (e, w) <- compile supportModules supportExterns supportForeigns (sort inputFiles) noPreCheck - case (const w <$> e) of - Left errs -> - return $ P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs - Right warnings -> - return $ P.prettyPrintMultipleErrors P.defaultPPEOptions $ warnings + return $ normalizePaths . P.prettyPrintMultipleErrors P.defaultPPEOptions $ either id (const w) e where noPreCheck = const (return ()) +-- Replaces Windows-style paths in an error or warning with POSIX paths +normalizePaths :: String -> String +normalizePaths = if pathSeparator == '\\' + then replaceMatches " [0-9A-Za-z_-]+(\\\\[0-9A-Za-z_-]+)+\\.[A-Za-z]+\\>" (map turnSlash) + else id + where + turnSlash '\\' = '/' + turnSlash c = c + +-- Uses a function to replace all matches of a regular expression in a string +replaceMatches :: String -> (String -> String) -> String -> String +replaceMatches reString phi = go + where + re :: Regex + re = makeRegex reString + go :: String -> String + go haystack = + let (prefix, needle, suffix) = match re haystack + in prefix ++ (if null needle then "" else phi needle ++ go suffix) + -- Takes the test entry point from a group of purs files - this is determined -- by the file with the shortest path name, as everything but the main file -- will be under a subdirectory. diff --git a/tests/purs/failing/DuplicateModule.out b/tests/purs/failing/DuplicateModule.out index 06a97ebd1f..7e66ff75bd 100644 --- a/tests/purs/failing/DuplicateModule.out +++ b/tests/purs/failing/DuplicateModule.out @@ -1,5 +1,5 @@ Error found: -at tests/purs/failing/DuplicateModule/M1.purs:1:1 - 1:16 (line 1, column 1 - line 1, column 16) +at tests/purs/failing/DuplicateModule.purs:2:1 - 2:16 (line 2, column 1 - line 2, column 16) Module M1 has been defined multiple times From 65f0cfd48000bec457bd772e66d5f1244f6fc7d1 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Tue, 31 Mar 2020 09:40:35 -0700 Subject: [PATCH 1196/1580] Use the same default extensions everywhere (#3823) * Use the same default extensions everywhere * Fix test output * Compile exe with default extensions * Fix ide warning --- app/Command/Bundle.hs | 2 ++ app/Command/Compile.hs | 2 ++ app/Command/Docs.hs | 2 ++ app/Command/Docs/Html.hs | 2 ++ app/Command/Docs/Markdown.hs | 2 ++ app/Command/Graph.hs | 2 ++ app/Command/Hierarchy.hs | 1 + app/Command/Publish.hs | 2 ++ app/Main.hs | 2 ++ app/Version.hs | 2 ++ default-extensions.yaml | 27 +++++++++++++++++ lib/purescript-ast/package.yaml | 27 +---------------- lib/purescript-cst/package.yaml | 25 +--------------- package.yaml | 29 ++----------------- src/Language/PureScript/Bundle.hs | 4 ++- .../PureScript/Docs/Convert/ReExports.hs | 2 ++ src/Language/PureScript/Ide/Types.hs | 2 +- .../PureScript/Interactive/Printer.hs | 2 ++ 18 files changed, 59 insertions(+), 78 deletions(-) create mode 100644 default-extensions.yaml diff --git a/app/Command/Bundle.hs b/app/Command/Bundle.hs index c030a2b974..a06a383c74 100644 --- a/app/Command/Bundle.hs +++ b/app/Command/Bundle.hs @@ -7,6 +7,8 @@ -- | Bundles compiled PureScript modules for the browser. module Command.Bundle (command) where +import Prelude + import Data.Traversable (for) import Data.Aeson (encode) import Data.Aeson.Encode.Pretty (confCompare, defConfig, encodePretty', keyOrder) diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 9246748e1c..fc6a572c3b 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -5,6 +5,8 @@ module Command.Compile (command) where +import Prelude + import Control.Applicative import Control.Monad import qualified Data.Aeson as A diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index f6bf57c9b3..cd73eda4eb 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -1,6 +1,8 @@ module Command.Docs (command, infoModList) where +import Prelude + import Command.Docs.Html import Command.Docs.Markdown import Control.Applicative diff --git a/app/Command/Docs/Html.hs b/app/Command/Docs/Html.hs index dbb009fa50..6362837562 100644 --- a/app/Command/Docs/Html.hs +++ b/app/Command/Docs/Html.hs @@ -8,6 +8,8 @@ module Command.Docs.Html , writeHtmlModules ) where +import Prelude + import Control.Applicative import Control.Arrow ((&&&)) import Control.Monad.Writer diff --git a/app/Command/Docs/Markdown.hs b/app/Command/Docs/Markdown.hs index 60d509892c..73338cbe37 100644 --- a/app/Command/Docs/Markdown.hs +++ b/app/Command/Docs/Markdown.hs @@ -5,6 +5,8 @@ module Command.Docs.Markdown , writeMarkdownModules ) where +import Prelude + import Data.Text (Text) import qualified Data.Text as T import qualified Language.PureScript as P diff --git a/app/Command/Graph.hs b/app/Command/Graph.hs index b1bf505b13..58f26ac00d 100644 --- a/app/Command/Graph.hs +++ b/app/Command/Graph.hs @@ -4,6 +4,8 @@ module Command.Graph (command) where +import Prelude + import Control.Applicative (many) import Control.Monad (unless, when) import qualified Data.Aeson as Json diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs index 142bd2d4ab..f732c5f146 100644 --- a/app/Command/Hierarchy.hs +++ b/app/Command/Hierarchy.hs @@ -17,6 +17,7 @@ module Command.Hierarchy (command) where +import Prelude import Protolude (catMaybes) import Control.Applicative (optional) diff --git a/app/Command/Publish.hs b/app/Command/Publish.hs index 43a9f6ae43..fe5f4c7d5e 100644 --- a/app/Command/Publish.hs +++ b/app/Command/Publish.hs @@ -2,6 +2,8 @@ module Command.Publish (command) where +import Prelude + import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy.Char8 as BL diff --git a/app/Main.hs b/app/Main.hs index 4b5b7df5d8..0acf5c7b3f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -7,6 +7,8 @@ module Main where +import Prelude + import qualified Command.Bundle as Bundle import qualified Command.Compile as Compile import qualified Command.Docs as Docs diff --git a/app/Version.hs b/app/Version.hs index dcf385041a..d56dad912a 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -3,6 +3,8 @@ module Version where +import Prelude + import Data.Version (showVersion) import Paths_purescript as Paths diff --git a/default-extensions.yaml b/default-extensions.yaml new file mode 100644 index 0000000000..2d8cbf1e11 --- /dev/null +++ b/default-extensions.yaml @@ -0,0 +1,27 @@ +- BangPatterns +- ConstraintKinds +- DataKinds +- DefaultSignatures +- DeriveFunctor +- DeriveFoldable +- DeriveTraversable +- DeriveGeneric +- DerivingStrategies +- EmptyDataDecls +- FlexibleContexts +- FlexibleInstances +- GeneralizedNewtypeDeriving +- KindSignatures +- LambdaCase +- MultiParamTypeClasses +- NamedFieldPuns +- NoImplicitPrelude +- PatternGuards +- PatternSynonyms +- RankNTypes +- RecordWildCards +- OverloadedStrings +- ScopedTypeVariables +- TupleSections +- TypeFamilies +- ViewPatterns diff --git a/lib/purescript-ast/package.yaml b/lib/purescript-ast/package.yaml index 00ff0335b7..c8175b0636 100644 --- a/lib/purescript-ast/package.yaml +++ b/lib/purescript-ast/package.yaml @@ -35,31 +35,6 @@ dependencies: library: source-dirs: src ghc-options: -Wall -O2 - default-extensions: - - ConstraintKinds - - DataKinds - - DefaultSignatures - - DeriveFunctor - - DeriveFoldable - - DeriveTraversable - - DeriveGeneric - - DerivingStrategies - - EmptyDataDecls - - FlexibleContexts - - FlexibleInstances - - GeneralizedNewtypeDeriving - - KindSignatures - - LambdaCase - - MultiParamTypeClasses - - NoImplicitPrelude - - PatternGuards - - PatternSynonyms - - RankNTypes - - RecordWildCards - - OverloadedStrings - - ScopedTypeVariables - - TupleSections - - TypeFamilies - - ViewPatterns + default-extensions: !include "../../default-extensions.yaml" stability: experimental diff --git a/lib/purescript-cst/package.yaml b/lib/purescript-cst/package.yaml index 7eeb0f424c..c3f6739ad0 100644 --- a/lib/purescript-cst/package.yaml +++ b/lib/purescript-cst/package.yaml @@ -34,30 +34,7 @@ build-tools: library: source-dirs: src ghc-options: -Wall -O2 - default-extensions: - - BangPatterns - - ConstraintKinds - - DataKinds - - DeriveFunctor - - DeriveFoldable - - DeriveTraversable - - DeriveGeneric - - DerivingStrategies - - EmptyDataDecls - - FlexibleContexts - - KindSignatures - - LambdaCase - - MultiParamTypeClasses - - NamedFieldPuns - - NoImplicitPrelude - - PatternGuards - - PatternSynonyms - - RankNTypes - - RecordWildCards - - OverloadedStrings - - ScopedTypeVariables - - TupleSections - - ViewPatterns + default-extensions: !include "../../default-extensions.yaml" tests: tests: diff --git a/package.yaml b/package.yaml index 39b3f22dc0..bf49ac0094 100644 --- a/package.yaml +++ b/package.yaml @@ -103,28 +103,7 @@ library: source-dirs: src ghc-options: -Wall -O2 other-modules: Paths_purescript - default-extensions: - - ConstraintKinds - - DataKinds - - DeriveFunctor - - DeriveFoldable - - DeriveTraversable - - DeriveGeneric - - DerivingStrategies - - EmptyDataDecls - - FlexibleContexts - - KindSignatures - - LambdaCase - - MultiParamTypeClasses - - NoImplicitPrelude - - PatternGuards - - PatternSynonyms - - RankNTypes - - RecordWildCards - - OverloadedStrings - - ScopedTypeVariables - - TupleSections - - ViewPatterns + default-extensions: !include "./default-extensions.yaml" executables: purs: @@ -163,6 +142,7 @@ executables: else: dependencies: - gitrev >=1.2.0 && <1.4 + default-extensions: !include "./default-extensions.yaml" tests: tests: @@ -179,10 +159,7 @@ tests: - hspec-discover - HUnit - regex-base - default-extensions: - - NoImplicitPrelude - - LambdaCase - - OverloadedStrings + default-extensions: !include "./default-extensions.yaml" flags: release: diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index cf90d2e0ae..82bf1cb234 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -378,6 +378,7 @@ toModule mids mid filename top | JSAstProgram smts _ <- top = Module mid filename <$> traverse toModuleElement smts | otherwise = err InvalidTopLevel where + err :: ErrorMessage -> m a err = throwError . ErrorInModule mid toModuleElement :: JSStatement -> m ModuleElement @@ -415,7 +416,7 @@ toModule mids mid filename top -- -- TODO: what if we assign to exports.foo and then later assign to -- module.exports (presumably overwriting exports.foo)? -getExportedIdentifiers :: (MonadError ErrorMessage m) +getExportedIdentifiers :: forall m. (MonadError ErrorMessage m) => String -> JSAST -> m [String] @@ -423,6 +424,7 @@ getExportedIdentifiers mname top | JSAstProgram stmts _ <- top = concat <$> traverse go stmts | otherwise = err InvalidTopLevel where + err :: ErrorMessage -> m a err = throwError . ErrorInModule (ModuleIdentifier mname Foreign) go stmt diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index d3b23c36e1..9cd096a4c3 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -179,6 +179,7 @@ collectDeclarations reExports = do expCtors = concatMap (fromMaybe [] . (>>= snd) . P.getTypeRef . snd) reExports lookupValueDeclaration :: + forall m. (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) => P.ModuleName -> @@ -190,6 +191,7 @@ lookupValueDeclaration importedFrom ident = do rs = filter (\d -> declTitle d == P.showIdent ident && (isValue d || isValueAlias d)) decls + errOther :: Show a => a -> m b errOther other = internalErrorInModule ("lookupValueDeclaration: unexpected result:\n" ++ diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index f566f2b40c..2a657bfbdc 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -1,7 +1,7 @@ -- | -- Type definitions for psc-ide -{-# language DeriveGeneric, DeriveAnyClass, DeriveFoldable, TemplateHaskell #-} +{-# language DeriveAnyClass, NoGeneralizedNewtypeDeriving, TemplateHaskell #-} module Language.PureScript.Ide.Types where diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index e42759610f..a0e5f01277 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -25,6 +25,8 @@ printModuleSignatures moduleName P.Environment{..} = let moduleNamesIdent = byModuleName names moduleTypeClasses = byModuleName typeClasses moduleTypes = byModuleName types + + byModuleName :: M.Map (P.Qualified a) b -> [P.Qualified a] byModuleName = filter ((== Just moduleName) . P.getQual) . M.keys in From 1fcbb06c702bd5ed17ddb446c3472266d180d3f5 Mon Sep 17 00:00:00 2001 From: Cyril Date: Sun, 5 Apr 2020 01:07:16 +0200 Subject: [PATCH 1197/1580] Deprecate primes in identifiers exported from foreign modules (#3792) --- CONTRIBUTORS.md | 1 + src/Language/PureScript/Errors.hs | 9 +++ src/Language/PureScript/Make/Actions.hs | 9 +++ tests/purs/passing/2172.purs | 10 ---- .../2172.js => warning/DeprecatedFFIPrime.js} | 0 tests/purs/warning/DeprecatedFFIPrime.out | 56 +++++++++++++++++++ tests/purs/warning/DeprecatedFFIPrime.purs | 10 ++++ 7 files changed, 85 insertions(+), 10 deletions(-) delete mode 100644 tests/purs/passing/2172.purs rename tests/purs/{passing/2172.js => warning/DeprecatedFFIPrime.js} (100%) create mode 100644 tests/purs/warning/DeprecatedFFIPrime.out create mode 100644 tests/purs/warning/DeprecatedFFIPrime.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 34b9b2e768..7e8228b146 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -139,6 +139,7 @@ If you would prefer to use different terms, please use the section below instead | [@matthew-hilty](https://github.com/matthew-hilty) | Matthew Hilty | [MIT license](http://opensource.org/licenses/MIT) | | [@woody88](https://github.com/woody88) | Woodson Delhia | [MIT license](http://opensource.org/licenses/MIT) | | [@mhmdanas](https://github.com/mhmdanas) | Mohammed Anas | [MIT license](http://opensource.org/licenses/MIT) | +| [@kl0tl](https://github.com/kl0tl) | Cyril Sobierajewicz | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 5e6260d83b..90dfc43fdd 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -63,6 +63,7 @@ data SimpleErrorMessage | MissingFFIImplementations ModuleName [Ident] | UnusedFFIImplementations ModuleName [Ident] | InvalidFFIIdentifier ModuleName Text + | DeprecatedFFIPrime ModuleName Text | FileIOError Text IOError -- ^ A description of what we were trying to do, and the error which occurred | InfiniteType SourceType | InfiniteKind SourceType @@ -221,6 +222,7 @@ errorCode em = case unwrapErrorMessage em of MissingFFIImplementations{} -> "MissingFFIImplementations" UnusedFFIImplementations{} -> "UnusedFFIImplementations" InvalidFFIIdentifier{} -> "InvalidFFIIdentifier" + DeprecatedFFIPrime{} -> "DeprecatedFFIPrime" FileIOError{} -> "FileIOError" InfiniteType{} -> "InfiniteType" InfiniteKind{} -> "InfiniteKind" @@ -669,6 +671,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , line "Note that exported identifiers in FFI modules must be valid PureScript identifiers." ] ] + renderSimpleErrorMessage (DeprecatedFFIPrime mn ident) = + paras [ line $ "In the FFI module for " <> markCode (runModuleName mn) <> ":" + , indent . paras $ + [ line $ "The identifier " <> markCode ident <> " contains a prime (" <> markCode "'" <> ")." + , line $ "Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future." + ] + ] renderSimpleErrorMessage InvalidDoBind = line "The last statement in a 'do' block must be an expression, but this block ends with a binder." renderSimpleErrorMessage InvalidDoLet = diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index c3a0d2fab5..9fbaf6f2c7 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -285,6 +285,11 @@ checkForeignDecls m path = do js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path foreignIdentsStrs <- either errorParsingModule pure $ getExps js + + let deprecatedFFI = filter (any (== '\'')) foreignIdentsStrs + unless (null deprecatedFFI) $ + warningDeprecatedForeignPrimes deprecatedFFI + foreignIdents <- either errorInvalidForeignIdentifiers (pure . S.fromList) @@ -315,6 +320,10 @@ checkForeignDecls m path = do errorInvalidForeignIdentifiers = throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack) + warningDeprecatedForeignPrimes :: [String] -> Make () + warningDeprecatedForeignPrimes = + tell . mconcat . map (errorMessage' modSS . DeprecatedFFIPrime mname . T.pack) + parseIdents :: [String] -> Either [String] [Ident] parseIdents strs = case partitionEithers (map parseIdent strs) of diff --git a/tests/purs/passing/2172.purs b/tests/purs/passing/2172.purs deleted file mode 100644 index 34580ccd3d..0000000000 --- a/tests/purs/passing/2172.purs +++ /dev/null @@ -1,10 +0,0 @@ -module Main where - -import Effect.Console (log) - -foreign import a' :: Number -foreign import b' :: Number -foreign import c' :: Number -foreign import d' :: Number - -main = log "Done" diff --git a/tests/purs/passing/2172.js b/tests/purs/warning/DeprecatedFFIPrime.js similarity index 100% rename from tests/purs/passing/2172.js rename to tests/purs/warning/DeprecatedFFIPrime.js diff --git a/tests/purs/warning/DeprecatedFFIPrime.out b/tests/purs/warning/DeprecatedFFIPrime.out new file mode 100644 index 0000000000..893228ea45 --- /dev/null +++ b/tests/purs/warning/DeprecatedFFIPrime.out @@ -0,0 +1,56 @@ +Error 1 of 4: + + at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) + + In the FFI module for Main: + + The identifier a' contains a prime ('). + Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future. + + + + See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, + or to contribute content related to this error. + +Error 2 of 4: + + at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) + + In the FFI module for Main: + + The identifier b' contains a prime ('). + Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future. + + + + See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, + or to contribute content related to this error. + +Error 3 of 4: + + at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) + + In the FFI module for Main: + + The identifier c' contains a prime ('). + Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future. + + + + See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, + or to contribute content related to this error. + +Error 4 of 4: + + at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) + + In the FFI module for Main: + + The identifier d' contains a prime ('). + Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future. + + + + See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/warning/DeprecatedFFIPrime.purs b/tests/purs/warning/DeprecatedFFIPrime.purs new file mode 100644 index 0000000000..3c57a19d92 --- /dev/null +++ b/tests/purs/warning/DeprecatedFFIPrime.purs @@ -0,0 +1,10 @@ +-- @shouldWarnWith DeprecatedFFIPrime +-- @shouldWarnWith DeprecatedFFIPrime +-- @shouldWarnWith DeprecatedFFIPrime +-- @shouldWarnWith DeprecatedFFIPrime +module Main where + +foreign import a' :: Number +foreign import b' :: Number +foreign import c' :: Number +foreign import d' :: Number From 965ba23c8e8969f4f5a88e469e89f16f921d02e8 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sat, 4 Apr 2020 16:16:21 -0700 Subject: [PATCH 1198/1580] Fix make ghcid (#3826) --- Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 2502363910..5ba08c61ad 100644 --- a/Makefile +++ b/Makefile @@ -7,10 +7,10 @@ help: ## Print documentation @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' ghcid: ## Run ghcid to quickly reload code on save. - ghcid --command "stack ghci purescript:lib purescript:test:tests --ghci-options -fno-code" + ghcid --command "stack ghci purescript:exe:purs purescript:lib purescript:test:tests purescript-ast purescript-cst --main-is purescript:exe:purs --ghci-options -fno-code" ghcid-test: ## Run ghcid to quickly reload code and run tests on save. - ghcid --command "stack ghci purescript:lib purescript:test:tests --ghci-options -fobject-code" \ + ghcid --command "stack ghci purescript:lib purescript:test:tests purescript-ast purescript-cst --ghci-options -fobject-code" \ --test "Main.main" build: ## Build the package. From 0aaa49070829f5a0a6bbdeb8541988a05dc93fd8 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sun, 5 Apr 2020 12:31:32 -0700 Subject: [PATCH 1199/1580] Fix substitution during kind generalization (#3831) We were not applying the substitution for generalized kinds to their own kinds, which can result in unknowns sticking around in a generalized kind. I've also fixed an issue wrt to hygiene in kind declarations, where the names for generalized kinds were not using the usual name generation scheme. --- src/Language/PureScript/TypeChecker/Kinds.hs | 5 ++--- tests/purs/passing/3830.purs | 16 ++++++++++++++++ 2 files changed, 18 insertions(+), 3 deletions(-) create mode 100644 tests/purs/passing/3830.purs diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index dd4c90ed33..e3306fb488 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -60,7 +60,7 @@ generalizeUnknowns unks ty = generalizeUnknownsWithVars :: [(Unknown, (Text, SourceType))] -> SourceType -> SourceType generalizeUnknownsWithVars binders ty = - mkForAll ((getAnnForType ty,) . fmap Just . snd <$> binders) . replaceUnknownsWithVars binders $ ty + mkForAll ((getAnnForType ty,) . fmap (Just . replaceUnknownsWithVars binders) . snd <$> binders) . replaceUnknownsWithVars binders $ ty replaceUnknownsWithVars :: [(Unknown, (Text, a))] -> SourceType -> SourceType replaceUnknownsWithVars binders ty @@ -855,8 +855,7 @@ checkKindDeclaration _ ty = do checkTypeKind kind E.kindType ty'' <- replaceAllTypeSynonyms ty' unks <- unknownsWithKinds . IS.toList $ unknowns ty'' - freshUnks <- traverse (traverse (\k -> (,k) <$> freshVar "k")) unks - finalTy <- generalizeUnknownsWithVars freshUnks <$> freshenForAlls ty' ty'' + finalTy <- generalizeUnknowns unks <$> freshenForAlls ty' ty'' checkQuantification finalTy checkValidKind finalTy where diff --git a/tests/purs/passing/3830.purs b/tests/purs/passing/3830.purs new file mode 100644 index 0000000000..05d040fe78 --- /dev/null +++ b/tests/purs/passing/3830.purs @@ -0,0 +1,16 @@ +module Main where + +import Effect.Console (log) + +data Proxy :: forall k. k -> Type +data Proxy a = Proxy + +data PProxy :: forall k1 (k2 :: k1). (Proxy k2 -> Type) -> Type +data PProxy p = PProxy + +type PProxy' = PProxy + +test :: PProxy' Proxy +test = PProxy + +main = log "Done" From 8869eb30cc4528a908e37cb97401938e59cbeffb Mon Sep 17 00:00:00 2001 From: Christoph Hegemann <6189397+kritzcreek@users.noreply.github.com> Date: Sun, 12 Apr 2020 20:09:20 +0200 Subject: [PATCH 1200/1580] Binary encoding for externs (#3841) This commit changes the encoding for externs from JSON to CBOR. We're using the serialise library to derive instances for all the relevant data types. By doing this we're getting significant speedups in IDE startup time, but also in the normal compiler pipeline. The performance measurements in this PR measure how long it takes to load the fully built pscid project and populate the IDE caches. It's dominated by the time it takes to deserialise the externs files, and drops from 3.5s to 0.55s. Memory allocations drop from 8,460,187,856 bytes to 1,649,605,704 bytes. --- lib/purescript-ast/package.yaml | 1 + .../Language/PureScript/AST/Declarations.hs | 7 +-- .../src/Language/PureScript/AST/Operators.hs | 3 ++ .../src/Language/PureScript/AST/SourcePos.hs | 10 ++-- .../src/Language/PureScript/Comments.hs | 2 + .../src/Language/PureScript/Environment.hs | 6 +++ .../src/Language/PureScript/Label.hs | 2 + .../src/Language/PureScript/Names.hs | 7 +++ .../src/Language/PureScript/PSString.hs | 2 + .../src/Language/PureScript/Roles.hs | 2 + .../src/Language/PureScript/Types.hs | 5 ++ package.yaml | 2 + psc-ide/README.md | 2 +- src/Language/PureScript/Externs.hs | 34 +++++++++---- src/Language/PureScript/Ide.hs | 12 ++--- src/Language/PureScript/Ide/Externs.hs | 42 ++++++++-------- src/Language/PureScript/Make.hs | 2 +- src/Language/PureScript/Make/Actions.hs | 8 +-- src/Language/PureScript/Make/Monad.hs | 50 +++++++++++++++++-- stack.yaml | 2 + 20 files changed, 142 insertions(+), 59 deletions(-) diff --git a/lib/purescript-ast/package.yaml b/lib/purescript-ast/package.yaml index c8175b0636..81198f62fe 100644 --- a/lib/purescript-ast/package.yaml +++ b/lib/purescript-ast/package.yaml @@ -29,6 +29,7 @@ dependencies: - mtl >=2.1.0 && <2.3.0 - protolude >=0.1.6 && <0.2.4 - scientific >=0.3.4.9 && <0.4 + - serialise - text - vector diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs index 1c5472207c..b462ad4f06 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs @@ -8,6 +8,7 @@ module Language.PureScript.AST.Declarations where import Prelude.Compat +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Data.Functor.Identity @@ -179,7 +180,7 @@ data DeclarationRef -- elaboration in name desugaring. -- | ReExportRef SourceSpan ExportSource DeclarationRef - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Serialise) instance Eq DeclarationRef where (TypeRef _ name dctors) == (TypeRef _ name' dctors') = name == name' && dctors == dctors' @@ -197,7 +198,7 @@ data ExportSource = { exportSourceImportedFrom :: Maybe ModuleName , exportSourceDefinedIn :: ModuleName } - deriving (Eq, Ord, Show, Generic, NFData) + deriving (Eq, Ord, Show, Generic, NFData, Serialise) -- enable sorting lists of explicitly imported refs when suggesting imports in linting, IDE, etc. -- not an Ord because this implementation is not consistent with its Eq instance. @@ -282,7 +283,7 @@ data ImportDeclarationType -- An import with a list of references to hide: `import M hiding (foo)` -- | Hiding [DeclarationRef] - deriving (Eq, Show) + deriving (Eq, Show, Generic, Serialise) isImplicit :: ImportDeclarationType -> Bool isImplicit Implicit = True diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Operators.hs b/lib/purescript-ast/src/Language/PureScript/AST/Operators.hs index bad560c078..aa7ad57304 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Operators.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Operators.hs @@ -5,6 +5,7 @@ module Language.PureScript.AST.Operators where import Prelude.Compat +import Codec.Serialise (Serialise) import GHC.Generics (Generic) import Control.DeepSeq (NFData) import Data.Aeson ((.=)) @@ -24,6 +25,7 @@ data Associativity = Infixl | Infixr | Infix deriving (Show, Eq, Ord, Generic) instance NFData Associativity +instance Serialise Associativity showAssoc :: Associativity -> String showAssoc Infixl = "infixl" @@ -49,6 +51,7 @@ data Fixity = Fixity Associativity Precedence deriving (Show, Eq, Ord, Generic) instance NFData Fixity +instance Serialise Fixity instance A.ToJSON Fixity where toJSON (Fixity associativity precedence) = diff --git a/lib/purescript-ast/src/Language/PureScript/AST/SourcePos.hs b/lib/purescript-ast/src/Language/PureScript/AST/SourcePos.hs index 58ad616c27..5fcb784325 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/SourcePos.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/SourcePos.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} -- | -- Source position information -- @@ -5,6 +6,7 @@ module Language.PureScript.AST.SourcePos where import Prelude.Compat +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Data.Aeson ((.=), (.:)) import Data.Text (Text) @@ -23,9 +25,7 @@ data SourcePos = SourcePos -- ^ Line number , sourcePosColumn :: Int -- ^ Column number - } deriving (Show, Eq, Ord, Generic) - -instance NFData SourcePos + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) displaySourcePos :: SourcePos -> Text displaySourcePos sp = @@ -53,9 +53,7 @@ data SourceSpan = SourceSpan -- ^ Start of the span , spanEnd :: SourcePos -- ^ End of the span - } deriving (Show, Eq, Ord, Generic) - -instance NFData SourceSpan + } deriving (Show, Eq, Ord, Generic, NFData, Serialise) displayStartEndPos :: SourceSpan -> Text displayStartEndPos sp = diff --git a/lib/purescript-ast/src/Language/PureScript/Comments.hs b/lib/purescript-ast/src/Language/PureScript/Comments.hs index 082fedb62f..468e794d34 100644 --- a/lib/purescript-ast/src/Language/PureScript/Comments.hs +++ b/lib/purescript-ast/src/Language/PureScript/Comments.hs @@ -6,6 +6,7 @@ module Language.PureScript.Comments where import Prelude.Compat +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Data.Text (Text) import GHC.Generics (Generic) @@ -18,5 +19,6 @@ data Comment deriving (Show, Eq, Ord, Generic) instance NFData Comment +instance Serialise Comment $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Comment) diff --git a/lib/purescript-ast/src/Language/PureScript/Environment.hs b/lib/purescript-ast/src/Language/PureScript/Environment.hs index bcd3c9cff8..2a5da9fa09 100644 --- a/lib/purescript-ast/src/Language/PureScript/Environment.hs +++ b/lib/purescript-ast/src/Language/PureScript/Environment.hs @@ -5,6 +5,7 @@ import Protolude (ordNub) import GHC.Generics (Generic) import Control.DeepSeq (NFData) +import Codec.Serialise (Serialise) import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A import qualified Data.Map as M @@ -83,6 +84,7 @@ data FunctionalDependency = FunctionalDependency } deriving (Show, Generic) instance NFData FunctionalDependency +instance Serialise FunctionalDependency instance A.FromJSON FunctionalDependency where parseJSON = A.withObject "FunctionalDependency" $ \o -> @@ -192,6 +194,7 @@ data NameVisibility deriving (Show, Eq, Generic) instance NFData NameVisibility +instance Serialise NameVisibility -- | A flag for whether a name is for an private or public value - only public values will be -- included in a generated externs file. @@ -206,6 +209,7 @@ data NameKind deriving (Show, Eq, Generic) instance NFData NameKind +instance Serialise NameKind -- | The kinds of a type data TypeKind @@ -222,6 +226,7 @@ data TypeKind deriving (Show, Eq, Generic) instance NFData TypeKind +instance Serialise TypeKind instance A.ToJSON TypeKind where toJSON (DataType args ctors) = @@ -255,6 +260,7 @@ data DataDeclType deriving (Show, Eq, Ord, Generic) instance NFData DataDeclType +instance Serialise DataDeclType showDataDeclType :: DataDeclType -> Text showDataDeclType Data = "data" diff --git a/lib/purescript-ast/src/Language/PureScript/Label.hs b/lib/purescript-ast/src/Language/PureScript/Label.hs index 4aab084503..e2e0dc8093 100644 --- a/lib/purescript-ast/src/Language/PureScript/Label.hs +++ b/lib/purescript-ast/src/Language/PureScript/Label.hs @@ -2,6 +2,7 @@ module Language.PureScript.Label (Label(..)) where import Prelude.Compat hiding (lex) import GHC.Generics (Generic) +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Data.Monoid () import Data.String (IsString(..)) @@ -17,3 +18,4 @@ newtype Label = Label { runLabel :: PSString } deriving (Show, Eq, Ord, IsString, Semigroup, Monoid, A.ToJSON, A.FromJSON, Generic) instance NFData Label +instance Serialise Label diff --git a/lib/purescript-ast/src/Language/PureScript/Names.hs b/lib/purescript-ast/src/Language/PureScript/Names.hs index 1e1408d48d..98fdeaadfa 100644 --- a/lib/purescript-ast/src/Language/PureScript/Names.hs +++ b/lib/purescript-ast/src/Language/PureScript/Names.hs @@ -7,6 +7,7 @@ module Language.PureScript.Names where import Prelude.Compat +import Codec.Serialise (Serialise) import Control.Monad.Supply.Class import Control.DeepSeq (NFData) import Data.Functor.Contravariant (contramap) @@ -29,6 +30,7 @@ data Name deriving (Eq, Ord, Show, Generic) instance NFData Name +instance Serialise Name getIdentName :: Name -> Maybe Ident getIdentName (IdentName name) = Just name @@ -77,6 +79,7 @@ data Ident deriving (Show, Eq, Ord, Generic) instance NFData Ident +instance Serialise Ident runIdent :: Ident -> Text runIdent (Ident i) = i @@ -100,6 +103,7 @@ newtype OpName (a :: OpNameType) = OpName { runOpName :: Text } deriving (Show, Eq, Ord, Generic) instance NFData (OpName a) +instance Serialise (OpName a) instance ToJSON (OpName a) where toJSON = toJSON . runOpName @@ -125,6 +129,7 @@ newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text } deriving (Show, Eq, Ord, Generic) instance NFData (ProperName a) +instance Serialise (ProperName a) instance ToJSON (ProperName a) where toJSON = toJSON . runProperName @@ -156,6 +161,7 @@ newtype ModuleName = ModuleName [ProperName 'Namespace] deriving (Show, Eq, Ord, Generic) instance NFData ModuleName +instance Serialise ModuleName runModuleName :: ModuleName -> Text runModuleName (ModuleName pns) = T.intercalate "." (runProperName <$> pns) @@ -179,6 +185,7 @@ data Qualified a = Qualified (Maybe ModuleName) a deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) instance NFData a => NFData (Qualified a) +instance Serialise a => Serialise (Qualified a) showQualified :: (a -> Text) -> Qualified a -> Text showQualified f (Qualified Nothing a) = f a diff --git a/lib/purescript-ast/src/Language/PureScript/PSString.hs b/lib/purescript-ast/src/Language/PureScript/PSString.hs index bf677c5c83..081bf715f1 100644 --- a/lib/purescript-ast/src/Language/PureScript/PSString.hs +++ b/lib/purescript-ast/src/Language/PureScript/PSString.hs @@ -11,6 +11,7 @@ module Language.PureScript.PSString import Prelude.Compat import GHC.Generics (Generic) +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Control.Exception (try, evaluate) import Control.Applicative ((<|>)) @@ -50,6 +51,7 @@ newtype PSString = PSString { toUTF16CodeUnits :: [Word16] } deriving (Eq, Ord, Semigroup, Monoid, Generic) instance NFData PSString +instance Serialise PSString instance Show PSString where show = show . codePoints diff --git a/lib/purescript-ast/src/Language/PureScript/Roles.hs b/lib/purescript-ast/src/Language/PureScript/Roles.hs index e06e382c31..1ac1fb74fa 100644 --- a/lib/purescript-ast/src/Language/PureScript/Roles.hs +++ b/lib/purescript-ast/src/Language/PureScript/Roles.hs @@ -9,6 +9,7 @@ module Language.PureScript.Roles import Prelude.Compat +import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import qualified Data.Aeson as A import qualified Data.Aeson.TH as A @@ -29,5 +30,6 @@ data Role deriving (Show, Eq, Ord, Generic) instance NFData Role +instance Serialise Role $(A.deriveJSON A.defaultOptions ''Role) diff --git a/lib/purescript-ast/src/Language/PureScript/Types.hs b/lib/purescript-ast/src/Language/PureScript/Types.hs index 4338e547a4..f221d3619d 100644 --- a/lib/purescript-ast/src/Language/PureScript/Types.hs +++ b/lib/purescript-ast/src/Language/PureScript/Types.hs @@ -6,6 +6,7 @@ module Language.PureScript.Types where import Prelude.Compat import Protolude (ordNub) +import Codec.Serialise (Serialise) import Control.Applicative ((<|>)) import Control.Arrow (first, second) import Control.DeepSeq (NFData) @@ -41,6 +42,7 @@ newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Eq, Ord, A.ToJSON, A.FromJSON, Generic) instance NFData SkolemScope +instance Serialise SkolemScope -- | -- The type of types @@ -87,6 +89,7 @@ data Type a deriving (Show, Generic, Functor, Foldable, Traversable) instance NFData a => NFData (Type a) +instance Serialise a => Serialise (Type a) srcTUnknown :: Int -> SourceType srcTUnknown = TUnknown NullSourceAnn @@ -155,6 +158,7 @@ data ConstraintData deriving (Show, Eq, Ord, Generic) instance NFData ConstraintData +instance Serialise ConstraintData -- | A typeclass constraint data Constraint a = Constraint @@ -171,6 +175,7 @@ data Constraint a = Constraint } deriving (Show, Generic, Functor, Foldable, Traversable) instance NFData a => NFData (Constraint a) +instance Serialise a => Serialise (Constraint a) srcConstraint :: Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> Maybe ConstraintData -> SourceConstraint srcConstraint = Constraint NullSourceAnn diff --git a/package.yaml b/package.yaml index bf49ac0094..5b5afcb7eb 100644 --- a/package.yaml +++ b/package.yaml @@ -50,6 +50,8 @@ dependencies: - boxes >=0.1.4 && <0.2.0 - bytestring - Cabal >= 2.2 && <3.0 + - cborg + - serialise - cheapskate >=0.1 && <0.2 - clock - containers diff --git a/psc-ide/README.md b/psc-ide/README.md index a97d1a2a71..80d9f65eed 100644 --- a/psc-ide/README.md +++ b/psc-ide/README.md @@ -32,7 +32,7 @@ After you started the server you can start issuing requests using `purs ide client`. Make sure you start by loading the modules before you try to query them. -`purs ide` expects the built externs.json inside the output folder of your +`purs ide` expects the built externs inside the output folder of your project after running `pulp build` or `purs compile` respectively. (If you changed the port of the server you can change the port for diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 9c802bd643..97b6d99320 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -13,11 +13,13 @@ module Language.PureScript.Externs , externsIsCurrentVersion , moduleToExternsFile , applyExternsFileToEnvironment + , externsFileName ) where import Prelude.Compat -import Data.Aeson.TH +import Codec.Serialise (Serialise) +import GHC.Generics (Generic) import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.List (foldl', find) import Data.Foldable (fold) @@ -39,6 +41,9 @@ import Paths_purescript as Paths -- | The data which will be serialized to an externs file data ExternsFile = ExternsFile + -- NOTE: Make sure to keep `efVersion` as the first field in this + -- record, so the derived Serialise instance produces CBOR that can + -- be checked for its version independent of the remaining format { efVersion :: Text -- ^ The externs version , efModuleName :: ModuleName @@ -55,7 +60,9 @@ data ExternsFile = ExternsFile -- ^ List of type and value declaration , efSourceSpan :: SourceSpan -- ^ Source span for error reporting - } deriving (Show) + } deriving (Show, Generic) + +instance Serialise ExternsFile -- | A module import in an externs file data ExternsImport = ExternsImport @@ -66,7 +73,9 @@ data ExternsImport = ExternsImport , eiImportType :: ImportDeclarationType -- | The imported-as name, for qualified imports , eiImportedAs :: Maybe ModuleName - } deriving (Show) + } deriving (Show, Generic) + +instance Serialise ExternsImport -- | A fixity declaration in an externs file data ExternsFixity = ExternsFixity @@ -79,7 +88,9 @@ data ExternsFixity = ExternsFixity , efOperator :: OpName 'ValueOpName -- | The value the operator is an alias for , efAlias :: Qualified (Either Ident (ProperName 'ConstructorName)) - } deriving (Show) + } deriving (Show, Generic) + +instance Serialise ExternsFixity -- | A type fixity declaration in an externs file data ExternsTypeFixity = ExternsTypeFixity @@ -92,7 +103,9 @@ data ExternsTypeFixity = ExternsTypeFixity , efTypeOperator :: OpName 'TypeOpName -- | The value the operator is an alias for , efTypeAlias :: Qualified (ProperName 'TypeName) - } deriving (Show) + } deriving (Show, Generic) + +instance Serialise ExternsTypeFixity -- | A type or value declaration appearing in an externs file data ExternsDeclaration = @@ -146,7 +159,9 @@ data ExternsDeclaration = , edInstanceChain :: [Qualified Ident] , edInstanceChainIndex :: Integer } - deriving Show + deriving (Show, Generic) + +instance Serialise ExternsDeclaration -- | Check whether the version in an externs file matches the currently running -- version. @@ -251,8 +266,5 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} ] toExternsDeclaration _ = [] -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport) -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFixity) -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsTypeFixity) -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration) -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile) +externsFileName :: FilePath +externsFileName = "externs.cbor" diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 210b821acf..383e80fd56 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -154,8 +154,8 @@ caseSplit l b e csa t = do patterns <- CS.makePattern l b e csa <$> CS.caseSplit t pure (MultilineTextResult patterns) --- | Finds all the externs.json files inside the output folder and returns the --- corresponding Modulenames +-- | Finds all the externs inside the output folder and returns the +-- corresponding module names findAvailableExterns :: (Ide m, MonadError IdeError m) => m [P.ModuleName] findAvailableExterns = do oDir <- outputDirectory @@ -166,13 +166,13 @@ findAvailableExterns = do moduleNames <- filterM (containsExterns oDir) directories pure (P.moduleNameFromString . toS <$> moduleNames) where - -- Takes the output directory and a filepath like "Monad.Control.Eff" and - -- looks up, whether that folder contains an externs.json + -- Takes the output directory and a filepath like "Data.Array" and + -- looks up, whether that folder contains an externs file containsExterns :: FilePath -> FilePath -> IO Bool containsExterns oDir d | d `elem` [".", ".."] = pure False | otherwise = do - let file = oDir d "externs.json" + let file = oDir d P.externsFileName doesFileExist file -- | Finds all matches for the globs specified at the commandline @@ -211,7 +211,7 @@ loadModules moduleNames = do -- We resolve all the modulenames to externs files and load these into memory. oDir <- outputDirectory let efPaths = - map (\mn -> oDir toS (P.runModuleName mn) "externs.json") moduleNames + map (\mn -> oDir toS (P.runModuleName mn) P.externsFileName) moduleNames efiles <- traverse readExternFile efPaths traverse_ insertExterns efiles diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 607848361e..6542d0bc77 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -7,13 +7,12 @@ module Language.PureScript.Ide.Externs import Protolude hiding (to, from, (&)) +import Codec.CBOR.Term as Term import "monad-logger" Control.Monad.Logger -import Data.Aeson (decodeStrict) -import Data.Aeson.Types (withObject, parseMaybe, (.:)) -import qualified Data.ByteString as BS import Data.Version (showVersion) import qualified Data.Text as Text import qualified Language.PureScript as P +import qualified Language.PureScript.Make.Monad as Make import Language.PureScript.Ide.Error (IdeError (..)) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util (properNameT) @@ -24,25 +23,24 @@ readExternFile => FilePath -> m P.ExternsFile readExternFile fp = do - externsFile <- liftIO (BS.readFile fp) - case decodeStrict externsFile of - Nothing -> - let - parser = withObject "ExternsFileVersion" (.: "efVersion") - maybeEFVersion = parseMaybe parser =<< decodeStrict externsFile - in case maybeEFVersion of - Nothing -> - throwError (GeneralError ("Parsing the extern at: " <> toS fp <> " failed")) - Just efVersion -> do - let errMsg = "Version mismatch for the externs at: " <> toS fp - <> " Expected: " <> version - <> " Found: " <> efVersion - logErrorN errMsg - throwError (GeneralError errMsg) - Just externs -> pure externs - - where - version = toS (showVersion P.version) + externsFile <- liftIO (Make.readCborFileIO fp) + case externsFile of + Just externs | version == P.efVersion externs -> + pure externs + _ -> + liftIO (Make.readCborFileIO fp) >>= \case + Just (Term.TList (_tag : Term.TString efVersion : _rest)) -> do + let errMsg = + "Version mismatch for the externs at: " + <> toS fp + <> " Expected: " <> version + <> " Found: " <> efVersion + logErrorN errMsg + throwError (GeneralError errMsg) + _ -> + throwError (GeneralError ("Parsing the extern at: " <> toS fp <> " failed")) + where + version = toS (showVersion P.version) convertExterns :: P.ExternsFile -> ([IdeDeclarationAnn], [(P.ModuleName, P.DeclarationRef)]) convertExterns ef = diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index c07e486d6f..00fefadf6b 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -110,7 +110,7 @@ rebuildModule' MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) = do evalSupplyT nextVar' $ codegen renamed docs exts return exts --- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.json@ file. +-- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file. -- -- If timestamps or hashes have not changed, existing externs files can be used to provide upstream modules' types without -- having to typecheck those modules again. diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 9fbaf6f2c7..1fb4ed52ff 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -42,7 +42,7 @@ import qualified Language.PureScript.CST as CST import qualified Language.PureScript.Docs.Prim as Docs.Prim import qualified Language.PureScript.Docs.Types as Docs import Language.PureScript.Errors -import Language.PureScript.Externs (ExternsFile) +import Language.PureScript.Externs (ExternsFile, externsFileName) import Language.PureScript.Make.Monad import Language.PureScript.Make.Cache import Language.PureScript.Names @@ -177,13 +177,13 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) getOutputTimestamp mn = do codegenTargets <- asks optionsCodegenTargets - let outputPaths = [outputFilename mn "externs.json"] <> fmap (targetFilename mn) (S.toList codegenTargets) + let outputPaths = [outputFilename mn externsFileName] <> fmap (targetFilename mn) (S.toList codegenTargets) timestamps <- traverse getTimestampMaybe outputPaths pure $ fmap minimum . NEL.nonEmpty =<< sequence timestamps readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile) readExterns mn = do - let path = outputDir T.unpack (runModuleName mn) "externs.json" + let path = outputDir T.unpack (runModuleName mn) externsFileName (path, ) <$> readExternsFile path outputPrimDocs :: Make () @@ -195,7 +195,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make () codegen m docs exts = do let mn = CF.moduleName m - lift $ writeJSONFile (outputFilename mn "externs.json") exts + lift $ writeCborFile (outputFilename mn externsFileName) exts codegenTargets <- lift $ asks optionsCodegenTargets when (S.member CoreFn codegenTargets) $ do let coreFnFile = targetFilename mn CoreFn diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index 8050e2e483..cd3fda172d 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -9,16 +9,23 @@ module Language.PureScript.Make.Monad , getTimestampMaybe , readTextFile , readJSONFile + , readJSONFileIO + , readCborFile + , readCborFileIO , readExternsFile , hashFile , writeTextFile , writeJSONFile + , writeCborFile + , writeCborFileIO , copyFile ) where import Prelude -import Control.Exception (tryJust) +import Codec.Serialise (Serialise) +import qualified Codec.Serialise as Serialise +import Control.Exception (fromException, tryJust) import Control.Monad (join, guard) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Error.Class (MonadError(..)) @@ -92,16 +99,31 @@ readTextFile path = -- instance. readJSONFile :: (MonadIO m, MonadError MultipleErrors m) => Aeson.FromJSON a => FilePath -> m (Maybe a) readJSONFile path = - makeIO ("read JSON file: " <> Text.pack path) $ do - r <- catchDoesNotExist $ Aeson.decodeFileStrict' path - return $ join r + makeIO ("read JSON file: " <> Text.pack path) (readJSONFileIO path) + +readJSONFileIO :: Aeson.FromJSON a => FilePath -> IO (Maybe a) +readJSONFileIO path = do + r <- catchDoesNotExist $ Aeson.decodeFileStrict' path + return $ join r + +-- | Read a Cbor encoded file in the 'Make' monad, returning +-- 'Nothing' if the file does not exist or could not be parsed. Errors +-- are captured using the 'MonadError' instance. +readCborFile :: (MonadIO m, MonadError MultipleErrors m) => Serialise a => FilePath -> m (Maybe a) +readCborFile path = + makeIO ("read Binary file: " <> Text.pack path) (readCborFileIO path) + +readCborFileIO :: Serialise a => FilePath -> IO (Maybe a) +readCborFileIO path = do + r <- catchDoesNotExist $ catchDeserialiseFailure $ Serialise.readFileDeserialise path + return (join r) -- | Read an externs file, returning 'Nothing' if the file does not exist, -- could not be parsed, or was generated by a different version of the -- compiler. readExternsFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m (Maybe ExternsFile) readExternsFile path = do - mexterns <- readJSONFile path + mexterns <- readCborFile path return $ do externs <- mexterns guard $ externsIsCurrentVersion externs @@ -123,6 +145,15 @@ catchDoesNotExist inner = do Right x -> return (Just x) +catchDeserialiseFailure :: IO a -> IO (Maybe a) +catchDeserialiseFailure inner = do + r <- tryJust fromException inner + case r of + Left (_ :: Serialise.DeserialiseFailure) -> + return Nothing + Right x -> + return (Just x) + -- | Write a text file in the 'Make' monad, capturing any errors using the -- 'MonadError' instance. writeTextFile :: FilePath -> B.ByteString -> Make () @@ -137,6 +168,15 @@ writeJSONFile path value = makeIO ("write JSON file: " <> Text.pack path) $ do createParentDirectory path Aeson.encodeFile path value +writeCborFile :: (MonadIO m, MonadError MultipleErrors m) => Serialise a => FilePath -> a -> m () +writeCborFile path value = + makeIO ("write Cbor file: " <> Text.pack path) (writeCborFileIO path value) + +writeCborFileIO :: Serialise a => FilePath -> a -> IO () +writeCborFileIO path value = do + createParentDirectory path + Serialise.writeFileSerialise path value + -- | Copy a file in the 'Make' monad, capturing any errors using the -- 'MonadError' instance. copyFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> FilePath -> m () diff --git a/stack.yaml b/stack.yaml index 1c83932f7e..7f405631e7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,6 +5,8 @@ packages: - lib/purescript-ast - lib/purescript-cst extra-deps: +- serialise-0.2.2.0 +- cborg-0.2.2.0 - happy-1.19.9 - language-javascript-0.7.0.0 - network-3.0.1.1 From 3916de11f563841531e7e34d4462b1866b2fb90c Mon Sep 17 00:00:00 2001 From: Cyril Date: Mon, 13 Apr 2020 18:02:04 +0200 Subject: [PATCH 1201/1580] Pretty print errors as warnings in warnings golden tests (#3846) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Pretty print errors as warnings in warnings golden tests * Refer to unexpected errors and warnings as diagnostics in tests * Don’t print unexpected warnings twice * Reuse existing pretty printers for unexpected diagnostics in tests --- tests/TestCompiler.hs | 30 +++++++++---------- tests/purs/warning/2140.out | 4 +-- tests/purs/warning/2411.out | 4 +-- tests/purs/warning/2542.out | 4 +-- tests/purs/warning/CustomWarning.out | 4 +-- tests/purs/warning/CustomWarning2.out | 4 +-- tests/purs/warning/CustomWarning3.out | 8 ++--- tests/purs/warning/CustomWarning4.out | 16 +++++----- tests/purs/warning/DeprecatedFFIPrime.out | 16 +++++----- .../warning/DeprecatedForeignImportKind.out | 4 +-- .../warning/DeprecatedImportExportKinds.out | 12 ++++---- .../purs/warning/DeprecatedRowKindSyntax.out | 4 +-- tests/purs/warning/DuplicateExportRef.out | 28 ++++++++--------- tests/purs/warning/DuplicateImport.out | 4 +-- tests/purs/warning/DuplicateImportRef.out | 16 +++++----- .../purs/warning/DuplicateSelectiveImport.out | 4 +-- tests/purs/warning/HidingImport.out | 8 ++--- tests/purs/warning/ImplicitImport.out | 8 ++--- .../purs/warning/ImplicitQualifiedImport.out | 8 ++--- .../ImplicitQualifiedImportReExport.out | 8 ++--- .../warning/Kind-UnusedExplicitImport-1.out | 4 +-- .../warning/Kind-UnusedExplicitImport-2.out | 4 +-- tests/purs/warning/Kind-UnusedImport.out | 4 +-- tests/purs/warning/MissingKindDeclaration.out | 16 +++++----- tests/purs/warning/MissingTypeDeclaration.out | 4 +-- tests/purs/warning/NewtypeInstance.out | 4 +-- tests/purs/warning/NewtypeInstance2.out | 4 +-- tests/purs/warning/NewtypeInstance3.out | 4 +-- tests/purs/warning/NewtypeInstance4.out | 4 +-- tests/purs/warning/OverlappingPattern.out | 8 ++--- tests/purs/warning/ScopeShadowing.out | 4 +-- tests/purs/warning/ScopeShadowing2.out | 4 +-- .../warning/ShadowedBinderPatternGuard.out | 4 +-- tests/purs/warning/ShadowedNameParens.out | 4 +-- tests/purs/warning/ShadowedTypeVar.out | 4 +-- .../warning/UnambiguousQuantifiedKind.out | 4 +-- tests/purs/warning/UnnecessaryFFIModule.out | 4 +-- .../warning/UnusedDctorExplicitImport.out | 4 +-- tests/purs/warning/UnusedDctorImportAll.out | 4 +-- .../warning/UnusedDctorImportExplicit.out | 4 +-- tests/purs/warning/UnusedExplicitImport.out | 4 +-- .../warning/UnusedExplicitImportTypeOp.out | 4 +-- .../warning/UnusedExplicitImportValOp.out | 4 +-- .../purs/warning/UnusedFFIImplementations.out | 4 +-- tests/purs/warning/UnusedImport.out | 8 ++--- tests/purs/warning/UnusedTypeVar.out | 4 +-- tests/purs/warning/WildcardInferredType.out | 8 ++--- tests/purs/warning/WildcardInferredType2.out | 4 +-- 48 files changed, 164 insertions(+), 166 deletions(-) diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 183b5b67c5..46502077da 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -121,14 +121,14 @@ failingTests supportModules supportExterns supportForeigns = do ] return $ testGroup "Failing examples" $ concat tests -checkShouldFailWith :: [String] -> P.MultipleErrors -> Maybe String -checkShouldFailWith expected errs = +checkShouldReport :: [String] -> (P.MultipleErrors -> String) -> P.MultipleErrors -> Maybe String +checkShouldReport expected prettyPrintDiagnostics errs = let actual = map P.errorCode $ P.runMultipleErrors errs in if sort expected == sort (map T.unpack actual) then checkPositioned errs - else Just $ "Expected these errors: " ++ show expected ++ ", but got these: " - ++ show actual ++ ", full error messages: \n" - ++ unlines (map (P.renderBox . P.prettyPrintSingleError P.defaultPPEOptions) (P.runMultipleErrors errs)) + else Just $ "Expected these diagnostics: " ++ show expected ++ ", but got these: " + ++ show actual ++ ", full diagnostic messages: \n" + ++ prettyPrintDiagnostics errs checkPositioned :: P.MultipleErrors -> Maybe String checkPositioned errs = @@ -137,7 +137,7 @@ checkPositioned errs = Nothing errs' -> Just - $ "Found errors with missing source spans:\n" + $ "Found diagnostics with missing source spans:\n" ++ unlines (map (P.renderBox . P.prettyPrintSingleError P.defaultPPEOptions) errs') where guardSpans :: P.ErrorMessage -> Maybe P.ErrorMessage @@ -192,13 +192,7 @@ assertCompilesWithWarnings supportModules supportExterns supportForeigns inputFi Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right warnings -> - return - . fmap (printAllWarnings warnings) - $ checkShouldFailWith shouldWarnWith warnings - - where - printAllWarnings warnings = - (<> "\n\n" <> P.prettyPrintMultipleErrors P.defaultPPEOptions warnings) + return $ checkShouldReport shouldWarnWith (P.prettyPrintMultipleWarnings P.defaultPPEOptions) warnings assertDoesNotCompile :: [P.Module] @@ -215,7 +209,7 @@ assertDoesNotCompile supportModules supportExterns supportForeigns inputFiles sh then Just $ "shouldFailWith declaration is missing (errors were: " ++ show (map P.errorCode (P.runMultipleErrors errs)) ++ ")" - else checkShouldFailWith shouldFailWith errs + else checkShouldReport shouldFailWith (P.prettyPrintMultipleErrors P.defaultPPEOptions) errs Right _ -> return $ Just "Should not have compiled" @@ -230,8 +224,12 @@ printErrorOrWarning -> IO String printErrorOrWarning supportModules supportExterns supportForeigns inputFiles = do -- Sorting the input files makes some messages (e.g., duplicate module) deterministic - (e, w) <- compile supportModules supportExterns supportForeigns (sort inputFiles) noPreCheck - return $ normalizePaths . P.prettyPrintMultipleErrors P.defaultPPEOptions $ either id (const w) e + (res, warnings) <- compile supportModules supportExterns supportForeigns (sort inputFiles) noPreCheck + return . normalizePaths $ case res of + Left errs -> + P.prettyPrintMultipleErrors P.defaultPPEOptions errs + Right _ -> + P.prettyPrintMultipleWarnings P.defaultPPEOptions warnings where noPreCheck = const (return ()) diff --git a/tests/purs/warning/2140.out b/tests/purs/warning/2140.out index 9de35dd2b7..70b7e49701 100644 --- a/tests/purs/warning/2140.out +++ b/tests/purs/warning/2140.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/2140.purs:5:3 - 5:36 (line 5, column 3 - line 5, column 36) @@ -8,5 +8,5 @@ in type declaration for f in type class declaration for Test See https://github.com/purescript/documentation/blob/master/errors/ShadowedTypeVar.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/2411.out b/tests/purs/warning/2411.out index 796505c5c5..ee60f0d0d7 100644 --- a/tests/purs/warning/2411.out +++ b/tests/purs/warning/2411.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/2411.purs:10:7 - 10:15 (line 10, column 7 - line 10, column 15) @@ -7,5 +7,5 @@ at tests/purs/warning/2411.purs:10:7 - 10:15 (line 10, column 7 - line 10, colum in value declaration test See https://github.com/purescript/documentation/blob/master/errors/ShadowedName.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/2542.out b/tests/purs/warning/2542.out index 340bc3dbb0..1b0cef80a1 100644 --- a/tests/purs/warning/2542.out +++ b/tests/purs/warning/2542.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/2542.purs:16:1 - 16:18 (line 16, column 1 - line 16, column 18) @@ -12,5 +12,5 @@ at tests/purs/warning/2542.purs:16:1 - 16:18 (line 16, column 1 - line 16, colum in value declaration main See https://github.com/purescript/documentation/blob/master/errors/MissingTypeDeclaration.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/CustomWarning.out b/tests/purs/warning/CustomWarning.out index 9b0fd1f884..abb5b70854 100644 --- a/tests/purs/warning/CustomWarning.out +++ b/tests/purs/warning/CustomWarning.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/CustomWarning.purs:9:1 - 9:11 (line 9, column 1 - line 9, column 11) @@ -10,5 +10,5 @@ at tests/purs/warning/CustomWarning.purs:9:1 - 9:11 (line 9, column 1 - line 9, in value declaration bar See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/CustomWarning2.out b/tests/purs/warning/CustomWarning2.out index 938cc3a6b5..e0031502c1 100644 --- a/tests/purs/warning/CustomWarning2.out +++ b/tests/purs/warning/CustomWarning2.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/CustomWarning2.purs:12:1 - 12:11 (line 12, column 1 - line 12, column 11) @@ -10,5 +10,5 @@ at tests/purs/warning/CustomWarning2.purs:12:1 - 12:11 (line 12, column 1 - line in value declaration baz See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/CustomWarning3.out b/tests/purs/warning/CustomWarning3.out index 75d151064d..79c49af880 100644 --- a/tests/purs/warning/CustomWarning3.out +++ b/tests/purs/warning/CustomWarning3.out @@ -1,4 +1,4 @@ -Error 1 of 2: +Warning 1 of 2: in module Main at tests/purs/warning/CustomWarning3.purs:14:1 - 14:11 (line 14, column 1 - line 14, column 11) @@ -11,9 +11,9 @@ Error 1 of 2: in value declaration baz See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 2 of 2: +Warning 2 of 2: in module Main at tests/purs/warning/CustomWarning3.purs:14:1 - 14:11 (line 14, column 1 - line 14, column 11) @@ -26,5 +26,5 @@ Error 2 of 2: in value declaration baz See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. diff --git a/tests/purs/warning/CustomWarning4.out b/tests/purs/warning/CustomWarning4.out index ea2e306962..1ecaa3f548 100644 --- a/tests/purs/warning/CustomWarning4.out +++ b/tests/purs/warning/CustomWarning4.out @@ -1,4 +1,4 @@ -Error 1 of 4: +Warning 1 of 4: in module Main at tests/purs/warning/CustomWarning4.purs:21:1 - 21:15 (line 21, column 1 - line 21, column 15) @@ -11,9 +11,9 @@ Error 1 of 4: in value declaration baz' See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 2 of 4: +Warning 2 of 4: in module Main at tests/purs/warning/CustomWarning4.purs:24:1 - 24:16 (line 24, column 1 - line 24, column 16) @@ -26,9 +26,9 @@ Error 2 of 4: in value declaration baz'' See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 3 of 4: +Warning 3 of 4: in module Main at tests/purs/warning/CustomWarning4.purs:27:1 - 27:17 (line 27, column 1 - line 27, column 17) @@ -41,9 +41,9 @@ Error 3 of 4: in value declaration baz''' See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 4 of 4: +Warning 4 of 4: in module Main at tests/purs/warning/CustomWarning4.purs:30:1 - 30:18 (line 30, column 1 - line 30, column 18) @@ -56,5 +56,5 @@ Error 4 of 4: in value declaration baz'''' See https://github.com/purescript/documentation/blob/master/errors/UserDefinedWarning.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. diff --git a/tests/purs/warning/DeprecatedFFIPrime.out b/tests/purs/warning/DeprecatedFFIPrime.out index 893228ea45..94e1912e92 100644 --- a/tests/purs/warning/DeprecatedFFIPrime.out +++ b/tests/purs/warning/DeprecatedFFIPrime.out @@ -1,4 +1,4 @@ -Error 1 of 4: +Warning 1 of 4: at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) @@ -10,9 +10,9 @@ Error 1 of 4: See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 2 of 4: +Warning 2 of 4: at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) @@ -24,9 +24,9 @@ Error 2 of 4: See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 3 of 4: +Warning 3 of 4: at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) @@ -38,9 +38,9 @@ Error 3 of 4: See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 4 of 4: +Warning 4 of 4: at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) @@ -52,5 +52,5 @@ Error 4 of 4: See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. diff --git a/tests/purs/warning/DeprecatedForeignImportKind.out b/tests/purs/warning/DeprecatedForeignImportKind.out index 5f840f7a42..c0305a48f6 100644 --- a/tests/purs/warning/DeprecatedForeignImportKind.out +++ b/tests/purs/warning/DeprecatedForeignImportKind.out @@ -1,9 +1,9 @@ -Error found: +Warning found: at tests/purs/warning/DeprecatedForeignImportKind.purs:4:1 - 4:24 (line 4, column 1 - line 4, column 24) Foreign kind imports are deprecated and will be removed in a future release. Use empty 'data' instead. See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/DeprecatedImportExportKinds.out b/tests/purs/warning/DeprecatedImportExportKinds.out index 9a1ece0306..d9ae23028d 100644 --- a/tests/purs/warning/DeprecatedImportExportKinds.out +++ b/tests/purs/warning/DeprecatedImportExportKinds.out @@ -1,4 +1,4 @@ -Error 1 of 3: +Warning 1 of 3: at tests/purs/warning/DeprecatedImportExportKinds.purs:6:13 - 6:21 (line 6, column 13 - line 6, column 21) @@ -6,9 +6,9 @@ Error 1 of 3: See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 2 of 3: +Warning 2 of 3: at tests/purs/warning/DeprecatedImportExportKinds/Lib.purs:5:1 - 5:24 (line 5, column 1 - line 5, column 24) @@ -16,9 +16,9 @@ Error 2 of 3: See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 3 of 3: +Warning 3 of 3: at tests/purs/warning/DeprecatedImportExportKinds/Lib.purs:2:5 - 2:13 (line 2, column 5 - line 2, column 13) @@ -26,5 +26,5 @@ Error 3 of 3: See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. diff --git a/tests/purs/warning/DeprecatedRowKindSyntax.out b/tests/purs/warning/DeprecatedRowKindSyntax.out index 4cc108c290..f0591ff448 100644 --- a/tests/purs/warning/DeprecatedRowKindSyntax.out +++ b/tests/purs/warning/DeprecatedRowKindSyntax.out @@ -1,9 +1,9 @@ -Error found: +Warning found: at tests/purs/warning/DeprecatedRowKindSyntax.purs:4:15 - 4:21 (line 4, column 15 - line 4, column 21) Unary '#' syntax for row kinds is deprecated and will be removed in a future release. Use the 'Row' kind instead. See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/DuplicateExportRef.out b/tests/purs/warning/DuplicateExportRef.out index 649b5c06ea..ee67bd3275 100644 --- a/tests/purs/warning/DuplicateExportRef.out +++ b/tests/purs/warning/DuplicateExportRef.out @@ -1,4 +1,4 @@ -Error 1 of 7: +Warning 1 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) @@ -7,9 +7,9 @@ Error 1 of 7: See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 2 of 7: +Warning 2 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) @@ -18,9 +18,9 @@ Error 2 of 7: See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 3 of 7: +Warning 3 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) @@ -29,9 +29,9 @@ Error 3 of 7: See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 4 of 7: +Warning 4 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) @@ -40,9 +40,9 @@ Error 4 of 7: See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 5 of 7: +Warning 5 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) @@ -51,9 +51,9 @@ Error 5 of 7: See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 6 of 7: +Warning 6 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) @@ -62,9 +62,9 @@ Error 6 of 7: See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 7 of 7: +Warning 7 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) @@ -73,5 +73,5 @@ Error 7 of 7: See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. diff --git a/tests/purs/warning/DuplicateImport.out b/tests/purs/warning/DuplicateImport.out index 089403fb97..916acf1d2b 100644 --- a/tests/purs/warning/DuplicateImport.out +++ b/tests/purs/warning/DuplicateImport.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/DuplicateImport.purs:5:1 - 5:34 (line 5, column 1 - line 5, column 34) @@ -6,5 +6,5 @@ at tests/purs/warning/DuplicateImport.purs:5:1 - 5:34 (line 5, column 1 - line 5 See https://github.com/purescript/documentation/blob/master/errors/DuplicateImport.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/DuplicateImportRef.out b/tests/purs/warning/DuplicateImportRef.out index e361bc5894..1ae248536c 100644 --- a/tests/purs/warning/DuplicateImportRef.out +++ b/tests/purs/warning/DuplicateImportRef.out @@ -1,4 +1,4 @@ -Error 1 of 4: +Warning 1 of 4: in module Main at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) @@ -7,9 +7,9 @@ Error 1 of 4: See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 2 of 4: +Warning 2 of 4: in module Main at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) @@ -18,9 +18,9 @@ Error 2 of 4: See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 3 of 4: +Warning 3 of 4: in module Main at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) @@ -29,9 +29,9 @@ Error 3 of 4: See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 4 of 4: +Warning 4 of 4: in module Main at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) @@ -40,5 +40,5 @@ Error 4 of 4: See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. diff --git a/tests/purs/warning/DuplicateSelectiveImport.out b/tests/purs/warning/DuplicateSelectiveImport.out index 3acb83ee71..3e0aef6609 100644 --- a/tests/purs/warning/DuplicateSelectiveImport.out +++ b/tests/purs/warning/DuplicateSelectiveImport.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/DuplicateSelectiveImport.purs:5:1 - 5:22 (line 5, column 1 - line 5, column 22) @@ -6,5 +6,5 @@ at tests/purs/warning/DuplicateSelectiveImport.purs:5:1 - 5:22 (line 5, column 1 See https://github.com/purescript/documentation/blob/master/errors/DuplicateSelectiveImport.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/HidingImport.out b/tests/purs/warning/HidingImport.out index c66ab99ff5..68171c403b 100644 --- a/tests/purs/warning/HidingImport.out +++ b/tests/purs/warning/HidingImport.out @@ -1,4 +1,4 @@ -Error 1 of 2: +Warning 1 of 2: in module Main at tests/purs/warning/HidingImport.purs:6:1 - 6:30 (line 6, column 1 - line 6, column 30) @@ -10,9 +10,9 @@ Error 1 of 2: See https://github.com/purescript/documentation/blob/master/errors/HidingImport.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 2 of 2: +Warning 2 of 2: in module Main at tests/purs/warning/HidingImport.purs:5:1 - 5:28 (line 5, column 1 - line 5, column 28) @@ -24,5 +24,5 @@ Error 2 of 2: See https://github.com/purescript/documentation/blob/master/errors/HidingImport.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. diff --git a/tests/purs/warning/ImplicitImport.out b/tests/purs/warning/ImplicitImport.out index 79326fe44f..e61062fba6 100644 --- a/tests/purs/warning/ImplicitImport.out +++ b/tests/purs/warning/ImplicitImport.out @@ -1,4 +1,4 @@ -Error 1 of 2: +Warning 1 of 2: in module Main at tests/purs/warning/ImplicitImport.purs:6:1 - 6:14 (line 6, column 1 - line 6, column 14) @@ -10,9 +10,9 @@ Error 1 of 2: See https://github.com/purescript/documentation/blob/master/errors/ImplicitImport.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 2 of 2: +Warning 2 of 2: in module Main at tests/purs/warning/ImplicitImport.purs:5:1 - 5:15 (line 5, column 1 - line 5, column 15) @@ -24,5 +24,5 @@ Error 2 of 2: See https://github.com/purescript/documentation/blob/master/errors/ImplicitImport.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. diff --git a/tests/purs/warning/ImplicitQualifiedImport.out b/tests/purs/warning/ImplicitQualifiedImport.out index b85569c87e..5e8002671e 100644 --- a/tests/purs/warning/ImplicitQualifiedImport.out +++ b/tests/purs/warning/ImplicitQualifiedImport.out @@ -1,4 +1,4 @@ -Error 1 of 2: +Warning 1 of 2: in module Main at tests/purs/warning/ImplicitQualifiedImport.purs:7:1 - 7:19 (line 7, column 1 - line 7, column 19) @@ -11,9 +11,9 @@ Error 1 of 2: See https://github.com/purescript/documentation/blob/master/errors/ImplicitQualifiedImport.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 2 of 2: +Warning 2 of 2: in module Main at tests/purs/warning/ImplicitQualifiedImport.purs:8:1 - 8:27 (line 8, column 1 - line 8, column 27) @@ -26,5 +26,5 @@ Error 2 of 2: See https://github.com/purescript/documentation/blob/master/errors/ImplicitQualifiedImport.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. diff --git a/tests/purs/warning/ImplicitQualifiedImportReExport.out b/tests/purs/warning/ImplicitQualifiedImportReExport.out index 30b19933f1..bb1f46586f 100644 --- a/tests/purs/warning/ImplicitQualifiedImportReExport.out +++ b/tests/purs/warning/ImplicitQualifiedImportReExport.out @@ -1,4 +1,4 @@ -Error 1 of 2: +Warning 1 of 2: in module Main at tests/purs/warning/ImplicitQualifiedImportReExport.purs:9:1 - 9:23 (line 9, column 1 - line 9, column 23) @@ -11,9 +11,9 @@ Error 1 of 2: See https://github.com/purescript/documentation/blob/master/errors/ImplicitQualifiedImportReExport.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 2 of 2: +Warning 2 of 2: in module Main at tests/purs/warning/ImplicitQualifiedImportReExport.purs:10:1 - 10:24 (line 10, column 1 - line 10, column 24) @@ -26,5 +26,5 @@ Error 2 of 2: See https://github.com/purescript/documentation/blob/master/errors/ImplicitQualifiedImportReExport.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. diff --git a/tests/purs/warning/Kind-UnusedExplicitImport-1.out b/tests/purs/warning/Kind-UnusedExplicitImport-1.out index e969f3f52c..064f3ee477 100644 --- a/tests/purs/warning/Kind-UnusedExplicitImport-1.out +++ b/tests/purs/warning/Kind-UnusedExplicitImport-1.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/Kind-UnusedExplicitImport-1.purs:6:1 - 6:39 (line 6, column 1 - line 6, column 39) @@ -13,5 +13,5 @@ at tests/purs/warning/Kind-UnusedExplicitImport-1.purs:6:1 - 6:39 (line 6, colum See https://github.com/purescript/documentation/blob/master/errors/UnusedExplicitImport.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/Kind-UnusedExplicitImport-2.out b/tests/purs/warning/Kind-UnusedExplicitImport-2.out index 7edd8ffdd1..cad43190b8 100644 --- a/tests/purs/warning/Kind-UnusedExplicitImport-2.out +++ b/tests/purs/warning/Kind-UnusedExplicitImport-2.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/Kind-UnusedExplicitImport-2.purs:6:1 - 6:39 (line 6, column 1 - line 6, column 39) @@ -13,5 +13,5 @@ at tests/purs/warning/Kind-UnusedExplicitImport-2.purs:6:1 - 6:39 (line 6, colum See https://github.com/purescript/documentation/blob/master/errors/UnusedExplicitImport.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/Kind-UnusedImport.out b/tests/purs/warning/Kind-UnusedImport.out index f6a0d54f18..df1908494c 100644 --- a/tests/purs/warning/Kind-UnusedImport.out +++ b/tests/purs/warning/Kind-UnusedImport.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/Kind-UnusedImport.purs:6:1 - 6:30 (line 6, column 1 - line 6, column 30) @@ -6,5 +6,5 @@ at tests/purs/warning/Kind-UnusedImport.purs:6:1 - 6:30 (line 6, column 1 - line See https://github.com/purescript/documentation/blob/master/errors/UnusedImport.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/MissingKindDeclaration.out b/tests/purs/warning/MissingKindDeclaration.out index 997fc5d473..5174fcff24 100644 --- a/tests/purs/warning/MissingKindDeclaration.out +++ b/tests/purs/warning/MissingKindDeclaration.out @@ -1,4 +1,4 @@ -Error 1 of 4: +Warning 1 of 4: in module Main at tests/purs/warning/MissingKindDeclaration.purs:7:1 - 7:21 (line 7, column 1 - line 7, column 21) @@ -12,9 +12,9 @@ Error 1 of 4: in type constructor Proxy See https://github.com/purescript/documentation/blob/master/errors/MissingKindDeclaration.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 2 of 4: +Warning 2 of 4: in module Main at tests/purs/warning/MissingKindDeclaration.purs:11:1 - 11:40 (line 11, column 1 - line 11, column 40) @@ -28,9 +28,9 @@ Error 2 of 4: in type synonym Natural See https://github.com/purescript/documentation/blob/master/errors/MissingKindDeclaration.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 3 of 4: +Warning 3 of 4: in module Main at tests/purs/warning/MissingKindDeclaration.purs:9:1 - 9:20 (line 9, column 1 - line 9, column 20) @@ -44,9 +44,9 @@ Error 3 of 4: in type constructor F See https://github.com/purescript/documentation/blob/master/errors/MissingKindDeclaration.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 4 of 4: +Warning 4 of 4: in module Main at tests/purs/warning/MissingKindDeclaration.purs:13:1 - 13:18 (line 13, column 1 - line 13, column 18) @@ -60,5 +60,5 @@ Error 4 of 4: in type class declaration for Clazz See https://github.com/purescript/documentation/blob/master/errors/MissingKindDeclaration.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. diff --git a/tests/purs/warning/MissingTypeDeclaration.out b/tests/purs/warning/MissingTypeDeclaration.out index 22aa2b1c55..add92fa0c7 100644 --- a/tests/purs/warning/MissingTypeDeclaration.out +++ b/tests/purs/warning/MissingTypeDeclaration.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/MissingTypeDeclaration.purs:4:1 - 4:6 (line 4, column 1 - line 4, column 6) @@ -12,5 +12,5 @@ at tests/purs/warning/MissingTypeDeclaration.purs:4:1 - 4:6 (line 4, column 1 - in value declaration x See https://github.com/purescript/documentation/blob/master/errors/MissingTypeDeclaration.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/NewtypeInstance.out b/tests/purs/warning/NewtypeInstance.out index e42f4cc9c4..72c32ddb3c 100644 --- a/tests/purs/warning/NewtypeInstance.out +++ b/tests/purs/warning/NewtypeInstance.out @@ -1,4 +1,4 @@ -Error found: +Warning found: at tests/purs/warning/NewtypeInstance.purs:8:1 - 8:38 (line 8, column 1 - line 8, column 38) The derived newtype instance for @@ -9,5 +9,5 @@ at tests/purs/warning/NewtypeInstance.purs:8:1 - 8:38 (line 8, column 1 - line 8 See https://github.com/purescript/documentation/blob/master/errors/MissingNewtypeSuperclassInstance.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/NewtypeInstance2.out b/tests/purs/warning/NewtypeInstance2.out index e781d97f75..8f6eed3101 100644 --- a/tests/purs/warning/NewtypeInstance2.out +++ b/tests/purs/warning/NewtypeInstance2.out @@ -1,4 +1,4 @@ -Error found: +Warning found: at tests/purs/warning/NewtypeInstance2.purs:15:1 - 15:86 (line 15, column 1 - line 15, column 86) The derived newtype instance for @@ -10,5 +10,5 @@ at tests/purs/warning/NewtypeInstance2.purs:15:1 - 15:86 (line 15, column 1 - li See https://github.com/purescript/documentation/blob/master/errors/MissingNewtypeSuperclassInstance.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/NewtypeInstance3.out b/tests/purs/warning/NewtypeInstance3.out index 5a7cad6a0d..7c8a7e79c6 100644 --- a/tests/purs/warning/NewtypeInstance3.out +++ b/tests/purs/warning/NewtypeInstance3.out @@ -1,4 +1,4 @@ -Error found: +Warning found: at tests/purs/warning/NewtypeInstance3.purs:21:1 - 21:86 (line 21, column 1 - line 21, column 86) The derived newtype instance for @@ -10,5 +10,5 @@ at tests/purs/warning/NewtypeInstance3.purs:21:1 - 21:86 (line 21, column 1 - li See https://github.com/purescript/documentation/blob/master/errors/MissingNewtypeSuperclassInstance.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/NewtypeInstance4.out b/tests/purs/warning/NewtypeInstance4.out index ebf2d4b882..9874bf408a 100644 --- a/tests/purs/warning/NewtypeInstance4.out +++ b/tests/purs/warning/NewtypeInstance4.out @@ -1,4 +1,4 @@ -Error found: +Warning found: at tests/purs/warning/NewtypeInstance4.purs:23:1 - 23:86 (line 23, column 1 - line 23, column 86) The derived newtype instance for @@ -10,5 +10,5 @@ at tests/purs/warning/NewtypeInstance4.purs:23:1 - 23:86 (line 23, column 1 - li See https://github.com/purescript/documentation/blob/master/errors/UnverifiableSuperclassInstance.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/OverlappingPattern.out b/tests/purs/warning/OverlappingPattern.out index 48534b5de3..b5fb9ecd72 100644 --- a/tests/purs/warning/OverlappingPattern.out +++ b/tests/purs/warning/OverlappingPattern.out @@ -1,4 +1,4 @@ -Error 1 of 2: +Warning 1 of 2: in module Main at tests/purs/warning/OverlappingPattern.purs:12:1 - 12:21 (line 12, column 1 - line 12, column 21) @@ -10,9 +10,9 @@ Error 1 of 2: in value declaration pat2 See https://github.com/purescript/documentation/blob/master/errors/OverlappingPattern.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 2 of 2: +Warning 2 of 2: in module Main at tests/purs/warning/OverlappingPattern.purs:7:1 - 7:21 (line 7, column 1 - line 7, column 21) @@ -24,5 +24,5 @@ Error 2 of 2: in value declaration pat1 See https://github.com/purescript/documentation/blob/master/errors/OverlappingPattern.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. diff --git a/tests/purs/warning/ScopeShadowing.out b/tests/purs/warning/ScopeShadowing.out index 5c0f99763c..b3042062b2 100644 --- a/tests/purs/warning/ScopeShadowing.out +++ b/tests/purs/warning/ScopeShadowing.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/ScopeShadowing.purs:4:1 - 4:15 (line 4, column 1 - line 4, column 15) @@ -10,5 +10,5 @@ at tests/purs/warning/ScopeShadowing.purs:4:1 - 4:15 (line 4, column 1 - line 4, See https://github.com/purescript/documentation/blob/master/errors/ScopeShadowing.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/ScopeShadowing2.out b/tests/purs/warning/ScopeShadowing2.out index 5bb1bf07ca..366d459216 100644 --- a/tests/purs/warning/ScopeShadowing2.out +++ b/tests/purs/warning/ScopeShadowing2.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/ScopeShadowing2.purs:7:1 - 7:22 (line 7, column 1 - line 7, column 22) @@ -10,5 +10,5 @@ at tests/purs/warning/ScopeShadowing2.purs:7:1 - 7:22 (line 7, column 1 - line 7 See https://github.com/purescript/documentation/blob/master/errors/ScopeShadowing.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/ShadowedBinderPatternGuard.out b/tests/purs/warning/ShadowedBinderPatternGuard.out index 8ae2dfd83e..b3918f5358 100644 --- a/tests/purs/warning/ShadowedBinderPatternGuard.out +++ b/tests/purs/warning/ShadowedBinderPatternGuard.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/ShadowedBinderPatternGuard.purs:6:7 - 6:8 (line 6, column 7 - line 6, column 8) @@ -7,5 +7,5 @@ at tests/purs/warning/ShadowedBinderPatternGuard.purs:6:7 - 6:8 (line 6, column in value declaration f See https://github.com/purescript/documentation/blob/master/errors/ShadowedName.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/ShadowedNameParens.out b/tests/purs/warning/ShadowedNameParens.out index 4864b84ff3..6c879e9933 100644 --- a/tests/purs/warning/ShadowedNameParens.out +++ b/tests/purs/warning/ShadowedNameParens.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/ShadowedNameParens.purs:5:9 - 5:10 (line 5, column 9 - line 5, column 10) @@ -7,5 +7,5 @@ at tests/purs/warning/ShadowedNameParens.purs:5:9 - 5:10 (line 5, column 9 - lin in value declaration f See https://github.com/purescript/documentation/blob/master/errors/ShadowedName.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/ShadowedTypeVar.out b/tests/purs/warning/ShadowedTypeVar.out index b2a01fea7d..56236409c4 100644 --- a/tests/purs/warning/ShadowedTypeVar.out +++ b/tests/purs/warning/ShadowedTypeVar.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/ShadowedTypeVar.purs:4:1 - 4:44 (line 4, column 1 - line 4, column 44) @@ -7,5 +7,5 @@ at tests/purs/warning/ShadowedTypeVar.purs:4:1 - 4:44 (line 4, column 1 - line 4 in type declaration for f See https://github.com/purescript/documentation/blob/master/errors/ShadowedTypeVar.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/UnambiguousQuantifiedKind.out b/tests/purs/warning/UnambiguousQuantifiedKind.out index c3048a18e6..d3b70ea42e 100644 --- a/tests/purs/warning/UnambiguousQuantifiedKind.out +++ b/tests/purs/warning/UnambiguousQuantifiedKind.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/UnambiguousQuantifiedKind.purs:12:1 - 12:11 (line 12, column 1 - line 12, column 11) @@ -12,5 +12,5 @@ at tests/purs/warning/UnambiguousQuantifiedKind.purs:12:1 - 12:11 (line 12, colu in value declaration test2 See https://github.com/purescript/documentation/blob/master/errors/MissingTypeDeclaration.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/UnnecessaryFFIModule.out b/tests/purs/warning/UnnecessaryFFIModule.out index 1399274611..d6bb02e5e9 100644 --- a/tests/purs/warning/UnnecessaryFFIModule.out +++ b/tests/purs/warning/UnnecessaryFFIModule.out @@ -1,4 +1,4 @@ -Error found: +Warning found: at tests/purs/warning/UnnecessaryFFIModule.purs:2:1 - 5:9 (line 2, column 1 - line 5, column 9) An unnecessary foreign module implementation was provided for module Main: @@ -9,5 +9,5 @@ at tests/purs/warning/UnnecessaryFFIModule.purs:2:1 - 5:9 (line 2, column 1 - li See https://github.com/purescript/documentation/blob/master/errors/UnnecessaryFFIModule.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/UnusedDctorExplicitImport.out b/tests/purs/warning/UnusedDctorExplicitImport.out index 8fc0fccce4..ada78634da 100644 --- a/tests/purs/warning/UnusedDctorExplicitImport.out +++ b/tests/purs/warning/UnusedDctorExplicitImport.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/UnusedDctorExplicitImport.purs:4:1 - 4:40 (line 4, column 1 - line 4, column 40) @@ -13,5 +13,5 @@ at tests/purs/warning/UnusedDctorExplicitImport.purs:4:1 - 4:40 (line 4, column See https://github.com/purescript/documentation/blob/master/errors/UnusedDctorExplicitImport.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/UnusedDctorImportAll.out b/tests/purs/warning/UnusedDctorImportAll.out index b22de09b8d..b14586f2a9 100644 --- a/tests/purs/warning/UnusedDctorImportAll.out +++ b/tests/purs/warning/UnusedDctorImportAll.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/UnusedDctorImportAll.purs:4:1 - 4:36 (line 4, column 1 - line 4, column 36) @@ -10,5 +10,5 @@ at tests/purs/warning/UnusedDctorImportAll.purs:4:1 - 4:36 (line 4, column 1 - l See https://github.com/purescript/documentation/blob/master/errors/UnusedDctorImport.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/UnusedDctorImportExplicit.out b/tests/purs/warning/UnusedDctorImportExplicit.out index a2acb53b26..b03955cafa 100644 --- a/tests/purs/warning/UnusedDctorImportExplicit.out +++ b/tests/purs/warning/UnusedDctorImportExplicit.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/UnusedDctorImportExplicit.purs:4:1 - 4:36 (line 4, column 1 - line 4, column 36) @@ -10,5 +10,5 @@ at tests/purs/warning/UnusedDctorImportExplicit.purs:4:1 - 4:36 (line 4, column See https://github.com/purescript/documentation/blob/master/errors/UnusedDctorImport.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/UnusedExplicitImport.out b/tests/purs/warning/UnusedExplicitImport.out index ac0a868b36..622704dad0 100644 --- a/tests/purs/warning/UnusedExplicitImport.out +++ b/tests/purs/warning/UnusedExplicitImport.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/UnusedExplicitImport.purs:4:1 - 4:40 (line 4, column 1 - line 4, column 40) @@ -13,5 +13,5 @@ at tests/purs/warning/UnusedExplicitImport.purs:4:1 - 4:40 (line 4, column 1 - l See https://github.com/purescript/documentation/blob/master/errors/UnusedExplicitImport.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/UnusedExplicitImportTypeOp.out b/tests/purs/warning/UnusedExplicitImportTypeOp.out index 5f2686d4fa..25dea28ea9 100644 --- a/tests/purs/warning/UnusedExplicitImportTypeOp.out +++ b/tests/purs/warning/UnusedExplicitImportTypeOp.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/UnusedExplicitImportTypeOp.purs:6:1 - 6:30 (line 6, column 1 - line 6, column 30) @@ -13,5 +13,5 @@ at tests/purs/warning/UnusedExplicitImportTypeOp.purs:6:1 - 6:30 (line 6, column See https://github.com/purescript/documentation/blob/master/errors/UnusedExplicitImport.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/UnusedExplicitImportValOp.out b/tests/purs/warning/UnusedExplicitImportValOp.out index a629b72ebf..3291c06a39 100644 --- a/tests/purs/warning/UnusedExplicitImportValOp.out +++ b/tests/purs/warning/UnusedExplicitImportValOp.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/UnusedExplicitImportValOp.purs:4:1 - 4:39 (line 4, column 1 - line 4, column 39) @@ -13,5 +13,5 @@ at tests/purs/warning/UnusedExplicitImportValOp.purs:4:1 - 4:39 (line 4, column See https://github.com/purescript/documentation/blob/master/errors/UnusedExplicitImport.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/UnusedFFIImplementations.out b/tests/purs/warning/UnusedFFIImplementations.out index 32b024c69b..10cfa2df62 100644 --- a/tests/purs/warning/UnusedFFIImplementations.out +++ b/tests/purs/warning/UnusedFFIImplementations.out @@ -1,4 +1,4 @@ -Error found: +Warning found: at tests/purs/warning/UnusedFFIImplementations.purs:2:1 - 4:30 (line 2, column 1 - line 4, column 30) The following definitions in the foreign module for module Main are unused: @@ -8,5 +8,5 @@ at tests/purs/warning/UnusedFFIImplementations.purs:2:1 - 4:30 (line 2, column 1 See https://github.com/purescript/documentation/blob/master/errors/UnusedFFIImplementations.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/UnusedImport.out b/tests/purs/warning/UnusedImport.out index c1138dacd7..7bc07c0392 100644 --- a/tests/purs/warning/UnusedImport.out +++ b/tests/purs/warning/UnusedImport.out @@ -1,4 +1,4 @@ -Error 1 of 2: +Warning 1 of 2: in module Main at tests/purs/warning/UnusedImport.purs:8:1 - 8:14 (line 8, column 1 - line 8, column 14) @@ -7,9 +7,9 @@ Error 1 of 2: See https://github.com/purescript/documentation/blob/master/errors/UnusedImport.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 2 of 2: +Warning 2 of 2: in module Main at tests/purs/warning/UnusedImport.purs:9:1 - 9:33 (line 9, column 1 - line 9, column 33) @@ -18,5 +18,5 @@ Error 2 of 2: See https://github.com/purescript/documentation/blob/master/errors/UnusedImport.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. diff --git a/tests/purs/warning/UnusedTypeVar.out b/tests/purs/warning/UnusedTypeVar.out index 9e8ca511cd..8222b07cbd 100644 --- a/tests/purs/warning/UnusedTypeVar.out +++ b/tests/purs/warning/UnusedTypeVar.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/UnusedTypeVar.purs:4:1 - 4:24 (line 4, column 1 - line 4, column 24) @@ -7,5 +7,5 @@ at tests/purs/warning/UnusedTypeVar.purs:4:1 - 4:24 (line 4, column 1 - line 4, in type declaration for f See https://github.com/purescript/documentation/blob/master/errors/UnusedTypeVar.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. diff --git a/tests/purs/warning/WildcardInferredType.out b/tests/purs/warning/WildcardInferredType.out index bcbceb452f..91aabf9a1e 100644 --- a/tests/purs/warning/WildcardInferredType.out +++ b/tests/purs/warning/WildcardInferredType.out @@ -1,4 +1,4 @@ -Error 1 of 2: +Warning 1 of 2: in module Main at tests/purs/warning/WildcardInferredType.purs:7:6 - 7:7 (line 7, column 6 - line 7, column 7) @@ -11,9 +11,9 @@ Error 1 of 2: in value declaration y See https://github.com/purescript/documentation/blob/master/errors/WildcardInferredType.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. -Error 2 of 2: +Warning 2 of 2: in module Main at tests/purs/warning/WildcardInferredType.purs:5:10 - 5:11 (line 5, column 10 - line 5, column 11) @@ -26,5 +26,5 @@ Error 2 of 2: in value declaration x See https://github.com/purescript/documentation/blob/master/errors/WildcardInferredType.md for more information, - or to contribute content related to this error. + or to contribute content related to this warning. diff --git a/tests/purs/warning/WildcardInferredType2.out b/tests/purs/warning/WildcardInferredType2.out index 89efd26d58..f6b3d70bc8 100644 --- a/tests/purs/warning/WildcardInferredType2.out +++ b/tests/purs/warning/WildcardInferredType2.out @@ -1,4 +1,4 @@ -Error found: +Warning found: in module Main at tests/purs/warning/WildcardInferredType2.purs:4:6 - 4:7 (line 4, column 6 - line 4, column 7) @@ -10,5 +10,5 @@ at tests/purs/warning/WildcardInferredType2.purs:4:6 - 4:7 (line 4, column 6 - l in value declaration x See https://github.com/purescript/documentation/blob/master/errors/WildcardInferredType.md for more information, -or to contribute content related to this error. +or to contribute content related to this warning. From a4f35ac878f0428a0b1beb51e34c0a9f5150df4b Mon Sep 17 00:00:00 2001 From: Gleb Popov <6yearold@gmail.com> Date: Tue, 14 Apr 2020 19:11:31 +0400 Subject: [PATCH 1202/1580] Fix build with new Happy versions. (#3837) --- CONTRIBUTORS.md | 1 + .../src/Language/PureScript/Names.hs | 3 + .../src/Language/PureScript/CST/Parser.y | 144 +++++++++--------- .../src/Language/PureScript/CST/Utils.hs | 48 ++++++ 4 files changed, 124 insertions(+), 72 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 7e8228b146..d5edbaa616 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -21,6 +21,7 @@ If you would prefer to use different terms, please use the section below instead | [@andyarvanitis](https://github.com/andyarvanitis) | Andy Arvanitis | [MIT license](http://opensource.org/licenses/MIT) | | [@anthok88](https://github.com/anthok88) | anthoq88 | MIT license | | [@ardumont](https://github.com/ardumont) | Antoine R. Dumont | [MIT license](http://opensource.org/licenses/MIT) | +| [@arrowd](https://github.com/arrowd) | Gleb Popov | [MIT license](http://opensource.org/licenses/MIT) | | [@aspidites](https://github.com/aspidites) | Edwin Marshall | [MIT license](http://opensource.org/licenses/MIT) | | [@bagl](https://github.com/bagl) | Petr Vapenka | [MIT license](http://opensource.org/licenses/MIT) | | [@balajirrao](https://github.com/balajirrao) | Balaji Rao | MIT license | diff --git a/lib/purescript-ast/src/Language/PureScript/Names.hs b/lib/purescript-ast/src/Language/PureScript/Names.hs index 98fdeaadfa..e5a0937a6d 100644 --- a/lib/purescript-ast/src/Language/PureScript/Names.hs +++ b/lib/purescript-ast/src/Language/PureScript/Names.hs @@ -122,6 +122,9 @@ data OpNameType = ValueOpName | TypeOpName | AnyOpName eraseOpName :: OpName a -> OpName 'AnyOpName eraseOpName = OpName . runOpName +coerceOpName :: OpName a -> OpName b +coerceOpName = OpName . runOpName + -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. -- diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y index 8ba4807ce1..7f234ff168 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y +++ b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y @@ -180,12 +180,12 @@ moduleName :: { Name N.ModuleName } : UPPER {% upperToModuleName $1 } | QUAL_UPPER {% upperToModuleName $1 } -qualProperName :: { QualifiedName (N.ProperName a) } - : UPPER {% toQualifiedName N.ProperName $1 } - | QUAL_UPPER {% toQualifiedName N.ProperName $1 } +qualProperName :: { QualifiedProperName } + : UPPER {% qualifiedProperName <\$> toQualifiedName N.ProperName $1 } + | QUAL_UPPER {% qualifiedProperName <\$> toQualifiedName N.ProperName $1 } -properName :: { Name (N.ProperName a) } - : UPPER {% toName N.ProperName $1 } +properName :: { ProperName } + : UPPER {% properName <\$> toName N.ProperName $1 } qualIdent :: { QualifiedName Ident } : LOWER {% toQualifiedName Ident $1 } @@ -208,29 +208,29 @@ ident :: { Name Ident } | 'representational' {% toName Ident $1 } | 'phantom' {% toName Ident $1 } -qualOp :: { QualifiedName (N.OpName a) } - : OPERATOR {% toQualifiedName N.OpName $1 } - | QUAL_OPERATOR {% toQualifiedName N.OpName $1 } - | '<=' {% toQualifiedName N.OpName $1 } - | '-' {% toQualifiedName N.OpName $1 } - | '#' {% toQualifiedName N.OpName $1 } - | ':' {% toQualifiedName N.OpName $1 } - -op :: { Name (N.OpName a) } - : OPERATOR {% toName N.OpName $1 } - | '<=' {% toName N.OpName $1 } - | '-' {% toName N.OpName $1 } - | '#' {% toName N.OpName $1 } - | ':' {% toName N.OpName $1 } - -qualSymbol :: { QualifiedName (N.OpName a) } - : SYMBOL {% toQualifiedName N.OpName $1 } - | QUAL_SYMBOL {% toQualifiedName N.OpName $1 } - | '(..)' {% toQualifiedName N.OpName $1 } - -symbol :: { Name (N.OpName a) } - : SYMBOL {% toName N.OpName $1 } - | '(..)' {% toName N.OpName $1 } +qualOp :: { QualifiedOpName } + : OPERATOR {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } + | QUAL_OPERATOR {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } + | '<=' {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } + | '-' {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } + | '#' {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } + | ':' {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } + +op :: { OpName } + : OPERATOR {% opName <\$> toName N.OpName $1 } + | '<=' {% opName <\$> toName N.OpName $1 } + | '-' {% opName <\$> toName N.OpName $1 } + | '#' {% opName <\$> toName N.OpName $1 } + | ':' {% opName <\$> toName N.OpName $1 } + +qualSymbol :: { QualifiedOpName } + : SYMBOL {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } + | QUAL_SYMBOL {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } + | '(..)' {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } + +symbol :: { OpName } + : SYMBOL {% opName <\$> toName N.OpName $1 } + | '(..)' {% opName <\$> toName N.OpName $1 } label :: { Label } : LOWER { toLabel $1 } @@ -305,7 +305,7 @@ type2 :: { Type () } type3 :: { Type () } : type4 { $1 } - | type3 qualOp type4 { TypeOp () $1 $2 $3 } + | type3 qualOp type4 { TypeOp () $1 (getQualifiedOpName $2) $3 } type4 :: { Type () } : type5 { $1 } @@ -318,8 +318,8 @@ type5 :: { Type () } typeAtom :: { Type ()} : '_' { TypeWildcard () $1 } | ident { TypeVar () $1 } - | qualProperName { TypeConstructor () $1 } - | qualSymbol { TypeOpName () $1 } + | qualProperName { TypeConstructor () (getQualifiedProperName $1) } + | qualSymbol { TypeOpName () (getQualifiedOpName $1) } | string { uncurry (TypeString ()) $1 } | hole { TypeHole () $1 } | '(->)' { TypeArrName () $1 } @@ -333,8 +333,8 @@ typeAtom :: { Type ()} -- row, and to annotate `a` with kind `Foo`, one must use `((a) :: Foo)`. typeKindedAtom :: { Type () } : '_' { TypeWildcard () $1 } - | qualProperName { TypeConstructor () $1 } - | qualSymbol { TypeOpName () $1 } + | qualProperName { TypeConstructor () (getQualifiedProperName $1) } + | qualSymbol { TypeOpName () (getQualifiedOpName $1) } | hole { TypeHole () $1 } | '{' row '}' { TypeRecord () (Wrapped $1 $2 $3) } | '(' row ')' { TypeRow () (Wrapped $1 $2 $3) } @@ -368,7 +368,7 @@ expr :: { Expr () } expr1 :: { Expr () } : expr2 { $1 } - | expr1 qualOp expr2 { ExprOp () $1 $2 $3 } + | expr1 qualOp expr2 { ExprOp () $1 (getQualifiedOpName $2) $3 } expr2 :: { Expr () } : expr3 { $1 } @@ -376,7 +376,7 @@ expr2 :: { Expr () } exprBacktick :: { Expr () } : expr3 { $1 } - | exprBacktick qualOp expr3 { ExprOp () $1 $2 $3 } + | exprBacktick qualOp expr3 { ExprOp () $1 (getQualifiedOpName $2) $3 } expr3 :: { Expr () } : expr4 { $1 } @@ -427,8 +427,8 @@ exprAtom :: { Expr () } : '_' { ExprSection () $1 } | hole { ExprHole () $1 } | qualIdent { ExprIdent () $1 } - | qualProperName { ExprConstructor () $1 } - | qualSymbol { ExprOpName () $1 } + | qualProperName { ExprConstructor () (getQualifiedProperName $1) } + | qualSymbol { ExprOpName () (getQualifiedOpName $1) } | boolean { uncurry (ExprBoolean ()) $1 } | char { uncurry (ExprChar ()) $1 } | string { uncurry (ExprString ()) $1 } @@ -566,7 +566,7 @@ binder :: { Binder () } binder1 :: { Binder () } : binder2 { $1 } - | binder1 qualOp binder2 { BinderOp () $1 $2 $3 } + | binder1 qualOp binder2 { BinderOp () $1 (getQualifiedOpName $2) $3 } binder2 :: { Binder () } : many(binderAtom) {% toBinderConstructor $1 } @@ -575,7 +575,7 @@ binderAtom :: { Binder () } : '_' { BinderWildcard () $1 } | ident { BinderVar () $1 } | ident '@' binderAtom { BinderNamed () $1 $2 $3 } - | qualProperName { BinderConstructor () $1 [] } + | qualProperName { BinderConstructor () (getQualifiedProperName $1) [] } | boolean { uncurry (BinderBoolean ()) $1 } | char { uncurry (BinderChar ()) $1 } | string { uncurry (BinderString ()) $1 } @@ -614,7 +614,7 @@ moduleDecls :: { ([ImportDecl ()], [Declaration ()]) } : manySep(moduleDecl, '\;') {% toModuleDecls $ NE.toList $1 } | {- empty -} { ([], []) } -moduleDecl :: { TmpModuleDecl a } +moduleDecl :: { TmpModuleDecl () } : importDecl { TmpImport $1 } | sep(decl, declElse) { TmpChain $1 } @@ -628,18 +628,18 @@ exports :: { Maybe (DelimitedNonEmpty (Export ())) } export :: { Export () } : ident { ExportValue () $1 } - | symbol { ExportOp () $1 } - | properName { ExportType () $1 Nothing } - | properName dataMembers { ExportType () $1 (Just $2) } - | 'type' symbol { ExportTypeOp () $1 $2 } - | 'class' properName { ExportClass () $1 $2 } - | 'kind' properName {% addWarning [$1, nameTok $2] WarnDeprecatedKindExportSyntax *> pure (ExportKind () $1 $2) } + | symbol { ExportOp () (getOpName $1) } + | properName { ExportType () (getProperName $1) Nothing } + | properName dataMembers { ExportType () (getProperName $1) (Just $2) } + | 'type' symbol { ExportTypeOp () $1 (getOpName $2) } + | 'class' properName { ExportClass () $1 (getProperName $2) } + | 'kind' properName {% addWarning [$1, nameTok (getProperName $2)] WarnDeprecatedKindExportSyntax *> pure (ExportKind () $1 (getProperName $2)) } | 'module' moduleName { ExportModule () $1 $2 } dataMembers :: { (DataMembers ()) } : '(..)' { DataAll () $1 } | '(' ')' { DataEnumerated () (Wrapped $1 Nothing $2) } - | '(' sep(properName, ',') ')' { DataEnumerated () (Wrapped $1 (Just $2) $3) } + | '(' sep(properName, ',') ')' { DataEnumerated () (Wrapped $1 (Just \$ getProperName <\$> $2) $3) } importDecl :: { ImportDecl () } : 'import' moduleName imports { ImportDecl () $1 $2 $3 Nothing } @@ -652,47 +652,47 @@ imports :: { Maybe (Maybe SourceToken, DelimitedNonEmpty (Import ())) } import :: { Import () } : ident { ImportValue () $1 } - | symbol { ImportOp () $1 } - | properName { ImportType () $1 Nothing } - | properName dataMembers { ImportType () $1 (Just $2) } - | 'type' symbol { ImportTypeOp () $1 $2 } - | 'class' properName { ImportClass () $1 $2 } - | 'kind' properName {% addWarning [$1, nameTok $2] WarnDeprecatedKindImportSyntax *> pure (ImportKind () $1 $2) } + | symbol { ImportOp () (getOpName $1) } + | properName { ImportType () (getProperName $1) Nothing } + | properName dataMembers { ImportType () (getProperName $1) (Just $2) } + | 'type' symbol { ImportTypeOp () $1 (getOpName $2) } + | 'class' properName { ImportClass () $1 (getProperName $2) } + | 'kind' properName {% addWarning [$1, nameTok (getProperName $2)] WarnDeprecatedKindImportSyntax *> pure (ImportKind () $1 (getProperName $2)) } decl :: { Declaration () } : dataHead { DeclData () $1 Nothing } | dataHead '=' sep(dataCtor, '|') { DeclData () $1 (Just ($2, $3)) } | typeHead '=' type {% checkNoWildcards $3 *> pure (DeclType () $1 $2 $3) } - | newtypeHead '=' properName typeAtom {% checkNoWildcards $4 *> pure (DeclNewtype () $1 $2 $3 $4) } + | newtypeHead '=' properName typeAtom {% checkNoWildcards $4 *> pure (DeclNewtype () $1 $2 (getProperName $3) $4) } | classHead { either id (\h -> DeclClass () h Nothing) $1 } | classHead 'where' '\{' manySep(classMember, '\;') '\}' {% either (const (parseError $2)) (\h -> pure $ DeclClass () h (Just ($2, $4))) $1 } | instHead { DeclInstanceChain () (Separated (Instance $1 Nothing) []) } | instHead 'where' '\{' manySep(instBinding, '\;') '\}' { DeclInstanceChain () (Separated (Instance $1 (Just ($2, $4))) []) } - | 'data' properName '::' type {% checkNoWildcards $4 *> pure (DeclKindSignature () $1 (Labeled $2 $3 $4)) } - | 'newtype' properName '::' type {% checkNoWildcards $4 *> pure (DeclKindSignature () $1 (Labeled $2 $3 $4)) } - | 'type' properName '::' type {% checkNoWildcards $4 *> pure (DeclKindSignature () $1 (Labeled $2 $3 $4)) } + | 'data' properName '::' type {% checkNoWildcards $4 *> pure (DeclKindSignature () $1 (Labeled (getProperName $2) $3 $4)) } + | 'newtype' properName '::' type {% checkNoWildcards $4 *> pure (DeclKindSignature () $1 (Labeled (getProperName $2) $3 $4)) } + | 'type' properName '::' type {% checkNoWildcards $4 *> pure (DeclKindSignature () $1 (Labeled (getProperName $2) $3 $4)) } | 'derive' instHead { DeclDerive () $1 Nothing $2 } | 'derive' 'newtype' instHead { DeclDerive () $1 (Just $2) $3 } | ident '::' type { DeclSignature () (Labeled $1 $2 $3) } | ident manyOrEmpty(binderAtom) guardedDecl { DeclValue () (ValueBindingFields $1 $2 $3) } | fixity { DeclFixity () $1 } | 'foreign' 'import' ident '::' type { DeclForeign () $1 $2 (ForeignValue (Labeled $3 $4 $5)) } - | 'foreign' 'import' 'data' properName '::' type { DeclForeign () $1 $2 (ForeignData $3 (Labeled $4 $5 $6)) } - | 'foreign' 'import' 'kind' properName {% addWarning [$1, $2, $3, nameTok $4] WarnDeprecatedForeignKindSyntax *> pure (DeclForeign () $1 $2 (ForeignKind $3 $4)) } - | 'type' 'role' properName many(role) { DeclRole () $1 $2 $3 $4 } + | 'foreign' 'import' 'data' properName '::' type { DeclForeign () $1 $2 (ForeignData $3 (Labeled (getProperName $4) $5 $6)) } + | 'foreign' 'import' 'kind' properName {% addWarning [$1, $2, $3, nameTok (getProperName $4)] WarnDeprecatedForeignKindSyntax *> pure (DeclForeign () $1 $2 (ForeignKind $3 (getProperName $4))) } + | 'type' 'role' properName many(role) { DeclRole () $1 $2 (getProperName $3) $4 } dataHead :: { DataHead () } - : 'data' properName manyOrEmpty(typeVarBinding) { DataHead $1 $2 $3 } + : 'data' properName manyOrEmpty(typeVarBinding) { DataHead $1 (getProperName $2) $3 } typeHead :: { DataHead () } - : 'type' properName manyOrEmpty(typeVarBinding) { DataHead $1 $2 $3 } + : 'type' properName manyOrEmpty(typeVarBinding) { DataHead $1 (getProperName $2) $3 } newtypeHead :: { DataHead () } - : 'newtype' properName manyOrEmpty(typeVarBinding) { DataHead $1 $2 $3 } + : 'newtype' properName manyOrEmpty(typeVarBinding) { DataHead $1 (getProperName $2) $3 } dataCtor :: { DataCtor () } : properName manyOrEmpty(typeAtom) - {% for_ $2 checkNoWildcards *> pure (DataCtor () $1 $2) } + {% for_ $2 checkNoWildcards *> pure (DataCtor () (getProperName $1) $2) } -- Class head syntax requires unbounded lookahead due to a conflict between -- row syntax and `typeVarBinding`. `(a :: B)` is either a row in `constraint` @@ -716,13 +716,13 @@ classHead :: { Either (Declaration ()) (ClassHead ()) } } classSignature :: { Labeled (Name (N.ProperName 'N.TypeName)) (Type ()) } - : properName '::' type {%^ revert $ checkNoWildcards $3 *> pure (Labeled $1 $2 $3) } + : properName '::' type {%^ revert $ checkNoWildcards $3 *> pure (Labeled (getProperName $1) $2 $3) } classSuper :: { (OneOrDelimited (Constraint ()), SourceToken) } : constraints '<=' {%^ revert $ pure ($1, $2) } classNameAndFundeps :: { (Name (N.ProperName 'N.ClassName), [TypeVarBinding ()], Maybe (SourceToken, Separated ClassFundep)) } - : properName manyOrEmpty(typeVarBinding) fundeps {%^ revert $ pure ($1, $2, $3) } + : properName manyOrEmpty(typeVarBinding) fundeps {%^ revert $ pure (getProperName $1, $2, $3) } fundeps :: { Maybe (SourceToken, Separated ClassFundep) } : {- empty -} { Nothing } @@ -737,16 +737,16 @@ classMember :: { Labeled (Name Ident) (Type ()) } instHead :: { InstanceHead () } : 'instance' ident '::' constraints '=>' qualProperName manyOrEmpty(typeAtom) - { InstanceHead $1 $2 $3 (Just ($4, $5)) $6 $7 } + { InstanceHead $1 $2 $3 (Just ($4, $5)) (getQualifiedProperName $6) $7 } | 'instance' ident '::' qualProperName manyOrEmpty(typeAtom) - { InstanceHead $1 $2 $3 Nothing $4 $5 } + { InstanceHead $1 $2 $3 Nothing (getQualifiedProperName $4) $5 } constraints :: { OneOrDelimited (Constraint ()) } : constraint { One $1 } | '(' sep(constraint, ',') ')' { Many (Wrapped $1 $2 $3) } constraint :: { Constraint () } - : qualProperName manyOrEmpty(typeAtom) {% for_ $2 checkNoWildcards *> for_ $2 checkNoForalls *> pure (Constraint () $1 $2) } + : qualProperName manyOrEmpty(typeAtom) {% for_ $2 checkNoWildcards *> for_ $2 checkNoForalls *> pure (Constraint () (getQualifiedProperName $1) $2) } | '(' constraint ')' { ConstraintParens () (Wrapped $1 $2 $3) } instBinding :: { InstanceBinding () } @@ -754,9 +754,9 @@ instBinding :: { InstanceBinding () } | ident manyOrEmpty(binderAtom) guardedDecl { InstanceBindingName () (ValueBindingFields $1 $2 $3) } fixity :: { FixityFields } - : infix int qualIdent 'as' op { FixityFields $1 $2 (FixityValue (fmap Left $3) $4 $5) } - | infix int qualProperName 'as' op { FixityFields $1 $2 (FixityValue (fmap Right $3) $4 $5) } - | infix int 'type' qualProperName 'as' op { FixityFields $1 $2 (FixityType $3 $4 $5 $6) } + : infix int qualIdent 'as' op { FixityFields $1 $2 (FixityValue (fmap Left $3) $4 (getOpName $5)) } + | infix int qualProperName 'as' op { FixityFields $1 $2 (FixityValue (fmap Right (getQualifiedProperName $3)) $4 (getOpName $5)) } + | infix int 'type' qualProperName 'as' op { FixityFields $1 $2 (FixityType $3 (getQualifiedProperName $4) $5 (getOpName $6)) } infix :: { (SourceToken, Fixity) } : 'infix' { ($1, Infix) } diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs index 54feed5734..cdd85cd8ef 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs @@ -19,6 +19,54 @@ import Language.PureScript.CST.Types import qualified Language.PureScript.Names as N import Language.PureScript.PSString (PSString, mkString) +-- | +-- A newtype for a qualified proper name whose ProperNameType has not yet been determined. +-- This is a workaround for Happy's limited support for polymorphism; it is used +-- inside the parser to allow us to write just one parser for qualified proper names +-- which can be used for all of the different ProperNameTypes +-- (via a call to getQualifiedProperName). +newtype QualifiedProperName = + QualifiedProperName { getQualifiedProperName :: forall a. QualifiedName (N.ProperName a) } + +qualifiedProperName :: QualifiedName (N.ProperName a) -> QualifiedProperName +qualifiedProperName n = QualifiedProperName (N.coerceProperName <$> n) + +-- | +-- A newtype for a proper name whose ProperNameType has not yet been determined. +-- This is a workaround for Happy's limited support for polymorphism; it is used +-- inside the parser to allow us to write just one parser for proper names +-- which can be used for all of the different ProperNameTypes +-- (via a call to getProperName). +newtype ProperName = + ProperName { getProperName :: forall a. Name (N.ProperName a) } + +properName :: Name (N.ProperName a) -> ProperName +properName n = ProperName (N.coerceProperName <$> n) + +-- | +-- A newtype for a qualified operator name whose OpNameType has not yet been determined. +-- This is a workaround for Happy's limited support for polymorphism; it is used +-- inside the parser to allow us to write just one parser for qualified operator names +-- which can be used for all of the different OpNameTypes +-- (via a call to getQualifiedOpName). +newtype QualifiedOpName = + QualifiedOpName { getQualifiedOpName :: forall a. QualifiedName (N.OpName a) } + +qualifiedOpName :: QualifiedName (N.OpName a) -> QualifiedOpName +qualifiedOpName n = QualifiedOpName (N.coerceOpName <$> n) + +-- | +-- A newtype for a operator name whose OpNameType has not yet been determined. +-- This is a workaround for Happy's limited support for polymorphism; it is used +-- inside the parser to allow us to write just one parser for operator names +-- which can be used for all of the different OpNameTypes +-- (via a call to getOpName). +newtype OpName = + OpName { getOpName :: forall a. Name (N.OpName a) } + +opName :: Name (N.OpName a) -> OpName +opName n = OpName (N.coerceOpName <$> n) + placeholder :: SourceToken placeholder = SourceToken { tokAnn = TokenAnn (SourceRange (SourcePos 0 0) (SourcePos 0 0)) [] [] From 0ea56b180015c748394e59ae0572d2450fdfab3e Mon Sep 17 00:00:00 2001 From: Christoph Hegemann <6189397+kritzcreek@users.noreply.github.com> Date: Fri, 17 Apr 2020 15:07:08 +0200 Subject: [PATCH 1203/1580] [purs ide] Hides compiler internals in Prim modules from completions (#3850) --- src/Language/PureScript/Ide/Prim.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index f9b2e5ae78..0cd30192f8 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -1,6 +1,8 @@ module Language.PureScript.Ide.Prim (idePrimDeclarations) where import Protolude + +import qualified Data.Text as T import qualified Data.Map as Map import qualified Language.PureScript as P import qualified Language.PureScript.Constants.Prim as C @@ -32,8 +34,12 @@ idePrimDeclarations = Map.fromList ) ] where - annType tys = foreach (Map.toList tys) $ \(tn, (kind, _)) -> - IdeDeclarationAnn emptyAnn (IdeDeclType (IdeType (P.disqualify tn) kind [])) + annType tys = flip mapMaybe (Map.toList tys) $ \(tn, (kind, _)) -> do + let name = P.disqualify tn + -- We need to remove the ClassName$Dict synonyms, because we + -- don't want them to show up in completions + guard (isNothing (T.find (== '$') (P.runProperName name))) + Just (IdeDeclarationAnn emptyAnn (IdeDeclType (IdeType name kind []))) annClass cls = foreach (Map.toList cls) $ \(cn, _) -> -- Dummy kind and instances here, but we primarily care about the name completion IdeDeclarationAnn emptyAnn (IdeDeclTypeClass (IdeTypeClass (P.disqualify cn) P.kindType []) ) From 9c2e6ce2339a42478c4a7ecf7cdab9a8ae40e877 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann <6189397+kritzcreek@users.noreply.github.com> Date: Tue, 21 Apr 2020 20:58:08 +0200 Subject: [PATCH 1204/1580] Represents ModuleNames as a single Text (#3843) * Represents ModuleNames as a single Text The hierarchy `[ProperName]` suggests doesn't actually exist except for the `Prim.` namespace. The compiler compares module names for equality and ordering all over the place though, so we should pick a representation suitable for that. * preserve CoreFn encoding --- .../Language/PureScript/AST/Declarations.hs | 4 +-- .../src/Language/PureScript/Constants/Prim.hs | 16 ++++++------ .../src/Language/PureScript/Environment.hs | 4 +-- .../src/Language/PureScript/Names.hs | 26 ++++++++++--------- .../src/Language/PureScript/CST/Convert.hs | 2 +- .../src/Language/PureScript/CST/Utils.hs | 4 +-- src/Language/PureScript/CodeGen/JS.hs | 6 ++--- src/Language/PureScript/CodeGen/JS/Common.hs | 4 +-- src/Language/PureScript/Constants/Prelude.hs | 4 +-- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- src/Language/PureScript/CoreFn/FromJSON.hs | 2 +- src/Language/PureScript/CoreFn/ToJSON.hs | 2 +- src/Language/PureScript/Hierarchy.hs | 4 +-- src/Language/PureScript/Interactive.hs | 4 +-- src/Language/PureScript/Interactive/Module.hs | 16 ++++++------ src/Language/PureScript/Interactive/Types.hs | 4 +-- src/Language/PureScript/Linter/Imports.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 14 +++++----- .../PureScript/TypeChecker/Entailment.hs | 2 +- tests/TestCoreFn.hs | 4 +-- tests/TestHierarchy.hs | 4 +-- 22 files changed, 67 insertions(+), 65 deletions(-) diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs index b462ad4f06..d7249be9dd 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs @@ -830,8 +830,8 @@ $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExportSo isTrueExpr :: Expr -> Bool isTrueExpr (Literal _ (BooleanLiteral True)) = True -isTrueExpr (Var _ (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True -isTrueExpr (Var _ (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True +isTrueExpr (Var _ (Qualified (Just (ModuleName "Prelude")) (Ident "otherwise"))) = True +isTrueExpr (Var _ (Qualified (Just (ModuleName "Data.Boolean")) (Ident "otherwise"))) = True isTrueExpr (TypedValue _ e _) = isTrueExpr e isTrueExpr (PositionedValue _ _ e) = isTrueExpr e isTrueExpr _ = False diff --git a/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs b/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs index 4367271831..6667e65117 100644 --- a/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs +++ b/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs @@ -17,7 +17,7 @@ partial :: forall a. (IsString a) => a partial = "Partial" pattern Prim :: ModuleName -pattern Prim = ModuleName [ProperName "Prim"] +pattern Prim = ModuleName "Prim" pattern Partial :: Qualified (ProperName 'ClassName) pattern Partial = Qualified (Just Prim) (ProperName "Partial") @@ -43,7 +43,7 @@ pattern Row = Qualified (Just Prim) (ProperName "Row") -- Prim.Boolean pattern PrimBoolean :: ModuleName -pattern PrimBoolean = ModuleName [ProperName "Prim", ProperName "Boolean"] +pattern PrimBoolean = ModuleName "Prim.Boolean" booleanTrue :: Qualified (ProperName 'TypeName) booleanTrue = Qualified (Just PrimBoolean) (ProperName "True") @@ -54,7 +54,7 @@ booleanFalse = Qualified (Just PrimBoolean) (ProperName "False") -- Prim.Coerce pattern PrimCoerce :: ModuleName -pattern PrimCoerce = ModuleName [ProperName "Prim", ProperName "Coerce"] +pattern PrimCoerce = ModuleName "Prim.Coerce" pattern Coercible :: Qualified (ProperName 'ClassName) pattern Coercible = Qualified (Just PrimCoerce) (ProperName "Coercible") @@ -62,7 +62,7 @@ pattern Coercible = Qualified (Just PrimCoerce) (ProperName "Coercible") -- Prim.Ordering pattern PrimOrdering :: ModuleName -pattern PrimOrdering = ModuleName [ProperName "Prim", ProperName "Ordering"] +pattern PrimOrdering = ModuleName "Prim.Ordering" orderingLT :: Qualified (ProperName 'TypeName) orderingLT = Qualified (Just PrimOrdering) (ProperName "LT") @@ -76,7 +76,7 @@ orderingGT = Qualified (Just PrimOrdering) (ProperName "GT") -- Prim.Row pattern PrimRow :: ModuleName -pattern PrimRow = ModuleName [ProperName "Prim", ProperName "Row"] +pattern PrimRow = ModuleName "Prim.Row" pattern RowUnion :: Qualified (ProperName 'ClassName) pattern RowUnion = Qualified (Just PrimRow) (ProperName "Union") @@ -93,7 +93,7 @@ pattern RowLacks = Qualified (Just PrimRow) (ProperName "Lacks") -- Prim.RowList pattern PrimRowList :: ModuleName -pattern PrimRowList = ModuleName [ProperName "Prim", ProperName "RowList"] +pattern PrimRowList = ModuleName "Prim.RowList" pattern RowToList :: Qualified (ProperName 'ClassName) pattern RowToList = Qualified (Just PrimRowList) (ProperName "RowToList") @@ -107,7 +107,7 @@ pattern RowListCons = Qualified (Just PrimRowList) (ProperName "Cons") -- Prim.Symbol pattern PrimSymbol :: ModuleName -pattern PrimSymbol = ModuleName [ProperName "Prim", ProperName "Symbol"] +pattern PrimSymbol = ModuleName "Prim.Symbol" pattern SymbolCompare :: Qualified (ProperName 'ClassName) pattern SymbolCompare = Qualified (Just PrimSymbol) (ProperName "Compare") @@ -121,7 +121,7 @@ pattern SymbolCons = Qualified (Just PrimSymbol) (ProperName "Cons") -- Prim.TypeError pattern PrimTypeError :: ModuleName -pattern PrimTypeError = ModuleName [ProperName "Prim", ProperName "TypeError"] +pattern PrimTypeError = ModuleName "Prim.TypeError" pattern Fail :: Qualified (ProperName 'ClassName) pattern Fail = Qualified (Just PrimTypeError) (ProperName "Fail") diff --git a/lib/purescript-ast/src/Language/PureScript/Environment.hs b/lib/purescript-ast/src/Language/PureScript/Environment.hs index 2a5da9fa09..feb10f81f8 100644 --- a/lib/purescript-ast/src/Language/PureScript/Environment.hs +++ b/lib/purescript-ast/src/Language/PureScript/Environment.hs @@ -278,12 +278,12 @@ instance A.FromJSON DataDeclType where -- | Construct a ProperName in the Prim module primName :: Text -> Qualified (ProperName a) -primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName +primName = Qualified (Just C.Prim) . ProperName -- | Construct a 'ProperName' in the @Prim.NAME@ module. primSubName :: Text -> Text -> Qualified (ProperName a) primSubName sub = - Qualified (Just $ ModuleName [ProperName C.prim, ProperName sub]) . ProperName + Qualified (Just $ ModuleName $ C.prim <> "." <> sub) . ProperName primKind :: Text -> SourceType primKind = primTy diff --git a/lib/purescript-ast/src/Language/PureScript/Names.hs b/lib/purescript-ast/src/Language/PureScript/Names.hs index e5a0937a6d..7b94cceaac 100644 --- a/lib/purescript-ast/src/Language/PureScript/Names.hs +++ b/lib/purescript-ast/src/Language/PureScript/Names.hs @@ -11,6 +11,7 @@ import Codec.Serialise (Serialise) import Control.Monad.Supply.Class import Control.DeepSeq (NFData) import Data.Functor.Contravariant (contramap) +import qualified Data.Vector as V import GHC.Generics (Generic) import Data.Aeson @@ -160,26 +161,20 @@ coerceProperName = ProperName . runProperName -- | -- Module names -- -newtype ModuleName = ModuleName [ProperName 'Namespace] +newtype ModuleName = ModuleName Text deriving (Show, Eq, Ord, Generic) + deriving newtype Serialise instance NFData ModuleName -instance Serialise ModuleName runModuleName :: ModuleName -> Text -runModuleName (ModuleName pns) = T.intercalate "." (runProperName <$> pns) +runModuleName (ModuleName name) = name moduleNameFromString :: Text -> ModuleName -moduleNameFromString = ModuleName . splitProperNames - where - splitProperNames s = case T.dropWhile (== '.') s of - "" -> [] - s' -> ProperName w : splitProperNames s'' - where (w, s'') = T.break (== '.') s' +moduleNameFromString = ModuleName isBuiltinModuleName :: ModuleName -> Bool -isBuiltinModuleName (ModuleName (ProperName "Prim" : _)) = True -isBuiltinModuleName _ = False +isBuiltinModuleName (ModuleName mn) = mn == "Prim" || T.isPrefixOf "Prim." mn -- | -- A qualified name, i.e. a name with an optional module name @@ -244,7 +239,14 @@ isQualifiedWith _ _ = False $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident) -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ModuleName) + +instance ToJSON ModuleName where + toJSON (ModuleName name) = toJSON (T.splitOn "." name) + +instance FromJSON ModuleName where + parseJSON = withArray "ModuleName" $ \names -> do + names' <- traverse parseJSON names + pure (ModuleName (T.intercalate "." (V.toList names'))) instance ToJSONKey ModuleName where toJSONKey = contramap runModuleName toJSONKey diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs index e386b4df85..b8b57944bf 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs @@ -85,7 +85,7 @@ moduleName = \case _ -> Nothing where go [] = Nothing - go ns = Just $ N.ModuleName $ N.ProperName <$> ns + go ns = Just $ N.ModuleName $ Text.intercalate "." ns qualified :: QualifiedName a -> N.Qualified a qualified q = N.Qualified (qualModule q) (qualName q) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs index cdd85cd8ef..f9a561cf28 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs @@ -129,14 +129,14 @@ toModuleName :: SourceToken -> [Text] -> Parser (Maybe N.ModuleName) toModuleName _ [] = pure Nothing toModuleName tok ns = do when (not (all isValidModuleNamespace ns)) $ addFailure [tok] ErrModuleName - pure . Just . N.ModuleName $ N.ProperName <$> ns + pure . Just . N.ModuleName $ Text.intercalate "." ns upperToModuleName :: SourceToken -> Parser (Name N.ModuleName) upperToModuleName tok = case tokValue tok of TokUpperName q a -> do let ns = q <> [a] when (not (all isValidModuleNamespace ns)) $ addFailure [tok] ErrModuleName - pure . Name tok . N.ModuleName $ N.ProperName <$> ns + pure . Name tok . N.ModuleName $ Text.intercalate "." ns _ -> internalError $ "Invalid upper name: " <> show tok toQualifiedName :: (Text -> a) -> SourceToken -> Parser (QualifiedName a) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 3f4344b94b..2f8a9d3c06 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -96,8 +96,8 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ = go acc _ [] = acc freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName - freshModuleName i mn'@(ModuleName pns) used = - let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) <> "_" <> T.pack (show i)] + freshModuleName i mn'@(ModuleName name) used = + let newName = ModuleName $ name <> "_" <> T.pack (show i) in if Ident (runModuleName newName) `elem` used then freshModuleName (i + 1) mn' used else newName @@ -307,7 +307,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ = -- | Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable that may have a qualified name. qualifiedToJS :: (a -> Ident) -> Qualified a -> AST - qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = AST.Var Nothing . runIdent $ f a + qualifiedToJS f (Qualified (Just C.Prim) a) = AST.Var Nothing . runIdent $ f a qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (AST.Var Nothing (moduleNameToJs mn')) qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToJs (f a) diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index c13a22d985..09f5a633c5 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -11,8 +11,8 @@ import Language.PureScript.Crash import Language.PureScript.Names moduleNameToJs :: ModuleName -> Text -moduleNameToJs (ModuleName pns) = - let name = T.intercalate "_" (runProperName `map` pns) +moduleNameToJs (ModuleName mn) = + let name = T.replace "." "_" mn in if nameIsJsBuiltIn name then "$$" <> name else name -- | Convert an 'Ident' into a valid JavaScript identifier: diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index a816c8f79a..4a294256fc 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -371,7 +371,7 @@ main = "main" -- Data.Symbol pattern DataSymbol :: ModuleName -pattern DataSymbol = ModuleName [ProperName "Data", ProperName "Symbol"] +pattern DataSymbol = ModuleName "Data.Symbol" pattern IsSymbol :: Qualified (ProperName 'ClassName) pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol") @@ -398,7 +398,7 @@ controlSemigroupoid :: forall a. (IsString a) => a controlSemigroupoid = "Control_Semigroupoid" pattern ControlBind :: ModuleName -pattern ControlBind = ModuleName [ProperName "Control", ProperName "Bind"] +pattern ControlBind = ModuleName "Control.Bind" controlBind :: forall a. (IsString a) => a controlBind = "Control_Bind" diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 7d060f734f..46b5aa324b 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -89,7 +89,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = exprToCoreFn ss com ty (A.App v1 v2) = App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2) exprToCoreFn ss com ty (A.Unused _) = - Var (ss, com, ty, Nothing) (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) + Var (ss, com, ty, Nothing) (Qualified (Just C.Prim) (Ident C.undefined)) exprToCoreFn _ com ty (A.Var ss ident) = Var (ss, com, ty, getValueMeta ident) ident exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) = diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 0cffaf2ec0..4b3b7d5f5f 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -104,7 +104,7 @@ qualifiedFromJSON f = withObject "Qualified" qualifiedFromObj return $ Qualified mn i moduleNameFromJSON :: Value -> Parser ModuleName -moduleNameFromJSON v = ModuleName <$> listParser properNameFromJSON v +moduleNameFromJSON v = ModuleName . T.intercalate "." <$> listParser parseJSON v moduleFromJSON :: Value -> Parser (Version, Module Ann) moduleFromJSON = withObject "Module" moduleFromObj diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 75e2d56db9..ec54c1e5c7 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -100,7 +100,7 @@ qualifiedToJSON f (Qualified mn a) = object ] moduleNameToJSON :: ModuleName -> Value -moduleNameToJSON (ModuleName pns) = toJSON $ properNameToJSON `map` pns +moduleNameToJSON (ModuleName name) = toJSON (T.splitOn (T.pack ".") name) moduleToJSON :: Version -> Module Ann -> Value moduleToJSON v m = object diff --git a/src/Language/PureScript/Hierarchy.hs b/src/Language/PureScript/Hierarchy.hs index b48e95f5b5..dea22eda6d 100644 --- a/src/Language/PureScript/Hierarchy.hs +++ b/src/Language/PureScript/Hierarchy.hs @@ -54,8 +54,8 @@ prettyPrint (SuperMap (Right (super, sub))) = " " <> P.runProperName super <> " -> " <> P.runProperName sub <> ";" runModuleName :: P.ModuleName -> GraphName -runModuleName (P.ModuleName pns) = - GraphName $ T.intercalate "_" (P.runProperName <$> pns) +runModuleName (P.ModuleName name) = + GraphName $ T.replace "." "_" name typeClasses :: Functor f => f P.Module -> f (Maybe Graph) typeClasses = diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index b74f107a94..b61ed6a079 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -272,7 +272,7 @@ handleTypeOf print' val = do case e of Left errs -> printErrors errs Right (_, env') -> - case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName [P.ProperName "$PSCI"])) (P.names env') of + case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName "$PSCI")) (P.names env') of Just (ty, _, _) -> print' . P.prettyPrintType maxBound $ ty Nothing -> print' "Could not find type" @@ -285,7 +285,7 @@ handleKindOf handleKindOf print' typ = do st <- get let m = createTemporaryModuleForKind st typ - mName = P.ModuleName [P.ProperName "$PSCI"] + mName = P.ModuleName "$PSCI" e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m case e of Left errs -> printErrors errs diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 31e9b48338..1ceeedf446 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -45,18 +45,18 @@ createTemporaryModule exec st val = let imports = psciImportedModules st lets = psciLetBindings st - moduleName = P.ModuleName [P.ProperName "$PSCI"] - effModuleName = P.moduleNameFromString "Effect" - effImport = (effModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Effect"])) - supportImport = (fst (psciInteractivePrint st), P.Implicit, Just (P.ModuleName [P.ProperName "$Support"])) - eval = P.Var internalSpan (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (snd (psciInteractivePrint st))) + moduleName = P.ModuleName "$PSCI" + effModuleName = P.ModuleName "Effect" + effImport = (effModuleName, P.Implicit, Just (P.ModuleName "$Effect")) + supportImport = (fst (psciInteractivePrint st), P.Implicit, Just (P.ModuleName "$Support")) + eval = P.Var internalSpan (P.Qualified (Just (P.ModuleName "$Support")) (snd (psciInteractivePrint st))) mainValue = P.App eval (P.Var internalSpan (P.Qualified Nothing (P.Ident "it"))) itDecl = P.ValueDecl (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val] typeDecl = P.TypeDeclaration (P.TypeDeclarationData (internalSpan, []) (P.Ident "$main") (P.srcTypeApp (P.srcTypeConstructor - (P.Qualified (Just (P.ModuleName [P.ProperName "$Effect"])) (P.ProperName "Effect"))) + (P.Qualified (Just (P.ModuleName "$Effect")) (P.ProperName "Effect"))) P.srcTypeWildcard)) mainDecl = P.ValueDecl (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] @@ -75,7 +75,7 @@ createTemporaryModuleForKind st typ = let imports = psciImportedModules st lets = psciLetBindings st - moduleName = P.ModuleName [P.ProperName "$PSCI"] + moduleName = P.ModuleName "$PSCI" itDecl = P.TypeSynonymDeclaration (internalSpan, []) (P.ProperName "IT") [] typ in P.Module internalSpan [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing @@ -87,7 +87,7 @@ createTemporaryModuleForImports :: PSCiState -> P.Module createTemporaryModuleForImports st = let imports = psciImportedModules st - moduleName = P.ModuleName [P.ProperName "$PSCI"] + moduleName = P.ModuleName "$PSCI" in P.Module internalSpan [] moduleName (importDecl `map` imports) Nothing diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index cb4693e77c..1b0c621c78 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -134,12 +134,12 @@ updateImportExports st@(PSCiState modules lets externs iprint _ _) = createEnv = runExceptT =<< fmap fst . runWriterT . foldM P.externsEnv P.primEnv temporaryName :: P.ModuleName - temporaryName = P.ModuleName [P.ProperName "$PSCI"] + temporaryName = P.ModuleName "$PSCI" temporaryModule :: P.Module temporaryModule = let - prim = (P.ModuleName [P.ProperName "Prim"], P.Implicit, Nothing) + prim = (P.ModuleName "Prim", P.Implicit, Nothing) decl = (importDecl `map` (prim : modules)) ++ lets in P.Module internalSpan [] temporaryName decl Nothing diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index de55f7cf89..69dc204368 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -142,7 +142,7 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do -- Checks whether a module is the Prim module - used to suppress any checks -- made, as Prim is always implicitly imported. isPrim :: ModuleName -> Bool - isPrim = (== ModuleName [ProperName C.prim]) + isPrim = (== C.Prim) -- Creates a map of virtual modules mapped to all the declarations that -- import to that module, with the corresponding source span, import type, diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 6850dac0ba..b63f090f72 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -51,7 +51,7 @@ desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModu initialState :: MemberMap initialState = mconcat - [ M.mapKeys (qualify (ModuleName [ProperName C.prim])) primClasses + [ M.mapKeys (qualify C.Prim) primClasses , M.mapKeys (qualify C.PrimCoerce) primCoerceClasses , M.mapKeys (qualify C.PrimRow) primRowClasses , M.mapKeys (qualify C.PrimRowList) primRowListClasses diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index bd6cf26530..009777571a 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -263,19 +263,19 @@ deriveNewtypeInstance ss mn syns kinds ndis className ds tys tyConNm dargs = do else tell . errorMessage' ss $ UnverifiableSuperclassInstance constraintClass className tys dataGenericRep :: ModuleName -dataGenericRep = ModuleName [ ProperName "Data", ProperName "Generic", ProperName "Rep" ] +dataGenericRep = ModuleName "Data.Generic.Rep" dataEq :: ModuleName -dataEq = ModuleName [ ProperName "Data", ProperName "Eq" ] +dataEq = ModuleName "Data.Eq" dataOrd :: ModuleName -dataOrd = ModuleName [ ProperName "Data", ProperName "Ord" ] +dataOrd = ModuleName "Data.Ord" dataNewtype :: ModuleName -dataNewtype = ModuleName [ ProperName "Data", ProperName "Newtype" ] +dataNewtype = ModuleName "Data.Newtype" dataFunctor :: ModuleName -dataFunctor = ModuleName [ ProperName "Data", ProperName "Functor" ] +dataFunctor = ModuleName "Data.Functor" unguarded :: Expr -> [GuardedExpr] unguarded e = [MkUnguarded e] @@ -460,7 +460,7 @@ deriveEq ss mn syns kinds ds tyConNm = do mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration" preludeConj :: Expr -> Expr -> Expr - preludeConj = App . App (Var ss (Qualified (Just (ModuleName [ProperName "Data", ProperName "HeytingAlgebra"])) (Ident C.conj))) + preludeConj = App . App (Var ss (Qualified (Just (ModuleName "Data.HeytingAlgebra")) (Ident C.conj))) preludeEq :: Expr -> Expr -> Expr preludeEq = App . App (Var ss (Qualified (Just dataEq) (Ident C.eq))) @@ -541,7 +541,7 @@ deriveOrd ss mn syns kinds ds tyConNm = do catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (orderingCtor "EQ")) orderingName :: Text -> Qualified (ProperName a) - orderingName = Qualified (Just (ModuleName [ProperName "Data", ProperName "Ordering"])) . ProperName + orderingName = Qualified (Just (ModuleName "Data.Ordering")) . ProperName orderingCtor :: Text -> Expr orderingCtor = Constructor ss . orderingName diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 0ff121a811..7caa9eae7f 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -198,7 +198,7 @@ entails SolverOptions{..} constraint context hints = findDicts ctx cn = fmap (fmap NamedInstance) . foldMap NEL.toList . foldMap M.elems . (>>= M.lookup cn) . flip M.lookup ctx valUndefined :: Expr - valUndefined = Var nullSourceSpan (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined)) + valUndefined = Var nullSourceSpan (Qualified (Just C.Prim) (Ident C.undefined)) solve :: SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr solve con = go 0 con diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index 2fcb158291..89e41af0a9 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -42,7 +42,7 @@ isSuccess _ = False spec :: Spec spec = context "CoreFnFromJsonTest" $ do - let mn = ModuleName [ProperName "Example", ProperName "Main"] + let mn = ModuleName "Example.Main" mp = "src/Example/Main.purs" ss = SourceSpan mp (SourcePos 0 0) (SourcePos 0 0) ann = ssAnn ss @@ -217,7 +217,7 @@ spec = context "CoreFnFromJsonTest" $ do [ CaseAlternative [ ConstructorBinder ann - (Qualified (Just (ModuleName [ProperName "Data", ProperName "Either"])) (ProperName "Either")) + (Qualified (Just (ModuleName "Data.Either")) (ProperName "Either")) (Qualified Nothing (ProperName "Left")) [VarBinder ann (Ident "z")] ] diff --git a/tests/TestHierarchy.hs b/tests/TestHierarchy.hs index 01557ff2eb..96656a47b7 100644 --- a/tests/TestHierarchy.hs +++ b/tests/TestHierarchy.hs @@ -32,7 +32,7 @@ main = testSpec "hierarchy" $ do let mainModule = P.Module (P.internalModuleSourceSpan "") [] - (P.ModuleName [P.ProperName "Main"]) + (P.ModuleName "Main") [] Nothing @@ -60,7 +60,7 @@ main = testSpec "hierarchy" $ do let mainModule = P.Module (P.internalModuleSourceSpan "") [] - (P.ModuleName [P.ProperName "Main"]) + (P.ModuleName "Main") declarations Nothing From 35053a5a757f163cd4ef2da367983410cc4b78cb Mon Sep 17 00:00:00 2001 From: Hardy Jones Date: Fri, 24 Apr 2020 07:37:10 -0700 Subject: [PATCH 1205/1580] Create issue templates (#3853) * Create issue templates We want a better experience for people using the issue tracker. This is the first step in making things better for people reporting issues. We want to direct people toward creating an issue that provides the right information. For now, we offer two options: bug reports, and concrete compiler proposals. If we find that we want a different set of options, or a different template for others to use, we can change this at a later date. * Remove erroneous file This file was accidentally added. * Add `contact_links` for general questions We want to point people to Discourse for general questions. We've been pushing for people to use Discourse for ideas or questions for quite a while now. In an effort to make things a bit easier on everyone, we want to have a `contact_link` that nudges people there from the get-go. Hopefully, this is an improvement on the current state of affairs. * Update .github/ISSUE_TEMPLATE/bug_report.md --- .github/ISSUE_TEMPLATE/bug_report.md | 28 +++++++++++++++++++++ .github/ISSUE_TEMPLATE/compiler-proposal.md | 24 ++++++++++++++++++ .github/ISSUE_TEMPLATE/config.yml | 5 ++++ 3 files changed, 57 insertions(+) create mode 100644 .github/ISSUE_TEMPLATE/bug_report.md create mode 100644 .github/ISSUE_TEMPLATE/compiler-proposal.md create mode 100644 .github/ISSUE_TEMPLATE/config.yml diff --git a/.github/ISSUE_TEMPLATE/bug_report.md b/.github/ISSUE_TEMPLATE/bug_report.md new file mode 100644 index 0000000000..ed0a1cf4a6 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/bug_report.md @@ -0,0 +1,28 @@ +--- +name: Bug report +about: Create a report to help us improve the PureScript compiler +title: '' +labels: bug +assignees: '' + +--- + +## Description + +A clear and concise description of what the bug is. + +## To Reproduce + +Steps to reproduce the behavior. + +## Expected behavior + +A clear and concise description of what you expected to happen. + +## Additional context + +Add any other context about the problem here. + +## PureScript version + +0.x.x diff --git a/.github/ISSUE_TEMPLATE/compiler-proposal.md b/.github/ISSUE_TEMPLATE/compiler-proposal.md new file mode 100644 index 0000000000..0644a0e22a --- /dev/null +++ b/.github/ISSUE_TEMPLATE/compiler-proposal.md @@ -0,0 +1,24 @@ +--- +name: Compiler proposal +about: A concrete suggestion to change the PureScript compiler +title: 'Proposal:' +labels: enhancement +assignees: '' + +--- + +## Summary + +One or two sentence summary of the proposal. + +## Motivation + +Background information about why this proposal is necessary. + +## Proposal + +Detailed description of the proposal. + +## Examples + +At least one or two examples of the proposal being used. diff --git a/.github/ISSUE_TEMPLATE/config.yml b/.github/ISSUE_TEMPLATE/config.yml new file mode 100644 index 0000000000..94e49fa62e --- /dev/null +++ b/.github/ISSUE_TEMPLATE/config.yml @@ -0,0 +1,5 @@ +blank_issues_enabled: true +contact_links: + - about: Please discuss ideas and ask questions on the PureScript Discourse. + name: Ideas and Questions + url: https://discourse.purescript.org/ From fe67ac07e9cac1d361a716740d8c82020b7a1214 Mon Sep 17 00:00:00 2001 From: Cyril Date: Sat, 25 Apr 2020 17:32:56 +0200 Subject: [PATCH 1206/1580] Deprecate constraints in foreign imports (#3829) --- lib/purescript-cst/src/Language/PureScript/CST/Errors.hs | 3 +++ lib/purescript-cst/src/Language/PureScript/CST/Parser.y | 2 +- lib/purescript-cst/src/Language/PureScript/CST/Utils.hs | 5 +++++ src/Language/PureScript/Errors.hs | 1 + .../purs/warning/DeprecatedConstraintInForeignImport.js | 5 +++++ .../purs/warning/DeprecatedConstraintInForeignImport.out | 9 +++++++++ .../warning/DeprecatedConstraintInForeignImport.purs | 6 ++++++ 7 files changed, 30 insertions(+), 1 deletion(-) create mode 100644 tests/purs/warning/DeprecatedConstraintInForeignImport.js create mode 100644 tests/purs/warning/DeprecatedConstraintInForeignImport.out create mode 100644 tests/purs/warning/DeprecatedConstraintInForeignImport.purs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs b/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs index 18ed7079ee..1f9784bb62 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs @@ -60,6 +60,7 @@ data ParserErrorType data ParserWarningType = WarnDeprecatedRowSyntax | WarnDeprecatedForeignKindSyntax + | WarnDeprecatedConstraintInForeignImportSyntax | WarnDeprecatedKindImportSyntax | WarnDeprecatedKindExportSyntax deriving (Show, Eq, Ord) @@ -186,6 +187,8 @@ prettyPrintWarningMessage (ParserErrorInfo {..}) = case errType of "Unary '#' syntax for row kinds is deprecated and will be removed in a future release. Use the 'Row' kind instead." WarnDeprecatedForeignKindSyntax -> "Foreign kind imports are deprecated and will be removed in a future release. Use empty 'data' instead." + WarnDeprecatedConstraintInForeignImportSyntax -> + "Constraints are deprecated in foreign imports and will be removed in a future release. Omit the constraint instead and update the foreign module accordingly." WarnDeprecatedKindImportSyntax -> "Kind imports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead." WarnDeprecatedKindExportSyntax -> diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y index 7f234ff168..5541f060a1 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y +++ b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y @@ -676,7 +676,7 @@ decl :: { Declaration () } | ident '::' type { DeclSignature () (Labeled $1 $2 $3) } | ident manyOrEmpty(binderAtom) guardedDecl { DeclValue () (ValueBindingFields $1 $2 $3) } | fixity { DeclFixity () $1 } - | 'foreign' 'import' ident '::' type { DeclForeign () $1 $2 (ForeignValue (Labeled $3 $4 $5)) } + | 'foreign' 'import' ident '::' type {% when (isConstrained $5) (addWarning ([$1, $2, nameTok $3, $4] <> toList (flattenType $5)) WarnDeprecatedConstraintInForeignImportSyntax) *> pure (DeclForeign () $1 $2 (ForeignValue (Labeled $3 $4 $5))) } | 'foreign' 'import' 'data' properName '::' type { DeclForeign () $1 $2 (ForeignData $3 (Labeled (getProperName $4) $5 $6)) } | 'foreign' 'import' 'kind' properName {% addWarning [$1, $2, $3, nameTok (getProperName $4)] WarnDeprecatedForeignKindSyntax *> pure (DeclForeign () $1 $2 (ForeignKind $3 (getProperName $4))) } | 'type' 'role' properName many(role) { DeclRole () $1 $2 (getProperName $3) $4 } diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs index f9a561cf28..e73752ecf3 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs @@ -222,6 +222,11 @@ toConstraint = convertParens addFailure [tok1, tok2] ErrTypeInConstraint pure $ Constraint mempty (QualifiedName tok1 Nothing (N.ProperName " Bool +isConstrained = everythingOnTypes (||) $ \case + TypeConstrained{} -> True + _ -> False + toBinderConstructor :: Monoid a => NE.NonEmpty (Binder a) -> Parser (Binder a) toBinderConstructor = \case BinderConstructor a name [] NE.:| bs -> diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 90dfc43fdd..373a2bd4c7 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -488,6 +488,7 @@ errorSuggestion err = | otherwise = "Row " <> kind suggest sugg CST.WarnDeprecatedForeignKindSyntax -> suggest $ "data " <> CST.printTokens (drop 3 toks) + CST.WarnDeprecatedConstraintInForeignImportSyntax -> Nothing CST.WarnDeprecatedKindImportSyntax -> suggest $ CST.printTokens $ drop 1 toks CST.WarnDeprecatedKindExportSyntax -> suggest $ CST.printTokens $ drop 1 toks _ -> Nothing diff --git a/tests/purs/warning/DeprecatedConstraintInForeignImport.js b/tests/purs/warning/DeprecatedConstraintInForeignImport.js new file mode 100644 index 0000000000..3be8843e1f --- /dev/null +++ b/tests/purs/warning/DeprecatedConstraintInForeignImport.js @@ -0,0 +1,5 @@ +exports.show = function (showDict) { + return function (a) { + return showDict.show(a); + }; +}; diff --git a/tests/purs/warning/DeprecatedConstraintInForeignImport.out b/tests/purs/warning/DeprecatedConstraintInForeignImport.out new file mode 100644 index 0000000000..428c49e87c --- /dev/null +++ b/tests/purs/warning/DeprecatedConstraintInForeignImport.out @@ -0,0 +1,9 @@ +Warning found: +at tests/purs/warning/DeprecatedConstraintInForeignImport.purs:6:1 - 6:50 (line 6, column 1 - line 6, column 50) + + Constraints are deprecated in foreign imports and will be removed in a future release. Omit the constraint instead and update the foreign module accordingly. + + +See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/DeprecatedConstraintInForeignImport.purs b/tests/purs/warning/DeprecatedConstraintInForeignImport.purs new file mode 100644 index 0000000000..19028028bd --- /dev/null +++ b/tests/purs/warning/DeprecatedConstraintInForeignImport.purs @@ -0,0 +1,6 @@ +-- @shouldWarnWith WarningParsingModule +module Main where + +import Data.Show (class Show) + +foreign import show :: ∀ a. Show a => a -> String From 63e90fe46323a5cdc2b1362ca857867499e1eff0 Mon Sep 17 00:00:00 2001 From: Cyril Date: Sat, 25 Apr 2020 17:49:38 +0200 Subject: [PATCH 1207/1580] Remove legacy resolutions format (#3847) --- src/Language/PureScript/Publish.hs | 52 +- .../PureScript/Publish/ErrorsWarnings.hs | 29 +- tests/TestPscPublish.hs | 5 - .../basic-example/resolutions-legacy.json | 640 ------------------ 4 files changed, 7 insertions(+), 719 deletions(-) delete mode 100644 tests/purs/publish/basic-example/resolutions-legacy.json diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 812e0b4540..564c2158c8 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -25,11 +25,11 @@ import Control.Arrow ((***)) import Control.Category ((>>>)) import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell) -import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, eachInObject, key, keyOrDefault, asBool, asString, withString, asText, withText) +import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, key, asString, withString) import qualified Data.ByteString.Lazy as BL import Data.Char (isSpace) import Data.String (String, lines) -import Data.List (stripPrefix, (\\), nubBy) +import Data.List (stripPrefix, (\\)) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Text as T import Data.Time.Clock (UTCTime) @@ -296,12 +296,7 @@ parseResolutionsFile resolutionsFile = do Right res -> pure res Left err -> - case parse asLegacyResolutions depsBS of - Right res -> do - warn $ LegacyResolutionsFormat resolutionsFile - pure res - Left _ -> - userError $ ResolutionsFileError resolutionsFile err + userError $ ResolutionsFileError resolutionsFile err -- | Parser for resolutions files, which contain information about the packages -- which this package depends on. A resolutions file should look something like @@ -337,47 +332,6 @@ asVersion :: Parse D.PackageError Version asVersion = withString (note D.InvalidVersion . D.parseVersion') --- | Extracts all dependencies and their versions from a legacy resolutions --- file, which is based on the output of `bower list --json --offline`. -asLegacyResolutions :: Parse D.PackageError [(PackageName, (FilePath, DependencyStatus))] -asLegacyResolutions = - nubBy ((==) `on` fst) <$> go True - where - go isToplevel = - keyDependencies isToplevel $ - (++) <$> (takeJusts <$> eachInObjectWithKey parsePackageName asDirectoryAndDependencyStatus) - <*> (concatMap snd <$> eachInObject (go False)) - - - keyDependencies isToplevel = - if isToplevel - then key "dependencies" - else fmap (fromMaybe []) . keyMay "dependencies" - - takeJusts :: [(a, Maybe b)] -> [(a,b)] - takeJusts = mapMaybe $ \(x,y) -> (x,) <$> y - - asDirectoryAndDependencyStatus :: Parse D.PackageError (Maybe (FilePath, DependencyStatus)) - asDirectoryAndDependencyStatus = do - isMissing <- keyOrDefault "missing" False asBool - if isMissing - then return Nothing - else do - directory <- key "canonicalDir" asString - status <- key "pkgMeta" $ - keyOrDefault "_resolution" NoResolution $ do - type_ <- key "type" asText - case type_ of - "version" -> - key "tag" $ fmap ResolvedVersion $ withText $ \tag -> - let - tag' = fromMaybe tag (T.stripPrefix "v" tag) - in - note D.InvalidVersion (D.parseVersion' (T.unpack tag')) - other -> - return (ResolvedOther other) - return $ Just (directory, status) - parsePackageName :: Text -> Either D.PackageError PackageName parsePackageName = first D.ErrorInPackageMeta . Bower.parsePackageName diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 99fa4178ee..41d9cd8e93 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -21,8 +21,7 @@ import Data.Aeson.BetterErrors (ParseError, displayError) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe -import Data.Monoid hiding (First, getFirst) -import Data.Semigroup (First(..)) +import Data.Monoid import Data.Version import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) @@ -46,7 +45,6 @@ data PackageWarning = NoResolvedVersion PackageName | UnacceptableVersion (PackageName, Text) | DirtyWorkingTree_Warn - | LegacyResolutionsFormat FilePath deriving (Show) -- | An error that should be fixed by the user. @@ -297,16 +295,15 @@ data CollectedWarnings = CollectedWarnings { noResolvedVersions :: [PackageName] , unacceptableVersions :: [(PackageName, Text)] , dirtyWorkingTree :: Any - , legacyResolutionsFormat :: Maybe (First FilePath) } deriving (Show, Eq, Ord) instance Semigroup CollectedWarnings where - (<>) (CollectedWarnings a b c d) (CollectedWarnings a' b' c' d') = - CollectedWarnings (a <> a') (b <> b') (c <> c') (d <> d') + (<>) (CollectedWarnings a b c) (CollectedWarnings a' b' c') = + CollectedWarnings (a <> a') (b <> b') (c <> c') instance Monoid CollectedWarnings where - mempty = CollectedWarnings mempty mempty mempty mempty + mempty = CollectedWarnings mempty mempty mempty collectWarnings :: [PackageWarning] -> CollectedWarnings collectWarnings = foldMap singular @@ -318,8 +315,6 @@ collectWarnings = foldMap singular mempty { unacceptableVersions = [t] } DirtyWorkingTree_Warn -> mempty { dirtyWorkingTree = Any True } - LegacyResolutionsFormat path -> - mempty { legacyResolutionsFormat = Just (First path) } renderWarnings :: [PackageWarning] -> Box renderWarnings warns = @@ -330,7 +325,6 @@ renderWarnings warns = , if getAny dirtyWorkingTree then Just warnDirtyWorkingTree else Nothing - , fmap (warnLegacyResolutions . getFirst) legacyResolutionsFormat ] in case catMaybes mboxes of [] -> nullBox @@ -396,20 +390,5 @@ warnDirtyWorkingTree = ++ "were not a dry run)" ) -warnLegacyResolutions :: FilePath -> Box -warnLegacyResolutions path = - vcat $ - [ para (concat - [ "Your resolutions file (" ++ path ++ ") is using the deprecated " - , "legacy format. Support for this format will be dropped in a future " - , "version." - ]) - , spacer - , para (concat - [ "In most cases, all you need to do to use the new format and silence " - , "this warning is to upgrade Pulp." - ]) - ] - printWarnings :: [PackageWarning] -> IO () printWarnings = printToStderr . renderWarnings diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index b91e9cdc7b..c2a7121237 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -44,11 +44,6 @@ spec = do "tests/purs/publish/basic-example" "resolutions.json" - it "basic example with legacy resolutions file" $ do - testPackage - "tests/purs/publish/basic-example" - "resolutions-legacy.json" - context "json compatibility" $ do let compatDir = "tests" "json-compat" versions <- runIO $ listDirectory compatDir diff --git a/tests/purs/publish/basic-example/resolutions-legacy.json b/tests/purs/publish/basic-example/resolutions-legacy.json deleted file mode 100644 index c08e4d9fac..0000000000 --- a/tests/purs/publish/basic-example/resolutions-legacy.json +++ /dev/null @@ -1,640 +0,0 @@ -{ - "endpoint": { - "name": "basic-example", - "source": ".", - "target": "*" - }, - "canonicalDir": ".", - "pkgMeta": { - "name": "basic-example", - "ignore": [ - "**/.*", - "node_modules", - "bower_components", - "output" - ], - "dependencies": { - "purescript-prelude": "^4.1.0", - "purescript-console": "^4.2.0", - "purescript-effect": "^2.0.1", - "purescript-newtype": "#master" - }, - "devDependencies": { - "purescript-psci-support": "^4.0.0" - } - }, - "dependencies": { - "purescript-console": { - "endpoint": { - "name": "purescript-console", - "source": "purescript-console", - "target": "^4.2.0" - }, - "canonicalDir": "../../../support/bower_components/purescript-console", - "pkgMeta": { - "name": "purescript-console", - "homepage": "https://github.com/purescript/purescript-console", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-console.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "package.json" - ], - "dependencies": { - "purescript-effect": "^2.0.0", - "purescript-prelude": "^4.0.0" - }, - "version": "4.2.0", - "_release": "4.2.0", - "_resolution": { - "type": "version", - "tag": "v4.2.0", - "commit": "add2bdb8a4af2213d993b728805f1f2a5e76deb8" - }, - "_source": "https://github.com/purescript/purescript-console.git", - "_target": "^4.2.0", - "_originalSource": "purescript-console" - }, - "dependencies": { - "purescript-effect": { - "endpoint": { - "name": "purescript-effect", - "source": "purescript-effect", - "target": "^2.0.0" - }, - "canonicalDir": "../../../support/bower_components/purescript-effect", - "pkgMeta": { - "name": "purescript-effect", - "homepage": "https://github.com/purescript/purescript-effect", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-effect.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "package.json" - ], - "dependencies": { - "purescript-prelude": "^4.0.0" - }, - "version": "2.0.1", - "_release": "2.0.1", - "_resolution": { - "type": "version", - "tag": "v2.0.1", - "commit": "d2a11e69abcda3b81c750e86e8746cda278f47bf" - }, - "_source": "https://github.com/purescript/purescript-effect.git", - "_target": "^2.0.1", - "_originalSource": "purescript-effect" - }, - "dependencies": { - "purescript-prelude": { - "endpoint": { - "name": "purescript-prelude", - "source": "purescript-prelude", - "target": "^4.0.0" - }, - "canonicalDir": "../../../support/bower_components/purescript-prelude", - "pkgMeta": { - "name": "purescript-prelude", - "homepage": "https://github.com/purescript/purescript-prelude", - "description": "The PureScript Prelude", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-prelude.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "package.json" - ], - "version": "4.1.0", - "_release": "4.1.0", - "_resolution": { - "type": "version", - "tag": "v4.1.0", - "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" - }, - "_source": "https://github.com/purescript/purescript-prelude.git", - "_target": "^4.1.0", - "_originalSource": "purescript-prelude" - }, - "dependencies": {}, - "nrDependants": 1 - } - }, - "nrDependants": 1 - }, - "purescript-prelude": { - "endpoint": { - "name": "purescript-prelude", - "source": "purescript-prelude", - "target": "^4.0.0" - }, - "canonicalDir": "../../../support/bower_components/purescript-prelude", - "pkgMeta": { - "name": "purescript-prelude", - "homepage": "https://github.com/purescript/purescript-prelude", - "description": "The PureScript Prelude", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-prelude.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "package.json" - ], - "version": "4.1.0", - "_release": "4.1.0", - "_resolution": { - "type": "version", - "tag": "v4.1.0", - "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" - }, - "_source": "https://github.com/purescript/purescript-prelude.git", - "_target": "^4.1.0", - "_originalSource": "purescript-prelude" - }, - "dependencies": {}, - "nrDependants": 1 - } - }, - "nrDependants": 1 - }, - "purescript-effect": { - "endpoint": { - "name": "purescript-effect", - "source": "purescript-effect", - "target": "^2.0.1" - }, - "canonicalDir": "../../../support/bower_components/purescript-effect", - "pkgMeta": { - "name": "purescript-effect", - "homepage": "https://github.com/purescript/purescript-effect", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-effect.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "package.json" - ], - "dependencies": { - "purescript-prelude": "^4.0.0" - }, - "version": "2.0.1", - "_release": "2.0.1", - "_resolution": { - "type": "version", - "tag": "v2.0.1", - "commit": "d2a11e69abcda3b81c750e86e8746cda278f47bf" - }, - "_source": "https://github.com/purescript/purescript-effect.git", - "_target": "^2.0.1", - "_originalSource": "purescript-effect" - }, - "dependencies": {}, - "nrDependants": 1 - }, - "purescript-newtype": { - "endpoint": { - "name": "purescript-newtype", - "source": "purescript-newtype", - "target": "master" - }, - "canonicalDir": "../../../support/bower_components/purescript-newtype", - "pkgMeta": { - "name": "purescript-newtype", - "homepage": "https://github.com/purescript/purescript-newtype", - "description": "Type class and functions for working with newtypes", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-newtype.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "package.json" - ], - "dependencies": { - "purescript-prelude": "^4.0.0" - }, - "_release": "7d85fa6a04", - "_resolution": { - "type": "branch", - "branch": "master", - "commit": "7d85fa6a040208c010b05f7c23af6a943ba08763" - }, - "_source": "https://github.com/garyb/purescript-newtype.git", - "_target": "master", - "_originalSource": "purescript-newtype" - }, - "dependencies": { - "purescript-prelude": { - "endpoint": { - "name": "purescript-prelude", - "source": "purescript-prelude", - "target": "^4.0.0" - }, - "canonicalDir": "../../../support/bower_components/purescript-prelude", - "pkgMeta": { - "name": "purescript-prelude", - "homepage": "https://github.com/purescript/purescript-prelude", - "description": "The PureScript Prelude", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-prelude.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "package.json" - ], - "version": "4.1.0", - "_release": "4.1.0", - "_resolution": { - "type": "version", - "tag": "v4.1.0", - "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" - }, - "_source": "https://github.com/purescript/purescript-prelude.git", - "_target": "^4.1.0", - "_originalSource": "purescript-prelude" - }, - "dependencies": {}, - "nrDependants": 1 - } - }, - "nrDependants": 1 - }, - "purescript-prelude": { - "endpoint": { - "name": "purescript-prelude", - "source": "purescript-prelude", - "target": "^4.1.0" - }, - "canonicalDir": "../../../support/bower_components/purescript-prelude", - "pkgMeta": { - "name": "purescript-prelude", - "homepage": "https://github.com/purescript/purescript-prelude", - "description": "The PureScript Prelude", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-prelude.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "package.json" - ], - "version": "4.1.0", - "_release": "4.1.0", - "_resolution": { - "type": "version", - "tag": "v4.1.0", - "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" - }, - "_source": "https://github.com/purescript/purescript-prelude.git", - "_target": "^4.1.0", - "_originalSource": "purescript-prelude" - }, - "dependencies": {}, - "nrDependants": 1 - }, - "purescript-psci-support": { - "endpoint": { - "name": "purescript-psci-support", - "source": "purescript-psci-support", - "target": "^4.0.0" - }, - "canonicalDir": "../../../support/bower_components/purescript-psci-support", - "pkgMeta": { - "name": "purescript-psci-support", - "homepage": "https://github.com/purescript/purescript-psci-support", - "description": "Support module for the PSCI interactive mode", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-psci-support.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "bower.json", - "package.json" - ], - "dependencies": { - "purescript-console": "^4.0.0", - "purescript-effect": "^2.0.0", - "purescript-prelude": "^4.0.0" - }, - "version": "4.0.0", - "_release": "4.0.0", - "_resolution": { - "type": "version", - "tag": "v4.0.0", - "commit": "a66a0fa8661eb8b5fe75cc862f4e2df2835c058d" - }, - "_source": "https://github.com/purescript/purescript-psci-support.git", - "_target": "^4.0.0", - "_originalSource": "purescript-psci-support" - }, - "dependencies": { - "purescript-console": { - "endpoint": { - "name": "purescript-console", - "source": "purescript-console", - "target": "^4.0.0" - }, - "canonicalDir": "../../../support/bower_components/purescript-console", - "pkgMeta": { - "name": "purescript-console", - "homepage": "https://github.com/purescript/purescript-console", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-console.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "package.json" - ], - "dependencies": { - "purescript-effect": "^2.0.0", - "purescript-prelude": "^4.0.0" - }, - "version": "4.2.0", - "_release": "4.2.0", - "_resolution": { - "type": "version", - "tag": "v4.2.0", - "commit": "add2bdb8a4af2213d993b728805f1f2a5e76deb8" - }, - "_source": "https://github.com/purescript/purescript-console.git", - "_target": "^4.2.0", - "_originalSource": "purescript-console" - }, - "dependencies": { - "purescript-effect": { - "endpoint": { - "name": "purescript-effect", - "source": "purescript-effect", - "target": "^2.0.0" - }, - "canonicalDir": "../../../support/bower_components/purescript-effect", - "pkgMeta": { - "name": "purescript-effect", - "homepage": "https://github.com/purescript/purescript-effect", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-effect.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "package.json" - ], - "dependencies": { - "purescript-prelude": "^4.0.0" - }, - "version": "2.0.1", - "_release": "2.0.1", - "_resolution": { - "type": "version", - "tag": "v2.0.1", - "commit": "d2a11e69abcda3b81c750e86e8746cda278f47bf" - }, - "_source": "https://github.com/purescript/purescript-effect.git", - "_target": "^2.0.1", - "_originalSource": "purescript-effect" - }, - "dependencies": { - "purescript-prelude": { - "endpoint": { - "name": "purescript-prelude", - "source": "purescript-prelude", - "target": "^4.0.0" - }, - "canonicalDir": "../../../support/bower_components/purescript-prelude", - "pkgMeta": { - "name": "purescript-prelude", - "homepage": "https://github.com/purescript/purescript-prelude", - "description": "The PureScript Prelude", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-prelude.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "package.json" - ], - "version": "4.1.0", - "_release": "4.1.0", - "_resolution": { - "type": "version", - "tag": "v4.1.0", - "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" - }, - "_source": "https://github.com/purescript/purescript-prelude.git", - "_target": "^4.1.0", - "_originalSource": "purescript-prelude" - }, - "dependencies": {}, - "nrDependants": 1 - } - }, - "nrDependants": 1 - }, - "purescript-prelude": { - "endpoint": { - "name": "purescript-prelude", - "source": "purescript-prelude", - "target": "^4.0.0" - }, - "canonicalDir": "../../../support/bower_components/purescript-prelude", - "pkgMeta": { - "name": "purescript-prelude", - "homepage": "https://github.com/purescript/purescript-prelude", - "description": "The PureScript Prelude", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-prelude.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "package.json" - ], - "version": "4.1.0", - "_release": "4.1.0", - "_resolution": { - "type": "version", - "tag": "v4.1.0", - "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" - }, - "_source": "https://github.com/purescript/purescript-prelude.git", - "_target": "^4.1.0", - "_originalSource": "purescript-prelude" - }, - "dependencies": {}, - "nrDependants": 1 - } - }, - "nrDependants": 1 - }, - "purescript-effect": { - "endpoint": { - "name": "purescript-effect", - "source": "purescript-effect", - "target": "^2.0.0" - }, - "canonicalDir": "../../../support/bower_components/purescript-effect", - "pkgMeta": { - "name": "purescript-effect", - "homepage": "https://github.com/purescript/purescript-effect", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-effect.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "package.json" - ], - "dependencies": { - "purescript-prelude": "^4.0.0" - }, - "version": "2.0.1", - "_release": "2.0.1", - "_resolution": { - "type": "version", - "tag": "v2.0.1", - "commit": "d2a11e69abcda3b81c750e86e8746cda278f47bf" - }, - "_source": "https://github.com/purescript/purescript-effect.git", - "_target": "^2.0.1", - "_originalSource": "purescript-effect" - }, - "dependencies": {}, - "nrDependants": 1 - }, - "purescript-prelude": { - "endpoint": { - "name": "purescript-prelude", - "source": "purescript-prelude", - "target": "^4.0.0" - }, - "canonicalDir": "../../../support/bower_components/purescript-prelude", - "pkgMeta": { - "name": "purescript-prelude", - "homepage": "https://github.com/purescript/purescript-prelude", - "description": "The PureScript Prelude", - "license": "BSD-3-Clause", - "repository": { - "type": "git", - "url": "git://github.com/purescript/purescript-prelude.git" - }, - "ignore": [ - "**/.*", - "bower_components", - "node_modules", - "output", - "test", - "bower.json", - "package.json" - ], - "version": "4.1.0", - "_release": "4.1.0", - "_resolution": { - "type": "version", - "tag": "v4.1.0", - "commit": "7a691ce2658bd8eaf28439391e29506dd154fb3d" - }, - "_source": "https://github.com/purescript/purescript-prelude.git", - "_target": "^4.1.0", - "_originalSource": "purescript-prelude" - }, - "dependencies": {}, - "nrDependants": 1 - } - }, - "nrDependants": 1 - } - }, - "nrDependants": 0 -} From e164eaa279e9f019a0bf9e6f61239c75f887bf56 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann <6189397+kritzcreek@users.noreply.github.com> Date: Sun, 26 Apr 2020 23:29:48 +0200 Subject: [PATCH 1208/1580] [purs ide] Extracts documentation comments for type classes (#3856) * [purs ide] Extracts documentation comments for type classes I had assumed we were already doing this? Maybe something about the Name structure changed. * [purs ide] Extracts documentation comments for type class members --- src/Language/PureScript/Ide/State.hs | 23 +++++++++++++------ .../Language/PureScript/Ide/CompletionSpec.hs | 14 +++++++++++ .../pscide/src/CompletionSpecDocs.purs | 7 +++++- 3 files changed, 36 insertions(+), 8 deletions(-) diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index c397988a77..afe386653e 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -261,6 +261,7 @@ resolveLocationsForModule (defs, types) decls = annotateValue annotateDataConstructor annotateType + annotateType -- type classes live in the type namespace annotateModule d where @@ -278,9 +279,10 @@ convertDeclaration' -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> (Text -> IdeDeclaration -> IdeDeclarationAnn) + -> (Text -> IdeDeclaration -> IdeDeclarationAnn) -> IdeDeclaration -> IdeDeclarationAnn -convertDeclaration' annotateFunction annotateValue annotateDataConstructor annotateType annotateModule d = +convertDeclaration' annotateFunction annotateValue annotateDataConstructor annotateType annotateClass annotateModule d = case d of IdeDeclValue v -> annotateFunction (v ^. ideValueIdent) d @@ -291,7 +293,7 @@ convertDeclaration' annotateFunction annotateValue annotateDataConstructor annot IdeDeclDataConstructor dtor -> annotateDataConstructor (dtor ^. ideDtorName . properNameT) d IdeDeclTypeClass tc -> - annotateType (tc ^. ideTCName . properNameT) d + annotateClass (tc ^. ideTCName . properNameT) d IdeDeclValueOperator operator -> annotateValue (operator ^. ideValueOpName . opNameT) d IdeDeclTypeOperator operator -> @@ -311,15 +313,21 @@ resolveDocumentationForModule :: P.Module -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] -resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) decls = map convertDecl decls +resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) decls = + map convertDecl decls where - comments :: Map P.Name [P.Comment] - comments = Map.insert (P.ModName moduleName) moduleComments $ Map.fromListWith (flip (<>)) $ concatMap (\case + extractDeclComments :: P.Declaration -> [(P.Name, [P.Comment])] + extractDeclComments = \case P.DataDeclaration (_, cs) _ ctorName _ ctors -> (P.TyName ctorName, cs) : map dtorComments ctors + P.TypeClassDeclaration (_, cs) tyClassName _ _ _ members -> + (P.TyClassName tyClassName, cs) : concatMap extractDeclComments members decl -> - maybe [] (\name' -> [(name', snd (P.declSourceAnn decl))]) (name decl)) - sdecls + maybe [] (\name' -> [(name', snd (P.declSourceAnn decl))]) (name decl) + + comments :: Map P.Name [P.Comment] + comments = Map.insert (P.ModName moduleName) moduleComments $ + Map.fromListWith (flip (<>)) $ concatMap extractDeclComments sdecls dtorComments :: P.DataConstructorDeclaration -> (P.Name, [P.Comment]) dtorComments dcd = (P.DctorName (P.dataCtorName dcd), snd (P.dataCtorAnn dcd)) @@ -335,6 +343,7 @@ resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) de (annotateValue . P.IdentName . P.Ident) (annotateValue . P.DctorName . P.ProperName) (annotateValue . P.TyName . P.ProperName) + (annotateValue . P.TyClassName . P.ProperName) (annotateValue . P.ModName . P.moduleNameFromString) d where diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs index 0a85fda69b..b9d3025fd3 100644 --- a/tests/Language/PureScript/Ide/CompletionSpec.hs +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -72,3 +72,17 @@ spec = describe "Applying completion options" $ do , typ "CompletionSpecDocs" ] result `shouldSatisfy` \res -> complDocumentation res == Just "Module Documentation\n" + + it "gets docs on type class declaration" $ do + ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpecDocs"] + , typ "DocClass" + ] + result `shouldSatisfy` \res -> complDocumentation res == Just "Doc for class\n" + + it "gets docs on type class members" $ do + ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpecDocs"] + , typ "member" + ] + result `shouldSatisfy` \res -> complDocumentation res == Just "doc for member\n" diff --git a/tests/support/pscide/src/CompletionSpecDocs.purs b/tests/support/pscide/src/CompletionSpecDocs.purs index dae3fc43c4..787113018c 100644 --- a/tests/support/pscide/src/CompletionSpecDocs.purs +++ b/tests/support/pscide/src/CompletionSpecDocs.purs @@ -11,4 +11,9 @@ withType = 42 -- | This is -- | a multi-line -- | comment -multiline = "multiline" \ No newline at end of file +multiline = "multiline" + +-- | Doc for class +class DocClass where + -- | doc for member + member :: Int From 4dae8c8fa49c9d699d3995d037975f30e84f26d0 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Wed, 29 Apr 2020 07:45:54 -0700 Subject: [PATCH 1209/1580] Print compile errors to stdout, progress messages to stderr (#3839) * Print progress messages to standard error * Print glob miss warnings to stderr regardless of --json-errors flag * Fix complier error: import hPutStrLn and stderr * Print compiler errors to stdout * Print compiler errors and warnings via --json-errors to stdout * Print compiler warnings to stdout * Change renderProgresMessage and Progress to use Text, not String * Set line buffering for both handlers * Refactor how newline is appended when writing content to stdout/stderr * Remove unnecessary parenthesis --- app/Command/Compile.hs | 14 +++++++------- app/Main.hs | 2 ++ src/Language/PureScript/Make/Actions.hs | 8 +++++--- 3 files changed, 14 insertions(+), 10 deletions(-) diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index fc6a572c3b..1ea69add2c 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -26,7 +26,7 @@ import qualified System.Console.ANSI as ANSI import System.Exit (exitSuccess, exitFailure) import System.Directory (getCurrentDirectory) import System.FilePath.Glob (glob) -import System.IO (hPutStr, hPutStrLn, stderr) +import System.IO (hPutStr, hPutStrLn, stderr, stdout) import System.IO.UTF8 (readUTF8FilesT) data PSCMakeOptions = PSCMakeOptions @@ -41,25 +41,25 @@ data PSCMakeOptions = PSCMakeOptions printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO () printWarningsAndErrors verbose False warnings errors = do pwd <- getCurrentDirectory - cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stderr + cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stdout let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose, P.ppeRelativeDirectory = pwd } when (P.nonEmpty warnings) $ - hPutStrLn stderr (P.prettyPrintMultipleWarnings ppeOpts warnings) + hPutStrLn stdout (P.prettyPrintMultipleWarnings ppeOpts warnings) case errors of Left errs -> do - hPutStrLn stderr (P.prettyPrintMultipleErrors ppeOpts errs) + hPutStrLn stdout (P.prettyPrintMultipleErrors ppeOpts errs) exitFailure Right _ -> return () printWarningsAndErrors verbose True warnings errors = do - hPutStrLn stderr . LBU8.toString . A.encode $ + hPutStrLn stdout . LBU8.toString . A.encode $ JSONResult (toJSONErrors verbose P.Warning warnings) (either (toJSONErrors verbose P.Error) (const []) errors) either (const exitFailure) (const (return ())) errors compile :: PSCMakeOptions -> IO () compile PSCMakeOptions{..} = do - input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput - when (null input && not pscmJSONErrors) $ do + input <- globWarningOnMisses warnFileTypeNotFound pscmInput + when (null input) $ do hPutStr stderr $ unlines [ "purs compile: No input files." , "Usage: For basic information, try the `--help' option." ] diff --git a/app/Main.hs b/app/Main.hs index 0acf5c7b3f..1725274904 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -29,6 +29,8 @@ main :: IO () main = do IO.hSetEncoding IO.stdout IO.utf8 IO.hSetEncoding IO.stderr IO.utf8 + IO.hSetBuffering IO.stdout IO.LineBuffering + IO.hSetBuffering IO.stderr IO.LineBuffering cmd <- Opts.handleParseResult . execParserPure opts =<< getArgs cmd where diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 1fb4ed52ff..eef6fefb03 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -26,6 +26,7 @@ import qualified Data.Map as M import Data.Maybe (fromMaybe, maybeToList) import qualified Data.Set as S import qualified Data.Text as T +import qualified Data.Text.IO as TIO import qualified Data.Text.Encoding as TE import Data.Time.Clock (UTCTime) import Data.Version (showVersion) @@ -54,6 +55,7 @@ import SourceMap import SourceMap.Types import System.Directory (getCurrentDirectory) import System.FilePath ((), makeRelative, splitPath, normalise) +import System.IO (stderr) -- | Determines when to rebuild a module data RebuildPolicy @@ -70,8 +72,8 @@ data ProgressMessage deriving (Show, Eq, Ord) -- | Render a progress message -renderProgressMessage :: ProgressMessage -> String -renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (runModuleName mn) +renderProgressMessage :: ProgressMessage -> T.Text +renderProgressMessage (CompilingModule mn) = T.append "Compiling " (runModuleName mn) -- | Actions that require implementations when running in "make" mode. -- @@ -269,7 +271,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = requiresForeign = not . null . CF.moduleForeign progress :: ProgressMessage -> Make () - progress = liftIO . putStrLn . renderProgressMessage + progress = liftIO . TIO.hPutStr stderr . (<> "\n") . renderProgressMessage readCacheDb :: Make CacheDb readCacheDb = readCacheDb' outputDir From 1d78a363dbded0e9d0714b0e7176317cac015257 Mon Sep 17 00:00:00 2001 From: Hardy Jones Date: Mon, 4 May 2020 10:50:30 -0700 Subject: [PATCH 1210/1580] Setup `hlint` to run in the project (#3816) * Setup `hlint` There have been a smattering of efforts to run `hlint` on the project: * 1b77d7e83bac4c83e57358cf6b5d8f2f9cbe7f6f * afd4605dcbfe3710a8b9252b07a583fce8f18f62 * 5860f1ee38cbdc3edb5cabd75bd22fc894807a76 * b120af74c689e491911909532172c5b315b5f86e * a647c7893e64b4b5886e5fe9d8c95a468aece820 * f806a6f4d51c8917c754269ad382327bd161febe * 20f1200532678510ff2ec4ee28d376619c51e3c8 * 0b07beb08d68b3ae1c77d645f85ef681cc260b9d The last explicit `hlint` inspiried cleanup was three and a half years ago. Over that time, we've accumulated almost 400 hints from `hlint`. It's unclear if these are all new or if they've been around for a while and the previous efforts only addressed some of the issues. To mitigate the number of new hints, we setup `hlint` properly in the project. Given that there are too many hints to attempt to take on all at once, we ignore all of the current hints with a `.hlint.yaml` file provided by the `--default` flag. We can triage the hints that we think are useful, and ignore the ones we don't find useful. The motivation behind doing this change now is that we want to be more consistent with the language extensions in use: https://github.com/purescript/purescript/issues/3805. Since `hlint` can enforce the use of language extensions: https://github.com/ndmitchell/hlint/tree/9f1e23655c4fac537446a2600dd2f5d89825406c#restricting-items, it seemed like an alright approach to solving this problem: https://github.com/purescript/purescript/issues/3805#issuecomment-599297787. We'll move on to cleaning up language extensions after we've decided what to do about this approach. * Be more platform-agnostic for `hlint` Turns out `make` doesn't exist on the Windows environment of TravisCI. It has `cmake` instead. Also, the macOS environment of TravisCI doesn't have the same version of `mktemp` or `rm` that exists on the Linux environment. It is probably using the BSD versions of those while we expected the GNU versions. We write things more agnostic by taking in the build and bin directories. This way, we can call the script with arguments instead of expecting it to know more information than it should. It was dubious of us to assume the path to `bin` would always work anyway. To address the Windows issue, we call the script directly to install `hlint` and run `hlint` manually once it's installed. This isn't ideal because it means that we have two workflows: one using `make` the other orchestrating things by hand. Hopefully, we can address these issues better in the future. * Fix environment variables Looks like each line in this YAML string is run as its own shell process. So maybe the variables aren't available directly to the script? It's unclear why this didn't work but a few lines above we had `URL` available in the environment. In any case, we try putting it all on one line so it should hopefully be part of the environment the script has available. --- .gitignore | 2 + .hlint.yaml | 114 ++++++++++++++++++++++++++++++++++++++++++++ .travis.yml | 3 ++ Makefile | 19 +++++++- ci/install-hlint.sh | 66 +++++++++++++++++++++++++ 5 files changed, 203 insertions(+), 1 deletion(-) create mode 100644 .hlint.yaml create mode 100755 ci/install-hlint.sh diff --git a/.gitignore b/.gitignore index 2c6f7ff578..82c6949369 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,5 @@ +.build +bin dist cabal-dev .cabal-sandbox diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000000..c41d339669 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,114 @@ +# HLint configuration file +# https://github.com/ndmitchell/hlint +########################## + +# This file contains a template configuration file, which is typically +# placed as .hlint.yaml in the root of your project + + +# Warnings currently triggered by your code +- ignore: {name: "Unused LANGUAGE pragma"} +- ignore: {name: "Redundant =="} +- ignore: {name: "Use infix"} +- ignore: {name: "Redundant do"} +- ignore: {name: "Use newtype instead of data"} +- ignore: {name: "Redundant bracket"} +- ignore: {name: "Use join"} +- ignore: {name: "Fuse foldr/map"} +- ignore: {name: "Eta reduce"} +- ignore: {name: "Use notElem"} +- ignore: {name: "Use lambda-case"} +- ignore: {name: "Avoid lambda"} +- ignore: {name: "Use tuple-section"} +- ignore: {name: "Use sortOn"} +- ignore: {name: "Redundant $"} +- ignore: {name: "Use record patterns"} +- ignore: {name: "Use String"} +- ignore: {name: "Use isDigit"} +- ignore: {name: "Use list literal pattern"} +- ignore: {name: "Use unless"} +- ignore: {name: "Move brackets to avoid $"} +- ignore: {name: "Use section"} +- ignore: {name: "Use &&"} +- ignore: {name: "Use <$>"} +- ignore: {name: "Use ."} +- ignore: {name: "Redundant if"} +- ignore: {name: "Use traverse_"} +- ignore: {name: "Use :"} +- ignore: {name: "Parse error"} +- ignore: {name: "Avoid reverse"} +- ignore: {name: "Use Just"} +- ignore: {name: "Use /="} +- ignore: {name: "Reduce duplication"} +- ignore: {name: "Use fewer imports"} +- ignore: {name: "Use camelCase"} +- ignore: {name: "Use ++"} +- ignore: {name: "Hoist not"} +- ignore: {name: "Functor law"} +- ignore: {name: "Use $>"} +- ignore: {name: "Redundant fmap"} +- ignore: {name: "Use =<<"} +- ignore: {name: "Use maybe"} +- ignore: {name: "Use zipWithM_"} +- ignore: {name: "Use fromMaybe"} +- ignore: {name: "Use gets"} +- ignore: {name: "Use unwords"} +- ignore: {name: "Use fmap"} +- ignore: {name: "Avoid lambda using `infix`"} +- ignore: {name: "Use <$"} +- ignore: {name: "Use const"} +- ignore: {name: "Fuse mapM/map"} + + +# Specify additional command line arguments +# +# - arguments: [--color, --cpp-simple, -XQuasiQuotes] + + +# Control which extensions/flags/modules/functions can be used +# +# - extensions: +# - default: false # all extension are banned by default +# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used +# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module +# +# - flags: +# - {name: -w, within: []} # -w is allowed nowhere +# +# - modules: +# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' +# - {name: Control.Arrow, within: []} # Certain modules are banned entirely +# +# - functions: +# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules + + +# Add custom hints for this project +# +# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" +# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} + + +# Turn on hints that are off by default +# +# Ban "module X(module X) where", to require a real export list +# - warn: {name: Use explicit module export list} +# +# Replace a $ b $ c with a . b $ c +# - group: {name: dollar, enabled: true} +# +# Generalise map to fmap, ++ to <> +# - group: {name: generalise, enabled: true} + + +# Ignore some builtin hints +# - ignore: {name: Use let} +# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules + + +# Define some custom infix operators +# - fixity: infixr 3 ~^#^~ + + +# To generate a suitable file for HLint do: +# $ hlint --default > .hlint.yaml diff --git a/.travis.yml b/.travis.yml index c8b543d8f7..7f0bbfb825 100644 --- a/.travis.yml +++ b/.travis.yml @@ -70,6 +70,8 @@ install: tar -xzf stack.tar.gz --strip-components=1 mv stack "$HOME/.local/bin/" popd +- | # Install hlint. + BIN_DIR="$HOME/.local/bin/" BUILD_DIR="$HOME/hlint" ci/install-hlint.sh - | # Set up the timeout command if which timeout >/dev/null then @@ -97,6 +99,7 @@ install: export CI_RELEASE=true fi script: +- hlint --git # Set a timeout of 35 minutes. We could use travis_wait here, but travis_wait # doesn't produce any output until the command finishes, and also doesn't # always show all of the command's output. diff --git a/Makefile b/Makefile index 5ba08c61ad..a1faa87a74 100644 --- a/Makefile +++ b/Makefile @@ -1,8 +1,20 @@ +bin_dir = bin +build_dir = .build package = purescript exe_target = purs stack_yaml = STACK_YAML="stack.yaml" stack = $(stack_yaml) stack +.DEFAULT_GOAL := help + +$(bin_dir)/hlint: ci/install-hlint.sh + BIN_DIR=$(bin_dir) BUILD_DIR=$(build_dir) $< + touch $@ + +clean: ## Remove build artifacts + rm -fr $(bin_dir) + rm -fr $(build_dir) + help: ## Print documentation @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' @@ -59,4 +71,9 @@ dev-deps: ## Install helpful development tools. license-generator: ## Update dependencies in LICENSE $(stack) ls dependencies purescript --flag purescript:RELEASE | stack license-generator/generate.hs > LICENSE -.PHONY : build build-dirty run install ghci test test-ghci test-profiling ghcid dev-deps license-generator +lint: lint-hlint ## Check project adheres to standards + +lint-hlint: $(bin_dir)/hlint ## Check project adheres to hlint standards + $< --git + +.PHONY : build build-dirty run install ghci test test-ghci test-profiling ghcid dev-deps license-generator clean lint lint-hlint diff --git a/ci/install-hlint.sh b/ci/install-hlint.sh new file mode 100755 index 0000000000..2037b7d259 --- /dev/null +++ b/ci/install-hlint.sh @@ -0,0 +1,66 @@ +#!/usr/bin/env bash + +set -o errexit +set -o nounset +set -o pipefail +IFS=$'\n\t' + +readonly hlint_version=2.2.11 +readonly build_dir="${BUILD_DIR:?Must provide a directory to build in}" +readonly bin_dir="${BIN_DIR:?Must provide a directory to install binaries}" + +function cleanup() { + local exit_code="${?}" + + exit "${exit_code}" +} + +trap cleanup EXIT + +function download_for_unix() { + local os="${1}" + local url="https://github.com/ndmitchell/hlint/releases/download/v${hlint_version}/hlint-${hlint_version}-x86_64-${os}.tar.gz" + + mkdir -p "${build_dir}" + pushd "${build_dir}" + curl --location "${url}" --output hlint.tar.gz + tar -xzf hlint.tar.gz --strip-components=1 + popd + + mkdir -p "${bin_dir}/data" + cp -r "${build_dir}/data" "${bin_dir}" + cp "${build_dir}/hlint" "${bin_dir}" +} + +function download_for_windows() { + local url="https://github.com/ndmitchell/hlint/releases/download/v${hlint_version}/hlint-${hlint_version}-x86_64-windows.zip" + + mkdir -p "${build_dir}" + pushd "${build_dir}" + curl --location "${url}" --output hlint.zip + 7z e -r hlint.zip + popd + + mkdir -p "${bin_dir}/data" + cp -r "${build_dir}/data" "${bin_dir}" + cp "${build_dir}/hlint.exe" "${bin_dir}" +} + +function main() { + # The OS environment variable is set to 'Windows_NT' on Windows NT systems. + # This should work for all recent Windows versions including: + # NT, 2000, XP, Server, Vista, 7, 8, 8.1, and 10. + case "${OS:-$(uname)}" in + 'Darwin') + download_for_unix 'osx';; + 'Linux') + download_for_unix 'linux';; + 'Windows_NT') + download_for_windows;; + *) + echo 'Unknown Platform. Only Linux, macOS, and Windows are supported'; + exit 1;; + esac +} + +main From 55a43b615e34c16624e333b157514f3199b2adf9 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Fri, 8 May 2020 11:10:34 +0100 Subject: [PATCH 1211/1580] Fix hlint warnings (#3864) --- app/Command/Compile.hs | 6 +++--- src/Language/PureScript/Make/Actions.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 1ea69add2c..2528957201 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -44,14 +44,14 @@ printWarningsAndErrors verbose False warnings errors = do cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stdout let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose, P.ppeRelativeDirectory = pwd } when (P.nonEmpty warnings) $ - hPutStrLn stdout (P.prettyPrintMultipleWarnings ppeOpts warnings) + putStrLn (P.prettyPrintMultipleWarnings ppeOpts warnings) case errors of Left errs -> do - hPutStrLn stdout (P.prettyPrintMultipleErrors ppeOpts errs) + putStrLn (P.prettyPrintMultipleErrors ppeOpts errs) exitFailure Right _ -> return () printWarningsAndErrors verbose True warnings errors = do - hPutStrLn stdout . LBU8.toString . A.encode $ + putStrLn . LBU8.toString . A.encode $ JSONResult (toJSONErrors verbose P.Warning warnings) (either (toJSONErrors verbose P.Error) (const []) errors) either (const exitFailure) (const (return ())) errors diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index eef6fefb03..d7cca6e8a5 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -288,7 +288,7 @@ checkForeignDecls m path = do foreignIdentsStrs <- either errorParsingModule pure $ getExps js - let deprecatedFFI = filter (any (== '\'')) foreignIdentsStrs + let deprecatedFFI = filter (elem '\'') foreignIdentsStrs unless (null deprecatedFFI) $ warningDeprecatedForeignPrimes deprecatedFFI From df3170f5bb0ba21517e2ca72db6aee5c479c99df Mon Sep 17 00:00:00 2001 From: Cyril Date: Fri, 8 May 2020 13:34:29 +0200 Subject: [PATCH 1212/1580] Remove core tests (#3861) --- RELEASE_GUIDE.md | 1 + core-tests/.gitignore | 3 -- core-tests/psc-package.json | 65 --------------------------- core-tests/test-everything.sh | 35 --------------- core-tests/tests/GenericDeriving.purs | 30 ------------- core-tests/tests/Main.purs | 8 ---- 6 files changed, 1 insertion(+), 141 deletions(-) delete mode 100644 core-tests/.gitignore delete mode 100644 core-tests/psc-package.json delete mode 100755 core-tests/test-everything.sh delete mode 100755 core-tests/tests/GenericDeriving.purs delete mode 100644 core-tests/tests/Main.purs diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md index 7b0d6acdb8..a5b7aad60c 100644 --- a/RELEASE_GUIDE.md +++ b/RELEASE_GUIDE.md @@ -2,6 +2,7 @@ ## Before making a release +- Check that there are no unintended breaking changes by compiling [the latest package set](https://github.com/purescript/package-sets/releases/latest) - Check that INSTALL.md is up-to-date - Regenerate LICENSE: `make license-generator` (see `license-generator/` for details) diff --git a/core-tests/.gitignore b/core-tests/.gitignore deleted file mode 100644 index ec714d16e2..0000000000 --- a/core-tests/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -core-docs.md -bower_components/ -output/ diff --git a/core-tests/psc-package.json b/core-tests/psc-package.json deleted file mode 100644 index 296a7aac3e..0000000000 --- a/core-tests/psc-package.json +++ /dev/null @@ -1,65 +0,0 @@ -{ - "name": "core-tests", - "set": "psc-0.11.3", - "source": "https://github.com/purescript/package-sets.git", - "depends": [ - "arrays", - "assert", - "bifunctors", - "catenable-lists", - "console", - "const", - "contravariant", - "control", - "datetime", - "distributive", - "eff", - "either", - "enums", - "exceptions", - "exists", - "foldable-traversable", - "foreign", - "free", - "functions", - "functors", - "gen", - "generics", - "generics-rep", - "globals", - "graphs", - "identity", - "inject", - "integers", - "invariant", - "lazy", - "maps", - "math", - "maybe", - "monoid", - "newtype", - "nonempty", - "orders", - "partial", - "parallel", - "prelude", - "profunctor", - "proxy", - "psci-support", - "quickcheck", - "random", - "refs", - "semirings", - "sets", - "st", - "strings", - "tailrec", - "transformers", - "tuples", - "typelevel-prelude", - "type-equality", - "unfoldable", - "unsafe-coerce", - "validation" - ] -} diff --git a/core-tests/test-everything.sh b/core-tests/test-everything.sh deleted file mode 100755 index 848a41c7bd..0000000000 --- a/core-tests/test-everything.sh +++ /dev/null @@ -1,35 +0,0 @@ -#!/usr/bin/env bash - -# exit on error -set -o errexit -# needed for using $(psc-package sources) -set -o noglob - -force_recompile='false' -force_reinstall='false' - -while getopts 'ci' flag; do - case "${flag}" in - c) force_recompile='true' ;; - i) force_reinstall='true' ;; - *) error "Unexpected option ${flag}" ;; - esac -done - -if [ "$force_reinstall" = "true" ] && [ -d ".psc-package" ]; then - echo "Reinstalling core packages..." - rm -rf .psc-package -fi - -psc-package update - -if [ "$force_recompile" = "true" ] && [ -d "output" ]; then - echo "Recompiling..." - rm -r output -fi - -stack exec purs compile tests/**/*.purs $(psc-package sources) - -stack exec purs docs $(psc-package sources) > core-docs.md - -NODE_PATH=output node -e "require('Test.Main').main()" diff --git a/core-tests/tests/GenericDeriving.purs b/core-tests/tests/GenericDeriving.purs deleted file mode 100755 index b95b185fb2..0000000000 --- a/core-tests/tests/GenericDeriving.purs +++ /dev/null @@ -1,30 +0,0 @@ -module Test.GenericDeriving where - -import Prelude - -import Effect (Effect) -import Effect.Console (log, logShow) -import Data.Generic (class Generic, gShow, gEq) -import Partial.Unsafe (unsafePartial) - -data Empty - -derive instance genericEmpty :: Partial => Generic Empty - -data A a - = A Number String - | B Int - | C (Array (A a)) - | D { "asgård" :: a } - | E Empty - -derive instance genericA :: (Partial, Generic b) => Generic (A b) - -newtype X b = X b - -derive instance genericX :: Generic (X String) - -main :: Effect Unit -main = unsafePartial do - log $ gShow (D { "asgård": C [ A 1.0 "test", B 42, D { "asgård": true } ] }) - logShow $ gEq (C [B 0]) (C [B 0] :: A Empty) diff --git a/core-tests/tests/Main.purs b/core-tests/tests/Main.purs deleted file mode 100644 index 8559c444ac..0000000000 --- a/core-tests/tests/Main.purs +++ /dev/null @@ -1,8 +0,0 @@ -module Test.Main where - -import Prelude -import Effect (Effect) -import Test.GenericDeriving as GenericDeriving - -main :: Effect Unit -main = GenericDeriving.main From 1b91bda780d8d80906adb16a9d63472718cec1c0 Mon Sep 17 00:00:00 2001 From: Paul Young <84700+paulyoung@users.noreply.github.com> Date: Mon, 18 May 2020 07:22:58 -0700 Subject: [PATCH 1213/1580] Fix CoreFn FromJSON version parsing and add test (#3877) * Fix CoreFn version parsing and add test * Move parseVersion' to CoreFn.FromJSON module --- src/Language/PureScript/CoreFn/FromJSON.hs | 16 ++++++++++++---- src/Language/PureScript/Docs/Types.hs | 11 ++--------- src/Language/PureScript/Publish.hs | 5 +++-- tests/TestCoreFn.hs | 9 +++++++++ 4 files changed, 26 insertions(+), 15 deletions(-) diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 4b3b7d5f5f..798ce2b843 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -4,6 +4,7 @@ module Language.PureScript.CoreFn.FromJSON ( moduleFromJSON + , parseVersion' ) where import Prelude.Compat @@ -12,7 +13,6 @@ import Data.Aeson import Data.Aeson.Types (Parser, Value, listParser) import Data.Text (Text) import qualified Data.Text as T -import Text.ParserCombinators.ReadP (readP_to_S) import qualified Data.Vector as V import Data.Version (Version, parseVersion) @@ -23,6 +23,14 @@ import Language.PureScript.CoreFn import Language.PureScript.Names import Language.PureScript.PSString (PSString) +import Text.ParserCombinators.ReadP (readP_to_S) + +parseVersion' :: String -> Maybe Version +parseVersion' str = + case filter (null . snd) $ readP_to_S parseVersion str of + [(vers, "")] -> Just vers + _ -> Nothing + constructorTypeFromJSON :: Value -> Parser ConstructorType constructorTypeFromJSON v = do t <- parseJSON v @@ -123,9 +131,9 @@ moduleFromJSON = withObject "Module" moduleFromObj versionFromJSON :: String -> Parser Version versionFromJSON v = - case readP_to_S parseVersion v of - (r, _) : _ -> return r - _ -> fail "failed parsing purs version" + case parseVersion' v of + Just r -> return r + Nothing -> fail "failed parsing purs version" importFromJSON :: FilePath -> Value -> Parser (Ann, ModuleName) importFromJSON modulePath = withObject "Import" diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 6792d9048f..1170f0fe20 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -28,14 +28,13 @@ import qualified Data.Text as T import qualified Data.Vector as V import qualified Language.PureScript.AST as P +import qualified Language.PureScript.CoreFn.FromJSON as P import qualified Language.PureScript.Crash as P import qualified Language.PureScript.Environment as P import qualified Language.PureScript.Names as P import qualified Language.PureScript.Types as P import qualified Paths_purescript as Paths -import Text.ParserCombinators.ReadP (readP_to_S) - import Web.Bower.PackageMeta hiding (Version, displayError) import Language.PureScript.Docs.RenderedCode as ReExports @@ -549,13 +548,7 @@ instance A.FromJSON GithubUser where parseJSON = toAesonParser' asGithubUser asVersion :: Parse PackageError Version -asVersion = withString (maybe (Left InvalidVersion) Right . parseVersion') - -parseVersion' :: String -> Maybe Version -parseVersion' str = - case filter (null . snd) $ readP_to_S parseVersion str of - [(vers, "")] -> Just vers - _ -> Nothing +asVersion = withString (maybe (Left InvalidVersion) Right . P.parseVersion') asModule :: Parse PackageError Module asModule = diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 564c2158c8..7a700c78d3 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -48,6 +48,7 @@ import qualified Web.Bower.PackageMeta as Bower import Language.PureScript.Publish.ErrorsWarnings import Language.PureScript.Publish.Utils import qualified Language.PureScript as P (version, ModuleName) +import qualified Language.PureScript.CoreFn.FromJSON as P import qualified Language.PureScript.Docs as D data PublishOptions = PublishOptions @@ -199,7 +200,7 @@ getVersionFromGitTag = do dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse parseMay str = do digits <- stripPrefix "v" str - (str,) <$> D.parseVersion' digits + (str,) <$> P.parseVersion' digits -- | Given a git tag, get the time it was created. getTagTime :: Text -> PrepareM UTCTime @@ -330,7 +331,7 @@ asResolutions = asVersion :: Parse D.PackageError Version asVersion = - withString (note D.InvalidVersion . D.parseVersion') + withString (note D.InvalidVersion . P.parseVersion') parsePackageName :: Text -> Either D.PackageError PackageName parsePackageName = first D.ErrorInPackageMeta . Bower.parsePackageName diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index 89e41af0a9..04b9fa9185 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -47,6 +47,15 @@ spec = context "CoreFnFromJsonTest" $ do ss = SourceSpan mp (SourcePos 0 0) (SourcePos 0 0) ann = ssAnn ss + specify "should parse version" $ do + let v = Version [0, 13, 6] [] + m = Module ss [] mn mp [] [] [] [] + r = fst <$> parseModule (moduleToJSON v m) + r `shouldSatisfy` isSuccess + case r of + Error _ -> return () + Aeson.Success v' -> v' `shouldBe` v + specify "should parse an empty module" $ do let r = parseMod $ Module ss [] mn mp [] [] [] [] r `shouldSatisfy` isSuccess From f6e9a7bb10a9d938bc4c3668f2793bfc54b636e1 Mon Sep 17 00:00:00 2001 From: Christoph Hegemann <6189397+kritzcreek@users.noreply.github.com> Date: Sun, 24 May 2020 09:57:45 +0200 Subject: [PATCH 1214/1580] Printer for CST Modules (#3887) * Starts work on extracting all tokens from a CST module * flattens everything * adds printer for module * uses a proper source range for the Eof token * makes layout token printing configurable * computes Eof range --- .../src/Language/PureScript/CST/Flatten.hs | 264 ++++++++++++++++++ .../src/Language/PureScript/CST/Print.hs | 28 +- 2 files changed, 285 insertions(+), 7 deletions(-) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs b/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs index fa32c32a80..88cfed2851 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs @@ -4,6 +4,264 @@ import Prelude import Data.DList (DList) import Language.PureScript.CST.Types +import Language.PureScript.CST.Positions + +flattenModule :: Module a -> DList SourceToken +flattenModule m@(Module _ a b c d e f g) = + pure a <> + flattenName b <> + foldMap (flattenWrapped (flattenSeparated flattenExport)) c <> + pure d <> + foldMap flattenImportDecl e <> + foldMap flattenDeclaration f <> + pure (SourceToken (TokenAnn eofRange g []) TokEof) + where + (_, endTkn) = moduleRange m + eofPos = advanceLeading (srcEnd (srcRange endTkn)) g + eofRange = SourceRange eofPos eofPos + +flattenDataHead :: DataHead a -> DList SourceToken +flattenDataHead (DataHead a b c) = pure a <> flattenName b <> foldMap flattenTypeVarBinding c + +flattenDataCtor :: DataCtor a -> DList SourceToken +flattenDataCtor (DataCtor _ a b) = flattenName a <> foldMap flattenType b + +flattenClassHead :: ClassHead a -> DList SourceToken +flattenClassHead (ClassHead a b c d e) = + pure a <> + foldMap (\(f, g) -> flattenOneOrDelimited flattenConstraint f <> pure g) b <> + flattenName c <> + foldMap flattenTypeVarBinding d <> + foldMap (\(f, g) -> pure f <> flattenSeparated flattenClassFundep g) e + +flattenClassFundep :: ClassFundep -> DList SourceToken +flattenClassFundep = \case + FundepDetermined a b -> + pure a <> foldMap flattenName b + FundepDetermines a b c -> + foldMap flattenName a <> pure b <> foldMap flattenName c + +flattenInstance :: Instance a -> DList SourceToken +flattenInstance (Instance a b) = + flattenInstanceHead a <> foldMap (\(c, d) -> pure c <> foldMap flattenInstanceBinding d) b + +flattenInstanceHead :: InstanceHead a -> DList SourceToken +flattenInstanceHead (InstanceHead a b c d e f) = + pure a <> + flattenName b <> + pure c <> + foldMap (\(g, h) -> flattenOneOrDelimited flattenConstraint g <> pure h) d <> + flattenQualifiedName e <> + foldMap flattenType f + +flattenInstanceBinding :: InstanceBinding a -> DList SourceToken +flattenInstanceBinding = \case + InstanceBindingSignature _ a -> flattenLabeled flattenName flattenType a + InstanceBindingName _ a -> flattenValueBindingFields a + +flattenValueBindingFields :: ValueBindingFields a -> DList SourceToken +flattenValueBindingFields (ValueBindingFields a b c) = + flattenName a <> + foldMap flattenBinder b <> + flattenGuarded c + +flattenBinder :: Binder a -> DList SourceToken +flattenBinder = \case + BinderWildcard _ a -> pure a + BinderVar _ a -> flattenName a + BinderNamed _ a b c -> flattenName a <> pure b <> flattenBinder c + BinderConstructor _ a b -> flattenQualifiedName a <> foldMap flattenBinder b + BinderBoolean _ a _ -> pure a + BinderChar _ a _ -> pure a + BinderString _ a _ -> pure a + BinderNumber _ a b _ -> foldMap pure a <> pure b + BinderArray _ a -> flattenWrapped (foldMap (flattenSeparated flattenBinder)) a + BinderRecord _ a -> + flattenWrapped (foldMap (flattenSeparated (flattenRecordLabeled flattenBinder))) a + BinderParens _ a -> flattenWrapped flattenBinder a + BinderTyped _ a b c -> flattenBinder a <> pure b <> flattenType c + BinderOp _ a b c -> flattenBinder a <> flattenQualifiedName b <> flattenBinder c + +flattenRecordLabeled :: (a -> DList SourceToken) -> RecordLabeled a -> DList SourceToken +flattenRecordLabeled f = \case + RecordPun a -> flattenName a + RecordField a b c -> flattenLabel a <> pure b <> f c + +flattenRecordAccessor :: RecordAccessor a -> DList SourceToken +flattenRecordAccessor (RecordAccessor a b c) = + flattenExpr a <> pure b <> flattenSeparated flattenLabel c + +flattenRecordUpdate :: RecordUpdate a -> DList SourceToken +flattenRecordUpdate = \case + RecordUpdateLeaf a b c -> flattenLabel a <> pure b <> flattenExpr c + RecordUpdateBranch a b -> + flattenLabel a <> flattenWrapped (flattenSeparated flattenRecordUpdate) b + +flattenLambda :: Lambda a -> DList SourceToken +flattenLambda (Lambda a b c d) = + pure a <> foldMap flattenBinder b <> pure c <> flattenExpr d + +flattenIfThenElse :: IfThenElse a -> DList SourceToken +flattenIfThenElse (IfThenElse a b c d e f) = + pure a <> flattenExpr b <> pure c <> flattenExpr d <> pure e <> flattenExpr f + +flattenCaseOf :: CaseOf a -> DList SourceToken +flattenCaseOf (CaseOf a b c d) = + pure a <> + flattenSeparated flattenExpr b <> + pure c <> + foldMap (\(e, f) -> flattenSeparated flattenBinder e <> flattenGuarded f) d + +flattenLetIn :: LetIn a -> DList SourceToken +flattenLetIn (LetIn a b c d) = + pure a <> foldMap flattenLetBinding b <> pure c <> flattenExpr d + +flattenDoBlock :: DoBlock a -> DList SourceToken +flattenDoBlock (DoBlock a b) = + pure a <> foldMap flattenDoStatement b + +flattenAdoBlock :: AdoBlock a -> DList SourceToken +flattenAdoBlock (AdoBlock a b c d) = + pure a <> foldMap flattenDoStatement b <> pure c <> flattenExpr d + +flattenDoStatement :: DoStatement a -> DList SourceToken +flattenDoStatement = \case + DoLet a b -> pure a <> foldMap flattenLetBinding b + DoDiscard a -> flattenExpr a + DoBind a b c -> flattenBinder a <> pure b <> flattenExpr c + +flattenExpr :: Expr a -> DList SourceToken +flattenExpr = \case + ExprHole _ a -> flattenName a + ExprSection _ a -> pure a + ExprIdent _ a -> flattenQualifiedName a + ExprConstructor _ a -> flattenQualifiedName a + ExprBoolean _ a _ -> pure a + ExprChar _ a _ -> pure a + ExprString _ a _ -> pure a + ExprNumber _ a _ -> pure a + ExprArray _ a -> flattenWrapped (foldMap (flattenSeparated flattenExpr)) a + ExprRecord _ a -> + flattenWrapped (foldMap (flattenSeparated (flattenRecordLabeled flattenExpr))) a + ExprParens _ a -> flattenWrapped flattenExpr a + ExprTyped _ a b c -> flattenExpr a <> pure b <> flattenType c + ExprInfix _ a b c -> flattenExpr a <> flattenWrapped flattenExpr b <> flattenExpr c + ExprOp _ a b c -> flattenExpr a <> flattenQualifiedName b <> flattenExpr c + ExprOpName _ a -> flattenQualifiedName a + ExprNegate _ a b -> pure a <> flattenExpr b + ExprRecordAccessor _ a -> flattenRecordAccessor a + ExprRecordUpdate _ a b -> flattenExpr a <> flattenWrapped (flattenSeparated flattenRecordUpdate) b + ExprApp _ a b -> flattenExpr a <> flattenExpr b + ExprLambda _ a -> flattenLambda a + ExprIf _ a -> flattenIfThenElse a + ExprCase _ a -> flattenCaseOf a + ExprLet _ a -> flattenLetIn a + ExprDo _ a -> flattenDoBlock a + ExprAdo _ a -> flattenAdoBlock a + +flattenLetBinding :: LetBinding a -> DList SourceToken +flattenLetBinding = \case + LetBindingSignature _ a -> flattenLabeled flattenName flattenType a + LetBindingName _ a -> flattenValueBindingFields a + LetBindingPattern _ a b c -> flattenBinder a <> pure b <> flattenWhere c + +flattenWhere :: Where a -> DList SourceToken +flattenWhere (Where a b) = + flattenExpr a <> foldMap (\(c, d) -> pure c <> foldMap flattenLetBinding d) b + +flattenPatternGuard :: PatternGuard a -> DList SourceToken +flattenPatternGuard (PatternGuard a b) = + foldMap (\(c, d) -> flattenBinder c <> pure d) a <> flattenExpr b + +flattenGuardedExpr :: GuardedExpr a -> DList SourceToken +flattenGuardedExpr (GuardedExpr a b c d) = + pure a <> + flattenSeparated flattenPatternGuard b <> + pure c <> + flattenWhere d + +flattenGuarded :: Guarded a -> DList SourceToken +flattenGuarded = \case + Unconditional a b -> pure a <> flattenWhere b + Guarded a -> foldMap flattenGuardedExpr a + +flattenFixityFields :: FixityFields -> DList SourceToken +flattenFixityFields (FixityFields (a, _) (b, _) c) = + pure a <> pure b <> flattenFixityOp c + +flattenFixityOp :: FixityOp -> DList SourceToken +flattenFixityOp = \case + FixityValue a b c -> flattenQualifiedName a <> pure b <> flattenName c + FixityType a b c d -> pure a <> flattenQualifiedName b <> pure c <> flattenName d + +flattenForeign :: Foreign a -> DList SourceToken +flattenForeign = \case + ForeignValue a -> flattenLabeled flattenName flattenType a + ForeignData a b -> pure a <> flattenLabeled flattenName flattenType b + ForeignKind a b -> pure a <> flattenName b + +flattenRole :: Role -> DList SourceToken +flattenRole = pure . roleTok + +flattenDeclaration :: Declaration a -> DList SourceToken +flattenDeclaration = \case + DeclData _ a b -> + flattenDataHead a <> + foldMap (\(t, cs) -> pure t <> flattenSeparated flattenDataCtor cs) b + DeclType _ a b c ->flattenDataHead a <> pure b <> flattenType c + DeclNewtype _ a b c d -> flattenDataHead a <> pure b <> flattenName c <> flattenType d + DeclClass _ a b -> + flattenClassHead a <> + foldMap (\(c, d) -> pure c <> foldMap (flattenLabeled flattenName flattenType) d) b + DeclInstanceChain _ a -> flattenSeparated flattenInstance a + DeclDerive _ a b c -> pure a <> foldMap pure b <> flattenInstanceHead c + DeclKindSignature _ a b -> pure a <> flattenLabeled flattenName flattenType b + DeclSignature _ a -> flattenLabeled flattenName flattenType a + DeclFixity _ a -> flattenFixityFields a + DeclForeign _ a b c -> pure a <> pure b <> flattenForeign c + DeclRole _ a b c d -> pure a <> pure b <> flattenName c <> foldMap flattenRole d + DeclValue _ a -> flattenValueBindingFields a + +flattenQualifiedName :: QualifiedName a -> DList SourceToken +flattenQualifiedName = pure . qualTok + +flattenName :: Name a -> DList SourceToken +flattenName = pure . nameTok + +flattenLabel :: Label -> DList SourceToken +flattenLabel = pure . lblTok + +flattenExport :: Export a -> DList SourceToken +flattenExport = \case + ExportValue _ n -> flattenName n + ExportOp _ n -> flattenName n + ExportType _ n dms -> flattenName n <> foldMap flattenDataMembers dms + ExportTypeOp _ t n -> pure t <> flattenName n + ExportClass _ t n -> pure t <> flattenName n + ExportKind _ t n -> pure t <> flattenName n + ExportModule _ t n -> pure t <> flattenName n + +flattenDataMembers :: DataMembers a -> DList SourceToken +flattenDataMembers = \case + DataAll _ t -> pure t + DataEnumerated _ ns -> flattenWrapped (foldMap (flattenSeparated flattenName)) ns + +flattenImportDecl :: ImportDecl a -> DList SourceToken +flattenImportDecl (ImportDecl _ a b c d) = + pure a <> + flattenName b <> + foldMap (\(mt, is) -> + foldMap pure mt <> flattenWrapped (flattenSeparated flattenImport) is) c <> + foldMap (\(t, n) -> pure t <> flattenName n) d + +flattenImport :: Import a -> DList SourceToken +flattenImport = \case + ImportValue _ n -> flattenName n + ImportOp _ n -> flattenName n + ImportType _ n dms -> flattenName n <> foldMap flattenDataMembers dms + ImportTypeOp _ t n -> pure t <> flattenName n + ImportClass _ t n -> pure t <> flattenName n + ImportKind _ t n -> pure t <> flattenName n flattenWrapped :: (a -> DList SourceToken) -> Wrapped a -> DList SourceToken flattenWrapped k (Wrapped a b c) = pure a <> k b <> pure c @@ -11,6 +269,12 @@ flattenWrapped k (Wrapped a b c) = pure a <> k b <> pure c flattenSeparated :: (a -> DList SourceToken) -> Separated a -> DList SourceToken flattenSeparated k (Separated a b) = k a <> foldMap (\(c, d) -> pure c <> k d) b +flattenOneOrDelimited + :: (a -> DList SourceToken) -> OneOrDelimited a -> DList SourceToken +flattenOneOrDelimited f = \case + One a -> f a + Many a -> flattenWrapped (flattenSeparated f) a + flattenLabeled :: (a -> DList SourceToken) -> (b -> DList SourceToken) -> Labeled a b -> DList SourceToken flattenLabeled ka kc (Labeled a b c) = ka a <> pure b <> kc c diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Print.hs b/lib/purescript-cst/src/Language/PureScript/CST/Print.hs index 16aac588dc..5cbb3467dd 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Print.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Print.hs @@ -5,18 +5,26 @@ module Language.PureScript.CST.Print ( printToken , printTokens + , printModule , printLeadingComment , printTrailingComment ) where import Prelude +import qualified Data.DList as DList import Data.Text (Text) import qualified Data.Text as Text import Language.PureScript.CST.Types +import Language.PureScript.CST.Flatten (flattenModule) printToken :: Token -> Text -printToken = \case +printToken = printToken' True + +-- | Prints a given Token. The bool controls whether or not layout +-- tokens should be printed. +printToken' :: Bool -> Token -> Text +printToken' showLayout = \case TokLeftParen -> "(" TokRightParen -> ")" TokLeftBrace -> "{" @@ -52,22 +60,28 @@ printToken = \case TokRawString raw -> "\"\"\"" <> raw <> "\"\"\"" TokInt raw _ -> raw TokNumber raw _ -> raw - TokLayoutStart -> "{" - TokLayoutSep -> ";" - TokLayoutEnd -> "}" - TokEof -> "" + TokLayoutStart -> if showLayout then "{" else "" + TokLayoutSep -> if showLayout then ";" else "" + TokLayoutEnd -> if showLayout then "}" else "" + TokEof -> if showLayout then "" else "" printQual :: [Text] -> Text printQual = Text.concat . map (<> ".") printTokens :: [SourceToken] -> Text -printTokens toks = Text.concat (map pp toks) +printTokens = printTokens' True + +printTokens' :: Bool -> [SourceToken] -> Text +printTokens' showLayout toks = Text.concat (map pp toks) where pp (SourceToken (TokenAnn _ leading trailing) tok) = Text.concat (map printLeadingComment leading) - <> printToken tok + <> printToken' showLayout tok <> Text.concat (map printTrailingComment trailing) +printModule :: Module a -> Text +printModule = printTokens' False . DList.toList . flattenModule + printLeadingComment :: Comment LineFeed -> Text printLeadingComment = \case Comment raw -> raw From d7e8ef857943e2186857c682076f0caf789e6abe Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 3 Jun 2020 21:57:53 +0200 Subject: [PATCH 1215/1580] Updated purescript version in package.yaml (#3894) --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 5b5afcb7eb..da2ee395c1 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.13.6' +version: '0.13.8' synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From fe57d49715f23bcc4eeae942173fd004381778e9 Mon Sep 17 00:00:00 2001 From: Cyril Date: Thu, 4 Jun 2020 23:51:37 +0200 Subject: [PATCH 1216/1580] Recurse on the right of arrows and under foralls when inferring nominal roles from kinds (#3896) * Recurse on the right of arrows when inferring nominal roles from kinds * Recurse under foralls when inferring nominal roles from kinds * Infer nominal roles from kinds arity --- src/Language/PureScript/TypeChecker/Roles.hs | 16 +++++------ tests/purs/failing/CoercibleForeign2.out | 28 ++++++++++++++++++++ tests/purs/failing/CoercibleForeign2.purs | 9 +++++++ tests/purs/failing/CoercibleForeign3.out | 28 ++++++++++++++++++++ tests/purs/failing/CoercibleForeign3.purs | 9 +++++++ 5 files changed, 82 insertions(+), 8 deletions(-) create mode 100644 tests/purs/failing/CoercibleForeign2.out create mode 100644 tests/purs/failing/CoercibleForeign2.purs create mode 100644 tests/purs/failing/CoercibleForeign3.out create mode 100644 tests/purs/failing/CoercibleForeign3.purs diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index 5edbad4b80..bc0f0c7b5d 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -139,11 +139,11 @@ inferRoles env tyName -- the absence of a role signature, provides the safest default for a type whose -- constructors are opaque to us. rolesFromForeignTypeKind :: SourceType -> [Role] -rolesFromForeignTypeKind - = go [] - where - go acc = \case - TypeApp _ (TypeApp _ fn k1) _k2 | eqType fn tyFunction -> - go (Nominal : acc) k1 - _k -> - Nominal : acc +rolesFromForeignTypeKind k = replicate (kindArity k) Nominal + +kindArity :: SourceType -> Int +kindArity = go 0 where + go n (TypeApp _ (TypeApp _ fn _) k) + | fn == tyFunction = go (n + 1) k + go n (ForAll _ _ _ k _) = go n k + go n _ = n diff --git a/tests/purs/failing/CoercibleForeign2.out b/tests/purs/failing/CoercibleForeign2.out new file mode 100644 index 0000000000..083afcb7bf --- /dev/null +++ b/tests/purs/failing/CoercibleForeign2.out @@ -0,0 +1,28 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleForeign2.purs:9:20 - 9:26 (line 9, column 20 - line 9, column 26) + + No type class instance was found for +   +  Prim.Coerce.Coercible (Foreign a0 b1 c2) +  (Foreign a0 b1 d3) +   + +while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b + is at least as general as type Foreign a0 b1 c2 -> Foreign a0 b1 d3 +while checking that expression coerce + has type Foreign a0 b1 c2 -> Foreign a0 b1 d3 +in value declaration foreignToForeign + +where a0 is a rigid type variable + bound at (line 9, column 20 - line 9, column 26) + b1 is a rigid type variable + bound at (line 9, column 20 - line 9, column 26) + c2 is a rigid type variable + bound at (line 9, column 20 - line 9, column 26) + d3 is a rigid type variable + bound at (line 9, column 20 - line 9, column 26) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleForeign2.purs b/tests/purs/failing/CoercibleForeign2.purs new file mode 100644 index 0000000000..bc94a389d1 --- /dev/null +++ b/tests/purs/failing/CoercibleForeign2.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +foreign import data Foreign :: Type -> Type -> Type -> Type + +foreignToForeign :: forall a b c d. Foreign a b c -> Foreign a b d +foreignToForeign = coerce diff --git a/tests/purs/failing/CoercibleForeign3.out b/tests/purs/failing/CoercibleForeign3.out new file mode 100644 index 0000000000..9bf213691d --- /dev/null +++ b/tests/purs/failing/CoercibleForeign3.out @@ -0,0 +1,28 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleForeign3.purs:9:20 - 9:26 (line 9, column 20 - line 9, column 26) + + No type class instance was found for +   +  Prim.Coerce.Coercible (Foreign @k0 a1 b2) +  (Foreign @k0 a1 c3) +   + +while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b + is at least as general as type Foreign @k0 a1 b2 -> Foreign @k0 a1 c3 +while checking that expression coerce + has type Foreign @k0 a1 b2 -> Foreign @k0 a1 c3 +in value declaration foreignToForeign + +where k0 is a rigid type variable + bound at (line 9, column 20 - line 9, column 26) + a1 is a rigid type variable + bound at (line 9, column 20 - line 9, column 26) + b2 is a rigid type variable + bound at (line 9, column 20 - line 9, column 26) + c3 is a rigid type variable + bound at (line 9, column 20 - line 9, column 26) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleForeign3.purs b/tests/purs/failing/CoercibleForeign3.purs new file mode 100644 index 0000000000..2abd379b12 --- /dev/null +++ b/tests/purs/failing/CoercibleForeign3.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +foreign import data Foreign :: ∀ k. k -> k -> Type + +foreignToForeign :: ∀ k (a :: k) (b :: k) (c :: k). Foreign a b -> Foreign a c +foreignToForeign = coerce From c044d69d4778c3d426e6550e20000362626ffacd Mon Sep 17 00:00:00 2001 From: Gabe Johnson Date: Sat, 13 Jun 2020 17:41:27 -0500 Subject: [PATCH 1217/1580] Have module re-exports appear in generated code (#3883) * Add re-exports to Language.PureScript.CoreFn.Module We need to make the `ExportSource` from `Language.PureScript.AST.Declarations.ReExportRef` available during code-gen. This requires adding it to `Module`. We don't actually do the work of adding the data in this commit, we merely add the field, update the JSON codecs, appease the compiler, and add a test for parsing the new field. * Add source of re-export to the module Now that we have a field for them, we add the re-exports to the module so they show up as both imported modules and exported members during code-gen. * Generate imports for re-exports Now that we're threading the necessary information down to `moduleToJs`, we can use it to generate the imports we need to later re-export. * Add re-exports to the generated code We build up the key/value pairs for the re-exports and append them to the rest of the exports. This broke bundling and required allowing `.` in addition to `$foreign.`. This is the only place where I'm unsure of my changes. * Handle bracket notation for re-exports while bundling In the last commit, we handled the case of member access using dot notation, but the passing tests were a fluke of caching. Now both cases are handled and tests are passing. * Add CitizenNet and my CitizenNet account to CONTRIBUTORS.md I have a separate account that I use for work and prefer to include this in addition to my personal acccount to differentiate who owns the copyright for what work. I also add my employer to the list of companies holding copyright. * Handle `Language.PureScript.CoreFn.exportToCoreFn` cases explicitly Previously, it was possible to forget to handle new constructors added to `DeclarationRef`. Now we handle them explicitly thus eliminating this potential source of bugs. * Test re-exports appear in generated code As suggested by @hdgarrood in https://github.com/purescript/purescript/pull/3883#pullrequestreview-417385565, we use the FFI to import a re-exported value. Module `A` defines a value `a`, module `B` re-exports `A`, and module `Main` does a foreign import of `a` via `B`. Logging the imported value proves that the re-export chain was successful. * Add more conditions to re-export test We tested that the value defined in one module could be re-exported and then imported via FFI. Now, we test that: 1. a re-exported module doesn't cause a name clash with any data constructors defined in the re-exporting module 2. a value, `a`, defined in a module, `A`, may be re-exported from another module, `B`, and again re-exported from a third module, `C`, which imported `a` from `B`. * Have test module export data constructor in addition to re-export I forgot to export the data constructor `A`. I had visually inspected the generated code and saw that the names didn't conflict. However, it's better to have the test make this assurance. --- CONTRIBUTORS.md | 2 + src/Language/PureScript/Bundle.hs | 4 ++ src/Language/PureScript/CodeGen/JS.hs | 20 ++++++- src/Language/PureScript/CoreFn/Desugar.hs | 21 ++++++-- src/Language/PureScript/CoreFn/FromJSON.hs | 5 ++ src/Language/PureScript/CoreFn/Module.hs | 3 ++ src/Language/PureScript/CoreFn/ToJSON.hs | 5 ++ src/Language/PureScript/Renamer.hs | 2 +- tests/TestCoreFn.hs | 59 ++++++++++++--------- tests/purs/passing/ReExportsExported.js | 4 ++ tests/purs/passing/ReExportsExported.purs | 7 +++ tests/purs/passing/ReExportsExported/A.purs | 4 ++ tests/purs/passing/ReExportsExported/B.purs | 7 +++ tests/purs/passing/ReExportsExported/C.purs | 4 ++ 14 files changed, 117 insertions(+), 30 deletions(-) create mode 100644 tests/purs/passing/ReExportsExported.js create mode 100644 tests/purs/passing/ReExportsExported.purs create mode 100644 tests/purs/passing/ReExportsExported/A.purs create mode 100644 tests/purs/passing/ReExportsExported/B.purs create mode 100644 tests/purs/passing/ReExportsExported/C.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index d5edbaa616..648ff2ab71 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -148,6 +148,7 @@ If you would prefer to use different terms, please use the section below instead | :------- | :--- | :------ | | [@charleso](https://github.com/charleso) | Charles O'Farrell | My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Charles O'Farrell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | | [@chrissmoak](https://github.com/chrissmoak) | Chris Smoak | My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | +| [@citizengabe](https://github.com/citizengabe) | Gabe Johnson | All contributions I have or will make using the @citizengabe GitHub account are during employment at [CitizenNet Inc.](#companies) who owns the copyright. All of my existing or future contributions made using the @gabejohnson GitHub account are personal contributions and subject to the terms specified [above](#contributors-using-standard-terms). | | [@dylex](https://github.com/dylex) | Dylan Simon | My existing and all future contributions to the PureScript compiler until further notice are Copyright Dylan Simon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | | [@leighman](http://github.com/leighman) | Jack Leigh | My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | | [@nagisa](https://github.com/nagisa) | nagisa | I hereby release my [only contribution](https://github.com/purescript/purescript/commit/80287a5d0de619862d3b4cda9c1ee276d18fdcd8) into public domain. | @@ -157,5 +158,6 @@ If you would prefer to use different terms, please use the section below instead | Username | Company | Terms | | :------- | :--- | :------ | +| [@citizennet](https://github.com/citizennet) | CitizenNet Inc. | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright CitizenNet Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@dbenyamin-cn](https://github.com/dbenyamin-cn) | | [@slamdata](https://github.com/slamdata) | SlamData, Inc. | Speaking on behalf of SlamData for SlamData employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright SlamData Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - @jdegoes | | [@qfpl](https://github.com/qfpl) | qfpl @ Data61 / CSIRO | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Data61 / CSIRO, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@lightandlight](https://github.com/lightandlight) | diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 82bf1cb234..682f56a297 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -402,9 +402,13 @@ toModule mids mid filename top exportType (JSMemberDot f _ _) | JSIdentifier _ "$foreign" <- f = pure ForeignReexport + | JSIdentifier _ ident <- f + = pure (RegularExport ident) exportType (JSMemberSquare f _ _ _) | JSIdentifier _ "$foreign" <- f = pure ForeignReexport + | JSIdentifier _ ident <- f + = pure (RegularExport ident) exportType (JSIdentifier _ s) = pure (RegularExport s) exportType _ = err UnsupportedExport diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 2f8a9d3c06..f3d0253dd6 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -50,7 +50,7 @@ moduleToJs => Module Ann -> Maybe AST -> m [AST] -moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ = +moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps @@ -59,6 +59,7 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ = optimized <- traverse (traverse optimize) jsDecls let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized + `S.union` M.keysSet reExps jsImports <- traverse (importToJs mnLookup) . filter (flip S.member usedModuleNames) . (\\ (mn : C.primModules)) $ ordNub $ map snd imps @@ -70,8 +71,10 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ = let moduleBody = header : foreign' ++ jsImports ++ concat optimized let foreignExps = exps `intersect` foreigns let standardExps = exps \\ foreignExps + let reExps' = M.toList (M.withoutKeys reExps (S.fromList C.primModules)) let exps' = AST.ObjectLiteral Nothing $ map (mkString . runIdent &&& AST.Var Nothing . identToJs) standardExps ++ map (mkString . runIdent &&& foreignIdent) foreignExps + ++ concatMap (reExportPairs mnLookup) reExps' return $ moduleBody ++ [AST.Assignment Nothing (accessorString "exports" (AST.Var Nothing "module")) exps'] where @@ -81,6 +84,21 @@ moduleToJs (Module _ coms mn _ imps exps foreigns decls) foreign_ = getNames (NonRec _ ident _) = [ident] getNames (Rec vals) = map (snd . fst) vals + -- | Generate code in the JavaScript IR for re-exported declarations, prepending + -- the module name from whence it was imported. + reExportPairs :: M.Map ModuleName (Ann, ModuleName) -> (ModuleName, [Ident]) -> [(PSString, AST)] + reExportPairs mnLookup (mn', idents) = + let toExportedMember :: Ident -> AST + toExportedMember = + maybe + (AST.Var Nothing . identToJs) + (flip accessor . AST.Var Nothing . moduleNameToJs . snd) + (M.lookup mn' mnLookup) + in + map + (mkString . runIdent &&& toExportedMember) + idents + -- | Creates alternative names for each module to ensure they don't collide -- with declaration names. renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 46b5aa324b..0285fa2792 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -38,11 +38,22 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = let imports = mapMaybe importToCoreFn decls ++ fmap (ssAnn modSS,) (findQualModules decls) imports' = dedupeImports imports exps' = ordNub $ concatMap exportToCoreFn exps + reExps = M.map ordNub $ M.unionsWith (++) (mapMaybe (fmap reExportsToCoreFn . toReExportRef) exps) externs = ordNub $ mapMaybe externToCoreFn decls decls' = concatMap declToCoreFn decls - in Module modSS coms mn (spanName modSS) imports' exps' externs decls' - + in Module modSS coms mn (spanName modSS) imports' exps' reExps externs decls' where + -- | Creates a map from a module name to the re-export references defined in + -- that module. + reExportsToCoreFn :: (ModuleName, A.DeclarationRef) -> M.Map ModuleName [Ident] + reExportsToCoreFn (mn', ref') = M.singleton mn' (exportToCoreFn ref') + + toReExportRef :: A.DeclarationRef -> Maybe (ModuleName, A.DeclarationRef) + toReExportRef (A.ReExportRef _ src ref) = + fmap + (, ref) + (A.exportSourceImportedFrom src) + toReExportRef _ = Nothing -- | Remove duplicate imports dedupeImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)] @@ -238,10 +249,14 @@ externToCoreFn _ = Nothing -- constructor, instances and values are flattened into one list. exportToCoreFn :: A.DeclarationRef -> [Ident] exportToCoreFn (A.TypeRef _ _ (Just dctors)) = fmap properToIdent dctors +exportToCoreFn (A.TypeRef _ _ Nothing) = [] +exportToCoreFn (A.TypeOpRef _ _) = [] exportToCoreFn (A.ValueRef _ name) = [name] +exportToCoreFn (A.ValueOpRef _ _) = [] exportToCoreFn (A.TypeClassRef _ name) = [properToIdent name] exportToCoreFn (A.TypeInstanceRef _ name) = [name] -exportToCoreFn _ = [] +exportToCoreFn (A.ModuleRef _ _) = [] +exportToCoreFn (A.ReExportRef _ _ _) = [] -- | Makes a typeclass dictionary constructor function. The returned expression -- is a function that accepts the superclass instances and member diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 798ce2b843..8ed85cf3d1 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -11,6 +11,7 @@ import Prelude.Compat import Data.Aeson import Data.Aeson.Types (Parser, Value, listParser) +import qualified Data.Map.Strict as M import Data.Text (Text) import qualified Data.Text as T import qualified Data.Vector as V @@ -124,6 +125,7 @@ moduleFromJSON = withObject "Module" moduleFromObj moduleSourceSpan <- o .: "sourceSpan" >>= sourceSpanFromJSON modulePath moduleImports <- o .: "imports" >>= listParser (importFromJSON modulePath) moduleExports <- o .: "exports" >>= listParser identFromJSON + moduleReExports <- o .: "reExports" >>= reExportsFromJSON moduleDecls <- o .: "decls" >>= listParser (bindFromJSON modulePath) moduleForeign <- o .: "foreign" >>= listParser identFromJSON moduleComments <- o .: "comments" >>= listParser parseJSON @@ -142,6 +144,9 @@ moduleFromJSON = withObject "Module" moduleFromObj mn <- o .: "moduleName" >>= moduleNameFromJSON return (ann, mn)) + reExportsFromJSON :: Value -> Parser (M.Map ModuleName [Ident]) + reExportsFromJSON = fmap (M.map (map Ident)) . parseJSON + bindFromJSON :: FilePath -> Value -> Parser (Bind Ann) bindFromJSON modulePath = withObject "Bind" bindFromObj where diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index d4212ea56f..a53077389a 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -2,6 +2,8 @@ module Language.PureScript.CoreFn.Module where import Prelude.Compat +import Data.Map.Strict (Map) + import Language.PureScript.AST.SourcePos import Language.PureScript.Comments import Language.PureScript.CoreFn.Expr @@ -20,6 +22,7 @@ data Module a = Module , modulePath :: FilePath , moduleImports :: [(a, ModuleName)] , moduleExports :: [Ident] + , moduleReExports :: Map ModuleName [Ident] , moduleForeign :: [Ident] , moduleDecls :: [Bind a] } deriving (Show) diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index ec54c1e5c7..ddd8b77c9f 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -11,6 +11,7 @@ import Prelude.Compat import Control.Arrow ((***)) import Data.Either (isLeft) +import qualified Data.Map.Strict as M import Data.Maybe (maybe) import Data.Aeson import Data.Version (Version, showVersion) @@ -109,6 +110,7 @@ moduleToJSON v m = object , T.pack "modulePath" .= toJSON (modulePath m) , T.pack "imports" .= map importToJSON (moduleImports m) , T.pack "exports" .= map identToJSON (moduleExports m) + , T.pack "reExports" .= reExportsToJSON (moduleReExports m) , T.pack "foreign" .= map identToJSON (moduleForeign m) , T.pack "decls" .= map bindToJSON (moduleDecls m) , T.pack "builtWith" .= toJSON (showVersion v) @@ -121,6 +123,9 @@ moduleToJSON v m = object , T.pack "moduleName" .= moduleNameToJSON mn ] + reExportsToJSON :: M.Map ModuleName [Ident] -> Value + reExportsToJSON = toJSON . M.map (map runIdent) + bindToJSON :: Bind Ann -> Value bindToJSON (NonRec ann n e) = object diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index 4ee82ad0d3..ace8223fac 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -109,7 +109,7 @@ renameInModules :: [Module Ann] -> [Module Ann] renameInModules = map go where go :: Module Ann -> Module Ann - go m@(Module _ _ _ _ _ _ _ decls) = m { moduleDecls = map (renameInDecl' (findDeclIdents decls)) decls } + go m@(Module _ _ _ _ _ _ _ _ decls) = m { moduleDecls = map (renameInDecl' (findDeclIdents decls)) decls } renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann renameInDecl' scope = runRename scope . renameInDecl True diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index 04b9fa9185..b4eff97481 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -10,6 +10,7 @@ import Prelude.Compat import Data.Aeson import Data.Aeson.Types as Aeson +import Data.Map as M import Data.Version import Language.PureScript.AST.Literals @@ -49,7 +50,7 @@ spec = context "CoreFnFromJsonTest" $ do specify "should parse version" $ do let v = Version [0, 13, 6] [] - m = Module ss [] mn mp [] [] [] [] + m = Module ss [] mn mp [] [] M.empty [] [] r = fst <$> parseModule (moduleToJSON v m) r `shouldSatisfy` isSuccess case r of @@ -57,42 +58,50 @@ spec = context "CoreFnFromJsonTest" $ do Aeson.Success v' -> v' `shouldBe` v specify "should parse an empty module" $ do - let r = parseMod $ Module ss [] mn mp [] [] [] [] + let r = parseMod $ Module ss [] mn mp [] [] M.empty [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () Aeson.Success m -> moduleName m `shouldBe` mn specify "should parse source span" $ do - let r = parseMod $ Module ss [] mn mp [] [] [] [] + let r = parseMod $ Module ss [] mn mp [] [] M.empty [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () Aeson.Success m -> moduleSourceSpan m `shouldBe` ss specify "should parse module path" $ do - let r = parseMod $ Module ss [] mn mp [] [] [] [] + let r = parseMod $ Module ss [] mn mp [] [] M.empty [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () Aeson.Success m -> modulePath m `shouldBe` mp specify "should parse imports" $ do - let r = parseMod $ Module ss [] mn mp [(ann, mn)] [] [] [] + let r = parseMod $ Module ss [] mn mp [(ann, mn)] [] M.empty [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () Aeson.Success m -> moduleImports m `shouldBe` [(ann, mn)] specify "should parse exports" $ do - let r = parseMod $ Module ss [] mn mp [] [Ident "exp"] [] [] + let r = parseMod $ Module ss [] mn mp [] [Ident "exp"] M.empty [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () Aeson.Success m -> moduleExports m `shouldBe` [Ident "exp"] + specify "should parse re-exports" $ do + let r = parseMod $ Module ss [] mn mp [] [] (M.singleton (ModuleName "Example.A") [Ident "exp"]) [] [] + r `shouldSatisfy` isSuccess + case r of + Error _ -> return () + Aeson.Success m -> moduleReExports m `shouldBe` M.singleton (ModuleName "Example.A") [Ident "exp"] + + specify "should parse foreign" $ do - let r = parseMod $ Module ss [] mn mp [] [] [Ident "exp"] [] + let r = parseMod $ Module ss [] mn mp [] [] M.empty [Ident "exp"] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () @@ -100,7 +109,7 @@ spec = context "CoreFnFromJsonTest" $ do context "Expr" $ do specify "should parse literals" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "x1") $ Literal ann (NumericLiteral (Left 1)) , NonRec ann (Ident "x2") $ Literal ann (NumericLiteral (Right 1.0)) , NonRec ann (Ident "x3") $ Literal ann (StringLiteral (mkString "abc")) @@ -112,18 +121,18 @@ spec = context "CoreFnFromJsonTest" $ do parseMod m `shouldSatisfy` isSuccess specify "should parse Constructor" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "constructor") $ Constructor ann (ProperName "Either") (ProperName "Left") [Ident "value0"] ] parseMod m `shouldSatisfy` isSuccess specify "should parse Accessor" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "x") $ Accessor ann (mkString "field") (Literal ann $ ObjectLiteral [(mkString "field", Literal ann (NumericLiteral (Left 1)))]) ] parseMod m `shouldSatisfy` isSuccess specify "should parse ObjectUpdate" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "objectUpdate") $ ObjectUpdate ann (Literal ann $ ObjectLiteral [(mkString "field", Literal ann (StringLiteral (mkString "abc")))]) @@ -132,14 +141,14 @@ spec = context "CoreFnFromJsonTest" $ do parseMod m `shouldSatisfy` isSuccess specify "should parse Abs" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "abs") $ Abs ann (Ident "x") (Var ann (Qualified (Just mn) (Ident "x"))) ] parseMod m `shouldSatisfy` isSuccess specify "should parse App" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "app") $ App ann (Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "x")))) @@ -148,7 +157,7 @@ spec = context "CoreFnFromJsonTest" $ do parseMod m `shouldSatisfy` isSuccess specify "should parse Case" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ Case ann [Var ann (Qualified Nothing (Ident "x"))] [ CaseAlternative @@ -159,7 +168,7 @@ spec = context "CoreFnFromJsonTest" $ do parseMod m `shouldSatisfy` isSuccess specify "should parse Case with guards" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ Case ann [Var ann (Qualified Nothing (Ident "x"))] [ CaseAlternative @@ -170,7 +179,7 @@ spec = context "CoreFnFromJsonTest" $ do parseMod m `shouldSatisfy` isSuccess specify "should parse Let" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ Let ann [ Rec [((ann, Ident "a"), Var ann (Qualified Nothing (Ident "x")))] ] @@ -180,28 +189,28 @@ spec = context "CoreFnFromJsonTest" $ do context "Meta" $ do specify "should parse IsConstructor" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec (ss, [], Nothing, Just (IsConstructor ProductType [Ident "x"])) (Ident "x") $ Literal (ss, [], Nothing, Just (IsConstructor SumType [])) (CharLiteral 'a') ] parseMod m `shouldSatisfy` isSuccess specify "should parse IsNewtype" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec (ss, [], Nothing, Just IsNewtype) (Ident "x") $ Literal ann (CharLiteral 'a') ] parseMod m `shouldSatisfy` isSuccess specify "should parse IsTypeClassConstructor" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec (ss, [], Nothing, Just IsTypeClassConstructor) (Ident "x") $ Literal ann (CharLiteral 'a') ] parseMod m `shouldSatisfy` isSuccess specify "should parse IsForeign" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec (ss, [], Nothing, Just IsForeign) (Ident "x") $ Literal ann (CharLiteral 'a') ] @@ -209,7 +218,7 @@ spec = context "CoreFnFromJsonTest" $ do context "Binders" $ do specify "should parse LiteralBinder" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ Case ann [Var ann (Qualified Nothing (Ident "x"))] [ CaseAlternative @@ -220,7 +229,7 @@ spec = context "CoreFnFromJsonTest" $ do parseMod m `shouldSatisfy` isSuccess specify "should parse VarBinder" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ Case ann [Var ann (Qualified Nothing (Ident "x"))] [ CaseAlternative @@ -236,7 +245,7 @@ spec = context "CoreFnFromJsonTest" $ do parseMod m `shouldSatisfy` isSuccess specify "should parse NamedBinder" $ do - let m = Module ss [] mn mp [] [] [] + let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ Case ann [Var ann (Qualified Nothing (Ident "x"))] [ CaseAlternative @@ -248,9 +257,9 @@ spec = context "CoreFnFromJsonTest" $ do context "Comments" $ do specify "should parse LineComment" $ do - let m = Module ss [ LineComment "line" ] mn mp [] [] [] [] + let m = Module ss [ LineComment "line" ] mn mp [] [] M.empty [] [] parseMod m `shouldSatisfy` isSuccess specify "should parse BlockComment" $ do - let m = Module ss [ BlockComment "block" ] mn mp [] [] [] [] + let m = Module ss [ BlockComment "block" ] mn mp [] [] M.empty [] [] parseMod m `shouldSatisfy` isSuccess diff --git a/tests/purs/passing/ReExportsExported.js b/tests/purs/passing/ReExportsExported.js new file mode 100644 index 0000000000..b73154be1e --- /dev/null +++ b/tests/purs/passing/ReExportsExported.js @@ -0,0 +1,4 @@ +"use strict"; + +// Import `A.a` which was re-exported from `B` and then again from `C` +exports.a = require('../C').a; diff --git a/tests/purs/passing/ReExportsExported.purs b/tests/purs/passing/ReExportsExported.purs new file mode 100644 index 0000000000..077e20f1c0 --- /dev/null +++ b/tests/purs/passing/ReExportsExported.purs @@ -0,0 +1,7 @@ +module Main where + +import Effect.Console (log) + +foreign import a :: String + +main = log a diff --git a/tests/purs/passing/ReExportsExported/A.purs b/tests/purs/passing/ReExportsExported/A.purs new file mode 100644 index 0000000000..3371489f29 --- /dev/null +++ b/tests/purs/passing/ReExportsExported/A.purs @@ -0,0 +1,4 @@ +module A (a) where + +a :: String +a = "Done" diff --git a/tests/purs/passing/ReExportsExported/B.purs b/tests/purs/passing/ReExportsExported/B.purs new file mode 100644 index 0000000000..84af99b864 --- /dev/null +++ b/tests/purs/passing/ReExportsExported/B.purs @@ -0,0 +1,7 @@ +module B (module A, A(..)) where + +import A + +-- | Test that there's no name collision between the imported module `A` and the +-- | data constructor `A`. +data A = A diff --git a/tests/purs/passing/ReExportsExported/C.purs b/tests/purs/passing/ReExportsExported/C.purs new file mode 100644 index 0000000000..222d09c31f --- /dev/null +++ b/tests/purs/passing/ReExportsExported/C.purs @@ -0,0 +1,4 @@ +module C (module B) where + +-- | `A.a` was re-exported from `B` and then again from `C` +import B From a7a3f83cdea63dfcf8dba0da2f26131aaab5ac51 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 25 Jun 2020 18:47:32 +0100 Subject: [PATCH 1218/1580] Check role declarations against inferred roles (#3873) * Check role declarations against inferred roles Fixes #3867. The main change here is that we are now storing checked roles in the `types` field of the Environment for `data` and `foreign import data` declarations, via the additions to the `TypeKind` type. Because we are storing roles in the environment, we no longer need to infer roles for any given type more than once. As such, `checkRoles` now works in a monad with `MonadState CheckState`, and when we come across another type while inferring roles, we can simply look its roles up from the Environment. The BindingGroups desugaring step ensures that types are in topological order, so this is safe: any mentioned types' roles will already have been checked and stored in the Environment. One case that we do not yet handle is types which cyclically depend on each other, e.g. data F a = F (G a) data G a = G (F a) Rather than crashing the compiler, these will now be incorrectly marked Phantom. I would like to address this in a future PR. * Fix warnings * Update error message as suggested in code review * Code review: use `withRoles` * Use Nominal role for Prim.TypeError classes * Remove unnecessary import * Fix golden test * Move nominalRolesForKind to Environment.hs --- .../Language/PureScript/AST/Declarations.hs | 1 + .../src/Language/PureScript/Environment.hs | 127 ++++------ .../src/Language/PureScript/Roles.hs | 8 + src/Language/PureScript.hs | 1 + src/Language/PureScript/Errors.hs | 20 ++ src/Language/PureScript/Externs.hs | 19 +- src/Language/PureScript/Ide/CaseSplit.hs | 4 +- src/Language/PureScript/Ide/Externs.hs | 2 - .../PureScript/Interactive/Printer.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 31 ++- .../PureScript/TypeChecker/Entailment.hs | 6 +- src/Language/PureScript/TypeChecker/Monad.hs | 2 +- src/Language/PureScript/TypeChecker/Roles.hs | 239 ++++++++++-------- tests/purs/failing/CoercibleNominal.purs | 2 +- .../purs/failing/CoercibleNominalWrapped.purs | 2 +- tests/purs/failing/CoercibleRoleMismatch1.out | 15 ++ .../purs/failing/CoercibleRoleMismatch1.purs | 6 + tests/purs/failing/CoercibleRoleMismatch2.out | 15 ++ .../purs/failing/CoercibleRoleMismatch2.purs | 10 + tests/purs/failing/CoercibleRoleMismatch3.out | 15 ++ .../purs/failing/CoercibleRoleMismatch3.purs | 10 + 21 files changed, 326 insertions(+), 211 deletions(-) create mode 100644 tests/purs/failing/CoercibleRoleMismatch1.out create mode 100644 tests/purs/failing/CoercibleRoleMismatch1.purs create mode 100644 tests/purs/failing/CoercibleRoleMismatch2.out create mode 100644 tests/purs/failing/CoercibleRoleMismatch2.purs create mode 100644 tests/purs/failing/CoercibleRoleMismatch3.out create mode 100644 tests/purs/failing/CoercibleRoleMismatch3.purs diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs index d7249be9dd..e8fef561b0 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs @@ -80,6 +80,7 @@ data ErrorMessageHint | ErrorInTypeDeclaration Ident | ErrorInTypeClassDeclaration (ProperName 'ClassName) | ErrorInKindDeclaration (ProperName 'TypeName) + | ErrorInRoleDeclaration (ProperName 'TypeName) | ErrorInForeignImport Ident | ErrorSolvingConstraint SourceConstraint | PositionedError (NEL.NonEmpty SourceSpan) diff --git a/lib/purescript-ast/src/Language/PureScript/Environment.hs b/lib/purescript-ast/src/Language/PureScript/Environment.hs index feb10f81f8..f2324e413e 100644 --- a/lib/purescript-ast/src/Language/PureScript/Environment.hs +++ b/lib/purescript-ast/src/Language/PureScript/Environment.hs @@ -36,7 +36,10 @@ data Environment = Environment -- ^ Data constructors currently in scope, along with their associated type -- constructor name, argument types and return type. , roleDeclarations :: M.Map (Qualified (ProperName 'TypeName)) [Role] - -- ^ Explicit role declarations currently in scope. + -- ^ Explicit role declarations currently in scope. Note that this field is + -- only used to store declared roles temporarily until they can be checked; + -- to find a type's real checked and/or inferred roles, refer to the TypeKind + -- in the `types` field. , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType) -- ^ Type synonyms currently in scope , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) @@ -100,17 +103,7 @@ instance A.ToJSON FunctionalDependency where -- | The initial environment with no values and only the default javascript types defined initEnvironment :: Environment -initEnvironment = Environment M.empty allPrimTypes M.empty primRoles M.empty M.empty allPrimClasses - --- | --- A lookup table of role definitions for primitive types whose constructors --- won't be present in any environment. -primRoles :: M.Map (Qualified (ProperName 'TypeName)) [Role] -primRoles = M.fromList - [ (primName "Function", [Representational, Representational]) - , (primName "Array", [Representational]) - , (primName "Record", [Representational]) - ] +initEnvironment = Environment M.empty allPrimTypes M.empty M.empty M.empty M.empty allPrimClasses -- | A constructor for TypeClassData that computes which type class arguments are fully determined -- and argument covering sets. @@ -213,11 +206,11 @@ instance Serialise NameKind -- | The kinds of a type data TypeKind - = DataType [(Text, Maybe SourceType)] [(ProperName 'ConstructorName, [SourceType])] + = DataType [(Text, Maybe SourceType, Role)] [(ProperName 'ConstructorName, [SourceType])] -- ^ Data type | TypeSynonym -- ^ Type synonym - | ExternData + | ExternData [Role] -- ^ Foreign data | LocalTypeVariable -- ^ A local type variable @@ -228,29 +221,6 @@ data TypeKind instance NFData TypeKind instance Serialise TypeKind -instance A.ToJSON TypeKind where - toJSON (DataType args ctors) = - A.object [ T.pack "DataType" .= A.object ["args" .= args, "ctors" .= ctors] ] - toJSON TypeSynonym = A.toJSON (T.pack "TypeSynonym") - toJSON ExternData = A.toJSON (T.pack "ExternData") - toJSON LocalTypeVariable = A.toJSON (T.pack "LocalTypeVariable") - toJSON ScopedTypeVar = A.toJSON (T.pack "ScopedTypeVar") - -instance A.FromJSON TypeKind where - parseJSON (A.Object o) = do - args <- o .: "DataType" - A.withObject "args" (\o1 -> - DataType <$> o1 .: "args" - <*> o1 .: "ctors") args - parseJSON (A.String s) = - case s of - "TypeSynonym" -> pure TypeSynonym - "ExternData" -> pure ExternData - "LocalTypeVariable" -> pure LocalTypeVariable - "ScopedTypeVar" -> pure ScopedTypeVar - _ -> fail "Unknown TypeKind" - parseJSON _ = fail "Invalid TypeKind" - -- | The type ('data' or 'newtype') of a data type declaration data DataDeclType = Data @@ -387,9 +357,11 @@ function t1 t2 = TypeApp nullSourceAnn (TypeApp nullSourceAnn tyFunction t1) t2 infixr 4 -:> primClass :: Qualified (ProperName 'TypeName) -> (SourceType -> SourceType) -> [(Qualified (ProperName 'TypeName), (SourceType, TypeKind))] -primClass name mkTy = - [ (name, (mkTy kindConstraint, ExternData)) - , (dictSynonymName <$> name, (mkTy kindType, TypeSynonym)) +primClass name mkKind = + [ let k = mkKind kindConstraint + in (name, (k, ExternData (nominalRolesForKind k))) + , let k = mkKind kindType + in (dictSynonymName <$> name, (k, TypeSynonym)) ] -- | The primitive types in the external environment with their @@ -398,19 +370,19 @@ primClass name mkTy = primTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primTypes = M.fromList - [ (primName "Type", (kindType, ExternData)) - , (primName "Constraint", (kindType, ExternData)) - , (primName "Symbol", (kindType, ExternData)) - , (primName "Row", (kindType -:> kindType, ExternData)) - , (primName "Function", (kindType -:> kindType -:> kindType, ExternData)) - , (primName "Array", (kindType -:> kindType, ExternData)) - , (primName "Record", (kindRow kindType -:> kindType, ExternData)) - , (primName "String", (kindType, ExternData)) - , (primName "Char", (kindType, ExternData)) - , (primName "Number", (kindType, ExternData)) - , (primName "Int", (kindType, ExternData)) - , (primName "Boolean", (kindType, ExternData)) - , (primName "Partial", (kindConstraint, ExternData)) + [ (primName "Type", (kindType, ExternData [])) + , (primName "Constraint", (kindType, ExternData [])) + , (primName "Symbol", (kindType, ExternData [])) + , (primName "Row", (kindType -:> kindType, ExternData [Phantom])) + , (primName "Function", (kindType -:> kindType -:> kindType, ExternData [Representational, Representational])) + , (primName "Array", (kindType -:> kindType, ExternData [Representational])) + , (primName "Record", (kindRow kindType -:> kindType, ExternData [Representational])) + , (primName "String", (kindType, ExternData [])) + , (primName "Char", (kindType, ExternData [])) + , (primName "Number", (kindType, ExternData [])) + , (primName "Int", (kindType, ExternData [])) + , (primName "Boolean", (kindType, ExternData [])) + , (primName "Partial", (kindConstraint, ExternData [])) ] -- | This 'Map' contains all of the prim types from all Prim modules. @@ -429,8 +401,8 @@ allPrimTypes = M.unions primBooleanTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primBooleanTypes = M.fromList - [ (primSubName C.moduleBoolean "True", (tyBoolean, ExternData)) - , (primSubName C.moduleBoolean "False", (tyBoolean, ExternData)) + [ (primSubName C.moduleBoolean "True", (tyBoolean, ExternData [])) + , (primSubName C.moduleBoolean "False", (tyBoolean, ExternData [])) ] primCoerceTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) @@ -442,10 +414,10 @@ primCoerceTypes = primOrderingTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primOrderingTypes = M.fromList - [ (primSubName C.moduleOrdering "Ordering", (kindType, ExternData)) - , (primSubName C.moduleOrdering "LT", (kindOrdering, ExternData)) - , (primSubName C.moduleOrdering "EQ", (kindOrdering, ExternData)) - , (primSubName C.moduleOrdering "GT", (kindOrdering, ExternData)) + [ (primSubName C.moduleOrdering "Ordering", (kindType, ExternData [])) + , (primSubName C.moduleOrdering "LT", (kindOrdering, ExternData [])) + , (primSubName C.moduleOrdering "EQ", (kindOrdering, ExternData [])) + , (primSubName C.moduleOrdering "GT", (kindOrdering, ExternData [])) ] primRowTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) @@ -460,9 +432,9 @@ primRowTypes = primRowListTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primRowListTypes = M.fromList $ - [ (primSubName C.moduleRowList "RowList", (kindType -:> kindType, ExternData)) - , (primSubName C.moduleRowList "Cons", (tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRowList (tyVar "k") -:> kindRowList (tyVar "k"), ExternData)) - , (primSubName C.moduleRowList "Nil", (tyForall "k" kindType $ kindRowList (tyVar "k"), ExternData)) + [ (primSubName C.moduleRowList "RowList", (kindType -:> kindType, ExternData [Phantom])) + , (primSubName C.moduleRowList "Cons", (tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRowList (tyVar "k") -:> kindRowList (tyVar "k"), ExternData [Phantom, Phantom, Phantom])) + , (primSubName C.moduleRowList "Nil", (tyForall "k" kindType $ kindRowList (tyVar "k"), ExternData [])) ] <> mconcat [ primClass (primSubName C.moduleRowList "RowToList") (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRowList (tyVar "k") -:> kind) ] @@ -478,14 +450,14 @@ primSymbolTypes = primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primTypeErrorTypes = M.fromList $ - [ (primSubName C.typeError "Doc", (kindType, ExternData)) - , (primSubName C.typeError "Fail", (kindDoc -:> kindConstraint, ExternData)) - , (primSubName C.typeError "Warn", (kindDoc -:> kindConstraint, ExternData)) - , (primSubName C.typeError "Text", (kindSymbol -:> kindDoc, ExternData)) - , (primSubName C.typeError "Quote", (kindType -:> kindDoc, ExternData)) - , (primSubName C.typeError "QuoteLabel", (kindSymbol -:> kindDoc, ExternData)) - , (primSubName C.typeError "Beside", (kindDoc -:> kindDoc -:> kindDoc, ExternData)) - , (primSubName C.typeError "Above", (kindDoc -:> kindDoc -:> kindDoc, ExternData)) + [ (primSubName C.typeError "Doc", (kindType, ExternData [])) + , (primSubName C.typeError "Fail", (kindDoc -:> kindConstraint, ExternData [Nominal])) + , (primSubName C.typeError "Warn", (kindDoc -:> kindConstraint, ExternData [Nominal])) + , (primSubName C.typeError "Text", (kindSymbol -:> kindDoc, ExternData [Phantom])) + , (primSubName C.typeError "Quote", (kindType -:> kindDoc, ExternData [Phantom])) + , (primSubName C.typeError "QuoteLabel", (kindSymbol -:> kindDoc, ExternData [Phantom])) + , (primSubName C.typeError "Beside", (kindDoc -:> kindDoc -:> kindDoc, ExternData [Phantom, Phantom])) + , (primSubName C.typeError "Above", (kindDoc -:> kindDoc -:> kindDoc, ExternData [Phantom, Phantom])) ] <> mconcat [ primClass (primSubName C.typeError "Fail") (\kind -> kindDoc -:> kind) , primClass (primSubName C.typeError "Warn") (\kind -> kindDoc -:> kind) @@ -626,7 +598,7 @@ lookupNewtypeConstructor env ty@(Qualified mn _) = (_, DataType tvs [(ctor, [wrappedTy])]) -> M.lookup (Qualified mn ctor) (dataConstructors env) >>= \case (Newtype, _, _, ids) -> - pure (map fst tvs, wrappedTy, ids) + pure (map (\(name, _, _) -> name) tvs, wrappedTy, ids) _ -> Nothing _ -> @@ -655,3 +627,16 @@ dictSynonymName = ProperName . dictSynonymName' . runProperName isDictSynonym :: ProperName a -> Bool isDictSynonym = T.isSuffixOf "$Dict" . runProperName + +-- | +-- Given the kind of a type, generate a list @Nominal@ roles. This is used for +-- opaque foreign types as well as type classes. +nominalRolesForKind :: Type a -> [Role] +nominalRolesForKind k = replicate (kindArity k) Nominal + +kindArity :: Type a -> Int +kindArity = go 0 where + go n (TypeApp _ (TypeApp _ fn _) k) + | eqType fn tyFunction = go (n + 1) k + go n (ForAll _ _ _ k _) = go n k + go n _ = n diff --git a/lib/purescript-ast/src/Language/PureScript/Roles.hs b/lib/purescript-ast/src/Language/PureScript/Roles.hs index 1ac1fb74fa..e680ceecd4 100644 --- a/lib/purescript-ast/src/Language/PureScript/Roles.hs +++ b/lib/purescript-ast/src/Language/PureScript/Roles.hs @@ -5,6 +5,7 @@ -- module Language.PureScript.Roles ( Role(..) + , displayRole ) where import Prelude.Compat @@ -13,6 +14,7 @@ import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import qualified Data.Aeson as A import qualified Data.Aeson.TH as A +import Data.Text (Text) import GHC.Generics (Generic) -- | @@ -33,3 +35,9 @@ instance NFData Role instance Serialise Role $(A.deriveJSON A.defaultOptions ''Role) + +displayRole :: Role -> Text +displayRole r = case r of + Nominal -> "nominal" + Representational -> "representational" + Phantom -> "phantom" diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index 23549a5653..d1e70f73d2 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -25,6 +25,7 @@ import Language.PureScript.Names as P import Language.PureScript.Options as P import Language.PureScript.Pretty as P import Language.PureScript.Renamer as P +import Language.PureScript.Roles as P import Language.PureScript.Sugar as P import Language.PureScript.TypeChecker as P import Language.PureScript.Types as P diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 373a2bd4c7..aff0ba0742 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -41,6 +41,7 @@ import Language.PureScript.Names import Language.PureScript.Pretty import Language.PureScript.Pretty.Common (endWith) import Language.PureScript.PSString (decodeStringWithReplacement) +import Language.PureScript.Roles import Language.PureScript.Traversals import Language.PureScript.Types import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers @@ -174,6 +175,11 @@ data SimpleErrorMessage | QuantificationCheckFailureInType [Int] SourceType | VisibleQuantificationCheckFailureInType Text | UnsupportedTypeInKind SourceType + -- | Declared role was more permissive than inferred. + | RoleMismatch + Text -- ^ Type variable in question + Role -- ^ inferred role + Role -- ^ declared role deriving (Show) data ErrorMessage = ErrorMessage @@ -329,6 +335,7 @@ errorCode em = case unwrapErrorMessage em of QuantificationCheckFailureInType {} -> "QuantificationCheckFailureInType" VisibleQuantificationCheckFailureInType {} -> "VisibleQuantificationCheckFailureInType" UnsupportedTypeInKind {} -> "UnsupportedTypeInKind" + RoleMismatch {} -> "RoleMismatch" -- | A stack trace for an error newtype MultipleErrors = MultipleErrors @@ -1277,6 +1284,15 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , line "is not supported in kinds." ] + renderSimpleErrorMessage (RoleMismatch var inferred declared) = + paras + [ line $ "Role mismatch for the type parameter " <> markCode var <> ":" + , indent . line $ + "The annotation says " <> markCode (displayRole declared) <> + " but the role " <> markCode (displayRole inferred) <> + " is required." + ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1@RCons{} t2@RCons{}) detail = let (row1Box, row2Box) = printRows t1 t2 @@ -1412,6 +1428,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ detail , line $ "in kind declaration for " <> markCode (runProperName name) ] + renderHint (ErrorInRoleDeclaration name) detail = + paras [ detail + , line $ "in role declaration for " <> markCode (runProperName name) + ] renderHint (ErrorInForeignImport nm) detail = paras [ detail , line $ "in foreign import " <> markCode (showIdent nm) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 97b6d99320..9d3253bc3e 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -33,7 +33,6 @@ import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Names -import Language.PureScript.Roles import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types @@ -115,11 +114,6 @@ data ExternsDeclaration = , edTypeKind :: SourceType , edTypeDeclarationKind :: TypeKind } - -- | A role declaration - | EDRole - { edRoleTypeName :: ProperName 'TypeName - , edRoleRoles :: [Role] - } -- | A type synonym | EDTypeSynonym { edTypeSynonymName :: ProperName 'TypeName @@ -175,7 +169,6 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar where applyDecl :: Environment -> ExternsDeclaration -> Environment applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) } - applyDecl env (EDRole pn roles) = env { roleDeclarations = M.insert (qual pn) roles (roleDeclarations env) } applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) } applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } @@ -206,7 +199,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} efImports = mapMaybe importDecl ds efFixities = mapMaybe fixityDecl ds efTypeFixities = mapMaybe typeFixityDecl ds - efDeclarations = concatMap toExternsDeclaration efExports ++ mapMaybe roleDecl ds + efDeclarations = concatMap toExternsDeclaration efExports efSourceSpan = ss fixityDecl :: Declaration -> Maybe ExternsFixity @@ -226,17 +219,13 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} importDecl (ImportDeclaration _ m mt qmn) = Just (ExternsImport m mt qmn) importDecl _ = Nothing - roleDecl :: Declaration -> Maybe ExternsDeclaration - roleDecl (RoleDeclaration (RoleDeclarationData _ name roles)) = Just (EDRole name roles) - roleDecl _ = Nothing - toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration] toExternsDeclaration (TypeRef _ pn dctors) = case Qualified (Just mn) pn `M.lookup` types env of Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration" Just (kind, TypeSynonym) | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ] - Just (kind, ExternData) -> [ EDType pn kind ExternData ] + Just (kind, ExternData rs) -> [ EDType pn kind (ExternData rs) ] Just (kind, tk@(DataType _ tys)) -> EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args | dctor <- fromMaybe (map fst tys) dctors @@ -249,10 +238,10 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} toExternsDeclaration (TypeClassRef _ className) | let dictName = dictSynonymName . coerceProperName $ className , Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env - , Just (kind, ExternData) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env + , Just (kind, ExternData rs) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env , Just (synKind, TypeSynonym) <- Qualified (Just mn) dictName `M.lookup` types env , Just (synArgs, synTy) <- Qualified (Just mn) dictName `M.lookup` typeSynonyms env - = [ EDType (coerceProperName className) kind ExternData + = [ EDType (coerceProperName className) kind (ExternData rs) , EDType dictName synKind TypeSynonym , EDTypeSynonym dictName synArgs synTy , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies typeClassIsEmpty diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 993bf1fa4f..a4b557ce36 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -44,7 +44,7 @@ explicitAnnotations = WildcardAnnotations True noAnnotations :: WildcardAnnotations noAnnotations = WildcardAnnotations False -type DataType = ([(Text, Maybe P.SourceType)], [(P.ProperName 'P.ConstructorName, [P.SourceType])]) +type DataType = ([(Text, Maybe P.SourceType, P.Role)], [(P.ProperName 'P.ConstructorName, [P.SourceType])]) caseSplit :: (Ide m, MonadError IdeError m) @@ -54,7 +54,7 @@ caseSplit q = do type' <- parseType' q (tc, args) <- splitTypeConstructor type' (typeVars, ctors) <- findTypeDeclaration tc - let applyTypeVars = P.everywhereOnTypes (P.replaceAllTypeVars (zip (map fst typeVars) args)) + let applyTypeVars = P.everywhereOnTypes (P.replaceAllTypeVars (zip (map (\(name, _, _) -> name) typeVars) args)) let appliedCtors = map (second (map applyTypeVars)) ctors pure appliedCtors diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 6542d0bc77..1849b764fd 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -114,8 +114,6 @@ convertDecl ed = case ed of (Just (IdeDeclDataConstructor (IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType))) - P.EDRole{..} -> - Right Nothing P.EDValue{..} -> Right (Just (IdeDeclValue (IdeValue edValueName edValueType))) P.EDClass{..} -> diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index a0e5f01277..665954ce43 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -113,7 +113,7 @@ printModuleSignatures moduleName P.Environment{..} = _ -> "data" in - Just $ textT (prefix <> " " <> P.runProperName name <> foldMap ((" " <>) . fst) typevars) Box.// printCons pt + Just $ textT (prefix <> " " <> P.runProperName name <> foldMap ((" " <>) . (\(v, _, _) -> v)) typevars) Box.// printCons pt _ -> Nothing diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 36a616b330..90c01eab5f 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -36,6 +36,7 @@ import Language.PureScript.Names import Language.PureScript.Roles import Language.PureScript.TypeChecker.Kinds as T import Language.PureScript.TypeChecker.Monad as T +import Language.PureScript.TypeChecker.Roles as T import Language.PureScript.TypeChecker.Synonyms as T import Language.PureScript.TypeChecker.Types as T import Language.PureScript.TypeChecker.Unify (varIfUnknown) @@ -49,7 +50,7 @@ addDataType => ModuleName -> DataDeclType -> ProperName 'TypeName - -> [(Text, Maybe SourceType)] + -> [(Text, Maybe SourceType, Role)] -> [(DataConstructorDeclaration, SourceType)] -> SourceType -> m () @@ -80,13 +81,17 @@ addDataConstructor moduleName dtype name dctor dctorArgs polyType = do checkTypeSynonyms polyType putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } -addRoleDeclaration +-- | Add an explicit role declaration to the Environment. The idea is that we +-- do this before encountering the data type which it refers to; we don't check +-- that the role declaration is valid until we encounter the data type's own +-- declaration. +addExplicitRoleDeclaration :: (MonadState CheckState m, MonadError MultipleErrors m) => ModuleName -> ProperName 'TypeName -> [Role] -> m () -addRoleDeclaration moduleName name roles = do +addExplicitRoleDeclaration moduleName name roles = do env <- getEnv putEnv $ env { roleDeclarations = M.insert (Qualified (Just moduleName) name) roles (roleDeclarations env) } @@ -149,7 +154,7 @@ addTypeClass _ qualifiedClassName args implies dependencies ds kind = do unless (hasSig || not (containsForAll kind)) $ do tell . errorMessage $ MissingKindDeclaration ClassSig (disqualify qualName) kind traverse_ (checkMemberIsUsable newClass (typeSynonyms env) (types env)) classMembers - putEnv $ env { types = M.insert qualName (kind, ExternData) (types env) + putEnv $ env { types = M.insert qualName (kind, ExternData (nominalRolesForKind kind)) (types env) , typeClasses = M.insert qualifiedClassName newClass (typeClasses env) } where classMembers :: [(Ident, SourceType)] @@ -250,6 +255,8 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms -- -- * Type-check all values and add them to the @Environment@ -- +-- * Infer all type roles and add them to the @Environment@ +-- -- * Bring type class instances into scope -- -- * Process module imports @@ -270,7 +277,9 @@ typeCheckAll moduleName _ = traverse go checkDuplicateTypeArguments $ map fst args (dataCtors, ctorKind) <- kindOfData moduleName (sa, name, args, dctors) let args' = args `withKinds` ctorKind - addDataType moduleName dtype name args' dataCtors ctorKind + roles <- checkRoles moduleName name args' dctors + let args'' = args' `withRoles` roles + addDataType moduleName dtype name args'' dataCtors ctorKind return $ DataDeclaration sa dtype name args dctors go (d@(DataBindingGroupDeclaration tys)) = do let tysList = NEL.toList tys @@ -284,7 +293,7 @@ typeCheckAll moduleName _ = traverse go for_ (zip dataDecls data_ks) $ \((dtype, (_, name, args, dctors)), (dataCtors, ctorKind)) -> do when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args - let args' = args `withKinds` ctorKind + let args' = args `withKinds` ctorKind `withRoles` repeat Phantom addDataType moduleName dtype name args' dataCtors ctorKind for_ (zip syns syn_ks) $ \((_, name, args, _), (elabTy, kind)) -> do checkDuplicateTypeArguments $ map fst args @@ -318,7 +327,7 @@ typeCheckAll moduleName _ = traverse go putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (elabTy, LocalTypeVariable) (types env) } return $ KindDeclaration sa kindFor name elabTy go d@(RoleDeclaration (RoleDeclarationData _sa name roles)) = do - addRoleDeclaration moduleName name roles + addExplicitRoleDeclaration moduleName name roles return d go TypeDeclaration{} = internalError "Type declarations should have been removed before typeCheckAlld" @@ -352,7 +361,10 @@ typeCheckAll moduleName _ = traverse go go (d@(ExternDataDeclaration _ name kind)) = do elabKind <- withFreshSubstitution $ checkKindDeclaration moduleName kind env <- getEnv - putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (elabKind, ExternData) (types env) } + let qualName = Qualified (Just moduleName) name + -- If there's an explicit role declaration, just trust it + let roles = fromMaybe (nominalRolesForKind elabKind) $ M.lookup qualName (roleDeclarations env) + putEnv $ env { types = M.insert qualName (elabKind, ExternData roles) (types env) } return d go (d@(ExternDeclaration (ss, _) name ty)) = do warnAndRethrow (addHint (ErrorInForeignImport name) . addHint (positionedError ss)) $ do @@ -545,6 +557,9 @@ typeCheckAll moduleName _ = traverse go withKinds ((s, Nothing):ss) (TypeApp _ (TypeApp _ tyFn k1) k2) | eqType tyFn tyFunction = (s, Just k1) : withKinds ss k2 withKinds _ _ = internalError "Invalid arguments to withKinds" + withRoles :: [(Text, Maybe SourceType)] -> [Role] -> [(Text, Maybe SourceType, Role)] + withRoles = zipWith $ \(v, k) r -> (v, k, r) + checkNewtype :: forall m . MonadError MultipleErrors m diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 7caa9eae7f..28eb25261a 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -417,15 +417,15 @@ entails SolverOptions{..} constraint context hints = t | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b - , not (null axs) && not (null bxs) && aTyName == bTyName - , tyRoles <- inferRoles env aTyName -> do + , not (null axs) && not (null bxs) && aTyName == bTyName -> do -- If both arguments are applications of the same type constructor -- (e.g. @data D a b = D a@ in the constraint -- @Coercible (D a b) (D a' b')@), infer the roles of the type -- constructor's arguments and generate wanted constraints -- appropriately (e.g. here @a@ is representational and @b@ is -- phantom, yielding @Coercible a a'@). - let k role ax bx = case role of + let tyRoles = lookupEnvRoles env aTyName + k role ax bx = case role of Nominal -- If we had first-class equality constraints, we'd just -- emit one of the form @(a ~ b)@ here and let the solver diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 26daaf5903..37411fb5a8 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -378,7 +378,7 @@ debugTypes = go <=< M.toList . types decl = case which of DataType _ _ -> "data" TypeSynonym -> "type" - ExternData -> "extern" + ExternData _ -> "extern" LocalTypeVariable -> "local" ScopedTypeVar -> "scoped" guard (not (isPrefixOf "Prim" name)) diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index bc0f0c7b5d..d2411f3ffc 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -5,11 +5,15 @@ -- Role inference -- module Language.PureScript.TypeChecker.Roles - ( inferRoles + ( lookupEnvRoles + , checkRoles ) where import Prelude.Compat +import Control.Monad +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State.Class (MonadState(..)) import Data.Coerce (coerce) import qualified Data.Map as M import Data.Maybe (fromMaybe) @@ -17,9 +21,11 @@ import qualified Data.Set as S import Data.Text (Text) import Language.PureScript.Environment +import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Roles import Language.PureScript.Types +import Language.PureScript.TypeChecker.Monad -- | -- A map of a type's formal parameter names to their roles. This type's @@ -38,112 +44,133 @@ instance Monoid RoleMap where RoleMap M.empty -- | --- Given an environment and the qualified name of a type constructor in that --- environment, returns a list of roles, in the order they are defined in the --- type definition. -inferRoles :: Environment -> Qualified (ProperName 'TypeName) -> [Role] -inferRoles env tyName - | Just roles <- M.lookup tyName (roleDeclarations env) = +-- Lookup the roles for a type in the environment. If the type does not have +-- roles (e.g. is a type synonym or a type variable), then this function +-- returns an empty list. +-- +lookupEnvRoles + :: Environment + -> Qualified (ProperName 'TypeName) + -> [Role] +lookupEnvRoles env tyName = + case fmap snd $ M.lookup tyName (types env) of + Just (DataType args _) -> + map (\(_, _, role) -> role) args + Just (ExternData roles) -> roles - | Just (_, DataType tvs ctors) <- envMeta = - -- A plain data type. For each constructor the type has, walk its list of - -- field types and accumulate a list of (formal parameter name, role) - -- pairs. Then, walk the list of defined parameters, ensuring both that - -- every parameter appears (with a default role of phantom) and that they - -- appear in the right order. - let ctorRoles = getRoleMap $ foldMap (foldMap (walk mempty) . snd) ctors - in map (\(tv, _) -> fromMaybe Phantom (M.lookup tv ctorRoles)) tvs - | Just (k, ExternData) <- envMeta = - -- A foreign data type. Since the type will have no defined constructors - -- nor associated data types, infer the set of type parameters from its - -- kind and assume in the absence of role signatures that all such - -- parameters are nominal. - rolesFromForeignTypeKind k - | otherwise = + _ -> [] + +-- | This function does the following: +-- +-- * Infers roles for the given data type declaration +-- +-- * Compares the inferred roles to the explicitly declared roles (if any) and +-- ensures that the explicitly declared roles are not more permissive than +-- the inferred ones +-- +checkRoles + :: forall m + . (MonadError MultipleErrors m, MonadState CheckState m) + => ModuleName + -> ProperName 'TypeName + -- ^ The name of the data type whose roles we are checking + -> [(Text, Maybe SourceType)] + -- ^ type parameters for the data type whose roles we are checking + -> [DataConstructorDeclaration] + -- ^ constructors of the data type whose roles we are checking + -> m [Role] +checkRoles moduleName tyName tyArgs ctors = do + let qualName = Qualified (Just moduleName) tyName + roleMaps <- traverse (walk mempty . snd) $ ctors >>= dataCtorFields + let + ctorRoles = getRoleMap $ mconcat roleMaps + inferredRoles = map (\(arg, _) -> fromMaybe Phantom (M.lookup arg ctorRoles)) tyArgs + env <- getEnv + rethrow (addHint (ErrorInRoleDeclaration tyName)) $ do + case M.lookup qualName (roleDeclarations env) of + Just declaredRoles -> do + let + k (var, _) inf dec = + if inf < dec + then throwError . errorMessage $ RoleMismatch var inf dec + else pure dec + sequence $ zipWith3 k tyArgs inferredRoles declaredRoles + Nothing -> + pure inferredRoles where - envTypes = types env - envMeta = M.lookup tyName envTypes - -- This function is named walk to match the specification given in the "Role - -- inference" section of the paper "Safe Zero-cost Coercions for Haskell". - walk :: S.Set Text -> SourceType -> RoleMap - walk btvs (TypeVar _ v) - -- A type variable standing alone (e.g. @a@ in @data D a b = D a@) is - -- representational, _unless_ it has been bound by a quantifier, in which - -- case it is not actually a parameter to the type (e.g. @z@ in - -- @data T z = T (forall z. z -> z)@). - | S.member v btvs = - mempty - | otherwise = - RoleMap $ M.singleton v Representational - walk btvs (ForAll _ tv _ t _) = - -- We can walk under universal quantifiers as long as we make note of the - -- variables that they bind. For instance, given a definition - -- @data T z = T (forall z. z -> z)@, we will make note that @z@ is bound - -- by a quantifier so that we do not mark @T@'s parameter as - -- representational later on. Similarly, given a definition like - -- @data D a = D (forall r. r -> a)@, we'll mark @r@ as bound so that it - -- doesn't appear as a spurious parameter to @D@ when we complete - -- inference. - walk (S.insert tv btvs) t - walk btvs (RCons _ _ thead ttail) = - -- For row types, we just walk along them and collect the results. - walk btvs thead <> walk btvs ttail - walk btvs (KindedType _ t _k) = - -- For kind-annotated types, discard the annotation and recurse on the - -- type beneath. - walk btvs t + -- This function is named @walk@ to match the specification given in the + -- "Role inference" section of the paper "Safe Zero-cost Coercions for + -- Haskell". + walk :: S.Set Text -> SourceType -> m RoleMap + walk btvs (TypeVar _ v) + -- A type variable standing alone (e.g. @a@ in @data D a b = D a@) is + -- representational, _unless_ it has been bound by a quantifier, in which + -- case it is not actually a parameter to the type (e.g. @z@ in + -- @data T z = T (forall z. z -> z)@). + | S.member v btvs = + pure mempty + | otherwise = + pure $ RoleMap $ M.singleton v Representational + walk btvs (ForAll _ tv _ t _) = + -- We can walk under universal quantifiers as long as we make note of the + -- variables that they bind. For instance, given a definition + -- @data T z = T (forall z. z -> z)@, we will make note that @z@ is bound + -- by a quantifier so that we do not mark @T@'s parameter as + -- representational later on. Similarly, given a definition like + -- @data D a = D (forall r. r -> a)@, we'll mark @r@ as bound so that it + -- doesn't appear as a spurious parameter to @D@ when we complete + -- inference. + walk (S.insert tv btvs) t + walk btvs (RCons _ _ thead ttail) = do + -- For row types, we just walk along them and collect the results. + h <- walk btvs thead + t <- walk btvs ttail + pure (h <> t) + walk btvs (KindedType _ t _k) = + -- For kind-annotated types, discard the annotation and recurse on the + -- type beneath. walk btvs t - | (t1, _, t2s) <- unapplyTypes t - , not $ null t2s = - case t1 of - -- If the type is an application of a type constructor to some - -- arguments, recursively infer the roles of the type constructor's - -- arguments. For each (role, argument) pair: - -- - -- * If the role is nominal, mark all free variables in the - -- argument as nominal also, since they cannot be coerced if the - -- argument's nominality is to be preserved. - -- * If the role is representational, recurse on the argument, since - -- its use of our parameters is important. - -- * If the role is phantom, terminate, since the argument's use of - -- our parameters is unimportant. - TypeConstructor _ t1Name -> - let t1Roles = inferRoles env t1Name - k role ti = case role of - Nominal -> - freeNominals ti - Representational -> - go ti - Phantom -> - mempty - in mconcat (zipWith k t1Roles t2s) - -- If the type is an application of any other type-level term, walk - -- that term to collect its roles and mark all free variables in - -- its argument as nominal. - _ -> - go t1 <> foldMap freeNominals t2s - | otherwise = - mempty - where - go = walk btvs - -- Given a type, computes the list of free variables in that type - -- (taking into account those bound in @walk@) and returns a @RoleMap@ - -- ascribing a nominal role to each of those variables. - freeNominals x = - let ftvs = filter (flip S.notMember btvs) (freeTypeVariables x) - in RoleMap (M.fromList $ map (, Nominal) ftvs) - --- | --- Given the kind of a foreign type, generate a list @Nominal@ roles which, in --- the absence of a role signature, provides the safest default for a type whose --- constructors are opaque to us. -rolesFromForeignTypeKind :: SourceType -> [Role] -rolesFromForeignTypeKind k = replicate (kindArity k) Nominal - -kindArity :: SourceType -> Int -kindArity = go 0 where - go n (TypeApp _ (TypeApp _ fn _) k) - | fn == tyFunction = go (n + 1) k - go n (ForAll _ _ _ k _) = go n k - go n _ = n + walk btvs t + | (t1, _, t2s) <- unapplyTypes t + , not $ null t2s = + case t1 of + -- If the type is an application of a type constructor to some + -- arguments, recursively infer the roles of the type constructor's + -- arguments. For each (role, argument) pair: + -- + -- * If the role is nominal, mark all free variables in the + -- argument as nominal also, since they cannot be coerced if the + -- argument's nominality is to be preserved. + -- * If the role is representational, recurse on the argument, since + -- its use of our parameters is important. + -- * If the role is phantom, terminate, since the argument's use of + -- our parameters is unimportant. + TypeConstructor _ t1Name -> do + env <- getEnv + let + t1Roles = lookupEnvRoles env t1Name + k role ti = case role of + Nominal -> + pure $ freeNominals ti + Representational -> + go ti + Phantom -> + pure mempty + fmap mconcat (zipWithM k t1Roles t2s) + -- If the type is an application of any other type-level term, walk + -- that term to collect its roles and mark all free variables in + -- its argument as nominal. + _ -> do + r <- go t1 + pure (r <> foldMap freeNominals t2s) + | otherwise = + pure mempty + where + go = walk btvs + -- Given a type, computes the list of free variables in that type + -- (taking into account those bound in @walk@) and returns a @RoleMap@ + -- ascribing a nominal role to each of those variables. + freeNominals x = + let ftvs = filter (flip S.notMember btvs) (freeTypeVariables x) + in RoleMap (M.fromList $ map (, Nominal) ftvs) diff --git a/tests/purs/failing/CoercibleNominal.purs b/tests/purs/failing/CoercibleNominal.purs index 479bdef759..365328227d 100644 --- a/tests/purs/failing/CoercibleNominal.purs +++ b/tests/purs/failing/CoercibleNominal.purs @@ -3,7 +3,7 @@ module Main where import Safe.Coerce (coerce) -data Nominal a b = Nominal a b +data Nominal a (b :: Type) = Nominal a type role Nominal nominal phantom diff --git a/tests/purs/failing/CoercibleNominalWrapped.purs b/tests/purs/failing/CoercibleNominalWrapped.purs index c79451e125..f679a2605f 100644 --- a/tests/purs/failing/CoercibleNominalWrapped.purs +++ b/tests/purs/failing/CoercibleNominalWrapped.purs @@ -3,7 +3,7 @@ module Main where import Safe.Coerce (coerce) -data Nominal a b = Nominal a b +data Nominal a (b :: Type) = Nominal a type role Nominal nominal phantom diff --git a/tests/purs/failing/CoercibleRoleMismatch1.out b/tests/purs/failing/CoercibleRoleMismatch1.out new file mode 100644 index 0000000000..5f9ba80805 --- /dev/null +++ b/tests/purs/failing/CoercibleRoleMismatch1.out @@ -0,0 +1,15 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleRoleMismatch1.purs:4:1 - 4:29 (line 4, column 1 - line 4, column 29) + + Role mismatch for the type parameter a: + + The annotation says phantom but the role representational is required. + + +in role declaration for Identity +in type constructor Identity + +See https://github.com/purescript/documentation/blob/master/errors/RoleMismatch.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleRoleMismatch1.purs b/tests/purs/failing/CoercibleRoleMismatch1.purs new file mode 100644 index 0000000000..d7980a9ad6 --- /dev/null +++ b/tests/purs/failing/CoercibleRoleMismatch1.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith RoleMismatch +module Main where + +data Identity a = Identity a + +type role Identity phantom diff --git a/tests/purs/failing/CoercibleRoleMismatch2.out b/tests/purs/failing/CoercibleRoleMismatch2.out new file mode 100644 index 0000000000..aded3eef96 --- /dev/null +++ b/tests/purs/failing/CoercibleRoleMismatch2.out @@ -0,0 +1,15 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleRoleMismatch2.purs:8:1 - 8:23 (line 8, column 1 - line 8, column 23) + + Role mismatch for the type parameter a: + + The annotation says phantom but the role nominal is required. + + +in role declaration for V +in type constructor V + +See https://github.com/purescript/documentation/blob/master/errors/RoleMismatch.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleRoleMismatch2.purs b/tests/purs/failing/CoercibleRoleMismatch2.purs new file mode 100644 index 0000000000..65d499fae5 --- /dev/null +++ b/tests/purs/failing/CoercibleRoleMismatch2.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith RoleMismatch +module Main where + +data T r (p :: Type) n = T r n + +type role T representational phantom nominal + +data V a = V (T a a a) + +type role V phantom diff --git a/tests/purs/failing/CoercibleRoleMismatch3.out b/tests/purs/failing/CoercibleRoleMismatch3.out new file mode 100644 index 0000000000..45c82181bb --- /dev/null +++ b/tests/purs/failing/CoercibleRoleMismatch3.out @@ -0,0 +1,15 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleRoleMismatch3.purs:8:1 - 8:23 (line 8, column 1 - line 8, column 23) + + Role mismatch for the type parameter a: + + The annotation says representational but the role nominal is required. + + +in role declaration for U +in type constructor U + +See https://github.com/purescript/documentation/blob/master/errors/RoleMismatch.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleRoleMismatch3.purs b/tests/purs/failing/CoercibleRoleMismatch3.purs new file mode 100644 index 0000000000..d19b6d1993 --- /dev/null +++ b/tests/purs/failing/CoercibleRoleMismatch3.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith RoleMismatch +module Main where + +data T r (p :: Type) n = T r n + +type role T representational phantom nominal + +data U a = U (T a a a) + +type role U representational From d5ce6551a61cccf9d81d678d5c8d5a7bda0be727 Mon Sep 17 00:00:00 2001 From: milesfrain Date: Thu, 25 Jun 2020 18:53:32 -0700 Subject: [PATCH 1219/1580] Faster warnDuplicateRefs (#3899) * Faster warnDuplicateRefs * Fixup - KindRef removed from DeclarationRef * Add to CONTRIBUTORS.md * Update tests with warnings for ALL duplicates * Revert "Update tests with warnings for ALL duplicates" This reverts commit 00a18591a33360fdbdf4de2269d88d98be13b328. * Discard one element from each set of duplicates * Modify tests for different warning ordering --- CONTRIBUTORS.md | 1 + .../Language/PureScript/AST/Declarations.hs | 22 +++++++++++++++++++ src/Language/PureScript/Sugar/Names/Common.hs | 15 +++++++++++-- tests/purs/warning/DuplicateExportRef.out | 8 +++---- tests/purs/warning/DuplicateImportRef.out | 4 ++-- 5 files changed, 42 insertions(+), 8 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 648ff2ab71..71f41bc4b1 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -77,6 +77,7 @@ If you would prefer to use different terms, please use the section below instead | [@mgmeier](https://github.com/mgmeier) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) | | [@michaelficarra](https://github.com/michaelficarra) | Michael Ficarra | [MIT license](http://opensource.org/licenses/MIT) | | [@MichaelXavier](https://github.com/MichaelXavier) | Michael Xavier | MIT license | +| [@milesfrain](https://github.com/milesfrain) | Miles Frain | [MIT license](http://opensource.org/licenses/MIT) | | [@mjgpy3](https://github.com/mjgpy3) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) | | [@mpietrzak](https://github.com/mpietrzak) | Maciej Pietrzak | [MIT license](http://opensource.org/licenses/MIT) | | [@mrhania](https://github.com/mrhania) | Łukasz Hanuszczak | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs index e8fef561b0..5b451e904c 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs @@ -194,6 +194,28 @@ instance Eq DeclarationRef where (ReExportRef _ mn ref) == (ReExportRef _ mn' ref') = mn == mn' && ref == ref' _ == _ = False +instance Ord DeclarationRef where + TypeRef _ name dctors `compare` TypeRef _ name' dctors' = compare name name' <> compare dctors dctors' + TypeOpRef _ name `compare` TypeOpRef _ name' = compare name name' + ValueRef _ name `compare` ValueRef _ name' = compare name name' + ValueOpRef _ name `compare` ValueOpRef _ name' = compare name name' + TypeClassRef _ name `compare` TypeClassRef _ name' = compare name name' + TypeInstanceRef _ name `compare` TypeInstanceRef _ name' = compare name name' + ModuleRef _ name `compare` ModuleRef _ name' = compare name name' + ReExportRef _ mn ref `compare` ReExportRef _ mn' ref' = compare mn mn' <> compare ref ref' + compare ref ref' = + compare (orderOf ref) (orderOf ref') + where + orderOf :: DeclarationRef -> Int + orderOf TypeRef{} = 0 + orderOf TypeOpRef{} = 1 + orderOf ValueRef{} = 2 + orderOf ValueOpRef{} = 3 + orderOf TypeClassRef{} = 4 + orderOf TypeInstanceRef{} = 5 + orderOf ModuleRef{} = 6 + orderOf ReExportRef{} = 7 + data ExportSource = ExportSource { exportSourceImportedFrom :: Maybe ModuleName diff --git a/src/Language/PureScript/Sugar/Names/Common.hs b/src/Language/PureScript/Sugar/Names/Common.hs index 6a681401e2..c2542cdbbd 100644 --- a/src/Language/PureScript/Sugar/Names/Common.hs +++ b/src/Language/PureScript/Sugar/Names/Common.hs @@ -6,7 +6,7 @@ import Protolude (ordNub) import Control.Monad.Writer (MonadWriter(..)) import Data.Foldable (for_) -import Data.List (nub, (\\)) +import Data.List (group, sort, (\\)) import Data.Maybe (mapMaybe) import Language.PureScript.AST @@ -24,7 +24,7 @@ warnDuplicateRefs -> m () warnDuplicateRefs pos toError refs = do let withoutCtors = deleteCtors `map` refs - dupeRefs = mapMaybe (refToName pos) $ withoutCtors \\ nub withoutCtors + dupeRefs = mapMaybe (refToName pos) $ removeUnique withoutCtors dupeCtors = concat $ mapMaybe (extractCtors pos) refs for_ (dupeRefs ++ dupeCtors) $ \(pos', name) -> @@ -32,6 +32,17 @@ warnDuplicateRefs pos toError refs = do where + -- Removes all unique elements from list + -- as well as one of each duplicate. + -- Example: + -- removeUnique [1,2,2,3,3,3,4] == [2,3,3] + -- Note that it may be more correct to keep ALL duplicates, + -- but that requires additional changes in how warnings are printed. + -- Example of keeping all duplicates (not what this code currently does): + -- removeUnique [1,2,2,3,3,3,4] == [2,2,3,3,3] + removeUnique :: Eq a => Ord a => [a] -> [a] + removeUnique = concatMap (drop 1) . group . sort + -- Deletes the constructor information from TypeRefs so that only the -- referenced type is used in the duplicate check - constructors are handled -- separately diff --git a/tests/purs/warning/DuplicateExportRef.out b/tests/purs/warning/DuplicateExportRef.out index ee67bd3275..82efd3bf36 100644 --- a/tests/purs/warning/DuplicateExportRef.out +++ b/tests/purs/warning/DuplicateExportRef.out @@ -14,7 +14,7 @@ Warning 2 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) - Export list contains multiple references to value fn + Export list contains multiple references to type operator (~>) See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, @@ -25,7 +25,7 @@ Warning 3 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) - Export list contains multiple references to operator (!) + Export list contains multiple references to value fn See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, @@ -36,7 +36,7 @@ Warning 4 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) - Export list contains multiple references to type class Y + Export list contains multiple references to operator (!) See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, @@ -47,7 +47,7 @@ Warning 5 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) - Export list contains multiple references to type operator (~>) + Export list contains multiple references to type class Y See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, diff --git a/tests/purs/warning/DuplicateImportRef.out b/tests/purs/warning/DuplicateImportRef.out index 1ae248536c..0e5f7101b9 100644 --- a/tests/purs/warning/DuplicateImportRef.out +++ b/tests/purs/warning/DuplicateImportRef.out @@ -25,7 +25,7 @@ Warning 3 of 4: in module Main at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) - Import list contains multiple references to type class Functor + Import list contains multiple references to operator (<>) See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, @@ -36,7 +36,7 @@ Warning 4 of 4: in module Main at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) - Import list contains multiple references to operator (<>) + Import list contains multiple references to type class Functor See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, From 5e3f01d892bcf23a7c3775274e6fb8ba5a214851 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 4 Jul 2020 16:04:08 +0100 Subject: [PATCH 1220/1580] Pin language-javascript to a specific version (#3904) This prevents issues like https://github.com/purescript-web/purescript-web-html/issues/31 where different distributions might end up with different versions of this library. --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index da2ee395c1..93ffaff252 100644 --- a/package.yaml +++ b/package.yaml @@ -65,7 +65,7 @@ dependencies: - fsnotify >=0.2.1 - Glob >=0.9 && <0.10 - haskeline >=0.7.0.0 && <0.8.0.0 - - language-javascript >=0.7.0.0 + - language-javascript ==0.7.0.0 # important: keep this pinned to a single specific version, since it's effectively part of the compiler's public API. - lifted-async >=0.10.0.3 && <0.10.1 - lifted-base >=0.2.3 && <0.2.4 - memory >=0.14 && <0.15 From 37ec7370883387a3832eaad636821a20f7337087 Mon Sep 17 00:00:00 2001 From: Cyril Date: Sat, 11 Jul 2020 20:28:00 +0200 Subject: [PATCH 1221/1580] Check roles of mutually recursive types (#3860) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Check roles of mutually recursive types * Don’t build a map each roles lookup --- src/Language/PureScript/TypeChecker.hs | 19 ++- .../PureScript/TypeChecker/Entailment.hs | 2 +- src/Language/PureScript/TypeChecker/Roles.hs | 157 ++++++++++++------ tests/purs/failing/CoercibleRoleMismatch4.out | 15 ++ .../purs/failing/CoercibleRoleMismatch4.purs | 8 + tests/purs/failing/CoercibleRoleMismatch5.out | 15 ++ .../purs/failing/CoercibleRoleMismatch5.purs | 7 + tests/purs/passing/Coercible.purs | 18 ++ 8 files changed, 185 insertions(+), 56 deletions(-) create mode 100644 tests/purs/failing/CoercibleRoleMismatch4.out create mode 100644 tests/purs/failing/CoercibleRoleMismatch4.purs create mode 100644 tests/purs/failing/CoercibleRoleMismatch5.out create mode 100644 tests/purs/failing/CoercibleRoleMismatch5.purs diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 90c01eab5f..de7459a89f 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -277,7 +277,8 @@ typeCheckAll moduleName _ = traverse go checkDuplicateTypeArguments $ map fst args (dataCtors, ctorKind) <- kindOfData moduleName (sa, name, args, dctors) let args' = args `withKinds` ctorKind - roles <- checkRoles moduleName name args' dctors + env <- getEnv + roles <- checkRoles env moduleName name args' dctors let args'' = args' `withRoles` roles addDataType moduleName dtype name args'' dataCtors ctorKind return $ DataDeclaration sa dtype name args dctors @@ -289,18 +290,22 @@ typeCheckAll moduleName _ = traverse go bindingGroupNames = ordNub ((syns^..traverse._2) ++ (dataDecls^..traverse._2._2) ++ (fmap coerceProperName (clss^..traverse._2._2))) sss = fmap declSourceSpan tys warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames) . addHint (PositionedError sss)) $ do + env <- getEnv (syn_ks, data_ks, cls_ks) <- kindsOfAll moduleName syns (fmap snd dataDecls) (fmap snd clss) - for_ (zip dataDecls data_ks) $ \((dtype, (_, name, args, dctors)), (dataCtors, ctorKind)) -> do - when (dtype == Newtype) $ checkNewtype name dctors - checkDuplicateTypeArguments $ map fst args - let args' = args `withKinds` ctorKind `withRoles` repeat Phantom - addDataType moduleName dtype name args' dataCtors ctorKind + let dataDeclsWithKinds = zipWith (\(dtype, (_, name, args, _)) (dataCtors, ctorKind) -> (dtype, name, args `withKinds` ctorKind, dataCtors, ctorKind)) dataDecls data_ks + checkRoles' = checkDataBindingGroupRoles env moduleName $ + map (\(_, name, args, dataCtors, _) -> (name, args, map fst dataCtors)) dataDeclsWithKinds + for_ dataDeclsWithKinds $ \(dtype, name, args', dataCtors, ctorKind) -> do + when (dtype == Newtype) $ checkNewtype name (map fst dataCtors) + checkDuplicateTypeArguments $ map fst args' + roles <- checkRoles' name args' + let args'' = args' `withRoles` roles + addDataType moduleName dtype name args'' dataCtors ctorKind for_ (zip syns syn_ks) $ \((_, name, args, _), (elabTy, kind)) -> do checkDuplicateTypeArguments $ map fst args let args' = args `withKinds` kind addTypeSynonym moduleName name args' elabTy kind for_ (zip clss cls_ks) $ \((deps, (sa, pn, _, _, _)), (args', implies', tys', kind)) -> do - env <- getEnv let qualifiedClassName = Qualified (Just moduleName) pn guardWith (errorMessage (DuplicateTypeClass pn (fst sa))) $ not (M.member qualifiedClassName (typeClasses env)) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 28eb25261a..7ef955e790 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -424,7 +424,7 @@ entails SolverOptions{..} constraint context hints = -- constructor's arguments and generate wanted constraints -- appropriately (e.g. here @a@ is representational and @b@ is -- phantom, yielding @Coercible a a'@). - let tyRoles = lookupEnvRoles env aTyName + let tyRoles = lookupRoles env aTyName k role ax bx = case role of Nominal -- If we had first-class equality constraints, we'd just diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index d2411f3ffc..a08f5ee80b 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -5,19 +5,20 @@ -- Role inference -- module Language.PureScript.TypeChecker.Roles - ( lookupEnvRoles + ( lookupRoles , checkRoles + , checkDataBindingGroupRoles ) where import Prelude.Compat -import Control.Monad import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.State (MonadState(..), runState, state) import Data.Coerce (coerce) import qualified Data.Map as M import Data.Maybe (fromMaybe) import qualified Data.Set as S +import Data.Semigroup (Any(..)) import Data.Text (Text) import Language.PureScript.Environment @@ -25,7 +26,6 @@ import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Roles import Language.PureScript.Types -import Language.PureScript.TypeChecker.Monad -- | -- A map of a type's formal parameter names to their roles. This type's @@ -43,23 +43,43 @@ instance Monoid RoleMap where mempty = RoleMap M.empty +type RoleEnv = M.Map (Qualified (ProperName 'TypeName)) [Role] + +typeKindRoles :: TypeKind -> Maybe [Role] +typeKindRoles = \case + DataType args _ -> + Just $ map (\(_, _, role) -> role) args + ExternData roles -> + Just roles + _ -> + Nothing + +getRoleEnv :: Environment -> RoleEnv +getRoleEnv env = + M.mapMaybe (typeKindRoles . snd) (types env) + +updateRoleEnv + :: Qualified (ProperName 'TypeName) + -> [Role] + -> RoleEnv + -> (Any, RoleEnv) +updateRoleEnv qualTyName roles' roleEnv = + let roles = fromMaybe (repeat Phantom) $ M.lookup qualTyName roleEnv + mostRestrictiveRoles = zipWith min roles roles' + didRolesChange = any (uncurry (<)) $ zip mostRestrictiveRoles roles + in (Any didRolesChange, M.insert qualTyName mostRestrictiveRoles roleEnv) + -- | -- Lookup the roles for a type in the environment. If the type does not have -- roles (e.g. is a type synonym or a type variable), then this function -- returns an empty list. -- -lookupEnvRoles +lookupRoles :: Environment -> Qualified (ProperName 'TypeName) -> [Role] -lookupEnvRoles env tyName = - case fmap snd $ M.lookup tyName (types env) of - Just (DataType args _) -> - map (\(_, _, role) -> role) args - Just (ExternData roles) -> - roles - _ -> - [] +lookupRoles env tyName = + fromMaybe [] $ M.lookup tyName (types env) >>= typeKindRoles . snd -- | This function does the following: -- @@ -71,8 +91,9 @@ lookupEnvRoles env tyName = -- checkRoles :: forall m - . (MonadError MultipleErrors m, MonadState CheckState m) - => ModuleName + . (MonadError MultipleErrors m) + => Environment + -> ModuleName -> ProperName 'TypeName -- ^ The name of the data type whose roles we are checking -> [(Text, Maybe SourceType)] @@ -80,38 +101,82 @@ checkRoles -> [DataConstructorDeclaration] -- ^ constructors of the data type whose roles we are checking -> m [Role] -checkRoles moduleName tyName tyArgs ctors = do - let qualName = Qualified (Just moduleName) tyName - roleMaps <- traverse (walk mempty . snd) $ ctors >>= dataCtorFields - let - ctorRoles = getRoleMap $ mconcat roleMaps - inferredRoles = map (\(arg, _) -> fromMaybe Phantom (M.lookup arg ctorRoles)) tyArgs - env <- getEnv - rethrow (addHint (ErrorInRoleDeclaration tyName)) $ do - case M.lookup qualName (roleDeclarations env) of - Just declaredRoles -> do - let - k (var, _) inf dec = - if inf < dec - then throwError . errorMessage $ RoleMismatch var inf dec - else pure dec - sequence $ zipWith3 k tyArgs inferredRoles declaredRoles - Nothing -> - pure inferredRoles +checkRoles env moduleName tyName tyArgs ctors = + checkDataBindingGroupRoles env moduleName [(tyName, tyArgs, ctors)] tyName tyArgs + +type DataDeclaration = + ( ProperName 'TypeName + , [(Text, Maybe SourceType)] + , [DataConstructorDeclaration] + ) + +checkDataBindingGroupRoles + :: forall m + . (MonadError MultipleErrors m) + => Environment + -> ModuleName + -> [DataDeclaration] + -> ProperName 'TypeName + -> [(Text, Maybe SourceType)] + -> m [Role] +checkDataBindingGroupRoles env moduleName group = + let initialRoleEnv = M.union (roleDeclarations env) (getRoleEnv env) + inferredRoleEnv = inferDataBindingGroupRoles moduleName group initialRoleEnv + in \tyName tyArgs -> do + let qualTyName = Qualified (Just moduleName) tyName + inferredRoles = M.lookup qualTyName inferredRoleEnv + rethrow (addHint (ErrorInRoleDeclaration tyName)) $ do + case M.lookup qualTyName (roleDeclarations env) of + Just declaredRoles -> do + let + k (var, _) inf dec = + if inf < dec + then throwError . errorMessage $ RoleMismatch var inf dec + else pure dec + sequence $ zipWith3 k tyArgs (fromMaybe (repeat Phantom) inferredRoles) declaredRoles + Nothing -> + pure $ fromMaybe (Phantom <$ tyArgs) inferredRoles + +inferDataBindingGroupRoles + :: ModuleName + -> [DataDeclaration] + -> RoleEnv + -> RoleEnv +inferDataBindingGroupRoles moduleName group roleEnv = + let (Any didRolesChange, roleEnv') = flip runState roleEnv $ + mconcat <$> traverse (state . inferDataDeclarationRoles moduleName) group + in if didRolesChange + then inferDataBindingGroupRoles moduleName group roleEnv' + else roleEnv' + +-- | +-- Infers roles for the given data type declaration, along with a flag to tell +-- if more restrictive roles were added to the environment. +-- +inferDataDeclarationRoles + :: ModuleName + -> DataDeclaration + -> RoleEnv + -> (Any, RoleEnv) +inferDataDeclarationRoles moduleName (tyName, tyArgs, ctors) roleEnv = + let qualTyName = Qualified (Just moduleName) tyName + ctorRoles = getRoleMap . foldMap (walk mempty . snd) $ ctors >>= dataCtorFields + inferredRoles = map (\(arg, _) -> fromMaybe Phantom (M.lookup arg ctorRoles)) tyArgs + in updateRoleEnv qualTyName inferredRoles roleEnv where -- This function is named @walk@ to match the specification given in the -- "Role inference" section of the paper "Safe Zero-cost Coercions for -- Haskell". - walk :: S.Set Text -> SourceType -> m RoleMap + walk :: S.Set Text -> SourceType -> RoleMap walk btvs (TypeVar _ v) -- A type variable standing alone (e.g. @a@ in @data D a b = D a@) is -- representational, _unless_ it has been bound by a quantifier, in which -- case it is not actually a parameter to the type (e.g. @z@ in -- @data T z = T (forall z. z -> z)@). | S.member v btvs = - pure mempty + mempty | otherwise = - pure $ RoleMap $ M.singleton v Representational + RoleMap $ M.singleton v Representational walk btvs (ForAll _ tv _ t _) = -- We can walk under universal quantifiers as long as we make note of the -- variables that they bind. For instance, given a definition @@ -124,9 +189,7 @@ checkRoles moduleName tyName tyArgs ctors = do walk (S.insert tv btvs) t walk btvs (RCons _ _ thead ttail) = do -- For row types, we just walk along them and collect the results. - h <- walk btvs thead - t <- walk btvs ttail - pure (h <> t) + walk btvs thead <> walk btvs ttail walk btvs (KindedType _ t _k) = -- For kind-annotated types, discard the annotation and recurse on the -- type beneath. @@ -146,26 +209,24 @@ checkRoles moduleName tyName tyArgs ctors = do -- its use of our parameters is important. -- * If the role is phantom, terminate, since the argument's use of -- our parameters is unimportant. - TypeConstructor _ t1Name -> do - env <- getEnv + TypeConstructor _ t1Name -> let - t1Roles = lookupEnvRoles env t1Name + t1Roles = fromMaybe (repeat Phantom) $ M.lookup t1Name roleEnv k role ti = case role of Nominal -> - pure $ freeNominals ti + freeNominals ti Representational -> go ti Phantom -> - pure mempty - fmap mconcat (zipWithM k t1Roles t2s) + mempty + in mconcat (zipWith k t1Roles t2s) -- If the type is an application of any other type-level term, walk -- that term to collect its roles and mark all free variables in -- its argument as nominal. _ -> do - r <- go t1 - pure (r <> foldMap freeNominals t2s) + go t1 <> foldMap freeNominals t2s | otherwise = - pure mempty + mempty where go = walk btvs -- Given a type, computes the list of free variables in that type diff --git a/tests/purs/failing/CoercibleRoleMismatch4.out b/tests/purs/failing/CoercibleRoleMismatch4.out new file mode 100644 index 0000000000..853afeca35 --- /dev/null +++ b/tests/purs/failing/CoercibleRoleMismatch4.out @@ -0,0 +1,15 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleRoleMismatch4.purs:4:1 - 4:19 (line 4, column 1 - line 4, column 19) + + Role mismatch for the type parameter a: + + The annotation says representational but the role nominal is required. + + +in role declaration for F +in data binding group F, G + +See https://github.com/purescript/documentation/blob/master/errors/RoleMismatch.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleRoleMismatch4.purs b/tests/purs/failing/CoercibleRoleMismatch4.purs new file mode 100644 index 0000000000..cb31fa590b --- /dev/null +++ b/tests/purs/failing/CoercibleRoleMismatch4.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith RoleMismatch +module Main where + +data F a = F (G a) +type role F representational + +data G a = G (F a) +type role G nominal diff --git a/tests/purs/failing/CoercibleRoleMismatch5.out b/tests/purs/failing/CoercibleRoleMismatch5.out new file mode 100644 index 0000000000..faabd7cc0e --- /dev/null +++ b/tests/purs/failing/CoercibleRoleMismatch5.out @@ -0,0 +1,15 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleRoleMismatch5.purs:4:1 - 4:21 (line 4, column 1 - line 4, column 21) + + Role mismatch for the type parameter a: + + The annotation says phantom but the role representational is required. + + +in role declaration for F +in data binding group F, G + +See https://github.com/purescript/documentation/blob/master/errors/RoleMismatch.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleRoleMismatch5.purs b/tests/purs/failing/CoercibleRoleMismatch5.purs new file mode 100644 index 0000000000..f656f507eb --- /dev/null +++ b/tests/purs/failing/CoercibleRoleMismatch5.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith RoleMismatch +module Main where + +data F a = F a (G a) +type role F phantom + +data G a = G (F a) diff --git a/tests/purs/passing/Coercible.purs b/tests/purs/passing/Coercible.purs index bffa099eb7..684b0e10cd 100644 --- a/tests/purs/passing/Coercible.purs +++ b/tests/purs/passing/Coercible.purs @@ -163,4 +163,22 @@ type ContextualKeywords = , role :: String ) +data MutuallyRecursivePhantom1 a + = MutuallyRecursivePhantom1 (MutuallyRecursivePhantom2 a) + +data MutuallyRecursivePhantom2 a + = MutuallyRecursivePhantom2 (MutuallyRecursivePhantom1 a) + +mutuallyRecursivePhantom :: forall a b. MutuallyRecursivePhantom1 a -> MutuallyRecursivePhantom1 b +mutuallyRecursivePhantom = coerce + +data MutuallyRecursiveRepresentational1 a + = MutuallyRecursiveRepresentational1 a (MutuallyRecursiveRepresentational2 a) + +data MutuallyRecursiveRepresentational2 a + = MutuallyRecursiveRepresentational2 (MutuallyRecursiveRepresentational1 a) + +mutuallyRecursiveRepresentational :: forall a. MutuallyRecursiveRepresentational1 a -> MutuallyRecursiveRepresentational1 (Id1 a) +mutuallyRecursiveRepresentational = coerce + main = log (coerce (NTString1 "Done") :: String) From 7f9848af0651231139669f9c888a471692a24549 Mon Sep 17 00:00:00 2001 From: Muse Mekuria Date: Thu, 13 Aug 2020 06:53:07 -0400 Subject: [PATCH 1222/1580] Updated link to book (#3916) --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index f2239f35e0..df883032eb 100644 --- a/README.md +++ b/README.md @@ -12,7 +12,7 @@ A small strongly typed programming language with expressive types that compiles ## Resources -- [PureScript book](https://leanpub.com/purescript/read) +- [PureScript book](https://book.purescript.org/) - [Documentation](https://github.com/purescript/documentation) - [Try PureScript](http://try.purescript.org) - [Pursuit Package Index](http://pursuit.purescript.org/) From 5e8bf03db33f73beea0aa076c68ef01a9cbdbf0e Mon Sep 17 00:00:00 2001 From: milesfrain Date: Thu, 20 Aug 2020 04:07:34 -0700 Subject: [PATCH 1223/1580] Add troubleshooting steps for libtinfo and EACCES errors (#3903) * Add troubleshooting steps for libtinfo and EACCES errors See https://github.com/purescript/documentation/pull/323#issuecomment-649905179 * Absorb `libtinfo` troubleshooting, change "here" link * Separate troubleshooting steps for libtinfo5 * Suggest installing both libtinfo5 and libncurses5-dev --- INSTALL.md | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/INSTALL.md b/INSTALL.md index 7b4fe9f777..9e70b83d4d 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -46,11 +46,23 @@ If you don't have stack installed, please see the [stack install documentation]( The PureScript REPL depends on the `curses` library (via the Haskell package `terminfo`). If you are having difficulty running the compiler, it may be -because the `curses` library is missing. +because the `curses` library is missing. This problem may appear as a `libtinfo` +error: +``` +error while loading shared libraries: libtinfo.so.5: cannot open shared object file: No such file or directory +``` On Linux, you will probably need to install `ncurses` manually. On Ubuntu, for example, this can be done by running: +``` +$ sudo apt install libtinfo5 libncurses5-dev +``` + +## EACCES error +If you encounter this error while trying to install via `npm`: ``` -$ sudo apt-get install libncurses5-dev +Error: EACCES: permission denied ``` + +The best solution is to install [Node.js and npm via a node version manager](https://docs.npmjs.com/downloading-and-installing-node-js-and-npm#using-a-node-version-manager-to-install-nodejs-and-npm). This error is due to permissions issues when installing packages globally. You can read more about this error in npm's guide to [resolving EACCES permissions errors when installing packages globally](https://docs.npmjs.com/getting-started/fixing-npm-permissions). From ac2def046070172e7a18fa9351a5e5d9d4281f1d Mon Sep 17 00:00:00 2001 From: Cyril Date: Sun, 30 Aug 2020 16:34:50 +0200 Subject: [PATCH 1224/1580] Disallow `Coercible` instance declarations (#3905) --- src/Language/PureScript/Errors.hs | 13 +++++++++++++ src/Language/PureScript/Sugar/TypeClasses.hs | 5 ++++- .../InvalidCoercibleInstanceDeclaration.out | 14 ++++++++++++++ .../InvalidCoercibleInstanceDeclaration.purs | 8 ++++++++ 4 files changed, 39 insertions(+), 1 deletion(-) create mode 100644 tests/purs/failing/InvalidCoercibleInstanceDeclaration.out create mode 100644 tests/purs/failing/InvalidCoercibleInstanceDeclaration.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index aff0ba0742..e2e23f3928 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -180,6 +180,7 @@ data SimpleErrorMessage Text -- ^ Type variable in question Role -- ^ inferred role Role -- ^ declared role + | InvalidCoercibleInstanceDeclaration [SourceType] deriving (Show) data ErrorMessage = ErrorMessage @@ -336,6 +337,7 @@ errorCode em = case unwrapErrorMessage em of VisibleQuantificationCheckFailureInType {} -> "VisibleQuantificationCheckFailureInType" UnsupportedTypeInKind {} -> "UnsupportedTypeInKind" RoleMismatch {} -> "RoleMismatch" + InvalidCoercibleInstanceDeclaration {} -> "InvalidCoercibleInstanceDeclaration" -- | A stack trace for an error newtype MultipleErrors = MultipleErrors @@ -453,6 +455,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (MissingTypeDeclaration nm ty) = MissingTypeDeclaration nm <$> f ty gSimple (MissingKindDeclaration sig nm ty) = MissingKindDeclaration sig nm <$> f ty gSimple (CannotGeneralizeRecursiveFunction nm ty) = CannotGeneralizeRecursiveFunction nm <$> f ty + gSimple (InvalidCoercibleInstanceDeclaration tys) = InvalidCoercibleInstanceDeclaration <$> traverse f tys gSimple other = pure other gHint (ErrorInSubsumption t1 t2) = ErrorInSubsumption <$> f t1 <*> f t2 @@ -1293,6 +1296,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl " is required." ] + renderSimpleErrorMessage (InvalidCoercibleInstanceDeclaration tys) = + paras + [ line "Invalid type class instance declaration for" + , markCodeBox $ indent $ Box.hsep 1 Box.left + [ line (showQualified runProperName C.Coercible) + , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) tys) + ] + , line "Instance declarations of this type class are disallowed." + ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1@RCons{} t2@RCons{}) detail = let (row1Box, row2Box) = printRows t1 t2 diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index b63f090f72..f0514e535e 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -206,7 +206,10 @@ desugarDecl mn exps = go modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False)) return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) go (TypeInstanceDeclaration _ _ _ _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" - go d@(TypeInstanceDeclaration sa _ _ name deps className tys (ExplicitInstance members)) = do + go d@(TypeInstanceDeclaration sa _ _ name deps className tys (ExplicitInstance members)) + | className == C.Coercible + = throwError . errorMessage' (fst sa) $ InvalidCoercibleInstanceDeclaration tys + | otherwise = do desugared <- desugarCases members dictDecl <- typeInstanceDictionaryDeclaration sa name mn deps className tys desugared return (expRef name className tys, [d, dictDecl]) diff --git a/tests/purs/failing/InvalidCoercibleInstanceDeclaration.out b/tests/purs/failing/InvalidCoercibleInstanceDeclaration.out new file mode 100644 index 0000000000..34e8147142 --- /dev/null +++ b/tests/purs/failing/InvalidCoercibleInstanceDeclaration.out @@ -0,0 +1,14 @@ +Error found: +at tests/purs/failing/InvalidCoercibleInstanceDeclaration.purs:8:1 - 8:36 (line 8, column 1 - line 8, column 36) + + Invalid type class instance declaration for +   +  Prim.Coerce.Coercible D +  D +   + Instance declarations of this type class are disallowed. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidCoercibleInstanceDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InvalidCoercibleInstanceDeclaration.purs b/tests/purs/failing/InvalidCoercibleInstanceDeclaration.purs new file mode 100644 index 0000000000..38a28a1af6 --- /dev/null +++ b/tests/purs/failing/InvalidCoercibleInstanceDeclaration.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidCoercibleInstanceDeclaration +module Main where + +import Prim.Coerce (class Coercible) + +data D + +instance coercible :: Coercible D D From 33a70bdedfa8d4682f19754e3092b45f487af9c5 Mon Sep 17 00:00:00 2001 From: Mark Eibes Date: Sun, 30 Aug 2020 16:35:39 +0200 Subject: [PATCH 1225/1580] Copy default-extensions.yaml to subprojects (#3908) * Copy default-extensions.yaml to subprojects * Add note to inform editors about other copies --- default-extensions.yaml | 4 +++ lib/purescript-ast/default-extensions.yaml | 31 ++++++++++++++++++++++ lib/purescript-ast/package.yaml | 2 +- lib/purescript-cst/default-extensions.yaml | 31 ++++++++++++++++++++++ lib/purescript-cst/package.yaml | 2 +- 5 files changed, 68 insertions(+), 2 deletions(-) create mode 100644 lib/purescript-ast/default-extensions.yaml create mode 100644 lib/purescript-cst/default-extensions.yaml diff --git a/default-extensions.yaml b/default-extensions.yaml index 2d8cbf1e11..abfa1e8bc8 100644 --- a/default-extensions.yaml +++ b/default-extensions.yaml @@ -1,3 +1,7 @@ +# This file should be kept in sync with the other default-extensions.yaml files in this repository. The files are located at: +# - default-extensions.yaml (the repository root), +# - lib/purescript-ast/default-extensions.yaml, +# - lib/purescript-cst/default-extensions.yaml - BangPatterns - ConstraintKinds - DataKinds diff --git a/lib/purescript-ast/default-extensions.yaml b/lib/purescript-ast/default-extensions.yaml new file mode 100644 index 0000000000..abfa1e8bc8 --- /dev/null +++ b/lib/purescript-ast/default-extensions.yaml @@ -0,0 +1,31 @@ +# This file should be kept in sync with the other default-extensions.yaml files in this repository. The files are located at: +# - default-extensions.yaml (the repository root), +# - lib/purescript-ast/default-extensions.yaml, +# - lib/purescript-cst/default-extensions.yaml +- BangPatterns +- ConstraintKinds +- DataKinds +- DefaultSignatures +- DeriveFunctor +- DeriveFoldable +- DeriveTraversable +- DeriveGeneric +- DerivingStrategies +- EmptyDataDecls +- FlexibleContexts +- FlexibleInstances +- GeneralizedNewtypeDeriving +- KindSignatures +- LambdaCase +- MultiParamTypeClasses +- NamedFieldPuns +- NoImplicitPrelude +- PatternGuards +- PatternSynonyms +- RankNTypes +- RecordWildCards +- OverloadedStrings +- ScopedTypeVariables +- TupleSections +- TypeFamilies +- ViewPatterns diff --git a/lib/purescript-ast/package.yaml b/lib/purescript-ast/package.yaml index 81198f62fe..d9405c36c2 100644 --- a/lib/purescript-ast/package.yaml +++ b/lib/purescript-ast/package.yaml @@ -36,6 +36,6 @@ dependencies: library: source-dirs: src ghc-options: -Wall -O2 - default-extensions: !include "../../default-extensions.yaml" + default-extensions: !include "default-extensions.yaml" stability: experimental diff --git a/lib/purescript-cst/default-extensions.yaml b/lib/purescript-cst/default-extensions.yaml new file mode 100644 index 0000000000..abfa1e8bc8 --- /dev/null +++ b/lib/purescript-cst/default-extensions.yaml @@ -0,0 +1,31 @@ +# This file should be kept in sync with the other default-extensions.yaml files in this repository. The files are located at: +# - default-extensions.yaml (the repository root), +# - lib/purescript-ast/default-extensions.yaml, +# - lib/purescript-cst/default-extensions.yaml +- BangPatterns +- ConstraintKinds +- DataKinds +- DefaultSignatures +- DeriveFunctor +- DeriveFoldable +- DeriveTraversable +- DeriveGeneric +- DerivingStrategies +- EmptyDataDecls +- FlexibleContexts +- FlexibleInstances +- GeneralizedNewtypeDeriving +- KindSignatures +- LambdaCase +- MultiParamTypeClasses +- NamedFieldPuns +- NoImplicitPrelude +- PatternGuards +- PatternSynonyms +- RankNTypes +- RecordWildCards +- OverloadedStrings +- ScopedTypeVariables +- TupleSections +- TypeFamilies +- ViewPatterns diff --git a/lib/purescript-cst/package.yaml b/lib/purescript-cst/package.yaml index c3f6739ad0..f2ca677382 100644 --- a/lib/purescript-cst/package.yaml +++ b/lib/purescript-cst/package.yaml @@ -34,7 +34,7 @@ build-tools: library: source-dirs: src ghc-options: -Wall -O2 - default-extensions: !include "../../default-extensions.yaml" + default-extensions: !include "default-extensions.yaml" tests: tests: From ba55bb1f7bcb54f6f211080957d09ca7f09c6497 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Tue, 1 Sep 2020 20:22:51 +0100 Subject: [PATCH 1226/1580] Update CONTRIBUTING.md (#3924) * Link to governance doc where appropriate * Remove reference to core-tests (which no longer exist) * Try to set expectations a bit better re: approving proposals or merging PRs * Rearrange the sections a little for clarity * Mention the `make` task so that it's easier to regenerate the LICENSE file --- CONTRIBUTING.md | 59 +++++++++++++++++++++++++++---------------------- 1 file changed, 32 insertions(+), 27 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index dc455d66e8..a89f39e3f4 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -1,50 +1,55 @@ +# Contributing to the PureScript Compiler + +## Reporting Issues + +When reporting issues, please be aware of the following: + +* Please use the appropriate issue template if there is one: filling out all of the sections in the template makes it much easier for us to understand what the problem is and how we might want to address it. +* We prefer to reserve the issue tracker in this repository for tasks which involve work on the compiler. If your report or proposal doesn't involve work on the compiler, please open it on the repository where the work would be done. If you're unsure, you can always ask in [the #purescript channel in FP Slack][] or [Discourse][]. +* If you have a question or need help, please ask in [the #purescript channel in FP Slack][] or [Discourse][] instead. +* When submitting feature proposals, please be aware that we prefer to be conservative about adding things to the language/compiler. A feature proposal is much more likely to be accepted if it includes a clear description of the problem it intends to solve, as well as not only a strong justification for why adding the feature will solve that problem, but also for why any existing features or techniques that could be used to solve that problem are insufficient. + +We have defined some [Project Values](https://github.com/purescript/governance#project-values) in our organization's governance document; referring to these may help you get a better idea of what is likely to be accepted and what isn't. + +## Sending Pull Requests + Pull requests are encouraged, but please open issues before starting to work on something that you intend to make into a PR, so that we can decide if it is a good fit or not. -## Finding Issues to Work On +### Finding Issues to Work On If you would like to contribute, please consider the issues in the current milestone first. If you are a new contributor, you may want to have a go at the ["new contributor" issues](https://github.com/purescript/purescript/labels/new%20contributor) to get started. -## Pull Requests +### Submitting Your Code -Please follow the following guidelines: +When submitting a pull request, please follow the following guidelines: - Add at least a test to `tests/purs/passing/` and possibly to `tests/purs/failing/`. - Build the binaries and libs with `stack build` - Make sure that all test suites are passing. Run the test suites with `stack test`. -- Build the core libraries by running the script in `core-tests`. +- Please try to keep changes small and isolated: smaller pull requests which only address one issue are much easier to review. +- For any code change, please append a copyright and licensing notice to the [CONTRIBUTORS.md](CONTRIBUTORS.md) file if your name is not in there already. -## Tests +### Running Tests Run all test suites with `stack test`. You will need `npm`, `bower` and `node` on your PATH to run the tests. -You can run individual test suites using `stack test --test-arguments="-p -PATTERN"` where `PATTERN` is one of `compiler`, `repl`, `ide`, `docs`, `corefn`, -or `hierarchy`. - -To build and run a specific test in `tests/purs/passing/` or `tests/purs/failing/`, add test arguments like so: +You can run individual test suites using `stack test --test-arguments="-p PATTERN"` where `PATTERN` is one of `compiler`, `repl`, `ide`, `docs`, `corefn`, or `hierarchy`. You can also build and run a specific test in `tests/purs/passing/` or `tests/purs/failing/` by using the test's filename as the pattern, e.g.: -`stack test --fast --test-arguments="-p 1110.purs"` +``` +stack test --fast --test-arguments="-p 1110.purs" +``` This will run whatever test uses the example file `1110.purs`. -## Code Review - -To prevent core libraries from getting broken, every change must be reviewed. A pull request will be merged as long as one other team member has verified the changes. - -## Adding Dependencies - -Because the PureScript compiler is distributed in binary form, we include -the licenses of all dependencies, including transitive ones, in the LICENSE -file. Therefore, whenever the dependencies change, the LICENSE file should be -updated. +### Adding Dependencies -This can be automated; see the `license-generator/generate.hs` file. +Because the PureScript compiler is distributed in binary form, we include the licenses of all dependencies, including transitive ones, in the LICENSE file. Therefore, whenever the dependencies change, the LICENSE file should be updated. -## Writing Issues +This process can be performed automatically by running `make license-generator`. -- If the issue is actually a question, please consider asking on Reddit, Stack Overflow or IRC first. -- Please include a minimal, repeatable test case with any bug report. +### Getting Pull Requests Merged -## Copyright and Licensing +Sometimes pull requests take a little while to be merged. This is partially because they often have knock-on effects for the rest of the ecosystem, and partially because we want to give core team members time to review and consider changes thoroughly. Please see the organization's [governance document](https://github.com/purescript/governance) for information about when a pull request may be merged. -For any code change, please append a copyright and licensing notice to the [CONTRIBUTORS.md](CONTRIBUTORS.md) file. +[the #purescript channel in FP Slack]: https://functionalprogramming.slack.com/ +[Discourse]: https://discourse.purescript.org/ From 2bd7ca5f45bd1b6daece10fe8c0f1e932d21ea75 Mon Sep 17 00:00:00 2001 From: milesfrain Date: Thu, 3 Sep 2020 22:40:33 -0700 Subject: [PATCH 1227/1580] Link to releases page (#3920) --- INSTALL.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/INSTALL.md b/INSTALL.md index 9e70b83d4d..32f6248653 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -15,7 +15,7 @@ See also for more details ## Official prebuilt binaries -Each release comes with prebuilt x86-64 binary bundles for Linux, mac OS, and Windows. Users of other operating systems or architectures will likely need to build the compiler from source; see below. +Each [release](https://github.com/purescript/purescript/releases) comes with prebuilt x86-64 binary bundles for Linux, mac OS, and Windows. Users of other operating systems or architectures will likely need to build the compiler from source; see below. To install a binary bundle, simply extract it and place the `purs` executable somewhere on your PATH. From 58c101f44bc238dcff7a7b4bf8d2033aada68875 Mon Sep 17 00:00:00 2001 From: Cyril Date: Sat, 5 Sep 2020 22:56:06 +0200 Subject: [PATCH 1228/1580] Forbid partial data constructors exports (#3872) * Forbid partial data constructors exports * Lookup data constructors in the environment * Add a comment to `checkDataConstructorsAreExported` --- src/Language/PureScript/Errors.hs | 8 +++---- src/Language/PureScript/Sugar/Operators.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 17 +++++++++++++ tests/purs/failing/ExportExplicit1.out | 24 ++++++++++++++----- tests/purs/failing/ExportExplicit1.purs | 4 ++-- tests/purs/failing/ExportExplicit1/M1.out | 10 -------- tests/purs/failing/ExportExplicit1/M1.purs | 2 +- .../failing/TransitiveDctorExportError.out | 13 ++++++++++ .../failing/TransitiveDctorExportError.purs | 4 ++++ tests/purs/passing/ExportExplicit/M1.purs | 2 +- 10 files changed, 61 insertions(+), 25 deletions(-) delete mode 100644 tests/purs/failing/ExportExplicit1/M1.out create mode 100644 tests/purs/failing/TransitiveDctorExportError.out create mode 100644 tests/purs/failing/TransitiveDctorExportError.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index e2e23f3928..5ee4896590 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -130,7 +130,7 @@ data SimpleErrorMessage | InvalidNewtype (ProperName 'TypeName) | InvalidInstanceHead SourceType | TransitiveExportError DeclarationRef [DeclarationRef] - | TransitiveDctorExportError DeclarationRef (ProperName 'ConstructorName) + | TransitiveDctorExportError DeclarationRef [ProperName 'ConstructorName] | ShadowedName Ident | ShadowedTypeVar Text | UnusedTypeVar Text @@ -1030,9 +1030,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " requires the following to also be exported: " , indent $ paras $ map (line . markCode . prettyPrintExport) ys ] - renderSimpleErrorMessage (TransitiveDctorExportError x ctor) = - paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " requires the following data constructor to also be exported: " - , indent $ line $ markCode $ runProperName ctor + renderSimpleErrorMessage (TransitiveDctorExportError x ctors) = + paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " requires the following data constructor" <> (if length ctors == 1 then "" else "s") <> " to also be exported: " + , indent $ paras $ map (line . markCode . runProperName) ctors ] renderSimpleErrorMessage (ShadowedName nm) = line $ "Name " <> markCode (showIdent nm) <> " was shadowed." diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index d79e88a070..942b2c0dcf 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -383,7 +383,7 @@ checkFixityExports m@(Module ss _ mn ds (Just exps)) = Right ctor -> unless (anyTypeRef (maybe False (elem ctor) . snd)) . throwError . errorMessage' ss - $ TransitiveDctorExportError dr ctor + $ TransitiveDctorExportError dr [ctor] checkRef dr@(TypeOpRef ss' op) = for_ (getTypeOpAlias op) $ \ty -> unless (anyTypeRef ((== ty) . fst)) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index de7459a89f..33b24558bb 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -595,6 +595,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = checkClassMembersAreExported e checkClassesAreExported e checkSuperClassesAreExported e + checkDataConstructorsAreExported e return $ Module ss coms mn decls' (Just exps) where qualify' :: a -> Qualified a @@ -732,3 +733,19 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = extractMemberName (TypeDeclaration td) = tydeclIdent td extractMemberName _ = internalError "Unexpected declaration in typeclass member list" checkClassMembersAreExported _ = return () + + -- | If any data constructors of a type are exported, we require all its data constructors to be exported. + checkDataConstructorsAreExported :: DeclarationRef -> m () + checkDataConstructorsAreExported dr@(TypeRef ss' name (Just exportedDataConstructorsNames)) + | not (null exportedDataConstructorsNames) = do + env <- getEnv + let dataConstructorNames = fromMaybe [] $ + M.lookup (mkQualified name mn) (types env) >>= getDataConstructorNames . snd + missingDataConstructorsNames = dataConstructorNames \\ exportedDataConstructorsNames + unless (null missingDataConstructorsNames) $ + throwError . errorMessage' ss' $ TransitiveDctorExportError dr missingDataConstructorsNames + where + getDataConstructorNames :: TypeKind -> Maybe [ProperName 'ConstructorName] + getDataConstructorNames (DataType _ constructors) = Just $ fst <$> constructors + getDataConstructorNames _ = Nothing + checkDataConstructorsAreExported _ = return () diff --git a/tests/purs/failing/ExportExplicit1.out b/tests/purs/failing/ExportExplicit1.out index 309c407aeb..962a855db1 100644 --- a/tests/purs/failing/ExportExplicit1.out +++ b/tests/purs/failing/ExportExplicit1.out @@ -1,10 +1,22 @@ -Error found: -in module Main -at tests/purs/failing/ExportExplicit1.purs:10:9 - 10:10 (line 10, column 9 - line 10, column 10) +Error 1 of 2: - Unknown data constructor Y + in module Main + at tests/purs/failing/ExportExplicit1.purs:9:9 - 9:10 (line 9, column 9 - line 9, column 10) + Unknown data constructor X -See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, -or to contribute content related to this error. + + See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module Main + at tests/purs/failing/ExportExplicit1.purs:10:9 - 10:10 (line 10, column 9 - line 10, column 10) + + Unknown data constructor Y + + + See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, + or to contribute content related to this error. diff --git a/tests/purs/failing/ExportExplicit1.purs b/tests/purs/failing/ExportExplicit1.purs index 574a12a7c6..def6510f04 100644 --- a/tests/purs/failing/ExportExplicit1.purs +++ b/tests/purs/failing/ExportExplicit1.purs @@ -1,12 +1,12 @@ -- @shouldFailWith UnknownName +-- @shouldFailWith UnknownName +-- should fail as X and Y constructors are not exported from M1 module Main where import M1 import Effect.Console (log) testX = X - --- should fail as Y constructor is not exported from M1 testY = Y main = log "Done" diff --git a/tests/purs/failing/ExportExplicit1/M1.out b/tests/purs/failing/ExportExplicit1/M1.out deleted file mode 100644 index 309c407aeb..0000000000 --- a/tests/purs/failing/ExportExplicit1/M1.out +++ /dev/null @@ -1,10 +0,0 @@ -Error found: -in module Main -at tests/purs/failing/ExportExplicit1.purs:10:9 - 10:10 (line 10, column 9 - line 10, column 10) - - Unknown data constructor Y - - -See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/ExportExplicit1/M1.purs b/tests/purs/failing/ExportExplicit1/M1.purs index f20006fb4b..fbf0956463 100644 --- a/tests/purs/failing/ExportExplicit1/M1.purs +++ b/tests/purs/failing/ExportExplicit1/M1.purs @@ -1,3 +1,3 @@ -module M1 (X(X)) where +module M1 (X) where data X = X | Y diff --git a/tests/purs/failing/TransitiveDctorExportError.out b/tests/purs/failing/TransitiveDctorExportError.out new file mode 100644 index 0000000000..e1748b9289 --- /dev/null +++ b/tests/purs/failing/TransitiveDctorExportError.out @@ -0,0 +1,13 @@ +Error found: +in module Main +at tests/purs/failing/TransitiveDctorExportError.purs:2:1 - 4:15 (line 2, column 1 - line 4, column 15) + + An export for T requires the following data constructor to also be exported: + + B + + + +See https://github.com/purescript/documentation/blob/master/errors/TransitiveDctorExportError.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TransitiveDctorExportError.purs b/tests/purs/failing/TransitiveDctorExportError.purs new file mode 100644 index 0000000000..21d5f4624b --- /dev/null +++ b/tests/purs/failing/TransitiveDctorExportError.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith TransitiveDctorExportError +module Main (T(A)) where + +data T = A | B diff --git a/tests/purs/passing/ExportExplicit/M1.purs b/tests/purs/passing/ExportExplicit/M1.purs index 273f1002fd..5195d0e96b 100644 --- a/tests/purs/passing/ExportExplicit/M1.purs +++ b/tests/purs/passing/ExportExplicit/M1.purs @@ -1,4 +1,4 @@ -module M1 (X(X), Z(..), foo) where +module M1 (X(X, Y), Z(..), foo) where data X = X | Y data Z = Z From 3a1ac103be48d1deee6dd72a754d3d2f67cae00d Mon Sep 17 00:00:00 2001 From: Cyril Date: Wed, 9 Sep 2020 13:59:31 +0200 Subject: [PATCH 1229/1580] Saturate higher kinded types in `Coercible` constraints (#3893) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This PR implements the type application rule mentioned by the Safe Zero-cost Coercions for Haskell paper in section 2.8 Supporting higher order polymorphism: * If Coercible t1 t2, where t1, t2 :: k1 → k2, then Coercible (t1 x) (t2 x) Fix #3889. * Saturate higher kinded types in `Coercible` constraints * Apply the polymorphic kind of `Coercible` constraints when solving them * Forbid heterogenously kinded `Coercible` constraints arguments * Don’t rewrite thrown away types when unifying `Coercible` arguments kinds * Compare `Coercible` arguments rewritten with their inferred kinds * Throw on failed type lookups when solving `Coercible` constraints * Remove redundant checks from `coercibleWanteds` guards * Support `Coercible` constraints on unsaturated type constructors with different kinds * Rewrite constructor fields when checking the kind of their data type Given the following declaration ```purs newtype N f = N (f {}) ``` solving a `Coercible (N f) (f {})` constraints yields a `Coercible (f {}) (f {})` subgoal by the unwraping rule. This constraint seems trivial but if constructors fields are not elaborated the actual subgoal is `Coercible (f (Record ())) (f (Record (() @Type)))`, which isn’t solvable because of the missing kind application on the left! Inferring kinds and comparing the rewritten terms fixes the issue at the expense of redundant work (kinds are already inferred during type checking) but then invalid coercions between unsaturated higher kinded types with polymorphic parameters fail to type check with an `UndefinedTypeVariable` error instead of the expected `NoInstanceFound`. * Fix CoercibleKindMismatch golden test --- .../Language/PureScript/AST/Declarations.hs | 3 + .../src/Language/PureScript/Environment.hs | 20 ++- src/Language/PureScript/Docs/Prim.hs | 19 ++- .../PureScript/TypeChecker/Entailment.hs | 147 ++++++++++-------- src/Language/PureScript/TypeChecker/Kinds.hs | 16 +- .../failing/3275-DataBindingGroupErrorPos.out | 1 - tests/purs/failing/CoercibleForeign.out | 2 +- tests/purs/failing/CoercibleForeign2.out | 2 +- tests/purs/failing/CoercibleForeign3.out | 2 +- .../failing/CoercibleHigherKindedData.out | 28 ++++ .../failing/CoercibleHigherKindedData.purs | 13 ++ .../failing/CoercibleHigherKindedNewtypes.out | 23 +++ .../CoercibleHigherKindedNewtypes.purs | 13 ++ tests/purs/failing/CoercibleKindMismatch.out | 31 ++++ tests/purs/failing/CoercibleKindMismatch.purs | 15 ++ tests/purs/failing/CoercibleNominal.out | 2 +- .../purs/failing/CoercibleNominalTypeApp.out | 2 +- .../purs/failing/CoercibleNominalWrapped.out | 2 +- .../failing/CoercibleRepresentational.out | 2 +- .../failing/CoercibleRepresentational2.out | 2 +- .../failing/CoercibleRepresentational3.out | 2 +- tests/purs/failing/InfiniteKind.out | 1 - tests/purs/failing/InfiniteKind2.out | 1 - tests/purs/failing/KindError.out | 1 - .../failing/StandaloneKindSignatures2.out | 1 - tests/purs/passing/Coercible.purs | 17 +- 26 files changed, 272 insertions(+), 96 deletions(-) create mode 100644 tests/purs/failing/CoercibleHigherKindedData.out create mode 100644 tests/purs/failing/CoercibleHigherKindedData.purs create mode 100644 tests/purs/failing/CoercibleHigherKindedNewtypes.out create mode 100644 tests/purs/failing/CoercibleHigherKindedNewtypes.purs create mode 100644 tests/purs/failing/CoercibleKindMismatch.out create mode 100644 tests/purs/failing/CoercibleKindMismatch.purs diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs index 5b451e904c..84ebd129e5 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs @@ -382,6 +382,9 @@ data DataConstructorDeclaration = DataConstructorDeclaration , dataCtorFields :: ![(Ident, SourceType)] } deriving (Show, Eq) +mapDataCtorFields :: ([(Ident, SourceType)] -> [(Ident, SourceType)]) -> DataConstructorDeclaration -> DataConstructorDeclaration +mapDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration { dataCtorFields = f dataCtorFields, .. } + traverseDataCtorFields :: Monad m => ([(Ident, SourceType)] -> m [(Ident, SourceType)]) -> DataConstructorDeclaration -> m DataConstructorDeclaration traverseDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration dataCtorAnn dataCtorName <$> f dataCtorFields diff --git a/lib/purescript-ast/src/Language/PureScript/Environment.hs b/lib/purescript-ast/src/Language/PureScript/Environment.hs index f2324e413e..229cebb4b5 100644 --- a/lib/purescript-ast/src/Language/PureScript/Environment.hs +++ b/lib/purescript-ast/src/Language/PureScript/Environment.hs @@ -408,7 +408,7 @@ primBooleanTypes = primCoerceTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primCoerceTypes = M.fromList $ mconcat - [ primClass (primSubName C.moduleCoerce "Coercible") (\kind -> kindType -:> kindType -:> kind) + [ primClass (primSubName C.moduleCoerce "Coercible") (\kind -> tyForall "k" kindType $ tyVar "k" -:> tyVar "k" -:> kind) ] primOrderingTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) @@ -485,9 +485,10 @@ allPrimClasses = M.unions primCoerceClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primCoerceClasses = M.fromList + -- class Coercible (a :: k) (b :: k) [ (primSubName C.moduleCoerce "Coercible", makeTypeClassData - [ ("a", Just kindType) - , ("b", Just kindType) + [ ("a", Just (tyVar "k")) + , ("b", Just (tyVar "k")) ] [] [] [] True) ] @@ -635,8 +636,11 @@ nominalRolesForKind :: Type a -> [Role] nominalRolesForKind k = replicate (kindArity k) Nominal kindArity :: Type a -> Int -kindArity = go 0 where - go n (TypeApp _ (TypeApp _ fn _) k) - | eqType fn tyFunction = go (n + 1) k - go n (ForAll _ _ _ k _) = go n k - go n _ = n +kindArity = length . fst . unapplyKinds + +unapplyKinds :: Type a -> ([Type a], Type a) +unapplyKinds = go [] where + go kinds (TypeApp _ (TypeApp _ fn k1) k2) + | eqType fn tyFunction = go (k1 : kinds) k2 + go kinds (ForAll _ _ _ k _) = go kinds k + go kinds k = (reverse kinds, k) diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index f06a5dce74..e99854a414 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -393,7 +393,7 @@ coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines , "" , "there is an instance:" , "" - , " coercibleConstructor :: Coercible a a' => Coercible (D a b) (D a' b')" + , " instance coercibleConstructor :: Coercible a a' => Coercible (D a b) (D a' b')" , "" , "Note that, since the type variable `a` plays a role in `D`'s representation," , "we require that the types `a` and `a'` are themselves `Coercible`. However," @@ -408,7 +408,22 @@ coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines , " instance coercibleNewtypeRight :: Coercible T b => Coercible NT b" , "" , "To prevent breaking abstractions, these instances are only usable if the" - , "constructor `MkNT` is in scope." + , "constructor `MkNT` is exported." + , "" + , "Fourth, every pair of unsaturated type constructors can be coerced if" + , "there is an instance for the fully saturated types. For example," + , "given the definitions:" + , "" + , "newtype NT1 a = MkNT1 a" + , "newtype NT2 a b = MkNT2 b" + , "" + , "there is an instance:" + , "" + , " instance coercibleUnsaturedTypes :: Coercible (NT1 b) (NT2 a b) => Coercible NT1 (NT2 a)" + , "" + , "This rule may seem puzzling since it is impossible to apply `coerce` to a term" + , "of type `NT1` but it is necessary to coerce types with higher kinded parameters." + , "" ] kindOrdering :: Declaration diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 7ef955e790..02fb947cf7 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -14,17 +14,18 @@ module Language.PureScript.TypeChecker.Entailment import Prelude.Compat import Protolude (ordNub) -import Control.Applicative ((<|>)) +import Control.Applicative ((<|>), empty) import Control.Arrow (second, (&&&)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State import Control.Monad.Supply.Class (MonadSupply(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Writer -import Data.Foldable (for_, fold, toList) +import Data.Foldable (for_, fold, foldl', toList) import Data.Function (on) import Data.Functor (($>)) -import Data.List (minimumBy, groupBy, nubBy, sortBy) +import Data.List (minimumBy, groupBy, nubBy, sortBy, zipWith4) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -168,12 +169,18 @@ entails entails SolverOptions{..} constraint context hints = solve constraint where + forClassNameM :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> m [TypeClassDict] + forClassNameM env ctx cn@C.Coercible kinds args = + solveCoercible env kinds args >>= + pure . fromMaybe (forClassName env ctx cn kinds args) + forClassNameM env ctx cn kinds args = + pure $ forClassName env ctx cn kinds args + forClassName :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> [TypeClassDict] forClassName _ ctx cn@C.Warn _ [msg] = -- Prefer a warning dictionary in scope if there is one available. -- This allows us to defer a warning by propagating the constraint. findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope [] 0 (WarnInstance msg) [] C.Warn [] [] [msg] Nothing] - forClassName env _ C.Coercible _ args | Just dicts <- solveCoercible env args = dicts forClassName _ _ C.IsSymbol _ args | Just dicts <- solveIsSymbol args = dicts forClassName _ _ C.SymbolCompare _ args | Just dicts <- solveSymbolCompare args = dicts forClassName _ _ C.SymbolAppend _ args | Just dicts <- solveSymbolAppend args = dicts @@ -225,10 +232,12 @@ entails SolverOptions{..} constraint context hints = Nothing -> throwError . errorMessage $ UnknownClass className' Just tcd -> pure tcd + dicts <- lift . lift $ forClassNameM env (combineContexts context inferred) className' kinds'' tys'' + let instances = do chain <- groupBy ((==) `on` tcdChain) $ sortBy (compare `on` (tcdChain &&& tcdIndex)) $ - forClassName env (combineContexts context inferred) className' kinds'' tys'' + dicts -- process instances in a chain in index order let found = for chain $ \tcd -> -- Make sure the type unifies with the type in the type instance definition @@ -381,80 +390,88 @@ entails SolverOptions{..} constraint context hints = subclassDictionaryValue dict className index = App (Accessor (mkString (superclassName className index)) dict) valUndefined - solveCoercible :: Environment -> [SourceType] -> Maybe [TypeClassDict] - solveCoercible env [a, b] = do - let tySynMap = typeSynonyms env - kindMap = types env - replaceTySyns = either (const Nothing) Just . replaceAllTypeSynonymsM tySynMap kindMap - a' <- replaceTySyns a - b' <- replaceTySyns b + solveCoercible :: Environment -> [SourceType] -> [SourceType] -> m (Maybe [TypeClassDict]) + solveCoercible env kinds [a, b] = runMaybeT $ do + let kindOf = lift . (sequence . (id &&& elaborateKind)) <=< replaceAllTypeSynonyms + (a', kind) <- kindOf a + (b', kind') <- kindOf b + lift $ unifyKinds kind kind' -- Solving terminates when the two arguments are the same. Since we -- currently don't support higher-rank arguments in instance heads, term -- equality is a sufficient notion of "the same". if a' == b' - then pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [] [] [a, b] Nothing] + then pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] Nothing] else do -- When solving must reduce and recurse, it doesn't matter whether we -- reduce the first or second argument -- if the constraint is -- solvable, either path will yield the same outcome. Consequently we -- just try the first argument first and the second argument second. - ws <- coercibleWanteds env a' b' <|> coercibleWanteds env b' a' - pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [] [] [a, b] (Just ws)] - solveCoercible _ _ = Nothing + ws <- (MaybeT $ coercibleWanteds env a' b') <|> (MaybeT $ coercibleWanteds env b' a') + pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] (Just ws)] + solveCoercible _ _ _ = pure Nothing -- | Take two types, @a@ and @b@ representing a desired constraint -- @Coercible a b@ and reduce them to a set of simpler wanted constraints -- whose satisfaction will yield the goal. - coercibleWanteds :: Environment -> SourceType -> SourceType -> Maybe [SourceConstraint] - coercibleWanteds env a b = case a of - TypeConstructor _ tyName -> do - -- If the first argument is a plain newtype (e.g. @newtype T = T U@ and - -- the constraint @Coercible T b@), look up the type of its wrapped - -- field and yield a new wanted constraint in terms of that type - -- (@Coercible U b@ in the example). - (_, wrappedTy, _) <- lookupNewtypeConstructor env tyName - pure [Constraint nullSourceAnn C.Coercible [] [wrappedTy, b] Nothing] - t - | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a - , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b - , not (null axs) && not (null bxs) && aTyName == bTyName -> do - -- If both arguments are applications of the same type constructor - -- (e.g. @data D a b = D a@ in the constraint - -- @Coercible (D a b) (D a' b')@), infer the roles of the type - -- constructor's arguments and generate wanted constraints - -- appropriately (e.g. here @a@ is representational and @b@ is - -- phantom, yielding @Coercible a a'@). - let tyRoles = lookupRoles env aTyName - k role ax bx = case role of - Nominal - -- If we had first-class equality constraints, we'd just - -- emit one of the form @(a ~ b)@ here and let the solver - -- recurse. Since we don't we must compare the types at - -- this point and fail if they don't match. This likely - -- means there are cases we should be able to handle that - -- we currently can't, but is at least sound. - | ax == bx -> - Just [] - | otherwise -> - Nothing - Representational -> - Just [Constraint nullSourceAnn C.Coercible [] [ax, bx] Nothing] - Phantom -> - Just [] - fmap concat $ sequence $ zipWith3 k tyRoles axs bxs - | (TypeConstructor _ tyName, _, xs) <- unapplyTypes t - , not $ null xs - , Just (tvs, wrappedTy, _) <- lookupNewtypeConstructor env tyName -> do - -- If the first argument is a newtype applied to some other types - -- (e.g. @newtype T a = T a@ in @Coercible (T X) b@), look up the - -- type of its wrapped field and yield a new wanted constraint in - -- terms of that type with the type arguments substituted in (e.g. - -- @Coercible (T[X/a]) b = Coercible X b@ in the example). - let wrappedTySub = replaceAllTypeVars (zip tvs xs) wrappedTy - pure [Constraint nullSourceAnn C.Coercible [] [wrappedTySub, b] Nothing] - _ -> + coercibleWanteds :: Environment -> SourceType -> SourceType -> m (Maybe [SourceConstraint]) + coercibleWanteds env a b + | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a + , (aTyKind, _) <- fromMaybe (internalError "coercibleWanteds: type lookup failed") $ M.lookup aTyName (types env) + , (aks, kind) <- unapplyKinds aTyKind + , length axs < length aks = do + -- If both arguments have kind @k1 -> k2@ (e.g. @data D a b = D a@ + -- in the constraint @Coercible (D a) (D a')@), yield a new wanted + -- constraint in terms of the types saturated with the same variables + -- (e.g. @Coercible (D a t0) (D a' t0)@ in the exemple). + tys <- traverse freshTypeWithKind $ drop (length axs) aks + let a' = foldl' srcTypeApp a tys + b' = foldl' srcTypeApp b tys + pure $ Just [srcCoercibleConstraint kind a' b'] + | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a + , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b + , not (null axs) && aTyName == bTyName + , (aTyKind, _) <- fromMaybe (internalError "coercibleWanteds: type lookup failed") $ M.lookup aTyName (types env) + = runMaybeT $ do + -- If both arguments are applications of the same type constructor + -- (e.g. @data D a b = D a@ in the constraint + -- @Coercible (D a b) (D a' b')@), infer the roles of the type + -- constructor's arguments and generate wanted constraints + -- appropriately (e.g. here @a@ is representational and @b@ is + -- phantom, yielding @Coercible a a'@). + let roles = lookupRoles env aTyName + kinds = fst $ unapplyKinds aTyKind + f role kx ax bx = case role of + Nominal + -- If we had first-class equality constraints, we'd just + -- emit one of the form @(a ~ b)@ here and let the solver + -- recurse. Since we don't we must compare the types at + -- this point and fail if they don't match. This likely + -- means there are cases we should be able to handle that + -- we currently can't, but is at least sound. + | ax == bx -> + pure [] + | otherwise -> + empty + Representational -> + pure [srcCoercibleConstraint kx ax bx] + Phantom -> + pure [] + fmap concat $ sequence $ zipWith4 f roles kinds axs bxs + | (TypeConstructor _ tyName, _, xs) <- unapplyTypes a + , Just (tvs, wrappedTy, _) <- lookupNewtypeConstructor env tyName = do + -- If the first argument is a newtype applied to some other types + -- (e.g. @newtype T a = T a@ in @Coercible (T X) b@), look up the + -- type of its wrapped field and yield a new wanted constraint in + -- terms of that type with the type arguments substituted in (e.g. + -- @Coercible (T[X/a]) b = Coercible X b@ in the example). + let wrappedTySub = replaceAllTypeVars (zip tvs xs) wrappedTy + pure $ Just [srcCoercibleConstraint kindType wrappedTySub b] + | otherwise = -- In all other cases we can't solve the constraint. - Nothing + pure Nothing + + srcCoercibleConstraint :: SourceType -> SourceType -> SourceType -> SourceConstraint + srcCoercibleConstraint k a b = srcConstraint C.Coercible [k] [a, b] Nothing solveIsSymbol :: [SourceType] -> Maybe [TypeClassDict] solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope [] 0 (IsSymbolInstance sym) [] C.IsSymbol [] [] [TypeLevelString ann sym] Nothing] diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index e3306fb488..7bd01f5e4c 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -24,6 +24,7 @@ module Language.PureScript.TypeChecker.Kinds import Prelude.Compat +import Control.Arrow ((***)) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State @@ -602,15 +603,17 @@ inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do tyCtor' = foldl (\ty -> srcTypeApp ty . srcTypeVar . fst) tyCtor tyArgs' ctorBinders = fmap (fmap (fmap Just)) $ sigBinders <> fmap (nullSourceAnn,) tyArgs' for ctors $ \ctor -> - fmap ((ctor,) . mkForAll ctorBinders) $ inferDataConstructor tyCtor' ctor + fmap (mkForAll ctorBinders) <$> inferDataConstructor tyCtor' ctor inferDataConstructor :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> DataConstructorDeclaration - -> m SourceType -inferDataConstructor tyCtor = - flip checkKind E.kindType . foldr ((E.-:>) . snd) tyCtor . dataCtorFields + -> m (DataConstructorDeclaration, SourceType) +inferDataConstructor tyCtor DataConstructorDeclaration{..} = do + dataCtorFields' <- traverse (traverse (flip checkKind E.kindType)) dataCtorFields + dataCtor <- flip (foldr ((E.-:>) . snd)) dataCtorFields' <$> checkKind tyCtor E.kindType + pure ( DataConstructorDeclaration { dataCtorFields = dataCtorFields', .. }, dataCtor ) type TypeDeclarationArgs = ( SourceAnn @@ -914,7 +917,7 @@ kindsOfAll moduleName syns dats clss = withFreshSubstitution $ do pure (((synName, synKind'), synBody'), unknowns synKind') datResultsWithUnks <- for (zip datDict datResults) $ \((datName, datKind), ctors) -> do datKind' <- apply datKind - ctors' <- traverse (traverse apply) ctors + ctors' <- traverse (bitraverse (traverseDataCtorFields (traverse (traverse apply))) apply) ctors pure (((datName, datKind'), ctors'), unknowns datKind') clsResultsWithUnks <- for (zip clsDict clsResults) $ \((clsName, clsKind), (args, supers, decls)) -> do clsKind' <- apply clsKind @@ -951,7 +954,8 @@ kindsOfAll moduleName syns dats clss = withFreshSubstitution $ do (args', supers', decls', generalizeUnknownsWithVars unkBinders clsKind) datResultsWithKinds <- for datResultsWithUnks $ \(((datName, datKind), ctors), _) -> do let tyUnks = snd . fromJust $ lookup (mkQualified datName moduleName) tySubs - ctors' = fmap (fmap (generalizeUnknowns tyUnks . replaceTypeCtors)) ctors + replaceDataCtorField ty = replaceUnknownsWithVars (unknownVarNames (usedTypeVariables ty) tyUnks) $ replaceTypeCtors ty + ctors' = fmap (mapDataCtorFields (fmap (fmap replaceDataCtorField)) *** generalizeUnknowns tyUnks . replaceTypeCtors) ctors traverse_ (traverse_ checkTypeQuantification) ctors' pure (ctors', generalizeUnknowns tyUnks datKind) synResultsWithKinds <- for synResultsWithUnks $ \(((synName, synKind), synBody), _) -> do diff --git a/tests/purs/failing/3275-DataBindingGroupErrorPos.out b/tests/purs/failing/3275-DataBindingGroupErrorPos.out index f20c51e038..1039d74617 100644 --- a/tests/purs/failing/3275-DataBindingGroupErrorPos.out +++ b/tests/purs/failing/3275-DataBindingGroupErrorPos.out @@ -14,7 +14,6 @@ at tests/purs/failing/3275-DataBindingGroupErrorPos.purs:7:19 - 7:22 (line 7, co while checking that type Bar a has kind t0 -> t1 while inferring the kind of Bar a a -while inferring the kind of Bar a a -> Foo a in data binding group Bar, Foo where t0 is an unknown type diff --git a/tests/purs/failing/CoercibleForeign.out b/tests/purs/failing/CoercibleForeign.out index 78b9536a51..39d5f61d71 100644 --- a/tests/purs/failing/CoercibleForeign.out +++ b/tests/purs/failing/CoercibleForeign.out @@ -8,7 +8,7 @@ at tests/purs/failing/CoercibleForeign.purs:11:20 - 11:26 (line 11, column 20 -  (Foreign (Id a0) (Id b1))   -while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Foreign a0 b1 -> Foreign (Id a0) (Id b1) while checking that expression coerce has type Foreign a0 b1 -> Foreign (Id a0) (Id b1) diff --git a/tests/purs/failing/CoercibleForeign2.out b/tests/purs/failing/CoercibleForeign2.out index 083afcb7bf..781eb1ed9f 100644 --- a/tests/purs/failing/CoercibleForeign2.out +++ b/tests/purs/failing/CoercibleForeign2.out @@ -8,7 +8,7 @@ at tests/purs/failing/CoercibleForeign2.purs:9:20 - 9:26 (line 9, column 20 - li  (Foreign a0 b1 d3)   -while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Foreign a0 b1 c2 -> Foreign a0 b1 d3 while checking that expression coerce has type Foreign a0 b1 c2 -> Foreign a0 b1 d3 diff --git a/tests/purs/failing/CoercibleForeign3.out b/tests/purs/failing/CoercibleForeign3.out index 9bf213691d..12f68bff9a 100644 --- a/tests/purs/failing/CoercibleForeign3.out +++ b/tests/purs/failing/CoercibleForeign3.out @@ -8,7 +8,7 @@ at tests/purs/failing/CoercibleForeign3.purs:9:20 - 9:26 (line 9, column 20 - li  (Foreign @k0 a1 c3)   -while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Foreign @k0 a1 b2 -> Foreign @k0 a1 c3 while checking that expression coerce has type Foreign @k0 a1 b2 -> Foreign @k0 a1 c3 diff --git a/tests/purs/failing/CoercibleHigherKindedData.out b/tests/purs/failing/CoercibleHigherKindedData.out new file mode 100644 index 0000000000..7800515797 --- /dev/null +++ b/tests/purs/failing/CoercibleHigherKindedData.out @@ -0,0 +1,28 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleHigherKindedData.purs:13:17 - 13:23 (line 13, column 17 - line 13, column 23) + + No type class instance was found for +   +  Prim.Coerce.Coercible (Unary @t4 t5)  +  (Binary @t2 @t4 a3 t5) +   + The instance head contains unknown type variables. Consider adding a type annotation. + +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b + is at least as general as type Proxy @(t0 -> Type) (Unary @t0) -> Proxy @(t1 -> Type) (... @t1 a3) +while checking that expression coerce + has type Proxy @(t0 -> Type) (Unary @t0) -> Proxy @(t1 -> Type) (... @t1 a3) +in value declaration unaryToBinary + +where a3 is a rigid type variable + bound at (line 13, column 17 - line 13, column 23) + t0 is an unknown type + t2 is an unknown type + t1 is an unknown type + t4 is an unknown type + t5 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleHigherKindedData.purs b/tests/purs/failing/CoercibleHigherKindedData.purs new file mode 100644 index 0000000000..bb0f718010 --- /dev/null +++ b/tests/purs/failing/CoercibleHigherKindedData.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +data Unary a +data Binary a b + +data Proxy a = Proxy +type role Proxy representational + +unaryToBinary :: forall a. Proxy Unary -> Proxy (Binary a) +unaryToBinary = coerce diff --git a/tests/purs/failing/CoercibleHigherKindedNewtypes.out b/tests/purs/failing/CoercibleHigherKindedNewtypes.out new file mode 100644 index 0000000000..de1064d6c5 --- /dev/null +++ b/tests/purs/failing/CoercibleHigherKindedNewtypes.out @@ -0,0 +1,23 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleHigherKindedNewtypes.purs:13:8 - 13:14 (line 13, column 8 - line 13, column 14) + + No type class instance was found for +   +  Prim.Coerce.Coercible t0 +  t1 +   + The instance head contains unknown type variables. Consider adding a type annotation. + +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b + is at least as general as type Ap @Type @Type N1 Int String -> Ap @Type @Type N2 Int String +while checking that expression coerce + has type Ap @Type @Type N1 Int String -> Ap @Type @Type N2 Int String +in value declaration swap + +where t1 is an unknown type + t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleHigherKindedNewtypes.purs b/tests/purs/failing/CoercibleHigherKindedNewtypes.purs new file mode 100644 index 0000000000..39dc2563f1 --- /dev/null +++ b/tests/purs/failing/CoercibleHigherKindedNewtypes.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +newtype Ap f a b = Ap (f a b) + +data Tuple a b = Tuple a b +newtype N1 a b = N1 (Tuple a b) +newtype N2 b a = N2 (Tuple a b) + +swap :: Ap N1 Int String -> Ap N2 Int String +swap = coerce diff --git a/tests/purs/failing/CoercibleKindMismatch.out b/tests/purs/failing/CoercibleKindMismatch.out new file mode 100644 index 0000000000..c6f3b0027b --- /dev/null +++ b/tests/purs/failing/CoercibleKindMismatch.out @@ -0,0 +1,31 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleKindMismatch.purs:14:39 - 14:45 (line 14, column 39 - line 14, column 45) + + Could not match kind +   +  Type +   + with kind +   +  t29 -> Type +   + +while solving type class constraint +  + Prim.Coerce.Coercible (Unary @t0)  + (Binary @t1 @t2) +  +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b + is at least as general as type Proxy @(t0 -> Type) (Unary @t0) -> Proxy @(t1 -> ...) (Binary @t1 @t2) +while checking that expression coerce + has type Proxy @(t0 -> Type) (Unary @t0) -> Proxy @(t1 -> ...) (Binary @t1 @t2) +in value declaration unaryToBinary + +where t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleKindMismatch.purs b/tests/purs/failing/CoercibleKindMismatch.purs new file mode 100644 index 0000000000..32a91f633a --- /dev/null +++ b/tests/purs/failing/CoercibleKindMismatch.purs @@ -0,0 +1,15 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +import Safe.Coerce (coerce) + +data Unary a +data Binary a b + +data Proxy :: forall k. k -> Type +data Proxy a = Proxy + +type role Proxy representational + +unaryToBinary :: Proxy Unary -> Proxy Binary +unaryToBinary = coerce diff --git a/tests/purs/failing/CoercibleNominal.out b/tests/purs/failing/CoercibleNominal.out index e84c6ee6a6..9f850dc4bd 100644 --- a/tests/purs/failing/CoercibleNominal.out +++ b/tests/purs/failing/CoercibleNominal.out @@ -8,7 +8,7 @@ at tests/purs/failing/CoercibleNominal.purs:11:20 - 11:26 (line 11, column 20 -  (Nominal b2 c1)   -while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Nominal a0 c1 -> Nominal b2 c1 while checking that expression coerce has type Nominal a0 c1 -> Nominal b2 c1 diff --git a/tests/purs/failing/CoercibleNominalTypeApp.out b/tests/purs/failing/CoercibleNominalTypeApp.out index d99972caef..2232a1983f 100644 --- a/tests/purs/failing/CoercibleNominalTypeApp.out +++ b/tests/purs/failing/CoercibleNominalTypeApp.out @@ -8,7 +8,7 @@ at tests/purs/failing/CoercibleNominalTypeApp.purs:13:8 - 13:14 (line 13, column  (G @Type Maybe String)   -while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type G @Type Maybe Int -> G @Type Maybe String while checking that expression coerce has type G @Type Maybe Int -> G @Type Maybe String diff --git a/tests/purs/failing/CoercibleNominalWrapped.out b/tests/purs/failing/CoercibleNominalWrapped.out index 781959f8a0..a60528d314 100644 --- a/tests/purs/failing/CoercibleNominalWrapped.out +++ b/tests/purs/failing/CoercibleNominalWrapped.out @@ -8,7 +8,7 @@ at tests/purs/failing/CoercibleNominalWrapped.purs:15:14 - 15:20 (line 15, colum  (Wrap (Id a0) b1)   -while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Wrap a0 b1 -> Wrap (Id a0) b1 while checking that expression coerce has type Wrap a0 b1 -> Wrap (Id a0) b1 diff --git a/tests/purs/failing/CoercibleRepresentational.out b/tests/purs/failing/CoercibleRepresentational.out index 90ef1ae9b6..2d3eb6eb16 100644 --- a/tests/purs/failing/CoercibleRepresentational.out +++ b/tests/purs/failing/CoercibleRepresentational.out @@ -8,7 +8,7 @@ at tests/purs/failing/CoercibleRepresentational.purs:11:20 - 11:26 (line 11, col  b3   -while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Phantom @t0 a1 -> Phantom @t2 b3 while checking that expression coerce has type Phantom @t0 a1 -> Phantom @t2 b3 diff --git a/tests/purs/failing/CoercibleRepresentational2.out b/tests/purs/failing/CoercibleRepresentational2.out index b2b1d38004..5e82bf8851 100644 --- a/tests/purs/failing/CoercibleRepresentational2.out +++ b/tests/purs/failing/CoercibleRepresentational2.out @@ -8,7 +8,7 @@ at tests/purs/failing/CoercibleRepresentational2.purs:9:14 - 9:20 (line 9, colum  String   -while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Arr1 Int -> Arr1 String while checking that expression coerce has type Arr1 Int -> Arr1 String diff --git a/tests/purs/failing/CoercibleRepresentational3.out b/tests/purs/failing/CoercibleRepresentational3.out index 529edab386..416387b287 100644 --- a/tests/purs/failing/CoercibleRepresentational3.out +++ b/tests/purs/failing/CoercibleRepresentational3.out @@ -8,7 +8,7 @@ at tests/purs/failing/CoercibleRepresentational3.purs:9:14 - 9:20 (line 9, colum  String   -while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Rec1 Int -> Rec1 String while checking that expression coerce has type Rec1 Int -> Rec1 String diff --git a/tests/purs/failing/InfiniteKind.out b/tests/purs/failing/InfiniteKind.out index 69e5eb4b9a..3bb4745c23 100644 --- a/tests/purs/failing/InfiniteKind.out +++ b/tests/purs/failing/InfiniteKind.out @@ -10,7 +10,6 @@ at tests/purs/failing/InfiniteKind.purs:5:17 - 5:18 (line 5, column 17 - line 5, while checking that type a has kind t0 while inferring the kind of a a -while inferring the kind of a a -> F a in type constructor F where t0 is an unknown type diff --git a/tests/purs/failing/InfiniteKind2.out b/tests/purs/failing/InfiniteKind2.out index 0153bcc434..1be74af830 100644 --- a/tests/purs/failing/InfiniteKind2.out +++ b/tests/purs/failing/InfiniteKind2.out @@ -10,7 +10,6 @@ at tests/purs/failing/InfiniteKind2.purs:5:23 - 5:27 (line 5, column 23 - line 5 while checking that type Tree has kind t0 while inferring the kind of m Tree -while inferring the kind of m Tree -> Tree m in type constructor Tree where t0 is an unknown type diff --git a/tests/purs/failing/KindError.out b/tests/purs/failing/KindError.out index 1339a8890d..fe56bd3e06 100644 --- a/tests/purs/failing/KindError.out +++ b/tests/purs/failing/KindError.out @@ -14,7 +14,6 @@ at tests/purs/failing/KindError.purs:6:35 - 6:36 (line 6, column 35 - line 6, co while checking that type f has kind t0 -> t1 while inferring the kind of f a -while inferring the kind of f a -> KindError f a in type constructor KindError where t0 is an unknown type diff --git a/tests/purs/failing/StandaloneKindSignatures2.out b/tests/purs/failing/StandaloneKindSignatures2.out index 9e9df4a898..0835b79c5b 100644 --- a/tests/purs/failing/StandaloneKindSignatures2.out +++ b/tests/purs/failing/StandaloneKindSignatures2.out @@ -14,7 +14,6 @@ at tests/purs/failing/StandaloneKindSignatures2.purs:8:35 - 8:36 (line 8, column while checking that type b has kind k1 while inferring the kind of Pair a b -while inferring the kind of Pair a b -> Pair' @k1 @k2 a b in type constructor Pair' See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, diff --git a/tests/purs/passing/Coercible.purs b/tests/purs/passing/Coercible.purs index 684b0e10cd..1a5f5b08fe 100644 --- a/tests/purs/passing/Coercible.purs +++ b/tests/purs/passing/Coercible.purs @@ -18,7 +18,7 @@ nt2ToNT1 :: NTString2 -> NTString1 nt2ToNT1 = coerce newtype Id1 a = Id1 a -newtype Id2 a = Id2 a +newtype Id2 b = Id2 b id1ToId2 :: forall a. Id1 a -> Id2 a id1ToId2 = coerce @@ -26,6 +26,11 @@ id1ToId2 = coerce id12ToId21 :: forall b. Id1 (Id2 b) -> Id2 (Id1 b) id12ToId21 = coerce +newtype Ap f a = Ap (f a) + +apId1ToApId2 :: forall a. Ap Id1 a -> Ap Id2 a +apId1ToApId2 = coerce + newtype Phantom1 a b = Phantom1 a phantom1TypeToPhantom1Symbol :: forall x (y :: Type) (z :: Symbol). Phantom1 x y -> Phantom1 x z @@ -115,6 +120,16 @@ data Rec3 a = Rec3 {} rec3ToRec3 :: forall m n. Rec3 m -> Rec3 n rec3ToRec3 = coerce +newtype Rec4 f = Rec4 (f {}) + +unwrapRec4 :: forall f. Rec4 f -> f {} +unwrapRec4 = coerce + +newtype Rec5 a f = Rec5 (f {}) + +apRec4ToApRec5 :: forall a. Ap Rec4 Id1 -> Ap (Rec5 a) Id1 +apRec4ToApRec5 = coerce + data Arr1 a b = Arr1 (Array a) (Array b) arr1ToArr1 :: Arr1 Int String -> Arr1 (Id1 Int) (Id2 String) From b1bb71bca58dd5cb52e7fd23c167dcb1e2bbb2c9 Mon Sep 17 00:00:00 2001 From: Jordan Mackie Date: Wed, 9 Sep 2020 13:01:18 +0100 Subject: [PATCH 1230/1580] Remove spurious doc comment on CoreFn Module (#3552) There have clearly been several changes since this comment was written, and this comment is now incorrect. Best to remove it. Co-authored-by: Jordan Mackie Co-authored-by: Ryan Hendrickson --- src/Language/PureScript/CoreFn/Module.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index a53077389a..ac8b0f84d5 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -12,9 +12,6 @@ import Language.PureScript.Names -- | -- The CoreFn module representation -- --- The json CoreFn representation does not contain type information. When --- parsing it one gets back `ModuleT () Ann` rather than `ModuleT Type Ann`, --- which is enough for `moduleToJs`. data Module a = Module { moduleSourceSpan :: SourceSpan , moduleComments :: [Comment] From 9edd4ff46e3fd9d616cfb46469685495a6ccb3eb Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Fri, 11 Sep 2020 19:24:00 -0700 Subject: [PATCH 1231/1580] Disallow cycles in foreign data kinds (#3929) * Disallow cycles in foreign data kinds * Fix deps signature guard in toposort * Refactor topsort vertices with fewer bools --- .../PureScript/Sugar/BindingGroups.hs | 27 +++++++++++++------ .../purs/failing/CycleInForeignDataKinds.out | 13 +++++++++ .../purs/failing/CycleInForeignDataKinds.purs | 5 ++++ tests/purs/failing/RowsInKinds.out | 2 +- tests/purs/passing/ForeignDataInKind.purs | 9 +++++++ 5 files changed, 47 insertions(+), 9 deletions(-) create mode 100644 tests/purs/failing/CycleInForeignDataKinds.out create mode 100644 tests/purs/failing/CycleInForeignDataKinds.purs create mode 100644 tests/purs/passing/ForeignDataInKind.purs diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 0d57c3ea3f..0a1d9c733b 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -28,6 +28,11 @@ import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Types +data VertexType + = VertexDefinition + | VertexKindSignature + deriving (Eq, Ord, Show) + -- | -- Replace all sets of mutually-recursive declarations in a module with binding groups -- @@ -67,22 +72,27 @@ createBindingGroups moduleName = mapM f <=< handleDecls handleDecls :: [Declaration] -> m [Declaration] handleDecls ds = do let values = mapMaybe (fmap (fmap extractGuardedExpr) . getValueDeclaration) ds - kindDecls = fmap (,True) $ filter isKindDecl ds - dataDecls = fmap (,False) $ filter (\a -> isDataDecl a || isExternDataDecl a || isTypeSynonymDecl a || isTypeClassDecl a) ds + kindDecls = fmap (,VertexKindSignature) $ filter (\a -> isKindDecl a || isExternDataDecl a) ds + dataDecls = fmap (,VertexDefinition) $ filter (\a -> isDataDecl a || isTypeSynonymDecl a || isTypeClassDecl a) ds kindSigs = fmap (declTypeName . fst) kindDecls typeSyns = fmap declTypeName $ filter isTypeSynonymDecl ds - allProperNames = fmap (declTypeName . fst) dataDecls allDecls = kindDecls ++ dataDecls - mkVert (d, isSig) = + allProperNames = fmap (declTypeName . fst) allDecls + mkVert (d, vty) = let names = usedTypeNames moduleName d `intersect` allProperNames name = declTypeName d -- If a dependency has a kind signature, than that's all we need to depend on, except -- in the case that we are defining a kind signature and using a type synonym. In order -- to expand the type synonym, we must depend on the synonym declaration itself. - deps = fmap (\n -> (n, n `elem` kindSigs && (isSig && not (n `elem` typeSyns)))) names - self | not isSig && name `elem` kindSigs = [(name, True)] - | otherwise = [] - in (d, (name, isSig), self ++ deps) + vtype n + | vty == VertexKindSignature && n `elem` typeSyns = VertexDefinition + | n `elem` kindSigs = VertexKindSignature + | otherwise = VertexDefinition + deps = fmap (\n -> (n, vtype n)) names + self + | vty == VertexDefinition && name `elem` kindSigs = [(name, VertexKindSignature)] + | otherwise = [] + in (d, (name, vty), self ++ deps) dataVerts = fmap mkVert allDecls dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup let allIdents = fmap valdeclIdent values @@ -226,6 +236,7 @@ toDataBindingGroup (CyclicSCC ds') | otherwise = return . DataBindingGroupDeclaration $ NEL.fromList ds' where kindDecl (KindDeclaration sa _ pn _) = [(fst sa, Qualified Nothing pn)] + kindDecl (ExternDataDeclaration sa pn _) = [(fst sa, Qualified Nothing pn)] kindDecl _ = [] isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName) diff --git a/tests/purs/failing/CycleInForeignDataKinds.out b/tests/purs/failing/CycleInForeignDataKinds.out new file mode 100644 index 0000000000..0f52489413 --- /dev/null +++ b/tests/purs/failing/CycleInForeignDataKinds.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/CycleInForeignDataKinds.purs:5:1 - 5:31 (line 5, column 1 - line 5, column 31) + + A cycle appears in a set of kind declarations: + + {Bar, Foo} + + Kind declarations may not refer to themselves in their own signatures. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInKindDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CycleInForeignDataKinds.purs b/tests/purs/failing/CycleInForeignDataKinds.purs new file mode 100644 index 0000000000..0328c410d0 --- /dev/null +++ b/tests/purs/failing/CycleInForeignDataKinds.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith CycleInKindDeclaration +module Main where + +foreign import data Foo :: Bar +foreign import data Bar :: Foo diff --git a/tests/purs/failing/RowsInKinds.out b/tests/purs/failing/RowsInKinds.out index a226e71125..5e32d41b44 100644 --- a/tests/purs/failing/RowsInKinds.out +++ b/tests/purs/failing/RowsInKinds.out @@ -5,7 +5,7 @@ at tests/purs/failing/RowsInKinds.purs:14:16 - 14:17 (line 14, column 16 - line Could not match kind    ( z :: Type -  | t25  +  | t24   )    with kind diff --git a/tests/purs/passing/ForeignDataInKind.purs b/tests/purs/passing/ForeignDataInKind.purs new file mode 100644 index 0000000000..664da3ccd1 --- /dev/null +++ b/tests/purs/passing/ForeignDataInKind.purs @@ -0,0 +1,9 @@ +module Main where + +import Prelude +import Effect.Console (log) + +foreign import data A :: Type +data B (x :: A) + +main = log "Done" From 983f2a056777000e95f79b8ac56484899620a285 Mon Sep 17 00:00:00 2001 From: Cyril Date: Sat, 12 Sep 2020 20:25:19 +0200 Subject: [PATCH 1232/1580] Expand type synonyms before role checking (#3909) --- src/Language/PureScript/TypeChecker.hs | 27 +++++++++++++------ .../failing/CoercibleRepresentational4.out | 19 +++++++++++++ .../failing/CoercibleRepresentational4.purs | 11 ++++++++ .../failing/CoercibleRepresentational5.out | 19 +++++++++++++ .../failing/CoercibleRepresentational5.purs | 15 +++++++++++ 5 files changed, 83 insertions(+), 8 deletions(-) create mode 100644 tests/purs/failing/CoercibleRepresentational4.out create mode 100644 tests/purs/failing/CoercibleRepresentational4.purs create mode 100644 tests/purs/failing/CoercibleRepresentational5.out create mode 100644 tests/purs/failing/CoercibleRepresentational5.purs diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 33b24558bb..e366ab0161 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -278,7 +278,8 @@ typeCheckAll moduleName _ = traverse go (dataCtors, ctorKind) <- kindOfData moduleName (sa, name, args, dctors) let args' = args `withKinds` ctorKind env <- getEnv - roles <- checkRoles env moduleName name args' dctors + dctors' <- traverse (replaceTypeSynonymsInDataConstructor . fst) dataCtors + roles <- checkRoles env moduleName name args' dctors' let args'' = args' `withRoles` roles addDataType moduleName dtype name args'' dataCtors ctorKind return $ DataDeclaration sa dtype name args dctors @@ -292,19 +293,21 @@ typeCheckAll moduleName _ = traverse go warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames) . addHint (PositionedError sss)) $ do env <- getEnv (syn_ks, data_ks, cls_ks) <- kindsOfAll moduleName syns (fmap snd dataDecls) (fmap snd clss) - let dataDeclsWithKinds = zipWith (\(dtype, (_, name, args, _)) (dataCtors, ctorKind) -> (dtype, name, args `withKinds` ctorKind, dataCtors, ctorKind)) dataDecls data_ks - checkRoles' = checkDataBindingGroupRoles env moduleName $ - map (\(_, name, args, dataCtors, _) -> (name, args, map fst dataCtors)) dataDeclsWithKinds + for_ (zip syns syn_ks) $ \((_, name, args, _), (elabTy, kind)) -> do + checkDuplicateTypeArguments $ map fst args + let args' = args `withKinds` kind + addTypeSynonym moduleName name args' elabTy kind + let dataDeclsWithKinds = zipWith (\(dtype, (_, name, args, _)) (dataCtors, ctorKind) -> + (dtype, name, args `withKinds` ctorKind, dataCtors, ctorKind)) dataDecls data_ks + checkRoles' <- fmap (checkDataBindingGroupRoles env moduleName) . + forM dataDeclsWithKinds $ \(_, name, args, dataCtors, _) -> + (name, args,) <$> traverse (replaceTypeSynonymsInDataConstructor . fst) dataCtors for_ dataDeclsWithKinds $ \(dtype, name, args', dataCtors, ctorKind) -> do when (dtype == Newtype) $ checkNewtype name (map fst dataCtors) checkDuplicateTypeArguments $ map fst args' roles <- checkRoles' name args' let args'' = args' `withRoles` roles addDataType moduleName dtype name args'' dataCtors ctorKind - for_ (zip syns syn_ks) $ \((_, name, args, _), (elabTy, kind)) -> do - checkDuplicateTypeArguments $ map fst args - let args' = args `withKinds` kind - addTypeSynonym moduleName name args' elabTy kind for_ (zip clss cls_ks) $ \((deps, (sa, pn, _, _, _)), (args', implies', tys', kind)) -> do let qualifiedClassName = Qualified (Just moduleName) pn guardWith (errorMessage (DuplicateTypeClass pn (fst sa))) $ @@ -565,6 +568,14 @@ typeCheckAll moduleName _ = traverse go withRoles :: [(Text, Maybe SourceType)] -> [Role] -> [(Text, Maybe SourceType, Role)] withRoles = zipWith $ \(v, k) r -> (v, k, r) + replaceTypeSynonymsInDataConstructor :: DataConstructorDeclaration -> m DataConstructorDeclaration + replaceTypeSynonymsInDataConstructor DataConstructorDeclaration{..} = do + dataCtorFields' <- traverse (traverse replaceAllTypeSynonyms) dataCtorFields + return DataConstructorDeclaration + { dataCtorFields = dataCtorFields' + , .. + } + checkNewtype :: forall m . MonadError MultipleErrors m diff --git a/tests/purs/failing/CoercibleRepresentational4.out b/tests/purs/failing/CoercibleRepresentational4.out new file mode 100644 index 0000000000..eb2a9a3d12 --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational4.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleRepresentational4.purs:11:38 - 11:44 (line 11, column 38 - line 11, column 44) + + No type class instance was found for +   +  Prim.Coerce.Coercible Int  +  String +   + +while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b + is at least as general as type Representational Int -> Representational String +while checking that expression coerce + has type Representational Int -> Representational String +in value declaration representationalToRepresentational + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleRepresentational4.purs b/tests/purs/failing/CoercibleRepresentational4.purs new file mode 100644 index 0000000000..d8383b8d15 --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational4.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +data F a = F a +type Synonym a = F a +data Representational a = Representational (Synonym a) + +representationalToRepresentational :: Representational Int -> Representational String +representationalToRepresentational = coerce diff --git a/tests/purs/failing/CoercibleRepresentational5.out b/tests/purs/failing/CoercibleRepresentational5.out new file mode 100644 index 0000000000..6a2534c21b --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational5.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleRepresentational5.purs:15:38 - 15:44 (line 15, column 38 - line 15, column 44) + + No type class instance was found for +   +  Prim.Coerce.Coercible Int  +  String +   + +while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b + is at least as general as type MutuallyRecursiveRepresentational2 Int -> MutuallyRecursiveRepresentational2 String +while checking that expression coerce + has type MutuallyRecursiveRepresentational2 Int -> MutuallyRecursiveRepresentational2 String +in value declaration representationalToRepresentational + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleRepresentational5.purs b/tests/purs/failing/CoercibleRepresentational5.purs new file mode 100644 index 0000000000..d073c29946 --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational5.purs @@ -0,0 +1,15 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +data MutuallyRecursiveRepresentational1 a + = MutuallyRecursiveRepresentational1 a (MutuallyRecursiveRepresentational2 a) + +type MutuallyRecursiveRepresentational1Synonym a = MutuallyRecursiveRepresentational1 a + +data MutuallyRecursiveRepresentational2 a + = MutuallyRecursiveRepresentational2 (MutuallyRecursiveRepresentational1Synonym a) + +representationalToRepresentational :: MutuallyRecursiveRepresentational2 Int -> MutuallyRecursiveRepresentational2 String +representationalToRepresentational = coerce From 02a1ab836db003c0c29c276d2c0aa4dcb95d201d Mon Sep 17 00:00:00 2001 From: Cyril Date: Sun, 13 Sep 2020 00:37:06 +0200 Subject: [PATCH 1233/1580] Fix `Coercible` golden tests (#3931) --- tests/purs/failing/CoercibleRepresentational4.out | 2 +- tests/purs/failing/CoercibleRepresentational5.out | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/purs/failing/CoercibleRepresentational4.out b/tests/purs/failing/CoercibleRepresentational4.out index eb2a9a3d12..3796706c6b 100644 --- a/tests/purs/failing/CoercibleRepresentational4.out +++ b/tests/purs/failing/CoercibleRepresentational4.out @@ -8,7 +8,7 @@ at tests/purs/failing/CoercibleRepresentational4.purs:11:38 - 11:44 (line 11, co  String   -while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Representational Int -> Representational String while checking that expression coerce has type Representational Int -> Representational String diff --git a/tests/purs/failing/CoercibleRepresentational5.out b/tests/purs/failing/CoercibleRepresentational5.out index 6a2534c21b..ac323ff661 100644 --- a/tests/purs/failing/CoercibleRepresentational5.out +++ b/tests/purs/failing/CoercibleRepresentational5.out @@ -8,7 +8,7 @@ at tests/purs/failing/CoercibleRepresentational5.purs:15:38 - 15:44 (line 15, co  String   -while checking that type forall (a :: Type) (b :: Type). Coercible a b => a -> b +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type MutuallyRecursiveRepresentational2 Int -> MutuallyRecursiveRepresentational2 String while checking that expression coerce has type MutuallyRecursiveRepresentational2 Int -> MutuallyRecursiveRepresentational2 String From bda95473476fd3443879d63ad3696bbddbcbd908 Mon Sep 17 00:00:00 2001 From: Cyril Date: Sun, 13 Sep 2020 17:32:41 +0200 Subject: [PATCH 1234/1580] Walk under constrained types during role inference (#3906) --- src/Language/PureScript/TypeChecker/Roles.hs | 22 ++++++++++------- tests/purs/failing/CoercibleConstrained1.out | 24 +++++++++++++++++++ tests/purs/failing/CoercibleConstrained1.purs | 11 +++++++++ tests/purs/failing/CoercibleConstrained2.out | 24 +++++++++++++++++++ tests/purs/failing/CoercibleConstrained2.purs | 11 +++++++++ tests/purs/failing/CoercibleConstrained3.out | 22 +++++++++++++++++ tests/purs/failing/CoercibleConstrained3.purs | 13 ++++++++++ tests/purs/passing/Coercible.purs | 11 +++++++++ 8 files changed, 130 insertions(+), 8 deletions(-) create mode 100644 tests/purs/failing/CoercibleConstrained1.out create mode 100644 tests/purs/failing/CoercibleConstrained1.purs create mode 100644 tests/purs/failing/CoercibleConstrained2.out create mode 100644 tests/purs/failing/CoercibleConstrained2.purs create mode 100644 tests/purs/failing/CoercibleConstrained3.out create mode 100644 tests/purs/failing/CoercibleConstrained3.purs diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index a08f5ee80b..9fe3073c3c 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -187,6 +187,10 @@ inferDataDeclarationRoles moduleName (tyName, tyArgs, ctors) roleEnv = -- doesn't appear as a spurious parameter to @D@ when we complete -- inference. walk (S.insert tv btvs) t + walk btvs (ConstrainedType _ Constraint{..} t) = + -- For constrained types, mark all free variables in the constraint + -- arguments as nominal and recurse on the type beneath the constraint. + walk btvs t <> foldMap (freeNominals btvs) constraintArgs walk btvs (RCons _ _ thead ttail) = do -- For row types, we just walk along them and collect the results. walk btvs thead <> walk btvs ttail @@ -214,7 +218,7 @@ inferDataDeclarationRoles moduleName (tyName, tyArgs, ctors) roleEnv = t1Roles = fromMaybe (repeat Phantom) $ M.lookup t1Name roleEnv k role ti = case role of Nominal -> - freeNominals ti + freeNominals btvs ti Representational -> go ti Phantom -> @@ -224,14 +228,16 @@ inferDataDeclarationRoles moduleName (tyName, tyArgs, ctors) roleEnv = -- that term to collect its roles and mark all free variables in -- its argument as nominal. _ -> do - go t1 <> foldMap freeNominals t2s + go t1 <> foldMap (freeNominals btvs) t2s | otherwise = mempty where go = walk btvs - -- Given a type, computes the list of free variables in that type - -- (taking into account those bound in @walk@) and returns a @RoleMap@ - -- ascribing a nominal role to each of those variables. - freeNominals x = - let ftvs = filter (flip S.notMember btvs) (freeTypeVariables x) - in RoleMap (M.fromList $ map (, Nominal) ftvs) + +-- Given a type, computes the list of free variables in that type +-- (taking into account those bound in @walk@) and returns a @RoleMap@ +-- ascribing a nominal role to each of those variables. +freeNominals :: S.Set Text -> SourceType -> RoleMap +freeNominals btvs x = + let ftvs = filter (flip S.notMember btvs) (freeTypeVariables x) + in RoleMap (M.fromList $ map (, Nominal) ftvs) diff --git a/tests/purs/failing/CoercibleConstrained1.out b/tests/purs/failing/CoercibleConstrained1.out new file mode 100644 index 0000000000..9731721f9c --- /dev/null +++ b/tests/purs/failing/CoercibleConstrained1.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleConstrained1.purs:11:28 - 11:34 (line 11, column 28 - line 11, column 34) + + No type class instance was found for +   +  Prim.Coerce.Coercible a0 +  b1 +   + +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b + is at least as general as type Constrained a0 -> Constrained b1 +while checking that expression coerce + has type Constrained a0 -> Constrained b1 +in value declaration constrainedToConstrained + +where a0 is a rigid type variable + bound at (line 11, column 28 - line 11, column 34) + b1 is a rigid type variable + bound at (line 11, column 28 - line 11, column 34) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleConstrained1.purs b/tests/purs/failing/CoercibleConstrained1.purs new file mode 100644 index 0000000000..cf462c6aa9 --- /dev/null +++ b/tests/purs/failing/CoercibleConstrained1.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +class Nullary + +data Constrained a = Constrained (Nullary => a) + +constrainedToConstrained :: forall a b. Constrained a -> Constrained b +constrainedToConstrained = coerce diff --git a/tests/purs/failing/CoercibleConstrained2.out b/tests/purs/failing/CoercibleConstrained2.out new file mode 100644 index 0000000000..6507a61898 --- /dev/null +++ b/tests/purs/failing/CoercibleConstrained2.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleConstrained2.purs:11:28 - 11:34 (line 11, column 28 - line 11, column 34) + + No type class instance was found for +   +  Prim.Coerce.Coercible (Constrained a0) +  (Constrained b1) +   + +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b + is at least as general as type Constrained a0 -> Constrained b1 +while checking that expression coerce + has type Constrained a0 -> Constrained b1 +in value declaration constrainedToConstrained + +where a0 is a rigid type variable + bound at (line 11, column 28 - line 11, column 34) + b1 is a rigid type variable + bound at (line 11, column 28 - line 11, column 34) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleConstrained2.purs b/tests/purs/failing/CoercibleConstrained2.purs new file mode 100644 index 0000000000..c4c962dfc9 --- /dev/null +++ b/tests/purs/failing/CoercibleConstrained2.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +class Unary a + +data Constrained a = Constrained (Unary a => a) + +constrainedToConstrained :: forall a b. Constrained a -> Constrained b +constrainedToConstrained = coerce diff --git a/tests/purs/failing/CoercibleConstrained3.out b/tests/purs/failing/CoercibleConstrained3.out new file mode 100644 index 0000000000..d5a6d3e9f6 --- /dev/null +++ b/tests/purs/failing/CoercibleConstrained3.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleConstrained3.purs:13:28 - 13:34 (line 13, column 28 - line 13, column 34) + + No type class instance was found for +   +  Prim.Coerce.Coercible (Constrained a0)  +  (Constrained (N a0)) +   + +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b + is at least as general as type Constrained a0 -> Constrained (N a0) +while checking that expression coerce + has type Constrained a0 -> Constrained (N a0) +in value declaration constrainedToConstrained + +where a0 is a rigid type variable + bound at (line 13, column 28 - line 13, column 34) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleConstrained3.purs b/tests/purs/failing/CoercibleConstrained3.purs new file mode 100644 index 0000000000..6db08eeb52 --- /dev/null +++ b/tests/purs/failing/CoercibleConstrained3.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +class Unary a + +data Constrained a = Constrained (Unary a => a) + +newtype N a = N a + +constrainedToConstrained :: forall a. Constrained a -> Constrained (N a) +constrainedToConstrained = coerce diff --git a/tests/purs/passing/Coercible.purs b/tests/purs/passing/Coercible.purs index 1a5f5b08fe..a63348194b 100644 --- a/tests/purs/passing/Coercible.purs +++ b/tests/purs/passing/Coercible.purs @@ -159,6 +159,17 @@ type role MyMap nominal representational mapToMap :: MyMap String String -> MyMap String NTString1 mapToMap = coerce +class Unary a + +data Constrained1 a b = Constrained1 (Unary a => b) + +constrained1ToConstrained1 :: forall a b. Constrained1 a b -> Constrained1 a (Id1 b) +constrained1ToConstrained1 = coerce + +data Constrained2 a = Constrained2 a (forall a. Unary a => a) + +type role Constrained2 representational + -- "role" should only be a reserved word after "type" testRoleNotReserved :: String -> String testRoleNotReserved role = role From d159242be16178132a9eb1aba22b616f94a54f09 Mon Sep 17 00:00:00 2001 From: Cyril Date: Tue, 15 Sep 2020 01:59:30 +0200 Subject: [PATCH 1235/1580] Check role declarations make sense (#3881) * Check orphan role declarations * Check role declarations arity * Check unsupported role declarations for type classes and type synonyms * Check duplicate role declarations * Restrict roles to be declared directly after their type --- src/Language/PureScript/Errors.hs | 29 +++++++++++++++ .../PureScript/Sugar/TypeDeclarations.hs | 37 +++++++++++++++++++ .../purs/failing/DuplicateRoleDeclaration.out | 10 +++++ .../failing/DuplicateRoleDeclaration.purs | 6 +++ tests/purs/failing/OrphanRoleDeclaration1.out | 10 +++++ .../purs/failing/OrphanRoleDeclaration1.purs | 4 ++ tests/purs/failing/OrphanRoleDeclaration2.out | 10 +++++ .../purs/failing/OrphanRoleDeclaration2.purs | 5 +++ tests/purs/failing/OrphanRoleDeclaration3.out | 10 +++++ .../purs/failing/OrphanRoleDeclaration3.purs | 8 ++++ .../failing/RoleDeclarationArityMismatch.out | 10 +++++ .../failing/RoleDeclarationArityMismatch.purs | 5 +++ .../RoleDeclarationArityMismatchForeign.out | 10 +++++ .../RoleDeclarationArityMismatchForeign.purs | 5 +++ .../UnsupportedRoleDeclarationTypeClass.out | 10 +++++ .../UnsupportedRoleDeclarationTypeClass.purs | 5 +++ .../UnsupportedRoleDeclarationTypeSynonym.out | 10 +++++ ...UnsupportedRoleDeclarationTypeSynonym.purs | 7 ++++ 18 files changed, 191 insertions(+) create mode 100644 tests/purs/failing/DuplicateRoleDeclaration.out create mode 100644 tests/purs/failing/DuplicateRoleDeclaration.purs create mode 100644 tests/purs/failing/OrphanRoleDeclaration1.out create mode 100644 tests/purs/failing/OrphanRoleDeclaration1.purs create mode 100644 tests/purs/failing/OrphanRoleDeclaration2.out create mode 100644 tests/purs/failing/OrphanRoleDeclaration2.purs create mode 100644 tests/purs/failing/OrphanRoleDeclaration3.out create mode 100644 tests/purs/failing/OrphanRoleDeclaration3.purs create mode 100644 tests/purs/failing/RoleDeclarationArityMismatch.out create mode 100644 tests/purs/failing/RoleDeclarationArityMismatch.purs create mode 100644 tests/purs/failing/RoleDeclarationArityMismatchForeign.out create mode 100644 tests/purs/failing/RoleDeclarationArityMismatchForeign.purs create mode 100644 tests/purs/failing/UnsupportedRoleDeclarationTypeClass.out create mode 100644 tests/purs/failing/UnsupportedRoleDeclarationTypeClass.purs create mode 100644 tests/purs/failing/UnsupportedRoleDeclarationTypeSynonym.out create mode 100644 tests/purs/failing/UnsupportedRoleDeclarationTypeSynonym.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 5ee4896590..ced6c5a131 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -72,6 +72,7 @@ data SimpleErrorMessage | MultipleTypeOpFixities (OpName 'TypeOpName) | OrphanTypeDeclaration Ident | OrphanKindDeclaration (ProperName 'TypeName) + | OrphanRoleDeclaration (ProperName 'TypeName) | RedefinedIdent Ident | OverlappingNamesInLet | UnknownName (Qualified Name) @@ -181,6 +182,9 @@ data SimpleErrorMessage Role -- ^ inferred role Role -- ^ declared role | InvalidCoercibleInstanceDeclaration [SourceType] + | UnsupportedRoleDeclaration + | RoleDeclarationArityMismatch (ProperName 'TypeName) Int Int + | DuplicateRoleDeclaration (ProperName 'TypeName) deriving (Show) data ErrorMessage = ErrorMessage @@ -237,6 +241,7 @@ errorCode em = case unwrapErrorMessage em of MultipleTypeOpFixities{} -> "MultipleTypeOpFixities" OrphanTypeDeclaration{} -> "OrphanTypeDeclaration" OrphanKindDeclaration{} -> "OrphanKindDeclaration" + OrphanRoleDeclaration{} -> "OrphanRoleDeclaration" RedefinedIdent{} -> "RedefinedIdent" OverlappingNamesInLet -> "OverlappingNamesInLet" UnknownName{} -> "UnknownName" @@ -338,6 +343,9 @@ errorCode em = case unwrapErrorMessage em of UnsupportedTypeInKind {} -> "UnsupportedTypeInKind" RoleMismatch {} -> "RoleMismatch" InvalidCoercibleInstanceDeclaration {} -> "InvalidCoercibleInstanceDeclaration" + UnsupportedRoleDeclaration {} -> "UnsupportedRoleDeclaration" + RoleDeclarationArityMismatch {} -> "RoleDeclarationArityMismatch" + DuplicateRoleDeclaration {} -> "DuplicateRoleDeclaration" -- | A stack trace for an error newtype MultipleErrors = MultipleErrors @@ -711,6 +719,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "The type declaration for " <> markCode (showIdent nm) <> " should be followed by its definition." renderSimpleErrorMessage (OrphanKindDeclaration nm) = line $ "The kind declaration for " <> markCode (runProperName nm) <> " should be followed by its definition." + renderSimpleErrorMessage (OrphanRoleDeclaration nm) = + line $ "The role declaration for " <> markCode (runProperName nm) <> " should follow its definition." renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident i)))) | i `elem` [ C.bind, C.discard ] = @@ -1306,6 +1316,25 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , line "Instance declarations of this type class are disallowed." ] + renderSimpleErrorMessage UnsupportedRoleDeclaration = + line $ "Role declarations are only supported for data types, not for type synonyms nor type classes." + + renderSimpleErrorMessage (RoleDeclarationArityMismatch name expected actual) = + line $ T.intercalate " " + [ "The type" + , markCode (runProperName name) + , "expects" + , T.pack (show expected) + , if expected == 1 then "argument" else "arguments" + , "but its role declaration lists" + <> if actual > expected then "" else " only" + , T.pack (show actual) + , if actual > 1 then "roles" else "role" + ] <> "." + + renderSimpleErrorMessage (DuplicateRoleDeclaration name) = + line $ "Duplicate role declaration for " <> markCode (runProperName name) <> "." + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1@RCons{} t2@RCons{}) detail = let (row1Box, row2Box) = printRows t1 t2 diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 709eafec8b..a3ce38d47e 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -27,6 +27,7 @@ desugarTypeDeclarationsModule desugarTypeDeclarationsModule (Module modSS coms name ds exps) = rethrow (addHint (ErrorInModule name)) $ do checkKindDeclarations ds + checkRoleDeclarations Nothing ds Module modSS coms name <$> desugarTypeDeclarations ds <*> pure exps where @@ -71,3 +72,39 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) = throwError . errorMessage' (fst sa) $ OrphanKindDeclaration name' checkKindDeclarations (_ : rest) = checkKindDeclarations rest checkKindDeclarations [] = return () + + checkRoleDeclarations :: Maybe Declaration -> [Declaration] -> m () + checkRoleDeclarations Nothing (RoleDeclaration RoleDeclarationData{..} : _) = + throwError . errorMessage' (fst rdeclSourceAnn) $ OrphanRoleDeclaration rdeclIdent + checkRoleDeclarations (Just (RoleDeclaration (RoleDeclarationData _ name' _))) ((RoleDeclaration (RoleDeclarationData{..})) : _) | name' == rdeclIdent = + throwError . errorMessage' (fst rdeclSourceAnn) $ DuplicateRoleDeclaration rdeclIdent + checkRoleDeclarations (Just d) (rd@(RoleDeclaration (RoleDeclarationData{..})) : rest) = do + unless (matchesDeclaration d) . throwError . errorMessage' (fst rdeclSourceAnn) $ OrphanRoleDeclaration rdeclIdent + unless (isSupported d) . throwError . errorMessage' (fst rdeclSourceAnn) $ UnsupportedRoleDeclaration + checkRoleDeclarationArity d + checkRoleDeclarations (Just rd) rest + where + isSupported :: Declaration -> Bool + isSupported (DataDeclaration{}) = True + isSupported (ExternDataDeclaration{}) = True + isSupported _ = False + matchesDeclaration :: Declaration -> Bool + matchesDeclaration (DataDeclaration _ _ name' _ _) = rdeclIdent == name' + matchesDeclaration (ExternDataDeclaration _ name' _) = rdeclIdent == name' + matchesDeclaration (TypeSynonymDeclaration _ name' _ _) = rdeclIdent == name' + matchesDeclaration (TypeClassDeclaration _ name' _ _ _ _) = rdeclIdent == coerceProperName name' + matchesDeclaration _ = False + checkRoleDeclarationArity :: Declaration -> m () + checkRoleDeclarationArity (DataDeclaration _ _ _ args _) = + throwRoleDeclarationArityMismatch $ length args + checkRoleDeclarationArity (ExternDataDeclaration _ _ kind) = + throwRoleDeclarationArityMismatch $ kindArity kind + checkRoleDeclarationArity _ = return () + throwRoleDeclarationArityMismatch :: Int -> m () + throwRoleDeclarationArityMismatch expected = do + let actual = length rdeclRoles + unless (expected == actual) $ + throwError . errorMessage' (fst rdeclSourceAnn) $ + RoleDeclarationArityMismatch rdeclIdent expected actual + checkRoleDeclarations _ (d : rest) = checkRoleDeclarations (Just d) rest + checkRoleDeclarations _ [] = return () diff --git a/tests/purs/failing/DuplicateRoleDeclaration.out b/tests/purs/failing/DuplicateRoleDeclaration.out new file mode 100644 index 0000000000..3c4a29664f --- /dev/null +++ b/tests/purs/failing/DuplicateRoleDeclaration.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DuplicateRoleDeclaration.purs:6:1 - 6:20 (line 6, column 1 - line 6, column 20) + + Duplicate role declaration for A. + + +See https://github.com/purescript/documentation/blob/master/errors/DuplicateRoleDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DuplicateRoleDeclaration.purs b/tests/purs/failing/DuplicateRoleDeclaration.purs new file mode 100644 index 0000000000..590b24a4fa --- /dev/null +++ b/tests/purs/failing/DuplicateRoleDeclaration.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DuplicateRoleDeclaration +module Main where + +data A a = A +type role A nominal +type role A phantom diff --git a/tests/purs/failing/OrphanRoleDeclaration1.out b/tests/purs/failing/OrphanRoleDeclaration1.out new file mode 100644 index 0000000000..754bc4bb57 --- /dev/null +++ b/tests/purs/failing/OrphanRoleDeclaration1.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/OrphanRoleDeclaration1.purs:4:1 - 4:20 (line 4, column 1 - line 4, column 20) + + The role declaration for D should follow its definition. + + +See https://github.com/purescript/documentation/blob/master/errors/OrphanRoleDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OrphanRoleDeclaration1.purs b/tests/purs/failing/OrphanRoleDeclaration1.purs new file mode 100644 index 0000000000..5ca3d6e55d --- /dev/null +++ b/tests/purs/failing/OrphanRoleDeclaration1.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith OrphanRoleDeclaration +module Main where + +type role D nominal diff --git a/tests/purs/failing/OrphanRoleDeclaration2.out b/tests/purs/failing/OrphanRoleDeclaration2.out new file mode 100644 index 0000000000..6809df3c8b --- /dev/null +++ b/tests/purs/failing/OrphanRoleDeclaration2.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/OrphanRoleDeclaration2.purs:4:1 - 4:20 (line 4, column 1 - line 4, column 20) + + The role declaration for D should follow its definition. + + +See https://github.com/purescript/documentation/blob/master/errors/OrphanRoleDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OrphanRoleDeclaration2.purs b/tests/purs/failing/OrphanRoleDeclaration2.purs new file mode 100644 index 0000000000..d850506354 --- /dev/null +++ b/tests/purs/failing/OrphanRoleDeclaration2.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith OrphanRoleDeclaration +module Main where + +type role D nominal +data D a = D a diff --git a/tests/purs/failing/OrphanRoleDeclaration3.out b/tests/purs/failing/OrphanRoleDeclaration3.out new file mode 100644 index 0000000000..4440913933 --- /dev/null +++ b/tests/purs/failing/OrphanRoleDeclaration3.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/OrphanRoleDeclaration3.purs:8:1 - 8:21 (line 8, column 1 - line 8, column 21) + + The role declaration for D1 should follow its definition. + + +See https://github.com/purescript/documentation/blob/master/errors/OrphanRoleDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OrphanRoleDeclaration3.purs b/tests/purs/failing/OrphanRoleDeclaration3.purs new file mode 100644 index 0000000000..7671c11d9f --- /dev/null +++ b/tests/purs/failing/OrphanRoleDeclaration3.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith OrphanRoleDeclaration +module Main where + +data D1 a = D1 a + +data D2 a = D2 a + +type role D1 nominal diff --git a/tests/purs/failing/RoleDeclarationArityMismatch.out b/tests/purs/failing/RoleDeclarationArityMismatch.out new file mode 100644 index 0000000000..133673dd3b --- /dev/null +++ b/tests/purs/failing/RoleDeclarationArityMismatch.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/RoleDeclarationArityMismatch.purs:5:1 - 5:20 (line 5, column 1 - line 5, column 20) + + The type A expects 0 arguments but its role declaration lists 1 role. + + +See https://github.com/purescript/documentation/blob/master/errors/RoleDeclarationArityMismatch.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RoleDeclarationArityMismatch.purs b/tests/purs/failing/RoleDeclarationArityMismatch.purs new file mode 100644 index 0000000000..80c1f34ece --- /dev/null +++ b/tests/purs/failing/RoleDeclarationArityMismatch.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith RoleDeclarationArityMismatch +module Main where + +data A = A +type role A nominal diff --git a/tests/purs/failing/RoleDeclarationArityMismatchForeign.out b/tests/purs/failing/RoleDeclarationArityMismatchForeign.out new file mode 100644 index 0000000000..ad3c1378c9 --- /dev/null +++ b/tests/purs/failing/RoleDeclarationArityMismatchForeign.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/RoleDeclarationArityMismatchForeign.purs:5:1 - 5:20 (line 5, column 1 - line 5, column 20) + + The type A expects 0 arguments but its role declaration lists 1 role. + + +See https://github.com/purescript/documentation/blob/master/errors/RoleDeclarationArityMismatch.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RoleDeclarationArityMismatchForeign.purs b/tests/purs/failing/RoleDeclarationArityMismatchForeign.purs new file mode 100644 index 0000000000..5eb29f8665 --- /dev/null +++ b/tests/purs/failing/RoleDeclarationArityMismatchForeign.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith RoleDeclarationArityMismatch +module Main where + +foreign import data A :: Type +type role A nominal diff --git a/tests/purs/failing/UnsupportedRoleDeclarationTypeClass.out b/tests/purs/failing/UnsupportedRoleDeclarationTypeClass.out new file mode 100644 index 0000000000..91751a89d5 --- /dev/null +++ b/tests/purs/failing/UnsupportedRoleDeclarationTypeClass.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/UnsupportedRoleDeclarationTypeClass.purs:5:1 - 5:29 (line 5, column 1 - line 5, column 29) + + Role declarations are only supported for data types, not for type synonyms nor type classes. + + +See https://github.com/purescript/documentation/blob/master/errors/UnsupportedRoleDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnsupportedRoleDeclarationTypeClass.purs b/tests/purs/failing/UnsupportedRoleDeclarationTypeClass.purs new file mode 100644 index 0000000000..58416510bd --- /dev/null +++ b/tests/purs/failing/UnsupportedRoleDeclarationTypeClass.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith UnsupportedRoleDeclaration +module Main where + +class C a +type role C representational diff --git a/tests/purs/failing/UnsupportedRoleDeclarationTypeSynonym.out b/tests/purs/failing/UnsupportedRoleDeclarationTypeSynonym.out new file mode 100644 index 0000000000..b1886dece5 --- /dev/null +++ b/tests/purs/failing/UnsupportedRoleDeclarationTypeSynonym.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/UnsupportedRoleDeclarationTypeSynonym.purs:7:1 - 7:20 (line 7, column 1 - line 7, column 20) + + Role declarations are only supported for data types, not for type synonyms nor type classes. + + +See https://github.com/purescript/documentation/blob/master/errors/UnsupportedRoleDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnsupportedRoleDeclarationTypeSynonym.purs b/tests/purs/failing/UnsupportedRoleDeclarationTypeSynonym.purs new file mode 100644 index 0000000000..921402541e --- /dev/null +++ b/tests/purs/failing/UnsupportedRoleDeclarationTypeSynonym.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith UnsupportedRoleDeclaration +module Main where + +data A a = A + +type B a = A a +type role B nominal From c8081249d98c58e9def4df5b2e9db082bb137961 Mon Sep 17 00:00:00 2001 From: Cyril Date: Wed, 16 Sep 2020 16:42:40 +0200 Subject: [PATCH 1236/1580] Solve `Coercible` constraints on rows (#3878) --- src/Language/PureScript/Docs/Prim.hs | 7 +++ .../PureScript/TypeChecker/Entailment.hs | 15 ++++++ .../failing/CoercibleClosedRowsDoNotUnify.out | 39 +++++++++++++++ .../CoercibleClosedRowsDoNotUnify.purs | 7 +++ .../failing/CoercibleOpenRowsDoNotUnify.out | 47 +++++++++++++++++++ .../failing/CoercibleOpenRowsDoNotUnify.purs | 7 +++ tests/purs/passing/Coercible.purs | 15 ++++++ 7 files changed, 137 insertions(+) create mode 100644 tests/purs/failing/CoercibleClosedRowsDoNotUnify.out create mode 100644 tests/purs/failing/CoercibleClosedRowsDoNotUnify.purs create mode 100644 tests/purs/failing/CoercibleOpenRowsDoNotUnify.out create mode 100644 tests/purs/failing/CoercibleOpenRowsDoNotUnify.purs diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index e99854a414..c0a20267cb 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -424,6 +424,13 @@ coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines , "This rule may seem puzzling since it is impossible to apply `coerce` to a term" , "of type `NT1` but it is necessary to coerce types with higher kinded parameters." , "" + , "Fifth, every pair of rows can be coerced if they have the same labels" + , "and the corresponding types for each label are coercible:" + , "" + , " instance coercibleRow :: Coercible a b => Coercible ( label :: a ) ( label :: b )" + , "" + , "Closed rows can't be coerced to open rows and open rows can only be" + , "coerced to open rows with the same row variable." ] kindOrdering :: Declaration diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 02fb947cf7..6def75750d 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -427,6 +427,21 @@ entails SolverOptions{..} constraint context hints = let a' = foldl' srcTypeApp a tys b' = foldl' srcTypeApp b tys pure $ Just [srcCoercibleConstraint kind a' b'] + -- If both arguments have kind @Row k@, yield new wanted constraints + -- in terms of pairs of types with the same label in both rows (e.g. + -- @Coercible D D'@ given @Coercible ( label :: D ) ( label :: D' )@) + -- and fail when some labels are exclusive to one row (e.g. @extra@ + -- in the constraint @Coercible () ( extra :: D )@) or when the tails + -- don’t unify (e.g. @()@ and @r@ in @Coercible () ( | r )@ or + -- @r@ and @s@ in @Coercible ( | r ) ( | s )@). + | RCons _ _ ty _ <- a = do + k <- elaborateKind ty + case alignRowsWith (srcCoercibleConstraint k) a b of + (constraints, (([], tail1), ([], tail2))) -> do + rethrow (const . errorMessage . NoInstanceFound $ srcCoercibleConstraint (kindRow k) a b) $ unifyTypes tail1 tail2 + pure $ Just constraints + (_, (rl1, rl2)) -> + throwError . errorMessage $ TypesDoNotUnify (rowFromList rl1) (rowFromList rl2) | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b , not (null axs) && aTyName == bTyName diff --git a/tests/purs/failing/CoercibleClosedRowsDoNotUnify.out b/tests/purs/failing/CoercibleClosedRowsDoNotUnify.out new file mode 100644 index 0000000000..353c189b63 --- /dev/null +++ b/tests/purs/failing/CoercibleClosedRowsDoNotUnify.out @@ -0,0 +1,39 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleClosedRowsDoNotUnify.purs:7:12 - 7:18 (line 7, column 12 - line 7, column 18) + + Could not match type +   +  ( x :: Int +  ...  +  )  +   + with type +   +  ( y :: String +  ...  +  )  +   + +while solving type class constraint +  + Prim.Coerce.Coercible ( x :: Int  + )  + ( y :: String + )  +  +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b + is at least as general as type { x :: Int  + }  + -> { y :: String +  }  +while checking that expression coerce + has type { x :: Int  + }  + -> { y :: String +  }  +in value declaration recToRec + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleClosedRowsDoNotUnify.purs b/tests/purs/failing/CoercibleClosedRowsDoNotUnify.purs new file mode 100644 index 0000000000..202ee0d87a --- /dev/null +++ b/tests/purs/failing/CoercibleClosedRowsDoNotUnify.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Safe.Coerce (coerce) + +recToRec :: { x :: Int } -> { y :: String } +recToRec = coerce diff --git a/tests/purs/failing/CoercibleOpenRowsDoNotUnify.out b/tests/purs/failing/CoercibleOpenRowsDoNotUnify.out new file mode 100644 index 0000000000..a311951420 --- /dev/null +++ b/tests/purs/failing/CoercibleOpenRowsDoNotUnify.out @@ -0,0 +1,47 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleOpenRowsDoNotUnify.purs:7:12 - 7:18 (line 7, column 12 - line 7, column 18) + + No type class instance was found for +   +  Prim.Coerce.Coercible ( x :: Int +  | r0  +  )  +  ( x :: Int +  | s1  +  )  +   + +while solving type class constraint +  + Prim.Coerce.Coercible { x :: Int + | r0  + }  + { x :: Int + | s1  + }  +  +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b + is at least as general as type { x :: Int  + | r0  + }  + -> { x :: Int +  | s1  +  }  +while checking that expression coerce + has type { x :: Int  + | r0  + }  + -> { x :: Int +  | s1  +  }  +in value declaration recToRec + +where r0 is a rigid type variable + bound at (line 7, column 12 - line 7, column 18) + s1 is a rigid type variable + bound at (line 7, column 12 - line 7, column 18) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleOpenRowsDoNotUnify.purs b/tests/purs/failing/CoercibleOpenRowsDoNotUnify.purs new file mode 100644 index 0000000000..d9d0782381 --- /dev/null +++ b/tests/purs/failing/CoercibleOpenRowsDoNotUnify.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +recToRec :: forall r s. { x :: Int | r } -> { x :: Int | s } +recToRec = coerce diff --git a/tests/purs/passing/Coercible.purs b/tests/purs/passing/Coercible.purs index a63348194b..3425121dfc 100644 --- a/tests/purs/passing/Coercible.purs +++ b/tests/purs/passing/Coercible.purs @@ -130,6 +130,21 @@ newtype Rec5 a f = Rec5 (f {}) apRec4ToApRec5 :: forall a. Ap Rec4 Id1 -> Ap (Rec5 a) Id1 apRec4ToApRec5 = coerce +type Rec6 a = { f :: a } + +rec6ToRec6 :: Rec6 Int -> Rec6 (Id1 Int) +rec6ToRec6 = coerce + +type Rec7 a b = { f :: a, g :: Int, h :: b } + +rec7ToRec7 :: Rec7 Int (Phantom2 String) -> Rec7 (Id1 Int) (Phantom2 Int) +rec7ToRec7 = coerce + +type Rec8 r a = { f :: a | r } + +rec8ToRec8 :: ∀ r. Rec8 r Int -> Rec8 r (Id1 Int) +rec8ToRec8 = coerce + data Arr1 a b = Arr1 (Array a) (Array b) arr1ToArr1 :: Arr1 Int String -> Arr1 (Id1 Int) (Id2 String) From f737ada1cec127dd8aa3638417abead4a7df1bed Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 17 Sep 2020 00:07:02 +0100 Subject: [PATCH 1237/1580] Bump version for 0.14.0-rc2 (#3934) The rc1 I already tagged is no good, because I forgot to update the version. That is particularly important for this release, because tools like psa need to be able to know what version of the CLI they have encountered in order to know whether to read from stdout or stderr if they want to maintain compatibility with both 0.13.x and 0.14.x. --- app/Version.hs | 9 ++++++++- package.yaml | 2 +- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/app/Version.hs b/app/Version.hs index d56dad912a..3bb1c8571a 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -12,8 +12,15 @@ import Paths_purescript as Paths import qualified Development.GitRev as GitRev #endif +-- Unfortunately, Cabal doesn't support prerelease identifiers on versions. To +-- avoid misleading users who run `purs --version`, we manually add the +-- prerelease identifier here (if any). When releasing a proper version, simply +-- set this to an empty string. +prerelease :: String +prerelease = "-rc2" + versionString :: String -versionString = showVersion Paths.version ++ extra +versionString = showVersion Paths.version ++ prerelease ++ extra where #ifdef RELEASE extra = "" diff --git a/package.yaml b/package.yaml index 93ffaff252..e681332372 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.13.8' +version: '0.14.0-rc2' # note: when updating this, update the prerelease identifier in app/Version.hs too! synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 9fff5e335e1d80a06665bbc4505875a5a1d0946d Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sat, 19 Sep 2020 11:16:26 -0700 Subject: [PATCH 1238/1580] Desugar type operator aliases inside parens (#3935) Fixes #3107 --- src/Language/PureScript/Sugar/Operators.hs | 4 ++-- src/Language/PureScript/Sugar/Operators/Types.hs | 2 +- tests/purs/passing/TypeOperators.purs | 3 +++ 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 942b2c0dcf..9f7bbcda47 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -167,10 +167,10 @@ rebracketFiltered pred_ externs modules = do goBinder pos other = return (pos, other) goType :: SourceSpan -> SourceType -> m SourceType - goType pos (BinaryNoParensType ann (TypeOp ann2 op) lhs rhs) = + goType pos (TypeOp ann2 op) = case op `M.lookup` typeAliased of Just alias -> - return $ TypeApp ann (TypeApp ann (TypeConstructor ann2 alias) lhs) rhs + return $ TypeConstructor ann2 alias Nothing -> throwError . errorMessage' pos $ UnknownName $ fmap TyOpName op goType _ other = return other diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs index fd2e1a188d..435a3e0d82 100644 --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -31,4 +31,4 @@ matchTypeOperators ss = matchOperators isBinOp extractOp fromOp reapply id fromOp _ = Nothing reapply :: a -> Qualified (OpName 'TypeOpName) -> SourceType -> SourceType -> SourceType - reapply _ = srcBinaryNoParensType . srcTypeOp + reapply _ op t1 t2 = srcTypeApp (srcTypeApp (TypeOp (ss, []) op) t1) t2 diff --git a/tests/purs/passing/TypeOperators.purs b/tests/purs/passing/TypeOperators.purs index 2c0c4df8b3..7c1362809c 100644 --- a/tests/purs/passing/TypeOperators.purs +++ b/tests/purs/passing/TypeOperators.purs @@ -14,6 +14,9 @@ testPrecedence1 x = x testPrecedence2 ∷ ∀ f g. f ~> g → f ~> g testPrecedence2 nat fx = nat fx +testParens ∷ ∀ f g. (~>) f g → (~>) f g +testParens nat = nat + swap ∷ ∀ a b. a /\ b → b /\ a swap (a /\ b) = b /\ a From 7030486677fd2d2fa5a24033ac4e0fe876d9fc71 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sat, 26 Sep 2020 13:08:12 -0700 Subject: [PATCH 1239/1580] Check all recursive paths in data binding groups (#3936) * Check all recursive paths in data binding groups This changes the data binding group check to follow all dependency paths, looking for loops in synonyms. Fixes #3918 * Add names to synonym cycle error --- src/Language/PureScript/Errors.hs | 17 +++++---- .../PureScript/Sugar/BindingGroups.hs | 36 +++++++++++++------ tests/purs/failing/InfiniteKind2.out | 2 +- tests/purs/failing/TypeSynonyms.out | 5 ++- tests/purs/failing/TypeSynonyms6.out | 14 ++++++++ tests/purs/failing/TypeSynonyms6.purs | 6 ++++ 6 files changed, 62 insertions(+), 18 deletions(-) create mode 100644 tests/purs/failing/TypeSynonyms6.out create mode 100644 tests/purs/failing/TypeSynonyms6.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index ced6c5a131..5cf511cb8d 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -91,7 +91,7 @@ data SimpleErrorMessage | InvalidDoBind | InvalidDoLet | CycleInDeclaration Ident - | CycleInTypeSynonym (Maybe (ProperName 'TypeName)) + | CycleInTypeSynonym [ProperName 'TypeName] | CycleInTypeClassDeclaration [Qualified (ProperName 'ClassName)] | CycleInKindDeclaration [Qualified (ProperName 'TypeName)] | CycleInModules [ModuleName] @@ -772,13 +772,18 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "There is a cycle in module dependencies in these modules: " , indent $ paras (map (line . markCode . runModuleName) mns) ] - renderSimpleErrorMessage (CycleInTypeSynonym name) = - paras [ line $ case name of - Just pn -> "A cycle appears in the definition of type synonym " <> markCode (runProperName pn) - Nothing -> "A cycle appears in a set of type synonym definitions." - , line "Cycles are disallowed because they can lead to loops in the type checker." + renderSimpleErrorMessage (CycleInTypeSynonym names) = + paras $ cycleError <> + [ line "Cycles are disallowed because they can lead to loops in the type checker." , line "Consider using a 'newtype' instead." ] + where + cycleError = case names of + [] -> pure . line $ "A cycle appears in a set of type synonym definitions." + [pn] -> pure . line $ "A cycle appears in the definition of type synonym " <> markCode (runProperName pn) + _ -> [ line " A cycle appears in a set of type synonym definitions:" + , indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName) names)) <> "}" + ] renderSimpleErrorMessage (CycleInTypeClassDeclaration [name]) = paras [ line $ "A type class '" <> markCode (runProperName (disqualify name)) <> "' may not have itself as a superclass." ] renderSimpleErrorMessage (CycleInTypeClassDeclaration names) = diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 0a1d9c733b..f691d7a1ec 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -12,11 +12,12 @@ module Language.PureScript.Sugar.BindingGroups import Prelude.Compat import Protolude (ordNub) -import Control.Monad ((<=<)) +import Control.Monad ((<=<), guard) import Control.Monad.Error.Class (MonadError(..)) import Data.Graph import Data.List (intersect) +import Data.Foldable (find) import Data.Maybe (isJust, mapMaybe) import qualified Data.List.NonEmpty as NEL import qualified Data.Set as S @@ -94,7 +95,7 @@ createBindingGroups moduleName = mapM f <=< handleDecls | otherwise = [] in (d, (name, vty), self ++ deps) dataVerts = fmap mkVert allDecls - dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup + dataBindingGroupDecls <- parU (stronglyConnCompR dataVerts) toDataBindingGroup let allIdents = fmap valdeclIdent values valueVerts = fmap (\d -> (d, valdeclIdent d, usedIdents moduleName d `intersect` allIdents)) values bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName) @@ -224,21 +225,36 @@ toBindingGroup moduleName (CyclicSCC ds') = do toDataBindingGroup :: MonadError MultipleErrors m - => SCC Declaration + => SCC (Declaration, (ProperName 'TypeName, VertexType), [(ProperName 'TypeName, VertexType)]) -> m Declaration -toDataBindingGroup (AcyclicSCC d) = return d -toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of - Just pn -> throwError . errorMessage' (declSourceSpan d) $ CycleInTypeSynonym (Just pn) - _ -> return d +toDataBindingGroup (AcyclicSCC (d, _, _)) = return d toDataBindingGroup (CyclicSCC ds') - | all (isJust . isTypeSynonym) ds' = throwError . errorMessage' (declSourceSpan (head ds')) $ CycleInTypeSynonym Nothing - | kds@((ss, _):_) <- concatMap kindDecl ds' = throwError . errorMessage' ss . CycleInKindDeclaration $ fmap snd kds - | otherwise = return . DataBindingGroupDeclaration $ NEL.fromList ds' + | kds@((ss, _):_) <- concatMap (kindDecl . getDecl) ds' = throwError . errorMessage' ss . CycleInKindDeclaration $ fmap snd kds + | not (null typeSynonymCycles) = + throwError + . MultipleErrors + . fmap (\syns -> ErrorMessage [positionedError . declSourceSpan . getDecl $ head syns] . CycleInTypeSynonym $ fmap (fst . getName) syns) + $ typeSynonymCycles + | otherwise = return . DataBindingGroupDeclaration . NEL.fromList $ getDecl <$> ds' where kindDecl (KindDeclaration sa _ pn _) = [(fst sa, Qualified Nothing pn)] kindDecl (ExternDataDeclaration sa pn _) = [(fst sa, Qualified Nothing pn)] kindDecl _ = [] + getDecl (decl, _, _) = decl + getName (_, name, _) = name + lookupVert name = find ((==) name . getName) ds' + + onlySynonyms (decl, name, deps) = do + guard . isJust $ isTypeSynonym decl + pure (decl, name, filter (maybe False (isJust . isTypeSynonym . getDecl) . lookupVert) deps) + + isCycle (CyclicSCC c) = Just c + isCycle _ = Nothing + + typeSynonymCycles = + mapMaybe isCycle . stronglyConnCompR . mapMaybe onlySynonyms $ ds' + isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName) isTypeSynonym (TypeSynonymDeclaration _ pn _ _) = Just pn isTypeSynonym _ = Nothing diff --git a/tests/purs/failing/InfiniteKind2.out b/tests/purs/failing/InfiniteKind2.out index 1be74af830..c06581ce76 100644 --- a/tests/purs/failing/InfiniteKind2.out +++ b/tests/purs/failing/InfiniteKind2.out @@ -10,7 +10,7 @@ at tests/purs/failing/InfiniteKind2.purs:5:23 - 5:27 (line 5, column 23 - line 5 while checking that type Tree has kind t0 while inferring the kind of m Tree -in type constructor Tree +in data binding group Tree where t0 is an unknown type diff --git a/tests/purs/failing/TypeSynonyms.out b/tests/purs/failing/TypeSynonyms.out index c135379f7b..6ad26b001e 100644 --- a/tests/purs/failing/TypeSynonyms.out +++ b/tests/purs/failing/TypeSynonyms.out @@ -1,7 +1,10 @@ Error found: at tests/purs/failing/TypeSynonyms.purs:6:1 - 6:19 (line 6, column 1 - line 6, column 19) - A cycle appears in a set of type synonym definitions. + A cycle appears in a set of type synonym definitions: + + {T1, T2} + Cycles are disallowed because they can lead to loops in the type checker. Consider using a 'newtype' instead. diff --git a/tests/purs/failing/TypeSynonyms6.out b/tests/purs/failing/TypeSynonyms6.out new file mode 100644 index 0000000000..84053912ed --- /dev/null +++ b/tests/purs/failing/TypeSynonyms6.out @@ -0,0 +1,14 @@ +Error found: +at tests/purs/failing/TypeSynonyms6.purs:4:1 - 4:11 (line 4, column 1 - line 4, column 11) + + A cycle appears in a set of type synonym definitions: + + {A, B} + + Cycles are disallowed because they can lead to loops in the type checker. + Consider using a 'newtype' instead. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInTypeSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeSynonyms6.purs b/tests/purs/failing/TypeSynonyms6.purs new file mode 100644 index 0000000000..ca2a131ec1 --- /dev/null +++ b/tests/purs/failing/TypeSynonyms6.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith CycleInTypeSynonym +module Main where + +type A = B +type B = { a :: A, b :: Loop } +data Loop = Loop B From ca399538c76ae384e92c1657cd42fae74b191490 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Sun, 27 Sep 2020 11:07:16 +0100 Subject: [PATCH 1240/1580] Allow instances for synonyms (#3539) * Allow instances for synonyms where the argument is fully determined * Fix again after merge * Remove determined-by-fundep requirement for synonym instances * Check instances after replacing type synonyms Co-authored-by: Ryan Hendrickson Co-authored-by: Harry Garrood --- src/Language/PureScript/Errors.hs | 4 ---- src/Language/PureScript/TypeChecker.hs | 16 ++++++------- ...TypeSynonyms6.out => TypeSynonymCycle.out} | 2 +- ...peSynonyms6.purs => TypeSynonymCycle.purs} | 0 tests/purs/failing/TypeSynonyms2.out | 14 ----------- tests/purs/failing/TypeSynonyms2.purs | 12 ---------- tests/purs/failing/TypeSynonyms3.out | 14 ----------- tests/purs/failing/TypeSynonyms3.purs | 12 ---------- tests/purs/failing/TypeSynonyms7.out | 20 ++++++++++++++++ tests/purs/failing/TypeSynonyms7.purs | 9 +++++++ .../TypeSynonymsOverlappingInstance.out | 24 +++++++++++++++++++ .../TypeSynonymsOverlappingInstance.purs | 15 ++++++++++++ tests/purs/passing/TypeSynonymInstance.purs | 16 +++++++++++++ 13 files changed, 92 insertions(+), 66 deletions(-) rename tests/purs/failing/{TypeSynonyms6.out => TypeSynonymCycle.out} (80%) rename tests/purs/failing/{TypeSynonyms6.purs => TypeSynonymCycle.purs} (100%) delete mode 100644 tests/purs/failing/TypeSynonyms2.out delete mode 100644 tests/purs/failing/TypeSynonyms2.purs delete mode 100644 tests/purs/failing/TypeSynonyms3.out delete mode 100644 tests/purs/failing/TypeSynonyms3.purs create mode 100644 tests/purs/failing/TypeSynonyms7.out create mode 100644 tests/purs/failing/TypeSynonyms7.purs create mode 100644 tests/purs/failing/TypeSynonymsOverlappingInstance.out create mode 100644 tests/purs/failing/TypeSynonymsOverlappingInstance.purs create mode 100644 tests/purs/passing/TypeSynonymInstance.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 5cf511cb8d..4e795203f5 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -126,7 +126,6 @@ data SimpleErrorMessage | ExprDoesNotHaveType Expr SourceType | PropertyIsMissing Label | AdditionalProperty Label - | TypeSynonymInstance | OrphanInstance Ident (Qualified (ProperName 'ClassName)) (S.Set ModuleName) [SourceType] | InvalidNewtype (ProperName 'TypeName) | InvalidInstanceHead SourceType @@ -294,7 +293,6 @@ errorCode em = case unwrapErrorMessage em of ExprDoesNotHaveType{} -> "ExprDoesNotHaveType" PropertyIsMissing{} -> "PropertyIsMissing" AdditionalProperty{} -> "AdditionalProperty" - TypeSynonymInstance -> "TypeSynonymInstance" OrphanInstance{} -> "OrphanInstance" InvalidNewtype{} -> "InvalidNewtype" InvalidInstanceHead{} -> "InvalidInstanceHead" @@ -1012,8 +1010,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "Type of expression lacks required label " <> markCode (prettyPrintLabel prop) <> "." renderSimpleErrorMessage (AdditionalProperty prop) = line $ "Type of expression contains additional label " <> markCode (prettyPrintLabel prop) <> "." - renderSimpleErrorMessage TypeSynonymInstance = - line "Type class instances for type synonyms are disallowed." renderSimpleErrorMessage (OrphanInstance nm cnm nonOrphanModules ts) = paras [ line $ "Orphan instance " <> markCode (showIdent nm) <> " found for " , markCodeBox $ indent $ Box.hsep 1 Box.left diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index e366ab0161..25d0a57215 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -226,10 +226,7 @@ checkTypeClassInstance cls i = check where check = \case TypeVar _ _ -> return () TypeLevelString _ _ -> return () - TypeConstructor _ ctor -> do - env <- getEnv - when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance - return () + TypeConstructor _ _ -> return () TypeApp _ t1 t2 -> check t1 >> check t2 KindApp _ t k -> check t >> check k KindedType _ t _ -> check t @@ -408,14 +405,15 @@ typeCheckAll moduleName _ = traverse go Just typeClass -> do checkInstanceArity dictName className typeClass tys (deps', kinds', tys', vars) <- withFreshSubstitution $ checkInstanceDeclaration moduleName (sa, deps, className, tys) - sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys') - let nonOrphanModules = findNonOrphanModules className typeClass tys' - checkOrphanInstance dictName className tys' nonOrphanModules + tys'' <- traverse replaceAllTypeSynonyms tys' + sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys'') + let nonOrphanModules = findNonOrphanModules className typeClass tys'' + checkOrphanInstance dictName className tys'' nonOrphanModules let qualifiedChain = Qualified (Just moduleName) <$> ch - checkOverlappingInstance qualifiedChain dictName className typeClass tys' nonOrphanModules + checkOverlappingInstance qualifiedChain dictName className typeClass tys'' nonOrphanModules _ <- traverseTypeInstanceBody checkInstanceMembers body deps'' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps' - let dict = TypeClassDictionaryInScope qualifiedChain idx qualifiedDictName [] className vars kinds' tys' (Just deps'') + let dict = TypeClassDictionaryInScope qualifiedChain idx qualifiedDictName [] className vars kinds' tys'' (Just deps'') addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict) return d diff --git a/tests/purs/failing/TypeSynonyms6.out b/tests/purs/failing/TypeSynonymCycle.out similarity index 80% rename from tests/purs/failing/TypeSynonyms6.out rename to tests/purs/failing/TypeSynonymCycle.out index 84053912ed..4deaff3f40 100644 --- a/tests/purs/failing/TypeSynonyms6.out +++ b/tests/purs/failing/TypeSynonymCycle.out @@ -1,5 +1,5 @@ Error found: -at tests/purs/failing/TypeSynonyms6.purs:4:1 - 4:11 (line 4, column 1 - line 4, column 11) +at tests/purs/failing/TypeSynonymCycle.purs:4:1 - 4:11 (line 4, column 1 - line 4, column 11) A cycle appears in a set of type synonym definitions: diff --git a/tests/purs/failing/TypeSynonyms6.purs b/tests/purs/failing/TypeSynonymCycle.purs similarity index 100% rename from tests/purs/failing/TypeSynonyms6.purs rename to tests/purs/failing/TypeSynonymCycle.purs diff --git a/tests/purs/failing/TypeSynonyms2.out b/tests/purs/failing/TypeSynonyms2.out deleted file mode 100644 index 9526a9425d..0000000000 --- a/tests/purs/failing/TypeSynonyms2.out +++ /dev/null @@ -1,14 +0,0 @@ -Error found: -in module Main -at tests/purs/failing/TypeSynonyms2.purs:11:1 - 12:12 (line 11, column 1 - line 12, column 12) - - Type class instances for type synonyms are disallowed. - -in type class instance -  - Main.Foo Bar -  - -See https://github.com/purescript/documentation/blob/master/errors/TypeSynonymInstance.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/TypeSynonyms2.purs b/tests/purs/failing/TypeSynonyms2.purs deleted file mode 100644 index e129df2a9a..0000000000 --- a/tests/purs/failing/TypeSynonyms2.purs +++ /dev/null @@ -1,12 +0,0 @@ --- @shouldFailWith TypeSynonymInstance -module Main where - -import Prelude - -class Foo a where - foo :: a -> String - -type Bar = String - -instance fooBar :: Foo Bar where - foo s = s diff --git a/tests/purs/failing/TypeSynonyms3.out b/tests/purs/failing/TypeSynonyms3.out deleted file mode 100644 index 32851ec208..0000000000 --- a/tests/purs/failing/TypeSynonyms3.out +++ /dev/null @@ -1,14 +0,0 @@ -Error found: -in module Main -at tests/purs/failing/TypeSynonyms3.purs:11:1 - 12:12 (line 11, column 1 - line 12, column 12) - - Type class instances for type synonyms are disallowed. - -in type class instance -  - Main.Foo Bar -  - -See https://github.com/purescript/documentation/blob/master/errors/TypeSynonymInstance.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/TypeSynonyms3.purs b/tests/purs/failing/TypeSynonyms3.purs deleted file mode 100644 index e129df2a9a..0000000000 --- a/tests/purs/failing/TypeSynonyms3.purs +++ /dev/null @@ -1,12 +0,0 @@ --- @shouldFailWith TypeSynonymInstance -module Main where - -import Prelude - -class Foo a where - foo :: a -> String - -type Bar = String - -instance fooBar :: Foo Bar where - foo s = s diff --git a/tests/purs/failing/TypeSynonyms7.out b/tests/purs/failing/TypeSynonyms7.out new file mode 100644 index 0000000000..f944d13844 --- /dev/null +++ b/tests/purs/failing/TypeSynonyms7.out @@ -0,0 +1,20 @@ +Error found: +in module Main +at tests/purs/failing/TypeSynonyms7.purs:8:1 - 9:14 (line 8, column 1 - line 9, column 14) + + Type class instance head is invalid due to use of type +   +  ( x :: Int +  | r  +  )  +   + All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form, unless the type is fully determined by other type class arguments via functional dependencies. + +in type class instance +  + Data.Show.Show (X r) +  + +See https://github.com/purescript/documentation/blob/master/errors/InvalidInstanceHead.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeSynonyms7.purs b/tests/purs/failing/TypeSynonyms7.purs new file mode 100644 index 0000000000..11855aef3b --- /dev/null +++ b/tests/purs/failing/TypeSynonyms7.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith InvalidInstanceHead +module Main where + +import Prelude + +type X r = {x :: Int | r} + +instance showX :: Show (X r) where + show _ = "" diff --git a/tests/purs/failing/TypeSynonymsOverlappingInstance.out b/tests/purs/failing/TypeSynonymsOverlappingInstance.out new file mode 100644 index 0000000000..edea0baaf3 --- /dev/null +++ b/tests/purs/failing/TypeSynonymsOverlappingInstance.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/TypeSynonymsOverlappingInstance.purs:14:1 - 15:16 (line 14, column 1 - line 15, column 16) + + Overlapping type class instances found for +   +  Main.Convert String +  String +   + The following instances were found: + + Main.convertSB + Main.convertSS + + +in type class instance +  + Main.Convert String + String +  + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingInstances.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeSynonymsOverlappingInstance.purs b/tests/purs/failing/TypeSynonymsOverlappingInstance.purs new file mode 100644 index 0000000000..9a31b7324f --- /dev/null +++ b/tests/purs/failing/TypeSynonymsOverlappingInstance.purs @@ -0,0 +1,15 @@ +-- @shouldFailWith OverlappingInstances +module Main where + +import Prelude + +class Convert a b | a -> b where + convert :: a -> b + +type Bar = String + +instance convertSB :: Convert String Bar where + convert s = s + +instance convertSS :: Convert String String where + convert s = s diff --git a/tests/purs/passing/TypeSynonymInstance.purs b/tests/purs/passing/TypeSynonymInstance.purs new file mode 100644 index 0000000000..9bfb9b292b --- /dev/null +++ b/tests/purs/passing/TypeSynonymInstance.purs @@ -0,0 +1,16 @@ +module Main where + +import Prelude + +import Effect.Console (log) + +class Convert a b | a -> b where + convert :: a -> b + +type Words = String + +instance convertSB :: Convert Int Words where + convert 0 = "Nope" + convert _ = "Done" + +main = log $ convert 1 From 868eba2be75fb21fc958ed48ace2b6c0897e6640 Mon Sep 17 00:00:00 2001 From: Cyril Date: Sat, 10 Oct 2020 15:24:17 +0200 Subject: [PATCH 1241/1580] Require newtype constructors to be imported for coercing them (#3937) * Require newtype constructors to be imported for coercing them * Document why we track coerced newtype ctors imports and lint them after typechecking --- .../src/Language/PureScript/Environment.hs | 15 ----- src/Language/PureScript/Docs/Convert.hs | 2 +- src/Language/PureScript/Interactive/Types.hs | 7 ++- src/Language/PureScript/Make.hs | 19 ++++-- src/Language/PureScript/Sugar.hs | 22 ++++--- src/Language/PureScript/Sugar/Names.hs | 42 +++++--------- src/Language/PureScript/TypeChecker.hs | 18 +++++- .../PureScript/TypeChecker/Entailment.hs | 58 +++++++++++++++---- src/Language/PureScript/TypeChecker/Monad.hs | 8 ++- .../failing/CoercibleRepresentational6.out | 22 +++++++ .../failing/CoercibleRepresentational6.purs | 8 +++ .../failing/CoercibleRepresentational6/N.purs | 3 + .../failing/CoercibleRepresentational7.out | 22 +++++++ .../failing/CoercibleRepresentational7.purs | 8 +++ .../failing/CoercibleRepresentational7/N.purs | 3 + tests/purs/warning/CoercibleUnusedImport.out | 0 tests/purs/warning/CoercibleUnusedImport.purs | 8 +++ .../warning/CoercibleUnusedImport/N1.purs | 3 + .../warning/CoercibleUnusedImport/N2.purs | 5 ++ ...ercibleUnusedNewtypeCtorExplicitImport.out | 0 ...rcibleUnusedNewtypeCtorExplicitImport.purs | 7 +++ .../N.purs | 3 + ...ercibleUnusedNewtypeCtorImplicitImport.out | 0 ...rcibleUnusedNewtypeCtorImplicitImport.purs | 7 +++ .../N.purs | 3 + 25 files changed, 221 insertions(+), 72 deletions(-) create mode 100644 tests/purs/failing/CoercibleRepresentational6.out create mode 100644 tests/purs/failing/CoercibleRepresentational6.purs create mode 100644 tests/purs/failing/CoercibleRepresentational6/N.purs create mode 100644 tests/purs/failing/CoercibleRepresentational7.out create mode 100644 tests/purs/failing/CoercibleRepresentational7.purs create mode 100644 tests/purs/failing/CoercibleRepresentational7/N.purs create mode 100644 tests/purs/warning/CoercibleUnusedImport.out create mode 100644 tests/purs/warning/CoercibleUnusedImport.purs create mode 100644 tests/purs/warning/CoercibleUnusedImport/N1.purs create mode 100644 tests/purs/warning/CoercibleUnusedImport/N2.purs create mode 100644 tests/purs/warning/CoercibleUnusedNewtypeCtorExplicitImport.out create mode 100644 tests/purs/warning/CoercibleUnusedNewtypeCtorExplicitImport.purs create mode 100644 tests/purs/warning/CoercibleUnusedNewtypeCtorExplicitImport/N.purs create mode 100644 tests/purs/warning/CoercibleUnusedNewtypeCtorImplicitImport.out create mode 100644 tests/purs/warning/CoercibleUnusedNewtypeCtorImplicitImport.purs create mode 100644 tests/purs/warning/CoercibleUnusedNewtypeCtorImplicitImport/N.purs diff --git a/lib/purescript-ast/src/Language/PureScript/Environment.hs b/lib/purescript-ast/src/Language/PureScript/Environment.hs index 229cebb4b5..3a80d88524 100644 --- a/lib/purescript-ast/src/Language/PureScript/Environment.hs +++ b/lib/purescript-ast/src/Language/PureScript/Environment.hs @@ -590,21 +590,6 @@ primTypeErrorClasses = [("message", Just kindDoc)] [] [] [] True) ] --- | Looks up a given name and, if it names a newtype, returns the names of the --- type's parameters, the type the newtype wraps and the names of the type's --- fields. -lookupNewtypeConstructor :: Environment -> Qualified (ProperName 'TypeName) -> Maybe ([Text], SourceType, [Ident]) -lookupNewtypeConstructor env ty@(Qualified mn _) = - M.lookup ty (types env) >>= \case - (_, DataType tvs [(ctor, [wrappedTy])]) -> - M.lookup (Qualified mn ctor) (dataConstructors env) >>= \case - (Newtype, _, _, ids) -> - pure (map (\(name, _, _) -> name) tvs, wrappedTy, ids) - _ -> - Nothing - _ -> - Nothing - -- | Finds information about data constructors from the current environment. lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) lookupConstructor env ctor = diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 3b2d3fdbbb..47cd461fe4 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -100,7 +100,7 @@ partiallyDesugar externs env = evalSupplyT 0 . desugar' >=> map P.desugarLetPatternModule >>> traverse P.desugarCasesModule >=> traverse P.desugarTypeDeclarationsModule - >=> fmap fst . runWriterT . P.desugarImports env + >=> fmap fst . runWriterT . flip evalStateT (env, mempty) . P.desugarImports >=> P.rebracketFiltered isInstanceDecl externs isInstanceDecl (P.TypeInstanceDeclaration {}) = True diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index 1b0c621c78..b052be8f20 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -37,6 +37,7 @@ import Data.List (foldl') import Language.PureScript.Sugar.Names.Env (nullImports, primExports) import Control.Monad (foldM) import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.State (execStateT) import Control.Monad.Writer.Strict (runWriterT) @@ -121,14 +122,14 @@ updateImportExports :: PSCiState -> PSCiState updateImportExports st@(PSCiState modules lets externs iprint _ _) = case createEnv (map snd externs) >>= flip desugarModule [temporaryModule] of Left _ -> st -- TODO: can this fail and what should we do? - Right (env, _) -> + Right env -> case M.lookup temporaryName env of Just (_, is, es) -> PSCiState modules lets externs iprint is es _ -> st -- impossible where - desugarModule :: P.Env -> [P.Module] -> Either P.MultipleErrors (P.Env, [P.Module]) - desugarModule e = runExceptT =<< fmap fst . runWriterT . P.desugarImportsWithEnv e + desugarModule :: P.Env -> [P.Module] -> Either P.MultipleErrors P.Env + desugarModule e = runExceptT =<< fmap (fst . fst) . runWriterT . flip execStateT (e, mempty) . P.desugarImports createEnv :: [P.ExternsFile] -> Either P.MultipleErrors P.Env createEnv = runExceptT =<< fmap fst . runWriterT . foldM P.externsEnv P.primEnv diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 00fefadf6b..9977dfaefc 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -16,10 +16,11 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class import Control.Monad.Supply import Control.Monad.Trans.Control (MonadBaseControl(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Trans.State (runStateT) +import Control.Monad.Writer.Class (MonadWriter(..), censor) import Control.Monad.Writer.Strict (runWriterT) import Data.Function (on) -import Data.Foldable (for_) +import Data.Foldable (fold, for_) import Data.List (foldl', sortBy) import qualified Data.List.NonEmpty as NEL import Data.Maybe (fromMaybe) @@ -75,9 +76,19 @@ rebuildModule' MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) = do let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs withPrim = importPrim m lint withPrim + ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do - desugar exEnv externs [withPrim] >>= \case - [desugared] -> runCheck' (emptyCheckState env) $ typeCheckModule desugared + runStateT (desugar externs [withPrim]) (exEnv, mempty) >>= \case + ([desugared], (exEnv', usedImportsByModuleName)) -> do + (checked, CheckState{..}) <- runStateT (typeCheckModule desugared) $ emptyCheckState env + let usedImports = fold $ M.lookup moduleName usedImportsByModuleName + usedImports' = foldl' (flip $ \(fromModuleName, newtypeCtorName) -> + M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName) usedImports checkCoercedNewtypeCtorsImports + -- Imports cannot be linted before type checking because we need to + -- known which newtype constructors are used to solve Coercible + -- constraints in order to not report them as unused. + censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports' + return (checked, checkEnv) _ -> internalError "desugar did not return a singleton" -- desugar case declarations *after* type- and exhaustiveness checking diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index da0d10bc1a..bbf802247e 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -5,16 +5,20 @@ module Language.PureScript.Sugar (desugar, module S) where import Control.Category ((>>>)) import Control.Monad -import Control.Monad.Error.Class (MonadError()) -import Control.Monad.Supply.Class -import Control.Monad.Writer.Class (MonadWriter()) +import Control.Monad.Error.Class (MonadError) +import Control.Monad.Supply.Class (MonadSupply) +import Control.Monad.State.Class (MonadState) +import Control.Monad.Writer.Class (MonadWriter) import Data.List (map) import Data.Traversable (traverse) +import Data.Map (Map) import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Externs +import Language.PureScript.Linter.Imports +import Language.PureScript.Names import Language.PureScript.Sugar.BindingGroups as S import Language.PureScript.Sugar.CaseDeclarations as S import Language.PureScript.Sugar.DoNotation as S @@ -53,12 +57,14 @@ import Language.PureScript.Sugar.TypeDeclarations as S -- * Group mutually recursive value and data declarations into binding groups. -- desugar - :: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => Env - -> [ExternsFile] + :: MonadSupply m + => MonadError MultipleErrors m + => MonadWriter MultipleErrors m + => MonadState (Env, Map ModuleName UsedImports) m + => [ExternsFile] -> [Module] -> m [Module] -desugar env externs = +desugar externs = map desugarSignedLiterals >>> traverse desugarObjectConstructors >=> traverse desugarDoModule @@ -66,7 +72,7 @@ desugar env externs = >=> map desugarLetPatternModule >>> traverse desugarCasesModule >=> traverse desugarTypeDeclarationsModule - >=> desugarImports env + >=> desugarImports >=> rebracket externs >=> traverse checkFixityExports >=> traverse (deriveInstances externs) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index ae1c2de5e7..84a49d27df 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -1,6 +1,5 @@ module Language.PureScript.Sugar.Names ( desugarImports - , desugarImportsWithEnv , Env , externsEnv , primEnv @@ -13,7 +12,7 @@ module Language.PureScript.Sugar.Names import Prelude.Compat import Protolude (ordNub, sortBy, on) -import Control.Arrow (first) +import Control.Arrow (first, second) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Lazy @@ -41,39 +40,30 @@ import Language.PureScript.Types -- desugarImports :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => Env - -> [Module] + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState (Env, M.Map ModuleName UsedImports) m) + => [Module] -> m [Module] -desugarImports env modules = - fmap snd (desugarImportsWithEnv env modules) - -desugarImportsWithEnv - :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => Env - -> [Module] - -> m (Env, [Module]) -desugarImportsWithEnv e modules = do - (modules', env') <- first reverse <$> foldM updateEnv ([], e) modules - (env',) <$> traverse (renameInModule' env') modules' +desugarImports modules = do + modules' <- reverse <$> foldM updateEnv [] modules + traverse renameInModule' modules' where - updateEnv :: ([Module], Env) -> Module -> m ([Module], Env) - updateEnv (ms, env) m@(Module ss _ mn _ refs) = do + updateEnv :: [Module] -> Module -> m [Module] + updateEnv ms m@(Module ss _ mn _ refs) = do members <- findExportable m - let env' = M.insert mn (ss, nullImports, members) env + env' <- gets $ M.insert mn (ss, nullImports, members) . fst (m', imps) <- resolveImports env' m exps <- maybe (return members) (resolveExports env' ss mn imps members) refs - return (m' : ms, M.insert mn (ss, imps, exps) env) + modify . first $ M.insert mn (ss, imps, exps) + return $ m' : ms - renameInModule' :: Env -> Module -> m Module - renameInModule' env m@(Module _ _ mn _ _) = + renameInModule' :: Module -> m Module + renameInModule' m@(Module _ _ mn _ _) = warnAndRethrow (addHint (ErrorInModule mn)) $ do + env <- gets fst let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env (m', used) <- flip runStateT M.empty $ renameInModule imps m - let m'' = elaborateExports exps m' - lintImports m'' env used - return m'' + modify . second $ M.alter (Just . maybe used (M.unionWith (<>) used)) mn + return $ elaborateExports exps m' -- | Create an environment from a collection of externs files externsEnv diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 25d0a57215..17b2af7425 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -21,6 +21,7 @@ import Control.Monad.Writer.Class (MonadWriter(..), censor) import Data.Foldable (for_, traverse_, toList) import Data.List (nub, nubBy, (\\), sort, group, intersect) import Data.Maybe +import Data.Either (partitionEithers) import Data.Text (Text) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M @@ -596,8 +597,9 @@ typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated before typeCheckModule" typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do - modify (\s -> s { checkCurrentModule = Just mn }) - decls' <- typeCheckAll mn exps decls + let (decls', imports) = partitionEithers $ fromImportDecl <$> decls + modify (\s -> s { checkCurrentModule = Just mn, checkCurrentModuleImports = imports }) + decls'' <- typeCheckAll mn exps decls' checkSuperClassesAreExported <- getSuperClassExportCheck for_ exps $ \e -> do checkTypesAreExported e @@ -605,8 +607,18 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = checkClassesAreExported e checkSuperClassesAreExported e checkDataConstructorsAreExported e - return $ Module ss coms mn decls' (Just exps) + return $ Module ss coms mn (map toImportDecl imports ++ decls'') (Just exps) where + + fromImportDecl :: Declaration -> Either Declaration (SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName) + fromImportDecl (ImportDeclaration sa moduleName importDeclarationType asModuleName) = + Right (sa, moduleName, importDeclarationType, asModuleName) + fromImportDecl decl = Left decl + + toImportDecl :: (SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName) -> Declaration + toImportDecl (sa, moduleName, importDeclarationType, asModuleName) = + ImportDeclaration sa moduleName importDeclarationType asModuleName + qualify' :: a -> Qualified a qualify' = Qualified (Just mn) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 6def75750d..feb85c42ca 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -25,8 +25,8 @@ import Control.Monad.Writer import Data.Foldable (for_, fold, foldl', toList) import Data.Function (on) import Data.Functor (($>)) -import Data.List (minimumBy, groupBy, nubBy, sortBy, zipWith4) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.List (find, groupBy, minimumBy, nubBy, sortBy, zipWith4) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S import Data.Traversable (for) @@ -472,15 +472,19 @@ entails SolverOptions{..} constraint context hints = Phantom -> pure [] fmap concat $ sequence $ zipWith4 f roles kinds axs bxs - | (TypeConstructor _ tyName, _, xs) <- unapplyTypes a - , Just (tvs, wrappedTy, _) <- lookupNewtypeConstructor env tyName = do - -- If the first argument is a newtype applied to some other types - -- (e.g. @newtype T a = T a@ in @Coercible (T X) b@), look up the - -- type of its wrapped field and yield a new wanted constraint in - -- terms of that type with the type arguments substituted in (e.g. - -- @Coercible (T[X/a]) b = Coercible X b@ in the example). - let wrappedTySub = replaceAllTypeVars (zip tvs xs) wrappedTy - pure $ Just [srcCoercibleConstraint kindType wrappedTySub b] + | (TypeConstructor _ newtypeName, _, xs) <- unapplyTypes a = do + (currentModuleName, currentModuleImports) <- gets $ checkCurrentModule &&& checkCurrentModuleImports + case lookupNewtypeConstructor env currentModuleName currentModuleImports newtypeName of + Just (fromModuleName, newtypeCtorName, tvs, wrappedTy, _) -> do + for_ fromModuleName $ flip insertCoercedNewtypeCtorImport newtypeCtorName + -- If the first argument is a newtype applied to some other types + -- (e.g. @newtype T a = T a@ in @Coercible (T X) b@), look up the + -- type of its wrapped field and yield a new wanted constraint in + -- terms of that type with the type arguments substituted in (e.g. + -- @Coercible (T[X/a]) b = Coercible X b@ in the example). + let wrappedTySub = replaceAllTypeVars (zip tvs xs) wrappedTy + pure $ Just [srcCoercibleConstraint kindType wrappedTySub b] + _ -> pure Nothing | otherwise = -- In all other cases we can't solve the constraint. pure Nothing @@ -488,6 +492,38 @@ entails SolverOptions{..} constraint context hints = srcCoercibleConstraint :: SourceType -> SourceType -> SourceType -> SourceConstraint srcCoercibleConstraint k a b = srcConstraint C.Coercible [k] [a, b] Nothing + -- | Looks up a given name and, if it names a newtype, returns the names of the + -- type's parameters, the type the newtype wraps and the names of the type's + -- fields. + lookupNewtypeConstructor + :: Environment + -> Maybe ModuleName + -> [(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName)] + -> Qualified (ProperName 'TypeName) + -> Maybe (Maybe ModuleName, Qualified (ProperName 'ConstructorName), [Text], SourceType, [Ident]) + lookupNewtypeConstructor env currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName) = do + let fromModule = find isNewtypeCtorInScope currentModuleImports + fromModuleName = (\(_, n, _, _) -> n) <$> fromModule + asModuleName = (\(_, _, _, n) -> n) =<< fromModule + guard $ newtypeModuleName == currentModuleName || isJust fromModule + (_, DataType tvs [(ctorName, [wrappedTy])]) <- M.lookup qualifiedNewtypeName (types env) + (Newtype, _, _, ids) <- M.lookup (Qualified newtypeModuleName ctorName) (dataConstructors env) + pure (fromModuleName, Qualified asModuleName ctorName, map (\(name, _, _) -> name) tvs, wrappedTy, ids) + where + isNewtypeCtorInScope (_, fromModuleName, importDeclType, _) = + newtypeModuleName == Just fromModuleName && case importDeclType of + Implicit -> True + Explicit refs -> any isNewtypeCtorRef refs + Hiding refs -> not $ any isNewtypeCtorRef refs + isNewtypeCtorRef = \case + TypeRef _ importedTyName Nothing -> importedTyName == newtypeName + TypeRef _ importedTyName (Just [_]) -> importedTyName == newtypeName + _ -> False + + insertCoercedNewtypeCtorImport :: MonadState CheckState m => ModuleName -> Qualified (ProperName 'ConstructorName) -> m () + insertCoercedNewtypeCtorImport fromModuleName newtypeCtor = modify $ \s -> + s { checkCoercedNewtypeCtorsImports = S.insert (fromModuleName, newtypeCtor) $ checkCoercedNewtypeCtorsImports s } + solveIsSymbol :: [SourceType] -> Maybe [TypeClassDict] solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope [] 0 (IsSymbolInstance sym) [] C.IsSymbol [] [] [TypeLevelString ann sym] Nothing] solveIsSymbol _ = Nothing diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 37411fb5a8..4bb926deba 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -16,6 +16,7 @@ import Control.Monad.Writer.Class (MonadWriter(..), censor) import Data.List (intercalate) import Data.Maybe import qualified Data.Map as M +import qualified Data.Set as S import Data.Text (Text, isPrefixOf, unpack) import qualified Data.List.NonEmpty as NEL @@ -68,6 +69,8 @@ data CheckState = CheckState -- ^ The next skolem scope constant , checkCurrentModule :: Maybe ModuleName -- ^ The current module + , checkCurrentModuleImports :: [(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName)] + -- ^ The current module imports , checkSubstitution :: Substitution -- ^ The current substitution , checkHints :: [ErrorMessageHint] @@ -75,11 +78,14 @@ data CheckState = CheckState -- This goes into state, rather than using 'rethrow', -- since this way, we can provide good error messages -- during instance resolution. + , checkCoercedNewtypeCtorsImports :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName)) + -- ^ Newtype constructors imports required to solve Coercible constraints. + -- We have to keep track of them so that we don't emit unused import warnings. } -- | Create an empty @CheckState@ emptyCheckState :: Environment -> CheckState -emptyCheckState env = CheckState env 0 0 0 Nothing emptySubstitution [] +emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty -- | Unification variables type Unknown = Int diff --git a/tests/purs/failing/CoercibleRepresentational6.out b/tests/purs/failing/CoercibleRepresentational6.out new file mode 100644 index 0000000000..7b66cdb47d --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational6.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleRepresentational6.purs:8:10 - 8:16 (line 8, column 10 - line 8, column 16) + + No type class instance was found for +   +  Prim.Coerce.Coercible (N a0) +  a0  +   + +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b + is at least as general as type N a0 -> a0 +while checking that expression coerce + has type N a0 -> a0 +in value declaration unwrap + +where a0 is a rigid type variable + bound at (line 8, column 10 - line 8, column 16) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleRepresentational6.purs b/tests/purs/failing/CoercibleRepresentational6.purs new file mode 100644 index 0000000000..ab0f36919e --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational6.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) +import N (N(..)) + +unwrap :: forall a. N a -> a +unwrap = coerce diff --git a/tests/purs/failing/CoercibleRepresentational6/N.purs b/tests/purs/failing/CoercibleRepresentational6/N.purs new file mode 100644 index 0000000000..6ef0e199d4 --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational6/N.purs @@ -0,0 +1,3 @@ +module N (N) where + +newtype N a = N a diff --git a/tests/purs/failing/CoercibleRepresentational7.out b/tests/purs/failing/CoercibleRepresentational7.out new file mode 100644 index 0000000000..d7adcf1742 --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational7.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleRepresentational7.purs:8:10 - 8:16 (line 8, column 10 - line 8, column 16) + + No type class instance was found for +   +  Prim.Coerce.Coercible (N a0) +  a0  +   + +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b + is at least as general as type N a0 -> a0 +while checking that expression coerce + has type N a0 -> a0 +in value declaration unwrap + +where a0 is a rigid type variable + bound at (line 8, column 10 - line 8, column 16) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleRepresentational7.purs b/tests/purs/failing/CoercibleRepresentational7.purs new file mode 100644 index 0000000000..ad21472176 --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational7.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) +import N (N) + +unwrap :: forall a. N a -> a +unwrap = coerce diff --git a/tests/purs/failing/CoercibleRepresentational7/N.purs b/tests/purs/failing/CoercibleRepresentational7/N.purs new file mode 100644 index 0000000000..fe6de00d5d --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational7/N.purs @@ -0,0 +1,3 @@ +module N (N(..)) where + +newtype N a = N a diff --git a/tests/purs/warning/CoercibleUnusedImport.out b/tests/purs/warning/CoercibleUnusedImport.out new file mode 100644 index 0000000000..e69de29bb2 diff --git a/tests/purs/warning/CoercibleUnusedImport.purs b/tests/purs/warning/CoercibleUnusedImport.purs new file mode 100644 index 0000000000..b9f5538899 --- /dev/null +++ b/tests/purs/warning/CoercibleUnusedImport.purs @@ -0,0 +1,8 @@ +module Main where + +import N1 +import N2 (N2(..)) +import Safe.Coerce (coerce) + +unwrap :: forall a. N2 a -> a +unwrap = coerce diff --git a/tests/purs/warning/CoercibleUnusedImport/N1.purs b/tests/purs/warning/CoercibleUnusedImport/N1.purs new file mode 100644 index 0000000000..dd69fed69e --- /dev/null +++ b/tests/purs/warning/CoercibleUnusedImport/N1.purs @@ -0,0 +1,3 @@ +module N1 where + +newtype N1 a = N1 a diff --git a/tests/purs/warning/CoercibleUnusedImport/N2.purs b/tests/purs/warning/CoercibleUnusedImport/N2.purs new file mode 100644 index 0000000000..eb1255ff46 --- /dev/null +++ b/tests/purs/warning/CoercibleUnusedImport/N2.purs @@ -0,0 +1,5 @@ +module N2 where + +import N1 + +newtype N2 a = N2 (N1 a) diff --git a/tests/purs/warning/CoercibleUnusedNewtypeCtorExplicitImport.out b/tests/purs/warning/CoercibleUnusedNewtypeCtorExplicitImport.out new file mode 100644 index 0000000000..e69de29bb2 diff --git a/tests/purs/warning/CoercibleUnusedNewtypeCtorExplicitImport.purs b/tests/purs/warning/CoercibleUnusedNewtypeCtorExplicitImport.purs new file mode 100644 index 0000000000..ff04785899 --- /dev/null +++ b/tests/purs/warning/CoercibleUnusedNewtypeCtorExplicitImport.purs @@ -0,0 +1,7 @@ +module Main where + +import N (N(N)) +import Safe.Coerce (coerce) + +unwrap :: forall a. N a -> a +unwrap = coerce diff --git a/tests/purs/warning/CoercibleUnusedNewtypeCtorExplicitImport/N.purs b/tests/purs/warning/CoercibleUnusedNewtypeCtorExplicitImport/N.purs new file mode 100644 index 0000000000..20ce211901 --- /dev/null +++ b/tests/purs/warning/CoercibleUnusedNewtypeCtorExplicitImport/N.purs @@ -0,0 +1,3 @@ +module N where + +newtype N a = N a diff --git a/tests/purs/warning/CoercibleUnusedNewtypeCtorImplicitImport.out b/tests/purs/warning/CoercibleUnusedNewtypeCtorImplicitImport.out new file mode 100644 index 0000000000..e69de29bb2 diff --git a/tests/purs/warning/CoercibleUnusedNewtypeCtorImplicitImport.purs b/tests/purs/warning/CoercibleUnusedNewtypeCtorImplicitImport.purs new file mode 100644 index 0000000000..a20c70387d --- /dev/null +++ b/tests/purs/warning/CoercibleUnusedNewtypeCtorImplicitImport.purs @@ -0,0 +1,7 @@ +module Main where + +import N (N(..)) +import Safe.Coerce (coerce) + +unwrap :: forall a. N a -> a +unwrap = coerce diff --git a/tests/purs/warning/CoercibleUnusedNewtypeCtorImplicitImport/N.purs b/tests/purs/warning/CoercibleUnusedNewtypeCtorImplicitImport/N.purs new file mode 100644 index 0000000000..20ce211901 --- /dev/null +++ b/tests/purs/warning/CoercibleUnusedNewtypeCtorImplicitImport/N.purs @@ -0,0 +1,3 @@ +module N where + +newtype N a = N a From 949954126f2a9826d044c88a277ecdc145f773cb Mon Sep 17 00:00:00 2001 From: Cyril Date: Sun, 11 Oct 2020 18:04:03 +0200 Subject: [PATCH 1242/1580] Turn `Coercible` into a symmetric relation (#3930) --- src/Language/PureScript/Docs/Prim.hs | 15 +++++++++----- .../PureScript/TypeChecker/Entailment.hs | 20 +++++++++++-------- tests/purs/passing/Coercible.purs | 7 +++++++ 3 files changed, 29 insertions(+), 13 deletions(-) diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index c0a20267cb..4f9f42cc9a 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -380,12 +380,17 @@ coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines , "This class does not have regular instances; instead they are created" , "on-the-fly during type-checking according to a set of rules." , "" - , "First, as a trivial base-case, reflexivity - any type has the same" - , "representation as itself:" + , "First, Coercible obeys reflexivity - any type has the same representation" + , "as itself:" , "" , " instance coercibleReflexive :: Coercible a a" , "" - , "Second, for every type constructor there is an instance that allows one" + , "Second, Coercible obeys symmetry - if a type `a` can be coerced to some" + , "other type `b`, then `b` can also be coerced back to `a`:" + , "" + , " instance coercibleSymmetric :: Coercible a b => Coercible b a" + , "" + , "Third, for every type constructor there is an instance that allows one" , "to coerce under the type constructor (`data` or `newtype`). For example," , "given a definition:" , "" @@ -401,7 +406,7 @@ coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines , "such as `b` is thus typically referred to as a \"phantom\" type), `b` and `b'`" , "can differ arbitrarily." , "" - , "Third, for every `newtype NT = MkNT T`, there is a pair of instances which" + , "Fourth, for every `newtype NT = MkNT T`, there is a pair of instances which" , "permit coercion in and out of the `newtype`:" , "" , " instance coercibleNewtypeLeft :: Coercible a T => Coercible a NT" @@ -410,7 +415,7 @@ coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines , "To prevent breaking abstractions, these instances are only usable if the" , "constructor `MkNT` is exported." , "" - , "Fourth, every pair of unsaturated type constructors can be coerced if" + , "Fifth, every pair of unsaturated type constructors can be coerced if" , "there is an instance for the fully saturated types. For example," , "given the definitions:" , "" diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index feb85c42ca..cc25ac8473 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -171,7 +171,7 @@ entails SolverOptions{..} constraint context hints = where forClassNameM :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> m [TypeClassDict] forClassNameM env ctx cn@C.Coercible kinds args = - solveCoercible env kinds args >>= + solveCoercible env ctx kinds args >>= pure . fromMaybe (forClassName env ctx cn kinds args) forClassNameM env ctx cn kinds args = pure $ forClassName env ctx cn kinds args @@ -390,16 +390,18 @@ entails SolverOptions{..} constraint context hints = subclassDictionaryValue dict className index = App (Accessor (mkString (superclassName className index)) dict) valUndefined - solveCoercible :: Environment -> [SourceType] -> [SourceType] -> m (Maybe [TypeClassDict]) - solveCoercible env kinds [a, b] = runMaybeT $ do + solveCoercible :: Environment -> InstanceContext -> [SourceType] -> [SourceType] -> m (Maybe [TypeClassDict]) + solveCoercible env ctx kinds [a, b] = runMaybeT $ do let kindOf = lift . (sequence . (id &&& elaborateKind)) <=< replaceAllTypeSynonyms (a', kind) <- kindOf a (b', kind') <- kindOf b lift $ unifyKinds kind kind' - -- Solving terminates when the two arguments are the same. Since we - -- currently don't support higher-rank arguments in instance heads, term - -- equality is a sufficient notion of "the same". - if a' == b' + -- Solving terminates when the two arguments are the same or if a + -- dictionary for a symmetric constraint is already in scope. + -- Since we currently don't support higher-rank arguments in instance + -- heads, term equality is a sufficient notion of "the same". + let coercibleDictsInScope = findDicts ctx C.Coercible Nothing + if a' == b' || any (isSymmetricCoercibleDictInScope a' b') coercibleDictsInScope then pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] Nothing] else do -- When solving must reduce and recurse, it doesn't matter whether we @@ -408,7 +410,9 @@ entails SolverOptions{..} constraint context hints = -- just try the first argument first and the second argument second. ws <- (MaybeT $ coercibleWanteds env a' b') <|> (MaybeT $ coercibleWanteds env b' a') pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] (Just ws)] - solveCoercible _ _ _ = pure Nothing + solveCoercible _ _ _ _ = pure Nothing + + isSymmetricCoercibleDictInScope a b TypeClassDictionaryInScope{..} = tcdInstanceTypes == [b, a] -- | Take two types, @a@ and @b@ representing a desired constraint -- @Coercible a b@ and reduce them to a set of simpler wanted constraints diff --git a/tests/purs/passing/Coercible.purs b/tests/purs/passing/Coercible.purs index 3425121dfc..2fd53b90ff 100644 --- a/tests/purs/passing/Coercible.purs +++ b/tests/purs/passing/Coercible.purs @@ -4,6 +4,13 @@ import Coercible.Lib import Effect.Console (log) import Safe.Coerce (coerce) +import Prim.Coerce (class Coercible) + +refl :: forall a. a -> a +refl = coerce + +symm :: forall a b. Coercible a b => b -> a +symm = coerce type SynString = String From 4d6680e6faf853e9d21b1e29acc13a44d9a2cd61 Mon Sep 17 00:00:00 2001 From: Cyril Date: Sun, 11 Oct 2020 18:05:18 +0200 Subject: [PATCH 1243/1580] Warn against exported types with hidden constructors but `Generic` or `Newtype` instances (#3907) * Warn against exported types with hidden constructors but `Generic` or `Newtype` instances * Factor `Data.Newtype` and `Data.Generic.Rep` names in constants modules --- .../PureScript/Constants/Data/Generic/Rep.hs | 40 ++++++ .../PureScript/Constants/Data/Newtype.hs | 7 ++ src/Language/PureScript/Errors.hs | 6 + .../PureScript/Sugar/TypeClasses/Deriving.hs | 117 ++++++------------ src/Language/PureScript/TypeChecker.hs | 24 +++- .../warning/HiddenConstructorsGeneric.out | 11 ++ .../warning/HiddenConstructorsGeneric.purs | 8 ++ .../warning/HiddenConstructorsNewtype.out | 11 ++ .../warning/HiddenConstructorsNewtype.purs | 8 ++ 9 files changed, 150 insertions(+), 82 deletions(-) create mode 100644 src/Language/PureScript/Constants/Data/Generic/Rep.hs create mode 100644 src/Language/PureScript/Constants/Data/Newtype.hs create mode 100644 tests/purs/warning/HiddenConstructorsGeneric.out create mode 100644 tests/purs/warning/HiddenConstructorsGeneric.purs create mode 100644 tests/purs/warning/HiddenConstructorsNewtype.out create mode 100644 tests/purs/warning/HiddenConstructorsNewtype.purs diff --git a/src/Language/PureScript/Constants/Data/Generic/Rep.hs b/src/Language/PureScript/Constants/Data/Generic/Rep.hs new file mode 100644 index 0000000000..c4327903fb --- /dev/null +++ b/src/Language/PureScript/Constants/Data/Generic/Rep.hs @@ -0,0 +1,40 @@ +module Language.PureScript.Constants.Data.Generic.Rep where + +import Prelude.Compat +import Language.PureScript.Names + +pattern DataGenericRep :: ModuleName +pattern DataGenericRep = ModuleName "Data.Generic.Rep" + +pattern Generic :: Qualified (ProperName 'ClassName) +pattern Generic = Qualified (Just DataGenericRep) (ProperName "Generic") + +to :: Qualified Ident +to = Qualified (Just DataGenericRep) (Ident "to") + +from :: Qualified Ident +from = Qualified (Just DataGenericRep) (Ident "from") + +pattern NoConstructors :: Qualified (ProperName a) +pattern NoConstructors = Qualified (Just DataGenericRep) (ProperName "NoConstructors") + +pattern NoArguments :: Qualified (ProperName a) +pattern NoArguments = Qualified (Just DataGenericRep) (ProperName "NoArguments") + +pattern Sum :: Qualified (ProperName a) +pattern Sum = Qualified (Just DataGenericRep) (ProperName "Sum") + +pattern Inl :: Qualified (ProperName a) +pattern Inl = Qualified (Just DataGenericRep) (ProperName "Inl") + +pattern Inr :: Qualified (ProperName a) +pattern Inr = Qualified (Just DataGenericRep) (ProperName "Inr") + +pattern Product :: Qualified (ProperName a) +pattern Product = Qualified (Just DataGenericRep) (ProperName "Product") + +pattern Constructor :: Qualified (ProperName a) +pattern Constructor = Qualified (Just DataGenericRep) (ProperName "Constructor") + +pattern Argument :: Qualified (ProperName a) +pattern Argument = Qualified (Just DataGenericRep) (ProperName "Argument") diff --git a/src/Language/PureScript/Constants/Data/Newtype.hs b/src/Language/PureScript/Constants/Data/Newtype.hs new file mode 100644 index 0000000000..fcb51ba863 --- /dev/null +++ b/src/Language/PureScript/Constants/Data/Newtype.hs @@ -0,0 +1,7 @@ +module Language.PureScript.Constants.Data.Newtype where + +import Prelude.Compat +import Language.PureScript.Names + +pattern Newtype :: Qualified (ProperName 'ClassName) +pattern Newtype = Qualified (Just (ModuleName "Data.Newtype")) (ProperName "Newtype") diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 4e795203f5..d65528aaf6 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -131,6 +131,7 @@ data SimpleErrorMessage | InvalidInstanceHead SourceType | TransitiveExportError DeclarationRef [DeclarationRef] | TransitiveDctorExportError DeclarationRef [ProperName 'ConstructorName] + | HiddenConstructors DeclarationRef (Qualified (ProperName 'ClassName)) | ShadowedName Ident | ShadowedTypeVar Text | UnusedTypeVar Text @@ -298,6 +299,7 @@ errorCode em = case unwrapErrorMessage em of InvalidInstanceHead{} -> "InvalidInstanceHead" TransitiveExportError{} -> "TransitiveExportError" TransitiveDctorExportError{} -> "TransitiveDctorExportError" + HiddenConstructors{} -> "HiddenConstructors" ShadowedName{} -> "ShadowedName" ShadowedTypeVar{} -> "ShadowedTypeVar" UnusedTypeVar{} -> "UnusedTypeVar" @@ -1045,6 +1047,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " requires the following data constructor" <> (if length ctors == 1 then "" else "s") <> " to also be exported: " , indent $ paras $ map (line . markCode . runProperName) ctors ] + renderSimpleErrorMessage (HiddenConstructors x className) = + paras [ line $ "An export for " <> markCode (prettyPrintExport x) <> " hides data constructors but the type declares an instance of " <> markCode (showQualified runProperName className) <> "." + , line "Such instance allows to match and construct values of this type, effectively making the constructors public." + ] renderSimpleErrorMessage (ShadowedName nm) = line $ "Name " <> markCode (showIdent nm) <> " was shadowed." renderSimpleErrorMessage (ShadowedTypeVar tv) = diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 009777571a..549f06efad 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -17,8 +17,10 @@ import Data.Ord (comparing) import qualified Data.Set as S import Data.Text (Text) import Language.PureScript.AST -import qualified Language.PureScript.Constants.Prelude as C -import qualified Language.PureScript.Constants.Prim as C +import qualified Language.PureScript.Constants.Data.Generic.Rep as DataGenericRep +import qualified Language.PureScript.Constants.Data.Newtype as DataNewtype +import qualified Language.PureScript.Constants.Prelude as Prelude +import qualified Language.PureScript.Constants.Prim as Prim import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors @@ -154,7 +156,7 @@ deriveInstance mn syns kinds _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveFunctor ss mn syns kinds ds tyCon | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 - | className == Qualified (Just dataNewtype) (ProperName "Newtype") + | className == DataNewtype.Newtype = case tys of [wrappedTy, unwrappedTy] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy @@ -163,7 +165,7 @@ deriveInstance mn syns kinds _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm return $ TypeInstanceDeclaration sa ch idx nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys wrappedTy _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 - | className == Qualified (Just dataGenericRep) (ProperName C.generic) + | className == DataGenericRep.Generic = case tys of [actualTy, repTy] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy @@ -262,18 +264,12 @@ deriveNewtypeInstance ss mn syns kinds ndis className ds tys tyConNm dargs = do tell . errorMessage' ss $ MissingNewtypeSuperclassInstance constraintClass className tys else tell . errorMessage' ss $ UnverifiableSuperclassInstance constraintClass className tys -dataGenericRep :: ModuleName -dataGenericRep = ModuleName "Data.Generic.Rep" - dataEq :: ModuleName dataEq = ModuleName "Data.Eq" dataOrd :: ModuleName dataOrd = ModuleName "Data.Ord" -dataNewtype :: ModuleName -dataNewtype = ModuleName "Data.Newtype" - dataFunctor :: ModuleName dataFunctor = ModuleName "Data.Functor" @@ -307,13 +303,13 @@ deriveGenericRep ss mn syns kinds ds tyConNm tyConArgs repTy = do lamCase ss' x [ CaseAlternative [NullBinder] - (unguarded (App toName (Var ss' (Qualified Nothing x)))) + (unguarded (App (Var ss DataGenericRep.to) (Var ss' (Qualified Nothing x)))) ] , ValueDecl (ss', []) (Ident "from") Public [] $ unguarded $ lamCase ss' x [ CaseAlternative [NullBinder] - (unguarded (App fromName (Var ss' (Qualified Nothing x)))) + (unguarded (App (Var ss DataGenericRep.from) (Var ss' (Qualified Nothing x)))) ] ] | otherwise = @@ -333,10 +329,12 @@ deriveGenericRep ss mn syns kinds ds tyConNm tyConArgs repTy = do select l r n = take (n - 1) (iterate (r .) l) ++ [compN (n - 1) r] sumBinders :: Int -> [Binder -> Binder] - sumBinders = select (ConstructorBinder ss inl . pure) (ConstructorBinder ss inr . pure) + sumBinders = select (ConstructorBinder ss DataGenericRep.Inl . pure) + (ConstructorBinder ss DataGenericRep.Inr . pure) sumExprs :: Int -> [Expr -> Expr] - sumExprs = select (App (Constructor ss inl)) (App (Constructor ss inr)) + sumExprs = select (App (Constructor ss DataGenericRep.Inl)) + (App (Constructor ss DataGenericRep.Inr)) compN :: Int -> (a -> a) -> a -> a compN 0 _ = id @@ -348,37 +346,37 @@ deriveGenericRep ss mn syns kinds ds tyConNm tyConArgs repTy = do makeInst (DataConstructorDeclaration _ ctorName args) = do args' <- mapM (replaceAllTypeSynonymsM syns kinds . snd) args (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args' - return ( srcTypeApp (srcTypeApp (srcTypeConstructor constructor) + return ( srcTypeApp (srcTypeApp (srcTypeConstructor DataGenericRep.Constructor) (srcTypeLevelString $ mkString (runProperName ctorName))) ctorTy - , CaseAlternative [ ConstructorBinder ss constructor [matchProduct] ] + , CaseAlternative [ ConstructorBinder ss DataGenericRep.Constructor [matchProduct] ] (unguarded (foldl' App (Constructor ss (Qualified (Just mn) ctorName)) ctorArgs)) , CaseAlternative [ ConstructorBinder ss (Qualified (Just mn) ctorName) matchCtor ] - (unguarded (constructor' mkProduct)) + (unguarded (App (Constructor ss DataGenericRep.Constructor) mkProduct)) ) makeProduct :: [SourceType] -> m (SourceType, Binder, [Expr], [Binder], Expr) makeProduct [] = - pure (noArgs, NullBinder, [], [], noArgs') + pure (srcTypeConstructor DataGenericRep.NoArguments, NullBinder, [], [], Constructor ss DataGenericRep.NoArguments) makeProduct args = do (tys, bs1, es1, bs2, es2) <- unzip5 <$> traverse makeArg args - pure ( foldr1 (\f -> srcTypeApp (srcTypeApp (srcTypeConstructor productName) f)) tys - , foldr1 (\b1 b2 -> ConstructorBinder ss productName [b1, b2]) bs1 + pure ( foldr1 (\f -> srcTypeApp (srcTypeApp (srcTypeConstructor DataGenericRep.Product) f)) tys + , foldr1 (\b1 b2 -> ConstructorBinder ss DataGenericRep.Product [b1, b2]) bs1 , es1 , bs2 - , foldr1 (\e1 -> App (App (Constructor ss productName) e1)) es2 + , foldr1 (\e1 -> App (App (Constructor ss DataGenericRep.Product) e1)) es2 ) makeArg :: SourceType -> m (SourceType, Binder, Expr, Binder, Expr) makeArg arg = do argName <- freshIdent "arg" - pure ( srcTypeApp (srcTypeConstructor argument) arg - , ConstructorBinder ss argument [ VarBinder ss argName ] + pure ( srcTypeApp (srcTypeConstructor DataGenericRep.Argument) arg + , ConstructorBinder ss DataGenericRep.Argument [ VarBinder ss argName ] , Var ss (Qualified Nothing argName) , VarBinder ss argName - , argument' (Var ss (Qualified Nothing argName)) + , App (Constructor ss DataGenericRep.Argument) (Var ss (Qualified Nothing argName)) ) underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative @@ -389,48 +387,9 @@ deriveGenericRep ss mn syns kinds ds tyConNm tyConArgs repTy = do underExpr _ _ = internalError "underExpr: expected unguarded alternative" toRepTy :: [SourceType] -> SourceType - toRepTy [] = noCtors + toRepTy [] = srcTypeConstructor DataGenericRep.NoConstructors toRepTy [only] = only - toRepTy ctors = foldr1 (\f -> srcTypeApp (srcTypeApp sumCtor f)) ctors - - toName :: Expr - toName = Var ss (Qualified (Just dataGenericRep) (Ident "to")) - - fromName :: Expr - fromName = Var ss (Qualified (Just dataGenericRep) (Ident "from")) - - noCtors :: SourceType - noCtors = srcTypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoConstructors")) - - noArgs :: SourceType - noArgs = srcTypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoArguments")) - - noArgs' :: Expr - noArgs' = Constructor ss (Qualified (Just dataGenericRep) (ProperName "NoArguments")) - - sumCtor :: SourceType - sumCtor = srcTypeConstructor (Qualified (Just dataGenericRep) (ProperName "Sum")) - - inl :: Qualified (ProperName 'ConstructorName) - inl = Qualified (Just dataGenericRep) (ProperName "Inl") - - inr :: Qualified (ProperName 'ConstructorName) - inr = Qualified (Just dataGenericRep) (ProperName "Inr") - - productName :: Qualified (ProperName ty) - productName = Qualified (Just dataGenericRep) (ProperName "Product") - - constructor :: Qualified (ProperName ty) - constructor = Qualified (Just dataGenericRep) (ProperName "Constructor") - - constructor' :: Expr -> Expr - constructor' = App (Constructor ss constructor) - - argument :: Qualified (ProperName ty) - argument = Qualified (Just dataGenericRep) (ProperName "Argument") - - argument' :: Expr -> Expr - argument' = App (Constructor ss argument) + toRepTy ctors = foldr1 (\f -> srcTypeApp (srcTypeApp (srcTypeConstructor DataGenericRep.Sum) f)) ctors checkIsWildcard :: MonadError MultipleErrors m => SourceSpan -> ProperName 'TypeName -> SourceType -> m () checkIsWildcard _ _ (TypeWildcard _ Nothing) = return () @@ -450,7 +409,7 @@ deriveEq deriveEq ss mn syns kinds ds tyConNm = do tyCon <- findTypeDecl ss tyConNm ds eqFun <- mkEqFunction tyCon - return [ ValueDecl (ss, []) (Ident C.eq) Public [] (unguarded eqFun) ] + return [ ValueDecl (ss, []) (Ident Prelude.eq) Public [] (unguarded eqFun) ] where mkEqFunction :: Declaration -> m Expr mkEqFunction (DataDeclaration (ss', _) _ _ _ args) = do @@ -460,13 +419,13 @@ deriveEq ss mn syns kinds ds tyConNm = do mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration" preludeConj :: Expr -> Expr -> Expr - preludeConj = App . App (Var ss (Qualified (Just (ModuleName "Data.HeytingAlgebra")) (Ident C.conj))) + preludeConj = App . App (Var ss (Qualified (Just (ModuleName "Data.HeytingAlgebra")) (Ident Prelude.conj))) preludeEq :: Expr -> Expr -> Expr - preludeEq = App . App (Var ss (Qualified (Just dataEq) (Ident C.eq))) + preludeEq = App . App (Var ss (Qualified (Just dataEq) (Ident Prelude.eq))) preludeEq1 :: Expr -> Expr -> Expr - preludeEq1 = App . App (Var ss (Qualified (Just dataEq) (Ident C.eq1))) + preludeEq1 = App . App (Var ss (Qualified (Just dataEq) (Ident Prelude.eq1))) addCatch :: [CaseAlternative] -> [CaseAlternative] addCatch xs @@ -501,10 +460,10 @@ deriveEq ss mn syns kinds ds tyConNm = do deriveEq1 :: SourceSpan -> [Declaration] deriveEq1 ss = - [ ValueDecl (ss, []) (Ident C.eq1) Public [] (unguarded preludeEq)] + [ ValueDecl (ss, []) (Ident Prelude.eq1) Public [] (unguarded preludeEq)] where preludeEq :: Expr - preludeEq = Var ss (Qualified (Just dataEq) (Ident C.eq)) + preludeEq = Var ss (Qualified (Just dataEq) (Ident Prelude.eq)) deriveOrd :: forall m @@ -519,7 +478,7 @@ deriveOrd deriveOrd ss mn syns kinds ds tyConNm = do tyCon <- findTypeDecl ss tyConNm ds compareFun <- mkCompareFunction tyCon - return [ ValueDecl (ss, []) (Ident C.compare) Public [] (unguarded compareFun) ] + return [ ValueDecl (ss, []) (Ident Prelude.compare) Public [] (unguarded compareFun) ] where mkCompareFunction :: Declaration -> m Expr mkCompareFunction (DataDeclaration (ss', _) _ _ _ args) = do @@ -550,10 +509,10 @@ deriveOrd ss mn syns kinds ds tyConNm = do orderingBinder name = ConstructorBinder ss (orderingName name) [] ordCompare :: Expr -> Expr -> Expr - ordCompare = App . App (Var ss (Qualified (Just dataOrd) (Ident C.compare))) + ordCompare = App . App (Var ss (Qualified (Just dataOrd) (Ident Prelude.compare))) ordCompare1 :: Expr -> Expr -> Expr - ordCompare1 = App . App (Var ss (Qualified (Just dataOrd) (Ident C.compare1))) + ordCompare1 = App . App (Var ss (Qualified (Just dataOrd) (Ident Prelude.compare1))) mkCtorClauses :: (DataConstructorDeclaration, Bool) -> m [CaseAlternative] mkCtorClauses ((DataConstructorDeclaration _ ctorName tys), isLast) = do @@ -603,10 +562,10 @@ deriveOrd ss mn syns kinds ds tyConNm = do deriveOrd1 :: SourceSpan -> [Declaration] deriveOrd1 ss = - [ ValueDecl (ss, []) (Ident C.compare1) Public [] (unguarded dataOrdCompare)] + [ ValueDecl (ss, []) (Ident Prelude.compare1) Public [] (unguarded dataOrdCompare)] where dataOrdCompare :: Expr - dataOrdCompare = Var ss (Qualified (Just dataOrd) (Ident C.compare)) + dataOrdCompare = Var ss (Qualified (Just dataOrd) (Ident Prelude.compare)) deriveNewtype :: forall m @@ -679,7 +638,7 @@ isAppliedVar (TypeApp _ (TypeVar _ _) _) = True isAppliedVar _ = False objectType :: Type a -> Maybe (Type a) -objectType (TypeApp _ (TypeConstructor _ C.Record) rec) = Just rec +objectType (TypeApp _ (TypeConstructor _ Prim.Record) rec) = Just rec objectType _ = Nothing decomposeRec :: SourceType -> Maybe [(Label, SourceType)] @@ -706,7 +665,7 @@ deriveFunctor deriveFunctor ss mn syns kinds ds tyConNm = do tyCon <- findTypeDecl ss tyConNm ds mapFun <- mkMapFunction tyCon - return [ ValueDecl (ss, []) (Ident C.map) Public [] (unguarded mapFun) ] + return [ ValueDecl (ss, []) (Ident Prelude.map) Public [] (unguarded mapFun) ] where mkMapFunction :: Declaration -> m Expr mkMapFunction (DataDeclaration (ss', _) _ _ tys ctors) = case reverse tys of @@ -728,7 +687,7 @@ deriveFunctor ss mn syns kinds ds tyConNm = do return $ CaseAlternative [caseBinder] (unguarded rebuilt) where fVar = mkVar ss f - mapVar = mkVarMn ss (Just dataFunctor) (Ident C.map) + mapVar = mkVarMn ss (Just dataFunctor) (Ident Prelude.map) -- TODO: deal with type synonyms, ala https://github.com/purescript/purescript/pull/2516 transformArg :: Ident -> SourceType -> m Expr diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 17b2af7425..14e4951b78 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -29,6 +29,8 @@ import qualified Data.Set as S import qualified Data.Text as T import Language.PureScript.AST +import qualified Language.PureScript.Constants.Data.Generic.Rep as DataGenericRep +import qualified Language.PureScript.Constants.Data.Newtype as DataNewtype import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors @@ -755,10 +757,20 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = extractMemberName _ = internalError "Unexpected declaration in typeclass member list" checkClassMembersAreExported _ = return () - -- | If any data constructors of a type are exported, we require all its data constructors to be exported. + -- If a type is exported without data constructors, we warn on `Generic` or `Newtype` instances. + -- On the other hand if any data constructors are exported, we require all of them to be exported. checkDataConstructorsAreExported :: DeclarationRef -> m () - checkDataConstructorsAreExported dr@(TypeRef ss' name (Just exportedDataConstructorsNames)) - | not (null exportedDataConstructorsNames) = do + checkDataConstructorsAreExported dr@(TypeRef ss' name (fromMaybe [] -> exportedDataConstructorsNames)) + | null exportedDataConstructorsNames = for_ + [ DataGenericRep.Generic + , DataNewtype.Newtype + ] $ \className -> do + env <- getEnv + let dicts = foldMap (foldMap NEL.toList) $ + M.lookup (Just mn) (typeClassDictionaries env) >>= M.lookup className + when (any isDictOfTypeRef dicts) $ + tell . errorMessage' ss' $ HiddenConstructors dr className + | otherwise = do env <- getEnv let dataConstructorNames = fromMaybe [] $ M.lookup (mkQualified name mn) (types env) >>= getDataConstructorNames . snd @@ -766,6 +778,12 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = unless (null missingDataConstructorsNames) $ throwError . errorMessage' ss' $ TransitiveDctorExportError dr missingDataConstructorsNames where + isDictOfTypeRef :: TypeClassDictionaryInScope a -> Bool + isDictOfTypeRef dict + | (TypeConstructor _ qualTyName, _, _) : _ <- unapplyTypes <$> tcdInstanceTypes dict + , qualTyName == Qualified (Just mn) name + = True + isDictOfTypeRef _ = False getDataConstructorNames :: TypeKind -> Maybe [ProperName 'ConstructorName] getDataConstructorNames (DataType _ constructors) = Just $ fst <$> constructors getDataConstructorNames _ = Nothing diff --git a/tests/purs/warning/HiddenConstructorsGeneric.out b/tests/purs/warning/HiddenConstructorsGeneric.out new file mode 100644 index 0000000000..eb4270c574 --- /dev/null +++ b/tests/purs/warning/HiddenConstructorsGeneric.out @@ -0,0 +1,11 @@ +Warning found: +in module Main +at tests/purs/warning/HiddenConstructorsGeneric.purs:2:1 - 8:40 (line 2, column 1 - line 8, column 40) + + An export for D hides data constructors but the type declares an instance of Data.Generic.Rep.Generic. + Such instance allows to match and construct values of this type, effectively making the constructors public. + + +See https://github.com/purescript/documentation/blob/master/errors/HiddenConstructors.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/HiddenConstructorsGeneric.purs b/tests/purs/warning/HiddenConstructorsGeneric.purs new file mode 100644 index 0000000000..3949f6b390 --- /dev/null +++ b/tests/purs/warning/HiddenConstructorsGeneric.purs @@ -0,0 +1,8 @@ +-- @shouldWarnWith HiddenConstructors +module Main (D) where + +import Data.Generic.Rep (class Generic) + +data D = D + +derive instance genericD :: Generic D _ diff --git a/tests/purs/warning/HiddenConstructorsNewtype.out b/tests/purs/warning/HiddenConstructorsNewtype.out new file mode 100644 index 0000000000..8e4c630caa --- /dev/null +++ b/tests/purs/warning/HiddenConstructorsNewtype.out @@ -0,0 +1,11 @@ +Warning found: +in module Main +at tests/purs/warning/HiddenConstructorsNewtype.purs:2:1 - 8:44 (line 2, column 1 - line 8, column 44) + + An export for N hides data constructors but the type declares an instance of Data.Newtype.Newtype. + Such instance allows to match and construct values of this type, effectively making the constructors public. + + +See https://github.com/purescript/documentation/blob/master/errors/HiddenConstructors.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/HiddenConstructorsNewtype.purs b/tests/purs/warning/HiddenConstructorsNewtype.purs new file mode 100644 index 0000000000..3d2620656a --- /dev/null +++ b/tests/purs/warning/HiddenConstructorsNewtype.purs @@ -0,0 +1,8 @@ +-- @shouldWarnWith HiddenConstructors +module Main (N) where + +import Data.Newtype (class Newtype) + +newtype N a = N a + +derive instance newtypeN :: Newtype (N a) _ From 7f4bafb8a334fd2778f540bb1abf24bc6c3dab8b Mon Sep 17 00:00:00 2001 From: Cyril Date: Sun, 11 Oct 2020 18:14:52 +0200 Subject: [PATCH 1244/1580] Update the desugaring pipeline to work on individual modules (#3944) Since 6d1b5ec3af12812810701b766a12f7c9aceabe75, `Language.PureScript.Sugar.desugar` is always applied to singleton arrays so this simplifies a few things. --- src/Language/PureScript/Docs/Convert.hs | 20 ++++++------- src/Language/PureScript/Interactive/Types.hs | 4 +-- src/Language/PureScript/Make.hs | 21 ++++++------- src/Language/PureScript/Sugar.hs | 31 ++++++++------------ src/Language/PureScript/Sugar/Names.hs | 21 ++++++------- src/Language/PureScript/Sugar/Operators.hs | 18 +++++------- src/Language/PureScript/Sugar/TypeClasses.hs | 6 ++-- 7 files changed, 53 insertions(+), 68 deletions(-) diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 47cd461fe4..987a41d570 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -39,10 +39,8 @@ convertModule :: P.Environment -> P.Module -> m Module -convertModule externs env checkEnv m = - partiallyDesugar externs env [m] >>= \case - [m'] -> pure (insertValueTypes checkEnv (convertSingleModule m')) - _ -> P.internalError "partiallyDesugar did not return a singleton" +convertModule externs env checkEnv = + fmap (insertValueTypes checkEnv . convertSingleModule) . partiallyDesugar externs env -- | -- Updates all the types of the ValueDeclarations inside the module based on @@ -90,16 +88,16 @@ partiallyDesugar :: (MonadError P.MultipleErrors m) => [P.ExternsFile] -> P.Env -> - [P.Module] -> - m [P.Module] + P.Module -> + m P.Module partiallyDesugar externs env = evalSupplyT 0 . desugar' where desugar' = - traverse P.desugarDoModule - >=> traverse P.desugarAdoModule - >=> map P.desugarLetPatternModule - >>> traverse P.desugarCasesModule - >=> traverse P.desugarTypeDeclarationsModule + P.desugarDoModule + >=> P.desugarAdoModule + >=> P.desugarLetPatternModule + >>> P.desugarCasesModule + >=> P.desugarTypeDeclarationsModule >=> fmap fst . runWriterT . flip evalStateT (env, mempty) . P.desugarImports >=> P.rebracketFiltered isInstanceDecl externs diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index b052be8f20..9c1c13a262 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -120,7 +120,7 @@ psciImportedModuleNames st = -- ensure that completions remain accurate. updateImportExports :: PSCiState -> PSCiState updateImportExports st@(PSCiState modules lets externs iprint _ _) = - case createEnv (map snd externs) >>= flip desugarModule [temporaryModule] of + case createEnv (map snd externs) >>= flip desugarModule temporaryModule of Left _ -> st -- TODO: can this fail and what should we do? Right env -> case M.lookup temporaryName env of @@ -128,7 +128,7 @@ updateImportExports st@(PSCiState modules lets externs iprint _ _) = _ -> st -- impossible where - desugarModule :: P.Env -> [P.Module] -> Either P.MultipleErrors P.Env + desugarModule :: P.Env -> P.Module -> Either P.MultipleErrors P.Env desugarModule e = runExceptT =<< fmap (fst . fst) . runWriterT . flip execStateT (e, mempty) . P.desugarImports createEnv :: [P.ExternsFile] -> Either P.MultipleErrors P.Env diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 9977dfaefc..afd446a133 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -78,18 +78,15 @@ rebuildModule' MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) = do lint withPrim ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do - runStateT (desugar externs [withPrim]) (exEnv, mempty) >>= \case - ([desugared], (exEnv', usedImportsByModuleName)) -> do - (checked, CheckState{..}) <- runStateT (typeCheckModule desugared) $ emptyCheckState env - let usedImports = fold $ M.lookup moduleName usedImportsByModuleName - usedImports' = foldl' (flip $ \(fromModuleName, newtypeCtorName) -> - M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName) usedImports checkCoercedNewtypeCtorsImports - -- Imports cannot be linted before type checking because we need to - -- known which newtype constructors are used to solve Coercible - -- constraints in order to not report them as unused. - censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports' - return (checked, checkEnv) - _ -> internalError "desugar did not return a singleton" + (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty) + (checked, CheckState{..}) <- runStateT (typeCheckModule desugared) $ emptyCheckState env + let usedImports' = foldl' (flip $ \(fromModuleName, newtypeCtorName) -> + M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName) usedImports checkCoercedNewtypeCtorsImports + -- Imports cannot be linted before type checking because we need to + -- known which newtype constructors are used to solve Coercible + -- constraints in order to not report them as unused. + censor (addHint (ErrorInModule moduleName)) $ lintImports checked exEnv' usedImports' + return (checked, checkEnv) -- desugar case declarations *after* type- and exhaustiveness checking -- since pattern guards introduces cases which the exhaustiveness checker diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index bbf802247e..bacc90ced9 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -10,15 +10,10 @@ import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.State.Class (MonadState) import Control.Monad.Writer.Class (MonadWriter) -import Data.List (map) -import Data.Traversable (traverse) -import Data.Map (Map) - import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Externs import Language.PureScript.Linter.Imports -import Language.PureScript.Names import Language.PureScript.Sugar.BindingGroups as S import Language.PureScript.Sugar.CaseDeclarations as S import Language.PureScript.Sugar.DoNotation as S @@ -60,21 +55,21 @@ desugar :: MonadSupply m => MonadError MultipleErrors m => MonadWriter MultipleErrors m - => MonadState (Env, Map ModuleName UsedImports) m + => MonadState (Env, UsedImports) m => [ExternsFile] - -> [Module] - -> m [Module] + -> Module + -> m Module desugar externs = - map desugarSignedLiterals - >>> traverse desugarObjectConstructors - >=> traverse desugarDoModule - >=> traverse desugarAdoModule - >=> map desugarLetPatternModule - >>> traverse desugarCasesModule - >=> traverse desugarTypeDeclarationsModule + desugarSignedLiterals + >>> desugarObjectConstructors + >=> desugarDoModule + >=> desugarAdoModule + >=> desugarLetPatternModule + >>> desugarCasesModule + >=> desugarTypeDeclarationsModule >=> desugarImports >=> rebracket externs - >=> traverse checkFixityExports - >=> traverse (deriveInstances externs) + >=> checkFixityExports + >=> deriveInstances externs >=> desugarTypeClasses externs - >=> traverse createBindingGroupsModule + >=> createBindingGroupsModule diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 84a49d27df..913b37d8e9 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -35,26 +35,23 @@ import Language.PureScript.Traversals import Language.PureScript.Types -- | --- Replaces all local names with qualified names within a list of modules. The --- modules should be topologically sorted beforehand. +-- Replaces all local names with qualified names. -- desugarImports :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState (Env, M.Map ModuleName UsedImports) m) - => [Module] - -> m [Module] -desugarImports modules = do - modules' <- reverse <$> foldM updateEnv [] modules - traverse renameInModule' modules' + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState (Env, UsedImports) m) + => Module + -> m Module +desugarImports = updateEnv >=> renameInModule' where - updateEnv :: [Module] -> Module -> m [Module] - updateEnv ms m@(Module ss _ mn _ refs) = do + updateEnv :: Module -> m Module + updateEnv m@(Module ss _ mn _ refs) = do members <- findExportable m env' <- gets $ M.insert mn (ss, nullImports, members) . fst (m', imps) <- resolveImports env' m exps <- maybe (return members) (resolveExports env' ss mn imps members) refs modify . first $ M.insert mn (ss, imps, exps) - return $ m' : ms + return m' renameInModule' :: Module -> m Module renameInModule' m@(Module _ _ mn _ _) = @@ -62,7 +59,7 @@ desugarImports modules = do env <- gets fst let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env (m', used) <- flip runStateT M.empty $ renameInModule imps m - modify . second $ M.alter (Just . maybe used (M.unionWith (<>) used)) mn + modify . second $ M.unionWith (<>) used return $ elaborateExports exps m' -- | Create an environment from a collection of externs files diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 9f7bbcda47..ff9d4d7d5a 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -34,7 +34,6 @@ import Data.Function (on) import Data.Functor.Identity (Identity(..), runIdentity) import Data.List (groupBy, sortBy) import Data.Maybe (mapMaybe, listToMaybe) -import Data.Traversable (for) import qualified Data.Map as M import qualified Language.PureScript.Constants.Prelude as C @@ -67,8 +66,8 @@ rebracket :: forall m . MonadError MultipleErrors m => [ExternsFile] - -> [Module] - -> m [Module] + -> Module + -> m Module rebracket = rebracketFiltered (const True) @@ -84,13 +83,13 @@ rebracketFiltered . MonadError MultipleErrors m => (Declaration -> Bool) -> [ExternsFile] - -> [Module] - -> m [Module] -rebracketFiltered pred_ externs modules = do + -> Module + -> m Module +rebracketFiltered pred_ externs m = do let (valueFixities, typeFixities) = partitionEithers $ concatMap externsFixities externs - ++ concatMap collectFixities modules + ++ collectFixities m ensureNoDuplicates' MultipleValueOpFixities valueFixities ensureNoDuplicates' MultipleTypeOpFixities typeFixities @@ -100,9 +99,8 @@ rebracketFiltered pred_ externs modules = do let typeOpTable = customOperatorTable' typeFixities let typeAliased = M.fromList (map makeLookupEntry typeFixities) - for modules - $ renameAliasedOperators valueAliased typeAliased - <=< rebracketModule pred_ valueOpTable typeOpTable + rebracketModule pred_ valueOpTable typeOpTable m >>= + renameAliasedOperators valueAliased typeAliased where diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index f0514e535e..2d67d21b3f 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -44,9 +44,9 @@ type Desugar = StateT MemberMap desugarTypeClasses :: (MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] - -> [Module] - -> m [Module] -desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule + -> Module + -> m Module +desugarTypeClasses externs = flip evalStateT initialState . desugarModule where initialState :: MemberMap initialState = From 48634d05da1021ac1bcb4907461ae9b2d3b0e699 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 11 Oct 2020 19:22:40 +0100 Subject: [PATCH 1245/1580] Update version to 0.14.0-rc3 (#3945) --- app/Version.hs | 2 +- package.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/app/Version.hs b/app/Version.hs index 3bb1c8571a..a318c0e9b8 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -17,7 +17,7 @@ import qualified Development.GitRev as GitRev -- prerelease identifier here (if any). When releasing a proper version, simply -- set this to an empty string. prerelease :: String -prerelease = "-rc2" +prerelease = "-rc3" versionString :: String versionString = showVersion Paths.version ++ prerelease ++ extra diff --git a/package.yaml b/package.yaml index e681332372..34db54431c 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.14.0-rc2' # note: when updating this, update the prerelease identifier in app/Version.hs too! +version: '0.14.0-rc3' # note: when updating this, update the prerelease identifier in app/Version.hs too! synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From cc48ced713cf519241f4449c522adb4f3bd31fcd Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Tue, 15 Dec 2020 21:41:39 -0500 Subject: [PATCH 1246/1580] Add source span to PartiallyAppliedSynonym errors (#3951) --- src/Language/PureScript/TypeChecker/Synonyms.hs | 14 +++++++------- tests/purs/failing/InvalidDerivedInstance3.out | 10 ++++++++++ tests/purs/failing/InvalidDerivedInstance3.purs | 10 ++++++++++ tests/purs/failing/TypeSynonyms4.out | 2 +- 4 files changed, 28 insertions(+), 8 deletions(-) create mode 100644 tests/purs/failing/InvalidDerivedInstance3.out create mode 100644 tests/purs/failing/InvalidDerivedInstance3.purs diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index cbc3a9a83a..7b76b21cb3 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -36,10 +36,10 @@ replaceAllTypeSynonyms' replaceAllTypeSynonyms' syns kinds = everywhereOnTypesTopDownM try where try :: SourceType -> Either MultipleErrors SourceType - try t = fromMaybe t <$> go 0 [] [] t + try t = fromMaybe t <$> go (fst $ getAnnForType t) 0 [] [] t - go :: Int -> [SourceType] -> [SourceType] -> SourceType -> Either MultipleErrors (Maybe SourceType) - go c kargs args (TypeConstructor _ ctor) + go :: SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType -> Either MultipleErrors (Maybe SourceType) + go ss c kargs args (TypeConstructor _ ctor) | Just (synArgs, body) <- M.lookup ctor syns , c == length synArgs , kindArgs <- lookupKindArgs ctor @@ -48,10 +48,10 @@ replaceAllTypeSynonyms' syns kinds = everywhereOnTypesTopDownM try in Just <$> try repl | Just (synArgs, _) <- M.lookup ctor syns , length synArgs > c - = throwError . errorMessage $ PartiallyAppliedSynonym ctor - go c kargs args (TypeApp _ f arg) = go (c + 1) kargs (arg : args) f - go c kargs args (KindApp _ f arg) = go c (arg : kargs) args f - go _ _ _ _ = return Nothing + = throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor + go ss c kargs args (TypeApp _ f arg) = go ss (c + 1) kargs (arg : args) f + go ss c kargs args (KindApp _ f arg) = go ss c (arg : kargs) args f + go _ _ _ _ _ = return Nothing lookupKindArgs :: Qualified (ProperName 'TypeName) -> [Text] lookupKindArgs ctor = fromMaybe [] $ fmap (fmap (fst . snd) . fst) . completeBinderList . fst =<< M.lookup ctor kinds diff --git a/tests/purs/failing/InvalidDerivedInstance3.out b/tests/purs/failing/InvalidDerivedInstance3.out new file mode 100644 index 0000000000..848b38720b --- /dev/null +++ b/tests/purs/failing/InvalidDerivedInstance3.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/InvalidDerivedInstance3.purs:8:15 - 8:16 (line 8, column 15 - line 8, column 16) + + Type synonym Main.S is partially applied. + Type synonyms must be applied to all of their type arguments. + + +See https://github.com/purescript/documentation/blob/master/errors/PartiallyAppliedSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InvalidDerivedInstance3.purs b/tests/purs/failing/InvalidDerivedInstance3.purs new file mode 100644 index 0000000000..5b676951f2 --- /dev/null +++ b/tests/purs/failing/InvalidDerivedInstance3.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith PartiallyAppliedSynonym +module Main where + +import Data.Newtype (class Newtype) + +data D a +type S a = D a +newtype N = N S + +derive instance newtypeN :: Newtype N _ diff --git a/tests/purs/failing/TypeSynonyms4.out b/tests/purs/failing/TypeSynonyms4.out index 20fabba5ef..6ff9926c75 100644 --- a/tests/purs/failing/TypeSynonyms4.out +++ b/tests/purs/failing/TypeSynonyms4.out @@ -1,6 +1,6 @@ Error found: in module TypeSynonyms4 -at tests/purs/failing/TypeSynonyms4.purs:8:1 - 8:15 (line 8, column 1 - line 8, column 15) +at tests/purs/failing/TypeSynonyms4.purs:8:12 - 8:15 (line 8, column 12 - line 8, column 15) Type synonym TypeSynonyms4.F is partially applied. Type synonyms must be applied to all of their type arguments. From 46f64af9dd04a3510ce2e487e2f13d01981bfa27 Mon Sep 17 00:00:00 2001 From: Mohammed Anas <6daf084a-8eaf-40fb-86c7-8500077c3b69@anonaddy.me> Date: Wed, 16 Dec 2020 05:44:36 +0300 Subject: [PATCH 1247/1580] Improve error message when `negate` isn't imported (#3952) * Improve error message when `negate` isn't imported * Add tests for bind and discard too --- src/Language/PureScript/Errors.hs | 2 ++ tests/purs/failing/2109-bind.out | 10 ++++++++++ tests/purs/failing/2109-bind.purs | 9 +++++++++ tests/purs/failing/2109-discard.out | 10 ++++++++++ tests/purs/failing/2109-discard.purs | 8 ++++++++ tests/purs/failing/2109-negate.out | 10 ++++++++++ tests/purs/failing/2109-negate.purs | 4 ++++ 7 files changed, 53 insertions(+) create mode 100644 tests/purs/failing/2109-bind.out create mode 100644 tests/purs/failing/2109-bind.purs create mode 100644 tests/purs/failing/2109-discard.out create mode 100644 tests/purs/failing/2109-discard.purs create mode 100644 tests/purs/failing/2109-negate.out create mode 100644 tests/purs/failing/2109-negate.purs diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index d65528aaf6..c99f043734 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -725,6 +725,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident i)))) | i `elem` [ C.bind, C.discard ] = line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode i <> " function. Please import " <> markCode i <> " from module " <> markCode "Prelude" + renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident i)))) | i == C.negate = + line $ "Unknown " <> printName name <> ". You're probably using numeric negation (the unary " <> markCode "-" <> " operator), which the compiler replaces with calls to the " <> markCode i <> " function. Please import " <> markCode i <> " from module " <> markCode "Prelude" renderSimpleErrorMessage (UnknownName name) = line $ "Unknown " <> printName name renderSimpleErrorMessage (UnknownImport mn name) = diff --git a/tests/purs/failing/2109-bind.out b/tests/purs/failing/2109-bind.out new file mode 100644 index 0000000000..2a22bb5ed0 --- /dev/null +++ b/tests/purs/failing/2109-bind.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/2109-bind.purs:8:3 - 8:14 (line 8, column 3 - line 8, column 14) + + Unknown value bind. You're probably using do-notation, which the compiler replaces with calls to the bind function. Please import bind from module Prelude + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2109-bind.purs b/tests/purs/failing/2109-bind.purs new file mode 100644 index 0000000000..8b2ea0cd20 --- /dev/null +++ b/tests/purs/failing/2109-bind.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith UnknownName +module Main where + +import Data.Maybe (Maybe(..)) +import Prelude (pure) + +x = do + x <- Just 1 + pure x diff --git a/tests/purs/failing/2109-discard.out b/tests/purs/failing/2109-discard.out new file mode 100644 index 0000000000..86457303ca --- /dev/null +++ b/tests/purs/failing/2109-discard.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/2109-discard.purs:7:3 - 7:12 (line 7, column 3 - line 7, column 12) + + Unknown value discard. You're probably using do-notation, which the compiler replaces with calls to the discard function. Please import discard from module Prelude + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2109-discard.purs b/tests/purs/failing/2109-discard.purs new file mode 100644 index 0000000000..1770690ec9 --- /dev/null +++ b/tests/purs/failing/2109-discard.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith UnknownName +module Main where + +import Prelude (unit, pure) + +main = do + pure unit + pure unit diff --git a/tests/purs/failing/2109-negate.out b/tests/purs/failing/2109-negate.out new file mode 100644 index 0000000000..18c42ee9cd --- /dev/null +++ b/tests/purs/failing/2109-negate.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/2109-negate.purs:4:5 - 4:7 (line 4, column 5 - line 4, column 7) + + Unknown value negate. You're probably using numeric negation (the unary - operator), which the compiler replaces with calls to the negate function. Please import negate from module Prelude + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/2109-negate.purs b/tests/purs/failing/2109-negate.purs new file mode 100644 index 0000000000..f7dbd1116a --- /dev/null +++ b/tests/purs/failing/2109-negate.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith UnknownName +module Main where + +x = -5 From 8534fbc14203cb2aaf3e4249d9c28ab90f7a58f8 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Tue, 15 Dec 2020 21:49:30 -0500 Subject: [PATCH 1248/1580] Unsupport bare negative literals as equational binders (#3956) This is a breaking change. The syntax foo -1 = ... as part of an equational definition, either at top-level or in a let-binding, is no longer supported. The fix is to wrap the negation in parentheses, as one would for an expression: foo (-1) = ... This enables using `-` as a constructor operator in binders. --- .../src/Language/PureScript/CST/Parser.y | 4 +- tests/purs/passing/MinusConstructor.purs | 38 +++++++++++++++++++ tests/purs/passing/NegativeBinder.purs | 7 +++- 3 files changed, 46 insertions(+), 3 deletions(-) create mode 100644 tests/purs/passing/MinusConstructor.purs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y index 5541f060a1..32e079041b 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y +++ b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y @@ -35,7 +35,7 @@ import qualified Language.PureScript.Roles as R import Language.PureScript.PSString (PSString) } -%expect 95 +%expect 93 %name parseType type %name parseExpr expr @@ -570,6 +570,7 @@ binder1 :: { Binder () } binder2 :: { Binder () } : many(binderAtom) {% toBinderConstructor $1 } + | '-' number { uncurry (BinderNumber () (Just $1)) $2 } binderAtom :: { Binder () } : '_' { BinderWildcard () $1 } @@ -580,7 +581,6 @@ binderAtom :: { Binder () } | char { uncurry (BinderChar ()) $1 } | string { uncurry (BinderString ()) $1 } | number { uncurry (BinderNumber () Nothing) $1 } - | '-' number { uncurry (BinderNumber () (Just $1)) $2 } | delim('[', binder, ',', ']') { BinderArray () $1 } | delim('{', recordBinder, ',', '}') { BinderRecord () $1 } | '(' binder ')' { BinderParens () (Wrapped $1 $2 $3) } diff --git a/tests/purs/passing/MinusConstructor.purs b/tests/purs/passing/MinusConstructor.purs new file mode 100644 index 0000000000..56e5a50c6b --- /dev/null +++ b/tests/purs/passing/MinusConstructor.purs @@ -0,0 +1,38 @@ +module Main where + +import Prelude + +import Effect.Console (log) +import Test.Assert (assert) + +data Tuple a b = Tuple a b + +infixl 6 Tuple as - + +test1 = + let tuple = "" - "" + left - right = tuple + in left + +test2 = case 3 - 4 of + left-4 -> left + _ -> 0 + +test3 (Tuple a b - c) = a +test3 _ = 0 + +test4 = case 7 - -3 of + left - -3 -> left + _ -> 0 + +test5 = case -7 - 8 of + -7-right -> right + _ -> 0 + +main = do + assert $ test1 == "" + assert $ test2 == 3 + assert $ test3 (5-10-15) == 5 + assert $ test4 == 7 + assert $ test5 == 8 + log "Done" diff --git a/tests/purs/passing/NegativeBinder.purs b/tests/purs/passing/NegativeBinder.purs index 2d4e36b52a..46a791c660 100644 --- a/tests/purs/passing/NegativeBinder.purs +++ b/tests/purs/passing/NegativeBinder.purs @@ -4,7 +4,12 @@ import Prelude import Effect.Console (log) test :: Number -> Boolean -test -1.0 = false +test (-1.0) = false test _ = true +test2 :: Number -> Number -> Boolean +test2 x y = case x, y of + -1.0, -1.0 -> false + _, _ -> true + main = log "Done" From 9f2bf864e5e9da0fa9f99c3d4a40bf709325e5f3 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Tue, 15 Dec 2020 22:06:16 -0500 Subject: [PATCH 1249/1580] Reform handling of quote characters in raw strings (#3961) This corrects a number of regressions introduced in 0.13, and imposes the uniform restriction that `"""` can't appear anywhere inside a raw string literal. It's possible (in fact, slightly easier) to lex strings such that an unlimited number of quotes are allowed at the end (and only at the end) of a raw string literal, but the simplicity and clarity of a uniform rule outweighs the implementation cost and the very minor loss of expressiveness. --- lib/purescript-cst/package.yaml | 1 + .../src/Data/Text/PureScript.hs | 23 ++++++++++++++ .../src/Language/PureScript/CST/Lexer.hs | 26 +++++++++------- tests/purs/passing/BlockStringEdgeCases.purs | 30 +++++++++++++++++++ 4 files changed, 70 insertions(+), 10 deletions(-) create mode 100644 lib/purescript-cst/src/Data/Text/PureScript.hs create mode 100644 tests/purs/passing/BlockStringEdgeCases.purs diff --git a/lib/purescript-cst/package.yaml b/lib/purescript-cst/package.yaml index f2ca677382..726dd7b38c 100644 --- a/lib/purescript-cst/package.yaml +++ b/lib/purescript-cst/package.yaml @@ -35,6 +35,7 @@ library: source-dirs: src ghc-options: -Wall -O2 default-extensions: !include "default-extensions.yaml" + other-modules: Data.Text.PureScript tests: tests: diff --git a/lib/purescript-cst/src/Data/Text/PureScript.hs b/lib/purescript-cst/src/Data/Text/PureScript.hs new file mode 100644 index 0000000000..65751bff6b --- /dev/null +++ b/lib/purescript-cst/src/Data/Text/PureScript.hs @@ -0,0 +1,23 @@ +-- | +-- This module contains internal extensions to Data.Text. +-- +module Data.Text.PureScript (spanUpTo) where + +import Prelude + +import Data.Text.Internal (Text(..), text) +import Data.Text.Unsafe (Iter(..), iter) + +-- | /O(n)/ 'spanUpTo', applied to a number @n@, predicate @p@, and text @t@, +-- returns a pair whose first element is the longest prefix (possibly empty) of +-- @t@ of length less than or equal to @n@ of elements that satisfy @p@, and +-- whose second is the remainder of the text. +{-# INLINE spanUpTo #-} +spanUpTo :: Int -> (Char -> Bool) -> Text -> (Text, Text) +spanUpTo n p t@(Text arr off len) = (hd, tl) + where hd = text arr off k + tl = text arr (off + k) (len - k) + !k = loop n 0 + loop !n' !i | n' > 0 && i < len && p c = loop (n' - 1) (i + d) + | otherwise = i + where Iter c d = iter t i diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs index 2ad7646479..64c8212a64 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs @@ -17,6 +17,7 @@ import qualified Data.Scientific as Sci import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as Text +import qualified Data.Text.PureScript as Text import Language.PureScript.CST.Errors import Language.PureScript.CST.Monad hiding (token) import Language.PureScript.CST.Layout @@ -121,6 +122,12 @@ nextWhile p = Parser $ \inp _ ksucc -> do let (chs, inp') = Text.span p inp ksucc inp' chs +{-# INLINE nextWhile' #-} +nextWhile' :: Int -> (Char -> Bool) -> Lexer Text +nextWhile' n p = Parser $ \inp _ ksucc -> do + let (chs, inp') = Text.spanUpTo n p inp + ksucc inp' chs + {-# INLINE peek #-} peek :: Lexer (Maybe Char) peek = Parser $ \inp _ ksucc -> @@ -428,15 +435,15 @@ token = peek >>= maybe (pure TokEof) k0 string : '"' stringPart* '"' - | '"""' .* '"""' + | '"""' '"'{0,2} ([^"]+ '"'{1,2})* [^"]* '"""' - This assumes maximal munch for quotes. A raw string literal can end with - any number of quotes, where the last 3 are considered the closing - delimiter. + A raw string literal can't contain any sequence of 3 or more quotes, + although sequences of 1 or 2 quotes are allowed anywhere, including at the + beginning or the end. -} string :: Lexer Token string = do - quotes1 <- nextWhile (== '"') + quotes1 <- nextWhile' 7 (== '"') case Text.length quotes1 of 0 -> do let @@ -467,19 +474,18 @@ token = peek >>= maybe (pure TokEof) k0 go "" mempty 1 -> pure $ TokString "" "" - n | n >= 5 -> do - let str = Text.take 5 quotes1 - pure $ TokString str (fromString (Text.unpack str)) + n | n >= 5 -> + pure $ TokRawString $ Text.drop 5 quotes1 _ -> do let go acc = do chs <- nextWhile (/= '"') - quotes2 <- nextWhile (== '"') + quotes2 <- nextWhile' 5 (== '"') case Text.length quotes2 of 0 -> throw ErrEof n | n >= 3 -> pure $ TokRawString $ acc <> chs <> Text.drop 3 quotes2 _ -> go (acc <> chs <> quotes2) - go "" + go $ Text.drop 2 quotes1 {- escape diff --git a/tests/purs/passing/BlockStringEdgeCases.purs b/tests/purs/passing/BlockStringEdgeCases.purs new file mode 100644 index 0000000000..469df80274 --- /dev/null +++ b/tests/purs/passing/BlockStringEdgeCases.purs @@ -0,0 +1,30 @@ +module Main where + +import Prelude +import Effect.Console (log) +import Test.Assert (assert') + +data Tuple a b = Tuple a b +derive instance tupleEq :: (Eq a, Eq b) => Eq (Tuple a b) + +main = do + assert' "empty string" ("""""" == "") + assert' "quote" (""""""" == "\"") + assert' "starts with quote" (""""x""" == "\"x") + assert' "ends with quote" ("""x"""" == "x\"") + assert' "two quotes" ("""""""" == "\"\"") + assert' "starts with two quotes" ("""""x""" == "\"\"x") + assert' "ends with two quotes" ("""x""""" == "x\"\"") + assert' "starts and ends with two quotes" ("""""x""""" == "\"\"x\"\"") + assert' "mixture 1" ("""""x"y""z"""" == "\"\"x\"y\"\"z\"") + assert' "mixture 2" ("""x"y""z""" == "x\"y\"\"z") + + -- These last tests are more about forbidding certain raw string literal + -- edge cases than about wanting to support mashing string literals against. + -- each other, which is techically legal but generally, if not universally, + -- a bad idea. + assert' "too many quotes 1" (Tuple """"""""" " == Tuple "\"\"" " ") + assert' "too many quotes 2" (Tuple """""""""" == Tuple "\"\"" "") + assert' "too many quotes 3" (Tuple """x"""""" " == Tuple "x\"\"" " ") + assert' "too many quotes 4" (Tuple """x""""""" == Tuple "x\"\"" "") + log "Done" From b90bbc2d6328bcd61c53c72cc4d7e1e3f3caff61 Mon Sep 17 00:00:00 2001 From: Cyril Date: Wed, 16 Dec 2020 04:08:47 +0100 Subject: [PATCH 1250/1580] Expand type synonyms in superclasses (#3966) * Expand type synonyms in superclasses * fixup! Expand type synonyms in superclasses --- src/Language/PureScript/TypeChecker.hs | 15 +++++++++------ .../purs/passing/TypeSynonymInSuperClass.purs | 18 ++++++++++++++++++ 2 files changed, 27 insertions(+), 6 deletions(-) create mode 100644 tests/purs/passing/TypeSynonymInSuperClass.purs diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 14e4951b78..a703f9cbc2 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -151,8 +151,8 @@ addTypeClass -> m () addTypeClass _ qualifiedClassName args implies dependencies ds kind = do env <- getEnv - let newClass = mkNewClass env - qualName = fmap coerceProperName qualifiedClassName + newClass <- mkNewClass + let qualName = fmap coerceProperName qualifiedClassName hasSig = qualName `M.member` types env unless (hasSig || not (containsForAll kind)) $ do tell . errorMessage $ MissingKindDeclaration ClassSig (disqualify qualName) kind @@ -163,11 +163,14 @@ addTypeClass _ qualifiedClassName args implies dependencies ds kind = do classMembers :: [(Ident, SourceType)] classMembers = map toPair ds - mkNewClass :: Environment -> TypeClassData - mkNewClass env = makeTypeClassData args classMembers implies dependencies ctIsEmpty + mkNewClass :: m TypeClassData + mkNewClass = do + env <- getEnv + implies' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms implies + let ctIsEmpty = null classMembers && all (typeClassIsEmpty . findSuperClass env) implies' + pure $ makeTypeClassData args classMembers implies' dependencies ctIsEmpty where - ctIsEmpty = null classMembers && all (typeClassIsEmpty . findSuperClass) implies - findSuperClass c = case M.lookup (constraintClass c) (typeClasses env) of + findSuperClass env c = case M.lookup (constraintClass c) (typeClasses env) of Just tcd -> tcd Nothing -> internalError "Unknown super class in TypeClassDeclaration" diff --git a/tests/purs/passing/TypeSynonymInSuperClass.purs b/tests/purs/passing/TypeSynonymInSuperClass.purs new file mode 100644 index 0000000000..7b23d8e969 --- /dev/null +++ b/tests/purs/passing/TypeSynonymInSuperClass.purs @@ -0,0 +1,18 @@ +module Main where + +import Prelude +import Effect.Console (log) + +type Env = { foo :: String } + +class Monad m <= MonadAsk r m | m -> r where + ask :: m r + +class (Monad m, MonadAsk Env m) <= MonadAskEnv m + +test :: forall m. MonadAskEnv m => m Boolean +test = do + { foo } <- ask + pure (foo == "test") + +main = log "Done" From ace2bab92379e776477c78b70323bcc131865d19 Mon Sep 17 00:00:00 2001 From: Cyril Date: Wed, 16 Dec 2020 04:09:52 +0100 Subject: [PATCH 1251/1580] Expand type synonyms in instances dictionaries (#3965) * Expand type synonyms in instances dictionaries * Expand type synonyms in derived newtype instances dictionaries * fixup! Expand type synonyms in instances dictionaries --- src/Language/PureScript/Sugar.hs | 30 ++++++++++++- src/Language/PureScript/Sugar/TypeClasses.hs | 45 ++++++++++++------- .../PureScript/Sugar/TypeClasses/Deriving.hs | 29 ++++-------- tests/purs/passing/TypeSynonymInstance2.purs | 14 ++++++ tests/purs/passing/TypeSynonymInstance3.purs | 23 ++++++++++ tests/purs/passing/TypeSynonymInstance4.purs | 13 ++++++ tests/purs/passing/TypeSynonymInstance5.purs | 13 ++++++ 7 files changed, 127 insertions(+), 40 deletions(-) create mode 100644 tests/purs/passing/TypeSynonymInstance2.purs create mode 100644 tests/purs/passing/TypeSynonymInstance3.purs create mode 100644 tests/purs/passing/TypeSynonymInstance4.purs create mode 100644 tests/purs/passing/TypeSynonymInstance5.purs diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index bacc90ced9..8a41fa7481 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -3,17 +3,23 @@ -- module Language.PureScript.Sugar (desugar, module S) where +import Prelude + import Control.Category ((>>>)) import Control.Monad import Control.Monad.Error.Class (MonadError) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.State.Class (MonadState) import Control.Monad.Writer.Class (MonadWriter) +import Data.Maybe (mapMaybe) + +import qualified Data.Map as M import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Externs import Language.PureScript.Linter.Imports +import Language.PureScript.Names import Language.PureScript.Sugar.BindingGroups as S import Language.PureScript.Sugar.CaseDeclarations as S import Language.PureScript.Sugar.DoNotation as S @@ -25,6 +31,7 @@ import Language.PureScript.Sugar.Operators as S import Language.PureScript.Sugar.TypeClasses as S import Language.PureScript.Sugar.TypeClasses.Deriving as S import Language.PureScript.Sugar.TypeDeclarations as S +import Language.PureScript.TypeChecker.Synonyms (SynonymMap) -- | -- The desugaring pipeline proceeds as follows: @@ -70,6 +77,25 @@ desugar externs = >=> desugarImports >=> rebracket externs >=> checkFixityExports - >=> deriveInstances externs - >=> desugarTypeClasses externs + >=> (\m -> + -- We need to collect type synonym information, since synonyms will not be + -- removed until later, during type checking. + let syns = findTypeSynonyms externs (getModuleName m) $ getModuleDeclarations m + -- We cannot prevent ill-kinded expansions of type synonyms without + -- knowing their kinds but they're not available yet. + kinds = mempty + in deriveInstances externs syns kinds m + >>= desugarTypeClasses externs syns kinds) >=> createBindingGroupsModule + +findTypeSynonyms :: [ExternsFile] -> ModuleName -> [Declaration] -> SynonymMap +findTypeSynonyms externs mn decls = + M.fromList $ (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) + ++ mapMaybe fromLocalDecl decls + where + fromExternsDecl mn' (EDTypeSynonym name args ty) = Just (Qualified (Just mn') name, (args, ty)) + fromExternsDecl _ _ = Nothing + + fromLocalDecl (TypeSynonymDeclaration _ name args ty) = + Just (Qualified (Just mn) name, (args, ty)) + fromLocalDecl _ = Nothing diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 2d67d21b3f..ea7047491a 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -21,6 +21,7 @@ import Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe) import qualified Data.List.NonEmpty as NEL import qualified Data.Set as S import Data.Text (Text) +import Data.Traversable (for) import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.Crash import Language.PureScript.Environment @@ -30,8 +31,9 @@ import Language.PureScript.Label (Label(..)) import Language.PureScript.Names import Language.PureScript.PSString (mkString) import Language.PureScript.Sugar.CaseDeclarations -import Language.PureScript.Types +import Language.PureScript.TypeChecker.Synonyms (SynonymMap, KindMap, replaceAllTypeSynonymsM) import Language.PureScript.TypeClassDictionaries (superclassName) +import Language.PureScript.Types type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData @@ -44,9 +46,11 @@ type Desugar = StateT MemberMap desugarTypeClasses :: (MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] + -> SynonymMap + -> KindMap -> Module -> m Module -desugarTypeClasses externs = flip evalStateT initialState . desugarModule +desugarTypeClasses externs syns kinds = flip evalStateT initialState . desugarModule syns kinds where initialState :: MemberMap initialState = @@ -70,13 +74,15 @@ desugarTypeClasses externs = flip evalStateT initialState . desugarModule desugarModule :: (MonadSupply m, MonadError MultipleErrors m) - => Module + => SynonymMap + -> KindMap + -> Module -> Desugar m Module -desugarModule (Module ss coms name decls (Just exps)) = do +desugarModule syns kinds (Module ss coms name decls (Just exps)) = do let (classDecls, restDecls) = partition isTypeClassDecl decls classVerts = fmap (\d -> (d, classDeclName d, superClassesNames d)) classDecls (classNewExpss, classDeclss) <- unzip <$> parU (stronglyConnComp classVerts) (desugarClassDecl name exps) - (restNewExpss, restDeclss) <- unzip <$> parU restDecls (desugarDecl name exps) + (restNewExpss, restDeclss) <- unzip <$> parU restDecls (desugarDecl syns kinds name exps) return $ Module ss coms name (concat restDeclss ++ concat classDeclss) $ Just (exps ++ catMaybes restNewExpss ++ catMaybes classNewExpss) where desugarClassDecl :: (MonadSupply m, MonadError MultipleErrors m) @@ -84,7 +90,7 @@ desugarModule (Module ss coms name decls (Just exps)) = do -> [DeclarationRef] -> SCC Declaration -> Desugar m (Maybe DeclarationRef, [Declaration]) - desugarClassDecl name' exps' (AcyclicSCC d) = desugarDecl name' exps' d + desugarClassDecl name' exps' (AcyclicSCC d) = desugarDecl syns kinds name' exps' d desugarClassDecl _ _ (CyclicSCC ds') = throwError . errorMessage' (declSourceSpan (head ds')) $ CycleInTypeClassDeclaration (map classDeclName ds') superClassesNames :: Declaration -> [Qualified (ProperName 'ClassName)] @@ -98,7 +104,7 @@ desugarModule (Module ss coms name decls (Just exps)) = do classDeclName (TypeClassDeclaration _ pn _ _ _ _) = Qualified (Just name) pn classDeclName _ = internalError "Expected TypeClassDeclaration" -desugarModule _ = internalError "Exports should have been elaborated in name desugaring" +desugarModule _ _ _ = internalError "Exports should have been elaborated in name desugaring" {- Desugar type class and type class instance declarations -- @@ -196,11 +202,13 @@ desugarModule _ = internalError "Exports should have been elaborated in name des -} desugarDecl :: (MonadSupply m, MonadError MultipleErrors m) - => ModuleName + => SynonymMap + -> KindMap + -> ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration]) -desugarDecl mn exps = go +desugarDecl syns kinds mn exps = go where go d@(TypeClassDeclaration sa name args implies deps members) = do modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False)) @@ -211,7 +219,7 @@ desugarDecl mn exps = go = throwError . errorMessage' (fst sa) $ InvalidCoercibleInstanceDeclaration tys | otherwise = do desugared <- desugarCases members - dictDecl <- typeInstanceDictionaryDeclaration sa name mn deps className tys desugared + dictDecl <- typeInstanceDictionaryDeclaration syns kinds sa name mn deps className tys desugared return (expRef name className tys, [d, dictDecl]) go d@(TypeInstanceDeclaration sa _ _ name deps className tys (NewtypeInstanceWithDictionary dict)) = do let dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictSynonymName) className)) tys @@ -292,7 +300,9 @@ unit = srcTypeApp tyRecord srcREmpty typeInstanceDictionaryDeclaration :: forall m . (MonadSupply m, MonadError MultipleErrors m) - => SourceAnn + => SynonymMap + -> KindMap + -> SourceAnn -> Ident -> ModuleName -> [SourceConstraint] @@ -300,7 +310,7 @@ typeInstanceDictionaryDeclaration -> [SourceType] -> [Declaration] -> Desugar m Declaration -typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = +typeInstanceDictionaryDeclaration syns kinds sa@(ss, _) name mn deps className tys decls = rethrow (addHint (ErrorInInstance className tys)) $ do m <- get @@ -323,11 +333,12 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = -- Create the type of the dictionary -- The type is a record type, but depending on type instance dependencies, may be constrained. -- The dictionary itself is a record literal. - let superclasses = superClassDictionaryNames typeClassSuperclasses `zip` - [ Abs (VarBinder ss UnusedIdent) (DeferredDictionary superclass tyArgs) - | (Constraint _ superclass _ suTyArgs _) <- typeClassSuperclasses - , let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs - ] + tys' <- traverse (replaceAllTypeSynonymsM syns kinds) tys + superclassesDicts <- for typeClassSuperclasses $ \(Constraint _ superclass _ suTyArgs _) -> do + suTyArgs' <- traverse (replaceAllTypeSynonymsM syns kinds) suTyArgs + let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys')) suTyArgs' + pure $ Abs (VarBinder ss UnusedIdent) (DeferredDictionary superclass tyArgs) + let superclasses = superClassDictionaryNames typeClassSuperclasses `zip` superclassesDicts let props = Literal ss $ ObjectLiteral $ map (first mkString) (members ++ superclasses) dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictSynonymName) className)) tys diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 549f06efad..f23a84becb 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -12,7 +12,7 @@ import Control.Monad.Supply.Class (MonadSupply) import Data.Foldable (for_) import Data.List (foldl', find, sortBy, unzip5) import qualified Data.Map as M -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe) import Data.Ord (comparing) import qualified Data.Set as S import Data.Text (Text) @@ -71,28 +71,13 @@ deriveInstances :: forall m . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) => [ExternsFile] + -> SynonymMap + -> KindMap -> Module -> m Module -deriveInstances externs (Module ss coms mn ds exts) = - Module ss coms mn <$> mapM (deriveInstance mn synonyms kinds instanceData ds) ds <*> pure exts +deriveInstances externs syns kinds (Module ss coms mn ds exts) = + Module ss coms mn <$> mapM (deriveInstance mn syns kinds instanceData ds) ds <*> pure exts where - kinds :: KindMap - kinds = mempty - - -- We need to collect type synonym information, since synonyms will not be - -- removed until later, during type checking. - synonyms :: SynonymMap - synonyms = - M.fromList $ (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) - ++ mapMaybe fromLocalDecl ds - where - fromExternsDecl mn' (EDTypeSynonym name args ty) = Just (Qualified (Just mn') name, (args, ty)) - fromExternsDecl _ _ = Nothing - - fromLocalDecl (TypeSynonymDeclaration _ name args ty) = - Just (Qualified (Just mn) name, (args, ty)) - fromLocalDecl _ = Nothing - instanceData :: NewtypeDerivedInstances instanceData = foldMap (\ExternsFile{..} -> foldMap (fromExternsDecl efModuleName) efDeclarations) externs <> foldMap fromLocalDecl ds @@ -226,7 +211,9 @@ deriveNewtypeInstance ss mn syns kinds ndis className ds tys tyConNm dargs = do case stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped' of Just wrapped'' -> do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs - return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped''])) + wrapped''' <- replaceAllTypeSynonymsM syns kinds $ replaceAllTypeVars subst wrapped'' + tys' <- mapM (replaceAllTypeSynonymsM syns kinds) tys + return (DeferredDictionary className (init tys' ++ [wrapped'''])) Nothing -> throwError . errorMessage' ss $ InvalidNewtypeInstance className tys go _ = throwError . errorMessage' ss $ InvalidNewtypeInstance className tys diff --git a/tests/purs/passing/TypeSynonymInstance2.purs b/tests/purs/passing/TypeSynonymInstance2.purs new file mode 100644 index 0000000000..0f16f74642 --- /dev/null +++ b/tests/purs/passing/TypeSynonymInstance2.purs @@ -0,0 +1,14 @@ +module Main where + +import Effect.Console (log) + +data D +type S = D + +class C0 a +class C0 a <= C1 a + +instance c0 :: C0 D +instance c1 :: C1 S + +main = log "Done" diff --git a/tests/purs/passing/TypeSynonymInstance3.purs b/tests/purs/passing/TypeSynonymInstance3.purs new file mode 100644 index 0000000000..874cf0bbf7 --- /dev/null +++ b/tests/purs/passing/TypeSynonymInstance3.purs @@ -0,0 +1,23 @@ +module Main where + +import Effect.Console (log) + +data Cons a b +infix 6 type Cons as :* + +data D2 +data D5 +data D6 +data D8 + +type D256 = D2 :* (D5 :* D6) + +class LtEq a b + +instance ltEqD8D256 :: LtEq D8 D256 + +class (LtEq a D256) <= Lte256 a + +instance lte256 :: Lte256 D8 + +main = log "Done" diff --git a/tests/purs/passing/TypeSynonymInstance4.purs b/tests/purs/passing/TypeSynonymInstance4.purs new file mode 100644 index 0000000000..829db5f7ba --- /dev/null +++ b/tests/purs/passing/TypeSynonymInstance4.purs @@ -0,0 +1,13 @@ +module Main where + +import Effect.Console (log) + +data D +type S = D +newtype N a = N a + +class C a + +derive newtype instance c :: C S => C (N S) + +main = log "Done" diff --git a/tests/purs/passing/TypeSynonymInstance5.purs b/tests/purs/passing/TypeSynonymInstance5.purs new file mode 100644 index 0000000000..e9f7ae766b --- /dev/null +++ b/tests/purs/passing/TypeSynonymInstance5.purs @@ -0,0 +1,13 @@ +module Main where + +import Effect.Console (log) + +data D +type S = D +newtype N a = N a + +class C a b + +derive newtype instance c :: C S a => C S (N a) + +main = log "Done" From 3dfb10635d89c457fcd79e89267d95a660465cb5 Mon Sep 17 00:00:00 2001 From: Cyril Date: Sat, 19 Dec 2020 09:43:40 +0100 Subject: [PATCH 1252/1580] Interaction solver for Coercible constraints (#3955) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Interaction solver for `Coercible` constraints * Don’t fail to lookup re-exported newtype constructors * fixup! Don’t fail to lookup re-exported newtype constructors --- src/Language/PureScript/Docs/Prim.hs | 23 +- src/Language/PureScript/Errors.hs | 8 + src/Language/PureScript/Make.hs | 3 +- src/Language/PureScript/TypeChecker.hs | 31 +- .../PureScript/TypeChecker/Entailment.hs | 161 +-- .../TypeChecker/Entailment/Coercible.hs | 923 ++++++++++++++++++ src/Language/PureScript/TypeChecker/Kinds.hs | 2 + src/Language/PureScript/TypeChecker/Monad.hs | 14 +- .../failing/CoercibleClosedRowsDoNotUnify.out | 8 +- tests/purs/failing/CoercibleConstrained1.out | 5 + tests/purs/failing/CoercibleConstrained2.out | 20 +- tests/purs/failing/CoercibleConstrained2.purs | 2 +- tests/purs/failing/CoercibleConstrained3.out | 20 +- tests/purs/failing/CoercibleConstrained3.purs | 2 +- tests/purs/failing/CoercibleForeign.out | 20 +- tests/purs/failing/CoercibleForeign.purs | 2 +- tests/purs/failing/CoercibleForeign2.out | 20 +- tests/purs/failing/CoercibleForeign2.purs | 2 +- tests/purs/failing/CoercibleForeign3.out | 20 +- tests/purs/failing/CoercibleForeign3.purs | 2 +- .../failing/CoercibleHigherKindedData.out | 5 + .../failing/CoercibleHigherKindedNewtypes.out | 17 +- tests/purs/failing/CoercibleKindMismatch.out | 8 +- tests/purs/failing/CoercibleNominal.out | 20 +- tests/purs/failing/CoercibleNominal.purs | 2 +- .../purs/failing/CoercibleNominalTypeApp.out | 20 +- .../purs/failing/CoercibleNominalTypeApp.purs | 2 +- .../purs/failing/CoercibleNominalWrapped.out | 20 +- .../purs/failing/CoercibleNominalWrapped.purs | 2 +- tests/purs/failing/CoercibleNonCanonical1.out | 27 + .../purs/failing/CoercibleNonCanonical1.purs | 11 + tests/purs/failing/CoercibleNonCanonical2.out | 24 + .../purs/failing/CoercibleNonCanonical2.purs | 10 + .../failing/CoercibleOpenRowsDoNotUnify.out | 12 +- .../failing/CoercibleRepresentational.out | 5 + .../failing/CoercibleRepresentational2.out | 5 + .../failing/CoercibleRepresentational3.out | 5 + .../failing/CoercibleRepresentational4.out | 5 + .../failing/CoercibleRepresentational5.out | 5 + .../failing/CoercibleRepresentational8.out | 24 + .../failing/CoercibleRepresentational8.purs | 9 + .../UnsafeCoerce.purs | 7 + .../PossiblyInfiniteCoercibleInstance.out | 25 + .../PossiblyInfiniteCoercibleInstance.purs | 9 + tests/purs/passing/Coercible.purs | 63 +- tests/purs/passing/Coercible/Lib.purs | 11 +- tests/purs/passing/Coercible/Lib2.purs | 3 + 47 files changed, 1396 insertions(+), 248 deletions(-) create mode 100644 src/Language/PureScript/TypeChecker/Entailment/Coercible.hs create mode 100644 tests/purs/failing/CoercibleNonCanonical1.out create mode 100644 tests/purs/failing/CoercibleNonCanonical1.purs create mode 100644 tests/purs/failing/CoercibleNonCanonical2.out create mode 100644 tests/purs/failing/CoercibleNonCanonical2.purs create mode 100644 tests/purs/failing/CoercibleRepresentational8.out create mode 100644 tests/purs/failing/CoercibleRepresentational8.purs create mode 100644 tests/purs/failing/CoercibleRepresentational8/UnsafeCoerce.purs create mode 100644 tests/purs/failing/PossiblyInfiniteCoercibleInstance.out create mode 100644 tests/purs/failing/PossiblyInfiniteCoercibleInstance.purs create mode 100644 tests/purs/passing/Coercible/Lib2.purs diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 4f9f42cc9a..f46421228b 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -390,7 +390,13 @@ coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines , "" , " instance coercibleSymmetric :: Coercible a b => Coercible b a" , "" - , "Third, for every type constructor there is an instance that allows one" + , "Third, Coercible obeys transitivity - if a type `a` can be coerced to some" + , "other type `b` which can be coerced to some other type `c`, then `a` can" + , "also be coerced to `c`:" + , "" + , " instance coercibleTransitive :: (Coercible a b, Coercible b c) => Coercible a c" + , "" + , "Fourth, for every type constructor there is an instance that allows one" , "to coerce under the type constructor (`data` or `newtype`). For example," , "given a definition:" , "" @@ -406,16 +412,16 @@ coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines , "such as `b` is thus typically referred to as a \"phantom\" type), `b` and `b'`" , "can differ arbitrarily." , "" - , "Fourth, for every `newtype NT = MkNT T`, there is a pair of instances which" + , "Fifth, for every `newtype NT = MkNT T`, there is a pair of instances which" , "permit coercion in and out of the `newtype`:" , "" , " instance coercibleNewtypeLeft :: Coercible a T => Coercible a NT" , " instance coercibleNewtypeRight :: Coercible T b => Coercible NT b" , "" , "To prevent breaking abstractions, these instances are only usable if the" - , "constructor `MkNT` is exported." + , "constructor `MkNT` is in scope." , "" - , "Fifth, every pair of unsaturated type constructors can be coerced if" + , "Sixth, every pair of unsaturated type constructors can be coerced if" , "there is an instance for the fully saturated types. For example," , "given the definitions:" , "" @@ -429,13 +435,12 @@ coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines , "This rule may seem puzzling since it is impossible to apply `coerce` to a term" , "of type `NT1` but it is necessary to coerce types with higher kinded parameters." , "" - , "Fifth, every pair of rows can be coerced if they have the same labels" - , "and the corresponding types for each label are coercible:" + , "Seventh, every pair of rows can be coerced if they have the same labels," + , "the corresponding types for each label and their tails are coercible:" , "" - , " instance coercibleRow :: Coercible a b => Coercible ( label :: a ) ( label :: b )" + , " instance coercibleRow :: (Coercible a b, Coercible r s) => Coercible ( label :: a | r ) ( label :: b | s )" , "" - , "Closed rows can't be coerced to open rows and open rows can only be" - , "coerced to open rows with the same row variable." + , "Closed rows can't be coerced to open rows." ] kindOrdering :: Declaration diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index c99f043734..10cb7349ed 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -107,6 +107,7 @@ data SimpleErrorMessage | AmbiguousTypeVariables SourceType [Int] | UnknownClass (Qualified (ProperName 'ClassName)) | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [SourceType] + | PossiblyInfiniteCoercibleInstance | CannotDerive (Qualified (ProperName 'ClassName)) [SourceType] | InvalidDerivedInstance (Qualified (ProperName 'ClassName)) [SourceType] Int | ExpectedTypeConstructor (Qualified (ProperName 'ClassName)) [SourceType] SourceType @@ -276,6 +277,7 @@ errorCode em = case unwrapErrorMessage em of AmbiguousTypeVariables{} -> "AmbiguousTypeVariables" UnknownClass{} -> "UnknownClass" PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance" + PossiblyInfiniteCoercibleInstance -> "PossiblyInfiniteCoercibleInstance" CannotDerive{} -> "CannotDerive" InvalidNewtypeInstance{} -> "InvalidNewtypeInstance" MissingNewtypeSuperclassInstance{} -> "MissingNewtypeSuperclassInstance" @@ -911,6 +913,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] , line "is possibly infinite." ] + renderSimpleErrorMessage PossiblyInfiniteCoercibleInstance = + line $ "A " <> markCode "Coercible" <> " instance is possibly infinite." renderSimpleErrorMessage (CannotDerive nm ts) = paras [ line "Cannot derive a type class instance for" , markCodeBox $ indent $ Box.hsep 1 Box.left @@ -1615,6 +1619,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl where isUnifyHint ErrorUnifyingTypes{} = True isUnifyHint _ = False + stripRedundantHints (NoInstanceFound (Constraint _ C.Coercible _ args _)) = stripFirst isSolverHint + where + isSolverHint (ErrorSolvingConstraint (Constraint _ C.Coercible _ args' _)) = args == args' + isSolverHint _ = False stripRedundantHints NoInstanceFound{} = stripFirst isSolverHint where isSolverHint ErrorSolvingConstraint{} = True diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index afd446a133..f7dd132bbe 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -79,7 +79,8 @@ rebuildModule' MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) = do ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do (desugared, (exEnv', usedImports)) <- runStateT (desugar externs withPrim) (exEnv, mempty) - (checked, CheckState{..}) <- runStateT (typeCheckModule desugared) $ emptyCheckState env + let modulesExports = (\(_, _, exports) -> exports) <$> exEnv' + (checked, CheckState{..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env let usedImports' = foldl' (flip $ \(fromModuleName, newtypeCtorName) -> M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName) usedImports checkCoercedNewtypeCtorsImports -- Imports cannot be linted before type checking because we need to diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index a703f9cbc2..a540152a23 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -37,6 +37,7 @@ import Language.PureScript.Errors import Language.PureScript.Linter import Language.PureScript.Names import Language.PureScript.Roles +import Language.PureScript.Sugar.Names.Env (Exports(..)) import Language.PureScript.TypeChecker.Kinds as T import Language.PureScript.TypeChecker.Monad as T import Language.PureScript.TypeChecker.Roles as T @@ -596,11 +597,12 @@ checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name typeCheckModule :: forall m . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => Module + => M.Map ModuleName Exports + -> Module -> m Module -typeCheckModule (Module _ _ _ _ Nothing) = +typeCheckModule _ (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated before typeCheckModule" -typeCheckModule (Module ss coms mn decls (Just exps)) = +typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do let (decls', imports) = partitionEithers $ fromImportDecl <$> decls modify (\s -> s { checkCurrentModule = Just mn, checkCurrentModuleImports = imports }) @@ -615,13 +617,28 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = return $ Module ss coms mn (map toImportDecl imports ++ decls'') (Just exps) where - fromImportDecl :: Declaration -> Either Declaration (SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName) + fromImportDecl + :: Declaration + -> Either Declaration + ( SourceAnn + , ModuleName + , ImportDeclarationType + , Maybe ModuleName + , M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource) + ) fromImportDecl (ImportDeclaration sa moduleName importDeclarationType asModuleName) = - Right (sa, moduleName, importDeclarationType, asModuleName) + Right (sa, moduleName, importDeclarationType, asModuleName, foldMap exportedTypes $ M.lookup moduleName modulesExports) fromImportDecl decl = Left decl - toImportDecl :: (SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName) -> Declaration - toImportDecl (sa, moduleName, importDeclarationType, asModuleName) = + toImportDecl + :: ( SourceAnn + , ModuleName + , ImportDeclarationType + , Maybe ModuleName + , M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource) + ) + -> Declaration + toImportDecl (sa, moduleName, importDeclarationType, asModuleName, _) = ImportDeclaration sa moduleName importDeclarationType asModuleName qualify' :: a -> Qualified a diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index cc25ac8473..ca63876a96 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -14,19 +14,17 @@ module Language.PureScript.TypeChecker.Entailment import Prelude.Compat import Protolude (ordNub) -import Control.Applicative ((<|>), empty) import Control.Arrow (second, (&&&)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State import Control.Monad.Supply.Class (MonadSupply(..)) -import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Writer -import Data.Foldable (for_, fold, foldl', toList) +import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.Functor (($>)) -import Data.List (find, groupBy, minimumBy, nubBy, sortBy, zipWith4) -import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.List (minimumBy, groupBy, nubBy, sortBy) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S import Data.Traversable (for) @@ -39,11 +37,9 @@ import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Names -import Language.PureScript.Roles +import Language.PureScript.TypeChecker.Entailment.Coercible import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds) import Language.PureScript.TypeChecker.Monad -import Language.PureScript.TypeChecker.Roles -import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types @@ -391,143 +387,24 @@ entails SolverOptions{..} constraint context hints = App (Accessor (mkString (superclassName className index)) dict) valUndefined solveCoercible :: Environment -> InstanceContext -> [SourceType] -> [SourceType] -> m (Maybe [TypeClassDict]) - solveCoercible env ctx kinds [a, b] = runMaybeT $ do - let kindOf = lift . (sequence . (id &&& elaborateKind)) <=< replaceAllTypeSynonyms - (a', kind) <- kindOf a - (b', kind') <- kindOf b - lift $ unifyKinds kind kind' - -- Solving terminates when the two arguments are the same or if a - -- dictionary for a symmetric constraint is already in scope. - -- Since we currently don't support higher-rank arguments in instance - -- heads, term equality is a sufficient notion of "the same". + solveCoercible env ctx kinds [a, b] = do let coercibleDictsInScope = findDicts ctx C.Coercible Nothing - if a' == b' || any (isSymmetricCoercibleDictInScope a' b') coercibleDictsInScope - then pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] Nothing] - else do - -- When solving must reduce and recurse, it doesn't matter whether we - -- reduce the first or second argument -- if the constraint is - -- solvable, either path will yield the same outcome. Consequently we - -- just try the first argument first and the second argument second. - ws <- (MaybeT $ coercibleWanteds env a' b') <|> (MaybeT $ coercibleWanteds env b' a') - pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] (Just ws)] + givens = flip mapMaybe coercibleDictsInScope $ \case + dict | [a', b'] <- tcdInstanceTypes dict -> Just (a', b') + | otherwise -> Nothing + GivenSolverState{ inertGivens } <- execStateT (solveGivens env) $ + initialGivenSolverState givens + WantedSolverState{ inertWanteds } <- execStateT (solveWanteds env) $ + initialWantedSolverState inertGivens a b + case inertWanteds of + [] -> pure $ Just [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] Nothing] + -- Solving fails when there's irreducible wanteds left. We report the + -- first residual constraint instead of the initial wanted, unless we + -- just swapped its arguments. + (k, a', b') : _ | a' == b && b' == a -> throwError $ insoluble k b' a' + (k, a', b') : _ -> throwError $ insoluble k a' b' solveCoercible _ _ _ _ = pure Nothing - isSymmetricCoercibleDictInScope a b TypeClassDictionaryInScope{..} = tcdInstanceTypes == [b, a] - - -- | Take two types, @a@ and @b@ representing a desired constraint - -- @Coercible a b@ and reduce them to a set of simpler wanted constraints - -- whose satisfaction will yield the goal. - coercibleWanteds :: Environment -> SourceType -> SourceType -> m (Maybe [SourceConstraint]) - coercibleWanteds env a b - | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a - , (aTyKind, _) <- fromMaybe (internalError "coercibleWanteds: type lookup failed") $ M.lookup aTyName (types env) - , (aks, kind) <- unapplyKinds aTyKind - , length axs < length aks = do - -- If both arguments have kind @k1 -> k2@ (e.g. @data D a b = D a@ - -- in the constraint @Coercible (D a) (D a')@), yield a new wanted - -- constraint in terms of the types saturated with the same variables - -- (e.g. @Coercible (D a t0) (D a' t0)@ in the exemple). - tys <- traverse freshTypeWithKind $ drop (length axs) aks - let a' = foldl' srcTypeApp a tys - b' = foldl' srcTypeApp b tys - pure $ Just [srcCoercibleConstraint kind a' b'] - -- If both arguments have kind @Row k@, yield new wanted constraints - -- in terms of pairs of types with the same label in both rows (e.g. - -- @Coercible D D'@ given @Coercible ( label :: D ) ( label :: D' )@) - -- and fail when some labels are exclusive to one row (e.g. @extra@ - -- in the constraint @Coercible () ( extra :: D )@) or when the tails - -- don’t unify (e.g. @()@ and @r@ in @Coercible () ( | r )@ or - -- @r@ and @s@ in @Coercible ( | r ) ( | s )@). - | RCons _ _ ty _ <- a = do - k <- elaborateKind ty - case alignRowsWith (srcCoercibleConstraint k) a b of - (constraints, (([], tail1), ([], tail2))) -> do - rethrow (const . errorMessage . NoInstanceFound $ srcCoercibleConstraint (kindRow k) a b) $ unifyTypes tail1 tail2 - pure $ Just constraints - (_, (rl1, rl2)) -> - throwError . errorMessage $ TypesDoNotUnify (rowFromList rl1) (rowFromList rl2) - | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a - , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b - , not (null axs) && aTyName == bTyName - , (aTyKind, _) <- fromMaybe (internalError "coercibleWanteds: type lookup failed") $ M.lookup aTyName (types env) - = runMaybeT $ do - -- If both arguments are applications of the same type constructor - -- (e.g. @data D a b = D a@ in the constraint - -- @Coercible (D a b) (D a' b')@), infer the roles of the type - -- constructor's arguments and generate wanted constraints - -- appropriately (e.g. here @a@ is representational and @b@ is - -- phantom, yielding @Coercible a a'@). - let roles = lookupRoles env aTyName - kinds = fst $ unapplyKinds aTyKind - f role kx ax bx = case role of - Nominal - -- If we had first-class equality constraints, we'd just - -- emit one of the form @(a ~ b)@ here and let the solver - -- recurse. Since we don't we must compare the types at - -- this point and fail if they don't match. This likely - -- means there are cases we should be able to handle that - -- we currently can't, but is at least sound. - | ax == bx -> - pure [] - | otherwise -> - empty - Representational -> - pure [srcCoercibleConstraint kx ax bx] - Phantom -> - pure [] - fmap concat $ sequence $ zipWith4 f roles kinds axs bxs - | (TypeConstructor _ newtypeName, _, xs) <- unapplyTypes a = do - (currentModuleName, currentModuleImports) <- gets $ checkCurrentModule &&& checkCurrentModuleImports - case lookupNewtypeConstructor env currentModuleName currentModuleImports newtypeName of - Just (fromModuleName, newtypeCtorName, tvs, wrappedTy, _) -> do - for_ fromModuleName $ flip insertCoercedNewtypeCtorImport newtypeCtorName - -- If the first argument is a newtype applied to some other types - -- (e.g. @newtype T a = T a@ in @Coercible (T X) b@), look up the - -- type of its wrapped field and yield a new wanted constraint in - -- terms of that type with the type arguments substituted in (e.g. - -- @Coercible (T[X/a]) b = Coercible X b@ in the example). - let wrappedTySub = replaceAllTypeVars (zip tvs xs) wrappedTy - pure $ Just [srcCoercibleConstraint kindType wrappedTySub b] - _ -> pure Nothing - | otherwise = - -- In all other cases we can't solve the constraint. - pure Nothing - - srcCoercibleConstraint :: SourceType -> SourceType -> SourceType -> SourceConstraint - srcCoercibleConstraint k a b = srcConstraint C.Coercible [k] [a, b] Nothing - - -- | Looks up a given name and, if it names a newtype, returns the names of the - -- type's parameters, the type the newtype wraps and the names of the type's - -- fields. - lookupNewtypeConstructor - :: Environment - -> Maybe ModuleName - -> [(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName)] - -> Qualified (ProperName 'TypeName) - -> Maybe (Maybe ModuleName, Qualified (ProperName 'ConstructorName), [Text], SourceType, [Ident]) - lookupNewtypeConstructor env currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName) = do - let fromModule = find isNewtypeCtorInScope currentModuleImports - fromModuleName = (\(_, n, _, _) -> n) <$> fromModule - asModuleName = (\(_, _, _, n) -> n) =<< fromModule - guard $ newtypeModuleName == currentModuleName || isJust fromModule - (_, DataType tvs [(ctorName, [wrappedTy])]) <- M.lookup qualifiedNewtypeName (types env) - (Newtype, _, _, ids) <- M.lookup (Qualified newtypeModuleName ctorName) (dataConstructors env) - pure (fromModuleName, Qualified asModuleName ctorName, map (\(name, _, _) -> name) tvs, wrappedTy, ids) - where - isNewtypeCtorInScope (_, fromModuleName, importDeclType, _) = - newtypeModuleName == Just fromModuleName && case importDeclType of - Implicit -> True - Explicit refs -> any isNewtypeCtorRef refs - Hiding refs -> not $ any isNewtypeCtorRef refs - isNewtypeCtorRef = \case - TypeRef _ importedTyName Nothing -> importedTyName == newtypeName - TypeRef _ importedTyName (Just [_]) -> importedTyName == newtypeName - _ -> False - - insertCoercedNewtypeCtorImport :: MonadState CheckState m => ModuleName -> Qualified (ProperName 'ConstructorName) -> m () - insertCoercedNewtypeCtorImport fromModuleName newtypeCtor = modify $ \s -> - s { checkCoercedNewtypeCtorsImports = S.insert (fromModuleName, newtypeCtor) $ checkCoercedNewtypeCtorsImports s } - solveIsSymbol :: [SourceType] -> Maybe [TypeClassDict] solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope [] 0 (IsSymbolInstance sym) [] C.IsSymbol [] [] [TypeLevelString ann sym] Nothing] solveIsSymbol _ = Nothing diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs new file mode 100644 index 0000000000..3202b4f9ce --- /dev/null +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -0,0 +1,923 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +-- | +-- Interaction solver for Coercible constraints +-- +module Language.PureScript.TypeChecker.Entailment.Coercible + ( GivenSolverState(..) + , initialGivenSolverState + , solveGivens + , WantedSolverState(..) + , initialWantedSolverState + , solveWanteds + , insoluble + ) where + +import Prelude.Compat hiding (interact) + +import Control.Applicative ((<|>), empty) +import Control.Arrow ((&&&)) +import Control.Monad ((<=<), guard, when) +import Control.Monad.Error.Class (MonadError, catchError, throwError) +import Control.Monad.State (MonadState, StateT, get, gets, modify, put) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) +import Control.Monad.Writer.Strict (Writer, execWriter, runWriter, tell) +import Data.Either (partitionEithers) +import Data.Foldable (fold, foldl', for_, toList) +import Data.Functor (($>)) +import Data.List (find) +import Data.Maybe (fromMaybe, isJust) +import Data.Monoid (Any(..)) +import Data.Text (Text) + +import qualified Data.Map as M +import qualified Data.Set as S + +import Language.PureScript.Crash +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Names +import Language.PureScript.TypeChecker.Kinds hiding (kindOf) +import Language.PureScript.TypeChecker.Monad +import Language.PureScript.TypeChecker.Roles +import Language.PureScript.TypeChecker.Synonyms +import Language.PureScript.TypeChecker.Unify +import Language.PureScript.Roles +import Language.PureScript.Types +import qualified Language.PureScript.Constants.Prim as Prim + +-- | State of the given constraints solver. +data GivenSolverState = + GivenSolverState + { inertGivens :: [(SourceType, SourceType, SourceType)] + -- ^ A set of irreducible given constraints which do not interact together. + , unsolvedGivens :: [(SourceType, SourceType)] + -- ^ Given constraints yet to be solved. + } + +-- | Initialize the given constraints solver state with the givens to solve. +initialGivenSolverState :: [(SourceType, SourceType)] -> GivenSolverState +initialGivenSolverState = + GivenSolverState [] + +-- | The given constraints solver follows these steps: +-- +-- 1. Solving can diverge for recursive newtypes, so we check the solver depth +-- and abort if we crossed an arbitrary limit. +-- +-- For instance the declarations: +-- +-- @ +-- newtype N a = N (a -> N a) +-- +-- example :: forall a b. N a -> N b +-- example = coerce +-- @ +-- +-- yield the wanted @Coercible (N a) (N b)@ which we can unwrap on both sides +-- to yield @Coercible (a -> N a) (b -> N b)@, which we can then decompose back +-- to @Coercible a b@ and @Coercible (N a) (N b)@. +-- +-- 2. We pick a constraint from the unsolved queue. If the queue is empty we are +-- done, otherwise we unify the constraint arguments kinds and continue. +-- +-- 3. Then we try to canonicalize the constraint. + +-- 3a. Canonicalization can fail, in which case we swallow the error and pretend +-- the constraint is irreducible because it is possible to eventually solve it. +-- +-- For instance the declarations: +-- +-- @ +-- data D a = D a +-- type role D nominal +-- +-- example :: forall a b. Coercible (D a) (D b) => D a -> D b +-- example = coerce +-- @ +-- +-- yield an insoluble given @Coercible (D a) (D b)@ which discharges the wanted +-- constraint regardless, because the given can be solved if @a@ and @b@ turn +-- out to be equal: @example (D true) :: D Boolean@ should compile. +-- +-- 3b. Canonicalization can succeed with an irreducible constraint which we +-- then interact with the inert set. +-- +-- 3bi. These interactions can yield a derived constraint which we add to the +-- unsolved queue and then go back to 1. +-- +-- 3bii. These interactions can discharge the constraint, in which case we go +-- back to 1. +-- +-- 3biii The constraint may not react to the inert set, in which case we add it +-- to the inert set, kick out any constraint that can be rewritten by the new +-- inert, add them to the unsolved queue and then go back to 1. +-- +-- 3c. Otherwise canonicalization can succeed with derived constraints which we +-- add to the unsolved queue and then go back to 1. +solveGivens + :: MonadError MultipleErrors m + => MonadState CheckState m + => Environment + -> StateT GivenSolverState m () +solveGivens env = go (0 :: Int) where + go n = do + when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance + gets unsolvedGivens >>= \case + [] -> pure () + given : unsolved -> do + (k, a, b) <- lift $ unify given + GivenSolverState{..} <- get + lift (canon env Nothing k a b `catchError` recover) >>= \case + Irreducible -> case interact env (a, b) inertGivens of + Just (Simplified (a', b')) -> + put $ GivenSolverState { unsolvedGivens = (a', b') : unsolved, .. } + Just Discharged -> + put $ GivenSolverState { unsolvedGivens = unsolved, .. } + Nothing -> do + let (kickedOut, kept) = partitionEithers $ kicksOut env (a, b) <$> inertGivens + put $ GivenSolverState + { inertGivens = (k, a, b) : kept + , unsolvedGivens = kickedOut <> unsolved + } + Canonicalized deriveds -> + put $ GivenSolverState { unsolvedGivens = toList deriveds <> unsolved, .. } + go (n + 1) + recover _ = pure Irreducible + +-- | State of the wanted constraints solver. +data WantedSolverState = + WantedSolverState + { inertGivens :: [(SourceType, SourceType, SourceType)] + -- ^ A set of irreducible given constraints which do not interact together, + -- but which could interact with the wanteds. + , inertWanteds :: [(SourceType, SourceType, SourceType)] + -- ^ A set of irreducible wanted constraints which do not interact together, + -- nor with any given. + , unsolvedWanteds :: [(SourceType, SourceType)] + -- ^ Wanted constraints yet to be solved. + } + +-- | Initialize the wanted constraints solver state with an inert set of givens +-- and the two parameters of the wanted to solve. +initialWantedSolverState + :: [(SourceType, SourceType, SourceType)] + -> SourceType + -> SourceType + -> WantedSolverState +initialWantedSolverState givens a b = + WantedSolverState givens [] [(a, b)] + +-- | The wanted constraints solver follows similar steps than the given solver, +-- except for: +-- +-- 1. When canonicalization fails we can swallow the error, but only if the +-- wanted interacts with the givens. +-- +-- For instance the declarations: +-- +-- @ +-- data D a = D a +-- type role D nominal +-- +-- example :: forall a b. Coercible (D a) (D b) => D a -> D b +-- example = coerce +-- @ +-- +-- yield an insoluble wanted @Coercible (D a) (D b)@ which is discharged by +-- the given. But we want @example :: forall a b. D a -> D b@ to fail. +-- +-- 2. Irreducible wanted constraints don't interact with the inert wanteds set, +-- because doing so would yield confusing error messages. +-- +-- For instance the declarations: +-- +-- @ +-- data D a = D a +-- +-- example :: forall a. D a a -> D Boolean Char +-- example = coerce +-- @ +-- +-- yield the wanted @Coercible (D a a) (D Boolean Char)@, which is decomposed to +-- the irreducibles @Coercible a Boolean@ and @Coercible a Char@. Would we +-- interact the latter with the former, we would report an insoluble +-- @Coercible Boolean Char@. +solveWanteds + :: MonadError MultipleErrors m + => MonadState CheckState m + => Environment + -> StateT WantedSolverState m () +solveWanteds env = go (0 :: Int) where + go n = do + when (n > 1000) . throwError . errorMessage $ PossiblyInfiniteCoercibleInstance + gets unsolvedWanteds >>= \case + [] -> pure () + wanted : unsolved -> do + (k, a, b) <- lift $ unify wanted + WantedSolverState{..} <- get + lift (canon env (Just inertGivens) k a b `catchError` recover (a, b) inertGivens) >>= \case + Irreducible -> case interact env (a, b) inertGivens of + Just (Simplified (a', b')) -> + put $ WantedSolverState { unsolvedWanteds = (a', b') : unsolved, .. } + Just Discharged -> + put $ WantedSolverState { unsolvedWanteds = unsolved, .. } + Nothing -> + put $ WantedSolverState + { inertWanteds = (k, a, b) : inertWanteds + , unsolvedWanteds = unsolved + , .. + } + Canonicalized deriveds -> + put $ WantedSolverState { unsolvedWanteds = toList deriveds <> unsolved, .. } + go (n + 1) + recover wanted givens errors = + case interact env wanted givens of + Nothing -> throwError errors + Just (Simplified wanted') -> pure . Canonicalized $ S.singleton wanted' + Just Discharged -> pure $ Canonicalized mempty + +-- | Unifying constraints arguments kinds isn't strictly necessary but yields +-- better error messages. For instance we cannot solve the constraint +-- @Coercible (D :: Type -> Type) (D a :: Type)@ because its arguments kinds +-- don't match and trying to unify them will say so, which is more helpful than +-- simply saying that no type class instance was found. +-- +-- A subtle thing to note is that types with polymorphic kinds can be annotated +-- with kind applications mentioning unknowns that we may have solved by +-- unifying the kinds. +-- +-- For instance the declarations: +-- +-- @ +-- data D :: forall k. k -> Type +-- data D a = D +-- +-- type role D representational +-- +-- example :: D D -> D D +-- example = coerce +-- @ +-- +-- yield a wanted +-- @Coercible (D \@(k1 -> Type) (D \@k1)) (D \@(k2 -> Type) (D \@k2))@, which we +-- decompose to @Coercible (D \@k1) (D \@k2)@, where @k1@ and @k2@ are unknowns. +-- This constraint is not reflexive because @D \@k1@ and @D \@k2@ are differents +-- but both arguments kinds unify with @k -> Type@, where @k@ is a fresh unknown, +-- so applying the substitution to @D \@k1@ and @D \@k2@ yields a +-- @Coercible (D \@k) (D \@k)@ constraint which could be trivially solved by +-- reflexivity instead of having to saturate the type constructors. +unify + :: MonadError MultipleErrors m + => MonadState CheckState m + => (SourceType, SourceType) + -> m (SourceType, SourceType, SourceType) +unify (a, b) = do + let kindOf = sequence . (id &&& elaborateKind) <=< replaceAllTypeSynonyms + (a', kind) <- kindOf a + (b', kind') <- kindOf b + unifyKinds kind kind' + subst <- gets checkSubstitution + pure ( substituteType subst kind + , substituteType subst a' + , substituteType subst b' + ) + +-- | A successful interaction between an irreducible constraint and an inert +-- given constraint has two possible outcomes: +data Interaction + = Simplified (SourceType, SourceType) + -- ^ The interaction can yield a derived constraint, + | Discharged + -- ^ or we can learn the irreducible constraint is redundant and discharge it. + +-- | Interact an irreducible constraint with an inert set of givens. +interact + :: Environment + -> (SourceType, SourceType) + -> [(SourceType, SourceType, SourceType)] + -> Maybe Interaction +interact env irred = go where + go [] = Nothing + go (inert : _) + | canDischarge inert irred = Just Discharged + | Just derived <- interactSameTyVar inert irred = Just $ Simplified derived + | Just derived <- interactDiffTyVar env inert irred = Just $ Simplified derived + go (_ : inerts) = go inerts + +-- | A given constraint of the form @Coercible a b@ can discharge constraints +-- of the form @Coercible a b@ and @Coercible b a@. +canDischarge + :: (SourceType, SourceType, SourceType) + -> (SourceType, SourceType) + -> Bool +canDischarge (_, a, b) constraint = + (a, b) == constraint || (b, a) == constraint + +-- | Two canonical constraints of the form @Coercible tv ty1@ and +-- @Coercible tv ty2@ can interact together and yield a new constraint +-- @Coercible ty1 ty2@. Canonicality matters to avoid loops. +-- +-- For instance the declarations: +-- +-- @ +-- data D a = D a +-- newtype N a = N (D (N a)) +-- +-- example :: forall a. Coercible a (D a) => a -> N a +-- example = coerce +-- @ +-- +-- yield a non canonical wanted @Coercible a (N a)@ that we can unwrap on the +-- right to yield @Coercible a (D (N a))@. Would it interact with the non +-- canonical given @Coercible a (D a)@ it would give @Coercible (D a) (D (N a))@, +-- then decompose back to @Coercible a (N a)@. +interactSameTyVar + :: (SourceType, SourceType, SourceType) + -> (SourceType, SourceType) + -> Maybe (SourceType, SourceType) +interactSameTyVar (_, tv1, ty1) (tv2, ty2) + | tv1 == tv2 && isCanonicalTyVarEq (tv1, ty1) && isCanonicalTyVarEq (tv2, ty2) + = Just (ty1, ty2) + | otherwise = Nothing + +-- | Two canonical constraints of the form @Coercible tv1 ty1@ and +-- @Coercible tv2 ty2@ can interact together and yield a new constraint +-- @Coercible tv2 ty2[ty1/tv1]@. Once again, canonicality matters to avoid loops. +-- +-- For instance the declarations: +-- +-- @ +-- data D a = D a +-- +-- example :: forall a b. Coercible b (D b) => a -> b +-- example = coerce +-- @ +-- +-- yield an irreducible canonical wanted @Coercible a b@. Would it interact with +-- the non canonical given @Coercible b (D b)@ it would give @Coercible a (D b)@, +-- which would keep interacting indefinitely with the given. +interactDiffTyVar + :: Environment + -> (SourceType, SourceType, SourceType) + -> (SourceType, SourceType) + -> Maybe (SourceType, SourceType) +interactDiffTyVar env (_, tv1, ty1) (tv2, ty2) + | tv1 /= tv2 && isCanonicalTyVarEq (tv2, ty2) + , (ty2', Any True) <- runWriter $ rewrite env (tv1, ty1) ty2 + = Just (tv2, ty2') + | otherwise = Nothing + +-- | A canonical constraint of the form @Coercible tv1 ty1@ can rewrite the +-- right hand side of an irreducible constraint of the form @Coercible tv2 ty2@ +-- by substituting @ty1@ for every occurence of @tv1@ at representational and +-- phantom role in @ty2@. Nominal occurences are left untouched. +rewrite :: Environment -> (SourceType, SourceType) -> SourceType -> Writer Any SourceType +rewrite env (Skolem _ _ _ s1 _, ty1) | not $ occurs s1 ty1 = go where + go (Skolem _ _ _ s2 _) | s1 == s2 = tell (Any True) $> ty1 + go ty2 | (Skolem{}, _, xs) <- unapplyTypes ty2, not $ null xs = + rewriteTyVarApp go ty2 + | (TypeConstructor _ tyName, _, _) <- unapplyTypes ty2 = do + rewriteTyConApp go (lookupRoles env tyName) ty2 + go (KindApp sa ty k) = KindApp sa <$> go ty <*> pure k + go (ForAll sa tv k ty scope) = ForAll sa tv k <$> go ty <*> pure scope + go (ConstrainedType sa Constraint{..} ty) | s1 `S.notMember` foldMap skolems constraintArgs = + ConstrainedType sa Constraint{..} <$> go ty + go (RCons sa label ty rest) = RCons sa label <$> go ty <*> go rest + go (KindedType sa ty k) = KindedType sa <$> go ty <*> pure k + go ty2 = pure ty2 +rewrite _ _ = pure + +-- | Rewrite the head of a type application of the form @tv a_0 .. a_n@. +rewriteTyVarApp + :: Applicative m + => (SourceType -> m SourceType) + -> SourceType + -> m SourceType +rewriteTyVarApp f = go where + go (TypeApp sa lhs rhs) = + TypeApp sa <$> go lhs <*> pure rhs + go (KindApp sa ty k) = + KindApp sa <$> go ty <*> pure k + go ty = f ty + +-- | Rewrite the representational and phantom arguments of a type application +-- of the form @D a_0 .. a_n@. +rewriteTyConApp + :: Applicative m + => (SourceType -> m SourceType) + -> [Role] + -> SourceType + -> m SourceType +rewriteTyConApp f = go where + go (role : roles) (TypeApp sa lhs rhs) = + TypeApp sa <$> go roles lhs <*> case role of + Nominal -> pure rhs + _ -> f rhs + go roles (KindApp sa ty k) = + KindApp sa <$> go roles ty <*> pure k + go _ ty = pure ty + +canRewrite :: Environment -> (SourceType, SourceType) -> SourceType -> Bool +canRewrite env irred = getAny . execWriter . rewrite env irred + +-- | An irreducible given constraint must kick out of the inert set any +-- constraint it can rewrite when it becomes inert, otherwise solving would be +-- sensitive to the order of constraints. Wanteds cannot rewrite other wanteds +-- so this applies only to givens. +-- +-- For instance the declaration: +-- +-- @ +-- example :: forall f g a b. Coercible a (f b) => Coercible f g => Proxy f -> a -> g b +-- example _ = coerce +-- @ +-- +-- yields the irreducible givens @Coercible a (f b)@ and @Coercible f g@. Would +-- we not kick out the former when adding the latter to the inert set we would +-- not be able to rewrite it to @Coercible a (g b)@ and discharge the wanted, +-- but inverting the givens would work. +kicksOut + :: Environment + -> (SourceType, SourceType) + -> (SourceType, SourceType, SourceType) + -> Either (SourceType, SourceType) (SourceType, SourceType, SourceType) +kicksOut env irred (_, tv2, ty2) + | isCanonicalTyVarEq (tv2, ty2) && canRewrite env irred ty2 + = Left (tv2, ty2) +kicksOut _ _ inert = Right inert + +-- | A constraint of the form @Coercible tv ty@ is canonical when @tv@ does not +-- occur in @ty@. Non canonical constraints do not interact to prevent loops. +isCanonicalTyVarEq :: (SourceType, SourceType) -> Bool +isCanonicalTyVarEq (Skolem _ _ _ s _, ty) = not $ occurs s ty +isCanonicalTyVarEq _ = False + +occurs :: Int -> SourceType -> Bool +occurs s1 = everythingOnTypes (||) go where + go (Skolem _ _ _ s2 _) | s1 == s2 = True + go _ = False + +skolems :: SourceType -> S.Set Int +skolems = everythingOnTypes (<>) go where + go (Skolem _ _ _ s _) = S.singleton s + go _ = mempty + +-- | A successful canonicalization result has two possible outcomes: +data Canonicalized + = Canonicalized (S.Set (SourceType, SourceType)) + -- ^ Canonicalization can yield a set of derived constraints, + | Irreducible + -- ^ or we can learn the constraint is irreducible. Irreducibility is not + -- necessarily an error, we may make further progress by interacting with + -- inerts. + +-- | Canonicalization takes a wanted constraint and try to reduce it to a set of +-- simpler constraints whose satisfaction will imply the goal. +canon + :: MonadError MultipleErrors m + => MonadState CheckState m + => Environment + -> Maybe [(SourceType, SourceType, SourceType)] + -> SourceType + -> SourceType + -> SourceType + -> m Canonicalized +canon env givens k a b = + maybe (throwError $ insoluble k a b) pure <=< runMaybeT $ + canonRefl a b + <|> canonUnsaturatedHigherKindedType env a b + <|> canonRow a b + -- We unwrap newtypes before trying the decomposition rules because it let + -- us solve more constraints. + -- + -- For instance the declarations: + -- + -- @ + -- newtype N f a = N (f a) + -- + -- example :: forall a b. Coercible a b => N Maybe a -> N Maybe b + -- example = coerce + -- @ + -- + -- yield the wanted @Coercible (N Maybe a) (N Maybe b)@ which we cannot + -- decompose because the second parameter of @N@ is nominal. On the other + -- hand, unwraping on both sides yields @Coercible (Maybe a) (Maybe b)@ + -- which we can then decompose to @Coercible a b@ and discharge with the + -- given. + <|> canonNewtypeLeft env a b + <|> canonNewtypeRight env a b + <|> canonDecomposition env a b + <|> canonDecompositionFailure env k a b + <|> canonNewtypeDecomposition env givens a b + <|> canonNewtypeDecompositionFailure a b + <|> canonTypeVars a b + <|> canonTypeVarLeft a b + <|> canonTypeVarRight a b + <|> canonApplicationLeft a b + <|> canonApplicationRight a b + +insoluble + :: SourceType + -> SourceType + -> SourceType + -> MultipleErrors +insoluble k a b = + errorMessage . NoInstanceFound $ srcConstraint Prim.Coercible [k] [a, b] Nothing + +-- | Constraints of the form @Coercible a b@ can be solved if the two arguments +-- are the same. Since we currently don't support higher-rank arguments in +-- instance heads, term equality is a sufficient notion of "the same". +canonRefl + :: Monad m + => SourceType + -> SourceType + -> MaybeT m Canonicalized +canonRefl a b = + guard (a == b) $> Canonicalized mempty + +-- | Constraints of the form @Coercible (T1 a_0 .. a_n) (T2 b_0 .. b_n)@, where +-- both arguments have kind @k1 -> k2@, yield a constraint +-- @Coercible (T1 a_0 .. a_n c_0 .. c_m) (T2 b_0 .. b_n c_0 .. c_m)@, where both +-- arguments are fully saturated with the same unknowns and have kind @Type@. +canonUnsaturatedHigherKindedType + :: MonadError MultipleErrors m + => MonadState CheckState m + => Environment + -> SourceType + -> SourceType + -> MaybeT m Canonicalized +canonUnsaturatedHigherKindedType env a b + | (TypeConstructor _ aTyName, akapps, axs) <- unapplyTypes a + , (ak, _) <- fromMaybe (internalError "canonUnsaturatedHigherKindedType: type lookup failed") $ M.lookup aTyName (types env) + , (aks, _) <- unapplyKinds ak + , length axs < length aks = do + ak' <- lift $ do + let (kvs, ak') = fromMaybe (internalError "canonUnsaturatedHigherKindedType: unkinded forall binder") $ completeBinderList ak + instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs akapps + unknownKinds <- traverse (\((ss, _), (kv, k)) -> (kv,) <$> freshKindWithKind ss k) $ drop (length akapps) kvs + pure $ replaceAllTypeVars (instantiatedKinds <> unknownKinds) ak' + let (aks', _) = unapplyKinds ak' + tys <- traverse freshTypeWithKind $ drop (length axs) aks' + let a' = foldl' srcTypeApp a tys + b' = foldl' srcTypeApp b tys + pure . Canonicalized $ S.singleton (a', b') + | otherwise = empty + +-- | Constraints of the form +-- @Coercible ( label_0 :: a_0, .. label_n :: a_n | r ) ( label_0 :: b_0, .. label_n :: b_n | s )@ +-- yield a constraint @Coercible r s@ and constraints on the types for each +-- label in both rows. Labels exclusive to one row yield a failure. +canonRow + :: MonadError MultipleErrors m + => MonadState CheckState m + => SourceType + -> SourceType + -> MaybeT m Canonicalized +canonRow a b + | RCons{} <- a = + case alignRowsWith (,) a b of + (deriveds, (([], tail1), ([], tail2))) -> do + pure . Canonicalized . S.fromList $ (tail1, tail2) : deriveds + (_, (rl1, rl2)) -> + throwError . errorMessage $ TypesDoNotUnify (rowFromList rl1) (rowFromList rl2) + | otherwise = empty + +-- | Unwraping a newtype can fails in two ways: +data UnwrapNewtypeError + = CannotUnwrapInfiniteNewtypeChain + -- ^ The newtype might wrap an infinite newtype chain. We may think that this + -- is already handled by the solver depth check, but failing to unwrap + -- infinite chains of newtypes let us try other rules. + -- + -- For instance the declarations: + -- + -- @ + -- newtype N a = N (N a) + -- type role N representational + -- + -- example :: forall a b. Coercible a b => N a -> N b + -- example = coerce + -- @ + -- + -- yield a wanted @Coercible (N a) (N b)@ that we can decompose to + -- @Coercible a b@ then discharge with the given if the newtype + -- unwraping rules do not apply. + | CannotUnwrapConstructor + -- ^ The constructor may not be in scope or may not belong to a newtype. + +-- | Unwraps a newtype and yields its underlying type with the newtype arguments +-- substituted in (e.g. @N[D/a] = D@ given @newtype N a = N a@ and @data D = D@). +unwrapNewtype + :: MonadState CheckState m + => Environment + -> SourceType + -> m (Either UnwrapNewtypeError SourceType) +unwrapNewtype env = go (0 :: Int) where + go n ty = runExceptT $ do + when (n > 1000) $ throwError CannotUnwrapInfiniteNewtypeChain + (currentModuleName, currentModuleImports) <- gets $ checkCurrentModule &&& checkCurrentModuleImports + case unapplyTypes ty of + (TypeConstructor _ newtypeName, _, xs) + | Just (fromModuleName, tvs, newtypeCtorName, wrappedTy) <- + lookupNewtypeConstructorInScope env currentModuleName currentModuleImports newtypeName + -- We refuse to unwrap newtypes over polytypes because we don't know how + -- to canonicalize them yet and we'd rather try to make progress with + -- another rule. + , isMonoType wrappedTy -> do + for_ fromModuleName $ flip insertCoercedNewtypeCtorImport newtypeCtorName + let wrappedTySub = replaceAllTypeVars (zip tvs xs) wrappedTy + ExceptT (go (n + 1) wrappedTySub) `catchError` \case + CannotUnwrapInfiniteNewtypeChain -> throwError CannotUnwrapInfiniteNewtypeChain + CannotUnwrapConstructor -> pure wrappedTySub + _ -> throwError CannotUnwrapConstructor + insertCoercedNewtypeCtorImport fromModuleName newtypeCtorName = modify $ \st -> + st { checkCoercedNewtypeCtorsImports = S.insert (fromModuleName, newtypeCtorName) $ checkCoercedNewtypeCtorsImports st } + +-- | Looks up a given name and, if it names a newtype, returns the names of the +-- type's parameters, the type the newtype wraps and the names of the type's +-- fields. +lookupNewtypeConstructor + :: Environment + -> Qualified (ProperName 'TypeName) + -> Maybe ([Text], ProperName 'ConstructorName, SourceType) +lookupNewtypeConstructor env qualifiedNewtypeName@(Qualified newtypeModuleName _) = do + (_, DataType tvs [(ctorName, [wrappedTy])]) <- M.lookup qualifiedNewtypeName (types env) + (Newtype, _, _, _) <- M.lookup (Qualified newtypeModuleName ctorName) (dataConstructors env) + pure (map (\(name, _, _) -> name) tvs, ctorName, wrappedTy) + +-- | Behaves like 'lookupNewtypeConstructor', but fails unless the newtype +-- constructor is in scope and returns the module from which it is imported, or +-- 'Nothing' if it is defined in the current module. +lookupNewtypeConstructorInScope + :: Environment + -> Maybe ModuleName + -> [ ( SourceAnn + , ModuleName + , ImportDeclarationType + , Maybe ModuleName + , M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource) + ) + ] + -> Qualified (ProperName 'TypeName) + -> Maybe (Maybe ModuleName, [Text], Qualified (ProperName 'ConstructorName), SourceType) +lookupNewtypeConstructorInScope env currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName) = do + let fromModule = find isNewtypeCtorImported currentModuleImports + fromModuleName = (\(_, n, _, _, _) -> n) <$> fromModule + asModuleName = (\(_, _, _, n, _) -> n) =<< fromModule + isDefinedInCurrentModule = newtypeModuleName == currentModuleName + isImported = isJust fromModule + guard $ isDefinedInCurrentModule || isImported + (tvs, ctorName, wrappedTy) <- lookupNewtypeConstructor env qualifiedNewtypeName + pure (fromModuleName, tvs, Qualified asModuleName ctorName, wrappedTy) + where + isNewtypeCtorImported (_, _, importDeclType, _, exportedTypes) = + case M.lookup newtypeName exportedTypes of + Just ([_], _) -> case importDeclType of + Implicit -> True + Explicit refs -> any isNewtypeCtorRef refs + Hiding refs -> not $ any isNewtypeCtorRef refs + _ -> False + isNewtypeCtorRef = \case + TypeRef _ importedTyName Nothing -> importedTyName == newtypeName + TypeRef _ importedTyName (Just [_]) -> importedTyName == newtypeName + _ -> False + +-- | Constraints of the form @Coercible (N a_0 .. a_n) b@ yield a constraint +-- @Coercible a b@ if unwraping the newtype yields @a@. +canonNewtypeLeft + :: MonadState CheckState m + => Environment + -> SourceType + -> SourceType + -> MaybeT m Canonicalized +canonNewtypeLeft env a b = + unwrapNewtype env a >>= \case + Left CannotUnwrapInfiniteNewtypeChain -> empty + Left CannotUnwrapConstructor -> empty + Right a' -> pure . Canonicalized $ S.singleton (a', b) + +-- | Constraints of the form @Coercible a (N b_0 .. b_n)@ yield a constraint +-- @Coercible a b@ if unwraping the newtype yields @b@. +canonNewtypeRight + :: MonadState CheckState m + => Environment + -> SourceType + -> SourceType + -> MaybeT m Canonicalized +canonNewtypeRight env = + flip $ canonNewtypeLeft env + +-- | Decomposes constraints of the form @Coercible (D a_0 .. a_n) (D b_0 .. b_n)@ +-- into constraints on their representational arguments, ignoring phantom +-- arguments and failing on unequal nominal arguments. +-- +-- For instance given the declarations: +-- +-- @ +-- data D a b c = D a b +-- type role D nominal representational +-- @ +-- +-- We can decompose @Coercible (D a b d) (D a c e)@ into @Coercible b c@, but +-- decomposing @Coercible (D a c d) (D b c d)@ would fail. +decompose + :: MonadError MultipleErrors m + => Environment + -> Qualified (ProperName 'TypeName) + -> [SourceType] + -> [SourceType] + -> m Canonicalized +decompose env tyName axs bxs = do + let roles = lookupRoles env tyName + f role ax bx = case role of + Nominal + -- If we had first-class equality constraints, we'd just + -- emit one of the form @(a ~ b)@ here and let the solver + -- recurse. Since we don't we must compare the types at + -- this point and fail if they don't match. This likely + -- means there are cases we should be able to handle that + -- we currently can't, but is at least sound. + | ax == bx -> + pure mempty + | otherwise -> + throwError . errorMessage $ TypesDoNotUnify ax bx + Representational -> + pure $ S.singleton (ax, bx) + Phantom -> + pure mempty + fmap (Canonicalized . fold) $ sequence $ zipWith3 f roles axs bxs + +-- | Constraints of the form @Coercible (D a_0 .. a_n) (D b_0 .. b_n)@, where +-- @D@ is not a newtype, yield constraints on their arguments. +canonDecomposition + :: MonadError MultipleErrors m + => MonadState CheckState m + => Environment + -> SourceType + -> SourceType + -> MaybeT m Canonicalized +canonDecomposition env a b + | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a + , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b + , aTyName == bTyName + , Nothing <- lookupNewtypeConstructor env aTyName = + decompose env aTyName axs bxs + | otherwise = empty + +-- | Constraints of the form @Coercible (D1 a_0 .. a_n) (D2 b_0 .. b_n)@, where +-- @D1@ and @D2@ are different type constructors and neither of them are +-- newtypes, are insoluble. +canonDecompositionFailure + :: MonadError MultipleErrors m + => MonadState CheckState m + => Environment + -> SourceType + -> SourceType + -> SourceType + -> MaybeT m Canonicalized +canonDecompositionFailure env k a b + | (TypeConstructor _ aTyName, _, _) <- unapplyTypes a + , (TypeConstructor _ bTyName, _, _) <- unapplyTypes b + , aTyName /= bTyName + , Nothing <- lookupNewtypeConstructor env aTyName + , Nothing <- lookupNewtypeConstructor env bTyName = + throwError $ insoluble k a b + | otherwise = empty + +-- | Wanted constraints of the form @Coercible (N a_0 .. a_n) (N b_0 .. b_n)@, +-- where @N@ is a newtype whose constructor is out of scope, yield constraints +-- on their arguments only when no given constraint can discharge them. +-- +-- We cannot decompose given constraints because newtypes are not necessarily +-- injective with respect to representational equality. +-- +-- For instance given the declaration: +-- +-- @ +-- newtype Const a b = MkConst a +-- type role Const representational representational +-- @ +-- +-- Decomposing a given @Coercible (Const a a) (Const a b)@ constraint to +-- @Coercible a b@ when @MkConst@ is out of scope would let us coerce arbitrary +-- types in modules where @MkConst@ is imported, because the given is easily +-- satisfied with the newtype unwraping rules. +-- +-- Moreover we do not decompose wanted constraints if they could be discharged +-- by a given constraint. +-- +-- For instance the declaration: +-- +-- @ +-- example :: forall a b. Coercible (Const a a) (Const a b) => Const a a -> Const a b +-- example = coerce +-- @ +-- +-- yield an irreducible given @Coercible (Const a a) (Const a b)@ when @MkConst@ +-- is out of scope. Would we decompose the wanted +-- @Coercible (Const a a) (Const a b)@ to @Coercible a b@ we would not be able +-- to discharge it with the given. +canonNewtypeDecomposition + :: MonadError MultipleErrors m + => MonadState CheckState m + => Environment + -> Maybe [(SourceType, SourceType, SourceType)] + -> SourceType + -> SourceType + -> MaybeT m Canonicalized +canonNewtypeDecomposition env (Just givens) a b + | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a + , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b + , aTyName == bTyName + , Just _ <- lookupNewtypeConstructor env aTyName = do + let givensCanDischarge = any (\given -> canDischarge given (a, b)) givens + guard $ not givensCanDischarge + decompose env aTyName axs bxs +canonNewtypeDecomposition _ _ _ _ = empty + +-- | Constraints of the form @Coercible (N1 a_0 .. a_n) (N2 b_0 .. b_n)@, where +-- @N1@ and @N2@ are different type constructors and either of them is a +-- newtype whose constructor is out of scope, are irreducible. +canonNewtypeDecompositionFailure + :: Monad m + => SourceType + -> SourceType + -> MaybeT m Canonicalized +canonNewtypeDecompositionFailure a b + | (TypeConstructor{}, _, _) <- unapplyTypes a + , (TypeConstructor{}, _, _) <- unapplyTypes b + = pure Irreducible + | otherwise = empty + +-- | Constraints of the form @Coercible tv1 tv2@ may be irreducibles, but only +-- when the variables are lexicographically ordered. Reordering variables is +-- neessary to prevent loops. +-- +-- For instance the declaration: +-- +-- @ +-- example :: forall a b. Coercible a b => Coercible b a => a -> b +-- example = coerce +-- @ +-- +-- yields the irreducible givens @Coercible a b@ and @Coercible b a@ which would +-- repeatedly kick each other out the inert set whereas reordering the latter to +-- @Coercible a b@ makes it redundant and let us discharge it. +canonTypeVars + :: Monad m + => SourceType + -> SourceType + -> MaybeT m Canonicalized +canonTypeVars a b + | Skolem _ tv1 _ _ _ <- a + , Skolem _ tv2 _ _ _ <- b + , tv2 < tv1 + = pure . Canonicalized $ S.singleton (b, a) + | Skolem{} <- a, Skolem{} <- b + = pure Irreducible + | otherwise = empty + +-- | Constraints of the form @Coercible tv ty@ are irreducibles. +canonTypeVarLeft + :: Monad m + => SourceType + -> SourceType + -> MaybeT m Canonicalized +canonTypeVarLeft a _ + | Skolem{} <- a = pure Irreducible + | otherwise = empty + +-- | Constraints of the form @Coercible ty tv@ are reordered to +-- @Coercible tv ty@ to satisfy the canonicality requirement of having the type +-- variable on the left. +canonTypeVarRight + :: Monad m + => SourceType + -> SourceType + -> MaybeT m Canonicalized +canonTypeVarRight a b + | Skolem{} <- b = pure . Canonicalized $ S.singleton (b, a) + | otherwise = empty + +-- | Constraints of the form @Coercible (f a_0 .. a_n) b@ are irreducibles. +canonApplicationLeft + :: Monad m + => SourceType + -> SourceType + -> MaybeT m Canonicalized +canonApplicationLeft a _ + | TypeApp{} <- a = pure Irreducible + | otherwise = empty + +-- | Constraints of the form @Coercible a (f b_0 .. b_n) b@ are irreducibles. +canonApplicationRight + :: Monad m + => SourceType + -> SourceType + -> MaybeT m Canonicalized +canonApplicationRight _ b + | TypeApp{} <- b = pure Irreducible + | otherwise = empty diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 7bd01f5e4c..6b92f9e059 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -20,6 +20,8 @@ module Language.PureScript.TypeChecker.Kinds , checkKindDeclaration , checkTypeKind , unknownsWithKinds + , freshKind + , freshKindWithKind ) where import Prelude.Compat diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 4bb926deba..a77b4b40c9 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -69,8 +69,18 @@ data CheckState = CheckState -- ^ The next skolem scope constant , checkCurrentModule :: Maybe ModuleName -- ^ The current module - , checkCurrentModuleImports :: [(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName)] - -- ^ The current module imports + , checkCurrentModuleImports :: + [ ( SourceAnn + , ModuleName + , ImportDeclarationType + , Maybe ModuleName + , M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource) + ) + ] + -- ^ The current module imports and their exported types. + -- Newtype constructors have to be in scope for some Coercible constraints to + -- be solvable, so we need to know which constructors are imported and whether + -- they are actually defined in or re-exported from the imported modules. , checkSubstitution :: Substitution -- ^ The current substitution , checkHints :: [ErrorMessageHint] diff --git a/tests/purs/failing/CoercibleClosedRowsDoNotUnify.out b/tests/purs/failing/CoercibleClosedRowsDoNotUnify.out index 353c189b63..9f4d67230b 100644 --- a/tests/purs/failing/CoercibleClosedRowsDoNotUnify.out +++ b/tests/purs/failing/CoercibleClosedRowsDoNotUnify.out @@ -17,10 +17,10 @@ at tests/purs/failing/CoercibleClosedRowsDoNotUnify.purs:7:12 - 7:18 (line 7, co while solving type class constraint   - Prim.Coerce.Coercible ( x :: Int  - )  - ( y :: String - )  + Prim.Coerce.Coercible { x :: Int  + }  + { y :: String + }    while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type { x :: Int  diff --git a/tests/purs/failing/CoercibleConstrained1.out b/tests/purs/failing/CoercibleConstrained1.out index 9731721f9c..d5a0e44f0d 100644 --- a/tests/purs/failing/CoercibleConstrained1.out +++ b/tests/purs/failing/CoercibleConstrained1.out @@ -8,6 +8,11 @@ at tests/purs/failing/CoercibleConstrained1.purs:11:28 - 11:34 (line 11, column  b1   +while solving type class constraint +  + Prim.Coerce.Coercible (Constrained a0) + (Constrained b1) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Constrained a0 -> Constrained b1 while checking that expression coerce diff --git a/tests/purs/failing/CoercibleConstrained2.out b/tests/purs/failing/CoercibleConstrained2.out index 6507a61898..0887faab0b 100644 --- a/tests/purs/failing/CoercibleConstrained2.out +++ b/tests/purs/failing/CoercibleConstrained2.out @@ -2,12 +2,20 @@ Error found: in module Main at tests/purs/failing/CoercibleConstrained2.purs:11:28 - 11:34 (line 11, column 28 - line 11, column 34) - No type class instance was found for -   -  Prim.Coerce.Coercible (Constrained a0) -  (Constrained b1) -   + Could not match type +   +  a0 +   + with type +   +  b1 +   +while solving type class constraint +  + Prim.Coerce.Coercible (Constrained a0) + (Constrained b1) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Constrained a0 -> Constrained b1 while checking that expression coerce @@ -19,6 +27,6 @@ where a0 is a rigid type variable b1 is a rigid type variable bound at (line 11, column 28 - line 11, column 34) -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/CoercibleConstrained2.purs b/tests/purs/failing/CoercibleConstrained2.purs index c4c962dfc9..71b4cd45ae 100644 --- a/tests/purs/failing/CoercibleConstrained2.purs +++ b/tests/purs/failing/CoercibleConstrained2.purs @@ -1,4 +1,4 @@ --- @shouldFailWith NoInstanceFound +-- @shouldFailWith TypesDoNotUnify module Main where import Safe.Coerce (coerce) diff --git a/tests/purs/failing/CoercibleConstrained3.out b/tests/purs/failing/CoercibleConstrained3.out index d5a6d3e9f6..91118d3bb7 100644 --- a/tests/purs/failing/CoercibleConstrained3.out +++ b/tests/purs/failing/CoercibleConstrained3.out @@ -2,12 +2,20 @@ Error found: in module Main at tests/purs/failing/CoercibleConstrained3.purs:13:28 - 13:34 (line 13, column 28 - line 13, column 34) - No type class instance was found for -   -  Prim.Coerce.Coercible (Constrained a0)  -  (Constrained (N a0)) -   + Could not match type +   +  a0 +   + with type +   +  N a0 +   +while solving type class constraint +  + Prim.Coerce.Coercible (Constrained a0)  + (Constrained (N a0)) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Constrained a0 -> Constrained (N a0) while checking that expression coerce @@ -17,6 +25,6 @@ in value declaration constrainedToConstrained where a0 is a rigid type variable bound at (line 13, column 28 - line 13, column 34) -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/CoercibleConstrained3.purs b/tests/purs/failing/CoercibleConstrained3.purs index 6db08eeb52..04f059c2b4 100644 --- a/tests/purs/failing/CoercibleConstrained3.purs +++ b/tests/purs/failing/CoercibleConstrained3.purs @@ -1,4 +1,4 @@ --- @shouldFailWith NoInstanceFound +-- @shouldFailWith TypesDoNotUnify module Main where import Safe.Coerce (coerce) diff --git a/tests/purs/failing/CoercibleForeign.out b/tests/purs/failing/CoercibleForeign.out index 39d5f61d71..a1f33a778c 100644 --- a/tests/purs/failing/CoercibleForeign.out +++ b/tests/purs/failing/CoercibleForeign.out @@ -2,12 +2,20 @@ Error found: in module Main at tests/purs/failing/CoercibleForeign.purs:11:20 - 11:26 (line 11, column 20 - line 11, column 26) - No type class instance was found for -   -  Prim.Coerce.Coercible (Foreign a0 b1)  -  (Foreign (Id a0) (Id b1)) -   + Could not match type +   +  a0 +   + with type +   +  Id a0 +   +while solving type class constraint +  + Prim.Coerce.Coercible (Foreign a0 b1)  + (Foreign (Id a0) (Id b1)) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Foreign a0 b1 -> Foreign (Id a0) (Id b1) while checking that expression coerce @@ -19,6 +27,6 @@ where a0 is a rigid type variable b1 is a rigid type variable bound at (line 11, column 20 - line 11, column 26) -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/CoercibleForeign.purs b/tests/purs/failing/CoercibleForeign.purs index eb157bf332..dc3dc5a675 100644 --- a/tests/purs/failing/CoercibleForeign.purs +++ b/tests/purs/failing/CoercibleForeign.purs @@ -1,4 +1,4 @@ --- @shouldFailWith NoInstanceFound +-- @shouldFailWith TypesDoNotUnify module Main where import Safe.Coerce (coerce) diff --git a/tests/purs/failing/CoercibleForeign2.out b/tests/purs/failing/CoercibleForeign2.out index 781eb1ed9f..ff43ac7059 100644 --- a/tests/purs/failing/CoercibleForeign2.out +++ b/tests/purs/failing/CoercibleForeign2.out @@ -2,12 +2,20 @@ Error found: in module Main at tests/purs/failing/CoercibleForeign2.purs:9:20 - 9:26 (line 9, column 20 - line 9, column 26) - No type class instance was found for -   -  Prim.Coerce.Coercible (Foreign a0 b1 c2) -  (Foreign a0 b1 d3) -   + Could not match type +   +  c2 +   + with type +   +  d3 +   +while solving type class constraint +  + Prim.Coerce.Coercible (Foreign a0 b1 c2) + (Foreign a0 b1 d3) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Foreign a0 b1 c2 -> Foreign a0 b1 d3 while checking that expression coerce @@ -23,6 +31,6 @@ where a0 is a rigid type variable d3 is a rigid type variable bound at (line 9, column 20 - line 9, column 26) -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/CoercibleForeign2.purs b/tests/purs/failing/CoercibleForeign2.purs index bc94a389d1..6200d49a71 100644 --- a/tests/purs/failing/CoercibleForeign2.purs +++ b/tests/purs/failing/CoercibleForeign2.purs @@ -1,4 +1,4 @@ --- @shouldFailWith NoInstanceFound +-- @shouldFailWith TypesDoNotUnify module Main where import Safe.Coerce (coerce) diff --git a/tests/purs/failing/CoercibleForeign3.out b/tests/purs/failing/CoercibleForeign3.out index 12f68bff9a..da20cd1011 100644 --- a/tests/purs/failing/CoercibleForeign3.out +++ b/tests/purs/failing/CoercibleForeign3.out @@ -2,12 +2,20 @@ Error found: in module Main at tests/purs/failing/CoercibleForeign3.purs:9:20 - 9:26 (line 9, column 20 - line 9, column 26) - No type class instance was found for -   -  Prim.Coerce.Coercible (Foreign @k0 a1 b2) -  (Foreign @k0 a1 c3) -   + Could not match type +   +  b2 +   + with type +   +  c3 +   +while solving type class constraint +  + Prim.Coerce.Coercible (Foreign @k0 a1 b2) + (Foreign @k0 a1 c3) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Foreign @k0 a1 b2 -> Foreign @k0 a1 c3 while checking that expression coerce @@ -23,6 +31,6 @@ where k0 is a rigid type variable c3 is a rigid type variable bound at (line 9, column 20 - line 9, column 26) -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/CoercibleForeign3.purs b/tests/purs/failing/CoercibleForeign3.purs index 2abd379b12..af9859fe6b 100644 --- a/tests/purs/failing/CoercibleForeign3.purs +++ b/tests/purs/failing/CoercibleForeign3.purs @@ -1,4 +1,4 @@ --- @shouldFailWith NoInstanceFound +-- @shouldFailWith TypesDoNotUnify module Main where import Safe.Coerce (coerce) diff --git a/tests/purs/failing/CoercibleHigherKindedData.out b/tests/purs/failing/CoercibleHigherKindedData.out index 7800515797..676e714c10 100644 --- a/tests/purs/failing/CoercibleHigherKindedData.out +++ b/tests/purs/failing/CoercibleHigherKindedData.out @@ -9,6 +9,11 @@ at tests/purs/failing/CoercibleHigherKindedData.purs:13:17 - 13:23 (line 13, col   The instance head contains unknown type variables. Consider adding a type annotation. +while solving type class constraint +  + Prim.Coerce.Coercible (Proxy @(t0 -> Type) (Unary @t0))  + (Proxy @(t1 -> Type) (Binary @t2 @t1 a3)) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Proxy @(t0 -> Type) (Unary @t0) -> Proxy @(t1 -> Type) (... @t1 a3) while checking that expression coerce diff --git a/tests/purs/failing/CoercibleHigherKindedNewtypes.out b/tests/purs/failing/CoercibleHigherKindedNewtypes.out index de1064d6c5..39c89d83dc 100644 --- a/tests/purs/failing/CoercibleHigherKindedNewtypes.out +++ b/tests/purs/failing/CoercibleHigherKindedNewtypes.out @@ -3,21 +3,22 @@ in module Main at tests/purs/failing/CoercibleHigherKindedNewtypes.purs:13:8 - 13:14 (line 13, column 8 - line 13, column 14) No type class instance was found for -   -  Prim.Coerce.Coercible t0 -  t1 -   - The instance head contains unknown type variables. Consider adding a type annotation. +   +  Prim.Coerce.Coercible Int  +  String +   +while solving type class constraint +  + Prim.Coerce.Coercible (Ap @Type @Type N1 Int String) + (Ap @Type @Type N2 Int String) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Ap @Type @Type N1 Int String -> Ap @Type @Type N2 Int String while checking that expression coerce has type Ap @Type @Type N1 Int String -> Ap @Type @Type N2 Int String in value declaration swap -where t1 is an unknown type - t0 is an unknown type - See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/CoercibleKindMismatch.out b/tests/purs/failing/CoercibleKindMismatch.out index c6f3b0027b..a06182d62e 100644 --- a/tests/purs/failing/CoercibleKindMismatch.out +++ b/tests/purs/failing/CoercibleKindMismatch.out @@ -12,10 +12,10 @@ at tests/purs/failing/CoercibleKindMismatch.purs:14:39 - 14:45 (line 14, column   while solving type class constraint -  - Prim.Coerce.Coercible (Unary @t0)  - (Binary @t1 @t2) -  +  + Prim.Coerce.Coercible (Proxy @(t0 -> Type) (Unary @t0))  + (Proxy @(t1 -> t2 -> Type) (Binary @t1 @t2)) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Proxy @(t0 -> Type) (Unary @t0) -> Proxy @(t1 -> ...) (Binary @t1 @t2) while checking that expression coerce diff --git a/tests/purs/failing/CoercibleNominal.out b/tests/purs/failing/CoercibleNominal.out index 9f850dc4bd..77bfb12e17 100644 --- a/tests/purs/failing/CoercibleNominal.out +++ b/tests/purs/failing/CoercibleNominal.out @@ -2,12 +2,20 @@ Error found: in module Main at tests/purs/failing/CoercibleNominal.purs:11:20 - 11:26 (line 11, column 20 - line 11, column 26) - No type class instance was found for -   -  Prim.Coerce.Coercible (Nominal a0 c1) -  (Nominal b2 c1) -   + Could not match type +   +  a0 +   + with type +   +  b2 +   +while solving type class constraint +  + Prim.Coerce.Coercible (Nominal a0 c1) + (Nominal b2 c1) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Nominal a0 c1 -> Nominal b2 c1 while checking that expression coerce @@ -21,6 +29,6 @@ where a0 is a rigid type variable c1 is a rigid type variable bound at (line 11, column 20 - line 11, column 26) -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/CoercibleNominal.purs b/tests/purs/failing/CoercibleNominal.purs index 365328227d..13c7da8144 100644 --- a/tests/purs/failing/CoercibleNominal.purs +++ b/tests/purs/failing/CoercibleNominal.purs @@ -1,4 +1,4 @@ --- @shouldFailWith NoInstanceFound +-- @shouldFailWith TypesDoNotUnify module Main where import Safe.Coerce (coerce) diff --git a/tests/purs/failing/CoercibleNominalTypeApp.out b/tests/purs/failing/CoercibleNominalTypeApp.out index 2232a1983f..2cc4b5a2a9 100644 --- a/tests/purs/failing/CoercibleNominalTypeApp.out +++ b/tests/purs/failing/CoercibleNominalTypeApp.out @@ -2,18 +2,26 @@ Error found: in module Main at tests/purs/failing/CoercibleNominalTypeApp.purs:13:8 - 13:14 (line 13, column 8 - line 13, column 14) - No type class instance was found for -   -  Prim.Coerce.Coercible (G @Type Maybe Int)  -  (G @Type Maybe String) -   + Could not match type +   +  Int +   + with type +   +  String +   +while solving type class constraint +  + Prim.Coerce.Coercible (G @Type Maybe Int)  + (G @Type Maybe String) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type G @Type Maybe Int -> G @Type Maybe String while checking that expression coerce has type G @Type Maybe Int -> G @Type Maybe String in value declaration gToG -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/CoercibleNominalTypeApp.purs b/tests/purs/failing/CoercibleNominalTypeApp.purs index b7eb0c2ace..80112d2c8e 100644 --- a/tests/purs/failing/CoercibleNominalTypeApp.purs +++ b/tests/purs/failing/CoercibleNominalTypeApp.purs @@ -1,4 +1,4 @@ --- @shouldFailWith NoInstanceFound +-- @shouldFailWith TypesDoNotUnify module Main where import Safe.Coerce (coerce) diff --git a/tests/purs/failing/CoercibleNominalWrapped.out b/tests/purs/failing/CoercibleNominalWrapped.out index a60528d314..31b820a455 100644 --- a/tests/purs/failing/CoercibleNominalWrapped.out +++ b/tests/purs/failing/CoercibleNominalWrapped.out @@ -2,12 +2,20 @@ Error found: in module Main at tests/purs/failing/CoercibleNominalWrapped.purs:15:14 - 15:20 (line 15, column 14 - line 15, column 20) - No type class instance was found for -   -  Prim.Coerce.Coercible (Wrap a0 b1)  -  (Wrap (Id a0) b1) -   + Could not match type +   +  a0 +   + with type +   +  Id a0 +   +while solving type class constraint +  + Prim.Coerce.Coercible (Wrap a0 b1)  + (Wrap (Id a0) b1) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Wrap a0 b1 -> Wrap (Id a0) b1 while checking that expression coerce @@ -19,6 +27,6 @@ where a0 is a rigid type variable b1 is a rigid type variable bound at (line 15, column 14 - line 15, column 20) -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/CoercibleNominalWrapped.purs b/tests/purs/failing/CoercibleNominalWrapped.purs index f679a2605f..04edff6650 100644 --- a/tests/purs/failing/CoercibleNominalWrapped.purs +++ b/tests/purs/failing/CoercibleNominalWrapped.purs @@ -1,4 +1,4 @@ --- @shouldFailWith NoInstanceFound +-- @shouldFailWith TypesDoNotUnify module Main where import Safe.Coerce (coerce) diff --git a/tests/purs/failing/CoercibleNonCanonical1.out b/tests/purs/failing/CoercibleNonCanonical1.out new file mode 100644 index 0000000000..f4f6de7097 --- /dev/null +++ b/tests/purs/failing/CoercibleNonCanonical1.out @@ -0,0 +1,27 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleNonCanonical1.purs:11:27 - 11:33 (line 11, column 27 - line 11, column 33) + + No type class instance was found for +   +  Prim.Coerce.Coercible a0  +  (D (N @k a0)) +   + +while solving type class constraint +  + Prim.Coerce.Coercible a0  + (N @Type a0) +  +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b + is at least as general as type a0 -> N @Type a0 +while checking that expression coerce + has type a0 -> N @Type a0 +in value declaration nonCanonicalSameTyVarEq + +where a0 is a rigid type variable + bound at (line 11, column 27 - line 11, column 33) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleNonCanonical1.purs b/tests/purs/failing/CoercibleNonCanonical1.purs new file mode 100644 index 0000000000..bd2a4f1b6b --- /dev/null +++ b/tests/purs/failing/CoercibleNonCanonical1.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Prim.Coerce (class Coercible) +import Safe.Coerce (coerce) + +data D a = D a +newtype N a = N (D (N a)) + +nonCanonicalSameTyVarEq :: forall a. Coercible a (D a) => a -> N a +nonCanonicalSameTyVarEq = coerce diff --git a/tests/purs/failing/CoercibleNonCanonical2.out b/tests/purs/failing/CoercibleNonCanonical2.out new file mode 100644 index 0000000000..b1bb270ff2 --- /dev/null +++ b/tests/purs/failing/CoercibleNonCanonical2.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleNonCanonical2.purs:10:27 - 10:33 (line 10, column 27 - line 10, column 33) + + No type class instance was found for +   +  Prim.Coerce.Coercible a0 +  b1 +   + +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b + is at least as general as type a0 -> b1 +while checking that expression coerce + has type a0 -> b1 +in value declaration nonCanonicalDiffTyVarEq + +where a0 is a rigid type variable + bound at (line 10, column 27 - line 10, column 33) + b1 is a rigid type variable + bound at (line 10, column 27 - line 10, column 33) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleNonCanonical2.purs b/tests/purs/failing/CoercibleNonCanonical2.purs new file mode 100644 index 0000000000..4743ae0a79 --- /dev/null +++ b/tests/purs/failing/CoercibleNonCanonical2.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Prim.Coerce (class Coercible) +import Safe.Coerce (coerce) + +data D a = D a + +nonCanonicalDiffTyVarEq :: forall a b. Coercible b (D b) => a -> b +nonCanonicalDiffTyVarEq = coerce diff --git a/tests/purs/failing/CoercibleOpenRowsDoNotUnify.out b/tests/purs/failing/CoercibleOpenRowsDoNotUnify.out index a311951420..4e96f7e13d 100644 --- a/tests/purs/failing/CoercibleOpenRowsDoNotUnify.out +++ b/tests/purs/failing/CoercibleOpenRowsDoNotUnify.out @@ -3,14 +3,10 @@ in module Main at tests/purs/failing/CoercibleOpenRowsDoNotUnify.purs:7:12 - 7:18 (line 7, column 12 - line 7, column 18) No type class instance was found for -   -  Prim.Coerce.Coercible ( x :: Int -  | r0  -  )  -  ( x :: Int -  | s1  -  )  -   +   +  Prim.Coerce.Coercible r0 +  s1 +   while solving type class constraint   diff --git a/tests/purs/failing/CoercibleRepresentational.out b/tests/purs/failing/CoercibleRepresentational.out index 2d3eb6eb16..42a657e6ca 100644 --- a/tests/purs/failing/CoercibleRepresentational.out +++ b/tests/purs/failing/CoercibleRepresentational.out @@ -8,6 +8,11 @@ at tests/purs/failing/CoercibleRepresentational.purs:11:20 - 11:26 (line 11, col  b3   +while solving type class constraint +  + Prim.Coerce.Coercible (Phantom @t0 a1) + (Phantom @t2 b3) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Phantom @t0 a1 -> Phantom @t2 b3 while checking that expression coerce diff --git a/tests/purs/failing/CoercibleRepresentational2.out b/tests/purs/failing/CoercibleRepresentational2.out index 5e82bf8851..435c8421cc 100644 --- a/tests/purs/failing/CoercibleRepresentational2.out +++ b/tests/purs/failing/CoercibleRepresentational2.out @@ -8,6 +8,11 @@ at tests/purs/failing/CoercibleRepresentational2.purs:9:14 - 9:20 (line 9, colum  String   +while solving type class constraint +  + Prim.Coerce.Coercible (Arr1 Int)  + (Arr1 String) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Arr1 Int -> Arr1 String while checking that expression coerce diff --git a/tests/purs/failing/CoercibleRepresentational3.out b/tests/purs/failing/CoercibleRepresentational3.out index 416387b287..f718b3c4cb 100644 --- a/tests/purs/failing/CoercibleRepresentational3.out +++ b/tests/purs/failing/CoercibleRepresentational3.out @@ -8,6 +8,11 @@ at tests/purs/failing/CoercibleRepresentational3.purs:9:14 - 9:20 (line 9, colum  String   +while solving type class constraint +  + Prim.Coerce.Coercible (Rec1 Int)  + (Rec1 String) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Rec1 Int -> Rec1 String while checking that expression coerce diff --git a/tests/purs/failing/CoercibleRepresentational4.out b/tests/purs/failing/CoercibleRepresentational4.out index 3796706c6b..50d61e5c8b 100644 --- a/tests/purs/failing/CoercibleRepresentational4.out +++ b/tests/purs/failing/CoercibleRepresentational4.out @@ -8,6 +8,11 @@ at tests/purs/failing/CoercibleRepresentational4.purs:11:38 - 11:44 (line 11, co  String   +while solving type class constraint +  + Prim.Coerce.Coercible (Representational Int)  + (Representational String) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type Representational Int -> Representational String while checking that expression coerce diff --git a/tests/purs/failing/CoercibleRepresentational5.out b/tests/purs/failing/CoercibleRepresentational5.out index ac323ff661..6c215721cf 100644 --- a/tests/purs/failing/CoercibleRepresentational5.out +++ b/tests/purs/failing/CoercibleRepresentational5.out @@ -8,6 +8,11 @@ at tests/purs/failing/CoercibleRepresentational5.purs:15:38 - 15:44 (line 15, co  String   +while solving type class constraint +  + Prim.Coerce.Coercible (MutuallyRecursiveRepresentational2 Int)  + (MutuallyRecursiveRepresentational2 String) +  while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type MutuallyRecursiveRepresentational2 Int -> MutuallyRecursiveRepresentational2 String while checking that expression coerce diff --git a/tests/purs/failing/CoercibleRepresentational8.out b/tests/purs/failing/CoercibleRepresentational8.out new file mode 100644 index 0000000000..cb5275fcbf --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational8.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleRepresentational8.purs:9:16 - 9:22 (line 9, column 16 - line 9, column 22) + + No type class instance was found for +   +  Prim.Coerce.Coercible a0 +  b1 +   + +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b + is at least as general as type a0 -> b1 +while checking that expression coerce + has type a0 -> b1 +in value declaration unsafeCoerce + +where a0 is a rigid type variable + bound at (line 9, column 16 - line 9, column 22) + b1 is a rigid type variable + bound at (line 9, column 16 - line 9, column 22) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleRepresentational8.purs b/tests/purs/failing/CoercibleRepresentational8.purs new file mode 100644 index 0000000000..b9c52cafae --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational8.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import UnsafeCoerce (UnsafeCoerce) +import Prim.Coerce (class Coercible) +import Safe.Coerce (coerce) + +unsafeCoerce :: forall a b. Coercible (UnsafeCoerce a) (UnsafeCoerce b) => a -> b +unsafeCoerce = coerce diff --git a/tests/purs/failing/CoercibleRepresentational8/UnsafeCoerce.purs b/tests/purs/failing/CoercibleRepresentational8/UnsafeCoerce.purs new file mode 100644 index 0000000000..0764bdda0a --- /dev/null +++ b/tests/purs/failing/CoercibleRepresentational8/UnsafeCoerce.purs @@ -0,0 +1,7 @@ +module UnsafeCoerce where + +import Data.Unit (Unit) + +newtype UnsafeCoerce a = UnsafeCoerce Unit + +type role UnsafeCoerce representational diff --git a/tests/purs/failing/PossiblyInfiniteCoercibleInstance.out b/tests/purs/failing/PossiblyInfiniteCoercibleInstance.out new file mode 100644 index 0000000000..1538fff462 --- /dev/null +++ b/tests/purs/failing/PossiblyInfiniteCoercibleInstance.out @@ -0,0 +1,25 @@ +Error found: +in module Main +at tests/purs/failing/PossiblyInfiniteCoercibleInstance.purs:9:12 - 9:18 (line 9, column 12 - line 9, column 18) + + A Coercible instance is possibly infinite. + +while solving type class constraint +  + Prim.Coerce.Coercible (N a0) + (N b1) +  +while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b + is at least as general as type N a0 -> N b1 +while checking that expression coerce + has type N a0 -> N b1 +in value declaration infinite + +where a0 is a rigid type variable + bound at (line 9, column 12 - line 9, column 18) + b1 is a rigid type variable + bound at (line 9, column 12 - line 9, column 18) + +See https://github.com/purescript/documentation/blob/master/errors/PossiblyInfiniteCoercibleInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PossiblyInfiniteCoercibleInstance.purs b/tests/purs/failing/PossiblyInfiniteCoercibleInstance.purs new file mode 100644 index 0000000000..1d172dfcc5 --- /dev/null +++ b/tests/purs/failing/PossiblyInfiniteCoercibleInstance.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith PossiblyInfiniteCoercibleInstance +module Main where + +import Safe.Coerce (coerce) + +newtype N a = N (a -> N a) + +infinite :: forall a b. N a -> N b +infinite = coerce diff --git a/tests/purs/passing/Coercible.purs b/tests/purs/passing/Coercible.purs index 2fd53b90ff..03172fc042 100644 --- a/tests/purs/passing/Coercible.purs +++ b/tests/purs/passing/Coercible.purs @@ -1,10 +1,11 @@ module Main where -import Coercible.Lib +import Coercible.Lib (NTLib1(..), NTLib2(..), NTLib3) import Effect.Console (log) -import Safe.Coerce (coerce) import Prim.Coerce (class Coercible) +import Safe.Coerce (coerce) +import Type.Proxy (Proxy) refl :: forall a. a -> a refl = coerce @@ -12,6 +13,18 @@ refl = coerce symm :: forall a b. Coercible a b => b -> a symm = coerce +trans :: forall a b c. Coercible a b => Coercible b c => Proxy b -> a -> c +trans _ = coerce + +trans' :: forall a b c. Coercible a b => Coercible c b => Proxy b -> a -> c +trans' _ = coerce + +trans'' :: forall a b c d. Coercible a c => Coercible a d => Coercible d b => Proxy c -> Proxy d -> a -> b +trans'' _ _ = coerce + +transSymm :: forall a b c. Coercible a b => Coercible b c => Proxy b -> c -> a +transSymm _ = coerce + type SynString = String newtype NTString1 = NTString1 SynString @@ -19,6 +32,15 @@ newtype NTString1 = NTString1 SynString nt1ToString :: NTString1 -> String nt1ToString = coerce +stringToNt1 :: String -> NTString1 +stringToNt1 = coerce + +toNT1 :: forall a. Coercible a String => a -> NTString1 +toNT1 = coerce + +toNT1Array :: forall a. Coercible a (Array String) => a -> Array NTString1 +toNT1Array = coerce + newtype NTString2 = NTString2 String nt2ToNT1 :: NTString2 -> NTString1 @@ -35,6 +57,9 @@ id12ToId21 = coerce newtype Ap f a = Ap (f a) +apId1ToApId1 :: forall a b. Coercible a b => Ap Id1 a -> Ap Id1 b +apId1ToApId1 = coerce + apId1ToApId2 :: forall a. Ap Id1 a -> Ap Id2 a apId1ToApId2 = coerce @@ -69,9 +94,15 @@ newtype NTFn2 x a b = NTFn2 (a -> x -> b) ntFn1ToNTFn2 :: forall a b. NTFn1 a b -> NTFn2 Int a b ntFn1ToNTFn2 = coerce -libExposedCtorToId2 :: forall z. NTLib z -> Id2 z +libExposedCtorToId2 :: forall z. NTLib1 z -> Id2 z libExposedCtorToId2 = coerce +libReExportedCtorToId2 :: forall z. NTLib2 z -> Id2 z +libReExportedCtorToId2 = coerce + +libHiddenCtorRepresentational :: forall a b. Coercible (NTLib3 a a) (NTLib3 a b) => NTLib3 a a -> NTLib3 a b +libHiddenCtorRepresentational = coerce + newtype Roles1 a b c = Roles1 (Phantom1 b c) roles1ToSecond :: forall r s t. Roles1 r s t -> s @@ -82,6 +113,15 @@ data D a b = D a underD :: D NTString1 Boolean -> D NTString2 Int underD = coerce +givenCanonicalSameTyVarEq :: forall a b c d e. Coercible a (D b c) => Coercible a (D d e) => Proxy a -> b -> d +givenCanonicalSameTyVarEq _ = coerce + +givenCanonicalDiffTyVarEq1 :: forall a b c d e. Coercible a (D b c) => Coercible b d => a -> D d e +givenCanonicalDiffTyVarEq1 = coerce + +givenCanonicalDiffTyVarEq2 :: forall f g a b. Coercible a (f b) => Coercible f g => Proxy f -> a -> g b +givenCanonicalDiffTyVarEq2 _ = coerce + newtype NTD a b c d = NTD (D b d) dToNTD :: forall i j k l. D j l -> NTD i (Id1 j) k (Phantom1 l k) @@ -149,9 +189,12 @@ rec7ToRec7 = coerce type Rec8 r a = { f :: a | r } -rec8ToRec8 :: ∀ r. Rec8 r Int -> Rec8 r (Id1 Int) +rec8ToRec8 :: forall r. Rec8 r Int -> Rec8 r (Id1 Int) rec8ToRec8 = coerce +rec8ToRec8' :: forall r s. Coercible r s => Rec8 r Int -> Rec8 s (Id1 Int) +rec8ToRec8' = coerce + data Arr1 a b = Arr1 (Array a) (Array b) arr1ToArr1 :: Arr1 Int String -> Arr1 (Id1 Int) (Id2 String) @@ -178,9 +221,12 @@ data MyMap k v = MyMap k v type role MyMap nominal representational -mapToMap :: MyMap String String -> MyMap String NTString1 +mapToMap :: forall k1 k2 a b. Coercible (MyMap k1 a) (MyMap k2 b) => MyMap k1 a -> MyMap k2 b mapToMap = coerce +mapStringToMapString :: MyMap String String -> MyMap String NTString1 +mapStringToMapString = mapToMap + class Unary a data Constrained1 a b = Constrained1 (Unary a => b) @@ -211,6 +257,13 @@ type ContextualKeywords = , role :: String ) +newtype RecursiveRepresentational a + = RecursiveRepresentational (RecursiveRepresentational a) +type role RecursiveRepresentational representational + +recursiveRepresentational :: forall a b. Coercible a b => RecursiveRepresentational a -> RecursiveRepresentational b +recursiveRepresentational = coerce + data MutuallyRecursivePhantom1 a = MutuallyRecursivePhantom1 (MutuallyRecursivePhantom2 a) diff --git a/tests/purs/passing/Coercible/Lib.purs b/tests/purs/passing/Coercible/Lib.purs index 6abd3c7b4e..cca268cfba 100644 --- a/tests/purs/passing/Coercible/Lib.purs +++ b/tests/purs/passing/Coercible/Lib.purs @@ -1,5 +1,12 @@ module Coercible.Lib - ( NTLib (..) + ( module Coercible.Lib2 + , NTLib1 (..) + , NTLib3 (..) ) where -newtype NTLib a = NTLib a +import Coercible.Lib2 + +newtype NTLib1 a = NTLib1 a + +newtype NTLib3 a b = NTLib3 a +type role NTLib3 representational representational diff --git a/tests/purs/passing/Coercible/Lib2.purs b/tests/purs/passing/Coercible/Lib2.purs new file mode 100644 index 0000000000..3fdef618d6 --- /dev/null +++ b/tests/purs/passing/Coercible/Lib2.purs @@ -0,0 +1,3 @@ +module Coercible.Lib2 where + +newtype NTLib2 a = NTLib2 a From 8663d00a27c2c36e229f3d2f98358e660c297335 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 19 Dec 2020 14:46:05 +0000 Subject: [PATCH 1253/1580] Update version to 0.14.0-rc4 (#3969) --- app/Version.hs | 2 +- package.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/app/Version.hs b/app/Version.hs index a318c0e9b8..4beb5c50d3 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -17,7 +17,7 @@ import qualified Development.GitRev as GitRev -- prerelease identifier here (if any). When releasing a proper version, simply -- set this to an empty string. prerelease :: String -prerelease = "-rc3" +prerelease = "-rc4" versionString :: String versionString = showVersion Paths.version ++ prerelease ++ extra diff --git a/package.yaml b/package.yaml index 34db54431c..37cb7c3050 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.14.0-rc3' # note: when updating this, update the prerelease identifier in app/Version.hs too! +version: '0.14.0-rc4' # note: when updating this, update the prerelease identifier in app/Version.hs too! synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 3799cab67f1a05afa21eea8fd169a9d351b9cf10 Mon Sep 17 00:00:00 2001 From: Fyodor Soikin Date: Tue, 22 Dec 2020 21:54:58 -0500 Subject: [PATCH 1254/1580] Update license-related error messages (#3970) * Update license-related error messages * Examples * Conform style, contributors.md --- CONTRIBUTORS.md | 1 + .../PureScript/Publish/ErrorsWarnings.hs | 45 ++++++++++--------- 2 files changed, 26 insertions(+), 20 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 71f41bc4b1..81053e8f55 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -51,6 +51,7 @@ If you would prefer to use different terms, please use the section below instead | [@fehrenbach](https://github.com/fehrenbach) | Stefan Fehrenbach | [MIT license](http://opensource.org/licenses/MIT) | | [@felixSchl](https://github.com/felixSchl) | Felix Schlitter | [MIT license](http://opensource.org/licenses/MIT) | | [@FrigoEU](https://github.com/FrigoEU) | Simon Van Casteren | [MIT license](http://opensource.org/licenses/MIT) | +| [@fsoikin](https://github.com/fsoikin) | Fyodor Soikin | [MIT license](http://opensource.org/licenses/MIT) | | [@garyb](https://github.com/garyb) | Gary Burgess | [MIT license](http://opensource.org/licenses/MIT) | | [@hdgarrood](https://github.com/hdgarrood) | Harry Garrood | [MIT license](http://opensource.org/licenses/MIT) | | [@houli](https://github.com/houli) | Eoin Houlihan | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 41d9cd8e93..4780ffa73f 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -166,32 +166,37 @@ displayUserError e = case e of displayRepositoryError err NoLicenseSpecified -> vcat $ - [ para (concat - [ "No license is specified in package manifest. Please add one, using the " - , "SPDX license expression format. For example, any of the " - , "following would be acceptable:" - ]) + [ para $ concat + [ "No license is specified in package manifest. Please add a " + , "\"license\" property with a SPDX license expression. For example, " + , "any of the following would be acceptable:" + ] , spacer ] ++ spdxExamples ++ [ spacer - , para ( - "Note that distributing code without a license means that nobody " - ++ "will (legally) be able to use it." - ) + , para $ concat + [ "See https://spdx.org/licenses/ for a full list of licenses. For more " + , "information on SPDX license expressions, see https://spdx.org/ids-how" + ] , spacer - , para (concat + , para $ concat + [ "Note that distributing code without a license means that nobody will " + , "(legally) be able to use it." + ] + , spacer + , para $ concat [ "It is also recommended to add a LICENSE file to the repository, " - , "including your name and the current year, although this is not " - , "necessary." - ]) + , "including your name and the current year, although this is not necessary." + ] ] InvalidLicense -> vcat $ - [ para (concat - [ "The license specified in package manifest is not a valid SPDX license " - , "expression. Please use the SPDX license expression format. For " - , "example, any of the following would be acceptable:" - ]) + [ para $ concat + [ "The license specified in package manifest is not a valid SPDX " + , "license expression. Please update the \"license\" property so that " + , "it is a valid SPDX license expression. For example, any of the " + , "following would be acceptable:" + ] , spacer ] ++ spdxExamples @@ -228,8 +233,8 @@ spdxExamples = [ "* \"MIT\"" , "* \"Apache-2.0\"" , "* \"BSD-2-Clause\"" - , "* \"GPL-2.0+\"" - , "* \"(GPL-3.0 OR MIT)\"" + , "* \"GPL-2.0-or-later\"" + , "* \"(GPL-3.0-only OR MIT)\"" ] displayRepositoryError :: RepositoryFieldError -> Box From d056c120821cc11f654cf15071cc0b43e98463f8 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 26 Dec 2020 07:59:40 -0500 Subject: [PATCH 1255/1580] Fix operator qualifier reversal bug (#3971) The relatively unusual combination of a multi-part qualifier and an operator used as a symbol--i.e., Foo.Bar.(!)--was previously being wrongly interpreted as Bar.Foo.(!). --- .../src/Language/PureScript/CST/Lexer.hs | 2 +- tests/purs/failing/QualifiedOperators.out | 10 ++++++++++ tests/purs/failing/QualifiedOperators.purs | 4 ++++ tests/purs/failing/QualifiedOperators2.out | 10 ++++++++++ tests/purs/failing/QualifiedOperators2.purs | 4 ++++ tests/purs/passing/QualifiedOperators.purs | 13 +++++++++++++ tests/purs/passing/QualifiedOperators/Foo.purs | 8 ++++++++ 7 files changed, 50 insertions(+), 1 deletion(-) create mode 100644 tests/purs/failing/QualifiedOperators.out create mode 100644 tests/purs/failing/QualifiedOperators.purs create mode 100644 tests/purs/failing/QualifiedOperators2.out create mode 100644 tests/purs/failing/QualifiedOperators2.purs create mode 100644 tests/purs/passing/QualifiedOperators.purs create mode 100644 tests/purs/passing/QualifiedOperators/Foo.purs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs index 64c8212a64..ceeab1cd64 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs @@ -322,7 +322,7 @@ token = peek >>= maybe (pure TokEof) k0 peek >>= \case Just ')' | isReservedSymbol chs -> throw ErrReservedSymbol - | otherwise -> next $> TokSymbolName qual chs + | otherwise -> next $> TokSymbolName (reverse qual) chs Just ch2 -> throw $ ErrLexeme (Just [ch2]) [] Nothing -> throw ErrEof Just ch -> throw $ ErrLexeme (Just [ch]) [] diff --git a/tests/purs/failing/QualifiedOperators.out b/tests/purs/failing/QualifiedOperators.out new file mode 100644 index 0000000000..25f703dbdc --- /dev/null +++ b/tests/purs/failing/QualifiedOperators.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/QualifiedOperators.purs:4:10 - 4:21 (line 4, column 10 - line 4, column 21) + + Unknown module Foo.Bar + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/QualifiedOperators.purs b/tests/purs/failing/QualifiedOperators.purs new file mode 100644 index 0000000000..36d80e12f5 --- /dev/null +++ b/tests/purs/failing/QualifiedOperators.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith UnknownName +module Main where + +test = 4 Foo.Bar.-#- 10 diff --git a/tests/purs/failing/QualifiedOperators2.out b/tests/purs/failing/QualifiedOperators2.out new file mode 100644 index 0000000000..5de5724b29 --- /dev/null +++ b/tests/purs/failing/QualifiedOperators2.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/QualifiedOperators2.purs:4:8 - 4:21 (line 4, column 8 - line 4, column 21) + + Unknown module Foo.Bar + + +See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/QualifiedOperators2.purs b/tests/purs/failing/QualifiedOperators2.purs new file mode 100644 index 0000000000..62d908d7f5 --- /dev/null +++ b/tests/purs/failing/QualifiedOperators2.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith UnknownName +module Main where + +test = Foo.Bar.(-#-) 4 10 diff --git a/tests/purs/passing/QualifiedOperators.purs b/tests/purs/passing/QualifiedOperators.purs new file mode 100644 index 0000000000..23e54729e3 --- /dev/null +++ b/tests/purs/passing/QualifiedOperators.purs @@ -0,0 +1,13 @@ +module Main where + +import Prelude + +import Effect.Console (log) +import Test.Assert (assert) + +import Foo as Foo.Bar + +main = do + assert $ 4 Foo.Bar.-#- 10 == 33 + assert $ Foo.Bar.(-#-) 4 10 == 33 + log "Done" diff --git a/tests/purs/passing/QualifiedOperators/Foo.purs b/tests/purs/passing/QualifiedOperators/Foo.purs new file mode 100644 index 0000000000..0d8ef9cdaf --- /dev/null +++ b/tests/purs/passing/QualifiedOperators/Foo.purs @@ -0,0 +1,8 @@ +module Foo where + +import Prelude + +tie :: Int -> Int -> Int +tie a b = (a - 1) * (b + 1) + +infix 5 tie as -#- From 62c5862430f91a9249046487bd80bd058b3df915 Mon Sep 17 00:00:00 2001 From: milesfrain Date: Sun, 27 Dec 2020 05:31:58 -0800 Subject: [PATCH 1256/1580] Refactor Ord instances (#3902) * Common code for Ord DeclarationRef * Use orderOf for compareType * Shrink Binder Eq and Ord --- .../src/Language/PureScript/AST/Binders.hs | 116 ++++++------------ .../Language/PureScript/AST/Declarations.hs | 51 +++----- .../src/Language/PureScript/Types.hs | 65 +++------- src/Language/PureScript/Ide/Imports.hs | 2 +- src/Language/PureScript/Linter/Imports.hs | 4 +- tests/purs/warning/DuplicateExportRef.out | 8 +- tests/purs/warning/DuplicateImportRef.out | 8 +- 7 files changed, 84 insertions(+), 170 deletions(-) diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs b/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs index 528ffb0987..01f9d5e129 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs @@ -71,100 +71,62 @@ data Binder -- the `Ord` instance was needed for the speed-up, but I did not want the `Eq` -- to have mismatched behavior. instance Eq Binder where - (==) NullBinder NullBinder = True - (==) NullBinder _ = False - - (==) (LiteralBinder _ lb) (LiteralBinder _ lb') = (==) lb lb' - (==) LiteralBinder{} _ = False - - (==) (VarBinder _ ident) (VarBinder _ ident') = (==) ident ident' - (==) VarBinder{} _ = False - - (==) (ConstructorBinder _ qpc bs) (ConstructorBinder _ qpc' bs') = - (==) qpc qpc' && (==) bs bs' - (==) ConstructorBinder{} _ = False - - (==) (OpBinder _ qov) (OpBinder _ qov') = - (==) qov qov' - (==) OpBinder{} _ = False - - (==) (BinaryNoParensBinder b1 b2 b3) (BinaryNoParensBinder b1' b2' b3') = - (==) b1 b1' && (==) b2 b2' && (==) b3 b3' - (==) BinaryNoParensBinder{} _ = False - - (==) (ParensInBinder b) (ParensInBinder b') = - (==) b b' - (==) ParensInBinder{} _ = False - - (==) (NamedBinder _ ident b) (NamedBinder _ ident' b') = - (==) ident ident' && (==) b b' - (==) NamedBinder{} _ = False - - (==) (PositionedBinder _ comments b) (PositionedBinder _ comments' b') = - (==) comments comments' && (==) b b' - (==) PositionedBinder{} _ = False - - (==) (TypedBinder ty b) (TypedBinder ty' b') = - (==) ty ty' && (==) b b' - (==) TypedBinder{} _ = False + NullBinder == NullBinder = + True + (LiteralBinder _ lb) == (LiteralBinder _ lb') = + lb == lb' + (VarBinder _ ident) == (VarBinder _ ident') = + ident == ident' + (ConstructorBinder _ qpc bs) == (ConstructorBinder _ qpc' bs') = + qpc == qpc' && bs == bs' + (OpBinder _ qov) == (OpBinder _ qov') = + qov == qov' + (BinaryNoParensBinder b1 b2 b3) == (BinaryNoParensBinder b1' b2' b3') = + b1 == b1' && b2 == b2' && b3 == b3' + (ParensInBinder b) == (ParensInBinder b') = + b == b' + (NamedBinder _ ident b) == (NamedBinder _ ident' b') = + ident == ident' && b == b' + (PositionedBinder _ comments b) == (PositionedBinder _ comments' b') = + comments == comments' && b == b' + (TypedBinder ty b) == (TypedBinder ty' b') = + ty == ty' && b == b' + _ == _ = False instance Ord Binder where compare NullBinder NullBinder = EQ - compare NullBinder _ = LT - - compare (LiteralBinder _ lb) (LiteralBinder _ lb') = compare lb lb' - compare LiteralBinder{} NullBinder = GT - compare LiteralBinder{} _ = LT - - compare (VarBinder _ ident) (VarBinder _ ident') = compare ident ident' - compare VarBinder{} NullBinder = GT - compare VarBinder{} LiteralBinder{} = GT - compare VarBinder{} _ = LT - + compare (LiteralBinder _ lb) (LiteralBinder _ lb') = + compare lb lb' + compare (VarBinder _ ident) (VarBinder _ ident') = + compare ident ident' compare (ConstructorBinder _ qpc bs) (ConstructorBinder _ qpc' bs') = compare qpc qpc' <> compare bs bs' - compare ConstructorBinder{} NullBinder = GT - compare ConstructorBinder{} LiteralBinder{} = GT - compare ConstructorBinder{} VarBinder{} = GT - compare ConstructorBinder{} _ = LT - compare (OpBinder _ qov) (OpBinder _ qov') = compare qov qov' - compare OpBinder{} NullBinder = GT - compare OpBinder{} LiteralBinder{} = GT - compare OpBinder{} VarBinder{} = GT - compare OpBinder{} ConstructorBinder{} = GT - compare OpBinder{} _ = LT - compare (BinaryNoParensBinder b1 b2 b3) (BinaryNoParensBinder b1' b2' b3') = compare b1 b1' <> compare b2 b2' <> compare b3 b3' - compare BinaryNoParensBinder{} ParensInBinder{} = LT - compare BinaryNoParensBinder{} NamedBinder{} = LT - compare BinaryNoParensBinder{} PositionedBinder{} = LT - compare BinaryNoParensBinder{} TypedBinder{} = LT - compare BinaryNoParensBinder{} _ = GT - compare (ParensInBinder b) (ParensInBinder b') = compare b b' - compare ParensInBinder{} NamedBinder{} = LT - compare ParensInBinder{} PositionedBinder{} = LT - compare ParensInBinder{} TypedBinder{} = LT - compare ParensInBinder{} _ = GT - compare (NamedBinder _ ident b) (NamedBinder _ ident' b') = compare ident ident' <> compare b b' - compare NamedBinder{} PositionedBinder{} = LT - compare NamedBinder{} TypedBinder{} = LT - compare NamedBinder{} _ = GT - compare (PositionedBinder _ comments b) (PositionedBinder _ comments' b') = compare comments comments' <> compare b b' - compare PositionedBinder{} TypedBinder{} = LT - compare PositionedBinder{} _ = GT - compare (TypedBinder ty b) (TypedBinder ty' b') = compare ty ty' <> compare b b' - compare TypedBinder{} _ = GT + compare binder binder' = + compare (orderOf binder) (orderOf binder') + where + orderOf :: Binder -> Int + orderOf NullBinder = 0 + orderOf LiteralBinder{} = 1 + orderOf VarBinder{} = 2 + orderOf ConstructorBinder{} = 3 + orderOf OpBinder{} = 4 + orderOf BinaryNoParensBinder{} = 5 + orderOf ParensInBinder{} = 6 + orderOf NamedBinder{} = 7 + orderOf PositionedBinder{} = 8 + orderOf TypedBinder{} = 9 -- | -- Collect all names introduced in binders in an expression diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs index 84ebd129e5..52e673427b 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs @@ -149,14 +149,18 @@ importPrim = -- data DeclarationRef -- | - -- A type constructor with data constructors + -- A type class -- - = TypeRef SourceSpan (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName]) + = TypeClassRef SourceSpan (ProperName 'ClassName) -- | -- A type operator -- | TypeOpRef SourceSpan (OpName 'TypeOpName) -- | + -- A type constructor with data constructors + -- + | TypeRef SourceSpan (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName]) + -- | -- A value -- | ValueRef SourceSpan Ident @@ -165,10 +169,6 @@ data DeclarationRef -- | ValueOpRef SourceSpan (OpName 'ValueOpName) -- | - -- A type class - -- - | TypeClassRef SourceSpan (ProperName 'ClassName) - -- | -- A type class instance, created during typeclass desugaring (name, class name, instance types) -- | TypeInstanceRef SourceSpan Ident @@ -184,22 +184,22 @@ data DeclarationRef deriving (Show, Generic, NFData, Serialise) instance Eq DeclarationRef where - (TypeRef _ name dctors) == (TypeRef _ name' dctors') = name == name' && dctors == dctors' + (TypeClassRef _ name) == (TypeClassRef _ name') = name == name' (TypeOpRef _ name) == (TypeOpRef _ name') = name == name' + (TypeRef _ name dctors) == (TypeRef _ name' dctors') = name == name' && dctors == dctors' (ValueRef _ name) == (ValueRef _ name') = name == name' (ValueOpRef _ name) == (ValueOpRef _ name') = name == name' - (TypeClassRef _ name) == (TypeClassRef _ name') = name == name' (TypeInstanceRef _ name) == (TypeInstanceRef _ name') = name == name' (ModuleRef _ name) == (ModuleRef _ name') = name == name' (ReExportRef _ mn ref) == (ReExportRef _ mn' ref') = mn == mn' && ref == ref' _ == _ = False instance Ord DeclarationRef where - TypeRef _ name dctors `compare` TypeRef _ name' dctors' = compare name name' <> compare dctors dctors' + TypeClassRef _ name `compare` TypeClassRef _ name' = compare name name' TypeOpRef _ name `compare` TypeOpRef _ name' = compare name name' + TypeRef _ name dctors `compare` TypeRef _ name' dctors' = compare name name' <> compare dctors dctors' ValueRef _ name `compare` ValueRef _ name' = compare name name' ValueOpRef _ name `compare` ValueOpRef _ name' = compare name name' - TypeClassRef _ name `compare` TypeClassRef _ name' = compare name name' TypeInstanceRef _ name `compare` TypeInstanceRef _ name' = compare name name' ModuleRef _ name `compare` ModuleRef _ name' = compare name name' ReExportRef _ mn ref `compare` ReExportRef _ mn' ref' = compare mn mn' <> compare ref ref' @@ -207,11 +207,11 @@ instance Ord DeclarationRef where compare (orderOf ref) (orderOf ref') where orderOf :: DeclarationRef -> Int - orderOf TypeRef{} = 0 + orderOf TypeClassRef{} = 0 orderOf TypeOpRef{} = 1 - orderOf ValueRef{} = 2 - orderOf ValueOpRef{} = 3 - orderOf TypeClassRef{} = 4 + orderOf TypeRef{} = 2 + orderOf ValueRef{} = 3 + orderOf ValueOpRef{} = 4 orderOf TypeInstanceRef{} = 5 orderOf ModuleRef{} = 6 orderOf ReExportRef{} = 7 @@ -223,29 +223,6 @@ data ExportSource = } deriving (Eq, Ord, Show, Generic, NFData, Serialise) --- enable sorting lists of explicitly imported refs when suggesting imports in linting, IDE, etc. --- not an Ord because this implementation is not consistent with its Eq instance. --- think of it as a notion of contextual, not inherent, ordering. -compDecRef :: DeclarationRef -> DeclarationRef -> Ordering -compDecRef (TypeRef _ name _) (TypeRef _ name' _) = compare name name' -compDecRef (TypeOpRef _ name) (TypeOpRef _ name') = compare name name' -compDecRef (ValueRef _ ident) (ValueRef _ ident') = compare ident ident' -compDecRef (ValueOpRef _ name) (ValueOpRef _ name') = compare name name' -compDecRef (TypeClassRef _ name) (TypeClassRef _ name') = compare name name' -compDecRef (TypeInstanceRef _ ident) (TypeInstanceRef _ ident') = compare ident ident' -compDecRef (ModuleRef _ name) (ModuleRef _ name') = compare name name' -compDecRef (ReExportRef _ name _) (ReExportRef _ name' _) = compare name name' -compDecRef ref ref' = compare - (orderOf ref) (orderOf ref') - where - orderOf :: DeclarationRef -> Int - orderOf TypeClassRef{} = 0 - orderOf TypeOpRef{} = 1 - orderOf TypeRef{} = 2 - orderOf ValueRef{} = 3 - orderOf ValueOpRef{} = 4 - orderOf _ = 6 - declRefSourceSpan :: DeclarationRef -> SourceSpan declRefSourceSpan (TypeRef ss _ _) = ss declRefSourceSpan (TypeOpRef ss _) = ss diff --git a/lib/purescript-ast/src/Language/PureScript/Types.hs b/lib/purescript-ast/src/Language/PureScript/Types.hs index f221d3619d..83be8fe8db 100644 --- a/lib/purescript-ast/src/Language/PureScript/Types.hs +++ b/lib/purescript-ast/src/Language/PureScript/Types.hs @@ -728,66 +728,41 @@ eqMaybeType _ _ = False compareType :: Type a -> Type b -> Ordering compareType (TUnknown _ a) (TUnknown _ a') = compare a a' -compareType (TUnknown {}) _ = LT - compareType (TypeVar _ a) (TypeVar _ a') = compare a a' -compareType (TypeVar {}) _ = LT -compareType _ (TypeVar {}) = GT - compareType (TypeLevelString _ a) (TypeLevelString _ a') = compare a a' -compareType (TypeLevelString {}) _ = LT -compareType _ (TypeLevelString {}) = GT - compareType (TypeWildcard _ a) (TypeWildcard _ a') = compare a a' -compareType (TypeWildcard {}) _ = LT -compareType _ (TypeWildcard {}) = GT - compareType (TypeConstructor _ a) (TypeConstructor _ a') = compare a a' -compareType (TypeConstructor {}) _ = LT -compareType _ (TypeConstructor {}) = GT - compareType (TypeOp _ a) (TypeOp _ a') = compare a a' -compareType (TypeOp {}) _ = LT -compareType _ (TypeOp {}) = GT - compareType (TypeApp _ a b) (TypeApp _ a' b') = compareType a a' <> compareType b b' -compareType (TypeApp {}) _ = LT -compareType _ (TypeApp {}) = GT - compareType (KindApp _ a b) (KindApp _ a' b') = compareType a a' <> compareType b b' -compareType (KindApp {}) _ = LT -compareType _ (KindApp {}) = GT - compareType (ForAll _ a b c d) (ForAll _ a' b' c' d') = compare a a' <> compareMaybeType b b' <> compareType c c' <> compare d d' -compareType (ForAll {}) _ = LT -compareType _ (ForAll {}) = GT - compareType (ConstrainedType _ a b) (ConstrainedType _ a' b') = compareConstraint a a' <> compareType b b' -compareType (ConstrainedType {}) _ = LT -compareType _ (ConstrainedType {}) = GT - compareType (Skolem _ a b c d) (Skolem _ a' b' c' d') = compare a a' <> compareMaybeType b b' <> compare c c' <> compare d d' -compareType (Skolem {}) _ = LT -compareType _ (Skolem {}) = GT - compareType (REmpty _) (REmpty _) = EQ -compareType (REmpty _) _ = LT -compareType _ (REmpty _) = GT - compareType (RCons _ a b c) (RCons _ a' b' c') = compare a a' <> compareType b b' <> compareType c c' -compareType (RCons {}) _ = LT -compareType _ (RCons {}) = GT - compareType (KindedType _ a b) (KindedType _ a' b') = compareType a a' <> compareType b b' -compareType (KindedType {}) _ = LT -compareType _ (KindedType {}) = GT - compareType (BinaryNoParensType _ a b c) (BinaryNoParensType _ a' b' c') = compareType a a' <> compareType b b' <> compareType c c' -compareType (BinaryNoParensType {}) _ = LT -compareType _ (BinaryNoParensType {}) = GT - compareType (ParensInType _ a) (ParensInType _ a') = compareType a a' -compareType (ParensInType {}) _ = GT +compareType typ typ' = + compare (orderOf typ) (orderOf typ') + where + orderOf :: Type a -> Int + orderOf TUnknown{} = 0 + orderOf TypeVar{} = 1 + orderOf TypeLevelString{} = 2 + orderOf TypeWildcard{} = 3 + orderOf TypeConstructor{} = 4 + orderOf TypeOp{} = 5 + orderOf TypeApp{} = 6 + orderOf KindApp{} = 7 + orderOf ForAll{} = 8 + orderOf ConstrainedType{} = 9 + orderOf Skolem{} = 10 + orderOf REmpty{} = 11 + orderOf RCons{} = 12 + orderOf KindedType{} = 13 + orderOf BinaryNoParensType{} = 14 + orderOf ParensInType{} = 15 compareMaybeType :: Maybe (Type a) -> Maybe (Type b) -> Ordering compareMaybeType (Just a) (Just b) = compareType a b diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 5afc7ccde6..69a8d68e53 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -229,7 +229,7 @@ addExplicitImport' decl moduleName qualifier imports = -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) insertDeclIntoImport :: IdeDeclaration -> Import -> Import insertDeclIntoImport decl' (Import mn (P.Explicit refs) qual) = - Import mn (P.Explicit (sortBy P.compDecRef (insertDeclIntoRefs decl' refs))) qual + Import mn (P.Explicit (sort (insertDeclIntoRefs decl' refs))) qual insertDeclIntoImport _ is = is insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef] diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 69dc204368..b4d25ba011 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -12,7 +12,7 @@ import Control.Monad.Writer.Class import Data.Function (on) import Data.Foldable (for_) -import Data.List (find, intersect, groupBy, sortBy, (\\)) +import Data.List (find, intersect, groupBy, sort, sortBy, (\\)) import Data.Maybe (mapMaybe) import Data.Monoid (Sum(..)) import Data.Traversable (forM) @@ -334,7 +334,7 @@ findUsedRefs ss env mni qn names = typesRefs = map (flip (TypeRef ss) (Just [])) typesWithoutDctors ++ map (\(ty, ds) -> TypeRef ss ty (Just ds)) (M.toList typesWithDctors) - in sortBy compDecRef $ classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs + in sort $ classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs where diff --git a/tests/purs/warning/DuplicateExportRef.out b/tests/purs/warning/DuplicateExportRef.out index 82efd3bf36..385bf8cfb2 100644 --- a/tests/purs/warning/DuplicateExportRef.out +++ b/tests/purs/warning/DuplicateExportRef.out @@ -3,7 +3,7 @@ Warning 1 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) - Export list contains multiple references to type X + Export list contains multiple references to type class Y See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, @@ -25,7 +25,7 @@ Warning 3 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) - Export list contains multiple references to value fn + Export list contains multiple references to type X See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, @@ -36,7 +36,7 @@ Warning 4 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) - Export list contains multiple references to operator (!) + Export list contains multiple references to value fn See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, @@ -47,7 +47,7 @@ Warning 5 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) - Export list contains multiple references to type class Y + Export list contains multiple references to operator (!) See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, diff --git a/tests/purs/warning/DuplicateImportRef.out b/tests/purs/warning/DuplicateImportRef.out index 0e5f7101b9..c1ce0ba695 100644 --- a/tests/purs/warning/DuplicateImportRef.out +++ b/tests/purs/warning/DuplicateImportRef.out @@ -3,7 +3,7 @@ Warning 1 of 4: in module Main at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) - Import list contains multiple references to type Unit + Import list contains multiple references to type class Functor See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, @@ -14,7 +14,7 @@ Warning 2 of 4: in module Main at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) - Import list contains multiple references to value unit + Import list contains multiple references to type Unit See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, @@ -25,7 +25,7 @@ Warning 3 of 4: in module Main at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) - Import list contains multiple references to operator (<>) + Import list contains multiple references to value unit See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, @@ -36,7 +36,7 @@ Warning 4 of 4: in module Main at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) - Import list contains multiple references to type class Functor + Import list contains multiple references to operator (<>) See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, From a3daf5b26e9ab692758b7df970fb0b00c67791f8 Mon Sep 17 00:00:00 2001 From: Fyodor Soikin Date: Sun, 27 Dec 2020 13:48:53 -0500 Subject: [PATCH 1257/1580] Don't implement Newtype methods when deriving (#3975) * Don't implement Newtype methods when deriving * Debug cruft * Hash * Return type --- .../PureScript/Sugar/TypeClasses/Deriving.hs | 31 ++++++------------- .../purescript-newtype/src/Data/Newtype.purs | 7 +++-- tests/purs/passing/GenericsRep.purs | 2 +- tests/purs/passing/NewtypeClass.purs | 18 ++++++----- tests/purs/passing/RowsInInstanceContext.purs | 7 +++-- tests/purs/passing/SolvingAppendSymbol.purs | 28 ++++++++--------- tests/purs/passing/SolvingCompareSymbol.purs | 18 +++++------ .../publish/basic-example/resolutions.json | 6 ++++ tests/support/bower.json | 22 +++++++------ 9 files changed, 71 insertions(+), 68 deletions(-) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index f23a84becb..c0f6c0ee9b 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -146,8 +146,8 @@ deriveInstance mn syns kinds _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm [wrappedTy, unwrappedTy] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy , mn == fromMaybe mn mn' - -> do (inst, actualUnwrappedTy) <- deriveNewtype ss mn syns kinds ds tyCon args unwrappedTy - return $ TypeInstanceDeclaration sa ch idx nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) + -> do actualUnwrappedTy <- deriveNewtype ss syns kinds ds tyCon args unwrappedTy + return $ TypeInstanceDeclaration sa ch idx nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance []) | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys wrappedTy _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 | className == DataGenericRep.Generic @@ -558,39 +558,26 @@ deriveNewtype :: forall m . (MonadError MultipleErrors m, MonadSupply m) => SourceSpan - -> ModuleName -> SynonymMap -> KindMap -> [Declaration] -> ProperName 'TypeName -> [SourceType] -> SourceType - -> m ([Declaration], SourceType) -deriveNewtype ss mn syns kinds ds tyConNm tyConArgs unwrappedTy = do + -> m SourceType +deriveNewtype ss syns kinds ds tyConNm tyConArgs unwrappedTy = do checkIsWildcard ss tyConNm unwrappedTy go =<< findTypeDecl ss tyConNm ds where - go :: Declaration -> m ([Declaration], SourceType) + go :: Declaration -> m SourceType go (DataDeclaration (ss', _) Data name _ _) = throwError . errorMessage' ss' $ CannotDeriveNewtypeForData name - go (DataDeclaration (ss', _) Newtype name args dctors) = do + go (DataDeclaration _ Newtype name args dctors) = do checkNewtype name dctors - wrappedIdent <- freshIdent "n" - unwrappedIdent <- freshIdent "a" - let (DataConstructorDeclaration _ ctorName [(_, ty)]) = head dctors + let (DataConstructorDeclaration _ _ [(_, ty)]) = head dctors ty' <- replaceAllTypeSynonymsM syns kinds ty - let inst = - [ ValueDecl (ss', []) (Ident "wrap") Public [] $ unguarded $ - Constructor ss' (Qualified (Just mn) ctorName) - , ValueDecl (ss', []) (Ident "unwrap") Public [] $ unguarded $ - lamCase ss' wrappedIdent - [ CaseAlternative - [ConstructorBinder ss' (Qualified (Just mn) ctorName) [VarBinder ss' unwrappedIdent]] - (unguarded (Var ss' (Qualified Nothing unwrappedIdent))) - ] - ] - subst = zipWith ((,) . fst) args tyConArgs - return (inst, replaceAllTypeVars subst ty') + let subst = zipWith ((,) . fst) args tyConArgs + return $ replaceAllTypeVars subst ty' go _ = internalError "deriveNewtype go: expected DataDeclaration" findTypeDecl diff --git a/tests/purs/docs/bower_components/purescript-newtype/src/Data/Newtype.purs b/tests/purs/docs/bower_components/purescript-newtype/src/Data/Newtype.purs index 6c17d64784..336e5b36ba 100644 --- a/tests/purs/docs/bower_components/purescript-newtype/src/Data/Newtype.purs +++ b/tests/purs/docs/bower_components/purescript-newtype/src/Data/Newtype.purs @@ -1,5 +1,6 @@ module Data.Newtype where -class Newtype t a | t -> a where - wrap :: a -> t - unwrap :: t -> a +import Prim.Coerce (class Coercible) + +class Newtype :: Type -> Type -> Constraint +class Coercible t a <= Newtype t a | t -> a diff --git a/tests/purs/passing/GenericsRep.purs b/tests/purs/passing/GenericsRep.purs index 3126768cf9..1535382ed9 100644 --- a/tests/purs/passing/GenericsRep.purs +++ b/tests/purs/passing/GenericsRep.purs @@ -4,7 +4,7 @@ import Prelude import Effect (Effect) import Effect.Console (log, logShow) import Data.Generic.Rep (class Generic) -import Data.Generic.Rep.Eq (genericEq) +import Data.Eq.Generic (genericEq) data X a = X a diff --git a/tests/purs/passing/NewtypeClass.purs b/tests/purs/passing/NewtypeClass.purs index 47ce815d7b..43799eb51e 100644 --- a/tests/purs/passing/NewtypeClass.purs +++ b/tests/purs/passing/NewtypeClass.purs @@ -3,16 +3,20 @@ module Main where import Prelude import Effect import Effect.Console +import Safe.Coerce (class Coercible, coerce) -class Newtype t a | t -> a where - wrap :: a -> t - unwrap :: t -> a +class Newtype :: Type -> Type -> Constraint +class Coercible t a <= Newtype t a | t -> a -instance newtypeMultiplicative :: Newtype (Multiplicative a) a where - wrap = Multiplicative - unwrap (Multiplicative a) = a +wrap :: forall t a. Newtype t a => a -> t +wrap = coerce -data Multiplicative a = Multiplicative a +unwrap :: forall t a. Newtype t a => t -> a +unwrap = coerce + +instance newtypeMultiplicative :: Newtype (Multiplicative a) a + +newtype Multiplicative a = Multiplicative a instance semiringMultiplicative :: Semiring a => Semigroup (Multiplicative a) where append (Multiplicative a) (Multiplicative b) = Multiplicative (a * b) diff --git a/tests/purs/passing/RowsInInstanceContext.purs b/tests/purs/passing/RowsInInstanceContext.purs index 19fa17f01b..5f18cefcdb 100644 --- a/tests/purs/passing/RowsInInstanceContext.purs +++ b/tests/purs/passing/RowsInInstanceContext.purs @@ -3,7 +3,6 @@ module Main where import Prelude import Effect (Effect) import Effect.Console (log) -import Data.Newtype (class Newtype, unwrap) class TypeEquals a b | a -> b, b -> a where coerce :: a -> b @@ -15,9 +14,13 @@ instance refl :: TypeEquals a a where newtype RecordNewtype = RecordNewtype { x :: String } +class OldStyleNewtype t a where + wrap :: a -> t + unwrap :: t -> a + instance newtypeRecordNewtype :: TypeEquals inner { x :: String } - => Newtype RecordNewtype inner where + => OldStyleNewtype RecordNewtype inner where wrap = RecordNewtype <<< coerce unwrap (RecordNewtype rec) = coerceBack rec diff --git a/tests/purs/passing/SolvingAppendSymbol.purs b/tests/purs/passing/SolvingAppendSymbol.purs index a1656dcea5..26d957bbe8 100644 --- a/tests/purs/passing/SolvingAppendSymbol.purs +++ b/tests/purs/passing/SolvingAppendSymbol.purs @@ -3,31 +3,31 @@ module Main where import Prelude import Effect.Console (log) import Prim.Symbol (class Append) -import Type.Data.Symbol (SProxy(..), reflectSymbol) -import Type.Data.Symbol (append) as Symbol +import Type.Proxy (Proxy(..)) +import Type.Data.Symbol (append, reflectSymbol) as Symbol -sym :: SProxy "" -sym = SProxy +sym :: Proxy "" +sym = Proxy -symA :: SProxy "A" -symA = SProxy +symA :: Proxy "A" +symA = Proxy -symB :: SProxy "B" -symB = SProxy +symB :: Proxy "B" +symB = Proxy -egAB :: SProxy "AB" +egAB :: Proxy "AB" egAB = Symbol.append symA symB -egBA :: SProxy "BA" +egBA :: Proxy "BA" egBA = Symbol.append symB symA -egA' :: SProxy "A" +egA' :: Proxy "A" egA' = Symbol.append sym (Symbol.append symA sym) main = do - let gotAB = reflectSymbol egAB == "AB" - gotBA = reflectSymbol egBA == "BA" - gotA' = reflectSymbol egA' == "A" + let gotAB = Symbol.reflectSymbol egAB == "AB" + gotBA = Symbol.reflectSymbol egBA == "BA" + gotA' = Symbol.reflectSymbol egA' == "A" when (not gotAB) $ log "Did not get AB" when (not gotBA) $ log "Did not get BA" when (not gotA') $ log "Did not get A" diff --git a/tests/purs/passing/SolvingCompareSymbol.purs b/tests/purs/passing/SolvingCompareSymbol.purs index 0b18b12fde..d5e03fc828 100644 --- a/tests/purs/passing/SolvingCompareSymbol.purs +++ b/tests/purs/passing/SolvingCompareSymbol.purs @@ -4,23 +4,23 @@ import Prelude import Effect.Console (log) import Prim.Symbol (class Compare) import Prim.Ordering (kind Ordering, LT, EQ, GT) -import Type.Data.Symbol (SProxy(..)) +import Type.Proxy (Proxy(..)) import Type.Data.Symbol (compare) as Symbol -import Type.Data.Ordering (OProxy(..), reflectOrdering) +import Type.Data.Ordering (reflectOrdering) -symA :: SProxy "A" -symA = SProxy +symA :: Proxy "A" +symA = Proxy -symB :: SProxy "B" -symB = SProxy +symB :: Proxy "B" +symB = Proxy -egLT :: OProxy LT +egLT :: Proxy LT egLT = Symbol.compare symA symB -egEQ :: OProxy EQ +egEQ :: Proxy EQ egEQ = Symbol.compare symA symA -egGT :: OProxy GT +egGT :: Proxy GT egGT = Symbol.compare symB symA main = do diff --git a/tests/purs/publish/basic-example/resolutions.json b/tests/purs/publish/basic-example/resolutions.json index 2e92161913..0cdda6f269 100644 --- a/tests/purs/publish/basic-example/resolutions.json +++ b/tests/purs/publish/basic-example/resolutions.json @@ -13,5 +13,11 @@ }, "purescript-newtype": { "path": "../../../support/bower_components/purescript-newtype" + }, + "purescript-safe-coerce": { + "path": "../../../support/bower_components/purescript-safe-coerce" + }, + "purescript-unsafe-coerce": { + "path": "../../../support/bower_components/purescript-unsafe-coerce" } } diff --git a/tests/support/bower.json b/tests/support/bower.json index 850a61c429..d54eaf6a21 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -12,7 +12,6 @@ "purescript-foldable-traversable": "4.0.0", "purescript-functions": "4.0.0", "purescript-gen": "2.0.0", - "purescript-generics-rep": "6.0.0", "purescript-globals": "4.0.0", "purescript-identity": "4.0.0", "purescript-integers": "4.0.0", @@ -21,25 +20,28 @@ "purescript-lists": "5.0.0", "purescript-math": "2.1.1", "purescript-maybe": "4.0.0", - "purescript-newtype": "3.0.0", + "purescript-newtype": "#debb7bdf5d712fb568eee16fae896fd2bc6087d0", "purescript-nonempty": "5.0.0", "purescript-partial": "2.0.0", - "purescript-prelude": "#c932361d008379958f14ca8cc2fe32e06cc2647d", - "purescript-proxy": "3.0.0", + "purescript-prelude": "#d3cdad16a1479403a3f14f94190868ba5e25c657", "purescript-psci-support": "4.0.0", "purescript-refs": "4.1.0", - "purescript-safe-coerce": "0.0.2", + "purescript-safe-coerce": "#46b3171f71ca5052de6411e383bef6abe80b3f86", "purescript-st": "4.0.0", "purescript-strings": "4.0.0", "purescript-tailrec": "4.0.0", "purescript-tuples": "5.0.0", - "purescript-type-equality": "3.0.0", - "purescript-typelevel-prelude": "#52ac4bcf9a38941606b3d928127089bd363ee946", + "purescript-type-equality": "#8be8f46e70074dd3ace313bd15227f26166e9675", + "purescript-typelevel-prelude": "#e1b1c9a73f5407c2b1b197d4776d8939129a2444", "purescript-unfoldable": "4.0.0", - "purescript-unsafe-coerce": "4.0.0" + "purescript-unsafe-coerce": "#76f1d3494a571b97a07f893a1e766f01f86f46f1" }, "resolutions": { - "purescript-prelude": "c932361d008379958f14ca8cc2fe32e06cc2647d", - "purescript-typelevel-prelude": "52ac4bcf9a38941606b3d928127089bd363ee946" + "purescript-newtype": "debb7bdf5d712fb568eee16fae896fd2bc6087d0", + "purescript-prelude": "d3cdad16a1479403a3f14f94190868ba5e25c657", + "purescript-safe-coerce": "46b3171f71ca5052de6411e383bef6abe80b3f86", + "purescript-type-equality": "8be8f46e70074dd3ace313bd15227f26166e9675", + "purescript-typelevel-prelude": "e1b1c9a73f5407c2b1b197d4776d8939129a2444", + "purescript-unsafe-coerce": "76f1d3494a571b97a07f893a1e766f01f86f46f1" } } From 53b323b6c8c0de00c1655e78cd09e4b3c0bb2b6b Mon Sep 17 00:00:00 2001 From: Cyril Date: Sun, 27 Dec 2020 20:40:37 +0100 Subject: [PATCH 1258/1580] Add hint about constructor not being in scope when the unwrapping rule fails (#3927) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Suggest to import newtype constructors when the unwrapping rules fail * Don’t require newtypes ctors to be exported to know they’re newtypes * Rename the error to MissingConstructorImportForCoercible * Turn the error into a hint --- .../Language/PureScript/AST/Declarations.hs | 1 + .../src/Language/PureScript/Environment.hs | 2 +- src/Language/PureScript/Errors.hs | 7 +++- src/Language/PureScript/Externs.hs | 2 +- src/Language/PureScript/Ide/CaseSplit.hs | 2 +- .../PureScript/Interactive/Printer.hs | 2 +- src/Language/PureScript/Linter/Exhaustive.hs | 2 +- src/Language/PureScript/Make.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 4 +- .../PureScript/TypeChecker/Entailment.hs | 16 +++++--- .../TypeChecker/Entailment/Coercible.hs | 37 +++++++++++-------- src/Language/PureScript/TypeChecker/Monad.hs | 4 +- src/Language/PureScript/TypeChecker/Roles.hs | 2 +- .../failing/CoercibleRepresentational6.out | 2 + .../failing/CoercibleRepresentational7.out | 2 + 15 files changed, 54 insertions(+), 33 deletions(-) diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs index 52e673427b..b7335b5247 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs @@ -83,6 +83,7 @@ data ErrorMessageHint | ErrorInRoleDeclaration (ProperName 'TypeName) | ErrorInForeignImport Ident | ErrorSolvingConstraint SourceConstraint + | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName)) | PositionedError (NEL.NonEmpty SourceSpan) deriving (Show) diff --git a/lib/purescript-ast/src/Language/PureScript/Environment.hs b/lib/purescript-ast/src/Language/PureScript/Environment.hs index 3a80d88524..97955e18d2 100644 --- a/lib/purescript-ast/src/Language/PureScript/Environment.hs +++ b/lib/purescript-ast/src/Language/PureScript/Environment.hs @@ -206,7 +206,7 @@ instance Serialise NameKind -- | The kinds of a type data TypeKind - = DataType [(Text, Maybe SourceType, Role)] [(ProperName 'ConstructorName, [SourceType])] + = DataType DataDeclType [(Text, Maybe SourceType, Role)] [(ProperName 'ConstructorName, [SourceType])] -- ^ Data type | TypeSynonym -- ^ Type synonym diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 10cb7349ed..ae799b6a4d 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1499,6 +1499,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) ] ] + renderHint (MissingConstructorImportForCoercible name) detail = + paras + [ detail + , Box.moveUp 1 $ Box.moveRight 2 $ line $ "Solving this instance requires the newtype constructor " <> markCode (showQualified runProperName name) <> " to be in scope." + ] renderHint (PositionedError srcSpan) detail = paras [ line $ "at " <> displaySourceSpan relPath (NEL.head srcSpan) , detail @@ -1619,7 +1624,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl where isUnifyHint ErrorUnifyingTypes{} = True isUnifyHint _ = False - stripRedundantHints (NoInstanceFound (Constraint _ C.Coercible _ args _)) = stripFirst isSolverHint + stripRedundantHints (NoInstanceFound (Constraint _ C.Coercible _ args _)) = filter (not . isSolverHint) where isSolverHint (ErrorSolvingConstraint (Constraint _ C.Coercible _ args' _)) = args == args' isSolverHint _ = False diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 9d3253bc3e..3f100ac68c 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -226,7 +226,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} Just (kind, TypeSynonym) | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ] Just (kind, ExternData rs) -> [ EDType pn kind (ExternData rs) ] - Just (kind, tk@(DataType _ tys)) -> + Just (kind, tk@(DataType _ _ tys)) -> EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args | dctor <- fromMaybe (map fst tys) dctors , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env) diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index a4b557ce36..57b225f280 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -76,7 +76,7 @@ findTypeDeclaration' -> First DataType findTypeDeclaration' t ExternsFile{..} = First $ head $ mapMaybe (\case - EDType tn _ (P.DataType typeVars ctors) + EDType tn _ (P.DataType _ typeVars ctors) | tn == t -> Just (typeVars, ctors) _ -> Nothing) efDeclarations diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index 665954ce43..a09597c052 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -103,7 +103,7 @@ printModuleSignatures moduleName P.Environment{..} = textT ("type " <> P.runProperName name <> foldMap ((" " <>) . fst) typevars) Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox maxBound dtType) - (Just (_, P.DataType typevars pt), _) -> + (Just (_, P.DataType _ typevars pt), _) -> let prefix = case pt of [(dtProperName,_)] -> diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index ffa3d8663c..e8ab59fde8 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -67,7 +67,7 @@ getConstructors env defmn n = extractConstructors lnte where extractConstructors :: Maybe (SourceType, TypeKind) -> [(ProperName 'ConstructorName, [SourceType])] - extractConstructors (Just (_, DataType _ pt)) = pt + extractConstructors (Just (_, DataType _ _ pt)) = pt extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors" lnte :: Maybe (SourceType, TypeKind) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index f7dd132bbe..101d95e052 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -82,7 +82,7 @@ rebuildModule' MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) = do let modulesExports = (\(_, _, exports) -> exports) <$> exEnv' (checked, CheckState{..}) <- runStateT (typeCheckModule modulesExports desugared) $ emptyCheckState env let usedImports' = foldl' (flip $ \(fromModuleName, newtypeCtorName) -> - M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName) usedImports checkCoercedNewtypeCtorsImports + M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName) usedImports checkConstructorImportsForCoercible -- Imports cannot be linted before type checking because we need to -- known which newtype constructors are used to solve Coercible -- constraints in order to not report them as unused. diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index a540152a23..ff873b7f4f 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -63,7 +63,7 @@ addDataType moduleName dtype name args dctors ctorKind = do let mapDataCtor (DataConstructorDeclaration _ ctorName vars) = (ctorName, snd <$> vars) qualName = (Qualified (Just moduleName) name) hasSig = qualName `M.member` types env - putEnv $ env { types = M.insert qualName (ctorKind, DataType args (map (mapDataCtor . fst) dctors)) (types env) } + putEnv $ env { types = M.insert qualName (ctorKind, DataType dtype args (map (mapDataCtor . fst) dctors)) (types env) } unless (hasSig || not (containsForAll ctorKind)) $ do tell . errorMessage $ MissingKindDeclaration (if dtype == Newtype then NewtypeSig else DataSig) name ctorKind for_ dctors $ \(DataConstructorDeclaration _ dctor fields, polyType) -> @@ -805,6 +805,6 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = = True isDictOfTypeRef _ = False getDataConstructorNames :: TypeKind -> Maybe [ProperName 'ConstructorName] - getDataConstructorNames (DataType _ constructors) = Just $ fst <$> constructors + getDataConstructorNames (DataType _ _ constructors) = Just $ fst <$> constructors getDataConstructorNames _ = Nothing checkDataConstructorsAreExported _ = return () diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index ca63876a96..c6e8dbf736 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -24,7 +24,7 @@ import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.Functor (($>)) import Data.List (minimumBy, groupBy, nubBy, sortBy) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S import Data.Traversable (for) @@ -394,13 +394,17 @@ entails SolverOptions{..} constraint context hints = | otherwise -> Nothing GivenSolverState{ inertGivens } <- execStateT (solveGivens env) $ initialGivenSolverState givens - WantedSolverState{ inertWanteds } <- execStateT (solveWanteds env) $ + (WantedSolverState{ inertWanteds }, hints') <- runWriterT . execStateT (solveWanteds env) $ initialWantedSolverState inertGivens a b - case inertWanteds of + -- Solving fails when there's irreducible wanteds left. + -- + -- We report the first residual constraint instead of the initial wanted, + -- unless we just swapped its arguments. + -- + -- We may have collected hints for the solving failure along the way, in + -- which case we decorate the error with the first one. + maybe id addHint (listToMaybe hints') `rethrow` case inertWanteds of [] -> pure $ Just [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] Nothing] - -- Solving fails when there's irreducible wanteds left. We report the - -- first residual constraint instead of the initial wanted, unless we - -- just swapped its arguments. (k, a', b') : _ | a' == b && b' == a -> throwError $ insoluble k b' a' (k, a', b') : _ -> throwError $ insoluble k a' b' solveCoercible _ _ _ _ = pure Nothing diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 3202b4f9ce..6ffae01cd9 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -23,7 +23,7 @@ import Control.Monad.State (MonadState, StateT, get, gets, modify, put) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) -import Control.Monad.Writer.Strict (Writer, execWriter, runWriter, tell) +import Control.Monad.Writer.Strict (MonadWriter, Writer, execWriter, runWriter, runWriterT, tell) import Data.Either (partitionEithers) import Data.Foldable (fold, foldl', for_, toList) import Data.Functor (($>)) @@ -37,7 +37,7 @@ import qualified Data.Set as S import Language.PureScript.Crash import Language.PureScript.Environment -import Language.PureScript.Errors +import Language.PureScript.Errors hiding (inScope) import Language.PureScript.Names import Language.PureScript.TypeChecker.Kinds hiding (kindOf) import Language.PureScript.TypeChecker.Monad @@ -130,7 +130,7 @@ solveGivens env = go (0 :: Int) where given : unsolved -> do (k, a, b) <- lift $ unify given GivenSolverState{..} <- get - lift (canon env Nothing k a b `catchError` recover) >>= \case + lift (fst <$> runWriterT (canon env Nothing k a b `catchError` recover)) >>= \case Irreducible -> case interact env (a, b) inertGivens of Just (Simplified (a', b')) -> put $ GivenSolverState { unsolvedGivens = (a', b') : unsolved, .. } @@ -207,6 +207,7 @@ initialWantedSolverState givens a b = -- @Coercible Boolean Char@. solveWanteds :: MonadError MultipleErrors m + => MonadWriter [ErrorMessageHint] m => MonadState CheckState m => Environment -> StateT WantedSolverState m () @@ -478,6 +479,7 @@ data Canonicalized -- simpler constraints whose satisfaction will imply the goal. canon :: MonadError MultipleErrors m + => MonadWriter [ErrorMessageHint] m => MonadState CheckState m => Environment -> Maybe [(SourceType, SourceType, SourceType)] @@ -612,6 +614,7 @@ data UnwrapNewtypeError -- substituted in (e.g. @N[D/a] = D@ given @newtype N a = N a@ and @data D = D@). unwrapNewtype :: MonadState CheckState m + => MonadWriter [ErrorMessageHint] m => Environment -> SourceType -> m (Either UnwrapNewtypeError SourceType) @@ -621,20 +624,23 @@ unwrapNewtype env = go (0 :: Int) where (currentModuleName, currentModuleImports) <- gets $ checkCurrentModule &&& checkCurrentModuleImports case unapplyTypes ty of (TypeConstructor _ newtypeName, _, xs) - | Just (fromModuleName, tvs, newtypeCtorName, wrappedTy) <- + | Just (inScope, fromModuleName, tvs, newtypeCtorName, wrappedTy) <- lookupNewtypeConstructorInScope env currentModuleName currentModuleImports newtypeName -- We refuse to unwrap newtypes over polytypes because we don't know how -- to canonicalize them yet and we'd rather try to make progress with -- another rule. , isMonoType wrappedTy -> do - for_ fromModuleName $ flip insertCoercedNewtypeCtorImport newtypeCtorName + when (not inScope) $ do + tell [MissingConstructorImportForCoercible newtypeCtorName] + throwError CannotUnwrapConstructor + for_ fromModuleName $ flip addConstructorImportForCoercible newtypeCtorName let wrappedTySub = replaceAllTypeVars (zip tvs xs) wrappedTy ExceptT (go (n + 1) wrappedTySub) `catchError` \case CannotUnwrapInfiniteNewtypeChain -> throwError CannotUnwrapInfiniteNewtypeChain CannotUnwrapConstructor -> pure wrappedTySub _ -> throwError CannotUnwrapConstructor - insertCoercedNewtypeCtorImport fromModuleName newtypeCtorName = modify $ \st -> - st { checkCoercedNewtypeCtorsImports = S.insert (fromModuleName, newtypeCtorName) $ checkCoercedNewtypeCtorsImports st } + addConstructorImportForCoercible fromModuleName newtypeCtorName = modify $ \st -> + st { checkConstructorImportsForCoercible = S.insert (fromModuleName, newtypeCtorName) $ checkConstructorImportsForCoercible st } -- | Looks up a given name and, if it names a newtype, returns the names of the -- type's parameters, the type the newtype wraps and the names of the type's @@ -643,13 +649,12 @@ lookupNewtypeConstructor :: Environment -> Qualified (ProperName 'TypeName) -> Maybe ([Text], ProperName 'ConstructorName, SourceType) -lookupNewtypeConstructor env qualifiedNewtypeName@(Qualified newtypeModuleName _) = do - (_, DataType tvs [(ctorName, [wrappedTy])]) <- M.lookup qualifiedNewtypeName (types env) - (Newtype, _, _, _) <- M.lookup (Qualified newtypeModuleName ctorName) (dataConstructors env) +lookupNewtypeConstructor env qualifiedNewtypeName = do + (_, DataType Newtype tvs [(ctorName, [wrappedTy])]) <- M.lookup qualifiedNewtypeName (types env) pure (map (\(name, _, _) -> name) tvs, ctorName, wrappedTy) --- | Behaves like 'lookupNewtypeConstructor', but fails unless the newtype --- constructor is in scope and returns the module from which it is imported, or +-- | Behaves like 'lookupNewtypeConstructor' but also returns whether the +-- newtype constructor is in scope and the module from which it is imported, or -- 'Nothing' if it is defined in the current module. lookupNewtypeConstructorInScope :: Environment @@ -662,16 +667,16 @@ lookupNewtypeConstructorInScope ) ] -> Qualified (ProperName 'TypeName) - -> Maybe (Maybe ModuleName, [Text], Qualified (ProperName 'ConstructorName), SourceType) + -> Maybe (Bool, Maybe ModuleName, [Text], Qualified (ProperName 'ConstructorName), SourceType) lookupNewtypeConstructorInScope env currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName) = do let fromModule = find isNewtypeCtorImported currentModuleImports fromModuleName = (\(_, n, _, _, _) -> n) <$> fromModule asModuleName = (\(_, _, _, n, _) -> n) =<< fromModule isDefinedInCurrentModule = newtypeModuleName == currentModuleName isImported = isJust fromModule - guard $ isDefinedInCurrentModule || isImported + inScope = isDefinedInCurrentModule || isImported (tvs, ctorName, wrappedTy) <- lookupNewtypeConstructor env qualifiedNewtypeName - pure (fromModuleName, tvs, Qualified asModuleName ctorName, wrappedTy) + pure (inScope, fromModuleName, tvs, Qualified asModuleName ctorName, wrappedTy) where isNewtypeCtorImported (_, _, importDeclType, _, exportedTypes) = case M.lookup newtypeName exportedTypes of @@ -689,6 +694,7 @@ lookupNewtypeConstructorInScope env currentModuleName currentModuleImports quali -- @Coercible a b@ if unwraping the newtype yields @a@. canonNewtypeLeft :: MonadState CheckState m + => MonadWriter [ErrorMessageHint] m => Environment -> SourceType -> SourceType @@ -703,6 +709,7 @@ canonNewtypeLeft env a b = -- @Coercible a b@ if unwraping the newtype yields @b@. canonNewtypeRight :: MonadState CheckState m + => MonadWriter [ErrorMessageHint] m => Environment -> SourceType -> SourceType diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index a77b4b40c9..3799569dbe 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -88,7 +88,7 @@ data CheckState = CheckState -- This goes into state, rather than using 'rethrow', -- since this way, we can provide good error messages -- during instance resolution. - , checkCoercedNewtypeCtorsImports :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName)) + , checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName)) -- ^ Newtype constructors imports required to solve Coercible constraints. -- We have to keep track of them so that we don't emit unused import warnings. } @@ -392,7 +392,7 @@ debugTypes = go <=< M.toList . types ppTy = prettyPrintType 100 srcTy name = showQualified runProperName qual decl = case which of - DataType _ _ -> "data" + DataType _ _ _ -> "data" TypeSynonym -> "type" ExternData _ -> "extern" LocalTypeVariable -> "local" diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index 9fe3073c3c..f8de82938a 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -47,7 +47,7 @@ type RoleEnv = M.Map (Qualified (ProperName 'TypeName)) [Role] typeKindRoles :: TypeKind -> Maybe [Role] typeKindRoles = \case - DataType args _ -> + DataType _ args _ -> Just $ map (\(_, _, role) -> role) args ExternData roles -> Just roles diff --git a/tests/purs/failing/CoercibleRepresentational6.out b/tests/purs/failing/CoercibleRepresentational6.out index 7b66cdb47d..a587159c40 100644 --- a/tests/purs/failing/CoercibleRepresentational6.out +++ b/tests/purs/failing/CoercibleRepresentational6.out @@ -8,6 +8,8 @@ at tests/purs/failing/CoercibleRepresentational6.purs:8:10 - 8:16 (line 8, colum  a0    + Solving this instance requires the newtype constructor N to be in scope. + while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type N a0 -> a0 while checking that expression coerce diff --git a/tests/purs/failing/CoercibleRepresentational7.out b/tests/purs/failing/CoercibleRepresentational7.out index d7adcf1742..0c5c1005a5 100644 --- a/tests/purs/failing/CoercibleRepresentational7.out +++ b/tests/purs/failing/CoercibleRepresentational7.out @@ -8,6 +8,8 @@ at tests/purs/failing/CoercibleRepresentational7.purs:8:10 - 8:16 (line 8, colum  a0    + Solving this instance requires the newtype constructor N to be in scope. + while checking that type forall (a :: Type) (b :: Type). Coercible @Type a b => a -> b is at least as general as type N a0 -> a0 while checking that expression coerce From d63cb8127fb1758874a2741366a3cdca11bf47a6 Mon Sep 17 00:00:00 2001 From: Cyril Date: Sun, 27 Dec 2020 21:44:50 +0100 Subject: [PATCH 1259/1580] Update version to 0.14.0-rc5 (#3976) --- app/Version.hs | 2 +- package.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/app/Version.hs b/app/Version.hs index 4beb5c50d3..673c6c0d5b 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -17,7 +17,7 @@ import qualified Development.GitRev as GitRev -- prerelease identifier here (if any). When releasing a proper version, simply -- set this to an empty string. prerelease :: String -prerelease = "-rc4" +prerelease = "-rc5" versionString :: String versionString = showVersion Paths.version ++ prerelease ++ extra diff --git a/package.yaml b/package.yaml index 37cb7c3050..68e43502d8 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.14.0-rc4' # note: when updating this, update the prerelease identifier in app/Version.hs too! +version: '0.14.0-rc5' # note: when updating this, update the prerelease identifier in app/Version.hs too! synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 781e9401f78c1f1d0b33643809048c63922db85a Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sun, 17 Jan 2021 16:42:46 -0800 Subject: [PATCH 1260/1580] Generate changelog and add PR template (#3989) * Add changelog generated from GH releases * Add PR template * Remove release candidates for v0.14.0 * Remove other release candidate entries that are blank --- .github/PULL_REQUEST_TEMPLATE.md | 12 + CHANGELOG.md | 3240 ++++++++++++++++++++++++++++++ 2 files changed, 3252 insertions(+) create mode 100644 .github/PULL_REQUEST_TEMPLATE.md create mode 100644 CHANGELOG.md diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md new file mode 100644 index 0000000000..4435abbec0 --- /dev/null +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -0,0 +1,12 @@ +**Description of the change** + +Clearly and concisely describe the purpose of the pull request. If this PR relates to an existing issue or change proposal, please link to it. Include any other background context that would help reviewers understand the motivation for this PR. + +--- + +**Checklist:** + +- [ ] Added the change to the changelog's "Unreleased" section with a reference to this PR (e.g. "- Made a change (#0000)") +- [ ] Linked any existing issues or proposals that this pull request should close +- [ ] Updated or added relevant documentation +- [ ] Added a test for the contribution (if applicable) diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000000..06541a116c --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3240 @@ +# Changelog + +Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). + +## [Unreleased] + +Breaking changes: + +New features: + +Bugfixes: + +Other improvements: + +## [v0.13.8](https://github.com/purescript/purescript/releases/tag/v0.13.8) - 2020-05-23 + +**Bug Fixes** + +* Update incremental build cache information properly on IDE rebuilds (#3789, @kritzcreek) + + Fixes a bug where triggering a rebuild via the IDE would not update the + `output/cache-db.json` file, which in certain situations could lead to + unnecessary rebuilds, as well as modules not being rebuilt when they should + have been. + +* Don't include compiler-internal declarations in IDE completions (#3850, @kritzcreek) + + IDE completions would previously include pseudo-declarations such as + `RowToList$Dict` which only exist internally, due to how type class + desugaring inside the compiler works. These declarations are now suppressed. + +* Fix corefn JSON version parsing (#3877, @paulyoung) + + Fixes a bug where the parser for the functional core (or "corefn") JSON + format would ignore all but the first component of the compiler version + stored in the JSON. This does not affect the compiler directly, but will be + useful for other tooling which depends on the corefn JSON parser provided by + the compiler library. + +**Improvements** + +* Add `purs graph` subcommand for graphing module dependencies (#3781, @jmackie, @f-f) + + This adds a new `graph` subcommand which allows tools to consume information + about which modules depend on which other modules. The format is as follows: + + ``` + { "Prelude": + { "path": "src/Prelude.purs" + , "depends": ["Data.Semiring", "Data.Ring", ...] + }, + "Data.Ring": + { "path": "src/Data/Ring.purs" + , "depends": [] + }, + ... + } + ``` + + Each property in the returned object has exactly two properties; `path`, + which is a string containing the file path relative to the directory where + the command was run, and `depends`, which is an array of the names of all + directly imported modules. + +* purs ide is better at reloading changes (#3799, @kritzcreek) + + The IDE would previously sometimes miss changes that were made outside of the + editor, like building with new dependencies or recompiling larger parts of + the project on the console. + + The IDE will now notice when this happened on the next command issued to it + and refresh its state before processing that command. This might cause the + first command after an external change to take a long time to execute, but + should increase reliability in general. + +* Switch to a binary encoding for externs files (#3841, @kritzcreek) + + This change should result in significant performance improvements in both IDE + load times and incremental builds where lots of modules are already built. + +* Represent module names as a single Text value internally (#3843, @kritzcreek) + + Boosts compiler performance by representing module names as a single Text + value, rather than a list of Text values as it was previously. + +* Extract documentation for type classes in purs ide (#3856, @kritzcreek) + + This changes makes documentation comments on type classes visible to the IDE. + +**Other** + +* Declare explicit upper bounds on Cabal and haskeline rather than relying on + stack's pvp-bounds (#3777, @coot) + +## [v0.13.7](https://github.com/purescript/purescript/releases/tag/v0.13.7) - 2020-05-23 + +_release withdrawn due to CI mishap_ + +## [v0.13.6](https://github.com/purescript/purescript/releases/tag/v0.13.6) - 2020-01-17 + +**Bug Fixes** + +* Reset IDE state before performing a full reload. (#3766, @kritzcreek) + + This prevents a space leak in the IDE. + +* Added source spans to ado desugaring. (#3758, @dariooddenino) + + Previously errors in ado desugaring might have had no line information. + +* Generate correct arity failure case for some guarded matches. (#3763, @nwolverson) + + Specifically when a multi-way case contains a pattern guard or multiple +guard expressions, the desugared case expression could contain a guard with +a different arity to the matched expressions, resulting in an error. + +**Improvements** + +* Improved ambiguous variable check for functional dependencies. (#3721, @MonoidMusician) + + Previously the compiler might warn about ambiguous variables that aren't actually ambiguous +due to functional dependencies. This check now fully takes functional dependencies into +consideration. + +* Optimize import desugaring for full builds (#3768, @colinwahl) + + The compiler was performing redundant work when resolving dependencies for modules resulting +in poor asymptotics. This work is now shared across modules yielding a 30-40% improvement in +build times for full builds. + +* Use PureScript escapes in string pretty-printing (#3751, @hdgarrood) + + Previously the compiler might print invalid escape sequences when pretty-printing code for +error messages. It now prints correctly escaped code based on PureScript's lexical grammar. + +* Optimize away binds to wildcards in do-notation (#3220, @matthewleon, @hdgarrood) + + This avoids generating variable assignments if no variables are actually bound in do-notation. +Previously the compiler would emit a unique variable name that went unused. + +* Output docs.json files for Prim modules (#3769, @f-f) + + This change allows downstream tools such as spago to obtain documentation data for Prim modules. +Please note, however, that the API for the docs.json files is unstable and may change without warning. + +**Other** +* Fix various typos in source comments (#3760, @bwignall) + +## [v0.13.5](https://github.com/purescript/purescript/releases/tag/v0.13.5) - 2019-11-13 + +This is a small bugfix release to address some issues which were introduced in 0.13.4. + +**Bug fixes** + +* Fix "too many open files" during compiling (#3743, @hdgarrood) + + The compiler would not promptly close files after opening them, which could easily lead to reaching the open file limit, causing the compiler to crash. + +* Fix incorrect unused import warnings when kinds are re-exported (#3744, @hdgarrood) + + Fixes a bug in which unused import warnings were generated for kinds which were re-exported (and therefore should have been considered "used"). + +**Other** + +* Fix Haddock markup error preventing Haddock docs being generated (#3745, @cdepillabout) +* Add upper bound on Protolude to prevent 0.2.4 from being selected (#3752, @hdgarrood) + +## [v0.13.4](https://github.com/purescript/purescript/releases/tag/v0.13.4) - 2019-10-20 + +**Enhancements** + +* Use content hashes when determining whether a file needs rebuilding (#3708, @hdgarrood) + + We now calculate and store content hashes of input files during compilation. If a file's modification time has changed since the last compile, we compare the hash to the previous hash; if the hash is unchanged, this allows us to skip rebuilding this file, speeding up the build. + +* Include import declaration qualifiers in unused import warnings (#3685, @matthew-hilty) + + Previously, warnings didn't distinguish between import declarations from the same module. Code like the following + ```purescript + import A.B (x) -- `x` is used. + import A.B (y) as C -- `y` is not used. + ``` + would induce a warning like `The import of module A.B is redundant` even though only the qualified import declaration `C` is actually redundant. The warning now would be `The import of module A.B (qualified as C) is redundant`. + +* Include kind imports when determining unused import warnings (#3685, @matthew-hilty) + + Previously, kind imports were ignored. The linter wouldn't emit any warnings for code like the following. + ```purescript + import A.B (kind K) -- `kind K` is not used. + ``` + And the linter, disregarding `kind K`, would emit an `UnusedImport` instead of an `UnusedExplicitImport` for code like the following. + ```purescript + import A.B (x, kind K) -- `x` is not used, but `kind K` is. + ``` + +* Better reporting of I/O errors (#3730, @hdgarrood) + + If an unexpected I/O error occurs during compiling, we now include details in the error message. For example, when trying to write compilation results onto a device which has run out of space, we previously would have received a "CannotWriteFile" error with no further information. Now, we receive the underlying error message too: + + ``` + I/O error while trying to write JSON file: ./output/cache-db.json + + ./output/cache-db.json: hClose: resource exhausted (No space left on device) + ``` + +**Bug fixes** + +* Improve type class resolution in the presence of constrained higher-order functions (#3558, @matthew-hilty) + + This is perhaps best illustrated with an example. + ```purescript + newtype LBox row a = LBox (∀ r. (∀ lbl _1. Row.Cons lbl a _1 row ⇒ IsSymbol lbl ⇒ SProxy lbl → r) → r) + + unLBox ∷ ∀ row a r. (∀ lbl _1. Row.Cons lbl a _1 row ⇒ IsSymbol lbl ⇒ SProxy lbl → r) → LBox row a → r + unLBox g (LBox f) = f g + + read ∷ ∀ row a. Record row → LBox row a → a + read rec = unLBox \lbl → Record.get lbl rec + ``` + + The `read` function would previously fail with the error + + ``` + No type class instance was found for + + Prim.Row.Cons lbl4 + a5 + t2 + row6 + ``` + + although that dictionary should have been available in the function passed to `unLBox`. Now, it type checks successfully. + +* Fix cache invalidation false negatives by storing timestamps (#3705, @hdgarrood) + + Previously, an input file would be considered 'modified', and thus requiring rebuilding on a subsequent compile, if its modification time specifies a point in time after any of the modification times of the corresponding output files. This has turned out to be insufficient; files can often change in a way that this algorithm misses, because the input file might still have a timestamp older than the output files. Often this can happen by switching between `git` branches or by updating a dependency. + + This problem can manifest as compiler errors which don't appear to make sense or correspond to what is inside a source file, and which (until now) would need to be fixed by a clean rebuild (e.g. `rm -r output`). + + We now make a note of the modification time when we read an input file, and we consider that input file to have changed on a subsequent compile if the modification time is different to what it was before. + + The hope with this fix is that it should never be necessary to remove an output directory to get a build to run successfully. If you do run into this problem again, it is a bug: please report it. + +* Fix exports incorrectly being identified as unused in purs bundle (#3727, @rhendric) + + References to properties on the `exports` object would previously not be picked up by `purs bundle` as uses of those properties, which could lead to them being incorrectly removed. For example: + + ```javascript + 'use strict'; + + exports.foo = 1; + exports.bar = exports.foo; + ``` + + would remove the `exports.foo = 1;` statement, breaking the assignment to `exports.bar`, if `foo` were not used elsewhere. This statement is now no longer removed. + +* Show entire rows in type errors in the presence of the `--verbose-errors` flag (#3722, @Woody88) + + The row diffing feature, which elides common labels in rows occurring in type errors, did not previously respect the `--verbose-errors` flag, giving the same output regardless of whether it was set or not. Now, if the flag has been supplied, we always show the entire row. + +**Other** + +* Add Makefile command to run license generator (#3718, @hdgarrood) +* Update language-javascript to 0.7.0.0 (@rhendric, @hdgarrood) + + This enables a number of newer JavaScript syntactic constructs to be used in FFI files. Please see the [language-javascript release notes][] for details. + +* Fix for object shorthand syntax in FFI files (#3742, @hdgarrood) + +[language-javascript release notes]: https://hackage.haskell.org/package/language-javascript-0.7.0.0/changelog + +## [v0.13.3](https://github.com/purescript/purescript/releases/tag/v0.13.3) - 2019-08-18 + +**Enhancements** + +* Eliminate empty type class dictionaries in generated code (#2768, @LiamGoodacre) + + Empty type class dictionaries — dictionaries which do not contain any type class member implementations at runtime — are often used to provide evidence at compile-time to justify that a particular operation will not fail; for example, `Prim.Row.Cons` can be used to justify that we can expect a record to contain a particular field with a particular type. Unfortunately, constructing empty dictionaries can be costly, especially in more complex scenarios such as type-level programming. This release implements a new optimization which avoids the need to build empty dictionaries at runtime by instead inserting `undefined` into the generated code. This optimization can both reduce code size and improve performance in certain contexts. + +* Render doc-comments for data constructors and type class members in HTML documentation (#3507, @marcosh) + + Documentation comments for data constructors and type class members are now picked up by `purs docs`, and will soon start appearing in Pursuit too. For example: + + ```purescript + -- | Doc-comments like this one were always rendered in Pursuit + data Maybe a = + -- | Now this one (for the Just constructor) will be rendered too + = Just a + -- | And this one (for Nothing) + | Nothing + + -- | Doc-comments like this one were always rendered in Pursuit + class Eq a where + -- | Now this one (for the `eq` method) will be rendered too + eq :: a -> a -> Boolean + ``` + +* Show diffs of rows in errors and hints (#3392, @dariooddenino) + + In type mismatches between rows, we now elide common labels so that the problem is easier to identify. For example, consider the following code, which has a type error due to the types of the `b` fields in the two records not matching: + + ```purescript + foo = + { a: 1, b: "hi", c: 3, d: 4, e: 5 } + bar = + { a: 1, b: 2, c: 3, d: 4, e: 5 } + baz = + [ foo, bar ] + ``` + + Previously, the type error would include the entirety of each record type: + + ``` + Could not match type + + String + + with type + + Int + + while trying to match type ( a :: Int + , b :: String + , c :: Int + , d :: Int + , e :: Int + ) + with type ( a :: Int + , b :: Int + , c :: Int + , d :: Int + , e :: Int + ) + ``` + + This can become quite difficult to read in the case of large record types. Now, we get this: + + ``` + Could not match type + + String + + with type + + Int + + while trying to match type + ( b :: String + ... + ) + + with type + ( b :: Int + ... + ) + ``` + +**Bug fixes** + +* Remove more dead code in `purs bundle` (#3551, @rhendric) + + The dead code elimination in `purs bundle` now no longer incorrectly considers declarations to be used in the presence of local variables which happen to share their names, and is therefore able to remove these declarations when they are unused. + +* Fix parsing of comma-separated guards in let statements (#3713, @natefaubion) + + The 0.13 parser would previously choke on guards separated by commas in let statements within do/ado blocks, such as + + ```purescript + test = ado + let + foo + | bar + , baz = + 42 + | otherwise = 100 + in + foo + ``` + + This has now been fixed. + +**Other** + +* Add placeholder purs.bin to fix npm installs (#3695, @hdgarrood) +* Refactor and simplify BuildPlan a little (#3699, @hdgarrood) +* Update link to partial type class guide in error message hints (#3717, @alextes) + +## [v0.13.2](https://github.com/purescript/purescript/releases/tag/v0.13.2) - 2019-07-05 + +**Enhancements** + +* Add --debug flag to `purs bundle` command (#3666, @rhendric) + + This flag causes an optimized-for-humans JSON representation of the modules +being bundled to be dumped to stderr, prior to dead code elimination. + +* Ignore duplicate file inputs to CLI commands (#3653, @dyerw) + + If, after expanding globs, a particular file path appears more than once, the +compiler will now ignore the extra occurrences, instead of emitting a +`DuplicateModule` error. + +**Bug fixes** + +* Fix printing of tokens with string escapes (#3665, @hdgarrood) +* Fix multiple "let"s in ado before the final "in" (#3675, @natefaubion) +* Throw a parse error (not internal error) when using quoted labels as puns (#3690, @natefaubion) + +**Other** + +* Parser: Remove partial type signatures for parameterized productions (#3667, @natefaubion) +* Make git consider \*.out files as binary for the golden tests (#3656, @kritzcreek) +* Fix build failures on older GHCs by tightening base lower bound (#3659, @hdgarrood) +* Pin happy version to address build failures when building with Cabal (#3660, @hdgarrood) +* Add upper bounds when producing source distributions (#3661, @hdgarrood) +* Update test dependency on typelevel-prelude (#3649, @hdgarrood) +* Update author and maintainer sections of cabal file (#3663, @hdgarrood) +* Update to GHC 8.6.5, Stackage LTS 13.26 (#3688, @hdgarrood) +* Various CI maintenance (#3687, @hdgarrood) +* Move the "purescript" npm package into the compiler repo (#3691, @hdgarrood) + +## [v0.13.1](https://github.com/purescript/purescript/releases/tag/v0.13.1) - 2019-07-04 + +_Notice: This release has been unpublished due to an error in the package tarball._ + +## [v0.13.0](https://github.com/purescript/purescript/releases/tag/v0.13.0) - 2019-05-30 + +**Grammar/Parser Changes** + +`0.13` is a very exciting release for me (@natefaubion). For the past few months I've been working on a complete rewrite of the existing parser. The old parser has served us very well, but it has grown very organically over the years which means it's developed some unsightly limbs! Throughout the process I've tried to iron out a lot of dark corner cases in the language grammar, and I hope this release will set us on a firm foundation so we can start to specify what "PureScript the Language" actually is. This release is definitely breaking, but I think you'll find the changes are modest. I also hope that this release will open up a lot of opportunities for syntactic tooling, both using the existing parser or even using alternative parsers (which are now possible). + +**Breaking** + +There are a number of breaking changes, but I think you'll find that most code will continue to parse fine. We've tested the parser against the existing ecosystem and several large production applications at Awake, Lumi, and SlamData. The migration burden was either non-existent or only involved a few changes. + +* The only whitespace now allowed in _code_ is ASCII space and line endings. Since you must use indentation to format PureScript code (unlike Haskell), we felt it was best to be more restrictive in what you can write instead of allowing potentially confusing behavior (implicit tab-width, zero-width spaces, etc). You can still use unicode whitespace within string literals. +* The only escapes accepted in string literals are `\n\r\t\'\"\\`, `\x[0-9a-fA-F]{1,6}` (unicode hex escape), and `\[\r\n ]+\` (gap escapes). We had inherited a vast zoo of escape codes from the Parsec Haskell Language parser. We decided to minimize what we support, and only add things back if there is significant demand. +* Octal and binary literals have been removed (hex remains). +* `\` is no longer a valid operator. It conflicts with lambda syntax. +* `@` is no longer a valid operator. It conflicts with named binder syntax. +* `forall` is no longer a valid identifier for expressions. We wanted a consistent rule for type identifiers and expression identifiers. +* Precedence of constructors with arguments in binders (`a@Foo b` must be `a@(Foo b)`). +* Precedence of kind annotations (`a :: Type -> Type b :: Type` must now be `(a :: Type -> Type) (b :: Type)`). +* Precedence of type annotations (`::` has lowest precedence, rather than sitting between operators and function application). +* Various edge cases with indentation/layout. Again, most code should work fine, but there were some cases where the old parser let you write code that violated the offside rule. + +**Fixes** + +* Many fixes around parse error locations. The new parser should yield much more precise error locations, especially for large expressions (like in HTML DSLs). +* Reported source spans no longer include whitespace and comments. +* Reported source span for the last token in a file is now correct. + +**Enhancements** + +* `where` is still only sugar for `let` (it does not introduce bindings over guards), but it is now usable in `case` branches in the same manner as declarations. +* `_` is now allowed in numeric literals, and is an ignored character (ie. `1_000_000 == 1000000`). +* Raw string literals (triple quotes) can now contain trailing quotes (ie. `"""hello "world"""" == "hello \"world\""`). +* Kind annotations are now allowed in `forall` contexts (#3576 @colinwahl). +* The new parser is much faster and can avoid parsing module bodies when initially sorting modules. We also do more work in parallel during the initialization phase of `purs compile`. This means that time to start compiling is faster, and incremental builds are faster. In my testing, a noop call to `purs compile` on the Awake codebase went from ~10s to ~3s. + +**Other Changes** + +**Breaking** + +* Fix sharing in function composition inlining (#3439 @natefaubion). This is really a bugfix, but it has the potential to break code. Previously, you could write recursive point-free compositions that the compiler inadvertently eta-expanded into working code by eliminating sharing. We've changed the optimization to respect strict evaluation semantics, which can cause existing code to stack overflow. This generally arises in instance definitions. Unfortunately, we don't have a way to disallow the problematic code at this time. +* Fail compilation when a module imports itself (#3586 @hdgarrood). +* Disallow re-exporting class and type with the same name (#3648 @joneshf). + +**Enhancements** + +* Better illegal whitespace errors (#3627 @hdgarrood). +* Only display class members that are not exported from the module when throwing a `TransitiveExportError` for a class (#3612 @colinwahl). +* Tweaks to type pretty printing (#3610 @garyb). +* Unify matching constraints (#3620 @garyb). +* Improve error message on ModuleNotFound error for Prim modules (#3637 @ealmansi). + +**Docs** + +* Make markdown format behave like html. Remove --docgen opt. Separate directories for html and markdown docs (#3641 @ealmansi). +* Make html the default output format (#3643 @ealmansi). +* Write ctags and etags to filesystem instead of stdout (#3644 @ealmansi). +* Add --output option for purs docs (#3647 @hdgarrood). +* Use externs files when producing docs (#3645 @hdgarrood). `docs` is now a codegen target for `purs compile` where documentation is persisted as a `docs.json` file in the `output` directory. + +**Internal** + +* Remove failable patterns and `NoMonadFailDesugaring` extension (#3610 @adnelson). +* Add tests for grammar fixes addressed by CST (#3629 #3631 @hdgarrood). +* Keep Parser.y ASCII to avoid locale issues with happy (#3640 @jmackie). +* Improve display of internal errors (#3634 @hdgarrood). + +## [v0.12.5](https://github.com/purescript/purescript/releases/tag/v0.12.5) - 2019-04-15 + +This small release fixes three issues which were introduced in 0.12.4. + +**Filter out module declarations when suggesting imports (#3591)** + +When determining candidates for imports, ignore modules. This allows you to easily import types which come from modules of the same name, like `Effect`. (@kRITZCREEK) + +**Running purs ide server crashes on macOS (#3594)** + +Running `purs ide server` on macOS would immediately crash with the error `purs: Network.Socket.listen: unsupported operation (Operation not supported on socket)`; this has now been fixed. (@f-f) + +**Take qualification into consideration when determining type class cycles (#3595)** + +When checking for cycles in type classes, the compiler is now able to distinguish classes which have come from different modules, meaning that e.g. `class SomeOtherModule.Foo <= Foo` is no longer incorrectly reported as a class having itself as a superclass. (@hdgarrood) + +## [v0.12.4](https://github.com/purescript/purescript/releases/tag/v0.12.4) - 2019-04-07 + +**Enhancements** + +**[purs ide] Treat module declarations like any other (#3541)** + +This means we can now complete module names with the completion API as well as being able to query for module level documentation and goto-defintion for module names. + +The list loadedModules command has also been deprecated, since you can now use the completion command with a filter for modules instead. (@kRITZCREEK) + +**Truncate types in errors (#3401)** + +Large types in error messages are now truncated. For example: + +```purescript +module Main where + +data Id a = Id a + +foo :: Id (Id (Id (Id (Id Int)))) +foo = "hi" +``` + +now produces + +``` + Could not match type + + String + + with type + + Id (Id (Id (... ...))) +``` + +The previous behaviour of printing the types in full may be recovered by passing the `--verbose-errors` flag to the compiler. (@hdgarrood) + +**Don't generate unused imports in JavaScript output (#2177)** + +In both CommonJS compiler output and JavaScript `purs bundle` output, we no longer emit JS imports for modules whose use sites have all been optimized out. This reduces the number of warnings produced by other JavaScript bundlers or compressors such as "Side effects in initialization of unused variable Control_Category". (@rhendric) + +**Simplify `purs publish` resolutions format (#3565)** + +The format for resolutions files passed via the CLI to `purs publish` has been simplified. A new-style resolutions file should look something like this: + +``` +{ + "purescript-prelude": { + "version": "4.0.0", + "path": "bower_components/purescript-prelude" + }, + "purescript-lists": { + "version": "6.0.0", + "path": "bower_components/purescript-lists" + }, + ... +} +``` + +The `version` field is used for generating links between packages on Pursuit, and the `path` field is used to obtain the source files while generating documentation: all files matching the glob "src/**/*.purs" relative to the +`path` directory will be picked up. + +The `version` field is optional, but omitting it will mean that no links will be generated for any declarations from that package on Pursuit. The "path" field is required. + +The old format is still accepted, but it has been deprecated, and `purs publish` will now produce a warning when consuming it. + +This change allows us to work around a bug in Bower which prevented packages with larger dependency trees (such as Halogen) from being uploaded to Pursuit (https://github.com/purescript-contrib/pulp/issues/351). (@hdgarrood) + +**Improve error messages for cycles in type class declarations (#3223)** + +A cycle in type class declarations, such as + +```purescript +class C a <= D a +class D a <= C a +``` + +now produces a more informative error, which no longer confusingly refers to type synonyms, and which displays all of the classes involved in the cycle. (@Saulukass) + +**Bug fixes** + +* Naming a constructor `PS` no longer causes JS runtime errors when using `purs bundle` (#3505, @mhcurylo) +* `purs publish` now warns instead of failing if not all dependencies have a resolved version, e.g. if some have been installed via a branch or commit reference instead of a version range (#3061, @hdgarrood) +* Fix handling of directive prologues like "use strict" in `purs bundle` (#3581, @rhendric) + +**Other** + +* Raise upper bound on aeson in package.yaml (#3537, @jacereda) +* Add Nix test dependencies to stack.yaml (#3525, @jmackie) +* [purs ide] Represent filters as a data type rather than functions (#3547, @kRITZCREEK) +* Carry data constructor field names in the AST (#3566, @garyb) +* Convert prim docs tests to use tasty (#3568, @hdgarrood) +* Bump bower version used in tests (#3570, @garyb) +* Add tests for `purs bundle` (#3533, @mhcurylo) +* Update to GHC 8.6.4 (#3560, @kRITZCREEK) +* Rerun some of the compiler tests to test with `purs bundle` (#3579, @rhendric) + +## [v0.12.3](https://github.com/purescript/purescript/releases/tag/v0.12.3) - 2019-02-24 + +**Enhancements** + +- Add better positions for UnknownName errors for types/kinds (#3515, @colinwahl) + + Previously an UnknownName error (arising from e.g. referring to a non-existent type, or a type which you forgot to import) would have a span covering the whole type annotation. Now, the error span only covers the relevant part of the type. + +- Boost performance of `purs docs` by simplifying re-export handling (#3534, @hdgarrood) + +**Bug fixes** + +- Fix applicative do notation breaking API documentation generation with `purs docs` (#3414, @hdgarrood) +- Fix the REPL browser backend (#3387, @dariooddenino) + +**Other** + +- Make the license generator a proper stack script (@kRITZCREEK) +- Include the module from which something was imported for re-exports in externs files (@hdgarrood) +- Add AppVeyor build status to README.md (@hdgarrood) + +## [v0.12.2](https://github.com/purescript/purescript/releases/tag/v0.12.2) - 2019-01-13 + +**New features** + +- Named type wildcards (#3500, @natefaubion) + + It's now possible to use `?hole` style syntax in type signatures where you want the compiler to tell you the missing type. This was previously possible by using `_` in a type signature, but now `_` can be used without raising a warning, as long as it does not appear in a top level declaration. + +**Enhancements** + +- Improve error message for missing node.js in the repl (#3456, @justinwoo) +- Add `Boolean` kind to `Prim.Boolean` (#3389, @justinwoo) +- Link to documentation repo as docs for non-Prim built-in types/kinds (#3460, @JordanMartinez) +- PSCi: Support multiple command types in paste-mode (#3471, @LiamGoodacre) +- Add `row:column` printing for source positions in error messages (#3473, @justinwoo) +- Add `:print` directive for customizable repl printing (#3478, @hdgarrood) +- Implement qualified `do` (#3373, @pkamenarsky) +- Add better source positions to kind errors (#3495, @natefaubion) + +**Fixes** + +- Remove references to previous kinds `*` and `!` (#3458, @LiamGoodacre) +- Fix linting of unused type variables (#3464, @LiamGoodacre) +- Avoid dropping super class dicts for the same class (#3461, @LiamGoodacre) +- Fix issue where `Partial` can foil TCO optimizations (#3218, @matthewleon) +- Fix quoting of record labels in error messages (#3480, @hdgarrood) +- Prevent invalid JS being generated from awkward record labels (#3486, @hdgarrood) +- Fix unnecessary quoting of reserved names when used as labels (#3487, @hdgarrood) +- Fix source spans for binding groups (#3462, @LiamGoodacre) +- Fix kind error for recursive data type (#3511, @natefaubion) + +**Other (internals)** + +- Add annotations to `Type` and `Kind` (#3484, @natefaubion) +- Use handwritten JSON instances for `Type`/`Kind` (#3496, @natefaubion) +- Remove pretty print constructors from `Type` (#3498, @natefaubion) +- Add JSON compatibility tests (#3497, @hdgarrood) +- Remove the concept of the 'current module' in Docs (#3506, @hdgarrood) + +## [v0.12.1](https://github.com/purescript/purescript/releases/tag/v0.12.1) - 2018-11-12 + +**Enhancements** + +* Print types of missing typeclass members (#3398, @fehrenbach) +* Added `Prim.TypeError.QuoteLabel` for pretty printing labels in custom type errors (#3436, @dariooddenino) +* `purs ide` accepts codegen targets for the rebuild command (#3449, @kRITZCREEK) + +**Fixes** + +* Fixes errors spans for `CannotFindDerivingType` (#3425, @kRITZCREEK) +* Fixes a traversal bug where `ObjectNestedUpdate` was surviving desugaring (#3388, @natefaubion) +* Fixes type operators reexports (#3410, @natefaubion) +* Fixes ST magic-do and inlining (#3444, @natefaubion) +* Fixes missing span information when using do-syntax without importing `bind` or `discard` (#3418, @natefaubion) +* Fixes missing span information when shadowing an open import with a module definition (#3417, @natefaubion) +* Fixes stale `:browse` environment after `:reload` (#3001, @rndnoise) + +**Other** + +* Fix test-support dependency versions and update psci browse test (#3374, @LiamGoodacre) +* Changes to build with GHC 8.4.3 (#3372, @kRITZCREEK) +* Set --haddock flag based on BUILD_TYPE (#3409, @justinwoo) +* Use `microlens-platform` instead of `lens` (#3400, @joneshf) +* Avoid `Data.ByteString.Lazy.toStrict` (#3433, @coot) +* Add ffiCodegen to MakeActions (#3434, @coot) +* Add nix config to stack.yaml (#3435, @f-f) + +## [v0.12.0](https://github.com/purescript/purescript/releases/tag/v0.12.0) - 2018-05-21 + +**Breaking changes** + +- Added applicative-do notation; `ado` is now a keyword. An full explanation of the behaviour and usage of `ado` is available [in a comment on the issue](https://github.com/purescript/purescript/pull/2889#issuecomment-301260299). (#2889, @rightfold) +- Removed wrapper scripts for the old binary names (psc, psci, etc.) (#2993, @hdgarrood) +- Removed compiler support for deriving `purescript-generics`. `purescript-generics-rep` is still supported. (#3007, @paf31) +- Instances with just one method now require the method to be indented (bug fix, but potentially breaking) (#2947, @quesebifurcan) +- Overlapping instances are now an error rather than a warning, but can be resolved with the new instance chain groups feature (#2315, @LiamGoodacre) +- Reworked the `CoreFn` json representation. This change enables use of the [Zephyr tree shaking tool](https://github.com/coot/zephyr) for PureScript. (#3049, #3342, @coot) +- It is no longer possible to export a type class that has superclasses that are not also exported (bug fix, but potentially breaking) (#3132, @parsonsmatt) +- `Eq` and `Ord` deriving will now rely on `Eq1` and `Ord1` constraints as necessary where sometimes previously `Eq (f _)` would be required. `Eq1` and `Ord1` instances can also be derived. (#3207, @garyb) +- Some `Prim` type classes have been renamed/moved, so will require explicit importing (#3176, @parsonsmatt): + - `RowCons` is now `Prim.Row.Cons` + - `Union` is now `Prim.Row.Union` + - `Fail` is now `Prim.TypeError.Fail` + - `Warn` is now `Prim.TypeError.Warn` +- Users can no longer specify modules under the `Prim` namespace (#3291, @parsonsmatt) +- `TypeConcat` and `TypeString` have been replaced because they were in kind `Symbol` but weren't literals. The `Prim.TypeError.Doc` kind and related constructors (`Text`, `Quote`, `Beside`, `Above`) have been added in their place. The `Fail` and `Warn` type classes now accept a `Doc` instead of a `Symbol`. + (#3134, @LiamGoodacre) +- In simple cases instance overlaps are now checked at declaration time rather than being deferred until an attempt is made to use them. (#3129, @LiamGoodacre) +- Chaining non-associative or mixed associativity operators of the same precedence is no longer allowed (#3315, @garyb) +- The `--dump-corefn` and `--source-maps` arguments to `purs compile` have been removed. There is now a `--codegen` argument that allows the specific codegen targets to be specified - for example, `--codegen corefn` will not produce JS files, `--codgen js,corefn` will produce both. If the `sourcemaps` target is used `js` will be implied, so there's no difference between `--codegen js,sourcemaps` and `--codegen sourcemaps`). If no targets are specified the default is `js`. (#3196, @garyb, @gabejohnson) +- Exported types that use foreign kinds now require the foreign kinds to be exported too (bug fix, but potentially breaking) (#3331, @garyb) +- The pursuit commands were removed from `purs ide` due to lack of use and editor tooling implementing the features instead (#3355, @kRITZCREEK) + +**Enhancements** + +- Added `Cons` compiler-solved type class for `Symbol` (#3054, @kcsongor) +- The `Append` compiler-solved type class for `Symbol` can now be run in reverse (#3025, @paf31) +- Find Usages for values and constructors in `purs ide` (#3206, @kRITZCREEK) +- `purs ide` treats `hiding` imports the same as open imports when sorting (#3069, @kRITZCREEK) +- Added inlining for fully saturated usages of `runEffFn/mkEffFn` (#3026, @nwolverson) +- Improved explanation of `UnusableDeclaration` error (#3088, #3304, @i-am-tom) +- Improved rendering of comments in generated JavaScript by removing additional newlines (#3096, @brandonhamilton) +- Instance chain support. (#2315, @LiamGoodacre) + > We can now express an explicit ordering on instances that would previously have been overlapping. + > For example we could now write an `IsEqual` type class to compute if two types are equal or apart: + > ``` + > class IsEqual (l :: Type) (r :: Type) (o :: Boolean) | l r -> o + > instance isEqualRefl :: IsEqual x x True + > else instance isEqualContra :: IsEqual l r False + > ``` + > Note the `else` keyword that links the two instances together. + > The `isEqualContra` will only be up for selection once the compiler knows it couldn't possible select `isEqualRefl` - i.e that `l` and `r` are definitely not equal. +- Improved orphan instance error to include locations where the instance would be valid (#3106, @i-am-tom) +- Added an explicit error for better explanation of duplicate type class or instance declarations (#3093, @LiamGoodacre) +- `purs ide` now provide documentation comments (#2349, @nwolverson) +- Clarified meaning of duplicate labels in a `Record` row (#3143, @paf31) +- Explicit import suggestions consistently use `(..)` for constructors now (#3142, @nwolverson) +- Improved tab completion in `purs repl` (#3227, @rndnoise) +- Large compiler perfomance improvement in some cases by skipping source spans in `Eq`, `Ord` for binders (#3265, @bitemyapp) +- Added support for error/warning messages to carry multiple source spans (#3255, @garyb) +- Improved tab completion in `purs repl` when parens and brackets are involved (#3236, @rndnoise) +- Improved completion in `purs repl` after `:kind` and `:type` (#3237, @rndnoise) +- Added the "magic do" optimisation for the new simplified `Effect` type (`Control.Monad.Eff` is still supported) (#3289, @kRITZCREEK, #3301, @garyb) +- Improvide build startup times when resuming a build with incremental results (#3270, @kRITZCREEK) +- Added compiler-solved `Prim.Row.Nub` type class (#3293, @natefaubion) +- Improved docs for `Prim.Row.Cons` and `Prim.Row.Union` (#3292, @vladciobanu) +- `Functor` can now be derived when quantifiers are used in constructors (#3232, @i-am-tom) +- `purs repl` will now complete types after `::` (#3239, @rndnoise) +- Added compiler-solved `Prim.Row.Lacks` type class (#3305, @natefaubion) +- Added current output path to missing output error message from `purs ide` (#3311, @rgrinberg) +- Improved parser error messages for `.purs-repl` (#3248, @rndnoise) +- `require` in generated JavaScript now includes full `index.js` file paths (#2621, @chexxor) +- Added more compiler-solved type classes and supporting types and kinds to `Prim`: + - `Prim.Ordering` module with `kind Ordering`, `type LT`, `type EQ`, `type GT` + - `Prim.RowList` module with `class RowToList`, `kind RowList`, `type Nil`, `type Cons` + - `Prim.Symbol` module with `class Compare`, `class Append`, `class Cons` + (#3312, @LiamGoodacre, @kRITZCREEK) +- Generated code for closed records now explicitly reconstructs the record rather than looping (#1493, @fehrenbach, [blog post with more details](http://stefan-fehrenbach.net/blog/2018-04-28-efficient-updates-closed-records-purescript/index.html)) +- Enhanced `purs --help` message to include hint about using `--help` with commands (#3344, @hdgarrood) +- `IncorrectConstructorArity` error message now includes a hint of how many arguments are expected for the constructor (#3353, @joneshf) +- `purs ide` now uses absolute locations for file paths for better experience in some editors (#3363, @kRITZCREEK) + +**Bug fixes** + +- Fixed a bug with names cause by `Prim` always being imported unqualified (#2197, @LightAndLight) +- Fixed overlapping instances error message to reflect its new status as an error (#3084, @drets) +- Added source position to `TypeClassDeclaration` errors (#3109, @b123400) +- Fixed entailment issues with skolems and matches in the typechecker (#3121, @LiamGoodacre) +- Fixed multiple parentheses around a type causing a crash (#3085, @MonoidMusician) +- Fixed `purs ide` inserting conflicting imports for types (#3131, @nwolverson) +- Fixed constraints being inferred differently for lambda expressions compared with equational declarations (#3125, @LiamGoodacre) +- Updated glob handling to prevent excessive memory usage (#3055, @hdgarrood) +- Added position information to warnings in type declarations (#3174, @b123400) +- Fixed documentation generated for Pursuit rendering functional dependency variables as identifier links (#3180, @houli) +- Naming a function argument `__unused` no longer breaks codegen (#3187, @matthewleon) +- Added position information to `ShadowedName` warning (#3213, @garyb) +- Added position information to `UnusedTypeVar` warning (#3214, @garyb) +- Added position information to `MissingClassMember`, `ExtraneousClassMember`, `ExpectedWildcard` errors (#3216, @garyb) +- Added position information to `ExportConflict` errors (#3217, @garyb) +- Fixed `ctags` and `etags` generation when explicit exports are involved (#3204, @matthewleon) +- Added position information to `ScopeShadowing` warning (#3219, @garyb) +- Added position information for various FFI related errors and warnings (#3276, @garyb) +- Added all available positions to `CycleInModule` and `DuplicateModule` errors (#3273, @garyb) +- Added position information for `IntOutOfRange` errors (#3277, @garyb, @kRITZCREEK) +- Warnings are now raised when a module re-exports a qualified module with implicit import (#2726, @garyb) +- `purs repl` now shows results for `:browse Prim` (#2672, @rndnoise) +- Added position information to `ErrorParsingFFIModule` (#3307, @nwolverson) +- Added position information for `ScopeConflict` cause by exports (#3318, @garyb) +- Added position information to errors that occur in binding groups and data binding groups (#3275, @garyb) +- Fixed a scoping issue when resolving operators (#2803, @kRITZCREEK, @LightAndLight) +- Type synonyms are now desugared earlier when newtype deriving (#3325, @LiamGoodacre) +- Fixed subgoals of compiler-solved type classes being ignored (#3333, @LiamGoodacre) +- Added position information to type operator associativity errors (#3337, @garyb) +- Updated description of `purs docs` command (#3343, @hdgarrood) +- Fixed `purs docs` issue with re-exporting from `Prim` submodules (#3347, @hdgarrood) +- Enabled `purs ide` imports for `Prim` submodules (#3352, @kRITZCREEK) +- Fixed `purs bundle` failing to bundle in the 0.12-rc1 (#3359, @garyb) +- Enabled `:browse` for `Prim` submodules in `purs repl` (#3364, @kRITZCREEK) + +**Other** + +- Updated installation information to include details about prebuild binaries (#3167, @MiracleBlue) +- Test suite now prints output when failing cases are encountered (#3181, @parsonsmatt) +- Updated test suite to use tasty (#2848, @kRITZCREEK) +- Improved performance of `repl` test suite (#3234, @rndnoise) +- Refactored `let` pattern desugaring to be less brittle (#3268, @kRITZCREEK) +- Added makefile with common tasks for contributors (#3266, @bitemyapp) +- Added `ghcid` and testing commands to makefile (#3290, @parsonsmatt) +- Removed old unused `MultipleFFIModules` error (#3308, @nwolverson) +- `mod` and `div` for `Int` are no longer inlined as their definition has changed in a way that makes their implementation more complicated - purescript/purescript-prelude#161 (#3309, @garyb) +- The test suite now checks warnings and errors have position information (#3211, @garyb) +- The AST was updated to be able to differentiate between `let` and `where` clauses (#3317, @joneshf) +- Support for an optimization pass on `CoreFn` was added (#3319, @matthewleon) +- Clarified note in the `purs ide` docs about the behaviour of `--editor-mode` (#3350, @chexxor) +- Updated bundle/install docs for 0.12 (#3357, @hdgarrood) +- Removed old readme for `psc-bundle` (a leftover from before the unified `purs` binary) (#3356, @Cmdv) + +## [v0.12.0-rc1](https://github.com/purescript/purescript/releases/tag/v0.12.0-rc1) - 2018-04-29 + +**Breaking changes** + +- Added applicative-do notation; `ado` is now a keyword. An full explanation of the behaviour and usage of `ado` is available [in a comment on the issue](https://github.com/purescript/purescript/pull/2889#issuecomment-301260299). (#2889, @rightfold) +- Removed wrapper scripts for the old binary names (psc, psci, etc.) (#2993, @hdgarrood) +- Removed compiler support for deriving `purescript-generics`. `purescript-generics-rep` is still supported. (#3007, @paf31) +- Instances with just one method now require the method to be indented (bug fix, but potentially breaking) (#2947, @quesebifurcan) +- Overlapping instances are now an error rather than a warning, but can be resolved with the new instance chain groups feature (#2315, @LiamGoodacre) +- Reworked the `CoreFn` json representation (#3049, @coot) +- It is no longer possible to export a type class that has superclasses that are not also exported (bug fix, but potentially breaking) (#3132, @parsonsmatt) +- `Eq` and `Ord` deriving will now rely on `Eq1` and `Ord1` constraints as necessary where sometimes previously `Eq (f _)` would be required. `Eq1` and `Ord1` instances can also be derived. (#3207, @garyb) +- Some `Prim` type classes have been renamed/moved, so will require explicit importing (#3176, @parsonsmatt): + - `RowCons` is now `Prim.Row.Cons` + - `Union` is now `Prim.Row.Union` + - `Fail` is now `Prim.TypeError.Fail` + - `Warn` is now `Prim.TypeError.Warn` +- Users can no longer specify modules under the `Prim` namespace (#3291, @parsonsmatt) +- `TypeConcat` and `TypeString` have been replaced because they were in kind `Symbol` but weren't literals. The `Prim.TypeErrer.Doc` kind and related constructors (`Text`, `Quote`, `Beside`, `Above`) have been added in their place. The `Fail` and `Warn` type classes now accept a `Doc` instead of a `Symbol`. + (#3134, @LiamGoodacre) +- In simple cases instance overlaps are now checked at declaration time rather than being deferred until an attempt is made to use them. (#3129, @LiamGoodacre) +- Chaining non-associative or mixed associativity operators of the same precedence is no longer allowed (#3315, @garyb) +- The `--dump-corefn` and `--source-maps` arguments to `purs compile` have been removed. There is now a `--codegen` argument that allows the specific codegen targets to be specified - for example, `--codegen corefn` will not produce JS files, `--codgen js,corefn` will produce both. If the `sourcemaps` target is used `js` will be implied, so there's no difference between `--codegen js,sourcemaps` and `--codegen sourcemaps`). If no targets are specified the default is `js`. (#3196, @garyb, @gabejohnson) +- Exported types that use foreign kinds now require the foreign kinds to be exported too (bug fix, but potentially breaking) (#3331, @garyb) + +**Enhancements** + +- Added `Cons` compiler-solved type class for `Symbol` (#3054, @kcsongor) +- The `Append` compiler-solved type class for `Symbol` can now be run in reverse (#3025, @paf31) +- Find Usages for values and constructors in `purs ide` (#3206, @kRITZCREEK) +- `purs ide` treats `hiding` imports the same as open imports when sorting (#3069, @kRITZCREEK) +- Added inlining for fully saturated usages of `runEffFn/mkEffFn` (#3026, @nwolverson) +- Improved explanation of `UnusableDeclaration` error (#3088, #3304, @i-am-tom) +- Improved rendering of comments in generated JavaScript by removing additional newlines (#3096, @brandonhamilton) +- Instance chain support. (#2315, @LiamGoodacre) + > We can now express an explicit ordering on instances that would previously have been overlapping. + > For example we could now write an `IsEqual` type class to compute if two types are equal or apart: + > ``` + > class IsEqual (l :: Type) (r :: Type) (o :: Boolean) | l r -> o + > instance isEqualRefl :: IsEqual x x True + > else instance isEqualContra :: IsEqual l r False + > ``` + > Note the `else` keyword that links the two instances together. + > The `isEqualContra` will only be up for selection once the compiler knows it couldn't possible select `isEqualRefl` - i.e that `l` and `r` are definitely not equal. +- Improved orphan instance error to include locations where the instance would be valid (#3106, @i-am-tom) +- Added an explicit error for better explanation of duplicate type class or instance declarations (#3093, @LiamGoodacre) +- `purs ide` now provide documentation comments (#2349, @nwolverson) +- Clarified meaning of duplicate labels in a `Record` row (#3143, @paf31) +- Explicit import suggestions consistently use `(..)` for constructors now (#3142, @nwolverson) +- Improved tab completion in `purs repl` (#3227, @rndnoise) +- Large compiler perfomance improvement in some cases by skipping source spans in `Eq`, `Ord` for binders (#3265, @bitemyapp) +- Added support for error/warning messages to carry multiple source spans (#3255, @garyb) +- Improved tab completion in `purs repl` when parens and brackets are involved (#3236, @rndnoise) +- Improved completion in `purs repl` after `:kind` and `:type` (#3237, @rndnoise) +- Added the "magic do" optimisation for the new simplified `Effect` type (`Control.Monad.Eff` is still supported) (#3289, @kRITZCREEK, #3301, @garyb) +- Improvide build startup times when resuming a build with incremental results (#3270, @kRITZCREEK) +- Added compiler-solved `Prim.Row.Nub` type class (#3293, @natefaubion) +- Improved docs for `Prim.Row.Cons` and `Prim.Row.Union` (#3292, @vladciobanu) +- `Functor` can now be derived when quantifiers are used in constructors (#3232, @i-am-tom) +- `purs repl` will now complete types after `::` (#3239, @rndnoise) +- Added compiler-solved `Prim.Row.Lacks` type class (#3305, @natefaubion) +- Added current output path to missing output error message from `purs ide` (#3311, @rgrinberg) +- Improved parser error messages for `.purs-repl` (#3248, @rndnoise) +- `require` in generated JavaScript now includes full `index.js` file paths (#2621, @chexxor) +- Added more compiler-solved type classes and supporting types and kinds to `Prim`: + - `Prim.Ordering` module with `kind Ordering`, `type LT`, `type EQ`, `type GT` + - `Prim.RowList` module with `class RowToList`, `kind RowList`, `type Nil`, `type Cons` + - `Prim.Symbol` module with `class Compare`, `class Append`, `class Cons` + (#3312, @LiamGoodacre, @kRITZCREEK) +- Generated code for closed records now explicitly reconstructs the record rather than looping (#1493, @fehrenbach, [blog post with more details](http://stefan-fehrenbach.net/blog/2018-04-28-efficient-updates-closed-records-purescript/index.html)) + +**Bug fixes** + +- Fixed a bug with names cause by `Prim` always being imported unqualified (#2197, @LightAndLight) +- Fixed overlapping instances error message to reflect its new status as an error (#3084, @drets) +- Added source position to `TypeClassDeclaration` errors (#3109, @b123400) +- Fixed entailment issues with skolems and matches in the typechecker (#3121, @LiamGoodacre) +- Fixed multiple parentheses around a type causing a crash (#3085, @MonoidMusician) +- Fixed `purs ide` inserting conflicting imports for types (#3131, @nwolverson) +- Fixed constraints being inferred differently for lambda expressions compared with equational declarations (#3125, @LiamGoodacre) +- Updated glob handling to prevent excessive memory usage (#3055, @hdgarrood) +- Added position information to warnings in type declarations (#3174, @b123400) +- Fixed documentation generated for Pursuit rendering functional dependency variables as identifier links (#3180, @houli) +- Naming a function argument `__unused` no longer breaks codegen (#3187, @matthewleon) +- Added position information to `ShadowedName` warning (#3213, @garyb) +- Added position information to `UnusedTypeVar` warning (#3214, @garyb) +- Added position information to `MissingClassMember`, `ExtraneousClassMember`, `ExpectedWildcard` errors (#3216, @garyb) +- Added position information to `ExportConflict` errors (#3217, @garyb) +- Fixed `ctags` and `etags` generation when explicit exports are involved (#3204, @matthewleon) +- Added position information to `ScopeShadowing` warning (#3219, @garyb) +- Added position information for various FFI related errors and warnings (#3276, @garyb) +- Added all available positions to `CycleInModule` and `DuplicateModule` errors (#3273, @garyb) +- Added position information for `IntOutOfRange` errors (#3277, @garyb, @kRITZCREEK) +- Warnings are now raised when a module re-exports a qualified module with implicit import (#2726, @garyb) +- `purs repl` now shows results for `:browse Prim` (#2672, @rndnoise) +- Added position information to `ErrorParsingFFIModule` (#3307, @nwolverson) +- Added position information for `ScopeConflict` cause by exports (#3318, @garyb) +- Added position information to errors that occur in binding groups and data binding groups (#3275, @garyb) +- Fixed a scoping issue when resolving operators (#2803, @kRITZCREEK, @LightAndLight) +- Type synonyms are now desugared earlier when newtype deriving (#3325, @LiamGoodacre) +- Fixed subgoals of compiler-solved type classes being ignored (#3333, @LiamGoodacre) +- Added position information to type operator associativity errors (#3337, @garyb) + +**Other** + +- Updated installation information to include details about prebuild binaries (#3167, @MiracleBlue) +- Test suite now prints output when failing cases are encountered (#3181, @parsonsmatt) +- Updated test suite to use tasty (#2848, @kRITZCREEK) +- Improved performance of `repl` test suite (#3234, @rndnoise) +- Refactored `let` pattern desugaring to be less brittle (#3268, @kRITZCREEK) +- Added makefile with common tasks for contributors (#3266, @bitemyapp) +- Added `ghcid` and testing commands to makefile (#3290, @parsonsmatt) +- Removed old unused `MultipleFFIModules` error (#3308, @nwolverson) +- `mod` and `div` for `Int` are no longer inlined as their definition has changed in a way that makes their implementation more complicated - purescript/purescript-prelude#161 (#3309, @garyb) +- The test suite now checks warnings and errors have position information (#3211, @garyb) +- The AST was updated to be able to differentiate between `let` and `where` clauses (#3317, @joneshf) +- Support for an optimization pass on `CoreFn` was added (#3319, @matthewleon) + +## [v0.11.7](https://github.com/purescript/purescript/releases/tag/v0.11.7) - 2017-11-15 + +**Enhancements** + +- Add position to type class declaration errors (@b123400) +- Add valid location list to orphan instance errors (@i-am-tom) +- Expand error message for UnusableDeclaration (#3088, @i-am-tom) +- Inline `Unsafe.Coerce.unsafeCoerce` (@coot) + +**Bug Fixes** + +- Correctly quote uppercased field labels in errors (@Thimoteus) +- `purs ide` inserts conflicting imports for types (#3131, @nwolverson) +- Instantiate abstraction body during inference to fix a type checking bug (@LiamGoodacre) +- Fix a bug related to the desugaring of nested parentheses (@MonoidMusician) +- Fix a loop in the kind checker (@paf31) +- Fix a bug in type operator precedence parsing (@paf31) +- Eliminate some redundant whitespace in the generated JS output (@matthewleon) +- Only add newline before initial group of comment lines during code generation (@brandonhamilton) +- Treat kinds as used in import warnings (@nwolverson) + +**`purs ide`** + +- Add an "editor mode" (@kRITZCREEK) + + When the `editor-mode` flag is specified at startup the server will not start afile watcher process any more. Instead it only reloads after successful rebuild commands. This is a lot less fragile than relying on the file system APIs, but will mean that a manual load needs to be triggered after builds that didn't go through `purs ide`. + +- `purs ide` now groups `hiding` imports with implicit ones (@kRITZCREEK) +- Return documentation comments in `purs ide` completions (@nwolverson) +- Add an `actualFile` parameter to the rebuild command (@kRITZCREEK) +- Add qualified explicit import (@nwolverson) +- Fixed case-splitting on local non-exported datatypes (@LightAndLight) +- Make the `filters` parameter in the `type` command optional (@b123400) + +**`purs docs`** + +- Embed CSS for HTML docs (@hdgarrood) +- Fix source links for re-exports (@felixSchl) +- Use order given in export list in generated docs (@hdgarrood) +- Prevent browser from treating the title and source link as one word (@Rufflewind) +- Fix fragment links to type constructors in HTML (@hdgarrood) + +**`purs repl`** + +- Add `:complete` directive to `purs repl` to support completion in more editors (@actionshrimp) + +**Other** + +- Add docs for duplicate labels in record types (@paf31) +- Adds a document for the design of `purs ide`. (@kRITZCREEK) +- Update `PROTOCOL.md` docs for `purs ide` (@BjornMelgaard) +- Upgrade to GHC version 8.2 (@kRITZCREEK) +- Allow `blaze-html-0.9` (@felixonmars) +- Bump `Glob` dependency (@mjhoy) +- Use `Hspec` in `TestDocs` (@hdgarrood) +- Fix AppVeyor deployment (#2774) (@hdgarrood) +- Various type safety improvements to the AST (@kRITZCREEK) +- Remove some references to old executables (@hdgarrood) +- Update the installation documentation (@hdgarrood) +- Update test dependencies (@hdgarrood) +- Only build `master` and versioned tags in AppVeyor (@hdgarrood) + +## [v0.11.6](https://github.com/purescript/purescript/releases/tag/v0.11.6) - 2017-07-10 + +**New Features** + +**`RowToList` support** + +(@LiamGoodacre) + +There is a new type class in `typelevel-prelude` called `RowToList`, which turns +a row of types into a type-level list. This allows us to work with closed +rows in more ways at the type level. The compiler will now solve these constraints +automatically for closed rows of types. + +**Enhancements** + +- Allow things to be hidden from Prim (@garyb) +- Re-evaluate REPL globs on `:reload` (@hdgarrood) +- Include comments in child declarations in HTML docs (@hdgarrood) + +**IDE Enhancements** + +- Collect data constructors (@kRITZCREEK) +- Adds declarations for Prim (@kRITZCREEK) +- Repopulates the rebuild cache when populating volatile state (@kRITZCREEK) +- Add declaration type filter (#2924) (@sectore) +- Improve reexport bundling (@kRITZCREEK) +- Resolve synonyms and kinds (@kRITZCREEK) + +**Bug Fixes** + +- Replace synonyms in instance constraints (@LiamGoodacre) +- Encode PSCI's server content as UTF-8 string (@dgendill) +- Fix child declaration ordering in docs (@hdgarrood) +- Improve instance ordering in HTML docs (@hdgarrood) +- Fix links to type operators in HTML docs (@hdgarrood) + +**Other** + +- Add source span annotations to Declaration (@garyb) +- Add source span annotations to DeclarationRef (@garyb) +- Remove `purescript.cabal` and add to `.gitignore` (@garyb) +- Raise upper bound on `aeson` in `package.yaml` (@garyb) +- Only build master and semver tags in Travis (@hdgarrood) + +## [v0.11.5](https://github.com/purescript/purescript/releases/tag/v0.11.5) - 2017-06-05 + +**Compiler** + +**Enhancements** + +**Type signatures in instances** + +(@cdepillabout) + +Type class instances can now include type signatures for class members, as documentation: + +```purescript +data MyType = MyType String + +instance showMyType :: Show MyType where + show :: MyType -> String + show (MyType s) = "(MyType " <> show s <> ")" +``` + +**Bug Fixes** + +- Encode HTML content as UTF8 when using `purs repl` with `--port` (@dgendill) +- Disallow some invalid newtype-derived instances (@paf31) +- Disallow `forall` within constraints (#2874, @sectore) +- Convert `\r\n` into `\n` after reading files (@kRITZCREEK) +- Fix PSCi tests (@kRITZCREEK) +- Better variable naming hygiene in TCO. (#2868, @houli) +- Simplify TCO generated code (@matthewleon) +- Remove newlines from printed custom type errors (@matthewleon) +- Fix some `purs` command line help message issues (@Cmdv) +- Apply relative paths during pretty printing of errors (@kRITZCREEK) +- Desugar `let` properly when generating docs (@paf31) +- Fix kind signature for `RowCons` type class in documentation (@tslawler) +- Fix an issue with error messages for `TypesDoNotUnify` involving duplicate labels (#2820, @thoradam) + +**Other** + +- Update `package.yaml` (@sol) +- Parse support modules from actual test support `purs` (@noraesae) +- Update `build` command to run tests (@sectore) +- Bumps lower bound for `directory` (@kRITZCREEK) +- Switch `core-tests` to `psc-package` (#2830, @matthewleon) +- Small fix for the copyright dates (@seanwestfall) +- Update `CONTRIBUTING.md` for "new contributor" label (@thoradam) + +**`purs ide`** + +**Features** + +- Add a new namespace filter (#2792, @sectore, @stefanholzmueller) + +A new filter, which restricts query results to the value, type and/or kind namespaces, which allows improvements to the completion and import commands. + +- Adds a command to add qualified imports (@kRITZCREEK) + +This empowers editor plugins to add imports for qualified identifiers, for example in [the Emacs plugin](https://github.com/epost/psc-ide-emacs/pull/103). + +- New import formatting (@kRITZCREEK) +- Group reexports in completions (@kRITZCREEK) + +Editors can now choose to let `purs ide` group reexports for the same value, to reduce noise when completing values like `Data.Functor.map` which are reexported a lot and show up that many times in the completion list. + +**Enhancements** + +- Parse modules in parallel (@kRITZCREEK) + +This can yield significant speedups in the initial load times. For example a full load of `slamdata/slamdata` improves from 11 to 6 seconds + +- Introduce completion options (@kRITZCREEK) + +**Bug Fixes** + +- Resolve synonyms and kinds (@kRITZCREEK) +- Work around laziness when measuring command performance (@kRITZCREEK) +- Simplify state type (@kRITZCREEK) +- Extract namespace ADT (@kRITZCREEK) +- Decodes source files as UTF8 when parsing out the imports (@kRITZCREEK) +- Fix the import command for kinds (@kRITZCREEK) +- Reads files in text mode for adding imports (@kRITZCREEK) +- Add `-h`/`--help` to `ide` subcommands (@simonyangme) + +## [v0.11.4](https://github.com/purescript/purescript/releases/tag/v0.11.4) - 2017-04-17 + +**Enhancements** + +- `purs` executable will now display help text by default (@matthewleon) +- Adding `-h`/`--help` to `ide` subcommands (@simonyangme) +- Some simplifications to the tail call optimization (@matthewleon) + +**Bug Fixes** + +- Remove newline from printed custom type errors (@matthewleon) +- Fix pretty printing of rows in error messages (#2820, @thoradam) +- Allow user to propagate Warn constraints (@paf31) +- Match type level strings in docs renderer (#2772, @hdgarrood) +- Fix encoding bug in `purs ide` list import command (@kRITZCREEK) +- `purs ide` now reads files in text mode for adding imports (@kRITZCREEK) + +**Other** + +- Bump `aeson` lower bound to 1.0 (@hdgarrood) +- Add a bunch of NFData instances (@hdgarrood) +- Turn off coveralls upload for now (@paf31) +- `purs` command line help message fixes (@Cmdv) +- Switch core-tests to `psc-package` (#2830, @matthewleon) +- Update `CONTRIBUTING.md` notes (@thoradam) + +## [v0.11.3](https://github.com/purescript/purescript/releases/tag/v0.11.3) - 2017-04-08 + +**Bug Fixes** + +- Fix the exhaustivity check for pattern guards (@alexbiehl) + +**Other** + +- Require `directory >=1.2.3.0` for XDG support (@bergmark) +- @noraesae has refactored some PSCi code to improve the test suite. +- Use `hpack` to generate the `.cabal` file (@kRITZCREEK) +- Use XDG Base Directory Specification for `psci_history` (@legrostdg) + +## [v0.11.2](https://github.com/purescript/purescript/releases/tag/v0.11.2) - 2017-04-02 + +**New Features** + +**Polymorphic Labels** + +(@paf31) + +A new `RowCons` constraint has been added to `Prim`. `RowCons` is a 4-way relation between + +1. Symbols +1. Types +1. Input rows +1. Output rows + +which appends a new label (1) with the specified type (2) onto the front of the input row (3), to generate a new output row (4). The constraint can also be run backwards to subtract a label from an output row. + +This allows us to quantify types over labels appearing at the front of a row type, by quantifying over the corresponding symbol/type pair. This gives us a limited form of polymorphic labels which enables things like writing [a single lens for any record accessor](https://github.com/purescript/purescript/blob/e4ff177017f1411ad4cbeade129cfe1bb52d6e99/examples/passing/PolyLabels.purs#L41-L51). + +**Enhancements** + +- Use XDG Base Directory Specification for the location of the `psci_history` file (@legrostdg) +- Collect more information for classes and synonyms in `purs ide` (@kRITZCREEK) + +**Bug Fixes** + +- Desugar pattern guards *after* type checking, to avoid an issue with the exhaustivity checker (@alexbiehl) + +**Other** + +- A new PSCi evaluation test suite was added (@noraesae) +- Use `hpack` to generate the `.cabal` file (@kRITZCREEK) + +## [v0.11.1](https://github.com/purescript/purescript/releases/tag/v0.11.1) - 2017-03-28 + +**Bug Fixes** + +**Compiler** + +- Enable TCO for variable intros and assignments #2779 (@paf31) +- Fixed special case in codegen for guards #2787 (@paf31) + +**Docs generation** + +- Wrap decl title in span for better double-click selection #2786 (@rightfold) +- List instance info under correct sections, fix #2780 (@paf31) + +## [v0.11.0](https://github.com/purescript/purescript/releases/tag/v0.11.0) - 2017-03-25 + +This release includes several breaking changes, in preparation for the 1.0 release, as well as many enhancements and bug fixes. + +Most users will probably want to wait until all aspects of the release have been finalized. Progress on libraries and tools is being tracked [here](https://github.com/purescript/purescript/issues/2745). + +Many thanks to the contributors who helped with this release! + +**Breaking Changes** + +(@garyb, @paf31) + +**`=>` now acts like a binary type operator** + +It was previously possible to specify many constraints in the same context by +separating them with commas inside parentheses on the left of the `=>`: + +```purescript +runFreeT :: ∀ m f. (Functor f, Monad m) => ... +``` + +This is no longer allowed. Instead, `=>` now acts like a binary operator, with a +constraint on the left and a type on the right. Multiple constraints must be +introduced using currying, as with regular function arguments: + +```purescript +runFreeT :: ∀ m f. Functor f => Monad m => ... +``` + +This is in preparation for adding _constraint kinds_, at which point `=>` will become +an actual binary type operator, defined in `Prim`. + +**`*` and `!` kinds have been removed** + +The kind symbols `*` (for the kind of types) and `!` (for the kind of effects) have been +removed from the parser. Instead of `*`, use `Type`, which is defined in `Prim`. +Instead of `!`, use `Effect`, which can now be imported from `Control.Monad.Eff`. + +The `#` symbol, which is used to construct a row kind, is still supported. We cannot move this kind into `Prim` (because it is polykinded, and we do not support kind polymorphism). + +**One single consolidated executable** + +The various `psc-*` executables have been replaced with a single executable called `purs`. +The various subcommands are documented on the `--help` page: + +``` +bundle Bundle compiled PureScript modules for the browser +compile Compile PureScript source files +docs Generate Markdown documentation from PureScript source files +hierarchy Generate a GraphViz directed graph of PureScript type classes +ide Start or query an IDE server process +publish Generates documentation packages for upload to Pursuit +repl Enter the interactive mode (PSCi) +``` + +Wrapper scripts will be provided in the binary distribution. + +**`psc-package` was removed** + +`psc-package` has been removed from the main compiler distribution. It will still +be maintained along with the package sets repo, but will not be bundled with the compiler. + +A binary distribution which is compatible with this release is [available](https://github.com/purescript/psc-package/releases/tag/v0.1.0). + +**Implicitly discarded values in `do` blocks now raise errors** + +Code which discards the result of a computation in a `do` block: + +```purescript +duplicate :: Array a -> Array a +duplicate xs = do + x <- xs + [true, false] -- the result here is discarded + pure x +``` + +will now raise an error. The compiler allows values of certain types to be discarded, +based on the `Discard` class in `Control.Bind`. The only type which can be discarded is +`Unit`, but the feature was implemented using a type class to enable support for +alternative preludes. + +**No more dependency on the Bower executable** + +In addition to removing `psc-package` from the compiler distribution, we have also +removed any explicit dependency on the Bower executable. The compiler will not assume +use of any particular package manager, but will aim to provide generic support for +package managers generally, via command line options and hooks. + +`purs publish` will continue to use the Bower JSON formats. The `bower.json` format +is now referred to as the "manifest file", while the output of `bower list --json`, +which is used by `purs publish` internally, is referred to as the "resolutions file". + +**Enhancements** + +**Pattern Guards** + +(@alexbiehl) + +In addition to regular guards: + +```purescript +foo x | condition x = ... +``` + +the compiler now supports _pattern guards_, which let the user simultaneously +test a value against a pattern, and bind names to values. + +For example, we can apply a function `fn` to an argument `x`, succeeding only if +`fn` returns `Just y` for some `y`, binding `y` at the same time: + +```purescript +bar x | Just y <- fn x = ... -- x and y are both in scope here +``` + +Pattern guards can be very useful for expressing certain types of control flow when +using algebraic data types. + +**HTML Documentation** + +(@hdgarrood) + +The `--format html` option has been added to `purs docs`. The HTML format uses +the Pursuit template, and is very useful for rendering documentation for offline +use. + +[Here is an example](http://harry.garrood.me/purs-html-docs-example/) of the generated HTML. + +**Duplicate Labels** + +(@paf31) + +Row types now support duplicate labels, which can be useful when using the `Eff` +monad. For example, we could not previously use the `catchException` function if +the resulting action _also_ required the `EXCEPTION` effect, since otherwise the +type of the inner action would contain a duplicate label. + +Rows are now unordered collections (of labels and types) _with duplicates_. However, +the collection of types for a specific label within a row _is_ ordered. +Conceptually, a row can be thought of as a type-level `Map Label (NonEmptyList Type)`. + +A type constructor (such as `Record`) which takes a row of types as an argument should +define what its meaning is on each row. The meaning of a value of type `Record r` +is a JavaScript object where the type of the value associated with each label is given +by the head element of the non-empty list of types for that label. + +**Row Constraints** + +(@doolse, @paf31) + +A new constraint called `Union` has been added to `Prim`. `Union` is a three-way relation between +rows of types, and the compiler will solve it automatically when it is possible to do so. + +`Union` is a left-biased union of rows which takes into account duplicate labels. If the same label appears in rows `l` and `r`, and `Union l r u` holds, then the label will appear twice in `u`. + +`Union` makes it possible to give a type to the function which merges two records: + +```purescript +merge :: forall r1 r2 r3. Union r1 r2 r3 => Record r1 -> Record r2 -> Record r3 +``` + +Note that this is a left-biased merge - if the two input record contain a common label, the type of the +label in the result will be taken from the left input. + +**Patterns in `let` expressions** + +(@noraesae) + +Let expressions and `where` clauses can now use binders on the left hand side of +a declaration: + +```purescript +map f xs = + let { head, tail } = uncons xs + in [f head] <> map f tail +``` + +Unlike in Haskell, declarations with these patterns cannot appear in dependency cycles, and bound names can only be used in declarations after the one in which they are brought into scope. + +**Find record accessors in Type Directed Search** + +(@kRITZCREEK) + +Type-directed search will now include results for record accessors. This can +be very useful when working with extensible records with a type-driven programming +workflow. + +**Other Enhancements** + +- Add basic usability check and error for ambiguously-typed type class members (@LiamGoodacre) +- Improved skolem escape check (@paf31) +- Fix links to declarations in `Prim` (@hdgarrood) +- Emit `_` instead of `false` case for `if then else` to improve optimizations (@rightfold) +- Add `InvalidDerivedInstance` error to improve errors for derived instances (@paf31) +- Make generated code for superclass instances less ugly (@paf31) +- Support polymorphic types in typed binders (@paf31) +- Make file paths relative in error messages (@paf31) +- Improve errors from module sorter (@paf31) +- Improve error for unused type variables (@paf31) +- Include source span in externs file for error reporting purposes (@paf31) +- Improve instance arity errors (@mrkgnao) + +**`purs ide`** + +**Features** + +**Improve import parsing** + +- `purs ide` now uses a new import parser, which allows `purs ide` to handle any +import section that the compiler would accept correctly. (@kRITZCREEK) +- Parse imports with hanging right paren (@matthewleon) +- Reuses lenient import parsing for the list import command (@kRITZCREEK) + +**Don't create the output/ directory if it can't be found** + +(@kRITZCREEK) + +`purs ide` will now no longer leave empty output/ directories behind when it is +started in a directory that is not a PureScript project. + +**Collect type class instances** + +(@kRITZCREEK) + +`purs ide` collects instances and stores them with their respective type class. +There's no way to retrieve these yet, but we will extend the protocol soon. + +**Bug Fixes** + +- No longer strip trailing dots for Pursuit queries (@kRITZCREEK) +- Fix #2537 (`psc-ide` shouldn't crash when building a non-existent file) (@kRITZCREEK) +- Fix #2504 (fix a crash related to prematurely closed handles) (@kRITZCREEK) +- Speed up rebuilding by x2, by rebuilding with open exports asynchronously (@kRITZCREEK) +- Return operators in `purs ide` imports list (@nwolverson) +- Also detect location information for operators (@kRITZCREEK) + +**Cleanup** + +- Removes unnecessary clause in import pretty printing (@kRITZCREEK) +- Removes the deprecated `--debug` option (@kRITZCREEK) +- Restructure testing to avoid running the server (@kRITZCREEK) + +**`purs repl`** + +- Add back `.purs-repl` file support (@paf31) +- PSCi command changes, add `:clear` (@noraesae) +- Declarations no longer require `let` (@noraesae) +- Improve CLI error and startup messages (@noraesae) + +**Bug Fixes** + +- Changes to help the tail call optimization fire more consistently (@paf31) +- Fix `everythingWithScope` traversal bug #2718 (@paf31) +- Errors for open rows in derived instances (@paf31) +- Instantiate types in record literals as necessary (@paf31) +- Fix `Generic` deriving with synonyms (@paf31) +- Rebuild modules if necessary when using `--dump-corefn` (@paf31) +- Ensure solved type classes are imported (@LiamGoodacre) +- Allow for older Git versions in `purs publish` (@mcoffin) +- Fix `purs publish --dry-run` (@hdgarrood) +- Exported data constructors can now contain quotes (@LiamGoodacre) + +**Documentation** + +- Capitalise *script into *Script (@noraesae) + +**Performance** + +- Optimize `keepImp` (@paf31) +- Replace `nub` with `ordNub` (@matthewleon) +- Combine inlining optimizations into a single pass (@paf31) + +**Other** + +- Add `HasCallStack` to internalError (@alexbiehl) +- Use Stackage LTS 8.0 (@noraesae) +- Address Travis timeout issues (@hdgarrood) +- Improve module structure in PSCi test suite (@noraesae) +- Fix the PSCi script (@mrkgnao) +- Include Git commit information in non-release builds (@hdgarrood) +- Add test case for #2756 (@int-index) +- Some code cleanup in the module imports phase (@matthewleon) + +## [v0.10.7](https://github.com/purescript/purescript/releases/tag/v0.10.7) - 2017-02-11 + +This release contains a bug fix for a bug in `psc-bundle` which was introduced in 0.10.6. + +## [v0.10.6](https://github.com/purescript/purescript/releases/tag/v0.10.6) - 2017-02-07 + +**Enhancements** +- Add support for user defined warnings via the `Warn` type class (@LiamGoodacre, [blog post](https://liamgoodacre.github.io/purescript/warnings/2017/01/17/purescript-warn-type-class.html)) +- Support nested record update (@LiamGoodacre, [blog post](https://liamgoodacre.github.io/purescript/records/2017/01/29/nested-record-updates.html)) +- Inline `unsafePartial` (@paf31) +- Fail early when `bind` is brought into scope inside `do` (@paf31) + +**Bug Fixes** +- Disallow polymorphic types in binders, preventing a crash (@paf31) +- Rebuild modules if necessary when using `--dump-corefn` (@paf31) +- `TypeLevelString`/`TypeConcat` should not be quoted (@michaelficarra) +- Generate JS static member accesses whenever possible (@michaelficarra) +- Require dependencies to exist during sorting phase (@paf31) +- Fix inlining for `negateInt` (@paf31) +- Fix object key quoting (@hdgarrood) +- Don't expand synonyms until after kind checking (@paf31) +- Fix 'Unknown type index' on mismatch between class and instance argument counts (@LiamGoodacre) +- Style comment types differently (@matthewleon) + +**`psc-ide`** +- Return operators in `psc-ide` imports list (@nwolverson) +- Collect type class instances (@kRITZCREEK) +- Log failing to accept or parse an incoming command (@kRITZCREEK) +- Fix #2537 (@kRITZCREEK) +- Fix #2504 (@kRITZCREEK) +- Also detect location information for operators (@kRITZCREEK) +- Speeds up rebuilding by x2 (@kRITZCREEK) +- Restructure testing to avoid running the server (@kRITZCREEK) + +**`psc-publish`** +- Add modules for rendering HTML documentation (@hdgarrood) +- Fix `psc-publish --dry-run` (@hdgarrood) +- Fix failure to parse git tag date in `psc-publish` (@hdgarrood) +- Add git tag time to `psc-publish` JSON (@hdgarrood) +- Remove `Docs.Bookmarks` (@hdgarrood) + +**Performance** +- Combine inlining optimizations into a single pass (@paf31) +- Use `Map.foldlWithKey'` instead of `foldl` (@hdgarrood) +- Minor memory usage improvements in `Language.PureScript.Docs` (@hdgarrood) + +**Other** +- Generate data constructors without IIFEs (@hdgarrood) +- Add stack-ghc-8.0.2.yaml (@noraesae) +- Add `HasCallStack` to `internalError` (@alexbiehl) +- Update `psc-package` to use turtle 1.3 (@taktoa) +- Remove `JSAccessor`; replace with `JSIndexer` (@michaelficarra) +- Store more information in `RenderedCode` (@hdgarrood) + +## [v0.10.5](https://github.com/purescript/purescript/releases/tag/v0.10.5) - 2017-01-06 + +**Enhancements** +- Adds specific error message when failing to import bind (@FrigoEU) + +**Bug Fixes** +- Detect conflicting data constructor names (@LiamGoodacre) +- Update pretty printer for Kinds (@hdgarrood) +- Restore JSON backwards compatibility for `PSString` (@hdgarrood) +- Replace type wildcards earlier (@paf31) +- Restore backwards compatibility for parsing Kinds (@hdgarrood) + +**Other** +- Update `bower-json` to 1.0.0.1 (@hdgarrood) + +## [v0.10.4](https://github.com/purescript/purescript/releases/tag/v0.10.4) - 2017-01-02 + +**New Features** + +**Deriving `Functor`** + +(@LiamGoodacre, #2515) + +The `Functor` type class can now be derived using the standard `derive instance` syntax: + +``` purescript +newtype F a = F { foo :: Array a, bar :: a } + +derive instance functorF :: Functor F +``` + +**User-Defined Kinds** + +(@LiamGoodacre, #2486) + +Custom kinds can now be defined using the `foreign import kind` syntax: + +``` purescript +foreign import kind SymbolList +``` + +Custom kinds can be ascribed to types using `foreign import data` declarations, as usual: + +``` purescript +foreign import data Nil :: SymbolList +foreign import data Cons :: Symbol -> SymbolList -> SymbolList +``` + +Note that kind arguments are not supported. + +User defined kinds can be imported/exported using the `kind` prefix, for example: + +``` purescript +import Type.SymbolList (kind SymbolList) +``` + +**Source Maps in `psc-bundle`** + +(@nwolverson) + +`psc-bundle` will now generate source maps if the`--source-maps` flag is used. + +**Solving `CompareSymbol` and `AppendSymbol`** + +(@LiamGoodacre, #2511) + +Support for the new `purescript-typelevel-prelude` library has been added to the compiler. `CompareSymbol` and `AppendSymbol` constraints will now be solved automatically for literal symbols. + +**New `psc-package` Features** + +(@paf31) + +Two new commands have been added to `psc-package` to support library authors and package set curators. +- The `updates` command (#2510) is used to update packages in the set. +- The `verify-set` command (#2459) is used to verify the health of a package set. This command replicates the work done by the `package-sets` CI job, and can be used to test modifications to the package set locally before making a pull request. + +**Enhancements** +- Update orphan instance check to use covering sets when functional dependencies are involved (@LiamGoodacre) +- Add `--node-path` option to PSCi to modify the path to the Node executable (#2507, @paf31) +- Add package information to re-exports (@hdgarrood) +- Add `Prim` docs to the library (#2498, @hdgarrood) + +**Bug Fixes** +- Derive instances when data types use type synonyms (#2516, @paf31) +- Unwrap `KindedType` when instance solving (@LiamGoodacre) +- Update links to wiki (#2476, @LiamGoodacre) +- Update websocket host to fix PSCi on Windows (#2483, @seungha-kim) +- Fix `psc-ide` tests on windows (@kRITZCREEK) +- Fix some issues with the pretty printer (#2039, @paf31) + +**Other** +- More robust license generator script (@hdgarrood) +- Further conversions to `Text` in the `Docs` modules (#2502, @hdgarrood) +- Add upper bound on `turtle`, fixes #2472, (@hdgarrood) +- Fix version bounds on `language-javascript` (@hdgarrood) + +## [v0.10.3](https://github.com/purescript/purescript/releases/tag/v0.10.3) - 2016-12-11 + +**Enhancements** + +**Solving `IsSymbol` instances** + +(@LiamGoodacre) + +The compiler will now derive `Data.Symbol.IsSymbol` instances for type-level string literals. + +This enables interesting type-level programming features, such as [deriving `Show` instances using `Data.Generics.Rep`](https://asciinema.org/a/1lc5nn3o9b24y2bos8eowmfa9). + +**Rows in Instance Heads** + +(@LiamGoodacre) + +The compiler now allows rows to appear in type class instance heads, but only in type arguments which are fully determined by some functional dependency. + +This allows instances like + +``` purescript +MonadState { field :: Type } MyAppMonad +``` + +and also `Newtype` instances for newtypes which contain records. + +**Speeds up parsing by reading files as Text** + +(@kRITZCREEK) + +The use of `String` has been replaced by `Text` in the compiler, resulting in some non-trivial performance improvements. + +**Functional Dependencies in `psc-docs` output** + +(@soupi, #2439) + +`psc-docs` now includes functional dependency information when rendering type classes. + +**New `psc-package` Commands** +- The `available` command (@andyarvanitis) shows all available packages in the current package set +- The `uninstall` command (@joneshf) removes a package from the set of active packages and updates the package configuration file. + +**Type Class Warning (@joneshf)** + +A warning was added for shadowed type variables in type class declarations. + +**Bug Fixes** +- `psc-package`: display full path in 'packages.json does not exist' error messsage (@andyarvanitis) +- Use `writeUTF8File` in `psc-bundle` (@hdgarrood) +- Use HTTPS to query Pursuit (@paf31) +- Moved the expansion of astral code points to UTF-16 surrogate pairs from the JS code generator to the parser (@michaelficarra, #2434) +- Allow astral code points in record literal keys (@michaelficarra, #2438) +- Add value source positions (@nwolverson) +- Update error message of `ErrorInDataBindingGroup` to include participating identifiers (@LiamGoodacre) + +**`psc-ide`** +- Polling option for psc-ide-server (@kRITZCREEK) +- Better logging and diagnostics (@kRITZCREEK) + +**Other** +- Dump output of `psc` tests to file (@andyarvanitis, #2453) +- Fix windows CI (@hdgarrood) +- Link to new documentation repo (@hdgarrood) +- Create documentation for psc-package (@paf31) +- Fix GHC 8.0.2 build (@RyanGlScott) +- Add `psc-package` to release bundle (@marsam) +- Update for latest `language-javascript` (@tmcgilchrist) +- Fix exhaustivity warnings (@charleso) +- Update `CONTRIBUTING.md` (@osa1) + +## [v0.10.2](https://github.com/purescript/purescript/releases/tag/v0.10.2) - 2016-11-07 + +**Major Changes** + +**Type-directed search (@kRITZCREEK)** + +This extends the typed holes error messages to include suggested replacements for a typed hole, by using type subsumption to determine which identifiers in scope are appropriate replacements. + +A blog post will accompany this feature soon. + +**`psc-package` (@paf31)** + +This is an experimental package manager for PureScript packages. It supports the following commands: +- `init` - create a new project using the package set for the current compiler version +- `update` - sync the local package collection with the package set +- `install` - install a specific package from the current set and add it to the package config +- `build` - run `psc` on any active packages +- `sources` - list source globs for active package versions +- `dependencies` - list transitive dependencies of the current project + +For example: + +``` text +$ psc-package init +$ psc-package install transformers +$ psc-package build +``` + +Eventually, `psc-package` might replace the use of Bower, but that will require support from tools like Pulp. For now, package authors should continue to publish packages using Bower and Pursuit. + +**`Data.Generic.Rep.Generic` Deriving (@paf31)** + +This is an alternative generic programming implementation based on `GHC.Generics`. It should allow deriving of more interesting classes, such as `Semigroup`. See the `purescript-generics-rep` package for examples. + +**Enhancements** +- #2323: Sort IDE-generated explicit imports (@bbqbaron) +- #2374: Add error message for ambiguous type variables in inferred contexts (@bbqbaron) +- #934 Add paste mode, remove --multi-line option (@paf31) +- Allow symbols in data constructors (@brandonhamilton) +- Fix inliner for integer bitwise operators (@brandonhamilton) +- Use SSL for pursuit queries (@guido4000) + +**Bug Fixes** +- #2370, allow rows in instance contexts (@paf31) +- #2379, add error message for unknown classes (@paf31) +- Better error messages for bad indentation (@paf31) +- Fix inliner for `Data.Array.unsafeIndex` (@brandonhamilton) +- Fix issue with typed holes in inference mode (@paf31) +- Fix scope traversal for do-notation bind. (@LiamGoodacre) +- Handle `TypeLevelString` when checking orphans (@joneshf) +- Move unsafeIndex to Data.Array (@brandonhamilton) +- Pretty-print suggested types differently (@paf31) +- Traversal should pick up bindings in all value declarations. (@LiamGoodacre) +- Treat type annotations on top-level expressions as if they were type declarations (@paf31) + +**Other** +- Refactor subsumes function (@paf31) +- Refactor to use `lens` (@kRITZCREEK) +- Small cleanup to `Language.PureScript.Interactive.IO` (@phiggins) +- Speeds up parsing by reading files as `Text` (@kRITZCREEK) +- Update outdated comments about Prim types (@rightfold) + +## [v0.10.1](https://github.com/purescript/purescript/releases/tag/v0.10.1) - 2016-10-02 + +**Breaking Changes** + +The new functional dependencies feature fixes type inference in some cases involving multi-parameter type classes. However, due to a bug in the compiler, some of those expressions were previously type checking where they should not have. As a result, it is necessary to add functional dependencies to some classes in order to make previous code type-check in some cases. Known examples are: +- `MonadEff` and `MonadAff` +- `MonadState`, `MonadReader`, and the rest of the MTL-style classes in `transformers` + +**New Features** + +**`Data.Newtype` Deriving** + +(@garyb) + +It is now possible to derive the `Newtype` class for any data declaration which is a `newtype`, using the existing `deriving instance` syntax: + +``` purescript +newtype Test = Test String + +derive instance newtypeTest :: Newtype Test _ +``` + +Note that the second type argument should be specified as a wildcard, and will be inferred. + +**Added type level string functions** + +(@FrigoEU) + +The `Prim` module now defines the `TypeString` and `TypeConcat` type constructors, which can be used to build more descriptive error messages which can depend on types, using the `Fail` constraint: + +``` purescript +instance cannotShowFunctions + :: Fail ("Function type " <> TypeString (a -> b) <> " cannot be shown.") + => Show (a -> b) where + show _ = "unreachable" + +infixl 6 type TypeConcat as <> +``` + +**`--dump-corefn`** + +(@rightfold) + +The compiler now supports the `--dump-corefn` option, which causes the functional core to be dumped in `output/**/corefn.json`. This should be useful for implementing new backends which interpret the functional core. + +**Newtype Deriving** + +(@paf31) + +It is now possible to derive type class instances for `newtype`s, by reusing the instance for the underlying type: + +``` purescript +newtype X = X String + +derive newtype instance showX :: Show X +``` + +Note that it is possible to derive instances for multi-parameter type classes, but the newtype must only appear as the last type argument. + +**Allow anonymous accessor chains (`_.a.b`)** + +(@rvion) + +Anonymous record accessor syntax has been extended to work with chains of one or more accessors: + +``` purescript +getBaz = _.foo.bar.baz +``` + +**Functional Dependencies (@paf31)** + +The type class solver now supports functional dependencies. A multi-parameter type class can define dependencies between its type arguments by using the `->` operator: + +``` purescript +class Stream el s | s -> el where + cons :: el -> (Unit -> s) -> s + uncons :: s -> { head :: el, tail :: s } +``` + +Here, the `s` and `el` type arguments are related by a single functional dependency, which ensures that there is at most one instance for any given type `s`. Alternatively, the type `s` _determines_ the type `el`, i.e. there is an implicit function from types `s` to types `el`. This information can be used by the solver to infer types where it was previously not possible. + +See the following examples for more information: +- [Streams](https://github.com/purescript/purescript/blob/f5aa07606b2ed87343bb80244c5490cb157def0a/examples/passing/Stream.purs) +- [GHC-style generics](https://github.com/purescript/purescript/blob/f5aa07606b2ed87343bb80244c5490cb157def0a/examples/passing/GHCGenerics.purs) +- [Type-level arithmetic](https://github.com/purescript/purescript/blob/f5aa07606b2ed87343bb80244c5490cb157def0a/examples/passing/FunWithFunDeps.purs) +- [Heterogeneous Lists](https://gist.github.com/paf31/ded46a2fb2419f4610582a02a0690bec) + +**Enhancements** +- Return qualifier from explicit/hiding imports (@nwolverson) +- Verify entry points exist in `psc-bundle` (@kRITZCREEK) +- Improved error messages for record subsumption (@FrigoEU) + +**psc-ide** +- Resolve types/kinds for operators (@kRITZCREEK) +- Unify Completion Commands (@kRITZCREEK) +- Parse type annotations from source files (@kRITZCREEK) +- Update pursuit JSON parsing (@nwolverson) +- Remove a pursuit workaround (@kRITZCREEK) +- Add a suggestion to the `UnusedDctorImport` warning (@FrigoEU) +- Return JSON errors for cycles in module dependencies (@kRITZCREEK) + +**Bug Fixes** +- Fix usage detection for operators (@garyb) +- Fix handling of duplicate module imports in JS codegen (@garyb) +- Fix a small bug in the type pretty-printer (@paf31) +- Fix function application judgment (@paf31) +- Fix inlining for `$` and `#` operators (@garyb) +- Fix `everywhereOnTypesTopDown` (@ianbollinger) +- Fix unification of string literals (@paf31) + +**Infrastructure** +- Support `aeson-1.0` (@phadej) +- Support `http-client-0.5` (@phadej) +- Safer installation from source in INSTALL.md (@hdgarrood) + +**Implementation** +- Fix most HLint warnings (@ianbollinger) +- Fixing imports (@charleso) +- Export `desugarDecl` from `Sugar.ObjectWildcards` (@rvion) +- Remove legacy `ObjectGetter` and update doc (@rvion) + +## [v0.9.3](https://github.com/purescript/purescript/releases/tag/v0.9.3) - 2016-08-01 + +**Enhancements** +- Better context information for typed hole errors (@paf31) +- Improved error messages in the constraint solver. Type class errors now include better contextual information, including smaller source spans. (@paf31) + +**Bug Fixes** +- Decode externs with correct encoding (@natefaubion) +- Fix bad codegen for empty string fields (@LiamGoodacre, #2244) +- Instantiate types in array literals before unification (@paf31, #2252) + +**Other** +- Upgrade to protolude 0.1.6 (@ilovezfs) +- Use latest LTS (@paf31, #2241) +- Add upper bound to http-client (@paf31, #2237) +- Combine the sdist and coverage builds. Avoid .tix files during deployment. (@paf31) + +## [v0.9.2](https://github.com/purescript/purescript/releases/tag/v0.9.2) - 2016-07-11 + +**Enhancements** + +**Goto Definition** + +@kRITZCREEK has added the ability to return position information for expressions in `psc-ide`. This can be used to implement a Goto Definition feature in IDEs which use `psc-ide-server` as the backend. + +**Evaluate PSCi expressions in the browser** + +(@paf31) + +PSCi now features an alternative backend, which can run commands in the browser via a websocket. To use this mode, simply pass the `--port` option on the command line: + +``` +$ pulp psci --port 9000 +``` + +and open your web browser to `localhost` on that port. + +See https://github.com/paf31/psci-experiment for a demonstration. + +**`psc-ide` architecture changes** + +@kRITZCREEK has worked on changing the architecture of `psc-ide` generally, to load data in multiple phases and asynchronously. This enables new features like Goto Definition above. + +**Other** +- Allow `pipes` version 4.2 (@felixonmars) +- Elaborate re-exports (@garyb) + +**Bug Fixes** + +**`psc-ide`** +- Fix unicode encoding of json responses (@kRITZCREEK) +- Improved handling of reexports (@kRITZCREEK) + +**Other** +- Update Data.Function constant for prelude 1.0 (@felixSchl) +- Include position info in ScopeShadowing warning (@garyb) + +## [v0.9.1](https://github.com/purescript/purescript/releases/tag/v0.9.1) - 2016-06-01 + +PureScript 0.9.1 is a major stable release of the compiler. It removes features which were deprecated in the 0.8.x series, and contains several useful enhancements and bug fixes. + +This release will be accompanied by new releases of the core libraries and a compatible version of Pulp, which have been updated to work with this version. + +Due to the relatively large number of breaking changes, library authors are advised that they will probably need to update their libraries to maintain compatibility. Users may prefer to continue using version 0.8.5 until their dependencies have been updated. + +**Breaking Changes** + +**Name resolving** + +(@garyb) + +The way names are resolved has now been updated in a way that may result in some breakages. The short version is: now only names that have been imported into a module can be referenced, and you can only reference things exactly as you imported them. + +Some examples: + +| Import statement | Exposed members | +| --- | --- | +| `import X` | `A`, `f` | +| `import X as Y` | `Y.A` `Y.f` | +| `import X (A)` | `A` | +| `import X (A) as Y` | `Y.A` | +| `import X hiding (f)` | `A` | +| `import Y hiding (f) as Y` | `Y.A` | + +Qualified references like `Control.Monad.Eff.Console.log` will no longer resolve unless there is a corresponding `import Control.Monad.Eff.Console as Control.Monad.Eff.Console`. Importing a module unqualified does not allow you to reference it with qualification, so `import X` does not allow references to `X.A` unless there is also an `import X as X`. + +Although the new scheme is stricter it should be easier to understand exactly what the effect of any given import statement is. The old resolution rules for qualified names were obscure and unexpected results could arise when locally-qualified module names overlapped with "actual" module names. + +Module re-exports have also been tightened up as a result of these rules. Now if module `X` is only imported `as Y`, the re-export must list `module Y` also. If a module is imported without being re-qualified then the original name is used. + +**Partial Constraints** + +(@garyb, @paf31) + +The compiler will now generate an error for a missing `Partial` constraints, where it would previously have issued a warning. + +**Module Restrictions** + +(@garyb, @paf31) +- Imports must now appear before other declarations in a module. +- A source file must now contain exactly one module. + +These restrictions will allow us to improve incremental build times in future, since we will only need to parse a small prefix of each file in order to figure out what needs to be rebuilt. Right now, we need to parse every file fully. + +**Foreign Function Interface Changes** + +(@paf31) + +Foreign modules are now found by filename rather than by searching for a custom JavaScript comment. The foreign module is found by changing the extension of the corresponding PureScript module from `.purs` to `.js`. + +This change was made to be more consistent with `psc-ide`, and also to adopt a simple convention which will port well to other backends. + +**Operator Aliases** + +(@garyb) + +All operators must be defined as aliases from now on. That is, it is no longer valid to define an operator as a name in local scope (e.g. `let (#) x y = x y in ...`). This change makes it possible to generate better JavaScript code for operators, by desugaring them to the functions they alias. + +**Other** +- Deprecated class import/export syntax has been removed (@LiamGoodacre). Classes are now imported using the `class` keyword, and exported similarly: + + ``` purescript + import Prelude (class Show, show) + ``` +- Remove support for `=` in record binders (@paf31). + + Record binders such as + + ``` purescript + f { x = 0 } = true + ``` + + are no longer supported. Record binders must now use `:` instead: + + ``` purescript + f { x: 0 } = true + ``` +- `Prim.Object` has been renamed to `Prim.Record` (#1768, @paf31) + +**Enhancements** + +**Programmable Type Errors** + +(@paf31) + +Constraints can now contain type-level strings which can be used as custom error messages using the `Fail` constraint. For example, one can now document the fact that foreign types such as `JSDate` cannot be made instances of `Generic`: + +``` purescript +instance dateIsNotGeneric + :: Fail "JSDate is not Generic. Consider using Int with toEpochMilliseconds instead." + => Generic JSDate where + fromSpine = crashWith "fromSpine: unreachable" + toSpine = crashWith "toSpine: unreachable" + toSignature = crashWith "toSignature: unreachable" +``` + +Attempting to derive a `Generic` instance for a type containing `JSDate` will then result in + +``` text +A custom type error occurred while solving type class constraints: + + JSDate is not Generic. Consider using Int with toEpochMilliseconds instead. +``` + +**Typed Hole Improvements** + +(#2070, @paf31) + +Typed hole error messages now include the types of any names in scope, to assist with type-driven development: + +``` text +> :t \x -> maybe 0 ?f x +Error found: +in module $PSCI +at line 1, column 8 - line 1, column 22 + + Hole 'f' has the inferred type + + t0 -> Int + + in the following context: + + it :: Maybe t0 -> Int + x :: Maybe t0 + + +in value declaration it + +where t0 is an unknown type +``` + +**Editor Support** +- The results of the last rebuild are now cached by `psc-ide`, which improves completion support for editor plugins. (@kRITZCREEK) +- A `reset` command was added to `psc-ide` (@kRITZCREEK) +- The compiler will now suggest replacements to address `MissingTypeDeclaration` and `TypeWildCard` warnings (@nwolverson) + +**PSCi Improvements** + +(@paf31) +- The design of PSCi has been changed to improve performance. PSCi now precompiles all dependencies and uses the same incremental rebuilding approach as `psc-ide`. This means that the `:load` and `:foreign` commands have been removed, since dependencies are fixed and pre-compiled when PSCi loads. +- PSCi now supports alternative base libraries such as Neon, by depending on `purescript-psci-support` for its supporting code. + +**Colors in Error Messages** + +Types and values will now be highlighted in error messages, when the terminal supports it (MacOS and Linux for now) (@soupi). + +**Type Names** + +Prime characters are now allowed in type names. (@garyb) + +**Bug Fixes** +- Parser error messages inside type class and instance declarations were improved (#2128, @bmjames) +- Editor suggestions for imports now use `(..)` (@garyb) +- Source-spans to token end position (@nwolverson) +- Some pretty printing issues related to string literals in records were fixed (@LiamGoodacre) +- Some presentation bugs in PSCi's `:show import` were fixed (@LiamGoodacre) +- Parsec was updated to the latest version to fix an issue with literal parsing (#2115, @hdgarrood) +- Fixed a bug related to certain typed binders which would cause the compiler to crash (#2055, @paf31) +- As-patterns now bind less tightly (@paf31) +- More identifiers can now be parsed in FFI imports (@michaelficarra) +- Fixed a performance issue which manifested under certain conditions in `psc-ide` (#2064, @kika) +- Fixed a test which contained an unreliable comparison (#2093, @andyarvanitis) +- The precedence of type application was corrected (#2092, @paf31) +- An indentation bug in the parser was fixed (@DavidLindbom) +- License errors from `psc-publish` were improved (@hdgarrood) + +**Other** +- The test suite now exercises various compiler warnings (@garyb) +- The test suite performance was improved by using incremental rebuilds (@paf31) +- The test suite now tests that passing tests contain a `main` function (@hdgarrood) +- The test suite now supports tests which use multiple files (@garyb) +- Portability of the core library test suite was improved (@bmjames) +- Performance of import elaboration was improved (@garyb) +- We now use Stack for our CI builds and release builds (#1974, @hdgarrood) +- We now use `NoImplicitPrelude` and enable some global extensions (@garyb) +- Type-safety in the source-level AST was improved (@garyb) +- Use HSpec for the compiler tests (@garyb) +- New Prelude names in 0.9 (@garyb) + +## [v0.9.0](https://github.com/purescript/purescript/releases/tag/v0.9.0) - 2016-05-22 + +**This is pre-release software** + +This release is provided so that library developers can test the new compiler features. + +## [v0.8.5](https://github.com/purescript/purescript/releases/tag/v0.8.5) - 2016-04-21 + +**New Features** +- Fast recompilation for single files in `psc-ide-server` #1712 (@kRITZCREEK, @paf31) + + The [`pscid`](https://github.com/kRITZCREEK/pscid) project makes use of this to watch files as you work and raise errors and warnings when they occur with near instant feedback. +- Operator aliases can now be declared for types #416 (@garyb) + + ``` purescript + infixr 6 type Natural as ~> + ``` +- Underscore wildcards can now be used in `case` and `if` expressions #1558 (@garyb) + + ``` purescript + case _ of + Something -> ... + ``` + + ``` purescript + -- underscores can optionally be used in any part of an `if` expression + cond = if _ then _ else _ + picker = if _ then "x" else "y" + ``` +- Typed holes #1283 (@garyb) + + ``` purescript + example :: forall a. Maybe a -> Unit + example ma = ?umm + ``` + + ``` + Hole 'umm' has the inferred type + + Unit + + in value declaration example + ``` + + You can use any identifier name after the question mark and that will be used to label the hole in the raised error message. + +**Breaking changes** +- Type annotations may need parentheses in some situations that they previously did not due to the introduction of type operators. For example, `x :: a == y` will be now parsed as `x :: (a == y)` instead of `(x :: a) == y`. + +**Enhancements** +- Improved error messages for invalid FFI identifiers #2011 (@hdgarrood) +- `psc-publish` now allows publishing of packages with a valid SPDX license field in `bower.json` #1985 (@hdgarrood) +- Haddock markdown fix #2001 (@trofi) +- `psc-ide` now creates the `output` folder on startup if it is missing #2030 (@kRITZCREEK) + +**Bug Fixes** +- Fixed an issue with incorrect suggestions when re-exporting modules #1862 (@garyb) +- Fixed an issue with invalid redundant import warnings #1823 (@garyb) +- Fixed an issue where `DuplicateSelectiveImport` would not fire when it should #2004 (@garyb) +- Fixed the error that occurs when an invalid newtype is created that belongs to a data binding group #1895 (@garyb) +- Fixed a case where re-exports included unintended exports #1872 (@garyb) +- Operator aliases can now be declared for qualified data constructors #2015 (@LiamGoodacre) +- A single `hiding` import will no longer raise an "unspecified imports" error #2017 (@garyb) +- Fixed a case where cycles in modules were being detected when they do not occur #2018 (@garyb) +- Various cases where files were not being read as UTF-8 on Windows were fixed #2027, #2031 (@garyb, @kRITZCREEK) +- Fixed some issues in pretty printing of records #2043 (@LiamGoodacre) +- `psci` now shows qualified imports correctly #2040 (@LiamGoodacre) +- Parser errors are now returned as JSON during IDE rebuild #2042 (@paf31) + +## [v0.8.4](https://github.com/purescript/purescript/releases/tag/v0.8.4) - 2016-04-06 + +This is an interim bug fix release before 0.9.0. + +**Enhancements** +- Check that FFI imports match with implementations (@hdgarrood) + + This is technically a breaking change, since some existing code might fail to compile if it has missing FFI code (`purescript-dom` is an example), but these libraries should be fixed soon. +- Import helper commands in psc-ide (@kRITZCREEK) + +**Bug Fixes** +- Disallow constraint generalization for recursive functions. (#1978, @paf31) +- Fix #1991, instantiate polymorphic types before unification (@paf31) +- Use UTF8 when writing to stdout and stderr (@garyb) +- Fix for rendered constrained types needing parens. (@LiamGoodacre) +- everythingWithScope improperly traversing binary ops (@LiamGoodacre) + +**Other** +- Update to use language-javascript 0.6.x (@nwolverson) + +## [v0.8.3](https://github.com/purescript/purescript/releases/tag/v0.8.3) - 2016-03-26 + +**Breaking Changes** +- We have dropped support for GHC 7.8 and older (@hdgarrood) + +**Enhancements** +- Infer types with class constraints (@paf31) + + For example, this simple code would previously have failed with a confusing `NoInstanceFound` error: + + ``` purescript + add x y = x + y + ``` + + The compiler will now infer the most general type, namely `forall a. (Semiring a) => a -> a -> a`. + + Note that constraints can only be inferred if they only mention type variables; inference of arbitrary types in constraints is not (yet) supported. So, for example, you would still have to write a type signature for a function which had a constraint such as `(MonadEff (console :: CONSOLE | eff) m)`. +- Default require path to `../` (@nwolverson) + + The previous default behavior was no require path prefix, which was confusing for some workflows. The new default is `../`, which is the prefix used in `purs-loader`. This option will be removed completely in 0.9. +- Expose hiding import suggestion in JSON (@nwolverson) +- Error on missing `LICENSE` file or missing license field in `bower.json` (@faineance) + +**Bug Fixes** +- Fix #1916 (@bagl) +- Fix detection of single open import (@garyb) +- Fix `true` not being treated as an infallible guard (@garyb) +- Fix pretty printer spinning (@garyb) +- Fix Windows build script (@garyb) +- Fix #1889, improve performance by avoiding whitespace operations on large strings (@paf31) + +**psc-ide** +- Fix a crash related to error messages in the case splitting command (@kRITZCREEK) +- Escape regex characters when using the flex matcher (@kRITZCREEK) +- Adds `--help` commands to the `psc-ide` executables (@kRITZCREEK) +- Catches EOF exceptions thrown in `acceptCommand` (@kRITZCREEK) + +**Other** +- Switched to Trusty distribution for Travis (@garyb) +- @kRITZCREEK and @faineance worked on refactoring the compiler. +- The `optparse-applicative` dependency was updated to `>= 0.12.1` (@stevejb71) +- The `bower-json` dependency was bumped (@hdgarrood) +- Better error message for `psc-publish` tests (@kRITZCREEK) +- Use generic Literal in the AST (@garyb) + +## [v0.8.2](https://github.com/purescript/purescript/releases/tag/v0.8.2) - 2016-02-29 + +**Breaking Changes** + +_None_ + +**Enhancements** +- `psc-ide` is now distributed with the compiler! (@kRITZCREEK) + + The `psc-ide-server` and `psc-ide-client` executables are now maintained and + distributed alongside the compiler. This will ensure that the externs file + format used by `psc-ide-server` is kept in sync with changes in the compiler. +- Source maps (@nwolverson) + + Source maps can be generated using the `--source-maps` flag. See the + [example repository](https://github.com/nwolverson/purescript-sourcemap-test) for a full demonstration of source maps using Webpack. +- Operator aliases for data constructors (@garyb) + + Aliases can now be defined for data constructors. For example: + + ``` purescript + data List a = Nil | Cons a (List a) + + infixr 6 Cons as : + ``` + + Here, the `:` operator can be used as a function to replace the `Cons` constructor, + _and also in binders_. +- `Eq` and `Ord` deriving (@paf31) + + `Eq` and `Ord` instances can now be derived, using the `derive instance` syntax: + + ``` purescript + derive instance eqList :: (Eq a) => Eq (List a) + derive instance ordList :: (Ord a) => Ord (List a) + ``` +- Types are now inferred in `psc-docs` and `psc-publish` (@hdgarrood) + + If type annotations are missing in source files, they will be inferred by + `psc-docs` and `psc-publish` before documentation generation. +- Initial version of new syntax for operator sections (#1846, @paf31) + + Operator sections can now be written using underscores. For example: + + ``` purescript + decrementAll :: Array Int -> Array Int + decrementAll = map (_ - 1) + ``` + + which is equivalent to: + + ``` purescript + decrementAll :: Array Int -> Array Int + decrementAll = map (\x -> x - 1) + ``` + +**Bug Fixes** +- Allow one open import without warning (@garyb) + + Warnings for open imports were a pain point for some users after the 0.8 release. + This change allows a single open import without a warning. This is still safe + in the presence of dependency updates, and does not lead to ambiguity for editor + plugins searching for declaration sites. + +**Other** +- @phadej has updated the Stack build to use the latest LTS and nightly builds. +- @izgzhen has refactored the PSCi code to be more readable. +- @hdgarrood has refactored the test suite. + +## [v0.8.1](https://github.com/purescript/purescript/releases/tag/v0.8.1) - 2016-02-29 + +You are recommended to use v0.8.2 instead. + +## [v0.8.0](https://github.com/purescript/purescript/releases/tag/v0.8.0) - 2016-01-31 + +A massive thanks to everyone involved in this release! + +**Breaking Changes** + +_None_, but there are lots of new warnings related to upcoming breaking changes in 0.9: +- Operators as aliases will become mandatory, and regular operators (as functions) will now generate warnings. +- Non-exhaustive functions will get a `Partial` constraint in 0.9, so the exhaustivity checker will now attempt to generate warnings by looking for `Partial` constraints in scope. +- The `qualified` import syntax has been deprecated. +- Class imports will use the new `class` syntax in 0.9 and the alternative syntax is deprecated. + +**Enhancements** +- Add native `Partial` constraint (@garyb) +- Reduce backtracking in parser to hopefully improve quality of parsing error messages (@paf31) +- Drop requirement to parenthesize single constraints in instance contexts (@garyb) +- Case expressions can now match multiple values (@natefaubion) +- Add operator aliases (@garyb) +- Show identifiers correctly in ctags (@nwolverson) +- Fix #1523, add `--json-errors` flag for editor integrations (@paf31) +- Error and warning corrections are now available to editors via `--json-errors` (@nwolverson) +- Check integer values are within range in codegen (@garyb) +- Support for unicode operators (@paf31) +- The parser now supports unicode symbols for `forall` and function arrows (@DavidLindbom) +- Module Imports + - Use `class` keyword for class references in imports (@garyb) + - Type imports no longer require `()` (@garyb) + - Allow import hiding with qualified imports (@garyb) + - Naming conflicts are now resolved at the use site (@garyb) +- Error Messages + - Fix #1662, display extra type info in instance errors (@paf31) + - Add information about skolem constants to type errors (@paf31) + - Sort rows in unification errors (@paf31) +- Warnings + - Warn on unspecified imports (@garyb) + - Warn when import X hiding (..) imports nothing (@garyb) + - Warn on duplicate imports and exports (@garyb) + - Warn about unused class imports (@garyb) + +**Bug Fixes** +- Renamer updates, fixes naming bug in some unlikely situations (@garyb) +- Fix #1645, implement new indentation rules for types to avoid very wide errors (@paf31) +- Fix "resource exhausted" issue on MacOS (@mgmeier) +- Fix #1664, check kind before expanding wildcards. (@paf31) +- Fix up shadowed module names in JS codegen (@garyb) +- Fix #1185, fix #1369, add everythingWithScope traversal to correct some scoping issues. (@paf31) +- Fix two cases where errors were missing context (@garyb) +- Fix #1636, instantiate polytypes fully, even under constraints. (@paf31) +- Fix missing data constructors in re-exports (@garyb) +- Fix codegen error with instance for re-exported class (@garyb) +- Fix #1479, encode .js files as UTF8. (@paf31) +- Fix a bug related to redundancy checking in cases (#1853, @nicodelpiano) +- Fix a TCO/composition inlining bug (@garyb, @hdgarrood) +- Fix renaming for nested constructor binders (#1839, @sharkdp) +- Fix generic deriving bug with >1 type argument (@hdgarrood) +- Fix generate fresh binder names unless all names in case are equal (#1825, @paf31) +- Fix external require expressions when minifying (#1794, @paf31) +- Rename `foreign` argument to fix compiling issue (@anttih) +- Allow use of bottom integer (@garyb) + +**Other** +- Fix #1700, remove warnings for syntactic features removed in 0.7.0 (@paf31) +- Fix psc-publish test (@passy) +- Relax rules for docs comments (#1820, @hdgarrood) +- Qualified name lookup is now supported in PSCi (#974, @soupi) +- https://github.com and git@github.com URLs are now allowed by psc-publish (@passy, @codedmart) +- Docs are now generated for module re-exports (@hdgarrood) +- Use friendly module name in psc-docs error (@nwolverson) +- Distinguish between the different ProperNames (@garyb) +- Warn about unspecified constructors in type imports (@garyb) +- Fix warning about values missing from virtual modules (@garyb) + +## [v0.7.6.1](https://github.com/purescript/purescript/releases/tag/v0.7.6.1) - 2015-11-18 + +Fixes a bug in generic deriving. + +See the [release notes for 0.7.6](https://github.com/purescript/purescript/releases/tag/v0.7.6). + +## [v0.7.6](https://github.com/purescript/purescript/releases/tag/v0.7.6) - 2015-11-18 + +Thanks once again to everyone involved in this release! + +This release includes some updates to generic deriving which require updating to the latest version of `purescript-generics`. + +**Features** +- Field puns, fix #921 (@balajirrao) + + It is now possble to construct objects by using values in scope with the same name as the field labels. For example, the expression `{ foo, bar }` is equivalent to `{ foo: foo, bar: bar }`. Patterns desugar in the same way. + +**Enhancements** +- Modules are now parsed in parallel (@paf31) +- Use `Types.Proxy.Proxy` instead of `Data.Generic.Proxy`. This fixes #1573 (@tfausak) +- Update generic deriving for latest `purescript-generics` changes (@paf31) +- New import warnings - unused data constructors, unused imports (@nwolverson) +- `psc-publish`: only warn on dirty working tree on dry runs (@hdgarrood) +- Add more information to psci :browse command (@soupi) +- Add support for --require-path option to psc-bundle (@natefaubion) +- Improved error reporting in psc-publish (@hdgarrood) +- Reduce noise in instance declarations in documentation (@hdgarrood) + +**Bug Fixes** +- New approach to unification, fixing some loops in the type checker (@paf31) +- Fix #1632, instantiate type variables in anyProxy calls in generic instances (@paf31) +- Fix warnings for unqualified implicit imports (@nwolverson) +- Fix #1596, don't show type checker warnings in the event of an error (@paf31) +- Fix #1602, improvements around code generation of string literals (@michaelficarra) +- Fix #1090, allow accessors in operator sections (@paf31) +- Fix #1590, limit depth of pretty-printed expressions (@paf31) +- Fix #1591, use the 'negate' in scope (@paf31) +- Fix #1335, track scoped type variables when skolemizing (@paf31) +- Fix #1175, check types inside where clauses inside instances (@paf31) +- Some refactoring (@phadej) +- Fixed some error messages (@zudov) + +**Deployment** +- Use `base-compat` to reduce the need for `CPP` (@phadej) +- Write license-generator in Haskell (@phadej) +- Add GHC 7.10.3 to CI build matrix (@phadej) + +## [v0.7.5.3](https://github.com/purescript/purescript/releases/tag/v0.7.5.3) - 2015-10-29 + +**Bug Fixes** +- #1072, #1130, #1578, #1577, #1582 + +## [v0.7.5.2](https://github.com/purescript/purescript/releases/tag/v0.7.5.2) - 2015-10-27 + +Fixes a build issue with GHC versions < 7.10. Functionally equivalent to v0.7.5.1. + +## [v0.7.5.1](https://github.com/purescript/purescript/releases/tag/v0.7.5.1) - 2015-10-27 + +**Bug Fixes** +- Fix #1169, #1315, #1534, #1543, #1548, #1551, #1557, #1570 +- Fix memory leak caused by WriterT (#1297) by @paf31 +- Display hints after main error (#1563) by @paf31 +- Friendlier errors by @paf31 +- Documentation fixes by @nwolverson +- Haddock fixes by @trofi + +## [v0.7.5](https://github.com/purescript/purescript/releases/tag/v0.7.5) - 2015-10-20 + +A big thank you to everyone who was involved in this release, from filing issues, through fixing bugs to testing patches. + +The main focus areas for this release, as part of the 0.8 milestone, were error messages and performance. + +**Breaking Changes** + +_None!_ + +**Enhancements** +- Pretty printing of types and expressions in errors was improved (@paf31) +- Externs files are now saved as JSON (@paf31) +- Support for parallel builds has been added (@paf31) + Builds will now use multiple cores by default, but the number of capabilities can be modified by passing the `-N` option to the GHC runtime: + + ``` text + psc +RTS -N8 + ``` +- Binders can now be given type annotations (@5outh) + + For example: + + ``` purescript + example = do + n :: Int <- get + put (n + 1) + ``` + + This can be useful when disambiguating types. +- There is a new warning for missing type signatures on top-level declarations (@paf31) +- There are new warnings for shadowed and unused type variables (@garyb) +- Contextual information in warnings was improved (@garyb) +- The `qualified` keyword is now optional when importing modules qualified (@michaelficarra) +- @zudov changed the behavior of PSCi on CTRL+C/D to match GHCi and other REPLs. +- A bug in row unification was fixed (#1310, @paf31) +- Constrained types can now be defined without a `forall` keyword. This is useful in some nullary type class and rank-N scenarios. (@paf31) + +**Bug Fixes** +- @garyb added some additional checks for transitive module exports. +- Type synonyms are now expanded more eagerly to avoid some error cases in the type checker (@paf31) +- Better support for multi-byte UTF-8 characters (@senju) +- A check has been added to the exhaustivity checker to avoid exponential blowup (@paf31) +- Empty case statements are no longer syntactically valid (@zudov) + +**Other** +- @aspidites fixed all compiler warnings in the core libraries. +- @zudov and @phadej have made improvements to the Stack distribution of the compiler, and the Stackage builds. +- @garyb has added a warning for operators in type classes, since they will be disallowed before 0.8. + +## [v0.7.4.1](https://github.com/purescript/purescript/releases/tag/v0.7.4.1) - 2015-08-26 + +This patch release fixes two bugs related to the new instance resolution algorithm and overlapping instances: +- `psci` would not work due to overlaps in the `PSCI.Support` module +- `free` would not build due to its dependency on `inject` + +The solution for now is to make overlapping instances into a _warning_ (instead of an error) at the site of their use. + +Later we might revisit this decision and allow the user to express classes like `Inject` which are necessarily overlapping. + +## [v0.7.4.0](https://github.com/purescript/purescript/releases/tag/v0.7.4.0) - 2015-08-25 + +**Breaking Changes** +- The type class instance search algorithm has changed. The search will now eagerly match an instance for each subgoal based on the instance head, or fail. This makes certain instances in previous versions of `purescript-transformers` invalid, so users of this release should upgrade to the latest `transformers`. +- A module must be imported to be re-exported. + +**Enhancements** +- `RedefinedModule` errors now include position info #1024 (@garyb) +- Multiple imports of the same module are now resolved correctly, allowing for combinations of qualified and unqualified importing #817 #1112 (@garyb) +- Errors for unresolvable imports and exports have been clarified #1232 (@garyb) +- A warning is emitted when importing `Type(..)` when `Type` is a synonym or has no constructors. #1391 (@garyb) +- Superclass constraints can now be relied upon when resolving instances #421 (@paf31) +- A serious performance regression was partially addressed, memory usage should now be drastically reduced #1297 (@garyb) +- Module re-export handling has been much improved. If a module is partially imported, only the specifically imported members are re-exported. Qualified modules can also be re-exported. #291 #1244 (@garyb) +- Parser error messages are now formatted in a manner more consistent with other errors #1098 (@epost) +- Using `-ffi` to specify JavaScript FFI files is now optional, files with a `.js` extension will be detected as FFI files automatically when encountered. #1268 (@mjgpy3) + +**Bug fixes** +- Fixed an error when attempting to derive for `Void` #1380 (@nicodelpiano) +- `"The impossible happened in desugarDo"` should no longer occur #386 (@paf31) + +**Other** + +@zudov, @phadej and @erdeszt made more updates and improvements to the CI build. + +## [v0.7.3](https://github.com/purescript/purescript/releases/tag/v0.7.3) - 2015-08-13 + +**Major Features** +- @gbaz has implemented **generic deriving**. This allows instances for the `Generic` class in the `purescript-generics` package to be derived by the compiler. + + A `Generic` instance can be derived as follows: + + ``` purescript + data Example = Foo String | Bar Int | Baz Boolean + + derive instance genericExample :: Generic Example + ``` + + `purescript-generics` provides examples of usage, such as `gShow`, `gEq` and `gCompare`, for printing, equality tests and comparison respectively. + + See #1138. +- @garyb has implemented a test for **orphan instances** which will now cause the build to fail with an error. See #1247 + +**Enhancements** +- @mjgpy3 has added a warning when an input glob does not match any files. + +**Bug Fixes** +- The `psc: <>` has been fixed. This was due to a bug in the error pretty printer. (@paf31) +- An issue with unicode characters in string literals was fixed by @michaelficarra. +- Compiler errors are now pretty printed in `psc-publish` (@paf31) +- Modules are no longer linted if they are not being rebuilt (@paf31) +- FFI bindings are now reloaded when changed, in PSCi (@paf31) + +**Other** +- @phadej and @zudov have improved our CI process, so that PureScript now compiles against three versions of GHC and two LTS Stackage releases, as well as the nightly stackage releases. +- @phadej and @lukerandall have worked on supporting PureScript in Stackage. + +## [v0.7.2.1](https://github.com/purescript/purescript/releases/tag/v0.7.2.1) - 2015-08-12 + +Functionally equivalent to v0.7.2. This release fixes a version incompatibility with Stackage. + +## [v0.7.2](https://github.com/purescript/purescript/releases/tag/v0.7.2) - 2015-08-03 + +**Bug fixes** +- Fixed haddock for the Language.PureScript.Bundle module #1262 (@wuzzeb) +- Some erroneous error positions were fixed for kind and missing instance errors #1086 (@garyb) +- The number of warnings printed for exhaustivity checks was limited to 5 #1281 (@nicodelpiano) +- Home directory is checked for `.psci` file _after_ the current working directory #883 (@mjgpy3) +- Line numbers now show for shadowed name warnings #1165 (@nicodelpiano) +- Cabal file was fixed for Nix packaging #1302 (@MasseGuillaume) +- Kind query for types defined in psci now works #1235 (@mjgpy3) +- Boolean operations are now being inlined again #1312 (@garyb) +- Int operations are now being inlined again #1330 (@garyb) +- "Writing..." and "Compiling..." messages are no-longer printed in `psci` #1276 (@paf31) + +**Enhancements** +- Exhaustivity checker was extended to report errors about redundant cases #1289 (@nicodelpiano) +- Improved triggering of suggestion for errors about using `(<<<)` instead of `(.)` #1284 (@mjgpy3) +- Only show the module name rather than the filename for pattern errors #1296 (@nicodelpiano) +- Error reporting in `psc-bundle` was improved #1307 (@hdgarrood) +- `psc-publish` code is now part of the library module #1304 (@hdgarrood) +- `psc-publish` now has `--version` and `--help` options #1300 (@garyb) +- `psc-publish` now has a `--dry-run` option for checking whether the module can be published #1308 (@hdgarrood) +- `psc-publish` now requires a clean working tree #1306 (@hdgarrood) +- `psc-publish` can now find `bower` on Windows machines #1317 (@hdgarrood) +- `psc-publish` now uses OS-specific path delimiters to fix another bug on Windows #1326 (@hdgarrood) +- Error list heading was made emacs-friendly #1327 (@epost) + +## [v0.7.1](https://github.com/purescript/purescript/releases/tag/v0.7.1) - 2015-07-13 + +Minor fixes after 0.7.0: +- @hdgarrood has worked on improvements to `psc-publish` to support the new Pursuit website. +- @mjgpy3 has improved warning messages +- @wuzzeb has improved the pretty printers +- @hdgarrood has added CI builds for GHC 7.10 and 7.6 + +Enhancements +- @nicodelpiano has added exhaustivity checking as a new warning type. Incomplete pattern matches will now generate warnings like this: + + ``` text + Warning in module Data.Either.Unsafe: + Warning in value declaration fromRight: + Warning at src/Data/Either/Unsafe.purs line 14, column 1 - line 15, column 1: + Pattern could not be determined to cover all cases. + The definition has the following uncovered cases: + (Data.Either.Left _) + See https://github.com/purescript/purescript/wiki/Error-Code-NotExhaustivePattern for more information, or to contribute content related to this error. + ``` + +## [v0.7.0](https://github.com/purescript/purescript/releases/tag/v0.7.0) - 2015-06-30 + +**Introduction** + +This release ("MELTDOWN") aims to handle as many planned breaking changes as possible, to ease the upgrade path before 1.0. It is necessary to upgrade almost all PureScript code to compile with this release. + +The latest versions of the core libraries have all been updated to compile with this release. Older versions of the core libraries will not work with this release, and the latest versions of libraries will not build with older compiler releases. + +Detailed instructions for those who need to migrate their code can be found [on the wiki](https://github.com/purescript/purescript/wiki/0.7-Migration-Guide). + +As usual, many thanks go to all of the contributors who helped with this release! + +**Breaking changes** +- The `psc` executable has been replaced with `psc-make`, which has been renamed to `psc` (in an effort to standardize on CommonJS module output). Features which were previously only available in old `psc` (dead code elimination, bundling code for the browser) are now handled by the new executable `psc-bundle`, which works with the output of the new `psc` (for faster, incremental builds). +- There are now `Int` and `Number` literals. To disambiguate the two, integer `Number` values must now be written with a decimal place (`3.0` rather than `3`). +- The `Prelude` module is no longer imported automatically, and must be imported the same way as any other module. +- No modules are included with the compiler now, they have been broken out into their own libraries: + - [purescript-prelude](https://github.com/purescript/purescript-prelude) + - [purescript-eff](https://github.com/purescript/purescript-eff) + - [purescript-st](https://github.com/purescript/purescript-st) + - [purescript-console](https://github.com/purescript/purescript-console) + - [purescript-functions](https://github.com/purescript/purescript-functions) +- `Debug.Trace` has been renamed to `Control.Monad.Eff.Console`, and `trace` has been renamed to `log`. +- `[]` syntax for array types has been removed. It is still possible to use `[]` array literals however. + - `[]` should now be written as `Array`, and `[a]` as `Array a`. +- Cons patterns for arrays have been removed. +- Declaring operators in classes will now produce a warning. Changes will be coming to operators in PureScript 0.8, and moving to named members in classes with operators as aliases (e.g. `(<$>) = map`) should make the transition easier in the future. +- JavaScript for the FFI can no longer be provided inline. + - Values must instead be provided in a separate `.js` file, and passed to the compiler with the `-ffi` flag. + - Values should be provided in the form `exports.foo = ...`, similar to a CommonJS module + - The file should have a comment `// module X.Y.Z` where `X.Y.Z` is the name of the module the JS values are for. + - [See here for an example](https://github.com/purescript/purescript-eff/blob/v0.1.0-rc.1/src/Control/Monad/Eff.js) + +**Enhancements** +- Module exports (@andyarvanitis). Currently, only full module exports are supported, but imported modules can be re-exported using the following syntax: + `purescript + module M1 (module M2) where + import M2 + ` +- Documentation improvements (@hdgarrood): + - `psc-docs` can now generate multiple output files, allowing documentation to be collected into functional groups. + - A new tool `psc-publish` has been added, which generates module documentation in a JSON format required by Pursuit 2 (coming soon) +- @hdgarrood has worked on improving the quality of code completion inside `psci`, and generally tidying up and refactoring that code. +- @puffnfresh has worked on dramatically increasing the performance of incremental builds, with improvements up to 10x compared to the previous release. +- The new `--require-path` option allows the syntax of module imports in generated CommonJS modules to be customized (@garyb). +- @etrepum has added support for building with Stack. +- PSCi now supports computations in the `Eff` monad. (@paf31) +- The compiler now emits warnings in the following cases: + - Operator name used in type class definition (@garyb) + - Type wildcard used (@nicodelpiano) + - Shadowed variable name (@paf31) +- @balajirrao has improved the appearance of unknown and rigid types appearing in error messages. +- @puffnfresh has added position information to pattern match errors. +- @puffnfresh has added some new optimizations (inlining `<<<` and `$`) + +**Bug Fixes** +- `psc`, `psc-docs` and `psc-bundle` now support file globs as command-line arguments, fixing a bug related to the command length on Windows machines (@paf31) +- @wuzzeb has fixed some issues in the pretty printer. +- @mjgpy3 has improved error messages related to incorrect pattern matches on data constructors. + +**Tools** +- Pulp has been updated: + - The new `psc` and `psc-bundle` binaries are supported + - FFI modules are now identified and compiled based on a convention + - `pulp docs` now generates individual Markdown files for each source module +- `gulp-purescript` has been updated: + - The new `psc` and `psc-bundle` binaries are supported + - FFI modules are now supported + +**Libraries** +- The following libraries have been moved into the core library set: + - `purescript-lists` - Strict and lazy linked list data structures + - `purescript-assert` - Low level assertion library for tests + - `purescript-parallel` - An applicative functor for parallel composition of asynchronous computations. + - `purescript-arrows` - Arrow type classes and standard instances. + - `purescript-tailrec` - A type class for stack-safe monadic tail recursion. +- The requirements for libraries in the `purescript-contrib` organization [have been tightened](https://github.com/purescript/purescript/wiki/Contrib-Guidelines), to try to ensure that libraries stay maintained. + +## [v0.7.0-rc.1](https://github.com/purescript/purescript/releases/tag/v0.7.0-rc.1) - 2015-06-07 + +**Important note** + +This release should be used with the latest versions of the core libraries, which are also tagged as `-rc.1`. + +**Breaking changes** +- There are now `Int` and `Number` literals. To disambiguate the two, integer `Number` values must now be written with a decimal place (`3.0` rather than `3`). +- The `Prelude` module is no longer imported automatically, and must be imported the same way as any other module. +- No modules are included with the compiler now, they have been broken out into their own libraries: + - [purescript-prelude](https://github.com/purescript/purescript-prelude) + - [purescript-eff](https://github.com/purescript/purescript-eff) + - [purescript-st](https://github.com/purescript/purescript-st) + - [purescript-console](https://github.com/purescript/purescript-console) + - [purescript-functions](https://github.com/purescript/purescript-functions) +- `[]` syntax for array types has been removed. It is still possible to use `[]` array literals however. + - `[]` should now be written as `Array`, and `[a]` as `Array a`. +- Cons patterns for arrays have been removed. +- Declaring operators in classes will now produce a warning. Changes will be coming to operators in PureScript 0.8, and moving to named members in classes with operators as aliases (e.g. `(<$>) = map`) should make the transition easier in the future. +- JavaScript for the FFI can no longer be provided inline. + - Values must instead be provided in a separate `.js` file, and passed to the compiler with the `-ffi` flag. + - Values should be provided in the form `exports.foo = ...`, similar to a CommonJS module + - The file should have a coment `// module X.Y.Z` where `X.Y.Z` is the name of the module the JS values are for. + - [See here for an example](https://github.com/purescript/purescript-eff/blob/v0.1.0-rc.1/src/Control/Monad/Eff.js) + +_Full release notes coming soon_ + +## [v0.6.9.5](https://github.com/purescript/purescript/releases/tag/v0.6.9.5) - 2015-04-25 + +This release contains two patches: +- Case statements were generating incorrect function name arguments #1008 (@paf31) +- Comments and verbose error flags were mixed up #991 (@garyb) + +## [v0.6.9.3](https://github.com/purescript/purescript/releases/tag/v0.6.9.3) - 2015-03-18 + +**Breaking Changes** +- `refEq` and `refIneq` are no longer exported from the `Prelude`. + +**Bug Fixes** +- Instances can now be defined before the corresponding class declaration (@paf31) +- A bug related to imports in `psci` was fixed. (@paf31) +- A typechecker bug related to type class dictionaries was fixed. (@garyb) +- A bug related to operator precedence in codegen was fixed. (@garyb) + +**Enhancements** +- `psci` now supports long-form directives (@mrhania) +- Syntax for imports and other declaration types in `psci` was improved. (@hdgarrood) +- Markdown comments can now be included at the module level (@joneshf) +- Error messages are now represented internally as an algebraic data type, and pretty printing has been improved by using the `boxes` library. Errors now link to the wiki. (@paf31) +- `psc-docs` can now generate tags files for Vim and Emacs (@jacereda) +- `psci` now supports a `--node-opts` flag for passing options to the Node executable. (@MichaelXavier) +- Code gen now preserves names of more function arguments in case statements (@andyarvanitis) +- There is now a `Semigroup` instance for `Ordering` (@pseudonom) + +**Documentation** +- The Prelude now has Markdown documentation (various contributors - thank you!) +- The [Pursuit](http://pursuit.purescript.org) website has been updated with new versions of libraries, including Markdown documentation (@hdgarrood) + +**Libraries** +- The following libraries are now core libraries: + - `purescript-tailrec` - A type class for monadic tail recursion + - `purescript-monad-eff` - A type class for monads supporting native effects + - `purescript-integers` - Integer numeric type + - `purescript-invariant` - Invariant functors + - `purescript-parallel` - An applicative functor for parallel composition of asynchronous computations + +**Other** +- There is an experimental C++11 backend for PureScript called [pure11](https://github.com/andyarvanitis/pure11). + +## [v0.6.8](https://github.com/purescript/purescript/releases/tag/v0.6.8) - 2015-02-21 + +**Breaking Changes** +- The `Num` type class has been refined to allow more interesting instances. The `Semiring`, `ModuloSemiring`, `Ring` and `DivisionRing` classes have been introduced. Most code should continue to compile, since `Number` was one of only a handful of instances, but library developers will need to break up their `Num` instances. + +**Enhancements** +- @garyb has improved the readability of `psc-docs` output. + +**Notes** +- All uses of the deprecated `ErrorT` have been replaced with `ExceptT` and the `transformers` and `mtl` dependencies bumped accordingly. + +## [v0.6.7.1](https://github.com/purescript/purescript/releases/tag/v0.6.7.1) - 2015-02-14 + +**Bug Fixes** +- A fix for a bug in the type class instance resolution code (#870, @paf31) + +## [v0.6.7](https://github.com/purescript/purescript/releases/tag/v0.6.7) - 2015-02-12 + +**Enhancements** + +**Scoped Type Variables** + +(#347, @paf31) + +This feature allows type variables which are bound by a `forall` keyword to be used inside type annotations in the body of the function. For example, suppose we want to define a `map` function on a `List` type: + +``` purescript +data List a = Nil | Cons a (List a) + +map :: forall a b. (a -> b) -> List a -> List b +map f = go + where + go Nil = Nil + go (Cons x xs) = Cons (f x) (map f xs) +``` + +To give a type to `go`, we could previously use type wildcards: + +``` purescript +go :: List _ -> List _ +``` + +Now, we can refer to the types `a` and `b` inside the type of `go`, giving a more precise type: + +``` purescript +go :: List a -> List b +``` + +**Rows In Instance Contexts** + +(@paf31, @apsk) + +This feature allows rows to appear on the left of a `=>` in a type signature. For example, given a `MonadEff` class: + +``` purescript +class MonadEff eff m where + liftEff :: forall a. Eff eff a -> m a +``` + +we can now write the following function which works in any `Monad` supporting `Trace` actions: + +``` purescript +logging :: forall m a eff. (Monad m, MonadEff (trace :: Trace | eff) m) => String -> m a -> m a +logging s action = do + liftEff $ trace $ "Starting: " <> s + a <- action + liftEff $ trace $ "Done: " <> s + return a +``` + +**Improved `let` bindings in `psci`** + +(#782, @paf31) + +Any declaration can now be used inside a `let` binding in `psci`. For example, we can define data types or foreign imports: + +``` text +> let data Foo = Foo | Bar | Baz + +> let foreign import foo :: Foo -> String +``` + +The general form of a `let` statement in `psci` now contains one or more declarations of any type, and these declarations simply get added to the current module. + +As a bonus, polymorphic functions bound using `let` now work at multiple type instantiations in `psci`: + +``` text +> let f x = x + +> if f true then f "true" else f "False" +"true" +``` + +**Markdown Support in `psc-docs`** + +(#802, @paf31) + +Markdown can now be used for documentation purposes by using pipe characters to align content. For example: + +``` purescript +-- | Create a copy of the array without its first element. +-- | +-- | Running time: `O(n)`, where `n` is the length of the array. +-- | +-- | This function is partial. Specifically, `tail []` is undefined. +tail :: forall a. [a] -> [a] +``` + +`psc-docs` will insert this markdown content verbatim into your generated documentation. + +**Bug Fixes** +- Modules are rebuilt before a command is executed in `psci`, to avoid situations where compiled code becomes out-of-date (@paf31) +- `@` is a valid operator name again (#815, @paf31) +- Reserved module names are now properly escaped (@garyb) + +## [v0.6.6](https://github.com/purescript/purescript/releases/tag/v0.6.6) - 2015-02-09 + +**Breaking Changes** +- The syntax of record getters was changed to `_.prop` (@garyb) + +**Enhancements** +- The record part of a record updater can now be made into a wildcard, e.g. `_ { foo = 1 }` (@garyb) +- Extended infix expressions are now supported, (@paf31) e.g. + + ``` + [1, 2, 3] `zipWith (+)` [4, 5, 6] + ``` + +**Bug Fixes** +- Newline issues were fixed in executables (@michaelficarra) + +## [v0.6.5](https://github.com/purescript/purescript/releases/tag/v0.6.5) - 2015-02-08 + +**Enhancements** +- Lightweight record constructors are now supported (@garyb): + + ``` purescript + person :: Maybe String -> Maybe Number -> Maybe Address -> Maybe Person + person = { name: _, age: _, location: _ } <$> name <*> age <*> location + ``` +- Field accessor sections are now supported (@garyb): + + ``` purescript + getPersonName :: Maybe String + getPersonName = (.name) <$> getPersonInfo + ``` +- Syntactic sugar has been introduced for object update functions: + + ``` purescript + updateName :: Person -> String -> Person + updateName person = person { name = _ } + ``` +- Operator sections are now supported (@garyb) + +**Bug Fixes** +- Some command line options were fixed in `psc-make` (@paulyoung) +- Some module import errors were fixed (@garyb) +- A typechecker bug related to row synonyms was fixed (#795, @paf31) + +## [v0.6.4.1](https://github.com/purescript/purescript/releases/tag/v0.6.4.1) - 2015-02-03 + +Various small bug fixes. + +## [v0.6.4](https://github.com/purescript/purescript/releases/tag/v0.6.4) - 2015-01-23 + +- Fix some precedence issues in the code generator. +- Tighten the bounds on `utf8-string`. +- Fixed a bug in the typechecker. + +## [v0.6.3](https://github.com/purescript/purescript/releases/tag/v0.6.3) - 2015-01-08 + +**Breaking Changes** + +**Bug Fixes** +- Case statement at end of `Eff` block not being executed. (#759, @paf31) +- A bug related to dead code elimination was fixed. (@garyb) +- Wildcards can now appear in row endings. (@RossMeikleham) + +**Enhancements** +- There is a new "core functional representation", which will enable certain optimizations, and new features such as rewrite rules. (#710, @garyb) +- Record pattern matches now allow field names to be separated from binders using `:` instead of `=`, to match record construction (#760, @leighman) +- Some improvements needed for the Pursuit tool (@hdgarrood) +- The lexer was separated from the parser, and now supports explicit comments in the AST. Documentation generated by `psc-docs` now contains any inline comments which precede the corresponding declaration, and generated code preserves the same comments. (@paf31) +- PureScript now builds on GHC 7.6.\* again. (@dylex) +- Proper names can now contain underscores. (@dylex) +- Several auto-completion improvements and fixes in PSCI. (@vkorablin) + +**Libraries** +- The Prelude now contains a `pureST` function to run `ST` computations in a pure context. (@KMahoney) + +**Tools** +- The Pursuit tool now runs on the community server, and integrates with Bower. Libraries can be added by submitting a pull request. (@hdgarrood) + +## [v0.6.2](https://github.com/purescript/purescript/releases/tag/v0.6.2) - 2014-11-28 + +**Breaking Changes** +- Command line options with multiplicity 1 now require an equals symbol, e.g. + + ``` + psc --main=Main --browser-namespace=PS + ``` + + The Grunt and Gulp plugins already support this format. + +**Enhancements** +- Use `optparse-applicative` instead of `cmdtheline` (@anthoq88) + +**Libraries** +- Move `STArray` out of Prelude. (@paf31) + +## [v0.6.1.2](https://github.com/purescript/purescript/releases/tag/v0.6.1.2) - 2014-11-24 + + + +## [v0.6.1.1](https://github.com/purescript/purescript/releases/tag/v0.6.1.1) - 2014-11-19 + +**Breaking Changes** +- The pipe symbol is now a reserved operator. +- The operators in the `Bits` type class have been renamed. + +**Enhancements** +- Fix build on GHC 7.6.\* (@dylex) +- Relax indentation requirements (@paf31) + +## [v0.6.1](https://github.com/purescript/purescript/releases/tag/v0.6.1) - 2014-11-18 + +**Breaking Changes** +- The body of a guarded expression must now be indented _past the guard_. For example, this is valid: + +``` haskell +positive n | n > 0 = true +positive _ = false +``` + +but this is not: + +``` haskell +positive n | n > 0 + = true +positive _ = false +``` + +**New Features** +- Type wildcards are now supported (#287, @paf31) + +**Enhancements** +- Allow unquoted keywords as key names in record literals (#606, @michaelficarra) +- Import instances when referencing qualified values (#667, @garyb) +- Multiple guard clauses are now supported (#294, @paf31) +- Type check let declarations immediately in `psci` (#615, @garyb) + +## [v0.6.0.2](https://github.com/purescript/purescript/releases/tag/v0.6.0.2) - 2014-11-09 + +- Prevent `psci` and `psc-make` from rebuilding everything on every build #692 + +## [v0.6.0](https://github.com/purescript/purescript/releases/tag/v0.6.0) - 2014-11-06 + +For more information on PureScript, see the [purescript.org website](http://purescript.org). + +**Breaking Changes** +- The `Alternative` type class hierarchy was refactored. See [here](https://github.com/purescript/purescript-control/issues/6). +- `--runtime-type-checks` has been removed. The recommended approach is to use `purescript-foreign`. (@garyb) +- The `Unit` type is now used in the Prelude and core libraries to represent values containing no data. (@garyb) +- The Prelude is no longer distributed as a separate file, but is embedded in the compiler executables. (@paf31) +- `docgen` is now called `psc-docs`. + +**New Features** +- Newtypes are now supported using the `newtype` keyword. The runtime representation of a newtype is identical to that of the contained type. (@garyb) +- Multiline string literals are now supported via triple-quote syntax, making FFI declarations much neater. (@phadej) +- Kind signatures on types and type constructor arguments are now supported. (@paf31) + +**Enhancements** +- The `runFnN` and `mkFnN` families of functions are now inlined by the optimizer, making interop with JavaScript functions of multiple arguments much simpler. (@paf31) +- Tail call optimization has been improved for functions using case expressions. (@paf31) +- Saturated calls to data constructors are now optimized. (@garyb) +- A new `Renamer` module now renames identifiers which shadow other names in scope, which greatly simplies code generation. (@garyb) +- `psci` now provides the following new options: + - `:b` to browse a module (@ardumont) + - `:s` to show current imports or modules (@ardumont) + - `:k` to find the kind of a type constructor (@5outh) +- The approach to checking whether a name is initialized in the generated JavaScript was simplified (@paf31) +- The dependency on the `PureScript_paths` module has been removed, which makes distribution via binaries simpler. (@paf31) +- Nested `if` blocks now get optimized. (@garyb) +- Generated code for type class dictionaries was simplified. (@garyb, @dylex) +- The code generator now inserts the version of `psc` into the file as a comment. (@co-dh) +- `()` is now valid syntax, referring to the empty row. (@paf31) +- The type checker will now display multiple errors for type errors in the same binding group. (@paf31) +- Imports can now specify hidden names using `import ... hiding ( ... )` (@andreypopp) + +**Bug Fixes** +- Binding group errors in type class members are now caught at compile time. (@dylex) +- Some errors related to type checking rows with duplicate labels were fixed. (@paf31) +- Some issues with the calculation of binding groups were fixed. (@paf31) +- Error messages for invalid case declarations are now generated. (@natefaubion) +- Some issues related to module exports were fixed. (@garyb) +- `psci` now checks imports for validity. (@Bogdanp) + +**Libraries** +- The `Alternative` type class hierarchy was refactored (@joneshf, @garyb) +- The `exceptions` library no longer supports throwing exceptions of any type. +- The following libraries have been moved to the core PureScript organisation: (@garyb) + - `purescript-transformers` + - `purescript-free` + - `purescript-const` + - `purescript-identity` + - `purescript-lazy` + - `purescript-distributive` + - `purescript-bifunctors` + - `purescript-contravariant` + - `purescript-profunctors` + - `purescript-maps` + +**Documentation** +- The [PureScript book](https://leanpub.com/purescript/read) is now available. +- The [PureScript wiki](https://github.com/purescript/purescript/wiki) is now the main resource for compiler and library documentation. + +## [v0.5.7.1](https://github.com/purescript/purescript/releases/tag/v0.5.7.1) - 2014-10-30 + + + +## [v0.5.7](https://github.com/purescript/purescript/releases/tag/v0.5.7) - 2014-10-29 + + + +## [0.5.6.1](https://github.com/purescript/purescript/releases/tag/0.5.6.1) - 2014-10-06 + + + +## [0.5.6](https://github.com/purescript/purescript/releases/tag/0.5.6) - 2014-10-06 + + + +## [v0.5.6.3](https://github.com/purescript/purescript/releases/tag/v0.5.6.3) - 2014-10-06 + + + +## [0.5.6.2](https://github.com/purescript/purescript/releases/tag/0.5.6.2) - 2014-09-22 + + + +## [v0.5.5](https://github.com/purescript/purescript/releases/tag/v0.5.5) - 2014-09-02 + + + +## [v0.5.4](https://github.com/purescript/purescript/releases/tag/v0.5.4) - 2014-08-04 + +This incremental release is provided to provide bug fixes and features required to compile the latest core libraries. + +## [v0.5.0](https://github.com/purescript/purescript/releases/tag/v0.5.0) - 2014-04-27 + +**Breaking Changes** +- Support for blocks has been removed. (paf31) +- Type class instances must now be named (paf31) + + ``` + instance showNumber :: Show Number where + ... + ``` +- Prelude modules now follow a naming scheme similar to haskell (e.g. `Data.Maybe`, `Control.Monad`) (garyb) +- Many modules that were previously part of the Prelude have been split into individual libraries, [now distributed via Bower](http://bower.io/search/?q=purescript) (garyb) +- Multiple modules with the same name are now disallowed rather than merged (garyb) +- The `Prelude` module is now imported automatically. Conflicts can be avoided by using qualified imports or an explicit import list. (garyb, paf31) +- Overlapping instances are no longer allowed. The `Prelude` and core libraries have been updated accordingly. (paf31) +- `Functor`, `Applicative`, `Monad` are now part of a class heirarchy that include `Apply` and `Bind`. `return` is now an alias for `pure`. (joneshf, paf31, garyb) +- `Semigroupoid` is now a superclass of `Category` (garyb) +- `(:)` is now part of Prelude (garyb) +- `(!!)` has been renamed to `Prelude.Unsafe.unsafeIndex` and a safe version has been added to `Data.Array` (garyb) + +**New Features** +- Multi parameter typeclasses (paf31) +- Superclasses (puffnfresh, paf31) +- FlexibleInstances and FlexibleContexts (paf31) +- Let bindings are now supported. The `let` keyword can introduce several local (possibly mutually recursive) bindings, along with optional type signatures. (paf31) +- `where` clauses are now supported in value declarations, with the same rules as `let` bindings (garyb) +- Empty data declarations and empty type classes are now supported (paf31) +- A new command line option `--codegen` controls which modules will have Javascript and externs generated (paf31) +- `psc-make` now generates CommonJS-compatible modules, which can be used with `require()` in `node`. `psc` still generates modules for use in the browser. (paf31, garyb) + +**Enhancements** +- Pretty printing for row types was improved (garyb) +- Module names can now contain `.` (garyb) +- New optimizer rules have been added for code in the ST monad, to reproduce the functionality of the blocks feature, which has been removed (paf31) +- Pattern binders are now usable in lambda expression arguments (paf31) +- PSCI now has a `:t` command for checking the type of a value (paf31) +- Array pretty printing via `show` has been improved (joneshf) +- PSCI completions are sorted (joneshf) +- PSCI now has help commands (joneshf) +- PSCI history is in XDG config (joneshf) +- PSCI allows loading of modules from ~ paths (joneshf) +- PSCI can accept a list of modules to load on start from the command line (paf31) +- PSCI can now be configured using a `.psci` file in the current directory. If such a file exists, it should contain a list of commands to run on startup. (paf31) +- Type class instances are now named, to enable easier interop with Javascript (paf31) +- Class names no longer need to be qualified in instance declarations (garyb) +- Module exports can now be specified explicitly (garyb) +- Let bindings can now define functions with binders (paf31) +- Case statements and functions which do not pattern match on their arguments now generate smaller code (paf31) +- Imported type class instances are now exported (paf31) +- Some error messages were improved (paf31) +- Qualfied module imports are now supported as `import qualified M as X` (garyb) +- The escape check was removed, since it was too restrictive (paf31) +- The binary operator reordering step was greatly simplified (paf31) +**The Object type constructor can now be referenced explicitly as `Prim.Object` (with kind `# * -> *`) (paf31)** +- Optimizations are now enabled by default and can be disabled with the `--no-tco` and `--no-magic-do` flags (garyb) +- Unary minus and signed numeric literals are now supported again (paf31, garyb) +- Type errors have been simplified, the full trace can be enabled with `--verbose-errors` or `-v` (paf31) +- Error messages now display source positions (paf31, garyb) +- The type classes implementation and code generation was greatly simplified (paf31) +- Object properties and row labels can now be accessed with arbitrary string names by using string literals (paf31) +- `(++)` is now an alias for the Semigroup operator `(<>)` (paf31) +- Error messages for classes with undefined or missing members have been improved (garyb) +- The SYB dependency was removed, and traversals rewritten by hand, for a large performance increase (paf31) + +**Bug Fixes** +- The subsumes relation has been fixed for object types (paf31) +- `sort` no longer mutates arrays (joneshf) +- PSCI now evaluates expressions (joneshf) +- Overlapping variables in typeclass instances are rejected (paf31) +- A bug in the optimizer related to inlining was fixed (paf31) +- A type checker bug related to array literals was fixed (paf31) +- Externs files (`--externs`) are now working again (paf31) +- Precedence of backticked infix functions have been corrected (paf31) +- A bug which allowed some incorrect type class instances to pass the type checker was fixed (paf31) +- Type synonyms are no longer restricted to kind `*` (paf31) +- Negative number literals have been restored (garyb) +- If a type defined in a module appears in an exported declaration it must also be exported from the module (garyb) +- Error messages for unresolvable types or values include the declaration name again (garyb) +- Characters in string literals are now properly escaped (garyb) +- A module containing a single orphan type declaration and no other declarations now fails to compile (garyb) +- An error involving ordering of type class instances was fixed (garyb, paf31) +- Externs files no longer include fixity declarations for members that were removed as dead code (garyb) +- A bug which prevented `sequence $ [Just 1]` from typechecking was fixed (paf31) + +**Libraries** +- Purescript libraries are now [distributed via Bower](http://bower.io/search/?q=purescript). There are currently around 40 libraries available. + +**Plugins** +- The `grunt-purescript` plugin has been updated to provide support for new command line options. +- There is a new `gulp-purescript` plugin available for compiling with Gulp. + +**Documentation** +- There is a new `hierarchy` executable which will generate `.dot` diagrams based on the type class hierarchy of a module. The Prelude docs have been updated to include such a type class diagram. (joneshf) From 7ecc42669c69682996f2196ba2eef6c4ca827348 Mon Sep 17 00:00:00 2001 From: Colin Wahl Date: Wed, 20 Jan 2021 14:06:20 -0800 Subject: [PATCH 1261/1580] Only include direct dependencies in output for purs graph (#3993) * Add DependencyDepth argument to sortModules. Only compute Direct dependencies for graph command, maintain existing behavior for other existing workflows * update test to make sure that only direct dependencies are included by purs graph * include Module3.purs in graph test modules paths * add forgotten newline at the end of graph.json * oops was supposed to remove trailing newline, not add one! * update CHANGELOG.md --- CHANGELOG.md | 5 +++++ src/Language/PureScript/Docs/Convert/ReExports.hs | 2 +- src/Language/PureScript/Graph.hs | 2 +- src/Language/PureScript/Ide/Rebuild.hs | 2 +- src/Language/PureScript/Make.hs | 2 +- src/Language/PureScript/ModuleDependencies.hs | 15 +++++++++++---- tests/TestGraph.hs | 2 +- tests/purs/graph/graph.json | 2 +- tests/purs/graph/src/Module2.purs | 2 ++ tests/purs/graph/src/Module3.purs | 4 ++++ 10 files changed, 28 insertions(+), 10 deletions(-) create mode 100644 tests/purs/graph/src/Module3.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index 06541a116c..d0d46c8224 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,11 @@ New features: Bugfixes: +* Only include direct dependencies in the output for `purs graph` (#3993, @colinwahl) + +Fixes a bug where the transitive closure of a module's dependencies +where included in the `depends` field in the output for `purs graph`. + Other improvements: ## [v0.13.8](https://github.com/purescript/purescript/releases/tag/v0.13.8) - 2020-05-23 diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 9cd096a4c3..5c9526a01d 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -68,7 +68,7 @@ updateReExports externs withPackage = execState action traversalOrder :: [P.ModuleName] traversalOrder = - case P.sortModules externsSignature externs of + case P.sortModules P.Transitive externsSignature externs of Right (es, _) -> map P.efModuleName es Left errs -> internalError $ "failed to sortModules: " ++ diff --git a/src/Language/PureScript/Graph.hs b/src/Language/PureScript/Graph.hs index af79555ebc..ca092be193 100644 --- a/src/Language/PureScript/Graph.hs +++ b/src/Language/PureScript/Graph.hs @@ -32,7 +32,7 @@ graph input = do Make.runMake Options.defaultOptions $ do ms <- CST.parseModulesFromFiles id moduleFiles let parsedModuleSig = Dependencies.moduleSignature . CST.resPartial - (_sorted, moduleGraph) <- Dependencies.sortModules (parsedModuleSig . snd) ms + (_sorted, moduleGraph) <- Dependencies.sortModules Dependencies.Direct (parsedModuleSig . snd) ms let pathMap = Map.fromList $ map (\(p, m) -> (Dependencies.sigModuleName (parsedModuleSig m), p)) ms pure (moduleGraphToJSON pathMap moduleGraph) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 1cf9bd0695..ac06b6e1e3 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -186,7 +186,7 @@ sortExterns -> m [P.ExternsFile] sortExterns m ex = do sorted' <- runExceptT - . P.sortModules P.moduleSignature + . P.sortModules P.Transitive P.moduleSignature . (:) m . map mkShallowModule . M.elems diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 101d95e052..b481b11791 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -131,7 +131,7 @@ make ma@MakeActions{..} ms = do checkModuleNames cacheDb <- readCacheDb - (sorted, graph) <- sortModules (moduleSignature . CST.resPartial) ms + (sorted, graph) <- sortModules Transitive (moduleSignature . CST.resPartial) ms (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph) diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index d57497f040..ed915b63d9 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -1,6 +1,7 @@ -- | Provides the ability to sort modules based on module dependencies module Language.PureScript.ModuleDependencies - ( sortModules + ( DependencyDepth(..) + , sortModules , ModuleGraph , ModuleSignature(..) , moduleSignature @@ -8,6 +9,7 @@ module Language.PureScript.ModuleDependencies import Protolude hiding (head) +import Data.Array ((!)) import Data.Graph import qualified Data.Set as S import Language.PureScript.AST @@ -26,16 +28,19 @@ data ModuleSignature = ModuleSignature , sigImports :: [(ModuleName, SourceSpan)] } +data DependencyDepth = Direct | Transitive + -- | Sort a collection of modules based on module dependencies. -- -- Reports an error if the module graph contains a cycle. sortModules :: forall m a . MonadError MultipleErrors m - => (a -> ModuleSignature) + => DependencyDepth + -> (a -> ModuleSignature) -> [a] -> m ([a], ModuleGraph) -sortModules toSig ms = do +sortModules dependencyDepth toSig ms = do let ms' = (\m -> (m, toSig m)) <$> ms mns = S.fromList $ map (sigModuleName . snd) ms' @@ -44,7 +49,9 @@ sortModules toSig ms = do let (graph, fromVertex, toVertex) = graphFromEdges verts moduleGraph = do (_, mn, _) <- verts let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn) - deps = reachable graph v + deps = case dependencyDepth of + Direct -> graph ! v + Transitive -> reachable graph v toKey i = case fromVertex i of (_, key, _) -> key return (mn, filter (/= mn) (map toKey deps)) return (fst <$> ms'', moduleGraph) diff --git a/tests/TestGraph.hs b/tests/TestGraph.hs index ef53d554f1..e83b32a31e 100644 --- a/tests/TestGraph.hs +++ b/tests/TestGraph.hs @@ -22,7 +22,7 @@ spec = do let baseDir = "tests/purs/graph/" let sourcesDir = baseDir <> "src/" it "should match the graph fixture" $ do - let modulePaths = (sourcesDir <>) <$> ["Module.purs", "Module2.purs"] + let modulePaths = (sourcesDir <>) <$> ["Module.purs", "Module2.purs", "Module3.purs"] let graphFixtureName = "graph.json" graphFixture <- readUTF8FileT (baseDir <> graphFixtureName) diff --git a/tests/purs/graph/graph.json b/tests/purs/graph/graph.json index 2f27a3a37a..0e6725089d 100644 --- a/tests/purs/graph/graph.json +++ b/tests/purs/graph/graph.json @@ -1 +1 @@ -{"Module2":{"path":"tests/purs/graph/src/Module2.purs","depends":[]},"Module":{"path":"tests/purs/graph/src/Module.purs","depends":["Module2"]}} \ No newline at end of file +{"Module2":{"path":"tests/purs/graph/src/Module2.purs","depends":["Module3"]},"Module3":{"path":"tests/purs/graph/src/Module3.purs","depends":[]},"Module":{"path":"tests/purs/graph/src/Module.purs","depends":["Module2"]}} \ No newline at end of file diff --git a/tests/purs/graph/src/Module2.purs b/tests/purs/graph/src/Module2.purs index 27b2053f36..547419beb4 100644 --- a/tests/purs/graph/src/Module2.purs +++ b/tests/purs/graph/src/Module2.purs @@ -1,4 +1,6 @@ module Module2 (bar) where +import Module3 (baz) + bar :: Int bar = 1 diff --git a/tests/purs/graph/src/Module3.purs b/tests/purs/graph/src/Module3.purs new file mode 100644 index 0000000000..15905130a2 --- /dev/null +++ b/tests/purs/graph/src/Module3.purs @@ -0,0 +1,4 @@ +module Module3 (baz) where + +baz :: Int +baz = 3 From d9bec8e443adce6cfa0cc39a3e567d5de5271d3d Mon Sep 17 00:00:00 2001 From: Mark Eibes Date: Sun, 24 Jan 2021 18:44:37 +0100 Subject: [PATCH 1262/1580] Extend ImportCompletion with declarationType (#3997) * Inclusive language * Add declarationType in completions * Improve documentation * Update CHANGELOG * Use existing DeclarationType type * Remove obsolete TODO --- CHANGELOG.md | 8 +++ psc-ide/PROTOCOL.md | 9 ++- src/Language/PureScript/Ide/Completion.hs | 2 + src/Language/PureScript/Ide/Error.hs | 22 ++++++- src/Language/PureScript/Ide/Filter.hs | 2 +- .../PureScript/Ide/Filter/Declaration.hs | 23 +++---- src/Language/PureScript/Ide/Imports.hs | 9 +-- src/Language/PureScript/Ide/Types.hs | 13 ++++ .../Language/PureScript/Ide/CompletionSpec.hs | 64 +++++++++++++++++++ tests/support/pscide/src/CompletionSpec.purs | 18 ++++++ 10 files changed, 145 insertions(+), 25 deletions(-) create mode 100644 tests/support/pscide/src/CompletionSpec.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index d0d46c8224..816685f513 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,14 @@ Breaking changes: New features: +* Extend ImportCompletion with declarationType (#3997, @i-am-the-slime) + + By exposing the declaration type (value, type, typeclass, etc.) + downstream tooling can annotate imports with this info so users know what they + are about to import. The info can also be mapped to a namespace filter to + allow importing identifiers that appear more than once in a source file which + throws an exception without such a filter. + Bugfixes: * Only include direct dependencies in the output for `purs graph` (#3993, @colinwahl) diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index a9981fe1d4..fba93d39f7 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -107,8 +107,10 @@ The `complete` command looks up possible completions/corrections. The following format is returned as the Result: -Both the `definedAt` as well as the `documentation` field might be `null` if they -couldn't be extracted from a source file. +The `definedAt`, `documentation`, as well as the `declarationType` field might +be `null` if they couldn't be extracted from a source file. See the +[Declaration Type Filter](#declaration-type-filter) further down for all +possible values of declaration types and how to use this information. ```json [ @@ -124,7 +126,8 @@ couldn't be extracted from a source file. "end": [3, 1] }, "documentation": "A filtering function", - "exportedFrom": ["Data.Array"] + "exportedFrom": ["Data.Array"], + "declarationType": "value", } ] ``` diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index d62dacb3ef..17b3666bdd 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -130,6 +130,8 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl), mns) = complDocumentation = _annDocumentation ann + complDeclarationType = Just (declarationType decl) + showFixity p a r o = let asso = case a of P.Infix -> "infix" diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 3a3645a804..dfe42f69b6 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -66,9 +66,27 @@ encodeRebuildErrors = toJSON . map encodeRebuildError . P.runMultipleErrors insertTSCompletions _ _ _ v = v identCompletion (P.Qualified mn i, ty) = - Completion (maybe "" P.runModuleName mn) i (prettyPrintTypeSingleLine ty) (prettyPrintTypeSingleLine ty) Nothing Nothing (maybe [] (\x -> [x]) mn) + Completion + { complModule = maybe "" P.runModuleName mn + , complIdentifier = i + , complType = prettyPrintTypeSingleLine ty + , complExpandedType = prettyPrintTypeSingleLine ty + , complLocation = Nothing + , complDocumentation = Nothing + , complExportedFrom = maybe [] (\x -> [x]) mn + , complDeclarationType = Nothing + } fieldCompletion (label, ty) = - Completion "" ("_." <> P.prettyPrintLabel label) (prettyPrintTypeSingleLine ty) (prettyPrintTypeSingleLine ty) Nothing Nothing [] + Completion + { complModule = "" + , complIdentifier = ("_." <> P.prettyPrintLabel label) + , complType = prettyPrintTypeSingleLine ty + , complExpandedType = prettyPrintTypeSingleLine ty + , complLocation = Nothing + , complDocumentation = Nothing + , complExportedFrom = [] + , complDeclarationType = Nothing + } textError :: IdeError -> Text textError (GeneralError msg) = msg diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 83829a75d8..576e40ee60 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -31,7 +31,7 @@ import Data.Aeson import Data.Text (isPrefixOf) import qualified Data.Set as Set import qualified Data.Map as Map -import Language.PureScript.Ide.Filter.Declaration (DeclarationType, declarationType) +import Language.PureScript.Ide.Filter.Declaration (DeclarationType) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import qualified Language.PureScript as P diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs index 96eda65312..96cd071874 100644 --- a/src/Language/PureScript/Ide/Filter/Declaration.hs +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -2,13 +2,11 @@ module Language.PureScript.Ide.Filter.Declaration ( DeclarationType(..) - , declarationType ) where import Protolude hiding (isPrefixOf) import Data.Aeson -import qualified Language.PureScript.Ide.Types as PI data DeclarationType = Value @@ -33,14 +31,13 @@ instance FromJSON DeclarationType where "typeoperator" -> pure TypeOperator "module" -> pure Module _ -> mzero - -declarationType :: PI.IdeDeclaration -> DeclarationType -declarationType decl = case decl of - PI.IdeDeclValue _ -> Value - PI.IdeDeclType _ -> Type - PI.IdeDeclTypeSynonym _ -> Synonym - PI.IdeDeclDataConstructor _ -> DataConstructor - PI.IdeDeclTypeClass _ -> TypeClass - PI.IdeDeclValueOperator _ -> ValueOperator - PI.IdeDeclTypeOperator _ -> TypeOperator - PI.IdeDeclModule _ -> Module +instance ToJSON DeclarationType where + toJSON dt = toJSON $ case dt of + Value -> "value" :: Text + Type -> "type" + Synonym -> "synonym" + DataConstructor -> "dataconstructor" + TypeClass -> "typeclass" + ValueOperator -> "valueoperator" + TypeOperator -> "typeoperator" + Module -> "module" diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 69a8d68e53..176fccbcc9 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -314,16 +314,13 @@ addImportForIdentifier fp ident qual filters = do -- worst Just decl -> Right <$> addExplicitImport fp decl m1 qual - -- Here we need the user to specify whether he wanted a dataconstructor - -- or a type - - -- TODO: With the new namespace filter, this can actually be a - -- request for the user to specify which of the two was wanted. + -- Here we need the user to specify whether they wanted a + -- dataconstructor or a type Nothing -> throwError (GeneralError "Undecidable between type and dataconstructor") -- Multiple matches were found so we need to ask the user to clarify which - -- module he meant + -- module they meant xs -> pure (Left xs) where diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 2a657bfbdc..7773050fd9 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -15,6 +15,7 @@ import Data.Time.Clock (UTCTime) import qualified Data.Map.Lazy as M import qualified Language.PureScript as P import qualified Language.PureScript.Errors.JSON as P +import Language.PureScript.Ide.Filter.Declaration (DeclarationType(..)) import Lens.Micro.Platform hiding ((.=)) type ModuleIdent = Text @@ -222,6 +223,7 @@ data Completion = Completion , complLocation :: Maybe P.SourceSpan , complDocumentation :: Maybe Text , complExportedFrom :: [P.ModuleName] + , complDeclarationType :: Maybe DeclarationType } deriving (Show, Eq, Ord) instance ToJSON Completion where @@ -234,6 +236,7 @@ instance ToJSON Completion where , "definedAt" .= complLocation , "documentation" .= complDocumentation , "exportedFrom" .= map P.runModuleName complExportedFrom + , "declarationType" .= complDeclarationType ] identifierFromDeclarationRef :: P.DeclarationRef -> Text @@ -245,6 +248,16 @@ identifierFromDeclarationRef = \case P.TypeOpRef _ op -> P.showOp op _ -> "" +declarationType :: IdeDeclaration -> DeclarationType +declarationType decl = case decl of + IdeDeclValue _ -> Value + IdeDeclType _ -> Type + IdeDeclTypeSynonym _ -> Synonym + IdeDeclDataConstructor _ -> DataConstructor + IdeDeclTypeClass _ -> TypeClass + IdeDeclValueOperator _ -> ValueOperator + IdeDeclTypeOperator _ -> TypeOperator + IdeDeclModule _ -> Module data Success = CompletionResult [Completion] | TextResult Text diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs index b9d3025fd3..b71ba6b9e8 100644 --- a/tests/Language/PureScript/Ide/CompletionSpec.hs +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -9,6 +9,7 @@ import qualified Language.PureScript as P import Language.PureScript.Ide.Test as Test import Language.PureScript.Ide.Command as Command import Language.PureScript.Ide.Completion +import qualified Language.PureScript.Ide.Filter.Declaration as DeclarationType import Language.PureScript.Ide.Types import Test.Hspec import System.FilePath @@ -86,3 +87,66 @@ spec = describe "Applying completion options" $ do , typ "member" ] result `shouldSatisfy` \res -> complDocumentation res == Just "doc for member\n" + + it "includes declarationType in completions for values" $ do + ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpec"] + , typ "exampleValue" + ] + result `shouldSatisfy` \res -> + complDeclarationType res == Just DeclarationType.Value + + it "includes declarationType in completions for functions" $ do + ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpec"] + , typ "exampleFunction" + ] + result `shouldSatisfy` \res -> + complDeclarationType res == Just DeclarationType.Value + + it "includes declarationType in completions for inferred values" $ do + ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpec"] + , typ "exampleInferredString" + ] + result `shouldSatisfy` \res -> + complDeclarationType res == Just DeclarationType.Value + + it "includes declarationType in completions for operators" $ do + ([_, (Right (CompletionResult results))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpec"] + , typ "\\°/" + ] + length results `shouldBe` 2 + results `shouldSatisfy` any (\res -> + complDeclarationType res == Just DeclarationType.ValueOperator) + results `shouldSatisfy` any (\res -> + complDeclarationType res == Just DeclarationType.TypeOperator) + + it "includes declarationType in completions for type constructors with \ + \conflicting names" $ do + ([_, (Right (CompletionResult results))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpec"] + , typ "ExampleTypeConstructor" + ] + length results `shouldBe` 2 + results `shouldSatisfy` any (\res -> + complDeclarationType res == Just DeclarationType.DataConstructor) + results `shouldSatisfy` any (\res -> + complDeclarationType res == Just DeclarationType.Type) + + it "includes declarationType in completions for type classes" $ do + ([_, (Right (CompletionResult [result]))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpec"] + , typ "ExampleClass" + ] + result `shouldSatisfy` \res -> + complDeclarationType res == Just DeclarationType.TypeClass + + it "includes declarationType in completions for type class members" $ do + ([_, (Right (CompletionResult [result]))], _) <- Test.inProject $ + Test.runIde [ load ["CompletionSpec"] + , typ "exampleMember" + ] + result `shouldSatisfy` \res -> + complDeclarationType res == Just DeclarationType.Value diff --git a/tests/support/pscide/src/CompletionSpec.purs b/tests/support/pscide/src/CompletionSpec.purs new file mode 100644 index 0000000000..a6e2bae81d --- /dev/null +++ b/tests/support/pscide/src/CompletionSpec.purs @@ -0,0 +1,18 @@ +module CompletionSpec where + +exampleValue :: Int +exampleValue = 42 + +exampleFunction :: Int -> Int +exampleFunction _ = 1 + +exampleInferredString = "" + +infixl 5 exampleFunction as \°/ + +data ExampleTypeConstructor a b = ExampleTypeConstructor a b + +infixl 5 type ExampleTypeConstructor as \°/ + +class ExampleClass where + exampleMember :: Int From e56d28b211864075c7232e56350539806efbb01f Mon Sep 17 00:00:00 2001 From: Christoph Hegemann <6189397+kritzcreek@users.noreply.github.com> Date: Sun, 24 Jan 2021 19:38:25 +0100 Subject: [PATCH 1263/1580] [purs ide] Improves protocol errors from the ide server (#3998) When failing to parse the Command Json we're now returning more descriptive error messages --- CHANGELOG.md | 2 ++ app/Command/Ide.hs | 9 +++++---- src/Language/PureScript/Ide/Command.hs | 15 ++++++++++----- src/Language/PureScript/Ide/Filter.hs | 5 +++-- src/Language/PureScript/Ide/Filter/Declaration.hs | 4 +++- src/Language/PureScript/Ide/Matcher.hs | 3 ++- src/Language/PureScript/Ide/Types.hs | 6 +++--- src/Language/PureScript/Ide/Util.hs | 5 +++-- 8 files changed, 31 insertions(+), 18 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 816685f513..f87066900d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -25,6 +25,8 @@ where included in the `depends` field in the output for `purs graph`. Other improvements: +* More descriptive protocol errors from the ide server (@kritzcreek) + ## [v0.13.8](https://github.com/purescript/purescript/releases/tag/v0.13.8) - 2020-05-23 **Bug Fixes** diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index 4c50f5ef16..630a476714 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -189,7 +189,7 @@ startServer port env = Network.withSocketsDo $ do Left err -> $(logError) err Right (cmd, h) -> do case decodeT cmd of - Just cmd' -> do + Right cmd' -> do let message duration = "Command " <> commandName cmd' @@ -210,10 +210,11 @@ startServer port env = Network.withSocketsDo $ do Right r -> Aeson.encode r Left err -> Aeson.encode err liftIO (hFlush stdout) - Nothing -> do - $(logError) ("Parsing the command failed. Command: " <> cmd) + Left err -> do + let errMsg = "Parsing the command failed with:\n" <> err <> "\nCommand: " <> cmd + $(logError) errMsg liftIO $ do - catchGoneHandle (T.hPutStrLn h (encodeT (GeneralError "Error parsing Command."))) + catchGoneHandle (T.hPutStrLn h (encodeT (GeneralError errMsg))) hFlush stdout liftIO $ catchGoneHandle (hClose h) diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index ac6991b694..4f858e6852 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -16,6 +16,7 @@ module Language.PureScript.Ide.Command where import Protolude +import Control.Monad.Fail (fail) import Data.Aeson import qualified Data.Map as Map import qualified Data.Set as Set @@ -103,7 +104,7 @@ instance FromJSON ImportCommand where <$> (o .: "identifier") <*> (fmap P.moduleNameFromString <$> o .:? "qualifier") - _ -> mzero + s -> fail ("Unknown import command: " <> show s) data ListType = LoadedModules | Imports FilePath | AvailableModules @@ -114,7 +115,7 @@ instance FromJSON ListType where "import" -> Imports <$> o .: "file" "loadedModules" -> pure LoadedModules "availableModules" -> pure AvailableModules - _ -> mzero + s -> fail ("Unknown list type: " <> show s) instance FromJSON Command where parseJSON = withObject "command" $ \o -> do @@ -175,10 +176,14 @@ instance FromJSON Command where <$> params .: "file" <*> params .:? "actualFile" <*> (parseCodegenTargets =<< params .:? "codegen" .!= [ "js" ]) - _ -> mzero + c -> fail ("Unknown command: " <> show c) where - parseCodegenTargets = - maybe mzero (pure . Set.fromList) . traverse (flip Map.lookup P.codegenTargets) + parseCodegenTargets ts = + case traverse (\t -> Map.lookup t P.codegenTargets) ts of + Nothing -> + fail ("Failed to parse codegen targets: " <> show ts) + Just ts' -> + pure (Set.fromList ts') mkAnnotations True = explicitAnnotations mkAnnotations False = noAnnotations diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 576e40ee60..885f06c465 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -26,9 +26,10 @@ module Language.PureScript.Ide.Filter import Protolude hiding (isPrefixOf, Prefix) +import Control.Monad.Fail (fail) import Data.Bifunctor (first) import Data.Aeson -import Data.Text (isPrefixOf) +import Data.Text (isPrefixOf) import qualified Data.Set as Set import qualified Data.Map as Map import Language.PureScript.Ide.Filter.Declaration (DeclarationType) @@ -141,4 +142,4 @@ instance FromJSON Filter where "declarations" -> do declarations <- o.: "params" pure (declarationTypeFilter (Set.fromList declarations)) - _ -> mzero + s -> fail ("Unknown filter: " <> show s) diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs index 96cd071874..82c1f94ee5 100644 --- a/src/Language/PureScript/Ide/Filter/Declaration.hs +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -6,6 +6,7 @@ module Language.PureScript.Ide.Filter.Declaration import Protolude hiding (isPrefixOf) +import Control.Monad.Fail (fail) import Data.Aeson data DeclarationType @@ -30,7 +31,8 @@ instance FromJSON DeclarationType where "valueoperator" -> pure ValueOperator "typeoperator" -> pure TypeOperator "module" -> pure Module - _ -> mzero + s -> fail ("Unknown declaration type: " <> show s) + instance ToJSON DeclarationType where toJSON dt = toJSON $ case dt of Value -> "value" :: Text diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index 1baf898e2c..85200de1c2 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -24,6 +24,7 @@ module Language.PureScript.Ide.Matcher import Protolude +import Control.Monad.Fail (fail) import Data.Aeson import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -49,7 +50,7 @@ instance FromJSON (Matcher IdeDeclarationAnn) where distanceMatcher <$> params .: "search" <*> params .: "maximumDistance" - Just _ -> mzero + Just s -> fail ("Unknown matcher: " <> show s) Nothing -> return mempty -- | Matches any occurrence of the search string with intersections diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 7773050fd9..4de450ea92 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -8,6 +8,7 @@ module Language.PureScript.Ide.Types where import Protolude hiding (moduleName) import Control.Concurrent.STM (TVar) +import Control.Monad.Fail (fail) import Data.Aeson (ToJSON, FromJSON, (.=)) import qualified Data.Aeson as Aeson import Data.IORef (IORef) @@ -314,12 +315,11 @@ data IdeNamespace = IdeNSValue | IdeNSType | IdeNSModule deriving (Show, Eq, Ord, Generic, NFData) instance FromJSON IdeNamespace where - parseJSON (Aeson.String s) = case s of + parseJSON = Aeson.withText "Namespace" $ \case "value" -> pure IdeNSValue "type" -> pure IdeNSType "module" -> pure IdeNSModule - _ -> mzero - parseJSON _ = mzero + s -> fail ("Unknown namespace: " <> show s) -- | A name tagged with a namespace data IdeNamespaced = IdeNamespaced IdeNamespace Text diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 56474f8aef..51065d8010 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -33,6 +33,7 @@ import Protolude hiding (decodeUtf8, encodeUtf8, to) import Data.Aeson +import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding as TLE import qualified Language.PureScript as P @@ -87,8 +88,8 @@ typeOperatorAliasT i = encodeT :: (ToJSON a) => a -> Text encodeT = TL.toStrict . TLE.decodeUtf8 . encode -decodeT :: (FromJSON a) => Text -> Maybe a -decodeT = decode . TLE.encodeUtf8 . TL.fromStrict +decodeT :: (FromJSON a) => Text -> Either Text a +decodeT = first T.pack . eitherDecode . TLE.encodeUtf8 . TL.fromStrict properNameT :: Getting r (P.ProperName a) Text properNameT = to P.runProperName From 41ec58a5f5bb9d0cef432699ea794c3e222a4fe3 Mon Sep 17 00:00:00 2001 From: Cyril Date: Wed, 17 Feb 2021 21:25:02 +0100 Subject: [PATCH 1264/1580] Update the changelog with release notes for the upcoming v0.14 (#3994) * Update CHANGELOG.md --- CHANGELOG.md | 285 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 281 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f87066900d..f3f6bcdff8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -18,12 +18,289 @@ New features: Bugfixes: -* Only include direct dependencies in the output for `purs graph` (#3993, @colinwahl) +Other improvements: -Fixes a bug where the transitive closure of a module's dependencies -where included in the `depends` field in the output for `purs graph`. +## v0.14.0 -Other improvements: +### Polykinds + +Polymorphic kinds, based on the [Kind Inference for Datatypes](https://richarde.dev/papers/2020/kind-inference/kind-inference.pdf) paper (#3779, #3831, #3929, @natefaubion) + +Just as types classify terms, kinds classify types. But while we have polymorphic types, kinds were previously monomorphic. + +This meant that we were not able to abstract over kinds, leading for instance to a proliferation of proxy types: + +```purescript +data Proxy (a :: Type) = Proxy +data SProxy (a :: Symbol) = SProxy +data RProxy (row :: # Type) = RProxy +data RLProxy (row :: RowList) = RLProxy +``` + +Now we can have a single proxy type, whose parameter has a polymorphic kind. + +#### Type :: Type + +The old `Kind` data type and namespace is gone. Kinds and types are the same and exist in the same namespace. + +Previously one could do: + +```purescript +foreign import kind Boolean +foreign import data True :: Boolean +foreign import data False :: Boolean +``` + +Where the kind `Boolean` and type `Boolean` were two different things. This is no longer the case. The `Prim` kind `Boolean` is now removed, and you can just use `Prim` type `Boolean` in the same way. This is a breaking change. + +The compiler still supports the old `foreign import kind` syntax but it warns that it's deprecated. + +```purescript +foreign import kind Foo +``` + +> Foreign kind imports are deprecated and will be removed in a future release. Use empty 'data' instead. + +It is treated internally as: + +```purescript +data Foo +``` + +Note that `foreign import data` declarations are not deprecated. They are still necessary to define types with kinds other than `Type` since constructors are not lifted as in GHC with [DataKinds](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/data_kinds.html#extension-DataKinds). + +Likewise, `kind` imports and exports are deprecated and treated the same as a type import or export. + +> Kind imports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead. + +The special unary `#` syntax for row kinds is still supported, but deprecated and will warn. There is now `Prim.Row :: Type -> Type` which can be used like a normal type constructor. + +> Unary '#' syntax for row kinds is deprecated and will be removed in a future release. Use the 'Row' kind instead. + +All of these deprecations have suggested fixes in the JSON output, so tools like [`purescript-suggest`](https://github.com/nwolverson/purescript-suggest) (or your IDE plugin) can automatically apply them. + +#### Kind Signatures + +With PolyKinds, all type-level declarations are generalized. + +```purescript +data Proxy a = Proxy +``` + +Previously, this had the `Type`-defaulted kind `Type -> Type`. Now this will be generalized to `forall k. k -> Type`. Such signature can be written with a kind signature declarations, similar to [standalone kind signatures](https://ryanglscott.github.io/2020/01/05/five-benefits-to-using-standalonekindsignatures/) in GHC. + +```purescript +data Proxy :: forall k. k -> Type +data Proxy a = Proxy +``` + +In GHC, all signatures use the `type` prefix, but we reuse the same keyword as the subsequent declaration because we already have `foreign import data` (rather than `foreign import type`) and because it makes things align nicer. Signatures have the same rule as value-level signatures, so they must always be followed by the "real" declaration. + +It's better to be explicit about polymorphism by writing signatures. Since we don't really quantify over free type variables, it's also necessary in the case that two poly-kinded arguments must have the same kind. The compiler will warn about missing kind signatures when polymorphic kinds are inferred. + +Classes can have signatures too, but they must end with the new `Constraint` kind instead of `Type`. For example, here's the new definition of `Prim.Row.Cons`: + +```purescript +class Cons :: forall k. Symbol -> k -> Row k -> Row k -> Constraint +class Cons label a tail row | label a tail -> row, label row -> a tail +``` + +### Safe zero-cost coercions + +Coercible constraints, based on the [Safe Zero-cost Coercions for Haskell](https://www.microsoft.com/en-us/research/uploads/prod/2018/05/coercible-JFP.pdf) paper (#3351, #3810, #3896, #3873, #3860, #3905, #3893, #3909, #3931, #3906, #3881, #3878, #3937, #3930, #3955, #3927, @lunaris, @rhendric, @kl0tl, @hdgarrood) + +`Prim.Coerce.Coercible` is a new compiler-solved class, used to relate types with the same runtime representation. One can use `Safe.Coerce.coerce` (from the new [`safe-coerce`](https://github.com/purescript/purescript-safe-coerce) library) instead of `Unsafe.Coerce.unsafeCoerce` to safely turn a `a` into a `b` when `Coercible a b` holds. + +#### Roles + +Types parameters now have _roles_, which depend on how they affect the runtime representation of their type. There are three roles, from most to least restrictive: + +* _nominal_ parameters can only be coerced to themselves. + +* _representational_ parameters can only be coerced to each other when a Coercible constraint holds. + +* _phantom_ parameters can be coerced to anything. + +#### Role annotations + +The compiler infers _nominal_ roles for foreign data types, which is safe but can be too constraining sometimes. For example this prevents the coercion of `Effect Age` to `Effect Int`, even though they have the same runtime representation. + +The roles of foreign data types can thus be loosened with explicit role annotations, similar to the [RoleAnnotations](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/roles.html#extension-RoleAnnotations) GHC extension. + +Here's the annotation we added to `Effect`: + +```purescript +type role Effect representational +``` + +Conversely, we might want to strengthen the roles of parameters with invariants invisible to the type system. Maps are the canonical example of this: the shape of their underlying tree rely on the `Ord` instance of their keys, but the `Ord` instance of a newtype may behave differently than the one of the wrapped type so it would be unsafe to allow coercions between `Map k1 a` and `Map k2 a`, even when `Coercible k1 k2` holds. + +In order to forbid such unsafe coercion we added a _nominal_ annotation to the first parameter of `Map`: + +```purescript +type role Map nominal representational +``` + +Annotated roles are compared against the roles inferred by the compiler so it is not possible to compromise safety by ascribing too permissive roles, except for foreign types. + +### Other changes + +#### Breaking + +* Add compiler support for `Coercible` based `Newtype` (#3975, @fsoikin) + +We added a `Coercible` superclass to `Data.Newtype.Newtype` in order to implement `unwrap`, `wrap` and most newtype combinators with `coerce` (see https://github.com/purescript/purescript-newtype/pull/22). This is only a breaking change for non derived instances because the `Newtype` class has no members anymore and can now only be implemented for representationally equal types (those satisfying the new superclass constraint). + +For example the instance for `newtype Additive a = Additive a` no longer implements `unwrap` and `wrap`: + +```diff ++instance newtypeAdditive :: Newtype (Additive a) a +-instance newtypeAdditive :: Newtype (Additive a) a where +- wrap = Additive +- unwrap (Additive a) = a +``` + +Derived instances don't require any modifications. + +* Reform handling of quote characters in raw strings (#3961, @rhendric) + +Quotes behaved rather unexpectedly in various edge cases inside raw strings. This clears things up by enforcing the following specification: + +``` +'"""' '"'{0,2} ([^"]+ '"'{1,2})* [^"]* '"""' +``` + +Meaning that raw strings can contain up to two successive quotes, any number of times, but three successive quotes are not allowed inside. + +* Unsupport bare negative literals as equational binders (#3956, @rhendric) + +It used to be possible to match on negative literals, such as `-1`, but this prevented parsing matches on constructors aliased to `-`. The compiler will reject matches on _bare_ negative literals, but they can still be matched by wrapping them in parentheses. + +* Forbid partial data constructors exports (#3872, @kl0tl) + +Exporting only some of the constructors of a type meant that changes internal to a module, such as adding or removing an unexported constructor, could cause unexhaustive pattern match errors in downstream code. Partial explicit export lists will have to be completed with the missing constructors or replaced by implicit export lists. + +* Print compile errors to stdout, progress messages to stderr (#3839, @JordanMartinez) + +Compiler errors and warnings arising from your code are now printed to stdout rather than stderr, and progress messages such as "Compiling Data.Array" are now printed to stderr rather than stdout. Warnings and errors arising from incorrect use of the CLI, such as specifying input files which don't exist or specifying globs which don't match any files, are still printed to stderr (as they were before). This change is useful when using the `--json-errors` flag, since you can now pipe JSON errors into other programs without having to perform awkward gymnastics such as `2>&1`. + +#### Fixes + +* Only include direct dependencies in the output for `purs graph` instead of their transitive closure (#3993, @colinwahl) + +* Fix the reversal of the qualifier of qualified operators (#3971, @rhendric) + +Qualified operators, for instance `Data.Array.(!)`, were interpreted with a reversed qualifier, like `Array.Data.(!)`. + +* Check all recursive paths in data binding groups (#3936, @natefaubion) + +The compiler was not catching recursive type synonyms when some recursive paths were guarded by data types or newtypes. + +* Desugar type operator aliases inside parens (#3935, @natefaubion) + +The compiler did not accept type operators inside parens in prefix position, except `(->)`. + +* Pin language-javascript to a specific version (#3904, @hdgarrood) + +Allowing the compiler to be built against various versions of `language-javascript` meant that multiple builds of the same version of the compiler could accept different syntaxes for JavaScript foreign modules, depending on how they were built. + +#### Improvements + +* Improves protocol errors from the IDE server (#3998, @kritzcreek) + +The IDE server now respond with more descriptive error messages when failing to parse a command. This should make it easier to contribute fixes to the various clients. + +* Extend IDE ImportCompletion with declarationType (#3997, @i-am-the-slime) + +By exposing the declaration type (value, type, typeclass, etc.) downstream tooling can annotate imports with this info so users know what they are about to import. The info can also be mapped to a namespace filter to allow importing identifiers that appear more than once in a source file which throws an exception without such a filter. + +* Improve error message when `negate` isn't imported (#3952, @mhmdanas) + +This shows a specific message when using negative literals but `Data.Ring.negate` is out of scope, similar to the messages shown when using do notation if `Control.Bind.bind` and `Control.Bind.discard` are out of scope. + +* Add source spans to `PartiallyAppliedSynonym` errors (#3951, @rhendric) + +`PartiallyAppliedSynonym` errors were usually rethrown with the appropriate source span, but not when deriving instances. This annotates those errors with the source span of the partially applied synonyms themselves, which is more robust and accurate than rethrowing the error with an approximate source span. + +* Allow type synonyms in instances heads and superclass constraints (#3539, #3966, #3965, @garyb, @kl0tl) + +This allows declarations such as + +```purescript +type Env = { port :: Int } +newtype App a = App (ReaderT Env Aff a) +derive newtype instance monadAskApp :: MonadAsk Env App +``` + +or + +```purescript +class (Monad m, MonadAsk Env m) <= MonadAskEnv m +``` + +* Improve incremental rebuild times for modules with large dependencies (#3899, @milesfrain) + +#### Other + +* Warn against exported types with hidden constructors but `Generic` or `Newtype` instances (#3907, @kl0tl) + +Types with hidden constructors are supposed to be opaque outside of their module of definition but `Generic` and `Newtype` instances allow to construct them with `Data.Generic.Rep.to` or `Data.Newtype.wrap` and examine their content with `Data.Generic.Rep.from` or `Data.Newtype.unwrap`, thus making void any invariant those types may witness. + +* Have module re-exports appear in generated code (#3883, @citizengabe) + +This is the first step towards smarter incremental rebuilds, which could skip rebuilding downstream modules when the interface of a module did not change (see #3724). + +* Add a printer for CST modules (#3887, @kritzcreek) + +* Deprecate constraints in foreign imports (#3829, @kl0tl) + +Constrained foreign imports leak instance dictionaries, hindering the compiler ability to optimize their representation. Manipulating dictionaries in foreign code should be avoided and foreign imports should accept the class members they need as additional arguments instead of being constrained. + +* Deprecate primes (the `'` character) in identifiers exported from foreign modules (#3792, @kl0tl) + +We are going to output ES modules instead of CommonJS in the next breaking release but named exports of ES modules, unlike CommonJS exports, have to be valid JavaScript identifiers and so cannot contain primes. + +#### Docs + +* Generate a changelog from the GitHub releases and add a pull request template (#3989, @JordanMartinez) + +* Detail license related error messages and fix incorrect SPDX sample licenses (#3970, @fsoikin) + +* Remove a spurious doc comment on the CoreFn Module type (#3552, @jmackie) + +* Add a link to the releases page (#3920, @milesfrain) + +* Update CONTRIBUTING.md (#3924, @hdgarrood) + +* Add troubleshooting steps for libtinfo and EACCES errors (#3903, @milesfrain) + +* Update an outdated link to the book (#3916, @sumew) + +#### Internal + +* Simplify the `Ord` instances of some AST types (#3902, @milesfrain) + +* Update the desugaring pipeline to work on individual modules (#3944, @kl0tl) + +* Remove the unmaintained and ignored core libraries tests (#3861, @kl0tl) + +* Configure Travis to run `hlint` (#3816, #3864, @joneshf, @hdgarrood) + +* Remove support for the legacy Bower resolutions format in `purs publish` (#3847, @kl0tl) + +* Add GitHub issue templates for bugs and proposals (#3853, @joneshf) + +* Add support for Happy >=1.19.10 (#3837, @arrowd) + +* Use the same default extensions in all packages (#3823, #3908, @natefaubion, @i-am-the-slime) + +* Relax `purescript-ast` dependency on `microlens-platform` to `microlens` (#3817, @joneshf) + +* Extract the AST and CST types, and related functions, into their own `purescript-ast` and `purescript-cst` packages for ease of consumption by external tooling (#3793, #3821, #3826, @joneshf, @natefaubion) + +* Fix various typos in documentation, comments and bindings names (#3795, @mhmdanas) + +* Add golden tests for errors and warnings (#3774, #3811, #3808, #3846, @dariooddenino, @rhendric, @kl0tl) * More descriptive protocol errors from the ide server (@kritzcreek) From f0d4660d9d3187ef0b6f14094a552a8a7eda0cc1 Mon Sep 17 00:00:00 2001 From: Cyril Date: Wed, 17 Feb 2021 21:59:25 +0100 Subject: [PATCH 1265/1580] Don't explain Coercible as a class with compiler-generated instances (#3999) * Don't explain Coercible as a class with compiler-generated instances --- CHANGELOG.md | 10 +-- src/Language/PureScript/Docs/Prim.hs | 92 ++++++++++++---------------- 2 files changed, 40 insertions(+), 62 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f3f6bcdff8..4609a71505 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,14 +8,6 @@ Breaking changes: New features: -* Extend ImportCompletion with declarationType (#3997, @i-am-the-slime) - - By exposing the declaration type (value, type, typeclass, etc.) - downstream tooling can annotate imports with this info so users know what they - are about to import. The info can also be mapped to a namespace filter to - allow importing identifiers that appear more than once in a source file which - throws an exception without such a filter. - Bugfixes: Other improvements: @@ -107,7 +99,7 @@ class Cons label a tail row | label a tail -> row, label row -> a tail ### Safe zero-cost coercions -Coercible constraints, based on the [Safe Zero-cost Coercions for Haskell](https://www.microsoft.com/en-us/research/uploads/prod/2018/05/coercible-JFP.pdf) paper (#3351, #3810, #3896, #3873, #3860, #3905, #3893, #3909, #3931, #3906, #3881, #3878, #3937, #3930, #3955, #3927, @lunaris, @rhendric, @kl0tl, @hdgarrood) +Coercible constraints, based on the [Safe Zero-cost Coercions for Haskell](https://www.microsoft.com/en-us/research/uploads/prod/2018/05/coercible-JFP.pdf) paper (#3351, #3810, #3896, #3873, #3860, #3905, #3893, #3909, #3931, #3906, #3881, #3878, #3937, #3930, #3955, #3927, #3999, @lunaris, @rhendric, @kl0tl, @hdgarrood) `Prim.Coerce.Coercible` is a new compiler-solved class, used to relate types with the same runtime representation. One can use `Safe.Coerce.coerce` (from the new [`safe-coerce`](https://github.com/purescript/purescript-safe-coerce) library) instead of `Unsafe.Coerce.unsafeCoerce` to safely turn a `a` into a `b` when `Coercible a b` holds. diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index f46421228b..df2b40313e 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -69,7 +69,7 @@ primBooleanDocsModule = Module primCoerceDocsModule :: Module primCoerceDocsModule = Module { modName = P.moduleNameFromString "Prim.Coerce" - , modComments = Just "The Prim.Coerce module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains automatically solved type classes for working with types that have provably-identical runtime representations." + , modComments = Just "The Prim.Coerce module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains an automatically solved type class for coercing types that have provably-identical runtime representations with [purescript-safe-coerce](https://pursuit.purescript.org/packages/purescript-safe-coerce)." , modDeclarations = [ coercible ] @@ -377,70 +377,56 @@ coercible :: Declaration coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines [ "Coercible is a two-parameter type class that has instances for types `a`" , "and `b` if the compiler can infer that they have the same representation." - , "This class does not have regular instances; instead they are created" - , "on-the-fly during type-checking according to a set of rules." + , "Coercible constraints are solved according to the following rules:" , "" - , "First, Coercible obeys reflexivity - any type has the same representation" - , "as itself:" + , "* _reflexivity_, any type has the same representation as itself:" + , "`Coercible a a` holds." , "" - , " instance coercibleReflexive :: Coercible a a" + , "* _symmetry_, if a type `a` can be coerced to some other type `b`, then `b`" + , "can also be coerced back to `a`: `Coercible a b` implies `Coercible b a`." , "" - , "Second, Coercible obeys symmetry - if a type `a` can be coerced to some" - , "other type `b`, then `b` can also be coerced back to `a`:" + , "* _transitivity_, if a type `a` can be coerced to some other type `b` which" + , "can be coerced to some other type `c`, then `a` can also be coerced to `c`:" + , "`Coercible a b` and `Coercible b c` imply `Coercible a c`." , "" - , " instance coercibleSymmetric :: Coercible a b => Coercible b a" + , "* Newtypes can be freely wrapped and unwrapped when their constructor is" + , "in scope:" , "" - , "Third, Coercible obeys transitivity - if a type `a` can be coerced to some" - , "other type `b` which can be coerced to some other type `c`, then `a` can" - , "also be coerced to `c`:" + , " newtype Age = Age Int" , "" - , " instance coercibleTransitive :: (Coercible a b, Coercible b c) => Coercible a c" + , "`Coercible Int Age` and `Coercible Age Int` hold since `Age` has the same" + , "runtime representation than `Int`." , "" - , "Fourth, for every type constructor there is an instance that allows one" - , "to coerce under the type constructor (`data` or `newtype`). For example," - , "given a definition:" + , "Newtype constructors have to be in scope to preserve abstraction. It's" + , "common to declare a newtype to encode some invariants (non emptiness of" + , "arrays with `Data.Array.NonEmpty.NonEmptyArray` for example), hide its" + , "constructor and export smart constructors instead. Without this restriction," + , "the guarantees provided by such newtypes would be void." , "" - , "data D a b = D a" + , "* If none of the above are applicable, two types of kind `Type` may be" + , "coercible, but only if their heads are the same. For example," + , "`Coercible (Maybe a) (Either a b)` does not hold because `Maybe` and" + , "`Either` are different. Those types don't share a common runtime" + , "representation so coercing between them would be unsafe. In addition their" + , "arguments may need to be identical or coercible, depending on the _roles_" + , "of the head's type parameters. Roles are documented in [the PureScript" + , "language reference](https://github.com/purescript/documentation/blob/master/language/Roles.md)." , "" - , "there is an instance:" + , "Coercible being polykinded, we can also coerce more than types of kind `Type`:" , "" - , " instance coercibleConstructor :: Coercible a a' => Coercible (D a b) (D a' b')" + , "* Rows are coercible when they have the same labels, when the corresponding" + , "pairs of types are coercible and when their tails are coercible:" + , "`Coercible ( label :: a | r ) ( label :: b | s )` holds when" + , "`Coercible a b` and `Coercible r s` do. Closed rows cannot be coerced to" + , "open rows." , "" - , "Note that, since the type variable `a` plays a role in `D`'s representation," - , "we require that the types `a` and `a'` are themselves `Coercible`. However," - , "since the variable `b` does not play a part in `D`'s representation (a type" - , "such as `b` is thus typically referred to as a \"phantom\" type), `b` and `b'`" - , "can differ arbitrarily." + , "* Higher kinded types are coercible if they are coercible when fully" + , "saturated: `Coercible (f :: _ -> Type) (g :: _ -> Type)` holds when" + , "`Coercible (f a) (g a)` does." , "" - , "Fifth, for every `newtype NT = MkNT T`, there is a pair of instances which" - , "permit coercion in and out of the `newtype`:" - , "" - , " instance coercibleNewtypeLeft :: Coercible a T => Coercible a NT" - , " instance coercibleNewtypeRight :: Coercible T b => Coercible NT b" - , "" - , "To prevent breaking abstractions, these instances are only usable if the" - , "constructor `MkNT` is in scope." - , "" - , "Sixth, every pair of unsaturated type constructors can be coerced if" - , "there is an instance for the fully saturated types. For example," - , "given the definitions:" - , "" - , "newtype NT1 a = MkNT1 a" - , "newtype NT2 a b = MkNT2 b" - , "" - , "there is an instance:" - , "" - , " instance coercibleUnsaturedTypes :: Coercible (NT1 b) (NT2 a b) => Coercible NT1 (NT2 a)" - , "" - , "This rule may seem puzzling since it is impossible to apply `coerce` to a term" - , "of type `NT1` but it is necessary to coerce types with higher kinded parameters." - , "" - , "Seventh, every pair of rows can be coerced if they have the same labels," - , "the corresponding types for each label and their tails are coercible:" - , "" - , " instance coercibleRow :: (Coercible a b, Coercible r s) => Coercible ( label :: a | r ) ( label :: b | s )" - , "" - , "Closed rows can't be coerced to open rows." + , "This rule may seem puzzling since there is no term of type `_ -> Type` to" + , "apply `coerce` to, but it is necessary when coercing types with higher" + , "kinded parameters." ] kindOrdering :: Declaration From 337e8035aaf9ad4bcddaa825e5bc41663a109d29 Mon Sep 17 00:00:00 2001 From: Cyril Date: Wed, 17 Feb 2021 22:31:54 +0100 Subject: [PATCH 1266/1580] Erase elaborated kinds from all errors by default (#4007) * Erase elaborated kinds from all errors by default --- CHANGELOG.md | 2 +- src/Language/PureScript/Errors.hs | 27 +++++++++++-------- .../failing/CoercibleHigherKindedData.out | 8 +++--- tests/purs/failing/CoercibleNonCanonical1.out | 8 +++--- .../InstanceChainSkolemUnknownMatch.out | 10 +++---- .../failing/PolykindInstanceOverlapping.out | 6 ++--- 6 files changed, 33 insertions(+), 28 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 4609a71505..95601b7b59 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,7 +16,7 @@ Other improvements: ### Polykinds -Polymorphic kinds, based on the [Kind Inference for Datatypes](https://richarde.dev/papers/2020/kind-inference/kind-inference.pdf) paper (#3779, #3831, #3929, @natefaubion) +Polymorphic kinds, based on the [Kind Inference for Datatypes](https://richarde.dev/papers/2020/kind-inference/kind-inference.pdf) paper (#3779, #3831, #3929, #4007, @natefaubion, @kl0tl) Just as types classify terms, kinds classify types. But while we have polymorphic types, kinds were previously monomorphic. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index ae799b6a4d..ad47096b1f 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -846,7 +846,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "Overlapping type class instances found for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + , Box.vcat Box.left (map prettyTypeAtom ts) ] , line "The following instances were found:" , indent $ paras (map (line . showQualified showIdent) ds) @@ -882,7 +882,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "No type class instance was found for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + , Box.vcat Box.left (map prettyTypeAtom ts) ] , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation." | any containsUnknowns ts @@ -909,7 +909,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "Type class instance for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + , Box.vcat Box.left (map prettyTypeAtom ts) ] , line "is possibly infinite." ] @@ -919,7 +919,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "Cannot derive a type class instance for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + , Box.vcat Box.left (map prettyTypeAtom ts) ] , line "since instances of this type class are not derivable." ] @@ -927,7 +927,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "Cannot derive newtype instance for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + , Box.vcat Box.left (map prettyTypeAtom ts) ] , line "Make sure this is a newtype." ] @@ -935,7 +935,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "The derived newtype instance for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cl) - , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + , Box.vcat Box.left (map prettyTypeAtom ts) ] , line $ "does not include a derived superclass instance for " <> markCode (showQualified runProperName su) <> "." ] @@ -943,7 +943,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "The derived newtype instance for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cl) - , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + , Box.vcat Box.left (map prettyTypeAtom ts) ] , line $ "implies an superclass instance for " <> markCode (showQualified runProperName su) <> " which could not be verified." ] @@ -951,7 +951,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "Cannot derive the type class instance" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + , Box.vcat Box.left (map prettyTypeAtom ts) ] , line $ fold $ [ "because the " @@ -967,7 +967,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line "Cannot derive the type class instance" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) - , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + , Box.vcat Box.left (map prettyTypeAtom ts) ] , "because the type" , markCodeBox $ indent $ prettyType ty @@ -1022,7 +1022,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line $ "Orphan instance " <> markCode (showIdent nm) <> " found for " , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm) - , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) ts) + , Box.vcat Box.left (map prettyTypeAtom ts) ] , Box.vcat Box.left $ case modulesToList of [] -> [ line "There is nowhere this instance can be placed without being an orphan." @@ -1324,7 +1324,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl [ line "Invalid type class instance declaration for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName C.Coercible) - , Box.vcat Box.left (map (typeAtomAsBox prettyDepth) tys) + , Box.vcat Box.left (map prettyTypeAtom tys) ] , line "Instance declarations of this type class are disallowed." ] @@ -1590,6 +1590,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl | full = typeAsBox depth | otherwise = typeAsBox depth . eraseForAllKindAnnotations . eraseKindApps + prettyTypeAtom :: Type a -> Box.Box + prettyTypeAtom + | full = typeAtomAsBox prettyDepth + | otherwise = typeAtomAsBox prettyDepth . eraseForAllKindAnnotations . eraseKindApps + levelText :: Text levelText = case level of Error -> "error" diff --git a/tests/purs/failing/CoercibleHigherKindedData.out b/tests/purs/failing/CoercibleHigherKindedData.out index 676e714c10..afad7f895c 100644 --- a/tests/purs/failing/CoercibleHigherKindedData.out +++ b/tests/purs/failing/CoercibleHigherKindedData.out @@ -3,10 +3,10 @@ in module Main at tests/purs/failing/CoercibleHigherKindedData.purs:13:17 - 13:23 (line 13, column 17 - line 13, column 23) No type class instance was found for -   -  Prim.Coerce.Coercible (Unary @t4 t5)  -  (Binary @t2 @t4 a3 t5) -   +   +  Prim.Coerce.Coercible (Unary t5)  +  (Binary a3 t5) +   The instance head contains unknown type variables. Consider adding a type annotation. while solving type class constraint diff --git a/tests/purs/failing/CoercibleNonCanonical1.out b/tests/purs/failing/CoercibleNonCanonical1.out index f4f6de7097..80405754e0 100644 --- a/tests/purs/failing/CoercibleNonCanonical1.out +++ b/tests/purs/failing/CoercibleNonCanonical1.out @@ -3,10 +3,10 @@ in module Main at tests/purs/failing/CoercibleNonCanonical1.purs:11:27 - 11:33 (line 11, column 27 - line 11, column 33) No type class instance was found for -   -  Prim.Coerce.Coercible a0  -  (D (N @k a0)) -   +   +  Prim.Coerce.Coercible a0  +  (D (N a0)) +   while solving type class constraint   diff --git a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out index cdb227c97b..c5e0d23286 100644 --- a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out +++ b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out @@ -3,11 +3,11 @@ in module InstanceChainSkolemUnknownMatch at tests/purs/failing/InstanceChainSkolemUnknownMatch.purs:14:13 - 14:36 (line 14, column 13 - line 14, column 36) No type class instance was found for -   -  InstanceChainSkolemUnknownMatch.Same (Proxy @Type t3)  -  (Proxy @Type Int) -  t4  -   +   +  InstanceChainSkolemUnknownMatch.Same (Proxy t3)  +  (Proxy Int) +  t4  +   The instance head contains unknown type variables. Consider adding a type annotation. while applying a function same diff --git a/tests/purs/failing/PolykindInstanceOverlapping.out b/tests/purs/failing/PolykindInstanceOverlapping.out index f9a97817ea..f9b3b77df5 100644 --- a/tests/purs/failing/PolykindInstanceOverlapping.out +++ b/tests/purs/failing/PolykindInstanceOverlapping.out @@ -3,9 +3,9 @@ in module Main at tests/purs/failing/PolykindInstanceOverlapping.purs:12:1 - 13:19 (line 12, column 1 - line 13, column 19) Overlapping type class instances found for -   -  Main.ShowP (Proxy @k a) -   +   +  Main.ShowP (Proxy a) +   The following instances were found: Main.test1 From 788e906c36cddc84ef166d816300dfd657529318 Mon Sep 17 00:00:00 2001 From: Cyril Date: Wed, 24 Feb 2021 13:28:14 +0100 Subject: [PATCH 1267/1580] Don't mention unknowns in unification errors when coercing misaligned rows (#4000) --- CHANGELOG.md | 2 +- .../TypeChecker/Entailment/Coercible.hs | 14 +++++- .../purs/failing/CoercibleUnknownRowTail1.out | 41 +++++++++++++++++ .../failing/CoercibleUnknownRowTail1.purs | 7 +++ .../purs/failing/CoercibleUnknownRowTail2.out | 46 +++++++++++++++++++ .../failing/CoercibleUnknownRowTail2.purs | 7 +++ 6 files changed, 114 insertions(+), 3 deletions(-) create mode 100644 tests/purs/failing/CoercibleUnknownRowTail1.out create mode 100644 tests/purs/failing/CoercibleUnknownRowTail1.purs create mode 100644 tests/purs/failing/CoercibleUnknownRowTail2.out create mode 100644 tests/purs/failing/CoercibleUnknownRowTail2.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index 95601b7b59..0bfc637453 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -99,7 +99,7 @@ class Cons label a tail row | label a tail -> row, label row -> a tail ### Safe zero-cost coercions -Coercible constraints, based on the [Safe Zero-cost Coercions for Haskell](https://www.microsoft.com/en-us/research/uploads/prod/2018/05/coercible-JFP.pdf) paper (#3351, #3810, #3896, #3873, #3860, #3905, #3893, #3909, #3931, #3906, #3881, #3878, #3937, #3930, #3955, #3927, #3999, @lunaris, @rhendric, @kl0tl, @hdgarrood) +Coercible constraints, based on the [Safe Zero-cost Coercions for Haskell](https://www.microsoft.com/en-us/research/uploads/prod/2018/05/coercible-JFP.pdf) paper (#3351, #3810, #3896, #3873, #3860, #3905, #3893, #3909, #3931, #3906, #3881, #3878, #3937, #3930, #3955, #3927, #3999, #4000, @lunaris, @rhendric, @kl0tl, @hdgarrood) `Prim.Coerce.Coercible` is a new compiler-solved class, used to relate types with the same runtime representation. One can use `Safe.Coerce.coerce` (from the new [`safe-coerce`](https://github.com/purescript/purescript-safe-coerce) library) instead of `Unsafe.Coerce.unsafeCoerce` to safely turn a `a` into a `b` when `Coercible a b` holds. diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 6ffae01cd9..7e8bc4cdd7 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -581,6 +581,16 @@ canonRow canonRow a b | RCons{} <- a = case alignRowsWith (,) a b of + -- We throw early when a bare unknown remains on either side after + -- aligning the rows because we don't know how to canonicalize them yet + -- and the unification error thrown when the rows are misaligned should + -- not mention unknowns. + (_, (([], u@TUnknown{}), rl2)) -> do + k <- elaborateKind u + throwError $ insoluble k u (rowFromList rl2) + (_, (rl1, ([], u@TUnknown{}))) -> do + k <- elaborateKind u + throwError $ insoluble k (rowFromList rl1) u (deriveds, (([], tail1), ([], tail2))) -> do pure . Canonicalized . S.fromList $ (tail1, tail2) : deriveds (_, (rl1, rl2)) -> @@ -725,7 +735,7 @@ canonNewtypeRight env = -- -- @ -- data D a b c = D a b --- type role D nominal representational +-- type role D nominal representational phantom -- @ -- -- We can decompose @Coercible (D a b d) (D a c e)@ into @Coercible b c@, but @@ -861,7 +871,7 @@ canonNewtypeDecompositionFailure a b -- | Constraints of the form @Coercible tv1 tv2@ may be irreducibles, but only -- when the variables are lexicographically ordered. Reordering variables is --- neessary to prevent loops. +-- necessary to prevent loops. -- -- For instance the declaration: -- diff --git a/tests/purs/failing/CoercibleUnknownRowTail1.out b/tests/purs/failing/CoercibleUnknownRowTail1.out new file mode 100644 index 0000000000..b89412208d --- /dev/null +++ b/tests/purs/failing/CoercibleUnknownRowTail1.out @@ -0,0 +1,41 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleUnknownRowTail1.purs:7:9 - 7:24 (line 7, column 9 - line 7, column 24) + + No type class instance was found for +   +  Prim.Coerce.Coercible () +  t0 +   + The instance head contains unknown type variables. Consider adding a type annotation. + +while solving type class constraint +  + Prim.Coerce.Coercible { a :: Int + }  + { a :: Int + | t0  + }  +  +while applying a function coerce + of type Coercible @Type t1 t2 => t1 -> t2 + to argument { a: 0 + }  +while checking that expression coerce { a: 0 +  }  + has type { a :: Int + | t0  + }  +while checking type of property accessor (coerce { a: ... +  }  + )  + .a  +in value declaration zero + +where t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleUnknownRowTail1.purs b/tests/purs/failing/CoercibleUnknownRowTail1.purs new file mode 100644 index 0000000000..d17b51d96f --- /dev/null +++ b/tests/purs/failing/CoercibleUnknownRowTail1.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +zero :: Int +zero = (coerce { a: 0 }).a diff --git a/tests/purs/failing/CoercibleUnknownRowTail2.out b/tests/purs/failing/CoercibleUnknownRowTail2.out new file mode 100644 index 0000000000..079d79368f --- /dev/null +++ b/tests/purs/failing/CoercibleUnknownRowTail2.out @@ -0,0 +1,46 @@ +Error found: +in module Main +at tests/purs/failing/CoercibleUnknownRowTail2.purs:7:9 - 7:30 (line 7, column 9 - line 7, column 30) + + No type class instance was found for +   +  Prim.Coerce.Coercible ( b :: Int +  )  +  t0  +   + The instance head contains unknown type variables. Consider adding a type annotation. + +while solving type class constraint +  + Prim.Coerce.Coercible { a :: Int + , b :: Int + }  + { a :: Int + | t0  + }  +  +while applying a function coerce + of type Coercible @Type t1 t2 => t1 -> t2 + to argument { a: 0 + , b: 1 + }  +while checking that expression coerce { a: 0 +  , b: 1 +  }  + has type { a :: Int + | t0  + }  +while checking type of property accessor (coerce { a: ... +  , b: ... +  }  + )  + .a  +in value declaration zero + +where t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CoercibleUnknownRowTail2.purs b/tests/purs/failing/CoercibleUnknownRowTail2.purs new file mode 100644 index 0000000000..9ab45b9705 --- /dev/null +++ b/tests/purs/failing/CoercibleUnknownRowTail2.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Safe.Coerce (coerce) + +zero :: Int +zero = (coerce { a: 0, b: 1 }).a From 89bdf5687359fba0eef70eec095bc07477d60099 Mon Sep 17 00:00:00 2001 From: Cyril Date: Thu, 25 Feb 2021 19:26:47 +0100 Subject: [PATCH 1268/1580] =?UTF-8?q?Release=20v0.14.0=20=F0=9F=8E=89=20(#?= =?UTF-8?q?4014)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Regenerate LICENSE * Update version to 0.14.0 --- LICENSE | 103 +++++++++++++++++++++++++++++++++++++++ app/Version.hs | 2 +- npm-package/package.json | 4 +- package.yaml | 2 +- 4 files changed, 107 insertions(+), 4 deletions(-) diff --git a/LICENSE b/LICENSE index 52d6ce7166..bc9cfd2a6e 100644 --- a/LICENSE +++ b/LICENSE @@ -47,6 +47,7 @@ PureScript uses the following Haskell library packages. Their license files foll bytestring-builder cabal-doctest case-insensitive + cborg cereal cheapskate clock @@ -80,6 +81,7 @@ PureScript uses the following Haskell library packages. Their license files foll fsnotify ghc-boot-th ghc-prim + half happy hashable haskeline @@ -120,6 +122,8 @@ PureScript uses the following Haskell library packages. Their license files foll process protolude psqueues + purescript-ast + purescript-cst random regex-base regex-tdfa @@ -129,6 +133,7 @@ PureScript uses the following Haskell library packages. Their license files foll semialign semigroupoids semigroups + serialise simple-sendfile sourcemap split @@ -1292,6 +1297,42 @@ case-insensitive LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +cborg LICENSE file: + + Copyright (c) 2015-2017 Duncan Coutts, + 2015-2017 Well-Typed LLP, + 2015 IRIS Connect Ltd. + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Duncan Coutts nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + cereal LICENSE file: Copyright (c) Lennart Kolmodin, Galois, Inc. @@ -2343,6 +2384,35 @@ ghc-prim LICENSE file: be a definition of the Haskell 98 Language. +half LICENSE file: + + Copyright 2014 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + happy LICENSE file: The Happy License @@ -3954,6 +4024,39 @@ semigroups LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +serialise LICENSE file: + + Copyright (c) 2017, Duncan Coutts + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Duncan Coutts nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + simple-sendfile LICENSE file: Copyright (c) 2009, IIJ Innovation Institute Inc. diff --git a/app/Version.hs b/app/Version.hs index 673c6c0d5b..9c2f3556be 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -17,7 +17,7 @@ import qualified Development.GitRev as GitRev -- prerelease identifier here (if any). When releasing a proper version, simply -- set this to an empty string. prerelease :: String -prerelease = "-rc5" +prerelease = "" versionString :: String versionString = showVersion Paths.version ++ prerelease ++ extra diff --git a/npm-package/package.json b/npm-package/package.json index d050c7a146..73cef384a6 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.13.6", + "version": "0.14.0", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.13.6", + "postinstall": "install-purescript --purs-ver=0.14.0", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/package.yaml b/package.yaml index 68e43502d8..9cbd5facd3 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: purescript -version: '0.14.0-rc5' # note: when updating this, update the prerelease identifier in app/Version.hs too! +version: '0.14.0' # note: when updating the prerelease identifier, update it in app/Version.hs too! synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From 20f529424c2bbf9bf786e8e23c51592f328350af Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Wed, 3 Mar 2021 13:26:35 -0500 Subject: [PATCH 1269/1580] Make close punctuation printable in errors (#3982) --- CHANGELOG.md | 2 ++ .../src/Language/PureScript/PSString.hs | 1 + tests/purs/failing/3891.out | 24 +++++++++++++++++++ tests/purs/failing/3891.purs | 4 ++++ 4 files changed, 31 insertions(+) create mode 100644 tests/purs/failing/3891.out create mode 100644 tests/purs/failing/3891.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index 0bfc637453..38a8263467 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,8 @@ New features: Bugfixes: +* Make close punctuation printable in errors (#3982, @rhendric) + Other improvements: ## v0.14.0 diff --git a/lib/purescript-ast/src/Language/PureScript/PSString.hs b/lib/purescript-ast/src/Language/PureScript/PSString.hs index 081bf715f1..61cfd77efa 100644 --- a/lib/purescript-ast/src/Language/PureScript/PSString.hs +++ b/lib/purescript-ast/src/Language/PureScript/PSString.hs @@ -182,6 +182,7 @@ prettyPrintString s = "\"" <> foldMap encodeChar (decodeStringEither s) <> "\"" , Char.ConnectorPunctuation , Char.DashPunctuation , Char.OpenPunctuation + , Char.ClosePunctuation , Char.InitialQuote , Char.FinalQuote , Char.OtherPunctuation diff --git a/tests/purs/failing/3891.out b/tests/purs/failing/3891.out new file mode 100644 index 0000000000..7aebfb1c40 --- /dev/null +++ b/tests/purs/failing/3891.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/3891.purs:4:8 - 4:15 (line 4, column 8 - line 4, column 15) + + Could not match type +   +  String +   + with type +   +  String -> t0 +   + +while applying a function "(" + of type String + to argument ")" +while inferring the type of "(" ")" +in value declaration oops + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3891.purs b/tests/purs/failing/3891.purs new file mode 100644 index 0000000000..c9681fa328 --- /dev/null +++ b/tests/purs/failing/3891.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +oops = "(" ")" From ce185d611bb48038db889058f52d2baef2e07417 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 13 Mar 2021 15:06:45 +0000 Subject: [PATCH 1270/1580] Drop "Proposal:" prefix in proposal template (#4026) It's just noise, and the `enhancement` label does a better job at identifying what kind of issue this is. --- .github/ISSUE_TEMPLATE/compiler-proposal.md | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/ISSUE_TEMPLATE/compiler-proposal.md b/.github/ISSUE_TEMPLATE/compiler-proposal.md index 0644a0e22a..32edbffed4 100644 --- a/.github/ISSUE_TEMPLATE/compiler-proposal.md +++ b/.github/ISSUE_TEMPLATE/compiler-proposal.md @@ -1,7 +1,6 @@ --- name: Compiler proposal about: A concrete suggestion to change the PureScript compiler -title: 'Proposal:' labels: enhancement assignees: '' From 757559625493781ceed5bf82d350cea1941b9e72 Mon Sep 17 00:00:00 2001 From: Peter Murphy <26548438+ptrfrncsmrph@users.noreply.github.com> Date: Sun, 14 Mar 2021 20:44:45 -0400 Subject: [PATCH 1271/1580] Add white outline stroke to logo.png (#4003) * Add white outline stroke to logo.png * Add Peter Murphy to CONTRIBUTORS.md * Move logo change to correct CHANGELOG section Co-authored-by: Harry Garrood --- CHANGELOG.md | 5 +++++ CONTRIBUTORS.md | 1 + README.md | 2 +- logo.png | Bin 2952 -> 23059 bytes 4 files changed, 7 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 38a8263467..af1cab9089 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,6 +14,10 @@ Bugfixes: Other improvements: +* Add white outline stroke to logo in README (#4003, @ptrfrncsmrph) + + The previous `logo.png` was not legible against a dark background (#4001). + ## v0.14.0 ### Polykinds @@ -298,6 +302,7 @@ We are going to output ES modules instead of CommonJS in the next breaking relea * More descriptive protocol errors from the ide server (@kritzcreek) + ## [v0.13.8](https://github.com/purescript/purescript/releases/tag/v0.13.8) - 2020-05-23 **Bug Fixes** diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 81053e8f55..5e8644cd24 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -97,6 +97,7 @@ If you would prefer to use different terms, please use the section below instead | [@phiggins](https://github.com/phiggins) | Pete Higgins | [MIT license](http://opensource.org/licenses/MIT) | | [@philopon](https://github.com/philopon) | Hirotomo Moriwaki | [MIT license](http://opensource.org/licenses/MIT) | | [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license](http://opensource.org/licenses/MIT) | +| [@ptrfrncsmrph](https://github.com/ptrfrncsmrph) | Peter Murphy | [MIT license](http://opensource.org/licenses/MIT) | | [@quesebifurcan](https://github.com/quesebifurcan) | Fredrik Wallberg | [MIT license](http://opensource.org/licenses/MIT) | | [@rhendric](https://github.com/rhendric) | Ryan Hendrickson | [MIT license](http://opensource.org/licenses/MIT) | | [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) | diff --git a/README.md b/README.md index df883032eb..0941dff566 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -[![PureScript](logo.png)](http://purescript.org) +PureScript A small strongly typed programming language with expressive types that compiles to JavaScript, written in and inspired by Haskell. diff --git a/logo.png b/logo.png index e6cc9347457c8f0ad45ac7b64efa695d886deb92..6c91bf49d8cb658d7868f7b2507514010b7e955f 100644 GIT binary patch literal 23059 zcmYgY1yoe+(}$&zltn<0t|bKo1f^DKkd%^;ZjkN}0d+w_x;vEa21V)4rIB168lk-0b9FQ{YzP_}`dwUX;K~O& zAxGdJyf<>XE@)_63b()L9^S6XXlV3k^3SC-JyTKh%69r)X}edIjJaqVLX7nh>KvK`l}SZ>E<=4?COPF~Y!?|bnN zaI%HsKhyKo&Kx_h^BzBl{rliF2T$ga1ySkZ( z`9!qmM1RE%qXB=cE;E)iCei#y9NH&Rbu>vIJ$!b8pj#&aKlBf7Zz?SbY^N{$=L*^! zE(9%8@WFo+Q;h`FNJesGKE&nt=cYitU@+QnV#0qOYrWNevl;vU*Yk!LkX>(n_y5;( zt5Ln#{r|tf{sb^!VVvUs>zLUOy#CjnhX2Uvg#oYM*_8j!P2smXcKyFK11lMF(Nx`~ zF#rGUy}?l+$s{cD|GexD@G^69v;W8;0OZ7~4gW__HWMI7NbNs@VBxodp8r?S*NdHn zmcH*;s@P--UpS8s^z|CQ5Yc*b!3rcERm&Q*?BA&|?MgsNd}Yt;j8pGx@iP0zY?78b z^5~gdW*y&QSNgKDbXxC;C1^Vozrp_X2AGfmE3k5Ew1{vk2qw&v%J$bM-hsC|{Lhc* zx2qNUUlh>au7XtR-{2!byIrRA-^e?p1Z46v{ZG;dK+-hn--r-{0$%%{AQcjIv~Oap zg^5*0#Q%#B>XZ2vpM->aXf^{Jd8{Z$S_vlwgVsx9Fz>|hFs<8BFYkE71EboT!t5W3 zYYR{L|5@sL}xN`{Z#?? z0fV#?sb(exE(hq@ze@;=B2@=dOJR9S1;LU)E&G4(m6Vx!+(eV_I#NI6Ut3_5s#R1} zWFFu*9Aes)u7z_PFnfftj$ivVXrTJvO*n)L={0>mlvs+#VP;X&Uml+{DOs@K=_m8R zf4R)yCOMPw;a}Ofc&PMVQ(X#r&K^sy5Cw>i!qVN1@!yCSU;F4T=Z?zQ+>G1Ut*$Wt zS*+)CIW-aiMIFxVLxY56j7RsbO`37yW>9t z$^T6ce;#?&#`BzLwhXF7jn1TW*IoV&^Lz3KpDVH%Ns9mVxnx=S=j^#!S9IqNe{z$p zvdD+>-7LllKOS;&w735ay+eEkEL@H#sv!Koj?W~8;ul&-byQfUuS-L_^l&*~>X)p4 z<7nn*I#^C&K8G>?`W!c=xYz3_E}^e{7v1NtkGUCh0~HUYwSvDq?{NH|Oss03AjLy_ zTax^{HDuXGWdE#v7zD-7Whj(n#pU>$VbI=1fj&LrsyseI{pxrotH`^BZ%jS8`?sT_nhks zF)A4||LXgiAy@JVU@g4=w^l3}1J;bR>RY915=|wF)wus{-A7P-S4P3Y)5|KAB0uEY z7m1lB)|>fAqYTLKHTZA1v5QH|z2%Xs@XT0v=#gSq$jJ#9V)%=XREOyVVcr8)JdXCi zM@gW=yvNCof#Gvk)8`aS7oR1b!Q$1MV;Nb8A&^PMkp<&Y$qUW?t-ZX^;745(y;UE-n8tN}%Cu7Ocja;;^XV!axu8TuW)`Q=NYe7Wjfx{TogY zzFB@qW_BA|nfTwhR`?hNYR$za&$wLI-r8I0^2!>iV3q0sNl8=wb=@$}ac-dFJB2S^ zdE@0*E|D3J^LUJ|qbO(|#FQgH-9Z@K_)5PwdxhocHk||dCjj!K3fVar7MTpXa52DBzoYBq#4y ziXkTla`F+V`TVYyesx>V-}nY&F<@23-`D)9X(gR_ACp{~BarOhP|YmIg+$@taaib! z9m6O6%Q)ijanK)7PYGuJi6oaGSm58x`wcjdy__Ae3CuoZGSdI`UU`L+&_1*Dq==!@ zYN1@pBgJly@oUx;Ym7h2(OU$A&l0mwYd>XzyqF4casQg~v(-tg*jRRmJ8R90trm{J zr^*zo6ZwB)O#hrLMqEa(9`TtE9)E3eNuDotC0I(Ac4j0}`-5A2nH>4J3|SUZ+57=5 zu$)xgtdECT-52B6omM7x1= zUpp8)?R1X>(u%(K;nv)l`mBcu;W6%r(|*Sd&@pI5U{~gDSItBmsjl9Ly#?aP<_;Pf zzpPyJr|Q7=%v0=d6o@m6+s)TP#}W7Bd)qK3c}PXnm|fe85*+~yWgm>Ooy=l;o=S&z zbtF=pAEo?w21f1ZL((Z{X=ipb%q`9)DOIZdrEE1t0 z4G7rTB;avbFo~aZdZz2wbrK#2FkQHuHTo~UmrO?{1x9*xG)5}48YPgO=t|SHDQ_N# zGzu%qEg4n)t6dO&F#Tav_DkxIv;%z~TL+}$jwJW&FtMaWx_m$X-kqY5)6vL%8_?1C zo7*YDc2k z1wm}%=Js-arny8&c=rK(VnXoc7tQJrL_q~PDLFN4&W}TOBU&<~>ealfQ6{QwD%6H5<}z1Z@X{h% zc&YY}k6c}zra8pg@4_l7-cP)}T68$du-`agHSTEfW3|x3V=FbdF&9jXGPTuGSd|ar z5E+c5om$+gX#J`k66|ltjr6MAu%E_-z&P{$oNytR47q!`c>}h19B8YV-BKN)J3UIg z`wu4whF9-S}oJqaAQoLy-1e~8H zBTTbfME?xt5a}_wS~c6*zo12))#k0Pywu)xQ75Oq@GL77tQ@B5Y#;X;3Y%(C=YCB$ zWpriKr87{Q6*gr)SC^gl%^FDV-Z$@vi@F4Jof^k^Rv!oKCKbFAAow4?P#sXtJPx?6gr)s;8jevL7w>E1V}cDrn^Uvq-lijGL>)>xpZvC%qWCCQNcm|Yqwt2$D!I0vNUM)UYdcxuLKDib1|G6;XO z&2}(u@|#bY_{pd^nqg8(^6IvxKqf6UbqP^^3Rr4Q)F0X=@r*_iVsf|4PO5_!;LhG;pz-N84I_OLI;&lUNMom13 z?F?o-8pVKkb@q9MD`YOV+@y}^l6NDB1ECSQy3k#&tzIKy`11VVRQ_!{KBj}urNyWD z)fUbbL2Ci{ay=@XsM(S+5i^8nZYXTBq80=H2PQdx(X>erEP6PdD{!Nma8&I=DkYP# zfkr@+weU@pl)Qwayx9Oj;aa}F1?QE~&CpFjM8@NnD608DDoI|X_&Ay~Bm7fef`le- zs(4N(-C4Z%URImknn2N^rF+^Cm$OjLE*lbrpTxqsYvje-rP?1qf#zJ|yO-stX&J4+ zCmzxue$VM;v99zl0(Ry%pW$q)!(XUG2Gx;KC+q6x;YVcSkM_+YwQp8$P9=(p@K?py zN-Xa`H16O!(b~ZB+Ev)F=(M+Auq_!g&ho^Ch>kh^8?p>R_zlxFhnoivqc|Jf710m7 zS2bqeZD0!r@aOE|XWbuuqONMYA~0JZQFY*J5&cfrpudEn9Ewf4}dn!Y&~1(*UXEH3}vVn6{EB)_qBOa8zL=@xE~d@-_xM zWkQ&$$FMu$7wKChYPy)E0#|0IKTgEFXMv^kF7AaN*q8KfLxh~|Q>r?_Bs1qwpOR(z zT&u{sKlOCfJ18c3{Cp}MDSm@|0^{>{=!fMz-uvlTpz=cD)Yx*yH33_gU_U6-QKOVF zZp~jE1j{C`T083w*TFl`z|Z+X`aX!s8kMH>iy5mnJH|V-f6DPq_)vL*KBdwtAumTE z9o_H0p>O(`$r|7aB179Oh3wc+*rXTnA6h`D*a5RiBm;s zz+=R7Oht?HZb31Y!qQsn zT(H5;C5tBmZC?#9`d--F-*0`Pn`I$1E<>;MU3kq?xl$Gj%7S>6^m@4-exH@(69t2` zX~Q2fC6MMhm1c2i>CEESl<(NVW^QiW+=Y}D?)OR3eOC6mMlH~X9umpEKSv3vI2)X% z^b{zZdG|g(kR7`Db|gFIO}3>HOE3{sQ*)4?oDF=US0y(u5b^2&vxZpY*^a_XAH3XF;0Exr^|6Yc1b8 z?ZhQad>c$Vt}DYfRNaCXJ;i08p%+Ngz+bGsiyuW(7V9_hSPNI{ollAUad|i~L&&S4 zf4yh+O~mr%J|4#^HvglroqIIFVBBY*-ybYa8KZ3(HBnNzC zj>V&O`@CZC*l#gFTWIL<;p$^?@7Hajmp_eW7fYWHzbJ8t*(Slj7b#t*Bqkuh-20G> zO%A9LzWrs{%BMcXG$g9W>v7&EdTw{7gS^T%G$Juzxn!E%#TJnJtU!VFbdRM1tz9V3 zk;Fz$ZN2(}kvQ|&-Aehk#Xm<2@k4_~8EA_+uoNBpxdD=g=s4U(re${GjR3S&AK90}&Cv?qz zdbP#`LI*{>=Buks`~6}D&WJ~%+GG0}Yf2G5M>VORnBRVr`>rKkhcNt-Bso(MCfLs* z&1s{jELZWkXduo!)pdJnZ0p;#W8IY_OE=}j&0_E-y!1xh&llC$2<-a=r=^s#jJmM& zW#})s1R|JL_d$}jBtzHHi0p~>J2u&r;`nZ)Lpz68K%yzv%5_H`%hB~3v4EdAz-8^= zv;Wiu!S=cl1{Qg3PD{S~6;7yUduILXkF{THWd=1$Vd6qsN%a4m1AAPJfzX$h*rF#r z7D6ggJ^9I#Uom+5?Vx$u!rd1J*H6l*LWaaW)cy8TjHVaUEd;SlH0?S0g_8T25eK0{G>Yjbzosg7XM~%T1-ha6RDawPH7TuI{7C-u#KZk$d8f9q*V*LiucCO9ytwSUnI&Vs zwIf8d(%-$@7FstEi(L0Y#k}NY+_lYUrZD3gtSPJCZ-w`sH-B+O9iIMc_=Ww_lO>faN9qj)7 zXFt2XezR_xSTYu*y7#m_S*_a!|G7Nuk?!2DTBvwg-PaOp2Q7&@-9b=%l2-&(o`&?i z(&6F_$_T>~9P-e?vHG$V@e-^{o@D1d@R=7P-gESOe~nm==dt_;lM)&Jd`7DSO_$5n z^Rx*C%Df+V(-b`B6H@uPl-#>4XP*%eM2kb%@(Jh>LfpfJug<9FV8-%>w&D27!3||N z%L7EFD(8tFU4XAx)iBh*v>3Bmi+pF|yUV)Z*jDfJp&0Ds==e|b`YG;&+uPHg3!RQQ`T?S-Z0&!eRI`zjj-9><`PO*+LRr%XqKd2J>U?| zRKJX!kY5+z_k)g4(=0B6Q)WXdE~rH;|`F)4VPIhq8sC!pN2Ki8#0bMAxM}d!gFxDbjZyi20(D zSTYQ~1IBaM=kz4@aXj(H3a62gib$t2+gZ0MK-L7PmZd*=B^H_%6$oY35!Lf88K!G> zaYn_gn3now+>A+R4Pim-othZo;v$Z^^~YJJ>xPP@4Ezo;E=u=K^eWMtF;4VI*?r_l zmH#+=LvXO(;p@Xxzs+`oDmQtPd`}Y-ot+H>hMIuv) zm|L?WQL*9<2Omw7<`#`b)+mX$PTpfuXj6-^Kv@0vXN~F}T=yn^k&=}1QH(Uh3dbW7 zXgHpzD}0i8Q}vv*=S*sl&$(>P$0Tviw#Np)4|AnUP&!H_TDsAlWbN#Z?SEl_(nzSW)?mQZOEc?(P@;-&%Se8RyBfzlXC~S zQT&A(B&yf%aFfDlhE`j__!YityaJ{`1yX!WT#v4y`&1~8Jia13@<%gbQU`hNHMn(v z3>F{sLA9|XH1Glz{Sot9$l>i)sfCQ2n>n9PAQm4@S6uXv{y`V83u5X~lWXl$)by`&s(0s|)4n1&e)+s*k(p2j znl%?IgRTNx2uZ^ljYUuL^a9iQO~JyY!gm?gqwb^9S&&n&rF%0ogY-s;7xbkI_iu7_ zIpbM1w85`kHR<_NK|ZaLp}VbfUbyQ}(`Rh`4&C-K#k2UD5t;%k%sWN%aq z+(-*?3MA3C1o!uo*fT4^;E-5&%Ve-^P@+DZndC?iqI8`9rrDzk7vinvlUA#JX`abe zw9reb{+v#=u=8EA2nZid?-1A++s)pC4NJ5F+DjVFGFhV-Q+V18otCN$Rb$0eu|K>? z7ExR}nce*Zj+K)9(WhS{JYe(L!{WN=g@bbVb#w6;nC!xYZA?mKTaTTj>w2%sLy!0Y@tyH_U8xtkwf8gD@ z^AWmS{GhtWG``E`s}3XC5UYzM`XBxlGZK^S^XyHyFuR$x-4 zz%#ON^u-#C{MO8Q{WLV<1;&b~tTN8}iMDia1SeiYCUdL1ti!-IT-hA zfoj<rx3_SzgDg3FE;E6o6c#U2=hOqg_!G`7l@LE5_s&x;U)?pN$e7nFAxu!b8-p3_|= zn|$ieMIMKqcU?#3$0Xh9xF&jhn4*7+z{;IFgI$e1pss7_4(`IGO~74EyoE= za_2IZ81g0-^pw;-?qW=Q9bG6a8wV_l$Bt$tO~kJG{bHI?pAGfB%I>Goqv`@A4j0Ol ziy-ywPDztRFVN`uSnB_#H{1qaaHGaBGOWM&qFPyKNJh1=^p*5)s0rDggCHJz1hzQ3 z<-*J7nm{S^=)^GRJ{C&%pvJB(A$N+C`mP6)IXNX<{IoJ}h)>YCE>+vNSl?sLmal>N zwK>pXB2j(w8z)nNL^ahsM(D6R-j+Wwa@sl~X}UTR{Zgkq%%<{-V_p1Km>}3DkQb)p zeo;Vuj2|L7@lVm~G6T?7A5d1E z7!K6z+R|!Wi|UCxq24*(Ifgx@Lr+<0neD=ic|$Ie`$0UjzK-jV3E0L1u?(4+c@Lnf zE@Nzp8(niL&uh6@a({Ia@0l{3X{-v&+9LxeY8r>Q1ooq-yDn6)>hU&;7YdfmUi)z6 zexWk$C3;fB{dX21{C6Ln@2@qSKFXytI{(EZS-!oWa& zI8F1is7Z@?ulFz8x}gTP2!~g0`Kd#A5YWq?QP~gCrC0qp(ajlxxgu0@(0 z+?U*FlFzq5m04o*b^4?cEq9Nd1EwnQ=Fd%MUpcm|tl=o8uq9#HHGGYAW~Criz$WJe zm%LN2Q}bJl*ny4?3=A+f^WZMVx10>{5TEF6v)zl#4gmwJ>jhlB@hQ1oqpqrwylO14 zSU1JevXU2TSkuTTBY{F5wh^Ih$9Ck$hyu-ORKcKHUvjIB?ZW29=zP|#FEV~s%E~^; zKV+R=X{^UZoByhdH;&?<|CuMpfQ1gUpXoEv@PntVCG*)+v$SnM{6-=7s1R4DH5rZ9 zR_YWU`FNaqS^|(?Gc`y<|3XY~B~HYenbeT%SgIwur)JgN!r7OS+0F%};!xXpNphB4 z`pge~A85Ph*22nY+T!mx|B#VHKhzrdbo#AyCxIRV4gZUU&_<$9+4l$l>^8vNqSo$P z#;V_FEJ}pdesP!UL}{t)!s|wDUiEUo2w7=Bl8%qHx=B}YzTyJvO6$wG77<7w)80<@ zlbccTqhk&G)cB~6pQK=u#3xTX+xdQ?nW)C0xqpBEJY~)B1m&?{f2eI{-a#&Q%~D>d z4H!qy>dflM_18ClI0tOAG~gi`8Wx3*oRlPK0tAGA7zpttQ^gDn1YxOa?71Fd;Q(Tt z5L;Uu?{U1o;6ZZVpj-q)JeLls1OaMw%MhRNQ1@*|Gp$RU-^wshj+m;Hq_=i);2+Xf z{X~BbSqC;LBhR`gsVcpS^sQvHrNV~aIlu5QOSYwT4ks%YxV&a_B6m)%1Mej`e8suB zDrVq4L~ao_q}N1E^9!(WYc8IUF0u!XP4y0*s2 z`HR_#0-}p3w7nh0=+<0Ju#-G@dFz|=Jdl|3YDrmHnck^8*B32JurWg>8rq?x!IE2r z7ik>>1PZcGgcnhMC6f64-0kSuJ)mhh# z=nLmE4-dE76+u^LDyRASol8+hCAT8~rWQ+AJ45}|0}SslJXV%_rhkkH1?!N~9*8J3 zoN@FbJ_LerRg_1noZllUNy?Lliu5I#YHTwd=#oS3HlvH<{o-@oYNfroPL6_hmH>67 zAt6~MBPWO%H@Zxgc)M&Tn!e-U-ihi=ijJ|WJm$RvtP~LgZOns;&rn0hK3L0J(WrOH zwi%Hx+xSIDy5$GX8fJS~J}BCu(s9|B`4uJKa>cH?JeNcd{$lZKJEstxp6u#a=DWCs z0`ay93)T#O*$MO1aSkFNYL=7zf~(uFvijZ3E#c!(JujnUd0ZLwd*f!@xT7bi-?=2o zdWY$o=1%-$b6h^sc&YhO``IqI|MU@t>zqf`XOQj}>kdTD&XNw6VpFAL2Uwj%^{2Uz zh;4V2_!ms@Mkv9x#Lcz_2!>0dni;s->FBXT9b>~P# zf*#H7L}%UsKZE~8UUwMR_-?_nF-w#wITypLOcOldfL~rFU|;oo@br)p9ZQrIU0NZm z03Tgi2bWz{HRAdhNS-{_7nJmhSH~7LDRqt>^Zc*v#-|9OhP*Bf~g(h!JOi(Gz2IoS`~cb?y*cmRJF4B zSc*aD8zYyDBFZAhJ8o_uU}8d%z(*Y{l3BQcZlH$EyB<1BrTWvknIs?3Oif%C6D&Dp z!(+BTefYZ}cZm1be0U3NxvT7|8o9{#=+WxA`w|rP@mVC+9{UVi7h;ZctTmvRcdUmm zJ=}89*N-*vcN%ze4GFX?zFgN~I!B5(8h!c{k*{2-m^^MoeeTuy(7G_+JTAeVaYyS- zaANmZu^-Ck=H1Roo0A=G+tPK4B;01k)v#&7uZW*dPogK-#U&F;d~3v!vav(s3sN%G z%va7iuGTw@=+c;g312fE3-0)-P-l!HDE78;#f)VD@H167rB>LW_VZa+afed>mea6% znZ3wKhR@m>{cg;v*y{zH(Jg7AVE_HSl>t!Lyf@dA2U0r5H4cX(FLHTu*;midzbDuD zob~zTCfF`+6kc&_snOqAIc{i})iPIrn?1mVfXJPj*g!DPTx@XJ)v6^BXT3{5B8z~* z5>nOYx4BH%R6>jn0}<;^cX)<1Bb?_bIy8H;f9fP*ss`Yq(OB9xhZv`r@C+zxiHTWA z$aEic1}ZphH4{vZJTBG&#^5$=)eMBgEXBr+bMw~Nlx6 zCdYUb<9Q$yMwD@R49_ECHxm$|Q$(s6-c@aO$|{|t*TQ9Qhf2N;qOP+n=t<0-rETjK zJ5YBzz^TqPqOi1ZEB6>lf6KPuk1*in#4uxRFm3<&^gX`4j>o5uW|yuo% zi#X=vY-S4-T{*9MoE?_thJx#_UN41=SvEH(M?jTBChax?^;IHfRwOnPuFfnow7LSs z@x#2Lx*#Wrf(v&|VNe2Z*HzhQNP)RQFn$)6ron6VhM1nj6h_KMbD>;1$CDY$KQDSt>LAX6eL0 zA|w!)UIMe%`@?HqSXf->NN3HVOer5TSuoLB>JT+*$y7rf9P%VrIF(|lb|P#a6tNFO zGz!b8aC)zD=45;Q$|Bu^yrTJvd?!~0;Pk~CV?!SL@5x(e`rskp3e0D?S`Xpk2fBw+ z$2m@Rk7<5%o_>&Rv;E=WMSRf+cdni^XHoqIy{#CQmw<$l?P<2po`TBaB!n$sg5NS^ zN`6nuI}{X#Ric-bwHM4?jvy$o#t=47qA9ARYUk$8o8uKmCK$FqVUjeCXPP)1?-m)? z>)V=8k#WfCMDs6MsV^$tGgl%mG&H)%C1NUZGFxvbYcCxo!+C(avD6n!t2i-Ep2xb3 zG*q;y#(3f}v$$@^`5I_gV}gIn5we@;rH4Nhgm|BLPsZ^ANu*xpZq?JYs;LMi@immo zd12EKuW*1QHFKg4K)=oF^My?#{2JpvnTNbo*?X*11%KteTT>$AJQGGk@A(WHnKjLcx3=|BFwdurkFPaKeYn4Ho=@$~d+xt6 zXyTWaBdsNY;saaram))4{;BHcY+(Shykhd!tuVg!(Z9KAyca4zIyj7|8RUCoXlwzA zdI954sS_$Ha$l=DZJH1)tCBHL*MpbCK&@OzTh)2-fc@5(3EX|!aK7TGp+dXztF4Br ziQ$gXf;-YJ_1dKuewCYUb@ONr_6u5C7+uk&{`8qg%eM$R$d)d-Vz=h=#n(s8@ZRjw zjVYCF4%vrxEku8u_!IyL8}a?B&5th9ix%@3GjWO0vApHtM;1{XWkcC%#tKDj=a-Be zVPT3%;`#>%d8Y|(Qk~MBXA$v&)V^9vNx(df>yzC3J>^gfr9O@jLtk1^mK3<6+R=oz zVeM{`vMS%_gY9i4R*c6H@@*H6jPAOI7pv)S+}vu;Z+zTPF~fsSZ65EaHbUT4KHPZA zWnQr5hk?B^f%61=xLb7W-UU*`7urViyeG^Qo& z+oB^6K-5TG_-9iPzH3oPU^Y7z8c_7SR%ef9IkFIG;aW5@c-41VC7)qLZ+A=0Z)F)R zCBLUhA}7~q3^b~%Y=8JR#8a zoyzEorv4(WvCEsE(DoNyVsvnE*Z%E-&p^QffsejMs6|0Hy7^c1{lvpI;dv|LsQCOL2O>1U*iP}<6wXN%h2*vHs*Y6h%qdbl{A z=!5)3KSL$y7P$8z0O9=$T*8-@qbzSBC$Xg@=~x9cG1)it#a-3lkU&riGsaw^5Vn0t zF{97XTwiIMZeo&{dTxaSfsFTwRp9X>T=sPxR50zUVWTT=0-*_oCk(pg3`VTgQMx5} zb>vj(vqFZH6=oTHH02n2Y`Q9hD|lrmZD6I&k<0JGk4oZ}SE@fe+qkcP!881$tsdrG zc7%QLQJTB#7WETdonwawf)*+w@1SF;x{o5@BkK+k;%$<<@+o1ly1AU*jMCPZ7j0LZ zyWMZ>H!o_aT0A;}X=R1=jg7k%!nRIdME=f2Wd)PdA@8Yq-77YH>?Z?&mzfi6uMluw z54_m1i-=c3(@;@X4johR*vPqBSks#hA7AnVZ2Te3QU0Cc><_ZE)Rq(?nN#dKk`-b$7r%b`IqfMO@wtkByEofV== z>9fI3l1`foekD$!8zZ?2V5y3LzJ*k+UlZVBni45dMyW`1VNQHf#%Z0?t+>ch5R821 zjD#9*jwZ$2u^h(8qx&8V&@@{3`F9Ir1E;_nXa>*vUSvR(*b{!%zePMw#-iP#=~2bxRtB!o;EY zR0mJehrq^ zVpUjH@&F=H!b=0*i@}&7`=-@_VpFrkk&2l;n9UjxN?I*3|&O_EE z7BguYT|sfH2k}>YzH>LC=_(oipQa_L#TZW3RK$OKR@p8>=EaFV1XZ)dUR~cGe@NLU z%^r4(^s<>dCP>pbj;8~F&~lJZzPcoC+dYS1g3%c>(JnuKB)UBt~4AKJ!9>v(df$o6p>cQ#iQrE;=jEkZaY~k`OiIo1vqPl*hy4;;}ThR)<6HUF> z3?Uwn)i$6RZ@5dYp~t*dvFzQznoD_5rT1KjVX@h7R(w&3Or2h3ea7STBipE!GNpyS z0?8+n}#_?u5v#)8b@jK5(6n$ zp|KNZ{!ZO!wXs68Er>UAAm3Je*Eu3;AlT0nS>l1ps7%pq=?)vO?yo76l2nt|zrbZD zA)MBbZd@Qy1;-5i$rivQ1z4-e`ZwAmh$lcmga(54eguIGxrp7GT8cf zN9q6GWRZ>5!cy)fw_4A>JL4Zu_4*siKD%_Ei*kR)R zk1sxEp4H|Oyhhv^tNy=$`fmK%-RP~J_z@B$OdW)?1$4|OL?eHwJxJsek^<*y`2f|x zL`$@~R!48kBm=b0WUqn^z{xbJT^|EM^Pf%n^QKQmg_b$=zNY}$MMMN4@92|cZ*3pG z>C6b!i_IIemxmm_ueaXFG{AMi7X@Wg4T&8zRsYjv>x~3=i*Yo-GIHUy2)9f#W=J+x4k$U z@F=GYmQ`Q@I|xt&RXRm26HBwf&zALrS3)! zPHWn|?ir!GSi{2;pIlbY+y%U(u1ieEhQFYNIl3X9S`&|#0K=gdY~bTgYxpOhlgmjjmh&!yvJZ)G(n?$M(o@R2khZbD? zEXlcLU+}GF=Of3q1BV*1SI`XcP=>nY=RMub4;$d0C+xT}$rQ@c6Nyf}KN7i--4Z6> zy;5V-ua@N|(dnRRc#{Axm&wdrO*bW|+JYW;v$(Fj5lZ{8%k{d56U~iU{R1##IxF1a z=6cmY#b5{WycI@bT zL!G(qJ6JJb!EpG6V#BfgZ+JyEf*H&3FbMN*<(AHElWxWKna_+tkKfytpRl5_KTZ@> zbbgykqKXM{VHMFPyQOdQtE@!%g@hWfhWZttRO|)YkP)Dp(@cSED9e{*626nrbon;m zL~FiZEYFc0DzezUGL?4Ox#-2N;8)^5W+yE-LZy2|UnS{R%X|e44~@4w2G|Eos%+@y z=?+a{heub-o6Y1Bxv_zo*-BEbc#HO#gkzr4^1sstDbsNxgE46*roY#4GhW;cxuPs3 z)i`%kn5~Cpwv$07736N(Hw6s+Gv|u(i#J5dBB@McKlfIqz~;1*#AcM(vksYKiC!Lx zSjA7i=$Mqh1z$J-cM3w64g^vg)8;dq8VkGu8OFp9e&x-n1Q4@MgE}+m_8Mecbr^rl z`O%geUwvsBtoqyG2+mB!=9Wwkz7VxRI0iPV0-4uvGTtiNx`y)R-0h<<^zCt@dp#qr zrvGdb`_)sNorwTP7^BJhItp}IVcCl0&LvT2Yw%v9IJPq$b7wnr8LDt;dQA?%|GfR)~hwRgYvPM~g| zJZws!8n|uvA^k#w)gnIadLU0ag6oVh$B}S&Wb#2|ICnr@2@qg+ZjbvU%ps26o!M6hl_GgF1aye4>W$!DM7g{Ciw!mWswW!Ue^RYoT<0fHPRtneU=767fGGQw@F( zB<^0=b#bb?0%{B~=48OmF~h&o2yL{}gL6Z6x*w15&#jou#u~hdR&Mn>q)WJG9+BQy zO=2??+$uHC3a^kAYo?1?U677wTBC={nAr(60D0kdO>1Iamp>tJ$K5e|-Ss0+>ghtx zhl+g8Xy+wWa{2d>G0#^4{27^)4&IUQF$*c@fyw2Pz zB0B=!f;his!wvT0Tvnoc3TnIJ)eqAiA0{GGzZ|w15WgnSuA3=zW{aqBB13vVEgvY( z-;AnhnCKqxQb6!C(8$fSQ6La!x{ftD@ldq(!V0Kl^6W~Q#u0YmaiRx`km?4hT zAAL%w&kd2qL`$tSL{aD#5C-u9cgJ*o)d`_u0xv(ghlBMu{ z-p&*L$%b!A%^rT41j&5sFEMEIz%kw?VZ6V@&RZ`W7n z`nzPAiW=Uv&V(YuGt@u&E}So;9ba~(6Zv_kHV*$t8WKdsu-c$#3-r;q#_#3OM@K+9}PY|hUTTNH6!wq-vyZ24o+(gWu>N^vF zZ~I=%gS9Q5D5@^uj)b?IrwXMU^ky`=d$kH3qh^-~Iu6nwl{?_%R`N#d9z={5S=_Ha zIe)H_+Feu+Y#gtf&vRtmQG3SDTaMH_^Uqb61}Y7wU#$$lEt{2S_{`#L75bhX=c5g4 zeEOrg3jne2-nPEyE9dt&d)R1Cjz7y${z_~pa77lZh2z^>wB?Q;H1Vp?y0>ceckiaU z$ZQ@+T(-ig@|GQ0Gn~mM2ZwX0X$czjT6-GGD`o+BRI2CwJj7 zr7qSv?QTyxJGb-*99)kuo(S9ThQ)Mv$+85&Vvh~k?xI>MIrdT(c9G|)+LrQV+tw`M zjD>p^GAf1htQQ7n1bwRjrPJ|P3Hh2F&6|-sm)%=Zs)8sG*c)gkh3{w;mG0+7abttZG{^8&4z-eeP{TJ z3|MA-N|5a}Wy`-mTzetU5%3y!^~RPl;2VP)w{Sd;=A`l;m6qw(4l@hd528)uM)#v$ zW}E%5Cpe4DfK6@~4V5I#@V7f>me?od6Y zu&v`$u8@rv+Hd5ej&F${#A@t8!RYSv!MUw8MF@rH_RajB?^cyTIwf_II}zJ2+45Wv#i8;$pYes3J>dBK_N~d|v4zQ|fF~%?>km(9pq??L*(pQ}Qqf>N@s?6hvIPN9Hj~4-}<=EkD zIsaZ9Sf53gko2-CudQEc$zROB1es$WquZtnPNd5Mw(1!g?Jgy_IGpf~pCgdSTgIAE%`x{jcrdt@7)Zlb$ zEh2o&Lgr<18lsp;SBu7hU~*#d!-R>RV8R(m7Str7m+a#Kf=W!|$=RY0H5ND@D{67V zN@Z&CE2b)qfyV%I!W*%$D+mFeA>HLcTj9>j=uuGblQXgXi`A2Jg4b48s~y#bfq22}=i^g+S;ZF7K z&uCd8<=OT`@V|qe#qg|@)mQl7jcFzWLBE&DUiuIExR<`V&7osQ7#ZNk%qRS;q z4PrC`QhJ=?eo2CO&dyqYd}PMsP;Xx}9xUQ^3OxjP%H#X-J-K!gv zkUU}z_0_`4I6BFCp3%%lJ+7ZUF0%SLGWvR>Ua{SSS zHjpN5T=?g#G!T?_ymt&1PU)Tu=u!(Ncp+G%?KZZGsO{#119!hP$cxWhF?3DEnJ} z=$f#4v*;Wfn9W3X-l9{LbOFrZIdaObT`^w_>b!L@TAsl{OKLRAuybb%kdLog_07`3 z$y9!Ij&0g;ZRw2Rb-K4A)s~)mfVOJa_mb=LvhQR|{WCfh$`G~D<|I|f(cQA%^ z+gc1b?ty)zdldp#oeLSS;lEUfB(j7s zwk#1t)*&?f-Z1+5-T&sj`_4P}-ZS^!^X@qx9VKNPvP){KAl@Uodn>D-3_$J~tOImlHh(Bpmk-F-_BPW*?T>2v2k04p$0Y-#r&X+nTjLc^?R6*j zOi#!6BQJRLv<>{~&92~=DI5!@HGP7hlgZYb4cwdQzk050aQ}QKQaN}{IlStdpsaMw znyFM-A|kkj+K1jkZI6@rB|I&l8z-93V9z$#C|-u;0{!-EYH-xBqX{2P&$MO>7EuN3 zyLO%IvC+d&Hhp2V{hZ&t{WxS(v0funXW6`Am%g{(G3^xg`i_2fH+cUiU z3J-VS2-X}ce~EIAt}5qhl>se9aihOyP;i3G%1m&&VJlq;1hb!O3&>-(FbYgcE$VP&>5wSG@v&J=>K5(C z8a-c??g7+iV?EmQ>sTa?9)x7sYFk+V zfF9YHKh53npbzfipfM^zG!O=Mwj!dTE?Pe(p+~iasjE%LwTmAwpXlS|rIi`jTVF0J zkLm5Kq#OpJ&od#?xx(-;1GV&zw$>^27r3+*HLVCAfR_Tv{spQ zu>4HroVnIdzwQdAyIJZEKA)=TgN?S@`uBmXH>C*QOT=M{`s8Sut%Y6uU}~E#>FgYRZ7;UTmbWwm1Go!#zI$ z7&C}+H%hl+Z0_OyK-4jWpb8HJzgK|5^=fh+=To+^ruu$;3l3Wn};00%a{g5Irt}K*qBznopS+wnzEp=E571RsreS)(WF=#^}5UmnRXOkG;@8 z2Y5O!(wHs8=w>ae%=ZS2HYlEQ%IYb?e<(s=JkVcR-fP?w47Xwq`l#EV>|r08x;blZ zIs@4Z5y4ux60F2Z;v3W;jkiDhm0{ecvi4s4awL7ls?X2KYDq80K zn2fXBEyNXk@mM*_CN+Y3=rUi4Ozd zS@WHVeO!>Ur^pz8Z@s4m#r0itKLh>%3rsCjyQ03)N;u=Kc0bK=hyA6dKLrb)pPrul z0JX-GFJ=060QSGiatS-V^aNEUH(F{YLZ&qM>k;ob1-G#&6n27BrJfuN_W4n~KqxFrHcC&wd)? zHnf`=u$_9=fAF_llkvtSAJboL6{y+!NU3+IfE4`IvpOX`$xQJx=i`cjd|sNpQ<55` zY)rlCgeJyqkmqM|Ftx8M*OIWY!y2o#1 zc;xAIR}#2m{85fmX;nGhz@dVhm^gG_diy6TN^tq6y~$)~Re+4xcGAww&8EsAY!$og z%AT@p=dQOY1zgY9>n_`Q;}o~NPDhKR@>bqzAgL|D#ZI{^ch+1+QU=SPbWL(&o!^hk z&oC%;`mOAeDD<8cmJZ7G7&zDWb^P(p%fX|sV_O63N56OpX32uplYb^`em<6#@H_SF zr7~u=3yU}6V9(0KHY&HP>GOYNhnXasu$imAnG+6P86|R0P@heW2)uSmQlRmVvzL~Wv$Hpz{GX5C zf$iW!N5?8tn8WLoe5h`4efl4IlNY03aKf!+y;#B`WG4ffU7O#XNN(H6XN@Aa6q0tn zV)}?9GC3?zYkttCB{3F(70Iu2BBPeBH5A;sfD!&y`>>E}uCtMC%MRWl-JhX-XJn-I zxwW^=`JFm%2|KYiqfzX;u@zR4(hHAhM;!(wBqaJ5s(Wg3q9?9%bf>M`)((ceFApHd z@T1R211Tu*@)P-<7hJ2zI(EJI`%>eKOW4i2G*4`iAJ0eSh#EJzUoJeHjq63 z?@dG?NNh$J{oOpAj3+O+w6ucTp2+6NF$Izj^TqEZs#Z%<+uu&5dicofx9k|@l1Cce zr!aw9x;l_M@295bV3M2s?F=V{xn0V zY~$yntj}(72(egufSIB{6hEc06I8qL)OJ@L`Z0iNIAhYKK2A4$P#I* zsrZWlUgA{$J~<=R+0@eZdy&ZdieWc5tvb7;*_p6F7q@@ooP{rs-#P!Z{47~CEkQvP zdRMIH3v^g$C8z`#0o07di%Y;? zj`YB#w@vL?9c6#+EV=v|UN<0e!Sn%42*1Vnba$ryOU2*yxVS5L5Axun6V^a+CcArW)EiG*! zn{1<_;$LJINDDZB;txUaZ{Ws%CvJu|06VGy02+3CZ=**;Ma8dwK&a_2XRoJbSN@%C zrSiJYZo1#5f3<1dB5s7CRVM+`z_`c;bXCl7GM(w{;v8pl47r3-fuYf0(UX}>*`SIb zNR~ybcylyBPjEMjX>zh+%dg#rCC$g48o?vR@C0}D!(MRpktyww{|4r!=nQc zI#IxVfOJ)HhD5FlF1kuIB8J%h=?!A+c*R0-d5sEQZf9f3%1MCGr0`_Zf9V+3WG5WE{L)a zXr7}ul&3^dX|8Tnk;6^b0WDmu0)v5ka;EPBIYw#zfin$*-OVJWKl8;M3@XnJbPC|z z%J~0YC6iO#K==n*00*7sO##N`Q%49e5cEo%x3+p!AmZOBI(Wp=9Y5ea!)tpj^3-F* zPw<(y<8`j%_z@#dwVKwy;<=U&#OGReJM#e`Ev*p58C1Vaxy+%KF#mlkUtgJJJ^|ry zNlz~Kk*vM>EVPTlS`P-6xE`V2*f{^;=HQt&x zycvOz$}2<16QpgkP9XIvxpq7Pj@9}{3}U73nQirLzcHazd@NTS{FVtFufa4*0qgis28&#Vf3curq)rHC|wt^FN` zJ=j)4X9*;*jp-j4q%oIVWm9xm;QlLuoPBj6gi2DGbcc$&>R@bm z@x}pr!vzEKr-K0i8)Q?)O-gx$?@$BeMF`Eo)19x2E^|~l23~CgCcaDzlfIl`MEBXl zN-$F{r;Mc*JM8L39jNf9@wWCm{&QU%MQs2Fs+3dvd;{$H->Nd%WqH?(br|CQLG?ez zB7l7VNa{6-UTQ4`m9=r)+h$2DNDh{5o8f0PWdK+8GDcEz5rDmyxUWN$-z|5m_y!kzvX+r9q*<=RE@Um1|roA;D z+xno}Tbh;Z<90ZB!LF^B4lF|rc0KpznR2eSV%4Y8BCg};{Jf})DRnp1_0=e;96W>9q4WhKvAx@Db>jfzd zAy|(~Ycbd$n)6ZZv-x7grR+#{@JbRd(V~uShoLlyopSV(la&batc{7ZfeLu_?#*Jc z%LBk}P3Ohu%yGFQNqCx{Hrvp?)1V>-nIyx!W<#1~K}bg-fta60`ZTmlIySkv00yNZ z?dX+fLxHqr!C54PjLIhlplA&5@tooRKjbM0pvwYdgSh_RDh^^)9af;1RbgZR%u z5Pl)_g1`w7si>-`t%lz_@EZ@WC^0Yq5DbyyV!&Lg4fjHbt|h5T0)uWHUha4m04Iuh zb&BZG9hP7*fU|RT3kif7lCHomgfV{kae?UAlL|nN&AE|EaqJ<0F8cs(NA$BvRgeIH z7CS9}>`h64GQ02o?@c_w)_U;xLyG_eY0&Lhvq1oF3rlyb)pe2aIex;&UJde}Y<&A@ zdCmRzbyO1O!G2zK^+a)KWMl5>)2ILIEH%!&6`>pGcp!A)s9C|HXLWzi(Fn5sR}1y= z72}@t7P{iUrb6T5xmjY5cj3GM1ff}f>q002P<1^@s6%hNON0000PbVXQnQ*UN; zcVTj606}DLVr3vnZDD6+Qe|Oed2z{QJOBU-DoI2^RCwC#o!fESMihpZ9K9P4Nj#H0 zgsQ-F1)(YsRe{I~WL6-t0!kGKs(?}jf-4YGf$4{2CYJ}K0tH7oh+t?J*j)gN1@M0} z99gu;y&ar?&t4}2G|G2B{J2biM1TMJdxF~NhUe#JR004EFhvzKDh{jk$3A^MrvDC5 zBLDyh1jxkUmVcc?Bme*q2v8IU0g(UzKp=oh93T<^00;!cK`9Op2><{D0#pK#002NB z#>C%${vM`3)({B*00aU+Bme-TVbWE?>?G%&)kkc*!A)~MB7@R6Nz;m9g3W`CasUiN zARavvi9`B2vvu4M2?zuL5Qt%mL@mb+k$^w|0D)*$D9E9%AQAuq0f0YvF-e^|N1Egf zJ*pRqY@XQB+mwgOvNlMICa&i&M*si>LM;;4p4HDSL;?T+f$&2lHU>`BrAT~&NB{uF z#>B@=8IIw*BIGEi?ebtwq9&Mw0ARoZ!A_Mf-nsBBTQ{lWzK2LaAOL_sfG#5=hy(-z zfZ+*5>IfI9V~bF|5DA|JVltVG(f(%X4|)asI?(%VKd>S6j*X9*y?4Iy=@1! z_T<{urVSZl*-;q~iE@#M23Ry|^Q)0GV<7xnlAWQ-7uno3zoL>(%8h{!2-4S+s6H|$ zs<8QhI~hwyb+q82pT5}IBhMo_q4p4y<~d3jZc^8s?t_qYnAMZw_%Qcmvf&ch*f#af zLWAJ~ABa?A``jC+@}5fUeNJQ3yfM+O^!}wN*?^mV=cL3g9t-8) zmJPEVHQ?Y@ntzTR!uE9+`L^04mmd<2D@A#h!oTBFY|EPomepX2N$=|OB#tdy!85d;6T^8hcNFn2M0U!NYbLh7zcE@xmWv+Vhy&S#juWH5;hyxhaI<1h)@hk}+GbQ2o31+CRsvxo4jqJVLlK8Q z)m`tLW(_`T^w@o~y=4pExso{7$Ywa1gvmvu%+FIXop&BL-Mwan*u6kN93T!QeC?u_ z1C;ht#QJpN5@bYkyALnzEQU-`mP;-rQc3C<*CJ=FL< zlePF-a|C2RJi&P>`R{=3amDFp%dPJ$YWnR&n&(^2E>CM&H1JNoJZKP#-;7CG8i0E%< z^Vqe;YNoC^PxJkY;{SpY-{R$d9gb9Yl6E_|TK0Za;jm4Hdg_P+HQZkKwbZQcFqw(i z`7RE0>_TGL`;Bey&gc-EbCRfDyk3T!Ez8Xfjh$+glcI@#EY2$Gl9`1MQ7t3wxh|W!cD^<&6x2)3j@ZbC%T8G| zWRCTMBZ;JPWFtS{| zFC=vy)yPXC6Sy>;Gx7H9B^smu?DITJb{L-SJVH(+Or7#&K|pDe`^xY~Y5tMA`gD>_c>Ogx)X2K{K+7+W2C=Jn1059a>tk^9?KNz3Jtq z%ApuOP_F1?XwzBb<1hu+&z^^TDB7vKh(~efNK#QZs{Iypn(sTEh@6L-Z#l0Yntncb zC0DUCk=0L^oz%ql<-}8n1H{1t?j-Nss_vBFhy6*&&j4ym$YfDeAQ_VJg?-L0U+RnM zQ#C(OausT%Q8!nL2$P~L?-8JKU z$#I=Z>XLe)7wmlKaJ-+{+07JR)%J45Gj?XRhEpVt(&kn(<-vBmFJ&PSvrDeiSiIgP zPW&R|lhG!}%u`SNi+DR%Gw0!)qS(wz+L0oOpvlOLBh`&0>fCV@7~@Hl3qK0}UfRX3&S*lc1VxIEPK zu@Je~l(V&S$hclkB|eV?>>~~pealqnEipARmJ#)Q6LxGd#G$deGIQ+ÒNYSsW?LQr02mUb7nK+eH@UpK*#))A1G)o4OaQbPL0Co-L7kpAPm+fo z)eV*BiA53s03Z+^h{V>jI=Y2O0072__FcG+hnq~&a>b_RWhTH87-9mzu|RYr66c=P z*Nx9Nhye%$0G$bhYmoo|0s%mGOie%Fa!vvO06>of0wMtb01$}AMFQ0g001Kp2n&(G zjdTD2&?6>Id Date: Thu, 18 Mar 2021 21:06:56 +0000 Subject: [PATCH 1272/1580] Drop hpack, make it easier to use cabal-install (#3933) Stack offers a relatively poor developer experience on this repository right now. The main issue is that build products are invalidated far more often than they should be. cabal-install is better at this, but using cabal-install together with hpack is a bit awkward. Additionally, hpack isn't really pulling its weight these days. Current versions of stack recommend that you check your generated cabal file in, which is a huge pain as you have to explain to contributors to please leave the cabal file alone and edit package.yaml instead (the comment saying the file is auto-generated is quite easy to miss). Current versions of Cabal also solve the issues which made hpack appealing in the first place, namely: - common stanzas mean you don't have to repeat yourself for things like -Wall or dependencies - tests are run from inside a source distribution by default, which means that if you forget to include something in extra-source-files you find out when you run the tests locally, rather than having to wait for CI to fail - the globbing syntax is slightly more powerful (admittedly not quite as powerful as hpack's, but you can use globs like tests/**/*.purs now, which gets us close enough to hpack that the difference is basically negligible). We do still need to manually maintain exposed-modules lists, but I am happy to take that in exchange for the build tool not invalidating our build products all the time. This PR drops hpack in favour of manually-maintained Cabal files, so that it's easier to use cabal-install when working on the compiler. Stack is still the only officially supported build tool though - the CI, contributing, and installation docs all still use Stack. Stack also works a little better now than it used to, because I think one of the causes of unnecessary rebuilds was us specifying optimization flags in the Cabal file. (Newer versions of Cabal warn you not to do this, so I think this might be a known issue). To ensure that release builds are built with -O2, I've updated the stack.yaml file to specify that -O2 should be used. --- .gitignore | 1 - CONTRIBUTING.md | 4 +- default-extensions.yaml | 31 -- lib/purescript-ast/.gitignore | 1 - lib/purescript-ast/default-extensions.yaml | 31 -- lib/purescript-ast/package.yaml | 41 --- lib/purescript-ast/purescript-ast.cabal | 100 +++++ lib/purescript-cst/.gitignore | 1 - lib/purescript-cst/default-extensions.yaml | 31 -- lib/purescript-cst/package.yaml | 58 --- lib/purescript-cst/purescript-cst.cabal | 108 ++++++ package.yaml | 174 --------- purescript.cabal | 405 +++++++++++++++++++++ stack.yaml | 5 +- 14 files changed, 619 insertions(+), 372 deletions(-) delete mode 100644 default-extensions.yaml delete mode 100644 lib/purescript-ast/.gitignore delete mode 100644 lib/purescript-ast/default-extensions.yaml delete mode 100644 lib/purescript-ast/package.yaml create mode 100644 lib/purescript-ast/purescript-ast.cabal delete mode 100644 lib/purescript-cst/.gitignore delete mode 100644 lib/purescript-cst/default-extensions.yaml delete mode 100644 lib/purescript-cst/package.yaml create mode 100644 lib/purescript-cst/purescript-cst.cabal delete mode 100644 package.yaml create mode 100644 purescript.cabal diff --git a/.gitignore b/.gitignore index 82c6949369..4cd805aa1b 100644 --- a/.gitignore +++ b/.gitignore @@ -24,7 +24,6 @@ core-tests/full-core-docs.md tests/support/package-lock.json .psc-ide-port .psc-package/ -purescript.cabal tags TAGS diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index a89f39e3f4..67be71a265 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -24,8 +24,8 @@ If you would like to contribute, please consider the issues in the current miles When submitting a pull request, please follow the following guidelines: - Add at least a test to `tests/purs/passing/` and possibly to `tests/purs/failing/`. -- Build the binaries and libs with `stack build` -- Make sure that all test suites are passing. Run the test suites with `stack test`. +- Build the binaries and libraries with `stack build --fast`. The `--fast` flag is recommended but not required; it disables optimizations, which can speed things up quite a bit. +- Make sure that all test suites are passing. Run the test suites with `stack test --fast`. - Please try to keep changes small and isolated: smaller pull requests which only address one issue are much easier to review. - For any code change, please append a copyright and licensing notice to the [CONTRIBUTORS.md](CONTRIBUTORS.md) file if your name is not in there already. diff --git a/default-extensions.yaml b/default-extensions.yaml deleted file mode 100644 index abfa1e8bc8..0000000000 --- a/default-extensions.yaml +++ /dev/null @@ -1,31 +0,0 @@ -# This file should be kept in sync with the other default-extensions.yaml files in this repository. The files are located at: -# - default-extensions.yaml (the repository root), -# - lib/purescript-ast/default-extensions.yaml, -# - lib/purescript-cst/default-extensions.yaml -- BangPatterns -- ConstraintKinds -- DataKinds -- DefaultSignatures -- DeriveFunctor -- DeriveFoldable -- DeriveTraversable -- DeriveGeneric -- DerivingStrategies -- EmptyDataDecls -- FlexibleContexts -- FlexibleInstances -- GeneralizedNewtypeDeriving -- KindSignatures -- LambdaCase -- MultiParamTypeClasses -- NamedFieldPuns -- NoImplicitPrelude -- PatternGuards -- PatternSynonyms -- RankNTypes -- RecordWildCards -- OverloadedStrings -- ScopedTypeVariables -- TupleSections -- TypeFamilies -- ViewPatterns diff --git a/lib/purescript-ast/.gitignore b/lib/purescript-ast/.gitignore deleted file mode 100644 index e0c0575d9f..0000000000 --- a/lib/purescript-ast/.gitignore +++ /dev/null @@ -1 +0,0 @@ -purescript-ast.cabal diff --git a/lib/purescript-ast/default-extensions.yaml b/lib/purescript-ast/default-extensions.yaml deleted file mode 100644 index abfa1e8bc8..0000000000 --- a/lib/purescript-ast/default-extensions.yaml +++ /dev/null @@ -1,31 +0,0 @@ -# This file should be kept in sync with the other default-extensions.yaml files in this repository. The files are located at: -# - default-extensions.yaml (the repository root), -# - lib/purescript-ast/default-extensions.yaml, -# - lib/purescript-cst/default-extensions.yaml -- BangPatterns -- ConstraintKinds -- DataKinds -- DefaultSignatures -- DeriveFunctor -- DeriveFoldable -- DeriveTraversable -- DeriveGeneric -- DerivingStrategies -- EmptyDataDecls -- FlexibleContexts -- FlexibleInstances -- GeneralizedNewtypeDeriving -- KindSignatures -- LambdaCase -- MultiParamTypeClasses -- NamedFieldPuns -- NoImplicitPrelude -- PatternGuards -- PatternSynonyms -- RankNTypes -- RecordWildCards -- OverloadedStrings -- ScopedTypeVariables -- TupleSections -- TypeFamilies -- ViewPatterns diff --git a/lib/purescript-ast/package.yaml b/lib/purescript-ast/package.yaml deleted file mode 100644 index d9405c36c2..0000000000 --- a/lib/purescript-ast/package.yaml +++ /dev/null @@ -1,41 +0,0 @@ -name: purescript-ast -version: '0.1.0.0' -synopsis: PureScript Programming Language Abstract Syntax Tree -description: Defines the underlying syntax of the PureScript Programming Language. -category: Language -author: Phil Freeman -maintainer: > - Gary Burgess , - Hardy Jones , - Harry Garrood , - Christoph Hegemann , - Liam Goodacre , - Nathan Faubion -copyright: (c) 2013-17 Phil Freeman, (c) 2014-19 Gary Burgess, (c) other contributors (see CONTRIBUTORS.md) -license: BSD3 -github: purescript/purescript -homepage: http://www.purescript.org/ -extra-source-files: - - README.md -dependencies: - - aeson >=1.0 && <1.5 - - base >=4.11 && <4.13 - - base-compat >=0.6.0 - - bytestring - - containers - - deepseq - - filepath - - microlens >=0.4.10 && <0.5 - - mtl >=2.1.0 && <2.3.0 - - protolude >=0.1.6 && <0.2.4 - - scientific >=0.3.4.9 && <0.4 - - serialise - - text - - vector - -library: - source-dirs: src - ghc-options: -Wall -O2 - default-extensions: !include "default-extensions.yaml" - -stability: experimental diff --git a/lib/purescript-ast/purescript-ast.cabal b/lib/purescript-ast/purescript-ast.cabal new file mode 100644 index 0000000000..55e9dd470d --- /dev/null +++ b/lib/purescript-ast/purescript-ast.cabal @@ -0,0 +1,100 @@ +cabal-version: 2.4 + +name: purescript-ast +version: 0.1.0.0 +synopsis: PureScript Programming Language Abstract Syntax Tree +description: Defines the underlying syntax of the PureScript Programming Language. +category: Language +stability: experimental +homepage: https://www.purescript.org/ +bug-reports: https://github.com/purescript/purescript/issues +author: Phil Freeman +maintainer: Gary Burgess , Hardy Jones , Harry Garrood , Christoph Hegemann , Liam Goodacre , Nathan Faubion + +copyright: (c) 2013-17 Phil Freeman, (c) 2014-19 Gary Burgess, (c) other contributors (see CONTRIBUTORS.md) +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/purescript/purescript + +common defaults + ghc-options: -Wall + default-language: Haskell2010 + default-extensions: + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFunctor + DeriveFoldable + DeriveTraversable + DeriveGeneric + DerivingStrategies + EmptyDataDecls + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + KindSignatures + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + NoImplicitPrelude + PatternGuards + PatternSynonyms + RankNTypes + RecordWildCards + OverloadedStrings + ScopedTypeVariables + TupleSections + TypeFamilies + ViewPatterns + build-depends: + aeson >=1.0 && <1.5, + base >=4.11 && <4.13, + base-compat >=0.6.0, + bytestring >=0.10.8.2 && <0.11, + containers >=0.6.0.1 && <0.7, + deepseq >=1.4.4.0 && <1.5, + filepath >=1.4.2.1 && <1.5, + microlens >=0.4.10 && <0.5, + mtl >=2.1.0 && <2.3.0, + protolude >=0.1.6 && <0.2.4, + scientific >=0.3.4.9 && <0.4, + serialise >=0.2.2.0 && <0.3, + text >=1.2.3.1 && <1.3, + vector >=0.12.0.3 && <0.13 + +library + import: defaults + hs-source-dirs: src + exposed-modules: + Control.Monad.Supply + Control.Monad.Supply.Class + Language.PureScript.AST + Language.PureScript.AST.Binders + Language.PureScript.AST.Declarations + Language.PureScript.AST.Exported + Language.PureScript.AST.Literals + Language.PureScript.AST.Operators + Language.PureScript.AST.SourcePos + Language.PureScript.AST.Traversals + Language.PureScript.Comments + Language.PureScript.Constants.Prim + Language.PureScript.Crash + Language.PureScript.Environment + Language.PureScript.Label + Language.PureScript.Names + Language.PureScript.PSString + Language.PureScript.Roles + Language.PureScript.Traversals + Language.PureScript.TypeClassDictionaries + Language.PureScript.Types + other-modules: + Paths_purescript_ast + autogen-modules: + Paths_purescript_ast diff --git a/lib/purescript-cst/.gitignore b/lib/purescript-cst/.gitignore deleted file mode 100644 index aaa2fe2fd1..0000000000 --- a/lib/purescript-cst/.gitignore +++ /dev/null @@ -1 +0,0 @@ -purescript-cst.cabal diff --git a/lib/purescript-cst/default-extensions.yaml b/lib/purescript-cst/default-extensions.yaml deleted file mode 100644 index abfa1e8bc8..0000000000 --- a/lib/purescript-cst/default-extensions.yaml +++ /dev/null @@ -1,31 +0,0 @@ -# This file should be kept in sync with the other default-extensions.yaml files in this repository. The files are located at: -# - default-extensions.yaml (the repository root), -# - lib/purescript-ast/default-extensions.yaml, -# - lib/purescript-cst/default-extensions.yaml -- BangPatterns -- ConstraintKinds -- DataKinds -- DefaultSignatures -- DeriveFunctor -- DeriveFoldable -- DeriveTraversable -- DeriveGeneric -- DerivingStrategies -- EmptyDataDecls -- FlexibleContexts -- FlexibleInstances -- GeneralizedNewtypeDeriving -- KindSignatures -- LambdaCase -- MultiParamTypeClasses -- NamedFieldPuns -- NoImplicitPrelude -- PatternGuards -- PatternSynonyms -- RankNTypes -- RecordWildCards -- OverloadedStrings -- ScopedTypeVariables -- TupleSections -- TypeFamilies -- ViewPatterns diff --git a/lib/purescript-cst/package.yaml b/lib/purescript-cst/package.yaml deleted file mode 100644 index 726dd7b38c..0000000000 --- a/lib/purescript-cst/package.yaml +++ /dev/null @@ -1,58 +0,0 @@ -name: purescript-cst -version: '0.1.0.0' -synopsis: PureScript Programming Language Concrete Syntax Tree -description: The surface syntax of the PureScript Programming Language. -category: Language -author: Phil Freeman -maintainer: > - Gary Burgess , - Hardy Jones , - Harry Garrood , - Christoph Hegemann , - Liam Goodacre , - Nathan Faubion -copyright: (c) 2013-17 Phil Freeman, (c) 2014-19 Gary Burgess, (c) other contributors (see CONTRIBUTORS.md) -license: BSD3 -github: purescript/purescript -homepage: http://www.purescript.org/ -extra-source-files: - - tests/purs/layout/*.out - - tests/purs/layout/*.purs - - README.md -dependencies: - - array - - base >=4.11 && <4.13 - - containers - - dlist - - purescript-ast - - scientific >=0.3.4.9 && <0.4 - - semigroups >=0.16.2 && <0.19 - - text -build-tools: - - happy ==1.19.9 - -library: - source-dirs: src - ghc-options: -Wall -O2 - default-extensions: !include "default-extensions.yaml" - other-modules: Data.Text.PureScript - -tests: - tests: - main: Main.hs - source-dirs: tests - ghc-options: -Wall - dependencies: - - base-compat >=0.6.0 - - bytestring - - filepath - - purescript-cst - - tasty - - tasty-golden - - tasty-quickcheck - default-extensions: - - NoImplicitPrelude - - LambdaCase - - OverloadedStrings - -stability: experimental diff --git a/lib/purescript-cst/purescript-cst.cabal b/lib/purescript-cst/purescript-cst.cabal new file mode 100644 index 0000000000..74a2e61bb4 --- /dev/null +++ b/lib/purescript-cst/purescript-cst.cabal @@ -0,0 +1,108 @@ +cabal-version: 2.4 + +name: purescript-cst +version: 0.1.0.0 +synopsis: PureScript Programming Language Concrete Syntax Tree +description: The surface syntax of the PureScript Programming Language. +category: Language +stability: experimental +homepage: http://www.purescript.org/ +bug-reports: https://github.com/purescript/purescript/issues +author: Phil Freeman +maintainer: Gary Burgess , Hardy Jones , Harry Garrood , Christoph Hegemann , Liam Goodacre , Nathan Faubion + +copyright: (c) 2013-17 Phil Freeman, (c) 2014-19 Gary Burgess, (c) other contributors (see CONTRIBUTORS.md) +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + tests/purs/**/*.out + tests/purs/**/*.purs + README.md + +source-repository head + type: git + location: https://github.com/purescript/purescript + +common defaults + ghc-options: -Wall + default-language: Haskell2010 + default-extensions: + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFunctor + DeriveFoldable + DeriveTraversable + DeriveGeneric + DerivingStrategies + EmptyDataDecls + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + KindSignatures + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + NoImplicitPrelude + PatternGuards + PatternSynonyms + RankNTypes + RecordWildCards + OverloadedStrings + ScopedTypeVariables + TupleSections + TypeFamilies + ViewPatterns + build-depends: + array >=0.5.3.0 && <0.6, + base >=4.11 && <4.13, + containers >=0.6.0.1 && <0.7, + dlist >=0.8.0.6 && <0.9, + purescript-ast ==0.1.0.0, + scientific >=0.3.4.9 && <0.4, + semigroups >=0.16.2 && <0.19, + text >=1.2.3.1 && <1.3 + build-tool-depends: + happy:happy ==1.19.9 + +library + import: defaults + hs-source-dirs: src + exposed-modules: + Language.PureScript.CST.Convert + Language.PureScript.CST.Errors + Language.PureScript.CST.Flatten + Language.PureScript.CST.Layout + Language.PureScript.CST.Lexer + Language.PureScript.CST.Monad + Language.PureScript.CST.Parser + Language.PureScript.CST.Positions + Language.PureScript.CST.Print + Language.PureScript.CST.Traversals + Language.PureScript.CST.Traversals.Type + Language.PureScript.CST.Types + Language.PureScript.CST.Utils + other-modules: + Data.Text.PureScript + Paths_purescript_cst + autogen-modules: + Paths_purescript_cst + +test-suite tests + import: defaults + hs-source-dirs: tests + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + TestCst + Paths_purescript_cst + build-depends: + base-compat, + purescript-cst, + bytestring, + filepath, + tasty, + tasty-golden, + tasty-quickcheck diff --git a/package.yaml b/package.yaml deleted file mode 100644 index 9cbd5facd3..0000000000 --- a/package.yaml +++ /dev/null @@ -1,174 +0,0 @@ -name: purescript -version: '0.14.0' # note: when updating the prerelease identifier, update it in app/Version.hs too! -synopsis: PureScript Programming Language Compiler -description: A small strongly, statically typed programming language with expressive - types, inspired by Haskell and compiling to JavaScript. -category: Language -author: Phil Freeman -maintainer: > - Gary Burgess , - Hardy Jones , - Harry Garrood , - Christoph Hegemann , - Liam Goodacre , - Nathan Faubion -copyright: (c) 2013-17 Phil Freeman, (c) 2014-19 Gary Burgess, (c) other contributors (see CONTRIBUTORS.md) -license: BSD3 -github: purescript/purescript -homepage: http://www.purescript.org/ -extra-source-files: - - app/static/* - - bundle/build.sh - - bundle/README - - tests/purs/**/*.js - - tests/purs/**/*.purs - - tests/purs/**/*.json - - tests/purs/**/*.out - - tests/json-compat/**/*.json - - tests/support/*.json - - tests/support/setup-win.cmd - - tests/support/psci/**.purs - - tests/support/psci/**.edit - - tests/support/pscide/src/**/*.purs - - tests/support/pscide/src/**/*.js - - tests/support/pscide/src/**/*.fail - - stack.yaml - - README.md - - INSTALL.md - - CONTRIBUTORS.md - - CONTRIBUTING.md -dependencies: - - aeson >=1.0 && <1.5 - - aeson-better-errors >=0.8 - - aeson-pretty - - ansi-terminal >=0.7.1 && <0.9 - - array - - base >=4.11 && <4.13 - - base-compat >=0.6.0 - - blaze-html >=0.8.1 && <0.10 - - bower-json >=1.0.0.1 && <1.1 - - boxes >=0.1.4 && <0.2.0 - - bytestring - - Cabal >= 2.2 && <3.0 - - cborg - - serialise - - cheapskate >=0.1 && <0.2 - - clock - - containers - - cryptonite >=0.25 - - data-ordlist >=0.4.7.0 - - deepseq - - directory >=1.2.3 - - edit-distance - - file-embed - - filepath - - fsnotify >=0.2.1 - - Glob >=0.9 && <0.10 - - haskeline >=0.7.0.0 && <0.8.0.0 - - language-javascript ==0.7.0.0 # important: keep this pinned to a single specific version, since it's effectively part of the compiler's public API. - - lifted-async >=0.10.0.3 && <0.10.1 - - lifted-base >=0.2.3 && <0.2.4 - - memory >=0.14 && <0.15 - - microlens-platform >=0.3.9.0 && <0.4 - - monad-control >=1.0.0.0 && <1.1 - - monad-logger >=0.3 && <0.4 - - mtl >=2.1.0 && <2.3.0 - - parallel >=3.2 && <3.3 - - parsec >=3.1.10 - - pattern-arrows >=0.0.2 && <0.1 - - process >=1.2.0 && <1.7 - - protolude >=0.1.6 && <0.2.4 - - purescript-ast - - purescript-cst - - regex-tdfa - - safe >=0.3.9 && <0.4 - - semigroups >=0.16.2 && <0.19 - - semialign >=1 && <1.1 - - sourcemap >=0.1.6 - - split - - stm >=0.2.4.0 - - stringsearch - - syb - - text - - these >= 1 && <1.1 - - time - - transformers >=0.3.0 && <0.6 - - transformers-base >=0.4.0 && <0.5 - - transformers-compat >=0.3.0 - - unordered-containers - - utf8-string >=1 && <2 - - vector -build-tools: - - happy ==1.19.9 - -library: - source-dirs: src - ghc-options: -Wall -O2 - other-modules: Paths_purescript - default-extensions: !include "./default-extensions.yaml" - -executables: - purs: - main: Main.hs - source-dirs: app - ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N - other-modules: - - Command.Bundle - - Command.Compile - - Command.Docs - - Command.Docs.Html - - Command.Docs.Markdown - - Command.Graph - - Command.Hierarchy - - Command.Ide - - Command.Publish - - Command.REPL - - Paths_purescript - - Version - - dependencies: - - ansi-wl-pprint - - file-embed - - http-types - - network >= 3.0.1.1 - - optparse-applicative >=0.13.0 - - purescript - - wai ==3.* - - wai-websockets ==3.* - - warp ==3.* - - websockets >=0.9 && <0.13 - when: - - condition: flag(release) - then: - cpp-options: -DRELEASE - else: - dependencies: - - gitrev >=1.2.0 && <1.4 - default-extensions: !include "./default-extensions.yaml" - -tests: - tests: - main: Main.hs - source-dirs: tests - ghc-options: -Wall - dependencies: - - purescript - - tasty - - tasty-golden - - tasty-hspec - - tasty-quickcheck - - hspec - - hspec-discover - - HUnit - - regex-base - default-extensions: !include "./default-extensions.yaml" - -flags: - release: - description: > - Mark this build as a release build: prevents inclusion of extra - info e.g. commit SHA in --version output) - manual: false - default: false - -stability: experimental diff --git a/purescript.cabal b/purescript.cabal new file mode 100644 index 0000000000..ded50103e1 --- /dev/null +++ b/purescript.cabal @@ -0,0 +1,405 @@ +cabal-version: 2.4 + +name: purescript +-- note: When updating the prerelease identifier, update it in app/Version.hs too! +version: 0.14.0 +synopsis: PureScript Programming Language Compiler +description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. +category: Language +stability: experimental +homepage: http://www.purescript.org/ +bug-reports: https://github.com/purescript/purescript/issues +author: Phil Freeman +maintainer: Gary Burgess , Hardy Jones , Harry Garrood , Christoph Hegemann , Liam Goodacre , Nathan Faubion + +copyright: (c) 2013-17 Phil Freeman, (c) 2014-19 Gary Burgess, (c) other contributors (see CONTRIBUTORS.md) +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + app/static/*.html + app/static/*.css + app/static/*.js + app/static/*.less + bundle/build.sh + bundle/README + tests/purs/**/*.js + tests/purs/**/*.purs + tests/purs/**/*.json + tests/purs/**/*.out + tests/json-compat/**/*.json + tests/support/*.json + tests/support/setup-win.cmd + tests/support/psci/**/*.purs + tests/support/psci/**/*.edit + tests/support/pscide/src/**/*.purs + tests/support/pscide/src/**/*.js + tests/support/pscide/src/**/*.fail + stack.yaml + README.md + INSTALL.md + CONTRIBUTORS.md + CONTRIBUTING.md + +source-repository head + type: git + location: https://github.com/purescript/purescript + +flag release + description: Mark this build as a release build: prevents inclusion of extra info e.g. commit SHA in --version output) + + manual: False + default: False + +common defaults + default-language: Haskell2010 + default-extensions: + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFunctor + DeriveFoldable + DeriveTraversable + DeriveGeneric + DerivingStrategies + EmptyDataDecls + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + KindSignatures + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + NoImplicitPrelude + PatternGuards + PatternSynonyms + RankNTypes + RecordWildCards + OverloadedStrings + ScopedTypeVariables + TupleSections + TypeFamilies + ViewPatterns + build-tool-depends: + happy:happy ==1.19.9 + build-depends: + -- NOTE: Please do not edit these version constraints manually. They are + -- deliberately made narrow because changing the dependency versions in + -- use can often result in changes in the compiler's behaviour. The + -- PureScript compiler is an executable first and foremost, and only + -- incidentally a library, and supporting a wide range of dependencies is + -- not a goal. + -- + -- These version ranges are generated from taking a Stackage snapshot and + -- then generating PVP-compliant bounds based on that snapshot. You can + -- update to a newer snapshot as follows: + -- + -- 1. Remove all version constraints from this cabal file (apart from + -- language-javascript). + -- 2. Update stack.yaml as required to select a new snapshot, and check + -- everything builds correctly with stack. + -- 3. Run `stack sdist`; this will produce a source distribution including + -- a modified version of the cabal file, which includes bounds for all + -- dependencies (because of `pvp-bounds: both` in stack.yaml). + -- 4. Copy the version bounds from the library's build-depends section + -- to here. + -- + -- This procedure allows us to take advantage of Stackage snapshots to + -- easily perform updates, while also ensuring that the compiler will be + -- built with (almost) the same install plan for both cabal and stack + -- users. + -- + -- We need to be especially careful with language-javascript because it + -- is part of the compiler's public API; all FFI modules must be parseable + -- by language-javascript otherwise the compiler will reject them. It + -- should always be pinned to a single specific version. + aeson >=1.4.2.0 && <1.5, + aeson-better-errors >=0.9.1.0 && <0.10, + aeson-pretty >=0.8.7 && <0.9, + ansi-terminal >=0.8.2 && <0.9, + array >=0.5.3.0 && <0.6, + base >=4.12.0.0 && <4.13, + base-compat >=0.10.5 && <0.11, + blaze-html >=0.9.1.1 && <0.10, + bower-json >=1.0.0.1 && <1.1, + boxes >=0.1.5 && <0.2, + bytestring >=0.10.8.2 && <0.11, + Cabal >=2.4.1.0 && <2.5, + cborg >=0.2.2.0 && <0.3, + serialise >=0.2.2.0 && <0.3, + cheapskate >=0.1.1.1 && <0.2, + clock >=0.7.2 && <0.8, + containers >=0.6.0.1 && <0.7, + cryptonite ==0.25.*, + data-ordlist >=0.4.7.0 && <0.5, + deepseq >=1.4.4.0 && <1.5, + directory >=1.3.3.0 && <1.4, + dlist >=0.8.0.6 && <0.9, + edit-distance >=0.2.2.1 && <0.3, + file-embed >=0.0.11 && <0.1, + filepath >=1.4.2.1 && <1.5, + fsnotify >=0.3.0.1 && <0.4, + Glob >=0.9.3 && <0.10, + haskeline >=0.7.5.0 && <0.8, + language-javascript ==0.7.0.0, + lifted-async >=0.10.0.4 && <0.11, + lifted-base >=0.2.3.12 && <0.3, + memory >=0.14.18 && <0.15, + microlens >=0.4.10 && <0.5, + microlens-platform >=0.3.11 && <0.4, + monad-control >=1.0.2.3 && <1.1, + monad-logger >=0.3.30 && <0.4, + mtl >=2.2.2 && <2.3, + parallel >=3.2.2.0 && <3.3, + parsec >=3.1.13.0 && <3.2, + pattern-arrows >=0.0.2 && <0.1, + process >=1.6.5.0 && <1.7, + protolude >=0.2.3 && <0.3, + purescript-ast >=0.1.0.0 && <0.2, + purescript-cst >=0.1.0.0 && <0.2, + regex-tdfa >=1.2.3.2 && <1.3, + safe >=0.3.17 && <0.4, + scientific >=0.3.6.2 && <0.4, + semigroups >=0.18.5 && <0.19, + semialign >=1 && <1.1, + sourcemap >=0.1.6 && <0.2, + split >=0.2.3.3 && <0.3, + stm >=2.5.0.0 && <2.6, + stringsearch >=0.3.6.6 && <0.4, + syb >=0.7.1 && <0.8, + text >=1.2.3.1 && <1.3, + these >=1.0.1 && <1.1, + time >=1.8.0.2 && <1.9, + transformers >=0.5.6.2 && <0.6, + transformers-base >=0.4.5.2 && <0.5, + transformers-compat >=0.6.5 && <0.7, + unordered-containers >=0.2.10.0 && <0.3, + utf8-string >=1.0.1.1 && <1.1, + vector >=0.12.0.3 && <0.13 + +library + import: defaults + hs-source-dirs: src + exposed-modules: + Control.Monad.Logger + Language.PureScript + Language.PureScript.Bundle + Language.PureScript.CodeGen + Language.PureScript.CodeGen.JS + Language.PureScript.CodeGen.JS.Common + Language.PureScript.CodeGen.JS.Printer + Language.PureScript.Constants.Prelude + Language.PureScript.Constants.Data.Generic.Rep + Language.PureScript.Constants.Data.Newtype + Language.PureScript.CoreFn + Language.PureScript.CoreFn.Ann + Language.PureScript.CoreFn.Binders + Language.PureScript.CoreFn.Desugar + Language.PureScript.CoreFn.Expr + Language.PureScript.CoreFn.FromJSON + Language.PureScript.CoreFn.Meta + Language.PureScript.CoreFn.Module + Language.PureScript.CoreFn.Optimizer + Language.PureScript.CoreFn.ToJSON + Language.PureScript.CoreFn.Traversals + Language.PureScript.CoreImp + Language.PureScript.CoreImp.AST + Language.PureScript.CoreImp.Optimizer + Language.PureScript.CoreImp.Optimizer.Blocks + Language.PureScript.CoreImp.Optimizer.Common + Language.PureScript.CoreImp.Optimizer.Inliner + Language.PureScript.CoreImp.Optimizer.MagicDo + Language.PureScript.CoreImp.Optimizer.TCO + Language.PureScript.CoreImp.Optimizer.Unused + Language.PureScript.CST + Language.PureScript.Docs + Language.PureScript.Docs.AsHtml + Language.PureScript.Docs.AsMarkdown + Language.PureScript.Docs.Collect + Language.PureScript.Docs.Convert + Language.PureScript.Docs.Convert.ReExports + Language.PureScript.Docs.Convert.Single + Language.PureScript.Docs.Css + Language.PureScript.Docs.Prim + Language.PureScript.Docs.Render + Language.PureScript.Docs.RenderedCode + Language.PureScript.Docs.RenderedCode.RenderType + Language.PureScript.Docs.RenderedCode.Types + Language.PureScript.Docs.Tags + Language.PureScript.Docs.Types + Language.PureScript.Docs.Utils.MonoidExtras + Language.PureScript.Errors + Language.PureScript.Errors.JSON + Language.PureScript.Externs + Language.PureScript.Graph + Language.PureScript.Hierarchy + Language.PureScript.Ide + Language.PureScript.Ide.CaseSplit + Language.PureScript.Ide.Command + Language.PureScript.Ide.Completion + Language.PureScript.Ide.Error + Language.PureScript.Ide.Externs + Language.PureScript.Ide.Filter + Language.PureScript.Ide.Filter.Declaration + Language.PureScript.Ide.Imports + Language.PureScript.Ide.Logging + Language.PureScript.Ide.Matcher + Language.PureScript.Ide.Prim + Language.PureScript.Ide.Rebuild + Language.PureScript.Ide.Reexports + Language.PureScript.Ide.SourceFile + Language.PureScript.Ide.State + Language.PureScript.Ide.Types + Language.PureScript.Ide.Usage + Language.PureScript.Ide.Util + Language.PureScript.Interactive + Language.PureScript.Interactive.Completion + Language.PureScript.Interactive.Directive + Language.PureScript.Interactive.IO + Language.PureScript.Interactive.Message + Language.PureScript.Interactive.Module + Language.PureScript.Interactive.Parser + Language.PureScript.Interactive.Printer + Language.PureScript.Interactive.Types + Language.PureScript.Linter + Language.PureScript.Linter.Exhaustive + Language.PureScript.Linter.Imports + Language.PureScript.Make + Language.PureScript.Make.Actions + Language.PureScript.Make.BuildPlan + Language.PureScript.Make.Cache + Language.PureScript.Make.Monad + Language.PureScript.ModuleDependencies + Language.PureScript.Options + Language.PureScript.Pretty + Language.PureScript.Pretty.Common + Language.PureScript.Pretty.Types + Language.PureScript.Pretty.Values + Language.PureScript.Publish + Language.PureScript.Publish.BoxesHelpers + Language.PureScript.Publish.ErrorsWarnings + Language.PureScript.Publish.Utils + Language.PureScript.Renamer + Language.PureScript.Sugar + Language.PureScript.Sugar.AdoNotation + Language.PureScript.Sugar.BindingGroups + Language.PureScript.Sugar.CaseDeclarations + Language.PureScript.Sugar.DoNotation + Language.PureScript.Sugar.LetPattern + Language.PureScript.Sugar.Names + Language.PureScript.Sugar.Names.Common + Language.PureScript.Sugar.Names.Env + Language.PureScript.Sugar.Names.Exports + Language.PureScript.Sugar.Names.Imports + Language.PureScript.Sugar.ObjectWildcards + Language.PureScript.Sugar.Operators + Language.PureScript.Sugar.Operators.Binders + Language.PureScript.Sugar.Operators.Common + Language.PureScript.Sugar.Operators.Expr + Language.PureScript.Sugar.Operators.Types + Language.PureScript.Sugar.TypeClasses + Language.PureScript.Sugar.TypeClasses.Deriving + Language.PureScript.Sugar.TypeDeclarations + Language.PureScript.TypeChecker + Language.PureScript.TypeChecker.Entailment + Language.PureScript.TypeChecker.Entailment.Coercible + Language.PureScript.TypeChecker.Kinds + Language.PureScript.TypeChecker.Monad + Language.PureScript.TypeChecker.Roles + Language.PureScript.TypeChecker.Skolems + Language.PureScript.TypeChecker.Subsumption + Language.PureScript.TypeChecker.Synonyms + Language.PureScript.TypeChecker.Types + Language.PureScript.TypeChecker.TypeSearch + Language.PureScript.TypeChecker.Unify + System.IO.UTF8 + other-modules: + Paths_purescript + autogen-modules: + Paths_purescript + +executable purs + import: defaults + hs-source-dirs: app + main-is: Main.hs + ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N + build-depends: + ansi-wl-pprint >=0.6.8.2 && < 0.7 + , file-embed ==0.0.11 + , http-types >=0.12.3 && < 0.13 + , network >= 3.0.1.1 && <3.1 + , optparse-applicative >=0.13.0 && <0.15 + , purescript + , wai ==3.* + , wai-websockets ==3.* + , warp ==3.* + , websockets >=0.9 && <0.13 + if flag(release) + cpp-options: -DRELEASE + else + build-depends: + gitrev >=1.2.0 && <1.4 + other-modules: + Command.Bundle + Command.Compile + Command.Docs + Command.Docs.Html + Command.Docs.Markdown + Command.Graph + Command.Hierarchy + Command.Ide + Command.Publish + Command.REPL + Version + Paths_purescript + autogen-modules: + Paths_purescript + +test-suite tests + import: defaults + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + build-depends: + purescript + , tasty + , tasty-golden + , tasty-hspec + , tasty-quickcheck + , hspec + , HUnit + , regex-base + build-tool-depends: + hspec-discover:hspec-discover -any + -- we need the compiler's executable available for the ide tests + , purescript:purs -any + other-modules: + Language.PureScript.Ide.CompletionSpec + Language.PureScript.Ide.FilterSpec + Language.PureScript.Ide.ImportsSpec + Language.PureScript.Ide.MatcherSpec + Language.PureScript.Ide.RebuildSpec + Language.PureScript.Ide.ReexportsSpec + Language.PureScript.Ide.SourceFileSpec + Language.PureScript.Ide.StateSpec + Language.PureScript.Ide.Test + Language.PureScript.Ide.UsageSpec + PscIdeSpec + TestBundle + TestCompiler + TestCoreFn + TestDocs + TestGraph + TestHierarchy + TestIde + TestMake + TestPrimDocs + TestPsci + TestPsci.CommandTest + TestPsci.CompletionTest + TestPsci.EvalTest + TestPsci.TestEnv + TestPscPublish + TestUtils + Paths_purescript diff --git a/stack.yaml b/stack.yaml index 7f405631e7..64592ce61b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,12 @@ resolver: lts-13.26 -pvp-bounds: upper +pvp-bounds: both packages: - '.' - lib/purescript-ast - lib/purescript-cst +ghc-options: + # Build with advanced optimizations enabled by default + "$locals": -O2 extra-deps: - serialise-0.2.2.0 - cborg-0.2.2.0 From b7a861652da7a502318798854b3cc1b543da77c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rados=C5=82aw=20Rowicki?= <35342116+radrow@users.noreply.github.com> Date: Fri, 19 Mar 2021 13:20:06 +0100 Subject: [PATCH 1273/1580] Fix exponential collapsing of BindingGroups (#4006) In short: When you dfs through a tree and launch the same dfs on each node then you go exponential. In long: I have spotted that function definitions which are big enough (see the added testcase) tend to blow up the memory and take extreme amount of time to handle. The issue was triggered particularly in the collapseBindingGroups as it was running a traversal through the whole AST of each declaration that on every let was calling the collapseBindingGroups which was running a traversal through the whole AST of each declaration that on every let was calling the collapseBindingGroups which was running a traversal through the whole AST of each declaration that on every let was calling the collapseBindingGroups which was running a traversal(...) More clearly, collapseBindingGroups used to run collapseBindingGroupsForValue on each AST node which was running collapseBindingGroups on every let expression. This was effectively forcing all inner lets to be visited twice which, by the fact, that each of these duplicated evaluations was running next two ones, was amplifying the problem leading to exponential complexity over the depth of a tree. Since the purpose of this function is to flatten the binding groups of the declarations across the whole AST, I changed the folding function for everywhereOnValues to simply flatten a single layer of declarations. It works perfectly as going deeper is already handled by everywhereOnValues. I have prepared a testcase that fails on the master branch but is successfully solved after the fixes. Work on this PR was funded by aeternity --- CONTRIBUTORS.md | 2 + .../PureScript/Sugar/BindingGroups.hs | 15 +- tests/purs/passing/BigFunction.purs | 140 ++++++++++++++++++ 3 files changed, 151 insertions(+), 6 deletions(-) create mode 100644 tests/purs/passing/BigFunction.purs diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 5e8644cd24..097c037ac1 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -99,6 +99,7 @@ If you would prefer to use different terms, please use the section below instead | [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license](http://opensource.org/licenses/MIT) | | [@ptrfrncsmrph](https://github.com/ptrfrncsmrph) | Peter Murphy | [MIT license](http://opensource.org/licenses/MIT) | | [@quesebifurcan](https://github.com/quesebifurcan) | Fredrik Wallberg | [MIT license](http://opensource.org/licenses/MIT) | +| [@radrow](https://github.com/radrow) | Radosław Rowicki | [MIT license](http://opensource.org/licenses/MIT) | | [@rhendric](https://github.com/rhendric) | Ryan Hendrickson | [MIT license](http://opensource.org/licenses/MIT) | | [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) | | [@rndnoise](https://www.github.com/rndnoise) | rndnoise | [MIT license](http://opensource.org/licenses/MIT) | @@ -164,3 +165,4 @@ If you would prefer to use different terms, please use the section below instead | [@citizennet](https://github.com/citizennet) | CitizenNet Inc. | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright CitizenNet Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@dbenyamin-cn](https://github.com/dbenyamin-cn) | | [@slamdata](https://github.com/slamdata) | SlamData, Inc. | Speaking on behalf of SlamData for SlamData employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright SlamData Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - @jdegoes | | [@qfpl](https://github.com/qfpl) | qfpl @ Data61 / CSIRO | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Data61 / CSIRO, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@lightandlight](https://github.com/lightandlight) | +| [@aeternity](https://aeternity.com/) | Aeternity Establishment | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Aeternity Establishment, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index f691d7a1ec..fa3bafd0d1 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -115,8 +115,15 @@ createBindingGroups moduleName = mapM f <=< handleDecls -- collapseBindingGroups :: [Declaration] -> [Declaration] collapseBindingGroups = - let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id - in fmap f . concatMap go + let (f, _, _) = everywhereOnValues id flattenBindingGroupsForValue id + in fmap f . flattenBindingGroups + +flattenBindingGroupsForValue :: Expr -> Expr +flattenBindingGroupsForValue (Let w ds val) = Let w (flattenBindingGroups ds) val +flattenBindingGroupsForValue other = other + +flattenBindingGroups :: [Declaration] -> [Declaration] +flattenBindingGroups = concatMap go where go (DataBindingGroupDeclaration ds) = NEL.toList ds go (BindingGroupDeclaration ds) = @@ -124,10 +131,6 @@ collapseBindingGroups = ValueDecl sa ident nameKind [] [MkUnguarded val]) ds go other = [other] -collapseBindingGroupsForValue :: Expr -> Expr -collapseBindingGroupsForValue (Let w ds val) = Let w (collapseBindingGroups ds) val -collapseBindingGroupsForValue other = other - usedIdents :: ModuleName -> ValueDeclarationData Expr -> [Ident] usedIdents moduleName = ordNub . usedIdents' S.empty . valdeclExpression where diff --git a/tests/purs/passing/BigFunction.purs b/tests/purs/passing/BigFunction.purs new file mode 100644 index 0000000000..b83642c4b4 --- /dev/null +++ b/tests/purs/passing/BigFunction.purs @@ -0,0 +1,140 @@ +module Main where + +import Prelude +import Data.Maybe +import Data.Array(index) +import Effect.Console(log) + +main = let x = f [] in log "Done" + +lookup :: forall a. Int -> Array a -> Maybe a +lookup = flip index + +f :: Array (Array Int) -> Int +f [] = 0 +f [m] | Just x <- lookup 1 m = x +f [m, mm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm = x + xx +f [m, mm, mmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm = x + xx + xxx +f [m, mm, mmm, mmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm = x + xx + xxx + xxxx +f [m, mm, mmm, mmmm, mmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm = x + xx + xxx + xxxx + xxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [] = 0 +f [m] | Just x <- lookup 1 m = x +f [m, mm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm = x + xx +f [m, mm, mmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm = x + xx + xxx +f [m, mm, mmm, mmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm = x + xx + xxx + xxxx +f [m, mm, mmm, mmmm, mmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm = x + xx + xxx + xxxx + xxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f [m, mm, mmm, mmmm, mmmmm, mmmmmm, mmmmmmm, mmmmmmmm, mmmmmmmmm, mmmmmmmmmm, mmmmmmmmmmm, mmmmmmmmmmmm, mmmmmmmmmmmmm, mmmmmmmmmmmmmm, mmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm] | Just x <- lookup 1 m, Just xx <- lookup 11 mm, Just xxx <- lookup 111 mmm, Just xxxx <- lookup 1111 mmmm, Just xxxxx <- lookup 11111 mmmmm, Just xxxxxx <- lookup 6 mmmmmm, Just xxxxxxx <- lookup 5 mmmmmmm, Just xxxxxxxx <- lookup 4 mmmmmmmm, Just xxxxxxxxx <- lookup 3 mmmmmmmmm, Just xxxxxxxxxx <- lookup 2 mmmmmmmmmm, Just xxxxxxxxxxx <- lookup 2 mmmmmmmmmmm, Just xxxxxxxxxxxx <- lookup 21 mmmmmmmmmmmm, Just xxxxxxxxxxxxx <- lookup 211 mmmmmmmmmmmmm, Just xxxxxxxxxxxxxx <- lookup 2111 mmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxx <- lookup 21111 mmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxx <- lookup 211111 mmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxx <- lookup 26 mmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxx <- lookup 25 mmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxx <- lookup 24 mmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxx <- lookup 23 mmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxx <- lookup 22 mmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxx <- lookup 221 mmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211 mmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22111 mmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 221111 mmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2211111 mmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 226 mmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2224 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2223 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 2222111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22221111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 222211111 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22226 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm, Just xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx <- lookup 22225 mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm = x + xx + xxx + xxxx + xxxxx + xxxxxx + xxxxxxx + xxxxxxxx + xxxxxxxxx + xxxxxxxxxx + xxxxxxxxxxx + xxxxxxxxxxxx + xxxxxxxxxxxxx + xxxxxxxxxxxxxx + xxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +f _ = 2137 From efbcc474f64264c6f75828c17294f9df97b69062 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Fri, 19 Mar 2021 16:14:38 -0400 Subject: [PATCH 1274/1580] Support TCO for functions with tail-recursive inner functions (#3958) This commit adds support for optimizing functions that contain local functions which call the outer function in tail position, as long as those functions themselves are only called from tail position, either in the outer function or in other such local functions. This enables hand-written mutually-tail-recursive function groups to be optimized, but more critically, it also means that case guards which desugar to use local functions don't break TCO. --- CHANGELOG.md | 11 + .../PureScript/CoreImp/Optimizer/TCO.hs | 207 ++++++++++++------ tests/purs/passing/3957.purs | 39 ++++ tests/purs/passing/TCOMutRec.purs | 95 ++++++++ 4 files changed, 280 insertions(+), 72 deletions(-) create mode 100644 tests/purs/passing/3957.purs create mode 100644 tests/purs/passing/TCOMutRec.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index af1cab9089..d59c2b1f9d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,17 @@ Breaking changes: New features: +* Support TCO for functions with tail-recursive inner functions (#3958, @rhendric) + + Adds support for optimizing functions that contain local functions which call + the outer function in tail position, as long as those functions themselves + are only called from tail position, either in the outer function or in other + such functions. + + This enables hand-written mutually-tail-recursive function groups to be + optimized, but more critically, it also means that case guards which desugar + to use local functions don't break TCO. + Bugfixes: * Make close punctuation printable in errors (#3982, @rhendric) diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index 6aa53905b6..196f255fc5 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -3,7 +3,13 @@ module Language.PureScript.CoreImp.Optimizer.TCO (tco) where import Prelude.Compat -import Data.Text (Text) +import Control.Applicative (empty, liftA2) +import Control.Monad (guard) +import Control.Monad.State (State, evalState, get, modify) +import Data.Foldable (foldr) +import Data.Functor (($>), (<&>)) +import qualified Data.Set as S +import Data.Text (Text, pack) import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.CoreImp.AST import Language.PureScript.AST.SourcePos (SourceSpan) @@ -11,15 +17,16 @@ import Safe (headDef, tailSafe) -- | Eliminate tail calls tco :: AST -> AST -tco = everywhere convert where +tco = flip evalState 0 . everywhereTopDownM convert where tcoVar :: Text -> Text tcoVar arg = "$tco_var_" <> arg copyVar :: Text -> Text copyVar arg = "$copy_" <> arg - tcoDone :: Text - tcoDone = "$tco_done" + tcoDoneM :: State Int Text + tcoDoneM = get <&> \count -> "$tco_done" <> + if count == 0 then "" else pack . show $ count tcoLoop :: Text tcoLoop = "$tco_loop" @@ -27,63 +34,135 @@ tco = everywhere convert where tcoResult :: Text tcoResult = "$tco_result" - convert :: AST -> AST + convert :: AST -> State Int AST convert (VariableIntroduction ss name (Just fn@Function {})) - | isTailRecursive name body' - = VariableIntroduction ss name (Just (replace (toLoop name outerArgs innerArgs body'))) + | Just trFns <- findTailRecursiveFns name arity body' + = VariableIntroduction ss name . Just . replace <$> toLoop trFns name arity outerArgs innerArgs body' where innerArgs = headDef [] argss outerArgs = concat . reverse $ tailSafe argss - (argss, body', replace) = collectAllFunctionArgs [] id fn - convert js = js - - collectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST) - collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 (body@(Return _ _):_))) = - collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (map copyVar args) (Block s2 [b]))) body - collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _)) = - (args : allArgs, body, f . Function ss ident (map copyVar args)) - collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 [body]))) = - collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (map copyVar args) (Block s3 [b])))) body - collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _))) = - (args : allArgs, body, f . Return s1 . Function s2 ident (map copyVar args)) - collectAllFunctionArgs allArgs f body = (allArgs, body, f) - - isTailRecursive :: Text -> AST -> Bool - isTailRecursive ident js = countSelfReferences js > 0 && allInTailPosition js where - countSelfReferences = everything (+) match where - match :: AST -> Int - match (Var _ ident') | ident == ident' = 1 - match _ = 0 + arity = length argss + -- ^ this is the number of calls, not the number of arguments, if there's + -- ever a practical difference. + (argss, body', replace) = topCollectAllFunctionArgs [] id fn + convert js = pure js + + rewriteFunctionsWith :: ([Text] -> [Text]) -> [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST) + rewriteFunctionsWith argMapper = collectAllFunctionArgs + where + collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 (body@(Return _ _):_))) = + collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (argMapper args) (Block s2 [b]))) body + collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _)) = + (args : allArgs, body, f . Function ss ident (argMapper args)) + collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 [body]))) = + collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (argMapper args) (Block s3 [b])))) body + collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _))) = + (args : allArgs, body, f . Return s1 . Function s2 ident (argMapper args)) + collectAllFunctionArgs allArgs f body = (allArgs, body, f) + + topCollectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST) + topCollectAllFunctionArgs = rewriteFunctionsWith (map copyVar) + + innerCollectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST) + innerCollectAllFunctionArgs = rewriteFunctionsWith id + + countReferences :: Text -> AST -> Int + countReferences ident = everything (+) match where + match :: AST -> Int + match (Var _ ident') | ident == ident' = 1 + match _ = 0 + + -- If `ident` is a tail-recursive function, returns a set of identifiers + -- that are locally bound to functions participating in the tail recursion. + -- Otherwise, returns Nothing. + findTailRecursiveFns :: Text -> Int -> AST -> Maybe (S.Set Text) + findTailRecursiveFns ident arity js = guard (countReferences ident js > 0) *> go (S.empty, S.singleton (ident, arity)) + where + + go :: (S.Set Text, S.Set (Text, Int)) -> Maybe (S.Set Text) + go (known, required) = + case S.minView required of + Just (r, required') -> do + required'' <- findTailPositionDeps r js + go (S.insert (fst r) known, required' <> (S.filter (not . (`S.member` known) . fst) required'')) + Nothing -> + pure known + + -- Returns set of identifiers (with their arities) that need to be used + -- exclusively in tail calls using their full arity in order for this + -- identifier to be considered in tail position (or Nothing if this + -- identifier is used somewhere not as a tail call with full arity). + findTailPositionDeps :: (Text, Int) -> AST -> Maybe (S.Set (Text, Int)) + findTailPositionDeps (ident, arity) js = allInTailPosition js where + countSelfReferences = countReferences ident allInTailPosition (Return _ expr) - | isSelfCall ident expr = countSelfReferences expr == 1 - | otherwise = countSelfReferences expr == 0 + | isSelfCall ident arity expr = guard (countSelfReferences expr == 1) $> S.empty + | otherwise = guard (countSelfReferences expr == 0) $> S.empty allInTailPosition (While _ js1 body) - = countSelfReferences js1 == 0 && allInTailPosition body + = guard (countSelfReferences js1 == 0) *> allInTailPosition body allInTailPosition (For _ _ js1 js2 body) - = countSelfReferences js1 == 0 && countSelfReferences js2 == 0 && allInTailPosition body + = guard (countSelfReferences js1 == 0 && countSelfReferences js2 == 0) *> allInTailPosition body allInTailPosition (ForIn _ _ js1 body) - = countSelfReferences js1 == 0 && allInTailPosition body + = guard (countSelfReferences js1 == 0) *> allInTailPosition body allInTailPosition (IfElse _ js1 body el) - = countSelfReferences js1 == 0 && allInTailPosition body && all allInTailPosition el + = guard (countSelfReferences js1 == 0) *> liftA2 mappend (allInTailPosition body) (foldMapA allInTailPosition el) allInTailPosition (Block _ body) - = all allInTailPosition body + = foldMapA allInTailPosition body allInTailPosition (Throw _ js1) - = countSelfReferences js1 == 0 + = guard (countSelfReferences js1 == 0) $> S.empty allInTailPosition (ReturnNoResult _) - = True - allInTailPosition (VariableIntroduction _ _ js1) - = all ((== 0) . countSelfReferences) js1 + = pure S.empty + allInTailPosition (VariableIntroduction _ _ Nothing) + = pure S.empty + allInTailPosition (VariableIntroduction _ ident' (Just js1)) + | countSelfReferences js1 == 0 = pure S.empty + | Function _ Nothing _ _ <- js1 + , (argss, body, _) <- innerCollectAllFunctionArgs [] id js1 + = S.insert (ident', length argss) <$> allInTailPosition body + | otherwise = empty allInTailPosition (Assignment _ _ js1) - = countSelfReferences js1 == 0 + = guard (countSelfReferences js1 == 0) $> S.empty allInTailPosition (Comment _ _ js1) = allInTailPosition js1 allInTailPosition _ - = False - - toLoop :: Text -> [Text] -> [Text] -> AST -> AST - toLoop ident outerArgs innerArgs js = - Block rootSS $ + = empty + + toLoop :: S.Set Text -> Text -> Int -> [Text] -> [Text] -> AST -> State Int AST + toLoop trFns ident arity outerArgs innerArgs js = do + tcoDone <- tcoDoneM + modify (+ 1) + + let + markDone :: Maybe SourceSpan -> AST + markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True) + + loopify :: AST -> AST + loopify (Return ss ret) + | isSelfCall ident arity ret = + let + allArgumentValues = concat $ collectArgs [] ret + in + Block ss $ + zipWith (\val arg -> + Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs + ++ zipWith (\val arg -> + Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs + ++ [ ReturnNoResult ss ] + | isIndirectSelfCall ret = Return ss ret + | otherwise = Block ss [ markDone ss, Return ss ret ] + loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ] + loopify (While ss cond body) = While ss cond (loopify body) + loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body) + loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body) + loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el) + loopify (Block ss body) = Block ss (map loopify body) + loopify (VariableIntroduction ss f (Just fn@(Function _ Nothing _ _))) + | (_, body, replace) <- innerCollectAllFunctionArgs [] id fn + , f `S.member` trFns = VariableIntroduction ss f (Just (replace (loopify body))) + loopify other = other + + pure $ Block rootSS $ map (\arg -> VariableIntroduction rootSS (tcoVar arg) (Just (Var rootSS (copyVar arg)))) outerArgs ++ [ VariableIntroduction rootSS tcoDone (Just (BooleanLiteral rootSS False)) , VariableIntroduction rootSS tcoResult Nothing @@ -96,30 +175,6 @@ tco = everywhere convert where where rootSS = Nothing - loopify :: AST -> AST - loopify (Return ss ret) - | isSelfCall ident ret = - let - allArgumentValues = concat $ collectArgs [] ret - in - Block ss $ - zipWith (\val arg -> - Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs - ++ zipWith (\val arg -> - Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs - ++ [ ReturnNoResult ss ] - | otherwise = Block ss [ markDone ss, Return ss ret ] - loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ] - loopify (While ss cond body) = While ss cond (loopify body) - loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body) - loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body) - loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el) - loopify (Block ss body) = Block ss (map loopify body) - loopify other = other - - markDone :: Maybe SourceSpan -> AST - markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True) - collectArgs :: [[AST]] -> AST -> [[AST]] collectArgs acc (App _ fn []) = -- count 0-argument applications as single-argument so we get the correct number of args @@ -127,7 +182,15 @@ tco = everywhere convert where collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn collectArgs acc _ = acc - isSelfCall :: Text -> AST -> Bool - isSelfCall ident (App _ (Var _ ident') _) = ident == ident' - isSelfCall ident (App _ fn _) = isSelfCall ident fn - isSelfCall _ _ = False + isIndirectSelfCall :: AST -> Bool + isIndirectSelfCall (App _ (Var _ ident') _) = ident' `S.member` trFns + isIndirectSelfCall (App _ fn _) = isIndirectSelfCall fn + isIndirectSelfCall _ = False + + isSelfCall :: Text -> Int -> AST -> Bool + isSelfCall ident 1 (App _ (Var _ ident') _) = ident == ident' + isSelfCall ident arity (App _ fn _) = isSelfCall ident (arity - 1) fn + isSelfCall _ _ _ = False + +foldMapA :: (Applicative f, Monoid w, Foldable t) => (a -> f w) -> t a -> f w +foldMapA f = foldr (liftA2 mappend . f) (pure mempty) diff --git a/tests/purs/passing/3957.purs b/tests/purs/passing/3957.purs new file mode 100644 index 0000000000..159abead92 --- /dev/null +++ b/tests/purs/passing/3957.purs @@ -0,0 +1,39 @@ +module Main where + +import Prelude +import Effect.Console (log) +import Test.Assert (assertEqual) + +data Maybe a = Nothing | Just a + +f :: Int -> Int +f x = case x of + 0 -> 0 + n | _ <- n -> f (x - 1) + _ -> f (x - 2) + +g :: Int -> Int +g x = case x of + 0 -> 0 + n | n == n, true -> g (x - 1) + _ -> g (x - 2) + +weirdsum :: Int -> (Int -> Maybe Int) -> Int -> Int +weirdsum accum f n = case n of + 0 -> accum + x | Just y <- f x -> weirdsum (accum + y) f (n - 1) + _ -> weirdsum accum f (n - 1) + +tricksyinners :: Int -> Int -> Int +tricksyinners accum x = case x of + 0 -> accum + f' x * f' x + n -> tricksyinners (accum + 2) (n - 1) + where + f' y = y + 3 + +main = do + assertEqual { expected: 0, actual: f 100000 } + assertEqual { expected: 0, actual: g 100000 } + assertEqual { expected: 20, actual: weirdsum 0 (\x -> if x < 5 then Just (2 * x) else Nothing) 100000 } + assertEqual { expected: 200009, actual: tricksyinners 0 100000 } + log "Done" diff --git a/tests/purs/passing/TCOMutRec.purs b/tests/purs/passing/TCOMutRec.purs new file mode 100644 index 0000000000..6f599c5bd6 --- /dev/null +++ b/tests/purs/passing/TCOMutRec.purs @@ -0,0 +1,95 @@ +module Main where + +import Prelude +import Effect (Effect) +import Effect.Console (log) +import Test.Assert (assertEqual, assertThrows) + +tco1 :: Int -> Int +tco1 = f 0 + where + f x y = g (x + 2) (y - 1) + where + g x' y' = if y' <= 0 then x' else f x' y' + +tco2 :: Int -> Int +tco2 = f 0 + where + f x y = g (x + 2) (y - 1) + where + g x' y' = h (y' <= 0) x' y' + h test x' y' = if test then x' else f x' y' + +tco3 :: Int -> Int +tco3 y0 = f 0 y0 + where + f x y = g x (h y) + where + g x' y' = + if y' <= 0 then x' + else if y' > y0 / 2 then g (j x') (y' - 1) + else f (x' + 2) y' + h y = y - 1 + j x = x + 3 + +tco4 :: Int -> Int +tco4 = f 0 + where + f x y = if y <= 0 then x else g (y - 1) + where + g y' = f (x + 2) y' + +-- The following examples are functions which are prevented from being TCO'd +-- because the arity of the function being looped does not match the function +-- call. In theory, these could be made to optimize via eta-expansion in the +-- future, in which case the assertions can change. + +ntco1 :: Int -> Int +ntco1 y0 = f 0 y0 + where + f x = if x > 10 * y0 then (x + _) else g x + where + g x' y' = f (x' + 10) (y' - 1) + +ntco2 :: Int -> Int +ntco2 = f 0 + where + f x y = if y <= 0 then x else g x (y - 1) + where + g x' = f (x' + 2) + +ntco3 :: Int -> Int +ntco3 = f 0 + where + f x y = if y <= 0 then x else g (y - 1) + where + g = f (x + 2) + +ntco4 :: Int -> Int +ntco4 = f 0 + where + f x y = if y <= 0 then x else g (y - 1) + where + g = h x + h x' y' = f (x' + 2) y' + +main :: Effect Unit +main = do + assertEqual { expected: 200000, actual: tco1 100000 } + assertEqual { expected: 200000, actual: tco2 100000 } + assertEqual { expected: 249997, actual: tco3 100000 } + assertEqual { expected: 200000, actual: tco4 100000 } + + assertEqual { expected: 1009, actual: ntco1 100 } + assertThrows \_ -> ntco1 100000 + + assertEqual { expected: 200, actual: ntco2 100 } + assertThrows \_ -> ntco2 100000 + + assertEqual { expected: 200, actual: ntco3 100 } + assertThrows \_ -> ntco3 100000 + + assertEqual { expected: 200, actual: ntco4 100 } + assertThrows \_ -> ntco4 100000 + + log "Done" From ee0b3d391151bcd5f56de4563208dcf657cccc8c Mon Sep 17 00:00:00 2001 From: Christoph Hegemann <6189397+kritzcreek@users.noreply.github.com> Date: Sat, 20 Mar 2021 18:26:35 +0100 Subject: [PATCH 1275/1580] Updates for GHC 8.10.4 (#4013) * Updates for GHC 8.10.3 * kick CI * Let's try bionic Also let's try actually noticing and obeying the new instructions for updating version constraints in purescript.cabal. Co-authored-by: Ryan Hendrickson --- .travis.yml | 5 +- app/Command/REPL.hs | 39 +++---- lib/purescript-ast/purescript-ast.cabal | 24 ++-- lib/purescript-cst/purescript-cst.cabal | 18 +-- lib/purescript-cst/tests/TestCst.hs | 8 +- purescript.cabal | 103 +++++++++--------- src/Language/PureScript/CoreFn/FromJSON.hs | 2 +- src/Language/PureScript/CoreFn/ToJSON.hs | 1 - src/Language/PureScript/Docs/Convert.hs | 1 - .../PureScript/Docs/Convert/Single.hs | 1 - src/Language/PureScript/Docs/Types.hs | 4 +- src/Language/PureScript/Ide/Filter.hs | 1 - src/Language/PureScript/Make/Actions.hs | 3 +- src/Language/PureScript/Pretty/Values.hs | 1 - src/Language/PureScript/Publish.hs | 6 +- src/Language/PureScript/Sugar/LetPattern.hs | 2 +- stack.yaml | 9 +- tests/TestCompiler.hs | 1 - tests/TestPsci/CompletionTest.hs | 1 - 19 files changed, 106 insertions(+), 124 deletions(-) diff --git a/.travis.yml b/.travis.yml index 7f0bbfb825..c045ba54b6 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,12 +9,11 @@ branches: - /^v\d+\.\d+(\.\d+)?(-\S*)?$/ env: global: - - STACK_VERSION=2.1.1 + - STACK_VERSION=2.5.1 matrix: include: - # We use trusty boxes because they seem to be a bit faster. - os: linux - dist: trusty + dist: bionic sudo: required - os: osx diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index f44c1e8abe..6a93dae371 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -22,9 +22,10 @@ import Control.Concurrent.STM (TVar, atomically, newTVarIO, writeTVar, readTVarIO, TChan, newBroadcastTChanIO, dupTChan, readTChan, writeTChan) -import Control.Exception (fromException) +import Control.Exception (fromException, SomeException) import Control.Monad -import Control.Monad.IO.Class (liftIO) +import Control.Monad.Catch (MonadMask) +import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Trans.Class import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.State.Strict (StateT, evalStateT) @@ -97,7 +98,7 @@ psciOptions = PSCiOptions <$> many inputFile <*> backend -- | Parses the input and returns either a command, or an error as a 'String'. -getCommand :: forall m. MonadException m => InputT m (Either String [Command]) +getCommand :: forall m. (MonadIO m, MonadMask m) => InputT m (Either String [Command]) getCommand = handleInterrupt (return (Right [])) $ do line <- withInterrupt $ getInputLine "> " case line of @@ -105,7 +106,7 @@ getCommand = handleInterrupt (return (Right [])) $ do Just "" -> return (Right []) Just s -> return (parseCommand s) -pasteMode :: forall m. MonadException m => InputT m (Either String [Command]) +pasteMode :: forall m. (MonadIO m, MonadMask m) => InputT m (Either String [Command]) pasteMode = parseCommand <$> go [] where @@ -175,21 +176,21 @@ browserBackend serverPort = Backend setup evaluate reload shutdown handleWebsocket pending = do conn <- WS.acceptRequest pending -- Fork a thread to keep the connection alive - WS.forkPingThread conn 10 - -- Clone the command channel - cmdChanCopy <- atomically $ dupTChan cmdChan - -- Listen for commands - forever $ do - cmd <- atomically $ readTChan cmdChanCopy - case cmd of - Eval resultVar -> void $ do - WS.sendTextData conn ("eval" :: Text) - result <- WS.receiveData conn - -- With many connected clients, all but one of - -- these attempts will fail. - tryPutMVar resultVar (unpack result) - Refresh -> - WS.sendTextData conn ("reload" :: Text) + WS.withPingThread conn 10 (pure ()) $ do + -- Clone the command channel + cmdChanCopy <- atomically $ dupTChan cmdChan + -- Listen for commands + forever $ do + cmd <- atomically $ readTChan cmdChanCopy + case cmd of + Eval resultVar -> void $ do + WS.sendTextData conn ("eval" :: Text) + result <- WS.receiveData conn + -- With many connected clients, all but one of + -- these attempts will fail. + tryPutMVar resultVar (unpack result) + Refresh -> + WS.sendTextData conn ("reload" :: Text) shutdownHandler :: IO () -> IO () shutdownHandler stopServer = void . forkIO $ do diff --git a/lib/purescript-ast/purescript-ast.cabal b/lib/purescript-ast/purescript-ast.cabal index 55e9dd470d..66dcaaca8c 100644 --- a/lib/purescript-ast/purescript-ast.cabal +++ b/lib/purescript-ast/purescript-ast.cabal @@ -54,20 +54,20 @@ common defaults TypeFamilies ViewPatterns build-depends: - aeson >=1.0 && <1.5, - base >=4.11 && <4.13, - base-compat >=0.6.0, - bytestring >=0.10.8.2 && <0.11, - containers >=0.6.0.1 && <0.7, + aeson >=1.5.6.0 && <1.6, + base >=4.14.1.0 && <4.15, + base-compat >=0.11.2 && <0.12, + bytestring >=0.10.12.0 && <0.11, + containers >=0.6.2.1 && <0.7, deepseq >=1.4.4.0 && <1.5, filepath >=1.4.2.1 && <1.5, - microlens >=0.4.10 && <0.5, - mtl >=2.1.0 && <2.3.0, - protolude >=0.1.6 && <0.2.4, - scientific >=0.3.4.9 && <0.4, - serialise >=0.2.2.0 && <0.3, - text >=1.2.3.1 && <1.3, - vector >=0.12.0.3 && <0.13 + microlens >=0.4.11.2 && <0.5, + mtl >=2.2.2 && <2.3, + protolude >=0.3.0 && <0.4, + scientific >=0.3.6.2 && <0.4, + serialise >=0.2.3.0 && <0.3, + text >=1.2.4.1 && <1.3, + vector >=0.12.1.2 && <0.13 library import: defaults diff --git a/lib/purescript-cst/purescript-cst.cabal b/lib/purescript-cst/purescript-cst.cabal index 74a2e61bb4..7820fb0bce 100644 --- a/lib/purescript-cst/purescript-cst.cabal +++ b/lib/purescript-cst/purescript-cst.cabal @@ -56,16 +56,16 @@ common defaults TypeFamilies ViewPatterns build-depends: - array >=0.5.3.0 && <0.6, - base >=4.11 && <4.13, - containers >=0.6.0.1 && <0.7, - dlist >=0.8.0.6 && <0.9, - purescript-ast ==0.1.0.0, - scientific >=0.3.4.9 && <0.4, - semigroups >=0.16.2 && <0.19, - text >=1.2.3.1 && <1.3 + array >=0.5.4.0 && <0.6, + base >=4.14.1.0 && <4.15, + containers >=0.6.2.1 && <0.7, + dlist >=0.8.0.8 && <0.9, + purescript-ast >=0.1.0.0 && <0.2, + scientific >=0.3.6.2 && <0.4, + semigroups >=0.19.1 && <0.20, + text >=1.2.4.1 && <1.3 build-tool-depends: - happy:happy ==1.19.9 + happy:happy ==1.20.0 library import: defaults diff --git a/lib/purescript-cst/tests/TestCst.hs b/lib/purescript-cst/tests/TestCst.hs index f4561a1535..6587a435e2 100644 --- a/lib/purescript-cst/tests/TestCst.hs +++ b/lib/purescript-cst/tests/TestCst.hs @@ -73,9 +73,9 @@ readTok' failMsg t = case CST.lex t of Right tok : _ -> pure tok Left (_, err) : _ -> - fail $ failMsg <> ": " <> CST.prettyPrintError err + error $ failMsg <> ": " <> CST.prettyPrintError err [] -> - fail "Empty token stream" + error "Empty token stream" readTok :: Text -> Gen SourceToken readTok = readTok' "Failed to parse" @@ -89,7 +89,7 @@ checkTok p f t = do SourceToken _ tok <- readTok t case f tok of Just a -> p t a - Nothing -> fail $ "Failed to lex correctly: " <> show tok + Nothing -> error $ "Failed to lex correctly: " <> show tok roundTripTok :: Text -> Gen Bool roundTripTok t = do @@ -106,7 +106,7 @@ checkReadNum t a = do chs' -> chs' case (== a) <$> readMaybe chs of Just a' -> pure a' - Nothing -> fail "Failed to `read`" + Nothing -> error "Failed to `read`" newtype PSSourceInt = PSSourceInt { unInt :: Text } deriving (Show, Eq) diff --git a/purescript.cabal b/purescript.cabal index ded50103e1..889d72a4b8 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -82,7 +82,7 @@ common defaults TypeFamilies ViewPatterns build-tool-depends: - happy:happy ==1.19.9 + happy:happy ==1.20.0 build-depends: -- NOTE: Please do not edit these version constraints manually. They are -- deliberately made narrow because changing the dependency versions in @@ -114,69 +114,69 @@ common defaults -- is part of the compiler's public API; all FFI modules must be parseable -- by language-javascript otherwise the compiler will reject them. It -- should always be pinned to a single specific version. - aeson >=1.4.2.0 && <1.5, + aeson >=1.5.6.0 && <1.6, aeson-better-errors >=0.9.1.0 && <0.10, - aeson-pretty >=0.8.7 && <0.9, - ansi-terminal >=0.8.2 && <0.9, - array >=0.5.3.0 && <0.6, - base >=4.12.0.0 && <4.13, - base-compat >=0.10.5 && <0.11, - blaze-html >=0.9.1.1 && <0.10, + aeson-pretty >=0.8.8 && <0.9, + ansi-terminal >=0.10.3 && <0.11, + array >=0.5.4.0 && <0.6, + base >=4.14.1.0 && <4.15, + base-compat >=0.11.2 && <0.12, + blaze-html >=0.9.1.2 && <0.10, bower-json >=1.0.0.1 && <1.1, boxes >=0.1.5 && <0.2, - bytestring >=0.10.8.2 && <0.11, - Cabal >=2.4.1.0 && <2.5, - cborg >=0.2.2.0 && <0.3, - serialise >=0.2.2.0 && <0.3, - cheapskate >=0.1.1.1 && <0.2, - clock >=0.7.2 && <0.8, - containers >=0.6.0.1 && <0.7, - cryptonite ==0.25.*, + bytestring >=0.10.12.0 && <0.11, + Cabal >=3.2.1.0 && <3.3, + cborg >=0.2.4.0 && <0.3, + serialise >=0.2.3.0 && <0.3, + cheapskate >=0.1.1.2 && <0.2, + clock ==0.8.*, + containers >=0.6.2.1 && <0.7, + cryptonite ==0.27.*, data-ordlist >=0.4.7.0 && <0.5, deepseq >=1.4.4.0 && <1.5, - directory >=1.3.3.0 && <1.4, - dlist >=0.8.0.6 && <0.9, + directory >=1.3.6.0 && <1.4, + dlist >=0.8.0.8 && <0.9, edit-distance >=0.2.2.1 && <0.3, - file-embed >=0.0.11 && <0.1, + file-embed >=0.0.13.0 && <0.1, filepath >=1.4.2.1 && <1.5, fsnotify >=0.3.0.1 && <0.4, - Glob >=0.9.3 && <0.10, - haskeline >=0.7.5.0 && <0.8, + Glob >=0.10.1 && <0.11, + haskeline >=0.8.1.1 && <0.9, language-javascript ==0.7.0.0, - lifted-async >=0.10.0.4 && <0.11, + lifted-async >=0.10.1.3 && <0.11, lifted-base >=0.2.3.12 && <0.3, - memory >=0.14.18 && <0.15, - microlens >=0.4.10 && <0.5, - microlens-platform >=0.3.11 && <0.4, + memory >=0.15.0 && <0.16, + microlens >=0.4.11.2 && <0.5, + microlens-platform >=0.4.1 && <0.5, monad-control >=1.0.2.3 && <1.1, - monad-logger >=0.3.30 && <0.4, + monad-logger >=0.3.36 && <0.4, mtl >=2.2.2 && <2.3, parallel >=3.2.2.0 && <3.3, - parsec >=3.1.13.0 && <3.2, + parsec >=3.1.14.0 && <3.2, pattern-arrows >=0.0.2 && <0.1, - process >=1.6.5.0 && <1.7, - protolude >=0.2.3 && <0.3, + process >=1.6.9.0 && <1.7, + protolude >=0.3.0 && <0.4, purescript-ast >=0.1.0.0 && <0.2, purescript-cst >=0.1.0.0 && <0.2, - regex-tdfa >=1.2.3.2 && <1.3, - safe >=0.3.17 && <0.4, + regex-tdfa >=1.3.1.0 && <1.4, + safe >=0.3.19 && <0.4, scientific >=0.3.6.2 && <0.4, - semigroups >=0.18.5 && <0.19, - semialign >=1 && <1.1, + semigroups >=0.19.1 && <0.20, + semialign >=1.1.0.1 && <1.2, sourcemap >=0.1.6 && <0.2, - split >=0.2.3.3 && <0.3, + split >=0.2.3.4 && <0.3, stm >=2.5.0.0 && <2.6, stringsearch >=0.3.6.6 && <0.4, - syb >=0.7.1 && <0.8, - text >=1.2.3.1 && <1.3, - these >=1.0.1 && <1.1, - time >=1.8.0.2 && <1.9, + syb >=0.7.2.1 && <0.8, + text >=1.2.4.1 && <1.3, + these >=1.1.1.1 && <1.2, + time >=1.9.3 && <1.10, transformers >=0.5.6.2 && <0.6, transformers-base >=0.4.5.2 && <0.5, - transformers-compat >=0.6.5 && <0.7, - unordered-containers >=0.2.10.0 && <0.3, - utf8-string >=1.0.1.1 && <1.1, - vector >=0.12.0.3 && <0.13 + transformers-compat >=0.6.6 && <0.7, + unordered-containers >=0.2.13.0 && <0.3, + utf8-string >=1.0.2 && <1.1, + vector >=0.12.1.2 && <0.13 library import: defaults @@ -325,16 +325,17 @@ executable purs main-is: Main.hs ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N build-depends: - ansi-wl-pprint >=0.6.8.2 && < 0.7 - , file-embed ==0.0.11 - , http-types >=0.12.3 && < 0.13 - , network >= 3.0.1.1 && <3.1 - , optparse-applicative >=0.13.0 && <0.15 + ansi-wl-pprint >=0.6.9 && <0.7 + , exceptions >=0.10.4 && <0.11 + , file-embed >=0.0.13.0 && <0.1 + , http-types >=0.12.3 && <0.13 + , network >= 3.1.1.1 && <3.2 + , optparse-applicative >=0.15.1.0 && <0.16 , purescript - , wai ==3.* - , wai-websockets ==3.* - , warp ==3.* - , websockets >=0.9 && <0.13 + , wai >=3.2.3 && <3.3 + , wai-websockets >=3.0.1.2 && <3.1 + , warp >=3.3.14 && <3.4 + , websockets >=0.12.7.2 && <0.13 if flag(release) cpp-options: -DRELEASE else diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 8ed85cf3d1..e0f042d566 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -10,7 +10,7 @@ module Language.PureScript.CoreFn.FromJSON import Prelude.Compat import Data.Aeson -import Data.Aeson.Types (Parser, Value, listParser) +import Data.Aeson.Types (Parser, listParser) import qualified Data.Map.Strict as M import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index ddd8b77c9f..e50da26dc2 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -12,7 +12,6 @@ import Prelude.Compat import Control.Arrow ((***)) import Data.Either (isLeft) import qualified Data.Map.Strict as M -import Data.Maybe (maybe) import Data.Aeson import Data.Version (Version, showVersion) import Data.Text (Text) diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 987a41d570..e108509a7c 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -10,7 +10,6 @@ import Protolude hiding (check) import Control.Category ((>>>)) import Control.Monad.Writer.Strict (runWriterT) import Control.Monad.Supply (evalSupplyT) -import Data.Functor (($>)) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Data.String (String) diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 6300ae9990..3ea9480956 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -7,7 +7,6 @@ import Protolude hiding (moduleName) import Control.Category ((>>>)) -import Data.Functor (($>)) import qualified Data.Text as T import Language.PureScript.Docs.Types diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 1170f0fe20..6bf6fd6111 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -6,11 +6,9 @@ module Language.PureScript.Docs.Types ) where -import Protolude hiding (to, from) +import Protolude hiding (to, from, unlines) import Prelude (String, unlines, lookup) -import GHC.Generics (Generic) -import Control.DeepSeq (NFData) import Control.Arrow ((***)) import Data.Aeson ((.=)) diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 885f06c465..0149fb230d 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -27,7 +27,6 @@ module Language.PureScript.Ide.Filter import Protolude hiding (isPrefixOf, Prefix) import Control.Monad.Fail (fail) -import Data.Bifunctor (first) import Data.Aeson import Data.Text (isPrefixOf) import qualified Data.Set as Set diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index d7cca6e8a5..fc58484fda 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -20,7 +20,7 @@ import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Bifunctor (bimap) import Data.Either (partitionEithers) -import Data.Foldable (for_, minimum) +import Data.Foldable (for_) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M import Data.Maybe (fromMaybe, maybeToList) @@ -47,7 +47,6 @@ import Language.PureScript.Externs (ExternsFile, externsFileName) import Language.PureScript.Make.Monad import Language.PureScript.Make.Cache import Language.PureScript.Names -import Language.PureScript.Names (runModuleName, ModuleName) import Language.PureScript.Options hiding (codegenTargets) import Language.PureScript.Pretty.Common (SMap(..)) import qualified Paths_purescript as Paths diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 0ab244e570..3cc85a0e82 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -11,7 +11,6 @@ import Prelude.Compat hiding ((<>)) import Control.Arrow (second) -import Data.Maybe (maybe) import Data.Text (Text) import qualified Data.List.NonEmpty as NEL import qualified Data.Monoid as Monoid ((<>)) diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 7a700c78d3..63c79e6ae4 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -19,7 +19,7 @@ module Language.PureScript.Publish , getModules ) where -import Protolude hiding (stdin) +import Protolude hiding (stdin, lines) import Control.Arrow ((***)) import Control.Category ((>>>)) @@ -27,16 +27,14 @@ import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell) import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, key, asString, withString) import qualified Data.ByteString.Lazy as BL -import Data.Char (isSpace) import Data.String (String, lines) import Data.List (stripPrefix, (\\)) -import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Text as T import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Version import qualified Distribution.SPDX as SPDX -import qualified Distribution.Parsec.Class as CabalParsec +import qualified Distribution.Parsec as CabalParsec import System.Directory (doesFileExist) import System.FilePath.Glob (globDir1) diff --git a/src/Language/PureScript/Sugar/LetPattern.hs b/src/Language/PureScript/Sugar/LetPattern.hs index 58944c67f0..6db0936783 100644 --- a/src/Language/PureScript/Sugar/LetPattern.hs +++ b/src/Language/PureScript/Sugar/LetPattern.hs @@ -6,7 +6,7 @@ module Language.PureScript.Sugar.LetPattern (desugarLetPatternModule) where import Prelude.Compat -import Data.List (groupBy, concatMap) +import Data.List (groupBy) import Data.Function (on) import Language.PureScript.AST diff --git a/stack.yaml b/stack.yaml index 64592ce61b..d3ce6d6380 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-13.26 +resolver: lts-17.6 pvp-bounds: both packages: - '.' @@ -8,13 +8,7 @@ ghc-options: # Build with advanced optimizations enabled by default "$locals": -O2 extra-deps: -- serialise-0.2.2.0 -- cborg-0.2.2.0 -- happy-1.19.9 - language-javascript-0.7.0.0 -- network-3.0.1.1 -- these-1.0.1 -- semialign-1 nix: enable: false packages: @@ -28,4 +22,3 @@ flags: lib-only: true these: assoc: false - quickcheck: false diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 46502077da..2b0ec78c35 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -55,7 +55,6 @@ import Text.Regex.TDFA (Regex) import TestUtils import Test.Tasty import Test.Tasty.Hspec -import Test.Tasty (testGroup) import Test.Tasty.Golden (goldenVsString) main :: IO TestTree diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index a9f059e1ba..579ec83009 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -6,7 +6,6 @@ import Prelude.Compat import Test.Hspec -import Control.Monad (mapM_) import Control.Monad.Trans.State.Strict (evalStateT) import Data.List (sort) import qualified Data.Text as T From cc2303274ad517ea7a11785b59d4059b55d05118 Mon Sep 17 00:00:00 2001 From: Cyril Date: Sat, 3 Apr 2021 18:25:03 +0200 Subject: [PATCH 1276/1580] Remove unused Data.Foldable.foldr import (#4042) * Remove unused Data.Foldable.foldr import * Update CHANGELOG.md --- CHANGELOG.md | 4 ++++ src/Language/PureScript/CoreImp/Optimizer/TCO.hs | 1 - 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d59c2b1f9d..e64b99b67b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -29,6 +29,10 @@ Other improvements: The previous `logo.png` was not legible against a dark background (#4001). +Internal: + +* Remove unused Data.Foldable.foldr import (#4042, @kl0tl) + ## v0.14.0 ### Polykinds diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index 196f255fc5..6cc028db7a 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -6,7 +6,6 @@ import Prelude.Compat import Control.Applicative (empty, liftA2) import Control.Monad (guard) import Control.Monad.State (State, evalState, get, modify) -import Data.Foldable (foldr) import Data.Functor (($>), (<&>)) import qualified Data.Set as S import Data.Text (Text, pack) From 3e40fd1c32b9ebe21934bb8e9a2f3efa4404066a Mon Sep 17 00:00:00 2001 From: Cyril Date: Sat, 3 Apr 2021 19:15:28 +0200 Subject: [PATCH 1277/1580] Upgrade tests Bower dependencies (#4041) * Upgrade tests Bower dependencies * Update CHANGELOG.md Co-authored-by: JordanMartinez --- CHANGELOG.md | 1 + tests/purs/failing/TypedHole.out | 10 ++- .../ImplicitQualifiedImportReExport.out | 2 +- tests/support/bower.json | 75 ++++++++----------- 4 files changed, 41 insertions(+), 47 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e64b99b67b..6ca854aa96 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -31,6 +31,7 @@ Other improvements: Internal: +* Upgrade tests Bower dependencies (#4041, @kl0tl) * Remove unused Data.Foldable.foldr import (#4042, @kl0tl) ## v0.14.0 diff --git a/tests/purs/failing/TypedHole.out b/tests/purs/failing/TypedHole.out index 8f0dbc26d7..9153ca38fc 100644 --- a/tests/purs/failing/TypedHole.out +++ b/tests/purs/failing/TypedHole.out @@ -7,10 +7,12 @@ at tests/purs/failing/TypedHole.purs:8:8 - 8:13 (line 8, column 8 - line 8, colu  Effect Unit   You could substitute the hole with one of these values: -   -  Data.Monoid.mempty :: forall m. Monoid m => m -  Main.main :: Effect Unit  -   +   +  Data.Monoid.mempty :: forall m. Monoid m => m  +  Effect.Class.Console.clear :: forall m. MonadEffect m => m Unit +  Effect.Console.clear :: Effect Unit  +  Main.main :: Effect Unit  +   in value declaration main diff --git a/tests/purs/warning/ImplicitQualifiedImportReExport.out b/tests/purs/warning/ImplicitQualifiedImportReExport.out index bb1f46586f..b0667d0940 100644 --- a/tests/purs/warning/ImplicitQualifiedImportReExport.out +++ b/tests/purs/warning/ImplicitQualifiedImportReExport.out @@ -21,7 +21,7 @@ Warning 2 of 2: Module Data.Either was imported as Y with unspecified imports. As this module is being re-exported, consider using the explicit form: - import Data.Either (Either(..), choose, either, fromLeft, fromRight, hush, isLeft, isRight, note, note') as Y + import Data.Either (Either(..), choose, either, fromLeft, fromLeft', fromRight, fromRight', hush, isLeft, isRight, note, note') as Y diff --git a/tests/support/bower.json b/tests/support/bower.json index d54eaf6a21..704c043a21 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -1,47 +1,38 @@ { "name": "purescript-test-suite-support", "dependencies": { - "purescript-arrays": "5.0.0", - "purescript-assert": "4.0.0", - "purescript-bifunctors": "4.0.0", - "purescript-console": "4.1.0", - "purescript-control": "4.0.0", - "purescript-distributive": "4.0.0", - "purescript-effect": "2.0.0", - "purescript-either": "4.0.0", - "purescript-foldable-traversable": "4.0.0", - "purescript-functions": "4.0.0", - "purescript-gen": "2.0.0", - "purescript-globals": "4.0.0", - "purescript-identity": "4.0.0", - "purescript-integers": "4.0.0", - "purescript-invariant": "4.0.0", - "purescript-lazy": "4.0.0", - "purescript-lists": "5.0.0", - "purescript-math": "2.1.1", - "purescript-maybe": "4.0.0", - "purescript-newtype": "#debb7bdf5d712fb568eee16fae896fd2bc6087d0", - "purescript-nonempty": "5.0.0", - "purescript-partial": "2.0.0", - "purescript-prelude": "#d3cdad16a1479403a3f14f94190868ba5e25c657", - "purescript-psci-support": "4.0.0", - "purescript-refs": "4.1.0", - "purescript-safe-coerce": "#46b3171f71ca5052de6411e383bef6abe80b3f86", - "purescript-st": "4.0.0", - "purescript-strings": "4.0.0", - "purescript-tailrec": "4.0.0", - "purescript-tuples": "5.0.0", - "purescript-type-equality": "#8be8f46e70074dd3ace313bd15227f26166e9675", - "purescript-typelevel-prelude": "#e1b1c9a73f5407c2b1b197d4776d8939129a2444", - "purescript-unfoldable": "4.0.0", - "purescript-unsafe-coerce": "#76f1d3494a571b97a07f893a1e766f01f86f46f1" - }, - "resolutions": { - "purescript-newtype": "debb7bdf5d712fb568eee16fae896fd2bc6087d0", - "purescript-prelude": "d3cdad16a1479403a3f14f94190868ba5e25c657", - "purescript-safe-coerce": "46b3171f71ca5052de6411e383bef6abe80b3f86", - "purescript-type-equality": "8be8f46e70074dd3ace313bd15227f26166e9675", - "purescript-typelevel-prelude": "e1b1c9a73f5407c2b1b197d4776d8939129a2444", - "purescript-unsafe-coerce": "76f1d3494a571b97a07f893a1e766f01f86f46f1" + "purescript-arrays": "6.0.0", + "purescript-assert": "5.0.0", + "purescript-bifunctors": "5.0.0", + "purescript-console": "5.0.0", + "purescript-control": "5.0.0", + "purescript-distributive": "5.0.0", + "purescript-effect": "3.0.0", + "purescript-either": "5.0.0", + "purescript-foldable-traversable": "5.0.0", + "purescript-functions": "5.0.0", + "purescript-gen": "3.0.0", + "purescript-identity": "5.0.0", + "purescript-integers": "5.0.0", + "purescript-invariant": "5.0.0", + "purescript-lazy": "5.0.0", + "purescript-lists": "6.0.0", + "purescript-math": "3.0.0", + "purescript-maybe": "5.0.0", + "purescript-newtype": "4.0.0", + "purescript-nonempty": "6.0.0", + "purescript-partial": "3.0.0", + "purescript-prelude": "5.0.0", + "purescript-psci-support": "5.0.0", + "purescript-refs": "5.0.0", + "purescript-safe-coerce": "1.0.0", + "purescript-st": "5.0.0", + "purescript-strings": "5.0.0", + "purescript-tailrec": "5.0.0", + "purescript-tuples": "6.0.0", + "purescript-type-equality": "4.0.0", + "purescript-typelevel-prelude": "6.0.0", + "purescript-unfoldable": "5.0.0", + "purescript-unsafe-coerce": "5.0.0" } } From bc898395c2da556c8ec6b7c702a3dff6d2f1bb9c Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 4 Apr 2021 18:45:59 +0100 Subject: [PATCH 1278/1580] Add hints to nested constraint errors (#4004) Co-authored-by: Ryan Hendrickson --- CHANGELOG.md | 2 ++ .../PureScript/TypeChecker/Entailment.hs | 20 +++++++++---------- tests/purs/failing/2616.out | 4 ++++ tests/purs/failing/LacksWithSubGoal.out | 7 +++++++ tests/purs/failing/ProgrammableTypeErrors.out | 4 ++++ .../ProgrammableTypeErrorsTypeString.out | 4 ++++ 6 files changed, 31 insertions(+), 10 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6ca854aa96..78997f6fcf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -29,6 +29,8 @@ Other improvements: The previous `logo.png` was not legible against a dark background (#4001). +* Show the constraints that were being solved when encountering a type error (@nwolverson, #4004) + Internal: * Upgrade tests Bower dependencies (#4041, @kl0tl) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index c6e8dbf736..94303208c5 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -204,11 +204,11 @@ entails SolverOptions{..} constraint context hints = valUndefined = Var nullSourceSpan (Qualified (Just C.Prim) (Ident C.undefined)) solve :: SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr - solve con = go 0 con + solve con = go 0 hints con where - go :: Int -> SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr - go work (Constraint _ className' _ tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' - go work con'@(Constraint _ className' kinds' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do + go :: Int -> [ErrorMessageHint] -> SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr + go work _ (Constraint _ className' _ tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' + go work hints' con'@(Constraint _ className' kinds' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do -- We might have unified types by solving other constraints, so we need to -- apply the latest substitution. latestSubst <- lift . lift $ gets checkSubstitution @@ -264,7 +264,7 @@ entails SolverOptions{..} constraint context hints = currentSubst' <- lift . lift $ gets checkSubstitution let subst'' = fmap (substituteType currentSubst') subst' -- Solve any necessary subgoals - args <- solveSubgoals subst'' (tcdDependencies tcd) + args <- solveSubgoals subst'' (ErrorSolvingConstraint con') (tcdDependencies tcd) initDict <- lift . lift $ mkDictionary (tcdValue tcd) args @@ -288,7 +288,7 @@ entails SolverOptions{..} constraint context hints = Deferred -> -- Constraint was deferred, just return the dictionary unchanged, -- with no unsolved constraints. Hopefully, we can solve this later. - return (TypeClassDictionary (srcConstraint className' kinds'' tys'' conInfo) context hints) + return (TypeClassDictionary (srcConstraint className' kinds'' tys'' conInfo) context hints') where -- | When checking functional dependencies, we need to use unification to make -- sure it is safe to use the selected instance. We will unify the solved type with @@ -357,10 +357,10 @@ entails SolverOptions{..} constraint context hints = -- Create dictionaries for subgoals which still need to be solved by calling go recursively -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively. - solveSubgoals :: Matching SourceType -> Maybe [SourceConstraint] -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) (Maybe [Expr]) - solveSubgoals _ Nothing = return Nothing - solveSubgoals subst (Just subgoals) = - Just <$> traverse (go (work + 1) . mapConstraintArgsAll (map (replaceAllTypeVars (M.toList subst)))) subgoals + solveSubgoals :: Matching SourceType -> ErrorMessageHint -> Maybe [SourceConstraint] -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) (Maybe [Expr]) + solveSubgoals _ _ Nothing = return Nothing + solveSubgoals subst hint (Just subgoals) = + Just <$> traverse (rethrow (addHint hint) . go (work + 1) (hints' <> [hint]) . mapConstraintArgsAll (map (replaceAllTypeVars (M.toList subst)))) subgoals -- We need subgoal dictionaries to appear in the term somewhere -- If there aren't any then the dictionary is just undefined diff --git a/tests/purs/failing/2616.out b/tests/purs/failing/2616.out index 340de0daeb..b064b199d0 100644 --- a/tests/purs/failing/2616.out +++ b/tests/purs/failing/2616.out @@ -9,6 +9,10 @@ at tests/purs/failing/2616.purs:9:1 - 9:38 (line 9, column 1 - line 9, column 38   The instance head contains unknown type variables. Consider adding a type annotation. +while solving type class constraint +  + Data.Ord.Ord (Record r1) +  while applying a function compare of type Ord t0 => t0 -> t0 -> Ordering to argument $l6 diff --git a/tests/purs/failing/LacksWithSubGoal.out b/tests/purs/failing/LacksWithSubGoal.out index 2602362d23..4938a23c86 100644 --- a/tests/purs/failing/LacksWithSubGoal.out +++ b/tests/purs/failing/LacksWithSubGoal.out @@ -8,6 +8,13 @@ at tests/purs/failing/LacksWithSubGoal.purs:14:11 - 14:33 (line 14, column 11 -  r0    +while solving type class constraint +  + Prim.Row.Lacks "hello"  + ( k :: Int + | r0  + )  +  while applying a function union of type Lacks @Type t1 t2 => S t1 -> R t2 to argument S diff --git a/tests/purs/failing/ProgrammableTypeErrors.out b/tests/purs/failing/ProgrammableTypeErrors.out index 094744f26b..972d7ab3a5 100644 --- a/tests/purs/failing/ProgrammableTypeErrors.out +++ b/tests/purs/failing/ProgrammableTypeErrors.out @@ -7,6 +7,10 @@ at tests/purs/failing/ProgrammableTypeErrors.purs:17:13 - 17:27 (line 17, column Cannot show functions +while solving type class constraint +  + Main.MyShow (Int -> Int) +  while applying a function myShow of type MyShow t0 => t0 -> String to argument \$0 ->  diff --git a/tests/purs/failing/ProgrammableTypeErrorsTypeString.out b/tests/purs/failing/ProgrammableTypeErrorsTypeString.out index 16df92cca2..d9c33ca38c 100644 --- a/tests/purs/failing/ProgrammableTypeErrorsTypeString.out +++ b/tests/purs/failing/ProgrammableTypeErrorsTypeString.out @@ -7,6 +7,10 @@ at tests/purs/failing/ProgrammableTypeErrorsTypeString.purs:24:9 - 24:24 (line 2 Don't want to show MyType Int because. +while solving type class constraint +  + Data.Show.Show (MyType Int) +  while applying a function show of type Show t0 => t0 -> String to argument MyType 2 From 4f2517148d580f1b050263994bb28cb8162dc9f5 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 8 Apr 2021 07:52:27 -0400 Subject: [PATCH 1279/1580] Use type annotation hint only when needed (#4025) This commit changes the criteria for when the message The instance head contains unknown type variables. Consider adding a type annotation. appears in a NoInstanceFound error. Instead of using it whenever an unknown type variable appears in an instance head, now the compiler adds this hint only when every covering set of type arguments of the instance head contains an unknown type variable. (Covering sets are determined by functional dependencies, if present; otherwise, the entire set of type arguments is the one and only covering set.) The rationale is that if any covering set is already completely known, then the availability of an appropriate instance will not be changed by adding more type annotations. --- CHANGELOG.md | 2 ++ .../src/Language/PureScript/Types.hs | 6 +++++ src/Language/PureScript/Errors.hs | 24 +++++++---------- .../PureScript/TypeChecker/Entailment.hs | 19 ++++++++----- .../TypeChecker/Entailment/Coercible.hs | 2 +- tests/purs/failing/2616.out | 1 - tests/purs/failing/4024-2.out | 27 +++++++++++++++++++ tests/purs/failing/4024-2.purs | 11 ++++++++ tests/purs/failing/4024.out | 26 ++++++++++++++++++ tests/purs/failing/4024.purs | 10 +++++++ .../InstanceChainBothUnknownAndMatch.out | 1 - .../InstanceChainSkolemUnknownMatch.out | 1 - 12 files changed, 105 insertions(+), 25 deletions(-) create mode 100644 tests/purs/failing/4024-2.out create mode 100644 tests/purs/failing/4024-2.purs create mode 100644 tests/purs/failing/4024.out create mode 100644 tests/purs/failing/4024.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index 78997f6fcf..9663c2406a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -23,6 +23,8 @@ Bugfixes: * Make close punctuation printable in errors (#3982, @rhendric) +* Use type annotation hint only when needed (#4025, @rhendric) + Other improvements: * Add white outline stroke to logo in README (#4003, @ptrfrncsmrph) diff --git a/lib/purescript-ast/src/Language/PureScript/Types.hs b/lib/purescript-ast/src/Language/PureScript/Types.hs index 83be8fe8db..d7ee1315da 100644 --- a/lib/purescript-ast/src/Language/PureScript/Types.hs +++ b/lib/purescript-ast/src/Language/PureScript/Types.hs @@ -549,6 +549,12 @@ unknowns = everythingOnTypes (<>) go where go (TUnknown _ u) = IS.singleton u go _ = mempty +containsUnknowns :: Type a -> Bool +containsUnknowns = everythingOnTypes (||) go where + go :: Type a -> Bool + go TUnknown{} = True + go _ = False + eraseKindApps :: Type a -> Type a eraseKindApps = everywhereOnTypes $ \case KindApp _ ty _ -> ty diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index ad47096b1f..6e0ecac694 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -103,7 +103,9 @@ data SimpleErrorMessage | KindsDoNotUnify SourceType SourceType | ConstrainedTypeUnified SourceType SourceType | OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified Ident] - | NoInstanceFound SourceConstraint + | NoInstanceFound + SourceConstraint -- ^ constraint that could not be solved + Bool -- ^ whether eliminating unknowns with annotations might help | AmbiguousTypeVariables SourceType [Int] | UnknownClass (Qualified (ProperName 'ClassName)) | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [SourceType] @@ -448,7 +450,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t - gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con + gSimple (NoInstanceFound con unks) = NoInstanceFound <$> overConstraintArgs (traverse f) con <*> pure unks gSimple (AmbiguousTypeVariables t us) = AmbiguousTypeVariables <$> f t <*> pure us gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts @@ -856,14 +858,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , markCodeBox $ indent $ line (showQualified runProperName nm) , line "because the class was not in scope. Perhaps it was not exported." ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Fail _ [ ty ] _)) | Just box <- toTypelevelString ty = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Fail _ [ ty ] _) _) | Just box <- toTypelevelString ty = paras [ line "A custom type error occurred while solving type class constraints:" , indent box ] renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Partial _ _ - (Just (PartialConstraintData bs b)))) = + (Just (PartialConstraintData bs b))) _) = paras [ line "A case expression could not be determined to cover all inputs." , line "The following additional cases are required to cover all inputs:" , indent $ paras $ @@ -872,28 +874,22 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl : [line "..." | not b] , line "Alternatively, add a Partial constraint to the type of the enclosing value." ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Discard _ [ty] _)) = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Discard _ [ty] _) _) = paras [ line "A result of type" , markCodeBox $ indent $ prettyType ty , line "was implicitly discarded in a do notation block." , line ("You can use " <> markCode "_ <- ..." <> " to explicitly discard the result.") ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ nm _ ts _)) = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ nm _ ts _) unks) = paras [ line "No type class instance was found for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map prettyTypeAtom ts) ] , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation." - | any containsUnknowns ts + | unks ] ] - where - containsUnknowns :: Type a -> Bool - containsUnknowns = everythingOnTypes (||) go - where - go TUnknown{} = True - go _ = False renderSimpleErrorMessage (AmbiguousTypeVariables t us) = paras [ line "The inferred type" , markCodeBox $ indent $ prettyType t @@ -1629,7 +1625,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl where isUnifyHint ErrorUnifyingTypes{} = True isUnifyHint _ = False - stripRedundantHints (NoInstanceFound (Constraint _ C.Coercible _ args _)) = filter (not . isSolverHint) + stripRedundantHints (NoInstanceFound (Constraint _ C.Coercible _ args _) _) = filter (not . isSolverHint) where isSolverHint (ErrorSolvingConstraint (Constraint _ C.Coercible _ args' _)) = args == args' isSolverHint _ = False diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 94303208c5..159c185fc1 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -23,7 +23,7 @@ import Control.Monad.Writer import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.Functor (($>)) -import Data.List (minimumBy, groupBy, nubBy, sortBy) +import Data.List (findIndices, minimumBy, groupBy, nubBy, sortBy) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -224,6 +224,7 @@ entails SolverOptions{..} constraint context hints = TypeClassData { typeClassDependencies , typeClassIsEmpty + , typeClassCoveringSets } <- case M.lookup className' classesInScope of Nothing -> throwError . errorMessage $ UnknownClass className' Just tcd -> pure tcd @@ -245,7 +246,7 @@ entails SolverOptions{..} constraint context hints = Right _ -> [] -- all apart Left Nothing -> [] -- last unknown Left (Just substsTcd) -> [substsTcd] -- found a match - solution <- lift . lift $ unique kinds'' tys'' instances + solution <- lift . lift $ unique kinds'' tys'' instances (unknownsInAllCoveringSets tys'' typeClassCoveringSets) case solution of Solved substs tcd -> do -- Note that we solved something. @@ -323,16 +324,16 @@ entails SolverOptions{..} constraint context hints = (substituteType currentSubst . replaceAllTypeVars (M.toList subst) $ instKind) (substituteType currentSubst tyKind) - unique :: [SourceType] -> [SourceType] -> [(a, TypeClassDict)] -> m (EntailsResult a) - unique kindArgs tyArgs [] + unique :: [SourceType] -> [SourceType] -> [(a, TypeClassDict)] -> Bool -> m (EntailsResult a) + unique kindArgs tyArgs [] unks | solverDeferErrors = return Deferred -- We need a special case for nullary type classes, since we want -- to generalize over Partial constraints. | solverShouldGeneralize && ((null kindArgs && null tyArgs) || any canBeGeneralized kindArgs || any canBeGeneralized tyArgs) = return (Unsolved (srcConstraint className' kindArgs tyArgs conInfo)) - | otherwise = throwError . errorMessage $ NoInstanceFound (srcConstraint className' kindArgs tyArgs conInfo) - unique _ _ [(a, dict)] = return $ Solved a dict - unique _ tyArgs tcds + | otherwise = throwError . errorMessage $ NoInstanceFound (srcConstraint className' kindArgs tyArgs conInfo) unks + unique _ _ [(a, dict)] _ = return $ Solved a dict + unique _ tyArgs tcds _ | pairwiseAny overlapping (map snd tcds) = throwError . errorMessage $ OverlappingInstances className' tyArgs (tcds >>= (toList . namedInstanceIdentifier . tcdValue . snd)) | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds) @@ -381,6 +382,10 @@ entails SolverOptions{..} constraint context hints = let fields = [ ("reflectSymbol", Abs (VarBinder nullSourceSpan UnusedIdent) (Literal nullSourceSpan (StringLiteral sym))) ] in return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal nullSourceSpan (ObjectLiteral fields)) + unknownsInAllCoveringSets :: [SourceType] -> S.Set (S.Set Int) -> Bool + unknownsInAllCoveringSets tyArgs = all (\s -> any (`S.member` s) unkIndices) + where unkIndices = findIndices containsUnknowns tyArgs + -- Turn a DictionaryValue into a Expr subclassDictionaryValue :: Expr -> Qualified (ProperName 'ClassName) -> Integer -> Expr subclassDictionaryValue dict className index = diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 7e8bc4cdd7..3014a12c4c 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -527,7 +527,7 @@ insoluble -> SourceType -> MultipleErrors insoluble k a b = - errorMessage . NoInstanceFound $ srcConstraint Prim.Coercible [k] [a, b] Nothing + errorMessage $ NoInstanceFound (srcConstraint Prim.Coercible [k] [a, b] Nothing) (any containsUnknowns [a, b]) -- | Constraints of the form @Coercible a b@ can be solved if the two arguments -- are the same. Since we currently don't support higher-rank arguments in diff --git a/tests/purs/failing/2616.out b/tests/purs/failing/2616.out index b064b199d0..0cf1843381 100644 --- a/tests/purs/failing/2616.out +++ b/tests/purs/failing/2616.out @@ -7,7 +7,6 @@ at tests/purs/failing/2616.purs:9:1 - 9:38 (line 9, column 1 - line 9, column 38  Prim.RowList.RowToList r1  t2   - The instance head contains unknown type variables. Consider adding a type annotation. while solving type class constraint   diff --git a/tests/purs/failing/4024-2.out b/tests/purs/failing/4024-2.out new file mode 100644 index 0000000000..af53a798d9 --- /dev/null +++ b/tests/purs/failing/4024-2.out @@ -0,0 +1,27 @@ +Error found: +in module Main +at tests/purs/failing/4024-2.purs:10:8 - 10:13 (line 10, column 8 - line 10, column 13) + + No type class instance was found for +   +  Main.Foo t2  +  t3  +  String +   + The instance head contains unknown type variables. Consider adding a type annotation. + +while applying a function bar + of type Foo @t0 @t1 @Type t2 t3 String => Int -> String + to argument 0 +while checking that expression bar 0 + has type String +in value declaration test + +where t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + t3 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4024-2.purs b/tests/purs/failing/4024-2.purs new file mode 100644 index 0000000000..0a0cdaefa3 --- /dev/null +++ b/tests/purs/failing/4024-2.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +class Foo a b c | a -> b c, b -> a c + +bar :: forall a b. Foo a b String => Int -> String +bar _ = "" + +test :: String +test = bar 0 + diff --git a/tests/purs/failing/4024.out b/tests/purs/failing/4024.out new file mode 100644 index 0000000000..15184fe83e --- /dev/null +++ b/tests/purs/failing/4024.out @@ -0,0 +1,26 @@ +Error found: +in module Main +at tests/purs/failing/4024.purs:10:8 - 10:13 (line 10, column 8 - line 10, column 13) + + No type class instance was found for +   +  Main.Foo String +  t2  +  t3  +   + +while applying a function bar + of type Foo @Type @t0 @t1 String t2 t3 => Int -> String + to argument 0 +while checking that expression bar 0 + has type String +in value declaration test + +where t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + t3 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4024.purs b/tests/purs/failing/4024.purs new file mode 100644 index 0000000000..3ee64b827c --- /dev/null +++ b/tests/purs/failing/4024.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +class Foo a b c | a -> b c, b -> a c + +bar :: forall a b. Foo String a b => Int -> String +bar _ = "" + +test :: String +test = bar 0 diff --git a/tests/purs/failing/InstanceChainBothUnknownAndMatch.out b/tests/purs/failing/InstanceChainBothUnknownAndMatch.out index 0fb050630d..153cfa51a9 100644 --- a/tests/purs/failing/InstanceChainBothUnknownAndMatch.out +++ b/tests/purs/failing/InstanceChainBothUnknownAndMatch.out @@ -16,7 +16,6 @@ at tests/purs/failing/InstanceChainBothUnknownAndMatch.purs:17:13 - 17:55 (line  )   t4    - The instance head contains unknown type variables. Consider adding a type annotation. while applying a function same of type Same @Type @Type t0 t1 t2 => t0 -> t1 -> SProxy t2 diff --git a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out index c5e0d23286..7bb44148c0 100644 --- a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out +++ b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out @@ -8,7 +8,6 @@ at tests/purs/failing/InstanceChainSkolemUnknownMatch.purs:14:13 - 14:36 (line 1  (Proxy Int)  t4    - The instance head contains unknown type variables. Consider adding a type annotation. while applying a function same of type Same @Type @Type t0 t1 t2 => t0 -> t1 -> SProxy t2 From 2f436d18fc9389ac7faea759bf0bdad8e6ed601d Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Thu, 8 Apr 2021 04:53:40 -0700 Subject: [PATCH 1280/1580] Desugar type operators in top-level kind signatures (#4027) Fixes #4023 --- CHANGELOG.md | 2 +- src/Language/PureScript/Sugar/Operators.hs | 4 ++++ tests/purs/passing/TypeOperators.purs | 5 +++++ 3 files changed, 10 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 9663c2406a..cc1c1c3e9b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -22,7 +22,7 @@ New features: Bugfixes: * Make close punctuation printable in errors (#3982, @rhendric) - +* Desugar type operators in top-level kind signatures (#4027, @natefaubion) * Use type annotation hint only when needed (#4025, @rhendric) Other improvements: diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index ff9d4d7d5a..2538bd3117 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -328,6 +328,10 @@ updateTypes goType = (goDecl, goExpr, goBinder) TypeSynonymDeclaration sa name args <$> goType' ss ty goDecl (TypeDeclaration (TypeDeclarationData sa@(ss, _) expr ty)) = TypeDeclaration . TypeDeclarationData sa expr <$> goType' ss ty + goDecl (KindDeclaration sa@(ss, _) sigFor name ty) = + KindDeclaration sa sigFor name <$> goType' ss ty + goDecl (ExternDataDeclaration sa@(ss, _) name ty) = + ExternDataDeclaration sa name <$> goType' ss ty goDecl other = return other diff --git a/tests/purs/passing/TypeOperators.purs b/tests/purs/passing/TypeOperators.purs index 7c1362809c..8383b85d24 100644 --- a/tests/purs/passing/TypeOperators.purs +++ b/tests/purs/passing/TypeOperators.purs @@ -20,4 +20,9 @@ testParens nat = nat swap ∷ ∀ a b. a /\ b → b /\ a swap (a /\ b) = b /\ a +foreign import data NatData ∷ ∀ f g. (f ~> g) -> f Type -> g Type + +type NatKind ∷ ∀ f g. (f ~> g) -> f Type -> g Type +type NatKind k a = k a + main = log "Done" From c626f32e530d1e0aed8aba97036988c04ecac895 Mon Sep 17 00:00:00 2001 From: Cyril Date: Thu, 8 Apr 2021 13:55:08 +0200 Subject: [PATCH 1281/1580] Instantiate polymorphic kinds when unwrapping newtypes while solving Coercible constraints (#4040) * Instantiate polymorphic kinds when unwrapping newtypes while solving Coercible constraints * Update CHANGELOG.md * fixup! Instantiate polymorphic kinds when unwrapping newtypes while solving Coercible constraints --- CHANGELOG.md | 2 ++ .../TypeChecker/Entailment/Coercible.hs | 26 +++++++++++-------- tests/purs/passing/Coercible.purs | 5 ++++ 3 files changed, 22 insertions(+), 11 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index cc1c1c3e9b..f81d4bad27 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -25,6 +25,8 @@ Bugfixes: * Desugar type operators in top-level kind signatures (#4027, @natefaubion) * Use type annotation hint only when needed (#4025, @rhendric) +* Instantiate polymorphic kinds when unwrapping newtypes while solving Coercible constraints (#4040, @kl0tl) + Other improvements: * Add white outline stroke to logo in README (#4003, @ptrfrncsmrph) diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 3014a12c4c..10b38f94b7 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -633,9 +633,9 @@ unwrapNewtype env = go (0 :: Int) where when (n > 1000) $ throwError CannotUnwrapInfiniteNewtypeChain (currentModuleName, currentModuleImports) <- gets $ checkCurrentModule &&& checkCurrentModuleImports case unapplyTypes ty of - (TypeConstructor _ newtypeName, _, xs) + (TypeConstructor _ newtypeName, ks, xs) | Just (inScope, fromModuleName, tvs, newtypeCtorName, wrappedTy) <- - lookupNewtypeConstructorInScope env currentModuleName currentModuleImports newtypeName + lookupNewtypeConstructorInScope env currentModuleName currentModuleImports newtypeName ks -- We refuse to unwrap newtypes over polytypes because we don't know how -- to canonicalize them yet and we'd rather try to make progress with -- another rule. @@ -658,10 +658,13 @@ unwrapNewtype env = go (0 :: Int) where lookupNewtypeConstructor :: Environment -> Qualified (ProperName 'TypeName) + -> [SourceType] -> Maybe ([Text], ProperName 'ConstructorName, SourceType) -lookupNewtypeConstructor env qualifiedNewtypeName = do - (_, DataType Newtype tvs [(ctorName, [wrappedTy])]) <- M.lookup qualifiedNewtypeName (types env) - pure (map (\(name, _, _) -> name) tvs, ctorName, wrappedTy) +lookupNewtypeConstructor env qualifiedNewtypeName ks = do + (newtyk, DataType Newtype tvs [(ctorName, [wrappedTy])]) <- M.lookup qualifiedNewtypeName (types env) + let (kvs, _) = fromMaybe (internalError "lookupNewtypeConstructor: unkinded forall binder") $ completeBinderList newtyk + instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs ks + pure (map (\(name, _, _) -> name) tvs, ctorName, replaceAllTypeVars instantiatedKinds wrappedTy) -- | Behaves like 'lookupNewtypeConstructor' but also returns whether the -- newtype constructor is in scope and the module from which it is imported, or @@ -677,15 +680,16 @@ lookupNewtypeConstructorInScope ) ] -> Qualified (ProperName 'TypeName) + -> [SourceType] -> Maybe (Bool, Maybe ModuleName, [Text], Qualified (ProperName 'ConstructorName), SourceType) -lookupNewtypeConstructorInScope env currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName) = do +lookupNewtypeConstructorInScope env currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName) ks = do let fromModule = find isNewtypeCtorImported currentModuleImports fromModuleName = (\(_, n, _, _, _) -> n) <$> fromModule asModuleName = (\(_, _, _, n, _) -> n) =<< fromModule isDefinedInCurrentModule = newtypeModuleName == currentModuleName isImported = isJust fromModule inScope = isDefinedInCurrentModule || isImported - (tvs, ctorName, wrappedTy) <- lookupNewtypeConstructor env qualifiedNewtypeName + (tvs, ctorName, wrappedTy) <- lookupNewtypeConstructor env qualifiedNewtypeName ks pure (inScope, fromModuleName, tvs, Qualified asModuleName ctorName, wrappedTy) where isNewtypeCtorImported (_, _, importDeclType, _, exportedTypes) = @@ -780,7 +784,7 @@ canonDecomposition env a b | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b , aTyName == bTyName - , Nothing <- lookupNewtypeConstructor env aTyName = + , Nothing <- lookupNewtypeConstructor env aTyName [] = decompose env aTyName axs bxs | otherwise = empty @@ -799,8 +803,8 @@ canonDecompositionFailure env k a b | (TypeConstructor _ aTyName, _, _) <- unapplyTypes a , (TypeConstructor _ bTyName, _, _) <- unapplyTypes b , aTyName /= bTyName - , Nothing <- lookupNewtypeConstructor env aTyName - , Nothing <- lookupNewtypeConstructor env bTyName = + , Nothing <- lookupNewtypeConstructor env aTyName [] + , Nothing <- lookupNewtypeConstructor env bTyName [] = throwError $ insoluble k a b | otherwise = empty @@ -849,7 +853,7 @@ canonNewtypeDecomposition env (Just givens) a b | (TypeConstructor _ aTyName, _, axs) <- unapplyTypes a , (TypeConstructor _ bTyName, _, bxs) <- unapplyTypes b , aTyName == bTyName - , Just _ <- lookupNewtypeConstructor env aTyName = do + , Just _ <- lookupNewtypeConstructor env aTyName [] = do let givensCanDischarge = any (\given -> canDischarge given (a, b)) givens guard $ not givensCanDischarge decompose env aTyName axs bxs diff --git a/tests/purs/passing/Coercible.purs b/tests/purs/passing/Coercible.purs index 03172fc042..62e5507f92 100644 --- a/tests/purs/passing/Coercible.purs +++ b/tests/purs/passing/Coercible.purs @@ -63,6 +63,11 @@ apId1ToApId1 = coerce apId1ToApId2 :: forall a. Ap Id1 a -> Ap Id2 a apId1ToApId2 = coerce +newtype ApPolykind f = ApPolykind (f ()) + +apPolykind :: forall f. ApPolykind f -> f () +apPolykind = coerce + newtype Phantom1 a b = Phantom1 a phantom1TypeToPhantom1Symbol :: forall x (y :: Type) (z :: Symbol). Phantom1 x y -> Phantom1 x z From a6d061f365f52d699737053ba85b922da73e1fad Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 8 Apr 2021 07:55:50 -0400 Subject: [PATCH 1282/1580] Make stack pedantic by default (#4045) * Make stack pedantic by default * fixup! Make stack pedantic by default --- ci/build.sh | 2 +- purescript.cabal | 1 + stack.yaml | 2 +- 3 files changed, 3 insertions(+), 2 deletions(-) diff --git a/ci/build.sh b/ci/build.sh index 1c46b0315d..a3be3a9884 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -47,5 +47,5 @@ tar -xzf sdist-test/lib/purescript-cst/purescript-cst-*.tar.gz -C sdist-test/lib $STACK sdist . --tar-dir sdist-test; tar -xzf sdist-test/purescript-*.tar.gz -C sdist-test --strip-components=1 pushd sdist-test -$STACK build --pedantic $STACK_OPTS +$STACK build $STACK_OPTS popd diff --git a/purescript.cabal b/purescript.cabal index 889d72a4b8..07f26ee400 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -52,6 +52,7 @@ flag release default: False common defaults + ghc-options: -Wall default-language: Haskell2010 default-extensions: BangPatterns diff --git a/stack.yaml b/stack.yaml index d3ce6d6380..5c78030d88 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,7 +6,7 @@ packages: - lib/purescript-cst ghc-options: # Build with advanced optimizations enabled by default - "$locals": -O2 + "$locals": -O2 -Werror extra-deps: - language-javascript-0.7.0.0 nix: From fbcc42e7634d61bc033b4bcea8133a6c60244772 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 8 Apr 2021 08:20:16 -0400 Subject: [PATCH 1283/1580] Fix row unification with shared unknown in tails (#4048) If two row types both have the same unknown type as their tails, they shouldn't be unified unless their labels all match. --- CHANGELOG.md | 2 + src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- src/Language/PureScript/TypeChecker/Unify.hs | 2 +- tests/purs/failing/3765-kinds.out | 29 ++++++++++++++ tests/purs/failing/3765-kinds.purs | 7 ++++ tests/purs/failing/3765.out | 42 ++++++++++++++++++++ tests/purs/failing/3765.purs | 6 +++ 7 files changed, 88 insertions(+), 2 deletions(-) create mode 100644 tests/purs/failing/3765-kinds.out create mode 100644 tests/purs/failing/3765-kinds.purs create mode 100644 tests/purs/failing/3765.out create mode 100644 tests/purs/failing/3765.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index f81d4bad27..10e103529b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -27,6 +27,8 @@ Bugfixes: * Instantiate polymorphic kinds when unwrapping newtypes while solving Coercible constraints (#4040, @kl0tl) +* Fix row unification with shared unknown in tails (#4048, @rhendric) + Other improvements: * Add white outline stroke to logo in README (#4003, @ptrfrncsmrph) diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 6b92f9e059..01851705be 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -411,7 +411,7 @@ unifyKindsWithFailure onFailure = go solveUnknown a' $ rowFromList (rs, p1) (([], w1), ([], w2)) | eqType w1 w2 -> pure () - ((rs1, TUnknown _ u1), (rs2, TUnknown _ u2)) -> do + ((rs1, TUnknown _ u1), (rs2, TUnknown _ u2)) | u1 /= u2 -> do rest <- freshKind nullSourceSpan solveUnknown u1 $ rowFromList (rs2, rest) solveUnknown u2 $ rowFromList (rs1, rest) diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index e68eae2c20..ad60f85cb7 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -166,7 +166,7 @@ unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where unifyTails ([], REmptyKinded _ _) ([], REmptyKinded _ _) = return () unifyTails ([], TypeVar _ v1) ([], TypeVar _ v2) | v1 == v2 = return () unifyTails ([], Skolem _ _ s1 _ _) ([], Skolem _ _ s2 _ _) | s1 == s2 = return () - unifyTails (sd1, TUnknown a u1) (sd2, TUnknown _ u2) = do + unifyTails (sd1, TUnknown a u1) (sd2, TUnknown _ u2) | u1 /= u2 = do forM_ sd1 $ occursCheck u2 . rowListType forM_ sd2 $ occursCheck u1 . rowListType rest' <- freshTypeWithKind =<< elaborateKind (TUnknown a u1) diff --git a/tests/purs/failing/3765-kinds.out b/tests/purs/failing/3765-kinds.out new file mode 100644 index 0000000000..138b69ba35 --- /dev/null +++ b/tests/purs/failing/3765-kinds.out @@ -0,0 +1,29 @@ +Error found: +in module Main +at tests/purs/failing/3765-kinds.purs:7:28 - 7:29 (line 7, column 28 - line 7, column 29) + + Could not match kind +   +  ( a :: Int +  | t11  +  )  +   + with kind +   +  ( b :: Int +  | t11  +  )  +   + +while checking that type x + has kind { b :: Int + | t0  + }  +while inferring the kind of Tricky x x +in type synonym MkTricky + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3765-kinds.purs b/tests/purs/failing/3765-kinds.purs new file mode 100644 index 0000000000..cff2cd9ca5 --- /dev/null +++ b/tests/purs/failing/3765-kinds.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +data Tricky :: forall r. {a :: Int | r} -> {b :: Int | r} -> Type +data Tricky x y = Tricky + +type MkTricky x = Tricky x x diff --git a/tests/purs/failing/3765.out b/tests/purs/failing/3765.out new file mode 100644 index 0000000000..ea35862c0b --- /dev/null +++ b/tests/purs/failing/3765.out @@ -0,0 +1,42 @@ +Error found: +in module Main +at tests/purs/failing/3765.purs:6:23 - 6:24 (line 6, column 23 - line 6, column 24) + + Could not match type +   +  ( b :: Int +  ...  +  | t0  +  )  +   + with type +   +  ( a :: Int +  ...  +  | t0  +  )  +   + +while trying to match type   +  ( b :: Int +  ...  +  | t0  +  )  +   + with type   +  ( a :: Int +  ...  +  | t0  +  )  +   +while checking that expression x + has type { b :: Int + | t0  + }  +in value declaration mkTricky + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3765.purs b/tests/purs/failing/3765.purs new file mode 100644 index 0000000000..c58af85885 --- /dev/null +++ b/tests/purs/failing/3765.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +data Tricky r = Tricky {a :: Int | r} {b :: Int | r} + +mkTricky x = Tricky x x From bc56a90059a49d9f65f7df85fd7389faeb72de70 Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Sun, 11 Apr 2021 09:04:21 -0700 Subject: [PATCH 1284/1580] Fix wildly off kind unification positions (#4050) * Fix wildly off kind unification positions Fixes #4019 This scrubs the kind-checker's error position context when invoking kind unification from type-checking routines. When the kind-checker errors, we want to preserve the context of the unification constraint. Unfortunately, we don't have that position on hand since it's maintained implicitly as part of the type-checker stack, so this is a somewhat indirect solution. * Add fix to CHANGELOG * Remove commented code --- CHANGELOG.md | 2 ++ src/Language/PureScript/Errors.hs | 6 ++++ .../PureScript/TypeChecker/Entailment.hs | 4 +-- .../TypeChecker/Entailment/Coercible.hs | 2 +- src/Language/PureScript/TypeChecker/Kinds.hs | 14 ++++++++++ src/Language/PureScript/TypeChecker/Types.hs | 2 +- src/Language/PureScript/TypeChecker/Unify.hs | 10 +++++-- tests/purs/failing/3077.out | 2 +- tests/purs/failing/4019-1.out | 27 ++++++++++++++++++ tests/purs/failing/4019-1.purs | 26 +++++++++++++++++ tests/purs/failing/4019-2.out | 28 +++++++++++++++++++ tests/purs/failing/4019-2.purs | 26 +++++++++++++++++ tests/purs/failing/CoercibleKindMismatch.out | 2 +- .../failing/PolykindInstantiatedInstance.out | 2 +- 14 files changed, 143 insertions(+), 10 deletions(-) create mode 100644 tests/purs/failing/4019-1.out create mode 100644 tests/purs/failing/4019-1.purs create mode 100644 tests/purs/failing/4019-2.out create mode 100644 tests/purs/failing/4019-2.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index 10e103529b..c1a661f878 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -29,6 +29,8 @@ Bugfixes: * Fix row unification with shared unknown in tails (#4048, @rhendric) +* Fix wildly off kind unification positions (#4050, @natefaubion) + Other improvements: * Add white outline stroke to logo in README (#4003, @ptrfrncsmrph) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6e0ecac694..9edf550c62 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1844,6 +1844,12 @@ withPosition :: SourceSpan -> ErrorMessage -> ErrorMessage withPosition NullSourceSpan err = err withPosition pos (ErrorMessage hints se) = ErrorMessage (positionedError pos : hints) se +withoutPosition :: ErrorMessage -> ErrorMessage +withoutPosition (ErrorMessage hints se) = ErrorMessage (filter go hints) se + where + go (PositionedError _) = False + go _ = True + positionedError :: SourceSpan -> ErrorMessageHint positionedError = PositionedError . pure diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 159c185fc1..fd1481e510 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -38,7 +38,7 @@ import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.TypeChecker.Entailment.Coercible -import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds) +import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds') import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries @@ -320,7 +320,7 @@ entails SolverOptions{..} constraint context hints = for_ (lookup var tcdForAll) $ \instKind -> do tyKind <- elaborateKind ty currentSubst <- gets checkSubstitution - unifyKinds + unifyKinds' (substituteType currentSubst . replaceAllTypeVars (M.toList subst) $ instKind) (substituteType currentSubst tyKind) diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 10b38f94b7..78bc2628bf 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -279,7 +279,7 @@ unify (a, b) = do let kindOf = sequence . (id &&& elaborateKind) <=< replaceAllTypeSynonyms (a', kind) <- kindOf a (b', kind') <- kindOf b - unifyKinds kind kind' + unifyKinds' kind kind' subst <- gets checkSubstitution pure ( substituteType subst kind , substituteType subst a' diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 01851705be..5dfd00c1c3 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -10,6 +10,7 @@ module Language.PureScript.TypeChecker.Kinds , kindOfClass , kindsOfAll , unifyKinds + , unifyKinds' , subsumesKind , instantiateKind , checkKind @@ -358,6 +359,19 @@ unifyKinds = unifyKindsWithFailure $ \w1 w2 -> . errorMessage''' (fst . getAnnForType <$> [w1, w2]) $ KindsDoNotUnify w1 w2 +-- | Does not attach positions to the error node, instead relies on the +-- | local position context. This is useful when invoking kind unification +-- | outside of kind checker internals. +unifyKinds' + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => SourceType + -> SourceType + -> m () +unifyKinds' = unifyKindsWithFailure $ \w1 w2 -> + throwError + . errorMessage + $ KindsDoNotUnify w1 w2 + -- | Check the kind of a type, failing if it is not of kind *. checkTypeKind :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 4196d0e7d9..2ac50648ad 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -730,7 +730,7 @@ check' (DeferredDictionary className tys) ty = do check' (TypedValue checkType val ty1) ty2 = do (elabTy1, kind1) <- kindOf ty1 (elabTy2, kind2) <- kindOf ty2 - unifyKinds kind1 kind2 + unifyKinds' kind1 kind2 checkTypeKind ty1 kind1 ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy1 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy2 diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index ad60f85cb7..94780d66c4 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -30,7 +30,7 @@ import qualified Data.Text as T import Language.PureScript.Crash import qualified Language.PureScript.Environment as E import Language.PureScript.Errors -import Language.PureScript.TypeChecker.Kinds (elaborateKind, instantiateKind, unifyKinds) +import Language.PureScript.TypeChecker.Kinds (elaborateKind, instantiateKind, unifyKinds') import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Skolems import Language.PureScript.Types @@ -63,7 +63,11 @@ freshTypeWithKind kind = state $ \st -> do -- | Update the substitution to solve a type constraint solveType :: (MonadError MultipleErrors m, MonadState CheckState m) => Int -> SourceType -> m () -solveType u t = do +solveType u t = rethrow (onErrorMessages withoutPosition) $ do + -- We strip the position so that any errors get rethrown with the position of + -- the original unification constraint. Otherwise errors may arise from arbitrary + -- locations. We don't otherwise have the "correct" position on hand, since it + -- is maintained as part of the type-checker stack. occursCheck u t k1 <- elaborateKind t subst <- gets checkSubstitution @@ -133,7 +137,7 @@ unifyTypes t1 t2 = do t3 `unifyTypes` t5 t4 `unifyTypes` t6 unifyTypes' (KindApp _ t3 t4) (KindApp _ t5 t6) = do - t3 `unifyKinds` t5 + t3 `unifyKinds'` t5 t4 `unifyTypes` t6 unifyTypes' (Skolem _ _ _ s1 _) (Skolem _ _ _ s2 _) | s1 == s2 = return () unifyTypes' (KindedType _ ty1 _) ty2 = ty1 `unifyTypes` ty2 diff --git a/tests/purs/failing/3077.out b/tests/purs/failing/3077.out index 3cc9b55af5..15fe3f3d33 100644 --- a/tests/purs/failing/3077.out +++ b/tests/purs/failing/3077.out @@ -1,6 +1,6 @@ Error found: in module Main -at tests/purs/failing/3077.purs:11:24 - 11:30 (line 11, column 24 - line 11, column 30) +at tests/purs/failing/3077.purs:11:14 - 11:38 (line 11, column 14 - line 11, column 38) Could not match kind   diff --git a/tests/purs/failing/4019-1.out b/tests/purs/failing/4019-1.out new file mode 100644 index 0000000000..667e2d453e --- /dev/null +++ b/tests/purs/failing/4019-1.out @@ -0,0 +1,27 @@ +Error found: +in module Main +at tests/purs/failing/4019-1.purs:26:21 - 26:24 (line 26, column 21 - line 26, column 24) + + Could not match kind +   +  K1 +   + with kind +   +  K2 +   + +while trying to match type Indexed @Type @K1 @K2 Array + with type t0 +while checking that expression foo + has type t0 t1 t2 t3 +in value declaration bar + +where t0 is an unknown type + t3 is an unknown type + t1 is an unknown type + t2 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4019-1.purs b/tests/purs/failing/4019-1.purs new file mode 100644 index 0000000000..8b79a99084 --- /dev/null +++ b/tests/purs/failing/4019-1.purs @@ -0,0 +1,26 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +import Prelude + +newtype Indexed ∷ forall k1 k2 k3. (k1 → Type) → k2 → k3 → k1 → Type +newtype Indexed m x y a = Indexed (m a) + +class IxFunctor ∷ ∀ ix. (ix → ix → Type → Type) → Constraint +class IxFunctor f where + imap ∷ ∀ a b x y. (a → b) → f x y a → f x y b + +instance ixFunctorIndexed ∷ Functor m ⇒ IxFunctor (Indexed m) where + imap f (Indexed ma) = Indexed (map f ma) + +foreign import data K1 :: Type +foreign import data K2 :: Type + +foreign import data D1 :: K1 +foreign import data D2 :: K2 + +foo :: Indexed Array D1 D2 Int +foo = Indexed [1] + +bar :: Indexed Array D1 D2 Int +bar = imap identity foo diff --git a/tests/purs/failing/4019-2.out b/tests/purs/failing/4019-2.out new file mode 100644 index 0000000000..6b1ee3d2d2 --- /dev/null +++ b/tests/purs/failing/4019-2.out @@ -0,0 +1,28 @@ +Error found: +in module Main +at tests/purs/failing/4019-2.purs:26:22 - 26:60 (line 26, column 22 - line 26, column 60) + + Could not match kind +   +  K1 +   + with kind +   +  K2 +   + +while trying to match type Indexed @Type @K1 @K2 Array + with type t0 +while checking that expression Indexed [ 1 +  ]  + has type t0 t1 t2 t3 +in value declaration bar + +where t0 is an unknown type + t3 is an unknown type + t1 is an unknown type + t2 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4019-2.purs b/tests/purs/failing/4019-2.purs new file mode 100644 index 0000000000..f30ea61280 --- /dev/null +++ b/tests/purs/failing/4019-2.purs @@ -0,0 +1,26 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +import Prelude + +newtype Indexed ∷ forall k1 k2 k3. (k1 → Type) → k2 → k3 → k1 → Type +newtype Indexed m x y a = Indexed (m a) + +class IxFunctor ∷ ∀ ix. (ix → ix → Type → Type) → Constraint +class IxFunctor f where + imap ∷ ∀ a b x y. (a → b) → f x y a → f x y b + +instance ixFunctorIndexed ∷ Functor m ⇒ IxFunctor (Indexed m) where + imap f (Indexed ma) = Indexed (map f ma) + +foreign import data K1 :: Type +foreign import data K2 :: Type + +foreign import data D1 :: K1 +foreign import data D2 :: K2 + +foo :: Indexed Array D1 D2 Int +foo = Indexed [1] + +bar :: Indexed Array D1 D2 Int +bar = imap identity (Indexed [1] :: Indexed Array D1 D2 Int) diff --git a/tests/purs/failing/CoercibleKindMismatch.out b/tests/purs/failing/CoercibleKindMismatch.out index a06182d62e..30ef9b17fc 100644 --- a/tests/purs/failing/CoercibleKindMismatch.out +++ b/tests/purs/failing/CoercibleKindMismatch.out @@ -1,6 +1,6 @@ Error found: in module Main -at tests/purs/failing/CoercibleKindMismatch.purs:14:39 - 14:45 (line 14, column 39 - line 14, column 45) +at tests/purs/failing/CoercibleKindMismatch.purs:15:17 - 15:23 (line 15, column 17 - line 15, column 23) Could not match kind   diff --git a/tests/purs/failing/PolykindInstantiatedInstance.out b/tests/purs/failing/PolykindInstantiatedInstance.out index 6cad82ab29..b2f7aa07e0 100644 --- a/tests/purs/failing/PolykindInstantiatedInstance.out +++ b/tests/purs/failing/PolykindInstantiatedInstance.out @@ -1,6 +1,6 @@ Error found: in module Main -at tests/purs/failing/PolykindInstantiatedInstance.purs:12:37 - 12:42 (line 12, column 37 - line 12, column 42) +at tests/purs/failing/PolykindInstantiatedInstance.purs:12:26 - 12:42 (line 12, column 26 - line 12, column 42) Could not match kind   From cf82492d472a576d6015e8dc49f74200fb874dae Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 11 Apr 2021 20:20:57 +0100 Subject: [PATCH 1285/1580] Unused warnings (#3819) * Linter - warn on unused local names/declarations * Declarations that are used but not exported * Variables bound in let/lambda bindings, case patterns, etc which are unused * Updating CONTRIBUTORS * id3as MIT Licence grant * Don't warn on _prefixed variables * Update src/Language/PureScript/Linter.hs Co-authored-by: Harry Garrood * PR Comments * Update CHANGELOG for unused warnings Co-authored-by: Adrian Roe Co-authored-by: Harry Garrood --- CHANGELOG.md | 6 + CONTRIBUTORS.md | 5 +- src/Language/PureScript/Errors.hs | 8 + src/Language/PureScript/Linter.hs | 171 +++++++++++++++++- tests/purs/warning/2383.purs | 1 + tests/purs/warning/2411.out | 2 +- tests/purs/warning/2411.purs | 1 + .../warning/ShadowedBinderPatternGuard.purs | 2 +- tests/purs/warning/ShadowedNameParens.out | 2 +- tests/purs/warning/ShadowedNameParens.purs | 4 +- tests/purs/warning/UnusedVar.out | 60 ++++++ tests/purs/warning/UnusedVar.purs | 47 +++++ tests/purs/warning/UnusedVarDecls.out | 23 +++ tests/purs/warning/UnusedVarDecls.purs | 17 ++ tests/purs/warning/UnusedVarDo.out | 48 +++++ tests/purs/warning/UnusedVarDo.purs | 35 ++++ 16 files changed, 419 insertions(+), 13 deletions(-) create mode 100644 tests/purs/warning/UnusedVar.out create mode 100644 tests/purs/warning/UnusedVar.purs create mode 100644 tests/purs/warning/UnusedVarDecls.out create mode 100644 tests/purs/warning/UnusedVarDecls.purs create mode 100644 tests/purs/warning/UnusedVarDo.out create mode 100644 tests/purs/warning/UnusedVarDo.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index c1a661f878..2d54525462 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,6 +19,12 @@ New features: optimized, but more critically, it also means that case guards which desugar to use local functions don't break TCO. +* Unused warnings (#3819, @nwolverson) + + The compiler now emits warnings for unused names and declarations. A + declaration is considered to be unused if it is not exported and not + reachable by any of the exported declarations. + Bugfixes: * Make close punctuation printable in errors (#3982, @rhendric) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 097c037ac1..755613f315 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -86,7 +86,6 @@ If you would prefer to use different terms, please use the section below instead | [@nicodelpiano](https://github.com/nicodelpiano) | Nicolas Del Piano | [MIT license](http://opensource.org/licenses/MIT) | | [@noraesae](https://github.com/noraesae) | Hyunje Jun | [MIT license](http://opensource.org/licenses/MIT) | | [@nullobject](https://github.com/nullobject) | Josh Bassett | [MIT license](http://opensource.org/licenses/MIT) | -| [@nwolverson](https://github.com/nwolverson) | Nicholas Wolverson | [MIT license](http://opensource.org/licenses/MIT) | | [@osa1](https://github.com/osa1) | Ömer Sinan Ağacan | MIT license | | [@paf31](https://github.com/paf31) | Phil Freeman | [MIT license](http://opensource.org/licenses/MIT) | | [@parsonsmatt](https://github.com/parsonsmatt) | Matt Parsons | [MIT license](http://opensource.org/licenses/MIT) | @@ -157,6 +156,9 @@ If you would prefer to use different terms, please use the section below instead | [@leighman](http://github.com/leighman) | Jack Leigh | My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | | [@nagisa](https://github.com/nagisa) | nagisa | I hereby release my [only contribution](https://github.com/purescript/purescript/commit/80287a5d0de619862d3b4cda9c1ee276d18fdcd8) into public domain. | | [@puffnfresh](https://github.com/puffnfresh) | Brian McKenna | All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler. | +| [@nwolverson](https://github.com/nwolverson) | Nicholas Wolverson | Contributions I made during March 2020 until further notice are in employment of [Id3as Company](#companies), who own the copyright. All other contributions remain Copyright Nicholas Wolverson, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | + + ### Companies @@ -165,4 +167,5 @@ If you would prefer to use different terms, please use the section below instead | [@citizennet](https://github.com/citizennet) | CitizenNet Inc. | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright CitizenNet Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@dbenyamin-cn](https://github.com/dbenyamin-cn) | | [@slamdata](https://github.com/slamdata) | SlamData, Inc. | Speaking on behalf of SlamData for SlamData employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright SlamData Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - @jdegoes | | [@qfpl](https://github.com/qfpl) | qfpl @ Data61 / CSIRO | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Data61 / CSIRO, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@lightandlight](https://github.com/lightandlight) | +| [@id3as](https://github.com/id3as) | id3as-company Ltd. | Speaking on behalf of id3as for id3as employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright id3as-company Ltd, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - @adrianroe | | [@aeternity](https://aeternity.com/) | Aeternity Establishment | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Aeternity Establishment, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 9edf550c62..3ff817da8b 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -138,6 +138,8 @@ data SimpleErrorMessage | ShadowedName Ident | ShadowedTypeVar Text | UnusedTypeVar Text + | UnusedName Ident + | UnusedDeclaration Ident | WildcardInferredType SourceType Context | HoleInferredType Text SourceType Context (Maybe TypeSearch) | MissingTypeDeclaration Ident SourceType @@ -305,6 +307,8 @@ errorCode em = case unwrapErrorMessage em of TransitiveDctorExportError{} -> "TransitiveDctorExportError" HiddenConstructors{} -> "HiddenConstructors" ShadowedName{} -> "ShadowedName" + UnusedName{} -> "UnusedName" + UnusedDeclaration{} -> "UnusedDeclaration" ShadowedTypeVar{} -> "ShadowedTypeVar" UnusedTypeVar{} -> "UnusedTypeVar" WildcardInferredType{} -> "WildcardInferredType" @@ -1057,6 +1061,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "Name " <> markCode (showIdent nm) <> " was shadowed." renderSimpleErrorMessage (ShadowedTypeVar tv) = line $ "Type variable " <> markCode tv <> " was shadowed." + renderSimpleErrorMessage (UnusedName nm) = + line $ "Name " <> markCode (showIdent nm) <> " was introduced but not used." + renderSimpleErrorMessage (UnusedDeclaration nm) = + line $ "Declaration " <> markCode (showIdent nm) <> " was not used, and is not exported." renderSimpleErrorMessage (UnusedTypeVar tv) = line $ "Type variable " <> markCode tv <> " is ambiguous, since it is unused in the polymorphic type which introduces it." renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) = diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 68f9eaae10..8b2d54085c 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -10,30 +10,31 @@ import Control.Monad.Writer.Class import Data.Maybe (mapMaybe) import qualified Data.Set as S import Data.Text (Text) +import qualified Data.Text as Text +import Control.Monad ((<=<)) import Language.PureScript.AST -import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.Linter.Exhaustive as L import Language.PureScript.Linter.Imports as L import Language.PureScript.Names import Language.PureScript.Types +import qualified Language.PureScript.Constants.Prelude as C -- | Lint the PureScript AST. -- | --- | Right now, this pass only performs a shadowing check. +-- | Right now, this pass performs a shadowing check and a check for unused bindings. lint :: forall m. (MonadWriter MultipleErrors m) => Module -> m () -lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds +lint modl@(Module _ _ mn ds _) = do + lintUnused modl + censor (addHint (ErrorInModule mn)) $ mapM_ lintDeclaration ds + where moduleNames :: S.Set ScopedIdent moduleNames = S.fromList (map ToplevelIdent (mapMaybe getDeclIdent ds)) getDeclIdent :: Declaration -> Maybe Ident - getDeclIdent (ValueDeclaration vd) = Just (valdeclIdent vd) - getDeclIdent (ExternDeclaration _ ident _) = Just ident - getDeclIdent (TypeInstanceDeclaration _ _ _ ident _ _ _ _) = Just ident - getDeclIdent BindingGroupDeclaration{} = internalError "lint: binding groups should not be desugared yet." - getDeclIdent _ = Nothing + getDeclIdent = getIdentName <=< declName lintDeclaration :: Declaration -> m () lintDeclaration = tell . f @@ -129,3 +130,157 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl | name `S.member` s = (s, errorMessage' ss (mkError name)) | otherwise = (S.insert name s, mempty) + + +lintUnused :: forall m. (MonadWriter MultipleErrors m) => Module -> m () +lintUnused (Module modSS _ mn modDecls exports) = + censor (addHint (ErrorInModule mn)) $ do + topVars <- traverse lintDeclaration modDecls + let allVars = S.unions topVars + case exports of + Nothing -> + pure () + Just exports' + | any thisModuleRef exports' -> pure () + | otherwise -> do + let exportIds = S.fromList $ mapMaybe getValueRef exports' + expectedUsedDecls = S.fromList (mapMaybe getDeclIdent $ filter isValueDecl modDecls) `S.difference` exportIds + unused = (expectedUsedDecls `S.difference` allVars) `S.difference` rebindable + newErrs = mconcat $ map unusedDeclError $ S.toList unused + tell newErrs + pure () + where + unusedDeclError ident = errorMessage' ss $ UnusedDeclaration ident + where + ss = case filter ((== Just ident) . getDeclIdent) modDecls of + decl:_ -> declSourceSpan decl + _ -> modSS + + thisModuleRef :: DeclarationRef -> Bool + thisModuleRef (ModuleRef _ mn') = mn == mn' + thisModuleRef _ = False + + rebindable :: S.Set Ident + rebindable = S.fromList [ Ident C.bind, Ident C.discard ] + + getDeclIdent :: Declaration -> Maybe Ident + getDeclIdent = getIdentName <=< declName + + lintDeclaration :: Declaration -> m (S.Set Ident) + lintDeclaration declToLint = do + let (vars, errs) = goDecl declToLint + tell errs + pure vars + where + + goDecl :: Declaration -> (S.Set Ident, MultipleErrors) + goDecl d@(ValueDeclaration vd) = + let allExprs = concatMap unguard $ valdeclExpression vd + bindNewNames = S.fromList (concatMap binderNames $ valdeclBinders vd) + ss = declSourceSpan d + (vars, errs) = removeAndWarn ss bindNewNames $ mconcat $ map (go ss) allExprs + errs' = addHint (ErrorInValueDeclaration $ valdeclIdent vd) errs + in + (vars, errs') + + goDecl (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance decls)) = mconcat $ map goDecl decls + goDecl _ = mempty + + go :: SourceSpan -> Expr -> (S.Set Ident, MultipleErrors) + go _ (Var _ (Qualified Nothing v)) = (S.singleton v, mempty) + go _ (Var _ _) = (S.empty, mempty) + + go ss (Let _ ds e) = + let letNames = S.fromList $ concatMap declIdents ds + in removeAndWarn ss letNames $ mconcat (go ss e : map underDecl ds) + go ss (Abs binder v1) = + let newNames = S.fromList (binderNames binder) + in + removeAndWarn ss newNames $ go ss v1 + + go ss (UnaryMinus _ v1) = go ss v1 + go ss (BinaryNoParens v0 v1 v2) = go ss v0 <> go ss v1 <> go ss v2 + go ss (Parens v1) = go ss v1 + go ss (TypeClassDictionaryConstructorApp _ v1) = go ss v1 + go ss (Accessor _ v1) = go ss v1 + + go ss (ObjectUpdate obj vs) = mconcat (go ss obj : map (go ss . snd) vs) + go ss (ObjectUpdateNested obj vs) = go ss obj <> goTree vs + where + goTree (PathTree tree) = mconcat $ map (goNode . snd) (runAssocList tree) + goNode (Leaf val) = go ss val + goNode (Branch val) = goTree val + + go ss (App v1 v2) = go ss v1 <> go ss v2 + go ss (Unused v) = go ss v + go ss (IfThenElse v1 v2 v3) = go ss v1 <> go ss v2 <> go ss v3 + go ss (Case vs alts) = + let f (CaseAlternative binders gexprs) = + let bindNewNames = S.fromList (concatMap binderNames binders) + allExprs = concatMap unguard gexprs + in + removeAndWarn ss bindNewNames $ mconcat $ map (go ss) allExprs + in + mconcat $ map (go ss) vs ++ map f alts + + go ss (TypedValue _ v1 _) = go ss v1 + go ss (Do _ es) = doElts ss es Nothing + go ss (Ado _ es v1) = doElts ss es (Just v1) + + go ss (Literal _ (ArrayLiteral es)) = mconcat $ map (go ss) es + go ss (Literal _ (ObjectLiteral oo)) = mconcat $ map (go ss . snd) oo + + go _ (PositionedValue ss' _ v1) = go ss' v1 + + go _ (Literal _ _) = mempty + go _ (Op _ _) = mempty + go _ (Constructor _ _) = mempty + go _ (TypeClassDictionary _ _ _) = mempty + go _ (TypeClassDictionaryAccessor _ _) = mempty + go _ (DeferredDictionary _ _) = mempty + go _ AnonymousArgument = mempty + go _ (Hole _) = mempty + + + doElts :: SourceSpan -> [DoNotationElement] -> Maybe Expr -> (S.Set Ident, MultipleErrors) + doElts ss' (DoNotationValue e : rest) v = go ss' e <> doElts ss' rest v + doElts ss' (DoNotationBind binder e : rest) v = + let bindNewNames = S.fromList (binderNames binder) + in go ss' e <> removeAndWarn ss' bindNewNames (doElts ss' rest v) + + doElts ss' (DoNotationLet ds : rest) v = + let letNewNames = S.fromList $ concatMap declIdents ds + declRes = foldr1 (<>) (map underDecl ds) + in removeAndWarn ss' letNewNames $ declRes <> doElts ss' rest v + doElts _ (PositionedDoNotationElement ss'' _ e : rest) v = doElts ss'' (e : rest) v + doElts ss' [] (Just e) = go ss' e <> (rebindable, mempty) + doElts _ [] Nothing = (rebindable, mempty) + + declIdents :: Declaration -> [Ident] + declIdents (ValueDecl _ ident _ _ _) = [ident] + declIdents (BoundValueDeclaration _ binders _) = binderNames binders + declIdents _ = [] + + -- let f x = e -- check the x in e (but not the f) + underDecl d@(ValueDecl _ _ _ binders gexprs) = + let bindNewNames = S.fromList (concatMap binderNames binders) + allExprs = concatMap unguard gexprs + ss = declSourceSpan d + in + removeAndWarn ss bindNewNames $ foldr1 (<>) $ map (go ss) allExprs + -- let {x} = e -- no binding to check inside e + underDecl d@(BoundValueDeclaration _ _ expr) = + go (declSourceSpan d) expr + underDecl _ = (mempty, mempty) + + unguard (GuardedExpr guards expr) = map unguard' guards ++ [expr] + unguard' (ConditionGuard ee) = ee + unguard' (PatternGuard _ ee) = ee + + removeAndWarn :: SourceSpan -> S.Set Ident -> (S.Set Ident, MultipleErrors) -> (S.Set Ident, MultipleErrors) + removeAndWarn ss newNames (used, errors) = + let filteredUsed = used `S.difference` newNames + warnUnused = S.filter (not . Text.isPrefixOf "_" . runIdent) (newNames `S.difference` used) + combinedErrors = if not $ S.null warnUnused then errors <> (mconcat $ map (errorMessage' ss . UnusedName) $ S.toList warnUnused) else errors + in + (filteredUsed, combinedErrors) diff --git a/tests/purs/warning/2383.purs b/tests/purs/warning/2383.purs index 855a4d6ba4..d0ab440e29 100644 --- a/tests/purs/warning/2383.purs +++ b/tests/purs/warning/2383.purs @@ -9,4 +9,5 @@ import Effect (Effect) main :: Effect Unit main = do x <- let x = pure unit in x + let _ = x -- don't warn x is unused pure unit diff --git a/tests/purs/warning/2411.out b/tests/purs/warning/2411.out index ee60f0d0d7..8798346cda 100644 --- a/tests/purs/warning/2411.out +++ b/tests/purs/warning/2411.out @@ -1,6 +1,6 @@ Warning found: in module Main -at tests/purs/warning/2411.purs:10:7 - 10:15 (line 10, column 7 - line 10, column 15) +at tests/purs/warning/2411.purs:11:7 - 11:15 (line 11, column 7 - line 11, column 15) Name x was shadowed. diff --git a/tests/purs/warning/2411.purs b/tests/purs/warning/2411.purs index 581c606479..ddc267c106 100644 --- a/tests/purs/warning/2411.purs +++ b/tests/purs/warning/2411.purs @@ -7,6 +7,7 @@ import Effect (Effect) test :: forall m. Monad m => Int -> m Unit test x = + let _ = x in -- don't mark x unused let x = unit in pure x diff --git a/tests/purs/warning/ShadowedBinderPatternGuard.purs b/tests/purs/warning/ShadowedBinderPatternGuard.purs index fa91eaec1e..6c728e2b4f 100644 --- a/tests/purs/warning/ShadowedBinderPatternGuard.purs +++ b/tests/purs/warning/ShadowedBinderPatternGuard.purs @@ -2,6 +2,6 @@ module Main where f :: Int -> Int -f n | i <- true -- this i is shadowed +f _ | i <- true -- this i is shadowed , i <- 1234 = i diff --git a/tests/purs/warning/ShadowedNameParens.out b/tests/purs/warning/ShadowedNameParens.out index 6c879e9933..7a0e22f64c 100644 --- a/tests/purs/warning/ShadowedNameParens.out +++ b/tests/purs/warning/ShadowedNameParens.out @@ -1,6 +1,6 @@ Warning found: in module Main -at tests/purs/warning/ShadowedNameParens.purs:5:9 - 5:10 (line 5, column 9 - line 5, column 10) +at tests/purs/warning/ShadowedNameParens.purs:7:5 - 7:6 (line 7, column 5 - line 7, column 6) Name n was shadowed. diff --git a/tests/purs/warning/ShadowedNameParens.purs b/tests/purs/warning/ShadowedNameParens.purs index 9241f68840..2de23917f6 100644 --- a/tests/purs/warning/ShadowedNameParens.purs +++ b/tests/purs/warning/ShadowedNameParens.purs @@ -2,4 +2,6 @@ module Main where f :: Int -> Int -> Int -f n = \(n) -> 1 +f n = + let _ = n in + \(n) -> n diff --git a/tests/purs/warning/UnusedVar.out b/tests/purs/warning/UnusedVar.out new file mode 100644 index 0000000000..cf94079605 --- /dev/null +++ b/tests/purs/warning/UnusedVar.out @@ -0,0 +1,60 @@ +Warning 1 of 5: + + in module Main + at tests/purs/warning/UnusedVar.purs:12:19 - 12:37 (line 12, column 19 - line 12, column 37) + + Name lambdaUnused was introduced but not used. + + in value declaration unusedInLambda + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + +Warning 2 of 5: + + in module Main + at tests/purs/warning/UnusedVar.purs:16:3 - 17:4 (line 16, column 3 - line 17, column 4) + + Name letUnused was introduced but not used. + + in value declaration unusedLetName + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + +Warning 3 of 5: + + in module Main + at tests/purs/warning/UnusedVar.purs:21:3 - 21:4 (line 21, column 3 - line 21, column 4) + + Name whereUnused was introduced but not used. + + in value declaration unusedWhereIsLet + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + +Warning 4 of 5: + + in module Main + at tests/purs/warning/UnusedVar.purs:26:7 - 26:27 (line 26, column 7 - line 26, column 27) + + Name letArgUnused was introduced but not used. + + in value declaration unusedLetArgument + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + +Warning 5 of 5: + + in module Main + at tests/purs/warning/UnusedVar.purs:39:3 - 40:20 (line 39, column 3 - line 40, column 20) + + Name caseUnused was introduced but not used. + + in value declaration unusedCaseBinder + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + diff --git a/tests/purs/warning/UnusedVar.purs b/tests/purs/warning/UnusedVar.purs new file mode 100644 index 0000000000..cafd56913a --- /dev/null +++ b/tests/purs/warning/UnusedVar.purs @@ -0,0 +1,47 @@ +-- @shouldWarnWith UnusedName +-- @shouldWarnWith UnusedName +-- @shouldWarnWith UnusedName +-- @shouldWarnWith UnusedName +-- @shouldWarnWith UnusedName +module Main where + +data X = X + + +unusedInLambda :: X +unusedInLambda = (\lambdaUnused -> X) X + +unusedLetName :: X +unusedLetName = + let letUnused = X in + X + +unusedWhereIsLet :: X +unusedWhereIsLet = + X + where whereUnused = X + +unusedLetArgument :: X +unusedLetArgument = + let f x letArgUnused = x + in f X X + +notUnusedLet :: X +notUnusedLet = + let f x = f' x + f' x = f x + in + f X + + +unusedCaseBinder :: X +unusedCaseBinder = + case X of + caseUnused -> X + +unusedObjUpdate :: { foo :: X } +unusedObjUpdate = + let x = X + obj = { foo: X } + in + obj { foo = x } \ No newline at end of file diff --git a/tests/purs/warning/UnusedVarDecls.out b/tests/purs/warning/UnusedVarDecls.out new file mode 100644 index 0000000000..4e32eb0b76 --- /dev/null +++ b/tests/purs/warning/UnusedVarDecls.out @@ -0,0 +1,23 @@ +Warning 1 of 2: + + in module Main + at tests/purs/warning/UnusedVarDecls.purs:13:1 - 13:28 (line 13, column 1 - line 13, column 28) + + Name unusedArg was introduced but not used. + + in value declaration unusedArgDecl + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + +Warning 2 of 2: + + in module Main + at tests/purs/warning/UnusedVarDecls.purs:16:1 - 17:4 (line 16, column 1 - line 17, column 4) + + Declaration unusedDecl was not used, and is not exported. + + + See https://github.com/purescript/documentation/blob/master/errors/UnusedDeclaration.md for more information, + or to contribute content related to this warning. + diff --git a/tests/purs/warning/UnusedVarDecls.purs b/tests/purs/warning/UnusedVarDecls.purs new file mode 100644 index 0000000000..4f71829279 --- /dev/null +++ b/tests/purs/warning/UnusedVarDecls.purs @@ -0,0 +1,17 @@ +-- @shouldWarnWith UnusedName +-- @shouldWarnWith UnusedDeclaration + +module Main + ( unusedArgDecl + , X(..) + ) where + +data X = X + + +unusedArgDecl :: X -> X +unusedArgDecl unusedArg = X + +unusedDecl :: X +unusedDecl = + X \ No newline at end of file diff --git a/tests/purs/warning/UnusedVarDo.out b/tests/purs/warning/UnusedVarDo.out new file mode 100644 index 0000000000..7eb09e286e --- /dev/null +++ b/tests/purs/warning/UnusedVarDo.out @@ -0,0 +1,48 @@ +Warning 1 of 4: + + in module Main + at tests/purs/warning/UnusedVarDo.purs:12:3 - 12:26 (line 12, column 3 - line 12, column 26) + + Name unusedDoBind was introduced but not used. + + in value declaration unusedDoBinding + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + +Warning 2 of 4: + + in module Main + at tests/purs/warning/UnusedVarDo.purs:24:3 - 24:23 (line 24, column 3 - line 24, column 23) + + Name unusedDoLet was introduced but not used. + + in value declaration unusedDoLetBinding + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + +Warning 3 of 4: + + in module Main + at tests/purs/warning/UnusedVarDo.purs:29:3 - 29:27 (line 29, column 3 - line 29, column 27) + + Name unusedAdoBind was introduced but not used. + + in value declaration unusedAdoBinding + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + +Warning 4 of 4: + + in module Main + at tests/purs/warning/UnusedVarDo.purs:34:3 - 34:24 (line 34, column 3 - line 34, column 24) + + Name unusedAdoLet was introduced but not used. + + in value declaration unusedAdoLetBinding + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + diff --git a/tests/purs/warning/UnusedVarDo.purs b/tests/purs/warning/UnusedVarDo.purs new file mode 100644 index 0000000000..ebf2525ac9 --- /dev/null +++ b/tests/purs/warning/UnusedVarDo.purs @@ -0,0 +1,35 @@ +-- @shouldWarnWith UnusedName +-- @shouldWarnWith UnusedName +-- @shouldWarnWith UnusedName +-- @shouldWarnWith UnusedName +module Main where + +import Prelude +import Data.Maybe (Maybe) + +unusedDoBinding :: Maybe Int +unusedDoBinding = do + unusedDoBind <- pure 42 + pure 17 + +usedDoBinding :: Maybe Int +usedDoBinding = do + fine <- pure 42 + let alsoFine = 1 + pure $ fine + alsoFine + + +unusedDoLetBinding :: Maybe Int +unusedDoLetBinding = do + let unusedDoLet = 42 + pure 17 + +unusedAdoBinding :: Maybe Int +unusedAdoBinding = ado + unusedAdoBind <- pure 42 + in 17 + +unusedAdoLetBinding :: Maybe Int +unusedAdoLetBinding = ado + let unusedAdoLet = 42 + in 17 \ No newline at end of file From bbb483519a7d142f506c48c81f47bc98d119e900 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 11 Apr 2021 20:54:07 +0100 Subject: [PATCH 1286/1580] Clarify unused warnings changelog entry (#4052) --- CHANGELOG.md | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2d54525462..35d0170e95 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,11 +19,14 @@ New features: optimized, but more critically, it also means that case guards which desugar to use local functions don't break TCO. -* Unused warnings (#3819, @nwolverson) - - The compiler now emits warnings for unused names and declarations. A - declaration is considered to be unused if it is not exported and not - reachable by any of the exported declarations. +* Add warnings for unused names and values (#3819, @nwolverson) + + The compiler now emits warnings when it encounters unused names in binders + and unused value declarations. A declaration is considered to be unused if it + is not exported and is also not reachable by any of the exported + declarations. The compiler will not currently produce unused warnings about + other kinds of declarations such as data and type class declarations, but we + intend to produce warnings for these in the future as well. Bugfixes: From 3c1e50921b2c02c37f4f6f766034c6d4e39cd3f8 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 12 Apr 2021 16:06:10 -0400 Subject: [PATCH 1287/1580] Fix kinded declaration reordering in desugaring (#4047) The type checker assumes that type class and type synonym definitions always precede their use (circular references are not allowed between these declarations). This constraint needs to be enforced by the `createBindingGroups` phase in desugaring, regardless of whether the declaration has a kind or is being referenced by a kind declaration. Failing to do so resulted in one issue where type synonyms were being expanded out of order with surprising consequences, and another where a superclass was not known when its subclass was being checked. --- CHANGELOG.md | 2 ++ .../PureScript/Sugar/BindingGroups.hs | 27 ++++++++++++------- tests/purs/failing/RowsInKinds.out | 2 +- tests/purs/passing/4035.purs | 14 ++++++++++ tests/purs/passing/4035/Other.purs | 4 +++ tests/purs/passing/4038.purs | 11 ++++++++ 6 files changed, 50 insertions(+), 10 deletions(-) create mode 100644 tests/purs/passing/4035.purs create mode 100644 tests/purs/passing/4035/Other.purs create mode 100644 tests/purs/passing/4038.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index 35d0170e95..c6ebd9212f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -38,6 +38,8 @@ Bugfixes: * Fix row unification with shared unknown in tails (#4048, @rhendric) +* Fix kinded declaration reordering in desugaring (#4047, @rhendric) + * Fix wildly off kind unification positions (#4050, @natefaubion) Other improvements: diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index fa3bafd0d1..c7dfe911ec 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -16,7 +16,7 @@ import Control.Monad ((<=<), guard) import Control.Monad.Error.Class (MonadError(..)) import Data.Graph -import Data.List (intersect) +import Data.List (intersect, (\\)) import Data.Foldable (find) import Data.Maybe (isJust, mapMaybe) import qualified Data.List.NonEmpty as NEL @@ -73,21 +73,29 @@ createBindingGroups moduleName = mapM f <=< handleDecls handleDecls :: [Declaration] -> m [Declaration] handleDecls ds = do let values = mapMaybe (fmap (fmap extractGuardedExpr) . getValueDeclaration) ds - kindDecls = fmap (,VertexKindSignature) $ filter (\a -> isKindDecl a || isExternDataDecl a) ds - dataDecls = fmap (,VertexDefinition) $ filter (\a -> isDataDecl a || isTypeSynonymDecl a || isTypeClassDecl a) ds + kindDecls = fmap (,VertexKindSignature) $ filter isKindDecl ds + dataDecls = fmap (,VertexDefinition) $ filter (\a -> isDataDecl a || isExternDataDecl a || isTypeSynonymDecl a || isTypeClassDecl a) ds kindSigs = fmap (declTypeName . fst) kindDecls typeSyns = fmap declTypeName $ filter isTypeSynonymDecl ds + nonTypeSynKindSigs = kindSigs \\ typeSyns allDecls = kindDecls ++ dataDecls allProperNames = fmap (declTypeName . fst) allDecls mkVert (d, vty) = let names = usedTypeNames moduleName d `intersect` allProperNames name = declTypeName d - -- If a dependency has a kind signature, than that's all we need to depend on, except - -- in the case that we are defining a kind signature and using a type synonym. In order - -- to expand the type synonym, we must depend on the synonym declaration itself. + -- If a dependency of a kind signature has a kind signature, than that's all we need to + -- depend on, except in the case that we are using a type synonym. In order to expand + -- the type synonym, we must depend on the synonym declaration itself. + -- + -- Arguably, type declarations (as opposed to just kind signatures) could also depend + -- on kind signatures when present. Attempting this caused one known issue (#4038); the + -- type checker might not expect type declarations not to be preceded or grouped by + -- their actual dependencies in all cases. But in principle, if done carefully, this + -- approach could be used to reduce the number or size of data binding group cycles. + -- (It's critical that kind signatures not appear in groups, which is why they get + -- special treatment.) vtype n - | vty == VertexKindSignature && n `elem` typeSyns = VertexDefinition - | n `elem` kindSigs = VertexKindSignature + | vty == VertexKindSignature && n `elem` nonTypeSynKindSigs = VertexKindSignature | otherwise = VertexDefinition deps = fmap (\n -> (n, vtype n)) names self @@ -228,7 +236,8 @@ toBindingGroup moduleName (CyclicSCC ds') = do toDataBindingGroup :: MonadError MultipleErrors m - => SCC (Declaration, (ProperName 'TypeName, VertexType), [(ProperName 'TypeName, VertexType)]) + => Ord a + => SCC (Declaration, (ProperName 'TypeName, a), [(ProperName 'TypeName, a)]) -> m Declaration toDataBindingGroup (AcyclicSCC (d, _, _)) = return d toDataBindingGroup (CyclicSCC ds') diff --git a/tests/purs/failing/RowsInKinds.out b/tests/purs/failing/RowsInKinds.out index 5e32d41b44..a226e71125 100644 --- a/tests/purs/failing/RowsInKinds.out +++ b/tests/purs/failing/RowsInKinds.out @@ -5,7 +5,7 @@ at tests/purs/failing/RowsInKinds.purs:14:16 - 14:17 (line 14, column 16 - line Could not match kind    ( z :: Type -  | t24  +  | t25   )    with kind diff --git a/tests/purs/passing/4035.purs b/tests/purs/passing/4035.purs new file mode 100644 index 0000000000..2c40f30ce4 --- /dev/null +++ b/tests/purs/passing/4035.purs @@ -0,0 +1,14 @@ +module Main where + +import Effect.Console (log) +import Other (Id) + +type Alias = Int + +type Wrapped :: forall k. (Type -> k) -> Row k -> Row k +type Wrapped f r = (key :: f Alias | r) + +type Unwrapped :: Row Type -> Row Type +type Unwrapped r = Wrapped Id r + +main = log "Done" diff --git a/tests/purs/passing/4035/Other.purs b/tests/purs/passing/4035/Other.purs new file mode 100644 index 0000000000..055b3c7831 --- /dev/null +++ b/tests/purs/passing/4035/Other.purs @@ -0,0 +1,4 @@ +module Other where + +type Id :: forall k. k -> k +type Id a = a diff --git a/tests/purs/passing/4038.purs b/tests/purs/passing/4038.purs new file mode 100644 index 0000000000..e25ec5c383 --- /dev/null +++ b/tests/purs/passing/4038.purs @@ -0,0 +1,11 @@ +module Main where + +import Effect.Console (log) + +class A :: Constraint +class A + +class B :: Constraint +class A <= B + +main = log "Done" From 06e38cb3d77ae3474f3f3ff6e74ae08253265fe0 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 12 Apr 2021 22:07:29 +0100 Subject: [PATCH 1288/1580] Require rebuild if any codegen targets are outdated (#4053) * Require rebuild if any codegen targets are outdated Fixes #3911, #3914: prevents an issue where a module would be considered up-to-date if only some of the requested codegen targets were up-to-date (as opposed to all of them). * Sleep for a second in between compiler invocations * Code review comments --- CHANGELOG.md | 7 ++ src/Language/PureScript/Make/Actions.hs | 37 +++++++++-- tests/TestMake.hs | 87 ++++++++++++++++++++++--- 3 files changed, 115 insertions(+), 16 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c6ebd9212f..9e47136afd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -50,6 +50,13 @@ Other improvements: * Show the constraints that were being solved when encountering a type error (@nwolverson, #4004) +* Fix incorrect incremental builds with different `--codegen` options (#3911, #3914, @hdgarrood) + + This bug meant that after invoking the compiler with different `--codegen` + options, it was easy to end up with (for example) an outdated docs.json or + corefn.json file in your output directory which would be incorrectly + considered up-to-date by the compiler. + Internal: * Upgrade tests Bower dependencies (#4041, @kl0tl) diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index fc58484fda..2931ae2191 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -87,9 +87,13 @@ data MakeActions m = MakeActions -- The content hash is returned as a monadic action so that the file does not -- have to be read if it's not necessary. , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime) - -- ^ Get the timestamp for the output files for a module. This should be the - -- timestamp for the oldest modified file, or 'Nothing' if any of the required - -- output files are missing. + -- ^ Get the time this module was last compiled, provided that all of the + -- requested codegen targets were also produced then. The defaultMakeActions + -- implementation uses the modification time of the externs file, because the + -- externs file is written first and we always write one. If there is no + -- externs file, or if any of the requested codegen targets were not produced + -- the last time this module was compiled, this function must return Nothing; + -- this indicates that the module will have to be recompiled. , readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile) -- ^ Read the externs file for a module as a string and also return the actual -- path for the file. @@ -178,9 +182,30 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime) getOutputTimestamp mn = do codegenTargets <- asks optionsCodegenTargets - let outputPaths = [outputFilename mn externsFileName] <> fmap (targetFilename mn) (S.toList codegenTargets) - timestamps <- traverse getTimestampMaybe outputPaths - pure $ fmap minimum . NEL.nonEmpty =<< sequence timestamps + mExternsTimestamp <- getTimestampMaybe (outputFilename mn externsFileName) + case mExternsTimestamp of + Nothing -> + -- If there is no externs file, we will need to compile the module in + -- order to produce one. + pure Nothing + Just externsTimestamp -> + case NEL.nonEmpty (fmap (targetFilename mn) (S.toList codegenTargets)) of + Nothing -> + -- If the externs file exists and no other codegen targets have + -- been requested, then we can consider the module up-to-date + pure (Just externsTimestamp) + Just outputPaths -> do + -- If any of the other output paths are nonexistent or older than + -- the externs file, then they should be considered outdated, and + -- so the module will need rebuilding. + mmodTimes <- traverse getTimestampMaybe outputPaths + pure $ case sequence mmodTimes of + Nothing -> + Nothing + Just modTimes -> + if externsTimestamp <= minimum modTimes + then Just externsTimestamp + else Nothing readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile) readExterns mn = do diff --git a/tests/TestMake.hs b/tests/TestMake.hs index dadee27fd7..d6bfa0e62e 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -9,6 +9,7 @@ import Prelude.Compat import qualified Language.PureScript as P import qualified Language.PureScript.CST as CST +import Control.Concurrent (threadDelay) import Control.Monad import Control.Exception (tryJust) import Control.Monad.IO.Class (liftIO) @@ -166,17 +167,73 @@ spec = do compileAllowingFailures [modulePath] `shouldReturn` moduleNames ["Module"] compileAllowingFailures [modulePath] `shouldReturn` moduleNames ["Module"] + it "recompiles if docs are requested but not up to date" $ do + let modulePath = sourcesDir "Module.purs" + moduleContent1 = "module Module where\nx :: Int\nx = 1" + moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" + optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] } + go opts = compileWithOptions opts [modulePath] >>= assertSuccess + oneSecond = 10^(6::Int) -- microseconds. + + writeFileWithTimestamp modulePath timestampA moduleContent1 + go optsWithDocs `shouldReturn` moduleNames ["Module"] + writeFileWithTimestamp modulePath timestampB moduleContent2 + -- See Note [Sleeping to avoid flaky tests] + threadDelay oneSecond + go P.defaultOptions `shouldReturn` moduleNames ["Module"] + -- Since the existing docs.json is now outdated, the module should be + -- recompiled. + go optsWithDocs `shouldReturn` moduleNames ["Module"] + + it "recompiles if corefn is requested but not up to date" $ do + let modulePath = sourcesDir "Module.purs" + moduleContent1 = "module Module where\nx :: Int\nx = 1" + moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" + optsCorefnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn } + go opts = compileWithOptions opts [modulePath] >>= assertSuccess + oneSecond = 10^(6::Int) -- microseconds. + + writeFileWithTimestamp modulePath timestampA moduleContent1 + go optsCorefnOnly `shouldReturn` moduleNames ["Module"] + writeFileWithTimestamp modulePath timestampB moduleContent2 + -- See Note [Sleeping to avoid flaky tests] + threadDelay oneSecond + go P.defaultOptions `shouldReturn` moduleNames ["Module"] + -- Since the existing corefn.json is now outdated, the module should be + -- recompiled. + go optsCorefnOnly `shouldReturn` moduleNames ["Module"] + +-- Note [Sleeping to avoid flaky tests] +-- +-- One of the things we want to test here is that all requested output files +-- (via the --codegen CLI option) must be up to date if we are to skip +-- recompiling a particular module. Since we check for outdatedness by +-- comparing the timestamp of the output files (eg. corefn.json, index.js) to +-- the timestamp of the externs file, this check is susceptible to flakiness +-- if the timestamp resolution is sufficiently coarse. To get around this, we +-- delay for one second. +-- +-- Note that most of the compiler behaviour here doesn't depend on file +-- timestamps (instead, content hashes are usually more important) and so +-- sleeping should not be necessary in most of these tests. +-- +-- See also discussion on https://github.com/purescript/purescript/pull/4053 + rimraf :: FilePath -> IO () rimraf = void . tryJust (guard . isDoesNotExistError) . removeDirectoryRecursive --- | Returns a set of the modules for which a rebuild was attempted, including --- the make result. -compileWithResult :: [FilePath] -> IO (Either P.MultipleErrors [P.ExternsFile], Set P.ModuleName) -compileWithResult input = do +-- | Compile a group of modules, returning a set of the modules for which a +-- rebuild was attempted, allowing the caller to set the compiler options and +-- including the make result in the return value. +compileWithOptions :: + P.Options -> + [FilePath] -> + IO (Either P.MultipleErrors [P.ExternsFile], Set P.ModuleName) +compileWithOptions opts input = do recompiled <- newMVar Set.empty moduleFiles <- readUTF8FilesT input - (makeResult, _) <- P.runMake P.defaultOptions $ do + (makeResult, _) <- P.runMake opts $ do ms <- CST.parseModulesFromFiles id moduleFiles let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms foreigns <- P.inferForeignModules filePathMap @@ -190,17 +247,27 @@ compileWithResult input = do recompiledModules <- readMVar recompiled pure (makeResult, recompiledModules) --- | Compile, returning the set of modules which were rebuilt, and failing if --- any errors occurred. -compile :: [FilePath] -> IO (Set P.ModuleName) -compile input = do - (result, recompiled) <- compileWithResult input +-- | Compile a group of modules using the default options, and including the +-- make result in the return value. +compileWithResult :: + [FilePath] -> + IO (Either P.MultipleErrors [P.ExternsFile], Set P.ModuleName) +compileWithResult = compileWithOptions P.defaultOptions + +assertSuccess :: (Either P.MultipleErrors a, Set P.ModuleName) -> IO (Set P.ModuleName) +assertSuccess (result, recompiled) = case result of Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) Right _ -> pure recompiled +-- | Compile, returning the set of modules which were rebuilt, and failing if +-- any errors occurred. +compile :: [FilePath] -> IO (Set P.ModuleName) +compile input = + compileWithResult input >>= assertSuccess + compileAllowingFailures :: [FilePath] -> IO (Set P.ModuleName) compileAllowingFailures input = fmap snd (compileWithResult input) From 112c832fefd1016fd93e848f625750c7b262af16 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 12 Apr 2021 17:43:52 -0400 Subject: [PATCH 1289/1580] Pedantically rename some variables (#4055) --- tests/TestMake.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/TestMake.hs b/tests/TestMake.hs index d6bfa0e62e..e3f312a84e 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -30,7 +30,7 @@ import Test.Tasty import Test.Tasty.Hspec utcMidnightOnDate :: Integer -> Int -> Int -> UTCTime -utcMidnightOnDate day month year = UTCTime (fromGregorian day month year) (secondsToDiffTime 0) +utcMidnightOnDate year month day = UTCTime (fromGregorian year month day) (secondsToDiffTime 0) timestampA, timestampB, timestampC, timestampD, timestampE, timestampF :: UTCTime timestampA = utcMidnightOnDate 2019 1 1 From bf4076a682e500279916b49ab4cf03855d8f040f Mon Sep 17 00:00:00 2001 From: Nathan Faubion Date: Wed, 14 Apr 2021 09:22:08 -0700 Subject: [PATCH 1290/1580] Fix printing of hiding imports (#4058) * Fix printing of hiding imports * Update changelog * Exercise multiple hiding formatting in ide test --- CHANGELOG.md | 1 + src/Language/PureScript/Errors.hs | 2 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 6 +++--- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 9e47136afd..1735d04e27 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -33,6 +33,7 @@ Bugfixes: * Make close punctuation printable in errors (#3982, @rhendric) * Desugar type operators in top-level kind signatures (#4027, @natefaubion) * Use type annotation hint only when needed (#4025, @rhendric) +* Fix pretty printing of "hiding" imports (#4058, @natefaubion) * Instantiate polymorphic kinds when unwrapping newtypes while solving Coercible constraints (#4040, @kl0tl) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 3ff817da8b..9ec7e317b8 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1676,7 +1676,7 @@ prettyPrintImport mn idt qual = let i = case idt of Implicit -> runModuleName mn Explicit refs -> runModuleName mn <> " (" <> T.intercalate ", " (mapMaybe prettyPrintRef refs) <> ")" - Hiding refs -> runModuleName mn <> " hiding (" <> T.intercalate "," (mapMaybe prettyPrintRef refs) <> ")" + Hiding refs -> runModuleName mn <> " hiding (" <> T.intercalate ", " (mapMaybe prettyPrintRef refs) <> ")" in i <> maybe "" (\q -> " as " <> runModuleName q) qual prettyPrintRef :: DeclarationRef -> Maybe Text diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index c9c549edb5..841588a32f 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -35,7 +35,7 @@ hidingFile :: [Text] hidingFile = [ "module Main where" , "import Prelude" - , "import Data.Maybe hiding (maybe)" + , "import Data.Maybe hiding (maybe, maybe')" , "" , "myFunc x y = x + y" ] @@ -138,10 +138,10 @@ spec = do , "" , "import Data.Map as Map" ] - it "adds a qualified import and maintains proper grouping for implicit hiding imports" $ + it "adds a qualified import and maintains proper grouping and formatting for implicit hiding imports" $ shouldBe (addQualifiedImport' hidingFileImports (Test.mn "Data.Map") (Test.mn "Map")) - [ "import Data.Maybe hiding (maybe)" + [ "import Data.Maybe hiding (maybe, maybe')" , "import Prelude" , "" , "import Data.Map as Map" From 1450554d5ea2767cccfe7c6c588d71165144561a Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 15 Apr 2021 15:41:11 +0100 Subject: [PATCH 1291/1580] Update INSTALL.md (#4059) `psvm` was marked as non-maintained in Sep 2019 so I think we can probably take it off this list. --- INSTALL.md | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/INSTALL.md b/INSTALL.md index 32f6248653..c26c322a32 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -6,12 +6,12 @@ alternatively Stack Overflow. ## Requirements -The PureScript compiler is built using GHC 8.6.4, and should be able to run on any operating system supported by GHC 8.6.4. In particular: +The PureScript compiler is built using GHC 8.10.4, and should be able to run on any operating system supported by GHC 8.10.4. In particular: * for Windows users, versions predating Vista are not officially supported, * for macOS / OS X users, versions predating Mac OS X 10.7 (Lion) are not officially supported. -See also for more details about the operating systems which GHC 8.6.4 supports. +See also for more details about the operating systems which GHC 8.10.4 supports. ## Official prebuilt binaries @@ -25,7 +25,6 @@ There are several other distributions of the PureScript compiler available, whic * NPM: `npm install -g purescript` * Homebrew (for macOS): `brew install purescript` -* [PSVM](https://github.com/ThomasCrevoisier/psvm-js): `npm install -g psvm` ## Compiling from source From 82064b46908ef1857dea82186d2d6859446048eb Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Thu, 15 Apr 2021 15:41:22 +0100 Subject: [PATCH 1292/1580] Update LICENSE for v0.14.1 (#4060) I had to add ghc-boot-th as an excluded package in the script because it's in the same category as `rts`, in the sense that it's not a real package but just part of GHC. --- LICENSE | 795 ++++++++++++++++++++++++++++------ license-generator/generate.hs | 1 + 2 files changed, 656 insertions(+), 140 deletions(-) diff --git a/LICENSE b/LICENSE index bc9cfd2a6e..3c5e36198a 100644 --- a/LICENSE +++ b/LICENSE @@ -16,6 +16,7 @@ PureScript uses the following Haskell library packages. Their license files foll Cabal Glob + HUnit SHA StateVar aeson @@ -26,11 +27,16 @@ PureScript uses the following Haskell library packages. Their license files foll ansi-wl-pprint appar array + asn1-encoding + asn1-parse + asn1-types + assoc async attoparsec auto-update base base-compat + base-compat-batteries base-orphans base64-bytestring basement @@ -46,9 +52,9 @@ PureScript uses the following Haskell library packages. Their license files foll bytestring bytestring-builder cabal-doctest + call-stack case-insensitive cborg - cereal cheapskate clock colour @@ -66,6 +72,7 @@ PureScript uses the following Haskell library packages. Their license files foll data-default-instances-containers data-default-instances-dlist data-default-instances-old-locale + data-fix data-ordlist deepseq directory @@ -73,22 +80,24 @@ PureScript uses the following Haskell library packages. Their license files foll dlist easy-file edit-distance + enclosed-exceptions entropy exceptions fast-logger file-embed filepath fsnotify - ghc-boot-th ghc-prim half happy hashable haskeline - hfsevents + hinotify + hourglass http-date http-types http2 + indexed-traversable integer-gmp integer-logarithms iproute @@ -117,6 +126,7 @@ PureScript uses the following Haskell library packages. Their license files foll parallel parsec pattern-arrows + pem pretty primitive process @@ -134,12 +144,14 @@ PureScript uses the following Haskell library packages. Their license files foll semigroupoids semigroups serialise + shelly simple-sendfile sourcemap split stm stm-chans streaming-commons + strict stringsearch syb tagged @@ -148,12 +160,15 @@ PureScript uses the following Haskell library packages. Their license files foll terminfo text th-abstraction + th-compat these time - time-locale-compat + time-compat + time-manager transformers transformers-base transformers-compat + type-equality typed-process uniplate unix @@ -175,6 +190,7 @@ PureScript uses the following Haskell library packages. Their license files foll warp websockets word8 + x509 xss-sanitize zlib @@ -243,6 +259,38 @@ Glob LICENSE file: OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +HUnit LICENSE file: + + HUnit is Copyright (c) Dean Herington, 2002, all rights reserved, + and is distributed as free software under the following license. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + - Redistributions of source code must retain the above copyright + notice, this list of conditions, and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright + notice, this list of conditions, and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + - The names of the copyright holders may not be used to endorse or + promote products derived from this software without specific prior + written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY + EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR + PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR + BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE + OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN + IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + SHA LICENSE file: Copyright (c) 2008, Galois, Inc. @@ -309,7 +357,7 @@ StateVar LICENSE file: aeson LICENSE file: - Copyright (c) 2011, MailRank, Inc. + Copyright (c) 2011, MailRank, Inc. 2014-2021 Aeson project contributors All rights reserved. @@ -600,6 +648,130 @@ array LICENSE file: ----------------------------------------------------------------------------- + +asn1-encoding LICENSE file: + + Copyright (c) 2010-2013 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +asn1-parse LICENSE file: + + Copyright (c) 2010-2013 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +asn1-types LICENSE file: + + Copyright (c) 2010-2013 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +assoc LICENSE file: + + Copyright (c) 2017, Oleg Grenrus + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + async LICENSE file: Copyright (c) 2012, Simon Marlow @@ -797,6 +969,28 @@ base-compat LICENSE file: OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +base-compat-batteries LICENSE file: + + Copyright (c) 2012-2018 Simon Hengel and Ryan Scott + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + THE SOFTWARE. + base-orphans LICENSE file: Copyright (c) 2015-2017 Simon Hengel , João Cristóvão , Ryan Scott @@ -856,7 +1050,7 @@ base64-bytestring LICENSE file: basement LICENSE file: Copyright (c) 2015-2017 Vincent Hanquez - Copyright (c) 2017 Foundation Maintainers + Copyright (c) 2017-2019 Foundation Maintainers All rights reserved. @@ -1263,6 +1457,28 @@ cabal-doctest LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +call-stack LICENSE file: + + Copyright (c) 2016 Simon Hengel + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + THE SOFTWARE. + case-insensitive LICENSE file: Copyright (c) 2011-2013 Bas van Dijk @@ -1333,39 +1549,6 @@ cborg LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -cereal LICENSE file: - - Copyright (c) Lennart Kolmodin, Galois, Inc. - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS - OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - cheapskate LICENSE file: Copyright (c) 2013, John MacFarlane @@ -1851,6 +2034,39 @@ data-default-instances-old-locale LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +data-fix LICENSE file: + + Copyright Anton Kholomiov 2010 + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Anton Kholomiov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + data-ordlist LICENSE file: Copyright (c) 2009-2010, Melding Monads @@ -2003,7 +2219,7 @@ distributive LICENSE file: dlist LICENSE file: - Copyright (c) 2006-2009 Don Stewart, 2013-2016 Sean Leather + Copyright (c) 2006-2009 Don Stewart, 2013-2019 Sean Leather All rights reserved. @@ -2092,6 +2308,29 @@ edit-distance LICENSE file: IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +enclosed-exceptions LICENSE file: + + Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + entropy LICENSE file: Copyright (c) Thomas DuBuisson @@ -2285,40 +2524,6 @@ fsnotify LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -ghc-boot-th LICENSE file: - - The Glasgow Haskell Compiler License - - Copyright 2002, The University Court of the University of Glasgow. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - - Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - - - Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - - - Neither name of the University nor the names of its contributors may be - used to endorse or promote products derived from this software without - specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF - GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - DAMAGE. - ghc-prim LICENSE file: This library (libraries/ghc-prim) is derived from code from several @@ -2481,62 +2686,95 @@ hashable LICENSE file: haskeline LICENSE file: - Copyright 2007-2009, Judah Jacobson. - All Rights Reserved. + Copyright 2007 Judah Jacobson Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - - Redistribution of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. + 1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. - - Redistribution in binary form must reproduce the above copyright notice, + 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY - EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + 3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE - USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -hfsevents LICENSE file: +hinotify LICENSE file: - Copyright (c) 2012, Luite Stegeman + Copyright (c) Lennart Kolmodin All rights reserved. Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: + modification, are permitted provided that the following conditions + are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. - * Neither the name of Luite Stegeman nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + +hourglass LICENSE file: + + Copyright (c) 2014 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. http-date LICENSE file: @@ -2623,16 +2861,45 @@ http2 LICENSE file: contributors may be used to endorse or promote products derived from this software without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS - FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + +indexed-traversable LICENSE file: + + Copyright 2012-2016 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. @@ -2923,7 +3190,8 @@ microlens-ghc LICENSE file: microlens-mtl LICENSE file: Copyright (c) 2013-2016 Edward Kmett, - 2015-2016 Artyom + 2015-2016 Artyom Kazak, + 2018 Monadfix All rights reserved. @@ -2938,7 +3206,7 @@ microlens-mtl LICENSE file: disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Artyom nor the names of other + * Neither the name of Monadfix nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. @@ -2991,7 +3259,8 @@ microlens-platform LICENSE file: microlens-th LICENSE file: - Copyright (c) 2013-2016 Eric Mertens, Edward Kmett, Artyom + Copyright (c) 2013-2016 Eric Mertens, Edward Kmett, Artyom Kazak + 2018 Monadfix All rights reserved. @@ -3006,7 +3275,7 @@ microlens-th LICENSE file: disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Artyom nor the names of other + * Neither the name of Monadfix nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. @@ -3541,6 +3810,36 @@ pattern-arrows LICENSE file: IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +pem LICENSE file: + + Copyright (c) 2010-2018 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + pretty LICENSE file: This library (libraries/pretty) is derived from code from @@ -3684,7 +3983,7 @@ process LICENSE file: protolude LICENSE file: - Copyright (c) 2016-2017, Stephen Diehl + Copyright (c) 2016-2020, Stephen Diehl Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to @@ -3738,6 +4037,38 @@ psqueues LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +purescript-ast LICENSE file: + + Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other + contributors + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + + 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +purescript-cst LICENSE file: + + Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other + contributors + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + + 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + random LICENSE file: This library (libraries/base) is derived from code from two @@ -3869,7 +4200,7 @@ resourcet LICENSE file: safe LICENSE file: - Copyright Neil Mitchell 2007-2018. + Copyright Neil Mitchell 2007-2020. All rights reserved. Redistribution and use in source and binary forms, with or without @@ -4057,6 +4388,39 @@ serialise LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +shelly LICENSE file: + + Copyright (c) 2017, Petr Rockai + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Petr Rockai nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + simple-sendfile LICENSE file: Copyright (c) 2009, IIJ Innovation Institute Inc. @@ -4248,6 +4612,35 @@ streaming-commons LICENSE file: OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +strict LICENSE file: + + Copyright (c) Roman Leshchinskiy 2006-2007 + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + stringsearch LICENSE file: Copyright (c)2010, Daniel Fischer @@ -4472,28 +4865,31 @@ template-haskell LICENSE file: terminfo LICENSE file: Copyright 2007, Judah Jacobson. - All Rights Reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - - Redistribution of source code must retain the above copyright notice, - this list of conditions and the following disclamer. + 1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. - - Redistribution in binary form must reproduce the above copyright notice, - this list of conditions and the following disclamer in the documentation + 2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY - EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + 3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE - USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. text LICENSE file: @@ -4526,7 +4922,7 @@ text LICENSE file: th-abstraction LICENSE file: - Copyright (c) 2017 Eric Mertens + Copyright (c) 2017-2020 Eric Mertens Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice @@ -4540,6 +4936,39 @@ th-abstraction LICENSE file: TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +th-compat LICENSE file: + + Copyright (c) 2020, Ryan Scott + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ryan Scott nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + these LICENSE file: Copyright (c) 2012, C. McCann, 2015-2019 Oleg Grenrus @@ -4586,9 +5015,9 @@ time LICENSE file: THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -time-locale-compat LICENSE file: +time-compat LICENSE file: - Copyright (c) 2014, Kei Hibino + Copyright (c) 2019 time contibutors, Oleg Grenrus All rights reserved. @@ -4603,7 +5032,7 @@ time-locale-compat LICENSE file: disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Kei Hibino nor the names of other + * Neither the name of Oleg Grenrus nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. @@ -4619,6 +5048,29 @@ time-locale-compat LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +time-manager LICENSE file: + + Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + transformers LICENSE file: The Glasgow Haskell Compiler License @@ -4716,6 +5168,39 @@ transformers-compat LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +type-equality LICENSE file: + + Copyright (c) 2009 Erik Hesselink, 2019 Oleg Grenrus, Ryan Scott + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of authors nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + typed-process LICENSE file: Copyright (c) 2016 FP Complete, https://www.fpcomplete.com/ @@ -4741,7 +5226,7 @@ typed-process LICENSE file: uniplate LICENSE file: - Copyright Neil Mitchell 2006-2013. + Copyright Neil Mitchell 2006-2020. All rights reserved. Redistribution and use in source and binary forms, with or without @@ -5364,6 +5849,36 @@ word8 LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +x509 LICENSE file: + + Copyright (c) 2010-2013 Vincent Hanquez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + xss-sanitize LICENSE file: The following license covers this documentation, and the source code, except diff --git a/license-generator/generate.hs b/license-generator/generate.hs index a439175eb6..5439db6775 100644 --- a/license-generator/generate.hs +++ b/license-generator/generate.hs @@ -65,6 +65,7 @@ depsNamesAndVersions = do excluded name = name == "purescript" || name == "rts" + || name == "ghc-boot-th" parse line = case splitOn " " line of From 2aae51058d819999e5aab171683f9c50ac56810b Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Thu, 15 Apr 2021 20:02:28 -0700 Subject: [PATCH 1293/1580] Fix shift/reduce conflicts (#4063) * Fix all shift/reduce conflicts * Update changelog --- CHANGELOG.md | 6 +++++ .../src/Language/PureScript/CST/Parser.y | 26 +++++++++---------- 2 files changed, 19 insertions(+), 13 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1735d04e27..5a2000e2fb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -58,6 +58,12 @@ Other improvements: corefn.json file in your output directory which would be incorrectly considered up-to-date by the compiler. +* Removed all shift/reduce conflicts in parser (#4063, @JordanMartinez). + + Happy defaults to using "shift" rather than "reduce" in shift/reduce + conflicts. This change merely makes explicit what is already happening + implicitly. + Internal: * Upgrade tests Bower dependencies (#4041, @kl0tl) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y index 32e079041b..bc237b84e7 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y +++ b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y @@ -35,7 +35,7 @@ import qualified Language.PureScript.Roles as R import Language.PureScript.PSString (PSString) } -%expect 93 +%expect 0 %name parseType type %name parseExpr expr @@ -144,7 +144,7 @@ import Language.PureScript.PSString (PSString) %% many(a) :: { NE.NonEmpty a } - : many1(a) { NE.reverse $1 } + : many1(a) %shift { NE.reverse $1 } many1(a) :: { NE.NonEmpty a } : a { pure $1 } @@ -169,7 +169,7 @@ sep(a, s) :: { Separated a } : sep1(a, s) { separated $1 } sep1(a, s) :: { [(SourceToken, a)] } - : a { [(placeholder, $1)] } + : a %shift { [(placeholder, $1)] } | sep1(a, s) s a { ($2, $3) : $1 } delim(a, b, c, d) :: { Delimited b } @@ -291,7 +291,7 @@ boolean :: { (SourceToken, Bool) } | 'false' { toBoolean $1 } type :: { Type () } - : type1 { $1 } + : type1 %shift { $1 } | type1 '::' type { TypeKinded () $1 $2 $3 } type1 :: { Type () } @@ -299,7 +299,7 @@ type1 :: { Type () } | forall many(typeVarBinding) '.' type1 { TypeForall () $1 $2 $3 $4 } type2 :: { Type () } - : type3 { $1 } + : type3 %shift { $1 } | type3 '->' type1 { TypeArr () $1 $2 $3 } | type3 '=>' type1 {% do cs <- toConstraint $1; pure $ TypeConstrained () cs $2 $3 } @@ -308,7 +308,7 @@ type3 :: { Type () } | type3 qualOp type4 { TypeOp () $1 (getQualifiedOpName $2) $3 } type4 :: { Type () } - : type5 { $1 } + : type5 %shift { $1 } | '#' type4 {% addWarning ($1 : toList (flattenType $2)) WarnDeprecatedRowSyntax *> pure (TypeUnaryRow () $1 $2) } type5 :: { Type () } @@ -359,16 +359,16 @@ forall :: { SourceToken } | 'forallu' { $1 } exprWhere :: { Where () } - : expr { Where $1 Nothing } + : expr %shift { Where $1 Nothing } | expr 'where' '\{' manySep(letBinding, '\;') '\}' { Where $1 (Just ($2, $4)) } expr :: { Expr () } - : expr1 { $1 } + : expr1 %shift { $1 } | expr1 '::' type { ExprTyped () $1 $2 $3 } expr1 :: { Expr () } - : expr2 { $1 } - | expr1 qualOp expr2 { ExprOp () $1 (getQualifiedOpName $2) $3 } + : expr2 %shift { $1 } + | expr1 qualOp expr2 %shift { ExprOp () $1 (getQualifiedOpName $2) $3 } expr2 :: { Expr () } : expr3 { $1 } @@ -379,7 +379,7 @@ exprBacktick :: { Expr () } | exprBacktick qualOp expr3 { ExprOp () $1 (getQualifiedOpName $2) $3 } expr3 :: { Expr () } - : expr4 { $1 } + : expr4 %shift { $1 } | '-' expr3 { ExprNegate () $1 $2 } expr4 :: { Expr () } @@ -411,7 +411,7 @@ expr5 :: { Expr () } { ExprCase () (CaseOf $1 $2 $3 (pure ($5, $7))) } expr6 :: { Expr () } - : expr7 { $1 } + : expr7 %shift { $1 } | expr7 '{' '}' { ExprApp () $1 (ExprRecord () (Wrapped $2 Nothing $3)) } | expr7 '{' sep(recordUpdateOrLabel, ',') '}' {% toRecordFields $3 >>= \case @@ -574,7 +574,7 @@ binder2 :: { Binder () } binderAtom :: { Binder () } : '_' { BinderWildcard () $1 } - | ident { BinderVar () $1 } + | ident %shift { BinderVar () $1 } | ident '@' binderAtom { BinderNamed () $1 $2 $3 } | qualProperName { BinderConstructor () (getQualifiedProperName $1) [] } | boolean { uncurry (BinderBoolean ()) $1 } From 0d570f6e3828fc1a93c7c20252bccb04b7d2b0f6 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 18 Apr 2021 15:09:27 +0100 Subject: [PATCH 1294/1580] Bump versions for v0.14.1 (#4068) --- CHANGELOG.md | 8 ++++++++ lib/purescript-ast/README.md | 3 ++- lib/purescript-ast/purescript-ast.cabal | 2 +- lib/purescript-cst/README.md | 3 ++- lib/purescript-cst/purescript-cst.cabal | 4 ++-- npm-package/package.json | 4 ++-- purescript.cabal | 18 ++++++++++-------- 7 files changed, 27 insertions(+), 15 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5a2000e2fb..7eccc96804 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,14 @@ Breaking changes: New features: +Bugfixes: + +Internal: + +## v0.14.1 + +New features: + * Support TCO for functions with tail-recursive inner functions (#3958, @rhendric) Adds support for optimizing functions that contain local functions which call diff --git a/lib/purescript-ast/README.md b/lib/purescript-ast/README.md index dd8b6fe610..4a65d10371 100644 --- a/lib/purescript-ast/README.md +++ b/lib/purescript-ast/README.md @@ -8,4 +8,5 @@ We provide a table to make it a bit easier to map between versions of `purescrip | `purescript` | `purescript-ast` | | --- | --- | -| `0.13.6` | `0.1.0.0` | +| `0.14.0` | `0.1.0.0` | +| `0.14.1` | `0.1.1.0` | diff --git a/lib/purescript-ast/purescript-ast.cabal b/lib/purescript-ast/purescript-ast.cabal index 66dcaaca8c..11e0628e43 100644 --- a/lib/purescript-ast/purescript-ast.cabal +++ b/lib/purescript-ast/purescript-ast.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: purescript-ast -version: 0.1.0.0 +version: 0.1.1.0 synopsis: PureScript Programming Language Abstract Syntax Tree description: Defines the underlying syntax of the PureScript Programming Language. category: Language diff --git a/lib/purescript-cst/README.md b/lib/purescript-cst/README.md index f72863acbd..93eedc4cc1 100644 --- a/lib/purescript-cst/README.md +++ b/lib/purescript-cst/README.md @@ -8,4 +8,5 @@ We provide a table to make it a bit easier to map between versions of `purescrip | `purescript` | `purescript-cst` | | --- | --- | -| `0.13.6` | `0.1.0.0` | +| `0.14.0` | `0.1.0.0` | +| `0.14.1` | `0.1.1.0` | diff --git a/lib/purescript-cst/purescript-cst.cabal b/lib/purescript-cst/purescript-cst.cabal index 7820fb0bce..92717de7b4 100644 --- a/lib/purescript-cst/purescript-cst.cabal +++ b/lib/purescript-cst/purescript-cst.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: purescript-cst -version: 0.1.0.0 +version: 0.1.1.0 synopsis: PureScript Programming Language Concrete Syntax Tree description: The surface syntax of the PureScript Programming Language. category: Language @@ -60,7 +60,7 @@ common defaults base >=4.14.1.0 && <4.15, containers >=0.6.2.1 && <0.7, dlist >=0.8.0.8 && <0.9, - purescript-ast >=0.1.0.0 && <0.2, + purescript-ast ==0.1.1.0, scientific >=0.3.6.2 && <0.4, semigroups >=0.19.1 && <0.20, text >=1.2.4.1 && <1.3 diff --git a/npm-package/package.json b/npm-package/package.json index 73cef384a6..033b29acd6 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.14.0", + "version": "0.14.1", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.14.0", + "postinstall": "install-purescript --purs-ver=0.14.1", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index 07f26ee400..d37ec61cb2 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.14.0 +version: 0.14.1 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language @@ -97,7 +97,7 @@ common defaults -- update to a newer snapshot as follows: -- -- 1. Remove all version constraints from this cabal file (apart from - -- language-javascript). + -- language-javascript, purescript-cst, and purescript-ast). -- 2. Update stack.yaml as required to select a new snapshot, and check -- everything builds correctly with stack. -- 3. Run `stack sdist`; this will produce a source distribution including @@ -111,10 +111,12 @@ common defaults -- built with (almost) the same install plan for both cabal and stack -- users. -- - -- We need to be especially careful with language-javascript because it - -- is part of the compiler's public API; all FFI modules must be parseable - -- by language-javascript otherwise the compiler will reject them. It - -- should always be pinned to a single specific version. + -- We need to be especially careful with purescript-cst, purescript-ast, + -- and language-javascript, because they all form part of the compiler's + -- public API. In the case of language-javascript specifically, all FFI + -- modules must be parseable by this library otherwise the compiler + -- will reject them. It should therefore always be pinned to a single + -- specific version. aeson >=1.5.6.0 && <1.6, aeson-better-errors >=0.9.1.0 && <0.10, aeson-pretty >=0.8.8 && <0.9, @@ -157,8 +159,8 @@ common defaults pattern-arrows >=0.0.2 && <0.1, process >=1.6.9.0 && <1.7, protolude >=0.3.0 && <0.4, - purescript-ast >=0.1.0.0 && <0.2, - purescript-cst >=0.1.0.0 && <0.2, + purescript-ast ==0.1.1.0, + purescript-cst ==0.1.1.0, regex-tdfa >=1.3.1.0 && <1.4, safe >=0.3.19 && <0.4, scientific >=0.3.6.2 && <0.4, From 9c03fc6bb2613aaada1f4f25028bbcf91eb6bd85 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 18 Apr 2021 20:29:56 +0100 Subject: [PATCH 1295/1580] Update RELEASE_GUIDE.md for multiple packages (#4061) --- RELEASE_GUIDE.md | 48 ++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 44 insertions(+), 4 deletions(-) diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md index a5b7aad60c..df1c22b0da 100644 --- a/RELEASE_GUIDE.md +++ b/RELEASE_GUIDE.md @@ -45,17 +45,57 @@ considering what effects this may have: ## Making a release - Make a commit bumping versions. The following should be updated: - - The `version` field in `package.yaml` + + - The `version` field in `purescript.cabal` + + - The `prerelease` field in `app/Version.hs`, if updating the prerelease + field + - The `version` field in `npm-package/package.json` + - The version to install in the `postinstall` script in `package.json` + + - If `purescript-ast` has changed at all since the last release: + + - The `version` field in `lib/purescript-ast/purescript-ast.cabal` (note + that the new version should be based on the PVP, according to what + changed since the previous release, and not on the actual compiler + version) + + - The versions table in `lib/purescript-ast/README.md`, + + - The version bounds for `purescript-ast` in + `lib/purescript-cst/purescript-cst.cabal` and in `purescript.cabal` + + - If `purescript-cst` has changed at all since the last release: + + - The `version` field in `lib/purescript-cst/purescript-cst.cabal` (note + that the new version should be based on the PVP, according to what + changed since the previous release, and not on the actual compiler + version) + + - The versions table in `lib/purescript-cst/README.md`, + + - The version bounds for `purescript-cst` in `purescript.cabal` + - Create a release from the releases tab in GitHub and copy in the release notes. This will also create a tag, which will kick off a CI build, which will upload prebuilt compiler binaries to the release on GitHub when it completes. (If the CI build fails, binaries can also be built locally and manually uploaded to the release on GitHub) -- Publish to Hackage: change to the compiler directory and run `stack upload .`. - It's a good idea to check that the package can be installed from Hackage at - this point. + +- Publish to Hackage: + + - change to the `lib/purescript-cst` directory and run `stack upload .` + + - change to the `lib/purescript-ast` directory and run `stack upload .` + + - Finally, run `stack upload .` from the repo root directory. + + It's a good idea to check that the three packages (`purescript`, + `purescript-cst`, and `purescript-ast`) can be installed from Hackage at this + point. + - After all of the prebuilt binaries are present on the GitHub releases page, publish to npm: change to the `npm-package` directory and run `npm publish`. It's a good idea to check that the package can be installed from npm at this From 4ae3b9c496f04670ccb573dd8fe852f761d774c7 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 18 Apr 2021 20:30:10 +0100 Subject: [PATCH 1296/1580] Rearrange CHANGELOG entry for 0.14.1 (#4070) Moves the incremental build fix entry in the changelog into the correct section - it is a bug fix. --- CHANGELOG.md | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7eccc96804..7c0d8196a5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -51,6 +51,13 @@ Bugfixes: * Fix wildly off kind unification positions (#4050, @natefaubion) +* Fix incorrect incremental builds with different `--codegen` options (#3911, #3914, @hdgarrood) + + This bug meant that after invoking the compiler with different `--codegen` + options, it was easy to end up with (for example) an outdated docs.json or + corefn.json file in your output directory which would be incorrectly + considered up-to-date by the compiler. + Other improvements: * Add white outline stroke to logo in README (#4003, @ptrfrncsmrph) @@ -59,13 +66,6 @@ Other improvements: * Show the constraints that were being solved when encountering a type error (@nwolverson, #4004) -* Fix incorrect incremental builds with different `--codegen` options (#3911, #3914, @hdgarrood) - - This bug meant that after invoking the compiler with different `--codegen` - options, it was easy to end up with (for example) an outdated docs.json or - corefn.json file in your output directory which would be incorrectly - considered up-to-date by the compiler. - * Removed all shift/reduce conflicts in parser (#4063, @JordanMartinez). Happy defaults to using "shift" rather than "reduce" in shift/reduce From 435ce6719915807f172afc9b7aaee180bcf890aa Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 19 Apr 2021 13:46:05 +0100 Subject: [PATCH 1297/1580] Prompt to add to CONTRIBUTORS.md (#4074) Prompts new contributors to add themselves to CONTRIBUTORS.md in the pull request template. Hopefully this will make it easier for maintainers to remember about this when reviewing PRs, as well as for making contributors aware of the file in the first place. --- .github/PULL_REQUEST_TEMPLATE.md | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index 4435abbec0..711103ccba 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -7,6 +7,7 @@ Clearly and concisely describe the purpose of the pull request. If this PR relat **Checklist:** - [ ] Added the change to the changelog's "Unreleased" section with a reference to this PR (e.g. "- Made a change (#0000)") +- [ ] Added myself to CONTRIBUTORS.md (if this is my first contribution) - [ ] Linked any existing issues or proposals that this pull request should close - [ ] Updated or added relevant documentation - [ ] Added a test for the contribution (if applicable) From b888b77937af307ec2bd307274945c725b6d03e5 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 19 Apr 2021 13:47:00 +0100 Subject: [PATCH 1298/1580] Drop libtinfo dependency (#4069) Resolves #3696. (Note that #3696 says "use static linking in binary distributions", and this doesn't actually do that as there are still a number of other dynamic library dependencies. However all of the remaining ones are very common and likely to already exist on the user's system, so that users hopefully shouldn't need to worry about dynamic library dependencies at all after this change, which hopefully does resolve the issue in practice.) We regularly hear from beginners who are having difficulty installing the compiler because of the libtinfo dependency, so let's drop it. The REPL experience is only very marginally degraded by this change, and I suspect a large chunk of users don't even use the REPL anyway - certainly CI environments, where the libtinfo dependency is often an issue, don't care about the REPL. If people do want the terminfo-based REPL they can still build their own version of the compiler with the haskeline `terminfo` flag enabled. See https://github.com/purescript/purescript/issues/3696#issuecomment-657282303 for a comparison. --- CHANGELOG.md | 10 ++++++++++ INSTALL.md | 8 ++++---- stack.yaml | 3 +++ 3 files changed, 17 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7c0d8196a5..7a0a5789d0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -72,6 +72,16 @@ Other improvements: conflicts. This change merely makes explicit what is already happening implicitly. +* Drop libtinfo dependency (#3696, @hdgarrood) + + Changes the build configuration so that by default, compiler binaries will + not have a dynamic library dependency on libncurses/libtinfo. This should + alleviate one of the most common pains in getting the compiler successfully + installed, especially on Linux. The cost is a slight degradation in the REPL + experience when editing long lines, but this can be avoided by building the + compiler with the libtinfo dependency by setting the `terminfo` flag of the + `haskeline` library to `true`. + Internal: * Upgrade tests Bower dependencies (#4041, @kl0tl) diff --git a/INSTALL.md b/INSTALL.md index c26c322a32..c660637a5e 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -43,10 +43,10 @@ If you don't have stack installed, please see the [stack install documentation]( ## The "curses" library -The PureScript REPL depends on the `curses` library (via the Haskell package -`terminfo`). If you are having difficulty running the compiler, it may be -because the `curses` library is missing. This problem may appear as a `libtinfo` -error: +Prior to version vX.Y.Z __TODO: fill in when known__, the PureScript REPL +depends on the `curses` library (via the Haskell package `terminfo`). If you +are having difficulty running the compiler, it may be because the `curses` +library is missing. This problem may appear as a `libtinfo` error: ``` error while loading shared libraries: libtinfo.so.5: cannot open shared object file: No such file or directory ``` diff --git a/stack.yaml b/stack.yaml index 5c78030d88..982dffce11 100644 --- a/stack.yaml +++ b/stack.yaml @@ -22,3 +22,6 @@ flags: lib-only: true these: assoc: false + haskeline: + # Avoids a libtinfo dynamic library dependency + terminfo: false From cf144110426d311f176f744328cac43d22ff8377 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 19 Apr 2021 20:31:20 +0100 Subject: [PATCH 1299/1580] Fixup docs for libtinfo change (#4075) - Move the libtinfo changelog entry out of v0.14.1 into 'unreleased' - Add the correct version in INSTALL.md - Explain that you can still depend on `curses` if you want to in INSTALL.md --- CHANGELOG.md | 20 ++++++++++---------- INSTALL.md | 14 ++++++++++---- 2 files changed, 20 insertions(+), 14 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7a0a5789d0..2935bcea1b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,16 @@ Bugfixes: Internal: +* Drop libtinfo dependency (#3696, @hdgarrood) + + Changes the build configuration so that by default, compiler binaries will + not have a dynamic library dependency on libncurses/libtinfo. This should + alleviate one of the most common pains in getting the compiler successfully + installed, especially on Linux. The cost is a slight degradation in the REPL + experience when editing long lines, but this can be avoided by building the + compiler with the libtinfo dependency by setting the `terminfo` flag of the + `haskeline` library to `true`. + ## v0.14.1 New features: @@ -72,16 +82,6 @@ Other improvements: conflicts. This change merely makes explicit what is already happening implicitly. -* Drop libtinfo dependency (#3696, @hdgarrood) - - Changes the build configuration so that by default, compiler binaries will - not have a dynamic library dependency on libncurses/libtinfo. This should - alleviate one of the most common pains in getting the compiler successfully - installed, especially on Linux. The cost is a slight degradation in the REPL - experience when editing long lines, but this can be avoided by building the - compiler with the libtinfo dependency by setting the `terminfo` flag of the - `haskeline` library to `true`. - Internal: * Upgrade tests Bower dependencies (#4041, @kl0tl) diff --git a/INSTALL.md b/INSTALL.md index c660637a5e..c74a88ea6f 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -43,10 +43,10 @@ If you don't have stack installed, please see the [stack install documentation]( ## The "curses" library -Prior to version vX.Y.Z __TODO: fill in when known__, the PureScript REPL -depends on the `curses` library (via the Haskell package `terminfo`). If you -are having difficulty running the compiler, it may be because the `curses` -library is missing. This problem may appear as a `libtinfo` error: +Prior to version v0.14.2, the PureScript REPL depends on the `curses` library +by default (via the Haskell package `terminfo`). If you are having difficulty +running the compiler, it may be because the `curses` library is missing. This +problem may appear as a `libtinfo` error: ``` error while loading shared libraries: libtinfo.so.5: cannot open shared object file: No such file or directory ``` @@ -57,6 +57,12 @@ example, this can be done by running: $ sudo apt install libtinfo5 libncurses5-dev ``` +As of v0.14.2, this should no longer be necessary if you are using the prebuilt +binaries or building the compiler from source with the default configuration. +However, you can still opt into using `curses` by setting the Haskeline +`terminfo` flag to `true`. This may improve the REPL experience slightly - for +example, by providing better editing of long input lines. + ## EACCES error If you encounter this error while trying to install via `npm`: From d62a6295e902eb742029d5601b361ec12bf4ffc1 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Fri, 23 Apr 2021 12:23:49 -0400 Subject: [PATCH 1300/1580] Migrate CI from Travis to GitHub Actions (#4077) --- .github/workflows/ci.yml | 90 +++++++++++++++++++++++++ .travis.yml | 119 --------------------------------- CHANGELOG.md | 2 + README.md | 2 +- ci/build.sh | 13 ++++ ci/convert-os-name.sh | 16 ----- ci/disable-windows-defender.sh | 23 ------- ci/install-hlint.sh | 66 ------------------ ci/run-hlint.sh | 92 +++++++++++++++++++++++++ 9 files changed, 198 insertions(+), 225 deletions(-) create mode 100644 .github/workflows/ci.yml delete mode 100644 .travis.yml delete mode 100755 ci/convert-os-name.sh delete mode 100755 ci/disable-windows-defender.sh delete mode 100755 ci/install-hlint.sh create mode 100755 ci/run-hlint.sh diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000000..78e0047d3f --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,90 @@ +name: "CI" + +on: + push: + branches: [ "master" ] + pull_request: + branches: [ "master" ] + release: + types: [ "published" ] + +defaults: + run: + shell: "bash" + +env: + CI_RELEASE: "${{ github.event_name == 'release' }}" + +jobs: + build: + strategy: + fail-fast: false # do not cancel builds for other OSes if one fails + matrix: + os: [ "ubuntu-latest", "macOS-latest", "windows-latest" ] + + runs-on: "${{ matrix.os }}" + + steps: + - uses: "actions/checkout@v2" + + - uses: "actions/setup-node@v1" + with: + node-version: "10" + + - id: "haskell" + uses: "haskell/actions/setup@v1" + with: + enable-stack: true + stack-version: "2.5.1" + stack-no-global: true + + - uses: "actions/cache@v2" + with: + path: | + ${{ steps.haskell.outputs.stack-root }} + key: "${{ runner.os }}-${{ hashFiles('stack.yaml') }}" + + - name: "(Windows only) Configure Stack to store its programs in STACK_ROOT" + # This ensures that the local GHC and MSYS binaries that Stack installs + # are included in the cache. (This behavior is the default on + # non-Windows OSes.) + if: "${{ runner.os == 'Windows' }}" + run: | + mkdir -p "$STACK_ROOT" + echo "local-programs-path: $STACK_ROOT/programs" > $STACK_ROOT/config.yaml + + - run: "ci/run-hlint.sh --git" + env: + VERSION: "2.2.11" + + - run: "ci/build.sh" + + - name: "(Release only) Create bundle" + if: "${{ env.CI_RELEASE == 'true' }}" + run: | + os_name="${{ runner.os }}" + case "$os_name" in + Linux) + bundle_os=linux64;; + macOS) + bundle_os=macos;; + Windows) + bundle_os=win64;; + *) + echo "Unknown OS name: $os_name" + exit 1;; + esac + cd sdist-test + bundle/build.sh "$bundle_os" + + - name: "(Release only) Publish bundle" + if: "${{ env.CI_RELEASE == 'true' }}" + # Astonishingly, GitHub doesn't currently maintain a first-party action + # for uploading assets to GitHub releases! This is the best third-party + # one I could find, but as this step handles a token, it seems + # particularly important that we lock it down to a specific audited + # version, instead of a tag like the other steps. + uses: "AButler/upload-release-assets@ec6d3263266dc57eb6645b5f75e827987f7c217d" + with: + repo-token: "${{ secrets.GITHUB_TOKEN }}" + files: "sdist-test/bundle/*.{tar.gz,sha}" diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index c045ba54b6..0000000000 --- a/.travis.yml +++ /dev/null @@ -1,119 +0,0 @@ -language: node_js -node_js: - - "10" -branches: - # Only build master and tagged versions, i.e. not feature branches; feature - # branches already get built after opening a pull request. - only: - - master - - /^v\d+\.\d+(\.\d+)?(-\S*)?$/ -env: - global: - - STACK_VERSION=2.5.1 -matrix: - include: - - os: linux - dist: bionic - sudo: required - - - os: osx - - - os: windows - # Override the default stack root directory to ensure that it will be - # cached - env: STACK_ROOT=$HOME/.stack - # workaround for https://travis-ci.community/t/windows-instances-hanging-before-install/250/15 - filter_secrets: false -addons: - apt: - packages: - - libgmp-dev -# Travis CI's build cache mechanism allows you to cache compiled artifacts in -# order to speed subsequent builds up; this is essential for us, because -# installing all of the compiler's Haskell dependencies can take longer than -# the allotted time for a single build. -# -# Unfortunately, if we allow a build to reach the Travis timeout limit, we -# don't get the opportunity to upload a cache (since uploading is included in -# the time limit, and we've already run out of time). Therefore, if we want -# the progress we have made in a build to be saved to the build cache, we need -# to make sure we abort the build early to allow time to upload the cache. -# Then, the next commit can pick up where the previous commit left off. -# -# If a CI build times out, you need to push a new commit. Amending and -# force-pushing DOES NOT WORK. I suspect this is because Travis will only -# consider a particular build cache to be appropriate to use when building a -# given commit with if the cache was created by a parent of the commit being -# built (which is sensible of them). -cache: - directories: - - $HOME/.stack - # Maximum amount of time in seconds spent attempting to upload a new cache - # before aborting. Since our cache can get rather large, increasing this - # value helps avoid situations where caches fail to be stored. The default - # value is 180 (at the time of writing). - timeout: 1000 -install: -- | - if [ "$TRAVIS_OS_NAME" = "windows" ] - then - ci/disable-windows-defender.sh - fi -- mkdir -p "$HOME/.local/bin" -- export PATH="$PATH:$HOME/.local/bin" -- | # Install stack. - URL="https://github.com/commercialhaskell/stack/releases/download/v${STACK_VERSION}/stack-${STACK_VERSION}-${TRAVIS_OS_NAME}-x86_64.tar.gz" - mkdir "$HOME/stack" - pushd "$HOME/stack" - curl --location "$URL" > stack.tar.gz - tar -xzf stack.tar.gz --strip-components=1 - mv stack "$HOME/.local/bin/" - popd -- | # Install hlint. - BIN_DIR="$HOME/.local/bin/" BUILD_DIR="$HOME/hlint" ci/install-hlint.sh -- | # Set up the timeout command - if which timeout >/dev/null - then - TIMEOUT=timeout - elif [ "$TRAVIS_OS_NAME" == "osx" ] - then - if ! which gtimeout >/dev/null - then - brew update - brew install coreutils - fi - TIMEOUT=gtimeout - else - echo "Unable to set up timeout command" - exit 1 - fi -- stack --version -- stack --no-terminal setup -- stack path -- npm install -g bower # for psc-docs / psc-publish tests -- export OS_NAME=$(./ci/convert-os-name.sh) -- | - if [ -n "$TRAVIS_TAG" ] - then - export CI_RELEASE=true - fi -script: -- hlint --git -# Set a timeout of 35 minutes. We could use travis_wait here, but travis_wait -# doesn't produce any output until the command finishes, and also doesn't -# always show all of the command's output. -- $TIMEOUT 35m ci/build.sh -before_deploy: -- pushd sdist-test -- bundle/build.sh $OS_NAME -- popd -deploy: - provider: releases - api_key: $RELEASE_KEY - file: - - sdist-test/bundle/$OS_NAME.tar.gz - - sdist-test/bundle/$OS_NAME.sha - skip_cleanup: true - on: - all_branches: true - tags: true diff --git a/CHANGELOG.md b/CHANGELOG.md index 2935bcea1b..657a996548 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -22,6 +22,8 @@ Internal: compiler with the libtinfo dependency by setting the `terminfo` flag of the `haskeline` library to `true`. +* Migrate CI from Travis to GitHub Actions (#4077, @rhendric) + ## v0.14.1 New features: diff --git a/README.md b/README.md index 0941dff566..a8f7f69583 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ A small strongly typed programming language with expressive types that compiles to JavaScript, written in and inspired by Haskell. -[![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://api.travis-ci.org/purescript/purescript.svg?branch=master)](http://travis-ci.org/purescript/purescript) +[![Hackage](https://img.shields.io/hackage/v/purescript.svg)](http://hackage.haskell.org/package/purescript) [![Build Status](https://github.com/purescript/purescript/actions/workflows/ci.yml/badge.svg?branch=master)](https://github.com/purescript/purescript/actions/workflows/ci.yml) ## Language info diff --git a/ci/build.sh b/ci/build.sh index a3be3a9884..b1283ff31e 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -2,6 +2,10 @@ set -ex +# Provides expanders that group console output in GitHub Actions +# See https://docs.github.com/en/actions/reference/workflow-commands-for-github-actions#grouping-log-lines +(echo "::group::Initialize variables") 2>/dev/null + # This is the main CI build script. It is intended to run on all platforms we # run CI on: linux, mac os, and windows. It makes use of the following # environment variables: @@ -35,10 +39,14 @@ fi # with an invalid option error. export TASTY_NO_CREATE=true +(echo "::endgroup::"; echo "::group::Install snapshot dependencies") 2>/dev/null + # Install snapshot dependencies (since these will be cached globally and thus # can be reused during the sdist build step) $STACK build --only-snapshot $STACK_OPTS +(echo "::endgroup::"; echo "::group::Build source distributions") 2>/dev/null + # Test in a source distribution (see above) $STACK sdist lib/purescript-ast --tar-dir sdist-test/lib/purescript-ast tar -xzf sdist-test/lib/purescript-ast/purescript-ast-*.tar.gz -C sdist-test/lib/purescript-ast --strip-components=1 @@ -46,6 +54,11 @@ $STACK sdist lib/purescript-cst --tar-dir sdist-test/lib/purescript-cst tar -xzf sdist-test/lib/purescript-cst/purescript-cst-*.tar.gz -C sdist-test/lib/purescript-cst --strip-components=1 $STACK sdist . --tar-dir sdist-test; tar -xzf sdist-test/purescript-*.tar.gz -C sdist-test --strip-components=1 + +(echo "::endgroup::"; echo "::group::Build and test PureScript") 2>/dev/null + pushd sdist-test $STACK build $STACK_OPTS popd + +(echo "::endgroup::") 2>/dev/null diff --git a/ci/convert-os-name.sh b/ci/convert-os-name.sh deleted file mode 100755 index a2e0574ad3..0000000000 --- a/ci/convert-os-name.sh +++ /dev/null @@ -1,16 +0,0 @@ -#!/bin/bash -# This script converts the Travis OS name into the format used for PureScript -# binary bundles. -set -e - -case "$TRAVIS_OS_NAME" in - "linux") - echo linux64;; - "osx") - echo macos;; - "windows") - echo win64;; - *) - echo "Unknown TRAVIS_OS_NAME: $TRAVIS_OS_NAME"; - exit 1;; -esac diff --git a/ci/disable-windows-defender.sh b/ci/disable-windows-defender.sh deleted file mode 100755 index a344b3bf6e..0000000000 --- a/ci/disable-windows-defender.sh +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/bash - -# Intended to speed up builds by disabling Windows Defender. -# See https://travis-ci.community/t/current-known-issues-please-read-this-before-posting-a-new-topic/264/15 - -export NODEPATH=$(where.exe node.exe) -export PROJECTDIR=$(pwd) -export TEMPDIR=$LOCALAPPDATA\\Temp - -powershell Add-MpPreference -ExclusionProcess ${NODEPATH} -powershell Add-MpPreference -ExclusionPath ${PROJECTDIR} -powershell Add-MpPreference -ExclusionPath ${TEMPDIR} - -echo "DisableArchiveScanning..." -powershell Start-Process -PassThru -Wait PowerShell -ArgumentList "'-Command Set-MpPreference -DisableArchiveScanning \$true'" - -echo "DisableBehaviorMonitoring..." -powershell Start-Process -PassThru -Wait PowerShell -ArgumentList "'-Command Set-MpPreference -DisableBehaviorMonitoring \$true'" - -echo "DisableRealtimeMonitoring..." -powershell Start-Process -PassThru -Wait PowerShell -ArgumentList "'-Command Set-MpPreference -DisableRealtimeMonitoring \$true'" - - diff --git a/ci/install-hlint.sh b/ci/install-hlint.sh deleted file mode 100755 index 2037b7d259..0000000000 --- a/ci/install-hlint.sh +++ /dev/null @@ -1,66 +0,0 @@ -#!/usr/bin/env bash - -set -o errexit -set -o nounset -set -o pipefail -IFS=$'\n\t' - -readonly hlint_version=2.2.11 -readonly build_dir="${BUILD_DIR:?Must provide a directory to build in}" -readonly bin_dir="${BIN_DIR:?Must provide a directory to install binaries}" - -function cleanup() { - local exit_code="${?}" - - exit "${exit_code}" -} - -trap cleanup EXIT - -function download_for_unix() { - local os="${1}" - local url="https://github.com/ndmitchell/hlint/releases/download/v${hlint_version}/hlint-${hlint_version}-x86_64-${os}.tar.gz" - - mkdir -p "${build_dir}" - pushd "${build_dir}" - curl --location "${url}" --output hlint.tar.gz - tar -xzf hlint.tar.gz --strip-components=1 - popd - - mkdir -p "${bin_dir}/data" - cp -r "${build_dir}/data" "${bin_dir}" - cp "${build_dir}/hlint" "${bin_dir}" -} - -function download_for_windows() { - local url="https://github.com/ndmitchell/hlint/releases/download/v${hlint_version}/hlint-${hlint_version}-x86_64-windows.zip" - - mkdir -p "${build_dir}" - pushd "${build_dir}" - curl --location "${url}" --output hlint.zip - 7z e -r hlint.zip - popd - - mkdir -p "${bin_dir}/data" - cp -r "${build_dir}/data" "${bin_dir}" - cp "${build_dir}/hlint.exe" "${bin_dir}" -} - -function main() { - # The OS environment variable is set to 'Windows_NT' on Windows NT systems. - # This should work for all recent Windows versions including: - # NT, 2000, XP, Server, Vista, 7, 8, 8.1, and 10. - case "${OS:-$(uname)}" in - 'Darwin') - download_for_unix 'osx';; - 'Linux') - download_for_unix 'linux';; - 'Windows_NT') - download_for_windows;; - *) - echo 'Unknown Platform. Only Linux, macOS, and Windows are supported'; - exit 1;; - esac -} - -main diff --git a/ci/run-hlint.sh b/ci/run-hlint.sh new file mode 100755 index 0000000000..bc98888214 --- /dev/null +++ b/ci/run-hlint.sh @@ -0,0 +1,92 @@ +#!/bin/sh +# This script was originally sourced from +# https://github.com/ndmitchell/neil/blob/b06624fe697c23375222856d538cb974e96da048/misc/run.sh +# and adapted for PureScript to do the following: +# * specialize for hlint instead of an arbitrary ndmitchell project +# * use a specified version, instead of the most recent release +# * install to a native temporary directory instead of a subdirectory of the project +# * make curl silent +# +# The original script was distributed with the following license, also available at +# https://github.com/ndmitchell/neil/blob/b06624fe697c23375222856d538cb974e96da048/LICENSE +# +# Copyright (c) Neil Mitchell 2010-2021 +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are +# met: +# +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# +# * Redistributions in binary form must reproduce the above +# copyright notice, this list of conditions and the following +# disclaimer in the documentation and/or other materials provided +# with the distribution. +# +# * The names of its contributors may not be used to endorse or +# promote products derived from this software without specific prior +# written permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +# OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +# This script is invoked from my Travis commands +# It bootstraps to grab the a binary release and run it +set -e # exit on errors + +PACKAGE=hlint +if [ -z "$VERSION" ]; then + echo The environment variable VERSION is required + exit 1 +fi + +case "$(uname)" in + "Darwin") + OS=osx;; + MINGW64_NT-*|MSYS_NT-*) + OS=windows;; + *) + OS=linux +esac + +if [ "$OS" = "windows" ]; then + EXT=.zip +else + EXT=.tar.gz +fi + +echo Downloading and running $PACKAGE... +URL=https://github.com/ndmitchell/$PACKAGE/releases/download/v$VERSION/$PACKAGE-$VERSION-x86_64-$OS$EXT +TEMP=$(mktemp -d ${TEMP:-/tmp}/.$PACKAGE-XXXXXX) + +cleanup(){ + rm -r $TEMP +} +trap cleanup EXIT + +retry(){ + ($@) && return + sleep 15 + ($@) && return + sleep 15 + $@ +} + +retry curl --silent --location -o$TEMP/$PACKAGE$EXT $URL +if [ "$OS" = "windows" ]; then + 7z x -y $TEMP/$PACKAGE$EXT -o$TEMP -r > /dev/null +else + tar -xzf $TEMP/$PACKAGE$EXT -C$TEMP +fi +$TEMP/$PACKAGE-$VERSION/$PACKAGE $* From 6c911673246857ee7d80aed622053c480af00735 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Fri, 23 Apr 2021 18:00:35 -0400 Subject: [PATCH 1301/1580] Remove setup-win.cmd (#4076) --- purescript.cabal | 1 - tests/TestUtils.hs | 16 ++++++---------- tests/support/setup-win.cmd | 3 --- 3 files changed, 6 insertions(+), 14 deletions(-) delete mode 100644 tests/support/setup-win.cmd diff --git a/purescript.cabal b/purescript.cabal index d37ec61cb2..167e70130d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -29,7 +29,6 @@ extra-source-files: tests/purs/**/*.out tests/json-compat/**/*.json tests/support/*.json - tests/support/setup-win.cmd tests/support/psci/**/*.purs tests/support/psci/**/*.edit tests/support/pscide/src/**/*.purs diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index dfacc8a107..a45a3cb68d 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -26,7 +26,6 @@ import Data.Time.Clock (UTCTime()) import Data.Tuple (swap) import System.Process hiding (cwd) import System.Directory -import System.Info import System.IO.UTF8 (readUTF8FileT) import System.Exit (exitFailure) import System.FilePath @@ -51,15 +50,12 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names updateSupportCode :: IO () updateSupportCode = do setCurrentDirectory "tests/support" - if System.Info.os == "mingw32" - then callProcess "setup-win.cmd" [] - else do - callProcess "npm" ["install"] - -- bower uses shebang "/usr/bin/env node", but we might have nodejs - node <- maybe cannotFindNode pure =<< findNodeProcess - -- Sometimes we run as a root (e.g. in simple docker containers) - -- And we are non-interactive: https://github.com/bower/bower/issues/1162 - callProcess node ["node_modules/.bin/bower", "--allow-root", "install", "--config.interactive=false"] + callCommand "npm install" + -- bower uses shebang "/usr/bin/env node", but we might have nodejs + node <- maybe cannotFindNode pure =<< findNodeProcess + -- Sometimes we run as a root (e.g. in simple docker containers) + -- And we are non-interactive: https://github.com/bower/bower/issues/1162 + callProcess node ["node_modules/bower/bin/bower", "--allow-root", "install", "--config.interactive=false"] setCurrentDirectory "../.." where cannotFindNode :: IO a diff --git a/tests/support/setup-win.cmd b/tests/support/setup-win.cmd deleted file mode 100644 index 2b40898f9b..0000000000 --- a/tests/support/setup-win.cmd +++ /dev/null @@ -1,3 +0,0 @@ -@echo off -call npm install -call node_modules\.bin\bower install --config.interactive=false From 255b415577db47baeb4eb04f4bbf0610e59f25b3 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 24 Apr 2021 17:48:52 +0100 Subject: [PATCH 1302/1580] Switch to hspec exclusively, remove tasty (#4057) Resolves #4056 Removes tasty, tasty-hspec, and tasty-golden from the main compiler test suite and switches it to use hspec directly instead. Golden testing now uses the HSPEC_ACCEPT and CI environment variables to control its behaviour (see the comments in TestUtils.hs for details). I was admittedly a bit off with the "6 or 7 lines" I projected in #4056, as our new `goldenVsString` function has admittedly ballooned to about 40, but I think it's probably still a good tradeoff to keep the dependency/total LOC count down. --- .hspec | 1 + CHANGELOG.md | 2 + CONTRIBUTING.md | 4 +- ci/build.sh | 6 -- lib/purescript-cst/purescript-cst.cabal | 19 ----- lib/purescript-cst/tests/Main.hs | 28 ------- purescript.cabal | 7 +- stack.yaml | 6 ++ tests/Main.hs | 44 ++++------ tests/TestBundle.hs | 6 +- tests/TestCompiler.hs | 84 +++++++++---------- tests/TestCoreFn.hs | 10 +-- .../purescript-cst/tests => tests}/TestCst.hs | 80 +++++++++--------- tests/TestDocs.hs | 18 ++-- tests/TestGraph.hs | 7 +- tests/TestHierarchy.hs | 7 +- tests/TestIde.hs | 9 +- tests/TestMake.hs | 6 +- tests/TestPrimDocs.hs | 7 +- tests/TestPscPublish.hs | 16 ++-- tests/TestPsci.hs | 8 +- tests/TestUtils.hs | 51 ++++++++++- .../purs/layout/.gitattributes | 0 .../tests => tests}/purs/layout/AdoIn.out | 0 .../tests => tests}/purs/layout/AdoIn.purs | 0 .../purs/layout/CaseGuards.out | 0 .../purs/layout/CaseGuards.purs | 0 .../tests => tests}/purs/layout/CaseWhere.out | 0 .../purs/layout/CaseWhere.purs | 0 .../tests => tests}/purs/layout/ClassHead.out | 0 .../purs/layout/ClassHead.purs | 0 .../tests => tests}/purs/layout/Commas.out | 0 .../tests => tests}/purs/layout/Commas.purs | 0 .../tests => tests}/purs/layout/Delimiter.out | 0 .../purs/layout/Delimiter.purs | 0 .../tests => tests}/purs/layout/DoLet.out | 0 .../tests => tests}/purs/layout/DoLet.purs | 0 .../purs/layout/DoOperator.out | 0 .../purs/layout/DoOperator.purs | 0 .../tests => tests}/purs/layout/DoWhere.out | 0 .../tests => tests}/purs/layout/DoWhere.purs | 0 .../purs/layout/IfThenElseDo.out | 0 .../purs/layout/IfThenElseDo.purs | 0 .../purs/layout/InstanceChainElse.out | 0 .../purs/layout/InstanceChainElse.purs | 0 .../tests => tests}/purs/layout/LetGuards.out | 0 .../purs/layout/LetGuards.purs | 0 47 files changed, 183 insertions(+), 243 deletions(-) create mode 100644 .hspec delete mode 100644 lib/purescript-cst/tests/Main.hs rename {lib/purescript-cst/tests => tests}/TestCst.hs (75%) rename {lib/purescript-cst/tests => tests}/purs/layout/.gitattributes (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/AdoIn.out (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/AdoIn.purs (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/CaseGuards.out (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/CaseGuards.purs (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/CaseWhere.out (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/CaseWhere.purs (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/ClassHead.out (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/ClassHead.purs (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/Commas.out (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/Commas.purs (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/Delimiter.out (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/Delimiter.purs (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/DoLet.out (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/DoLet.purs (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/DoOperator.out (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/DoOperator.purs (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/DoWhere.out (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/DoWhere.purs (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/IfThenElseDo.out (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/IfThenElseDo.purs (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/InstanceChainElse.out (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/InstanceChainElse.purs (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/LetGuards.out (100%) rename {lib/purescript-cst/tests => tests}/purs/layout/LetGuards.purs (100%) diff --git a/.hspec b/.hspec new file mode 100644 index 0000000000..28f079001c --- /dev/null +++ b/.hspec @@ -0,0 +1 @@ +--times diff --git a/CHANGELOG.md b/CHANGELOG.md index 657a996548..101b5c802e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -24,6 +24,8 @@ Internal: * Migrate CI from Travis to GitHub Actions (#4077, @rhendric) +* Remove tasty from test suite and just use hspec (#4056, @hdgarrood) + ## v0.14.1 New features: diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 67be71a265..de54bf0166 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -33,10 +33,10 @@ When submitting a pull request, please follow the following guidelines: Run all test suites with `stack test`. You will need `npm`, `bower` and `node` on your PATH to run the tests. -You can run individual test suites using `stack test --test-arguments="-p PATTERN"` where `PATTERN` is one of `compiler`, `repl`, `ide`, `docs`, `corefn`, or `hierarchy`. You can also build and run a specific test in `tests/purs/passing/` or `tests/purs/failing/` by using the test's filename as the pattern, e.g.: +You can run individual test suites using `stack test --test-arguments="--match PATTERN"` where `PATTERN` is one of `compiler`, `repl`, `ide`, `docs`, `corefn`, or `hierarchy`. You can also build and run a specific test in `tests/purs/passing/` or `tests/purs/failing/` by using the test's filename as the pattern, e.g.: ``` -stack test --fast --test-arguments="-p 1110.purs" +stack test --fast --test-arguments="--match 1110.purs" ``` This will run whatever test uses the example file `1110.purs`. diff --git a/ci/build.sh b/ci/build.sh index b1283ff31e..f45a15a323 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -33,12 +33,6 @@ else STACK_OPTS="$STACK_OPTS --fast" fi -# Fail the build instead of creating missing golden test files. Note that using -# the environment variable as opposed to the command line flag version of this -# option prevents test executables that don't contain golden tests from failing -# with an invalid option error. -export TASTY_NO_CREATE=true - (echo "::endgroup::"; echo "::group::Install snapshot dependencies") 2>/dev/null # Install snapshot dependencies (since these will be cached globally and thus diff --git a/lib/purescript-cst/purescript-cst.cabal b/lib/purescript-cst/purescript-cst.cabal index 92717de7b4..d3489bda0e 100644 --- a/lib/purescript-cst/purescript-cst.cabal +++ b/lib/purescript-cst/purescript-cst.cabal @@ -16,8 +16,6 @@ license: BSD-3-Clause license-file: LICENSE build-type: Simple extra-source-files: - tests/purs/**/*.out - tests/purs/**/*.purs README.md source-repository head @@ -89,20 +87,3 @@ library Paths_purescript_cst autogen-modules: Paths_purescript_cst - -test-suite tests - import: defaults - hs-source-dirs: tests - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - TestCst - Paths_purescript_cst - build-depends: - base-compat, - purescript-cst, - bytestring, - filepath, - tasty, - tasty-golden, - tasty-quickcheck diff --git a/lib/purescript-cst/tests/Main.hs b/lib/purescript-cst/tests/Main.hs deleted file mode 100644 index 8a044fd81a..0000000000 --- a/lib/purescript-cst/tests/Main.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TupleSections #-} - -module Main (main) where - -import Prelude.Compat - -import Test.Tasty - -import qualified TestCst - -import System.IO (hSetEncoding, stdout, stderr, utf8) - -main :: IO () -main = do - hSetEncoding stdout utf8 - hSetEncoding stderr utf8 - - cstTests <- TestCst.main - - defaultMain $ - testGroup - "Tests" - [ cstTests - ] diff --git a/purescript.cabal b/purescript.cabal index 167e70130d..e465c780c8 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -39,6 +39,7 @@ extra-source-files: INSTALL.md CONTRIBUTORS.md CONTRIBUTING.md + .hspec source-repository head type: git @@ -366,12 +367,9 @@ test-suite tests main-is: Main.hs build-depends: purescript - , tasty - , tasty-golden - , tasty-hspec - , tasty-quickcheck , hspec , HUnit + , QuickCheck , regex-base build-tool-depends: hspec-discover:hspec-discover -any @@ -392,6 +390,7 @@ test-suite tests TestBundle TestCompiler TestCoreFn + TestCst TestDocs TestGraph TestHierarchy diff --git a/stack.yaml b/stack.yaml index 982dffce11..fce38e1d0e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,6 +9,12 @@ ghc-options: "$locals": -O2 -Werror extra-deps: - language-javascript-0.7.0.0 +- git: https://github.com/hspec/hspec.git + commit: 8f628c861d01ec8fc0a94ffdfe31e4399bd049d1 + subdirs: + - . + - hspec-core + - hspec-discover nix: enable: false packages: diff --git a/tests/Main.hs b/tests/Main.hs index 2617d33e9e..a9d9b7e363 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -8,10 +8,11 @@ module Main (main) where import Prelude () import Prelude.Compat -import Test.Tasty +import Test.Hspec import qualified TestCompiler import qualified TestCoreFn +import qualified TestCst import qualified TestDocs import qualified TestHierarchy import qualified TestPrimDocs @@ -33,34 +34,19 @@ main = do heading "Updating support code" TestUtils.updateSupportCode - ideTests <- TestIde.main - compilerTests <- TestCompiler.main - makeTests <- TestMake.main - psciTests <- TestPsci.main - pscBundleTests <- TestBundle.main - coreFnTests <- TestCoreFn.main - docsTests <- TestDocs.main - primDocsTests <- TestPrimDocs.main - publishTests <- TestPscPublish.main - hierarchyTests <- TestHierarchy.main - graphTests <- TestGraph.main - - defaultMain $ - testGroup - "Tests" - [ compilerTests - , makeTests - , psciTests - , pscBundleTests - , ideTests - , coreFnTests - , docsTests - , primDocsTests - , publishTests - , hierarchyTests - , graphTests - ] - + hspec $ do + describe "cst" TestCst.spec + describe "ide" TestIde.spec + describe "compiler" TestCompiler.spec + describe "make" TestMake.spec + describe "psci" TestPsci.spec + describe "bundle" TestBundle.spec + describe "corefn" TestCoreFn.spec + describe "docs" TestDocs.spec + describe "prim-docs" TestPrimDocs.spec + describe "publish" TestPscPublish.spec + describe "hierarchy" TestHierarchy.spec + describe "graph" TestGraph.spec where heading msg = do putStrLn "" diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs index ab209d5989..a8d71ab5d3 100644 --- a/tests/TestBundle.hs +++ b/tests/TestBundle.hs @@ -29,11 +29,7 @@ import System.IO.UTF8 import qualified System.FilePath.Glob as Glob import TestUtils -import Test.Tasty -import Test.Tasty.Hspec - -main :: IO TestTree -main = testSpec "bundle" spec +import Test.Hspec spec :: Spec spec = do diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 2b0ec78c35..ced763e9ce 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -21,9 +21,10 @@ module TestCompiler where -- -- @shouldFailWith TypesDoNotUnify -- -- @shouldFailWith TransitiveExportError -- --- Failing tests also check their output against the relative golden files (`.out`). --- The golden files are generated automatically when missing, and can be updated --- by passing `--accept` to `--test-arguments.` +-- Warning and failing tests also check their output against the relative +-- golden files (`.out`). The golden files are generated automatically when +-- missing, and can be updated by setting the "HSPEC_ACCEPT" environment +-- variable, e.g. by running `HSPEC_ACCEPT=true stack test`. import Prelude () import Prelude.Compat @@ -39,7 +40,6 @@ import qualified Data.Text.Encoding as T import qualified Data.Map as M -import qualified Data.ByteString.Lazy as BS import Control.Monad @@ -53,29 +53,26 @@ import Text.Regex.Base import Text.Regex.TDFA (Regex) import TestUtils -import Test.Tasty -import Test.Tasty.Hspec -import Test.Tasty.Golden (goldenVsString) - -main :: IO TestTree -main = do - (supportModules, supportExterns, supportForeigns) <- setupSupportModules - passing <- passingTests supportModules supportExterns supportForeigns - warning <- warningTests supportModules supportExterns supportForeigns - failing <- failingTests supportModules supportExterns supportForeigns - return . testGroup "compiler" $ [passing, warning, failing] +import Test.Hspec + +spec :: Spec +spec = do + (supportModules, supportExterns, supportForeigns) <- runIO setupSupportModules + + passingTests supportModules supportExterns supportForeigns + warningTests supportModules supportExterns supportForeigns + failingTests supportModules supportExterns supportForeigns passingTests :: [P.Module] -> [P.ExternsFile] -> M.Map P.ModuleName FilePath - -> IO TestTree + -> Spec passingTests supportModules supportExterns supportForeigns = do - passingTestCases <- getTestFiles "passing" + passingTestCases <- runIO $ getTestFiles "passing" + outputFile <- runIO $ createOutputFile logfile - outputFile <- createOutputFile logfile - - testSpec "Passing examples" $ + describe "Passing examples" $ forM_ passingTestCases $ \testPurs -> it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ assertCompiles supportModules supportExterns supportForeigns testPurs outputFile @@ -84,41 +81,36 @@ warningTests :: [P.Module] -> [P.ExternsFile] -> M.Map P.ModuleName FilePath - -> IO TestTree + -> Spec warningTests supportModules supportExterns supportForeigns = do - warningTestCases <- getTestFiles "warning" - tests <- forM warningTestCases $ \testPurs -> do - let mainPath = getTestMain testPurs - expectedWarnings <- getShouldWarnWith mainPath - wTc <- testSpecs $ - it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $ + warningTestCases <- runIO $ getTestFiles "warning" + + describe "Warning examples" $ + forM_ warningTestCases $ \testPurs -> do + let mainPath = getTestMain testPurs + expectedWarnings <- runIO $ getShouldWarnWith mainPath + it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $ do assertCompilesWithWarnings supportModules supportExterns supportForeigns testPurs expectedWarnings - return $ wTc ++ [ goldenVsString - ("'" <> takeFileName mainPath <> "' golden test") - (replaceExtension mainPath ".out") - (BS.fromStrict . T.encodeUtf8 . T.pack <$> printErrorOrWarning supportModules supportExterns supportForeigns testPurs) - ] - return $ testGroup "Warning examples" $ concat tests + goldenVsString + (replaceExtension mainPath ".out") + (T.encodeUtf8 . T.pack <$> printErrorOrWarning supportModules supportExterns supportForeigns testPurs) failingTests :: [P.Module] -> [P.ExternsFile] -> M.Map P.ModuleName FilePath - -> IO TestTree + -> Spec failingTests supportModules supportExterns supportForeigns = do - failingTestCases <- getTestFiles "failing" - tests <- forM failingTestCases $ \testPurs -> do - let mainPath = getTestMain testPurs - expectedFailures <- getShouldFailWith mainPath - fTc <- testSpecs $ - it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ + failingTestCases <- runIO $ getTestFiles "failing" + describe "Failing examples" $ do + forM_ failingTestCases $ \testPurs -> do + let mainPath = getTestMain testPurs + expectedFailures <- runIO $ getShouldFailWith mainPath + it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do assertDoesNotCompile supportModules supportExterns supportForeigns testPurs expectedFailures - return $ fTc ++ [ goldenVsString - ("'" <> takeFileName mainPath <> "' golden test") - (replaceExtension mainPath ".out") - (BS.fromStrict . T.encodeUtf8 . T.pack <$> printErrorOrWarning supportModules supportExterns supportForeigns testPurs) - ] - return $ testGroup "Failing examples" $ concat tests + goldenVsString + (replaceExtension mainPath ".out") + (T.encodeUtf8 . T.pack <$> printErrorOrWarning supportModules supportExterns supportForeigns testPurs) checkShouldReport :: [String] -> (P.MultipleErrors -> String) -> P.MultipleErrors -> Maybe String checkShouldReport expected prettyPrintDiagnostics errs = diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index b4eff97481..0f5b851021 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -module TestCoreFn (main) where +module TestCoreFn (spec) where import Prelude () import Prelude.Compat @@ -22,11 +22,7 @@ import Language.PureScript.CoreFn.ToJSON import Language.PureScript.Names import Language.PureScript.PSString -import Test.Tasty -import Test.Tasty.Hspec - -main :: IO TestTree -main = testSpec "corefn" spec +import Test.Hspec parseModule :: Value -> Result (Version, Module Ann) parseModule = parse moduleFromJSON @@ -42,7 +38,7 @@ isSuccess (Aeson.Success _) = True isSuccess _ = False spec :: Spec -spec = context "CoreFnFromJsonTest" $ do +spec = context "CoreFnFromJson" $ do let mn = ModuleName "Example.Main" mp = "src/Example/Main.purs" ss = SourceSpan mp (SourcePos 0 0) (SourcePos 0 0) diff --git a/lib/purescript-cst/tests/TestCst.hs b/tests/TestCst.hs similarity index 75% rename from lib/purescript-cst/tests/TestCst.hs rename to tests/TestCst.hs index 6587a435e2..20f06ad0cf 100644 --- a/lib/purescript-cst/tests/TestCst.hs +++ b/tests/TestCst.hs @@ -5,16 +5,15 @@ module TestCst where import Prelude -import Control.Monad (when) -import qualified Data.ByteString.Lazy as BS +import Control.Monad (when, forM_) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.IO as Text -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Golden (goldenVsString, findByExtension) -import Test.Tasty.QuickCheck +import Test.Hspec +import Test.QuickCheck +import TestUtils import Text.Read (readMaybe) import Language.PureScript.CST.Errors as CST import Language.PureScript.CST.Lexer as CST @@ -22,23 +21,20 @@ import Language.PureScript.CST.Print as CST import Language.PureScript.CST.Types import System.FilePath (takeBaseName, replaceExtension) -main :: IO TestTree -main = do - lytTests <- layoutTests - pure $ testGroup "cst" - [ lytTests - , litTests - ] - -layoutTests :: IO TestTree -layoutTests = do - pursFiles <- findByExtension [".purs"] "./tests/purs/layout" - return $ testGroup "Layout golden tests" $ do - file <- pursFiles - pure $ goldenVsString - (takeBaseName file) - (replaceExtension file ".out") - (BS.fromStrict . Text.encodeUtf8 <$> runLexer file) +spec :: Spec +spec = do + layoutSpec + literalsSpec + +layoutSpec :: Spec +layoutSpec = do + pursFiles <- runIO $ concat <$> getTestFiles "layout" + describe "Layout golden tests" $ do + forM_ pursFiles $ \file -> + it (takeBaseName file) $ + goldenVsString + (replaceExtension file ".out") + (Text.encodeUtf8 <$> runLexer file) where runLexer file = do src <- Text.readFile file @@ -48,25 +44,27 @@ layoutTests = do Right toks -> do pure $ CST.printTokens toks -litTests :: TestTree -litTests = testGroup "Literals" - [ testProperty "Integer" $ - checkTok checkReadNum (\case TokInt _ a -> Just a; _ -> Nothing) . unInt - , testProperty "Hex" $ - checkTok checkReadNum (\case TokInt _ a -> Just a; _ -> Nothing) . unHex - , testProperty "Number" $ - checkTok checkReadNum (\case TokNumber _ a -> Just a; _ -> Nothing) . unFloat - , testProperty "Exponent" $ - checkTok checkReadNum (\case TokNumber _ a -> Just a; _ -> Nothing) . unExponent - - , testProperty "Integer (round trip)" $ roundTripTok . unInt - , testProperty "Hex (round trip)" $ roundTripTok . unHex - , testProperty "Number (round trip)" $ roundTripTok . unFloat - , testProperty "Exponent (round trip)" $ roundTripTok . unExponent - , testProperty "Char (round trip)" $ roundTripTok . unChar - , testProperty "String (round trip)" $ roundTripTok . unString - , testProperty "Raw String (round trip)" $ roundTripTok . unRawString - ] +literalsSpec :: Spec +literalsSpec = describe "Literals" $ do + testProperty "Integer" $ + checkTok checkReadNum (\case TokInt _ a -> Just a; _ -> Nothing) . unInt + testProperty "Hex" $ + checkTok checkReadNum (\case TokInt _ a -> Just a; _ -> Nothing) . unHex + testProperty "Number" $ + checkTok checkReadNum (\case TokNumber _ a -> Just a; _ -> Nothing) . unFloat + testProperty "Exponent" $ + checkTok checkReadNum (\case TokNumber _ a -> Just a; _ -> Nothing) . unExponent + + testProperty "Integer (round trip)" $ roundTripTok . unInt + testProperty "Hex (round trip)" $ roundTripTok . unHex + testProperty "Number (round trip)" $ roundTripTok . unFloat + testProperty "Exponent (round trip)" $ roundTripTok . unExponent + testProperty "Char (round trip)" $ roundTripTok . unChar + testProperty "String (round trip)" $ roundTripTok . unString + testProperty "Raw String (round trip)" $ roundTripTok . unRawString + + where + testProperty name test = specify name (property test) readTok' :: String -> Text -> Gen SourceToken readTok' failMsg t = case CST.lex t of diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 013dc7d9c5..4daf912aae 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -29,11 +29,7 @@ import Web.Bower.PackageMeta (parsePackageName, runPackageName) import TestPscPublish (preparePackage) -import Test.Tasty -import Test.Tasty.Hspec (Spec, it, context, expectationFailure, runIO, testSpec) - -main :: IO TestTree -main = testSpec "docs" spec +import Test.Hspec spec :: Spec spec = do @@ -306,8 +302,8 @@ displayAssertionFailure = \case "in rendered code for " <> decl <> ", bad link location for " <> target <> ": expected " <> T.pack (show expected) <> " got " <> T.pack (show actual) - WrongOrder _ before after' -> - "expected to see " <> before <> " before " <> after' + WrongOrder _ before' after' -> + "expected to see " <> before' <> " before " <> after' displayTagsAssertionFailure :: TagsAssertionFailure -> Text displayTagsAssertionFailure = \case @@ -462,20 +458,20 @@ runAssertion assertion linksCtx Docs.Module{..} = Nothing -> Fail (LinkedDeclarationMissing mn decl destTitle) - ShouldComeBefore mn before after' -> + ShouldComeBefore mn before' after' -> let decls = declarationsFor mn indexOf :: Text -> Maybe Int indexOf title = findIndex ((==) title . Docs.declTitle) decls in - case (indexOf before, indexOf after') of + case (indexOf before', indexOf after') of (Just i, Just j) -> if i < j then Pass - else Fail (WrongOrder mn before after') + else Fail (WrongOrder mn before' after') (Nothing, _) -> - Fail (NotDocumented mn before) + Fail (NotDocumented mn before') (_, Nothing) -> Fail (NotDocumented mn after') diff --git a/tests/TestGraph.hs b/tests/TestGraph.hs index e83b32a31e..a4b2ac744c 100644 --- a/tests/TestGraph.hs +++ b/tests/TestGraph.hs @@ -3,8 +3,7 @@ module TestGraph where import Prelude () import Prelude.Compat -import Test.Tasty -import Test.Tasty.Hspec +import Test.Hspec import System.IO.UTF8 (readUTF8FileT) import Data.Either (isLeft) @@ -13,10 +12,6 @@ import qualified Data.Text.Encoding as Text import qualified Data.Aeson as Json import qualified Language.PureScript as P - -main :: IO TestTree -main = testSpec "graph" spec - spec :: Spec spec = do let baseDir = "tests/purs/graph/" diff --git a/tests/TestHierarchy.hs b/tests/TestHierarchy.hs index 96656a47b7..ad1d26a9df 100644 --- a/tests/TestHierarchy.hs +++ b/tests/TestHierarchy.hs @@ -6,11 +6,10 @@ import Prelude import Language.PureScript.Hierarchy import qualified Language.PureScript as P -import Test.Tasty -import Test.Tasty.Hspec (describe, it, shouldBe, testSpec) +import Test.Hspec -main :: IO TestTree -main = testSpec "hierarchy" $ do +spec :: Spec +spec = describe "hierarchy" $ do describe "Language.PureScript.Hierarchy" $ do describe "prettyPrint" $ do it "creates just the node when there is no relation" $ do diff --git a/tests/TestIde.hs b/tests/TestIde.hs index 8879d85a1e..2ed41af7ff 100644 --- a/tests/TestIde.hs +++ b/tests/TestIde.hs @@ -5,12 +5,11 @@ import Prelude import Control.Monad (unless) import Language.PureScript.Ide.Test import qualified PscIdeSpec -import Test.Tasty -import Test.Tasty.Hspec +import Test.Hspec -main :: IO TestTree -main = - testSpec "ide" (beforeAll_ setup PscIdeSpec.spec) +spec :: Spec +spec = + beforeAll_ setup PscIdeSpec.spec where setup = do deleteOutputFolder diff --git a/tests/TestMake.hs b/tests/TestMake.hs index e3f312a84e..c4d811e1ac 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -26,8 +26,7 @@ import System.Directory import System.IO.Error (isDoesNotExistError) import System.IO.UTF8 (readUTF8FilesT, writeUTF8FileT) -import Test.Tasty -import Test.Tasty.Hspec +import Test.Hspec utcMidnightOnDate :: Integer -> Int -> Int -> UTCTime utcMidnightOnDate year month day = UTCTime (fromGregorian year month day) (secondsToDiffTime 0) @@ -40,9 +39,6 @@ timestampD = utcMidnightOnDate 2019 1 4 timestampE = utcMidnightOnDate 2019 1 5 timestampF = utcMidnightOnDate 2019 1 6 -main :: IO TestTree -main = testSpec "make" spec - spec :: Spec spec = do let sourcesDir = "tests/purs/make" diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index d7690635ba..2cfb01aaa5 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -10,12 +10,7 @@ import qualified Data.Text as Text import qualified Language.PureScript as P import qualified Language.PureScript.Docs as D -import Test.Tasty -import Test.Tasty.Hspec (Spec, testSpec, it) -import Test.Hspec (shouldBe) - -main :: IO TestTree -main = testSpec "prim docs" spec +import Test.Hspec spec :: Spec spec = do diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index c2a7121237..78e5085b9e 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -24,13 +24,9 @@ import Language.PureScript.Publish (PublishOptions(..), defaultPublishOptions) import qualified Language.PureScript.Publish as Publish import qualified Language.PureScript.Publish.ErrorsWarnings as Publish -import Test.Tasty -import Test.Tasty.Hspec (Spec, Expectation, runIO, context, it, expectationFailure, testSpec) +import Test.Hspec import TestUtils hiding (inferForeignModules, makeActions) -main :: IO TestTree -main = testSpec "publish" spec - spec :: Spec spec = do context "preparePackage with json roundtrips" $ do @@ -67,14 +63,14 @@ data TestResult roundTrip :: UploadedPackage -> TestResult roundTrip pkg = - let before = A.encode pkg - in case A.eitherDecode before of + let before' = A.encode pkg + in case A.eitherDecode before' of Left err -> ParseFailed err Right parsed -> do let after' = A.encode (parsed :: UploadedPackage) - if before == after' - then Pass before - else Mismatch before after' + if before' == after' + then Pass before' + else Mismatch before' after' testRunOptions :: FilePath -> PublishOptions testRunOptions resolutionsFile = defaultPublishOptions diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index 1f985c194f..9f7d9fa27c 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -1,17 +1,15 @@ module TestPsci where import Prelude () -import Prelude.Compat import TestPsci.CommandTest (commandTests) import TestPsci.CompletionTest (completionTests) import TestPsci.EvalTest (evalTests) -import Test.Tasty -import Test.Tasty.Hspec +import Test.Hspec -main :: IO TestTree -main = testSpec "repl" $ do +spec :: Spec +spec = do completionTests commandTests evalTests diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index a45a3cb68d..852d2c7de5 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -17,22 +17,27 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Writer.Class (tell) import Control.Exception +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS import Data.Char (isSpace) import Data.Function (on) import Data.List (sort, sortBy, stripPrefix, groupBy) import qualified Data.Map as M +import Data.Maybe (isJust) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Data.Time.Clock (UTCTime()) import Data.Tuple (swap) -import System.Process hiding (cwd) import System.Directory -import System.IO.UTF8 (readUTF8FileT) import System.Exit (exitFailure) +import System.Environment (lookupEnv) import System.FilePath +import System.IO.Error (isDoesNotExistError) +import System.IO.UTF8 (readUTF8FileT) +import System.Process hiding (cwd) import qualified System.FilePath.Glob as Glob import System.IO -import Test.Tasty.Hspec - +import Test.Hspec findNodeProcess :: IO (Maybe String) findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names @@ -236,3 +241,41 @@ modulesDir = ".test_modules" "node_modules" logpath :: FilePath logpath = "purescript-output" + +-- | Assert that the contents of the provided file path match the result of the +-- provided action. If the "HSPEC_ACCEPT" environment variable is set, or if the +-- file does not already exist, we write the resulting ByteString out to the +-- provided file path instead. However, if the "CI" environment variable is +-- set, "HSPEC_ACCEPT" is ignored and we require that the file does exist with +-- the correct contents (see #3808). Based (very loosely) on the tasty-golden +-- package. +goldenVsString + :: HasCallStack -- For expectationFailure; use the call site for better failure locations + => FilePath + -> IO ByteString + -> Expectation +goldenVsString goldenFile testAction = do + accept <- isJust <$> lookupEnv "HSPEC_ACCEPT" + ci <- isJust <$> lookupEnv "CI" + goldenContents <- tryJust (guard . isDoesNotExistError) (BS.readFile goldenFile) + case goldenContents of + Left () -> + -- The golden file does not exist + if ci + then expectationFailure $ "Missing golden file: " ++ goldenFile + else createOrReplaceGoldenFile + + Right _ | not ci && accept -> + createOrReplaceGoldenFile + + Right expected -> do + actual <- testAction + if expected == actual + then pure () + else expectationFailure $ + "Test output differed from '" ++ goldenFile ++ "'; got:\n" ++ + T.unpack (T.decodeUtf8With (\_ _ -> Just '\xFFFD') actual) + where + createOrReplaceGoldenFile = do + testAction >>= BS.writeFile goldenFile + pendingWith "Accepting new output" diff --git a/lib/purescript-cst/tests/purs/layout/.gitattributes b/tests/purs/layout/.gitattributes similarity index 100% rename from lib/purescript-cst/tests/purs/layout/.gitattributes rename to tests/purs/layout/.gitattributes diff --git a/lib/purescript-cst/tests/purs/layout/AdoIn.out b/tests/purs/layout/AdoIn.out similarity index 100% rename from lib/purescript-cst/tests/purs/layout/AdoIn.out rename to tests/purs/layout/AdoIn.out diff --git a/lib/purescript-cst/tests/purs/layout/AdoIn.purs b/tests/purs/layout/AdoIn.purs similarity index 100% rename from lib/purescript-cst/tests/purs/layout/AdoIn.purs rename to tests/purs/layout/AdoIn.purs diff --git a/lib/purescript-cst/tests/purs/layout/CaseGuards.out b/tests/purs/layout/CaseGuards.out similarity index 100% rename from lib/purescript-cst/tests/purs/layout/CaseGuards.out rename to tests/purs/layout/CaseGuards.out diff --git a/lib/purescript-cst/tests/purs/layout/CaseGuards.purs b/tests/purs/layout/CaseGuards.purs similarity index 100% rename from lib/purescript-cst/tests/purs/layout/CaseGuards.purs rename to tests/purs/layout/CaseGuards.purs diff --git a/lib/purescript-cst/tests/purs/layout/CaseWhere.out b/tests/purs/layout/CaseWhere.out similarity index 100% rename from lib/purescript-cst/tests/purs/layout/CaseWhere.out rename to tests/purs/layout/CaseWhere.out diff --git a/lib/purescript-cst/tests/purs/layout/CaseWhere.purs b/tests/purs/layout/CaseWhere.purs similarity index 100% rename from lib/purescript-cst/tests/purs/layout/CaseWhere.purs rename to tests/purs/layout/CaseWhere.purs diff --git a/lib/purescript-cst/tests/purs/layout/ClassHead.out b/tests/purs/layout/ClassHead.out similarity index 100% rename from lib/purescript-cst/tests/purs/layout/ClassHead.out rename to tests/purs/layout/ClassHead.out diff --git a/lib/purescript-cst/tests/purs/layout/ClassHead.purs b/tests/purs/layout/ClassHead.purs similarity index 100% rename from lib/purescript-cst/tests/purs/layout/ClassHead.purs rename to tests/purs/layout/ClassHead.purs diff --git a/lib/purescript-cst/tests/purs/layout/Commas.out b/tests/purs/layout/Commas.out similarity index 100% rename from lib/purescript-cst/tests/purs/layout/Commas.out rename to tests/purs/layout/Commas.out diff --git a/lib/purescript-cst/tests/purs/layout/Commas.purs b/tests/purs/layout/Commas.purs similarity index 100% rename from lib/purescript-cst/tests/purs/layout/Commas.purs rename to tests/purs/layout/Commas.purs diff --git a/lib/purescript-cst/tests/purs/layout/Delimiter.out b/tests/purs/layout/Delimiter.out similarity index 100% rename from lib/purescript-cst/tests/purs/layout/Delimiter.out rename to tests/purs/layout/Delimiter.out diff --git a/lib/purescript-cst/tests/purs/layout/Delimiter.purs b/tests/purs/layout/Delimiter.purs similarity index 100% rename from lib/purescript-cst/tests/purs/layout/Delimiter.purs rename to tests/purs/layout/Delimiter.purs diff --git a/lib/purescript-cst/tests/purs/layout/DoLet.out b/tests/purs/layout/DoLet.out similarity index 100% rename from lib/purescript-cst/tests/purs/layout/DoLet.out rename to tests/purs/layout/DoLet.out diff --git a/lib/purescript-cst/tests/purs/layout/DoLet.purs b/tests/purs/layout/DoLet.purs similarity index 100% rename from lib/purescript-cst/tests/purs/layout/DoLet.purs rename to tests/purs/layout/DoLet.purs diff --git a/lib/purescript-cst/tests/purs/layout/DoOperator.out b/tests/purs/layout/DoOperator.out similarity index 100% rename from lib/purescript-cst/tests/purs/layout/DoOperator.out rename to tests/purs/layout/DoOperator.out diff --git a/lib/purescript-cst/tests/purs/layout/DoOperator.purs b/tests/purs/layout/DoOperator.purs similarity index 100% rename from lib/purescript-cst/tests/purs/layout/DoOperator.purs rename to tests/purs/layout/DoOperator.purs diff --git a/lib/purescript-cst/tests/purs/layout/DoWhere.out b/tests/purs/layout/DoWhere.out similarity index 100% rename from lib/purescript-cst/tests/purs/layout/DoWhere.out rename to tests/purs/layout/DoWhere.out diff --git a/lib/purescript-cst/tests/purs/layout/DoWhere.purs b/tests/purs/layout/DoWhere.purs similarity index 100% rename from lib/purescript-cst/tests/purs/layout/DoWhere.purs rename to tests/purs/layout/DoWhere.purs diff --git a/lib/purescript-cst/tests/purs/layout/IfThenElseDo.out b/tests/purs/layout/IfThenElseDo.out similarity index 100% rename from lib/purescript-cst/tests/purs/layout/IfThenElseDo.out rename to tests/purs/layout/IfThenElseDo.out diff --git a/lib/purescript-cst/tests/purs/layout/IfThenElseDo.purs b/tests/purs/layout/IfThenElseDo.purs similarity index 100% rename from lib/purescript-cst/tests/purs/layout/IfThenElseDo.purs rename to tests/purs/layout/IfThenElseDo.purs diff --git a/lib/purescript-cst/tests/purs/layout/InstanceChainElse.out b/tests/purs/layout/InstanceChainElse.out similarity index 100% rename from lib/purescript-cst/tests/purs/layout/InstanceChainElse.out rename to tests/purs/layout/InstanceChainElse.out diff --git a/lib/purescript-cst/tests/purs/layout/InstanceChainElse.purs b/tests/purs/layout/InstanceChainElse.purs similarity index 100% rename from lib/purescript-cst/tests/purs/layout/InstanceChainElse.purs rename to tests/purs/layout/InstanceChainElse.purs diff --git a/lib/purescript-cst/tests/purs/layout/LetGuards.out b/tests/purs/layout/LetGuards.out similarity index 100% rename from lib/purescript-cst/tests/purs/layout/LetGuards.out rename to tests/purs/layout/LetGuards.out diff --git a/lib/purescript-cst/tests/purs/layout/LetGuards.purs b/tests/purs/layout/LetGuards.purs similarity index 100% rename from lib/purescript-cst/tests/purs/layout/LetGuards.purs rename to tests/purs/layout/LetGuards.purs From 0fcbddf5aa07b905b1bb0313c53b01b068470d03 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sat, 24 Apr 2021 22:41:00 +0100 Subject: [PATCH 1303/1580] Avoid compiling tests with diagnostics twice (#4079) * Avoid compiling tests with diagnostics twice Previously we compiled every warning and failing test example twice. Now we just do it once. This speeds up the tests. I've taken the opportunity to simplify the API provided by TestUtils slightly. I've removed the callback-style API provided by `assert` (because imo it just wasn't pulling its weight and isn't needed when we already have `compile`, and also it encouraged ignoring warnings). I've also removed the `check` argument to `compile`. The only way it was being used was in the passing tests, to assert that we had a module called `Main` in each test. However, there's not really any need for this check: if a test has no `Main` module, we'll find that out (and the test will fail) when we try to run it under `node`. These changes shave about 20s off the test suite for me locally - from 125s down to 105s. That's not quite as much as I'd hoped but still nice. * Update CHANGELOG --- CHANGELOG.md | 2 + tests/TestBundle.hs | 64 +++++++++++------------ tests/TestCompiler.hs | 116 +++++++++++++++++++----------------------- tests/TestUtils.hs | 26 ++-------- 4 files changed, 89 insertions(+), 119 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 101b5c802e..f846f85eb2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -26,6 +26,8 @@ Internal: * Remove tasty from test suite and just use hspec (#4056, @hdgarrood) +* Avoid compiling tests with diagnostics twice in test suite (#4079, @hdgarrood) + ## v0.14.1 New features: diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs index a8d71ab5d3..2069225791 100644 --- a/tests/TestBundle.hs +++ b/tests/TestBundle.hs @@ -10,7 +10,7 @@ import Prelude () import Prelude.Compat import qualified Language.PureScript as P -import Language.PureScript.Bundle +import Language.PureScript.Bundle import Data.Function (on) import Data.List (minimumBy) @@ -35,14 +35,14 @@ spec :: Spec spec = do (supportModules, supportExterns, supportForeigns) <- runIO $ setupSupportModules bundleTestCases <- runIO $ getTestFiles "bundle" - outputFile <- runIO $ createOutputFile logfile + outputFile <- runIO $ createOutputFile logfile context "Bundle examples" $ forM_ bundleTestCases $ \testPurs -> do it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile, bundle and run without error") $ assertBundles supportModules supportExterns supportForeigns testPurs outputFile where - + -- Takes the test entry point from a group of purs files - this is determined -- by the file with the shortest path name, as everything but the main file -- will be under a subdirectory. @@ -56,36 +56,34 @@ assertBundles -> [FilePath] -> Handle -> Expectation -assertBundles supportModules supportExterns supportForeigns inputFiles outputFile = - assert supportModules supportExterns supportForeigns inputFiles checkMain $ \e -> - case e of - Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs - Right _ -> do - process <- findNodeProcess - jsFiles <- Glob.globDir1 (Glob.compile "**/*.js") modulesDir - let entryPoint = modulesDir "index.js" - let entryModule = map (`ModuleIdentifier` Regular) ["Main"] - bundled <- runExceptT $ do - input <- forM jsFiles $ \filename -> do - js <- liftIO $ readUTF8File filename - mid <- guessModuleIdentifier filename - length js `seq` return (mid, Just filename, js) - bundleSM input entryModule (Just $ "Main") "PS" (Just entryPoint) Nothing - case bundled of - Right (_, js) -> do - writeUTF8File entryPoint js - result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process - hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" - case result of - Just (ExitSuccess, out, err) - | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err - | not (null out) && trim (last (lines out)) == "Done" -> do - hPutStr outputFile out - return Nothing - | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out - Just (ExitFailure _, _, err) -> return $ Just err - Nothing -> return $ Just "Couldn't find node.js executable" - Left err -> return . Just $ "Coud not bundle: " ++ show err +assertBundles supportModules supportExterns supportForeigns inputFiles outputFile = do + (result, _) <- compile supportModules supportExterns supportForeigns inputFiles + case result of + Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs + Right _ -> do + process <- findNodeProcess + jsFiles <- Glob.globDir1 (Glob.compile "**/*.js") modulesDir + let entryPoint = modulesDir "index.js" + let entryModule = map (`ModuleIdentifier` Regular) ["Main"] + bundled <- runExceptT $ do + input <- forM jsFiles $ \filename -> do + js <- liftIO $ readUTF8File filename + mid <- guessModuleIdentifier filename + length js `seq` return (mid, Just filename, js) + bundleSM input entryModule (Just $ "Main") "PS" (Just entryPoint) Nothing + case bundled of + Right (_, js) -> do + writeUTF8File entryPoint js + nodeResult <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process + hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" + case nodeResult of + Just (ExitSuccess, out, err) + | not (null err) -> expectationFailure $ "Test wrote to stderr:\n\n" <> err + | not (null out) && trim (last (lines out)) == "Done" -> hPutStr outputFile out + | otherwise -> expectationFailure $ "Test did not finish with 'Done':\n\n" <> out + Just (ExitFailure _, _, err) -> expectationFailure err + Nothing -> expectationFailure "Couldn't find node.js executable" + Left err -> expectationFailure $ "Could not bundle: " ++ show err logfile :: FilePath logfile = "bundle-tests.out" diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index ced763e9ce..d6524239b5 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -91,9 +91,6 @@ warningTests supportModules supportExterns supportForeigns = do expectedWarnings <- runIO $ getShouldWarnWith mainPath it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $ do assertCompilesWithWarnings supportModules supportExterns supportForeigns testPurs expectedWarnings - goldenVsString - (replaceExtension mainPath ".out") - (T.encodeUtf8 . T.pack <$> printErrorOrWarning supportModules supportExterns supportForeigns testPurs) failingTests :: [P.Module] @@ -108,26 +105,23 @@ failingTests supportModules supportExterns supportForeigns = do expectedFailures <- runIO $ getShouldFailWith mainPath it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do assertDoesNotCompile supportModules supportExterns supportForeigns testPurs expectedFailures - goldenVsString - (replaceExtension mainPath ".out") - (T.encodeUtf8 . T.pack <$> printErrorOrWarning supportModules supportExterns supportForeigns testPurs) -checkShouldReport :: [String] -> (P.MultipleErrors -> String) -> P.MultipleErrors -> Maybe String +checkShouldReport :: [String] -> (P.MultipleErrors -> String) -> P.MultipleErrors -> Expectation checkShouldReport expected prettyPrintDiagnostics errs = let actual = map P.errorCode $ P.runMultipleErrors errs in if sort expected == sort (map T.unpack actual) then checkPositioned errs - else Just $ "Expected these diagnostics: " ++ show expected ++ ", but got these: " + else expectationFailure $ "Expected these diagnostics: " ++ show expected ++ ", but got these: " ++ show actual ++ ", full diagnostic messages: \n" ++ prettyPrintDiagnostics errs -checkPositioned :: P.MultipleErrors -> Maybe String +checkPositioned :: P.MultipleErrors -> Expectation checkPositioned errs = case mapMaybe guardSpans (P.runMultipleErrors errs) of [] -> - Nothing + pure () errs' -> - Just + expectationFailure $ "Found diagnostics with missing source spans:\n" ++ unlines (map (P.renderBox . P.prettyPrintSingleError P.defaultPPEOptions) errs') where @@ -150,25 +144,23 @@ assertCompiles -> [FilePath] -> Handle -> Expectation -assertCompiles supportModules supportExterns supportForeigns inputFiles outputFile = - assert supportModules supportExterns supportForeigns inputFiles checkMain $ \e -> - case e of - Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs - Right _ -> do - process <- findNodeProcess - let entryPoint = modulesDir "index.js" - writeFile entryPoint "require('Main').main()" - result <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process - hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" - case result of - Just (ExitSuccess, out, err) - | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err - | not (null out) && trim (last (lines out)) == "Done" -> do - hPutStr outputFile out - return Nothing - | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out - Just (ExitFailure _, _, err) -> return $ Just err - Nothing -> return $ Just "Couldn't find node.js executable" +assertCompiles supportModules supportExterns supportForeigns inputFiles outputFile = do + (result, _) <- compile supportModules supportExterns supportForeigns inputFiles + case result of + Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs + Right _ -> do + process <- findNodeProcess + let entryPoint = modulesDir "index.js" + writeFile entryPoint "require('Main').main()" + nodeResult <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process + hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" + case nodeResult of + Just (ExitSuccess, out, err) + | not (null err) -> expectationFailure $ "Test wrote to stderr:\n\n" <> err + | not (null out) && trim (last (lines out)) == "Done" -> hPutStr outputFile out + | otherwise -> expectationFailure $ "Test did not finish with 'Done':\n\n" <> out + Just (ExitFailure _, _, err) -> expectationFailure err + Nothing -> expectationFailure "Couldn't find node.js executable" assertCompilesWithWarnings :: [P.Module] @@ -177,13 +169,16 @@ assertCompilesWithWarnings -> [FilePath] -> [String] -> Expectation -assertCompilesWithWarnings supportModules supportExterns supportForeigns inputFiles shouldWarnWith = - assert supportModules supportExterns supportForeigns inputFiles checkMain $ \e -> - case e of - Left errs -> - return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs - Right warnings -> - return $ checkShouldReport shouldWarnWith (P.prettyPrintMultipleWarnings P.defaultPPEOptions) warnings +assertCompilesWithWarnings supportModules supportExterns supportForeigns inputFiles shouldWarnWith = do + result'@(result, warnings) <- compile supportModules supportExterns supportForeigns inputFiles + case result of + Left errs -> + expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs + Right _ -> do + checkShouldReport shouldWarnWith (P.prettyPrintMultipleWarnings P.defaultPPEOptions) warnings + goldenVsString + (replaceExtension (getTestMain inputFiles) ".out") + (return . T.encodeUtf8 . T.pack $ printDiagnosticsForGoldenTest result') assertDoesNotCompile :: [P.Module] @@ -192,37 +187,32 @@ assertDoesNotCompile -> [FilePath] -> [String] -> Expectation -assertDoesNotCompile supportModules supportExterns supportForeigns inputFiles shouldFailWith = - assert supportModules supportExterns supportForeigns inputFiles noPreCheck $ \e -> - case e of - Left errs -> - return $ if null shouldFailWith - then Just $ "shouldFailWith declaration is missing (errors were: " - ++ show (map P.errorCode (P.runMultipleErrors errs)) - ++ ")" - else checkShouldReport shouldFailWith (P.prettyPrintMultipleErrors P.defaultPPEOptions) errs - Right _ -> - return $ Just "Should not have compiled" - - where - noPreCheck = const (return ()) +assertDoesNotCompile supportModules supportExterns supportForeigns inputFiles shouldFailWith = do + result <- compile supportModules supportExterns supportForeigns inputFiles + case fst result of + Left errs -> do + when (null shouldFailWith) + (expectationFailure $ + "shouldFailWith declaration is missing (errors were: " + ++ show (map P.errorCode (P.runMultipleErrors errs)) + ++ ")") + checkShouldReport shouldFailWith (P.prettyPrintMultipleErrors P.defaultPPEOptions) errs + goldenVsString + (replaceExtension (getTestMain inputFiles) ".out") + (return . T.encodeUtf8 . T.pack $ printDiagnosticsForGoldenTest result) + Right _ -> + expectationFailure "Should not have compiled" -printErrorOrWarning - :: [P.Module] - -> [P.ExternsFile] - -> M.Map P.ModuleName FilePath - -> [FilePath] - -> IO String -printErrorOrWarning supportModules supportExterns supportForeigns inputFiles = do - -- Sorting the input files makes some messages (e.g., duplicate module) deterministic - (res, warnings) <- compile supportModules supportExterns supportForeigns (sort inputFiles) noPreCheck - return . normalizePaths $ case res of +-- Prints a set of diagnostics (i.e. errors or warnings) as a string, in order +-- to compare it to the contents of a golden test file. +printDiagnosticsForGoldenTest :: (Either P.MultipleErrors a, P.MultipleErrors) -> String +printDiagnosticsForGoldenTest (result, warnings) = + normalizePaths $ case result of Left errs -> + -- TODO: should probably include warnings when failing? P.prettyPrintMultipleErrors P.defaultPPEOptions errs Right _ -> P.prettyPrintMultipleWarnings P.defaultPPEOptions warnings - where - noPreCheck = const (return ()) -- Replaces Windows-style paths in an error or warning with POSIX paths normalizePaths :: String -> String diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 852d2c7de5..de68de3ca5 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -167,39 +167,19 @@ compile -> [P.ExternsFile] -> M.Map P.ModuleName FilePath -> [FilePath] - -> ([P.Module] -> IO ()) -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) -compile supportModules supportExterns supportForeigns inputFiles check = runTest $ do - fs <- liftIO $ readInput inputFiles +compile supportModules supportExterns supportForeigns inputFiles = runTest $ do + -- Sorting the input files makes some messages (e.g., duplicate module) deterministic + fs <- liftIO $ readInput (sort inputFiles) msWithWarnings <- CST.parseFromFiles id fs tell $ foldMap (\(fp, (ws, _)) -> CST.toMultipleWarnings fp ws) msWithWarnings let ms = fmap snd <$> msWithWarnings foreigns <- inferForeignModules ms - liftIO (check (map snd ms)) let actions = makeActions supportModules (foreigns `M.union` supportForeigns) case ms of [singleModule] -> pure <$> P.rebuildModule actions supportExterns (snd singleModule) _ -> P.make actions (CST.pureResult <$> supportModules ++ map snd ms) -assert - :: [P.Module] - -> [P.ExternsFile] - -> M.Map P.ModuleName FilePath - -> [FilePath] - -> ([P.Module] -> IO ()) - -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String)) - -> Expectation -assert supportModules supportExterns supportForeigns inputFiles check f = do - (e, w) <- compile supportModules supportExterns supportForeigns inputFiles check - maybeErr <- f (const w <$> e) - maybe (return ()) expectationFailure maybeErr - -checkMain :: [P.Module] -> IO () -checkMain ms = - unless (any ((== P.moduleNameFromString "Main") . P.getModuleName) ms) - (fail "Main module missing") - - makeActions :: [P.Module] -> M.Map P.ModuleName FilePath -> P.MakeActions P.Make makeActions modules foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False) { P.getInputTimestampsAndHashes = getInputTimestampsAndHashes From ba34b9db6c2581bc380c4bb1eedc39821487c979 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sun, 25 Apr 2021 21:24:45 -0400 Subject: [PATCH 1304/1580] Do less work in test initialization (#4080) The goal of this commit is to minimize the amount of time it takes for Hspec to get from the starting line to a complete spec tree, and thus to improve the time it takes to run individual or small numbers of tests from the suite. First, Hspec `beforeAll`/`beforeAllWith` hooks are used to defer some work until Hspec actually runs the tests that require that work. Second, the `npm install` and `bower install` pre-test steps are throttled to run once a day, provided that the output directories already exist and that their input files haven't changed. --- CHANGELOG.md | 2 + tests/Main.hs | 13 +--- tests/TestBundle.hs | 26 +++----- tests/TestCompiler.hs | 89 ++++++++++--------------- tests/TestDocs.hs | 81 ++++++----------------- tests/TestPsci/CompletionTest.hs | 109 ++++++++++++++++--------------- tests/TestUtils.hs | 70 +++++++++++++++----- tests/support/.gitignore | 1 + 8 files changed, 180 insertions(+), 211 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f846f85eb2..32247a85c2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -28,6 +28,8 @@ Internal: * Avoid compiling tests with diagnostics twice in test suite (#4079, @hdgarrood) +* Do less work in test initialization (#4080, @rhendric) + ## v0.14.1 New features: diff --git a/tests/Main.hs b/tests/Main.hs index a9d9b7e363..2bdad5d6f4 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -31,26 +31,19 @@ main = do hSetEncoding stdout utf8 hSetEncoding stderr utf8 - heading "Updating support code" TestUtils.updateSupportCode hspec $ do describe "cst" TestCst.spec describe "ide" TestIde.spec - describe "compiler" TestCompiler.spec + beforeAll TestUtils.setupSupportModules $ do + describe "compiler" TestCompiler.spec + describe "bundle" TestBundle.spec describe "make" TestMake.spec describe "psci" TestPsci.spec - describe "bundle" TestBundle.spec describe "corefn" TestCoreFn.spec describe "docs" TestDocs.spec describe "prim-docs" TestPrimDocs.spec describe "publish" TestPscPublish.spec describe "hierarchy" TestHierarchy.spec describe "graph" TestGraph.spec - where - heading msg = do - putStrLn "" - putStrLn $ replicate 79 '#' - putStrLn $ "# " ++ msg - putStrLn $ replicate 79 '#' - putStrLn "" diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs index 2069225791..d16dffe21f 100644 --- a/tests/TestBundle.hs +++ b/tests/TestBundle.hs @@ -15,8 +15,6 @@ import Language.PureScript.Bundle import Data.Function (on) import Data.List (minimumBy) -import qualified Data.Map as M - import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except @@ -31,16 +29,14 @@ import qualified System.FilePath.Glob as Glob import TestUtils import Test.Hspec -spec :: Spec -spec = do - (supportModules, supportExterns, supportForeigns) <- runIO $ setupSupportModules - bundleTestCases <- runIO $ getTestFiles "bundle" - outputFile <- runIO $ createOutputFile logfile - +spec :: SpecWith SupportModules +spec = context "Bundle examples" $ - forM_ bundleTestCases $ \testPurs -> do - it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile, bundle and run without error") $ - assertBundles supportModules supportExterns supportForeigns testPurs outputFile + beforeAllWith ((<$> createOutputFile logfile) . (,)) $ do + bundleTestCases <- runIO $ getTestFiles "bundle" + forM_ bundleTestCases $ \testPurs -> do + it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile, bundle and run without error") $ \(support, outputFile) -> + assertBundles support testPurs outputFile where -- Takes the test entry point from a group of purs files - this is determined @@ -50,14 +46,12 @@ spec = do getTestMain = minimumBy (compare `on` length) assertBundles - :: [P.Module] - -> [P.ExternsFile] - -> M.Map P.ModuleName FilePath + :: SupportModules -> [FilePath] -> Handle -> Expectation -assertBundles supportModules supportExterns supportForeigns inputFiles outputFile = do - (result, _) <- compile supportModules supportExterns supportForeigns inputFiles +assertBundles support inputFiles outputFile = do + (result, _) <- compile support inputFiles case result of Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index d6524239b5..f0941c96df 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -33,13 +33,11 @@ import qualified Language.PureScript as P import Control.Arrow ((>>>)) import Data.Function (on) -import Data.List (sort, stripPrefix, intercalate, minimumBy) +import Data.List (sort, stripPrefix, minimumBy) import Data.Maybe (mapMaybe) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Data.Map as M - import Control.Monad @@ -55,56 +53,43 @@ import Text.Regex.TDFA (Regex) import TestUtils import Test.Hspec -spec :: Spec +spec :: SpecWith SupportModules spec = do - (supportModules, supportExterns, supportForeigns) <- runIO setupSupportModules - - passingTests supportModules supportExterns supportForeigns - warningTests supportModules supportExterns supportForeigns - failingTests supportModules supportExterns supportForeigns - -passingTests - :: [P.Module] - -> [P.ExternsFile] - -> M.Map P.ModuleName FilePath - -> Spec -passingTests supportModules supportExterns supportForeigns = do + passingTests + warningTests + failingTests + +passingTests :: SpecWith SupportModules +passingTests = do passingTestCases <- runIO $ getTestFiles "passing" - outputFile <- runIO $ createOutputFile logfile describe "Passing examples" $ - forM_ passingTestCases $ \testPurs -> - it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ - assertCompiles supportModules supportExterns supportForeigns testPurs outputFile - -warningTests - :: [P.Module] - -> [P.ExternsFile] - -> M.Map P.ModuleName FilePath - -> Spec -warningTests supportModules supportExterns supportForeigns = do + beforeAllWith ((<$> createOutputFile logfile) . (,)) $ + forM_ passingTestCases $ \testPurs -> + it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ \(support, outputFile) -> + assertCompiles support testPurs outputFile + +warningTests :: SpecWith SupportModules +warningTests = do warningTestCases <- runIO $ getTestFiles "warning" describe "Warning examples" $ forM_ warningTestCases $ \testPurs -> do let mainPath = getTestMain testPurs - expectedWarnings <- runIO $ getShouldWarnWith mainPath - it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $ do - assertCompilesWithWarnings supportModules supportExterns supportForeigns testPurs expectedWarnings - -failingTests - :: [P.Module] - -> [P.ExternsFile] - -> M.Map P.ModuleName FilePath - -> Spec -failingTests supportModules supportExterns supportForeigns = do + it ("'" <> takeFileName mainPath <> "' should compile with expected warning(s)") $ \support -> do + expectedWarnings <- getShouldWarnWith mainPath + assertCompilesWithWarnings support testPurs expectedWarnings + +failingTests :: SpecWith SupportModules +failingTests = do failingTestCases <- runIO $ getTestFiles "failing" + describe "Failing examples" $ do forM_ failingTestCases $ \testPurs -> do let mainPath = getTestMain testPurs - expectedFailures <- runIO $ getShouldFailWith mainPath - it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ do - assertDoesNotCompile supportModules supportExterns supportForeigns testPurs expectedFailures + it ("'" <> takeFileName mainPath <> "' should fail to compile") $ \support -> do + expectedFailures <- getShouldFailWith mainPath + assertDoesNotCompile support testPurs expectedFailures checkShouldReport :: [String] -> (P.MultipleErrors -> String) -> P.MultipleErrors -> Expectation checkShouldReport expected prettyPrintDiagnostics errs = @@ -138,14 +123,12 @@ checkPositioned errs = emptyPos = P.SourcePos 0 0 assertCompiles - :: [P.Module] - -> [P.ExternsFile] - -> M.Map P.ModuleName FilePath + :: SupportModules -> [FilePath] -> Handle -> Expectation -assertCompiles supportModules supportExterns supportForeigns inputFiles outputFile = do - (result, _) <- compile supportModules supportExterns supportForeigns inputFiles +assertCompiles support inputFiles outputFile = do + (result, _) <- compile support inputFiles case result of Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do @@ -163,14 +146,12 @@ assertCompiles supportModules supportExterns supportForeigns inputFiles outputFi Nothing -> expectationFailure "Couldn't find node.js executable" assertCompilesWithWarnings - :: [P.Module] - -> [P.ExternsFile] - -> M.Map P.ModuleName FilePath + :: SupportModules -> [FilePath] -> [String] -> Expectation -assertCompilesWithWarnings supportModules supportExterns supportForeigns inputFiles shouldWarnWith = do - result'@(result, warnings) <- compile supportModules supportExterns supportForeigns inputFiles +assertCompilesWithWarnings support inputFiles shouldWarnWith = do + result'@(result, warnings) <- compile support inputFiles case result of Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs @@ -181,14 +162,12 @@ assertCompilesWithWarnings supportModules supportExterns supportForeigns inputFi (return . T.encodeUtf8 . T.pack $ printDiagnosticsForGoldenTest result') assertDoesNotCompile - :: [P.Module] - -> [P.ExternsFile] - -> M.Map P.ModuleName FilePath + :: SupportModules -> [FilePath] -> [String] -> Expectation -assertDoesNotCompile supportModules supportExterns supportForeigns inputFiles shouldFailWith = do - result <- compile supportModules supportExterns supportForeigns inputFiles +assertDoesNotCompile support inputFiles shouldFailWith = do + result <- compile support inputFiles case fst result of Left errs -> do when (null shouldFailWith) diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 4daf912aae..0ff54b09ea 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -1,15 +1,9 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} - module TestDocs where import Prelude () import Prelude.Compat -import Control.Arrow (first) +import Data.Bifunctor (first) import Data.List (findIndex) import Data.Foldable import Safe (headMay) @@ -32,70 +26,37 @@ import TestPscPublish (preparePackage) import Test.Hspec spec :: Spec -spec = do - packageResult <- runIO (preparePackage "tests/purs/docs" "resolutions.json") - - case packageResult of - Left e -> - it "failed to produce docs" $ do - expectationFailure (Boxes.render (Publish.renderError e)) - Right pkg -> - mkSpec pkg - -mkSpec :: Docs.Package Docs.NotYetKnown -> Spec -mkSpec pkg@Docs.Package{..} = do - let linksCtx = Docs.getLinksContext pkg - +spec = beforeAll (handleDocPrepFailure <$> preparePackage "tests/purs/docs" "resolutions.json") $ context "Language.PureScript.Docs" $ do context "Doc generation tests:" $ - forM_ testCases $ \(mnString, assertions) -> do - let mn = P.moduleNameFromString mnString - mdl = find ((==) mn . Docs.modName) pkgModules - - context ("in module " ++ T.unpack mnString) $ - case mdl of - Nothing -> - it "exists in docs output" $ - expectationFailure ("module not found in docs: " ++ T.unpack mnString) - Just mdl' -> - toHspec linksCtx mdl' assertions - - context "Tag generation tests:" $ - forM_ testTagsCases $ \(mnString, assertions) -> do - let mn = P.moduleNameFromString mnString - mdl = find ((==) mn . Docs.modName) pkgModules - context ("in module " ++ T.unpack mnString) $ - case mdl of - Nothing -> - it "exists in docs output" $ - expectationFailure ("module not found in docs: " ++ T.unpack mnString) - Just mdl' -> - tagAssertionsToHspec mdl' assertions - - where - toHspec :: Docs.LinksContext -> Docs.Module -> [DocsAssertion] -> Spec - toHspec linksCtx mdl assertions = - forM_ assertions $ \a -> - it (T.unpack (displayAssertion a)) $ do - case runAssertion a linksCtx mdl of + mkSpec testCases displayAssertion $ \a pkg mdl -> + case runAssertion a (Docs.getLinksContext pkg) mdl of Pass -> pure () Fail reason -> expectationFailure (T.unpack (displayAssertionFailure reason)) - tagAssertionsToHspec :: Docs.Module -> [TagsAssertion] -> Spec - tagAssertionsToHspec mdl assertions = - let tags = Map.fromList $ Docs.tags mdl - in forM_ assertions $ \a -> - it (T.unpack (displayTagsAssertion a)) $ do - case runTagsAssertion a tags of + context "Tag generation tests:" $ + mkSpec testTagsCases displayTagsAssertion $ \a _ mdl -> + case runTagsAssertion a (Map.fromList $ Docs.tags mdl) of TagsPass -> pure () TagsFail reason -> expectationFailure (T.unpack (displayTagsAssertionFailure reason)) - -takeJust :: String -> Maybe a -> a -takeJust msg = fromMaybe (error msg) + where + handleDocPrepFailure = first (expectationFailure . ("failed to produce docs: " <>) . Boxes.render . Publish.renderError) + + mkSpec cases displayAssertion' runner = + forM_ cases $ \(mnString, assertions) -> do + let mn = P.moduleNameFromString mnString + context ("in module " ++ T.unpack mnString) $ + forM_ assertions $ \a -> + it (T.unpack (displayAssertion' a)) . either id $ \pkg@Docs.Package{..} -> + case find ((==) mn . Docs.modName) pkgModules of + Nothing -> + expectationFailure ("module not found in docs: " ++ T.unpack mnString) + Just mdl -> + runner a pkg mdl data DocsAssertion -- | Assert that a particular declaration is documented with the given diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index 579ec83009..e9712dd22b 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -7,6 +7,7 @@ import Prelude.Compat import Test.Hspec import Control.Monad.Trans.State.Strict (evalStateT) +import Data.Functor ((<&>)) import Data.List (sort) import qualified Data.Text as T import qualified Language.PureScript as P @@ -15,93 +16,93 @@ import TestPsci.TestEnv (initTestPSCiEnv) import TestUtils (getSupportModuleNames) completionTests :: Spec -completionTests = context "completionTests" $ do - mns <- runIO getSupportModuleNames - psciState <- runIO getPSCiStateForCompletion - mapM_ (assertCompletedOk psciState) (completionTestData mns) +completionTests = context "completionTests" $ + beforeAll getPSCiStateForCompletion $ + mapM_ assertCompletedOk completionTestData -- If the cursor is at the right end of the line, with the 1st element of the -- pair as the text in the line, then pressing tab should offer all the -- elements of the list (which is the 2nd element) as completions. -completionTestData :: [T.Text] -> [(String, [String])] -completionTestData supportModuleNames = +completionTestData :: [(String, IO [String])] +completionTestData = -- basic directives - [ (":h", [":help"]) - , (":r", [":reload"]) - , (":c", [":clear", ":complete"]) - , (":q", [":quit"]) - , (":b", [":browse"]) + [ (":h", pure [":help"]) + , (":r", pure [":reload"]) + , (":c", pure [":clear", ":complete"]) + , (":q", pure [":quit"]) + , (":b", pure [":browse"]) -- :browse should complete module names - , (":b Eff", map (":b Effect" ++) ["", ".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"]) - , (":b Effect.", map (":b Effect" ++) [".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"]) + , (":b Eff", pure $ map (":b Effect" ++) ["", ".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"]) + , (":b Effect.", pure $ map (":b Effect" ++) [".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"]) -- import should complete module names - , ("import Eff", map ("import Effect" ++) ["", ".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"]) - , ("import Effect.", map ("import Effect" ++) [".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"]) + , ("import Eff", pure $ map ("import Effect" ++) ["", ".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"]) + , ("import Effect.", pure $ map ("import Effect" ++) [".Unsafe", ".Class", ".Class.Console", ".Console", ".Uncurried", ".Ref"]) -- :quit, :help, :reload, :clear should not complete - , (":help ", []) - , (":quit ", []) - , (":reload ", []) - , (":clear ", []) + , (":help ", pure []) + , (":quit ", pure []) + , (":reload ", pure []) + , (":clear ", pure []) -- :show should complete its available arguments - , (":show ", [":show import", ":show loaded", ":show print"]) - , (":show a", []) + , (":show ", pure [":show import", ":show loaded", ":show print"]) + , (":show a", pure []) -- :type should complete next word from values and constructors in scope - , (":type uni", [":type unit"]) - , (":type E", [":type EQ"]) - , (":type P.", map (":type P." ++) ["EQ", "GT", "LT", "unit"]) -- import Prelude (unit, Ordering(..)) as P - , (":type Effect.Console.lo", []) - , (":type voi", []) + , (":type uni", pure [":type unit"]) + , (":type E", pure [":type EQ"]) + , (":type P.", pure $ map (":type P." ++) ["EQ", "GT", "LT", "unit"]) -- import Prelude (unit, Ordering(..)) as P + , (":type Effect.Console.lo", pure []) + , (":type voi", pure []) -- :kind should complete next word from types in scope - , (":kind Str", [":kind String"]) - , (":kind ST.", [":kind ST.Region", ":kind ST.ST"]) -- import Control.Monad.ST as ST - , (":kind STRef.", [":kind STRef.STRef"]) -- import Control.Monad.ST.Ref as STRef - , (":kind Effect.", []) + , (":kind Str", pure [":kind String"]) + , (":kind ST.", pure [":kind ST.Region", ":kind ST.ST"]) -- import Control.Monad.ST as ST + , (":kind STRef.", pure [":kind STRef.STRef"]) -- import Control.Monad.ST.Ref as STRef + , (":kind Effect.", pure []) -- Only one argument for these directives should be completed - , (":show import ", []) - , (":browse Data.List ", []) + , (":show import ", pure []) + , (":browse Data.List ", pure []) -- These directives take any number of completable terms - , (":type const compa", [":type const compare", ":type const comparing"]) - , (":kind Array In", [":kind Array Int"]) + , (":type const compa", pure [":type const compare", ":type const comparing"]) + , (":kind Array In", pure [":kind Array Int"]) -- a few other import tests - , ("impor", ["import"]) - , ("import ", map (T.unpack . mappend "import ") supportModuleNames) - , ("import Prelude ", []) + , ("impor", pure ["import"]) + , ("import ", getSupportModuleNames <&> map (T.unpack . mappend "import ")) + , ("import Prelude ", pure []) -- String and number literals should not be completed - , ("\"hi", []) - , ("34", []) + , ("\"hi", pure []) + , ("34", pure []) -- Identifiers and data constructors in scope should be completed - , ("uni", ["unit"]) - , ("G", ["GT"]) - , ("P.G", ["P.GT"]) - , ("P.uni", ["P.unit"]) - , ("voi", []) -- import Prelude hiding (void) - , ("Effect.Class.", []) + , ("uni", pure ["unit"]) + , ("G", pure ["GT"]) + , ("P.G", pure ["P.GT"]) + , ("P.uni", pure ["P.unit"]) + , ("voi", pure []) -- import Prelude hiding (void) + , ("Effect.Class.", pure []) -- complete first name after type annotation symbol - , ("1 :: I", ["1 :: Int"]) - , ("1 ::I", ["1 ::Int"]) - , ("1:: I", ["1:: Int"]) - , ("1::I", ["1::Int"]) - , ("(1::Int) uni", ["(1::Int) unit"]) -- back to completing values + , ("1 :: I", pure ["1 :: Int"]) + , ("1 ::I", pure ["1 ::Int"]) + , ("1:: I", pure ["1:: Int"]) + , ("1::I", pure ["1::Int"]) + , ("(1::Int) uni", pure ["(1::Int) unit"]) -- back to completing values -- Parens and brackets aren't considered part of the current identifier - , ("map id [uni", ["map id [unit"]) - , ("map (cons", ["map (const"]) + , ("map id [uni", pure ["map id [unit"]) + , ("map (cons", pure ["map (const"]) ] -assertCompletedOk :: PSCiState -> (String, [String]) -> Spec -assertCompletedOk psciState (line, expecteds) = specify line $ do +assertCompletedOk :: (String, IO [String]) -> SpecWith PSCiState +assertCompletedOk (line, expectedsM) = specify line $ \psciState -> do + expecteds <- expectedsM results <- runCM psciState (completion' (reverse line, "")) let actuals = formatCompletions results sort actuals `shouldBe` sort expecteds diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index de68de3ca5..352da0af16 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -26,7 +26,7 @@ import qualified Data.Map as M import Data.Maybe (isJust) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Data.Time.Clock (UTCTime()) +import Data.Time.Clock (UTCTime(), diffUTCTime, getCurrentTime, nominalDay) import Data.Tuple (swap) import System.Directory import System.Exit (exitFailure) @@ -53,21 +53,55 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names -- updating. -- updateSupportCode :: IO () -updateSupportCode = do - setCurrentDirectory "tests/support" - callCommand "npm install" - -- bower uses shebang "/usr/bin/env node", but we might have nodejs - node <- maybe cannotFindNode pure =<< findNodeProcess - -- Sometimes we run as a root (e.g. in simple docker containers) - -- And we are non-interactive: https://github.com/bower/bower/issues/1162 - callProcess node ["node_modules/bower/bin/bower", "--allow-root", "install", "--config.interactive=false"] - setCurrentDirectory "../.." +updateSupportCode = withCurrentDirectory "tests/support" $ do + let lastUpdatedFile = ".last_updated" + skipUpdate <- fmap isJust . runMaybeT $ do + -- We skip the update if: `.last_updated` exists, + lastUpdated <- MaybeT $ getModificationTimeMaybe lastUpdatedFile + + -- ... and it was modified less than a day ago (no particular reason why + -- "one day" specifically), + now <- lift $ getCurrentTime + guard $ now `diffUTCTime` lastUpdated < nominalDay + + -- ... and the needed directories exist, + contents <- lift $ listDirectory "." + guard $ "node_modules" `elem` contents && "bower_components" `elem` contents + + -- ... and everything else in `tests/support` is at least as old as + -- `.last_updated`. + modTimes <- lift $ traverse getModificationTime . filter (/= lastUpdatedFile) $ contents + guard $ all (<= lastUpdated) modTimes + + pure () + + unless skipUpdate $ do + heading "Updating support code" + callCommand "npm install" + -- bower uses shebang "/usr/bin/env node", but we might have nodejs + node <- maybe cannotFindNode pure =<< findNodeProcess + -- Sometimes we run as a root (e.g. in simple docker containers) + -- And we are non-interactive: https://github.com/bower/bower/issues/1162 + callProcess node ["node_modules/bower/bin/bower", "--allow-root", "install", "--config.interactive=false"] + writeFile lastUpdatedFile "" where cannotFindNode :: IO a cannotFindNode = do hPutStrLn stderr "Cannot find node (or nodejs) executable" exitFailure + getModificationTimeMaybe :: FilePath -> IO (Maybe UTCTime) + getModificationTimeMaybe f = catch (Just <$> getModificationTime f) $ \case + e | isDoesNotExistError e -> pure Nothing + | otherwise -> throw e + + heading msg = do + putStrLn "" + putStrLn $ replicate 79 '#' + putStrLn $ "# " ++ msg + putStrLn $ replicate 79 '#' + putStrLn "" + readInput :: [FilePath] -> IO [(FilePath, T.Text)] readInput inputFiles = forM inputFiles $ \inputFile -> do text <- readUTF8FileT inputFile @@ -108,7 +142,13 @@ createOutputFile logfileName = do createDirectoryIfMissing False (tmp logpath) openFile (tmp logpath logfileName) WriteMode -setupSupportModules :: IO ([P.Module], [P.ExternsFile], M.Map P.ModuleName FilePath) +data SupportModules = SupportModules + { supportModules :: [P.Module] + , supportExterns :: [P.ExternsFile] + , supportForeigns :: M.Map P.ModuleName FilePath + } + +setupSupportModules :: IO SupportModules setupSupportModules = do ms <- getSupportModuleTuples let modules = map snd ms @@ -118,7 +158,7 @@ setupSupportModules = do return (externs, foreigns) case supportExterns of Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) - Right (externs, foreigns) -> return (modules, externs, foreigns) + Right (externs, foreigns) -> return $ SupportModules modules externs foreigns getTestFiles :: FilePath -> IO [[FilePath]] getTestFiles testDir = do @@ -163,12 +203,10 @@ getTestFiles testDir = do else dir compile - :: [P.Module] - -> [P.ExternsFile] - -> M.Map P.ModuleName FilePath + :: SupportModules -> [FilePath] -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) -compile supportModules supportExterns supportForeigns inputFiles = runTest $ do +compile SupportModules{..} inputFiles = runTest $ do -- Sorting the input files makes some messages (e.g., duplicate module) deterministic fs <- liftIO $ readInput (sort inputFiles) msWithWarnings <- CST.parseFromFiles id fs diff --git a/tests/support/.gitignore b/tests/support/.gitignore index 68b9e27759..fdd2fabfc0 100644 --- a/tests/support/.gitignore +++ b/tests/support/.gitignore @@ -1,2 +1,3 @@ node_modules/ bower_components/ +/.last_updated From d78dc267e77c4f6bbfc59831737d54c0fa0bda32 Mon Sep 17 00:00:00 2001 From: Gleb Popov <6yearold@gmail.com> Date: Mon, 26 Apr 2021 22:39:12 +0300 Subject: [PATCH 1305/1580] Note FreeBSD binary packages in the installation instructions. (#4081) --- INSTALL.md | 1 + 1 file changed, 1 insertion(+) diff --git a/INSTALL.md b/INSTALL.md index c74a88ea6f..5d48107750 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -25,6 +25,7 @@ There are several other distributions of the PureScript compiler available, whic * NPM: `npm install -g purescript` * Homebrew (for macOS): `brew install purescript` +* FreeBSD binary packages: `pkg install hs-purescript` ## Compiling from source From e03fa6e3348f96b7842d6ec589125aa7acd699f4 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Wed, 12 May 2021 22:06:36 +0100 Subject: [PATCH 1306/1580] Unused var tweaks (#4088) * Unused-variable warning for non-recursive bindings. fix #4083 * Tighten spans for unused variable warnings --- CHANGELOG.md | 5 + .../src/Language/PureScript/AST/Binders.hs | 10 +- src/Language/PureScript/Linter.hs | 157 +++++++++--------- tests/purs/warning/UnusedVar.out | 56 +++++-- tests/purs/warning/UnusedVar.purs | 24 ++- tests/purs/warning/UnusedVarDecls.out | 2 +- tests/purs/warning/UnusedVarDo.out | 8 +- tests/purs/warning/UnusedVarDo.purs | 7 +- 8 files changed, 172 insertions(+), 97 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 32247a85c2..b6fe954a9e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,11 @@ New features: Bugfixes: +* Unused identifier warnings now report smaller and more relevant source spans (#4088, @nwolverson) + + Also fix incorrect warnings in cases involving a let-pattern binding shadowing + an existing identifier. + Internal: * Drop libtinfo dependency (#3696, @hdgarrood) diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs b/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs index 01f9d5e129..a4b9c8a79b 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs @@ -132,14 +132,17 @@ instance Ord Binder where -- Collect all names introduced in binders in an expression -- binderNames :: Binder -> [Ident] -binderNames = go [] +binderNames = map snd . binderNamesWithSpans + +binderNamesWithSpans :: Binder -> [(SourceSpan, Ident)] +binderNamesWithSpans = go [] where go ns (LiteralBinder _ b) = lit ns b - go ns (VarBinder _ name) = name : ns + go ns (VarBinder ss name) = (ss, name) : ns go ns (ConstructorBinder _ _ bs) = foldl go ns bs go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3] go ns (ParensInBinder b) = go ns b - go ns (NamedBinder _ name b) = go (name : ns) b + go ns (NamedBinder ss name b) = go ((ss, name) : ns) b go ns (PositionedBinder _ _ b) = go ns b go ns (TypedBinder _ b) = go ns b go ns _ = ns @@ -147,6 +150,7 @@ binderNames = go [] lit ns (ArrayLiteral bs) = foldl go ns bs lit ns _ = ns + isIrrefutable :: Binder -> Bool isIrrefutable NullBinder = True isIrrefutable (VarBinder _ _) = True diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 8b2d54085c..93f5b1b7ed 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -174,11 +174,10 @@ lintUnused (Module modSS _ mn modDecls exports) = where goDecl :: Declaration -> (S.Set Ident, MultipleErrors) - goDecl d@(ValueDeclaration vd) = + goDecl (ValueDeclaration vd) = let allExprs = concatMap unguard $ valdeclExpression vd - bindNewNames = S.fromList (concatMap binderNames $ valdeclBinders vd) - ss = declSourceSpan d - (vars, errs) = removeAndWarn ss bindNewNames $ mconcat $ map (go ss) allExprs + bindNewNames = S.fromList (concatMap binderNamesWithSpans $ valdeclBinders vd) + (vars, errs) = removeAndWarn bindNewNames $ mconcat $ map go allExprs errs' = addHint (ErrorInValueDeclaration $ valdeclIdent vd) errs in (vars, errs') @@ -186,101 +185,105 @@ lintUnused (Module modSS _ mn modDecls exports) = goDecl (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance decls)) = mconcat $ map goDecl decls goDecl _ = mempty - go :: SourceSpan -> Expr -> (S.Set Ident, MultipleErrors) - go _ (Var _ (Qualified Nothing v)) = (S.singleton v, mempty) - go _ (Var _ _) = (S.empty, mempty) - - go ss (Let _ ds e) = - let letNames = S.fromList $ concatMap declIdents ds - in removeAndWarn ss letNames $ mconcat (go ss e : map underDecl ds) - go ss (Abs binder v1) = - let newNames = S.fromList (binderNames binder) + go :: Expr -> (S.Set Ident, MultipleErrors) + go (Var _ (Qualified Nothing v)) = (S.singleton v, mempty) + go (Var _ _) = (S.empty, mempty) + + go (Let _ ds e) = + let (letNames, letNamesRec) = foldMap declIdents ds + in removeAndWarn letNamesRec $ + removeAndWarn letNames (go e) + <> mconcat (map underDecl ds) + go (Abs binder v1) = + let newNames = S.fromList (binderNamesWithSpans binder) in - removeAndWarn ss newNames $ go ss v1 + removeAndWarn newNames $ go v1 - go ss (UnaryMinus _ v1) = go ss v1 - go ss (BinaryNoParens v0 v1 v2) = go ss v0 <> go ss v1 <> go ss v2 - go ss (Parens v1) = go ss v1 - go ss (TypeClassDictionaryConstructorApp _ v1) = go ss v1 - go ss (Accessor _ v1) = go ss v1 + go (UnaryMinus _ v1) = go v1 + go (BinaryNoParens v0 v1 v2) = go v0 <> go v1 <> go v2 + go (Parens v1) = go v1 + go (TypeClassDictionaryConstructorApp _ v1) = go v1 + go (Accessor _ v1) = go v1 - go ss (ObjectUpdate obj vs) = mconcat (go ss obj : map (go ss . snd) vs) - go ss (ObjectUpdateNested obj vs) = go ss obj <> goTree vs + go (ObjectUpdate obj vs) = mconcat (go obj : map (go . snd) vs) + go (ObjectUpdateNested obj vs) = go obj <> goTree vs where goTree (PathTree tree) = mconcat $ map (goNode . snd) (runAssocList tree) - goNode (Leaf val) = go ss val + goNode (Leaf val) = go val goNode (Branch val) = goTree val - go ss (App v1 v2) = go ss v1 <> go ss v2 - go ss (Unused v) = go ss v - go ss (IfThenElse v1 v2 v3) = go ss v1 <> go ss v2 <> go ss v3 - go ss (Case vs alts) = + go (App v1 v2) = go v1 <> go v2 + go (Unused v) = go v + go (IfThenElse v1 v2 v3) = go v1 <> go v2 <> go v3 + go (Case vs alts) = let f (CaseAlternative binders gexprs) = - let bindNewNames = S.fromList (concatMap binderNames binders) + let bindNewNames = S.fromList (concatMap binderNamesWithSpans binders) allExprs = concatMap unguard gexprs in - removeAndWarn ss bindNewNames $ mconcat $ map (go ss) allExprs + removeAndWarn bindNewNames $ mconcat $ map go allExprs in - mconcat $ map (go ss) vs ++ map f alts - - go ss (TypedValue _ v1 _) = go ss v1 - go ss (Do _ es) = doElts ss es Nothing - go ss (Ado _ es v1) = doElts ss es (Just v1) - - go ss (Literal _ (ArrayLiteral es)) = mconcat $ map (go ss) es - go ss (Literal _ (ObjectLiteral oo)) = mconcat $ map (go ss . snd) oo - - go _ (PositionedValue ss' _ v1) = go ss' v1 - - go _ (Literal _ _) = mempty - go _ (Op _ _) = mempty - go _ (Constructor _ _) = mempty - go _ (TypeClassDictionary _ _ _) = mempty - go _ (TypeClassDictionaryAccessor _ _) = mempty - go _ (DeferredDictionary _ _) = mempty - go _ AnonymousArgument = mempty - go _ (Hole _) = mempty - - - doElts :: SourceSpan -> [DoNotationElement] -> Maybe Expr -> (S.Set Ident, MultipleErrors) - doElts ss' (DoNotationValue e : rest) v = go ss' e <> doElts ss' rest v - doElts ss' (DoNotationBind binder e : rest) v = - let bindNewNames = S.fromList (binderNames binder) - in go ss' e <> removeAndWarn ss' bindNewNames (doElts ss' rest v) - - doElts ss' (DoNotationLet ds : rest) v = - let letNewNames = S.fromList $ concatMap declIdents ds - declRes = foldr1 (<>) (map underDecl ds) - in removeAndWarn ss' letNewNames $ declRes <> doElts ss' rest v - doElts _ (PositionedDoNotationElement ss'' _ e : rest) v = doElts ss'' (e : rest) v - doElts ss' [] (Just e) = go ss' e <> (rebindable, mempty) - doElts _ [] Nothing = (rebindable, mempty) - - declIdents :: Declaration -> [Ident] - declIdents (ValueDecl _ ident _ _ _) = [ident] - declIdents (BoundValueDeclaration _ binders _) = binderNames binders - declIdents _ = [] + mconcat $ map go vs ++ map f alts + + go (TypedValue _ v1 _) = go v1 + go (Do _ es) = doElts es Nothing + go (Ado _ es v1) = doElts es (Just v1) + + go (Literal _ (ArrayLiteral es)) = mconcat $ map go es + go (Literal _ (ObjectLiteral oo)) = mconcat $ map (go . snd) oo + + go (PositionedValue _ _ v1) = go v1 + + go (Literal _ _) = mempty + go (Op _ _) = mempty + go (Constructor _ _) = mempty + go (TypeClassDictionary _ _ _) = mempty + go (TypeClassDictionaryAccessor _ _) = mempty + go (DeferredDictionary _ _) = mempty + go AnonymousArgument = mempty + go (Hole _) = mempty + + + doElts :: [DoNotationElement] -> Maybe Expr -> (S.Set Ident, MultipleErrors) + doElts (DoNotationValue e : rest) v = go e <> doElts rest v + doElts (DoNotationBind binder e : rest) v = + let bindNewNames = S.fromList (binderNamesWithSpans binder) + in go e <> removeAndWarn bindNewNames (doElts rest v) + + doElts (DoNotationLet ds : rest) v = + let (letNewNames, letNewNamesRec) = foldMap declIdents ds + in removeAndWarn letNewNamesRec $ + mconcat (map underDecl ds) + <> removeAndWarn letNewNames (doElts rest v) + doElts (PositionedDoNotationElement _ _ e : rest) v = doElts (e : rest) v + doElts [] (Just e) = go e <> (rebindable, mempty) + doElts [] Nothing = (rebindable, mempty) + + -- (non-recursively, recursively) bound idents in decl + declIdents :: Declaration -> (S.Set (SourceSpan, Ident), S.Set (SourceSpan, Ident)) + declIdents (ValueDecl (ss,_) ident _ _ _) = (S.empty, S.singleton (ss, ident)) + declIdents (BoundValueDeclaration _ binders _) = (S.fromList $ binderNamesWithSpans binders, S.empty) + declIdents _ = (S.empty, S.empty) -- let f x = e -- check the x in e (but not the f) - underDecl d@(ValueDecl _ _ _ binders gexprs) = - let bindNewNames = S.fromList (concatMap binderNames binders) + underDecl (ValueDecl _ _ _ binders gexprs) = + let bindNewNames = S.fromList (concatMap binderNamesWithSpans binders) allExprs = concatMap unguard gexprs - ss = declSourceSpan d in - removeAndWarn ss bindNewNames $ foldr1 (<>) $ map (go ss) allExprs + removeAndWarn bindNewNames $ foldr1 (<>) $ map go allExprs -- let {x} = e -- no binding to check inside e - underDecl d@(BoundValueDeclaration _ _ expr) = - go (declSourceSpan d) expr + underDecl (BoundValueDeclaration _ _ expr) = go expr underDecl _ = (mempty, mempty) unguard (GuardedExpr guards expr) = map unguard' guards ++ [expr] unguard' (ConditionGuard ee) = ee unguard' (PatternGuard _ ee) = ee - removeAndWarn :: SourceSpan -> S.Set Ident -> (S.Set Ident, MultipleErrors) -> (S.Set Ident, MultipleErrors) - removeAndWarn ss newNames (used, errors) = - let filteredUsed = used `S.difference` newNames + removeAndWarn :: S.Set (SourceSpan, Ident) -> (S.Set Ident, MultipleErrors) -> (S.Set Ident, MultipleErrors) + removeAndWarn newNamesWithSpans (used, errors) = + let newNames = S.map snd newNamesWithSpans + filteredUsed = used `S.difference` newNames warnUnused = S.filter (not . Text.isPrefixOf "_" . runIdent) (newNames `S.difference` used) - combinedErrors = if not $ S.null warnUnused then errors <> (mconcat $ map (errorMessage' ss . UnusedName) $ S.toList warnUnused) else errors + warnUnusedSpans = S.filter (\(_,ident) -> ident `elem` warnUnused) newNamesWithSpans + combinedErrors = if not $ S.null warnUnusedSpans then errors <> (mconcat $ map (\(ss,ident) -> errorMessage' ss $ UnusedName ident) $ S.toList warnUnusedSpans) else errors in (filteredUsed, combinedErrors) diff --git a/tests/purs/warning/UnusedVar.out b/tests/purs/warning/UnusedVar.out index cf94079605..6c5350e9e8 100644 --- a/tests/purs/warning/UnusedVar.out +++ b/tests/purs/warning/UnusedVar.out @@ -1,7 +1,7 @@ -Warning 1 of 5: +Warning 1 of 8: in module Main - at tests/purs/warning/UnusedVar.purs:12:19 - 12:37 (line 12, column 19 - line 12, column 37) + at tests/purs/warning/UnusedVar.purs:15:20 - 15:32 (line 15, column 20 - line 15, column 32) Name lambdaUnused was introduced but not used. @@ -10,10 +10,10 @@ Warning 1 of 5: See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, or to contribute content related to this warning. -Warning 2 of 5: +Warning 2 of 8: in module Main - at tests/purs/warning/UnusedVar.purs:16:3 - 17:4 (line 16, column 3 - line 17, column 4) + at tests/purs/warning/UnusedVar.purs:19:7 - 19:20 (line 19, column 7 - line 19, column 20) Name letUnused was introduced but not used. @@ -22,10 +22,10 @@ Warning 2 of 5: See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, or to contribute content related to this warning. -Warning 3 of 5: +Warning 3 of 8: in module Main - at tests/purs/warning/UnusedVar.purs:21:3 - 21:4 (line 21, column 3 - line 21, column 4) + at tests/purs/warning/UnusedVar.purs:25:9 - 25:24 (line 25, column 9 - line 25, column 24) Name whereUnused was introduced but not used. @@ -34,10 +34,10 @@ Warning 3 of 5: See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, or to contribute content related to this warning. -Warning 4 of 5: +Warning 4 of 8: in module Main - at tests/purs/warning/UnusedVar.purs:26:7 - 26:27 (line 26, column 7 - line 26, column 27) + at tests/purs/warning/UnusedVar.purs:29:11 - 29:23 (line 29, column 11 - line 29, column 23) Name letArgUnused was introduced but not used. @@ -46,10 +46,10 @@ Warning 4 of 5: See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, or to contribute content related to this warning. -Warning 5 of 5: +Warning 5 of 8: in module Main - at tests/purs/warning/UnusedVar.purs:39:3 - 40:20 (line 39, column 3 - line 40, column 20) + at tests/purs/warning/UnusedVar.purs:43:5 - 43:15 (line 43, column 5 - line 43, column 15) Name caseUnused was introduced but not used. @@ -58,3 +58,39 @@ Warning 5 of 5: See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, or to contribute content related to this warning. +Warning 6 of 8: + + in module Main + at tests/purs/warning/UnusedVar.purs:61:34 - 61:35 (line 61, column 34 - line 61, column 35) + + Name x was introduced but not used. + + in value declaration unusedShadowedByRecursiveBinding + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + +Warning 7 of 8: + + in module Main + at tests/purs/warning/UnusedVar.purs:68:8 - 68:9 (line 68, column 8 - line 68, column 9) + + Name x was introduced but not used. + + in value declaration unusedShadowingLet + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + +Warning 8 of 8: + + in module Main + at tests/purs/warning/UnusedVar.purs:62:7 - 62:16 (line 62, column 7 - line 62, column 16) + + Name x was shadowed. + + in value declaration unusedShadowedByRecursiveBinding + + See https://github.com/purescript/documentation/blob/master/errors/ShadowedName.md for more information, + or to contribute content related to this warning. + diff --git a/tests/purs/warning/UnusedVar.purs b/tests/purs/warning/UnusedVar.purs index cafd56913a..f1e646d0ca 100644 --- a/tests/purs/warning/UnusedVar.purs +++ b/tests/purs/warning/UnusedVar.purs @@ -3,6 +3,9 @@ -- @shouldWarnWith UnusedName -- @shouldWarnWith UnusedName -- @shouldWarnWith UnusedName +-- @shouldWarnWith UnusedName +-- @shouldWarnWith UnusedName +-- @shouldWarnWith ShadowedName module Main where data X = X @@ -44,4 +47,23 @@ unusedObjUpdate = let x = X obj = { foo: X } in - obj { foo = x } \ No newline at end of file + obj { foo = x } + +-- The outer x is used in the let-bound expression, the let-binding variable is used in the body +notUnusedNonRecursiveBinding :: X -> X +notUnusedNonRecursiveBinding x = + let {x} = {x} + in x + +-- Almost like above but the outer x is not used, as x is bound recursively (Can also be true if there are no +-- arguments to x but in most cases this will error due to being cyclic) +unusedShadowedByRecursiveBinding :: X -> X +unusedShadowedByRecursiveBinding x = + let x _ = x X + in x X + +-- In this case the outer x is used but the new x binding is not +unusedShadowingLet :: X -> X +unusedShadowingLet x = + let (x) = x + in X \ No newline at end of file diff --git a/tests/purs/warning/UnusedVarDecls.out b/tests/purs/warning/UnusedVarDecls.out index 4e32eb0b76..58b2f20c78 100644 --- a/tests/purs/warning/UnusedVarDecls.out +++ b/tests/purs/warning/UnusedVarDecls.out @@ -1,7 +1,7 @@ Warning 1 of 2: in module Main - at tests/purs/warning/UnusedVarDecls.purs:13:1 - 13:28 (line 13, column 1 - line 13, column 28) + at tests/purs/warning/UnusedVarDecls.purs:13:15 - 13:24 (line 13, column 15 - line 13, column 24) Name unusedArg was introduced but not used. diff --git a/tests/purs/warning/UnusedVarDo.out b/tests/purs/warning/UnusedVarDo.out index 7eb09e286e..b25475df00 100644 --- a/tests/purs/warning/UnusedVarDo.out +++ b/tests/purs/warning/UnusedVarDo.out @@ -1,7 +1,7 @@ Warning 1 of 4: in module Main - at tests/purs/warning/UnusedVarDo.purs:12:3 - 12:26 (line 12, column 3 - line 12, column 26) + at tests/purs/warning/UnusedVarDo.purs:12:3 - 12:15 (line 12, column 3 - line 12, column 15) Name unusedDoBind was introduced but not used. @@ -13,7 +13,7 @@ Warning 1 of 4: Warning 2 of 4: in module Main - at tests/purs/warning/UnusedVarDo.purs:24:3 - 24:23 (line 24, column 3 - line 24, column 23) + at tests/purs/warning/UnusedVarDo.purs:24:7 - 24:23 (line 24, column 7 - line 24, column 23) Name unusedDoLet was introduced but not used. @@ -25,7 +25,7 @@ Warning 2 of 4: Warning 3 of 4: in module Main - at tests/purs/warning/UnusedVarDo.purs:29:3 - 29:27 (line 29, column 3 - line 29, column 27) + at tests/purs/warning/UnusedVarDo.purs:29:3 - 29:16 (line 29, column 3 - line 29, column 16) Name unusedAdoBind was introduced but not used. @@ -37,7 +37,7 @@ Warning 3 of 4: Warning 4 of 4: in module Main - at tests/purs/warning/UnusedVarDo.purs:34:3 - 34:24 (line 34, column 3 - line 34, column 24) + at tests/purs/warning/UnusedVarDo.purs:34:7 - 34:24 (line 34, column 7 - line 34, column 24) Name unusedAdoLet was introduced but not used. diff --git a/tests/purs/warning/UnusedVarDo.purs b/tests/purs/warning/UnusedVarDo.purs index ebf2525ac9..3f5c4412e2 100644 --- a/tests/purs/warning/UnusedVarDo.purs +++ b/tests/purs/warning/UnusedVarDo.purs @@ -32,4 +32,9 @@ unusedAdoBinding = ado unusedAdoLetBinding :: Maybe Int unusedAdoLetBinding = ado let unusedAdoLet = 42 - in 17 \ No newline at end of file + in 17 + +notUnusedNonRecursiveBinding :: Int -> Maybe Int +notUnusedNonRecursiveBinding x = do + let {x} = {x} + pure x From 2daf461985ca615c6bc725482331c081facf6256 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Mon, 24 May 2021 07:15:20 -0700 Subject: [PATCH 1307/1580] Make instance names optional by generating them based on types (#4085) * Make instance names optional by generating them based on types * Add passing test for instance name generation * Add failing test if '::' part is not included in named instance * Update changelog to describe feature --- CHANGELOG.md | 35 +++++++ lib/purescript-ast/purescript-ast.cabal | 1 + .../Language/PureScript/AST/Declarations.hs | 6 +- .../PureScript/AST/Declarations/ChainId.hs | 20 ++++ .../PureScript/TypeClassDictionaries.hs | 3 +- .../src/Language/PureScript/CST/Convert.hs | 68 ++++++++++++-- .../src/Language/PureScript/CST/Flatten.hs | 11 +-- .../src/Language/PureScript/CST/Parser.y | 10 +- .../src/Language/PureScript/CST/Positions.hs | 2 +- .../src/Language/PureScript/CST/Types.hs | 3 +- purescript.cabal | 1 + .../PureScript/Docs/Convert/Single.hs | 2 +- src/Language/PureScript/Externs.hs | 3 +- src/Language/PureScript/Sugar.hs | 4 + src/Language/PureScript/Sugar/TypeClasses.hs | 5 +- .../PureScript/Sugar/TypeClasses/Instances.hs | 40 ++++++++ src/Language/PureScript/TypeChecker.hs | 12 ++- .../PureScript/TypeChecker/Entailment.hs | 26 +++--- tests/Language/PureScript/Ide/StateSpec.hs | 2 +- .../failing/InstanceNamedWithoutSeparator.out | 10 ++ .../InstanceNamedWithoutSeparator.purs | 12 +++ .../purs/passing/InstanceNamesGenerated.purs | 92 +++++++++++++++++++ .../InstanceUnnamedSimilarClassName.purs | 16 ++++ .../ImportedClassName.purs | 4 + 24 files changed, 341 insertions(+), 47 deletions(-) create mode 100644 lib/purescript-ast/src/Language/PureScript/AST/Declarations/ChainId.hs create mode 100644 src/Language/PureScript/Sugar/TypeClasses/Instances.hs create mode 100644 tests/purs/failing/InstanceNamedWithoutSeparator.out create mode 100644 tests/purs/failing/InstanceNamedWithoutSeparator.purs create mode 100644 tests/purs/passing/InstanceNamesGenerated.purs create mode 100644 tests/purs/passing/InstanceUnnamedSimilarClassName.purs create mode 100644 tests/purs/passing/InstanceUnnamedSimilarClassName/ImportedClassName.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index b6fe954a9e..d980d4c7b2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,41 @@ Breaking changes: New features: +* Make type class instance names optional (#4085, @JordanMartinez) + + Previously, one would be required to define a unique name for a type class + instance. For example + + ```purescript + -- instance naming convention: + -- classNameType1Type2Type3 + instance fooIntString :: Foo Int String + ``` + + Now, the name and `::` separator characters are optional. The above instance + could be rewritten like so: + + ```purescript + instance Foo Int String + ``` + + and the compiler will generate a unique name for the instance + (e.g. `$dollar_FooIntString_4` where `4` is a randomly-generated number + that can change across compiler runs). This version of the instance name + is not intended for use in FFI. + + Note: if one wrote + + ```purescript + instance ReallyLongClassName Int String + ``` + + the generated name would be something like + `$dollar_ReallyLongClassNameIntStr_87` rather than + `$dollar_ReallyLongClassNameIntString_87` as the generated part + of the name will be truncated to 25 characters (long enough to be readable + without being too verbose). + Bugfixes: * Unused identifier warnings now report smaller and more relevant source spans (#4088, @nwolverson) diff --git a/lib/purescript-ast/purescript-ast.cabal b/lib/purescript-ast/purescript-ast.cabal index 11e0628e43..86f69053bb 100644 --- a/lib/purescript-ast/purescript-ast.cabal +++ b/lib/purescript-ast/purescript-ast.cabal @@ -78,6 +78,7 @@ library Language.PureScript.AST Language.PureScript.AST.Binders Language.PureScript.AST.Declarations + Language.PureScript.AST.Declarations.ChainId Language.PureScript.AST.Exported Language.PureScript.AST.Literals Language.PureScript.AST.Operators diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs index b7335b5247..e2ed1e2bd8 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs @@ -7,6 +7,7 @@ module Language.PureScript.AST.Declarations where import Prelude.Compat +import Protolude.Exceptions (hush) import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) @@ -22,6 +23,7 @@ import Language.PureScript.AST.Binders import Language.PureScript.AST.Literals import Language.PureScript.AST.Operators import Language.PureScript.AST.SourcePos +import Language.PureScript.AST.Declarations.ChainId (ChainId) import Language.PureScript.Types import Language.PureScript.PSString (PSString) import Language.PureScript.Label (Label) @@ -429,7 +431,7 @@ data Declaration -- A type instance declaration (instance chain, chain index, name, -- dependencies, class name, instance types, member declarations) -- - | TypeInstanceDeclaration SourceAnn [Ident] Integer Ident [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody + | TypeInstanceDeclaration SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody deriving (Show) data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName) @@ -502,7 +504,7 @@ declName (ExternDataDeclaration _ n _) = Just (TyName n) declName (FixityDeclaration _ (Left (ValueFixity _ _ n))) = Just (ValOpName n) declName (FixityDeclaration _ (Right (TypeFixity _ _ n))) = Just (TyOpName n) declName (TypeClassDeclaration _ n _ _ _ _) = Just (TyClassName n) -declName (TypeInstanceDeclaration _ _ _ n _ _ _ _) = Just (IdentName n) +declName (TypeInstanceDeclaration _ _ _ n _ _ _ _) = IdentName <$> hush n declName ImportDeclaration{} = Nothing declName BindingGroupDeclaration{} = Nothing declName DataBindingGroupDeclaration{} = Nothing diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations/ChainId.hs b/lib/purescript-ast/src/Language/PureScript/AST/Declarations/ChainId.hs new file mode 100644 index 0000000000..a5b47f6d37 --- /dev/null +++ b/lib/purescript-ast/src/Language/PureScript/AST/Declarations/ChainId.hs @@ -0,0 +1,20 @@ +module Language.PureScript.AST.Declarations.ChainId + ( ChainId + , mkChainId + ) where + +import Prelude +import qualified Language.PureScript.AST.SourcePos as Pos +import Control.DeepSeq (NFData) +import Codec.Serialise (Serialise) + +-- | +-- For a given instance chain, stores the chain's file name and +-- the starting source pos of the first instance in the chain. +-- This data is used to determine which instances are part of +-- the same instance chain. +newtype ChainId = ChainId (String, Pos.SourcePos) + deriving (Eq, Ord, Show, NFData, Serialise) + +mkChainId :: String -> Pos.SourcePos -> ChainId +mkChainId fileName startingSourcePos = ChainId (fileName, startingSourcePos) diff --git a/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs b/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs index deb3915f05..d951723a15 100644 --- a/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs +++ b/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs @@ -6,6 +6,7 @@ import GHC.Generics (Generic) import Control.DeepSeq (NFData) import Data.Text (Text, pack) +import Language.PureScript.AST.Declarations.ChainId (ChainId) import Language.PureScript.Names import Language.PureScript.Types @@ -15,7 +16,7 @@ import Language.PureScript.Types data TypeClassDictionaryInScope v = TypeClassDictionaryInScope { -- | The instance chain - tcdChain :: [Qualified Ident] + tcdChain :: Maybe ChainId -- | Index of the instance chain , tcdIndex :: Integer -- | The value with which the dictionary can be accessed at runtime diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs index b8b57944bf..3c2202225f 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs @@ -15,7 +15,7 @@ module Language.PureScript.CST.Convert , comments ) where -import Prelude +import Prelude hiding (take) import Data.Bifunctor (bimap, first) import Data.Foldable (foldl', toList) @@ -24,13 +24,14 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust, fromJust, mapMaybe) import qualified Data.Text as Text import qualified Language.PureScript.AST as AST +import Language.PureScript.AST.Declarations.ChainId (mkChainId) import qualified Language.PureScript.AST.SourcePos as Pos import qualified Language.PureScript.Comments as C import Language.PureScript.Crash (internalError) import qualified Language.PureScript.Environment as Env import qualified Language.PureScript.Label as L import qualified Language.PureScript.Names as N -import Language.PureScript.PSString (mkString) +import Language.PureScript.PSString (mkString, prettyPrintStringJS) import qualified Language.PureScript.Types as T import Language.PureScript.CST.Positions import Language.PureScript.CST.Print (printToken) @@ -468,24 +469,24 @@ convertDeclaration fileName decl = case decl of (goSig <$> maybe [] (NE.toList . snd) bd) DeclInstanceChain _ insts -> do let - instName (Instance (InstanceHead _ a _ _ _ _) _) = ident $ nameValue a - chainId = instName <$> toList insts - goInst ix inst@(Instance (InstanceHead _ name _ ctrs cls args) bd) = do + chainId = mkChainId fileName $ startSourcePos $ instKeyword $ instHead $ sepHead insts + goInst ix inst@(Instance (InstanceHead _ nameSep ctrs cls args) bd) = do let ann' = uncurry (sourceAnnCommented fileName) $ instanceRange inst AST.TypeInstanceDeclaration ann' chainId ix - (ident $ nameValue name) + (mkPartialInstanceName nameSep cls args) (convertConstraint fileName <$> maybe [] (toList . fst) ctrs) (qualified cls) (convertType fileName <$> args) (AST.ExplicitInstance $ goInstanceBinding <$> maybe [] (NE.toList . snd) bd) uncurry goInst <$> zip [0..] (toList insts) - DeclDerive _ _ new (InstanceHead _ name _ ctrs cls args) -> do + DeclDerive _ _ new (InstanceHead kw nameSep ctrs cls args) -> do let - name' = ident $ nameValue name + chainId = mkChainId fileName $ startSourcePos kw + name' = mkPartialInstanceName nameSep cls args instTy | isJust new = AST.NewtypeInstance | otherwise = AST.DerivedInstance - pure $ AST.TypeInstanceDeclaration ann [name'] 0 name' + pure $ AST.TypeInstanceDeclaration ann chainId 0 name' (convertConstraint fileName <$> maybe [] (toList . fst) ctrs) (qualified cls) (convertType fileName <$> args) @@ -530,6 +531,55 @@ convertDeclaration fileName decl = case decl of ann = uncurry (sourceAnnCommented fileName) $ declRange decl + startSourcePos :: SourceToken -> Pos.SourcePos + startSourcePos = sourcePos . srcStart . tokRange . tokAnn + + mkPartialInstanceName :: Maybe (Name Ident, SourceToken) -> QualifiedName (N.ProperName 'N.ClassName) -> [Type a] -> Either Text.Text N.Ident + mkPartialInstanceName nameSep cls args = + maybe (Left genName) (Right . ident . nameValue . fst) nameSep + where + -- truncate to 25 chars to reduce verbosity + -- of name and still keep it readable + -- unique identifier will be appended to this name + -- in desugaring proces + genName :: Text.Text + genName = "$_" <> Text.take 25 (className <> typeArgs) <> "_" + + className :: Text.Text + className = N.runProperName $ qualName cls + + typeArgs :: Text.Text + typeArgs = foldMap argName args + + argName :: Type a -> Text.Text + argName = \case + -- These are only useful to disambiguate between overlapping instances + -- but they’re disallowed outside of instance chains. Since we’re + -- avoiding name collisions with unique identifiers anyway, + -- we don't need to render this constructor. + TypeVar{} -> "" + TypeConstructor _ qn -> N.runProperName $ qualName qn + TypeOpName _ qn -> N.runOpName $ qualName qn + TypeString _ _ ps -> prettyPrintStringJS ps + + -- Typed holes are disallowed in instance heads + TypeHole{} -> "" + TypeParens _ t -> argName $ wrpValue t + TypeKinded _ t1 _ t2 -> argName t1 <> argName t2 + TypeRecord _ _ -> "Record" + TypeRow _ _ -> "Row" + TypeArrName _ _ -> "Function" + TypeWildcard{} -> "_" + + -- Polytypes are disallowed in instance heads + TypeForall{} -> "" + TypeApp _ t1 t2 -> argName t1 <> argName t2 + TypeOp _ t1 op t2 -> + argName t1 <> (N.runOpName $ qualName op) <> argName t2 + TypeArr _ t1 _ t2 -> argName t1 <> "Function" <> argName t2 + TypeConstrained{} -> "" + TypeUnaryRow{} -> "Row" + goTypeVar = \case TypeVarKinded (Wrapped _ (Labeled x _ y) _) -> (getIdent $ nameValue x, Just $ convertType fileName y) TypeVarName x -> (getIdent $ nameValue x, Nothing) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs b/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs index 88cfed2851..8d90614fb3 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs @@ -46,13 +46,12 @@ flattenInstance (Instance a b) = flattenInstanceHead a <> foldMap (\(c, d) -> pure c <> foldMap flattenInstanceBinding d) b flattenInstanceHead :: InstanceHead a -> DList SourceToken -flattenInstanceHead (InstanceHead a b c d e f) = +flattenInstanceHead (InstanceHead a b c d e) = pure a <> - flattenName b <> - pure c <> - foldMap (\(g, h) -> flattenOneOrDelimited flattenConstraint g <> pure h) d <> - flattenQualifiedName e <> - foldMap flattenType f + foldMap (\(n, s) -> flattenName n <> pure s) b <> + foldMap (\(g, h) -> flattenOneOrDelimited flattenConstraint g <> pure h) c <> + flattenQualifiedName d <> + foldMap flattenType e flattenInstanceBinding :: InstanceBinding a -> DList SourceToken flattenInstanceBinding = \case diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y index bc237b84e7..cbc6ba4056 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y +++ b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y @@ -736,10 +736,14 @@ classMember :: { Labeled (Name Ident) (Type ()) } : ident '::' type {% checkNoWildcards $3 *> pure (Labeled $1 $2 $3) } instHead :: { InstanceHead () } - : 'instance' ident '::' constraints '=>' qualProperName manyOrEmpty(typeAtom) - { InstanceHead $1 $2 $3 (Just ($4, $5)) (getQualifiedProperName $6) $7 } + : 'instance' constraints '=>' qualProperName manyOrEmpty(typeAtom) + { InstanceHead $1 Nothing (Just ($2, $3)) (getQualifiedProperName $4) $5 } + | 'instance' qualProperName manyOrEmpty(typeAtom) + { InstanceHead $1 Nothing Nothing (getQualifiedProperName $2) $3 } + | 'instance' ident '::' constraints '=>' qualProperName manyOrEmpty(typeAtom) + { InstanceHead $1 (Just ($2, $3)) (Just ($4, $5)) (getQualifiedProperName $6) $7 } | 'instance' ident '::' qualProperName manyOrEmpty(typeAtom) - { InstanceHead $1 $2 $3 Nothing (getQualifiedProperName $4) $5 } + { InstanceHead $1 (Just ($2, $3)) Nothing (getQualifiedProperName $4) $5 } constraints :: { OneOrDelimited (Constraint ()) } : constraint { One $1 } diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs index 0d49fc7624..e5a1abe1cd 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs @@ -211,7 +211,7 @@ instanceRange (Instance hd bd) where start = instanceHeadRange hd instanceHeadRange :: InstanceHead a -> TokenRange -instanceHeadRange (InstanceHead kw _ _ _ cls types) +instanceHeadRange (InstanceHead kw _ _ cls types) | [] <- types = (kw, qualTok cls) | otherwise = (kw, snd . typeRange $ last types) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Types.hs b/lib/purescript-cst/src/Language/PureScript/CST/Types.hs index c35c3e9d07..7f5844cca9 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Types.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Types.hs @@ -261,8 +261,7 @@ data ClassFundep data InstanceHead a = InstanceHead { instKeyword :: SourceToken - , instName :: Name Ident - , instSep :: SourceToken + , instNameSep :: Maybe (Name Ident, SourceToken) , instConstraints :: Maybe (OneOrDelimited (Constraint a), SourceToken) , instClass :: QualifiedName (N.ProperName 'N.ClassName) , instTypes :: [Type a] diff --git a/purescript.cabal b/purescript.cabal index e465c780c8..a746132352 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -303,6 +303,7 @@ library Language.PureScript.Sugar.Operators.Types Language.PureScript.Sugar.TypeClasses Language.PureScript.Sugar.TypeClasses.Deriving + Language.PureScript.Sugar.TypeClasses.Instances Language.PureScript.Sugar.TypeDeclarations Language.PureScript.TypeChecker Language.PureScript.TypeChecker.Entailment diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 3ea9480956..3199d669d5 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -94,7 +94,7 @@ getDeclarationTitle (P.DataDeclaration _ _ name _ _) = Just (P.runProperName nam getDeclarationTitle (P.ExternDataDeclaration _ name _) = Just (P.runProperName name) getDeclarationTitle (P.TypeSynonymDeclaration _ name _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeClassDeclaration _ name _ _ _ _) = Just (P.runProperName name) -getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ name _ _ _ _) = Just (P.showIdent name) +getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ name _ _ _ _) = P.showIdent <$> hush name getDeclarationTitle (P.TypeFixityDeclaration _ _ _ op) = Just ("type " <> P.showOp op) getDeclarationTitle (P.ValueFixityDeclaration _ _ _ op) = Just (P.showOp op) getDeclarationTitle _ = Nothing diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 3f100ac68c..2a92064f35 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -30,6 +30,7 @@ import qualified Data.Map as M import qualified Data.List.NonEmpty as NEL import Language.PureScript.AST +import Language.PureScript.AST.Declarations.ChainId (ChainId) import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Names @@ -150,7 +151,7 @@ data ExternsDeclaration = , edInstanceKinds :: [SourceType] , edInstanceTypes :: [SourceType] , edInstanceConstraints :: Maybe [SourceConstraint] - , edInstanceChain :: [Qualified Ident] + , edInstanceChain :: Maybe ChainId , edInstanceChainIndex :: Integer } deriving (Show, Generic) diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 8a41fa7481..c6a3c9f912 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -30,6 +30,7 @@ import Language.PureScript.Sugar.ObjectWildcards as S import Language.PureScript.Sugar.Operators as S import Language.PureScript.Sugar.TypeClasses as S import Language.PureScript.Sugar.TypeClasses.Deriving as S +import Language.PureScript.Sugar.TypeClasses.Instances as S import Language.PureScript.Sugar.TypeDeclarations as S import Language.PureScript.TypeChecker.Synonyms (SynonymMap) @@ -48,6 +49,8 @@ import Language.PureScript.TypeChecker.Synonyms (SynonymMap) -- -- * Desugar top-level case declarations into explicit case expressions -- +-- * Generate type class instance names for those not defined in source code +-- -- * Desugar type declarations into value declarations with explicit type annotations -- -- * Qualify any unqualified names and types @@ -85,6 +88,7 @@ desugar externs = -- knowing their kinds but they're not available yet. kinds = mempty in deriveInstances externs syns kinds m + >>= desugarTypeClassInstanceNames >>= desugarTypeClasses externs syns kinds) >=> createBindingGroupsModule diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index ea7047491a..c647b67fdf 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -214,14 +214,15 @@ desugarDecl syns kinds mn exps = go modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False)) return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) go (TypeInstanceDeclaration _ _ _ _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" - go d@(TypeInstanceDeclaration sa _ _ name deps className tys (ExplicitInstance members)) + go (TypeInstanceDeclaration _ _ _ (Left _) _ _ _ _) = internalError "instance names should have been desugared" + go d@(TypeInstanceDeclaration sa _ _ (Right name) deps className tys (ExplicitInstance members)) | className == C.Coercible = throwError . errorMessage' (fst sa) $ InvalidCoercibleInstanceDeclaration tys | otherwise = do desugared <- desugarCases members dictDecl <- typeInstanceDictionaryDeclaration syns kinds sa name mn deps className tys desugared return (expRef name className tys, [d, dictDecl]) - go d@(TypeInstanceDeclaration sa _ _ name deps className tys (NewtypeInstanceWithDictionary dict)) = do + go d@(TypeInstanceDeclaration sa _ _ (Right name) deps className tys (NewtypeInstanceWithDictionary dict)) = do let dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictSynonymName) className)) tys constrainedTy = quantify (foldr (srcConstrainedType) dictTy deps) return (expRef name className tys, [d, ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Instances.hs b/src/Language/PureScript/Sugar/TypeClasses/Instances.hs new file mode 100644 index 0000000000..081d7c9314 --- /dev/null +++ b/src/Language/PureScript/Sugar/TypeClasses/Instances.hs @@ -0,0 +1,40 @@ +-- | +-- This module implements the desugaring pass which creates the compiler-generated +-- names for type class instances that do not have one defined in the source code. +-- +module Language.PureScript.Sugar.TypeClasses.Instances + ( desugarTypeClassInstanceNames + ) where + +import Prelude.Compat hiding (take) + +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class +import Data.Text (pack) +import Language.PureScript.Errors +import Language.PureScript.Names + +-- | +-- Completes the name generation for type class instances that do not have +-- a unique name defined in source code. All `Left Text` values +-- will be converted to `Right Ident` values. +-- +desugarTypeClassInstanceNames + :: (MonadSupply m, MonadError MultipleErrors m) + => Module + -> m Module +desugarTypeClassInstanceNames (Module ss coms name decls exps) = do + desugaredDecl <- parU decls desugarInstName + pure $ Module ss coms name desugaredDecl exps + + where + desugarInstName + :: (MonadSupply m, MonadError MultipleErrors m) + => Declaration + -> m Declaration + desugarInstName = \case + TypeInstanceDeclaration sa chainId idx (Left genText) deps className tys bd -> do + uniqueIdent <- fresh + let finalName = Ident $ genText <> (pack $ show uniqueIdent) + pure $ TypeInstanceDeclaration sa chainId idx (Right finalName) deps className tys bd + a -> pure a diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index ff873b7f4f..13348b7841 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -29,6 +29,7 @@ import qualified Data.Set as S import qualified Data.Text as T import Language.PureScript.AST +import Language.PureScript.AST.Declarations.ChainId (ChainId) import qualified Language.PureScript.Constants.Data.Generic.Rep as DataGenericRep import qualified Language.PureScript.Constants.Data.Newtype as DataNewtype import Language.PureScript.Crash @@ -400,7 +401,8 @@ typeCheckAll moduleName _ = traverse go (args', implies', tys', kind) <- kindOfClass moduleName (sa, pn, args, implies, tys) addTypeClass moduleName qualifiedClassName (fmap Just <$> args') implies' deps tys' kind return d - go (d@(TypeInstanceDeclaration sa@(ss, _) ch idx dictName deps className tys body)) = + go (TypeInstanceDeclaration _ _ _ (Left _) _ _ _ _) = internalError "typeCheckAll: type class instance generated name should have been desugared" + go (d@(TypeInstanceDeclaration sa@(ss, _) ch idx (Right dictName) deps className tys body)) = rethrow (addHint (ErrorInInstance className tys) . addHint (positionedError ss)) $ do env <- getEnv let qualifiedDictName = Qualified (Just moduleName) dictName @@ -416,11 +418,11 @@ typeCheckAll moduleName _ = traverse go sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys'') let nonOrphanModules = findNonOrphanModules className typeClass tys'' checkOrphanInstance dictName className tys'' nonOrphanModules - let qualifiedChain = Qualified (Just moduleName) <$> ch - checkOverlappingInstance qualifiedChain dictName className typeClass tys'' nonOrphanModules + let chainId = Just ch + checkOverlappingInstance chainId dictName className typeClass tys'' nonOrphanModules _ <- traverseTypeInstanceBody checkInstanceMembers body deps'' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps' - let dict = TypeClassDictionaryInScope qualifiedChain idx qualifiedDictName [] className vars kinds' tys'' (Just deps'') + let dict = TypeClassDictionaryInScope chainId idx qualifiedDictName [] className vars kinds' tys'' (Just deps'') addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict) return d @@ -491,7 +493,7 @@ typeCheckAll moduleName _ = traverse go -- flexible instances: the instances `Cls X y` and `Cls x Y` overlap and -- could live in different modules but won't be caught here. checkOverlappingInstance - :: [Qualified Ident] + :: Maybe ChainId -> Ident -> Qualified (ProperName 'ClassName) -> TypeClassData diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index fd1481e510..72d9455529 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -176,7 +176,7 @@ entails SolverOptions{..} constraint context hints = forClassName _ ctx cn@C.Warn _ [msg] = -- Prefer a warning dictionary in scope if there is one available. -- This allows us to defer a warning by propagating the constraint. - findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope [] 0 (WarnInstance msg) [] C.Warn [] [] [msg] Nothing] + findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope Nothing 0 (WarnInstance msg) [] C.Warn [] [] [msg] Nothing] forClassName _ _ C.IsSymbol _ args | Just dicts <- solveIsSymbol args = dicts forClassName _ _ C.SymbolCompare _ args | Just dicts <- solveSymbolCompare args = dicts forClassName _ _ C.SymbolAppend _ args | Just dicts <- solveSymbolAppend args = dicts @@ -409,13 +409,13 @@ entails SolverOptions{..} constraint context hints = -- We may have collected hints for the solving failure along the way, in -- which case we decorate the error with the first one. maybe id addHint (listToMaybe hints') `rethrow` case inertWanteds of - [] -> pure $ Just [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] Nothing] + [] -> pure $ Just [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] Nothing] (k, a', b') : _ | a' == b && b' == a -> throwError $ insoluble k b' a' (k, a', b') : _ -> throwError $ insoluble k a' b' solveCoercible _ _ _ _ = pure Nothing solveIsSymbol :: [SourceType] -> Maybe [TypeClassDict] - solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope [] 0 (IsSymbolInstance sym) [] C.IsSymbol [] [] [TypeLevelString ann sym] Nothing] + solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope Nothing 0 (IsSymbolInstance sym) [] C.IsSymbol [] [] [TypeLevelString ann sym] Nothing] solveIsSymbol _ = Nothing solveSymbolCompare :: [SourceType] -> Maybe [TypeClassDict] @@ -425,14 +425,14 @@ entails SolverOptions{..} constraint context hints = EQ -> C.orderingEQ GT -> C.orderingGT args' = [arg0, arg1, srcTypeConstructor ordering] - in Just [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolCompare [] [] args' Nothing] + in Just [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolCompare [] [] args' Nothing] solveSymbolCompare _ = Nothing solveSymbolAppend :: [SourceType] -> Maybe [TypeClassDict] solveSymbolAppend [arg0, arg1, arg2] = do (arg0', arg1', arg2') <- appendSymbols arg0 arg1 arg2 let args' = [arg0', arg1', arg2'] - pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolAppend [] [] args' Nothing] + pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolAppend [] [] args' Nothing] solveSymbolAppend _ = Nothing -- | Append type level symbols, or, run backwards, strip a prefix or suffix @@ -454,7 +454,7 @@ entails SolverOptions{..} constraint context hints = solveSymbolCons [arg0, arg1, arg2] = do (arg0', arg1', arg2') <- consSymbol arg0 arg1 arg2 let args' = [arg0', arg1', arg2'] - pure [TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.SymbolCons [] [] args' Nothing] + pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolCons [] [] args' Nothing] solveSymbolCons _ = Nothing consSymbol :: SourceType -> SourceType -> SourceType -> Maybe (SourceType, SourceType, SourceType) @@ -472,7 +472,7 @@ entails SolverOptions{..} constraint context hints = solveUnion :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] solveUnion kinds [l, r, u] = do (lOut, rOut, uOut, cst, vars) <- unionRows kinds l r u - pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowUnion vars kinds [lOut, rOut, uOut] cst ] + pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowUnion vars kinds [lOut, rOut, uOut] cst ] solveUnion _ _ = Nothing -- | Left biased union of two row types @@ -503,13 +503,13 @@ entails SolverOptions{..} constraint context hints = solveRowCons :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] solveRowCons kinds [TypeLevelString ann sym, ty, r, _] = - Just [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowCons [] kinds [TypeLevelString ann sym, ty, r, srcRCons (Label sym) ty r] Nothing ] + Just [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowCons [] kinds [TypeLevelString ann sym, ty, r, srcRCons (Label sym) ty r] Nothing ] solveRowCons _ _ = Nothing solveRowToList :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] solveRowToList [kind] [r, _] = do entries <- rowToRowList kind r - pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowToList [] [kind] [r, entries] Nothing ] + pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowToList [] [kind] [r, entries] Nothing ] solveRowToList _ _ = Nothing -- | Convert a closed row to a sorted list of entries @@ -528,7 +528,7 @@ entails SolverOptions{..} constraint context hints = solveNub :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] solveNub kinds [r, _] = do r' <- nubRows r - pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowNub [] kinds [r, r'] Nothing ] + pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowNub [] kinds [r, r'] Nothing ] solveNub _ _ = Nothing nubRows :: SourceType -> Maybe SourceType @@ -540,10 +540,10 @@ entails SolverOptions{..} constraint context hints = solveLacks :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] solveLacks kinds tys@[_, REmptyKinded _ _] = - pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowLacks [] kinds tys Nothing ] + pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowLacks [] kinds tys Nothing ] solveLacks kinds [TypeLevelString ann sym, r] = do (r', cst) <- rowLacks kinds sym r - pure [ TypeClassDictionaryInScope [] 0 EmptyClassInstance [] C.RowLacks [] kinds [TypeLevelString ann sym, r'] cst ] + pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowLacks [] kinds [TypeLevelString ann sym, r'] cst ] solveLacks _ _ = Nothing rowLacks :: [SourceType] -> PSString -> SourceType -> Maybe (SourceType, Maybe [SourceConstraint]) @@ -700,7 +700,7 @@ newDictionaries path name (Constraint _ className instanceKinds instanceTy _) = (replaceAllTypeVars sub <$> supArgs) Nothing) ) typeClassSuperclasses [0..] - return (TypeClassDictionaryInScope [] 0 name path className [] instanceKinds instanceTy Nothing : supDicts) + return (TypeClassDictionaryInScope Nothing 0 name path className [] instanceKinds instanceTy Nothing : supDicts) mkContext :: [NamedDict] -> InstanceContext mkContext = foldr combineContexts M.empty . map fromDict where diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index a5465e4881..fe0b9caf32 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -67,7 +67,7 @@ ef = P.ExternsFile -- , edInstanceConstraints = mempty -- , edInstanceChain = - mempty + Nothing -- , edInstanceChainIndex = 0 -- } diff --git a/tests/purs/failing/InstanceNamedWithoutSeparator.out b/tests/purs/failing/InstanceNamedWithoutSeparator.out new file mode 100644 index 0000000000..2cc0ea01ca --- /dev/null +++ b/tests/purs/failing/InstanceNamedWithoutSeparator.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/InstanceNamedWithoutSeparator.purs:9:23 - 9:26 (line 9, column 23 - line 9, column 26) + + Unable to parse module: + Unexpected token 'Foo' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/InstanceNamedWithoutSeparator.purs b/tests/purs/failing/InstanceNamedWithoutSeparator.purs new file mode 100644 index 0000000000..3d9689ebe5 --- /dev/null +++ b/tests/purs/failing/InstanceNamedWithoutSeparator.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +import Effect.Console (log) + +class Foo a +-- the "::" separator between the name and class name +-- needs to be added. +instance instanceName Foo x +-- else instance Foo x + +main = log "Done" diff --git a/tests/purs/passing/InstanceNamesGenerated.purs b/tests/purs/passing/InstanceNamesGenerated.purs new file mode 100644 index 0000000000..a78cb99269 --- /dev/null +++ b/tests/purs/passing/InstanceNamesGenerated.purs @@ -0,0 +1,92 @@ +module Main where + +import Effect.Console (log) +import Data.Generic.Rep (class Generic) + +-- This file verifies that unnamed instances will produce +-- completely-generated instance names without problems. + +class NoTypeParams +instance NoTypeParams + + +class OneTypeParam a +instance OneTypeParam Boolean + + +class OneTypeParamChain a +instance OneTypeParamChain Boolean +else instance OneTypeParamChain String + + +class MultipleTypeParams :: Type -> Type -> Type -> Type -> Type -> Constraint +class MultipleTypeParams a b c d e + +instance MultipleTypeParams Boolean Int Number Char String + + +class MultipleTypeParamsChain :: Type -> Type -> Type -> Type -> Type -> Constraint +class MultipleTypeParamsChain a b c d e + +instance MultipleTypeParamsChain Boolean Int Number Char Boolean +else instance MultipleTypeParamsChain Boolean Int Number Char Int +else instance MultipleTypeParamsChain Boolean Int Number Char Number +else instance MultipleTypeParamsChain Boolean Int Number Char Char +else instance MultipleTypeParamsChain Boolean Int Number Char String + + +class HigherKindedTypeParams :: (Type -> Type) -> (Type -> Type) -> Constraint +class HigherKindedTypeParams f g where + hktp :: f Int -> g Int -> Int + +instance HigherKindedTypeParams Array (Either Int) where + hktp _ _ = 0 + + +class HigherKindedTypeParamsChain :: (Type -> Type) -> (Type -> Type) -> Constraint +class HigherKindedTypeParamsChain f g where + hktpChain :: f Int -> g Int -> Int + +instance HigherKindedTypeParamsChain Array (Either Int) where + hktpChain _ _ = 0 +else instance HigherKindedTypeParamsChain (Either Int) Array where + hktpChain _ _ = 0 + + +data CustomKind +foreign import data Constructor1 :: CustomKind +foreign import data Constructor2 :: CustomKind +foreign import data Constructor3 :: CustomKind + +class MultipleKindParams :: CustomKind -> Constraint +class MultipleKindParams customKind + +instance MultipleKindParams Constructor1 + + +class MultipleKindParamsChain :: CustomKind -> Constraint +class MultipleKindParamsChain customKind + +instance MultipleKindParamsChain Constructor1 +else instance MultipleKindParamsChain Constructor2 +else instance MultipleKindParamsChain Constructor3 + + +data Arrow a b = Foo a b +class ReservedWord a +instance ReservedWord (Arrow a b) +instance ReservedWord ((->) a b) + + +data GenericFoo = GenericFoo +derive instance Generic GenericFoo _ + + +class OverlappingStillCompiles a +instance OverlappingStillCompiles x +else instance OverlappingStillCompiles x + + +main = log "Done" + +data Either l r = Left l | Right r diff --git a/tests/purs/passing/InstanceUnnamedSimilarClassName.purs b/tests/purs/passing/InstanceUnnamedSimilarClassName.purs new file mode 100644 index 0000000000..5fb4193152 --- /dev/null +++ b/tests/purs/passing/InstanceUnnamedSimilarClassName.purs @@ -0,0 +1,16 @@ +module Main where + +import Effect.Console (log) +import ImportedClassName as I + +data Foo = Foo + +class ClassName a where + foo :: a -> Int + +instance ClassName Foo where + foo _ = 0 +instance I.ClassName Foo where + foo _ = 0 + +main = log "Done" diff --git a/tests/purs/passing/InstanceUnnamedSimilarClassName/ImportedClassName.purs b/tests/purs/passing/InstanceUnnamedSimilarClassName/ImportedClassName.purs new file mode 100644 index 0000000000..c966693350 --- /dev/null +++ b/tests/purs/passing/InstanceUnnamedSimilarClassName/ImportedClassName.purs @@ -0,0 +1,4 @@ +module ImportedClassName where + +class ClassName a where + foo :: a -> Int From 74c7670746b7613fc896390229576edb239f35af Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:32 -0400 Subject: [PATCH 1308/1580] Remove unneeded HLint ignore directives --- .hlint.yaml | 2 -- 1 file changed, 2 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index c41d339669..aa05b2b4c1 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -40,7 +40,6 @@ - ignore: {name: "Use Just"} - ignore: {name: "Use /="} - ignore: {name: "Reduce duplication"} -- ignore: {name: "Use fewer imports"} - ignore: {name: "Use camelCase"} - ignore: {name: "Use ++"} - ignore: {name: "Hoist not"} @@ -55,7 +54,6 @@ - ignore: {name: "Use unwords"} - ignore: {name: "Use fmap"} - ignore: {name: "Avoid lambda using `infix`"} -- ignore: {name: "Use <$"} - ignore: {name: "Use const"} - ignore: {name: "Fuse mapM/map"} From 35181567491edf70ca931e2496077e01c2368468 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:32 -0400 Subject: [PATCH 1309/1580] HLint fix: "Parse error" --- .hlint.yaml | 1 - src/Language/PureScript/Docs/RenderedCode/RenderType.hs | 5 ++++- src/Language/PureScript/Pretty/Types.hs | 8 ++++++-- 3 files changed, 10 insertions(+), 4 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index aa05b2b4c1..f054af9f15 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -35,7 +35,6 @@ - ignore: {name: "Redundant if"} - ignore: {name: "Use traverse_"} - ignore: {name: "Use :"} -- ignore: {name: "Parse error"} - ignore: {name: "Avoid reverse"} - ignore: {name: "Use Just"} - ignore: {name: "Use /="} diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index 4eed8478e3..314300b5e4 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -1,3 +1,6 @@ +-- HLint is confused by the identifier `pattern` if PatternSynonyms is enabled. +{-# LANGUAGE NoPatternSynonyms #-} + -- | Functions for producing RenderedCode values from PureScript Type values. module Language.PureScript.Docs.RenderedCode.RenderType @@ -30,7 +33,7 @@ typeLiterals :: Pattern () PrettyPrintType RenderedCode typeLiterals = mkPattern match where match (PPTypeWildcard name) = - Just $ maybe (syntax "_") (syntax . ("?" <>)) name + Just $ syntax $ maybe "_" ("?" <>) name match (PPTypeVar var) = Just (typeVar var) match (PPRecord labels tail_) = diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index b8e2e768dc..ee3721230e 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -1,3 +1,6 @@ +-- HLint is confused by the identifier `pattern` if PatternSynonyms is enabled. +{-# LANGUAGE NoPatternSynonyms #-} + -- | -- Pretty printer for Types -- @@ -22,6 +25,7 @@ import Prelude.Compat hiding ((<>)) import Control.Arrow ((<+>)) import Control.PatternArrows as PA +import Data.Bifunctor (first) import Data.Maybe (fromMaybe, catMaybes) import Data.Text (Text) import qualified Data.Text as T @@ -180,7 +184,7 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} = where typeLiterals :: Pattern () PrettyPrintType Box typeLiterals = mkPattern match where - match (PPTypeWildcard name) = Just $ maybe (text "_") (text . ('?' :) . T.unpack) name + match (PPTypeWildcard name) = Just $ text $ maybe "_" (('?' :) . T.unpack) name match (PPTypeVar var) = Just $ text $ T.unpack var match (PPTypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s match (PPTypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor @@ -228,7 +232,7 @@ matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where forall_ :: Pattern () PrettyPrintType ([(String, Maybe PrettyPrintType)], PrettyPrintType) forall_ = mkPattern match where - match (PPForAll idents ty) = Just (map (\(v, mbK) -> (T.unpack v, mbK)) idents, ty) + match (PPForAll idents ty) = Just (map (first T.unpack) idents, ty) match _ = Nothing typeAtomAsBox' :: PrettyPrintType -> Box From 96e96c7c873c4310406ddc1cd34e4425243dca9b Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:32 -0400 Subject: [PATCH 1310/1580] HLint fix: "Unused LANGUAGE pragma" --- .hlint.yaml | 1 - app/Command/Bundle.hs | 6 ------ app/Command/Compile.hs | 5 ----- app/Command/Docs/Html.hs | 3 --- app/Command/Docs/Markdown.hs | 2 -- app/Command/Graph.hs | 4 ---- app/Command/Hierarchy.hs | 2 -- app/Command/Ide.hs | 6 ------ app/Command/Publish.hs | 2 -- app/Command/REPL.hs | 8 -------- app/Main.hs | 7 ------- lib/purescript-ast/src/Language/PureScript/Crash.hs | 1 - src/Control/Monad/Logger.hs | 3 --- src/Language/PureScript/Docs/RenderedCode/Types.hs | 3 --- src/Language/PureScript/Docs/Types.hs | 2 -- src/Language/PureScript/Errors.hs | 3 --- src/Language/PureScript/Externs.hs | 2 -- src/Language/PureScript/Ide/Filter.hs | 2 -- src/Language/PureScript/Ide/Filter/Declaration.hs | 2 -- src/Language/PureScript/Ide/Matcher.hs | 3 --- src/Language/PureScript/Ide/Reexports.hs | 1 - src/Language/PureScript/Ide/State.hs | 3 --- src/Language/PureScript/Make/Cache.hs | 2 -- src/Language/PureScript/Make/Monad.hs | 2 -- src/Language/PureScript/Pretty/Common.hs | 2 -- src/Language/PureScript/Publish.hs | 2 -- src/Language/PureScript/Sugar/AdoNotation.hs | 2 -- src/Language/PureScript/Sugar/DoNotation.hs | 2 -- src/Language/PureScript/TypeChecker.hs | 2 -- src/Language/PureScript/TypeChecker/Entailment.hs | 2 -- src/Language/PureScript/TypeChecker/Monad.hs | 1 - src/Language/PureScript/TypeChecker/Roles.hs | 1 - src/Language/PureScript/TypeChecker/Subsumption.hs | 1 - src/Language/PureScript/TypeChecker/Types.hs | 2 -- src/Language/PureScript/TypeChecker/Unify.hs | 2 -- src/System/IO/UTF8.hs | 2 -- tests/Language/PureScript/Ide/CompletionSpec.hs | 2 -- tests/Language/PureScript/Ide/FilterSpec.hs | 2 -- tests/Language/PureScript/Ide/ImportsSpec.hs | 2 -- tests/Language/PureScript/Ide/MatcherSpec.hs | 3 --- tests/Language/PureScript/Ide/RebuildSpec.hs | 2 -- tests/Language/PureScript/Ide/ReexportsSpec.hs | 2 -- tests/Language/PureScript/Ide/SourceFileSpec.hs | 2 -- tests/Language/PureScript/Ide/StateSpec.hs | 2 -- tests/Language/PureScript/Ide/Test.hs | 3 --- tests/Language/PureScript/Ide/UsageSpec.hs | 2 -- tests/Main.hs | 3 --- tests/TestBundle.hs | 4 ---- tests/TestCompiler.hs | 4 ---- tests/TestCoreFn.hs | 3 --- tests/TestCst.hs | 3 --- tests/TestHierarchy.hs | 1 - tests/TestPscPublish.hs | 4 ---- tests/TestPsci/CommandTest.hs | 2 -- tests/TestPsci/CompletionTest.hs | 1 - tests/TestPsci/TestEnv.hs | 2 -- tests/TestUtils.hs | 4 ---- 57 files changed, 149 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index f054af9f15..a7cd08135f 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -7,7 +7,6 @@ # Warnings currently triggered by your code -- ignore: {name: "Unused LANGUAGE pragma"} - ignore: {name: "Redundant =="} - ignore: {name: "Use infix"} - ignore: {name: "Redundant do"} diff --git a/app/Command/Bundle.hs b/app/Command/Bundle.hs index a06a383c74..bed22fcd78 100644 --- a/app/Command/Bundle.hs +++ b/app/Command/Bundle.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RecordWildCards #-} - -- | Bundles compiled PureScript modules for the browser. module Command.Bundle (command) where diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 2528957201..2a423c9526 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Command.Compile (command) where import Prelude diff --git a/app/Command/Docs/Html.hs b/app/Command/Docs/Html.hs index 6362837562..f49cdf9305 100644 --- a/app/Command/Docs/Html.hs +++ b/app/Command/Docs/Html.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} - module Command.Docs.Html ( asHtml , layout diff --git a/app/Command/Docs/Markdown.hs b/app/Command/Docs/Markdown.hs index 73338cbe37..e14a4e408a 100644 --- a/app/Command/Docs/Markdown.hs +++ b/app/Command/Docs/Markdown.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Command.Docs.Markdown ( asMarkdown , writeMarkdownModules diff --git a/app/Command/Graph.hs b/app/Command/Graph.hs index 58f26ac00d..ca2b5d7060 100644 --- a/app/Command/Graph.hs +++ b/app/Command/Graph.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - module Command.Graph (command) where import Prelude diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs index f732c5f146..f7690599aa 100644 --- a/app/Command/Hierarchy.hs +++ b/app/Command/Hierarchy.hs @@ -13,8 +13,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE DataKinds #-} - module Command.Hierarchy (command) where import Prelude diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index 630a476714..00b275993e 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -12,14 +12,8 @@ -- The server accepting commands for psc-ide ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE LambdaCase #-} module Command.Ide (command) where diff --git a/app/Command/Publish.hs b/app/Command/Publish.hs index fe5f4c7d5e..84e5fe5a8d 100644 --- a/app/Command/Publish.hs +++ b/app/Command/Publish.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Command.Publish (command) where import Prelude diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 6a93dae371..01429b093e 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -1,14 +1,6 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} module Command.REPL (command) where diff --git a/app/Main.hs b/app/Main.hs index 1725274904..8472b78751 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} - module Main where import Prelude diff --git a/lib/purescript-ast/src/Language/PureScript/Crash.hs b/lib/purescript-ast/src/Language/PureScript/Crash.hs index fe72169bb0..858c7361a9 100644 --- a/lib/purescript-ast/src/Language/PureScript/Crash.hs +++ b/lib/purescript-ast/src/Language/PureScript/Crash.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE ImplicitParams #-} module Language.PureScript.Crash where diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs index c4969d8572..c5c051dfe3 100644 --- a/src/Control/Monad/Logger.hs +++ b/src/Control/Monad/Logger.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} - -- | -- A replacement for WriterT IO which uses mutable references. -- diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 8eefbe1ad9..377858bf9d 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveGeneric #-} - -- | Data types and functions for representing a simplified form of PureScript -- code, intended for use in e.g. HTML documentation. diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 6bf6fd6111..4359abdcfd 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Language.PureScript.Docs.Types ( module Language.PureScript.Docs.Types , module ReExports diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 9ec7e317b8..82e1118a59 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} - module Language.PureScript.Errors ( module Language.PureScript.AST , module Language.PureScript.Errors diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 2a92064f35..a1a3f53002 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - -- | -- This module generates code for \"externs\" files, i.e. files containing only -- foreign import declarations. diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 0149fb230d..0c887b9cab 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -12,8 +12,6 @@ -- Filters for psc-ide commands ----------------------------------------------------------------------------- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Language.PureScript.Ide.Filter ( Filter , moduleFilter diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs index 82c1f94ee5..c98f03c5e8 100644 --- a/src/Language/PureScript/Ide/Filter/Declaration.hs +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Language.PureScript.Ide.Filter.Declaration ( DeclarationType(..) ) where diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index 85200de1c2..30369796a3 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -12,9 +12,6 @@ -- Matchers for psc-ide commands ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Language.PureScript.Ide.Matcher ( Matcher , runMatcher diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index b66b887678..c2bbb9f310 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- -- Module : Language.PureScript.Ide.Reexports diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index afe386653e..9234711b40 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -13,9 +13,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE PackageImports #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeApplications #-} module Language.PureScript.Ide.State diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs index bfc3e4c7f8..e69acd4317 100644 --- a/src/Language/PureScript/Make/Cache.hs +++ b/src/Language/PureScript/Make/Cache.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Language.PureScript.Make.Cache ( ContentHash , hash diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index cd3fda172d..cea5fa882f 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Language.PureScript.Make.Monad ( -- * Implementation of Make API using files on disk Make(..) diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 8ced1e3e9e..a7c69a21fc 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- | -- Common pretty-printing utility functions -- diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 63c79e6ae4..98a3a2c016 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Language.PureScript.Publish ( preparePackage , preparePackage' diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs index 496b0e7e01..5225e1a5b8 100644 --- a/src/Language/PureScript/Sugar/AdoNotation.hs +++ b/src/Language/PureScript/Sugar/AdoNotation.hs @@ -1,8 +1,6 @@ -- | This module implements the desugaring pass which replaces ado-notation statements with -- appropriate calls to pure and apply. -{-# LANGUAGE PatternGuards #-} - module Language.PureScript.Sugar.AdoNotation (desugarAdoModule) where import Prelude.Compat hiding (abs) diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 2b253169f3..1bd74f7f29 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -1,8 +1,6 @@ -- | This module implements the desugaring pass which replaces do-notation statements with -- appropriate calls to bind. -{-# LANGUAGE PatternGuards #-} - module Language.PureScript.Sugar.DoNotation (desugarDoModule) where import Prelude.Compat diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 13348b7841..2e41c907df 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} - -- | -- The top-level type checker, which checks all declarations in a module. -- diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 72d9455529..63480ba7b3 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} - -- | -- Type class entailment -- diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 3799569dbe..1e9b6b65b6 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -- | diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index f8de82938a..e99e9878d9 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeApplications #-} -- | diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index ae7d22868c..f4e0da99c4 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -- | Subsumption checking module Language.PureScript.TypeChecker.Subsumption diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 2ac50648ad..01f8a693b4 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} - -- | -- This module implements the type checker -- diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 94780d66c4..cbf7076693 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} - -- | -- Functions and instances relating to unification -- diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs index 6bb0187262..302334d00c 100644 --- a/src/System/IO/UTF8.hs +++ b/src/System/IO/UTF8.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TupleSections #-} - module System.IO.UTF8 where import Prelude.Compat diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs index b71ba6b9e8..4cfb1d3d01 100644 --- a/tests/Language/PureScript/Ide/CompletionSpec.hs +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.CompletionSpec where import Protolude diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index c721c217b7..6544d14216 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.FilterSpec where import Protolude diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 841588a32f..bcedcb8830 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.ImportsSpec where import Protolude hiding (moduleName) diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs index 22eb860e12..f792c4ce94 100644 --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - module Language.PureScript.Ide.MatcherSpec where import Protolude diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index f7f1d827cb..fd4bb8184a 100644 --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.RebuildSpec where import Protolude diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index 51e700e7e2..cbc2e6e88d 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.ReexportsSpec where import Protolude diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index aba2370e2b..037beff3fa 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} module Language.PureScript.Ide.SourceFileSpec where import Protolude diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index fe0b9caf32..e269455987 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.StateSpec where import Protolude diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index 178e926257..a3dbb62587 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE DataKinds #-} module Language.PureScript.Ide.Test where import Control.Concurrent.STM diff --git a/tests/Language/PureScript/Ide/UsageSpec.hs b/tests/Language/PureScript/Ide/UsageSpec.hs index 3c619dce3b..aa3083cc4c 100644 --- a/tests/Language/PureScript/Ide/UsageSpec.hs +++ b/tests/Language/PureScript/Ide/UsageSpec.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} module Language.PureScript.Ide.UsageSpec where import Protolude diff --git a/tests/Main.hs b/tests/Main.hs index 2bdad5d6f4..065821a95e 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleInstances #-} module Main (main) where diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs index d16dffe21f..d60e65fd5f 100644 --- a/tests/TestBundle.hs +++ b/tests/TestBundle.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module TestBundle where diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index f0941c96df..a762b37a11 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module TestCompiler where diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index 0f5b851021..f83e07bb95 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} module TestCoreFn (spec) where diff --git a/tests/TestCst.hs b/tests/TestCst.hs index 20f06ad0cf..8c094473b9 100644 --- a/tests/TestCst.hs +++ b/tests/TestCst.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} module TestCst where import Prelude diff --git a/tests/TestHierarchy.hs b/tests/TestHierarchy.hs index ad1d26a9df..ad83c24908 100644 --- a/tests/TestHierarchy.hs +++ b/tests/TestHierarchy.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module TestHierarchy where import Prelude diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 78e5085b9e..374fc0c6f2 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} - module TestPscPublish where import Prelude diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs index 758cfbc982..3872f81ea1 100644 --- a/tests/TestPsci/CommandTest.hs +++ b/tests/TestPsci/CommandTest.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module TestPsci.CommandTest where import Prelude () diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index e9712dd22b..b8f1667af6 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module TestPsci.CompletionTest where import Prelude () diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 31d5fdc591..5f9e8587c7 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module TestPsci.TestEnv where import Prelude () diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 352da0af16..3c31c8a21d 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} - - module TestUtils where import Prelude () From a18ce3d6cdb3f3995b474c74b9f4415e55505b59 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:32 -0400 Subject: [PATCH 1311/1580] HLint fix: "Redundant ==" --- .hlint.yaml | 1 - app/Command/Bundle.hs | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index a7cd08135f..9bf7ab145a 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -7,7 +7,6 @@ # Warnings currently triggered by your code -- ignore: {name: "Redundant =="} - ignore: {name: "Use infix"} - ignore: {name: "Redundant do"} - ignore: {name: "Use newtype instead of data"} diff --git a/app/Command/Bundle.hs b/app/Command/Bundle.hs index bed22fcd78..ac3be3933a 100644 --- a/app/Command/Bundle.hs +++ b/app/Command/Bundle.hs @@ -46,7 +46,7 @@ app Options{..} = do when (null inputFiles) . liftIO $ do hPutStrLn stderr "purs bundle: No input files." exitFailure - when (isNothing optionsOutputFile && optionsSourceMaps == True) . liftIO $ do + when (isNothing optionsOutputFile && optionsSourceMaps) . liftIO $ do hPutStrLn stderr "purs bundle: Source maps only supported when output file specified." exitFailure From 025aa3a9b1492909159980fe9d6c9fa81a33d15d Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:32 -0400 Subject: [PATCH 1312/1580] HLint fix: "Redundant if" --- .hlint.yaml | 1 - src/Language/PureScript/Docs/AsHtml.hs | 5 +---- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 9bf7ab145a..186e5a947c 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -30,7 +30,6 @@ - ignore: {name: "Use &&"} - ignore: {name: "Use <$>"} - ignore: {name: "Use ."} -- ignore: {name: "Redundant if"} - ignore: {name: "Use traverse_"} - ignore: {name: "Use :"} - ignore: {name: "Avoid reverse"} diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index 3fc7074c76..118bda4d4e 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -216,10 +216,7 @@ codeAsHtml r = outputWith elemAsHtml linkToDecl = linkToDeclaration r startsWithUpper :: Text -> Bool - startsWithUpper str = - if T.null str - then False - else isUpper (T.index str 0) + startsWithUpper str = not (T.null str) && isUpper (T.index str 0) isOp = isRight . runParser CST.parseOperator From 0cfb84a3bd0334c7c5987024515aacee1a2f8b8e Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:32 -0400 Subject: [PATCH 1313/1580] HLint fix: "Use notElem" --- .hlint.yaml | 1 - lib/purescript-ast/src/Language/PureScript/Environment.hs | 2 +- src/Language/PureScript/TypeChecker/Entailment.hs | 2 +- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 186e5a947c..4dc772a792 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -14,7 +14,6 @@ - ignore: {name: "Use join"} - ignore: {name: "Fuse foldr/map"} - ignore: {name: "Eta reduce"} -- ignore: {name: "Use notElem"} - ignore: {name: "Use lambda-case"} - ignore: {name: "Avoid lambda"} - ignore: {name: "Use tuple-section"} diff --git a/lib/purescript-ast/src/Language/PureScript/Environment.hs b/lib/purescript-ast/src/Language/PureScript/Environment.hs index 97955e18d2..1018cd1dab 100644 --- a/lib/purescript-ast/src/Language/PureScript/Environment.hs +++ b/lib/purescript-ast/src/Language/PureScript/Environment.hs @@ -154,7 +154,7 @@ makeTypeClassData args m s deps tcIsEmpty = TypeClassData args m s deps determin Nothing -> internalError "Unknown argument index in makeTypeClassData" Just v -> let contributesToVar = G.reachable (G.transposeG depGraph) v varContributesTo = G.reachable depGraph v - in any (\r -> not (r `elem` varContributesTo)) contributesToVar + in any (`notElem` varContributesTo) contributesToVar -- find all the arguments that are determined determinedArgs :: S.Set Int diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 63480ba7b3..b1127a07d0 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -551,7 +551,7 @@ entails SolverOptions{..} constraint context hints = (fixed, rest) = rowToList r lacksSym = - not $ sym `elem` (runLabel . rowListLabel <$> fixed) + sym `notElem` (runLabel . rowListLabel <$> fixed) (canMakeProgress, cst) = case rest of REmptyKinded _ _ -> (True, Nothing) From 08f4c3d148676b7d27e76b6d4c8bdde9bf819442 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:32 -0400 Subject: [PATCH 1314/1580] HLint fix: "Use String" --- .hlint.yaml | 1 - .../src/Language/PureScript/CST/Lexer.hs | 10 +++++----- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 4dc772a792..956da604a0 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -20,7 +20,6 @@ - ignore: {name: "Use sortOn"} - ignore: {name: "Redundant $"} - ignore: {name: "Use record patterns"} -- ignore: {name: "Use String"} - ignore: {name: "Use isDigit"} - ignore: {name: "Use list literal pattern"} - ignore: {name: "Use unless"} diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs index ceeab1cd64..1b6d399b69 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs @@ -332,7 +332,7 @@ token = peek >>= maybe (pure TokEof) k0 operator : symbolChar+ -} - operator :: [Text] -> [Char] -> Lexer Token + operator :: [Text] -> String -> Lexer Token operator qual pre = do rest <- nextWhile isSymbolChar pure . TokOperator (reverse qual) $ Text.pack pre <> rest @@ -649,20 +649,20 @@ token = peek >>= maybe (pure TokEof) k0 then throw ErrExpectedHex else pure $ TokInt ("0x" <> chs) $ digitsToIntegerBase 16 $ Text.unpack chs -digitsToInteger :: [Char] -> Integer +digitsToInteger :: String -> Integer digitsToInteger = digitsToIntegerBase 10 -digitsToIntegerBase :: Integer -> [Char] -> Integer +digitsToIntegerBase :: Integer -> String -> Integer digitsToIntegerBase b = foldl' (\n c -> n * b + (toInteger (Char.digitToInt c))) 0 -digitsToScientific :: [Char] -> [Char] -> (Integer, Int) +digitsToScientific :: String -> String -> (Integer, Int) digitsToScientific = go 0 . reverse where go !exp is [] = (digitsToInteger (reverse is), exp) go !exp is (f : fs) = go (exp - 1) (f : is) fs isSymbolChar :: Char -> Bool -isSymbolChar c = (c `elem` (":!#$%&*+./<=>?@\\^|-~" :: [Char])) || (not (Char.isAscii c) && Char.isSymbol c) +isSymbolChar c = (c `elem` (":!#$%&*+./<=>?@\\^|-~" :: String)) || (not (Char.isAscii c) && Char.isSymbol c) isReservedSymbolError :: ParserErrorType -> Bool isReservedSymbolError = (== ErrReservedSymbol) From 959bf2ef62ffb760561a0146368e534fdcd9bb77 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:32 -0400 Subject: [PATCH 1315/1580] HLint fix: "Use isDigit" --- .hlint.yaml | 1 - lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs | 9 +++------ 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 956da604a0..b30318dc72 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -20,7 +20,6 @@ - ignore: {name: "Use sortOn"} - ignore: {name: "Redundant $"} - ignore: {name: "Use record patterns"} -- ignore: {name: "Use isDigit"} - ignore: {name: "Use list literal pattern"} - ignore: {name: "Use unless"} - ignore: {name: "Move brackets to avoid $"} diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs index 1b6d399b69..e35d0b1b45 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs @@ -570,7 +570,7 @@ token = peek >>= maybe (pure TokEof) k0 Just '0' -> next *> peek >>= \case Just ch | isNumberChar ch -> throw ErrLeadingZero _ -> pure $ Just ("0", "0") - Just ch | isDigitChar ch -> Just <$> digits + Just ch | Char.isDigit ch -> Just <$> digits _ -> pure $ Nothing {- @@ -586,7 +586,7 @@ token = peek >>= maybe (pure TokEof) k0 '0' -> peek >>= \case Just ch | isNumberChar ch -> throw ErrLeadingZero _ -> pure $ Just ("0", "0") - ch | isDigitChar ch -> do + ch | Char.isDigit ch -> do (raw, chs) <- digits pure $ Just (Text.cons ch raw, ch : chs) _ -> pure $ Nothing @@ -692,11 +692,8 @@ isIdentStart c = Char.isLower c || c == '_' isIdentChar :: Char -> Bool isIdentChar c = Char.isAlphaNum c || c == '_' || c == '\'' -isDigitChar :: Char -> Bool -isDigitChar c = c >= '0' && c <= '9' - isNumberChar :: Char -> Bool -isNumberChar c = (c >= '0' && c <= '9') || c == '_' +isNumberChar c = Char.isDigit c || c == '_' isNormalStringChar :: Char -> Bool isNormalStringChar c = c /= '"' && c /= '\\' && c /= '\r' && c /= '\n' From 6c4706854e98ebe533f18cebc2cd5e9084e3c412 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1316/1580] HLint fix: "Use unless" --- .hlint.yaml | 1 - lib/purescript-cst/src/Language/PureScript/CST/Utils.hs | 6 +++--- src/Language/PureScript/TypeChecker/Entailment/Coercible.hs | 4 ++-- src/Language/PureScript/TypeChecker/Types.hs | 2 +- 4 files changed, 6 insertions(+), 7 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index b30318dc72..b9af70fcb3 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -21,7 +21,6 @@ - ignore: {name: "Redundant $"} - ignore: {name: "Use record patterns"} - ignore: {name: "Use list literal pattern"} -- ignore: {name: "Use unless"} - ignore: {name: "Move brackets to avoid $"} - ignore: {name: "Use section"} - ignore: {name: "Use &&"} diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs index e73752ecf3..b9e4b80bc0 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs @@ -2,7 +2,7 @@ module Language.PureScript.CST.Utils where import Prelude -import Control.Monad (when) +import Control.Monad (unless) import Data.Coerce (coerce) import Data.Foldable (for_) import Data.Functor (($>)) @@ -128,14 +128,14 @@ internalError = error . ("Internal parser error: " <>) toModuleName :: SourceToken -> [Text] -> Parser (Maybe N.ModuleName) toModuleName _ [] = pure Nothing toModuleName tok ns = do - when (not (all isValidModuleNamespace ns)) $ addFailure [tok] ErrModuleName + unless (all isValidModuleNamespace ns) $ addFailure [tok] ErrModuleName pure . Just . N.ModuleName $ Text.intercalate "." ns upperToModuleName :: SourceToken -> Parser (Name N.ModuleName) upperToModuleName tok = case tokValue tok of TokUpperName q a -> do let ns = q <> [a] - when (not (all isValidModuleNamespace ns)) $ addFailure [tok] ErrModuleName + unless (all isValidModuleNamespace ns) $ addFailure [tok] ErrModuleName pure . Name tok . N.ModuleName $ Text.intercalate "." ns _ -> internalError $ "Invalid upper name: " <> show tok diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 78bc2628bf..1eed5d6c50 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -17,7 +17,7 @@ import Prelude.Compat hiding (interact) import Control.Applicative ((<|>), empty) import Control.Arrow ((&&&)) -import Control.Monad ((<=<), guard, when) +import Control.Monad ((<=<), guard, unless, when) import Control.Monad.Error.Class (MonadError, catchError, throwError) import Control.Monad.State (MonadState, StateT, get, gets, modify, put) import Control.Monad.Trans.Class (lift) @@ -640,7 +640,7 @@ unwrapNewtype env = go (0 :: Int) where -- to canonicalize them yet and we'd rather try to make progress with -- another rule. , isMonoType wrappedTy -> do - when (not inScope) $ do + unless inScope $ do tell [MissingConstructorImportForCoercible newtypeCtorName] throwError CannotUnwrapConstructor for_ fromModuleName $ flip addConstructorImportForCoercible newtypeCtorName diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 01f8a693b4..cc2b96c40d 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -157,7 +157,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do let constraintTypeVars = fold (conData >>= snd) let solved = solveFrom determinedFromType let unsolvedVars = S.difference constraintTypeVars solved - when (not (S.null unsolvedVars)) . + unless (S.null unsolvedVars) . throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage' ss From ee00343df2b612e192c5bf81dfe1887f14393b90 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1317/1580] HLint fix: "Use traverse_" --- .hlint.yaml | 1 - src/Language/PureScript/Docs/Convert/ReExports.hs | 3 ++- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index b9af70fcb3..0ee25ae94f 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -26,7 +26,6 @@ - ignore: {name: "Use &&"} - ignore: {name: "Use <$>"} - ignore: {name: "Use ."} -- ignore: {name: "Use traverse_"} - ignore: {name: "Use :"} - ignore: {name: "Avoid reverse"} - ignore: {name: "Use Just"} diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 5c9526a01d..d465982bcd 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -12,6 +12,7 @@ import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.State.Strict (execState) import Data.Either +import Data.Foldable (traverse_) import Data.Map (Map) import Data.Maybe (mapMaybe, fromMaybe) import qualified Data.Map as Map @@ -47,7 +48,7 @@ updateReExports :: updateReExports externs withPackage = execState action where action = - void (traverse go traversalOrder) + traverse_ go traversalOrder go mn = do mdl <- lookup' mn From 7f1fb20d2614932fc56d29fcfd72272622b51cd9 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1318/1580] HLint fix: "Use /=" --- .hlint.yaml | 1 - src/Language/PureScript/Ide/Logging.hs | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 0ee25ae94f..b3f51987c2 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -29,7 +29,6 @@ - ignore: {name: "Use :"} - ignore: {name: "Avoid reverse"} - ignore: {name: "Use Just"} -- ignore: {name: "Use /="} - ignore: {name: "Reduce duplication"} - ignore: {name: "Use camelCase"} - ignore: {name: "Use ++"} diff --git a/src/Language/PureScript/Ide/Logging.hs b/src/Language/PureScript/Ide/Logging.hs index 33fc3c2bdd..9ffaafa278 100644 --- a/src/Language/PureScript/Ide/Logging.hs +++ b/src/Language/PureScript/Ide/Logging.hs @@ -22,7 +22,7 @@ runLogger logLevel' = LogAll -> True LogDefault -> not (logLevel == LevelOther "perf" || logLevel == LevelDebug) LogNone -> False - LogDebug -> not (logLevel == LevelOther "perf") + LogDebug -> logLevel /= LevelOther "perf" LogPerf -> logLevel == LevelOther "perf") labelTimespec :: Text -> TimeSpec -> Text From cfc530675724e7f84f116c2c43cb7de9f74ea12e Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1319/1580] HLint fix: "Use $>" --- .hlint.yaml | 1 - src/Language/PureScript/Sugar/Operators.hs | 3 ++- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index b3f51987c2..14fece3c92 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -34,7 +34,6 @@ - ignore: {name: "Use ++"} - ignore: {name: "Hoist not"} - ignore: {name: "Functor law"} -- ignore: {name: "Use $>"} - ignore: {name: "Redundant fmap"} - ignore: {name: "Use =<<"} - ignore: {name: "Use maybe"} diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 2538bd3117..bc6e205744 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -31,6 +31,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Data.Either (partitionEithers) import Data.Foldable (for_, traverse_) import Data.Function (on) +import Data.Functor (($>)) import Data.Functor.Identity (Identity(..), runIdentity) import Data.List (groupBy, sortBy) import Data.Maybe (mapMaybe, listToMaybe) @@ -372,7 +373,7 @@ checkFixityExports (Module _ _ _ _ Nothing) = checkFixityExports m@(Module ss _ mn ds (Just exps)) = rethrow (addHint (ErrorInModule mn)) $ rethrowWithPosition ss (traverse_ checkRef exps) - *> return m + $> m where checkRef :: DeclarationRef -> m () From fa35f9a11bf17a1de34cc80e3a83b51fd7b1e2aa Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1320/1580] HLint fix: "Use =<<" --- .hlint.yaml | 1 - src/Language/PureScript/Sugar/Operators/Common.hs | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 14fece3c92..38412c0d6b 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -35,7 +35,6 @@ - ignore: {name: "Hoist not"} - ignore: {name: "Functor law"} - ignore: {name: "Redundant fmap"} -- ignore: {name: "Use =<<"} - ignore: {name: "Use maybe"} - ignore: {name: "Use zipWithM_"} - ignore: {name: "Use fromMaybe"} diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index a038d384e5..5f1d10fc86 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -118,7 +118,7 @@ matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains mixedAssoc :: [NEL.NonEmpty (Qualified (OpName nameType))] mixedAssoc = fmap join . filter (\precGroup -> NEL.length precGroup > 1) $ assocGrouped nonAssoc :: [NEL.NonEmpty (Qualified (OpName nameType))] - nonAssoc = join $ fmap (NEL.filter (\assocGroup -> opAssoc (NEL.head assocGroup) == Infix && sum (fmap opUsages assocGroup) > 1)) assocGrouped + nonAssoc = NEL.filter (\assocGroup -> opAssoc (NEL.head assocGroup) == Infix && sum (fmap opUsages assocGroup) > 1) =<< assocGrouped in if null (nonAssoc ++ mixedAssoc) then internalError "matchOperators: cannot reorder operators" @@ -141,4 +141,4 @@ matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains -> ErrorMessage mkPositionedError chainOpSpans grp = ErrorMessage - [PositionedError (join . fmap (fromJust . flip M.lookup chainOpSpans) $ grp)] + [PositionedError (fromJust . flip M.lookup chainOpSpans =<< grp)] From 2ed5aea16a898e4c7b9118ce2af2f6a549cd8588 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1321/1580] HLint fix: "Use maybe" --- .hlint.yaml | 1 - src/Language/PureScript/Sugar/TypeClasses.hs | 4 ++-- tests/Language/PureScript/Ide/Test.hs | 2 +- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 38412c0d6b..ff01ec4f2a 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -35,7 +35,6 @@ - ignore: {name: "Hoist not"} - ignore: {name: "Functor law"} - ignore: {name: "Redundant fmap"} -- ignore: {name: "Use maybe"} - ignore: {name: "Use zipWithM_"} - ignore: {name: "Use fromMaybe"} - ignore: {name: "Use gets"} diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index c647b67fdf..ff6b9027d1 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -17,7 +17,7 @@ import Control.Monad.Supply.Class import Data.Graph import Data.List (find, partition) import qualified Data.Map as M -import Data.Maybe (catMaybes, mapMaybe, isJust, fromMaybe) +import Data.Maybe (catMaybes, mapMaybe, isJust) import qualified Data.List.NonEmpty as NEL import qualified Data.Set as S import Data.Text (Text) @@ -362,7 +362,7 @@ declIdent (TypeDeclaration td) = Just (tydeclIdent td) declIdent _ = Nothing typeClassMemberName :: Declaration -> Text -typeClassMemberName = fromMaybe (internalError "typeClassMemberName: Invalid declaration in type class definition") . fmap runIdent . declIdent +typeClassMemberName = maybe (internalError "typeClassMemberName: Invalid declaration in type class definition") runIdent . declIdent superClassDictionaryNames :: [Constraint a] -> [Text] superClassDictionaryNames supers = diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index a3dbb62587..11fa4a3c3f 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -136,7 +136,7 @@ compileTestProject = inProject $ do (_, _, _, procHandle) <- createProcess $ (shell $ "purs compile \"src/**/*.purs\"") r <- tryNTimes 10 (getProcessExitCode procHandle) - pure (fromMaybe False (isSuccess <$> r)) + pure (maybe False isSuccess r) isSuccess :: ExitCode -> Bool isSuccess ExitSuccess = True From d1c674b275f7a5d1bdd5567385f598beec2d150a Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1322/1580] HLint fix: "Use zipWithM_" --- .hlint.yaml | 1 - src/Language/PureScript/TypeChecker.hs | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index ff01ec4f2a..f63f4ef543 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -35,7 +35,6 @@ - ignore: {name: "Hoist not"} - ignore: {name: "Functor law"} - ignore: {name: "Redundant fmap"} -- ignore: {name: "Use zipWithM_"} - ignore: {name: "Use fromMaybe"} - ignore: {name: "Use gets"} - ignore: {name: "Use unwords"} diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 2e41c907df..e4e99be3c6 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -10,7 +10,7 @@ module Language.PureScript.TypeChecker import Prelude.Compat import Protolude (headMay, ordNub) -import Control.Monad (when, unless, void, forM,) +import Control.Monad (when, unless, void, forM, zipWithM_) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), modify, gets) import Control.Monad.Supply.Class (MonadSupply) @@ -413,7 +413,7 @@ typeCheckAll moduleName _ = traverse go checkInstanceArity dictName className typeClass tys (deps', kinds', tys', vars) <- withFreshSubstitution $ checkInstanceDeclaration moduleName (sa, deps, className, tys) tys'' <- traverse replaceAllTypeSynonyms tys' - sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys'') + zipWithM_ (checkTypeClassInstance typeClass) [0..] tys'' let nonOrphanModules = findNonOrphanModules className typeClass tys'' checkOrphanInstance dictName className tys'' nonOrphanModules let chainId = Just ch From 0359d1fc9f313dd649bf6d12966e3225fbd7b364 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1323/1580] HLint fix: "Use fromMaybe" --- .hlint.yaml | 1 - src/Language/PureScript/TypeChecker/Kinds.hs | 6 +++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index f63f4ef543..faa1e686ef 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -35,7 +35,6 @@ - ignore: {name: "Hoist not"} - ignore: {name: "Functor law"} - ignore: {name: "Redundant fmap"} -- ignore: {name: "Use fromMaybe"} - ignore: {name: "Use gets"} - ignore: {name: "Use unwords"} - ignore: {name: "Use fmap"} diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 5dfd00c1c3..5afe2dec53 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -41,7 +41,7 @@ import Data.Functor (($>)) import qualified Data.IntSet as IS import Data.List (nubBy, sortBy, (\\)) import qualified Data.Map as M -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, fromMaybe) import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T @@ -191,7 +191,7 @@ inferKind = \tyToInfer -> kind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing $ ProperName v) pure (ty, kind $> ann) ty@(Skolem ann _ mbK _ _) -> do - kind <- apply $ maybe (internalError "Skolem has no kind") id mbK + kind <- apply $ fromMaybe (internalError "Skolem has no kind") mbK pure (ty, kind $> ann) ty@(TUnknown ann u) -> do kind <- apply . snd =<< lookupUnsolved u @@ -499,7 +499,7 @@ elaborateKind = \case kind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing $ ProperName a) pure (kind $> ann) (Skolem ann _ mbK _ _) -> do - kind <- apply $ maybe (internalError "Skolem has no kind") id mbK + kind <- apply $ fromMaybe (internalError "Skolem has no kind") mbK pure $ kind $> ann TUnknown ann a' -> do kind <- snd <$> lookupUnsolved a' From 6d818a84a5dc7f8839469fc8efbc79fa4933ced3 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1324/1580] HLint fix: "Use gets" --- .hlint.yaml | 1 - src/Language/PureScript/TypeChecker/Monad.hs | 8 ++++---- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index faa1e686ef..aac198a609 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -35,7 +35,6 @@ - ignore: {name: "Hoist not"} - ignore: {name: "Functor law"} - ignore: {name: "Redundant fmap"} -- ignore: {name: "Use gets"} - ignore: {name: "Use unwords"} - ignore: {name: "Use fmap"} - ignore: {name: "Avoid lambda using `infix`"} diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 1e9b6b65b6..76b03b669a 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -196,14 +196,14 @@ withTypeClassDictionaries entries action = do getTypeClassDictionaries :: (MonadState CheckState m) => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))) -getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get +getTypeClassDictionaries = gets $ typeClassDictionaries . checkEnv -- | Lookup type class dictionaries in a module. lookupTypeClassDictionaries :: (MonadState CheckState m) => Maybe ModuleName -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) -lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get +lookupTypeClassDictionaries mn = gets $ fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv -- | Lookup type class dictionaries in a module. lookupTypeClassDictionariesForClass @@ -295,7 +295,7 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do -- | Get the current @Environment@ getEnv :: (MonadState CheckState m) => m Environment -getEnv = checkEnv <$> get +getEnv = gets checkEnv -- | Get locally-bound names in context, to create an error message. getLocalContext :: MonadState CheckState m => m Context @@ -362,7 +362,7 @@ unsafeCheckCurrentModule :: forall m . (MonadError MultipleErrors m, MonadState CheckState m) => m ModuleName -unsafeCheckCurrentModule = checkCurrentModule <$> get >>= \case +unsafeCheckCurrentModule = gets checkCurrentModule >>= \case Nothing -> internalError "No module name set in scope" Just name -> pure name From 6ddcad5f386a2fa6683543c992c88350e6bf7d1c Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1325/1580] HLint fix: "Use unwords" --- .hlint.yaml | 1 - src/Language/PureScript/TypeChecker/Monad.hs | 9 ++++----- tests/TestPsci/EvalTest.hs | 2 +- 3 files changed, 5 insertions(+), 7 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index aac198a609..7078c1012f 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -35,7 +35,6 @@ - ignore: {name: "Hoist not"} - ignore: {name: "Functor law"} - ignore: {name: "Redundant fmap"} -- ignore: {name: "Use unwords"} - ignore: {name: "Use fmap"} - ignore: {name: "Avoid lambda using `infix`"} - ignore: {name: "Use const"} diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 76b03b669a..095890a2bc 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -12,7 +12,6 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State import Control.Monad.Writer.Class (MonadWriter(..), censor) -import Data.List (intercalate) import Data.Maybe import qualified Data.Map as M import qualified Data.Set as S @@ -422,7 +421,7 @@ debugTypeSynonyms = fmap go . M.toList . typeSynonyms where go (qual, (binders, subTy)) = do let - vars = intercalate " " $ flip fmap binders $ \case + vars = unwords $ flip fmap binders $ \case (v, Just k) -> "(" <> unpack v <> " :: " <> init (prettyPrintType 100 k) <> ")" (v, Nothing) -> unpack v ppTy = prettyPrintType 100 subTy @@ -440,8 +439,8 @@ debugTypeClassDictionaries = go . typeClassDictionaries moduleName = maybe "" (\m -> "[" <> runModuleName m <> "] ") mbModuleName className' = showQualified runProperName className ident' = showQualified runIdent ident - kds = intercalate " " $ fmap ((\a -> "@(" <> a <> ")") . debugType) $ tcdInstanceKinds $ NEL.head dicts - tys = intercalate " " $ fmap ((\a -> "(" <> a <> ")") . debugType) $ tcdInstanceTypes $ NEL.head dicts + kds = unwords $ fmap ((\a -> "@(" <> a <> ")") . debugType) $ tcdInstanceKinds $ NEL.head dicts + tys = unwords $ fmap ((\a -> "(" <> a <> ")") . debugType) $ tcdInstanceTypes $ NEL.head dicts pure $ "dict " <> unpack moduleName <> unpack className' <> " " <> unpack ident' <> " (" <> show (length dicts) <> ")" <> " " <> kds <> " " <> tys debugTypeClasses :: Environment -> [String] @@ -450,7 +449,7 @@ debugTypeClasses = fmap go . M.toList . typeClasses go (className, tc) = do let className' = showQualified runProperName className - args = intercalate " " $ fmap (\(a, b) -> "(" <> debugType (maybe (srcTypeVar a) (srcKindedType (srcTypeVar a)) b) <> ")") $ typeClassArguments tc + args = unwords $ fmap (\(a, b) -> "(" <> debugType (maybe (srcTypeVar a) (srcKindedType (srcTypeVar a)) b) <> ")") $ typeClassArguments tc "class " <> unpack className' <> " " <> args debugValue :: Expr -> String diff --git a/tests/TestPsci/EvalTest.hs b/tests/TestPsci/EvalTest.hs index 5aae8ab90a..ec54853037 100644 --- a/tests/TestPsci/EvalTest.hs +++ b/tests/TestPsci/EvalTest.hs @@ -46,7 +46,7 @@ parseEvalLine line = case stripPrefix evalCommentPrefix line of Just rest -> case splitOn " " rest of - "shouldEvaluateTo" : args -> Comment (ShouldEvaluateTo $ intercalate " " args) + "shouldEvaluateTo" : args -> Comment (ShouldEvaluateTo $ unwords args) "paste" : [] -> Comment (Paste []) _ -> Invalid line Nothing -> Line line From 0056c8158b580c7f38206b2e46e3e226bc702e9b Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1326/1580] HLint fix: "Use &&" --- .hlint.yaml | 1 - src/Language/PureScript/CodeGen/JS/Common.hs | 8 +++----- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 7078c1012f..0b6e3e3a93 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -23,7 +23,6 @@ - ignore: {name: "Use list literal pattern"} - ignore: {name: "Move brackets to avoid $"} - ignore: {name: "Use section"} -- ignore: {name: "Use &&"} - ignore: {name: "Use <$>"} - ignore: {name: "Use ."} - ignore: {name: "Use :"} diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 09f5a633c5..546d709a44 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -51,11 +51,9 @@ anyNameToJs name -- absolutely necessary. isValidJsIdentifier :: Text -> Bool isValidJsIdentifier s = - and - [ not (T.null s) - , isAlpha (T.head s) - , s == anyNameToJs s - ] + not (T.null s) && + isAlpha (T.head s) && + s == anyNameToJs s -- | Attempts to find a human-readable name for a symbol, if none has been specified returns the -- ordinal value. From 3a00ce3fe8af14acec8d0dcc4fb2ccd7513d1351 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1327/1580] HLint fix: "Use ++" --- .hlint.yaml | 1 - .../PureScript/Publish/ErrorsWarnings.hs | 21 ++++++++----------- 2 files changed, 9 insertions(+), 13 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 0b6e3e3a93..4a0c995ca6 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -30,7 +30,6 @@ - ignore: {name: "Use Just"} - ignore: {name: "Reduce duplication"} - ignore: {name: "Use camelCase"} -- ignore: {name: "Use ++"} - ignore: {name: "Hoist not"} - ignore: {name: "Functor law"} - ignore: {name: "Redundant fmap"} diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 4780ffa73f..300622f6fc 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -174,20 +174,17 @@ displayUserError e = case e of , spacer ] ++ spdxExamples ++ [ spacer - , para $ concat - [ "See https://spdx.org/licenses/ for a full list of licenses. For more " - , "information on SPDX license expressions, see https://spdx.org/ids-how" - ] + , para $ + "See https://spdx.org/licenses/ for a full list of licenses. For more " ++ + "information on SPDX license expressions, see https://spdx.org/ids-how" , spacer - , para $ concat - [ "Note that distributing code without a license means that nobody will " - , "(legally) be able to use it." - ] + , para $ + "Note that distributing code without a license means that nobody will " ++ + "(legally) be able to use it." , spacer - , para $ concat - [ "It is also recommended to add a LICENSE file to the repository, " - , "including your name and the current year, although this is not necessary." - ] + , para $ + "It is also recommended to add a LICENSE file to the repository, " ++ + "including your name and the current year, although this is not necessary." ] InvalidLicense -> vcat $ From a6c1090e1f1e218e5554caea831e47d5f372a25b Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1328/1580] HLint fix: "Use list literal pattern" --- .hlint.yaml | 1 - lib/purescript-cst/src/Language/PureScript/CST/Utils.hs | 2 +- tests/TestPsci/EvalTest.hs | 2 +- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 4a0c995ca6..4029ad2d83 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -20,7 +20,6 @@ - ignore: {name: "Use sortOn"} - ignore: {name: "Redundant $"} - ignore: {name: "Use record patterns"} -- ignore: {name: "Use list literal pattern"} - ignore: {name: "Move brackets to avoid $"} - ignore: {name: "Use section"} - ignore: {name: "Use <$>"} diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs index b9e4b80bc0..0dc3ae1b67 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs @@ -115,7 +115,7 @@ unexpectedToks toRange toCst err old = do separated :: [(SourceToken, a)] -> Separated a separated = go [] where - go accum ((_, a) : []) = Separated a accum + go accum [(_, a)] = Separated a accum go accum (x : xs) = go (x : accum) xs go _ [] = internalError "Separated should not be empty" diff --git a/tests/TestPsci/EvalTest.hs b/tests/TestPsci/EvalTest.hs index ec54853037..171a03fa1b 100644 --- a/tests/TestPsci/EvalTest.hs +++ b/tests/TestPsci/EvalTest.hs @@ -47,7 +47,7 @@ parseEvalLine line = Just rest -> case splitOn " " rest of "shouldEvaluateTo" : args -> Comment (ShouldEvaluateTo $ unwords args) - "paste" : [] -> Comment (Paste []) + ["paste"] -> Comment (Paste []) _ -> Invalid line Nothing -> Line line From 1660ac278d6df13bae7f9580f1c8234d197d0614 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1329/1580] HLint fix: "Use :" --- .hlint.yaml | 1 - src/Language/PureScript/Docs/Render.hs | 3 +-- src/Language/PureScript/Ide/Error.hs | 2 +- src/Language/PureScript/Publish/ErrorsWarnings.hs | 11 +++++------ 4 files changed, 7 insertions(+), 10 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 4029ad2d83..83c042e3c8 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -24,7 +24,6 @@ - ignore: {name: "Use section"} - ignore: {name: "Use <$>"} - ignore: {name: "Use ."} -- ignore: {name: "Use :"} - ignore: {name: "Avoid reverse"} - ignore: {name: "Use Just"} - ignore: {name: "Reduce duplication"} diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 46c2fc7693..a4c0104c47 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -86,8 +86,7 @@ renderChildDeclaration ChildDeclaration{..} = ChildInstance constraints ty -> maybeToList (renderConstraints constraints) ++ [ renderType ty ] ChildDataConstructor args -> - [ dataCtor' cdeclTitle ] - ++ map renderTypeAtom args + dataCtor' cdeclTitle : map renderTypeAtom args ChildTypeClassMember ty -> [ ident' cdeclTitle diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index dfe42f69b6..bdc559f216 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -73,7 +73,7 @@ encodeRebuildErrors = toJSON . map encodeRebuildError . P.runMultipleErrors , complExpandedType = prettyPrintTypeSingleLine ty , complLocation = Nothing , complDocumentation = Nothing - , complExportedFrom = maybe [] (\x -> [x]) mn + , complExportedFrom = toList mn , complDeclarationType = Nothing } fieldCompletion (label, ty) = diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 300622f6fc..83226dedec 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -203,12 +203,11 @@ displayUserError e = case e of do_ = pl "do" "does" dependencies = pl "dependencies" "dependency" in vcat $ - [ para (concat + para (concat [ "The following ", dependencies, " ", do_, " not appear to be " , "installed:" - ]) - ] ++ - bulletedListT runPackageName (NonEmpty.toList pkgs) + ]) : + bulletedListT runPackageName (NonEmpty.toList pkgs) CompileError err -> vcat [ para "Compile error:" @@ -221,8 +220,8 @@ displayUserError e = case e of ) ResolutionsFileError path err -> successivelyIndented $ - [ "Error in resolutions file (" ++ path ++ "):" ] - ++ map T.unpack (displayError D.displayPackageError err) + ("Error in resolutions file (" ++ path ++ "):") : + map T.unpack (displayError D.displayPackageError err) spdxExamples :: [Box] spdxExamples = From b8f180acd5881b5b68c7ab6fc2c16d7e8ff3b352 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:33 -0400 Subject: [PATCH 1330/1580] HLint fix: "Use ." --- .hlint.yaml | 1 - src/Language/PureScript/CoreImp/Optimizer/Inliner.hs | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 83c042e3c8..8863897a5c 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -23,7 +23,6 @@ - ignore: {name: "Move brackets to avoid $"} - ignore: {name: "Use section"} - ignore: {name: "Use <$>"} -- ignore: {name: "Use ."} - ignore: {name: "Avoid reverse"} - ignore: {name: "Use Just"} - ignore: {name: "Reduce duplication"} diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index 6c367e99a0..6016930aff 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -46,7 +46,7 @@ etaConvert = everywhere convert convert :: AST -> AST convert (Block ss [Return _ (App _ (Function _ Nothing idents block@(Block _ body)) args)]) | all shouldInline args && - not (any (`isRebound` block) (map (Var Nothing) idents)) && + not (any ((`isRebound` block) . Var Nothing) idents) && not (any (`isRebound` block) args) = Block ss (map (replaceIdents (zip idents args)) body) convert (Function _ Nothing [] (Block _ [Return _ (App _ fn [])])) = fn From 47caed13e9f223341e513ac9aad8d1d9262e5b1b Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:34 -0400 Subject: [PATCH 1331/1580] HLint fix: "Use Just" --- .hlint.yaml | 1 - src/Language/PureScript/Externs.hs | 7 ++----- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 8863897a5c..6a983b168a 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -24,7 +24,6 @@ - ignore: {name: "Use section"} - ignore: {name: "Use <$>"} - ignore: {name: "Avoid reverse"} -- ignore: {name: "Use Just"} - ignore: {name: "Reduce duplication"} - ignore: {name: "Use camelCase"} - ignore: {name: "Hoist not"} diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index a1a3f53002..13d9543ef7 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -203,17 +203,14 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} fixityDecl :: Declaration -> Maybe ExternsFixity fixityDecl (ValueFixityDeclaration _ (Fixity assoc prec) name op) = - fmap (const (ExternsFixity assoc prec op name)) (find (findOp getValueOpRef op) exps) + fmap (const (ExternsFixity assoc prec op name)) (find ((== Just op) . getValueOpRef) exps) fixityDecl _ = Nothing typeFixityDecl :: Declaration -> Maybe ExternsTypeFixity typeFixityDecl (TypeFixityDeclaration _ (Fixity assoc prec) name op) = - fmap (const (ExternsTypeFixity assoc prec op name)) (find (findOp getTypeOpRef op) exps) + fmap (const (ExternsTypeFixity assoc prec op name)) (find ((== Just op) . getTypeOpRef) exps) typeFixityDecl _ = Nothing - findOp :: (DeclarationRef -> Maybe (OpName a)) -> OpName a -> DeclarationRef -> Bool - findOp g op = maybe False (== op) . g - importDecl :: Declaration -> Maybe ExternsImport importDecl (ImportDeclaration _ m mt qmn) = Just (ExternsImport m mt qmn) importDecl _ = Nothing From dc4244bdeeb11a1a378ee7a40f46f2bbe42a1147 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:34 -0400 Subject: [PATCH 1332/1580] HLint fix: "Hoist not" --- .hlint.yaml | 1 - src/Language/PureScript/Sugar/CaseDeclarations.hs | 2 +- src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- tests/TestCompiler.hs | 2 +- 4 files changed, 3 insertions(+), 4 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 6a983b168a..207e469dc3 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -26,7 +26,6 @@ - ignore: {name: "Avoid reverse"} - ignore: {name: "Reduce duplication"} - ignore: {name: "Use camelCase"} -- ignore: {name: "Hoist not"} - ignore: {name: "Functor law"} - ignore: {name: "Redundant fmap"} - ignore: {name: "Use fmap"} diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 7326ba96d3..aee6536a14 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -58,7 +58,7 @@ desugarGuardedExprs -> Expr -> m Expr desugarGuardedExprs ss (Case scrut alternatives) - | any (not . isTrivialExpr) scrut = do + | not $ all isTrivialExpr scrut = do -- in case the scrutinee is non trivial (e.g. not a Var or Literal) -- we may evaluate the scrutinee more than once when a guard occurs. -- We bind the scrutinee to Vars here to mitigate this case. diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 5afe2dec53..5730c44517 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -690,7 +690,7 @@ checkQuantification ty = go acc _ [] = reverse acc go acc sco ((_, (arg, k)) : rest) - | any (not . flip elem sco) $ freeTypeVariables k = goDeps acc arg rest + | not . all (flip elem sco) $ freeTypeVariables k = goDeps acc arg rest | otherwise = go acc (arg : sco) rest goDeps acc _ [] = acc diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index a762b37a11..06f5a3cf92 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -108,7 +108,7 @@ checkPositioned errs = where guardSpans :: P.ErrorMessage -> Maybe P.ErrorMessage guardSpans err = case P.errorSpan err of - Just ss | any (not . isNonsenseSpan) ss -> Nothing + Just ss | not $ all isNonsenseSpan ss -> Nothing _ -> Just err isNonsenseSpan :: P.SourceSpan -> Bool From 79261d4f735aaf9715857634adc6efece7f81772 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:34 -0400 Subject: [PATCH 1333/1580] HLint fix: "Redundant fmap" --- .hlint.yaml | 1 - src/Language/PureScript/Sugar/Operators/Common.hs | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 207e469dc3..8bd731465f 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -27,7 +27,6 @@ - ignore: {name: "Reduce duplication"} - ignore: {name: "Use camelCase"} - ignore: {name: "Functor law"} -- ignore: {name: "Redundant fmap"} - ignore: {name: "Use fmap"} - ignore: {name: "Avoid lambda using `infix`"} - ignore: {name: "Use const"} diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index 5f1d10fc86..cdc9cbafe6 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -104,9 +104,9 @@ matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains opInfo :: M.Map (Qualified (OpName nameType)) (Integer, Associativity) opInfo = M.fromList $ concatMap (\(n, o) -> map (\(name, assoc) -> (name, (n, assoc))) o) (zip [0..] ops) opPrec :: Qualified (OpName nameType) -> Integer - opPrec = fromJust . fmap fst . flip M.lookup opInfo + opPrec = fst . fromJust . flip M.lookup opInfo opAssoc :: Qualified (OpName nameType) -> Associativity - opAssoc = fromJust . fmap snd . flip M.lookup opInfo + opAssoc = snd . fromJust . flip M.lookup opInfo chainOpSpans :: M.Map (Qualified (OpName nameType)) (NEL.NonEmpty SourceSpan) chainOpSpans = foldr (\(ss, name) -> M.alter (Just . maybe (pure ss) (NEL.cons ss)) name) M.empty . mapMaybe fromOp $ rights chain opUsages :: Qualified (OpName nameType) -> Int From a5b857e2cbd16cde494d35c4934429046cf3a463 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:34 -0400 Subject: [PATCH 1334/1580] HLint fix: "Use sortOn" --- .hlint.yaml | 1 - lib/purescript-ast/src/Language/PureScript/AST/Exported.hs | 4 ++-- lib/purescript-ast/src/Language/PureScript/Types.hs | 5 ++--- lib/purescript-cst/src/Language/PureScript/CST/Monad.hs | 4 ++-- src/Language/PureScript/CoreFn/Desugar.hs | 4 ++-- src/Language/PureScript/Errors.hs | 5 ++--- src/Language/PureScript/Ide/Matcher.hs | 2 +- src/Language/PureScript/Linter/Exhaustive.hs | 5 ++--- src/Language/PureScript/Linter/Imports.hs | 4 ++-- src/Language/PureScript/Make.hs | 4 ++-- src/Language/PureScript/Sugar/Names.hs | 4 ++-- src/Language/PureScript/Sugar/Names/Env.hs | 4 ++-- src/Language/PureScript/Sugar/Names/Exports.hs | 4 ++-- src/Language/PureScript/Sugar/Operators.hs | 7 ++++--- src/Language/PureScript/Sugar/TypeClasses/Deriving.hs | 7 +++---- src/Language/PureScript/TypeChecker/Entailment.hs | 4 ++-- src/Language/PureScript/TypeChecker/Kinds.hs | 5 ++--- 17 files changed, 34 insertions(+), 39 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 8bd731465f..5e282004d8 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -17,7 +17,6 @@ - ignore: {name: "Use lambda-case"} - ignore: {name: "Avoid lambda"} - ignore: {name: "Use tuple-section"} -- ignore: {name: "Use sortOn"} - ignore: {name: "Redundant $"} - ignore: {name: "Use record patterns"} - ignore: {name: "Move brackets to avoid $"} diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Exported.hs b/lib/purescript-ast/src/Language/PureScript/AST/Exported.hs index 9cf015e0bc..60c860cf8d 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Exported.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Exported.hs @@ -4,7 +4,7 @@ module Language.PureScript.AST.Exported ) where import Prelude.Compat -import Protolude (sortBy, on) +import Protolude (sortOn) import Control.Category ((>>>)) @@ -148,7 +148,7 @@ isDctorExported ident (Just exps) ctor = test `any` exps -- reorder :: [DeclarationRef] -> [Declaration] -> [Declaration] reorder refs = - sortBy (compare `on` refIndex) + sortOn refIndex where refIndices = M.fromList $ zip (map declRefName refs) [(0::Int)..] diff --git a/lib/purescript-ast/src/Language/PureScript/Types.hs b/lib/purescript-ast/src/Language/PureScript/Types.hs index d7ee1315da..019f0bbe89 100644 --- a/lib/purescript-ast/src/Language/PureScript/Types.hs +++ b/lib/purescript-ast/src/Language/PureScript/Types.hs @@ -16,8 +16,7 @@ import qualified Data.Aeson as A import qualified Data.Aeson.Types as A import Data.Foldable (fold) import qualified Data.IntSet as IS -import Data.List (sort, sortBy) -import Data.Ord (comparing) +import Data.List (sort, sortOn) import Data.Maybe (fromMaybe, isJust) import qualified Data.Set as S import Data.Text (Text) @@ -413,7 +412,7 @@ rowToList = go where -- | Convert a row to a list of pairs of labels and types, sorted by the labels. rowToSortedList :: Type a -> ([RowListItem a], Type a) -rowToSortedList = first (sortBy (comparing rowListLabel)) . rowToList +rowToSortedList = first (sortOn rowListLabel) . rowToList -- | Convert a list of labels and types to a row rowFromList :: ([RowListItem a], Type a) -> Type a diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs b/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs index e123738d2e..0ffb1c2aa2 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs @@ -2,7 +2,7 @@ module Language.PureScript.CST.Monad where import Prelude -import Data.List (sortBy) +import Data.List (sortOn) import qualified Data.List.NonEmpty as NE import Data.Ord (comparing) import Data.Text (Text) @@ -66,7 +66,7 @@ runParser st (Parser k) = k st left right right st'@(ParserState {..}) res | null parserErrors = (st', Right res) - | otherwise = (st', Left $ NE.fromList $ sortBy (comparing errRange) parserErrors) + | otherwise = (st', Left $ NE.fromList $ sortOn errRange parserErrors) runTokenParser :: Parser a -> [LexResult] -> Either (NE.NonEmpty ParserError) ([ParserWarning], a) runTokenParser p buff = fmap (warnings,) res diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 0285fa2792..1723d87d4e 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -6,7 +6,7 @@ import Protolude (ordNub) import Control.Arrow (second) import Data.Function (on) -import Data.List (sort, sortBy) +import Data.List (sort, sortOn) import Data.Maybe (mapMaybe) import Data.Tuple (swap) import qualified Data.List.NonEmpty as NEL @@ -120,7 +120,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal _ (A.ObjectLiteral _)) _)) = exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name lit) exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal _ (A.ObjectLiteral vs))) = - let args = fmap (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs + let args = fmap (exprToCoreFn ss [] Nothing . snd) $ sortOn fst vs ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name) in foldl (App (ss, com, Nothing, Nothing)) ctor args exprToCoreFn ss com ty (A.TypeClassDictionaryAccessor _ ident) = diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 82e1118a59..8d3e428ce2 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -16,11 +16,10 @@ import Data.Char (isSpace) import Data.Either (partitionEithers) import Data.Foldable (fold) import Data.Functor.Identity (Identity(..)) -import Data.List (transpose, nubBy, partition, dropWhileEnd, sort, sortBy) +import Data.List (transpose, nubBy, partition, dropWhileEnd, sort, sortOn) import qualified Data.List.NonEmpty as NEL import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import qualified Data.Map as M -import Data.Ord (comparing) import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text) @@ -1529,7 +1528,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl -- Keep the unique labels only filterRows :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Type a, Type a) filterRows (s1, r1) (s2, r2) = - let sort' = sortBy (comparing $ \(RowListItem _ name ty) -> (name, ty)) + let sort' = sortOn $ \(RowListItem _ name ty) -> (name, ty) notElem' s (RowListItem _ name ty) = all (\(RowListItem _ name' ty') -> name /= name' || not (eqType ty ty')) s unique1 = filter (notElem' s2) s1 unique2 = filter (notElem' s1) s2 diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index 30369796a3..40b8283a02 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -80,7 +80,7 @@ runMatcher :: Matcher a -> [Match a] -> [Match a] runMatcher (Matcher m)= appEndo m sortCompletions :: [ScoredMatch a] -> [ScoredMatch a] -sortCompletions = sortBy (flip compare `on` snd) +sortCompletions = sortOn (Down . snd) flexMatch :: Text -> [Match IdeDeclarationAnn] -> [ScoredMatch IdeDeclarationAnn] flexMatch = mapMaybe . flexRate diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index e8ab59fde8..0bd0ddea0a 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -17,8 +17,7 @@ import Control.Monad (unless) import Control.Monad.Writer.Class import Control.Monad.Supply.Class (MonadSupply, fresh, freshName) -import Data.Function (on) -import Data.List (foldl', sortBy) +import Data.List (foldl', sortOn) import Data.Maybe (fromMaybe) import qualified Data.Map as M import Data.Text (Text) @@ -133,7 +132,7 @@ missingCasesSingle env mn (LiteralBinder _ (ObjectLiteral bs)) (LiteralBinder ss where (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders) - sortNames = sortBy (compare `on` fst) + sortNames = sortOn fst (sbs, sbs') = (sortNames bs, sortNames bs') diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index b4d25ba011..6fa297b2c2 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -12,7 +12,7 @@ import Control.Monad.Writer.Class import Data.Function (on) import Data.Foldable (for_) -import Data.List (find, intersect, groupBy, sort, sortBy, (\\)) +import Data.List (find, intersect, groupBy, sort, sortOn, (\\)) import Data.Maybe (mapMaybe) import Data.Monoid (Sum(..)) import Data.Traversable (forM) @@ -94,7 +94,7 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do . map tail . filter ((> 1) . length) . groupBy ((==) `on` defQual) - . sortBy (compare `on` defQual) + . sortOn defQual $ unwarned for_ duplicates $ \(pos, _, _) -> diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index b481b11791..a8df3cfea6 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -21,7 +21,7 @@ import Control.Monad.Writer.Class (MonadWriter(..), censor) import Control.Monad.Writer.Strict (runWriterT) import Data.Function (on) import Data.Foldable (fold, for_) -import Data.List (foldl', sortBy) +import Data.List (foldl', sortOn) import qualified Data.List.NonEmpty as NEL import Data.Maybe (fromMaybe) import qualified Data.Map as M @@ -199,7 +199,7 @@ make ma@MakeActions{..} ms = do -- Find all groups of duplicate values in a list based on a projection. findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [NEL.NonEmpty a] findDuplicates f xs = - case filter ((> 1) . length) . NEL.groupBy ((==) `on` f) . sortBy (compare `on` f) $ xs of + case filter ((> 1) . length) . NEL.groupBy ((==) `on` f) . sortOn f $ xs of [] -> Nothing xss -> Just xss diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 913b37d8e9..b8676d5db1 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -10,7 +10,7 @@ module Language.PureScript.Sugar.Names ) where import Prelude.Compat -import Protolude (ordNub, sortBy, on) +import Protolude (ordNub, sortOn) import Control.Arrow (first, second) import Control.Monad @@ -149,7 +149,7 @@ elaborateExports exps (Module ss coms mn decls refs) = -- their order in the source file. reorderExports :: [Declaration] -> Maybe [DeclarationRef] -> [DeclarationRef] -> [DeclarationRef] reorderExports decls originalRefs = - sortBy (compare `on` originalIndex) + sortOn originalIndex where names = maybe (mapMaybe declName decls) (map declRefName) originalRefs diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 4471b13923..96d5cfda80 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -29,7 +29,7 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Function (on) import Data.Foldable (find) -import Data.List (groupBy, sortBy, delete) +import Data.List (groupBy, sortOn, delete) import Data.Maybe (fromJust, mapMaybe) import Safe (headMay) import qualified Data.Map as M @@ -490,7 +490,7 @@ checkImportConflicts -> m (ModuleName, ModuleName) checkImportConflicts ss currentModule toName xs = let - byOrig = sortBy (compare `on` importSourceModule) xs + byOrig = sortOn importSourceModule xs groups = groupBy ((==) `on` importSourceModule) byOrig nonImplicit = filter ((/= FromImplicit) . importProvenance) xs name = toName . disqualify . importName $ head xs diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index c0236f05b9..83f4934008 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -11,7 +11,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Data.Function (on) import Data.Foldable (traverse_) -import Data.List (intersect, groupBy, sortBy) +import Data.List (intersect, groupBy, sortOn) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M @@ -256,7 +256,7 @@ filterModule mn exps refs = do = fmap (\(ss', (tc, dcs)) -> TypeRef ss' tc dcs) . fmap (foldr1 $ \(ss, (tc, dcs1)) (_, (_, dcs2)) -> (ss, (tc, liftM2 (++) dcs1 dcs2))) . groupBy ((==) `on` (fst . snd)) - . sortBy (compare `on` (fst . snd)) + . sortOn (fst . snd) . mapMaybe (\ref -> (declRefSourceSpan ref,) <$> getTypeRef ref) filterTypes diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index bc6e205744..8103e6c13e 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -33,9 +33,10 @@ import Data.Foldable (for_, traverse_) import Data.Function (on) import Data.Functor (($>)) import Data.Functor.Identity (Identity(..), runIdentity) -import Data.List (groupBy, sortBy) +import Data.List (groupBy, sortOn) import Data.Maybe (mapMaybe, listToMaybe) import qualified Data.Map as M +import Data.Ord (Down(..)) import qualified Language.PureScript.Constants.Prelude as C @@ -278,7 +279,7 @@ ensureNoDuplicates => (a -> SimpleErrorMessage) -> [(Qualified a, SourceSpan)] -> m () -ensureNoDuplicates toError m = go $ sortBy (compare `on` fst) m +ensureNoDuplicates toError m = go $ sortOn fst m where go [] = return () go [_] = return () @@ -293,7 +294,7 @@ customOperatorTable customOperatorTable fixities = let userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities - sorted = sortBy (flip compare `on` (\(_, p, _) -> p)) userOps + sorted = sortOn (Down . (\(_, p, _) -> p)) userOps groups = groupBy ((==) `on` (\(_, p, _) -> p)) sorted in map (map (\(name, _, a) -> (name, a))) groups diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index c0f6c0ee9b..7249cdcc16 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -10,10 +10,9 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Supply.Class (MonadSupply) import Data.Foldable (for_) -import Data.List (foldl', find, sortBy, unzip5) +import Data.List (foldl', find, sortOn, unzip5) import qualified Data.Map as M import Data.Maybe (fromMaybe) -import Data.Ord (comparing) import qualified Data.Set as S import Data.Text (Text) import Language.PureScript.AST @@ -616,13 +615,13 @@ objectType (TypeApp _ (TypeConstructor _ Prim.Record) rec) = Just rec objectType _ = Nothing decomposeRec :: SourceType -> Maybe [(Label, SourceType)] -decomposeRec = fmap (sortBy (comparing fst)) . go +decomposeRec = fmap (sortOn fst) . go where go (RCons _ str typ typs) = fmap ((str, typ) :) (go typs) go (REmptyKinded _ _) = Just [] go _ = Nothing decomposeRec' :: SourceType -> [(Label, SourceType)] -decomposeRec' = sortBy (comparing fst) . go +decomposeRec' = sortOn fst . go where go (RCons _ str typ typs) = (str, typ) : go typs go _ = [] diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index b1127a07d0..26c9a0c3b0 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -21,7 +21,7 @@ import Control.Monad.Writer import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.Functor (($>)) -import Data.List (findIndices, minimumBy, groupBy, nubBy, sortBy) +import Data.List (findIndices, minimumBy, groupBy, nubBy, sortOn) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -231,7 +231,7 @@ entails SolverOptions{..} constraint context hints = let instances = do chain <- groupBy ((==) `on` tcdChain) $ - sortBy (compare `on` (tcdChain &&& tcdIndex)) $ + sortOn (tcdChain &&& tcdIndex) $ dicts -- process instances in a chain in index order let found = for chain $ \tcd -> diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 5730c44517..86540fa24f 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -39,10 +39,9 @@ import Data.Foldable (for_, traverse_) import Data.Function (on) import Data.Functor (($>)) import qualified Data.IntSet as IS -import Data.List (nubBy, sortBy, (\\)) +import Data.List (nubBy, sortOn, (\\)) import qualified Data.Map as M import Data.Maybe (fromJust, fromMaybe) -import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T import Data.Traversable (for) @@ -147,7 +146,7 @@ unknownsWithKinds :: forall m. (MonadState CheckState m, MonadError MultipleErrors m, HasCallStack) => [Unknown] -> m [(Unknown, SourceType)] -unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortBy (comparing fst) . join) . traverse go +unknownsWithKinds = fmap (fmap snd . nubBy ((==) `on` fst) . sortOn fst . join) . traverse go where go u = do (lvl, ty) <- traverse apply =<< lookupUnsolved u From e32a66566d264b01bf5c349e1f16f9ebc60b8588 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:34 -0400 Subject: [PATCH 1335/1580] HLint fix: "Avoid reverse" --- .hlint.yaml | 1 - src/Language/PureScript/Errors.hs | 6 +++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 5e282004d8..8ace716db6 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -22,7 +22,6 @@ - ignore: {name: "Move brackets to avoid $"} - ignore: {name: "Use section"} - ignore: {name: "Use <$>"} -- ignore: {name: "Avoid reverse"} - ignore: {name: "Reduce duplication"} - ignore: {name: "Use camelCase"} - ignore: {name: "Functor law"} diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8d3e428ce2..a7d82f7fb9 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -16,10 +16,11 @@ import Data.Char (isSpace) import Data.Either (partitionEithers) import Data.Foldable (fold) import Data.Functor.Identity (Identity(..)) -import Data.List (transpose, nubBy, partition, dropWhileEnd, sort, sortOn) +import Data.List (transpose, nubBy, partition, dropWhileEnd, sortOn) import qualified Data.List.NonEmpty as NEL import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import qualified Data.Map as M +import Data.Ord (Down(..)) import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text) @@ -377,8 +378,7 @@ errorMessage''' :: [SourceSpan] -> SimpleErrorMessage -> MultipleErrors errorMessage''' sss err = maybe (errorMessage err) (flip errorMessage'' err) . NEL.nonEmpty - . reverse - . sort + . sortOn Down $ filter (/= NullSourceSpan) sss -- | Create an error set from a single error message From 1e28933ae8fdc28464f3b1062e4418d034cfa8b0 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:34 -0400 Subject: [PATCH 1336/1580] HLint fix: "Redundant bracket" --- .hlint.yaml | 1 - app/Command/Ide.hs | 2 +- .../src/Language/PureScript/Environment.hs | 2 +- .../src/Language/PureScript/Types.hs | 4 +-- .../src/Language/PureScript/CST/Convert.hs | 2 +- .../src/Language/PureScript/CST/Errors.hs | 6 ++--- .../src/Language/PureScript/CST/Lexer.hs | 4 +-- .../src/Language/PureScript/CST/Monad.hs | 6 ++--- .../src/Language/PureScript/CST/Positions.hs | 6 ++--- .../src/Language/PureScript/CST/Utils.hs | 4 +-- license-generator/generate.hs | 2 +- src/Language/PureScript/Bundle.hs | 2 +- .../PureScript/CoreImp/Optimizer/Inliner.hs | 2 +- .../PureScript/CoreImp/Optimizer/TCO.hs | 4 +-- src/Language/PureScript/Docs/Collect.hs | 4 +-- src/Language/PureScript/Docs/Convert.hs | 4 +-- .../PureScript/Docs/Convert/ReExports.hs | 2 +- src/Language/PureScript/Docs/Types.hs | 2 +- src/Language/PureScript/Errors.hs | 10 +++---- src/Language/PureScript/Ide.hs | 2 +- src/Language/PureScript/Ide/Command.hs | 2 +- src/Language/PureScript/Ide/Error.hs | 6 ++--- src/Language/PureScript/Ide/Types.hs | 2 +- src/Language/PureScript/Interactive/Module.hs | 2 +- .../PureScript/Interactive/Printer.hs | 2 +- src/Language/PureScript/Pretty/Types.hs | 2 +- src/Language/PureScript/Pretty/Values.hs | 2 +- src/Language/PureScript/Publish.hs | 2 +- .../PureScript/Sugar/CaseDeclarations.hs | 2 +- src/Language/PureScript/Sugar/Names/Common.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 10 +++---- .../PureScript/Sugar/TypeDeclarations.hs | 8 +++--- src/Language/PureScript/TypeChecker.hs | 16 ++++++------ src/Language/PureScript/TypeChecker/Types.hs | 2 +- .../Language/PureScript/Ide/CompletionSpec.hs | 26 +++++++++---------- tests/Language/PureScript/Ide/ImportsSpec.hs | 6 ++--- tests/Language/PureScript/Ide/RebuildSpec.hs | 4 +-- .../Language/PureScript/Ide/SourceFileSpec.hs | 2 +- tests/Language/PureScript/Ide/Test.hs | 4 +-- tests/TestPrimDocs.hs | 4 +-- tests/TestPsci/CommandTest.hs | 2 +- 42 files changed, 90 insertions(+), 91 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 8ace716db6..9145916a93 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -10,7 +10,6 @@ - ignore: {name: "Use infix"} - ignore: {name: "Redundant do"} - ignore: {name: "Use newtype instead of data"} -- ignore: {name: "Redundant bracket"} - ignore: {name: "Use join"} - ignore: {name: "Fuse foldr/map"} - ignore: {name: "Eta reduce"} diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index 00b275993e..5da186a7c0 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -221,7 +221,7 @@ catchGoneHandle :: IO () -> IO () catchGoneHandle = handle (\e -> case e of IOError { ioe_type = ResourceVanished } -> - putText ("[Error] psc-ide-server tried to interact with the handle, but the connection was already gone.") + putText "[Error] psc-ide-server tried to interact with the handle, but the connection was already gone." _ -> throwIO e) acceptCommand diff --git a/lib/purescript-ast/src/Language/PureScript/Environment.hs b/lib/purescript-ast/src/Language/PureScript/Environment.hs index 1018cd1dab..2eaacefa8c 100644 --- a/lib/purescript-ast/src/Language/PureScript/Environment.hs +++ b/lib/purescript-ast/src/Language/PureScript/Environment.hs @@ -468,7 +468,7 @@ primTypeErrorTypes = primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses = M.fromList - [ (primName "Partial", (makeTypeClassData [] [] [] [] True)) + [ (primName "Partial", makeTypeClassData [] [] [] [] True) ] -- | This contains all of the type classes from all Prim modules. diff --git a/lib/purescript-ast/src/Language/PureScript/Types.hs b/lib/purescript-ast/src/Language/PureScript/Types.hs index 019f0bbe89..9c55a59b6e 100644 --- a/lib/purescript-ast/src/Language/PureScript/Types.hs +++ b/lib/purescript-ast/src/Language/PureScript/Types.hs @@ -210,7 +210,7 @@ constraintDataToJSON (PartialConstraintData bs trunc) = ] constraintToJSON :: (a -> A.Value) -> Constraint a -> A.Value -constraintToJSON annToJSON (Constraint {..}) = +constraintToJSON annToJSON Constraint {..} = A.object [ "constraintAnn" .= annToJSON constraintAnn , "constraintClass" .= constraintClass @@ -642,7 +642,7 @@ everywhereOnTypesTopDownM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (T everywhereOnTypesTopDownM f = go <=< f where go (TypeApp ann t1 t2) = TypeApp ann <$> (f t1 >>= go) <*> (f t2 >>= go) go (KindApp ann t1 t2) = KindApp ann <$> (f t1 >>= go) <*> (f t2 >>= go) - go (ForAll ann arg mbK ty sco) = ForAll ann arg <$> (traverse (f >=> go) mbK) <*> (f ty >>= go) <*> pure sco + go (ForAll ann arg mbK ty sco) = ForAll ann arg <$> traverse (f >=> go) mbK <*> (f ty >>= go) <*> pure sco go (ConstrainedType ann c ty) = ConstrainedType ann <$> overConstraintArgsAll (mapM (go <=< f)) c <*> (f ty >>= go) go (RCons ann name ty rest) = RCons ann name <$> (f ty >>= go) <*> (f rest >>= go) go (KindedType ann ty k) = KindedType ann <$> (f ty >>= go) <*> (f k >>= go) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs index 3c2202225f..69dfb58fae 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs @@ -614,7 +614,7 @@ convertImportDecl fileName decl@(ImportDecl _ _ modName mbNames mbQual) = do ann = uncurry (sourceAnnCommented fileName) $ importDeclRange decl importTy = case mbNames of Nothing -> AST.Implicit - Just (hiding, (Wrapped _ imps _)) -> do + Just (hiding, Wrapped _ imps _) -> do let imps' = convertImport fileName <$> toList imps if isJust hiding then AST.Hiding imps' diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs b/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs index 1f9784bb62..4e7db9dfa8 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs @@ -76,7 +76,7 @@ type ParserError = ParserErrorInfo ParserErrorType type ParserWarning = ParserErrorInfo ParserWarningType prettyPrintError :: ParserError -> String -prettyPrintError pe@(ParserErrorInfo { errRange }) = +prettyPrintError pe@ParserErrorInfo { errRange } = prettyPrintErrorMessage pe <> " at " <> errPos where errPos = case errRange of @@ -84,7 +84,7 @@ prettyPrintError pe@(ParserErrorInfo { errRange }) = "line " <> show line <> ", column " <> show col prettyPrintErrorMessage :: ParserError -> String -prettyPrintErrorMessage (ParserErrorInfo {..}) = case errType of +prettyPrintErrorMessage ParserErrorInfo {..} = case errType of ErrWildcardInType -> "Unexpected wildcard in type; type wildcards are only allowed in value annotations" ErrConstraintInKind -> @@ -182,7 +182,7 @@ prettyPrintErrorMessage (ParserErrorInfo {..}) = case errType of "U+" <> map toUpper (printf "%0.4x" (fromEnum x)) prettyPrintWarningMessage :: ParserWarning -> String -prettyPrintWarningMessage (ParserErrorInfo {..}) = case errType of +prettyPrintWarningMessage ParserErrorInfo {..} = case errType of WarnDeprecatedRowSyntax -> "Unary '#' syntax for row kinds is deprecated and will be removed in a future release. Use the 'Row' kind instead." WarnDeprecatedForeignKindSyntax -> diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs index e35d0b1b45..1ef436d29a 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs @@ -70,7 +70,7 @@ lexWithState = go Parser lexK = tokenAndComments - go state@(LexState {..}) = + go state@LexState {..} = lexK lexSource onError onSuccess where onError lexSource' err = do @@ -653,7 +653,7 @@ digitsToInteger :: String -> Integer digitsToInteger = digitsToIntegerBase 10 digitsToIntegerBase :: Integer -> String -> Integer -digitsToIntegerBase b = foldl' (\n c -> n * b + (toInteger (Char.digitToInt c))) 0 +digitsToIntegerBase b = foldl' (\n c -> n * b + toInteger (Char.digitToInt c)) 0 digitsToScientific :: String -> String -> (Integer, Int) digitsToScientific = go 0 . reverse diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs b/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs index 0ffb1c2aa2..79beab2306 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs @@ -61,10 +61,10 @@ instance Monad (ParserM e s) where runParser :: ParserState -> Parser a -> (ParserState, Either (NE.NonEmpty ParserError) a) runParser st (Parser k) = k st left right where - left st'@(ParserState {..}) err = + left st'@ParserState {..} err = (st', Left $ NE.sortBy (comparing errRange) $ err NE.:| parserErrors) - right st'@(ParserState {..}) res + right st'@ParserState {..} res | null parserErrors = (st', Right res) | otherwise = (st', Left $ NE.fromList $ sortOn errRange parserErrors) @@ -179,7 +179,7 @@ token t = do else parseError t' munch :: Parser SourceToken -munch = Parser $ \state@(ParserState {..}) kerr ksucc -> +munch = Parser $ \state@ParserState {..} kerr ksucc -> case parserBuff of Right tok : parserBuff' -> ksucc (state { parserBuff = parserBuff' }) tok diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs index e5a1abe1cd..196254e7cf 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs @@ -118,10 +118,10 @@ labelRange :: Label -> TokenRange labelRange a = (lblTok a, lblTok a) wrappedRange :: Wrapped a -> TokenRange -wrappedRange (Wrapped { wrpOpen, wrpClose }) = (wrpOpen, wrpClose) +wrappedRange Wrapped { wrpOpen, wrpClose } = (wrpOpen, wrpClose) moduleRange :: Module a -> TokenRange -moduleRange (Module { modKeyword, modWhere, modImports, modDecls }) = +moduleRange Module { modKeyword, modWhere, modImports, modDecls } = case (modImports, modDecls) of ([], []) -> (modKeyword, modWhere) (is, []) -> (modKeyword, snd . importDeclRange $ last is) @@ -140,7 +140,7 @@ exportRange = \case ExportModule _ a b -> (a, nameTok b) importDeclRange :: ImportDecl a -> TokenRange -importDeclRange (ImportDecl { impKeyword, impModule, impNames, impQual }) +importDeclRange ImportDecl { impKeyword, impModule, impNames, impQual } | Just (_, modName) <- impQual = (impKeyword, nameTok modName) | Just (_, imports) <- impNames = (impKeyword, wrpClose imports) | otherwise = (impKeyword, nameTok impModule) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs index 0dc3ae1b67..9128b00f26 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs @@ -120,7 +120,7 @@ separated = go [] go _ [] = internalError "Separated should not be empty" consSeparated :: a -> SourceToken -> Separated a -> Separated a -consSeparated x sep (Separated {..}) = Separated x ((sep, sepHead) : sepTail) +consSeparated x sep Separated {..} = Separated x ((sep, sepHead) : sepTail) internalError :: String -> a internalError = error . ("Internal parser error: " <>) @@ -232,7 +232,7 @@ toBinderConstructor = \case BinderConstructor a name [] NE.:| bs -> pure $ BinderConstructor a name bs a NE.:| [] -> pure a - a NE.:| _ -> unexpectedToks binderRange (unexpectedBinder) ErrExprInBinder a + a NE.:| _ -> unexpectedToks binderRange unexpectedBinder ErrExprInBinder a toRecordFields :: Monoid a diff --git a/license-generator/generate.hs b/license-generator/generate.hs index 5439db6775..817d39c715 100644 --- a/license-generator/generate.hs +++ b/license-generator/generate.hs @@ -159,7 +159,7 @@ downloadFromHackage urlpath manager dep = do resp <- httpLbs req manager let status = responseStatus resp - if (status /= ok200) + if status /= ok200 then do hPutStrLn stderr $ "Bad status code for " ++ url hPutStrLn stderr $ "Expected 200, got " ++ show status diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 682f56a297..3fe486fd10 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -650,7 +650,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o map (\(porig, pgen) -> Mapping { mapOriginal = Just (Pos (fromIntegral $ porig + 1) 0) , mapSourceFile = pathToFile <$> file - , mapGenerated = (Pos (fromIntegral $ pos + pgen) 0) + , mapGenerated = Pos (fromIntegral $ pos + pgen) 0 , mapName = Nothing }) (offsets (0,0) (Right 1 : positions))) diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index 6016930aff..206eaec448 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -284,7 +284,7 @@ inlineFnComposition = everywhereTopDownM convert where goApps (App _ (App _ (App _ fn [dict']) [x]) [y]) | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x - goApps app@(App {}) = pure . Right . (,app) <$> freshName + goApps app@App {} = pure . Right . (,app) <$> freshName goApps other = pure [Left other] isFnCompose :: AST -> AST -> Bool diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index 6cc028db7a..e1356b6d7c 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -83,7 +83,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where case S.minView required of Just (r, required') -> do required'' <- findTailPositionDeps r js - go (S.insert (fst r) known, required' <> (S.filter (not . (`S.member` known) . fst) required'')) + go (S.insert (fst r) known, required' <> S.filter (not . (`S.member` known) . fst) required'') Nothing -> pure known @@ -168,7 +168,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where , Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]) , While rootSS (Unary rootSS Not (Var rootSS tcoDone)) (Block rootSS - [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))]) + [Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) (map (Var rootSS . tcoVar) outerArgs ++ map (Var rootSS . copyVar) innerArgs))]) , Return rootSS (Var rootSS tcoResult) ] where diff --git a/src/Language/PureScript/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs index 2c64384d61..ef84d4bc1b 100644 --- a/src/Language/PureScript/Docs/Collect.hs +++ b/src/Language/PureScript/Docs/Collect.hs @@ -59,7 +59,7 @@ collectDocs outputDir inputFiles depsFiles = do addReExports withPackage docsModules externs docsModules <- go modulePaths - pure ((filter (shouldKeep . modName . snd) docsModules), modulesDeps) + pure (filter (shouldKeep . modName . snd) docsModules, modulesDeps) where packageDiscriminators modulesDeps = @@ -226,4 +226,4 @@ getModulePackageInfo inputFiles depsFiles = do InPackage FilePath -> m (InPackage FilePath, Text) readFileAs fi = - liftIO . fmap ((fi,)) $ readUTF8FileT (ignorePackage fi) + liftIO . fmap (fi,) $ readUTF8FileT (ignorePackage fi) diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index e108509a7c..a91440d07c 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -50,7 +50,7 @@ insertValueTypes :: insertValueTypes env m = m { modDeclarations = map go (modDeclarations m) } where - go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard{} }) = + go d@Declaration { declInfo = ValueDeclaration P.TypeWildcard{} } = let ident = P.Ident . CST.getIdent . CST.nameValue . parseIdent $ declTitle d ty = lookupName ident @@ -100,5 +100,5 @@ partiallyDesugar externs env = evalSupplyT 0 . desugar' >=> fmap fst . runWriterT . flip evalStateT (env, mempty) . P.desugarImports >=> P.rebracketFiltered isInstanceDecl externs - isInstanceDecl (P.TypeInstanceDeclaration {}) = True + isInstanceDecl P.TypeInstanceDeclaration {} = True isInstanceDecl _ = False diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index d465982bcd..462f515bd4 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -99,7 +99,7 @@ getReExports externsEnv mn = case Map.lookup mn externsEnv of Nothing -> internalError ("Module missing: " ++ T.unpack (P.runModuleName mn)) - Just (P.ExternsFile { P.efExports = refs }) -> do + Just P.ExternsFile { P.efExports = refs } -> do let reExpRefs = mapMaybe toReExportRef refs runReaderT (collectDeclarations reExpRefs) mn diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 4359abdcfd..2f38bec48e 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -688,7 +688,7 @@ asQualifiedProperName = fromAesonParser asQualifiedIdent :: Parse e (P.Qualified P.Ident) asQualifiedIdent = fromAesonParser -asSourceAnn :: Parse e (P.SourceAnn) +asSourceAnn :: Parse e P.SourceAnn asSourceAnn = fromAesonParser asModuleMap :: Parse PackageError (Map P.ModuleName PackageName) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index a7d82f7fb9..3cdc54cc9a 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -788,20 +788,20 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl [] -> pure . line $ "A cycle appears in a set of type synonym definitions." [pn] -> pure . line $ "A cycle appears in the definition of type synonym " <> markCode (runProperName pn) _ -> [ line " A cycle appears in a set of type synonym definitions:" - , indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName) names)) <> "}" + , indent $ line $ "{" <> T.intercalate ", " (map (markCode . runProperName) names) <> "}" ] renderSimpleErrorMessage (CycleInTypeClassDeclaration [name]) = paras [ line $ "A type class '" <> markCode (runProperName (disqualify name)) <> "' may not have itself as a superclass." ] renderSimpleErrorMessage (CycleInTypeClassDeclaration names) = paras [ line $ "A cycle appears in a set of type class definitions:" - , indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName . disqualify) names)) <> "}" + , indent $ line $ "{" <> T.intercalate ", " (map (markCode . runProperName . disqualify) names) <> "}" , line "Cycles are disallowed because they can lead to loops in the type checker." ] renderSimpleErrorMessage (CycleInKindDeclaration [name]) = paras [ line $ "A kind declaration '" <> markCode (runProperName (disqualify name)) <> "' may not refer to itself in its own signature." ] renderSimpleErrorMessage (CycleInKindDeclaration names) = paras [ line $ "A cycle appears in a set of kind declarations:" - , indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName . disqualify) names)) <> "}" + , indent $ line $ "{" <> T.intercalate ", " (map (markCode . runProperName . disqualify) names) <> "}" , line "Kind declarations may not refer to themselves in their own signatures." ] renderSimpleErrorMessage (NameIsUndefined ident) = @@ -1031,7 +1031,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] where modulesToList = S.toList $ S.delete (moduleNameFromString "Prim") nonOrphanModules - formattedModules = T.intercalate " or " ((markCode . runModuleName) <$> modulesToList) + formattedModules = T.intercalate " or " (markCode . runModuleName <$> modulesToList) renderSimpleErrorMessage (InvalidNewtype name) = paras [ line $ "Newtype " <> markCode (runProperName name) <> " is invalid." , line "Newtypes must define a single constructor with a single argument." @@ -1077,7 +1077,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl let maxTSResults = 15 tsResult = case ts of - Just (TSAfter{tsAfterIdentifiers=idents}) | not (null idents) -> + Just TSAfter{tsAfterIdentifiers=idents} | not (null idents) -> let formatTS (names, types) = let diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 383e80fd56..cf56b4d8b4 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -160,7 +160,7 @@ findAvailableExterns :: (Ide m, MonadError IdeError m) => m [P.ModuleName] findAvailableExterns = do oDir <- outputDirectory unlessM (liftIO (doesDirectoryExist oDir)) - (throwError (GeneralError $ "Couldn't locate your output directory at: " <> (T.pack (normalise oDir)))) + (throwError (GeneralError $ "Couldn't locate your output directory at: " <> T.pack (normalise oDir))) liftIO $ do directories <- getDirectoryContents oDir moduleNames <- filterM (containsExterns oDir) directories diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 4f858e6852..185474f11e 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -160,7 +160,7 @@ instance FromJSON Command where "usages" -> do params <- o .: "params" FindUsages - <$> (map P.moduleNameFromString (params .: "module")) + <$> map P.moduleNameFromString (params .: "module") <*> params .: "identifier" <*> params .: "namespace" "import" -> do diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index bdc559f216..60f17b9f55 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -52,7 +52,7 @@ encodeRebuildErrors = toJSON . map encodeRebuildError . P.runMultipleErrors encodeRebuildError err = case err of (P.ErrorMessage _ ((P.HoleInferredType name _ _ - (Just (P.TSAfter{tsAfterIdentifiers=idents, tsAfterRecordFields=fields}))))) -> + (Just P.TSAfter{tsAfterIdentifiers=idents, tsAfterRecordFields=fields})))) -> insertTSCompletions name idents (fromMaybe [] fields) (toJSON (toJSONError False P.Error err)) _ -> (toJSON . toJSONError False P.Error) err @@ -61,7 +61,7 @@ encodeRebuildErrors = toJSON . map encodeRebuildError . P.runMultipleErrors Aeson.Object (HM.insert "pursIde" (object [ "name" .= name - , "completions" .= (ordNub (map identCompletion idents ++ map fieldCompletion fields)) + , "completions" .= ordNub (map identCompletion idents ++ map fieldCompletion fields) ]) value) insertTSCompletions _ _ _ v = v @@ -79,7 +79,7 @@ encodeRebuildErrors = toJSON . map encodeRebuildError . P.runMultipleErrors fieldCompletion (label, ty) = Completion { complModule = "" - , complIdentifier = ("_." <> P.prettyPrintLabel label) + , complIdentifier = "_." <> P.prettyPrintLabel label , complType = prettyPrintTypeSingleLine ty , complExpandedType = prettyPrintTypeSingleLine ty , complLocation = Nothing diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 4de450ea92..cc53169ac3 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -228,7 +228,7 @@ data Completion = Completion } deriving (Show, Eq, Ord) instance ToJSON Completion where - toJSON (Completion {..}) = + toJSON Completion {..} = Aeson.object [ "module" .= complModule , "identifier" .= complIdentifier diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 1ceeedf446..66d930b0f2 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -17,7 +17,7 @@ supportModuleName = fst initialInteractivePrint -- | Checks if the Console module is defined supportModuleIsDefined :: [P.ModuleName] -> Bool -supportModuleIsDefined = any ((== supportModuleName)) +supportModuleIsDefined = elem supportModuleName -- * Module Management diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index a09597c052..64f6e1df67 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -122,7 +122,7 @@ printModuleSignatures moduleName P.Environment{..} = Box.moveRight 2 $ Box.vcat Box.left $ mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $ - map (\(cons,idents) -> (textT (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt + map (\(cons,idents) -> textT (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents)) pt prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox maxBound t diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index ee3721230e..57500de8aa 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -180,7 +180,7 @@ explicitParens = mkPattern match matchTypeAtom :: TypeRenderOptions -> Pattern () PrettyPrintType Box matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} = - typeLiterals <+> fmap ((`before` (text ")")) . (text "(" <>)) (matchType tro) + typeLiterals <+> fmap ((`before` text ")") . (text "(" <>)) (matchType tro) where typeLiterals :: Pattern () PrettyPrintType Box typeLiterals = mkPattern match where diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 3cc85a0e82..6fb59d291b 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -226,7 +226,7 @@ prettyPrintLiteralBinder (ArrayLiteral bs) = -- prettyPrintBinder :: Binder -> Text prettyPrintBinder (ConstructorBinder _ ctor []) = runProperName (disqualify ctor) -prettyPrintBinder (ConstructorBinder _ ctor args) = (runProperName (disqualify ctor)) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args) +prettyPrintBinder (ConstructorBinder _ ctor args) = runProperName (disqualify ctor) Monoid.<> " " Monoid.<> T.unwords (map prettyPrintBinderAtom args) prettyPrintBinder (PositionedBinder _ _ binder) = prettyPrintBinder binder prettyPrintBinder (TypedBinder _ binder) = prettyPrintBinder binder prettyPrintBinder b = prettyPrintBinderAtom b diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 98a3a2c016..cc242efcdf 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -162,7 +162,7 @@ getModules opts paths = do (inputFiles, depsFiles) <- liftIO (getInputAndDepsFiles paths) (modules, moduleMap) <- - (liftIO (runExceptT (D.collectDocs (publishCompileOutputDir opts) inputFiles depsFiles))) + liftIO (runExceptT (D.collectDocs (publishCompileOutputDir opts) inputFiles depsFiles)) >>= either (userError . CompileError) return pure (map snd modules, moduleMap) diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index aee6536a14..918287f1e4 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -186,7 +186,7 @@ desugarGuardedExprs ss (Case scrut alternatives) = -- in Case scrut (CaseAlternative vb [MkUnguarded (desugarGuard gs e alt_fail)] - : (alt_fail' (length scrut))) + : alt_fail' (length scrut)) return [ CaseAlternative scrut_nullbinder [MkUnguarded rhs]] diff --git a/src/Language/PureScript/Sugar/Names/Common.hs b/src/Language/PureScript/Sugar/Names/Common.hs index c2542cdbbd..0be439c5fc 100644 --- a/src/Language/PureScript/Sugar/Names/Common.hs +++ b/src/Language/PureScript/Sugar/Names/Common.hs @@ -54,7 +54,7 @@ warnDuplicateRefs pos toError refs = do extractCtors :: SourceSpan -> DeclarationRef -> Maybe [(SourceSpan, Name)] extractCtors pos' (TypeRef _ _ (Just dctors)) = let dupes = dctors \\ ordNub dctors - in if null dupes then Nothing else Just $ ((pos',) . DctorName) <$> dupes + in if null dupes then Nothing else Just $ (pos',) . DctorName <$> dupes extractCtors _ _ = Nothing -- Converts a DeclarationRef into a name for an error message. diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index ff6b9027d1..dc0a1eee2c 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -224,7 +224,7 @@ desugarDecl syns kinds mn exps = go return (expRef name className tys, [d, dictDecl]) go d@(TypeInstanceDeclaration sa _ _ (Right name) deps className tys (NewtypeInstanceWithDictionary dict)) = do let dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictSynonymName) className)) tys - constrainedTy = quantify (foldr (srcConstrainedType) dictTy deps) + constrainedTy = quantify (foldr srcConstrainedType dictTy deps) return (expRef name className tys, [d, ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) go other = return (Nothing, [other]) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 7249cdcc16..4df581549c 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -196,7 +196,7 @@ deriveNewtypeInstance ss mn syns kinds ndis className ds tys tyConNm dargs = do tyCon <- findTypeDecl ss tyConNm ds go tyCon where - go (DataDeclaration _ Newtype _ tyArgNames [(DataConstructorDeclaration _ _ [(_, wrapped)])]) = do + go (DataDeclaration _ Newtype _ tyArgNames [DataConstructorDeclaration _ _ [(_, wrapped)]]) = do -- The newtype might not be applied to all type arguments. -- This is okay as long as the newtype wraps something which ends with -- sufficiently many type applications to variables. @@ -439,7 +439,7 @@ deriveEq ss mn syns kinds ds tyConNm = do | Just rec <- objectType ty , Just fields <- decomposeRec rec = conjAll - . map (\((Label str), typ) -> toEqTest (Accessor str l) (Accessor str r) typ) + . map (\(Label str, typ) -> toEqTest (Accessor str l) (Accessor str r) typ) $ fields | isAppliedVar ty = preludeEq1 l r | otherwise = preludeEq l r @@ -501,7 +501,7 @@ deriveOrd ss mn syns kinds ds tyConNm = do ordCompare1 = App . App (Var ss (Qualified (Just dataOrd) (Ident Prelude.compare1))) mkCtorClauses :: (DataConstructorDeclaration, Bool) -> m [CaseAlternative] - mkCtorClauses ((DataConstructorDeclaration _ ctorName tys), isLast) = do + mkCtorClauses (DataConstructorDeclaration _ ctorName tys, isLast) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") tys' <- mapM (replaceAllTypeSynonymsM syns kinds . snd) tys @@ -541,7 +541,7 @@ deriveOrd ss mn syns kinds ds tyConNm = do | Just rec <- objectType ty , Just fields <- decomposeRec rec = appendAll - . map (\((Label str), typ) -> toOrdering (Accessor str l) (Accessor str r) typ) + . map (\(Label str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ) $ fields | isAppliedVar ty = ordCompare1 l r | otherwise = ordCompare l r @@ -685,7 +685,7 @@ deriveFunctor ss mn syns kinds ds tyConNm = do buildRecord updates = do arg <- freshIdent "o" let argVar = mkVar ss arg - mkAssignment ((Label l), x) = (l, App x (Accessor l argVar)) + mkAssignment (Label l, x) = (l, App x (Accessor l argVar)) return (lam ss arg (ObjectUpdate argVar (mkAssignment <$> updates))) -- quantifiers diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index a3ce38d47e..3936aa5566 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -76,17 +76,17 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) = checkRoleDeclarations :: Maybe Declaration -> [Declaration] -> m () checkRoleDeclarations Nothing (RoleDeclaration RoleDeclarationData{..} : _) = throwError . errorMessage' (fst rdeclSourceAnn) $ OrphanRoleDeclaration rdeclIdent - checkRoleDeclarations (Just (RoleDeclaration (RoleDeclarationData _ name' _))) ((RoleDeclaration (RoleDeclarationData{..})) : _) | name' == rdeclIdent = + checkRoleDeclarations (Just (RoleDeclaration (RoleDeclarationData _ name' _))) ((RoleDeclaration RoleDeclarationData{..}) : _) | name' == rdeclIdent = throwError . errorMessage' (fst rdeclSourceAnn) $ DuplicateRoleDeclaration rdeclIdent - checkRoleDeclarations (Just d) (rd@(RoleDeclaration (RoleDeclarationData{..})) : rest) = do + checkRoleDeclarations (Just d) (rd@(RoleDeclaration RoleDeclarationData{..}) : rest) = do unless (matchesDeclaration d) . throwError . errorMessage' (fst rdeclSourceAnn) $ OrphanRoleDeclaration rdeclIdent unless (isSupported d) . throwError . errorMessage' (fst rdeclSourceAnn) $ UnsupportedRoleDeclaration checkRoleDeclarationArity d checkRoleDeclarations (Just rd) rest where isSupported :: Declaration -> Bool - isSupported (DataDeclaration{}) = True - isSupported (ExternDataDeclaration{}) = True + isSupported DataDeclaration{} = True + isSupported ExternDataDeclaration{} = True isSupported _ = False matchesDeclaration :: Declaration -> Bool matchesDeclaration (DataDeclaration _ _ name' _ _) = rdeclIdent == name' diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index e4e99be3c6..4d76d0ca85 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -60,7 +60,7 @@ addDataType addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv let mapDataCtor (DataConstructorDeclaration _ ctorName vars) = (ctorName, snd <$> vars) - qualName = (Qualified (Just moduleName) name) + qualName = Qualified (Just moduleName) name hasSig = qualName `M.member` types env putEnv $ env { types = M.insert qualName (ctorKind, DataType dtype args (map (mapDataCtor . fst) dctors)) (types env) } unless (hasSig || not (containsForAll ctorKind)) $ do @@ -109,7 +109,7 @@ addTypeSynonym addTypeSynonym moduleName name args ty kind = do env <- getEnv checkTypeSynonyms ty - let qualName = (Qualified (Just moduleName) name) + let qualName = Qualified (Just moduleName) name hasSig = qualName `M.member` types env unless (hasSig || isDictSynonym name || not (containsForAll kind)) $ do tell . errorMessage $ MissingKindDeclaration TypeSynonymSig name kind @@ -286,12 +286,12 @@ typeCheckAll moduleName _ = traverse go let args'' = args' `withRoles` roles addDataType moduleName dtype name args'' dataCtors ctorKind return $ DataDeclaration sa dtype name args dctors - go (d@(DataBindingGroupDeclaration tys)) = do + go d@(DataBindingGroupDeclaration tys) = do let tysList = NEL.toList tys syns = mapMaybe toTypeSynonym tysList dataDecls = mapMaybe toDataDecl tysList clss = mapMaybe toClassDecl tysList - bindingGroupNames = ordNub ((syns^..traverse._2) ++ (dataDecls^..traverse._2._2) ++ (fmap coerceProperName (clss^..traverse._2._2))) + bindingGroupNames = ordNub ((syns^..traverse._2) ++ (dataDecls^..traverse._2._2) ++ fmap coerceProperName (clss^..traverse._2._2)) sss = fmap declSourceSpan tys warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames) . addHint (PositionedError sss)) $ do env <- getEnv @@ -369,7 +369,7 @@ typeCheckAll moduleName _ = traverse go addValue moduleName name ty nameKind return (sai, nameKind, val) return . BindingGroupDeclaration $ NEL.fromList vals'' - go (d@(ExternDataDeclaration _ name kind)) = do + go d@(ExternDataDeclaration _ name kind) = do elabKind <- withFreshSubstitution $ checkKindDeclaration moduleName kind env <- getEnv let qualName = Qualified (Just moduleName) name @@ -377,7 +377,7 @@ typeCheckAll moduleName _ = traverse go let roles = fromMaybe (nominalRolesForKind elabKind) $ M.lookup qualName (roleDeclarations env) putEnv $ env { types = M.insert qualName (elabKind, ExternData roles) (types env) } return d - go (d@(ExternDeclaration (ss, _) name ty)) = do + go d@(ExternDeclaration (ss, _) name ty) = do warnAndRethrow (addHint (ErrorInForeignImport name) . addHint (positionedError ss)) $ do env <- getEnv (elabTy, kind) <- withFreshSubstitution $ do @@ -400,7 +400,7 @@ typeCheckAll moduleName _ = traverse go addTypeClass moduleName qualifiedClassName (fmap Just <$> args') implies' deps tys' kind return d go (TypeInstanceDeclaration _ _ _ (Left _) _ _ _ _) = internalError "typeCheckAll: type class instance generated name should have been desugared" - go (d@(TypeInstanceDeclaration sa@(ss, _) ch idx (Right dictName) deps className tys body)) = + go d@(TypeInstanceDeclaration sa@(ss, _) ch idx (Right dictName) deps className tys body) = rethrow (addHint (ErrorInInstance className tys) . addHint (positionedError ss)) $ do env <- getEnv let qualifiedDictName = Qualified (Just moduleName) dictName @@ -587,7 +587,7 @@ checkNewtype => ProperName 'TypeName -> [DataConstructorDeclaration] -> m () -checkNewtype _ [(DataConstructorDeclaration _ _ [_])] = return () +checkNewtype _ [DataConstructorDeclaration _ _ [_]] = return () checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name -- | diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index cc2b96c40d..1934dce7a7 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -172,7 +172,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do finalState <- get let replaceTypes' = replaceTypes (checkSubstitution finalState) runTypeSearch' gen = runTypeSearch (guard gen $> foldMap snd inferred) finalState - raisePreviousWarnings gen = (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceTypes')) + raisePreviousWarnings gen = escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceTypes') raisePreviousWarnings False wInfer forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs index 4cfb1d3d01..c0c320876c 100644 --- a/tests/Language/PureScript/Ide/CompletionSpec.hs +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -45,49 +45,49 @@ spec = describe "Applying completion options" $ do reexportMatches `shouldBe` [(Match (mn "A", ideKind "Kind"), [mn "A", mn "B"])] it "gets simple docs on definition itself" $ do - ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $ Test.runIde [ load ["CompletionSpecDocs"] , typ "something" ] result `shouldSatisfy` \res -> complDocumentation res == Just "Doc x\n" it "gets multiline docs" $ do - ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $ Test.runIde [ load ["CompletionSpecDocs"] , typ "multiline" ] result `shouldSatisfy` \res -> complDocumentation res == Just "This is\na multi-line\ncomment\n" it "gets simple docs on type annotation" $ do - ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $ Test.runIde [ load ["CompletionSpecDocs"] , typ "withType" ] result `shouldSatisfy` \res -> complDocumentation res == Just "Doc *123*\n" it "gets docs on module declaration" $ do - ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $ Test.runIde [ load ["CompletionSpecDocs"] , typ "CompletionSpecDocs" ] result `shouldSatisfy` \res -> complDocumentation res == Just "Module Documentation\n" it "gets docs on type class declaration" $ do - ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $ Test.runIde [ load ["CompletionSpecDocs"] , typ "DocClass" ] result `shouldSatisfy` \res -> complDocumentation res == Just "Doc for class\n" it "gets docs on type class members" $ do - ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $ Test.runIde [ load ["CompletionSpecDocs"] , typ "member" ] result `shouldSatisfy` \res -> complDocumentation res == Just "doc for member\n" it "includes declarationType in completions for values" $ do - ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $ Test.runIde [ load ["CompletionSpec"] , typ "exampleValue" ] @@ -95,7 +95,7 @@ spec = describe "Applying completion options" $ do complDeclarationType res == Just DeclarationType.Value it "includes declarationType in completions for functions" $ do - ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $ Test.runIde [ load ["CompletionSpec"] , typ "exampleFunction" ] @@ -103,7 +103,7 @@ spec = describe "Applying completion options" $ do complDeclarationType res == Just DeclarationType.Value it "includes declarationType in completions for inferred values" $ do - ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $ Test.runIde [ load ["CompletionSpec"] , typ "exampleInferredString" ] @@ -111,7 +111,7 @@ spec = describe "Applying completion options" $ do complDeclarationType res == Just DeclarationType.Value it "includes declarationType in completions for operators" $ do - ([_, (Right (CompletionResult results))], _) <- Test.inProject $ + ([_, Right (CompletionResult results)], _) <- Test.inProject $ Test.runIde [ load ["CompletionSpec"] , typ "\\°/" ] @@ -123,7 +123,7 @@ spec = describe "Applying completion options" $ do it "includes declarationType in completions for type constructors with \ \conflicting names" $ do - ([_, (Right (CompletionResult results))], _) <- Test.inProject $ + ([_, Right (CompletionResult results)], _) <- Test.inProject $ Test.runIde [ load ["CompletionSpec"] , typ "ExampleTypeConstructor" ] @@ -134,7 +134,7 @@ spec = describe "Applying completion options" $ do complDeclarationType res == Just DeclarationType.Type) it "includes declarationType in completions for type classes" $ do - ([_, (Right (CompletionResult [result]))], _) <- Test.inProject $ + ([_, Right (CompletionResult [result])], _) <- Test.inProject $ Test.runIde [ load ["CompletionSpec"] , typ "ExampleClass" ] @@ -142,7 +142,7 @@ spec = describe "Applying completion options" $ do complDeclarationType res == Just DeclarationType.TypeClass it "includes declarationType in completions for type class members" $ do - ([_, (Right (CompletionResult [result]))], _) <- Test.inProject $ + ([_, Right (CompletionResult [result])], _) <- Test.inProject $ Test.runIde [ load ["CompletionSpec"] , typ "exampleMember" ] diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index bcedcb8830..bf7c40e07a 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -286,7 +286,7 @@ spec = do describe "explicit import sorting" $ do -- given some basic import skeleton let Right (_, _, baseImports, _) = sliceImportSection $ withImports ["import Control.Monad (ap)"] - moduleName = (P.moduleNameFromString "Control.Monad") + moduleName = P.moduleNameFromString "Control.Monad" addImport imports import' = addExplicitImport' import' moduleName Nothing imports valueImport ident = _idaDeclaration (Test.ideValue ident Nothing) typeImport name = _idaDeclaration (Test.ideType name Nothing []) @@ -306,11 +306,11 @@ spec = do ["import Prelude", "", "import Control.Monad (ap, unless, where)"] it "sorts type, value" $ expectSorted - ((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"])) + (map valueImport ["unless", "where"] ++ map typeImport ["Foo", "Bar"]) ["import Prelude", "", "import Control.Monad (Bar, Foo, ap, unless, where)"] it "sorts class, type, value" $ expectSorted - ((map valueImport ["unless", "where"]) ++ (map typeImport ["Foo", "Bar"]) ++ (map classImport ["Applicative", "Bind"])) + (map valueImport ["unless", "where"] ++ map typeImport ["Foo", "Bar"] ++ map classImport ["Applicative", "Bind"]) ["import Prelude", "", "import Control.Monad (class Applicative, class Bind, Bar, Foo, ap, unless, where)"] it "sorts types with constructors, using open imports for the constructors" $ expectSorted diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index fd4bb8184a..6f32c3e112 100644 --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -61,12 +61,12 @@ spec = describe "Rebuilding single modules" $ do Test.runIde [ rebuild "RebuildSpecWithMissingForeign.fail" ] result `shouldSatisfy` isLeft it "completes a hidden identifier after rebuilding" $ do - ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $ Test.runIde [ rebuildSync "RebuildSpecWithHiddenIdent.purs" , Complete [] (flexMatcher "hid") (Just (Test.mn "RebuildSpecWithHiddenIdent")) defaultCompletionOptions] complIdentifier result `shouldBe` "hidden" it "uses the specified `actualFile` for location information" $ do - ([_, (Right (CompletionResult [ result ]))], _) <- Test.inProject $ + ([_, Right (CompletionResult [ result ])], _) <- Test.inProject $ Test.runIde' Test.defConfig emptyIdeState diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 037beff3fa..3852dbc094 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -78,7 +78,7 @@ spec = do r `shouldBe` synonymSS it "finds a data declaration and its constructors" $ do rs <- traverse getLocation ["SFData", "SFOne", "SFTwo", "SFThree"] - traverse_ (`shouldBe` (Just typeSS)) rs + traverse_ (`shouldBe` Just typeSS) rs it "finds a class declaration" $ do Just r <- getLocation "SFClass" r `shouldBe` classSS diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index 11fa4a3c3f..135aa61c36 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -82,7 +82,7 @@ ideValueOp opName ident precedence assoc t = (IdeValueOperator (P.OpName opName) (bimap P.Ident P.ProperName <$> ident) - (precedence) + precedence (fromMaybe P.Infix assoc) t)) @@ -92,7 +92,7 @@ ideTypeOp opName ident precedence assoc k = (IdeTypeOperator (P.OpName opName) (P.ProperName <$> ident) - (precedence) + precedence (fromMaybe P.Infix assoc) k)) diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index 2cfb01aaa5..f09a4da753 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -21,7 +21,7 @@ spec = do it "all Prim modules are fully documented" $ do let actualPrimNames = -- note that prim type classes are listed in P.primTypes - (filter (not . Text.any (== '$')) . map (P.runProperName . P.disqualify . fst) $ Map.toList + filter (not . Text.any (== '$')) . map (P.runProperName . P.disqualify . fst) $ Map.toList ( P.primTypes <> P.primBooleanTypes <> P.primCoerceTypes <> @@ -29,7 +29,7 @@ spec = do P.primRowTypes <> P.primRowListTypes <> P.primTypeErrorTypes <> - P.primSymbolTypes )) + P.primSymbolTypes ) let documentedPrimNames = map D.declTitle (concatMap D.modDeclarations D.primModules) diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs index 3872f81ea1..cde4b3df91 100644 --- a/tests/TestPsci/CommandTest.hs +++ b/tests/TestPsci/CommandTest.hs @@ -67,7 +67,7 @@ commandTests = context "commandTests" $ do specPSCi ":print" $ do let failMsg = "Unable to set the repl's printing function" let interactivePrintModuleShouldBe modName = do - modName' <- (fst . psciInteractivePrint) <$> get + modName' <- fst . psciInteractivePrint <$> get modName' `equalsTo` modName run "import Prelude" From 40574d227330a998c93c500a0fbeb07802b2dc43 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:34 -0400 Subject: [PATCH 1337/1580] HLint fix: "Redundant $" --- .hlint.yaml | 1 - .../src/Language/PureScript/Types.hs | 2 +- .../src/Language/PureScript/CST/Convert.hs | 2 +- .../src/Language/PureScript/CST/Lexer.hs | 10 +++---- .../src/Language/PureScript/CST/Monad.hs | 2 +- src/Language/PureScript/CodeGen/JS/Printer.hs | 2 +- src/Language/PureScript/Errors.hs | 30 +++++++++---------- src/Language/PureScript/Linter/Exhaustive.hs | 2 +- .../PureScript/Sugar/Names/Exports.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- .../PureScript/TypeChecker/Entailment.hs | 2 +- src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- tests/Language/PureScript/Ide/Test.hs | 2 +- tests/TestBundle.hs | 2 +- tests/TestCst.hs | 2 +- tests/TestHierarchy.hs | 2 +- tests/TestUtils.hs | 2 +- 17 files changed, 34 insertions(+), 35 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 9145916a93..3a52535915 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -16,7 +16,6 @@ - ignore: {name: "Use lambda-case"} - ignore: {name: "Avoid lambda"} - ignore: {name: "Use tuple-section"} -- ignore: {name: "Redundant $"} - ignore: {name: "Use record patterns"} - ignore: {name: "Move brackets to avoid $"} - ignore: {name: "Use section"} diff --git a/lib/purescript-ast/src/Language/PureScript/Types.hs b/lib/purescript-ast/src/Language/PureScript/Types.hs index 9c55a59b6e..a25943ef73 100644 --- a/lib/purescript-ast/src/Language/PureScript/Types.hs +++ b/lib/purescript-ast/src/Language/PureScript/Types.hs @@ -595,7 +595,7 @@ everywhereOnTypes f = go where go (TypeApp ann t1 t2) = f (TypeApp ann (go t1) (go t2)) go (KindApp ann t1 t2) = f (KindApp ann (go t1) (go t2)) go (ForAll ann arg mbK ty sco) = f (ForAll ann arg (go <$> mbK) (go ty) sco) - go (ConstrainedType ann c ty) = f (ConstrainedType ann (mapConstraintArgsAll (map go) $ c) (go ty)) + go (ConstrainedType ann c ty) = f (ConstrainedType ann (mapConstraintArgsAll (map go) c) (go ty)) go (RCons ann name ty rest) = f (RCons ann name (go ty) (go rest)) go (KindedType ann ty k) = f (KindedType ann (go ty) (go k)) go (BinaryNoParensType ann t1 t2 t3) = f (BinaryNoParensType ann (go t1) (go t2) (go t3)) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs index 69dfb58fae..0c895c1c81 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs @@ -121,7 +121,7 @@ convertType fileName = go TypeHole _ a -> T.TypeWildcard (sourceName fileName a) . Just . getIdent $ nameValue a TypeString _ a b -> - T.TypeLevelString (sourceAnnCommented fileName a a) $ b + T.TypeLevelString (sourceAnnCommented fileName a a) b TypeRow _ (Wrapped _ row b) -> goRow row b TypeRecord _ (Wrapped a row b) -> do diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs index 1ef436d29a..dfc54023ab 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs @@ -204,7 +204,7 @@ breakComments = k0 [] comment = isBlockComment >>= \case Just True -> Just <$> blockComment "{-" Just False -> Just <$> lineComment "--" - Nothing -> pure $ Nothing + Nothing -> pure Nothing lineComment acc = do comm <- nextWhile (\c -> c /= '\r' && c /= '\n') @@ -417,7 +417,7 @@ token = peek >>= maybe (pure TokEof) k0 Just ch -> next $> (Text.singleton ch, ch) Nothing -> - throw $ ErrEof + throw ErrEof peek >>= \case Just '\'' | fromEnum ch > 0xFFFF -> throw ErrAstralCodePointInChar @@ -425,7 +425,7 @@ token = peek >>= maybe (pure TokEof) k0 Just ch2 -> throw $ ErrLexeme (Just [ch2]) [] _ -> - throw $ ErrEof + throw ErrEof {- stringPart @@ -571,7 +571,7 @@ token = peek >>= maybe (pure TokEof) k0 Just ch | isNumberChar ch -> throw ErrLeadingZero _ -> pure $ Just ("0", "0") Just ch | Char.isDigit ch -> Just <$> digits - _ -> pure $ Nothing + _ -> pure Nothing {- integer1 @@ -589,7 +589,7 @@ token = peek >>= maybe (pure TokEof) k0 ch | Char.isDigit ch -> do (raw, chs) <- digits pure $ Just (Text.cons ch raw, ch : chs) - _ -> pure $ Nothing + _ -> pure Nothing {- fraction diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs b/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs index 79beab2306..4b2b1a615f 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs @@ -157,7 +157,7 @@ manyDelimited open close sep p = do _ <- token open res <- go1 _ <- token close - pure $ res + pure res where go1 = oneOf $ NE.fromList diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index b69270cdac..d1fe3bed5d 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -122,7 +122,7 @@ literals = mkPattern' match' match _ = mzero comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen - comment (LineComment com) = fmap mconcat $ sequence $ + comment (LineComment com) = fmap mconcat $ sequence [ currentIndent , return $ emit "//" <> emit com <> emit "\n" ] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 3cdc54cc9a..b0d39db4e9 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -698,7 +698,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line $ "In the FFI module for " <> markCode (runModuleName mn) <> ":" , indent . paras $ [ line $ "The identifier " <> markCode ident <> " contains a prime (" <> markCode "'" <> ")." - , line $ "Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future." + , line "Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future." ] ] renderSimpleErrorMessage InvalidDoBind = @@ -793,14 +793,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (CycleInTypeClassDeclaration [name]) = paras [ line $ "A type class '" <> markCode (runProperName (disqualify name)) <> "' may not have itself as a superclass." ] renderSimpleErrorMessage (CycleInTypeClassDeclaration names) = - paras [ line $ "A cycle appears in a set of type class definitions:" + paras [ line "A cycle appears in a set of type class definitions:" , indent $ line $ "{" <> T.intercalate ", " (map (markCode . runProperName . disqualify) names) <> "}" , line "Cycles are disallowed because they can lead to loops in the type checker." ] renderSimpleErrorMessage (CycleInKindDeclaration [name]) = paras [ line $ "A kind declaration '" <> markCode (runProperName (disqualify name)) <> "' may not refer to itself in its own signature." ] renderSimpleErrorMessage (CycleInKindDeclaration names) = - paras [ line $ "A cycle appears in a set of kind declarations:" + paras [ line "A cycle appears in a set of kind declarations:" , indent $ line $ "{" <> T.intercalate ", " (map (markCode . runProperName . disqualify) names) <> "}" , line "Kind declarations may not refer to themselves in their own signatures." ] @@ -949,7 +949,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl [ line (showQualified runProperName nm) , Box.vcat Box.left (map prettyTypeAtom ts) ] - , line $ fold $ + , line $ fold [ "because the " , markCode (showQualified runProperName nm) , " type class has " @@ -985,11 +985,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (OverlappingArgNames ident) = line $ "Overlapping names in function/binder" <> foldMap ((" in declaration " <>) . showIdent) ident renderSimpleErrorMessage (MissingClassMember identsAndTypes) = - paras $ [ line "The following type class members have not been implemented:" - , Box.vcat Box.left - [ markCodeBox $ Box.text (T.unpack (showIdent ident)) Box.<> " :: " Box.<> prettyType ty - | (ident, ty) <- NEL.toList identsAndTypes ] - ] + paras [ line "The following type class members have not been implemented:" + , Box.vcat Box.left + [ markCodeBox $ Box.text (T.unpack (showIdent ident)) Box.<> " :: " Box.<> prettyType ty + | (ident, ty) <- NEL.toList identsAndTypes ] + ] renderSimpleErrorMessage (ExtraneousClassMember ident className) = line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className) renderSimpleErrorMessage (ExpectedType ty kind) = @@ -1107,7 +1107,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (MissingKindDeclaration sig name ty) = let sigKw = prettyPrintKindSignatureFor sig in paras [ line $ "The inferred kind for the " <> sigKw <> " declaration " <> markCode (runProperName name) <> " contains polymorphic kinds." - , line $ "Consider adding a top-level kind signature as a form of documentation." + , line "Consider adding a top-level kind signature as a form of documentation." , markCodeBox $ indent $ Box.hsep 1 Box.left [ line $ sigKw <> " " <> runProperName name <> " ::" , prettyTypeWithDepth maxBound ty @@ -1173,7 +1173,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderSimpleErrorMessage msg@(ImplicitQualifiedImportReExport importedModule asModule _) = paras [ line $ "Module " <> markCode (runModuleName importedModule) <> " was imported as " <> markCode (runModuleName asModule) <> " with unspecified imports." - , line $ "As this module is being re-exported, consider using the explicit form:" + , line "As this module is being re-exported, consider using the explicit form:" , indent $ line $ markCode $ showSuggestion msg ] @@ -1252,9 +1252,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderSimpleErrorMessage (CannotDefinePrimModules mn) = - paras $ + paras [ line $ "The module name " <> markCode (runModuleName mn) <> " is in the Prim namespace." - , line $ "The Prim namespace is reserved for compiler-defined terms." + , line "The Prim namespace is reserved for compiler-defined terms." ] renderSimpleErrorMessage (MixedAssociativityError opsWithAssoc) = @@ -1300,7 +1300,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (VisibleQuantificationCheckFailureInType var) = paras [ line $ "Visible dependent quantification of type variable " <> markCode var <> " is not supported." - , line $ "If you would like this feature supported, please bother Liam Goodacre (@LiamGoodacre)." + , line "If you would like this feature supported, please bother Liam Goodacre (@LiamGoodacre)." ] renderSimpleErrorMessage (UnsupportedTypeInKind ty) = @@ -1330,7 +1330,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] renderSimpleErrorMessage UnsupportedRoleDeclaration = - line $ "Role declarations are only supported for data types, not for type synonyms nor type classes." + line "Role declarations are only supported for data types, not for type synonyms nor type classes." renderSimpleErrorMessage (RoleDeclarationArityMismatch name expected actual) = line $ T.intercalate " " diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 0bd0ddea0a..7bb8d587a7 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -293,7 +293,7 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' where partial :: Text -> Text -> Declaration partial var tyVar = - ValueDecl (ss, []) UnusedIdent Private [] $ + ValueDecl (ss, []) UnusedIdent Private [] [MkUnguarded (TypedValue True diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 83f4934008..cceb94a0d6 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -217,7 +217,7 @@ resolveExports env ss mn imps exps refs = resolve f (Qualified (Just mn'') a) = do exps' <- envModuleExports <$> mn'' `M.lookup` env src <- a `M.lookup` f exps' - return $ (a, src { exportSourceImportedFrom = Just mn'' }) + return (a, src { exportSourceImportedFrom = Just mn'' }) resolve _ _ = internalError "Unqualified value in resolve" -- | diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index dc0a1eee2c..dcbb3472b4 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -288,7 +288,7 @@ typeClassMemberToDictionaryAccessor -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarationData sa ident ty)) = let className = Qualified (Just mn) name - in ValueDecl sa ident Private [] $ + in ValueDecl sa ident Private [] [MkUnguarded ( TypedValue False (TypeClassDictionaryAccessor className ident) $ moveQuantifiersToFront (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty)) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 26c9a0c3b0..6488fc3f34 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -231,7 +231,7 @@ entails SolverOptions{..} constraint context hints = let instances = do chain <- groupBy ((==) `on` tcdChain) $ - sortOn (tcdChain &&& tcdIndex) $ + sortOn (tcdChain &&& tcdIndex) dicts -- process instances in a chain in index order let found = for chain $ \tcd -> diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 86540fa24f..5f7d387a5c 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -217,7 +217,7 @@ inferKind = \tyToInfer -> t2' <- checkKind t2 argKind pure (KindApp ann t1' t2', replaceTypeVars arg t2' resKind) _ -> - internalError $ "inferKind: unkinded forall binder" + internalError "inferKind: unkinded forall binder" KindedType _ t1 t2 -> do t2' <- replaceAllTypeSynonyms . fst =<< go t2 t1' <- checkKind t1 t2' diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index 135aa61c36..e620b38e20 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -134,7 +134,7 @@ inProject f = do compileTestProject :: IO Bool compileTestProject = inProject $ do (_, _, _, procHandle) <- - createProcess $ (shell $ "purs compile \"src/**/*.purs\"") + createProcess $ shell "purs compile \"src/**/*.purs\"" r <- tryNTimes 10 (getProcessExitCode procHandle) pure (maybe False isSuccess r) diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs index d60e65fd5f..42712c6100 100644 --- a/tests/TestBundle.hs +++ b/tests/TestBundle.hs @@ -60,7 +60,7 @@ assertBundles support inputFiles outputFile = do js <- liftIO $ readUTF8File filename mid <- guessModuleIdentifier filename length js `seq` return (mid, Just filename, js) - bundleSM input entryModule (Just $ "Main") "PS" (Just entryPoint) Nothing + bundleSM input entryModule (Just "Main") "PS" (Just entryPoint) Nothing case bundled of Right (_, js) -> do writeUTF8File entryPoint js diff --git a/tests/TestCst.hs b/tests/TestCst.hs index 8c094473b9..fb62f768e7 100644 --- a/tests/TestCst.hs +++ b/tests/TestCst.hs @@ -186,7 +186,7 @@ genStringChar delimiter ch = frequency genRawString :: Gen PSSourceRawString genRawString = PSSourceRawString <$> do - chs <- listOf $ arbitraryUnicodeChar + chs <- listOf arbitraryUnicodeChar let k1 acc qs cs = do let (cs', q) = span (/= '"') cs diff --git a/tests/TestHierarchy.hs b/tests/TestHierarchy.hs index ad83c24908..05c6e75a99 100644 --- a/tests/TestHierarchy.hs +++ b/tests/TestHierarchy.hs @@ -19,7 +19,7 @@ spec = describe "hierarchy" $ do prettyPrinted `shouldBe` " A;" it "creates a relation when there is one" $ do - let superMap = SuperMap (Right $ (P.ProperName "A", P.ProperName "B")) + let superMap = SuperMap (Right (P.ProperName "A", P.ProperName "B")) let prettyPrinted = prettyPrint superMap diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 3c31c8a21d..d14cd8d2a9 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -57,7 +57,7 @@ updateSupportCode = withCurrentDirectory "tests/support" $ do -- ... and it was modified less than a day ago (no particular reason why -- "one day" specifically), - now <- lift $ getCurrentTime + now <- lift getCurrentTime guard $ now `diffUTCTime` lastUpdated < nominalDay -- ... and the needed directories exist, From 0bfa4efb245c067b92d7173230259eec19202077 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:34 -0400 Subject: [PATCH 1338/1580] HLint fix: "Move brackets to avoid $" --- .hlint.yaml | 1 - lib/purescript-cst/src/Language/PureScript/CST/Convert.hs | 2 +- src/Language/PureScript/Bundle.hs | 2 +- src/Language/PureScript/Docs/Tags.hs | 2 +- src/Language/PureScript/Linter.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses/Instances.hs | 2 +- 6 files changed, 5 insertions(+), 6 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 3a52535915..6279e572f5 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -17,7 +17,6 @@ - ignore: {name: "Avoid lambda"} - ignore: {name: "Use tuple-section"} - ignore: {name: "Use record patterns"} -- ignore: {name: "Move brackets to avoid $"} - ignore: {name: "Use section"} - ignore: {name: "Use <$>"} - ignore: {name: "Reduce duplication"} diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs index 0c895c1c81..371ea54c4c 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs @@ -575,7 +575,7 @@ convertDeclaration fileName decl = case decl of TypeForall{} -> "" TypeApp _ t1 t2 -> argName t1 <> argName t2 TypeOp _ t1 op t2 -> - argName t1 <> (N.runOpName $ qualName op) <> argName t2 + argName t1 <> N.runOpName (qualName op) <> argName t2 TypeArr _ t1 _ t2 -> argName t1 <> "Function" <> argName t2 TypeConstrained{} -> "" TypeUnaryRow{} -> "Row" diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 3fe486fd10..fb6239f54f 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -313,7 +313,7 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) in (map (\name -> (m, name, Internal)) shorthandNames, bn) toReference (JSFunctionExpression _ _ _ params _ _) bn - = ([], bn \\ (mapMaybe unIdentifier $ commaList params)) + = ([], bn \\ mapMaybe unIdentifier (commaList params)) toReference e bn | Just nm <- exportsAccessor e -- exports.foo means there's a dependency on the public member "foo" of diff --git a/src/Language/PureScript/Docs/Tags.hs b/src/Language/PureScript/Docs/Tags.hs index 0310bb7a63..95d4b07faf 100644 --- a/src/Language/PureScript/Docs/Tags.hs +++ b/src/Language/PureScript/Docs/Tags.hs @@ -18,7 +18,7 @@ tags = map (first T.unpack) . concatMap dtags . modDeclarations where dtags :: Declaration -> [(T.Text, Int)] dtags decl = case declSourceSpan decl of - Just ss -> (declTitle decl, pos ss):(mapMaybe subtag $ declChildren decl) + Just ss -> (declTitle decl, pos ss):mapMaybe subtag (declChildren decl) Nothing -> mapMaybe subtag $ declChildren decl subtag :: ChildDeclaration -> Maybe (T.Text, Int) diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 93f5b1b7ed..2b5c3b6326 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -284,6 +284,6 @@ lintUnused (Module modSS _ mn modDecls exports) = filteredUsed = used `S.difference` newNames warnUnused = S.filter (not . Text.isPrefixOf "_" . runIdent) (newNames `S.difference` used) warnUnusedSpans = S.filter (\(_,ident) -> ident `elem` warnUnused) newNamesWithSpans - combinedErrors = if not $ S.null warnUnusedSpans then errors <> (mconcat $ map (\(ss,ident) -> errorMessage' ss $ UnusedName ident) $ S.toList warnUnusedSpans) else errors + combinedErrors = if not $ S.null warnUnusedSpans then errors <> mconcat (map (\(ss,ident) -> errorMessage' ss $ UnusedName ident) $ S.toList warnUnusedSpans) else errors in (filteredUsed, combinedErrors) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Instances.hs b/src/Language/PureScript/Sugar/TypeClasses/Instances.hs index 081d7c9314..a2ea95a678 100644 --- a/src/Language/PureScript/Sugar/TypeClasses/Instances.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Instances.hs @@ -35,6 +35,6 @@ desugarTypeClassInstanceNames (Module ss coms name decls exps) = do desugarInstName = \case TypeInstanceDeclaration sa chainId idx (Left genText) deps className tys bd -> do uniqueIdent <- fresh - let finalName = Ident $ genText <> (pack $ show uniqueIdent) + let finalName = Ident $ genText <> pack (show uniqueIdent) pure $ TypeInstanceDeclaration sa chainId idx (Right finalName) deps className tys bd a -> pure a From 13edbf73347312d8645b0eef80d426a8cd26096e Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:34 -0400 Subject: [PATCH 1339/1580] HLint fix: "Use <$>" --- .hlint.yaml | 1 - src/Language/PureScript/CodeGen/JS/Printer.hs | 2 +- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- src/Language/PureScript/CoreFn/Optimizer.hs | 2 +- src/Language/PureScript/Docs/Collect.hs | 2 +- src/Language/PureScript/Docs/Prim.hs | 4 ++-- src/Language/PureScript/Publish.hs | 2 +- src/Language/PureScript/Sugar/BindingGroups.hs | 10 +++++----- src/Language/PureScript/TypeChecker/Entailment.hs | 4 ++-- src/Language/PureScript/TypeChecker/Kinds.hs | 4 ++-- src/Language/PureScript/TypeChecker/Monad.hs | 2 +- 11 files changed, 17 insertions(+), 18 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 6279e572f5..7ceb4846cd 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -18,7 +18,6 @@ - ignore: {name: "Use tuple-section"} - ignore: {name: "Use record patterns"} - ignore: {name: "Use section"} -- ignore: {name: "Use <$>"} - ignore: {name: "Reduce duplication"} - ignore: {name: "Use camelCase"} - ignore: {name: "Functor law"} diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index d1fe3bed5d..39fe77c897 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -122,7 +122,7 @@ literals = mkPattern' match' match _ = mzero comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen - comment (LineComment com) = fmap mconcat $ sequence + comment (LineComment com) = mconcat <$> sequence [ currentIndent , return $ emit "//" <> emit com <> emit "\n" ] diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 1723d87d4e..4b77836ace 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -120,7 +120,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal _ (A.ObjectLiteral _)) _)) = exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name lit) exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal _ (A.ObjectLiteral vs))) = - let args = fmap (exprToCoreFn ss [] Nothing . snd) $ sortOn fst vs + let args = exprToCoreFn ss [] Nothing . snd <$> sortOn fst vs ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name) in foldl (App (ss, com, Nothing, Nothing)) ctor args exprToCoreFn ss com ty (A.TypeClassDictionaryAccessor _ ident) = diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index e28870ccbf..6b3c9ef2b5 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -43,7 +43,7 @@ closedRecordFields (TypeApp _ (TypeConstructor _ C.Record) row) = where collect :: Type a -> Maybe [Label] collect (REmptyKinded _ _) = Just [] - collect (RCons _ l _ r) = collect r >>= return . (l :) + collect (RCons _ l _ r) = (l :) <$> collect r collect _ = Nothing closedRecordFields _ = Nothing diff --git a/src/Language/PureScript/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs index ef84d4bc1b..02db5949be 100644 --- a/src/Language/PureScript/Docs/Collect.hs +++ b/src/Language/PureScript/Docs/Collect.hs @@ -158,7 +158,7 @@ operateAndRetag :: [(tag, a)] -> m [(tag, b)] operateAndRetag keyA keyB operation input = - fmap (map retag) $ operation (map snd input) + map retag <$> operation (map snd input) where tags :: Map key tag tags = Map.fromList $ map (\(tag, a) -> (keyA a, tag)) input diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index df2b40313e..3afa0cebf1 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -209,8 +209,8 @@ primClassOf gen title comments = Declaration , declInfo = let tcd = lookupPrimClassOf gen title - args = fmap (fmap (fmap ($> ()))) $ P.typeClassArguments tcd - superclasses = fmap ($> ()) $ P.typeClassSuperclasses tcd + args = fmap (fmap ($> ())) <$> P.typeClassArguments tcd + superclasses = ($> ()) <$> P.typeClassSuperclasses tcd fundeps = convertFundepsToStrings args (P.typeClassDependencies tcd) in TypeClassDeclaration args superclasses fundeps diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index cc242efcdf..dd82843dc9 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -212,7 +212,7 @@ getManifestRepositoryInfo pkgMeta = Nothing -> do giturl <- catchError (Just . T.strip . T.pack <$> readProcess' "git" ["config", "remote.origin.url"] "") (const (return Nothing)) - userError (BadRepositoryField (RepositoryFieldMissing (giturl >>= extractGithub >>= return . format))) + userError (BadRepositoryField (RepositoryFieldMissing (giturl >>= extractGithub <&> format))) Just Repository{..} -> do unless (repositoryType == "git") (userError (BadRepositoryField (BadRepositoryType repositoryType))) diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index c7dfe911ec..bee60e36db 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -73,13 +73,13 @@ createBindingGroups moduleName = mapM f <=< handleDecls handleDecls :: [Declaration] -> m [Declaration] handleDecls ds = do let values = mapMaybe (fmap (fmap extractGuardedExpr) . getValueDeclaration) ds - kindDecls = fmap (,VertexKindSignature) $ filter isKindDecl ds - dataDecls = fmap (,VertexDefinition) $ filter (\a -> isDataDecl a || isExternDataDecl a || isTypeSynonymDecl a || isTypeClassDecl a) ds - kindSigs = fmap (declTypeName . fst) kindDecls - typeSyns = fmap declTypeName $ filter isTypeSynonymDecl ds + kindDecls = (,VertexKindSignature) <$> filter isKindDecl ds + dataDecls = (,VertexDefinition) <$> filter (\a -> isDataDecl a || isExternDataDecl a || isTypeSynonymDecl a || isTypeClassDecl a) ds + kindSigs = declTypeName . fst <$> kindDecls + typeSyns = declTypeName <$> filter isTypeSynonymDecl ds nonTypeSynKindSigs = kindSigs \\ typeSyns allDecls = kindDecls ++ dataDecls - allProperNames = fmap (declTypeName . fst) allDecls + allProperNames = declTypeName . fst <$> allDecls mkVert (d, vty) = let names = usedTypeNames moduleName d `intersect` allProperNames name = declTypeName d diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 6488fc3f34..f1f92e8afa 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -165,8 +165,8 @@ entails SolverOptions{..} constraint context hints = where forClassNameM :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> m [TypeClassDict] forClassNameM env ctx cn@C.Coercible kinds args = - solveCoercible env ctx kinds args >>= - pure . fromMaybe (forClassName env ctx cn kinds args) + fromMaybe (forClassName env ctx cn kinds args) <$> + solveCoercible env ctx kinds args forClassNameM env ctx cn kinds args = pure $ forClassName env ctx cn kinds args diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 5f7d387a5c..c63af80270 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -918,8 +918,8 @@ kindsOfAll -> [ClassDeclarationArgs] -> m ([TypeDeclarationResult], [DataDeclarationResult], [ClassDeclarationResult]) kindsOfAll moduleName syns dats clss = withFreshSubstitution $ do - synDict <- for syns $ \(sa, synName, _, _) -> fmap (synName,) $ existingSignatureOrFreshKind moduleName (fst sa) synName - datDict <- for dats $ \(sa, datName, _, _) -> fmap (datName,) $ existingSignatureOrFreshKind moduleName (fst sa) datName + synDict <- for syns $ \(sa, synName, _, _) -> (synName,) <$> existingSignatureOrFreshKind moduleName (fst sa) synName + datDict <- for dats $ \(sa, datName, _, _) -> (datName,) <$> existingSignatureOrFreshKind moduleName (fst sa) datName clsDict <- for clss $ \(sa, clsName, _, _, _) -> fmap (coerceProperName clsName,) $ existingSignatureOrFreshKind moduleName (fst sa) $ coerceProperName clsName let bindingGroup = synDict <> datDict <> clsDict bindLocalTypeVariables moduleName bindingGroup $ do diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 095890a2bc..3736aaa931 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -449,7 +449,7 @@ debugTypeClasses = fmap go . M.toList . typeClasses go (className, tc) = do let className' = showQualified runProperName className - args = unwords $ fmap (\(a, b) -> "(" <> debugType (maybe (srcTypeVar a) (srcKindedType (srcTypeVar a)) b) <> ")") $ typeClassArguments tc + args = unwords $ (\(a, b) -> "(" <> debugType (maybe (srcTypeVar a) (srcKindedType (srcTypeVar a)) b) <> ")") <$> typeClassArguments tc "class " <> unpack className' <> " " <> args debugValue :: Expr -> String From fab54c69ced2f44107e9ed5ca291a0fdb0857d3c Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:34 -0400 Subject: [PATCH 1340/1580] HLint fix: "Eta reduce" --- .hlint.yaml | 1 - lib/purescript-ast/src/Language/PureScript/Environment.hs | 4 ++-- .../src/Language/PureScript/CST/Positions.hs | 4 ++-- src/Language/PureScript/CoreImp/Optimizer/TCO.hs | 2 +- src/Language/PureScript/Docs/AsHtml.hs | 2 +- src/Language/PureScript/Ide/Completion.hs | 4 ++-- src/Language/PureScript/Ide/State.hs | 8 ++++---- src/Language/PureScript/Ide/Util.hs | 8 ++++---- src/Language/PureScript/Make/Cache.hs | 2 +- src/Language/PureScript/Sugar/Operators/Types.hs | 2 +- src/Language/PureScript/TypeChecker/Entailment.hs | 6 +++--- src/Language/PureScript/TypeChecker/Kinds.hs | 4 ++-- tests/Language/PureScript/Ide/UsageSpec.hs | 2 +- 13 files changed, 24 insertions(+), 25 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 7ceb4846cd..7b09df7603 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -12,7 +12,6 @@ - ignore: {name: "Use newtype instead of data"} - ignore: {name: "Use join"} - ignore: {name: "Fuse foldr/map"} -- ignore: {name: "Eta reduce"} - ignore: {name: "Use lambda-case"} - ignore: {name: "Avoid lambda"} - ignore: {name: "Use tuple-section"} diff --git a/lib/purescript-ast/src/Language/PureScript/Environment.hs b/lib/purescript-ast/src/Language/PureScript/Environment.hs index 2eaacefa8c..0ce32275ec 100644 --- a/lib/purescript-ast/src/Language/PureScript/Environment.hs +++ b/lib/purescript-ast/src/Language/PureScript/Environment.hs @@ -132,7 +132,7 @@ makeTypeClassData -> [FunctionalDependency] -> Bool -> TypeClassData -makeTypeClassData args m s deps tcIsEmpty = TypeClassData args m s deps determinedArgs coveringSets tcIsEmpty +makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs coveringSets where argumentIndices = [0 .. length args - 1] @@ -349,7 +349,7 @@ isTypeOrApplied t1 t2 = eqType t1 t2 -- | Smart constructor for function types function :: SourceType -> SourceType -> SourceType -function t1 t2 = TypeApp nullSourceAnn (TypeApp nullSourceAnn tyFunction t1) t2 +function = TypeApp nullSourceAnn . TypeApp nullSourceAnn tyFunction -- To make reading the kind signatures below easier (-:>) :: SourceType -> SourceType -> SourceType diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs index 196254e7cf..d9c739b8ee 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs @@ -18,10 +18,10 @@ advanceToken :: SourcePos -> Token -> SourcePos advanceToken pos = applyDelta pos . tokenDelta advanceLeading :: SourcePos -> [Comment LineFeed] -> SourcePos -advanceLeading pos = foldl' (\a -> applyDelta a . commentDelta lineDelta) pos +advanceLeading = foldl' $ \a -> applyDelta a . commentDelta lineDelta advanceTrailing :: SourcePos -> [Comment Void] -> SourcePos -advanceTrailing pos = foldl' (\a -> applyDelta a . commentDelta (const (0, 0))) pos +advanceTrailing = foldl' $ \a -> applyDelta a . commentDelta (const (0, 0)) tokenDelta :: Token -> (Int, Int) tokenDelta = \case diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index e1356b6d7c..f63b499ee1 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -92,7 +92,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where -- identifier to be considered in tail position (or Nothing if this -- identifier is used somewhere not as a tail call with full arity). findTailPositionDeps :: (Text, Int) -> AST -> Maybe (S.Set (Text, Int)) - findTailPositionDeps (ident, arity) js = allInTailPosition js where + findTailPositionDeps (ident, arity) = allInTailPosition where countSelfReferences = countReferences ident allInTailPosition (Return _ expr) diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index 118bda4d4e..884b89d2bf 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -316,7 +316,7 @@ v :: Text -> AttributeValue v = toValue withClass :: String -> Html -> Html -withClass className content = H.span ! A.class_ (fromString className) $ content +withClass className = H.span ! A.class_ (fromString className) partitionChildren :: [ChildDeclaration] -> diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 17b3666bdd..8914aae48d 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -54,8 +54,8 @@ getExactCompletions search filters modules = matchesFromModules :: ModuleMap [IdeDeclarationAnn] -> [Match IdeDeclarationAnn] matchesFromModules = Map.foldMapWithKey completionFromModule where - completionFromModule moduleName decls = - map (\x -> Match (moduleName, x)) decls + completionFromModule moduleName = + map $ \x -> Match (moduleName, x) data CompletionOptions = CompletionOptions { coMaxResults :: Maybe Int diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 9234711b40..25b2af367c 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -249,8 +249,8 @@ resolveLocationsForModule :: (DefinitionSites P.SourceSpan, TypeAnnotations) -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] -resolveLocationsForModule (defs, types) decls = - map convertDeclaration decls +resolveLocationsForModule (defs, types) = + map convertDeclaration where convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration' @@ -310,8 +310,8 @@ resolveDocumentationForModule :: P.Module -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] -resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) decls = - map convertDecl decls +resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) = + map convertDecl where extractDeclComments :: P.Declaration -> [(P.Name, [P.Comment])] extractDeclComments = \case diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 51065d8010..4905bd71d4 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -77,13 +77,13 @@ unwrapMatch (Match (_, ed)) = ed valueOperatorAliasT :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text -valueOperatorAliasT i = - P.showQualified (either P.runIdent P.runProperName) i +valueOperatorAliasT = + P.showQualified $ either P.runIdent P.runProperName typeOperatorAliasT :: P.Qualified (P.ProperName 'P.TypeName) -> Text -typeOperatorAliasT i = - P.showQualified P.runProperName i +typeOperatorAliasT = + P.showQualified P.runProperName encodeT :: (ToJSON a) => a -> Text encodeT = TL.toStrict . TLE.decodeUtf8 . encode diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs index e69acd4317..b56261951f 100644 --- a/src/Language/PureScript/Make/Cache.hs +++ b/src/Language/PureScript/Make/Cache.hs @@ -129,7 +129,7 @@ checkChanged cacheDb mn basePath currentInfo = do -- | Remove any modules from the given set from the cache database; used when -- they failed to build. removeModules :: Set ModuleName -> CacheDb -> CacheDb -removeModules moduleNames = flip Map.withoutKeys moduleNames +removeModules = flip Map.withoutKeys -- | 1. Any path that is beneath our current working directory will be -- stored as a normalised relative path diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs index 435a3e0d82..ce274b2f33 100644 --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -31,4 +31,4 @@ matchTypeOperators ss = matchOperators isBinOp extractOp fromOp reapply id fromOp _ = Nothing reapply :: a -> Qualified (OpName 'TypeOpName) -> SourceType -> SourceType -> SourceType - reapply _ op t1 t2 = srcTypeApp (srcTypeApp (TypeOp (ss, []) op) t1) t2 + reapply _ op = srcTypeApp . srcTypeApp (TypeOp (ss, []) op) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index f1f92e8afa..5cf3419a9a 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -202,11 +202,11 @@ entails SolverOptions{..} constraint context hints = valUndefined = Var nullSourceSpan (Qualified (Just C.Prim) (Ident C.undefined)) solve :: SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr - solve con = go 0 hints con + solve = go 0 hints where go :: Int -> [ErrorMessageHint] -> SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr go work _ (Constraint _ className' _ tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' - go work hints' con'@(Constraint _ className' kinds' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con') .) . runStateT . runWriterT $ do + go work hints' con@(Constraint _ className' kinds' tys' conInfo) = WriterT . StateT . (withErrorMessageHint (ErrorSolvingConstraint con) .) . runStateT . runWriterT $ do -- We might have unified types by solving other constraints, so we need to -- apply the latest substitution. latestSubst <- lift . lift $ gets checkSubstitution @@ -263,7 +263,7 @@ entails SolverOptions{..} constraint context hints = currentSubst' <- lift . lift $ gets checkSubstitution let subst'' = fmap (substituteType currentSubst') subst' -- Solve any necessary subgoals - args <- solveSubgoals subst'' (ErrorSolvingConstraint con') (tcdDependencies tcd) + args <- solveSubgoals subst'' (ErrorSolvingConstraint con) (tcdDependencies tcd) initDict <- lift . lift $ mkDictionary (tcdValue tcd) args diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index c63af80270..c820d1d08c 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -678,8 +678,8 @@ checkQuantification :: forall m. (MonadError MultipleErrors m) => SourceType -> m () -checkQuantification ty = - collectErrors . go [] [] . fst . fromJust . completeBinderList $ ty +checkQuantification = + collectErrors . go [] [] . fst . fromJust . completeBinderList where collectErrors vars = unless (null vars) diff --git a/tests/Language/PureScript/Ide/UsageSpec.hs b/tests/Language/PureScript/Ide/UsageSpec.hs index aa3083cc4c..51f3f7ac63 100644 --- a/tests/Language/PureScript/Ide/UsageSpec.hs +++ b/tests/Language/PureScript/Ide/UsageSpec.hs @@ -15,7 +15,7 @@ load :: [Text] -> Command load = LoadSync . map Test.mn usage :: P.ModuleName -> Text -> IdeNamespace -> Command -usage mn ident ns = FindUsages mn ident ns +usage = FindUsages shouldBeUsage :: P.SourceSpan -> (FilePath, Text) -> Expectation shouldBeUsage usage' (fp, range) = From aa0f7151a56f439bee3cacabacf37104a7c7be8d Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:34 -0400 Subject: [PATCH 1341/1580] HLint fix: "Use join" --- .hlint.yaml | 1 - app/Main.hs | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 7b09df7603..21e9af0868 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -10,7 +10,6 @@ - ignore: {name: "Use infix"} - ignore: {name: "Redundant do"} - ignore: {name: "Use newtype instead of data"} -- ignore: {name: "Use join"} - ignore: {name: "Fuse foldr/map"} - ignore: {name: "Use lambda-case"} - ignore: {name: "Avoid lambda"} diff --git a/app/Main.hs b/app/Main.hs index 8472b78751..7b0132d1e4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,6 +10,7 @@ import qualified Command.Hierarchy as Hierarchy import qualified Command.Ide as Ide import qualified Command.Publish as Publish import qualified Command.REPL as REPL +import Control.Monad (join) import Data.Foldable (fold) import qualified Options.Applicative as Opts import System.Environment (getArgs) @@ -24,8 +25,7 @@ main = do IO.hSetEncoding IO.stderr IO.utf8 IO.hSetBuffering IO.stdout IO.LineBuffering IO.hSetBuffering IO.stderr IO.LineBuffering - cmd <- Opts.handleParseResult . execParserPure opts =<< getArgs - cmd + join $ Opts.handleParseResult . execParserPure opts =<< getArgs where opts = Opts.info (versionInfo <*> Opts.helper <*> commands) infoModList infoModList = Opts.fullDesc <> headerInfo <> footerInfo From 4623ae533dd0ec885b3b8c528c3a9d9d4d44d6f8 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:34 -0400 Subject: [PATCH 1342/1580] HLint fix: "Use fmap" --- .hlint.yaml | 1 - src/Language/PureScript/TypeChecker/Kinds.hs | 4 ++-- src/Language/PureScript/TypeChecker/TypeSearch.hs | 2 +- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 21e9af0868..5b6950c7af 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -19,7 +19,6 @@ - ignore: {name: "Reduce duplication"} - ignore: {name: "Use camelCase"} - ignore: {name: "Functor law"} -- ignore: {name: "Use fmap"} - ignore: {name: "Avoid lambda using `infix`"} - ignore: {name: "Use const"} - ignore: {name: "Fuse mapM/map"} diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index c820d1d08c..5779099da1 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -617,8 +617,8 @@ inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do tyCtor = foldl (\ty -> srcKindApp ty . srcTypeVar . fst . snd) tyCtorName sigBinders tyCtor' = foldl (\ty -> srcTypeApp ty . srcTypeVar . fst) tyCtor tyArgs' ctorBinders = fmap (fmap (fmap Just)) $ sigBinders <> fmap (nullSourceAnn,) tyArgs' - for ctors $ \ctor -> - fmap (mkForAll ctorBinders) <$> inferDataConstructor tyCtor' ctor + for ctors $ + fmap (fmap (mkForAll ctorBinders)) . inferDataConstructor tyCtor' inferDataConstructor :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index 1e05fbd4f5..dcbc344e77 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -36,7 +36,7 @@ checkInEnvironment env st = . TC.runCheck' (st { TC.checkEnv = env }) evalWriterT :: Monad m => WriterT b m r -> m r -evalWriterT m = liftM fst (runWriterT m) +evalWriterT m = fmap fst (runWriterT m) checkSubsume :: Maybe [(P.Ident, Entailment.InstanceContext, P.SourceConstraint)] From 727724825f39d7541d6005190801ccdc0b56ade9 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:35 -0400 Subject: [PATCH 1343/1580] HLint fix: "Use const" --- .hlint.yaml | 1 - tests/TestPsci/TestEnv.hs | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 5b6950c7af..5bfb5dceef 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -20,7 +20,6 @@ - ignore: {name: "Use camelCase"} - ignore: {name: "Functor law"} - ignore: {name: "Avoid lambda using `infix`"} -- ignore: {name: "Use const"} - ignore: {name: "Fuse mapM/map"} diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 5f9e8587c7..5ac693aa1b 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -73,7 +73,7 @@ runAndEval comm jsOutputEval textOutputEval = Right commands -> -- The JS result is ignored, as it's already written in a JS source file. -- For the detail, please refer to Interactive.hs - traverse_ (handleCommand (\_ -> jsOutputEval) (return ()) textOutputEval) commands + traverse_ (handleCommand (const jsOutputEval) (return ()) textOutputEval) commands -- | Run a PSCi command, evaluate compiled JS, and ignore evaluation output and printed output run :: String -> TestPSCi () From 1bf3139c79cb8c5c362ad57ac7d73c7ff05f7ef0 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:35 -0400 Subject: [PATCH 1344/1580] HLint fix: "Use lambda-case" --- .hlint.yaml | 1 - .../src/Language/PureScript/Environment.hs | 9 ++++---- src/Language/PureScript/Docs/Types.hs | 2 +- .../PureScript/Ide/Filter/Declaration.hs | 23 +++++++++---------- src/Language/PureScript/TypeChecker.hs | 2 +- 5 files changed, 17 insertions(+), 20 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 5bfb5dceef..853948604c 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -11,7 +11,6 @@ - ignore: {name: "Redundant do"} - ignore: {name: "Use newtype instead of data"} - ignore: {name: "Fuse foldr/map"} -- ignore: {name: "Use lambda-case"} - ignore: {name: "Avoid lambda"} - ignore: {name: "Use tuple-section"} - ignore: {name: "Use record patterns"} diff --git a/lib/purescript-ast/src/Language/PureScript/Environment.hs b/lib/purescript-ast/src/Language/PureScript/Environment.hs index 0ce32275ec..f5aff65742 100644 --- a/lib/purescript-ast/src/Language/PureScript/Environment.hs +++ b/lib/purescript-ast/src/Language/PureScript/Environment.hs @@ -240,11 +240,10 @@ instance A.ToJSON DataDeclType where toJSON = A.toJSON . showDataDeclType instance A.FromJSON DataDeclType where - parseJSON = A.withText "DataDeclType" $ \str -> - case str of - "data" -> return Data - "newtype" -> return Newtype - other -> fail $ "invalid type: '" ++ T.unpack other ++ "'" + parseJSON = A.withText "DataDeclType" $ \case + "data" -> return Data + "newtype" -> return Newtype + other -> fail $ "invalid type: '" ++ T.unpack other ++ "'" -- | Construct a ProperName in the Prim module primName :: Text -> Qualified (ProperName a) diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 2f38bec48e..6dfc30cf4d 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -646,7 +646,7 @@ asFunDeps = eachInArray asFunDep asDataDeclType :: Parse PackageError P.DataDeclType asDataDeclType = - withText $ \s -> case s of + withText $ \case "data" -> Right P.Data "newtype" -> Right P.Newtype other -> Left (InvalidDataDeclType other) diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs index c98f03c5e8..563bd151e2 100644 --- a/src/Language/PureScript/Ide/Filter/Declaration.hs +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -19,20 +19,19 @@ data DeclarationType deriving (Show, Eq, Ord) instance FromJSON DeclarationType where - parseJSON = withText "Declaration type tag" $ \str -> - case str of - "value" -> pure Value - "type" -> pure Type - "synonym" -> pure Synonym - "dataconstructor" -> pure DataConstructor - "typeclass" -> pure TypeClass - "valueoperator" -> pure ValueOperator - "typeoperator" -> pure TypeOperator - "module" -> pure Module - s -> fail ("Unknown declaration type: " <> show s) + parseJSON = withText "Declaration type tag" $ \case + "value" -> pure Value + "type" -> pure Type + "synonym" -> pure Synonym + "dataconstructor" -> pure DataConstructor + "typeclass" -> pure TypeClass + "valueoperator" -> pure ValueOperator + "typeoperator" -> pure TypeOperator + "module" -> pure Module + s -> fail ("Unknown declaration type: " <> show s) instance ToJSON DeclarationType where - toJSON dt = toJSON $ case dt of + toJSON = toJSON . \case Value -> "value" :: Text Type -> "type" Synonym -> "synonym" diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 4d76d0ca85..0a169950a3 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -672,7 +672,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = pure $ checkSuperClassExport superClassesFor transitiveSuperClassesFor moduleClassExports :: S.Set (Qualified (ProperName 'ClassName)) - moduleClassExports = S.fromList $ mapMaybe (\x -> case x of + moduleClassExports = S.fromList $ mapMaybe (\case TypeClassRef _ name -> Just (qualify' name) _ -> Nothing) exps From 5b21792b95987d07eb87e766afe28b270455c463 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:35 -0400 Subject: [PATCH 1345/1580] HLint fix: "Use infix" --- .hlint.yaml | 1 - app/Command/Compile.hs | 2 +- lib/purescript-ast/src/Language/PureScript/Names.hs | 2 +- lib/purescript-cst/src/Language/PureScript/CST/Convert.hs | 4 ++-- src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/Ide/Filter.hs | 2 +- src/Language/PureScript/TypeChecker/Monad.hs | 2 +- 7 files changed, 7 insertions(+), 8 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 853948604c..b6ea4c9836 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -7,7 +7,6 @@ # Warnings currently triggered by your code -- ignore: {name: "Use infix"} - ignore: {name: "Redundant do"} - ignore: {name: "Use newtype instead of data"} - ignore: {name: "Fuse foldr/map"} diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 2a423c9526..4383e6b8e4 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -149,7 +149,7 @@ options = where -- Ensure that the JS target is included if sourcemaps are handleTargets :: [P.CodegenTarget] -> S.Set P.CodegenTarget - handleTargets ts = S.fromList (if elem P.JSSourceMap ts then P.JS : ts else ts) + handleTargets ts = S.fromList (if P.JSSourceMap `elem` ts then P.JS : ts else ts) pscMakeOptions :: Opts.Parser PSCMakeOptions pscMakeOptions = PSCMakeOptions <$> many inputFile diff --git a/lib/purescript-ast/src/Language/PureScript/Names.hs b/lib/purescript-ast/src/Language/PureScript/Names.hs index 7b94cceaac..6b3eaa4d20 100644 --- a/lib/purescript-ast/src/Language/PureScript/Names.hs +++ b/lib/purescript-ast/src/Language/PureScript/Names.hs @@ -174,7 +174,7 @@ moduleNameFromString :: Text -> ModuleName moduleNameFromString = ModuleName isBuiltinModuleName :: ModuleName -> Bool -isBuiltinModuleName (ModuleName mn) = mn == "Prim" || T.isPrefixOf "Prim." mn +isBuiltinModuleName (ModuleName mn) = mn == "Prim" || "Prim." `T.isPrefixOf` mn -- | -- A qualified name, i.e. a name with an optional module name diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs index 371ea54c4c..fc13db2c93 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs @@ -40,8 +40,8 @@ import Language.PureScript.CST.Types comment :: Comment a -> Maybe C.Comment comment = \case Comment t - | Text.isPrefixOf "{-" t -> Just $ C.BlockComment $ Text.drop 2 $ Text.dropEnd 2 t - | Text.isPrefixOf "--" t -> Just $ C.LineComment $ Text.drop 2 t + | "{-" `Text.isPrefixOf` t -> Just $ C.BlockComment $ Text.drop 2 $ Text.dropEnd 2 t + | "--" `Text.isPrefixOf` t -> Just $ C.LineComment $ Text.drop 2 t _ -> Nothing comments :: [Comment a] -> [C.Comment] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index b0d39db4e9..6fce239501 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -506,7 +506,7 @@ errorSuggestion err = case CST.errType pe of CST.WarnDeprecatedRowSyntax -> do let kind = CST.printTokens $ drop 1 toks - sugg | T.isPrefixOf " " kind = "Row" <> kind + sugg | " " `T.isPrefixOf` kind = "Row" <> kind | otherwise = "Row " <> kind suggest sugg CST.WarnDeprecatedForeignKindSyntax -> suggest $ "data " <> CST.printTokens (drop 3 toks) diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 0c887b9cab..4bca2e1275 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -102,7 +102,7 @@ applyDeclarationFilter f = case f of namespaceFilter' :: Set IdeNamespace -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] namespaceFilter' namespaces = - filter (\decl -> elem (namespaceForDeclaration (discardAnn decl)) namespaces) + filter (\decl -> namespaceForDeclaration (discardAnn decl) `elem` namespaces) exactFilter' :: Text -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] exactFilter' search = diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 3736aaa931..e9ae0a64ef 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -395,7 +395,7 @@ debugTypes = go <=< M.toList . types ExternData _ -> "extern" LocalTypeVariable -> "local" ScopedTypeVar -> "scoped" - guard (not (isPrefixOf "Prim" name)) + guard (not ("Prim" `isPrefixOf` name)) pure $ decl <> " " <> unpack name <> " :: " <> init ppTy debugNames :: Environment -> [String] From b9a27c463e87453b4cb419668c8cf4abfdf93348 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:35 -0400 Subject: [PATCH 1346/1580] HLint fix: "Use tuple-section" --- .hlint.yaml | 1 - .../src/Language/PureScript/AST/Traversals.hs | 4 ++-- .../src/Language/PureScript/Traversals.hs | 6 +++--- src/Language/PureScript/Bundle.hs | 2 +- src/Language/PureScript/Interactive/Directive.hs | 2 +- src/Language/PureScript/Renamer.hs | 4 ++-- src/Language/PureScript/Sugar/Names.hs | 14 +++++++------- src/Language/PureScript/TypeChecker/Types.hs | 2 +- 8 files changed, 17 insertions(+), 18 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index b6ea4c9836..6d8b838771 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -11,7 +11,6 @@ - ignore: {name: "Use newtype instead of data"} - ignore: {name: "Fuse foldr/map"} - ignore: {name: "Avoid lambda"} -- ignore: {name: "Use tuple-section"} - ignore: {name: "Use record patterns"} - ignore: {name: "Use section"} - ignore: {name: "Reduce duplication"} diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs b/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs index 6738363112..835aa840a7 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs @@ -131,7 +131,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds f' (ValueDecl sa name nameKind bs val) = ValueDecl sa name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val - f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds + f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (name, nameKind, ) <$> (g val >>= g')) ds f' (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f' <=< f) ds f' (TypeInstanceDeclaration sa ch idx name cs className args ds) = TypeInstanceDeclaration sa ch idx name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds f' (BoundValueDeclaration sa b expr) = BoundValueDeclaration sa <$> (h' <=< h) b <*> (g' <=< g) expr @@ -201,7 +201,7 @@ everywhereOnValuesM f g h = (f', g', h') f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f f' (ValueDecl sa name nameKind bs val) = ValueDecl sa name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val >>= f - f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f + f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (name, nameKind, ) <$> g' val) ds) >>= f f' (BoundValueDeclaration sa b expr) = (BoundValueDeclaration sa <$> h' b <*> g' expr) >>= f f' (TypeClassDeclaration sa name args implies deps ds) = (TypeClassDeclaration sa name args implies deps <$> traverse f' ds) >>= f f' (TypeInstanceDeclaration sa ch idx name cs className args ds) = (TypeInstanceDeclaration sa ch idx name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f diff --git a/lib/purescript-ast/src/Language/PureScript/Traversals.hs b/lib/purescript-ast/src/Language/PureScript/Traversals.hs index b4621d1a03..ce42f696b6 100644 --- a/lib/purescript-ast/src/Language/PureScript/Traversals.hs +++ b/lib/purescript-ast/src/Language/PureScript/Traversals.hs @@ -4,13 +4,13 @@ module Language.PureScript.Traversals where import Prelude.Compat fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b) -fstM f (a, b) = flip (,) b <$> f a +fstM f (a, b) = (, b) <$> f a sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c) -sndM f (a, b) = (,) a <$> f b +sndM f (a, b) = (a, ) <$> f b thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d) -thirdM f (a, b, c) = (,,) a b <$> f c +thirdM f (a, b, c) = (a, b, ) <$> f c pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d) pairM f g (a, b) = (,) <$> f a <*> g b diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index fb6239f54f..734c61da8c 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -311,7 +311,7 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) mapMaybe unPropertyIdentRef $ trailingCommaList props in - (map (\name -> (m, name, Internal)) shorthandNames, bn) + (map (m, , Internal) shorthandNames, bn) toReference (JSFunctionExpression _ _ _ params _ _) bn = ([], bn \\ mapMaybe unIdentifier (commaList params)) toReference e bn diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs index cee68efd35..3bb8a9b110 100644 --- a/src/Language/PureScript/Interactive/Directive.hs +++ b/src/Language/PureScript/Interactive/Directive.hs @@ -42,7 +42,7 @@ directiveStrings = directiveStrings' :: [(String, Directive)] directiveStrings' = concatMap go directiveStrings where - go (dir, strs) = map (\s -> (s, dir)) strs + go (dir, strs) = map (, dir) strs -- | -- List of all directive strings. diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index ace8223fac..b11ed65e39 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -134,7 +134,7 @@ renameInDecl isTopLevel (Rec ds) = do name' <- if isTopLevel then return name else updateScope name return ((a, name'), val) updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann) - updateValues (aname, val) = (,) aname <$> renameInValue val + updateValues (aname, val) = (aname, ) <$> renameInValue val -- | -- Renames within a value. @@ -146,7 +146,7 @@ renameInValue c@Constructor{} = return c renameInValue (Accessor ann prop v) = Accessor ann prop <$> renameInValue v renameInValue (ObjectUpdate ann obj vs) = - ObjectUpdate ann <$> renameInValue obj <*> traverse (\(name, v) -> (,) name <$> renameInValue v) vs + ObjectUpdate ann <$> renameInValue obj <*> traverse (\(name, v) -> (name, ) <$> renameInValue v) vs renameInValue e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = return e renameInValue (Abs ann name v) = newScope $ Abs ann <$> updateScope name <*> renameInValue v diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index b8676d5db1..5d6137e850 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -257,15 +257,15 @@ renameInModule imports (Module modSS coms mn decls exps) = throwError . errorMessage' pos $ OverlappingNamesInLet return ((pos, args ++ bound), Let w ds val') updateValue (_, bound) (Var ss name'@(Qualified Nothing ident)) | ident `notElem` bound = - (,) (ss, bound) <$> (Var ss <$> updateValueName name' ss) + ((ss, bound), ) <$> (Var ss <$> updateValueName name' ss) updateValue (_, bound) (Var ss name'@(Qualified (Just _) _)) = - (,) (ss, bound) <$> (Var ss <$> updateValueName name' ss) + ((ss, bound), ) <$> (Var ss <$> updateValueName name' ss) updateValue (_, bound) (Op ss op) = - (,) (ss, bound) <$> (Op ss <$> updateValueOpName op ss) + ((ss, bound), ) <$> (Op ss <$> updateValueOpName op ss) updateValue (_, bound) (Constructor ss name) = - (,) (ss, bound) <$> (Constructor ss <$> updateDataConstructorName name ss) + ((ss, bound), ) <$> (Constructor ss <$> updateDataConstructorName name ss) updateValue s (TypedValue check val ty) = - (,) s <$> (TypedValue check val <$> updateTypesEverywhere ty) + (s, ) <$> (TypedValue check val <$> updateTypesEverywhere ty) updateValue s v = return (s, v) updateBinder @@ -275,9 +275,9 @@ renameInModule imports (Module modSS coms mn decls exps) = updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((pos, bound), v) updateBinder (_, bound) (ConstructorBinder ss name b) = - (,) (ss, bound) <$> (ConstructorBinder ss <$> updateDataConstructorName name ss <*> pure b) + ((ss, bound), ) <$> (ConstructorBinder ss <$> updateDataConstructorName name ss <*> pure b) updateBinder (_, bound) (OpBinder ss op) = - (,) (ss, bound) <$> (OpBinder ss <$> updateValueOpName op ss) + ((ss, bound), ) <$> (OpBinder ss <$> updateValueOpName op ss) updateBinder s (TypedBinder t b) = do t' <- updateTypesEverywhere t return (s, TypedBinder t' b) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 1934dce7a7..966ebbe98a 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -464,7 +464,7 @@ inferLetBinding -> Expr -> (Expr -> m TypedValue') -> m ([Declaration], TypedValue') -inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) +inferLetBinding seen [] ret j = (seen, ) <$> withBindingGroupVisible (j ret) inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (TypedValue checkType val ty)] : rest) ret j = do moduleName <- unsafeCheckCurrentModule TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do From eee8599e0e4697cf5dfffa6d6fccc564f2c9ea5c Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 20:46:35 -0400 Subject: [PATCH 1347/1580] HLint fix: "Use camelCase" --- .hlint.yaml | 1 - app/Command/Publish.hs | 2 +- src/Language/PureScript/Publish/ErrorsWarnings.hs | 4 ++-- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 6d8b838771..aeb242ae9b 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -14,7 +14,6 @@ - ignore: {name: "Use record patterns"} - ignore: {name: "Use section"} - ignore: {name: "Reduce duplication"} -- ignore: {name: "Use camelCase"} - ignore: {name: "Functor law"} - ignore: {name: "Avoid lambda using `infix`"} - ignore: {name: "Fuse mapM/map"} diff --git a/app/Command/Publish.hs b/app/Command/Publish.hs index 84e5fe5a8d..930d48a79c 100644 --- a/app/Command/Publish.hs +++ b/app/Command/Publish.hs @@ -63,7 +63,7 @@ mkPublishOptions cliOpts = opts { publishGetVersion = return ("0.0.0", Version [0,0,0] []) , publishGetTagTime = const (liftIO getCurrentTime) - , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn + , publishWorkingTreeDirty = warn DirtyWorkingTreeWarn } else opts diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 83226dedec..4b4085da83 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -44,7 +44,7 @@ data PackageError data PackageWarning = NoResolvedVersion PackageName | UnacceptableVersion (PackageName, Text) - | DirtyWorkingTree_Warn + | DirtyWorkingTreeWarn deriving (Show) -- | An error that should be fixed by the user. @@ -314,7 +314,7 @@ collectWarnings = foldMap singular mempty { noResolvedVersions = [pn] } UnacceptableVersion t -> mempty { unacceptableVersions = [t] } - DirtyWorkingTree_Warn -> + DirtyWorkingTreeWarn -> mempty { dirtyWorkingTree = Any True } renderWarnings :: [PackageWarning] -> Box From 29a9d2dec7e25bc9c2ce44dea4959b6f3f98074b Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 13 May 2021 21:05:06 -0400 Subject: [PATCH 1348/1580] Update changelog --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index d980d4c7b2..ff13f1eeb1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -70,6 +70,8 @@ Internal: * Do less work in test initialization (#4080, @rhendric) +* Follow more HLint suggestions (#4090, @rhendric) + ## v0.14.1 New features: From ed37180e91201e334737730e3cbb656e21d75c5e Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 28 May 2021 17:27:37 -0700 Subject: [PATCH 1349/1580] Export `rebuildModule'` to speed up Try PureScript! slightly (#4095) * Export `rebuildModule'` from Make.hs Once exported, this function can be used in the `trypurescript` project to speed up the project slightly * Update changelog --- CHANGELOG.md | 2 ++ src/Language/PureScript/Make.hs | 1 + 2 files changed, 3 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index ff13f1eeb1..9873c8a2cb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -72,6 +72,8 @@ Internal: * Follow more HLint suggestions (#4090, @rhendric) +* Export `rebuildModule'` to speed up Try PureScript! slightly (#4095 by @JordanMartinez) + ## v0.14.1 New features: diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index a8df3cfea6..e17b0d5049 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -2,6 +2,7 @@ module Language.PureScript.Make ( -- * Make API rebuildModule + , rebuildModule' , make , inferForeignModules , module Monad From 45756eac952a5da67848340bb7529ef5d2b362cb Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sun, 30 May 2021 16:14:17 -0700 Subject: [PATCH 1350/1580] Merge purescript-ast into purescript-cst (#4094) * Move all AST code files into CST's corresponding folders * Merge purescript-ast.cabal into purescript-cst.cabal * Merge purescript-ast's Readme into purescript-cst's Readme * Remove the purescript-ast folder * Remove purescript-ast from references and build files * Update release guide * Add a changelog for this entry * Update description of purescript-cst library * Update version table to distinguish ast merge --- CHANGELOG.md | 2 + LICENSE | 18 ---- Makefile | 4 +- RELEASE_GUIDE.md | 18 +--- ci/build.sh | 2 - lib/purescript-ast/LICENSE | 13 --- lib/purescript-ast/README.md | 12 --- lib/purescript-ast/Setup.hs | 6 -- lib/purescript-ast/purescript-ast.cabal | 101 ------------------ lib/purescript-cst/README.md | 12 ++- lib/purescript-cst/purescript-cst.cabal | 38 ++++++- .../src/Control/Monad/Supply.hs | 0 .../src/Control/Monad/Supply/Class.hs | 0 .../src/Language/PureScript/AST.hs | 0 .../src/Language/PureScript/AST/Binders.hs | 0 .../Language/PureScript/AST/Declarations.hs | 0 .../PureScript/AST/Declarations/ChainId.hs | 0 .../src/Language/PureScript/AST/Exported.hs | 0 .../src/Language/PureScript/AST/Literals.hs | 0 .../src/Language/PureScript/AST/Operators.hs | 0 .../src/Language/PureScript/AST/SourcePos.hs | 0 .../src/Language/PureScript/AST/Traversals.hs | 0 .../src/Language/PureScript/Comments.hs | 0 .../src/Language/PureScript/Constants/Prim.hs | 0 .../src/Language/PureScript/Crash.hs | 0 .../src/Language/PureScript/Environment.hs | 0 .../src/Language/PureScript/Label.hs | 0 .../src/Language/PureScript/Names.hs | 0 .../src/Language/PureScript/PSString.hs | 0 .../src/Language/PureScript/Roles.hs | 0 .../src/Language/PureScript/Traversals.hs | 0 .../PureScript/TypeClassDictionaries.hs | 0 .../src/Language/PureScript/Types.hs | 0 purescript.cabal | 5 +- stack.yaml | 1 - 35 files changed, 52 insertions(+), 180 deletions(-) delete mode 100644 lib/purescript-ast/LICENSE delete mode 100644 lib/purescript-ast/README.md delete mode 100644 lib/purescript-ast/Setup.hs delete mode 100644 lib/purescript-ast/purescript-ast.cabal rename lib/{purescript-ast => purescript-cst}/src/Control/Monad/Supply.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Control/Monad/Supply/Class.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/AST.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/AST/Binders.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/AST/Declarations.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/AST/Declarations/ChainId.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/AST/Exported.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/AST/Literals.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/AST/Operators.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/AST/SourcePos.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/AST/Traversals.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/Comments.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/Constants/Prim.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/Crash.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/Environment.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/Label.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/Names.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/PSString.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/Roles.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/Traversals.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/TypeClassDictionaries.hs (100%) rename lib/{purescript-ast => purescript-cst}/src/Language/PureScript/Types.hs (100%) diff --git a/CHANGELOG.md b/CHANGELOG.md index 9873c8a2cb..2ad84346a7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -74,6 +74,8 @@ Internal: * Export `rebuildModule'` to speed up Try PureScript! slightly (#4095 by @JordanMartinez) +* Merge `purescript-ast` into `purescript-cst` (#4094 by @JordanMartinez) + ## v0.14.1 New features: diff --git a/LICENSE b/LICENSE index 3c5e36198a..0a4de0c5a8 100644 --- a/LICENSE +++ b/LICENSE @@ -132,7 +132,6 @@ PureScript uses the following Haskell library packages. Their license files foll process protolude psqueues - purescript-ast purescript-cst random regex-base @@ -4037,22 +4036,6 @@ psqueues LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -purescript-ast LICENSE file: - - Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other - contributors - All rights reserved. - - Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - - 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - - 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - purescript-cst LICENSE file: Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other @@ -5933,4 +5916,3 @@ zlib LICENSE file: CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - diff --git a/Makefile b/Makefile index a1faa87a74..2cba9b5918 100644 --- a/Makefile +++ b/Makefile @@ -19,10 +19,10 @@ help: ## Print documentation @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' ghcid: ## Run ghcid to quickly reload code on save. - ghcid --command "stack ghci purescript:exe:purs purescript:lib purescript:test:tests purescript-ast purescript-cst --main-is purescript:exe:purs --ghci-options -fno-code" + ghcid --command "stack ghci purescript:exe:purs purescript:lib purescript:test:tests purescript-cst --main-is purescript:exe:purs --ghci-options -fno-code" ghcid-test: ## Run ghcid to quickly reload code and run tests on save. - ghcid --command "stack ghci purescript:lib purescript:test:tests purescript-ast purescript-cst --ghci-options -fobject-code" \ + ghcid --command "stack ghci purescript:lib purescript:test:tests purescript-cst --ghci-options -fobject-code" \ --test "Main.main" build: ## Build the package. diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md index df1c22b0da..383aa541ab 100644 --- a/RELEASE_GUIDE.md +++ b/RELEASE_GUIDE.md @@ -55,18 +55,6 @@ considering what effects this may have: - The version to install in the `postinstall` script in `package.json` - - If `purescript-ast` has changed at all since the last release: - - - The `version` field in `lib/purescript-ast/purescript-ast.cabal` (note - that the new version should be based on the PVP, according to what - changed since the previous release, and not on the actual compiler - version) - - - The versions table in `lib/purescript-ast/README.md`, - - - The version bounds for `purescript-ast` in - `lib/purescript-cst/purescript-cst.cabal` and in `purescript.cabal` - - If `purescript-cst` has changed at all since the last release: - The `version` field in `lib/purescript-cst/purescript-cst.cabal` (note @@ -88,12 +76,10 @@ considering what effects this may have: - change to the `lib/purescript-cst` directory and run `stack upload .` - - change to the `lib/purescript-ast` directory and run `stack upload .` - - Finally, run `stack upload .` from the repo root directory. - It's a good idea to check that the three packages (`purescript`, - `purescript-cst`, and `purescript-ast`) can be installed from Hackage at this + It's a good idea to check that the two packages (`purescript` and + `purescript-cst`) can be installed from Hackage at this point. - After all of the prebuilt binaries are present on the GitHub releases page, diff --git a/ci/build.sh b/ci/build.sh index f45a15a323..404ff8384e 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -42,8 +42,6 @@ $STACK build --only-snapshot $STACK_OPTS (echo "::endgroup::"; echo "::group::Build source distributions") 2>/dev/null # Test in a source distribution (see above) -$STACK sdist lib/purescript-ast --tar-dir sdist-test/lib/purescript-ast -tar -xzf sdist-test/lib/purescript-ast/purescript-ast-*.tar.gz -C sdist-test/lib/purescript-ast --strip-components=1 $STACK sdist lib/purescript-cst --tar-dir sdist-test/lib/purescript-cst tar -xzf sdist-test/lib/purescript-cst/purescript-cst-*.tar.gz -C sdist-test/lib/purescript-cst --strip-components=1 $STACK sdist . --tar-dir sdist-test; diff --git a/lib/purescript-ast/LICENSE b/lib/purescript-ast/LICENSE deleted file mode 100644 index 7904c3e262..0000000000 --- a/lib/purescript-ast/LICENSE +++ /dev/null @@ -1,13 +0,0 @@ -Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other -contributors -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - -1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - -3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/lib/purescript-ast/README.md b/lib/purescript-ast/README.md deleted file mode 100644 index 4a65d10371..0000000000 --- a/lib/purescript-ast/README.md +++ /dev/null @@ -1,12 +0,0 @@ -# purescript-ast - -Defines the underlying syntax of the PureScript Programming Language. - -## Compiler compatibility - -We provide a table to make it a bit easier to map between versions of `purescript` and `purescript-ast`. - -| `purescript` | `purescript-ast` | -| --- | --- | -| `0.14.0` | `0.1.0.0` | -| `0.14.1` | `0.1.1.0` | diff --git a/lib/purescript-ast/Setup.hs b/lib/purescript-ast/Setup.hs deleted file mode 100644 index cd7b151a59..0000000000 --- a/lib/purescript-ast/Setup.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import Distribution.Simple - -main :: IO () -main = defaultMain diff --git a/lib/purescript-ast/purescript-ast.cabal b/lib/purescript-ast/purescript-ast.cabal deleted file mode 100644 index 86f69053bb..0000000000 --- a/lib/purescript-ast/purescript-ast.cabal +++ /dev/null @@ -1,101 +0,0 @@ -cabal-version: 2.4 - -name: purescript-ast -version: 0.1.1.0 -synopsis: PureScript Programming Language Abstract Syntax Tree -description: Defines the underlying syntax of the PureScript Programming Language. -category: Language -stability: experimental -homepage: https://www.purescript.org/ -bug-reports: https://github.com/purescript/purescript/issues -author: Phil Freeman -maintainer: Gary Burgess , Hardy Jones , Harry Garrood , Christoph Hegemann , Liam Goodacre , Nathan Faubion - -copyright: (c) 2013-17 Phil Freeman, (c) 2014-19 Gary Burgess, (c) other contributors (see CONTRIBUTORS.md) -license: BSD-3-Clause -license-file: LICENSE -build-type: Simple -extra-source-files: - README.md - -source-repository head - type: git - location: https://github.com/purescript/purescript - -common defaults - ghc-options: -Wall - default-language: Haskell2010 - default-extensions: - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveFoldable - DeriveTraversable - DeriveGeneric - DerivingStrategies - EmptyDataDecls - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving - KindSignatures - LambdaCase - MultiParamTypeClasses - NamedFieldPuns - NoImplicitPrelude - PatternGuards - PatternSynonyms - RankNTypes - RecordWildCards - OverloadedStrings - ScopedTypeVariables - TupleSections - TypeFamilies - ViewPatterns - build-depends: - aeson >=1.5.6.0 && <1.6, - base >=4.14.1.0 && <4.15, - base-compat >=0.11.2 && <0.12, - bytestring >=0.10.12.0 && <0.11, - containers >=0.6.2.1 && <0.7, - deepseq >=1.4.4.0 && <1.5, - filepath >=1.4.2.1 && <1.5, - microlens >=0.4.11.2 && <0.5, - mtl >=2.2.2 && <2.3, - protolude >=0.3.0 && <0.4, - scientific >=0.3.6.2 && <0.4, - serialise >=0.2.3.0 && <0.3, - text >=1.2.4.1 && <1.3, - vector >=0.12.1.2 && <0.13 - -library - import: defaults - hs-source-dirs: src - exposed-modules: - Control.Monad.Supply - Control.Monad.Supply.Class - Language.PureScript.AST - Language.PureScript.AST.Binders - Language.PureScript.AST.Declarations - Language.PureScript.AST.Declarations.ChainId - Language.PureScript.AST.Exported - Language.PureScript.AST.Literals - Language.PureScript.AST.Operators - Language.PureScript.AST.SourcePos - Language.PureScript.AST.Traversals - Language.PureScript.Comments - Language.PureScript.Constants.Prim - Language.PureScript.Crash - Language.PureScript.Environment - Language.PureScript.Label - Language.PureScript.Names - Language.PureScript.PSString - Language.PureScript.Roles - Language.PureScript.Traversals - Language.PureScript.TypeClassDictionaries - Language.PureScript.Types - other-modules: - Paths_purescript_ast - autogen-modules: - Paths_purescript_ast diff --git a/lib/purescript-cst/README.md b/lib/purescript-cst/README.md index 93eedc4cc1..ae69955b43 100644 --- a/lib/purescript-cst/README.md +++ b/lib/purescript-cst/README.md @@ -1,6 +1,6 @@ # purescript-cst -Defines the surface syntax of the PureScript Programming Language. +The parser for the PureScript programming language. ## Compiler compatibility @@ -8,5 +8,11 @@ We provide a table to make it a bit easier to map between versions of `purescrip | `purescript` | `purescript-cst` | | --- | --- | -| `0.14.0` | `0.1.0.0` | -| `0.14.1` | `0.1.1.0` | +| 0.14.2 | 0.2.0.0 | + +Before v0.14.2, there was a third package, `purescript-ast`. In v0.14.2, `purescript-ast` was merged into `purescript-cst`. + +| `purescript` | `purescript-cst` | `purescript-ast` | +| --- | --- | --- | +| 0.14.1 | 0.1.1.0 | 0.1.1.0 | +| 0.14.0 | 0.1.0.0 | 0.1.0.0 | diff --git a/lib/purescript-cst/purescript-cst.cabal b/lib/purescript-cst/purescript-cst.cabal index d3489bda0e..c59591df5b 100644 --- a/lib/purescript-cst/purescript-cst.cabal +++ b/lib/purescript-cst/purescript-cst.cabal @@ -3,7 +3,7 @@ cabal-version: 2.4 name: purescript-cst version: 0.1.1.0 synopsis: PureScript Programming Language Concrete Syntax Tree -description: The surface syntax of the PureScript Programming Language. +description: The parser for the PureScript programming language. category: Language stability: experimental homepage: http://www.purescript.org/ @@ -54,14 +54,24 @@ common defaults TypeFamilies ViewPatterns build-depends: + aeson >=1.5.6.0 && <1.6, array >=0.5.4.0 && <0.6, base >=4.14.1.0 && <4.15, + base-compat >=0.11.2 && <0.12, + bytestring >=0.10.12.0 && <0.11, containers >=0.6.2.1 && <0.7, + deepseq >=1.4.4.0 && <1.5, dlist >=0.8.0.8 && <0.9, - purescript-ast ==0.1.1.0, + filepath >=1.4.2.1 && <1.5, + microlens >=0.4.11.2 && <0.5, + mtl >=2.2.2 && <2.3, + protolude >=0.3.0 && <0.4, scientific >=0.3.6.2 && <0.4, semigroups >=0.19.1 && <0.20, - text >=1.2.4.1 && <1.3 + text >=1.2.4.1 && <1.3, + serialise >=0.2.3.0 && <0.3, + text >=1.2.4.1 && <1.3, + vector >=0.12.1.2 && <0.13 build-tool-depends: happy:happy ==1.20.0 @@ -69,6 +79,17 @@ library import: defaults hs-source-dirs: src exposed-modules: + Control.Monad.Supply + Control.Monad.Supply.Class + Language.PureScript.AST + Language.PureScript.AST.Binders + Language.PureScript.AST.Declarations + Language.PureScript.AST.Declarations.ChainId + Language.PureScript.AST.Exported + Language.PureScript.AST.Literals + Language.PureScript.AST.Operators + Language.PureScript.AST.SourcePos + Language.PureScript.AST.Traversals Language.PureScript.CST.Convert Language.PureScript.CST.Errors Language.PureScript.CST.Flatten @@ -82,6 +103,17 @@ library Language.PureScript.CST.Traversals.Type Language.PureScript.CST.Types Language.PureScript.CST.Utils + Language.PureScript.Comments + Language.PureScript.Constants.Prim + Language.PureScript.Crash + Language.PureScript.Environment + Language.PureScript.Label + Language.PureScript.Names + Language.PureScript.PSString + Language.PureScript.Roles + Language.PureScript.Traversals + Language.PureScript.TypeClassDictionaries + Language.PureScript.Types other-modules: Data.Text.PureScript Paths_purescript_cst diff --git a/lib/purescript-ast/src/Control/Monad/Supply.hs b/lib/purescript-cst/src/Control/Monad/Supply.hs similarity index 100% rename from lib/purescript-ast/src/Control/Monad/Supply.hs rename to lib/purescript-cst/src/Control/Monad/Supply.hs diff --git a/lib/purescript-ast/src/Control/Monad/Supply/Class.hs b/lib/purescript-cst/src/Control/Monad/Supply/Class.hs similarity index 100% rename from lib/purescript-ast/src/Control/Monad/Supply/Class.hs rename to lib/purescript-cst/src/Control/Monad/Supply/Class.hs diff --git a/lib/purescript-ast/src/Language/PureScript/AST.hs b/lib/purescript-cst/src/Language/PureScript/AST.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/AST.hs rename to lib/purescript-cst/src/Language/PureScript/AST.hs diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs b/lib/purescript-cst/src/Language/PureScript/AST/Binders.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/AST/Binders.hs rename to lib/purescript-cst/src/Language/PureScript/AST/Binders.hs diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs rename to lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations/ChainId.hs b/lib/purescript-cst/src/Language/PureScript/AST/Declarations/ChainId.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/AST/Declarations/ChainId.hs rename to lib/purescript-cst/src/Language/PureScript/AST/Declarations/ChainId.hs diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Exported.hs b/lib/purescript-cst/src/Language/PureScript/AST/Exported.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/AST/Exported.hs rename to lib/purescript-cst/src/Language/PureScript/AST/Exported.hs diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Literals.hs b/lib/purescript-cst/src/Language/PureScript/AST/Literals.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/AST/Literals.hs rename to lib/purescript-cst/src/Language/PureScript/AST/Literals.hs diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Operators.hs b/lib/purescript-cst/src/Language/PureScript/AST/Operators.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/AST/Operators.hs rename to lib/purescript-cst/src/Language/PureScript/AST/Operators.hs diff --git a/lib/purescript-ast/src/Language/PureScript/AST/SourcePos.hs b/lib/purescript-cst/src/Language/PureScript/AST/SourcePos.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/AST/SourcePos.hs rename to lib/purescript-cst/src/Language/PureScript/AST/SourcePos.hs diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs b/lib/purescript-cst/src/Language/PureScript/AST/Traversals.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/AST/Traversals.hs rename to lib/purescript-cst/src/Language/PureScript/AST/Traversals.hs diff --git a/lib/purescript-ast/src/Language/PureScript/Comments.hs b/lib/purescript-cst/src/Language/PureScript/Comments.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/Comments.hs rename to lib/purescript-cst/src/Language/PureScript/Comments.hs diff --git a/lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs b/lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/Constants/Prim.hs rename to lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs diff --git a/lib/purescript-ast/src/Language/PureScript/Crash.hs b/lib/purescript-cst/src/Language/PureScript/Crash.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/Crash.hs rename to lib/purescript-cst/src/Language/PureScript/Crash.hs diff --git a/lib/purescript-ast/src/Language/PureScript/Environment.hs b/lib/purescript-cst/src/Language/PureScript/Environment.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/Environment.hs rename to lib/purescript-cst/src/Language/PureScript/Environment.hs diff --git a/lib/purescript-ast/src/Language/PureScript/Label.hs b/lib/purescript-cst/src/Language/PureScript/Label.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/Label.hs rename to lib/purescript-cst/src/Language/PureScript/Label.hs diff --git a/lib/purescript-ast/src/Language/PureScript/Names.hs b/lib/purescript-cst/src/Language/PureScript/Names.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/Names.hs rename to lib/purescript-cst/src/Language/PureScript/Names.hs diff --git a/lib/purescript-ast/src/Language/PureScript/PSString.hs b/lib/purescript-cst/src/Language/PureScript/PSString.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/PSString.hs rename to lib/purescript-cst/src/Language/PureScript/PSString.hs diff --git a/lib/purescript-ast/src/Language/PureScript/Roles.hs b/lib/purescript-cst/src/Language/PureScript/Roles.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/Roles.hs rename to lib/purescript-cst/src/Language/PureScript/Roles.hs diff --git a/lib/purescript-ast/src/Language/PureScript/Traversals.hs b/lib/purescript-cst/src/Language/PureScript/Traversals.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/Traversals.hs rename to lib/purescript-cst/src/Language/PureScript/Traversals.hs diff --git a/lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs b/lib/purescript-cst/src/Language/PureScript/TypeClassDictionaries.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/TypeClassDictionaries.hs rename to lib/purescript-cst/src/Language/PureScript/TypeClassDictionaries.hs diff --git a/lib/purescript-ast/src/Language/PureScript/Types.hs b/lib/purescript-cst/src/Language/PureScript/Types.hs similarity index 100% rename from lib/purescript-ast/src/Language/PureScript/Types.hs rename to lib/purescript-cst/src/Language/PureScript/Types.hs diff --git a/purescript.cabal b/purescript.cabal index a746132352..dde6260d38 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -97,7 +97,7 @@ common defaults -- update to a newer snapshot as follows: -- -- 1. Remove all version constraints from this cabal file (apart from - -- language-javascript, purescript-cst, and purescript-ast). + -- language-javascript and purescript-cst). -- 2. Update stack.yaml as required to select a new snapshot, and check -- everything builds correctly with stack. -- 3. Run `stack sdist`; this will produce a source distribution including @@ -111,7 +111,7 @@ common defaults -- built with (almost) the same install plan for both cabal and stack -- users. -- - -- We need to be especially careful with purescript-cst, purescript-ast, + -- We need to be especially careful with purescript-cst -- and language-javascript, because they all form part of the compiler's -- public API. In the case of language-javascript specifically, all FFI -- modules must be parseable by this library otherwise the compiler @@ -159,7 +159,6 @@ common defaults pattern-arrows >=0.0.2 && <0.1, process >=1.6.9.0 && <1.7, protolude >=0.3.0 && <0.4, - purescript-ast ==0.1.1.0, purescript-cst ==0.1.1.0, regex-tdfa >=1.3.1.0 && <1.4, safe >=0.3.19 && <0.4, diff --git a/stack.yaml b/stack.yaml index fce38e1d0e..2717a09caf 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,7 +2,6 @@ resolver: lts-17.6 pvp-bounds: both packages: - '.' -- lib/purescript-ast - lib/purescript-cst ghc-options: # Build with advanced optimizations enabled by default From 40dd447b2acd51c206c48cf3dcedada1e4b94594 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 4 Jun 2021 20:31:27 -0700 Subject: [PATCH 1351/1580] Bump versions for v0.14.2 (#4103) * Regenerate LICENSE * Bump versions for v0.14.2 release * Update changelog for v0.14.2; create new 'Unreleased' section --- CHANGELOG.md | 10 +++++++- LICENSE | 31 +------------------------ lib/purescript-cst/purescript-cst.cabal | 2 +- npm-package/package.json | 4 ++-- purescript.cabal | 4 ++-- 5 files changed, 15 insertions(+), 36 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2ad84346a7..f015c09bc9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,14 @@ Breaking changes: New features: +Bugfixes: + +Internal: + +## v0.14.2 + +New features: + * Make type class instance names optional (#4085, @JordanMartinez) Previously, one would be required to define a unique name for a type class @@ -46,7 +54,7 @@ New features: Bugfixes: * Unused identifier warnings now report smaller and more relevant source spans (#4088, @nwolverson) - + Also fix incorrect warnings in cases involving a let-pattern binding shadowing an existing identifier. diff --git a/LICENSE b/LICENSE index 0a4de0c5a8..87d2b2f910 100644 --- a/LICENSE +++ b/LICENSE @@ -156,7 +156,6 @@ PureScript uses the following Haskell library packages. Their license files foll tagged tagsoup template-haskell - terminfo text th-abstraction th-compat @@ -4845,35 +4844,6 @@ template-haskell LICENSE file: DAMAGE. -terminfo LICENSE file: - - Copyright 2007, Judah Jacobson. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - 1. Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - - 3. Neither the name of the copyright holder nor the names of its contributors - may be used to endorse or promote products derived from this software without - specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - text LICENSE file: Copyright (c) 2008-2009, Tom Harper @@ -5916,3 +5886,4 @@ zlib LICENSE file: CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/lib/purescript-cst/purescript-cst.cabal b/lib/purescript-cst/purescript-cst.cabal index c59591df5b..c09705aee5 100644 --- a/lib/purescript-cst/purescript-cst.cabal +++ b/lib/purescript-cst/purescript-cst.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: purescript-cst -version: 0.1.1.0 +version: 0.2.0.0 synopsis: PureScript Programming Language Concrete Syntax Tree description: The parser for the PureScript programming language. category: Language diff --git a/npm-package/package.json b/npm-package/package.json index 033b29acd6..8a4be9ee47 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.14.1", + "version": "0.14.2", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.14.1", + "postinstall": "install-purescript --purs-ver=0.14.2", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index dde6260d38..1eb9e9d795 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.14.1 +version: 0.14.2 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language @@ -159,7 +159,7 @@ common defaults pattern-arrows >=0.0.2 && <0.1, process >=1.6.9.0 && <1.7, protolude >=0.3.0 && <0.4, - purescript-cst ==0.1.1.0, + purescript-cst ==0.2.0.0, regex-tdfa >=1.3.1.0 && <1.4, safe >=0.3.19 && <0.4, scientific >=0.3.6.2 && <0.4, From 83f0a3c3d60831cbb1b73464eea93771bd18f3bb Mon Sep 17 00:00:00 2001 From: ncaq Date: Wed, 9 Jun 2021 04:17:47 +0900 Subject: [PATCH 1352/1580] Fix errors when generating Haddocks (#4073) * added: ci: stack: --haddock check haddock in ci. * fixed: avoid haddock error * updated: CHANGELOG.md * added: ci/build.sh: haddock reason comment Apply from code review. > We have gone back and forth on this a couple of times, so I think we should add a comment explaining why it is necessary so that it doesn't get removed again later to speed CI up. For example: > > * added: CONTRIBUTORS.md: ncaq * Update src/Language/PureScript/TypeChecker/Kinds.hs Co-authored-by: Harry Garrood * Update src/Language/PureScript/TypeChecker/Kinds.hs Co-authored-by: Harry Garrood * Update src/Language/PureScript/TypeChecker/Kinds.hs Co-authored-by: Harry Garrood * Update src/Language/PureScript/TypeChecker/Kinds.hs Co-authored-by: Harry Garrood * Fix text wrapping issue * Put inlined comments underneath the part they are documenting * Be consistent with all other changes * Fix changelog Co-authored-by: Harry Garrood Co-authored-by: JordanMartinez --- CHANGELOG.md | 2 ++ CONTRIBUTORS.md | 1 + ci/build.sh | 4 +++- src/Language/PureScript/TypeChecker/Kinds.hs | 16 ++++++++-------- src/Language/PureScript/TypeChecker/Roles.hs | 16 +++++++++------- 5 files changed, 23 insertions(+), 16 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f015c09bc9..15a7c28545 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,8 @@ Bugfixes: Internal: +* Fix for Haddock (#4072 by @ncaq and @JordanMartinez) + ## v0.14.2 New features: diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 755613f315..2eaf3a639d 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -83,6 +83,7 @@ If you would prefer to use different terms, please use the section below instead | [@mpietrzak](https://github.com/mpietrzak) | Maciej Pietrzak | [MIT license](http://opensource.org/licenses/MIT) | | [@mrhania](https://github.com/mrhania) | Łukasz Hanuszczak | [MIT license](http://opensource.org/licenses/MIT) | | [@natefaubion](https://github.com/natefaubion) | Nathan Faubion | [MIT license](http://opensource.org/licenses/MIT) | +| [@ncaq](https://github.com/ncaq) | ncaq | [MIT license](http://opensource.org/licenses/MIT) | | [@nicodelpiano](https://github.com/nicodelpiano) | Nicolas Del Piano | [MIT license](http://opensource.org/licenses/MIT) | | [@noraesae](https://github.com/noraesae) | Hyunje Jun | [MIT license](http://opensource.org/licenses/MIT) | | [@nullobject](https://github.com/nullobject) | Josh Bassett | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/ci/build.sh b/ci/build.sh index 404ff8384e..cd60c07dd1 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -23,7 +23,9 @@ set -ex # for compilation or for tests in our package.yaml file (these sorts of issues # don't test to get noticed until after releasing otherwise). -STACK="stack --no-terminal --jobs=2" +# We test with --haddock because haddock generation can fail if there is invalid doc-comment syntax, +# and these failures are very easy to miss otherwise. +STACK="stack --no-terminal --haddock --jobs=2" STACK_OPTS="--test" if [ "$CI_RELEASE" = "true" ] diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 5779099da1..9749020227 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -588,9 +588,9 @@ type DataDeclarationArgs = type DataDeclarationResult = ( [(DataConstructorDeclaration, SourceType)] - -- ^ The infered type signatures of data constructors + -- The infered type signatures of data constructors , SourceType - -- ^ The inferred kind of the declaration + -- The inferred kind of the declaration ) kindOfData @@ -639,9 +639,9 @@ type TypeDeclarationArgs = type TypeDeclarationResult = ( SourceType - -- ^ The elaborated rhs of the declaration + -- The elaborated rhs of the declaration , SourceType - -- ^ The inferred kind of the declaration + -- The inferred kind of the declaration ) kindOfTypeSynonym @@ -752,13 +752,13 @@ type ClassDeclarationArgs = type ClassDeclarationResult = ( [(Text, SourceType)] - -- ^ The kind annotated class arguments + -- The kind annotated class arguments , [SourceConstraint] - -- ^ The kind annotated superclass constraints + -- The kind annotated superclass constraints , [Declaration] - -- ^ The kind annotated declarations + -- The kind annotated declarations , SourceType - -- ^ The inferred kind of the declaration + -- The inferred kind of the declaration ) kindOfClass diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index e99e9878d9..4c283a0972 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -205,13 +205,15 @@ inferDataDeclarationRoles moduleName (tyName, tyArgs, ctors) roleEnv = -- arguments, recursively infer the roles of the type constructor's -- arguments. For each (role, argument) pair: -- - -- * If the role is nominal, mark all free variables in the - -- argument as nominal also, since they cannot be coerced if the - -- argument's nominality is to be preserved. - -- * If the role is representational, recurse on the argument, since - -- its use of our parameters is important. - -- * If the role is phantom, terminate, since the argument's use of - -- our parameters is unimportant. + -- - If the role is nominal, mark all free variables in the argument + -- as nominal also, since they cannot be coerced if the + -- argument's nominality is to be preserved. + -- + -- - If the role is representational, recurse on the argument, since + -- its use of our parameters is important. + -- + -- - If the role is phantom, terminate, since the argument's use of + -- our parameters is unimportant. TypeConstructor _ t1Name -> let t1Roles = fromMaybe (repeat Phantom) $ M.lookup t1Name roleEnv From 8d18bb03812bfe3b57a28cf9d2be623dc31e032f Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 8 Jun 2021 17:52:44 -0700 Subject: [PATCH 1353/1580] Proposal: edits to RELEASE_GUIDE.md (#4104) * Add pre-reqs section to release_guide.md * Remove 'write release notes' as we copy-paste CHANGELOG.md now * Provide clearer directions on compiling package set & checking INSTALL.md * Link to tools * Add changelog entry --- CHANGELOG.md | 2 ++ RELEASE_GUIDE.md | 50 ++++++++++++++++++++++++++++++++++++++---------- 2 files changed, 42 insertions(+), 10 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 15a7c28545..cfd2ad7d10 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,6 +14,8 @@ Internal: * Fix for Haddock (#4072 by @ncaq and @JordanMartinez) +* Update RELEASE_GUIDE.md with more details (#4104 by @JordanMartinez) + ## v0.14.2 New features: diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md index 383aa541ab..c44fca0901 100644 --- a/RELEASE_GUIDE.md +++ b/RELEASE_GUIDE.md @@ -1,15 +1,45 @@ # Release Guide (for maintainers) +## Prerequisites + +- You will need a [Hackage](https://hackage.haskell.org/) account that has been invited to be a maintainer of the `purescript` package on Hackage. If you don't have one, create one and ask to be invited as a maintainer. +- You will need an [NPM](https://www.npmjs.com/) account that has been invited to be a maintainer of the `purescript` package on NPM. If you don't have one, create one and ask to be invited as a maintainer. +- You need `spago` installed. +- You need to be logged into NPM (i.e. running `npm whoami` should print your NPM account's username) + ## Before making a release - Check that there are no unintended breaking changes by compiling [the latest package set](https://github.com/purescript/package-sets/releases/latest) -- Check that INSTALL.md is up-to-date -- Regenerate LICENSE: `make license-generator` (see `license-generator/` for - details) -- Write release notes -Additionally, if there are any breaking changes, there are number of downstream -projects who we should probably at least notify: +```bash +stack build +mkdir wPackageSet +pushd wPackageSet +spago init +spago upgrade-set +# install all packages in the set +spago install $(spago ls packages | cut -f 1 -d ' ' | tr '\n' ' ') + +# Verify that code compiles and docs are properly created +stack exec bash < Date: Fri, 11 Jun 2021 20:33:25 -0700 Subject: [PATCH 1354/1580] Fix unnamed instance docs issue (#4111) * Fix unnamed instance docs issue * Update changelog --- CHANGELOG.md | 2 ++ src/Language/PureScript/Docs/Convert/Single.hs | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index cfd2ad7d10..f16116729d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,8 @@ New features: Bugfixes: +* Ensure unnamed instances appear in documentation (#4109 by @JordanMartinez) + Internal: * Fix for Haddock (#4072 by @ncaq and @JordanMartinez) diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 3199d669d5..4099ce6618 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -94,7 +94,7 @@ getDeclarationTitle (P.DataDeclaration _ _ name _ _) = Just (P.runProperName nam getDeclarationTitle (P.ExternDataDeclaration _ name _) = Just (P.runProperName name) getDeclarationTitle (P.TypeSynonymDeclaration _ name _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeClassDeclaration _ name _ _ _ _) = Just (P.runProperName name) -getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ name _ _ _ _) = P.showIdent <$> hush name +getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ name _ _ _ _) = Just $ either (const "") P.showIdent name getDeclarationTitle (P.TypeFixityDeclaration _ _ _ op) = Just ("type " <> P.showOp op) getDeclarationTitle (P.ValueFixityDeclaration _ _ _ op) = Just (P.showOp op) getDeclarationTitle _ = Nothing From ee691c2509a4e8152d3a35c88e820bb1685f7512 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Fri, 18 Jun 2021 21:40:44 -0400 Subject: [PATCH 1355/1580] Allow fixity, kind, role declarations in REPL (#4046) It seems that advances in parsing and/or interpretation have made the artificial restriction that used to exist on declarations in the REPL no longer necessary. Fixity, kind, and role declarations are all tested and working, and the only other types of declarations that exist in the AST at this time are imports (which are specially handled in an earlier parser), BoundValueDeclarations (which can't be created at the top level), and binding groups (which are only created in desugaring). --- CHANGELOG.md | 2 ++ src/Language/PureScript/Interactive/Parser.hs | 25 ++----------------- tests/purs/psci/BasicEval.purs | 9 +++++++ tests/purs/psci/Multiline.purs | 5 ++++ 4 files changed, 18 insertions(+), 23 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f16116729d..fecde031cb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,8 @@ Bugfixes: * Ensure unnamed instances appear in documentation (#4109 by @JordanMartinez) +* Allow fixity, kind, role declarations in REPL (#4046, @rhendric) + Internal: * Fix for Haddock (#4072 by @ncaq and @JordanMartinez) diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index 9d3ff1cb2c..efa510a5c5 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -8,7 +8,7 @@ module Language.PureScript.Interactive.Parser import Prelude.Compat hiding (lex) -import Control.Monad (join, unless) +import Control.Monad (join) import Data.Bifunctor (bimap) import Data.Char (isSpace) import Data.List (intercalate) @@ -17,7 +17,6 @@ import qualified Data.Text as T import qualified Language.PureScript as P import qualified Language.PureScript.CST as CST import qualified Language.PureScript.CST.Monad as CSTM -import qualified Language.PureScript.CST.Positions as CST import qualified Language.PureScript.Interactive.Directive as D import Language.PureScript.Interactive.Types @@ -128,27 +127,7 @@ psciImport filePath = do -- | Any declaration that we don't need a 'special case' parser for -- (like import declarations). psciDeclaration :: CST.Parser Command -psciDeclaration = do - decl <- CST.parseDeclP - let decl' = CST.convertDeclaration "" decl - unless (all acceptable decl') $ do - let - tok = fst $ CST.declRange decl - tok' = T.unpack $ CST.printToken $ CST.tokValue tok - msg = tok' <> "; this kind of declaration is not supported in psci" - CSTM.parseFail tok $ CST.ErrLexeme (Just msg) [] - pure $ Decls decl' - -acceptable :: P.Declaration -> Bool -acceptable P.DataDeclaration{} = True -acceptable P.TypeSynonymDeclaration{} = True -acceptable P.ExternDeclaration{} = True -acceptable P.ExternDataDeclaration{} = True -acceptable P.TypeClassDeclaration{} = True -acceptable P.TypeInstanceDeclaration{} = True -acceptable P.TypeDeclaration{} = True -acceptable P.ValueDeclaration{} = True -acceptable _ = False +psciDeclaration = Decls . CST.convertDeclaration "" <$> CST.parseDeclP parseReplQuery' :: String -> Either String ReplQuery parseReplQuery' str = diff --git a/tests/purs/psci/BasicEval.purs b/tests/purs/psci/BasicEval.purs index 2722a71081..1a909cd41e 100644 --- a/tests/purs/psci/BasicEval.purs +++ b/tests/purs/psci/BasicEval.purs @@ -8,3 +8,12 @@ fac n = foldl mul 1 (1..n) -- @shouldEvaluateTo 3628800 fac 10 + +infix 4 mul as |*| + +-- @shouldEvaluateTo 50 +5 |*| 10 + +data X a = X + +type role X representational diff --git a/tests/purs/psci/Multiline.purs b/tests/purs/psci/Multiline.purs index c12f543732..aa023827b7 100644 --- a/tests/purs/psci/Multiline.purs +++ b/tests/purs/psci/Multiline.purs @@ -10,3 +10,8 @@ fac n = foldl mul 1 (1..n) -- @shouldEvaluateTo 3628800 fac 10 + +-- @paste +data X :: Type -> Type +data X a = X +-- @paste From 5aee79e28053b0556978a97f82aa6571528c3a89 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Sun, 20 Jun 2021 00:09:37 +0300 Subject: [PATCH 1356/1580] Pin OS versions in CI, instead of using the latest (#4113) --- .github/workflows/ci.yml | 2 +- CHANGELOG.md | 2 ++ CONTRIBUTORS.md | 1 + 3 files changed, 4 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 78e0047d3f..8b822b5c69 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -20,7 +20,7 @@ jobs: strategy: fail-fast: false # do not cancel builds for other OSes if one fails matrix: - os: [ "ubuntu-latest", "macOS-latest", "windows-latest" ] + os: [ "ubuntu-18.04", "macOS-10.15", "windows-2016" ] runs-on: "${{ matrix.os }}" diff --git a/CHANGELOG.md b/CHANGELOG.md index fecde031cb..8414db8a2f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,6 +14,8 @@ Bugfixes: * Allow fixity, kind, role declarations in REPL (#4046, @rhendric) +* Pin OS versions used in CI (#4107, @f-f) + Internal: * Fix for Haddock (#4072 by @ncaq and @JordanMartinez) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 2eaf3a639d..1dd3ff21f9 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -52,6 +52,7 @@ If you would prefer to use different terms, please use the section below instead | [@felixSchl](https://github.com/felixSchl) | Felix Schlitter | [MIT license](http://opensource.org/licenses/MIT) | | [@FrigoEU](https://github.com/FrigoEU) | Simon Van Casteren | [MIT license](http://opensource.org/licenses/MIT) | | [@fsoikin](https://github.com/fsoikin) | Fyodor Soikin | [MIT license](http://opensource.org/licenses/MIT) | +| [@f-f](https://github.com/f-f) | Fabrizio Ferrai | [MIT license](http://opensource.org/licenses/MIT) | | [@garyb](https://github.com/garyb) | Gary Burgess | [MIT license](http://opensource.org/licenses/MIT) | | [@hdgarrood](https://github.com/hdgarrood) | Harry Garrood | [MIT license](http://opensource.org/licenses/MIT) | | [@houli](https://github.com/houli) | Eoin Houlihan | [MIT license](http://opensource.org/licenses/MIT) | From 179dd00e37119b4ef32cb8f44ba7a6cd51582eab Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Sun, 20 Jun 2021 13:34:44 +0100 Subject: [PATCH 1357/1580] Fix UnusedName for multiple non-recursive let bindings (#4114) - When there are multiple let bindings in a single let declaration, ensure that non-recursive bindings are checked properly with respect to subsequent declarations Fix #4110 Co-authored-by: JordanMartinez --- CHANGELOG.md | 2 ++ src/Language/PureScript/Linter.hs | 27 +++++++++++------- tests/purs/warning/UnusedVar.out | 44 ++++++++++++++++++----------- tests/purs/warning/UnusedVar.purs | 37 +++++++++++++++++++++++- tests/purs/warning/UnusedVarDo.purs | 8 ++++++ 5 files changed, 91 insertions(+), 27 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8414db8a2f..26dafb6363 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,6 +16,8 @@ Bugfixes: * Pin OS versions used in CI (#4107, @f-f) +* Fix UnusedName warnings for multiple non-recursive let bindings (#4114 by @nwolverson) + Internal: * Fix for Haddock (#4072 by @ncaq and @JordanMartinez) diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 2b5c3b6326..77393f69bd 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -189,11 +189,8 @@ lintUnused (Module modSS _ mn modDecls exports) = go (Var _ (Qualified Nothing v)) = (S.singleton v, mempty) go (Var _ _) = (S.empty, mempty) - go (Let _ ds e) = - let (letNames, letNamesRec) = foldMap declIdents ds - in removeAndWarn letNamesRec $ - removeAndWarn letNames (go e) - <> mconcat (map underDecl ds) + go (Let _ ds e) = onDecls ds (go e) + go (Abs binder v1) = let newNames = S.fromList (binderNamesWithSpans binder) in @@ -249,11 +246,8 @@ lintUnused (Module modSS _ mn modDecls exports) = let bindNewNames = S.fromList (binderNamesWithSpans binder) in go e <> removeAndWarn bindNewNames (doElts rest v) - doElts (DoNotationLet ds : rest) v = - let (letNewNames, letNewNamesRec) = foldMap declIdents ds - in removeAndWarn letNewNamesRec $ - mconcat (map underDecl ds) - <> removeAndWarn letNewNames (doElts rest v) + doElts (DoNotationLet ds : rest) v = onDecls ds (doElts rest v) + doElts (PositionedDoNotationElement _ _ e : rest) v = doElts (e : rest) v doElts [] (Just e) = go e <> (rebindable, mempty) doElts [] Nothing = (rebindable, mempty) @@ -264,6 +258,19 @@ lintUnused (Module modSS _ mn modDecls exports) = declIdents (BoundValueDeclaration _ binders _) = (S.fromList $ binderNamesWithSpans binders, S.empty) declIdents _ = (S.empty, S.empty) + onDecls :: [ Declaration ] -> (S.Set Ident, MultipleErrors) -> (S.Set Ident, MultipleErrors) + onDecls ds errs = + let + onDecl d (accErrs, accLetNamesRec) = + let (letNames, recNames) = declIdents d + dErrs = underDecl d + errs' = dErrs <> removeAndWarn letNames accErrs + in + (errs', accLetNamesRec <> recNames) + (errs'', letNamesRec) = foldr onDecl (errs, S.empty) ds + in + removeAndWarn letNamesRec errs'' + -- let f x = e -- check the x in e (but not the f) underDecl (ValueDecl _ _ _ binders gexprs) = let bindNewNames = S.fromList (concatMap binderNamesWithSpans binders) diff --git a/tests/purs/warning/UnusedVar.out b/tests/purs/warning/UnusedVar.out index 6c5350e9e8..7556b6ebb6 100644 --- a/tests/purs/warning/UnusedVar.out +++ b/tests/purs/warning/UnusedVar.out @@ -1,7 +1,7 @@ -Warning 1 of 8: +Warning 1 of 9: in module Main - at tests/purs/warning/UnusedVar.purs:15:20 - 15:32 (line 15, column 20 - line 15, column 32) + at tests/purs/warning/UnusedVar.purs:16:20 - 16:32 (line 16, column 20 - line 16, column 32) Name lambdaUnused was introduced but not used. @@ -10,10 +10,10 @@ Warning 1 of 8: See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, or to contribute content related to this warning. -Warning 2 of 8: +Warning 2 of 9: in module Main - at tests/purs/warning/UnusedVar.purs:19:7 - 19:20 (line 19, column 7 - line 19, column 20) + at tests/purs/warning/UnusedVar.purs:20:7 - 20:20 (line 20, column 7 - line 20, column 20) Name letUnused was introduced but not used. @@ -22,10 +22,10 @@ Warning 2 of 8: See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, or to contribute content related to this warning. -Warning 3 of 8: +Warning 3 of 9: in module Main - at tests/purs/warning/UnusedVar.purs:25:9 - 25:24 (line 25, column 9 - line 25, column 24) + at tests/purs/warning/UnusedVar.purs:26:9 - 26:24 (line 26, column 9 - line 26, column 24) Name whereUnused was introduced but not used. @@ -34,10 +34,10 @@ Warning 3 of 8: See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, or to contribute content related to this warning. -Warning 4 of 8: +Warning 4 of 9: in module Main - at tests/purs/warning/UnusedVar.purs:29:11 - 29:23 (line 29, column 11 - line 29, column 23) + at tests/purs/warning/UnusedVar.purs:30:11 - 30:23 (line 30, column 11 - line 30, column 23) Name letArgUnused was introduced but not used. @@ -46,10 +46,10 @@ Warning 4 of 8: See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, or to contribute content related to this warning. -Warning 5 of 8: +Warning 5 of 9: in module Main - at tests/purs/warning/UnusedVar.purs:43:5 - 43:15 (line 43, column 5 - line 43, column 15) + at tests/purs/warning/UnusedVar.purs:44:5 - 44:15 (line 44, column 5 - line 44, column 15) Name caseUnused was introduced but not used. @@ -58,10 +58,10 @@ Warning 5 of 8: See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, or to contribute content related to this warning. -Warning 6 of 8: +Warning 6 of 9: in module Main - at tests/purs/warning/UnusedVar.purs:61:34 - 61:35 (line 61, column 34 - line 61, column 35) + at tests/purs/warning/UnusedVar.purs:62:34 - 62:35 (line 62, column 34 - line 62, column 35) Name x was introduced but not used. @@ -70,10 +70,10 @@ Warning 6 of 8: See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, or to contribute content related to this warning. -Warning 7 of 8: +Warning 7 of 9: in module Main - at tests/purs/warning/UnusedVar.purs:68:8 - 68:9 (line 68, column 8 - line 68, column 9) + at tests/purs/warning/UnusedVar.purs:69:8 - 69:9 (line 69, column 8 - line 69, column 9) Name x was introduced but not used. @@ -82,10 +82,22 @@ Warning 7 of 8: See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, or to contribute content related to this warning. -Warning 8 of 8: +Warning 8 of 9: in module Main - at tests/purs/warning/UnusedVar.purs:62:7 - 62:16 (line 62, column 7 - line 62, column 16) + at tests/purs/warning/UnusedVar.purs:87:7 - 87:8 (line 87, column 7 - line 87, column 8) + + Name x was introduced but not used. + + in value declaration notOops + + See https://github.com/purescript/documentation/blob/master/errors/UnusedName.md for more information, + or to contribute content related to this warning. + +Warning 9 of 9: + + in module Main + at tests/purs/warning/UnusedVar.purs:63:7 - 63:16 (line 63, column 7 - line 63, column 16) Name x was shadowed. diff --git a/tests/purs/warning/UnusedVar.purs b/tests/purs/warning/UnusedVar.purs index f1e646d0ca..6a71633bbd 100644 --- a/tests/purs/warning/UnusedVar.purs +++ b/tests/purs/warning/UnusedVar.purs @@ -5,6 +5,7 @@ -- @shouldWarnWith UnusedName -- @shouldWarnWith UnusedName -- @shouldWarnWith UnusedName +-- @shouldWarnWith UnusedName -- @shouldWarnWith ShadowedName module Main where @@ -66,4 +67,38 @@ unusedShadowedByRecursiveBinding x = unusedShadowingLet :: X -> X unusedShadowingLet x = let (x) = x - in X \ No newline at end of file + in X + +-- 4110 +oops ∷ { inner :: String } → String +oops box = + let + { inner } = box + val = inner + in + val + +-- like oops but switching order to show we don't +notOops ∷ { x :: String } -> String → String +notOops box x = + let + val = x + _blah = x + { x } = box + in + val + +bindingGroupsNotRecognised :: Int +bindingGroupsNotRecognised = + let + f n = g n + g n = f n + + -- Second f is unused because this is multiple recursive binding groups, we don't warn because we assume + -- it might be one binding group so there is a usage. If it would be 1 binding group there would be an error + -- Shadowed variable warnings are similarly not aware of binding groups + { x } = { x: 2 } + h n = n + f x = x + in + h x \ No newline at end of file diff --git a/tests/purs/warning/UnusedVarDo.purs b/tests/purs/warning/UnusedVarDo.purs index 3f5c4412e2..601d6e1d9e 100644 --- a/tests/purs/warning/UnusedVarDo.purs +++ b/tests/purs/warning/UnusedVarDo.purs @@ -38,3 +38,11 @@ notUnusedNonRecursiveBinding :: Int -> Maybe Int notUnusedNonRecursiveBinding x = do let {x} = {x} pure x + +-- 4110 in do syntax +oops ∷ { inner :: String } → String +oops box = do + let + { inner } = box + val = inner + val \ No newline at end of file From 936d8d25a711cf5895903410a3525d4bd25baa5e Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sun, 20 Jun 2021 18:07:23 -0400 Subject: [PATCH 1358/1580] Use GenIdent for anonymous instances (#4096) This fixes the limitation of the CoreFn renamer which prevented it from renaming top-level GenIdents. As a consequence, we can now give unnamed instances more idiomatic names and still guarantee that they will be unique in their module. --- CHANGELOG.md | 2 + .../src/Language/PureScript/CST/Convert.hs | 13 +- src/Language/PureScript/Externs.hs | 32 +++-- src/Language/PureScript/Make.hs | 4 +- src/Language/PureScript/Renamer.hs | 111 +++++++++++------- .../PureScript/Sugar/TypeClasses/Instances.hs | 17 ++- .../OverlapAcrossModulesUnnamedInstance.out | 24 ++++ .../OverlapAcrossModulesUnnamedInstance.purs | 7 ++ .../Class.out | 24 ++++ .../Class.purs | 2 + .../X.purs | 4 + tests/purs/failing/OverlappingInstances.purs | 2 +- .../failing/OverlappingUnnamedInstances.out | 22 ++++ .../failing/OverlappingUnnamedInstances.purs | 17 +++ .../PolykindUnnamedInstanceOverlapping.out | 22 ++++ .../PolykindUnnamedInstanceOverlapping.purs | 13 ++ ...TypeSynonymsOverlappingUnnamedInstance.out | 24 ++++ ...ypeSynonymsOverlappingUnnamedInstance.purs | 15 +++ .../purs/passing/InstanceNamesGenerated.purs | 8 +- .../passing/InstanceNamesGenerated/Lib.purs | 20 ++++ .../TransitiveImportUnnamedInstance.purs | 9 ++ .../Middle.purs | 5 + .../TransitiveImportUnnamedInstance/Test.purs | 9 ++ 23 files changed, 340 insertions(+), 66 deletions(-) create mode 100644 tests/purs/failing/OverlapAcrossModulesUnnamedInstance.out create mode 100644 tests/purs/failing/OverlapAcrossModulesUnnamedInstance.purs create mode 100644 tests/purs/failing/OverlapAcrossModulesUnnamedInstance/Class.out create mode 100644 tests/purs/failing/OverlapAcrossModulesUnnamedInstance/Class.purs create mode 100644 tests/purs/failing/OverlapAcrossModulesUnnamedInstance/X.purs create mode 100644 tests/purs/failing/OverlappingUnnamedInstances.out create mode 100644 tests/purs/failing/OverlappingUnnamedInstances.purs create mode 100644 tests/purs/failing/PolykindUnnamedInstanceOverlapping.out create mode 100644 tests/purs/failing/PolykindUnnamedInstanceOverlapping.purs create mode 100644 tests/purs/failing/TypeSynonymsOverlappingUnnamedInstance.out create mode 100644 tests/purs/failing/TypeSynonymsOverlappingUnnamedInstance.purs create mode 100644 tests/purs/passing/InstanceNamesGenerated/Lib.purs create mode 100644 tests/purs/passing/TransitiveImportUnnamedInstance.purs create mode 100644 tests/purs/passing/TransitiveImportUnnamedInstance/Middle.purs create mode 100644 tests/purs/passing/TransitiveImportUnnamedInstance/Test.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index 26dafb6363..a837ffd1ae 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -24,6 +24,8 @@ Internal: * Update RELEASE_GUIDE.md with more details (#4104 by @JordanMartinez) +* Use GenIdent for anonymous instances (#4096, @rhendric) + ## v0.14.2 New features: diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs index fc13db2c93..5ad703e002 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs @@ -18,6 +18,7 @@ module Language.PureScript.CST.Convert import Prelude hiding (take) import Data.Bifunctor (bimap, first) +import Data.Char (toLower) import Data.Foldable (foldl', toList) import Data.Functor (($>)) import qualified Data.List.NonEmpty as NE @@ -540,13 +541,17 @@ convertDeclaration fileName decl = case decl of where -- truncate to 25 chars to reduce verbosity -- of name and still keep it readable - -- unique identifier will be appended to this name - -- in desugaring proces + -- name will be used to create a GenIdent + -- in desugaring process genName :: Text.Text - genName = "$_" <> Text.take 25 (className <> typeArgs) <> "_" + genName = Text.take 25 (className <> typeArgs) className :: Text.Text - className = N.runProperName $ qualName cls + className + = foldMap (uncurry Text.cons . first toLower) + . Text.uncons + . N.runProperName + $ qualName cls typeArgs :: Text.Text typeArgs = foldMap argName args diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 13d9543ef7..942f70db38 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -17,6 +17,7 @@ module Language.PureScript.Externs import Prelude.Compat import Codec.Serialise (Serialise) +import Control.Monad (join) import GHC.Generics (Generic) import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.List (foldl', find) @@ -187,18 +188,24 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar qual :: a -> Qualified a qual = Qualified (Just efModuleName) --- | Generate an externs file for all declarations in a module -moduleToExternsFile :: Module -> Environment -> ExternsFile -moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated" -moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} +-- | Generate an externs file for all declarations in a module. +-- +-- The `Map Ident Ident` argument should contain any top-level `GenIdent`s that +-- were rewritten to `Ident`s when the module was compiled; this rewrite only +-- happens in the CoreFn, not the original module AST, so it needs to be +-- applied to the exported names here also. (The appropriate map is returned by +-- `L.P.Renamer.renameInModule`.) +moduleToExternsFile :: Module -> Environment -> M.Map Ident Ident -> ExternsFile +moduleToExternsFile (Module _ _ _ _ Nothing) _ _ = internalError "moduleToExternsFile: module exports were not elaborated" +moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsFile{..} where efVersion = T.pack (showVersion Paths.version) efModuleName = mn - efExports = exps + efExports = map renameRef exps efImports = mapMaybe importDecl ds efFixities = mapMaybe fixityDecl ds efTypeFixities = mapMaybe typeFixityDecl ds - efDeclarations = concatMap toExternsDeclaration efExports + efDeclarations = concatMap toExternsDeclaration exps efSourceSpan = ss fixityDecl :: Declaration -> Maybe ExternsFixity @@ -230,7 +237,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} _ -> internalError "toExternsDeclaration: Invalid input" toExternsDeclaration (ValueRef _ ident) | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env - = [ EDValue ident ty ] + = [ EDValue (lookupRenamedIdent ident) ty ] toExternsDeclaration (TypeClassRef _ className) | let dictName = dictSynonymName . coerceProperName $ className , Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env @@ -243,7 +250,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies typeClassIsEmpty ] toExternsDeclaration (TypeInstanceRef _ ident) - = [ EDInstance tcdClassName ident tcdForAll tcdInstanceKinds tcdInstanceTypes tcdDependencies tcdChain tcdIndex + = [ EDInstance tcdClassName (lookupRenamedIdent ident) tcdForAll tcdInstanceKinds tcdInstanceTypes tcdDependencies tcdChain tcdIndex | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env)) , m2 <- M.elems m1 , nel <- maybeToList (M.lookup (Qualified (Just mn) ident) m2) @@ -251,5 +258,14 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..} ] toExternsDeclaration _ = [] + renameRef :: DeclarationRef -> DeclarationRef + renameRef = \case + ValueRef ss' ident -> ValueRef ss' $ lookupRenamedIdent ident + TypeInstanceRef ss' ident -> TypeInstanceRef ss' $ lookupRenamedIdent ident + other -> other + + lookupRenamedIdent :: Ident -> Ident + lookupRenamedIdent = flip (join M.findWithDefault) renamedIdents + externsFileName :: FilePath externsFileName = "externs.cbor" diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index e17b0d5049..2f4065d717 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -100,8 +100,8 @@ rebuildModule' MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) = do let mod' = Module ss coms moduleName regrouped exps corefn = CF.moduleToCoreFn env' mod' optimized = CF.optimizeCoreFn corefn - [renamed] = renameInModules [optimized] - exts = moduleToExternsFile mod' env' + (renamedIdents, renamed) = renameInModule optimized + exts = moduleToExternsFile mod' env' renamedIdents ffiCodegen renamed -- It may seem more obvious to write `docs <- Docs.convertModule m env' here, diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index b11ed65e39..75a5335261 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -1,14 +1,15 @@ -- | -- Renaming pass that prevents shadowing of local identifiers. -- -module Language.PureScript.Renamer (renameInModules) where +module Language.PureScript.Renamer (renameInModule) where import Prelude.Compat import Control.Monad.State +import Data.Functor ((<&>)) import Data.List (find) -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromJust, fromMaybe, isNothing) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T @@ -39,8 +40,8 @@ initState scope = RenameState (M.fromList (zip scope scope)) (S.fromList scope) -- | -- Runs renaming starting with a list of idents for the initial scope. -- -runRename :: [Ident] -> Rename a -> a -runRename scope = flip evalState (initState scope) +runRename :: [Ident] -> Rename a -> (a, RenameState) +runRename scope = flip runState (initState scope) -- | -- Creates a new renaming scope using the current as a basis. Used to backtrack @@ -93,48 +94,68 @@ lookupIdent name = do Just name'' -> return name'' Nothing -> error $ "Rename scope is missing ident '" ++ T.unpack (showIdent name) ++ "'" --- | --- Finds idents introduced by declarations. --- -findDeclIdents :: [Bind Ann] -> [Ident] -findDeclIdents = concatMap go - where - go (NonRec _ ident _) = [ident] - go (Rec ds) = map (snd . fst) ds -- | --- Renames within each declaration in a module. +-- Renames within each declaration in a module. Returns the map of renamed +-- identifiers in the top-level scope, so that they can be renamed in the +-- externs files as well. -- -renameInModules :: [Module Ann] -> [Module Ann] -renameInModules = map go +renameInModule :: Module Ann -> (M.Map Ident Ident, Module Ann) +renameInModule m@(Module _ _ _ _ _ exports _ foreigns decls) = (rsBoundNames, m { moduleExports, moduleDecls }) where - go :: Module Ann -> Module Ann - go m@(Module _ _ _ _ _ _ _ _ decls) = m { moduleDecls = map (renameInDecl' (findDeclIdents decls)) decls } - - renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann - renameInDecl' scope = runRename scope . renameInDecl True + ((moduleDecls, moduleExports), RenameState{..}) = runRename foreigns $ + (,) <$> renameInDecls decls <*> traverse lookupIdent exports -- | --- Renames within a declaration. isTopLevel is used to determine whether the --- declaration is a module member or appearing within a Let. At the top level --- declarations are not renamed or added to the scope (they should already have --- been added), whereas in a Let declarations are renamed if their name shadows --- another in the current scope. +-- Renames within a list of declarations. The list is processed in three +-- passes: +-- +-- 1) Declarations with user-provided names are added to the scope, renaming +-- them only if necessary to prevent shadowing. +-- 2) Declarations with compiler-provided names are added to the scope, +-- renaming them to prevent shadowing or collision with a user-provided +-- name. +-- 3) The bodies of the declarations are processed recursively. -- -renameInDecl :: Bool -> Bind Ann -> Rename (Bind Ann) -renameInDecl isTopLevel (NonRec a name val) = do - name' <- if isTopLevel then return name else updateScope name - NonRec a name' <$> renameInValue val -renameInDecl isTopLevel (Rec ds) = do - ds' <- traverse updateNames ds - Rec <$> traverse updateValues ds' +-- The distinction between passes 1 and 2 is critical in the top-level module +-- scope, where declarations can be exported and named declarations must not +-- be renamed. Below the top level, this only matters for programmers looking +-- at the generated code or using a debugger; we want them to see the names +-- they used as much as possible. +-- +-- The distinction between the first two passes and pass 3 is important because +-- a `GenIdent` can appear before its declaration in a depth-first traversal, +-- and we need to visit the declaration first in order to rename all of its +-- uses. Similarly, a plain `Ident` could shadow another declared in an outer +-- scope but later in a depth-first traversal, and we need to visit the +-- outer declaration first in order to know to rename the inner one. +-- +renameInDecls :: [Bind Ann] -> Rename [Bind Ann] +renameInDecls = + traverse (renameDecl False) + >=> traverse (renameDecl True) + >=> traverse renameValuesInDecl + where - updateNames :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann) - updateNames ((a, name), val) = do - name' <- if isTopLevel then return name else updateScope name - return ((a, name'), val) - updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann) - updateValues (aname, val) = (aname, ) <$> renameInValue val + + renameDecl :: Bool -> Bind Ann -> Rename (Bind Ann) + renameDecl isSecondPass = \case + NonRec a name val -> updateName name <&> \name' -> NonRec a name' val + Rec ds -> Rec <$> traverse updateNames ds + where + updateName :: Ident -> Rename Ident + updateName name = (if isSecondPass == isPlainIdent name then pure else updateScope) name + + updateNames :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann) + updateNames ((a, name), val) = updateName name <&> \name' -> ((a, name'), val) + + renameValuesInDecl :: Bind Ann -> Rename (Bind Ann) + renameValuesInDecl = \case + NonRec a name val -> NonRec a name <$> renameInValue val + Rec ds -> Rec <$> traverse updateValues ds + where + updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann) + updateValues (aname, val) = (aname, ) <$> renameInValue val -- | -- Renames within a value. @@ -152,13 +173,17 @@ renameInValue (Abs ann name v) = newScope $ Abs ann <$> updateScope name <*> renameInValue v renameInValue (App ann v1 v2) = App ann <$> renameInValue v1 <*> renameInValue v2 -renameInValue (Var ann (Qualified Nothing name)) = - Var ann . Qualified Nothing <$> lookupIdent name +renameInValue (Var ann (Qualified mn name)) | isNothing mn || not (isPlainIdent name) = + -- This should only rename identifiers local to the current module: either + -- they aren't qualified, or they are but they have a name that should not + -- have appeared in a module's externs, so they must be from this module's + -- top-level scope. + Var ann . Qualified mn <$> lookupIdent name renameInValue v@Var{} = return v renameInValue (Case ann vs alts) = newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts renameInValue (Let ann ds v) = - newScope $ Let ann <$> traverse (renameInDecl False) ds <*> renameInValue v + newScope $ Let ann <$> renameInDecls ds <*> renameInValue v -- | -- Renames within literals. @@ -189,3 +214,7 @@ renameInBinder (ConstructorBinder ann tctor dctor bs) = ConstructorBinder ann tctor dctor <$> traverse renameInBinder bs renameInBinder (NamedBinder ann name b) = NamedBinder ann <$> updateScope name <*> renameInBinder b + +isPlainIdent :: Ident -> Bool +isPlainIdent Ident{} = True +isPlainIdent _ = False diff --git a/src/Language/PureScript/Sugar/TypeClasses/Instances.hs b/src/Language/PureScript/Sugar/TypeClasses/Instances.hs index a2ea95a678..8f8d63b1f6 100644 --- a/src/Language/PureScript/Sugar/TypeClasses/Instances.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Instances.hs @@ -8,11 +8,11 @@ module Language.PureScript.Sugar.TypeClasses.Instances import Prelude.Compat hiding (take) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class -import Data.Text (pack) -import Language.PureScript.Errors -import Language.PureScript.Names +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class +import Data.Functor ((<&>)) +import Language.PureScript.Errors +import Language.PureScript.Names -- | -- Completes the name generation for type class instances that do not have @@ -33,8 +33,7 @@ desugarTypeClassInstanceNames (Module ss coms name decls exps) = do => Declaration -> m Declaration desugarInstName = \case - TypeInstanceDeclaration sa chainId idx (Left genText) deps className tys bd -> do - uniqueIdent <- fresh - let finalName = Ident $ genText <> pack (show uniqueIdent) - pure $ TypeInstanceDeclaration sa chainId idx (Right finalName) deps className tys bd + TypeInstanceDeclaration sa chainId idx (Left genText) deps className tys bd -> + freshIdent genText <&> \ident -> + TypeInstanceDeclaration sa chainId idx (Right ident) deps className tys bd a -> pure a diff --git a/tests/purs/failing/OverlapAcrossModulesUnnamedInstance.out b/tests/purs/failing/OverlapAcrossModulesUnnamedInstance.out new file mode 100644 index 0000000000..6d0fe73b86 --- /dev/null +++ b/tests/purs/failing/OverlapAcrossModulesUnnamedInstance.out @@ -0,0 +1,24 @@ +Error found: +in module OverlapAcrossModules +at tests/purs/failing/OverlapAcrossModulesUnnamedInstance.purs:6:1 - 6:15 (line 6, column 1 - line 6, column 15) + + Overlapping type class instances found for +   +  OverlapAcrossModules.Class.C X +  Y +   + The following instances were found: + + OverlapAcrossModules.X.cX + OverlapAcrossModules.$cXY0 + + +in type class instance +  + OverlapAcrossModules.Class.C X + Y +  + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingInstances.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OverlapAcrossModulesUnnamedInstance.purs b/tests/purs/failing/OverlapAcrossModulesUnnamedInstance.purs new file mode 100644 index 0000000000..030cfd2351 --- /dev/null +++ b/tests/purs/failing/OverlapAcrossModulesUnnamedInstance.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith OverlappingInstances +module OverlapAcrossModules where +import OverlapAcrossModules.Class +import OverlapAcrossModules.X +data Y +instance C X Y + diff --git a/tests/purs/failing/OverlapAcrossModulesUnnamedInstance/Class.out b/tests/purs/failing/OverlapAcrossModulesUnnamedInstance/Class.out new file mode 100644 index 0000000000..ae7c7037f3 --- /dev/null +++ b/tests/purs/failing/OverlapAcrossModulesUnnamedInstance/Class.out @@ -0,0 +1,24 @@ +Error found: +in module OverlapAcrossModules +at tests/purs/failing/OverlapAcrossModules.purs:6:1 - 6:22 (line 6, column 1 - line 6, column 22) + + Overlapping type class instances found for +   +  OverlapAcrossModules.Class.C X +  Y +   + The following instances were found: + + OverlapAcrossModules.X.cxy + OverlapAcrossModules.cxy + + +in type class instance +  + OverlapAcrossModules.Class.C X + Y +  + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingInstances.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OverlapAcrossModulesUnnamedInstance/Class.purs b/tests/purs/failing/OverlapAcrossModulesUnnamedInstance/Class.purs new file mode 100644 index 0000000000..6b4699a9a1 --- /dev/null +++ b/tests/purs/failing/OverlapAcrossModulesUnnamedInstance/Class.purs @@ -0,0 +1,2 @@ +module OverlapAcrossModules.Class where +class C x y diff --git a/tests/purs/failing/OverlapAcrossModulesUnnamedInstance/X.purs b/tests/purs/failing/OverlapAcrossModulesUnnamedInstance/X.purs new file mode 100644 index 0000000000..79692c813b --- /dev/null +++ b/tests/purs/failing/OverlapAcrossModulesUnnamedInstance/X.purs @@ -0,0 +1,4 @@ +module OverlapAcrossModules.X where +import OverlapAcrossModules.Class +data X +instance C X y diff --git a/tests/purs/failing/OverlappingInstances.purs b/tests/purs/failing/OverlappingInstances.purs index 9ae7230584..c6c51d0a2f 100644 --- a/tests/purs/failing/OverlappingInstances.purs +++ b/tests/purs/failing/OverlappingInstances.purs @@ -12,6 +12,6 @@ instance testInt :: Test Int where -- The OverlappingInstances instances error only arises when there are two -- choices for a dictionary, not when the instances are defined. So without --- `value` this module would not raise a warning. +-- `value` this module would not raise an error. value :: Int value = test 1 diff --git a/tests/purs/failing/OverlappingUnnamedInstances.out b/tests/purs/failing/OverlappingUnnamedInstances.out new file mode 100644 index 0000000000..2943fa6873 --- /dev/null +++ b/tests/purs/failing/OverlappingUnnamedInstances.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/OverlappingUnnamedInstances.purs:10:1 - 11:13 (line 10, column 1 - line 11, column 13) + + Overlapping type class instances found for +   +  Main.Test Int +   + The following instances were found: + + Main.$test1 + Main.$testInt2 + + +in type class instance +  + Main.Test Int +  + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingInstances.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OverlappingUnnamedInstances.purs b/tests/purs/failing/OverlappingUnnamedInstances.purs new file mode 100644 index 0000000000..92e85ec3bd --- /dev/null +++ b/tests/purs/failing/OverlappingUnnamedInstances.purs @@ -0,0 +1,17 @@ +-- @shouldFailWith OverlappingInstances +module Main where + +class Test a where + test :: a -> a + +instance Test a where + test x = x + +instance Test Int where + test _ = 0 + +-- The OverlappingInstances instances error only arises when there are two +-- choices for a dictionary, not when the instances are defined. So without +-- `value` this module would not raise an error. +value :: Int +value = test 1 diff --git a/tests/purs/failing/PolykindUnnamedInstanceOverlapping.out b/tests/purs/failing/PolykindUnnamedInstanceOverlapping.out new file mode 100644 index 0000000000..b46d4f743c --- /dev/null +++ b/tests/purs/failing/PolykindUnnamedInstanceOverlapping.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/PolykindUnnamedInstanceOverlapping.purs:12:1 - 13:19 (line 12, column 1 - line 13, column 19) + + Overlapping type class instances found for +   +  Main.ShowP (Proxy a) +   + The following instances were found: + + Main.$showPProxy2 + Main.$showPProxy3 + + +in type class instance +  + Main.ShowP (Proxy (a :: k)) +  + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingInstances.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PolykindUnnamedInstanceOverlapping.purs b/tests/purs/failing/PolykindUnnamedInstanceOverlapping.purs new file mode 100644 index 0000000000..13c18dbf5d --- /dev/null +++ b/tests/purs/failing/PolykindUnnamedInstanceOverlapping.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith OverlappingInstances +module Main where + +data Proxy a = Proxy + +class ShowP a where + showP :: a -> String + +instance ShowP (Proxy ((a) :: k)) where + showP _ = "Type" + +instance ShowP (Proxy ((a) :: k)) where + showP _ = "Type" diff --git a/tests/purs/failing/TypeSynonymsOverlappingUnnamedInstance.out b/tests/purs/failing/TypeSynonymsOverlappingUnnamedInstance.out new file mode 100644 index 0000000000..6e5b2922e1 --- /dev/null +++ b/tests/purs/failing/TypeSynonymsOverlappingUnnamedInstance.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/TypeSynonymsOverlappingUnnamedInstance.purs:14:1 - 15:16 (line 14, column 1 - line 15, column 16) + + Overlapping type class instances found for +   +  Main.Convert String +  String +   + The following instances were found: + + Main.$convertStringBar0 + Main.$convertStringString1 + + +in type class instance +  + Main.Convert String + String +  + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingInstances.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeSynonymsOverlappingUnnamedInstance.purs b/tests/purs/failing/TypeSynonymsOverlappingUnnamedInstance.purs new file mode 100644 index 0000000000..856edbc86f --- /dev/null +++ b/tests/purs/failing/TypeSynonymsOverlappingUnnamedInstance.purs @@ -0,0 +1,15 @@ +-- @shouldFailWith OverlappingInstances +module Main where + +import Prelude + +class Convert a b | a -> b where + convert :: a -> b + +type Bar = String + +instance Convert String Bar where + convert s = s + +instance Convert String String where + convert s = s diff --git a/tests/purs/passing/InstanceNamesGenerated.purs b/tests/purs/passing/InstanceNamesGenerated.purs index a78cb99269..21e7981a90 100644 --- a/tests/purs/passing/InstanceNamesGenerated.purs +++ b/tests/purs/passing/InstanceNamesGenerated.purs @@ -1,8 +1,12 @@ module Main where +import Prelude + import Effect.Console (log) import Data.Generic.Rep (class Generic) +import Lib (namedExportStillWorksUnit) + -- This file verifies that unnamed instances will produce -- completely-generated instance names without problems. @@ -87,6 +91,8 @@ instance OverlappingStillCompiles x else instance OverlappingStillCompiles x -main = log "Done" +main = do + namedExportStillWorksUnit 0 + log "Done" data Either l r = Left l | Right r diff --git a/tests/purs/passing/InstanceNamesGenerated/Lib.purs b/tests/purs/passing/InstanceNamesGenerated/Lib.purs new file mode 100644 index 0000000000..321e5fb1af --- /dev/null +++ b/tests/purs/passing/InstanceNamesGenerated/Lib.purs @@ -0,0 +1,20 @@ +module Lib where + +import Prelude + +import Effect (Effect) + +class NamedExportStillWorks a where + doTest :: Effect a + +-- This test expects the generated name of this instance to be +-- namedExportStillWorksUnit in the absence of another identifier with that +-- name (as we have here). +-- The test ensures that the instance doesn't preempt the named declaration. +-- (If the naming scheme for unnamed instances ever changes, the name of the +-- exported declaration in this test should change with it.) +instance NamedExportStillWorks Unit where + doTest = pure unit + +namedExportStillWorksUnit :: Int -> Effect Unit +namedExportStillWorksUnit _ = doTest diff --git a/tests/purs/passing/TransitiveImportUnnamedInstance.purs b/tests/purs/passing/TransitiveImportUnnamedInstance.purs new file mode 100644 index 0000000000..62830afcb7 --- /dev/null +++ b/tests/purs/passing/TransitiveImportUnnamedInstance.purs @@ -0,0 +1,9 @@ +module Main where + + import Prelude + import Middle + import Effect.Console + + main = do + logShow (middle unit) + log "Done" diff --git a/tests/purs/passing/TransitiveImportUnnamedInstance/Middle.purs b/tests/purs/passing/TransitiveImportUnnamedInstance/Middle.purs new file mode 100644 index 0000000000..c4b5282a75 --- /dev/null +++ b/tests/purs/passing/TransitiveImportUnnamedInstance/Middle.purs @@ -0,0 +1,5 @@ +module Middle where + +import Test (test) + +middle = test diff --git a/tests/purs/passing/TransitiveImportUnnamedInstance/Test.purs b/tests/purs/passing/TransitiveImportUnnamedInstance/Test.purs new file mode 100644 index 0000000000..0bd0f0898e --- /dev/null +++ b/tests/purs/passing/TransitiveImportUnnamedInstance/Test.purs @@ -0,0 +1,9 @@ +module Test where + +import Prelude + +class TestCls a where + test :: a -> a + +instance TestCls Unit where + test _ = unit From df373537f65a90a68432b455fb530bfda505cac8 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Mon, 21 Jun 2021 06:37:45 -0700 Subject: [PATCH 1359/1580] Move type class instance name desugaring into type class desugaring pass (#4099) This refactors the work done in #4085. It was not merged immediately due to the work done in #4096 that would produce a merge conflict. --- CHANGELOG.md | 2 + purescript.cabal | 1 - src/Language/PureScript/Sugar.hs | 4 -- src/Language/PureScript/Sugar/TypeClasses.hs | 21 +++++++--- .../PureScript/Sugar/TypeClasses/Instances.hs | 39 ------------------- 5 files changed, 17 insertions(+), 50 deletions(-) delete mode 100644 src/Language/PureScript/Sugar/TypeClasses/Instances.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index a837ffd1ae..dc7134453b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -26,6 +26,8 @@ Internal: * Use GenIdent for anonymous instances (#4096, @rhendric) +* Desugar type class instance names in type class desugaring pass (#4099 by @JordanMartinez) + ## v0.14.2 New features: diff --git a/purescript.cabal b/purescript.cabal index 1eb9e9d795..ec4f0bc071 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -302,7 +302,6 @@ library Language.PureScript.Sugar.Operators.Types Language.PureScript.Sugar.TypeClasses Language.PureScript.Sugar.TypeClasses.Deriving - Language.PureScript.Sugar.TypeClasses.Instances Language.PureScript.Sugar.TypeDeclarations Language.PureScript.TypeChecker Language.PureScript.TypeChecker.Entailment diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index c6a3c9f912..8a41fa7481 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -30,7 +30,6 @@ import Language.PureScript.Sugar.ObjectWildcards as S import Language.PureScript.Sugar.Operators as S import Language.PureScript.Sugar.TypeClasses as S import Language.PureScript.Sugar.TypeClasses.Deriving as S -import Language.PureScript.Sugar.TypeClasses.Instances as S import Language.PureScript.Sugar.TypeDeclarations as S import Language.PureScript.TypeChecker.Synonyms (SynonymMap) @@ -49,8 +48,6 @@ import Language.PureScript.TypeChecker.Synonyms (SynonymMap) -- -- * Desugar top-level case declarations into explicit case expressions -- --- * Generate type class instance names for those not defined in source code --- -- * Desugar type declarations into value declarations with explicit type annotations -- -- * Qualify any unqualified names and types @@ -88,7 +85,6 @@ desugar externs = -- knowing their kinds but they're not available yet. kinds = mempty in deriveInstances externs syns kinds m - >>= desugarTypeClassInstanceNames >>= desugarTypeClasses externs syns kinds) >=> createBindingGroupsModule diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index dcbb3472b4..9b09a7e912 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -214,20 +214,29 @@ desugarDecl syns kinds mn exps = go modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False)) return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) go (TypeInstanceDeclaration _ _ _ _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" - go (TypeInstanceDeclaration _ _ _ (Left _) _ _ _ _) = internalError "instance names should have been desugared" - go d@(TypeInstanceDeclaration sa _ _ (Right name) deps className tys (ExplicitInstance members)) + go (TypeInstanceDeclaration sa chainId idx name deps className tys (ExplicitInstance members)) | className == C.Coercible = throwError . errorMessage' (fst sa) $ InvalidCoercibleInstanceDeclaration tys | otherwise = do desugared <- desugarCases members - dictDecl <- typeInstanceDictionaryDeclaration syns kinds sa name mn deps className tys desugared - return (expRef name className tys, [d, dictDecl]) - go d@(TypeInstanceDeclaration sa _ _ (Right name) deps className tys (NewtypeInstanceWithDictionary dict)) = do + name' <- desugarInstName name + dictDecl <- typeInstanceDictionaryDeclaration syns kinds sa name' mn deps className tys desugared + let d = TypeInstanceDeclaration sa chainId idx (Right name') deps className tys (ExplicitInstance members) + return (expRef name' className tys, [d, dictDecl]) + go (TypeInstanceDeclaration sa chainId idx name deps className tys (NewtypeInstanceWithDictionary dict)) = do + name' <- desugarInstName name let dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictSynonymName) className)) tys constrainedTy = quantify (foldr srcConstrainedType dictTy deps) - return (expRef name className tys, [d, ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) + d = TypeInstanceDeclaration sa chainId idx (Right name') deps className tys (NewtypeInstanceWithDictionary dict) + return (expRef name' className tys, [d, ValueDecl sa name' Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) go other = return (Nothing, [other]) + -- | + -- Completes the name generation for type class instances that do not have + -- a unique name defined in source code. + desugarInstName :: MonadSupply m => Either Text Ident -> Desugar m Ident + desugarInstName = either freshIdent pure + expRef :: Ident -> Qualified (ProperName 'ClassName) -> [SourceType] -> Maybe DeclarationRef expRef name className tys | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef genSpan name diff --git a/src/Language/PureScript/Sugar/TypeClasses/Instances.hs b/src/Language/PureScript/Sugar/TypeClasses/Instances.hs deleted file mode 100644 index 8f8d63b1f6..0000000000 --- a/src/Language/PureScript/Sugar/TypeClasses/Instances.hs +++ /dev/null @@ -1,39 +0,0 @@ --- | --- This module implements the desugaring pass which creates the compiler-generated --- names for type class instances that do not have one defined in the source code. --- -module Language.PureScript.Sugar.TypeClasses.Instances - ( desugarTypeClassInstanceNames - ) where - -import Prelude.Compat hiding (take) - -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class -import Data.Functor ((<&>)) -import Language.PureScript.Errors -import Language.PureScript.Names - --- | --- Completes the name generation for type class instances that do not have --- a unique name defined in source code. All `Left Text` values --- will be converted to `Right Ident` values. --- -desugarTypeClassInstanceNames - :: (MonadSupply m, MonadError MultipleErrors m) - => Module - -> m Module -desugarTypeClassInstanceNames (Module ss coms name decls exps) = do - desugaredDecl <- parU decls desugarInstName - pure $ Module ss coms name desugaredDecl exps - - where - desugarInstName - :: (MonadSupply m, MonadError MultipleErrors m) - => Declaration - -> m Declaration - desugarInstName = \case - TypeInstanceDeclaration sa chainId idx (Left genText) deps className tys bd -> - freshIdent genText <&> \ident -> - TypeInstanceDeclaration sa chainId idx (Right ident) deps className tys bd - a -> pure a From fcf0acbcf11ad113820d32ce9ee82365a6015c9c Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Mon, 21 Jun 2021 20:08:18 -0700 Subject: [PATCH 1360/1580] Display kind signatures and comments in docs (#4100) * Render kind signatures and comments in docs * Add a line separator between kind sig docs and data decl docs * Update isExported to include kind signatures via simpler approach * Update changelog entry * Test that kind sigs appear in docs of declarations with kind sigs * Verify that doc-comment merging is done correctly --- CHANGELOG.md | 26 ++++++ app/static/pursuit.css | 6 +- app/static/pursuit.less | 7 +- .../Language/PureScript/AST/Declarations.hs | 7 +- .../src/Language/PureScript/AST/Exported.hs | 21 ++++- src/Language/PureScript/Docs/AsHtml.hs | 9 +- src/Language/PureScript/Docs/Convert.hs | 1 + .../PureScript/Docs/Convert/ReExports.hs | 1 + .../PureScript/Docs/Convert/Single.hs | 27 ++++++ src/Language/PureScript/Docs/Prim.hs | 2 + src/Language/PureScript/Docs/Render.hs | 9 ++ .../PureScript/Docs/RenderedCode/Types.hs | 9 ++ src/Language/PureScript/Docs/Types.hs | 44 +++++++++ tests/TestDocs.hs | 90 +++++++++++++++++++ tests/purs/docs/src/KindSignatureDocs.purs | 60 +++++++++++++ 15 files changed, 311 insertions(+), 8 deletions(-) create mode 100644 tests/purs/docs/src/KindSignatureDocs.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index dc7134453b..5b94210e4c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,32 @@ Breaking changes: New features: +* Display kind signatures and their comments in documentation (#4100 by JordanMartinez) + + Previously, data/newtype/type/class declarations that have explicit kind + signatures would not display those kind signatures in their documentation. + For example, the two below types... + + ```purescript + data PolyProxy :: forall k. k -> Type + data PolyProxy a = PolyProxy + + data TypeProxy :: Type -> Type + data TypeProxy a = TypeProxy + ``` + + ... would only show the following information in their docs. One cannot + be distinguished from another due to the missing kind signatures: + + ``` + data PolyProxy a = PolyProxy + + data TypeProxy a = TypeProxy + ``` + + Now, these types' kind signatures are displayed above their declarations + in their docs, similar to what one would see in the source code. + Bugfixes: * Ensure unnamed instances appear in documentation (#4109 by @JordanMartinez) diff --git a/app/static/pursuit.css b/app/static/pursuit.css index dd4671995f..709b859b54 100644 --- a/app/static/pursuit.css +++ b/app/static/pursuit.css @@ -404,14 +404,18 @@ ol li { border-radius: 0; border-top: 1px solid #cccccc; border-bottom: 1px solid #cccccc; - padding: 0.328em 0; + padding: 0; } .decl__signature code { display: block; + padding: 0.328em 0; padding-left: 2.441em; text-indent: -2.441em; white-space: normal; } +.decl__kind { + border-bottom: 1px solid #cccccc; +} :target .decl__signature, :target .decl__signature code { /* We want the background to be transparent, even when the parent is a target */ diff --git a/app/static/pursuit.less b/app/static/pursuit.less index 1b064b2c5f..7a9629f494 100644 --- a/app/static/pursuit.less +++ b/app/static/pursuit.less @@ -485,16 +485,21 @@ ol li { border-radius: 0; border-top: 1px solid darken(@background, 20%); border-bottom: 1px solid darken(@background, 20%); - padding: 0.328em 0; + padding: 0; } .decl__signature code { display: block; + padding: 0.328em 0; padding-left: 2.441em; text-indent: -2.441em; white-space: normal; } +.decl__kind { + border-bottom: 1px solid darken(@background, 20%); +} + :target .decl__signature, :target .decl__signature code { /* We want the background to be transparent, even when the parent is a target */ diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs index e2ed1e2bd8..c2d0c85d86 100644 --- a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs @@ -473,7 +473,9 @@ data KindSignatureFor | NewtypeSig | TypeSynonymSig | ClassSig - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance NFData KindSignatureFor declSourceAnn :: Declaration -> SourceAnn declSourceAnn (DataDeclaration sa _ _ _ _) = sa @@ -495,6 +497,9 @@ declSourceAnn (TypeInstanceDeclaration sa _ _ _ _ _ _ _) = sa declSourceSpan :: Declaration -> SourceSpan declSourceSpan = fst . declSourceAnn +-- Note: Kind Declarations' names can refer to either a `TyClassName` +-- or a `TypeName`. Use a helper function for handling `KindDeclaration`s +-- specifically in the context in which it is needed. declName :: Declaration -> Maybe Name declName (DataDeclaration _ _ n _ _) = Just (TyName n) declName (TypeSynonymDeclaration _ n _ _) = Just (TyName n) diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Exported.hs b/lib/purescript-cst/src/Language/PureScript/AST/Exported.hs index 60c860cf8d..831149d8ef 100644 --- a/lib/purescript-cst/src/Language/PureScript/AST/Exported.hs +++ b/lib/purescript-cst/src/Language/PureScript/AST/Exported.hs @@ -7,6 +7,7 @@ import Prelude.Compat import Protolude (sortOn) import Control.Category ((>>>)) +import Control.Applicative ((<|>)) import Data.Maybe (mapMaybe) import qualified Data.Map as M @@ -30,6 +31,8 @@ import Language.PureScript.Names -- list, unless there is no export list, in which case they appear in the same -- order as they do in the source file. -- +-- Kind signatures declarations are also exported if their associated +-- declaration is exported. exportedDeclarations :: Module -> [Declaration] exportedDeclarations (Module _ _ mn decls exps) = go decls where @@ -126,6 +129,11 @@ typeInstanceConstituents _ = [] isExported :: Maybe [DeclarationRef] -> Declaration -> Bool isExported Nothing _ = True isExported _ TypeInstanceDeclaration{} = True +isExported (Just exps) (KindDeclaration _ _ n _) = any matches exps + where + matches declRef = do + let refName = declRefName declRef + TyName n == refName || TyClassName (tyToClassName n) == refName isExported (Just exps) decl = any matches exps where matches declRef = declName decl == Just (declRefName declRef) @@ -152,5 +160,14 @@ reorder refs = where refIndices = M.fromList $ zip (map declRefName refs) [(0::Int)..] - refIndex decl = - declName decl >>= flip M.lookup refIndices + refIndex = \case + KindDeclaration _ _ n _ -> + M.lookup (TyName n) refIndices <|> M.lookup (TyClassName (tyToClassName n)) refIndices + + decl -> declName decl >>= flip M.lookup refIndices + +-- | +-- Workaround to the fact that a `KindDeclaration`'s name's `ProperNameType` +-- isn't the same as the corresponding `TypeClassDeclaration`'s `ProperNameType` +tyToClassName :: ProperName 'TypeName -> ProperName 'ClassName +tyToClassName = coerceProperName diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index 884b89d2bf..3ff4c6102e 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -145,9 +145,12 @@ declAsHtml r d@Declaration{..} = do case declInfo of AliasDeclaration fixity alias_ -> renderAlias fixity alias_ - _ -> - pre ! A.class_ "decl__signature" $ code $ - codeAsHtml r (Render.renderDeclaration d) + _ -> do + pre ! A.class_ "decl__signature" $ do + for_ declKind $ \kindInfo -> do + code ! A.class_ "decl__kind" $ do + codeAsHtml r (Render.renderKindSig declTitle kindInfo) + code $ codeAsHtml r (Render.renderDeclaration d) for_ declComments renderMarkdown diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index a91440d07c..9dd57ce6b8 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -50,6 +50,7 @@ insertValueTypes :: insertValueTypes env m = m { modDeclarations = map go (modDeclarations m) } where + -- insert value types go d@Declaration { declInfo = ValueDeclaration P.TypeWildcard{} } = let ident = P.Ident . CST.getIdent . CST.nameValue . parseIdent $ declTitle d diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 462f515bd4..e308c556ef 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -434,6 +434,7 @@ handleEnv TypeClassEnv{..} = , declSourceSpan = cdeclSourceSpan , declChildren = [] , declInfo = ValueDeclaration (addConstraint constraint typ) + , declKind = Nothing } _ -> internalErrorInModule diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 4099ce6618..d27f5d971a 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -66,8 +66,19 @@ type IntermediateDeclaration -- since they appear at the top level in the AST, and since they might need to -- appear as children in two places (for example, if a data type defined in a -- module is an instance of a type class also defined in that module). +-- +-- The AugmentKindSig constructor allows us to add a kind signature +-- to its corresponding declaration. Comments for both declarations +-- are also merged together. data DeclarationAugment = AugmentChild ChildDeclaration + | AugmentKindSig KindSignatureInfo + +data KindSignatureInfo = KindSignatureInfo + { ksiComments :: Maybe Text + , ksiKeyword :: P.KindSignatureFor + , ksiKind :: Type' + } -- | Augment top-level declarations; the second pass. See the comments under -- the type synonym IntermediateDeclaration for more information. @@ -86,6 +97,15 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) = augmentWith (AugmentChild child) d = d { declChildren = declChildren d ++ [child] } + augmentWith (AugmentKindSig KindSignatureInfo{..}) d = + d { declComments = mergeComments ksiComments $ declComments d + , declKind = Just $ KindInfo { kiKeyword = ksiKeyword, kiKind = ksiKind } + } + where + mergeComments Nothing dc = dc + mergeComments kc Nothing = kc + mergeComments (Just kcoms) (Just dcoms) = + Just $ kcoms <> "\n" <> dcoms getDeclarationTitle :: P.Declaration -> Maybe Text getDeclarationTitle (P.ValueDeclaration vd) = Just (P.showIdent (P.valdeclIdent vd)) @@ -97,6 +117,7 @@ getDeclarationTitle (P.TypeClassDeclaration _ name _ _ _ _) = Just (P.runProperN getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ name _ _ _ _) = Just $ either (const "") P.showIdent name getDeclarationTitle (P.TypeFixityDeclaration _ _ _ op) = Just ("type " <> P.showOp op) getDeclarationTitle (P.ValueFixityDeclaration _ _ _ op) = Just (P.showOp op) +getDeclarationTitle (P.KindDeclaration _ _ n _) = Just (P.runProperName n) getDeclarationTitle _ = Nothing -- | Create a basic Declaration value. @@ -107,6 +128,7 @@ mkDeclaration (ss, com) title info = , declSourceSpan = Just ss -- TODO: make this non-optional when we next break the format , declChildren = [] , declInfo = info + , declKind = Nothing -- kind sigs are added in augment pass } basicDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Maybe IntermediateDeclaration @@ -159,6 +181,11 @@ convertDeclaration (P.ValueFixityDeclaration sa fixity (P.Qualified mn alias) _) Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Right alias))) convertDeclaration (P.TypeFixityDeclaration sa fixity (P.Qualified mn alias) _) title = Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Left alias))) +convertDeclaration (P.KindDeclaration sa keyword _ kind) title = + Just $ Left ([(title, AugmentType), (title, AugmentClass)], AugmentKindSig ksi) + where + comms = convertComments $ snd sa + ksi = KindSignatureInfo { ksiComments = comms, ksiKeyword = keyword, ksiKind = kind $> () } convertDeclaration _ _ = Nothing convertComments :: [P.Comment] -> Maybe Text diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 3afa0cebf1..bf6b9f2afe 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -183,6 +183,7 @@ primTypeOf gen title comments = Declaration , declSourceSpan = Nothing , declChildren = [] , declInfo = ExternDataDeclaration (lookupPrimTypeKindOf gen title) + , declKind = Nothing } -- | Lookup the TypeClassData of a Prim class. This function is specifically @@ -214,6 +215,7 @@ primClassOf gen title comments = Declaration fundeps = convertFundepsToStrings args (P.typeClassDependencies tcd) in TypeClassDeclaration args superclasses fundeps + , declKind = Nothing } kindType :: Declaration diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index a4c0104c47..fda917dfb5 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -24,6 +24,15 @@ import qualified Language.PureScript.Environment as P import qualified Language.PureScript.Names as P import qualified Language.PureScript.Types as P +renderKindSig :: Text -> KindInfo -> RenderedCode +renderKindSig declTitle KindInfo{..} = + mintersperse sp + [ keyword $ kindSignatureForKeyword kiKeyword + , renderType (P.TypeConstructor () (notQualified declTitle)) + , syntax "::" + , renderType kiKind + ] + renderDeclaration :: Declaration -> RenderedCode renderDeclaration Declaration{..} = mintersperse sp $ case declInfo of diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 377858bf9d..7e7f2e0e0d 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -30,6 +30,7 @@ module Language.PureScript.Docs.RenderedCode.Types , keywordFixity , keywordKind , keywordAs + , kindSignatureFor , ident , dataCtor , typeCtor @@ -54,6 +55,7 @@ import qualified Data.Text.Encoding as TE import Language.PureScript.Names import Language.PureScript.AST (Associativity(..)) +import qualified Language.PureScript.AST.Declarations as P -- | Given a list of actions, attempt them all, returning the first success. -- If all the actions fail, 'tryAll' returns the first argument. @@ -307,6 +309,13 @@ keywordKind = keyword "kind" keywordAs :: RenderedCode keywordAs = keyword "as" +kindSignatureFor :: P.KindSignatureFor -> RenderedCode +kindSignatureFor = \case + P.DataSig -> keywordData + P.NewtypeSig -> keywordNewtype + P.TypeSynonymSig -> keywordType + P.ClassSig -> keywordClass + ident :: Qualified Ident -> RenderedCode ident (fromQualified -> (mn, name)) = RC [Symbol ValueLevel (runIdent name) (Link mn)] diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 6dfc30cf4d..ee2aff8ea3 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -132,6 +132,7 @@ data Declaration = Declaration , declSourceSpan :: Maybe P.SourceSpan , declChildren :: [ChildDeclaration] , declInfo :: DeclarationInfo + , declKind :: Maybe KindInfo } deriving (Show, Eq, Ord, Generic) @@ -184,6 +185,17 @@ data DeclarationInfo instance NFData DeclarationInfo +-- | +-- Wraps enough information to properly render the kind signature +-- of a data/newtype/type/class declaration. +data KindInfo = KindInfo + { kiKeyword :: P.KindSignatureFor + , kiKind :: Type' + } + deriving (Show, Eq, Ord, Generic) + +instance NFData KindInfo + convertFundepsToStrings :: [(Text, Maybe Type')] -> [P.FunctionalDependency] -> [([Text], [Text])] convertFundepsToStrings args fundeps = map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps @@ -347,6 +359,7 @@ data PackageError | InvalidFixity | InvalidKind Text | InvalidDataDeclType Text + | InvalidKindSignatureFor Text | InvalidTime deriving (Show, Eq, Ord, Generic) @@ -530,6 +543,8 @@ displayPackageError e = case e of "Invalid kind: \"" <> str <> "\"" InvalidDataDeclType str -> "Invalid data declaration type: \"" <> str <> "\"" + InvalidKindSignatureFor str -> + "Invalid kind signature keyword: \"" <> str <> "\"" InvalidTime -> "Invalid time" @@ -560,6 +575,7 @@ asDeclaration = <*> key "sourceSpan" (perhaps asSourceSpan) <*> key "children" (eachInArray asChildDeclaration) <*> key "info" asDeclarationInfo + <*> keyOrDefault "kind" Nothing (perhaps asKindInfo) asReExport :: Parse PackageError (InPackage P.ModuleName, [Declaration]) asReExport = @@ -631,6 +647,20 @@ asDeclarationInfo = do other -> throwCustomError (InvalidDeclarationType other) +asKindInfo :: Parse PackageError KindInfo +asKindInfo = + KindInfo <$> key "keyword" asKindSignatureFor + <*> key "kind" asType + +asKindSignatureFor :: Parse PackageError P.KindSignatureFor +asKindSignatureFor = + withText $ \case + "data" -> Right P.DataSig + "newtype" -> Right P.NewtypeSig + "class" -> Right P.ClassSig + "type" -> Right P.TypeSynonymSig + x -> Left (InvalidKindSignatureFor x) + asTypeArguments :: Parse PackageError [(Text, Maybe Type')] asTypeArguments = eachInArray asTypeArgument where @@ -777,8 +807,22 @@ instance A.ToJSON Declaration where , "sourceSpan" .= declSourceSpan , "children" .= declChildren , "info" .= declInfo + , "kind" .= declKind ] +instance A.ToJSON KindInfo where + toJSON KindInfo{..} = + A.object [ "keyword" .= kindSignatureForKeyword kiKeyword + , "kind" .= kiKind + ] + +kindSignatureForKeyword :: P.KindSignatureFor -> Text +kindSignatureForKeyword = \case + P.DataSig -> "data" + P.NewtypeSig -> "newtype" + P.TypeSynonymSig -> "type" + P.ClassSig -> "class" + instance A.ToJSON ChildDeclaration where toJSON ChildDeclaration{..} = A.object [ "title" .= cdeclTitle diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 0ff54b09ea..102d70cd9b 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -106,6 +106,12 @@ data DocsAssertion | ShouldHaveLink P.ModuleName Text Text Docs.Namespace Docs.LinkLocation -- | Assert that a given declaration comes before another in the output | ShouldComeBefore P.ModuleName Text Text + -- | Assert that a given declaration has the given kind signature + | ShouldHaveKindSignature P.ModuleName Text Text + -- | Assert that a given declaration with doc-comments on its + -- kind signature and type declaration are properly merged into one + -- doc-comment. + | ShouldMergeDocComments P.ModuleName Text (Maybe Text) data TagsAssertion -- | Assert that a particular declaration is tagged @@ -161,6 +167,10 @@ displayAssertion = \case ShouldComeBefore mn declA declB -> showQual mn declA <> " should come before " <> showQual mn declB <> " in the docs" + ShouldHaveKindSignature mn decl expected -> + showQual mn decl <> " should have the kind signature `" <> expected <> "`" + ShouldMergeDocComments mn decl _ -> + showQual mn decl <> " should merge its kind declaration and type declaration's doc-comments" displayTagsAssertion :: TagsAssertion -> Text displayTagsAssertion = \case @@ -215,6 +225,18 @@ data DocsAssertionFailure | BadLinkLocation P.ModuleName Text Text Docs.LinkLocation Docs.LinkLocation -- | Declarations were in the wrong order | WrongOrder P.ModuleName Text Text + -- | Expected a kind signature for a declaration, but did not find one + -- Fields: module name, declaration title. + | KindSignatureMissing P.ModuleName Text + -- | The rendered kind signature did not match the expected one. + -- Fields: module name, declaration title, expected kind signature, + -- actual kind signature + | KindSignatureMismatch P.ModuleName Text Text Text + -- | The doc comments for the kind signature and type declaration were + -- not properly merged into the expected one. + -- Fields: module name, declaration title, expected doc-comments, + -- actual doc-comments + | DocCommentMergeFailure P.ModuleName Text Text Text data TagsAssertionFailure -- | A declaration was not tagged, but should have been @@ -265,6 +287,15 @@ displayAssertionFailure = \case " got " <> T.pack (show actual) WrongOrder _ before' after' -> "expected to see " <> before' <> " before " <> after' + KindSignatureMissing _ decl -> + "the kind signature for " <> decl <> " is missing." + KindSignatureMismatch _ decl expected actual -> + "expected the kind signature for " <> decl <> "\n" <> + "to be `" <> expected <> "`\n" <> + " got `" <> actual <> "`" + DocCommentMergeFailure _ decl expected actual -> + "Expected the doc-comment for " <> decl <> " to merge comments and be `" <> + expected <> "`; got `" <> actual <> "`" displayTagsAssertionFailure :: TagsAssertionFailure -> Text displayTagsAssertionFailure = \case @@ -436,6 +467,24 @@ runAssertion assertion linksCtx Docs.Module{..} = (_, Nothing) -> Fail (NotDocumented mn after') + ShouldHaveKindSignature mn decl expected -> + findDeclKinds mn decl $ \case + Just Docs.KindInfo{..} -> + if expected /= actual + then Fail (KindSignatureMismatch mn decl expected actual) + else Pass + where + actual = codeToString $ Docs.renderKindSig decl $ + Docs.KindInfo kiKeyword kiKind + Nothing -> Fail (KindSignatureMissing mn decl) + + ShouldMergeDocComments mn decl expected -> + findDecl mn decl $ \Docs.Declaration{..} -> + if expected == declComments + then Pass + else Fail (DocCommentMergeFailure mn decl (display expected) (display declComments)) + where + display = fromMaybe "" where declarationsFor mn = if mn == modName @@ -452,6 +501,13 @@ runAssertion assertion linksCtx Docs.Module{..} = Just decl -> f decl + findDeclKinds mn title f = + case find ((==) title . Docs.declTitle) (declarationsFor mn) of + Nothing -> + Fail (NotDocumented mn title) + Just Docs.Declaration{..} -> + f declKind + findDeclChildren mn title child f = findDecl mn title $ \Docs.Declaration{..} -> case find ((==) child . Docs.cdeclTitle) declChildren of @@ -667,6 +723,40 @@ testCases = [ ShouldBeDocumented (n "TypeSynonymInstance") "MyNT" ["MyNT", "ntMyNT"] ] ) + , ("KindSignatureDocs", + -- expected kind signatures + [ ShouldHaveKindSignature (n "KindSignatureDocs") "DKindAndType" "data DKindAndType :: forall k. k -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "TKindAndType" "type TKindAndType :: forall k. k -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "NKindAndType" "newtype NKindAndType :: forall k. k -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "CKindAndType" "class CKindAndType :: forall k. (k -> Type) -> k -> Constraint" + + , ShouldHaveKindSignature (n "KindSignatureDocs") "DKindOnly" "data DKindOnly :: forall k. k -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "TKindOnly" "type TKindOnly :: forall k. k -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "NKindOnly" "newtype NKindOnly :: forall k. k -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "CKindOnly" "class CKindOnly :: forall k. (k -> Type) -> k -> Constraint" + + , ShouldHaveKindSignature (n "KindSignatureDocs") "DTypeOnly" "data DTypeOnly :: forall k. k -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "TTypeOnly" "type TTypeOnly :: forall k. k -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "NTypeOnly" "newtype NTypeOnly :: forall k. k -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "CTypeOnly" "class CTypeOnly :: forall k. (k -> Type) -> k -> Constraint" + + -- expected docs + , ShouldMergeDocComments (n "KindSignatureDocs") "DKindAndType" $ Just "dkatk\n\ndkatt\n" + , ShouldMergeDocComments (n "KindSignatureDocs") "TKindAndType" $ Just "tkatk\n\ntkatt\n" + , ShouldMergeDocComments (n "KindSignatureDocs") "NKindAndType" $ Just "nkatk\n\nnkatt\n" + , ShouldMergeDocComments (n "KindSignatureDocs") "CKindAndType" $ Just "ckatk\n\nckatt\n" + + , ShouldMergeDocComments (n "KindSignatureDocs") "DKindOnly" $ Just "dkok\n" + , ShouldMergeDocComments (n "KindSignatureDocs") "TKindOnly" $ Just "tkok\n" + , ShouldMergeDocComments (n "KindSignatureDocs") "NKindOnly" $ Just "nkok\n" + , ShouldMergeDocComments (n "KindSignatureDocs") "CKindOnly" $ Just "ckok\n" + + , ShouldMergeDocComments (n "KindSignatureDocs") "DTypeOnly" $ Just "dtot\n" + , ShouldMergeDocComments (n "KindSignatureDocs") "TTypeOnly" $ Just "ttot\n" + , ShouldMergeDocComments (n "KindSignatureDocs") "NTypeOnly" $ Just "ntot\n" + , ShouldMergeDocComments (n "KindSignatureDocs") "CTypeOnly" $ Just "ctot\n" + ] + ) ] where diff --git a/tests/purs/docs/src/KindSignatureDocs.purs b/tests/purs/docs/src/KindSignatureDocs.purs new file mode 100644 index 0000000000..d7e693e47a --- /dev/null +++ b/tests/purs/docs/src/KindSignatureDocs.purs @@ -0,0 +1,60 @@ +module KindSignatureDocs where + +-- | dkatk +data DKindAndType :: forall k. k -> Type +-- | dkatt +data DKindAndType a = DKindAndType + +-- | tkatk +type TKindAndType :: forall k. k -> Type +-- | tkatt +type TKindAndType a = Int + +-- | nkatk +newtype NKindAndType :: forall k. k -> Type +-- | nkatt +newtype NKindAndType a = NKindAndType Int + +-- | ckatk +class CKindAndType :: forall k. (k -> Type) -> k -> Constraint +-- | ckatt +class CKindAndType a k where + fooKindAndType :: a k -> String + +---------- + +-- | dkok +data DKindOnly :: forall k. k -> Type +data DKindOnly a = DKindOnly + +-- | tkok +type TKindOnly :: forall k. k -> Type +type TKindOnly a = Int + +-- | nkok +newtype NKindOnly :: forall k. k -> Type +newtype NKindOnly a = NKindOnly Int + +-- | ckok +class CKindOnly :: forall k. (k -> Type) -> k -> Constraint +class CKindOnly a k where + fooKindOnly :: a k -> String + +---------- + +data DTypeOnly :: forall k. k -> Type +-- | dtot +data DTypeOnly a = DTypeOnly + +type TTypeOnly :: forall k. k -> Type +-- | ttot +type TTypeOnly a = Int + +newtype NTypeOnly :: forall k. k -> Type +-- | ntot +newtype NTypeOnly a = NTypeOnly Int + +class CTypeOnly :: forall k. (k -> Type) -> k -> Constraint +-- | ctot +class CTypeOnly a k where + fooTypeOnly :: a k -> String From 7f4aea4fb5b9059a4af78a3eb0ba93c26f3943a4 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 26 Jun 2021 12:36:30 -0400 Subject: [PATCH 1361/1580] Remove generated names from errors about instances (#4118) --- CHANGELOG.md | 2 ++ .../Language/PureScript/AST/Declarations.hs | 16 +++++---- .../src/Language/PureScript/Names.hs | 4 +++ .../PureScript/TypeClassDictionaries.hs | 3 ++ .../src/Language/PureScript/Types.hs | 16 ++++++++- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- src/Language/PureScript/Errors.hs | 36 +++++++++++++++---- src/Language/PureScript/Externs.hs | 17 ++++++--- src/Language/PureScript/Interactive.hs | 4 ++- src/Language/PureScript/Renamer.hs | 4 --- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 27 ++++++++------ .../PureScript/TypeChecker/Entailment.hs | 35 ++++++++++-------- tests/Language/PureScript/Ide/StateSpec.hs | 4 +++ .../Class.out => OrphanUnnamedInstance.out} | 4 +-- tests/purs/failing/OrphanUnnamedInstance.purs | 7 ++++ .../failing/OrphanUnnamedInstance/Class.purs | 4 +++ tests/purs/failing/OverlapAcrossModules.out | 4 +-- .../OverlapAcrossModulesUnnamedInstance.out | 4 +-- tests/purs/failing/OverlappingInstances.out | 4 +-- .../failing/OverlappingUnnamedInstances.out | 4 +-- .../failing/PolykindInstanceOverlapping.out | 4 +-- .../PolykindUnnamedInstanceOverlapping.out | 4 +-- .../TooFewUnnamedClassInstanceArgs.out | 15 ++++++++ .../TooFewUnnamedClassInstanceArgs.purs | 8 +++++ .../TypeSynonymsOverlappingInstance.out | 4 +-- ...TypeSynonymsOverlappingUnnamedInstance.out | 4 +-- 27 files changed, 175 insertions(+), 67 deletions(-) rename tests/purs/failing/{OrphanInstance/Class.out => OrphanUnnamedInstance.out} (78%) create mode 100644 tests/purs/failing/OrphanUnnamedInstance.purs create mode 100644 tests/purs/failing/OrphanUnnamedInstance/Class.purs create mode 100644 tests/purs/failing/TooFewUnnamedClassInstanceArgs.out create mode 100644 tests/purs/failing/TooFewUnnamedClassInstanceArgs.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index 5b94210e4c..6191fb1973 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -44,6 +44,8 @@ Bugfixes: * Fix UnusedName warnings for multiple non-recursive let bindings (#4114 by @nwolverson) +* Remove generated names from errors about instances (#4118 by @rhendric) + Internal: * Fix for Haddock (#4072 by @ncaq and @JordanMartinez) diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs index c2d0c85d86..a33e406ed5 100644 --- a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs @@ -147,6 +147,9 @@ importPrim = addDefaultImport (Qualified (Just primModName) primModName) . addDefaultImport (Qualified Nothing primModName) +data NameSource = UserNamed | CompilerNamed + deriving (Show, Generic, NFData, Serialise) + -- | -- An item in a list of explicit imports or exports -- @@ -172,9 +175,9 @@ data DeclarationRef -- | ValueOpRef SourceSpan (OpName 'ValueOpName) -- | - -- A type class instance, created during typeclass desugaring (name, class name, instance types) + -- A type class instance, created during typeclass desugaring -- - | TypeInstanceRef SourceSpan Ident + | TypeInstanceRef SourceSpan Ident NameSource -- | -- A module, in its entirety -- @@ -192,7 +195,7 @@ instance Eq DeclarationRef where (TypeRef _ name dctors) == (TypeRef _ name' dctors') = name == name' && dctors == dctors' (ValueRef _ name) == (ValueRef _ name') = name == name' (ValueOpRef _ name) == (ValueOpRef _ name') = name == name' - (TypeInstanceRef _ name) == (TypeInstanceRef _ name') = name == name' + (TypeInstanceRef _ name _) == (TypeInstanceRef _ name' _) = name == name' (ModuleRef _ name) == (ModuleRef _ name') = name == name' (ReExportRef _ mn ref) == (ReExportRef _ mn' ref') = mn == mn' && ref == ref' _ == _ = False @@ -203,7 +206,7 @@ instance Ord DeclarationRef where TypeRef _ name dctors `compare` TypeRef _ name' dctors' = compare name name' <> compare dctors dctors' ValueRef _ name `compare` ValueRef _ name' = compare name name' ValueOpRef _ name `compare` ValueOpRef _ name' = compare name name' - TypeInstanceRef _ name `compare` TypeInstanceRef _ name' = compare name name' + TypeInstanceRef _ name _ `compare` TypeInstanceRef _ name' _ = compare name name' ModuleRef _ name `compare` ModuleRef _ name' = compare name name' ReExportRef _ mn ref `compare` ReExportRef _ mn' ref' = compare mn mn' <> compare ref ref' compare ref ref' = @@ -232,7 +235,7 @@ declRefSourceSpan (TypeOpRef ss _) = ss declRefSourceSpan (ValueRef ss _) = ss declRefSourceSpan (ValueOpRef ss _) = ss declRefSourceSpan (TypeClassRef ss _) = ss -declRefSourceSpan (TypeInstanceRef ss _) = ss +declRefSourceSpan (TypeInstanceRef ss _ _) = ss declRefSourceSpan (ModuleRef ss _) = ss declRefSourceSpan (ReExportRef ss _ _) = ss @@ -242,7 +245,7 @@ declRefName (TypeOpRef _ n) = TyOpName n declRefName (ValueRef _ n) = IdentName n declRefName (ValueOpRef _ n) = ValOpName n declRefName (TypeClassRef _ n) = TyClassName n -declRefName (TypeInstanceRef _ n) = IdentName n +declRefName (TypeInstanceRef _ n _) = IdentName n declRefName (ModuleRef _ n) = ModName n declRefName (ReExportRef _ _ ref) = declRefName ref @@ -835,6 +838,7 @@ data PathNode t = Leaf t | Branch (PathTree t) newtype AssocList k t = AssocList { runAssocList :: [(k, t)] } deriving (Show, Eq, Ord, Foldable, Functor, Traversable) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''NameSource) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExportSource) diff --git a/lib/purescript-cst/src/Language/PureScript/Names.hs b/lib/purescript-cst/src/Language/PureScript/Names.hs index 6b3eaa4d20..bf18164076 100644 --- a/lib/purescript-cst/src/Language/PureScript/Names.hs +++ b/lib/purescript-cst/src/Language/PureScript/Names.hs @@ -97,6 +97,10 @@ freshIdent name = GenIdent (Just name) <$> fresh freshIdent' :: MonadSupply m => m Ident freshIdent' = GenIdent Nothing <$> fresh +isPlainIdent :: Ident -> Bool +isPlainIdent Ident{} = True +isPlainIdent _ = False + -- | -- Operator alias names. -- diff --git a/lib/purescript-cst/src/Language/PureScript/TypeClassDictionaries.hs b/lib/purescript-cst/src/Language/PureScript/TypeClassDictionaries.hs index d951723a15..3c8306ac43 100644 --- a/lib/purescript-cst/src/Language/PureScript/TypeClassDictionaries.hs +++ b/lib/purescript-cst/src/Language/PureScript/TypeClassDictionaries.hs @@ -33,6 +33,9 @@ data TypeClassDictionaryInScope v , tcdInstanceTypes :: [SourceType] -- | Type class dependencies which must be satisfied to construct this dictionary , tcdDependencies :: Maybe [SourceConstraint] + -- | If this instance was unnamed, the type to use when describing it in + -- error messages + , tcdDescription :: Maybe SourceType } deriving (Show, Functor, Foldable, Traversable, Generic) diff --git a/lib/purescript-cst/src/Language/PureScript/Types.hs b/lib/purescript-cst/src/Language/PureScript/Types.hs index a25943ef73..061d96c10d 100644 --- a/lib/purescript-cst/src/Language/PureScript/Types.hs +++ b/lib/purescript-cst/src/Language/PureScript/Types.hs @@ -14,7 +14,7 @@ import Control.Monad ((<=<), (>=>)) import Data.Aeson ((.:), (.:?), (.!=), (.=)) import qualified Data.Aeson as A import qualified Data.Aeson.Types as A -import Data.Foldable (fold) +import Data.Foldable (fold, foldl') import qualified Data.IntSet as IS import Data.List (sort, sortOn) import Data.Maybe (fromMaybe, isJust) @@ -590,6 +590,20 @@ unapplyConstraints = go [] go acc (ConstrainedType _ con ty) = go (con : acc) ty go acc ty = (reverse acc, ty) +-- | Construct the type of an instance declaration from its parts. Used in +-- error messages describing unnamed instances. +srcInstanceType + :: SourceSpan + -> [(Text, SourceType)] + -> Qualified (ProperName 'ClassName) + -> [SourceType] + -> SourceType +srcInstanceType ss vars className tys + = setAnnForType (ss, []) + . flip (foldr $ \(tv, k) ty -> srcForAll tv (Just k) ty Nothing) vars + . flip (foldl' srcTypeApp) tys + $ srcTypeConstructor $ coerceProperName <$> className + everywhereOnTypes :: (Type a -> Type a) -> Type a -> Type a everywhereOnTypes f = go where go (TypeApp ann t1 t2) = f (TypeApp ann (go t1) (go t2)) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 4b77836ace..f846eafaae 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -254,7 +254,7 @@ exportToCoreFn (A.TypeOpRef _ _) = [] exportToCoreFn (A.ValueRef _ name) = [name] exportToCoreFn (A.ValueOpRef _ _) = [] exportToCoreFn (A.TypeClassRef _ name) = [properToIdent name] -exportToCoreFn (A.TypeInstanceRef _ name) = [name] +exportToCoreFn (A.TypeInstanceRef _ name _) = [name] exportToCoreFn (A.ModuleRef _ _) = [] exportToCoreFn (A.ReExportRef _ _ _) = [] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6fce239501..9029417740 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -12,6 +12,7 @@ import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.State.Lazy import Control.Monad.Writer +import Data.Bitraversable (bitraverse) import Data.Char (isSpace) import Data.Either (partitionEithers) import Data.Foldable (fold) @@ -99,7 +100,7 @@ data SimpleErrorMessage | TypesDoNotUnify SourceType SourceType | KindsDoNotUnify SourceType SourceType | ConstrainedTypeUnified SourceType SourceType - | OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified Ident] + | OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified (Either SourceType Ident)] | NoInstanceFound SourceConstraint -- ^ constraint that could not be solved Bool -- ^ whether eliminating unknowns with annotations might help @@ -452,7 +453,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t gSimple (NoInstanceFound con unks) = NoInstanceFound <$> overConstraintArgs (traverse f) con <*> pure unks gSimple (AmbiguousTypeVariables t us) = AmbiguousTypeVariables <$> f t <*> pure us - gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts + gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> traverse (traverse $ bitraverse f pure) insts gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts gSimple (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts @@ -851,7 +852,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , Box.vcat Box.left (map prettyTypeAtom ts) ] , line "The following instances were found:" - , indent $ paras (map (line . showQualified showIdent) ds) + , indent $ paras (map prettyInstanceName ds) ] renderSimpleErrorMessage (UnknownClass nm) = paras [ line "No type class instance was found for class" @@ -1015,7 +1016,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (AdditionalProperty prop) = line $ "Type of expression contains additional label " <> markCode (prettyPrintLabel prop) <> "." renderSimpleErrorMessage (OrphanInstance nm cnm nonOrphanModules ts) = - paras [ line $ "Orphan instance " <> markCode (showIdent nm) <> " found for " + paras [ line $ "Orphan instance" <> prettyPrintPlainIdent nm <> " found for " , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName cnm) , Box.vcat Box.left (map prettyTypeAtom ts) @@ -1223,7 +1224,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (ClassInstanceArityMismatch dictName className expected actual) = paras [ line $ "The type class " <> markCode (showQualified runProperName className) <> " expects " <> T.pack (show expected) <> " " <> argsMsg <> "." - , line $ "But the instance " <> markCode (showIdent dictName) <> mismatchMsg <> T.pack (show actual) <> "." + , line $ "But the instance" <> prettyPrintPlainIdent dictName <> mismatchMsg <> T.pack (show actual) <> "." ] where mismatchMsg = if actual > expected then " provided " else " only provided " @@ -1659,6 +1660,27 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl hintCategory PositionedError{} = PositionHint hintCategory _ = OtherHint + prettyPrintPlainIdent :: Ident -> Text + prettyPrintPlainIdent ident = + if isPlainIdent ident + then " " <> markCode (showIdent ident) + else "" + + prettyInstanceName :: Qualified (Either SourceType Ident) -> Box.Box + prettyInstanceName = \case + Qualified maybeMn (Left ty) -> + "instance " + Box.<> (case maybeMn of + Just mn -> "in module " + Box.<> line (markCode $ runModuleName mn) + Box.<> " " + Nothing -> Box.nullBox) + Box.<> "with type " + Box.<> markCodeBox (prettyType ty) + Box.<> " " + Box.<> (line . displayStartEndPos . fst $ getAnnForType ty) + Qualified mn (Right inst) -> line . markCode . showQualified showIdent $ Qualified mn inst + -- Pretty print and export declaration prettyPrintExport :: DeclarationRef -> Text prettyPrintExport (TypeRef _ pn _) = runProperName pn @@ -1690,8 +1712,10 @@ prettyPrintRef (ValueOpRef _ op) = Just $ showOp op prettyPrintRef (TypeClassRef _ pn) = Just $ "class " <> runProperName pn -prettyPrintRef (TypeInstanceRef _ ident) = +prettyPrintRef (TypeInstanceRef _ ident UserNamed) = Just $ showIdent ident +prettyPrintRef (TypeInstanceRef _ _ CompilerNamed) = + Nothing prettyPrintRef (ModuleRef _ name) = Just $ "module " <> runModuleName name prettyPrintRef ReExportRef{} = diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 942f70db38..9a4d137c70 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -152,6 +152,8 @@ data ExternsDeclaration = , edInstanceConstraints :: Maybe [SourceConstraint] , edInstanceChain :: Maybe ChainId , edInstanceChainIndex :: Integer + , edInstanceNameSource :: NameSource + , edInstanceSourceSpan :: SourceSpan } deriving (Show, Generic) @@ -173,18 +175,23 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } applyDecl env (EDClass pn args members cs deps tcIsEmpty) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) } - applyDecl env (EDInstance className ident vars kinds tys cs ch idx) = + applyDecl env (EDInstance className ident vars kinds tys cs ch idx ns ss) = env { typeClassDictionaries = updateMap (updateMap (M.insertWith (<>) (qual ident) (pure dict)) className) (Just efModuleName) (typeClassDictionaries env) } where dict :: NamedDict - dict = TypeClassDictionaryInScope ch idx (qual ident) [] className vars kinds tys cs + dict = TypeClassDictionaryInScope ch idx (qual ident) [] className vars kinds tys cs instTy updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a updateMap f = M.alter (Just . f . fold) + instTy :: Maybe SourceType + instTy = case ns of + CompilerNamed -> Just $ srcInstanceType ss vars className tys + UserNamed -> Nothing + qual :: a -> Qualified a qual = Qualified (Just efModuleName) @@ -249,8 +256,8 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF , EDTypeSynonym dictName synArgs synTy , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies typeClassIsEmpty ] - toExternsDeclaration (TypeInstanceRef _ ident) - = [ EDInstance tcdClassName (lookupRenamedIdent ident) tcdForAll tcdInstanceKinds tcdInstanceTypes tcdDependencies tcdChain tcdIndex + toExternsDeclaration (TypeInstanceRef ss' ident ns) + = [ EDInstance tcdClassName (lookupRenamedIdent ident) tcdForAll tcdInstanceKinds tcdInstanceTypes tcdDependencies tcdChain tcdIndex ns ss' | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env)) , m2 <- M.elems m1 , nel <- maybeToList (M.lookup (Qualified (Just mn) ident) m2) @@ -261,7 +268,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF renameRef :: DeclarationRef -> DeclarationRef renameRef = \case ValueRef ss' ident -> ValueRef ss' $ lookupRenamedIdent ident - TypeInstanceRef ss' ident -> TypeInstanceRef ss' $ lookupRenamedIdent ident + TypeInstanceRef ss' ident _ | not $ isPlainIdent ident -> TypeInstanceRef ss' (lookupRenamedIdent ident) CompilerNamed other -> other lookupRenamedIdent :: Ident -> Ident diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index b61ed6a079..a88534b3e4 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -218,8 +218,10 @@ handleShowImportedModules print' = do Just $ N.showOp op showRef (P.TypeClassRef _ pn) = Just $ "class " <> N.runProperName pn - showRef (P.TypeInstanceRef _ ident) = + showRef (P.TypeInstanceRef _ ident P.UserNamed) = Just $ N.runIdent ident + showRef (P.TypeInstanceRef _ _ P.CompilerNamed) = + Nothing showRef (P.ModuleRef _ name) = Just $ "module " <> N.runModuleName name showRef (P.ReExportRef _ _ _) = diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index 75a5335261..6a97078636 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -214,7 +214,3 @@ renameInBinder (ConstructorBinder ann tctor dctor bs) = ConstructorBinder ann tctor dctor <$> traverse renameInBinder bs renameInBinder (NamedBinder ann name b) = NamedBinder ann <$> updateScope name <*> renameInBinder b - -isPlainIdent :: Ident -> Bool -isPlainIdent Ident{} = True -isPlainIdent _ = False diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 9b09a7e912..5955e2ea73 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -239,7 +239,7 @@ desugarDecl syns kinds mn exps = go expRef :: Ident -> Qualified (ProperName 'ClassName) -> [SourceType] -> Maybe DeclarationRef expRef name className tys - | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef genSpan name + | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef genSpan name UserNamed | otherwise = Nothing isExportedClass :: Qualified (ProperName 'ClassName) -> Bool diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 0a169950a3..9125fb30f0 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -8,7 +8,7 @@ module Language.PureScript.TypeChecker ) where import Prelude.Compat -import Protolude (headMay, ordNub) +import Protolude (headMay, maybeToLeft, ordNub) import Control.Monad (when, unless, void, forM, zipWithM_) import Control.Monad.Error.Class (MonadError(..)) @@ -417,10 +417,12 @@ typeCheckAll moduleName _ = traverse go let nonOrphanModules = findNonOrphanModules className typeClass tys'' checkOrphanInstance dictName className tys'' nonOrphanModules let chainId = Just ch - checkOverlappingInstance chainId dictName className typeClass tys'' nonOrphanModules + checkOverlappingInstance ss chainId dictName vars className typeClass tys'' nonOrphanModules _ <- traverseTypeInstanceBody checkInstanceMembers body deps'' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps' - let dict = TypeClassDictionaryInScope chainId idx qualifiedDictName [] className vars kinds' tys'' (Just deps'') + let dict = + TypeClassDictionaryInScope chainId idx qualifiedDictName [] className vars kinds' tys'' (Just deps'') $ + if isPlainIdent dictName then Nothing else Just $ srcInstanceType ss vars className tys'' addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict) return d @@ -491,27 +493,32 @@ typeCheckAll moduleName _ = traverse go -- flexible instances: the instances `Cls X y` and `Cls x Y` overlap and -- could live in different modules but won't be caught here. checkOverlappingInstance - :: Maybe ChainId + :: SourceSpan + -> Maybe ChainId -> Ident + -> [(Text, SourceType)] -> Qualified (ProperName 'ClassName) -> TypeClassData -> [SourceType] -> S.Set ModuleName -> m () - checkOverlappingInstance ch dictName className typeClass tys' nonOrphanModules = do + checkOverlappingInstance ss ch dictName vars className typeClass tys' nonOrphanModules = do for_ nonOrphanModules $ \m -> do dicts <- M.toList <$> lookupTypeClassDictionariesForClass (Just m) className - for_ dicts $ \(ident, dictNel) -> do + for_ dicts $ \(Qualified mn' ident, dictNel) -> do for_ dictNel $ \dict -> do -- ignore instances in the same instance chain if ch == tcdChain dict || instancesAreApart (typeClassCoveringSets typeClass) tys' (tcdInstanceTypes dict) then return () - else throwError . errorMessage $ - OverlappingInstances className - tys' - [ident, Qualified (Just moduleName) dictName] + else do + let this = if isPlainIdent dictName then Right dictName else Left $ srcInstanceType ss vars className tys' + let that = Qualified mn' . maybeToLeft ident $ tcdDescription dict + throwError . errorMessage $ + OverlappingInstances className + tys' + [that, Qualified (Just moduleName) this] instancesAreApart :: S.Set (S.Set Int) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 5cf3419a9a..eb338a018c 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -174,7 +174,7 @@ entails SolverOptions{..} constraint context hints = forClassName _ ctx cn@C.Warn _ [msg] = -- Prefer a warning dictionary in scope if there is one available. -- This allows us to defer a warning by propagating the constraint. - findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope Nothing 0 (WarnInstance msg) [] C.Warn [] [] [msg] Nothing] + findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope Nothing 0 (WarnInstance msg) [] C.Warn [] [] [msg] Nothing Nothing] forClassName _ _ C.IsSymbol _ args | Just dicts <- solveIsSymbol args = dicts forClassName _ _ C.SymbolCompare _ args | Just dicts <- solveSymbolCompare args = dicts forClassName _ _ C.SymbolAppend _ args | Just dicts <- solveSymbolAppend args = dicts @@ -333,9 +333,16 @@ entails SolverOptions{..} constraint context hints = unique _ _ [(a, dict)] _ = return $ Solved a dict unique _ tyArgs tcds _ | pairwiseAny overlapping (map snd tcds) = - throwError . errorMessage $ OverlappingInstances className' tyArgs (tcds >>= (toList . namedInstanceIdentifier . tcdValue . snd)) + throwError . errorMessage $ OverlappingInstances className' tyArgs (tcds >>= (toList . tcdToInstanceDescription . snd)) | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds) + tcdToInstanceDescription :: TypeClassDict -> Maybe (Qualified (Either SourceType Ident)) + tcdToInstanceDescription TypeClassDictionaryInScope{ tcdDescription, tcdValue } = + let nii = namedInstanceIdentifier tcdValue + in case tcdDescription of + Just ty -> flip Qualified (Left ty) <$> fmap getQual nii + Nothing -> fmap Right <$> nii + canBeGeneralized :: Type a -> Bool canBeGeneralized TUnknown{} = True canBeGeneralized (KindedType _ t _) = canBeGeneralized t @@ -407,13 +414,13 @@ entails SolverOptions{..} constraint context hints = -- We may have collected hints for the solving failure along the way, in -- which case we decorate the error with the first one. maybe id addHint (listToMaybe hints') `rethrow` case inertWanteds of - [] -> pure $ Just [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] Nothing] + [] -> pure $ Just [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.Coercible [] kinds [a, b] Nothing Nothing] (k, a', b') : _ | a' == b && b' == a -> throwError $ insoluble k b' a' (k, a', b') : _ -> throwError $ insoluble k a' b' solveCoercible _ _ _ _ = pure Nothing solveIsSymbol :: [SourceType] -> Maybe [TypeClassDict] - solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope Nothing 0 (IsSymbolInstance sym) [] C.IsSymbol [] [] [TypeLevelString ann sym] Nothing] + solveIsSymbol [TypeLevelString ann sym] = Just [TypeClassDictionaryInScope Nothing 0 (IsSymbolInstance sym) [] C.IsSymbol [] [] [TypeLevelString ann sym] Nothing Nothing] solveIsSymbol _ = Nothing solveSymbolCompare :: [SourceType] -> Maybe [TypeClassDict] @@ -423,14 +430,14 @@ entails SolverOptions{..} constraint context hints = EQ -> C.orderingEQ GT -> C.orderingGT args' = [arg0, arg1, srcTypeConstructor ordering] - in Just [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolCompare [] [] args' Nothing] + in Just [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolCompare [] [] args' Nothing Nothing] solveSymbolCompare _ = Nothing solveSymbolAppend :: [SourceType] -> Maybe [TypeClassDict] solveSymbolAppend [arg0, arg1, arg2] = do (arg0', arg1', arg2') <- appendSymbols arg0 arg1 arg2 let args' = [arg0', arg1', arg2'] - pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolAppend [] [] args' Nothing] + pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolAppend [] [] args' Nothing Nothing] solveSymbolAppend _ = Nothing -- | Append type level symbols, or, run backwards, strip a prefix or suffix @@ -452,7 +459,7 @@ entails SolverOptions{..} constraint context hints = solveSymbolCons [arg0, arg1, arg2] = do (arg0', arg1', arg2') <- consSymbol arg0 arg1 arg2 let args' = [arg0', arg1', arg2'] - pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolCons [] [] args' Nothing] + pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolCons [] [] args' Nothing Nothing] solveSymbolCons _ = Nothing consSymbol :: SourceType -> SourceType -> SourceType -> Maybe (SourceType, SourceType, SourceType) @@ -470,7 +477,7 @@ entails SolverOptions{..} constraint context hints = solveUnion :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] solveUnion kinds [l, r, u] = do (lOut, rOut, uOut, cst, vars) <- unionRows kinds l r u - pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowUnion vars kinds [lOut, rOut, uOut] cst ] + pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowUnion vars kinds [lOut, rOut, uOut] cst Nothing ] solveUnion _ _ = Nothing -- | Left biased union of two row types @@ -501,13 +508,13 @@ entails SolverOptions{..} constraint context hints = solveRowCons :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] solveRowCons kinds [TypeLevelString ann sym, ty, r, _] = - Just [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowCons [] kinds [TypeLevelString ann sym, ty, r, srcRCons (Label sym) ty r] Nothing ] + Just [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowCons [] kinds [TypeLevelString ann sym, ty, r, srcRCons (Label sym) ty r] Nothing Nothing ] solveRowCons _ _ = Nothing solveRowToList :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] solveRowToList [kind] [r, _] = do entries <- rowToRowList kind r - pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowToList [] [kind] [r, entries] Nothing ] + pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowToList [] [kind] [r, entries] Nothing Nothing ] solveRowToList _ _ = Nothing -- | Convert a closed row to a sorted list of entries @@ -526,7 +533,7 @@ entails SolverOptions{..} constraint context hints = solveNub :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] solveNub kinds [r, _] = do r' <- nubRows r - pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowNub [] kinds [r, r'] Nothing ] + pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowNub [] kinds [r, r'] Nothing Nothing ] solveNub _ _ = Nothing nubRows :: SourceType -> Maybe SourceType @@ -538,10 +545,10 @@ entails SolverOptions{..} constraint context hints = solveLacks :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] solveLacks kinds tys@[_, REmptyKinded _ _] = - pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowLacks [] kinds tys Nothing ] + pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowLacks [] kinds tys Nothing Nothing ] solveLacks kinds [TypeLevelString ann sym, r] = do (r', cst) <- rowLacks kinds sym r - pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowLacks [] kinds [TypeLevelString ann sym, r'] cst ] + pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowLacks [] kinds [TypeLevelString ann sym, r'] cst Nothing ] solveLacks _ _ = Nothing rowLacks :: [SourceType] -> PSString -> SourceType -> Maybe (SourceType, Maybe [SourceConstraint]) @@ -698,7 +705,7 @@ newDictionaries path name (Constraint _ className instanceKinds instanceTy _) = (replaceAllTypeVars sub <$> supArgs) Nothing) ) typeClassSuperclasses [0..] - return (TypeClassDictionaryInScope Nothing 0 name path className [] instanceKinds instanceTy Nothing : supDicts) + return (TypeClassDictionaryInScope Nothing 0 name path className [] instanceKinds instanceTy Nothing Nothing : supDicts) mkContext :: [NamedDict] -> InstanceContext mkContext = foldr combineContexts M.empty . map fromDict where diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index e269455987..a30b57ce99 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -68,6 +68,10 @@ ef = P.ExternsFile Nothing -- , edInstanceChainIndex = 0 + -- , edInstanceNameSource = + P.UserNamed + -- , edInstanceSourceSpan = + P.NullSourceSpan -- } ] --, efSourceSpan = diff --git a/tests/purs/failing/OrphanInstance/Class.out b/tests/purs/failing/OrphanUnnamedInstance.out similarity index 78% rename from tests/purs/failing/OrphanInstance/Class.out rename to tests/purs/failing/OrphanUnnamedInstance.out index 356d84cb09..52447d1cca 100644 --- a/tests/purs/failing/OrphanInstance/Class.out +++ b/tests/purs/failing/OrphanUnnamedInstance.out @@ -1,8 +1,8 @@ Error found: in module Test -at tests/purs/failing/OrphanInstance.purs:6:1 - 7:11 (line 6, column 1 - line 7, column 11) +at tests/purs/failing/OrphanUnnamedInstance.purs:6:1 - 7:11 (line 6, column 1 - line 7, column 11) - Orphan instance cBoolean found for + Orphan instance found for    Class.C Boolean   diff --git a/tests/purs/failing/OrphanUnnamedInstance.purs b/tests/purs/failing/OrphanUnnamedInstance.purs new file mode 100644 index 0000000000..c5a7db3969 --- /dev/null +++ b/tests/purs/failing/OrphanUnnamedInstance.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith OrphanInstance +module Test where + +import Class + +instance C Boolean where + op a = a diff --git a/tests/purs/failing/OrphanUnnamedInstance/Class.purs b/tests/purs/failing/OrphanUnnamedInstance/Class.purs new file mode 100644 index 0000000000..0b482d48a1 --- /dev/null +++ b/tests/purs/failing/OrphanUnnamedInstance/Class.purs @@ -0,0 +1,4 @@ +module Class where + +class C a where + op :: a -> a diff --git a/tests/purs/failing/OverlapAcrossModules.out b/tests/purs/failing/OverlapAcrossModules.out index ae7c7037f3..1da4826c5f 100644 --- a/tests/purs/failing/OverlapAcrossModules.out +++ b/tests/purs/failing/OverlapAcrossModules.out @@ -9,8 +9,8 @@ at tests/purs/failing/OverlapAcrossModules.purs:6:1 - 6:22 (line 6, column 1 - l   The following instances were found: - OverlapAcrossModules.X.cxy - OverlapAcrossModules.cxy + OverlapAcrossModules.X.cxy + OverlapAcrossModules.cxy in type class instance diff --git a/tests/purs/failing/OverlapAcrossModulesUnnamedInstance.out b/tests/purs/failing/OverlapAcrossModulesUnnamedInstance.out index 6d0fe73b86..9ea61e29b4 100644 --- a/tests/purs/failing/OverlapAcrossModulesUnnamedInstance.out +++ b/tests/purs/failing/OverlapAcrossModulesUnnamedInstance.out @@ -9,8 +9,8 @@ at tests/purs/failing/OverlapAcrossModulesUnnamedInstance.purs:6:1 - 6:15 (line   The following instances were found: - OverlapAcrossModules.X.cX - OverlapAcrossModules.$cXY0 + OverlapAcrossModules.X.cX + instance in module OverlapAcrossModules with type C X Y (line 6, column 1 - line 6, column 15) in type class instance diff --git a/tests/purs/failing/OverlappingInstances.out b/tests/purs/failing/OverlappingInstances.out index 19b0cfc556..f4c096b695 100644 --- a/tests/purs/failing/OverlappingInstances.out +++ b/tests/purs/failing/OverlappingInstances.out @@ -8,8 +8,8 @@ at tests/purs/failing/OverlappingInstances.purs:10:1 - 11:13 (line 10, column 1   The following instances were found: - Main.testRefl - Main.testInt + Main.testRefl + Main.testInt in type class instance diff --git a/tests/purs/failing/OverlappingUnnamedInstances.out b/tests/purs/failing/OverlappingUnnamedInstances.out index 2943fa6873..22f0525f1c 100644 --- a/tests/purs/failing/OverlappingUnnamedInstances.out +++ b/tests/purs/failing/OverlappingUnnamedInstances.out @@ -8,8 +8,8 @@ at tests/purs/failing/OverlappingUnnamedInstances.purs:10:1 - 11:13 (line 10, co   The following instances were found: - Main.$test1 - Main.$testInt2 + instance in module Main with type forall a. Test a (line 7, column 1 - line 8, column 13) + instance in module Main with type Test Int (line 10, column 1 - line 11, column 13) in type class instance diff --git a/tests/purs/failing/PolykindInstanceOverlapping.out b/tests/purs/failing/PolykindInstanceOverlapping.out index f9b3b77df5..866b9af3a9 100644 --- a/tests/purs/failing/PolykindInstanceOverlapping.out +++ b/tests/purs/failing/PolykindInstanceOverlapping.out @@ -8,8 +8,8 @@ at tests/purs/failing/PolykindInstanceOverlapping.purs:12:1 - 13:19 (line 12, co   The following instances were found: - Main.test1 - Main.test2 + Main.test1 + Main.test2 in type class instance diff --git a/tests/purs/failing/PolykindUnnamedInstanceOverlapping.out b/tests/purs/failing/PolykindUnnamedInstanceOverlapping.out index b46d4f743c..5e84fbb8e9 100644 --- a/tests/purs/failing/PolykindUnnamedInstanceOverlapping.out +++ b/tests/purs/failing/PolykindUnnamedInstanceOverlapping.out @@ -8,8 +8,8 @@ at tests/purs/failing/PolykindUnnamedInstanceOverlapping.purs:12:1 - 13:19 (line   The following instances were found: - Main.$showPProxy2 - Main.$showPProxy3 + instance in module Main with type forall a. ShowP (Proxy a) (line 9, column 1 - line 10, column 19) + instance in module Main with type forall a. ShowP (Proxy a) (line 12, column 1 - line 13, column 19) in type class instance diff --git a/tests/purs/failing/TooFewUnnamedClassInstanceArgs.out b/tests/purs/failing/TooFewUnnamedClassInstanceArgs.out new file mode 100644 index 0000000000..589715e368 --- /dev/null +++ b/tests/purs/failing/TooFewUnnamedClassInstanceArgs.out @@ -0,0 +1,15 @@ +Error found: +in module Main +at tests/purs/failing/TooFewUnnamedClassInstanceArgs.purs:8:1 - 8:20 (line 8, column 1 - line 8, column 20) + + The type class Main.Foo expects 2 arguments. + But the instance only provided 1. + +in type class instance +  + Main.Foo String +  + +See https://github.com/purescript/documentation/blob/master/errors/ClassInstanceArityMismatch.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TooFewUnnamedClassInstanceArgs.purs b/tests/purs/failing/TooFewUnnamedClassInstanceArgs.purs new file mode 100644 index 0000000000..140b60b4a2 --- /dev/null +++ b/tests/purs/failing/TooFewUnnamedClassInstanceArgs.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith ClassInstanceArityMismatch +module Main where + +import Prelude + +class Foo a b + +instance Foo String diff --git a/tests/purs/failing/TypeSynonymsOverlappingInstance.out b/tests/purs/failing/TypeSynonymsOverlappingInstance.out index edea0baaf3..7365f496a1 100644 --- a/tests/purs/failing/TypeSynonymsOverlappingInstance.out +++ b/tests/purs/failing/TypeSynonymsOverlappingInstance.out @@ -9,8 +9,8 @@ at tests/purs/failing/TypeSynonymsOverlappingInstance.purs:14:1 - 15:16 (line 14   The following instances were found: - Main.convertSB - Main.convertSS + Main.convertSB + Main.convertSS in type class instance diff --git a/tests/purs/failing/TypeSynonymsOverlappingUnnamedInstance.out b/tests/purs/failing/TypeSynonymsOverlappingUnnamedInstance.out index 6e5b2922e1..d510bad034 100644 --- a/tests/purs/failing/TypeSynonymsOverlappingUnnamedInstance.out +++ b/tests/purs/failing/TypeSynonymsOverlappingUnnamedInstance.out @@ -9,8 +9,8 @@ at tests/purs/failing/TypeSynonymsOverlappingUnnamedInstance.purs:14:1 - 15:16 (   The following instances were found: - Main.$convertStringBar0 - Main.$convertStringString1 + instance in module Main with type Convert String String (line 11, column 1 - line 12, column 16) + instance in module Main with type Convert String String (line 14, column 1 - line 15, column 16) in type class instance From 962d94f2494247c3c81b424a348b8e30355525ac Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sat, 26 Jun 2021 11:41:07 -0700 Subject: [PATCH 1362/1580] Display inferred kind signatures in HTML docs (#4119) * Test that inferred kind signatures appear in docs * Insert inferred kind signatures into docs without restraint * Replace 'forall (k :: Type). k -> ...' with 'forall k. k -> ...' * Test: kind signatures where all type params have kind `Type` are hidden * In docs, don't show kind signatures in docs `(Type ->)* -> Terminal` kind signatures in docs * Test that terminals don't have kind signatures either * Test that kind signatures with mixed kinds are displayed * Update changelog --- CHANGELOG.md | 39 ++++------ src/Language/PureScript/Docs/Convert.hs | 87 +++++++++++++++++++++- tests/TestDocs.hs | 65 ++++++++++++++-- tests/purs/docs/src/KindSignatureDocs.purs | 49 ++++++++++++ 4 files changed, 206 insertions(+), 34 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6191fb1973..8895f0796c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,31 +8,20 @@ Breaking changes: New features: -* Display kind signatures and their comments in documentation (#4100 by JordanMartinez) - - Previously, data/newtype/type/class declarations that have explicit kind - signatures would not display those kind signatures in their documentation. - For example, the two below types... - - ```purescript - data PolyProxy :: forall k. k -> Type - data PolyProxy a = PolyProxy - - data TypeProxy :: Type -> Type - data TypeProxy a = TypeProxy - ``` - - ... would only show the following information in their docs. One cannot - be distinguished from another due to the missing kind signatures: - - ``` - data PolyProxy a = PolyProxy - - data TypeProxy a = TypeProxy - ``` - - Now, these types' kind signatures are displayed above their declarations - in their docs, similar to what one would see in the source code. +* Display kind signatures and their comments in documentation (#4100 and #4119 by JordanMartinez) + + The compiler now displays kind signatures for data, newtype, type + synonym, and type class declarations in generated documentation. The + compiler now also includes documentation-comments (i.e. those which start + with a `|` character) both above and below the associated kind signature + declaration (if any) in generated documentation, whereas previously + documentation-comments above a kind signature declaration were ignored. + + Both explicitly declared and inferred kinds are included in documentation. + The compiler omits including a kind signature in generated documentation + only when the kind is considered "uninteresting". An uninteresting kind is + defined as one where all of the declaration's type parameters have kind + `Type`. Bugfixes: diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 9dd57ce6b8..306324d6ce 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -25,6 +25,7 @@ import qualified Language.PureScript.Environment as P import qualified Language.PureScript.Names as P import qualified Language.PureScript.Sugar as P import qualified Language.PureScript.Types as P +import qualified Language.PureScript.Constants.Prim as Prim -- | -- Convert a single module to a Docs.Module, making use of a pre-existing @@ -39,15 +40,21 @@ convertModule :: P.Module -> m Module convertModule externs env checkEnv = - fmap (insertValueTypes checkEnv . convertSingleModule) . partiallyDesugar externs env + fmap (insertValueTypesAndAdjustKinds checkEnv . convertSingleModule) . partiallyDesugar externs env -- | -- Updates all the types of the ValueDeclarations inside the module based on -- their types inside the given Environment. -- -insertValueTypes :: +-- Removes explicit kind signatures if they are "uninteresting." +-- +-- Inserts inferred kind signatures into the corresponding declarations +-- if no kind signature was declared explicitly and the kind +-- signature is "interesting." +-- +insertValueTypesAndAdjustKinds :: P.Environment -> Module -> Module -insertValueTypes env m = +insertValueTypesAndAdjustKinds env m = m { modDeclarations = map go (modDeclarations m) } where -- insert value types @@ -57,6 +64,18 @@ insertValueTypes env m = ty = lookupName ident in d { declInfo = ValueDeclaration (ty $> ()) } + + go d@Declaration{..} | Just keyword <- extractKeyword declInfo = + case declKind of + Just ks -> + -- hide explicit kind signatures that are "uninteresting" + if isUninteresting keyword $ kiKind ks + then d { declKind = Nothing } + else d + Nothing -> + -- insert inferred kinds so long as they are "interesting" + insertInferredKind d declTitle keyword + go other = other @@ -71,6 +90,68 @@ insertValueTypes env m = Nothing -> err ("name not found: " ++ show key) + -- | + -- Extracts the keyword for a declaration (if there is one) + extractKeyword :: DeclarationInfo -> Maybe P.KindSignatureFor + extractKeyword = \case + DataDeclaration dataDeclType _ -> Just $ case dataDeclType of + P.Data -> P.DataSig + P.Newtype -> P.NewtypeSig + TypeSynonymDeclaration _ _ -> Just P.TypeSynonymSig + TypeClassDeclaration _ _ _ -> Just P.ClassSig + _ -> Nothing + + -- | + -- Returns True if the kind signature is "uninteresting", which + -- is a kind that follows this form: + -- - `Type` + -- - `Constraint` (class declaration only) + -- - `Type -> K` where `K` is an "uninteresting" kind + isUninteresting + :: P.KindSignatureFor -> P.Type () -> Bool + isUninteresting keyword = \case + P.TypeApp _ t1 t2 | t1 == kindFunctionType -> + isUninteresting keyword t2 + x -> + x == kindPrimType || (isClassKeyword && x == kindPrimConstraint) + where + isClassKeyword = case keyword of + P.ClassSig -> True + _ -> False + + insertInferredKind :: Declaration -> Text -> P.KindSignatureFor -> Declaration + insertInferredKind d name keyword = + let + key = P.Qualified (Just (modName m)) (P.ProperName name) + in case Map.lookup key (P.types env) of + Just (inferredKind, _) -> + if isUninteresting keyword inferredKind' + then d + else d { declKind = Just $ KindInfo + { kiKeyword = keyword + , kiKind = dropTypeSortAnnotation inferredKind' + } + } + where + inferredKind' = inferredKind $> () + + -- changes `forall (k :: Type). k -> ...` + -- to `forall k . k -> ...` + dropTypeSortAnnotation = \case + P.ForAll sa txt (Just kAnn) rest skol | kAnn == kindPrimType -> + P.ForAll sa txt Nothing (dropTypeSortAnnotation rest) skol + rest -> rest + + Nothing -> + err ("type not found: " ++ show key) + + -- constants for kind signature-related code + kindPrimType = P.TypeConstructor () Prim.Type + kindPrimFunction = P.TypeConstructor () Prim.Function + kindPrimConstraint = P.TypeConstructor () Prim.Constraint + -- `Type ->` + kindFunctionType = P.TypeApp () kindPrimFunction kindPrimType + err msg = P.internalError ("Docs.Convert.insertValueTypes: " ++ msg) diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 102d70cd9b..aa03b527f0 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -108,6 +108,8 @@ data DocsAssertion | ShouldComeBefore P.ModuleName Text Text -- | Assert that a given declaration has the given kind signature | ShouldHaveKindSignature P.ModuleName Text Text + -- | Assert that a given declaration does not have a kind signature + | ShouldNotHaveKindSignature P.ModuleName Text -- | Assert that a given declaration with doc-comments on its -- kind signature and type declaration are properly merged into one -- doc-comment. @@ -169,6 +171,8 @@ displayAssertion = \case " in the docs" ShouldHaveKindSignature mn decl expected -> showQual mn decl <> " should have the kind signature `" <> expected <> "`" + ShouldNotHaveKindSignature mn decl -> + showQual mn decl <> " should not have a kind signature." ShouldMergeDocComments mn decl _ -> showQual mn decl <> " should merge its kind declaration and type declaration's doc-comments" @@ -229,9 +233,13 @@ data DocsAssertionFailure -- Fields: module name, declaration title. | KindSignatureMissing P.ModuleName Text -- | The rendered kind signature did not match the expected one. - -- Fields: module name, declaration title, expected kind signature, - -- actual kind signature - | KindSignatureMismatch P.ModuleName Text Text Text + -- Fields: module name, declaration title, expected kind signature (text), + -- actual kind signature (text), actual kind signature (structure) + | KindSignatureMismatch P.ModuleName Text Text Text (P.Type ()) + -- | A kind signature was found where none was expected. + -- Fields: module name, declaration title, actual kind signature (text), + -- actual kind signature (structure) + | KindSignaturePresent P.ModuleName Text Text (P.Type ()) -- | The doc comments for the kind signature and type declaration were -- not properly merged into the expected one. -- Fields: module name, declaration title, expected doc-comments, @@ -289,10 +297,15 @@ displayAssertionFailure = \case "expected to see " <> before' <> " before " <> after' KindSignatureMissing _ decl -> "the kind signature for " <> decl <> " is missing." - KindSignatureMismatch _ decl expected actual -> + KindSignatureMismatch _ decl expected actualTxt actualKind -> "expected the kind signature for " <> decl <> "\n" <> "to be `" <> expected <> "`\n" <> - " got `" <> actual <> "`" + " got `" <> actualTxt <> "`\n" <> + "Structure of kind: " <> T.pack (show actualKind) + KindSignaturePresent _ decl actualTxt actualKind -> + "the kind signature for " <> decl <> "was not empty.\n" <> + "got `" <> actualTxt <> "`\n" <> + "Structure of kind: " <> T.pack (show actualKind) DocCommentMergeFailure _ decl expected actual -> "Expected the doc-comment for " <> decl <> " to merge comments and be `" <> expected <> "`; got `" <> actual <> "`" @@ -471,13 +484,22 @@ runAssertion assertion linksCtx Docs.Module{..} = findDeclKinds mn decl $ \case Just Docs.KindInfo{..} -> if expected /= actual - then Fail (KindSignatureMismatch mn decl expected actual) + then Fail (KindSignatureMismatch mn decl expected actual kiKind) else Pass where actual = codeToString $ Docs.renderKindSig decl $ Docs.KindInfo kiKeyword kiKind Nothing -> Fail (KindSignatureMissing mn decl) + ShouldNotHaveKindSignature mn decl -> + findDeclKinds mn decl $ \case + Just Docs.KindInfo{..} -> + Fail (KindSignaturePresent mn decl actual kiKind) + where + actual = codeToString $ Docs.renderKindSig decl $ + Docs.KindInfo kiKeyword kiKind + Nothing -> Pass + ShouldMergeDocComments mn decl expected -> findDecl mn decl $ \Docs.Declaration{..} -> if expected == declComments @@ -740,6 +762,32 @@ testCases = , ShouldHaveKindSignature (n "KindSignatureDocs") "NTypeOnly" "newtype NTypeOnly :: forall k. k -> Type" , ShouldHaveKindSignature (n "KindSignatureDocs") "CTypeOnly" "class CTypeOnly :: forall k. (k -> Type) -> k -> Constraint" + -- Declarations with no explicit kind signatures should still have + -- their inferred kind signatures displayed as long as at least one + -- type parameter does not have kind `Type`. + , ShouldHaveKindSignature (n "KindSignatureDocs") "DImplicit" "data DImplicit :: forall k. k -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "TImplicit" "type TImplicit :: forall k. k -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "NImplicit" "newtype NImplicit :: forall k. k -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "CImplicit" "class CImplicit :: forall k1. (k1 -> Type) -> k1 -> Constraint" + + -- Declarations with no explicit kind signatures should not be displayed + -- if each type parameter in their inferred kind signature + -- has kind `Type`. + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DHidden" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DNothing" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "THidden" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "NHidden" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "CHidden" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "CNothing" + + -- Declarations with no explicit kind signatures should be displayed + -- if at least one type parameter has a kind other than `Type` + -- despite all others having kind `Type`. + , ShouldHaveKindSignature (n "KindSignatureDocs") "DShown" "data DShown :: Type -> Type -> (Type -> Type) -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "TShown" "type TShown :: (Type -> Type) -> Type -> Type -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "NShown" "newtype NShown :: Type -> (Type -> Type) -> Type -> Type" + , ShouldHaveKindSignature (n "KindSignatureDocs") "CShown" "class CShown :: (Type -> Type) -> Type -> Type -> Constraint" + -- expected docs , ShouldMergeDocComments (n "KindSignatureDocs") "DKindAndType" $ Just "dkatk\n\ndkatt\n" , ShouldMergeDocComments (n "KindSignatureDocs") "TKindAndType" $ Just "tkatk\n\ntkatt\n" @@ -755,6 +803,11 @@ testCases = , ShouldMergeDocComments (n "KindSignatureDocs") "TTypeOnly" $ Just "ttot\n" , ShouldMergeDocComments (n "KindSignatureDocs") "NTypeOnly" $ Just "ntot\n" , ShouldMergeDocComments (n "KindSignatureDocs") "CTypeOnly" $ Just "ctot\n" + + , ShouldMergeDocComments (n "KindSignatureDocs") "DImplicit" $ Just "dit\n" + , ShouldMergeDocComments (n "KindSignatureDocs") "TImplicit" $ Just "tit\n" + , ShouldMergeDocComments (n "KindSignatureDocs") "NImplicit" $ Just "nit\n" + , ShouldMergeDocComments (n "KindSignatureDocs") "CImplicit" $ Just "cit\n" ] ) ] diff --git a/tests/purs/docs/src/KindSignatureDocs.purs b/tests/purs/docs/src/KindSignatureDocs.purs index d7e693e47a..0c76f7de5b 100644 --- a/tests/purs/docs/src/KindSignatureDocs.purs +++ b/tests/purs/docs/src/KindSignatureDocs.purs @@ -58,3 +58,52 @@ class CTypeOnly :: forall k. (k -> Type) -> k -> Constraint -- | ctot class CTypeOnly a k where fooTypeOnly :: a k -> String + +---------- + +-- | dit +data DImplicit a = DImplicit + +-- | tit +type TImplicit a = Int + +-- | nit +newtype NImplicit a = NImplicit Int + +-- | cit +class CImplicit a k where + fooImplicit :: a k -> String + +---------- + +-- | dit +data DHidden a b c = DHidden a b c + +data DNothing + +-- | tit +type THidden a b c = DHidden b c a + +-- | nit +newtype NHidden a b c = NHidden (DHidden a c b) + +-- | cit +class CHidden a b c where + fooHidden :: a -> b -> c -> String + +class CNothing + +---------- + +-- | dit +data DShown a b f = DShown (f Int) a b + +-- | tit +type TShown f b c = DShown b c f + +-- | nit +newtype NShown a f c = NShown (DShown a c f) + +-- | cit +class CShown f a b where + fooShown :: f Int -> a -> b -> String From 4e0eac6757709b462aeecc3992b2c8bb2acbb771 Mon Sep 17 00:00:00 2001 From: Varik Valefor <38414004+varikvalefor@users.noreply.github.com> Date: Mon, 28 Jun 2021 16:58:58 -0400 Subject: [PATCH 1363/1580] RELEASE_GUIDE.md: s/Or alternatively/Alternatively/ (#4123) "Or alternatively" is redundant. --- RELEASE_GUIDE.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md index c44fca0901..bec12e8d0d 100644 --- a/RELEASE_GUIDE.md +++ b/RELEASE_GUIDE.md @@ -43,7 +43,7 @@ projects whom we should probably at least notify. See below subsections: ### Libraries -Are there breaking changes to the language? Or alternatively, are there +Are there breaking changes to the language? Alternatively, are there language changes which require breaking changes in the relevant libraries to make use of? If so: From f1953214775945b65ba53ae903b4238c352dcd29 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 28 Jun 2021 17:03:01 -0400 Subject: [PATCH 1364/1580] Improve apartness checking (#4064) Instances in an instance chain that don't match the constraint being searched must be proven apart from the constraint for the search to continue to the next instance in the chain. This commit tweaks the apartness checker to fix a variety of incorrect apartness judgments, and also adds a hint to the NoInstanceFound error message if ambiguous instances (neither matching nor apart) excluded additional instances in a chain from consideration. --- CHANGELOG.md | 2 + src/Language/PureScript/Errors.hs | 21 +++++--- .../PureScript/TypeChecker/Entailment.hs | 53 ++++++++++++------- .../TypeChecker/Entailment/Coercible.hs | 2 +- tests/purs/failing/3329.out | 28 ++++++++++ tests/purs/failing/3329.purs | 24 +++++++++ tests/purs/failing/3531-2.out | 27 ++++++++++ tests/purs/failing/3531-2.purs | 23 ++++++++ tests/purs/failing/3531-3.out | 32 +++++++++++ tests/purs/failing/3531-3.purs | 23 ++++++++ tests/purs/failing/3531-4.out | 33 ++++++++++++ tests/purs/failing/3531-4.purs | 21 ++++++++ tests/purs/failing/3531-5.out | 32 +++++++++++ tests/purs/failing/3531-5.purs | 16 ++++++ tests/purs/failing/3531-6.out | 33 ++++++++++++ tests/purs/failing/3531-6.purs | 21 ++++++++ tests/purs/failing/3531.out | 27 ++++++++++ tests/purs/failing/3531.purs | 16 ++++++ tests/purs/failing/4028.out | 27 ++++++++++ tests/purs/failing/4028.purs | 29 ++++++++++ .../InstanceChainBothUnknownAndMatch.out | 4 ++ .../InstanceChainSkolemUnknownMatch.out | 4 ++ tests/purs/passing/3329.purs | 34 ++++++++++++ tests/purs/passing/3941.purs | 25 +++++++++ 24 files changed, 530 insertions(+), 27 deletions(-) create mode 100644 tests/purs/failing/3329.out create mode 100644 tests/purs/failing/3329.purs create mode 100644 tests/purs/failing/3531-2.out create mode 100644 tests/purs/failing/3531-2.purs create mode 100644 tests/purs/failing/3531-3.out create mode 100644 tests/purs/failing/3531-3.purs create mode 100644 tests/purs/failing/3531-4.out create mode 100644 tests/purs/failing/3531-4.purs create mode 100644 tests/purs/failing/3531-5.out create mode 100644 tests/purs/failing/3531-5.purs create mode 100644 tests/purs/failing/3531-6.out create mode 100644 tests/purs/failing/3531-6.purs create mode 100644 tests/purs/failing/3531.out create mode 100644 tests/purs/failing/3531.purs create mode 100644 tests/purs/failing/4028.out create mode 100644 tests/purs/failing/4028.purs create mode 100644 tests/purs/passing/3329.purs create mode 100644 tests/purs/passing/3941.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index 8895f0796c..2123b42e0f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -35,6 +35,8 @@ Bugfixes: * Remove generated names from errors about instances (#4118 by @rhendric) +* Improve apartness checking (#4064, @rhendric) + Internal: * Fix for Haddock (#4072 by @ncaq and @JordanMartinez) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 9029417740..cc8c8ce1e5 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -103,6 +103,7 @@ data SimpleErrorMessage | OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified (Either SourceType Ident)] | NoInstanceFound SourceConstraint -- ^ constraint that could not be solved + [Qualified (Either SourceType Ident)] -- ^ a list of instances that stopped further progress in instance chains due to ambiguity Bool -- ^ whether eliminating unknowns with annotations might help | AmbiguousTypeVariables SourceType [Int] | UnknownClass (Qualified (ProperName 'ClassName)) @@ -451,7 +452,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t - gSimple (NoInstanceFound con unks) = NoInstanceFound <$> overConstraintArgs (traverse f) con <*> pure unks + gSimple (NoInstanceFound con ambig unks) = NoInstanceFound <$> overConstraintArgs (traverse f) con <*> pure ambig <*> pure unks gSimple (AmbiguousTypeVariables t us) = AmbiguousTypeVariables <$> f t <*> pure us gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> traverse (traverse $ bitraverse f pure) insts gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts @@ -859,14 +860,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , markCodeBox $ indent $ line (showQualified runProperName nm) , line "because the class was not in scope. Perhaps it was not exported." ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Fail _ [ ty ] _) _) | Just box <- toTypelevelString ty = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Fail _ [ ty ] _) _ _) | Just box <- toTypelevelString ty = paras [ line "A custom type error occurred while solving type class constraints:" , indent box ] renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Partial _ _ - (Just (PartialConstraintData bs b))) _) = + (Just (PartialConstraintData bs b))) _ _) = paras [ line "A case expression could not be determined to cover all inputs." , line "The following additional cases are required to cover all inputs:" , indent $ paras $ @@ -875,18 +876,26 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl : [line "..." | not b] , line "Alternatively, add a Partial constraint to the type of the enclosing value." ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Discard _ [ty] _) _) = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Discard _ [ty] _) _ _) = paras [ line "A result of type" , markCodeBox $ indent $ prettyType ty , line "was implicitly discarded in a do notation block." , line ("You can use " <> markCode "_ <- ..." <> " to explicitly discard the result.") ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ nm _ ts _) unks) = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ nm _ ts _) ambiguous unks) = paras [ line "No type class instance was found for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map prettyTypeAtom ts) ] + , paras $ let useMessage msg = + [ line msg + , indent $ paras (map prettyInstanceName ambiguous) + ] + in case ambiguous of + [] -> [] + [_] -> useMessage "The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered:" + _ -> useMessage "The following instances partially overlap the above constraint, which means the rest of their instance chains will not be considered:" , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation." | unks ] @@ -1630,7 +1639,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl where isUnifyHint ErrorUnifyingTypes{} = True isUnifyHint _ = False - stripRedundantHints (NoInstanceFound (Constraint _ C.Coercible _ args _) _) = filter (not . isSolverHint) + stripRedundantHints (NoInstanceFound (Constraint _ C.Coercible _ args _) _ _) = filter (not . isSolverHint) where isSolverHint (ErrorSolvingConstraint (Constraint _ C.Coercible _ args' _)) = args == args' isSolverHint _ = False diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index eb338a018c..067c5eb408 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -18,11 +18,12 @@ import Control.Monad.State import Control.Monad.Supply.Class (MonadSupply(..)) import Control.Monad.Writer +import Data.Either (lefts, partitionEithers) import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.Functor (($>)) -import Data.List (findIndices, minimumBy, groupBy, nubBy, sortOn) -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.List (findIndices, minimumBy, groupBy, nubBy, sortOn, tails) +import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S import Data.Traversable (for) @@ -229,22 +230,23 @@ entails SolverOptions{..} constraint context hints = dicts <- lift . lift $ forClassNameM env (combineContexts context inferred) className' kinds'' tys'' - let instances = do + let (catMaybes -> ambiguous, instances) = partitionEithers $ do chain <- groupBy ((==) `on` tcdChain) $ sortOn (tcdChain &&& tcdIndex) dicts -- process instances in a chain in index order - let found = for chain $ \tcd -> + let found = for (init $ tails chain) $ \(tcd:tl) -> -- Make sure the type unifies with the type in the type instance definition case matches typeClassDependencies tcd tys'' of - Apart -> Right () -- keep searching - Match substs -> Left (Just (substs, tcd)) -- found a match - Unknown -> Left Nothing -- can't continue with this chain yet, need proof of apartness - case found of - Right _ -> [] -- all apart - Left Nothing -> [] -- last unknown - Left (Just substsTcd) -> [substsTcd] -- found a match - solution <- lift . lift $ unique kinds'' tys'' instances (unknownsInAllCoveringSets tys'' typeClassCoveringSets) + Apart -> Right () -- keep searching + Match substs -> Left (Right (substs, tcd)) -- found a match + Unknown -> + if null (tcdChain tcd) || null tl + then Right () -- need proof of apartness but this is either not in a chain or at the end + else Left (Left (tcdToInstanceDescription tcd)) -- can't continue with this chain yet, need proof of apartness + + lefts [found] + solution <- lift . lift $ unique kinds'' tys'' ambiguous instances (unknownsInAllCoveringSets tys'' typeClassCoveringSets) case solution of Solved substs tcd -> do -- Note that we solved something. @@ -322,16 +324,16 @@ entails SolverOptions{..} constraint context hints = (substituteType currentSubst . replaceAllTypeVars (M.toList subst) $ instKind) (substituteType currentSubst tyKind) - unique :: [SourceType] -> [SourceType] -> [(a, TypeClassDict)] -> Bool -> m (EntailsResult a) - unique kindArgs tyArgs [] unks + unique :: [SourceType] -> [SourceType] -> [Qualified (Either SourceType Ident)] -> [(a, TypeClassDict)] -> Bool -> m (EntailsResult a) + unique kindArgs tyArgs ambiguous [] unks | solverDeferErrors = return Deferred -- We need a special case for nullary type classes, since we want -- to generalize over Partial constraints. | solverShouldGeneralize && ((null kindArgs && null tyArgs) || any canBeGeneralized kindArgs || any canBeGeneralized tyArgs) = return (Unsolved (srcConstraint className' kindArgs tyArgs conInfo)) - | otherwise = throwError . errorMessage $ NoInstanceFound (srcConstraint className' kindArgs tyArgs conInfo) unks - unique _ _ [(a, dict)] _ = return $ Solved a dict - unique _ tyArgs tcds _ + | otherwise = throwError . errorMessage $ NoInstanceFound (srcConstraint className' kindArgs tyArgs conInfo) ambiguous unks + unique _ _ _ [(a, dict)] _ = return $ Solved a dict + unique _ tyArgs _ tcds _ | pairwiseAny overlapping (map snd tcds) = throwError . errorMessage $ OverlappingInstances className' tyArgs (tcds >>= (toList . tcdToInstanceDescription . snd)) | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds) @@ -638,6 +640,7 @@ matches deps TypeClassDictionaryInScope{..} tys = go (sd, r) ([], TypeVar _ v) = (Match (), M.singleton v [rowFromList (sd, r)]) go _ _ = (Apart, M.empty) typeHeadsAreEqual (TUnknown _ _) _ = (Unknown, M.empty) + typeHeadsAreEqual Skolem{} _ = (Unknown, M.empty) typeHeadsAreEqual _ _ = (Apart, M.empty) both :: (Matched (), Matching [Type a]) -> (Matched (), Matching [Type a]) -> (Matched (), Matching [Type a]) @@ -655,9 +658,11 @@ matches deps TypeClassDictionaryInScope{..} tys = typesAreEqual (KindedType _ t1 _) t2 = typesAreEqual t1 t2 typesAreEqual t1 (KindedType _ t2 _) = typesAreEqual t1 t2 typesAreEqual (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = Match () - typesAreEqual (Skolem _ _ _ s1 _) (Skolem _ _ _ s2 _) | s1 == s2 = Match () - typesAreEqual (Skolem _ _ _ _ _) _ = Unknown - typesAreEqual _ (Skolem _ _ _ _ _) = Unknown + typesAreEqual (TUnknown _ u1) t2 = if t2 `containsUnknown` u1 then Apart else Unknown + typesAreEqual t1 (TUnknown _ u2) = if t1 `containsUnknown` u2 then Apart else Unknown + typesAreEqual (Skolem _ _ _ s1 _) (Skolem _ _ _ s2 _) | s1 == s2 = Match () + typesAreEqual (Skolem _ _ _ s1 _) t2 = if t2 `containsSkolem` s1 then Apart else Unknown + typesAreEqual t1 (Skolem _ _ _ s2 _) = if t1 `containsSkolem` s2 then Apart else Unknown typesAreEqual (TypeVar _ v1) (TypeVar _ v2) | v1 == v2 = Match () typesAreEqual (TypeLevelString _ s1) (TypeLevelString _ s2) | s1 == s2 = Match () typesAreEqual (TypeConstructor _ c1) (TypeConstructor _ c2) | c1 == c2 = Match () @@ -673,6 +678,8 @@ matches deps TypeClassDictionaryInScope{..} tys = go (l, t1) (r, KindedType _ t2 _) = go (l, t1) (r, t2) go ([], KindApp _ t1 k1) ([], KindApp _ t2 k2) = typesAreEqual t1 t2 <> typesAreEqual k1 k2 go ([], TUnknown _ u1) ([], TUnknown _ u2) | u1 == u2 = Match () + go ([], TUnknown _ _) ([], _) = Unknown + go ([], _) ([], TUnknown _ _) = Unknown go ([], Skolem _ _ _ s1 _) ([], Skolem _ _ _ s2 _) | s1 == s2 = Match () go ([], Skolem _ _ _ _ _) _ = Unknown go _ ([], Skolem _ _ _ _ _) = Unknown @@ -685,6 +692,12 @@ matches deps TypeClassDictionaryInScope{..} tys = isRCons RCons{} = True isRCons _ = False + containsSkolem :: Type a -> Int -> Bool + containsSkolem t s = everythingOnTypes (||) (\case Skolem _ _ _ s' _ -> s == s'; _ -> False) t + + containsUnknown :: Type a -> Int -> Bool + containsUnknown t u = everythingOnTypes (||) (\case TUnknown _ u' -> u == u'; _ -> False) t + -- | Add a dictionary for the constraint to the scope, and dictionaries -- for all implied superclass instances. newDictionaries diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 1eed5d6c50..bb16e25b62 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -527,7 +527,7 @@ insoluble -> SourceType -> MultipleErrors insoluble k a b = - errorMessage $ NoInstanceFound (srcConstraint Prim.Coercible [k] [a, b] Nothing) (any containsUnknowns [a, b]) + errorMessage $ NoInstanceFound (srcConstraint Prim.Coercible [k] [a, b] Nothing) [] (any containsUnknowns [a, b]) -- | Constraints of the form @Coercible a b@ can be solved if the two arguments -- are the same. Since we currently don't support higher-rank arguments in diff --git a/tests/purs/failing/3329.out b/tests/purs/failing/3329.out new file mode 100644 index 0000000000..ce9bbe6c77 --- /dev/null +++ b/tests/purs/failing/3329.out @@ -0,0 +1,28 @@ +Error found: +in module Main +at tests/purs/failing/3329.purs:24:8 - 24:11 (line 24, column 8 - line 24, column 11) + + No type class instance was found for +   +  Main.Inject g0  +  (Either f1 g0) +   + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + Main.injectLeft + + +while checking that type forall (f :: Type) (g :: Type). Inject f g => f -> g + is at least as general as type g0 -> Either f1 g0 +while checking that expression inj + has type g0 -> Either f1 g0 +in value declaration injR + +where f1 is a rigid type variable + bound at (line 24, column 8 - line 24, column 11) + g0 is a rigid type variable + bound at (line 24, column 8 - line 24, column 11) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3329.purs b/tests/purs/failing/3329.purs new file mode 100644 index 0000000000..7beb876929 --- /dev/null +++ b/tests/purs/failing/3329.purs @@ -0,0 +1,24 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Data.Either (Either(..)) +import Data.Maybe (Maybe(..)) + +class Inject f g where + inj :: f -> g + prj :: g -> Maybe f + +instance injectRefl :: Inject x x where + inj x = x + prj x = Just x +else instance injectLeft :: Inject l (Either l r) where + inj x = Left x + prj (Left x) = Just x + prj _ = Nothing +else instance injectRight :: Inject x r => Inject x (Either l r) where + inj x = Right (inj x) + prj (Right x) = prj x + prj _ = Nothing + +injR :: forall f g. g -> Either f g +injR = inj diff --git a/tests/purs/failing/3531-2.out b/tests/purs/failing/3531-2.out new file mode 100644 index 0000000000..dcb39d4592 --- /dev/null +++ b/tests/purs/failing/3531-2.out @@ -0,0 +1,27 @@ +Error found: +in module Main +at tests/purs/failing/3531-2.purs:22:11 - 22:22 (line 22, column 11 - line 22, column 22) + + No type class instance was found for +   +  Main.C (X t2 Int) +   + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + Main.cx + + The instance head contains unknown type variables. Consider adding a type annotation. + +while applying a function thing + of type C t0 => t0 -> t0 + to argument test1 +while inferring the type of thing test1 +in value declaration test2 + +where t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3531-2.purs b/tests/purs/failing/3531-2.purs new file mode 100644 index 0000000000..ed20e5f1cc --- /dev/null +++ b/tests/purs/failing/3531-2.purs @@ -0,0 +1,23 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Prim.TypeError (class Fail, Text) + +class C x where + thing :: x -> x + +data X a b = X + +test1 :: forall a. X a Int +test1 = X + +instance cx :: C (X x x) where + thing x = x + +else instance cxFail :: Fail (Text "Fell through") => C (X x y) where + thing x = x + +test2 :: Boolean +test2 = do + let X = thing test1 + true diff --git a/tests/purs/failing/3531-3.out b/tests/purs/failing/3531-3.out new file mode 100644 index 0000000000..8f52a662cc --- /dev/null +++ b/tests/purs/failing/3531-3.out @@ -0,0 +1,32 @@ +Error found: +in module Main +at tests/purs/failing/3531-3.purs:22:11 - 22:22 (line 22, column 11 - line 22, column 22) + + No type class instance was found for +   +  Main.C (X  +  { foo :: Int +  | t1  +  }  +  { foo :: Int +  }  +  )  +   + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + Main.cx + + The instance head contains unknown type variables. Consider adding a type annotation. + +while applying a function thing + of type C t0 => t0 -> t0 + to argument test1 +while inferring the type of thing test1 +in value declaration test2 + +where t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3531-3.purs b/tests/purs/failing/3531-3.purs new file mode 100644 index 0000000000..5d3704101c --- /dev/null +++ b/tests/purs/failing/3531-3.purs @@ -0,0 +1,23 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Prim.TypeError (class Fail, Text) + +class C x where + thing :: x -> x + +data X a b = X + +test1 :: forall r. X { foo :: Int | r } { foo :: Int } +test1 = X + +instance cx :: C (X x x) where + thing x = x + +else instance cxFail :: Fail (Text "Fell through") => C (X x y) where + thing x = x + +test2 :: Boolean +test2 = do + let X = thing test1 + true diff --git a/tests/purs/failing/3531-4.out b/tests/purs/failing/3531-4.out new file mode 100644 index 0000000000..04b5b756d5 --- /dev/null +++ b/tests/purs/failing/3531-4.out @@ -0,0 +1,33 @@ +Error found: +in module Main +at tests/purs/failing/3531-4.purs:21:7 - 21:27 (line 21, column 7 - line 21, column 27) + + No type class instance was found for +   +  Main.C a4 +  b5 +   + The following instances partially overlap the above constraint, which means the rest of their instance chains will not be considered: + + Main.c1 + Main.c3 + + +while applying a function c + of type C @t0 @t1 t2 t3 => Proxy @t0 t2 -> Proxy @t1 t3 -> Boolean + to argument Proxy +while inferring the type of c Proxy +in value declaration fn + +where a4 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + b5 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + t3 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3531-4.purs b/tests/purs/failing/3531-4.purs new file mode 100644 index 0000000000..46c73fd52e --- /dev/null +++ b/tests/purs/failing/3531-4.purs @@ -0,0 +1,21 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +data Proxy a = Proxy + +class C a b where + c :: Proxy a -> Proxy b -> Boolean + +instance c1 :: C String String where + c _ _ = true +else instance c2 :: C String a where + c _ _ = false + +instance c3 :: C Int Int where + c _ _ = true +else instance c4 :: C Int a where + c _ _ = false + +fn :: forall a b. Proxy a -> Proxy b -> Int +fn _ _ = 42 where + x = c (Proxy :: Proxy a) (Proxy :: Proxy b) diff --git a/tests/purs/failing/3531-5.out b/tests/purs/failing/3531-5.out new file mode 100644 index 0000000000..f82fb0d6a1 --- /dev/null +++ b/tests/purs/failing/3531-5.out @@ -0,0 +1,32 @@ +Error found: +in module Main +at tests/purs/failing/3531-5.purs:16:7 - 16:27 (line 16, column 7 - line 16, column 27) + + No type class instance was found for +   +  Main.C a4 +  b5 +   + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + instance in module Main with type forall a. C String (Array a) (line 9, column 1 - line 10, column 15) + + +while applying a function c + of type C @t0 @t1 t2 t3 => Proxy @t0 t2 -> Proxy @t1 t3 -> Boolean + to argument Proxy +while inferring the type of c Proxy +in value declaration fn + +where a4 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + b5 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + t3 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3531-5.purs b/tests/purs/failing/3531-5.purs new file mode 100644 index 0000000000..5c19ed374e --- /dev/null +++ b/tests/purs/failing/3531-5.purs @@ -0,0 +1,16 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +data Proxy a = Proxy + +class C a b where + c :: Proxy a -> Proxy b -> Boolean + +instance C String (Array a) where + c _ _ = true +else instance c2 :: C String a where + c _ _ = false + +fn :: forall a b. Proxy a -> Proxy b -> Int +fn _ _ = 42 where + x = c (Proxy :: Proxy a) (Proxy :: Proxy b) diff --git a/tests/purs/failing/3531-6.out b/tests/purs/failing/3531-6.out new file mode 100644 index 0000000000..f454d0679e --- /dev/null +++ b/tests/purs/failing/3531-6.out @@ -0,0 +1,33 @@ +Error found: +in module Main +at tests/purs/failing/3531-6.purs:21:7 - 21:27 (line 21, column 7 - line 21, column 27) + + No type class instance was found for +   +  Main.C a4 +  b5 +   + The following instances partially overlap the above constraint, which means the rest of their instance chains will not be considered: + + instance in module Main with type forall a. C String (Array a) (line 9, column 1 - line 10, column 15) + instance in module Main with type C Int Int (line 14, column 1 - line 15, column 15) + + +while applying a function c + of type C @t0 @t1 t2 t3 => Proxy @t0 t2 -> Proxy @t1 t3 -> Boolean + to argument Proxy +while inferring the type of c Proxy +in value declaration fn + +where a4 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + b5 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + t3 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3531-6.purs b/tests/purs/failing/3531-6.purs new file mode 100644 index 0000000000..204ef158a1 --- /dev/null +++ b/tests/purs/failing/3531-6.purs @@ -0,0 +1,21 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +data Proxy a = Proxy + +class C a b where + c :: Proxy a -> Proxy b -> Boolean + +instance C String (Array a) where + c _ _ = true +else instance c2 :: C String a where + c _ _ = false + +instance C Int Int where + c _ _ = true +else instance c4 :: C Int a where + c _ _ = false + +fn :: forall a b. Proxy a -> Proxy b -> Int +fn _ _ = 42 where + x = c (Proxy :: Proxy a) (Proxy :: Proxy b) diff --git a/tests/purs/failing/3531.out b/tests/purs/failing/3531.out new file mode 100644 index 0000000000..71e3f55972 --- /dev/null +++ b/tests/purs/failing/3531.out @@ -0,0 +1,27 @@ +Error found: +in module Main +at tests/purs/failing/3531.purs:16:7 - 16:27 (line 16, column 7 - line 16, column 27) + + No type class instance was found for +   +  Main.C a2 +   + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + Main.c1 + + +while applying a function c + of type C @t0 t1 => Proxy @t0 t1 -> Boolean + to argument Proxy +while inferring the type of c Proxy +in value declaration fn + +where a2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3531.purs b/tests/purs/failing/3531.purs new file mode 100644 index 0000000000..b7d28a2c96 --- /dev/null +++ b/tests/purs/failing/3531.purs @@ -0,0 +1,16 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +data Proxy a = Proxy + +class C a where + c :: Proxy a -> Boolean + +instance c1 :: C String where + c _ = true +else instance c2 :: C a where + c _ = false + +fn :: forall a. Proxy a -> Int +fn _ = 42 where + x = c (Proxy :: Proxy a) diff --git a/tests/purs/failing/4028.out b/tests/purs/failing/4028.out new file mode 100644 index 0000000000..477c18364a --- /dev/null +++ b/tests/purs/failing/4028.out @@ -0,0 +1,27 @@ +Error found: +in module Main +at tests/purs/failing/4028.purs:29:12 - 29:37 (line 29, column 12 - line 29, column 37) + + No type class instance was found for +   +  Main.TLShow (S i2) +   + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + Main.tlShow2 + + +while applying a function go + of type TLShow @t0 t1 => Proxy @t0 t1 -> Int -> String + to argument Proxy +while inferring the type of go Proxy +in value declaration peano + +where i2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4028.purs b/tests/purs/failing/4028.purs new file mode 100644 index 0000000000..590d85d42b --- /dev/null +++ b/tests/purs/failing/4028.purs @@ -0,0 +1,29 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Prelude + +import Type.Proxy (Proxy(..)) + +foreign import data Peano :: Type + +foreign import data Z :: Peano +foreign import data S :: Peano -> Peano + +class TLShow :: forall k. k -> Constraint +class TLShow i where + tlShow :: Proxy i -> String + +instance tlShow2 :: TLShow (S (S Z)) where + tlShow _ = "2" +else instance tlShow0 :: TLShow Z where + tlShow _ = "0" +else instance tlShowS :: TLShow x => TLShow (S x) where + tlShow _ = "S" <> tlShow (Proxy :: Proxy x) + +peano :: Int -> String +peano = go (Proxy :: Proxy Z) + where + go :: forall i. TLShow i => Proxy i -> Int -> String + go p 0 = tlShow p + go _ n = go (Proxy :: Proxy (S i)) (n - 1) diff --git a/tests/purs/failing/InstanceChainBothUnknownAndMatch.out b/tests/purs/failing/InstanceChainBothUnknownAndMatch.out index 153cfa51a9..f08c540f40 100644 --- a/tests/purs/failing/InstanceChainBothUnknownAndMatch.out +++ b/tests/purs/failing/InstanceChainBothUnknownAndMatch.out @@ -16,6 +16,10 @@ at tests/purs/failing/InstanceChainBothUnknownAndMatch.purs:17:13 - 17:55 (line  )   t4    + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + InstanceChains.BothUnknownAndMatch.sameY + while applying a function same of type Same @Type @Type t0 t1 t2 => t0 -> t1 -> SProxy t2 diff --git a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out index 7bb44148c0..fa66f419ef 100644 --- a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out +++ b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out @@ -8,6 +8,10 @@ at tests/purs/failing/InstanceChainSkolemUnknownMatch.purs:14:13 - 14:36 (line 1  (Proxy Int)  t4    + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + InstanceChainSkolemUnknownMatch.sameY + while applying a function same of type Same @Type @Type t0 t1 t2 => t0 -> t1 -> SProxy t2 diff --git a/tests/purs/passing/3329.purs b/tests/purs/passing/3329.purs new file mode 100644 index 0000000000..5d531182d5 --- /dev/null +++ b/tests/purs/passing/3329.purs @@ -0,0 +1,34 @@ +module Main where + +import Prelude + +import Data.Either (Either(..)) +import Data.Maybe (Maybe(..)) +import Effect (Effect) +import Effect.Console (log) + +class Inject f g where + inj :: f -> g + prj :: g -> Maybe f + +instance injectRefl :: Inject x x where + inj x = x + prj x = Just x +else instance injectLeft :: Inject l (Either l r) where + inj x = Left x + prj (Left x) = Just x + prj _ = Nothing +else instance injectRight :: Inject x r => Inject x (Either l r) where + inj x = Right (inj x) + prj (Right x) = prj x + prj _ = Nothing + +injL :: forall f g. f -> Either f g +injL = inj + +main :: Effect Unit +main = log "Done" + where + testInjLWithUnknowns a = case inj a of + Left a' -> a' + Right _ -> a diff --git a/tests/purs/passing/3941.purs b/tests/purs/passing/3941.purs new file mode 100644 index 0000000000..321ccedacb --- /dev/null +++ b/tests/purs/passing/3941.purs @@ -0,0 +1,25 @@ +module Main where + +import Effect.Console (log) +import Unsafe.Coerce (unsafeCoerce) + +class TwoParams a b where + func :: a -> b + +instance equals :: TwoParams a a where + func a = a +else +instance any :: TwoParams a b where + func = unsafeCoerce + +testEquals :: forall a. a -> a +testEquals = func -- with instance `equals` +testAny :: Int -> Boolean +testAny = func -- with instance `any` + +-- `a` and `m a` are never unifiable unless we have infinite types (and of course not) +-- so expected that the instance `any` is chosen. +thisShouldBeCompiled :: forall m a. a -> m a +thisShouldBeCompiled = func + +main = log "Done" From 6b05869d3822e6c6d2a7ff03b94bf84144046211 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 1 Jul 2021 21:31:47 -0400 Subject: [PATCH 1365/1580] Revert "Improve apartness checking (#4064)" (#4129) This reverts commit f1953214775945b65ba53ae903b4238c352dcd29. --- CHANGELOG.md | 2 - src/Language/PureScript/Errors.hs | 21 +++----- .../PureScript/TypeChecker/Entailment.hs | 53 +++++++------------ .../TypeChecker/Entailment/Coercible.hs | 2 +- tests/purs/failing/3329.out | 28 ---------- tests/purs/failing/3329.purs | 24 --------- tests/purs/failing/3531-2.out | 27 ---------- tests/purs/failing/3531-2.purs | 23 -------- tests/purs/failing/3531-3.out | 32 ----------- tests/purs/failing/3531-3.purs | 23 -------- tests/purs/failing/3531-4.out | 33 ------------ tests/purs/failing/3531-4.purs | 21 -------- tests/purs/failing/3531-5.out | 32 ----------- tests/purs/failing/3531-5.purs | 16 ------ tests/purs/failing/3531-6.out | 33 ------------ tests/purs/failing/3531-6.purs | 21 -------- tests/purs/failing/3531.out | 27 ---------- tests/purs/failing/3531.purs | 16 ------ tests/purs/failing/4028.out | 27 ---------- tests/purs/failing/4028.purs | 29 ---------- .../InstanceChainBothUnknownAndMatch.out | 4 -- .../InstanceChainSkolemUnknownMatch.out | 4 -- tests/purs/passing/3329.purs | 34 ------------ tests/purs/passing/3941.purs | 25 --------- 24 files changed, 27 insertions(+), 530 deletions(-) delete mode 100644 tests/purs/failing/3329.out delete mode 100644 tests/purs/failing/3329.purs delete mode 100644 tests/purs/failing/3531-2.out delete mode 100644 tests/purs/failing/3531-2.purs delete mode 100644 tests/purs/failing/3531-3.out delete mode 100644 tests/purs/failing/3531-3.purs delete mode 100644 tests/purs/failing/3531-4.out delete mode 100644 tests/purs/failing/3531-4.purs delete mode 100644 tests/purs/failing/3531-5.out delete mode 100644 tests/purs/failing/3531-5.purs delete mode 100644 tests/purs/failing/3531-6.out delete mode 100644 tests/purs/failing/3531-6.purs delete mode 100644 tests/purs/failing/3531.out delete mode 100644 tests/purs/failing/3531.purs delete mode 100644 tests/purs/failing/4028.out delete mode 100644 tests/purs/failing/4028.purs delete mode 100644 tests/purs/passing/3329.purs delete mode 100644 tests/purs/passing/3941.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index 2123b42e0f..8895f0796c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -35,8 +35,6 @@ Bugfixes: * Remove generated names from errors about instances (#4118 by @rhendric) -* Improve apartness checking (#4064, @rhendric) - Internal: * Fix for Haddock (#4072 by @ncaq and @JordanMartinez) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index cc8c8ce1e5..9029417740 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -103,7 +103,6 @@ data SimpleErrorMessage | OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified (Either SourceType Ident)] | NoInstanceFound SourceConstraint -- ^ constraint that could not be solved - [Qualified (Either SourceType Ident)] -- ^ a list of instances that stopped further progress in instance chains due to ambiguity Bool -- ^ whether eliminating unknowns with annotations might help | AmbiguousTypeVariables SourceType [Int] | UnknownClass (Qualified (ProperName 'ClassName)) @@ -452,7 +451,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t - gSimple (NoInstanceFound con ambig unks) = NoInstanceFound <$> overConstraintArgs (traverse f) con <*> pure ambig <*> pure unks + gSimple (NoInstanceFound con unks) = NoInstanceFound <$> overConstraintArgs (traverse f) con <*> pure unks gSimple (AmbiguousTypeVariables t us) = AmbiguousTypeVariables <$> f t <*> pure us gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> traverse (traverse $ bitraverse f pure) insts gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts @@ -860,14 +859,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , markCodeBox $ indent $ line (showQualified runProperName nm) , line "because the class was not in scope. Perhaps it was not exported." ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Fail _ [ ty ] _) _ _) | Just box <- toTypelevelString ty = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Fail _ [ ty ] _) _) | Just box <- toTypelevelString ty = paras [ line "A custom type error occurred while solving type class constraints:" , indent box ] renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Partial _ _ - (Just (PartialConstraintData bs b))) _ _) = + (Just (PartialConstraintData bs b))) _) = paras [ line "A case expression could not be determined to cover all inputs." , line "The following additional cases are required to cover all inputs:" , indent $ paras $ @@ -876,26 +875,18 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl : [line "..." | not b] , line "Alternatively, add a Partial constraint to the type of the enclosing value." ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Discard _ [ty] _) _ _) = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Discard _ [ty] _) _) = paras [ line "A result of type" , markCodeBox $ indent $ prettyType ty , line "was implicitly discarded in a do notation block." , line ("You can use " <> markCode "_ <- ..." <> " to explicitly discard the result.") ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ nm _ ts _) ambiguous unks) = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ nm _ ts _) unks) = paras [ line "No type class instance was found for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map prettyTypeAtom ts) ] - , paras $ let useMessage msg = - [ line msg - , indent $ paras (map prettyInstanceName ambiguous) - ] - in case ambiguous of - [] -> [] - [_] -> useMessage "The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered:" - _ -> useMessage "The following instances partially overlap the above constraint, which means the rest of their instance chains will not be considered:" , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation." | unks ] @@ -1639,7 +1630,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl where isUnifyHint ErrorUnifyingTypes{} = True isUnifyHint _ = False - stripRedundantHints (NoInstanceFound (Constraint _ C.Coercible _ args _) _ _) = filter (not . isSolverHint) + stripRedundantHints (NoInstanceFound (Constraint _ C.Coercible _ args _) _) = filter (not . isSolverHint) where isSolverHint (ErrorSolvingConstraint (Constraint _ C.Coercible _ args' _)) = args == args' isSolverHint _ = False diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 067c5eb408..eb338a018c 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -18,12 +18,11 @@ import Control.Monad.State import Control.Monad.Supply.Class (MonadSupply(..)) import Control.Monad.Writer -import Data.Either (lefts, partitionEithers) import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.Functor (($>)) -import Data.List (findIndices, minimumBy, groupBy, nubBy, sortOn, tails) -import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) +import Data.List (findIndices, minimumBy, groupBy, nubBy, sortOn) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S import Data.Traversable (for) @@ -230,23 +229,22 @@ entails SolverOptions{..} constraint context hints = dicts <- lift . lift $ forClassNameM env (combineContexts context inferred) className' kinds'' tys'' - let (catMaybes -> ambiguous, instances) = partitionEithers $ do + let instances = do chain <- groupBy ((==) `on` tcdChain) $ sortOn (tcdChain &&& tcdIndex) dicts -- process instances in a chain in index order - let found = for (init $ tails chain) $ \(tcd:tl) -> + let found = for chain $ \tcd -> -- Make sure the type unifies with the type in the type instance definition case matches typeClassDependencies tcd tys'' of - Apart -> Right () -- keep searching - Match substs -> Left (Right (substs, tcd)) -- found a match - Unknown -> - if null (tcdChain tcd) || null tl - then Right () -- need proof of apartness but this is either not in a chain or at the end - else Left (Left (tcdToInstanceDescription tcd)) -- can't continue with this chain yet, need proof of apartness - - lefts [found] - solution <- lift . lift $ unique kinds'' tys'' ambiguous instances (unknownsInAllCoveringSets tys'' typeClassCoveringSets) + Apart -> Right () -- keep searching + Match substs -> Left (Just (substs, tcd)) -- found a match + Unknown -> Left Nothing -- can't continue with this chain yet, need proof of apartness + case found of + Right _ -> [] -- all apart + Left Nothing -> [] -- last unknown + Left (Just substsTcd) -> [substsTcd] -- found a match + solution <- lift . lift $ unique kinds'' tys'' instances (unknownsInAllCoveringSets tys'' typeClassCoveringSets) case solution of Solved substs tcd -> do -- Note that we solved something. @@ -324,16 +322,16 @@ entails SolverOptions{..} constraint context hints = (substituteType currentSubst . replaceAllTypeVars (M.toList subst) $ instKind) (substituteType currentSubst tyKind) - unique :: [SourceType] -> [SourceType] -> [Qualified (Either SourceType Ident)] -> [(a, TypeClassDict)] -> Bool -> m (EntailsResult a) - unique kindArgs tyArgs ambiguous [] unks + unique :: [SourceType] -> [SourceType] -> [(a, TypeClassDict)] -> Bool -> m (EntailsResult a) + unique kindArgs tyArgs [] unks | solverDeferErrors = return Deferred -- We need a special case for nullary type classes, since we want -- to generalize over Partial constraints. | solverShouldGeneralize && ((null kindArgs && null tyArgs) || any canBeGeneralized kindArgs || any canBeGeneralized tyArgs) = return (Unsolved (srcConstraint className' kindArgs tyArgs conInfo)) - | otherwise = throwError . errorMessage $ NoInstanceFound (srcConstraint className' kindArgs tyArgs conInfo) ambiguous unks - unique _ _ _ [(a, dict)] _ = return $ Solved a dict - unique _ tyArgs _ tcds _ + | otherwise = throwError . errorMessage $ NoInstanceFound (srcConstraint className' kindArgs tyArgs conInfo) unks + unique _ _ [(a, dict)] _ = return $ Solved a dict + unique _ tyArgs tcds _ | pairwiseAny overlapping (map snd tcds) = throwError . errorMessage $ OverlappingInstances className' tyArgs (tcds >>= (toList . tcdToInstanceDescription . snd)) | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds) @@ -640,7 +638,6 @@ matches deps TypeClassDictionaryInScope{..} tys = go (sd, r) ([], TypeVar _ v) = (Match (), M.singleton v [rowFromList (sd, r)]) go _ _ = (Apart, M.empty) typeHeadsAreEqual (TUnknown _ _) _ = (Unknown, M.empty) - typeHeadsAreEqual Skolem{} _ = (Unknown, M.empty) typeHeadsAreEqual _ _ = (Apart, M.empty) both :: (Matched (), Matching [Type a]) -> (Matched (), Matching [Type a]) -> (Matched (), Matching [Type a]) @@ -658,11 +655,9 @@ matches deps TypeClassDictionaryInScope{..} tys = typesAreEqual (KindedType _ t1 _) t2 = typesAreEqual t1 t2 typesAreEqual t1 (KindedType _ t2 _) = typesAreEqual t1 t2 typesAreEqual (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = Match () - typesAreEqual (TUnknown _ u1) t2 = if t2 `containsUnknown` u1 then Apart else Unknown - typesAreEqual t1 (TUnknown _ u2) = if t1 `containsUnknown` u2 then Apart else Unknown - typesAreEqual (Skolem _ _ _ s1 _) (Skolem _ _ _ s2 _) | s1 == s2 = Match () - typesAreEqual (Skolem _ _ _ s1 _) t2 = if t2 `containsSkolem` s1 then Apart else Unknown - typesAreEqual t1 (Skolem _ _ _ s2 _) = if t1 `containsSkolem` s2 then Apart else Unknown + typesAreEqual (Skolem _ _ _ s1 _) (Skolem _ _ _ s2 _) | s1 == s2 = Match () + typesAreEqual (Skolem _ _ _ _ _) _ = Unknown + typesAreEqual _ (Skolem _ _ _ _ _) = Unknown typesAreEqual (TypeVar _ v1) (TypeVar _ v2) | v1 == v2 = Match () typesAreEqual (TypeLevelString _ s1) (TypeLevelString _ s2) | s1 == s2 = Match () typesAreEqual (TypeConstructor _ c1) (TypeConstructor _ c2) | c1 == c2 = Match () @@ -678,8 +673,6 @@ matches deps TypeClassDictionaryInScope{..} tys = go (l, t1) (r, KindedType _ t2 _) = go (l, t1) (r, t2) go ([], KindApp _ t1 k1) ([], KindApp _ t2 k2) = typesAreEqual t1 t2 <> typesAreEqual k1 k2 go ([], TUnknown _ u1) ([], TUnknown _ u2) | u1 == u2 = Match () - go ([], TUnknown _ _) ([], _) = Unknown - go ([], _) ([], TUnknown _ _) = Unknown go ([], Skolem _ _ _ s1 _) ([], Skolem _ _ _ s2 _) | s1 == s2 = Match () go ([], Skolem _ _ _ _ _) _ = Unknown go _ ([], Skolem _ _ _ _ _) = Unknown @@ -692,12 +685,6 @@ matches deps TypeClassDictionaryInScope{..} tys = isRCons RCons{} = True isRCons _ = False - containsSkolem :: Type a -> Int -> Bool - containsSkolem t s = everythingOnTypes (||) (\case Skolem _ _ _ s' _ -> s == s'; _ -> False) t - - containsUnknown :: Type a -> Int -> Bool - containsUnknown t u = everythingOnTypes (||) (\case TUnknown _ u' -> u == u'; _ -> False) t - -- | Add a dictionary for the constraint to the scope, and dictionaries -- for all implied superclass instances. newDictionaries diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index bb16e25b62..1eed5d6c50 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -527,7 +527,7 @@ insoluble -> SourceType -> MultipleErrors insoluble k a b = - errorMessage $ NoInstanceFound (srcConstraint Prim.Coercible [k] [a, b] Nothing) [] (any containsUnknowns [a, b]) + errorMessage $ NoInstanceFound (srcConstraint Prim.Coercible [k] [a, b] Nothing) (any containsUnknowns [a, b]) -- | Constraints of the form @Coercible a b@ can be solved if the two arguments -- are the same. Since we currently don't support higher-rank arguments in diff --git a/tests/purs/failing/3329.out b/tests/purs/failing/3329.out deleted file mode 100644 index ce9bbe6c77..0000000000 --- a/tests/purs/failing/3329.out +++ /dev/null @@ -1,28 +0,0 @@ -Error found: -in module Main -at tests/purs/failing/3329.purs:24:8 - 24:11 (line 24, column 8 - line 24, column 11) - - No type class instance was found for -   -  Main.Inject g0  -  (Either f1 g0) -   - The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: - - Main.injectLeft - - -while checking that type forall (f :: Type) (g :: Type). Inject f g => f -> g - is at least as general as type g0 -> Either f1 g0 -while checking that expression inj - has type g0 -> Either f1 g0 -in value declaration injR - -where f1 is a rigid type variable - bound at (line 24, column 8 - line 24, column 11) - g0 is a rigid type variable - bound at (line 24, column 8 - line 24, column 11) - -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/3329.purs b/tests/purs/failing/3329.purs deleted file mode 100644 index 7beb876929..0000000000 --- a/tests/purs/failing/3329.purs +++ /dev/null @@ -1,24 +0,0 @@ --- @shouldFailWith NoInstanceFound -module Main where - -import Data.Either (Either(..)) -import Data.Maybe (Maybe(..)) - -class Inject f g where - inj :: f -> g - prj :: g -> Maybe f - -instance injectRefl :: Inject x x where - inj x = x - prj x = Just x -else instance injectLeft :: Inject l (Either l r) where - inj x = Left x - prj (Left x) = Just x - prj _ = Nothing -else instance injectRight :: Inject x r => Inject x (Either l r) where - inj x = Right (inj x) - prj (Right x) = prj x - prj _ = Nothing - -injR :: forall f g. g -> Either f g -injR = inj diff --git a/tests/purs/failing/3531-2.out b/tests/purs/failing/3531-2.out deleted file mode 100644 index dcb39d4592..0000000000 --- a/tests/purs/failing/3531-2.out +++ /dev/null @@ -1,27 +0,0 @@ -Error found: -in module Main -at tests/purs/failing/3531-2.purs:22:11 - 22:22 (line 22, column 11 - line 22, column 22) - - No type class instance was found for -   -  Main.C (X t2 Int) -   - The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: - - Main.cx - - The instance head contains unknown type variables. Consider adding a type annotation. - -while applying a function thing - of type C t0 => t0 -> t0 - to argument test1 -while inferring the type of thing test1 -in value declaration test2 - -where t0 is an unknown type - t1 is an unknown type - t2 is an unknown type - -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/3531-2.purs b/tests/purs/failing/3531-2.purs deleted file mode 100644 index ed20e5f1cc..0000000000 --- a/tests/purs/failing/3531-2.purs +++ /dev/null @@ -1,23 +0,0 @@ --- @shouldFailWith NoInstanceFound -module Main where - -import Prim.TypeError (class Fail, Text) - -class C x where - thing :: x -> x - -data X a b = X - -test1 :: forall a. X a Int -test1 = X - -instance cx :: C (X x x) where - thing x = x - -else instance cxFail :: Fail (Text "Fell through") => C (X x y) where - thing x = x - -test2 :: Boolean -test2 = do - let X = thing test1 - true diff --git a/tests/purs/failing/3531-3.out b/tests/purs/failing/3531-3.out deleted file mode 100644 index 8f52a662cc..0000000000 --- a/tests/purs/failing/3531-3.out +++ /dev/null @@ -1,32 +0,0 @@ -Error found: -in module Main -at tests/purs/failing/3531-3.purs:22:11 - 22:22 (line 22, column 11 - line 22, column 22) - - No type class instance was found for -   -  Main.C (X  -  { foo :: Int -  | t1  -  }  -  { foo :: Int -  }  -  )  -   - The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: - - Main.cx - - The instance head contains unknown type variables. Consider adding a type annotation. - -while applying a function thing - of type C t0 => t0 -> t0 - to argument test1 -while inferring the type of thing test1 -in value declaration test2 - -where t0 is an unknown type - t1 is an unknown type - -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/3531-3.purs b/tests/purs/failing/3531-3.purs deleted file mode 100644 index 5d3704101c..0000000000 --- a/tests/purs/failing/3531-3.purs +++ /dev/null @@ -1,23 +0,0 @@ --- @shouldFailWith NoInstanceFound -module Main where - -import Prim.TypeError (class Fail, Text) - -class C x where - thing :: x -> x - -data X a b = X - -test1 :: forall r. X { foo :: Int | r } { foo :: Int } -test1 = X - -instance cx :: C (X x x) where - thing x = x - -else instance cxFail :: Fail (Text "Fell through") => C (X x y) where - thing x = x - -test2 :: Boolean -test2 = do - let X = thing test1 - true diff --git a/tests/purs/failing/3531-4.out b/tests/purs/failing/3531-4.out deleted file mode 100644 index 04b5b756d5..0000000000 --- a/tests/purs/failing/3531-4.out +++ /dev/null @@ -1,33 +0,0 @@ -Error found: -in module Main -at tests/purs/failing/3531-4.purs:21:7 - 21:27 (line 21, column 7 - line 21, column 27) - - No type class instance was found for -   -  Main.C a4 -  b5 -   - The following instances partially overlap the above constraint, which means the rest of their instance chains will not be considered: - - Main.c1 - Main.c3 - - -while applying a function c - of type C @t0 @t1 t2 t3 => Proxy @t0 t2 -> Proxy @t1 t3 -> Boolean - to argument Proxy -while inferring the type of c Proxy -in value declaration fn - -where a4 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - b5 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - t0 is an unknown type - t1 is an unknown type - t2 is an unknown type - t3 is an unknown type - -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/3531-4.purs b/tests/purs/failing/3531-4.purs deleted file mode 100644 index 46c73fd52e..0000000000 --- a/tests/purs/failing/3531-4.purs +++ /dev/null @@ -1,21 +0,0 @@ --- @shouldFailWith NoInstanceFound -module Main where - -data Proxy a = Proxy - -class C a b where - c :: Proxy a -> Proxy b -> Boolean - -instance c1 :: C String String where - c _ _ = true -else instance c2 :: C String a where - c _ _ = false - -instance c3 :: C Int Int where - c _ _ = true -else instance c4 :: C Int a where - c _ _ = false - -fn :: forall a b. Proxy a -> Proxy b -> Int -fn _ _ = 42 where - x = c (Proxy :: Proxy a) (Proxy :: Proxy b) diff --git a/tests/purs/failing/3531-5.out b/tests/purs/failing/3531-5.out deleted file mode 100644 index f82fb0d6a1..0000000000 --- a/tests/purs/failing/3531-5.out +++ /dev/null @@ -1,32 +0,0 @@ -Error found: -in module Main -at tests/purs/failing/3531-5.purs:16:7 - 16:27 (line 16, column 7 - line 16, column 27) - - No type class instance was found for -   -  Main.C a4 -  b5 -   - The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: - - instance in module Main with type forall a. C String (Array a) (line 9, column 1 - line 10, column 15) - - -while applying a function c - of type C @t0 @t1 t2 t3 => Proxy @t0 t2 -> Proxy @t1 t3 -> Boolean - to argument Proxy -while inferring the type of c Proxy -in value declaration fn - -where a4 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - b5 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - t0 is an unknown type - t1 is an unknown type - t2 is an unknown type - t3 is an unknown type - -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/3531-5.purs b/tests/purs/failing/3531-5.purs deleted file mode 100644 index 5c19ed374e..0000000000 --- a/tests/purs/failing/3531-5.purs +++ /dev/null @@ -1,16 +0,0 @@ --- @shouldFailWith NoInstanceFound -module Main where - -data Proxy a = Proxy - -class C a b where - c :: Proxy a -> Proxy b -> Boolean - -instance C String (Array a) where - c _ _ = true -else instance c2 :: C String a where - c _ _ = false - -fn :: forall a b. Proxy a -> Proxy b -> Int -fn _ _ = 42 where - x = c (Proxy :: Proxy a) (Proxy :: Proxy b) diff --git a/tests/purs/failing/3531-6.out b/tests/purs/failing/3531-6.out deleted file mode 100644 index f454d0679e..0000000000 --- a/tests/purs/failing/3531-6.out +++ /dev/null @@ -1,33 +0,0 @@ -Error found: -in module Main -at tests/purs/failing/3531-6.purs:21:7 - 21:27 (line 21, column 7 - line 21, column 27) - - No type class instance was found for -   -  Main.C a4 -  b5 -   - The following instances partially overlap the above constraint, which means the rest of their instance chains will not be considered: - - instance in module Main with type forall a. C String (Array a) (line 9, column 1 - line 10, column 15) - instance in module Main with type C Int Int (line 14, column 1 - line 15, column 15) - - -while applying a function c - of type C @t0 @t1 t2 t3 => Proxy @t0 t2 -> Proxy @t1 t3 -> Boolean - to argument Proxy -while inferring the type of c Proxy -in value declaration fn - -where a4 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - b5 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - t0 is an unknown type - t1 is an unknown type - t2 is an unknown type - t3 is an unknown type - -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/3531-6.purs b/tests/purs/failing/3531-6.purs deleted file mode 100644 index 204ef158a1..0000000000 --- a/tests/purs/failing/3531-6.purs +++ /dev/null @@ -1,21 +0,0 @@ --- @shouldFailWith NoInstanceFound -module Main where - -data Proxy a = Proxy - -class C a b where - c :: Proxy a -> Proxy b -> Boolean - -instance C String (Array a) where - c _ _ = true -else instance c2 :: C String a where - c _ _ = false - -instance C Int Int where - c _ _ = true -else instance c4 :: C Int a where - c _ _ = false - -fn :: forall a b. Proxy a -> Proxy b -> Int -fn _ _ = 42 where - x = c (Proxy :: Proxy a) (Proxy :: Proxy b) diff --git a/tests/purs/failing/3531.out b/tests/purs/failing/3531.out deleted file mode 100644 index 71e3f55972..0000000000 --- a/tests/purs/failing/3531.out +++ /dev/null @@ -1,27 +0,0 @@ -Error found: -in module Main -at tests/purs/failing/3531.purs:16:7 - 16:27 (line 16, column 7 - line 16, column 27) - - No type class instance was found for -   -  Main.C a2 -   - The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: - - Main.c1 - - -while applying a function c - of type C @t0 t1 => Proxy @t0 t1 -> Boolean - to argument Proxy -while inferring the type of c Proxy -in value declaration fn - -where a2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - t0 is an unknown type - t1 is an unknown type - -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/3531.purs b/tests/purs/failing/3531.purs deleted file mode 100644 index b7d28a2c96..0000000000 --- a/tests/purs/failing/3531.purs +++ /dev/null @@ -1,16 +0,0 @@ --- @shouldFailWith NoInstanceFound -module Main where - -data Proxy a = Proxy - -class C a where - c :: Proxy a -> Boolean - -instance c1 :: C String where - c _ = true -else instance c2 :: C a where - c _ = false - -fn :: forall a. Proxy a -> Int -fn _ = 42 where - x = c (Proxy :: Proxy a) diff --git a/tests/purs/failing/4028.out b/tests/purs/failing/4028.out deleted file mode 100644 index 477c18364a..0000000000 --- a/tests/purs/failing/4028.out +++ /dev/null @@ -1,27 +0,0 @@ -Error found: -in module Main -at tests/purs/failing/4028.purs:29:12 - 29:37 (line 29, column 12 - line 29, column 37) - - No type class instance was found for -   -  Main.TLShow (S i2) -   - The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: - - Main.tlShow2 - - -while applying a function go - of type TLShow @t0 t1 => Proxy @t0 t1 -> Int -> String - to argument Proxy -while inferring the type of go Proxy -in value declaration peano - -where i2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - t0 is an unknown type - t1 is an unknown type - -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/4028.purs b/tests/purs/failing/4028.purs deleted file mode 100644 index 590d85d42b..0000000000 --- a/tests/purs/failing/4028.purs +++ /dev/null @@ -1,29 +0,0 @@ --- @shouldFailWith NoInstanceFound -module Main where - -import Prelude - -import Type.Proxy (Proxy(..)) - -foreign import data Peano :: Type - -foreign import data Z :: Peano -foreign import data S :: Peano -> Peano - -class TLShow :: forall k. k -> Constraint -class TLShow i where - tlShow :: Proxy i -> String - -instance tlShow2 :: TLShow (S (S Z)) where - tlShow _ = "2" -else instance tlShow0 :: TLShow Z where - tlShow _ = "0" -else instance tlShowS :: TLShow x => TLShow (S x) where - tlShow _ = "S" <> tlShow (Proxy :: Proxy x) - -peano :: Int -> String -peano = go (Proxy :: Proxy Z) - where - go :: forall i. TLShow i => Proxy i -> Int -> String - go p 0 = tlShow p - go _ n = go (Proxy :: Proxy (S i)) (n - 1) diff --git a/tests/purs/failing/InstanceChainBothUnknownAndMatch.out b/tests/purs/failing/InstanceChainBothUnknownAndMatch.out index f08c540f40..153cfa51a9 100644 --- a/tests/purs/failing/InstanceChainBothUnknownAndMatch.out +++ b/tests/purs/failing/InstanceChainBothUnknownAndMatch.out @@ -16,10 +16,6 @@ at tests/purs/failing/InstanceChainBothUnknownAndMatch.purs:17:13 - 17:55 (line  )   t4    - The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: - - InstanceChains.BothUnknownAndMatch.sameY - while applying a function same of type Same @Type @Type t0 t1 t2 => t0 -> t1 -> SProxy t2 diff --git a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out index fa66f419ef..7bb44148c0 100644 --- a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out +++ b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out @@ -8,10 +8,6 @@ at tests/purs/failing/InstanceChainSkolemUnknownMatch.purs:14:13 - 14:36 (line 1  (Proxy Int)  t4    - The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: - - InstanceChainSkolemUnknownMatch.sameY - while applying a function same of type Same @Type @Type t0 t1 t2 => t0 -> t1 -> SProxy t2 diff --git a/tests/purs/passing/3329.purs b/tests/purs/passing/3329.purs deleted file mode 100644 index 5d531182d5..0000000000 --- a/tests/purs/passing/3329.purs +++ /dev/null @@ -1,34 +0,0 @@ -module Main where - -import Prelude - -import Data.Either (Either(..)) -import Data.Maybe (Maybe(..)) -import Effect (Effect) -import Effect.Console (log) - -class Inject f g where - inj :: f -> g - prj :: g -> Maybe f - -instance injectRefl :: Inject x x where - inj x = x - prj x = Just x -else instance injectLeft :: Inject l (Either l r) where - inj x = Left x - prj (Left x) = Just x - prj _ = Nothing -else instance injectRight :: Inject x r => Inject x (Either l r) where - inj x = Right (inj x) - prj (Right x) = prj x - prj _ = Nothing - -injL :: forall f g. f -> Either f g -injL = inj - -main :: Effect Unit -main = log "Done" - where - testInjLWithUnknowns a = case inj a of - Left a' -> a' - Right _ -> a diff --git a/tests/purs/passing/3941.purs b/tests/purs/passing/3941.purs deleted file mode 100644 index 321ccedacb..0000000000 --- a/tests/purs/passing/3941.purs +++ /dev/null @@ -1,25 +0,0 @@ -module Main where - -import Effect.Console (log) -import Unsafe.Coerce (unsafeCoerce) - -class TwoParams a b where - func :: a -> b - -instance equals :: TwoParams a a where - func a = a -else -instance any :: TwoParams a b where - func = unsafeCoerce - -testEquals :: forall a. a -> a -testEquals = func -- with instance `equals` -testAny :: Int -> Boolean -testAny = func -- with instance `any` - --- `a` and `m a` are never unifiable unless we have infinite types (and of course not) --- so expected that the instance `any` is chosen. -thisShouldBeCompiled :: forall m a. a -> m a -thisShouldBeCompiled = func - -main = log "Done" From b4c90a8bb6a1059f271f4211687192370fda81bc Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 6 Jul 2021 13:05:20 -0700 Subject: [PATCH 1366/1580] Prepare for v0.14.3 release (#4128) * Update versions for upcoming v0.14.3 release * Finalize changelog for v0.14.3 * Update purescript-cst to v0.3.0.0 --- CHANGELOG.md | 8 ++++++++ lib/purescript-cst/README.md | 1 + lib/purescript-cst/purescript-cst.cabal | 2 +- npm-package/package.json | 4 ++-- purescript.cabal | 4 ++-- 5 files changed, 14 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8895f0796c..cf4fa206e3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,14 @@ Breaking changes: New features: +Bugfixes: + +Internal: + +## v0.14.3 + +New features: + * Display kind signatures and their comments in documentation (#4100 and #4119 by JordanMartinez) The compiler now displays kind signatures for data, newtype, type diff --git a/lib/purescript-cst/README.md b/lib/purescript-cst/README.md index ae69955b43..1775170d86 100644 --- a/lib/purescript-cst/README.md +++ b/lib/purescript-cst/README.md @@ -9,6 +9,7 @@ We provide a table to make it a bit easier to map between versions of `purescrip | `purescript` | `purescript-cst` | | --- | --- | | 0.14.2 | 0.2.0.0 | +| 0.14.3 | 0.3.0.0 | Before v0.14.2, there was a third package, `purescript-ast`. In v0.14.2, `purescript-ast` was merged into `purescript-cst`. diff --git a/lib/purescript-cst/purescript-cst.cabal b/lib/purescript-cst/purescript-cst.cabal index c09705aee5..e04a54afd5 100644 --- a/lib/purescript-cst/purescript-cst.cabal +++ b/lib/purescript-cst/purescript-cst.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: purescript-cst -version: 0.2.0.0 +version: 0.3.0.0 synopsis: PureScript Programming Language Concrete Syntax Tree description: The parser for the PureScript programming language. category: Language diff --git a/npm-package/package.json b/npm-package/package.json index 8a4be9ee47..ad519c778f 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.14.2", + "version": "0.14.3", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.14.2", + "postinstall": "install-purescript --purs-ver=0.14.3", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index ec4f0bc071..e3cb467064 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.14.2 +version: 0.14.3 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language @@ -159,7 +159,7 @@ common defaults pattern-arrows >=0.0.2 && <0.1, process >=1.6.9.0 && <1.7, protolude >=0.3.0 && <0.4, - purescript-cst ==0.2.0.0, + purescript-cst ==0.3.0.0, regex-tdfa >=1.3.1.0 && <1.4, safe >=0.3.19 && <0.4, scientific >=0.3.6.2 && <0.4, From c1f9ccc6dc6771ed75cb45268c3eae89f1905f8c Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 6 Jul 2021 19:49:33 -0700 Subject: [PATCH 1367/1580] Refer to binary using local-doc-root workaround (#4139) * Refer to binary using local-doc-root workaround * Update changelog --- CHANGELOG.md | 2 +- bundle/build.sh | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index cf4fa206e3..cd1de49d76 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -45,7 +45,7 @@ Bugfixes: Internal: -* Fix for Haddock (#4072 by @ncaq and @JordanMartinez) +* Fix for Haddock (#4072 by @ncaq and @JordanMartinez, #4139 by @JordanMartinez) * Update RELEASE_GUIDE.md with more details (#4104 by @JordanMartinez) diff --git a/bundle/build.sh b/bundle/build.sh index 4402c6baa9..db37b52937 100755 --- a/bundle/build.sh +++ b/bundle/build.sh @@ -26,7 +26,7 @@ then else BIN="purs" fi -FULL_BIN="$(stack path --local-install-root)/bin/$BIN" +FULL_BIN="$(stack path --local-doc-root)/../bin/$BIN" if [ "$OS" != "win64" ] then strip "$FULL_BIN" From 564223175395963db2e9144d1034ad2e0be050d3 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 12 Jul 2021 13:52:26 -0400 Subject: [PATCH 1368/1580] Move unreleased changelog entries to CHANGELOG.d (#4132) --- .github/PULL_REQUEST_TEMPLATE.md | 2 +- CHANGELOG.d/README.md | 50 +++++++ CHANGELOG.d/internal_changelog-dir.md | 3 + CHANGELOG.md | 10 -- RELEASE_GUIDE.md | 3 + update-changelog.hs | 202 ++++++++++++++++++++++++++ 6 files changed, 259 insertions(+), 11 deletions(-) create mode 100644 CHANGELOG.d/README.md create mode 100644 CHANGELOG.d/internal_changelog-dir.md create mode 100755 update-changelog.hs diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index 711103ccba..501ee01403 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -6,7 +6,7 @@ Clearly and concisely describe the purpose of the pull request. If this PR relat **Checklist:** -- [ ] Added the change to the changelog's "Unreleased" section with a reference to this PR (e.g. "- Made a change (#0000)") +- [ ] Added a file to CHANGELOG.d for this PR (see CHANGELOG.d/README.md) - [ ] Added myself to CONTRIBUTORS.md (if this is my first contribution) - [ ] Linked any existing issues or proposals that this pull request should close - [ ] Updated or added relevant documentation diff --git a/CHANGELOG.d/README.md b/CHANGELOG.d/README.md new file mode 100644 index 0000000000..2d9698909c --- /dev/null +++ b/CHANGELOG.d/README.md @@ -0,0 +1,50 @@ +This directory contains changelog entries for work that has not yet been +released. When a release goes out, these files will be concatenated and +prepended to CHANGELOG.md in a new section for that release. + +Maintainers: see update-changelog.hs for details of this process. + +Contributors: read on! + +When you are preparing a new PR, add a new file to this directory. The file +should be named `{PREFIX}_{SLUG}.md`, where `{PREFIX}` is one of the following: +* `breaking`: for breaking changes +* `feature`: for new features +* `fix`: for bug fixes +* `internal`: for work that will not directly affect users of PureScript +* `misc`: for anything else that needs to be logged + +`{SLUG}` should be a short description of the work you've done. The name has no +impact on the final CHANGELOG.md. + +Some example names: +* `fix_issue-9876.md` +* `breaking_deprecate-classes.md` +* `misc_add-forum-to-readme.md` + +The contents of the file can be as brief as: + +```markdown +* A short message, like the title of your commit +``` + +Please remember the initial `*`! These files will all be concatenated into +lists. + +If you have more to say about your work, indent additional lines like so: + +``````markdown +* A short message, like the title of your commit + + Here is a longer explanation of what this is all about. Of course, this file + is Markdown, so feel free to use *formatting* + + ``` + and code blocks + ``` + + if it makes your work more understandable. +`````` + +You do not have to edit your changelog file to include a reference to your PR. +The CHANGELOG.md updating script will do this automatically and credit you. diff --git a/CHANGELOG.d/internal_changelog-dir.md b/CHANGELOG.d/internal_changelog-dir.md new file mode 100644 index 0000000000..07d5deea04 --- /dev/null +++ b/CHANGELOG.d/internal_changelog-dir.md @@ -0,0 +1,3 @@ +* Move unreleased changelog entries to CHANGELOG.d + + See CHANGELOG.d/README.md for details. diff --git a/CHANGELOG.md b/CHANGELOG.md index cd1de49d76..61d81476db 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,16 +2,6 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). -## [Unreleased] - -Breaking changes: - -New features: - -Bugfixes: - -Internal: - ## v0.14.3 New features: diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md index bec12e8d0d..50e6ad8b1f 100644 --- a/RELEASE_GUIDE.md +++ b/RELEASE_GUIDE.md @@ -96,6 +96,9 @@ considering what effects this may have: - The version bounds for `purescript-cst` in `purescript.cabal` +- Run `stack update-changelog.hs`, which will move the entries in `CHANGELOG.d` + to a new section in `CHANGELOG.md` labeled with the new version. + - Create a release from the releases tab in GitHub and copy in the release notes. This will also create a tag, which will kick off a CI build, which will upload prebuilt compiler binaries to the release on GitHub when it diff --git a/update-changelog.hs b/update-changelog.hs new file mode 100755 index 0000000000..bb149ec903 --- /dev/null +++ b/update-changelog.hs @@ -0,0 +1,202 @@ +#!/usr/bin/env stack +-- stack --resolver lts-17.6 script +{-# LANGUAGE + DeriveFoldable + , DeriveFunctor + , DeriveTraversable + , FlexibleContexts + , LambdaCase + , NoImplicitPrelude + , OverloadedStrings + , PackageImports + , RecordWildCards + , TupleSections + , ViewPatterns +#-} +-- | +-- This script updates CHANGELOG.md with the contents of CHANGELOG.d, and +-- empties CHANGELOG.d. It takes care of: +-- +-- * Sorting entries by the order in which their PRs were merged +-- * Appending (#1234 by @author) to the first line of each fragment, +-- optionally adding multiple PR numbers and/or authors as applicable +-- * Grouping entries by type and adding non-empty group headings to the +-- changelog +-- * Syncing any affected files to the Git index, preparing for you to make +-- your release commit +-- +-- Be sure to run this *after* updating the version number in +-- npm-package/package.json, as that's where this script gets the new section +-- header from. +-- + +module Main (main) where + +import Protolude hiding (intercalate, readFile, writeFile) +import qualified Protolude + +import Control.Monad.Fail (fail) +import qualified Data.Aeson as JSON +import Data.Attoparsec.ByteString (maybeResult, parse) +import "bifunctors" + Data.Bifunctor.Flip (Flip(..)) +import qualified Data.ByteString as BS +import qualified Data.HashMap.Lazy as HM +import qualified Data.List.NonEmpty as NEL +import Data.String (String) +import qualified Data.String as String +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) +import Data.Time.Format.ISO8601 (iso8601ParseM) +import Data.Time.LocalTime (zonedTimeToUTC) +import GitHub.REST (GHEndpoint(..), GitHubState(..), KeyValue(..), MonadGitHubREST, StdMethod(..), queryGitHub, runGitHubT) +import qualified SimpleCmd.Git as IOGit +import System.Directory (setCurrentDirectory) +import System.FilePath (normalise, takeFileName, ()) + +main = runGitHubT gitHubState $ do + git "rev-parse" ["--show-toplevel"] >>= liftIO . setCurrentDirectory + entries <- String.lines <$> git "ls-tree" ["--name-only", "HEAD", "CHANGELOG.d/"] + + breaks <- processEntriesStartingWith "break" entries + features <- processEntriesStartingWith "feat" entries + fixes <- processEntriesStartingWith "fix" entries + internal <- processEntriesStartingWith "int" entries + misc <- processEntriesStartingWith "misc" entries + + let entryFiles = ceFile <$> breaks <> features <> fixes <> internal <> misc + unless (null entryFiles) $ do + + changes <- git "status" ("-s" : "--" : "CHANGELOG.md" : entryFiles) + unless (null changes) . liftIO . die $ + "You have uncommitted changes to changelog files. " <> + "Please commit, stash, or revert them before running this script." + + version <- getVersion + (changelogPreamble, changelogRest) <- T.breakOn "\n## " <$> readFile "CHANGELOG.md" + writeFile "CHANGELOG.md" $ + changelogPreamble + <> "\n## " <> version <> "\n" + <> conditionalSection "Breaking changes" breaks + <> conditionalSection "New features" features + <> conditionalSection "Bugfixes" fixes + <> conditionalSection "Other improvements" misc + <> conditionalSection "Internal" internal + <> changelogRest + + git_ "add" ["CHANGELOG.md"] + git_ "rm" $ "-q" : entryFiles + +gitHubState :: GitHubState +gitHubState = GitHubState Nothing "purescript/purescript update-changelog.hs" "v3" + +processEntriesStartingWith :: (MonadFail m, MonadGitHubREST m, MonadIO m) => String -> [String] -> m [ChangelogEntry] +processEntriesStartingWith prefix + = fmap (sortOn ceDate) + . traverse updateEntry + . filter ((prefix `isPrefixOf`) . map toLower . takeFileName) + +updateEntry :: (MonadFail m, MonadGitHubREST m, MonadIO m) => String -> m ChangelogEntry +updateEntry file = do + (header, body) <- T.breakOn "\n" . T.strip <$> (readFile . normalise) file + + allCommits <- + fmap (NEL.fromList . sortOn glcTime) + . traverse (\(T.breakOn " " -> (h, T.breakOn " " . T.tail -> (c, s))) -> + GitLogCommit (T.tail s) h . zonedTimeToUTC <$> iso8601ParseM (toS c)) + =<< gitLines "log" ["-m", "--follow", "--format=%H %cI %s", file] + + prCommits <- + filterM isInterestingCommit + . mapMaybe (traverse parsePRNumber) + $ NEL.toList allCommits + + let prNumbers = map (snd . glcData) prCommits + + prAuthors <- ordNub <$> traverse lookupPRAuthor prNumbers + + let headerSuffix = if null prNumbers then "" else + " (" + <> commaSeparate (map (("#" <>) . show) prNumbers) + <> " by " + <> commaSeparate (map ("@" <>) prAuthors) + <> ")" + + pure $ ChangelogEntry file (header <> headerSuffix <> body <> "\n") (glcTime $ NEL.head allCommits) + +parsePRNumber :: Text -> Maybe (CommitType, Int) +parsePRNumber = liftA2 (<|>) + (fmap (MergeCommit, ) . readMaybe . toS . fst . T.breakOn " " <=< T.stripPrefix "Merge pull request #") + (fmap (SquashCommit, ) . readMaybe . toS <=< T.stripSuffix ")" . snd . T.breakOnEnd "(#") + +-- | +-- This function helps us exclude PRs that are just fixups of changelog +-- wording. An interesting commit is one that has either edited a file that +-- isn't part of the changelog, or is a merge commit. +-- +isInterestingCommit :: MonadIO m => GitLogCommit (CommitType, Int) -> m Bool +isInterestingCommit GitLogCommit{..} = case fst glcData of + MergeCommit -> pure True + SquashCommit -> + not . all (\path -> "CHANGELOG.md" == path || "CHANGELOG.d/" `T.isPrefixOf` path) + <$> gitLines "show" ["--format=", "--name-only", toS glcHash] + +lookupPRAuthor :: (MonadFail m, MonadGitHubREST m) => Int -> m Text +lookupPRAuthor prNum = + queryGitHub GHEndpoint{ method = GET + , endpoint = "/repos/purescript/purescript/pulls/:pr" + , endpointVals = ["pr" := prNum] + , ghData = [] + } + >>= \case + JSON.Object (HM.lookup "user" -> Just (JSON.Object (HM.lookup "login" -> Just (JSON.String name)))) -> pure name + _ -> fail "error accessing GitHub API" + +commaSeparate :: [Text] -> Text +commaSeparate = \case + [] -> "" + [a] -> a + [a, b] -> a <> " and " <> b + more | Just (init, last) <- unsnoc more -> T.intercalate ", " init <> ", and " <> last + +getVersion :: (MonadFail m, MonadIO m) => m Text +getVersion = + (liftIO . BS.readFile) ("npm-package" "package.json") >>= \case + (maybeResult . parse JSON.json -> Just (JSON.Object (HM.lookup "version" -> Just (JSON.String v)))) -> pure v + _ -> fail "could not read version from npm-package/package.json" + +conditionalSection :: Text -> [ChangelogEntry] -> Text +conditionalSection header = \case + [] -> "" + entries -> + "\n" <> header <> ":\n\n" <> T.intercalate "\n" (map ceContent entries) + +git :: MonadIO m => String -> [String] -> m String +git cmd = liftIO . IOGit.git cmd + +git_ :: MonadIO m => String -> [String] -> m () +git_ cmd = liftIO . IOGit.git_ cmd + +gitLines :: MonadIO m => String -> [String] -> m [Text] +gitLines cmd args = lines . toS <$> git cmd args + +readFile :: MonadIO m => FilePath -> m Text +readFile = liftIO . Protolude.readFile + +writeFile :: MonadIO m => FilePath -> Text -> m () +writeFile path = liftIO . Protolude.writeFile path + +data ChangelogEntry = ChangelogEntry + { ceFile :: String + , ceContent :: Text + , ceDate :: UTCTime + } + +data GitLogCommit a = GitLogCommit + { glcData :: a + , glcHash :: Text + , glcTime :: UTCTime + } + deriving (Functor, Foldable, Traversable) + +data CommitType = MergeCommit | SquashCommit From a1081ae63e035183792a515c2e76da33f7800fcd Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Mon, 12 Jul 2021 21:24:31 -0700 Subject: [PATCH 1369/1580] Add note about what to do when a release fails (#4147) * Add note about what to do when a release fails * Add changelog entry --- CHANGELOG.d/internal_explain approach for broken releases.md | 1 + RELEASE_GUIDE.md | 4 ++++ 2 files changed, 5 insertions(+) create mode 100644 CHANGELOG.d/internal_explain approach for broken releases.md diff --git a/CHANGELOG.d/internal_explain approach for broken releases.md b/CHANGELOG.d/internal_explain approach for broken releases.md new file mode 100644 index 0000000000..e52c97e6aa --- /dev/null +++ b/CHANGELOG.d/internal_explain approach for broken releases.md @@ -0,0 +1 @@ +* Clarify in RELEASE_GUIDE what to do when broken releases are made diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md index 50e6ad8b1f..04477aa5b6 100644 --- a/RELEASE_GUIDE.md +++ b/RELEASE_GUIDE.md @@ -120,6 +120,10 @@ considering what effects this may have: It's a good idea to check that the package can be installed from npm at this point. +Note: if a release does not go as planned (e.g. [`v0.14.3`](https://github.com/purescript/purescript/pull/4139)), we should not delete the broken GitHub release or its Git tag. Rather, we should make a new release and update the GitHub release notes and the corresponding section in the CHANGELOG.md file for the broken release to +1. say that it's not a real release, and +1. refer people to the newer release. + ## After making a release - Document any language changes in the documentation repo From 216761668e40f0e82214991bee99bd9b41956beb Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Mon, 12 Jul 2021 21:27:21 -0700 Subject: [PATCH 1370/1580] Minor edits to RELEASE_GUIDE.md (#4131) * Add note to submit PR and get it merged before triggering CI build * Link to PVP directly * Add changelog entry --- .../internal_miscellaneous updates to release guide.md | 1 + RELEASE_GUIDE.md | 7 ++++--- 2 files changed, 5 insertions(+), 3 deletions(-) create mode 100644 CHANGELOG.d/internal_miscellaneous updates to release guide.md diff --git a/CHANGELOG.d/internal_miscellaneous updates to release guide.md b/CHANGELOG.d/internal_miscellaneous updates to release guide.md new file mode 100644 index 0000000000..e0dd6b9f88 --- /dev/null +++ b/CHANGELOG.d/internal_miscellaneous updates to release guide.md @@ -0,0 +1 @@ +* Miscellaneous updates/clarifications to the release guide diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md index 04477aa5b6..ec936831af 100644 --- a/RELEASE_GUIDE.md +++ b/RELEASE_GUIDE.md @@ -88,9 +88,8 @@ considering what effects this may have: - If `purescript-cst` has changed at all since the last release: - The `version` field in `lib/purescript-cst/purescript-cst.cabal` (note - that the new version should be based on the PVP, according to what - changed since the previous release, and not on the actual compiler - version) + that the new version should be based on the [PVP](https://pvp.haskell.org/), + according to what changed since the previous release, and not on the actual compiler version) - The versions table in `lib/purescript-cst/README.md`, @@ -99,6 +98,8 @@ considering what effects this may have: - Run `stack update-changelog.hs`, which will move the entries in `CHANGELOG.d` to a new section in `CHANGELOG.md` labeled with the new version. +- Submit a PR with the above commits and get it merged. + - Create a release from the releases tab in GitHub and copy in the release notes. This will also create a tag, which will kick off a CI build, which will upload prebuilt compiler binaries to the release on GitHub when it From c07f13714ead2014b55008d8227d41ee9b6efd8f Mon Sep 17 00:00:00 2001 From: milesfrain Date: Tue, 13 Jul 2021 07:14:17 -0700 Subject: [PATCH 1371/1580] Add developer guide (#3900) * Add developer guide * Add IDE guide link * Refine profile visualizer section Also removed note about old stack versions thrashing workspaces. * Review feedback - stack instructions * Review feedback - HLS link * Add changelog entry --- CHANGELOG.d/misc-dev-guide-3900.md | 1 + CONTRIBUTING.md | 110 ++++++++++++++++++++++++++++- 2 files changed, 109 insertions(+), 2 deletions(-) create mode 100644 CHANGELOG.d/misc-dev-guide-3900.md diff --git a/CHANGELOG.d/misc-dev-guide-3900.md b/CHANGELOG.d/misc-dev-guide-3900.md new file mode 100644 index 0000000000..b1b247cc43 --- /dev/null +++ b/CHANGELOG.d/misc-dev-guide-3900.md @@ -0,0 +1 @@ +* Add developer guide to readme \ No newline at end of file diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index de54bf0166..a3e588c556 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -51,5 +51,111 @@ This process can be performed automatically by running `make license-generator`. Sometimes pull requests take a little while to be merged. This is partially because they often have knock-on effects for the rest of the ecosystem, and partially because we want to give core team members time to review and consider changes thoroughly. Please see the organization's [governance document](https://github.com/purescript/governance) for information about when a pull request may be merged. -[the #purescript channel in FP Slack]: https://functionalprogramming.slack.com/ -[Discourse]: https://discourse.purescript.org/ +## Developer Guide + +The following instructions are intended to help PureScript users more easily contribute to the compiler, even if this is your first Haskell project. + +### Prerequisites + +Install `stack`. [Instructions](https://docs.haskellstack.org/en/stable/README/). + +Update stack's package index before proceeding: +``` +stack update +``` + +### Clone + +``` +git clone https://github.com/purescript/purescript.git purescript_compiler +cd purescript_compiler +``` + +### Build + +``` +stack build +``` + +This will take a while the first time it is run. + +### Running a locally-compiled version of PureScript + +Run `stack exec bash` to launch a subshell (substitute `bash` with your preferred shell) where your locally-compiled version of `purs` is available at the front of your `PATH`. Other tools (such as `spago`) will also grab this latest `purs` version if executed in this shell. You can use `purs --version` and `which purs` to confirm you're executing your locally-compiled version. + +``` +> purs --version +0.14.2 +> which purs +~/.nvm/versions/node/v14.9.0/bin/purs + +> stack exec bash + +> purs --version +0.14.2 [development build; commit: f1953214775945b65ba53ae903b4238c352dcd29 DIRTY] +> which purs +~/projects/purescript/complier/.stack-work/install/x86_64-linux-tinfo6/1a835accec0abb5a1f7364196133985d18f8c46ee8c7424ce43cf68bab56e5b1/8.10.4/bin/purs +``` + +If you plan on using your patched version of `purs` for a while (for example, while waiting on your changes to be incorporated into the next official release), it may be more convenient to install it globally with: + +``` +stack install +``` + +Note that other installed version (e.g. what npm installs) may still have priority depending on how your `PATH` is configured. `stack install` should warn about other higher-priority versions, and you can always use `which purs` as a sanity check. Uninstall by simply deleting the `purs` binary (location can be found with `which purs`). + +### Profiling + +A profiling build is used to help diagnose performance issues with the compiler. + +Create a profiling build with: +``` +stack build --profile +``` +This will also take a while the first time it is run. + +Setting-up a local shell for your profiling build is similar to the steps for the standard build, just add the `--profile` flag: +``` +stack exec --profile bash +``` +Note that the bin directory prepended to `$PATH` is different than the standard build, so you can let this be a third "profiling" shell that you leave open between rebuilds. + +The `purs` compiler is often wrapped by `spago`. Here's how to pass the "time profiling" flag `-p` via spago: +``` +spago build --purs-args "+RTS -p -RTS" +``` + +Note: There are other profiling flags (such as `-hc` for heap size). You can read more about these flags [here](http://book.realworldhaskell.org/read/profiling-and-optimization.html). + +This creates a `purs.prof` file. You can view the contents of this file directly, but it is often more convenient to use a visualizer. + +### Profile Visualizers + +Each of these produces a clickable visual display of profiling info. Feel free to open the output files in the web browser of your choice. These examples use `firefox`. + +#### [ghc-prof-flamegraph](https://github.com/fpco/ghc-prof-flamegraph) +``` +stack build --copy-compiler-tool ghc-prof-flamegraph +stack exec -- ghc-prof-flamegraph purs.prof +firefox purs.svg +``` + +For more flamegraph customizations, you can also try [`stackcollapse-ghc`](https://github.com/marcin-rzeznicki/stackcollapse-ghc) + +#### [profiteur](https://github.com/jaspervdj/profiteur) +``` +stack build --copy-compiler-tool profiteur +stack exec -- profiteur purs.prof +firefox purs.prof.html +``` + +### Additional Resources + +* [Haskell Language Server](https://github.com/haskell/haskell-language-server#installation) installation guide. + +* PureScript-compiler-focused [guide](https://discourse.purescript.org/t/haskell-tooling-guide-vscode-hie/1505) covering VSCode + HIE setup. + +* Beginner-friendly [guide](https://www.vacationlabs.com/haskell/environment-setup.html) covering VSCode + HIE setup, although the steps needed some tweaking for compatibility with the PureScript compiler project. + +* An [outdated table](https://github.com/rainbyte/haskell-ide-chart#the-chart-with-a-link-to-each-plug-in) of IDE recommendations. Note that the [`intero`](https://github.com/chrisdone/intero/blob/master/README.md) backend (listed for four entries) is no longer supported. From c5e7d0b1caa9ede96ca31bf60198ea038444d950 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Tue, 13 Jul 2021 19:05:54 -0400 Subject: [PATCH 1372/1580] Delete make_release_notes (#4151) --- make_release_notes | 2 -- 1 file changed, 2 deletions(-) delete mode 100755 make_release_notes diff --git a/make_release_notes b/make_release_notes deleted file mode 100755 index edf84a2d22..0000000000 --- a/make_release_notes +++ /dev/null @@ -1,2 +0,0 @@ -curl https://api.github.com/repos/purescript/purescript/pulls?state=closed\&per_page=100 \ - | jq -r '.[] | ("- " + .title + " (@" + .user.login + ")")' From 4a8e2b5d81207100804fd817e24a766ae5d690f1 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Tue, 13 Jul 2021 20:13:10 -0400 Subject: [PATCH 1373/1580] Run Weeder in CI and make it happy (#4148) Weeder runs a whole-program analysis and will fail the build if there are any functions not reachable from our list of roots, which includes the purs executable and a few API points used externally. This commit removes all such functions, and in a few cases removes primes from functions that had their un-primed counterparts thus removed. --- .github/workflows/ci.yml | 43 ++++++- CHANGELOG.d/internal_weeder.md | 1 + .../src/Control/Monad/Supply.hs | 10 -- .../Language/PureScript/AST/Declarations.hs | 10 -- .../src/Language/PureScript/CST/Monad.hs | 4 - .../src/Language/PureScript/CST/Positions.hs | 8 -- .../src/Language/PureScript/CST/Utils.hs | 15 --- .../src/Language/PureScript/Constants/Prim.hs | 12 -- .../src/Language/PureScript/Environment.hs | 25 ----- .../src/Language/PureScript/Names.hs | 4 - .../src/Language/PureScript/Traversals.hs | 7 -- .../src/Language/PureScript/Types.hs | 47 -------- src/Language/PureScript/Constants/Prelude.hs | 106 ------------------ src/Language/PureScript/CoreFn/Traversals.hs | 32 ------ .../PureScript/CoreImp/Optimizer/Common.hs | 8 -- src/Language/PureScript/Docs/AsHtml.hs | 4 - src/Language/PureScript/Docs/AsMarkdown.hs | 4 - .../PureScript/Docs/RenderedCode/Types.hs | 75 +------------ src/Language/PureScript/Docs/Types.hs | 28 +---- src/Language/PureScript/Errors.hs | 6 - src/Language/PureScript/Ide/SourceFile.hs | 17 +-- src/Language/PureScript/Ide/Types.hs | 1 - .../PureScript/Interactive/Directive.hs | 17 +-- src/Language/PureScript/Interactive/Module.hs | 11 +- src/Language/PureScript/Interactive/Types.hs | 5 - src/Language/PureScript/Make/BuildPlan.hs | 5 - src/Language/PureScript/Pretty/Common.hs | 18 --- src/Language/PureScript/Pretty/Types.hs | 4 - .../PureScript/Publish/BoxesHelpers.hs | 3 - .../PureScript/Publish/ErrorsWarnings.hs | 4 - .../PureScript/Sugar/BindingGroups.hs | 9 -- src/Language/PureScript/Sugar/Names/Env.hs | 25 ----- src/Language/PureScript/TypeChecker/Monad.hs | 15 +-- .../PureScript/TypeChecker/TypeSearch.hs | 2 +- .../Language/PureScript/Ide/CompletionSpec.hs | 5 - .../Language/PureScript/Ide/SourceFileSpec.hs | 6 +- tests/Language/PureScript/Ide/Test.hs | 7 -- tests/TestMake.hs | 4 +- weeder.dhall | 34 ++++++ 39 files changed, 90 insertions(+), 551 deletions(-) create mode 100644 CHANGELOG.d/internal_weeder.md create mode 100644 weeder.dhall diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 8b822b5c69..3bfa5070da 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -20,6 +20,7 @@ jobs: strategy: fail-fast: false # do not cancel builds for other OSes if one fails matrix: + # If upgrading Ubuntu, also upgrade it in the lint job below os: [ "ubuntu-18.04", "macOS-10.15", "windows-2016" ] runs-on: "${{ matrix.os }}" @@ -35,6 +36,7 @@ jobs: uses: "haskell/actions/setup@v1" with: enable-stack: true + # If upgrading Stack, also upgrade it in the lint job below stack-version: "2.5.1" stack-no-global: true @@ -53,10 +55,6 @@ jobs: mkdir -p "$STACK_ROOT" echo "local-programs-path: $STACK_ROOT/programs" > $STACK_ROOT/config.yaml - - run: "ci/run-hlint.sh --git" - env: - VERSION: "2.2.11" - - run: "ci/build.sh" - name: "(Release only) Create bundle" @@ -88,3 +86,40 @@ jobs: with: repo-token: "${{ secrets.GITHUB_TOKEN }}" files: "sdist-test/bundle/*.{tar.gz,sha}" + + lint: + runs-on: "ubuntu-18.04" + + steps: + - uses: "actions/checkout@v2" + + - id: "haskell" + uses: "haskell/actions/setup@v1" + with: + enable-stack: true + stack-version: "2.5.1" + stack-no-global: true + + - uses: "actions/cache@v2" + with: + path: | + ${{ steps.haskell.outputs.stack-root }} + key: "${{ runner.os }}-lint-${{ hashFiles('stack.yaml') }}" + + - run: "ci/run-hlint.sh --git" + env: + VERSION: "2.2.11" + + - run: "stack --no-terminal --jobs=2 build --copy-compiler-tool weeder" + + - run: "stack --no-terminal --jobs=2 build --fast --ghc-options -fwrite-ide-info" + + - run: "stack exec weeder" + + # Now do it again, with the test suite included. We don't want a + # reference from our test suite to count in the above check; the fact + # that a function is tested is not evidence that it's needed. But we also + # don't want to leave weeds lying around in our test suite either. + - run: "stack --no-terminal --jobs=2 build --fast --test --no-run-tests --ghc-options -fwrite-ide-info" + + - run: "stack exec weeder" diff --git a/CHANGELOG.d/internal_weeder.md b/CHANGELOG.d/internal_weeder.md new file mode 100644 index 0000000000..0cdd3c35ad --- /dev/null +++ b/CHANGELOG.d/internal_weeder.md @@ -0,0 +1 @@ +* Run Weeder in CI and make it happy diff --git a/lib/purescript-cst/src/Control/Monad/Supply.hs b/lib/purescript-cst/src/Control/Monad/Supply.hs index dd9e2f74a6..65e48f97a9 100644 --- a/lib/purescript-cst/src/Control/Monad/Supply.hs +++ b/lib/purescript-cst/src/Control/Monad/Supply.hs @@ -11,8 +11,6 @@ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer -import Data.Functor.Identity - newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus) @@ -21,11 +19,3 @@ runSupplyT n = flip runStateT n . unSupplyT evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a evalSupplyT n = fmap fst . runSupplyT n - -type Supply = SupplyT Identity - -runSupply :: Integer -> Supply a -> (a, Integer) -runSupply n = runIdentity . runSupplyT n - -evalSupply :: Integer -> Supply a -> a -evalSupply n = runIdentity . evalSupplyT n diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs index a33e406ed5..9cc76fd928 100644 --- a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs @@ -291,10 +291,6 @@ data ImportDeclarationType | Hiding [DeclarationRef] deriving (Eq, Show, Generic, Serialise) -isImplicit :: ImportDeclarationType -> Bool -isImplicit Implicit = True -isImplicit _ = False - isExplicit :: ImportDeclarationType -> Bool isExplicit (Explicit _) = True isExplicit _ = False @@ -323,9 +319,6 @@ data TypeDeclarationData = TypeDeclarationData , tydeclType :: !SourceType } deriving (Show, Eq) -overTypeDeclaration :: (TypeDeclarationData -> TypeDeclarationData) -> Declaration -> Declaration -overTypeDeclaration f d = maybe d (TypeDeclaration . f) (getTypeDeclaration d) - getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData getTypeDeclaration (TypeDeclaration d) = Just d getTypeDeclaration _ = Nothing @@ -348,9 +341,6 @@ data ValueDeclarationData a = ValueDeclarationData , valdeclExpression :: !a } deriving (Show, Functor, Foldable, Traversable) -overValueDeclaration :: (ValueDeclarationData [GuardedExpr] -> ValueDeclarationData [GuardedExpr]) -> Declaration -> Declaration -overValueDeclaration f d = maybe d (ValueDeclaration . f) (getValueDeclaration d) - getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr]) getValueDeclaration (ValueDeclaration d) = Just d getValueDeclaration _ = Nothing diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs b/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs index 4b2b1a615f..038c4137d8 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs @@ -110,10 +110,6 @@ addFailure :: [SourceToken] -> ParserErrorType -> Parser () addFailure toks ty = Parser $ \st _ ksucc -> ksucc (st { parserErrors = mkParserError [] toks ty : parserErrors st }) () -addFailures :: [ParserError] -> Parser () -addFailures errs = Parser $ \st _ ksucc -> - ksucc (st { parserErrors = errs <> parserErrors st }) () - parseFail' :: [SourceToken] -> ParserErrorType -> Parser a parseFail' toks msg = Parser $ \st kerr _ -> kerr st (mkParserError [] toks msg) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs index d9c739b8ee..ba76ad7374 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs @@ -114,9 +114,6 @@ nameRange a = (nameTok a, nameTok a) qualRange :: QualifiedName a -> TokenRange qualRange a = (qualTok a, qualTok a) -labelRange :: Label -> TokenRange -labelRange a = (lblTok a, lblTok a) - wrappedRange :: Wrapped a -> TokenRange wrappedRange Wrapped { wrpOpen, wrpClose } = (wrpOpen, wrpClose) @@ -338,8 +335,3 @@ recordUpdateRange :: RecordUpdate a -> TokenRange recordUpdateRange = \case RecordUpdateLeaf a _ b -> (lblTok a, snd $ exprRange b) RecordUpdateBranch a (Wrapped _ _ b) -> (lblTok a, b) - -recordLabeledExprRange :: RecordLabeled (Expr a) -> TokenRange -recordLabeledExprRange = \case - RecordPun a -> nameRange a - RecordField a _ b -> (fst $ labelRange a, snd $ exprRange b) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs index 9128b00f26..9c31d5fd8b 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs @@ -85,18 +85,9 @@ unexpectedLabel tok = Label tok "" unexpectedExpr :: Monoid a => [SourceToken] -> Expr a unexpectedExpr toks = ExprIdent mempty (unexpectedQual (head toks)) -unexpectedDecl :: Monoid a => [SourceToken] -> Declaration a -unexpectedDecl toks = DeclValue mempty (ValueBindingFields (unexpectedName (head toks)) [] (error " [SourceToken] -> Binder a unexpectedBinder toks = BinderVar mempty (unexpectedName (head toks)) -unexpectedLetBinding :: Monoid a => [SourceToken] -> LetBinding a -unexpectedLetBinding toks = LetBindingName mempty (ValueBindingFields (unexpectedName (head toks)) [] (error "")) - -unexpectedInstBinding :: Monoid a => [SourceToken] -> InstanceBinding a -unexpectedInstBinding toks = InstanceBindingName mempty (ValueBindingFields (unexpectedName (head toks)) [] (error "")) - unexpectedRecordUpdate :: Monoid a => [SourceToken] -> RecordUpdate a unexpectedRecordUpdate toks = RecordUpdateLeaf (unexpectedLabel (head toks)) (head toks) (unexpectedExpr toks) @@ -119,9 +110,6 @@ separated = go [] go accum (x : xs) = go (x : accum) xs go _ [] = internalError "Separated should not be empty" -consSeparated :: a -> SourceToken -> Separated a -> Separated a -consSeparated x sep Separated {..} = Separated x ((sep, sepHead) : sepTail) - internalError :: String -> a internalError = error . ("Internal parser error: " <>) @@ -170,9 +158,6 @@ toLabel tok = case tokValue tok of TokForall ASCII -> Label tok $ mkString "forall" _ -> internalError $ "Invalid label: " <> show tok -labelToIdent :: Label -> Parser (Name Ident) -labelToIdent (Label tok _) = toName Ident tok - toString :: SourceToken -> (SourceToken, PSString) toString tok = case tokValue tok of TokString _ a -> (tok, a) diff --git a/lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs b/lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs index 6667e65117..7c823a17a0 100644 --- a/lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs +++ b/lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs @@ -13,9 +13,6 @@ undefined = "undefined" -- Prim -partial :: forall a. (IsString a) => a -partial = "Partial" - pattern Prim :: ModuleName pattern Prim = ModuleName "Prim" @@ -45,12 +42,6 @@ pattern Row = Qualified (Just Prim) (ProperName "Row") pattern PrimBoolean :: ModuleName pattern PrimBoolean = ModuleName "Prim.Boolean" -booleanTrue :: Qualified (ProperName 'TypeName) -booleanTrue = Qualified (Just PrimBoolean) (ProperName "True") - -booleanFalse :: Qualified (ProperName 'TypeName) -booleanFalse = Qualified (Just PrimBoolean) (ProperName "False") - -- Prim.Coerce pattern PrimCoerce :: ModuleName @@ -135,9 +126,6 @@ primModules = [Prim, PrimBoolean, PrimCoerce, PrimOrdering, PrimRow, PrimRowList typ :: forall a. (IsString a) => a typ = "Type" -kindBoolean :: forall a. (IsString a) => a -kindBoolean = "Boolean" - kindOrdering :: forall a. (IsString a) => a kindOrdering = "Ordering" diff --git a/lib/purescript-cst/src/Language/PureScript/Environment.hs b/lib/purescript-cst/src/Language/PureScript/Environment.hs index f5aff65742..9bd9ffcecb 100644 --- a/lib/purescript-cst/src/Language/PureScript/Environment.hs +++ b/lib/purescript-cst/src/Language/PureScript/Environment.hs @@ -267,19 +267,12 @@ kindType = primKind C.typ kindConstraint :: SourceType kindConstraint = primKind C.constraint -isKindType :: Type a -> Bool -isKindType (TypeConstructor _ n) = n == primName C.typ -isKindType _ = False - kindSymbol :: SourceType kindSymbol = primKind C.symbol kindDoc :: SourceType kindDoc = primSubKind C.typeError C.doc -kindBoolean :: SourceType -kindBoolean = primSubKind C.moduleBoolean C.kindBoolean - kindOrdering :: SourceType kindOrdering = primSubKind C.moduleOrdering C.kindOrdering @@ -334,18 +327,6 @@ tyVar = TypeVar nullSourceAnn tyForall :: Text -> SourceType -> SourceType -> SourceType tyForall var k ty = ForAll nullSourceAnn var (Just k) ty Nothing --- | Check whether a type is a record -isObject :: Type a -> Bool -isObject = isTypeOrApplied tyRecord - --- | Check whether a type is a function -isFunction :: Type a -> Bool -isFunction = isTypeOrApplied tyFunction - -isTypeOrApplied :: Type a -> Type b -> Bool -isTypeOrApplied t1 (TypeApp _ t2 _) = eqType t1 t2 -isTypeOrApplied t1 t2 = eqType t1 t2 - -- | Smart constructor for function types function :: SourceType -> SourceType -> SourceType function = TypeApp nullSourceAnn . TypeApp nullSourceAnn tyFunction @@ -594,12 +575,6 @@ lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> ( lookupConstructor env ctor = fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env --- | Checks whether a data constructor is for a newtype. -isNewtypeConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> Bool -isNewtypeConstructor e ctor = case lookupConstructor e ctor of - (Newtype, _, _, _) -> True - (Data, _, _, _) -> False - -- | Finds information about values from the current environment. lookupValue :: Environment -> Qualified Ident -> Maybe (SourceType, NameKind, NameVisibility) lookupValue env ident = ident `M.lookup` names env diff --git a/lib/purescript-cst/src/Language/PureScript/Names.hs b/lib/purescript-cst/src/Language/PureScript/Names.hs index bf18164076..dec1fbe1b7 100644 --- a/lib/purescript-cst/src/Language/PureScript/Names.hs +++ b/lib/purescript-cst/src/Language/PureScript/Names.hs @@ -57,10 +57,6 @@ getClassName :: Name -> Maybe (ProperName 'ClassName) getClassName (TyClassName name) = Just name getClassName _ = Nothing -getModName :: Name -> Maybe ModuleName -getModName (ModName name) = Just name -getModName _ = Nothing - -- | -- Names for value identifiers -- diff --git a/lib/purescript-cst/src/Language/PureScript/Traversals.hs b/lib/purescript-cst/src/Language/PureScript/Traversals.hs index ce42f696b6..25b426b15a 100644 --- a/lib/purescript-cst/src/Language/PureScript/Traversals.hs +++ b/lib/purescript-cst/src/Language/PureScript/Traversals.hs @@ -3,9 +3,6 @@ module Language.PureScript.Traversals where import Prelude.Compat -fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b) -fstM f (a, b) = (, b) <$> f a - sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c) sndM f (a, b) = (a, ) <$> f b @@ -15,10 +12,6 @@ thirdM f (a, b, c) = (a, b, ) <$> f c pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d) pairM f g (a, b) = (,) <$> f a <*> g b -maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b) -maybeM _ Nothing = pure Nothing -maybeM f (Just a) = Just <$> f a - eitherM :: (Applicative f) => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d) eitherM f _ (Left a) = Left <$> f a eitherM _ g (Right b) = Right <$> g b diff --git a/lib/purescript-cst/src/Language/PureScript/Types.hs b/lib/purescript-cst/src/Language/PureScript/Types.hs index 061d96c10d..7c35913873 100644 --- a/lib/purescript-cst/src/Language/PureScript/Types.hs +++ b/lib/purescript-cst/src/Language/PureScript/Types.hs @@ -18,7 +18,6 @@ import Data.Foldable (fold, foldl') import qualified Data.IntSet as IS import Data.List (sort, sortOn) import Data.Maybe (fromMaybe, isJust) -import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) @@ -105,9 +104,6 @@ srcTypeWildcard = TypeWildcard NullSourceAnn Nothing srcTypeConstructor :: Qualified (ProperName 'TypeName) -> SourceType srcTypeConstructor = TypeConstructor NullSourceAnn -srcTypeOp :: Qualified (OpName 'TypeOpName) -> SourceType -srcTypeOp = TypeOp NullSourceAnn - srcTypeApp :: SourceType -> SourceType -> SourceType srcTypeApp = TypeApp NullSourceAnn @@ -129,12 +125,6 @@ srcRCons = RCons NullSourceAnn srcKindedType :: SourceType -> SourceType -> SourceType srcKindedType = KindedType NullSourceAnn -srcBinaryNoParensType :: SourceType -> SourceType -> SourceType -> SourceType -srcBinaryNoParensType = BinaryNoParensType NullSourceAnn - -srcParensInType :: SourceType -> SourceType -srcParensInType = ParensInType NullSourceAnn - pattern REmptyKinded :: forall a. a -> Maybe (Type a) -> Type a pattern REmptyKinded ann mbK <- (toREmptyKinded -> Just (ann, mbK)) @@ -185,12 +175,6 @@ mapConstraintArgs f c = c { constraintArgs = f (constraintArgs c) } overConstraintArgs :: Functor f => ([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a) overConstraintArgs f c = (\args -> c { constraintArgs = args }) <$> f (constraintArgs c) -mapConstraintKindArgs :: ([Type a] -> [Type a]) -> Constraint a -> Constraint a -mapConstraintKindArgs f c = c { constraintKindArgs = f (constraintKindArgs c) } - -overConstraintKindArgs :: Functor f => ([Type a] -> f [Type a]) -> Constraint a -> f (Constraint a) -overConstraintKindArgs f c = (\args -> c { constraintKindArgs = args }) <$> f (constraintKindArgs c) - mapConstraintArgsAll :: ([Type a] -> [Type a]) -> Constraint a -> Constraint a mapConstraintArgsAll f c = c { constraintKindArgs = f (constraintKindArgs c) @@ -528,13 +512,6 @@ moveQuantifiersToFront = go [] [] where go qs cs (ConstrainedType ann c ty) = go qs ((ann, c) : cs) ty go qs cs ty = foldl (\ty' (ann, q, sco, mbK) -> ForAll ann q mbK ty' sco) (foldl (\ty' (ann, c) -> ConstrainedType ann c ty') ty cs) qs --- | Check if a type contains wildcards -containsWildcards :: Type a -> Bool -containsWildcards = everythingOnTypes (||) go where - go :: Type a -> Bool - go TypeWildcard{} = True - go _ = False - -- | Check if a type contains `forall` containsForAll :: Type a -> Bool containsForAll = everythingOnTypes (||) go where @@ -616,18 +593,6 @@ everywhereOnTypes f = go where go (ParensInType ann t) = f (ParensInType ann (go t)) go other = f other -everywhereOnTypesTopDown :: (Type a -> Type a) -> Type a -> Type a -everywhereOnTypesTopDown f = go . f where - go (TypeApp ann t1 t2) = TypeApp ann (go (f t1)) (go (f t2)) - go (KindApp ann t1 t2) = KindApp ann (go (f t1)) (go (f t2)) - go (ForAll ann arg mbK ty sco) = ForAll ann arg (go . f <$> mbK) (go (f ty)) sco - go (ConstrainedType ann c ty) = ConstrainedType ann (mapConstraintArgsAll (map (go . f)) c) (go (f ty)) - go (RCons ann name ty rest) = RCons ann name (go (f ty)) (go (f rest)) - go (KindedType ann ty k) = KindedType ann (go (f ty)) (go (f k)) - go (BinaryNoParensType ann t1 t2 t3) = BinaryNoParensType ann (go (f t1)) (go (f t2)) (go (f t3)) - go (ParensInType ann t) = ParensInType ann (go (f t)) - go other = f other - everywhereOnTypesM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (Type a) everywhereOnTypesM f = go where go (TypeApp ann t1 t2) = (TypeApp ann <$> go t1 <*> go t2) >>= f @@ -640,18 +605,6 @@ everywhereOnTypesM f = go where go (ParensInType ann t) = (ParensInType ann <$> go t) >>= f go other = f other -everywhereWithScopeOnTypesM :: Monad m => S.Set Text -> (S.Set Text -> Type a -> m (Type a)) -> Type a -> m (Type a) -everywhereWithScopeOnTypesM s0 f = go s0 where - go s (TypeApp ann t1 t2) = (TypeApp ann <$> go s t1 <*> go s t2) >>= f s - go s (KindApp ann t1 t2) = (KindApp ann <$> go s t1 <*> go s t2) >>= f s - go s (ForAll ann arg mbK ty sco) = (ForAll ann arg <$> traverse (go s) mbK <*> go (S.insert arg s) ty <*> pure sco) >>= f s - go s (ConstrainedType ann c ty) = (ConstrainedType ann <$> overConstraintArgsAll (traverse (go s)) c <*> go s ty) >>= f s - go s (RCons ann name ty rest) = (RCons ann name <$> go s ty <*> go s rest) >>= f s - go s (KindedType ann ty k) = (KindedType ann <$> go s ty <*> go s k) >>= f s - go s (BinaryNoParensType ann t1 t2 t3) = (BinaryNoParensType ann <$> go s t1 <*> go s t2 <*> go s t3) >>= f s - go s (ParensInType ann t) = (ParensInType ann <$> go s t) >>= f s - go s other = f s other - everywhereOnTypesTopDownM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (Type a) everywhereOnTypesTopDownM f = go <=< f where go (TypeApp ann t1 t2) = TypeApp ann <$> (f t1 >>= go) <*> (f t2 >>= go) diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index 4a294256fc..39af647330 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -9,30 +9,15 @@ import Language.PureScript.Names -- Operators -($) :: forall a. (IsString a) => a -($) = "$" - apply :: forall a. (IsString a) => a apply = "apply" -(#) :: forall a. (IsString a) => a -(#) = "#" - applyFlipped :: forall a. (IsString a) => a applyFlipped = "applyFlipped" -(<>) :: forall a. (IsString a) => a -(<>) = "<>" - -(++) :: forall a. (IsString a) => a -(++) = "++" - append :: forall a. (IsString a) => a append = "append" -(>>=) :: forall a. (IsString a) => a -(>>=) = ">>=" - bind :: forall a. (IsString a) => a bind = "bind" @@ -42,72 +27,36 @@ discard = "discard" pattern Discard :: Qualified (ProperName 'ClassName) pattern Discard = Qualified (Just ControlBind) (ProperName "Discard") -(+) :: forall a. (IsString a) => a -(+) = "+" - add :: forall a. (IsString a) => a add = "add" -(-) :: forall a. (IsString a) => a -(-) = "-" - sub :: forall a. (IsString a) => a sub = "sub" -(*) :: forall a. (IsString a) => a -(*) = "*" - mul :: forall a. (IsString a) => a mul = "mul" -(/) :: forall a. (IsString a) => a -(/) = "/" - div :: forall a. (IsString a) => a div = "div" -(%) :: forall a. (IsString a) => a -(%) = "%" - -mod :: forall a. (IsString a) => a -mod = "mod" - -(<) :: forall a. (IsString a) => a -(<) = "<" - lessThan :: forall a. (IsString a) => a lessThan = "lessThan" -(>) :: forall a. (IsString a) => a -(>) = ">" - greaterThan :: forall a. (IsString a) => a greaterThan = "greaterThan" -(<=) :: forall a. (IsString a) => a -(<=) = "<=" - lessThanOrEq :: forall a. (IsString a) => a lessThanOrEq = "lessThanOrEq" -(>=) :: forall a. (IsString a) => a -(>=) = ">=" - greaterThanOrEq :: forall a. (IsString a) => a greaterThanOrEq = "greaterThanOrEq" -(==) :: forall a. (IsString a) => a -(==) = "==" - eq :: forall a. (IsString a) => a eq = "eq" eq1 :: forall a. (IsString a) => a eq1 = "eq1" -(/=) :: forall a. (IsString a) => a -(/=) = "/=" - notEq :: forall a. (IsString a) => a notEq = "notEq" @@ -117,15 +66,9 @@ compare = "compare" compare1 :: forall a. (IsString a) => a compare1 = "compare1" -(&&) :: forall a. (IsString a) => a -(&&) = "&&" - conj :: forall a. (IsString a) => a conj = "conj" -(||) :: forall a. (IsString a) => a -(||) = "||" - disj :: forall a. (IsString a) => a disj = "disj" @@ -141,15 +84,9 @@ and = "and" xor :: forall a. (IsString a) => a xor = "xor" -(<<<) :: forall a. (IsString a) => a -(<<<) = "<<<" - compose :: forall a. (IsString a) => a compose = "compose" -(>>>) :: forall a. (IsString a) => a -(>>>) = ">>>" - composeFlipped :: forall a. (IsString a) => a composeFlipped = "composeFlipped" @@ -190,18 +127,9 @@ bottom = "bottom" top :: forall a. (IsString a) => a top = "top" -return :: forall a. (IsString a) => a -return = "return" - pure' :: forall a. (IsString a) => a pure' = "pure" -returnEscaped :: forall a. (IsString a) => a -returnEscaped = "$return" - -unit :: forall a. (IsString a) => a -unit = "unit" - -- Core lib values runST :: forall a. (IsString a) => a @@ -292,18 +220,9 @@ ringNumber = "ringNumber" ringInt :: forall a. (IsString a) => a ringInt = "ringInt" -moduloSemiringNumber :: forall a. (IsString a) => a -moduloSemiringNumber = "moduloSemiringNumber" - -moduloSemiringInt :: forall a. (IsString a) => a -moduloSemiringInt = "moduloSemiringInt" - euclideanRingNumber :: forall a. (IsString a) => a euclideanRingNumber = "euclideanRingNumber" -euclideanRingInt :: forall a. (IsString a) => a -euclideanRingInt = "euclideanRingInt" - ordBoolean :: forall a. (IsString a) => a ordBoolean = "ordBoolean" @@ -337,9 +256,6 @@ eqBoolean = "eqBoolean" boundedBoolean :: forall a. (IsString a) => a boundedBoolean = "boundedBoolean" -booleanAlgebraBoolean :: forall a. (IsString a) => a -booleanAlgebraBoolean = "booleanAlgebraBoolean" - heytingAlgebraBoolean :: forall a. (IsString a) => a heytingAlgebraBoolean = "heytingAlgebraBoolean" @@ -349,25 +265,6 @@ semigroupString = "semigroupString" semigroupoidFn :: forall a. (IsString a) => a semigroupoidFn = "semigroupoidFn" --- Generic Deriving - -generic :: forall a. (IsString a) => a -generic = "Generic" - -toSpine :: forall a. (IsString a) => a -toSpine = "toSpine" - -fromSpine :: forall a. (IsString a) => a -fromSpine = "fromSpine" - -toSignature :: forall a. (IsString a) => a -toSignature = "toSignature" - --- Main module - -main :: forall a. (IsString a) => a -main = "main" - -- Data.Symbol pattern DataSymbol :: ModuleName @@ -376,9 +273,6 @@ pattern DataSymbol = ModuleName "Data.Symbol" pattern IsSymbol :: Qualified (ProperName 'ClassName) pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol") -prelude :: forall a. (IsString a) => a -prelude = "Prelude" - dataArray :: forall a. (IsString a) => a dataArray = "Data_Array" diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs index 5415911863..291232065f 100644 --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -43,35 +43,3 @@ everywhereOnValues f g h = (f', g', h') handleLiteral i (ArrayLiteral ls) = ArrayLiteral (map i ls) handleLiteral i (ObjectLiteral ls) = ObjectLiteral (map (fmap i) ls) handleLiteral _ other = other - -everythingOnValues :: (r -> r -> r) -> - (Bind a -> r) -> - (Expr a -> r) -> - (Binder a -> r) -> - (CaseAlternative a -> r) -> - (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r) -everythingOnValues (<>.) f g h i = (f', g', h', i') - where - f' b@(NonRec _ _ e) = f b <>. g' e - f' b@(Rec es) = foldl (<>.) (f b) (map (g' . snd) es) - - g' v@(Literal _ l) = foldl (<>.) (g v) (map g' (extractLiteral l)) - g' v@(Accessor _ _ e1) = g v <>. g' e1 - g' v@(ObjectUpdate _ obj vs) = foldl (<>.) (g v <>. g' obj) (map (g' . snd) vs) - g' v@(Abs _ _ e1) = g v <>. g' e1 - g' v@(App _ e1 e2) = g v <>. g' e1 <>. g' e2 - g' v@(Case _ vs alts) = foldl (<>.) (foldl (<>.) (g v) (map g' vs)) (map i' alts) - g' v@(Let _ ds e1) = foldl (<>.) (g v) (map f' ds) <>. g' e1 - g' v = g v - - h' b@(LiteralBinder _ l) = foldl (<>.) (h b) (map h' (extractLiteral l)) - h' b@(ConstructorBinder _ _ _ bs) = foldl (<>.) (h b) (map h' bs) - h' b@(NamedBinder _ _ b1) = h b <>. h' b1 - h' b = h b - - i' ca@(CaseAlternative bs (Right val)) = foldl (<>.) (i ca) (map h' bs) <>. g' val - i' ca@(CaseAlternative bs (Left gs)) = foldl (<>.) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs) - - extractLiteral (ArrayLiteral xs) = xs - extractLiteral (ObjectLiteral xs) = map snd xs - extractLiteral _ = [] diff --git a/src/Language/PureScript/CoreImp/Optimizer/Common.hs b/src/Language/PureScript/CoreImp/Optimizer/Common.hs index 040995cb36..8085895e0a 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Common.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Common.hs @@ -43,14 +43,6 @@ isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everything (++) variablesOf (Var _ var) = [var] variablesOf _ = [] -isUsed :: Text -> AST -> Bool -isUsed var1 = everything (||) check - where - check :: AST -> Bool - check (Var _ var2) | var1 == var2 = True - check (Assignment _ target _) | var1 == targetVariable target = True - check _ = False - targetVariable :: AST -> Text targetVariable (Var _ var) = var targetVariable (Indexer _ _ tgt) = targetVariable tgt diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index 3ff4c6102e..2cf625cc82 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -7,7 +7,6 @@ module Language.PureScript.Docs.AsHtml ( HtmlOutputModule(..), HtmlRenderContext(..), nullRenderContext, - declNamespace, packageAsHtml, moduleAsHtml, makeFragment, @@ -39,9 +38,6 @@ import Language.PureScript.Docs.RenderedCode hiding (sp) import qualified Language.PureScript.Docs.Render as Render import qualified Language.PureScript.CST as CST -declNamespace :: Declaration -> Namespace -declNamespace = declInfoNamespace . declInfo - data HtmlOutput a = HtmlOutput { htmlIndex :: [(Maybe Char, a)] , htmlModules :: [(P.ModuleName, HtmlOutputModule a)] diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 1177de0026..0a150a2417 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -1,7 +1,6 @@ module Language.PureScript.Docs.AsMarkdown ( Docs , runDocs - , modulesAsMarkdown , moduleAsMarkdown , codeToString ) where @@ -21,9 +20,6 @@ import Language.PureScript.Docs.Types import qualified Language.PureScript as P import qualified Language.PureScript.Docs.Render as Render -modulesAsMarkdown :: [Module] -> Docs -modulesAsMarkdown = mapM_ moduleAsMarkdown - moduleAsMarkdown :: Module -> Docs moduleAsMarkdown Module{..} = do headerLevel 2 $ "Module " <> P.runModuleName modName diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 7e7f2e0e0d..30c83bde19 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -3,34 +3,25 @@ module Language.PureScript.Docs.RenderedCode.Types ( RenderedCodeElement(..) - , asRenderedCodeElement , ContainingModule(..) , asContainingModule - , containingModuleToMaybe , maybeToContainingModule - , fromContainingModule , fromQualified , Namespace(..) , Link(..) , FixityAlias , RenderedCode - , asRenderedCode , outputWith , sp - , parens , syntax , keyword , keywordForall , keywordData - , keywordNewtype , keywordType , keywordClass - , keywordInstance , keywordWhere , keywordFixity - , keywordKind , keywordAs - , kindSignatureFor , ident , dataCtor , typeCtor @@ -46,7 +37,7 @@ import GHC.Generics (Generic) import Control.DeepSeq (NFData) import Control.Monad.Error.Class (MonadError(..)) -import Data.Aeson.BetterErrors (Parse, nth, withText, withValue, toAesonParser, perhaps, asText, eachInArray) +import Data.Aeson.BetterErrors (Parse, nth, withText, withValue, toAesonParser, perhaps, asText) import qualified Data.Aeson as A import Data.Text (Text) import qualified Data.Text as T @@ -55,7 +46,6 @@ import qualified Data.Text.Encoding as TE import Language.PureScript.Names import Language.PureScript.AST (Associativity(..)) -import qualified Language.PureScript.AST.Declarations as P -- | Given a list of actions, attempt them all, returning the first success. -- If all the actions fail, 'tryAll' returns the first argument. @@ -125,21 +115,6 @@ maybeToContainingModule :: Maybe ModuleName -> ContainingModule maybeToContainingModule Nothing = ThisModule maybeToContainingModule (Just mn) = OtherModule mn --- | --- Convert a 'ContainingModule' to a 'Maybe' 'ModuleName', using the obvious --- isomorphism. --- -containingModuleToMaybe :: ContainingModule -> Maybe ModuleName -containingModuleToMaybe ThisModule = Nothing -containingModuleToMaybe (OtherModule mn) = Just mn - --- | --- A version of 'fromMaybe' for 'ContainingModule' values. --- -fromContainingModule :: ModuleName -> ContainingModule -> ModuleName -fromContainingModule def ThisModule = def -fromContainingModule _ (OtherModule mn) = mn - fromQualified :: Qualified a -> (ContainingModule, a) fromQualified (Qualified mn x) = (maybeToContainingModule mn, x) @@ -210,30 +185,6 @@ instance A.ToJSON RenderedCodeElement where toJSON (Symbol ns str link) = A.toJSON ["symbol", A.toJSON ns, A.toJSON str, A.toJSON link] -asRenderedCodeElement :: Parse Text RenderedCodeElement -asRenderedCodeElement = - tryParse "RenderedCodeElement" $ - [ a Syntax "syntax" - , a Keyword "keyword" - , asSpace - , asSymbol - ] ++ backwardsCompat - where - a ctor' ctorStr = firstEq ctorStr (ctor' <$> nth 1 asText) - asSymbol = firstEq "symbol" (Symbol <$> nth 1 asNamespace <*> nth 2 asText <*> nth 3 asLink) - asSpace = firstEq "space" (pure Space) - - -- These will make some mistakes e.g. treating data constructors as types, - -- because the old code did not save information which is necessary to - -- distinguish these cases. This is the best we can do. - backwardsCompat = - [ oldAsIdent - , oldAsCtor - ] - - oldAsIdent = firstEq "ident" (Symbol ValueLevel <$> nth 1 asText <*> nth 2 (Link <$> asContainingModule)) - oldAsCtor = firstEq "ctor" (Symbol TypeLevel <$> nth 1 asText <*> nth 2 (Link <$> asContainingModule)) - -- | -- A type representing a highly simplified version of PureScript code, intended -- for use in output formats like plain text or HTML. @@ -245,9 +196,6 @@ newtype RenderedCode instance A.ToJSON RenderedCode where toJSON (RC elems) = A.toJSON elems -asRenderedCode :: Parse Text RenderedCode -asRenderedCode = RC <$> eachInArray asRenderedCodeElement - -- | -- This function allows conversion of a 'RenderedCode' value into a value of -- some other type (for example, plain text, or HTML). The first argument @@ -263,11 +211,6 @@ outputWith f = foldMap f . unRC sp :: RenderedCode sp = RC [Space] --- | --- Wrap a RenderedCode value in parens. -parens :: RenderedCode -> RenderedCode -parens x = syntax "(" <> x <> syntax ")" - -- possible TODO: instead of this function, export RenderedCode values for -- each syntax element, eg syntaxArr (== syntax "->"), syntaxLBrace, -- syntaxRBrace, etc. @@ -283,18 +226,12 @@ keywordForall = keyword "forall" keywordData :: RenderedCode keywordData = keyword "data" -keywordNewtype :: RenderedCode -keywordNewtype = keyword "newtype" - keywordType :: RenderedCode keywordType = keyword "type" keywordClass :: RenderedCode keywordClass = keyword "class" -keywordInstance :: RenderedCode -keywordInstance = keyword "instance" - keywordWhere :: RenderedCode keywordWhere = keyword "where" @@ -303,19 +240,9 @@ keywordFixity Infixl = keyword "infixl" keywordFixity Infixr = keyword "infixr" keywordFixity Infix = keyword "infix" -keywordKind :: RenderedCode -keywordKind = keyword "kind" - keywordAs :: RenderedCode keywordAs = keyword "as" -kindSignatureFor :: P.KindSignatureFor -> RenderedCode -kindSignatureFor = \case - P.DataSig -> keywordData - P.NewtypeSig -> keywordNewtype - P.TypeSynonymSig -> keywordType - P.ClassSig -> keywordClass - ident :: Qualified Ident -> RenderedCode ident (fromQualified -> (mn, name)) = RC [Symbol ValueLevel (runIdent name) (Link mn)] diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index ee2aff8ea3..129892e12f 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -11,7 +11,7 @@ import Control.Arrow ((***)) import Data.Aeson ((.=)) import Data.Aeson.BetterErrors - (Parse, ParseError, parse, keyOrDefault, throwCustomError, key, asText, + (Parse, keyOrDefault, throwCustomError, key, asText, keyMay, withString, eachInArray, asNull, (.!), toAesonParser, toAesonParser', fromAesonParser, perhaps, withText, asIntegral, nth, eachInObjectWithKey, asString) @@ -34,9 +34,9 @@ import qualified Paths_purescript as Paths import Web.Bower.PackageMeta hiding (Version, displayError) import Language.PureScript.Docs.RenderedCode as ReExports - (RenderedCode, asRenderedCode, + (RenderedCode, ContainingModule(..), asContainingModule, - RenderedCodeElement(..), asRenderedCodeElement, + RenderedCodeElement(..), Namespace(..), FixityAlias) type Type' = P.Type () @@ -376,13 +376,6 @@ instance Functor InPackage where fmap f (Local x) = Local (f x) fmap f (FromDep pkgName x) = FromDep pkgName (f x) -takeLocal :: InPackage a -> Maybe a -takeLocal (Local a) = Just a -takeLocal _ = Nothing - -takeLocals :: [InPackage a] -> [a] -takeLocals = mapMaybe takeLocal - ignorePackage :: InPackage a -> a ignorePackage (Local x) = x ignorePackage (FromDep _ x) = x @@ -477,12 +470,6 @@ getLinksContext Package{..} = ---------------------- -- Parsing -parseUploadedPackage :: Version -> LByteString -> Either (ParseError PackageError) UploadedPackage -parseUploadedPackage minVersion = parse $ asUploadedPackage minVersion - -parseVerifiedPackage :: Version -> LByteString -> Either (ParseError PackageError) VerifiedPackage -parseVerifiedPackage minVersion = parse $ asVerifiedPackage minVersion - asPackage :: Version -> (forall e. Parse e a) -> Parse PackageError (Package a) asPackage minimumVersion uploader = do -- If the compilerVersion key is missing, we can be sure that it was produced @@ -520,9 +507,6 @@ asNotYetKnown = NotYetKnown <$ asNull instance A.FromJSON NotYetKnown where parseJSON = toAesonParser' asNotYetKnown -asVerifiedPackage :: Version -> Parse PackageError VerifiedPackage -asVerifiedPackage minVersion = asPackage minVersion asGithubUser - displayPackageError :: PackageError -> Text displayPackageError e = case e of CompilerTooOld minV usedV -> @@ -715,12 +699,6 @@ asConstraint = P.Constraint () <$> key "constraintClass" asQualifiedProperName asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a)) asQualifiedProperName = fromAesonParser -asQualifiedIdent :: Parse e (P.Qualified P.Ident) -asQualifiedIdent = fromAesonParser - -asSourceAnn :: Parse e P.SourceAnn -asSourceAnn = fromAesonParser - asModuleMap :: Parse PackageError (Map P.ModuleName PackageName) asModuleMap = Map.fromList <$> diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 9029417740..32c9532524 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1849,12 +1849,6 @@ toTypelevelString _ = Nothing rethrow :: (MonadError e m) => (e -> e) -> m a -> m a rethrow f = flip catchError (throwError . f) -reifyErrors :: (MonadError e m) => m a -> m (Either e a) -reifyErrors ma = catchError (fmap Right ma) (return . Left) - -reflectErrors :: (MonadError e m) => m (Either e a) -> m a -reflectErrors ma = ma >>= either throwError return - warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a warnAndRethrow f = rethrow f . censor f diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 723981455a..61dfcb4e14 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -13,8 +13,7 @@ ----------------------------------------------------------------------------- module Language.PureScript.Ide.SourceFile - ( parseModule - , parseModulesFromFiles + ( parseModulesFromFiles , extractAstInformation -- for tests , extractSpans @@ -31,16 +30,8 @@ import Language.PureScript.Ide.Error import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -parseModule - :: (MonadIO m, MonadError IdeError m) - => FilePath - -> m (Either FilePath (FilePath, P.Module)) -parseModule path = do - (absPath, contents) <- ideReadFile path - pure (parseModule' absPath contents) - -parseModule' :: FilePath -> Text -> Either FilePath (FilePath, P.Module) -parseModule' path file = +parseModule :: FilePath -> Text -> Either FilePath (FilePath, P.Module) +parseModule path file = case snd $ CST.parseFromFile path file of Left _ -> Left path Right m -> Right (path, m) @@ -51,7 +42,7 @@ parseModulesFromFiles -> m [Either FilePath (FilePath, P.Module)] parseModulesFromFiles paths = do files <- traverse ideReadFile paths - pure (inParallel (map (uncurry parseModule') files)) + pure (inParallel (map (uncurry parseModule) files)) where inParallel :: [Either e (k, a)] -> [Either e (k, a)] inParallel = withStrategy (parList rseq) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index cc53169ac3..11946aa21d 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -125,7 +125,6 @@ makeLenses ''IdeType makeLenses ''IdeTypeSynonym makeLenses ''IdeDataConstructor makeLenses ''IdeTypeClass -makeLenses ''IdeInstance makeLenses ''IdeValueOperator makeLenses ''IdeTypeOperator diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs index 3bb8a9b110..40daec6cb0 100644 --- a/src/Language/PureScript/Interactive/Directive.hs +++ b/src/Language/PureScript/Interactive/Directive.hs @@ -5,18 +5,12 @@ module Language.PureScript.Interactive.Directive where import Prelude.Compat -import Data.Maybe (fromJust, listToMaybe) +import Data.Maybe (fromJust) import Data.List (isPrefixOf) import Data.Tuple (swap) import Language.PureScript.Interactive.Types --- | --- List of all available directives. --- -directives :: [Directive] -directives = map fst directiveStrings - -- | -- A mapping of directives to the different strings that can be used to invoke -- them. @@ -44,12 +38,6 @@ directiveStrings' = concatMap go directiveStrings where go (dir, strs) = map (, dir) strs --- | --- List of all directive strings. --- -strings :: [String] -strings = concatMap snd directiveStrings - -- | -- Returns all possible string representations of a directive. -- @@ -77,9 +65,6 @@ directivesFor = map fst . directivesFor' directiveStringsFor :: String -> [String] directiveStringsFor = map snd . directivesFor' -parseDirective :: String -> Maybe Directive -parseDirective = listToMaybe . directivesFor - -- | -- The help menu. -- diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 66d930b0f2..8e8a61077c 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -7,7 +7,7 @@ import qualified Language.PureScript.CST as CST import Language.PureScript.Interactive.Types import System.Directory (getCurrentDirectory) import System.FilePath (pathSeparator, makeRelative) -import System.IO.UTF8 (readUTF8FileT, readUTF8FilesT) +import System.IO.UTF8 (readUTF8FilesT) -- * Support Module @@ -21,15 +21,6 @@ supportModuleIsDefined = elem supportModuleName -- * Module Management --- | Loads a file for use with imports. -loadModule :: FilePath -> IO (Either String [P.Module]) -loadModule filename = do - pwd <- getCurrentDirectory - content <- readUTF8FileT filename - return $ - either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd}) (Right . map (snd . snd)) $ - CST.parseFromFiles id [(filename, content)] - -- | Load all modules. loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)]) loadAllModules files = do diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index 9c1c13a262..cadd7f62ad 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -15,7 +15,6 @@ module Language.PureScript.Interactive.Types , psciLetBindings , initialPSCiState , initialInteractivePrint - , psciImportedModuleNames , updateImportedModules , updateLoadedExterns , updateLets @@ -109,10 +108,6 @@ psciEnvironment st = foldl' (flip P.applyExternsFileToEnvironment) P.initEnviron -- type ImportedModule = (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName) -psciImportedModuleNames :: PSCiState -> [P.ModuleName] -psciImportedModuleNames st = - map (\(mn, _, _) -> mn) (psciImportedModules st) - -- * State helpers -- This function updates the Imports and Exports values in the PSCiState, which are used for diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index a8b0bfbab8..5e83b290ae 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -2,7 +2,6 @@ module Language.PureScript.Make.BuildPlan ( BuildPlan(bpEnv) , BuildJobResult(..) , buildJobSuccess - , buildJobFailure , construct , getResult , collectResults @@ -65,10 +64,6 @@ buildJobSuccess :: BuildJobResult -> Maybe (MultipleErrors, ExternsFile) buildJobSuccess (BuildJobSucceeded warnings externs) = Just (warnings, externs) buildJobSuccess _ = Nothing -buildJobFailure :: BuildJobResult -> Maybe MultipleErrors -buildJobFailure (BuildJobFailed errors) = Just errors -buildJobFailure _ = Nothing - -- | Information obtained about a particular module while constructing a build -- plan; used to decide whether a module needs rebuilding. data RebuildStatus = RebuildStatus diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index a7c69a21fc..3a483b0ffe 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -17,12 +17,6 @@ import Language.PureScript.CST.Lexer (isUnquotedKey) import Text.PrettyPrint.Boxes hiding ((<>)) import qualified Text.PrettyPrint.Boxes as Box --- | --- Wrap a string in parentheses --- -parens :: String -> String -parens s = "(" <> s <> ")" - parensT :: Text -> Text parensT s = "(" <> s <> ")" @@ -108,9 +102,6 @@ addPos (SourcePos n _) (SourcePos n' m') = SourcePos (n+n') m' data PrinterState = PrinterState { indent :: Int } -emptyPrinterState :: PrinterState -emptyPrinterState = PrinterState { indent = 0 } - -- | -- Number of characters per indentation level -- @@ -135,15 +126,6 @@ currentIndent = do current <- get return $ emit $ T.replicate (indent current) " " --- | --- Print many lines --- -prettyPrintMany :: (Emit gen) => (a -> StateT PrinterState Maybe gen) -> [a] -> StateT PrinterState Maybe gen -prettyPrintMany f xs = do - ss <- mapM f xs - indentString <- currentIndent - return $ intercalate (emit "\n") $ map (mappend indentString) ss - objectKeyRequiresQuoting :: Text -> Bool objectKeyRequiresQuoting = not . isUnquotedKey diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 57500de8aa..f6751649f8 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -10,7 +10,6 @@ module Language.PureScript.Pretty.Types , convertPrettyPrintType , typeAsBox , typeDiffAsBox - , suggestedTypeAsBox , prettyPrintType , prettyPrintTypeWithUnicode , prettyPrintSuggestedType @@ -259,9 +258,6 @@ typeDiffAsBox' = typeAsBoxImpl diffOptions typeDiffAsBox :: Int -> Type a -> Box typeDiffAsBox maxDepth = typeDiffAsBox' . convertPrettyPrintType maxDepth -suggestedTypeAsBox :: PrettyPrintType -> Box -suggestedTypeAsBox = typeAsBoxImpl suggestingOptions - data TypeRenderOptions = TypeRenderOptions { troSuggesting :: Bool , troUnicode :: Bool diff --git a/src/Language/PureScript/Publish/BoxesHelpers.hs b/src/Language/PureScript/Publish/BoxesHelpers.hs index 0fe2b0f1a7..536e5bf8a7 100644 --- a/src/Language/PureScript/Publish/BoxesHelpers.hs +++ b/src/Language/PureScript/Publish/BoxesHelpers.hs @@ -44,6 +44,3 @@ bulletedListT f = bulletedList (T.unpack . f) printToStderr :: Boxes.Box -> IO () printToStderr = hPutStr stderr . Boxes.render - -printToStdout :: Boxes.Box -> IO () -printToStdout = putStr . Boxes.render diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 4b4085da83..94c84c80b7 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -7,7 +7,6 @@ module Language.PureScript.Publish.ErrorsWarnings , RepositoryFieldError(..) , JSONSource(..) , printError - , printErrorToStdout , renderError , printWarnings , renderWarnings @@ -87,9 +86,6 @@ data OtherError printError :: PackageError -> IO () printError = printToStderr . renderError -printErrorToStdout :: PackageError -> IO () -printErrorToStdout = printToStdout . renderError - renderError :: PackageError -> Box renderError err = case err of diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index bee60e36db..99334fec6a 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -6,7 +6,6 @@ module Language.PureScript.Sugar.BindingGroups ( createBindingGroups , createBindingGroupsModule , collapseBindingGroups - , collapseBindingGroupsModule ) where import Prelude.Compat @@ -44,14 +43,6 @@ createBindingGroupsModule createBindingGroupsModule (Module ss coms name ds exps) = Module ss coms name <$> createBindingGroups name ds <*> pure exps --- | --- Collapse all binding groups in a module to individual declarations --- -collapseBindingGroupsModule :: [Module] -> [Module] -collapseBindingGroupsModule = - fmap $ \(Module ss coms name ds exps) -> - Module ss coms name (collapseBindingGroups ds) exps - createBindingGroups :: forall m . (MonadError MultipleErrors m) diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 96d5cfda80..37bddb3f0f 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -8,8 +8,6 @@ module Language.PureScript.Sugar.Names.Env , Env , primEnv , primExports - , envModuleSourceSpan - , envModuleImports , envModuleExports , ExportMode(..) , exportType @@ -17,7 +15,6 @@ module Language.PureScript.Sugar.Names.Env , exportTypeClass , exportValue , exportValueOp - , getExports , checkImportConflicts ) where @@ -159,18 +156,6 @@ nullExports = Exports M.empty M.empty M.empty M.empty M.empty -- type Env = M.Map ModuleName (SourceSpan, Imports, Exports) --- | --- Extracts the 'SourceSpan' from an 'Env' value. --- -envModuleSourceSpan :: (SourceSpan, a, b) -> SourceSpan -envModuleSourceSpan (ss, _, _) = ss - --- | --- Extracts the 'Imports' from an 'Env' value. --- -envModuleImports :: (a, Imports, b) -> Imports -envModuleImports (_, imps, _) = imps - -- | -- Extracts the 'Exports' from an 'Env' value. -- @@ -466,16 +451,6 @@ throwExportConflict' ss new existing newName existingName = throwError . errorMessage' ss $ ExportConflict (Qualified (Just new) newName) (Qualified (Just existing) existingName) --- | --- Gets the exports for a module, or raise an error if the module doesn't exist. --- -getExports :: MonadError MultipleErrors m => Env -> ModuleName -> m Exports -getExports env mn = - maybe - (throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn) - (return . envModuleExports) - $ M.lookup mn env - -- | -- When reading a value from the imports, check that there are no conflicts in -- scope. diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index e9ae0a64ef..efa3e6e865 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -310,26 +310,15 @@ putEnv env = modify (\s -> s { checkEnv = env }) modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m () modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) }) --- | Run a computation in the typechecking monad, starting with an empty @Environment@ -runCheck :: (Functor m) => StateT CheckState m a -> m (a, Environment) -runCheck = runCheck' (emptyCheckState initEnvironment) - -- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@. -runCheck' :: (Functor m) => CheckState -> StateT CheckState m a -> m (a, Environment) -runCheck' st check = second checkEnv <$> runStateT check st +runCheck :: (Functor m) => CheckState -> StateT CheckState m a -> m (a, Environment) +runCheck st check = second checkEnv <$> runStateT check st -- | Make an assertion, failing with an error message guardWith :: (MonadError e m) => e -> Bool -> m () guardWith _ True = return () guardWith e False = throwError e --- | Run a computation in the substitution monad, generating a return value and the final substitution. -captureSubstitution - :: MonadState CheckState m - => m a - -> m (a, Substitution) -captureSubstitution = capturingSubstitution (,) - capturingSubstitution :: MonadState CheckState m => (a -> Substitution -> b) diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index dcbc344e77..a93bd96f85 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -33,7 +33,7 @@ checkInEnvironment env st = . runExcept . evalWriterT . P.evalSupplyT 0 - . TC.runCheck' (st { TC.checkEnv = env }) + . TC.runCheck (st { TC.checkEnv = env }) evalWriterT :: Monad m => WriterT b m r -> m r evalWriterT m = fmap fst (runWriterT m) diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs index c0c320876c..d8704ed78a 100644 --- a/tests/Language/PureScript/Ide/CompletionSpec.hs +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -2,7 +2,6 @@ module Language.PureScript.Ide.CompletionSpec where import Protolude -import qualified Data.Set as Set import qualified Language.PureScript as P import Language.PureScript.Ide.Test as Test import Language.PureScript.Ide.Command as Command @@ -10,7 +9,6 @@ import Language.PureScript.Ide.Completion import qualified Language.PureScript.Ide.Filter.Declaration as DeclarationType import Language.PureScript.Ide.Types import Test.Hspec -import System.FilePath reexportMatches :: [Match IdeDeclarationAnn] reexportMatches = @@ -29,9 +27,6 @@ typ txt = Type txt [] Nothing load :: [Text] -> Command load = LoadSync . map Test.mn -rebuildSync :: FilePath -> Command -rebuildSync fp = RebuildSync ("src" fp) Nothing (Set.singleton P.JS) - spec :: Spec spec = describe "Applying completion options" $ do it "keeps all matches if maxResults is not specified" $ do diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 3852dbc094..a34131825a 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -9,13 +9,11 @@ import Language.PureScript.Ide.Types import Language.PureScript.Ide.Test import Test.Hspec -span0, span1, span2 :: P.SourceSpan -span0 = P.SourceSpan "ModuleLevel" (P.SourcePos 0 0) (P.SourcePos 1 1) +span1, span2 :: P.SourceSpan span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2) span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3) -ann0, ann1, ann2 :: P.SourceAnn -ann0 = (span0, []) +ann1, ann2 :: P.SourceAnn ann1 = (span1, []) ann2 = (span2, []) diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index e620b38e20..923bc38bf8 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -43,19 +43,12 @@ volatileState s ds = vs = IdeVolatileState (AstData Map.empty) (Map.fromList decls) Nothing decls = map (first P.moduleNameFromString) ds --- | Adding Annotations to IdeDeclarations -ann :: IdeDeclarationAnn -> Annotation -> IdeDeclarationAnn -ann (IdeDeclarationAnn _ d) a = IdeDeclarationAnn a d - annLoc :: IdeDeclarationAnn -> P.SourceSpan -> IdeDeclarationAnn annLoc (IdeDeclarationAnn a d) loc = IdeDeclarationAnn a {_annLocation = Just loc} d annExp :: IdeDeclarationAnn -> Text -> IdeDeclarationAnn annExp (IdeDeclarationAnn a d) e = IdeDeclarationAnn a {_annExportedFrom = Just (mn e)} d -annTyp :: IdeDeclarationAnn -> P.SourceType -> IdeDeclarationAnn -annTyp (IdeDeclarationAnn a d) ta = IdeDeclarationAnn a {_annTypeAnnotation = Just ta} d - ida :: IdeDeclaration -> IdeDeclarationAnn ida = IdeDeclarationAnn emptyAnn diff --git a/tests/TestMake.hs b/tests/TestMake.hs index c4d811e1ac..1d3268a95f 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -31,13 +31,11 @@ import Test.Hspec utcMidnightOnDate :: Integer -> Int -> Int -> UTCTime utcMidnightOnDate year month day = UTCTime (fromGregorian year month day) (secondsToDiffTime 0) -timestampA, timestampB, timestampC, timestampD, timestampE, timestampF :: UTCTime +timestampA, timestampB, timestampC, timestampD :: UTCTime timestampA = utcMidnightOnDate 2019 1 1 timestampB = utcMidnightOnDate 2019 1 2 timestampC = utcMidnightOnDate 2019 1 3 timestampD = utcMidnightOnDate 2019 1 4 -timestampE = utcMidnightOnDate 2019 1 5 -timestampF = utcMidnightOnDate 2019 1 6 spec :: Spec spec = do diff --git a/weeder.dhall b/weeder.dhall new file mode 100644 index 0000000000..18d6883d85 --- /dev/null +++ b/weeder.dhall @@ -0,0 +1,34 @@ +{ roots = + [ "^Main\\.main$" + , "^PscIdeSpec\\.main$" + + -- These declarations are used in Pursuit. (The Types declarations are + -- reexported in the L.P.Docs module, and referenced from there, but Weeder + -- isn't that smart.) + , "^Language\\.PureScript\\.Docs\\.AsHtml\\.packageAsHtml$" + , "^Language\\.PureScript\\.Docs\\.Types\\.asUploadedPackage$" + , "^Language\\.PureScript\\.Docs\\.Types\\.getLink$" + , "^Language\\.PureScript\\.Docs\\.Types\\.getLinksContext$" + , "^Language\\.PureScript\\.Docs\\.Types\\.packageName$" + , "^Language\\.PureScript\\.Docs\\.Types\\.verifyPackage$" + + -- These declarations are believed to be used in other projects that we want + -- to continue to support. + , "^Language\\.PureScript\\.CoreFn\\.FromJSON\\.moduleFromJSON$" + , "^Language\\.PureScript\\.CST\\.Print\\.printModule$" + + -- These declarations are there to be used during development or testing. + , "^Language\\.PureScript\\.Ide\\.Imports\\.parseImport$" + , "^Language\\.PureScript\\.TypeChecker\\.Monad\\.debug" + + -- These declarations are unprincipled exceptions that we don't mind + -- supporting just in case they're used now or in the future. + , "^Language\\.PureScript\\.CST\\.Parser\\.parseExpr$" + + -- These declarations are generated by tools; it doesn't matter if they're + -- unused because we can't do anything about them. + , "^Language\\.PureScript\\.CST\\.Parser\\.happy" + , "^Paths_purescript(_cst)?\\." + ] +, type-class-roots = True +} From 6986faa034e4860fc08cc646137f4a7498b94ff8 Mon Sep 17 00:00:00 2001 From: Nick Scheel <11701520+MonoidMusician@users.noreply.github.com> Date: Tue, 13 Jul 2021 20:44:30 -0500 Subject: [PATCH 1374/1580] Solve union constraints backwards (#3720) The union solver for `Union l r u` was missing the case when `r` and `u` are literals (which should solve, according to the fundeps, and indeed is possible to solve). --- CHANGELOG.d/fix_solve_union_backwards.md | 2 ++ .../PureScript/TypeChecker/Entailment.hs | 36 +++++++++++++++---- tests/purs/passing/RowUnion.purs | 14 ++++++++ 3 files changed, 46 insertions(+), 6 deletions(-) create mode 100644 CHANGELOG.d/fix_solve_union_backwards.md diff --git a/CHANGELOG.d/fix_solve_union_backwards.md b/CHANGELOG.d/fix_solve_union_backwards.md new file mode 100644 index 0000000000..fd0f092cbc --- /dev/null +++ b/CHANGELOG.d/fix_solve_union_backwards.md @@ -0,0 +1,2 @@ +* Solve `Prim.Row.Union left right all` constraint for `left` when `all` and `right` are already closed rows, + reflecting the existing functional dependency `all right -> left` diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index eb338a018c..abdd8f77b9 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -21,7 +21,7 @@ import Control.Monad.Writer import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.Functor (($>)) -import Data.List (findIndices, minimumBy, groupBy, nubBy, sortOn) +import Data.List (findIndices, minimumBy, groupBy, nubBy, sortOn, delete) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -481,19 +481,42 @@ entails SolverOptions{..} constraint context hints = solveUnion _ _ = Nothing -- | Left biased union of two row types + unionRows :: [SourceType] -> SourceType -> SourceType -> SourceType -> Maybe (SourceType, SourceType, SourceType, Maybe [SourceConstraint], [(Text, SourceType)]) - unionRows kinds l r _ = - guard canMakeProgress $> (l, r, rowFromList out, cons, vars) + unionRows kinds l r u = + guard canMakeProgress $> (lOut, rOut, uOut, cons, vars) where (fixed, rest) = rowToList l rowVar = srcTypeVar "r" - (canMakeProgress, out, cons, vars) = + (canMakeProgress, lOut, rOut, uOut, cons, vars) = case rest of -- If the left hand side is a closed row, then we can merge -- its labels into the right hand side. - REmptyKinded _ _ -> (True, (fixed, r), Nothing, []) + REmptyKinded _ _ -> (True, l, r, rowFromList (fixed, r), Nothing, []) + -- If the right hand side and output are closed rows, then we can + -- compute the left hand side by subtracting the right hand side + -- from the output. + _ | (right, rightu@(REmptyKinded _ _)) <- rowToList r + , (output, restu@(REmptyKinded _ _)) <- rowToList u -> + let + -- Partition the output rows into those that belong in right + -- (taken off the end) and those that must end up in left. + grabLabel e (left', right', remaining) + | rowListLabel e `elem` remaining = + (left', e : right', delete (rowListLabel e) remaining) + | otherwise = + (e : left', right', remaining) + (outL, outR, leftover) = + foldr grabLabel ([], [], fmap rowListLabel right) output + in ( null leftover + , rowFromList (outL, restu) + , rowFromList (outR, rightu) + , u + , Nothing + , [] + ) -- If the left hand side is not definitely closed, then the only way we -- can safely make progress is to move any known labels from the left -- input into the output, and add a constraint for any remaining labels. @@ -501,7 +524,8 @@ entails SolverOptions{..} constraint context hints = -- the right hand side, and we can't be certain we won't reorder the -- types for such labels. _ -> ( not (null fixed) - , (fixed, rowVar) + , l, r + , rowFromList (fixed, rowVar) , Just [ srcConstraint C.RowUnion kinds [rest, r, rowVar] Nothing ] , [("r", kindRow (head kinds))] ) diff --git a/tests/purs/passing/RowUnion.purs b/tests/purs/passing/RowUnion.purs index 2b921f2037..ca443299f6 100644 --- a/tests/purs/passing/RowUnion.purs +++ b/tests/purs/passing/RowUnion.purs @@ -5,6 +5,20 @@ import Prim.Row import Effect import Effect.Console +data Proxy a = Proxy + +solve :: forall l r u. Union l r u => Proxy r -> Proxy u -> Proxy l +solve _ _ = Proxy + +solveUnionBackwardsNil :: Proxy _ +solveUnionBackwardsNil = solve (Proxy :: Proxy ()) (Proxy :: Proxy ()) + +solveUnionBackwardsCons :: Proxy _ +solveUnionBackwardsCons = solve (Proxy :: Proxy ( a :: Int )) (Proxy :: Proxy ( a :: Int, b :: String )) + +solveUnionBackwardsDblCons :: Proxy _ +solveUnionBackwardsDblCons = solve (Proxy :: Proxy ( a :: Int, a :: String )) (Proxy :: Proxy ( a :: Boolean, a :: Int, a :: String )) + foreign import merge :: forall r1 r2 r3 . Union r1 r2 r3 From 2b9c7a668ca6520f4847afcf66768a5019be8402 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 16 Jul 2021 06:36:49 -0700 Subject: [PATCH 1375/1580] Omit kind sigs where kind is uninteresting, even when parens are involved (#4137) * Consider redundant parenthesis when checking for "uninteresting" kinds * Test that uninteresting kinds in redundant parens are still not rendered Variants of this include - parens wrapping a singleton `(Type)` / `(Constraint)` - parens wrapping one part of sig `Type -> (Type) -> Type` - parens wrapping the head `(Type) -> Type` - parens wrapping the tail `Type -> (Type -> Type)` ` parens wrapping the whole `(Type -> Type -> Type)` - kind sigs via kind annotation `data Foo (a :: Type) = Foo a` * Create section for explicit kind signatures where parens are involved * Fix typo: add missing space in test error message * Add changelog entry --- ...eresting kind sigs when parens involved.md | 1 + src/Language/PureScript/Docs/Convert.hs | 33 ++++++++++------- tests/TestDocs.hs | 18 +++++++++- tests/purs/docs/src/KindSignatureDocs.purs | 35 +++++++++++++++++++ 4 files changed, 73 insertions(+), 14 deletions(-) create mode 100644 CHANGELOG.d/fix_fix uninteresting kind sigs when parens involved.md diff --git a/CHANGELOG.d/fix_fix uninteresting kind sigs when parens involved.md b/CHANGELOG.d/fix_fix uninteresting kind sigs when parens involved.md new file mode 100644 index 0000000000..93b811288d --- /dev/null +++ b/CHANGELOG.d/fix_fix uninteresting kind sigs when parens involved.md @@ -0,0 +1 @@ +* Account for redundant parens when excluding uninteresting kind sigs from docs diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 306324d6ce..32fbdd9dcf 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -108,17 +108,31 @@ insertValueTypesAndAdjustKinds env m = -- - `Constraint` (class declaration only) -- - `Type -> K` where `K` is an "uninteresting" kind isUninteresting - :: P.KindSignatureFor -> P.Type () -> Bool + :: P.KindSignatureFor -> Type' -> Bool isUninteresting keyword = \case - P.TypeApp _ t1 t2 | t1 == kindFunctionType -> - isUninteresting keyword t2 - x -> - x == kindPrimType || (isClassKeyword && x == kindPrimConstraint) + -- `Type -> ...` + P.TypeApp _ f a | isTypeAppFunctionType f -> isUninteresting keyword a + P.ParensInType _ ty -> isUninteresting keyword ty + x -> isKindPrimType x || (isClassKeyword && isKindPrimConstraint x) where isClassKeyword = case keyword of P.ClassSig -> True _ -> False + isTypeAppFunctionType = \case + P.TypeApp _ f a -> isKindFunction f && isKindPrimType a + P.ParensInType _ ty -> isTypeAppFunctionType ty + _ -> False + + isKindFunction = isTypeConstructor Prim.Function + isKindPrimType = isTypeConstructor Prim.Type + isKindPrimConstraint = isTypeConstructor Prim.Constraint + + isTypeConstructor k = \case + P.TypeConstructor _ k' -> k' == k + P.ParensInType _ ty -> isTypeConstructor k ty + _ -> False + insertInferredKind :: Declaration -> Text -> P.KindSignatureFor -> Declaration insertInferredKind d name keyword = let @@ -138,20 +152,13 @@ insertValueTypesAndAdjustKinds env m = -- changes `forall (k :: Type). k -> ...` -- to `forall k . k -> ...` dropTypeSortAnnotation = \case - P.ForAll sa txt (Just kAnn) rest skol | kAnn == kindPrimType -> + P.ForAll sa txt (Just (P.TypeConstructor _ Prim.Type)) rest skol -> P.ForAll sa txt Nothing (dropTypeSortAnnotation rest) skol rest -> rest Nothing -> err ("type not found: " ++ show key) - -- constants for kind signature-related code - kindPrimType = P.TypeConstructor () Prim.Type - kindPrimFunction = P.TypeConstructor () Prim.Function - kindPrimConstraint = P.TypeConstructor () Prim.Constraint - -- `Type ->` - kindFunctionType = P.TypeApp () kindPrimFunction kindPrimType - err msg = P.internalError ("Docs.Convert.insertValueTypes: " ++ msg) diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index aa03b527f0..4f5d54a089 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -303,7 +303,7 @@ displayAssertionFailure = \case " got `" <> actualTxt <> "`\n" <> "Structure of kind: " <> T.pack (show actualKind) KindSignaturePresent _ decl actualTxt actualKind -> - "the kind signature for " <> decl <> "was not empty.\n" <> + "the kind signature for " <> decl <> " was not empty.\n" <> "got `" <> actualTxt <> "`\n" <> "Structure of kind: " <> T.pack (show actualKind) DocCommentMergeFailure _ decl expected actual -> @@ -780,6 +780,22 @@ testCases = , ShouldNotHaveKindSignature (n "KindSignatureDocs") "CHidden" , ShouldNotHaveKindSignature (n "KindSignatureDocs") "CNothing" + -- Declarations with an explicit kind signature that is wrapped + -- in parenthesis at various points, but which "desugars" so to speak + -- to an uninteresting kind signature should not be displayed. + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataRedundantParenthesis" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "ClassRedundantParenthesis" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataHeadParens" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataTailParens" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataWholeParens" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataSelfParens" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "ClassSelfParens" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataKindAnnotation" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataKindAnnotationWithParens" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "FunctionParens1" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "FunctionParens2" + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "FunctionParens3" + -- Declarations with no explicit kind signatures should be displayed -- if at least one type parameter has a kind other than `Type` -- despite all others having kind `Type`. diff --git a/tests/purs/docs/src/KindSignatureDocs.purs b/tests/purs/docs/src/KindSignatureDocs.purs index 0c76f7de5b..a8a37e4cb3 100644 --- a/tests/purs/docs/src/KindSignatureDocs.purs +++ b/tests/purs/docs/src/KindSignatureDocs.purs @@ -95,6 +95,41 @@ class CNothing ---------- +data DataRedundantParenthesis :: (Type) -> (Type) +data DataRedundantParenthesis a = DataRedundantParenthesis + +class ClassRedundantParenthesis :: (Type) -> (Constraint) +class ClassRedundantParenthesis a + +data DataHeadParens :: (Type) -> Type -> Type +data DataHeadParens a b = DataHeadParens + +data DataTailParens :: Type -> (Type -> Type) +data DataTailParens a b = DataTailParens + +data DataWholeParens :: (Type -> Type -> Type) +data DataWholeParens a b = DataWholeParens + +data DataSelfParens :: (Type) +data DataSelfParens = DataSelfParens + +class ClassSelfParens :: (Constraint) +class ClassSelfParens + +data DataKindAnnotation (a :: Type) = DataKindAnnotation a + +data DataKindAnnotationWithParens (a :: (Type)) = DataKindAnnotationWithParens a + +data FunctionParens1 :: (->) Type Type +data FunctionParens1 a = FunctionParens1 a + +data FunctionParens2 :: ((->) Type) Type +data FunctionParens2 a = FunctionParens2 a + +data FunctionParens3 :: (((->) Type)) Type +data FunctionParens3 a = FunctionParens3 a +---------- + -- | dit data DShown a b f = DShown (f Int) a b From 7767c9fe45d465c8fbe18c85ae2bb62c91822c0d Mon Sep 17 00:00:00 2001 From: Cyril Date: Sat, 17 Jul 2021 23:49:29 +0200 Subject: [PATCH 1376/1580] Add golden tests for self cycles in type class declarations, kind declarations and foreign data type declarations (#4162) * Add golden tests for self cycles in type class declarations * Add golden tests for self cycles in kind declarations * Add golden tests for self cycles in foreign data type declarations * Remove unreachable case in CycleInTypeSynonym errors rendering * Store non empty names lists under cycle error constructors * Add changelog entry --- ...ternal_add-golden-tests-for-self-cycles.md | 1 + src/Language/PureScript/Errors.hs | 30 +++++++++---------- src/Language/PureScript/ModuleDependencies.hs | 2 +- .../PureScript/Sugar/BindingGroups.hs | 9 +++--- src/Language/PureScript/Sugar/TypeClasses.hs | 7 +++-- .../failing/SelfCycleInForeignDataKinds.out | 9 ++++++ .../failing/SelfCycleInForeignDataKinds.purs | 4 +++ .../failing/SelfCycleInKindDeclaration.out | 9 ++++++ .../failing/SelfCycleInKindDeclaration.purs | 5 ++++ .../SelfCycleInTypeClassDeclaration.out | 9 ++++++ .../SelfCycleInTypeClassDeclaration.purs | 4 +++ 11 files changed, 67 insertions(+), 22 deletions(-) create mode 100644 CHANGELOG.d/internal_add-golden-tests-for-self-cycles.md create mode 100644 tests/purs/failing/SelfCycleInForeignDataKinds.out create mode 100644 tests/purs/failing/SelfCycleInForeignDataKinds.purs create mode 100644 tests/purs/failing/SelfCycleInKindDeclaration.out create mode 100644 tests/purs/failing/SelfCycleInKindDeclaration.purs create mode 100644 tests/purs/failing/SelfCycleInTypeClassDeclaration.out create mode 100644 tests/purs/failing/SelfCycleInTypeClassDeclaration.purs diff --git a/CHANGELOG.d/internal_add-golden-tests-for-self-cycles.md b/CHANGELOG.d/internal_add-golden-tests-for-self-cycles.md new file mode 100644 index 0000000000..3d36934765 --- /dev/null +++ b/CHANGELOG.d/internal_add-golden-tests-for-self-cycles.md @@ -0,0 +1 @@ +* Add golden tests for self cycles in type class declarations, kind declarations and foreign data type declarations diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 32c9532524..76c39c9bbc 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -19,6 +19,7 @@ import Data.Foldable (fold) import Data.Functor.Identity (Identity(..)) import Data.List (transpose, nubBy, partition, dropWhileEnd, sortOn) import qualified Data.List.NonEmpty as NEL +import Data.List.NonEmpty (NonEmpty((:|))) import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import qualified Data.Map as M import Data.Ord (Down(..)) @@ -89,10 +90,10 @@ data SimpleErrorMessage | InvalidDoBind | InvalidDoLet | CycleInDeclaration Ident - | CycleInTypeSynonym [ProperName 'TypeName] - | CycleInTypeClassDeclaration [Qualified (ProperName 'ClassName)] - | CycleInKindDeclaration [Qualified (ProperName 'TypeName)] - | CycleInModules [ModuleName] + | CycleInTypeSynonym (NEL.NonEmpty (ProperName 'TypeName)) + | CycleInTypeClassDeclaration (NEL.NonEmpty (Qualified (ProperName 'ClassName))) + | CycleInKindDeclaration (NEL.NonEmpty (Qualified (ProperName 'TypeName))) + | CycleInModules (NEL.NonEmpty ModuleName) | NameIsUndefined Ident | UndefinedTypeVariable (ProperName 'TypeName) | PartiallyAppliedSynonym (Qualified (ProperName 'TypeName)) @@ -773,11 +774,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "The value of " <> markCode (showIdent nm) <> " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = case mns of - [mn] -> + mn :| [] -> line $ "Module " <> markCode (runModuleName mn) <> " imports itself." _ -> paras [ line "There is a cycle in module dependencies in these modules: " - , indent $ paras (map (line . markCode . runModuleName) mns) + , indent $ paras (line . markCode . runModuleName <$> NEL.toList mns) ] renderSimpleErrorMessage (CycleInTypeSynonym names) = paras $ cycleError <> @@ -786,23 +787,22 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] where cycleError = case names of - [] -> pure . line $ "A cycle appears in a set of type synonym definitions." - [pn] -> pure . line $ "A cycle appears in the definition of type synonym " <> markCode (runProperName pn) - _ -> [ line " A cycle appears in a set of type synonym definitions:" - , indent $ line $ "{" <> T.intercalate ", " (map (markCode . runProperName) names) <> "}" - ] - renderSimpleErrorMessage (CycleInTypeClassDeclaration [name]) = + pn :| [] -> pure . line $ "A cycle appears in the definition of type synonym " <> markCode (runProperName pn) + _ -> [ line " A cycle appears in a set of type synonym definitions:" + , indent $ line $ "{" <> T.intercalate ", " (markCode . runProperName <$> NEL.toList names) <> "}" + ] + renderSimpleErrorMessage (CycleInTypeClassDeclaration (name :| [])) = paras [ line $ "A type class '" <> markCode (runProperName (disqualify name)) <> "' may not have itself as a superclass." ] renderSimpleErrorMessage (CycleInTypeClassDeclaration names) = paras [ line "A cycle appears in a set of type class definitions:" - , indent $ line $ "{" <> T.intercalate ", " (map (markCode . runProperName . disqualify) names) <> "}" + , indent $ line $ "{" <> T.intercalate ", " (markCode . runProperName . disqualify <$> NEL.toList names) <> "}" , line "Cycles are disallowed because they can lead to loops in the type checker." ] - renderSimpleErrorMessage (CycleInKindDeclaration [name]) = + renderSimpleErrorMessage (CycleInKindDeclaration (name :| [])) = paras [ line $ "A kind declaration '" <> markCode (runProperName (disqualify name)) <> "' may not refer to itself in its own signature." ] renderSimpleErrorMessage (CycleInKindDeclaration names) = paras [ line "A cycle appears in a set of kind declarations:" - , indent $ line $ "{" <> T.intercalate ", " (map (markCode . runProperName . disqualify) names) <> "}" + , indent $ line $ "{" <> T.intercalate ", " (markCode . runProperName . disqualify <$> NEL.toList names) <> "}" , line "Kind declarations may not refer to themselves in their own signatures." ] renderSimpleErrorMessage (NameIsUndefined ident) = diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index ed915b63d9..909f5046f9 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -83,7 +83,7 @@ toModule (CyclicSCC ms) = Just ms' -> throwError . errorMessage'' (fmap (sigSourceSpan . snd) ms') - $ CycleInModules (map (sigModuleName . snd) ms) + $ CycleInModules (map (sigModuleName . snd) ms') moduleSignature :: Module -> ModuleSignature moduleSignature (Module ss _ mn ds _) = ModuleSignature ss mn (ordNub (mapMaybe usedModules ds)) diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 99334fec6a..3d57bf349c 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -16,6 +16,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Data.Graph import Data.List (intersect, (\\)) +import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty) import Data.Foldable (find) import Data.Maybe (isJust, mapMaybe) import qualified Data.List.NonEmpty as NEL @@ -24,7 +25,7 @@ import qualified Data.Set as S import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Environment -import Language.PureScript.Errors +import Language.PureScript.Errors hiding (nonEmpty) import Language.PureScript.Names import Language.PureScript.Types @@ -232,11 +233,11 @@ toDataBindingGroup -> m Declaration toDataBindingGroup (AcyclicSCC (d, _, _)) = return d toDataBindingGroup (CyclicSCC ds') - | kds@((ss, _):_) <- concatMap (kindDecl . getDecl) ds' = throwError . errorMessage' ss . CycleInKindDeclaration $ fmap snd kds + | Just kds@((ss, _):|_) <- nonEmpty $ concatMap (kindDecl . getDecl) ds' = throwError . errorMessage' ss . CycleInKindDeclaration $ fmap snd kds | not (null typeSynonymCycles) = throwError . MultipleErrors - . fmap (\syns -> ErrorMessage [positionedError . declSourceSpan . getDecl $ head syns] . CycleInTypeSynonym $ fmap (fst . getName) syns) + . fmap (\syns -> ErrorMessage [positionedError . declSourceSpan . getDecl $ NEL.head syns] . CycleInTypeSynonym $ fmap (fst . getName) syns) $ typeSynonymCycles | otherwise = return . DataBindingGroupDeclaration . NEL.fromList $ getDecl <$> ds' where @@ -252,7 +253,7 @@ toDataBindingGroup (CyclicSCC ds') guard . isJust $ isTypeSynonym decl pure (decl, name, filter (maybe False (isJust . isTypeSynonym . getDecl) . lookupVert) deps) - isCycle (CyclicSCC c) = Just c + isCycle (CyclicSCC c) = nonEmpty c isCycle _ = Nothing typeSynonymCycles = diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 5955e2ea73..a21d46fc44 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -16,6 +16,7 @@ import Control.Monad.State import Control.Monad.Supply.Class import Data.Graph import Data.List (find, partition) +import Data.List.NonEmpty (nonEmpty) import qualified Data.Map as M import Data.Maybe (catMaybes, mapMaybe, isJust) import qualified Data.List.NonEmpty as NEL @@ -25,7 +26,7 @@ import Data.Traversable (for) import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.Crash import Language.PureScript.Environment -import Language.PureScript.Errors hiding (isExported) +import Language.PureScript.Errors hiding (isExported, nonEmpty) import Language.PureScript.Externs import Language.PureScript.Label (Label(..)) import Language.PureScript.Names @@ -91,7 +92,9 @@ desugarModule syns kinds (Module ss coms name decls (Just exps)) = do -> SCC Declaration -> Desugar m (Maybe DeclarationRef, [Declaration]) desugarClassDecl name' exps' (AcyclicSCC d) = desugarDecl syns kinds name' exps' d - desugarClassDecl _ _ (CyclicSCC ds') = throwError . errorMessage' (declSourceSpan (head ds')) $ CycleInTypeClassDeclaration (map classDeclName ds') + desugarClassDecl _ _ (CyclicSCC ds') + | Just ds'' <- nonEmpty ds' = throwError . errorMessage' (declSourceSpan (NEL.head ds'')) $ CycleInTypeClassDeclaration (NEL.map classDeclName ds'') + | otherwise = internalError "desugarClassDecl: empty CyclicSCC" superClassesNames :: Declaration -> [Qualified (ProperName 'ClassName)] superClassesNames (TypeClassDeclaration _ _ _ implies _ _) = fmap constraintName implies diff --git a/tests/purs/failing/SelfCycleInForeignDataKinds.out b/tests/purs/failing/SelfCycleInForeignDataKinds.out new file mode 100644 index 0000000000..7bcf09c5ef --- /dev/null +++ b/tests/purs/failing/SelfCycleInForeignDataKinds.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/SelfCycleInForeignDataKinds.purs:4:1 - 4:31 (line 4, column 1 - line 4, column 31) + + A kind declaration 'Foo' may not refer to itself in its own signature. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInKindDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/SelfCycleInForeignDataKinds.purs b/tests/purs/failing/SelfCycleInForeignDataKinds.purs new file mode 100644 index 0000000000..170be42a81 --- /dev/null +++ b/tests/purs/failing/SelfCycleInForeignDataKinds.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith CycleInKindDeclaration +module Main where + +foreign import data Foo :: Foo diff --git a/tests/purs/failing/SelfCycleInKindDeclaration.out b/tests/purs/failing/SelfCycleInKindDeclaration.out new file mode 100644 index 0000000000..ee5a95b15c --- /dev/null +++ b/tests/purs/failing/SelfCycleInKindDeclaration.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/SelfCycleInKindDeclaration.purs:4:1 - 4:24 (line 4, column 1 - line 4, column 24) + + A kind declaration 'Foo' may not refer to itself in its own signature. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInKindDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/SelfCycleInKindDeclaration.purs b/tests/purs/failing/SelfCycleInKindDeclaration.purs new file mode 100644 index 0000000000..39e20da613 --- /dev/null +++ b/tests/purs/failing/SelfCycleInKindDeclaration.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith CycleInKindDeclaration +module Main where + +data Foo :: Foo -> Type +data Foo a = Foo diff --git a/tests/purs/failing/SelfCycleInTypeClassDeclaration.out b/tests/purs/failing/SelfCycleInTypeClassDeclaration.out new file mode 100644 index 0000000000..d8b91a5226 --- /dev/null +++ b/tests/purs/failing/SelfCycleInTypeClassDeclaration.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/SelfCycleInTypeClassDeclaration.purs:4:1 - 4:23 (line 4, column 1 - line 4, column 23) + + A type class 'Foo' may not have itself as a superclass. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInTypeClassDeclaration.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/SelfCycleInTypeClassDeclaration.purs b/tests/purs/failing/SelfCycleInTypeClassDeclaration.purs new file mode 100644 index 0000000000..98153bb5f9 --- /dev/null +++ b/tests/purs/failing/SelfCycleInTypeClassDeclaration.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith CycleInTypeClassDeclaration +module Main where + +class (Foo a) <= Foo a From 4a2cf3ac584173770be4daf515377806bb598062 Mon Sep 17 00:00:00 2001 From: Cyril Date: Sun, 18 Jul 2021 00:04:38 +0200 Subject: [PATCH 1377/1580] Add a hint for errors in foreign data type declarations (#4161) * Add a hint for errors in foreign data type declarations * Add changelog entry --- .../fix_error-in-foreign-import-data-hint.md | 1 + .../src/Language/PureScript/AST/Declarations.hs | 1 + src/Language/PureScript/Errors.hs | 4 ++++ src/Language/PureScript/TypeChecker.hs | 17 +++++++++-------- tests/purs/failing/UnsupportedTypeInKind.out | 1 + 5 files changed, 16 insertions(+), 8 deletions(-) create mode 100644 CHANGELOG.d/fix_error-in-foreign-import-data-hint.md diff --git a/CHANGELOG.d/fix_error-in-foreign-import-data-hint.md b/CHANGELOG.d/fix_error-in-foreign-import-data-hint.md new file mode 100644 index 0000000000..48e3549ee3 --- /dev/null +++ b/CHANGELOG.d/fix_error-in-foreign-import-data-hint.md @@ -0,0 +1 @@ +* Add a hint for errors in foreign data type declarations diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs index 9cc76fd928..ea153e81f8 100644 --- a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs @@ -84,6 +84,7 @@ data ErrorMessageHint | ErrorInKindDeclaration (ProperName 'TypeName) | ErrorInRoleDeclaration (ProperName 'TypeName) | ErrorInForeignImport Ident + | ErrorInForeignImportData (ProperName 'TypeName) | ErrorSolvingConstraint SourceConstraint | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName)) | PositionedError (NEL.NonEmpty SourceSpan) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 76c39c9bbc..b7528c7261 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1492,6 +1492,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ detail , line $ "in foreign import " <> markCode (showIdent nm) ] + renderHint (ErrorInForeignImportData nm) detail = + paras [ detail + , line $ "in foreign data type declaration for " <> markCode (runProperName nm) + ] renderHint (ErrorSolvingConstraint (Constraint _ nm _ ts _)) detail = paras [ detail , line "while solving type class constraint" diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 9125fb30f0..e36bd6261b 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -369,14 +369,15 @@ typeCheckAll moduleName _ = traverse go addValue moduleName name ty nameKind return (sai, nameKind, val) return . BindingGroupDeclaration $ NEL.fromList vals'' - go d@(ExternDataDeclaration _ name kind) = do - elabKind <- withFreshSubstitution $ checkKindDeclaration moduleName kind - env <- getEnv - let qualName = Qualified (Just moduleName) name - -- If there's an explicit role declaration, just trust it - let roles = fromMaybe (nominalRolesForKind elabKind) $ M.lookup qualName (roleDeclarations env) - putEnv $ env { types = M.insert qualName (elabKind, ExternData roles) (types env) } - return d + go d@(ExternDataDeclaration (ss, _) name kind) = do + warnAndRethrow (addHint (ErrorInForeignImportData name) . addHint (positionedError ss)) $ do + elabKind <- withFreshSubstitution $ checkKindDeclaration moduleName kind + env <- getEnv + let qualName = Qualified (Just moduleName) name + -- If there's an explicit role declaration, just trust it + let roles = fromMaybe (nominalRolesForKind elabKind) $ M.lookup qualName (roleDeclarations env) + putEnv $ env { types = M.insert qualName (elabKind, ExternData roles) (types env) } + return d go d@(ExternDeclaration (ss, _) name ty) = do warnAndRethrow (addHint (ErrorInForeignImport name) . addHint (positionedError ss)) $ do env <- getEnv diff --git a/tests/purs/failing/UnsupportedTypeInKind.out b/tests/purs/failing/UnsupportedTypeInKind.out index c26bebaa2c..b811914f36 100644 --- a/tests/purs/failing/UnsupportedTypeInKind.out +++ b/tests/purs/failing/UnsupportedTypeInKind.out @@ -8,6 +8,7 @@ at tests/purs/failing/UnsupportedTypeInKind.purs:7:28 - 7:38 (line 7, column 28 is not supported in kinds. +in foreign data type declaration for Bad See https://github.com/purescript/documentation/blob/master/errors/UnsupportedTypeInKind.md for more information, or to contribute content related to this error. From 7b7c47deef96214720aaa22e524ae3177606382f Mon Sep 17 00:00:00 2001 From: Peter Becich Date: Sat, 17 Jul 2021 15:22:01 -0700 Subject: [PATCH 1378/1580] update Stack in Github Actions (#4134) Co-authored-by: JordanMartinez --- .github/workflows/ci.yml | 4 ++-- CONTRIBUTORS.md | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 3bfa5070da..e33fc6eb44 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -37,7 +37,7 @@ jobs: with: enable-stack: true # If upgrading Stack, also upgrade it in the lint job below - stack-version: "2.5.1" + stack-version: "2.7.1" stack-no-global: true - uses: "actions/cache@v2" @@ -97,7 +97,7 @@ jobs: uses: "haskell/actions/setup@v1" with: enable-stack: true - stack-version: "2.5.1" + stack-version: "2.7.1" stack-no-global: true - uses: "actions/cache@v2" diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 1dd3ff21f9..d1d258b46a 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -94,6 +94,7 @@ If you would prefer to use different terms, please use the section below instead | [@passy](https://github.com/passy) | Pascal Hartig | [MIT license](http://opensource.org/licenses/MIT) | | [@paulyoung](https://github.com/paulyoung) | Paul Young | [MIT license](http://opensource.org/licenses/MIT) | | [@pelotom](https://github.com/pelotom) | Thomas Crockett | [MIT license](http://opensource.org/licenses/MIT) | +| [@peterbecich](https://github.com/peterbecich) | Peter Becich | [MIT license](http://opensource.org/licenses/MIT) | | [@phadej](https://github.com/phadej) | Oleg Grenrus | [MIT license](http://opensource.org/licenses/MIT) | | [@phiggins](https://github.com/phiggins) | Pete Higgins | [MIT license](http://opensource.org/licenses/MIT) | | [@philopon](https://github.com/philopon) | Hirotomo Moriwaki | [MIT license](http://opensource.org/licenses/MIT) | From 9908e622e4bc2fb9efdc8789c3ea7021cf3b4698 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sun, 18 Jul 2021 21:37:22 -0400 Subject: [PATCH 1379/1580] Represent class dictionaries as newtypes (#4125) Class dictionaries are now represented as newtype wrappers of records. This drops the awkward TypeClassDictionaryConstructorApp and TypeClassDictionaryAccessor expressions in favor of regular newtype constructors and record accessors. --- .../internal_typeclasses-are-newtypes.md | 1 + .../Language/PureScript/AST/Declarations.hs | 9 -- .../src/Language/PureScript/AST/Traversals.hs | 7 -- .../src/Language/PureScript/Environment.hs | 14 +-- src/Language/PureScript/CodeGen/JS.hs | 16 +--- src/Language/PureScript/CoreFn/Desugar.hs | 43 ++------- src/Language/PureScript/Externs.hs | 14 +-- src/Language/PureScript/Ide/Externs.hs | 10 +-- src/Language/PureScript/Linter.hs | 2 - src/Language/PureScript/Linter/Exhaustive.hs | 1 - src/Language/PureScript/Pretty/Values.hs | 4 - src/Language/PureScript/Renamer.hs | 1 - src/Language/PureScript/Sugar.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 88 ++++++++++--------- src/Language/PureScript/TypeChecker.hs | 4 +- .../PureScript/TypeChecker/Entailment.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 22 ++++- .../failing/InstanceSigsDifferentTypes.out | 16 ++-- .../failing/InstanceSigsIncorrectType.out | 11 ++- tests/purs/failing/Superclasses1.out | 5 +- tests/purs/failing/Superclasses3.out | 2 +- tests/purs/failing/Superclasses5.out | 15 ++-- 22 files changed, 123 insertions(+), 166 deletions(-) create mode 100644 CHANGELOG.d/internal_typeclasses-are-newtypes.md diff --git a/CHANGELOG.d/internal_typeclasses-are-newtypes.md b/CHANGELOG.d/internal_typeclasses-are-newtypes.md new file mode 100644 index 0000000000..0ca4652e65 --- /dev/null +++ b/CHANGELOG.d/internal_typeclasses-are-newtypes.md @@ -0,0 +1 @@ +* Represent class dictionaries as newtypes diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs index ea153e81f8..aeec4d187e 100644 --- a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs @@ -710,11 +710,6 @@ data Expr -- | Ado (Maybe ModuleName) [DoNotationElement] Expr -- | - -- An application of a typeclass dictionary constructor. The value should be - -- an ObjectLiteral. - -- - | TypeClassDictionaryConstructorApp (Qualified (ProperName 'ClassName)) Expr - -- | -- 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): whether or not to look @@ -725,10 +720,6 @@ data Expr (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))) [ErrorMessageHint] -- | - -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring. - -- - | TypeClassDictionaryAccessor (Qualified (ProperName 'ClassName)) Ident - -- | -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking -- | DeferredDictionary (Qualified (ProperName 'ClassName)) [SourceType] diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Traversals.hs b/lib/purescript-cst/src/Language/PureScript/AST/Traversals.hs index 835aa840a7..7fb29e6d92 100644 --- a/lib/purescript-cst/src/Language/PureScript/AST/Traversals.hs +++ b/lib/purescript-cst/src/Language/PureScript/AST/Traversals.hs @@ -67,7 +67,6 @@ everywhereOnValues f g h = (f', g', h') g' (UnaryMinus ss v) = g (UnaryMinus ss (g' v)) g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2)) g' (Parens v) = g (Parens (g' v)) - g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v)) g' (Accessor prop v) = g (Accessor prop (g' v)) g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (fmap (fmap g') vs)) g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs)) @@ -142,7 +141,6 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (UnaryMinus ss v) = UnaryMinus ss <$> (g v >>= g') g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g') g' (Parens v) = Parens <$> (g v >>= g') - g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g') g' (Accessor prop v) = Accessor prop <$> (g v >>= g') g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (g' <=< g) vs @@ -212,7 +210,6 @@ everywhereOnValuesM f g h = (f', g', h') g' (UnaryMinus ss v) = (UnaryMinus ss <$> g' v) >>= g g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g g' (Parens v) = (Parens <$> g' v) >>= g - g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse g' vs) >>= g @@ -285,7 +282,6 @@ everythingOnValues (<>.) f g h i j = (f', g', h', i', j') g' v@(UnaryMinus _ v1) = g v <>. g' v1 g' v@(BinaryNoParens op v1 v2) = g v <>. g' op <>. g' v1 <>. g' v2 g' v@(Parens v1) = g v <>. g' v1 - g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <>. g' v1 g' v@(Accessor _ v1) = g v <>. g' v1 g' v@(ObjectUpdate obj vs) = foldl (<>.) (g v <>. g' obj) (fmap (g' . snd) vs) g' v@(ObjectUpdateNested obj vs) = foldl (<>.) (g v <>. g' obj) (fmap g' vs) @@ -367,7 +363,6 @@ everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i g' s (UnaryMinus _ v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <>. g'' s v1 <>. g'' s v2 g' s (Parens v1) = g'' s v1 - g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s . snd) vs) g' s (ObjectUpdateNested obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s) vs) @@ -453,7 +448,6 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g' s (UnaryMinus ss v) = UnaryMinus ss <$> g'' s v g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2 g' s (Parens v) = Parens <$> g'' s v - g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v g' s (Accessor prop v) = Accessor prop <$> g'' s v g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (g'' s) vs @@ -547,7 +541,6 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) g' s (UnaryMinus _ v1) = g'' s v1 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2 g' s (Parens v1) = g'' s v1 - g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs g' s (ObjectUpdateNested obj vs) = g'' s obj <> foldMap (g'' s) vs diff --git a/lib/purescript-cst/src/Language/PureScript/Environment.hs b/lib/purescript-cst/src/Language/PureScript/Environment.hs index 9bd9ffcecb..e6227054db 100644 --- a/lib/purescript-cst/src/Language/PureScript/Environment.hs +++ b/lib/purescript-cst/src/Language/PureScript/Environment.hs @@ -341,7 +341,7 @@ primClass name mkKind = [ let k = mkKind kindConstraint in (name, (k, ExternData (nominalRolesForKind k))) , let k = mkKind kindType - in (dictSynonymName <$> name, (k, TypeSynonym)) + in (dictTypeName <$> name, (k, TypeSynonym)) ] -- | The primitive types in the external environment with their @@ -579,14 +579,14 @@ lookupConstructor env ctor = lookupValue :: Environment -> Qualified Ident -> Maybe (SourceType, NameKind, NameVisibility) lookupValue env ident = ident `M.lookup` names env -dictSynonymName' :: Text -> Text -dictSynonymName' = (<> "$Dict") +dictTypeName' :: Text -> Text +dictTypeName' = (<> "$Dict") -dictSynonymName :: ProperName a -> ProperName a -dictSynonymName = ProperName . dictSynonymName' . runProperName +dictTypeName :: ProperName a -> ProperName a +dictTypeName = ProperName . dictTypeName' . runProperName -isDictSynonym :: ProperName a -> Bool -isDictSynonym = T.isSuffixOf "$Dict" . runProperName +isDictTypeName :: ProperName a -> Bool +isDictTypeName = T.isSuffixOf "$Dict" . runProperName -- | -- Given the kind of a type, generate a list @Nominal@ roles. This is used for diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index f3d0253dd6..c01f21eb06 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -161,6 +161,10 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ = -- Generate code in the simplified JavaScript intermediate representation for a declaration -- bindToJs :: Bind Ann -> m [AST] + bindToJs (NonRec (_, _, _, Just IsTypeClassConstructor) _ _) = pure [] + -- Unlike other newtype constructors, type class constructors are only + -- ever applied; it's not possible to use them as values. So it's safe to + -- erase them. bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS) @@ -220,16 +224,6 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ = obj <- valueToJs o sts <- mapM (sndM valueToJs) ps extendObj obj sts - valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = - let args = unAbs e - in return $ AST.Function Nothing Nothing (map identToJs args) (AST.Block Nothing $ map assign args) - where - unAbs :: Expr Ann -> [Ident] - unAbs (Abs _ arg val) = arg : unAbs val - unAbs _ = [] - assign :: Ident -> AST - assign name = AST.Assignment Nothing (accessorString (mkString $ runIdent name) (AST.Var Nothing "this")) - (var name) valueToJs' (Abs _ arg val) = do ret <- valueToJs val let jsArg = case arg of @@ -243,8 +237,6 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ = Var (_, _, _, Just IsNewtype) _ -> return (head args') Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields -> return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args' - Var (_, _, _, Just IsTypeClassConstructor) name -> - return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args' _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToJs f where unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann]) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index f846eafaae..474eed9229 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,12 +1,11 @@ module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where import Prelude.Compat -import Protolude (ordNub) +import Protolude (ordNub, orEmpty) import Control.Arrow (second) import Data.Function (on) -import Data.List (sort, sortOn) import Data.Maybe (mapMaybe) import Data.Tuple (swap) import qualified Data.List.NonEmpty as NEL @@ -24,9 +23,7 @@ import Language.PureScript.CoreFn.Module import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Names -import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDictionaryNames) import Language.PureScript.Types -import Language.PureScript.PSString (mkString) import qualified Language.PureScript.AST as A import qualified Language.PureScript.Constants.Prim as C @@ -65,8 +62,10 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = -- | Desugars member declarations from AST to CoreFn representation. declToCoreFn :: A.Declaration -> [Bind Ann] declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [ctor]) = - [NonRec (ssA ss) (properToIdent $ A.dataCtorName ctor) $ + [NonRec (ss, [], Nothing, declMeta) (properToIdent $ A.dataCtorName ctor) $ Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ Qualified Nothing (Ident "x"))] + where + declMeta = isDictTypeName (A.dataCtorName ctor) `orEmpty` IsTypeClassConstructor declToCoreFn d@(A.DataDeclaration _ Newtype _ _ _) = error $ "Found newtype with multiple constructors: " ++ show d declToCoreFn (A.DataDeclaration (ss, com) Data tyName _ ctors) = @@ -81,8 +80,6 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] declToCoreFn (A.BindingGroupDeclaration ds) = [Rec . NEL.toList $ fmap (\(((ss, com), name), _, e) -> ((ssA ss, name), exprToCoreFn ss com Nothing e)) ds] - declToCoreFn (A.TypeClassDeclaration sa@(ss, _) name _ supers _ members) = - [NonRec (ssA ss) (properToIdent name) $ mkTypeClassConstructor sa supers members] declToCoreFn _ = [] -- | Desugars expressions from AST to CoreFn representation. @@ -117,15 +114,6 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = exprToCoreFn ss com (Just ty) v exprToCoreFn ss com ty (A.Let w ds v) = Let (ss, com, ty, getLetMeta w) (concatMap declToCoreFn ds) (exprToCoreFn ss [] Nothing v) - exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal _ (A.ObjectLiteral _)) _)) = - exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name lit) - exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal _ (A.ObjectLiteral vs))) = - let args = exprToCoreFn ss [] Nothing . snd <$> sortOn fst vs - ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name) - in foldl (App (ss, com, Nothing, Nothing)) ctor args - exprToCoreFn ss com ty (A.TypeClassDictionaryAccessor _ ident) = - Abs (ss, com, ty, Nothing) (Ident "dict") - (Accessor (ssAnn ss) (mkString $ runIdent ident) (Var (ssAnn ss) $ Qualified Nothing (Ident "dict"))) exprToCoreFn _ com ty (A.PositionedValue ss com1 v) = exprToCoreFn ss (com ++ com1) ty v exprToCoreFn _ _ _ e = @@ -221,10 +209,6 @@ findQualModules decls = fqValues :: A.Expr -> [ModuleName] fqValues (A.Var _ q) = getQual' q fqValues (A.Constructor _ q) = getQual' q - -- Some instances are automatically solved and have their class dictionaries - -- built inline instead of having a named instance defined and imported. - -- We therefore need to import these constructors if they aren't already. - fqValues (A.TypeClassDictionaryConstructorApp c _) = getQual' c fqValues _ = [] fqBinders :: A.Binder -> [ModuleName] @@ -245,32 +229,19 @@ externToCoreFn (A.ExternDeclaration _ name _) = Just name externToCoreFn _ = Nothing -- | Desugars export declarations references from AST to CoreFn representation. --- CoreFn modules only export values, so all data constructors, class --- constructor, instances and values are flattened into one list. +-- CoreFn modules only export values, so all data constructors, instances and +-- values are flattened into one list. exportToCoreFn :: A.DeclarationRef -> [Ident] exportToCoreFn (A.TypeRef _ _ (Just dctors)) = fmap properToIdent dctors exportToCoreFn (A.TypeRef _ _ Nothing) = [] exportToCoreFn (A.TypeOpRef _ _) = [] exportToCoreFn (A.ValueRef _ name) = [name] exportToCoreFn (A.ValueOpRef _ _) = [] -exportToCoreFn (A.TypeClassRef _ name) = [properToIdent name] +exportToCoreFn (A.TypeClassRef _ _) = [] exportToCoreFn (A.TypeInstanceRef _ name _) = [name] exportToCoreFn (A.ModuleRef _ _) = [] exportToCoreFn (A.ReExportRef _ _ _) = [] --- | Makes a typeclass dictionary constructor function. The returned expression --- is a function that accepts the superclass instances and member --- implementations and returns a record for the instance dictionary. -mkTypeClassConstructor :: SourceAnn -> [SourceConstraint] -> [A.Declaration] -> Expr Ann -mkTypeClassConstructor (ss, com) [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral []) -mkTypeClassConstructor (ss, com) supers members = - let args@(a:as) = sort $ fmap typeClassMemberName members ++ superClassDictionaryNames supers - props = [ (mkString arg, Var (ssAnn ss) $ Qualified Nothing (Ident arg)) | arg <- args ] - dict = Literal (ssAnn ss) (ObjectLiteral props) - in Abs (ss, com, Nothing, Just IsTypeClassConstructor) - (Ident a) - (foldr (Abs (ssAnn ss) . Ident) dict as) - -- | Converts a ProperName to an Ident. properToIdent :: ProperName a -> Ident properToIdent = Ident . runProperName diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 9a4d137c70..c10d96c2f4 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -246,14 +246,14 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env = [ EDValue (lookupRenamedIdent ident) ty ] toExternsDeclaration (TypeClassRef _ className) - | let dictName = dictSynonymName . coerceProperName $ className + | let dictName = dictTypeName . coerceProperName $ className , Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env - , Just (kind, ExternData rs) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env - , Just (synKind, TypeSynonym) <- Qualified (Just mn) dictName `M.lookup` types env - , Just (synArgs, synTy) <- Qualified (Just mn) dictName `M.lookup` typeSynonyms env - = [ EDType (coerceProperName className) kind (ExternData rs) - , EDType dictName synKind TypeSynonym - , EDTypeSynonym dictName synArgs synTy + , Just (kind, tk) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env + , Just (dictKind, dictData@(DataType _ _ [(dctor, _)])) <- Qualified (Just mn) dictName `M.lookup` types env + , Just (dty, _, ty, args) <- Qualified (Just mn) dctor `M.lookup` dataConstructors env + = [ EDType (coerceProperName className) kind tk + , EDType dictName dictKind dictData + , EDDataConstructor dctor dty dictName ty args , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies typeClassIsEmpty ] toExternsDeclaration (TypeInstanceRef ss' ident ns) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 1849b764fd..7a67d160d8 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -109,11 +109,11 @@ convertDecl ed = case ed of if isNothing (Text.find (== '$') (edTypeSynonymName^.properNameT)) then Left (SynonymToResolve edTypeSynonymName edTypeSynonymType) else Right Nothing - P.EDDataConstructor{..} -> - Right - (Just - (IdeDeclDataConstructor - (IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType))) + P.EDDataConstructor{..} -> Right do + guard (isNothing (Text.find (== '$') (edDataCtorName^.properNameT))) + Just + (IdeDeclDataConstructor + (IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType)) P.EDValue{..} -> Right (Just (IdeDeclValue (IdeValue edValueName edValueType))) P.EDClass{..} -> diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 77393f69bd..c6559802bd 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -199,7 +199,6 @@ lintUnused (Module modSS _ mn modDecls exports) = go (UnaryMinus _ v1) = go v1 go (BinaryNoParens v0 v1 v2) = go v0 <> go v1 <> go v2 go (Parens v1) = go v1 - go (TypeClassDictionaryConstructorApp _ v1) = go v1 go (Accessor _ v1) = go v1 go (ObjectUpdate obj vs) = mconcat (go obj : map (go . snd) vs) @@ -234,7 +233,6 @@ lintUnused (Module modSS _ mn modDecls exports) = go (Op _ _) = mempty go (Constructor _ _) = mempty go (TypeClassDictionary _ _ _) = mempty - go (TypeClassDictionaryAccessor _ _) = mempty go (DeferredDictionary _ _) = mempty go AnonymousArgument = mempty go (Hole _) = mempty diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 7bb8d587a7..dc4131bda9 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -338,7 +338,6 @@ checkExhaustiveExpr initSS env mn = onExpr initSS onExpr _ (UnaryMinus ss e) = UnaryMinus ss <$> onExpr ss e onExpr _ (Literal ss (ArrayLiteral es)) = Literal ss . ArrayLiteral <$> mapM (onExpr ss) es onExpr _ (Literal ss (ObjectLiteral es)) = Literal ss . ObjectLiteral <$> mapM (sndM (onExpr ss)) es - onExpr ss (TypeClassDictionaryConstructorApp x e) = TypeClassDictionaryConstructorApp x <$> onExpr ss e onExpr ss (Accessor x e) = Accessor x <$> onExpr ss e onExpr ss (ObjectUpdate o es) = ObjectUpdate <$> onExpr ss o <*> mapM (sndM (onExpr ss)) es onExpr ss (Abs x e) = Abs x <$> onExpr ss e diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 6fb59d291b..f911dd7fc5 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -68,8 +68,6 @@ prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintValueAtom (d - 1) o `b prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg prettyPrintValue d (Unused val) = prettyPrintValue d val prettyPrintValue d (Abs arg val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) -prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) = - text (T.unpack (runProperName (disqualify className)) ++ " ") <> prettyPrintValueAtom (d - 1) ps prettyPrintValue d (Case values binders) = (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) // moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders)) @@ -89,8 +87,6 @@ prettyPrintValue d (Ado m els yield) = -- TODO: constraint kind args prettyPrintValue d (TypeClassDictionary (Constraint _ name _ tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map (typeAtomAsBox d) tys prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name)) -prettyPrintValue _ (TypeClassDictionaryAccessor className ident) = - text "#dict-accessor " <> text (T.unpack (runProperName (disqualify className))) <> text "." <> text (T.unpack (showIdent ident)) <> text ">" prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val prettyPrintValue d (Literal _ l) = prettyPrintLiteralValue d l diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index 6a97078636..d9835bb9a1 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -168,7 +168,6 @@ renameInValue (Accessor ann prop v) = Accessor ann prop <$> renameInValue v renameInValue (ObjectUpdate ann obj vs) = ObjectUpdate ann <$> renameInValue obj <*> traverse (\(name, v) -> (name, ) <$> renameInValue v) vs -renameInValue e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = return e renameInValue (Abs ann name v) = newScope $ Abs ann <$> updateScope name <*> renameInValue v renameInValue (App ann v1 v2) = diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 8a41fa7481..19ba1a0700 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -54,7 +54,7 @@ import Language.PureScript.TypeChecker.Synonyms (SynonymMap) -- -- * Rebracket user-defined binary operators -- --- * Introduce type synonyms for type class dictionaries +-- * Introduce newtypes for type class dictionaries and value declarations for instances -- -- * Group mutually recursive value and data declarations into binding groups. -- diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index a21d46fc44..5ea3243e31 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -1,6 +1,6 @@ -- | --- This module implements the desugaring pass which creates type synonyms for type class dictionaries --- and dictionary expressions for type class instances. +-- This module implements the desugaring pass which creates newtypes for type class dictionaries +-- and value declarations for type class instances. -- module Language.PureScript.Sugar.TypeClasses ( desugarTypeClasses @@ -111,7 +111,7 @@ desugarModule _ _ _ = internalError "Exports should have been elaborated in name {- Desugar type class and type class instance declarations -- --- Type classes become type synonyms for their dictionaries, and type instances become dictionary declarations. +-- Type classes become newtypes for their dictionaries, and type instances become dictionary declarations. -- Additional values are generated to access individual members of a dictionary, with the appropriate type. -- -- E.g. the following @@ -139,68 +139,64 @@ desugarModule _ _ _ = internalError "Exports should have been elaborated in name -- -- -- --- type Foo a = { foo :: a -> a } +-- newtype Foo$Dict a = Foo$Dict { foo :: a -> a } -- -- -- this following type is marked as not needing to be checked so a new Abs -- -- is not introduced around the definition in type checking, but when -- -- called the dictionary value is still passed in for the `dict` argument --- foo :: forall a. (Foo a) => a -> a --- foo dict = dict.foo +-- foo :: forall a. (Foo$Dict a) => a -> a +-- foo (Foo$Dict dict) = dict.foo -- --- fooString :: {} -> Foo String --- fooString _ = s ++ s }> +-- fooString :: Foo$Dict String +-- fooString = Foo$Dict { foo: \s -> s ++ s } -- --- fooArray :: forall a. (Foo a) => Foo [a] --- fooArray = +-- fooArray :: forall a. (Foo$Dict a) => Foo$Dict [a] +-- fooArray = Foo$Dict { foo: map foo } -- -- {- Superclasses -} -- -- -- --- type Sub a = { sub :: a --- , "Foo0" :: {} -> Foo a --- } +-- newtype Sub$Dict a = Sub$Dict { sub :: a +-- , "Foo0" :: {} -> Foo$Dict a +-- } -- -- -- As with `foo` above, this type is unchecked at the declaration --- sub :: forall a. (Sub a) => a --- sub dict = dict.sub +-- sub :: forall a. (Sub$Dict a) => a +-- sub (Sub$Dict dict) = dict.sub -- --- subString :: {} -> Sub String --- subString _ = { sub: "", --- , "Foo0": \_ -> --- } +-- subString :: Sub$Dict String +-- subString = Sub$Dict { sub: "", +-- , "Foo0": \_ -> +-- } -- -- and finally as the generated javascript: -- --- function Foo(foo) { --- this.foo = foo; --- }; --- -- var foo = function (dict) { -- return dict.foo; -- }; -- --- var fooString = function (_) { --- return new Foo(function (s) { --- return s + s; --- }); --- }; --- --- var fooArray = function (__dict_Foo_15) { --- return new Foo(map(foo(__dict_Foo_15))); +-- var fooString = { +-- foo: function (s) { +-- return s + s; +-- } -- }; -- --- function Sub(Foo0, sub) { --- this["Foo0"] = Foo0; --- this.sub = sub; +-- var fooArray = function (dictFoo) { +-- return { +-- foo: map(foo(dictFoo)) +-- }; -- }; -- -- var sub = function (dict) { -- return dict.sub; -- }; -- --- var subString = function (_) { --- return new Sub(fooString, ""); +-- var subString = { +-- sub: "", +-- Foo0: function () { +-- return fooString; +-- } -- }; -} desugarDecl @@ -228,7 +224,7 @@ desugarDecl syns kinds mn exps = go return (expRef name' className tys, [d, dictDecl]) go (TypeInstanceDeclaration sa chainId idx name deps className tys (NewtypeInstanceWithDictionary dict)) = do name' <- desugarInstName name - let dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictSynonymName) className)) tys + let dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictTypeName) className)) tys constrainedTy = quantify (foldr srcConstrainedType dictTy deps) d = TypeInstanceDeclaration sa chainId idx (Right name') deps className tys (NewtypeInstanceWithDictionary dict) return (expRef name' className tys, [d, ValueDecl sa name' Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) @@ -284,13 +280,15 @@ typeClassDictionaryDeclaration -> Declaration typeClassDictionaryDeclaration sa name args implies members = let superclassTypes = superClassDictionaryNames implies `zip` - [ function unit (foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictSynonymName) superclass)) tyArgs) + [ function unit (foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictTypeName) superclass)) tyArgs) | (Constraint _ superclass _ tyArgs _) <- implies ] members' = map (first runIdent . memberToNameAndType) members mtys = members' ++ superclassTypes toRowListItem (l, t) = srcRowListItem (Label $ mkString l) t - in TypeSynonymDeclaration sa (coerceProperName $ dictSynonymName name) args (srcTypeApp tyRecord $ rowFromList (map toRowListItem mtys, srcREmpty)) + ctor = DataConstructorDeclaration sa (coerceProperName $ dictTypeName name) + [(Ident "dict", srcTypeApp tyRecord $ rowFromList (map toRowListItem mtys, srcREmpty))] + in DataDeclaration sa Newtype (coerceProperName $ dictTypeName name) args [ctor] typeClassMemberToDictionaryAccessor :: ModuleName @@ -298,11 +296,15 @@ typeClassMemberToDictionaryAccessor -> [(Text, Maybe SourceType)] -> Declaration -> Declaration -typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarationData sa ident ty)) = +typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarationData sa@(ss, _) ident ty)) = let className = Qualified (Just mn) name + dictIdent = Ident "dict" + dictObjIdent = Ident "v" + ctor = ConstructorBinder ss (coerceProperName . dictTypeName <$> className) [VarBinder ss dictObjIdent] + acsr = Accessor (mkString $ runIdent ident) (Var ss (Qualified Nothing dictObjIdent)) in ValueDecl sa ident Private [] [MkUnguarded ( - TypedValue False (TypeClassDictionaryAccessor className ident) $ + TypedValue False (Abs (VarBinder ss dictIdent) (Case [Var ss $ Qualified Nothing dictIdent] [CaseAlternative [ctor] [MkUnguarded acsr]])) $ moveQuantifiersToFront (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty)) )] typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" @@ -354,9 +356,9 @@ typeInstanceDictionaryDeclaration syns kinds sa@(ss, _) name mn deps className t let superclasses = superClassDictionaryNames typeClassSuperclasses `zip` superclassesDicts let props = Literal ss $ ObjectLiteral $ map (first mkString) (members ++ superclasses) - dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictSynonymName) className)) tys + dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictTypeName) className)) tys constrainedTy = quantify (foldr srcConstrainedType dictTy deps) - dict = TypeClassDictionaryConstructorApp className props + dict = App (Constructor ss (fmap (coerceProperName . dictTypeName) className)) props result = ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)] return result diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index e36bd6261b..9f75efd258 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -63,7 +63,7 @@ addDataType moduleName dtype name args dctors ctorKind = do qualName = Qualified (Just moduleName) name hasSig = qualName `M.member` types env putEnv $ env { types = M.insert qualName (ctorKind, DataType dtype args (map (mapDataCtor . fst) dctors)) (types env) } - unless (hasSig || not (containsForAll ctorKind)) $ do + unless (hasSig || isDictTypeName name || not (containsForAll ctorKind)) $ do tell . errorMessage $ MissingKindDeclaration (if dtype == Newtype then NewtypeSig else DataSig) name ctorKind for_ dctors $ \(DataConstructorDeclaration _ dctor fields, polyType) -> warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $ @@ -111,7 +111,7 @@ addTypeSynonym moduleName name args ty kind = do checkTypeSynonyms ty let qualName = Qualified (Just moduleName) name hasSig = qualName `M.member` types env - unless (hasSig || isDictSynonym name || not (containsForAll kind)) $ do + unless (hasSig || not (containsForAll kind)) $ do tell . errorMessage $ MissingKindDeclaration TypeSynonymSig name kind putEnv $ env { types = M.insert qualName (kind, TypeSynonym) (types env) , typeSynonyms = M.insert qualName (args, ty) (typeSynonyms env) } diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index abdd8f77b9..ed9828db24 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -385,7 +385,7 @@ entails SolverOptions{..} constraint context hints = return (useEmptyDict args) mkDictionary (IsSymbolInstance sym) _ = let fields = [ ("reflectSymbol", Abs (VarBinder nullSourceSpan UnusedIdent) (Literal nullSourceSpan (StringLiteral sym))) ] in - return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal nullSourceSpan (ObjectLiteral fields)) + return $ App (Constructor nullSourceSpan (coerceProperName . dictTypeName <$> C.IsSymbol)) (Literal nullSourceSpan (ObjectLiteral fields)) unknownsInAllCoveringSets :: [SourceType] -> S.Set (S.Set Int) -> Bool unknownsInAllCoveringSets tyArgs = all (\s -> any (`S.member` s) unkIndices) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 966ebbe98a..c0c37d042f 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -750,9 +750,6 @@ check' e@(Literal ss (ObjectLiteral ps)) t@(TypeApp _ obj row) | obj == tyRecord ensureNoDuplicateProperties ps ps' <- checkProperties e ps row False return $ TypedValue' True (Literal ss (ObjectLiteral ps')) t -check' (TypeClassDictionaryConstructorApp name ps) t = do - ps' <- tvToExpr <$> check' ps t - return $ TypedValue' True (TypeClassDictionaryConstructorApp name ps') t check' e@(ObjectUpdate obj ps) t@(TypeApp _ o row) | o == tyRecord = do ensureNoDuplicateProperties ps -- We need to be careful to avoid duplicate labels here. @@ -853,7 +850,7 @@ checkFunctionApplication -- ^ The argument expression -> m (SourceType, Expr) -- ^ The result type, and the elaborated term -checkFunctionApplication fn fnTy arg = withErrorMessageHint (ErrorInApplication fn fnTy arg) $ do +checkFunctionApplication fn fnTy arg = withErrorMessageHint' fn (ErrorInApplication fn fnTy arg) $ do subst <- gets checkSubstitution checkFunctionApplication' fn (substituteType subst fnTy) arg @@ -898,3 +895,20 @@ ensureNoDuplicateProperties ps = case ls \\ ordNub ls of l : _ -> throwError . errorMessage $ DuplicateLabel (Label l) Nothing _ -> return () + +-- | Test if this is an internal value to be excluded from error hints +isInternal :: Expr -> Bool +isInternal = \case + PositionedValue _ _ v -> isInternal v + TypedValue _ v _ -> isInternal v + Constructor _ (Qualified _ name) -> isDictTypeName name + _ -> False + +-- | Introduce a hint only if the given expression is not internal +withErrorMessageHint' + :: (MonadState CheckState m, MonadError MultipleErrors m) + => Expr + -> ErrorMessageHint + -> m a + -> m a +withErrorMessageHint' expr = if isInternal expr then const id else withErrorMessageHint diff --git a/tests/purs/failing/InstanceSigsDifferentTypes.out b/tests/purs/failing/InstanceSigsDifferentTypes.out index cbcc24c362..f06904a946 100644 --- a/tests/purs/failing/InstanceSigsDifferentTypes.out +++ b/tests/purs/failing/InstanceSigsDifferentTypes.out @@ -1,20 +1,20 @@ Error found: in module Main -at tests/purs/failing/InstanceSigsDifferentTypes.purs:8:1 - 10:12 (line 8, column 1 - line 10, column 12) +at tests/purs/failing/InstanceSigsDifferentTypes.purs:10:9 - 10:12 (line 10, column 9 - line 10, column 12) Could not match type -   -  Int -   - with type    Number   + with type +   +  Int +   -while checking that type Int - is at least as general as type Number +while checking that type Number + is at least as general as type Int while checking that expression 0.0 - has type Number + has type Int in value declaration fooNumber See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, diff --git a/tests/purs/failing/InstanceSigsIncorrectType.out b/tests/purs/failing/InstanceSigsIncorrectType.out index bd5bc19196..c8779b4aab 100644 --- a/tests/purs/failing/InstanceSigsIncorrectType.out +++ b/tests/purs/failing/InstanceSigsIncorrectType.out @@ -11,12 +11,15 @@ at tests/purs/failing/InstanceSigsIncorrectType.purs:8:1 - 10:13 (line 8, column  Number   -while checking that type Boolean - is at least as general as type Number -while checking that expression true - has type Number +while trying to match type Foo$Dict t0 + with type Foo$Dict Number +while checking that expression Foo$Dict { foo: true +  }  + has type Foo$Dict Number in value declaration fooNumber +where t0 is an unknown type + See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/Superclasses1.out b/tests/purs/failing/Superclasses1.out index 3d43a5ec77..ed16d56c71 100644 --- a/tests/purs/failing/Superclasses1.out +++ b/tests/purs/failing/Superclasses1.out @@ -8,10 +8,11 @@ at tests/purs/failing/Superclasses1.purs:12:1 - 13:17 (line 12, column 1 - line   while checking that expression #dict Su - has type { su :: Number -> Number - }  + has type Su$Dict t0 in value declaration clNumber +where t0 is an unknown type + See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/Superclasses3.out b/tests/purs/failing/Superclasses3.out index d3abf7268a..45a682d7a4 100644 --- a/tests/purs/failing/Superclasses3.out +++ b/tests/purs/failing/Superclasses3.out @@ -13,7 +13,7 @@ while inferring the kind of ( "Foo0" :: Record () -> Foo$Dict b )  while inferring the kind of { "Foo0" :: Record () -> Foo$Dict b }  -in type synonym Bar$Dict +in type constructor Bar$Dict where t0 is an unknown type diff --git a/tests/purs/failing/Superclasses5.out b/tests/purs/failing/Superclasses5.out index b05d814439..2e708648e2 100644 --- a/tests/purs/failing/Superclasses5.out +++ b/tests/purs/failing/Superclasses5.out @@ -10,20 +10,17 @@ at tests/purs/failing/Superclasses5.purs:17:1 - 18:18 (line 17, column 1 - line Alternatively, add a Partial constraint to the type of the enclosing value. while applying a function $__unused - of type Partial => t1 -> t1 + of type Partial => t0 -> t0 to argument case $0 of   [ x ] -> [ su x  ]  -while checking that expression $__unused (case $0 of  -  [ x ] -> [ ... -  ]  -  )  - has type Array a0 +while inferring the type of $__unused (case $0 of  +  [ x ] -> [ ... +  ]  +  )  in value declaration suArray -where a0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - t1 is an unknown type +where t0 is an unknown type See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, or to contribute content related to this error. From 5d0f1a6a93c450add53135e06ed74f98b5a4bc98 Mon Sep 17 00:00:00 2001 From: Cyril Date: Tue, 20 Jul 2021 18:14:25 +0200 Subject: [PATCH 1380/1580] Add support for bundling function declarations (#4044) --- .../fix_bundle-function-declarations.md | 1 + src/Language/PureScript/Bundle.hs | 4 ++++ tests/purs/bundle/FunctionDeclaration.js | 19 +++++++++++++++++++ tests/purs/bundle/FunctionDeclaration.purs | 14 ++++++++++++++ 4 files changed, 38 insertions(+) create mode 100644 CHANGELOG.d/fix_bundle-function-declarations.md create mode 100644 tests/purs/bundle/FunctionDeclaration.js create mode 100644 tests/purs/bundle/FunctionDeclaration.purs diff --git a/CHANGELOG.d/fix_bundle-function-declarations.md b/CHANGELOG.d/fix_bundle-function-declarations.md new file mode 100644 index 0000000000..ce613debd4 --- /dev/null +++ b/CHANGELOG.d/fix_bundle-function-declarations.md @@ -0,0 +1 @@ +* Do not remove bindings referenced in function declarations when bundling diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 734c61da8c..0ab9e79589 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -474,6 +474,10 @@ matchMember stmt , JSIdentifier _ name <- var , JSVarInit _ decl <- varInit = Just (Internal, name, decl) + -- function foo(...args) { body } + | JSFunction a0 jsIdent a1 args a2 body _ <- stmt + , JSIdentName _ name <- jsIdent + = pure (Internal, name, JSFunctionExpression a0 jsIdent a1 args a2 body) -- exports.foo = expr; exports["foo"] = expr; | JSAssignStatement e (JSAssign _) decl _ <- stmt , Just name <- exportsAccessor e diff --git a/tests/purs/bundle/FunctionDeclaration.js b/tests/purs/bundle/FunctionDeclaration.js new file mode 100644 index 0000000000..6d7bfdc1e0 --- /dev/null +++ b/tests/purs/bundle/FunctionDeclaration.js @@ -0,0 +1,19 @@ +"use strict"; + +var foo = 0; + +function bar(foo) { + return foo; +} + +var baz = "Done"; + +function qux() { + return bar(baz); +} + +exports.qux = qux; + +var fs = require('fs'); +var source = fs.readFileSync(__filename, 'utf-8'); +exports.fooIsEliminated = !/^ *var foo/m.test(source); diff --git a/tests/purs/bundle/FunctionDeclaration.purs b/tests/purs/bundle/FunctionDeclaration.purs new file mode 100644 index 0000000000..5d9810c71b --- /dev/null +++ b/tests/purs/bundle/FunctionDeclaration.purs @@ -0,0 +1,14 @@ +module Main (main) where + +import Prelude +import Effect (Effect) +import Effect.Console (log) +import Test.Assert (assert') + +main :: Effect Unit +main = do + assert' "foo" fooIsEliminated + qux >>= log + +foreign import qux :: Effect String +foreign import fooIsEliminated :: Boolean From 05a46be2dfda2031e0d48a15059185582adabb8b Mon Sep 17 00:00:00 2001 From: Thomas Honeyman Date: Sun, 25 Jul 2021 12:49:18 -0400 Subject: [PATCH 1381/1580] Replace Slack links with Discord (#4166) --- CONTRIBUTING.md | 4 ++-- INSTALL.md | 4 +--- README.md | 4 ++-- RELEASE_GUIDE.md | 1 + 4 files changed, 6 insertions(+), 7 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index a3e588c556..0b88492e71 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -5,8 +5,8 @@ When reporting issues, please be aware of the following: * Please use the appropriate issue template if there is one: filling out all of the sections in the template makes it much easier for us to understand what the problem is and how we might want to address it. -* We prefer to reserve the issue tracker in this repository for tasks which involve work on the compiler. If your report or proposal doesn't involve work on the compiler, please open it on the repository where the work would be done. If you're unsure, you can always ask in [the #purescript channel in FP Slack][] or [Discourse][]. -* If you have a question or need help, please ask in [the #purescript channel in FP Slack][] or [Discourse][] instead. +* We prefer to reserve the issue tracker in this repository for tasks which involve work on the compiler. If your report or proposal doesn't involve work on the compiler, please open it on the repository where the work would be done. If you're unsure, you can always ask on [Discord](https://discord.gg/sMqwYUbvz6) or [Discourse](https://discourse.purescript.org). +* If you have a question or need help, please ask on [Discord](https://discord.gg/sMqwYUbvz6) or [Discourse](https://discourse.purescript.org) instead. * When submitting feature proposals, please be aware that we prefer to be conservative about adding things to the language/compiler. A feature proposal is much more likely to be accepted if it includes a clear description of the problem it intends to solve, as well as not only a strong justification for why adding the feature will solve that problem, but also for why any existing features or techniques that could be used to solve that problem are insufficient. We have defined some [Project Values](https://github.com/purescript/governance#project-values) in our organization's governance document; referring to these may help you get a better idea of what is likely to be accepted and what isn't. diff --git a/INSTALL.md b/INSTALL.md index 5d48107750..829ab18c82 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -1,8 +1,6 @@ # Installation information -If you are having difficulty installing the PureScript compiler, feel free to -ask for help! A good place is the #purescript IRC channel on Freenode, the #purescript channel on [FPChat Slack](https://fpchat-invite.herokuapp.com/), or -alternatively Stack Overflow. +If you are having difficulty installing the PureScript compiler, feel free to ask for help! The best places are the [PureScript Discord](https://discord.gg/sMqwYUbvz6) or [PureScript Discourse](https://discourse.purescript.org). ## Requirements diff --git a/README.md b/README.md index a8f7f69583..8cb2772cdf 100644 --- a/README.md +++ b/README.md @@ -19,6 +19,6 @@ A small strongly typed programming language with expressive types that compiles ## Help! -- [#purescript @ FP Slack](https://functionalprogramming.slack.com/) -- [PureScript Language Forum](https://discourse.purescript.org/) +- [PureScript Discord](https://discord.gg/sMqwYUbvz6/) +- [PureScript Discourse](https://discourse.purescript.org/) - [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript) diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md index ec936831af..4b8acb0716 100644 --- a/RELEASE_GUIDE.md +++ b/RELEASE_GUIDE.md @@ -136,5 +136,6 @@ Note: if a release does not go as planned (e.g. [`v0.14.3`](https://github.com/p - Update Try PureScript - Make release announcements: - Discourse + - Discord - Twitter - /r/purescript From 80ad9943d8223880e109ee9d6a1d9d0ad71c4c2c Mon Sep 17 00:00:00 2001 From: Thomas Honeyman Date: Sun, 25 Jul 2021 14:07:36 -0400 Subject: [PATCH 1382/1580] Fix Discord link in README (#4167) --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 8cb2772cdf..0d34002dfa 100644 --- a/README.md +++ b/README.md @@ -19,6 +19,6 @@ A small strongly typed programming language with expressive types that compiles ## Help! -- [PureScript Discord](https://discord.gg/sMqwYUbvz6/) +- [PureScript Discord](https://discord.gg/sMqwYUbvz6) - [PureScript Discourse](https://discourse.purescript.org/) - [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript) From 65213e7aec8548807ea2f6ccf452054b425c39bb Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 26 Jul 2021 01:40:08 -0400 Subject: [PATCH 1383/1580] Improve row type error messages (#4159) * Remove a redundant hint that repeats the types in the error * Correctly diff rows containing duplicate items * Erase kind applications from rows in errors (by default) --- CHANGELOG.d/fix_3701.md | 4 ++ src/Language/PureScript/Errors.hs | 25 ++++++-- src/Language/PureScript/TypeChecker/Unify.hs | 3 +- tests/purs/failing/3701.out | 64 ++++++++++++++++++++ tests/purs/failing/3701.purs | 39 ++++++++++++ tests/purs/failing/3765.out | 19 ++---- tests/purs/failing/DuplicateProperties.out | 11 +--- 7 files changed, 136 insertions(+), 29 deletions(-) create mode 100644 CHANGELOG.d/fix_3701.md create mode 100644 tests/purs/failing/3701.out create mode 100644 tests/purs/failing/3701.purs diff --git a/CHANGELOG.d/fix_3701.md b/CHANGELOG.d/fix_3701.md new file mode 100644 index 0000000000..a8640817a5 --- /dev/null +++ b/CHANGELOG.d/fix_3701.md @@ -0,0 +1,4 @@ +* Improve row type error messages + * Remove a redundant hint that repeats the types in the error + * Correctly diff rows containing duplicate items + * Erase kind applications from rows in errors (by default) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index b7528c7261..3a61b15ef8 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -12,6 +12,7 @@ import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.State.Lazy import Control.Monad.Writer +import Data.Bifunctor (first, second) import Data.Bitraversable (bitraverse) import Data.Char (isSpace) import Data.Either (partitionEithers) @@ -1515,7 +1516,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl ] printRow :: (Int -> Type a -> Box.Box) -> Type a -> Box.Box - printRow f t = markCodeBox $ indent $ f prettyDepth t + printRow f = markCodeBox . indent . f prettyDepth . + if full then id else eraseForAllKindAnnotations . eraseKindApps -- If both rows are not empty, print them as diffs -- If verbose print all rows else only print unique rows @@ -1534,13 +1536,24 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl filterRows :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Type a, Type a) filterRows (s1, r1) (s2, r2) = let sort' = sortOn $ \(RowListItem _ name ty) -> (name, ty) - notElem' s (RowListItem _ name ty) = all (\(RowListItem _ name' ty') -> name /= name' || not (eqType ty ty')) s - unique1 = filter (notElem' s2) s1 - unique2 = filter (notElem' s1) s2 - in ( rowFromList (sort' unique1, r1) - , rowFromList (sort' unique2, r2) + (unique1, unique2) = diffSortedRowLists (sort' s1, sort' s2) + in ( rowFromList (unique1, r1) + , rowFromList (unique2, r2) ) + -- Importantly, this removes exactly the same number of elements from + -- both lists, even if there are repeated (name, ty) keys. It requires + -- the inputs to be sorted but ensures that the outputs remain sorted. + diffSortedRowLists :: ([RowListItem a], [RowListItem a]) -> ([RowListItem a], [RowListItem a]) + diffSortedRowLists = go where + go = \case + (s1@(h1@(RowListItem _ name1 ty1) : t1), s2@(h2@(RowListItem _ name2 ty2) : t2)) -> + case (name1, ty1) `compare` (name2, ty2) of + EQ -> go (t1, t2) + LT -> first (h1:) $ go (t1, s2) + GT -> second (h2:) $ go (s1, t2) + other -> other + renderContext :: Context -> [Box.Box] renderContext [] = [] renderContext ctx = diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index cbf7076693..5dc9b3ff7f 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -175,8 +175,7 @@ unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where solveType u1 (rowFromList (sd2, rest')) solveType u2 (rowFromList (sd1, rest')) unifyTails _ _ = - withErrorMessageHint (ErrorUnifyingTypes r1 r2) $ - throwError . errorMessage $ TypesDoNotUnify r1 r2 + throwError . errorMessage $ TypesDoNotUnify r1 r2 -- | -- Replace type wildcards with unknowns diff --git a/tests/purs/failing/3701.out b/tests/purs/failing/3701.out new file mode 100644 index 0000000000..cee399f617 --- /dev/null +++ b/tests/purs/failing/3701.out @@ -0,0 +1,64 @@ +Error found: +in module Main +at tests/purs/failing/3701.purs:39:8 - 39:34 (line 39, column 8 - line 39, column 34) + + Could not match type +   +  ( ... ) +   + with type +   +  ( thing1 :: String +  ...  +  )  +   + +while solving type class constraint +  + Prim.Row.Nub ( thing1 :: String + , thing1 :: String + , thing2 :: Int  + )  + ( thing1 :: String + , thing1 :: String + , thing2 :: Int  + )  +  +while applying a function fooMerge + of type Union @Type t0  +  ( thing1 :: String  +  , thing2 :: Int  +  )  +  ( thing1 :: String  +  , thing2 :: Int  +  | t0  +  )  +  => Nub @Type  +  ( thing1 :: String  +  , thing2 :: Int  +  | t0  +  )  +  ( thing1 :: String  +  , thing2 :: Int  +  | t0  +  )  +  => Record t0  +  -> { thing1 :: String +  , thing2 :: Int  +  | t0  +  }  + to argument { thing1: "foo" + }  +while checking that expression fooMerge { thing1: "foo" +  }  + has type { thing1 :: String + , thing1 :: String + , thing2 :: Int  + }  +in value declaration foo2 + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3701.purs b/tests/purs/failing/3701.purs new file mode 100644 index 0000000000..7ab525c55a --- /dev/null +++ b/tests/purs/failing/3701.purs @@ -0,0 +1,39 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prim.Row as Row + +merge + :: forall r1 r2 r3 r4 + . Row.Union r1 r2 r3 + => Row.Nub r3 r4 + => Record r1 + -> Record r2 + -> Record r4 +merge r = merge r + + +type FooRow r = + ( thing1 :: String + , thing2 :: Int + | r + ) + +type AddedRow = + ( thing3 :: String ) + +type AddedRow2 = + ( thing1 :: String ) + +fooMerge :: forall addedRow. + Row.Union addedRow (FooRow ()) (FooRow addedRow) => + Row.Nub (FooRow addedRow) (FooRow addedRow) => + Record addedRow -> + Record (FooRow addedRow) +fooMerge addedRow = merge addedRow {thing1: "foo", thing2: 1} + +foo1 :: Record (FooRow (AddedRow)) +foo1 = fooMerge { thing3: "foo" } + +foo2 :: Record (FooRow (AddedRow2)) +foo2 = fooMerge { thing1: "foo" } diff --git a/tests/purs/failing/3765.out b/tests/purs/failing/3765.out index ea35862c0b..1ae4deb72f 100644 --- a/tests/purs/failing/3765.out +++ b/tests/purs/failing/3765.out @@ -17,25 +17,18 @@ at tests/purs/failing/3765.purs:6:23 - 6:24 (line 6, column 23 - line 6, column  )    -while trying to match type   -  ( b :: Int -  ...  -  | t0  -  )  -   - with type   -  ( a :: Int -  ...  -  | t0  -  )  -   +while trying to match type { b :: Int + | t0  + }  + with type t1 while checking that expression x has type { b :: Int | t0  }  in value declaration mkTricky -where t0 is an unknown type +where t1 is an unknown type + t0 is an unknown type See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/DuplicateProperties.out b/tests/purs/failing/DuplicateProperties.out index 6ed0c05e2f..fb826e01aa 100644 --- a/tests/purs/failing/DuplicateProperties.out +++ b/tests/purs/failing/DuplicateProperties.out @@ -16,17 +16,11 @@ at tests/purs/failing/DuplicateProperties.purs:12:18 - 12:32 (line 12, column 18  )    -while trying to match type   -  ( y :: Unit -  ...  -  )  -   - with type   +while trying to match type Test t1 + with type Test   ( x :: Unit -  ...   | t0   )  -   while checking that expression subtractX hasX has type Test   ( x :: Unit @@ -35,6 +29,7 @@ while checking that expression subtractX hasX in value declaration baz where t0 is an unknown type + t1 is an unknown type See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, or to contribute content related to this error. From 1835443ca2883633a6be5773f4063e5143fc8a46 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 26 Jul 2021 01:40:39 -0400 Subject: [PATCH 1384/1580] Defer synonym expansion from type class desugaring (#4164) Instead of expanding type synonyms when type classes are desugared into their more primitive representation, we leave them in place and expand them when constraints are solved by the type checker instead. --- CHANGELOG.d/fix_4101.md | 3 ++ src/Language/PureScript/Sugar.hs | 4 +- src/Language/PureScript/Sugar/TypeClasses.hs | 37 +++++++------------ .../PureScript/TypeChecker/Entailment.hs | 3 +- tests/purs/passing/4101.purs | 20 ++++++++++ tests/purs/passing/4101/Lib.purs | 9 +++++ 6 files changed, 49 insertions(+), 27 deletions(-) create mode 100644 CHANGELOG.d/fix_4101.md create mode 100644 tests/purs/passing/4101.purs create mode 100644 tests/purs/passing/4101/Lib.purs diff --git a/CHANGELOG.d/fix_4101.md b/CHANGELOG.d/fix_4101.md new file mode 100644 index 0000000000..65cc23b504 --- /dev/null +++ b/CHANGELOG.d/fix_4101.md @@ -0,0 +1,3 @@ +* Fix bad interaction between superclasses and type synonyms + + See #4101. diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 19ba1a0700..52a33486b6 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -84,8 +84,8 @@ desugar externs = -- We cannot prevent ill-kinded expansions of type synonyms without -- knowing their kinds but they're not available yet. kinds = mempty - in deriveInstances externs syns kinds m - >>= desugarTypeClasses externs syns kinds) + in deriveInstances externs syns kinds m) + >=> desugarTypeClasses externs >=> createBindingGroupsModule findTypeSynonyms :: [ExternsFile] -> ModuleName -> [Declaration] -> SynonymMap diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 5ea3243e31..a5b5b59e2f 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -32,7 +32,6 @@ import Language.PureScript.Label (Label(..)) import Language.PureScript.Names import Language.PureScript.PSString (mkString) import Language.PureScript.Sugar.CaseDeclarations -import Language.PureScript.TypeChecker.Synonyms (SynonymMap, KindMap, replaceAllTypeSynonymsM) import Language.PureScript.TypeClassDictionaries (superclassName) import Language.PureScript.Types @@ -47,11 +46,9 @@ type Desugar = StateT MemberMap desugarTypeClasses :: (MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] - -> SynonymMap - -> KindMap -> Module -> m Module -desugarTypeClasses externs syns kinds = flip evalStateT initialState . desugarModule syns kinds +desugarTypeClasses externs = flip evalStateT initialState . desugarModule where initialState :: MemberMap initialState = @@ -75,15 +72,13 @@ desugarTypeClasses externs syns kinds = flip evalStateT initialState . desugarMo desugarModule :: (MonadSupply m, MonadError MultipleErrors m) - => SynonymMap - -> KindMap - -> Module + => Module -> Desugar m Module -desugarModule syns kinds (Module ss coms name decls (Just exps)) = do +desugarModule (Module ss coms name decls (Just exps)) = do let (classDecls, restDecls) = partition isTypeClassDecl decls classVerts = fmap (\d -> (d, classDeclName d, superClassesNames d)) classDecls (classNewExpss, classDeclss) <- unzip <$> parU (stronglyConnComp classVerts) (desugarClassDecl name exps) - (restNewExpss, restDeclss) <- unzip <$> parU restDecls (desugarDecl syns kinds name exps) + (restNewExpss, restDeclss) <- unzip <$> parU restDecls (desugarDecl name exps) return $ Module ss coms name (concat restDeclss ++ concat classDeclss) $ Just (exps ++ catMaybes restNewExpss ++ catMaybes classNewExpss) where desugarClassDecl :: (MonadSupply m, MonadError MultipleErrors m) @@ -91,7 +86,7 @@ desugarModule syns kinds (Module ss coms name decls (Just exps)) = do -> [DeclarationRef] -> SCC Declaration -> Desugar m (Maybe DeclarationRef, [Declaration]) - desugarClassDecl name' exps' (AcyclicSCC d) = desugarDecl syns kinds name' exps' d + desugarClassDecl name' exps' (AcyclicSCC d) = desugarDecl name' exps' d desugarClassDecl _ _ (CyclicSCC ds') | Just ds'' <- nonEmpty ds' = throwError . errorMessage' (declSourceSpan (NEL.head ds'')) $ CycleInTypeClassDeclaration (NEL.map classDeclName ds'') | otherwise = internalError "desugarClassDecl: empty CyclicSCC" @@ -107,7 +102,7 @@ desugarModule syns kinds (Module ss coms name decls (Just exps)) = do classDeclName (TypeClassDeclaration _ pn _ _ _ _) = Qualified (Just name) pn classDeclName _ = internalError "Expected TypeClassDeclaration" -desugarModule _ _ _ = internalError "Exports should have been elaborated in name desugaring" +desugarModule _ = internalError "Exports should have been elaborated in name desugaring" {- Desugar type class and type class instance declarations -- @@ -201,13 +196,11 @@ desugarModule _ _ _ = internalError "Exports should have been elaborated in name -} desugarDecl :: (MonadSupply m, MonadError MultipleErrors m) - => SynonymMap - -> KindMap - -> ModuleName + => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration]) -desugarDecl syns kinds mn exps = go +desugarDecl mn exps = go where go d@(TypeClassDeclaration sa name args implies deps members) = do modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False)) @@ -219,7 +212,7 @@ desugarDecl syns kinds mn exps = go | otherwise = do desugared <- desugarCases members name' <- desugarInstName name - dictDecl <- typeInstanceDictionaryDeclaration syns kinds sa name' mn deps className tys desugared + dictDecl <- typeInstanceDictionaryDeclaration sa name' mn deps className tys desugared let d = TypeInstanceDeclaration sa chainId idx (Right name') deps className tys (ExplicitInstance members) return (expRef name' className tys, [d, dictDecl]) go (TypeInstanceDeclaration sa chainId idx name deps className tys (NewtypeInstanceWithDictionary dict)) = do @@ -314,10 +307,8 @@ unit = srcTypeApp tyRecord srcREmpty typeInstanceDictionaryDeclaration :: forall m - . (MonadSupply m, MonadError MultipleErrors m) - => SynonymMap - -> KindMap - -> SourceAnn + . MonadError MultipleErrors m + => SourceAnn -> Ident -> ModuleName -> [SourceConstraint] @@ -325,7 +316,7 @@ typeInstanceDictionaryDeclaration -> [SourceType] -> [Declaration] -> Desugar m Declaration -typeInstanceDictionaryDeclaration syns kinds sa@(ss, _) name mn deps className tys decls = +typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = rethrow (addHint (ErrorInInstance className tys)) $ do m <- get @@ -348,10 +339,8 @@ typeInstanceDictionaryDeclaration syns kinds sa@(ss, _) name mn deps className t -- Create the type of the dictionary -- The type is a record type, but depending on type instance dependencies, may be constrained. -- The dictionary itself is a record literal. - tys' <- traverse (replaceAllTypeSynonymsM syns kinds) tys superclassesDicts <- for typeClassSuperclasses $ \(Constraint _ superclass _ suTyArgs _) -> do - suTyArgs' <- traverse (replaceAllTypeSynonymsM syns kinds) suTyArgs - let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys')) suTyArgs' + let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs pure $ Abs (VarBinder ss UnusedIdent) (DeferredDictionary superclass tyArgs) let superclasses = superClassDictionaryNames typeClassSuperclasses `zip` superclassesDicts diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index ed9828db24..22df3f882e 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -38,6 +38,7 @@ import Language.PureScript.Names import Language.PureScript.TypeChecker.Entailment.Coercible import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds') import Language.PureScript.TypeChecker.Monad +import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types @@ -161,7 +162,7 @@ entails -- ^ Error message hints to apply to any instance errors -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr entails SolverOptions{..} constraint context hints = - solve constraint + overConstraintArgsAll (lift . lift . traverse replaceAllTypeSynonyms) constraint >>= solve where forClassNameM :: Environment -> InstanceContext -> Qualified (ProperName 'ClassName) -> [SourceType] -> [SourceType] -> m [TypeClassDict] forClassNameM env ctx cn@C.Coercible kinds args = diff --git a/tests/purs/passing/4101.purs b/tests/purs/passing/4101.purs new file mode 100644 index 0000000000..41ffc77c7d --- /dev/null +++ b/tests/purs/passing/4101.purs @@ -0,0 +1,20 @@ +module Main where + +import Effect.Console (log) + +import Lib + +class ClassA :: Type -> Type -> Constraint +class ClassA t a + +class ClassB :: Type -> Type -> Constraint +class ClassA t a <= ClassB t a + +data VariantF :: (Type -> Type) -> Type +data VariantF fs +data Expr + +instance a :: ClassA Expr (VariantF UNIT) +instance b :: ClassB Expr (VariantF UNIT) + +main = log "Done" diff --git a/tests/purs/passing/4101/Lib.purs b/tests/purs/passing/4101/Lib.purs new file mode 100644 index 0000000000..fc5f850e7d --- /dev/null +++ b/tests/purs/passing/4101/Lib.purs @@ -0,0 +1,9 @@ +module Lib where + +newtype Const :: forall k. Type -> k -> Type +newtype Const a b = Const a + +data Unit = Unit + +type CONST = Const +type UNIT = CONST Unit From 73357205ff984c3351a0a0c4176af807bbb669b8 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 26 Jul 2021 10:21:34 -0400 Subject: [PATCH 1385/1580] Fix regression in row unification (#4168) --- CHANGELOG.d/fix_4158.md | 1 + src/Language/PureScript/TypeChecker/Unify.hs | 2 +- tests/purs/failing/4158.out | 34 ++++++++++++++++++++ tests/purs/failing/4158.purs | 9 ++++++ 4 files changed, 45 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/fix_4158.md create mode 100644 tests/purs/failing/4158.out create mode 100644 tests/purs/failing/4158.purs diff --git a/CHANGELOG.d/fix_4158.md b/CHANGELOG.d/fix_4158.md new file mode 100644 index 0000000000..4be9393df0 --- /dev/null +++ b/CHANGELOG.d/fix_4158.md @@ -0,0 +1 @@ +* Fix regression in row unification diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 5dc9b3ff7f..bb7fb0ce8a 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -167,7 +167,7 @@ unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where unifyTails (sd, r) ([], TUnknown _ u) = solveType u (rowFromList (sd, r)) unifyTails ([], REmptyKinded _ _) ([], REmptyKinded _ _) = return () unifyTails ([], TypeVar _ v1) ([], TypeVar _ v2) | v1 == v2 = return () - unifyTails ([], Skolem _ _ s1 _ _) ([], Skolem _ _ s2 _ _) | s1 == s2 = return () + unifyTails ([], Skolem _ _ _ s1 _) ([], Skolem _ _ _ s2 _) | s1 == s2 = return () unifyTails (sd1, TUnknown a u1) (sd2, TUnknown _ u2) | u1 /= u2 = do forM_ sd1 $ occursCheck u2 . rowListType forM_ sd2 $ occursCheck u1 . rowListType diff --git a/tests/purs/failing/4158.out b/tests/purs/failing/4158.out new file mode 100644 index 0000000000..9639711b3c --- /dev/null +++ b/tests/purs/failing/4158.out @@ -0,0 +1,34 @@ +Error found: +in module Main +at tests/purs/failing/4158.purs:9:10 - 9:11 (line 9, column 10 - line 9, column 11) + + Could not match type +   +  a1 +   + with type +   +  b0 +   + +while trying to match type { foo :: Int + | a1  + }  + with type { foo :: Int + | b0  + }  +while checking that expression r + has type Maybe  +  { foo :: Int +  | b0  +  }  +in value declaration evil + +where a1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + b0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4158.purs b/tests/purs/failing/4158.purs new file mode 100644 index 0000000000..93e22ddfc8 --- /dev/null +++ b/tests/purs/failing/4158.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prelude + +data Maybe a = Just a | Nothing + +evil :: forall a b. Maybe (Record (foo :: Int | a)) -> Maybe (Record (foo :: Int | b)) +evil r = r From ec4dd2b368acdd94b94b548239486ce631369fbb Mon Sep 17 00:00:00 2001 From: Thomas Honeyman Date: Thu, 5 Aug 2021 10:35:36 -0400 Subject: [PATCH 1386/1580] Update Discord link to remove explicit invite (#4170) --- CONTRIBUTING.md | 4 ++-- INSTALL.md | 2 +- README.md | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 0b88492e71..99dc4ac2b6 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -5,8 +5,8 @@ When reporting issues, please be aware of the following: * Please use the appropriate issue template if there is one: filling out all of the sections in the template makes it much easier for us to understand what the problem is and how we might want to address it. -* We prefer to reserve the issue tracker in this repository for tasks which involve work on the compiler. If your report or proposal doesn't involve work on the compiler, please open it on the repository where the work would be done. If you're unsure, you can always ask on [Discord](https://discord.gg/sMqwYUbvz6) or [Discourse](https://discourse.purescript.org). -* If you have a question or need help, please ask on [Discord](https://discord.gg/sMqwYUbvz6) or [Discourse](https://discourse.purescript.org) instead. +* We prefer to reserve the issue tracker in this repository for tasks which involve work on the compiler. If your report or proposal doesn't involve work on the compiler, please open it on the repository where the work would be done. If you're unsure, you can always ask on [Discord](https://purescript.org/chat) or [Discourse](https://discourse.purescript.org). +* If you have a question or need help, please ask on [Discord](https://purescript.org/chat) or [Discourse](https://discourse.purescript.org) instead. * When submitting feature proposals, please be aware that we prefer to be conservative about adding things to the language/compiler. A feature proposal is much more likely to be accepted if it includes a clear description of the problem it intends to solve, as well as not only a strong justification for why adding the feature will solve that problem, but also for why any existing features or techniques that could be used to solve that problem are insufficient. We have defined some [Project Values](https://github.com/purescript/governance#project-values) in our organization's governance document; referring to these may help you get a better idea of what is likely to be accepted and what isn't. diff --git a/INSTALL.md b/INSTALL.md index 829ab18c82..1f1ce1932d 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -1,6 +1,6 @@ # Installation information -If you are having difficulty installing the PureScript compiler, feel free to ask for help! The best places are the [PureScript Discord](https://discord.gg/sMqwYUbvz6) or [PureScript Discourse](https://discourse.purescript.org). +If you are having difficulty installing the PureScript compiler, feel free to ask for help! The best places are the [PureScript Discord](https://purescript.org/chat) or [PureScript Discourse](https://discourse.purescript.org). ## Requirements diff --git a/README.md b/README.md index 0d34002dfa..b26b8d64cd 100644 --- a/README.md +++ b/README.md @@ -19,6 +19,6 @@ A small strongly typed programming language with expressive types that compiles ## Help! -- [PureScript Discord](https://discord.gg/sMqwYUbvz6) +- [PureScript Discord](https://purescript.org/chat) - [PureScript Discourse](https://discourse.purescript.org/) - [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript) From 616ffb072f0f561c3513b730b0362c9f37495a0c Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 10 Aug 2021 11:17:51 -0700 Subject: [PATCH 1387/1580] Fix backtick offside rule (#4172) * Add changelog entry * Use offsideEndP for backtick case * Add golden test for backtick case --- CHANGELOG.d/fix_4171.md | 1 + .../src/Language/PureScript/CST/Layout.hs | 2 +- tests/purs/layout/BacktickOperator.out | 22 +++++++++++++++++++ tests/purs/layout/BacktickOperator.purs | 21 ++++++++++++++++++ 4 files changed, 45 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/fix_4171.md create mode 100644 tests/purs/layout/BacktickOperator.out create mode 100644 tests/purs/layout/BacktickOperator.purs diff --git a/CHANGELOG.d/fix_4171.md b/CHANGELOG.d/fix_4171.md new file mode 100644 index 0000000000..eca5c2282e --- /dev/null +++ b/CHANGELOG.d/fix_4171.md @@ -0,0 +1 @@ +* Fix backtick operator rule diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs b/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs index 12df99ee8f..61b6d38b5f 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs @@ -265,7 +265,7 @@ insertLayout src@(SourceToken tokAnn tok) nextPos stack = ((_, LytTick) : stk', acc') -> (stk', acc') & insertToken src _ -> - state & insertDefault & pushStack tokPos LytTick + state & collapse offsideEndP & insertSep & insertToken src & pushStack tokPos LytTick -- In general, commas should close all indented contexts. -- example = [ do foo diff --git a/tests/purs/layout/BacktickOperator.out b/tests/purs/layout/BacktickOperator.out new file mode 100644 index 0000000000..068b8298d2 --- /dev/null +++ b/tests/purs/layout/BacktickOperator.out @@ -0,0 +1,22 @@ +module Test where{ + +example1 = do{ + foo bar} + <|> baz; + +example2 = do{ + foo bar} + `wat` baz; + +example3 = + case _ of{ + Foo a -> 1; + Bar b -> 2} + `append` 3; + +example4 = + case _ of{ + Foo a -> 1; + Bar b -> 2} + + 3} + \ No newline at end of file diff --git a/tests/purs/layout/BacktickOperator.purs b/tests/purs/layout/BacktickOperator.purs new file mode 100644 index 0000000000..81be3e37e4 --- /dev/null +++ b/tests/purs/layout/BacktickOperator.purs @@ -0,0 +1,21 @@ +module Test where + +example1 = do + foo bar + <|> baz + +example2 = do + foo bar + `wat` baz + +example3 = + case _ of + Foo a -> 1 + Bar b -> 2 + `append` 3 + +example4 = + case _ of + Foo a -> 1 + Bar b -> 2 + + 3 From c2a4189338db8369064e06d06d98cf9ff3a3a13d Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Wed, 25 Aug 2021 07:02:11 -0700 Subject: [PATCH 1388/1580] Prepare for v0.14.4 release (#4175) * Update version to v0.14.4 * Regenerate changelog * Add 'v' in front of version header * Bump purescript-cst to 0.4.0.0 --- CHANGELOG.d/fix_3701.md | 4 -- CHANGELOG.d/fix_4101.md | 3 -- CHANGELOG.d/fix_4158.md | 1 - CHANGELOG.d/fix_4171.md | 1 - .../fix_bundle-function-declarations.md | 1 - .../fix_error-in-foreign-import-data-hint.md | 1 - ...eresting kind sigs when parens involved.md | 1 - CHANGELOG.d/fix_solve_union_backwards.md | 2 - ...ternal_add-golden-tests-for-self-cycles.md | 1 - CHANGELOG.d/internal_changelog-dir.md | 3 -- ...al_explain approach for broken releases.md | 1 - ..._miscellaneous updates to release guide.md | 1 - .../internal_typeclasses-are-newtypes.md | 1 - CHANGELOG.d/internal_weeder.md | 1 - CHANGELOG.d/misc-dev-guide-3900.md | 1 - CHANGELOG.md | 46 +++++++++++++++++++ lib/purescript-cst/README.md | 1 + lib/purescript-cst/purescript-cst.cabal | 2 +- npm-package/package.json | 4 +- purescript.cabal | 4 +- 20 files changed, 52 insertions(+), 28 deletions(-) delete mode 100644 CHANGELOG.d/fix_3701.md delete mode 100644 CHANGELOG.d/fix_4101.md delete mode 100644 CHANGELOG.d/fix_4158.md delete mode 100644 CHANGELOG.d/fix_4171.md delete mode 100644 CHANGELOG.d/fix_bundle-function-declarations.md delete mode 100644 CHANGELOG.d/fix_error-in-foreign-import-data-hint.md delete mode 100644 CHANGELOG.d/fix_fix uninteresting kind sigs when parens involved.md delete mode 100644 CHANGELOG.d/fix_solve_union_backwards.md delete mode 100644 CHANGELOG.d/internal_add-golden-tests-for-self-cycles.md delete mode 100644 CHANGELOG.d/internal_changelog-dir.md delete mode 100644 CHANGELOG.d/internal_explain approach for broken releases.md delete mode 100644 CHANGELOG.d/internal_miscellaneous updates to release guide.md delete mode 100644 CHANGELOG.d/internal_typeclasses-are-newtypes.md delete mode 100644 CHANGELOG.d/internal_weeder.md delete mode 100644 CHANGELOG.d/misc-dev-guide-3900.md diff --git a/CHANGELOG.d/fix_3701.md b/CHANGELOG.d/fix_3701.md deleted file mode 100644 index a8640817a5..0000000000 --- a/CHANGELOG.d/fix_3701.md +++ /dev/null @@ -1,4 +0,0 @@ -* Improve row type error messages - * Remove a redundant hint that repeats the types in the error - * Correctly diff rows containing duplicate items - * Erase kind applications from rows in errors (by default) diff --git a/CHANGELOG.d/fix_4101.md b/CHANGELOG.d/fix_4101.md deleted file mode 100644 index 65cc23b504..0000000000 --- a/CHANGELOG.d/fix_4101.md +++ /dev/null @@ -1,3 +0,0 @@ -* Fix bad interaction between superclasses and type synonyms - - See #4101. diff --git a/CHANGELOG.d/fix_4158.md b/CHANGELOG.d/fix_4158.md deleted file mode 100644 index 4be9393df0..0000000000 --- a/CHANGELOG.d/fix_4158.md +++ /dev/null @@ -1 +0,0 @@ -* Fix regression in row unification diff --git a/CHANGELOG.d/fix_4171.md b/CHANGELOG.d/fix_4171.md deleted file mode 100644 index eca5c2282e..0000000000 --- a/CHANGELOG.d/fix_4171.md +++ /dev/null @@ -1 +0,0 @@ -* Fix backtick operator rule diff --git a/CHANGELOG.d/fix_bundle-function-declarations.md b/CHANGELOG.d/fix_bundle-function-declarations.md deleted file mode 100644 index ce613debd4..0000000000 --- a/CHANGELOG.d/fix_bundle-function-declarations.md +++ /dev/null @@ -1 +0,0 @@ -* Do not remove bindings referenced in function declarations when bundling diff --git a/CHANGELOG.d/fix_error-in-foreign-import-data-hint.md b/CHANGELOG.d/fix_error-in-foreign-import-data-hint.md deleted file mode 100644 index 48e3549ee3..0000000000 --- a/CHANGELOG.d/fix_error-in-foreign-import-data-hint.md +++ /dev/null @@ -1 +0,0 @@ -* Add a hint for errors in foreign data type declarations diff --git a/CHANGELOG.d/fix_fix uninteresting kind sigs when parens involved.md b/CHANGELOG.d/fix_fix uninteresting kind sigs when parens involved.md deleted file mode 100644 index 93b811288d..0000000000 --- a/CHANGELOG.d/fix_fix uninteresting kind sigs when parens involved.md +++ /dev/null @@ -1 +0,0 @@ -* Account for redundant parens when excluding uninteresting kind sigs from docs diff --git a/CHANGELOG.d/fix_solve_union_backwards.md b/CHANGELOG.d/fix_solve_union_backwards.md deleted file mode 100644 index fd0f092cbc..0000000000 --- a/CHANGELOG.d/fix_solve_union_backwards.md +++ /dev/null @@ -1,2 +0,0 @@ -* Solve `Prim.Row.Union left right all` constraint for `left` when `all` and `right` are already closed rows, - reflecting the existing functional dependency `all right -> left` diff --git a/CHANGELOG.d/internal_add-golden-tests-for-self-cycles.md b/CHANGELOG.d/internal_add-golden-tests-for-self-cycles.md deleted file mode 100644 index 3d36934765..0000000000 --- a/CHANGELOG.d/internal_add-golden-tests-for-self-cycles.md +++ /dev/null @@ -1 +0,0 @@ -* Add golden tests for self cycles in type class declarations, kind declarations and foreign data type declarations diff --git a/CHANGELOG.d/internal_changelog-dir.md b/CHANGELOG.d/internal_changelog-dir.md deleted file mode 100644 index 07d5deea04..0000000000 --- a/CHANGELOG.d/internal_changelog-dir.md +++ /dev/null @@ -1,3 +0,0 @@ -* Move unreleased changelog entries to CHANGELOG.d - - See CHANGELOG.d/README.md for details. diff --git a/CHANGELOG.d/internal_explain approach for broken releases.md b/CHANGELOG.d/internal_explain approach for broken releases.md deleted file mode 100644 index e52c97e6aa..0000000000 --- a/CHANGELOG.d/internal_explain approach for broken releases.md +++ /dev/null @@ -1 +0,0 @@ -* Clarify in RELEASE_GUIDE what to do when broken releases are made diff --git a/CHANGELOG.d/internal_miscellaneous updates to release guide.md b/CHANGELOG.d/internal_miscellaneous updates to release guide.md deleted file mode 100644 index e0dd6b9f88..0000000000 --- a/CHANGELOG.d/internal_miscellaneous updates to release guide.md +++ /dev/null @@ -1 +0,0 @@ -* Miscellaneous updates/clarifications to the release guide diff --git a/CHANGELOG.d/internal_typeclasses-are-newtypes.md b/CHANGELOG.d/internal_typeclasses-are-newtypes.md deleted file mode 100644 index 0ca4652e65..0000000000 --- a/CHANGELOG.d/internal_typeclasses-are-newtypes.md +++ /dev/null @@ -1 +0,0 @@ -* Represent class dictionaries as newtypes diff --git a/CHANGELOG.d/internal_weeder.md b/CHANGELOG.d/internal_weeder.md deleted file mode 100644 index 0cdd3c35ad..0000000000 --- a/CHANGELOG.d/internal_weeder.md +++ /dev/null @@ -1 +0,0 @@ -* Run Weeder in CI and make it happy diff --git a/CHANGELOG.d/misc-dev-guide-3900.md b/CHANGELOG.d/misc-dev-guide-3900.md deleted file mode 100644 index b1b247cc43..0000000000 --- a/CHANGELOG.d/misc-dev-guide-3900.md +++ /dev/null @@ -1 +0,0 @@ -* Add developer guide to readme \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md index 61d81476db..16102a709a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,52 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## v0.14.4 + +Bugfixes: + +* Solve `Prim.Row.Union left right all` constraint for `left` when `all` and `right` are already closed rows, (#3720 by @MonoidMusician) + reflecting the existing functional dependency `all right -> left` + +* Account for redundant parens when excluding uninteresting kind sigs from docs (#4137 by @JordanMartinez) + +* Add a hint for errors in foreign data type declarations (#4161 by @kl0tl) + +* Do not remove bindings referenced in function declarations when bundling (#4044 by @kl0tl) + +* Improve row type error messages (#4159 by @rhendric) + * Remove a redundant hint that repeats the types in the error + * Correctly diff rows containing duplicate items + * Erase kind applications from rows in errors (by default) + +* Fix bad interaction between superclasses and type synonyms (#4164 by @rhendric) + + See #4101. + +* Fix regression in row unification (#4168 by @rhendric) + +* Fix backtick operator rule (#4172 by @JordanMartinez) + +Other improvements: + +* Add developer guide to readme (#3900 by @milesfrain) + +Internal: + +* Move unreleased changelog entries to CHANGELOG.d (#4132 by @rhendric) + + See CHANGELOG.d/README.md for details. + +* Clarify in RELEASE_GUIDE what to do when broken releases are made (#4147 by @JordanMartinez) + +* Miscellaneous updates/clarifications to the release guide (#4131 by @JordanMartinez) + +* Run Weeder in CI and make it happy (#4148 by @rhendric) + +* Add golden tests for self cycles in type class declarations, kind declarations and foreign data type declarations (#4162 by @kl0tl) + +* Represent class dictionaries as newtypes (#4125 by @rhendric) + ## v0.14.3 New features: diff --git a/lib/purescript-cst/README.md b/lib/purescript-cst/README.md index 1775170d86..099c784403 100644 --- a/lib/purescript-cst/README.md +++ b/lib/purescript-cst/README.md @@ -10,6 +10,7 @@ We provide a table to make it a bit easier to map between versions of `purescrip | --- | --- | | 0.14.2 | 0.2.0.0 | | 0.14.3 | 0.3.0.0 | +| 0.14.4 | 0.4.0.0 | Before v0.14.2, there was a third package, `purescript-ast`. In v0.14.2, `purescript-ast` was merged into `purescript-cst`. diff --git a/lib/purescript-cst/purescript-cst.cabal b/lib/purescript-cst/purescript-cst.cabal index e04a54afd5..9377ac5c06 100644 --- a/lib/purescript-cst/purescript-cst.cabal +++ b/lib/purescript-cst/purescript-cst.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: purescript-cst -version: 0.3.0.0 +version: 0.4.0.0 synopsis: PureScript Programming Language Concrete Syntax Tree description: The parser for the PureScript programming language. category: Language diff --git a/npm-package/package.json b/npm-package/package.json index ad519c778f..1a84218b77 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.14.3", + "version": "0.14.4", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.14.3", + "postinstall": "install-purescript --purs-ver=0.14.4", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index e3cb467064..5317db211d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.14.3 +version: 0.14.4 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language @@ -159,7 +159,7 @@ common defaults pattern-arrows >=0.0.2 && <0.1, process >=1.6.9.0 && <1.7, protolude >=0.3.0 && <0.4, - purescript-cst ==0.3.0.0, + purescript-cst ==0.4.0.0, regex-tdfa >=1.3.1.0 && <1.4, safe >=0.3.19 && <0.4, scientific >=0.3.6.2 && <0.4, From 729822bc115085efe5441522f69eaec7eb4ff4ff Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Wed, 25 Aug 2021 10:17:25 -0700 Subject: [PATCH 1389/1580] More Release guide updates (#4177) * Don't build a search index in case its broken `purescript-docs-search` still hasn't been updated yet so without the `-S` flag, the output of `spago docs` may be mistakenly interpreted as a problem * Add release task: make new package set * Clarify updates to TryPureScript * Clarify when Pursuit should be updated/redeployed * Add changelog entry * Fix typo Co-authored-by: Harry Garrood * Fix typo Co-authored-by: Harry Garrood Co-authored-by: Harry Garrood --- .../internal_release-guide-clarifications.md | 1 + RELEASE_GUIDE.md | 13 ++++++++----- 2 files changed, 9 insertions(+), 5 deletions(-) create mode 100644 CHANGELOG.d/internal_release-guide-clarifications.md diff --git a/CHANGELOG.d/internal_release-guide-clarifications.md b/CHANGELOG.d/internal_release-guide-clarifications.md new file mode 100644 index 0000000000..412c1bc2e3 --- /dev/null +++ b/CHANGELOG.d/internal_release-guide-clarifications.md @@ -0,0 +1 @@ +* Fix command and clarify a few other requirements in release guide \ No newline at end of file diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md index 4b8acb0716..7815062cb1 100644 --- a/RELEASE_GUIDE.md +++ b/RELEASE_GUIDE.md @@ -23,7 +23,7 @@ spago install $(spago ls packages | cut -f 1 -d ' ' | tr '\n' ' ') # Verify that code compiles and docs are properly created stack exec bash < Date: Wed, 22 Sep 2021 19:34:32 +0100 Subject: [PATCH 1390/1580] Synonym inference bug (#4184) Fix synonym inference bug --- CHANGELOG.d/fix-4183.md | 1 + CONTRIBUTORS.md | 1 + src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- tests/purs/warning/4183.out | 15 +++++++++++++++ tests/purs/warning/4183.purs | 4 ++++ 5 files changed, 22 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/fix-4183.md create mode 100644 tests/purs/warning/4183.out create mode 100644 tests/purs/warning/4183.purs diff --git a/CHANGELOG.d/fix-4183.md b/CHANGELOG.d/fix-4183.md new file mode 100644 index 0000000000..979f6b533a --- /dev/null +++ b/CHANGELOG.d/fix-4183.md @@ -0,0 +1 @@ +* Fix a case where kind inference inferred the wrong kind for type synonyms diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index d1d258b46a..14e7939075 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -64,6 +64,7 @@ If you would prefer to use different terms, please use the section below instead | [@japesinator](https://github.com/japesinator) | JP Smith | [MIT license](http://opensource.org/licenses/MIT) | | [@jkachmar](https://github.com/jkachmar) | Joe Kachmar | MIT license | | [@joneshf](https://github.com/joneshf) | Hardy Jones | MIT license | +| [@jy14898](https://github.com/jy14898) | Joseph Young | MIT license | | [@kika](https://github.com/kika) | Kirill Pertsev | MIT license | | [@kRITZCREEK](https://github.com/kRITZCREEK) | Christoph Hegemann | MIT license | | [@L8D](https://github.com/L8D) | Tenor Biel | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 9749020227..e8e138c5c3 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -665,7 +665,7 @@ inferTypeSynonym moduleName (ann, tyName, tyArgs, tyBody) = do tyArgs' <- for tyArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< flip checkKind E.kindType unifyKinds tyKind' $ foldr ((E.-:>) . snd) kindRes tyArgs' bindLocalTypeVariables moduleName (first ProperName <$> tyArgs') $ do - tyBodyAndKind <- inferKind tyBody + tyBodyAndKind <- traverse apply =<< inferKind tyBody instantiateKind tyBodyAndKind =<< apply kindRes -- | Checks that a particular generalization is valid and well-scoped. diff --git a/tests/purs/warning/4183.out b/tests/purs/warning/4183.out new file mode 100644 index 0000000000..17501978ae --- /dev/null +++ b/tests/purs/warning/4183.out @@ -0,0 +1,15 @@ +Warning found: +in module Main +at tests/purs/warning/4183.purs:4:1 - 4:21 (line 4, column 1 - line 4, column 21) + + The inferred kind for the type declaration T contains polymorphic kinds. + Consider adding a top-level kind signature as a form of documentation. +   +  type T :: forall k. (k -> k) -> k -> k +   + +in type synonym T + +See https://github.com/purescript/documentation/blob/master/errors/MissingKindDeclaration.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/4183.purs b/tests/purs/warning/4183.purs new file mode 100644 index 0000000000..7a9b4871c4 --- /dev/null +++ b/tests/purs/warning/4183.purs @@ -0,0 +1,4 @@ +-- @shouldWarnWith MissingKindDeclaration +module Main where + +type T f a = f (f a) From a581e64dc7890f55146cfe9dd5de69c61b0aeb49 Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Sun, 26 Sep 2021 03:43:04 +0900 Subject: [PATCH 1391/1580] Derive Functor for Language.PureScript.CoreFn.Module (#4186) --- CHANGELOG.d/internal_add-functor-for-module.md | 1 + src/Language/PureScript/CoreFn/Module.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/internal_add-functor-for-module.md diff --git a/CHANGELOG.d/internal_add-functor-for-module.md b/CHANGELOG.d/internal_add-functor-for-module.md new file mode 100644 index 0000000000..cc2001916c --- /dev/null +++ b/CHANGELOG.d/internal_add-functor-for-module.md @@ -0,0 +1 @@ +* Add `Functor` instance for `Language.PureScript.CoreFn.Module`. diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index ac8b0f84d5..3466245e81 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -22,4 +22,4 @@ data Module a = Module , moduleReExports :: Map ModuleName [Ident] , moduleForeign :: [Ident] , moduleDecls :: [Bind a] - } deriving (Show) + } deriving (Functor, Show) From e320a21ba230718deb17f0d2a3d477ab936795e9 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Thu, 14 Oct 2021 05:19:28 +0800 Subject: [PATCH 1392/1580] Properly rename module imports in case of conflicts with declarations (#4188) * Make renameImports work with dotted modules * Add passing test for renameImports * Add CHANGELOG.d entry * Add @PureFunctor to CONTRIBUTORS.md --- CHANGELOG.d/fix_4174.md | 1 + CONTRIBUTORS.md | 1 + src/Language/PureScript/CodeGen/JS.hs | 2 +- tests/purs/passing/4174.purs | 16 ++++++++++++++++ 4 files changed, 19 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/fix_4174.md create mode 100644 tests/purs/passing/4174.purs diff --git a/CHANGELOG.d/fix_4174.md b/CHANGELOG.d/fix_4174.md new file mode 100644 index 0000000000..9c685d2764 --- /dev/null +++ b/CHANGELOG.d/fix_4174.md @@ -0,0 +1 @@ +* Properly rename module imports in case of conflicts with declarations diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 14e7939075..ba0e3b1591 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -148,6 +148,7 @@ If you would prefer to use different terms, please use the section below instead | [@woody88](https://github.com/woody88) | Woodson Delhia | [MIT license](http://opensource.org/licenses/MIT) | | [@mhmdanas](https://github.com/mhmdanas) | Mohammed Anas | [MIT license](http://opensource.org/licenses/MIT) | | [@kl0tl](https://github.com/kl0tl) | Cyril Sobierajewicz | [MIT license](http://opensource.org/licenses/MIT) | +| [@PureFunctor](https://github.com/PureFunctor) | Justin Garcia | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index c01f21eb06..856fa9ce2b 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -106,7 +106,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ = where go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName) go acc used ((ann, mn') : mns') = - let mni = Ident $ runModuleName mn' + let mni = Ident $ moduleNameToJs mn' in if mn' /= mn && mni `elem` used then let newName = freshModuleName 1 mn' used in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns' diff --git a/tests/purs/passing/4174.purs b/tests/purs/passing/4174.purs new file mode 100644 index 0000000000..cf73216985 --- /dev/null +++ b/tests/purs/passing/4174.purs @@ -0,0 +1,16 @@ +module Main where + +import Data.Unit (Unit, unit) +import Effect.Console (log) + +data Effect_Console = Effect_Console + +d :: Effect_Console +d = Effect_Console + +newtype Data_Unit = Data_Unit Unit + +n :: Data_Unit +n = Data_Unit unit + +main = log "Done" From c14d52e0bd4caca88358ac082911e8a94d072dd5 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 22 Oct 2021 14:03:52 -0700 Subject: [PATCH 1393/1580] Make v0.14.5 Release (#4189) * Update version to v0.14.5 * Update changelog * Pin weeder version to 2.2.0 --- .github/workflows/ci.yml | 4 +++- CHANGELOG.d/fix-4183.md | 1 - CHANGELOG.d/fix_4174.md | 1 - CHANGELOG.d/internal_add-functor-for-module.md | 1 - .../internal_release-guide-clarifications.md | 1 - CHANGELOG.md | 14 ++++++++++++++ lib/purescript-cst/README.md | 1 + npm-package/package.json | 4 ++-- purescript.cabal | 2 +- 9 files changed, 21 insertions(+), 8 deletions(-) delete mode 100644 CHANGELOG.d/fix-4183.md delete mode 100644 CHANGELOG.d/fix_4174.md delete mode 100644 CHANGELOG.d/internal_add-functor-for-module.md delete mode 100644 CHANGELOG.d/internal_release-guide-clarifications.md diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index e33fc6eb44..6fc164b074 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -110,7 +110,9 @@ jobs: env: VERSION: "2.2.11" - - run: "stack --no-terminal --jobs=2 build --copy-compiler-tool weeder" + # Note: the weeder version will need to be updated when we next update our version + # of GHC + - run: "stack --no-terminal --jobs=2 build --copy-compiler-tool weeder-2.2.0" - run: "stack --no-terminal --jobs=2 build --fast --ghc-options -fwrite-ide-info" diff --git a/CHANGELOG.d/fix-4183.md b/CHANGELOG.d/fix-4183.md deleted file mode 100644 index 979f6b533a..0000000000 --- a/CHANGELOG.d/fix-4183.md +++ /dev/null @@ -1 +0,0 @@ -* Fix a case where kind inference inferred the wrong kind for type synonyms diff --git a/CHANGELOG.d/fix_4174.md b/CHANGELOG.d/fix_4174.md deleted file mode 100644 index 9c685d2764..0000000000 --- a/CHANGELOG.d/fix_4174.md +++ /dev/null @@ -1 +0,0 @@ -* Properly rename module imports in case of conflicts with declarations diff --git a/CHANGELOG.d/internal_add-functor-for-module.md b/CHANGELOG.d/internal_add-functor-for-module.md deleted file mode 100644 index cc2001916c..0000000000 --- a/CHANGELOG.d/internal_add-functor-for-module.md +++ /dev/null @@ -1 +0,0 @@ -* Add `Functor` instance for `Language.PureScript.CoreFn.Module`. diff --git a/CHANGELOG.d/internal_release-guide-clarifications.md b/CHANGELOG.d/internal_release-guide-clarifications.md deleted file mode 100644 index 412c1bc2e3..0000000000 --- a/CHANGELOG.d/internal_release-guide-clarifications.md +++ /dev/null @@ -1 +0,0 @@ -* Fix command and clarify a few other requirements in release guide \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md index 16102a709a..d11c210adf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,20 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.14.5 + +Bugfixes: + +* Fix a case where kind inference inferred the wrong kind for type synonyms (#4184 by @jy14898) + +* Properly rename module imports in case of conflicts with declarations (#4188 by @PureFunctor) + +Internal: + +* Fix command and clarify a few other requirements in release guide (#4177 by @JordanMartinez) + +* Add `Functor` instance for `Language.PureScript.CoreFn.Module`. (#4186 by @cdepillabout) + ## v0.14.4 Bugfixes: diff --git a/lib/purescript-cst/README.md b/lib/purescript-cst/README.md index 099c784403..521d41ed87 100644 --- a/lib/purescript-cst/README.md +++ b/lib/purescript-cst/README.md @@ -11,6 +11,7 @@ We provide a table to make it a bit easier to map between versions of `purescrip | 0.14.2 | 0.2.0.0 | | 0.14.3 | 0.3.0.0 | | 0.14.4 | 0.4.0.0 | +| 0.14.5 | 0.4.0.0 | Before v0.14.2, there was a third package, `purescript-ast`. In v0.14.2, `purescript-ast` was merged into `purescript-cst`. diff --git a/npm-package/package.json b/npm-package/package.json index 1a84218b77..ed3d001afe 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.14.4", + "version": "0.14.5", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.14.4", + "postinstall": "install-purescript --purs-ver=0.14.5", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index 5317db211d..8c1a8e951e 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.14.4 +version: 0.14.5 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From fd22f09fbac0e9329077b6a3bda475e30f5b3d1a Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Tue, 9 Nov 2021 03:44:35 +0800 Subject: [PATCH 1394/1580] Include missing source spans for data constructors (#4202) * Add missing source span to ChildDeclaration * Destructure using a let binding instead * Add CHANGELOG.d entry --- CHANGELOG.d/fix_ctor-spans.md | 1 + src/Language/PureScript/Docs/Convert/Single.hs | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/fix_ctor-spans.md diff --git a/CHANGELOG.d/fix_ctor-spans.md b/CHANGELOG.d/fix_ctor-spans.md new file mode 100644 index 0000000000..82b82d2e93 --- /dev/null +++ b/CHANGELOG.d/fix_ctor-spans.md @@ -0,0 +1 @@ +* Add missing source spans to data constructors when generating docs diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index d27f5d971a..405a4f53b8 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -150,7 +150,8 @@ convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title = children = map convertCtor ctors convertCtor :: P.DataConstructorDeclaration -> ChildDeclaration convertCtor P.DataConstructorDeclaration{..} = - ChildDeclaration (P.runProperName dataCtorName) (convertComments $ snd dataCtorAnn) Nothing (ChildDataConstructor (fmap (($> ()) . snd) dataCtorFields)) + let (sourceSpan, comments) = dataCtorAnn + in ChildDeclaration (P.runProperName dataCtorName) (convertComments comments) (Just sourceSpan) (ChildDataConstructor (fmap (($> ()) . snd) dataCtorFields)) convertDeclaration (P.ExternDataDeclaration sa _ kind') title = basicDeclaration sa title (ExternDataDeclaration (kind' $> ())) convertDeclaration (P.TypeSynonymDeclaration sa _ args ty) title = From 198dfcb63ec0c158a99839bb18c194a989274071 Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Tue, 9 Nov 2021 14:14:53 +0900 Subject: [PATCH 1395/1580] Bump PureScript to building with LTS-18 (#4199) --- .github/workflows/ci.yml | 19 +++++++++- CHANGELOG.d/internal_bump-to-lts-18.md | 1 + INSTALL.md | 4 +- app/Main.hs | 2 +- lib/purescript-cst/purescript-cst.cabal | 20 +++++----- purescript.cabal | 50 ++++++++++++------------- stack.yaml | 17 +++++---- 7 files changed, 67 insertions(+), 46 deletions(-) create mode 100644 CHANGELOG.d/internal_bump-to-lts-18.md diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 6fc164b074..7f42c067d7 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -111,8 +111,23 @@ jobs: VERSION: "2.2.11" # Note: the weeder version will need to be updated when we next update our version - # of GHC - - run: "stack --no-terminal --jobs=2 build --copy-compiler-tool weeder-2.2.0" + # of GHC. + # + # weeder-2.2.0 has somewhat strange version deps. It doesn't appear to + # support the exact versions of dhall and generic-lens in LTS-18. + # However, forcing it to use the versions of dhall and generic-lens in + # LTS-18 doesn't cause any problems when building, so the following + # commands build weeder while ignoring version constraints. + - name: Install weeder + run: | + # The `stack.yaml` file is copied to a separate file so that + # adding `allow-newer: true` doesn't affect any subsequant + # calls to `stack`. + cp stack.yaml stack-weeder.yaml + # `allow-newer: true` is needed so that weeder-2.2.0 can be + # installed with the dependencies present in LTS-18. + echo 'allow-newer: true' >> stack-weeder.yaml + stack --no-terminal --jobs=2 build --copy-compiler-tool --stack-yaml ./stack-weeder.yaml weeder-2.2.0 - run: "stack --no-terminal --jobs=2 build --fast --ghc-options -fwrite-ide-info" diff --git a/CHANGELOG.d/internal_bump-to-lts-18.md b/CHANGELOG.d/internal_bump-to-lts-18.md new file mode 100644 index 0000000000..f3b8201706 --- /dev/null +++ b/CHANGELOG.d/internal_bump-to-lts-18.md @@ -0,0 +1 @@ +* Bump PureScript to building with GHC-8.10.7, as well as from LTS-17 to LTS-18. diff --git a/INSTALL.md b/INSTALL.md index 1f1ce1932d..ecda0b18f2 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -4,12 +4,12 @@ If you are having difficulty installing the PureScript compiler, feel free to as ## Requirements -The PureScript compiler is built using GHC 8.10.4, and should be able to run on any operating system supported by GHC 8.10.4. In particular: +The PureScript compiler is built using GHC 8.10.7, and should be able to run on any operating system supported by GHC 8.10.7. In particular: * for Windows users, versions predating Vista are not officially supported, * for macOS / OS X users, versions predating Mac OS X 10.7 (Lion) are not officially supported. -See also for more details about the operating systems which GHC 8.10.4 supports. +See also for more details about the operating systems which GHC 8.10.7 supports. ## Official prebuilt binaries diff --git a/app/Main.hs b/app/Main.hs index 7b0132d1e4..76064aa2db 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -48,7 +48,7 @@ main = do -- | Displays full command help when invoked with no arguments. execParserPure :: Opts.ParserInfo a -> [String] -> Opts.ParserResult a execParserPure pinfo [] = Opts.Failure $ - Opts.parserFailure Opts.defaultPrefs pinfo Opts.ShowHelpText mempty + Opts.parserFailure Opts.defaultPrefs pinfo (Opts.ShowHelpText Nothing) mempty execParserPure pinfo args = Opts.execParserPure Opts.defaultPrefs pinfo args versionInfo :: Opts.Parser (a -> a) diff --git a/lib/purescript-cst/purescript-cst.cabal b/lib/purescript-cst/purescript-cst.cabal index 9377ac5c06..c57419a8b6 100644 --- a/lib/purescript-cst/purescript-cst.cabal +++ b/lib/purescript-cst/purescript-cst.cabal @@ -54,24 +54,26 @@ common defaults TypeFamilies ViewPatterns build-depends: + -- NOTE: Please do not edit these version constraints manually. + -- See the note in ../../purescript.cabal for an explanation of how to edit + -- these version constraints. aeson >=1.5.6.0 && <1.6, array >=0.5.4.0 && <0.6, - base >=4.14.1.0 && <4.15, + base >=4.14.3.0 && <4.15, base-compat >=0.11.2 && <0.12, bytestring >=0.10.12.0 && <0.11, - containers >=0.6.2.1 && <0.7, + containers >=0.6.5.1 && <0.7, deepseq >=1.4.4.0 && <1.5, - dlist >=0.8.0.8 && <0.9, + dlist ==1.0.*, filepath >=1.4.2.1 && <1.5, - microlens >=0.4.11.2 && <0.5, + microlens >=0.4.12.0 && <0.5, mtl >=2.2.2 && <2.3, protolude >=0.3.0 && <0.4, - scientific >=0.3.6.2 && <0.4, - semigroups >=0.19.1 && <0.20, + scientific >=0.3.7.0 && <0.4, + semigroups >=0.19.2 && <0.20, + serialise >=0.2.4.0 && <0.3, text >=1.2.4.1 && <1.3, - serialise >=0.2.3.0 && <0.3, - text >=1.2.4.1 && <1.3, - vector >=0.12.1.2 && <0.13 + vector >=0.12.3.1 && <0.13 build-tool-depends: happy:happy ==1.20.0 diff --git a/purescript.cabal b/purescript.cabal index 8c1a8e951e..765ddabdf3 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -119,66 +119,66 @@ common defaults -- specific version. aeson >=1.5.6.0 && <1.6, aeson-better-errors >=0.9.1.0 && <0.10, - aeson-pretty >=0.8.8 && <0.9, - ansi-terminal >=0.10.3 && <0.11, + aeson-pretty >=0.8.9 && <0.9, + ansi-terminal ==0.11.*, array >=0.5.4.0 && <0.6, - base >=4.14.1.0 && <4.15, + base >=4.14.3.0 && <4.15, base-compat >=0.11.2 && <0.12, blaze-html >=0.9.1.2 && <0.10, bower-json >=1.0.0.1 && <1.1, boxes >=0.1.5 && <0.2, bytestring >=0.10.12.0 && <0.11, Cabal >=3.2.1.0 && <3.3, - cborg >=0.2.4.0 && <0.3, - serialise >=0.2.3.0 && <0.3, + cborg >=0.2.6.0 && <0.3, + serialise >=0.2.4.0 && <0.3, cheapskate >=0.1.1.2 && <0.2, - clock ==0.8.*, - containers >=0.6.2.1 && <0.7, - cryptonite ==0.27.*, + clock >=0.8.2 && <0.9, + containers >=0.6.5.1 && <0.7, + cryptonite ==0.29.*, data-ordlist >=0.4.7.0 && <0.5, deepseq >=1.4.4.0 && <1.5, directory >=1.3.6.0 && <1.4, - dlist >=0.8.0.8 && <0.9, + dlist ==1.0.*, edit-distance >=0.2.2.1 && <0.3, - file-embed >=0.0.13.0 && <0.1, + file-embed >=0.0.15.0 && <0.1, filepath >=1.4.2.1 && <1.5, fsnotify >=0.3.0.1 && <0.4, Glob >=0.10.1 && <0.11, - haskeline >=0.8.1.1 && <0.9, + haskeline >=0.8.2 && <0.9, language-javascript ==0.7.0.0, - lifted-async >=0.10.1.3 && <0.11, + lifted-async >=0.10.2.2 && <0.11, lifted-base >=0.2.3.12 && <0.3, memory >=0.15.0 && <0.16, - microlens >=0.4.11.2 && <0.5, - microlens-platform >=0.4.1 && <0.5, - monad-control >=1.0.2.3 && <1.1, + microlens >=0.4.12.0 && <0.5, + microlens-platform >=0.4.2 && <0.5, + monad-control >=1.0.3.1 && <1.1, monad-logger >=0.3.36 && <0.4, mtl >=2.2.2 && <2.3, parallel >=3.2.2.0 && <3.3, parsec >=3.1.14.0 && <3.2, pattern-arrows >=0.0.2 && <0.1, - process >=1.6.9.0 && <1.7, + process >=1.6.13.2 && <1.7, protolude >=0.3.0 && <0.4, purescript-cst ==0.4.0.0, - regex-tdfa >=1.3.1.0 && <1.4, + regex-tdfa >=1.3.1.1 && <1.4, safe >=0.3.19 && <0.4, - scientific >=0.3.6.2 && <0.4, - semigroups >=0.19.1 && <0.20, + scientific >=0.3.7.0 && <0.4, + semigroups >=0.19.2 && <0.20, semialign >=1.1.0.1 && <1.2, - sourcemap >=0.1.6 && <0.2, + sourcemap >=0.1.6.1 && <0.2, split >=0.2.3.4 && <0.3, - stm >=2.5.0.0 && <2.6, + stm >=2.5.0.1 && <2.6, stringsearch >=0.3.6.6 && <0.4, syb >=0.7.2.1 && <0.8, text >=1.2.4.1 && <1.3, these >=1.1.1.1 && <1.2, time >=1.9.3 && <1.10, transformers >=0.5.6.2 && <0.6, - transformers-base >=0.4.5.2 && <0.5, + transformers-base >=0.4.6 && <0.5, transformers-compat >=0.6.6 && <0.7, - unordered-containers >=0.2.13.0 && <0.3, + unordered-containers >=0.2.14.0 && <0.3, utf8-string >=1.0.2 && <1.1, - vector >=0.12.1.2 && <0.13 + vector >=0.12.3.1 && <0.13 library import: defaults @@ -332,7 +332,7 @@ executable purs , file-embed >=0.0.13.0 && <0.1 , http-types >=0.12.3 && <0.13 , network >= 3.1.1.1 && <3.2 - , optparse-applicative >=0.15.1.0 && <0.16 + , optparse-applicative >=0.16.1.0 && <0.17 , purescript , wai >=3.2.3 && <3.3 , wai-websockets >=3.0.1.2 && <3.1 diff --git a/stack.yaml b/stack.yaml index 2717a09caf..de8b47203d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-17.6 +resolver: lts-18.15 pvp-bounds: both packages: - '.' @@ -7,13 +7,16 @@ ghc-options: # Build with advanced optimizations enabled by default "$locals": -O2 -Werror extra-deps: +# As of 2021-11-08, the latest release of `language-javascript` is 0.7.1.0, +# but it has a problem with parsing the `async` keyword. It doesn't allow +# `async` to be used as an object key: +# https://github.com/erikd/language-javascript/issues/131 - language-javascript-0.7.0.0 -- git: https://github.com/hspec/hspec.git - commit: 8f628c861d01ec8fc0a94ffdfe31e4399bd049d1 - subdirs: - - . - - hspec-core - - hspec-discover +# The ./.hspec file uses the --times flag, which was added in hspec-2.8.0. +# LTS-18 has only hspec-2.7. +- hspec-2.8.3 +- hspec-core-2.8.3 +- hspec-discover-2.8.3 nix: enable: false packages: From 7d286f8d7ded989c482cade4d78212bf3e03160f Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Fri, 12 Nov 2021 16:24:08 -0500 Subject: [PATCH 1396/1580] Prevent hangs on internal errors (#4126) --- CHANGELOG.d/internal_fix-internal-error-hangs.md | 1 + src/Language/PureScript/Make.hs | 10 +++++++++- 2 files changed, 10 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/internal_fix-internal-error-hangs.md diff --git a/CHANGELOG.d/internal_fix-internal-error-hangs.md b/CHANGELOG.d/internal_fix-internal-error-hangs.md new file mode 100644 index 0000000000..3f342678da --- /dev/null +++ b/CHANGELOG.d/internal_fix-internal-error-hangs.md @@ -0,0 +1 @@ +* Prevent hangs on internal errors diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 2f4065d717..94e5bbd73e 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -12,11 +12,12 @@ module Language.PureScript.Make import Prelude.Compat import Control.Concurrent.Lifted as C +import Control.Exception.Base (onException) import Control.Monad hiding (sequence) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class import Control.Monad.Supply -import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Control.Monad.Trans.Control (MonadBaseControl(..), control) import Control.Monad.Trans.State (runStateT) import Control.Monad.Writer.Class (MonadWriter(..), censor) import Control.Monad.Writer.Strict (runWriterT) @@ -146,6 +147,10 @@ make ma@MakeActions{..} ms = do (fmap importPrim . snd $ CST.resFull m) (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted) + -- Prevent hanging on other modules when there is an internal error + -- (the exception is thrown, but other threads waiting on MVars are released) + `onExceptionLifted` BuildPlan.markComplete buildPlan moduleName (BuildJobFailed mempty) + -- Wait for all threads to complete, and collect results (and errors). (failures, successes) <- let @@ -237,6 +242,9 @@ make ma@MakeActions{..} ms = do BuildPlan.markComplete buildPlan moduleName result + onExceptionLifted :: m a -> m b -> m a + onExceptionLifted l r = control $ \runInIO -> runInIO l `onException` runInIO r + -- | Infer the module name for a module by looking for the same filename with -- a .js extension. inferForeignModules From 8c5ef9beb8c659e349ec295afd87995acf7bfeb0 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sat, 13 Nov 2021 10:38:15 -0800 Subject: [PATCH 1397/1580] Expand Layout.hs module docs (#4197) * Add more detailed summary of Layout.hs * Use multiple let bindings in indentation example * Simplify 1st paragraph --- .../src/Language/PureScript/CST/Layout.hs | 152 +++++++++++++++++- 1 file changed, 150 insertions(+), 2 deletions(-) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs b/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs index 61b6d38b5f..2b32704373 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs @@ -1,4 +1,11 @@ --- | The parser itself is unaware of indentation, and instead only parses explicit +-- | +-- ## High-Level Summary +-- +-- This section provides a high-level summary of this file. For those who +-- know more about compiler-development, the below explanation is likely enough. +-- For everyone else, see the next section. +-- +-- The parser itself is unaware of indentation, and instead only parses explicit -- delimiters which are inserted by this layout algorithm (much like Haskell). -- This is convenient because the actual grammar can be specified apart from the -- indentation rules. Haskell has a few problematic productions which make it @@ -17,7 +24,148 @@ -- such an algorithm. Unquoted properties for layout keywords introduce a domino -- effect of complexity since we have to mask and unmask any usage of . (also in -- foralls!) or labels in record literals. - +-- +-- ## Detailed Summary +-- +-- ### The Problem +-- +-- The parser itself is unaware of indentation or other such layout concerns. +-- Rather than dealing with it explicitly, the parser and its +-- grammar rules are only aware of normal tokens (e.g. @TokLowerName@) and +-- three special zero-width tokens, @TokLayoutStart@, @TokLayoutSep@, +-- and @TokLayoutEnd@. This is convenient because the actual grammar +-- can be specified apart from the indentation rules and other such +-- layout concerns. +-- +-- For a simple example, the parser parses all three examples of the code below +-- using the exact same grammar rules for the @let@ keyword despite +-- each example using different indentations levels: +-- +-- @ +-- -- Example 1 +-- let foo = 5 +-- x = 2 in foo +-- +-- -- Example 2 +-- let +-- bar = 5 +-- y = 2 +-- in bar +-- +-- -- Example 3 +-- let baz +-- = +-- 5 +-- z= 2 in baz +-- @ +-- +-- Each block of code might appear to the parser as a stream of the +-- following source tokens where the @\{@ sequence represents +-- @TokLayoutStart@, the @\;@ sequence represents @TokLayoutSep@, +-- and the @\}@ sequence represents @TokLayoutEnd@: +-- - @let \{foo = 5\;x = 2\} in foo@ +-- - @let \{bar = 5\;y = 2\} in bar@ +-- - @let \{baz = 5\;z = 2\} in baz@ +-- +-- +-- For a more complex example, consider commas: +-- +-- @ +-- case one, { twoA, twoB }, [ three1 +-- , three2 +-- , do +-- { three3, three4 } <- case arg1, arg2 of +-- Nothing, _ -> { three3: 1, three4: 2 } +-- Just _, Nothing -> { three3: 2, three4: 3 } +-- _, _ -> { three3: 3, three4: 4 } +-- pure $ three3 + three4 +-- ] of +-- @ +-- +-- Which of the above 13 commas function as the separaters between the +-- case binders (e.g. @one@) in the outermost @case ... of@ context? +-- +-- ### The Solution +-- +-- The parser doesn't have to care about layout concerns (e.g. indentation +-- or what starts and ends a context, such as a case binder) because the +-- lexer solves that problem instead. +-- +-- So, how does the lexer solve this problem? It follows this general algorithm: +-- 1. Lex the source code text into an initial stream of `SourceToken`s +-- that do not have any of the three special tokens mentioned previously. +-- 2. On a token-by-token basis, determine whether the lexer should +-- 1. insert one of the three special tokens, +-- 2. modify the current context (e.g. are we within a case binder? +-- Are we in a record expression?) +-- +-- Step 2 is handled via 'insertLayout' and is essentially a state machine. +-- The layout delimiters, (e.g. 'LytCase', 'LytBrace', 'LytProperty', +-- and 'LytOf' in the next section's example) either stop certain "rules" +-- from applying or ensure that certain "rules" now apply. By "rules", +-- we mean whether and where one of the three special tokens are added. +-- The comments in the source code for the 'insertLayout' algorithm call +-- pushing these delimiters onto the stack "masking" and popping them off +-- as "unmasking". Seeing when a layout delimiter is pushed and popped +-- are the keys to understanding this algorithm. +-- +-- ### Walking Through an Example +-- +-- Before showing an example, let's remember a few things. +-- 1. The @TokLowerName "case"@ token (i.e. a "case" keyword) indicates the start +-- of a @case ... of@ context. That context includes case binders (like the +-- example shown previously) that can get quite complex. When encountered, +-- we may need to insert one or more of the three special tokens here +-- until we encounter the terminating @TokLowerName "of"@ token that +-- signifies its end. +-- 2. "case" and "of" can also appear as a record field's name. In such a context, +-- they would not start or end a @case ... of@ block. +-- +-- Given the below source code... +-- +-- @ +-- case { case: "foo", of: "bar" } of +-- @ +-- +-- the lexer would go through something like the following states: +-- 1. Encountered @TokLowerName "case"@. Update current context to +-- "within a case of expression" by pushing the 'LytCase' delimiter +-- onto the layout delimiter stack. Insert the @case@ token +-- into the stream of source tokens. +-- 2. Encountered @TokLeftBrace@. Update current context to +-- "within a record expression" by pushing the 'LytBrace' delimiter. +-- Since we expect a field name to be the next token we see, +-- which may include a reserved keyword, update the current context again to +-- "expecting a field name" by pushing the `LytProperty`. +-- delimiter. Insert the @{@ token into the stream of source tokens. +-- 3. Encountered @TokLowerName "case"@. Check the current context. +-- Since it's a `LytProperty`, this is a field name and we shouldn't +-- assume that the next few tokens will be case binders. However, +-- since this might be a record with no more fields, update the +-- current context back to "within a record expression" by popping +-- the `LytProperty` off the layout delimiter stack. Insert the @case@ token +-- 4. Encountered @TokColon@. Insert the @:@ token +-- 5. Encountered @TokLowerName "foo"@. Insert the @foo@ token. +-- 6. Encountered @TokComma@. Check the current context. Since it's a `LytBrace`, +-- we're in a record expression and there is another field. Update the +-- current context by pushing `LytProperty` as we expect a field name again. +-- 7. Encountered @TokLowerName "of"@. Check the current context. +-- Since it's a `LytProperty`, this is a field name rather +-- than the end of a case binder. Thus, we don't expect the next tokens +-- to be the @body@ in a @case ... of body@ expression. However, since +-- this might be a record with no more fields, update the current context +-- back to "within a record expression" by popping the `LytProperty` +-- off the stack. Insert the @of@ token. +-- 8. Encountered @TokRightBrace@. Check the current context. +-- Since it's a `LytBrace`, this is the end of a record expression. +-- Update the current context to "within a case of expression" +-- by popping the `LytBrace` off the stack. Insert the @}@ token. +-- 9. Encountered @TokLowername "of"@. Check the current context. +-- Since it's a 'LytCase', this is the end of a @case ... of@ expression +-- and the body will follow. Update the current context to +-- "body of a case of expression" by pushing 'LytOf' onto the layout stack. +-- Insert the @of@ token into the stream of tokens. +-- module Language.PureScript.CST.Layout where import Prelude From 375bcdce4fc3d98bbac44dc63292ef86e9b3ecbc Mon Sep 17 00:00:00 2001 From: Cyril Sobierajewicz Date: Tue, 16 Nov 2021 07:05:52 +0100 Subject: [PATCH 1398/1580] Check role declarations arity during type checking (#4157) * Check role declarations arity during type checking * Add changelog entry * fixup! Check role declarations arity during type checking * Eliminate redundant declaration hints from error messages --- ...-declarations-arity-during-typechecking.md | 1 + .../Language/PureScript/AST/Declarations.hs | 1 + .../src/Language/PureScript/Environment.hs | 7 +- src/Language/PureScript/Errors.hs | 11 ++ .../PureScript/Sugar/BindingGroups.hs | 13 ++- .../PureScript/Sugar/TypeDeclarations.hs | 13 --- src/Language/PureScript/TypeChecker.hs | 47 ++++---- src/Language/PureScript/TypeChecker/Roles.hs | 103 +++++++++++------- tests/purs/failing/CoercibleRoleMismatch1.out | 3 +- tests/purs/failing/CoercibleRoleMismatch2.out | 3 +- tests/purs/failing/CoercibleRoleMismatch3.out | 3 +- tests/purs/failing/CoercibleRoleMismatch4.out | 3 +- tests/purs/failing/CoercibleRoleMismatch5.out | 3 +- .../failing/RoleDeclarationArityMismatch.out | 1 + .../RoleDeclarationArityMismatchForeign.out | 1 + .../RoleDeclarationArityMismatchForeign2.out | 11 ++ .../RoleDeclarationArityMismatchForeign2.purs | 5 + .../RoleDeclarationArityMismatchForeign3.out | 11 ++ .../RoleDeclarationArityMismatchForeign3.purs | 5 + .../RoleDeclarationArityMismatchForeign4.out | 11 ++ .../RoleDeclarationArityMismatchForeign4.purs | 7 ++ tests/purs/warning/2140.out | 1 - 22 files changed, 169 insertions(+), 95 deletions(-) create mode 100644 CHANGELOG.d/fix_check-role-declarations-arity-during-typechecking.md create mode 100644 tests/purs/failing/RoleDeclarationArityMismatchForeign2.out create mode 100644 tests/purs/failing/RoleDeclarationArityMismatchForeign2.purs create mode 100644 tests/purs/failing/RoleDeclarationArityMismatchForeign3.out create mode 100644 tests/purs/failing/RoleDeclarationArityMismatchForeign3.purs create mode 100644 tests/purs/failing/RoleDeclarationArityMismatchForeign4.out create mode 100644 tests/purs/failing/RoleDeclarationArityMismatchForeign4.purs diff --git a/CHANGELOG.d/fix_check-role-declarations-arity-during-typechecking.md b/CHANGELOG.d/fix_check-role-declarations-arity-during-typechecking.md new file mode 100644 index 0000000000..2c85dcd867 --- /dev/null +++ b/CHANGELOG.d/fix_check-role-declarations-arity-during-typechecking.md @@ -0,0 +1 @@ +* Check role declarations arity during type checking diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs index aeec4d187e..7fe131733c 100644 --- a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs @@ -97,6 +97,7 @@ data HintCategory | CheckHint | PositionHint | SolverHint + | DeclarationHint | OtherHint deriving (Show, Eq) diff --git a/lib/purescript-cst/src/Language/PureScript/Environment.hs b/lib/purescript-cst/src/Language/PureScript/Environment.hs index e6227054db..0e7e5731c0 100644 --- a/lib/purescript-cst/src/Language/PureScript/Environment.hs +++ b/lib/purescript-cst/src/Language/PureScript/Environment.hs @@ -35,11 +35,6 @@ data Environment = Environment , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) -- ^ Data constructors currently in scope, along with their associated type -- constructor name, argument types and return type. - , roleDeclarations :: M.Map (Qualified (ProperName 'TypeName)) [Role] - -- ^ Explicit role declarations currently in scope. Note that this field is - -- only used to store declared roles temporarily until they can be checked; - -- to find a type's real checked and/or inferred roles, refer to the TypeKind - -- in the `types` field. , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType) -- ^ Type synonyms currently in scope , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) @@ -103,7 +98,7 @@ instance A.ToJSON FunctionalDependency where -- | The initial environment with no values and only the default javascript types defined initEnvironment :: Environment -initEnvironment = Environment M.empty allPrimTypes M.empty M.empty M.empty M.empty allPrimClasses +initEnvironment = Environment M.empty allPrimTypes M.empty M.empty M.empty allPrimClasses -- | A constructor for TypeClassData that computes which type class arguments are fully determined -- and argument covering sets. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 3a61b15ef8..14c7798476 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1675,6 +1675,17 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl hintCategory ErrorCheckingKind{} = CheckHint hintCategory ErrorSolvingConstraint{} = SolverHint hintCategory PositionedError{} = PositionHint + hintCategory ErrorInDataConstructor{} = DeclarationHint + hintCategory ErrorInTypeConstructor{} = DeclarationHint + hintCategory ErrorInBindingGroup{} = DeclarationHint + hintCategory ErrorInDataBindingGroup{} = DeclarationHint + hintCategory ErrorInTypeSynonym{} = DeclarationHint + hintCategory ErrorInValueDeclaration{} = DeclarationHint + hintCategory ErrorInTypeDeclaration{} = DeclarationHint + hintCategory ErrorInTypeClassDeclaration{} = DeclarationHint + hintCategory ErrorInKindDeclaration{} = DeclarationHint + hintCategory ErrorInRoleDeclaration{} = DeclarationHint + hintCategory ErrorInForeignImport{} = DeclarationHint hintCategory _ = OtherHint prettyPrintPlainIdent :: Ident -> Text diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 3d57bf349c..67f78ce96d 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -18,6 +18,7 @@ import Data.Graph import Data.List (intersect, (\\)) import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty) import Data.Foldable (find) +import Data.Functor (($>)) import Data.Maybe (isJust, mapMaybe) import qualified Data.List.NonEmpty as NEL import qualified Data.Set as S @@ -32,6 +33,7 @@ import Language.PureScript.Types data VertexType = VertexDefinition | VertexKindSignature + | VertexRoleDeclaration deriving (Eq, Ord, Show) -- | @@ -67,10 +69,12 @@ createBindingGroups moduleName = mapM f <=< handleDecls let values = mapMaybe (fmap (fmap extractGuardedExpr) . getValueDeclaration) ds kindDecls = (,VertexKindSignature) <$> filter isKindDecl ds dataDecls = (,VertexDefinition) <$> filter (\a -> isDataDecl a || isExternDataDecl a || isTypeSynonymDecl a || isTypeClassDecl a) ds + roleDecls = (,VertexRoleDeclaration) <$> filter isRoleDecl ds + roleAnns = declTypeName . fst <$> roleDecls kindSigs = declTypeName . fst <$> kindDecls typeSyns = declTypeName <$> filter isTypeSynonymDecl ds nonTypeSynKindSigs = kindSigs \\ typeSyns - allDecls = kindDecls ++ dataDecls + allDecls = kindDecls ++ dataDecls ++ roleDecls allProperNames = declTypeName . fst <$> allDecls mkVert (d, vty) = let names = usedTypeNames moduleName d `intersect` allProperNames @@ -91,7 +95,10 @@ createBindingGroups moduleName = mapM f <=< handleDecls | otherwise = VertexDefinition deps = fmap (\n -> (n, vtype n)) names self - | vty == VertexDefinition && name `elem` kindSigs = [(name, VertexKindSignature)] + | vty == VertexDefinition = + (guard (name `elem` kindSigs) $> (name, VertexKindSignature)) + ++ (guard (name `elem` roleAnns && not (isExternDataDecl d)) $> (name, VertexRoleDeclaration)) + | vty == VertexRoleDeclaration = [(name, VertexDefinition)] | otherwise = [] in (d, (name, vty), self ++ deps) dataVerts = fmap mkVert allDecls @@ -100,7 +107,6 @@ createBindingGroups moduleName = mapM f <=< handleDecls valueVerts = fmap (\d -> (d, valdeclIdent d, usedIdents moduleName d `intersect` allIdents)) values bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName) return $ filter isImportDecl ds ++ - filter isRoleDecl ds ++ dataBindingGroupDecls ++ filter isTypeClassInstanceDecl ds ++ filter isFixityDecl ds ++ @@ -188,6 +194,7 @@ declTypeName (ExternDataDeclaration _ pn _) = pn declTypeName (TypeSynonymDeclaration _ pn _ _) = pn declTypeName (TypeClassDeclaration _ pn _ _ _ _) = coerceProperName pn declTypeName (KindDeclaration _ _ pn _) = pn +declTypeName (RoleDeclaration (RoleDeclarationData _ pn _)) = pn declTypeName _ = internalError "Expected DataDeclaration" -- | diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 3936aa5566..19c0abbdd5 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -81,7 +81,6 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) = checkRoleDeclarations (Just d) (rd@(RoleDeclaration RoleDeclarationData{..}) : rest) = do unless (matchesDeclaration d) . throwError . errorMessage' (fst rdeclSourceAnn) $ OrphanRoleDeclaration rdeclIdent unless (isSupported d) . throwError . errorMessage' (fst rdeclSourceAnn) $ UnsupportedRoleDeclaration - checkRoleDeclarationArity d checkRoleDeclarations (Just rd) rest where isSupported :: Declaration -> Bool @@ -94,17 +93,5 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) = matchesDeclaration (TypeSynonymDeclaration _ name' _ _) = rdeclIdent == name' matchesDeclaration (TypeClassDeclaration _ name' _ _ _ _) = rdeclIdent == coerceProperName name' matchesDeclaration _ = False - checkRoleDeclarationArity :: Declaration -> m () - checkRoleDeclarationArity (DataDeclaration _ _ _ args _) = - throwRoleDeclarationArityMismatch $ length args - checkRoleDeclarationArity (ExternDataDeclaration _ _ kind) = - throwRoleDeclarationArityMismatch $ kindArity kind - checkRoleDeclarationArity _ = return () - throwRoleDeclarationArityMismatch :: Int -> m () - throwRoleDeclarationArityMismatch expected = do - let actual = length rdeclRoles - unless (expected == actual) $ - throwError . errorMessage' (fst rdeclSourceAnn) $ - RoleDeclarationArityMismatch rdeclIdent expected actual checkRoleDeclarations _ (d : rest) = checkRoleDeclarations (Just d) rest checkRoleDeclarations _ [] = return () diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 9f75efd258..6f3846d4a4 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -84,19 +84,25 @@ addDataConstructor moduleName dtype name dctor dctorArgs polyType = do checkTypeSynonyms polyType putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } --- | Add an explicit role declaration to the Environment. The idea is that we --- do this before encountering the data type which it refers to; we don't check --- that the role declaration is valid until we encounter the data type's own --- declaration. -addExplicitRoleDeclaration - :: (MonadState CheckState m, MonadError MultipleErrors m) +checkRoleDeclaration + :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName - -> ProperName 'TypeName - -> [Role] + -> RoleDeclarationData -> m () -addExplicitRoleDeclaration moduleName name roles = do - env <- getEnv - putEnv $ env { roleDeclarations = M.insert (Qualified (Just moduleName) name) roles (roleDeclarations env) } +checkRoleDeclaration moduleName (RoleDeclarationData (ss, _) name declaredRoles) = do + warnAndRethrow (addHint (ErrorInRoleDeclaration name) . addHint (positionedError ss)) $ do + env <- getEnv + let qualName = Qualified (Just moduleName) name + case M.lookup qualName (types env) of + Just (kind, DataType dtype args dctors) -> do + checkRoleDeclarationArity name declaredRoles (length args) + checkRoles args declaredRoles + let args' = zipWith (\(v, k, _) r -> (v, k, r)) args declaredRoles + putEnv $ env { types = M.insert qualName (kind, DataType dtype args' dctors) (types env) } + Just (kind, ExternData _) -> do + checkRoleDeclarationArity name declaredRoles (kindArity kind) + putEnv $ env { types = M.insert qualName (kind, ExternData declaredRoles) (types env) } + _ -> internalError "Unsupported role declaration" addTypeSynonym :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) @@ -282,14 +288,14 @@ typeCheckAll moduleName _ = traverse go let args' = args `withKinds` ctorKind env <- getEnv dctors' <- traverse (replaceTypeSynonymsInDataConstructor . fst) dataCtors - roles <- checkRoles env moduleName name args' dctors' - let args'' = args' `withRoles` roles + let args'' = args' `withRoles` inferRoles env moduleName name args' dctors' addDataType moduleName dtype name args'' dataCtors ctorKind return $ DataDeclaration sa dtype name args dctors go d@(DataBindingGroupDeclaration tys) = do let tysList = NEL.toList tys syns = mapMaybe toTypeSynonym tysList dataDecls = mapMaybe toDataDecl tysList + roleDecls = mapMaybe toRoleDecl tysList clss = mapMaybe toClassDecl tysList bindingGroupNames = ordNub ((syns^..traverse._2) ++ (dataDecls^..traverse._2._2) ++ fmap coerceProperName (clss^..traverse._2._2)) sss = fmap declSourceSpan tys @@ -302,15 +308,15 @@ typeCheckAll moduleName _ = traverse go addTypeSynonym moduleName name args' elabTy kind let dataDeclsWithKinds = zipWith (\(dtype, (_, name, args, _)) (dataCtors, ctorKind) -> (dtype, name, args `withKinds` ctorKind, dataCtors, ctorKind)) dataDecls data_ks - checkRoles' <- fmap (checkDataBindingGroupRoles env moduleName) . + inferRoles' <- fmap (inferDataBindingGroupRoles env moduleName roleDecls) . forM dataDeclsWithKinds $ \(_, name, args, dataCtors, _) -> (name, args,) <$> traverse (replaceTypeSynonymsInDataConstructor . fst) dataCtors for_ dataDeclsWithKinds $ \(dtype, name, args', dataCtors, ctorKind) -> do when (dtype == Newtype) $ checkNewtype name (map fst dataCtors) checkDuplicateTypeArguments $ map fst args' - roles <- checkRoles' name args' - let args'' = args' `withRoles` roles + let args'' = args' `withRoles` inferRoles' name args' addDataType moduleName dtype name args'' dataCtors ctorKind + for_ roleDecls $ checkRoleDeclaration moduleName for_ (zip clss cls_ks) $ \((deps, (sa, pn, _, _, _)), (args', implies', tys', kind)) -> do let qualifiedClassName = Qualified (Just moduleName) pn guardWith (errorMessage (DuplicateTypeClass pn (fst sa))) $ @@ -322,6 +328,8 @@ typeCheckAll moduleName _ = traverse go toTypeSynonym _ = Nothing toDataDecl (DataDeclaration sa dtype nm args dctors) = Just (dtype, (sa, nm, args, dctors)) toDataDecl _ = Nothing + toRoleDecl (RoleDeclaration rdd) = Just rdd + toRoleDecl _ = Nothing toClassDecl (TypeClassDeclaration sa nm args implies deps decls) = Just (deps, (sa, nm, args, implies, decls)) toClassDecl _ = Nothing go (TypeSynonymDeclaration sa@(ss, _) name args ty) = do @@ -337,8 +345,8 @@ typeCheckAll moduleName _ = traverse go env <- getEnv putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (elabTy, LocalTypeVariable) (types env) } return $ KindDeclaration sa kindFor name elabTy - go d@(RoleDeclaration (RoleDeclarationData _sa name roles)) = do - addExplicitRoleDeclaration moduleName name roles + go d@(RoleDeclaration rdd) = do + checkRoleDeclaration moduleName rdd return d go TypeDeclaration{} = internalError "Type declarations should have been removed before typeCheckAlld" @@ -374,8 +382,7 @@ typeCheckAll moduleName _ = traverse go elabKind <- withFreshSubstitution $ checkKindDeclaration moduleName kind env <- getEnv let qualName = Qualified (Just moduleName) name - -- If there's an explicit role declaration, just trust it - let roles = fromMaybe (nominalRolesForKind elabKind) $ M.lookup qualName (roleDeclarations env) + roles = nominalRolesForKind elabKind putEnv $ env { types = M.insert qualName (elabKind, ExternData roles) (types env) } return d go d@(ExternDeclaration (ss, _) name ty) = do diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index 4c283a0972..4366afb2f1 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -6,11 +6,15 @@ module Language.PureScript.TypeChecker.Roles ( lookupRoles , checkRoles - , checkDataBindingGroupRoles + , checkRoleDeclarationArity + , inferRoles + , inferDataBindingGroupRoles ) where import Prelude.Compat +import Control.Arrow ((&&&)) +import Control.Monad (unless, when, zipWithM_) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State (MonadState(..), runState, state) import Data.Coerce (coerce) @@ -80,18 +84,42 @@ lookupRoles lookupRoles env tyName = fromMaybe [] $ M.lookup tyName (types env) >>= typeKindRoles . snd --- | This function does the following: --- --- * Infers roles for the given data type declaration --- --- * Compares the inferred roles to the explicitly declared roles (if any) and --- ensures that the explicitly declared roles are not more permissive than --- the inferred ones +-- | +-- Compares the inferred roles to the explicitly declared roles and ensures +-- that the explicitly declared roles are not more permissive than the +-- inferred ones. -- checkRoles :: forall m . (MonadError MultipleErrors m) - => Environment + => [(Text, Maybe SourceType, Role)] + -- ^ type parameters for the data type whose roles we are checking + -> [Role] + -- ^ roles declared for the data type + -> m () +checkRoles tyArgs declaredRoles = do + let k (var, _, inf) dec = + when (inf < dec) . throwError . errorMessage $ RoleMismatch var inf dec + zipWithM_ k tyArgs declaredRoles + +checkRoleDeclarationArity + :: forall m + . (MonadError MultipleErrors m) + => ProperName 'TypeName + -> [Role] + -> Int + -> m () +checkRoleDeclarationArity tyName roles expected = do + let actual = length roles + unless (expected == actual) $ + throwError . errorMessage $ + RoleDeclarationArityMismatch tyName expected actual + +-- | +-- Infers roles for the given data type declaration. +-- +inferRoles + :: Environment -> ModuleName -> ProperName 'TypeName -- ^ The name of the data type whose roles we are checking @@ -99,9 +127,27 @@ checkRoles -- ^ type parameters for the data type whose roles we are checking -> [DataConstructorDeclaration] -- ^ constructors of the data type whose roles we are checking - -> m [Role] -checkRoles env moduleName tyName tyArgs ctors = - checkDataBindingGroupRoles env moduleName [(tyName, tyArgs, ctors)] tyName tyArgs + -> [Role] +inferRoles env moduleName tyName tyArgs ctors = + inferDataBindingGroupRoles env moduleName [] [(tyName, tyArgs, ctors)] tyName tyArgs + +inferDataBindingGroupRoles + :: Environment + -> ModuleName + -> [RoleDeclarationData] + -> [DataDeclaration] + -> ProperName 'TypeName + -> [(Text, Maybe SourceType)] + -> [Role] +inferDataBindingGroupRoles env moduleName roleDeclarations group = + let declaredRoleEnv = M.fromList $ map (Qualified (Just moduleName) . rdeclIdent &&& rdeclRoles) roleDeclarations + inferredRoleEnv = getRoleEnv env + initialRoleEnv = declaredRoleEnv `M.union` inferredRoleEnv + inferredRoleEnv' = inferDataBindingGroupRoles' moduleName group initialRoleEnv + in \tyName tyArgs -> + let qualTyName = Qualified (Just moduleName) tyName + inferredRoles = M.lookup qualTyName inferredRoleEnv' + in fromMaybe (Phantom <$ tyArgs) inferredRoles type DataDeclaration = ( ProperName 'TypeName @@ -109,43 +155,16 @@ type DataDeclaration = , [DataConstructorDeclaration] ) -checkDataBindingGroupRoles - :: forall m - . (MonadError MultipleErrors m) - => Environment - -> ModuleName - -> [DataDeclaration] - -> ProperName 'TypeName - -> [(Text, Maybe SourceType)] - -> m [Role] -checkDataBindingGroupRoles env moduleName group = - let initialRoleEnv = M.union (roleDeclarations env) (getRoleEnv env) - inferredRoleEnv = inferDataBindingGroupRoles moduleName group initialRoleEnv - in \tyName tyArgs -> do - let qualTyName = Qualified (Just moduleName) tyName - inferredRoles = M.lookup qualTyName inferredRoleEnv - rethrow (addHint (ErrorInRoleDeclaration tyName)) $ do - case M.lookup qualTyName (roleDeclarations env) of - Just declaredRoles -> do - let - k (var, _) inf dec = - if inf < dec - then throwError . errorMessage $ RoleMismatch var inf dec - else pure dec - sequence $ zipWith3 k tyArgs (fromMaybe (repeat Phantom) inferredRoles) declaredRoles - Nothing -> - pure $ fromMaybe (Phantom <$ tyArgs) inferredRoles - -inferDataBindingGroupRoles +inferDataBindingGroupRoles' :: ModuleName -> [DataDeclaration] -> RoleEnv -> RoleEnv -inferDataBindingGroupRoles moduleName group roleEnv = +inferDataBindingGroupRoles' moduleName group roleEnv = let (Any didRolesChange, roleEnv') = flip runState roleEnv $ mconcat <$> traverse (state . inferDataDeclarationRoles moduleName) group in if didRolesChange - then inferDataBindingGroupRoles moduleName group roleEnv' + then inferDataBindingGroupRoles' moduleName group roleEnv' else roleEnv' -- | diff --git a/tests/purs/failing/CoercibleRoleMismatch1.out b/tests/purs/failing/CoercibleRoleMismatch1.out index 5f9ba80805..bdfe5f8970 100644 --- a/tests/purs/failing/CoercibleRoleMismatch1.out +++ b/tests/purs/failing/CoercibleRoleMismatch1.out @@ -1,6 +1,6 @@ Error found: in module Main -at tests/purs/failing/CoercibleRoleMismatch1.purs:4:1 - 4:29 (line 4, column 1 - line 4, column 29) +at tests/purs/failing/CoercibleRoleMismatch1.purs:6:1 - 6:27 (line 6, column 1 - line 6, column 27) Role mismatch for the type parameter a: @@ -8,7 +8,6 @@ at tests/purs/failing/CoercibleRoleMismatch1.purs:4:1 - 4:29 (line 4, column 1 - in role declaration for Identity -in type constructor Identity See https://github.com/purescript/documentation/blob/master/errors/RoleMismatch.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/CoercibleRoleMismatch2.out b/tests/purs/failing/CoercibleRoleMismatch2.out index aded3eef96..c4e42541fb 100644 --- a/tests/purs/failing/CoercibleRoleMismatch2.out +++ b/tests/purs/failing/CoercibleRoleMismatch2.out @@ -1,6 +1,6 @@ Error found: in module Main -at tests/purs/failing/CoercibleRoleMismatch2.purs:8:1 - 8:23 (line 8, column 1 - line 8, column 23) +at tests/purs/failing/CoercibleRoleMismatch2.purs:10:1 - 10:20 (line 10, column 1 - line 10, column 20) Role mismatch for the type parameter a: @@ -8,7 +8,6 @@ at tests/purs/failing/CoercibleRoleMismatch2.purs:8:1 - 8:23 (line 8, column 1 - in role declaration for V -in type constructor V See https://github.com/purescript/documentation/blob/master/errors/RoleMismatch.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/CoercibleRoleMismatch3.out b/tests/purs/failing/CoercibleRoleMismatch3.out index 45c82181bb..f9ee257468 100644 --- a/tests/purs/failing/CoercibleRoleMismatch3.out +++ b/tests/purs/failing/CoercibleRoleMismatch3.out @@ -1,6 +1,6 @@ Error found: in module Main -at tests/purs/failing/CoercibleRoleMismatch3.purs:8:1 - 8:23 (line 8, column 1 - line 8, column 23) +at tests/purs/failing/CoercibleRoleMismatch3.purs:10:1 - 10:29 (line 10, column 1 - line 10, column 29) Role mismatch for the type parameter a: @@ -8,7 +8,6 @@ at tests/purs/failing/CoercibleRoleMismatch3.purs:8:1 - 8:23 (line 8, column 1 - in role declaration for U -in type constructor U See https://github.com/purescript/documentation/blob/master/errors/RoleMismatch.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/CoercibleRoleMismatch4.out b/tests/purs/failing/CoercibleRoleMismatch4.out index 853afeca35..2ea0f9b791 100644 --- a/tests/purs/failing/CoercibleRoleMismatch4.out +++ b/tests/purs/failing/CoercibleRoleMismatch4.out @@ -1,6 +1,6 @@ Error found: in module Main -at tests/purs/failing/CoercibleRoleMismatch4.purs:4:1 - 4:19 (line 4, column 1 - line 4, column 19) +at tests/purs/failing/CoercibleRoleMismatch4.purs:5:1 - 5:29 (line 5, column 1 - line 5, column 29) Role mismatch for the type parameter a: @@ -8,7 +8,6 @@ at tests/purs/failing/CoercibleRoleMismatch4.purs:4:1 - 4:19 (line 4, column 1 - in role declaration for F -in data binding group F, G See https://github.com/purescript/documentation/blob/master/errors/RoleMismatch.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/CoercibleRoleMismatch5.out b/tests/purs/failing/CoercibleRoleMismatch5.out index faabd7cc0e..c862f32351 100644 --- a/tests/purs/failing/CoercibleRoleMismatch5.out +++ b/tests/purs/failing/CoercibleRoleMismatch5.out @@ -1,6 +1,6 @@ Error found: in module Main -at tests/purs/failing/CoercibleRoleMismatch5.purs:4:1 - 4:21 (line 4, column 1 - line 4, column 21) +at tests/purs/failing/CoercibleRoleMismatch5.purs:5:1 - 5:20 (line 5, column 1 - line 5, column 20) Role mismatch for the type parameter a: @@ -8,7 +8,6 @@ at tests/purs/failing/CoercibleRoleMismatch5.purs:4:1 - 4:21 (line 4, column 1 - in role declaration for F -in data binding group F, G See https://github.com/purescript/documentation/blob/master/errors/RoleMismatch.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/RoleDeclarationArityMismatch.out b/tests/purs/failing/RoleDeclarationArityMismatch.out index 133673dd3b..17527a4706 100644 --- a/tests/purs/failing/RoleDeclarationArityMismatch.out +++ b/tests/purs/failing/RoleDeclarationArityMismatch.out @@ -4,6 +4,7 @@ at tests/purs/failing/RoleDeclarationArityMismatch.purs:5:1 - 5:20 (line 5, colu The type A expects 0 arguments but its role declaration lists 1 role. +in role declaration for A See https://github.com/purescript/documentation/blob/master/errors/RoleDeclarationArityMismatch.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/RoleDeclarationArityMismatchForeign.out b/tests/purs/failing/RoleDeclarationArityMismatchForeign.out index ad3c1378c9..81aa291b57 100644 --- a/tests/purs/failing/RoleDeclarationArityMismatchForeign.out +++ b/tests/purs/failing/RoleDeclarationArityMismatchForeign.out @@ -4,6 +4,7 @@ at tests/purs/failing/RoleDeclarationArityMismatchForeign.purs:5:1 - 5:20 (line The type A expects 0 arguments but its role declaration lists 1 role. +in role declaration for A See https://github.com/purescript/documentation/blob/master/errors/RoleDeclarationArityMismatch.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/RoleDeclarationArityMismatchForeign2.out b/tests/purs/failing/RoleDeclarationArityMismatchForeign2.out new file mode 100644 index 0000000000..ac07e8bea7 --- /dev/null +++ b/tests/purs/failing/RoleDeclarationArityMismatchForeign2.out @@ -0,0 +1,11 @@ +Error found: +in module Main +at tests/purs/failing/RoleDeclarationArityMismatchForeign2.purs:5:1 - 5:20 (line 5, column 1 - line 5, column 20) + + The type A expects 2 arguments but its role declaration lists only 1 role. + +in role declaration for A + +See https://github.com/purescript/documentation/blob/master/errors/RoleDeclarationArityMismatch.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RoleDeclarationArityMismatchForeign2.purs b/tests/purs/failing/RoleDeclarationArityMismatchForeign2.purs new file mode 100644 index 0000000000..3e35171ccc --- /dev/null +++ b/tests/purs/failing/RoleDeclarationArityMismatchForeign2.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith RoleDeclarationArityMismatch +module Main where + +foreign import data A :: Type -> (Type -> Type) +type role A nominal diff --git a/tests/purs/failing/RoleDeclarationArityMismatchForeign3.out b/tests/purs/failing/RoleDeclarationArityMismatchForeign3.out new file mode 100644 index 0000000000..0c02428e0e --- /dev/null +++ b/tests/purs/failing/RoleDeclarationArityMismatchForeign3.out @@ -0,0 +1,11 @@ +Error found: +in module Main +at tests/purs/failing/RoleDeclarationArityMismatchForeign3.purs:5:1 - 5:20 (line 5, column 1 - line 5, column 20) + + The type A expects 2 arguments but its role declaration lists only 1 role. + +in role declaration for A + +See https://github.com/purescript/documentation/blob/master/errors/RoleDeclarationArityMismatch.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RoleDeclarationArityMismatchForeign3.purs b/tests/purs/failing/RoleDeclarationArityMismatchForeign3.purs new file mode 100644 index 0000000000..1bcc9dc38c --- /dev/null +++ b/tests/purs/failing/RoleDeclarationArityMismatchForeign3.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith RoleDeclarationArityMismatch +module Main where + +foreign import data A :: (Type -> Type -> Type) +type role A nominal diff --git a/tests/purs/failing/RoleDeclarationArityMismatchForeign4.out b/tests/purs/failing/RoleDeclarationArityMismatchForeign4.out new file mode 100644 index 0000000000..911863747a --- /dev/null +++ b/tests/purs/failing/RoleDeclarationArityMismatchForeign4.out @@ -0,0 +1,11 @@ +Error found: +in module Main +at tests/purs/failing/RoleDeclarationArityMismatchForeign4.purs:7:1 - 7:20 (line 7, column 1 - line 7, column 20) + + The type A expects 2 arguments but its role declaration lists only 1 role. + +in role declaration for A + +See https://github.com/purescript/documentation/blob/master/errors/RoleDeclarationArityMismatch.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RoleDeclarationArityMismatchForeign4.purs b/tests/purs/failing/RoleDeclarationArityMismatchForeign4.purs new file mode 100644 index 0000000000..9d600c13ab --- /dev/null +++ b/tests/purs/failing/RoleDeclarationArityMismatchForeign4.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith RoleDeclarationArityMismatch +module Main where + +type To = Function + +foreign import data A :: To Type (To Type Type) +type role A nominal diff --git a/tests/purs/warning/2140.out b/tests/purs/warning/2140.out index 70b7e49701..3d81edd247 100644 --- a/tests/purs/warning/2140.out +++ b/tests/purs/warning/2140.out @@ -5,7 +5,6 @@ at tests/purs/warning/2140.purs:5:3 - 5:36 (line 5, column 3 - line 5, column 36 Type variable a was shadowed. in type declaration for f -in type class declaration for Test See https://github.com/purescript/documentation/blob/master/errors/ShadowedTypeVar.md for more information, or to contribute content related to this warning. From 6b2b2a9b7aacdb81d5f2e8ecf8d7fc523a7e6d00 Mon Sep 17 00:00:00 2001 From: Denis Stoyanov Date: Wed, 17 Nov 2021 21:08:22 +0200 Subject: [PATCH 1399/1580] Make `Quote` from `Prim.TypeError` polykinded (#4142) Co-authored-by: Jordan Martinez --- .../feature_make-quote-work-on-more-kinds.md | 1 + CONTRIBUTORS.md | 1 + .../src/Language/PureScript/Environment.hs | 2 +- src/Language/PureScript/Errors.hs | 2 +- ...rammablePolykindedTypeErrorsTypeString.out | 18 +++++++++++++++ ...ammablePolykindedTypeErrorsTypeString.purs | 23 +++++++++++++++++++ 6 files changed, 45 insertions(+), 2 deletions(-) create mode 100644 CHANGELOG.d/feature_make-quote-work-on-more-kinds.md create mode 100644 tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.out create mode 100644 tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.purs diff --git a/CHANGELOG.d/feature_make-quote-work-on-more-kinds.md b/CHANGELOG.d/feature_make-quote-work-on-more-kinds.md new file mode 100644 index 0000000000..7346df247d --- /dev/null +++ b/CHANGELOG.d/feature_make-quote-work-on-more-kinds.md @@ -0,0 +1 @@ +* Make `Prim.TypeError`'s `Quote` work on all kinds, not just kind `Type`. diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index ba0e3b1591..7f0b556ed7 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -149,6 +149,7 @@ If you would prefer to use different terms, please use the section below instead | [@mhmdanas](https://github.com/mhmdanas) | Mohammed Anas | [MIT license](http://opensource.org/licenses/MIT) | | [@kl0tl](https://github.com/kl0tl) | Cyril Sobierajewicz | [MIT license](http://opensource.org/licenses/MIT) | | [@PureFunctor](https://github.com/PureFunctor) | Justin Garcia | [MIT license](http://opensource.org/licenses/MIT) | +| [@xgrommx](https://github.com/xgrommx) | Denis Stoyanov | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/lib/purescript-cst/src/Language/PureScript/Environment.hs b/lib/purescript-cst/src/Language/PureScript/Environment.hs index 0e7e5731c0..db3dcdcd97 100644 --- a/lib/purescript-cst/src/Language/PureScript/Environment.hs +++ b/lib/purescript-cst/src/Language/PureScript/Environment.hs @@ -429,7 +429,7 @@ primTypeErrorTypes = , (primSubName C.typeError "Fail", (kindDoc -:> kindConstraint, ExternData [Nominal])) , (primSubName C.typeError "Warn", (kindDoc -:> kindConstraint, ExternData [Nominal])) , (primSubName C.typeError "Text", (kindSymbol -:> kindDoc, ExternData [Phantom])) - , (primSubName C.typeError "Quote", (kindType -:> kindDoc, ExternData [Phantom])) + , (primSubName C.typeError "Quote", (tyForall "k" kindType $ tyVar "k" -:> kindDoc, ExternData [Phantom])) , (primSubName C.typeError "QuoteLabel", (kindSymbol -:> kindDoc, ExternData [Phantom])) , (primSubName C.typeError "Beside", (kindDoc -:> kindDoc -:> kindDoc, ExternData [Phantom, Phantom])) , (primSubName C.typeError "Above", (kindDoc -:> kindDoc -:> kindDoc, ExternData [Phantom, Phantom])) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 14c7798476..7d5752f982 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1861,7 +1861,7 @@ toTypelevelString (TypeLevelString _ s) = Just . Box.text $ decodeStringWithReplacement s toTypelevelString (TypeApp _ (TypeConstructor _ f) x) | f == primSubName C.typeError "Text" = toTypelevelString x -toTypelevelString (TypeApp _ (TypeConstructor _ f) x) +toTypelevelString (TypeApp _ (KindApp _ (TypeConstructor _ f) _) x) | f == primSubName C.typeError "Quote" = Just (typeAsBox maxBound x) toTypelevelString (TypeApp _ (TypeConstructor _ f) (TypeLevelString _ x)) | f == primSubName C.typeError "QuoteLabel" = Just . line . prettyPrintLabel . Label $ x diff --git a/tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.out b/tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.out new file mode 100644 index 0000000000..4968c73575 --- /dev/null +++ b/tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.out @@ -0,0 +1,18 @@ +Error found: +in module Main +at tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.purs:23:7 - 23:17 (line 23, column 7 - line 23, column 17) + + A custom type error occurred while solving type class constraints: + + Don't want to show Just @Type String because. + + +while checking that type Fail (Beside (Beside (Text "Don\'t want to show ") (... ...)) (Text " because.")) => String + is at least as general as type String +while checking that expression someString + has type String +in value declaration main + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.purs b/tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.purs new file mode 100644 index 0000000000..575251c093 --- /dev/null +++ b/tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.purs @@ -0,0 +1,23 @@ +-- @shouldFailWith NoInstanceFound + +module Main where + +import Prelude +import Prim.TypeError +import Effect (Effect) +import Effect.Console (log) + +data Maybe :: forall k. k -> Type +data Maybe a + +foreign import data Nothing :: forall k. Maybe k +foreign import data Just :: forall k. k -> Maybe k + +someString :: Fail (Text "Don't want to show " <> Quote (Just String) <> Text " because.") => String +someString = "someString" + +infixl 6 type Beside as <> + +main :: Effect Unit +main = do + log someString From 2c78eb614cb1f3556737900e57d0e7395158791e Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Wed, 17 Nov 2021 13:27:33 -0800 Subject: [PATCH 1400/1580] Display roles in HTML docs (#4121) Including roles in markdown docs was not added in this PR. Markdown docs currently render their docs a specific way that would require reworking that part to fix. Most people don't use Markdown docs now that HTML docs are the norm, so this shouldn't be an issue. FFI declarations are converted to DataDeclarations so that we can still show their roles in their corresponding docs. See below for a longer explanation. Finally, all comments on kind signatures, declarations, and role declarations are merged together in the final docs. * Include role declarations in list of ordered exports * Insert roles in doc decl augmentation pass * Render role annotations in HTML docs but not markdown docs * Add test: verify expected role declarations match actual ones * Swap parameter order for renderRole * Link to roles page on doc repo when role annotation is clicked * Ensure inferred types are Text, not String * Don't mention values as some types are intentionally uninhabited * Ensure role page is opened in new window/tab * Render role as italics, sans-serif font with no underline * Make role links unbolded * Use clearer error message if add a 2nd role declaration to data decl * Add/refactor doc-comment merging tests to include role declarations * Ignore rather than crash when attempting to add role declarations to FFI * Rewrite addRoles so that it's stack-safe This commit also throws an internalError if two situations where it didn't previously. First, if the number of roles don't match the number of type vars. Second, if we somehow attempt to add another role to a type var that already has one. None of these should be possible by this point, but should it ever happen, it'll help us track down what went wrong. * Throw an error if we get an unexpected value for role annotation word * Include `RoleDeclaration`s in `declName` * Use one renderType with two faces to prevent code from unsyncing * Convert FFI declarations into data declaration FFI declarations (i.e. ExternDataDeclaration) are rendered using only their kind signature. Since roles are rendered by annotating the type parameters of a normal signature, we need to convert the FFI declarations to a data declaration, so that we can annotate that data declaration's type parameters with their corresponding roles. However, the FFI declaration does not have type parameters. Thus, we infer how many type parameters it implicitly has based on its kind signature and then generate a name for those type parameters. The generated names are easily distinguishable from developer-defined ones (e.g. `data Foo a b`) because they are generated via `t` and an 0-based index. When most developers typically use `a`, `b`, `f`, or `m` as the names of their type parameters (or more descriptive names like `container`), this different pattern will stand out and indicate that the type is an FFI data type * Insert inferred roles if none were explicitly declared * Insert inferred roles for data declarations This also inserts inferred roles for FFI declarations due to coming after the FFI conversion pass * Add test checking for role annotations for FFI data types * Use rhendric's rendering for role explanation (argument version) * Rename E to FFI to clarify type of declaration * Add tests for higher-kinded type parameters * Add tests for FFI declarations' kind signatures * Verify that FFI declarations with redundant parens are accounted for * Test all possible variations of doc comment merging * Update changelog to clarify the FFI declaration rendering situation * Add note: intentionally not dropping sort ann for explicit kind sigs * Fix typo Co-authored-by: Cyril * Re-enable FFI role declaration tests Co-authored-by: Cyril --- .../feature_display roles in html docs.md | 49 +++++++ app/static/pursuit.css | 21 +++ app/static/pursuit.less | 26 ++++ .../Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Docs/AsHtml.hs | 23 ++++ src/Language/PureScript/Docs/AsMarkdown.hs | 3 + src/Language/PureScript/Docs/Convert.hs | 87 +++++++++++- .../PureScript/Docs/Convert/Single.hs | 38 +++++- src/Language/PureScript/Docs/Prim.hs | 2 +- src/Language/PureScript/Docs/Render.hs | 9 +- .../Docs/RenderedCode/RenderType.hs | 78 ++++++++++- .../PureScript/Docs/RenderedCode/Types.hs | 12 ++ src/Language/PureScript/Docs/Types.hs | 28 +++- src/Language/PureScript/Pretty/Types.hs | 6 +- tests/TestDocs.hs | 129 ++++++++++++++---- tests/purs/docs/src/DocCommentsMerge.purs | 118 ++++++++++++++++ tests/purs/docs/src/KindSignatureDocs.purs | 35 +---- tests/purs/docs/src/RoleAnnotationDocs.purs | 36 +++++ 18 files changed, 622 insertions(+), 80 deletions(-) create mode 100644 CHANGELOG.d/feature_display roles in html docs.md create mode 100644 tests/purs/docs/src/DocCommentsMerge.purs create mode 100644 tests/purs/docs/src/RoleAnnotationDocs.purs diff --git a/CHANGELOG.d/feature_display roles in html docs.md b/CHANGELOG.d/feature_display roles in html docs.md new file mode 100644 index 0000000000..819b720ed0 --- /dev/null +++ b/CHANGELOG.d/feature_display roles in html docs.md @@ -0,0 +1,49 @@ +* Display role annotations in HTML docs + + Previously, the HTML docs would not indicate which types could be safely + coerced and which could not: + + ```purescript + -- cannot be coerced + data Foo1 a = Foo1 a + type role Foo1 nominal + + -- can be coerced + data Foo2 a = Foo2 + type role Foo2 phantom + + -- can be coerced in some contexts + data Foo3 a = Foo3 a + type role Foo3 representational + ``` + + The HTML docs now display the role annotations either explicitly + declared by the developer or those inferred by the compiler. + + Since role annotations are an advanced feature and since most type + parameters' roles are the `representational` role, the `phantom` and + `nominal` role annotations are displayed in documentation whereas the + `representational` role is not, similar to "uninteresting" kind signatures. + + Lastly, FFI declarations like below... + + ```purescript + foreign import data Foo :: (Type -> Type) -> Type + type role Foo nominal + ``` + + ...will be rendered as though they are data declarations: + + ```purescript + data Foo :: (Type -> Type) -> Type + data Foo t0 + type role Foo nominal + ``` + + One can distinguish FFI declarations with roles separately from normal `data` + declarations that have roles based on the name of the type parameters. Since FFI declarations' type parameters are implicit and thus unnamed, the compiler will generate their name: `t0`, `t1`, ..., `tN` where `N` is a zero-based + index of the type parameter. + + Note: the resulting documentation will display the roles, but the roles + will not be selectable when selecting the type in case one wants to + copy-paste the type into source code. diff --git a/app/static/pursuit.css b/app/static/pursuit.css index 709b859b54..eba6222be5 100644 --- a/app/static/pursuit.css +++ b/app/static/pursuit.css @@ -413,6 +413,27 @@ ol li { text-indent: -2.441em; white-space: normal; } +.decl__role { + font-family: "Roboto", sans-serif; + font-style: italic; + font-weight: normal; +} +/* See https://stackoverflow.com/a/32162038 + Content licensed under CC BY-SA 3.0 +*/ +.decl__role_hover[title] { + /* Remove line that appears under abbr element */ + border-bottom: none; + text-decoration: none; + /* Ensure cursor doesn't change to question mark */ + cursor: inherit; +} +.decl__role_nominal::after { + content: "nominal"; +} +.decl__role_phantom::after { + content: "phantom"; +} .decl__kind { border-bottom: 1px solid #cccccc; } diff --git a/app/static/pursuit.less b/app/static/pursuit.less index 7a9629f494..5358322d41 100644 --- a/app/static/pursuit.less +++ b/app/static/pursuit.less @@ -496,6 +496,32 @@ ol li { white-space: normal; } +.decl__role { + font-family: "Roboto", sans-serif; + font-style: italic; + font-weight: normal; +} + +/* See https://stackoverflow.com/a/32162038 + Content licensed under CC BY-SA 3.0 +*/ +.decl__role_hover[title] { + /* Remove line that appears under abbr element */ + border-bottom: none; + text-decoration: none; + + /* Ensure cursor doesn't change to question mark */ + cursor: inherit; +} + +.decl__role_nominal::after { + content: "nominal"; +} + +.decl__role_phantom::after { + content: "phantom"; +} + .decl__kind { border-bottom: 1px solid darken(@background, 20%); } diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs index 7fe131733c..cda9ca7488 100644 --- a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs @@ -505,13 +505,13 @@ declName (FixityDeclaration _ (Left (ValueFixity _ _ n))) = Just (ValOpName n) declName (FixityDeclaration _ (Right (TypeFixity _ _ n))) = Just (TyOpName n) declName (TypeClassDeclaration _ n _ _ _ _) = Just (TyClassName n) declName (TypeInstanceDeclaration _ _ _ n _ _ _ _) = IdentName <$> hush n +declName (RoleDeclaration RoleDeclarationData{..}) = Just (TyName rdeclIdent) declName ImportDeclaration{} = Nothing declName BindingGroupDeclaration{} = Nothing declName DataBindingGroupDeclaration{} = Nothing declName BoundValueDeclaration{} = Nothing declName KindDeclaration{} = Nothing declName TypeDeclaration{} = Nothing -declName RoleDeclaration{} = Nothing -- | -- Test if a declaration is a value declaration diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index 2cf625cc82..ed4e12498a 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -211,6 +211,29 @@ codeAsHtml r = outputWith elemAsHtml linkToDecl ns target mn (withClass class_ (text name)) NoLink -> text name + Role role -> + case role of + "nominal" -> renderRole describeNominal "decl__role_nominal" + "phantom" -> renderRole describePhantom "decl__role_phantom" + + -- representational is intentionally not rendered + "representational" -> toHtml ("" :: Text) + + x -> P.internalError $ "codeAsHtml: unknown value for role annotation: '" <> T.unpack x <> "'" + where + renderRole hoverTextContent className = + H.a ! A.href (v docRepoRolePage) ! A.target (v "_blank") ! A.class_ "decl__role" $ do + H.abbr ! A.class_ "decl__role_hover" ! A.title (v hoverTextContent) $ do + H.sub ! A.class_ className $ do + toHtml ("" :: Text) + + docRepoRolePage = + "https://github.com/purescript/documentation/blob/master/language/Roles.md" + + describeNominal = + "The 'nominal' role means this argument may not change when coercing the type." + describePhantom = + "The 'phantom' role means this argument can change freely when coercing the type." linkToDecl = linkToDeclaration r diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 0a150a2417..38748ec263 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -63,6 +63,9 @@ codeToString = outputWith elemAsMarkdown elemAsMarkdown Space = " " elemAsMarkdown (Symbol _ x _) = x + -- roles aren't rendered in markdown + elemAsMarkdown (Role _) = "" + -- fixityAsMarkdown :: P.Fixity -> Docs -- fixityAsMarkdown (P.Fixity associativity precedence) = -- tell' $ concat [ "_" diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 32fbdd9dcf..801b79fdb7 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -13,6 +13,7 @@ import Control.Monad.Supply (evalSupplyT) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Data.String (String) +import qualified Data.Text as T import Language.PureScript.Docs.Convert.Single (convertSingleModule) import Language.PureScript.Docs.Types @@ -23,6 +24,7 @@ import qualified Language.PureScript.Errors as P import qualified Language.PureScript.Externs as P import qualified Language.PureScript.Environment as P import qualified Language.PureScript.Names as P +import qualified Language.PureScript.Roles as P import qualified Language.PureScript.Sugar as P import qualified Language.PureScript.Types as P import qualified Language.PureScript.Constants.Prim as Prim @@ -43,6 +45,12 @@ convertModule externs env checkEnv = fmap (insertValueTypesAndAdjustKinds checkEnv . convertSingleModule) . partiallyDesugar externs env -- | +-- Convert FFI declarations into `DataDeclaration` so that the declaration's +-- roles (if any) can annotate the generated type parameter names. +-- +-- Inserts all data declarations inferred roles if none were specified +-- explicitly. +-- -- Updates all the types of the ValueDeclarations inside the module based on -- their types inside the given Environment. -- @@ -55,8 +63,80 @@ convertModule externs env checkEnv = insertValueTypesAndAdjustKinds :: P.Environment -> Module -> Module insertValueTypesAndAdjustKinds env m = - m { modDeclarations = map go (modDeclarations m) } + m { modDeclarations = map (go . insertInferredRoles . convertFFIDecl) (modDeclarations m) } where + -- | + -- Convert FFI declarations into data declaration + -- by generating the type parameters' names based on its kind signature. + -- Note: `Prim` modules' docs don't go through this conversion process + -- so `ExternDataDeclaration` values will still exist beyond this point. + convertFFIDecl d@Declaration { declInfo = ExternDataDeclaration kind roles } = + d { declInfo = DataDeclaration P.Data (genTypeParams kind) roles + , declKind = Just (KindInfo P.DataSig kind) + } + + convertFFIDecl other = other + + insertInferredRoles d@Declaration { declInfo = DataDeclaration dataDeclType args [] } = + d { declInfo = DataDeclaration dataDeclType args inferredRoles } + + where + inferredRoles :: [P.Role] + inferredRoles = do + let key = P.Qualified (Just (modName m)) (P.ProperName (declTitle d)) + case Map.lookup key (P.types env) of + Just (_, tyKind) -> case tyKind of + P.DataType _ tySourceTyRole _ -> + map (\(_,_,r) -> r) tySourceTyRole + P.ExternData rs -> + rs + _ -> + [] + Nothing -> + err $ "type not found: " <> show key + + insertInferredRoles other = + other + + -- | + -- Given an FFI declaration like this + -- ``` + -- foreign import data Foo + -- :: forall a b c d + -- . MyKind a b + -- -> OtherKind c d + -- -> Symbol + -- -> (Type -> Type) + -- -> (Type) -- unneeded parens a developer typo + -- -> Type + -- ``` + -- Return a list of values, one for each implicit type parameter + -- of `(tX, Nothing)` where `X` refers to the index of he parameter + -- in that list, matching the values expected by `Render.toTypeVar` + genTypeParams :: Type' -> [(Text, Maybe Type')] + genTypeParams kind = do + let n = countParams 0 kind + map (\(i :: Int) -> ("t" <> T.pack (show i), Nothing)) $ take n [0..] + where + countParams :: Int -> Type' -> Int + countParams acc = \case + P.ForAll _ _ _ rest _ -> + countParams acc rest + + P.TypeApp _ f a | isFunctionApplication f -> + countParams (acc + 1) a + + P.ParensInType _ ty -> + countParams acc ty + + _ -> + acc + + isFunctionApplication = \case + P.TypeApp _ (P.TypeConstructor () Prim.Function) _ -> True + P.ParensInType _ ty -> isFunctionApplication ty + _ -> False + -- insert value types go d@Declaration { declInfo = ValueDeclaration P.TypeWildcard{} } = let @@ -94,7 +174,7 @@ insertValueTypesAndAdjustKinds env m = -- Extracts the keyword for a declaration (if there is one) extractKeyword :: DeclarationInfo -> Maybe P.KindSignatureFor extractKeyword = \case - DataDeclaration dataDeclType _ -> Just $ case dataDeclType of + DataDeclaration dataDeclType _ _ -> Just $ case dataDeclType of P.Data -> P.DataSig P.Newtype -> P.NewtypeSig TypeSynonymDeclaration _ _ -> Just P.TypeSynonymSig @@ -149,6 +229,9 @@ insertValueTypesAndAdjustKinds env m = where inferredKind' = inferredKind $> () + -- Note: the below change to the final kind used is intentionally + -- NOT being done for explicit kind signatures: + -- -- changes `forall (k :: Type). k -> ...` -- to `forall k . k -> ...` dropTypeSortAnnotation = \case diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 405a4f53b8..d69961a050 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -15,6 +15,7 @@ import qualified Language.PureScript.AST as P import qualified Language.PureScript.Comments as P import qualified Language.PureScript.Crash as P import qualified Language.PureScript.Names as P +import qualified Language.PureScript.Roles as P import qualified Language.PureScript.Types as P -- | @@ -73,6 +74,7 @@ type IntermediateDeclaration data DeclarationAugment = AugmentChild ChildDeclaration | AugmentKindSig KindSignatureInfo + | AugmentRole (Maybe Text) [P.Role] data KindSignatureInfo = KindSignatureInfo { ksiComments :: Maybe Text @@ -101,11 +103,29 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) = d { declComments = mergeComments ksiComments $ declComments d , declKind = Just $ KindInfo { kiKeyword = ksiKeyword, kiKind = ksiKind } } + augmentWith (AugmentRole comms roles) d = + d { declComments = mergeComments (declComments d) comms + , declInfo = insertRoles + } where - mergeComments Nothing dc = dc - mergeComments kc Nothing = kc - mergeComments (Just kcoms) (Just dcoms) = - Just $ kcoms <> "\n" <> dcoms + insertRoles = case declInfo d of + DataDeclaration dataDeclType args [] -> + DataDeclaration dataDeclType args roles + DataDeclaration _ _ _ -> + P.internalError "augmentWith: could not add a second role declaration to a data declaration" + + ExternDataDeclaration kind [] -> + ExternDataDeclaration kind roles + ExternDataDeclaration _ _ -> + P.internalError "augmentWith: could not add a second role declaration to an FFI declaration" + + _ -> P.internalError "augmentWith: could not add role to declaration" + + mergeComments :: Maybe Text -> Maybe Text -> Maybe Text + mergeComments Nothing bot = bot + mergeComments top Nothing = top + mergeComments (Just topComs) (Just bottomComs) = + Just $ topComs <> "\n" <> bottomComs getDeclarationTitle :: P.Declaration -> Maybe Text getDeclarationTitle (P.ValueDeclaration vd) = Just (P.showIdent (P.valdeclIdent vd)) @@ -118,6 +138,7 @@ getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ name _ _ _ _) = Just $ eith getDeclarationTitle (P.TypeFixityDeclaration _ _ _ op) = Just ("type " <> P.showOp op) getDeclarationTitle (P.ValueFixityDeclaration _ _ _ op) = Just (P.showOp op) getDeclarationTitle (P.KindDeclaration _ _ n _) = Just (P.runProperName n) +getDeclarationTitle (P.RoleDeclaration P.RoleDeclarationData{..}) = Just (P.runProperName rdeclIdent) getDeclarationTitle _ = Nothing -- | Create a basic Declaration value. @@ -146,14 +167,14 @@ convertDeclaration (P.ExternDeclaration sa _ ty) title = convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title = Just (Right (mkDeclaration sa title info) { declChildren = children }) where - info = DataDeclaration dtype (fmap (fmap (fmap ($> ()))) args) + info = DataDeclaration dtype (fmap (fmap (fmap ($> ()))) args) [] children = map convertCtor ctors convertCtor :: P.DataConstructorDeclaration -> ChildDeclaration convertCtor P.DataConstructorDeclaration{..} = let (sourceSpan, comments) = dataCtorAnn in ChildDeclaration (P.runProperName dataCtorName) (convertComments comments) (Just sourceSpan) (ChildDataConstructor (fmap (($> ()) . snd) dataCtorFields)) convertDeclaration (P.ExternDataDeclaration sa _ kind') title = - basicDeclaration sa title (ExternDataDeclaration (kind' $> ())) + basicDeclaration sa title (ExternDataDeclaration (kind' $> ()) []) convertDeclaration (P.TypeSynonymDeclaration sa _ args ty) title = basicDeclaration sa title (TypeSynonymDeclaration (fmap (fmap (fmap ($> ()))) args) (ty $> ())) convertDeclaration (P.TypeClassDeclaration sa _ args implies fundeps ds) title = @@ -187,6 +208,11 @@ convertDeclaration (P.KindDeclaration sa keyword _ kind) title = where comms = convertComments $ snd sa ksi = KindSignatureInfo { ksiComments = comms, ksiKeyword = keyword, ksiKind = kind $> () } +convertDeclaration (P.RoleDeclaration P.RoleDeclarationData{..}) title = + Just $ Left ([(title, AugmentType)], AugmentRole comms rdeclRoles) + where + comms = convertComments $ snd rdeclSourceAnn + convertDeclaration _ _ = Nothing convertComments :: [P.Comment] -> Maybe Text diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index bf6b9f2afe..ae7cb2a434 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -182,7 +182,7 @@ primTypeOf gen title comments = Declaration , declComments = Just comments , declSourceSpan = Nothing , declChildren = [] - , declInfo = ExternDataDeclaration (lookupPrimTypeKindOf gen title) + , declInfo = ExternDataDeclaration (lookupPrimTypeKindOf gen title) [] , declKind = Nothing } diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index fda917dfb5..ee105a4dc6 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -41,11 +41,14 @@ renderDeclaration Declaration{..} = , syntax "::" , renderType ty ] - DataDeclaration dtype args -> + DataDeclaration dtype args roles -> [ keyword (P.showDataDeclType dtype) - , renderType (typeApp declTitle args) + , renderTypeWithRole roles (typeApp declTitle args) ] - ExternDataDeclaration kind' -> + + -- All FFI declarations, except for `Prim` modules' doc declarations, + -- will have been converted to `DataDeclaration`s by this point. + ExternDataDeclaration kind' _ -> [ keywordData , renderType (P.TypeConstructor () (notQualified declTitle)) , syntax "::" diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index 314300b5e4..7203c4c1d5 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -5,6 +5,7 @@ module Language.PureScript.Docs.RenderedCode.RenderType ( renderType + , renderTypeWithRole , renderType' , renderTypeAtom , renderTypeAtom' @@ -15,6 +16,7 @@ import Prelude.Compat import Data.Maybe (fromMaybe) import Data.Text (Text) +import Data.List (uncons) import Control.Arrow ((<+>)) import Control.PatternArrows as PA @@ -23,6 +25,7 @@ import Language.PureScript.Crash import Language.PureScript.Label import Language.PureScript.Names import Language.PureScript.Pretty.Types +import Language.PureScript.Roles import Language.PureScript.Types import Language.PureScript.PSString (prettyPrintString) @@ -34,8 +37,8 @@ typeLiterals = mkPattern match where match (PPTypeWildcard name) = Just $ syntax $ maybe "_" ("?" <>) name - match (PPTypeVar var) = - Just (typeVar var) + match (PPTypeVar var role) = + Just $ typeVar var <> roleAnn role match (PPRecord labels tail_) = Just $ mintersperse sp [ syntax "{" @@ -150,11 +153,80 @@ forall_ = mkPattern match match (PPForAll mbKindedIdents ty) = Just (mbKindedIdents, ty) match _ = Nothing +renderTypeInternal :: (PrettyPrintType -> PrettyPrintType) -> Type a -> RenderedCode +renderTypeInternal insertRolesIfAny = + renderType' . insertRolesIfAny . convertPrettyPrintType maxBound + -- | -- Render code representing a Type -- renderType :: Type a -> RenderedCode -renderType = renderType' . convertPrettyPrintType maxBound +renderType = renderTypeInternal id + +-- | +-- Render code representing a Type +-- but augment the `TypeVar`s with their `Role` if they have one +-- +renderTypeWithRole :: [Role] -> Type a -> RenderedCode +renderTypeWithRole = \case + [] -> renderType + roleList -> renderTypeInternal (addRole roleList [] . Left) + where + -- `data Foo first second = Foo` will produce + -- ``` + -- PPTypeApp + -- (PPTypeApp (PPTypeConstructor fooName) (PPTypeVar "first" Nothing)) + -- (PPTypeVar "second" Nothing) + -- ``` + -- So, we recurse down the left side of `TypeApp` first before + -- recursing down the right side. To make this stack-safe, + -- we use a tail-recursive function with its own stack. + -- - Left = values that have not yet been examined and need + -- a role added to them (if any). There's still work "left" to do. + -- - Right = values that have been examined and now need to be + -- reassembled into their original value + addRole + :: [Role] + -> [Either PrettyPrintType PrettyPrintType] + -> Either PrettyPrintType PrettyPrintType + -> PrettyPrintType + addRole roles stack pp = case pp of + Left next -> case next of + PPTypeVar t Nothing + | Just (x, xs) <- uncons roles -> + addRole xs stack (Right $ PPTypeVar t (Just $ displayRole x)) + | otherwise -> + internalError "addRole: invalid arguments - number of roles doesn't match number of type parameters" + + PPTypeVar _ (Just _) -> + internalError "addRole: attempted to add a second role to a type parameter that already has one" + + PPTypeApp leftSide rightSide -> do + -- push right-side to stack and continue recursing on left-side + addRole roles (Left rightSide : stack) (Left leftSide) + + other -> + -- nothing to check, so move on + addRole roles stack (Right other) + + + pendingAssembly@(Right rightSideOrFinalValue) -> case stack of + (unfinishedRightSide@(Left _) : remaining) -> + -- We've finished recursing through the left-side of a `TypeApp`. + -- Now we'll recurse through the right-side. + -- We push `pendingAssembly` onto the stack so we can assemble + -- the `PPTypeApp` together once it's right-side is done. + addRole roles (pendingAssembly : remaining) unfinishedRightSide + + (Right leftSide : remaining) -> + -- We've finished recursing through the right-side of a `TypeApp` + -- We'll rebulid it and wrap it in `Right` so any other higher-level + -- `TypeApp`s can be reassembled now, too. + addRole roles remaining (Right (PPTypeApp leftSide rightSideOrFinalValue)) + + [] -> + -- We've reassembled everything. It's time to return. + rightSideOrFinalValue renderType' :: PrettyPrintType -> RenderedCode renderType' diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 30c83bde19..c3f37b5201 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -27,6 +27,7 @@ module Language.PureScript.Docs.RenderedCode.Types , typeCtor , typeOp , typeVar + , roleAnn , alias , aliasName ) where @@ -173,6 +174,7 @@ data RenderedCodeElement -- namespace (value, type, or kind). Note that this is not related to the -- kind called Symbol for type-level strings. | Symbol Namespace Text Link + | Role Text deriving (Show, Eq, Ord) instance A.ToJSON RenderedCodeElement where @@ -184,6 +186,8 @@ instance A.ToJSON RenderedCodeElement where A.toJSON ["space" :: Text] toJSON (Symbol ns str link) = A.toJSON ["symbol", A.toJSON ns, A.toJSON str, A.toJSON link] + toJSON (Role role) = + A.toJSON ["role", role] -- | -- A type representing a highly simplified version of PureScript code, intended @@ -262,6 +266,14 @@ typeOp (fromQualified -> (mn, name)) = typeVar :: Text -> RenderedCode typeVar x = RC [Symbol TypeLevel x NoLink] +roleAnn :: Maybe Text -> RenderedCode +roleAnn = RC . maybe [] renderRole + where + renderRole = \case + "nominal" -> [Role "nominal"] + "phantom" -> [Role "phantom"] + _ -> [] + type FixityAlias = Qualified (Either (ProperName 'TypeName) (Either Ident (ProperName 'ConstructorName))) alias :: FixityAlias -> RenderedCode diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 129892e12f..be7cdbe3dc 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -28,6 +28,7 @@ import qualified Language.PureScript.CoreFn.FromJSON as P import qualified Language.PureScript.Crash as P import qualified Language.PureScript.Environment as P import qualified Language.PureScript.Names as P +import qualified Language.PureScript.Roles as P import qualified Language.PureScript.Types as P import qualified Paths_purescript as Paths @@ -158,12 +159,12 @@ data DeclarationInfo -- newtype) and its type arguments. Constructors are represented as child -- declarations. -- - | DataDeclaration P.DataDeclType [(Text, Maybe Type')] + | DataDeclaration P.DataDeclType [(Text, Maybe Type')] [P.Role] -- | -- A data type foreign import, with its kind. -- - | ExternDataDeclaration Type' + | ExternDataDeclaration Type' [P.Role] -- | -- A type synonym, with its type arguments and its type. @@ -216,8 +217,8 @@ convertFundepsToStrings args fundeps = declInfoToString :: DeclarationInfo -> Text declInfoToString (ValueDeclaration _) = "value" -declInfoToString (DataDeclaration _ _) = "data" -declInfoToString (ExternDataDeclaration _) = "externData" +declInfoToString (DataDeclaration _ _ _) = "data" +declInfoToString (ExternDataDeclaration _ _) = "externData" declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym" declInfoToString (TypeClassDeclaration _ _ _) = "typeClass" declInfoToString (AliasDeclaration _ _) = "alias" @@ -361,6 +362,7 @@ data PackageError | InvalidDataDeclType Text | InvalidKindSignatureFor Text | InvalidTime + | InvalidRole Text deriving (Show, Eq, Ord, Generic) instance NFData PackageError @@ -531,6 +533,8 @@ displayPackageError e = case e of "Invalid kind signature keyword: \"" <> str <> "\"" InvalidTime -> "Invalid time" + InvalidRole str -> + "Invalid role keyword: \"" <> str <> "\"" instance A.FromJSON a => A.FromJSON (Package a) where parseJSON = toAesonParser displayPackageError @@ -613,8 +617,10 @@ asDeclarationInfo = do "data" -> DataDeclaration <$> key "dataDeclType" asDataDeclType <*> key "typeArguments" asTypeArguments + <*> keyOrDefault "roles" [] (eachInArray asRole) "externData" -> ExternDataDeclaration <$> key "kind" asType + <*> keyOrDefault "roles" [] (eachInArray asRole) "typeSynonym" -> TypeSynonymDeclaration <$> key "arguments" asTypeArguments <*> key "type" asType @@ -627,7 +633,7 @@ asDeclarationInfo = do <*> key "alias" asFixityAlias -- Backwards compat: kinds are extern data "kind" -> - pure $ ExternDataDeclaration (P.kindType $> ()) + pure $ ExternDataDeclaration (P.kindType $> ()) [] other -> throwCustomError (InvalidDeclarationType other) @@ -650,6 +656,14 @@ asTypeArguments = eachInArray asTypeArgument where asTypeArgument = (,) <$> nth 0 asText <*> nth 1 (perhaps asType) +asRole :: Parse PackageError P.Role +asRole = + withText $ \case + "Representational" -> Right P.Representational + "Nominal" -> Right P.Nominal + "Phantom" -> Right P.Phantom + other -> Left (InvalidRole other) + asType :: Parse e Type' asType = fromAesonParser @@ -814,8 +828,8 @@ instance A.ToJSON DeclarationInfo where where props = case info of ValueDeclaration ty -> ["type" .= ty] - DataDeclaration ty args -> ["dataDeclType" .= ty, "typeArguments" .= args] - ExternDataDeclaration kind -> ["kind" .= kind] + DataDeclaration ty args roles -> ["dataDeclType" .= ty, "typeArguments" .= args, "roles" .= roles] + ExternDataDeclaration kind roles -> ["kind" .= kind, "roles" .= roles] TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty] TypeClassDeclaration args super fundeps -> ["arguments" .= args, "superclasses" .= super, "fundeps" .= fundeps] AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias] diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index f6751649f8..2c9f85677f 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -41,7 +41,7 @@ import Text.PrettyPrint.Boxes hiding ((<+>)) data PrettyPrintType = PPTUnknown Int - | PPTypeVar Text + | PPTypeVar Text (Maybe Text) | PPTypeLevelString PSString | PPTypeWildcard (Maybe Text) | PPTypeConstructor (Qualified (ProperName 'TypeName)) @@ -65,7 +65,7 @@ convertPrettyPrintType :: Int -> Type a -> PrettyPrintType convertPrettyPrintType = go where go _ (TUnknown _ n) = PPTUnknown n - go _ (TypeVar _ t) = PPTypeVar t + go _ (TypeVar _ t) = PPTypeVar t Nothing go _ (TypeLevelString _ s) = PPTypeLevelString s go _ (TypeWildcard _ n) = PPTypeWildcard n go _ (TypeConstructor _ c) = PPTypeConstructor c @@ -184,7 +184,7 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} = typeLiterals :: Pattern () PrettyPrintType Box typeLiterals = mkPattern match where match (PPTypeWildcard name) = Just $ text $ maybe "_" (('?' :) . T.unpack) name - match (PPTypeVar var) = Just $ text $ T.unpack var + match (PPTypeVar var _) = Just $ text $ T.unpack var match (PPTypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s match (PPTypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor match (PPTUnknown u) diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 4f5d54a089..00fe60a5b3 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -111,9 +111,12 @@ data DocsAssertion -- | Assert that a given declaration does not have a kind signature | ShouldNotHaveKindSignature P.ModuleName Text -- | Assert that a given declaration with doc-comments on its - -- kind signature and type declaration are properly merged into one - -- doc-comment. + -- kind signature, type declaration, and role declaration are properly + -- merged into one doc-comment. | ShouldMergeDocComments P.ModuleName Text (Maybe Text) + -- | Assert that a given declaration's type parameters have the + -- given role annotations + | ShouldHaveRoleAnnotation P.ModuleName Text [P.Role] data TagsAssertion -- | Assert that a particular declaration is tagged @@ -174,7 +177,12 @@ displayAssertion = \case ShouldNotHaveKindSignature mn decl -> showQual mn decl <> " should not have a kind signature." ShouldMergeDocComments mn decl _ -> - showQual mn decl <> " should merge its kind declaration and type declaration's doc-comments" + showQual mn decl <> " should merge the doc-comments of its kind " <> + "declaration (if any), type declaration, and role declaration (if any) " <> + "into one doc-comment." + ShouldHaveRoleAnnotation mn decl expected -> + showQual mn decl <> " should have the expected role annotations: " <> + T.intercalate ", " (fmap P.displayRole expected) displayTagsAssertion :: TagsAssertion -> Text displayTagsAssertion = \case @@ -240,11 +248,18 @@ data DocsAssertionFailure -- Fields: module name, declaration title, actual kind signature (text), -- actual kind signature (structure) | KindSignaturePresent P.ModuleName Text Text (P.Type ()) - -- | The doc comments for the kind signature and type declaration were - -- not properly merged into the expected one. + -- | The doc comments for the kind signature (if any), type declaration, and + -- role declaration (if any) were not properly merged into the expected one. -- Fields: module name, declaration title, expected doc-comments, -- actual doc-comments | DocCommentMergeFailure P.ModuleName Text Text Text + -- | The given declaration cannot have role annotations. + -- Fields: module name, declaration title + | CannotHaveRoles P.ModuleName Text + -- | The list of expected roles did not match the list of actual roles + -- fields: module name, declaration title, expected role list, + -- actual role list + | RoleMismatch P.ModuleName Text [P.Role] [P.Role] data TagsAssertionFailure -- | A declaration was not tagged, but should have been @@ -309,6 +324,14 @@ displayAssertionFailure = \case DocCommentMergeFailure _ decl expected actual -> "Expected the doc-comment for " <> decl <> " to merge comments and be `" <> expected <> "`; got `" <> actual <> "`" + CannotHaveRoles _ decl -> + decl <> " is a type of declaration that cannot have roles." + RoleMismatch _ decl expected actual -> + "Expected the role annotations for " <> decl <> " to be \n" <> + "`" <> displayRoleList expected <> "`, but got\n" <> + "`" <> displayRoleList actual <> "`" + where + displayRoleList = T.intercalate ", " . fmap P.displayRole displayTagsAssertionFailure :: TagsAssertionFailure -> Text displayTagsAssertionFailure = \case @@ -507,6 +530,12 @@ runAssertion assertion linksCtx Docs.Module{..} = else Fail (DocCommentMergeFailure mn decl (display expected) (display declComments)) where display = fromMaybe "" + + ShouldHaveRoleAnnotation mn decl expected -> + findDeclRoles mn decl $ \actual -> + if expected == actual + then Pass + else Fail (RoleMismatch mn decl expected actual) where declarationsFor mn = if mn == modName @@ -530,6 +559,17 @@ runAssertion assertion linksCtx Docs.Module{..} = Just Docs.Declaration{..} -> f declKind + findDeclRoles mn title f = + case find ((==) title . Docs.declTitle) (declarationsFor mn) of + Nothing -> + Fail (NotDocumented mn title) + Just Docs.Declaration{..} -> + case getRoles declInfo of + Nothing -> + Fail (CannotHaveRoles mn title) + Just roles -> + f roles + findDeclChildren mn title child f = findDecl mn title $ \Docs.Declaration{..} -> case find ((==) child . Docs.cdeclTitle) declChildren of @@ -552,6 +592,11 @@ runAssertion assertion linksCtx Docs.Module{..} = childrenTitles = map Docs.cdeclTitle . Docs.declChildren + getRoles :: Docs.DeclarationInfo -> Maybe [P.Role] + getRoles = \case + Docs.DataDeclaration _ _ roles -> Just roles + _ -> Nothing + extract :: Docs.RenderedCode -> Docs.Namespace -> Text -> Maybe Docs.DocLink extract rc ns title = getFirst (Docs.outputWith (First . go) rc) >>= getLink where @@ -780,9 +825,15 @@ testCases = , ShouldNotHaveKindSignature (n "KindSignatureDocs") "CHidden" , ShouldNotHaveKindSignature (n "KindSignatureDocs") "CNothing" + -- FFI declarations always have an explicit kind signature + -- but only show them if they are "interesting." + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "FFI_Hidden" + , ShouldHaveKindSignature (n "KindSignatureDocs") "FFI_Shown" "data FFI_Shown :: (Type -> Type) -> Type" + -- Declarations with an explicit kind signature that is wrapped -- in parenthesis at various points, but which "desugars" so to speak -- to an uninteresting kind signature should not be displayed. + , ShouldNotHaveKindSignature (n "KindSignatureDocs") "FFI_RedundantParenthesis" , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataRedundantParenthesis" , ShouldNotHaveKindSignature (n "KindSignatureDocs") "ClassRedundantParenthesis" , ShouldNotHaveKindSignature (n "KindSignatureDocs") "DataHeadParens" @@ -803,27 +854,53 @@ testCases = , ShouldHaveKindSignature (n "KindSignatureDocs") "TShown" "type TShown :: (Type -> Type) -> Type -> Type -> Type" , ShouldHaveKindSignature (n "KindSignatureDocs") "NShown" "newtype NShown :: Type -> (Type -> Type) -> Type -> Type" , ShouldHaveKindSignature (n "KindSignatureDocs") "CShown" "class CShown :: (Type -> Type) -> Type -> Type -> Constraint" - - -- expected docs - , ShouldMergeDocComments (n "KindSignatureDocs") "DKindAndType" $ Just "dkatk\n\ndkatt\n" - , ShouldMergeDocComments (n "KindSignatureDocs") "TKindAndType" $ Just "tkatk\n\ntkatt\n" - , ShouldMergeDocComments (n "KindSignatureDocs") "NKindAndType" $ Just "nkatk\n\nnkatt\n" - , ShouldMergeDocComments (n "KindSignatureDocs") "CKindAndType" $ Just "ckatk\n\nckatt\n" - - , ShouldMergeDocComments (n "KindSignatureDocs") "DKindOnly" $ Just "dkok\n" - , ShouldMergeDocComments (n "KindSignatureDocs") "TKindOnly" $ Just "tkok\n" - , ShouldMergeDocComments (n "KindSignatureDocs") "NKindOnly" $ Just "nkok\n" - , ShouldMergeDocComments (n "KindSignatureDocs") "CKindOnly" $ Just "ckok\n" - - , ShouldMergeDocComments (n "KindSignatureDocs") "DTypeOnly" $ Just "dtot\n" - , ShouldMergeDocComments (n "KindSignatureDocs") "TTypeOnly" $ Just "ttot\n" - , ShouldMergeDocComments (n "KindSignatureDocs") "NTypeOnly" $ Just "ntot\n" - , ShouldMergeDocComments (n "KindSignatureDocs") "CTypeOnly" $ Just "ctot\n" - - , ShouldMergeDocComments (n "KindSignatureDocs") "DImplicit" $ Just "dit\n" - , ShouldMergeDocComments (n "KindSignatureDocs") "TImplicit" $ Just "tit\n" - , ShouldMergeDocComments (n "KindSignatureDocs") "NImplicit" $ Just "nit\n" - , ShouldMergeDocComments (n "KindSignatureDocs") "CImplicit" $ Just "cit\n" + ] + ) + , ("RoleAnnotationDocs", + [ ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "D_RNP" [P.Representational, P.Nominal, P.Phantom] + , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "D_NPR" [P.Nominal, P.Phantom, P.Representational] + , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "D_PRN" [P.Phantom, P.Representational, P.Nominal] + , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_NNN" [P.Nominal, P.Nominal, P.Nominal] + , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_RNP" [P.Representational, P.Nominal, P.Phantom] + + , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_Higher1" [P.Representational, P.Nominal, P.Phantom] + , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_Higher2" [P.Representational, P.Nominal, P.Phantom] + , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_Higher3" [P.Representational, P.Nominal, P.Phantom] + , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_Higher4" [P.Representational, P.Nominal, P.Phantom] + + , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_HeadParens" [P.Representational, P.Nominal, P.Phantom] + , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_TailParens" [P.Representational, P.Nominal, P.Phantom] + , ShouldHaveRoleAnnotation (n "RoleAnnotationDocs") "FFI_WholeParens" [P.Representational, P.Nominal, P.Phantom] + ] + ) + , ("DocCommentsMerge", + [ ShouldMergeDocComments (n "DocCommentsMerge") "DataOnly" $ Just "decl\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "KindOnlyData" $ Just "kind\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "KindAndData" $ Just "kind\n\ndecl\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "DataRoleOnly" $ Just "role\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "DataAndRole" $ Just "decl\n\nrole\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "KindOnlyDataRoleOnly" $ Just "kind\n\nrole\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "KindDataAndRole" $ Just "kind\n\ndecl\n\nrole\n" + + , ShouldMergeDocComments (n "DocCommentsMerge") "FFIOnly" $ Just "decl\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "FFIRoleOnly" $ Just "role\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "FFIAndRole" $ Just "decl\n\nrole\n" + + , ShouldMergeDocComments (n "DocCommentsMerge") "NewtypeOnly" $ Just "decl\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "KindOnlyNewtype" $ Just "kind\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "KindAndNewtype" $ Just "kind\n\ndecl\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "NewtypeRoleOnly" $ Just "role\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "NewtypeAndRole" $ Just "decl\n\nrole\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "KindOnlyNewtypeRoleOnly" $ Just "kind\n\nrole\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "KindNewtypeAndRole" $ Just "kind\n\ndecl\n\nrole\n" + + , ShouldMergeDocComments (n "DocCommentsMerge") "TypeOnly" $ Just "decl\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "KindOnlyType" $ Just "kind\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "KindAndType" $ Just "kind\n\ndecl\n" + + , ShouldMergeDocComments (n "DocCommentsMerge") "ClassOnly" $ Just "decl\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "KindOnlyClass" $ Just "kind\n" + , ShouldMergeDocComments (n "DocCommentsMerge") "KindAndClass" $ Just "kind\n\ndecl\n" ] ) ] diff --git a/tests/purs/docs/src/DocCommentsMerge.purs b/tests/purs/docs/src/DocCommentsMerge.purs new file mode 100644 index 0000000000..b160560a4a --- /dev/null +++ b/tests/purs/docs/src/DocCommentsMerge.purs @@ -0,0 +1,118 @@ +module DocCommentsMerge where + +-- | decl +data DataOnly = DataOnly + +-- | kind +data KindOnlyData :: Type +data KindOnlyData = KindOnlyData + +-- | kind +data KindAndData :: Type +-- | decl +data KindAndData = KindAndData + +data DataRoleOnly a b = DataRoleOnly a b +-- | role +type role DataRoleOnly representational representational + +-- | decl +data DataAndRole a b = DataAndRole a b +-- | role +type role DataAndRole representational representational + +-- | kind +data KindOnlyDataRoleOnly :: Type -> Type +data KindOnlyDataRoleOnly a = KindOnlyDataRoleOnly +-- | role +type role KindOnlyDataRoleOnly representational + +-- | kind +data KindDataAndRole :: Type -> Type +-- | decl +data KindDataAndRole a = KindDataAndRole +-- | role +type role KindDataAndRole representational + +--- + +-- | decl +foreign import data FFIOnly :: Type + +foreign import data FFIRoleOnly :: Type -> Type +-- | role +type role FFIRoleOnly representational + +-- | decl +foreign import data FFIAndRole :: Type -> Type +-- | role +type role FFIAndRole representational + +--- + +-- | decl +newtype NewtypeOnly = NewtypeOnly Int + +-- | kind +newtype KindOnlyNewtype :: Type +newtype KindOnlyNewtype = KindOnlyNewtype Int + +-- | kind +newtype KindAndNewtype :: Type -> Type -> Type +-- | decl +newtype KindAndNewtype a b = KindAndNewtype Int + +newtype NewtypeRoleOnly a b = NewtypeRoleOnly Int +-- | role +type role NewtypeRoleOnly representational representational + +-- | decl +newtype NewtypeAndRole a b = NewtypeAndRole Int +-- | role +type role NewtypeAndRole representational representational + +-- | kind +newtype KindOnlyNewtypeRoleOnly :: Type -> Type -> Type +newtype KindOnlyNewtypeRoleOnly a b = KindOnlyNewtypeRoleOnly Int +-- | role +type role KindOnlyNewtypeRoleOnly representational representational + +-- | kind +newtype KindNewtypeAndRole :: Type -> Type -> Type +-- | decl +newtype KindNewtypeAndRole a b = KindNewtypeAndRole Int +-- | role +type role KindNewtypeAndRole representational representational + +--- + +-- | decl +type TypeOnly = Int + +-- | kind +type KindOnlyType :: Type -> Type -> Type +type KindOnlyType a b = Int + +-- | kind +type KindAndType :: Type -> Type -> Type +-- | decl +type KindAndType a b = Int + +-- type can't have role annotations + +--- + +-- | decl +class ClassOnly + +-- | kind +class KindOnlyClass :: Constraint +class KindOnlyClass + +-- | kind +class KindAndClass :: Type -> Constraint +-- | decl +class KindAndClass a where + fooKindAndClass :: a -> String + +-- class can't have role declarations diff --git a/tests/purs/docs/src/KindSignatureDocs.purs b/tests/purs/docs/src/KindSignatureDocs.purs index a8a37e4cb3..4d487efb64 100644 --- a/tests/purs/docs/src/KindSignatureDocs.purs +++ b/tests/purs/docs/src/KindSignatureDocs.purs @@ -1,41 +1,29 @@ module KindSignatureDocs where --- | dkatk data DKindAndType :: forall k. k -> Type --- | dkatt data DKindAndType a = DKindAndType --- | tkatk type TKindAndType :: forall k. k -> Type --- | tkatt type TKindAndType a = Int --- | nkatk newtype NKindAndType :: forall k. k -> Type --- | nkatt newtype NKindAndType a = NKindAndType Int --- | ckatk class CKindAndType :: forall k. (k -> Type) -> k -> Constraint --- | ckatt class CKindAndType a k where fooKindAndType :: a k -> String ---------- --- | dkok data DKindOnly :: forall k. k -> Type data DKindOnly a = DKindOnly --- | tkok type TKindOnly :: forall k. k -> Type type TKindOnly a = Int --- | nkok newtype NKindOnly :: forall k. k -> Type newtype NKindOnly a = NKindOnly Int --- | ckok class CKindOnly :: forall k. (k -> Type) -> k -> Constraint class CKindOnly a k where fooKindOnly :: a k -> String @@ -43,51 +31,39 @@ class CKindOnly a k where ---------- data DTypeOnly :: forall k. k -> Type --- | dtot data DTypeOnly a = DTypeOnly type TTypeOnly :: forall k. k -> Type --- | ttot type TTypeOnly a = Int newtype NTypeOnly :: forall k. k -> Type --- | ntot newtype NTypeOnly a = NTypeOnly Int class CTypeOnly :: forall k. (k -> Type) -> k -> Constraint --- | ctot class CTypeOnly a k where fooTypeOnly :: a k -> String ---------- --- | dit data DImplicit a = DImplicit --- | tit type TImplicit a = Int --- | nit newtype NImplicit a = NImplicit Int --- | cit class CImplicit a k where fooImplicit :: a k -> String ---------- --- | dit data DHidden a b c = DHidden a b c data DNothing --- | tit type THidden a b c = DHidden b c a --- | nit newtype NHidden a b c = NHidden (DHidden a c b) --- | cit class CHidden a b c where fooHidden :: a -> b -> c -> String @@ -95,6 +71,13 @@ class CNothing ---------- +foreign import data FFI_Hidden :: Type -> Type -> Type +foreign import data FFI_Shown :: (Type -> Type) -> Type + +---------- + +foreign import data FFI_RedundantParenthesis :: (Type) -> Type + data DataRedundantParenthesis :: (Type) -> (Type) data DataRedundantParenthesis a = DataRedundantParenthesis @@ -130,15 +113,11 @@ data FunctionParens3 :: (((->) Type)) Type data FunctionParens3 a = FunctionParens3 a ---------- --- | dit data DShown a b f = DShown (f Int) a b --- | tit type TShown f b c = DShown b c f --- | nit newtype NShown a f c = NShown (DShown a c f) --- | cit class CShown f a b where fooShown :: f Int -> a -> b -> String diff --git a/tests/purs/docs/src/RoleAnnotationDocs.purs b/tests/purs/docs/src/RoleAnnotationDocs.purs new file mode 100644 index 0000000000..e94453c8a1 --- /dev/null +++ b/tests/purs/docs/src/RoleAnnotationDocs.purs @@ -0,0 +1,36 @@ +module RoleAnnotationDocs where + +data D_RNP a b c = D_RNP +type role D_RNP representational nominal phantom + +data D_NPR a b c = D_NPR +type role D_NPR nominal phantom representational + +data D_PRN a b c = D_PRN +type role D_PRN phantom representational nominal + +foreign import data FFI_NNN :: Type -> Type -> Type -> Type + +foreign import data FFI_RNP :: Type -> Type -> Type -> Type +type role FFI_RNP representational nominal phantom + +foreign import data FFI_Higher1 :: (Type -> Type) -> Type -> Type -> Type +type role FFI_Higher1 representational nominal phantom + +foreign import data FFI_Higher2 :: Type -> (Type -> Type) -> Type -> Type +type role FFI_Higher2 representational nominal phantom + +foreign import data FFI_Higher3 :: Type -> Type -> (Type -> Type) -> Type +type role FFI_Higher3 representational nominal phantom + +foreign import data FFI_Higher4 :: Type -> (Type -> (Type -> Type)) -> Type -> Type +type role FFI_Higher4 representational nominal phantom + +foreign import data FFI_HeadParens :: (Type) -> Type -> Type -> Type +type role FFI_HeadParens representational nominal phantom + +foreign import data FFI_TailParens :: Type -> (Type -> Type -> Type) +type role FFI_TailParens representational nominal phantom + +foreign import data FFI_WholeParens :: (Type -> Type -> Type -> Type) +type role FFI_WholeParens representational nominal phantom From 40d4a3d0635e8ad96220fe2d84ee511aad77dbbd Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Wed, 17 Nov 2021 21:38:58 +0000 Subject: [PATCH 1401/1580] Update unnamed instances changelog entry (#4122) * Update unnamed instances changelog entry I know this has already gone out, but the current treatment of this feature in the changelog is slightly inaccurate - it's not true that these numbers are randomly generated, they should actually be deterministic - if the module hasn't otherwise changed, you should always get the same number out. I don't think we should document the scheme for what generated instance names look like, because we shouldn't consider it part of the compiler's public API; documenting it could be read as telling users that they can rely on this not changing, which is not the case. Co-authored-by: JordanMartinez --- CHANGELOG.md | 18 ++---------------- 1 file changed, 2 insertions(+), 16 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d11c210adf..4ec42e01d5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -125,22 +125,8 @@ New features: instance Foo Int String ``` - and the compiler will generate a unique name for the instance - (e.g. `$dollar_FooIntString_4` where `4` is a randomly-generated number - that can change across compiler runs). This version of the instance name - is not intended for use in FFI. - - Note: if one wrote - - ```purescript - instance ReallyLongClassName Int String - ``` - - the generated name would be something like - `$dollar_ReallyLongClassNameIntStr_87` rather than - `$dollar_ReallyLongClassNameIntString_87` as the generated part - of the name will be truncated to 25 characters (long enough to be readable - without being too verbose). + Note that generated instance names can change without warning as a result of changes + elsewhere in your code, so do not rely upon these names in any FFI code. Bugfixes: From 18e3b14c556c5bd58e391531e4f4e511f834c3ff Mon Sep 17 00:00:00 2001 From: Dennis Gosnell Date: Tue, 23 Nov 2021 13:44:24 +0900 Subject: [PATCH 1402/1580] remove explicit disabling of Nix in stack.yaml (#4198) * remove explicit disabling of Nix in stack.yaml * Add CHANGELOG entry. * Format changelog entry Co-authored-by: JordanMartinez --- CHANGELOG.d/internal_no-explicit-disable-nix.md | 5 +++++ stack.yaml | 1 - 2 files changed, 5 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/internal_no-explicit-disable-nix.md diff --git a/CHANGELOG.d/internal_no-explicit-disable-nix.md b/CHANGELOG.d/internal_no-explicit-disable-nix.md new file mode 100644 index 0000000000..edd4e22794 --- /dev/null +++ b/CHANGELOG.d/internal_no-explicit-disable-nix.md @@ -0,0 +1,5 @@ +* The explicit disabling of Nix has been removed from `stack.yaml`. + + For developers on NixOS, this means that you should be able to build + PureScript by running `stack build` instead of `stack build --nix`. + For other developers, this shouldn't affect you. diff --git a/stack.yaml b/stack.yaml index de8b47203d..8818ba186d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,7 +18,6 @@ extra-deps: - hspec-core-2.8.3 - hspec-discover-2.8.3 nix: - enable: false packages: - zlib # Test dependencies From d2fb21b7c5fd3014c306a46f4591d709651c1034 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Tue, 21 Dec 2021 10:11:39 -0500 Subject: [PATCH 1403/1580] Build the entire latest package set in CI (#4217) * Build the entire latest package set in CI The package set is only built in Linux, as that tends to be the OS that otherwise finishes first, and there's no need to run this test three times. The package set is *not* built if there are any files in CHANGELOG.d starting with `breaking_`, indicating that there are unreleased breaking changes. --- .github/workflows/ci.yml | 12 ++++++ .../internal_build-package-set-in-ci.md | 3 ++ ci/build-package-set.sh | 38 +++++++++++++++++++ 3 files changed, 53 insertions(+) create mode 100644 CHANGELOG.d/internal_build-package-set-in-ci.md create mode 100755 ci/build-package-set.sh diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7f42c067d7..c02b1202e7 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -57,6 +57,18 @@ jobs: - run: "ci/build.sh" + - name: "(Linux only) Build the entire package set" + if: "${{ runner.os == 'Linux' }}" + # We build in this directory in build.sh, so this is where we need to + # launch `stack exec`. The actual package-set building happens in a + # temporary directory. + working-directory: "sdist-test" + # The presence or absence of the --haddock flag changes the location + # into which stack places all build artifacts. Since we use --haddock + # in our CI builds, in order to actually get stack to find the purs + # binary it created, we need to use the flag here as well. + run: "stack --haddock exec ../ci/build-package-set.sh" + - name: "(Release only) Create bundle" if: "${{ env.CI_RELEASE == 'true' }}" run: | diff --git a/CHANGELOG.d/internal_build-package-set-in-ci.md b/CHANGELOG.d/internal_build-package-set-in-ci.md new file mode 100644 index 0000000000..daa99068bc --- /dev/null +++ b/CHANGELOG.d/internal_build-package-set-in-ci.md @@ -0,0 +1,3 @@ +* Build the entire latest package set in CI + + See [#4128](https://github.com/purescript/purescript/pull/4128). diff --git a/ci/build-package-set.sh b/ci/build-package-set.sh new file mode 100755 index 0000000000..bc60689d34 --- /dev/null +++ b/ci/build-package-set.sh @@ -0,0 +1,38 @@ +#!/usr/bin/env bash + +set -eu -o pipefail +shopt -s nullglob + +psroot=$(dirname "$(dirname "$(realpath "$0")")") + +if [[ "${CI:-}" && "$(echo $psroot/CHANGELOG.d/breaking_*)" ]]; then + echo "Skipping package-set build due to unreleased breaking changes" + exit 0 +fi + +tmpdir=$(mktemp -d) +trap 'rm -rf "$tmpdir"' EXIT +export PATH="$tmpdir/node_modules/.bin:$PATH" +cd "$tmpdir" + +echo ::group::Ensure Spago is available +which spago || npm install spago +echo ::endgroup:: + +echo ::group::Create dummy project +echo 'let upstream = https://github.com/purescript/package-sets/releases/download/XXX/packages.dhall in upstream' > packages.dhall +echo '{ name = "my-project", dependencies = [] : List Text, packages = ./packages.dhall, sources = [] : List Text }' > spago.dhall +spago upgrade-set +# Override the `metadata` package's version to match `purs` version +# so that `spago build` actually works +sed -i'' "\$c in upstream with metadata.version = \"v$(purs --version | { read v z && echo $v; })\"" packages.dhall +spago install $(spago ls packages | while read name z; do echo $name; done) +echo ::endgroup:: + +echo ::group::Compile package set +spago build +echo ::endgroup:: + +echo ::group::Document package set +spago docs --no-search +echo ::endgroup:: From c1bcbd553badac2959710da30a70d464307738be Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Wed, 22 Dec 2021 07:18:51 +0800 Subject: [PATCH 1404/1580] Inline newtype constructor applications with ($) (#4205) Co-authored-by: Ryan Hendrickson --- CHANGELOG.d/fix_newtype_dollar.md | 1 + .../internal_optimization_golden_tests.md | 5 ++++ src/Language/PureScript/CoreFn/Optimizer.hs | 19 +++++++++++++-- .../PureScript/CoreImp/Optimizer/Inliner.hs | 7 ------ tests/TestCompiler.hs | 24 +++++++++++++++++++ tests/purs/.gitattributes | 1 + tests/purs/optimize/2866.out.js | 15 ++++++++++++ tests/purs/optimize/2866.purs | 12 ++++++++++ 8 files changed, 75 insertions(+), 9 deletions(-) create mode 100644 CHANGELOG.d/fix_newtype_dollar.md create mode 100644 CHANGELOG.d/internal_optimization_golden_tests.md create mode 100644 tests/purs/.gitattributes create mode 100644 tests/purs/optimize/2866.out.js create mode 100644 tests/purs/optimize/2866.purs diff --git a/CHANGELOG.d/fix_newtype_dollar.md b/CHANGELOG.d/fix_newtype_dollar.md new file mode 100644 index 0000000000..4b00670ea3 --- /dev/null +++ b/CHANGELOG.d/fix_newtype_dollar.md @@ -0,0 +1 @@ +* Optimize newtype applications with the ($) operator diff --git a/CHANGELOG.d/internal_optimization_golden_tests.md b/CHANGELOG.d/internal_optimization_golden_tests.md new file mode 100644 index 0000000000..2082e45246 --- /dev/null +++ b/CHANGELOG.d/internal_optimization_golden_tests.md @@ -0,0 +1,5 @@ +* Create test machinery for optimizations + + This adds machinery for testing code generation for optimizations. + + Partially extracted from #3915 to add tests for #4205. diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 6b3c9ef2b5..b876dfdff5 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -3,15 +3,17 @@ module Language.PureScript.CoreFn.Optimizer (optimizeCoreFn) where import Protolude hiding (Type) import Data.List (lookup) +import qualified Data.Text as T import Language.PureScript.AST.Literals import Language.PureScript.AST.SourcePos import Language.PureScript.CoreFn.Ann import Language.PureScript.CoreFn.Expr import Language.PureScript.CoreFn.Module import Language.PureScript.CoreFn.Traversals -import Language.PureScript.Names (Ident(UnusedIdent), Qualified(Qualified)) +import Language.PureScript.Names (Ident(..), ModuleName(..), Qualified(..)) import Language.PureScript.Label import Language.PureScript.Types +import qualified Language.PureScript.Constants.Prelude as C import qualified Language.PureScript.Constants.Prim as C -- | @@ -24,7 +26,10 @@ optimizeModuleDecls :: [Bind Ann] -> [Bind Ann] optimizeModuleDecls = map transformBinds where (transformBinds, _, _) = everywhereOnValues identity transformExprs identity - transformExprs = optimizeUnusedPartialFn . optimizeClosedRecordUpdate + transformExprs + = optimizeUnusedPartialFn + . optimizeClosedRecordUpdate + . optimizeDataFunctionApply optimizeClosedRecordUpdate :: Expr Ann -> Expr Ann optimizeClosedRecordUpdate ou@(ObjectUpdate a@(_, _, Just t, _) r updatedFields) = @@ -54,3 +59,13 @@ optimizeUnusedPartialFn (Let _ (App _ (App _ (Var _ (Qualified _ UnusedIdent)) _) originalCoreFn)) = originalCoreFn optimizeUnusedPartialFn e = e + +optimizeDataFunctionApply :: Expr a -> Expr a +optimizeDataFunctionApply e = case e of + (App a (App _ (Var _ (Qualified (Just (ModuleName mn)) (Ident fn))) x) y) + | mn == dataFunction && fn == C.apply -> App a x y + | mn == dataFunction && fn == C.applyFlipped -> App a y x + _ -> e + where + dataFunction :: Text + dataFunction = T.replace "_" "." C.dataFunction diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index 206eaec448..8bfa5e5c30 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -164,8 +164,6 @@ inlineCommonOperators = everywhereTopDown $ applyAll $ , binary' C.dataIntBits C.zshr ZeroFillShiftRight , unary' C.dataIntBits C.complement BitwiseNot - , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x] - , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x] , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing) ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++ @@ -248,11 +246,6 @@ inlineCommonOperators = everywhereTopDown $ applyAll $ convert (App _ (App _ op' [x]) [y]) | p op' = f x y convert other = other - isModFn :: (Text, PSString) -> AST -> Bool - isModFn (m, op) (Indexer _ (StringLiteral _ op') (Var _ m')) = - m == m' && op == op' - isModFn _ _ = False - isModFnWithDict :: (Text, PSString) -> AST -> Bool isModFnWithDict (m, op) (App _ (Indexer _ (StringLiteral _ op') (Var _ m')) [Var _ _]) = m == m' && op == op' diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 06f5a3cf92..3b06a66d2c 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -28,6 +28,7 @@ import Prelude.Compat import qualified Language.PureScript as P import Control.Arrow ((>>>)) +import qualified Data.ByteString as BS import Data.Function (on) import Data.List (sort, stripPrefix, minimumBy) import Data.Maybe (mapMaybe) @@ -54,6 +55,7 @@ spec = do passingTests warningTests failingTests + optimizeTests passingTests :: SpecWith SupportModules passingTests = do @@ -87,6 +89,15 @@ failingTests = do expectedFailures <- getShouldFailWith mainPath assertDoesNotCompile support testPurs expectedFailures +optimizeTests :: SpecWith SupportModules +optimizeTests = do + optimizeTestCases <- runIO $ getTestFiles "optimize" + + describe "Optimization examples" $ + forM_ optimizeTestCases $ \testPurs -> + it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile to expected output") $ \support -> + assertCompilesToExpectedOutput support testPurs + checkShouldReport :: [String] -> (P.MultipleErrors -> String) -> P.MultipleErrors -> Expectation checkShouldReport expected prettyPrintDiagnostics errs = let actual = map P.errorCode $ P.runMultipleErrors errs @@ -178,6 +189,19 @@ assertDoesNotCompile support inputFiles shouldFailWith = do Right _ -> expectationFailure "Should not have compiled" +assertCompilesToExpectedOutput + :: SupportModules + -> [FilePath] + -> Expectation +assertCompilesToExpectedOutput support inputFiles = do + (result, _) <- compile support inputFiles + case result of + Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs + Right _ -> + goldenVsString + (replaceExtension (getTestMain inputFiles) ".out.js") + (BS.readFile $ modulesDir "Main/index.js") + -- Prints a set of diagnostics (i.e. errors or warnings) as a string, in order -- to compare it to the contents of a golden test file. printDiagnosticsForGoldenTest :: (Either P.MultipleErrors a, P.MultipleErrors) -> String diff --git a/tests/purs/.gitattributes b/tests/purs/.gitattributes new file mode 100644 index 0000000000..5fa9fa7340 --- /dev/null +++ b/tests/purs/.gitattributes @@ -0,0 +1 @@ +*.out.js -text diff --git a/tests/purs/optimize/2866.out.js b/tests/purs/optimize/2866.out.js new file mode 100644 index 0000000000..a8f0d51269 --- /dev/null +++ b/tests/purs/optimize/2866.out.js @@ -0,0 +1,15 @@ + +// Canonical test for #2866. This doesn't need to test whether `apply`s +// defined from modules other than `Data.Function` are incorrectly +// optimized since the rest of the test suite seemingly catches it. +"use strict"; +var Area = function (x) { + return x; +}; +var areaFlipped = 42; +var area = 42; +module.exports = { + Area: Area, + area: area, + areaFlipped: areaFlipped +}; diff --git a/tests/purs/optimize/2866.purs b/tests/purs/optimize/2866.purs new file mode 100644 index 0000000000..8341433354 --- /dev/null +++ b/tests/purs/optimize/2866.purs @@ -0,0 +1,12 @@ +-- Canonical test for #2866. This doesn't need to test whether `apply`s +-- defined from modules other than `Data.Function` are incorrectly +-- optimized since the rest of the test suite seemingly catches it. +module Main where + +import Prelude + +newtype Area = Area Int + +area = Area $ 42 + +areaFlipped = 42 # Area From 53b4117045f5517023f5d22f9fa506e651e4ff3e Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Tue, 21 Dec 2021 22:51:49 -0500 Subject: [PATCH 1405/1580] Update GitHub issue templates to use new tag names (#4219) --- .github/ISSUE_TEMPLATE/bug_report.md | 2 +- .github/ISSUE_TEMPLATE/compiler-proposal.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/ISSUE_TEMPLATE/bug_report.md b/.github/ISSUE_TEMPLATE/bug_report.md index ed0a1cf4a6..6aa97380fc 100644 --- a/.github/ISSUE_TEMPLATE/bug_report.md +++ b/.github/ISSUE_TEMPLATE/bug_report.md @@ -2,7 +2,7 @@ name: Bug report about: Create a report to help us improve the PureScript compiler title: '' -labels: bug +labels: 'type: bug' assignees: '' --- diff --git a/.github/ISSUE_TEMPLATE/compiler-proposal.md b/.github/ISSUE_TEMPLATE/compiler-proposal.md index 32edbffed4..889002fa08 100644 --- a/.github/ISSUE_TEMPLATE/compiler-proposal.md +++ b/.github/ISSUE_TEMPLATE/compiler-proposal.md @@ -1,7 +1,7 @@ --- name: Compiler proposal about: A concrete suggestion to change the PureScript compiler -labels: enhancement +labels: 'type: enhancement' assignees: '' --- From d4950b001916ad79daf910d54fb227417243f4de Mon Sep 17 00:00:00 2001 From: Justin Garcia <91515796+sjpgarcia@users.noreply.github.com> Date: Tue, 28 Dec 2021 03:17:06 +0800 Subject: [PATCH 1406/1580] Properly deserialize unused identifiers in the CoreFn (#4221) * Create constant for unused identifiers * Deserialize unused identifiers properly * Add changelog.d entry * Add academic account to CONTRIBUTORS.md * Derive Eq for CoreFn expressions * Add roundtrip test for UnusedIdent * Use unusedIdent constant elsewhere --- CHANGELOG.d/fix_unused_ident.md | 7 +++++++ CONTRIBUTORS.md | 2 +- lib/purescript-cst/src/Language/PureScript/Names.hs | 5 ++++- src/Language/PureScript/CodeGen/JS/Common.hs | 2 +- src/Language/PureScript/CoreFn/Binders.hs | 2 +- src/Language/PureScript/CoreFn/Expr.hs | 6 +++--- src/Language/PureScript/CoreFn/FromJSON.hs | 4 +++- tests/TestCoreFn.hs | 9 +++++++++ 8 files changed, 29 insertions(+), 8 deletions(-) create mode 100644 CHANGELOG.d/fix_unused_ident.md diff --git a/CHANGELOG.d/fix_unused_ident.md b/CHANGELOG.d/fix_unused_ident.md new file mode 100644 index 0000000000..b708866a0e --- /dev/null +++ b/CHANGELOG.d/fix_unused_ident.md @@ -0,0 +1,7 @@ +# Properly deserialize unused identifiers in the CoreFn + + This mostly affects downstream consumers of the CoreFn as discussed in + #4201. This makes it so CoreFn deserialization properly reads `$__unused` + into `UnusedIdent` instead of an `Ident`. This is particularly useful for + downstream consumers of the CoreFn such as alternative backends that don't + allow arguments to be omitted from functions. diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 7f0b556ed7..2e9b029c71 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -148,7 +148,7 @@ If you would prefer to use different terms, please use the section below instead | [@woody88](https://github.com/woody88) | Woodson Delhia | [MIT license](http://opensource.org/licenses/MIT) | | [@mhmdanas](https://github.com/mhmdanas) | Mohammed Anas | [MIT license](http://opensource.org/licenses/MIT) | | [@kl0tl](https://github.com/kl0tl) | Cyril Sobierajewicz | [MIT license](http://opensource.org/licenses/MIT) | -| [@PureFunctor](https://github.com/PureFunctor) | Justin Garcia | [MIT license](http://opensource.org/licenses/MIT) | +| [@PureFunctor](https://github.com/PureFunctor), [@sjpgarcia](https://github.com/sjpgarcia) | Justin Garcia | [MIT license](http://opensource.org/licenses/MIT) | | [@xgrommx](https://github.com/xgrommx) | Denis Stoyanov | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/lib/purescript-cst/src/Language/PureScript/Names.hs b/lib/purescript-cst/src/Language/PureScript/Names.hs index dec1fbe1b7..fe127f3e0f 100644 --- a/lib/purescript-cst/src/Language/PureScript/Names.hs +++ b/lib/purescript-cst/src/Language/PureScript/Names.hs @@ -78,11 +78,14 @@ data Ident instance NFData Ident instance Serialise Ident +unusedIdent :: Text +unusedIdent = "$__unused" + runIdent :: Ident -> Text runIdent (Ident i) = i runIdent (GenIdent Nothing n) = "$" <> T.pack (show n) runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n) -runIdent UnusedIdent = "$__unused" +runIdent UnusedIdent = unusedIdent showIdent :: Ident -> Text showIdent = runIdent diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 546d709a44..746005be68 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -23,7 +23,7 @@ moduleNameToJs (ModuleName mn) = identToJs :: Ident -> Text identToJs (Ident name) = anyNameToJs name identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" -identToJs UnusedIdent = "$__unused" +identToJs UnusedIdent = unusedIdent -- | Convert a 'ProperName' into a valid JavaScript identifier: -- diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index acff617a41..94ff20ff4b 100644 --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -31,7 +31,7 @@ data Binder a -- | -- A binder which binds its input to an identifier -- - | NamedBinder a Ident (Binder a) deriving (Show, Functor) + | NamedBinder a Ident (Binder a) deriving (Eq, Show, Functor) extractBinderAnn :: Binder a -> a diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index 981bf37c0f..bc8a953fdc 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -52,7 +52,7 @@ data Expr a -- A let binding -- | Let a [Bind a] (Expr a) - deriving (Show, Functor) + deriving (Eq, Show, Functor) -- | -- A let or module binding. @@ -65,7 +65,7 @@ data Bind a -- | -- Mutually recursive binding group for several values -- - | Rec [((a, Ident), Expr a)] deriving (Show, Functor) + | Rec [((a, Ident), Expr a)] deriving (Eq, Show, Functor) -- | -- A guard is just a boolean-valued expression that appears alongside a set of binders @@ -84,7 +84,7 @@ data CaseAlternative a = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a) - } deriving (Show) + } deriving (Eq, Show) instance Functor CaseAlternative where diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index e0f042d566..e9aaf93da3 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -99,7 +99,9 @@ literalFromJSON t = withObject "Literal" literalFromObj ObjectLiteral <$> recordFromJSON t val identFromJSON :: Value -> Parser Ident -identFromJSON = withText "Ident" (return . Ident) +identFromJSON = withText "Ident" $ \case + ident | ident == unusedIdent -> pure UnusedIdent + | otherwise -> pure $ Ident ident properNameFromJSON :: Value -> Parser (ProperName a) properNameFromJSON = fmap ProperName . parseJSON diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index f83e07bb95..bb809b796f 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -149,6 +149,15 @@ spec = context "CoreFnFromJson" $ do ] parseMod m `shouldSatisfy` isSuccess + specify "should parse UnusedIdent in Abs" $ do + let i = NonRec ann (Ident "f") (Abs ann UnusedIdent (Var ann (Qualified Nothing (Ident "x")))) + let r = parseMod $ Module ss [] mn mp [] [] M.empty [] [i] + r `shouldSatisfy` isSuccess + case r of + Error _ -> pure () + Aeson.Success Module{..} -> + moduleDecls `shouldBe` [i] + specify "should parse Case" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ From 81dd8ea73ad8eab9cc56be492fe5883bec59b8d0 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 27 Dec 2021 14:18:46 -0500 Subject: [PATCH 1407/1580] Fix type operators in declaration param kinds (#4220) This fixes an internal error triggered by using a type operator in the kind of a type parameter of a data declaration, type synonym declaration, or class declaration. --- CHANGELOG.d/fix_4218.md | 5 +++++ src/Language/PureScript/Sugar/Operators.hs | 12 ++++++++---- tests/purs/passing/TypeOperators.purs | 6 ++++++ 3 files changed, 19 insertions(+), 4 deletions(-) create mode 100644 CHANGELOG.d/fix_4218.md diff --git a/CHANGELOG.d/fix_4218.md b/CHANGELOG.d/fix_4218.md new file mode 100644 index 0000000000..83a66b54f6 --- /dev/null +++ b/CHANGELOG.d/fix_4218.md @@ -0,0 +1,5 @@ +* Fix type operators in declaration param kinds + + This fixes an internal error triggered by using a type operator in the + kind of a type parameter of a data declaration, type synonym + declaration, or class declaration. diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 8103e6c13e..bfc216a0af 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -315,19 +315,23 @@ updateTypes goType = (goDecl, goExpr, goBinder) goDecl :: Declaration -> m Declaration goDecl (DataDeclaration sa@(ss, _) ddt name args dctors) = - DataDeclaration sa ddt name args - <$> traverse (traverseDataCtorFields (traverse (sndM (goType' ss)))) dctors + DataDeclaration sa ddt name + <$> traverse (traverse (traverse (goType' ss))) args + <*> traverse (traverseDataCtorFields (traverse (sndM (goType' ss)))) dctors goDecl (ExternDeclaration sa@(ss, _) name ty) = ExternDeclaration sa name <$> goType' ss ty goDecl (TypeClassDeclaration sa@(ss, _) name args implies deps decls) = do implies' <- traverse (overConstraintArgs (traverse (goType' ss))) implies - return $ TypeClassDeclaration sa name args implies' deps decls + args' <- traverse (traverse (traverse (goType' ss))) args + return $ TypeClassDeclaration sa name args' implies' deps decls goDecl (TypeInstanceDeclaration sa@(ss, _) ch idx name cs className tys impls) = do cs' <- traverse (overConstraintArgs (traverse (goType' ss))) cs tys' <- traverse (goType' ss) tys return $ TypeInstanceDeclaration sa ch idx name cs' className tys' impls goDecl (TypeSynonymDeclaration sa@(ss, _) name args ty) = - TypeSynonymDeclaration sa name args <$> goType' ss ty + TypeSynonymDeclaration sa name + <$> traverse (traverse (traverse (goType' ss))) args + <*> goType' ss ty goDecl (TypeDeclaration (TypeDeclarationData sa@(ss, _) expr ty)) = TypeDeclaration . TypeDeclarationData sa expr <$> goType' ss ty goDecl (KindDeclaration sa@(ss, _) sigFor name ty) = diff --git a/tests/purs/passing/TypeOperators.purs b/tests/purs/passing/TypeOperators.purs index 8383b85d24..a54ecd42b0 100644 --- a/tests/purs/passing/TypeOperators.purs +++ b/tests/purs/passing/TypeOperators.purs @@ -25,4 +25,10 @@ foreign import data NatData ∷ ∀ f g. (f ~> g) -> f Type -> g Type type NatKind ∷ ∀ f g. (f ~> g) -> f Type -> g Type type NatKind k a = k a +data UseOperatorInDataParamKind (a :: Type /\ Type) = UseOperatorInDataParamKind + +type UseOperatorInTypeParamKind (a :: Type /\ Type) = Int + +class UseOperatorInClassParamKind (a :: Type /\ Type) + main = log "Done" From 69955a73441492ad7b49aa8e7a13076aa5f690e3 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sun, 30 Jan 2022 04:04:49 -0500 Subject: [PATCH 1408/1580] Rewrite `Partial` optimization to be cleaner (#4208) This feature shrinks the generated JS code for declarations that use empty type classes, such as `Partial`, but is otherwise not expected to have user-visible consequences. A previous issue involving `Partial` resulted in an ad-hoc optimization pass added to the CoreFn phase. This pass consumed code generated by the exhaustiveness checker, which used `UnusedIdent` in a questionable manner, and ran a rewrite on it that assumed that the only part of the compile that would use `UnusedIdent` in such a questionable manner was necessarily the exhaustiveness checker. This commit: * simplifies the code generated by the exhaustiveness checker for partial matches, in particular removing any use of `UnusedIdent`s; * removes the offending CoreFn optimization pass; * solves the problem originally motivating said optimization pass by using an `UnusedIdent` for the generated parameter when type-checking a value constrained by an empty type class (such parameters, importantly for our sanity, are actually unused); * and backs out a related hack in TCO that worked around such generated parameters being present but called without an argument. The intended result is simpler compiler code; happy side effects include simpler error messages involving partial pattern matches (seen here in a few golden test output changes) and simpler generated code (fewer unused function parameters, fewer local variables in some TCO-triggering functions). --- .../feature_rewrite-partial-optimization.md | 5 +++ src/Language/PureScript/CoreFn/Optimizer.hs | 11 +---- .../PureScript/CoreImp/Optimizer/TCO.hs | 4 -- src/Language/PureScript/Linter/Exhaustive.hs | 44 ++++--------------- src/Language/PureScript/TypeChecker/Types.hs | 16 +++++-- tests/purs/failing/2806.out | 11 ++--- tests/purs/failing/NonExhaustivePatGuard.out | 11 ++--- tests/purs/failing/Superclasses5.out | 13 ++---- 8 files changed, 38 insertions(+), 77 deletions(-) create mode 100644 CHANGELOG.d/feature_rewrite-partial-optimization.md diff --git a/CHANGELOG.d/feature_rewrite-partial-optimization.md b/CHANGELOG.d/feature_rewrite-partial-optimization.md new file mode 100644 index 0000000000..2ed2d14788 --- /dev/null +++ b/CHANGELOG.d/feature_rewrite-partial-optimization.md @@ -0,0 +1,5 @@ +* Rewrite `Partial` optimization to be cleaner + + This feature shrinks the generated JS code for declarations that use + empty type classes, such as `Partial`, but is otherwise not expected to + have user-visible consequences. diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index b876dfdff5..29fa7259d7 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -27,8 +27,7 @@ optimizeModuleDecls = map transformBinds where (transformBinds, _, _) = everywhereOnValues identity transformExprs identity transformExprs - = optimizeUnusedPartialFn - . optimizeClosedRecordUpdate + = optimizeClosedRecordUpdate . optimizeDataFunctionApply optimizeClosedRecordUpdate :: Expr Ann -> Expr Ann @@ -52,14 +51,6 @@ closedRecordFields (TypeApp _ (TypeConstructor _ C.Record) row) = collect _ = Nothing closedRecordFields _ = Nothing --- | See https://github.com/purescript/purescript/issues/3157 -optimizeUnusedPartialFn :: Expr a -> Expr a -optimizeUnusedPartialFn (Let _ - [NonRec _ UnusedIdent _] - (App _ (App _ (Var _ (Qualified _ UnusedIdent)) _) originalCoreFn)) = - originalCoreFn -optimizeUnusedPartialFn e = e - optimizeDataFunctionApply :: Expr a -> Expr a optimizeDataFunctionApply e = case e of (App a (App _ (Var _ (Qualified (Just (ModuleName mn)) (Ident fn))) x) y) diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index f63b499ee1..f93c6a93df 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -9,7 +9,6 @@ import Control.Monad.State (State, evalState, get, modify) import Data.Functor (($>), (<&>)) import qualified Data.Set as S import Data.Text (Text, pack) -import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.CoreImp.AST import Language.PureScript.AST.SourcePos (SourceSpan) import Safe (headDef, tailSafe) @@ -175,9 +174,6 @@ tco = flip evalState 0 . everywhereTopDownM convert where rootSS = Nothing collectArgs :: [[AST]] -> AST -> [[AST]] - collectArgs acc (App _ fn []) = - -- count 0-argument applications as single-argument so we get the correct number of args - collectArgs ([Var Nothing C.undefined] : acc) fn collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn collectArgs acc _ = acc diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index dc4131bda9..2d124b16ea 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -15,12 +15,11 @@ import Control.Applicative import Control.Arrow (first, second) import Control.Monad (unless) import Control.Monad.Writer.Class -import Control.Monad.Supply.Class (MonadSupply, fresh, freshName) +import Control.Monad.Supply.Class (MonadSupply) import Data.List (foldl', sortOn) import Data.Maybe (fromMaybe) import qualified Data.Map as M -import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.AST.Binders @@ -268,49 +267,22 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' case rr of Left Incomplete -> tellIncomplete _ -> return () - if null bss - then return expr + return $ if null bss + then expr else addPartialConstraint (second null (splitAt 5 bss)) expr where tellRedundant = tell . errorMessage' ss . uncurry OverlappingPattern . second null . splitAt 5 $ bss' tellIncomplete = tell . errorMessage' ss $ IncompleteExhaustivityCheck - -- | We add a Partial constraint by adding a call to the following identity function: - -- - -- partial :: forall a. Partial => a -> a + -- | We add a Partial constraint by annotating the expression to have type `Partial => _`. -- -- The binder information is provided so that it can be embedded in the constraint, -- and then included in the error message. - addPartialConstraint :: ([[Binder]], Bool) -> Expr -> m Expr - addPartialConstraint (bss, complete) e = do - tyVar <- ("p" <>) . T.pack . show <$> fresh - var <- freshName - return $ - Let - FromLet - [ partial var tyVar ] - $ App (Var ss (Qualified Nothing UnusedIdent)) e + addPartialConstraint :: ([[Binder]], Bool) -> Expr -> Expr + addPartialConstraint (bss, complete) e = + TypedValue True e $ + srcConstrainedType (srcConstraint C.Partial [] [] (Just constraintData)) srcTypeWildcard where - partial :: Text -> Text -> Declaration - partial var tyVar = - ValueDecl (ss, []) UnusedIdent Private [] - [MkUnguarded - (TypedValue - True - (Abs (VarBinder ss (Ident var)) (Var ss (Qualified Nothing (Ident var)))) - (ty tyVar)) - ] - - ty :: Text -> SourceType - ty tyVar = - srcForAll tyVar - Nothing - ( srcConstrainedType - (srcConstraint C.Partial [] [] (Just constraintData)) - $ srcTypeApp (srcTypeApp tyFunction (srcTypeVar tyVar)) (srcTypeVar tyVar) - ) - Nothing - constraintData :: ConstraintData constraintData = PartialConstraintData (map (map prettyPrintBinderAtom) bss) complete diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index c0c37d042f..b5b3d0c4fa 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -75,6 +75,12 @@ data TypedValue' = TypedValue' Bool Expr SourceType tvToExpr :: TypedValue' -> Expr tvToExpr (TypedValue' c e t) = TypedValue c e t +-- | Lookup data about a type class in the @Environment@ +lookupTypeClass :: MonadState CheckState m => Qualified (ProperName 'ClassName) -> m TypeClassData +lookupTypeClass name = + let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup name + in gets (findClass . typeClasses . checkEnv) + -- | Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. typesOf @@ -116,8 +122,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -- ambiguous types to be inferred if they can be solved by some functional -- dependency. conData <- forM unsolved $ \(_, _, con) -> do - let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup (constraintClass con) - TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv) + TypeClassData{ typeClassDependencies } <- lookupTypeClass $ constraintClass con let -- The set of unknowns mentioned in each argument. unknownsForArg :: [S.Set Int] @@ -670,8 +675,11 @@ check' val (ForAll ann ident mbK ty _) = do | otherwise = val val' <- tvToExpr <$> check skVal sk return $ TypedValue' True val' (ForAll ann ident mbK ty (Just scope)) -check' val t@(ConstrainedType _ con@(Constraint _ (Qualified _ (ProperName className)) _ _ _) ty) = do - dictName <- freshIdent ("dict" <> className) +check' val t@(ConstrainedType _ con@(Constraint _ cls@(Qualified _ (ProperName className)) _ _ _) ty) = do + TypeClassData{ typeClassIsEmpty } <- lookupTypeClass cls + -- An empty class dictionary is never used; see code in `TypeChecker.Entailment` + -- that wraps empty dictionary solutions in `Unused`. + dictName <- if typeClassIsEmpty then pure UnusedIdent else freshIdent ("dict" <> className) dicts <- newDictionaries [] (Qualified Nothing dictName) con val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty return $ TypedValue' True (Abs (VarBinder nullSourceSpan dictName) (tvToExpr val')) t diff --git a/tests/purs/failing/2806.out b/tests/purs/failing/2806.out index b089ac5a1b..f5daaaf170 100644 --- a/tests/purs/failing/2806.out +++ b/tests/purs/failing/2806.out @@ -9,13 +9,10 @@ at tests/purs/failing/2806.purs:6:1 - 6:29 (line 6, column 1 - line 6, column 29 Alternatively, add a Partial constraint to the type of the enclosing value. -while applying a function $__unused - of type Partial => t1 -> t1 - to argument case e of  -  e | L x <- e -> x -while checking that expression $__unused (case e of  -  e | L x <- e -> x -  )  +while checking that type Partial => t1 + is at least as general as type a0 +while checking that expression case e of  +  e | L x <- e -> x has type a0 in value declaration g diff --git a/tests/purs/failing/NonExhaustivePatGuard.out b/tests/purs/failing/NonExhaustivePatGuard.out index 51b24a58fd..18d547672b 100644 --- a/tests/purs/failing/NonExhaustivePatGuard.out +++ b/tests/purs/failing/NonExhaustivePatGuard.out @@ -9,13 +9,10 @@ at tests/purs/failing/NonExhaustivePatGuard.purs:4:1 - 4:16 (line 4, column 1 - Alternatively, add a Partial constraint to the type of the enclosing value. -while applying a function $__unused - of type Partial => t0 -> t0 - to argument case x of  -  x | 1 <- x -> x -while checking that expression $__unused (case x of  -  x | 1 <- x -> x -  )  +while checking that type Partial => t0 + is at least as general as type Int +while checking that expression case x of  +  x | 1 <- x -> x has type Int in value declaration f diff --git a/tests/purs/failing/Superclasses5.out b/tests/purs/failing/Superclasses5.out index 2e708648e2..9514bdf756 100644 --- a/tests/purs/failing/Superclasses5.out +++ b/tests/purs/failing/Superclasses5.out @@ -9,15 +9,10 @@ at tests/purs/failing/Superclasses5.purs:17:1 - 18:18 (line 17, column 1 - line Alternatively, add a Partial constraint to the type of the enclosing value. -while applying a function $__unused - of type Partial => t0 -> t0 - to argument case $0 of  -  [ x ] -> [ su x -  ]  -while inferring the type of $__unused (case $0 of  -  [ x ] -> [ ... -  ]  -  )  +while checking that expression case $0 of  +  [ x ] -> [ su x +  ]  + has type t0 in value declaration suArray where t0 is an unknown type From 7bf9e618280fbde18c0932e8875ec0595e825e37 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sun, 30 Jan 2022 04:06:13 -0500 Subject: [PATCH 1409/1580] Scope type vars when type checking typed values (#4216) When the compiler is checking an expression that is annotated with a type against another expected type, and the annotation introduces a type variable, the compiler needs to introduce that type variable to the scope of any types used inside the expression. One noteworthy case of this pattern is member signatures inside instances. This fix allows type variables introduced in member signatures to be used in the member declaration itself. --- ...ype-vars-when-type-checking-typed-values.md | 10 ++++++++++ src/Language/PureScript/TypeChecker/Types.hs | 5 +++-- tests/purs/passing/2941.purs | 18 ++++++++++++++++++ 3 files changed, 31 insertions(+), 2 deletions(-) create mode 100644 CHANGELOG.d/fix_scope-type-vars-when-type-checking-typed-values.md create mode 100644 tests/purs/passing/2941.purs diff --git a/CHANGELOG.d/fix_scope-type-vars-when-type-checking-typed-values.md b/CHANGELOG.d/fix_scope-type-vars-when-type-checking-typed-values.md new file mode 100644 index 0000000000..6fe9272cfb --- /dev/null +++ b/CHANGELOG.d/fix_scope-type-vars-when-type-checking-typed-values.md @@ -0,0 +1,10 @@ +* Scope type vars when type checking typed values + + When the compiler is checking an expression that is annotated with a + type against another expected type, and the annotation introduces a type + variable, the compiler needs to introduce that type variable to the + scope of any types used inside the expression. + + One noteworthy case of this pattern is member signatures inside + instances. This fix allows type variables introduced in member + signatures to be used in the member declaration itself. diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index b5b3d0c4fa..1c2951528e 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -734,7 +734,8 @@ check' (DeferredDictionary className tys) ty = do (TypeClassDictionary con dicts hints) ty check' (TypedValue checkType val ty1) ty2 = do - (elabTy1, kind1) <- kindOf ty1 + moduleName <- unsafeCheckCurrentModule + ((args, elabTy1), kind1) <- kindOfWithScopedVars ty1 (elabTy2, kind2) <- kindOf ty2 unifyKinds' kind1 kind2 checkTypeKind ty1 kind1 @@ -742,7 +743,7 @@ check' (TypedValue checkType val ty1) ty2 = do ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy2 elaborate <- subsumes ty1' ty2' val' <- if checkType - then tvToExpr <$> check val ty1' + then withScopedTypeVars moduleName args $ tvToExpr <$> check val ty1' else pure val return $ TypedValue' True (TypedValue checkType (elaborate val') ty1') ty2' check' (Case vals binders) ret = do diff --git a/tests/purs/passing/2941.purs b/tests/purs/passing/2941.purs new file mode 100644 index 0000000000..126cd024ff --- /dev/null +++ b/tests/purs/passing/2941.purs @@ -0,0 +1,18 @@ +module Main where + +import Effect.Console (log) + +test0 = ((((\_ -> 0) :: b -> Int) :: forall b. b -> Int) :: forall a. a -> Int) + +test1 :: {attr :: forall a. a -> Int} +test1 = {attr: ((\_ -> 0) :: b -> Int) :: forall b. b -> Int} + +class Test2 where + f :: forall a. a -> a + +instance test2 :: Test2 where + f :: forall a. a -> a + f x = (x :: a) + + +main = log "Done" From 0b5abdb5f46923bfa10b8fb3335900b8cd87ef0c Mon Sep 17 00:00:00 2001 From: Verity Scheel Date: Fri, 18 Feb 2022 17:16:23 -0500 Subject: [PATCH 1410/1580] Add myself to contributors (#4237) Somehow I forgot to do this earlier. --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 2e9b029c71..9f9f252bbd 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -150,6 +150,7 @@ If you would prefer to use different terms, please use the section below instead | [@kl0tl](https://github.com/kl0tl) | Cyril Sobierajewicz | [MIT license](http://opensource.org/licenses/MIT) | | [@PureFunctor](https://github.com/PureFunctor), [@sjpgarcia](https://github.com/sjpgarcia) | Justin Garcia | [MIT license](http://opensource.org/licenses/MIT) | | [@xgrommx](https://github.com/xgrommx) | Denis Stoyanov | [MIT license](http://opensource.org/licenses/MIT) | +| [@MonoidMusician](https://github.com/MonoidMusician) | Verity Scheel | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms From 7f385cd116b6ac51cea49df01529d031580db005 Mon Sep 17 00:00:00 2001 From: Thomas Honeyman Date: Fri, 25 Feb 2022 06:33:50 -0800 Subject: [PATCH 1411/1580] Support the purs.json manifest in purs publish (#4233) * Add @thomashoneyman to contributors * Add stack.yaml.lock to .gitignore * Add purs.json manifest file in tests * Scaffold registry types and update tests * Add compatibility module to maintain the existing pipeline * Prefix package names when converting to Bower * Remove registry metadata types and files * Move isPursJson check closer to use site * Add changelog entry * Explicitly include purs.json files * Rename purs.json fields * Revert doc comment update * Update error message * Update repository error message, add 'purescript-' to bower package meta * Better errors for location field, remove version JSON parsing --- .gitignore | 1 + .../feature_support-purs-json-manifest.md | 13 +++ CONTRIBUTORS.md | 1 + purescript.cabal | 1 + src/Language/PureScript/Docs/Types.hs | 21 +++- src/Language/PureScript/Publish.hs | 47 ++++++--- .../PureScript/Publish/ErrorsWarnings.hs | 39 ++++++-- .../PureScript/Publish/Registry/Compat.hs | 98 +++++++++++++++++++ tests/TestDocs.hs | 2 +- tests/TestPscPublish.hs | 27 +++-- tests/purs/docs/purs.json | 11 +++ tests/purs/publish/basic-example/purs.json | 14 +++ 12 files changed, 237 insertions(+), 38 deletions(-) create mode 100644 CHANGELOG.d/feature_support-purs-json-manifest.md create mode 100644 src/Language/PureScript/Publish/Registry/Compat.hs create mode 100644 tests/purs/docs/purs.json create mode 100644 tests/purs/publish/basic-example/purs.json diff --git a/.gitignore b/.gitignore index 4cd805aa1b..5ac1c2d1b9 100644 --- a/.gitignore +++ b/.gitignore @@ -3,6 +3,7 @@ bin dist cabal-dev .cabal-sandbox +stack.yaml.lock cabal.sandbox.config dist-newstyle/ cabal.project.local* diff --git a/CHANGELOG.d/feature_support-purs-json-manifest.md b/CHANGELOG.d/feature_support-purs-json-manifest.md new file mode 100644 index 0000000000..f702c4e7ff --- /dev/null +++ b/CHANGELOG.d/feature_support-purs-json-manifest.md @@ -0,0 +1,13 @@ +- Add support for publishing via the `purs.json` manifest format + + This feature expands compiler support for publishing packages with different + manifest formats. Previously, packages had to have a `bower.json` manifest; + now, packages can choose to have a `purs.json` manifest instead. + + This feature provides only partial support for packages published to the + PureScript registry using the `purs.json` manifest format. Registry packages + are allowed to be hosted anywhere (not just GitHub), and do not need to be + Git repositories at all. However, `purs publish` and its primary consumer, + Pursuit, both require packages to be available on GitHub and for their version + to be a SemVer-compliant Git tag. Therefore, this feature only supports + registry packages that are compatible with these restrictions. diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 9f9f252bbd..79484f6ce2 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -151,6 +151,7 @@ If you would prefer to use different terms, please use the section below instead | [@PureFunctor](https://github.com/PureFunctor), [@sjpgarcia](https://github.com/sjpgarcia) | Justin Garcia | [MIT license](http://opensource.org/licenses/MIT) | | [@xgrommx](https://github.com/xgrommx) | Denis Stoyanov | [MIT license](http://opensource.org/licenses/MIT) | | [@MonoidMusician](https://github.com/MonoidMusician) | Verity Scheel | [MIT license](http://opensource.org/licenses/MIT) | +| [@thomashoneyman](https://github.com/thomashoneyman) | Thomas Honeyman | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/purescript.cabal b/purescript.cabal index 765ddabdf3..de591de44f 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -281,6 +281,7 @@ library Language.PureScript.Publish Language.PureScript.Publish.BoxesHelpers Language.PureScript.Publish.ErrorsWarnings + Language.PureScript.Publish.Registry.Compat Language.PureScript.Publish.Utils Language.PureScript.Renamer Language.PureScript.Sugar diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index be7cdbe3dc..836e2afc86 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -39,6 +39,7 @@ import Language.PureScript.Docs.RenderedCode as ReExports ContainingModule(..), asContainingModule, RenderedCodeElement(..), Namespace(..), FixityAlias) +import Language.PureScript.Publish.Registry.Compat (PursJsonError, showPursJsonError) type Type' = P.Type () type Constraint' = P.Constraint () @@ -75,7 +76,17 @@ instance NFData NotYetKnown type UploadedPackage = Package NotYetKnown type VerifiedPackage = Package GithubUser -type ManifestError = BowerError +data ManifestError + = BowerManifest BowerError + | PursManifest PursJsonError + deriving (Show, Eq, Ord, Generic) + +instance NFData ManifestError + +showManifestError :: ManifestError -> Text +showManifestError = \case + BowerManifest err -> showBowerError err + PursManifest err -> showPursJsonError err verifyPackage :: GithubUser -> UploadedPackage -> VerifiedPackage verifyPackage verifiedUser Package{..} = @@ -481,7 +492,7 @@ asPackage minimumVersion uploader = do when (compilerVersion < minimumVersion) (throwCustomError $ CompilerTooOld minimumVersion compilerVersion) - Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta + Package <$> key "packageMeta" asPackageMeta .! (ErrorInPackageMeta . BowerManifest) <*> key "version" asVersion <*> key "versionTag" asText <*> keyMay "tagTime" (withString parseTimeEither) @@ -516,7 +527,7 @@ displayPackageError e = case e of <> " of the compiler, but it appears that " <> T.pack (showVersion usedV) <> " was used." ErrorInPackageMeta err -> - "Error in package metadata: " <> showBowerError err + "Error in package metadata: " <> showManifestError err InvalidVersion -> "Invalid version" InvalidDeclarationType str -> @@ -584,7 +595,7 @@ p `pOr` q = catchError p (const q) asInPackage :: Parse ManifestError a -> Parse ManifestError (InPackage a) asInPackage inner = - build <$> key "package" (perhaps (withText parsePackageName)) + build <$> key "package" (perhaps (withText (mapLeft BowerManifest . parsePackageName))) <*> key "item" inner where build Nothing = Local @@ -740,7 +751,7 @@ asResolvedDependencies = parsePackageName' :: Text -> Either PackageError PackageName parsePackageName' = - mapLeft ErrorInPackageMeta . parsePackageName + mapLeft ErrorInPackageMeta . (mapLeft BowerManifest . parsePackageName) mapLeft :: (a -> a') -> Either a b -> Either a' b mapLeft f (Left x) = Left (f x) diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index dd82843dc9..2e1d468abe 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -23,7 +23,6 @@ import Control.Arrow ((***)) import Control.Category ((>>>)) import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell) -import Data.Aeson.BetterErrors (Parse, parse, keyMay, eachInObjectWithKey, key, asString, withString) import qualified Data.ByteString.Lazy as BL import Data.String (String, lines) import Data.List (stripPrefix, (\\)) @@ -42,15 +41,19 @@ import Web.Bower.PackageMeta (PackageMeta(..), PackageName, Repository(..)) import qualified Web.Bower.PackageMeta as Bower import Language.PureScript.Publish.ErrorsWarnings +import Language.PureScript.Publish.Registry.Compat import Language.PureScript.Publish.Utils import qualified Language.PureScript as P (version, ModuleName) import qualified Language.PureScript.CoreFn.FromJSON as P import qualified Language.PureScript.Docs as D +import Data.Aeson.BetterErrors (Parse, withString, eachInObjectWithKey, asString, key, keyMay, parse, mapError) +import Language.PureScript.Docs.Types (ManifestError(BowerManifest, PursManifest)) data PublishOptions = PublishOptions { -- | How to obtain the version tag and version that the data being -- generated will refer to. publishGetVersion :: PrepareM (Text, Version) + -- | How to obtain at what time the version was committed , publishGetTagTime :: Text -> PrepareM UTCTime , -- | What to do when the working tree is dirty publishWorkingTreeDirty :: PrepareM () @@ -128,11 +131,23 @@ catchLeft a f = either f pure a preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage preparePackage' opts = do - unlessM (liftIO (doesFileExist (publishManifestFile opts))) (userError PackageManifestNotFound) checkCleanWorkingTree opts - pkgMeta <- liftIO (Bower.decodeFile (publishManifestFile opts)) - >>= flip catchLeft (userError . CouldntDecodePackageManifest) + let manifestPath = publishManifestFile opts + pkgMeta <- liftIO (try (BL.readFile manifestPath)) >>= \case + Left (_ :: IOException) -> + userError $ PackageManifestNotFound manifestPath + Right found -> do + -- We can determine the type of the manifest file based on the file path, + -- as both the PureScript and Bower registries require their manifest + -- files to have specific names. + let isPursJson = "purs.json" `T.isInfixOf` T.pack manifestPath + if isPursJson then do + pursJson <- catchLeft (parse (mapError PursManifest asPursJson) found) (userError . CouldntDecodePackageManifest) + catchLeft (toBowerPackage pursJson) (userError . CouldntConvertPackageManifest) + else + catchLeft (parse (mapError BowerManifest Bower.asPackageMeta) found) (userError . CouldntDecodePackageManifest) + checkLicense pkgMeta (pkgVersionTag, pkgVersion) <- publishGetVersion opts @@ -143,15 +158,12 @@ preparePackage' opts = do (pkgModules, pkgModuleMap) <- getModules opts (map (second fst) resolvedDeps) - let declaredDeps = map fst $ - Bower.bowerDependencies pkgMeta - ++ Bower.bowerDevDependencies pkgMeta + let declaredDeps = map fst $ Bower.bowerDependencies pkgMeta ++ Bower.bowerDevDependencies pkgMeta pkgResolvedDependencies <- handleDeps declaredDeps (map (second snd) resolvedDeps) let pkgUploader = D.NotYetKnown let pkgCompilerVersion = P.version - return D.Package{..} getModules @@ -169,17 +181,24 @@ getModules opts paths = do data TreeStatus = Clean | Dirty deriving (Show, Eq, Ord, Enum) -getGitWorkingTreeStatus :: PrepareM TreeStatus -getGitWorkingTreeStatus = do - out <- readProcess' "git" ["status", "--porcelain"] "" +getGitWorkingTreeStatus :: FilePath -> PrepareM TreeStatus +getGitWorkingTreeStatus manifestFilePath = do + output <- lines <$> readProcess' "git" ["status", "--porcelain"] "" + -- The PureScript registry generates purs.json files when publishing legacy + -- packages. To ensure these packages can also be published to Pursuit, we + -- include an exemption to the working tree status check that will ignore + -- untracked purs.json files. Note that _modified_ purs.json files will + -- still fail this check. + let untrackedPursJson = "?? " <> manifestFilePath + let filtered = filter (/= untrackedPursJson) output return $ - if all null . lines $ out + if all null filtered then Clean else Dirty checkCleanWorkingTree :: PublishOptions -> PrepareM () checkCleanWorkingTree opts = do - status <- getGitWorkingTreeStatus + status <- getGitWorkingTreeStatus (publishManifestFile opts) unless (status == Clean) $ publishWorkingTreeDirty opts @@ -330,7 +349,7 @@ asVersion = withString (note D.InvalidVersion . P.parseVersion') parsePackageName :: Text -> Either D.PackageError PackageName -parsePackageName = first D.ErrorInPackageMeta . Bower.parsePackageName +parsePackageName = first D.ErrorInPackageMeta . D.mapLeft BowerManifest . Bower.parsePackageName handleDeps :: [PackageName] diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 94c84c80b7..84087f55c0 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -31,6 +31,8 @@ import qualified Language.PureScript as P import Language.PureScript.Publish.BoxesHelpers import Web.Bower.PackageMeta (PackageName, runPackageName, showBowerError) +import qualified Web.Bower.PackageMeta as Bower +import Language.PureScript.Docs.Types (showManifestError) -- | An error which meant that it was not possible to retrieve metadata for a -- package. @@ -48,8 +50,9 @@ data PackageWarning -- | An error that should be fixed by the user. data UserError - = PackageManifestNotFound + = PackageManifestNotFound FilePath | ResolutionsFileNotFound + | CouldntConvertPackageManifest Bower.BowerError | CouldntDecodePackageManifest (ParseError D.ManifestError) | TagMustBeCheckedOut | AmbiguousVersions [Version] -- Invariant: should contain at least two elements @@ -115,17 +118,26 @@ renderError err = displayUserError :: UserError -> Box displayUserError e = case e of - PackageManifestNotFound -> - para ( - "The package manifest file was not found. Please create one, or run " ++ - "`pulp init`." - ) + PackageManifestNotFound path -> do + vcat + [ para "The package manifest file was not found:" + , indented (para path) + , spacer + , para "Please create either a bower.json or purs.json manifest file." + ] ResolutionsFileNotFound -> para "The resolutions file was not found." + CouldntConvertPackageManifest err -> + vcat + [ para "Unable to convert your package manifest file to the Bower format:" + , indented ((para . T.unpack) (showBowerError err)) + , spacer + , para "Please ensure that your package manifest file is valid." + ] CouldntDecodePackageManifest err -> vcat [ para "There was a problem with your package manifest file:" - , indented (vcat (map (para . T.unpack) (displayError showBowerError err))) + , indented (vcat (map (para . T.unpack) (displayError showManifestError err))) , spacer , para "Please ensure that your package manifest file is valid." ] @@ -234,10 +246,10 @@ displayRepositoryError err = case err of RepositoryFieldMissing giturl -> vcat [ para (concat - [ "The 'repository' field is not present in your package manifest file. " + [ "The 'repository' or 'location' field is not present in your package manifest file. " , "Without this information, Pursuit would not be able to generate " , "source links in your package's documentation. Please add one - like " - , "this, for example:" + , "this, if you are using the bower.json format:" ]) , spacer , indented (vcat @@ -247,6 +259,15 @@ displayRepositoryError err = case err of , para "}" ] ) + , para "or like this, if you are using the purs.json format:" + , spacer + , indented (vcat + [ para "\"location\": {" + , indented (para "\"githubOwner\": \"USER\",") + , indented (para "\"githubRepo\": \"REPO\",") + , para "}" + ] + ) ] BadRepositoryType ty -> para (concat diff --git a/src/Language/PureScript/Publish/Registry/Compat.hs b/src/Language/PureScript/Publish/Registry/Compat.hs new file mode 100644 index 0000000000..d9bf5038ae --- /dev/null +++ b/src/Language/PureScript/Publish/Registry/Compat.hs @@ -0,0 +1,98 @@ +-- | A compatibility module that allows a restricted set of purs.json manifest +-- | files to be used for publishing. The manifest must described a package +-- | available on GitHub, and it must be convertable to a Bower manifest. +-- | +-- | Fully supporting the registry manifest format will require `purs publish` +-- | and by extension Pursuit to relax the requirement that packages are hosted +-- | on GitHub, because the registry does not have this requirement. +module Language.PureScript.Publish.Registry.Compat where + +import Protolude +import qualified Data.Map as Map +import qualified Web.Bower.PackageMeta as Bower +import Data.Bitraversable (Bitraversable(..)) +import Data.Aeson.BetterErrors (key, asText, keyMay, eachInObject, Parse, throwCustomError) + +-- | Convert a valid purs.json manifest into a bower.json manifest +toBowerPackage :: PursJson -> Either Bower.BowerError Bower.PackageMeta +toBowerPackage PursJson{..} = do + bowerName <- Bower.parsePackageName ("purescript-" <> pursJsonName) + let + bowerDescription = pursJsonDescription + bowerMain = [] + bowerModuleType = [] + bowerLicense = [ pursJsonLicense ] + bowerIgnore = [] + bowerKeywords = [] + bowerAuthors = [] + bowerHomepage = Just pursJsonLocation + bowerRepository = Just $ Bower.Repository { repositoryUrl = pursJsonLocation, repositoryType = "git" } + bowerDevDependencies = [] + bowerResolutions = [] + bowerPrivate = False + + let parseDependencies = traverse (bitraverse (Bower.parsePackageName . ("purescript-" <>)) (pure . Bower.VersionRange)) + bowerDependencies <- parseDependencies $ Map.toAscList pursJsonDependencies + pure $ Bower.PackageMeta {..} + +-- | A partial representation of the purs.json manifest format, including only +-- | the fields required for publishing. +-- | +-- | https://github.com/purescript/registry/blob/master/v1/Manifest.dhall +-- +-- This type is intended for compatibility with the Bower publishing pipeline, +-- and does not accurately reflect all possible purs.json manifests. However, +-- supporting purs.json manifests properly introduces breaking changes to the +-- compiler and to Pursuit. +data PursJson = PursJson + { -- | The name of the package + pursJsonName :: Text + -- | The SPDX identifier representing the package license + , pursJsonLicense :: Text + -- | The GitHub repository hosting the package + , pursJsonLocation :: Text + -- | An optional description of the package + , pursJsonDescription :: Maybe Text + -- | A map of dependencies, where keys are package names and values are + -- | dependency ranges of the form '>=X.Y.Z Text +showPursJsonError = \case + MalformedLocationField -> + "The 'location' field must be either '{ \"githubOwner\": OWNER, \"githubRepo\": REPO }' or '{ \"gitUrl\": URL }'." + +asPursJson :: Parse PursJsonError PursJson +asPursJson = do + pursJsonName <- key "name" asText + pursJsonDescription <- keyMay "description" asText + pursJsonLicense <- key "license" asText + pursJsonDependencies <- key "dependencies" (Map.fromAscList <$> eachInObject asText) + -- Packages are required to come from GitHub in PureScript 0.14.x, but the + -- PureScript registry does not require this, nor does it require that + -- packages are Git repositories. This restriction should be lifted when + -- we fully support purs.json manifests in the compiler and on Pursuit. + -- + -- For the time being, we only parse manifests that include a GitHub owner + -- and repo pair, or which specify a Git URL, which we use to try and get + -- the package from GitHub. + pursJsonLocation <- key "location" asOwnerRepoOrGitUrl + pure $ PursJson{..} + where + asOwnerRepoOrGitUrl = + catchError asOwnerRepo (\_ -> catchError asGitUrl (\_ -> throwCustomError MalformedLocationField)) + + asGitUrl = + key "gitUrl" asText + + asOwnerRepo = do + githubOwner <- key "githubOwner" asText + githubRepo <- key "githubRepo" asText + pure $ "https://github.com/" <> githubOwner <> "/" <> githubRepo <> ".git" diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 00fe60a5b3..b941a56d18 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -26,7 +26,7 @@ import TestPscPublish (preparePackage) import Test.Hspec spec :: Spec -spec = beforeAll (handleDocPrepFailure <$> preparePackage "tests/purs/docs" "resolutions.json") $ +spec = beforeAll (handleDocPrepFailure <$> preparePackage "tests/purs/docs" "purs.json" "resolutions.json") $ context "Language.PureScript.Docs" $ do context "Doc generation tests:" $ mkSpec testCases displayAssertion $ \a pkg mdl -> diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 374fc0c6f2..86c5b3b116 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -29,11 +29,19 @@ spec = do it "purescript-prelude" $ do testPackage "tests/support/bower_components/purescript-prelude" + "bower.json" "../../prelude-resolutions.json" - it "basic example" $ do + it "basic example (bower.json)" $ do testPackage "tests/purs/publish/basic-example" + "bower.json" + "resolutions.json" + + it "basic example (purs.json)" $ do + testPackage + "tests/purs/publish/basic-example" + "purs.json" "resolutions.json" context "json compatibility" $ do @@ -68,9 +76,10 @@ roundTrip pkg = then Pass before' else Mismatch before' after' -testRunOptions :: FilePath -> PublishOptions -testRunOptions resolutionsFile = defaultPublishOptions +testRunOptions :: FilePath -> FilePath -> PublishOptions +testRunOptions manifestFile resolutionsFile = defaultPublishOptions { publishResolutionsFile = resolutionsFile + , publishManifestFile = manifestFile , publishGetVersion = return testVersion , publishGetTagTime = const (liftIO getCurrentTime) , publishWorkingTreeDirty = return () @@ -79,9 +88,9 @@ testRunOptions resolutionsFile = defaultPublishOptions -- | Given a directory which contains a package, produce JSON from it, and then -- | attempt to parse it again, and ensure that it doesn't change. -testPackage :: FilePath -> FilePath -> Expectation -testPackage packageDir resolutionsFile = do - res <- preparePackage packageDir resolutionsFile +testPackage :: FilePath -> FilePath -> FilePath -> Expectation +testPackage packageDir manifestFile resolutionsFile = do + res <- preparePackage packageDir manifestFile resolutionsFile case res of Left err -> expectationFailure $ @@ -100,11 +109,11 @@ testPackage packageDir resolutionsFile = do -- output directory each time to ensure that we are actually testing the docs -- code in the working tree as it is now (as opposed to how it was at some -- point in the past when the tests were previously successfully run). -preparePackage :: FilePath -> FilePath -> IO (Either Publish.PackageError UploadedPackage) -preparePackage packageDir resolutionsFile = +preparePackage :: FilePath -> FilePath -> FilePath -> IO (Either Publish.PackageError UploadedPackage) +preparePackage packageDir manifestFile resolutionsFile = pushd packageDir $ do removeDirectoryRecursiveIfPresent "output" - Publish.preparePackage (testRunOptions resolutionsFile) + Publish.preparePackage (testRunOptions manifestFile resolutionsFile) removeDirectoryRecursiveIfPresent :: FilePath -> IO () removeDirectoryRecursiveIfPresent = diff --git a/tests/purs/docs/purs.json b/tests/purs/docs/purs.json new file mode 100644 index 0000000000..4125508db4 --- /dev/null +++ b/tests/purs/docs/purs.json @@ -0,0 +1,11 @@ +{ + "name": "docs-test-package", + "license": "MIT", + "version": "1.0.0", + "location": { + "gitUrl": "https://github.com/not-real/not-a-real-repo.git" + }, + "dependencies": { + "prelude": ">=1.0.0 <2.0.0" + } +} diff --git a/tests/purs/publish/basic-example/purs.json b/tests/purs/publish/basic-example/purs.json new file mode 100644 index 0000000000..bed21e3be3 --- /dev/null +++ b/tests/purs/publish/basic-example/purs.json @@ -0,0 +1,14 @@ +{ + "name": "basic-example", + "version": "1.0.0", + "license": "MIT", + "location": { + "githubOwner": "purescript", + "githubRepo": "test" + }, + "dependencies": { + "console": ">=1.0.0 <2.0.0", + "prelude": ">=1.0.0 <2.0.0", + "effect": ">=1.0.0 <2.0.0" + } +} From a1023905b5f41363969591b7d3f7fb6e3cd0a5c7 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 25 Feb 2022 11:49:53 -0600 Subject: [PATCH 1412/1580] Make v0.14.6 PS release (#4236) * Run `make license-generator` * Update version to 0.14.6 * Update changelog via purs-changelog --- .../feature_display roles in html docs.md | 49 ------- .../feature_make-quote-work-on-more-kinds.md | 1 - .../feature_rewrite-partial-optimization.md | 5 - .../feature_support-purs-json-manifest.md | 13 -- CHANGELOG.d/fix_4218.md | 5 - ...-declarations-arity-during-typechecking.md | 1 - CHANGELOG.d/fix_ctor-spans.md | 1 - CHANGELOG.d/fix_newtype_dollar.md | 1 - ...pe-vars-when-type-checking-typed-values.md | 10 -- CHANGELOG.d/fix_unused_ident.md | 7 - .../internal_build-package-set-in-ci.md | 3 - CHANGELOG.d/internal_bump-to-lts-18.md | 1 - .../internal_fix-internal-error-hangs.md | 1 - .../internal_no-explicit-disable-nix.md | 5 - .../internal_optimization_golden_tests.md | 5 - CHANGELOG.md | 131 ++++++++++++++++++ LICENSE | 107 ++++++++++---- lib/purescript-cst/README.md | 1 + npm-package/package.json | 4 +- purescript.cabal | 2 +- 20 files changed, 216 insertions(+), 137 deletions(-) delete mode 100644 CHANGELOG.d/feature_display roles in html docs.md delete mode 100644 CHANGELOG.d/feature_make-quote-work-on-more-kinds.md delete mode 100644 CHANGELOG.d/feature_rewrite-partial-optimization.md delete mode 100644 CHANGELOG.d/feature_support-purs-json-manifest.md delete mode 100644 CHANGELOG.d/fix_4218.md delete mode 100644 CHANGELOG.d/fix_check-role-declarations-arity-during-typechecking.md delete mode 100644 CHANGELOG.d/fix_ctor-spans.md delete mode 100644 CHANGELOG.d/fix_newtype_dollar.md delete mode 100644 CHANGELOG.d/fix_scope-type-vars-when-type-checking-typed-values.md delete mode 100644 CHANGELOG.d/fix_unused_ident.md delete mode 100644 CHANGELOG.d/internal_build-package-set-in-ci.md delete mode 100644 CHANGELOG.d/internal_bump-to-lts-18.md delete mode 100644 CHANGELOG.d/internal_fix-internal-error-hangs.md delete mode 100644 CHANGELOG.d/internal_no-explicit-disable-nix.md delete mode 100644 CHANGELOG.d/internal_optimization_golden_tests.md diff --git a/CHANGELOG.d/feature_display roles in html docs.md b/CHANGELOG.d/feature_display roles in html docs.md deleted file mode 100644 index 819b720ed0..0000000000 --- a/CHANGELOG.d/feature_display roles in html docs.md +++ /dev/null @@ -1,49 +0,0 @@ -* Display role annotations in HTML docs - - Previously, the HTML docs would not indicate which types could be safely - coerced and which could not: - - ```purescript - -- cannot be coerced - data Foo1 a = Foo1 a - type role Foo1 nominal - - -- can be coerced - data Foo2 a = Foo2 - type role Foo2 phantom - - -- can be coerced in some contexts - data Foo3 a = Foo3 a - type role Foo3 representational - ``` - - The HTML docs now display the role annotations either explicitly - declared by the developer or those inferred by the compiler. - - Since role annotations are an advanced feature and since most type - parameters' roles are the `representational` role, the `phantom` and - `nominal` role annotations are displayed in documentation whereas the - `representational` role is not, similar to "uninteresting" kind signatures. - - Lastly, FFI declarations like below... - - ```purescript - foreign import data Foo :: (Type -> Type) -> Type - type role Foo nominal - ``` - - ...will be rendered as though they are data declarations: - - ```purescript - data Foo :: (Type -> Type) -> Type - data Foo t0 - type role Foo nominal - ``` - - One can distinguish FFI declarations with roles separately from normal `data` - declarations that have roles based on the name of the type parameters. Since FFI declarations' type parameters are implicit and thus unnamed, the compiler will generate their name: `t0`, `t1`, ..., `tN` where `N` is a zero-based - index of the type parameter. - - Note: the resulting documentation will display the roles, but the roles - will not be selectable when selecting the type in case one wants to - copy-paste the type into source code. diff --git a/CHANGELOG.d/feature_make-quote-work-on-more-kinds.md b/CHANGELOG.d/feature_make-quote-work-on-more-kinds.md deleted file mode 100644 index 7346df247d..0000000000 --- a/CHANGELOG.d/feature_make-quote-work-on-more-kinds.md +++ /dev/null @@ -1 +0,0 @@ -* Make `Prim.TypeError`'s `Quote` work on all kinds, not just kind `Type`. diff --git a/CHANGELOG.d/feature_rewrite-partial-optimization.md b/CHANGELOG.d/feature_rewrite-partial-optimization.md deleted file mode 100644 index 2ed2d14788..0000000000 --- a/CHANGELOG.d/feature_rewrite-partial-optimization.md +++ /dev/null @@ -1,5 +0,0 @@ -* Rewrite `Partial` optimization to be cleaner - - This feature shrinks the generated JS code for declarations that use - empty type classes, such as `Partial`, but is otherwise not expected to - have user-visible consequences. diff --git a/CHANGELOG.d/feature_support-purs-json-manifest.md b/CHANGELOG.d/feature_support-purs-json-manifest.md deleted file mode 100644 index f702c4e7ff..0000000000 --- a/CHANGELOG.d/feature_support-purs-json-manifest.md +++ /dev/null @@ -1,13 +0,0 @@ -- Add support for publishing via the `purs.json` manifest format - - This feature expands compiler support for publishing packages with different - manifest formats. Previously, packages had to have a `bower.json` manifest; - now, packages can choose to have a `purs.json` manifest instead. - - This feature provides only partial support for packages published to the - PureScript registry using the `purs.json` manifest format. Registry packages - are allowed to be hosted anywhere (not just GitHub), and do not need to be - Git repositories at all. However, `purs publish` and its primary consumer, - Pursuit, both require packages to be available on GitHub and for their version - to be a SemVer-compliant Git tag. Therefore, this feature only supports - registry packages that are compatible with these restrictions. diff --git a/CHANGELOG.d/fix_4218.md b/CHANGELOG.d/fix_4218.md deleted file mode 100644 index 83a66b54f6..0000000000 --- a/CHANGELOG.d/fix_4218.md +++ /dev/null @@ -1,5 +0,0 @@ -* Fix type operators in declaration param kinds - - This fixes an internal error triggered by using a type operator in the - kind of a type parameter of a data declaration, type synonym - declaration, or class declaration. diff --git a/CHANGELOG.d/fix_check-role-declarations-arity-during-typechecking.md b/CHANGELOG.d/fix_check-role-declarations-arity-during-typechecking.md deleted file mode 100644 index 2c85dcd867..0000000000 --- a/CHANGELOG.d/fix_check-role-declarations-arity-during-typechecking.md +++ /dev/null @@ -1 +0,0 @@ -* Check role declarations arity during type checking diff --git a/CHANGELOG.d/fix_ctor-spans.md b/CHANGELOG.d/fix_ctor-spans.md deleted file mode 100644 index 82b82d2e93..0000000000 --- a/CHANGELOG.d/fix_ctor-spans.md +++ /dev/null @@ -1 +0,0 @@ -* Add missing source spans to data constructors when generating docs diff --git a/CHANGELOG.d/fix_newtype_dollar.md b/CHANGELOG.d/fix_newtype_dollar.md deleted file mode 100644 index 4b00670ea3..0000000000 --- a/CHANGELOG.d/fix_newtype_dollar.md +++ /dev/null @@ -1 +0,0 @@ -* Optimize newtype applications with the ($) operator diff --git a/CHANGELOG.d/fix_scope-type-vars-when-type-checking-typed-values.md b/CHANGELOG.d/fix_scope-type-vars-when-type-checking-typed-values.md deleted file mode 100644 index 6fe9272cfb..0000000000 --- a/CHANGELOG.d/fix_scope-type-vars-when-type-checking-typed-values.md +++ /dev/null @@ -1,10 +0,0 @@ -* Scope type vars when type checking typed values - - When the compiler is checking an expression that is annotated with a - type against another expected type, and the annotation introduces a type - variable, the compiler needs to introduce that type variable to the - scope of any types used inside the expression. - - One noteworthy case of this pattern is member signatures inside - instances. This fix allows type variables introduced in member - signatures to be used in the member declaration itself. diff --git a/CHANGELOG.d/fix_unused_ident.md b/CHANGELOG.d/fix_unused_ident.md deleted file mode 100644 index b708866a0e..0000000000 --- a/CHANGELOG.d/fix_unused_ident.md +++ /dev/null @@ -1,7 +0,0 @@ -# Properly deserialize unused identifiers in the CoreFn - - This mostly affects downstream consumers of the CoreFn as discussed in - #4201. This makes it so CoreFn deserialization properly reads `$__unused` - into `UnusedIdent` instead of an `Ident`. This is particularly useful for - downstream consumers of the CoreFn such as alternative backends that don't - allow arguments to be omitted from functions. diff --git a/CHANGELOG.d/internal_build-package-set-in-ci.md b/CHANGELOG.d/internal_build-package-set-in-ci.md deleted file mode 100644 index daa99068bc..0000000000 --- a/CHANGELOG.d/internal_build-package-set-in-ci.md +++ /dev/null @@ -1,3 +0,0 @@ -* Build the entire latest package set in CI - - See [#4128](https://github.com/purescript/purescript/pull/4128). diff --git a/CHANGELOG.d/internal_bump-to-lts-18.md b/CHANGELOG.d/internal_bump-to-lts-18.md deleted file mode 100644 index f3b8201706..0000000000 --- a/CHANGELOG.d/internal_bump-to-lts-18.md +++ /dev/null @@ -1 +0,0 @@ -* Bump PureScript to building with GHC-8.10.7, as well as from LTS-17 to LTS-18. diff --git a/CHANGELOG.d/internal_fix-internal-error-hangs.md b/CHANGELOG.d/internal_fix-internal-error-hangs.md deleted file mode 100644 index 3f342678da..0000000000 --- a/CHANGELOG.d/internal_fix-internal-error-hangs.md +++ /dev/null @@ -1 +0,0 @@ -* Prevent hangs on internal errors diff --git a/CHANGELOG.d/internal_no-explicit-disable-nix.md b/CHANGELOG.d/internal_no-explicit-disable-nix.md deleted file mode 100644 index edd4e22794..0000000000 --- a/CHANGELOG.d/internal_no-explicit-disable-nix.md +++ /dev/null @@ -1,5 +0,0 @@ -* The explicit disabling of Nix has been removed from `stack.yaml`. - - For developers on NixOS, this means that you should be able to build - PureScript by running `stack build` instead of `stack build --nix`. - For other developers, this shouldn't affect you. diff --git a/CHANGELOG.d/internal_optimization_golden_tests.md b/CHANGELOG.d/internal_optimization_golden_tests.md deleted file mode 100644 index 2082e45246..0000000000 --- a/CHANGELOG.d/internal_optimization_golden_tests.md +++ /dev/null @@ -1,5 +0,0 @@ -* Create test machinery for optimizations - - This adds machinery for testing code generation for optimizations. - - Partially extracted from #3915 to add tests for #4205. diff --git a/CHANGELOG.md b/CHANGELOG.md index 4ec42e01d5..2a7926e0d2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,137 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.14.6 + +New features: + +* Make `Prim.TypeError`'s `Quote` work on all kinds, not just kind `Type`. (#4142 by @xgrommx) + +* Display role annotations in HTML docs (#4121 by @JordanMartinez) + + Previously, the HTML docs would not indicate which types could be safely + coerced and which could not: + + ```purescript + -- cannot be coerced + data Foo1 a = Foo1 a + type role Foo1 nominal + + -- can be coerced + data Foo2 a = Foo2 + type role Foo2 phantom + + -- can be coerced in some contexts + data Foo3 a = Foo3 a + type role Foo3 representational + ``` + + The HTML docs now display the role annotations either explicitly + declared by the developer or those inferred by the compiler. + + Since role annotations are an advanced feature and since most type + parameters' roles are the `representational` role, the `phantom` and + `nominal` role annotations are displayed in documentation whereas the + `representational` role is not, similar to "uninteresting" kind signatures. + + Lastly, FFI declarations like below... + + ```purescript + foreign import data Foo :: (Type -> Type) -> Type + type role Foo nominal + ``` + + ...will be rendered as though they are data declarations: + + ```purescript + data Foo :: (Type -> Type) -> Type + data Foo t0 + type role Foo nominal + ``` + + One can distinguish FFI declarations with roles separately from normal `data` + declarations that have roles based on the name of the type parameters. Since FFI declarations' type parameters are implicit and thus unnamed, the compiler will generate their name: `t0`, `t1`, ..., `tN` where `N` is a zero-based + index of the type parameter. + + Note: the resulting documentation will display the roles, but the roles + will not be selectable when selecting the type in case one wants to + copy-paste the type into source code. + +* Rewrite `Partial` optimization to be cleaner (#4208 by @rhendric) + + This feature shrinks the generated JS code for declarations that use + empty type classes, such as `Partial`, but is otherwise not expected to + have user-visible consequences. + +- Add support for publishing via the `purs.json` manifest format (#4233 by @thomashoneyman) + + This feature expands compiler support for publishing packages with different + manifest formats. Previously, packages had to have a `bower.json` manifest; + now, packages can choose to have a `purs.json` manifest instead. + + This feature provides only partial support for packages published to the + PureScript registry using the `purs.json` manifest format. Registry packages + are allowed to be hosted anywhere (not just GitHub), and do not need to be + Git repositories at all. However, `purs publish` and its primary consumer, + Pursuit, both require packages to be available on GitHub and for their version + to be a SemVer-compliant Git tag. Therefore, this feature only supports + registry packages that are compatible with these restrictions. + +Bugfixes: + +* Add missing source spans to data constructors when generating docs (#4202 by @PureFunctor) + +* Check role declarations arity during type checking (#4157 by @kl0tl) + +* Optimize newtype applications with the ($) operator (#4205 by @PureFunctor) + +* Properly deserialize unused identifiers in the CoreFn (#4221 by @sjpgarcia) + + This mostly affects downstream consumers of the CoreFn as discussed in + #4201. This makes it so CoreFn deserialization properly reads `$__unused` + into `UnusedIdent` instead of an `Ident`. This is particularly useful for + downstream consumers of the CoreFn such as alternative backends that don't + allow arguments to be omitted from functions. + +* Fix type operators in declaration param kinds (#4220 by @rhendric) + + This fixes an internal error triggered by using a type operator in the + kind of a type parameter of a data declaration, type synonym + declaration, or class declaration. + +* Scope type vars when type checking typed values (#4216 by @rhendric) + + When the compiler is checking an expression that is annotated with a + type against another expected type, and the annotation introduces a type + variable, the compiler needs to introduce that type variable to the + scope of any types used inside the expression. + + One noteworthy case of this pattern is member signatures inside + instances. This fix allows type variables introduced in member + signatures to be used in the member declaration itself. + +Internal: + +* Bump PureScript to building with GHC-8.10.7, as well as from LTS-17 to LTS-18. (#4199 by @cdepillabout) + +* Prevent hangs on internal errors (#4126 by @rhendric) + +* The explicit disabling of Nix has been removed from `stack.yaml`. (#4198 by @cdepillabout) + + For developers on NixOS, this means that you should be able to build + PureScript by running `stack build` instead of `stack build --nix`. + For other developers, this shouldn't affect you. + +* Build the entire latest package set in CI (#4217 by @rhendric) + + See [#4128](https://github.com/purescript/purescript/pull/4128). + +* Create test machinery for optimizations (#4205 by @PureFunctor) + + This adds machinery for testing code generation for optimizations. + + Partially extracted from #3915 to add tests for #4205. + ## 0.14.5 Bugfixes: diff --git a/LICENSE b/LICENSE index 87d2b2f910..76df930fdf 100644 --- a/LICENSE +++ b/LICENSE @@ -147,6 +147,7 @@ PureScript uses the following Haskell library packages. Their license files foll simple-sendfile sourcemap split + splitmix stm stm-chans streaming-commons @@ -172,6 +173,7 @@ PureScript uses the following Haskell library packages. Their license files foll unix unix-compat unix-time + unliftio unliftio-core unordered-containers utf8-string @@ -324,7 +326,7 @@ SHA LICENSE file: StateVar LICENSE file: Copyright (c) 2014-2015, Edward Kmett - Copyright (c) 2009-2018, Sven Panne + Copyright (c) 2009-2021, Sven Panne All rights reserved. Redistribution and use in source and binary forms, with or without @@ -1457,7 +1459,7 @@ cabal-doctest LICENSE file: call-stack LICENSE file: - Copyright (c) 2016 Simon Hengel + Copyright (c) 2016-2021 Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -2217,37 +2219,34 @@ distributive LICENSE file: dlist LICENSE file: - Copyright (c) 2006-2009 Don Stewart, 2013-2019 Sean Leather + Copyright © 2006-2009 Don Stewart, 2013-2020 Sean Leather, contributors All rights reserved. - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are - met: + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. + 1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. + 2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. - * Neither the name of Don Stewart nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. + 3. Neither the name of the copyright holders nor the names of other contributors + may be used to endorse or promote products derived from this software without + specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR + TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. easy-file LICENSE file: @@ -4498,6 +4497,39 @@ split LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +splitmix LICENSE file: + + Copyright (c) 2017, Oleg Grenrus + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + stm LICENSE file: The Glasgow Haskell Compiler License @@ -5308,6 +5340,29 @@ unix-time LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +unliftio LICENSE file: + + Copyright (c) 2017 FP Complete + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be included + in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY + CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, + TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE + SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + unliftio-core LICENSE file: Copyright (c) 2017 FP Complete diff --git a/lib/purescript-cst/README.md b/lib/purescript-cst/README.md index 521d41ed87..6b19919444 100644 --- a/lib/purescript-cst/README.md +++ b/lib/purescript-cst/README.md @@ -12,6 +12,7 @@ We provide a table to make it a bit easier to map between versions of `purescrip | 0.14.3 | 0.3.0.0 | | 0.14.4 | 0.4.0.0 | | 0.14.5 | 0.4.0.0 | +| 0.14.6 | 0.4.0.0 | Before v0.14.2, there was a third package, `purescript-ast`. In v0.14.2, `purescript-ast` was merged into `purescript-cst`. diff --git a/npm-package/package.json b/npm-package/package.json index ed3d001afe..d84775cf51 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.14.5", + "version": "0.14.6", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.14.5", + "postinstall": "install-purescript --purs-ver=0.14.6", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index de591de44f..f17f11848e 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.14.5 +version: 0.14.6 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 7917cb44678f6aeec365280de34e4794f7fb2211 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sat, 26 Feb 2022 14:17:33 -0600 Subject: [PATCH 1413/1580] Make v0.14.7 (#4245) * Bump purescript-cst to 0.5.0.0 * Bump purescript to 0.14.7 * Update changelog --- CHANGELOG.md | 6 +++++- lib/purescript-cst/README.md | 1 + lib/purescript-cst/purescript-cst.cabal | 2 +- npm-package/package.json | 4 ++-- purescript.cabal | 4 ++-- 5 files changed, 11 insertions(+), 6 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2a7926e0d2..b6d59ae79c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,7 +2,7 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). -## 0.14.6 +## 0.14.7 New features: @@ -133,6 +133,10 @@ Internal: Partially extracted from #3915 to add tests for #4205. +## 0.14.6 + +Do not use this release. `purescript-cst`'s version wasn't bumped when this release was made. So, tools like `trypurescript` cannot depend on it. See [0.14.7](#0147) for the same thing. + ## 0.14.5 Bugfixes: diff --git a/lib/purescript-cst/README.md b/lib/purescript-cst/README.md index 6b19919444..035e29c635 100644 --- a/lib/purescript-cst/README.md +++ b/lib/purescript-cst/README.md @@ -13,6 +13,7 @@ We provide a table to make it a bit easier to map between versions of `purescrip | 0.14.4 | 0.4.0.0 | | 0.14.5 | 0.4.0.0 | | 0.14.6 | 0.4.0.0 | +| 0.14.7 | 0.5.0.0 | Before v0.14.2, there was a third package, `purescript-ast`. In v0.14.2, `purescript-ast` was merged into `purescript-cst`. diff --git a/lib/purescript-cst/purescript-cst.cabal b/lib/purescript-cst/purescript-cst.cabal index c57419a8b6..a72b9675dd 100644 --- a/lib/purescript-cst/purescript-cst.cabal +++ b/lib/purescript-cst/purescript-cst.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: purescript-cst -version: 0.4.0.0 +version: 0.5.0.0 synopsis: PureScript Programming Language Concrete Syntax Tree description: The parser for the PureScript programming language. category: Language diff --git a/npm-package/package.json b/npm-package/package.json index d84775cf51..3f60b8beaa 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.14.6", + "version": "0.14.7", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.14.6", + "postinstall": "install-purescript --purs-ver=0.14.7", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index f17f11848e..0dd7b8075f 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.14.6 +version: 0.14.7 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language @@ -159,7 +159,7 @@ common defaults pattern-arrows >=0.0.2 && <0.1, process >=1.6.13.2 && <1.7, protolude >=0.3.0 && <0.4, - purescript-cst ==0.4.0.0, + purescript-cst ==0.5.0.0, regex-tdfa >=1.3.1.1 && <1.4, safe >=0.3.19 && <0.4, scientific >=0.3.7.0 && <0.4, From ff68b93b912d23f22db40d9116ce9c84d6b793e6 Mon Sep 17 00:00:00 2001 From: sigma-andex <77549848+sigma-andex@users.noreply.github.com> Date: Sun, 27 Feb 2022 00:04:04 +0000 Subject: [PATCH 1414/1580] Support es modules (#4232) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Add ES imports/exports to CoreImp AST * Print ES imports/exports * Codegen ES imports for PureScript modules * Codegen ES imports for foreign modules * Codegen ES exports * Extract both CJS and ES exports from foreign modules * Remove the redundant "use strict;" pragma from modules header ES modules are already parsed in strict mode. * Don’t emit empty statements for empty exports lists * Bundle ES modules * Load ES modules with `esm` in the Node.js REPL and tests * Escape primes in modules accessors * Forbid unescaped primes in foreign modules exports * Run tests against patched dependencies * Rewrite ES modules in the browser REPL client * Revert "Load ES modules with `esm` in the Node.js REPL and tests" This reverts commit 7f0c07e98b616e4a931964d210c7059a65b1a6fd. * Allow Node.js to load .js files in the output directory as ES modules Node.js loads JavaScript files with a .js extension as CommonJS modules unless they're within a directory with a `"type": "module"` package.json, in which case it loads them as ES modules. * Import CommonJS foreign modules through an ES module wrapper * Don't let tests nor the REPL compile into a node_modules directory Node.js ignores the package.json file of the output directory otherwise and loads .js files as CommonJS modules. * Bundle re-exports * Load bundles as CommonJS modules in tests * Update Node.js version on CI * Disallow CommonJS exports named `default` Node.js allows ES modules to import CommonJS modules by providing the module.exports object as their default export and named exports for statically discoverable properties of the module.exports object. This has an unpleasant consequence for foreign imports: CommonJS exports named `default` are only available as the default property of their default export so a `default :: String` identifier imported from a CommonJS foreign module would actually have type `{ default :: String }`! * Disallow CommonJS exports and imports in ES foreign modules The require function and the exports object are not available in ES modules on Node.js. * Deprecate CommonJS foreign modules * Convert CommonJS foreign modules in tests to ES modules * Don't optimize away dependencies of named ES exports of declarations * fixup! Import CommonJS foreign modules through an ES module wrapper * fixup! Don't optimize away dependencies of named ES exports of declarations * Revert "Disallow CommonJS exports named `default`" This reverts commit 4976eee1599300511236b9a491b09ecb332cf852. * Add tests for foreign CommonJS exports named default * Extend support to Node.js v12.0.0 with --experimental-modules * Filter out Node.js experimental ES modules loader warning * Update bundler error messages * Fix HLint warnings * Add purity annotations to function applications and constructor instantations * Surround purity annotations in parens * Mention es modules in version * Add purity annotations to top-level applications only. * Follow top-level literals as well * Annotate all top-level-reachable applications. * Traverse under lhs functions and operators * Use # for annotation. * Add comments, remove potentially aggressive cases. * Simplify to uniform top-level IIFEs. * Fix tests * Add myself to contributors * Fix experimental-modules flag required version (#11) Improve error message * Add i-am-the-slime to contributors * Fix pr comments (#12) * Rename node.js to Node.js * Remove unused Unsafe.hs * Add resolutions to fix dep conflicts * Add changelog.d entry for es modules (#14) * Update prefix to match script's expected one * Drop unneeded whitespace * Update src/Language/PureScript/Errors.hs Co-authored-by: Nathan Faubion * Fix broken tests after spelling correction commit * Remove temporary entries from changelog * Refactor Pure -> Comment in CoreImp * Refactor CoreImp modules * Be less liberal with IIFEs Co-authored-by: Cyril Sobierajewicz Co-authored-by: Mark Eibes Co-authored-by: Nathan Faubion Co-authored-by: Thomas Honeyman Co-authored-by: Jordan Martinez Co-authored-by: Nathan Faubion Co-authored-by: Ryan Hendrickson --- .github/workflows/ci.yml | 2 +- CHANGELOG.d/breaking_switch-to-es-modules.md | 26 ++ CONTRIBUTORS.md | 2 + app/Command/REPL.hs | 18 +- app/static/index.js | 15 +- purescript.cabal | 1 + src/Language/PureScript/Bundle.hs | 373 +++++++++++++----- src/Language/PureScript/CodeGen/JS.hs | 140 ++++--- src/Language/PureScript/CodeGen/JS/Printer.hs | 100 +++-- src/Language/PureScript/CoreImp/AST.hs | 19 +- src/Language/PureScript/CoreImp/Module.hs | 19 + .../PureScript/CoreImp/Optimizer/TCO.hs | 2 +- src/Language/PureScript/Errors.hs | 21 +- src/Language/PureScript/Interactive/IO.hs | 55 ++- src/Language/PureScript/Interactive/Module.hs | 2 +- src/Language/PureScript/Make.hs | 2 + src/Language/PureScript/Make/Actions.hs | 103 ++++- tests/TestBundle.hs | 15 +- tests/TestCompiler.hs | 13 +- tests/TestMake.hs | 4 +- tests/TestPsci/TestEnv.hs | 12 +- tests/TestUtils.hs | 16 +- tests/purs/bundle/3551/ModuleWithDeadCode.js | 6 +- tests/purs/bundle/3727.js | 6 +- tests/purs/bundle/ObjectShorthand.js | 12 +- .../DeprecatedFFIPrime.js | 0 .../DeprecatedFFIPrime.out | 32 +- tests/purs/failing/DeprecatedFFIPrime.purs | 10 + .../purs/failing/MissingFFIImplementations.js | 2 +- .../failing/UnsupportedFFICommonJSExports1.js | 2 + .../UnsupportedFFICommonJSExports1.out | 12 + .../UnsupportedFFICommonJSExports1.purs | 5 + .../failing/UnsupportedFFICommonJSExports2.js | 4 + .../UnsupportedFFICommonJSExports2.out | 13 + .../UnsupportedFFICommonJSExports2.purs | 5 + .../failing/UnsupportedFFICommonJSImports1.js | 4 + .../UnsupportedFFICommonJSImports1.out | 12 + .../UnsupportedFFICommonJSImports1.purs | 5 + .../failing/UnsupportedFFICommonJSImports2.js | 5 + .../UnsupportedFFICommonJSImports2.out | 12 + .../UnsupportedFFICommonJSImports2.purs | 5 + tests/purs/optimize/2866.out.js | 10 +- tests/purs/passing/EffFn.js | 2 +- tests/purs/passing/FFIDefaultCJSExport.js | 1 + tests/purs/passing/FFIDefaultCJSExport.purs | 7 + tests/purs/passing/FFIDefaultESExport.js | 3 + tests/purs/passing/FFIDefaultESExport.purs | 7 + tests/purs/passing/FunWithFunDeps.js | 10 +- tests/purs/passing/PolyLabels.js | 6 +- tests/purs/passing/ReExportsExported.js | 4 +- tests/purs/passing/RowUnion.js | 4 +- .../DeprecatedConstraintInForeignImport.js | 2 +- .../warning/DeprecatedFFICommonJSModule.js | 4 + .../warning/DeprecatedFFICommonJSModule.out | 13 + .../warning/DeprecatedFFICommonJSModule.purs | 5 + tests/purs/warning/DeprecatedFFIPrime.purs | 10 - tests/purs/warning/UnnecessaryFFIModule.js | 2 +- .../purs/warning/UnusedFFIImplementations.js | 4 +- tests/support/bower.json | 51 ++- .../pscide/src/RebuildSpecWithForeign.js | 2 +- 60 files changed, 924 insertions(+), 335 deletions(-) create mode 100644 CHANGELOG.d/breaking_switch-to-es-modules.md create mode 100644 src/Language/PureScript/CoreImp/Module.hs rename tests/purs/{warning => failing}/DeprecatedFFIPrime.js (100%) rename tests/purs/{warning => failing}/DeprecatedFFIPrime.out (51%) create mode 100644 tests/purs/failing/DeprecatedFFIPrime.purs create mode 100644 tests/purs/failing/UnsupportedFFICommonJSExports1.js create mode 100644 tests/purs/failing/UnsupportedFFICommonJSExports1.out create mode 100644 tests/purs/failing/UnsupportedFFICommonJSExports1.purs create mode 100644 tests/purs/failing/UnsupportedFFICommonJSExports2.js create mode 100644 tests/purs/failing/UnsupportedFFICommonJSExports2.out create mode 100644 tests/purs/failing/UnsupportedFFICommonJSExports2.purs create mode 100644 tests/purs/failing/UnsupportedFFICommonJSImports1.js create mode 100644 tests/purs/failing/UnsupportedFFICommonJSImports1.out create mode 100644 tests/purs/failing/UnsupportedFFICommonJSImports1.purs create mode 100644 tests/purs/failing/UnsupportedFFICommonJSImports2.js create mode 100644 tests/purs/failing/UnsupportedFFICommonJSImports2.out create mode 100644 tests/purs/failing/UnsupportedFFICommonJSImports2.purs create mode 100644 tests/purs/passing/FFIDefaultCJSExport.js create mode 100644 tests/purs/passing/FFIDefaultCJSExport.purs create mode 100644 tests/purs/passing/FFIDefaultESExport.js create mode 100644 tests/purs/passing/FFIDefaultESExport.purs create mode 100644 tests/purs/warning/DeprecatedFFICommonJSModule.js create mode 100644 tests/purs/warning/DeprecatedFFICommonJSModule.out create mode 100644 tests/purs/warning/DeprecatedFFICommonJSModule.purs delete mode 100644 tests/purs/warning/DeprecatedFFIPrime.purs diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index c02b1202e7..ed07b2caf4 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -30,7 +30,7 @@ jobs: - uses: "actions/setup-node@v1" with: - node-version: "10" + node-version: "12" - id: "haskell" uses: "haskell/actions/setup@v1" diff --git a/CHANGELOG.d/breaking_switch-to-es-modules.md b/CHANGELOG.d/breaking_switch-to-es-modules.md new file mode 100644 index 0000000000..f65e8d9221 --- /dev/null +++ b/CHANGELOG.d/breaking_switch-to-es-modules.md @@ -0,0 +1,26 @@ +* Switch from Common JS to ES modules + + Previously, Purescript used Common JS for FFI declarations. + + Before, FFI was declared like this... + + ```javascript + const mymodule = require('mymodule') + + exports.myvar = mymodule.myvar + ``` + + ...and will be changed to this... + + ```javascript + import * as M from 'mymodule'; + export const myvar = M.myvar + ``` + ...or using the short version... + + ```javascript + export { myvar } from 'mymodule'; + ``` + +* FFI is annotated with `/* #__PURE__ */` so that bundlers can perform DCE +* The current LTS Node.js version `12` is now the required minimum version diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 79484f6ce2..37203a317a 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -152,6 +152,8 @@ If you would prefer to use different terms, please use the section below instead | [@xgrommx](https://github.com/xgrommx) | Denis Stoyanov | [MIT license](http://opensource.org/licenses/MIT) | | [@MonoidMusician](https://github.com/MonoidMusician) | Verity Scheel | [MIT license](http://opensource.org/licenses/MIT) | | [@thomashoneyman](https://github.com/thomashoneyman) | Thomas Honeyman | [MIT license](http://opensource.org/licenses/MIT) | +| [@sigma-andex](https://github.com/sigma-andex) | Jan Schulte | [MIT license](http://opensource.org/licenses/MIT) | +| [@i-am-the-slime](https://github.com/i-am-the-slime) | Mark Eibes | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 01429b093e..27be4bc9e9 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -44,8 +44,7 @@ import System.IO.UTF8 (readUTF8File) import System.Exit import System.Directory (doesFileExist, getCurrentDirectory) import System.FilePath (()) -import System.FilePath.Glob (glob) -import System.Process (readProcessWithExitCode) +import qualified System.FilePath.Glob as Glob import qualified Data.ByteString.Lazy.UTF8 as U -- | Command line options @@ -108,7 +107,7 @@ pasteMode = -- | Make a JavaScript bundle for the browser. bundle :: IO (Either Bundle.ErrorMessage String) bundle = runExceptT $ do - inputFiles <- liftIO (glob (".psci_modules" "node_modules" "*" "*.js")) + inputFiles <- liftIO $ concat <$> Glob.globDir [Glob.compile "*/*.js", Glob.compile "*/foreign.cjs"] modulesDir input <- for inputFiles $ \filename -> do js <- liftIO (readUTF8File filename) mid <- Bundle.guessModuleIdentifier filename @@ -280,13 +279,12 @@ nodeBackend nodePath nodeArgs = Backend setup eval reload shutdown eval :: () -> String -> IO () eval _ _ = do - writeFile indexFile "require('$PSCI')['$main']();" - process <- maybe findNodeProcess (pure . pure) nodePath - result <- traverse (\node -> readProcessWithExitCode node (nodeArgs ++ [indexFile]) "") process + writeFile indexFile "import('./$PSCI/index.js').then(({ $main }) => $main());" + result <- readNodeProcessWithExitCode nodePath (nodeArgs ++ [indexFile]) "" case result of - Just (ExitSuccess, out, _) -> putStrLn out - Just (ExitFailure _, _, err) -> putStrLn err - Nothing -> putStrLn "Could not find node.js. Do you have node.js installed and available in your PATH?" + Right (ExitSuccess, out, _) -> putStrLn out + Right (ExitFailure _, _, err) -> putStrLn err + Left err -> putStrLn err reload :: () -> IO () reload _ = return () @@ -303,7 +301,7 @@ command = loop <$> options where loop :: PSCiOptions -> IO () loop PSCiOptions{..} = do - inputFiles <- concat <$> traverse glob psciInputGlob + inputFiles <- concat <$> traverse Glob.glob psciInputGlob e <- runExceptT $ do modules <- ExceptT (loadAllModules inputFiles) when (null modules) . liftIO $ do diff --git a/app/static/index.js b/app/static/index.js index 1d0714fd71..f496540c4c 100644 --- a/app/static/index.js +++ b/app/static/index.js @@ -16,13 +16,24 @@ var evaluate = function evaluate(js) { // which will be returned to PSCi. buffer.push(s); }; - // Replace any require(...) statements with lookups on the PSCI object. + // Replace any require and import statements with lookups on the PSCI object + // and export statements with assignments to module.exports. var replaced = js.replace(/require\("[^"]*"\)/g, function(s) { return "PSCI['" + s.split('/')[1] + "']"; + }).replace(/import \* as ([^\s]+) from "([^"]*)"/g, function (_, as, from) { + return "var " + as + " = PSCI['" + from.split('/')[1] + "']"; + }).replace(/export \{([^}]+)\} from "\.\/foreign\.js";?/g, function (_, exports) { + return exports.replace(/^\s*([^,\s]+),?\s*$/gm, function (_, exported) { + return "module.exports." + exported + " = $foreign." + exported + ";"; + }); + }).replace(/export \{([^}]+)\};?/g, function (_, exports) { + return exports.replace(/^\s*([^,\s]+)(?: as ([^\s]+))?,?\s*$/gm, function (_, exported, as) { + return "module.exports." + (as || exported) + " = " + exported + ";"; + }); }); // Wrap the module and evaluate it. var wrapped = - [ 'var module = {};' + [ 'var module = { exports: {} };' , '(function(module) {' , replaced , '})(module);' diff --git a/purescript.cabal b/purescript.cabal index 0dd7b8075f..1a0da0f622 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -207,6 +207,7 @@ library Language.PureScript.CoreFn.Traversals Language.PureScript.CoreImp Language.PureScript.CoreImp.AST + Language.PureScript.CoreImp.Module Language.PureScript.CoreImp.Optimizer Language.PureScript.CoreImp.Optimizer.Blocks Language.PureScript.CoreImp.Optimizer.Common diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 0ab9e79589..f45bc3e18a 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -13,7 +13,10 @@ module Language.PureScript.Bundle , ModuleType(..) , ErrorMessage(..) , printErrorMessage + , ForeignModuleExports(..) , getExportedIdentifiers + , ForeignModuleImports(..) + , getImportedModules , Module ) where @@ -31,16 +34,19 @@ import Data.Foldable (fold) import Data.Generics (GenericM, everything, everythingWithContext, everywhere, gmapMo, mkMp, mkQ, mkT) import Data.Graph import Data.List (stripPrefix, (\\)) -import Data.Maybe (catMaybes, fromMaybe, mapMaybe) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList) import Data.Version (showVersion) import qualified Data.Aeson as A import qualified Data.Map as M import qualified Data.Set as S -import qualified Data.Text.Lazy as T +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT import Language.JavaScript.Parser import Language.JavaScript.Parser.AST import Language.JavaScript.Process.Minify +import Language.PureScript.Names (ModuleName(..)) +import Language.PureScript.CodeGen.JS.Common (moduleNameToJs) import qualified Paths_purescript as Paths @@ -54,6 +60,7 @@ data ErrorMessage = UnsupportedModulePath String | InvalidTopLevel | UnableToParseModule String + | UnsupportedImport | UnsupportedExport | ErrorInModule ModuleIdentifier ErrorMessage | MissingEntryPoint String @@ -89,6 +96,7 @@ guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory f where guessModuleType "index.js" = pure Regular guessModuleType "foreign.js" = pure Foreign + guessModuleType "foreign.cjs" = pure Foreign guessModuleType name = throwError $ UnsupportedModulePath name data Visibility @@ -111,7 +119,7 @@ data ExportType -- | There are four types of module element we are interested in: -- --- 1) Require statements +-- 1) Import declarations and require statements -- 2) Member declarations -- 3) Export lists -- 4) Everything else @@ -119,22 +127,22 @@ data ExportType -- Each is labelled with the original AST node which generated it, so that we can dump it back -- into the output during codegen. data ModuleElement - = Require JSStatement String (Either String ModuleIdentifier) + = Import JSModuleItem String (Either String ModuleIdentifier) | Member JSStatement Visibility String JSExpression [Key] | ExportsList [(ExportType, String, JSExpression, [Key])] | Other JSStatement - | Skip JSStatement + | Skip JSModuleItem deriving (Show) instance A.ToJSON ModuleElement where toJSON = \case - (Require _ name (Right target)) -> - A.object [ "type" .= A.String "Require" + (Import _ name (Right target)) -> + A.object [ "type" .= A.String "Import" , "name" .= name , "target" .= target ] - (Require _ name (Left targetPath)) -> - A.object [ "type" .= A.String "Require" + (Import _ name (Left targetPath)) -> + A.object [ "type" .= A.String "Import" , "name" .= name , "targetPath" .= targetPath ] @@ -150,11 +158,11 @@ instance A.ToJSON ModuleElement where ] (Other stmt) -> A.object [ "type" .= A.String "Other" - , "js" .= getFragment stmt + , "js" .= getFragment (JSAstStatement stmt JSNoAnnot) ] - (Skip stmt) -> + (Skip item) -> A.object [ "type" .= A.String "Skip" - , "js" .= getFragment stmt + , "js" .= getFragment (JSAstModule [item] JSNoAnnot) ] where @@ -177,9 +185,9 @@ instance A.ToJSON ModuleElement where , "dependsOn" .= map keyToJSON dependsOn ] - getFragment = ellipsize . renderToText . minifyJS . flip JSAstStatement JSNoAnnot + getFragment = ellipsize . renderToText . minifyJS where - ellipsize text = if T.compareLength text 20 == GT then T.take 19 text `T.snoc` ellipsis else text + ellipsize text = if LT.compareLength text 20 == GT then LT.take 19 text `LT.snoc` ellipsis else text ellipsis = '\x2026' -- | A module is just a list of elements of the types listed above. @@ -195,10 +203,11 @@ instance A.ToJSON Module where -- | Prepare an error message for consumption by humans. printErrorMessage :: ErrorMessage -> [String] printErrorMessage (UnsupportedModulePath s) = - [ "A CommonJS module has an unsupported name (" ++ show s ++ ")." + [ "An ES or CommonJS module has an unsupported name (" ++ show s ++ ")." , "The following file names are supported:" , " 1) index.js (PureScript native modules)" - , " 2) foreign.js (PureScript foreign modules)" + , " 2) foreign.js (PureScript ES foreign modules)" + , " 3) foreign.cjs (PureScript CommonJS foreign modules)" ] printErrorMessage InvalidTopLevel = [ "Expected a list of source elements at the top level." ] @@ -206,10 +215,24 @@ printErrorMessage (UnableToParseModule err) = [ "The module could not be parsed:" , err ] +printErrorMessage UnsupportedImport = + [ "An import was unsupported." + , "Modules can be imported with ES namespace imports declarations:" + , " import * as module from \"Module.Name\"" + , "Alternatively, they can be also be imported with the CommonJS require function:" + , " var module = require(\"Module.Name\")" + ] printErrorMessage UnsupportedExport = - [ "An export was unsupported. Exports can be defined in one of two ways: " - , " 1) exports.name = ..." - , " 2) exports = { ... }" + [ "An export was unsupported." + , "Declarations can be exported as ES named exports:" + , " export var decl" + , "Existing identifiers can be exported as well:" + , " export { name }" + , "They can also be renamed on export:" + , " export { name as alias }" + , "Alternatively, CommonJS exports can be defined in one of two ways:" + , " 1) exports.name = value" + , " 2) exports = { name: value }" ] printErrorMessage (ErrorInModule mid e) = ("Error in module " ++ displayIdentifier mid ++ ":") @@ -219,13 +242,13 @@ printErrorMessage (ErrorInModule mid e) = displayIdentifier (ModuleIdentifier name ty) = name ++ " (" ++ showModuleType ty ++ ")" printErrorMessage (MissingEntryPoint mName) = - [ "Couldn't find a CommonJS module for the specified entry point: " ++ mName + [ "Could not find an ES module or CommonJS module for the specified entry point: " ++ mName ] printErrorMessage (MissingMainModule mName) = - [ "Couldn't find a CommonJS module for the specified main module: " ++ mName + [ "Could not find an ES module or CommonJS module for the specified main module: " ++ mName ] --- | Calculate the ModuleIdentifier which a require(...) statement imports. +-- | Calculate the ModuleIdentifier imported by an import declaration or a require(...) statement. checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier checkImportPath "./foreign.js" m _ = Right (ModuleIdentifier (moduleName m) Foreign) @@ -247,10 +270,14 @@ stripSuffix suffix xs = -- -- 1) module.name or member["name"] -- --- where module was imported using +-- where module was imported using require -- -- var module = require("Module.Name"); -- +-- or an import declaration +-- +-- import * as module from "Module.Name"; +-- -- 2) name -- -- where name is the name of a member defined in the current module. @@ -262,7 +289,7 @@ withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) imports = mapMaybe toImport es where toImport :: ModuleElement -> Maybe (String, ModuleIdentifier) - toImport (Require _ nm (Right mid)) = Just (nm, mid) + toImport (Import _ nm (Right mid)) = Just (nm, mid) toImport _ = Nothing -- | Collects all member names in scope, so that we can identify dependencies of the second type. @@ -369,52 +396,159 @@ trailingCommaList :: JSCommaTrailingList a -> [a] trailingCommaList (JSCTLComma l _) = commaList l trailingCommaList (JSCTLNone l) = commaList l +identName :: JSIdent -> Maybe String +identName (JSIdentName _ ident) = Just ident +identName _ = Nothing + +exportStatementIdentifiers :: JSStatement -> [String] +exportStatementIdentifiers (JSVariable _ jsExpressions _) = + varNames jsExpressions +exportStatementIdentifiers (JSConstant _ jsExpressions _) = + varNames jsExpressions +exportStatementIdentifiers (JSLet _ jsExpressions _) = + varNames jsExpressions +exportStatementIdentifiers (JSClass _ jsIdent _ _ _ _ _) = + maybeToList . identName $ jsIdent +exportStatementIdentifiers (JSFunction _ jsIdent _ _ _ _ _) = + maybeToList . identName $ jsIdent +exportStatementIdentifiers (JSGenerator _ _ jsIdent _ _ _ _ _) = + maybeToList . identName $ jsIdent +exportStatementIdentifiers _ = [] + +varNames :: JSCommaList JSExpression -> [String] +varNames = mapMaybe varName . commaList + where + varName (JSVarInitExpression (JSIdentifier _ ident) _) = Just ident + varName _ = Nothing + +sp :: JSAnnot +sp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ] + +stringLiteral :: String -> JSExpression +stringLiteral s = JSStringLiteral JSNoAnnot $ "\"" ++ s ++ "\"" + -- | Attempt to create a Module from a JavaScript AST. -- -- Each type of module element is matched using pattern guards, and everything else is bundled into the -- Other constructor. toModule :: forall m. (MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> Maybe FilePath -> JSAST -> m Module toModule mids mid filename top - | JSAstProgram smts _ <- top = Module mid filename <$> traverse toModuleElement smts + | JSAstModule jsModuleItems _ <- top + , JSModuleImportDeclaration _ jsImportDeclaration : _ <- jsModuleItems + , JSImportDeclaration JSImportClauseDefault{} jsFromClause _ <- jsImportDeclaration + , JSFromClause _ _ importPath <- jsFromClause + , "./foreign.cjs" <- strValue importPath + = pure $ Module mid filename [] + | JSAstModule jsModuleItems _ <- top = Module mid filename . mconcat <$> traverse toModuleElements jsModuleItems | otherwise = err InvalidTopLevel where err :: ErrorMessage -> m a err = throwError . ErrorInModule mid - toModuleElement :: JSStatement -> m ModuleElement - toModuleElement stmt - | Just (importName, importPath) <- matchRequire mids mid stmt - = pure (Require stmt importName importPath) - toModuleElement stmt - | Just (visibility, name, decl) <- matchMember stmt - = pure (Member stmt visibility name decl []) - toModuleElement stmt - | Just props <- matchExportsAssignment stmt - = ExportsList <$> traverse toExport (trailingCommaList props) + toModuleElements :: JSModuleItem -> m [ModuleElement] + toModuleElements item@(JSModuleImportDeclaration _ jsImportDeclaration) + | JSImportDeclaration jsImportClause jsFromClause _ <- jsImportDeclaration + , JSImportClauseNameSpace jsImportNameSpace <- jsImportClause + , JSImportNameSpace _ _ jsIdent <- jsImportNameSpace + , JSFromClause _ _ importPath <- jsFromClause + , importPath' <- checkImportPath (strValue importPath) mid mids + = maybe (err UnsupportedImport) pure (identName jsIdent) >>= \name -> + pure [Import item name importPath'] + toModuleElements (JSModuleImportDeclaration _ _) + = err UnsupportedImport + + toModuleElements (JSModuleExportDeclaration _ jsExportDeclaration) + | JSExportFrom jsExportClause jsFromClause _ <- jsExportDeclaration + , JSFromClause _ _ from <- jsFromClause + , JSExportClause _ jsExportSpecifiers _ <- jsExportClause + = pure . ExportsList <$> exportSpecifiersList (Just (strValue from)) jsExportSpecifiers + toModuleElements (JSModuleExportDeclaration _ jsExportDeclaration) + | JSExportLocals jsExportClause _ <- jsExportDeclaration + , JSExportClause _ jsExportSpecifiers _ <- jsExportClause + = pure . ExportsList <$> exportSpecifiersList Nothing jsExportSpecifiers + toModuleElements (JSModuleExportDeclaration _ jsExportDeclaration) + | JSExport jsStatement _ <- jsExportDeclaration + , Just (name, decl) <- matchInternalMember jsStatement + = pure [ Member jsStatement Internal name decl [] + , ExportsList [toRegularExport' name] + ] + toModuleElements (JSModuleExportDeclaration _ JSExport{}) + = err UnsupportedExport + + toModuleElements item@(JSModuleStatementListItem jsStatement) + | Just (importName, importPath) <- matchRequire jsStatement + = pure [Import item importName $ checkImportPath importPath mid mids] + toModuleElements (JSModuleStatementListItem jsStatement) + | Just (visibility, name, decl) <- matchMember jsStatement + = pure [Member jsStatement visibility name decl []] + toModuleElements (JSModuleStatementListItem jsStatement) + | Just props <- matchExportsAssignment jsStatement + = pure . ExportsList <$> traverse objectPropertyToExport (trailingCommaList props) where - toExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key]) - toExport (JSPropertyNameandValue name _ [val]) = - (,,val,[]) <$> exportType val + objectPropertyToExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key]) + objectPropertyToExport (JSPropertyNameandValue name _ [val]) = + (,,val,[]) <$> expressionExportType val <*> extractLabel' name - toExport _ = err UnsupportedExport + objectPropertyToExport _ = err UnsupportedExport - exportType :: JSExpression -> m ExportType - exportType (JSMemberDot f _ _) + expressionExportType :: JSExpression -> m ExportType + expressionExportType (JSMemberDot f _ _) | JSIdentifier _ "$foreign" <- f = pure ForeignReexport | JSIdentifier _ ident <- f = pure (RegularExport ident) - exportType (JSMemberSquare f _ _ _) + expressionExportType (JSMemberSquare f _ _ _) | JSIdentifier _ "$foreign" <- f = pure ForeignReexport | JSIdentifier _ ident <- f = pure (RegularExport ident) - exportType (JSIdentifier _ s) = pure (RegularExport s) - exportType _ = err UnsupportedExport + expressionExportType (JSIdentifier _ s) = pure (RegularExport s) + expressionExportType _ = err UnsupportedExport extractLabel' = maybe (err UnsupportedExport) pure . extractLabel - toModuleElement other = pure (Other other) + toModuleElements (JSModuleStatementListItem other) = pure [Other other] + + exportSpecifiersList from = + fmap catMaybes . traverse (exportSpecifier from) . commaList + + exportSpecifier from (JSExportSpecifier jsIdent) + = traverse (toExport' from) $ identName jsIdent + exportSpecifier from (JSExportSpecifierAs jsIdent _ jsIdentAs) + = sequence $ toExport from <$> identName jsIdent <*> identName jsIdentAs + + toExport :: Maybe String -> String -> String -> m (ExportType, String, JSExpression, [Key]) + toExport (Just from) name as + | from == "./foreign.js" = + pure . (ForeignReexport, as,, []) $ + JSMemberSquare (JSIdentifier sp "$foreign") JSNoAnnot + (stringLiteral name) JSNoAnnot + | Just from' <- stripSuffix "/index.js" =<< stripPrefix "../" from = + pure . (RegularExport name, as,, []) $ + JSMemberSquare (JSIdentifier sp (T.unpack . moduleNameToJs . ModuleName $ T.pack from')) JSNoAnnot + (stringLiteral name) JSNoAnnot + | otherwise = err UnsupportedExport + toExport Nothing name as = + pure $ toRegularExport name as + + toExport' from name = toExport from name name + + toRegularExport name as = + (RegularExport name, as, JSIdentifier sp name, []) + + toRegularExport' name = toRegularExport name name + +data ForeignModuleExports = + ForeignModuleExports + { cjsExports :: [String] + , esExports :: [String] + } deriving (Show) + +instance Semigroup ForeignModuleExports where + (ForeignModuleExports cjsExports esExports) <> (ForeignModuleExports cjsExports' esExports') = + ForeignModuleExports (cjsExports <> cjsExports') (esExports <> esExports') +instance Monoid ForeignModuleExports where + mempty = ForeignModuleExports [] [] -- Get a list of all the exported identifiers from a foreign module. -- @@ -423,21 +557,25 @@ toModule mids mid filename top getExportedIdentifiers :: forall m. (MonadError ErrorMessage m) => String -> JSAST - -> m [String] + -> m ForeignModuleExports getExportedIdentifiers mname top - | JSAstProgram stmts _ <- top = concat <$> traverse go stmts + | JSAstModule jsModuleItems _ <- top = fold <$> traverse go jsModuleItems | otherwise = err InvalidTopLevel where err :: ErrorMessage -> m a err = throwError . ErrorInModule (ModuleIdentifier mname Foreign) - go stmt - | Just props <- matchExportsAssignment stmt - = traverse toIdent (trailingCommaList props) - | Just (Public, name, _) <- matchMember stmt - = pure [name] + go (JSModuleStatementListItem jsStatement) + | Just props <- matchExportsAssignment jsStatement + = do cjsExports <- traverse toIdent (trailingCommaList props) + pure ForeignModuleExports{ cjsExports, esExports = [] } + | Just (Public, name, _) <- matchMember jsStatement + = pure ForeignModuleExports{ cjsExports = [name], esExports = [] } | otherwise - = pure [] + = pure mempty + go (JSModuleExportDeclaration _ jsExportDeclaration) = + pure ForeignModuleExports{ cjsExports = [], esExports = exportDeclarationIdentifiers jsExportDeclaration } + go _ = pure mempty toIdent (JSPropertyNameandValue name _ [_]) = extractLabel' name @@ -446,13 +584,57 @@ getExportedIdentifiers mname top extractLabel' = maybe (err UnsupportedExport) pure . extractLabel + exportDeclarationIdentifiers (JSExportFrom jsExportClause _ _) = + exportClauseIdentifiers jsExportClause + exportDeclarationIdentifiers (JSExportLocals jsExportClause _) = + exportClauseIdentifiers jsExportClause + exportDeclarationIdentifiers (JSExport jsStatement _) = + exportStatementIdentifiers jsStatement + + exportClauseIdentifiers (JSExportClause _ jsExportsSpecifiers _) = + mapMaybe exportSpecifierName $ commaList jsExportsSpecifiers + + exportSpecifierName (JSExportSpecifier jsIdent) = identName jsIdent + exportSpecifierName (JSExportSpecifierAs _ _ jsIdentAs) = identName jsIdentAs + +data ForeignModuleImports = + ForeignModuleImports + { cjsImports :: [String] + , esImports :: [String] + } deriving (Show) + +instance Semigroup ForeignModuleImports where + (ForeignModuleImports cjsImports esImports) <> (ForeignModuleImports cjsImports' esImports') = + ForeignModuleImports (cjsImports <> cjsImports') (esImports <> esImports') +instance Monoid ForeignModuleImports where + mempty = ForeignModuleImports [] [] + +-- Get a list of all the imported module identifiers from a foreign module. +getImportedModules :: forall m. (MonadError ErrorMessage m) + => String + -> JSAST + -> m ForeignModuleImports +getImportedModules mname top + | JSAstModule jsModuleItems _ <- top = pure $ foldMap go jsModuleItems + | otherwise = err InvalidTopLevel + where + err :: ErrorMessage -> m a + err = throwError . ErrorInModule (ModuleIdentifier mname Foreign) + + go (JSModuleStatementListItem jsStatement) + | Just (_, mid) <- matchRequire jsStatement + = ForeignModuleImports{ cjsImports = [mid], esImports = [] } + go (JSModuleImportDeclaration _ jsImportDeclaration) = + ForeignModuleImports{ cjsImports = [], esImports = [importDeclarationModuleId jsImportDeclaration] } + go _ = mempty + + importDeclarationModuleId (JSImportDeclaration _ (JSFromClause _ _ mid) _) = mid + importDeclarationModuleId (JSImportDeclarationBare _ mid _) = mid + -- Matches JS statements like this: -- var ModuleName = require("file"); -matchRequire :: S.Set String - -> ModuleIdentifier - -> JSStatement - -> Maybe (String, Either String ModuleIdentifier) -matchRequire mids mid stmt +matchRequire :: JSStatement -> Maybe (String, String) +matchRequire stmt | JSVariable _ jsInit _ <- stmt , [JSVarInitExpression var varInit] <- commaList jsInit , JSIdentifier _ importName <- var @@ -460,28 +642,34 @@ matchRequire mids mid stmt , JSMemberExpression req _ argsE _ <- jsInitEx , JSIdentifier _ "require" <- req , [ Just importPath ] <- map fromStringLiteral (commaList argsE) - , importPath' <- checkImportPath importPath mid mids - = Just (importName, importPath') + = Just (importName, importPath) | otherwise = Nothing -- Matches JS member declarations. matchMember :: JSStatement -> Maybe (Visibility, String, JSExpression) matchMember stmt + | Just (name, decl) <- matchInternalMember stmt + = pure (Internal, name, decl) + -- exports.foo = expr; exports["foo"] = expr; + | JSAssignStatement e (JSAssign _) decl _ <- stmt + , Just name <- exportsAccessor e + = Just (Public, name, decl) + | otherwise + = Nothing + +matchInternalMember :: JSStatement -> Maybe (String, JSExpression) +matchInternalMember stmt -- var foo = expr; | JSVariable _ jsInit _ <- stmt , [JSVarInitExpression var varInit] <- commaList jsInit , JSIdentifier _ name <- var , JSVarInit _ decl <- varInit - = Just (Internal, name, decl) + = pure (name, decl) -- function foo(...args) { body } | JSFunction a0 jsIdent a1 args a2 body _ <- stmt , JSIdentName _ name <- jsIdent - = pure (Internal, name, JSFunctionExpression a0 jsIdent a1 args a2 body) - -- exports.foo = expr; exports["foo"] = expr; - | JSAssignStatement e (JSAssign _) decl _ <- stmt - , Just name <- exportsAccessor e - = Just (Public, name, decl) + = pure (name, JSFunctionExpression a0 jsIdent a1 args a2 body) | otherwise = Nothing @@ -530,8 +718,8 @@ compile modules entryPoints = filteredModules where -- | Create a set of vertices for a module element. -- - -- Require statements don't contribute towards dependencies, since they effectively get - -- inlined wherever they are used inside other module elements. + -- Imports declarations and require statements don't contribute towards dependencies, + -- since they effectively get inlined wherever they are used inside other module elements. toVertices :: ModuleIdentifier -> ModuleElement -> [(ModuleElement, Key, [Key])] toVertices p m@(Member _ visibility nm _ deps) = [(m, (p, nm, visibility), deps)] toVertices p m@(ExportsList exps) = map toVertex exps @@ -571,11 +759,11 @@ compile modules entryPoints = filteredModules | otherwise = d : go rest skipDecl :: ModuleElement -> ModuleElement - skipDecl (Require s _ _) = Skip s - skipDecl (Member s _ _ _ _) = Skip s - skipDecl (ExportsList _) = Skip (JSEmptyStatement JSNoAnnot) - skipDecl (Other s) = Skip s - skipDecl (Skip s) = Skip s + skipDecl (Import item _ _) = Skip item + skipDecl (Member stmt _ _ _ _) = Skip $ JSModuleStatementListItem stmt + skipDecl (ExportsList _) = Skip . JSModuleStatementListItem $ JSEmptyStatement JSNoAnnot + skipDecl (Other stmt) = Skip $ JSModuleStatementListItem stmt + skipDecl (Skip item) = Skip item -- | Filter out the exports for members which aren't used. filterExports :: ModuleElement -> ModuleElement @@ -584,7 +772,7 @@ compile modules entryPoints = filteredModules isDeclUsed :: ModuleElement -> Bool isDeclUsed (Member _ visibility nm _ _) = isKeyUsed (mid, nm, visibility) - isDeclUsed (Require _ _ (Right midRef)) = midRef `S.member` modulesReferenced + isDeclUsed (Import _ _ (Right midRef)) = midRef `S.member` modulesReferenced isDeclUsed _ = True isKeyUsed :: Key -> Bool @@ -605,7 +793,7 @@ sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (top return (m, mid, mapMaybe getKey els) getKey :: ModuleElement -> Maybe ModuleIdentifier - getKey (Require _ _ (Right mi)) = Just mi + getKey (Import _ _ (Right mi)) = Just mi getKey _ = Nothing -- | A module is empty if it contains no exported members (in other words, @@ -618,7 +806,7 @@ isModuleEmpty (Module _ _ els) = all isElementEmpty els where isElementEmpty :: ModuleElement -> Bool isElementEmpty (ExportsList exps) = null exps - isElementEmpty Require{} = True + isElementEmpty Import{} = True isElementEmpty (Other _) = True isElementEmpty (Skip _) = True isElementEmpty _ = False @@ -659,7 +847,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o }) (offsets (0,0) (Right 1 : positions))) moduleFns - (scanl (+) (3 + moduleLength [prelude]) (map (3+) moduleLengths)) -- 3 lines between each module & at top + (scanl (+) (3 + moduleLength [JSModuleStatementListItem prelude]) (map (3+) moduleLengths)) -- 3 lines between each module & at top (map snd modulesJS) } where @@ -669,7 +857,7 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o offsets (m, n) (Right d:rest) = map ((m+) &&& (n+)) [0 .. d - 1] ++ offsets (m+d, n+d) rest offsets _ _ = [] - moduleLength :: [JSStatement] -> Int + moduleLength :: [JSModuleItem] -> Int moduleLength = everything (+) (mkQ 0 countw) where countw :: CommentAnnotation -> Int @@ -688,13 +876,13 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o (jsDecls, lengths) = unzip $ map declToJS ds withLength :: [JSStatement] -> ([JSStatement], Either Int Int) - withLength n = (n, Right $ moduleLength n) + withLength n = (n, Right . moduleLength $ JSModuleStatementListItem <$> n) declToJS :: ModuleElement -> ([JSStatement], Either Int Int) declToJS (Member n _ _ _ _) = withLength [n] declToJS (Other n) = withLength [n] declToJS (Skip n) = ([], Left $ moduleLength [n]) - declToJS (Require _ nm req) = withLength + declToJS (Import _ nm req) = withLength [ JSVariable lfsp (cList [ @@ -702,15 +890,15 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o (JSVarInit sp $ either require (innerModuleReference sp . moduleName) req ) ]) (JSSemi JSNoAnnot) ] - declToJS (ExportsList exps) = withLength $ map toExport exps + declToJS (ExportsList exps) = withLength $ map toCommonJSExport exps where - toExport :: (ExportType, String, JSExpression, [Key]) -> JSStatement - toExport (_, nm, val, _) = + toCommonJSExport :: (ExportType, String, JSExpression, [Key]) -> JSStatement + toCommonJSExport (_, nm, val, _) = JSAssignStatement (JSMemberSquare (JSIdentifier lfsp "exports") JSNoAnnot - (str nm) JSNoAnnot) + (stringLiteral nm) JSNoAnnot) (JSAssign sp) val (JSSemi JSNoAnnot) @@ -748,22 +936,18 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o require :: String -> JSExpression require mn = - JSMemberExpression (JSIdentifier JSNoAnnot "require") JSNoAnnot (cList [ str mn ]) JSNoAnnot + JSMemberExpression (JSIdentifier JSNoAnnot "require") JSNoAnnot + (cList [ stringLiteral mn ]) JSNoAnnot moduleReference :: JSAnnot -> String -> JSExpression moduleReference a mn = JSMemberSquare (JSIdentifier a optionsNamespace) JSNoAnnot - (str mn) JSNoAnnot + (stringLiteral mn) JSNoAnnot innerModuleReference :: JSAnnot -> String -> JSExpression innerModuleReference a mn = JSMemberSquare (JSIdentifier a "$PS") JSNoAnnot - (str mn) JSNoAnnot - - - str :: String -> JSExpression - str s = JSStringLiteral JSNoAnnot $ "\"" ++ s ++ "\"" - + (stringLiteral mn) JSNoAnnot emptyObj :: JSAnnot -> JSExpression emptyObj a = JSObjectLiteral a (JSCTLNone JSLNil) JSNoAnnot @@ -831,9 +1015,6 @@ codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping o lfsp :: JSAnnot lfsp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] - sp :: JSAnnot - sp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ] - -- | The bundling function. -- This function performs dead code elimination, filters empty modules -- and generates and prints the final JavaScript bundle. @@ -852,7 +1033,7 @@ bundleSM inputStrs entryPoints mainModule namespace outFilename reportRawModules forM_ entryPoints $ \mIdent -> when (mIdent `notElem` map mid inputStrs) (throwError (MissingEntryPoint (moduleName mIdent))) input <- forM inputStrs $ \(ident, filename, js) -> do - ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident) + ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parseModule js (moduleName ident) return (ident, filename, ast) let mids = S.fromList (map (moduleName . mid) input) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 856fa9ce2b..6a71a97dec 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -9,17 +9,19 @@ module Language.PureScript.CodeGen.JS import Prelude.Compat import Protolude (ordNub) -import Control.Arrow ((&&&)) +import Control.Applicative (liftA2) import Control.Monad (forM, replicateM, void) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class +import Data.Bifunctor (first) import Data.List ((\\), intersect) +import qualified Data.List.NonEmpty as NEL (nonEmpty) import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Set as S -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T @@ -28,6 +30,7 @@ import Language.PureScript.AST.SourcePos import Language.PureScript.CodeGen.JS.Common as Common import Language.PureScript.CoreImp.AST (AST, everywhereTopDownM, withSourceSpan) import qualified Language.PureScript.CoreImp.AST as AST +import qualified Language.PureScript.CoreImp.Module as AST import Language.PureScript.CoreImp.Optimizer import Language.PureScript.CoreFn import Language.PureScript.Crash @@ -48,57 +51,92 @@ moduleToJs :: forall m . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) => Module Ann - -> Maybe AST - -> m [AST] -moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ = + -> Maybe PSString + -> m AST.Module +moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps let decls' = renameModules mnLookup decls jsDecls <- mapM bindToJs decls' - optimized <- traverse (traverse optimize) jsDecls let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup + let moduleObjectNames = "$foreign" `S.insert` M.keysSet mnReverseLookup + optimized <- traverse (traverse (fmap (annotatePure moduleObjectNames) . optimize)) jsDecls let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized `S.union` M.keysSet reExps - jsImports <- traverse (importToJs mnLookup) - . filter (flip S.member usedModuleNames) - . (\\ (mn : C.primModules)) $ ordNub $ map snd imps + let jsImports + = map (importToJs mnLookup) + . filter (flip S.member usedModuleNames) + . (\\ (mn : C.primModules)) $ ordNub $ map snd imps F.traverse_ (F.traverse_ checkIntegers) optimized comments <- not <$> asks optionsNoComments - let strict = AST.StringLiteral Nothing "use strict" - let header = if comments && not (null coms) then AST.Comment Nothing coms strict else strict - let foreign' = [AST.VariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_] - let moduleBody = header : foreign' ++ jsImports ++ concat optimized + let header = if comments then coms else [] + let foreign' = maybe [] (pure . AST.Import "$foreign") $ if null foreigns then Nothing else foreignInclude + let moduleBody = concat optimized let foreignExps = exps `intersect` foreigns let standardExps = exps \\ foreignExps let reExps' = M.toList (M.withoutKeys reExps (S.fromList C.primModules)) - let exps' = AST.ObjectLiteral Nothing $ map (mkString . runIdent &&& AST.Var Nothing . identToJs) standardExps - ++ map (mkString . runIdent &&& foreignIdent) foreignExps - ++ concatMap (reExportPairs mnLookup) reExps' - return $ moduleBody ++ [AST.Assignment Nothing (accessorString "exports" (AST.Var Nothing "module")) exps'] + let jsExports + = (maybeToList . exportsToJs foreignInclude $ foreignExps) + ++ (maybeToList . exportsToJs Nothing $ standardExps) + ++ mapMaybe reExportsToJs reExps' + return $ AST.Module header (foreign' ++ jsImports) moduleBody jsExports where + -- | Adds purity annotations to top-level values for bundlers. + -- The semantics here derive from treating top-level module evaluation as pure, which lets + -- us remove any unreferenced top-level declarations. To achieve this, we wrap any non-trivial + -- top-level values in an IIFE marked with a pure annotation. + annotatePure :: S.Set Text -> AST -> AST + annotatePure moduleObjectNames = annotateOrWrap + where + annotateOrWrap = liftA2 fromMaybe pureIife maybePure + + -- | If the JS is potentially effectful (in the eyes of a bundler that + -- doesn't know about PureScript), return Nothing. Otherwise, return Just + -- the JS with any needed pure annotations added, and, in the case of a + -- variable declaration, an IIFE to be annotated. + maybePure :: AST -> Maybe AST + maybePure = maybePureGen False + + -- | Like maybePure, but doesn't add a pure annotation to App. This exists + -- to prevent from doubling up on annotation comments on curried + -- applications; from experimentation, it turns out that a comment on the + -- outermost App is sufficient for the entire curried chain to be + -- considered effect-free. + maybePure' :: AST -> Maybe AST + maybePure' = maybePureGen True + + maybePureGen alreadyAnnotated = \case + AST.VariableIntroduction ss name j -> Just (AST.VariableIntroduction ss name (annotateOrWrap <$> j)) + AST.App ss f args -> (if alreadyAnnotated then AST.App else pureApp) ss <$> maybePure' f <*> traverse maybePure args + -- In general, indexers can be effectful, but not when indexing into an + -- ES module object. + AST.Indexer ss idx v@(AST.Var _ name) + | name `S.member` moduleObjectNames -> (\idx' -> AST.Indexer ss idx' v) <$> maybePure idx + AST.ArrayLiteral ss jss -> AST.ArrayLiteral ss <$> traverse maybePure jss + AST.ObjectLiteral ss props -> AST.ObjectLiteral ss <$> traverse (traverse maybePure) props + AST.Comment c js -> AST.Comment c <$> maybePure js + + js@AST.NumericLiteral{} -> Just js + js@AST.StringLiteral{} -> Just js + js@AST.BooleanLiteral{} -> Just js + js@AST.Function{} -> Just js + js@AST.Var{} -> Just js + + _ -> Nothing + + pureIife :: AST -> AST + pureIife val = pureApp Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing [AST.Return Nothing val])) [] + + pureApp :: Maybe SourceSpan -> AST -> [AST] -> AST + pureApp ss f = AST.Comment AST.PureAnnotation . AST.App ss f -- | Extracts all declaration names from a binding group. getNames :: Bind Ann -> [Ident] getNames (NonRec _ ident _) = [ident] getNames (Rec vals) = map (snd . fst) vals - -- | Generate code in the JavaScript IR for re-exported declarations, prepending - -- the module name from whence it was imported. - reExportPairs :: M.Map ModuleName (Ann, ModuleName) -> (ModuleName, [Ident]) -> [(PSString, AST)] - reExportPairs mnLookup (mn', idents) = - let toExportedMember :: Ident -> AST - toExportedMember = - maybe - (AST.Var Nothing . identToJs) - (flip accessor . AST.Var Nothing . moduleNameToJs . snd) - (M.lookup mn' mnLookup) - in - map - (mkString . runIdent &&& toExportedMember) - idents - -- | Creates alternative names for each module to ensure they don't collide -- with declaration names. renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName) @@ -122,12 +160,23 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ = -- | Generates JavaScript code for a module import, binding the required module -- to the alternative - importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m AST - importToJs mnLookup mn' = do - let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - let moduleBody = AST.App Nothing (AST.Var Nothing "require") - [AST.StringLiteral Nothing (fromString (".." T.unpack (runModuleName mn') "index.js"))] - withPos ss $ AST.VariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody) + importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> AST.Import + importToJs mnLookup mn' = + let (_, mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup + in AST.Import (moduleNameToJs mnSafe) (moduleImportPath mn') + + -- | Generates JavaScript code for exporting at least one identifier, + -- eventually from another module. + exportsToJs :: Maybe PSString -> [Ident] -> Maybe AST.Export + exportsToJs from = fmap (flip AST.Export from) . NEL.nonEmpty . fmap runIdent + + -- | Generates JavaScript code for re-exporting at least one identifier from + -- from another module. + reExportsToJs :: (ModuleName, [Ident]) -> Maybe AST.Export + reExportsToJs = uncurry exportsToJs . first (Just . moduleImportPath) + + moduleImportPath :: ModuleName -> PSString + moduleImportPath mn' = fromString (".." T.unpack (runModuleName mn') "index.js") -- | Replaces the `ModuleName`s in the AST so that the generated code refers to -- the collision-avoiding renamed module imports. @@ -177,7 +226,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ = withoutComment <- asks optionsNoComments if withoutComment then nonRecToJS a i (modifyAnn removeComments e) - else AST.Comment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e) + else AST.Comment (AST.SourceComments com) <$> nonRecToJS a i (modifyAnn removeComments e) nonRecToJS (ss, _, _, _) ident val = do js <- valueToJs val withPos ss $ AST.VariableIntroduction Nothing (identToJs ident) (Just js) @@ -197,10 +246,13 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ = -- | Generate code in the simplified JavaScript intermediate representation for an accessor based on -- a PureScript identifier. If the name is not valid in JavaScript (symbol based, reserved name) an -- indexer is returned. - accessor :: Ident -> AST -> AST - accessor (Ident prop) = accessorString $ mkString prop - accessor (GenIdent _ _) = internalError "GenIdent in accessor" - accessor UnusedIdent = internalError "UnusedIdent in accessor" + moduleAccessor :: Ident -> AST -> AST + moduleAccessor (Ident prop) = moduleAccessorString prop + moduleAccessor (GenIdent _ _) = internalError "GenIdent in moduleAccessor" + moduleAccessor UnusedIdent = internalError "UnusedIdent in moduleAccessor" + + moduleAccessorString :: Text -> AST -> AST + moduleAccessorString = accessorString . mkString . T.replace "'" "$prime" accessorString :: PSString -> AST -> AST accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop) @@ -318,7 +370,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreign_ = -- variable that may have a qualified name. qualifiedToJS :: (a -> Ident) -> Qualified a -> AST qualifiedToJS f (Qualified (Just C.Prim) a) = AST.Var Nothing . runIdent $ f a - qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (AST.Var Nothing (moduleNameToJs mn')) + qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = moduleAccessor (f a) (AST.Var Nothing (moduleNameToJs mn')) qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToJs (f a) foreignIdent :: Ident -> AST diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index 39fe77c897..8ffc0403d2 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -15,10 +15,12 @@ import qualified Control.Arrow as A import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.List.NonEmpty as NEL (toList) import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.CodeGen.JS.Common import Language.PureScript.CoreImp.AST +import Language.PureScript.CoreImp.Module import Language.PureScript.Comments import Language.PureScript.Crash import Language.PureScript.Pretty.Common @@ -114,40 +116,70 @@ literals = mkPattern' match' [ return $ emit "throw " , prettyPrintJS' value ] - match (Comment _ com js) = mconcat <$> sequence + match (Comment (SourceComments com) js) = mconcat <$> sequence [ return $ emit "\n" , mconcat <$> forM com comment , prettyPrintJS' js ] + match (Comment PureAnnotation js) = mconcat <$> sequence + [ return $ emit "/* #__PURE__ */ " + , prettyPrintJS' js + ] match _ = mzero - comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen - comment (LineComment com) = mconcat <$> sequence - [ currentIndent - , return $ emit "//" <> emit com <> emit "\n" - ] - comment (BlockComment com) = fmap mconcat $ sequence $ - [ currentIndent - , return $ emit "/**\n" - ] ++ - map asLine (T.lines com) ++ - [ currentIndent - , return $ emit " */\n" +comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen +comment (LineComment com) = mconcat <$> sequence + [ currentIndent + , return $ emit "//" <> emit com <> emit "\n" + ] +comment (BlockComment com) = fmap mconcat $ sequence $ + [ currentIndent + , return $ emit "/**\n" + ] ++ + map asLine (T.lines com) ++ + [ currentIndent + , return $ emit " */\n" + , currentIndent + ] + where + asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen + asLine s = do + i <- currentIndent + return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n" + + removeComments :: Text -> Text + removeComments t = + case T.stripPrefix "*/" t of + Just rest -> removeComments rest + Nothing -> case T.uncons t of + Just (x, xs) -> x `T.cons` removeComments xs + Nothing -> "" + +prettyImport :: (Emit gen) => Import -> StateT PrinterState Maybe gen +prettyImport (Import ident from) = + return . emit $ + "import * as " <> ident <> " from " <> prettyPrintStringJS from <> ";" + +prettyExport :: (Emit gen) => Export -> StateT PrinterState Maybe gen +prettyExport (Export idents from) = + mconcat <$> sequence + [ return $ emit "export {\n" + , withIndent $ do + let exportsStrings = emit . exportedIdentToString from <$> idents + indentString <- currentIndent + return . intercalate (emit ",\n") . NEL.toList $ (indentString <>) <$> exportsStrings + , return $ emit "\n" , currentIndent + , return . emit $ "}" <> maybe "" ((" from " <>) . prettyPrintStringJS) from <> ";" ] - where - asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen - asLine s = do - i <- currentIndent - return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n" - - removeComments :: Text -> Text - removeComments t = - case T.stripPrefix "*/" t of - Just rest -> removeComments rest - Nothing -> case T.uncons t of - Just (x, xs) -> x `T.cons` removeComments xs - Nothing -> "" + where + exportedIdentToString Nothing ident + | nameIsJsReserved ident || nameIsJsBuiltIn ident + = "$$" <> ident <> " as " <> ident + exportedIdentToString _ "$main" + = T.concatMap identCharToText "$main" <> " as $main" + exportedIdentToString _ ident + = T.concatMap identCharToText ident accessor :: Pattern PrinterState AST (Text, AST) accessor = mkPattern match @@ -217,14 +249,22 @@ prettyStatements sts = do indentString <- currentIndent return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss +prettyModule :: (Emit gen) => Module -> StateT PrinterState Maybe gen +prettyModule Module{..} = do + header <- mconcat <$> traverse comment modHeader + imps <- traverse prettyImport modImports + body <- prettyStatements modBody + exps <- traverse prettyExport modExports + pure $ header <> intercalate (emit "\n") (imps ++ body : exps) + -- | Generate a pretty-printed string representing a collection of JavaScript expressions at the same indentation level -prettyPrintJSWithSourceMaps :: [AST] -> (Text, [SMap]) +prettyPrintJSWithSourceMaps :: Module -> (Text, [SMap]) prettyPrintJSWithSourceMaps js = - let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js + let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyModule) js in (s, mp) -prettyPrintJS :: [AST] -> Text -prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements +prettyPrintJS :: Module -> Text +prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyModule -- | Generate an indented, pretty-printed string representing a JavaScript expression prettyPrintJS' :: (Emit gen) => AST -> StateT PrinterState Maybe gen diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs index b6dcad1446..87f3d004ba 100644 --- a/src/Language/PureScript/CoreImp/AST.hs +++ b/src/Language/PureScript/CoreImp/AST.hs @@ -44,6 +44,13 @@ data BinaryOperator | ZeroFillShiftRight deriving (Show, Eq) +-- | Data type for CoreImp comments, which can come from either the PureScript +-- source or internal transformations. +data CIComments + = SourceComments [Comment] + | PureAnnotation + deriving (Show, Eq) + -- | Data type for simplified JavaScript expressions data AST = NumericLiteral (Maybe SourceSpan) (Either Integer Double) @@ -90,7 +97,7 @@ data AST -- ^ Throw statement | InstanceOf (Maybe SourceSpan) AST AST -- ^ instanceof check - | Comment (Maybe SourceSpan) [Comment] AST + | Comment CIComments AST -- ^ Commented JavaScript deriving (Show, Eq) @@ -122,7 +129,7 @@ withSourceSpan withSpan = go where go (ReturnNoResult _) = ReturnNoResult ss go (Throw _ js) = Throw ss js go (InstanceOf _ j1 j2) = InstanceOf ss j1 j2 - go (Comment _ com j) = Comment ss com j + go c@Comment{} = c getSourceSpan :: AST -> Maybe SourceSpan getSourceSpan = go where @@ -149,7 +156,7 @@ getSourceSpan = go where go (ReturnNoResult ss) = ss go (Throw ss _) = ss go (InstanceOf ss _ _) = ss - go (Comment ss _ _) = ss + go (Comment _ _) = Nothing everywhere :: (AST -> AST) -> AST -> AST everywhere f = go where @@ -171,7 +178,7 @@ everywhere f = go where go (Return ss js) = f (Return ss (go js)) go (Throw ss js) = f (Throw ss (go js)) go (InstanceOf ss j1 j2) = f (InstanceOf ss (go j1) (go j2)) - go (Comment ss com j) = f (Comment ss com (go j)) + go (Comment com j) = f (Comment com (go j)) go other = f other everywhereTopDown :: (AST -> AST) -> AST -> AST @@ -197,7 +204,7 @@ everywhereTopDownM f = f >=> go where go (Return ss j) = Return ss <$> f' j go (Throw ss j) = Throw ss <$> f' j go (InstanceOf ss j1 j2) = InstanceOf ss <$> f' j1 <*> f' j2 - go (Comment ss com j) = Comment ss com <$> f' j + go (Comment com j) = Comment com <$> f' j go other = f other everything :: (r -> r -> r) -> (AST -> r) -> AST -> r @@ -220,5 +227,5 @@ everything (<>.) f = go where go j@(Return _ j1) = f j <>. go j1 go j@(Throw _ j1) = f j <>. go j1 go j@(InstanceOf _ j1 j2) = f j <>. go j1 <>. go j2 - go j@(Comment _ _ j1) = f j <>. go j1 + go j@(Comment _ j1) = f j <>. go j1 go other = f other diff --git a/src/Language/PureScript/CoreImp/Module.hs b/src/Language/PureScript/CoreImp/Module.hs new file mode 100644 index 0000000000..efd591508f --- /dev/null +++ b/src/Language/PureScript/CoreImp/Module.hs @@ -0,0 +1,19 @@ +module Language.PureScript.CoreImp.Module where + +import Protolude +import qualified Data.List.NonEmpty as NEL (NonEmpty) + +import Language.PureScript.Comments +import Language.PureScript.CoreImp.AST +import Language.PureScript.PSString (PSString) + +data Module = Module + { modHeader :: [Comment] + , modImports :: [Import] + , modBody :: [AST] + , modExports :: [Export] + } + +data Import = Import Text PSString + +data Export = Export (NEL.NonEmpty Text) (Maybe PSString) diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index f93c6a93df..1189d18c99 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -121,7 +121,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where | otherwise = empty allInTailPosition (Assignment _ _ js1) = guard (countSelfReferences js1 == 0) $> S.empty - allInTailPosition (Comment _ _ js1) + allInTailPosition (Comment _ js1) = allInTailPosition js1 allInTailPosition _ = empty diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 7d5752f982..1d6f56d295 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -65,6 +65,9 @@ data SimpleErrorMessage | UnusedFFIImplementations ModuleName [Ident] | InvalidFFIIdentifier ModuleName Text | DeprecatedFFIPrime ModuleName Text + | DeprecatedFFICommonJSModule ModuleName FilePath + | UnsupportedFFICommonJSExports ModuleName [Text] + | UnsupportedFFICommonJSImports ModuleName [Text] | FileIOError Text IOError -- ^ A description of what we were trying to do, and the error which occurred | InfiniteType SourceType | InfiniteKind SourceType @@ -239,6 +242,9 @@ errorCode em = case unwrapErrorMessage em of UnusedFFIImplementations{} -> "UnusedFFIImplementations" InvalidFFIIdentifier{} -> "InvalidFFIIdentifier" DeprecatedFFIPrime{} -> "DeprecatedFFIPrime" + DeprecatedFFICommonJSModule {} -> "DeprecatedFFICommonJSModule" + UnsupportedFFICommonJSExports {} -> "UnsupportedFFICommonJSExports" + UnsupportedFFICommonJSImports {} -> "UnsupportedFFICommonJSImports" FileIOError{} -> "FileIOError" InfiniteType{} -> "InfiniteType" InfiniteKind{} -> "InfiniteKind" @@ -701,9 +707,22 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line $ "In the FFI module for " <> markCode (runModuleName mn) <> ":" , indent . paras $ [ line $ "The identifier " <> markCode ident <> " contains a prime (" <> markCode "'" <> ")." - , line "Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future." + , line "Primes are not allowed in identifiers exported from FFI modules." ] ] + renderSimpleErrorMessage (DeprecatedFFICommonJSModule mn path) = + paras [ line $ "A CommonJS foreign module implementation was provided for module " <> markCode (runModuleName mn) <> ": " + , indent . lineS $ path + , line "CommonJS foreign modules are deprecated and won't be supported in the future." + ] + renderSimpleErrorMessage (UnsupportedFFICommonJSExports mn idents) = + paras [ line $ "The following CommonJS exports are not supported in the ES foreign module for module " <> markCode (runModuleName mn) <> ": " + , indent . paras $ map line idents + ] + renderSimpleErrorMessage (UnsupportedFFICommonJSImports mn mids) = + paras [ line $ "The following CommonJS imports are not supported in the ES foreign module for module " <> markCode (runModuleName mn) <> ": " + , indent . paras $ map line mids + ] renderSimpleErrorMessage InvalidDoBind = line "The last statement in a 'do' block must be an expression, but this block ends with a binder." renderSimpleErrorMessage InvalidDoLet = diff --git a/src/Language/PureScript/Interactive/IO.hs b/src/Language/PureScript/Interactive/IO.hs index 92a2e8dc64..1b0ba2fc00 100644 --- a/src/Language/PureScript/Interactive/IO.hs +++ b/src/Language/PureScript/Interactive/IO.hs @@ -1,13 +1,25 @@ -module Language.PureScript.Interactive.IO (findNodeProcess, getHistoryFilename) where +{-# LANGUAGE TypeApplications #-} + +module Language.PureScript.Interactive.IO (findNodeProcess, readNodeProcessWithExitCode, getHistoryFilename) where import Prelude.Compat -import Control.Monad (msum) +import Control.Monad (msum, void) +import Control.Monad.Error.Class (throwError) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Data.Functor ((<&>)) +import Data.List (isInfixOf) import System.Directory (XdgDirectory (..), createDirectoryIfMissing, getAppUserDataDirectory, getXdgDirectory, findExecutable, doesFileExist) +import System.Exit (ExitCode(ExitFailure, ExitSuccess)) import System.FilePath (takeDirectory, ()) +import System.Process (readProcessWithExitCode) +import Text.Parsec ((), many1, parse, sepBy) +import Text.Parsec.Char (char, digit) +import Protolude (note) mkdirp :: FilePath -> IO () mkdirp = createDirectoryIfMissing True . takeDirectory @@ -21,9 +33,42 @@ onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVar -- Locates the node executable. -- Checks for either @nodejs@ or @node@. -- -findNodeProcess :: IO (Maybe String) -findNodeProcess = onFirstFileMatching findExecutable names - where names = ["nodejs", "node"] +findNodeProcess :: IO (Either String String) +findNodeProcess = onFirstFileMatching findExecutable ["nodejs", "node"] <&> + note "Could not find Node.js. Do you have Node.js installed and available in your PATH?" + +findNodeVersion :: String -> IO (Maybe String) +findNodeVersion node = do + result <- readProcessWithExitCode node ["--version"] "" + return $ case result of + (ExitSuccess, version, _) -> Just version + (ExitFailure _, _, _) -> Nothing + +readNodeProcessWithExitCode :: Maybe FilePath -> [String] -> String -> IO (Either String (ExitCode, String, String)) +readNodeProcessWithExitCode nodePath nodeArgs stdin = runExceptT $ do + process <- maybe (ExceptT findNodeProcess) pure nodePath + (major, _, _) <- lift (findNodeVersion process) >>= \case + Nothing -> throwError "Could not find Node.js version." + Just version -> do + let semver = do + void $ char 'v' + major : minor : patch : _ <- fmap (read @Int) (many1 digit) `sepBy` void (char '.') + pure (major, minor, patch) + case parse (semver "Could not parse Node.js version.") "" version of + Left err -> throwError $ show err + Right (major, minor, patch) + | major < 12 -> throwError $ "Unsupported Node.js version " <> show major <> ". Required Node.js version >=12." + | otherwise -> pure (major, minor, patch) + let nodeArgs' = if major < 13 then "--experimental-modules" : nodeArgs else nodeArgs + lift (readProcessWithExitCode process nodeArgs' stdin) <&> \case + (ExitSuccess, out, err) -> + (ExitSuccess, out, censorExperimentalWarnings err) + (ExitFailure code, out, err) -> + (ExitFailure code, out, err) + +censorExperimentalWarnings :: String -> String +censorExperimentalWarnings = + unlines . filter (not . ("ExperimentalWarning" `isInfixOf`)) . lines -- | -- Grabs the filename where the history is stored. diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 8e8a61077c..c0ca5c1b53 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -89,7 +89,7 @@ indexFile :: FilePath indexFile = ".psci_modules" ++ pathSeparator : "index.js" modulesDir :: FilePath -modulesDir = ".psci_modules" ++ pathSeparator : "node_modules" +modulesDir = ".psci_modules" internalSpan :: P.SourceSpan internalSpan = P.internalModuleSourceSpan "" diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 94e5bbd73e..069735c5e4 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -167,6 +167,8 @@ make ma@MakeActions{..} ms = do -- Write the updated build cache database to disk writeCacheDb $ Cache.removeModules (M.keysSet failures) newCacheDb + writePackageJson + -- If generating docs, also generate them for the Prim modules outputPrimDocs diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 2931ae2191..8bc41c40fa 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -11,6 +11,7 @@ module Language.PureScript.Make.Actions import Prelude +import Control.Arrow ((&&&)) import Control.Monad hiding (sequence) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class @@ -18,6 +19,7 @@ import Control.Monad.Reader (asks) import Control.Monad.Supply import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Aeson (Value(String), (.=), object) import Data.Bifunctor (bimap) import Data.Either (partitionEithers) import Data.Foldable (for_) @@ -37,7 +39,6 @@ import qualified Language.PureScript.CodeGen.JS as J import Language.PureScript.CodeGen.JS.Printer import qualified Language.PureScript.CoreFn as CF import qualified Language.PureScript.CoreFn.ToJSON as CFJ -import qualified Language.PureScript.CoreImp.AST as Imp import Language.PureScript.Crash import qualified Language.PureScript.CST as CST import qualified Language.PureScript.Docs.Prim as Docs.Prim @@ -109,6 +110,9 @@ data MakeActions m = MakeActions , writeCacheDb :: CacheDb -> m () -- ^ Write the given cache database to some external source (e.g. a file on -- disk). + , writePackageJson :: m () + -- ^ Write to the output directory the package.json file allowing Node.js to + -- load .js files as ES modules. , outputPrimDocs :: m () -- ^ If generating docs, output the documentation for the Prim modules } @@ -135,6 +139,15 @@ writeCacheDb' -> m () writeCacheDb' = writeJSONFile . cacheDbFile +writePackageJson' + :: (MonadIO m, MonadError MultipleErrors m) + => FilePath + -- ^ The path to the output directory + -> m () +writePackageJson' outputDir = writeJSONFile (outputDir "package.json") $ object + [ "type" .= String "module" + ] + -- | A set of make actions that read and write modules from the given directory. buildMakeActions :: FilePath @@ -147,7 +160,7 @@ buildMakeActions -- ^ Generate a prefix comment? -> MakeActions Make buildMakeActions outputDir filePathMap foreigns usePrefix = - MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb outputPrimDocs + MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb writePackageJson outputPrimDocs where getInputTimestampsAndHashes @@ -233,7 +246,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = | not $ requiresForeign m -> do return Nothing | otherwise -> do - return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign.js"] + return $ Just "./foreign.js" Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn | otherwise -> return Nothing rawJs <- J.moduleToJs m foreignInclude @@ -260,12 +273,34 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = Just path | not $ requiresForeign m -> tell $ errorMessage' (CF.moduleSourceSpan m) $ UnnecessaryFFIModule mn path - | otherwise -> - checkForeignDecls m path + | otherwise -> do + (foreignModuleType, foreignIdents) <- checkForeignDecls m path + case foreignModuleType of + ESModule -> copyFile path (outputFilename mn "foreign.js") + CJSModule -> do + tell $ errorMessage' (CF.moduleSourceSpan m) $ DeprecatedFFICommonJSModule mn path + copyFile path (outputFilename mn "foreign.cjs") + writeESForeignModuleWrapper mn foreignIdents + Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn | otherwise -> return () - for_ (mn `M.lookup` foreigns) $ \path -> - copyFile path (outputFilename mn "foreign.js") + + writeESForeignModuleWrapper :: ModuleName -> S.Set Ident -> Make () + writeESForeignModuleWrapper mn idents = + writeTextFile (outputFilename mn "foreign.js") wrapper + where + xs = (J.identToJs &&& runIdent) <$> S.toList idents + wrapper = TE.encodeUtf8 . T.intercalate "\n" $ + "import $foreign from \"./foreign.cjs\";" : + fmap (uncurry toLocalDeclaration) xs ++ + [ "export { " <> T.intercalate ", " (uncurry toNamedExport <$> xs) <> " };" + , "" + ] + toLocalDeclaration local exported = + "var " <> local <> " = $foreign." <> exported <> ";" + toNamedExport local exported + | local == exported = local + | otherwise = local <> " as " <> exported genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do @@ -303,18 +338,38 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = writeCacheDb :: CacheDb -> Make () writeCacheDb = writeCacheDb' outputDir + writePackageJson :: Make () + writePackageJson = writePackageJson' outputDir + +data ForeignModuleType = ESModule | CJSModule deriving (Show) + -- | Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module. -checkForeignDecls :: CF.Module ann -> FilePath -> Make () +checkForeignDecls :: CF.Module ann -> FilePath -> Make (ForeignModuleType, S.Set Ident) checkForeignDecls m path = do jsStr <- T.unpack <$> readTextFile path - js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path + js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parseModule jsStr path + + (foreignModuleType, foreignIdentsStrs) <- + case (,) <$> getForeignModuleExports js <*> getForeignModuleImports js of + Left reason -> errorParsingModule reason + Right (Bundle.ForeignModuleExports{..}, Bundle.ForeignModuleImports{..}) + | not (null cjsExports && null cjsImports) + , null esExports + , null esImports -> do + let deprecatedFFI = filter (elem '\'') cjsExports + unless (null deprecatedFFI) $ + errorDeprecatedForeignPrimes deprecatedFFI - foreignIdentsStrs <- either errorParsingModule pure $ getExps js + pure (CJSModule, cjsExports) + | otherwise -> do + unless (null cjsImports) $ + errorUnsupportedFFICommonJSImports cjsImports - let deprecatedFFI = filter (elem '\'') foreignIdentsStrs - unless (null deprecatedFFI) $ - warningDeprecatedForeignPrimes deprecatedFFI + unless (null cjsExports) $ + errorUnsupportedFFICommonJSExports cjsExports + + pure (ESModule, esExports) foreignIdents <- either errorInvalidForeignIdentifiers @@ -332,6 +387,7 @@ checkForeignDecls m path = do throwError . errorMessage' modSS . MissingFFIImplementations mname $ S.toList missingFFI + pure (foreignModuleType, foreignIdents) where mname = CF.moduleName m modSS = CF.moduleSourceSpan m @@ -339,16 +395,27 @@ checkForeignDecls m path = do errorParsingModule :: Bundle.ErrorMessage -> Make a errorParsingModule = throwError . errorMessage' modSS . ErrorParsingFFIModule path . Just - getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String] - getExps = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname)) + getForeignModuleExports :: JS.JSAST -> Either Bundle.ErrorMessage Bundle.ForeignModuleExports + getForeignModuleExports = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname)) + + getForeignModuleImports :: JS.JSAST -> Either Bundle.ErrorMessage Bundle.ForeignModuleImports + getForeignModuleImports = Bundle.getImportedModules (T.unpack (runModuleName mname)) errorInvalidForeignIdentifiers :: [String] -> Make a errorInvalidForeignIdentifiers = throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack) - warningDeprecatedForeignPrimes :: [String] -> Make () - warningDeprecatedForeignPrimes = - tell . mconcat . map (errorMessage' modSS . DeprecatedFFIPrime mname . T.pack) + errorDeprecatedForeignPrimes :: [String] -> Make a + errorDeprecatedForeignPrimes = + throwError . mconcat . map (errorMessage' modSS . DeprecatedFFIPrime mname . T.pack) + + errorUnsupportedFFICommonJSExports :: [String] -> Make a + errorUnsupportedFFICommonJSExports = + throwError . errorMessage' modSS . UnsupportedFFICommonJSExports mname . map T.pack + + errorUnsupportedFFICommonJSImports :: [String] -> Make a + errorUnsupportedFFICommonJSImports = + throwError . errorMessage' modSS . UnsupportedFFICommonJSImports mname . map T.pack parseIdents :: [String] -> Either [String] [Ident] parseIdents strs = diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs index 42712c6100..bff8f30d5a 100644 --- a/tests/TestBundle.hs +++ b/tests/TestBundle.hs @@ -7,6 +7,7 @@ import Prelude.Compat import qualified Language.PureScript as P import Language.PureScript.Bundle +import Language.PureScript.Interactive.IO (readNodeProcessWithExitCode) import Data.Function (on) import Data.List (minimumBy) @@ -16,7 +17,6 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except import System.Exit -import System.Process import System.FilePath import System.IO import System.IO.UTF8 @@ -51,9 +51,8 @@ assertBundles support inputFiles outputFile = do case result of Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do - process <- findNodeProcess - jsFiles <- Glob.globDir1 (Glob.compile "**/*.js") modulesDir - let entryPoint = modulesDir "index.js" + jsFiles <- concat <$> Glob.globDir [Glob.compile "*/*.js", Glob.compile "*/foreign.cjs"] modulesDir + let entryPoint = modulesDir "index.cjs" let entryModule = map (`ModuleIdentifier` Regular) ["Main"] bundled <- runExceptT $ do input <- forM jsFiles $ \filename -> do @@ -64,15 +63,15 @@ assertBundles support inputFiles outputFile = do case bundled of Right (_, js) -> do writeUTF8File entryPoint js - nodeResult <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process + nodeResult <- readNodeProcessWithExitCode Nothing [entryPoint] "" hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" case nodeResult of - Just (ExitSuccess, out, err) + Right (ExitSuccess, out, err) | not (null err) -> expectationFailure $ "Test wrote to stderr:\n\n" <> err | not (null out) && trim (last (lines out)) == "Done" -> hPutStr outputFile out | otherwise -> expectationFailure $ "Test did not finish with 'Done':\n\n" <> out - Just (ExitFailure _, _, err) -> expectationFailure err - Nothing -> expectationFailure "Couldn't find node.js executable" + Right (ExitFailure _, _, err) -> expectationFailure err + Left err -> expectationFailure err Left err -> expectationFailure $ "Could not bundle: " ++ show err logfile :: FilePath diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 3b06a66d2c..7d20c9bf0f 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -26,6 +26,7 @@ import Prelude () import Prelude.Compat import qualified Language.PureScript as P +import Language.PureScript.Interactive.IO (readNodeProcessWithExitCode) import Control.Arrow ((>>>)) import qualified Data.ByteString as BS @@ -39,7 +40,6 @@ import qualified Data.Text.Encoding as T import Control.Monad import System.Exit -import System.Process import System.FilePath import System.IO import System.IO.UTF8 (readUTF8File) @@ -139,18 +139,17 @@ assertCompiles support inputFiles outputFile = do case result of Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do - process <- findNodeProcess let entryPoint = modulesDir "index.js" - writeFile entryPoint "require('Main').main()" - nodeResult <- traverse (\node -> readProcessWithExitCode node [entryPoint] "") process + writeFile entryPoint "import('./Main/index.js').then(({ main }) => main());" + nodeResult <- readNodeProcessWithExitCode Nothing [entryPoint] "" hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" case nodeResult of - Just (ExitSuccess, out, err) + Right (ExitSuccess, out, err) | not (null err) -> expectationFailure $ "Test wrote to stderr:\n\n" <> err | not (null out) && trim (last (lines out)) == "Done" -> hPutStr outputFile out | otherwise -> expectationFailure $ "Test did not finish with 'Done':\n\n" <> out - Just (ExitFailure _, _, err) -> expectationFailure err - Nothing -> expectationFailure "Couldn't find node.js executable" + Right (ExitFailure _, _, err) -> expectationFailure err + Left err -> expectationFailure err assertCompilesWithWarnings :: SupportModules diff --git a/tests/TestMake.hs b/tests/TestMake.hs index 1d3268a95f..040b5a37e3 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -86,7 +86,7 @@ spec = do writeFileWithTimestamp modulePath timestampA moduleContent compile [modulePath] `shouldReturn` moduleNames ["Module"] - writeFileWithTimestamp moduleFFIPath timestampB "exports.bar = 1;\n" + writeFileWithTimestamp moduleFFIPath timestampB "export var bar = 1;\n" compile [modulePath] `shouldReturn` moduleNames ["Module"] it "recompiles if an FFI file was removed" $ do @@ -96,7 +96,7 @@ spec = do moduleContent = "module Module where\nfoo = 0\n" writeFileWithTimestamp modulePath timestampA moduleContent - writeFileWithTimestamp moduleFFIPath timestampB "exports.bar = 1;\n" + writeFileWithTimestamp moduleFFIPath timestampB "export var bar = 1;\n" compile [modulePath] `shouldReturn` moduleNames ["Module"] removeFile moduleFFIPath diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 5ac693aa1b..8b8d5d7eb7 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -17,7 +17,6 @@ import System.Directory (getCurrentDirectory, doesPathExist, removeFil import System.Exit import System.FilePath ((), pathSeparator) import qualified System.FilePath.Glob as Glob -import System.Process (readProcessWithExitCode) import Test.Hspec (shouldBe, Expectation) -- | A monad transformer for handle PSCi actions in tests @@ -55,13 +54,12 @@ execTestPSCi i = do -- command evaluation. jsEval :: TestPSCi String jsEval = liftIO $ do - writeFile indexFile "require('$PSCI')['$main']();" - process <- findNodeProcess - result <- traverse (\node -> readProcessWithExitCode node [indexFile] "") process + writeFile indexFile "import('./$PSCI/index.js').then(({ $main }) => $main());" + result <- readNodeProcessWithExitCode Nothing [indexFile] "" case result of - Just (ExitSuccess, out, _) -> return out - Just (ExitFailure _, _, err) -> putStrLn err >> exitFailure - Nothing -> putStrLn "Couldn't find node.js" >> exitFailure + Right (ExitSuccess, out, _) -> return out + Right (ExitFailure _, _, err) -> putStrLn err >> exitFailure + Left err -> putStrLn err >> exitFailure -- | Run a PSCi command and evaluate its outputs: -- * jsOutputEval is used to evaluate compiled JS output by PSCi diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index d14cd8d2a9..4db550f8d7 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -5,6 +5,7 @@ import Prelude.Compat import qualified Language.PureScript as P import qualified Language.PureScript.CST as CST +import Language.PureScript.Interactive.IO (findNodeProcess) import Control.Arrow ((***), (>>>)) import Control.Monad @@ -35,11 +36,6 @@ import qualified System.FilePath.Glob as Glob import System.IO import Test.Hspec -findNodeProcess :: IO (Maybe String) -findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names - where - names = ["nodejs", "node"] - -- | -- Fetches code necessary to run the tests with. The resulting support code -- should then be checked in, so that npm/bower etc is not required to run the @@ -75,15 +71,15 @@ updateSupportCode = withCurrentDirectory "tests/support" $ do heading "Updating support code" callCommand "npm install" -- bower uses shebang "/usr/bin/env node", but we might have nodejs - node <- maybe cannotFindNode pure =<< findNodeProcess + node <- either cannotFindNode pure =<< findNodeProcess -- Sometimes we run as a root (e.g. in simple docker containers) -- And we are non-interactive: https://github.com/bower/bower/issues/1162 callProcess node ["node_modules/bower/bin/bower", "--allow-root", "install", "--config.interactive=false"] writeFile lastUpdatedFile "" where - cannotFindNode :: IO a - cannotFindNode = do - hPutStrLn stderr "Cannot find node (or nodejs) executable" + cannotFindNode :: String -> IO a + cannotFindNode message = do + hPutStrLn stderr message exitFailure getModificationTimeMaybe :: FilePath -> IO (Maybe UTCTime) @@ -251,7 +247,7 @@ trim :: String -> String trim = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse modulesDir :: FilePath -modulesDir = ".test_modules" "node_modules" +modulesDir = ".test_modules" logpath :: FilePath logpath = "purescript-output" diff --git a/tests/purs/bundle/3551/ModuleWithDeadCode.js b/tests/purs/bundle/3551/ModuleWithDeadCode.js index ab7965286f..faa66d6178 100644 --- a/tests/purs/bundle/3551/ModuleWithDeadCode.js +++ b/tests/purs/bundle/3551/ModuleWithDeadCode.js @@ -1,10 +1,8 @@ -"use strict"; - -var fs = require('fs'); +import * as fs from 'fs'; var source = fs.readFileSync(__filename, 'utf-8'); -exports.results = { +export var results = { fooIsNotEliminated: /^ *var foo =/m.test(source), barIsExported: /^ *exports\["bar"\] =/m.test(source), barIsNotEliminated: /^ *var bar =/m.test(source), diff --git a/tests/purs/bundle/3727.js b/tests/purs/bundle/3727.js index 02e18d2982..d2148a0750 100644 --- a/tests/purs/bundle/3727.js +++ b/tests/purs/bundle/3727.js @@ -1,4 +1,2 @@ -'use strict'; - -exports.foo = 1; -exports.bar = exports.foo; +export var foo = 1; +export { foo as bar }; diff --git a/tests/purs/bundle/ObjectShorthand.js b/tests/purs/bundle/ObjectShorthand.js index 156ff0c9da..8ab71c994b 100644 --- a/tests/purs/bundle/ObjectShorthand.js +++ b/tests/purs/bundle/ObjectShorthand.js @@ -1,15 +1,13 @@ -"use strict"; +export var foo = 1; -var foo = 1; - -exports.bar = { foo }; +export var bar = { foo }; var baz = 2; -exports.quux = function(baz) { +export var quux = function(baz) { return { baz }; }; -var fs = require('fs'); +import * as fs from 'fs'; var source = fs.readFileSync(__filename, 'utf-8'); -exports.bazIsEliminated = !/^ *var baz =/m.test(source); +export var bazIsEliminated = !/^ *var baz =/m.test(source); diff --git a/tests/purs/warning/DeprecatedFFIPrime.js b/tests/purs/failing/DeprecatedFFIPrime.js similarity index 100% rename from tests/purs/warning/DeprecatedFFIPrime.js rename to tests/purs/failing/DeprecatedFFIPrime.js diff --git a/tests/purs/warning/DeprecatedFFIPrime.out b/tests/purs/failing/DeprecatedFFIPrime.out similarity index 51% rename from tests/purs/warning/DeprecatedFFIPrime.out rename to tests/purs/failing/DeprecatedFFIPrime.out index 94e1912e92..fd22d4708b 100644 --- a/tests/purs/warning/DeprecatedFFIPrime.out +++ b/tests/purs/failing/DeprecatedFFIPrime.out @@ -1,56 +1,56 @@ -Warning 1 of 4: +Error 1 of 4: - at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) + at tests/purs/failing/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) In the FFI module for Main: The identifier a' contains a prime ('). - Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future. + Primes are not allowed in identifiers exported from FFI modules. See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, - or to contribute content related to this warning. + or to contribute content related to this error. -Warning 2 of 4: +Error 2 of 4: - at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) + at tests/purs/failing/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) In the FFI module for Main: The identifier b' contains a prime ('). - Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future. + Primes are not allowed in identifiers exported from FFI modules. See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, - or to contribute content related to this warning. + or to contribute content related to this error. -Warning 3 of 4: +Error 3 of 4: - at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) + at tests/purs/failing/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) In the FFI module for Main: The identifier c' contains a prime ('). - Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future. + Primes are not allowed in identifiers exported from FFI modules. See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, - or to contribute content related to this warning. + or to contribute content related to this error. -Warning 4 of 4: +Error 4 of 4: - at tests/purs/warning/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) + at tests/purs/failing/DeprecatedFFIPrime.purs:5:1 - 10:28 (line 5, column 1 - line 10, column 28) In the FFI module for Main: The identifier d' contains a prime ('). - Primes in identifiers exported from FFI modules are deprecated and won’t be supported in the future. + Primes are not allowed in identifiers exported from FFI modules. See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFIPrime.md for more information, - or to contribute content related to this warning. + or to contribute content related to this error. diff --git a/tests/purs/failing/DeprecatedFFIPrime.purs b/tests/purs/failing/DeprecatedFFIPrime.purs new file mode 100644 index 0000000000..0100e1fad8 --- /dev/null +++ b/tests/purs/failing/DeprecatedFFIPrime.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith DeprecatedFFIPrime +-- @shouldFailWith DeprecatedFFIPrime +-- @shouldFailWith DeprecatedFFIPrime +-- @shouldFailWith DeprecatedFFIPrime +module Main where + +foreign import a' :: Number +foreign import b' :: Number +foreign import c' :: Number +foreign import d' :: Number diff --git a/tests/purs/failing/MissingFFIImplementations.js b/tests/purs/failing/MissingFFIImplementations.js index d29ee4cff9..ccb7243f7e 100644 --- a/tests/purs/failing/MissingFFIImplementations.js +++ b/tests/purs/failing/MissingFFIImplementations.js @@ -1 +1 @@ -exports.yes = true; +export var yes = true; diff --git a/tests/purs/failing/UnsupportedFFICommonJSExports1.js b/tests/purs/failing/UnsupportedFFICommonJSExports1.js new file mode 100644 index 0000000000..a74e1904db --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSExports1.js @@ -0,0 +1,2 @@ +export var yes = true; +exports.no = false; diff --git a/tests/purs/failing/UnsupportedFFICommonJSExports1.out b/tests/purs/failing/UnsupportedFFICommonJSExports1.out new file mode 100644 index 0000000000..d39cd8ad0b --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSExports1.out @@ -0,0 +1,12 @@ +Error found: +at tests/purs/failing/UnsupportedFFICommonJSExports1.purs:2:1 - 5:29 (line 2, column 1 - line 5, column 29) + + The following CommonJS exports are not supported in the ES foreign module for module Main: + + no + + + +See https://github.com/purescript/documentation/blob/master/errors/UnsupportedFFICommonJSExports.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnsupportedFFICommonJSExports1.purs b/tests/purs/failing/UnsupportedFFICommonJSExports1.purs new file mode 100644 index 0000000000..fc64c41988 --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSExports1.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith UnsupportedFFICommonJSExports +module Main where + +foreign import yes :: Boolean +foreign import no :: Boolean diff --git a/tests/purs/failing/UnsupportedFFICommonJSExports2.js b/tests/purs/failing/UnsupportedFFICommonJSExports2.js new file mode 100644 index 0000000000..10854c8a3b --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSExports2.js @@ -0,0 +1,4 @@ +import { yes, no } from "some ES module"; + +exports.yes = yes; +exports.no = no; diff --git a/tests/purs/failing/UnsupportedFFICommonJSExports2.out b/tests/purs/failing/UnsupportedFFICommonJSExports2.out new file mode 100644 index 0000000000..d06dad5f4d --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSExports2.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/UnsupportedFFICommonJSExports2.purs:2:1 - 5:29 (line 2, column 1 - line 5, column 29) + + The following CommonJS exports are not supported in the ES foreign module for module Main: + + yes + no + + + +See https://github.com/purescript/documentation/blob/master/errors/UnsupportedFFICommonJSExports.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnsupportedFFICommonJSExports2.purs b/tests/purs/failing/UnsupportedFFICommonJSExports2.purs new file mode 100644 index 0000000000..fc64c41988 --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSExports2.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith UnsupportedFFICommonJSExports +module Main where + +foreign import yes :: Boolean +foreign import no :: Boolean diff --git a/tests/purs/failing/UnsupportedFFICommonJSImports1.js b/tests/purs/failing/UnsupportedFFICommonJSImports1.js new file mode 100644 index 0000000000..c34d89c38c --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSImports1.js @@ -0,0 +1,4 @@ +var cjsImports = require("some CJS module"); + +export var yes = cjsImports.yes; +export var no = cjsImports.no; diff --git a/tests/purs/failing/UnsupportedFFICommonJSImports1.out b/tests/purs/failing/UnsupportedFFICommonJSImports1.out new file mode 100644 index 0000000000..59d0cf4351 --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSImports1.out @@ -0,0 +1,12 @@ +Error found: +at tests/purs/failing/UnsupportedFFICommonJSImports1.purs:2:1 - 5:29 (line 2, column 1 - line 5, column 29) + + The following CommonJS imports are not supported in the ES foreign module for module Main: + + some CJS module + + + +See https://github.com/purescript/documentation/blob/master/errors/UnsupportedFFICommonJSImports.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnsupportedFFICommonJSImports1.purs b/tests/purs/failing/UnsupportedFFICommonJSImports1.purs new file mode 100644 index 0000000000..85e64dc9f3 --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSImports1.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith UnsupportedFFICommonJSImports +module Main where + +foreign import yes :: Boolean +foreign import no :: Boolean diff --git a/tests/purs/failing/UnsupportedFFICommonJSImports2.js b/tests/purs/failing/UnsupportedFFICommonJSImports2.js new file mode 100644 index 0000000000..7d4b8973b5 --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSImports2.js @@ -0,0 +1,5 @@ +import { yes } from "some ES module"; +var cjsImports = require("some CJS module"); + +exports.yes = yes; +exports.no = cjsImports.no; diff --git a/tests/purs/failing/UnsupportedFFICommonJSImports2.out b/tests/purs/failing/UnsupportedFFICommonJSImports2.out new file mode 100644 index 0000000000..605a493420 --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSImports2.out @@ -0,0 +1,12 @@ +Error found: +at tests/purs/failing/UnsupportedFFICommonJSImports2.purs:2:1 - 5:29 (line 2, column 1 - line 5, column 29) + + The following CommonJS imports are not supported in the ES foreign module for module Main: + + some CJS module + + + +See https://github.com/purescript/documentation/blob/master/errors/UnsupportedFFICommonJSImports.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/UnsupportedFFICommonJSImports2.purs b/tests/purs/failing/UnsupportedFFICommonJSImports2.purs new file mode 100644 index 0000000000..85e64dc9f3 --- /dev/null +++ b/tests/purs/failing/UnsupportedFFICommonJSImports2.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith UnsupportedFFICommonJSImports +module Main where + +foreign import yes :: Boolean +foreign import no :: Boolean diff --git a/tests/purs/optimize/2866.out.js b/tests/purs/optimize/2866.out.js index a8f0d51269..f0854cce7d 100644 --- a/tests/purs/optimize/2866.out.js +++ b/tests/purs/optimize/2866.out.js @@ -1,15 +1,13 @@ - // Canonical test for #2866. This doesn't need to test whether `apply`s // defined from modules other than `Data.Function` are incorrectly // optimized since the rest of the test suite seemingly catches it. -"use strict"; var Area = function (x) { return x; }; var areaFlipped = 42; var area = 42; -module.exports = { - Area: Area, - area: area, - areaFlipped: areaFlipped +export { + Area, + area, + areaFlipped }; diff --git a/tests/purs/passing/EffFn.js b/tests/purs/passing/EffFn.js index b645b0527e..8360cbe7cd 100644 --- a/tests/purs/passing/EffFn.js +++ b/tests/purs/passing/EffFn.js @@ -1 +1 @@ -exports.add3 = function (a,b,c) { return a + b + c; }; \ No newline at end of file +export var add3 = function (a,b,c) { return a + b + c; }; diff --git a/tests/purs/passing/FFIDefaultCJSExport.js b/tests/purs/passing/FFIDefaultCJSExport.js new file mode 100644 index 0000000000..873a59a12b --- /dev/null +++ b/tests/purs/passing/FFIDefaultCJSExport.js @@ -0,0 +1 @@ +exports.default = "Done"; diff --git a/tests/purs/passing/FFIDefaultCJSExport.purs b/tests/purs/passing/FFIDefaultCJSExport.purs new file mode 100644 index 0000000000..1d084b6d8d --- /dev/null +++ b/tests/purs/passing/FFIDefaultCJSExport.purs @@ -0,0 +1,7 @@ +module Main where + +import Effect.Console (log) + +foreign import default :: String + +main = log default diff --git a/tests/purs/passing/FFIDefaultESExport.js b/tests/purs/passing/FFIDefaultESExport.js new file mode 100644 index 0000000000..ab294f31ea --- /dev/null +++ b/tests/purs/passing/FFIDefaultESExport.js @@ -0,0 +1,3 @@ +var message = "Done"; + +export { message as default }; diff --git a/tests/purs/passing/FFIDefaultESExport.purs b/tests/purs/passing/FFIDefaultESExport.purs new file mode 100644 index 0000000000..1d084b6d8d --- /dev/null +++ b/tests/purs/passing/FFIDefaultESExport.purs @@ -0,0 +1,7 @@ +module Main where + +import Effect.Console (log) + +foreign import default :: String + +main = log default diff --git a/tests/purs/passing/FunWithFunDeps.js b/tests/purs/passing/FunWithFunDeps.js index dea73d18fe..171f389176 100644 --- a/tests/purs/passing/FunWithFunDeps.js +++ b/tests/purs/passing/FunWithFunDeps.js @@ -1,15 +1,15 @@ //: forall e. FVect Z e -exports.fnil = []; +export var fnil = []; //: forall n e. e -> FVect n e -> FVect (S n) e -exports.fcons = function (hd) { +export var fcons = function (hd) { return function (tl) { return [hd].concat(tl); }; }; -exports.fappend = function (dict) { +export var fappend = function (dict) { return function (left) { return function (right) { return left.concat(right); @@ -17,7 +17,7 @@ exports.fappend = function (dict) { }; }; -exports.fflatten = function (dict) { +export var fflatten = function (dict) { return function (v) { var accRef = []; for (var indexRef = 0; indexRef < v.length; indexRef += 1) { @@ -27,6 +27,6 @@ exports.fflatten = function (dict) { }; }; -exports.ftoArray = function (vect) { +export var ftoArray = function (vect) { return vect; }; diff --git a/tests/purs/passing/PolyLabels.js b/tests/purs/passing/PolyLabels.js index b9900e4d3b..115375cd48 100644 --- a/tests/purs/passing/PolyLabels.js +++ b/tests/purs/passing/PolyLabels.js @@ -1,12 +1,10 @@ -"use strict"; - -exports.unsafeGet = function (s) { +export var unsafeGet = function (s) { return function (o) { return o[s]; }; }; -exports.unsafeSet = function(s) { +export var unsafeSet = function (s) { return function(a) { return function (o) { var o1 = {}; diff --git a/tests/purs/passing/ReExportsExported.js b/tests/purs/passing/ReExportsExported.js index b73154be1e..5ca086e78a 100644 --- a/tests/purs/passing/ReExportsExported.js +++ b/tests/purs/passing/ReExportsExported.js @@ -1,4 +1,2 @@ -"use strict"; - // Import `A.a` which was re-exported from `B` and then again from `C` -exports.a = require('../C').a; +export { a } from '../C/index.js'; diff --git a/tests/purs/passing/RowUnion.js b/tests/purs/passing/RowUnion.js index c002b18f57..4f037587a2 100644 --- a/tests/purs/passing/RowUnion.js +++ b/tests/purs/passing/RowUnion.js @@ -1,6 +1,4 @@ -"use strict"; - -exports.merge = function (dict) { +export var merge = function (dict) { return function (l) { return function (r) { var o = {}; diff --git a/tests/purs/warning/DeprecatedConstraintInForeignImport.js b/tests/purs/warning/DeprecatedConstraintInForeignImport.js index 3be8843e1f..8e629a2a03 100644 --- a/tests/purs/warning/DeprecatedConstraintInForeignImport.js +++ b/tests/purs/warning/DeprecatedConstraintInForeignImport.js @@ -1,4 +1,4 @@ -exports.show = function (showDict) { +export var show = function (showDict) { return function (a) { return showDict.show(a); }; diff --git a/tests/purs/warning/DeprecatedFFICommonJSModule.js b/tests/purs/warning/DeprecatedFFICommonJSModule.js new file mode 100644 index 0000000000..45e5121ffc --- /dev/null +++ b/tests/purs/warning/DeprecatedFFICommonJSModule.js @@ -0,0 +1,4 @@ +"use strict"; + +exports.yes = true; +exports.no = true; diff --git a/tests/purs/warning/DeprecatedFFICommonJSModule.out b/tests/purs/warning/DeprecatedFFICommonJSModule.out new file mode 100644 index 0000000000..38fb74714a --- /dev/null +++ b/tests/purs/warning/DeprecatedFFICommonJSModule.out @@ -0,0 +1,13 @@ +Warning found: +at tests/purs/warning/DeprecatedFFICommonJSModule.purs:2:1 - 5:29 (line 2, column 1 - line 5, column 29) + + A CommonJS foreign module implementation was provided for module Main: + + tests/purs/warning/DeprecatedFFICommonJSModule.js + + CommonJS foreign modules are deprecated and won't be supported in the future. + + +See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFICommonJSModule.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/DeprecatedFFICommonJSModule.purs b/tests/purs/warning/DeprecatedFFICommonJSModule.purs new file mode 100644 index 0000000000..b91bed426b --- /dev/null +++ b/tests/purs/warning/DeprecatedFFICommonJSModule.purs @@ -0,0 +1,5 @@ +-- @shouldWarnWith DeprecatedFFICommonJSModule +module Main where + +foreign import yes :: Boolean +foreign import no :: Boolean diff --git a/tests/purs/warning/DeprecatedFFIPrime.purs b/tests/purs/warning/DeprecatedFFIPrime.purs deleted file mode 100644 index 3c57a19d92..0000000000 --- a/tests/purs/warning/DeprecatedFFIPrime.purs +++ /dev/null @@ -1,10 +0,0 @@ --- @shouldWarnWith DeprecatedFFIPrime --- @shouldWarnWith DeprecatedFFIPrime --- @shouldWarnWith DeprecatedFFIPrime --- @shouldWarnWith DeprecatedFFIPrime -module Main where - -foreign import a' :: Number -foreign import b' :: Number -foreign import c' :: Number -foreign import d' :: Number diff --git a/tests/purs/warning/UnnecessaryFFIModule.js b/tests/purs/warning/UnnecessaryFFIModule.js index 346c8e9012..bd1835d69d 100644 --- a/tests/purs/warning/UnnecessaryFFIModule.js +++ b/tests/purs/warning/UnnecessaryFFIModule.js @@ -1 +1 @@ -exports.out = null; +export var out = null; diff --git a/tests/purs/warning/UnusedFFIImplementations.js b/tests/purs/warning/UnusedFFIImplementations.js index d50f2e60a8..78ab638547 100644 --- a/tests/purs/warning/UnusedFFIImplementations.js +++ b/tests/purs/warning/UnusedFFIImplementations.js @@ -1,2 +1,2 @@ -exports.yes = true; -exports.no = false; +export var yes = true; +export var no = false; diff --git a/tests/support/bower.json b/tests/support/bower.json index 704c043a21..667acb6679 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -1,38 +1,55 @@ { "name": "purescript-test-suite-support", "dependencies": { - "purescript-arrays": "6.0.0", + "purescript-arrays": "https://github.com/working-group-purescript-es/purescript-arrays.git#es-modules", "purescript-assert": "5.0.0", "purescript-bifunctors": "5.0.0", - "purescript-console": "5.0.0", - "purescript-control": "5.0.0", + "purescript-console": "https://github.com/working-group-purescript-es/purescript-console.git#es-modules", + "purescript-control": "https://github.com/working-group-purescript-es/purescript-control.git#es-modules", "purescript-distributive": "5.0.0", - "purescript-effect": "3.0.0", + "purescript-effect": "https://github.com/working-group-purescript-es/purescript-effect.git#es-modules", "purescript-either": "5.0.0", - "purescript-foldable-traversable": "5.0.0", - "purescript-functions": "5.0.0", + "purescript-foldable-traversable": "https://github.com/working-group-purescript-es/purescript-foldable-traversable.git#es-modules", + "purescript-functions": "https://github.com/working-group-purescript-es/purescript-functions.git#es-modules", "purescript-gen": "3.0.0", "purescript-identity": "5.0.0", - "purescript-integers": "5.0.0", + "purescript-integers": "https://github.com/working-group-purescript-es/purescript-integers.git#es-modules", "purescript-invariant": "5.0.0", - "purescript-lazy": "5.0.0", + "purescript-lazy": "https://github.com/working-group-purescript-es/purescript-lazy.git#es-modules", "purescript-lists": "6.0.0", - "purescript-math": "3.0.0", + "purescript-math": "https://github.com/working-group-purescript-es/purescript-math.git#es-modules", "purescript-maybe": "5.0.0", "purescript-newtype": "4.0.0", "purescript-nonempty": "6.0.0", - "purescript-partial": "3.0.0", - "purescript-prelude": "5.0.0", + "purescript-partial": "https://github.com/working-group-purescript-es/purescript-partial.git#es-modules", + "purescript-prelude": "https://github.com/working-group-purescript-es/purescript-prelude.git#es-modules", "purescript-psci-support": "5.0.0", - "purescript-refs": "5.0.0", + "purescript-refs": "https://github.com/working-group-purescript-es/purescript-refs.git#es-modules", "purescript-safe-coerce": "1.0.0", - "purescript-st": "5.0.0", - "purescript-strings": "5.0.0", + "purescript-st": "https://github.com/working-group-purescript-es/purescript-st.git#es-modules", + "purescript-strings": "https://github.com/working-group-purescript-es/purescript-strings.git#es-modules", "purescript-tailrec": "5.0.0", "purescript-tuples": "6.0.0", "purescript-type-equality": "4.0.0", "purescript-typelevel-prelude": "6.0.0", - "purescript-unfoldable": "5.0.0", - "purescript-unsafe-coerce": "5.0.0" + "purescript-unfoldable": "https://github.com/working-group-purescript-es/purescript-unfoldable.git#es-modules", + "purescript-unsafe-coerce": "https://github.com/working-group-purescript-es/purescript-unsafe-coerce.git#es-modules" + }, + "resolutions": { + "purescript-console": "es-modules", + "purescript-effect": "es-modules", + "purescript-control": "es-modules", + "purescript-foldable-traversable": "es-modules", + "purescript-functions": "es-modules", + "purescript-lazy": "es-modules", + "purescript-math": "es-modules", + "purescript-arrays": "es-modules", + "purescript-integers": "es-modules", + "purescript-partial": "es-modules", + "purescript-refs": "es-modules", + "purescript-st": "es-modules", + "purescript-unfoldable": "es-modules", + "purescript-prelude": "es-modules", + "purescript-unsafe-coerce": "es-modules" } -} +} \ No newline at end of file diff --git a/tests/support/pscide/src/RebuildSpecWithForeign.js b/tests/support/pscide/src/RebuildSpecWithForeign.js index 8ea453ff71..577e8a5d5d 100644 --- a/tests/support/pscide/src/RebuildSpecWithForeign.js +++ b/tests/support/pscide/src/RebuildSpecWithForeign.js @@ -1 +1 @@ -exports.f = 5; +export var f = 5; From a4375eb8deb3d2ca4f696ac4e22bbe6f508ced9f Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 26 Feb 2022 20:00:44 -0500 Subject: [PATCH 1415/1580] Improve apartness checking (#4149) This reverts commit 6b05869d3822e6c6d2a7ff03b94bf84144046211. --- .../breaking_improve-apartness-checking.md | 3 ++ src/Language/PureScript/Errors.hs | 21 +++++--- .../PureScript/TypeChecker/Entailment.hs | 53 ++++++++++++------- .../TypeChecker/Entailment/Coercible.hs | 2 +- tests/purs/failing/3329.out | 28 ++++++++++ tests/purs/failing/3329.purs | 24 +++++++++ tests/purs/failing/3531-2.out | 27 ++++++++++ tests/purs/failing/3531-2.purs | 23 ++++++++ tests/purs/failing/3531-3.out | 32 +++++++++++ tests/purs/failing/3531-3.purs | 23 ++++++++ tests/purs/failing/3531-4.out | 33 ++++++++++++ tests/purs/failing/3531-4.purs | 21 ++++++++ tests/purs/failing/3531-5.out | 32 +++++++++++ tests/purs/failing/3531-5.purs | 16 ++++++ tests/purs/failing/3531-6.out | 33 ++++++++++++ tests/purs/failing/3531-6.purs | 21 ++++++++ tests/purs/failing/3531.out | 27 ++++++++++ tests/purs/failing/3531.purs | 16 ++++++ tests/purs/failing/4028.out | 27 ++++++++++ tests/purs/failing/4028.purs | 29 ++++++++++ .../InstanceChainBothUnknownAndMatch.out | 4 ++ .../InstanceChainSkolemUnknownMatch.out | 4 ++ tests/purs/passing/3329.purs | 34 ++++++++++++ tests/purs/passing/3941.purs | 25 +++++++++ 24 files changed, 531 insertions(+), 27 deletions(-) create mode 100644 CHANGELOG.d/breaking_improve-apartness-checking.md create mode 100644 tests/purs/failing/3329.out create mode 100644 tests/purs/failing/3329.purs create mode 100644 tests/purs/failing/3531-2.out create mode 100644 tests/purs/failing/3531-2.purs create mode 100644 tests/purs/failing/3531-3.out create mode 100644 tests/purs/failing/3531-3.purs create mode 100644 tests/purs/failing/3531-4.out create mode 100644 tests/purs/failing/3531-4.purs create mode 100644 tests/purs/failing/3531-5.out create mode 100644 tests/purs/failing/3531-5.purs create mode 100644 tests/purs/failing/3531-6.out create mode 100644 tests/purs/failing/3531-6.purs create mode 100644 tests/purs/failing/3531.out create mode 100644 tests/purs/failing/3531.purs create mode 100644 tests/purs/failing/4028.out create mode 100644 tests/purs/failing/4028.purs create mode 100644 tests/purs/passing/3329.purs create mode 100644 tests/purs/passing/3941.purs diff --git a/CHANGELOG.d/breaking_improve-apartness-checking.md b/CHANGELOG.d/breaking_improve-apartness-checking.md new file mode 100644 index 0000000000..752e786336 --- /dev/null +++ b/CHANGELOG.d/breaking_improve-apartness-checking.md @@ -0,0 +1,3 @@ +* Improve apartness checking + + See details in https://github.com/purescript/documentation/blob/master/language/Type-Classes.md#instance-chains diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 1d6f56d295..4084070998 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -108,6 +108,7 @@ data SimpleErrorMessage | OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified (Either SourceType Ident)] | NoInstanceFound SourceConstraint -- ^ constraint that could not be solved + [Qualified (Either SourceType Ident)] -- ^ a list of instances that stopped further progress in instance chains due to ambiguity Bool -- ^ whether eliminating unknowns with annotations might help | AmbiguousTypeVariables SourceType [Int] | UnknownClass (Qualified (ProperName 'ClassName)) @@ -459,7 +460,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t - gSimple (NoInstanceFound con unks) = NoInstanceFound <$> overConstraintArgs (traverse f) con <*> pure unks + gSimple (NoInstanceFound con ambig unks) = NoInstanceFound <$> overConstraintArgs (traverse f) con <*> pure ambig <*> pure unks gSimple (AmbiguousTypeVariables t us) = AmbiguousTypeVariables <$> f t <*> pure us gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> traverse (traverse $ bitraverse f pure) insts gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts @@ -879,14 +880,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , markCodeBox $ indent $ line (showQualified runProperName nm) , line "because the class was not in scope. Perhaps it was not exported." ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Fail _ [ ty ] _) _) | Just box <- toTypelevelString ty = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Fail _ [ ty ] _) _ _) | Just box <- toTypelevelString ty = paras [ line "A custom type error occurred while solving type class constraints:" , indent box ] renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Partial _ _ - (Just (PartialConstraintData bs b))) _) = + (Just (PartialConstraintData bs b))) _ _) = paras [ line "A case expression could not be determined to cover all inputs." , line "The following additional cases are required to cover all inputs:" , indent $ paras $ @@ -895,18 +896,26 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl : [line "..." | not b] , line "Alternatively, add a Partial constraint to the type of the enclosing value." ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Discard _ [ty] _) _) = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Discard _ [ty] _) _ _) = paras [ line "A result of type" , markCodeBox $ indent $ prettyType ty , line "was implicitly discarded in a do notation block." , line ("You can use " <> markCode "_ <- ..." <> " to explicitly discard the result.") ] - renderSimpleErrorMessage (NoInstanceFound (Constraint _ nm _ ts _) unks) = + renderSimpleErrorMessage (NoInstanceFound (Constraint _ nm _ ts _) ambiguous unks) = paras [ line "No type class instance was found for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map prettyTypeAtom ts) ] + , paras $ let useMessage msg = + [ line msg + , indent $ paras (map prettyInstanceName ambiguous) + ] + in case ambiguous of + [] -> [] + [_] -> useMessage "The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered:" + _ -> useMessage "The following instances partially overlap the above constraint, which means the rest of their instance chains will not be considered:" , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation." | unks ] @@ -1666,7 +1675,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl where isUnifyHint ErrorUnifyingTypes{} = True isUnifyHint _ = False - stripRedundantHints (NoInstanceFound (Constraint _ C.Coercible _ args _) _) = filter (not . isSolverHint) + stripRedundantHints (NoInstanceFound (Constraint _ C.Coercible _ args _) _ _) = filter (not . isSolverHint) where isSolverHint (ErrorSolvingConstraint (Constraint _ C.Coercible _ args' _)) = args == args' isSolverHint _ = False diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 22df3f882e..5e265b4e9e 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -18,11 +18,12 @@ import Control.Monad.State import Control.Monad.Supply.Class (MonadSupply(..)) import Control.Monad.Writer +import Data.Either (lefts, partitionEithers) import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.Functor (($>)) -import Data.List (findIndices, minimumBy, groupBy, nubBy, sortOn, delete) -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.List (delete, findIndices, groupBy, minimumBy, nubBy, sortOn, tails) +import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S import Data.Traversable (for) @@ -230,22 +231,23 @@ entails SolverOptions{..} constraint context hints = dicts <- lift . lift $ forClassNameM env (combineContexts context inferred) className' kinds'' tys'' - let instances = do + let (catMaybes -> ambiguous, instances) = partitionEithers $ do chain <- groupBy ((==) `on` tcdChain) $ sortOn (tcdChain &&& tcdIndex) dicts -- process instances in a chain in index order - let found = for chain $ \tcd -> + let found = for (init $ tails chain) $ \(tcd:tl) -> -- Make sure the type unifies with the type in the type instance definition case matches typeClassDependencies tcd tys'' of - Apart -> Right () -- keep searching - Match substs -> Left (Just (substs, tcd)) -- found a match - Unknown -> Left Nothing -- can't continue with this chain yet, need proof of apartness - case found of - Right _ -> [] -- all apart - Left Nothing -> [] -- last unknown - Left (Just substsTcd) -> [substsTcd] -- found a match - solution <- lift . lift $ unique kinds'' tys'' instances (unknownsInAllCoveringSets tys'' typeClassCoveringSets) + Apart -> Right () -- keep searching + Match substs -> Left (Right (substs, tcd)) -- found a match + Unknown -> + if null (tcdChain tcd) || null tl + then Right () -- need proof of apartness but this is either not in a chain or at the end + else Left (Left (tcdToInstanceDescription tcd)) -- can't continue with this chain yet, need proof of apartness + + lefts [found] + solution <- lift . lift $ unique kinds'' tys'' ambiguous instances (unknownsInAllCoveringSets tys'' typeClassCoveringSets) case solution of Solved substs tcd -> do -- Note that we solved something. @@ -323,16 +325,16 @@ entails SolverOptions{..} constraint context hints = (substituteType currentSubst . replaceAllTypeVars (M.toList subst) $ instKind) (substituteType currentSubst tyKind) - unique :: [SourceType] -> [SourceType] -> [(a, TypeClassDict)] -> Bool -> m (EntailsResult a) - unique kindArgs tyArgs [] unks + unique :: [SourceType] -> [SourceType] -> [Qualified (Either SourceType Ident)] -> [(a, TypeClassDict)] -> Bool -> m (EntailsResult a) + unique kindArgs tyArgs ambiguous [] unks | solverDeferErrors = return Deferred -- We need a special case for nullary type classes, since we want -- to generalize over Partial constraints. | solverShouldGeneralize && ((null kindArgs && null tyArgs) || any canBeGeneralized kindArgs || any canBeGeneralized tyArgs) = return (Unsolved (srcConstraint className' kindArgs tyArgs conInfo)) - | otherwise = throwError . errorMessage $ NoInstanceFound (srcConstraint className' kindArgs tyArgs conInfo) unks - unique _ _ [(a, dict)] _ = return $ Solved a dict - unique _ tyArgs tcds _ + | otherwise = throwError . errorMessage $ NoInstanceFound (srcConstraint className' kindArgs tyArgs conInfo) ambiguous unks + unique _ _ _ [(a, dict)] _ = return $ Solved a dict + unique _ tyArgs _ tcds _ | pairwiseAny overlapping (map snd tcds) = throwError . errorMessage $ OverlappingInstances className' tyArgs (tcds >>= (toList . tcdToInstanceDescription . snd)) | otherwise = return $ uncurry Solved (minimumBy (compare `on` length . tcdPath . snd) tcds) @@ -663,6 +665,7 @@ matches deps TypeClassDictionaryInScope{..} tys = go (sd, r) ([], TypeVar _ v) = (Match (), M.singleton v [rowFromList (sd, r)]) go _ _ = (Apart, M.empty) typeHeadsAreEqual (TUnknown _ _) _ = (Unknown, M.empty) + typeHeadsAreEqual Skolem{} _ = (Unknown, M.empty) typeHeadsAreEqual _ _ = (Apart, M.empty) both :: (Matched (), Matching [Type a]) -> (Matched (), Matching [Type a]) -> (Matched (), Matching [Type a]) @@ -680,9 +683,11 @@ matches deps TypeClassDictionaryInScope{..} tys = typesAreEqual (KindedType _ t1 _) t2 = typesAreEqual t1 t2 typesAreEqual t1 (KindedType _ t2 _) = typesAreEqual t1 t2 typesAreEqual (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = Match () - typesAreEqual (Skolem _ _ _ s1 _) (Skolem _ _ _ s2 _) | s1 == s2 = Match () - typesAreEqual (Skolem _ _ _ _ _) _ = Unknown - typesAreEqual _ (Skolem _ _ _ _ _) = Unknown + typesAreEqual (TUnknown _ u1) t2 = if t2 `containsUnknown` u1 then Apart else Unknown + typesAreEqual t1 (TUnknown _ u2) = if t1 `containsUnknown` u2 then Apart else Unknown + typesAreEqual (Skolem _ _ _ s1 _) (Skolem _ _ _ s2 _) | s1 == s2 = Match () + typesAreEqual (Skolem _ _ _ s1 _) t2 = if t2 `containsSkolem` s1 then Apart else Unknown + typesAreEqual t1 (Skolem _ _ _ s2 _) = if t1 `containsSkolem` s2 then Apart else Unknown typesAreEqual (TypeVar _ v1) (TypeVar _ v2) | v1 == v2 = Match () typesAreEqual (TypeLevelString _ s1) (TypeLevelString _ s2) | s1 == s2 = Match () typesAreEqual (TypeConstructor _ c1) (TypeConstructor _ c2) | c1 == c2 = Match () @@ -698,6 +703,8 @@ matches deps TypeClassDictionaryInScope{..} tys = go (l, t1) (r, KindedType _ t2 _) = go (l, t1) (r, t2) go ([], KindApp _ t1 k1) ([], KindApp _ t2 k2) = typesAreEqual t1 t2 <> typesAreEqual k1 k2 go ([], TUnknown _ u1) ([], TUnknown _ u2) | u1 == u2 = Match () + go ([], TUnknown _ _) ([], _) = Unknown + go ([], _) ([], TUnknown _ _) = Unknown go ([], Skolem _ _ _ s1 _) ([], Skolem _ _ _ s2 _) | s1 == s2 = Match () go ([], Skolem _ _ _ _ _) _ = Unknown go _ ([], Skolem _ _ _ _ _) = Unknown @@ -710,6 +717,12 @@ matches deps TypeClassDictionaryInScope{..} tys = isRCons RCons{} = True isRCons _ = False + containsSkolem :: Type a -> Int -> Bool + containsSkolem t s = everythingOnTypes (||) (\case Skolem _ _ _ s' _ -> s == s'; _ -> False) t + + containsUnknown :: Type a -> Int -> Bool + containsUnknown t u = everythingOnTypes (||) (\case TUnknown _ u' -> u == u'; _ -> False) t + -- | Add a dictionary for the constraint to the scope, and dictionaries -- for all implied superclass instances. newDictionaries diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 1eed5d6c50..bb16e25b62 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -527,7 +527,7 @@ insoluble -> SourceType -> MultipleErrors insoluble k a b = - errorMessage $ NoInstanceFound (srcConstraint Prim.Coercible [k] [a, b] Nothing) (any containsUnknowns [a, b]) + errorMessage $ NoInstanceFound (srcConstraint Prim.Coercible [k] [a, b] Nothing) [] (any containsUnknowns [a, b]) -- | Constraints of the form @Coercible a b@ can be solved if the two arguments -- are the same. Since we currently don't support higher-rank arguments in diff --git a/tests/purs/failing/3329.out b/tests/purs/failing/3329.out new file mode 100644 index 0000000000..ce9bbe6c77 --- /dev/null +++ b/tests/purs/failing/3329.out @@ -0,0 +1,28 @@ +Error found: +in module Main +at tests/purs/failing/3329.purs:24:8 - 24:11 (line 24, column 8 - line 24, column 11) + + No type class instance was found for +   +  Main.Inject g0  +  (Either f1 g0) +   + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + Main.injectLeft + + +while checking that type forall (f :: Type) (g :: Type). Inject f g => f -> g + is at least as general as type g0 -> Either f1 g0 +while checking that expression inj + has type g0 -> Either f1 g0 +in value declaration injR + +where f1 is a rigid type variable + bound at (line 24, column 8 - line 24, column 11) + g0 is a rigid type variable + bound at (line 24, column 8 - line 24, column 11) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3329.purs b/tests/purs/failing/3329.purs new file mode 100644 index 0000000000..7beb876929 --- /dev/null +++ b/tests/purs/failing/3329.purs @@ -0,0 +1,24 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Data.Either (Either(..)) +import Data.Maybe (Maybe(..)) + +class Inject f g where + inj :: f -> g + prj :: g -> Maybe f + +instance injectRefl :: Inject x x where + inj x = x + prj x = Just x +else instance injectLeft :: Inject l (Either l r) where + inj x = Left x + prj (Left x) = Just x + prj _ = Nothing +else instance injectRight :: Inject x r => Inject x (Either l r) where + inj x = Right (inj x) + prj (Right x) = prj x + prj _ = Nothing + +injR :: forall f g. g -> Either f g +injR = inj diff --git a/tests/purs/failing/3531-2.out b/tests/purs/failing/3531-2.out new file mode 100644 index 0000000000..dcb39d4592 --- /dev/null +++ b/tests/purs/failing/3531-2.out @@ -0,0 +1,27 @@ +Error found: +in module Main +at tests/purs/failing/3531-2.purs:22:11 - 22:22 (line 22, column 11 - line 22, column 22) + + No type class instance was found for +   +  Main.C (X t2 Int) +   + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + Main.cx + + The instance head contains unknown type variables. Consider adding a type annotation. + +while applying a function thing + of type C t0 => t0 -> t0 + to argument test1 +while inferring the type of thing test1 +in value declaration test2 + +where t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3531-2.purs b/tests/purs/failing/3531-2.purs new file mode 100644 index 0000000000..ed20e5f1cc --- /dev/null +++ b/tests/purs/failing/3531-2.purs @@ -0,0 +1,23 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Prim.TypeError (class Fail, Text) + +class C x where + thing :: x -> x + +data X a b = X + +test1 :: forall a. X a Int +test1 = X + +instance cx :: C (X x x) where + thing x = x + +else instance cxFail :: Fail (Text "Fell through") => C (X x y) where + thing x = x + +test2 :: Boolean +test2 = do + let X = thing test1 + true diff --git a/tests/purs/failing/3531-3.out b/tests/purs/failing/3531-3.out new file mode 100644 index 0000000000..8f52a662cc --- /dev/null +++ b/tests/purs/failing/3531-3.out @@ -0,0 +1,32 @@ +Error found: +in module Main +at tests/purs/failing/3531-3.purs:22:11 - 22:22 (line 22, column 11 - line 22, column 22) + + No type class instance was found for +   +  Main.C (X  +  { foo :: Int +  | t1  +  }  +  { foo :: Int +  }  +  )  +   + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + Main.cx + + The instance head contains unknown type variables. Consider adding a type annotation. + +while applying a function thing + of type C t0 => t0 -> t0 + to argument test1 +while inferring the type of thing test1 +in value declaration test2 + +where t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3531-3.purs b/tests/purs/failing/3531-3.purs new file mode 100644 index 0000000000..5d3704101c --- /dev/null +++ b/tests/purs/failing/3531-3.purs @@ -0,0 +1,23 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Prim.TypeError (class Fail, Text) + +class C x where + thing :: x -> x + +data X a b = X + +test1 :: forall r. X { foo :: Int | r } { foo :: Int } +test1 = X + +instance cx :: C (X x x) where + thing x = x + +else instance cxFail :: Fail (Text "Fell through") => C (X x y) where + thing x = x + +test2 :: Boolean +test2 = do + let X = thing test1 + true diff --git a/tests/purs/failing/3531-4.out b/tests/purs/failing/3531-4.out new file mode 100644 index 0000000000..04b5b756d5 --- /dev/null +++ b/tests/purs/failing/3531-4.out @@ -0,0 +1,33 @@ +Error found: +in module Main +at tests/purs/failing/3531-4.purs:21:7 - 21:27 (line 21, column 7 - line 21, column 27) + + No type class instance was found for +   +  Main.C a4 +  b5 +   + The following instances partially overlap the above constraint, which means the rest of their instance chains will not be considered: + + Main.c1 + Main.c3 + + +while applying a function c + of type C @t0 @t1 t2 t3 => Proxy @t0 t2 -> Proxy @t1 t3 -> Boolean + to argument Proxy +while inferring the type of c Proxy +in value declaration fn + +where a4 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + b5 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + t3 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3531-4.purs b/tests/purs/failing/3531-4.purs new file mode 100644 index 0000000000..46c73fd52e --- /dev/null +++ b/tests/purs/failing/3531-4.purs @@ -0,0 +1,21 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +data Proxy a = Proxy + +class C a b where + c :: Proxy a -> Proxy b -> Boolean + +instance c1 :: C String String where + c _ _ = true +else instance c2 :: C String a where + c _ _ = false + +instance c3 :: C Int Int where + c _ _ = true +else instance c4 :: C Int a where + c _ _ = false + +fn :: forall a b. Proxy a -> Proxy b -> Int +fn _ _ = 42 where + x = c (Proxy :: Proxy a) (Proxy :: Proxy b) diff --git a/tests/purs/failing/3531-5.out b/tests/purs/failing/3531-5.out new file mode 100644 index 0000000000..f82fb0d6a1 --- /dev/null +++ b/tests/purs/failing/3531-5.out @@ -0,0 +1,32 @@ +Error found: +in module Main +at tests/purs/failing/3531-5.purs:16:7 - 16:27 (line 16, column 7 - line 16, column 27) + + No type class instance was found for +   +  Main.C a4 +  b5 +   + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + instance in module Main with type forall a. C String (Array a) (line 9, column 1 - line 10, column 15) + + +while applying a function c + of type C @t0 @t1 t2 t3 => Proxy @t0 t2 -> Proxy @t1 t3 -> Boolean + to argument Proxy +while inferring the type of c Proxy +in value declaration fn + +where a4 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + b5 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + t3 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3531-5.purs b/tests/purs/failing/3531-5.purs new file mode 100644 index 0000000000..5c19ed374e --- /dev/null +++ b/tests/purs/failing/3531-5.purs @@ -0,0 +1,16 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +data Proxy a = Proxy + +class C a b where + c :: Proxy a -> Proxy b -> Boolean + +instance C String (Array a) where + c _ _ = true +else instance c2 :: C String a where + c _ _ = false + +fn :: forall a b. Proxy a -> Proxy b -> Int +fn _ _ = 42 where + x = c (Proxy :: Proxy a) (Proxy :: Proxy b) diff --git a/tests/purs/failing/3531-6.out b/tests/purs/failing/3531-6.out new file mode 100644 index 0000000000..f454d0679e --- /dev/null +++ b/tests/purs/failing/3531-6.out @@ -0,0 +1,33 @@ +Error found: +in module Main +at tests/purs/failing/3531-6.purs:21:7 - 21:27 (line 21, column 7 - line 21, column 27) + + No type class instance was found for +   +  Main.C a4 +  b5 +   + The following instances partially overlap the above constraint, which means the rest of their instance chains will not be considered: + + instance in module Main with type forall a. C String (Array a) (line 9, column 1 - line 10, column 15) + instance in module Main with type C Int Int (line 14, column 1 - line 15, column 15) + + +while applying a function c + of type C @t0 @t1 t2 t3 => Proxy @t0 t2 -> Proxy @t1 t3 -> Boolean + to argument Proxy +while inferring the type of c Proxy +in value declaration fn + +where a4 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + b5 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + t3 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3531-6.purs b/tests/purs/failing/3531-6.purs new file mode 100644 index 0000000000..204ef158a1 --- /dev/null +++ b/tests/purs/failing/3531-6.purs @@ -0,0 +1,21 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +data Proxy a = Proxy + +class C a b where + c :: Proxy a -> Proxy b -> Boolean + +instance C String (Array a) where + c _ _ = true +else instance c2 :: C String a where + c _ _ = false + +instance C Int Int where + c _ _ = true +else instance c4 :: C Int a where + c _ _ = false + +fn :: forall a b. Proxy a -> Proxy b -> Int +fn _ _ = 42 where + x = c (Proxy :: Proxy a) (Proxy :: Proxy b) diff --git a/tests/purs/failing/3531.out b/tests/purs/failing/3531.out new file mode 100644 index 0000000000..71e3f55972 --- /dev/null +++ b/tests/purs/failing/3531.out @@ -0,0 +1,27 @@ +Error found: +in module Main +at tests/purs/failing/3531.purs:16:7 - 16:27 (line 16, column 7 - line 16, column 27) + + No type class instance was found for +   +  Main.C a2 +   + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + Main.c1 + + +while applying a function c + of type C @t0 t1 => Proxy @t0 t1 -> Boolean + to argument Proxy +while inferring the type of c Proxy +in value declaration fn + +where a2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3531.purs b/tests/purs/failing/3531.purs new file mode 100644 index 0000000000..b7d28a2c96 --- /dev/null +++ b/tests/purs/failing/3531.purs @@ -0,0 +1,16 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +data Proxy a = Proxy + +class C a where + c :: Proxy a -> Boolean + +instance c1 :: C String where + c _ = true +else instance c2 :: C a where + c _ = false + +fn :: forall a. Proxy a -> Int +fn _ = 42 where + x = c (Proxy :: Proxy a) diff --git a/tests/purs/failing/4028.out b/tests/purs/failing/4028.out new file mode 100644 index 0000000000..477c18364a --- /dev/null +++ b/tests/purs/failing/4028.out @@ -0,0 +1,27 @@ +Error found: +in module Main +at tests/purs/failing/4028.purs:29:12 - 29:37 (line 29, column 12 - line 29, column 37) + + No type class instance was found for +   +  Main.TLShow (S i2) +   + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + Main.tlShow2 + + +while applying a function go + of type TLShow @t0 t1 => Proxy @t0 t1 -> Int -> String + to argument Proxy +while inferring the type of go Proxy +in value declaration peano + +where i2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4028.purs b/tests/purs/failing/4028.purs new file mode 100644 index 0000000000..590d85d42b --- /dev/null +++ b/tests/purs/failing/4028.purs @@ -0,0 +1,29 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Prelude + +import Type.Proxy (Proxy(..)) + +foreign import data Peano :: Type + +foreign import data Z :: Peano +foreign import data S :: Peano -> Peano + +class TLShow :: forall k. k -> Constraint +class TLShow i where + tlShow :: Proxy i -> String + +instance tlShow2 :: TLShow (S (S Z)) where + tlShow _ = "2" +else instance tlShow0 :: TLShow Z where + tlShow _ = "0" +else instance tlShowS :: TLShow x => TLShow (S x) where + tlShow _ = "S" <> tlShow (Proxy :: Proxy x) + +peano :: Int -> String +peano = go (Proxy :: Proxy Z) + where + go :: forall i. TLShow i => Proxy i -> Int -> String + go p 0 = tlShow p + go _ n = go (Proxy :: Proxy (S i)) (n - 1) diff --git a/tests/purs/failing/InstanceChainBothUnknownAndMatch.out b/tests/purs/failing/InstanceChainBothUnknownAndMatch.out index 153cfa51a9..f08c540f40 100644 --- a/tests/purs/failing/InstanceChainBothUnknownAndMatch.out +++ b/tests/purs/failing/InstanceChainBothUnknownAndMatch.out @@ -16,6 +16,10 @@ at tests/purs/failing/InstanceChainBothUnknownAndMatch.purs:17:13 - 17:55 (line  )   t4    + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + InstanceChains.BothUnknownAndMatch.sameY + while applying a function same of type Same @Type @Type t0 t1 t2 => t0 -> t1 -> SProxy t2 diff --git a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out index 7bb44148c0..fa66f419ef 100644 --- a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out +++ b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out @@ -8,6 +8,10 @@ at tests/purs/failing/InstanceChainSkolemUnknownMatch.purs:14:13 - 14:36 (line 1  (Proxy Int)  t4    + The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered: + + InstanceChainSkolemUnknownMatch.sameY + while applying a function same of type Same @Type @Type t0 t1 t2 => t0 -> t1 -> SProxy t2 diff --git a/tests/purs/passing/3329.purs b/tests/purs/passing/3329.purs new file mode 100644 index 0000000000..5d531182d5 --- /dev/null +++ b/tests/purs/passing/3329.purs @@ -0,0 +1,34 @@ +module Main where + +import Prelude + +import Data.Either (Either(..)) +import Data.Maybe (Maybe(..)) +import Effect (Effect) +import Effect.Console (log) + +class Inject f g where + inj :: f -> g + prj :: g -> Maybe f + +instance injectRefl :: Inject x x where + inj x = x + prj x = Just x +else instance injectLeft :: Inject l (Either l r) where + inj x = Left x + prj (Left x) = Just x + prj _ = Nothing +else instance injectRight :: Inject x r => Inject x (Either l r) where + inj x = Right (inj x) + prj (Right x) = prj x + prj _ = Nothing + +injL :: forall f g. f -> Either f g +injL = inj + +main :: Effect Unit +main = log "Done" + where + testInjLWithUnknowns a = case inj a of + Left a' -> a' + Right _ -> a diff --git a/tests/purs/passing/3941.purs b/tests/purs/passing/3941.purs new file mode 100644 index 0000000000..321ccedacb --- /dev/null +++ b/tests/purs/passing/3941.purs @@ -0,0 +1,25 @@ +module Main where + +import Effect.Console (log) +import Unsafe.Coerce (unsafeCoerce) + +class TwoParams a b where + func :: a -> b + +instance equals :: TwoParams a a where + func a = a +else +instance any :: TwoParams a b where + func = unsafeCoerce + +testEquals :: forall a. a -> a +testEquals = func -- with instance `equals` +testAny :: Int -> Boolean +testAny = func -- with instance `any` + +-- `a` and `m a` are never unifiable unless we have infinite types (and of course not) +-- so expected that the instance `any` is chosen. +thisShouldBeCompiled :: forall m a. a -> m a +thisShouldBeCompiled = func + +main = log "Done" From 6620b4e075569991c987c1fb89b91e2d104420e7 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sat, 26 Feb 2022 19:24:01 -0600 Subject: [PATCH 1416/1580] Doc HSPEC_ACCEPT; verify `Main` module exists in PS tests (#4243) * Add note about HSPEC_ACCEPT env * Verify that PS file's module name is 'Main' * Add changelog entry * Verify test fails if module name isn't `Main` * Do Main module name check on passing/bundle tests * Fix logic bug * Drop unneeded T.pack * Fix typo Co-authored-by: Ryan Hendrickson * Remove 'NotNamedMain.purs' Co-authored-by: Ryan Hendrickson --- CHANGELOG.d/internal_document-hspec-accept.md | 1 + .../internal_error-on-non-Main-modules.md | 1 + CONTRIBUTING.md | 2 ++ tests/TestBundle.hs | 2 +- tests/TestCompiler.hs | 8 +++--- tests/TestUtils.hs | 26 +++++++++++++++---- 6 files changed, 30 insertions(+), 10 deletions(-) create mode 100644 CHANGELOG.d/internal_document-hspec-accept.md create mode 100644 CHANGELOG.d/internal_error-on-non-Main-modules.md diff --git a/CHANGELOG.d/internal_document-hspec-accept.md b/CHANGELOG.d/internal_document-hspec-accept.md new file mode 100644 index 0000000000..7c90c240fc --- /dev/null +++ b/CHANGELOG.d/internal_document-hspec-accept.md @@ -0,0 +1 @@ +* Document the `HSPEC_ACCEPT` flag for generating golden files \ No newline at end of file diff --git a/CHANGELOG.d/internal_error-on-non-Main-modules.md b/CHANGELOG.d/internal_error-on-non-Main-modules.md new file mode 100644 index 0000000000..78c52eaf86 --- /dev/null +++ b/CHANGELOG.d/internal_error-on-non-Main-modules.md @@ -0,0 +1 @@ +* Fail test if PureScript file(s) don't have a `Main` module \ No newline at end of file diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 99dc4ac2b6..f896f83d41 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -41,6 +41,8 @@ stack test --fast --test-arguments="--match 1110.purs" This will run whatever test uses the example file `1110.purs`. +The golden files (e.g. `*.out` files) are generated automatically when missing, and can be updated by setting the "HSPEC_ACCEPT" environment variable, e.g. by running `HSPEC_ACCEPT=true stack test`. + ### Adding Dependencies Because the PureScript compiler is distributed in binary form, we include the licenses of all dependencies, including transitive ones, in the LICENSE file. Therefore, whenever the dependencies change, the LICENSE file should be updated. diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs index bff8f30d5a..df766fa3b3 100644 --- a/tests/TestBundle.hs +++ b/tests/TestBundle.hs @@ -47,7 +47,7 @@ assertBundles -> Handle -> Expectation assertBundles support inputFiles outputFile = do - (result, _) <- compile support inputFiles + (result, _) <- compile True support inputFiles case result of Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 7d20c9bf0f..8402a08951 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -135,7 +135,7 @@ assertCompiles -> Handle -> Expectation assertCompiles support inputFiles outputFile = do - (result, _) <- compile support inputFiles + (result, _) <- compile True support inputFiles case result of Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do @@ -157,7 +157,7 @@ assertCompilesWithWarnings -> [String] -> Expectation assertCompilesWithWarnings support inputFiles shouldWarnWith = do - result'@(result, warnings) <- compile support inputFiles + result'@(result, warnings) <- compile False support inputFiles case result of Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs @@ -173,7 +173,7 @@ assertDoesNotCompile -> [String] -> Expectation assertDoesNotCompile support inputFiles shouldFailWith = do - result <- compile support inputFiles + result <- compile False support inputFiles case fst result of Left errs -> do when (null shouldFailWith) @@ -193,7 +193,7 @@ assertCompilesToExpectedOutput -> [FilePath] -> Expectation assertCompilesToExpectedOutput support inputFiles = do - (result, _) <- compile support inputFiles + (result, _) <- compile False support inputFiles case result of Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 4db550f8d7..5c66efe20a 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -5,6 +5,8 @@ import Prelude.Compat import qualified Language.PureScript as P import qualified Language.PureScript.CST as CST +import qualified Language.PureScript.AST as AST +import qualified Language.PureScript.Names as N import Language.PureScript.Interactive.IO (findNodeProcess) import Control.Arrow ((***), (>>>)) @@ -195,20 +197,34 @@ getTestFiles testDir = do else dir compile - :: SupportModules + :: Bool + -> SupportModules -> [FilePath] -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) -compile SupportModules{..} inputFiles = runTest $ do +compile checkForMainModule SupportModules{..} inputFiles = runTest $ do -- Sorting the input files makes some messages (e.g., duplicate module) deterministic fs <- liftIO $ readInput (sort inputFiles) msWithWarnings <- CST.parseFromFiles id fs tell $ foldMap (\(fp, (ws, _)) -> CST.toMultipleWarnings fp ws) msWithWarnings let ms = fmap snd <$> msWithWarnings foreigns <- inferForeignModules ms - let actions = makeActions supportModules (foreigns `M.union` supportForeigns) + let + actions = makeActions supportModules (foreigns `M.union` supportForeigns) + hasMainModule = (==) 1 $ length $ filter (== "Main") $ fmap getPsModuleName ms case ms of - [singleModule] -> pure <$> P.rebuildModule actions supportExterns (snd singleModule) - _ -> P.make actions (CST.pureResult <$> supportModules ++ map snd ms) + [singleModule] -> do + when (checkForMainModule && not hasMainModule) $ do + error $ "When testing a single PureScript file, the file's module's name must be 'Main' but got '" + <> T.unpack (getPsModuleName singleModule) <> "'." + pure <$> P.rebuildModule actions supportExterns (snd singleModule) + _ -> do + when (checkForMainModule && not hasMainModule) $ do + error "When testing multiple PureScript files, the main file's module's name must be 'Main'." + P.make actions (CST.pureResult <$> supportModules ++ map snd ms) + +getPsModuleName :: (a, AST.Module) -> T.Text +getPsModuleName psModule = case snd psModule of + AST.Module _ _ (N.ModuleName t) _ _ -> t makeActions :: [P.Module] -> M.Map P.ModuleName FilePath -> P.MakeActions P.Make makeActions modules foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False) From 010a2d613a9bd3c0f3cc387a2d2bc36ce0842517 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sat, 26 Feb 2022 19:57:10 -0600 Subject: [PATCH 1417/1580] Disable constraints in FFI (#4240) * Error when constraints are found in FFI values For example... ``` foreign import foo :: forall a. Show a => a -> String ``` Constraints are not allowed because one can implicitly rely upon the dictionary's representation at runtime. * Add test for FFI constraint workaround In other words, type class dictionary members (e.g. `show` below) must be passed explicitly into the FFI function for one to use them in FFI. ``` foreign import fooImpl :: forall a. (a -> String) -> a -> String foo :: forall a. Show a => a -> String foo a = fooImpl show a ``` Note: this test may break if we change the Show instances for any of the used types in `purescript-prelude`. * Rename test files to drop 'Deprecated' * Add changelog entry --- .../breaking_disable-constraints-in-ffi.md | 23 +++++++++++++++++++ .../src/Language/PureScript/CST/Errors.hs | 6 ++--- .../src/Language/PureScript/CST/Parser.y | 2 +- src/Language/PureScript/Errors.hs | 1 - .../ConstraintInForeignImport.js} | 0 .../failing/ConstraintInForeignImport.out | 10 ++++++++ .../ConstraintInForeignImport.purs} | 2 +- tests/purs/passing/FFIConstraintWorkaround.js | 7 ++++++ .../purs/passing/FFIConstraintWorkaround.purs | 22 ++++++++++++++++++ tests/purs/passing/FunWithFunDeps.js | 22 ++++++++---------- tests/purs/passing/FunWithFunDeps.purs | 8 +++++-- tests/purs/passing/RowUnion.js | 10 ++++---- tests/purs/passing/RowUnion.purs | 9 +++++++- .../DeprecatedConstraintInForeignImport.out | 9 -------- 14 files changed, 94 insertions(+), 37 deletions(-) create mode 100644 CHANGELOG.d/breaking_disable-constraints-in-ffi.md rename tests/purs/{warning/DeprecatedConstraintInForeignImport.js => failing/ConstraintInForeignImport.js} (100%) create mode 100644 tests/purs/failing/ConstraintInForeignImport.out rename tests/purs/{warning/DeprecatedConstraintInForeignImport.purs => failing/ConstraintInForeignImport.purs} (71%) create mode 100644 tests/purs/passing/FFIConstraintWorkaround.js create mode 100644 tests/purs/passing/FFIConstraintWorkaround.purs delete mode 100644 tests/purs/warning/DeprecatedConstraintInForeignImport.out diff --git a/CHANGELOG.d/breaking_disable-constraints-in-ffi.md b/CHANGELOG.d/breaking_disable-constraints-in-ffi.md new file mode 100644 index 0000000000..b0c08e45f2 --- /dev/null +++ b/CHANGELOG.d/breaking_disable-constraints-in-ffi.md @@ -0,0 +1,23 @@ +* Disable type class constraints in FFI + + Previously, one could write FFI like the following: + ```purescript + foreign import foo :: forall a. Show a => a -> String + ``` + + Type class dictionaries are "magically" handled by the compiler. + By including them in the above FFI, one can depend on their representation. + Since the representation can change without notice, this may silently break + code. + + In `v0.14.x`, a warning was emitted if these were used. Now it will fail + to compile. Rather, one should write something like the following + where the members of the type class are passed explicitly to + the FFI function as arguments: + + ```purescript + foo :: forall a. Show a => a -> String + foo val = fooImpl show val + + foreign import fooImpl :: forall a. (a -> String) -> a -> String + ``` diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs b/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs index 4e7db9dfa8..89fa5a96e1 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs @@ -53,6 +53,7 @@ data ParserErrorType | ErrQualifiedName | ErrEmptyDo | ErrLexeme (Maybe String) [String] + | ErrConstraintInForeignImportSyntax | ErrEof | ErrCustom String deriving (Show, Eq, Ord) @@ -60,7 +61,6 @@ data ParserErrorType data ParserWarningType = WarnDeprecatedRowSyntax | WarnDeprecatedForeignKindSyntax - | WarnDeprecatedConstraintInForeignImportSyntax | WarnDeprecatedKindImportSyntax | WarnDeprecatedKindExportSyntax deriving (Show, Eq, Ord) @@ -157,6 +157,8 @@ prettyPrintErrorMessage ParserErrorInfo {..} = case errType of "Expected do statement" ErrLexeme _ _ -> basicError + ErrConstraintInForeignImportSyntax -> + "Constraints are not allowed in foreign imports. Omit the constraint instead and update the foreign module accordingly." ErrToken | SourceToken _ (TokLeftArrow _) : _ <- errToks -> "Unexpected \"<-\" in expression, perhaps due to a missing 'do' or 'ado' keyword" @@ -187,8 +189,6 @@ prettyPrintWarningMessage ParserErrorInfo {..} = case errType of "Unary '#' syntax for row kinds is deprecated and will be removed in a future release. Use the 'Row' kind instead." WarnDeprecatedForeignKindSyntax -> "Foreign kind imports are deprecated and will be removed in a future release. Use empty 'data' instead." - WarnDeprecatedConstraintInForeignImportSyntax -> - "Constraints are deprecated in foreign imports and will be removed in a future release. Omit the constraint instead and update the foreign module accordingly." WarnDeprecatedKindImportSyntax -> "Kind imports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead." WarnDeprecatedKindExportSyntax -> diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y index cbc6ba4056..07500d9ba1 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y +++ b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y @@ -676,7 +676,7 @@ decl :: { Declaration () } | ident '::' type { DeclSignature () (Labeled $1 $2 $3) } | ident manyOrEmpty(binderAtom) guardedDecl { DeclValue () (ValueBindingFields $1 $2 $3) } | fixity { DeclFixity () $1 } - | 'foreign' 'import' ident '::' type {% when (isConstrained $5) (addWarning ([$1, $2, nameTok $3, $4] <> toList (flattenType $5)) WarnDeprecatedConstraintInForeignImportSyntax) *> pure (DeclForeign () $1 $2 (ForeignValue (Labeled $3 $4 $5))) } + | 'foreign' 'import' ident '::' type {% when (isConstrained $5) (addFailure ([$1, $2, nameTok $3, $4] <> toList (flattenType $5)) ErrConstraintInForeignImportSyntax) *> pure (DeclForeign () $1 $2 (ForeignValue (Labeled $3 $4 $5))) } | 'foreign' 'import' 'data' properName '::' type { DeclForeign () $1 $2 (ForeignData $3 (Labeled (getProperName $4) $5 $6)) } | 'foreign' 'import' 'kind' properName {% addWarning [$1, $2, $3, nameTok (getProperName $4)] WarnDeprecatedForeignKindSyntax *> pure (DeclForeign () $1 $2 (ForeignKind $3 (getProperName $4))) } | 'type' 'role' properName many(role) { DeclRole () $1 $2 (getProperName $3) $4 } diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 4084070998..351388e7bb 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -520,7 +520,6 @@ errorSuggestion err = | otherwise = "Row " <> kind suggest sugg CST.WarnDeprecatedForeignKindSyntax -> suggest $ "data " <> CST.printTokens (drop 3 toks) - CST.WarnDeprecatedConstraintInForeignImportSyntax -> Nothing CST.WarnDeprecatedKindImportSyntax -> suggest $ CST.printTokens $ drop 1 toks CST.WarnDeprecatedKindExportSyntax -> suggest $ CST.printTokens $ drop 1 toks _ -> Nothing diff --git a/tests/purs/warning/DeprecatedConstraintInForeignImport.js b/tests/purs/failing/ConstraintInForeignImport.js similarity index 100% rename from tests/purs/warning/DeprecatedConstraintInForeignImport.js rename to tests/purs/failing/ConstraintInForeignImport.js diff --git a/tests/purs/failing/ConstraintInForeignImport.out b/tests/purs/failing/ConstraintInForeignImport.out new file mode 100644 index 0000000000..f50837b3a1 --- /dev/null +++ b/tests/purs/failing/ConstraintInForeignImport.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/ConstraintInForeignImport.purs:6:1 - 6:50 (line 6, column 1 - line 6, column 50) + + Unable to parse module: + Constraints are not allowed in foreign imports. Omit the constraint instead and update the foreign module accordingly. + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/DeprecatedConstraintInForeignImport.purs b/tests/purs/failing/ConstraintInForeignImport.purs similarity index 71% rename from tests/purs/warning/DeprecatedConstraintInForeignImport.purs rename to tests/purs/failing/ConstraintInForeignImport.purs index 19028028bd..81677f8bb5 100644 --- a/tests/purs/warning/DeprecatedConstraintInForeignImport.purs +++ b/tests/purs/failing/ConstraintInForeignImport.purs @@ -1,4 +1,4 @@ --- @shouldWarnWith WarningParsingModule +-- @shouldFailWith ErrorParsingModule module Main where import Data.Show (class Show) diff --git a/tests/purs/passing/FFIConstraintWorkaround.js b/tests/purs/passing/FFIConstraintWorkaround.js new file mode 100644 index 0000000000..6df6f54f48 --- /dev/null +++ b/tests/purs/passing/FFIConstraintWorkaround.js @@ -0,0 +1,7 @@ +"use strict"; + +exports.showImpl = function (showFn) { + return function (val) { + return showFn(val); + }; +}; diff --git a/tests/purs/passing/FFIConstraintWorkaround.purs b/tests/purs/passing/FFIConstraintWorkaround.purs new file mode 100644 index 0000000000..54b7d3fe2e --- /dev/null +++ b/tests/purs/passing/FFIConstraintWorkaround.purs @@ -0,0 +1,22 @@ +module Main where + +import Prelude +import Effect +import Effect.Console +import Test.Assert + +main :: Effect Unit +main = do + assert' "Showing Int is correct" $ showFFI 4 == "4" + assert' "Showing String is correct" $ showFFI "string" == "\"string\"" + assert' "Showing Record is correct" $ + showFFI { a: 1, b: true, c: 'd', e: 4.0 } == "{ a: 1, b: true, c: 'd', e: 4.0 }" + log "Done" + +showFFI :: forall a. Show a => a -> String +showFFI = showImpl show + +-- Since type class constraints are not allowed +-- in FFI declarations, we have to pass members +-- we want to use into the function itself. +foreign import showImpl :: forall a. (a -> String) -> a -> String diff --git a/tests/purs/passing/FunWithFunDeps.js b/tests/purs/passing/FunWithFunDeps.js index 171f389176..322903a11b 100644 --- a/tests/purs/passing/FunWithFunDeps.js +++ b/tests/purs/passing/FunWithFunDeps.js @@ -9,22 +9,18 @@ export var fcons = function (hd) { }; }; -export var fappend = function (dict) { - return function (left) { - return function (right) { - return left.concat(right); - }; +export var fappendImpl = function (left) { + return function (right) { + return left.concat(right); }; }; -export var fflatten = function (dict) { - return function (v) { - var accRef = []; - for (var indexRef = 0; indexRef < v.length; indexRef += 1) { - accRef = accRef.concat(v[indexRef]); - } - return accRef; - }; +export var fflattenImpl = function (v) { + var accRef = []; + for (var indexRef = 0; indexRef < v.length; indexRef += 1) { + accRef = accRef.concat(v[indexRef]); + } + return accRef; }; export var ftoArray = function (vect) { diff --git a/tests/purs/passing/FunWithFunDeps.purs b/tests/purs/passing/FunWithFunDeps.purs index 9b9a99145d..7a3e90eff9 100644 --- a/tests/purs/passing/FunWithFunDeps.purs +++ b/tests/purs/passing/FunWithFunDeps.purs @@ -26,8 +26,12 @@ instance natMultS :: (NatMult m n r, NatPlus n r s) => NatMult (S m) n s foreign import data FVect :: Type -> Type -> Type foreign import fnil :: forall e. FVect Z e foreign import fcons :: forall n e. e -> FVect n e -> FVect (S n) e -foreign import fappend :: forall l r o e. NatPlus l r o => FVect l e -> FVect r e -> FVect o e -foreign import fflatten :: forall f s t o. NatMult f s o => FVect f (FVect s t) -> FVect o t +fappend :: forall l r o e. NatPlus l r o => FVect l e -> FVect r e -> FVect o e +fappend = fappendImpl +foreign import fappendImpl :: forall l r o e. FVect l e -> FVect r e -> FVect o e +fflatten :: forall f s t o. NatMult f s o => FVect f (FVect s t) -> FVect o t +fflatten = fflattenImpl +foreign import fflattenImpl :: forall f s t o. FVect f (FVect s t) -> FVect o t foreign import ftoArray :: forall n e. FVect n e -> Array e -- should be able to figure these out diff --git a/tests/purs/passing/RowUnion.js b/tests/purs/passing/RowUnion.js index 4f037587a2..17697d3263 100644 --- a/tests/purs/passing/RowUnion.js +++ b/tests/purs/passing/RowUnion.js @@ -1,8 +1,6 @@ -export var merge = function (dict) { - return function (l) { - return function (r) { - var o = {}; - return Object.assign(o, r, l); - }; +export var mergeImpl = function (l) { + return function (r) { + var o = {}; + return Object.assign(o, r, l); }; }; diff --git a/tests/purs/passing/RowUnion.purs b/tests/purs/passing/RowUnion.purs index ca443299f6..182b9d1bf8 100644 --- a/tests/purs/passing/RowUnion.purs +++ b/tests/purs/passing/RowUnion.purs @@ -19,12 +19,19 @@ solveUnionBackwardsCons = solve (Proxy :: Proxy ( a :: Int )) (Proxy :: Proxy ( solveUnionBackwardsDblCons :: Proxy _ solveUnionBackwardsDblCons = solve (Proxy :: Proxy ( a :: Int, a :: String )) (Proxy :: Proxy ( a :: Boolean, a :: Int, a :: String )) -foreign import merge +merge :: forall r1 r2 r3 . Union r1 r2 r3 => Record r1 -> Record r2 -> Record r3 +merge = mergeImpl + +foreign import mergeImpl + :: forall r1 r2 r3 + . Record r1 + -> Record r2 + -> Record r3 test1 = merge { x: 1 } { y: true } diff --git a/tests/purs/warning/DeprecatedConstraintInForeignImport.out b/tests/purs/warning/DeprecatedConstraintInForeignImport.out deleted file mode 100644 index 428c49e87c..0000000000 --- a/tests/purs/warning/DeprecatedConstraintInForeignImport.out +++ /dev/null @@ -1,9 +0,0 @@ -Warning found: -at tests/purs/warning/DeprecatedConstraintInForeignImport.purs:6:1 - 6:50 (line 6, column 1 - line 6, column 50) - - Constraints are deprecated in foreign imports and will be removed in a future release. Omit the constraint instead and update the foreign module accordingly. - - -See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, -or to contribute content related to this warning. - From 4c4fcf67f493c2f0119fa212e968c88979c8fc31 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sat, 26 Feb 2022 20:01:27 -0600 Subject: [PATCH 1418/1580] Remove deprecated syntax: '#' and 'kind' (#4239) * Remove deprecated syntax for row kinds: `#` These have been replaced with the `Row` kind in the `Prim` module ``` -- Before data Foo (a :: # Type) = Foo -- After data Foo (a :: Row Type) = Foo ``` * Remove deprecated kind syntax Before: ``` module Foo (kind MyKind) where import Bar (kind AnotherKind) foreign import data MyKind :: Type foreign import data MyCtor :: MyKind ``` After: ``` module Foo (MyKind) where import Bar (AnotherKind) data MyKind :: Type foreign import data MyCtor :: MyKind ``` * Update tests: use `Proxy` for proxy types rather than kind-specific Proxy types * Fix last shift-reduce conflicts Co-authored-by: Ryan Hendrickson * Add changelog entry --- ...ing_drop-deprecated-row-and-kind-syntax.md | 1 + .../src/Language/PureScript/CST/Convert.hs | 4 --- .../src/Language/PureScript/CST/Flatten.hs | 2 -- .../src/Language/PureScript/CST/Parser.y | 20 ++----------- .../src/Language/PureScript/CST/Positions.hs | 2 -- .../src/Language/PureScript/CST/Types.hs | 2 -- tests/purs/docs/src/PrimSubmodules.purs | 2 +- .../purs/failing/DiffKindsSameName/LibA.purs | 2 +- .../purs/failing/DiffKindsSameName/LibB.purs | 2 +- tests/purs/failing/DuplicateProperties.purs | 2 +- tests/purs/failing/LacksWithSubGoal.purs | 2 +- tests/purs/failing/TransitiveKindExport.purs | 2 +- tests/purs/passing/3114.purs | 13 ++++---- tests/purs/passing/3114/VendoredVariant.purs | 8 ++--- tests/purs/passing/DuplicateProperties.purs | 19 +++++------- tests/purs/passing/ForeignKind.purs | 2 +- tests/purs/passing/ForeignKind/Lib.purs | 4 +-- tests/purs/passing/RowUnion.purs | 2 +- tests/purs/passing/SolvingCompareSymbol.purs | 2 +- .../warning/DeprecatedForeignImportKind.out | 9 ------ .../warning/DeprecatedForeignImportKind.purs | 4 --- .../warning/DeprecatedImportExportKinds.out | 30 ------------------- .../warning/DeprecatedImportExportKinds.purs | 8 ----- .../DeprecatedImportExportKinds/Lib.purs | 5 ---- .../purs/warning/DeprecatedRowKindSyntax.out | 9 ------ .../purs/warning/DeprecatedRowKindSyntax.purs | 4 --- 26 files changed, 34 insertions(+), 128 deletions(-) create mode 100644 CHANGELOG.d/breaking_drop-deprecated-row-and-kind-syntax.md delete mode 100644 tests/purs/warning/DeprecatedForeignImportKind.out delete mode 100644 tests/purs/warning/DeprecatedForeignImportKind.purs delete mode 100644 tests/purs/warning/DeprecatedImportExportKinds.out delete mode 100644 tests/purs/warning/DeprecatedImportExportKinds.purs delete mode 100644 tests/purs/warning/DeprecatedImportExportKinds/Lib.purs delete mode 100644 tests/purs/warning/DeprecatedRowKindSyntax.out delete mode 100644 tests/purs/warning/DeprecatedRowKindSyntax.purs diff --git a/CHANGELOG.d/breaking_drop-deprecated-row-and-kind-syntax.md b/CHANGELOG.d/breaking_drop-deprecated-row-and-kind-syntax.md new file mode 100644 index 0000000000..1ec461f99f --- /dev/null +++ b/CHANGELOG.d/breaking_drop-deprecated-row-and-kind-syntax.md @@ -0,0 +1 @@ +* Removes deprecated syntax for rows (i.e. `#`) and kinds (i.e. `kind`-keyword) \ No newline at end of file diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs index 5ad703e002..46994f017c 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs @@ -645,8 +645,6 @@ convertImport fileName imp = case imp of AST.TypeOpRef ann $ nameValue a ImportClass _ _ a -> AST.TypeClassRef ann $ nameValue a - ImportKind _ _ a -> - AST.TypeRef ann (nameValue a) (Just []) where ann = sourceSpan fileName . toSourceRange $ importRange imp @@ -669,8 +667,6 @@ convertExport fileName export = case export of AST.TypeOpRef ann $ nameValue a ExportClass _ _ a -> AST.TypeClassRef ann $ nameValue a - ExportKind _ _ a -> - AST.TypeRef ann (nameValue a) Nothing ExportModule _ _ a -> AST.ModuleRef ann (nameValue a) where diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs b/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs index 8d90614fb3..c643f60904 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs @@ -237,7 +237,6 @@ flattenExport = \case ExportType _ n dms -> flattenName n <> foldMap flattenDataMembers dms ExportTypeOp _ t n -> pure t <> flattenName n ExportClass _ t n -> pure t <> flattenName n - ExportKind _ t n -> pure t <> flattenName n ExportModule _ t n -> pure t <> flattenName n flattenDataMembers :: DataMembers a -> DList SourceToken @@ -260,7 +259,6 @@ flattenImport = \case ImportType _ n dms -> flattenName n <> foldMap flattenDataMembers dms ImportTypeOp _ t n -> pure t <> flattenName n ImportClass _ t n -> pure t <> flattenName n - ImportKind _ t n -> pure t <> flattenName n flattenWrapped :: (a -> DList SourceToken) -> Wrapped a -> DList SourceToken flattenWrapped k (Wrapped a b c) = pure a <> k b <> pure c diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y index 07500d9ba1..d1f6d77711 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y +++ b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y @@ -90,7 +90,6 @@ import Language.PureScript.PSString (PSString) '\\' { SourceToken _ TokBackslash } '-' { SourceToken _ (TokOperator [] "-") } '@' { SourceToken _ (TokOperator [] "@") } - '#' { SourceToken _ (TokOperator [] "#") } 'ado' { SourceToken _ (TokLowerName _ "ado") } 'as' { SourceToken _ (TokLowerName [] "as") } 'case' { SourceToken _ (TokLowerName [] "case") } @@ -111,7 +110,6 @@ import Language.PureScript.PSString (PSString) 'infixl' { SourceToken _ (TokLowerName [] "infixl") } 'infixr' { SourceToken _ (TokLowerName [] "infixr") } 'instance' { SourceToken _ (TokLowerName [] "instance") } - 'kind' { SourceToken _ (TokLowerName [] "kind") } 'let' { SourceToken _ (TokLowerName [] "let") } 'module' { SourceToken _ (TokLowerName [] "module") } 'newtype' { SourceToken _ (TokLowerName [] "newtype") } @@ -192,7 +190,6 @@ qualIdent :: { QualifiedName Ident } | QUAL_LOWER {% toQualifiedName Ident $1 } | 'as' {% toQualifiedName Ident $1 } | 'hiding' {% toQualifiedName Ident $1 } - | 'kind' {% toQualifiedName Ident $1 } | 'role' {% toQualifiedName Ident $1 } | 'nominal' {% toQualifiedName Ident $1 } | 'representational' {% toQualifiedName Ident $1 } @@ -202,7 +199,6 @@ ident :: { Name Ident } : LOWER {% toName Ident $1 } | 'as' {% toName Ident $1 } | 'hiding' {% toName Ident $1 } - | 'kind' {% toName Ident $1 } | 'role' {% toName Ident $1 } | 'nominal' {% toName Ident $1 } | 'representational' {% toName Ident $1 } @@ -213,14 +209,12 @@ qualOp :: { QualifiedOpName } | QUAL_OPERATOR {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } | '<=' {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } | '-' {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } - | '#' {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } | ':' {% qualifiedOpName <\$> toQualifiedName N.OpName $1 } op :: { OpName } : OPERATOR {% opName <\$> toName N.OpName $1 } | '<=' {% opName <\$> toName N.OpName $1 } | '-' {% opName <\$> toName N.OpName $1 } - | '#' {% opName <\$> toName N.OpName $1 } | ':' {% opName <\$> toName N.OpName $1 } qualSymbol :: { QualifiedOpName } @@ -255,7 +249,6 @@ label :: { Label } | 'infixl' { toLabel $1 } | 'infixr' { toLabel $1 } | 'instance' { toLabel $1 } - | 'kind' { toLabel $1 } | 'let' { toLabel $1 } | 'module' { toLabel $1 } | 'newtype' { toLabel $1 } @@ -304,16 +297,12 @@ type2 :: { Type () } | type3 '=>' type1 {% do cs <- toConstraint $1; pure $ TypeConstrained () cs $2 $3 } type3 :: { Type () } - : type4 { $1 } - | type3 qualOp type4 { TypeOp () $1 (getQualifiedOpName $2) $3 } + : type4 %shift { $1 } + | type3 qualOp type4 %shift { TypeOp () $1 (getQualifiedOpName $2) $3 } type4 :: { Type () } - : type5 %shift { $1 } - | '#' type4 {% addWarning ($1 : toList (flattenType $2)) WarnDeprecatedRowSyntax *> pure (TypeUnaryRow () $1 $2) } - -type5 :: { Type () } : typeAtom { $1 } - | type5 typeAtom { TypeApp () $1 $2 } + | type4 typeAtom { TypeApp () $1 $2 } typeAtom :: { Type ()} : '_' { TypeWildcard () $1 } @@ -633,7 +622,6 @@ export :: { Export () } | properName dataMembers { ExportType () (getProperName $1) (Just $2) } | 'type' symbol { ExportTypeOp () $1 (getOpName $2) } | 'class' properName { ExportClass () $1 (getProperName $2) } - | 'kind' properName {% addWarning [$1, nameTok (getProperName $2)] WarnDeprecatedKindExportSyntax *> pure (ExportKind () $1 (getProperName $2)) } | 'module' moduleName { ExportModule () $1 $2 } dataMembers :: { (DataMembers ()) } @@ -657,7 +645,6 @@ import :: { Import () } | properName dataMembers { ImportType () (getProperName $1) (Just $2) } | 'type' symbol { ImportTypeOp () $1 (getOpName $2) } | 'class' properName { ImportClass () $1 (getProperName $2) } - | 'kind' properName {% addWarning [$1, nameTok (getProperName $2)] WarnDeprecatedKindImportSyntax *> pure (ImportKind () $1 (getProperName $2)) } decl :: { Declaration () } : dataHead { DeclData () $1 Nothing } @@ -678,7 +665,6 @@ decl :: { Declaration () } | fixity { DeclFixity () $1 } | 'foreign' 'import' ident '::' type {% when (isConstrained $5) (addFailure ([$1, $2, nameTok $3, $4] <> toList (flattenType $5)) ErrConstraintInForeignImportSyntax) *> pure (DeclForeign () $1 $2 (ForeignValue (Labeled $3 $4 $5))) } | 'foreign' 'import' 'data' properName '::' type { DeclForeign () $1 $2 (ForeignData $3 (Labeled (getProperName $4) $5 $6)) } - | 'foreign' 'import' 'kind' properName {% addWarning [$1, $2, $3, nameTok (getProperName $4)] WarnDeprecatedForeignKindSyntax *> pure (DeclForeign () $1 $2 (ForeignKind $3 (getProperName $4))) } | 'type' 'role' properName many(role) { DeclRole () $1 $2 (getProperName $3) $4 } dataHead :: { DataHead () } diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs index ba76ad7374..41d1756f4c 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs @@ -133,7 +133,6 @@ exportRange = \case | otherwise -> nameRange a ExportTypeOp _ a b -> (a, nameTok b) ExportClass _ a b -> (a, nameTok b) - ExportKind _ a b -> (a, nameTok b) ExportModule _ a b -> (a, nameTok b) importDeclRange :: ImportDecl a -> TokenRange @@ -151,7 +150,6 @@ importRange = \case | otherwise -> nameRange a ImportTypeOp _ a b -> (a, nameTok b) ImportClass _ a b -> (a, nameTok b) - ImportKind _ a b -> (a, nameTok b) dataMembersRange :: DataMembers a -> TokenRange dataMembersRange = \case diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Types.hs b/lib/purescript-cst/src/Language/PureScript/CST/Types.hs index 7f5844cca9..ef3ebf153f 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Types.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Types.hs @@ -183,7 +183,6 @@ data Export a | ExportType a (Name (N.ProperName 'N.TypeName)) (Maybe (DataMembers a)) | ExportTypeOp a SourceToken (Name (N.OpName 'N.TypeOpName)) | ExportClass a SourceToken (Name (N.ProperName 'N.ClassName)) - | ExportKind a SourceToken (Name (N.ProperName 'N.TypeName)) | ExportModule a SourceToken (Name N.ModuleName) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) @@ -231,7 +230,6 @@ data Import a | ImportType a (Name (N.ProperName 'N.TypeName)) (Maybe (DataMembers a)) | ImportTypeOp a SourceToken (Name (N.OpName 'N.TypeOpName)) | ImportClass a SourceToken (Name (N.ProperName 'N.ClassName)) - | ImportKind a SourceToken (Name (N.ProperName 'N.TypeName)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) data DataHead a = DataHead diff --git a/tests/purs/docs/src/PrimSubmodules.purs b/tests/purs/docs/src/PrimSubmodules.purs index ee3c4fdec0..2b34bc231e 100644 --- a/tests/purs/docs/src/PrimSubmodules.purs +++ b/tests/purs/docs/src/PrimSubmodules.purs @@ -1,6 +1,6 @@ module PrimSubmodules (Lol(..), x, y, module O) where -import Prim.Ordering (kind Ordering, LT, EQ, GT) as O +import Prim.Ordering (Ordering, LT, EQ, GT) as O data Lol (a :: O.Ordering) = Lol Int diff --git a/tests/purs/failing/DiffKindsSameName/LibA.purs b/tests/purs/failing/DiffKindsSameName/LibA.purs index d36b2ec15b..a87a610c0b 100644 --- a/tests/purs/failing/DiffKindsSameName/LibA.purs +++ b/tests/purs/failing/DiffKindsSameName/LibA.purs @@ -1,4 +1,4 @@ module DiffKindsSameName.LibA where -foreign import kind DemoKind +data DemoKind diff --git a/tests/purs/failing/DiffKindsSameName/LibB.purs b/tests/purs/failing/DiffKindsSameName/LibB.purs index 52bcb0f42b..9bfeddeb50 100644 --- a/tests/purs/failing/DiffKindsSameName/LibB.purs +++ b/tests/purs/failing/DiffKindsSameName/LibB.purs @@ -1,6 +1,6 @@ module DiffKindsSameName.LibB where -foreign import kind DemoKind +data DemoKind foreign import data DemoData :: DemoKind diff --git a/tests/purs/failing/DuplicateProperties.purs b/tests/purs/failing/DuplicateProperties.purs index 6349b30356..32c1552a7d 100644 --- a/tests/purs/failing/DuplicateProperties.purs +++ b/tests/purs/failing/DuplicateProperties.purs @@ -3,7 +3,7 @@ module DuplicateProperties where import Prelude -foreign import data Test :: # Type -> Type +foreign import data Test :: Row Type -> Type foreign import subtractX :: forall r. Test (x :: Unit | r) -> Test r diff --git a/tests/purs/failing/LacksWithSubGoal.purs b/tests/purs/failing/LacksWithSubGoal.purs index 40db3afd4f..4e5428234d 100644 --- a/tests/purs/failing/LacksWithSubGoal.purs +++ b/tests/purs/failing/LacksWithSubGoal.purs @@ -5,7 +5,7 @@ import Prim.Row (class Lacks) data S (r :: Symbol) = S -data R (r :: # Type) = R +data R (r :: Row Type) = R union :: forall s r. Lacks s r => S s -> R r union S = R diff --git a/tests/purs/failing/TransitiveKindExport.purs b/tests/purs/failing/TransitiveKindExport.purs index 7aba655967..f1d0c47a86 100644 --- a/tests/purs/failing/TransitiveKindExport.purs +++ b/tests/purs/failing/TransitiveKindExport.purs @@ -1,6 +1,6 @@ -- @shouldFailWith TransitiveExportError module Main (TestProxy(..)) where -foreign import kind Test +data Test data TestProxy (p :: Test) = TestProxy diff --git a/tests/purs/passing/3114.purs b/tests/purs/passing/3114.purs index 5d9d2af4c8..f49e7e6a39 100644 --- a/tests/purs/passing/3114.purs +++ b/tests/purs/passing/3114.purs @@ -9,17 +9,18 @@ import Effect import Effect.Console (log) import VendoredVariant import Data.Symbol +import Type.Proxy (Proxy(..)) type TestVariants = - ( foo :: FProxy Maybe - , bar :: FProxy (Tuple String) + ( foo :: Proxy Maybe + , bar :: Proxy (Tuple String) ) -_foo :: SProxy "foo" -_foo = SProxy +_foo :: Proxy "foo" +_foo = Proxy -_bar :: SProxy "bar" -_bar = SProxy +_bar :: Proxy "bar" +_bar = Proxy main :: Effect Unit main = do diff --git a/tests/purs/passing/3114/VendoredVariant.purs b/tests/purs/passing/3114/VendoredVariant.purs index 2442e99a96..7582bc5933 100644 --- a/tests/purs/passing/3114/VendoredVariant.purs +++ b/tests/purs/passing/3114/VendoredVariant.purs @@ -7,9 +7,9 @@ import Prim.Row as Row import Unsafe.Coerce (unsafeCoerce) import Partial.Unsafe (unsafeCrashWith) import Data.Symbol +import Type.Proxy (Proxy(..)) -data FProxy (k :: Type -> Type) = FProxy -data VariantF (f :: # Type) a +data VariantF (f :: Row Type) a newtype VariantFRep f a = VariantFRep { type :: String @@ -23,9 +23,9 @@ case_ r = unsafeCrashWith case unsafeCoerce r of on :: forall sym f a b r1 r2 - . Row.Cons sym (FProxy f) r1 r2 + . Row.Cons sym (Proxy f) r1 r2 => IsSymbol sym - => SProxy sym + => Proxy sym -> (f a -> b) -> (VariantF r1 a -> b) -> VariantF r2 a diff --git a/tests/purs/passing/DuplicateProperties.purs b/tests/purs/passing/DuplicateProperties.purs index 238a9f221b..d98d14be54 100644 --- a/tests/purs/passing/DuplicateProperties.purs +++ b/tests/purs/passing/DuplicateProperties.purs @@ -2,25 +2,22 @@ module Main where import Prelude import Effect.Console (log) +import Type.Proxy (Proxy(..)) -data RProxy (r :: # Type) = RProxy +subtractX :: forall r a. Proxy (x :: a | r) -> Proxy r +subtractX Proxy = Proxy -data Proxy (a :: Type) = Proxy +extractX :: forall r a. Proxy (x :: a | r) -> Proxy a +extractX Proxy = Proxy -subtractX :: forall r a. RProxy (x :: a | r) -> RProxy r -subtractX RProxy = RProxy - -extractX :: forall r a. RProxy (x :: a | r) -> Proxy a -extractX RProxy = Proxy - -hasX :: forall r a b. RProxy (x :: a, y :: b | r) -hasX = RProxy +hasX :: forall r a b. Proxy (x :: a, y :: b | r) +hasX = Proxy test1 = subtractX (subtractX hasX) test2 :: forall r a b - . RProxy (x :: a, x :: b, x :: Int | r) + . Proxy (x :: a, x :: b, x :: Int | r) -> Proxy Int test2 x = extractX (subtractX (subtractX x)) diff --git a/tests/purs/passing/ForeignKind.purs b/tests/purs/passing/ForeignKind.purs index c2d4421f2b..54eb08766c 100644 --- a/tests/purs/passing/ForeignKind.purs +++ b/tests/purs/passing/ForeignKind.purs @@ -1,7 +1,7 @@ module Main where import Prelude -import ForeignKinds.Lib (kind Nat, Zero, Succ, N3, NatProxy, class AddNat, addNat, proxy1, proxy2) +import ForeignKinds.Lib (Nat, Zero, Succ, N3, NatProxy, class AddNat, addNat, proxy1, proxy2) import Effect.Console (log) proxy1Add2Is3 :: NatProxy N3 diff --git a/tests/purs/passing/ForeignKind/Lib.purs b/tests/purs/passing/ForeignKind/Lib.purs index 0ca2c13638..d28a9a5ccd 100644 --- a/tests/purs/passing/ForeignKind/Lib.purs +++ b/tests/purs/passing/ForeignKind/Lib.purs @@ -1,8 +1,8 @@ -module ForeignKinds.Lib (kind Nat, Kinded, Zero, Succ, N0, N1, N2, N3, NatProxy(..), class AddNat, addNat, proxy1, proxy2) where +module ForeignKinds.Lib (Nat, Kinded, Zero, Succ, N0, N1, N2, N3, NatProxy(..), class AddNat, addNat, proxy1, proxy2) where -- declaration -foreign import kind Nat +data Nat -- use in foreign data diff --git a/tests/purs/passing/RowUnion.purs b/tests/purs/passing/RowUnion.purs index 182b9d1bf8..a2197f4719 100644 --- a/tests/purs/passing/RowUnion.purs +++ b/tests/purs/passing/RowUnion.purs @@ -69,7 +69,7 @@ withDefaultsClosed p = merge p { y: 1, z: 1 } test4 = withDefaults { x: 1, y: 2 } -- r is a subrow of s if Union r t s for some t. -class Subrow (r :: # Type) (s :: # Type) +class Subrow (r :: Row Type) (s :: Row Type) instance subrow :: Union r t s => Subrow r s main :: Effect Unit diff --git a/tests/purs/passing/SolvingCompareSymbol.purs b/tests/purs/passing/SolvingCompareSymbol.purs index d5e03fc828..a0a68df42a 100644 --- a/tests/purs/passing/SolvingCompareSymbol.purs +++ b/tests/purs/passing/SolvingCompareSymbol.purs @@ -3,7 +3,7 @@ module Main where import Prelude import Effect.Console (log) import Prim.Symbol (class Compare) -import Prim.Ordering (kind Ordering, LT, EQ, GT) +import Prim.Ordering (Ordering, LT, EQ, GT) import Type.Proxy (Proxy(..)) import Type.Data.Symbol (compare) as Symbol import Type.Data.Ordering (reflectOrdering) diff --git a/tests/purs/warning/DeprecatedForeignImportKind.out b/tests/purs/warning/DeprecatedForeignImportKind.out deleted file mode 100644 index c0305a48f6..0000000000 --- a/tests/purs/warning/DeprecatedForeignImportKind.out +++ /dev/null @@ -1,9 +0,0 @@ -Warning found: -at tests/purs/warning/DeprecatedForeignImportKind.purs:4:1 - 4:24 (line 4, column 1 - line 4, column 24) - - Foreign kind imports are deprecated and will be removed in a future release. Use empty 'data' instead. - - -See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, -or to contribute content related to this warning. - diff --git a/tests/purs/warning/DeprecatedForeignImportKind.purs b/tests/purs/warning/DeprecatedForeignImportKind.purs deleted file mode 100644 index 0a12f8ac1e..0000000000 --- a/tests/purs/warning/DeprecatedForeignImportKind.purs +++ /dev/null @@ -1,4 +0,0 @@ --- @shouldWarnWith WarningParsingModule -module Main where - -foreign import kind Foo diff --git a/tests/purs/warning/DeprecatedImportExportKinds.out b/tests/purs/warning/DeprecatedImportExportKinds.out deleted file mode 100644 index d9ae23028d..0000000000 --- a/tests/purs/warning/DeprecatedImportExportKinds.out +++ /dev/null @@ -1,30 +0,0 @@ -Warning 1 of 3: - - at tests/purs/warning/DeprecatedImportExportKinds.purs:6:13 - 6:21 (line 6, column 13 - line 6, column 21) - - Kind imports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead. - - - See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, - or to contribute content related to this warning. - -Warning 2 of 3: - - at tests/purs/warning/DeprecatedImportExportKinds/Lib.purs:5:1 - 5:24 (line 5, column 1 - line 5, column 24) - - Foreign kind imports are deprecated and will be removed in a future release. Use empty 'data' instead. - - - See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, - or to contribute content related to this warning. - -Warning 3 of 3: - - at tests/purs/warning/DeprecatedImportExportKinds/Lib.purs:2:5 - 2:13 (line 2, column 5 - line 2, column 13) - - Kind exports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead. - - - See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, - or to contribute content related to this warning. - diff --git a/tests/purs/warning/DeprecatedImportExportKinds.purs b/tests/purs/warning/DeprecatedImportExportKinds.purs deleted file mode 100644 index b52d729146..0000000000 --- a/tests/purs/warning/DeprecatedImportExportKinds.purs +++ /dev/null @@ -1,8 +0,0 @@ --- @shouldWarnWith WarningParsingModule --- @shouldWarnWith WarningParsingModule --- @shouldWarnWith WarningParsingModule -module Main where - -import Lib (kind Foo) - -foreign import data Bar :: Foo diff --git a/tests/purs/warning/DeprecatedImportExportKinds/Lib.purs b/tests/purs/warning/DeprecatedImportExportKinds/Lib.purs deleted file mode 100644 index 8cc65ed21f..0000000000 --- a/tests/purs/warning/DeprecatedImportExportKinds/Lib.purs +++ /dev/null @@ -1,5 +0,0 @@ -module Lib - ( kind Foo - ) where - -foreign import kind Foo diff --git a/tests/purs/warning/DeprecatedRowKindSyntax.out b/tests/purs/warning/DeprecatedRowKindSyntax.out deleted file mode 100644 index f0591ff448..0000000000 --- a/tests/purs/warning/DeprecatedRowKindSyntax.out +++ /dev/null @@ -1,9 +0,0 @@ -Warning found: -at tests/purs/warning/DeprecatedRowKindSyntax.purs:4:15 - 4:21 (line 4, column 15 - line 4, column 21) - - Unary '#' syntax for row kinds is deprecated and will be removed in a future release. Use the 'Row' kind instead. - - -See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, -or to contribute content related to this warning. - diff --git a/tests/purs/warning/DeprecatedRowKindSyntax.purs b/tests/purs/warning/DeprecatedRowKindSyntax.purs deleted file mode 100644 index c1e21a3190..0000000000 --- a/tests/purs/warning/DeprecatedRowKindSyntax.purs +++ /dev/null @@ -1,4 +0,0 @@ --- @shouldWarnWith WarningParsingModule -module Main where - -class R (a :: # Type) From 1419786846980c9a3f140de687cf72d6e10965d3 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sat, 26 Feb 2022 21:17:12 -0600 Subject: [PATCH 1419/1580] Add 'addWarning' to roots temporarily (#4249) --- weeder.dhall | 3 +++ 1 file changed, 3 insertions(+) diff --git a/weeder.dhall b/weeder.dhall index 18d6883d85..94d521fc78 100644 --- a/weeder.dhall +++ b/weeder.dhall @@ -2,6 +2,9 @@ [ "^Main\\.main$" , "^PscIdeSpec\\.main$" + -- Temporary fix until #4241 gets merged + , "^Language\\.PureScript\\.CST\\.Monad\\.addWarning" + -- These declarations are used in Pursuit. (The Types declarations are -- reexported in the L.P.Docs module, and referenced from there, but Weeder -- isn't that smart.) From 20d8441a09bd05a04e0dbbac9baab4a81e37ad8b Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sat, 26 Feb 2022 21:18:51 -0600 Subject: [PATCH 1420/1580] Update CI to use windows-2019 (#4248) --- .github/workflows/ci.yml | 2 +- CHANGELOG.d/internal_update-ci-windows-to-2019.md | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/internal_update-ci-windows-to-2019.md diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index ed07b2caf4..0699b9e59a 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -21,7 +21,7 @@ jobs: fail-fast: false # do not cancel builds for other OSes if one fails matrix: # If upgrading Ubuntu, also upgrade it in the lint job below - os: [ "ubuntu-18.04", "macOS-10.15", "windows-2016" ] + os: [ "ubuntu-18.04", "macOS-10.15", "windows-2019" ] runs-on: "${{ matrix.os }}" diff --git a/CHANGELOG.d/internal_update-ci-windows-to-2019.md b/CHANGELOG.d/internal_update-ci-windows-to-2019.md new file mode 100644 index 0000000000..0779c57594 --- /dev/null +++ b/CHANGELOG.d/internal_update-ci-windows-to-2019.md @@ -0,0 +1 @@ +* Update CI to use `windows-2019` since `windows-2016` is deprecated \ No newline at end of file From f01ba8f4d402dde0dad9feae4c48949318bf24be Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sun, 27 Feb 2022 22:17:06 -0500 Subject: [PATCH 1421/1580] Apply precedence rules to operator sections (#4033) This commit moves operator section desugaring from the beginning of the desugaring pipeline to the rebracketing phase. This allows the compiler to correctly detect whether an operator section is well-formed based on the precedence rules in effect. (In the process, this commit also refines the positioning of error messages associated with incorrect anonymous arguments.) Previously, `(_ * 4 + 1)` would desugar to `\x -> x * (4 + 1)`, even though `*` has higher precedence than `+`. Conversely, `(3 * 2 + _)` would not compile, even though `*` has higher precedence than `+`. These bugs have now been fixed; `(_ * 4 + 1)` is an error, and `(3 * 2 + _)` desugars to `\x -> 3 * 2 + x`. If you have code that relied on the old behavior, add an extra pair of parentheses around the expression in the section. --- CHANGELOG.d/breaking_fix-3981.md | 10 +++++++ .../Language/PureScript/AST/Declarations.hs | 5 ++++ .../PureScript/Sugar/ObjectWildcards.hs | 19 -------------- src/Language/PureScript/Sugar/Operators.hs | 26 ++++++++++++++++++- .../PureScript/Sugar/Operators/Expr.hs | 4 +-- tests/purs/failing/AnonArgument1.out | 2 +- tests/purs/failing/AnonArgument2.out | 2 +- tests/purs/failing/AnonArgument3.out | 2 +- tests/purs/failing/AnonArgument3.purs | 2 ++ tests/purs/failing/OperatorSections2.out | 9 +++++++ tests/purs/failing/OperatorSections2.purs | 6 +++++ tests/purs/failing/ProgrammableTypeErrors.out | 8 +++--- tests/purs/passing/OperatorSections.purs | 2 ++ 13 files changed, 68 insertions(+), 29 deletions(-) create mode 100644 CHANGELOG.d/breaking_fix-3981.md create mode 100644 tests/purs/failing/OperatorSections2.out create mode 100644 tests/purs/failing/OperatorSections2.purs diff --git a/CHANGELOG.d/breaking_fix-3981.md b/CHANGELOG.d/breaking_fix-3981.md new file mode 100644 index 0000000000..d76e45f28c --- /dev/null +++ b/CHANGELOG.d/breaking_fix-3981.md @@ -0,0 +1,10 @@ +* Apply precedence rules to operator sections + + Previously, `(_ * 4 + 1)` would desugar to `\x -> x * (4 + 1)`, even + though `*` has higher precedence than `+`. Conversely, `(3 * 2 + _)` + would not compile, even though `*` has higher precedence than `+`. These + bugs have now been fixed; `(_ * 4 + 1)` is an error, and `(3 * 2 + _)` + desugars to `\x -> 3 * 2 + x`. + + If you have code that relied on the old behavior, add an extra pair of + parentheses around the expression in the section. diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs index cda9ca7488..71be7ba99d 100644 --- a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs @@ -833,3 +833,8 @@ isTrueExpr (Var _ (Qualified (Just (ModuleName "Data.Boolean")) (Ident "otherwis isTrueExpr (TypedValue _ e _) = isTrueExpr e isTrueExpr (PositionedValue _ _ e) = isTrueExpr e isTrueExpr _ = False + +isAnonymousArgument :: Expr -> Bool +isAnonymousArgument AnonymousArgument = True +isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e +isAnonymousArgument _ = False diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 6c629c0698..e0a0613561 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -31,16 +31,6 @@ desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d (fn, _, _) = everywhereOnValuesTopDownM return desugarExpr return desugarExpr :: Expr -> m Expr - desugarExpr AnonymousArgument = throwError . errorMessage $ IncorrectAnonymousArgument - desugarExpr (Parens b) - | b' <- stripPositionInfo b - , BinaryNoParens op val u <- b' - , isAnonymousArgument u = do arg <- freshIdent' - return $ Abs (VarBinder nullSourceSpan arg) $ App (App op val) (Var nullSourceSpan (Qualified Nothing arg)) - | b' <- stripPositionInfo b - , BinaryNoParens op u val <- b' - , isAnonymousArgument u = do arg <- freshIdent' - return $ Abs (VarBinder nullSourceSpan arg) $ App (App op (Var nullSourceSpan (Qualified Nothing arg))) val desugarExpr (Literal ss (ObjectLiteral ps)) = wrapLambdaAssoc (Literal ss . ObjectLiteral) ps desugarExpr (ObjectUpdateNested obj ps) = transformNestedUpdate obj ps desugarExpr (Accessor prop u) @@ -96,21 +86,12 @@ desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d wrapLambdaAssoc :: ([(PSString, Expr)] -> Expr) -> [(PSString, Expr)] -> m Expr wrapLambdaAssoc mkVal = wrapLambda (mkVal . runAssocList) . AssocList - stripPositionInfo :: Expr -> Expr - stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e - stripPositionInfo e = e - peelAnonAccessorChain :: Expr -> Maybe [PSString] peelAnonAccessorChain (Accessor p e) = (p :) <$> peelAnonAccessorChain e peelAnonAccessorChain (PositionedValue _ _ e) = peelAnonAccessorChain e peelAnonAccessorChain AnonymousArgument = Just [] peelAnonAccessorChain _ = Nothing - isAnonymousArgument :: Expr -> Bool - isAnonymousArgument AnonymousArgument = True - isAnonymousArgument (PositionedValue _ _ e) = isAnonymousArgument e - isAnonymousArgument _ = False - freshIfAnon :: Expr -> m (Maybe Ident) freshIfAnon u | isAnonymousArgument u = Just <$> freshIdent' diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index bfc216a0af..0f74abe079 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -27,6 +27,7 @@ import Language.PureScript.Types import Control.Monad (unless, (<=<)) import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class (MonadSupply) import Data.Either (partitionEithers) import Data.Foldable (for_, traverse_) @@ -67,6 +68,7 @@ type TypeFixityRecord = FixityRecord (OpName 'TypeOpName) (ProperName 'TypeName) rebracket :: forall m . MonadError MultipleErrors m + => MonadSupply m => [ExternsFile] -> Module -> m Module @@ -83,6 +85,7 @@ rebracket = rebracketFiltered :: forall m . MonadError MultipleErrors m + => MonadSupply m => (Declaration -> Bool) -> [ExternsFile] -> Module @@ -178,6 +181,7 @@ rebracketFiltered pred_ externs m = do rebracketModule :: forall m . (MonadError MultipleErrors m) + => MonadSupply m => (Declaration -> Bool) -> [[(Qualified (OpName 'ValueOpName), Associativity)]] -> [[(Qualified (OpName 'TypeOpName), Associativity)]] @@ -189,7 +193,7 @@ rebracketModule pred_ valueOpTable typeOpTable (Module ss coms mn ds exts) = f' :: [Declaration] -> m [Declaration] f' = fmap (map (\d -> if pred_ d then removeParens d else d)) . - flip parU (usingPredicate pred_ f) + flip parU (usingPredicate pred_ (g <=< f)) (f, _, _, _, _) = everywhereWithContextOnValuesM @@ -200,6 +204,8 @@ rebracketModule pred_ valueOpTable typeOpTable (Module ss coms mn ds exts) = defS defS + (g, _, _) = everywhereOnValuesTopDownM pure removeBinaryNoParens pure + (goDecl, goExpr', goBinder') = updateTypes goType goType :: SourceSpan -> SourceType -> m SourceType @@ -208,6 +214,24 @@ rebracketModule pred_ valueOpTable typeOpTable (Module ss coms mn ds exts) = wrap :: (a -> m a) -> (SourceSpan, a) -> m (SourceSpan, a) wrap go (ss', a) = (ss',) <$> go a +removeBinaryNoParens :: (MonadError MultipleErrors m, MonadSupply m) => Expr -> m Expr +removeBinaryNoParens u + | isAnonymousArgument u = case u of + PositionedValue p _ _ -> rethrowWithPosition p err + _ -> err + where err = throwError . errorMessage $ IncorrectAnonymousArgument +removeBinaryNoParens (Parens (stripPositionInfo -> BinaryNoParens op l r)) + | isAnonymousArgument r = do arg <- freshIdent' + return $ Abs (VarBinder nullSourceSpan arg) $ App (App op l) (Var nullSourceSpan (Qualified Nothing arg)) + | isAnonymousArgument l = do arg <- freshIdent' + return $ Abs (VarBinder nullSourceSpan arg) $ App (App op (Var nullSourceSpan (Qualified Nothing arg))) r +removeBinaryNoParens (BinaryNoParens op l r) = return $ App (App op l) r +removeBinaryNoParens e = return e + +stripPositionInfo :: Expr -> Expr +stripPositionInfo (PositionedValue _ _ e) = stripPositionInfo e +stripPositionInfo e = e + removeParens :: Declaration -> Declaration removeParens = f where diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index d01c89e521..4fb12acbc1 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -36,13 +36,13 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable fromOp _ = Nothing reapply :: SourceSpan -> Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr - reapply ss op t1 = App (App (Op ss op) t1) + reapply ss = BinaryNoParens . Op ss modOpTable :: [[P.Operator (Chain Expr) () Identity Expr]] -> [[P.Operator (Chain Expr) () Identity Expr]] modOpTable table = - [ P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft ] + [ P.Infix (P.try (BinaryNoParens <$> parseTicks)) P.AssocLeft ] : table parseTicks :: P.Parsec (Chain Expr) () Expr diff --git a/tests/purs/failing/AnonArgument1.out b/tests/purs/failing/AnonArgument1.out index 92f2727b80..4cdd9330fa 100644 --- a/tests/purs/failing/AnonArgument1.out +++ b/tests/purs/failing/AnonArgument1.out @@ -1,5 +1,5 @@ Error found: -at tests/purs/failing/AnonArgument1.purs:5:1 - 5:9 (line 5, column 1 - line 5, column 9) +at tests/purs/failing/AnonArgument1.purs:5:8 - 5:9 (line 5, column 8 - line 5, column 9) An anonymous function argument appears in an invalid context. diff --git a/tests/purs/failing/AnonArgument2.out b/tests/purs/failing/AnonArgument2.out index faa84312db..84030b05d1 100644 --- a/tests/purs/failing/AnonArgument2.out +++ b/tests/purs/failing/AnonArgument2.out @@ -1,5 +1,5 @@ Error found: -at tests/purs/failing/AnonArgument2.purs:7:1 - 7:17 (line 7, column 1 - line 7, column 17) +at tests/purs/failing/AnonArgument2.purs:7:16 - 7:17 (line 7, column 16 - line 7, column 17) An anonymous function argument appears in an invalid context. diff --git a/tests/purs/failing/AnonArgument3.out b/tests/purs/failing/AnonArgument3.out index 2466eddbbd..bc6413c8fc 100644 --- a/tests/purs/failing/AnonArgument3.out +++ b/tests/purs/failing/AnonArgument3.out @@ -1,5 +1,5 @@ Error found: -at tests/purs/failing/AnonArgument3.purs:5:1 - 5:13 (line 5, column 1 - line 5, column 13) +at tests/purs/failing/AnonArgument3.purs:7:12 - 7:13 (line 7, column 12 - line 7, column 13) An anonymous function argument appears in an invalid context. diff --git a/tests/purs/failing/AnonArgument3.purs b/tests/purs/failing/AnonArgument3.purs index 34f9814cf3..ac185fde17 100644 --- a/tests/purs/failing/AnonArgument3.purs +++ b/tests/purs/failing/AnonArgument3.purs @@ -1,5 +1,7 @@ -- @shouldFailWith IncorrectAnonymousArgument module Main where +import Prelude + test :: Int -> Int test = 1 + _ diff --git a/tests/purs/failing/OperatorSections2.out b/tests/purs/failing/OperatorSections2.out new file mode 100644 index 0000000000..4371430edf --- /dev/null +++ b/tests/purs/failing/OperatorSections2.out @@ -0,0 +1,9 @@ +Error found: +at tests/purs/failing/OperatorSections2.purs:6:10 - 6:11 (line 6, column 10 - line 6, column 11) + + An anonymous function argument appears in an invalid context. + + +See https://github.com/purescript/documentation/blob/master/errors/IncorrectAnonymousArgument.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/OperatorSections2.purs b/tests/purs/failing/OperatorSections2.purs new file mode 100644 index 0000000000..3c69430271 --- /dev/null +++ b/tests/purs/failing/OperatorSections2.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith IncorrectAnonymousArgument +module Main where + +import Prelude + +test = ( _ * 4 + 1 ) 50 diff --git a/tests/purs/failing/ProgrammableTypeErrors.out b/tests/purs/failing/ProgrammableTypeErrors.out index 972d7ab3a5..7e0069e7cc 100644 --- a/tests/purs/failing/ProgrammableTypeErrors.out +++ b/tests/purs/failing/ProgrammableTypeErrors.out @@ -13,10 +13,10 @@ while solving type class constraint   while applying a function myShow of type MyShow t0 => t0 -> String - to argument \$0 ->  -  (add $0) 1 -while checking that expression myShow (\$0 ->  -  (add $0) 1 + to argument \$1 ->  +  (add $1) 1 +while checking that expression myShow (\$1 ->  +  (add $1) 1  )  has type String in value declaration main diff --git a/tests/purs/passing/OperatorSections.purs b/tests/purs/passing/OperatorSections.purs index 00538142eb..20c1e166ac 100644 --- a/tests/purs/passing/OperatorSections.purs +++ b/tests/purs/passing/OperatorSections.purs @@ -15,4 +15,6 @@ main = do let div x y = x.x / y.x assert $ (_ `div` foo { x = 4.0 }) { x: 4.0 } == 1.0 assert $ (foo { x = 4.0 } `div` _) { x: 4.0 } == 1.0 + assert $ (_ + 2 * 3) 1 == 7 + assert $ (3 * 2 + _) 1 == 7 log "Done" From 3ff73b60575a58b562c2d8bfb6cdc7f14ad449f2 Mon Sep 17 00:00:00 2001 From: sigma-andex <77549848+sigma-andex@users.noreply.github.com> Date: Tue, 1 Mar 2022 19:19:36 +0000 Subject: [PATCH 1422/1580] Fail if CJS is detected in FFI (#4250) * Support only es modules - Emit error if FFI parsing succeeds and a CommonJS module is detected - Do not emit a warning or error if FFI parsing fails * Remove failing bundler test * Add changelog entry. * Update src/Language/PureScript/Make/Actions.hs Co-authored-by: Ryan Hendrickson * Improve error message Co-authored-by: Ryan Hendrickson --- CHANGELOG.d/breaking_fail-on-cjs-detected.md | 13 ++ src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/Make/Actions.hs | 124 ++++++++---------- tests/purs/bundle/FunctionDeclaration.js | 19 --- tests/purs/bundle/FunctionDeclaration.purs | 14 -- tests/purs/bundle/ObjectShorthand.js | 2 +- .../DeprecatedFFICommonJSModule.js | 0 .../failing/DeprecatedFFICommonJSModule.out | 13 ++ .../DeprecatedFFICommonJSModule.purs | 2 +- .../FFIDefaultCJSExport.js | 0 tests/purs/failing/FFIDefaultCJSExport.out | 13 ++ .../FFIDefaultCJSExport.purs | 1 + tests/purs/passing/FFIConstraintWorkaround.js | 4 +- .../warning/DeprecatedFFICommonJSModule.out | 13 -- tests/support/bower.json | 9 +- 15 files changed, 107 insertions(+), 122 deletions(-) create mode 100644 CHANGELOG.d/breaking_fail-on-cjs-detected.md delete mode 100644 tests/purs/bundle/FunctionDeclaration.js delete mode 100644 tests/purs/bundle/FunctionDeclaration.purs rename tests/purs/{warning => failing}/DeprecatedFFICommonJSModule.js (100%) create mode 100644 tests/purs/failing/DeprecatedFFICommonJSModule.out rename tests/purs/{warning => failing}/DeprecatedFFICommonJSModule.purs (62%) rename tests/purs/{passing => failing}/FFIDefaultCJSExport.js (100%) create mode 100644 tests/purs/failing/FFIDefaultCJSExport.out rename tests/purs/{passing => failing}/FFIDefaultCJSExport.purs (68%) delete mode 100644 tests/purs/warning/DeprecatedFFICommonJSModule.out diff --git a/CHANGELOG.d/breaking_fail-on-cjs-detected.md b/CHANGELOG.d/breaking_fail-on-cjs-detected.md new file mode 100644 index 0000000000..e2a9ddc667 --- /dev/null +++ b/CHANGELOG.d/breaking_fail-on-cjs-detected.md @@ -0,0 +1,13 @@ +* If FFI parsing succeeds & CommonJS is detected, fail; otherwise, do not error or warn + + Previously, the compiler would emit an error if it failed to parse the FFI JavaScript file. + Since the underlying JavaScript parser (i.e. `language-javascript`) fails to parse even + valid JavaScript files, we cannot consider every failed parse to mean invalid JS files. + Fixing the parser would require a lot of effort, so we are planning to remove it instead + in `v0.16.x`. + + If the parse succeeds and a CommonJS module is detected, a compiler error is now emitted. + If the parse fails, we no longer emit a compiler error. While we could emit a warning, + such a warning will quickly become annoying for FFI files that trigger the buggy paths + of `language-javascript`. Moreover, we presume that all will be migrating their code to + ES modules now that CommonJS is being deprecated in the larger JavaScript ecosystem. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 351388e7bb..a56a8c8980 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -713,7 +713,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (DeprecatedFFICommonJSModule mn path) = paras [ line $ "A CommonJS foreign module implementation was provided for module " <> markCode (runModuleName mn) <> ": " , indent . lineS $ path - , line "CommonJS foreign modules are deprecated and won't be supported in the future." + , line "CommonJS foreign modules are no longer supported. Use native JavaScript/ECMAScript module syntax instead." ] renderSimpleErrorMessage (UnsupportedFFICommonJSExports mn idents) = paras [ line $ "The following CommonJS exports are not supported in the ES foreign module for module " <> markCode (runModuleName mn) <> ": " diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 8bc41c40fa..c811596d87 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -11,7 +11,6 @@ module Language.PureScript.Make.Actions import Prelude -import Control.Arrow ((&&&)) import Control.Monad hiding (sequence) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class @@ -20,7 +19,7 @@ import Control.Monad.Supply import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Aeson (Value(String), (.=), object) -import Data.Bifunctor (bimap) +import Data.Bifunctor (bimap, first) import Data.Either (partitionEithers) import Data.Foldable (for_) import qualified Data.List.NonEmpty as NEL @@ -274,33 +273,16 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = | not $ requiresForeign m -> tell $ errorMessage' (CF.moduleSourceSpan m) $ UnnecessaryFFIModule mn path | otherwise -> do - (foreignModuleType, foreignIdents) <- checkForeignDecls m path - case foreignModuleType of - ESModule -> copyFile path (outputFilename mn "foreign.js") - CJSModule -> do - tell $ errorMessage' (CF.moduleSourceSpan m) $ DeprecatedFFICommonJSModule mn path - copyFile path (outputFilename mn "foreign.cjs") - writeESForeignModuleWrapper mn foreignIdents + checkResult <- checkForeignDecls m path + case checkResult of + Left _ -> copyFile path (outputFilename mn "foreign.js") + Right (ESModule, _) -> copyFile path (outputFilename mn "foreign.js") + Right (CJSModule, _) -> do + throwError $ errorMessage' (CF.moduleSourceSpan m) $ DeprecatedFFICommonJSModule mn path Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn | otherwise -> return () - writeESForeignModuleWrapper :: ModuleName -> S.Set Ident -> Make () - writeESForeignModuleWrapper mn idents = - writeTextFile (outputFilename mn "foreign.js") wrapper - where - xs = (J.identToJs &&& runIdent) <$> S.toList idents - wrapper = TE.encodeUtf8 . T.intercalate "\n" $ - "import $foreign from \"./foreign.cjs\";" : - fmap (uncurry toLocalDeclaration) xs ++ - [ "export { " <> T.intercalate ", " (uncurry toNamedExport <$> xs) <> " };" - , "" - ] - toLocalDeclaration local exported = - "var " <> local <> " = $foreign." <> exported <> ";" - toNamedExport local exported - | local == exported = local - | otherwise = local <> " as " <> exported genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do @@ -345,55 +327,61 @@ data ForeignModuleType = ESModule | CJSModule deriving (Show) -- | Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module. -checkForeignDecls :: CF.Module ann -> FilePath -> Make (ForeignModuleType, S.Set Ident) +checkForeignDecls :: CF.Module ann -> FilePath -> Make (Either MultipleErrors (ForeignModuleType, S.Set Ident)) checkForeignDecls m path = do jsStr <- T.unpack <$> readTextFile path - js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parseModule jsStr path - - (foreignModuleType, foreignIdentsStrs) <- - case (,) <$> getForeignModuleExports js <*> getForeignModuleImports js of - Left reason -> errorParsingModule reason - Right (Bundle.ForeignModuleExports{..}, Bundle.ForeignModuleImports{..}) - | not (null cjsExports && null cjsImports) - , null esExports - , null esImports -> do - let deprecatedFFI = filter (elem '\'') cjsExports - unless (null deprecatedFFI) $ - errorDeprecatedForeignPrimes deprecatedFFI - - pure (CJSModule, cjsExports) - | otherwise -> do - unless (null cjsImports) $ - errorUnsupportedFFICommonJSImports cjsImports - - unless (null cjsExports) $ - errorUnsupportedFFICommonJSExports cjsExports - - pure (ESModule, esExports) - - foreignIdents <- either - errorInvalidForeignIdentifiers - (pure . S.fromList) - (parseIdents foreignIdentsStrs) - let importedIdents = S.fromList (CF.moduleForeign m) - - let unusedFFI = foreignIdents S.\\ importedIdents - unless (null unusedFFI) $ - tell . errorMessage' modSS . UnusedFFIImplementations mname $ - S.toList unusedFFI - - let missingFFI = importedIdents S.\\ foreignIdents - unless (null missingFFI) $ - throwError . errorMessage' modSS . MissingFFIImplementations mname $ - S.toList missingFFI - - pure (foreignModuleType, foreignIdents) + + let + parseResult :: Either MultipleErrors JS.JSAST + parseResult = first (errorParsingModule . Bundle.UnableToParseModule) $ JS.parseModule jsStr path + traverse checkFFI parseResult + where mname = CF.moduleName m modSS = CF.moduleSourceSpan m - errorParsingModule :: Bundle.ErrorMessage -> Make a - errorParsingModule = throwError . errorMessage' modSS . ErrorParsingFFIModule path . Just + checkFFI :: JS.JSAST -> Make (ForeignModuleType, S.Set Ident) + checkFFI js = do + (foreignModuleType, foreignIdentsStrs) <- + case (,) <$> getForeignModuleExports js <*> getForeignModuleImports js of + Left reason -> throwError $ errorParsingModule reason + Right (Bundle.ForeignModuleExports{..}, Bundle.ForeignModuleImports{..}) + | not (null cjsExports && null cjsImports) + , null esExports + , null esImports -> do + let deprecatedFFI = filter (elem '\'') cjsExports + unless (null deprecatedFFI) $ + errorDeprecatedForeignPrimes deprecatedFFI + + pure (CJSModule, cjsExports) + | otherwise -> do + unless (null cjsImports) $ + errorUnsupportedFFICommonJSImports cjsImports + + unless (null cjsExports) $ + errorUnsupportedFFICommonJSExports cjsExports + + pure (ESModule, esExports) + + foreignIdents <- either + errorInvalidForeignIdentifiers + (pure . S.fromList) + (parseIdents foreignIdentsStrs) + let importedIdents = S.fromList (CF.moduleForeign m) + + let unusedFFI = foreignIdents S.\\ importedIdents + unless (null unusedFFI) $ + tell . errorMessage' modSS . UnusedFFIImplementations mname $ + S.toList unusedFFI + + let missingFFI = importedIdents S.\\ foreignIdents + unless (null missingFFI) $ + throwError . errorMessage' modSS . MissingFFIImplementations mname $ + S.toList missingFFI + pure (foreignModuleType, foreignIdents) + + errorParsingModule :: Bundle.ErrorMessage -> MultipleErrors + errorParsingModule = errorMessage' modSS . ErrorParsingFFIModule path . Just getForeignModuleExports :: JS.JSAST -> Either Bundle.ErrorMessage Bundle.ForeignModuleExports getForeignModuleExports = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname)) diff --git a/tests/purs/bundle/FunctionDeclaration.js b/tests/purs/bundle/FunctionDeclaration.js deleted file mode 100644 index 6d7bfdc1e0..0000000000 --- a/tests/purs/bundle/FunctionDeclaration.js +++ /dev/null @@ -1,19 +0,0 @@ -"use strict"; - -var foo = 0; - -function bar(foo) { - return foo; -} - -var baz = "Done"; - -function qux() { - return bar(baz); -} - -exports.qux = qux; - -var fs = require('fs'); -var source = fs.readFileSync(__filename, 'utf-8'); -exports.fooIsEliminated = !/^ *var foo/m.test(source); diff --git a/tests/purs/bundle/FunctionDeclaration.purs b/tests/purs/bundle/FunctionDeclaration.purs deleted file mode 100644 index 5d9810c71b..0000000000 --- a/tests/purs/bundle/FunctionDeclaration.purs +++ /dev/null @@ -1,14 +0,0 @@ -module Main (main) where - -import Prelude -import Effect (Effect) -import Effect.Console (log) -import Test.Assert (assert') - -main :: Effect Unit -main = do - assert' "foo" fooIsEliminated - qux >>= log - -foreign import qux :: Effect String -foreign import fooIsEliminated :: Boolean diff --git a/tests/purs/bundle/ObjectShorthand.js b/tests/purs/bundle/ObjectShorthand.js index 8ab71c994b..225e8bf063 100644 --- a/tests/purs/bundle/ObjectShorthand.js +++ b/tests/purs/bundle/ObjectShorthand.js @@ -1,4 +1,4 @@ -export var foo = 1; +var foo = 1; export var bar = { foo }; diff --git a/tests/purs/warning/DeprecatedFFICommonJSModule.js b/tests/purs/failing/DeprecatedFFICommonJSModule.js similarity index 100% rename from tests/purs/warning/DeprecatedFFICommonJSModule.js rename to tests/purs/failing/DeprecatedFFICommonJSModule.js diff --git a/tests/purs/failing/DeprecatedFFICommonJSModule.out b/tests/purs/failing/DeprecatedFFICommonJSModule.out new file mode 100644 index 0000000000..60ae55d931 --- /dev/null +++ b/tests/purs/failing/DeprecatedFFICommonJSModule.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/DeprecatedFFICommonJSModule.purs:2:1 - 5:29 (line 2, column 1 - line 5, column 29) + + A CommonJS foreign module implementation was provided for module Main: + + tests/purs/failing/DeprecatedFFICommonJSModule.js + + CommonJS foreign modules are no longer supported. Use native JavaScript/ECMAScript module syntax instead. + + +See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFICommonJSModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/warning/DeprecatedFFICommonJSModule.purs b/tests/purs/failing/DeprecatedFFICommonJSModule.purs similarity index 62% rename from tests/purs/warning/DeprecatedFFICommonJSModule.purs rename to tests/purs/failing/DeprecatedFFICommonJSModule.purs index b91bed426b..6c5f21e6d5 100644 --- a/tests/purs/warning/DeprecatedFFICommonJSModule.purs +++ b/tests/purs/failing/DeprecatedFFICommonJSModule.purs @@ -1,4 +1,4 @@ --- @shouldWarnWith DeprecatedFFICommonJSModule +-- @shouldFailWith DeprecatedFFICommonJSModule module Main where foreign import yes :: Boolean diff --git a/tests/purs/passing/FFIDefaultCJSExport.js b/tests/purs/failing/FFIDefaultCJSExport.js similarity index 100% rename from tests/purs/passing/FFIDefaultCJSExport.js rename to tests/purs/failing/FFIDefaultCJSExport.js diff --git a/tests/purs/failing/FFIDefaultCJSExport.out b/tests/purs/failing/FFIDefaultCJSExport.out new file mode 100644 index 0000000000..90ce31fd7d --- /dev/null +++ b/tests/purs/failing/FFIDefaultCJSExport.out @@ -0,0 +1,13 @@ +Error found: +at tests/purs/failing/FFIDefaultCJSExport.purs:2:1 - 8:19 (line 2, column 1 - line 8, column 19) + + A CommonJS foreign module implementation was provided for module Main: + + tests/purs/failing/FFIDefaultCJSExport.js + + CommonJS foreign modules are no longer supported. Use native JavaScript/ECMAScript module syntax instead. + + +See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFICommonJSModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/passing/FFIDefaultCJSExport.purs b/tests/purs/failing/FFIDefaultCJSExport.purs similarity index 68% rename from tests/purs/passing/FFIDefaultCJSExport.purs rename to tests/purs/failing/FFIDefaultCJSExport.purs index 1d084b6d8d..93de635f63 100644 --- a/tests/purs/passing/FFIDefaultCJSExport.purs +++ b/tests/purs/failing/FFIDefaultCJSExport.purs @@ -1,3 +1,4 @@ +-- @shouldFailWith DeprecatedFFICommonJSModule module Main where import Effect.Console (log) diff --git a/tests/purs/passing/FFIConstraintWorkaround.js b/tests/purs/passing/FFIConstraintWorkaround.js index 6df6f54f48..755092a488 100644 --- a/tests/purs/passing/FFIConstraintWorkaround.js +++ b/tests/purs/passing/FFIConstraintWorkaround.js @@ -1,6 +1,4 @@ -"use strict"; - -exports.showImpl = function (showFn) { +export function showImpl(showFn) { return function (val) { return showFn(val); }; diff --git a/tests/purs/warning/DeprecatedFFICommonJSModule.out b/tests/purs/warning/DeprecatedFFICommonJSModule.out deleted file mode 100644 index 38fb74714a..0000000000 --- a/tests/purs/warning/DeprecatedFFICommonJSModule.out +++ /dev/null @@ -1,13 +0,0 @@ -Warning found: -at tests/purs/warning/DeprecatedFFICommonJSModule.purs:2:1 - 5:29 (line 2, column 1 - line 5, column 29) - - A CommonJS foreign module implementation was provided for module Main: - - tests/purs/warning/DeprecatedFFICommonJSModule.js - - CommonJS foreign modules are deprecated and won't be supported in the future. - - -See https://github.com/purescript/documentation/blob/master/errors/DeprecatedFFICommonJSModule.md for more information, -or to contribute content related to this warning. - diff --git a/tests/support/bower.json b/tests/support/bower.json index 667acb6679..86b33c3be0 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -2,13 +2,14 @@ "name": "purescript-test-suite-support", "dependencies": { "purescript-arrays": "https://github.com/working-group-purescript-es/purescript-arrays.git#es-modules", - "purescript-assert": "5.0.0", + "purescript-assert": "https://github.com/working-group-purescript-es/purescript-assert.git#es-modules", "purescript-bifunctors": "5.0.0", "purescript-console": "https://github.com/working-group-purescript-es/purescript-console.git#es-modules", "purescript-control": "https://github.com/working-group-purescript-es/purescript-control.git#es-modules", "purescript-distributive": "5.0.0", "purescript-effect": "https://github.com/working-group-purescript-es/purescript-effect.git#es-modules", "purescript-either": "5.0.0", + "purescript-enums": "https://github.com/working-group-purescript-es/purescript-enums.git#es-modules", "purescript-foldable-traversable": "https://github.com/working-group-purescript-es/purescript-foldable-traversable.git#es-modules", "purescript-functions": "https://github.com/working-group-purescript-es/purescript-functions.git#es-modules", "purescript-gen": "3.0.0", @@ -21,6 +22,7 @@ "purescript-maybe": "5.0.0", "purescript-newtype": "4.0.0", "purescript-nonempty": "6.0.0", + "purescript-numbers": "https://github.com/working-group-purescript-es/purescript-numbers.git#es-modules", "purescript-partial": "https://github.com/working-group-purescript-es/purescript-partial.git#es-modules", "purescript-prelude": "https://github.com/working-group-purescript-es/purescript-prelude.git#es-modules", "purescript-psci-support": "5.0.0", @@ -37,7 +39,9 @@ }, "resolutions": { "purescript-console": "es-modules", + "purescript-assert": "es-modules", "purescript-effect": "es-modules", + "purescript-enums": "es-modules", "purescript-control": "es-modules", "purescript-foldable-traversable": "es-modules", "purescript-functions": "es-modules", @@ -45,6 +49,7 @@ "purescript-math": "es-modules", "purescript-arrays": "es-modules", "purescript-integers": "es-modules", + "purescript-numbers": "es-modules", "purescript-partial": "es-modules", "purescript-refs": "es-modules", "purescript-st": "es-modules", @@ -52,4 +57,4 @@ "purescript-prelude": "es-modules", "purescript-unsafe-coerce": "es-modules" } -} \ No newline at end of file +} From 0177f717990911ede5ebe8ad7b0f520ad99383bf Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 1 Mar 2022 13:45:12 -0600 Subject: [PATCH 1423/1580] Warn on ad-hoc `case ... of` expressions (#4241) * Warn on ad-hoc case ... of expressions ``` case foo of binder -> binder -- ^ this needs to be indented -- past the original binder, similar to let bindings ``` * Update lists to v6.1.0 v6.0.0 was using syntax this PR deprecates * Update changelog entry * Drop 'addWarning' from weeder root This was a temporary fix to make CI pass due to other PRs removing the need for `addWarning` in `Parser.y` --- ...king_warn-on-two-ad-hoc-case-statements.md | 25 +++++++++++++++++++ .../src/Language/PureScript/CST/Errors.hs | 3 +++ .../src/Language/PureScript/CST/Parser.y | 4 +-- src/Language/PureScript/Errors.hs | 1 + .../DeprecatedCaseOfOffsideSyntax1.out | 9 +++++++ .../DeprecatedCaseOfOffsideSyntax1.purs | 9 +++++++ .../DeprecatedCaseOfOffsideSyntax2.out | 9 +++++++ .../DeprecatedCaseOfOffsideSyntax2.purs | 8 ++++++ tests/support/bower.json | 2 +- weeder.dhall | 3 --- 10 files changed, 67 insertions(+), 6 deletions(-) create mode 100644 CHANGELOG.d/breaking_warn-on-two-ad-hoc-case-statements.md create mode 100644 tests/purs/warning/DeprecatedCaseOfOffsideSyntax1.out create mode 100644 tests/purs/warning/DeprecatedCaseOfOffsideSyntax1.purs create mode 100644 tests/purs/warning/DeprecatedCaseOfOffsideSyntax2.out create mode 100644 tests/purs/warning/DeprecatedCaseOfOffsideSyntax2.purs diff --git a/CHANGELOG.d/breaking_warn-on-two-ad-hoc-case-statements.md b/CHANGELOG.d/breaking_warn-on-two-ad-hoc-case-statements.md new file mode 100644 index 0000000000..533fed7fc3 --- /dev/null +++ b/CHANGELOG.d/breaking_warn-on-two-ad-hoc-case-statements.md @@ -0,0 +1,25 @@ +* Warn on ad-hoc non-single-line case expression syntax + + The following code will now produce a compiler warning. + These were originally supported to ease the migration + to the new CST parser. + + ```purescript + -- before: `arg` isn't indented "past" the `Foo arg` binder + case foo of Foo arg -> + arg + -- after + case foo of Foo arg -> + foo + ``` + + Dropping the above syntax make case expressions more similar to how `let` bindings work: + ```purescript + let ok = 1 + let + ok = 1 + let ok = + 1 + let notOk = + 1 + ``` \ No newline at end of file diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs b/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs index 89fa5a96e1..ce776c87c2 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs @@ -63,6 +63,7 @@ data ParserWarningType | WarnDeprecatedForeignKindSyntax | WarnDeprecatedKindImportSyntax | WarnDeprecatedKindExportSyntax + | WarnDeprecatedCaseOfOffsideSyntax deriving (Show, Eq, Ord) data ParserErrorInfo a = ParserErrorInfo @@ -193,3 +194,5 @@ prettyPrintWarningMessage ParserErrorInfo {..} = case errType of "Kind imports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead." WarnDeprecatedKindExportSyntax -> "Kind exports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead." + WarnDeprecatedCaseOfOffsideSyntax -> + "Dedented expressions in case branches are deprecated and will be removed in a future release. Indent the branch's expression past it's binder instead." diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y index d1f6d77711..8a9b6e79fe 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y +++ b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y @@ -395,9 +395,9 @@ expr5 :: { Expr () } -- at any level, but this is ambiguous. We allow it in the case of a singleton -- case, since this is used in the wild. | 'case' sep(expr, ',') 'of' '\{' sep(binder1, ',') '->' '\}' exprWhere - { ExprCase () (CaseOf $1 $2 $3 (pure ($5, Unconditional $6 $8))) } + {% addWarning (let (a,b) = whereRange $8 in [a, b]) WarnDeprecatedCaseOfOffsideSyntax *> pure (ExprCase () (CaseOf $1 $2 $3 (pure ($5, Unconditional $6 $8)))) } | 'case' sep(expr, ',') 'of' '\{' sep(binder1, ',') '\}' guardedCase - { ExprCase () (CaseOf $1 $2 $3 (pure ($5, $7))) } + {% addWarning (let (a,b) = guardedRange $7 in [a, b]) WarnDeprecatedCaseOfOffsideSyntax *> pure (ExprCase () (CaseOf $1 $2 $3 (pure ($5, $7)))) } expr6 :: { Expr () } : expr7 %shift { $1 } diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index a56a8c8980..8818f3bdef 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -522,6 +522,7 @@ errorSuggestion err = CST.WarnDeprecatedForeignKindSyntax -> suggest $ "data " <> CST.printTokens (drop 3 toks) CST.WarnDeprecatedKindImportSyntax -> suggest $ CST.printTokens $ drop 1 toks CST.WarnDeprecatedKindExportSyntax -> suggest $ CST.printTokens $ drop 1 toks + CST.WarnDeprecatedCaseOfOffsideSyntax -> Nothing _ -> Nothing where emptySuggestion = Just $ ErrorSuggestion "" diff --git a/tests/purs/warning/DeprecatedCaseOfOffsideSyntax1.out b/tests/purs/warning/DeprecatedCaseOfOffsideSyntax1.out new file mode 100644 index 0000000000..1840a74fa5 --- /dev/null +++ b/tests/purs/warning/DeprecatedCaseOfOffsideSyntax1.out @@ -0,0 +1,9 @@ +Warning found: +at tests/purs/warning/DeprecatedCaseOfOffsideSyntax1.purs:9:3 - 9:4 (line 9, column 3 - line 9, column 4) + + Dedented expressions in case branches are deprecated and will be removed in a future release. Indent the branch's expression past it's binder instead. + + +See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/DeprecatedCaseOfOffsideSyntax1.purs b/tests/purs/warning/DeprecatedCaseOfOffsideSyntax1.purs new file mode 100644 index 0000000000..5c4d59604d --- /dev/null +++ b/tests/purs/warning/DeprecatedCaseOfOffsideSyntax1.purs @@ -0,0 +1,9 @@ +-- @shouldWarnWith WarningParsingModule +module DeprecatedCaseOfOffsideSyntax1 where + +data Foo = Foo Int + +test :: Foo -> Int +test = case _ of + Foo i -> + i diff --git a/tests/purs/warning/DeprecatedCaseOfOffsideSyntax2.out b/tests/purs/warning/DeprecatedCaseOfOffsideSyntax2.out new file mode 100644 index 0000000000..b33a0b63a4 --- /dev/null +++ b/tests/purs/warning/DeprecatedCaseOfOffsideSyntax2.out @@ -0,0 +1,9 @@ +Warning found: +at tests/purs/warning/DeprecatedCaseOfOffsideSyntax2.purs:8:3 - 8:4 (line 8, column 3 - line 8, column 4) + + Dedented expressions in case branches are deprecated and will be removed in a future release. Indent the branch's expression past it's binder instead. + + +See https://github.com/purescript/documentation/blob/master/errors/WarningParsingModule.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/DeprecatedCaseOfOffsideSyntax2.purs b/tests/purs/warning/DeprecatedCaseOfOffsideSyntax2.purs new file mode 100644 index 0000000000..bd994f4eb6 --- /dev/null +++ b/tests/purs/warning/DeprecatedCaseOfOffsideSyntax2.purs @@ -0,0 +1,8 @@ +-- @shouldWarnWith WarningParsingModule +module DeprecatedCaseOfOffsideSyntax2 where + +data Foo = Foo Int + +test :: Foo -> Int +test = case _ of Foo i -> + i diff --git a/tests/support/bower.json b/tests/support/bower.json index 86b33c3be0..7090e578ab 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -17,7 +17,7 @@ "purescript-integers": "https://github.com/working-group-purescript-es/purescript-integers.git#es-modules", "purescript-invariant": "5.0.0", "purescript-lazy": "https://github.com/working-group-purescript-es/purescript-lazy.git#es-modules", - "purescript-lists": "6.0.0", + "purescript-lists": "6.1.0", "purescript-math": "https://github.com/working-group-purescript-es/purescript-math.git#es-modules", "purescript-maybe": "5.0.0", "purescript-newtype": "4.0.0", diff --git a/weeder.dhall b/weeder.dhall index 94d521fc78..18d6883d85 100644 --- a/weeder.dhall +++ b/weeder.dhall @@ -2,9 +2,6 @@ [ "^Main\\.main$" , "^PscIdeSpec\\.main$" - -- Temporary fix until #4241 gets merged - , "^Language\\.PureScript\\.CST\\.Monad\\.addWarning" - -- These declarations are used in Pursuit. (The Types declarations are -- reexported in the L.P.Docs module, and referenced from there, but Weeder -- isn't that smart.) From 6590563396dc952a92148e44a326caa43a2f8d76 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 1 Mar 2022 16:34:38 -0600 Subject: [PATCH 1424/1580] Make first alpha release for v0.15.0 (#4251) * Make first alpha release for v0.15.0 We wanted to use `0.15.0-alpha.1`, but cabal couldn't parse the `purescript.cabal` file. So, we're going with `-alpha-01` prefix in case we go over 10 alpha releases --- app/Version.hs | 2 +- purescript.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/app/Version.hs b/app/Version.hs index 9c2f3556be..c8031aa7b3 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -17,7 +17,7 @@ import qualified Development.GitRev as GitRev -- prerelease identifier here (if any). When releasing a proper version, simply -- set this to an empty string. prerelease :: String -prerelease = "" +prerelease = "-alpha-01" versionString :: String versionString = showVersion Paths.version ++ prerelease ++ extra diff --git a/purescript.cabal b/purescript.cabal index 1a0da0f622..4ec66c5ee1 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.14.7 +version: 0.15.0-alpha-01 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 24eeeb216e73921d8457a641eddba39a0b49b22e Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Fri, 4 Mar 2022 08:06:26 +0800 Subject: [PATCH 1425/1580] Type-level integers (#4207) * Implement native type-level integers Added support for type-level integers and compiler-solved operations such as `Add`, `Mul`, and `Compare`. Type-level integers use the `Int` type as their kind. * Implement the Reflectable type class The `Reflectable` type class is a common interface for reflecting type-level values down to the term-level. Its instances are automatically solved by the compiler, and it allows `Symbol`, `Int`, `Boolean`, and `Ordering` kinded types to be reflected to their term-level representations. Co-authored-by: Csongor Kiss Co-authored-by: Ryan Hendrickson --- CHANGELOG.d/feature_is_reflectable.md | 7 ++ CHANGELOG.d/feature_type_level_ints.md | 5 + .../src/Language/PureScript/CST/Convert.hs | 3 + .../src/Language/PureScript/CST/Flatten.hs | 1 + .../src/Language/PureScript/CST/Parser.y | 9 +- .../src/Language/PureScript/CST/Positions.hs | 2 + .../PureScript/CST/Traversals/Type.hs | 1 + .../src/Language/PureScript/CST/Types.hs | 1 + .../src/Language/PureScript/Constants/Prim.hs | 25 ++++- .../src/Language/PureScript/Environment.hs | 43 +++++++ .../src/Language/PureScript/Types.hs | 39 ++++--- purescript.cabal | 1 + src/Language/PureScript/Constants/Prelude.hs | 21 ++++ src/Language/PureScript/Docs/Prim.hs | 30 +++++ .../Docs/RenderedCode/RenderType.hs | 4 +- src/Language/PureScript/Ide/Prim.hs | 5 + src/Language/PureScript/Linter.hs | 1 + src/Language/PureScript/Pretty/Types.hs | 3 + src/Language/PureScript/Sugar/Names/Env.hs | 8 ++ src/Language/PureScript/Sugar/TypeClasses.hs | 1 + src/Language/PureScript/TypeChecker.hs | 2 + .../PureScript/TypeChecker/Entailment.hs | 85 ++++++++++++++ .../TypeChecker/Entailment/IntCompare.hs | 102 +++++++++++++++++ src/Language/PureScript/TypeChecker/Kinds.hs | 4 + src/Language/PureScript/TypeChecker/Unify.hs | 1 + tests/TestPrimDocs.hs | 3 +- tests/purs/failing/CompareInt1.out | 43 +++++++ tests/purs/failing/CompareInt1.purs | 14 +++ tests/purs/failing/CompareInt10.out | 43 +++++++ tests/purs/failing/CompareInt10.purs | 14 +++ tests/purs/failing/CompareInt11.out | 33 ++++++ tests/purs/failing/CompareInt11.purs | 14 +++ tests/purs/failing/CompareInt12.out | 33 ++++++ tests/purs/failing/CompareInt12.purs | 14 +++ tests/purs/failing/CompareInt2.out | 43 +++++++ tests/purs/failing/CompareInt2.purs | 14 +++ tests/purs/failing/CompareInt3.out | 43 +++++++ tests/purs/failing/CompareInt3.purs | 14 +++ tests/purs/failing/CompareInt4.out | 43 +++++++ tests/purs/failing/CompareInt4.purs | 14 +++ tests/purs/failing/CompareInt5.out | 43 +++++++ tests/purs/failing/CompareInt5.purs | 14 +++ tests/purs/failing/CompareInt6.out | 43 +++++++ tests/purs/failing/CompareInt6.purs | 14 +++ tests/purs/failing/CompareInt7.out | 43 +++++++ tests/purs/failing/CompareInt7.purs | 14 +++ tests/purs/failing/CompareInt8.out | 43 +++++++ tests/purs/failing/CompareInt8.purs | 14 +++ tests/purs/failing/CompareInt9.out | 43 +++++++ tests/purs/failing/CompareInt9.purs | 14 +++ tests/purs/failing/IntAsRecordLabel.out | 10 ++ tests/purs/failing/IntAsRecordLabel.purs | 4 + tests/purs/layout/IntType.out | 8 ++ tests/purs/layout/IntType.purs | 7 ++ tests/purs/passing/ParseTypeInt.purs | 28 +++++ tests/purs/passing/SolvingAddInt.purs | 26 +++++ tests/purs/passing/SolvingCompareInt.purs | 106 ++++++++++++++++++ tests/purs/passing/SolvingMulInt.purs | 14 +++ tests/purs/passing/SolvingReflectable.purs | 52 +++++++++ .../purs/passing/SolvingReflectable/Lib.purs | 5 + 60 files changed, 1314 insertions(+), 17 deletions(-) create mode 100644 CHANGELOG.d/feature_is_reflectable.md create mode 100644 CHANGELOG.d/feature_type_level_ints.md create mode 100644 src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs create mode 100644 tests/purs/failing/CompareInt1.out create mode 100644 tests/purs/failing/CompareInt1.purs create mode 100644 tests/purs/failing/CompareInt10.out create mode 100644 tests/purs/failing/CompareInt10.purs create mode 100644 tests/purs/failing/CompareInt11.out create mode 100644 tests/purs/failing/CompareInt11.purs create mode 100644 tests/purs/failing/CompareInt12.out create mode 100644 tests/purs/failing/CompareInt12.purs create mode 100644 tests/purs/failing/CompareInt2.out create mode 100644 tests/purs/failing/CompareInt2.purs create mode 100644 tests/purs/failing/CompareInt3.out create mode 100644 tests/purs/failing/CompareInt3.purs create mode 100644 tests/purs/failing/CompareInt4.out create mode 100644 tests/purs/failing/CompareInt4.purs create mode 100644 tests/purs/failing/CompareInt5.out create mode 100644 tests/purs/failing/CompareInt5.purs create mode 100644 tests/purs/failing/CompareInt6.out create mode 100644 tests/purs/failing/CompareInt6.purs create mode 100644 tests/purs/failing/CompareInt7.out create mode 100644 tests/purs/failing/CompareInt7.purs create mode 100644 tests/purs/failing/CompareInt8.out create mode 100644 tests/purs/failing/CompareInt8.purs create mode 100644 tests/purs/failing/CompareInt9.out create mode 100644 tests/purs/failing/CompareInt9.purs create mode 100644 tests/purs/failing/IntAsRecordLabel.out create mode 100644 tests/purs/failing/IntAsRecordLabel.purs create mode 100644 tests/purs/layout/IntType.out create mode 100644 tests/purs/layout/IntType.purs create mode 100644 tests/purs/passing/ParseTypeInt.purs create mode 100644 tests/purs/passing/SolvingAddInt.purs create mode 100644 tests/purs/passing/SolvingCompareInt.purs create mode 100644 tests/purs/passing/SolvingMulInt.purs create mode 100644 tests/purs/passing/SolvingReflectable.purs create mode 100644 tests/purs/passing/SolvingReflectable/Lib.purs diff --git a/CHANGELOG.d/feature_is_reflectable.md b/CHANGELOG.d/feature_is_reflectable.md new file mode 100644 index 0000000000..fb3aa552d2 --- /dev/null +++ b/CHANGELOG.d/feature_is_reflectable.md @@ -0,0 +1,7 @@ +* Implement the Reflectable type class + + The `Reflectable` type class is a common interface for reflecting + type-level values down to the term-level. Its instances are + automatically solved by the compiler, and it allows `Symbol`, `Int`, + `Boolean`, and `Ordering` kinded types to be reflected to their + term-level representations. diff --git a/CHANGELOG.d/feature_type_level_ints.md b/CHANGELOG.d/feature_type_level_ints.md new file mode 100644 index 0000000000..280f6f42d4 --- /dev/null +++ b/CHANGELOG.d/feature_type_level_ints.md @@ -0,0 +1,5 @@ +* Implement native type-level integers + + Added support for type-level integers and compiler-solved operations + such as `Add`, `Mul`, and `Compare`. Type-level integers use the `Int` + type as their kind. diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs index 46994f017c..aba35ce179 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs @@ -123,6 +123,8 @@ convertType fileName = go T.TypeWildcard (sourceName fileName a) . Just . getIdent $ nameValue a TypeString _ a b -> T.TypeLevelString (sourceAnnCommented fileName a a) b + TypeInt _ _ a b -> + T.TypeLevelInt (sourceAnnCommented fileName a a) b TypeRow _ (Wrapped _ row b) -> goRow row b TypeRecord _ (Wrapped a row b) -> do @@ -566,6 +568,7 @@ convertDeclaration fileName decl = case decl of TypeConstructor _ qn -> N.runProperName $ qualName qn TypeOpName _ qn -> N.runOpName $ qualName qn TypeString _ _ ps -> prettyPrintStringJS ps + TypeInt _ _ _ nt -> Text.pack $ show nt -- Typed holes are disallowed in instance heads TypeHole{} -> "" diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs b/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs index c643f60904..fe20adecd3 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs @@ -282,6 +282,7 @@ flattenType = \case TypeWildcard _ a -> pure a TypeHole _ a -> pure $ nameTok a TypeString _ a _ -> pure a + TypeInt _ a b _ -> maybe mempty pure a <> pure b TypeRow _ a -> flattenWrapped flattenRow a TypeRecord _ a -> flattenWrapped flattenRow a TypeForall _ a b c d -> pure a <> foldMap flattenTypeVarBinding b <> pure c <> flattenType d diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y index 8a9b6e79fe..0f800c05b2 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y +++ b/lib/purescript-cst/src/Language/PureScript/CST/Parser.y @@ -19,6 +19,7 @@ module Language.PureScript.CST.Parser import Prelude hiding (lex) import Control.Monad ((<=<), when) +import Data.Bifunctor (second) import Data.Foldable (foldl', for_, toList) import qualified Data.List.NonEmpty as NE import Data.Text (Text) @@ -301,8 +302,12 @@ type3 :: { Type () } | type3 qualOp type4 %shift { TypeOp () $1 (getQualifiedOpName $2) $3 } type4 :: { Type () } + : type5 %shift { $1 } + | '-' int { uncurry (TypeInt () (Just $1)) (second negate $2) } + +type5 :: { Type () } : typeAtom { $1 } - | type4 typeAtom { TypeApp () $1 $2 } + | type5 typeAtom { TypeApp () $1 $2 } typeAtom :: { Type ()} : '_' { TypeWildcard () $1 } @@ -310,6 +315,7 @@ typeAtom :: { Type ()} | qualProperName { TypeConstructor () (getQualifiedProperName $1) } | qualSymbol { TypeOpName () (getQualifiedOpName $1) } | string { uncurry (TypeString ()) $1 } + | int { uncurry (TypeInt () Nothing) $1 } | hole { TypeHole () $1 } | '(->)' { TypeArrName () $1 } | '{' row '}' { TypeRecord () (Wrapped $1 $2 $3) } @@ -324,6 +330,7 @@ typeKindedAtom :: { Type () } : '_' { TypeWildcard () $1 } | qualProperName { TypeConstructor () (getQualifiedProperName $1) } | qualSymbol { TypeOpName () (getQualifiedOpName $1) } + | int { uncurry (TypeInt () Nothing) $1 } | hole { TypeHole () $1 } | '{' row '}' { TypeRecord () (Wrapped $1 $2 $3) } | '(' row ')' { TypeRow () (Wrapped $1 $2 $3) } diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs index 41d1756f4c..88630805f9 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs @@ -9,6 +9,7 @@ import Prelude import Data.Foldable (foldl') import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Void (Void) import qualified Data.Text as Text @@ -244,6 +245,7 @@ typeRange = \case TypeWildcard _ a -> (a, a) TypeHole _ a -> nameRange a TypeString _ a _ -> (a, a) + TypeInt _ a b _ -> (fromMaybe b a, b) TypeRow _ a -> wrappedRange a TypeRecord _ a -> wrappedRange a TypeForall _ a _ _ b -> (a, snd $ typeRange b) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs b/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs index 9d4fd7195c..c3e6c97ef4 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs @@ -14,6 +14,7 @@ everythingOnTypes op k = goTy TypeWildcard _ _ -> k ty TypeHole _ _ -> k ty TypeString _ _ _ -> k ty + TypeInt _ _ _ _ -> k ty TypeRow _ (Wrapped _ row _) -> goRow ty row TypeRecord _ (Wrapped _ row _) -> goRow ty row TypeForall _ _ _ _ ty2 -> k ty `op` goTy ty2 diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Types.hs b/lib/purescript-cst/src/Language/PureScript/CST/Types.hs index ef3ebf153f..7450058e61 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Types.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Types.hs @@ -137,6 +137,7 @@ data Type a | TypeWildcard a SourceToken | TypeHole a (Name Ident) | TypeString a SourceToken PSString + | TypeInt a (Maybe SourceToken) SourceToken Integer | TypeRow a (Wrapped (Row a)) | TypeRecord a (Wrapped (Row a)) | TypeForall a SourceToken (NonEmpty (TypeVarBinding a)) SourceToken (Type a) diff --git a/lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs b/lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs index 7c823a17a0..2d86a8f109 100644 --- a/lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs +++ b/lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs @@ -42,6 +42,12 @@ pattern Row = Qualified (Just Prim) (ProperName "Row") pattern PrimBoolean :: ModuleName pattern PrimBoolean = ModuleName "Prim.Boolean" +booleanTrue :: Qualified (ProperName 'TypeName) +booleanTrue = Qualified (Just PrimBoolean) (ProperName "True") + +booleanFalse :: Qualified (ProperName 'TypeName) +booleanFalse = Qualified (Just PrimBoolean) (ProperName "False") + -- Prim.Coerce pattern PrimCoerce :: ModuleName @@ -95,6 +101,20 @@ pattern RowListNil = Qualified (Just PrimRowList) (ProperName "Nil") pattern RowListCons :: Qualified (ProperName 'TypeName) pattern RowListCons = Qualified (Just PrimRowList) (ProperName "Cons") +-- Prim.Int + +pattern PrimInt :: ModuleName +pattern PrimInt = ModuleName "Prim.Int" + +pattern IntAdd :: Qualified (ProperName 'ClassName) +pattern IntAdd = Qualified (Just PrimInt) (ProperName "Add") + +pattern IntCompare :: Qualified (ProperName 'ClassName) +pattern IntCompare = Qualified (Just PrimInt) (ProperName "Compare") + +pattern IntMul :: Qualified (ProperName 'ClassName) +pattern IntMul = Qualified (Just PrimInt) (ProperName "Mul") + -- Prim.Symbol pattern PrimSymbol :: ModuleName @@ -121,7 +141,7 @@ pattern Warn :: Qualified (ProperName 'ClassName) pattern Warn = Qualified (Just PrimTypeError) (ProperName "Warn") primModules :: [ModuleName] -primModules = [Prim, PrimBoolean, PrimCoerce, PrimOrdering, PrimRow, PrimRowList, PrimSymbol, PrimTypeError] +primModules = [Prim, PrimBoolean, PrimCoerce, PrimOrdering, PrimRow, PrimRowList, PrimSymbol, PrimInt, PrimTypeError] typ :: forall a. (IsString a) => a typ = "Type" @@ -167,5 +187,8 @@ moduleRowList = "RowList" moduleSymbol :: forall a. (IsString a) => a moduleSymbol = "Symbol" +moduleInt :: forall a. (IsString a) => a +moduleInt = "Int" + typeError :: forall a. (IsString a) => a typeError = "TypeError" diff --git a/lib/purescript-cst/src/Language/PureScript/Environment.hs b/lib/purescript-cst/src/Language/PureScript/Environment.hs index db3dcdcd97..be8b7fe899 100644 --- a/lib/purescript-cst/src/Language/PureScript/Environment.hs +++ b/lib/purescript-cst/src/Language/PureScript/Environment.hs @@ -370,6 +370,7 @@ allPrimTypes = M.unions , primRowTypes , primRowListTypes , primSymbolTypes + , primIntTypes , primTypeErrorTypes ] @@ -422,6 +423,14 @@ primSymbolTypes = , primClass (primSubName C.moduleSymbol "Cons") (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind) ] +primIntTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +primIntTypes = + M.fromList $ mconcat + [ primClass (primSubName C.moduleInt "Add") (\kind -> tyInt -:> tyInt -:> tyInt -:> kind) + , primClass (primSubName C.moduleInt "Compare") (\kind -> tyInt -:> tyInt -:> kindOrdering -:> kind) + , primClass (primSubName C.moduleInt "Mul") (\kind -> tyInt -:> tyInt -:> tyInt -:> kind) + ] + primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primTypeErrorTypes = M.fromList $ @@ -454,6 +463,7 @@ allPrimClasses = M.unions , primRowClasses , primRowListClasses , primSymbolClasses + , primIntClasses , primTypeErrorClasses ] @@ -553,6 +563,39 @@ primSymbolClasses = ] True) ] +primIntClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primIntClasses = + M.fromList + -- class Add (left :: Int) (right :: Int) (sum :: Int) | left right -> sum, left sum -> right, right sum -> left + [ (primSubName C.moduleInt "Add", makeTypeClassData + [ ("left", Just tyInt) + , ("right", Just tyInt) + , ("sum", Just tyInt) + ] [] [] + [ FunctionalDependency [0, 1] [2] + , FunctionalDependency [0, 2] [1] + , FunctionalDependency [1, 2] [0] + ] True) + + -- class Compare (left :: Int) (right :: Int) (ordering :: Ordering) | left right -> ordering + , (primSubName C.moduleInt "Compare", makeTypeClassData + [ ("left", Just tyInt) + , ("right", Just kindSymbol) + , ("ordering", Just kindSymbol) + ] [] [] + [ FunctionalDependency [0, 1] [2] + ] True) + + -- class Mul (left :: Int) (right :: Int) (product :: Int) | left right -> product + , (primSubName C.moduleInt "Mul", makeTypeClassData + [ ("left", Just tyInt) + , ("right", Just tyInt) + , ("product", Just tyInt) + ] [] [] + [ FunctionalDependency [0, 1] [2] + ] True) + ] + primTypeErrorClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primTypeErrorClasses = M.fromList diff --git a/lib/purescript-cst/src/Language/PureScript/Types.hs b/lib/purescript-cst/src/Language/PureScript/Types.hs index 7c35913873..2ff3d6bc4d 100644 --- a/lib/purescript-cst/src/Language/PureScript/Types.hs +++ b/lib/purescript-cst/src/Language/PureScript/Types.hs @@ -52,6 +52,8 @@ data Type a | TypeVar a Text -- | A type-level string | TypeLevelString a PSString + -- | A type-level natural + | TypeLevelInt a Integer -- | A type wildcard, as would appear in a partial type synonym | TypeWildcard a (Maybe Text) -- | A type constructor @@ -98,6 +100,9 @@ srcTypeVar = TypeVar NullSourceAnn srcTypeLevelString :: PSString -> SourceType srcTypeLevelString = TypeLevelString NullSourceAnn +srcTypeLevelInt :: Integer -> SourceType +srcTypeLevelInt = TypeLevelInt NullSourceAnn + srcTypeWildcard :: SourceType srcTypeWildcard = TypeWildcard NullSourceAnn Nothing @@ -212,6 +217,8 @@ typeToJSON annToJSON ty = variant "TypeVar" a b TypeLevelString a b -> variant "TypeLevelString" a b + TypeLevelInt a b -> + variant "TypeLevelInt" a b TypeWildcard a b -> variant "TypeWildcard" a b TypeConstructor a b -> @@ -296,6 +303,8 @@ typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do TypeVar a <$> contents "TypeLevelString" -> TypeLevelString a <$> contents + "TypeLevelInt" -> + TypeLevelInt a <$> contents "TypeWildcard" -> do b <- contents <|> pure Nothing pure $ TypeWildcard a b @@ -648,6 +657,7 @@ annForType :: Lens' (Type a) a annForType k (TUnknown a b) = (\z -> TUnknown z b) <$> k a annForType k (TypeVar a b) = (\z -> TypeVar z b) <$> k a annForType k (TypeLevelString a b) = (\z -> TypeLevelString z b) <$> k a +annForType k (TypeLevelInt a b) = (\z -> TypeLevelInt z b) <$> k a annForType k (TypeWildcard a b) = (\z -> TypeWildcard z b) <$> k a annForType k (TypeConstructor a b) = (\z -> TypeConstructor z b) <$> k a annForType k (TypeOp a b) = (\z -> TypeOp z b) <$> k a @@ -678,6 +688,7 @@ eqType :: Type a -> Type b -> Bool eqType (TUnknown _ a) (TUnknown _ a') = a == a' eqType (TypeVar _ a) (TypeVar _ a') = a == a' eqType (TypeLevelString _ a) (TypeLevelString _ a') = a == a' +eqType (TypeLevelInt _ a) (TypeLevelInt _ a') = a == a' eqType (TypeWildcard _ a) (TypeWildcard _ a') = a == a' eqType (TypeConstructor _ a) (TypeConstructor _ a') = a == a' eqType (TypeOp _ a) (TypeOp _ a') = a == a' @@ -702,6 +713,7 @@ compareType :: Type a -> Type b -> Ordering compareType (TUnknown _ a) (TUnknown _ a') = compare a a' compareType (TypeVar _ a) (TypeVar _ a') = compare a a' compareType (TypeLevelString _ a) (TypeLevelString _ a') = compare a a' +compareType (TypeLevelInt _ a) (TypeLevelInt _ a') = compare a a' compareType (TypeWildcard _ a) (TypeWildcard _ a') = compare a a' compareType (TypeConstructor _ a) (TypeConstructor _ a') = compare a a' compareType (TypeOp _ a) (TypeOp _ a') = compare a a' @@ -722,19 +734,20 @@ compareType typ typ' = orderOf TUnknown{} = 0 orderOf TypeVar{} = 1 orderOf TypeLevelString{} = 2 - orderOf TypeWildcard{} = 3 - orderOf TypeConstructor{} = 4 - orderOf TypeOp{} = 5 - orderOf TypeApp{} = 6 - orderOf KindApp{} = 7 - orderOf ForAll{} = 8 - orderOf ConstrainedType{} = 9 - orderOf Skolem{} = 10 - orderOf REmpty{} = 11 - orderOf RCons{} = 12 - orderOf KindedType{} = 13 - orderOf BinaryNoParensType{} = 14 - orderOf ParensInType{} = 15 + orderOf TypeLevelInt{} = 3 + orderOf TypeWildcard{} = 4 + orderOf TypeConstructor{} = 5 + orderOf TypeOp{} = 6 + orderOf TypeApp{} = 7 + orderOf KindApp{} = 8 + orderOf ForAll{} = 9 + orderOf ConstrainedType{} = 10 + orderOf Skolem{} = 11 + orderOf REmpty{} = 12 + orderOf RCons{} = 13 + orderOf KindedType{} = 14 + orderOf BinaryNoParensType{} = 15 + orderOf ParensInType{} = 16 compareMaybeType :: Maybe (Type a) -> Maybe (Type b) -> Ordering compareMaybeType (Just a) (Just b) = compareType a b diff --git a/purescript.cabal b/purescript.cabal index 4ec66c5ee1..8d681a7f0b 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -308,6 +308,7 @@ library Language.PureScript.TypeChecker Language.PureScript.TypeChecker.Entailment Language.PureScript.TypeChecker.Entailment.Coercible + Language.PureScript.TypeChecker.Entailment.IntCompare Language.PureScript.TypeChecker.Kinds Language.PureScript.TypeChecker.Monad Language.PureScript.TypeChecker.Roles diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index 39af647330..7ba65dbba1 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -273,6 +273,27 @@ pattern DataSymbol = ModuleName "Data.Symbol" pattern IsSymbol :: Qualified (ProperName 'ClassName) pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol") +pattern DataReflectable :: ModuleName +pattern DataReflectable = ModuleName "Data.Reflectable" + +pattern Reflectable :: Qualified (ProperName 'ClassName) +pattern Reflectable = Qualified (Just DataReflectable) (ProperName "Reflectable") + +pattern DataOrdering :: ModuleName +pattern DataOrdering = ModuleName "Data.Ordering" + +pattern Ordering :: Qualified (ProperName 'TypeName) +pattern Ordering = Qualified (Just DataOrdering) (ProperName "Ordering") + +pattern LT :: Qualified (ProperName 'ConstructorName) +pattern LT = Qualified (Just DataOrdering) (ProperName "LT") + +pattern EQ :: Qualified (ProperName 'ConstructorName) +pattern EQ = Qualified (Just DataOrdering) (ProperName "EQ") + +pattern GT :: Qualified (ProperName 'ConstructorName) +pattern GT = Qualified (Just DataOrdering) (ProperName "GT") + dataArray :: forall a. (IsString a) => a dataArray = "Data_Array" diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index ae7cb2a434..1509e9408b 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -26,6 +26,7 @@ primModules = , primRowDocsModule , primRowListDocsModule , primSymbolDocsModule + , primIntDocsModule , primTypeErrorDocsModule ] @@ -127,6 +128,18 @@ primSymbolDocsModule = Module , modReExports = [] } +primIntDocsModule :: Module +primIntDocsModule = Module + { modName = P.moduleNameFromString "Prim.Int" + , modComments = Just "The Prim.Int module is embedded in the PureScript compiler. Unlike `Prim`, it is not imported implicitly. It contains automatically solved type classes for working with type-level intural numbers." + , modDeclarations = + [ intAdd + , intCompare + , intMul + ] + , modReExports = [] + } + primTypeErrorDocsModule :: Module primTypeErrorDocsModule = Module { modName = P.moduleNameFromString "Prim.TypeError" @@ -195,6 +208,7 @@ lookupPrimClassOf g = unsafeLookupOf g P.primRowClasses <> P.primRowListClasses <> P.primSymbolClasses <> + P.primIntClasses <> P.primTypeErrorClasses ) "Docs.Prim: No such Prim class: " @@ -520,6 +534,22 @@ symbolCons = primClassOf (P.primSubName "Symbol") "Cons" $ T.unlines , "cannot be empty." ] +intAdd :: Declaration +intAdd = primClassOf (P.primSubName "Int") "Add" $ T.unlines + [ "Compiler solved type class for adding type-level `Int`s." + ] + +intCompare :: Declaration +intCompare = primClassOf (P.primSubName "Int") "Compare" $ T.unlines + [ "Compiler solved type class for comparing two type-level `Int`s." + , "Produces an `Ordering`." + ] + +intMul :: Declaration +intMul = primClassOf (P.primSubName "Int") "Mul" $ T.unlines + [ "Compiler solved type class for multiplying type-level `Int`s." + ] + fail :: Declaration fail = primClassOf (P.primSubName "TypeError") "Fail" $ T.unlines [ "The Fail type class is part of the custom type errors feature. To provide" diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index 7203c4c1d5..deae4be7bc 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -15,7 +15,7 @@ module Language.PureScript.Docs.RenderedCode.RenderType import Prelude.Compat import Data.Maybe (fromMaybe) -import Data.Text (Text) +import Data.Text (Text, pack) import Data.List (uncons) import Control.Arrow ((<+>)) @@ -55,6 +55,8 @@ typeLiterals = mkPattern match Just (typeOp n) match (PPTypeLevelString str) = Just (syntax (prettyPrintString str)) + match (PPTypeLevelInt nat) = + Just (syntax $ pack $ show nat) match _ = Nothing diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index 0cd30192f8..1768b30784 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -29,6 +29,9 @@ idePrimDeclarations = Map.fromList , ( C.PrimSymbol , mconcat [primSymbolTypes, primSymbolClasses] ) + , ( C.PrimInt + , mconcat [primIntTypes, primIntClasses] + ) , ( C.PrimTypeError , mconcat [primTypeErrorTypes, primTypeErrorClasses] ) @@ -55,10 +58,12 @@ idePrimDeclarations = Map.fromList primRowTypes = annType (removeClasses PEnv.primRowTypes PEnv.primRowClasses) primRowListTypes = annType (removeClasses PEnv.primRowListTypes PEnv.primRowListClasses) primSymbolTypes = annType (removeClasses PEnv.primSymbolTypes PEnv.primSymbolClasses) + primIntTypes = annType (removeClasses PEnv.primIntTypes PEnv.primIntClasses) primTypeErrorTypes = annType (removeClasses PEnv.primTypeErrorTypes PEnv.primTypeErrorClasses) primClasses = annClass PEnv.primClasses primRowClasses = annClass PEnv.primRowClasses primRowListClasses = annClass PEnv.primRowListClasses primSymbolClasses = annClass PEnv.primSymbolClasses + primIntClasses = annClass PEnv.primIntClasses primTypeErrorClasses = annClass PEnv.primTypeErrorClasses diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index c6559802bd..8b1bf2d7d2 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -113,6 +113,7 @@ lint modl@(Module _ _ mn ds _) = do go unused (BinaryNoParensType _ t1 t2 t3) = go unused t1 `combine` go unused t2 `combine` go unused t3 go unused TUnknown{} = (unused, mempty) go unused TypeLevelString{} = (unused, mempty) + go unused TypeLevelInt{} = (unused, mempty) go unused TypeWildcard{} = (unused, mempty) go unused TypeConstructor{} = (unused, mempty) go unused TypeOp{} = (unused, mempty) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 2c9f85677f..84e8a7acec 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -43,6 +43,7 @@ data PrettyPrintType = PPTUnknown Int | PPTypeVar Text (Maybe Text) | PPTypeLevelString PSString + | PPTypeLevelInt Integer | PPTypeWildcard (Maybe Text) | PPTypeConstructor (Qualified (ProperName 'TypeName)) | PPTypeOp (Qualified (OpName 'TypeOpName)) @@ -67,6 +68,7 @@ convertPrettyPrintType = go go _ (TUnknown _ n) = PPTUnknown n go _ (TypeVar _ t) = PPTypeVar t Nothing go _ (TypeLevelString _ s) = PPTypeLevelString s + go _ (TypeLevelInt _ n) = PPTypeLevelInt n go _ (TypeWildcard _ n) = PPTypeWildcard n go _ (TypeConstructor _ c) = PPTypeConstructor c go _ (TypeOp _ o) = PPTypeOp o @@ -186,6 +188,7 @@ matchTypeAtom tro@TypeRenderOptions{troSuggesting = suggesting} = match (PPTypeWildcard name) = Just $ text $ maybe "_" (('?' :) . T.unpack) name match (PPTypeVar var _) = Just $ text $ T.unpack var match (PPTypeLevelString s) = Just $ text $ T.unpack $ prettyPrintString s + match (PPTypeLevelInt n) = Just $ text $ show n match (PPTypeConstructor ctor) = Just $ text $ T.unpack $ runProperName $ disqualify ctor match (PPTUnknown u) | suggesting = Just $ text "_" diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 37bddb3f0f..d2dfc36365 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -204,6 +204,11 @@ primRowListExports = mkPrimExports primRowListTypes primRowListClasses primSymbolExports :: Exports primSymbolExports = mkPrimExports primSymbolTypes primSymbolClasses +-- | +-- The exported types from the @Prim.Int@ module +primIntExports :: Exports +primIntExports = mkPrimExports primIntTypes primIntClasses + -- | -- The exported types from the @Prim.TypeError@ module -- @@ -256,6 +261,9 @@ primEnv = M.fromList , ( C.PrimSymbol , (internalModuleSourceSpan "", nullImports, primSymbolExports) ) + , ( C.PrimInt + , (internalModuleSourceSpan "", nullImports, primIntExports) + ) , ( C.PrimTypeError , (internalModuleSourceSpan "", nullImports, primTypeErrorExports) ) diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index a5b5b59e2f..35b938b83f 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -58,6 +58,7 @@ desugarTypeClasses externs = flip evalStateT initialState . desugarModule , M.mapKeys (qualify C.PrimRow) primRowClasses , M.mapKeys (qualify C.PrimRowList) primRowListClasses , M.mapKeys (qualify C.PrimSymbol) primSymbolClasses + , M.mapKeys (qualify C.PrimInt) primIntClasses , M.mapKeys (qualify C.PrimTypeError) primTypeErrorClasses , M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) ] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 6f3846d4a4..13b97ada4d 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -238,6 +238,7 @@ checkTypeClassInstance cls i = check where check = \case TypeVar _ _ -> return () TypeLevelString _ _ -> return () + TypeLevelInt _ _ -> return () TypeConstructor _ _ -> return () TypeApp _ t1 t2 -> check t1 >> check t2 KindApp _ t k -> check t >> check k @@ -471,6 +472,7 @@ typeCheckAll moduleName _ = traverse go typeModule :: SourceType -> Maybe ModuleName typeModule (TypeVar _ _) = Nothing typeModule (TypeLevelString _ _) = Nothing + typeModule (TypeLevelInt _ _) = Nothing typeModule (TypeConstructor _ (Qualified (Just mn'') _)) = Just mn'' typeModule (TypeConstructor _ (Qualified Nothing _)) = internalError "Unqualified type name in findNonOrphanModules" typeModule (TypeApp _ t1 _) = typeModule t1 diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 5e265b4e9e..9d137d8545 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -37,6 +37,7 @@ import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.TypeChecker.Entailment.Coercible +import Language.PureScript.TypeChecker.Entailment.IntCompare import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds') import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) @@ -56,9 +57,29 @@ data Evidence -- | Computed instances | WarnInstance SourceType -- ^ Warn type class with a user-defined warning message | IsSymbolInstance PSString -- ^ The IsSymbol type class for a given Symbol literal + | ReflectableInstance Reflectable -- ^ The Reflectable type class for a reflectable kind | EmptyClassInstance -- ^ For any solved type class with no members deriving (Show, Eq) +-- | Describes kinds that are reflectable to the term-level +data Reflectable + = ReflectableInt Integer -- ^ For type-level numbers + | ReflectableString PSString -- ^ For type-level strings + | ReflectableBoolean Bool -- ^ For type-level booleans + | ReflectableOrdering Ordering -- ^ For type-level orderings + deriving (Show, Eq) + +-- | Reflect a reflectable type into an expression +asExpression :: Reflectable -> Expr +asExpression = \case + ReflectableInt n -> Literal NullSourceSpan $ NumericLiteral $ Left n + ReflectableString s -> Literal NullSourceSpan $ StringLiteral s + ReflectableBoolean b -> Literal NullSourceSpan $ BooleanLiteral b + ReflectableOrdering o -> Constructor NullSourceSpan $ case o of + LT -> C.LT + EQ -> C.EQ + GT -> C.GT + -- | Extract the identifier of a named instance namedInstanceIdentifier :: Evidence -> Maybe (Qualified Ident) namedInstanceIdentifier (NamedInstance i) = Just i @@ -181,6 +202,10 @@ entails SolverOptions{..} constraint context hints = forClassName _ _ C.SymbolCompare _ args | Just dicts <- solveSymbolCompare args = dicts forClassName _ _ C.SymbolAppend _ args | Just dicts <- solveSymbolAppend args = dicts forClassName _ _ C.SymbolCons _ args | Just dicts <- solveSymbolCons args = dicts + forClassName _ _ C.IntAdd _ args | Just dicts <- solveIntAdd args = dicts + forClassName _ ctx C.IntCompare _ args | Just dicts <- solveIntCompare ctx args = dicts + forClassName _ _ C.IntMul _ args | Just dicts <- solveIntMul args = dicts + forClassName _ _ C.Reflectable _ args | Just dicts <- solveReflectable args = dicts forClassName _ _ C.RowUnion kinds args | Just dicts <- solveUnion kinds args = dicts forClassName _ _ C.RowNub kinds args | Just dicts <- solveNub kinds args = dicts forClassName _ _ C.RowLacks kinds args | Just dicts <- solveLacks kinds args = dicts @@ -389,6 +414,9 @@ entails SolverOptions{..} constraint context hints = mkDictionary (IsSymbolInstance sym) _ = let fields = [ ("reflectSymbol", Abs (VarBinder nullSourceSpan UnusedIdent) (Literal nullSourceSpan (StringLiteral sym))) ] in return $ App (Constructor nullSourceSpan (coerceProperName . dictTypeName <$> C.IsSymbol)) (Literal nullSourceSpan (ObjectLiteral fields)) + mkDictionary (ReflectableInstance ref) _ = + let fields = [ ("reflectType", Abs (VarBinder nullSourceSpan UnusedIdent) (asExpression ref)) ] in + pure $ App (Constructor nullSourceSpan (coerceProperName . dictTypeName <$> C.Reflectable)) (Literal nullSourceSpan (ObjectLiteral fields)) unknownsInAllCoveringSets :: [SourceType] -> S.Set (S.Set Int) -> Bool unknownsInAllCoveringSets tyArgs = all (\s -> any (`S.member` s) unkIndices) @@ -477,6 +505,61 @@ entails SolverOptions{..} constraint context hints = pure (arg1, arg2, srcTypeLevelString (mkString $ h' <> t')) consSymbol _ _ _ = Nothing + solveReflectable :: [SourceType] -> Maybe [TypeClassDict] + solveReflectable [typeLevel, _] = do + (ref, typ) <- case typeLevel of + TypeLevelInt _ i -> pure (ReflectableInt i, tyInt) + TypeLevelString _ s -> pure (ReflectableString s, tyString) + TypeConstructor _ n + | n == C.booleanTrue -> pure (ReflectableBoolean True, tyBoolean) + | n == C.booleanFalse -> pure (ReflectableBoolean False, tyBoolean) + | n == C.orderingLT -> pure (ReflectableOrdering LT, srcTypeConstructor C.Ordering) + | n == C.orderingEQ -> pure (ReflectableOrdering EQ, srcTypeConstructor C.Ordering) + | n == C.orderingGT -> pure (ReflectableOrdering GT, srcTypeConstructor C.Ordering) + _ -> Nothing + pure [TypeClassDictionaryInScope Nothing 0 (ReflectableInstance ref) [] C.Reflectable [] [] [typeLevel, typ] Nothing Nothing] + solveReflectable _ = Nothing + + solveIntAdd :: [SourceType] -> Maybe [TypeClassDict] + solveIntAdd [arg0, arg1, arg2] = do + (arg0', arg1', arg2') <- addInts arg0 arg1 arg2 + let args' = [arg0', arg1', arg2'] + pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.IntAdd [] [] args' Nothing Nothing] + solveIntAdd _ = Nothing + + addInts :: SourceType -> SourceType -> SourceType -> Maybe (SourceType, SourceType, SourceType) + -- | l r -> o, l + r = o + addInts arg0@(TypeLevelInt _ l) arg1@(TypeLevelInt _ r) _ = pure (arg0, arg1, srcTypeLevelInt (l + r)) + -- | l o -> r, o - l = r + addInts arg0@(TypeLevelInt _ l) _ arg2@(TypeLevelInt _ o) = pure (arg0, srcTypeLevelInt (o - l), arg2) + -- | r o -> l, o - r = l + addInts _ arg1@(TypeLevelInt _ r) arg2@(TypeLevelInt _ o) = pure (srcTypeLevelInt (o - r), arg1, arg2) + addInts _ _ _ = Nothing + + solveIntCompare :: InstanceContext -> [SourceType] -> Maybe [TypeClassDict] + solveIntCompare _ [arg0@(TypeLevelInt _ a), arg1@(TypeLevelInt _ b), _] = + let ordering = case compare a b of + EQ -> C.orderingEQ + LT -> C.orderingLT + GT -> C.orderingGT + args' = [arg0, arg1, srcTypeConstructor ordering] + in pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.IntCompare [] [] args' Nothing Nothing] + solveIntCompare ctx args@[a, b, _] = do + let compareDictsInScope = findDicts ctx C.IntCompare Nothing + givens = flip mapMaybe compareDictsInScope $ \case + dict | [a', b', c'] <- tcdInstanceTypes dict -> mkRelation a' b' c' + | otherwise -> Nothing + facts = mkFacts (args : (tcdInstanceTypes <$> compareDictsInScope)) + c' <- solveRelation (givens <> facts) a b + pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.IntCompare [] [] [a, b, srcTypeConstructor c'] Nothing Nothing] + solveIntCompare _ _ = Nothing + + solveIntMul :: [SourceType] -> Maybe [TypeClassDict] + solveIntMul [arg0@(TypeLevelInt _ l), arg1@(TypeLevelInt _ r), _] = + let args' = [arg0, arg1, srcTypeLevelInt (l * r)] + in pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.IntMul [] [] args' Nothing Nothing] + solveIntMul _ = Nothing + solveUnion :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] solveUnion kinds [l, r, u] = do (lOut, rOut, uOut, cst, vars) <- unionRows kinds l r u @@ -643,6 +726,7 @@ matches deps TypeClassDictionaryInScope{..} tys = typeHeadsAreEqual t (TypeVar _ v) = (Match (), M.singleton v [t]) typeHeadsAreEqual (TypeConstructor _ c1) (TypeConstructor _ c2) | c1 == c2 = (Match (), M.empty) typeHeadsAreEqual (TypeLevelString _ s1) (TypeLevelString _ s2) | s1 == s2 = (Match (), M.empty) + typeHeadsAreEqual (TypeLevelInt _ n1) (TypeLevelInt _ n2) | n1 == n2 = (Match (), M.empty) typeHeadsAreEqual (TypeApp _ h1 t1) (TypeApp _ h2 t2) = both (typeHeadsAreEqual h1 h2) (typeHeadsAreEqual t1 t2) typeHeadsAreEqual (KindApp _ h1 t1) (KindApp _ h2 t2) = @@ -690,6 +774,7 @@ matches deps TypeClassDictionaryInScope{..} tys = typesAreEqual t1 (Skolem _ _ _ s2 _) = if t1 `containsSkolem` s2 then Apart else Unknown typesAreEqual (TypeVar _ v1) (TypeVar _ v2) | v1 == v2 = Match () typesAreEqual (TypeLevelString _ s1) (TypeLevelString _ s2) | s1 == s2 = Match () + typesAreEqual (TypeLevelInt _ n1) (TypeLevelInt _ n2) | n1 == n2 = Match () typesAreEqual (TypeConstructor _ c1) (TypeConstructor _ c2) | c1 == c2 = Match () typesAreEqual (TypeApp _ h1 t1) (TypeApp _ h2 t2) = typesAreEqual h1 h2 <> typesAreEqual t1 t2 typesAreEqual (KindApp _ h1 t1) (KindApp _ h2 t2) = typesAreEqual h1 h2 <> typesAreEqual t1 t2 diff --git a/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs b/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs new file mode 100644 index 0000000000..50f2205ffb --- /dev/null +++ b/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs @@ -0,0 +1,102 @@ +-- | +-- Graph-based solver for comparing type-level numbers with respect to +-- reflexivity, symmetry, and transitivity properties. +-- +module Language.PureScript.TypeChecker.Entailment.IntCompare where + +import Protolude + +import qualified Data.Graph as G +import qualified Data.Map as M + +import qualified Language.PureScript.Names as P +import qualified Language.PureScript.Types as P +import qualified Language.PureScript.Constants.Prim as P + +data Relation a + = Equal a a + | LessThan a a + deriving (Functor, Show, Eq, Ord) + +type Context a = [Relation a] + +type PSOrdering = P.Qualified (P.ProperName 'P.TypeName) + +-- Commentary: +-- +-- In essence, this solver builds a directed graph using the provided +-- context, which is then used to determine the relationship between +-- the two elements being compared. +-- +-- Given the context [a < b, b < c], we can infer that a < c as a +-- path exists from a to c. Likewise, we can also infer that c > a +-- as a path exists from c to a. +-- +-- ╔═══╗ ╔═══╗ ╔═══╗ +-- ║ a ║ -> ║ b ║ -> ║ c ║ +-- ╚═══╝ ╚═══╝ ╚═══╝ +-- +-- Introducing equality to the context augments the graph further, +-- and it is represented by creating cycles between equal nodes. +-- For example, [a < b, b < c, c = d] yields the following graph: +-- +-- ╔═══╗ ╔═══╗ ╔═══╗ ╔═══╗ +-- ║ a ║ -> ║ b ║ -> ║ c ║ <-> ║ d ║ +-- ╚═══╝ ╚═══╝ ╚═══╝ ╚═══╝ +solveRelation :: forall a. Ord a => Context a -> a -> a -> Maybe PSOrdering +solveRelation context lhs rhs = + if lhs == rhs then + pure P.orderingEQ + else do + let (graph, search) = inequalities + lhs' <- search lhs + rhs' <- search rhs + case (G.path graph lhs' rhs', G.path graph rhs' lhs') of + (True, True) -> + pure P.orderingEQ + (True, False) -> + pure P.orderingLT + (False, True) -> + pure P.orderingGT + _ -> + Nothing + where + inequalities :: (G.Graph, a -> Maybe G.Vertex) + inequalities = makeGraph $ clean $ foldMap convert context + where + convert :: Relation a -> [(a, [a])] + convert (Equal a b) = [(a, [b]), (b, [a])] + convert (LessThan a b) = [(a, [b]), (b, [])] + + makeGraph :: [(a, [a])] -> (G.Graph, a -> Maybe G.Vertex) + makeGraph m = + case G.graphFromEdges $ (\(a, b) -> (a, a, b)) <$> m of + (g, _, f) -> (g, f) + + clean :: forall k. Ord k => [(k, [k])] -> [(k, [k])] + clean = M.toList . M.fromListWith (<>) + +mkRelation :: P.Type a -> P.Type a -> P.Type a -> Maybe (Relation (P.Type a)) +mkRelation lhs rhs rel = case rel of + P.TypeConstructor _ ordering + | ordering == P.orderingEQ -> pure $ Equal lhs rhs + | ordering == P.orderingLT -> pure $ LessThan lhs rhs + | ordering == P.orderingGT -> pure $ LessThan rhs lhs + _ -> + Nothing + +mkFacts :: [[P.Type a]] -> [Relation (P.Type a)] +mkFacts = mkRels [] . sort . findFacts + where + mkRels a [] = concat a + mkRels a (x : xs) = mkRels (map (LessThan x) xs : a) xs + + findFacts = mapMaybe $ \case + [P.TypeLevelInt _ _, P.TypeLevelInt _ _, _] -> + Nothing + [i@(P.TypeLevelInt _ _), _, _] -> + Just i + [_, i@(P.TypeLevelInt _ _), _] -> + Just i + _ -> + Nothing diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index e8e138c5c3..2f46ab8642 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -185,6 +185,8 @@ inferKind = \tyToInfer -> pure (ConstrainedType ann' con'' ty', E.kindType $> ann') ty@(TypeLevelString ann _) -> pure (ty, E.kindSymbol $> ann) + ty@(TypeLevelInt ann _) -> + pure (ty, E.tyInt $> ann) ty@(TypeVar ann v) -> do moduleName <- unsafeCheckCurrentModule kind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing $ ProperName v) @@ -486,6 +488,8 @@ elaborateKind elaborateKind = \case TypeLevelString ann _ -> pure $ E.kindSymbol $> ann + TypeLevelInt ann _ -> + pure $ E.tyInt $> ann TypeConstructor ann v -> do env <- getEnv case M.lookup v (E.types env) of diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index bb7fb0ce8a..9bcde68465 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -131,6 +131,7 @@ unifyTypes t1 t2 = do unifyTypes' ty1@(TypeConstructor _ c1) ty2@(TypeConstructor _ c2) = guardWith (errorMessage (TypesDoNotUnify ty1 ty2)) (c1 == c2) unifyTypes' (TypeLevelString _ s1) (TypeLevelString _ s2) | s1 == s2 = return () + unifyTypes' (TypeLevelInt _ n1) (TypeLevelInt _ n2) | n1 == n2 = return () unifyTypes' (TypeApp _ t3 t4) (TypeApp _ t5 t6) = do t3 `unifyTypes` t5 t4 `unifyTypes` t6 diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index f09a4da753..4a4eeee53d 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -29,7 +29,8 @@ spec = do P.primRowTypes <> P.primRowListTypes <> P.primTypeErrorTypes <> - P.primSymbolTypes ) + P.primSymbolTypes <> + P.primIntTypes ) let documentedPrimNames = map D.declTitle (concatMap D.modDeclarations D.primModules) diff --git a/tests/purs/failing/CompareInt1.out b/tests/purs/failing/CompareInt1.out new file mode 100644 index 0000000000..452403b8b6 --- /dev/null +++ b/tests/purs/failing/CompareInt1.out @@ -0,0 +1,43 @@ +Error found: +in module Main +at tests/purs/failing/CompareInt1.purs:14:16 - 14:29 (line 14, column 16 - line 14, column 29) + + Could not match type +   +  EQ +   + with type +   +  GT +   + +while solving type class constraint +  + Prim.Int.Compare a0 + b1 + GT +  +while checking that type forall (l :: Int) (r :: Int).  +  Compare l r GT => Proxy @(Row Int) +  ( left :: l  +  , right :: r  +  )  + is at least as general as type Proxy @(Row Int) +  ( left :: a0  +  , right :: b1  +  )  +while checking that expression assertGreater + has type Proxy @(Row Int) +  ( left :: a0  +  , right :: b1  +  )  +in value declaration impossible + +where a0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + b1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CompareInt1.purs b/tests/purs/failing/CompareInt1.purs new file mode 100644 index 0000000000..d53a28c5f7 --- /dev/null +++ b/tests/purs/failing/CompareInt1.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prim.Int (class Compare) +import Prim.Ordering (EQ, GT, LT) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +assertGreater :: forall l r. Compare l r GT => Proxy ( left :: l, right :: r ) +assertGreater = Proxy + +impossible :: forall a b c. Compare a b EQ => Compare b c GT => Proxy c -> Proxy ( left :: a, right :: b ) +impossible _ = assertGreater diff --git a/tests/purs/failing/CompareInt10.out b/tests/purs/failing/CompareInt10.out new file mode 100644 index 0000000000..35b30cb145 --- /dev/null +++ b/tests/purs/failing/CompareInt10.out @@ -0,0 +1,43 @@ +Error found: +in module Main +at tests/purs/failing/CompareInt10.purs:14:16 - 14:27 (line 14, column 16 - line 14, column 27) + + Could not match type +   +  LT +   + with type +   +  EQ +   + +while solving type class constraint +  + Prim.Int.Compare c0 + a1 + EQ +  +while checking that type forall (l :: Int) (r :: Int).  +  Compare l r EQ => Proxy @(Row Int) +  ( left :: l  +  , right :: r  +  )  + is at least as general as type Proxy @(Row Int) +  ( left :: c0  +  , right :: a1  +  )  +while checking that expression assertEqual + has type Proxy @(Row Int) +  ( left :: c0  +  , right :: a1  +  )  +in value declaration impossible + +where a1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + c0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CompareInt10.purs b/tests/purs/failing/CompareInt10.purs new file mode 100644 index 0000000000..fef893fbcf --- /dev/null +++ b/tests/purs/failing/CompareInt10.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prim.Int (class Compare) +import Prim.Ordering (EQ, GT, LT) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +assertEqual :: forall l r. Compare l r EQ => Proxy ( left :: l, right :: r ) +assertEqual = Proxy + +impossible :: forall a b c. Compare a b GT => Compare b c GT => Proxy c -> Proxy ( left :: c, right :: a ) +impossible _ = assertEqual diff --git a/tests/purs/failing/CompareInt11.out b/tests/purs/failing/CompareInt11.out new file mode 100644 index 0000000000..930710c038 --- /dev/null +++ b/tests/purs/failing/CompareInt11.out @@ -0,0 +1,33 @@ +Error found: +in module Main +at tests/purs/failing/CompareInt11.purs:14:14 - 14:26 (line 14, column 14 - line 14, column 26) + + No type class instance was found for +   +  Prim.Int.Compare a0 +  5  +  LT +   + +while checking that type forall (l :: Int) (r :: Int).  +  Compare l r LT => Proxy @(Row Int) +  ( left :: l  +  , right :: r  +  )  + is at least as general as type Proxy @(Row Int) +  ( left :: a0  +  , right :: 5  +  )  +while checking that expression assertLesser + has type Proxy @(Row Int) +  ( left :: a0  +  , right :: 5  +  )  +in value declaration impossible + +where a0 is a rigid type variable + bound at (line 14, column 14 - line 14, column 26) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CompareInt11.purs b/tests/purs/failing/CompareInt11.purs new file mode 100644 index 0000000000..a5ae237841 --- /dev/null +++ b/tests/purs/failing/CompareInt11.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Prim.Int (class Compare) +import Prim.Ordering (EQ, GT, LT) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +assertLesser :: forall l r. Compare l r LT => Proxy ( left :: l, right :: r ) +assertLesser = Proxy + +impossible :: forall a. Compare a 10 LT => Proxy ( left :: a, right :: 5 ) +impossible = assertLesser diff --git a/tests/purs/failing/CompareInt12.out b/tests/purs/failing/CompareInt12.out new file mode 100644 index 0000000000..8a56b46db2 --- /dev/null +++ b/tests/purs/failing/CompareInt12.out @@ -0,0 +1,33 @@ +Error found: +in module Main +at tests/purs/failing/CompareInt12.purs:14:14 - 14:27 (line 14, column 14 - line 14, column 27) + + No type class instance was found for +   +  Prim.Int.Compare a0 +  20 +  GT +   + +while checking that type forall (l :: Int) (r :: Int).  +  Compare l r GT => Proxy @(Row Int) +  ( left :: l  +  , right :: r  +  )  + is at least as general as type Proxy @(Row Int) +  ( left :: a0  +  , right :: 20  +  )  +while checking that expression assertGreater + has type Proxy @(Row Int) +  ( left :: a0  +  , right :: 20  +  )  +in value declaration impossible + +where a0 is a rigid type variable + bound at (line 14, column 14 - line 14, column 27) + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CompareInt12.purs b/tests/purs/failing/CompareInt12.purs new file mode 100644 index 0000000000..9e1bbef689 --- /dev/null +++ b/tests/purs/failing/CompareInt12.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Prim.Int (class Compare) +import Prim.Ordering (EQ, GT, LT) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +assertGreater :: forall l r. Compare l r GT => Proxy ( left :: l, right :: r ) +assertGreater = Proxy + +impossible :: forall a. Compare a 10 GT => Proxy ( left :: a, right :: 20 ) +impossible = assertGreater diff --git a/tests/purs/failing/CompareInt2.out b/tests/purs/failing/CompareInt2.out new file mode 100644 index 0000000000..8817b303d9 --- /dev/null +++ b/tests/purs/failing/CompareInt2.out @@ -0,0 +1,43 @@ +Error found: +in module Main +at tests/purs/failing/CompareInt2.purs:14:14 - 14:27 (line 14, column 14 - line 14, column 27) + + Could not match type +   +  LT +   + with type +   +  GT +   + +while solving type class constraint +  + Prim.Int.Compare b0 + a1 + GT +  +while checking that type forall (l :: Int) (r :: Int).  +  Compare l r GT => Proxy @(Row Int) +  ( left :: l  +  , right :: r  +  )  + is at least as general as type Proxy @(Row Int) +  ( left :: b0  +  , right :: a1  +  )  +while checking that expression assertGreater + has type Proxy @(Row Int) +  ( left :: b0  +  , right :: a1  +  )  +in value declaration impossible + +where a1 is a rigid type variable + bound at (line 14, column 14 - line 14, column 27) + b0 is a rigid type variable + bound at (line 14, column 14 - line 14, column 27) + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CompareInt2.purs b/tests/purs/failing/CompareInt2.purs new file mode 100644 index 0000000000..06ba919f83 --- /dev/null +++ b/tests/purs/failing/CompareInt2.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prim.Int (class Compare) +import Prim.Ordering (EQ, GT, LT) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +assertGreater :: forall l r. Compare l r GT => Proxy ( left :: l, right :: r ) +assertGreater = Proxy + +impossible :: forall a b. Compare a b GT => Proxy ( left :: b, right :: a ) +impossible = assertGreater diff --git a/tests/purs/failing/CompareInt3.out b/tests/purs/failing/CompareInt3.out new file mode 100644 index 0000000000..35c8a1d0da --- /dev/null +++ b/tests/purs/failing/CompareInt3.out @@ -0,0 +1,43 @@ +Error found: +in module Main +at tests/purs/failing/CompareInt3.purs:14:16 - 14:28 (line 14, column 16 - line 14, column 28) + + Could not match type +   +  EQ +   + with type +   +  LT +   + +while solving type class constraint +  + Prim.Int.Compare a0 + b1 + LT +  +while checking that type forall (l :: Int) (r :: Int).  +  Compare l r LT => Proxy @(Row Int) +  ( left :: l  +  , right :: r  +  )  + is at least as general as type Proxy @(Row Int) +  ( left :: a0  +  , right :: b1  +  )  +while checking that expression assertLesser + has type Proxy @(Row Int) +  ( left :: a0  +  , right :: b1  +  )  +in value declaration impossible + +where a0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + b1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CompareInt3.purs b/tests/purs/failing/CompareInt3.purs new file mode 100644 index 0000000000..93bc00b8c2 --- /dev/null +++ b/tests/purs/failing/CompareInt3.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prim.Int (class Compare) +import Prim.Ordering (EQ, GT, LT) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +assertLesser :: forall l r. Compare l r LT => Proxy ( left :: l, right :: r ) +assertLesser = Proxy + +impossible :: forall a b c. Compare a b EQ => Compare b c LT => Proxy c -> Proxy ( left :: a, right :: b ) +impossible _ = assertLesser diff --git a/tests/purs/failing/CompareInt4.out b/tests/purs/failing/CompareInt4.out new file mode 100644 index 0000000000..d2c7f2956d --- /dev/null +++ b/tests/purs/failing/CompareInt4.out @@ -0,0 +1,43 @@ +Error found: +in module Main +at tests/purs/failing/CompareInt4.purs:14:14 - 14:26 (line 14, column 14 - line 14, column 26) + + Could not match type +   +  GT +   + with type +   +  LT +   + +while solving type class constraint +  + Prim.Int.Compare b0 + a1 + LT +  +while checking that type forall (l :: Int) (r :: Int).  +  Compare l r LT => Proxy @(Row Int) +  ( left :: l  +  , right :: r  +  )  + is at least as general as type Proxy @(Row Int) +  ( left :: b0  +  , right :: a1  +  )  +while checking that expression assertLesser + has type Proxy @(Row Int) +  ( left :: b0  +  , right :: a1  +  )  +in value declaration impossible + +where a1 is a rigid type variable + bound at (line 14, column 14 - line 14, column 26) + b0 is a rigid type variable + bound at (line 14, column 14 - line 14, column 26) + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CompareInt4.purs b/tests/purs/failing/CompareInt4.purs new file mode 100644 index 0000000000..fca2e6d42a --- /dev/null +++ b/tests/purs/failing/CompareInt4.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prim.Int (class Compare) +import Prim.Ordering (EQ, GT, LT) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +assertLesser :: forall l r. Compare l r LT => Proxy ( left :: l, right :: r ) +assertLesser = Proxy + +impossible :: forall a b. Compare a b LT => Proxy ( left :: b, right :: a ) +impossible = assertLesser diff --git a/tests/purs/failing/CompareInt5.out b/tests/purs/failing/CompareInt5.out new file mode 100644 index 0000000000..a7e90314c4 --- /dev/null +++ b/tests/purs/failing/CompareInt5.out @@ -0,0 +1,43 @@ +Error found: +in module Main +at tests/purs/failing/CompareInt5.purs:14:16 - 14:29 (line 14, column 16 - line 14, column 29) + + Could not match type +   +  LT +   + with type +   +  GT +   + +while solving type class constraint +  + Prim.Int.Compare c0 + a1 + GT +  +while checking that type forall (l :: Int) (r :: Int).  +  Compare l r GT => Proxy @(Row Int) +  ( left :: l  +  , right :: r  +  )  + is at least as general as type Proxy @(Row Int) +  ( left :: c0  +  , right :: a1  +  )  +while checking that expression assertGreater + has type Proxy @(Row Int) +  ( left :: c0  +  , right :: a1  +  )  +in value declaration impossible + +where a1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + c0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CompareInt5.purs b/tests/purs/failing/CompareInt5.purs new file mode 100644 index 0000000000..f4f8fba8a8 --- /dev/null +++ b/tests/purs/failing/CompareInt5.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prim.Int (class Compare) +import Prim.Ordering (EQ, GT, LT) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +assertGreater :: forall l r. Compare l r GT => Proxy ( left :: l, right :: r ) +assertGreater = Proxy + +impossible :: forall a b c. Compare a b GT => Compare b c GT => Proxy c -> Proxy ( left :: c, right :: a ) +impossible _ = assertGreater diff --git a/tests/purs/failing/CompareInt6.out b/tests/purs/failing/CompareInt6.out new file mode 100644 index 0000000000..a355c5dba3 --- /dev/null +++ b/tests/purs/failing/CompareInt6.out @@ -0,0 +1,43 @@ +Error found: +in module Main +at tests/purs/failing/CompareInt6.purs:14:16 - 14:28 (line 14, column 16 - line 14, column 28) + + Could not match type +   +  GT +   + with type +   +  LT +   + +while solving type class constraint +  + Prim.Int.Compare c0 + a1 + LT +  +while checking that type forall (l :: Int) (r :: Int).  +  Compare l r LT => Proxy @(Row Int) +  ( left :: l  +  , right :: r  +  )  + is at least as general as type Proxy @(Row Int) +  ( left :: c0  +  , right :: a1  +  )  +while checking that expression assertLesser + has type Proxy @(Row Int) +  ( left :: c0  +  , right :: a1  +  )  +in value declaration impossible + +where a1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + c0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CompareInt6.purs b/tests/purs/failing/CompareInt6.purs new file mode 100644 index 0000000000..d9ba79f870 --- /dev/null +++ b/tests/purs/failing/CompareInt6.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prim.Int (class Compare) +import Prim.Ordering (EQ, GT, LT) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +assertLesser :: forall l r. Compare l r LT => Proxy ( left :: l, right :: r ) +assertLesser = Proxy + +impossible :: forall a b c. Compare a b LT => Compare b c LT => Proxy c -> Proxy ( left :: c, right :: a ) +impossible _ = assertLesser diff --git a/tests/purs/failing/CompareInt7.out b/tests/purs/failing/CompareInt7.out new file mode 100644 index 0000000000..f065e86703 --- /dev/null +++ b/tests/purs/failing/CompareInt7.out @@ -0,0 +1,43 @@ +Error found: +in module Main +at tests/purs/failing/CompareInt7.purs:14:16 - 14:27 (line 14, column 16 - line 14, column 27) + + Could not match type +   +  LT +   + with type +   +  EQ +   + +while solving type class constraint +  + Prim.Int.Compare a0 + c1 + EQ +  +while checking that type forall (l :: Int) (r :: Int).  +  Compare l r EQ => Proxy @(Row Int) +  ( left :: l  +  , right :: r  +  )  + is at least as general as type Proxy @(Row Int) +  ( left :: a0  +  , right :: c1  +  )  +while checking that expression assertEqual + has type Proxy @(Row Int) +  ( left :: a0  +  , right :: c1  +  )  +in value declaration impossible + +where a0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + c1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CompareInt7.purs b/tests/purs/failing/CompareInt7.purs new file mode 100644 index 0000000000..2155a911d2 --- /dev/null +++ b/tests/purs/failing/CompareInt7.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prim.Int (class Compare) +import Prim.Ordering (EQ, GT, LT) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +assertEqual :: forall l r. Compare l r EQ => Proxy ( left :: l, right :: r ) +assertEqual = Proxy + +impossible :: forall a b c. Compare a b LT => Compare b c LT => Proxy c -> Proxy ( left :: a, right :: c ) +impossible _ = assertEqual diff --git a/tests/purs/failing/CompareInt8.out b/tests/purs/failing/CompareInt8.out new file mode 100644 index 0000000000..e7c4cbd1d0 --- /dev/null +++ b/tests/purs/failing/CompareInt8.out @@ -0,0 +1,43 @@ +Error found: +in module Main +at tests/purs/failing/CompareInt8.purs:14:16 - 14:27 (line 14, column 16 - line 14, column 27) + + Could not match type +   +  GT +   + with type +   +  EQ +   + +while solving type class constraint +  + Prim.Int.Compare a0 + c1 + EQ +  +while checking that type forall (l :: Int) (r :: Int).  +  Compare l r EQ => Proxy @(Row Int) +  ( left :: l  +  , right :: r  +  )  + is at least as general as type Proxy @(Row Int) +  ( left :: a0  +  , right :: c1  +  )  +while checking that expression assertEqual + has type Proxy @(Row Int) +  ( left :: a0  +  , right :: c1  +  )  +in value declaration impossible + +where a0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + c1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CompareInt8.purs b/tests/purs/failing/CompareInt8.purs new file mode 100644 index 0000000000..85bf481870 --- /dev/null +++ b/tests/purs/failing/CompareInt8.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prim.Int (class Compare) +import Prim.Ordering (EQ, GT, LT) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +assertEqual :: forall l r. Compare l r EQ => Proxy ( left :: l, right :: r ) +assertEqual = Proxy + +impossible :: forall a b c. Compare a b GT => Compare b c GT => Proxy c -> Proxy ( left :: a, right :: c ) +impossible _ = assertEqual diff --git a/tests/purs/failing/CompareInt9.out b/tests/purs/failing/CompareInt9.out new file mode 100644 index 0000000000..9e55dcf883 --- /dev/null +++ b/tests/purs/failing/CompareInt9.out @@ -0,0 +1,43 @@ +Error found: +in module Main +at tests/purs/failing/CompareInt9.purs:14:16 - 14:27 (line 14, column 16 - line 14, column 27) + + Could not match type +   +  GT +   + with type +   +  EQ +   + +while solving type class constraint +  + Prim.Int.Compare c0 + a1 + EQ +  +while checking that type forall (l :: Int) (r :: Int).  +  Compare l r EQ => Proxy @(Row Int) +  ( left :: l  +  , right :: r  +  )  + is at least as general as type Proxy @(Row Int) +  ( left :: c0  +  , right :: a1  +  )  +while checking that expression assertEqual + has type Proxy @(Row Int) +  ( left :: c0  +  , right :: a1  +  )  +in value declaration impossible + +where a1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + c0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/CompareInt9.purs b/tests/purs/failing/CompareInt9.purs new file mode 100644 index 0000000000..21743243b2 --- /dev/null +++ b/tests/purs/failing/CompareInt9.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prim.Int (class Compare) +import Prim.Ordering (EQ, GT, LT) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +assertEqual :: forall l r. Compare l r EQ => Proxy ( left :: l, right :: r ) +assertEqual = Proxy + +impossible :: forall a b c. Compare a b LT => Compare b c LT => Proxy c -> Proxy ( left :: c, right :: a ) +impossible _ = assertEqual diff --git a/tests/purs/failing/IntAsRecordLabel.out b/tests/purs/failing/IntAsRecordLabel.out new file mode 100644 index 0000000000..c991b689b9 --- /dev/null +++ b/tests/purs/failing/IntAsRecordLabel.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/IntAsRecordLabel.purs:4:27 - 4:29 (line 4, column 27 - line 4, column 29) + + Unable to parse module: + Unexpected token '42' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/IntAsRecordLabel.purs b/tests/purs/failing/IntAsRecordLabel.purs new file mode 100644 index 0000000000..27f2fadeb3 --- /dev/null +++ b/tests/purs/failing/IntAsRecordLabel.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +type IntAsRecordLabel = { 42 :: Int } diff --git a/tests/purs/layout/IntType.out b/tests/purs/layout/IntType.out new file mode 100644 index 0000000000..b05e2ac44a --- /dev/null +++ b/tests/purs/layout/IntType.out @@ -0,0 +1,8 @@ +module Test where{ + +type IntType = (-1); + +type IntType' = (- + -- here's a comment + 1)} + \ No newline at end of file diff --git a/tests/purs/layout/IntType.purs b/tests/purs/layout/IntType.purs new file mode 100644 index 0000000000..b6e70dc476 --- /dev/null +++ b/tests/purs/layout/IntType.purs @@ -0,0 +1,7 @@ +module Test where + +type IntType = (-1) + +type IntType' = (- + -- here's a comment + 1) diff --git a/tests/purs/passing/ParseTypeInt.purs b/tests/purs/passing/ParseTypeInt.purs new file mode 100644 index 0000000000..edd7d89d6c --- /dev/null +++ b/tests/purs/passing/ParseTypeInt.purs @@ -0,0 +1,28 @@ +module Main where + +import Effect.Console (log) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +a :: Proxy 42 +a = Proxy + +b :: Proxy (-42) +b = Proxy + +c :: Proxy (42 :: Int) +c = Proxy + +d :: Proxy ((42) :: Int) +d = Proxy + +e :: Proxy ((-42) :: Int) +e = Proxy + +f :: Proxy (- + -- here's a comment + 1) +f = Proxy + +main = log "Done" diff --git a/tests/purs/passing/SolvingAddInt.purs b/tests/purs/passing/SolvingAddInt.purs new file mode 100644 index 0000000000..16c44fb5fb --- /dev/null +++ b/tests/purs/passing/SolvingAddInt.purs @@ -0,0 +1,26 @@ +module Main where + +import Effect.Console (log) +import Prim.Int (class Add) + +data Proxy k = Proxy + +a :: forall n. Add 21 21 n => Proxy n +a = Proxy + +a' :: Proxy 42 +a' = a + +b :: forall n. Add 21 n 42 => Proxy n +b = Proxy + +b' :: Proxy 21 +b' = b + +c :: forall n. Add n 21 42 => Proxy n +c = Proxy + +c' :: Proxy 21 +c' = c + +main = log "Done" diff --git a/tests/purs/passing/SolvingCompareInt.purs b/tests/purs/passing/SolvingCompareInt.purs new file mode 100644 index 0000000000..bfd0d9e592 --- /dev/null +++ b/tests/purs/passing/SolvingCompareInt.purs @@ -0,0 +1,106 @@ +module Main where + +import Effect.Console (log) +import Prim.Int (class Compare) +import Prim.Ordering (EQ, GT, LT) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +assertLesser :: forall l r. Compare l r LT => Proxy ( left :: l, right :: r ) +assertLesser = Proxy + +assertGreater :: forall l r. Compare l r GT => Proxy ( left :: l, right :: r ) +assertGreater = Proxy + +assertEqual :: forall l r. Compare l r EQ => Proxy ( left :: l, right :: r ) +assertEqual = Proxy + +symmLt :: forall m n. Compare m n GT => Proxy ( left :: n, right :: m ) +symmLt = assertLesser + +symmGt :: forall m n. Compare m n LT => Proxy ( left :: n, right :: m ) +symmGt = assertGreater + +symmEq :: forall m n. Compare m n EQ => Proxy ( left :: n, right :: m ) +symmEq = assertEqual + +reflEq :: forall (n :: Int). Proxy ( left :: n, right :: n ) +reflEq = assertEqual + +transLt :: forall m n p. Compare m n LT => Compare n p LT => Proxy n -> Proxy ( left :: m, right :: p ) +transLt _ = assertLesser + +transLtEq :: forall m n p. Compare m n LT => Compare n p EQ => Proxy n -> Proxy ( left :: m, right :: p ) +transLtEq _ = assertLesser + +transEqLt :: forall m n p. Compare m n EQ => Compare n p LT => Proxy n -> Proxy ( left :: m, right :: p ) +transEqLt _ = assertLesser + +transGt :: forall m n p. Compare m n GT => Compare n p GT => Proxy n -> Proxy ( left :: m, right :: p ) +transGt _ = assertGreater + +transGtEq :: forall m n p. Compare m n GT => Compare n p EQ => Proxy n -> Proxy ( left :: m, right :: p ) +transGtEq _ = assertGreater + +transEqGt :: forall m n p. Compare m n EQ => Compare n p GT => Proxy n -> Proxy ( left :: m, right :: p ) +transEqGt _ = assertGreater + +transEq :: forall m n p. Compare m n EQ => Compare n p EQ => Proxy n -> Proxy ( left :: m, right :: p ) +transEq _ = assertEqual + +transSymmLt :: forall m n p. Compare n m GT => Compare n p LT => Proxy n -> Proxy ( left :: m, right :: p ) +transSymmLt _ = assertLesser + +transSymmLtEq :: forall m n p. Compare n m GT => Compare n p EQ => Proxy n -> Proxy ( left :: m, right :: p ) +transSymmLtEq _ = assertLesser + +transSymmEqLt :: forall m n p. Compare n m EQ => Compare n p LT => Proxy n -> Proxy ( left :: m, right :: p ) +transSymmEqLt _ = assertLesser + +transSymmGt :: forall m n p. Compare n m LT => Compare n p GT => Proxy n -> Proxy ( left :: m, right :: p ) +transSymmGt _ = assertGreater + +transSymmGtEq :: forall m n p. Compare n m LT => Compare n p EQ => Proxy n -> Proxy ( left :: m, right :: p ) +transSymmGtEq _ = assertGreater + +transSymmEqGt :: forall m n p. Compare n m EQ => Compare n p GT => Proxy n -> Proxy ( left :: m, right :: p ) +transSymmEqGt _ = assertGreater + +transSymmEq :: forall m n p. Compare n m EQ => Compare n p EQ => Proxy n -> Proxy ( left :: m, right :: p ) +transSymmEq _ = assertEqual + +litLt :: Proxy ( left :: 0, right :: 1 ) +litLt = assertLesser + +litGt :: Proxy ( left :: 1, right :: 0 ) +litGt = assertGreater + +litEq :: Proxy ( left :: 0, right :: 0 ) +litEq = assertEqual + +class AssertIsGT o where + assertIsGT :: Proxy o -> Boolean + +instance AssertIsGT GT where + assertIsGT _ = true + +infer :: forall l r o. Compare l r o => AssertIsGT o => Proxy l -> Proxy r -> Boolean +infer _ _ = assertIsGT (Proxy :: _ o) + +inferSolved :: forall m n p. Compare m n GT => Compare n p GT => Proxy m -> Proxy n -> Proxy p -> Boolean +inferSolved m _ p = infer m p + +litTransLT :: forall a. Compare a 10 LT => Proxy ( left :: a, right :: 20 ) +litTransLT = assertLesser + +litTransGT :: forall a. Compare a 10 GT => Proxy ( left :: a, right :: 0 ) +litTransGT = assertGreater + +litTransRange :: forall a o. Compare a 10 LT => Compare 0 a LT => Proxy ( left :: a, right :: 20 ) +litTransRange = assertLesser + +withFacts :: forall l r o. Compare l 10 LT => Compare r 20 GT => Proxy ( left :: l, right :: r ) +withFacts = assertLesser + +main = log "Done" diff --git a/tests/purs/passing/SolvingMulInt.purs b/tests/purs/passing/SolvingMulInt.purs new file mode 100644 index 0000000000..d5e854574d --- /dev/null +++ b/tests/purs/passing/SolvingMulInt.purs @@ -0,0 +1,14 @@ +module Main where + +import Effect.Console (log) +import Prim.Int (class Mul) + +data Proxy k = Proxy + +a :: forall n. Mul 4 4 n => Proxy n +a = Proxy + +a' :: Proxy 16 +a' = a + +main = log "Done" diff --git a/tests/purs/passing/SolvingReflectable.purs b/tests/purs/passing/SolvingReflectable.purs new file mode 100644 index 0000000000..e6e0fc9826 --- /dev/null +++ b/tests/purs/passing/SolvingReflectable.purs @@ -0,0 +1,52 @@ +module Main where + +import Prelude + +import Data.Ordering (Ordering(..)) +import Data.Reflectable (reflectType) +import Effect.Console (log) +import Prim.Boolean (True, False) +import Prim.Ordering (LT, EQ, GT) + +data Proxy :: forall k. k -> Type +data Proxy n = Proxy + +refInt :: Proxy 42 +refInt = Proxy + +refIntPass :: Boolean +refIntPass = reflectType refInt == 42 + +refString :: Proxy "PureScript" +refString = Proxy + +refStringPass :: Boolean +refStringPass = reflectType refString == "PureScript" + +refBooleanT :: Proxy True +refBooleanT = Proxy + +refBooleanF :: Proxy False +refBooleanF = Proxy + +refBooleanPass :: Boolean +refBooleanPass = reflectType refBooleanT == true && reflectType refBooleanF == false + +refOrderingLT :: Proxy LT +refOrderingLT = Proxy + +refOrderingEQ :: Proxy EQ +refOrderingEQ = Proxy + +refOrderingGT :: Proxy GT +refOrderingGT = Proxy + +refOrderingPass :: Boolean +refOrderingPass = + reflectType refOrderingLT == LT + && reflectType refOrderingEQ == EQ + && reflectType refOrderingGT == GT + +main = do + when (refIntPass && refStringPass && refBooleanPass && refOrderingPass) $ + log "Done" diff --git a/tests/purs/passing/SolvingReflectable/Lib.purs b/tests/purs/passing/SolvingReflectable/Lib.purs new file mode 100644 index 0000000000..0ad5966ed3 --- /dev/null +++ b/tests/purs/passing/SolvingReflectable/Lib.purs @@ -0,0 +1,5 @@ +module Data.Reflectable where + +class Reflectable :: forall k. k -> Type -> Constraint +class Reflectable v t | v -> t where + reflectType :: forall proxy. proxy v -> t From 3d50222d6cf71b373c369a7186628ab5257c84c8 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Tue, 8 Mar 2022 21:42:40 +0800 Subject: [PATCH 1426/1580] Show compilation progress (#4258) * Initial scaffolding for build progress * Add rendering for build progress * Track build progress as part of the build plan * Make counter increment not block * Extract common progress rendering code * Add CHANGELOG.d entry --- CHANGELOG.d/feature_compilation_progress.md | 12 ++++++++++ src/Language/PureScript/Docs/Collect.hs | 8 ++----- src/Language/PureScript/Make.hs | 26 ++++++++++++++++----- src/Language/PureScript/Make/Actions.hs | 21 +++++++++++++---- src/Language/PureScript/Make/BuildPlan.hs | 6 +++-- tests/TestMake.hs | 2 +- 6 files changed, 56 insertions(+), 19 deletions(-) create mode 100644 CHANGELOG.d/feature_compilation_progress.md diff --git a/CHANGELOG.d/feature_compilation_progress.md b/CHANGELOG.d/feature_compilation_progress.md new file mode 100644 index 0000000000..ac798d5325 --- /dev/null +++ b/CHANGELOG.d/feature_compilation_progress.md @@ -0,0 +1,12 @@ +* Print compilation progress on the command line + + This feature makes it so `purs compile` and `purs docs` now show + compilation progress on the command line. Example output: + + ```purs + [ 1 of 59] Compiling Type.Proxy + [ 2 of 59] Compiling Type.Data.RowList + ... + [58 of 59] Compiling Effect.Class.Console + [59 of 59] Compiling Test.Main + ``` diff --git a/src/Language/PureScript/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs index 02db5949be..32bece3738 100644 --- a/src/Language/PureScript/Docs/Collect.hs +++ b/src/Language/PureScript/Docs/Collect.hs @@ -9,9 +9,9 @@ import Control.Arrow ((&&&)) import qualified Data.Aeson.BetterErrors as ABE import qualified Data.ByteString as BS import qualified Data.Map as Map -import Data.String (String) import qualified Data.Set as Set import qualified Data.Text as T +import qualified Data.Text.IO as TIO import System.FilePath (()) import System.IO.UTF8 (readUTF8FileT, readUTF8FilesT) @@ -96,16 +96,12 @@ compileForDocs outputDir inputFiles = do foreigns <- P.inferForeignModules filePathMap let makeActions = (P.buildMakeActions outputDir filePathMap foreigns False) - { P.progress = liftIO . putStrLn . renderProgressMessage + { P.progress = liftIO . TIO.hPutStr stdout . (<> "\n") . P.renderProgressMessage "Compiling documentation for " } P.make makeActions (map snd ms) either throwError return result where - renderProgressMessage :: P.ProgressMessage -> String - renderProgressMessage (P.CompilingModule mn) = - "Compiling documentation for " ++ T.unpack (P.runModuleName mn) - testOptions :: P.Options testOptions = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.Docs } diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 069735c5e4..3e68387e2c 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -73,8 +73,19 @@ rebuildModule' -> [ExternsFile] -> Module -> m ExternsFile -rebuildModule' MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) = do - progress $ CompilingModule moduleName +rebuildModule' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing + +rebuildModuleWithIndex + :: forall m + . (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => MakeActions m + -> Env + -> [ExternsFile] + -> Module + -> Maybe (Int, Int) + -> m ExternsFile +rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) moduleIndex = do + progress $ CompilingModule moduleName moduleIndex let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs withPrim = importPrim m lint withPrim @@ -138,10 +149,11 @@ make ma@MakeActions{..} ms = do (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph) let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted + let totalModuleCount = length toBeRebuilt for_ toBeRebuilt $ \m -> fork $ do let moduleName = getModuleName . CST.resPartial $ m let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph) - buildModule buildPlan moduleName + buildModule buildPlan moduleName totalModuleCount (spanName . getModuleSourceSpan . CST.resPartial $ m) (fst $ CST.resFull m) (fmap importPrim . snd $ CST.resFull m) @@ -215,8 +227,8 @@ make ma@MakeActions{..} ms = do inOrderOf :: (Ord a) => [a] -> [a] -> [a] inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys - buildModule :: BuildPlan -> ModuleName -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m () - buildModule buildPlan moduleName fp pwarnings mres deps = do + buildModule :: BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m () + buildModule buildPlan moduleName cnt fp pwarnings mres deps = do result <- flip catchError (return . BuildJobFailed) $ do let pwarnings' = CST.toMultipleWarnings fp pwarnings tell pwarnings' @@ -238,7 +250,9 @@ make ma@MakeActions{..} ms = do _ -> return e foldM go env deps env <- C.readMVar (bpEnv buildPlan) - (exts, warnings) <- listen $ rebuildModule' ma env externs m + idx <- C.takeMVar (bpIndex buildPlan) + C.putMVar (bpIndex buildPlan) (idx + 1) + (exts, warnings) <- listen $ rebuildModuleWithIndex ma env externs m (Just (idx, cnt)) return $ BuildJobSucceeded (pwarnings' <> warnings) exts Nothing -> return BuildJobSkipped diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index c811596d87..5fed6fa999 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -2,6 +2,7 @@ module Language.PureScript.Make.Actions ( MakeActions(..) , RebuildPolicy(..) , ProgressMessage(..) + , renderProgressMessage , buildMakeActions , checkForeignDecls , cacheDbFile @@ -66,13 +67,25 @@ data RebuildPolicy -- | Progress messages from the make process data ProgressMessage - = CompilingModule ModuleName + = CompilingModule ModuleName (Maybe (Int, Int)) -- ^ Compilation started for the specified module deriving (Show, Eq, Ord) -- | Render a progress message -renderProgressMessage :: ProgressMessage -> T.Text -renderProgressMessage (CompilingModule mn) = T.append "Compiling " (runModuleName mn) +renderProgressMessage :: T.Text -> ProgressMessage -> T.Text +renderProgressMessage infx (CompilingModule mn mi) = + T.concat + [ renderProgressIndex mi + , infx + , runModuleName mn + ] + where + renderProgressIndex :: Maybe (Int, Int) -> T.Text + renderProgressIndex = maybe "" $ \(start, end) -> + let start' = T.pack (show start) + end' = T.pack (show end) + preSpace = T.replicate (T.length end' - T.length start') " " + in "[" <> preSpace <> start' <> " of " <> end' <> "] " -- | Actions that require implementations when running in "make" mode. -- @@ -312,7 +325,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = requiresForeign = not . null . CF.moduleForeign progress :: ProgressMessage -> Make () - progress = liftIO . TIO.hPutStr stderr . (<> "\n") . renderProgressMessage + progress = liftIO . TIO.hPutStr stderr . (<> "\n") . renderProgressMessage "Compiling " readCacheDb :: Make CacheDb readCacheDb = readCacheDb' outputDir diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 5e83b290ae..cf9c2833a9 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -1,5 +1,5 @@ module Language.PureScript.Make.BuildPlan - ( BuildPlan(bpEnv) + ( BuildPlan(bpEnv, bpIndex) , BuildJobResult(..) , buildJobSuccess , construct @@ -38,6 +38,7 @@ data BuildPlan = BuildPlan { bpPrebuilt :: M.Map ModuleName Prebuilt , bpBuildJobs :: M.Map ModuleName BuildJob , bpEnv :: C.MVar Env + , bpIndex :: C.MVar Int } data Prebuilt = Prebuilt @@ -140,8 +141,9 @@ construct MakeActions{..} cacheDb (sorted, graph) = do let toBeRebuilt = filter (not . flip M.member prebuilt) sortedModuleNames buildJobs <- foldM makeBuildJob M.empty toBeRebuilt env <- C.newMVar primEnv + idx <- C.newMVar 1 pure - ( BuildPlan prebuilt buildJobs env + ( BuildPlan prebuilt buildJobs env idx , let update = flip $ \s -> M.alter (const (statusNewCacheInfo s)) (statusModuleName s) diff --git a/tests/TestMake.hs b/tests/TestMake.hs index 040b5a37e3..70ac4550ad 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -233,7 +233,7 @@ compileWithOptions opts input = do foreigns <- P.inferForeignModules filePathMap let makeActions = (P.buildMakeActions modulesDir filePathMap foreigns True) - { P.progress = \(P.CompilingModule mn) -> + { P.progress = \(P.CompilingModule mn _) -> liftIO $ modifyMVar_ recompiled (return . Set.insert mn) } P.make makeActions (map snd ms) From cfda24d50d6ee4ccf335ce0e15809807c1dff3b7 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 11 Mar 2022 07:08:26 -0800 Subject: [PATCH 1427/1580] Update version to 0.15.0-alpha-02 (#4262) --- app/Version.hs | 2 +- purescript.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/app/Version.hs b/app/Version.hs index c8031aa7b3..0a9b9a4a6a 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -17,7 +17,7 @@ import qualified Development.GitRev as GitRev -- prerelease identifier here (if any). When releasing a proper version, simply -- set this to an empty string. prerelease :: String -prerelease = "-alpha-01" +prerelease = "-alpha-02" versionString :: String versionString = showVersion Paths.version ++ prerelease ++ extra diff --git a/purescript.cabal b/purescript.cabal index 8d681a7f0b..cbcfe7fbfd 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.15.0-alpha-01 +version: 0.15.0-alpha-02 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 1d5c618054bc0c452128e8758dc01b758a3a6f39 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 11 Mar 2022 16:06:34 -0800 Subject: [PATCH 1428/1580] Remove `purs bundle` and browser backend for `purs repl` (#4255) * Disable purs bundle command and tests * 'purs bundle' only throws error now * Add basic changelog entry * Drop writeUTF8File Use writeUTF8FileT instead * `purs bundle` prints link to migration guide * Remove bundle tests completely * Remove browser backend for REPL * Remove unused language pragma: TH * Remove dead code found by weeder * Verify that var, const or function syntax all compile * Apply suggestions from code review Co-authored-by: Thomas Honeyman * Drop static files for browser backend * Drop deps used in browser backend Co-authored-by: Thomas Honeyman --- .../breaking_drop-repl-browser-backend.md | 4 + CHANGELOG.d/breaking_remove-purs-bundle.md | 3 + app/Command/Bundle.hs | 144 +--- app/Command/REPL.hs | 180 +---- app/Main.hs | 2 +- app/static/index.html | 10 - app/static/index.js | 74 --- purescript.cabal | 7 - src/Language/PureScript/Bundle.hs | 619 +----------------- src/System/IO/UTF8.hs | 4 - tests/Main.hs | 3 +- tests/TestBundle.hs | 78 --- tests/TestUtils.hs | 17 +- tests/purs/bundle/3551.purs | 21 - tests/purs/bundle/3551/ModuleWithDeadCode.js | 10 - .../purs/bundle/3551/ModuleWithDeadCode.purs | 16 - tests/purs/bundle/3727.js | 2 - tests/purs/bundle/3727.purs | 13 - tests/purs/bundle/ObjectShorthand.js | 13 - tests/purs/bundle/ObjectShorthand.purs | 18 - tests/purs/bundle/PSasConstructor.purs | 11 - tests/purs/bundle/RerunCompilerTests.txt | 27 - tests/purs/passing/ESFFIFunctionConst.js | 3 + tests/purs/passing/ESFFIFunctionConst.purs | 8 + tests/purs/passing/ESFFIFunctionFunction.js | 3 + tests/purs/passing/ESFFIFunctionFunction.purs | 8 + tests/purs/passing/ESFFIFunctionVar.js | 3 + tests/purs/passing/ESFFIFunctionVar.purs | 8 + tests/purs/passing/ESFFIValueConst1.js | 1 + tests/purs/passing/ESFFIValueConst1.purs | 8 + tests/purs/passing/ESFFIValueVar.js | 1 + tests/purs/passing/ESFFIValueVar.purs | 8 + 32 files changed, 81 insertions(+), 1246 deletions(-) create mode 100644 CHANGELOG.d/breaking_drop-repl-browser-backend.md create mode 100644 CHANGELOG.d/breaking_remove-purs-bundle.md delete mode 100644 app/static/index.html delete mode 100644 app/static/index.js delete mode 100644 tests/TestBundle.hs delete mode 100644 tests/purs/bundle/3551.purs delete mode 100644 tests/purs/bundle/3551/ModuleWithDeadCode.js delete mode 100644 tests/purs/bundle/3551/ModuleWithDeadCode.purs delete mode 100644 tests/purs/bundle/3727.js delete mode 100644 tests/purs/bundle/3727.purs delete mode 100644 tests/purs/bundle/ObjectShorthand.js delete mode 100644 tests/purs/bundle/ObjectShorthand.purs delete mode 100644 tests/purs/bundle/PSasConstructor.purs delete mode 100644 tests/purs/bundle/RerunCompilerTests.txt create mode 100644 tests/purs/passing/ESFFIFunctionConst.js create mode 100644 tests/purs/passing/ESFFIFunctionConst.purs create mode 100644 tests/purs/passing/ESFFIFunctionFunction.js create mode 100644 tests/purs/passing/ESFFIFunctionFunction.purs create mode 100644 tests/purs/passing/ESFFIFunctionVar.js create mode 100644 tests/purs/passing/ESFFIFunctionVar.purs create mode 100644 tests/purs/passing/ESFFIValueConst1.js create mode 100644 tests/purs/passing/ESFFIValueConst1.purs create mode 100644 tests/purs/passing/ESFFIValueVar.js create mode 100644 tests/purs/passing/ESFFIValueVar.purs diff --git a/CHANGELOG.d/breaking_drop-repl-browser-backend.md b/CHANGELOG.d/breaking_drop-repl-browser-backend.md new file mode 100644 index 0000000000..a42ea6efe0 --- /dev/null +++ b/CHANGELOG.d/breaking_drop-repl-browser-backend.md @@ -0,0 +1,4 @@ +* Drop support for browser backend for repl (i.e. `purs repl --port 1234`) + + Running this command will print a link that directs users to use + Try PureScript instead. \ No newline at end of file diff --git a/CHANGELOG.d/breaking_remove-purs-bundle.md b/CHANGELOG.d/breaking_remove-purs-bundle.md new file mode 100644 index 0000000000..0c9803463c --- /dev/null +++ b/CHANGELOG.d/breaking_remove-purs-bundle.md @@ -0,0 +1,3 @@ +* Remove `purs bundle` + + Users of `purs bundle` should switch to a standalone bundler such as `esbuild`, `webpack` or `parcel`. \ No newline at end of file diff --git a/app/Command/Bundle.hs b/app/Command/Bundle.hs index ac3be3933a..0d01c04b68 100644 --- a/app/Command/Bundle.hs +++ b/app/Command/Bundle.hs @@ -3,141 +3,21 @@ module Command.Bundle (command) where import Prelude -import Data.Traversable (for) -import Data.Aeson (encode) -import Data.Aeson.Encode.Pretty (confCompare, defConfig, encodePretty', keyOrder) -import Data.Maybe (isNothing) -import Data.Text (Text) -import Control.Applicative -import Control.Monad -import Control.Monad.Error.Class -import Control.Monad.Trans.Except -import Control.Monad.IO.Class -import System.FilePath (takeDirectory, (), (<.>), takeFileName) -import System.FilePath.Glob (glob) import System.Exit (exitFailure) -import System.IO (stderr, hPutStr, hPutStrLn) -import System.IO.UTF8 (readUTF8File, writeUTF8File) -import System.Directory (createDirectoryIfMissing, getCurrentDirectory) -import qualified Data.ByteString.Lazy.UTF8 as LBU8 -import Language.PureScript.Bundle -import Options.Applicative (Parser) +import System.IO (stderr, hPutStrLn) import qualified Options.Applicative as Opts -import SourceMap -import SourceMap.Types --- | Command line options. -data Options = Options - { optionsInputFiles :: [FilePath] - , optionsOutputFile :: Maybe FilePath - , optionsEntryPoints :: [String] - , optionsMainModule :: Maybe String - , optionsNamespace :: String - , optionsSourceMaps :: Bool - , optionsDebug :: Bool - } deriving Show - --- | The main application function. --- This function parses the input files, performs dead code elimination, filters empty modules --- and generates and prints the final Javascript bundle. -app :: (MonadError ErrorMessage m, MonadIO m) => Options -> m (Maybe SourceMapping, String) -app Options{..} = do - inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles - when (null inputFiles) . liftIO $ do - hPutStrLn stderr "purs bundle: No input files." - exitFailure - when (isNothing optionsOutputFile && optionsSourceMaps) . liftIO $ do - hPutStrLn stderr "purs bundle: Source maps only supported when output file specified." - exitFailure - - input <- for inputFiles $ \filename -> do - js <- liftIO (readUTF8File filename) - mid <- guessModuleIdentifier filename - length js `seq` return (mid, Just filename, js) -- evaluate readFile till EOF before returning, not to exhaust file handles - - let entryIds = map (`ModuleIdentifier` Regular) optionsEntryPoints - - currentDir <- liftIO getCurrentDirectory - let outFile = if optionsSourceMaps then fmap (currentDir ) optionsOutputFile else Nothing - let withRawModules = if optionsDebug then Just bundleDebug else Nothing - bundleSM input entryIds optionsMainModule optionsNamespace outFile withRawModules - --- | Print a JSON representation of a list of modules to stderr. -bundleDebug :: (MonadIO m) => [Module] -> m () -bundleDebug = liftIO . hPutStrLn stderr . LBU8.toString . encodePretty' (defConfig { confCompare = keyComparer }) - where - -- | Some key order hints for improved readability. - keyComparer :: Text -> Text -> Ordering - keyComparer = keyOrder ["type", "name", "moduleId"] -- keys to put first - <> flip (keyOrder ["dependsOn", "elements"]) -- keys to put last - --- | Command line options parser. -options :: Parser Options -options = Options <$> some inputFile - <*> optional outputFile - <*> many entryPoint - <*> optional mainModule - <*> namespace - <*> sourceMaps - <*> debug - where - inputFile :: Parser FilePath - inputFile = Opts.strArgument $ - Opts.metavar "FILE" - <> Opts.help "The input .js file(s)" - - outputFile :: Parser FilePath - outputFile = Opts.strOption $ - Opts.short 'o' - <> Opts.long "output" - <> Opts.help "The output .js file" - - entryPoint :: Parser String - entryPoint = Opts.strOption $ - Opts.short 'm' - <> Opts.long "module" - <> Opts.help "Entry point module name(s). All code which is not a transitive dependency of an entry point module will be removed." - - mainModule :: Parser String - mainModule = Opts.strOption $ - Opts.long "main" - <> Opts.help "Generate code to run the main method in the specified module." - - namespace :: Parser String - namespace = Opts.strOption $ - Opts.short 'n' - <> Opts.long "namespace" - <> Opts.value "PS" - <> Opts.showDefault - <> Opts.help "Specify the namespace that PureScript modules will be exported to when running in the browser." - - sourceMaps :: Parser Bool - sourceMaps = Opts.switch $ - Opts.long "source-maps" - <> Opts.help "Whether to generate source maps for the bundle (requires --output)." - - debug :: Parser Bool - debug = Opts.switch $ - Opts.long "debug" - <> Opts.help "Whether to emit a JSON representation of all parsed modules to stderr." +app :: IO () +app = do + hPutStrLn stderr $ unlines + [ "'purs bundle' was removed in the v0.15.0 release." + , "See https://www.github.com/purescript/documentation/migration-guides/0.15-Migration-Guide.md " + , "for more information and bundler alternatives." + ] + exitFailure -- | Make it go. command :: Opts.Parser (IO ()) -command = run <$> (Opts.helper <*> options) where - run :: Options -> IO () - run opts = do - output <- runExceptT (app opts) - case output of - Left err -> do - hPutStr stderr (unlines (printErrorMessage err)) - exitFailure - Right (sourcemap, js) -> - case optionsOutputFile opts of - Just outputFile -> do - createDirectoryIfMissing True (takeDirectory outputFile) - case sourcemap of - Just sm -> do - writeUTF8File outputFile $ js ++ "\n//# sourceMappingURL=" ++ (takeFileName outputFile <.> "map") ++ "\n" - writeUTF8File (outputFile <.> "map") $ LBU8.toString . encode $ generate sm - Nothing -> writeUTF8File outputFile js - Nothing -> putStrLn js +command = run <$> (Opts.helper <*> pure ()) where + run :: () -> IO () + run _ = app diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 27be4bc9e9..ee1e49f245 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -1,20 +1,11 @@ {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} module Command.REPL (command) where import Prelude () import Prelude.Compat import Control.Applicative (many, (<|>)) -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, - tryPutMVar) -import Control.Concurrent.STM (TVar, atomically, newTVarIO, writeTVar, - readTVarIO, - TChan, newBroadcastTChanIO, dupTChan, - readTChan, writeTChan) -import Control.Exception (fromException, SomeException) import Control.Monad import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class (liftIO, MonadIO) @@ -22,22 +13,10 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.State.Strict (StateT, evalStateT) import Control.Monad.Trans.Reader (ReaderT, runReaderT) -import Data.FileEmbed (embedStringFile) import Data.Foldable (for_) -import Data.String (IsString(..)) -import Data.Text (Text, unpack) -import Data.Traversable (for) import qualified Language.PureScript as P -import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.CST as CST import Language.PureScript.Interactive -import Network.HTTP.Types.Header (hContentType, hCacheControl, - hPragma, hExpires) -import Network.HTTP.Types.Status (status200, status404, status503) -import qualified Network.Wai as Wai -import qualified Network.Wai.Handler.Warp as Warp -import qualified Network.Wai.Handler.WebSockets as WS -import qualified Network.WebSockets as WS import qualified Options.Applicative as Opts import System.Console.Haskeline import System.IO.UTF8 (readUTF8File) @@ -45,7 +24,7 @@ import System.Exit import System.Directory (doesFileExist, getCurrentDirectory) import System.FilePath (()) import qualified System.FilePath.Glob as Glob -import qualified Data.ByteString.Lazy.UTF8 as U +import System.IO (hPutStrLn, stderr) -- | Command line options data PSCiOptions = PSCiOptions @@ -77,7 +56,7 @@ port :: Opts.Parser Int port = Opts.option Opts.auto $ Opts.long "port" <> Opts.short 'p' - <> Opts.help "The web server port" + <> Opts.help "The browser REPL backend was removed in v0.15.0. Use https://try.purescript.org instead." backend :: Opts.Parser Backend backend = @@ -104,22 +83,6 @@ pasteMode = go :: [String] -> InputT m String go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine "… " --- | Make a JavaScript bundle for the browser. -bundle :: IO (Either Bundle.ErrorMessage String) -bundle = runExceptT $ do - inputFiles <- liftIO $ concat <$> Glob.globDir [Glob.compile "*/*.js", Glob.compile "*/foreign.cjs"] modulesDir - input <- for inputFiles $ \filename -> do - js <- liftIO (readUTF8File filename) - mid <- Bundle.guessModuleIdentifier filename - length js `seq` return (mid, js) - Bundle.bundle input [] Nothing "PSCI" - -indexJS :: IsString string => string -indexJS = $(embedStringFile "app/static/index.js") - -indexPage :: IsString string => string -indexPage = $(embedStringFile "app/static/index.html") - -- | All of the functions required to implement a PSCi backend data Backend = forall state. Backend { _backendSetup :: IO state @@ -132,144 +95,13 @@ data Backend = forall state. Backend -- ^ Shut down the backend } --- | Commands which can be sent to the browser -data BrowserCommand - = Eval (MVar String) - -- ^ Evaluate the latest JS - | Refresh - -- ^ Refresh the page - --- | State for the browser backend -data BrowserState = BrowserState - { browserCommands :: TChan BrowserCommand - -- ^ A channel which receives data when the compiled JS has - -- been updated - , browserShutdownNotice :: MVar () - -- ^ An MVar which becomes full when the server should shut down - , browserIndexJS :: TVar (Maybe String) - -- ^ A TVar holding the latest compiled JS - , browserBundleJS :: TVar (Maybe String) - -- ^ A TVar holding the latest bundled JS - } - browserBackend :: Int -> Backend -browserBackend serverPort = Backend setup evaluate reload shutdown +browserBackend _ = Backend setup mempty mempty mempty where - setup :: IO BrowserState + setup :: IO () setup = do - shutdownVar <- newEmptyMVar - cmdChan <- newBroadcastTChanIO - indexJs <- newTVarIO Nothing - bundleJs <- newTVarIO Nothing - - let - handleWebsocket :: WS.PendingConnection -> IO () - handleWebsocket pending = do - conn <- WS.acceptRequest pending - -- Fork a thread to keep the connection alive - WS.withPingThread conn 10 (pure ()) $ do - -- Clone the command channel - cmdChanCopy <- atomically $ dupTChan cmdChan - -- Listen for commands - forever $ do - cmd <- atomically $ readTChan cmdChanCopy - case cmd of - Eval resultVar -> void $ do - WS.sendTextData conn ("eval" :: Text) - result <- WS.receiveData conn - -- With many connected clients, all but one of - -- these attempts will fail. - tryPutMVar resultVar (unpack result) - Refresh -> - WS.sendTextData conn ("reload" :: Text) - - shutdownHandler :: IO () -> IO () - shutdownHandler stopServer = void . forkIO $ do - () <- takeMVar shutdownVar - stopServer - - onException :: Maybe Wai.Request -> SomeException -> IO () - onException req ex - | Just (_ :: WS.ConnectionException) <- fromException ex - = return () -- ignore websocket disconnects - | otherwise = Warp.defaultOnException req ex - - staticServer :: Wai.Application - staticServer req respond = - case Wai.pathInfo req of - [] -> - respond $ Wai.responseLBS status200 - [(hContentType, "text/html; charset=UTF-8")] - (U.fromString indexPage) - ["js", "index.js"] -> - respond $ Wai.responseLBS status200 - [(hContentType, "application/javascript")] - (U.fromString indexJS) - ["js", "latest.js"] -> do - may <- readTVarIO indexJs - case may of - Nothing -> - respond $ Wai.responseLBS status503 [] "Service not available" - Just js -> - respond $ Wai.responseLBS status200 - [ (hContentType, "application/javascript") - , (hCacheControl, "no-cache, no-store, must-revalidate") - , (hPragma, "no-cache") - , (hExpires, "0") - ] - (U.fromString js) - ["js", "bundle.js"] -> do - may <- readTVarIO bundleJs - case may of - Nothing -> - respond $ Wai.responseLBS status503 [] "Service not available" - Just js -> - respond $ Wai.responseLBS status200 - [ (hContentType, "application/javascript")] - (U.fromString js) - _ -> respond $ Wai.responseLBS status404 [] "Not found" - - let browserState = BrowserState cmdChan shutdownVar indexJs bundleJs - createBundle browserState - - putStrLn $ "Serving http://localhost:" <> show serverPort <> "/. Waiting for connections..." - _ <- forkIO $ Warp.runSettings ( Warp.setInstallShutdownHandler shutdownHandler - . Warp.setPort serverPort - . Warp.setOnException onException - $ Warp.defaultSettings - ) $ - WS.websocketsOr WS.defaultConnectionOptions - handleWebsocket - staticServer - return browserState - - createBundle :: BrowserState -> IO () - createBundle state = do - putStrLn "Bundling JavaScript..." - ejs <- bundle - case ejs of - Left err -> do - putStrLn (unlines (Bundle.printErrorMessage err)) - exitFailure - Right js -> - atomically $ writeTVar (browserBundleJS state) (Just js) - - reload :: BrowserState -> IO () - reload state = do - createBundle state - atomically $ writeTChan (browserCommands state) Refresh - - shutdown :: BrowserState -> IO () - shutdown state = putMVar (browserShutdownNotice state) () - - evaluate :: BrowserState -> String -> IO () - evaluate state js = liftIO $ do - resultVar <- newEmptyMVar - atomically $ do - writeTVar (browserIndexJS state) (Just js) - writeTChan (browserCommands state) (Eval resultVar) - result <- takeMVar resultVar - putStrLn result + hPutStrLn stderr "The browser REPL backend was removed in v0.15.0. Use TryPureScript instead: https://try.purescript.org" + exitFailure nodeBackend :: Maybe FilePath -> [String] -> Backend nodeBackend nodePath nodeArgs = Backend setup eval reload shutdown diff --git a/app/Main.hs b/app/Main.hs index 76064aa2db..757ef645d6 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -60,7 +60,7 @@ main = do (Opts.subparser . fold) [ Opts.command "bundle" (Opts.info Bundle.command - (Opts.progDesc "Bundle compiled PureScript modules for the browser")) + (Opts.progDesc "This command was removed in v0.15.0. Run this command for migration information.")) , Opts.command "compile" (Opts.info Compile.command (Opts.progDesc "Compile PureScript source files")) diff --git a/app/static/index.html b/app/static/index.html deleted file mode 100644 index f749b8ae22..0000000000 --- a/app/static/index.html +++ /dev/null @@ -1,10 +0,0 @@ - - - - PureScript Interactive - - - - - - diff --git a/app/static/index.js b/app/static/index.js deleted file mode 100644 index f496540c4c..0000000000 --- a/app/static/index.js +++ /dev/null @@ -1,74 +0,0 @@ -var get = function get(uri, callback, onError) { - var request = new XMLHttpRequest(); - request.addEventListener('load', function() { - callback(request.responseText); - }); - request.addEventListener('error', onError); - request.open('GET', uri); - request.send(); -}; -var evaluate = function evaluate(js) { - var buffer = []; - // Save the old console.log function - var oldLog = console.log; - console.log = function(s) { - // Push log output into a temporary buffer - // which will be returned to PSCi. - buffer.push(s); - }; - // Replace any require and import statements with lookups on the PSCI object - // and export statements with assignments to module.exports. - var replaced = js.replace(/require\("[^"]*"\)/g, function(s) { - return "PSCI['" + s.split('/')[1] + "']"; - }).replace(/import \* as ([^\s]+) from "([^"]*)"/g, function (_, as, from) { - return "var " + as + " = PSCI['" + from.split('/')[1] + "']"; - }).replace(/export \{([^}]+)\} from "\.\/foreign\.js";?/g, function (_, exports) { - return exports.replace(/^\s*([^,\s]+),?\s*$/gm, function (_, exported) { - return "module.exports." + exported + " = $foreign." + exported + ";"; - }); - }).replace(/export \{([^}]+)\};?/g, function (_, exports) { - return exports.replace(/^\s*([^,\s]+)(?: as ([^\s]+))?,?\s*$/gm, function (_, exported, as) { - return "module.exports." + (as || exported) + " = " + exported + ";"; - }); - }); - // Wrap the module and evaluate it. - var wrapped = - [ 'var module = { exports: {} };' - , '(function(module) {' - , replaced - , '})(module);' - , 'return module.exports["$main"] && module.exports["$main"]();' - ].join('\n'); - new Function(wrapped)(); - // Restore console.log - console.log = oldLog; - return buffer.join('\n'); -}; -window.onload = function() { - var socket = new WebSocket('ws://localhost:' + location.port); - var evalNext = function reload() { - get('js/latest.js', function(response) { - try { - var result = evaluate(response); - socket.send(result); - } catch (ex) { - socket.send(ex.stack); - } - }, function(err) { - socket.send('Error sending JavaScript'); - }); - }; - socket.onopen = function() { - console.log('Connected'); - socket.onmessage = function(event) { - switch (event.data) { - case 'eval': - evalNext(); - break; - case 'reload': - location.reload(); - break; - } - }; - }; -}; diff --git a/purescript.cabal b/purescript.cabal index cbcfe7fbfd..cad07c8672 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -17,9 +17,7 @@ license: BSD-3-Clause license-file: LICENSE build-type: Simple extra-source-files: - app/static/*.html app/static/*.css - app/static/*.js app/static/*.less bundle/build.sh bundle/README @@ -337,10 +335,6 @@ executable purs , network >= 3.1.1.1 && <3.2 , optparse-applicative >=0.16.1.0 && <0.17 , purescript - , wai >=3.2.3 && <3.3 - , wai-websockets >=3.0.1.2 && <3.1 - , warp >=3.3.14 && <3.4 - , websockets >=0.12.7.2 && <0.13 if flag(release) cpp-options: -DRELEASE else @@ -389,7 +383,6 @@ test-suite tests Language.PureScript.Ide.Test Language.PureScript.Ide.UsageSpec PscIdeSpec - TestBundle TestCompiler TestCoreFn TestCst diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index f45bc3e18a..26b319f40f 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -5,11 +5,7 @@ -- performs dead code elimination, filters empty modules, -- and generates the final JavaScript bundle. module Language.PureScript.Bundle - ( bundle - , bundleSM - , guessModuleIdentifier - , ModuleIdentifier(..) - , moduleName + ( ModuleIdentifier(..) , ModuleType(..) , ErrorMessage(..) , printErrorMessage @@ -21,38 +17,19 @@ module Language.PureScript.Bundle ) where import Prelude.Compat -import Protolude (ordNub) -import Control.Monad import Control.Monad.Error.Class -import Control.Arrow ((&&&)) import Data.Aeson ((.=)) -import Data.Array ((!)) import Data.Char (chr, digitToInt) import Data.Foldable (fold) -import Data.Generics (GenericM, everything, everythingWithContext, everywhere, gmapMo, mkMp, mkQ, mkT) -import Data.Graph -import Data.List (stripPrefix, (\\)) -import Data.Maybe (catMaybes, fromMaybe, mapMaybe, maybeToList) -import Data.Version (showVersion) +import Data.Maybe (mapMaybe, maybeToList) import qualified Data.Aeson as A -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Language.JavaScript.Parser import Language.JavaScript.Parser.AST import Language.JavaScript.Process.Minify -import Language.PureScript.Names (ModuleName(..)) -import Language.PureScript.CodeGen.JS.Common (moduleNameToJs) - -import qualified Paths_purescript as Paths - -import System.FilePath (takeFileName, takeDirectory, takeDirectory, makeRelative) - -import SourceMap.Types -- | The type of error messages. We separate generation and rendering of errors using a data -- type, in case we need to match on error types later. @@ -87,18 +64,6 @@ instance A.ToJSON ModuleIdentifier where , "type" .= show mt ] -moduleName :: ModuleIdentifier -> String -moduleName (ModuleIdentifier name _) = name - --- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier. -guessModuleIdentifier :: MonadError ErrorMessage m => FilePath -> m ModuleIdentifier -guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> guessModuleType (takeFileName filename) - where - guessModuleType "index.js" = pure Regular - guessModuleType "foreign.js" = pure Foreign - guessModuleType "foreign.cjs" = pure Foreign - guessModuleType name = throwError $ UnsupportedModulePath name - data Visibility = Public | Internal @@ -248,114 +213,6 @@ printErrorMessage (MissingMainModule mName) = [ "Could not find an ES module or CommonJS module for the specified main module: " ++ mName ] --- | Calculate the ModuleIdentifier imported by an import declaration or a require(...) statement. -checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Either String ModuleIdentifier -checkImportPath "./foreign.js" m _ = - Right (ModuleIdentifier (moduleName m) Foreign) -checkImportPath name _ names - | Just name' <- stripSuffix "/index.js" =<< stripPrefix "../" name - , name' `S.member` names = Right (ModuleIdentifier name' Regular) -checkImportPath name _ _ = Left name - -stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] -stripSuffix suffix xs = - case splitAt (length xs - length suffix) xs of - (before, after) - | after == suffix -> Just before - | otherwise -> Nothing - --- | Compute the dependencies of all elements in a module, and add them to the tree. --- --- Members and exports can have dependencies. A dependency is of one of the following forms: --- --- 1) module.name or member["name"] --- --- where module was imported using require --- --- var module = require("Module.Name"); --- --- or an import declaration --- --- import * as module from "Module.Name"; --- --- 2) name --- --- where name is the name of a member defined in the current module. -withDeps :: Module -> Module -withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) - where - -- | Collects all modules which are imported, so that we can identify dependencies of the first type. - imports :: [(String, ModuleIdentifier)] - imports = mapMaybe toImport es - where - toImport :: ModuleElement -> Maybe (String, ModuleIdentifier) - toImport (Import _ nm (Right mid)) = Just (nm, mid) - toImport _ = Nothing - - -- | Collects all member names in scope, so that we can identify dependencies of the second type. - boundNames :: [String] - boundNames = mapMaybe toBoundName es - where - toBoundName :: ModuleElement -> Maybe String - toBoundName (Member _ Internal nm _ _) = Just nm - toBoundName _ = Nothing - - -- | Calculate dependencies and add them to the current element. - expandDeps :: ModuleElement -> ModuleElement - expandDeps (Member n f nm decl _) = Member n f nm decl (ordNub $ dependencies modulePath decl) - expandDeps (ExportsList exps) = ExportsList (map expand exps) - where - expand (ty, nm, n1, _) = (ty, nm, n1, ordNub (dependencies modulePath n1)) - expandDeps other = other - - dependencies :: ModuleIdentifier -> JSExpression -> [Key] - dependencies m = everythingWithContext boundNames (++) (mkQ (const [] &&& id) toReference) - where - toReference :: JSExpression -> [String] -> ([Key], [String]) - toReference (JSMemberDot mn _ nm) bn - | JSIdentifier _ mn' <- mn - , JSIdentifier _ nm' <- nm - , Just mid <- lookup mn' imports - = ([(mid, nm', Public)], bn) - toReference (JSMemberSquare mn _ nm _) bn - | JSIdentifier _ mn' <- mn - , Just nm' <- fromStringLiteral nm - , Just mid <- lookup mn' imports - = ([(mid, nm', Public)], bn) - toReference (JSIdentifier _ nm) bn - | nm `elem` bn - -- only add a dependency if this name is still in the list of names - -- bound to the module level (i.e., hasn't been shadowed by a function - -- parameter) - = ([(m, nm, Internal)], bn) - toReference (JSObjectLiteral _ props _) bn - = let - shorthandNames = - filter (`elem` bn) $ - -- only add a dependency if this name is still in the list of - -- names bound to the module level (i.e., hasn't been shadowed by a - -- function parameter) - mapMaybe unPropertyIdentRef $ - trailingCommaList props - in - (map (m, , Internal) shorthandNames, bn) - toReference (JSFunctionExpression _ _ _ params _ _) bn - = ([], bn \\ mapMaybe unIdentifier (commaList params)) - toReference e bn - | Just nm <- exportsAccessor e - -- exports.foo means there's a dependency on the public member "foo" of - -- this module. - = ([(m, nm, Public)], bn) - toReference _ bn = ([], bn) - - unIdentifier :: JSExpression -> Maybe String - unIdentifier (JSIdentifier _ name) = Just name - unIdentifier _ = Nothing - - unPropertyIdentRef :: JSObjectProperty -> Maybe String - unPropertyIdentRef (JSPropertyIdentRef _ name) = Just name - unPropertyIdentRef _ = Nothing - -- String literals include the quote chars fromStringLiteral :: JSExpression -> Maybe String fromStringLiteral (JSStringLiteral _ str) = Just $ strValue str @@ -421,123 +278,6 @@ varNames = mapMaybe varName . commaList varName (JSVarInitExpression (JSIdentifier _ ident) _) = Just ident varName _ = Nothing -sp :: JSAnnot -sp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty " " ] - -stringLiteral :: String -> JSExpression -stringLiteral s = JSStringLiteral JSNoAnnot $ "\"" ++ s ++ "\"" - --- | Attempt to create a Module from a JavaScript AST. --- --- Each type of module element is matched using pattern guards, and everything else is bundled into the --- Other constructor. -toModule :: forall m. (MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> Maybe FilePath -> JSAST -> m Module -toModule mids mid filename top - | JSAstModule jsModuleItems _ <- top - , JSModuleImportDeclaration _ jsImportDeclaration : _ <- jsModuleItems - , JSImportDeclaration JSImportClauseDefault{} jsFromClause _ <- jsImportDeclaration - , JSFromClause _ _ importPath <- jsFromClause - , "./foreign.cjs" <- strValue importPath - = pure $ Module mid filename [] - | JSAstModule jsModuleItems _ <- top = Module mid filename . mconcat <$> traverse toModuleElements jsModuleItems - | otherwise = err InvalidTopLevel - where - err :: ErrorMessage -> m a - err = throwError . ErrorInModule mid - - toModuleElements :: JSModuleItem -> m [ModuleElement] - toModuleElements item@(JSModuleImportDeclaration _ jsImportDeclaration) - | JSImportDeclaration jsImportClause jsFromClause _ <- jsImportDeclaration - , JSImportClauseNameSpace jsImportNameSpace <- jsImportClause - , JSImportNameSpace _ _ jsIdent <- jsImportNameSpace - , JSFromClause _ _ importPath <- jsFromClause - , importPath' <- checkImportPath (strValue importPath) mid mids - = maybe (err UnsupportedImport) pure (identName jsIdent) >>= \name -> - pure [Import item name importPath'] - toModuleElements (JSModuleImportDeclaration _ _) - = err UnsupportedImport - - toModuleElements (JSModuleExportDeclaration _ jsExportDeclaration) - | JSExportFrom jsExportClause jsFromClause _ <- jsExportDeclaration - , JSFromClause _ _ from <- jsFromClause - , JSExportClause _ jsExportSpecifiers _ <- jsExportClause - = pure . ExportsList <$> exportSpecifiersList (Just (strValue from)) jsExportSpecifiers - toModuleElements (JSModuleExportDeclaration _ jsExportDeclaration) - | JSExportLocals jsExportClause _ <- jsExportDeclaration - , JSExportClause _ jsExportSpecifiers _ <- jsExportClause - = pure . ExportsList <$> exportSpecifiersList Nothing jsExportSpecifiers - toModuleElements (JSModuleExportDeclaration _ jsExportDeclaration) - | JSExport jsStatement _ <- jsExportDeclaration - , Just (name, decl) <- matchInternalMember jsStatement - = pure [ Member jsStatement Internal name decl [] - , ExportsList [toRegularExport' name] - ] - toModuleElements (JSModuleExportDeclaration _ JSExport{}) - = err UnsupportedExport - - toModuleElements item@(JSModuleStatementListItem jsStatement) - | Just (importName, importPath) <- matchRequire jsStatement - = pure [Import item importName $ checkImportPath importPath mid mids] - toModuleElements (JSModuleStatementListItem jsStatement) - | Just (visibility, name, decl) <- matchMember jsStatement - = pure [Member jsStatement visibility name decl []] - toModuleElements (JSModuleStatementListItem jsStatement) - | Just props <- matchExportsAssignment jsStatement - = pure . ExportsList <$> traverse objectPropertyToExport (trailingCommaList props) - where - objectPropertyToExport :: JSObjectProperty -> m (ExportType, String, JSExpression, [Key]) - objectPropertyToExport (JSPropertyNameandValue name _ [val]) = - (,,val,[]) <$> expressionExportType val - <*> extractLabel' name - objectPropertyToExport _ = err UnsupportedExport - - expressionExportType :: JSExpression -> m ExportType - expressionExportType (JSMemberDot f _ _) - | JSIdentifier _ "$foreign" <- f - = pure ForeignReexport - | JSIdentifier _ ident <- f - = pure (RegularExport ident) - expressionExportType (JSMemberSquare f _ _ _) - | JSIdentifier _ "$foreign" <- f - = pure ForeignReexport - | JSIdentifier _ ident <- f - = pure (RegularExport ident) - expressionExportType (JSIdentifier _ s) = pure (RegularExport s) - expressionExportType _ = err UnsupportedExport - - extractLabel' = maybe (err UnsupportedExport) pure . extractLabel - - toModuleElements (JSModuleStatementListItem other) = pure [Other other] - - exportSpecifiersList from = - fmap catMaybes . traverse (exportSpecifier from) . commaList - - exportSpecifier from (JSExportSpecifier jsIdent) - = traverse (toExport' from) $ identName jsIdent - exportSpecifier from (JSExportSpecifierAs jsIdent _ jsIdentAs) - = sequence $ toExport from <$> identName jsIdent <*> identName jsIdentAs - - toExport :: Maybe String -> String -> String -> m (ExportType, String, JSExpression, [Key]) - toExport (Just from) name as - | from == "./foreign.js" = - pure . (ForeignReexport, as,, []) $ - JSMemberSquare (JSIdentifier sp "$foreign") JSNoAnnot - (stringLiteral name) JSNoAnnot - | Just from' <- stripSuffix "/index.js" =<< stripPrefix "../" from = - pure . (RegularExport name, as,, []) $ - JSMemberSquare (JSIdentifier sp (T.unpack . moduleNameToJs . ModuleName $ T.pack from')) JSNoAnnot - (stringLiteral name) JSNoAnnot - | otherwise = err UnsupportedExport - toExport Nothing name as = - pure $ toRegularExport name as - - toExport' from name = toExport from name name - - toRegularExport name as = - (RegularExport name, as, JSIdentifier sp name, []) - - toRegularExport' name = toRegularExport name name - data ForeignModuleExports = ForeignModuleExports { cjsExports :: [String] @@ -702,358 +442,3 @@ extractLabel :: JSPropertyName -> Maybe String extractLabel (JSPropertyString _ nm) = Just $ strValue nm extractLabel (JSPropertyIdent _ nm) = Just nm extractLabel _ = Nothing - --- | Eliminate unused code based on the specified entry point set. -compile :: [Module] -> [ModuleIdentifier] -> [Module] -compile modules [] = modules -compile modules entryPoints = filteredModules - where - (graph, vertexToNode, vertexFor) = graphFromEdges verts - - -- | The vertex set - verts :: [(ModuleElement, Key, [Key])] - verts = do - Module mid _ els <- modules - concatMap (toVertices mid) els - where - -- | Create a set of vertices for a module element. - -- - -- Imports declarations and require statements don't contribute towards dependencies, - -- since they effectively get inlined wherever they are used inside other module elements. - toVertices :: ModuleIdentifier -> ModuleElement -> [(ModuleElement, Key, [Key])] - toVertices p m@(Member _ visibility nm _ deps) = [(m, (p, nm, visibility), deps)] - toVertices p m@(ExportsList exps) = map toVertex exps - where - toVertex (ForeignReexport, nm, _, ks) = (m, (p, nm, Public), ks) - toVertex (RegularExport _, nm, _, ks) = (m, (p, nm, Public), ks) - toVertices _ _ = [] - - -- | The set of vertices whose connected components we are interested in keeping. - entryPointVertices :: [Vertex] - entryPointVertices = catMaybes $ do - (_, k@(mid, _, Public), _) <- verts - guard $ mid `elem` entryPoints - return (vertexFor k) - - -- | The set of vertices reachable from an entry point - reachableSet :: S.Set Vertex - reachableSet = S.fromList (concatMap (reachable graph) entryPointVertices) - - -- | A map from modules to the modules that are used by its reachable members. - moduleReferenceMap :: M.Map ModuleIdentifier (S.Set ModuleIdentifier) - moduleReferenceMap = M.fromAscListWith mappend $ map (vertToModule &&& vertToModuleRefs) $ S.toList reachableSet - where - vertToModuleRefs v = foldMap (S.singleton . vertToModule) $ graph ! v - vertToModule v = m where (_, (m, _, _), _) = vertexToNode v - - filteredModules :: [Module] - filteredModules = map filterUsed modules - where - filterUsed :: Module -> Module - filterUsed (Module mid fn ds) = Module mid fn (map filterExports (go ds)) - where - go :: [ModuleElement] -> [ModuleElement] - go [] = [] - go (d : rest) - | not (isDeclUsed d) = skipDecl d : go rest - | otherwise = d : go rest - - skipDecl :: ModuleElement -> ModuleElement - skipDecl (Import item _ _) = Skip item - skipDecl (Member stmt _ _ _ _) = Skip $ JSModuleStatementListItem stmt - skipDecl (ExportsList _) = Skip . JSModuleStatementListItem $ JSEmptyStatement JSNoAnnot - skipDecl (Other stmt) = Skip $ JSModuleStatementListItem stmt - skipDecl (Skip item) = Skip item - - -- | Filter out the exports for members which aren't used. - filterExports :: ModuleElement -> ModuleElement - filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm, Public)) exps) - filterExports me = me - - isDeclUsed :: ModuleElement -> Bool - isDeclUsed (Member _ visibility nm _ _) = isKeyUsed (mid, nm, visibility) - isDeclUsed (Import _ _ (Right midRef)) = midRef `S.member` modulesReferenced - isDeclUsed _ = True - - isKeyUsed :: Key -> Bool - isKeyUsed k - | Just me <- vertexFor k = me `S.member` reachableSet - | otherwise = False - - modulesReferenced :: S.Set ModuleIdentifier - modulesReferenced = fold $ M.lookup mid moduleReferenceMap - --- | Topologically sort the module dependency graph, so that when we generate code, modules can be --- defined in the right order. -sortModules :: [Module] -> [Module] -sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (topSort graph)) - where - (graph, nodeFor, _) = graphFromEdges $ do - m@(Module mid _ els) <- modules - return (m, mid, mapMaybe getKey els) - - getKey :: ModuleElement -> Maybe ModuleIdentifier - getKey (Import _ _ (Right mi)) = Just mi - getKey _ = Nothing - --- | A module is empty if it contains no exported members (in other words, --- if the only things left after dead code elimination are module imports and --- "other" foreign code). --- --- If a module is empty, we don't want to generate code for it. -isModuleEmpty :: Module -> Bool -isModuleEmpty (Module _ _ els) = all isElementEmpty els - where - isElementEmpty :: ModuleElement -> Bool - isElementEmpty (ExportsList exps) = null exps - isElementEmpty Import{} = True - isElementEmpty (Other _) = True - isElementEmpty (Skip _) = True - isElementEmpty _ = False - --- | Generate code for a set of modules, including a call to main(). --- --- Modules get defined on the global PS object, as follows: --- --- var PS = { }; --- (function(exports) { --- ... --- })(PS["Module.Name"] = PS["Module.Name"] || {}); --- --- In particular, a module and its foreign imports share the same namespace inside PS. --- This saves us from having to generate unique names for a module and its foreign imports, --- and is safe since a module shares a namespace with its foreign imports in PureScript as well --- (so there is no way to have overlaps in code generated by the compiler). -codeGen :: Maybe String -- ^ main module - -> String -- ^ namespace - -> [Module] -- ^ input modules - -> Maybe String -- ^ output filename - -> (Maybe SourceMapping, String) -codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping outFileOpt, rendered) - where - rendered = renderToString (JSAstProgram (prelude : concatMap fst modulesJS ++ maybe [] runMain optionsMainModule) JSNoAnnot) - - sourceMapping :: String -> SourceMapping - sourceMapping outFile = SourceMapping { - smFile = outFile, - smSourceRoot = Nothing, - smMappings = concat $ - zipWith3 (\file (pos :: Int) positions -> - map (\(porig, pgen) -> Mapping { - mapOriginal = Just (Pos (fromIntegral $ porig + 1) 0) - , mapSourceFile = pathToFile <$> file - , mapGenerated = Pos (fromIntegral $ pos + pgen) 0 - , mapName = Nothing - }) - (offsets (0,0) (Right 1 : positions))) - moduleFns - (scanl (+) (3 + moduleLength [JSModuleStatementListItem prelude]) (map (3+) moduleLengths)) -- 3 lines between each module & at top - (map snd modulesJS) - } - where - pathToFile = makeRelative (takeDirectory outFile) - - offsets (m, n) (Left d:rest) = offsets (m+d, n) rest - offsets (m, n) (Right d:rest) = map ((m+) &&& (n+)) [0 .. d - 1] ++ offsets (m+d, n+d) rest - offsets _ _ = [] - - moduleLength :: [JSModuleItem] -> Int - moduleLength = everything (+) (mkQ 0 countw) - where - countw :: CommentAnnotation -> Int - countw (WhiteSpace _ s) = length (filter (== '\n') s) - countw _ = 0 - - moduleLengths :: [Int] - moduleLengths = map (sum . map (either (const 0) id) . snd) modulesJS - moduleFns = map (\(Module _ fn _) -> fn) ms - - modulesJS = map moduleToJS ms - - moduleToJS :: Module -> ([JSStatement], [Either Int Int]) - moduleToJS (Module mid _ ds) = (wrap mid (indent (concat jsDecls)), lengths) - where - (jsDecls, lengths) = unzip $ map declToJS ds - - withLength :: [JSStatement] -> ([JSStatement], Either Int Int) - withLength n = (n, Right . moduleLength $ JSModuleStatementListItem <$> n) - - declToJS :: ModuleElement -> ([JSStatement], Either Int Int) - declToJS (Member n _ _ _ _) = withLength [n] - declToJS (Other n) = withLength [n] - declToJS (Skip n) = ([], Left $ moduleLength [n]) - declToJS (Import _ nm req) = withLength - [ - JSVariable lfsp - (cList [ - JSVarInitExpression (JSIdentifier sp nm) - (JSVarInit sp $ either require (innerModuleReference sp . moduleName) req ) - ]) (JSSemi JSNoAnnot) - ] - declToJS (ExportsList exps) = withLength $ map toCommonJSExport exps - - where - - toCommonJSExport :: (ExportType, String, JSExpression, [Key]) -> JSStatement - toCommonJSExport (_, nm, val, _) = - JSAssignStatement - (JSMemberSquare (JSIdentifier lfsp "exports") JSNoAnnot - (stringLiteral nm) JSNoAnnot) - (JSAssign sp) - val - (JSSemi JSNoAnnot) - - -- comma lists are reverse-consed - cList :: [a] -> JSCommaList a - cList [] = JSLNil - cList [x] = JSLOne x - cList l = go $ reverse l - where - go [x] = JSLOne x - go (h:t)= JSLCons (go t) JSNoAnnot h - go [] = error "Invalid case in comma-list" - - indent :: [JSStatement] -> [JSStatement] - indent = everywhere (mkT squash) - where - squash JSNoAnnot = JSAnnot (TokenPn 0 0 2) [] - squash (JSAnnot pos ann) = JSAnnot (keepCol pos) (map splat ann) - squash JSAnnotSpace = JSAnnot (TokenPn 0 0 2) [] - - splat (CommentA pos s) = CommentA (keepCol pos) s - splat (WhiteSpace pos w) = WhiteSpace (keepCol pos) w - splat ann = ann - - keepCol (TokenPn _ _ c) = TokenPn 0 0 (if c >= 0 then c + 2 else 2) - - prelude :: JSStatement - prelude = JSVariable (JSAnnot tokenPosnEmpty [ CommentA tokenPosnEmpty $ "// Generated by purs bundle " ++ showVersion Paths.version - , WhiteSpace tokenPosnEmpty "\n" ]) - (cList [ - JSVarInitExpression (JSIdentifier sp optionsNamespace) - (JSVarInit sp (emptyObj sp)) - ]) (JSSemi JSNoAnnot) - - require :: String -> JSExpression - require mn = - JSMemberExpression (JSIdentifier JSNoAnnot "require") JSNoAnnot - (cList [ stringLiteral mn ]) JSNoAnnot - - moduleReference :: JSAnnot -> String -> JSExpression - moduleReference a mn = - JSMemberSquare (JSIdentifier a optionsNamespace) JSNoAnnot - (stringLiteral mn) JSNoAnnot - - innerModuleReference :: JSAnnot -> String -> JSExpression - innerModuleReference a mn = - JSMemberSquare (JSIdentifier a "$PS") JSNoAnnot - (stringLiteral mn) JSNoAnnot - - emptyObj :: JSAnnot -> JSExpression - emptyObj a = JSObjectLiteral a (JSCTLNone JSLNil) JSNoAnnot - - initializeObject :: JSAnnot -> (JSAnnot -> String -> JSExpression) -> String -> JSExpression - initializeObject a makeReference mn = - JSAssignExpression (makeReference a mn) (JSAssign sp) - $ JSExpressionBinary (makeReference sp mn) (JSBinOpOr sp) - $ emptyObj sp - - -- Like `somewhere`, but stops after the first successful transformation - firstwhere :: MonadPlus m => GenericM m -> GenericM m - firstwhere f x = f x `mplus` gmapMo (firstwhere f) x - - prependWhitespace :: String -> [JSStatement] -> [JSStatement] - prependWhitespace val = fromMaybe <*> firstwhere (mkMp $ Just . reannotate) - where - reannotate (JSAnnot rpos annots) = JSAnnot rpos (ws : annots) - reannotate _ = JSAnnot tokenPosnEmpty [ws] - - ws = WhiteSpace tokenPosnEmpty val - - iife :: [JSStatement] -> String -> JSExpression -> JSStatement - iife body param arg = - JSMethodCall (JSExpressionParen lf (JSFunctionExpression JSNoAnnot JSIdentNone JSNoAnnot (JSLOne (JSIdentifier JSNoAnnot param)) JSNoAnnot - (JSBlock sp (prependWhitespace "\n " body) lf)) - JSNoAnnot) - JSNoAnnot - (JSLOne arg) - JSNoAnnot - (JSSemi JSNoAnnot) - - wrap :: ModuleIdentifier -> [JSStatement] -> [JSStatement] - wrap (ModuleIdentifier mn mtype) ds = - case mtype of - Regular -> [iife (addModuleExports ds) "$PS" (JSIdentifier JSNoAnnot optionsNamespace)] - Foreign -> [iife ds "exports" (initializeObject JSNoAnnot moduleReference mn)] - where - -- Insert the exports var after a directive prologue, if one is present. - -- Per ECMA-262 5.1, "A Directive Prologue is the longest sequence of - -- ExpressionStatement productions [...] where each ExpressionStatement - -- [...] consists entirely of a StringLiteral [...]." - -- (http://ecma-international.org/ecma-262/5.1/#sec-14.1) - addModuleExports :: [JSStatement] -> [JSStatement] - addModuleExports (x:xs) | isDirective x = x : addModuleExports xs - addModuleExports xs - = JSExpressionStatement (initializeObject lfsp innerModuleReference mn) (JSSemi JSNoAnnot) - : JSVariable lfsp (JSLOne $ JSVarInitExpression (JSIdentifier sp "exports") $ JSVarInit sp (innerModuleReference sp mn)) (JSSemi JSNoAnnot) - : xs - - isDirective (JSExpressionStatement (JSStringLiteral _ _) _) = True - isDirective _ = False - - runMain :: String -> [JSStatement] - runMain mn = - [JSMethodCall - (JSMemberDot (moduleReference lf mn) JSNoAnnot - (JSIdentifier JSNoAnnot "main")) - JSNoAnnot (cList []) JSNoAnnot (JSSemi JSNoAnnot)] - - lf :: JSAnnot - lf = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n" ] - - - lfsp :: JSAnnot - lfsp = JSAnnot tokenPosnEmpty [ WhiteSpace tokenPosnEmpty "\n " ] - --- | The bundling function. --- This function performs dead code elimination, filters empty modules --- and generates and prints the final JavaScript bundle. -bundleSM :: (MonadError ErrorMessage m) - => [(ModuleIdentifier, Maybe FilePath, String)] -- ^ The input modules. Each module should be javascript rendered from the compiler. - -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination - -> Maybe String -- ^ An optional main module. - -> String -- ^ The namespace (e.g. PS). - -> Maybe FilePath -- ^ The output file name (if there is one - in which case generate source map) - -> Maybe ([Module] -> m ()) -- ^ Optionally report the parsed modules prior to DCE -- used by "bundle --debug" - -> m (Maybe SourceMapping, String) -bundleSM inputStrs entryPoints mainModule namespace outFilename reportRawModules = do - let mid (a,_,_) = a - forM_ mainModule $ \mname -> - when (mname `notElem` map (moduleName . mid) inputStrs) (throwError (MissingMainModule mname)) - forM_ entryPoints $ \mIdent -> - when (mIdent `notElem` map mid inputStrs) (throwError (MissingEntryPoint (moduleName mIdent))) - input <- forM inputStrs $ \(ident, filename, js) -> do - ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parseModule js (moduleName ident) - return (ident, filename, ast) - - let mids = S.fromList (map (moduleName . mid) input) - - modules <- traverse (fmap withDeps . (\(a,fn,c) -> toModule mids a fn c)) input - - forM_ reportRawModules ($ modules) - - let compiled = compile modules entryPoints - sorted = sortModules (filter (not . isModuleEmpty) compiled) - - return (codeGen mainModule namespace sorted outFilename) - --- | The bundling function. --- This function performs dead code elimination, filters empty modules --- and generates and prints the final JavaScript bundle. -bundle :: (MonadError ErrorMessage m) - => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from the compiler. - -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination - -> Maybe String -- ^ An optional main module. - -> String -- ^ The namespace (e.g. PS). - -> m String -bundle inputStrs entryPoints mainModule namespace = snd <$> bundleSM (map (\(a,b) -> (a,Nothing,b)) inputStrs) entryPoints mainModule namespace Nothing Nothing diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs index 302334d00c..3414503f12 100644 --- a/src/System/IO/UTF8.hs +++ b/src/System/IO/UTF8.hs @@ -30,7 +30,3 @@ writeUTF8FileT inFile text = readUTF8File :: FilePath -> IO String readUTF8File inFile = fmap (UTF8.toString . fixCRLF) (BS.readFile inFile) - -writeUTF8File :: FilePath -> String -> IO () -writeUTF8File inFile text = - BS.writeFile inFile (UTF8.fromString text) diff --git a/tests/Main.hs b/tests/Main.hs index 065821a95e..c61dd473d5 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -16,7 +16,7 @@ import qualified TestPrimDocs import qualified TestPsci import qualified TestIde import qualified TestPscPublish -import qualified TestBundle +-- import qualified TestBundle import qualified TestMake import qualified TestUtils import qualified TestGraph @@ -35,7 +35,6 @@ main = do describe "ide" TestIde.spec beforeAll TestUtils.setupSupportModules $ do describe "compiler" TestCompiler.spec - describe "bundle" TestBundle.spec describe "make" TestMake.spec describe "psci" TestPsci.spec describe "corefn" TestCoreFn.spec diff --git a/tests/TestBundle.hs b/tests/TestBundle.hs deleted file mode 100644 index df766fa3b3..0000000000 --- a/tests/TestBundle.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE DoAndIfThenElse #-} - -module TestBundle where - -import Prelude () -import Prelude.Compat - -import qualified Language.PureScript as P -import Language.PureScript.Bundle -import Language.PureScript.Interactive.IO (readNodeProcessWithExitCode) - -import Data.Function (on) -import Data.List (minimumBy) - -import Control.Monad -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Except - -import System.Exit -import System.FilePath -import System.IO -import System.IO.UTF8 -import qualified System.FilePath.Glob as Glob - -import TestUtils -import Test.Hspec - -spec :: SpecWith SupportModules -spec = - context "Bundle examples" $ - beforeAllWith ((<$> createOutputFile logfile) . (,)) $ do - bundleTestCases <- runIO $ getTestFiles "bundle" - forM_ bundleTestCases $ \testPurs -> do - it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile, bundle and run without error") $ \(support, outputFile) -> - assertBundles support testPurs outputFile - where - - -- Takes the test entry point from a group of purs files - this is determined - -- by the file with the shortest path name, as everything but the main file - -- will be under a subdirectory. - getTestMain :: [FilePath] -> FilePath - getTestMain = minimumBy (compare `on` length) - -assertBundles - :: SupportModules - -> [FilePath] - -> Handle - -> Expectation -assertBundles support inputFiles outputFile = do - (result, _) <- compile True support inputFiles - case result of - Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs - Right _ -> do - jsFiles <- concat <$> Glob.globDir [Glob.compile "*/*.js", Glob.compile "*/foreign.cjs"] modulesDir - let entryPoint = modulesDir "index.cjs" - let entryModule = map (`ModuleIdentifier` Regular) ["Main"] - bundled <- runExceptT $ do - input <- forM jsFiles $ \filename -> do - js <- liftIO $ readUTF8File filename - mid <- guessModuleIdentifier filename - length js `seq` return (mid, Just filename, js) - bundleSM input entryModule (Just "Main") "PS" (Just entryPoint) Nothing - case bundled of - Right (_, js) -> do - writeUTF8File entryPoint js - nodeResult <- readNodeProcessWithExitCode Nothing [entryPoint] "" - hPutStrLn outputFile $ "\n" <> takeFileName (last inputFiles) <> ":" - case nodeResult of - Right (ExitSuccess, out, err) - | not (null err) -> expectationFailure $ "Test wrote to stderr:\n\n" <> err - | not (null out) && trim (last (lines out)) == "Done" -> hPutStr outputFile out - | otherwise -> expectationFailure $ "Test did not finish with 'Done':\n\n" <> out - Right (ExitFailure _, _, err) -> expectationFailure err - Left err -> expectationFailure err - Left err -> expectationFailure $ "Could not bundle: " ++ show err - -logfile :: FilePath -logfile = "bundle-tests.out" diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 5c66efe20a..3ed0f2a8ca 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -156,23 +156,8 @@ setupSupportModules = do getTestFiles :: FilePath -> IO [[FilePath]] getTestFiles testDir = do - cwd <- getCurrentDirectory let dir = "tests" "purs" testDir - testsInPath <- getFiles dir <$> testGlob dir - let rerunPath = dir "RerunCompilerTests.txt" - hasRerunFile <- doesFileExist rerunPath - rerunTests <- - if hasRerunFile - then let compilerTestDir = cwd "tests" "purs" "passing" - textToTestFiles - = mapM (\path -> ((path ++ ".purs") :) <$> testGlob path) - . map ((compilerTestDir ) . T.unpack) - . filter (not . T.null) - . map (T.strip . fst . T.breakOn "--") - . T.lines - in readUTF8FileT rerunPath >>= textToTestFiles - else return [] - return $ testsInPath ++ rerunTests + getFiles dir <$> testGlob dir where -- A glob for all purs and js files within a test directory testGlob :: FilePath -> IO [FilePath] diff --git a/tests/purs/bundle/3551.purs b/tests/purs/bundle/3551.purs deleted file mode 100644 index 4600967da5..0000000000 --- a/tests/purs/bundle/3551.purs +++ /dev/null @@ -1,21 +0,0 @@ -module Main where - -import Prelude -import Effect (Effect) -import Effect.Console (error, log) - -import ModuleWithDeadCode (class FooBar, exportThatUsesBar, results) - -main :: Effect Unit -main = do - when results.barIsExported $ error "bar is exported" - when results.fooIsNotEliminated $ error "foo is not eliminated" - - -- These are brittleness canaries; if they fail, then the compiler output has - -- probably changed such that the above checks are not doing their job. - unless results.exportThatUsesBarIsExported $ - error "likely test error: check that barIsExported is working" - unless results.barIsNotEliminated $ - error "likely test error: check that fooIsNotEliminated is working" - - when (exportThatUsesBar 0) $ log "Done" diff --git a/tests/purs/bundle/3551/ModuleWithDeadCode.js b/tests/purs/bundle/3551/ModuleWithDeadCode.js deleted file mode 100644 index faa66d6178..0000000000 --- a/tests/purs/bundle/3551/ModuleWithDeadCode.js +++ /dev/null @@ -1,10 +0,0 @@ -import * as fs from 'fs'; - -var source = fs.readFileSync(__filename, 'utf-8'); - -export var results = { - fooIsNotEliminated: /^ *var foo =/m.test(source), - barIsExported: /^ *exports\["bar"\] =/m.test(source), - barIsNotEliminated: /^ *var bar =/m.test(source), - exportThatUsesBarIsExported: /^ *exports\["exportThatUsesBar"\] =/m.test(source), -}; diff --git a/tests/purs/bundle/3551/ModuleWithDeadCode.purs b/tests/purs/bundle/3551/ModuleWithDeadCode.purs deleted file mode 100644 index a67ff7bf41..0000000000 --- a/tests/purs/bundle/3551/ModuleWithDeadCode.purs +++ /dev/null @@ -1,16 +0,0 @@ -module ModuleWithDeadCode (class FooBar, bar, exportThatUsesBar, foo, results) where - -import Prelude - -class FooBar a where - foo :: a - bar :: a -> Boolean - -instance intFooBar :: FooBar Int where - foo = 0 - bar _ = true - -exportThatUsesBar :: forall a. (FooBar a) => a -> Boolean -exportThatUsesBar = bar - -foreign import results :: { fooIsNotEliminated :: Boolean, barIsExported :: Boolean, barIsNotEliminated :: Boolean, exportThatUsesBarIsExported :: Boolean } diff --git a/tests/purs/bundle/3727.js b/tests/purs/bundle/3727.js deleted file mode 100644 index d2148a0750..0000000000 --- a/tests/purs/bundle/3727.js +++ /dev/null @@ -1,2 +0,0 @@ -export var foo = 1; -export { foo as bar }; diff --git a/tests/purs/bundle/3727.purs b/tests/purs/bundle/3727.purs deleted file mode 100644 index 2bdf512a28..0000000000 --- a/tests/purs/bundle/3727.purs +++ /dev/null @@ -1,13 +0,0 @@ -module Main (main) where - -import Prelude -import Effect (Effect) -import Effect.Console (log) -import Test.Assert (assert) - -main :: Effect Unit -main = do - assert (bar == 1) - log "Done" - -foreign import bar :: Int diff --git a/tests/purs/bundle/ObjectShorthand.js b/tests/purs/bundle/ObjectShorthand.js deleted file mode 100644 index 225e8bf063..0000000000 --- a/tests/purs/bundle/ObjectShorthand.js +++ /dev/null @@ -1,13 +0,0 @@ -var foo = 1; - -export var bar = { foo }; - -var baz = 2; - -export var quux = function(baz) { - return { baz }; -}; - -import * as fs from 'fs'; -var source = fs.readFileSync(__filename, 'utf-8'); -export var bazIsEliminated = !/^ *var baz =/m.test(source); diff --git a/tests/purs/bundle/ObjectShorthand.purs b/tests/purs/bundle/ObjectShorthand.purs deleted file mode 100644 index 6914845ecb..0000000000 --- a/tests/purs/bundle/ObjectShorthand.purs +++ /dev/null @@ -1,18 +0,0 @@ --- See issue #3741 -module Main (main) where - -import Prelude -import Effect (Effect) -import Effect.Console (log) -import Test.Assert (assert') - -main :: Effect Unit -main = do - assert' "bar" (bar.foo == 1) - assert' "quux" (quux 3 == { baz: 3 }) - assert' "baz" bazIsEliminated - log "Done" - -foreign import bar :: { foo :: Int } -foreign import quux :: forall a. a -> { baz :: a } -foreign import bazIsEliminated :: Boolean diff --git a/tests/purs/bundle/PSasConstructor.purs b/tests/purs/bundle/PSasConstructor.purs deleted file mode 100644 index d30721ae39..0000000000 --- a/tests/purs/bundle/PSasConstructor.purs +++ /dev/null @@ -1,11 +0,0 @@ -module Main where - -import Prelude -import Effect (Effect) -import Effect.Console (log) - -data P = PS - -main :: Effect Unit -main = do - log "Done" diff --git a/tests/purs/bundle/RerunCompilerTests.txt b/tests/purs/bundle/RerunCompilerTests.txt deleted file mode 100644 index ab8991352a..0000000000 --- a/tests/purs/bundle/RerunCompilerTests.txt +++ /dev/null @@ -1,27 +0,0 @@ --- Each line in this file that doesn't start with "--" is the name of a test --- in purs/passing which should be rerun during bundle testing. Rerunning --- every test in purs/passing would take more time than it's worth, so these --- tests have been cherry-picked for having moderately complex imports. - -Collatz -DctorOperatorAlias -EffFn -ExtendedInfixOperators -Fib -ForeignKind -FunWithFunDeps -GenericsRep -Import -ImportExplicit -ImportQualified -Let -Operators -QualifiedAdo -QualifiedDo -SolvingAppendSymbol -SolvingCompareSymbol -SolvingIsSymbol -TCO -TransitiveImport -TypeOperators -TypeWithoutParens diff --git a/tests/purs/passing/ESFFIFunctionConst.js b/tests/purs/passing/ESFFIFunctionConst.js new file mode 100644 index 0000000000..d09301bc40 --- /dev/null +++ b/tests/purs/passing/ESFFIFunctionConst.js @@ -0,0 +1,3 @@ +export const functionName = function (a) { + return a; +} diff --git a/tests/purs/passing/ESFFIFunctionConst.purs b/tests/purs/passing/ESFFIFunctionConst.purs new file mode 100644 index 0000000000..ad59f5d8ab --- /dev/null +++ b/tests/purs/passing/ESFFIFunctionConst.purs @@ -0,0 +1,8 @@ +module Main where + +import Prelude +import Effect.Console (log) + +foreign import functionName :: forall a. a -> a + +main = log "Done" diff --git a/tests/purs/passing/ESFFIFunctionFunction.js b/tests/purs/passing/ESFFIFunctionFunction.js new file mode 100644 index 0000000000..b77cd5a262 --- /dev/null +++ b/tests/purs/passing/ESFFIFunctionFunction.js @@ -0,0 +1,3 @@ +export function functionName(a) { + return a; +} diff --git a/tests/purs/passing/ESFFIFunctionFunction.purs b/tests/purs/passing/ESFFIFunctionFunction.purs new file mode 100644 index 0000000000..ad59f5d8ab --- /dev/null +++ b/tests/purs/passing/ESFFIFunctionFunction.purs @@ -0,0 +1,8 @@ +module Main where + +import Prelude +import Effect.Console (log) + +foreign import functionName :: forall a. a -> a + +main = log "Done" diff --git a/tests/purs/passing/ESFFIFunctionVar.js b/tests/purs/passing/ESFFIFunctionVar.js new file mode 100644 index 0000000000..e2a2a85d8d --- /dev/null +++ b/tests/purs/passing/ESFFIFunctionVar.js @@ -0,0 +1,3 @@ +export var functionName = function (a) { + return a; +} diff --git a/tests/purs/passing/ESFFIFunctionVar.purs b/tests/purs/passing/ESFFIFunctionVar.purs new file mode 100644 index 0000000000..ad59f5d8ab --- /dev/null +++ b/tests/purs/passing/ESFFIFunctionVar.purs @@ -0,0 +1,8 @@ +module Main where + +import Prelude +import Effect.Console (log) + +foreign import functionName :: forall a. a -> a + +main = log "Done" diff --git a/tests/purs/passing/ESFFIValueConst1.js b/tests/purs/passing/ESFFIValueConst1.js new file mode 100644 index 0000000000..efeee5db16 --- /dev/null +++ b/tests/purs/passing/ESFFIValueConst1.js @@ -0,0 +1 @@ +export const value = 1; diff --git a/tests/purs/passing/ESFFIValueConst1.purs b/tests/purs/passing/ESFFIValueConst1.purs new file mode 100644 index 0000000000..f2b492eb75 --- /dev/null +++ b/tests/purs/passing/ESFFIValueConst1.purs @@ -0,0 +1,8 @@ +module Main where + +import Prelude +import Effect.Console (log) + +foreign import value :: Int + +main = log "Done" diff --git a/tests/purs/passing/ESFFIValueVar.js b/tests/purs/passing/ESFFIValueVar.js new file mode 100644 index 0000000000..7a5eae2dbb --- /dev/null +++ b/tests/purs/passing/ESFFIValueVar.js @@ -0,0 +1 @@ +export var value = 1; diff --git a/tests/purs/passing/ESFFIValueVar.purs b/tests/purs/passing/ESFFIValueVar.purs new file mode 100644 index 0000000000..f2b492eb75 --- /dev/null +++ b/tests/purs/passing/ESFFIValueVar.purs @@ -0,0 +1,8 @@ +module Main where + +import Prelude +import Effect.Console (log) + +foreign import value :: Int + +main = log "Done" From 2667489aefc8bdffe798a8b897fb21321277b1a5 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Thu, 17 Mar 2022 05:37:31 +0800 Subject: [PATCH 1429/1580] Restore names when generalizing unknowns (#4257) * Track and restore names of quantified variables * Add golden test * Add CHANGELOG.d entry * Regenerate erroneous output files * Make AmbiguousTypeVariables carry variable names * Make hlint happy * Extract insertUnkName usage to a helper function * Reduce code duplication * Update CHANGELOG.d entry --- CHANGELOG.d/feature_restore_names.md | 25 ++++++++++++++ src/Language/PureScript/Errors.hs | 10 +++--- src/Language/PureScript/TypeChecker.hs | 3 +- src/Language/PureScript/TypeChecker/Monad.hs | 28 ++++++++++++++-- src/Language/PureScript/TypeChecker/Types.hs | 16 +++++++-- src/Language/PureScript/TypeChecker/Unify.hs | 29 +++++++++++------ tests/purs/failing/ConstraintInference.out | 4 +-- tests/purs/failing/Generalization2.out | 2 +- tests/purs/warning/4256.out | 34 ++++++++++++++++++++ tests/purs/warning/4256.purs | 16 +++++++++ 10 files changed, 144 insertions(+), 23 deletions(-) create mode 100644 CHANGELOG.d/feature_restore_names.md create mode 100644 tests/purs/warning/4256.out create mode 100644 tests/purs/warning/4256.purs diff --git a/CHANGELOG.d/feature_restore_names.md b/CHANGELOG.d/feature_restore_names.md new file mode 100644 index 0000000000..b32fc31318 --- /dev/null +++ b/CHANGELOG.d/feature_restore_names.md @@ -0,0 +1,25 @@ +* Restore names of quantified variables during generalization + + This makes the compiler aware of the names of quantified variables + instantiated into unification variables, such that when the latter + is generalized, semantic information is restored. For example: + + ```purs + addNumberSuffix :: forall a b c d. a -> b -> c -> d -> a + addNumberSuffix a _ _ _ = a + + addNumberSuffix' = addNumberSuffix 0 + ``` + + Previously, inferring top-level declarations without type signatures + would use `t` suffixed with an integer for type variables. + + ```purs + forall t6 t7 t8. t6 -> t7 -> t8 -> Int + ``` + + Now, the inferred type would refer back to their original names. + + ```purs + forall b6 c7 d8. b6 -> c7 -> d8 -> Int + ``` diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 8818f3bdef..6a0e74c92b 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -110,7 +110,7 @@ data SimpleErrorMessage SourceConstraint -- ^ constraint that could not be solved [Qualified (Either SourceType Ident)] -- ^ a list of instances that stopped further progress in instance chains due to ambiguity Bool -- ^ whether eliminating unknowns with annotations might help - | AmbiguousTypeVariables SourceType [Int] + | AmbiguousTypeVariables SourceType [(Text, Int)] | UnknownClass (Qualified (ProperName 'ClassName)) | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [SourceType] | PossiblyInfiniteCoercibleInstance @@ -461,7 +461,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t gSimple (NoInstanceFound con ambig unks) = NoInstanceFound <$> overConstraintArgs (traverse f) con <*> pure ambig <*> pure unks - gSimple (AmbiguousTypeVariables t us) = AmbiguousTypeVariables <$> f t <*> pure us + gSimple (AmbiguousTypeVariables t uis) = AmbiguousTypeVariables <$> f t <*> pure uis gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> traverse (traverse $ bitraverse f pure) insts gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts @@ -920,14 +920,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl | unks ] ] - renderSimpleErrorMessage (AmbiguousTypeVariables t us) = + renderSimpleErrorMessage (AmbiguousTypeVariables t uis) = paras [ line "The inferred type" , markCodeBox $ indent $ prettyType t , line "has type variables which are not determined by those mentioned in the body of the type:" , indent $ Box.hsep 1 Box.left [ Box.vcat Box.left - [ line $ markCode ("t" <> T.pack (show u)) <> " could not be determined" - | u <- us ] + [ line $ markCode (u <> T.pack (show i)) <> " could not be determined" + | (u, i) <- uis ] ] , line "Consider adding a type annotation." ] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 13b97ada4d..5254ffb427 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -391,7 +391,8 @@ typeCheckAll moduleName _ = traverse go env <- getEnv (elabTy, kind) <- withFreshSubstitution $ do ((unks, ty'), kind) <- kindOfWithUnknowns ty - pure (varIfUnknown unks ty', kind) + ty'' <- varIfUnknown unks ty' + pure (ty'', kind) checkTypeKind elabTy kind case M.lookup (Qualified (Just moduleName) name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index efa3e6e865..b4fafa9fa8 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -49,11 +49,26 @@ data Substitution = Substitution -- ^ Type substitution , substUnsolved :: M.Map Int (UnkLevel, SourceType) -- ^ Unsolved unification variables with their level (scope ordering) and kind + , substNames :: M.Map Int Text + -- ^ The original names of unknowns } +insertUnkName :: (MonadState CheckState m) => Unknown -> Text -> m () +insertUnkName u t = do + modify (\s -> + s { checkSubstitution = + (checkSubstitution s) { substNames = + M.insert u t $ substNames $ checkSubstitution s + } + } + ) + +lookupUnkName :: (MonadState CheckState m) => Unknown -> m (Maybe Text) +lookupUnkName u = gets $ M.lookup u . substNames . checkSubstitution + -- | An empty substitution emptySubstitution :: Substitution -emptySubstitution = Substitution M.empty M.empty +emptySubstitution = Substitution M.empty M.empty M.empty -- | State required for type checking data CheckState = CheckState @@ -445,8 +460,12 @@ debugValue :: Expr -> String debugValue = init . render . prettyPrintValue 100 debugSubstitution :: Substitution -> [String] -debugSubstitution (Substitution solved unsolved) = - fmap go1 (M.toList solved) <> fmap go2 (M.toList unsolved') +debugSubstitution (Substitution solved unsolved names) = + concat + [ fmap go1 (M.toList solved) + , fmap go2 (M.toList unsolved') + , fmap go3 (M.toList names) + ] where unsolved' = M.filterWithKey (\k _ -> M.notMember k solved) unsolved @@ -456,3 +475,6 @@ debugSubstitution (Substitution solved unsolved) = go2 (u, (_, k)) = "?" <> show u <> " :: " <> debugType k + + go3 (u, t) = + unpack t <> show u diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 1c2951528e..77d1d32504 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -105,7 +105,8 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do ty'' = constrain unsolved ty' unsolvedTypeVarsWithKinds <- unknownsWithKinds . IS.toList . unknowns $ constrain unsolved ty'' let unsolvedTypeVars = IS.toList $ unknowns ty' - generalized = varIfUnknown unsolvedTypeVarsWithKinds ty'' + + generalized <- varIfUnknown unsolvedTypeVarsWithKinds ty'' when shouldGeneralize $ do -- Show the inferred type in a warning @@ -162,11 +163,15 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do let constraintTypeVars = fold (conData >>= snd) let solved = solveFrom determinedFromType let unsolvedVars = S.difference constraintTypeVars solved + let lookupUnkName' i = do + mn <- lookupUnkName i + pure (fromMaybe "t" mn, i) + unsolvedVarNames <- traverse lookupUnkName' (S.toList unsolvedVars) unless (S.null unsolvedVars) . throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage' ss - $ AmbiguousTypeVariables generalized (S.toList unsolvedVars) + $ AmbiguousTypeVariables generalized unsolvedVarNames -- Check skolem variables did not escape their scope skolemEscapeCheck val' @@ -322,6 +327,7 @@ instantiatePolyTypeWithUnknowns -> m (Expr, SourceType) instantiatePolyTypeWithUnknowns val (ForAll _ ident mbK ty _) = do u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK + insertUnkName' u ident instantiatePolyTypeWithUnknowns val $ replaceTypeVars ident u ty instantiatePolyTypeWithUnknowns val (ConstrainedType _ con ty) = do dicts <- getTypeClassDictionaries @@ -329,6 +335,11 @@ instantiatePolyTypeWithUnknowns val (ConstrainedType _ con ty) = do instantiatePolyTypeWithUnknowns (App val (TypeClassDictionary con dicts hints)) ty instantiatePolyTypeWithUnknowns val ty = return (val, ty) +-- | Match against TUnknown and call insertUnkName, failing otherwise. +insertUnkName' :: (MonadState CheckState m, MonadError MultipleErrors m) => SourceType -> Text -> m () +insertUnkName' (TUnknown _ i) n = insertUnkName i n +insertUnkName' _ _ = internalCompilerError "type is not TUnknown" + -- | Infer a type for a value, rethrowing any error to provide a more useful error message infer :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) @@ -876,6 +887,7 @@ checkFunctionApplication' fn (TypeApp _ (TypeApp _ tyFunction' argTy) retTy) arg return (retTy, App fn arg') checkFunctionApplication' fn (ForAll _ ident mbK ty _) arg = do u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK + insertUnkName' u ident let replaced = replaceTypeVars ident u ty checkFunctionApplication fn replaced arg checkFunctionApplication' fn (KindedType _ ty _) arg = diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 9bcde68465..20cba3dfc5 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -22,6 +22,7 @@ import Control.Monad.State.Class (MonadState(..), gets, modify, state) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Foldable (traverse_) +import Data.Maybe (fromMaybe) import qualified Data.Map as M import qualified Data.Text as T @@ -195,13 +196,23 @@ replaceTypeWildcards = everywhereOnTypesM replace -- | -- Replace outermost unsolved unification variables with named type variables -- -varIfUnknown :: [(Unknown, SourceType)] -> SourceType -> SourceType -varIfUnknown unks ty = - mkForAll (toBinding <$> unks) $ go ty +varIfUnknown :: forall m. (MonadState CheckState m) => [(Unknown, SourceType)] -> SourceType -> m SourceType +varIfUnknown unks ty = do + bn' <- traverse toBinding unks + ty' <- go ty + pure $ mkForAll bn' ty' where - toName = T.cons 't' . T.pack . show - toBinding (a, k) = (getAnnForType ty, (toName a, Just $ go k)) - go = everywhereOnTypes $ \case - (TUnknown ann u) - | Just _ <- lookup u unks -> TypeVar ann (toName u) - t -> t + toName :: Unknown -> m T.Text + toName u = (<> T.pack (show u)) . fromMaybe "t" <$> lookupUnkName u + + toBinding :: (Unknown, SourceType) -> m (SourceAnn, (T.Text, Maybe SourceType)) + toBinding (u, k) = do + u' <- toName u + k' <- go k + pure (getAnnForType ty, (u', Just k')) + + go :: SourceType -> m SourceType + go = everywhereOnTypesM $ \case + (TUnknown ann u) -> + TypeVar ann <$> toName u + t -> pure t diff --git a/tests/purs/failing/ConstraintInference.out b/tests/purs/failing/ConstraintInference.out index 4e72d8345f..b927321573 100644 --- a/tests/purs/failing/ConstraintInference.out +++ b/tests/purs/failing/ConstraintInference.out @@ -4,11 +4,11 @@ at tests/purs/failing/ConstraintInference.purs:10:1 - 10:21 (line 10, column 1 - The inferred type   -  forall t8 t11. Show t8 => t11 -> String +  forall c8 t11. Show c8 => t11 -> String   has type variables which are not determined by those mentioned in the body of the type: - t8 could not be determined + c8 could not be determined Consider adding a type annotation. diff --git a/tests/purs/failing/Generalization2.out b/tests/purs/failing/Generalization2.out index d87ab6757f..65cb6c97c7 100644 --- a/tests/purs/failing/Generalization2.out +++ b/tests/purs/failing/Generalization2.out @@ -5,7 +5,7 @@ at tests/purs/failing/Generalization2.purs:6:1 - 7:45 (line 6, column 1 - line 7 Unable to generalize the type of the recursive function test. The inferred type of test was:   -  forall t7. Semigroup t7 => Int -> t7 -> t7 +  forall a7. Semigroup a7 => Int -> a7 -> a7   Try adding a type signature. diff --git a/tests/purs/warning/4256.out b/tests/purs/warning/4256.out new file mode 100644 index 0000000000..cbf4467e21 --- /dev/null +++ b/tests/purs/warning/4256.out @@ -0,0 +1,34 @@ +Warning 1 of 2: + + in module Main + at tests/purs/warning/4256.purs:16:1 - 16:58 (line 16, column 1 - line 16, column 58) + + No type declaration was provided for the top-level declaration of baz. + It is good practice to provide type declarations as a form of documentation. + The inferred type of baz was: +   +  forall c14 d15 b25 d27. d27 -> c14 -> b25 -> d15 -> d27 +   + + in value declaration baz + + See https://github.com/purescript/documentation/blob/master/errors/MissingTypeDeclaration.md for more information, + or to contribute content related to this warning. + +Warning 2 of 2: + + in module Main + at tests/purs/warning/4256.purs:8:1 - 8:37 (line 8, column 1 - line 8, column 37) + + No type declaration was provided for the top-level declaration of addNumberSuffix'. + It is good practice to provide type declarations as a form of documentation. + The inferred type of addNumberSuffix' was: +   +  forall b34 c35 d36. b34 -> c35 -> d36 -> Int +   + + in value declaration addNumberSuffix' + + See https://github.com/purescript/documentation/blob/master/errors/MissingTypeDeclaration.md for more information, + or to contribute content related to this warning. + diff --git a/tests/purs/warning/4256.purs b/tests/purs/warning/4256.purs new file mode 100644 index 0000000000..6e0da49d05 --- /dev/null +++ b/tests/purs/warning/4256.purs @@ -0,0 +1,16 @@ +-- @shouldWarnWith MissingTypeDeclaration +-- @shouldWarnWith MissingTypeDeclaration +module Main where + +addNumberSuffix :: forall a b c d. a -> b -> c -> d -> a +addNumberSuffix a _ _ _ = a + +addNumberSuffix' = addNumberSuffix 0 + +foo :: forall a b c d. a -> b -> c -> d -> a +foo a _ _ _ = a + +bar :: forall a b c d. a -> b -> c -> d -> a +bar a _ _ _ = a + +baz a x y = bar (foo a 2 3 4) (foo a 2 3 4) (foo x y a a) From 2cb64faf8c753287f1bf884c6754bd86010fc5a8 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Fri, 18 Mar 2022 14:12:09 -0400 Subject: [PATCH 1430/1580] Fix warning suppression for wildcard types (#4269) This bug was triggered by defining recursive partial functions or recursive bindings that contained wildcards in inner type annotations. Recursive partial function declarations now no longer cause spurious wildcard warnings to be emitted, and actual user-written wildcards now accurately emit warnings if and only if they don't appear within a binding (recursive or otherwise) with a complete (wildcard-free) type signature. --- CHANGELOG.d/fix_4268.md | 9 ++ .../src/Language/PureScript/AST/Traversals.hs | 20 +++++ .../src/Language/PureScript/CST/Convert.hs | 4 +- .../src/Language/PureScript/Types.hs | 31 ++++++- purescript.cabal | 1 + .../PureScript/Docs/Convert/Single.hs | 2 +- src/Language/PureScript/Errors.hs | 3 - src/Language/PureScript/Linter/Exhaustive.hs | 2 +- src/Language/PureScript/Linter/Wildcards.hs | 40 +++++++++ src/Language/PureScript/Pretty/Types.hs | 3 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 27 ++---- src/Language/PureScript/TypeChecker/Unify.hs | 9 +- tests/purs/warning/4268.out | 0 tests/purs/warning/4268.purs | 4 + tests/purs/warning/WildcardInferredType2.out | 89 ++++++++++++++++--- tests/purs/warning/WildcardInferredType2.purs | 48 +++++++++- 17 files changed, 247 insertions(+), 47 deletions(-) create mode 100644 CHANGELOG.d/fix_4268.md create mode 100644 src/Language/PureScript/Linter/Wildcards.hs create mode 100644 tests/purs/warning/4268.out create mode 100644 tests/purs/warning/4268.purs diff --git a/CHANGELOG.d/fix_4268.md b/CHANGELOG.d/fix_4268.md new file mode 100644 index 0000000000..74f2df6fb1 --- /dev/null +++ b/CHANGELOG.d/fix_4268.md @@ -0,0 +1,9 @@ +* Fix warning suppression for wildcard types + + This bug was triggered by defining recursive partial functions or + recursive bindings that contained wildcards in inner type annotations. + Recursive partial function declarations now no longer cause spurious + wildcard warnings to be emitted, and actual user-written wildcards now + accurately emit warnings if and only if they don't appear within a + binding (recursive or otherwise) with a complete (wildcard-free) type + signature. diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Traversals.hs b/lib/purescript-cst/src/Language/PureScript/AST/Traversals.hs index 7fb29e6d92..d35f073530 100644 --- a/lib/purescript-cst/src/Language/PureScript/AST/Traversals.hs +++ b/lib/purescript-cst/src/Language/PureScript/AST/Traversals.hs @@ -8,6 +8,7 @@ import Prelude.Compat import Control.Monad import Data.Foldable (fold) +import Data.Functor.Identity (runIdentity) import Data.List (mapAccumL) import Data.Maybe (mapMaybe) import qualified Data.List.NonEmpty as NEL @@ -415,6 +416,25 @@ everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i k' s (ConditionGuard e) = g'' s e k' s (PatternGuard b e) = h'' s b <>. g'' s e +everywhereWithContextOnValues + :: forall s + . s + -> (s -> Declaration -> (s, Declaration)) + -> (s -> Expr -> (s, Expr)) + -> (s -> Binder -> (s, Binder)) + -> (s -> CaseAlternative -> (s, CaseAlternative)) + -> (s -> DoNotationElement -> (s, DoNotationElement)) + -> ( Declaration -> Declaration + , Expr -> Expr + , Binder -> Binder + , CaseAlternative -> CaseAlternative + , DoNotationElement -> DoNotationElement + ) +everywhereWithContextOnValues s f g h i j = (runIdentity . f', runIdentity . g', runIdentity . h', runIdentity . i', runIdentity . j') + where + (f', g', h', i', j') = everywhereWithContextOnValuesM s (wrap f) (wrap g) (wrap h) (wrap i) (wrap j) + wrap = ((pure .) .) + everywhereWithContextOnValuesM :: forall m s . (Monad m) diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs index aba35ce179..077db41867 100644 --- a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs +++ b/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs @@ -118,9 +118,9 @@ convertType fileName = go TypeConstructor _ a -> T.TypeConstructor (sourceQualName fileName a) $ qualified a TypeWildcard _ a -> - T.TypeWildcard (sourceAnnCommented fileName a a) Nothing + T.TypeWildcard (sourceAnnCommented fileName a a) T.UnnamedWildcard TypeHole _ a -> - T.TypeWildcard (sourceName fileName a) . Just . getIdent $ nameValue a + T.TypeWildcard (sourceName fileName a) . T.HoleWildcard . getIdent $ nameValue a TypeString _ a b -> T.TypeLevelString (sourceAnnCommented fileName a a) b TypeInt _ _ a b -> diff --git a/lib/purescript-cst/src/Language/PureScript/Types.hs b/lib/purescript-cst/src/Language/PureScript/Types.hs index 2ff3d6bc4d..1be0077735 100644 --- a/lib/purescript-cst/src/Language/PureScript/Types.hs +++ b/lib/purescript-cst/src/Language/PureScript/Types.hs @@ -42,6 +42,18 @@ newtype SkolemScope = SkolemScope { runSkolemScope :: Int } instance NFData SkolemScope instance Serialise SkolemScope +-- | +-- Describes how a TypeWildcard should be presented to the user during +-- type checking: holes (?foo) are always emitted as errors, whereas unnamed +-- wildcards (_) default to warnings, but are ignored entirely if they are +-- contained by a binding with a complete (wildcard-free) type signature. +-- +data WildcardData = HoleWildcard Text | UnnamedWildcard | IgnoredWildcard + deriving (Show, Eq, Ord, Generic) + +instance NFData WildcardData +instance Serialise WildcardData + -- | -- The type of types -- @@ -55,7 +67,7 @@ data Type a -- | A type-level natural | TypeLevelInt a Integer -- | A type wildcard, as would appear in a partial type synonym - | TypeWildcard a (Maybe Text) + | TypeWildcard a WildcardData -- | A type constructor | TypeConstructor a (Qualified (ProperName 'TypeName)) -- | A type operator. This will be desugared into a type constructor during the @@ -104,7 +116,7 @@ srcTypeLevelInt :: Integer -> SourceType srcTypeLevelInt = TypeLevelInt NullSourceAnn srcTypeWildcard :: SourceType -srcTypeWildcard = TypeWildcard NullSourceAnn Nothing +srcTypeWildcard = TypeWildcard NullSourceAnn UnnamedWildcard srcTypeConstructor :: Qualified (ProperName 'TypeName) -> SourceType srcTypeConstructor = TypeConstructor NullSourceAnn @@ -266,6 +278,12 @@ typeToJSON annToJSON ty = , "annotation" .= annToJSON ann ] +instance A.ToJSON WildcardData where + toJSON = \case + HoleWildcard name -> A.String name + UnnamedWildcard -> A.Null + IgnoredWildcard -> A.object [ "ignored" .= True ] + instance A.ToJSON a => A.ToJSON (Type a) where toJSON = typeToJSON A.toJSON @@ -306,7 +324,7 @@ typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do "TypeLevelInt" -> TypeLevelInt a <$> contents "TypeWildcard" -> do - b <- contents <|> pure Nothing + b <- contents <|> pure UnnamedWildcard pure $ TypeWildcard a b "TypeConstructor" -> TypeConstructor a <$> contents @@ -387,6 +405,13 @@ instance {-# OVERLAPPING #-} A.FromJSON a => A.FromJSON (Constraint a) where instance A.FromJSON ConstraintData where parseJSON = constraintDataFromJSON +instance A.FromJSON WildcardData where + parseJSON = \case + A.String name -> pure $ HoleWildcard name + A.Object _ -> pure IgnoredWildcard + A.Null -> pure UnnamedWildcard + _ -> fail "Unrecognized WildcardData" + data RowListItem a = RowListItem { rowListAnn :: a , rowListLabel :: Label diff --git a/purescript.cabal b/purescript.cabal index cad07c8672..b465f3b8ab 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -266,6 +266,7 @@ library Language.PureScript.Linter Language.PureScript.Linter.Exhaustive Language.PureScript.Linter.Imports + Language.PureScript.Linter.Wildcards Language.PureScript.Make Language.PureScript.Make.Actions Language.PureScript.Make.BuildPlan diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index d69961a050..a86603ca94 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -161,7 +161,7 @@ convertDeclaration (P.ValueDecl sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) convertDeclaration (P.ValueDecl sa _ _ _ _) title = -- If no explicit type declaration was provided, insert a wildcard, so that -- the actual type will be added during type checking. - basicDeclaration sa title (ValueDeclaration (P.TypeWildcard () Nothing)) + basicDeclaration sa title (ValueDeclaration (P.TypeWildcard () P.UnnamedWildcard)) convertDeclaration (P.ExternDeclaration sa _ ty) title = basicDeclaration sa title (ValueDeclaration (ty $> ())) convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title = diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6a0e74c92b..5bc5cbabd2 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1931,9 +1931,6 @@ withoutPosition (ErrorMessage hints se) = ErrorMessage (filter go hints) se positionedError :: SourceSpan -> ErrorMessageHint positionedError = PositionedError . pure -filterErrors :: (ErrorMessage -> Bool) -> MultipleErrors -> MultipleErrors -filterErrors f = MultipleErrors . filter f . runMultipleErrors - -- | Runs a computation listening for warnings and then escalating any warnings -- that match the predicate to error status. escalateWarningWhen diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 2d124b16ea..f78586bbb7 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -281,7 +281,7 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' addPartialConstraint :: ([[Binder]], Bool) -> Expr -> Expr addPartialConstraint (bss, complete) e = TypedValue True e $ - srcConstrainedType (srcConstraint C.Partial [] [] (Just constraintData)) srcTypeWildcard + srcConstrainedType (srcConstraint C.Partial [] [] (Just constraintData)) $ TypeWildcard NullSourceAnn IgnoredWildcard where constraintData :: ConstraintData constraintData = diff --git a/src/Language/PureScript/Linter/Wildcards.hs b/src/Language/PureScript/Linter/Wildcards.hs new file mode 100644 index 0000000000..0a614e379e --- /dev/null +++ b/src/Language/PureScript/Linter/Wildcards.hs @@ -0,0 +1,40 @@ +module Language.PureScript.Linter.Wildcards + ( ignoreWildcardsUnderCompleteTypeSignatures + ) where + +import Protolude hiding (Type) + +import Language.PureScript.AST +import Language.PureScript.Types + +-- | +-- Replaces `TypeWildcard _ UnnamedWildcard` with +-- `TypeWildcard _ IgnoredWildcard` in places where we don't want to emit a +-- warning about wildcards. +-- +-- The guiding principle here is that a wildcard can be ignored if there is a +-- complete (wildcard-free) type signature on a binding somewhere between the +-- type in which the wildcard occurs and the top level of the module. In +-- particular, this means that top-level signatures containing wildcards are +-- always warnings, and a top-level signature always prevents wildcards on +-- inner bindings from emitting warnings. +-- +ignoreWildcardsUnderCompleteTypeSignatures :: Declaration -> Declaration +ignoreWildcardsUnderCompleteTypeSignatures = onDecl + where + (onDecl, _, _, _, _) = everywhereWithContextOnValues False (,) handleExpr (,) (,) (,) + handleExpr isCovered = \case + tv@(TypedValue chk v ty) + | isCovered -> (True, TypedValue chk v $ ignoreWildcards ty) + | otherwise -> (isComplete ty, tv) + other -> (isCovered, other) + +ignoreWildcards :: Type a -> Type a +ignoreWildcards = everywhereOnTypes $ \case + TypeWildcard a UnnamedWildcard -> TypeWildcard a IgnoredWildcard + other -> other + +isComplete :: Type a -> Bool +isComplete = everythingOnTypes (&&) $ \case + TypeWildcard{} -> False + _ -> True diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 84e8a7acec..8988b4226e 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -69,7 +69,8 @@ convertPrettyPrintType = go go _ (TypeVar _ t) = PPTypeVar t Nothing go _ (TypeLevelString _ s) = PPTypeLevelString s go _ (TypeLevelInt _ n) = PPTypeLevelInt n - go _ (TypeWildcard _ n) = PPTypeWildcard n + go _ (TypeWildcard _ (HoleWildcard n)) = PPTypeWildcard (Just n) + go _ (TypeWildcard _ _) = PPTypeWildcard Nothing go _ (TypeConstructor _ c) = PPTypeConstructor c go _ (TypeOp _ o) = PPTypeOp o go _ (Skolem _ t _ n _) = PPSkolem t n diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 4df581549c..7f5a25eceb 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -378,7 +378,7 @@ deriveGenericRep ss mn syns kinds ds tyConNm tyConArgs repTy = do toRepTy ctors = foldr1 (\f -> srcTypeApp (srcTypeApp (srcTypeConstructor DataGenericRep.Sum) f)) ctors checkIsWildcard :: MonadError MultipleErrors m => SourceSpan -> ProperName 'TypeName -> SourceType -> m () -checkIsWildcard _ _ (TypeWildcard _ Nothing) = return () +checkIsWildcard _ _ (TypeWildcard _ UnnamedWildcard) = return () checkIsWildcard ss tyConNm _ = throwError . errorMessage' ss $ ExpectedWildcard tyConNm diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 5254ffb427..8db639e694 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -14,10 +14,10 @@ import Control.Monad (when, unless, void, forM, zipWithM_) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), modify, gets) import Control.Monad.Supply.Class (MonadSupply) -import Control.Monad.Writer.Class (MonadWriter(..), censor) +import Control.Monad.Writer.Class (MonadWriter, tell) import Data.Foldable (for_, traverse_, toList) -import Data.List (nub, nubBy, (\\), sort, group, intersect) +import Data.List (nub, nubBy, (\\), sort, group) import Data.Maybe import Data.Either (partitionEithers) import Data.Text (Text) @@ -34,6 +34,7 @@ import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Linter +import Language.PureScript.Linter.Wildcards import Language.PureScript.Names import Language.PureScript.Roles import Language.PureScript.Sugar.Names.Env (Exports(..)) @@ -275,10 +276,9 @@ typeCheckAll :: forall m . (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName - -> [DeclarationRef] -> [Declaration] -> m [Declaration] -typeCheckAll moduleName _ = traverse go +typeCheckAll moduleName = traverse go where go :: Declaration -> m Declaration go (DataDeclaration sa@(ss, _) dtype name args dctors) = do @@ -353,7 +353,7 @@ typeCheckAll moduleName _ = traverse go internalError "Type declarations should have been removed before typeCheckAlld" go (ValueDecl sa@(ss, _) name nameKind [] [MkUnguarded val]) = do env <- getEnv - warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (positionedError ss)) . censorLocalUnnamedWildcards val $ do + warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (positionedError ss)) $ do val' <- checkExhaustiveExpr ss env moduleName val valueIsNotDefined moduleName name typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] >>= \case @@ -562,21 +562,6 @@ typeCheckAll moduleName _ = traverse go | moduleName `S.member` nonOrphanModules = return () | otherwise = throwError . errorMessage $ OrphanInstance dictName className nonOrphanModules tys' - censorLocalUnnamedWildcards :: Expr -> m a -> m a - censorLocalUnnamedWildcards (TypedValue _ _ ty) = censor (filterErrors (not . isLocalUnnamedWildcardError ty)) - censorLocalUnnamedWildcards _ = id - - isLocalUnnamedWildcardError :: SourceType -> ErrorMessage -> Bool - isLocalUnnamedWildcardError ty err@(ErrorMessage _ (WildcardInferredType _ _)) = - let - ssWildcard (TypeWildcard (ss', _) Nothing) = [ss'] - ssWildcard _ = [] - sssWildcards = everythingOnTypes (<>) ssWildcard ty - sss = maybe [] NEL.toList $ errorSpan err - in - null $ intersect sss sssWildcards - isLocalUnnamedWildcardError _ _ = False - -- | -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, -- extracted from the kind of the type constructor itself. @@ -624,7 +609,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do let (decls', imports) = partitionEithers $ fromImportDecl <$> decls modify (\s -> s { checkCurrentModule = Just mn, checkCurrentModuleImports = imports }) - decls'' <- typeCheckAll mn exps decls' + decls'' <- typeCheckAll mn $ ignoreWildcardsUnderCompleteTypeSignatures <$> decls' checkSuperClassesAreExported <- getSuperClassExportCheck for_ exps $ \e -> do checkTypesAreExported e diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 20cba3dfc5..f976fce43b 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -185,11 +185,14 @@ unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where replaceTypeWildcards :: (MonadWriter MultipleErrors m, MonadState CheckState m) => SourceType -> m SourceType replaceTypeWildcards = everywhereOnTypesM replace where - replace (TypeWildcard ann name) = do + replace (TypeWildcard ann wdata) = do t <- freshType ctx <- getLocalContext - let err = maybe (WildcardInferredType t ctx) (\n -> HoleInferredType n t ctx Nothing) name - warnWithPosition (fst ann) $ tell $ errorMessage err + let err = case wdata of + HoleWildcard n -> Just $ HoleInferredType n t ctx Nothing + UnnamedWildcard -> Just $ WildcardInferredType t ctx + IgnoredWildcard -> Nothing + forM_ err $ warnWithPosition (fst ann) . tell . errorMessage return t replace other = return other diff --git a/tests/purs/warning/4268.out b/tests/purs/warning/4268.out new file mode 100644 index 0000000000..e69de29bb2 diff --git a/tests/purs/warning/4268.purs b/tests/purs/warning/4268.purs new file mode 100644 index 0000000000..1f91ae507b --- /dev/null +++ b/tests/purs/warning/4268.purs @@ -0,0 +1,4 @@ +module Main where + +f :: Partial => Int -> Int +f 0 = f 1 diff --git a/tests/purs/warning/WildcardInferredType2.out b/tests/purs/warning/WildcardInferredType2.out index f6b3d70bc8..52cbc66ce7 100644 --- a/tests/purs/warning/WildcardInferredType2.out +++ b/tests/purs/warning/WildcardInferredType2.out @@ -1,14 +1,83 @@ -Warning found: -in module Main -at tests/purs/warning/WildcardInferredType2.purs:4:6 - 4:7 (line 4, column 6 - line 4, column 7) +Warning 1 of 5: - Wildcard type definition has the inferred type -   -  Int -   + in module Main + at tests/purs/warning/WildcardInferredType2.purs:10:6 - 10:7 (line 10, column 6 - line 10, column 7) -in value declaration x + Wildcard type definition has the inferred type +   +  Int +   -See https://github.com/purescript/documentation/blob/master/errors/WildcardInferredType.md for more information, -or to contribute content related to this warning. + in value declaration x + + See https://github.com/purescript/documentation/blob/master/errors/WildcardInferredType.md for more information, + or to contribute content related to this warning. + +Warning 2 of 5: + + in module Main + at tests/purs/warning/WildcardInferredType2.purs:51:9 - 51:10 (line 51, column 9 - line 51, column 10) + + Wildcard type definition has the inferred type +   +  Int +   + + in binding group foxtrot, echo + + See https://github.com/purescript/documentation/blob/master/errors/WildcardInferredType.md for more information, + or to contribute content related to this warning. + +Warning 3 of 5: + + in module Main + at tests/purs/warning/WildcardInferredType2.purs:54:8 - 54:9 (line 54, column 8 - line 54, column 9) + + Wildcard type definition has the inferred type +   +  Int +   + in the following context: + + m :: Int + + + in binding group foxtrot, echo + + See https://github.com/purescript/documentation/blob/master/errors/WildcardInferredType.md for more information, + or to contribute content related to this warning. + +Warning 4 of 5: + + in module Main + at tests/purs/warning/WildcardInferredType2.purs:47:1 - 49:8 (line 47, column 1 - line 49, column 8) + + No type declaration was provided for the top-level declaration of delta. + It is good practice to provide type declarations as a form of documentation. + The inferred type of delta was: +   +  Int -> Int +   + + in binding group delta, charlie + + See https://github.com/purescript/documentation/blob/master/errors/MissingTypeDeclaration.md for more information, + or to contribute content related to this warning. + +Warning 5 of 5: + + in module Main + at tests/purs/warning/WildcardInferredType2.purs:25:1 - 31:14 (line 25, column 1 - line 31, column 14) + + No type declaration was provided for the top-level declaration of alpha. + It is good practice to provide type declarations as a form of documentation. + The inferred type of alpha was: +   +  Int +   + + in value declaration alpha + + See https://github.com/purescript/documentation/blob/master/errors/MissingTypeDeclaration.md for more information, + or to contribute content related to this warning. diff --git a/tests/purs/warning/WildcardInferredType2.purs b/tests/purs/warning/WildcardInferredType2.purs index 441a326c18..151bd2ddb0 100644 --- a/tests/purs/warning/WildcardInferredType2.purs +++ b/tests/purs/warning/WildcardInferredType2.purs @@ -1,6 +1,12 @@ -- @shouldWarnWith WildcardInferredType +-- @shouldWarnWith MissingTypeDeclaration +-- @shouldWarnWith WildcardInferredType +-- @shouldWarnWith WildcardInferredType +-- @shouldWarnWith MissingTypeDeclaration module Main where +import Prelude + x :: _ x = 42 @@ -11,4 +17,44 @@ z :: Int z = n where n :: _ - n = 42 \ No newline at end of file + n = 42 + +-- Inner signatures can suppress warnings from more-inner wildcards, +-- even though a top-level signature is missing (see #4268) + +alpha = f 0 + where + f :: Int -> Int + f m = n + where + n :: _ + n = m + 1 + +-- Tests for recursive binding groups (see #4268) + +bravo :: Int -> Int +bravo m = if n > 0 then bravo (n - 1) else n + where + n :: _ + n = m + +charlie :: Int -> Int +charlie m = if n > 0 then delta (n - 1) else n + where + n :: _ + n = m + +delta m = if n > 0 then charlie (n - 1) else n + where + n = m + +echo :: _ -> Int -- Partial signatures don't count! +echo m = if n > 0 then foxtrot (n - 1) else n + where + n :: _ + n = m + +foxtrot :: Int -> Int +foxtrot m = if n > 0 then echo (n - 1) else n + where + n = m From 76b9548f78e1690a44d4212f07e3debea2983dc5 Mon Sep 17 00:00:00 2001 From: Mohammed Anas Date: Fri, 18 Mar 2022 21:13:22 +0300 Subject: [PATCH 1431/1580] Clarify what do-notation compiles to in error (#4272) --- CHANGELOG.d/misc_clarify-point-in-do-notation-error.md | 7 +++++++ src/Language/PureScript/Errors.hs | 2 +- tests/purs/failing/2109-bind.out | 2 +- tests/purs/failing/2109-discard.out | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) create mode 100644 CHANGELOG.d/misc_clarify-point-in-do-notation-error.md diff --git a/CHANGELOG.d/misc_clarify-point-in-do-notation-error.md b/CHANGELOG.d/misc_clarify-point-in-do-notation-error.md new file mode 100644 index 0000000000..221135666e --- /dev/null +++ b/CHANGELOG.d/misc_clarify-point-in-do-notation-error.md @@ -0,0 +1,7 @@ +* Improve "Unknown value bind" and "Unknown value discard" errors + + The previous error implies that do-notation compiles down to only `bind` or to + only `discard` (depending on whether the symbol not found was `bind` or + `discard` respectively), which is somewhat misleading, especially in the + latter case. Now, the error states correctly that do-notation compiles down to + both functions. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 5bc5cbabd2..2d89b49b81 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -751,7 +751,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident i)))) | i `elem` [ C.bind, C.discard ] = - line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode i <> " function. Please import " <> markCode i <> " from module " <> markCode "Prelude" + line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode "bind" <> " and " <> markCode "discard" <> " functions. Please import " <> markCode i <> " from module " <> markCode "Prelude" renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident i)))) | i == C.negate = line $ "Unknown " <> printName name <> ". You're probably using numeric negation (the unary " <> markCode "-" <> " operator), which the compiler replaces with calls to the " <> markCode i <> " function. Please import " <> markCode i <> " from module " <> markCode "Prelude" renderSimpleErrorMessage (UnknownName name) = diff --git a/tests/purs/failing/2109-bind.out b/tests/purs/failing/2109-bind.out index 2a22bb5ed0..ad8804be6b 100644 --- a/tests/purs/failing/2109-bind.out +++ b/tests/purs/failing/2109-bind.out @@ -2,7 +2,7 @@ Error found: in module Main at tests/purs/failing/2109-bind.purs:8:3 - 8:14 (line 8, column 3 - line 8, column 14) - Unknown value bind. You're probably using do-notation, which the compiler replaces with calls to the bind function. Please import bind from module Prelude + Unknown value bind. You're probably using do-notation, which the compiler replaces with calls to the bind and discard functions. Please import bind from module Prelude See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, diff --git a/tests/purs/failing/2109-discard.out b/tests/purs/failing/2109-discard.out index 86457303ca..08cc768e5f 100644 --- a/tests/purs/failing/2109-discard.out +++ b/tests/purs/failing/2109-discard.out @@ -2,7 +2,7 @@ Error found: in module Main at tests/purs/failing/2109-discard.purs:7:3 - 7:12 (line 7, column 3 - line 7, column 12) - Unknown value discard. You're probably using do-notation, which the compiler replaces with calls to the discard function. Please import discard from module Prelude + Unknown value discard. You're probably using do-notation, which the compiler replaces with calls to the bind and discard functions. Please import discard from module Prelude See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, From 5f77fb484f91348acea687985ba0cf2b2279f1d6 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Sat, 19 Mar 2022 02:21:31 +0800 Subject: [PATCH 1432/1580] Remove compiler-generated identifiers from type search results (#4260) Filter out non-plain idents in type search --- CHANGELOG.d/fix_3559.md | 1 + .../PureScript/TypeChecker/TypeSearch.hs | 5 ++- tests/purs/failing/TypedHole3.out | 34 +++++++++++++++++++ tests/purs/failing/TypedHole3.purs | 4 +++ 4 files changed, 43 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/fix_3559.md create mode 100644 tests/purs/failing/TypedHole3.out create mode 100644 tests/purs/failing/TypedHole3.purs diff --git a/CHANGELOG.d/fix_3559.md b/CHANGELOG.d/fix_3559.md new file mode 100644 index 0000000000..5818f5dd23 --- /dev/null +++ b/CHANGELOG.d/fix_3559.md @@ -0,0 +1 @@ +* Remove compiler-generated identifiers from type search results diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index a93bd96f85..95b9be56d2 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -123,8 +123,11 @@ typeSearch unsolved env st type' = matchingNames = runTypeSearch (Map.map (\(ty, _, _) -> ty) (P.names env)) matchingConstructors = runTypeSearch (Map.map (\(_, _, ty, _) -> ty) (P.dataConstructors env)) (allLabels, matchingLabels) = accessorSearch unsolved env st type' + + runPlainIdent (Qualified m (Ident k), v) = Just (Qualified m k, v) + runPlainIdent _ = Nothing in ( (first (P.Qualified Nothing . ("_." <>) . P.prettyPrintLabel) <$> matchingLabels) - <> (first (map P.runIdent) <$> Map.toList matchingNames) + <> mapMaybe runPlainIdent (Map.toList matchingNames) <> (first (map P.runProperName) <$> Map.toList matchingConstructors) , if null allLabels then Nothing else Just allLabels) diff --git a/tests/purs/failing/TypedHole3.out b/tests/purs/failing/TypedHole3.out new file mode 100644 index 0000000000..db08ba593b --- /dev/null +++ b/tests/purs/failing/TypedHole3.out @@ -0,0 +1,34 @@ +Error found: +in module Main +at tests/purs/failing/TypedHole3.purs:4:10 - 4:15 (line 4, column 10 - line 4, column 15) + + Hole 'help' has the inferred type +   +  t0 +   + You could substitute the hole with one of these values: +   +  Control.Alt.alt :: forall f a. Alt f => f a -> f a -> f a  +  Control.Alternative.guard :: forall m. Alternative m => Boolean -> m Unit  +  Control.Applicative.liftA1 :: forall f a b. Applicative f => (a -> b) -> f a -> f b  +  Control.Applicative.pure :: forall f a. Applicative f => a -> f a  +  Control.Applicative.unless :: forall m. Applicative m => Boolean -> m Unit -> m Unit  +  Control.Applicative.when :: forall m. Applicative m => Boolean -> m Unit -> m Unit  +  Control.Apply.apply :: forall f a b. Apply f => f (a -> b) -> f a -> f b  +  Control.Apply.applyFirst :: forall a b f. Apply f => f a -> f b -> f a  +  Control.Apply.applySecond :: forall a b f. Apply f => f a -> f b -> f b  +  Control.Apply.lift2 :: forall a b c f. Apply f => (a -> b -> c) -> f a -> ... -> ...  +  Control.Apply.lift3 :: forall a b c d f. Apply f => (a -> b -> ...) -> f a -> ... -> ...  +  Control.Apply.lift4 :: forall a b c d e f. Apply f => (a -> b -> ...) -> f a -> ... -> ...  +  Control.Apply.lift5 :: forall a b c d e f g. Apply f => (a -> b -> ...) -> f a -> ... -> ... +  Control.Biapplicative.bipure :: forall w a b. Biapplicative w => a -> b -> w a b  +  Control.Biapply.biapply :: forall w a b c d. Biapply w => w (a -> b) (c -> d) -> w a c -> w b d  +   + +in value declaration fn + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/HoleInferredType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypedHole3.purs b/tests/purs/failing/TypedHole3.purs new file mode 100644 index 0000000000..03050c96ba --- /dev/null +++ b/tests/purs/failing/TypedHole3.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith HoleInferredType +module Main where + +fn _ _ = ?help From 6c2299fff46b43fbd49bc41fc00b0d5b05dc2c59 Mon Sep 17 00:00:00 2001 From: Nicholas Yip Date: Fri, 1 Apr 2022 18:05:21 +0900 Subject: [PATCH 1433/1580] Containerized Linux build (Glibc 2.24) (#4228) --- .github/workflows/ci.yml | 70 ++++++++++++++-------- CHANGELOG.d/feature_support_older_glibc.md | 4 ++ CONTRIBUTORS.md | 1 + ci/build-package-set.sh | 2 +- ci/fix-home | 12 ++++ stack.yaml | 2 + 6 files changed, 66 insertions(+), 25 deletions(-) create mode 100644 CHANGELOG.d/feature_support_older_glibc.md create mode 100755 ci/fix-home diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 0699b9e59a..a85890eac9 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -14,18 +14,32 @@ defaults: env: CI_RELEASE: "${{ github.event_name == 'release' }}" + STACK_VERSION: "2.7.3" jobs: build: strategy: fail-fast: false # do not cancel builds for other OSes if one fails matrix: - # If upgrading Ubuntu, also upgrade it in the lint job below - os: [ "ubuntu-18.04", "macOS-10.15", "windows-2019" ] + include: + - # If upgrading the Haskell image, also upgrade it in the lint job below + os: "ubuntu-latest" + image: "haskell:8.10.7-stretch@sha256:100f8fb7d7d8d64adb5e106fe8136b8d4cbdc03aeb2cbd145a7597d74b69bafb" + - os: "macOS-10.15" + - os: "windows-2019" runs-on: "${{ matrix.os }}" + container: "${{ matrix.image }}" steps: + - # We need a proper Git repository, but the checkout step will unpack a tarball instead of doing a clone + # if the Git version is less than 2.18. + name: "(Linux only) Install a newer version of Git" + if: "${{ runner.os == 'Linux' }}" + run: | + . /etc/os-release + echo deb http://deb.debian.org/debian "$VERSION_CODENAME"-backports main >> /etc/apt/sources.list + apt-get update && apt-get install -y git/"$VERSION_CODENAME"-backports - uses: "actions/checkout@v2" - uses: "actions/setup-node@v1" @@ -33,18 +47,25 @@ jobs: node-version: "12" - id: "haskell" + name: "(Non-Linux only) Install Haskell" + if: "${{ runner.os != 'Linux' }}" uses: "haskell/actions/setup@v1" with: enable-stack: true - # If upgrading Stack, also upgrade it in the lint job below - stack-version: "2.7.1" + stack-version: "${{ env.STACK_VERSION }}" stack-no-global: true + - name: "(Linux only) Check Stack version" + if: "${{ runner.os == 'Linux' }}" + run: | + [ "$(stack --numeric-version)" = "$STACK_VERSION" ] + - uses: "actions/cache@v2" with: path: | + /root/.stack ${{ steps.haskell.outputs.stack-root }} - key: "${{ runner.os }}-${{ hashFiles('stack.yaml') }}" + key: "${{ runner.os }}-MdyPsf-${{ hashFiles('stack.yaml') }}" - name: "(Windows only) Configure Stack to store its programs in STACK_ROOT" # This ensures that the local GHC and MSYS binaries that Stack installs @@ -55,7 +76,7 @@ jobs: mkdir -p "$STACK_ROOT" echo "local-programs-path: $STACK_ROOT/programs" > $STACK_ROOT/config.yaml - - run: "ci/build.sh" + - run: "ci/fix-home ci/build.sh" - name: "(Linux only) Build the entire package set" if: "${{ runner.os == 'Linux' }}" @@ -67,7 +88,7 @@ jobs: # into which stack places all build artifacts. Since we use --haddock # in our CI builds, in order to actually get stack to find the purs # binary it created, we need to use the flag here as well. - run: "stack --haddock exec ../ci/build-package-set.sh" + run: "../ci/fix-home stack --haddock exec ../ci/build-package-set.sh" - name: "(Release only) Create bundle" if: "${{ env.CI_RELEASE == 'true' }}" @@ -85,7 +106,7 @@ jobs: exit 1;; esac cd sdist-test - bundle/build.sh "$bundle_os" + ci/fix-home bundle/build.sh "$bundle_os" - name: "(Release only) Publish bundle" if: "${{ env.CI_RELEASE == 'true' }}" @@ -100,25 +121,26 @@ jobs: files: "sdist-test/bundle/*.{tar.gz,sha}" lint: - runs-on: "ubuntu-18.04" + runs-on: "ubuntu-latest" + container: "haskell:8.10.7-stretch@sha256:100f8fb7d7d8d64adb5e106fe8136b8d4cbdc03aeb2cbd145a7597d74b69bafb" steps: + - # We need a proper Git repository, but the checkout step will unpack a tarball instead of doing a clone + # if the Git version is less than 2.18. + name: "Install a newer version of Git" + run: | + . /etc/os-release + echo deb http://deb.debian.org/debian "$VERSION_CODENAME"-backports main >> /etc/apt/sources.list + apt-get update && apt-get install -y git/"$VERSION_CODENAME"-backports - uses: "actions/checkout@v2" - - id: "haskell" - uses: "haskell/actions/setup@v1" - with: - enable-stack: true - stack-version: "2.7.1" - stack-no-global: true - - uses: "actions/cache@v2" with: path: | - ${{ steps.haskell.outputs.stack-root }} - key: "${{ runner.os }}-lint-${{ hashFiles('stack.yaml') }}" + /root/.stack + key: "${{ runner.os }}-UnWw0N-lint-${{ hashFiles('stack.yaml') }}" - - run: "ci/run-hlint.sh --git" + - run: "ci/fix-home ci/run-hlint.sh --git" env: VERSION: "2.2.11" @@ -139,16 +161,16 @@ jobs: # `allow-newer: true` is needed so that weeder-2.2.0 can be # installed with the dependencies present in LTS-18. echo 'allow-newer: true' >> stack-weeder.yaml - stack --no-terminal --jobs=2 build --copy-compiler-tool --stack-yaml ./stack-weeder.yaml weeder-2.2.0 + ci/fix-home stack --no-terminal --jobs=2 build --copy-compiler-tool --stack-yaml ./stack-weeder.yaml weeder-2.2.0 - - run: "stack --no-terminal --jobs=2 build --fast --ghc-options -fwrite-ide-info" + - run: "ci/fix-home stack --no-terminal --jobs=2 build --fast --ghc-options -fwrite-ide-info" - - run: "stack exec weeder" + - run: "ci/fix-home stack exec weeder" # Now do it again, with the test suite included. We don't want a # reference from our test suite to count in the above check; the fact # that a function is tested is not evidence that it's needed. But we also # don't want to leave weeds lying around in our test suite either. - - run: "stack --no-terminal --jobs=2 build --fast --test --no-run-tests --ghc-options -fwrite-ide-info" + - run: "ci/fix-home stack --no-terminal --jobs=2 build --fast --test --no-run-tests --ghc-options -fwrite-ide-info" - - run: "stack exec weeder" + - run: "ci/fix-home stack exec weeder" diff --git a/CHANGELOG.d/feature_support_older_glibc.md b/CHANGELOG.d/feature_support_older_glibc.md new file mode 100644 index 0000000000..6e641e6b71 --- /dev/null +++ b/CHANGELOG.d/feature_support_older_glibc.md @@ -0,0 +1,4 @@ +* Support Glibc versions >= `2.24` + + Previously, `purs` required a Glibc version greater than or equal to `2.27`. + This requirement is relaxed to support a Glibc version down to `2.24`. diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 37203a317a..8b4cceee24 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -154,6 +154,7 @@ If you would prefer to use different terms, please use the section below instead | [@thomashoneyman](https://github.com/thomashoneyman) | Thomas Honeyman | [MIT license](http://opensource.org/licenses/MIT) | | [@sigma-andex](https://github.com/sigma-andex) | Jan Schulte | [MIT license](http://opensource.org/licenses/MIT) | | [@i-am-the-slime](https://github.com/i-am-the-slime) | Mark Eibes | [MIT license](http://opensource.org/licenses/MIT) | +| [@sd-yip](https://github.com/sd-yip) | Nicholas Yip | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/ci/build-package-set.sh b/ci/build-package-set.sh index bc60689d34..a6eae3419f 100755 --- a/ci/build-package-set.sh +++ b/ci/build-package-set.sh @@ -16,7 +16,7 @@ export PATH="$tmpdir/node_modules/.bin:$PATH" cd "$tmpdir" echo ::group::Ensure Spago is available -which spago || npm install spago +which spago || npm install spago@0.20.3 echo ::endgroup:: echo ::group::Create dummy project diff --git a/ci/fix-home b/ci/fix-home new file mode 100755 index 0000000000..7423615071 --- /dev/null +++ b/ci/fix-home @@ -0,0 +1,12 @@ +#!/usr/bin/env sh + +# CI Steps on Linux (in the container) are run as root, while on macOS and Windows, they are not. +# And on GitHub Actions, environment variables from the host machine has a higher priority than those from a container, +# including user-specific variables like `USER`, `HOME`, etc. +# +# The following fixes the `HOME` value for CLI tools (primarily Stack) that expects a properly configured `HOME` value. +if [ "$(whoami)" = root ]; then + HOME=/root "$@" +else + "$@" +fi diff --git a/stack.yaml b/stack.yaml index 8818ba186d..b939843858 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,5 @@ +# Please update Haskell image versions under .github/workflows/ci.yml together to use the same GHC version +# (or the CI build will fail) resolver: lts-18.15 pvp-bounds: both packages: From c9fb852922494e07a9eaed93f33772f1f15e1fdf Mon Sep 17 00:00:00 2001 From: Nicholas Yip Date: Sat, 2 Apr 2022 00:21:52 +0900 Subject: [PATCH 1434/1580] Fix ownership of the CI working directory (#4276) --- .github/workflows/ci.yml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index a85890eac9..7d58e9c4f9 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -55,10 +55,11 @@ jobs: stack-version: "${{ env.STACK_VERSION }}" stack-no-global: true - - name: "(Linux only) Check Stack version" + - name: "(Linux only) Check Stack version and fix working directory ownership" if: "${{ runner.os == 'Linux' }}" run: | [ "$(stack --numeric-version)" = "$STACK_VERSION" ] + chown root:root . - uses: "actions/cache@v2" with: @@ -134,6 +135,10 @@ jobs: apt-get update && apt-get install -y git/"$VERSION_CODENAME"-backports - uses: "actions/checkout@v2" + - name: "Fix working directory ownership" + run: | + chown root:root . + - uses: "actions/cache@v2" with: path: | From b8b8d3c8a47e4771f4b8ed75acbb558d6f6b5dcf Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 1 Apr 2022 11:52:27 -0500 Subject: [PATCH 1435/1580] Remove libtinfo from binary; add CI test to ensure not added in future (#4259) * Add CI test to ensure libtinfo isn't in binary * Ensure process is on 1.6.13.1 --- .github/workflows/ci.yml | 10 ++++++++++ purescript.cabal | 2 +- stack.yaml | 4 ++++ 3 files changed, 15 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7d58e9c4f9..86cb259bc2 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -91,6 +91,16 @@ jobs: # binary it created, we need to use the flag here as well. run: "../ci/fix-home stack --haddock exec ../ci/build-package-set.sh" + - name: Verify that 'libtinfo' isn't in binary + if: runner.os == 'Linux' + working-directory: "sdist-test" + run: | + if [ $(ldd $(stack path --local-doc-root)/../bin/purs | grep 'libtinfo' | wc -l) -ge 1 ]; then + echo "libtinfo detected" + ldd $(stack path --local-doc-root)/../bin/purs | grep 'libtinfo' + exit 1 + fi + - name: "(Release only) Create bundle" if: "${{ env.CI_RELEASE == 'true' }}" run: | diff --git a/purescript.cabal b/purescript.cabal index b465f3b8ab..c3f1561bea 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -155,7 +155,7 @@ common defaults parallel >=3.2.2.0 && <3.3, parsec >=3.1.14.0 && <3.2, pattern-arrows >=0.0.2 && <0.1, - process >=1.6.13.2 && <1.7, + process ==1.6.13.1, protolude >=0.3.0 && <0.4, purescript-cst ==0.5.0.0, regex-tdfa >=1.3.1.1 && <1.4, diff --git a/stack.yaml b/stack.yaml index b939843858..c76c7de507 100644 --- a/stack.yaml +++ b/stack.yaml @@ -19,6 +19,10 @@ extra-deps: - hspec-2.8.3 - hspec-core-2.8.3 - hspec-discover-2.8.3 +# Fix issue with libtinfo. +# See https://github.com/purescript/purescript/issues/4253 +- process-1.6.13.1 +- Cabal-3.2.1.0 nix: packages: - zlib From ce0d1a14be98715d2cda90ba7ffab8c40e595fac Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 1 Apr 2022 14:58:57 -0500 Subject: [PATCH 1436/1580] Make alpha-03 release (#4275) --- app/Version.hs | 2 +- purescript.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/app/Version.hs b/app/Version.hs index 0a9b9a4a6a..2893e21a59 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -17,7 +17,7 @@ import qualified Development.GitRev as GitRev -- prerelease identifier here (if any). When releasing a proper version, simply -- set this to an empty string. prerelease :: String -prerelease = "-alpha-02" +prerelease = "-alpha-03" versionString :: String versionString = showVersion Paths.version ++ prerelease ++ extra diff --git a/purescript.cabal b/purescript.cabal index c3f1561bea..ecc2b06679 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.15.0-alpha-02 +version: 0.15.0-alpha-03 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From d0107b5ff7dae2c97d28d9be48792b74d746ba30 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 1 Apr 2022 21:03:02 -0500 Subject: [PATCH 1437/1580] Fix release build path issue; make 0.15.0-alpha-04 release (#4279) * Fix path location * Verify bundle creation works Note: this doesn't cause any of the files to be uploaded * Only create bundle on releases This reverts the previous commit * Update version to alpha-04 --- .github/workflows/ci.yml | 2 +- app/Version.hs | 2 +- purescript.cabal | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 86cb259bc2..22d43efc2e 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -117,7 +117,7 @@ jobs: exit 1;; esac cd sdist-test - ci/fix-home bundle/build.sh "$bundle_os" + ../ci/fix-home bundle/build.sh "$bundle_os" - name: "(Release only) Publish bundle" if: "${{ env.CI_RELEASE == 'true' }}" diff --git a/app/Version.hs b/app/Version.hs index 2893e21a59..61fc6aa0db 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -17,7 +17,7 @@ import qualified Development.GitRev as GitRev -- prerelease identifier here (if any). When releasing a proper version, simply -- set this to an empty string. prerelease :: String -prerelease = "-alpha-03" +prerelease = "-alpha-04" versionString :: String versionString = showVersion Paths.version ++ prerelease ++ extra diff --git a/purescript.cabal b/purescript.cabal index ecc2b06679..5b3c8ff35c 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.15.0-alpha-03 +version: 0.15.0-alpha-04 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 36de70af9d794d6bbc95d5d455901f73d0b7833f Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 5 Apr 2022 08:11:58 -0500 Subject: [PATCH 1438/1580] Stop `purs docs` failure due to `case _ of` in inst decl (#4282) * Add reproducible test for 4274: OperatorSection * Only run incorrect anon arg check on purs compile, not on purs docs See https://github.com/purescript/purescript/issues/4274#issuecomment-1087730651= for more details --- src/Language/PureScript/Docs/Convert.hs | 3 +- src/Language/PureScript/Sugar/Operators.hs | 44 ++++++++++++++++++---- tests/purs/docs/src/OperatorSection.purs | 16 ++++++++ 3 files changed, 55 insertions(+), 8 deletions(-) create mode 100644 tests/purs/docs/src/OperatorSection.purs diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 801b79fdb7..965b349163 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -28,6 +28,7 @@ import qualified Language.PureScript.Roles as P import qualified Language.PureScript.Sugar as P import qualified Language.PureScript.Types as P import qualified Language.PureScript.Constants.Prim as Prim +import Language.PureScript.Sugar (RebracketCaller(CalledByDocs)) -- | -- Convert a single module to a Docs.Module, making use of a pre-existing @@ -270,7 +271,7 @@ partiallyDesugar externs env = evalSupplyT 0 . desugar' >>> P.desugarCasesModule >=> P.desugarTypeDeclarationsModule >=> fmap fst . runWriterT . flip evalStateT (env, mempty) . P.desugarImports - >=> P.rebracketFiltered isInstanceDecl externs + >=> P.rebracketFiltered CalledByDocs isInstanceDecl externs isInstanceDecl P.TypeInstanceDeclaration {} = True isInstanceDecl _ = False diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 0f74abe079..1cba3d0bf5 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -7,6 +7,7 @@ -- module Language.PureScript.Sugar.Operators ( desugarSignedLiterals + , RebracketCaller(..) , rebracket , rebracketFiltered , checkFixityExports @@ -73,7 +74,7 @@ rebracket -> Module -> m Module rebracket = - rebracketFiltered (const True) + rebracketFiltered CalledByCompile (const True) -- | -- A version of `rebracket` which allows you to choose which declarations @@ -86,11 +87,12 @@ rebracketFiltered :: forall m . MonadError MultipleErrors m => MonadSupply m - => (Declaration -> Bool) + => RebracketCaller + -> (Declaration -> Bool) -> [ExternsFile] -> Module -> m Module -rebracketFiltered pred_ externs m = do +rebracketFiltered !caller pred_ externs m = do let (valueFixities, typeFixities) = partitionEithers $ concatMap externsFixities externs @@ -104,7 +106,7 @@ rebracketFiltered pred_ externs m = do let typeOpTable = customOperatorTable' typeFixities let typeAliased = M.fromList (map makeLookupEntry typeFixities) - rebracketModule pred_ valueOpTable typeOpTable m >>= + rebracketModule caller pred_ valueOpTable typeOpTable m >>= renameAliasedOperators valueAliased typeAliased where @@ -178,22 +180,50 @@ rebracketFiltered pred_ externs m = do throwError . errorMessage' pos $ UnknownName $ fmap TyOpName op goType _ other = return other +-- | Indicates whether the `rebracketModule` +-- is being called with the full desugar pass +-- run via `purs compile` or whether +-- only the partial desguar pass is run +-- via `purs docs`. +-- This indication is needed to prevent +-- a `purs docs` error when using +-- `case _ of` syntax in a type class instance. +data RebracketCaller + = CalledByCompile + | CalledByDocs + deriving (Eq, Show) + rebracketModule :: forall m . (MonadError MultipleErrors m) => MonadSupply m - => (Declaration -> Bool) + => RebracketCaller + -> (Declaration -> Bool) -> [[(Qualified (OpName 'ValueOpName), Associativity)]] -> [[(Qualified (OpName 'TypeOpName), Associativity)]] -> Module -> m Module -rebracketModule pred_ valueOpTable typeOpTable (Module ss coms mn ds exts) = +rebracketModule !caller pred_ valueOpTable typeOpTable (Module ss coms mn ds exts) = Module ss coms mn <$> f' ds <*> pure exts where f' :: [Declaration] -> m [Declaration] f' = fmap (map (\d -> if pred_ d then removeParens d else d)) . - flip parU (usingPredicate pred_ (g <=< f)) + flip parU (usingPredicate pred_ h) + + -- | The AST will run through all the desugar passes when compiling + -- and only some of the desugar passes when generating docs. + -- When generating docs, `case _ of` syntax used in an instance declaration + -- can trigger the `IncorrectAnonymousArgument` error because it does not + -- run the same passes that the compile desguaring does. Since `purs docs` + -- will only succeed once `purs compile` succeeds, we can ignore this check + -- when running `purs docs`. + -- See https://github.com/purescript/purescript/issues/4274#issuecomment-1087730651= + -- for more info. + h :: Declaration -> m Declaration + h = case caller of + CalledByDocs -> f + CalledByCompile -> g <=< f (f, _, _, _, _) = everywhereWithContextOnValuesM diff --git a/tests/purs/docs/src/OperatorSection.purs b/tests/purs/docs/src/OperatorSection.purs new file mode 100644 index 0000000000..d8c718f3f1 --- /dev/null +++ b/tests/purs/docs/src/OperatorSection.purs @@ -0,0 +1,16 @@ +module OperatorSection where + +data List a = Nil | Cons a (List a) + +infixr 6 Cons as : + +class Foldable f where + foldl :: forall a b. (b -> a -> b) -> b -> f a -> b + +instance Foldable List where + -- Note: this is not a valid `Foldable` instance, + -- but it verifies that producing docs for + -- this file still works. See #4274 for more details. + foldl f b = case _ of + Nil -> b + a : _as -> f b a From 970bab2e2bc7e97cbfc507fa973c4a168e38d748 Mon Sep 17 00:00:00 2001 From: jgart <47760695+jgarte@users.noreply.github.com> Date: Wed, 13 Apr 2022 23:58:59 -0400 Subject: [PATCH 1439/1580] Add GNU Guix installation instructions (#4286) --- INSTALL.md | 1 + 1 file changed, 1 insertion(+) diff --git a/INSTALL.md b/INSTALL.md index ecda0b18f2..0adba49e91 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -24,6 +24,7 @@ There are several other distributions of the PureScript compiler available, whic * NPM: `npm install -g purescript` * Homebrew (for macOS): `brew install purescript` * FreeBSD binary packages: `pkg install hs-purescript` +* GNU Guix: `guix install purescript` ## Compiling from source From 0527e71725257bf16a3c7bd5fce608e856a77dae Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 14 Apr 2022 14:45:20 -0400 Subject: [PATCH 1440/1580] Lazy initialization for recursive bindings (#4283) This commit adds src/Language/PureScript/CoreFn/Laziness.hs, a transformation on CoreFn that introduces call-by-need semantics to bindings in recursive binding groups. This is the only way to restore soundness to those groups without forbidding many programs we've previously allowed, as historically any reference to another identifier within the same binding group has been permitted as long as it occurs within a lambda, regardless of whether that lambda is reduced in the course of initialization. The rest of PureScript remains call-by-value. Also, the imperfect prohibitions on cyclic references enforced during desugaring and type checking remain in place; consequently, this change does not alter the set of programs accepted by the compiler. For details, see the extensive commentary in Laziness.hs. This is unlikely to break a working program, but the upshot for users is that it's now possible to get a run-time error when dereferencing an identifier in a recursive binding group before it has been initialized, instead of silently getting an `undefined` value and having that maybe or maybe not lead to an error somewhere else. --- CHANGELOG.d/breaking_fix-4179.md | 67 +++ .../src/Language/PureScript/Names.hs | 21 + purescript.cabal | 2 + src/Language/PureScript/CodeGen/JS.hs | 83 ++- src/Language/PureScript/CodeGen/JS/Common.hs | 2 + src/Language/PureScript/Constants/Prelude.hs | 6 + src/Language/PureScript/CoreFn/Laziness.hs | 569 ++++++++++++++++++ src/Language/PureScript/CoreFn/Traversals.hs | 41 ++ stack.yaml | 2 + tests/purs/optimize/4179.out.js | 101 ++++ tests/purs/optimize/4179.purs | 45 ++ tests/purs/passing/4179.js | 2 + tests/purs/passing/4179.purs | 73 +++ tests/purs/passing/4179/CustomAssert.js | 12 + tests/purs/passing/4179/CustomAssert.purs | 10 + .../passing/4179/InitializationError.purs | 14 + 16 files changed, 1026 insertions(+), 24 deletions(-) create mode 100644 CHANGELOG.d/breaking_fix-4179.md create mode 100644 src/Language/PureScript/CoreFn/Laziness.hs create mode 100644 tests/purs/optimize/4179.out.js create mode 100644 tests/purs/optimize/4179.purs create mode 100644 tests/purs/passing/4179.js create mode 100644 tests/purs/passing/4179.purs create mode 100644 tests/purs/passing/4179/CustomAssert.js create mode 100644 tests/purs/passing/4179/CustomAssert.purs create mode 100644 tests/purs/passing/4179/InitializationError.purs diff --git a/CHANGELOG.d/breaking_fix-4179.md b/CHANGELOG.d/breaking_fix-4179.md new file mode 100644 index 0000000000..500f6d593a --- /dev/null +++ b/CHANGELOG.d/breaking_fix-4179.md @@ -0,0 +1,67 @@ +* Lazy initialization for recursive bindings + + This is unlikely to break a working program, but the upshot for users is + that it's now possible to get a run-time error when dereferencing an + identifier in a recursive binding group before it has been initialized, + instead of silently getting an `undefined` value and having that maybe + or maybe not lead to an error somewhere else. + + This change can cause code that relies on tail-call optimization to no + longer compile with that optimization. If you find that code that + previously compiled to a TCO loop no longer does but does include `$lazy` + initializers, please report the issue. + + **Alternate backend maintainers:** for you, this change represents a + clarification of a responsibility shared by all backends. The identifiers + bound in a recursive binding group need to behave as if those identifiers + have call-by-need semantics during the initialization of the entire binding + group. (Initializing the binding group entails ensuring every initializer + has been executed, so after the binding group is initialized, these + identifiers can be considered call-by-value again.) + + If an identifier is needed during its own call-by-need initialization, the + backend must ensure that an explicit run-time error is raised appropriate for + your target platform. This error may be raised at compile time instead if the + backend can determine that such a cycle is inevitable. Returning your + target language's equivalent of JavaScript's `undefined`, as `purs` did in + earlier releases in some cases, is not permitted. + + If your target language natively has call-by-need semantics, you probably + don't have to do anything. If your target language is call-by-value and you + are using PureScript as a library, you can use the function + `Language.PureScript.CoreFn.Laziness.applyLazinessTransform` to your CoreFn + input to satisfy this responsibility; if you do, you will need to do the + following: + + * Translate `InternalIdent RuntimeLazyFactory` and `InternalIdent (Lazy _)` + identifiers to appropriate strings for your backend + * Ensure that any output file that needs it has a reference to a function + named `InternalIdent RuntimeLazyFactory`, with type `forall a. Fn3 String + String (Unit -> a) (Int -> a)`, and with the same semantics as the + following JavaScript (though you should customize the error raised to be + appropriate for your target language): + + ```js + function (name, moduleName, init) { + var state = 0; + var val; + return function (lineNumber) { + if (state === 2) return val; + if (state === 1) throw new ReferenceError(name + " was needed before it finished initializing (module " + moduleName + ", line " + lineNumber + ")", moduleName, lineNumber); + state = 1; + val = init(); + state = 2; + return val; + }; + }; + ``` + + If neither of the previous cases apply to you, you can meet this + responsibility most easily simply by ensuring that all recursive bindings are + lazy. You may instead choose to implement some light analysis to skip + generating lazy bindings in some cases, such as if every initializer in the + binding group is an `Abs`. You also may choose to reimplement + `applyLazinessTransform`, or even develop a more sophisticated laziness + transform for your backend. It is of course your responsibility to ensure + that the result of whatever analysis you do is equivalent to the expected + semantics. diff --git a/lib/purescript-cst/src/Language/PureScript/Names.hs b/lib/purescript-cst/src/Language/PureScript/Names.hs index fe127f3e0f..50c3330425 100644 --- a/lib/purescript-cst/src/Language/PureScript/Names.hs +++ b/lib/purescript-cst/src/Language/PureScript/Names.hs @@ -57,6 +57,21 @@ getClassName :: Name -> Maybe (ProperName 'ClassName) getClassName (TyClassName name) = Just name getClassName _ = Nothing +-- | +-- This type is meant to be extended with any new uses for idents that come +-- along. Adding constructors to this type is cheaper than adding them to +-- `Ident` because functions that match on `Ident` can ignore all +-- `InternalIdent`s with a single pattern, and thus don't have to change if +-- a new `InternalIdentData` constructor is created. +-- +data InternalIdentData + -- Used by CoreFn.Laziness + = RuntimeLazyFactory | Lazy !Text + deriving (Show, Eq, Ord, Generic) + +instance NFData InternalIdentData +instance Serialise InternalIdentData + -- | -- Names for value identifiers -- @@ -73,6 +88,10 @@ data Ident -- A generated name used only for type-checking -- | UnusedIdent + -- | + -- A generated name used only for internal transformations + -- + | InternalIdent !InternalIdentData deriving (Show, Eq, Ord, Generic) instance NFData Ident @@ -86,6 +105,7 @@ runIdent (Ident i) = i runIdent (GenIdent Nothing n) = "$" <> T.pack (show n) runIdent (GenIdent (Just name) n) = "$" <> name <> T.pack (show n) runIdent UnusedIdent = unusedIdent +runIdent InternalIdent{} = error "unexpected InternalIdent" showIdent :: Ident -> Text showIdent = runIdent @@ -242,6 +262,7 @@ isQualifiedWith _ _ = False $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''InternalIdentData) instance ToJSON ModuleName where toJSON (ModuleName name) = toJSON (T.splitOn "." name) diff --git a/purescript.cabal b/purescript.cabal index 5b3c8ff35c..abcf989099 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -151,6 +151,7 @@ common defaults microlens-platform >=0.4.2 && <0.5, monad-control >=1.0.3.1 && <1.1, monad-logger >=0.3.36 && <0.4, + monoidal-containers >=0.6.2.0 && <0.7, mtl >=2.2.2 && <2.3, parallel >=3.2.2.0 && <3.3, parsec >=3.1.14.0 && <3.2, @@ -198,6 +199,7 @@ library Language.PureScript.CoreFn.Desugar Language.PureScript.CoreFn.Expr Language.PureScript.CoreFn.FromJSON + Language.PureScript.CoreFn.Laziness Language.PureScript.CoreFn.Meta Language.PureScript.CoreFn.Module Language.PureScript.CoreFn.Optimizer diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 6a71a97dec..1564c7cd75 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -14,6 +14,7 @@ import Control.Monad (forM, replicateM, void) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Supply.Class +import Control.Monad.Writer (MonadWriter, runWriterT, writer) import Data.Bifunctor (first) import Data.List ((\\), intersect) @@ -22,17 +23,19 @@ import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Set as S import Data.Maybe (fromMaybe, mapMaybe, maybeToList) +import Data.Monoid (Any(..)) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.AST.SourcePos import Language.PureScript.CodeGen.JS.Common as Common -import Language.PureScript.CoreImp.AST (AST, everywhereTopDownM, withSourceSpan) +import Language.PureScript.CoreImp.AST (AST, everywhere, everywhereTopDownM, withSourceSpan) import qualified Language.PureScript.CoreImp.AST as AST import qualified Language.PureScript.CoreImp.Module as AST import Language.PureScript.CoreImp.Optimizer import Language.PureScript.CoreFn +import Language.PureScript.CoreFn.Laziness (applyLazinessTransform) import Language.PureScript.Crash import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..), MultipleErrors(..), rethrow, errorMessage, @@ -58,10 +61,10 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = let usedNames = concatMap getNames decls let mnLookup = renameImports usedNames imps let decls' = renameModules mnLookup decls - jsDecls <- mapM bindToJs decls' + (jsDecls, Any needRuntimeLazy) <- runWriterT $ mapM (moduleBindToJs mn) decls' let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup let moduleObjectNames = "$foreign" `S.insert` M.keysSet mnReverseLookup - optimized <- traverse (traverse (fmap (annotatePure moduleObjectNames) . optimize)) jsDecls + optimized <- traverse (traverse (fmap (annotatePure moduleObjectNames) . optimize)) (if needRuntimeLazy then [runtimeLazy] : jsDecls else jsDecls) let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized `S.union` M.keysSet reExps let jsImports @@ -206,6 +209,57 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = go (AST.Var _ name) = foldMap S.singleton $ M.lookup name mnReverseLookup go _ = mempty + -- Check that all integers fall within the valid int range for JavaScript. + checkIntegers :: AST -> m () + checkIntegers = void . everywhereTopDownM go + where + go :: AST -> m AST + go (AST.Unary _ AST.Negate (AST.NumericLiteral ss (Left i))) = + -- Move the negation inside the literal; since this is a top-down + -- traversal doing this replacement will stop the next case from raising + -- the error when attempting to use -2147483648, as if left unrewritten + -- the value is `Unary Negate (NumericLiteral (Left 2147483648))`, and + -- 2147483648 is larger than the maximum allowed int. + return $ AST.NumericLiteral ss (Left (-i)) + go js@(AST.NumericLiteral ss (Left i)) = + let minInt = -2147483648 + maxInt = 2147483647 + in if i < minInt || i > maxInt + then throwError . maybe errorMessage errorMessage' ss $ IntOutOfRange i "JavaScript" minInt maxInt + else return js + go other = return other + + runtimeLazy :: AST + runtimeLazy = + AST.VariableIntroduction Nothing "$runtime_lazy" . Just . AST.Function Nothing Nothing ["name", "moduleName", "init"] . AST.Block Nothing $ + [ AST.VariableIntroduction Nothing "state" . Just . AST.NumericLiteral Nothing $ Left 0 + , AST.VariableIntroduction Nothing "val" Nothing + , AST.Return Nothing . AST.Function Nothing Nothing ["lineNumber"] . AST.Block Nothing $ + [ AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing "state") (AST.NumericLiteral Nothing (Left 2))) (AST.Return Nothing $ AST.Var Nothing "val") Nothing + , AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing "state") (AST.NumericLiteral Nothing (Left 1))) (AST.Throw Nothing $ AST.Unary Nothing AST.New (AST.App Nothing (AST.Var Nothing "ReferenceError") [foldl1 (AST.Binary Nothing AST.Add) + [ AST.Var Nothing "name" + , AST.StringLiteral Nothing " was needed before it finished initializing (module " + , AST.Var Nothing "moduleName" + , AST.StringLiteral Nothing ", line " + , AST.Var Nothing "lineNumber" + , AST.StringLiteral Nothing ")" + ], AST.Var Nothing "moduleName", AST.Var Nothing "lineNumber"])) Nothing + , AST.Assignment Nothing (AST.Var Nothing "state") . AST.NumericLiteral Nothing $ Left 1 + , AST.Assignment Nothing (AST.Var Nothing "val") $ AST.App Nothing (AST.Var Nothing "init") [] + , AST.Assignment Nothing (AST.Var Nothing "state") . AST.NumericLiteral Nothing $ Left 2 + , AST.Return Nothing $ AST.Var Nothing "val" + ] + ] + + +moduleBindToJs + :: forall m + . (Monad m, MonadReader Options m, MonadSupply m, MonadWriter Any m, MonadError MultipleErrors m) + => ModuleName + -> Bind Ann + -> m [AST] +moduleBindToJs mn = bindToJs + where -- | -- Generate code in the simplified JavaScript intermediate representation for a declaration -- @@ -215,7 +269,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = -- ever applied; it's not possible to use them as values. So it's safe to -- erase them. bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val - bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS) + bindToJs (Rec vals) = writer (applyLazinessTransform mn vals) >>= traverse (uncurry . uncurry $ nonRecToJS) -- | Generate code in the simplified JavaScript intermediate representation for a single non-recursive -- declaration. @@ -250,6 +304,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = moduleAccessor (Ident prop) = moduleAccessorString prop moduleAccessor (GenIdent _ _) = internalError "GenIdent in moduleAccessor" moduleAccessor UnusedIdent = internalError "UnusedIdent in moduleAccessor" + moduleAccessor InternalIdent{} = internalError "InternalIdent in moduleAccessor" moduleAccessorString :: Text -> AST -> AST moduleAccessorString = accessorString . mkString . T.replace "'" "$prime" @@ -486,23 +541,3 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = done'' <- go done' (index + 1) bs' js <- binderToJs elVar done'' binder return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js) - - -- Check that all integers fall within the valid int range for JavaScript. - checkIntegers :: AST -> m () - checkIntegers = void . everywhereTopDownM go - where - go :: AST -> m AST - go (AST.Unary _ AST.Negate (AST.NumericLiteral ss (Left i))) = - -- Move the negation inside the literal; since this is a top-down - -- traversal doing this replacement will stop the next case from raising - -- the error when attempting to use -2147483648, as if left unrewritten - -- the value is `Unary Negate (NumericLiteral (Left 2147483648))`, and - -- 2147483648 is larger than the maximum allowed int. - return $ AST.NumericLiteral ss (Left (-i)) - go js@(AST.NumericLiteral ss (Left i)) = - let minInt = -2147483648 - maxInt = 2147483647 - in if i < minInt || i > maxInt - then throwError . maybe errorMessage errorMessage' ss $ IntOutOfRange i "JavaScript" minInt maxInt - else return js - go other = return other diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 746005be68..b3fd2c46d1 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -24,6 +24,8 @@ identToJs :: Ident -> Text identToJs (Ident name) = anyNameToJs name identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" identToJs UnusedIdent = unusedIdent +identToJs (InternalIdent RuntimeLazyFactory) = "$runtime_lazy" +identToJs (InternalIdent (Lazy name)) = "$lazy_" <> anyNameToJs name -- | Convert a 'ProperName' into a valid JavaScript identifier: -- diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index 7ba65dbba1..608b5deb9c 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -282,6 +282,12 @@ pattern Reflectable = Qualified (Just DataReflectable) (ProperName "Reflectable" pattern DataOrdering :: ModuleName pattern DataOrdering = ModuleName "Data.Ordering" +pattern DataFunctionUncurried :: ModuleName +pattern DataFunctionUncurried = ModuleName "Data.Function.Uncurried" + +pattern PartialUnsafe :: ModuleName +pattern PartialUnsafe = ModuleName "Partial.Unsafe" + pattern Ordering :: Qualified (ProperName 'TypeName) pattern Ordering = Qualified (Just DataOrdering) (ProperName "Ordering") diff --git a/src/Language/PureScript/CoreFn/Laziness.hs b/src/Language/PureScript/CoreFn/Laziness.hs new file mode 100644 index 0000000000..fbe7ffb9fb --- /dev/null +++ b/src/Language/PureScript/CoreFn/Laziness.hs @@ -0,0 +1,569 @@ +module Language.PureScript.CoreFn.Laziness + ( applyLazinessTransform + ) where + +import Protolude hiding (force) +import Protolude.Unsafe (unsafeHead) + +import Control.Arrow ((&&&)) +import qualified Data.Array as A +import Data.Coerce (coerce) +import Data.Graph (SCC(..), stronglyConnComp) +import Data.List (foldl1', (!!)) +import qualified Data.IntMap.Monoidal as IM +import qualified Data.IntSet as IS +import qualified Data.Map.Monoidal as M +import Data.Semigroup (Max(..)) +import qualified Data.Set as S + +import Language.PureScript.AST.SourcePos +import qualified Language.PureScript.Constants.Prelude as C +import Language.PureScript.CoreFn +import Language.PureScript.Crash +import Language.PureScript.Names +import Language.PureScript.PSString (mkString) + +-- This module is responsible for ensuring that the bindings in recursive +-- binding groups are initialized in a valid order, introducing run-time +-- laziness and initialization checks as necessary. +-- +-- PureScript is a call-by-value language with strict data constructors, this +-- transformation notwithstanding. The only laziness introduced here is in the +-- initialization of a binding. PureScript is uninterested in the order in +-- which bindings are written by the user. The compiler has always attempted to +-- emit the bindings in an order that makes sense for the backend, but without +-- this transformation, recursive bindings are emitted in an arbitrary order, +-- which can cause unexpected behavior at run time if a binding is dereferenced +-- before it has initialized. +-- +-- To prevent unexpected errors, this transformation does a syntax-driven +-- analysis of a single recursive binding group to attempt to statically order +-- the bindings, and when that fails, falls back to lazy initializers that will +-- succeed or fail deterministically with a clear error at run time. +-- +-- Example: +-- +-- x = f \_ -> +-- x +-- +-- becomes (with some details of the $runtime_lazy function elided): +-- +-- -- the binding of x has been rewritten as a lazy initializer +-- $lazy_x = $runtime_lazy \_ -> +-- f \_ -> +-- $lazy_x 2 -- the reference to x has been rewritten as a force call +-- x = $lazy_x 1 +-- +-- Central to this analysis are the concepts of delay and force, which are +-- attributes given to every subexpression in the binding group. Delay and +-- force are defined by the following traversal. This traversal is used twice: +-- once to collect all the references made by each binding in the group, and +-- then again to rewrite some references to force calls. (The implications of +-- delay and force on initialization order are specified later.) + +-- | +-- Visits every `Var` in an expression with the provided function, including +-- the amount of delay and force applied to that `Var`, and substitutes the +-- result back into the tree (propagating an `Applicative` effect). +-- +-- Delay is a non-negative integer that represents the number of lambdas that +-- enclose an expression. Force is a non-negative integer that represents the +-- number of values that are being applied to an expression. Delay is always +-- statically determinable, but force can be *unknown*, so it's represented +-- here with a Maybe. In a function application `f a b`, `f` has force 2, but +-- `a` and `b` have unknown force--it depends on what `f` does with them. +-- +-- The rules of assigning delay and force are simple: +-- * The expressions that are assigned to bindings in this group have +-- delay 0, force 0. +-- * In a function application, the function expression has force 1 higher +-- than the force of the application expression, and the argument +-- expression has unknown force. +-- * UNLESS this argument is being directly provided to a constructor (in +-- other words, the function expression is either a constructor itself or +-- a constructor that has already been partially applied), in which case +-- the force of both subexpressions is unchanged. We can assume that +-- constructors don't apply any additional force to their arguments. +-- * If the force of a lambda is zero, the delay of the body of the lambda is +-- incremented; otherwise, the force of the body of the lambda is +-- decremented. (Applying one argument to a lambda cancels out one unit of +-- delay.) +-- * In the argument of a Case and the bindings of a Let, force is unknown. +-- * Everywhere else, preserve the delay and force of the enclosing +-- expression. +-- +-- Here are some illustrative examples of the above rules. We will use a +-- pseudocode syntax to annotate a subexpression with delay and force: +-- `expr#d!f` means `expr` has delay d and force f. `!*` is used to denote +-- unknown force. +-- +-- x = y#0!0 +-- x = y#0!2 a#0!* b#0!* +-- x = (\_ -> y#1!0)#0!0 +-- x = \_ _ -> y#2!1 a#2!* +-- x = (\_ -> y#0!0)#0!1 z#0!* +-- x = Just { a: a#0!0, b: b#0!0 } +-- x = let foo = (y#1!* a b#1!*)#1!* in foo + 1 +-- +-- (Note that this analysis is quite ignorant of any actual control flow +-- choices made at run time. It doesn't even track what happens to a reference +-- after it has been locally bound by a Let or Case. Instead, it just assumes +-- the worst--once locally bound to a new name, it imagines that absolutely +-- anything could happen to that new name and thus to the underlying reference. +-- But the value-to-weight ratio of this approach is perhaps surprisingly +-- high.) +-- +-- Every subexpression gets a delay and a force, but we are only interested +-- in references to other bindings in the binding group, so the traversal only +-- exposes `Var`s to the provided function. +-- +onVarsWithDelayAndForce :: forall f. Applicative f => (Int -> Maybe Int -> Ann -> Qualified Ident -> f (Expr Ann)) -> Expr Ann -> f (Expr Ann) +onVarsWithDelayAndForce f = snd . go 0 $ Just 0 + where + go :: Int -> Maybe Int -> (Bind Ann -> f (Bind Ann), Expr Ann -> f (Expr Ann)) + go delay force = (handleBind, handleExpr') + where + (handleBind, handleExpr, handleBinder, handleCaseAlternative) = traverseCoreFn handleBind handleExpr' handleBinder handleCaseAlternative + handleExpr' = \case + Var a i -> f delay force a i + Abs a i e -> Abs a i <$> snd (if force == Just 0 then go (succ delay) force else go delay $ fmap pred force) e + -- A clumsy hack to preserve TCO in a particular idiom of unsafePartial once seen in Data.Map.Internal, possibly still used elsewhere. + App a1 e1@(Var _ (Qualified (Just C.PartialUnsafe) (Ident up))) (Abs a2 i e2) | up == C.unsafePartial + -> App a1 e1 . Abs a2 i <$> handleExpr' e2 + App a e1 e2 -> + -- `handleApp` is just to handle the constructor application exception + -- somewhat gracefully (i.e., without requiring a deep inspection of + -- the function expression at every step). If we didn't care about + -- constructors, this could have been simply: + -- App a <$> snd (go delay (fmap succ force)) e1 <*> snd (go delay Nothing) e2 + handleApp 1 [(a, e2)] e1 + Case a vs alts -> Case a <$> traverse (snd $ go delay Nothing) vs <*> traverse handleCaseAlternative alts + Let a ds e -> Let a <$> traverse (fst $ go delay Nothing) ds <*> handleExpr' e + other -> handleExpr other + + handleApp len args = \case + App a e1 e2 -> handleApp (len + 1) ((a, e2) : args) e1 + Var a@(_, _, _, Just meta) i | isConstructorLike meta + -> foldl (\e1 (a2, e2) -> App a2 <$> e1 <*> handleExpr' e2) (f delay force a i) args + e -> foldl (\e1 (a2, e2) -> App a2 <$> e1 <*> snd (go delay Nothing) e2) (snd (go delay (fmap (+ len) force)) e) args + isConstructorLike = \case + IsConstructor{} -> True + IsNewtype -> True + _ -> False + +-- Once we assign a delay and force value to every `Var` in the binding group, +-- we can consider how to order the bindings to allow them all to successfully +-- initialize. There is one principle here: each binding must be initialized +-- before the identifier being bound is ready for use. If the preorder thus +-- induced has cycles, those cycles need to be resolved with laziness. All of +-- the details concern what "ready for use" means. +-- +-- The definition of delay and force suggests that "ready for use" depends on +-- those attributes. If a lambda is bound to the name x, then the references in +-- the lambda don't need to be initialized before x is initialized. This is +-- represented by the fact that those references have non-zero delay. But if +-- the expression bound to x is instead the application of a function y that is +-- also bound in this binding group, then not only does y need to be +-- initialized before x, so do some of the non-zero delay references in y. This +-- is represented by the fact that the occurrence of y in the expression bound +-- to x has non-zero force. +-- +-- An example, reusing the pseudocode annotations defined above: +-- +-- x _ = y#1!0 +-- y = x#0!1 a +-- +-- y doesn't need to be initialized before x is, because the reference to y in +-- x's initializer has delay 1. But y does need to be initialized before x is +-- ready for use with force 1, because force 1 is enough to overcome the delay +-- of that reference. And since y has a delay-0 reference to x with force 1, y +-- will need to be ready for use before it is initialized; thus, y needs to be +-- made lazy. +-- +-- So just as function applications "cancel out" lambdas, a known applied force +-- cancels out an equal amount of delay, causing some references that may not +-- have been needed earlier to enter play. (And to be safe, we must assume that +-- unknown force cancels out *any* amount of delay.) There is another, subtler +-- aspect of this: if there are not enough lambdas to absorb every argument +-- applied to a function, those arguments will end up applied to the result of +-- the function. Likewise, if there is excess force left over after some of it +-- has been canceled by delay, that excess is carried to the references +-- activated. (Again, an unknown amount of force must be assumed to lead to an +-- unknown amount of excess force.) +-- +-- Another example: +-- +-- f = g#0!2 a b +-- g x = h#1!2 c x +-- h _ _ _ = f#3!0 +-- +-- Initializing f will lead to an infinite loop in this example. f invokes g +-- with two arguments. g absorbs one argument, and the second ends up being +-- applied to the result of h c x, resulting in h being invoked with three +-- arguments. Invoking h with three arguments results in dereferencing f, which +-- is not yet ready. To capture this loop in our analysis, we say that making +-- f ready for use with force 0 requires making g ready for use with force 2, +-- which requires making h ready for use with force 3 (two units of force from +-- the lexical position of h, plus one unit of excess force carried forward), +-- which cyclically requires f to be ready for use with force 0. +-- +-- These preceding observations are captured and generalized by the following +-- rules: +-- +-- USE-INIT: Before a reference to x is ready for use with any force, x must +-- be initialized. +-- +-- We will make x lazy iff this rule induces a cycle--i.e., initializing x +-- requires x to be ready for use first. +-- +-- USE-USE: Before a reference to x is ready for use with force f: +-- * if a reference in the initializer of x has delay d and force f', +-- * and either d <= f or f is unknown, +-- * then that reference must itself be ready for use with +-- force f – d + f' (or with unknown force if f or f' is unknown). +-- +-- USE-IMMEDIATE: Initializing a binding x is equivalent to requiring a +-- reference to x to be ready for use with force 0, per USE-USE. +-- +-- Equivalently: before x is initialized, any reference in the initializer +-- of x with delay 0 and force f must be ready for use with force f. +-- +-- Examples: +-- +-- Assume x is bound in a recursive binding group with the below bindings. +-- +-- All of the following initializers require x to be ready for use with some +-- amount of force, and therefore require x to be initialized first. +-- +-- a = x#0!0 +-- b = (\_ -> x#0!0) 1 +-- c = foo x#0!* +-- d = (\_ -> foo x#0!*) 1 +-- +-- In the following initializers, before p can be initialized, x must be +-- ready for use with force f – d + f'. (And both x and q must be +-- initialized, of course; but x being ready for use with that force may +-- induce additional constraints.) +-- +-- p = ... q#0!f ... +-- q = ... x#d!f' ... (where d <= f) +-- +-- Excess force stacks, of course: in the following initializers, before r +-- can be initialized, x must be ready for use with force +-- f — d + f' — d' + f'': +-- +-- r = ... s#0!f ... +-- s = ... t#d!f' ... (where d <= f) +-- t = ... x#d'!f'' ... (where d' <= f – d + f') +-- +-- +-- To satisfy these rules, we will construct a graph between (identifier, +-- delay) pairs, with edges induced by the USE-USE rule, and effectively run a +-- topsort to get the initialization preorder. For this part, it's simplest to +-- think of delay as an element of the naturals extended with a positive +-- infinity, corresponding to an unknown amount of force. (We'll do arithmetic +-- on these extended naturals as you would naively expect; we won't do anything +-- suspect like subtracting infinity from infinity.) With that in mind, we can +-- construct the graph as follows: for each reference from i1 to i2 with delay +-- d and force f, draw an infinite family of edges from (i1, d + n) to (i2, f + +-- n) for all 0 <= n <= ∞, where n represents the excess force carried over +-- from a previous edge. Unfortunately, as an infinite graph, we can't expect +-- the tools in Data.Graph to help us traverse it; we will have to be a little +-- bit clever. +-- +-- The following data types and functions are for searching this infinite graph +-- and carving from it a finite amount of data to work with. Specifically, we +-- want to know for each identifier i, which other identifiers are +-- irreflexively reachable from (i, 0) (and thus must be initialized before i +-- is), and with what maximum force (in the event of a loop, not every +-- reference to i in the reachable identifier needs to be rewritten to a force +-- call; only the ones with delay up to the maximum force used during i's +-- initialization). We also want the option of aborting a given reachability +-- search, for one of two reasons. +-- +-- * If we encounter a reference with unknown force, abort. +-- * If we encounter a cycle where force on a single identifier is +-- increasing, abort. (Because of USE-USE, as soon as an identifier is +-- revisited with greater force than its first visit, the difference is +-- carried forward as excess, so it is possible to retrace that path to get +-- an arbitrarily high amount of force.) +-- +-- Both reasons mean that it is theoretically possible for the identifier in +-- question to need every other identifier in the binding group to be +-- initialized before it is. (Every identifier in a recursive binding group is +-- necessarily reachable from every other, ignoring delay and force, which is +-- what arbitrarily high force lets you do.) +-- +-- In order to reuse parts of this reachability computation across identifiers, +-- we are going to represent it with a rose tree data structure interleaved with +-- a monad capturing the abort semantics. (The monad is Maybe, but we don't +-- need to know that here!) + +type MaxRoseTree m a = m (IM.MonoidalIntMap (MaxRoseNode m a)) +data MaxRoseNode m a = MaxRoseNode a (MaxRoseTree m a) + +-- Dissecting this data structure: +-- +-- m (...) +-- ^ represents whether to abort or continue the search +-- +-- IM.MonoidalIntMap (...) +-- ^ the keys of this map are other identifiers reachable from the current +-- one (we'll map the identifiers in this binding group to Ints for ease of +-- computation) +-- +-- the values of this map are: +-- +-- MaxRoseNode a (...) +-- ^ this will store the force applied to the next identifier +-- (MaxRoseTree m a) +-- ^ and this, the tree of identifiers reachable from there +-- +-- We're only interested in continuing down the search path that applies the +-- most force to a given identifier! So when we combine two MaxRoseTrees, +-- we want to resolve any key collisions in their MonoidalIntMaps with this +-- semigroup: + +instance Ord a => Semigroup (MaxRoseNode m a) where + l@(MaxRoseNode l1 _) <> r@(MaxRoseNode r1 _) = if r1 > l1 then r else l + +-- And that's why this is called a MaxRoseTree. +-- +-- Traversing this tree to get a single MonoidalIntMap with the entire closure +-- plus force information is fairly straightforward: + +mrtFlatten :: (Monad m, Ord a) => MaxRoseTree m a -> m (IM.MonoidalIntMap (Max a)) +mrtFlatten = (getAp . IM.foldMapWithKey (\i (MaxRoseNode a inner) -> Ap $ (IM.singleton i (Max a) <>) <$> mrtFlatten inner) =<<) + +-- The use of the `Ap` monoid ensures that if any child of this tree aborts, +-- the entire tree aborts. +-- +-- One might ask, why interleave the abort monad with the tree at all if we're +-- just going to flatten it out at the end? The point is to flatten it out at +-- the end, but *not* during the generation of the tree. Attempting to flatten +-- the tree as we generate it can result in an infinite loop, because a subtree +-- needs to be exhaustively searched for abort conditions before it can be used +-- in another tree. With this approach, we can use lazy trees as building +-- blocks and, as long as they get rewritten to be finite or have aborts before +-- they're flattened, the analysis still terminates. + +-- | +-- Given a maximum index and a function that returns a map of edges to next +-- indices, returns an array for each index up to maxIndex of maps from the +-- indices reachable from the current index, to the maximum force applied to +-- those indices. +searchReachable + :: forall m force + . (Alternative m, Monad m, Enum force, Ord force) + => Int + -> ((Int, force) -> m (IM.MonoidalIntMap (Max force))) + -> A.Array Int (m (IM.MonoidalIntMap (Max force))) +searchReachable maxIdx lookupEdges = mrtFlatten . unsafeHead <$> mem + where + -- This is a finite array of infinite lists, used to memoize all the search + -- trees. `unsafeHead` is used above to pull the first tree out of each list + -- in the array--the one corresponding to zero force, which is what's needed + -- to initialize the corresponding identifier. (`unsafeHead` is safe here, of + -- course: infinite lists.) + mem :: A.Array Int [MaxRoseTree m force] + mem = A.listArray (0, maxIdx) + [ [cutLoops <*> fmap (IM.mapWithKey memoizedNode) . lookupEdges $ (i, f) | f <- [toEnum 0..]] + | i <- [0..maxIdx] + ] + + memoizedNode :: Int -> Max force -> MaxRoseNode m force + memoizedNode i (Max force) = MaxRoseNode force $ mem A.! i !! fromEnum force + + -- And this is the function that prevents the search from actually being + -- infinite. It applies a filter to a `MaxRoseTree` at every level, looking for + -- indices anywhere in the tree that match the current vertex. If a match is + -- found with greater force than the current force, that part of the tree is + -- rewritten to abort; otherwise, that part of the tree is rewritten to be + -- empty (there's nothing new in that part of the search). + -- + -- A new version of `cutLoops` is applied for each node in the search, so + -- each edge in a search path will add another filter on a new index. Since + -- there are a finite number of indices in our universe, this guarantees that + -- the analysis terminates, because no single search path can have length + -- greater than `maxIdx`. + cutLoops :: (Int, force) -> MaxRoseTree m force -> MaxRoseTree m force + cutLoops (i, force) = go + where + go = (=<<) . IM.traverseWithKey $ \i' (MaxRoseNode force' inner) -> + MaxRoseNode force' <$> if i == i' then guard (force >= force') $> pure IM.empty else pure $ go inner + +-- One last data structure to define and then it's on to the main event. +-- +-- The laziness transform effectively takes a list of eager bindings (x = ...) +-- and splits some of them into lazy definitions ($lazy_x = ...) and lazy +-- bindings (x = $lazy_x ...). It's convenient to work with these three +-- declarations as the following sum type: + +data RecursiveGroupItem e = EagerBinding Ann e | LazyDefinition e | LazyBinding Ann + deriving Functor + +-- | +-- Transform a recursive binding group, reordering the bindings within when a +-- correct initialization order can be statically determined, and rewriting +-- bindings and references to be lazy otherwise. +-- +applyLazinessTransform :: ModuleName -> [((Ann, Ident), Expr Ann)] -> ([((Ann, Ident), Expr Ann)], Any) +applyLazinessTransform mn rawItems = let + + -- Establish the mapping from names to ints. + rawItemsByName :: M.MonoidalMap Ident (Ann, Expr Ann) + rawItemsByName = M.fromList $ (snd . fst &&& first fst) <$> rawItems + + maxIdx = M.size rawItemsByName - 1 + + rawItemsByIndex :: A.Array Int (Ann, Expr Ann) + rawItemsByIndex = A.listArray (0, maxIdx) $ M.elems rawItemsByName + + names :: S.Set Ident + names = M.keysSet rawItemsByName + + -- Now do the first delay/force traversal of all the bindings to find + -- references to other names in this binding group. + -- + -- The parts of this type mean: + -- D is the maximum force (or Nothing if unknown) with which the identifier C + -- is referenced in any delay-B position inside the expression A. + -- + -- where A, B, C, and D are as below: + -- A B (keys) C (keys) D + findReferences :: Expr Ann -> IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int))) + findReferences = (getConst .) . onVarsWithDelayAndForce $ \delay force _ -> \case + Qualified mn' ident | all (== mn) mn', Just i <- ident `S.lookupIndex` names + -> Const . IM.singleton delay . IM.singleton i $ coerceForce force + _ -> Const IM.empty + + -- The parts of this type mean: + -- D is the maximum force (or Nothing if unknown) with which the identifier C + -- is referenced in any delay-B position inside the binding of identifier A. + -- + -- where A, B, C, and D are as below: + -- A B (keys) C (keys) D + refsByIndex :: A.Array Int (IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int)))) + refsByIndex = findReferences . snd <$> rawItemsByIndex + + -- Using the approach explained above, traverse the reference graph generated + -- by `refsByIndex` and find all reachable names. + -- + -- The parts of this type mean: + -- D is the maximum force with which the identifier C is referenced, + -- directly or indirectly, during the initialization of identifier A. B is + -- Nothing if the analysis of A was inconclusive and A might need the entire + -- binding group. + -- + -- where A, B, C, and D are as below: + -- A B C (keys) D + reachablesByIndex :: A.Array Int (Maybe (IM.MonoidalIntMap (Max Int))) + reachablesByIndex = searchReachable maxIdx $ \(i, force) -> + getAp . flip IM.foldMapWithKey (dropKeysAbove force $ refsByIndex A.! i) $ \delay -> + IM.foldMapWithKey $ \i' force' -> + Ap $ IM.singleton i' . Max . (force - delay +) <$> uncoerceForce force' + + -- If `reachablesByIndex` is a sort of labeled relation, this function + -- produces part of the reverse relation, but only for the edges from the + -- given vertex. + -- + -- The parts of this type mean: + -- The identifier A is reachable from the identifier B with maximum force C + -- (B is also the index provided to the function). + -- + -- where A, B, and C are as below: + -- (B) A B (singleton key) C + reverseReachablesFor :: Int -> IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int))) + reverseReachablesFor i = case reachablesByIndex A.! i of + Nothing -> IM.fromAscList $ (, IM.singleton i $ Ap Nothing) <$> [0..maxIdx] + Just im -> IM.singleton i . Ap . Just <$> im + + -- We can use `reachablesByIndex` to build a finite graph and topsort it; + -- in the process, we'll pack the nodes of the graph with data we'll want + -- next. Remember that if our reachability computation aborted, we have to + -- assume that every other identifier is reachable from that one--hence the + -- `maybe [0..maxIdx]`. + sccs = stronglyConnComp $ do + (i, mbReachable) <- A.assocs reachablesByIndex + pure ((reverseReachablesFor i, (S.elemAt i names, rawItemsByIndex A.! i)), i, maybe [0..maxIdx] (IS.toList . IM.keysSet) mbReachable) + + (replacements, items) = flip foldMap sccs $ \case + -- The easy case: this binding doesn't need to be made lazy after all! + AcyclicSCC (_, (ident, (a, e))) -> pure [(ident, EagerBinding a e)] + -- The tough case: we have a loop. + -- We need to do two things here: + -- * Collect the reversed reachables relation for each vertex in this + -- loop; we'll use this to replace references with force calls + -- * Copy the vertex list into two lists: a list of lazy definitions and + -- a list of lazy bindings + -- Both of these results are monoidal, so the outer `foldMap` will + -- concatenate them pairwise. + CyclicSCC vertices -> (foldMap fst vertices, map (fmap (LazyDefinition . snd) . snd) vertices ++ map (fmap (LazyBinding . fst) . snd) vertices) + + -- We have `replacements` expressed in terms of indices; we want to map it + -- back to names before traversing the bindings again. + replacementsByName :: M.MonoidalMap Ident (M.MonoidalMap Ident (Ap Maybe (Max Int))) + replacementsByName = M.fromAscList . map (bimap (flip S.elemAt names) (M.fromAscList . map (first (flip S.elemAt names)) . IM.toAscList)) . IM.toAscList $ replacements + + -- And finally, this is the second delay/force traversal where we take + -- `replacementsByName` and use it to rewrite references with force calls, + -- but only if the delay of those references is at most the maximum amount + -- of force used by the initialization of the referenced binding to + -- reference the outer binding. A reference made with a higher delay than + -- that can safely continue to use the original reference, since it won't be + -- needed until after the referenced binding is done initializing. + replaceReferencesWithForceCall :: (Ident, RecursiveGroupItem (Expr Ann)) -> (Ident, RecursiveGroupItem (Expr Ann)) + replaceReferencesWithForceCall pair@(ident, item) = case ident `M.lookup` replacementsByName of + Nothing -> pair + Just m -> let + rewriteExpr = (runIdentity .) . onVarsWithDelayAndForce $ \delay _ ann -> pure . \case + Qualified mn' ident' | all (== mn) mn', any (all (>= Max delay) . getAp) $ ident' `M.lookup` m + -> makeForceCall ann ident' + q -> Var ann q + in (ident, rewriteExpr <$> item) + + -- All that's left to do is run the above replacement on every item, + -- translate items from our `RecursiveGroupItem` representation back into the + -- form CoreFn expects, and inform the caller whether we made any laziness + -- transformations after all. (That last bit of information is used to + -- determine if the runtime factory function needs to be injected.) + in (uncurry fromRGI . replaceReferencesWithForceCall <$> items, Any . not $ IM.null replacements) + + where + + nullAnn = ssAnn nullSourceSpan + runtimeLazy = Var nullAnn . Qualified Nothing $ InternalIdent RuntimeLazyFactory + runFn3 = Var nullAnn . Qualified (Just C.DataFunctionUncurried) . Ident $ C.runFn <> "3" + strLit = Literal nullAnn . StringLiteral . mkString + + lazifyIdent = \case + Ident txt -> InternalIdent $ Lazy txt + _ -> internalError "Unexpected argument to lazifyIdent" + + makeForceCall :: Ann -> Ident -> Expr Ann + makeForceCall (ss, _, _, _) ident + -- We expect the functions produced by `runtimeLazy` to accept one + -- argument: the line number on which this reference is made. The runtime + -- code uses this number to generate a message that identifies where the + -- evaluation looped. + = App nullAnn (Var nullAnn . Qualified Nothing $ lazifyIdent ident) + . Literal nullAnn . NumericLiteral . Left . toInteger . sourcePosLine + $ spanStart ss + + fromRGI :: Ident -> RecursiveGroupItem (Expr Ann) -> ((Ann, Ident), Expr Ann) + fromRGI i = \case + EagerBinding a e -> ((a, i), e) + -- We expect the `runtimeLazy` factory to accept three arguments: the + -- identifier being initialized, the name of the module, and of course a + -- thunk that actually contains the initialization code. + LazyDefinition e -> ((nullAnn, lazifyIdent i), foldl1' (App nullAnn) [runFn3, runtimeLazy, strLit $ runIdent i, strLit $ runModuleName mn, Abs nullAnn UnusedIdent e]) + LazyBinding a -> ((a, i), makeForceCall a i) + + dropKeysAbove :: Int -> IM.MonoidalIntMap a -> IM.MonoidalIntMap a + dropKeysAbove n = fst . IM.split (n + 1) + + coerceForce :: Maybe Int -> Ap Maybe (Max Int) + coerceForce = coerce + + uncoerceForce :: Ap Maybe (Max Int) -> Maybe Int + uncoerceForce = coerce diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs index 291232065f..e69ccb87d3 100644 --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -6,6 +6,7 @@ module Language.PureScript.CoreFn.Traversals where import Prelude.Compat import Control.Arrow (second, (***), (+++)) +import Data.Bitraversable (bitraverse) import Language.PureScript.AST.Literals import Language.PureScript.CoreFn.Binders @@ -43,3 +44,43 @@ everywhereOnValues f g h = (f', g', h') handleLiteral i (ArrayLiteral ls) = ArrayLiteral (map i ls) handleLiteral i (ObjectLiteral ls) = ObjectLiteral (map (fmap i) ls) handleLiteral _ other = other + +-- | +-- Apply the provided functions to the top level of AST nodes. +-- +-- This function is useful as a building block for recursive functions, but +-- doesn't actually recurse itself. +-- +traverseCoreFn + :: forall f a + . Applicative f + => (Bind a -> f (Bind a)) + -> (Expr a -> f (Expr a)) + -> (Binder a -> f (Binder a)) + -> (CaseAlternative a -> f (CaseAlternative a)) + -> (Bind a -> f (Bind a), Expr a -> f (Expr a), Binder a -> f (Binder a), CaseAlternative a -> f (CaseAlternative a)) +traverseCoreFn f g h i = (f', g', h', i') + where + f' (NonRec a name e) = NonRec a name <$> g e + f' (Rec es) = Rec <$> traverse (traverse g) es + + g' (Literal ann e) = Literal ann <$> handleLiteral g e + g' (Accessor ann prop e) = Accessor ann prop <$> g e + g' (ObjectUpdate ann obj vs) = ObjectUpdate ann <$> g obj <*> traverse (traverse g) vs + g' (Abs ann name e) = Abs ann name <$> g e + g' (App ann v1 v2) = App ann <$> g v1 <*> g v2 + g' (Case ann vs alts) = Case ann <$> traverse g vs <*> traverse i alts + g' (Let ann ds e) = Let ann <$> traverse f ds <*> g' e + g' e = pure e + + h' (LiteralBinder a b) = LiteralBinder a <$> handleLiteral h b + h' (NamedBinder a name b) = NamedBinder a name <$> h b + h' (ConstructorBinder a q1 q2 bs) = ConstructorBinder a q1 q2 <$> traverse h bs + h' b = pure b + + i' ca = CaseAlternative <$> traverse h (caseAlternativeBinders ca) <*> bitraverse (traverse $ bitraverse g g) g (caseAlternativeResult ca) + + handleLiteral withItem = \case + ArrayLiteral ls -> ArrayLiteral <$> traverse withItem ls + ObjectLiteral ls -> ObjectLiteral <$> traverse (traverse withItem) ls + other -> pure other diff --git a/stack.yaml b/stack.yaml index c76c7de507..9b7d5860b6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -23,6 +23,8 @@ extra-deps: # See https://github.com/purescript/purescript/issues/4253 - process-1.6.13.1 - Cabal-3.2.1.0 +# Not included in Stackage until the lts-19 series +- monoidal-containers-0.6.2.0 nix: packages: - zlib diff --git a/tests/purs/optimize/4179.out.js b/tests/purs/optimize/4179.out.js new file mode 100644 index 0000000000..5129e291f4 --- /dev/null +++ b/tests/purs/optimize/4179.out.js @@ -0,0 +1,101 @@ +var $runtime_lazy = function (name, moduleName, init) { + var state = 0; + var val; + return function (lineNumber) { + if (state === 2) return val; + if (state === 1) throw new ReferenceError(name + " was needed before it finished initializing (module " + moduleName + ", line " + lineNumber + ")", moduleName, lineNumber); + state = 1; + val = init(); + state = 2; + return val; + }; +}; + +// This is a test that TCO isn't broken by unsafePartial. +var tcoable = function ($copy_v) { + var $tco_done = false; + var $tco_result; + function $tco_loop(v) { + if (v === 0) { + $tco_done = true; + return "done"; + }; + if (v > 0) { + $copy_v = v - 1 | 0; + return; + }; + throw new Error("Failed pattern match at Main (line 43, column 25 - line 45, column 31): " + [ v.constructor.name ]); + }; + while (!$tco_done) { + $tco_result = $tco_loop($copy_v); + }; + return $tco_result; +}; +var isOdd = function (n) { + return n > 0 && !isEven(n - 1 | 0); +}; +var isEven = function (n) { + return n === 0 || isOdd(n - 1 | 0); +}; + +// This is an example of four mutually recursive bindings with a complex +// run-time dependency structure. The expected result is: +// alpha is defined without any laziness +// bravo and charlie are lazily initialized in a group +// and then delta is lazily initialized +var alpha = function (v) { + if (v === 0) { + return $lazy_bravo(18); + }; + if (v === 1) { + return $lazy_charlie(19); + }; + if (v === 2) { + return function (y) { + var $7 = y > 0; + if ($7) { + return bravo(y); + }; + return charlie(y); + }; + }; + return function (y) { + return $lazy_delta(21)(y)(v); + }; +}; +var $lazy_charlie = /* #__PURE__ */ $runtime_lazy("charlie", "Main", function () { + return (function (v) { + return alpha; + })({})(4); +}); +var $lazy_bravo = /* #__PURE__ */ $runtime_lazy("bravo", "Main", function () { + return (function (v) { + return alpha; + })({})(3); +}); +var charlie = /* #__PURE__ */ $lazy_charlie(31); +var bravo = /* #__PURE__ */ $lazy_bravo(28); +var $lazy_delta = /* #__PURE__ */ $runtime_lazy("delta", "Main", function () { + var b = (function (v) { + return bravo; + })({}); + return function (x) { + return function (y) { + var $8 = x === y; + if ($8) { + return b(0); + }; + return 1.0; + }; + }; +}); +var delta = /* #__PURE__ */ $lazy_delta(34); +export { + isEven, + isOdd, + alpha, + bravo, + charlie, + delta, + tcoable +}; diff --git a/tests/purs/optimize/4179.purs b/tests/purs/optimize/4179.purs new file mode 100644 index 0000000000..30fc6aed4d --- /dev/null +++ b/tests/purs/optimize/4179.purs @@ -0,0 +1,45 @@ +module Main where + +import Prelude + +import Partial.Unsafe (unsafePartial) + +isEven n = n == 0 || isOdd (n - 1) +isOdd n = n > 0 && not (isEven (n - 1)) + +-- This is an example of four mutually recursive bindings with a complex +-- run-time dependency structure. The expected result is: +-- alpha is defined without any laziness +-- bravo and charlie are lazily initialized in a group +-- and then delta is lazily initialized + +alpha :: Int -> Int -> Number +alpha = case _ of + 0 -> bravo + 1 -> charlie + 2 -> \y -> if y > 0 then bravo y else charlie y + x -> \y -> delta y x + +-- Me: `alpha` +-- purs: The value of alpha is undefined here, so this reference is not allowed. +-- Me: `(\_ -> alpha) {}` +-- purs: LGTM! + +bravo :: Int -> Number +bravo = (\_ -> alpha) {} 3 + +charlie :: Int -> Number +charlie = (\_ -> alpha) {} 4 + +delta :: Int -> Int -> Number +delta = + let b = (\_ -> bravo) {} + in \x y -> if x == y then b 0 else 1.0 + + +-- This is a test that TCO isn't broken by unsafePartial. + +tcoable :: Int -> String +tcoable = unsafePartial case _ of + 0 -> "done" + n | n > 0 -> tcoable (n - 1) diff --git a/tests/purs/passing/4179.js b/tests/purs/passing/4179.js new file mode 100644 index 0000000000..e31f09f618 --- /dev/null +++ b/tests/purs/passing/4179.js @@ -0,0 +1,2 @@ +export const runtimeImportImpl = nothing => just => moduleName => body => () => + import(`../${moduleName}/index.js`).then(() => body(nothing)(), err => body(just(err.toString()))()); diff --git a/tests/purs/passing/4179.purs b/tests/purs/passing/4179.purs new file mode 100644 index 0000000000..4d105ede52 --- /dev/null +++ b/tests/purs/passing/4179.purs @@ -0,0 +1,73 @@ +module Main where + +import Prelude + +import Data.Maybe (Maybe(..)) +import Effect (Effect) +import Effect.Console (log) +import Test.Assert (assertEqual) +import CustomAssert (assertThrows) + +force :: forall a b. (Unit -> b) -> b +force f = f unit + +alpha = { backref: \_ -> bravo, x: 1 } +bravo = force \_ -> alpha.x + + +complicatedIdentity :: forall a. a -> a +complicatedIdentity = h + where + -- This highly contrived function tests that escalating force is caught and + -- doesn't cause an infinite loop during compilation. ("Escalating force" + -- means that invoking `f` with two argument leads to `f` being invoked with + -- three arguments, and so on.) + + -- If the escalating loop in `f` isn't taken into account, `h` might be + -- initialized before `g`, which will lead to a run-time error. The intended + -- behavior is to lazily initialize `g` and `h` together, and let the fact + -- that at run time `g` never actually dereferences `h` resolve the + -- initialization ordering. + + f :: forall a. Int -> { tick :: a -> a, tock :: a -> a } + f n = { tick: if n <= 0 then identity else (f (n - 1)).tock identity, tock: \a -> g n a } + + g :: forall a. Int -> a -> a + g = (\bit -> if bit then \n -> (f n).tick else const h) true + + h :: forall a. a -> a + h = (\n -> (f n).tick) 10 + + +foreign import runtimeImportImpl :: forall a. Maybe String -> (String -> Maybe String) -> String -> (Maybe String -> Effect a) -> Effect a + +runtimeImport :: forall a. String -> (Maybe String -> Effect a) -> Effect a +runtimeImport = runtimeImportImpl Nothing Just + +type ID = forall a. a -> a + +main = do + err <- assertThrows \_ -> + let + selfOwn = { a: 1, b: force \_ -> selfOwn.a } + in selfOwn + assertEqual { actual: err, expected: "ReferenceError: selfOwn was needed before it finished initializing (module Main, line 52)" } + + err2 <- assertThrows \_ -> + let + f = (\_ -> { left: g identity, right: h identity }) unit + + g :: ID -> ID + g x = (j x x x).right + + h :: ID -> ID -> { left :: ID, right :: ID } + h x = j x x + + j x y z = { left: x y z, right: f.left } + in f + assertEqual { actual: err2, expected: "ReferenceError: f was needed before it finished initializing (module Main, line 66)" } + + assertEqual { actual: bravo, expected: 1 } + runtimeImport "InitializationError" \err3 -> do + assertEqual { actual: err3, expected: Just "ReferenceError: alphaArray was needed before it finished initializing (module InitializationError, line 0)" } -- TODO: fix the 0 + log "Done" diff --git a/tests/purs/passing/4179/CustomAssert.js b/tests/purs/passing/4179/CustomAssert.js new file mode 100644 index 0000000000..24a6e2ab4d --- /dev/null +++ b/tests/purs/passing/4179/CustomAssert.js @@ -0,0 +1,12 @@ +export var assertThrowsImpl = function (arg) { + return function (f) { + return function () { + try { + f(arg); + } catch (e) { + return e.toString(); + } + throw new Error("Assertion failed: An error should have been thrown"); + }; + }; +}; diff --git a/tests/purs/passing/4179/CustomAssert.purs b/tests/purs/passing/4179/CustomAssert.purs new file mode 100644 index 0000000000..16047a035c --- /dev/null +++ b/tests/purs/passing/4179/CustomAssert.purs @@ -0,0 +1,10 @@ +module CustomAssert (assertThrows) where + +import Prelude + +import Effect (Effect) + +assertThrows :: forall a. (Unit -> a) -> Effect String +assertThrows = assertThrowsImpl unit + +foreign import assertThrowsImpl :: forall a b. a -> (a -> b) -> Effect String diff --git a/tests/purs/passing/4179/InitializationError.purs b/tests/purs/passing/4179/InitializationError.purs new file mode 100644 index 0000000000..0368b48ead --- /dev/null +++ b/tests/purs/passing/4179/InitializationError.purs @@ -0,0 +1,14 @@ +module InitializationError where + +class Alpha a where + alpha :: a Int -> a Int +class Alpha a <= Bravo a +class Bravo a <= Charlie a + +charlieAlpha :: forall a. Charlie a => a Int -> a Int +charlieAlpha = alpha + +instance alphaArray :: Alpha Array where + alpha = charlieAlpha +instance Bravo Array +instance Charlie Array From 3fc881cdbbe19d8c0052d6816b2ca5ad59f94e92 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 15 Apr 2022 17:41:08 -0500 Subject: [PATCH 1441/1580] Make alpha-05 release (#4291) --- app/Version.hs | 2 +- purescript.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/app/Version.hs b/app/Version.hs index 61fc6aa0db..7ce919137f 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -17,7 +17,7 @@ import qualified Development.GitRev as GitRev -- prerelease identifier here (if any). When releasing a proper version, simply -- set this to an empty string. prerelease :: String -prerelease = "-alpha-04" +prerelease = "-alpha-05" versionString :: String versionString = showVersion Paths.version ++ prerelease ++ extra diff --git a/purescript.cabal b/purescript.cabal index abcf989099..8ea29acbde 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.15.0-alpha-04 +version: 0.15.0-alpha-05 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From f374270faf3e7f891277babeb705765640b8965c Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Thu, 21 Apr 2022 13:52:52 -0500 Subject: [PATCH 1442/1580] Add Prim.Int.ToString compiler-solved class (#4267) * Add Prim.Int.ToString compiler-solved class This class is being added primarily because large integers outside the range of JavaScript's Int bounds can still be reflected to the value level if the type used is a BigInt rather than an Int. This is done by converting a type-level Int to a type-level String and then reflecting that String into a value-level one that is used in BigInt's constructor. --- CHANGELOG.d/feature_type_level_ints.md | 2 +- .../src/Language/PureScript/Constants/Prim.hs | 3 + .../src/Language/PureScript/Environment.hs | 9 +++ src/Language/PureScript/Docs/Prim.hs | 6 ++ .../PureScript/TypeChecker/Entailment.hs | 13 ++++ tests/purs/failing/IntToString1.out | 31 ++++++++ tests/purs/failing/IntToString1.purs | 14 ++++ tests/purs/failing/IntToString2.out | 31 ++++++++ tests/purs/failing/IntToString2.purs | 14 ++++ tests/purs/failing/IntToString3.out | 31 ++++++++ tests/purs/failing/IntToString3.purs | 14 ++++ tests/purs/passing/IntToString.purs | 71 +++++++++++++++++++ 12 files changed, 238 insertions(+), 1 deletion(-) create mode 100644 tests/purs/failing/IntToString1.out create mode 100644 tests/purs/failing/IntToString1.purs create mode 100644 tests/purs/failing/IntToString2.out create mode 100644 tests/purs/failing/IntToString2.purs create mode 100644 tests/purs/failing/IntToString3.out create mode 100644 tests/purs/failing/IntToString3.purs create mode 100644 tests/purs/passing/IntToString.purs diff --git a/CHANGELOG.d/feature_type_level_ints.md b/CHANGELOG.d/feature_type_level_ints.md index 280f6f42d4..7a359fb97c 100644 --- a/CHANGELOG.d/feature_type_level_ints.md +++ b/CHANGELOG.d/feature_type_level_ints.md @@ -1,5 +1,5 @@ * Implement native type-level integers Added support for type-level integers and compiler-solved operations - such as `Add`, `Mul`, and `Compare`. Type-level integers use the `Int` + such as `Add`, `Mul`, `Compare`, and `ToString`. Type-level integers use the `Int` type as their kind. diff --git a/lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs b/lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs index 2d86a8f109..ad5a15ab0d 100644 --- a/lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs +++ b/lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs @@ -115,6 +115,9 @@ pattern IntCompare = Qualified (Just PrimInt) (ProperName "Compare") pattern IntMul :: Qualified (ProperName 'ClassName) pattern IntMul = Qualified (Just PrimInt) (ProperName "Mul") +pattern IntToString :: Qualified (ProperName 'ClassName) +pattern IntToString = Qualified (Just PrimInt) (ProperName "ToString") + -- Prim.Symbol pattern PrimSymbol :: ModuleName diff --git a/lib/purescript-cst/src/Language/PureScript/Environment.hs b/lib/purescript-cst/src/Language/PureScript/Environment.hs index be8b7fe899..67ee6a2df9 100644 --- a/lib/purescript-cst/src/Language/PureScript/Environment.hs +++ b/lib/purescript-cst/src/Language/PureScript/Environment.hs @@ -429,6 +429,7 @@ primIntTypes = [ primClass (primSubName C.moduleInt "Add") (\kind -> tyInt -:> tyInt -:> tyInt -:> kind) , primClass (primSubName C.moduleInt "Compare") (\kind -> tyInt -:> tyInt -:> kindOrdering -:> kind) , primClass (primSubName C.moduleInt "Mul") (\kind -> tyInt -:> tyInt -:> tyInt -:> kind) + , primClass (primSubName C.moduleInt "ToString") (\kind -> tyInt -:> kindSymbol -:> kind) ] primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) @@ -594,6 +595,14 @@ primIntClasses = ] [] [] [ FunctionalDependency [0, 1] [2] ] True) + + -- class ToString (int :: Int) (string :: Symbol) | int -> string + , (primSubName C.moduleInt "ToString", makeTypeClassData + [ ("int", Just tyInt) + , ("string", Just kindSymbol) + ] [] [] + [ FunctionalDependency [0] [1] + ] True) ] primTypeErrorClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 1509e9408b..e113476459 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -136,6 +136,7 @@ primIntDocsModule = Module [ intAdd , intCompare , intMul + , intToString ] , modReExports = [] } @@ -550,6 +551,11 @@ intMul = primClassOf (P.primSubName "Int") "Mul" $ T.unlines [ "Compiler solved type class for multiplying type-level `Int`s." ] +intToString :: Declaration +intToString = primClassOf (P.primSubName "Int") "ToString" $ T.unlines + [ "Compiler solved type class for converting a type-level `Int` into a type-level `String` (i.e. `Symbol`)." + ] + fail :: Declaration fail = primClassOf (P.primSubName "TypeError") "Fail" $ T.unlines [ "The Fail type class is part of the custom type errors feature. To provide" diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 9d137d8545..5b31913389 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -205,6 +205,7 @@ entails SolverOptions{..} constraint context hints = forClassName _ _ C.IntAdd _ args | Just dicts <- solveIntAdd args = dicts forClassName _ ctx C.IntCompare _ args | Just dicts <- solveIntCompare ctx args = dicts forClassName _ _ C.IntMul _ args | Just dicts <- solveIntMul args = dicts + forClassName _ _ C.IntToString _ args | Just dicts <- solveIntToString args = dicts forClassName _ _ C.Reflectable _ args | Just dicts <- solveReflectable args = dicts forClassName _ _ C.RowUnion kinds args | Just dicts <- solveUnion kinds args = dicts forClassName _ _ C.RowNub kinds args | Just dicts <- solveNub kinds args = dicts @@ -505,6 +506,18 @@ entails SolverOptions{..} constraint context hints = pure (arg1, arg2, srcTypeLevelString (mkString $ h' <> t')) consSymbol _ _ _ = Nothing + solveIntToString :: [SourceType] -> Maybe [TypeClassDict] + solveIntToString [arg0, _] = do + (arg0', arg1') <- printIntToString arg0 + let args' = [arg0', arg1'] + pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.IntToString [] [] args' Nothing Nothing] + solveIntToString _ = Nothing + + printIntToString :: SourceType -> Maybe (SourceType, SourceType) + printIntToString arg0@(TypeLevelInt _ i) = do + pure (arg0, srcTypeLevelString $ mkString $ T.pack $ show i) + printIntToString _ = Nothing + solveReflectable :: [SourceType] -> Maybe [TypeClassDict] solveReflectable [typeLevel, _] = do (ref, typ) <- case typeLevel of diff --git a/tests/purs/failing/IntToString1.out b/tests/purs/failing/IntToString1.out new file mode 100644 index 0000000000..c816d7e9a1 --- /dev/null +++ b/tests/purs/failing/IntToString1.out @@ -0,0 +1,31 @@ +Error found: +in module Main +at tests/purs/failing/IntToString1.purs:14:15 - 14:46 (line 14, column 15 - line 14, column 46) + + Could not match type +   +  "1" +   + with type +   +  "a" +   + +while solving type class constraint +  + Prim.Int.ToString 1  + "a" +  +while applying a function testToString + of type ToString t0 t1 => Proxy @Int t0 -> Proxy @Symbol t1 + to argument Proxy +while checking that expression testToString Proxy + has type Proxy @Symbol "a" +in value declaration posToString + +where t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/IntToString1.purs b/tests/purs/failing/IntToString1.purs new file mode 100644 index 0000000000..4c5d6b2a31 --- /dev/null +++ b/tests/purs/failing/IntToString1.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prelude +import Prim.Int (class ToString) + +data Proxy :: forall k. k -> Type +data Proxy a = Proxy + +testToString :: forall i s. ToString i s => Proxy i -> Proxy s +testToString _ = Proxy + +posToString :: Proxy "a" +posToString = testToString (Proxy :: Proxy 1) diff --git a/tests/purs/failing/IntToString2.out b/tests/purs/failing/IntToString2.out new file mode 100644 index 0000000000..24e24d0d44 --- /dev/null +++ b/tests/purs/failing/IntToString2.out @@ -0,0 +1,31 @@ +Error found: +in module Main +at tests/purs/failing/IntToString2.purs:14:15 - 14:49 (line 14, column 15 - line 14, column 49) + + Could not match type +   +  "-1" +   + with type +   +  "a" +   + +while solving type class constraint +  + Prim.Int.ToString -1  + "a" +  +while applying a function testToString + of type ToString t0 t1 => Proxy @Int t0 -> Proxy @Symbol t1 + to argument Proxy +while checking that expression testToString Proxy + has type Proxy @Symbol "a" +in value declaration negToString + +where t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/IntToString2.purs b/tests/purs/failing/IntToString2.purs new file mode 100644 index 0000000000..05f977d530 --- /dev/null +++ b/tests/purs/failing/IntToString2.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prelude +import Prim.Int (class ToString) + +data Proxy :: forall k. k -> Type +data Proxy a = Proxy + +testToString :: forall i s. ToString i s => Proxy i -> Proxy s +testToString _ = Proxy + +negToString :: Proxy "a" +negToString = testToString (Proxy :: Proxy (-1)) diff --git a/tests/purs/failing/IntToString3.out b/tests/purs/failing/IntToString3.out new file mode 100644 index 0000000000..7008f15fec --- /dev/null +++ b/tests/purs/failing/IntToString3.out @@ -0,0 +1,31 @@ +Error found: +in module Main +at tests/purs/failing/IntToString3.purs:14:16 - 14:47 (line 14, column 16 - line 14, column 47) + + Could not match type +   +  "0" +   + with type +   +  "a" +   + +while solving type class constraint +  + Prim.Int.ToString 0  + "a" +  +while applying a function testToString + of type ToString t0 t1 => Proxy @Int t0 -> Proxy @Symbol t1 + to argument Proxy +while checking that expression testToString Proxy + has type Proxy @Symbol "a" +in value declaration zeroToString + +where t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/IntToString3.purs b/tests/purs/failing/IntToString3.purs new file mode 100644 index 0000000000..71a58be7b0 --- /dev/null +++ b/tests/purs/failing/IntToString3.purs @@ -0,0 +1,14 @@ +-- @shouldFailWith TypesDoNotUnify +module Main where + +import Prelude +import Prim.Int (class ToString) + +data Proxy :: forall k. k -> Type +data Proxy a = Proxy + +testToString :: forall i s. ToString i s => Proxy i -> Proxy s +testToString _ = Proxy + +zeroToString :: Proxy "a" +zeroToString = testToString (Proxy :: Proxy 0) diff --git a/tests/purs/passing/IntToString.purs b/tests/purs/passing/IntToString.purs new file mode 100644 index 0000000000..736706e6d4 --- /dev/null +++ b/tests/purs/passing/IntToString.purs @@ -0,0 +1,71 @@ +module Main where + +import Prelude +import Effect.Console (log) +import Prim.Int (class Add, class Mul, class ToString) + +data Proxy :: forall k. k -> Type +data Proxy a = Proxy + +type One = 1 +type NegOne = (-1) +type Zero = 0 + +testToString :: forall i s. ToString i s => Proxy i -> Proxy s +testToString _ = Proxy + +posToString :: Proxy "1" +posToString = testToString (Proxy :: Proxy 1) + +negToString :: Proxy "-1" +negToString = testToString (Proxy :: Proxy (-1)) + +zeroToString :: Proxy "0" +zeroToString = testToString (Proxy :: Proxy 0) + +posToStringTA :: Proxy "1" +posToStringTA = testToString (Proxy :: Proxy One) + +negToStringTA :: Proxy "-1" +negToStringTA = testToString (Proxy :: Proxy NegOne) + +zeroToStringTA :: Proxy "0" +zeroToStringTA = testToString (Proxy :: Proxy Zero) + +intAdd + :: forall i1 i2 i3 + . Add i1 i2 i3 + => Proxy i1 + -> Proxy i2 + -> Proxy i3 +intAdd _ _ = Proxy + +intMul + :: forall i1 i2 i3 + . Mul i1 i2 i3 + => Proxy i1 + -> Proxy i2 + -> Proxy i3 +intMul _ _ = Proxy + +testAdd :: Proxy "4" +testAdd = testToString (intAdd (Proxy :: _ 1) (Proxy :: _ 3)) + +testMul :: Proxy "6" +testMul = testToString (intMul (Proxy :: _ 2) (Proxy :: _ 3)) + +testMulAdd :: Proxy "10" +testMulAdd = testToString (intAdd (Proxy :: _ 4) (intMul (Proxy :: _ 2) (Proxy :: _ 3))) + +testAddMul :: Proxy "20" +testAddMul = testToString (intMul (Proxy :: _ 4) (intAdd (Proxy :: _ 2) (Proxy :: _ 3))) + +_maxInt = Proxy :: _ 2147483647 + +testMax :: Proxy "2147483647" +testMax = testToString _maxInt + +testBeyondMax :: Proxy "4294967294" +testBeyondMax = testToString (intMul _maxInt (Proxy :: _ 2)) + +main = log "Done" From 211e67d4e7d186682ea70e8740055ad4e6624671 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 22 Apr 2022 13:42:38 -0500 Subject: [PATCH 1443/1580] Merge/move 'lib/purescript-cst/' into 'src/' (#4290) * Delete license file (matches repo's one) * Delete Setup.hs * Merge purescript-cst.cabal into purescript.cabal * Update purescript-cst readme * Drop purescript-cst references in cabal/stack files * Update release guide * Update weeder.dhall file * Drop purescript-cst in build.sh * Add changelog entry * Move/Merge `lib/purescript-cst/src` into `src/` --- CHANGELOG.d/internal_mv-cst-into-src.md | 1 + RELEASE_GUIDE.md | 23 +--- ci/build.sh | 2 - lib/purescript-cst/LICENSE | 13 -- lib/purescript-cst/README.md | 4 +- lib/purescript-cst/Setup.hs | 6 - lib/purescript-cst/purescript-cst.cabal | 123 ------------------ purescript.cabal | 43 +++++- .../src => src}/Control/Monad/Supply.hs | 0 .../src => src}/Control/Monad/Supply/Class.hs | 0 .../src => src}/Data/Text/PureScript.hs | 0 .../src => src}/Language/PureScript/AST.hs | 0 .../Language/PureScript/AST/Binders.hs | 0 .../Language/PureScript/AST/Declarations.hs | 0 .../PureScript/AST/Declarations/ChainId.hs | 0 .../Language/PureScript/AST/Exported.hs | 0 .../Language/PureScript/AST/Literals.hs | 0 .../Language/PureScript/AST/Operators.hs | 0 .../Language/PureScript/AST/SourcePos.hs | 0 .../Language/PureScript/AST/Traversals.hs | 0 .../Language/PureScript/CST/Convert.hs | 0 .../Language/PureScript/CST/Errors.hs | 0 .../Language/PureScript/CST/Flatten.hs | 0 .../Language/PureScript/CST/Layout.hs | 0 .../Language/PureScript/CST/Lexer.hs | 0 .../Language/PureScript/CST/Monad.hs | 0 .../Language/PureScript/CST/Parser.y | 0 .../Language/PureScript/CST/Positions.hs | 0 .../Language/PureScript/CST/Print.hs | 0 .../Language/PureScript/CST/Traversals.hs | 0 .../PureScript/CST/Traversals/Type.hs | 0 .../Language/PureScript/CST/Types.hs | 0 .../Language/PureScript/CST/Utils.hs | 0 .../Language/PureScript/Comments.hs | 0 .../Language/PureScript/Constants/Prim.hs | 0 .../src => src}/Language/PureScript/Crash.hs | 0 .../Language/PureScript/Environment.hs | 0 .../src => src}/Language/PureScript/Label.hs | 0 .../src => src}/Language/PureScript/Names.hs | 0 .../Language/PureScript/PSString.hs | 0 .../src => src}/Language/PureScript/Roles.hs | 0 .../Language/PureScript/Traversals.hs | 0 .../PureScript/TypeClassDictionaries.hs | 0 .../src => src}/Language/PureScript/Types.hs | 0 stack.yaml | 1 - weeder.dhall | 2 +- 46 files changed, 48 insertions(+), 170 deletions(-) create mode 100644 CHANGELOG.d/internal_mv-cst-into-src.md delete mode 100644 lib/purescript-cst/LICENSE delete mode 100644 lib/purescript-cst/Setup.hs delete mode 100644 lib/purescript-cst/purescript-cst.cabal rename {lib/purescript-cst/src => src}/Control/Monad/Supply.hs (100%) rename {lib/purescript-cst/src => src}/Control/Monad/Supply/Class.hs (100%) rename {lib/purescript-cst/src => src}/Data/Text/PureScript.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/AST.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/AST/Binders.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/AST/Declarations.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/AST/Declarations/ChainId.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/AST/Exported.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/AST/Literals.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/AST/Operators.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/AST/SourcePos.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/AST/Traversals.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/CST/Convert.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/CST/Errors.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/CST/Flatten.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/CST/Layout.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/CST/Lexer.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/CST/Monad.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/CST/Parser.y (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/CST/Positions.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/CST/Print.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/CST/Traversals.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/CST/Traversals/Type.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/CST/Types.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/CST/Utils.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/Comments.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/Constants/Prim.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/Crash.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/Environment.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/Label.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/Names.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/PSString.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/Roles.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/Traversals.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/TypeClassDictionaries.hs (100%) rename {lib/purescript-cst/src => src}/Language/PureScript/Types.hs (100%) diff --git a/CHANGELOG.d/internal_mv-cst-into-src.md b/CHANGELOG.d/internal_mv-cst-into-src.md new file mode 100644 index 0000000000..eafcb8b973 --- /dev/null +++ b/CHANGELOG.d/internal_mv-cst-into-src.md @@ -0,0 +1 @@ +* Move `lib/purescript-cst` into `src/` \ No newline at end of file diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md index 7815062cb1..39d2ec4f4d 100644 --- a/RELEASE_GUIDE.md +++ b/RELEASE_GUIDE.md @@ -85,16 +85,6 @@ considering what effects this may have: - The version to install in the `postinstall` script in `package.json` - - If `purescript-cst` has changed at all since the last release: - - - The `version` field in `lib/purescript-cst/purescript-cst.cabal` (note - that the new version should be based on the [PVP](https://pvp.haskell.org/), - according to what changed since the previous release, and not on the actual compiler version) - - - The versions table in `lib/purescript-cst/README.md`, - - - The version bounds for `purescript-cst` in `purescript.cabal` - - Run `stack update-changelog.hs`, which will move the entries in `CHANGELOG.d` to a new section in `CHANGELOG.md` labeled with the new version. @@ -106,15 +96,10 @@ considering what effects this may have: completes. (If the CI build fails, binaries can also be built locally and manually uploaded to the release on GitHub) -- Publish to Hackage: +- Publish to Hackage: run `stack upload .` from the repo root directory. - - change to the `lib/purescript-cst` directory and run `stack upload .` - - - Finally, run `stack upload .` from the repo root directory. - - It's a good idea to check that the two packages (`purescript` and - `purescript-cst`) can be installed from Hackage at this - point. + It's a good idea to check that the package (`purescript`) + can be installed from Hackage at this point. - After all of the prebuilt binaries are present on the GitHub releases page, publish to npm: change to the `npm-package` directory and run `npm publish`. @@ -123,7 +108,7 @@ considering what effects this may have: Note: if a release does not go as planned (e.g. [`v0.14.3`](https://github.com/purescript/purescript/pull/4139)), we should not delete the broken GitHub release or its Git tag. Rather, we should make a new release and update the GitHub release notes and the corresponding section in the CHANGELOG.md file for the broken release to 1. say that it's not a real release, and -1. refer people to the newer release. +2. refer people to the newer release. ## After making a release diff --git a/ci/build.sh b/ci/build.sh index cd60c07dd1..81c8c33b5b 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -44,8 +44,6 @@ $STACK build --only-snapshot $STACK_OPTS (echo "::endgroup::"; echo "::group::Build source distributions") 2>/dev/null # Test in a source distribution (see above) -$STACK sdist lib/purescript-cst --tar-dir sdist-test/lib/purescript-cst -tar -xzf sdist-test/lib/purescript-cst/purescript-cst-*.tar.gz -C sdist-test/lib/purescript-cst --strip-components=1 $STACK sdist . --tar-dir sdist-test; tar -xzf sdist-test/purescript-*.tar.gz -C sdist-test --strip-components=1 diff --git a/lib/purescript-cst/LICENSE b/lib/purescript-cst/LICENSE deleted file mode 100644 index 7904c3e262..0000000000 --- a/lib/purescript-cst/LICENSE +++ /dev/null @@ -1,13 +0,0 @@ -Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other -contributors -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - -1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - -3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/lib/purescript-cst/README.md b/lib/purescript-cst/README.md index 035e29c635..8f385dc45a 100644 --- a/lib/purescript-cst/README.md +++ b/lib/purescript-cst/README.md @@ -1,9 +1,11 @@ # purescript-cst -The parser for the PureScript programming language. +The parser for the PureScript programming language was temporarily released as a separate package for the `0.14.x` series. In `0.15.x`, it was merged back into the main `purescript` package. This table only exists for documentary purposes. ## Compiler compatibility +In `v0.15.0`, the `purescript-cst` package was merged back into the `purescript` package. + We provide a table to make it a bit easier to map between versions of `purescript` and `purescript-cst`. | `purescript` | `purescript-cst` | diff --git a/lib/purescript-cst/Setup.hs b/lib/purescript-cst/Setup.hs deleted file mode 100644 index cd7b151a59..0000000000 --- a/lib/purescript-cst/Setup.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import Distribution.Simple - -main :: IO () -main = defaultMain diff --git a/lib/purescript-cst/purescript-cst.cabal b/lib/purescript-cst/purescript-cst.cabal deleted file mode 100644 index a72b9675dd..0000000000 --- a/lib/purescript-cst/purescript-cst.cabal +++ /dev/null @@ -1,123 +0,0 @@ -cabal-version: 2.4 - -name: purescript-cst -version: 0.5.0.0 -synopsis: PureScript Programming Language Concrete Syntax Tree -description: The parser for the PureScript programming language. -category: Language -stability: experimental -homepage: http://www.purescript.org/ -bug-reports: https://github.com/purescript/purescript/issues -author: Phil Freeman -maintainer: Gary Burgess , Hardy Jones , Harry Garrood , Christoph Hegemann , Liam Goodacre , Nathan Faubion - -copyright: (c) 2013-17 Phil Freeman, (c) 2014-19 Gary Burgess, (c) other contributors (see CONTRIBUTORS.md) -license: BSD-3-Clause -license-file: LICENSE -build-type: Simple -extra-source-files: - README.md - -source-repository head - type: git - location: https://github.com/purescript/purescript - -common defaults - ghc-options: -Wall - default-language: Haskell2010 - default-extensions: - BangPatterns - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFunctor - DeriveFoldable - DeriveTraversable - DeriveGeneric - DerivingStrategies - EmptyDataDecls - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving - KindSignatures - LambdaCase - MultiParamTypeClasses - NamedFieldPuns - NoImplicitPrelude - PatternGuards - PatternSynonyms - RankNTypes - RecordWildCards - OverloadedStrings - ScopedTypeVariables - TupleSections - TypeFamilies - ViewPatterns - build-depends: - -- NOTE: Please do not edit these version constraints manually. - -- See the note in ../../purescript.cabal for an explanation of how to edit - -- these version constraints. - aeson >=1.5.6.0 && <1.6, - array >=0.5.4.0 && <0.6, - base >=4.14.3.0 && <4.15, - base-compat >=0.11.2 && <0.12, - bytestring >=0.10.12.0 && <0.11, - containers >=0.6.5.1 && <0.7, - deepseq >=1.4.4.0 && <1.5, - dlist ==1.0.*, - filepath >=1.4.2.1 && <1.5, - microlens >=0.4.12.0 && <0.5, - mtl >=2.2.2 && <2.3, - protolude >=0.3.0 && <0.4, - scientific >=0.3.7.0 && <0.4, - semigroups >=0.19.2 && <0.20, - serialise >=0.2.4.0 && <0.3, - text >=1.2.4.1 && <1.3, - vector >=0.12.3.1 && <0.13 - build-tool-depends: - happy:happy ==1.20.0 - -library - import: defaults - hs-source-dirs: src - exposed-modules: - Control.Monad.Supply - Control.Monad.Supply.Class - Language.PureScript.AST - Language.PureScript.AST.Binders - Language.PureScript.AST.Declarations - Language.PureScript.AST.Declarations.ChainId - Language.PureScript.AST.Exported - Language.PureScript.AST.Literals - Language.PureScript.AST.Operators - Language.PureScript.AST.SourcePos - Language.PureScript.AST.Traversals - Language.PureScript.CST.Convert - Language.PureScript.CST.Errors - Language.PureScript.CST.Flatten - Language.PureScript.CST.Layout - Language.PureScript.CST.Lexer - Language.PureScript.CST.Monad - Language.PureScript.CST.Parser - Language.PureScript.CST.Positions - Language.PureScript.CST.Print - Language.PureScript.CST.Traversals - Language.PureScript.CST.Traversals.Type - Language.PureScript.CST.Types - Language.PureScript.CST.Utils - Language.PureScript.Comments - Language.PureScript.Constants.Prim - Language.PureScript.Crash - Language.PureScript.Environment - Language.PureScript.Label - Language.PureScript.Names - Language.PureScript.PSString - Language.PureScript.Roles - Language.PureScript.Traversals - Language.PureScript.TypeClassDictionaries - Language.PureScript.Types - other-modules: - Data.Text.PureScript - Paths_purescript_cst - autogen-modules: - Paths_purescript_cst diff --git a/purescript.cabal b/purescript.cabal index 8ea29acbde..fdad946654 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -95,7 +95,7 @@ common defaults -- update to a newer snapshot as follows: -- -- 1. Remove all version constraints from this cabal file (apart from - -- language-javascript and purescript-cst). + -- language-javascript). -- 2. Update stack.yaml as required to select a new snapshot, and check -- everything builds correctly with stack. -- 3. Run `stack sdist`; this will produce a source distribution including @@ -109,8 +109,8 @@ common defaults -- built with (almost) the same install plan for both cabal and stack -- users. -- - -- We need to be especially careful with purescript-cst - -- and language-javascript, because they all form part of the compiler's + -- We need to be especially careful with + -- language-javascript, because it forms a part of the compiler's -- public API. In the case of language-javascript specifically, all FFI -- modules must be parseable by this library otherwise the compiler -- will reject them. It should therefore always be pinned to a single @@ -158,7 +158,6 @@ common defaults pattern-arrows >=0.0.2 && <0.1, process ==1.6.13.1, protolude >=0.3.0 && <0.4, - purescript-cst ==0.5.0.0, regex-tdfa >=1.3.1.1 && <1.4, safe >=0.3.19 && <0.4, scientific >=0.3.7.0 && <0.4, @@ -184,7 +183,18 @@ library hs-source-dirs: src exposed-modules: Control.Monad.Logger + Control.Monad.Supply + Control.Monad.Supply.Class Language.PureScript + Language.PureScript.AST + Language.PureScript.AST.Binders + Language.PureScript.AST.Declarations + Language.PureScript.AST.Declarations.ChainId + Language.PureScript.AST.Exported + Language.PureScript.AST.Literals + Language.PureScript.AST.Operators + Language.PureScript.AST.SourcePos + Language.PureScript.AST.Traversals Language.PureScript.Bundle Language.PureScript.CodeGen Language.PureScript.CodeGen.JS @@ -216,6 +226,22 @@ library Language.PureScript.CoreImp.Optimizer.TCO Language.PureScript.CoreImp.Optimizer.Unused Language.PureScript.CST + Language.PureScript.CST.Convert + Language.PureScript.CST.Errors + Language.PureScript.CST.Flatten + Language.PureScript.CST.Layout + Language.PureScript.CST.Lexer + Language.PureScript.CST.Monad + Language.PureScript.CST.Parser + Language.PureScript.CST.Positions + Language.PureScript.CST.Print + Language.PureScript.CST.Traversals + Language.PureScript.CST.Traversals.Type + Language.PureScript.CST.Types + Language.PureScript.CST.Utils + Language.PureScript.Comments + Language.PureScript.Constants.Prim + Language.PureScript.Crash Language.PureScript.Docs Language.PureScript.Docs.AsHtml Language.PureScript.Docs.AsMarkdown @@ -232,6 +258,7 @@ library Language.PureScript.Docs.Tags Language.PureScript.Docs.Types Language.PureScript.Docs.Utils.MonoidExtras + Language.PureScript.Environment Language.PureScript.Errors Language.PureScript.Errors.JSON Language.PureScript.Externs @@ -265,6 +292,7 @@ library Language.PureScript.Interactive.Parser Language.PureScript.Interactive.Printer Language.PureScript.Interactive.Types + Language.PureScript.Label Language.PureScript.Linter Language.PureScript.Linter.Exhaustive Language.PureScript.Linter.Imports @@ -275,17 +303,20 @@ library Language.PureScript.Make.Cache Language.PureScript.Make.Monad Language.PureScript.ModuleDependencies + Language.PureScript.Names Language.PureScript.Options Language.PureScript.Pretty Language.PureScript.Pretty.Common Language.PureScript.Pretty.Types Language.PureScript.Pretty.Values + Language.PureScript.PSString Language.PureScript.Publish Language.PureScript.Publish.BoxesHelpers Language.PureScript.Publish.ErrorsWarnings Language.PureScript.Publish.Registry.Compat Language.PureScript.Publish.Utils Language.PureScript.Renamer + Language.PureScript.Roles Language.PureScript.Sugar Language.PureScript.Sugar.AdoNotation Language.PureScript.Sugar.BindingGroups @@ -306,6 +337,7 @@ library Language.PureScript.Sugar.TypeClasses Language.PureScript.Sugar.TypeClasses.Deriving Language.PureScript.Sugar.TypeDeclarations + Language.PureScript.Traversals Language.PureScript.TypeChecker Language.PureScript.TypeChecker.Entailment Language.PureScript.TypeChecker.Entailment.Coercible @@ -319,8 +351,11 @@ library Language.PureScript.TypeChecker.Types Language.PureScript.TypeChecker.TypeSearch Language.PureScript.TypeChecker.Unify + Language.PureScript.TypeClassDictionaries + Language.PureScript.Types System.IO.UTF8 other-modules: + Data.Text.PureScript Paths_purescript autogen-modules: Paths_purescript diff --git a/lib/purescript-cst/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs similarity index 100% rename from lib/purescript-cst/src/Control/Monad/Supply.hs rename to src/Control/Monad/Supply.hs diff --git a/lib/purescript-cst/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs similarity index 100% rename from lib/purescript-cst/src/Control/Monad/Supply/Class.hs rename to src/Control/Monad/Supply/Class.hs diff --git a/lib/purescript-cst/src/Data/Text/PureScript.hs b/src/Data/Text/PureScript.hs similarity index 100% rename from lib/purescript-cst/src/Data/Text/PureScript.hs rename to src/Data/Text/PureScript.hs diff --git a/lib/purescript-cst/src/Language/PureScript/AST.hs b/src/Language/PureScript/AST.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/AST.hs rename to src/Language/PureScript/AST.hs diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/AST/Binders.hs rename to src/Language/PureScript/AST/Binders.hs diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/AST/Declarations.hs rename to src/Language/PureScript/AST/Declarations.hs diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Declarations/ChainId.hs b/src/Language/PureScript/AST/Declarations/ChainId.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/AST/Declarations/ChainId.hs rename to src/Language/PureScript/AST/Declarations/ChainId.hs diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/AST/Exported.hs rename to src/Language/PureScript/AST/Exported.hs diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/AST/Literals.hs rename to src/Language/PureScript/AST/Literals.hs diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/AST/Operators.hs rename to src/Language/PureScript/AST/Operators.hs diff --git a/lib/purescript-cst/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/AST/SourcePos.hs rename to src/Language/PureScript/AST/SourcePos.hs diff --git a/lib/purescript-cst/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/AST/Traversals.hs rename to src/Language/PureScript/AST/Traversals.hs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/CST/Convert.hs rename to src/Language/PureScript/CST/Convert.hs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/CST/Errors.hs rename to src/Language/PureScript/CST/Errors.hs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs b/src/Language/PureScript/CST/Flatten.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/CST/Flatten.hs rename to src/Language/PureScript/CST/Flatten.hs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/CST/Layout.hs rename to src/Language/PureScript/CST/Layout.hs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs b/src/Language/PureScript/CST/Lexer.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/CST/Lexer.hs rename to src/Language/PureScript/CST/Lexer.hs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Monad.hs b/src/Language/PureScript/CST/Monad.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/CST/Monad.hs rename to src/Language/PureScript/CST/Monad.hs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/CST/Parser.y rename to src/Language/PureScript/CST/Parser.y diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Positions.hs b/src/Language/PureScript/CST/Positions.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/CST/Positions.hs rename to src/Language/PureScript/CST/Positions.hs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Print.hs b/src/Language/PureScript/CST/Print.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/CST/Print.hs rename to src/Language/PureScript/CST/Print.hs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Traversals.hs b/src/Language/PureScript/CST/Traversals.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/CST/Traversals.hs rename to src/Language/PureScript/CST/Traversals.hs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs b/src/Language/PureScript/CST/Traversals/Type.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/CST/Traversals/Type.hs rename to src/Language/PureScript/CST/Traversals/Type.hs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/CST/Types.hs rename to src/Language/PureScript/CST/Types.hs diff --git a/lib/purescript-cst/src/Language/PureScript/CST/Utils.hs b/src/Language/PureScript/CST/Utils.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/CST/Utils.hs rename to src/Language/PureScript/CST/Utils.hs diff --git a/lib/purescript-cst/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/Comments.hs rename to src/Language/PureScript/Comments.hs diff --git a/lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs b/src/Language/PureScript/Constants/Prim.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/Constants/Prim.hs rename to src/Language/PureScript/Constants/Prim.hs diff --git a/lib/purescript-cst/src/Language/PureScript/Crash.hs b/src/Language/PureScript/Crash.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/Crash.hs rename to src/Language/PureScript/Crash.hs diff --git a/lib/purescript-cst/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/Environment.hs rename to src/Language/PureScript/Environment.hs diff --git a/lib/purescript-cst/src/Language/PureScript/Label.hs b/src/Language/PureScript/Label.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/Label.hs rename to src/Language/PureScript/Label.hs diff --git a/lib/purescript-cst/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/Names.hs rename to src/Language/PureScript/Names.hs diff --git a/lib/purescript-cst/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/PSString.hs rename to src/Language/PureScript/PSString.hs diff --git a/lib/purescript-cst/src/Language/PureScript/Roles.hs b/src/Language/PureScript/Roles.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/Roles.hs rename to src/Language/PureScript/Roles.hs diff --git a/lib/purescript-cst/src/Language/PureScript/Traversals.hs b/src/Language/PureScript/Traversals.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/Traversals.hs rename to src/Language/PureScript/Traversals.hs diff --git a/lib/purescript-cst/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/TypeClassDictionaries.hs rename to src/Language/PureScript/TypeClassDictionaries.hs diff --git a/lib/purescript-cst/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs similarity index 100% rename from lib/purescript-cst/src/Language/PureScript/Types.hs rename to src/Language/PureScript/Types.hs diff --git a/stack.yaml b/stack.yaml index 9b7d5860b6..e93abd1edf 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,7 +4,6 @@ resolver: lts-18.15 pvp-bounds: both packages: - '.' -- lib/purescript-cst ghc-options: # Build with advanced optimizations enabled by default "$locals": -O2 -Werror diff --git a/weeder.dhall b/weeder.dhall index 18d6883d85..b681fde085 100644 --- a/weeder.dhall +++ b/weeder.dhall @@ -28,7 +28,7 @@ -- These declarations are generated by tools; it doesn't matter if they're -- unused because we can't do anything about them. , "^Language\\.PureScript\\.CST\\.Parser\\.happy" - , "^Paths_purescript(_cst)?\\." + , "^Paths_purescript?\\." ] , type-class-roots = True } From 7aa9b70dee70c48c7472ec1d7034ca244436e26e Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Mon, 25 Apr 2022 10:07:17 -0500 Subject: [PATCH 1444/1580] Add instructions for publishing prerelease to NPM (#4295) * Add instructions for publishing prerelease to NPM * Fix normal release instructions --- RELEASE_GUIDE.md | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md index 39d2ec4f4d..9466b7f32a 100644 --- a/RELEASE_GUIDE.md +++ b/RELEASE_GUIDE.md @@ -96,15 +96,21 @@ considering what effects this may have: completes. (If the CI build fails, binaries can also be built locally and manually uploaded to the release on GitHub) -- Publish to Hackage: run `stack upload .` from the repo root directory. +- If making a normal release, publish to Hackage by running `stack upload .` from the repo root directory. It's a good idea to check that the package (`purescript`) can be installed from Hackage at this point. - After all of the prebuilt binaries are present on the GitHub releases page, - publish to npm: change to the `npm-package` directory and run `npm publish`. - It's a good idea to check that the package can be installed from npm at this - point. + publish to npm: change to the `npm-package` directory and do the following: + - if making a pre-release (e.g. `v0.15.0-alpha-05`) + - run `npm publish --tag next` + - verify that the prerelease can be installed via `npm i purescript@next` + - if making a normal release (e.g. `v0.15.0`) + - run `npm publish` + - run `npm dist-tag add purescript@VERSION next` where `VERSION` is `v0.15.0`. + - verify that the release can be installed via `npm i purescript@next` + - verify that the release can be installed via `npm i purescript` Note: if a release does not go as planned (e.g. [`v0.14.3`](https://github.com/purescript/purescript/pull/4139)), we should not delete the broken GitHub release or its Git tag. Rather, we should make a new release and update the GitHub release notes and the corresponding section in the CHANGELOG.md file for the broken release to 1. say that it's not a real release, and From a846892d178d3c9c76c162ca39b9deb6fad4ec8e Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Mon, 25 Apr 2022 10:53:50 -0500 Subject: [PATCH 1445/1580] Make alpha-06 release (#4296) --- app/Version.hs | 2 +- npm-package/package.json | 4 ++-- purescript.cabal | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/app/Version.hs b/app/Version.hs index 7ce919137f..904994d572 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -17,7 +17,7 @@ import qualified Development.GitRev as GitRev -- prerelease identifier here (if any). When releasing a proper version, simply -- set this to an empty string. prerelease :: String -prerelease = "-alpha-05" +prerelease = "-alpha-06" versionString :: String versionString = showVersion Paths.version ++ prerelease ++ extra diff --git a/npm-package/package.json b/npm-package/package.json index 3f60b8beaa..26562f47bd 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.14.7", + "version": "0.15.0-alpha-06", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.14.7", + "postinstall": "install-purescript --purs-ver=0.15.0-alpha-06", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index fdad946654..8e62803ce2 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.15.0-alpha-05 +version: 0.15.0-alpha-06 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From da7876835cb0ca36573358a1bdf71a4a139cad70 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 26 Apr 2022 13:38:21 -0500 Subject: [PATCH 1446/1580] Make 0.15.0-alpha-07 release (#4297) * Update installer to 0.2.6 * Update version to 0.15.0-alpha-07 --- app/Version.hs | 2 +- npm-package/package.json | 6 +++--- purescript.cabal | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/app/Version.hs b/app/Version.hs index 904994d572..ffdf5999fe 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -17,7 +17,7 @@ import qualified Development.GitRev as GitRev -- prerelease identifier here (if any). When releasing a proper version, simply -- set this to an empty string. prerelease :: String -prerelease = "-alpha-06" +prerelease = "-alpha-07" versionString :: String versionString = showVersion Paths.version ++ prerelease ++ extra diff --git a/npm-package/package.json b/npm-package/package.json index 26562f47bd..f76fa51262 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.0-alpha-06", + "version": "0.15.0-alpha-07", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -15,7 +15,7 @@ "purs": "purs.bin" }, "dependencies": { - "purescript-installer": "^0.2.0" + "purescript-installer": "^0.2.6" }, "homepage": "https://github.com/purescript/purescript", "repository": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.0-alpha-06", + "postinstall": "install-purescript --purs-ver=0.15.0-alpha-07", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index 8e62803ce2..797f456f55 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.15.0-alpha-06 +version: 0.15.0-alpha-07 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 8ae7ba397526d5e3999cb825adad8c9c8e22fd94 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Thu, 28 Apr 2022 13:09:38 -0500 Subject: [PATCH 1447/1580] Update tests and their bower dependencies to 0.15.0 library versions (#4300) * Update test's bower.json files to released versions * Update passing tests * Fix duplicate module error prelude defines `Data.Reflectable` module now * Update golden tests * Install spago 0.20.8 * Add changelog entry --- ...ernal_update-tests-to-released-versions.md | 1 + ci/build-package-set.sh | 2 +- .../InstanceChainBothUnknownAndMatch.out | 12 +-- .../InstanceChainBothUnknownAndMatch.purs | 14 ++- .../InstanceChainSkolemUnknownMatch.out | 4 +- .../InstanceChainSkolemUnknownMatch.purs | 7 +- tests/purs/failing/RowLacks.out | 13 +-- tests/purs/failing/RowLacks.purs | 12 +-- .../3558-UpToDateDictsForHigherOrderFns.purs | 9 +- tests/purs/passing/AppendInReverse.purs | 12 +-- tests/purs/passing/PolyLabels.purs | 15 ++-- tests/purs/passing/RowLacks.purs | 30 +++---- tests/purs/passing/RowNub.purs | 14 +-- tests/purs/passing/SolvingIsSymbol/Lib.purs | 7 +- tests/purs/passing/SolvingReflectable.purs | 4 +- .../purs/passing/SolvingReflectable/Lib.purs | 5 -- .../purs/passing/StringEdgeCases/Symbols.purs | 11 +-- .../warning/Kind-UnusedExplicitImport-1.out | 4 +- .../warning/Kind-UnusedExplicitImport-1.purs | 2 +- .../warning/Kind-UnusedExplicitImport-2.out | 4 +- .../warning/Kind-UnusedExplicitImport-2.purs | 5 +- tests/support/bower.json | 89 +++++++------------ 22 files changed, 126 insertions(+), 150 deletions(-) create mode 100644 CHANGELOG.d/internal_update-tests-to-released-versions.md delete mode 100644 tests/purs/passing/SolvingReflectable/Lib.purs diff --git a/CHANGELOG.d/internal_update-tests-to-released-versions.md b/CHANGELOG.d/internal_update-tests-to-released-versions.md new file mode 100644 index 0000000000..23269e0e9d --- /dev/null +++ b/CHANGELOG.d/internal_update-tests-to-released-versions.md @@ -0,0 +1 @@ +* Update tests and their bower deps to 0.15.0-compatible versions \ No newline at end of file diff --git a/ci/build-package-set.sh b/ci/build-package-set.sh index a6eae3419f..a1fc41734f 100755 --- a/ci/build-package-set.sh +++ b/ci/build-package-set.sh @@ -16,7 +16,7 @@ export PATH="$tmpdir/node_modules/.bin:$PATH" cd "$tmpdir" echo ::group::Ensure Spago is available -which spago || npm install spago@0.20.3 +which spago || npm install spago@0.20.8 echo ::endgroup:: echo ::group::Create dummy project diff --git a/tests/purs/failing/InstanceChainBothUnknownAndMatch.out b/tests/purs/failing/InstanceChainBothUnknownAndMatch.out index f08c540f40..a097d1936c 100644 --- a/tests/purs/failing/InstanceChainBothUnknownAndMatch.out +++ b/tests/purs/failing/InstanceChainBothUnknownAndMatch.out @@ -1,15 +1,15 @@ Error found: in module InstanceChains.BothUnknownAndMatch -at tests/purs/failing/InstanceChainBothUnknownAndMatch.purs:17:13 - 17:55 (line 17, column 13 - line 17, column 55) +at tests/purs/failing/InstanceChainBothUnknownAndMatch.purs:15:13 - 15:53 (line 15, column 13 - line 15, column 53) No type class instance was found for   -  InstanceChains.BothUnknownAndMatch.Same (RProxy  +  InstanceChains.BothUnknownAndMatch.Same (Proxy   ( m :: Int  , u :: t3   )   )  -  (RProxy  +  (Proxy   ( m :: Int  , u :: Int  )  @@ -22,9 +22,9 @@ at tests/purs/failing/InstanceChainBothUnknownAndMatch.purs:17:13 - 17:55 (line while applying a function same - of type Same @Type @Type t0 t1 t2 => t0 -> t1 -> SProxy t2 - to argument RProxy -while inferring the type of same RProxy + of type Same @Type @Type t0 t1 t2 => t0 -> t1 -> Proxy @Symbol t2 + to argument Proxy +while inferring the type of same Proxy in value declaration example where t3 is a rigid type variable diff --git a/tests/purs/failing/InstanceChainBothUnknownAndMatch.purs b/tests/purs/failing/InstanceChainBothUnknownAndMatch.purs index 2c9cf6ef06..ff1254c7df 100644 --- a/tests/purs/failing/InstanceChainBothUnknownAndMatch.purs +++ b/tests/purs/failing/InstanceChainBothUnknownAndMatch.purs @@ -1,18 +1,16 @@ -- @shouldFailWith NoInstanceFound module InstanceChains.BothUnknownAndMatch where -import Type.Proxy (Proxy) -import Type.Row (RProxy(..)) -import Data.Symbol (SProxy(..)) +import Type.Proxy (Proxy(..)) class Same l r (o :: Symbol) | l r -> o instance sameY :: Same t t "Y" else instance sameN :: Same l r "N" -same :: forall l r o. Same l r o => l -> r -> SProxy o -same _ _ = SProxy +same :: forall l r o. Same l r o => l -> r -> Proxy o +same _ _ = Proxy -- for label `u`, `t ~ Int` should be Unknown -- for label `m`, `Int ~ Int` should be a match -- together they should be Unknown -example :: forall t. Proxy t -> SProxy _ -example _ = same (RProxy :: RProxy (u :: t, m :: Int)) - (RProxy :: RProxy (u :: Int, m :: Int)) +example :: forall t. Proxy t -> Proxy _ +example _ = same (Proxy :: Proxy (u :: t, m :: Int)) + (Proxy :: Proxy (u :: Int, m :: Int)) diff --git a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out index fa66f419ef..82e1ace510 100644 --- a/tests/purs/failing/InstanceChainSkolemUnknownMatch.out +++ b/tests/purs/failing/InstanceChainSkolemUnknownMatch.out @@ -1,6 +1,6 @@ Error found: in module InstanceChainSkolemUnknownMatch -at tests/purs/failing/InstanceChainSkolemUnknownMatch.purs:14:13 - 14:36 (line 14, column 13 - line 14, column 36) +at tests/purs/failing/InstanceChainSkolemUnknownMatch.purs:13:13 - 13:36 (line 13, column 13 - line 13, column 36) No type class instance was found for   @@ -14,7 +14,7 @@ at tests/purs/failing/InstanceChainSkolemUnknownMatch.purs:14:13 - 14:36 (line 1 while applying a function same - of type Same @Type @Type t0 t1 t2 => t0 -> t1 -> SProxy t2 + of type Same @Type @Type t0 t1 t2 => t0 -> t1 -> Proxy @Symbol t2 to argument Proxy while inferring the type of same Proxy in value declaration example diff --git a/tests/purs/failing/InstanceChainSkolemUnknownMatch.purs b/tests/purs/failing/InstanceChainSkolemUnknownMatch.purs index 9968ed3b4c..e291c47993 100644 --- a/tests/purs/failing/InstanceChainSkolemUnknownMatch.purs +++ b/tests/purs/failing/InstanceChainSkolemUnknownMatch.purs @@ -2,14 +2,13 @@ module InstanceChainSkolemUnknownMatch where import Type.Proxy (Proxy(..)) -import Data.Symbol (SProxy(..)) class Same l r (o :: Symbol) | l r -> o instance sameY :: Same t t "Y" else instance sameN :: Same l r "N" -same :: forall l r o. Same l r o => l -> r -> SProxy o -same _ _ = SProxy +same :: forall l r o. Same l r o => l -> r -> Proxy o +same _ _ = Proxy -- shouldn't discard sameY as Apart -example :: forall (t :: Type). Proxy t -> SProxy _ +example :: forall (t :: Type). Proxy t -> Proxy _ example _ = same (Proxy :: Proxy t) (Proxy :: Proxy Int) diff --git a/tests/purs/failing/RowLacks.out b/tests/purs/failing/RowLacks.out index a4565012f6..bd424a618a 100644 --- a/tests/purs/failing/RowLacks.out +++ b/tests/purs/failing/RowLacks.out @@ -1,6 +1,6 @@ Error found: in module Main -at tests/purs/failing/RowLacks.purs:16:9 - 16:68 (line 16, column 9 - line 16, column 68) +at tests/purs/failing/RowLacks.purs:16:9 - 16:66 (line 16, column 9 - line 16, column 66) No type class instance was found for   @@ -12,13 +12,16 @@ at tests/purs/failing/RowLacks.purs:16:9 - 16:68 (line 16, column 9 - line 16, c   while applying a function lacksX - of type Lacks @Type "x" t0 => RProxy t0 -> RProxy (() @Type) - to argument RProxy -while checking that expression lacksX RProxy - has type RProxy (() @Type) + of type Lacks @t1 "x" t2 => Proxy @(Row t1) t2 -> Proxy @(Row t3) (() @t3) + to argument Proxy +while checking that expression lacksX Proxy + has type Proxy @(Row t0) (() @t0) in value declaration test1 where t0 is an unknown type + t1 is an unknown type + t3 is an unknown type + t2 is an unknown type See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/RowLacks.purs b/tests/purs/failing/RowLacks.purs index 7805872e63..c2e4b497de 100644 --- a/tests/purs/failing/RowLacks.purs +++ b/tests/purs/failing/RowLacks.purs @@ -3,16 +3,16 @@ module Main where import Effect.Console (log) import Prim.Row (class Lacks) -import Type.Row (RProxy(..)) +import Type.Proxy (Proxy(..)) lacksX :: forall r . Lacks "x" r - => RProxy r - -> RProxy () -lacksX _ = RProxy + => Proxy r + -> Proxy () +lacksX _ = Proxy -test1 :: RProxy () -test1 = lacksX (RProxy :: RProxy (x :: Int, y :: Int, z :: String)) +test1 :: Proxy () +test1 = lacksX (Proxy :: Proxy (x :: Int, y :: Int, z :: String)) main = log "Done" diff --git a/tests/purs/passing/3558-UpToDateDictsForHigherOrderFns.purs b/tests/purs/passing/3558-UpToDateDictsForHigherOrderFns.purs index 8515fc9d76..d5f067df92 100644 --- a/tests/purs/passing/3558-UpToDateDictsForHigherOrderFns.purs +++ b/tests/purs/passing/3558-UpToDateDictsForHigherOrderFns.purs @@ -4,12 +4,13 @@ import Prelude (Unit) import Effect (Effect) import Effect.Console (log) import Record.Unsafe (unsafeGet) -import Type.Data.Symbol (class IsSymbol, SProxy, reflectSymbol) +import Type.Data.Symbol (class IsSymbol, reflectSymbol) import Type.Row (class Cons) as Row +import Type.Proxy (Proxy) -newtype LBox row a = LBox (∀ r. (∀ lbl _1. Row.Cons lbl a _1 row ⇒ IsSymbol lbl ⇒ SProxy lbl → r) → r) +newtype LBox row a = LBox (∀ r. (∀ lbl _1. Row.Cons lbl a _1 row ⇒ IsSymbol lbl ⇒ Proxy lbl → r) → r) -unLBox ∷ ∀ row a r. (∀ lbl _1. Row.Cons lbl a _1 row ⇒ IsSymbol lbl ⇒ SProxy lbl → r) → LBox row a → r +unLBox ∷ ∀ row a r. (∀ lbl _1. Row.Cons lbl a _1 row ⇒ IsSymbol lbl ⇒ Proxy lbl → r) → LBox row a → r unLBox g (LBox f) = f g -- Example 1 @@ -24,7 +25,7 @@ get :: forall r r' l a . IsSymbol l => Row.Cons l a r' r - => SProxy l + => Proxy l -> Record r -> a get l r = unsafeGet (reflectSymbol l) r diff --git a/tests/purs/passing/AppendInReverse.purs b/tests/purs/passing/AppendInReverse.purs index b900657e59..572d531aa5 100644 --- a/tests/purs/passing/AppendInReverse.purs +++ b/tests/purs/passing/AppendInReverse.purs @@ -1,9 +1,9 @@ module Main where import Prelude -import Data.Symbol (SProxy(..)) import Prim.Symbol (class Append) import Effect.Console (log) +import Type.Proxy (Proxy(..)) class Balanced (sym :: Symbol) @@ -15,20 +15,20 @@ instance balanced2 , Balanced sym2 ) => Balanced sym -balanced :: forall sym. Balanced sym => SProxy sym -> String +balanced :: forall sym. Balanced sym => Proxy sym -> String balanced _ = "ok" b0 :: String -b0 = balanced (SProxy :: SProxy "") +b0 = balanced (Proxy :: Proxy "") b1 :: String -b1 = balanced (SProxy :: SProxy "()") +b1 = balanced (Proxy :: Proxy "()") b2 :: String -b2 = balanced (SProxy :: SProxy "(())") +b2 = balanced (Proxy :: Proxy "(())") b3 :: String -b3 = balanced (SProxy :: SProxy "((()))") +b3 = balanced (Proxy :: Proxy "((()))") main = do log b0 diff --git a/tests/purs/passing/PolyLabels.purs b/tests/purs/passing/PolyLabels.purs index 15caed8e8d..95b915ae5d 100644 --- a/tests/purs/passing/PolyLabels.purs +++ b/tests/purs/passing/PolyLabels.purs @@ -4,7 +4,8 @@ import Prelude import Prim.Row import Effect import Effect.Console -import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) +import Data.Symbol (class IsSymbol, reflectSymbol) +import Type.Proxy (Proxy(..)) foreign import unsafeGet :: forall r a @@ -23,7 +24,7 @@ get :: forall r r' l a . IsSymbol l => Cons l a r' r - => SProxy l + => Proxy l -> Record r -> a get l = unsafeGet (reflectSymbol l) @@ -33,7 +34,7 @@ set . IsSymbol l => Cons l a r r1 => Cons l b r r2 - => SProxy l + => Proxy l -> b -> Record r1 -> Record r2 @@ -45,20 +46,20 @@ lens => Cons l a r r1 => Cons l b r r2 => Functor f - => SProxy l + => Proxy l -> (a -> f b) -> Record r1 -> f (Record r2) lens l f r = flip (set l) r <$> f (get l r) getFoo :: forall a r. { foo :: a | r } -> a -getFoo = get (SProxy :: SProxy "foo") +getFoo = get (Proxy :: Proxy "foo") setFoo :: forall a b r. b -> { foo :: a | r } -> { foo :: b | r } -setFoo = set (SProxy :: SProxy "foo") +setFoo = set (Proxy :: Proxy "foo") fooLens :: forall f a b r. Functor f => (a -> f b) -> { foo :: a | r } -> f { foo :: b | r } -fooLens = lens (SProxy :: SProxy "foo") +fooLens = lens (Proxy :: Proxy "foo") main :: Effect Unit main = do diff --git a/tests/purs/passing/RowLacks.purs b/tests/purs/passing/RowLacks.purs index 34d664ce11..34bee65f1a 100644 --- a/tests/purs/passing/RowLacks.purs +++ b/tests/purs/passing/RowLacks.purs @@ -2,34 +2,32 @@ module Main where import Effect.Console (log) import Prim.Row (class Lacks) -import Type.Row (RProxy(..)) - -data SProxy (a :: Symbol) = SProxy +import Type.Proxy (Proxy(..)) lacksX :: forall r . Lacks "x" r - => RProxy r - -> RProxy () -lacksX _ = RProxy + => Proxy r + -> Proxy () +lacksX _ = Proxy lacksSym :: forall sym (to :: Row Type) . Lacks sym to - => SProxy sym - -> RProxy to -lacksSym _ = RProxy + => Proxy sym + -> Proxy to +lacksSym _ = Proxy -test1 :: RProxy () -test1 = lacksX (RProxy :: RProxy (y :: Int, z :: String)) +test1 :: Proxy () +test1 = lacksX (Proxy :: Proxy (y :: Int, z :: String)) -test2 :: forall r. Lacks "x" r => RProxy r -> RProxy () -test2 _ = lacksX (RProxy :: RProxy (y :: Int, z :: String | r)) +test2 :: forall r. Lacks "x" r => Proxy r -> Proxy () +test2 _ = lacksX (Proxy :: Proxy (y :: Int, z :: String | r)) -test3 :: RProxy () -test3 = test2 (RProxy :: RProxy (a :: String)) +test3 :: Proxy () +test3 = test2 (Proxy :: Proxy (a :: String)) -test4 :: forall sym. SProxy sym -> RProxy () +test4 :: forall sym. Proxy sym -> Proxy () test4 = lacksSym main = log "Done" diff --git a/tests/purs/passing/RowNub.purs b/tests/purs/passing/RowNub.purs index fd9f6ca3b8..574f192c8c 100644 --- a/tests/purs/passing/RowNub.purs +++ b/tests/purs/passing/RowNub.purs @@ -2,22 +2,22 @@ module Main where import Effect.Console (log) import Prim.Row (class Nub, class Union) -import Type.Row (RProxy(..)) +import Type.Proxy (Proxy(..)) nubUnion :: forall r1 r2 r3 r4 . Union r1 r2 r3 => Nub r3 r4 - => RProxy r1 - -> RProxy r2 - -> RProxy r4 -nubUnion _ _ = RProxy + => Proxy r1 + -> Proxy r2 + -> Proxy r4 +nubUnion _ _ = Proxy type InL = (x :: Int, y :: String) type InR = (x :: String, y :: Int, z :: Boolean) type Out = (x :: Int, y :: String, z :: Boolean) -test :: RProxy Out -test = nubUnion (RProxy :: RProxy InL) (RProxy :: RProxy InR) +test :: Proxy Out +test = nubUnion (Proxy :: Proxy InL) (Proxy :: Proxy InR) main = log "Done" diff --git a/tests/purs/passing/SolvingIsSymbol/Lib.purs b/tests/purs/passing/SolvingIsSymbol/Lib.purs index 18ea3b2924..0ceb55b8d2 100644 --- a/tests/purs/passing/SolvingIsSymbol/Lib.purs +++ b/tests/purs/passing/SolvingIsSymbol/Lib.purs @@ -1,10 +1,11 @@ module SolvingIsSymbol.Lib where import Data.Symbol +import Type.Proxy (Proxy(..)) -literalSymbol :: SProxy "literal" -literalSymbol = SProxy +literalSymbol :: Proxy "literal" +literalSymbol = Proxy -libReflectSymbol :: forall s. IsSymbol s => SProxy s -> String +libReflectSymbol :: forall s. IsSymbol s => Proxy s -> String libReflectSymbol = reflectSymbol diff --git a/tests/purs/passing/SolvingReflectable.purs b/tests/purs/passing/SolvingReflectable.purs index e6e0fc9826..69842befb7 100644 --- a/tests/purs/passing/SolvingReflectable.purs +++ b/tests/purs/passing/SolvingReflectable.purs @@ -7,9 +7,7 @@ import Data.Reflectable (reflectType) import Effect.Console (log) import Prim.Boolean (True, False) import Prim.Ordering (LT, EQ, GT) - -data Proxy :: forall k. k -> Type -data Proxy n = Proxy +import Type.Proxy (Proxy(..)) refInt :: Proxy 42 refInt = Proxy diff --git a/tests/purs/passing/SolvingReflectable/Lib.purs b/tests/purs/passing/SolvingReflectable/Lib.purs deleted file mode 100644 index 0ad5966ed3..0000000000 --- a/tests/purs/passing/SolvingReflectable/Lib.purs +++ /dev/null @@ -1,5 +0,0 @@ -module Data.Reflectable where - -class Reflectable :: forall k. k -> Type -> Constraint -class Reflectable v t | v -> t where - reflectType :: forall proxy. proxy v -> t diff --git a/tests/purs/passing/StringEdgeCases/Symbols.purs b/tests/purs/passing/StringEdgeCases/Symbols.purs index 0289a893d0..bdcc673158 100644 --- a/tests/purs/passing/StringEdgeCases/Symbols.purs +++ b/tests/purs/passing/StringEdgeCases/Symbols.purs @@ -6,15 +6,16 @@ module Symbols where import Prelude import Effect.Console (log) import Prim.Symbol (class Append) -import Type.Data.Symbol (SProxy(..), reflectSymbol) +import Type.Data.Symbol (reflectSymbol) import Type.Data.Symbol (append) as Symbol import Test.Assert (assert') +import Type.Proxy (Proxy(..)) -highS :: SProxy "\xd834" -highS = SProxy +highS :: Proxy "\xd834" +highS = Proxy -lowS :: SProxy "\xdf06" -lowS = SProxy +lowS :: Proxy "\xdf06" +lowS = Proxy loneSurrogates :: Boolean loneSurrogates = reflectSymbol (Symbol.append highS lowS) == "\x1d306" diff --git a/tests/purs/warning/Kind-UnusedExplicitImport-1.out b/tests/purs/warning/Kind-UnusedExplicitImport-1.out index 064f3ee477..8560ddba83 100644 --- a/tests/purs/warning/Kind-UnusedExplicitImport-1.out +++ b/tests/purs/warning/Kind-UnusedExplicitImport-1.out @@ -1,10 +1,10 @@ Warning found: in module Main -at tests/purs/warning/Kind-UnusedExplicitImport-1.purs:6:1 - 6:39 (line 6, column 1 - line 6, column 39) +at tests/purs/warning/Kind-UnusedExplicitImport-1.purs:6:1 - 6:47 (line 6, column 1 - line 6, column 47) The import of module Type.RowList contains the following unused references: - RLProxy + ListToRow It could be replaced with: diff --git a/tests/purs/warning/Kind-UnusedExplicitImport-1.purs b/tests/purs/warning/Kind-UnusedExplicitImport-1.purs index d2895c2290..7c7a8b335b 100644 --- a/tests/purs/warning/Kind-UnusedExplicitImport-1.purs +++ b/tests/purs/warning/Kind-UnusedExplicitImport-1.purs @@ -3,7 +3,7 @@ module Main where import Prelude (Unit, unit, pure) import Effect (Effect) -import Type.RowList (RLProxy, RowList) +import Type.RowList (class ListToRow, RowList) class A (a :: RowList Type) diff --git a/tests/purs/warning/Kind-UnusedExplicitImport-2.out b/tests/purs/warning/Kind-UnusedExplicitImport-2.out index cad43190b8..1ba9def753 100644 --- a/tests/purs/warning/Kind-UnusedExplicitImport-2.out +++ b/tests/purs/warning/Kind-UnusedExplicitImport-2.out @@ -1,6 +1,6 @@ Warning found: in module Main -at tests/purs/warning/Kind-UnusedExplicitImport-2.purs:6:1 - 6:39 (line 6, column 1 - line 6, column 39) +at tests/purs/warning/Kind-UnusedExplicitImport-2.purs:6:1 - 6:47 (line 6, column 1 - line 6, column 47) The import of module Type.RowList contains the following unused references: @@ -8,7 +8,7 @@ at tests/purs/warning/Kind-UnusedExplicitImport-2.purs:6:1 - 6:39 (line 6, colum It could be replaced with: - import Type.RowList (RLProxy) + import Type.RowList (class ListToRow) diff --git a/tests/purs/warning/Kind-UnusedExplicitImport-2.purs b/tests/purs/warning/Kind-UnusedExplicitImport-2.purs index 480dcfca9f..2bbaccefe0 100644 --- a/tests/purs/warning/Kind-UnusedExplicitImport-2.purs +++ b/tests/purs/warning/Kind-UnusedExplicitImport-2.purs @@ -3,9 +3,10 @@ module Main where import Prelude (Unit, unit, pure) import Effect (Effect) -import Type.RowList (RLProxy, RowList) +import Type.RowList (class ListToRow, RowList) +import Type.Proxy (Proxy) -f :: forall l. RLProxy l -> Int +f :: forall l r. ListToRow l r => Proxy l -> Int f _ = 0 main :: Effect Unit diff --git a/tests/support/bower.json b/tests/support/bower.json index 7090e578ab..035f9e076d 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -1,60 +1,39 @@ { "name": "purescript-test-suite-support", "dependencies": { - "purescript-arrays": "https://github.com/working-group-purescript-es/purescript-arrays.git#es-modules", - "purescript-assert": "https://github.com/working-group-purescript-es/purescript-assert.git#es-modules", - "purescript-bifunctors": "5.0.0", - "purescript-console": "https://github.com/working-group-purescript-es/purescript-console.git#es-modules", - "purescript-control": "https://github.com/working-group-purescript-es/purescript-control.git#es-modules", - "purescript-distributive": "5.0.0", - "purescript-effect": "https://github.com/working-group-purescript-es/purescript-effect.git#es-modules", - "purescript-either": "5.0.0", - "purescript-enums": "https://github.com/working-group-purescript-es/purescript-enums.git#es-modules", - "purescript-foldable-traversable": "https://github.com/working-group-purescript-es/purescript-foldable-traversable.git#es-modules", - "purescript-functions": "https://github.com/working-group-purescript-es/purescript-functions.git#es-modules", - "purescript-gen": "3.0.0", - "purescript-identity": "5.0.0", - "purescript-integers": "https://github.com/working-group-purescript-es/purescript-integers.git#es-modules", - "purescript-invariant": "5.0.0", - "purescript-lazy": "https://github.com/working-group-purescript-es/purescript-lazy.git#es-modules", - "purescript-lists": "6.1.0", - "purescript-math": "https://github.com/working-group-purescript-es/purescript-math.git#es-modules", - "purescript-maybe": "5.0.0", - "purescript-newtype": "4.0.0", - "purescript-nonempty": "6.0.0", - "purescript-numbers": "https://github.com/working-group-purescript-es/purescript-numbers.git#es-modules", - "purescript-partial": "https://github.com/working-group-purescript-es/purescript-partial.git#es-modules", - "purescript-prelude": "https://github.com/working-group-purescript-es/purescript-prelude.git#es-modules", - "purescript-psci-support": "5.0.0", - "purescript-refs": "https://github.com/working-group-purescript-es/purescript-refs.git#es-modules", - "purescript-safe-coerce": "1.0.0", - "purescript-st": "https://github.com/working-group-purescript-es/purescript-st.git#es-modules", - "purescript-strings": "https://github.com/working-group-purescript-es/purescript-strings.git#es-modules", - "purescript-tailrec": "5.0.0", - "purescript-tuples": "6.0.0", - "purescript-type-equality": "4.0.0", - "purescript-typelevel-prelude": "6.0.0", - "purescript-unfoldable": "https://github.com/working-group-purescript-es/purescript-unfoldable.git#es-modules", - "purescript-unsafe-coerce": "https://github.com/working-group-purescript-es/purescript-unsafe-coerce.git#es-modules" - }, - "resolutions": { - "purescript-console": "es-modules", - "purescript-assert": "es-modules", - "purescript-effect": "es-modules", - "purescript-enums": "es-modules", - "purescript-control": "es-modules", - "purescript-foldable-traversable": "es-modules", - "purescript-functions": "es-modules", - "purescript-lazy": "es-modules", - "purescript-math": "es-modules", - "purescript-arrays": "es-modules", - "purescript-integers": "es-modules", - "purescript-numbers": "es-modules", - "purescript-partial": "es-modules", - "purescript-refs": "es-modules", - "purescript-st": "es-modules", - "purescript-unfoldable": "es-modules", - "purescript-prelude": "es-modules", - "purescript-unsafe-coerce": "es-modules" + "purescript-arrays": "^7.0.0", + "purescript-assert": "^6.0.0", + "purescript-bifunctors": "^6.0.0", + "purescript-console": "^6.0.0", + "purescript-control": "^6.0.0", + "purescript-distributive": "^6.0.0", + "purescript-effect": "^4.0.0", + "purescript-either": "^6.0.0", + "purescript-enums": "^6.0.0", + "purescript-foldable-traversable": "^6.0.0", + "purescript-functions": "^6.0.0", + "purescript-gen": "^4.0.0", + "purescript-identity": "^6.0.0", + "purescript-integers": "^6.0.0", + "purescript-invariant": "^6.0.0", + "purescript-lazy": "^6.0.0", + "purescript-lists": "^7.0.0", + "purescript-maybe": "^6.0.0", + "purescript-newtype": "^5.0.0", + "purescript-nonempty": "^7.0.0", + "purescript-numbers": "^9.0.0", + "purescript-partial": "^4.0.0", + "purescript-prelude": "^6.0.0", + "purescript-psci-support": "^6.0.0", + "purescript-refs": "^6.0.0", + "purescript-safe-coerce": "^2.0.0", + "purescript-st": "^6.0.0", + "purescript-strings": "^6.0.0", + "purescript-tailrec": "^6.0.0", + "purescript-tuples": "^7.0.0", + "purescript-type-equality": "^4.0.1", + "purescript-typelevel-prelude": "^7.0.0", + "purescript-unfoldable": "^6.0.0", + "purescript-unsafe-coerce": "^6.0.0" } } From b5f97489d0a383ff3ad6edb2b0ec530b611bd1fb Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 29 Apr 2022 05:07:29 -0500 Subject: [PATCH 1448/1580] Fix package set step by upgrading npm in CI (#4302) * Update node to 14 12 will be EOL in a few months * Update npm before running package set step --- .github/workflows/ci.yml | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 22d43efc2e..85a5cbeeb3 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -42,9 +42,9 @@ jobs: apt-get update && apt-get install -y git/"$VERSION_CODENAME"-backports - uses: "actions/checkout@v2" - - uses: "actions/setup-node@v1" + - uses: "actions/setup-node@v2" with: - node-version: "12" + node-version: "14" - id: "haskell" name: "(Non-Linux only) Install Haskell" @@ -89,7 +89,12 @@ jobs: # into which stack places all build artifacts. Since we use --haddock # in our CI builds, in order to actually get stack to find the purs # binary it created, we need to use the flag here as well. - run: "../ci/fix-home stack --haddock exec ../ci/build-package-set.sh" + # + # Moreover, npm has a hook issue that will cause spago to fail to install + # We upgrade npm to fix this + run: | + npm i -g npm@8.8.0 + ../ci/fix-home stack --haddock exec ../ci/build-package-set.sh - name: Verify that 'libtinfo' isn't in binary if: runner.os == 'Linux' From 1324638f7f262d1abcae30fe3a628c99191e4c2a Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 29 Apr 2022 11:40:07 -0500 Subject: [PATCH 1449/1580] Make 0.15.0 release (#4299) * Update version to 0.15.0 * Regenerate license * Finalize 0.15.0 changelog entry --- .../breaking_disable-constraints-in-ffi.md | 23 - ...ing_drop-deprecated-row-and-kind-syntax.md | 1 - .../breaking_drop-repl-browser-backend.md | 4 - CHANGELOG.d/breaking_fail-on-cjs-detected.md | 13 - CHANGELOG.d/breaking_fix-3981.md | 10 - CHANGELOG.d/breaking_fix-4179.md | 67 - .../breaking_improve-apartness-checking.md | 3 - CHANGELOG.d/breaking_remove-purs-bundle.md | 3 - CHANGELOG.d/breaking_switch-to-es-modules.md | 26 - ...king_warn-on-two-ad-hoc-case-statements.md | 25 - CHANGELOG.d/feature_compilation_progress.md | 12 - CHANGELOG.d/feature_is_reflectable.md | 7 - CHANGELOG.d/feature_restore_names.md | 25 - CHANGELOG.d/feature_support_older_glibc.md | 4 - CHANGELOG.d/feature_type_level_ints.md | 5 - CHANGELOG.d/fix_3559.md | 1 - CHANGELOG.d/fix_4268.md | 9 - CHANGELOG.d/internal_document-hspec-accept.md | 1 - .../internal_error-on-non-Main-modules.md | 1 - CHANGELOG.d/internal_mv-cst-into-src.md | 1 - .../internal_update-ci-windows-to-2019.md | 1 - ...ernal_update-tests-to-released-versions.md | 1 - ...misc_clarify-point-in-do-notation-error.md | 7 - CHANGELOG.md | 285 ++++ LICENSE | 1348 +++++------------ app/Version.hs | 2 +- npm-package/package.json | 4 +- purescript.cabal | 2 +- 28 files changed, 630 insertions(+), 1261 deletions(-) delete mode 100644 CHANGELOG.d/breaking_disable-constraints-in-ffi.md delete mode 100644 CHANGELOG.d/breaking_drop-deprecated-row-and-kind-syntax.md delete mode 100644 CHANGELOG.d/breaking_drop-repl-browser-backend.md delete mode 100644 CHANGELOG.d/breaking_fail-on-cjs-detected.md delete mode 100644 CHANGELOG.d/breaking_fix-3981.md delete mode 100644 CHANGELOG.d/breaking_fix-4179.md delete mode 100644 CHANGELOG.d/breaking_improve-apartness-checking.md delete mode 100644 CHANGELOG.d/breaking_remove-purs-bundle.md delete mode 100644 CHANGELOG.d/breaking_switch-to-es-modules.md delete mode 100644 CHANGELOG.d/breaking_warn-on-two-ad-hoc-case-statements.md delete mode 100644 CHANGELOG.d/feature_compilation_progress.md delete mode 100644 CHANGELOG.d/feature_is_reflectable.md delete mode 100644 CHANGELOG.d/feature_restore_names.md delete mode 100644 CHANGELOG.d/feature_support_older_glibc.md delete mode 100644 CHANGELOG.d/feature_type_level_ints.md delete mode 100644 CHANGELOG.d/fix_3559.md delete mode 100644 CHANGELOG.d/fix_4268.md delete mode 100644 CHANGELOG.d/internal_document-hspec-accept.md delete mode 100644 CHANGELOG.d/internal_error-on-non-Main-modules.md delete mode 100644 CHANGELOG.d/internal_mv-cst-into-src.md delete mode 100644 CHANGELOG.d/internal_update-ci-windows-to-2019.md delete mode 100644 CHANGELOG.d/internal_update-tests-to-released-versions.md delete mode 100644 CHANGELOG.d/misc_clarify-point-in-do-notation-error.md diff --git a/CHANGELOG.d/breaking_disable-constraints-in-ffi.md b/CHANGELOG.d/breaking_disable-constraints-in-ffi.md deleted file mode 100644 index b0c08e45f2..0000000000 --- a/CHANGELOG.d/breaking_disable-constraints-in-ffi.md +++ /dev/null @@ -1,23 +0,0 @@ -* Disable type class constraints in FFI - - Previously, one could write FFI like the following: - ```purescript - foreign import foo :: forall a. Show a => a -> String - ``` - - Type class dictionaries are "magically" handled by the compiler. - By including them in the above FFI, one can depend on their representation. - Since the representation can change without notice, this may silently break - code. - - In `v0.14.x`, a warning was emitted if these were used. Now it will fail - to compile. Rather, one should write something like the following - where the members of the type class are passed explicitly to - the FFI function as arguments: - - ```purescript - foo :: forall a. Show a => a -> String - foo val = fooImpl show val - - foreign import fooImpl :: forall a. (a -> String) -> a -> String - ``` diff --git a/CHANGELOG.d/breaking_drop-deprecated-row-and-kind-syntax.md b/CHANGELOG.d/breaking_drop-deprecated-row-and-kind-syntax.md deleted file mode 100644 index 1ec461f99f..0000000000 --- a/CHANGELOG.d/breaking_drop-deprecated-row-and-kind-syntax.md +++ /dev/null @@ -1 +0,0 @@ -* Removes deprecated syntax for rows (i.e. `#`) and kinds (i.e. `kind`-keyword) \ No newline at end of file diff --git a/CHANGELOG.d/breaking_drop-repl-browser-backend.md b/CHANGELOG.d/breaking_drop-repl-browser-backend.md deleted file mode 100644 index a42ea6efe0..0000000000 --- a/CHANGELOG.d/breaking_drop-repl-browser-backend.md +++ /dev/null @@ -1,4 +0,0 @@ -* Drop support for browser backend for repl (i.e. `purs repl --port 1234`) - - Running this command will print a link that directs users to use - Try PureScript instead. \ No newline at end of file diff --git a/CHANGELOG.d/breaking_fail-on-cjs-detected.md b/CHANGELOG.d/breaking_fail-on-cjs-detected.md deleted file mode 100644 index e2a9ddc667..0000000000 --- a/CHANGELOG.d/breaking_fail-on-cjs-detected.md +++ /dev/null @@ -1,13 +0,0 @@ -* If FFI parsing succeeds & CommonJS is detected, fail; otherwise, do not error or warn - - Previously, the compiler would emit an error if it failed to parse the FFI JavaScript file. - Since the underlying JavaScript parser (i.e. `language-javascript`) fails to parse even - valid JavaScript files, we cannot consider every failed parse to mean invalid JS files. - Fixing the parser would require a lot of effort, so we are planning to remove it instead - in `v0.16.x`. - - If the parse succeeds and a CommonJS module is detected, a compiler error is now emitted. - If the parse fails, we no longer emit a compiler error. While we could emit a warning, - such a warning will quickly become annoying for FFI files that trigger the buggy paths - of `language-javascript`. Moreover, we presume that all will be migrating their code to - ES modules now that CommonJS is being deprecated in the larger JavaScript ecosystem. diff --git a/CHANGELOG.d/breaking_fix-3981.md b/CHANGELOG.d/breaking_fix-3981.md deleted file mode 100644 index d76e45f28c..0000000000 --- a/CHANGELOG.d/breaking_fix-3981.md +++ /dev/null @@ -1,10 +0,0 @@ -* Apply precedence rules to operator sections - - Previously, `(_ * 4 + 1)` would desugar to `\x -> x * (4 + 1)`, even - though `*` has higher precedence than `+`. Conversely, `(3 * 2 + _)` - would not compile, even though `*` has higher precedence than `+`. These - bugs have now been fixed; `(_ * 4 + 1)` is an error, and `(3 * 2 + _)` - desugars to `\x -> 3 * 2 + x`. - - If you have code that relied on the old behavior, add an extra pair of - parentheses around the expression in the section. diff --git a/CHANGELOG.d/breaking_fix-4179.md b/CHANGELOG.d/breaking_fix-4179.md deleted file mode 100644 index 500f6d593a..0000000000 --- a/CHANGELOG.d/breaking_fix-4179.md +++ /dev/null @@ -1,67 +0,0 @@ -* Lazy initialization for recursive bindings - - This is unlikely to break a working program, but the upshot for users is - that it's now possible to get a run-time error when dereferencing an - identifier in a recursive binding group before it has been initialized, - instead of silently getting an `undefined` value and having that maybe - or maybe not lead to an error somewhere else. - - This change can cause code that relies on tail-call optimization to no - longer compile with that optimization. If you find that code that - previously compiled to a TCO loop no longer does but does include `$lazy` - initializers, please report the issue. - - **Alternate backend maintainers:** for you, this change represents a - clarification of a responsibility shared by all backends. The identifiers - bound in a recursive binding group need to behave as if those identifiers - have call-by-need semantics during the initialization of the entire binding - group. (Initializing the binding group entails ensuring every initializer - has been executed, so after the binding group is initialized, these - identifiers can be considered call-by-value again.) - - If an identifier is needed during its own call-by-need initialization, the - backend must ensure that an explicit run-time error is raised appropriate for - your target platform. This error may be raised at compile time instead if the - backend can determine that such a cycle is inevitable. Returning your - target language's equivalent of JavaScript's `undefined`, as `purs` did in - earlier releases in some cases, is not permitted. - - If your target language natively has call-by-need semantics, you probably - don't have to do anything. If your target language is call-by-value and you - are using PureScript as a library, you can use the function - `Language.PureScript.CoreFn.Laziness.applyLazinessTransform` to your CoreFn - input to satisfy this responsibility; if you do, you will need to do the - following: - - * Translate `InternalIdent RuntimeLazyFactory` and `InternalIdent (Lazy _)` - identifiers to appropriate strings for your backend - * Ensure that any output file that needs it has a reference to a function - named `InternalIdent RuntimeLazyFactory`, with type `forall a. Fn3 String - String (Unit -> a) (Int -> a)`, and with the same semantics as the - following JavaScript (though you should customize the error raised to be - appropriate for your target language): - - ```js - function (name, moduleName, init) { - var state = 0; - var val; - return function (lineNumber) { - if (state === 2) return val; - if (state === 1) throw new ReferenceError(name + " was needed before it finished initializing (module " + moduleName + ", line " + lineNumber + ")", moduleName, lineNumber); - state = 1; - val = init(); - state = 2; - return val; - }; - }; - ``` - - If neither of the previous cases apply to you, you can meet this - responsibility most easily simply by ensuring that all recursive bindings are - lazy. You may instead choose to implement some light analysis to skip - generating lazy bindings in some cases, such as if every initializer in the - binding group is an `Abs`. You also may choose to reimplement - `applyLazinessTransform`, or even develop a more sophisticated laziness - transform for your backend. It is of course your responsibility to ensure - that the result of whatever analysis you do is equivalent to the expected - semantics. diff --git a/CHANGELOG.d/breaking_improve-apartness-checking.md b/CHANGELOG.d/breaking_improve-apartness-checking.md deleted file mode 100644 index 752e786336..0000000000 --- a/CHANGELOG.d/breaking_improve-apartness-checking.md +++ /dev/null @@ -1,3 +0,0 @@ -* Improve apartness checking - - See details in https://github.com/purescript/documentation/blob/master/language/Type-Classes.md#instance-chains diff --git a/CHANGELOG.d/breaking_remove-purs-bundle.md b/CHANGELOG.d/breaking_remove-purs-bundle.md deleted file mode 100644 index 0c9803463c..0000000000 --- a/CHANGELOG.d/breaking_remove-purs-bundle.md +++ /dev/null @@ -1,3 +0,0 @@ -* Remove `purs bundle` - - Users of `purs bundle` should switch to a standalone bundler such as `esbuild`, `webpack` or `parcel`. \ No newline at end of file diff --git a/CHANGELOG.d/breaking_switch-to-es-modules.md b/CHANGELOG.d/breaking_switch-to-es-modules.md deleted file mode 100644 index f65e8d9221..0000000000 --- a/CHANGELOG.d/breaking_switch-to-es-modules.md +++ /dev/null @@ -1,26 +0,0 @@ -* Switch from Common JS to ES modules - - Previously, Purescript used Common JS for FFI declarations. - - Before, FFI was declared like this... - - ```javascript - const mymodule = require('mymodule') - - exports.myvar = mymodule.myvar - ``` - - ...and will be changed to this... - - ```javascript - import * as M from 'mymodule'; - export const myvar = M.myvar - ``` - ...or using the short version... - - ```javascript - export { myvar } from 'mymodule'; - ``` - -* FFI is annotated with `/* #__PURE__ */` so that bundlers can perform DCE -* The current LTS Node.js version `12` is now the required minimum version diff --git a/CHANGELOG.d/breaking_warn-on-two-ad-hoc-case-statements.md b/CHANGELOG.d/breaking_warn-on-two-ad-hoc-case-statements.md deleted file mode 100644 index 533fed7fc3..0000000000 --- a/CHANGELOG.d/breaking_warn-on-two-ad-hoc-case-statements.md +++ /dev/null @@ -1,25 +0,0 @@ -* Warn on ad-hoc non-single-line case expression syntax - - The following code will now produce a compiler warning. - These were originally supported to ease the migration - to the new CST parser. - - ```purescript - -- before: `arg` isn't indented "past" the `Foo arg` binder - case foo of Foo arg -> - arg - -- after - case foo of Foo arg -> - foo - ``` - - Dropping the above syntax make case expressions more similar to how `let` bindings work: - ```purescript - let ok = 1 - let - ok = 1 - let ok = - 1 - let notOk = - 1 - ``` \ No newline at end of file diff --git a/CHANGELOG.d/feature_compilation_progress.md b/CHANGELOG.d/feature_compilation_progress.md deleted file mode 100644 index ac798d5325..0000000000 --- a/CHANGELOG.d/feature_compilation_progress.md +++ /dev/null @@ -1,12 +0,0 @@ -* Print compilation progress on the command line - - This feature makes it so `purs compile` and `purs docs` now show - compilation progress on the command line. Example output: - - ```purs - [ 1 of 59] Compiling Type.Proxy - [ 2 of 59] Compiling Type.Data.RowList - ... - [58 of 59] Compiling Effect.Class.Console - [59 of 59] Compiling Test.Main - ``` diff --git a/CHANGELOG.d/feature_is_reflectable.md b/CHANGELOG.d/feature_is_reflectable.md deleted file mode 100644 index fb3aa552d2..0000000000 --- a/CHANGELOG.d/feature_is_reflectable.md +++ /dev/null @@ -1,7 +0,0 @@ -* Implement the Reflectable type class - - The `Reflectable` type class is a common interface for reflecting - type-level values down to the term-level. Its instances are - automatically solved by the compiler, and it allows `Symbol`, `Int`, - `Boolean`, and `Ordering` kinded types to be reflected to their - term-level representations. diff --git a/CHANGELOG.d/feature_restore_names.md b/CHANGELOG.d/feature_restore_names.md deleted file mode 100644 index b32fc31318..0000000000 --- a/CHANGELOG.d/feature_restore_names.md +++ /dev/null @@ -1,25 +0,0 @@ -* Restore names of quantified variables during generalization - - This makes the compiler aware of the names of quantified variables - instantiated into unification variables, such that when the latter - is generalized, semantic information is restored. For example: - - ```purs - addNumberSuffix :: forall a b c d. a -> b -> c -> d -> a - addNumberSuffix a _ _ _ = a - - addNumberSuffix' = addNumberSuffix 0 - ``` - - Previously, inferring top-level declarations without type signatures - would use `t` suffixed with an integer for type variables. - - ```purs - forall t6 t7 t8. t6 -> t7 -> t8 -> Int - ``` - - Now, the inferred type would refer back to their original names. - - ```purs - forall b6 c7 d8. b6 -> c7 -> d8 -> Int - ``` diff --git a/CHANGELOG.d/feature_support_older_glibc.md b/CHANGELOG.d/feature_support_older_glibc.md deleted file mode 100644 index 6e641e6b71..0000000000 --- a/CHANGELOG.d/feature_support_older_glibc.md +++ /dev/null @@ -1,4 +0,0 @@ -* Support Glibc versions >= `2.24` - - Previously, `purs` required a Glibc version greater than or equal to `2.27`. - This requirement is relaxed to support a Glibc version down to `2.24`. diff --git a/CHANGELOG.d/feature_type_level_ints.md b/CHANGELOG.d/feature_type_level_ints.md deleted file mode 100644 index 7a359fb97c..0000000000 --- a/CHANGELOG.d/feature_type_level_ints.md +++ /dev/null @@ -1,5 +0,0 @@ -* Implement native type-level integers - - Added support for type-level integers and compiler-solved operations - such as `Add`, `Mul`, `Compare`, and `ToString`. Type-level integers use the `Int` - type as their kind. diff --git a/CHANGELOG.d/fix_3559.md b/CHANGELOG.d/fix_3559.md deleted file mode 100644 index 5818f5dd23..0000000000 --- a/CHANGELOG.d/fix_3559.md +++ /dev/null @@ -1 +0,0 @@ -* Remove compiler-generated identifiers from type search results diff --git a/CHANGELOG.d/fix_4268.md b/CHANGELOG.d/fix_4268.md deleted file mode 100644 index 74f2df6fb1..0000000000 --- a/CHANGELOG.d/fix_4268.md +++ /dev/null @@ -1,9 +0,0 @@ -* Fix warning suppression for wildcard types - - This bug was triggered by defining recursive partial functions or - recursive bindings that contained wildcards in inner type annotations. - Recursive partial function declarations now no longer cause spurious - wildcard warnings to be emitted, and actual user-written wildcards now - accurately emit warnings if and only if they don't appear within a - binding (recursive or otherwise) with a complete (wildcard-free) type - signature. diff --git a/CHANGELOG.d/internal_document-hspec-accept.md b/CHANGELOG.d/internal_document-hspec-accept.md deleted file mode 100644 index 7c90c240fc..0000000000 --- a/CHANGELOG.d/internal_document-hspec-accept.md +++ /dev/null @@ -1 +0,0 @@ -* Document the `HSPEC_ACCEPT` flag for generating golden files \ No newline at end of file diff --git a/CHANGELOG.d/internal_error-on-non-Main-modules.md b/CHANGELOG.d/internal_error-on-non-Main-modules.md deleted file mode 100644 index 78c52eaf86..0000000000 --- a/CHANGELOG.d/internal_error-on-non-Main-modules.md +++ /dev/null @@ -1 +0,0 @@ -* Fail test if PureScript file(s) don't have a `Main` module \ No newline at end of file diff --git a/CHANGELOG.d/internal_mv-cst-into-src.md b/CHANGELOG.d/internal_mv-cst-into-src.md deleted file mode 100644 index eafcb8b973..0000000000 --- a/CHANGELOG.d/internal_mv-cst-into-src.md +++ /dev/null @@ -1 +0,0 @@ -* Move `lib/purescript-cst` into `src/` \ No newline at end of file diff --git a/CHANGELOG.d/internal_update-ci-windows-to-2019.md b/CHANGELOG.d/internal_update-ci-windows-to-2019.md deleted file mode 100644 index 0779c57594..0000000000 --- a/CHANGELOG.d/internal_update-ci-windows-to-2019.md +++ /dev/null @@ -1 +0,0 @@ -* Update CI to use `windows-2019` since `windows-2016` is deprecated \ No newline at end of file diff --git a/CHANGELOG.d/internal_update-tests-to-released-versions.md b/CHANGELOG.d/internal_update-tests-to-released-versions.md deleted file mode 100644 index 23269e0e9d..0000000000 --- a/CHANGELOG.d/internal_update-tests-to-released-versions.md +++ /dev/null @@ -1 +0,0 @@ -* Update tests and their bower deps to 0.15.0-compatible versions \ No newline at end of file diff --git a/CHANGELOG.d/misc_clarify-point-in-do-notation-error.md b/CHANGELOG.d/misc_clarify-point-in-do-notation-error.md deleted file mode 100644 index 221135666e..0000000000 --- a/CHANGELOG.d/misc_clarify-point-in-do-notation-error.md +++ /dev/null @@ -1,7 +0,0 @@ -* Improve "Unknown value bind" and "Unknown value discard" errors - - The previous error implies that do-notation compiles down to only `bind` or to - only `discard` (depending on whether the symbol not found was `bind` or - `discard` respectively), which is somewhat misleading, especially in the - latter case. Now, the error states correctly that do-notation compiles down to - both functions. diff --git a/CHANGELOG.md b/CHANGELOG.md index b6d59ae79c..75f52f84b5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,291 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.0 + +Breaking changes: + +* Switch from Common JS to ES modules (#4232 by @sigma-andex) + + Previously, Purescript used Common JS for FFI declarations. + + Before, FFI was declared like this... + + ```javascript + const mymodule = require('mymodule') + + exports.myvar = mymodule.myvar + ``` + + ...and will be changed to this... + + ```javascript + import * as M from 'mymodule'; + export const myvar = M.myvar + ``` + ...or using the short version... + + ```javascript + export { myvar } from 'mymodule'; + ``` + +* FFI is annotated with `/* #__PURE__ */` so that bundlers can perform DCE +* The current LTS Node.js version `12` is now the required minimum version + +* Improve apartness checking (#4149 by @rhendric) + + See details in https://github.com/purescript/documentation/blob/master/language/Type-Classes.md#instance-chains + +* Disable type class constraints in FFI (#4240 by @JordanMartinez) + + Previously, one could write FFI like the following: + ```purescript + foreign import foo :: forall a. Show a => a -> String + ``` + + Type class dictionaries are "magically" handled by the compiler. + By including them in the above FFI, one can depend on their representation. + Since the representation can change without notice, this may silently break + code. + + In `v0.14.x`, a warning was emitted if these were used. Now it will fail + to compile. Rather, one should write something like the following + where the members of the type class are passed explicitly to + the FFI function as arguments: + + ```purescript + foo :: forall a. Show a => a -> String + foo val = fooImpl show val + + foreign import fooImpl :: forall a. (a -> String) -> a -> String + ``` + +* Removes deprecated syntax for rows (i.e. `#`) and kinds (i.e. `kind`-keyword) (#4239 by @JordanMartinez) + +* Apply precedence rules to operator sections (#4033 by @rhendric) + + Previously, `(_ * 4 + 1)` would desugar to `\x -> x * (4 + 1)`, even + though `*` has higher precedence than `+`. Conversely, `(3 * 2 + _)` + would not compile, even though `*` has higher precedence than `+`. These + bugs have now been fixed; `(_ * 4 + 1)` is an error, and `(3 * 2 + _)` + desugars to `\x -> 3 * 2 + x`. + + If you have code that relied on the old behavior, add an extra pair of + parentheses around the expression in the section. + +* If FFI parsing succeeds & CommonJS is detected, fail; otherwise, do not error or warn (#4250 by @sigma-andex) + + Previously, the compiler would emit an error if it failed to parse the FFI JavaScript file. + Since the underlying JavaScript parser (i.e. `language-javascript`) fails to parse even + valid JavaScript files, we cannot consider every failed parse to mean invalid JS files. + Fixing the parser would require a lot of effort, so we are planning to remove it instead + in `v0.16.x`. + + If the parse succeeds and a CommonJS module is detected, a compiler error is now emitted. + If the parse fails, we no longer emit a compiler error. While we could emit a warning, + such a warning will quickly become annoying for FFI files that trigger the buggy paths + of `language-javascript`. Moreover, we presume that all will be migrating their code to + ES modules now that CommonJS is being deprecated in the larger JavaScript ecosystem. + +* Warn on ad-hoc non-single-line case expression syntax (#4241 by @JordanMartinez) + + The following code will now produce a compiler warning. + These were originally supported to ease the migration + to the new CST parser. + + ```purescript + -- before: `arg` isn't indented "past" the `Foo arg` binder + case foo of Foo arg -> + arg + -- after + case foo of Foo arg -> + foo + ``` + + Dropping the above syntax make case expressions more similar to how `let` bindings work: + ```purescript + let ok = 1 + let + ok = 1 + let ok = + 1 + let notOk = + 1 + ``` + +* Drop support for browser backend for repl (i.e. `purs repl --port 1234`) (#4255 by @JordanMartinez) + + Running this command will print a link that directs users to use + Try PureScript instead. + +* Remove `purs bundle` (#4255 by @JordanMartinez) + + Users of `purs bundle` should switch to a standalone bundler such as `esbuild`, `webpack` or `parcel`. + +* Lazy initialization for recursive bindings (#4283 by @rhendric) + + This is unlikely to break a working program, but the upshot for users is + that it's now possible to get a run-time error when dereferencing an + identifier in a recursive binding group before it has been initialized, + instead of silently getting an `undefined` value and having that maybe + or maybe not lead to an error somewhere else. + + This change can cause code that relies on tail-call optimization to no + longer compile with that optimization. If you find that code that + previously compiled to a TCO loop no longer does but does include `$lazy` + initializers, please report the issue. + + **Alternate backend maintainers:** for you, this change represents a + clarification of a responsibility shared by all backends. The identifiers + bound in a recursive binding group need to behave as if those identifiers + have call-by-need semantics during the initialization of the entire binding + group. (Initializing the binding group entails ensuring every initializer + has been executed, so after the binding group is initialized, these + identifiers can be considered call-by-value again.) + + If an identifier is needed during its own call-by-need initialization, the + backend must ensure that an explicit run-time error is raised appropriate for + your target platform. This error may be raised at compile time instead if the + backend can determine that such a cycle is inevitable. Returning your + target language's equivalent of JavaScript's `undefined`, as `purs` did in + earlier releases in some cases, is not permitted. + + If your target language natively has call-by-need semantics, you probably + don't have to do anything. If your target language is call-by-value and you + are using PureScript as a library, you can use the function + `Language.PureScript.CoreFn.Laziness.applyLazinessTransform` to your CoreFn + input to satisfy this responsibility; if you do, you will need to do the + following: + + * Translate `InternalIdent RuntimeLazyFactory` and `InternalIdent (Lazy _)` + identifiers to appropriate strings for your backend + * Ensure that any output file that needs it has a reference to a function + named `InternalIdent RuntimeLazyFactory`, with type `forall a. Fn3 String + String (Unit -> a) (Int -> a)`, and with the same semantics as the + following JavaScript (though you should customize the error raised to be + appropriate for your target language): + + ```js + function (name, moduleName, init) { + var state = 0; + var val; + return function (lineNumber) { + if (state === 2) return val; + if (state === 1) throw new ReferenceError(name + " was needed before it finished initializing (module " + moduleName + ", line " + lineNumber + ")", moduleName, lineNumber); + state = 1; + val = init(); + state = 2; + return val; + }; + }; + ``` + + If neither of the previous cases apply to you, you can meet this + responsibility most easily simply by ensuring that all recursive bindings are + lazy. You may instead choose to implement some light analysis to skip + generating lazy bindings in some cases, such as if every initializer in the + binding group is an `Abs`. You also may choose to reimplement + `applyLazinessTransform`, or even develop a more sophisticated laziness + transform for your backend. It is of course your responsibility to ensure + that the result of whatever analysis you do is equivalent to the expected + semantics. + +New features: + +* Implement the Reflectable type class (#4207 by @PureFunctor) + + The `Reflectable` type class is a common interface for reflecting + type-level values down to the term-level. Its instances are + automatically solved by the compiler, and it allows `Symbol`, `Int`, + `Boolean`, and `Ordering` kinded types to be reflected to their + term-level representations. + +* Implement native type-level integers (#4207 and #4267 by @PureFunctor and @JordanMartinez) + + Added support for type-level integers and compiler-solved operations + such as `Add`, `Mul`, `Compare`, and `ToString`. Type-level integers use the `Int` + type as their kind. + +* Print compilation progress on the command line (#4258 by @PureFunctor) + + This feature makes it so `purs compile` and `purs docs` now show + compilation progress on the command line. Example output: + + ```purs + [ 1 of 59] Compiling Type.Proxy + [ 2 of 59] Compiling Type.Data.RowList + ... + [58 of 59] Compiling Effect.Class.Console + [59 of 59] Compiling Test.Main + ``` + +* Restore names of quantified variables during generalization (#4257 by @PureFunctor) + + This makes the compiler aware of the names of quantified variables + instantiated into unification variables, such that when the latter + is generalized, semantic information is restored. For example: + + ```purs + addNumberSuffix :: forall a b c d. a -> b -> c -> d -> a + addNumberSuffix a _ _ _ = a + + addNumberSuffix' = addNumberSuffix 0 + ``` + + Previously, inferring top-level declarations without type signatures + would use `t` suffixed with an integer for type variables. + + ```purs + forall t6 t7 t8. t6 -> t7 -> t8 -> Int + ``` + + Now, the inferred type would refer back to their original names. + + ```purs + forall b6 c7 d8. b6 -> c7 -> d8 -> Int + ``` + +* Support Glibc versions >= `2.24` (#4228 by @sd-yip) + + Previously, `purs` required a Glibc version greater than or equal to `2.27`. + This requirement is relaxed to support a Glibc version down to `2.24`. + +Bugfixes: + +* Fix warning suppression for wildcard types (#4269 by @rhendric) + + This bug was triggered by defining recursive partial functions or + recursive bindings that contained wildcards in inner type annotations. + Recursive partial function declarations now no longer cause spurious + wildcard warnings to be emitted, and actual user-written wildcards now + accurately emit warnings if and only if they don't appear within a + binding (recursive or otherwise) with a complete (wildcard-free) type + signature. + +* Remove compiler-generated identifiers from type search results (#4260 by @PureFunctor) + +Other improvements: + +* Improve "Unknown value bind" and "Unknown value discard" errors (#4272 by @mhmdanas) + + The previous error implies that do-notation compiles down to only `bind` or to + only `discard` (depending on whether the symbol not found was `bind` or + `discard` respectively), which is somewhat misleading, especially in the + latter case. Now, the error states correctly that do-notation compiles down to + both functions. + +Internal: + +* Document the `HSPEC_ACCEPT` flag for generating golden files (#4243 by @JordanMartinez) + +* Fail test if PureScript file(s) don't have a `Main` module (#4243 by @JordanMartinez) + +* Update CI to use `windows-2019` since `windows-2016` is deprecated (#4248 by @JordanMartinez) + +* Move `lib/purescript-cst` into `src/` (#4290 by @JordanMartinez) + +* Update tests and their bower deps to 0.15.0-compatible versions (#4300 by @JordanMartinez) + ## 0.14.7 New features: diff --git a/LICENSE b/LICENSE index 76df930fdf..89c19ef2b4 100644 --- a/LICENSE +++ b/LICENSE @@ -16,20 +16,15 @@ PureScript uses the following Haskell library packages. Their license files foll Cabal Glob - HUnit - SHA StateVar + adjunctions aeson aeson-better-errors aeson-pretty alex ansi-terminal ansi-wl-pprint - appar array - asn1-encoding - asn1-parse - asn1-types assoc async attoparsec @@ -38,7 +33,6 @@ PureScript uses the following Haskell library packages. Their license files foll base-compat base-compat-batteries base-orphans - base64-bytestring basement bifunctors binary @@ -47,10 +41,7 @@ PureScript uses the following Haskell library packages. Their license files foll blaze-markup bower-json boxes - bsb-http-chunked - byteorder bytestring - bytestring-builder cabal-doctest call-stack case-insensitive @@ -64,7 +55,6 @@ PureScript uses the following Haskell library packages. Their license files foll constraints containers contravariant - cookie cryptonite css-text data-default @@ -81,11 +71,11 @@ PureScript uses the following Haskell library packages. Their license files foll easy-file edit-distance enclosed-exceptions - entropy exceptions fast-logger file-embed filepath + free fsnotify ghc-prim half @@ -93,15 +83,15 @@ PureScript uses the following Haskell library packages. Their license files foll hashable haskeline hinotify - hourglass - http-date http-types - http2 indexed-traversable + indexed-traversable-instances integer-gmp integer-logarithms - iproute + invariant + kan-extensions language-javascript + lens lifted-async lifted-base memory @@ -110,30 +100,29 @@ PureScript uses the following Haskell library packages. Their license files foll microlens-mtl microlens-platform microlens-th - mime-types monad-control monad-logger monad-loops mono-traversable + monoidal-containers mtl mtl-compat network - network-byte-order network-uri + newtype old-locale old-time optparse-applicative parallel parsec pattern-arrows - pem pretty primitive process + profunctors protolude - psqueues - purescript-cst random + reflection regex-base regex-tdfa resourcet @@ -144,7 +133,6 @@ PureScript uses the following Haskell library packages. Their license files foll semigroups serialise shelly - simple-sendfile sourcemap split splitmix @@ -163,7 +151,6 @@ PureScript uses the following Haskell library packages. Their license files foll these time time-compat - time-manager transformers transformers-base transformers-compat @@ -173,24 +160,14 @@ PureScript uses the following Haskell library packages. Their license files foll unix unix-compat unix-time - unliftio unliftio-core unordered-containers utf8-string uuid-types - vault vector vector-algorithms void - wai - wai-app-static - wai-extra - wai-logger - wai-websockets - warp - websockets - word8 - x509 + witherable xss-sanitize zlib @@ -259,70 +236,6 @@ Glob LICENSE file: OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -HUnit LICENSE file: - - HUnit is Copyright (c) Dean Herington, 2002, all rights reserved, - and is distributed as free software under the following license. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - - Redistributions of source code must retain the above copyright - notice, this list of conditions, and the following disclaimer. - - - Redistributions in binary form must reproduce the above copyright - notice, this list of conditions, and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - - The names of the copyright holders may not be used to endorse or - promote products derived from this software without specific prior - written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY - EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR - PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE - LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR - BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, - WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE - OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN - IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -SHA LICENSE file: - - Copyright (c) 2008, Galois, Inc. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - * Neither the name of the Galois, Inc. nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS - FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - StateVar LICENSE file: Copyright (c) 2014-2015, Edward Kmett @@ -355,6 +268,35 @@ StateVar LICENSE file: ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +adjunctions LICENSE file: + + Copyright 2011-2014 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + aeson LICENSE file: Copyright (c) 2011, MailRank, Inc. 2014-2021 Aeson project contributors @@ -530,38 +472,6 @@ ansi-wl-pprint LICENSE file: or otherwise) arising in any way out of the use of this software, even if advised of the possibility of such damage. -appar LICENSE file: - - Copyright (c) 2009, IIJ Innovation Institute Inc. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - * Neither the name of the copyright holders nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS - FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - array LICENSE file: This library (libraries/base) is derived from code from several @@ -649,96 +559,6 @@ array LICENSE file: ----------------------------------------------------------------------------- -asn1-encoding LICENSE file: - - Copyright (c) 2010-2013 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - -asn1-parse LICENSE file: - - Copyright (c) 2010-2013 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - -asn1-types LICENSE file: - - Copyright (c) 2010-2013 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - assoc LICENSE file: Copyright (c) 2017, Oleg Grenrus @@ -1014,39 +834,6 @@ base-orphans LICENSE file: TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -base64-bytestring LICENSE file: - - Copyright (c) 2010 Bryan O'Sullivan - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS - OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - basement LICENSE file: Copyright (c) 2015-2017 Vincent Hanquez @@ -1292,137 +1079,38 @@ boxes LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -bsb-http-chunked LICENSE file: +bytestring LICENSE file: - Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 2011 + Copyright (c) Don Stewart 2005-2009 + (c) Duncan Coutts 2006-2015 + (c) David Roundy 2003-2005 + (c) Simon Meier 2010-2011 All rights reserved. Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Jasper Van der Jeugt nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -byteorder LICENSE file: - - Copyright 2009, Antoine Latter - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of the author nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -bytestring LICENSE file: - - Copyright (c) Don Stewart 2005-2009 - (c) Duncan Coutts 2006-2015 - (c) David Roundy 2003-2005 - (c) Simon Meier 2010-2011 - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - -bytestring-builder LICENSE file: - - Copyright Jasper Van der Jeugt 2010, Simon Meier 2010-2013 - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Jasper Van der Jeugt nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. cabal-doctest LICENSE file: @@ -1812,29 +1500,6 @@ contravariant LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -cookie LICENSE file: - - Copyright (c) 2010 Michael Snoyman, http://www.yesodweb.com/ - - Permission is hereby granted, free of charge, to any person obtaining - a copy of this software and associated documentation files (the - "Software"), to deal in the Software without restriction, including - without limitation the rights to use, copy, modify, merge, publish, - distribute, sublicense, and/or sell copies of the Software, and to - permit persons to whom the Software is furnished to do so, subject to - the following conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE - LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION - OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - cryptonite LICENSE file: Copyright (c) 2006-2015 Vincent Hanquez @@ -2328,39 +1993,6 @@ enclosed-exceptions LICENSE file: OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -entropy LICENSE file: - - Copyright (c) Thomas DuBuisson - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS - OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - exceptions LICENSE file: Copyright 2013-2015 Edward Kmett @@ -2488,6 +2120,39 @@ filepath LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +free LICENSE file: + + Copyright 2008-2013 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + fsnotify LICENSE file: Copyright (c) 2012, Mark Dittmer @@ -2743,68 +2408,6 @@ hinotify LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -hourglass LICENSE file: - - Copyright (c) 2014 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - -http-date LICENSE file: - - Copyright (c) 2009, IIJ Innovation Institute Inc. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - * Neither the name of the copyright holders nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS - FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - http-types LICENSE file: Copyright (c) 2011, Aristid Breitkreuz @@ -2839,39 +2442,36 @@ http-types LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -http2 LICENSE file: +indexed-traversable LICENSE file: + + Copyright 2012-2016 Edward Kmett - Copyright (c) 2013, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - * Neither the name of the copyright holders nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS - FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -indexed-traversable LICENSE file: +indexed-traversable-instances LICENSE file: Copyright 2012-2016 Edward Kmett @@ -2952,35 +2552,62 @@ integer-logarithms LICENSE file: LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -iproute LICENSE file: +invariant LICENSE file: + + Copyright (c) 2012-2017, University of Kansas + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, + OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +kan-extensions LICENSE file: + + Copyright 2008-2016 Edward Kmett - Copyright (c) 2009, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - * Neither the name of the copyright holders nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS - FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. @@ -3017,6 +2644,35 @@ language-javascript LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +lens LICENSE file: + + Copyright 2012-2016 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + lifted-async LICENSE file: Copyright (c) 2012-2017, Mitsutoshi Aoe @@ -3288,29 +2944,6 @@ microlens-th LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -mime-types LICENSE file: - - Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ - - Permission is hereby granted, free of charge, to any person obtaining - a copy of this software and associated documentation files (the - "Software"), to deal in the Software without restriction, including - without limitation the rights to use, copy, modify, merge, publish, - distribute, sublicense, and/or sell copies of the Software, and to - permit persons to whom the Software is furnished to do so, subject to - the following conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE - LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION - OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - monad-control LICENSE file: Copyright © 2010, Bas van Dijk, Anders Kaseorg @@ -3389,6 +3022,39 @@ mono-traversable LICENSE file: OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +monoidal-containers LICENSE file: + + Copyright (c) 2015, Ben Gamari + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ben Gamari nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + mtl LICENSE file: The Glasgow Haskell Compiler License @@ -3488,39 +3154,6 @@ network LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -network-byte-order LICENSE file: - - Copyright (c) 2017, Kazu Yamamoto - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Kazu Yamamoto nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - network-uri LICENSE file: Copyright (c) 2002-2010, The University Court of the University of Glasgow. @@ -3553,6 +3186,40 @@ network-uri LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +newtype LICENSE file: + + Copyright (c) 2011, Darius Jahandarie + 2019, Herbert Valerio Riedel + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Darius Jahandarie nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + old-locale LICENSE file: This library (libraries/base) is derived from code from two @@ -3807,47 +3474,17 @@ pattern-arrows LICENSE file: IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -pem LICENSE file: +pretty LICENSE file: + + This library (libraries/pretty) is derived from code from + the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below). + + ----------------------------------------------------------------------------- - Copyright (c) 2010-2018 Vincent Hanquez + The Glasgow Haskell Compiler License - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - -pretty LICENSE file: - - This library (libraries/pretty) is derived from code from - the GHC project which is largely (c) The University of - Glasgow, and distributable under a BSD-style license (see below). - - ----------------------------------------------------------------------------- - - The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without @@ -3978,6 +3615,39 @@ process LICENSE file: ----------------------------------------------------------------------------- +profunctors LICENSE file: + + Copyright 2011-2015 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + protolude LICENSE file: Copyright (c) 2016-2020, Stephen Diehl @@ -4000,56 +3670,6 @@ protolude LICENSE file: FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -psqueues LICENSE file: - - The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - - Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - - - Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - - - Neither name of the University nor the names of its contributors may be - used to endorse or promote products derived from this software without - specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF - GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - DAMAGE. - -purescript-cst LICENSE file: - - Copyright (c) 2013-17 Phil Freeman, (c) 2014-2017 Gary Burgess, and other - contributors - All rights reserved. - - Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - - 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - - 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - random LICENSE file: This library (libraries/base) is derived from code from two @@ -4116,6 +3736,40 @@ random LICENSE file: ----------------------------------------------------------------------------- +reflection LICENSE file: + + Copyright (c) 2009-2013 Edward Kmett + Copyright (c) 2004 Oleg Kiselyov and Chung-chieh Shan + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Edward Kmett nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + regex-base LICENSE file: This modile is under this "3 clause" BSD license: @@ -4402,38 +4056,6 @@ shelly LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -simple-sendfile LICENSE file: - - Copyright (c) 2009, IIJ Innovation Institute Inc. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - * Neither the name of the copyright holders nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS - FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - sourcemap LICENSE file: Copyright (c) 2012, Chris Done @@ -5033,29 +4655,6 @@ time-compat LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -time-manager LICENSE file: - - Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ - - Permission is hereby granted, free of charge, to any person obtaining - a copy of this software and associated documentation files (the - "Software"), to deal in the Software without restriction, including - without limitation the rights to use, copy, modify, merge, publish, - distribute, sublicense, and/or sell copies of the Software, and to - permit persons to whom the Software is furnished to do so, subject to - the following conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE - LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION - OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - transformers LICENSE file: The Glasgow Haskell Compiler License @@ -5340,29 +4939,6 @@ unix-time LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -unliftio LICENSE file: - - Copyright (c) 2017 FP Complete - - Permission is hereby granted, free of charge, to any person obtaining - a copy of this software and associated documentation files (the - "Software"), to deal in the Software without restriction, including - without limitation the rights to use, copy, modify, merge, publish, - distribute, sublicense, and/or sell copies of the Software, and to - permit persons to whom the Software is furnished to do so, subject to - the following conditions: - - The above copyright notice and this permission notice shall be included - in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY - CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, - TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE - SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - unliftio-core LICENSE file: Copyright (c) 2017 FP Complete @@ -5477,39 +5053,6 @@ uuid-types LICENSE file: NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -vault LICENSE file: - - Copyright (c)2011, Heinrich Apfelmus - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Heinrich Apfelmus nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - vector LICENSE file: Copyright (c) 2008-2012, Roman Leshchinskiy @@ -5645,156 +5188,9 @@ void LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -wai LICENSE file: - - Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ - - Permission is hereby granted, free of charge, to any person obtaining - a copy of this software and associated documentation files (the - "Software"), to deal in the Software without restriction, including - without limitation the rights to use, copy, modify, merge, publish, - distribute, sublicense, and/or sell copies of the Software, and to - permit persons to whom the Software is furnished to do so, subject to - the following conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE - LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION - OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -wai-app-static LICENSE file: - - Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ - - Permission is hereby granted, free of charge, to any person obtaining - a copy of this software and associated documentation files (the - "Software"), to deal in the Software without restriction, including - without limitation the rights to use, copy, modify, merge, publish, - distribute, sublicense, and/or sell copies of the Software, and to - permit persons to whom the Software is furnished to do so, subject to - the following conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE - LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION - OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -wai-extra LICENSE file: - - Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ - - Permission is hereby granted, free of charge, to any person obtaining - a copy of this software and associated documentation files (the - "Software"), to deal in the Software without restriction, including - without limitation the rights to use, copy, modify, merge, publish, - distribute, sublicense, and/or sell copies of the Software, and to - permit persons to whom the Software is furnished to do so, subject to - the following conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE - LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION - OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -wai-logger LICENSE file: - - Copyright (c) 2009, IIJ Innovation Institute Inc. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - * Neither the name of the copyright holders nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS - FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - -wai-websockets LICENSE file: - - Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ - - Permission is hereby granted, free of charge, to any person obtaining - a copy of this software and associated documentation files (the - "Software"), to deal in the Software without restriction, including - without limitation the rights to use, copy, modify, merge, publish, - distribute, sublicense, and/or sell copies of the Software, and to - permit persons to whom the Software is furnished to do so, subject to - the following conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. +witherable LICENSE file: - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE - LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION - OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -warp LICENSE file: - - Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ - - Permission is hereby granted, free of charge, to any person obtaining - a copy of this software and associated documentation files (the - "Software"), to deal in the Software without restriction, including - without limitation the rights to use, copy, modify, merge, publish, - distribute, sublicense, and/or sell copies of the Software, and to - permit persons to whom the Software is furnished to do so, subject to - the following conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE - LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION - OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -websockets LICENSE file: - - Copyright Jasper Van der Jeugt, 2011 + Copyright (c) 2014, Fumiaki Kinoshita All rights reserved. @@ -5809,7 +5205,7 @@ websockets LICENSE file: disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Siniša Biđin nor the names of other + * Neither the name of Fumiaki Kinoshita nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. @@ -5825,68 +5221,6 @@ websockets LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -word8 LICENSE file: - - Copyright (c) 2012, IIJ Innovation Institute Inc. - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - * Neither the name of the copyright holders nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS - FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - -x509 LICENSE file: - - Copyright (c) 2010-2013 Vincent Hanquez - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. - xss-sanitize LICENSE file: The following license covers this documentation, and the source code, except diff --git a/app/Version.hs b/app/Version.hs index ffdf5999fe..9c2f3556be 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -17,7 +17,7 @@ import qualified Development.GitRev as GitRev -- prerelease identifier here (if any). When releasing a proper version, simply -- set this to an empty string. prerelease :: String -prerelease = "-alpha-07" +prerelease = "" versionString :: String versionString = showVersion Paths.version ++ prerelease ++ extra diff --git a/npm-package/package.json b/npm-package/package.json index f76fa51262..d3dab36ff1 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.0-alpha-07", + "version": "0.15.0", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.0-alpha-07", + "postinstall": "install-purescript --purs-ver=0.15.0", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index 797f456f55..caf6d12bc6 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- note: When updating the prerelease identifier, update it in app/Version.hs too! -version: 0.15.0-alpha-07 +version: 0.15.0 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 53a754b3386164872ade59d9493d9dd36db927ff Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 30 Apr 2022 09:54:19 -0400 Subject: [PATCH 1450/1580] ci/build-package-set.sh: exclude metadata package (#4304) `metadata` is a dummy package, not an actual part of the package set. However, if asked, spago will try to install it anyway, and complain if a matching version doesn't exist. When developing a new version of PureScript, there might be a delay before the package set maintainers get around to ensuring such a version exists. But there's no need to wait for that if we simply don't install that package. --- ci/build-package-set.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ci/build-package-set.sh b/ci/build-package-set.sh index a1fc41734f..12a6fcb34c 100755 --- a/ci/build-package-set.sh +++ b/ci/build-package-set.sh @@ -26,7 +26,7 @@ spago upgrade-set # Override the `metadata` package's version to match `purs` version # so that `spago build` actually works sed -i'' "\$c in upstream with metadata.version = \"v$(purs --version | { read v z && echo $v; })\"" packages.dhall -spago install $(spago ls packages | while read name z; do echo $name; done) +spago install $(spago ls packages | while read name z; do if [[ $name != metadata ]]; then echo $name; fi; done) echo ::endgroup:: echo ::group::Compile package set From 32a92ed5541d6b6ffd0065386603f2d6500bc7bf Mon Sep 17 00:00:00 2001 From: Nick Date: Tue, 3 May 2022 01:18:08 +1200 Subject: [PATCH 1451/1580] Fix broken link to 0.15 migration documentation (#4305) * Fix broken link to 0.15 migration documentation * Update contributors --- CONTRIBUTORS.md | 1 + app/Command/Bundle.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 8b4cceee24..43175a9aa6 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -86,6 +86,7 @@ If you would prefer to use different terms, please use the section below instead | [@mrhania](https://github.com/mrhania) | Łukasz Hanuszczak | [MIT license](http://opensource.org/licenses/MIT) | | [@natefaubion](https://github.com/natefaubion) | Nathan Faubion | [MIT license](http://opensource.org/licenses/MIT) | | [@ncaq](https://github.com/ncaq) | ncaq | [MIT license](http://opensource.org/licenses/MIT) | +| [@NickMolloy](https://github.com/NickMolloy) | Nick Molloy | [MIT license](http://opensource.org/licenses/MIT) | | [@nicodelpiano](https://github.com/nicodelpiano) | Nicolas Del Piano | [MIT license](http://opensource.org/licenses/MIT) | | [@noraesae](https://github.com/noraesae) | Hyunje Jun | [MIT license](http://opensource.org/licenses/MIT) | | [@nullobject](https://github.com/nullobject) | Josh Bassett | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/app/Command/Bundle.hs b/app/Command/Bundle.hs index 0d01c04b68..266e91a708 100644 --- a/app/Command/Bundle.hs +++ b/app/Command/Bundle.hs @@ -11,7 +11,7 @@ app :: IO () app = do hPutStrLn stderr $ unlines [ "'purs bundle' was removed in the v0.15.0 release." - , "See https://www.github.com/purescript/documentation/migration-guides/0.15-Migration-Guide.md " + , "See https://github.com/purescript/documentation/blob/master/migration-guides/0.15-Migration-Guide.md" , "for more information and bundler alternatives." ] exitFailure From b72ac9d85bd111b11618f8f17b5edae26bd75903 Mon Sep 17 00:00:00 2001 From: Fyodor Soikin Date: Fri, 6 May 2022 22:58:46 -0400 Subject: [PATCH 1452/1580] Ignore type wildcards in binders when under a fully-typed declaration (#4309) --- ...ix_issue-4308-type-wildcards-in-binders.md | 13 +++++ src/Language/PureScript/Linter/Wildcards.hs | 9 +++- tests/purs/warning/4308.out | 49 +++++++++++++++++++ tests/purs/warning/4308.purs | 14 ++++++ 4 files changed, 84 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/fix_issue-4308-type-wildcards-in-binders.md create mode 100644 tests/purs/warning/4308.out create mode 100644 tests/purs/warning/4308.purs diff --git a/CHANGELOG.d/fix_issue-4308-type-wildcards-in-binders.md b/CHANGELOG.d/fix_issue-4308-type-wildcards-in-binders.md new file mode 100644 index 0000000000..f7d77f07e6 --- /dev/null +++ b/CHANGELOG.d/fix_issue-4308-type-wildcards-in-binders.md @@ -0,0 +1,13 @@ +* Do not emit warnings about type wildcards used in binders (patterns). + + Type wildcards in the following examples no longer trigger a warning: + + ``` + f :: Int + f = 42 # \(x :: _) -> x + + g :: Maybe Int + g = do + x :: _ <- getX + pure $ x + 5 + ``` diff --git a/src/Language/PureScript/Linter/Wildcards.hs b/src/Language/PureScript/Linter/Wildcards.hs index 0a614e379e..06f1ddf6fb 100644 --- a/src/Language/PureScript/Linter/Wildcards.hs +++ b/src/Language/PureScript/Linter/Wildcards.hs @@ -22,13 +22,20 @@ import Language.PureScript.Types ignoreWildcardsUnderCompleteTypeSignatures :: Declaration -> Declaration ignoreWildcardsUnderCompleteTypeSignatures = onDecl where - (onDecl, _, _, _, _) = everywhereWithContextOnValues False (,) handleExpr (,) (,) (,) + (onDecl, _, _, _, _) = everywhereWithContextOnValues False (,) handleExpr handleBinder (,) (,) + handleExpr isCovered = \case tv@(TypedValue chk v ty) | isCovered -> (True, TypedValue chk v $ ignoreWildcards ty) | otherwise -> (isComplete ty, tv) other -> (isCovered, other) + handleBinder isCovered = \case + tb@(TypedBinder ty b) + | isCovered -> (True, TypedBinder (ignoreWildcards ty) b) + | otherwise -> (isComplete ty, tb) + other -> (isCovered, other) + ignoreWildcards :: Type a -> Type a ignoreWildcards = everywhereOnTypes $ \case TypeWildcard a UnnamedWildcard -> TypeWildcard a IgnoredWildcard diff --git a/tests/purs/warning/4308.out b/tests/purs/warning/4308.out new file mode 100644 index 0000000000..37057ac6fe --- /dev/null +++ b/tests/purs/warning/4308.out @@ -0,0 +1,49 @@ +Warning 1 of 3: + + in module Main + at tests/purs/warning/4308.purs:13:6 - 13:7 (line 13, column 6 - line 13, column 7) + + Wildcard type definition has the inferred type +   +  Int +   + + in value declaration g + + See https://github.com/purescript/documentation/blob/master/errors/WildcardInferredType.md for more information, + or to contribute content related to this warning. + +Warning 2 of 3: + + in module Main + at tests/purs/warning/4308.purs:14:13 - 14:14 (line 14, column 13 - line 14, column 14) + + Wildcard type definition has the inferred type +   +  Int +   + + in value declaration g + + See https://github.com/purescript/documentation/blob/master/errors/WildcardInferredType.md for more information, + or to contribute content related to this warning. + +Warning 3 of 3: + + in module Main + at tests/purs/warning/4308.purs:14:25 - 14:26 (line 14, column 25 - line 14, column 26) + + Wildcard type definition has the inferred type +   +  Int +   + in the following context: + + y :: Int + + + in value declaration g + + See https://github.com/purescript/documentation/blob/master/errors/WildcardInferredType.md for more information, + or to contribute content related to this warning. + diff --git a/tests/purs/warning/4308.purs b/tests/purs/warning/4308.purs new file mode 100644 index 0000000000..4013fa6bc5 --- /dev/null +++ b/tests/purs/warning/4308.purs @@ -0,0 +1,14 @@ +-- @shouldWarnWith WildcardInferredType +-- @shouldWarnWith WildcardInferredType +-- @shouldWarnWith WildcardInferredType +module Main where + +-- No warnings expected here because `f` has full type signature +f :: Int +f = (\(y :: _) -> (y :: _)) 42 + +-- All three warnings expected here because the type signature of `g` has a +-- wildcard in it. One warning for the top-level signature wildcard, one for the +-- wildcard in the lambda parameter pattern, and one in the lambda body. +g :: _ +g = (\(y :: _) -> (y :: _)) 42 From 012b9040d7b31d31e1f5df191e8a01bfeb230de9 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Fri, 6 May 2022 23:28:29 -0400 Subject: [PATCH 1453/1580] Fix issue with unnamed instances using type operators (#4311) --- CHANGELOG.d/fix_4310.md | 1 + src/Language/PureScript/CodeGen/JS.hs | 2 +- tests/purs/passing/4310.purs | 8 ++++++++ tests/purs/passing/4310/Lib.purs | 17 +++++++++++++++++ 4 files changed, 27 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/fix_4310.md create mode 100644 tests/purs/passing/4310.purs create mode 100644 tests/purs/passing/4310/Lib.purs diff --git a/CHANGELOG.d/fix_4310.md b/CHANGELOG.d/fix_4310.md new file mode 100644 index 0000000000..62b2520c9e --- /dev/null +++ b/CHANGELOG.d/fix_4310.md @@ -0,0 +1 @@ +* Fix issue with unnamed instances using type operators diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 1564c7cd75..07019811bb 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -307,7 +307,7 @@ moduleBindToJs mn = bindToJs moduleAccessor InternalIdent{} = internalError "InternalIdent in moduleAccessor" moduleAccessorString :: Text -> AST -> AST - moduleAccessorString = accessorString . mkString . T.replace "'" "$prime" + moduleAccessorString = accessorString . mkString . T.concatMap identCharToText accessorString :: PSString -> AST -> AST accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop) diff --git a/tests/purs/passing/4310.purs b/tests/purs/passing/4310.purs new file mode 100644 index 0000000000..9bbeda84d6 --- /dev/null +++ b/tests/purs/passing/4310.purs @@ -0,0 +1,8 @@ +module Main where + +import Effect.Console (log) +import Lib + +main = do + let q = runTest (4 /\ 4) + log "Done" diff --git a/tests/purs/passing/4310/Lib.purs b/tests/purs/passing/4310/Lib.purs new file mode 100644 index 0000000000..1ccf3afd49 --- /dev/null +++ b/tests/purs/passing/4310/Lib.purs @@ -0,0 +1,17 @@ +module Lib where + +import Prelude + +data Tuple a b = Tuple a b + +infixr 6 Tuple as /\ +infixr 6 type Tuple as /\ + +class Test a where + runTest :: a -> String + +instance Test Int where + runTest _ = "4" + +instance (Test a, Test b) => Test (a /\ b) where + runTest (a /\ b) = runTest a <> runTest b From 1f486e6f2b6a216acda7d5c964b625e548003509 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sat, 7 May 2022 08:57:48 -0500 Subject: [PATCH 1454/1580] Fix Prim.Int class Compare docs (#4313) --- CHANGELOG.d/bug_fix-prim-int-compare-docs.md | 1 + src/Language/PureScript/Environment.hs | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) create mode 100644 CHANGELOG.d/bug_fix-prim-int-compare-docs.md diff --git a/CHANGELOG.d/bug_fix-prim-int-compare-docs.md b/CHANGELOG.d/bug_fix-prim-int-compare-docs.md new file mode 100644 index 0000000000..379e54542d --- /dev/null +++ b/CHANGELOG.d/bug_fix-prim-int-compare-docs.md @@ -0,0 +1 @@ +* Fix incorrect `Prim.Int (class Compare)` docs: `Int` & `Ordering`, not `Symbol` diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 67ee6a2df9..aa907a30a6 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -581,8 +581,8 @@ primIntClasses = -- class Compare (left :: Int) (right :: Int) (ordering :: Ordering) | left right -> ordering , (primSubName C.moduleInt "Compare", makeTypeClassData [ ("left", Just tyInt) - , ("right", Just kindSymbol) - , ("ordering", Just kindSymbol) + , ("right", Just tyInt) + , ("ordering", Just kindOrdering) ] [] [] [ FunctionalDependency [0, 1] [2] ] True) From fdcae630acc07428f90b039d5b954a2b8e9a68bf Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Tue, 10 May 2022 21:16:27 -0400 Subject: [PATCH 1455/1580] Check for partially applied type synonyms in kinds and constructors (#4169) This check doesn't prevent any programs from compiling; it just makes sure that a more specific PartiallyAppliedSynonym error is raised instead of a KindsDoNotUnify error, which could be interpreted as implying that a partially applied synonym has a valid kind and would be supported elsewhere if that kind is expected. --- ...feature_partially-applied-synonym-check.md | 7 +++ src/Language/PureScript/TypeChecker/Kinds.hs | 47 +++++++++++++++---- tests/purs/failing/PASTrumpsKDNU1.out | 17 +++++++ tests/purs/failing/PASTrumpsKDNU1.purs | 15 ++++++ tests/purs/failing/PASTrumpsKDNU2.out | 15 ++++++ tests/purs/failing/PASTrumpsKDNU2.purs | 10 ++++ tests/purs/failing/PASTrumpsKDNU3.out | 16 +++++++ tests/purs/failing/PASTrumpsKDNU3.purs | 10 ++++ tests/purs/failing/PASTrumpsKDNU4.out | 14 ++++++ tests/purs/failing/PASTrumpsKDNU4.purs | 6 +++ tests/purs/failing/PASTrumpsKDNU5.out | 14 ++++++ tests/purs/failing/PASTrumpsKDNU5.purs | 6 +++ tests/purs/failing/PASTrumpsKDNU6.out | 14 ++++++ tests/purs/failing/PASTrumpsKDNU6.purs | 6 +++ tests/purs/failing/PASTrumpsKDNU7.out | 14 ++++++ tests/purs/failing/PASTrumpsKDNU7.purs | 6 +++ tests/purs/failing/RowConstructors2.out | 12 ++--- tests/purs/failing/RowConstructors2.purs | 2 +- tests/purs/failing/TypeSynonyms10.out | 21 +++++++++ tests/purs/failing/TypeSynonyms10.purs | 8 ++++ tests/purs/failing/TypeSynonyms8.out | 14 ++++++ tests/purs/failing/TypeSynonyms8.purs | 6 +++ tests/purs/failing/TypeSynonyms9.out | 15 ++++++ tests/purs/failing/TypeSynonyms9.purs | 7 +++ tests/purs/passing/TypeSynonyms.purs | 2 + 25 files changed, 285 insertions(+), 19 deletions(-) create mode 100644 CHANGELOG.d/feature_partially-applied-synonym-check.md create mode 100644 tests/purs/failing/PASTrumpsKDNU1.out create mode 100644 tests/purs/failing/PASTrumpsKDNU1.purs create mode 100644 tests/purs/failing/PASTrumpsKDNU2.out create mode 100644 tests/purs/failing/PASTrumpsKDNU2.purs create mode 100644 tests/purs/failing/PASTrumpsKDNU3.out create mode 100644 tests/purs/failing/PASTrumpsKDNU3.purs create mode 100644 tests/purs/failing/PASTrumpsKDNU4.out create mode 100644 tests/purs/failing/PASTrumpsKDNU4.purs create mode 100644 tests/purs/failing/PASTrumpsKDNU5.out create mode 100644 tests/purs/failing/PASTrumpsKDNU5.purs create mode 100644 tests/purs/failing/PASTrumpsKDNU6.out create mode 100644 tests/purs/failing/PASTrumpsKDNU6.purs create mode 100644 tests/purs/failing/PASTrumpsKDNU7.out create mode 100644 tests/purs/failing/PASTrumpsKDNU7.purs create mode 100644 tests/purs/failing/TypeSynonyms10.out create mode 100644 tests/purs/failing/TypeSynonyms10.purs create mode 100644 tests/purs/failing/TypeSynonyms8.out create mode 100644 tests/purs/failing/TypeSynonyms8.purs create mode 100644 tests/purs/failing/TypeSynonyms9.out create mode 100644 tests/purs/failing/TypeSynonyms9.purs diff --git a/CHANGELOG.d/feature_partially-applied-synonym-check.md b/CHANGELOG.d/feature_partially-applied-synonym-check.md new file mode 100644 index 0000000000..56c4d3ac36 --- /dev/null +++ b/CHANGELOG.d/feature_partially-applied-synonym-check.md @@ -0,0 +1,7 @@ +* Check for partially applied syns in kinds, ctors + + This check doesn't prevent any programs from compiling; it just makes + sure that a more specific PartiallyAppliedSynonym error is raised + instead of a KindsDoNotUnify error, which could be interpreted as + implying that a partially applied synonym has a valid kind and would be + supported elsewhere if that kind is expected. diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 2f46ab8642..d433181743 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -180,7 +180,7 @@ inferKind = \tyToInfer -> throwError . errorMessage' (fst ann) . UnknownName . fmap TyClassName $ v Just _ -> checkConstraint con - ty' <- checkKind ty E.kindType + ty' <- checkIsSaturatedType ty con'' <- applyConstraint con' pure (ConstrainedType ann' con'' ty', E.kindType $> ann') ty@(TypeLevelString ann _) -> @@ -228,10 +228,10 @@ inferKind = \tyToInfer -> ForAll ann arg mbKind ty sc -> do moduleName <- unsafeCheckCurrentModule kind <- case mbKind of - Just k -> replaceAllTypeSynonyms =<< checkKind k E.kindType + Just k -> replaceAllTypeSynonyms =<< checkIsSaturatedType k Nothing -> freshKind (fst ann) (ty', unks) <- bindLocalTypeVariables moduleName [(ProperName arg, kind)] $ do - ty' <- apply =<< checkKind ty E.kindType + ty' <- apply =<< checkIsSaturatedType ty unks <- unknownsWithKinds . IS.toList $ unknowns ty' pure (ty', unks) for_ unks . uncurry $ addUnsolved Nothing @@ -249,7 +249,8 @@ inferAppKind -> m (SourceType, SourceType) inferAppKind ann (fn, fnKind) arg = case fnKind of TypeApp _ (TypeApp _ arrKind argKind) resKind | eqType arrKind E.tyFunction -> do - arg' <- checkKind arg argKind + expandSynonyms <- requiresSynonymsToExpand fn + arg' <- checkKind' expandSynonyms arg argKind (TypeApp ann fn arg',) <$> apply resKind TUnknown _ u -> do (lvl, _) <- lookupUnsolved u @@ -266,6 +267,12 @@ inferAppKind ann (fn, fnKind) arg = case fnKind of inferAppKind ann (KindApp ann fn (TUnknown ann u), replaceTypeVars a (TUnknown ann u) ty) arg _ -> cannotApplyTypeToType fn arg + where + requiresSynonymsToExpand = \case + TypeConstructor _ v -> M.notMember v . E.typeSynonyms <$> getEnv + TypeApp _ l _ -> requiresSynonymsToExpand l + KindApp _ l _ -> requiresSynonymsToExpand l + _ -> pure True cannotApplyTypeToType :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) @@ -293,12 +300,34 @@ checkKind => SourceType -> SourceType -> m SourceType -checkKind ty kind2 = +checkKind = checkKind' False + +-- | `checkIsSaturatedType t` is identical to `checkKind t E.kindType` except +-- that the former checks that the type synonyms in `t` expand completely. This +-- is the appropriate function to use when expanding the types of type +-- parameter kinds, arguments to data constructors, etc., in order for the +-- PartiallyAppliedSynonym error to take precedence over the KindsDoNotUnify +-- error. +-- +checkIsSaturatedType + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => SourceType + -> m SourceType +checkIsSaturatedType ty = checkKind' True ty E.kindType + +checkKind' + :: (MonadError MultipleErrors m, MonadState CheckState m, HasCallStack) + => Bool + -> SourceType + -> SourceType + -> m SourceType +checkKind' requireSynonymsToExpand ty kind2 = do withErrorMessageHint (ErrorCheckingKind ty kind2) . rethrowWithPosition (fst $ getAnnForType ty) $ do (ty', kind1) <- inferKind ty kind1' <- apply kind1 kind2' <- apply kind2 + when requireSynonymsToExpand $ void $ replaceAllTypeSynonyms ty' instantiateKind (ty', kind1') kind2' instantiateKind @@ -614,7 +643,7 @@ inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do tyKind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing tyName) let (sigBinders, tyKind') = fromJust . completeBinderList $ tyKind bindLocalTypeVariables moduleName (first ProperName . snd <$> sigBinders) $ do - tyArgs' <- for tyArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< flip checkKind E.kindType + tyArgs' <- for tyArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< checkIsSaturatedType subsumesKind (foldr ((E.-:>) . snd) E.kindType tyArgs') tyKind' bindLocalTypeVariables moduleName (first ProperName <$> tyArgs') $ do let tyCtorName = srcTypeConstructor $ mkQualified tyName moduleName @@ -630,7 +659,7 @@ inferDataConstructor -> DataConstructorDeclaration -> m (DataConstructorDeclaration, SourceType) inferDataConstructor tyCtor DataConstructorDeclaration{..} = do - dataCtorFields' <- traverse (traverse (flip checkKind E.kindType)) dataCtorFields + dataCtorFields' <- traverse (traverse checkIsSaturatedType) dataCtorFields dataCtor <- flip (foldr ((E.-:>) . snd)) dataCtorFields' <$> checkKind tyCtor E.kindType pure ( DataConstructorDeclaration { dataCtorFields = dataCtorFields', .. }, dataCtor ) @@ -666,7 +695,7 @@ inferTypeSynonym moduleName (ann, tyName, tyArgs, tyBody) = do let (sigBinders, tyKind') = fromJust . completeBinderList $ tyKind bindLocalTypeVariables moduleName (first ProperName . snd <$> sigBinders) $ do kindRes <- freshKind (fst ann) - tyArgs' <- for tyArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< flip checkKind E.kindType + tyArgs' <- for tyArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< checkIsSaturatedType unifyKinds tyKind' $ foldr ((E.-:>) . snd) kindRes tyArgs' bindLocalTypeVariables moduleName (first ProperName <$> tyArgs') $ do tyBodyAndKind <- traverse apply =<< inferKind tyBody @@ -782,7 +811,7 @@ inferClassDeclaration moduleName (ann, clsName, clsArgs, superClasses, decls) = clsKind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing $ coerceProperName clsName) let (sigBinders, clsKind') = fromJust . completeBinderList $ clsKind bindLocalTypeVariables moduleName (first ProperName . snd <$> sigBinders) $ do - clsArgs' <- for clsArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< flip checkKind E.kindType + clsArgs' <- for clsArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< checkIsSaturatedType unifyKinds clsKind' $ foldr ((E.-:>) . snd) E.kindConstraint clsArgs' bindLocalTypeVariables moduleName (first ProperName <$> clsArgs') $ do (clsArgs',,) diff --git a/tests/purs/failing/PASTrumpsKDNU1.out b/tests/purs/failing/PASTrumpsKDNU1.out new file mode 100644 index 0000000000..4f66aff0ce --- /dev/null +++ b/tests/purs/failing/PASTrumpsKDNU1.out @@ -0,0 +1,17 @@ +Error found: +in module Main +at tests/purs/failing/PASTrumpsKDNU1.purs:14:33 - 14:43 (line 14, column 33 - line 14, column 43) + + Type synonym Data.NaturalTransformation.NaturalTransformation is partially applied. + Type synonyms must be applied to all of their type arguments. + +while checking that type NaturalTransformation Array + has kind Type +while inferring the kind of Show a => NaturalTransformation Array +while inferring the kind of Proxy (Show a => NaturalTransformation Array) +while inferring the kind of forall a. Proxy (Show a => NaturalTransformation Array) +in value declaration f + +See https://github.com/purescript/documentation/blob/master/errors/PartiallyAppliedSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PASTrumpsKDNU1.purs b/tests/purs/failing/PASTrumpsKDNU1.purs new file mode 100644 index 0000000000..e12b642aac --- /dev/null +++ b/tests/purs/failing/PASTrumpsKDNU1.purs @@ -0,0 +1,15 @@ +-- @shouldFailWith PartiallyAppliedSynonym +module Main where + +import Prelude + +-- The PASTrumpsKDNU series of tests check a number of situations in which +-- both PartiallyAppliedSynonym and KindsDoNotUnify would be reasonable +-- errors to show; in these situtations, PartiallyAppliedSynonym is likely to +-- be the more useful error. + +data Proxy :: forall k. k -> Type +data Proxy a = Proxy + +f :: forall a. Proxy (Show a => (~>) Array) +f = Proxy diff --git a/tests/purs/failing/PASTrumpsKDNU2.out b/tests/purs/failing/PASTrumpsKDNU2.out new file mode 100644 index 0000000000..930028b8df --- /dev/null +++ b/tests/purs/failing/PASTrumpsKDNU2.out @@ -0,0 +1,15 @@ +Error found: +in module Main +at tests/purs/failing/PASTrumpsKDNU2.purs:9:19 - 9:29 (line 9, column 19 - line 9, column 29) + + Type synonym Data.NaturalTransformation.NaturalTransformation is partially applied. + Type synonyms must be applied to all of their type arguments. + +while checking that type NaturalTransformation Array + has kind Type +while inferring the kind of forall (a :: NaturalTransformation Array). Proxy a -> Proxy a +in value declaration f + +See https://github.com/purescript/documentation/blob/master/errors/PartiallyAppliedSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PASTrumpsKDNU2.purs b/tests/purs/failing/PASTrumpsKDNU2.purs new file mode 100644 index 0000000000..00fb71a694 --- /dev/null +++ b/tests/purs/failing/PASTrumpsKDNU2.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith PartiallyAppliedSynonym +module Main where + +import Prelude + +data Proxy :: forall k. k -> Type +data Proxy a = Proxy + +f :: forall (a :: (~>) Array). Proxy a -> Proxy a +f x = x diff --git a/tests/purs/failing/PASTrumpsKDNU3.out b/tests/purs/failing/PASTrumpsKDNU3.out new file mode 100644 index 0000000000..8de6b8a59e --- /dev/null +++ b/tests/purs/failing/PASTrumpsKDNU3.out @@ -0,0 +1,16 @@ +Error found: +in module Main +at tests/purs/failing/PASTrumpsKDNU3.purs:9:23 - 9:33 (line 9, column 23 - line 9, column 33) + + Type synonym Data.NaturalTransformation.NaturalTransformation is partially applied. + Type synonyms must be applied to all of their type arguments. + +while checking that type NaturalTransformation Array + has kind Type +while inferring the kind of forall a. NaturalTransformation Array +while inferring the kind of Proxy (forall a. NaturalTransformation Array) +in value declaration p + +See https://github.com/purescript/documentation/blob/master/errors/PartiallyAppliedSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PASTrumpsKDNU3.purs b/tests/purs/failing/PASTrumpsKDNU3.purs new file mode 100644 index 0000000000..fddb4a547b --- /dev/null +++ b/tests/purs/failing/PASTrumpsKDNU3.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith PartiallyAppliedSynonym +module Main where + +import Prelude + +data Proxy :: forall k. k -> Type +data Proxy a = Proxy + +p :: Proxy (forall a. (~>) Array) +p = Proxy diff --git a/tests/purs/failing/PASTrumpsKDNU4.out b/tests/purs/failing/PASTrumpsKDNU4.out new file mode 100644 index 0000000000..b6f519f728 --- /dev/null +++ b/tests/purs/failing/PASTrumpsKDNU4.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/PASTrumpsKDNU4.purs:6:14 - 6:24 (line 6, column 14 - line 6, column 24) + + Type synonym Data.NaturalTransformation.NaturalTransformation is partially applied. + Type synonyms must be applied to all of their type arguments. + +while checking that type NaturalTransformation Array + has kind Type +in type constructor D + +See https://github.com/purescript/documentation/blob/master/errors/PartiallyAppliedSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PASTrumpsKDNU4.purs b/tests/purs/failing/PASTrumpsKDNU4.purs new file mode 100644 index 0000000000..13f9a0f2ae --- /dev/null +++ b/tests/purs/failing/PASTrumpsKDNU4.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith PartiallyAppliedSynonym +module Main where + +import Prelude + +data D (a :: (~>) Array) = D diff --git a/tests/purs/failing/PASTrumpsKDNU5.out b/tests/purs/failing/PASTrumpsKDNU5.out new file mode 100644 index 0000000000..f8b55fdeb5 --- /dev/null +++ b/tests/purs/failing/PASTrumpsKDNU5.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/PASTrumpsKDNU5.purs:6:16 - 6:26 (line 6, column 16 - line 6, column 26) + + Type synonym Data.NaturalTransformation.NaturalTransformation is partially applied. + Type synonyms must be applied to all of their type arguments. + +while checking that type NaturalTransformation Array + has kind Type +in type constructor N + +See https://github.com/purescript/documentation/blob/master/errors/PartiallyAppliedSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PASTrumpsKDNU5.purs b/tests/purs/failing/PASTrumpsKDNU5.purs new file mode 100644 index 0000000000..99bfa4ab46 --- /dev/null +++ b/tests/purs/failing/PASTrumpsKDNU5.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith PartiallyAppliedSynonym +module Main where + +import Prelude + +newtype N = N ((~>) Array) diff --git a/tests/purs/failing/PASTrumpsKDNU6.out b/tests/purs/failing/PASTrumpsKDNU6.out new file mode 100644 index 0000000000..8b45d68af2 --- /dev/null +++ b/tests/purs/failing/PASTrumpsKDNU6.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/PASTrumpsKDNU6.purs:6:14 - 6:24 (line 6, column 14 - line 6, column 24) + + Type synonym Data.NaturalTransformation.NaturalTransformation is partially applied. + Type synonyms must be applied to all of their type arguments. + +while checking that type NaturalTransformation Array + has kind Type +in type synonym T + +See https://github.com/purescript/documentation/blob/master/errors/PartiallyAppliedSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PASTrumpsKDNU6.purs b/tests/purs/failing/PASTrumpsKDNU6.purs new file mode 100644 index 0000000000..5bfb6a80e8 --- /dev/null +++ b/tests/purs/failing/PASTrumpsKDNU6.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith PartiallyAppliedSynonym +module Main where + +import Prelude + +type T (a :: (~>) Array) = Int diff --git a/tests/purs/failing/PASTrumpsKDNU7.out b/tests/purs/failing/PASTrumpsKDNU7.out new file mode 100644 index 0000000000..3ea32bb392 --- /dev/null +++ b/tests/purs/failing/PASTrumpsKDNU7.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/PASTrumpsKDNU7.purs:6:15 - 6:25 (line 6, column 15 - line 6, column 25) + + Type synonym Data.NaturalTransformation.NaturalTransformation is partially applied. + Type synonyms must be applied to all of their type arguments. + +while checking that type NaturalTransformation Array + has kind Type +in type constructor C$Dict + +See https://github.com/purescript/documentation/blob/master/errors/PartiallyAppliedSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/PASTrumpsKDNU7.purs b/tests/purs/failing/PASTrumpsKDNU7.purs new file mode 100644 index 0000000000..434ed11409 --- /dev/null +++ b/tests/purs/failing/PASTrumpsKDNU7.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith PartiallyAppliedSynonym +module Main where + +import Prelude + +class C (a :: (~>) Array) diff --git a/tests/purs/failing/RowConstructors2.out b/tests/purs/failing/RowConstructors2.out index 03f17dfcfb..05ddf97853 100644 --- a/tests/purs/failing/RowConstructors2.out +++ b/tests/purs/failing/RowConstructors2.out @@ -2,20 +2,14 @@ Error found: in module Main at tests/purs/failing/RowConstructors2.purs:7:16 - 7:19 (line 7, column 16 - line 7, column 19) - Could not match kind -   -  Function (Row Type) -   - with kind -   -  Row -   + Type synonym Main.Foo is partially applied. + Type synonyms must be applied to all of their type arguments. while checking that type Foo has kind Row Type while inferring the kind of Record Foo in type synonym Bar -See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/PartiallyAppliedSynonym.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/RowConstructors2.purs b/tests/purs/failing/RowConstructors2.purs index aeec350276..778f92cd44 100644 --- a/tests/purs/failing/RowConstructors2.purs +++ b/tests/purs/failing/RowConstructors2.purs @@ -1,4 +1,4 @@ --- @shouldFailWith KindsDoNotUnify +-- @shouldFailWith PartiallyAppliedSynonym module Main where import Effect.Console (log) diff --git a/tests/purs/failing/TypeSynonyms10.out b/tests/purs/failing/TypeSynonyms10.out new file mode 100644 index 0000000000..8a9e2ecaf3 --- /dev/null +++ b/tests/purs/failing/TypeSynonyms10.out @@ -0,0 +1,21 @@ +Error found: +in module Main +at tests/purs/failing/TypeSynonyms10.purs:8:19 - 8:23 (line 8, column 19 - line 8, column 23) + + Could not match kind +   +  (Type -> Type) -> Type +   + with kind +   +  Type +   + +while checking that type NaturalTransformation Array + has kind Type +while inferring the kind of F (NaturalTransformation Array) +in type constructor N + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeSynonyms10.purs b/tests/purs/failing/TypeSynonyms10.purs new file mode 100644 index 0000000000..85c490b0c7 --- /dev/null +++ b/tests/purs/failing/TypeSynonyms10.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +import Prelude + +type F (a :: Type) = a + +newtype N = N (F ((~>) Array)) diff --git a/tests/purs/failing/TypeSynonyms8.out b/tests/purs/failing/TypeSynonyms8.out new file mode 100644 index 0000000000..7e07f48615 --- /dev/null +++ b/tests/purs/failing/TypeSynonyms8.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/TypeSynonyms8.purs:6:15 - 6:16 (line 6, column 15 - line 6, column 16) + + Type synonym Main.S is partially applied. + Type synonyms must be applied to all of their type arguments. + +while checking that type S + has kind Type +in type constructor N + +See https://github.com/purescript/documentation/blob/master/errors/PartiallyAppliedSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeSynonyms8.purs b/tests/purs/failing/TypeSynonyms8.purs new file mode 100644 index 0000000000..3690ea973f --- /dev/null +++ b/tests/purs/failing/TypeSynonyms8.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith PartiallyAppliedSynonym +module Main where + +data D a +type S a = D a +newtype N = N S diff --git a/tests/purs/failing/TypeSynonyms9.out b/tests/purs/failing/TypeSynonyms9.out new file mode 100644 index 0000000000..cba09b84b3 --- /dev/null +++ b/tests/purs/failing/TypeSynonyms9.out @@ -0,0 +1,15 @@ +Error found: +in module Main +at tests/purs/failing/TypeSynonyms9.purs:7:19 - 7:29 (line 7, column 19 - line 7, column 29) + + Type synonym Data.NaturalTransformation.NaturalTransformation is partially applied. + Type synonyms must be applied to all of their type arguments. + +while checking that type NaturalTransformation Array + has kind (Type -> Type) -> Type -> Type +while inferring the kind of A (NaturalTransformation Array) +in type constructor B + +See https://github.com/purescript/documentation/blob/master/errors/PartiallyAppliedSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/TypeSynonyms9.purs b/tests/purs/failing/TypeSynonyms9.purs new file mode 100644 index 0000000000..e80ce7871e --- /dev/null +++ b/tests/purs/failing/TypeSynonyms9.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith PartiallyAppliedSynonym +module Main where + +import Prelude + +newtype A (a :: (Type -> Type) -> Type -> Type) = A String +newtype B = B (A ((~>) Array)) diff --git a/tests/purs/passing/TypeSynonyms.purs b/tests/purs/passing/TypeSynonyms.purs index 55ddf98f79..d8567b9920 100644 --- a/tests/purs/passing/TypeSynonyms.purs +++ b/tests/purs/passing/TypeSynonyms.purs @@ -25,4 +25,6 @@ fst = test1 :: forall a b c. Lens (Pair (Pair a b) c) a test1 = composeLenses fst fst +newtype N = N (Array ~> Array) + main = log "Done" From 41bf005f01302ed6e398ca3463547a07e310bea9 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 12 May 2022 07:35:41 -0400 Subject: [PATCH 1456/1580] Deploy builds continuously to GitHub and npm (#4306) --- .github/workflows/ci.yml | 60 +++++++++++++++++++++++-- CHANGELOG.d/internal_cd.md | 1 + RELEASE_GUIDE.md | 40 ++++++++++++----- ci/build.sh | 89 +++++++++++++++++++++++++++++++++++++- purescript.cabal | 2 +- 5 files changed, 177 insertions(+), 15 deletions(-) create mode 100644 CHANGELOG.d/internal_cd.md diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 85a5cbeeb3..46839ca1f5 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -13,9 +13,20 @@ defaults: shell: "bash" env: + CI_PRERELEASE: "${{ github.event_name == 'push' }}" CI_RELEASE: "${{ github.event_name == 'release' }}" STACK_VERSION: "2.7.3" +concurrency: + # We never want two releases or prereleases building at the same time, since + # they would likely both claim the same version number. Pull request builds + # can happen in parallel with anything else, since they don't mutate global + # state with a release. (GitHub Actions is either too cheap to give us `if` + # expressions or too lazy to document them, but we have untyped boolean + # operators to fall back on.) + group: "${{ github.event_name == 'pull_request' && github.run_id || 'continuous-deployment' }}" + cancel-in-progress: true + jobs: build: strategy: @@ -31,6 +42,10 @@ jobs: runs-on: "${{ matrix.os }}" container: "${{ matrix.image }}" + outputs: + do-not-prerelease: "${{ steps.build.outputs.do-not-prerelease }}" + version: "${{ steps.build.outputs.version }}" + steps: - # We need a proper Git repository, but the checkout step will unpack a tarball instead of doing a clone # if the Git version is less than 2.18. @@ -77,7 +92,8 @@ jobs: mkdir -p "$STACK_ROOT" echo "local-programs-path: $STACK_ROOT/programs" > $STACK_ROOT/config.yaml - - run: "ci/fix-home ci/build.sh" + - id: "build" + run: "ci/fix-home ci/build.sh" - name: "(Linux only) Build the entire package set" if: "${{ runner.os == 'Linux' }}" @@ -106,8 +122,8 @@ jobs: exit 1 fi - - name: "(Release only) Create bundle" - if: "${{ env.CI_RELEASE == 'true' }}" + - name: "(Release/prerelease only) Create bundle" + if: "${{ env.CI_RELEASE == 'true' || env.CI_PRERELEASE == 'true' && steps.build.outputs.do-not-prerelease != 'true' }}" run: | os_name="${{ runner.os }}" case "$os_name" in @@ -124,6 +140,15 @@ jobs: cd sdist-test ../ci/fix-home bundle/build.sh "$bundle_os" + - name: "(Prerelease only) Upload bundle" + if: "${{ env.CI_PRERELEASE == 'true' && steps.build.outputs.do-not-prerelease != 'true' }}" + uses: "actions/upload-artifact@v3" + with: + name: "${{ runner.os }}-bundle" + path: | + sdist-test/bundle/*.sha + sdist-test/bundle/*.tar.gz + - name: "(Release only) Publish bundle" if: "${{ env.CI_RELEASE == 'true' }}" # Astonishingly, GitHub doesn't currently maintain a first-party action @@ -194,3 +219,32 @@ jobs: - run: "ci/fix-home stack --no-terminal --jobs=2 build --fast --test --no-run-tests --ghc-options -fwrite-ide-info" - run: "ci/fix-home stack exec weeder" + + make-prerelease: + runs-on: "ubuntu-latest" + needs: + - "build" + - "lint" + if: "${{ github.event_name == 'push' && needs.build.outputs.do-not-prerelease != 'true' }}" + steps: + - uses: "actions/download-artifact@v3" + - uses: "ncipollo/release-action@v1.10.0" + with: + tag: "${{ needs.build.outputs.version }}" + artifacts: "*-bundle/*" + prerelease: true + body: "This is an automated preview release. Get the latest stable release [here](https://github.com/purescript/purescript/releases/latest)." + - uses: "actions/checkout@v3" + - uses: "actions/setup-node@v3" + with: + node-version: "16.x" + - name: "Publish npm package" + working-directory: "npm-package" + env: + BUILD_VERSION: "${{ needs.build.outputs.version }}" + NODE_AUTH_TOKEN: "${{ secrets.NPM_TOKEN }}" + run: | + src_version=$(node -pe 'require("./package.json").version') + npm version --allow-same-version "$BUILD_VERSION" + sed -i -e "s/--purs-ver=${src_version//./\\.}/--purs-ver=$BUILD_VERSION/" package.json + npm publish --tag next diff --git a/CHANGELOG.d/internal_cd.md b/CHANGELOG.d/internal_cd.md new file mode 100644 index 0000000000..f7c8d1957a --- /dev/null +++ b/CHANGELOG.d/internal_cd.md @@ -0,0 +1 @@ +* Deploy builds continuously to GitHub and npm diff --git a/RELEASE_GUIDE.md b/RELEASE_GUIDE.md index 9466b7f32a..02ac3a4fe5 100644 --- a/RELEASE_GUIDE.md +++ b/RELEASE_GUIDE.md @@ -72,14 +72,38 @@ considering what effects this may have: - JSON produced by `purs publish` - this might affect Pursuit +## Making a release candidate + +- Make a commit bumping versions. The following should be updated: + + - The `version` field in `purescript.cabal` should be set to the expected + final release version. + + - The `prerelease` field in `app/Version.hs` should be set to `-rc.0`. + + - The `version` field in `npm-package/package.json` should be set to the + concatenation of the above two items. + + - The version to install in the `postinstall` script in `package.json` should + match the `version` field. + +- Upon merging the PR, the release candidate will be published to GitHub and + npm. There is no need to make a manual release for the RC. Subsequent builds + will be deployed to successive `-rc.*` numbers until a final release is made. + +- Verify that the release candidate can be installed via `npm i purescript@next` + ## Making a release +- Test that the last build published to `purescript@next` works in downstream + projects before starting the manual release process. + - Make a commit bumping versions. The following should be updated: - The `version` field in `purescript.cabal` - - The `prerelease` field in `app/Version.hs`, if updating the prerelease - field + - The `prerelease` field in `app/Version.hs` should be cleared, if a + release candidate was previously published - The `version` field in `npm-package/package.json` @@ -103,14 +127,10 @@ considering what effects this may have: - After all of the prebuilt binaries are present on the GitHub releases page, publish to npm: change to the `npm-package` directory and do the following: - - if making a pre-release (e.g. `v0.15.0-alpha-05`) - - run `npm publish --tag next` - - verify that the prerelease can be installed via `npm i purescript@next` - - if making a normal release (e.g. `v0.15.0`) - - run `npm publish` - - run `npm dist-tag add purescript@VERSION next` where `VERSION` is `v0.15.0`. - - verify that the release can be installed via `npm i purescript@next` - - verify that the release can be installed via `npm i purescript` + - run `npm publish` + - run `npm dist-tag add purescript@VERSION next` where `VERSION` is `v0.15.0`. + - verify that the release can be installed via `npm i purescript@next` + - verify that the release can be installed via `npm i purescript` Note: if a release does not go as planned (e.g. [`v0.14.3`](https://github.com/purescript/purescript/pull/4139)), we should not delete the broken GitHub release or its Git tag. Rather, we should make a new release and update the GitHub release notes and the corresponding section in the CHANGELOG.md file for the broken release to 1. say that it's not a real release, and diff --git a/ci/build.sh b/ci/build.sh index 81c8c33b5b..2d212f1c5a 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -28,13 +28,100 @@ set -ex STACK="stack --no-terminal --haddock --jobs=2" STACK_OPTS="--test" -if [ "$CI_RELEASE" = "true" ] +if [ "$CI_RELEASE" = "true" -o "$CI_PRERELEASE" = "true" ] then STACK_OPTS="$STACK_OPTS --flag=purescript:RELEASE" else STACK_OPTS="$STACK_OPTS --fast" fi +(echo "::endgroup::"; echo "::group::Set version number for build") 2>/dev/null + +pushd npm-package + +package_version=$(node -pe 'require("./package.json").version') +package_release_version=${package_version%%-*} +package_prerelease_suffix=${package_version#$package_release_version} + +if ! grep -q "\"install-purescript --purs-ver=${package_version//./\\.}\"" package.json +then + echo "Version in npm-package/package.json doesn't match version in install-purescript call" + exit 1 +fi + +if ! grep -q "^version:\\s*${package_release_version//./\\.}$" ../purescript.cabal +then + echo "Version in npm-package/package.json doesn't match version in purescript.cabal" + exit 1 +fi + +if ! grep -q "^prerelease = \"${package_prerelease_suffix//./\\.}\"$" ../app/Version.hs +then + echo "Version in npm-package/package.json doesn't match prerelease in app/Version.hs" + exit 1 +fi + +function largest-matching-git-tag { + grep -E "^${1//./\\.}(\\.|$)" "$git_tags" | head -n 1 +} + +git_tags=$(mktemp) +trap 'rm "$git_tags"' EXIT +git ls-remote --tags -q --sort=-version:refname | sed 's_^.*refs/tags/__' > $git_tags +if [ "$package_prerelease_suffix" ] +then + tag=$(largest-matching-git-tag "v$package_release_version${package_prerelease_suffix%%.*}") + if [ "$tag" ] + then + npm version --allow-same-version "$tag" + build_version=$(npm version --no-git-tag-version prerelease) + build_version=${build_version#v} + else + build_version=$package_version + fi +else # (current version does not contain a prerelease suffix) + if grep -Fqx "v$package_release_version" "$git_tags" + then # (the current version has been published) + bump=patch + if [ "$(find ../CHANGELOG.d -maxdepth 1 -name 'breaking_*' -print -quit)" ] + then + # If we ever reach 1.0, change this to major and uncomment the below + bump=minor + #elif [ "$(find ../CHANGELOG.d -maxdepth 1 -name 'feature_*' -print -quit)" ] + #then + # bump=minor + fi + next_tag=$(npm version --no-git-tag-version "$bump") + tag=$(largest-matching-git-tag "$next_tag-[0-9]+") + if [ "$tag" ] + then + npm version --allow-same-version "$tag" + build_version=$(npm version --no-git-tag-version prerelease) + else + build_version=$(npm version --allow-same-version "$next_tag-0") + fi + build_version=${build_version#v} + else # (current version has not been published) + build_version=$package_version + echo "::set-output name=do-not-prerelease::true" + fi +fi + +echo "::set-output name=version::v$build_version" + +if [ "$build_version" != "$package_version" ] +then + build_release_version=${build_version%%-*} + build_prerelease_suffix=${build_version#$build_release_version} + # We don't need to update the install-purescript command before we build; + # we'll do that when we publish. All we need to update here are the files + # that affect the purs binary. + sed -i -e "s/^\\(version:\\s*\\)${package_release_version//./\\.}/\1$build_release_version/" ../purescript.cabal + sed -i -e "s/^prerelease = \"${package_prerelease_suffix//./\\.}\"$/prerelease = \"${build_prerelease_suffix}\"/" ../app/Version.hs +fi + +popd + (echo "::endgroup::"; echo "::group::Install snapshot dependencies") 2>/dev/null # Install snapshot dependencies (since these will be cached globally and thus diff --git a/purescript.cabal b/purescript.cabal index caf6d12bc6..e0440c1c2f 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: purescript --- note: When updating the prerelease identifier, update it in app/Version.hs too! +-- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. version: 0.15.0 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. From ba2af33abe265ce4ee8c31f2165de983c9b1f090 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 12 May 2022 16:43:42 -0400 Subject: [PATCH 1457/1580] Fix npm publish (#4320) Without an explicit `registry-url` input, `setup-node` doesn't create the `.npmrc` file that hooks `NODE_AUTH_TOKEN` into the publishing workflow. --- .github/workflows/ci.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 46839ca1f5..c4d1aa6ec2 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -238,6 +238,7 @@ jobs: - uses: "actions/setup-node@v3" with: node-version: "16.x" + registry-url: "https://registry.npmjs.org" - name: "Publish npm package" working-directory: "npm-package" env: From e909a467d679b32bd392380d21b5d4a184554786 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 12 May 2022 18:04:36 -0400 Subject: [PATCH 1458/1580] Fix purescript-installer call for prereleases (#4321) --- .github/workflows/ci.yml | 2 +- ci/build.sh | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index c4d1aa6ec2..b16bcb6955 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -230,7 +230,7 @@ jobs: - uses: "actions/download-artifact@v3" - uses: "ncipollo/release-action@v1.10.0" with: - tag: "${{ needs.build.outputs.version }}" + tag: "v${{ needs.build.outputs.version }}" artifacts: "*-bundle/*" prerelease: true body: "This is an automated preview release. Get the latest stable release [here](https://github.com/purescript/purescript/releases/latest)." diff --git a/ci/build.sh b/ci/build.sh index 2d212f1c5a..6d1e53ccd9 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -107,7 +107,7 @@ else # (current version does not contain a prerelease suffix) fi fi -echo "::set-output name=version::v$build_version" +echo "::set-output name=version::$build_version" if [ "$build_version" != "$package_version" ] then From 22208830d6aecbc2760171d5780ded21c57b12ba Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 14 May 2022 04:16:58 -0400 Subject: [PATCH 1459/1580] Fix bad interaction between module renaming and inliner (#4322) This bug was triggered when modules that the compiler handles specially are shadowed by local constructors. For example, a constructor named `Prim` could have caused references to `Prim_1["undefined"]` to be produced in the compiled code, leading to a reference error at run time. Less severely, a constructor named `Control_Bind` would have caused the compiler not to inline known monadic functions, leading to slower and less readable compiled code. --- CHANGELOG.d/fix_4229.md | 9 + src/Language/PureScript/CodeGen/JS.hs | 127 ++++------ src/Language/PureScript/Constants/Prelude.hs | 85 +++---- src/Language/PureScript/CoreFn/Optimizer.hs | 12 +- src/Language/PureScript/CoreImp/AST.hs | 5 + .../PureScript/CoreImp/Optimizer/Common.hs | 9 +- .../PureScript/CoreImp/Optimizer/Inliner.hs | 218 +++++++++--------- .../PureScript/CoreImp/Optimizer/MagicDo.hs | 22 +- tests/purs/optimize/4229.out.js | 17 ++ tests/purs/optimize/4229.purs | 13 ++ tests/purs/optimize/Foreign.js | 1 + tests/purs/optimize/Foreign.out.js | 5 + tests/purs/optimize/Foreign.purs | 5 + tests/purs/passing/4229.purs | 13 ++ 14 files changed, 284 insertions(+), 257 deletions(-) create mode 100644 CHANGELOG.d/fix_4229.md create mode 100644 tests/purs/optimize/4229.out.js create mode 100644 tests/purs/optimize/4229.purs create mode 100644 tests/purs/optimize/Foreign.js create mode 100644 tests/purs/optimize/Foreign.out.js create mode 100644 tests/purs/optimize/Foreign.purs create mode 100644 tests/purs/passing/4229.purs diff --git a/CHANGELOG.d/fix_4229.md b/CHANGELOG.d/fix_4229.md new file mode 100644 index 0000000000..40b785d49d --- /dev/null +++ b/CHANGELOG.d/fix_4229.md @@ -0,0 +1,9 @@ +* Fix bad interaction between module renaming and inliner + + This bug was triggered when modules that the compiler handles specially + are shadowed by local constructors. For example, a constructor named + `Prim` could have caused references to `Prim_1["undefined"]` to be + produced in the compiled code, leading to a reference error at run time. + Less severely, a constructor named `Control_Bind` would have caused the + compiler not to inline known monadic functions, leading to slower and + less readable compiled code. diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 07019811bb..0dec7807f3 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -59,23 +59,20 @@ moduleToJs moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = rethrow (addHint (ErrorInModule mn)) $ do let usedNames = concatMap getNames decls - let mnLookup = renameImports usedNames imps - let decls' = renameModules mnLookup decls - (jsDecls, Any needRuntimeLazy) <- runWriterT $ mapM (moduleBindToJs mn) decls' - let mnReverseLookup = M.fromList $ map (\(origName, (_, safeName)) -> (moduleNameToJs safeName, origName)) $ M.toList mnLookup - let moduleObjectNames = "$foreign" `S.insert` M.keysSet mnReverseLookup - optimized <- traverse (traverse (fmap (annotatePure moduleObjectNames) . optimize)) (if needRuntimeLazy then [runtimeLazy] : jsDecls else jsDecls) - let usedModuleNames = foldMap (foldMap (findModules mnReverseLookup)) optimized - `S.union` M.keysSet reExps - let jsImports - = map (importToJs mnLookup) - . filter (flip S.member usedModuleNames) - . (\\ (mn : C.primModules)) $ ordNub $ map snd imps + let imps' = ordNub $ map snd imps + let mnLookup = renameImports usedNames imps' + (jsDecls, Any needRuntimeLazy) <- runWriterT $ mapM (moduleBindToJs mn) decls + optimized <- traverse (traverse (fmap annotatePure . optimize)) (if needRuntimeLazy then [runtimeLazy] : jsDecls else jsDecls) F.traverse_ (F.traverse_ checkIntegers) optimized comments <- not <$> asks optionsNoComments let header = if comments then coms else [] - let foreign' = maybe [] (pure . AST.Import "$foreign") $ if null foreigns then Nothing else foreignInclude + let foreign' = maybe [] (pure . AST.Import FFINamespace) $ if null foreigns then Nothing else foreignInclude let moduleBody = concat optimized + let (S.union (M.keysSet reExps) -> usedModuleNames, renamedModuleBody) = traverse (replaceModuleAccessors mnLookup) moduleBody + let jsImports + = map (importToJs mnLookup) + . filter (flip S.member usedModuleNames) + $ (\\ (mn : C.primModules)) imps' let foreignExps = exps `intersect` foreigns let standardExps = exps \\ foreignExps let reExps' = M.toList (M.withoutKeys reExps (S.fromList C.primModules)) @@ -83,15 +80,15 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = = (maybeToList . exportsToJs foreignInclude $ foreignExps) ++ (maybeToList . exportsToJs Nothing $ standardExps) ++ mapMaybe reExportsToJs reExps' - return $ AST.Module header (foreign' ++ jsImports) moduleBody jsExports + return $ AST.Module header (foreign' ++ jsImports) renamedModuleBody jsExports where -- | Adds purity annotations to top-level values for bundlers. -- The semantics here derive from treating top-level module evaluation as pure, which lets -- us remove any unreferenced top-level declarations. To achieve this, we wrap any non-trivial -- top-level values in an IIFE marked with a pure annotation. - annotatePure :: S.Set Text -> AST -> AST - annotatePure moduleObjectNames = annotateOrWrap + annotatePure :: AST -> AST + annotatePure = annotateOrWrap where annotateOrWrap = liftA2 fromMaybe pureIife maybePure @@ -113,19 +110,18 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = maybePureGen alreadyAnnotated = \case AST.VariableIntroduction ss name j -> Just (AST.VariableIntroduction ss name (annotateOrWrap <$> j)) AST.App ss f args -> (if alreadyAnnotated then AST.App else pureApp) ss <$> maybePure' f <*> traverse maybePure args - -- In general, indexers can be effectful, but not when indexing into an - -- ES module object. - AST.Indexer ss idx v@(AST.Var _ name) - | name `S.member` moduleObjectNames -> (\idx' -> AST.Indexer ss idx' v) <$> maybePure idx AST.ArrayLiteral ss jss -> AST.ArrayLiteral ss <$> traverse maybePure jss AST.ObjectLiteral ss props -> AST.ObjectLiteral ss <$> traverse (traverse maybePure) props AST.Comment c js -> AST.Comment c <$> maybePure js + js@(AST.Indexer _ _ (AST.Var _ FFINamespace)) -> Just js + js@AST.NumericLiteral{} -> Just js js@AST.StringLiteral{} -> Just js js@AST.BooleanLiteral{} -> Just js js@AST.Function{} -> Just js js@AST.Var{} -> Just js + js@AST.ModuleAccessor{} -> Just js _ -> Nothing @@ -142,31 +138,31 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = -- | Creates alternative names for each module to ensure they don't collide -- with declaration names. - renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName) + renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName Text renameImports = go M.empty where - go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName) - go acc used ((ann, mn') : mns') = - let mni = Ident $ moduleNameToJs mn' - in if mn' /= mn && mni `elem` used - then let newName = freshModuleName 1 mn' used - in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns' - else go (M.insert mn' (ann, mn') acc) used mns' + go :: M.Map ModuleName Text -> [Ident] -> [ModuleName] -> M.Map ModuleName Text + go acc used (mn' : mns') = + let mnj = moduleNameToJs mn' + in if mn' /= mn && Ident mnj `elem` used + then let newName = freshModuleName 1 mnj used + in go (M.insert mn' newName acc) (Ident newName : used) mns' + else go (M.insert mn' mnj acc) used mns' go acc _ [] = acc - freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName - freshModuleName i mn'@(ModuleName name) used = - let newName = ModuleName $ name <> "_" <> T.pack (show i) - in if Ident (runModuleName newName) `elem` used + freshModuleName :: Integer -> Text -> [Ident] -> Text + freshModuleName i mn' used = + let newName = mn' <> "_" <> T.pack (show i) + in if Ident newName `elem` used then freshModuleName (i + 1) mn' used else newName -- | Generates JavaScript code for a module import, binding the required module -- to the alternative - importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> AST.Import + importToJs :: M.Map ModuleName Text -> ModuleName -> AST.Import importToJs mnLookup mn' = - let (_, mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - in AST.Import (moduleNameToJs mnSafe) (moduleImportPath mn') + let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup + in AST.Import mnSafe (moduleImportPath mn') -- | Generates JavaScript code for exporting at least one identifier, -- eventually from another module. @@ -181,33 +177,15 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = moduleImportPath :: ModuleName -> PSString moduleImportPath mn' = fromString (".." T.unpack (runModuleName mn') "index.js") - -- | Replaces the `ModuleName`s in the AST so that the generated code refers to - -- the collision-avoiding renamed module imports. - renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann] - renameModules mnLookup binds = - let (f, _, _) = everywhereOnValues id goExpr goBinder - in map f binds - where - goExpr :: Expr a -> Expr a - goExpr (Var ann q) = Var ann (renameQual q) - goExpr e = e - goBinder :: Binder a -> Binder a - goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs - goBinder b = b - renameQual :: Qualified a -> Qualified a - renameQual (Qualified (Just mn') a) = - let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup - in Qualified (Just mnSafe) a - renameQual q = q - - -- | - -- Find the set of ModuleNames referenced by an AST. - -- - findModules :: M.Map Text ModuleName -> AST -> S.Set ModuleName - findModules mnReverseLookup = AST.everything mappend go - where - go (AST.Var _ name) = foldMap S.singleton $ M.lookup name mnReverseLookup - go _ = mempty + -- | Replaces the `ModuleAccessor`s in the AST with `Indexer`s, ensuring that + -- the generated code refers to the collision-avoiding renamed module + -- imports. Also returns set of used module names. + replaceModuleAccessors :: M.Map ModuleName Text -> AST -> (S.Set ModuleName, AST) + replaceModuleAccessors mnLookup = everywhereTopDownM $ \case + AST.ModuleAccessor _ mn' name -> + let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup + in (S.singleton mn', accessorString name $ AST.Var Nothing mnSafe) + other -> pure other -- Check that all integers fall within the valid int range for JavaScript. checkIntegers :: AST -> m () @@ -297,21 +275,6 @@ moduleBindToJs mn = bindToJs var :: Ident -> AST var = AST.Var Nothing . identToJs - -- | Generate code in the simplified JavaScript intermediate representation for an accessor based on - -- a PureScript identifier. If the name is not valid in JavaScript (symbol based, reserved name) an - -- indexer is returned. - moduleAccessor :: Ident -> AST -> AST - moduleAccessor (Ident prop) = moduleAccessorString prop - moduleAccessor (GenIdent _ _) = internalError "GenIdent in moduleAccessor" - moduleAccessor UnusedIdent = internalError "UnusedIdent in moduleAccessor" - moduleAccessor InternalIdent{} = internalError "InternalIdent in moduleAccessor" - - moduleAccessorString :: Text -> AST -> AST - moduleAccessorString = accessorString . mkString . T.concatMap identCharToText - - accessorString :: PSString -> AST -> AST - accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop) - -- | Generate code in the simplified JavaScript intermediate representation for a value or expression. valueToJs :: Expr Ann -> m AST valueToJs e = @@ -425,11 +388,11 @@ moduleBindToJs mn = bindToJs -- variable that may have a qualified name. qualifiedToJS :: (a -> Ident) -> Qualified a -> AST qualifiedToJS f (Qualified (Just C.Prim) a) = AST.Var Nothing . runIdent $ f a - qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = moduleAccessor (f a) (AST.Var Nothing (moduleNameToJs mn')) + qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = AST.ModuleAccessor Nothing mn' . mkString . T.concatMap identCharToText . runIdent $ f a qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToJs (f a) foreignIdent :: Ident -> AST - foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign") + foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing FFINamespace) -- | Generate code in the simplified JavaScript intermediate representation for pattern match binders -- and guards. @@ -541,3 +504,9 @@ moduleBindToJs mn = bindToJs done'' <- go done' (index + 1) bs' js <- binderToJs elVar done'' binder return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js) + +accessorString :: PSString -> AST -> AST +accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop) + +pattern FFINamespace :: Text +pattern FFINamespace = "$foreign" diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index 608b5deb9c..57e9a8b8ca 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -300,77 +300,68 @@ pattern EQ = Qualified (Just DataOrdering) (ProperName "EQ") pattern GT :: Qualified (ProperName 'ConstructorName) pattern GT = Qualified (Just DataOrdering) (ProperName "GT") -dataArray :: forall a. (IsString a) => a -dataArray = "Data_Array" +pattern DataArray :: ModuleName +pattern DataArray = ModuleName "Data.Array" -eff :: forall a. (IsString a) => a -eff = "Control_Monad_Eff" +pattern Eff :: ModuleName +pattern Eff = ModuleName "Control.Monad.Eff" -effect :: forall a. (IsString a) => a -effect = "Effect" +pattern Effect :: ModuleName +pattern Effect = ModuleName "Effect" -st :: forall a. (IsString a) => a -st = "Control_Monad_ST_Internal" +pattern ST :: ModuleName +pattern ST = ModuleName "Control.Monad.ST.Internal" -controlApplicative :: forall a. (IsString a) => a -controlApplicative = "Control_Applicative" +pattern ControlApplicative :: ModuleName +pattern ControlApplicative = ModuleName "Control.Applicative" -controlSemigroupoid :: forall a. (IsString a) => a -controlSemigroupoid = "Control_Semigroupoid" +pattern ControlSemigroupoid :: ModuleName +pattern ControlSemigroupoid = ModuleName "Control.Semigroupoid" pattern ControlBind :: ModuleName pattern ControlBind = ModuleName "Control.Bind" -controlBind :: forall a. (IsString a) => a -controlBind = "Control_Bind" +pattern ControlMonadEffUncurried :: ModuleName +pattern ControlMonadEffUncurried = ModuleName "Control.Monad.Eff.Uncurried" -controlMonadEffUncurried :: forall a. (IsString a) => a -controlMonadEffUncurried = "Control_Monad_Eff_Uncurried" +pattern EffectUncurried :: ModuleName +pattern EffectUncurried = ModuleName "Effect.Uncurried" -effectUncurried :: forall a. (IsString a) => a -effectUncurried = "Effect_Uncurried" +pattern DataBounded :: ModuleName +pattern DataBounded = ModuleName "Data.Bounded" -dataBounded :: forall a. (IsString a) => a -dataBounded = "Data_Bounded" +pattern DataSemigroup :: ModuleName +pattern DataSemigroup = ModuleName "Data.Semigroup" -dataSemigroup :: forall a. (IsString a) => a -dataSemigroup = "Data_Semigroup" +pattern DataHeytingAlgebra :: ModuleName +pattern DataHeytingAlgebra = ModuleName "Data.HeytingAlgebra" -dataHeytingAlgebra :: forall a. (IsString a) => a -dataHeytingAlgebra = "Data_HeytingAlgebra" +pattern DataEq :: ModuleName +pattern DataEq = ModuleName "Data.Eq" -dataEq :: forall a. (IsString a) => a -dataEq = "Data_Eq" +pattern DataOrd :: ModuleName +pattern DataOrd = ModuleName "Data.Ord" -dataOrd :: forall a. (IsString a) => a -dataOrd = "Data_Ord" +pattern DataSemiring :: ModuleName +pattern DataSemiring = ModuleName "Data.Semiring" -dataSemiring :: forall a. (IsString a) => a -dataSemiring = "Data_Semiring" +pattern DataRing :: ModuleName +pattern DataRing = ModuleName "Data.Ring" -dataRing :: forall a. (IsString a) => a -dataRing = "Data_Ring" +pattern DataEuclideanRing :: ModuleName +pattern DataEuclideanRing = ModuleName "Data.EuclideanRing" -dataEuclideanRing :: forall a. (IsString a) => a -dataEuclideanRing = "Data_EuclideanRing" +pattern DataFunction :: ModuleName +pattern DataFunction = ModuleName "Data.Function" -dataFunction :: forall a. (IsString a) => a -dataFunction = "Data_Function" - -dataFunctionUncurried :: forall a. (IsString a) => a -dataFunctionUncurried = "Data_Function_Uncurried" - -dataIntBits :: forall a. (IsString a) => a -dataIntBits = "Data_Int_Bits" - -partialUnsafe :: forall a. (IsString a) => a -partialUnsafe = "Partial_Unsafe" +pattern DataIntBits :: ModuleName +pattern DataIntBits = ModuleName "Data.Int.Bits" unsafePartial :: forall a. (IsString a) => a unsafePartial = "unsafePartial" -unsafeCoerce :: forall a. (IsString a) => a -unsafeCoerce = "Unsafe_Coerce" +pattern UnsafeCoerce :: ModuleName +pattern UnsafeCoerce = ModuleName "Unsafe.Coerce" unsafeCoerceFn :: forall a. (IsString a) => a unsafeCoerceFn = "unsafeCoerce" diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 29fa7259d7..0d9ff5fc81 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -3,14 +3,13 @@ module Language.PureScript.CoreFn.Optimizer (optimizeCoreFn) where import Protolude hiding (Type) import Data.List (lookup) -import qualified Data.Text as T import Language.PureScript.AST.Literals import Language.PureScript.AST.SourcePos import Language.PureScript.CoreFn.Ann import Language.PureScript.CoreFn.Expr import Language.PureScript.CoreFn.Module import Language.PureScript.CoreFn.Traversals -import Language.PureScript.Names (Ident(..), ModuleName(..), Qualified(..)) +import Language.PureScript.Names (Ident(..), Qualified(..)) import Language.PureScript.Label import Language.PureScript.Types import qualified Language.PureScript.Constants.Prelude as C @@ -53,10 +52,7 @@ closedRecordFields _ = Nothing optimizeDataFunctionApply :: Expr a -> Expr a optimizeDataFunctionApply e = case e of - (App a (App _ (Var _ (Qualified (Just (ModuleName mn)) (Ident fn))) x) y) - | mn == dataFunction && fn == C.apply -> App a x y - | mn == dataFunction && fn == C.applyFlipped -> App a y x + (App a (App _ (Var _ (Qualified (Just C.DataFunction) (Ident fn))) x) y) + | fn == C.apply -> App a x y + | fn == C.applyFlipped -> App a y x _ -> e - where - dataFunction :: Text - dataFunction = T.replace "_" "." C.dataFunction diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs index 87f3d004ba..16720591a9 100644 --- a/src/Language/PureScript/CoreImp/AST.hs +++ b/src/Language/PureScript/CoreImp/AST.hs @@ -9,6 +9,7 @@ import Data.Text (Text) import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.Comments +import Language.PureScript.Names (ModuleName) import Language.PureScript.PSString (PSString) import Language.PureScript.Traversals @@ -75,6 +76,8 @@ data AST -- ^ Function application | Var (Maybe SourceSpan) Text -- ^ Variable + | ModuleAccessor (Maybe SourceSpan) ModuleName PSString + -- ^ Value from another module | Block (Maybe SourceSpan) [AST] -- ^ A block of expressions in braces | VariableIntroduction (Maybe SourceSpan) Text (Maybe AST) @@ -118,6 +121,7 @@ withSourceSpan withSpan = go where go (Function _ name args j) = Function ss name args j go (App _ j js) = App ss j js go (Var _ s) = Var ss s + go (ModuleAccessor _ s1 s2) = ModuleAccessor ss s1 s2 go (Block _ js) = Block ss js go (VariableIntroduction _ name j) = VariableIntroduction ss name j go (Assignment _ j1 j2) = Assignment ss j1 j2 @@ -145,6 +149,7 @@ getSourceSpan = go where go (Function ss _ _ _) = ss go (App ss _ _) = ss go (Var ss _) = ss + go (ModuleAccessor ss _ _) = ss go (Block ss _) = ss go (VariableIntroduction ss _ _) = ss go (Assignment ss _ _) = ss diff --git a/src/Language/PureScript/CoreImp/Optimizer/Common.hs b/src/Language/PureScript/CoreImp/Optimizer/Common.hs index 8085895e0a..32879e6249 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Common.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Common.hs @@ -9,6 +9,7 @@ import Data.Maybe (fromMaybe) import Language.PureScript.Crash import Language.PureScript.CoreImp.AST +import Language.PureScript.Names (ModuleName) import Language.PureScript.PSString (PSString) applyAll :: [a -> a] -> a -> a @@ -59,10 +60,10 @@ removeFromBlock :: ([AST] -> [AST]) -> AST -> AST removeFromBlock go (Block ss sts) = Block ss (go sts) removeFromBlock _ js = js -isDict :: (Text, PSString) -> AST -> Bool -isDict (moduleName, dictName) (Indexer _ (StringLiteral _ x) (Var _ y)) = - x == dictName && y == moduleName +isDict :: (ModuleName, PSString) -> AST -> Bool +isDict (moduleName, dictName) (ModuleAccessor _ x y) = + x == moduleName && y == dictName isDict _ _ = False -isDict' :: [(Text, PSString)] -> AST -> Bool +isDict' :: [(ModuleName, PSString)] -> AST -> Bool isDict' xs js = any (`isDict` js) xs diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index 8bfa5e5c30..7916cdd262 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -21,6 +21,7 @@ import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as T +import Language.PureScript.Names (ModuleName) import Language.PureScript.PSString (PSString) import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Common @@ -34,6 +35,7 @@ import qualified Language.PureScript.Constants.Prim as C -- Probably needs to be fixed in pretty-printer instead. shouldInline :: AST -> Bool shouldInline (Var _ _) = True +shouldInline (ModuleAccessor _ _ _) = True shouldInline (NumericLiteral _ _) = True shouldInline (StringLiteral _ _) = True shouldInline (BooleanLiteral _ _) = True @@ -98,14 +100,14 @@ inlineCommonValues = everywhere convert | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply x y | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract x y convert other = other - fnZero = (C.dataSemiring, C.zero) - fnOne = (C.dataSemiring, C.one) - fnBottom = (C.dataBounded, C.bottom) - fnTop = (C.dataBounded, C.top) - fnAdd = (C.dataSemiring, C.add) - fnMultiply = (C.dataSemiring, C.mul) - fnSubtract = (C.dataRing, C.sub) - fnNegate = (C.dataRing, C.negate) + fnZero = (C.DataSemiring, C.zero) + fnOne = (C.DataSemiring, C.one) + fnBottom = (C.DataBounded, C.bottom) + fnTop = (C.DataBounded, C.top) + fnAdd = (C.DataSemiring, C.add) + fnMultiply = (C.DataSemiring, C.mul) + fnSubtract = (C.DataRing, C.sub) + fnNegate = (C.DataRing, C.negate) intOp ss op x y = Binary ss BitwiseOr (Binary ss op x y) (NumericLiteral ss (Left 0)) inlineCommonOperators :: AST -> AST @@ -156,50 +158,50 @@ inlineCommonOperators = everywhereTopDown $ applyAll $ , binary heytingAlgebraBoolean opDisj Or , unary heytingAlgebraBoolean opNot Not - , binary' C.dataIntBits C.or BitwiseOr - , binary' C.dataIntBits C.and BitwiseAnd - , binary' C.dataIntBits C.xor BitwiseXor - , binary' C.dataIntBits C.shl ShiftLeft - , binary' C.dataIntBits C.shr ShiftRight - , binary' C.dataIntBits C.zshr ZeroFillShiftRight - , unary' C.dataIntBits C.complement BitwiseNot + , binary' C.DataIntBits C.or BitwiseOr + , binary' C.DataIntBits C.and BitwiseAnd + , binary' C.DataIntBits C.xor BitwiseXor + , binary' C.DataIntBits C.shl ShiftLeft + , binary' C.DataIntBits C.shr ShiftRight + , binary' C.DataIntBits C.zshr ZeroFillShiftRight + , unary' C.DataIntBits C.complement BitwiseNot - , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing) + , inlineNonClassFunction (isModFnWithDict (C.DataArray, C.unsafeIndex)) $ flip (Indexer Nothing) ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++ - [ fn | i <- [0..10], fn <- [ mkEffFn C.controlMonadEffUncurried C.mkEffFn i, runEffFn C.controlMonadEffUncurried C.runEffFn i ] ] ++ - [ fn | i <- [0..10], fn <- [ mkEffFn C.effectUncurried C.mkEffectFn i, runEffFn C.effectUncurried C.runEffectFn i ] ] + [ fn | i <- [0..10], fn <- [ mkEffFn C.ControlMonadEffUncurried C.mkEffFn i, runEffFn C.ControlMonadEffUncurried C.runEffFn i ] ] ++ + [ fn | i <- [0..10], fn <- [ mkEffFn C.EffectUncurried C.mkEffectFn i, runEffFn C.EffectUncurried C.runEffectFn i ] ] where - binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST + binary :: (ModuleName, PSString) -> (ModuleName, PSString) -> BinaryOperator -> AST -> AST binary dict fns op = convert where convert :: AST -> AST convert (App ss (App _ (App _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = Binary ss op x y convert other = other - binary' :: Text -> PSString -> BinaryOperator -> AST -> AST + binary' :: ModuleName -> PSString -> BinaryOperator -> AST -> AST binary' moduleName opString op = convert where convert :: AST -> AST convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op x y convert other = other - unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST + unary :: (ModuleName, PSString) -> (ModuleName, PSString) -> UnaryOperator -> AST -> AST unary dicts fns op = convert where convert :: AST -> AST convert (App ss (App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op x convert other = other - unary' :: Text -> PSString -> UnaryOperator -> AST -> AST + unary' :: ModuleName -> PSString -> UnaryOperator -> AST -> AST unary' moduleName fnName op = convert where convert :: AST -> AST convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op x convert other = other mkFn :: Int -> AST -> AST - mkFn = mkFn' C.dataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args js -> + mkFn = mkFn' C.DataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args js -> Function ss1 Nothing args (Block ss2 [Return ss3 js]) - mkEffFn :: Text -> Text -> Int -> AST -> AST + mkEffFn :: ModuleName -> Text -> Int -> AST -> AST mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args js -> Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 js [])]) - mkFn' :: Text -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST + mkFn' :: ModuleName -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST mkFn' modName fnName res 0 = convert where convert :: AST -> AST convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 js])]) | isNFn modName fnName 0 mkFnN = @@ -217,19 +219,19 @@ inlineCommonOperators = everywhereTopDown $ applyAll $ collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret collectArgs _ _ _ = Nothing - isNFn :: Text -> Text -> Int -> AST -> Bool - isNFn expectMod prefix n (Indexer _ (StringLiteral _ name) (Var _ modName)) | modName == expectMod = + isNFn :: ModuleName -> Text -> Int -> AST -> Bool + isNFn expectMod prefix n (ModuleAccessor _ modName name) | modName == expectMod = name == fromString (T.unpack prefix <> show n) isNFn _ _ _ _ = False runFn :: Int -> AST -> AST - runFn = runFn' C.dataFunctionUncurried C.runFn App + runFn = runFn' C.DataFunctionUncurried C.runFn App - runEffFn :: Text -> Text -> Int -> AST -> AST + runEffFn :: ModuleName -> Text -> Int -> AST -> AST runEffFn modName fnName = runFn' modName fnName $ \ss fn acc -> Function ss Nothing [] (Block ss [Return ss (App ss fn acc)]) - runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST + runFn' :: ModuleName -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST runFn' modName runFnName res n = convert where convert :: AST -> AST convert js = fromMaybe js $ go n [] js @@ -246,8 +248,8 @@ inlineCommonOperators = everywhereTopDown $ applyAll $ convert (App _ (App _ op' [x]) [y]) | p op' = f x y convert other = other - isModFnWithDict :: (Text, PSString) -> AST -> Bool - isModFnWithDict (m, op) (App _ (Indexer _ (StringLiteral _ op') (Var _ m')) [Var _ _]) = + isModFnWithDict :: (ModuleName, PSString) -> AST -> Bool + isModFnWithDict (m, op) (App _ (ModuleAccessor _ m' op') [Var _ _]) = m == m' && op == op' isModFnWithDict _ _ = False @@ -286,126 +288,126 @@ inlineFnComposition = everywhereTopDownM convert where isFnComposeFlipped :: AST -> AST -> Bool isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn - fnCompose :: forall a b. (IsString a, IsString b) => (a, b) - fnCompose = (C.controlSemigroupoid, C.compose) + fnCompose :: forall a. IsString a => (ModuleName, a) + fnCompose = (C.ControlSemigroupoid, C.compose) - fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b) - fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped) + fnComposeFlipped :: forall a. IsString a => (ModuleName, a) + fnComposeFlipped = (C.ControlSemigroupoid, C.composeFlipped) inlineUnsafeCoerce :: AST -> AST inlineUnsafeCoerce = everywhereTopDown convert where - convert (App _ (Indexer _ (StringLiteral _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ]) - | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce + convert (App _ (ModuleAccessor _ C.UnsafeCoerce unsafeCoerceFn) [ comp ]) + | unsafeCoerceFn == C.unsafeCoerceFn = comp convert other = other inlineUnsafePartial :: AST -> AST inlineUnsafePartial = everywhereTopDown convert where - convert (App ss (Indexer _ (StringLiteral _ unsafePartial) (Var _ partialUnsafe)) [ comp ]) - | unsafePartial == C.unsafePartial && partialUnsafe == C.partialUnsafe + convert (App ss (ModuleAccessor _ C.PartialUnsafe unsafePartial) [ comp ]) + | unsafePartial == C.unsafePartial -- Apply to undefined here, the application should be optimized away -- if it is safe to do so = App ss comp [ Var ss C.undefined ] convert other = other -semiringNumber :: forall a b. (IsString a, IsString b) => (a, b) -semiringNumber = (C.dataSemiring, C.semiringNumber) +semiringNumber :: forall a. IsString a => (ModuleName, a) +semiringNumber = (C.DataSemiring, C.semiringNumber) -semiringInt :: forall a b. (IsString a, IsString b) => (a, b) -semiringInt = (C.dataSemiring, C.semiringInt) +semiringInt :: forall a. IsString a => (ModuleName, a) +semiringInt = (C.DataSemiring, C.semiringInt) -ringNumber :: forall a b. (IsString a, IsString b) => (a, b) -ringNumber = (C.dataRing, C.ringNumber) +ringNumber :: forall a. IsString a => (ModuleName, a) +ringNumber = (C.DataRing, C.ringNumber) -ringInt :: forall a b. (IsString a, IsString b) => (a, b) -ringInt = (C.dataRing, C.ringInt) +ringInt :: forall a. IsString a => (ModuleName, a) +ringInt = (C.DataRing, C.ringInt) -euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b) -euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber) +euclideanRingNumber :: forall a. IsString a => (ModuleName, a) +euclideanRingNumber = (C.DataEuclideanRing, C.euclideanRingNumber) -eqNumber :: forall a b. (IsString a, IsString b) => (a, b) -eqNumber = (C.dataEq, C.eqNumber) +eqNumber :: forall a. IsString a => (ModuleName, a) +eqNumber = (C.DataEq, C.eqNumber) -eqInt :: forall a b. (IsString a, IsString b) => (a, b) -eqInt = (C.dataEq, C.eqInt) +eqInt :: forall a. IsString a => (ModuleName, a) +eqInt = (C.DataEq, C.eqInt) -eqString :: forall a b. (IsString a, IsString b) => (a, b) -eqString = (C.dataEq, C.eqString) +eqString :: forall a. IsString a => (ModuleName, a) +eqString = (C.DataEq, C.eqString) -eqChar :: forall a b. (IsString a, IsString b) => (a, b) -eqChar = (C.dataEq, C.eqChar) +eqChar :: forall a. IsString a => (ModuleName, a) +eqChar = (C.DataEq, C.eqChar) -eqBoolean :: forall a b. (IsString a, IsString b) => (a, b) -eqBoolean = (C.dataEq, C.eqBoolean) +eqBoolean :: forall a. IsString a => (ModuleName, a) +eqBoolean = (C.DataEq, C.eqBoolean) -ordBoolean :: forall a b. (IsString a, IsString b) => (a, b) -ordBoolean = (C.dataOrd, C.ordBoolean) +ordBoolean :: forall a. IsString a => (ModuleName, a) +ordBoolean = (C.DataOrd, C.ordBoolean) -ordNumber :: forall a b. (IsString a, IsString b) => (a, b) -ordNumber = (C.dataOrd, C.ordNumber) +ordNumber :: forall a. IsString a => (ModuleName, a) +ordNumber = (C.DataOrd, C.ordNumber) -ordInt :: forall a b. (IsString a, IsString b) => (a, b) -ordInt = (C.dataOrd, C.ordInt) +ordInt :: forall a. IsString a => (ModuleName, a) +ordInt = (C.DataOrd, C.ordInt) -ordString :: forall a b. (IsString a, IsString b) => (a, b) -ordString = (C.dataOrd, C.ordString) +ordString :: forall a. IsString a => (ModuleName, a) +ordString = (C.DataOrd, C.ordString) -ordChar :: forall a b. (IsString a, IsString b) => (a, b) -ordChar = (C.dataOrd, C.ordChar) +ordChar :: forall a. IsString a => (ModuleName, a) +ordChar = (C.DataOrd, C.ordChar) -semigroupString :: forall a b. (IsString a, IsString b) => (a, b) -semigroupString = (C.dataSemigroup, C.semigroupString) +semigroupString :: forall a. IsString a => (ModuleName, a) +semigroupString = (C.DataSemigroup, C.semigroupString) -boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b) -boundedBoolean = (C.dataBounded, C.boundedBoolean) +boundedBoolean :: forall a. IsString a => (ModuleName, a) +boundedBoolean = (C.DataBounded, C.boundedBoolean) -heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b) -heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean) +heytingAlgebraBoolean :: forall a. IsString a => (ModuleName, a) +heytingAlgebraBoolean = (C.DataHeytingAlgebra, C.heytingAlgebraBoolean) -semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b) -semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn) +semigroupoidFn :: forall a. IsString a => (ModuleName, a) +semigroupoidFn = (C.ControlSemigroupoid, C.semigroupoidFn) -opAdd :: forall a b. (IsString a, IsString b) => (a, b) -opAdd = (C.dataSemiring, C.add) +opAdd :: forall a. IsString a => (ModuleName, a) +opAdd = (C.DataSemiring, C.add) -opMul :: forall a b. (IsString a, IsString b) => (a, b) -opMul = (C.dataSemiring, C.mul) +opMul :: forall a. IsString a => (ModuleName, a) +opMul = (C.DataSemiring, C.mul) -opEq :: forall a b. (IsString a, IsString b) => (a, b) -opEq = (C.dataEq, C.eq) +opEq :: forall a. IsString a => (ModuleName, a) +opEq = (C.DataEq, C.eq) -opNotEq :: forall a b. (IsString a, IsString b) => (a, b) -opNotEq = (C.dataEq, C.notEq) +opNotEq :: forall a. IsString a => (ModuleName, a) +opNotEq = (C.DataEq, C.notEq) -opLessThan :: forall a b. (IsString a, IsString b) => (a, b) -opLessThan = (C.dataOrd, C.lessThan) +opLessThan :: forall a. IsString a => (ModuleName, a) +opLessThan = (C.DataOrd, C.lessThan) -opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b) -opLessThanOrEq = (C.dataOrd, C.lessThanOrEq) +opLessThanOrEq :: forall a. IsString a => (ModuleName, a) +opLessThanOrEq = (C.DataOrd, C.lessThanOrEq) -opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b) -opGreaterThan = (C.dataOrd, C.greaterThan) +opGreaterThan :: forall a. IsString a => (ModuleName, a) +opGreaterThan = (C.DataOrd, C.greaterThan) -opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b) -opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq) +opGreaterThanOrEq :: forall a. IsString a => (ModuleName, a) +opGreaterThanOrEq = (C.DataOrd, C.greaterThanOrEq) -opAppend :: forall a b. (IsString a, IsString b) => (a, b) -opAppend = (C.dataSemigroup, C.append) +opAppend :: forall a. IsString a => (ModuleName, a) +opAppend = (C.DataSemigroup, C.append) -opSub :: forall a b. (IsString a, IsString b) => (a, b) -opSub = (C.dataRing, C.sub) +opSub :: forall a. IsString a => (ModuleName, a) +opSub = (C.DataRing, C.sub) -opNegate :: forall a b. (IsString a, IsString b) => (a, b) -opNegate = (C.dataRing, C.negate) +opNegate :: forall a. IsString a => (ModuleName, a) +opNegate = (C.DataRing, C.negate) -opDiv :: forall a b. (IsString a, IsString b) => (a, b) -opDiv = (C.dataEuclideanRing, C.div) +opDiv :: forall a. IsString a => (ModuleName, a) +opDiv = (C.DataEuclideanRing, C.div) -opConj :: forall a b. (IsString a, IsString b) => (a, b) -opConj = (C.dataHeytingAlgebra, C.conj) +opConj :: forall a. IsString a => (ModuleName, a) +opConj = (C.DataHeytingAlgebra, C.conj) -opDisj :: forall a b. (IsString a, IsString b) => (a, b) -opDisj = (C.dataHeytingAlgebra, C.disj) +opDisj :: forall a. IsString a => (ModuleName, a) +opDisj = (C.DataHeytingAlgebra, C.disj) -opNot :: forall a b. (IsString a, IsString b) => (a, b) -opNot = (C.dataHeytingAlgebra, C.not) +opNot :: forall a. IsString a => (ModuleName, a) +opNot = (C.DataHeytingAlgebra, C.not) diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs index 59dc7bc2c8..7b6a1f6f34 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs @@ -6,10 +6,10 @@ import Prelude.Compat import Protolude (ordNub) import Data.Maybe (fromJust, isJust) -import Data.Text (Text) import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Common +import Language.PureScript.Names (ModuleName) import Language.PureScript.PSString (mkString) import qualified Language.PureScript.Constants.Prelude as C @@ -28,15 +28,15 @@ import qualified Language.PureScript.Constants.Prelude as C -- ... -- } magicDoEff :: AST -> AST -magicDoEff = magicDo C.eff C.effDictionaries +magicDoEff = magicDo C.Eff C.effDictionaries magicDoEffect :: AST -> AST -magicDoEffect = magicDo C.effect C.effectDictionaries +magicDoEffect = magicDo C.Effect C.effectDictionaries magicDoST :: AST -> AST -magicDoST = magicDo C.st C.stDictionaries +magicDoST = magicDo C.ST C.stDictionaries -magicDo :: Text -> C.EffectDictionaries -> AST -> AST +magicDo :: ModuleName -> C.EffectDictionaries -> AST -> AST magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert where -- The name of the function block which is added to denote a do block @@ -72,7 +72,7 @@ magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert isBind _ = False -- Check if an expression represents a call to @discard@ isDiscard (App _ (App _ fn [dict1]) [dict2]) - | isDict (C.controlBind, C.discardUnitDictionary) dict1 && + | isDict (C.ControlBind, C.discardUnitDictionary) dict1 && isDict (effectModule, edBindDict) dict2 && isDiscardPoly fn = True isDiscard _ = False @@ -80,13 +80,13 @@ magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True isPure _ = False -- Check if an expression represents the polymorphic >>= function - isBindPoly = isDict (C.controlBind, C.bind) + isBindPoly = isDict (C.ControlBind, C.bind) -- Check if an expression represents the polymorphic pure function - isPurePoly = isDict (C.controlApplicative, C.pure') + isPurePoly = isDict (C.ControlApplicative, C.pure') -- Check if an expression represents the polymorphic discard function - isDiscardPoly = isDict (C.controlBind, C.discard) + isDiscardPoly = isDict (C.ControlBind, C.discard) -- Check if an expression represents a function in the Effect module - isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == effectModule && name == name' + isEffFunc name (ModuleAccessor _ eff name') = eff == effectModule && name == name' isEffFunc _ _ = False applyReturns :: AST -> AST @@ -125,7 +125,7 @@ inlineST = everywhere convertBlock if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref]) convert _ other = other -- Check if an expression represents a function in the ST module - isSTFunc name (Indexer _ (StringLiteral _ name') (Var _ st)) = st == C.st && name == name' + isSTFunc name (ModuleAccessor _ C.ST name') = name == name' isSTFunc _ _ = False -- Find all ST Refs initialized in this block findSTRefsIn = everything (++) isSTRef diff --git a/tests/purs/optimize/4229.out.js b/tests/purs/optimize/4229.out.js new file mode 100644 index 0000000000..3fa9e5659f --- /dev/null +++ b/tests/purs/optimize/4229.out.js @@ -0,0 +1,17 @@ +import * as Data_Unit from "../Data.Unit/index.js"; +import * as Effect_Console from "../Effect.Console/index.js"; +var Control_Bind = /* #__PURE__ */ (function () { + function Control_Bind() { + + }; + Control_Bind.value = new Control_Bind(); + return Control_Bind; +})(); +var main = function __do() { + Data_Unit.unit; + return Effect_Console.log("Done")(); +}; +export { + Control_Bind, + main +}; diff --git a/tests/purs/optimize/4229.purs b/tests/purs/optimize/4229.purs new file mode 100644 index 0000000000..77b2a8c5ff --- /dev/null +++ b/tests/purs/optimize/4229.purs @@ -0,0 +1,13 @@ +module Main where + +import Prelude + +import Effect (Effect) +import Effect.Console (log) + +data X = Control_Bind + +main :: Effect Unit +main = do + pure unit + log "Done" diff --git a/tests/purs/optimize/Foreign.js b/tests/purs/optimize/Foreign.js new file mode 100644 index 0000000000..9d7381d29f --- /dev/null +++ b/tests/purs/optimize/Foreign.js @@ -0,0 +1 @@ +export const foo = 42; diff --git a/tests/purs/optimize/Foreign.out.js b/tests/purs/optimize/Foreign.out.js new file mode 100644 index 0000000000..610605c4ed --- /dev/null +++ b/tests/purs/optimize/Foreign.out.js @@ -0,0 +1,5 @@ +import * as $foreign from "./foreign.js"; +var bar = $foreign.foo; +export { + bar +}; diff --git a/tests/purs/optimize/Foreign.purs b/tests/purs/optimize/Foreign.purs new file mode 100644 index 0000000000..3c496aea24 --- /dev/null +++ b/tests/purs/optimize/Foreign.purs @@ -0,0 +1,5 @@ +module Main (bar) where + +foreign import foo :: Int + +bar = foo diff --git a/tests/purs/passing/4229.purs b/tests/purs/passing/4229.purs new file mode 100644 index 0000000000..4b254a442c --- /dev/null +++ b/tests/purs/passing/4229.purs @@ -0,0 +1,13 @@ +module Main where + +import Effect.Console (log) +import Partial.Unsafe (unsafePartial) + +data X = Prim + +f :: Partial => Int -> Int +f 0 = 0 + +f' = unsafePartial f + +main = log "Done" From 123fc42fbdc040c159261bb391ce7baf9488a36a Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sat, 14 May 2022 03:27:12 -0500 Subject: [PATCH 1460/1580] Update Prim docs for type-level changes; clean up other docs (#4317) Prim docs: update for type-level changes and cleans up other docs For type-level changes * Boolean - clarifies that True/False are kinded by this type * Symbol - provides an example * Int - clarifies the similarities and differences between value-level and type-level literals. For cleanup changes: - Row - provide more details on this kind and include an example - Number - clarify when negative literals must be wrapped in parentheses - String - provide triple-quote literal syntax example; refer to Symbol - Char - wrap referenced types/values in backticks Co-authored-by: Ryan Hendrickson --- CHANGELOG.d/fix_update-prim-docs.md | 1 + src/Language/PureScript/Docs/Prim.hs | 81 ++++++++++++++++++++++------ 2 files changed, 65 insertions(+), 17 deletions(-) create mode 100644 CHANGELOG.d/fix_update-prim-docs.md diff --git a/CHANGELOG.d/fix_update-prim-docs.md b/CHANGELOG.d/fix_update-prim-docs.md new file mode 100644 index 0000000000..8f4f3449b0 --- /dev/null +++ b/CHANGELOG.d/fix_update-prim-docs.md @@ -0,0 +1 @@ +* Update `Prim` docs for Boolean, Int, String/Symbol, Number, Record, and Row \ No newline at end of file diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index e113476459..7a57db813b 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -258,12 +258,22 @@ kindSymbol = primType "Symbol" $ T.unlines , "" , "Construct types of this kind using the same literal syntax as documented" , "for strings." + , "" + , " type Hello :: Symbol" + , " type Hello = \"Hello, world\"" + , "" ] kindRow :: Declaration kindRow = primType "Row" $ T.unlines [ "`Row` is the kind constructor of label-indexed types which map type-level strings to other types." - , "For example, the kind of `Record` is `Row Type -> Type`, mapping field names to values." + , "The most common use of `Row` is `Row Type`, a row mapping labels to basic (of kind `Type`) types:" + , "" + , " type ExampleRow :: Row Type" + , " type ExampleRow = ( name :: String, values :: Array Int )" + , "" + , "This is the kind of `Row` expected by the `Record` type constructor." + , "More advanced row kinds like `Row (Type -> Type)` are used much less frequently." ] function :: Declaration @@ -322,20 +332,46 @@ number :: Declaration number = primType "Number" $ T.unlines [ "A double precision floating point number (IEEE 754)." , "" - , "Construct values of this type with literals:" + , "Construct values of this type with literals." + , "Negative literals must be wrapped in parentheses if the negation sign could be mistaken" + , "for an infix operator:" , "" - , " y = 35.23 :: Number" - , " z = 1.224e6 :: Number" + , " x = 35.23 :: Number" + , " y = -1.224e6 :: Number" + , " z = exp (-1.0) :: Number" ] int :: Declaration int = primType "Int" $ T.unlines - [ "A 32-bit signed integer. See the purescript-integers package for details" + [ "A 32-bit signed integer. See the `purescript-integers` package for details" , "of how this is accomplished when compiling to JavaScript." , "" - , "Construct values of this type with literals:" + , "Construct values of this type with literals. Hexadecimal syntax is supported." + , "Negative literals must be wrapped in parentheses if the negation sign could be mistaken" + , "for an infix operator:" + , "" + , " x = -23 :: Int" + , " y = 0x17 :: Int" + , " z = complement (-24) :: Int" + , "" + , "Integers used as types are considered to have kind `Int`." + , "Unlike value-level `Int`s, which must be representable as a 32-bit signed integer," + , "type-level `Int`s are unbounded. Hexadecimal support is also supported at the type level." + , "" + , " type One :: Int" + , " type One = 1" + , " " + , " type Beyond32BitSignedInt :: Int" + , " type Beyond32BitSignedInt = 2147483648" + , " " + , " type HexInt :: Int" + , " type HexInt = 0x17" + , "" + , "Negative integer literals at the type level must be" + , "wrapped in parentheses if the negation sign could be mistaken for an infix operator." , "" - , " x = 23 :: Int" + , " type NegativeOne = -1" + , " foo :: Proxy (-1) -> ..." ] string :: Declaration @@ -348,26 +384,37 @@ string = primType "String" $ T.unlines , "" , " x = \"hello, world\" :: String" , "" - , "Multi-line string literals are also supported with triple quotes (`\"\"\"`)." + , "Multi-line string literals are also supported with triple quotes (`\"\"\"`):" + , "" + , " x = \"\"\"multi" + , " line\"\"\"" + , "" + , "At the type level, string literals represent types with kind `Symbol`." + , "These types will have kind `String` in a future release:" + , "" + , " type Hello :: Symbol" + , " type Hello = \"Hello, world\"" ] char :: Declaration char = primType "Char" $ T.unlines - [ "A single character (UTF-16 code unit). The JavaScript representation is a" - , "normal String, which is guaranteed to contain one code unit. This means" - , "that astral plane characters (i.e. those with code point values greater" - , "than 0xFFFF) cannot be represented as Char values." - , "" - , "Construct values of this type with literals, using single quotes `'`:" - , "" - , " x = 'a' :: Char" - ] + [ "A single character (UTF-16 code unit). The JavaScript representation is a" + , "normal `String`, which is guaranteed to contain one code unit. This means" + , "that astral plane characters (i.e. those with code point values greater" + , "than `0xFFFF`) cannot be represented as `Char` values." + , "" + , "Construct values of this type with literals, using single quotes `'`:" + , "" + , " x = 'a' :: Char" + ] boolean :: Declaration boolean = primType "Boolean" $ T.unlines [ "A JavaScript Boolean value." , "" , "Construct values of this type with the literals `true` and `false`." + , "" + , "The `True` and `False` types defined in `Prim.Boolean` have this type as their kind." ] partial :: Declaration From 6015fe970f9f0fa0a3ad948335e410d5e8f5ced2 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sat, 14 May 2022 04:41:30 -0500 Subject: [PATCH 1461/1580] Clarify version scheme and what counts as a breaking change (#4318) --- VERSIONING_POLICY.md | 9 +++++++++ purescript.cabal | 1 + 2 files changed, 10 insertions(+) create mode 100644 VERSIONING_POLICY.md diff --git a/VERSIONING_POLICY.md b/VERSIONING_POLICY.md new file mode 100644 index 0000000000..223747f89c --- /dev/null +++ b/VERSIONING_POLICY.md @@ -0,0 +1,9 @@ +# Versioning Policy + +PureScript can be perceived from two different perspectives: +1. PureScript-the-application (e.g. using `purs` to compile code) +1. PureScript-the-library (e.g. building a tool that depends on the [`purescript` package](https://hackage.haskell.org/package/purescript)) + +This project is versioned using [SemVer 2.0.0](https://semver.org/), not [PVP](https://pvp.haskell.org/) because users of PureScript-the-application are the intended audience. Thus, breaking changes to PureScript-the-application are reflected in this project's version. Since `CoreFn` is considered part of PureScript-the-application, a breaking change to that format is reflected in the project version. + +Since PureScript-the-library is used by internal tools like [Try PureScript](https://github.com/purescript/trypurescript) and [Pursuit](https://github.com/purescript/pursuit), it must be published to Hackage as a library. However, PureScript-the-library is considered unstable and can make breaking changes to library users without reflecting that in the version. diff --git a/purescript.cabal b/purescript.cabal index e0440c1c2f..33febbd4cb 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -37,6 +37,7 @@ extra-source-files: INSTALL.md CONTRIBUTORS.md CONTRIBUTING.md + VERSIONING_POLICY.md .hspec source-repository head From 177f5c831035c5c0b18ffea020e71b2bb6f5cd02 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sun, 15 May 2022 14:56:34 -0400 Subject: [PATCH 1462/1580] Prerelease only if sources change (#4324) --- CHANGELOG.d/internal_cd.md | 3 + ci/build.sh | 128 ++++++++++++++++++++++--------------- 2 files changed, 78 insertions(+), 53 deletions(-) diff --git a/CHANGELOG.d/internal_cd.md b/CHANGELOG.d/internal_cd.md index f7c8d1957a..d8439ad23b 100644 --- a/CHANGELOG.d/internal_cd.md +++ b/CHANGELOG.d/internal_cd.md @@ -1 +1,4 @@ * Deploy builds continuously to GitHub and npm + + (Builds triggered by changes that shouldn't affect the published package are + not deployed.) diff --git a/ci/build.sh b/ci/build.sh index 6d1e53ccd9..e528aaabb8 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -37,90 +37,112 @@ fi (echo "::endgroup::"; echo "::group::Set version number for build") 2>/dev/null -pushd npm-package +git fetch --depth=1 origin "v$(npm view purescript@next version)" + +# List of files/folders to use to detect if a new prerelease should be issued. +# Any path that could contain files that affect the built bundles or the +# published npm package should be included here. Paths that no longer exist +# should be deleted. A false positive is not as big a deal as a false negative, +# so err on the side of including stuff. +if git diff --quiet FETCH_HEAD HEAD -- \ + .github/workflows app bundle ci npm-package src \ + purescript.cabal stack.yaml +then + echo "Skipping prerelease because no input affecting the published package was" + echo "changed since the last prerelease" + echo "::set-output name=do-not-prerelease::true" +else + do_prerelease=true +fi -package_version=$(node -pe 'require("./package.json").version') +package_version=$(node -pe 'require("./npm-package/package.json").version') package_release_version=${package_version%%-*} package_prerelease_suffix=${package_version#$package_release_version} -if ! grep -q "\"install-purescript --purs-ver=${package_version//./\\.}\"" package.json +if ! grep -q "\"install-purescript --purs-ver=${package_version//./\\.}\"" npm-package/package.json then echo "Version in npm-package/package.json doesn't match version in install-purescript call" exit 1 fi -if ! grep -q "^version:\\s*${package_release_version//./\\.}$" ../purescript.cabal +if ! grep -q "^version:\\s*${package_release_version//./\\.}$" purescript.cabal then echo "Version in npm-package/package.json doesn't match version in purescript.cabal" exit 1 fi -if ! grep -q "^prerelease = \"${package_prerelease_suffix//./\\.}\"$" ../app/Version.hs +if ! grep -q "^prerelease = \"${package_prerelease_suffix//./\\.}\"$" app/Version.hs then echo "Version in npm-package/package.json doesn't match prerelease in app/Version.hs" exit 1 fi -function largest-matching-git-tag { - grep -E "^${1//./\\.}(\\.|$)" "$git_tags" | head -n 1 -} - -git_tags=$(mktemp) -trap 'rm "$git_tags"' EXIT -git ls-remote --tags -q --sort=-version:refname | sed 's_^.*refs/tags/__' > $git_tags -if [ "$package_prerelease_suffix" ] +if [ "$do_prerelease" ] then - tag=$(largest-matching-git-tag "v$package_release_version${package_prerelease_suffix%%.*}") - if [ "$tag" ] + function largest-matching-git-tag { + grep -E "^${1//./\\.}(\\.|$)" "$git_tags" | head -n 1 + } + + git_tags=$(mktemp) + trap 'rm "$git_tags"' EXIT + git ls-remote --tags -q --sort=-version:refname | sed 's_^.*refs/tags/__' > $git_tags + + pushd npm-package + + if [ "$package_prerelease_suffix" ] then - npm version --allow-same-version "$tag" - build_version=$(npm version --no-git-tag-version prerelease) - build_version=${build_version#v} - else - build_version=$package_version - fi -else # (current version does not contain a prerelease suffix) - if grep -Fqx "v$package_release_version" "$git_tags" - then # (the current version has been published) - bump=patch - if [ "$(find ../CHANGELOG.d -maxdepth 1 -name 'breaking_*' -print -quit)" ] - then - # If we ever reach 1.0, change this to major and uncomment the below - bump=minor - #elif [ "$(find ../CHANGELOG.d -maxdepth 1 -name 'feature_*' -print -quit)" ] - #then - # bump=minor - fi - next_tag=$(npm version --no-git-tag-version "$bump") - tag=$(largest-matching-git-tag "$next_tag-[0-9]+") + tag=$(largest-matching-git-tag "v$package_release_version${package_prerelease_suffix%%.*}") if [ "$tag" ] then npm version --allow-same-version "$tag" build_version=$(npm version --no-git-tag-version prerelease) + build_version=${build_version#v} else - build_version=$(npm version --allow-same-version "$next_tag-0") + build_version=$package_version + fi + else # (current version does not contain a prerelease suffix) + if grep -Fqx "v$package_release_version" "$git_tags" + then # (the current version has been published) + bump=patch + if [ "$(find ../CHANGELOG.d -maxdepth 1 -name 'breaking_*' -print -quit)" ] + then + # If we ever reach 1.0, change this to major and uncomment the below + bump=minor + #elif [ "$(find ../CHANGELOG.d -maxdepth 1 -name 'feature_*' -print -quit)" ] + #then + # bump=minor + fi + next_tag=$(npm version --no-git-tag-version "$bump") + tag=$(largest-matching-git-tag "$next_tag-[0-9]+") + if [ "$tag" ] + then + npm version --allow-same-version "$tag" + build_version=$(npm version --no-git-tag-version prerelease) + else + build_version=$(npm version --allow-same-version "$next_tag-0") + fi + build_version=${build_version#v} + else # (current version has not been published) + build_version=$package_version + echo "::set-output name=do-not-prerelease::true" fi - build_version=${build_version#v} - else # (current version has not been published) - build_version=$package_version - echo "::set-output name=do-not-prerelease::true" fi -fi -echo "::set-output name=version::$build_version" + echo "::set-output name=version::$build_version" -if [ "$build_version" != "$package_version" ] -then - build_release_version=${build_version%%-*} - build_prerelease_suffix=${build_version#$build_release_version} - # We don't need to update the install-purescript command before we build; - # we'll do that when we publish. All we need to update here are the files - # that affect the purs binary. - sed -i -e "s/^\\(version:\\s*\\)${package_release_version//./\\.}/\1$build_release_version/" ../purescript.cabal - sed -i -e "s/^prerelease = \"${package_prerelease_suffix//./\\.}\"$/prerelease = \"${build_prerelease_suffix}\"/" ../app/Version.hs -fi + popd -popd + if [ "$build_version" != "$package_version" ] + then + build_release_version=${build_version%%-*} + build_prerelease_suffix=${build_version#$build_release_version} + # We don't need to update the install-purescript command before we build; + # we'll do that when we publish. All we need to update here are the files + # that affect the purs binary. + sed -i -e "s/^\\(version:\\s*\\)${package_release_version//./\\.}/\1$build_release_version/" purescript.cabal + sed -i -e "s/^prerelease = \"${package_prerelease_suffix//./\\.}\"$/prerelease = \"${build_prerelease_suffix}\"/" app/Version.hs + fi +fi (echo "::endgroup::"; echo "::group::Install snapshot dependencies") 2>/dev/null From 3d7c22f6aa66a1c08b0a931f77ff3bc64a3b18d5 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sun, 15 May 2022 14:57:04 -0400 Subject: [PATCH 1463/1580] Fix crash caused by polykinded instances (#4325) --- CHANGELOG.d/fix_4180.md | 20 ++++++++++++++++++++ src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- tests/purs/passing/4180.purs | 14 ++++++++++++++ 3 files changed, 35 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/fix_4180.md create mode 100644 tests/purs/passing/4180.purs diff --git a/CHANGELOG.d/fix_4180.md b/CHANGELOG.d/fix_4180.md new file mode 100644 index 0000000000..3fbd318af8 --- /dev/null +++ b/CHANGELOG.d/fix_4180.md @@ -0,0 +1,20 @@ +* Fix crash caused by polykinded instances + + A polykinded instance is a class instance where one or more of the type + parameters has an indeterminate kind. For example, the kind of `a` in + + ```purs + instance SomeClass (Proxy a) where ... + ``` + + is indeterminate unless it's somehow used in a constraint or functional + dependency of the instance in a way that determines it. + + The above instance would not have caused the crash; instead, instances needed + to be of the form + + ```purs + instance SomeClass (f a) where ... + ``` + + in order to cause it. diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index d433181743..41fc593b6d 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -889,7 +889,7 @@ checkInstanceDeclaration moduleName (ann, constraints, clsName, args) = do ty' <- checkKind ty E.kindConstraint constraints' <- for constraints checkConstraint allTy <- apply $ foldr srcConstrainedType ty' constraints' - allUnknowns <- unknownsWithKinds . IS.toList $ unknowns allTy + allUnknowns <- unknownsWithKinds . IS.toList . foldMap unknowns . (allTy :) =<< traverse (apply . snd) freeVarsDict let unknownVars = unknownVarNames (usedTypeVariables allTy) allUnknowns let allWithVars = replaceUnknownsWithVars unknownVars allTy let (allConstraints, (_, allKinds, allArgs)) = unapplyTypes <$> unapplyConstraints allWithVars diff --git a/tests/purs/passing/4180.purs b/tests/purs/passing/4180.purs new file mode 100644 index 0000000000..aff735959f --- /dev/null +++ b/tests/purs/passing/4180.purs @@ -0,0 +1,14 @@ +module Main where + +import Effect.Console (log) + +class C (t :: Type) +instance C (f a) + +f :: C (Array String) => Int +f = 0 + +v :: Int +v = f + +main = log "Done" From c984e32126846d2c1dca2ec0db99830c6ad4a492 Mon Sep 17 00:00:00 2001 From: jgart <47760695+jgarte@users.noreply.github.com> Date: Sun, 15 May 2022 14:21:56 -0500 Subject: [PATCH 1464/1580] Add Matrix channel and Libera.Chat channel as unaffiliated spaces (#4292) Co-authored-by: Jordan Martinez --- README.md | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/README.md b/README.md index b26b8d64cd..59ce6231cb 100644 --- a/README.md +++ b/README.md @@ -19,6 +19,15 @@ A small strongly typed programming language with expressive types that compiles ## Help! +### Community Spaces + +The following spaces are governed by the [PureScript Community Code of Conduct](https://github.com/purescript/governance/blob/master/CODE_OF_CONDUCT.md). The majority of PureScript users use these spaces to discuss and collaborate on PureScript-related topics: - [PureScript Discord](https://purescript.org/chat) - [PureScript Discourse](https://discourse.purescript.org/) + +### Unaffiliated Spaces + +Some PureScript users also collaborate in the below spaces. These do not fall under the code of conduct linked above. They may have no code of conduct or one very different than the one linked above. +- [PureScript Matrix](https://matrix.to/#/#purescript:matrix.org) - [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript) +- [The `#purescript` channel on Libera.Chat](https://libera.chat/) From a7ae87fc29cdb6ca57a5b512c3482f11c1e6a1d2 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sun, 15 May 2022 18:21:17 -0400 Subject: [PATCH 1465/1580] Fix incomplete type traversals (#4155) --- CHANGELOG.d/internal_type-traversals.md | 4 + purescript.cabal | 4 + src/Language/PureScript/Errors.hs | 11 ++- .../TypeChecker/Entailment/Coercible.hs | 4 + src/Language/PureScript/Types.hs | 13 ++- tests/Main.hs | 2 + tests/TestAst.hs | 94 +++++++++++++++++++ 7 files changed, 126 insertions(+), 6 deletions(-) create mode 100644 CHANGELOG.d/internal_type-traversals.md create mode 100644 tests/TestAst.hs diff --git a/CHANGELOG.d/internal_type-traversals.md b/CHANGELOG.d/internal_type-traversals.md new file mode 100644 index 0000000000..2bba7424a5 --- /dev/null +++ b/CHANGELOG.d/internal_type-traversals.md @@ -0,0 +1,4 @@ +* Fix incomplete type traversals + + This corrects oversights in some compiler internals that are not known to be + the cause of any user-facing issues. diff --git a/purescript.cabal b/purescript.cabal index 33febbd4cb..a89ba66d1d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -145,6 +145,7 @@ common defaults Glob >=0.10.1 && <0.11, haskeline >=0.8.2 && <0.9, language-javascript ==0.7.0.0, + lens >=4.19.2 && <4.20, lifted-async >=0.10.2.2 && <0.11, lifted-base >=0.2.3.12 && <0.3, memory >=0.15.0 && <0.16, @@ -402,8 +403,10 @@ test-suite tests main-is: Main.hs build-depends: purescript + , generic-random , hspec , HUnit + , newtype , QuickCheck , regex-base build-tool-depends: @@ -422,6 +425,7 @@ test-suite tests Language.PureScript.Ide.Test Language.PureScript.Ide.UsageSpec PscIdeSpec + TestAst TestCompiler TestCoreFn TestCst diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 2d89b49b81..ec030cc6b0 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -429,7 +429,7 @@ unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage unwrapErrorMessage (ErrorMessage _ se) = se replaceUnknowns :: SourceType -> State TypeMap SourceType -replaceUnknowns = everywhereOnTypesM replaceTypes where +replaceUnknowns = everywhereOnTypesTopDownM replaceTypes where replaceTypes :: SourceType -> State TypeMap SourceType replaceTypes (TUnknown ann u) = do m <- get @@ -439,14 +439,17 @@ replaceUnknowns = everywhereOnTypesM replaceTypes where put $ m { umUnknownMap = M.insert u u' (umUnknownMap m), umNextIndex = u' + 1 } return (TUnknown ann u') Just u' -> return (TUnknown ann u') - replaceTypes (Skolem ann name mbK s sko) = do + -- We intentionally remove the kinds from skolems, because they are never + -- presented when pretty-printing. Any unknowns in those kinds shouldn't + -- appear in the list of unknowns unless used somewhere else. + replaceTypes (Skolem ann name _ s sko) = do m <- get case M.lookup s (umSkolemMap m) of Nothing -> do let s' = umNextIndex m put $ m { umSkolemMap = M.insert s (T.unpack name, s', Just (fst ann)) (umSkolemMap m), umNextIndex = s' + 1 } - return (Skolem ann name mbK s' sko) - Just (_, s', _) -> return (Skolem ann name mbK s' sko) + return (Skolem ann name Nothing s' sko) + Just (_, s', _) -> return (Skolem ann name Nothing s' sko) replaceTypes other = return other onTypesInErrorMessage :: (SourceType -> SourceType) -> ErrorMessage -> ErrorMessage diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index bb16e25b62..ba06ea55c7 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -527,6 +527,10 @@ insoluble -> SourceType -> MultipleErrors insoluble k a b = + -- We can erase kind applications when determining whether to show the + -- "Consider adding a type annotation" hint, because annotating kinds to + -- instantiate unknowns in Coercible constraints should never resolve + -- NoInstanceFound errors. errorMessage $ NoInstanceFound (srcConstraint Prim.Coercible [k] [a, b] Nothing) [] (any containsUnknowns [a, b]) -- | Constraints of the form @Coercible a b@ can be solved if the two arguments diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 1be0077735..ca942e543b 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -559,8 +559,10 @@ unknowns = everythingOnTypes (<>) go where go (TUnknown _ u) = IS.singleton u go _ = mempty +-- | Check if a type contains unknowns in a position that is relevant to +-- constraint solving. (Kinds are not.) containsUnknowns :: Type a -> Bool -containsUnknowns = everythingOnTypes (||) go where +containsUnknowns = everythingOnTypes (||) go . eraseKindApps where go :: Type a -> Bool go TUnknown{} = True go _ = False @@ -570,6 +572,8 @@ eraseKindApps = everywhereOnTypes $ \case KindApp _ ty _ -> ty ConstrainedType ann con ty -> ConstrainedType ann (con { constraintKindArgs = [] }) ty + Skolem ann name _ i sc -> + Skolem ann name Nothing i sc other -> other eraseForAllKindAnnotations :: Type a -> Type a @@ -621,6 +625,7 @@ everywhereOnTypes f = go where go (KindApp ann t1 t2) = f (KindApp ann (go t1) (go t2)) go (ForAll ann arg mbK ty sco) = f (ForAll ann arg (go <$> mbK) (go ty) sco) go (ConstrainedType ann c ty) = f (ConstrainedType ann (mapConstraintArgsAll (map go) c) (go ty)) + go (Skolem ann name mbK i sc) = f (Skolem ann name (go <$> mbK) i sc) go (RCons ann name ty rest) = f (RCons ann name (go ty) (go rest)) go (KindedType ann ty k) = f (KindedType ann (go ty) (go k)) go (BinaryNoParensType ann t1 t2 t3) = f (BinaryNoParensType ann (go t1) (go t2) (go t3)) @@ -633,6 +638,7 @@ everywhereOnTypesM f = go where go (KindApp ann t1 t2) = (KindApp ann <$> go t1 <*> go t2) >>= f go (ForAll ann arg mbK ty sco) = (ForAll ann arg <$> traverse go mbK <*> go ty <*> pure sco) >>= f go (ConstrainedType ann c ty) = (ConstrainedType ann <$> overConstraintArgsAll (mapM go) c <*> go ty) >>= f + go (Skolem ann name mbK i sc) = (Skolem ann name <$> traverse go mbK <*> pure i <*> pure sc) >>= f go (RCons ann name ty rest) = (RCons ann name <$> go ty <*> go rest) >>= f go (KindedType ann ty k) = (KindedType ann <$> go ty <*> go k) >>= f go (BinaryNoParensType ann t1 t2 t3) = (BinaryNoParensType ann <$> go t1 <*> go t2 <*> go t3) >>= f @@ -645,11 +651,12 @@ everywhereOnTypesTopDownM f = go <=< f where go (KindApp ann t1 t2) = KindApp ann <$> (f t1 >>= go) <*> (f t2 >>= go) go (ForAll ann arg mbK ty sco) = ForAll ann arg <$> traverse (f >=> go) mbK <*> (f ty >>= go) <*> pure sco go (ConstrainedType ann c ty) = ConstrainedType ann <$> overConstraintArgsAll (mapM (go <=< f)) c <*> (f ty >>= go) + go (Skolem ann name mbK i sc) = Skolem ann name <$> traverse (f >=> go) mbK <*> pure i <*> pure sc go (RCons ann name ty rest) = RCons ann name <$> (f ty >>= go) <*> (f rest >>= go) go (KindedType ann ty k) = KindedType ann <$> (f ty >>= go) <*> (f k >>= go) go (BinaryNoParensType ann t1 t2 t3) = BinaryNoParensType ann <$> (f t1 >>= go) <*> (f t2 >>= go) <*> (f t3 >>= go) go (ParensInType ann t) = ParensInType ann <$> (f t >>= go) - go other = f other + go other = pure other everythingOnTypes :: (r -> r -> r) -> (Type a -> r) -> Type a -> r everythingOnTypes (<+>) f = go where @@ -658,6 +665,7 @@ everythingOnTypes (<+>) f = go where go t@(ForAll _ _ (Just k) ty _) = f t <+> go k <+> go ty go t@(ForAll _ _ _ ty _) = f t <+> go ty go t@(ConstrainedType _ c ty) = foldl (<+>) (f t) (map go (constraintKindArgs c) ++ map go (constraintArgs c)) <+> go ty + go t@(Skolem _ _ (Just k) _ _) = f t <+> go k go t@(RCons _ _ ty rest) = f t <+> go ty <+> go rest go t@(KindedType _ ty k) = f t <+> go ty <+> go k go t@(BinaryNoParensType _ t1 t2 t3) = f t <+> go t1 <+> go t2 <+> go t3 @@ -672,6 +680,7 @@ everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 where go s (ForAll _ _ (Just k) ty _) = go' s k <+> go' s ty go s (ForAll _ _ _ ty _) = go' s ty go s (ConstrainedType _ c ty) = foldl (<+>) r0 (map (go' s) (constraintKindArgs c) ++ map (go' s) (constraintArgs c)) <+> go' s ty + go s (Skolem _ _ (Just k) _ _) = go' s k go s (RCons _ _ ty rest) = go' s ty <+> go' s rest go s (KindedType _ ty k) = go' s ty <+> go' s k go s (BinaryNoParensType _ t1 t2 t3) = go' s t1 <+> go' s t2 <+> go' s t3 diff --git a/tests/Main.hs b/tests/Main.hs index c61dd473d5..5d202bae64 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -7,6 +7,7 @@ import Prelude.Compat import Test.Hspec +import qualified TestAst import qualified TestCompiler import qualified TestCoreFn import qualified TestCst @@ -32,6 +33,7 @@ main = do hspec $ do describe "cst" TestCst.spec + describe "ast" TestAst.spec describe "ide" TestIde.spec beforeAll TestUtils.setupSupportModules $ do describe "compiler" TestCompiler.spec diff --git a/tests/TestAst.hs b/tests/TestAst.hs new file mode 100644 index 0000000000..a7d0439d2e --- /dev/null +++ b/tests/TestAst.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE TypeApplications #-} +module TestAst where + +import Protolude hiding (Constraint, Type, (:+)) + +import Control.Lens ((+~)) +import Control.Newtype (ala') +import Generic.Random +import Test.Hspec +import Test.QuickCheck + +import Language.PureScript.Label +import Language.PureScript.Names +import Language.PureScript.PSString +import Language.PureScript.Types + +spec :: Spec +spec = do + describe "Language.PureScript.Types" $ do + describe "everywhereOnTypes" $ do + everywhereOnTypesSpec everywhereOnTypes + describe "everywhereOnTypesM" $ do + everywhereOnTypesSpec $ ala' Identity everywhereOnTypesM + describe "everywhereOnTypesTopDownM" $ do + everywhereOnTypesSpec $ ala' Identity everywhereOnTypesTopDownM + describe "everythingOnTypes" $ do + everythingOnTypesSpec everythingOnTypes + describe "everythingWithContextOnTypes" $ do + everythingOnTypesSpec $ \f g -> everythingWithContextOnTypes () [] f $ \s -> (s, ) . g + +everywhereOnTypesSpec :: ((Type Int -> Type Int) -> Type Int -> Type Int) -> Spec +everywhereOnTypesSpec everywhereOnTypesUnderTest = do + it "should visit each type once" $ + forAllShrink (genTypeAnnotatedWith (pure 0) (pure 1)) subterms $ \t -> + all (== 1) `isSatisfiedBy` everywhereOnTypesUnderTest (annForType +~ 1) t + +everythingOnTypesSpec :: (([Int] -> [Int] -> [Int]) -> (Type Int -> [Int]) -> Type Int -> [Int]) -> Spec +everythingOnTypesSpec everythingOnTypesUnderTest = do + it "should visit each type once" $ + forAllShrink (genTypeAnnotatedWith (pure 1) (pure 0)) subterms $ \t -> + everythingOnTypesUnderTest (++) (pure . getAnnForType) t === + filter (== 1) (toList t) + + +infixr 0 `isSatisfiedBy` +isSatisfiedBy :: forall a p. Show a => Testable p => (a -> p) -> a -> Property +isSatisfiedBy = liftA2 counterexample show + +genTypeAnnotatedWith :: forall a. Gen a -> Gen a -> Gen (Type a) +genTypeAnnotatedWith genTypeAnn genConstraintAnn = genType where + generatorEnvironment + = genConstraint + :+ maybeOf genConstraintData + :+ Label <$> genPSString + :+ genPSString + :+ genQualified (OpName @'TypeOpName) + :+ genQualified (ProperName @'ClassName) + :+ genQualified (ProperName @'TypeName) + :+ genSkolemScope + :+ maybeOf genSkolemScope + :+ genText + :+ listOf' (listOf' genText) + :+ maybeOf genText + :+ genType + :+ listOf' genType + :+ maybeOf genType + :+ genWildcardData + + genConstraint :: Gen (Constraint a) + genConstraint = genericArbitraryUG (genConstraintAnn :+ generatorEnvironment) + + genConstraintData :: Gen ConstraintData + genConstraintData = genericArbitraryUG generatorEnvironment + + genQualified :: forall b. (Text -> b) -> Gen (Qualified b) + genQualified ctor = Qualified Nothing . ctor <$> genText + + genSkolemScope :: Gen SkolemScope + genSkolemScope = SkolemScope <$> arbitrary + + genType :: Gen (Type a) + genType = genericArbitraryRecG (genTypeAnn :+ generatorEnvironment) uniform `withBaseCase` (TypeVar <$> genTypeAnn <*> genText) + + genWildcardData :: Gen WildcardData + genWildcardData = genericArbitraryUG genText + + maybeOf :: forall b. Gen b -> Gen (Maybe b) + maybeOf = genericArbitraryUG + + genText :: Gen Text + genText = pure "x" -- Feel free to make this random if it matters at some point. + + genPSString :: Gen PSString + genPSString = pure "x" -- Ditto. From 20d6c6c6bc598b6f49026391c20e1d99b47454b5 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sun, 15 May 2022 18:21:49 -0400 Subject: [PATCH 1466/1580] Move most instance deriving into the type checker (#4315) --- CHANGELOG.d/feature_3510.md | 1 + CHANGELOG.d/fix_3453.md | 3 + CHANGELOG.d/fix_4105.md | 3 + CHANGELOG.d/fix_4200.md | 3 + purescript.cabal | 2 + src/Language/PureScript/AST/Declarations.hs | 12 +- src/Language/PureScript/AST/Utils.hs | 49 ++ src/Language/PureScript/Constants/Prelude.hs | 35 +- src/Language/PureScript/Linter.hs | 1 + src/Language/PureScript/Pretty/Values.hs | 1 + src/Language/PureScript/Sugar.hs | 28 +- src/Language/PureScript/Sugar/TypeClasses.hs | 33 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 608 ++---------------- src/Language/PureScript/TypeChecker.hs | 3 +- .../PureScript/TypeChecker/Deriving.hs | 431 +++++++++++++ src/Language/PureScript/TypeChecker/Types.hs | 8 +- tests/purs/failing/2616.out | 4 +- tests/purs/failing/3405.out | 13 +- tests/purs/failing/3405.purs | 2 +- tests/purs/failing/3453.out | 11 + tests/purs/failing/3453.purs | 8 + tests/purs/failing/3510.out | 18 + tests/purs/failing/3510.purs | 7 + tests/purs/failing/InvalidDerivedInstance.out | 16 +- .../purs/failing/InvalidDerivedInstance.purs | 2 +- .../purs/failing/InvalidDerivedInstance2.out | 21 +- .../purs/failing/InvalidDerivedInstance2.purs | 2 +- .../purs/failing/InvalidDerivedInstance3.out | 4 + tests/purs/failing/NewtypeInstance.out | 2 + tests/purs/failing/NewtypeInstance2.out | 11 +- tests/purs/failing/NewtypeInstance3.out | 2 + tests/purs/failing/NewtypeInstance4.out | 2 + tests/purs/failing/NewtypeInstance5.out | 2 + tests/purs/failing/NewtypeInstance6.out | 25 +- tests/purs/failing/NewtypeInstance6.purs | 2 +- tests/purs/failing/NewtypeUnnamedInstance.out | 14 + .../purs/failing/NewtypeUnnamedInstance.purs | 8 + tests/purs/passing/3510.purs | 11 + tests/purs/passing/4105.purs | 12 + tests/purs/passing/4105/Lib.purs | 5 + tests/purs/passing/4200.purs | 11 + tests/purs/passing/4200/Lib.purs | 7 + tests/purs/passing/NewtypeInstance.purs | 7 + tests/purs/warning/NewtypeInstance.out | 2 + tests/purs/warning/NewtypeInstance2.out | 13 +- tests/purs/warning/NewtypeInstance3.out | 13 +- tests/purs/warning/NewtypeInstance4.out | 13 +- 47 files changed, 847 insertions(+), 644 deletions(-) create mode 100644 CHANGELOG.d/feature_3510.md create mode 100644 CHANGELOG.d/fix_3453.md create mode 100644 CHANGELOG.d/fix_4105.md create mode 100644 CHANGELOG.d/fix_4200.md create mode 100644 src/Language/PureScript/AST/Utils.hs create mode 100644 src/Language/PureScript/TypeChecker/Deriving.hs create mode 100644 tests/purs/failing/3453.out create mode 100644 tests/purs/failing/3453.purs create mode 100644 tests/purs/failing/3510.out create mode 100644 tests/purs/failing/3510.purs create mode 100644 tests/purs/failing/NewtypeUnnamedInstance.out create mode 100644 tests/purs/failing/NewtypeUnnamedInstance.purs create mode 100644 tests/purs/passing/3510.purs create mode 100644 tests/purs/passing/4105.purs create mode 100644 tests/purs/passing/4105/Lib.purs create mode 100644 tests/purs/passing/4200.purs create mode 100644 tests/purs/passing/4200/Lib.purs diff --git a/CHANGELOG.d/feature_3510.md b/CHANGELOG.d/feature_3510.md new file mode 100644 index 0000000000..819e172a0a --- /dev/null +++ b/CHANGELOG.d/feature_3510.md @@ -0,0 +1 @@ +* Support deriving instances for type synonyms diff --git a/CHANGELOG.d/fix_3453.md b/CHANGELOG.d/fix_3453.md new file mode 100644 index 0000000000..8875dd004a --- /dev/null +++ b/CHANGELOG.d/fix_3453.md @@ -0,0 +1,3 @@ +* Fix bad interaction between newtype deriving and type synonyms + + See #3453. diff --git a/CHANGELOG.d/fix_4105.md b/CHANGELOG.d/fix_4105.md new file mode 100644 index 0000000000..064264fdcb --- /dev/null +++ b/CHANGELOG.d/fix_4105.md @@ -0,0 +1,3 @@ +* Fix bad interaction between instance deriving and type synonyms + + See #4105. diff --git a/CHANGELOG.d/fix_4200.md b/CHANGELOG.d/fix_4200.md new file mode 100644 index 0000000000..dc14953b50 --- /dev/null +++ b/CHANGELOG.d/fix_4200.md @@ -0,0 +1,3 @@ +* Fix spurious kind unification error triggered by newtype deriving, type synonyms, and polykinds + + See #4200. diff --git a/purescript.cabal b/purescript.cabal index a89ba66d1d..d0f1ec2293 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -197,6 +197,7 @@ library Language.PureScript.AST.Operators Language.PureScript.AST.SourcePos Language.PureScript.AST.Traversals + Language.PureScript.AST.Utils Language.PureScript.Bundle Language.PureScript.CodeGen Language.PureScript.CodeGen.JS @@ -341,6 +342,7 @@ library Language.PureScript.Sugar.TypeDeclarations Language.PureScript.Traversals Language.PureScript.TypeChecker + Language.PureScript.TypeChecker.Deriving Language.PureScript.TypeChecker.Entailment Language.PureScript.TypeChecker.Entailment.Coercible Language.PureScript.TypeChecker.Entailment.IntCompare diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 71be7ba99d..30d564c117 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -441,15 +441,17 @@ pattern ValueFixityDeclaration sa fixity name op = FixityDeclaration sa (Left (V pattern TypeFixityDeclaration :: SourceAnn -> Fixity -> Qualified (ProperName 'TypeName) -> OpName 'TypeOpName -> Declaration pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (TypeFixity fixity name op)) +data InstanceDerivationStrategy + = KnownClassStrategy + | NewtypeStrategy + deriving (Show) + -- | The members of a type class instance declaration data TypeInstanceBody = DerivedInstance -- ^ This is a derived instance | NewtypeInstance -- ^ This is an instance derived from a newtype - | NewtypeInstanceWithDictionary Expr - -- ^ This is an instance derived from a newtype, desugared to include a - -- dictionary for the type under the newtype. | ExplicitInstance [Declaration] -- ^ This is a regular (explicit) instance deriving (Show) @@ -725,6 +727,10 @@ data Expr -- | DeferredDictionary (Qualified (ProperName 'ClassName)) [SourceType] -- | + -- A placeholder for a type class instance to be derived during typechecking + -- + | DerivedInstancePlaceholder (Qualified (ProperName 'ClassName)) InstanceDerivationStrategy + -- | -- A placeholder for an anonymous function argument -- | AnonymousArgument diff --git a/src/Language/PureScript/AST/Utils.hs b/src/Language/PureScript/AST/Utils.hs new file mode 100644 index 0000000000..638ce26f0d --- /dev/null +++ b/src/Language/PureScript/AST/Utils.hs @@ -0,0 +1,49 @@ +module Language.PureScript.AST.Utils where + +import Protolude + +import Language.PureScript.AST +import Language.PureScript.Names +import Language.PureScript.Types + +lam :: Ident -> Expr -> Expr +lam = Abs . mkBinder + +lamCase :: Ident -> [CaseAlternative] -> Expr +lamCase s = lam s . Case [mkVar s] + +lamCase2 :: Ident -> Ident -> [CaseAlternative] -> Expr +lamCase2 s t = lam s . lam t . Case [mkVar s, mkVar t] + +mkRef :: Qualified Ident -> Expr +mkRef = Var nullSourceSpan + +mkVarMn :: Maybe ModuleName -> Ident -> Expr +mkVarMn mn = mkRef . Qualified mn + +mkVar :: Ident -> Expr +mkVar = mkVarMn Nothing + +mkBinder :: Ident -> Binder +mkBinder = VarBinder nullSourceSpan + +mkLit :: Literal Expr -> Expr +mkLit = Literal nullSourceSpan + +mkCtor :: ModuleName -> ProperName 'ConstructorName -> Expr +mkCtor mn name = Constructor nullSourceSpan (Qualified (Just mn) name) + +mkCtorBinder :: ModuleName -> ProperName 'ConstructorName -> [Binder] -> Binder +mkCtorBinder mn name = ConstructorBinder nullSourceSpan (Qualified (Just mn) name) + +unguarded :: Expr -> [GuardedExpr] +unguarded e = [MkUnguarded e] + +unwrapTypeConstructor :: SourceType -> Maybe (Qualified (ProperName 'TypeName), [SourceType], [SourceType]) +unwrapTypeConstructor = go [] [] + where + go kargs args = \case + TypeConstructor _ tyCon -> Just (tyCon, kargs, args) + TypeApp _ ty arg -> go kargs (arg : args) ty + KindApp _ ty karg -> go (karg : kargs) args ty + _ -> Nothing diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index 57e9a8b8ca..99ff5aa1fc 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -1,7 +1,7 @@ -- | Various constants which refer to things in the Prelude module Language.PureScript.Constants.Prelude where -import Prelude.Compat +import Prelude.Compat hiding (compare, map) import Data.String (IsString) import Language.PureScript.PSString (PSString) @@ -339,9 +339,42 @@ pattern DataHeytingAlgebra = ModuleName "Data.HeytingAlgebra" pattern DataEq :: ModuleName pattern DataEq = ModuleName "Data.Eq" +pattern Eq :: Qualified (ProperName 'ClassName) +pattern Eq = Qualified (Just DataEq) (ProperName "Eq") + +pattern Eq1 :: Qualified (ProperName 'ClassName) +pattern Eq1 = Qualified (Just DataEq) (ProperName "Eq1") + +identEq :: Qualified Ident +identEq = Qualified (Just DataEq) (Ident eq) + +identEq1 :: Qualified Ident +identEq1 = Qualified (Just DataEq) (Ident eq1) + pattern DataOrd :: ModuleName pattern DataOrd = ModuleName "Data.Ord" +pattern Ord :: Qualified (ProperName 'ClassName) +pattern Ord = Qualified (Just DataOrd) (ProperName "Ord") + +pattern Ord1 :: Qualified (ProperName 'ClassName) +pattern Ord1 = Qualified (Just DataOrd) (ProperName "Ord1") + +identCompare :: Qualified Ident +identCompare = Qualified (Just DataOrd) (Ident compare) + +identCompare1 :: Qualified Ident +identCompare1 = Qualified (Just DataOrd) (Ident compare1) + +pattern DataFunctor :: ModuleName +pattern DataFunctor = ModuleName "Data.Functor" + +pattern Functor :: Qualified (ProperName 'ClassName) +pattern Functor = Qualified (Just DataFunctor) (ProperName "Functor") + +identMap :: Qualified Ident +identMap = Qualified (Just DataFunctor) (Ident map) + pattern DataSemiring :: ModuleName pattern DataSemiring = ModuleName "Data.Semiring" diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 8b1bf2d7d2..74b538d311 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -235,6 +235,7 @@ lintUnused (Module modSS _ mn modDecls exports) = go (Constructor _ _) = mempty go (TypeClassDictionary _ _ _) = mempty go (DeferredDictionary _ _) = mempty + go (DerivedInstancePlaceholder _ _) = mempty go AnonymousArgument = mempty go (Hole _) = mempty diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index f911dd7fc5..31002baf22 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -87,6 +87,7 @@ prettyPrintValue d (Ado m els yield) = -- TODO: constraint kind args prettyPrintValue d (TypeClassDictionary (Constraint _ name _ tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ T.unpack (runProperName (disqualify name))) : map (typeAtomAsBox d) tys prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ T.unpack (runProperName (disqualify name)) +prettyPrintValue _ (DerivedInstancePlaceholder name _) = text $ "#derived " ++ T.unpack (runProperName (disqualify name)) prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val prettyPrintValue d (Literal _ l) = prettyPrintLiteralValue d l diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 52a33486b6..91bbc4624e 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -3,23 +3,17 @@ -- module Language.PureScript.Sugar (desugar, module S) where -import Prelude - import Control.Category ((>>>)) import Control.Monad import Control.Monad.Error.Class (MonadError) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.State.Class (MonadState) import Control.Monad.Writer.Class (MonadWriter) -import Data.Maybe (mapMaybe) - -import qualified Data.Map as M import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Externs import Language.PureScript.Linter.Imports -import Language.PureScript.Names import Language.PureScript.Sugar.BindingGroups as S import Language.PureScript.Sugar.CaseDeclarations as S import Language.PureScript.Sugar.DoNotation as S @@ -31,7 +25,6 @@ import Language.PureScript.Sugar.Operators as S import Language.PureScript.Sugar.TypeClasses as S import Language.PureScript.Sugar.TypeClasses.Deriving as S import Language.PureScript.Sugar.TypeDeclarations as S -import Language.PureScript.TypeChecker.Synonyms (SynonymMap) -- | -- The desugaring pipeline proceeds as follows: @@ -77,25 +70,6 @@ desugar externs = >=> desugarImports >=> rebracket externs >=> checkFixityExports - >=> (\m -> - -- We need to collect type synonym information, since synonyms will not be - -- removed until later, during type checking. - let syns = findTypeSynonyms externs (getModuleName m) $ getModuleDeclarations m - -- We cannot prevent ill-kinded expansions of type synonyms without - -- knowing their kinds but they're not available yet. - kinds = mempty - in deriveInstances externs syns kinds m) + >=> deriveInstances >=> desugarTypeClasses externs >=> createBindingGroupsModule - -findTypeSynonyms :: [ExternsFile] -> ModuleName -> [Declaration] -> SynonymMap -findTypeSynonyms externs mn decls = - M.fromList $ (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) - ++ mapMaybe fromLocalDecl decls - where - fromExternsDecl mn' (EDTypeSynonym name args ty) = Just (Qualified (Just mn') name, (args, ty)) - fromExternsDecl _ _ = Nothing - - fromLocalDecl (TypeSynonymDeclaration _ name args ty) = - Just (Qualified (Just mn) name, (args, ty)) - fromLocalDecl _ = Nothing diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 35b938b83f..8c376ffd84 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -206,22 +206,27 @@ desugarDecl mn exps = go go d@(TypeClassDeclaration sa name args implies deps members) = do modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False)) return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) - go (TypeInstanceDeclaration _ _ _ _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" - go (TypeInstanceDeclaration sa chainId idx name deps className tys (ExplicitInstance members)) - | className == C.Coercible - = throwError . errorMessage' (fst sa) $ InvalidCoercibleInstanceDeclaration tys - | otherwise = do - desugared <- desugarCases members + go (TypeInstanceDeclaration sa chainId idx name deps className tys body) = do name' <- desugarInstName name - dictDecl <- typeInstanceDictionaryDeclaration sa name' mn deps className tys desugared - let d = TypeInstanceDeclaration sa chainId idx (Right name') deps className tys (ExplicitInstance members) + let d = TypeInstanceDeclaration sa chainId idx (Right name') deps className tys body + let explicitOrNot = case body of + DerivedInstance -> Left $ DerivedInstancePlaceholder className KnownClassStrategy + NewtypeInstance -> Left $ DerivedInstancePlaceholder className NewtypeStrategy + ExplicitInstance members -> Right members + dictDecl <- case explicitOrNot of + Right members + | className == C.Coercible -> + throwError . errorMessage' (fst sa) $ InvalidCoercibleInstanceDeclaration tys + | otherwise -> do + desugared <- desugarCases members + typeInstanceDictionaryDeclaration sa name' mn deps className tys desugared + Left dict -> + let + dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictTypeName) className)) tys + constrainedTy = quantify (foldr srcConstrainedType dictTy deps) + in + return $ ValueDecl sa name' Private [] [MkUnguarded (TypedValue True dict constrainedTy)] return (expRef name' className tys, [d, dictDecl]) - go (TypeInstanceDeclaration sa chainId idx name deps className tys (NewtypeInstanceWithDictionary dict)) = do - name' <- desugarInstName name - let dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictTypeName) className)) tys - constrainedTy = quantify (foldr srcConstrainedType dictTy deps) - d = TypeInstanceDeclaration sa chainId idx (Right name') deps className tys (NewtypeInstanceWithDictionary dict) - return (expRef name' className tys, [d, ValueDecl sa name' Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) go other = return (Nothing, [other]) -- | diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 7f5a25eceb..923278005e 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -2,297 +2,92 @@ module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where import Prelude.Compat -import Protolude (ordNub) +import Protolude (note) -import Control.Arrow (second) -import Control.Monad (replicateM, zipWithM, unless, when) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Supply.Class (MonadSupply) -import Data.Foldable (for_) -import Data.List (foldl', find, sortOn, unzip5) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import qualified Data.Set as S -import Data.Text (Text) +import Data.List (foldl', find, unzip5) import Language.PureScript.AST +import Language.PureScript.AST.Utils import qualified Language.PureScript.Constants.Data.Generic.Rep as DataGenericRep import qualified Language.PureScript.Constants.Data.Newtype as DataNewtype -import qualified Language.PureScript.Constants.Prelude as Prelude -import qualified Language.PureScript.Constants.Prim as Prim import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors -import Language.PureScript.Externs import Language.PureScript.Names -import Language.PureScript.Label (Label(..)) import Language.PureScript.PSString (mkString) import Language.PureScript.Types import Language.PureScript.TypeChecker (checkNewtype) -import Language.PureScript.TypeChecker.Synonyms (SynonymMap, KindMap, replaceAllTypeSynonymsM) - --- | When deriving an instance for a newtype, we must ensure that all superclass --- instances were derived in the same way. This data structure is used to ensure --- this property. -data NewtypeDerivedInstances = NewtypeDerivedInstances - { ndiClasses :: M.Map (ModuleName, ProperName 'ClassName) ([Text], [SourceConstraint], [FunctionalDependency]) - -- ^ A list of superclass constraints for each type class. Since type classes - -- have not been desugared here, we need to track this. - , ndiDerivedInstances :: S.Set ((ModuleName, ProperName 'ClassName), (ModuleName, ProperName 'TypeName)) - -- ^ A list of newtype instances which were derived in this module. - } deriving Show - -instance Semigroup NewtypeDerivedInstances where - x <> y = - NewtypeDerivedInstances { ndiClasses = ndiClasses x <> ndiClasses y - , ndiDerivedInstances = ndiDerivedInstances x <> ndiDerivedInstances y - } - -instance Monoid NewtypeDerivedInstances where - mempty = NewtypeDerivedInstances mempty mempty - --- | Extract the name of the newtype appearing in the last type argument of --- a derived newtype instance. --- --- Note: since newtypes in newtype instances can only be applied to type arguments --- (no flexible instances allowed), we don't need to bother with unification when --- looking for matching superclass instances, which saves us a lot of work. Instead, --- we just match the newtype name. -extractNewtypeName :: ModuleName -> [SourceType] -> Maybe (ModuleName, ProperName 'TypeName) -extractNewtypeName _ [] = Nothing -extractNewtypeName mn xs = go (last xs) where - go (TypeApp _ ty (TypeVar _ _)) = go ty - go (TypeConstructor _ name) = Just (qualify mn name) - go _ = Nothing -- | Elaborates deriving instance declarations by code generation. deriveInstances :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) - => [ExternsFile] - -> SynonymMap - -> KindMap - -> Module + . (MonadError MultipleErrors m, MonadSupply m) + => Module -> m Module -deriveInstances externs syns kinds (Module ss coms mn ds exts) = - Module ss coms mn <$> mapM (deriveInstance mn syns kinds instanceData ds) ds <*> pure exts - where - instanceData :: NewtypeDerivedInstances - instanceData = - foldMap (\ExternsFile{..} -> foldMap (fromExternsDecl efModuleName) efDeclarations) externs <> foldMap fromLocalDecl ds - where - fromExternsDecl mn' EDClass{..} = - NewtypeDerivedInstances (M.singleton (mn', edClassName) (map fst edClassTypeArguments, edClassConstraints, edFunctionalDependencies)) mempty - fromExternsDecl mn' EDInstance{..} = - foldMap (\nm -> NewtypeDerivedInstances mempty (S.singleton (qualify mn' edInstanceClassName, nm))) (extractNewtypeName mn' edInstanceTypes) - fromExternsDecl _ _ = mempty - - fromLocalDecl (TypeClassDeclaration _ cl args cons deps _) = - NewtypeDerivedInstances (M.singleton (mn, cl) (map fst args, cons, deps)) mempty - fromLocalDecl (TypeInstanceDeclaration _ _ _ _ _ cl tys _) = - foldMap (\nm -> NewtypeDerivedInstances mempty (S.singleton (qualify mn cl, nm))) (extractNewtypeName mn tys) - fromLocalDecl _ = mempty +deriveInstances (Module ss coms mn ds exts) = + Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts -- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration, -- elaborates that into an instance declaration via code generation. +-- +-- More instance deriving happens during type checking. The instances +-- derived here are special for two reasons: +-- * they depend only on the structure of the data, not types; and +-- * they expect wildcard types from the user and generate type expressions +-- to replace them. +-- deriveInstance - :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadSupply m) + :: forall m + . (MonadError MultipleErrors m, MonadSupply m) => ModuleName - -> SynonymMap - -> KindMap - -> NewtypeDerivedInstances -> [Declaration] -> Declaration -> m Declaration -deriveInstance mn syns kinds _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys DerivedInstance) - | className == Qualified (Just dataEq) (ProperName "Eq") - = case tys of - [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty - , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveEq ss mn syns kinds ds tyCon - | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty - _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 - | className == Qualified (Just dataEq) (ProperName "Eq1") - = case tys of - [ty] | Just (Qualified mn' _, _) <- unwrapTypeConstructor ty - , mn == fromMaybe mn mn' - -> pure . TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance $ deriveEq1 ss - | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty - _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 - | className == Qualified (Just dataOrd) (ProperName "Ord") - = case tys of - [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty - , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveOrd ss mn syns kinds ds tyCon - | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty - _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 - | className == Qualified (Just dataOrd) (ProperName "Ord1") - = case tys of - [ty] | Just (Qualified mn' _, _) <- unwrapTypeConstructor ty - , mn == fromMaybe mn mn' - -> pure . TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance $ deriveOrd1 ss - | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty - _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 - | className == Qualified (Just dataFunctor) (ProperName "Functor") - = case tys of - [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty - , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveFunctor ss mn syns kinds ds tyCon - | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty - _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 - | className == DataNewtype.Newtype - = case tys of - [wrappedTy, unwrappedTy] - | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy - , mn == fromMaybe mn mn' - -> do actualUnwrappedTy <- deriveNewtype ss syns kinds ds tyCon args unwrappedTy - return $ TypeInstanceDeclaration sa ch idx nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance []) - | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys wrappedTy - _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 - | className == DataGenericRep.Generic - = case tys of - [actualTy, repTy] - | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy - , mn == fromMaybe mn mn' - -> do (inst, inferredRepTy) <- deriveGenericRep ss mn syns kinds ds tyCon args repTy - return $ TypeInstanceDeclaration sa ch idx nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) - | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys actualTy - _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 - | otherwise = throwError . errorMessage' ss $ CannotDerive className tys -deriveInstance mn syns kinds ndis ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys NewtypeInstance) = - case tys of - _ : _ | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys) - , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration sa ch idx nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance ss mn syns kinds ndis className ds tys tyCon args - | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys (last tys) - _ -> throwError . errorMessage' ss $ InvalidNewtypeInstance className tys -deriveInstance _ _ _ _ _ e = return e - -unwrapTypeConstructor :: SourceType -> Maybe (Qualified (ProperName 'TypeName), [SourceType]) -unwrapTypeConstructor = fmap (second reverse) . go - where - go (TypeConstructor _ tyCon) = Just (tyCon, []) - go (TypeApp _ ty arg) = do - (tyCon, args) <- go ty - return (tyCon, arg : args) - go _ = Nothing - -deriveNewtypeInstance - :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => SourceSpan - -> ModuleName - -> SynonymMap - -> KindMap - -> NewtypeDerivedInstances - -> Qualified (ProperName 'ClassName) - -> [Declaration] - -> [SourceType] - -> ProperName 'TypeName - -> [SourceType] - -> m Expr -deriveNewtypeInstance ss mn syns kinds ndis className ds tys tyConNm dargs = do - verifySuperclasses - tyCon <- findTypeDecl ss tyConNm ds - go tyCon - where - go (DataDeclaration _ Newtype _ tyArgNames [DataConstructorDeclaration _ _ [(_, wrapped)]]) = do - -- The newtype might not be applied to all type arguments. - -- This is okay as long as the newtype wraps something which ends with - -- sufficiently many type applications to variables. - -- For example, we can derive Functor for - -- - -- newtype MyArray a = MyArray (Array a) - -- - -- since Array a is a type application which uses the last - -- type argument - wrapped' <- replaceAllTypeSynonymsM syns kinds wrapped - case stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped' of - Just wrapped'' -> do - let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs - wrapped''' <- replaceAllTypeSynonymsM syns kinds $ replaceAllTypeVars subst wrapped'' - tys' <- mapM (replaceAllTypeSynonymsM syns kinds) tys - return (DeferredDictionary className (init tys' ++ [wrapped'''])) - Nothing -> throwError . errorMessage' ss $ InvalidNewtypeInstance className tys - go _ = throwError . errorMessage' ss $ InvalidNewtypeInstance className tys - - takeReverse :: Int -> [a] -> [a] - takeReverse n = take n . reverse - - stripRight :: [(Text, Maybe kind)] -> SourceType -> Maybe SourceType - stripRight [] ty = Just ty - stripRight ((arg, _) : args) (TypeApp _ t (TypeVar _ arg')) - | arg == arg' = stripRight args t - stripRight _ _ = Nothing - - verifySuperclasses :: m () - verifySuperclasses = - for_ (M.lookup (qualify mn className) (ndiClasses ndis)) $ \(args, superclasses, _) -> - for_ superclasses $ \Constraint{..} -> do - let constraintClass' = qualify (error "verifySuperclasses: unknown class module") constraintClass - for_ (M.lookup constraintClass' (ndiClasses ndis)) $ \(_, _, deps) -> - -- We need to check whether the newtype is mentioned, because of classes like MonadWriter - -- with its Monoid superclass constraint. - when (not (null args) && any ((last args `elem`) . usedTypeVariables) constraintArgs) $ do - -- For now, we only verify superclasses where the newtype is the only argument, - -- or for which all other arguments are determined by functional dependencies. - -- Everything else raises a UnverifiableSuperclassInstance warning. - -- This covers pretty much all cases we're interested in, but later we might want to do - -- more work to extend this to other superclass relationships. - let determined = map (srcTypeVar . (args !!)) . ordNub . concatMap fdDetermined . filter ((== [length args - 1]) . fdDeterminers) $ deps - if eqType (last constraintArgs) (srcTypeVar (last args)) && all (`elem` determined) (init constraintArgs) - then do - -- Now make sure that a superclass instance was derived. Again, this is not a complete - -- check, since the superclass might have multiple type arguments, so overlaps might still - -- be possible, so we warn again. - for_ (extractNewtypeName mn tys) $ \nm -> - unless ((constraintClass', nm) `S.member` ndiDerivedInstances ndis) $ - tell . errorMessage' ss $ MissingNewtypeSuperclassInstance constraintClass className tys - else tell . errorMessage' ss $ UnverifiableSuperclassInstance constraintClass className tys - -dataEq :: ModuleName -dataEq = ModuleName "Data.Eq" - -dataOrd :: ModuleName -dataOrd = ModuleName "Data.Ord" - -dataFunctor :: ModuleName -dataFunctor = ModuleName "Data.Functor" - -unguarded :: Expr -> [GuardedExpr] -unguarded e = [MkUnguarded e] +deriveInstance mn ds decl = + case decl of + TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys DerivedInstance -> let + binaryWildcardClass :: (Declaration -> [SourceType] -> m ([Declaration], SourceType)) -> m Declaration + binaryWildcardClass f = case tys of + [ty1, ty2] -> case unwrapTypeConstructor ty1 of + Just (Qualified (Just mn') tyCon, _, args) | mn == mn' -> do + checkIsWildcard ss tyCon ty2 + tyConDecl <- findTypeDecl ss tyCon ds + (members, ty2') <- f tyConDecl args + pure $ TypeInstanceDeclaration sa ch idx nm deps className [ty1, ty2'] (ExplicitInstance members) + _ -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty1 + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 + + in case className of + DataNewtype.Newtype -> binaryWildcardClass deriveNewtype + DataGenericRep.Generic -> binaryWildcardClass (deriveGenericRep ss mn) + _ -> pure decl + _ -> pure decl deriveGenericRep :: forall m . (MonadError MultipleErrors m, MonadSupply m) => SourceSpan -> ModuleName - -> SynonymMap - -> KindMap - -> [Declaration] - -> ProperName 'TypeName + -> Declaration -> [SourceType] - -> SourceType -> m ([Declaration], SourceType) -deriveGenericRep ss mn syns kinds ds tyConNm tyConArgs repTy = do - checkIsWildcard ss tyConNm repTy - go =<< findTypeDecl ss tyConNm ds - where - go :: Declaration -> m ([Declaration], SourceType) - go (DataDeclaration (ss', _) _ _ args dctors) = do +deriveGenericRep ss mn tyCon tyConArgs = + case tyCon of + DataDeclaration (ss', _) _ _ args dctors -> do x <- freshIdent "x" (reps, to, from) <- unzip3 <$> traverse makeInst dctors let rep = toRepTy reps inst | null reps = -- If there are no cases, spin [ ValueDecl (ss', []) (Ident "to") Public [] $ unguarded $ - lamCase ss' x + lamCase x [ CaseAlternative [NullBinder] (unguarded (App (Var ss DataGenericRep.to) (Var ss' (Qualified Nothing x)))) ] , ValueDecl (ss', []) (Ident "from") Public [] $ unguarded $ - lamCase ss' x + lamCase x [ CaseAlternative [NullBinder] (unguarded (App (Var ss DataGenericRep.from) (Var ss' (Qualified Nothing x)))) @@ -300,14 +95,16 @@ deriveGenericRep ss mn syns kinds ds tyConNm tyConArgs repTy = do ] | otherwise = [ ValueDecl (ss', []) (Ident "to") Public [] $ unguarded $ - lamCase ss' x (zipWith ($) (map underBinder (sumBinders (length dctors))) to) + lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to) , ValueDecl (ss', []) (Ident "from") Public [] $ unguarded $ - lamCase ss' x (zipWith ($) (map underExpr (sumExprs (length dctors))) from) + lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from) ] subst = zipWith ((,) . fst) args tyConArgs return (inst, replaceAllTypeVars subst rep) - go _ = internalError "deriveGenericRep go: expected DataDeclaration" + _ -> internalError "deriveGenericRep: expected DataDeclaration" + + where select :: (a -> a) -> (a -> a) -> Int -> [a -> a] select _ _ 0 = [] @@ -330,7 +127,7 @@ deriveGenericRep ss mn syns kinds ds tyConNm tyConArgs repTy = do :: DataConstructorDeclaration -> m (SourceType, CaseAlternative, CaseAlternative) makeInst (DataConstructorDeclaration _ ctorName args) = do - args' <- mapM (replaceAllTypeSynonymsM syns kinds . snd) args + let args' = map snd args (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args' return ( srcTypeApp (srcTypeApp (srcTypeConstructor DataGenericRep.Constructor) (srcTypeLevelString $ mkString (runProperName ctorName))) @@ -382,202 +179,22 @@ checkIsWildcard _ _ (TypeWildcard _ UnnamedWildcard) = return () checkIsWildcard ss tyConNm _ = throwError . errorMessage' ss $ ExpectedWildcard tyConNm -deriveEq - :: forall m - . (MonadError MultipleErrors m, MonadSupply m) - => SourceSpan - -> ModuleName - -> SynonymMap - -> KindMap - -> [Declaration] - -> ProperName 'TypeName - -> m [Declaration] -deriveEq ss mn syns kinds ds tyConNm = do - tyCon <- findTypeDecl ss tyConNm ds - eqFun <- mkEqFunction tyCon - return [ ValueDecl (ss, []) (Ident Prelude.eq) Public [] (unguarded eqFun) ] - where - mkEqFunction :: Declaration -> m Expr - mkEqFunction (DataDeclaration (ss', _) _ _ _ args) = do - x <- freshIdent "x" - y <- freshIdent "y" - lamCase2 ss' x y <$> (addCatch <$> mapM mkCtorClause args) - mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration" - - preludeConj :: Expr -> Expr -> Expr - preludeConj = App . App (Var ss (Qualified (Just (ModuleName "Data.HeytingAlgebra")) (Ident Prelude.conj))) - - preludeEq :: Expr -> Expr -> Expr - preludeEq = App . App (Var ss (Qualified (Just dataEq) (Ident Prelude.eq))) - - preludeEq1 :: Expr -> Expr -> Expr - preludeEq1 = App . App (Var ss (Qualified (Just dataEq) (Ident Prelude.eq1))) - - addCatch :: [CaseAlternative] -> [CaseAlternative] - addCatch xs - | length xs /= 1 = xs ++ [catchAll] - | otherwise = xs -- Avoid redundant case - where - catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (Literal ss (BooleanLiteral False))) - - mkCtorClause :: DataConstructorDeclaration -> m CaseAlternative - mkCtorClause (DataConstructorDeclaration _ ctorName tys) = do - identsL <- replicateM (length tys) (freshIdent "l") - identsR <- replicateM (length tys) (freshIdent "r") - tys' <- mapM (replaceAllTypeSynonymsM syns kinds . snd) tys - let tests = zipWith3 toEqTest (map (Var ss . Qualified Nothing) identsL) (map (Var ss . Qualified Nothing) identsR) tys' - return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (unguarded (conjAll tests)) - where - caseBinder idents = ConstructorBinder ss (Qualified (Just mn) ctorName) (map (VarBinder ss) idents) - - conjAll :: [Expr] -> Expr - conjAll [] = Literal ss (BooleanLiteral True) - conjAll xs = foldl1 preludeConj xs - - toEqTest :: Expr -> Expr -> SourceType -> Expr - toEqTest l r ty - | Just rec <- objectType ty - , Just fields <- decomposeRec rec = - conjAll - . map (\(Label str, typ) -> toEqTest (Accessor str l) (Accessor str r) typ) - $ fields - | isAppliedVar ty = preludeEq1 l r - | otherwise = preludeEq l r - -deriveEq1 :: SourceSpan -> [Declaration] -deriveEq1 ss = - [ ValueDecl (ss, []) (Ident Prelude.eq1) Public [] (unguarded preludeEq)] - where - preludeEq :: Expr - preludeEq = Var ss (Qualified (Just dataEq) (Ident Prelude.eq)) - -deriveOrd - :: forall m - . (MonadError MultipleErrors m, MonadSupply m) - => SourceSpan - -> ModuleName - -> SynonymMap - -> KindMap - -> [Declaration] - -> ProperName 'TypeName - -> m [Declaration] -deriveOrd ss mn syns kinds ds tyConNm = do - tyCon <- findTypeDecl ss tyConNm ds - compareFun <- mkCompareFunction tyCon - return [ ValueDecl (ss, []) (Ident Prelude.compare) Public [] (unguarded compareFun) ] - where - mkCompareFunction :: Declaration -> m Expr - mkCompareFunction (DataDeclaration (ss', _) _ _ _ args) = do - x <- freshIdent "x" - y <- freshIdent "y" - lamCase2 ss' x y <$> (addCatch . concat <$> mapM mkCtorClauses (splitLast args)) - mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration" - - splitLast :: [a] -> [(a, Bool)] - splitLast [] = [] - splitLast [x] = [(x, True)] - splitLast (x : xs) = (x, False) : splitLast xs - - addCatch :: [CaseAlternative] -> [CaseAlternative] - addCatch xs - | null xs = [catchAll] -- No type constructors - | otherwise = xs - where - catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (orderingCtor "EQ")) - - orderingName :: Text -> Qualified (ProperName a) - orderingName = Qualified (Just (ModuleName "Data.Ordering")) . ProperName - - orderingCtor :: Text -> Expr - orderingCtor = Constructor ss . orderingName - - orderingBinder :: Text -> Binder - orderingBinder name = ConstructorBinder ss (orderingName name) [] - - ordCompare :: Expr -> Expr -> Expr - ordCompare = App . App (Var ss (Qualified (Just dataOrd) (Ident Prelude.compare))) - - ordCompare1 :: Expr -> Expr -> Expr - ordCompare1 = App . App (Var ss (Qualified (Just dataOrd) (Ident Prelude.compare1))) - - mkCtorClauses :: (DataConstructorDeclaration, Bool) -> m [CaseAlternative] - mkCtorClauses (DataConstructorDeclaration _ ctorName tys, isLast) = do - identsL <- replicateM (length tys) (freshIdent "l") - identsR <- replicateM (length tys) (freshIdent "r") - tys' <- mapM (replaceAllTypeSynonymsM syns kinds . snd) tys - let tests = zipWith3 toOrdering (map (Var ss . Qualified Nothing) identsL) (map (Var ss . Qualified Nothing) identsR) tys' - extras | not isLast = [ CaseAlternative [ ConstructorBinder ss (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) - , NullBinder - ] - (unguarded (orderingCtor "LT")) - , CaseAlternative [ NullBinder - , ConstructorBinder ss (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) - ] - (unguarded (orderingCtor "GT")) - ] - | otherwise = [] - return $ CaseAlternative [ caseBinder identsL - , caseBinder identsR - ] - (unguarded (appendAll tests)) - : extras - - where - caseBinder idents = ConstructorBinder ss (Qualified (Just mn) ctorName) (map (VarBinder ss) idents) - - appendAll :: [Expr] -> Expr - appendAll [] = orderingCtor "EQ" - appendAll [x] = x - appendAll (x : xs) = Case [x] [ CaseAlternative [orderingBinder "LT"] - (unguarded (orderingCtor "LT")) - , CaseAlternative [orderingBinder "GT"] - (unguarded (orderingCtor "GT")) - , CaseAlternative [ NullBinder ] - (unguarded (appendAll xs)) - ] - - toOrdering :: Expr -> Expr -> SourceType -> Expr - toOrdering l r ty - | Just rec <- objectType ty - , Just fields <- decomposeRec rec = - appendAll - . map (\(Label str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ) - $ fields - | isAppliedVar ty = ordCompare1 l r - | otherwise = ordCompare l r - -deriveOrd1 :: SourceSpan -> [Declaration] -deriveOrd1 ss = - [ ValueDecl (ss, []) (Ident Prelude.compare1) Public [] (unguarded dataOrdCompare)] - where - dataOrdCompare :: Expr - dataOrdCompare = Var ss (Qualified (Just dataOrd) (Ident Prelude.compare)) - deriveNewtype :: forall m - . (MonadError MultipleErrors m, MonadSupply m) - => SourceSpan - -> SynonymMap - -> KindMap - -> [Declaration] - -> ProperName 'TypeName + . MonadError MultipleErrors m + => Declaration -> [SourceType] - -> SourceType - -> m SourceType -deriveNewtype ss syns kinds ds tyConNm tyConArgs unwrappedTy = do - checkIsWildcard ss tyConNm unwrappedTy - go =<< findTypeDecl ss tyConNm ds - where - go :: Declaration -> m SourceType - go (DataDeclaration (ss', _) Data name _ _) = + -> m ([Declaration], SourceType) +deriveNewtype tyCon tyConArgs = + case tyCon of + DataDeclaration (ss', _) Data name _ _ -> throwError . errorMessage' ss' $ CannotDeriveNewtypeForData name - go (DataDeclaration _ Newtype name args dctors) = do + DataDeclaration _ Newtype name args dctors -> do checkNewtype name dctors let (DataConstructorDeclaration _ _ [(_, ty)]) = head dctors - ty' <- replaceAllTypeSynonymsM syns kinds ty let subst = zipWith ((,) . fst) args tyConArgs - return $ replaceAllTypeVars subst ty' - go _ = internalError "deriveNewtype go: expected DataDeclaration" + return ([], replaceAllTypeVars subst ty) + _ -> internalError "deriveNewtype: expected DataDeclaration" findTypeDecl :: (MonadError MultipleErrors m) @@ -585,117 +202,8 @@ findTypeDecl -> ProperName 'TypeName -> [Declaration] -> m Declaration -findTypeDecl ss tyConNm = maybe (throwError . errorMessage' ss $ CannotFindDerivingType tyConNm) return . find isTypeDecl +findTypeDecl ss tyConNm = note (errorMessage' ss $ CannotFindDerivingType tyConNm) . find isTypeDecl where isTypeDecl :: Declaration -> Bool - isTypeDecl (DataDeclaration _ _ nm _ _) | nm == tyConNm = True + isTypeDecl (DataDeclaration _ _ nm _ _) = nm == tyConNm isTypeDecl _ = False - -lam :: SourceSpan -> Ident -> Expr -> Expr -lam ss = Abs . VarBinder ss - -lamCase :: SourceSpan -> Ident -> [CaseAlternative] -> Expr -lamCase ss s = lam ss s . Case [mkVar ss s] - -lamCase2 :: SourceSpan -> Ident -> Ident -> [CaseAlternative] -> Expr -lamCase2 ss s t = lam ss s . lam ss t . Case [mkVar ss s, mkVar ss t] - -mkVarMn :: SourceSpan -> Maybe ModuleName -> Ident -> Expr -mkVarMn ss mn = Var ss . Qualified mn - -mkVar :: SourceSpan -> Ident -> Expr -mkVar ss = mkVarMn ss Nothing - -isAppliedVar :: Type a -> Bool -isAppliedVar (TypeApp _ (TypeVar _ _) _) = True -isAppliedVar _ = False - -objectType :: Type a -> Maybe (Type a) -objectType (TypeApp _ (TypeConstructor _ Prim.Record) rec) = Just rec -objectType _ = Nothing - -decomposeRec :: SourceType -> Maybe [(Label, SourceType)] -decomposeRec = fmap (sortOn fst) . go - where go (RCons _ str typ typs) = fmap ((str, typ) :) (go typs) - go (REmptyKinded _ _) = Just [] - go _ = Nothing - -decomposeRec' :: SourceType -> [(Label, SourceType)] -decomposeRec' = sortOn fst . go - where go (RCons _ str typ typs) = (str, typ) : go typs - go _ = [] - -deriveFunctor - :: forall m - . (MonadError MultipleErrors m, MonadSupply m) - => SourceSpan - -> ModuleName - -> SynonymMap - -> KindMap - -> [Declaration] - -> ProperName 'TypeName - -> m [Declaration] -deriveFunctor ss mn syns kinds ds tyConNm = do - tyCon <- findTypeDecl ss tyConNm ds - mapFun <- mkMapFunction tyCon - return [ ValueDecl (ss, []) (Ident Prelude.map) Public [] (unguarded mapFun) ] - where - mkMapFunction :: Declaration -> m Expr - mkMapFunction (DataDeclaration (ss', _) _ _ tys ctors) = case reverse tys of - [] -> throwError . errorMessage' ss' $ KindsDoNotUnify (kindType -:> kindType) kindType - ((iTy, _) : _) -> do - f <- freshIdent "f" - m <- freshIdent "m" - lam ss' f . lamCase ss' m <$> mapM (mkCtorClause iTy f) ctors - mkMapFunction _ = internalError "mkMapFunction: expected DataDeclaration" - - mkCtorClause :: Text -> Ident -> DataConstructorDeclaration -> m CaseAlternative - mkCtorClause iTyName f (DataConstructorDeclaration _ ctorName ctorTys) = do - idents <- replicateM (length ctorTys) (freshIdent "v") - ctorTys' <- mapM (replaceAllTypeSynonymsM syns kinds . snd) ctorTys - args <- zipWithM transformArg idents ctorTys' - let ctor = Constructor ss (Qualified (Just mn) ctorName) - rebuilt = foldl' App ctor args - caseBinder = ConstructorBinder ss (Qualified (Just mn) ctorName) (VarBinder ss <$> idents) - return $ CaseAlternative [caseBinder] (unguarded rebuilt) - where - fVar = mkVar ss f - mapVar = mkVarMn ss (Just dataFunctor) (Ident Prelude.map) - - -- TODO: deal with type synonyms, ala https://github.com/purescript/purescript/pull/2516 - transformArg :: Ident -> SourceType -> m Expr - transformArg ident = fmap (foldr App (mkVar ss ident)) . goType where - - goType :: SourceType -> m (Maybe Expr) - -- argument matches the index type - goType (TypeVar _ t) | t == iTyName = return (Just fVar) - - -- records - goType recTy | Just row <- objectType recTy = - traverse buildUpdate (decomposeRec' row) >>= (traverse buildRecord . justUpdates) - where - justUpdates :: [Maybe (Label, Expr)] -> Maybe [(Label, Expr)] - justUpdates = foldMap (fmap return) - - buildUpdate :: (Label, SourceType) -> m (Maybe (Label, Expr)) - buildUpdate (lbl, ty) = do upd <- goType ty - return ((lbl,) <$> upd) - - buildRecord :: [(Label, Expr)] -> m Expr - buildRecord updates = do - arg <- freshIdent "o" - let argVar = mkVar ss arg - mkAssignment (Label l, x) = (l, App x (Accessor l argVar)) - return (lam ss arg (ObjectUpdate argVar (mkAssignment <$> updates))) - - -- quantifiers - goType (ForAll _ scopedVar _ t _) | scopedVar /= iTyName = goType t - - -- constraints - goType (ConstrainedType _ _ t) = goType t - - -- under a `* -> *`, just assume functor for now - goType (TypeApp _ _ t) = fmap (App mapVar) <$> goType t - - -- otherwise do nothing - will fail type checking if type does actually contain index - goType _ = return Nothing diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 8db639e694..7cc2f867cc 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -353,7 +353,8 @@ typeCheckAll moduleName = traverse go internalError "Type declarations should have been removed before typeCheckAlld" go (ValueDecl sa@(ss, _) name nameKind [] [MkUnguarded val]) = do env <- getEnv - warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (positionedError ss)) $ do + let declHint = if isPlainIdent name then addHint (ErrorInValueDeclaration name) else id + warnAndRethrow (declHint . addHint (positionedError ss)) $ do val' <- checkExhaustiveExpr ss env moduleName val valueIsNotDefined moduleName name typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] >>= \case diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs new file mode 100644 index 0000000000..dfb8b8bdb1 --- /dev/null +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -0,0 +1,431 @@ +module Language.PureScript.TypeChecker.Deriving (deriveInstance) where + +import Protolude hiding (Type) + +import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Foldable (foldl1) +import Data.List (init, last, zipWith3, (!!)) +import qualified Data.Map as M + +import Control.Monad.Supply.Class +import Language.PureScript.AST +import Language.PureScript.AST.Utils +import qualified Language.PureScript.Constants.Prelude as Prelude +import qualified Language.PureScript.Constants.Prim as Prim +import Language.PureScript.Crash +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Label (Label(..)) +import Language.PureScript.Names +import Language.PureScript.PSString +import Language.PureScript.Sugar.TypeClasses +import Language.PureScript.TypeChecker.Monad +import Language.PureScript.TypeChecker.Synonyms +import Language.PureScript.TypeClassDictionaries +import Language.PureScript.Types + +-- | Extract the name of the newtype appearing in the last type argument of +-- a derived newtype instance. +-- +-- Note: since newtypes in newtype instances can only be applied to type arguments +-- (no flexible instances allowed), we don't need to bother with unification when +-- looking for matching superclass instances, which saves us a lot of work. Instead, +-- we just match the newtype name. +extractNewtypeName :: ModuleName -> [SourceType] -> Maybe (ModuleName, ProperName 'TypeName) +extractNewtypeName mn + = fmap (\(n, _, _) -> qualify mn n) + . (unwrapTypeConstructor <=< lastMay) + +deriveInstance + :: forall m + . MonadError MultipleErrors m + => MonadState CheckState m + => MonadSupply m + => MonadWriter MultipleErrors m + => SourceType + -> Qualified (ProperName 'ClassName) + -> InstanceDerivationStrategy + -> m Expr +deriveInstance instType className strategy = do + mn <- unsafeCheckCurrentModule + env <- getEnv + (fmap coerceProperName -> ctorName, _, tys) <- maybe (internalCompilerError "invalid instance type") pure $ unwrapTypeConstructor instType + + TypeClassData{..} <- + note (errorMessage . UnknownName $ fmap TyClassName className) $ + className `M.lookup` typeClasses env + + case strategy of + KnownClassStrategy -> let + unaryClass :: (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]) -> m Expr + unaryClass f = case tys of + [ty] -> case unwrapTypeConstructor ty of + Just (Qualified (Just mn') tyCon, _, _) | mn == mn' -> do + let superclassesDicts = flip map typeClassSuperclasses $ \(Constraint _ superclass _ suTyArgs _) -> + let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs + in lam UnusedIdent (DeferredDictionary superclass tyArgs) + let superclasses = map mkString (superClassDictionaryNames typeClassSuperclasses) `zip` superclassesDicts + App (Constructor nullSourceSpan ctorName) . mkLit . ObjectLiteral . (++ superclasses) <$> f mn tyCon + _ -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty + _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 + + in case className of + Prelude.Eq -> unaryClass deriveEq + Prelude.Eq1 -> unaryClass $ \_ _ -> deriveEq1 + Prelude.Functor -> unaryClass deriveFunctor + Prelude.Ord -> unaryClass deriveOrd + Prelude.Ord1 -> unaryClass $ \_ _ -> deriveOrd1 + -- See L.P.Sugar.TypeClasses.Deriving for the classes that can be + -- derived prior to type checking. + _ -> throwError . errorMessage $ CannotDerive className tys + + NewtypeStrategy -> + case tys of + _ : _ | Just (Qualified (Just mn') tyCon, kargs, args) <- unwrapTypeConstructor (last tys) + , mn == mn' + -> deriveNewtypeInstance mn className tys tyCon kargs args + | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys (last tys) + _ -> throwError . errorMessage $ InvalidNewtypeInstance className tys + +deriveNewtypeInstance + :: forall m + . MonadError MultipleErrors m + => MonadState CheckState m + => MonadSupply m + => MonadWriter MultipleErrors m + => ModuleName + -> Qualified (ProperName 'ClassName) + -> [SourceType] + -> ProperName 'TypeName + -> [SourceType] + -> [SourceType] + -> m Expr +deriveNewtypeInstance mn className tys tyConNm dkargs dargs = do + verifySuperclasses + (dtype, tyKindNames, tyArgNames, ctors) <- lookupTypeDecl mn tyConNm + go dtype tyKindNames tyArgNames ctors + where + go (Just Newtype) tyKindNames tyArgNames [(_, [wrapped])] = do + -- The newtype might not be applied to all type arguments. + -- This is okay as long as the newtype wraps something which ends with + -- sufficiently many type applications to variables. + -- For example, we can derive Functor for + -- + -- newtype MyArray a = MyArray (Array a) + -- + -- since Array a is a type application which uses the last + -- type argument + wrapped' <- replaceAllTypeSynonyms wrapped + case stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped' of + Just wrapped'' -> do + let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs <> zip tyKindNames dkargs + wrapped''' <- replaceAllTypeSynonyms $ replaceAllTypeVars subst wrapped'' + tys' <- mapM replaceAllTypeSynonyms tys + return (DeferredDictionary className (init tys' ++ [wrapped'''])) + Nothing -> throwError . errorMessage $ InvalidNewtypeInstance className tys + go _ _ _ _ = throwError . errorMessage $ InvalidNewtypeInstance className tys + + takeReverse :: Int -> [a] -> [a] + takeReverse n = take n . reverse + + stripRight :: [(Text, Maybe kind)] -> SourceType -> Maybe SourceType + stripRight [] ty = Just ty + stripRight ((arg, _) : args) (TypeApp _ t (TypeVar _ arg')) + | arg == arg' = stripRight args t + stripRight _ _ = Nothing + + verifySuperclasses :: m () + verifySuperclasses = do + env <- getEnv + for_ (M.lookup className (typeClasses env)) $ \TypeClassData{ typeClassArguments = args, typeClassSuperclasses = superclasses } -> + for_ superclasses $ \Constraint{..} -> do + let constraintClass' = qualify (internalError "verifySuperclasses: unknown class module") constraintClass + for_ (M.lookup constraintClass (typeClasses env)) $ \TypeClassData{ typeClassDependencies = deps } -> + -- We need to check whether the newtype is mentioned, because of classes like MonadWriter + -- with its Monoid superclass constraint. + when (not (null args) && any ((fst (last args) `elem`) . usedTypeVariables) constraintArgs) $ do + -- For now, we only verify superclasses where the newtype is the only argument, + -- or for which all other arguments are determined by functional dependencies. + -- Everything else raises a UnverifiableSuperclassInstance warning. + -- This covers pretty much all cases we're interested in, but later we might want to do + -- more work to extend this to other superclass relationships. + let determined = map (srcTypeVar . fst . (args !!)) . ordNub . concatMap fdDetermined . filter ((== [length args - 1]) . fdDeterminers) $ deps + if eqType (last constraintArgs) (srcTypeVar . fst $ last args) && all (`elem` determined) (init constraintArgs) + then do + -- Now make sure that a superclass instance was derived. Again, this is not a complete + -- check, since the superclass might have multiple type arguments, so overlaps might still + -- be possible, so we warn again. + for_ (extractNewtypeName mn tys) $ \nm -> do + unless (hasNewtypeSuperclassInstance constraintClass' nm (typeClassDictionaries env)) $ + tell . errorMessage $ MissingNewtypeSuperclassInstance constraintClass className tys + else tell . errorMessage $ UnverifiableSuperclassInstance constraintClass className tys + + -- Note that this check doesn't actually verify that the superclass is + -- newtype-derived; see #3168. The whole verifySuperclasses feature + -- is pretty sketchy, and could use a thorough review and probably rewrite. + hasNewtypeSuperclassInstance (suModule, suClass) nt@(newtypeModule, _) dicts = + let su = Qualified (Just suModule) suClass + lookIn mn' + = elem nt + . (toList . extractNewtypeName mn' . tcdInstanceTypes + <=< foldMap toList . M.elems + <=< toList . (M.lookup su <=< M.lookup (Just mn'))) + $ dicts + in lookIn suModule || lookIn newtypeModule + +deriveEq + :: forall m + . MonadError MultipleErrors m + => MonadState CheckState m + => MonadSupply m + => ModuleName + -> ProperName 'TypeName + -> m [(PSString, Expr)] +deriveEq mn tyConNm = do + (_, _, _, ctors) <- lookupTypeDecl mn tyConNm + eqFun <- mkEqFunction ctors + pure [(Prelude.eq, eqFun)] + where + mkEqFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr + mkEqFunction ctors = do + x <- freshIdent "x" + y <- freshIdent "y" + lamCase2 x y . addCatch <$> mapM mkCtorClause ctors + + preludeConj :: Expr -> Expr -> Expr + preludeConj = App . App (mkVarMn (Just (ModuleName "Data.HeytingAlgebra")) (Ident Prelude.conj)) + + preludeEq :: Expr -> Expr -> Expr + preludeEq = App . App (mkRef Prelude.identEq) + + preludeEq1 :: Expr -> Expr -> Expr + preludeEq1 = App . App (mkRef Prelude.identEq1) + + addCatch :: [CaseAlternative] -> [CaseAlternative] + addCatch xs + | length xs /= 1 = xs ++ [catchAll] + | otherwise = xs -- Avoid redundant case + where + catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (mkLit (BooleanLiteral False))) + + mkCtorClause :: (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative + mkCtorClause (ctorName, tys) = do + identsL <- replicateM (length tys) (freshIdent "l") + identsR <- replicateM (length tys) (freshIdent "r") + tys' <- mapM replaceAllTypeSynonyms tys + let tests = zipWith3 toEqTest (map mkVar identsL) (map mkVar identsR) tys' + return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (unguarded (conjAll tests)) + where + caseBinder idents = mkCtorBinder mn ctorName $ map mkBinder idents + + conjAll :: [Expr] -> Expr + conjAll = \case + [] -> mkLit (BooleanLiteral True) + xs -> foldl1 preludeConj xs + + toEqTest :: Expr -> Expr -> SourceType -> Expr + toEqTest l r ty + | Just fields <- decomposeRec <=< objectType $ ty + = conjAll + . map (\(Label str, typ) -> toEqTest (Accessor str l) (Accessor str r) typ) + $ fields + | isAppliedVar ty = preludeEq1 l r + | otherwise = preludeEq l r + +deriveEq1 :: forall m. Applicative m => m [(PSString, Expr)] +deriveEq1 = pure [(Prelude.eq1, mkRef Prelude.identEq)] + +deriveOrd + :: forall m + . MonadError MultipleErrors m + => MonadState CheckState m + => MonadSupply m + => ModuleName + -> ProperName 'TypeName + -> m [(PSString, Expr)] +deriveOrd mn tyConNm = do + (_, _, _, ctors) <- lookupTypeDecl mn tyConNm + compareFun <- mkCompareFunction ctors + pure [(Prelude.compare, compareFun)] + where + mkCompareFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr + mkCompareFunction ctors = do + x <- freshIdent "x" + y <- freshIdent "y" + lamCase2 x y <$> (addCatch . concat <$> mapM mkCtorClauses (splitLast ctors)) + + splitLast :: [a] -> [(a, Bool)] + splitLast [] = [] + splitLast [x] = [(x, True)] + splitLast (x : xs) = (x, False) : splitLast xs + + addCatch :: [CaseAlternative] -> [CaseAlternative] + addCatch xs + | null xs = [catchAll] -- No type constructors + | otherwise = xs + where + catchAll = CaseAlternative [NullBinder, NullBinder] (unguarded (orderingCtor "EQ")) + + orderingMod :: ModuleName + orderingMod = ModuleName "Data.Ordering" + + orderingCtor :: Text -> Expr + orderingCtor = mkCtor orderingMod . ProperName + + orderingBinder :: Text -> Binder + orderingBinder name = mkCtorBinder orderingMod (ProperName name) [] + + ordCompare :: Expr -> Expr -> Expr + ordCompare = App . App (mkRef Prelude.identCompare) + + ordCompare1 :: Expr -> Expr -> Expr + ordCompare1 = App . App (mkRef Prelude.identCompare1) + + mkCtorClauses :: ((ProperName 'ConstructorName, [SourceType]), Bool) -> m [CaseAlternative] + mkCtorClauses ((ctorName, tys), isLast) = do + identsL <- replicateM (length tys) (freshIdent "l") + identsR <- replicateM (length tys) (freshIdent "r") + tys' <- mapM replaceAllTypeSynonyms tys + let tests = zipWith3 toOrdering (map mkVar identsL) (map mkVar identsR) tys' + extras | not isLast = [ CaseAlternative [nullCaseBinder, NullBinder] (unguarded (orderingCtor "LT")) + , CaseAlternative [NullBinder, nullCaseBinder] (unguarded (orderingCtor "GT")) + ] + | otherwise = [] + return $ CaseAlternative [ caseBinder identsL + , caseBinder identsR + ] + (unguarded (appendAll tests)) + : extras + + where + caseBinder idents = mkCtorBinder mn ctorName $ map mkBinder idents + nullCaseBinder = mkCtorBinder mn ctorName $ replicate (length tys) NullBinder + + appendAll :: [Expr] -> Expr + appendAll = \case + [] -> orderingCtor "EQ" + [x] -> x + (x : xs) -> Case [x] [ CaseAlternative [orderingBinder "LT"] (unguarded (orderingCtor "LT")) + , CaseAlternative [orderingBinder "GT"] (unguarded (orderingCtor "GT")) + , CaseAlternative [NullBinder] (unguarded (appendAll xs)) + ] + + toOrdering :: Expr -> Expr -> SourceType -> Expr + toOrdering l r ty + | Just fields <- decomposeRec <=< objectType $ ty + = appendAll + . map (\(Label str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ) + $ fields + | isAppliedVar ty = ordCompare1 l r + | otherwise = ordCompare l r + +deriveOrd1 :: forall m. Applicative m => m [(PSString, Expr)] +deriveOrd1 = pure [(Prelude.compare1, mkRef Prelude.identCompare)] + +lookupTypeDecl + :: forall m + . MonadError MultipleErrors m + => MonadState CheckState m + => ModuleName + -> ProperName 'TypeName + -> m (Maybe DataDeclType, [Text], [(Text, Maybe SourceType)], [(ProperName 'ConstructorName, [SourceType])]) +lookupTypeDecl mn typeName = do + env <- getEnv + note (errorMessage $ CannotFindDerivingType typeName) $ do + (kind, DataType _ args dctors) <- Qualified (Just mn) typeName `M.lookup` types env + (kargs, _) <- completeBinderList kind + let dtype = do + (ctorName, _) <- headMay dctors + (a, _, _, _) <- Qualified (Just mn) ctorName `M.lookup` dataConstructors env + pure a + pure (dtype, fst . snd <$> kargs, map (\(v, k, _) -> (v, k)) args, dctors) + +isAppliedVar :: Type a -> Bool +isAppliedVar (TypeApp _ (TypeVar _ _) _) = True +isAppliedVar _ = False + +objectType :: Type a -> Maybe (Type a) +objectType (TypeApp _ (TypeConstructor _ Prim.Record) rec) = Just rec +objectType _ = Nothing + +decomposeRec :: SourceType -> Maybe [(Label, SourceType)] +decomposeRec = fmap (sortOn fst) . go + where go (RCons _ str typ typs) = fmap ((str, typ) :) (go typs) + go (REmptyKinded _ _) = Just [] + go _ = Nothing + +decomposeRec' :: SourceType -> [(Label, SourceType)] +decomposeRec' = sortOn fst . go + where go (RCons _ str typ typs) = (str, typ) : go typs + go _ = [] + +deriveFunctor + :: forall m + . MonadError MultipleErrors m + => MonadState CheckState m + => MonadSupply m + => ModuleName + -> ProperName 'TypeName + -> m [(PSString, Expr)] +deriveFunctor mn tyConNm = do + (_, _, tys, ctors) <- lookupTypeDecl mn tyConNm + mapFun <- mkMapFunction tys ctors + pure [(Prelude.map, mapFun)] + where + mkMapFunction :: [(Text, Maybe SourceType)] -> [(ProperName 'ConstructorName, [SourceType])] -> m Expr + mkMapFunction tys ctors = case reverse tys of + [] -> throwError . errorMessage $ KindsDoNotUnify (kindType -:> kindType) kindType + ((iTy, _) : _) -> do + f <- freshIdent "f" + m <- freshIdent "m" + lam f . lamCase m <$> mapM (mkCtorClause iTy f) ctors + + mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative + mkCtorClause iTyName f (ctorName, ctorTys) = do + idents <- replicateM (length ctorTys) (freshIdent "v") + ctorTys' <- mapM replaceAllTypeSynonyms ctorTys + args <- zipWithM transformArg idents ctorTys' + let ctor = mkCtor mn ctorName + rebuilt = foldl' App ctor args + caseBinder = mkCtorBinder mn ctorName $ map mkBinder idents + return $ CaseAlternative [caseBinder] (unguarded rebuilt) + where + fVar = mkVar f + mapVar = mkRef Prelude.identMap + + transformArg :: Ident -> SourceType -> m Expr + transformArg ident = fmap (foldr App (mkVar ident)) . goType where + + goType :: SourceType -> m (Maybe Expr) + -- argument matches the index type + goType (TypeVar _ t) | t == iTyName = return (Just fVar) + + -- records + goType recTy | Just row <- objectType recTy = + traverse buildUpdate (decomposeRec' row) >>= (traverse buildRecord . justUpdates) + where + justUpdates :: [Maybe (Label, Expr)] -> Maybe [(Label, Expr)] + justUpdates = foldMap (fmap return) + + buildUpdate :: (Label, SourceType) -> m (Maybe (Label, Expr)) + buildUpdate (lbl, ty) = do upd <- goType ty + return ((lbl,) <$> upd) + + buildRecord :: [(Label, Expr)] -> m Expr + buildRecord updates = do + arg <- freshIdent "o" + let argVar = mkVar arg + mkAssignment (Label l, x) = (l, App x (Accessor l argVar)) + return (lam arg (ObjectUpdate argVar (mkAssignment <$> updates))) + + -- quantifiers + goType (ForAll _ scopedVar _ t _) | scopedVar /= iTyName = goType t + + -- constraints + goType (ConstrainedType _ _ t) = goType t + + -- under a `* -> *`, just assume functor for now + goType (TypeApp _ _ t) = fmap (App mapVar) <$> goType t + + -- otherwise do nothing - will fail type checking if type does actually contain index + goType _ = return Nothing diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 77d1d32504..83958949fb 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -51,6 +51,7 @@ import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Traversals +import Language.PureScript.TypeChecker.Deriving import Language.PureScript.TypeChecker.Entailment import Language.PureScript.TypeChecker.Kinds import Language.PureScript.TypeChecker.Monad @@ -656,7 +657,7 @@ check => Expr -> SourceType -> m TypedValue' -check val ty = withErrorMessageHint (ErrorCheckingType val ty) $ check' val ty +check val ty = withErrorMessageHint' val (ErrorCheckingType val ty) $ check' val ty -- | -- Check the type of a value @@ -770,6 +771,10 @@ check' e@(Literal ss (ObjectLiteral ps)) t@(TypeApp _ obj row) | obj == tyRecord ensureNoDuplicateProperties ps ps' <- checkProperties e ps row False return $ TypedValue' True (Literal ss (ObjectLiteral ps')) t +check' (DerivedInstancePlaceholder name strategy) t = do + d <- deriveInstance t name strategy + d' <- tvToExpr <$> check' d t + return $ TypedValue' True d' t check' e@(ObjectUpdate obj ps) t@(TypeApp _ o row) | o == tyRecord = do ensureNoDuplicateProperties ps -- We need to be careful to avoid duplicate labels here. @@ -923,6 +928,7 @@ isInternal = \case PositionedValue _ _ v -> isInternal v TypedValue _ v _ -> isInternal v Constructor _ (Qualified _ name) -> isDictTypeName name + DerivedInstancePlaceholder{} -> True _ -> False -- | Introduce a hint only if the given expression is not internal diff --git a/tests/purs/failing/2616.out b/tests/purs/failing/2616.out index 0cf1843381..1307985fbc 100644 --- a/tests/purs/failing/2616.out +++ b/tests/purs/failing/2616.out @@ -14,8 +14,8 @@ while solving type class constraint   while applying a function compare of type Ord t0 => t0 -> t0 -> Ordering - to argument $l6 -while inferring the type of compare $l6 + to argument $l2 +while inferring the type of compare $l2 in value declaration ordFoo where r1 is a rigid type variable diff --git a/tests/purs/failing/3405.out b/tests/purs/failing/3405.out index ea38286820..551254cbc0 100644 --- a/tests/purs/failing/3405.out +++ b/tests/purs/failing/3405.out @@ -1,9 +1,18 @@ Error found: +in module Main at tests/purs/failing/3405.purs:8:1 - 8:43 (line 8, column 1 - line 8, column 43) - Cannot derive a type class instance, because the type declaration for Something could not be found. + Orphan instance eqSomething found for +   +  Data.Eq.Eq Int +   + This problem can be resolved by declaring the instance in Data.Eq, or by defining the instance on a newtype wrapper. +in type class instance +  + Data.Eq.Eq Something +  -See https://github.com/purescript/documentation/blob/master/errors/CannotFindDerivingType.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/OrphanInstance.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/3405.purs b/tests/purs/failing/3405.purs index de7ab7ca02..431e5a3dee 100644 --- a/tests/purs/failing/3405.purs +++ b/tests/purs/failing/3405.purs @@ -1,4 +1,4 @@ --- @shouldFailWith CannotFindDerivingType +-- @shouldFailWith OrphanInstance module Main where import Prelude diff --git a/tests/purs/failing/3453.out b/tests/purs/failing/3453.out new file mode 100644 index 0000000000..e5bcd23b41 --- /dev/null +++ b/tests/purs/failing/3453.out @@ -0,0 +1,11 @@ +Error found: +at tests/purs/failing/3453.purs:6:1 - 6:11 (line 6, column 1 - line 6, column 11) + + A cycle appears in the definition of type synonym S + Cycles are disallowed because they can lead to loops in the type checker. + Consider using a 'newtype' instead. + + +See https://github.com/purescript/documentation/blob/master/errors/CycleInTypeSynonym.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3453.purs b/tests/purs/failing/3453.purs new file mode 100644 index 0000000000..8bc3d6cbe7 --- /dev/null +++ b/tests/purs/failing/3453.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith CycleInTypeSynonym +module Main where + +import Data.Newtype (class Newtype) + +type S = S +newtype Z = Z S +derive instance newtypeZ :: Newtype Z _ diff --git a/tests/purs/failing/3510.out b/tests/purs/failing/3510.out new file mode 100644 index 0000000000..d1a9d57fc9 --- /dev/null +++ b/tests/purs/failing/3510.out @@ -0,0 +1,18 @@ +Error found: +in module Main +at tests/purs/failing/3510.purs:7:1 - 7:28 (line 7, column 1 - line 7, column 28) + + Type class instance head is invalid due to use of type +   +  () +   + All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form, unless the type is fully determined by other type class arguments via functional dependencies. + +in type class instance +  + Data.Eq.Eq T +  + +See https://github.com/purescript/documentation/blob/master/errors/InvalidInstanceHead.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/3510.purs b/tests/purs/failing/3510.purs new file mode 100644 index 0000000000..aa608ccd41 --- /dev/null +++ b/tests/purs/failing/3510.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith InvalidInstanceHead +module Main where + +import Prelude (class Eq) + +type T = {} +derive instance eqT :: Eq T diff --git a/tests/purs/failing/InvalidDerivedInstance.out b/tests/purs/failing/InvalidDerivedInstance.out index 5377cb056b..46ac3b7ffe 100644 --- a/tests/purs/failing/InvalidDerivedInstance.out +++ b/tests/purs/failing/InvalidDerivedInstance.out @@ -1,14 +1,16 @@ Error found: +in module Main at tests/purs/failing/InvalidDerivedInstance.purs:8:1 - 8:30 (line 8, column 1 - line 8, column 30) - Cannot derive the type class instance -   -  Data.Eq.Eq X -  X -   - because the Data.Eq.Eq type class has 1 type argument, but the declaration specifies 2. + The type class Data.Eq.Eq expects 1 argument. + But the instance eqX provided 2. +in type class instance +  + Data.Eq.Eq X + X +  -See https://github.com/purescript/documentation/blob/master/errors/InvalidDerivedInstance.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/ClassInstanceArityMismatch.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/InvalidDerivedInstance.purs b/tests/purs/failing/InvalidDerivedInstance.purs index 11b1b46613..68714c7f62 100644 --- a/tests/purs/failing/InvalidDerivedInstance.purs +++ b/tests/purs/failing/InvalidDerivedInstance.purs @@ -1,4 +1,4 @@ --- @shouldFailWith InvalidDerivedInstance +-- @shouldFailWith ClassInstanceArityMismatch module Main where import Prelude diff --git a/tests/purs/failing/InvalidDerivedInstance2.out b/tests/purs/failing/InvalidDerivedInstance2.out index 385bace2f4..842629b933 100644 --- a/tests/purs/failing/InvalidDerivedInstance2.out +++ b/tests/purs/failing/InvalidDerivedInstance2.out @@ -1,17 +1,18 @@ Error found: +in module Main at tests/purs/failing/InvalidDerivedInstance2.purs:6:1 - 6:34 (line 6, column 1 - line 6, column 34) - Cannot derive the type class instance -   -  Data.Eq.Eq (Record ()) -   - because the type -   -  Record () -   - is not of the required form T a_1 ... a_n, where T is a type constructor defined in the same module. + Type class instance head is invalid due to use of type +   +  () +   + All types appearing in instance declarations must be of the form T a_1 .. a_n, where each type a_i is of the same form, unless the type is fully determined by other type class arguments via functional dependencies. +in type class instance +  + Data.Eq.Eq (Record ()) +  -See https://github.com/purescript/documentation/blob/master/errors/ExpectedTypeConstructor.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/InvalidInstanceHead.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/InvalidDerivedInstance2.purs b/tests/purs/failing/InvalidDerivedInstance2.purs index ec467337a7..e5d3f52d60 100644 --- a/tests/purs/failing/InvalidDerivedInstance2.purs +++ b/tests/purs/failing/InvalidDerivedInstance2.purs @@ -1,4 +1,4 @@ --- @shouldFailWith ExpectedTypeConstructor +-- @shouldFailWith InvalidInstanceHead module Main where import Prelude diff --git a/tests/purs/failing/InvalidDerivedInstance3.out b/tests/purs/failing/InvalidDerivedInstance3.out index 848b38720b..ded7378003 100644 --- a/tests/purs/failing/InvalidDerivedInstance3.out +++ b/tests/purs/failing/InvalidDerivedInstance3.out @@ -1,9 +1,13 @@ Error found: +in module Main at tests/purs/failing/InvalidDerivedInstance3.purs:8:15 - 8:16 (line 8, column 15 - line 8, column 16) Type synonym Main.S is partially applied. Type synonyms must be applied to all of their type arguments. +while checking that type S + has kind Type +in type constructor N See https://github.com/purescript/documentation/blob/master/errors/PartiallyAppliedSynonym.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/NewtypeInstance.out b/tests/purs/failing/NewtypeInstance.out index 044059b267..efb1dae92f 100644 --- a/tests/purs/failing/NewtypeInstance.out +++ b/tests/purs/failing/NewtypeInstance.out @@ -1,4 +1,5 @@ Error found: +in module Main at tests/purs/failing/NewtypeInstance.purs:8:1 - 8:40 (line 8, column 1 - line 8, column 40) Cannot derive newtype instance for @@ -7,6 +8,7 @@ at tests/purs/failing/NewtypeInstance.purs:8:1 - 8:40 (line 8, column 1 - line 8   Make sure this is a newtype. +in value declaration showX See https://github.com/purescript/documentation/blob/master/errors/InvalidNewtypeInstance.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/NewtypeInstance2.out b/tests/purs/failing/NewtypeInstance2.out index b0ef43daee..f8f48e1695 100644 --- a/tests/purs/failing/NewtypeInstance2.out +++ b/tests/purs/failing/NewtypeInstance2.out @@ -1,12 +1,17 @@ Error found: +in module Main at tests/purs/failing/NewtypeInstance2.purs:8:1 - 8:54 (line 8, column 1 - line 8, column 54) Cannot derive newtype instance for -   -  Data.Show.Show (X a) -   +   +  Data.Show.Show (X a0) +   Make sure this is a newtype. +in value declaration showX + +where a0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) See https://github.com/purescript/documentation/blob/master/errors/InvalidNewtypeInstance.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/NewtypeInstance3.out b/tests/purs/failing/NewtypeInstance3.out index d5ed7a8c4c..ba27672759 100644 --- a/tests/purs/failing/NewtypeInstance3.out +++ b/tests/purs/failing/NewtypeInstance3.out @@ -1,4 +1,5 @@ Error found: +in module Main at tests/purs/failing/NewtypeInstance3.purs:8:1 - 8:43 (line 8, column 1 - line 8, column 43) Cannot derive newtype instance for @@ -7,6 +8,7 @@ at tests/purs/failing/NewtypeInstance3.purs:8:1 - 8:43 (line 8, column 1 - line   Make sure this is a newtype. +in value declaration nullary See https://github.com/purescript/documentation/blob/master/errors/InvalidNewtypeInstance.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/NewtypeInstance4.out b/tests/purs/failing/NewtypeInstance4.out index cc3e7abc0c..2446c82964 100644 --- a/tests/purs/failing/NewtypeInstance4.out +++ b/tests/purs/failing/NewtypeInstance4.out @@ -1,4 +1,5 @@ Error found: +in module Main at tests/purs/failing/NewtypeInstance4.purs:8:1 - 8:40 (line 8, column 1 - line 8, column 40) Cannot derive newtype instance for @@ -7,6 +8,7 @@ at tests/purs/failing/NewtypeInstance4.purs:8:1 - 8:40 (line 8, column 1 - line   Make sure this is a newtype. +in value declaration showX See https://github.com/purescript/documentation/blob/master/errors/InvalidNewtypeInstance.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/NewtypeInstance5.out b/tests/purs/failing/NewtypeInstance5.out index 911ea2b6bd..335096de25 100644 --- a/tests/purs/failing/NewtypeInstance5.out +++ b/tests/purs/failing/NewtypeInstance5.out @@ -1,4 +1,5 @@ Error found: +in module Main at tests/purs/failing/NewtypeInstance5.purs:8:1 - 8:46 (line 8, column 1 - line 8, column 46) Cannot derive newtype instance for @@ -7,6 +8,7 @@ at tests/purs/failing/NewtypeInstance5.purs:8:1 - 8:46 (line 8, column 1 - line   Make sure this is a newtype. +in value declaration functorX See https://github.com/purescript/documentation/blob/master/errors/InvalidNewtypeInstance.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/NewtypeInstance6.out b/tests/purs/failing/NewtypeInstance6.out index a3a0989b20..d135cf3c83 100644 --- a/tests/purs/failing/NewtypeInstance6.out +++ b/tests/purs/failing/NewtypeInstance6.out @@ -1,13 +1,24 @@ Error found: -at tests/purs/failing/NewtypeInstance6.purs:8:1 - 8:46 (line 8, column 1 - line 8, column 46) +in module Main +at tests/purs/failing/NewtypeInstance6.purs:8:45 - 8:46 (line 8, column 45 - line 8, column 46) - Cannot derive newtype instance for -   -  Data.Functor.Functor X -   - Make sure this is a newtype. + Could not match kind +   +  Type -> Type +   + with kind +   +  Type +   +while checking that type X + has kind Type -> Type +while inferring the kind of Functor X +in type class instance +  + Data.Functor.Functor X +  -See https://github.com/purescript/documentation/blob/master/errors/InvalidNewtypeInstance.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/NewtypeInstance6.purs b/tests/purs/failing/NewtypeInstance6.purs index fe7136661d..5833b1a382 100644 --- a/tests/purs/failing/NewtypeInstance6.purs +++ b/tests/purs/failing/NewtypeInstance6.purs @@ -1,4 +1,4 @@ --- @shouldFailWith InvalidNewtypeInstance +-- @shouldFailWith KindsDoNotUnify module Main where import Prelude diff --git a/tests/purs/failing/NewtypeUnnamedInstance.out b/tests/purs/failing/NewtypeUnnamedInstance.out new file mode 100644 index 0000000000..4ba7a4072f --- /dev/null +++ b/tests/purs/failing/NewtypeUnnamedInstance.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/NewtypeUnnamedInstance.purs:8:1 - 8:31 (line 8, column 1 - line 8, column 31) + + Cannot derive newtype instance for +   +  Data.Show.Show X +   + Make sure this is a newtype. + + +See https://github.com/purescript/documentation/blob/master/errors/InvalidNewtypeInstance.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/NewtypeUnnamedInstance.purs b/tests/purs/failing/NewtypeUnnamedInstance.purs new file mode 100644 index 0000000000..b308b1cebc --- /dev/null +++ b/tests/purs/failing/NewtypeUnnamedInstance.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith InvalidNewtypeInstance +module Main where + +import Prelude + +data X = X + +derive newtype instance Show X diff --git a/tests/purs/passing/3510.purs b/tests/purs/passing/3510.purs new file mode 100644 index 0000000000..d3c0bf650c --- /dev/null +++ b/tests/purs/passing/3510.purs @@ -0,0 +1,11 @@ +module Main where + +import Prelude (class Eq) +import Effect.Console (log) + +data Maybe a = Just a | Nothing + +type T = Maybe Int +derive instance eqT :: Eq T + +main = log "Done" diff --git a/tests/purs/passing/4105.purs b/tests/purs/passing/4105.purs new file mode 100644 index 0000000000..4eb266baec --- /dev/null +++ b/tests/purs/passing/4105.purs @@ -0,0 +1,12 @@ +module Main where + +import Prelude + +import Effect.Console (log) + +import Lib (Patch) + +newtype UpdateDto = UpdateDto Patch +derive instance eqUpdateDto :: Eq UpdateDto + +main = log "Done" diff --git a/tests/purs/passing/4105/Lib.purs b/tests/purs/passing/4105/Lib.purs new file mode 100644 index 0000000000..89ccc3043d --- /dev/null +++ b/tests/purs/passing/4105/Lib.purs @@ -0,0 +1,5 @@ +module Lib where + +type Template col = { bio :: col String } +type Identity a = a +type Patch = Template Identity diff --git a/tests/purs/passing/4200.purs b/tests/purs/passing/4200.purs new file mode 100644 index 0000000000..5bcd6e4df9 --- /dev/null +++ b/tests/purs/passing/4200.purs @@ -0,0 +1,11 @@ +module Main where + +import Data.Newtype (class Newtype) +import Effect.Console (log) +import Lib (TAlias) + +newtype NewA a = NewA (TAlias Int) + +derive instance Newtype (NewA a) _ + +main = log "Done" diff --git a/tests/purs/passing/4200/Lib.purs b/tests/purs/passing/4200/Lib.purs new file mode 100644 index 0000000000..645940a232 --- /dev/null +++ b/tests/purs/passing/4200/Lib.purs @@ -0,0 +1,7 @@ +module Lib where + +data T :: forall m. m -> Type +data T msg = E + +type TAlias :: forall k. k -> Type +type TAlias msg = T msg diff --git a/tests/purs/passing/NewtypeInstance.purs b/tests/purs/passing/NewtypeInstance.purs index e16e574360..d2a1b333f0 100644 --- a/tests/purs/passing/NewtypeInstance.purs +++ b/tests/purs/passing/NewtypeInstance.purs @@ -54,6 +54,13 @@ type Syn' w a = MyWriter w a newtype Syn a = Syn (Syn' (MyArray Int) a) derive newtype instance functorSyn :: Functor Syn +data Proxy2 a b = Proxy2 +derive instance Functor (Proxy2 x) + +newtype Foo :: forall k. k -> Type +newtype Foo a = Foo (Proxy2 k a) +derive newtype instance Functor Foo + main = do logShow (X "test") logShow (singleton "test" :: Y String) diff --git a/tests/purs/warning/NewtypeInstance.out b/tests/purs/warning/NewtypeInstance.out index 72c32ddb3c..b6dd688801 100644 --- a/tests/purs/warning/NewtypeInstance.out +++ b/tests/purs/warning/NewtypeInstance.out @@ -1,4 +1,5 @@ Warning found: +in module Main at tests/purs/warning/NewtypeInstance.purs:8:1 - 8:38 (line 8, column 1 - line 8, column 38) The derived newtype instance for @@ -7,6 +8,7 @@ at tests/purs/warning/NewtypeInstance.purs:8:1 - 8:38 (line 8, column 1 - line 8   does not include a derived superclass instance for Data.Eq.Eq. +in value declaration ordX See https://github.com/purescript/documentation/blob/master/errors/MissingNewtypeSuperclassInstance.md for more information, or to contribute content related to this warning. diff --git a/tests/purs/warning/NewtypeInstance2.out b/tests/purs/warning/NewtypeInstance2.out index 8f6eed3101..e9afcb3d74 100644 --- a/tests/purs/warning/NewtypeInstance2.out +++ b/tests/purs/warning/NewtypeInstance2.out @@ -1,13 +1,18 @@ Warning found: +in module Main at tests/purs/warning/NewtypeInstance2.purs:15:1 - 15:86 (line 15, column 1 - line 15, column 86) The derived newtype instance for -   -  Main.MonadWriter w  -  (MyWriter w) -   +   +  Main.MonadWriter w0  +  (MyWriter w0) +   does not include a derived superclass instance for Control.Monad.Monad. +in value declaration monadWriterMyWriter + +where w0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) See https://github.com/purescript/documentation/blob/master/errors/MissingNewtypeSuperclassInstance.md for more information, or to contribute content related to this warning. diff --git a/tests/purs/warning/NewtypeInstance3.out b/tests/purs/warning/NewtypeInstance3.out index 7c8a7e79c6..bb3e96b4db 100644 --- a/tests/purs/warning/NewtypeInstance3.out +++ b/tests/purs/warning/NewtypeInstance3.out @@ -1,13 +1,18 @@ Warning found: +in module Main at tests/purs/warning/NewtypeInstance3.purs:21:1 - 21:86 (line 21, column 1 - line 21, column 86) The derived newtype instance for -   -  Main.MonadWriter w  -  (MyWriter w) -   +   +  Main.MonadWriter w0  +  (MyWriter w0) +   does not include a derived superclass instance for Main.MonadTell. +in value declaration monadWriterMyWriter + +where w0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) See https://github.com/purescript/documentation/blob/master/errors/MissingNewtypeSuperclassInstance.md for more information, or to contribute content related to this warning. diff --git a/tests/purs/warning/NewtypeInstance4.out b/tests/purs/warning/NewtypeInstance4.out index 9874bf408a..2d81d13624 100644 --- a/tests/purs/warning/NewtypeInstance4.out +++ b/tests/purs/warning/NewtypeInstance4.out @@ -1,13 +1,18 @@ Warning found: +in module Main at tests/purs/warning/NewtypeInstance4.purs:23:1 - 23:86 (line 23, column 1 - line 23, column 86) The derived newtype instance for -   -  Main.MonadWriter w  -  (MyWriter w) -   +   +  Main.MonadWriter w0  +  (MyWriter w0) +   implies an superclass instance for Main.MonadTell which could not be verified. +in value declaration monadWriterMyWriter + +where w0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) See https://github.com/purescript/documentation/blob/master/errors/UnverifiableSuperclassInstance.md for more information, or to contribute content related to this warning. From 94343bc4613a0cbf8507943809fa2d49b81bb0bf Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 16 May 2022 09:55:31 -0400 Subject: [PATCH 1467/1580] Drop dependency on microlens libraries (#4327) --- CHANGELOG.d/internal_drop-microlens.md | 1 + purescript.cabal | 2 -- src/Language/PureScript/Ide/Completion.hs | 2 +- src/Language/PureScript/Ide/Externs.hs | 2 +- src/Language/PureScript/Ide/Imports.hs | 2 +- src/Language/PureScript/Ide/Reexports.hs | 2 +- src/Language/PureScript/Ide/State.hs | 2 +- src/Language/PureScript/Ide/Types.hs | 2 +- src/Language/PureScript/Ide/Usage.hs | 2 +- src/Language/PureScript/Ide/Util.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 3 +-- src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- src/Language/PureScript/Types.hs | 3 +-- tests/Language/PureScript/Ide/StateSpec.hs | 2 +- 14 files changed, 13 insertions(+), 16 deletions(-) create mode 100644 CHANGELOG.d/internal_drop-microlens.md diff --git a/CHANGELOG.d/internal_drop-microlens.md b/CHANGELOG.d/internal_drop-microlens.md new file mode 100644 index 0000000000..a62ada0ca3 --- /dev/null +++ b/CHANGELOG.d/internal_drop-microlens.md @@ -0,0 +1 @@ +* Drop dependency on microlens libraries diff --git a/purescript.cabal b/purescript.cabal index d0f1ec2293..36794cbf5a 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -149,8 +149,6 @@ common defaults lifted-async >=0.10.2.2 && <0.11, lifted-base >=0.2.3.12 && <0.3, memory >=0.15.0 && <0.16, - microlens >=0.4.12.0 && <0.5, - microlens-platform >=0.4.2 && <0.5, monad-control >=1.0.3.1 && <1.1, monad-logger >=0.3.36 && <0.4, monoidal-containers >=0.6.2.0 && <0.7, diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 8914aae48d..206d905b6d 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -11,6 +11,7 @@ module Language.PureScript.Ide.Completion import Protolude hiding ((<&>), moduleName) +import Control.Lens hiding (op, (&)) import Data.Aeson import qualified Data.Map as Map import qualified Data.Text as T @@ -20,7 +21,6 @@ import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import Lens.Micro.Platform hiding ((&)) -- | Applies the CompletionFilters and the Matcher to the given Modules -- and sorts the found Completions according to the Matching Score diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 7a67d160d8..4ca2d7a6c8 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -8,6 +8,7 @@ module Language.PureScript.Ide.Externs import Protolude hiding (to, from, (&)) import Codec.CBOR.Term as Term +import Control.Lens hiding (anyOf) import "monad-logger" Control.Monad.Logger import Data.Version (showVersion) import qualified Data.Text as Text @@ -16,7 +17,6 @@ import qualified Language.PureScript.Make.Monad as Make import Language.PureScript.Ide.Error (IdeError (..)) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util (properNameT) -import Lens.Micro.Platform readExternFile :: (MonadIO m, MonadError IdeError m, MonadLogger m) diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 176fccbcc9..a7a9bd3404 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -32,6 +32,7 @@ module Language.PureScript.Ide.Imports import Protolude hiding (moduleName) +import Control.Lens ((^.), (%~), ix, has) import Data.List (findIndex, nubBy, partition) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map @@ -46,7 +47,6 @@ import Language.PureScript.Ide.State import Language.PureScript.Ide.Prim import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import Lens.Micro.Platform ((^.), (%~), ix, has) import System.IO.UTF8 (writeUTF8FileT) data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index c2bbb9f310..bc717d16d2 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -24,11 +24,11 @@ module Language.PureScript.Ide.Reexports import Protolude hiding (moduleName) +import Control.Lens hiding (anyOf, (&)) import qualified Data.Map as Map import qualified Language.PureScript as P import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import Lens.Micro.Platform hiding ((&)) -- | Contains the module with resolved reexports, and possible failures data ReexportResult a diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 25b2af367c..fed4dd6579 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -41,6 +41,7 @@ import Protolude hiding (moduleName) import Control.Arrow import Control.Concurrent.STM +import Control.Lens hiding (anyOf, op, (&)) import "monad-logger" Control.Monad.Logger import Data.IORef import qualified Data.Map.Lazy as Map @@ -54,7 +55,6 @@ import Language.PureScript.Ide.Reexports import Language.PureScript.Ide.SourceFile import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import Lens.Micro.Platform hiding ((&)) import System.Directory (getModificationTime) -- | Resets all State inside psc-ide diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 11946aa21d..8464a08c4c 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -8,6 +8,7 @@ module Language.PureScript.Ide.Types where import Protolude hiding (moduleName) import Control.Concurrent.STM (TVar) +import Control.Lens hiding (op, (.=)) import Control.Monad.Fail (fail) import Data.Aeson (ToJSON, FromJSON, (.=)) import qualified Data.Aeson as Aeson @@ -17,7 +18,6 @@ import qualified Data.Map.Lazy as M import qualified Language.PureScript as P import qualified Language.PureScript.Errors.JSON as P import Language.PureScript.Ide.Filter.Declaration (DeclarationType(..)) -import Lens.Micro.Platform hiding ((.=)) type ModuleIdent = Text type ModuleMap a = Map P.ModuleName a diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index 81ccee3542..0694b6f523 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -8,13 +8,13 @@ module Language.PureScript.Ide.Usage import Protolude hiding (moduleName) +import Control.Lens (preview) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Language.PureScript as P import Language.PureScript.Ide.State (getAllModules, getFileState) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import Lens.Micro.Platform (preview) -- | -- How we find usages, given an IdeDeclaration and the module it was defined in: diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 4905bd71d4..5f13157ed2 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -32,6 +32,7 @@ module Language.PureScript.Ide.Util import Protolude hiding (decodeUtf8, encodeUtf8, to) +import Control.Lens hiding (op, (&)) import Data.Aeson import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -40,7 +41,6 @@ import qualified Language.PureScript as P import Language.PureScript.Ide.Error (IdeError(..)) import Language.PureScript.Ide.Logging import Language.PureScript.Ide.Types -import Lens.Micro.Platform hiding ((&)) import System.IO.UTF8 (readUTF8FileT) import System.Directory (makeAbsolute) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 7cc2f867cc..5d8a9b39be 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -10,6 +10,7 @@ module Language.PureScript.TypeChecker import Prelude.Compat import Protolude (headMay, maybeToLeft, ordNub) +import Control.Lens ((^..), _2) import Control.Monad (when, unless, void, forM, zipWithM_) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), modify, gets) @@ -47,8 +48,6 @@ import Language.PureScript.TypeChecker.Unify (varIfUnknown) import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types -import Lens.Micro.Platform ((^..), _2) - addDataType :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 41fc593b6d..9066455ca9 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -28,6 +28,7 @@ module Language.PureScript.TypeChecker.Kinds import Prelude.Compat import Control.Arrow ((***)) +import Control.Lens ((^.), _1, _2, _3) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State @@ -55,7 +56,6 @@ import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScop import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.Types import Language.PureScript.Pretty.Types -import Lens.Micro.Platform ((^.), _1, _2, _3) generalizeUnknowns :: [(Unknown, SourceType)] -> SourceType -> SourceType generalizeUnknowns unks ty = diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index ca942e543b..5a23ca146f 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -10,6 +10,7 @@ import Codec.Serialise (Serialise) import Control.Applicative ((<|>)) import Control.Arrow (first, second) import Control.DeepSeq (NFData) +import Control.Lens (Lens', (^.), set) import Control.Monad ((<=<), (>=>)) import Data.Aeson ((.:), (.:?), (.!=), (.=)) import qualified Data.Aeson as A @@ -28,8 +29,6 @@ import Language.PureScript.Names import Language.PureScript.Label (Label) import Language.PureScript.PSString (PSString) -import Lens.Micro (Lens', (^.), set) - type SourceType = Type SourceAnn type SourceConstraint = Constraint SourceAnn diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index a30b57ce99..e1e0611a04 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -1,11 +1,11 @@ module Language.PureScript.Ide.StateSpec where import Protolude +import Control.Lens hiding (anyOf, (&)) import Language.PureScript.Ide.Types import Language.PureScript.Ide.State import Language.PureScript.Ide.Test import qualified Language.PureScript as P -import Lens.Micro.Platform hiding ((&)) import Test.Hspec import qualified Data.Map as Map From f8e342a5f21fcca83eaf00f63af7f2b0ebca7687 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 17 May 2022 12:43:43 -0500 Subject: [PATCH 1468/1580] Fix CI golden test; update test deps' either/tailrec to 6.1.0 (#4329) * Update either/tailrec to 6.1.0 * Update golden test out --- tests/purs/warning/ImplicitQualifiedImportReExport.out | 2 +- tests/support/bower.json | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/purs/warning/ImplicitQualifiedImportReExport.out b/tests/purs/warning/ImplicitQualifiedImportReExport.out index b0667d0940..cbf9bd416d 100644 --- a/tests/purs/warning/ImplicitQualifiedImportReExport.out +++ b/tests/purs/warning/ImplicitQualifiedImportReExport.out @@ -21,7 +21,7 @@ Warning 2 of 2: Module Data.Either was imported as Y with unspecified imports. As this module is being re-exported, consider using the explicit form: - import Data.Either (Either(..), choose, either, fromLeft, fromLeft', fromRight, fromRight', hush, isLeft, isRight, note, note') as Y + import Data.Either (Either(..), blush, choose, either, fromLeft, fromLeft', fromRight, fromRight', hush, isLeft, isRight, note, note') as Y diff --git a/tests/support/bower.json b/tests/support/bower.json index 035f9e076d..dd4d3edec7 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -8,7 +8,7 @@ "purescript-control": "^6.0.0", "purescript-distributive": "^6.0.0", "purescript-effect": "^4.0.0", - "purescript-either": "^6.0.0", + "purescript-either": "^6.1.0", "purescript-enums": "^6.0.0", "purescript-foldable-traversable": "^6.0.0", "purescript-functions": "^6.0.0", @@ -29,7 +29,7 @@ "purescript-safe-coerce": "^2.0.0", "purescript-st": "^6.0.0", "purescript-strings": "^6.0.0", - "purescript-tailrec": "^6.0.0", + "purescript-tailrec": "^6.1.0", "purescript-tuples": "^7.0.0", "purescript-type-equality": "^4.0.1", "purescript-typelevel-prelude": "^7.0.0", From 7ce6178a264ec16b331692fdb2ee73d6369eef01 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 17 May 2022 13:26:13 -0500 Subject: [PATCH 1469/1580] Make 0.15.1 release (#4328) * Run make license-generator * Bump version to 0.15.1 * Update changelog for 0.15.1 --- CHANGELOG.d/bug_fix-prim-int-compare-docs.md | 1 - CHANGELOG.d/feature_3510.md | 1 - ...feature_partially-applied-synonym-check.md | 7 - CHANGELOG.d/fix_3453.md | 3 - CHANGELOG.d/fix_4105.md | 3 - CHANGELOG.d/fix_4180.md | 20 -- CHANGELOG.d/fix_4200.md | 3 - CHANGELOG.d/fix_4229.md | 9 - CHANGELOG.d/fix_4310.md | 1 - ...ix_issue-4308-type-wildcards-in-binders.md | 13 -- CHANGELOG.d/fix_update-prim-docs.md | 1 - CHANGELOG.d/internal_cd.md | 4 - CHANGELOG.d/internal_drop-microlens.md | 1 - CHANGELOG.d/internal_type-traversals.md | 4 - CHANGELOG.md | 93 +++++++++ LICENSE | 179 ------------------ npm-package/package.json | 4 +- purescript.cabal | 2 +- 18 files changed, 96 insertions(+), 253 deletions(-) delete mode 100644 CHANGELOG.d/bug_fix-prim-int-compare-docs.md delete mode 100644 CHANGELOG.d/feature_3510.md delete mode 100644 CHANGELOG.d/feature_partially-applied-synonym-check.md delete mode 100644 CHANGELOG.d/fix_3453.md delete mode 100644 CHANGELOG.d/fix_4105.md delete mode 100644 CHANGELOG.d/fix_4180.md delete mode 100644 CHANGELOG.d/fix_4200.md delete mode 100644 CHANGELOG.d/fix_4229.md delete mode 100644 CHANGELOG.d/fix_4310.md delete mode 100644 CHANGELOG.d/fix_issue-4308-type-wildcards-in-binders.md delete mode 100644 CHANGELOG.d/fix_update-prim-docs.md delete mode 100644 CHANGELOG.d/internal_cd.md delete mode 100644 CHANGELOG.d/internal_drop-microlens.md delete mode 100644 CHANGELOG.d/internal_type-traversals.md diff --git a/CHANGELOG.d/bug_fix-prim-int-compare-docs.md b/CHANGELOG.d/bug_fix-prim-int-compare-docs.md deleted file mode 100644 index 379e54542d..0000000000 --- a/CHANGELOG.d/bug_fix-prim-int-compare-docs.md +++ /dev/null @@ -1 +0,0 @@ -* Fix incorrect `Prim.Int (class Compare)` docs: `Int` & `Ordering`, not `Symbol` diff --git a/CHANGELOG.d/feature_3510.md b/CHANGELOG.d/feature_3510.md deleted file mode 100644 index 819e172a0a..0000000000 --- a/CHANGELOG.d/feature_3510.md +++ /dev/null @@ -1 +0,0 @@ -* Support deriving instances for type synonyms diff --git a/CHANGELOG.d/feature_partially-applied-synonym-check.md b/CHANGELOG.d/feature_partially-applied-synonym-check.md deleted file mode 100644 index 56c4d3ac36..0000000000 --- a/CHANGELOG.d/feature_partially-applied-synonym-check.md +++ /dev/null @@ -1,7 +0,0 @@ -* Check for partially applied syns in kinds, ctors - - This check doesn't prevent any programs from compiling; it just makes - sure that a more specific PartiallyAppliedSynonym error is raised - instead of a KindsDoNotUnify error, which could be interpreted as - implying that a partially applied synonym has a valid kind and would be - supported elsewhere if that kind is expected. diff --git a/CHANGELOG.d/fix_3453.md b/CHANGELOG.d/fix_3453.md deleted file mode 100644 index 8875dd004a..0000000000 --- a/CHANGELOG.d/fix_3453.md +++ /dev/null @@ -1,3 +0,0 @@ -* Fix bad interaction between newtype deriving and type synonyms - - See #3453. diff --git a/CHANGELOG.d/fix_4105.md b/CHANGELOG.d/fix_4105.md deleted file mode 100644 index 064264fdcb..0000000000 --- a/CHANGELOG.d/fix_4105.md +++ /dev/null @@ -1,3 +0,0 @@ -* Fix bad interaction between instance deriving and type synonyms - - See #4105. diff --git a/CHANGELOG.d/fix_4180.md b/CHANGELOG.d/fix_4180.md deleted file mode 100644 index 3fbd318af8..0000000000 --- a/CHANGELOG.d/fix_4180.md +++ /dev/null @@ -1,20 +0,0 @@ -* Fix crash caused by polykinded instances - - A polykinded instance is a class instance where one or more of the type - parameters has an indeterminate kind. For example, the kind of `a` in - - ```purs - instance SomeClass (Proxy a) where ... - ``` - - is indeterminate unless it's somehow used in a constraint or functional - dependency of the instance in a way that determines it. - - The above instance would not have caused the crash; instead, instances needed - to be of the form - - ```purs - instance SomeClass (f a) where ... - ``` - - in order to cause it. diff --git a/CHANGELOG.d/fix_4200.md b/CHANGELOG.d/fix_4200.md deleted file mode 100644 index dc14953b50..0000000000 --- a/CHANGELOG.d/fix_4200.md +++ /dev/null @@ -1,3 +0,0 @@ -* Fix spurious kind unification error triggered by newtype deriving, type synonyms, and polykinds - - See #4200. diff --git a/CHANGELOG.d/fix_4229.md b/CHANGELOG.d/fix_4229.md deleted file mode 100644 index 40b785d49d..0000000000 --- a/CHANGELOG.d/fix_4229.md +++ /dev/null @@ -1,9 +0,0 @@ -* Fix bad interaction between module renaming and inliner - - This bug was triggered when modules that the compiler handles specially - are shadowed by local constructors. For example, a constructor named - `Prim` could have caused references to `Prim_1["undefined"]` to be - produced in the compiled code, leading to a reference error at run time. - Less severely, a constructor named `Control_Bind` would have caused the - compiler not to inline known monadic functions, leading to slower and - less readable compiled code. diff --git a/CHANGELOG.d/fix_4310.md b/CHANGELOG.d/fix_4310.md deleted file mode 100644 index 62b2520c9e..0000000000 --- a/CHANGELOG.d/fix_4310.md +++ /dev/null @@ -1 +0,0 @@ -* Fix issue with unnamed instances using type operators diff --git a/CHANGELOG.d/fix_issue-4308-type-wildcards-in-binders.md b/CHANGELOG.d/fix_issue-4308-type-wildcards-in-binders.md deleted file mode 100644 index f7d77f07e6..0000000000 --- a/CHANGELOG.d/fix_issue-4308-type-wildcards-in-binders.md +++ /dev/null @@ -1,13 +0,0 @@ -* Do not emit warnings about type wildcards used in binders (patterns). - - Type wildcards in the following examples no longer trigger a warning: - - ``` - f :: Int - f = 42 # \(x :: _) -> x - - g :: Maybe Int - g = do - x :: _ <- getX - pure $ x + 5 - ``` diff --git a/CHANGELOG.d/fix_update-prim-docs.md b/CHANGELOG.d/fix_update-prim-docs.md deleted file mode 100644 index 8f4f3449b0..0000000000 --- a/CHANGELOG.d/fix_update-prim-docs.md +++ /dev/null @@ -1 +0,0 @@ -* Update `Prim` docs for Boolean, Int, String/Symbol, Number, Record, and Row \ No newline at end of file diff --git a/CHANGELOG.d/internal_cd.md b/CHANGELOG.d/internal_cd.md deleted file mode 100644 index d8439ad23b..0000000000 --- a/CHANGELOG.d/internal_cd.md +++ /dev/null @@ -1,4 +0,0 @@ -* Deploy builds continuously to GitHub and npm - - (Builds triggered by changes that shouldn't affect the published package are - not deployed.) diff --git a/CHANGELOG.d/internal_drop-microlens.md b/CHANGELOG.d/internal_drop-microlens.md deleted file mode 100644 index a62ada0ca3..0000000000 --- a/CHANGELOG.d/internal_drop-microlens.md +++ /dev/null @@ -1 +0,0 @@ -* Drop dependency on microlens libraries diff --git a/CHANGELOG.d/internal_type-traversals.md b/CHANGELOG.d/internal_type-traversals.md deleted file mode 100644 index 2bba7424a5..0000000000 --- a/CHANGELOG.d/internal_type-traversals.md +++ /dev/null @@ -1,4 +0,0 @@ -* Fix incomplete type traversals - - This corrects oversights in some compiler internals that are not known to be - the cause of any user-facing issues. diff --git a/CHANGELOG.md b/CHANGELOG.md index 75f52f84b5..7ab4dbb097 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,99 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.1 + +New features: + +* Check for partially applied synonyms in kinds, ctors (#4169 by @rhendric) + + This check doesn't prevent any programs from compiling; it just makes + sure that a more specific `PartiallyAppliedSynonym` error is raised + instead of a `KindsDoNotUnify` error, which could be interpreted as + implying that a partially applied synonym has a valid kind and would be + supported elsewhere if that kind is expected. + +* Support deriving instances for type synonyms (#4315 by @rhendric) + +Bugfixes: + +* Do not emit warnings about type wildcards used in binders (patterns). (#4309 by @fsoikin) + + Type wildcards in the following examples no longer trigger a warning: + + ``` + f :: Int + f = 42 # \(x :: _) -> x + + g :: Maybe Int + g = do + x :: _ <- getX + pure $ x + 5 + ``` + +* Fix issue with unnamed instances using type operators (#4311 by @rhendric) + +* Fix incorrect `Prim.Int (class Compare)` docs: `Int` & `Ordering`, not `Symbol` (#4313 by @JordanMartinez) + +* Fix bad interaction between module renaming and inliner (#4322 by @rhendric) + + This bug was triggered when modules that the compiler handles specially + are shadowed by local constructors. For example, a constructor named + `Prim` could have caused references to `Prim_1["undefined"]` to be + produced in the compiled code, leading to a reference error at run time. + Less severely, a constructor named `Control_Bind` would have caused the + compiler not to inline known monadic functions, leading to slower and + less readable compiled code. + +* Update `Prim` docs for Boolean, Int, String/Symbol, Number, Record, and Row (#4317 by @JordanMartinez) + +* Fix crash caused by polykinded instances (#4325 by @rhendric) + + A polykinded instance is a class instance where one or more of the type + parameters has an indeterminate kind. For example, the kind of `a` in + + ```purs + instance SomeClass (Proxy a) where ... + ``` + + is indeterminate unless it's somehow used in a constraint or functional + dependency of the instance in a way that determines it. + + The above instance would not have caused the crash; instead, instances needed + to be of the form + + ```purs + instance SomeClass (f a) where ... + ``` + + in order to cause it. + +* Fix bad interaction between newtype deriving and type synonyms (#4315 by @rhendric) + + See #3453. + +* Fix bad interaction between instance deriving and type synonyms (#4315 by @rhendric) + + See #4105. + +* Fix spurious kind unification error triggered by newtype deriving, type synonyms, and polykinds (#4315 by @rhendric) + + See #4200. + +Internal: + +* Deploy builds continuously to GitHub and npm (#4306 and #4324 by @rhendric) + + (Builds triggered by changes that shouldn't affect the published package are + not deployed.) + +* Fix incomplete type traversals (#4155 by @rhendric) + + This corrects oversights in some compiler internals that are not known to be + the cause of any user-facing issues. + +* Drop dependency on microlens libraries (#4327 by @rhendric) + ## 0.15.0 Breaking changes: diff --git a/LICENSE b/LICENSE index 89c19ef2b4..4b6dcc8159 100644 --- a/LICENSE +++ b/LICENSE @@ -95,11 +95,6 @@ PureScript uses the following Haskell library packages. Their license files foll lifted-async lifted-base memory - microlens - microlens-ghc - microlens-mtl - microlens-platform - microlens-th monad-control monad-logger monad-loops @@ -2770,180 +2765,6 @@ memory LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -microlens LICENSE file: - - Copyright (c) 2013-2016 Edward Kmett, - 2015-2016 Artyom Kazak, - 2018 Monadfix - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Monadfix nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -microlens-ghc LICENSE file: - - Copyright (c) 2013-2016 Edward Kmett, - 2015-2016 Artyom Kazak, - 2018 Monadfix - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Monadfix nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -microlens-mtl LICENSE file: - - Copyright (c) 2013-2016 Edward Kmett, - 2015-2016 Artyom Kazak, - 2018 Monadfix - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Monadfix nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -microlens-platform LICENSE file: - - Copyright (c) 2012-2016 Edward Kmett, - 2015-2016 Artyom Kazak, - 2018 Monadfix - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Monadfix nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -microlens-th LICENSE file: - - Copyright (c) 2013-2016 Eric Mertens, Edward Kmett, Artyom Kazak - 2018 Monadfix - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Monadfix nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - monad-control LICENSE file: Copyright © 2010, Bas van Dijk, Anders Kaseorg diff --git a/npm-package/package.json b/npm-package/package.json index d3dab36ff1..e9c2dc8f65 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.0", + "version": "0.15.1", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.0", + "postinstall": "install-purescript --purs-ver=0.15.1", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index 36794cbf5a..7d2c09171a 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.0 +version: 0.15.1 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 79a76e4265a15b3950cc2dbd85a5b82dc6ab0d8b Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Tue, 17 May 2022 15:51:20 -0400 Subject: [PATCH 1470/1580] Only update version number for prerelease (#4330) --- .github/workflows/ci.yml | 17 ++++++++++------- ci/build.sh | 33 ++++++++++++++++++--------------- 2 files changed, 28 insertions(+), 22 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index b16bcb6955..a30d3c7b3c 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -18,13 +18,16 @@ env: STACK_VERSION: "2.7.3" concurrency: - # We never want two releases or prereleases building at the same time, since - # they would likely both claim the same version number. Pull request builds - # can happen in parallel with anything else, since they don't mutate global - # state with a release. (GitHub Actions is either too cheap to give us `if` - # expressions or too lazy to document them, but we have untyped boolean - # operators to fall back on.) - group: "${{ github.event_name == 'pull_request' && github.run_id || 'continuous-deployment' }}" + # We never want two prereleases building at the same time, since they would + # likely both claim the same version number. Pull request builds can happen + # in parallel with anything else, since they don't mutate global state with a + # release. Release builds don't change their behavior based on published + # state, so they don't interfere with each other and there's no point in + # canceling a prerelease build if a release build starts; and we would never + # want a release build to be canceled by a prerelease build either. (GitHub + # Actions is either too cheap to give us `if` expressions or too lazy to + # document them, but we have untyped boolean operators to fall back on.) + group: "${{ github.event_name != 'push' && github.run_id || 'continuous-deployment' }}" cancel-in-progress: true jobs: diff --git a/ci/build.sh b/ci/build.sh index e528aaabb8..a01c953c30 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -37,22 +37,25 @@ fi (echo "::endgroup::"; echo "::group::Set version number for build") 2>/dev/null -git fetch --depth=1 origin "v$(npm view purescript@next version)" - -# List of files/folders to use to detect if a new prerelease should be issued. -# Any path that could contain files that affect the built bundles or the -# published npm package should be included here. Paths that no longer exist -# should be deleted. A false positive is not as big a deal as a false negative, -# so err on the side of including stuff. -if git diff --quiet FETCH_HEAD HEAD -- \ - .github/workflows app bundle ci npm-package src \ - purescript.cabal stack.yaml +if [ "$CI_PRERELEASE" = "true" ] then - echo "Skipping prerelease because no input affecting the published package was" - echo "changed since the last prerelease" - echo "::set-output name=do-not-prerelease::true" -else - do_prerelease=true + git fetch --depth=1 origin "v$(npm view purescript@next version)" + + # List of files/folders to use to detect if a new prerelease should be + # issued. Any path that could contain files that affect the built bundles or + # the published npm package should be included here. Paths that no longer + # exist should be deleted. A false positive is not as big a deal as a false + # negative, so err on the side of including stuff. + if git diff --quiet FETCH_HEAD HEAD -- \ + .github/workflows app bundle ci npm-package src \ + purescript.cabal stack.yaml + then + echo "Skipping prerelease because no input affecting the published package was" + echo "changed since the last prerelease" + echo "::set-output name=do-not-prerelease::true" + else + do_prerelease=true + fi fi package_version=$(node -pe 'require("./npm-package/package.json").version') From 493867a9981526db771d1c4f6163296a1d497e23 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Tue, 17 May 2022 17:22:35 -0400 Subject: [PATCH 1471/1580] Make 0.15.2 release (#4331) --- CHANGELOG.md | 6 +++++- npm-package/package.json | 4 ++-- purescript.cabal | 2 +- 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7ab4dbb097..daec42a74e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,7 +2,7 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). -## 0.15.1 +## 0.15.2 New features: @@ -95,6 +95,10 @@ Internal: * Drop dependency on microlens libraries (#4327 by @rhendric) +## 0.15.1 + +Release skipped; use [0.15.2](#0152). + ## 0.15.0 Breaking changes: diff --git a/npm-package/package.json b/npm-package/package.json index e9c2dc8f65..6d4610b315 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.1", + "version": "0.15.2", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.1", + "postinstall": "install-purescript --purs-ver=0.15.2", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index 7d2c09171a..4289c89a73 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.1 +version: 0.15.2 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 1f6157d93723b57a6a7be453ceff1d38556d2eff Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Wed, 18 May 2022 11:06:45 -0500 Subject: [PATCH 1472/1580] Stop requiring devDependencies to publish (#4332) --- CHANGELOG.d/fix_4298-stop-requiring-dev-deps.md | 1 + src/Language/PureScript/Publish.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/fix_4298-stop-requiring-dev-deps.md diff --git a/CHANGELOG.d/fix_4298-stop-requiring-dev-deps.md b/CHANGELOG.d/fix_4298-stop-requiring-dev-deps.md new file mode 100644 index 0000000000..26bb0aeb4c --- /dev/null +++ b/CHANGELOG.d/fix_4298-stop-requiring-dev-deps.md @@ -0,0 +1 @@ +* Stop requiring `bower.json` `devDependencies` when publishing \ No newline at end of file diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 2e1d468abe..cc4f94cae1 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -158,7 +158,7 @@ preparePackage' opts = do (pkgModules, pkgModuleMap) <- getModules opts (map (second fst) resolvedDeps) - let declaredDeps = map fst $ Bower.bowerDependencies pkgMeta ++ Bower.bowerDevDependencies pkgMeta + let declaredDeps = map fst $ Bower.bowerDependencies pkgMeta pkgResolvedDependencies <- handleDeps declaredDeps (map (second snd) resolvedDeps) let pkgUploader = D.NotYetKnown From d721f48ddf4bc633f465948f3510698b4636de8e Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Wed, 18 May 2022 13:22:14 -0400 Subject: [PATCH 1473/1580] Float compiler-synthesized function applications (#3915) This commit implements a common subexpression elimination pass during CoreFn optimization. The optimizer only targets `App`s that the compiler has created, meaning: applying functions to typeclass dictionaries, accessing superclasses from a typeclass dictionary, or creating new instances of `IsSymbol`. Furthermore, the pass only moves subexpressions if they can be moved to an outer function or if the subexpression appears more than once inside the scope to which it would be moved. --- .../feature_cse-for-typeclass-dicts.md | 10 + purescript.cabal | 2 + src/Control/Monad/Supply.hs | 7 + src/Control/Monad/Supply/Class.hs | 4 +- src/Language/PureScript/CodeGen/JS.hs | 36 +- src/Language/PureScript/CodeGen/JS/Printer.hs | 2 +- src/Language/PureScript/Constants/Prelude.hs | 9 + src/Language/PureScript/CoreFn/Binders.hs | 2 +- src/Language/PureScript/CoreFn/CSE.hs | 428 ++++++++++++++++++ src/Language/PureScript/CoreFn/Desugar.hs | 14 +- src/Language/PureScript/CoreFn/Expr.hs | 6 +- src/Language/PureScript/CoreFn/FromJSON.hs | 2 + src/Language/PureScript/CoreFn/Meta.hs | 4 + src/Language/PureScript/CoreFn/Optimizer.hs | 8 +- src/Language/PureScript/CoreFn/ToJSON.hs | 1 + src/Language/PureScript/CoreImp/AST.hs | 14 +- src/Language/PureScript/CoreImp/Optimizer.hs | 43 +- .../PureScript/CoreImp/Optimizer/Inliner.hs | 47 +- .../PureScript/CoreImp/Optimizer/MagicDo.hs | 20 +- .../PureScript/CoreImp/Optimizer/TCO.hs | 14 +- .../PureScript/CoreImp/Optimizer/Unused.hs | 25 + src/Language/PureScript/Make.hs | 4 +- tests/purs/optimize/4179.out.js | 8 +- tests/purs/optimize/Monad.out.js | 30 ++ tests/purs/optimize/Monad.purs | 17 + tests/purs/optimize/Primitives.out.js | 10 + tests/purs/optimize/Primitives.purs | 9 + tests/purs/optimize/RecursiveInstances.out.js | 107 +++++ tests/purs/optimize/RecursiveInstances.purs | 31 ++ tests/purs/optimize/Symbols.out.js | 68 +++ tests/purs/optimize/Symbols.purs | 40 ++ tests/purs/passing/CyclicInstances.purs | 29 ++ tests/purs/passing/TCOFloated.purs | 11 + 33 files changed, 984 insertions(+), 78 deletions(-) create mode 100644 CHANGELOG.d/feature_cse-for-typeclass-dicts.md create mode 100644 src/Language/PureScript/CoreFn/CSE.hs create mode 100644 tests/purs/optimize/Monad.out.js create mode 100644 tests/purs/optimize/Monad.purs create mode 100644 tests/purs/optimize/Primitives.out.js create mode 100644 tests/purs/optimize/Primitives.purs create mode 100644 tests/purs/optimize/RecursiveInstances.out.js create mode 100644 tests/purs/optimize/RecursiveInstances.purs create mode 100644 tests/purs/optimize/Symbols.out.js create mode 100644 tests/purs/optimize/Symbols.purs create mode 100644 tests/purs/passing/CyclicInstances.purs create mode 100644 tests/purs/passing/TCOFloated.purs diff --git a/CHANGELOG.d/feature_cse-for-typeclass-dicts.md b/CHANGELOG.d/feature_cse-for-typeclass-dicts.md new file mode 100644 index 0000000000..4846ef0323 --- /dev/null +++ b/CHANGELOG.d/feature_cse-for-typeclass-dicts.md @@ -0,0 +1,10 @@ +* Float compiler-synthesized function applications + + This is a limited implementation of common subexpression elimination for + expressions created by the compiler in the process of creating and using + typeclass dictionaries. Users can expect code that heavily uses typeclasses + to produce JavaScript that is shorter, simpler, and faster. + + Common subexpression elimination is not applied to any expressions explicitly + written by users. If you want those floated to a higher scope, you have to do + so manually. diff --git a/purescript.cabal b/purescript.cabal index 4289c89a73..ba60be7446 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -63,6 +63,7 @@ common defaults DeriveTraversable DeriveGeneric DerivingStrategies + DerivingVia EmptyDataDecls FlexibleContexts FlexibleInstances @@ -207,6 +208,7 @@ library Language.PureScript.CoreFn Language.PureScript.CoreFn.Ann Language.PureScript.CoreFn.Binders + Language.PureScript.CoreFn.CSE Language.PureScript.CoreFn.Desugar Language.PureScript.CoreFn.Expr Language.PureScript.CoreFn.FromJSON diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs index 65e48f97a9..1ddb3e8a92 100644 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -11,6 +11,8 @@ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer +import Data.Functor.Identity + newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus) @@ -19,3 +21,8 @@ runSupplyT n = flip runStateT n . unSupplyT evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a evalSupplyT n = fmap fst . runSupplyT n + +type Supply = SupplyT Identity + +runSupply :: Integer -> Supply a -> (a, Integer) +runSupply n = runIdentity . runSupplyT n diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index 409340b6e9..4642efcc19 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -6,8 +6,9 @@ module Control.Monad.Supply.Class where import Prelude.Compat -import Control.Monad.Supply +import Control.Monad.RWS import Control.Monad.State +import Control.Monad.Supply import Control.Monad.Writer import Data.Text (Text, pack) @@ -28,6 +29,7 @@ instance Monad m => MonadSupply (SupplyT m) where instance MonadSupply m => MonadSupply (StateT s m) instance (Monoid w, MonadSupply m) => MonadSupply (WriterT w m) +instance (Monoid w, MonadSupply m) => MonadSupply (RWST r w s m) freshName :: MonadSupply m => m Text freshName = fmap (("$" <> ) . pack . show) fresh diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 0dec7807f3..c483180fe8 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -30,7 +30,7 @@ import qualified Data.Text as T import Language.PureScript.AST.SourcePos import Language.PureScript.CodeGen.JS.Common as Common -import Language.PureScript.CoreImp.AST (AST, everywhere, everywhereTopDownM, withSourceSpan) +import Language.PureScript.CoreImp.AST (AST, InitializerEffects(..), everywhere, everywhereTopDownM, withSourceSpan) import qualified Language.PureScript.CoreImp.AST as AST import qualified Language.PureScript.CoreImp.Module as AST import Language.PureScript.CoreImp.Optimizer @@ -62,7 +62,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = let imps' = ordNub $ map snd imps let mnLookup = renameImports usedNames imps' (jsDecls, Any needRuntimeLazy) <- runWriterT $ mapM (moduleBindToJs mn) decls - optimized <- traverse (traverse (fmap annotatePure . optimize)) (if needRuntimeLazy then [runtimeLazy] : jsDecls else jsDecls) + optimized <- fmap (fmap (fmap annotatePure)) . optimize (map identToJs exps) $ if needRuntimeLazy then [runtimeLazy] : jsDecls else jsDecls F.traverse_ (F.traverse_ checkIntegers) optimized comments <- not <$> asks optionsNoComments let header = if comments then coms else [] @@ -108,7 +108,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = maybePure' = maybePureGen True maybePureGen alreadyAnnotated = \case - AST.VariableIntroduction ss name j -> Just (AST.VariableIntroduction ss name (annotateOrWrap <$> j)) + AST.VariableIntroduction ss name j -> Just (AST.VariableIntroduction ss name (fmap annotateOrWrap <$> j)) AST.App ss f args -> (if alreadyAnnotated then AST.App else pureApp) ss <$> maybePure' f <*> traverse maybePure args AST.ArrayLiteral ss jss -> AST.ArrayLiteral ss <$> traverse maybePure jss AST.ObjectLiteral ss props -> AST.ObjectLiteral ss <$> traverse (traverse maybePure) props @@ -209,8 +209,8 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = runtimeLazy :: AST runtimeLazy = - AST.VariableIntroduction Nothing "$runtime_lazy" . Just . AST.Function Nothing Nothing ["name", "moduleName", "init"] . AST.Block Nothing $ - [ AST.VariableIntroduction Nothing "state" . Just . AST.NumericLiteral Nothing $ Left 0 + AST.VariableIntroduction Nothing "$runtime_lazy" . Just . (UnknownEffects, ) . AST.Function Nothing Nothing ["name", "moduleName", "init"] . AST.Block Nothing $ + [ AST.VariableIntroduction Nothing "state" . Just . (UnknownEffects, ) . AST.NumericLiteral Nothing $ Left 0 , AST.VariableIntroduction Nothing "val" Nothing , AST.Return Nothing . AST.Function Nothing Nothing ["lineNumber"] . AST.Block Nothing $ [ AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing "state") (AST.NumericLiteral Nothing (Left 2))) (AST.Return Nothing $ AST.Var Nothing "val") Nothing @@ -261,7 +261,13 @@ moduleBindToJs mn = bindToJs else AST.Comment (AST.SourceComments com) <$> nonRecToJS a i (modifyAnn removeComments e) nonRecToJS (ss, _, _, _) ident val = do js <- valueToJs val - withPos ss $ AST.VariableIntroduction Nothing (identToJs ident) (Just js) + withPos ss $ AST.VariableIntroduction Nothing (identToJs ident) (Just (guessEffects val, js)) + + guessEffects :: Expr Ann -> AST.InitializerEffects + guessEffects = \case + Var _ (Qualified Nothing _) -> NoEffects + App (_, _, _, Just IsSyntheticApp) _ _ -> NoEffects + _ -> UnknownEffects withPos :: SourceSpan -> AST -> m AST withPos ss js = do @@ -327,7 +333,7 @@ moduleBindToJs mn = bindToJs ret <- valueToJs val return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (ds' ++ [AST.Return Nothing ret]))) [] valueToJs' (Constructor (_, _, _, Just IsNewtype) _ ctor _) = - return $ AST.VariableIntroduction Nothing (properToJs ctor) (Just $ + return $ AST.VariableIntroduction Nothing (properToJs ctor) (Just . (UnknownEffects, ) $ AST.ObjectLiteral Nothing [("create", AST.Function Nothing Nothing ["value"] (AST.Block Nothing [AST.Return Nothing $ AST.Var Nothing "value"]))]) @@ -369,8 +375,8 @@ moduleBindToJs mn = bindToJs jsNewObj = AST.Var Nothing newObj jsEvaluatedObj = AST.Var Nothing evaluatedObj block = AST.Block Nothing (evaluate:objAssign:copy:extend ++ [AST.Return Nothing jsNewObj]) - evaluate = AST.VariableIntroduction Nothing evaluatedObj (Just obj) - objAssign = AST.VariableIntroduction Nothing newObj (Just $ AST.ObjectLiteral Nothing []) + evaluate = AST.VariableIntroduction Nothing evaluatedObj (Just (UnknownEffects, obj)) + objAssign = AST.VariableIntroduction Nothing newObj (Just (NoEffects, AST.ObjectLiteral Nothing [])) copy = AST.ForIn Nothing key jsEvaluatedObj $ AST.Block Nothing [AST.IfElse Nothing cond assign Nothing] cond = AST.App Nothing (accessorString "call" (accessorString "hasOwnProperty" (AST.ObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey] assign = AST.Block Nothing [AST.Assignment Nothing (AST.Indexer Nothing jsKey jsNewObj) (AST.Indexer Nothing jsKey jsEvaluatedObj)] @@ -399,7 +405,7 @@ moduleBindToJs mn = bindToJs bindersToJs :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST bindersToJs ss binders vals = do valNames <- replicateM (length vals) freshName - let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals) + let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map (Just . (UnknownEffects, )) vals) jss <- forM binders $ \(CaseAlternative bs result) -> do ret <- guardsToJs result go valNames ret bs @@ -448,7 +454,7 @@ moduleBindToJs mn = bindToJs binderToJs' varName done (LiteralBinder _ l) = literalToBinderJS varName done l binderToJs' varName done (VarBinder _ ident) = - return (AST.VariableIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : done) + return (AST.VariableIntroduction Nothing (identToJs ident) (Just (NoEffects, AST.Var Nothing varName)) : done) binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) = binderToJs varName done b binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do @@ -466,12 +472,12 @@ moduleBindToJs mn = bindToJs argVar <- freshName done'' <- go remain done' js <- binderToJs argVar done'' binder - return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToJs field) $ AST.Var Nothing varName) : js) + return (AST.VariableIntroduction Nothing argVar (Just (UnknownEffects, accessorString (mkString $ identToJs field) $ AST.Var Nothing varName)) : js) binderToJs' _ _ ConstructorBinder{} = internalError "binderToJs: Invalid ConstructorBinder in binderToJs" binderToJs' varName done (NamedBinder _ ident binder) = do js <- binderToJs varName done binder - return (AST.VariableIntroduction Nothing (identToJs ident) (Just (AST.Var Nothing varName)) : js) + return (AST.VariableIntroduction Nothing (identToJs ident) (Just (NoEffects, AST.Var Nothing varName)) : js) literalToBinderJS :: Text -> [AST] -> Literal (Binder Ann) -> m [AST] literalToBinderJS varName done (NumericLiteral num) = @@ -492,7 +498,7 @@ moduleBindToJs mn = bindToJs propVar <- freshName done'' <- go done' bs' js <- binderToJs propVar done'' binder - return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : js) + return (AST.VariableIntroduction Nothing propVar (Just (UnknownEffects, accessorString prop (AST.Var Nothing varName))) : js) literalToBinderJS varName done (ArrayLiteral bs) = do js <- go done 0 bs return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (accessorString "length" (AST.Var Nothing varName)) (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs)))) (AST.Block Nothing js) Nothing] @@ -503,7 +509,7 @@ moduleBindToJs mn = bindToJs elVar <- freshName done'' <- go done' (index + 1) bs' js <- binderToJs elVar done'' binder - return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js) + return (AST.VariableIntroduction Nothing elVar (Just (UnknownEffects, AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : js) accessorString :: PSString -> AST -> AST accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop) diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index 8ffc0403d2..5cba6c7b3b 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -73,7 +73,7 @@ literals = mkPattern' match' match (Var _ ident) = return $ emit ident match (VariableIntroduction _ ident value) = mconcat <$> sequence [ return $ emit $ "var " <> ident - , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value + , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS' . snd) value ] match (Assignment _ target value) = mconcat <$> sequence [ prettyPrintJS' target diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index 99ff5aa1fc..1bc229442c 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -113,6 +113,9 @@ zshr = "zshr" complement :: forall a. (IsString a) => a complement = "complement" +identity :: forall a. (IsString a) => a +identity = "identity" + -- Prelude Values zero :: forall a. (IsString a) => a @@ -265,6 +268,9 @@ semigroupString = "semigroupString" semigroupoidFn :: forall a. (IsString a) => a semigroupoidFn = "semigroupoidFn" +categoryFn :: forall a. (IsString a) => a +categoryFn = "categoryFn" + -- Data.Symbol pattern DataSymbol :: ModuleName @@ -321,6 +327,9 @@ pattern ControlSemigroupoid = ModuleName "Control.Semigroupoid" pattern ControlBind :: ModuleName pattern ControlBind = ModuleName "Control.Bind" +pattern ControlCategory :: ModuleName +pattern ControlCategory = ModuleName "Control.Category" + pattern ControlMonadEffUncurried :: ModuleName pattern ControlMonadEffUncurried = ModuleName "Control.Monad.Eff.Uncurried" diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index 94ff20ff4b..c43763f80f 100644 --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -31,7 +31,7 @@ data Binder a -- | -- A binder which binds its input to an identifier -- - | NamedBinder a Ident (Binder a) deriving (Eq, Show, Functor) + | NamedBinder a Ident (Binder a) deriving (Eq, Ord, Show, Functor) extractBinderAnn :: Binder a -> a diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs new file mode 100644 index 0000000000..83a1beca2e --- /dev/null +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | This module performs limited common subexpression elimination +module Language.PureScript.CoreFn.CSE (optimizeCommonSubexpressions) where + +import Protolude hiding (pass) + +import Control.Lens +import Control.Monad.Supply (Supply) +import Control.Monad.Supply.Class (MonadSupply) +import Control.Monad.RWS (MonadWriter, RWST, censor, evalRWST, listen, pass, tell) +import Data.Bitraversable (bitraverse) +import Data.Functor.Compose (Compose(..)) +import qualified Data.IntMap.Monoidal as IM +import qualified Data.IntSet as IS +import qualified Data.Map as M +import Data.Maybe (fromJust) +import Data.Semigroup (Min(..)) +import Data.Semigroup.Generic (GenericSemigroupMonoid(..)) + +import Language.PureScript.AST.Literals +import Language.PureScript.AST.SourcePos (nullSourceSpan) +import qualified Language.PureScript.Constants.Prelude as C +import Language.PureScript.CoreFn.Ann (Ann) +import Language.PureScript.CoreFn.Binders +import Language.PureScript.CoreFn.Expr +import Language.PureScript.CoreFn.Meta (Meta(IsSyntheticApp)) +import Language.PureScript.CoreFn.Traversals +import Language.PureScript.Environment (dictTypeName) +import Language.PureScript.Names +import Language.PureScript.PSString (decodeString) + +-- | +-- `discuss f m` is an action that listens to the output of `m`, passes that +-- and its value through `f`, and uses (only) the value of the result to set +-- the new value and output. (Any output produced via the monad in `f` is +-- ignored, though other monadic effects will hold.) +-- +discuss :: MonadWriter w m => ((a, w) -> m (b, w)) -> m a -> m b +discuss f = pass . fmap (second const) . (f <=< listen) + +-- | +-- Modify the target of an optic in the state with a monadic computation that +-- returns some extra information of type `r` in a tuple. +-- +-- I would prefer that this be a named function, but I don't know what to name +-- it. I went with symbols instead because the function that this operator most +-- resembles is `(%%=)`, which doesn't have a textual name as far as I know. +-- Compare the following (approximate) types: +-- +-- @ +-- (%%=) :: MonadState s m => Lens s s a b -> (a -> (r, b)) -> m r +-- (%%<~) :: MonadState s m => Lens s s a b -> (a -> m (r, b)) -> m r +-- @ +-- +-- Replacing the `=` with `<~` was inspired by analogy with the following pair: +-- +-- @ +-- (.=) :: MonadState s m => Lens s s a b -> b -> m () +-- (<~) :: MonadState s m => Lens s s a b -> m b -> m () +-- @ +-- +-- I regret any confusion that ensues. +-- +-- Note that there are two interpretations that could reasonably be expected +-- for this type. +-- +-- @ +-- (%%<~) :: MonadState s m => Lens s s a b -> (a -> m (r, b)) -> m r +-- @ +-- +-- One is: +-- * Get the focused `a` value from the monad +-- * Run the computation +-- * Get the new state from the returned monad +-- * Take the returned `b` value and set it in the new state +-- +-- The other is: +-- * Get the focused `a` value from the monad +-- * Run the computation +-- * Take the returned `b` value and set it in the *original* state +-- * Put the result into the returned monad +-- +-- This operator corresponds to the second interpretation. The purpose of this, +-- and part of the purpose of having this operator at all instead of composing +-- simpler operators, is to enable using the lens only once (on the original +-- state) instead of twice (for a get and a set on different states). +-- +(%%<~) + :: MonadState s m + => ((a -> Compose m ((,) r) b) -> s -> Compose m ((,) r) s) + -- ^ please read as Lens s s a b + -> (a -> m (r, b)) + -> m r +l %%<~ f = get >>= getCompose . l (Compose . f) >>= state . const +infix 4 %%<~ + +-- | +-- A PluralityMap is like a weaker multiset: like a multiset, it can hold +-- several of the same value, but instead of keeping track of their exact +-- counts, it only records whether there is one (False) or more than one +-- (True). +-- +newtype PluralityMap k = PluralityMap { getPluralityMap :: M.Map k Bool } + +instance Ord k => Semigroup (PluralityMap k) where + PluralityMap l <> PluralityMap r = + let + l' = M.mapWithKey (\k -> (|| k `M.member` r)) l + in PluralityMap $ l' `M.union` r + +instance Ord k => Monoid (PluralityMap k) where + mempty = PluralityMap M.empty + +data BindingType = NonRecursive | Recursive deriving Eq + +-- | +-- Record summary data about an expression. +-- +data CSESummary = CSESummary + { _scopesUsed :: IS.IntSet + -- ^ set of the scope numbers used in this expression + , _noFloatWithin :: Maybe (Min Int) + -- ^ optionally a scope within which this expression is not to be floated + -- (because the expression uses an identifier bound recursively in that + -- scope) + , _plurality :: PluralityMap Ident + -- ^ which floated identifiers are used more than once in this expression + -- (note that a single use inside an Abs will be considered multiple uses, + -- as this pass doesn't know when/how many times an Abs will be executed) + , _newBindings :: IM.MonoidalIntMap [(Ident, (PluralityMap Ident, Expr Ann))] + -- ^ floated bindings, organized by scope number + , _toBeReinlined :: M.Map Ident (Expr Ann) + -- ^ a map of floated identifiers that did not end up getting bound and + -- will need to be reinlined at the end of the pass + } + deriving Generic + deriving (Semigroup, Monoid) via GenericSemigroupMonoid CSESummary + +-- | +-- Append a value at a given scope depth. +-- +addToScope :: Semigroup v => Int -> v -> IM.MonoidalIntMap v -> IM.MonoidalIntMap v +addToScope depth v + = IM.alter (Just . maybe v (<> v)) depth + +-- | +-- Remove and return an entire scope from a map of bindings. +-- +popScope :: Monoid v => Int -> IM.MonoidalIntMap v -> (v, IM.MonoidalIntMap v) +popScope depth + = first fold . IM.updateLookupWithKey (\_ _ -> Nothing) depth + +-- | +-- Describe the context of an expression. +-- +data CSEEnvironment = CSEEnvironment + { _depth :: Int + -- ^ number of enclosing binding scopes (this includes not only Abs, but + -- Let and CaseAlternative bindings) + , _bound :: M.Map Ident (Int, BindingType) + -- ^ map from identifiers to depth in which they are bound and whether + -- or not the binding is recursive + } + +makeLenses ''CSESummary +makeLenses ''CSEEnvironment + +-- | +-- Map from the shape of an expression to an identifier created to represent +-- that expression, organized by scope depth. +-- +type CSEState = IM.MonoidalIntMap (M.Map (Expr ()) Ident) + +-- | +-- The monad in which CSE takes place. +-- +type CSEMonad a = RWST CSEEnvironment CSESummary CSEState Supply a + +type HasCSEReader = MonadReader CSEEnvironment +type HasCSEWriter = MonadWriter CSESummary +type HasCSEState = MonadState CSEState + +-- | +-- Run a CSEMonad computation; the return value is augmented with a map of +-- identifiers that should be replaced in the final expression because they +-- didn't end up needing to be floated. +-- +runCSEMonad :: CSEMonad a -> Supply (a, M.Map Ident (Expr Ann)) +runCSEMonad x = second (^. toBeReinlined) <$> evalRWST x (CSEEnvironment 0 M.empty) IM.empty + +-- | +-- Mark all expressions floated out of this computation as "plural". This pass +-- assumes that any given Abs may be invoked multiple times, so any expressions +-- inside the Abs but floated out of it also count as having multiple uses, +-- even if they only appear once within the Abs. Consequently, any expressions +-- that can be floated out of an Abs won't be reinlined at the end. +-- +enterAbs :: HasCSEWriter m => m a -> m a +enterAbs = censor $ plurality %~ PluralityMap . fmap (const True) . getPluralityMap + +-- | +-- Run the provided computation in a new scope. +-- +newScope :: (HasCSEReader m, HasCSEWriter m) => (Int -> m a) -> m a +newScope body = local (depth %~ succ) $ do + d <- view depth + censor (filterToDepth d) (body d) + where + filterToDepth d + = (scopesUsed %~ IS.filter (< d)) + . (noFloatWithin %~ find (< Min d)) + +-- | +-- Record a list of identifiers as being bound in the given scope. +-- +withBoundIdents :: HasCSEReader m => [Ident] -> (Int, BindingType) -> m a -> m a +withBoundIdents idents t = local (bound %~ flip (foldl' (flip (flip M.insert t))) idents) + +-- | +-- Run the provided computation in a new scope in which the provided +-- identifiers are bound non-recursively. +-- +newScopeWithIdents :: (HasCSEReader m, HasCSEWriter m) => [Ident] -> m a -> m a +newScopeWithIdents idents = newScope . flip (withBoundIdents idents . (, NonRecursive)) + +-- | +-- Produce, or retrieve from the state, an identifier for referencing the given +-- expression, at and below the given depth. +-- +generateIdentFor :: (HasCSEState m, MonadSupply m) => Int -> Expr () -> m (Bool, Ident) +generateIdentFor d e = at d . non mempty . at e %%<~ \case + Nothing -> freshIdent (nameHint e) <&> \ident -> ((True, ident), Just ident) + Just ident -> pure ((False, ident), Just ident) + -- A reminder: as with %%=, the first element of the returned pair is the + -- final result of the expression, and the second element is the value to + -- stuff back through the lens into the state. (The difference is that %%<~ + -- enables doing monadic work in the RHS, namely `freshIdent` here.) + where + nameHint = \case + App _ v1 v2 + | Var _ n <- v1 + , fmap (ProperName . runIdent) n == fmap dictTypeName C.IsSymbol + , Literal _ (ObjectLiteral [(_, Abs _ _ (Literal _ (StringLiteral str)))]) <- v2 + , Just decodedStr <- decodeString str + -> decodedStr <> "IsSymbol" + | otherwise + -> nameHint v1 + Var _ (Qualified _ ident) + | Ident name <- ident -> name + | GenIdent (Just name) _ <- ident -> name + Accessor _ prop _ + | Just decodedProp <- decodeString prop -> decodedProp + _ -> "ref" + +nullAnn :: Ann +nullAnn = (nullSourceSpan, [], Nothing, Nothing) + +-- | +-- Use a map to substitute local Vars in a list of Binds. +-- +replaceLocals :: M.Map Ident (Expr Ann) -> [Bind Ann] -> [Bind Ann] +replaceLocals m = if M.null m then identity else map f' where + (f', g', _) = everywhereOnValues identity f identity + f e@(Var _ (Qualified Nothing ident)) = maybe e g' $ ident `M.lookup` m + f e = e + +-- | +-- Store in the monad a new binding for the given expression, returning a Var +-- referencing it. The provided CSESummary will be transformed to reflect the +-- replacement. +-- +floatExpr + :: (HasCSEState m, MonadSupply m) + => (Expr Ann, CSESummary) + -> m (Expr Ann, CSESummary) +floatExpr = \case + (e, w@CSESummary{ _noFloatWithin = Nothing, .. }) -> do + let deepestScope = if IS.null _scopesUsed then 0 else IS.findMax _scopesUsed + (isNew, ident) <- generateIdentFor deepestScope (void e) + let w' = w + & (if isNew then newBindings %~ addToScope deepestScope [(ident, (_plurality, e))] else identity) + & plurality .~ PluralityMap (M.singleton ident False) + pure (Var nullAnn (Qualified Nothing ident), w') + (e, w) -> pure (e, w) + +-- | +-- Take possession of the Binds intended to be added to the current scope, +-- removing them from the state, and return the list of Binds along with +-- whatever value is returned by the provided computation. +-- +getNewBinds + :: (HasCSEReader m, HasCSEState m, HasCSEWriter m) + => m a + -> m ([Bind Ann], a) +getNewBinds = + discuss $ \(a, w) -> do + d <- view depth + at d .= Nothing + let (floatedHere, w') = newBindings (popScope d) w + pure $ first (, a) $ foldr handleFloat ([], w') floatedHere + where + handleFloat (ident, (p, e)) (bs, w) = + if fromJust . M.lookup ident . getPluralityMap $ w ^. plurality + then (NonRec nullAnn ident e : bs, w') + else (bs, w' & toBeReinlined %~ M.insert ident e) + where w' = w & plurality <>~ p + +-- | +-- Like getNewBinds, but also stores the Binds in a Let wrapping the provided +-- expression. If said expression is already a Let, adds these Binds to that +-- Let instead. +-- +getNewBindsAsLet + :: (HasCSEReader m, HasCSEWriter m, HasCSEState m) + => m (Expr Ann) + -> m (Expr Ann) +getNewBindsAsLet = fmap (uncurry go) . getNewBinds where + go bs = if null bs then identity else \case + Let a bs' e' -> Let a (bs ++ bs') e' + e' -> Let nullAnn bs e' + +-- | +-- Feed the Writer part of the monad with the requirements of this name. +-- +summarizeName + :: (HasCSEReader m, HasCSEWriter m) + => ModuleName + -> Qualified Ident + -> m () +summarizeName mn (Qualified mn' ident) = do + m <- view bound + let (s, bt) = + fromMaybe (0, NonRecursive) $ + guard (all (== mn) mn') *> ident `M.lookup` m + tell $ mempty + & scopesUsed .~ IS.singleton s + & noFloatWithin .~ (guard (bt == Recursive) $> Min s) + +-- | +-- Collect all the Idents put in scope by a list of Binders. +-- +identsFromBinders :: [Binder a] -> [Ident] +identsFromBinders = foldMap identsFromBinder where + identsFromBinder = \case + LiteralBinder _ (ArrayLiteral xs) -> identsFromBinders xs + LiteralBinder _ (ObjectLiteral xs) -> identsFromBinders (map snd xs) + VarBinder _ ident -> [ident] + ConstructorBinder _ _ _ xs -> identsFromBinders xs + NamedBinder _ ident x -> ident : identsFromBinder x + LiteralBinder _ BooleanLiteral{} -> [] + LiteralBinder _ CharLiteral{} -> [] + LiteralBinder _ NumericLiteral{} -> [] + LiteralBinder _ StringLiteral{} -> [] + NullBinder{} -> [] + +-- | +-- Float synthetic Apps (right now, the only Apps marked as synthetic are type +-- class dictionaries being fed to functions with constraints, superclass +-- accessors, and instances of IsSymbol) to a new or existing Let as close to +-- the top level as possible. +-- +optimizeCommonSubexpressions :: ModuleName -> [Bind Ann] -> Supply [Bind Ann] +optimizeCommonSubexpressions mn + = fmap (uncurry (flip replaceLocals)) + . runCSEMonad + . fmap (uncurry (++)) + . getNewBinds + . fmap fst + . handleBinds (pure ()) + + where + + -- This is the one place (I think?) that keeps this from being a general + -- common subexpression elimination pass. + shouldFloatExpr :: Expr Ann -> Bool + shouldFloatExpr = \case + App (_, _, _, Just IsSyntheticApp) e _ -> isSimple e + _ -> False + + isSimple :: Expr Ann -> Bool + isSimple = \case + Var{} -> True + Accessor _ _ e -> isSimple e + _ -> False + + handleAndWrapExpr :: Expr Ann -> CSEMonad (Expr Ann) + handleAndWrapExpr = getNewBindsAsLet . handleExpr + + (handleBind, handleExprDefault, handleBinder, _) = traverseCoreFn handleBind handleExpr handleBinder handleCaseAlternative + + handleExpr :: Expr Ann -> CSEMonad (Expr Ann) + handleExpr = discuss (ifM (shouldFloatExpr . fst) floatExpr pure) . \case + Abs a ident e -> enterAbs $ Abs a ident <$> newScopeWithIdents [ident] (handleAndWrapExpr e) + v@(Var _ qname) -> summarizeName mn qname $> v + Let a bs e -> uncurry (Let a) <$> handleBinds (handleExpr e) bs + x -> handleExprDefault x + + handleCaseAlternative :: CaseAlternative Ann -> CSEMonad (CaseAlternative Ann) + handleCaseAlternative (CaseAlternative bs x) = CaseAlternative bs <$> do + newScopeWithIdents (identsFromBinders bs) $ + bitraverse (traverse $ bitraverse handleAndWrapExpr handleAndWrapExpr) handleAndWrapExpr x + + handleBinds :: forall a. CSEMonad a -> [Bind Ann] -> CSEMonad ([Bind Ann], a) + handleBinds = foldr go . fmap pure where + go :: Bind Ann -> CSEMonad ([Bind Ann], a) -> CSEMonad ([Bind Ann], a) + go b inner = case b of + -- For a NonRec Bind, traverse the bound expression in the current scope + -- and then create a new scope for any remaining Binds and/or whatever + -- inner thing all these Binds are applied to. + NonRec a ident e -> do + e' <- handleExpr e + newScopeWithIdents [ident] $ + prependToNewBindsFromInner $ NonRec a ident e' + Rec es -> + -- For a Rec Bind, the bound expressions need a new scope in which all + -- these identifiers are bound recursively; then the remaining Binds + -- and the inner thing can be traversed in the same scope with the same + -- identifiers now bound non-recursively. + newScope $ \d -> do + let idents = map (snd . fst) es + es' <- withBoundIdents idents (d, Recursive) $ traverse (traverse handleExpr) es + withBoundIdents idents (d, NonRecursive) $ + prependToNewBindsFromInner $ Rec es' + + where + + prependToNewBindsFromInner :: Bind Ann -> CSEMonad ([Bind Ann], a) + prependToNewBindsFromInner hd = first (hd :) . join <$> getNewBinds inner diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 474eed9229..8e6f75c922 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -95,7 +95,19 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = exprToCoreFn _ _ _ (A.Abs _ _) = internalError "Abs with Binder argument was not desugared before exprToCoreFn mn" exprToCoreFn ss com ty (A.App v1 v2) = - App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2) + App (ss, com, ty, (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) v1' v2' + where + v1' = exprToCoreFn ss [] Nothing v1 + v2' = exprToCoreFn ss [] Nothing v2 + isDictCtor = \case + A.Constructor _ (Qualified _ name) -> isDictTypeName name + _ -> False + isSynthetic = \case + A.App v3 v4 -> isDictCtor v3 || isSynthetic v3 && isSynthetic v4 + A.Accessor _ v3 -> isSynthetic v3 + A.Var NullSourceSpan _ -> True + A.Unused{} -> True + _ -> False exprToCoreFn ss com ty (A.Unused _) = Var (ss, com, ty, Nothing) (Qualified (Just C.Prim) (Ident C.undefined)) exprToCoreFn _ com ty (A.Var ss ident) = diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index bc8a953fdc..ab56446701 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -52,7 +52,7 @@ data Expr a -- A let binding -- | Let a [Bind a] (Expr a) - deriving (Eq, Show, Functor) + deriving (Eq, Ord, Show, Functor) -- | -- A let or module binding. @@ -65,7 +65,7 @@ data Bind a -- | -- Mutually recursive binding group for several values -- - | Rec [((a, Ident), Expr a)] deriving (Eq, Show, Functor) + | Rec [((a, Ident), Expr a)] deriving (Eq, Ord, Show, Functor) -- | -- A guard is just a boolean-valued expression that appears alongside a set of binders @@ -84,7 +84,7 @@ data CaseAlternative a = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a) - } deriving (Eq, Show) + } deriving (Eq, Ord, Show) instance Functor CaseAlternative where diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index e9aaf93da3..b3c2d52fa9 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -53,6 +53,8 @@ metaFromJSON v = withObject "Meta" metaFromObj v -> return $ Just IsTypeClassConstructor "IsForeign" -> return $ Just IsForeign "IsWhere" -> return $ Just IsWhere + "IsSyntheticApp" + -> return $ Just IsSyntheticApp _ -> fail ("not recognized Meta: " ++ T.unpack type_) isConstructorFromJSON o = do diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs index a656c92df3..028f641b95 100644 --- a/src/Language/PureScript/CoreFn/Meta.hs +++ b/src/Language/PureScript/CoreFn/Meta.hs @@ -31,6 +31,10 @@ data Meta -- The contained value is a where clause -- | IsWhere + -- | + -- The contained function application was synthesized by the compiler + -- + | IsSyntheticApp deriving (Show, Eq, Ord) -- | diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 0d9ff5fc81..d44f18add9 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -1,11 +1,13 @@ module Language.PureScript.CoreFn.Optimizer (optimizeCoreFn) where -import Protolude hiding (Type) +import Protolude hiding (Type, moduleName) +import Control.Monad.Supply (Supply) import Data.List (lookup) import Language.PureScript.AST.Literals import Language.PureScript.AST.SourcePos import Language.PureScript.CoreFn.Ann +import Language.PureScript.CoreFn.CSE import Language.PureScript.CoreFn.Expr import Language.PureScript.CoreFn.Module import Language.PureScript.CoreFn.Traversals @@ -18,8 +20,8 @@ import qualified Language.PureScript.Constants.Prim as C -- | -- CoreFn optimization pass. -- -optimizeCoreFn :: Module Ann -> Module Ann -optimizeCoreFn m = m {moduleDecls = optimizeModuleDecls $ moduleDecls m} +optimizeCoreFn :: Module Ann -> Supply (Module Ann) +optimizeCoreFn m = fmap (\md -> m {moduleDecls = md}) . optimizeCommonSubexpressions (moduleName m) . optimizeModuleDecls $ moduleDecls m optimizeModuleDecls :: [Bind Ann] -> [Bind Ann] optimizeModuleDecls = map transformBinds diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index e50da26dc2..53e26ccba8 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -38,6 +38,7 @@ metaToJSON IsNewtype = object [ T.pack "metaType" .= "IsNewtype" ] metaToJSON IsTypeClassConstructor = object [ T.pack "metaType" .= "IsTypeClassConstructor" ] metaToJSON IsForeign = object [ T.pack "metaType" .= "IsForeign" ] metaToJSON IsWhere = object [ T.pack "metaType" .= "IsWhere" ] +metaToJSON IsSyntheticApp = object [ T.pack "metaType" .= "IsSyntheticApp" ] sourceSpanToJSON :: SourceSpan -> Value sourceSpanToJSON (SourceSpan _ spanStart spanEnd) = diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs index 16720591a9..d7a8a8f441 100644 --- a/src/Language/PureScript/CoreImp/AST.hs +++ b/src/Language/PureScript/CoreImp/AST.hs @@ -52,6 +52,12 @@ data CIComments | PureAnnotation deriving (Show, Eq) +-- | +-- Indicates whether the initializer of a variable is known not to have side +-- effects, and thus can be inlined if needed or removed if unneeded. +-- +data InitializerEffects = NoEffects | UnknownEffects deriving (Show, Eq) + -- | Data type for simplified JavaScript expressions data AST = NumericLiteral (Maybe SourceSpan) (Either Integer Double) @@ -80,7 +86,7 @@ data AST -- ^ Value from another module | Block (Maybe SourceSpan) [AST] -- ^ A block of expressions in braces - | VariableIntroduction (Maybe SourceSpan) Text (Maybe AST) + | VariableIntroduction (Maybe SourceSpan) Text (Maybe (InitializerEffects, AST)) -- ^ A variable introduction and optional initialization | Assignment (Maybe SourceSpan) AST AST -- ^ A variable assignment @@ -174,7 +180,7 @@ everywhere f = go where go (Function ss name args j) = f (Function ss name args (go j)) go (App ss j js) = f (App ss (go j) (map go js)) go (Block ss js) = f (Block ss (map go js)) - go (VariableIntroduction ss name j) = f (VariableIntroduction ss name (fmap go j)) + go (VariableIntroduction ss name j) = f (VariableIntroduction ss name (fmap (fmap go) j)) go (Assignment ss j1 j2) = f (Assignment ss (go j1) (go j2)) go (While ss j1 j2) = f (While ss (go j1) (go j2)) go (For ss name j1 j2 j3) = f (For ss name (go j1) (go j2) (go j3)) @@ -200,7 +206,7 @@ everywhereTopDownM f = f >=> go where go (Function ss name args j) = Function ss name args <$> f' j go (App ss j js) = App ss <$> f' j <*> traverse f' js go (Block ss js) = Block ss <$> traverse f' js - go (VariableIntroduction ss name j) = VariableIntroduction ss name <$> traverse f' j + go (VariableIntroduction ss name j) = VariableIntroduction ss name <$> traverse (traverse f') j go (Assignment ss j1 j2) = Assignment ss <$> f' j1 <*> f' j2 go (While ss j1 j2) = While ss <$> f' j1 <*> f' j2 go (For ss name j1 j2 j3) = For ss name <$> f' j1 <*> f' j2 <*> f' j3 @@ -222,7 +228,7 @@ everything (<>.) f = go where go j@(Function _ _ _ j1) = f j <>. go j1 go j@(App _ j1 js) = foldl (<>.) (f j <>. go j1) (map go js) go j@(Block _ js) = foldl (<>.) (f j) (map go js) - go j@(VariableIntroduction _ _ (Just j1)) = f j <>. go j1 + go j@(VariableIntroduction _ _ (Just (_, j1))) = f j <>. go j1 go j@(Assignment _ j1 j2) = f j <>. go j1 <>. go j2 go j@(While _ j1 j2) = f j <>. go j1 <>. go j2 go j@(For _ _ j1 j2 j3) = f j <>. go j1 <>. go j2 <>. go j3 diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs index de92116251..c4af2658bd 100644 --- a/src/Language/PureScript/CoreImp/Optimizer.hs +++ b/src/Language/PureScript/CoreImp/Optimizer.hs @@ -21,6 +21,8 @@ module Language.PureScript.CoreImp.Optimizer (optimize) where import Prelude.Compat +import Data.Text (Text) + import Control.Monad.Supply.Class (MonadSupply) import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Blocks @@ -31,17 +33,20 @@ import Language.PureScript.CoreImp.Optimizer.TCO import Language.PureScript.CoreImp.Optimizer.Unused -- | Apply a series of optimizer passes to simplified JavaScript code -optimize :: MonadSupply m => AST -> m AST -optimize js = do - js' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . applyAll - [ inlineCommonValues - , inlineCommonOperators - ]) js - untilFixedPoint (return . tidyUp) . tco . inlineST - =<< untilFixedPoint (return . magicDoST) - =<< untilFixedPoint (return . magicDoEff) - =<< untilFixedPoint (return . magicDoEffect) js' +optimize :: forall m. MonadSupply m => [Text] -> [[AST]] -> m [[AST]] +optimize exps jsDecls = removeUnusedEffectFreeVars exps <$> traverse (traverse go) jsDecls where + go :: AST -> m AST + go js = do + js' <- untilFixedPoint (inlineFnComposition expander . inlineFnIdentity expander . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . applyAll + [ inlineCommonValues expander + , inlineCommonOperators expander + ]) js + untilFixedPoint (return . tidyUp) . tco . inlineST + =<< untilFixedPoint (return . magicDoST expander) + =<< untilFixedPoint (return . magicDoEff expander) + =<< untilFixedPoint (return . magicDoEffect expander) js' + tidyUp :: AST -> AST tidyUp = applyAll [ collapseNestedBlocks @@ -54,9 +59,27 @@ optimize js = do , inlineVariables ] + expander = buildExpander (concat jsDecls) + untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a untilFixedPoint f = go where go a = do a' <- f a if a' == a then return a' else go a' + +-- | +-- Take all top-level ASTs and return a function for expanding top-level +-- variables during the various inlining steps in `optimize`. +-- +-- Everything that gets inlined as an optimization is of a form that would +-- have been lifted to a top-level binding during CSE, so for purposes of +-- inlining we can save some time by only expanding variables bound at that +-- level and not worrying about any inner scopes. +-- +buildExpander :: [AST] -> AST -> AST +buildExpander = replaceIdents . foldr go [] + where + go = \case + VariableIntroduction _ name (Just (NoEffects, e)) -> ((name, e) :) + _ -> id diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index 7916cdd262..dc8f330fe4 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -4,6 +4,7 @@ module Language.PureScript.CoreImp.Optimizer.Inliner , inlineCommonValues , inlineCommonOperators , inlineFnComposition + , inlineFnIdentity , inlineUnsafeCoerce , inlineUnsafePartial , etaConvert @@ -79,23 +80,23 @@ inlineVariables = everywhere $ removeFromBlock go where go :: [AST] -> [AST] go [] = [] - go (VariableIntroduction _ var (Just js) : sts) + go (VariableIntroduction _ var (Just (_, js)) : sts) | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) = go (map (replaceIdent var js) sts) go (s:sts) = s : go sts -inlineCommonValues :: AST -> AST -inlineCommonValues = everywhere convert +inlineCommonValues :: (AST -> AST) -> AST -> AST +inlineCommonValues expander = everywhere convert where convert :: AST -> AST - convert (App ss fn [dict]) + convert (expander -> App ss fn [dict]) | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0) | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1) | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True - convert (App ss (App _ fn [dict]) [x]) + convert (App ss (expander -> App _ fn [dict]) [x]) | isDict ringInt dict && isDict fnNegate fn = Binary ss BitwiseOr (Unary ss Negate x) (NumericLiteral ss (Left 0)) - convert (App ss (App _ (App _ fn [dict]) [x]) [y]) + convert (App ss (App _ (expander -> App _ fn [dict]) [x]) [y]) | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add x y | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply x y | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract x y @@ -110,8 +111,8 @@ inlineCommonValues = everywhere convert fnNegate = (C.DataRing, C.negate) intOp ss op x y = Binary ss BitwiseOr (Binary ss op x y) (NumericLiteral ss (Left 0)) -inlineCommonOperators :: AST -> AST -inlineCommonOperators = everywhereTopDown $ applyAll $ +inlineCommonOperators :: (AST -> AST) -> AST -> AST +inlineCommonOperators expander = everywhereTopDown $ applyAll $ [ binary semiringNumber opAdd Add , binary semiringNumber opMul Multiply @@ -175,7 +176,7 @@ inlineCommonOperators = everywhereTopDown $ applyAll $ binary :: (ModuleName, PSString) -> (ModuleName, PSString) -> BinaryOperator -> AST -> AST binary dict fns op = convert where convert :: AST -> AST - convert (App ss (App _ (App _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = Binary ss op x y + convert (App ss (App _ (expander -> App _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = Binary ss op x y convert other = other binary' :: ModuleName -> PSString -> BinaryOperator -> AST -> AST binary' moduleName opString op = convert where @@ -185,7 +186,7 @@ inlineCommonOperators = everywhereTopDown $ applyAll $ unary :: (ModuleName, PSString) -> (ModuleName, PSString) -> UnaryOperator -> AST -> AST unary dicts fns op = convert where convert :: AST -> AST - convert (App ss (App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op x + convert (App ss (expander -> App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op x convert other = other unary' :: ModuleName -> PSString -> UnaryOperator -> AST -> AST unary' moduleName fnName op = convert where @@ -255,20 +256,21 @@ inlineCommonOperators = everywhereTopDown $ applyAll $ -- (f <<< g $ x) = f (g x) -- (f <<< g) = \x -> f (g x) -inlineFnComposition :: forall m. MonadSupply m => AST -> m AST -inlineFnComposition = everywhereTopDownM convert where +inlineFnComposition :: forall m. MonadSupply m => (AST -> AST) -> AST -> m AST +inlineFnComposition expander = everywhereTopDownM convert + where convert :: AST -> m AST - convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z]) + convert (App s1 (App s2 (App _ (expander -> App _ fn [dict']) [x]) [y]) [z]) | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]] | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]] - convert app@(App ss (App _ (App _ fn [dict']) _) _) + convert app@(App ss (App _ (expander -> App _ fn [dict']) _) _) | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName convert other = return other mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST mkApps ss fns a = App ss (Function ss Nothing [] (Block ss $ vars <> [Return Nothing comp])) [] where - vars = uncurry (VariableIntroduction ss) . fmap Just <$> rights fns + vars = uncurry (VariableIntroduction ss) . fmap (Just . (UnknownEffects, )) <$> rights fns comp = Function ss Nothing [a] (Block ss [Return Nothing apps]) apps = foldr (\fn acc -> App ss (mkApp fn) [acc]) (Var ss a) fns @@ -276,7 +278,7 @@ inlineFnComposition = everywhereTopDownM convert where mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name goApps :: AST -> m [Either AST (Text, AST)] - goApps (App _ (App _ (App _ fn [dict']) [x]) [y]) + goApps (App _ (App _ (expander -> App _ fn [dict']) [x]) [y]) | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x goApps app@App {} = pure . Right . (,app) <$> freshName @@ -294,6 +296,16 @@ inlineFnComposition = everywhereTopDownM convert where fnComposeFlipped :: forall a. IsString a => (ModuleName, a) fnComposeFlipped = (C.ControlSemigroupoid, C.composeFlipped) +inlineFnIdentity :: (AST -> AST) -> AST -> AST +inlineFnIdentity expander = everywhereTopDown convert + where + convert :: AST -> AST + convert (App _ (expander -> App _ fn [dict]) [x]) | isDict categoryFn dict && isDict fnIdentity fn = x + convert other = other + + fnIdentity :: forall a. IsString a => (ModuleName, a) + fnIdentity = (C.ControlCategory, C.identity) + inlineUnsafeCoerce :: AST -> AST inlineUnsafeCoerce = everywhereTopDown convert where convert (App _ (ModuleAccessor _ C.UnsafeCoerce unsafeCoerceFn) [ comp ]) @@ -367,6 +379,9 @@ heytingAlgebraBoolean = (C.DataHeytingAlgebra, C.heytingAlgebraBoolean) semigroupoidFn :: forall a. IsString a => (ModuleName, a) semigroupoidFn = (C.ControlSemigroupoid, C.semigroupoidFn) +categoryFn :: forall a. IsString a => (ModuleName, a) +categoryFn = (C.ControlCategory, C.categoryFn) + opAdd :: forall a. IsString a => (ModuleName, a) opAdd = (C.DataSemiring, C.add) diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs index 7b6a1f6f34..cdcf0138b0 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs @@ -27,17 +27,17 @@ import qualified Language.PureScript.Constants.Prelude as C -- var x = m1(); -- ... -- } -magicDoEff :: AST -> AST +magicDoEff :: (AST -> AST) -> AST -> AST magicDoEff = magicDo C.Eff C.effDictionaries -magicDoEffect :: AST -> AST +magicDoEffect :: (AST -> AST) -> AST -> AST magicDoEffect = magicDo C.Effect C.effectDictionaries -magicDoST :: AST -> AST +magicDoST :: (AST -> AST) -> AST -> AST magicDoST = magicDo C.ST C.stDictionaries -magicDo :: ModuleName -> C.EffectDictionaries -> AST -> AST -magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert +magicDo :: ModuleName -> C.EffectDictionaries -> (AST -> AST) -> AST -> AST +magicDo effectModule C.EffectDictionaries{..} expander = everywhereTopDown convert where -- The name of the function block which is added to denote a do block fnName = "__do" @@ -54,7 +54,7 @@ magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert Function s1 (Just fnName) [] $ Block s2 (App s2 m [] : map applyReturns js ) -- Desugar bind convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 js)]) | isBind bind = - Function s1 (Just fnName) [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns js) + Function s1 (Just fnName) [] $ Block s2 (VariableIntroduction s2 arg (Just (UnknownEffects, App s2 m [])) : map applyReturns js) -- Desugar untilE convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f = App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) [] @@ -68,16 +68,16 @@ magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) [] convert other = other -- Check if an expression represents a monomorphic call to >>= for the Eff monad - isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True + isBind (expander -> App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True isBind _ = False -- Check if an expression represents a call to @discard@ - isDiscard (App _ (App _ fn [dict1]) [dict2]) + isDiscard (expander -> App _ (expander -> App _ fn [dict1]) [dict2]) | isDict (C.ControlBind, C.discardUnitDictionary) dict1 && isDict (effectModule, edBindDict) dict2 && isDiscardPoly fn = True isDiscard _ = False -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative - isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True + isPure (expander -> App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True isPure _ = False -- Check if an expression represents the polymorphic >>= function isBindPoly = isDict (C.ControlBind, C.bind) @@ -130,7 +130,7 @@ inlineST = everywhere convertBlock -- Find all ST Refs initialized in this block findSTRefsIn = everything (++) isSTRef where - isSTRef (VariableIntroduction _ ident (Just (App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident] + isSTRef (VariableIntroduction _ ident (Just (_, App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident] isSTRef _ = [] -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef findAllSTUsagesIn = everything (++) isSTUsage diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index 1189d18c99..c109afd333 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -33,9 +33,9 @@ tco = flip evalState 0 . everywhereTopDownM convert where tcoResult = "$tco_result" convert :: AST -> State Int AST - convert (VariableIntroduction ss name (Just fn@Function {})) + convert (VariableIntroduction ss name (Just (p, fn@Function {}))) | Just trFns <- findTailRecursiveFns name arity body' - = VariableIntroduction ss name . Just . replace <$> toLoop trFns name arity outerArgs innerArgs body' + = VariableIntroduction ss name . Just . (p,) . replace <$> toLoop trFns name arity outerArgs innerArgs body' where innerArgs = headDef [] argss outerArgs = concat . reverse $ tailSafe argss @@ -113,7 +113,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where = pure S.empty allInTailPosition (VariableIntroduction _ _ Nothing) = pure S.empty - allInTailPosition (VariableIntroduction _ ident' (Just js1)) + allInTailPosition (VariableIntroduction _ ident' (Just (_, js1))) | countSelfReferences js1 == 0 = pure S.empty | Function _ Nothing _ _ <- js1 , (argss, body, _) <- innerCollectAllFunctionArgs [] id js1 @@ -155,14 +155,14 @@ tco = flip evalState 0 . everywhereTopDownM convert where loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body) loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el) loopify (Block ss body) = Block ss (map loopify body) - loopify (VariableIntroduction ss f (Just fn@(Function _ Nothing _ _))) + loopify (VariableIntroduction ss f (Just (p, fn@(Function _ Nothing _ _)))) | (_, body, replace) <- innerCollectAllFunctionArgs [] id fn - , f `S.member` trFns = VariableIntroduction ss f (Just (replace (loopify body))) + , f `S.member` trFns = VariableIntroduction ss f (Just (p, replace (loopify body))) loopify other = other pure $ Block rootSS $ - map (\arg -> VariableIntroduction rootSS (tcoVar arg) (Just (Var rootSS (copyVar arg)))) outerArgs ++ - [ VariableIntroduction rootSS tcoDone (Just (BooleanLiteral rootSS False)) + map (\arg -> VariableIntroduction rootSS (tcoVar arg) (Just (UnknownEffects, Var rootSS (copyVar arg)))) outerArgs ++ + [ VariableIntroduction rootSS tcoDone (Just (UnknownEffects, BooleanLiteral rootSS False)) , VariableIntroduction rootSS tcoResult Nothing , Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]) , While rootSS (Unary rootSS Not (Var rootSS tcoDone)) diff --git a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs index 54ef0fc832..ef5599ca45 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs @@ -2,10 +2,16 @@ module Language.PureScript.CoreImp.Optimizer.Unused ( removeCodeAfterReturnStatements , removeUndefinedApp + , removeUnusedEffectFreeVars ) where import Prelude.Compat +import Control.Monad (filterM) +import Data.Monoid (Any(..)) +import qualified Data.Set as S +import Data.Text (Text) + import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Common import qualified Language.PureScript.Constants.Prim as C @@ -25,3 +31,22 @@ removeUndefinedApp = everywhere convert where convert (App ss fn [Var _ arg]) | arg == C.undefined = App ss fn [] convert js = js + +removeUnusedEffectFreeVars :: [Text] -> [[AST]] -> [[AST]] +removeUnusedEffectFreeVars exps = loop + where + expsSet = S.fromList exps + + loop :: [[AST]] -> [[AST]] + loop asts = if changed then loop (filter (not . null) asts') else asts + where + used = expsSet <> foldMap (foldMap (everything (<>) (\case Var _ x -> S.singleton x; _ -> S.empty))) asts + (Any changed, asts') = traverse (filterM (anyFalses . isInUsedSet used)) asts + + isInUsedSet :: S.Set Text -> AST -> Bool + isInUsedSet used = \case + VariableIntroduction _ var (Just (NoEffects, _)) -> var `S.member` used + _ -> True + + anyFalses :: Bool -> (Any, Bool) + anyFalses x = (Any (not x), x) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 3e68387e2c..3b5d7912ae 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -111,7 +111,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded let mod' = Module ss coms moduleName regrouped exps corefn = CF.moduleToCoreFn env' mod' - optimized = CF.optimizeCoreFn corefn + (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn (renamedIdents, renamed) = renameInModule optimized exts = moduleToExternsFile mod' env' renamedIdents ffiCodegen renamed @@ -129,7 +129,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs Right d -> d - evalSupplyT nextVar' $ codegen renamed docs exts + evalSupplyT nextVar'' $ codegen renamed docs exts return exts -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file. diff --git a/tests/purs/optimize/4179.out.js b/tests/purs/optimize/4179.out.js index 5129e291f4..992b422a1f 100644 --- a/tests/purs/optimize/4179.out.js +++ b/tests/purs/optimize/4179.out.js @@ -52,8 +52,8 @@ var alpha = function (v) { }; if (v === 2) { return function (y) { - var $7 = y > 0; - if ($7) { + var $13 = y > 0; + if ($13) { return bravo(y); }; return charlie(y); @@ -81,8 +81,8 @@ var $lazy_delta = /* #__PURE__ */ $runtime_lazy("delta", "Main", function () { })({}); return function (x) { return function (y) { - var $8 = x === y; - if ($8) { + var $14 = x === y; + if ($14) { return b(0); }; return 1.0; diff --git a/tests/purs/optimize/Monad.out.js b/tests/purs/optimize/Monad.out.js new file mode 100644 index 0000000000..1a823571af --- /dev/null +++ b/tests/purs/optimize/Monad.out.js @@ -0,0 +1,30 @@ +import * as Control_Applicative from "../Control.Applicative/index.js"; +import * as Control_Bind from "../Control.Bind/index.js"; +var liftM1 = function (dictMonad) { + var bind = Control_Bind.bind(dictMonad.Bind1()); + var pure = Control_Applicative.pure(dictMonad.Applicative0()); + return function (f) { + return function (a) { + return bind(a)(function (a$prime) { + return pure(f(a$prime)); + }); + }; + }; +}; +var ap = function (dictMonad) { + var bind = Control_Bind.bind(dictMonad.Bind1()); + var pure = Control_Applicative.pure(dictMonad.Applicative0()); + return function (f) { + return function (a) { + return bind(f)(function (f$prime) { + return bind(a)(function (a$prime) { + return pure(f$prime(a$prime)); + }); + }); + }; + }; +}; +export { + liftM1, + ap +}; diff --git a/tests/purs/optimize/Monad.purs b/tests/purs/optimize/Monad.purs new file mode 100644 index 0000000000..931572be84 --- /dev/null +++ b/tests/purs/optimize/Monad.purs @@ -0,0 +1,17 @@ +module Main where + +import Control.Applicative (class Applicative, pure) +import Control.Bind (class Bind, bind) + +class (Applicative m, Bind m) <= Monad m + +liftM1 :: forall m a b. Monad m => (a -> b) -> m a -> m b +liftM1 f a = do + a' <- a + pure (f a') + +ap :: forall m a b. Monad m => m (a -> b) -> m a -> m b +ap f a = do + f' <- f + a' <- a + pure (f' a') diff --git a/tests/purs/optimize/Primitives.out.js b/tests/purs/optimize/Primitives.out.js new file mode 100644 index 0000000000..20907cc483 --- /dev/null +++ b/tests/purs/optimize/Primitives.out.js @@ -0,0 +1,10 @@ +// This test checks that no unused Semiring abstractions are introduced when +// the operators are compiled to JS primitives. +var f = function (x) { + return function (y) { + return x * (y + 1 | 0) | 0; + }; +}; +export { + f +}; diff --git a/tests/purs/optimize/Primitives.purs b/tests/purs/optimize/Primitives.purs new file mode 100644 index 0000000000..7a7df2ffa7 --- /dev/null +++ b/tests/purs/optimize/Primitives.purs @@ -0,0 +1,9 @@ +-- This test checks that no unused Semiring abstractions are introduced when +-- the operators are compiled to JS primitives. + +module Main where + +import Prelude + +f :: Int -> Int -> Int +f x y = x * (y + 1) diff --git a/tests/purs/optimize/RecursiveInstances.out.js b/tests/purs/optimize/RecursiveInstances.out.js new file mode 100644 index 0000000000..bac3268850 --- /dev/null +++ b/tests/purs/optimize/RecursiveInstances.out.js @@ -0,0 +1,107 @@ +import * as Data_Semigroup from "../Data.Semigroup/index.js"; +import * as Data_Symbol from "../Data.Symbol/index.js"; +import * as Type_Proxy from "../Type.Proxy/index.js"; +var append = /* #__PURE__ */ Data_Semigroup.append(Data_Semigroup.semigroupArray); +var findKeysAuxNil = { + findKeysAux: function (v) { + return [ ]; + } +}; +var findKeysAux = function (dict) { + return dict.findKeysAux; +}; +var findKeysAuxCons = function (dictIsSymbol) { + var reflectSymbol = Data_Symbol.reflectSymbol(dictIsSymbol); + return function (dictFindKeysAux) { + var findKeysAux1 = findKeysAux(dictFindKeysAux); + return { + findKeysAux: function (v) { + return append([ reflectSymbol(Type_Proxy["Proxy"].value) ])(findKeysAux1(Type_Proxy["Proxy"].value)); + } + }; + }; +}; +var findKeysAuxCons1 = /* #__PURE__ */ findKeysAuxCons({ + reflectSymbol: function () { + return "a"; + } +}); +var findKeysAuxCons2 = /* #__PURE__ */ findKeysAuxCons({ + reflectSymbol: function () { + return "b"; + } +}); +var findKeysAuxCons3 = /* #__PURE__ */ findKeysAuxCons({ + reflectSymbol: function () { + return "c"; + } +}); +var findKeysAuxCons4 = /* #__PURE__ */ findKeysAuxCons({ + reflectSymbol: function () { + return "d"; + } +}); +var findKeys = function () { + return function (dictFindKeysAux) { + var findKeysAux1 = findKeysAux(dictFindKeysAux); + return function (v) { + return findKeysAux1(Type_Proxy["Proxy"].value); + }; + }; +}; +var findKeys11 = /* #__PURE__ */ findKeys(); +var findKeys12 = /* #__PURE__ */ findKeys11(/* #__PURE__ */ findKeysAuxCons1(findKeysAuxNil)); +var findKeys13 = /* #__PURE__ */ findKeys11(/* #__PURE__ */ findKeysAuxCons1(/* #__PURE__ */ findKeysAuxCons2(/* #__PURE__ */ findKeysAuxCons3(/* #__PURE__ */ findKeysAuxCons4(/* #__PURE__ */ findKeysAuxCons({ + reflectSymbol: function () { + return "e"; + } +})(findKeysAuxNil)))))); +var findKeys14 = /* #__PURE__ */ findKeys11(/* #__PURE__ */ findKeysAuxCons1(/* #__PURE__ */ findKeysAuxCons2(findKeysAuxNil))); +var findKeys15 = /* #__PURE__ */ findKeys11(/* #__PURE__ */ findKeysAuxCons1(/* #__PURE__ */ findKeysAuxCons2(/* #__PURE__ */ findKeysAuxCons3(findKeysAuxNil)))); +var findKeys16 = /* #__PURE__ */ findKeys11(/* #__PURE__ */ findKeysAuxCons1(/* #__PURE__ */ findKeysAuxCons2(/* #__PURE__ */ findKeysAuxCons3(/* #__PURE__ */ findKeysAuxCons4(findKeysAuxNil))))); +var findKeys1 = /* #__PURE__ */ (function () { + return findKeys12(Type_Proxy["Proxy"].value); +})(); +var findKeys10 = /* #__PURE__ */ (function () { + return findKeys13(Type_Proxy["Proxy"].value); +})(); +var findKeys2 = /* #__PURE__ */ (function () { + return findKeys14(Type_Proxy["Proxy"].value); +})(); +var findKeys3 = /* #__PURE__ */ (function () { + return findKeys15(Type_Proxy["Proxy"].value); +})(); +var findKeys4 = /* #__PURE__ */ (function () { + return findKeys16(Type_Proxy["Proxy"].value); +})(); +var findKeys5 = /* #__PURE__ */ (function () { + return findKeys13(Type_Proxy["Proxy"].value); +})(); +var findKeys6 = /* #__PURE__ */ (function () { + return findKeys12(Type_Proxy["Proxy"].value); +})(); +var findKeys7 = /* #__PURE__ */ (function () { + return findKeys14(Type_Proxy["Proxy"].value); +})(); +var findKeys8 = /* #__PURE__ */ (function () { + return findKeys15(Type_Proxy["Proxy"].value); +})(); +var findKeys9 = /* #__PURE__ */ (function () { + return findKeys16(Type_Proxy["Proxy"].value); +})(); +export { + findKeysAux, + findKeys, + findKeys1, + findKeys2, + findKeys3, + findKeys4, + findKeys5, + findKeys6, + findKeys7, + findKeys8, + findKeys9, + findKeys10, + findKeysAuxNil, + findKeysAuxCons +}; diff --git a/tests/purs/optimize/RecursiveInstances.purs b/tests/purs/optimize/RecursiveInstances.purs new file mode 100644 index 0000000000..0719609037 --- /dev/null +++ b/tests/purs/optimize/RecursiveInstances.purs @@ -0,0 +1,31 @@ +module Main where + +import Prelude + +import Prim.Row as R +import Prim.RowList as RL +import Type.Prelude (class IsSymbol, Proxy(..), reflectSymbol) + +class FindKeysAux :: forall k. RL.RowList k -> Constraint +class FindKeysAux a where + findKeysAux :: Proxy a -> Array String + +instance FindKeysAux RL.Nil where + findKeysAux _ = [] + +else instance (IsSymbol l, FindKeysAux r) => FindKeysAux (RL.Cons l t r) where + findKeysAux _ = [ reflectSymbol (Proxy :: Proxy l) ] <> findKeysAux (Proxy :: Proxy r) + +findKeys :: forall r rl. RL.RowToList r rl => FindKeysAux rl => Proxy r -> Array String +findKeys _ = findKeysAux (Proxy :: Proxy rl) + +findKeys1 = findKeys (Proxy :: Proxy (a :: Unit)) +findKeys2 = findKeys (Proxy :: Proxy (a :: Unit, b :: Unit)) +findKeys3 = findKeys (Proxy :: Proxy (a :: Unit, b :: Unit, c :: Unit)) +findKeys4 = findKeys (Proxy :: Proxy (a :: Unit, b :: Unit, c :: Unit, d :: Unit)) +findKeys5 = findKeys (Proxy :: Proxy (a :: Unit, b :: Unit, c :: Unit, d :: Unit, e :: Unit)) +findKeys6 = findKeys (Proxy :: Proxy (a :: Unit)) +findKeys7 = findKeys (Proxy :: Proxy (a :: Unit, b :: Unit)) +findKeys8 = findKeys (Proxy :: Proxy (a :: Unit, b :: Unit, c :: Unit)) +findKeys9 = findKeys (Proxy :: Proxy (a :: Unit, b :: Unit, c :: Unit, d :: Unit)) +findKeys10 = findKeys (Proxy :: Proxy (a :: Unit, b :: Unit, c :: Unit, d :: Unit, e :: Unit)) diff --git a/tests/purs/optimize/Symbols.out.js b/tests/purs/optimize/Symbols.out.js new file mode 100644 index 0000000000..8025617462 --- /dev/null +++ b/tests/purs/optimize/Symbols.out.js @@ -0,0 +1,68 @@ +import * as Data_Symbol from "../Data.Symbol/index.js"; +import * as Record_Unsafe from "../Record.Unsafe/index.js"; +import * as Type_Proxy from "../Type.Proxy/index.js"; +var fooIsSymbol = { + reflectSymbol: function () { + return "foo"; + } +}; +var set = function (dictIsSymbol) { + var reflectSymbol = Data_Symbol.reflectSymbol(dictIsSymbol); + return function () { + return function (l) { + return function (a) { + return function (r) { + return Record_Unsafe.unsafeSet(reflectSymbol(l))(a)(r); + }; + }; + }; + }; +}; +var set1 = /* #__PURE__ */ set(fooIsSymbol)(); +var get = function (dictIsSymbol) { + var reflectSymbol = Data_Symbol.reflectSymbol(dictIsSymbol); + return function () { + return function (l) { + return function (r) { + return Record_Unsafe.unsafeGet(reflectSymbol(l))(r); + }; + }; + }; +}; +var get1 = /* #__PURE__ */ get(fooIsSymbol)(); +var get2 = /* #__PURE__ */ get({ + reflectSymbol: function () { + return "bar"; + } +})(); +var foo = /* #__PURE__ */ (function () { + return Type_Proxy["Proxy"].value; +})(); +var h = function (n) { + return set1(foo)(n)({ + foo: 0 + }); +}; +var f = function (n) { + return get1(foo)({ + foo: n + }); +}; +var bar = /* #__PURE__ */ (function () { + return Type_Proxy["Proxy"].value; +})(); +var g = function (n) { + return get2(bar)({ + foo: 0, + bar: n + }); +}; +export { + get, + set, + foo, + bar, + f, + g, + h +}; diff --git a/tests/purs/optimize/Symbols.purs b/tests/purs/optimize/Symbols.purs new file mode 100644 index 0000000000..578d225a02 --- /dev/null +++ b/tests/purs/optimize/Symbols.purs @@ -0,0 +1,40 @@ +module Main where + +import Data.Symbol (class IsSymbol, reflectSymbol) +import Prim.Row (class Cons) +import Record.Unsafe (unsafeGet, unsafeSet) +import Type.Proxy (Proxy(..)) + +get + :: forall r r' l a + . IsSymbol l + => Cons l a r' r + => Proxy l + -> Record r + -> a +get l r = unsafeGet (reflectSymbol l) r + +set + :: forall r r' l a + . IsSymbol l + => Cons l a r' r + => Proxy l + -> a + -> Record r + -> Record r +set l a r = unsafeSet (reflectSymbol l) a r + +foo :: Proxy "foo" +foo = Proxy + +bar :: Proxy "bar" +bar = Proxy + +f :: Int -> Int +f n = get foo { foo: n } + +g :: Int -> Int +g n = get bar { foo: 0, bar: n } + +h :: Int -> { foo :: Int } +h n = set foo n { foo: 0 } diff --git a/tests/purs/passing/CyclicInstances.purs b/tests/purs/passing/CyclicInstances.purs new file mode 100644 index 0000000000..f50358aa7e --- /dev/null +++ b/tests/purs/passing/CyclicInstances.purs @@ -0,0 +1,29 @@ +module Main where + +import Prelude + +import Data.Generic.Rep (class Generic) +import Data.Show.Generic (genericShow) +import Effect.Console (log) + +newtype A = A B +derive newtype instance Show A +data B = B C + | Z +derive instance Generic B _ +instance Show B where show x = genericShow x +newtype C = C A +derive instance Generic C _ +instance Show C where show = genericShow + +newtype A2 = A2 { x :: B2 } +derive newtype instance Show A2 +data B2 = B2 C2 + | Z2 +derive instance Generic B2 _ +instance Show B2 where show x = genericShow x +newtype C2 = C2 A2 +derive instance Generic C2 _ +instance Show C2 where show = genericShow + +main = log "Done" diff --git a/tests/purs/passing/TCOFloated.purs b/tests/purs/passing/TCOFloated.purs new file mode 100644 index 0000000000..9283ec5355 --- /dev/null +++ b/tests/purs/passing/TCOFloated.purs @@ -0,0 +1,11 @@ +module Main where + +import Prelude +import Effect.Console (log) + +main = log (looper { foo: 100000 }) + +-- The Ord instance for { foo :: Int } will be floated to an outer scope. This +-- test verifies that TCO happens anyway. +looper :: { foo :: Int } -> String +looper x = if x <= { foo: 0 } then "Done" else looper { foo: x.foo - 1 } From 8181c4fee34fdfa576ad7029ec2303f71020e1b6 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Fri, 20 May 2022 17:00:30 -0400 Subject: [PATCH 1474/1580] Accommodate internal initial-digit identifiers (#4334) The motivating example is the `xyzIsSymbol` style of variable name that can be created by `CoreFn.CSE`. --- .../internal_accommodate-initial-digit-idents.md | 1 + src/Language/PureScript/CodeGen/JS/Common.hs | 7 +++++-- tests/purs/passing/CSEInitialDigitSymbols.purs | 16 ++++++++++++++++ 3 files changed, 22 insertions(+), 2 deletions(-) create mode 100644 CHANGELOG.d/internal_accommodate-initial-digit-idents.md create mode 100644 tests/purs/passing/CSEInitialDigitSymbols.purs diff --git a/CHANGELOG.d/internal_accommodate-initial-digit-idents.md b/CHANGELOG.d/internal_accommodate-initial-digit-idents.md new file mode 100644 index 0000000000..d5e162db70 --- /dev/null +++ b/CHANGELOG.d/internal_accommodate-initial-digit-idents.md @@ -0,0 +1 @@ +* Accommodate internally-generated identifiers that start with digits diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index b3fd2c46d1..cdb34d3e36 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -19,9 +19,12 @@ moduleNameToJs (ModuleName mn) = -- -- * Alphanumeric characters are kept unmodified. -- --- * Reserved javascript identifiers are prefixed with '$$'. +-- * Reserved javascript identifiers and identifiers starting with digits are +-- prefixed with '$$'. identToJs :: Ident -> Text -identToJs (Ident name) = anyNameToJs name +identToJs (Ident name) + | not (T.null name) && isDigit (T.head name) = "$$" <> T.concatMap identCharToText name + | otherwise = anyNameToJs name identToJs (GenIdent _ _) = internalError "GenIdent in identToJs" identToJs UnusedIdent = unusedIdent identToJs (InternalIdent RuntimeLazyFactory) = "$runtime_lazy" diff --git a/tests/purs/passing/CSEInitialDigitSymbols.purs b/tests/purs/passing/CSEInitialDigitSymbols.purs new file mode 100644 index 0000000000..0a015754bc --- /dev/null +++ b/tests/purs/passing/CSEInitialDigitSymbols.purs @@ -0,0 +1,16 @@ +module Main where + +import Data.Symbol (class IsSymbol, reflectSymbol) +import Effect.Console (log) +import Type.Proxy (Proxy(..)) + +reflectSymbol' :: forall s. IsSymbol s => Proxy s -> String +reflectSymbol' = reflectSymbol + +two = reflectSymbol (Proxy :: _ "2") +two2 = reflectSymbol' (Proxy :: _ "2") + +twoThirty = reflectSymbol (Proxy :: _ "2:30") +twoThirty2 = reflectSymbol' (Proxy :: _ "2:30") + +main = log "Done" From e9d949606a29d4af8bd0a75b5e519c375d481f95 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Sun, 22 May 2022 23:23:47 +0100 Subject: [PATCH 1475/1580] Enable more warnings in purescript.cabal (#4336) * Enable more warnings in purescript.cabal This enables -Wincomplete-uni-patterns and -Wincomplete-record-updates by default. They are both good warnings to have on, as they help identify situations where code is likely to result in an error at runtime. --- .../internal_enable-more-ghc-warnings.md | 3 ++ purescript.cabal | 9 +++++- .../PureScript/CoreImp/Optimizer/Unused.hs | 7 +++-- src/Language/PureScript/Ide/Imports.hs | 15 +++++----- src/Language/PureScript/Sugar/Names/Env.hs | 8 +++-- .../PureScript/Sugar/TypeClasses/Deriving.hs | 3 +- src/Language/PureScript/TypeChecker.hs | 12 +++++--- .../PureScript/TypeChecker/Entailment.hs | 30 ++++++++++++++++--- 8 files changed, 65 insertions(+), 22 deletions(-) create mode 100644 CHANGELOG.d/internal_enable-more-ghc-warnings.md diff --git a/CHANGELOG.d/internal_enable-more-ghc-warnings.md b/CHANGELOG.d/internal_enable-more-ghc-warnings.md new file mode 100644 index 0000000000..3ba9db1519 --- /dev/null +++ b/CHANGELOG.d/internal_enable-more-ghc-warnings.md @@ -0,0 +1,3 @@ +* Update purescript.cabal so that the PureScript compiler is built with the + flags -Wincomplete-uni-patterns and -Wincomplete-record-updates enabled by + default. diff --git a/purescript.cabal b/purescript.cabal index ba60be7446..508b5b20a8 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -51,7 +51,12 @@ flag release default: False common defaults - ghc-options: -Wall + -- Note: -Wall-incomplete-uni-patterns and -Wincomplete-record-updates can be + -- removed once we upgrade to GHC 9.2.1 since they are now included in -Wall. + ghc-options: + -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates default-language: Haskell2010 default-extensions: BangPatterns @@ -403,6 +408,8 @@ test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Main.hs + -- Not a problem for this warning to arise in tests + ghc-options: -Wno-incomplete-uni-patterns build-depends: purescript , generic-random diff --git a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs index ef5599ca45..13c4c9f374 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs @@ -20,8 +20,11 @@ removeCodeAfterReturnStatements :: AST -> AST removeCodeAfterReturnStatements = everywhere (removeFromBlock go) where go :: [AST] -> [AST] - go jss | not (any isReturn jss) = jss - | otherwise = let (body, ret : _) = break isReturn jss in body ++ [ret] + go jss = + case break isReturn jss of + (_, []) -> jss + (body, ret : _ ) -> body ++ [ret] + isReturn (Return _ _) = True isReturn (ReturnNoResult _) = True isReturn _ = False diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index a7a9bd3404..0db7f79fa9 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -33,7 +33,7 @@ module Language.PureScript.Ide.Imports import Protolude hiding (moduleName) import Control.Lens ((^.), (%~), ix, has) -import Data.List (findIndex, nubBy, partition) +import Data.List (nubBy, partition) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Text as T @@ -256,13 +256,14 @@ addExplicitImport' decl moduleName qualifier imports = ideSpan :: P.SourceSpan ideSpan = P.internalModuleSourceSpan "" +-- | If none of the elements of the list satisfy the given predicate 'predicate', then prepend the default value 'def' +-- to the given list. Otherwise, update the first element of the list that satisfies 'predicate' with the updating +-- function 'update'. updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a] -updateAtFirstOrPrepend p t d l = - case findIndex p l of - Nothing -> d : l - Just i -> - let (x, a : y) = splitAt i l - in x ++ [t a] ++ y +updateAtFirstOrPrepend predicate update def xs = + case break predicate xs of + (before, []) -> def : before + (before, x : after) -> before ++ [update x] ++ after -- | Looks up the given identifier in the currently loaded modules. -- diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index d2dfc36365..5abcf8f04d 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -34,6 +34,7 @@ import qualified Data.Set as S import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.AST +import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors import Language.PureScript.Names @@ -488,5 +489,8 @@ checkImportConflicts ss currentModule toName xs = return (mnNew, mnOrig) _ -> throwError . errorMessage' ss $ ScopeConflict name conflictModules else - let ImportRecord (Qualified (Just mnNew) _) mnOrig _ _ = head byOrig - in return (mnNew, mnOrig) + case head byOrig of + ImportRecord (Qualified (Just mnNew) _) mnOrig _ _ -> + return (mnNew, mnOrig) + _ -> + internalError "checkImportConflicts: ImportRecord should be qualified" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 923278005e..aa318fcdd0 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -190,8 +190,7 @@ deriveNewtype tyCon tyConArgs = DataDeclaration (ss', _) Data name _ _ -> throwError . errorMessage' ss' $ CannotDeriveNewtypeForData name DataDeclaration _ Newtype name args dctors -> do - checkNewtype name dctors - let (DataConstructorDeclaration _ _ [(_, ty)]) = head dctors + (_, (_, ty)) <- checkNewtype name dctors let subst = zipWith ((,) . fst) args tyConArgs return ([], replaceAllTypeVars subst ty) _ -> internalError "deriveNewtype: expected DataDeclaration" diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 5d8a9b39be..33c531da84 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -282,7 +282,7 @@ typeCheckAll moduleName = traverse go go :: Declaration -> m Declaration go (DataDeclaration sa@(ss, _) dtype name args dctors) = do warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (positionedError ss)) $ do - when (dtype == Newtype) $ checkNewtype name dctors + when (dtype == Newtype) $ void $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args (dataCtors, ctorKind) <- kindOfData moduleName (sa, name, args, dctors) let args' = args `withKinds` ctorKind @@ -312,7 +312,7 @@ typeCheckAll moduleName = traverse go forM dataDeclsWithKinds $ \(_, name, args, dataCtors, _) -> (name, args,) <$> traverse (replaceTypeSynonymsInDataConstructor . fst) dataCtors for_ dataDeclsWithKinds $ \(dtype, name, args', dataCtors, ctorKind) -> do - when (dtype == Newtype) $ checkNewtype name (map fst dataCtors) + when (dtype == Newtype) $ void $ checkNewtype name (map fst dataCtors) checkDuplicateTypeArguments $ map fst args' let args'' = args' `withRoles` inferRoles' name args' addDataType moduleName dtype name args'' dataCtors ctorKind @@ -584,13 +584,17 @@ typeCheckAll moduleName = traverse go , .. } +-- | Check that a newtype has just one data constructor with just one field, or +-- throw an error. If the newtype is valid, this function returns the single +-- data constructor declaration and the single field, as a 'proof' that the +-- newtype was indeed a valid newtype. checkNewtype :: forall m . MonadError MultipleErrors m => ProperName 'TypeName -> [DataConstructorDeclaration] - -> m () -checkNewtype _ [DataConstructorDeclaration _ _ [_]] = return () + -> m (DataConstructorDeclaration, (Ident, SourceType)) +checkNewtype _ [decl@(DataConstructorDeclaration _ _ [field])] = return (decl, field) checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name -- | diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 5b31913389..67de6e7aeb 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -22,13 +22,14 @@ import Data.Either (lefts, partitionEithers) import Data.Foldable (for_, fold, toList) import Data.Function (on) import Data.Functor (($>)) -import Data.List (delete, findIndices, groupBy, minimumBy, nubBy, sortOn, tails) +import Data.List (delete, findIndices, minimumBy, nubBy, sortOn, tails) import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S import Data.Traversable (for) import Data.Text (Text, stripPrefix, stripSuffix) import qualified Data.Text as T +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import Language.PureScript.AST @@ -91,7 +92,7 @@ type TypeClassDict = TypeClassDictionaryInScope Evidence -- | The 'InstanceContext' tracks those constraints which can be satisfied. type InstanceContext = M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) - (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) + (M.Map (Qualified Ident) (NonEmpty NamedDict))) -- | A type substitution which makes an instance head match a list of types. -- @@ -258,11 +259,12 @@ entails SolverOptions{..} constraint context hints = dicts <- lift . lift $ forClassNameM env (combineContexts context inferred) className' kinds'' tys'' let (catMaybes -> ambiguous, instances) = partitionEithers $ do - chain <- groupBy ((==) `on` tcdChain) $ + chain :: NonEmpty TypeClassDict <- + NEL.groupBy ((==) `on` tcdChain) $ sortOn (tcdChain &&& tcdIndex) dicts -- process instances in a chain in index order - let found = for (init $ tails chain) $ \(tcd:tl) -> + let found = for (tails1 chain) $ \(tcd :| tl) -> -- Make sure the type unifies with the type in the type instance definition case matches typeClassDependencies tcd tys'' of Apart -> Right () -- keep searching @@ -863,3 +865,23 @@ pairwiseM :: Applicative m => (a -> a -> m ()) -> [a] -> m () pairwiseM _ [] = pure () pairwiseM _ [_] = pure () pairwiseM p (x : xs) = traverse (p x) xs *> pairwiseM p xs + +-- | Return all nonempty suffixes of a nonempty list. For example: +-- +-- tails1 (fromList [1]) == fromList [fromList [1]] +-- tails1 (fromList [1,2]) == fromList [fromList [1,2], fromList [2]] +-- tails1 (fromList [1,2,3]) == fromList [fromList [1,2,3], fromList [2,3], fromList [3]] +tails1 :: NonEmpty a -> NonEmpty (NonEmpty a) +tails1 = + -- NEL.fromList is an unsafe function, but this usage should be safe, since: + -- + -- * `tails xs = [xs, tail xs, tail (tail xs), ..., []]` + -- + -- * If `xs` is nonempty, it follows that `tails xs` contains at least one nonempty + -- list, since `head (tails xs) = xs`. + -- + -- * The only empty element of `tails xs` is the last one (by the definition of `tails`) + -- + -- * Therefore, if we take all but the last element of `tails xs` i.e. + -- `init (tails xs)`, we have a nonempty list of nonempty lists + NEL.fromList . map NEL.fromList . init . tails . NEL.toList From 3c28f9cd08212216a0f8bd3e2bcb207aa6cfbfab Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Thu, 26 May 2022 18:07:50 -0500 Subject: [PATCH 1476/1580] Setup infrastructure for testing source maps (#4335) --- .gitignore | 3 + ...l_setup-source-maps-test-infrastructure.md | 1 + CONTRIBUTING.md | 4 ++ get-source-maps.sh | 30 ++++++++++ purescript.cabal | 2 + tests/Main.hs | 2 + tests/TestCompiler.hs | 8 +-- tests/TestSourceMaps.hs | 55 +++++++++++++++++++ tests/TestUtils.hs | 50 +++++++++++++---- tests/purs/sourcemaps/Recipe.out.js.map | 1 + tests/purs/sourcemaps/Recipe.purs | 3 + 11 files changed, 143 insertions(+), 16 deletions(-) create mode 100644 CHANGELOG.d/internal_setup-source-maps-test-infrastructure.md create mode 100755 get-source-maps.sh create mode 100644 tests/TestSourceMaps.hs create mode 100644 tests/purs/sourcemaps/Recipe.out.js.map create mode 100644 tests/purs/sourcemaps/Recipe.purs diff --git a/.gitignore b/.gitignore index 5ac1c2d1b9..0454beffcb 100644 --- a/.gitignore +++ b/.gitignore @@ -28,6 +28,9 @@ tests/support/package-lock.json tags TAGS +# Gather source map files from golden tests +.source-maps + # Profiling related *.aux *.hp diff --git a/CHANGELOG.d/internal_setup-source-maps-test-infrastructure.md b/CHANGELOG.d/internal_setup-source-maps-test-infrastructure.md new file mode 100644 index 0000000000..794dcd6630 --- /dev/null +++ b/CHANGELOG.d/internal_setup-source-maps-test-infrastructure.md @@ -0,0 +1 @@ +* Setup infrastructure for testing source maps \ No newline at end of file diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index f896f83d41..45e72f452c 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -43,6 +43,10 @@ This will run whatever test uses the example file `1110.purs`. The golden files (e.g. `*.out` files) are generated automatically when missing, and can be updated by setting the "HSPEC_ACCEPT" environment variable, e.g. by running `HSPEC_ACCEPT=true stack test`. +The source map tests' output can be visualized using the [Source Map Visualization](https://sokra.github.io/source-map-visualization/) website. The site requires uploading three files in the following order: the `.js` file, the `.js.map` file, and the `.purs` file. + +To produce these files, run `stack test --fast --ta "--match sourcemaps" && ./get-source-maps.sh`. Each test's 3 files will be stored in `.source-maps//` folder. The `get-source-maps.sh` script only works if the test files abide by the requirements described in [TestSourceMaps.hs](.tests/TestSourceMaps.hs). + ### Adding Dependencies Because the PureScript compiler is distributed in binary form, we include the licenses of all dependencies, including transitive ones, in the LICENSE file. Therefore, whenever the dependencies change, the LICENSE file should be updated. diff --git a/get-source-maps.sh b/get-source-maps.sh new file mode 100755 index 0000000000..af61df247b --- /dev/null +++ b/get-source-maps.sh @@ -0,0 +1,30 @@ +#!/usr/bin/env bash + +TEST_MODULES_DIR=.test_modules +OUTPUT_DIR=.source-maps + +if [ ! -d "$TEST_MODULES_DIR" ]; then + echo "'$TEST_MODULES_DIR' dir does not exist. You need to run 'stack test --fast --ta \"--match sourcemaps\"' first" + exit 1 +fi + +if [ -d "$OUTPUT_DIR" ]; then + echo "Removing $OUTPUT_DIR" + rm -rf "$OUTPUT_DIR" +fi + +echo "Getting source maps" + +mkdir -p "$OUTPUT_DIR" + +while IFS= read -r -d '' file +do + MODULE="$(basename "$file" .purs)" + echo "Copying files for $MODULE" + mkdir -p "$OUTPUT_DIR/$MODULE" + cp -r \ + "$TEST_MODULES_DIR/SourceMaps.$MODULE/index.js" \ + "$TEST_MODULES_DIR/SourceMaps.$MODULE/index.js.map" \ + "$OUTPUT_DIR/$MODULE/" + cp "$file" "$OUTPUT_DIR/$MODULE/$MODULE.purs" +done < <(find "tests/purs/sourcemaps" -type f -wholename '*.purs' -print0) diff --git a/purescript.cabal b/purescript.cabal index 508b5b20a8..030b85a9cb 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -22,6 +22,7 @@ extra-source-files: bundle/build.sh bundle/README tests/purs/**/*.js + tests/purs/**/*.js.map tests/purs/**/*.purs tests/purs/**/*.json tests/purs/**/*.out @@ -450,5 +451,6 @@ test-suite tests TestPsci.EvalTest TestPsci.TestEnv TestPscPublish + TestSourceMaps TestUtils Paths_purescript diff --git a/tests/Main.hs b/tests/Main.hs index 5d202bae64..3da8f99a35 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -17,6 +17,7 @@ import qualified TestPrimDocs import qualified TestPsci import qualified TestIde import qualified TestPscPublish +import qualified TestSourceMaps -- import qualified TestBundle import qualified TestMake import qualified TestUtils @@ -37,6 +38,7 @@ main = do describe "ide" TestIde.spec beforeAll TestUtils.setupSupportModules $ do describe "compiler" TestCompiler.spec + describe "sourcemaps" TestSourceMaps.spec describe "make" TestMake.spec describe "psci" TestPsci.spec describe "corefn" TestCoreFn.spec diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 8402a08951..dbda973cf2 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -135,7 +135,7 @@ assertCompiles -> Handle -> Expectation assertCompiles support inputFiles outputFile = do - (result, _) <- compile True support inputFiles + (result, _) <- compile (Just IsMain) support inputFiles case result of Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do @@ -157,7 +157,7 @@ assertCompilesWithWarnings -> [String] -> Expectation assertCompilesWithWarnings support inputFiles shouldWarnWith = do - result'@(result, warnings) <- compile False support inputFiles + result'@(result, warnings) <- compile Nothing support inputFiles case result of Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs @@ -173,7 +173,7 @@ assertDoesNotCompile -> [String] -> Expectation assertDoesNotCompile support inputFiles shouldFailWith = do - result <- compile False support inputFiles + result <- compile Nothing support inputFiles case fst result of Left errs -> do when (null shouldFailWith) @@ -193,7 +193,7 @@ assertCompilesToExpectedOutput -> [FilePath] -> Expectation assertCompilesToExpectedOutput support inputFiles = do - (result, _) <- compile False support inputFiles + (result, _) <- compile Nothing support inputFiles case result of Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> diff --git a/tests/TestSourceMaps.hs b/tests/TestSourceMaps.hs new file mode 100644 index 0000000000..e971933f08 --- /dev/null +++ b/tests/TestSourceMaps.hs @@ -0,0 +1,55 @@ +module TestSourceMaps where + +import Prelude + +import Control.Monad (forM_) +import Test.Hspec +import System.FilePath (replaceExtension, takeFileName) +import qualified Language.PureScript as P +import qualified Data.ByteString as BS +import TestUtils (goldenVsString, getTestFiles, SupportModules (..), compile', ExpectedModuleName (IsSourceMap)) +import qualified Data.Set as Set +import TestCompiler (getTestMain) + +spec :: SpecWith SupportModules +spec = + goldenFiles + +-- See the CONTRIBUTING.md file for why the below requirements are needed. +-- Test files and their module names must abide by the following requirements: +-- - Test files must reside in the @tests/purs/sourcemaps/@ directory +-- - Module names must be prefixed with "SourceMaps." with the remainder +-- matching the file name. For example: +-- - File Name: @tests/purs/sourcemaps/Test123.purs@ +-- - Module Name: @SourceMaps.Test123@ +-- - File Name: @tests/purs/sourcemaps/Bug1234.purs@ +-- - Module Name: @SourceMaps.Bug1234@ +goldenFiles :: SpecWith SupportModules +goldenFiles = do + sourceMapsFiles <- runIO $ getTestFiles "sourcemaps" + + describe "golden files" $ + forM_ sourceMapsFiles $ \inputFiles -> + it ("'" <> takeFileName (getTestMain inputFiles) <> "' should compile to expected output") $ \support -> + assertCompilesToExpectedOutput support inputFiles + +assertCompilesToExpectedOutput + :: SupportModules + -> [FilePath] + -> Expectation +assertCompilesToExpectedOutput support inputFiles = do + + let + modulePath = getTestMain inputFiles + + (result, _) <- compile' compilationOptions (Just (IsSourceMap modulePath)) support inputFiles + case result of + Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs + Right compiledModulePath -> + goldenVsString + (replaceExtension modulePath ".out.js.map") + (BS.readFile compiledModulePath) + + where + compilationOptions :: P.Options + compilationOptions = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.JSSourceMap] } diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 3ed0f2a8ca..9ed7401a12 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -20,7 +20,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Char (isSpace) import Data.Function (on) -import Data.List (sort, sortBy, stripPrefix, groupBy) +import Data.List (sort, sortBy, stripPrefix, groupBy, find) import qualified Data.Map as M import Data.Maybe (isJust) import qualified Data.Text as T @@ -181,12 +181,24 @@ getTestFiles testDir = do then maybe fp reverse $ stripPrefix ext $ reverse fp else dir +data ExpectedModuleName + = IsMain + | IsSourceMap FilePath + compile - :: Bool + :: Maybe ExpectedModuleName -> SupportModules -> [FilePath] - -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) -compile checkForMainModule SupportModules{..} inputFiles = runTest $ do + -> IO (Either P.MultipleErrors FilePath, P.MultipleErrors) +compile = compile' P.defaultOptions + +compile' + :: P.Options + -> Maybe ExpectedModuleName + -> SupportModules + -> [FilePath] + -> IO (Either P.MultipleErrors FilePath, P.MultipleErrors) +compile' options expectedModule SupportModules{..} inputFiles = P.runMake options $ do -- Sorting the input files makes some messages (e.g., duplicate module) deterministic fs <- liftIO $ readInput (sort inputFiles) msWithWarnings <- CST.parseFromFiles id fs @@ -195,17 +207,31 @@ compile checkForMainModule SupportModules{..} inputFiles = runTest $ do foreigns <- inferForeignModules ms let actions = makeActions supportModules (foreigns `M.union` supportForeigns) - hasMainModule = (==) 1 $ length $ filter (== "Main") $ fmap getPsModuleName ms + (hasExpectedModuleName, expectedModuleName, compiledModulePath) = case expectedModule of + -- Check if there is one (and only one) module called "Main" + Just IsMain -> + let + moduleName = "Main" + compiledPath = modulesDir moduleName "index.js" + in ((==) 1 $ length $ filter (== moduleName) $ fmap (T.unpack . getPsModuleName) ms, moduleName, compiledPath) + -- Check if main sourcemap module starts with "SourceMaps." and matches its file name + Just (IsSourceMap modulePath) -> + let + moduleName = "SourceMaps." <> (dropExtensions . takeFileName $ modulePath) + compiledPath = modulesDir moduleName "index.js.map" + in (maybe False ((==) moduleName . T.unpack . getPsModuleName) (find ((==) modulePath . fst) ms), moduleName, compiledPath) + Nothing -> (True, mempty, mempty) + case ms of [singleModule] -> do - when (checkForMainModule && not hasMainModule) $ do - error $ "When testing a single PureScript file, the file's module's name must be 'Main' but got '" - <> T.unpack (getPsModuleName singleModule) <> "'." - pure <$> P.rebuildModule actions supportExterns (snd singleModule) + unless hasExpectedModuleName $ + error ("While testing a single PureScript file, the expected module name was '" <> expectedModuleName <> + "' but got '" <> T.unpack (getPsModuleName singleModule) <> "'.") + compiledModulePath <$ P.rebuildModule actions supportExterns (snd singleModule) _ -> do - when (checkForMainModule && not hasMainModule) $ do - error "When testing multiple PureScript files, the main file's module's name must be 'Main'." - P.make actions (CST.pureResult <$> supportModules ++ map snd ms) + unless hasExpectedModuleName $ + error $ "While testing multiple PureScript files, the expected main module was not found: '" <> expectedModuleName <> "'." + compiledModulePath <$ P.make actions (CST.pureResult <$> supportModules ++ map snd ms) getPsModuleName :: (a, AST.Module) -> T.Text getPsModuleName psModule = case snd psModule of diff --git a/tests/purs/sourcemaps/Recipe.out.js.map b/tests/purs/sourcemaps/Recipe.out.js.map new file mode 100644 index 0000000000..500c26441e --- /dev/null +++ b/tests/purs/sourcemaps/Recipe.out.js.map @@ -0,0 +1 @@ +{"mappings":"","sources":[],"names":[],"version":3,"file":"index.js"} \ No newline at end of file diff --git a/tests/purs/sourcemaps/Recipe.purs b/tests/purs/sourcemaps/Recipe.purs new file mode 100644 index 0000000000..c6b6880dd3 --- /dev/null +++ b/tests/purs/sourcemaps/Recipe.purs @@ -0,0 +1,3 @@ +-- | This file demonstrates the naming convention to use for +-- | source map tests +module SourceMaps.Recipe where From 9580971cd0500cc5e956d637238c886fdf0dafb3 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sat, 28 May 2022 18:21:54 -0500 Subject: [PATCH 1477/1580] Stop emitting null source spans (#4343) * Fix null mapping issue (#4034) * Verify that each source map test produces a valid source map file --- ...ix_4034-stop-emitting-null-source-spans.md | 1 + CONTRIBUTORS.md | 1 + purescript.cabal | 2 + src/Language/PureScript/Make/Actions.hs | 10 ++- src/Language/PureScript/Pretty/Common.hs | 4 +- tests/TestSourceMaps.hs | 34 ++++++--- tests/purs/sourcemaps/Bug4034.js | 51 +++++++++++++ tests/purs/sourcemaps/Bug4034.out.js.map | 1 + tests/purs/sourcemaps/Bug4034.purs | 71 +++++++++++++++++++ tests/support/checkSourceMapValidity.js | 33 +++++++++ tests/support/package.json | 3 +- 11 files changed, 196 insertions(+), 15 deletions(-) create mode 100644 CHANGELOG.d/fix_4034-stop-emitting-null-source-spans.md create mode 100644 tests/purs/sourcemaps/Bug4034.js create mode 100644 tests/purs/sourcemaps/Bug4034.out.js.map create mode 100644 tests/purs/sourcemaps/Bug4034.purs create mode 100644 tests/support/checkSourceMapValidity.js diff --git a/CHANGELOG.d/fix_4034-stop-emitting-null-source-spans.md b/CHANGELOG.d/fix_4034-stop-emitting-null-source-spans.md new file mode 100644 index 0000000000..1d7a2112f6 --- /dev/null +++ b/CHANGELOG.d/fix_4034-stop-emitting-null-source-spans.md @@ -0,0 +1 @@ +* Stop emitting source spans with negative line/column numbers \ No newline at end of file diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 43175a9aa6..68aafb4bff 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -156,6 +156,7 @@ If you would prefer to use different terms, please use the section below instead | [@sigma-andex](https://github.com/sigma-andex) | Jan Schulte | [MIT license](http://opensource.org/licenses/MIT) | | [@i-am-the-slime](https://github.com/i-am-the-slime) | Mark Eibes | [MIT license](http://opensource.org/licenses/MIT) | | [@sd-yip](https://github.com/sd-yip) | Nicholas Yip | [MIT license](http://opensource.org/licenses/MIT) | +| [@j-nava](https://github.com/j-nava) | Jesse Nava | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/purescript.cabal b/purescript.cabal index 030b85a9cb..c28d5acc50 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -28,6 +28,7 @@ extra-source-files: tests/purs/**/*.out tests/json-compat/**/*.json tests/support/*.json + tests/support/checkSourceMapValidity.js tests/support/psci/**/*.purs tests/support/psci/**/*.edit tests/support/pscide/src/**/*.purs @@ -181,6 +182,7 @@ common defaults transformers >=0.5.6.2 && <0.6, transformers-base >=0.4.6 && <0.5, transformers-compat >=0.6.6 && <0.7, + typed-process >=0.2.7.0 && <0.3, unordered-containers >=0.2.14.0 && <0.3, utf8-string >=1.0.2 && <1.1, vector >=0.12.3.1 && <0.13 diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 5fed6fa999..ff50ba1d0c 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -54,7 +54,8 @@ import qualified Paths_purescript as Paths import SourceMap import SourceMap.Types import System.Directory (getCurrentDirectory) -import System.FilePath ((), makeRelative, splitPath, normalise) +import System.FilePath ((), makeRelative, splitPath, normalise, splitDirectories) +import qualified System.FilePath.Posix as Posix import System.IO (stderr) -- | Determines when to rebuild a module @@ -299,9 +300,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do - let pathToDir = iterate (".." ) ".." !! length (splitPath $ normalise outputDir) + let pathToDir = iterate (".." Posix.) ".." !! length (splitPath $ normalise outputDir) sourceFile = case mappings of - (SMap file _ _ : _) -> Just $ pathToDir makeRelative dir (T.unpack file) + (SMap file _ _ : _) -> Just $ pathToDir Posix. normalizeSMPath (makeRelative dir (T.unpack file)) _ -> Nothing let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings = map (\(SMap _ orig gen) -> Mapping { @@ -321,6 +322,9 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } = Pos { posLine = fromIntegral l, posColumn = fromIntegral c } + normalizeSMPath :: FilePath -> FilePath + normalizeSMPath = Posix.joinPath . splitDirectories + requiresForeign :: CF.Module a -> Bool requiresForeign = not . null . CF.moduleForeign diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 3a483b0ffe..6a40bd6b39 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -11,7 +11,7 @@ import Data.List (elemIndices, intersperse) import Data.Text (Text) import qualified Data.Text as T -import Language.PureScript.AST (SourcePos(..), SourceSpan(..)) +import Language.PureScript.AST (SourcePos(..), SourceSpan(..), nullSourceSpan) import Language.PureScript.CST.Lexer (isUnquotedKey) import Text.PrettyPrint.Boxes hiding ((<>)) @@ -74,7 +74,7 @@ instance Emit StrPos where -- | -- Add a new mapping entry for given source position with initially zero generated position -- - addMapping SourceSpan { spanName = file, spanStart = startPos } = StrPos (zeroPos, mempty, [mapping]) + addMapping ss@SourceSpan { spanName = file, spanStart = startPos } = StrPos (zeroPos, mempty, [ mapping | ss /= nullSourceSpan ]) where mapping = SMap (T.pack file) startPos zeroPos zeroPos = SourcePos 0 0 diff --git a/tests/TestSourceMaps.hs b/tests/TestSourceMaps.hs index e971933f08..ec2b545e6c 100644 --- a/tests/TestSourceMaps.hs +++ b/tests/TestSourceMaps.hs @@ -2,14 +2,16 @@ module TestSourceMaps where import Prelude -import Control.Monad (forM_) +import Control.Monad (void, forM_) import Test.Hspec -import System.FilePath (replaceExtension, takeFileName) +import System.FilePath (replaceExtension, takeFileName, (), (<.>)) import qualified Language.PureScript as P import qualified Data.ByteString as BS +import Data.Foldable (fold) import TestUtils (goldenVsString, getTestFiles, SupportModules (..), compile', ExpectedModuleName (IsSourceMap)) import qualified Data.Set as Set import TestCompiler (getTestMain) +import System.Process.Typed (proc, readProcess_) spec :: SpecWith SupportModules spec = @@ -29,15 +31,21 @@ goldenFiles = do sourceMapsFiles <- runIO $ getTestFiles "sourcemaps" describe "golden files" $ - forM_ sourceMapsFiles $ \inputFiles -> - it ("'" <> takeFileName (getTestMain inputFiles) <> "' should compile to expected output") $ \support -> - assertCompilesToExpectedOutput support inputFiles + forM_ sourceMapsFiles $ \inputFiles -> do + let + testName = fold + [ "'" + , takeFileName (getTestMain inputFiles) + , "' should compile to expected output and produce a valid source map file" + ] + it testName $ \support -> do + assertCompilesToExpectedValidOutput support inputFiles -assertCompilesToExpectedOutput +assertCompilesToExpectedValidOutput :: SupportModules -> [FilePath] -> Expectation -assertCompilesToExpectedOutput support inputFiles = do +assertCompilesToExpectedValidOutput support inputFiles = do let modulePath = getTestMain inputFiles @@ -45,11 +53,19 @@ assertCompilesToExpectedOutput support inputFiles = do (result, _) <- compile' compilationOptions (Just (IsSourceMap modulePath)) support inputFiles case result of Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs - Right compiledModulePath -> + Right actualSourceMapFile -> do goldenVsString (replaceExtension modulePath ".out.js.map") - (BS.readFile compiledModulePath) + (BS.readFile actualSourceMapFile) + sourceMapIsValid actualSourceMapFile where compilationOptions :: P.Options compilationOptions = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.JSSourceMap] } + +-- | Fails the test if the produced source maps are not valid. +sourceMapIsValid :: FilePath -> Expectation +sourceMapIsValid sourceMapFilePath = do + let + scriptPath = "tests" "support" "checkSourceMapValidity" <.> "js" + void $ readProcess_ (proc "node" [scriptPath, sourceMapFilePath]) diff --git a/tests/purs/sourcemaps/Bug4034.js b/tests/purs/sourcemaps/Bug4034.js new file mode 100644 index 0000000000..b96fed8d19 --- /dev/null +++ b/tests/purs/sourcemaps/Bug4034.js @@ -0,0 +1,51 @@ +export const log = function (s) { + return function () { + console.log(s); + }; +}; + +export const warn = function (s) { + return function () { + console.warn(s); + }; +}; + +export const error = function (s) { + return function () { + console.error(s); + }; +}; + +export const info = function (s) { + return function () { + console.info(s); + }; +}; + +export const debug = function (s) { + return function () { + console.debug(s); + }; +}; + +export const time = function (s) { + return function () { + console.time(s); + }; +}; + +export const timeLog = function (s) { + return function () { + console.timeLog(s); + }; +}; + +export const timeEnd = function (s) { + return function () { + console.timeEnd(s); + }; +}; + +export const clear = function () { + console.clear(); +}; diff --git a/tests/purs/sourcemaps/Bug4034.out.js.map b/tests/purs/sourcemaps/Bug4034.out.js.map new file mode 100644 index 0000000000..04087de7ff --- /dev/null +++ b/tests/purs/sourcemaps/Bug4034.out.js.map @@ -0,0 +1 @@ +{"mappings":";;;;;;;;AA2BA,eAAA;;WAAA;kCACwB;;;;;;AAXxB,cAAA;;WAAA;iCACsB;;;;;;AA6BtB,eAAA;;WAAA;kCACwB;;;;;;AAXxB,gBAAA;;WAAA;mCAC0B;;;;;;AAmB1B,gBAAA;;WAAA;mCAC0B","sources":["../../tests/purs/sourcemaps/Bug4034.purs"],"names":[],"version":3,"file":"index.js"} \ No newline at end of file diff --git a/tests/purs/sourcemaps/Bug4034.purs b/tests/purs/sourcemaps/Bug4034.purs new file mode 100644 index 0000000000..14fbb70be8 --- /dev/null +++ b/tests/purs/sourcemaps/Bug4034.purs @@ -0,0 +1,71 @@ +-- | This module is the same as `purescript-effect@v6.0.0`'s `Effect.Console` file +-- | under a different module name. +-- | This verifies that null source spans are no longer emitted. +module SourceMaps.Bug4034 where + +import Effect (Effect) + +import Data.Show (class Show, show) +import Data.Unit (Unit) + +-- | Write a message to the console. +foreign import log + :: String + -> Effect Unit + +-- | Write a value to the console, using its `Show` instance to produce a +-- | `String`. +logShow :: forall a. Show a => a -> Effect Unit +logShow a = log (show a) + +-- | Write an warning to the console. +foreign import warn + :: String + -> Effect Unit + +-- | Write an warning value to the console, using its `Show` instance to produce +-- | a `String`. +warnShow :: forall a. Show a => a -> Effect Unit +warnShow a = warn (show a) + +-- | Write an error to the console. +foreign import error + :: String + -> Effect Unit + +-- | Write an error value to the console, using its `Show` instance to produce a +-- | `String`. +errorShow :: forall a. Show a => a -> Effect Unit +errorShow a = error (show a) + +-- | Write an info message to the console. +foreign import info + :: String + -> Effect Unit + +-- | Write an info value to the console, using its `Show` instance to produce a +-- | `String`. +infoShow :: forall a. Show a => a -> Effect Unit +infoShow a = info (show a) + +-- | Write an debug message to the console. +foreign import debug + :: String + -> Effect Unit + +-- | Write an debug value to the console, using its `Show` instance to produce a +-- | `String`. +debugShow :: forall a. Show a => a -> Effect Unit +debugShow a = debug (show a) + +-- | Start a named timer. +foreign import time :: String -> Effect Unit + +-- | Print the time since a named timer started in milliseconds. +foreign import timeLog :: String -> Effect Unit + +-- | Stop a named timer and print time since it started in milliseconds. +foreign import timeEnd :: String -> Effect Unit + +-- | Clears the console +foreign import clear :: Effect Unit diff --git a/tests/support/checkSourceMapValidity.js b/tests/support/checkSourceMapValidity.js new file mode 100644 index 0000000000..4272b3115d --- /dev/null +++ b/tests/support/checkSourceMapValidity.js @@ -0,0 +1,33 @@ +// Run as `node checkSourceMapValidity.js path/to/index.js.map` + +const s = require("source-map"); +const fs = require("fs"); +const process = require("process"); + +if (process.argv.length < 3) { + const errMsg = [ + "Script did not receive the source map file path as its only argument", + "Rerun using `node checkSourceMapValidity.js path/to/index.js.map`" + ].join("\n"); + throw new Error(errMsg); +} + +const sourceMapFilePath = process.argv[2]; +console.log(`Checking validity of source map for ${sourceMapFilePath}`); +const content = fs.readFileSync(sourceMapFilePath, {encoding: "utf-8"}); +s.SourceMapConsumer.with( + JSON.parse(content), + null, + (consumer) => { + // We only use the `eachMapping` function to trigger an error + // if a mapping is invalid. + consumer.eachMapping(function () {}); + } + ) + .then(() => console.log(`${sourceMapFilePath} sourcemap is valid`)) + .catch((e) => { + console.error(` ${e.message}`); + // See https://nodejs.org/dist/latest-v16.x/docs/api/process.html#processexitcode + // for why we don't call `process.exit(1)` + process.exitCode = 1; + }); diff --git a/tests/support/package.json b/tests/support/package.json index 0e54c5ed3a..d60097eba8 100644 --- a/tests/support/package.json +++ b/tests/support/package.json @@ -3,6 +3,7 @@ "dependencies": { "bower": "^1.8.8", "glob": "^5.0.14", - "rimraf": "^2.5.2" + "rimraf": "^2.5.2", + "source-map": "^0.7.3" } } From 9534e24d3fb87d6c6b222c8b31d13b57cc5c3e04 Mon Sep 17 00:00:00 2001 From: Harry Garrood Date: Mon, 30 May 2022 00:03:15 +0100 Subject: [PATCH 1478/1580] Remove unused SimpleErrorMessage constructors (#4344) --- ...ternal_remove-unused-error-constructors.md | 1 + src/Language/PureScript/Errors.hs | 61 ------------------- src/Language/PureScript/Ide/Error.hs | 7 --- 3 files changed, 1 insertion(+), 68 deletions(-) create mode 100644 CHANGELOG.d/internal_remove-unused-error-constructors.md diff --git a/CHANGELOG.d/internal_remove-unused-error-constructors.md b/CHANGELOG.d/internal_remove-unused-error-constructors.md new file mode 100644 index 0000000000..b6e1998420 --- /dev/null +++ b/CHANGELOG.d/internal_remove-unused-error-constructors.md @@ -0,0 +1 @@ +* Removed a couple of unused SimpleErrorMessage constructors diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index ec030cc6b0..7fb5a5d15d 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -4,7 +4,6 @@ module Language.PureScript.Errors ) where import Prelude.Compat -import Protolude (ordNub) import Control.Arrow ((&&&)) import Control.Exception (displayException) @@ -46,9 +45,6 @@ import Language.PureScript.Traversals import Language.PureScript.Types import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers import qualified System.Console.ANSI as ANSI -import qualified Text.Parsec as P -import qualified Text.Parsec.Error as PE -import Text.Parsec.Error (Message(..)) import qualified Text.PrettyPrint.Boxes as Box -- | A type of error messages @@ -56,7 +52,6 @@ data SimpleErrorMessage = InternalCompilerError Text Text | ModuleNotFound ModuleName | ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage) - | ErrorParsingModule P.ParseError | ErrorParsingCSTModule CST.ParserError | WarningParsingCSTModule CST.ParserWarning | MissingFFIModule ModuleName @@ -150,7 +145,6 @@ data SimpleErrorMessage | MissingKindDeclaration KindSignatureFor (ProperName 'TypeName) SourceType | OverlappingPattern [[Binder]] Bool | IncompleteExhaustivityCheck - | MisleadingEmptyTypeImport ModuleName (ProperName 'TypeName) | ImportHidingModule ModuleName | UnusedImport ModuleName (Maybe ModuleName) | UnusedExplicitImport ModuleName [Name] (Maybe ModuleName) [DeclarationRef] @@ -234,7 +228,6 @@ errorCode em = case unwrapErrorMessage em of InternalCompilerError{} -> "InternalCompilerError" ModuleNotFound{} -> "ModuleNotFound" ErrorParsingFFIModule{} -> "ErrorParsingFFIModule" - ErrorParsingModule{} -> "ErrorParsingModule" ErrorParsingCSTModule{} -> "ErrorParsingModule" WarningParsingCSTModule{} -> "WarningParsingModule" MissingFFIModule{} -> "MissingFFIModule" @@ -324,7 +317,6 @@ errorCode em = case unwrapErrorMessage em of MissingKindDeclaration{} -> "MissingKindDeclaration" OverlappingPattern{} -> "OverlappingPattern" IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck" - MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport" ImportHidingModule{} -> "ImportHidingModule" UnusedImport{} -> "UnusedImport" UnusedExplicitImport{} -> "UnusedExplicitImport" @@ -674,10 +666,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl , indent . lineS $ path ] ++ map (indent . lineS) (concatMap Bundle.printErrorMessage (maybeToList extra)) - renderSimpleErrorMessage (ErrorParsingModule err) = - paras [ line "Unable to parse module: " - , prettyPrintParseError err - ] renderSimpleErrorMessage (ErrorParsingCSTModule err) = paras [ line "Unable to parse module: " , line $ T.pack $ CST.prettyPrintErrorMessage err @@ -1096,8 +1084,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "Declaration " <> markCode (showIdent nm) <> " was not used, and is not exported." renderSimpleErrorMessage (UnusedTypeVar tv) = line $ "Type variable " <> markCode tv <> " is ambiguous, since it is unused in the polymorphic type which introduces it." - renderSimpleErrorMessage (MisleadingEmptyTypeImport mn name) = - line $ "Importing type " <> markCode (runProperName name <> "(..)") <> " from " <> markCode (runModuleName mn) <> " is misleading as it has no exported data constructors." renderSimpleErrorMessage (ImportHidingModule name) = paras [ line "hiding imports cannot be used to hide modules." , line $ "An attempt was made to hide the import of " <> markCode (runModuleName name) @@ -1820,53 +1806,6 @@ prettyPrintMultipleErrorsWith ppeOptions _ intro (MultipleErrors es) = , Box.moveRight 2 err ] --- | Pretty print a Parsec ParseError as a Box -prettyPrintParseError :: P.ParseError -> Box.Box -prettyPrintParseError = prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . PE.errorMessages - --- | Pretty print 'ParseError' detail messages. --- --- Adapted from 'Text.Parsec.Error.showErrorMessages'. --- See . -prettyPrintParseErrorMessages :: String -> String -> String -> String -> String -> [Message] -> Box.Box -prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs - | null msgs = Box.text msgUnknown - | otherwise = Box.vcat Box.left $ map Box.text $ clean [showSysUnExpect,showUnExpect,showExpect,showMessages] - - where - (sysUnExpect,msgs1) = span (SysUnExpect "" ==) msgs - (unExpect,msgs2) = span (UnExpect "" ==) msgs1 - (expect,messages) = span (Expect "" ==) msgs2 - - showExpect = showMany msgExpecting expect - showUnExpect = showMany msgUnExpected unExpect - showSysUnExpect | not (null unExpect) || - null sysUnExpect = "" - | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput - | otherwise = msgUnExpected ++ " " ++ firstMsg - where - firstMsg = PE.messageString (head sysUnExpect) - - showMessages = showMany "" messages - - -- helpers - showMany pre msgs' = case clean (map PE.messageString msgs') of - [] -> "" - ms | null pre -> commasOr ms - | otherwise -> pre ++ " " ++ commasOr ms - - commasOr [] = "" - commasOr [m] = m - commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms - - commaSep = separate ", " . clean - - separate _ [] = "" - separate _ [m] = m - separate sep (m:ms) = m ++ sep ++ separate sep ms - - clean = ordNub . filter (not . null) - -- | Indent to the right, and pad on top and bottom. indent :: Box.Box -> Box.Box indent = Box.moveUp 1 . Box.moveDown 1 . Box.moveRight 2 diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 60f17b9f55..e31f20700d 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -25,14 +25,12 @@ import qualified Language.PureScript as P import Language.PureScript.Errors.JSON import Language.PureScript.Ide.Types (ModuleIdent, Completion(..)) import Protolude -import qualified Text.Parsec.Error as Parsec data IdeError = GeneralError Text | NotFound Text | ModuleNotFound ModuleIdent | ModuleFileNotFound ModuleIdent - | ParseError Parsec.ParseError Text | RebuildError P.MultipleErrors deriving (Show) @@ -93,11 +91,6 @@ textError (GeneralError msg) = msg textError (NotFound ident) = "Symbol '" <> ident <> "' not found." textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found." textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found" -textError (ParseError parseError msg) = let escape = show - -- escape newlines and other special - -- chars so we can send the error - -- over the socket as a single line - in msg <> ": " <> escape parseError textError (RebuildError err) = show err prettyPrintTypeSingleLine :: P.Type a -> Text From e4c98bb3e1829862ba0c9c0cec5e82c360ce4d9d Mon Sep 17 00:00:00 2001 From: Colin Wahl Date: Mon, 30 May 2022 14:05:25 -0700 Subject: [PATCH 1479/1580] Support shebang lines in modules (#4214) A module can now start with 0 or more shebang lines. These lines are lexed as comments, but this lexer pass only occurs if one uses a variant of `lex`: `lexModule`. --- CHANGELOG.d/feature_support-module-shebang.md | 15 ++++ src/Language/PureScript/CST.hs | 2 +- src/Language/PureScript/CST/Lexer.hs | 78 +++++++++++++++++-- src/Language/PureScript/CST/Parser.y | 2 +- src/Language/PureScript/Ide/Imports.hs | 2 +- tests/TestDocs.hs | 34 ++++++++ tests/purs/docs/src/Shebang1Undocumented.purs | 4 + tests/purs/docs/src/Shebang2Undocumented.purs | 8 ++ tests/purs/docs/src/Shebang3Undocumented.purs | 9 +++ tests/purs/docs/src/Shebang4Undocumented.purs | 10 +++ tests/purs/layout/Shebang.out | 7 ++ tests/purs/layout/Shebang.purs | 6 ++ 12 files changed, 168 insertions(+), 9 deletions(-) create mode 100644 CHANGELOG.d/feature_support-module-shebang.md create mode 100644 tests/purs/docs/src/Shebang1Undocumented.purs create mode 100644 tests/purs/docs/src/Shebang2Undocumented.purs create mode 100644 tests/purs/docs/src/Shebang3Undocumented.purs create mode 100644 tests/purs/docs/src/Shebang4Undocumented.purs create mode 100644 tests/purs/layout/Shebang.out create mode 100644 tests/purs/layout/Shebang.purs diff --git a/CHANGELOG.d/feature_support-module-shebang.md b/CHANGELOG.d/feature_support-module-shebang.md new file mode 100644 index 0000000000..ea918eba9b --- /dev/null +++ b/CHANGELOG.d/feature_support-module-shebang.md @@ -0,0 +1,15 @@ +* Add support for optional shebang lines + + One or more shebang line are only allowed as the first lines of a file + + ```purs + #! a shebang line + #! another shebang line + -- | module doc comment + -- other comment + module MyModule where + + #! Using a shebang here will fail to parse + foo :: String + foo = "" + ``` \ No newline at end of file diff --git a/src/Language/PureScript/CST.hs b/src/Language/PureScript/CST.hs index 4fe672e9a8..eaa6de4daa 100644 --- a/src/Language/PureScript/CST.hs +++ b/src/Language/PureScript/CST.hs @@ -62,7 +62,7 @@ parseFromFiles toFilePath input = $ \(k, a) -> (k, sequence $ parseFromFile (toFilePath k) a) parseModuleFromFile :: FilePath -> Text -> Either (NE.NonEmpty ParserError) (PartialResult AST.Module) -parseModuleFromFile fp content = fmap (convertModule fp) <$> parseModule (lex content) +parseModuleFromFile fp content = fmap (convertModule fp) <$> parseModule (lexModule content) parseFromFile :: FilePath -> Text -> ([ParserWarning], Either (NE.NonEmpty ParserError) AST.Module) parseFromFile fp content = fmap (convertModule fp) <$> parse content diff --git a/src/Language/PureScript/CST/Lexer.hs b/src/Language/PureScript/CST/Lexer.hs index dfc54023ab..5f71e2c5ae 100644 --- a/src/Language/PureScript/CST/Lexer.hs +++ b/src/Language/PureScript/CST/Lexer.hs @@ -1,5 +1,6 @@ module Language.PureScript.CST.Lexer ( lenient + , lexModule , lex , lexTopLevel , lexWithState @@ -37,10 +38,17 @@ lenient = go ann = TokenAnn (SourceRange pos pos) (lexLeading st) [] [Right (SourceToken ann TokEof)] +lexModule :: Text -> [LexResult] +lexModule = lex' shebangThenComments + -- | Lexes according to root layout rules. lex :: Text -> [LexResult] -lex src = do - let (leading, src') = comments src +lex = lex' comments + +lex' :: (Text -> ([Comment LineFeed], Text)) -> Text -> [LexResult] +lex' lexComments src = do + let (leading, src') = lexComments src + lexWithState $ LexState { lexPos = advanceLeading (SourcePos 1 1) leading , lexLeading = leading @@ -143,6 +151,17 @@ restore p (Parser k) = Parser $ \inp kerr ksucc -> tokenAndComments :: Lexer (Token, ([Comment void], [Comment LineFeed])) tokenAndComments = (,) <$> token <*> breakComments +shebangThenComments :: Text -> ([Comment LineFeed], Text) +shebangThenComments src = do + let + (sb, (coms, src')) = comments <$> shebang src + (sb <> coms, src') + +shebang :: Text -> ([Comment LineFeed], Text) +shebang = \src -> k src (\_ _ -> ([], src)) (\inp a -> (a, inp)) + where + Parser k = breakShebang + comments :: Text -> ([Comment LineFeed], Text) comments = \src -> k src (\_ _ -> ([], src)) (\inp (a, b) -> (a <> b, inp)) where @@ -206,10 +225,6 @@ breakComments = k0 [] Just False -> Just <$> lineComment "--" Nothing -> pure Nothing - lineComment acc = do - comm <- nextWhile (\c -> c /= '\r' && c /= '\n') - pure $ Comment (acc <> comm) - blockComment acc = do chs <- nextWhile (/= '-') dashes <- nextWhile (== '-') @@ -219,6 +234,57 @@ breakComments = k0 [] Just '}' -> next $> Comment (acc <> chs <> dashes <> "}") _ -> blockComment (acc <> chs <> dashes) +breakShebang :: ParserM ParserErrorType Text [Comment LineFeed] +breakShebang = shebangComment >>= \case + Just comm -> k0 [comm] + Nothing -> pure [] + where + k0 acc = lineFeedShebang >>= \case + Just (lf, sb) -> do + comm <- lineComment sb + k0 (comm : lf : acc) + Nothing -> + pure $ reverse acc + + lineFeedShebang = Parser $ \inp _ ksucc -> + case unconsLineFeed inp of + Just (lf, inp2) + | Just (sb, inp3) <- unconsShebang inp2 -> + ksucc inp3 $ Just (lf, sb) + _ -> + ksucc inp Nothing + + unconsLineFeed :: Text -> Maybe (Comment LineFeed, Text) + unconsLineFeed inp = + case Text.uncons inp of + Just ('\r', inp2) -> + case Text.uncons inp2 of + Just ('\n', inp3) -> + Just (Line CRLF, inp3) + _ -> + Just (Line CRLF, inp2) + Just ('\n', inp2) -> + Just (Line LF, inp2) + _ -> + Nothing + + unconsShebang :: Text -> Maybe (Text, Text) + unconsShebang = fmap ("#!",) . Text.stripPrefix "#!" + + shebangComment = isShebang >>= traverse lineComment + + isShebang = Parser $ \inp _ ksucc -> + case unconsShebang inp of + Just (sb, inp3) -> + ksucc inp3 $ Just sb + _ -> + ksucc inp Nothing + +lineComment :: forall lf. Text -> ParserM ParserErrorType Text (Comment lf) +lineComment acc = do + comm <- nextWhile (\c -> c /= '\r' && c /= '\n') + pure $ Comment (acc <> comm) + token :: Lexer Token token = peek >>= maybe (pure TokEof) k0 where diff --git a/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y index 0f800c05b2..7785298c0e 100644 --- a/src/Language/PureScript/CST/Parser.y +++ b/src/Language/PureScript/CST/Parser.y @@ -792,7 +792,7 @@ lexer :: (SourceToken -> Parser a) -> Parser a lexer k = munch >>= k parse :: Text -> ([ParserWarning], Either (NE.NonEmpty ParserError) (Module ())) -parse = either (([],) . Left) resFull . parseModule . lex +parse = either (([],) . Left) resFull . parseModule . lexModule data PartialResult a = PartialResult { resPartial :: a diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 0db7f79fa9..95fb37e383 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -93,7 +93,7 @@ data ImportParse = ImportParse parseModuleHeader :: Text -> Either (NE.NonEmpty CST.ParserError) ImportParse parseModuleHeader src = do - CST.PartialResult md _ <- CST.parseModule $ CST.lenient $ CST.lex src + CST.PartialResult md _ <- CST.parseModule $ CST.lenient $ CST.lexModule src let mn = CST.nameValue $ CST.modNamespace md decls = flip fmap (CST.modImports md) $ \decl -> do diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index b941a56d18..046a2784da 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -117,6 +117,8 @@ data DocsAssertion -- | Assert that a given declaration's type parameters have the -- given role annotations | ShouldHaveRoleAnnotation P.ModuleName Text [P.Role] + -- | Assert that a given module has the expected doc comments + | ShouldHaveModuleDocs P.ModuleName (Maybe Text) data TagsAssertion -- | Assert that a particular declaration is tagged @@ -183,6 +185,9 @@ displayAssertion = \case ShouldHaveRoleAnnotation mn decl expected -> showQual mn decl <> " should have the expected role annotations: " <> T.intercalate ", " (fmap P.displayRole expected) + ShouldHaveModuleDocs mn expected -> + "Module doc comments for module `" <> P.runModuleName mn <> "` should be " <> + maybe "empty" (\t -> "'" <> t <> "`") expected displayTagsAssertion :: TagsAssertion -> Text displayTagsAssertion = \case @@ -260,6 +265,9 @@ data DocsAssertionFailure -- fields: module name, declaration title, expected role list, -- actual role list | RoleMismatch P.ModuleName Text [P.Role] [P.Role] + -- | The module's doc comments should be the expected + -- fields: module name, expected docs, actual docs + | WrongModuleDocs P.ModuleName (Maybe Text) (Maybe Text) data TagsAssertionFailure -- | A declaration was not tagged, but should have been @@ -332,6 +340,10 @@ displayAssertionFailure = \case "`" <> displayRoleList actual <> "`" where displayRoleList = T.intercalate ", " . fmap P.displayRole + WrongModuleDocs mn expected actual -> + "Expected module docs for " <> P.runModuleName mn <> "\n" <> + "to be `" <> fromMaybe "" expected <> "`\n" <> + " got `" <> fromMaybe "" actual <> "`" displayTagsAssertionFailure :: TagsAssertionFailure -> Text displayTagsAssertionFailure = \case @@ -536,6 +548,12 @@ runAssertion assertion linksCtx Docs.Module{..} = if expected == actual then Pass else Fail (RoleMismatch mn decl expected actual) + + ShouldHaveModuleDocs mn expected -> + if expected == modComments then + Pass + else + Fail (WrongModuleDocs mn expected modComments) where declarationsFor mn = if mn == modName @@ -903,6 +921,22 @@ testCases = , ShouldMergeDocComments (n "DocCommentsMerge") "KindAndClass" $ Just "kind\n\ndecl\n" ] ) + , ("Shebang1Undocumented", + [ ShouldHaveModuleDocs (n "Shebang1Undocumented") Nothing + ] + ) + , ("Shebang2Undocumented", + [ ShouldHaveModuleDocs (n "Shebang2Undocumented") Nothing + ] + ) + , ("Shebang3Undocumented", + [ ShouldHaveModuleDocs (n "Shebang3Undocumented") $ Just "Normal doc comment\n" + ] + ) + , ("Shebang4Undocumented", + [ ShouldHaveModuleDocs (n "Shebang4Undocumented") $ Just "Normal doc comment\n" + ] + ) ] where diff --git a/tests/purs/docs/src/Shebang1Undocumented.purs b/tests/purs/docs/src/Shebang1Undocumented.purs new file mode 100644 index 0000000000..089c4b8759 --- /dev/null +++ b/tests/purs/docs/src/Shebang1Undocumented.purs @@ -0,0 +1,4 @@ +#! a single shebang comment +module Shebang1Undocumented where + +import Prelude diff --git a/tests/purs/docs/src/Shebang2Undocumented.purs b/tests/purs/docs/src/Shebang2Undocumented.purs new file mode 100644 index 0000000000..db453c9f8b --- /dev/null +++ b/tests/purs/docs/src/Shebang2Undocumented.purs @@ -0,0 +1,8 @@ +#! a +#! multi +#! line +#! shebang +#! comment +module Shebang2Undocumented where + +import Prelude diff --git a/tests/purs/docs/src/Shebang3Undocumented.purs b/tests/purs/docs/src/Shebang3Undocumented.purs new file mode 100644 index 0000000000..3202e7d06e --- /dev/null +++ b/tests/purs/docs/src/Shebang3Undocumented.purs @@ -0,0 +1,9 @@ +#! a +#! multi +#! line +#! shebang +#! comment +-- | Normal doc comment +module Shebang3Undocumented where + +import Prelude diff --git a/tests/purs/docs/src/Shebang4Undocumented.purs b/tests/purs/docs/src/Shebang4Undocumented.purs new file mode 100644 index 0000000000..dc3a6b9fe1 --- /dev/null +++ b/tests/purs/docs/src/Shebang4Undocumented.purs @@ -0,0 +1,10 @@ +#! a +#! multi +#! line +#! shebang +#! comment +-- Normal comment +-- | Normal doc comment +module Shebang4Undocumented where + +import Prelude diff --git a/tests/purs/layout/Shebang.out b/tests/purs/layout/Shebang.out new file mode 100644 index 0000000000..c2c867c2ee --- /dev/null +++ b/tests/purs/layout/Shebang.out @@ -0,0 +1,7 @@ +#! shebang line 1 +#! shebang line 2 + +module Test where{ + +foo = 42} + \ No newline at end of file diff --git a/tests/purs/layout/Shebang.purs b/tests/purs/layout/Shebang.purs new file mode 100644 index 0000000000..63986ee496 --- /dev/null +++ b/tests/purs/layout/Shebang.purs @@ -0,0 +1,6 @@ +#! shebang line 1 +#! shebang line 2 + +module Test where + +foo = 42 From 8d6878780f14c82e5f6453051b09ce7af2b50084 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Sat, 18 Jun 2022 18:57:10 +0800 Subject: [PATCH 1480/1580] Fix inconsistency between `stack test` and `cabal test` (#4354) * Use `aeson` when comparing JSON files in tests * Add version bounds to the test suite's `build-depends` --- CHANGELOG.d/internal_golden_json_tests.md | 4 ++++ CHANGELOG.d/internal_test_suite_version_bounds.md | 1 + purescript.cabal | 12 ++++++------ tests/TestGraph.hs | 6 +++--- tests/TestSourceMaps.hs | 13 +++++++++---- 5 files changed, 23 insertions(+), 13 deletions(-) create mode 100644 CHANGELOG.d/internal_golden_json_tests.md create mode 100644 CHANGELOG.d/internal_test_suite_version_bounds.md diff --git a/CHANGELOG.d/internal_golden_json_tests.md b/CHANGELOG.d/internal_golden_json_tests.md new file mode 100644 index 0000000000..73fa1f23e1 --- /dev/null +++ b/CHANGELOG.d/internal_golden_json_tests.md @@ -0,0 +1,4 @@ +* Compare json files through `aeson` in tests + + This fixes the tests for the graph and source map outputs, as the + ordering is inconsistent between `stack test` and `cabal test`. diff --git a/CHANGELOG.d/internal_test_suite_version_bounds.md b/CHANGELOG.d/internal_test_suite_version_bounds.md new file mode 100644 index 0000000000..01a8a71733 --- /dev/null +++ b/CHANGELOG.d/internal_test_suite_version_bounds.md @@ -0,0 +1 @@ +* Add version bounds to the test suite's `build-depends`. diff --git a/purescript.cabal b/purescript.cabal index c28d5acc50..e44b2ae355 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -415,12 +415,12 @@ test-suite tests ghc-options: -Wno-incomplete-uni-patterns build-depends: purescript - , generic-random - , hspec - , HUnit - , newtype - , QuickCheck - , regex-base + , generic-random >=1.4.0.0 && <1.5 + , hspec ==2.8.3 + , HUnit >=1.6.2.0 && <1.7 + , newtype >=0.2.2.0 && <0.3 + , QuickCheck >=2.14.2 && <2.15 + , regex-base >=0.94.0.1 && <0.95 build-tool-depends: hspec-discover:hspec-discover -any -- we need the compiler's executable available for the ide tests diff --git a/tests/TestGraph.hs b/tests/TestGraph.hs index a4b2ac744c..e9c361a37a 100644 --- a/tests/TestGraph.hs +++ b/tests/TestGraph.hs @@ -24,9 +24,9 @@ spec = do eitherGraph <- fst <$> P.graph modulePaths case eitherGraph of Left err -> error $ "Graph creation failed. Errors: " <> show err - Right res -> - let textRes = Text.decodeUtf8 $ ByteString.toStrict $ Json.encode res - in graphFixture `shouldBe` textRes + Right res -> do + let graphFixture' = Json.decode $ ByteString.fromStrict $ Text.encodeUtf8 graphFixture + graphFixture' `shouldBe` Just res it "should fail when trying to include non-existing modules in the graph" $ do let modulePath = sourcesDir <> "ModuleFailing.purs" diff --git a/tests/TestSourceMaps.hs b/tests/TestSourceMaps.hs index ec2b545e6c..347b0ce28a 100644 --- a/tests/TestSourceMaps.hs +++ b/tests/TestSourceMaps.hs @@ -3,12 +3,14 @@ module TestSourceMaps where import Prelude import Control.Monad (void, forM_) +import Data.Aeson as Json import Test.Hspec import System.FilePath (replaceExtension, takeFileName, (), (<.>)) import qualified Language.PureScript as P import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS import Data.Foldable (fold) -import TestUtils (goldenVsString, getTestFiles, SupportModules (..), compile', ExpectedModuleName (IsSourceMap)) +import TestUtils (getTestFiles, SupportModules (..), compile', ExpectedModuleName (IsSourceMap)) import qualified Data.Set as Set import TestCompiler (getTestMain) import System.Process.Typed (proc, readProcess_) @@ -54,9 +56,12 @@ assertCompilesToExpectedValidOutput support inputFiles = do case result of Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right actualSourceMapFile -> do - goldenVsString - (replaceExtension modulePath ".out.js.map") - (BS.readFile actualSourceMapFile) + let + readAndDecode :: FilePath -> IO (Maybe Json.Value) + readAndDecode = fmap (Json.decode . LBS.fromStrict) . BS.readFile + goldenFile <- readAndDecode $ replaceExtension modulePath ".out.js.map" + actualFile <- readAndDecode actualSourceMapFile + goldenFile `shouldBe` actualFile sourceMapIsValid actualSourceMapFile where From 1887bcf2ebb3f15f8410f1d353e344e42f7d3b9c Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sun, 19 Jun 2022 15:12:40 -0500 Subject: [PATCH 1481/1580] Update codebase to GHC 9.2.3 (#4351) Co-authored-by: Harry Garrood Co-authored-by: Justin Garcia Co-authored-by: PureFunctor --- .github/workflows/ci.yml | 12 +- .hlint.yaml | 1 + CHANGELOG.d/internal_update-to-ghc-9.2.3.md | 1 + app/Version.hs | 7 +- cabal.project | 2 + purescript.cabal | 88 +++---- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/CST/Utils.hs | 5 +- src/Language/PureScript/CoreFn/ToJSON.hs | 219 +++++++++--------- src/Language/PureScript/Docs/Types.hs | 7 +- src/Language/PureScript/Errors/JSON.hs | 2 +- src/Language/PureScript/Graph.hs | 5 +- src/Language/PureScript/Ide/Error.hs | 4 +- src/Language/PureScript/Names.hs | 8 +- .../PureScript/TypeChecker/Entailment.hs | 18 +- stack.yaml | 21 +- tests/TestGraph.hs | 9 +- tests/purs/sourcemaps/Bug4034.out.js.map | 2 +- tests/purs/sourcemaps/Recipe.out.js.map | 2 +- 19 files changed, 213 insertions(+), 202 deletions(-) create mode 100644 CHANGELOG.d/internal_update-to-ghc-9.2.3.md create mode 100644 cabal.project diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index a30d3c7b3c..39f611ac5a 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -15,7 +15,7 @@ defaults: env: CI_PRERELEASE: "${{ github.event_name == 'push' }}" CI_RELEASE: "${{ github.event_name == 'release' }}" - STACK_VERSION: "2.7.3" + STACK_VERSION: "2.7.5" concurrency: # We never want two prereleases building at the same time, since they would @@ -38,7 +38,7 @@ jobs: include: - # If upgrading the Haskell image, also upgrade it in the lint job below os: "ubuntu-latest" - image: "haskell:8.10.7-stretch@sha256:100f8fb7d7d8d64adb5e106fe8136b8d4cbdc03aeb2cbd145a7597d74b69bafb" + image: "ghcr.io/purescript/haskell:9.2.3-stretch@sha256:70fd2b6255deb5daa961e6983591a0e21e9ac1e793923bee54aa2cc62e01f867" - os: "macOS-10.15" - os: "windows-2019" @@ -119,9 +119,9 @@ jobs: if: runner.os == 'Linux' working-directory: "sdist-test" run: | - if [ $(ldd $(stack path --local-doc-root)/../bin/purs | grep 'libtinfo' | wc -l) -ge 1 ]; then + if [ $(ldd $(../ci/fix-home stack path --local-doc-root)/../bin/purs | grep 'libtinfo' | wc -l) -ge 1 ]; then echo "libtinfo detected" - ldd $(stack path --local-doc-root)/../bin/purs | grep 'libtinfo' + ldd $(../ci/fix-home stack path --local-doc-root)/../bin/purs | grep 'libtinfo' exit 1 fi @@ -166,7 +166,7 @@ jobs: lint: runs-on: "ubuntu-latest" - container: "haskell:8.10.7-stretch@sha256:100f8fb7d7d8d64adb5e106fe8136b8d4cbdc03aeb2cbd145a7597d74b69bafb" + container: "ghcr.io/purescript/haskell:9.2.3-stretch@sha256:70fd2b6255deb5daa961e6983591a0e21e9ac1e793923bee54aa2cc62e01f867" steps: - # We need a proper Git repository, but the checkout step will unpack a tarball instead of doing a clone @@ -209,7 +209,7 @@ jobs: # `allow-newer: true` is needed so that weeder-2.2.0 can be # installed with the dependencies present in LTS-18. echo 'allow-newer: true' >> stack-weeder.yaml - ci/fix-home stack --no-terminal --jobs=2 build --copy-compiler-tool --stack-yaml ./stack-weeder.yaml weeder-2.2.0 + ci/fix-home stack --no-terminal --jobs=2 build --copy-compiler-tool --stack-yaml ./stack-weeder.yaml weeder-2.4.0 - run: "ci/fix-home stack --no-terminal --jobs=2 build --fast --ghc-options -fwrite-ide-info" diff --git a/.hlint.yaml b/.hlint.yaml index aeb242ae9b..545de81c6a 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -17,6 +17,7 @@ - ignore: {name: "Functor law"} - ignore: {name: "Avoid lambda using `infix`"} - ignore: {name: "Fuse mapM/map"} +- ignore: {name: "Eta reduce"} # This warning will often make suggestions that are no longer valid due to simplified subsumption # Specify additional command line arguments diff --git a/CHANGELOG.d/internal_update-to-ghc-9.2.3.md b/CHANGELOG.d/internal_update-to-ghc-9.2.3.md new file mode 100644 index 0000000000..ea0d4dc2f1 --- /dev/null +++ b/CHANGELOG.d/internal_update-to-ghc-9.2.3.md @@ -0,0 +1 @@ +* Update GHC to 9.2.3 \ No newline at end of file diff --git a/app/Version.hs b/app/Version.hs index 9c2f3556be..633a0d8053 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -26,7 +26,8 @@ versionString = showVersion Paths.version ++ prerelease ++ extra extra = "" #else extra = " [development build; commit: " ++ $(GitRev.gitHash) ++ dirty ++ "]" - dirty - | $(GitRev.gitDirty) = " DIRTY" - | otherwise = "" + dirty = + if $(GitRev.gitDirty) + then " DIRTY" + else "" #endif diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000000..51c7ecb87d --- /dev/null +++ b/cabal.project @@ -0,0 +1,2 @@ +packages: + purescript.cabal diff --git a/purescript.cabal b/purescript.cabal index e44b2ae355..df0a14e30e 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -124,66 +124,66 @@ common defaults -- modules must be parseable by this library otherwise the compiler -- will reject them. It should therefore always be pinned to a single -- specific version. - aeson >=1.5.6.0 && <1.6, - aeson-better-errors >=0.9.1.0 && <0.10, + aeson >=2.0.3.0 && <2.1, + aeson-better-errors >=0.9.1.1 && <0.10, aeson-pretty >=0.8.9 && <0.9, - ansi-terminal ==0.11.*, + ansi-terminal >=0.11.3 && <0.12, array >=0.5.4.0 && <0.6, - base >=4.14.3.0 && <4.15, - base-compat >=0.11.2 && <0.12, + base >=4.16.2.0 && <4.17, + base-compat >=0.12.1 && <0.13, blaze-html >=0.9.1.2 && <0.10, - bower-json >=1.0.0.1 && <1.1, + bower-json >=1.1.0.0 && <1.2, boxes >=0.1.5 && <0.2, - bytestring >=0.10.12.0 && <0.11, - Cabal >=3.2.1.0 && <3.3, - cborg >=0.2.6.0 && <0.3, - serialise >=0.2.4.0 && <0.3, + bytestring >=0.11.3.1 && <0.12, + Cabal >=3.6.3.0 && <3.7, + cborg >=0.2.7.0 && <0.3, + serialise >=0.2.5.0 && <0.3, cheapskate >=0.1.1.2 && <0.2, - clock >=0.8.2 && <0.9, + clock >=0.8.3 && <0.9, containers >=0.6.5.1 && <0.7, - cryptonite ==0.29.*, + cryptonite ==0.30.*, data-ordlist >=0.4.7.0 && <0.5, - deepseq >=1.4.4.0 && <1.5, - directory >=1.3.6.0 && <1.4, + deepseq >=1.4.6.1 && <1.5, + directory >=1.3.6.2 && <1.4, dlist ==1.0.*, edit-distance >=0.2.2.1 && <0.3, file-embed >=0.0.15.0 && <0.1, - filepath >=1.4.2.1 && <1.5, + filepath >=1.4.2.2 && <1.5, fsnotify >=0.3.0.1 && <0.4, - Glob >=0.10.1 && <0.11, + Glob >=0.10.2 && <0.11, haskeline >=0.8.2 && <0.9, language-javascript ==0.7.0.0, - lens >=4.19.2 && <4.20, + lens >=5.1.1 && <5.2, lifted-async >=0.10.2.2 && <0.11, lifted-base >=0.2.3.12 && <0.3, - memory >=0.15.0 && <0.16, + memory >=0.17.0 && <0.18, monad-control >=1.0.3.1 && <1.1, monad-logger >=0.3.36 && <0.4, monoidal-containers >=0.6.2.0 && <0.7, mtl >=2.2.2 && <2.3, parallel >=3.2.2.0 && <3.3, - parsec >=3.1.14.0 && <3.2, + parsec >=3.1.15.0 && <3.2, pattern-arrows >=0.0.2 && <0.1, process ==1.6.13.1, - protolude >=0.3.0 && <0.4, - regex-tdfa >=1.3.1.1 && <1.4, + protolude >=0.3.1 && <0.4, + regex-tdfa >=1.3.1.2 && <1.4, safe >=0.3.19 && <0.4, scientific >=0.3.7.0 && <0.4, - semigroups >=0.19.2 && <0.20, - semialign >=1.1.0.1 && <1.2, - sourcemap >=0.1.6.1 && <0.2, + semigroups ==0.20.*, + semialign >=1.2.0.1 && <1.3, + sourcemap >=0.1.7 && <0.2, split >=0.2.3.4 && <0.3, - stm >=2.5.0.1 && <2.6, + stm >=2.5.0.2 && <2.6, stringsearch >=0.3.6.6 && <0.4, syb >=0.7.2.1 && <0.8, - text >=1.2.4.1 && <1.3, + text >=1.2.5.0 && <1.3, these >=1.1.1.1 && <1.2, - time >=1.9.3 && <1.10, + time >=1.11.1.1 && <1.12, transformers >=0.5.6.2 && <0.6, transformers-base >=0.4.6 && <0.5, - transformers-compat >=0.6.6 && <0.7, - typed-process >=0.2.7.0 && <0.3, - unordered-containers >=0.2.14.0 && <0.3, + transformers-compat >=0.7.1 && <0.8, + typed-process >=0.2.10.1 && <0.3, + unordered-containers >=0.2.19.1 && <0.3, utf8-string >=1.0.2 && <1.1, vector >=0.12.3.1 && <0.13 @@ -378,13 +378,13 @@ executable purs main-is: Main.hs ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N build-depends: - ansi-wl-pprint >=0.6.9 && <0.7 - , exceptions >=0.10.4 && <0.11 - , file-embed >=0.0.13.0 && <0.1 - , http-types >=0.12.3 && <0.13 - , network >= 3.1.1.1 && <3.2 - , optparse-applicative >=0.16.1.0 && <0.17 - , purescript + ansi-wl-pprint >=0.6.9 && <0.7, + exceptions >=0.10.4 && <0.11, + file-embed >=0.0.13.0 && <0.1, + http-types >=0.12.3 && <0.13, + network >=3.1.2.7 && <3.2, + optparse-applicative >=0.17.0.0 && <0.18, + purescript if flag(release) cpp-options: -DRELEASE else @@ -414,13 +414,13 @@ test-suite tests -- Not a problem for this warning to arise in tests ghc-options: -Wno-incomplete-uni-patterns build-depends: - purescript - , generic-random >=1.4.0.0 && <1.5 - , hspec ==2.8.3 - , HUnit >=1.6.2.0 && <1.7 - , newtype >=0.2.2.0 && <0.3 - , QuickCheck >=2.14.2 && <2.15 - , regex-base >=0.94.0.1 && <0.95 + purescript, + generic-random >=1.5.0.1 && <1.6, + hspec ==2.9.2, + HUnit >=1.6.2.0 && <1.7, + newtype >=0.2.2.0 && <0.3, + QuickCheck >=2.14.2 && <2.15, + regex-base >=0.94.0.2 && <0.95 build-tool-depends: hspec-discover:hspec-discover -any -- we need the compiler's executable available for the ide tests diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 30d564c117..5e7bd060ad 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -828,9 +828,9 @@ newtype AssocList k t = AssocList { runAssocList :: [(k, t)] } deriving (Show, Eq, Ord, Foldable, Functor, Traversable) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''NameSource) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExportSource) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType) -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExportSource) isTrueExpr :: Expr -> Bool isTrueExpr (Literal _ (BooleanLiteral True)) = True diff --git a/src/Language/PureScript/CST/Utils.hs b/src/Language/PureScript/CST/Utils.hs index 9c31d5fd8b..8ffb536f9e 100644 --- a/src/Language/PureScript/CST/Utils.hs +++ b/src/Language/PureScript/CST/Utils.hs @@ -38,11 +38,14 @@ qualifiedProperName n = QualifiedProperName (N.coerceProperName <$> n) -- which can be used for all of the different ProperNameTypes -- (via a call to getProperName). newtype ProperName = - ProperName { getProperName :: forall a. Name (N.ProperName a) } + ProperName { _getProperName :: forall a. Name (N.ProperName a) } properName :: Name (N.ProperName a) -> ProperName properName n = ProperName (N.coerceProperName <$> n) +getProperName :: forall a. ProperName -> Name (N.ProperName a) +getProperName pn = _getProperName pn -- eta expansion needed here due to simplified subsumption + -- | -- A newtype for a qualified operator name whose OpNameType has not yet been determined. -- This is a workaround for Happy's limited support for polymorphism; it is used diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 53e26ccba8..bcff76776f 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -12,7 +12,10 @@ import Prelude.Compat import Control.Arrow ((***)) import Data.Either (isLeft) import qualified Data.Map.Strict as M -import Data.Aeson +import Data.Aeson hiding ((.=)) +import qualified Data.Aeson +import qualified Data.Aeson.Key +import Data.Aeson.Types (Pair) import Data.Version (Version, showVersion) import Data.Text (Text) import qualified Data.Text as T @@ -27,65 +30,69 @@ constructorTypeToJSON :: ConstructorType -> Value constructorTypeToJSON ProductType = toJSON "ProductType" constructorTypeToJSON SumType = toJSON "SumType" +infixr 8 .= +(.=) :: ToJSON a => String -> a -> Pair +key .= value = Data.Aeson.Key.fromString key Data.Aeson..= value + metaToJSON :: Meta -> Value metaToJSON (IsConstructor t is) = object - [ T.pack "metaType" .= "IsConstructor" - , T.pack "constructorType" .= constructorTypeToJSON t - , T.pack "identifiers" .= identToJSON `map` is + [ "metaType" .= "IsConstructor" + , "constructorType" .= constructorTypeToJSON t + , "identifiers" .= identToJSON `map` is ] -metaToJSON IsNewtype = object [ T.pack "metaType" .= "IsNewtype" ] -metaToJSON IsTypeClassConstructor = object [ T.pack "metaType" .= "IsTypeClassConstructor" ] -metaToJSON IsForeign = object [ T.pack "metaType" .= "IsForeign" ] -metaToJSON IsWhere = object [ T.pack "metaType" .= "IsWhere" ] -metaToJSON IsSyntheticApp = object [ T.pack "metaType" .= "IsSyntheticApp" ] +metaToJSON IsNewtype = object [ "metaType" .= "IsNewtype" ] +metaToJSON IsTypeClassConstructor = object [ "metaType" .= "IsTypeClassConstructor" ] +metaToJSON IsForeign = object [ "metaType" .= "IsForeign" ] +metaToJSON IsWhere = object [ "metaType" .= "IsWhere" ] +metaToJSON IsSyntheticApp = object [ "metaType" .= "IsSyntheticApp" ] sourceSpanToJSON :: SourceSpan -> Value sourceSpanToJSON (SourceSpan _ spanStart spanEnd) = - object [ T.pack "start" .= spanStart - , T.pack "end" .= spanEnd + object [ "start" .= spanStart + , "end" .= spanEnd ] annToJSON :: Ann -> Value -annToJSON (ss, _, _, m) = object [ T.pack "sourceSpan" .= sourceSpanToJSON ss - , T.pack "meta" .= maybe Null metaToJSON m +annToJSON (ss, _, _, m) = object [ "sourceSpan" .= sourceSpanToJSON ss + , "meta" .= maybe Null metaToJSON m ] literalToJSON :: (a -> Value) -> Literal a -> Value literalToJSON _ (NumericLiteral (Left n)) = object - [ T.pack "literalType" .= "IntLiteral" - , T.pack "value" .= n + [ "literalType" .= "IntLiteral" + , "value" .= n ] literalToJSON _ (NumericLiteral (Right n)) = object - [ T.pack "literalType" .= "NumberLiteral" - , T.pack "value" .= n + [ "literalType" .= "NumberLiteral" + , "value" .= n ] literalToJSON _ (StringLiteral s) = object - [ T.pack "literalType" .= "StringLiteral" - , T.pack "value" .= s + [ "literalType" .= "StringLiteral" + , "value" .= s ] literalToJSON _ (CharLiteral c) = object - [ T.pack "literalType" .= "CharLiteral" - , T.pack "value" .= c + [ "literalType" .= "CharLiteral" + , "value" .= c ] literalToJSON _ (BooleanLiteral b) = object - [ T.pack "literalType" .= "BooleanLiteral" - , T.pack "value" .= b + [ "literalType" .= "BooleanLiteral" + , "value" .= b ] literalToJSON t (ArrayLiteral xs) = object - [ T.pack "literalType" .= "ArrayLiteral" - , T.pack "value" .= map t xs + [ "literalType" .= "ArrayLiteral" + , "value" .= map t xs ] literalToJSON t (ObjectLiteral xs) = object - [ T.pack "literalType" .= "ObjectLiteral" - , T.pack "value" .= recordToJSON t xs + [ "literalType" .= "ObjectLiteral" + , "value" .= recordToJSON t xs ] identToJSON :: Ident -> Value @@ -96,8 +103,8 @@ properNameToJSON = toJSON . runProperName qualifiedToJSON :: (a -> Text) -> Qualified a -> Value qualifiedToJSON f (Qualified mn a) = object - [ T.pack "moduleName" .= maybe Null moduleNameToJSON mn - , T.pack "identifier" .= toJSON (f a) + [ "moduleName" .= maybe Null moduleNameToJSON mn + , "identifier" .= toJSON (f a) ] moduleNameToJSON :: ModuleName -> Value @@ -105,22 +112,22 @@ moduleNameToJSON (ModuleName name) = toJSON (T.splitOn (T.pack ".") name) moduleToJSON :: Version -> Module Ann -> Value moduleToJSON v m = object - [ T.pack "sourceSpan" .= sourceSpanToJSON (moduleSourceSpan m) - , T.pack "moduleName" .= moduleNameToJSON (moduleName m) - , T.pack "modulePath" .= toJSON (modulePath m) - , T.pack "imports" .= map importToJSON (moduleImports m) - , T.pack "exports" .= map identToJSON (moduleExports m) - , T.pack "reExports" .= reExportsToJSON (moduleReExports m) - , T.pack "foreign" .= map identToJSON (moduleForeign m) - , T.pack "decls" .= map bindToJSON (moduleDecls m) - , T.pack "builtWith" .= toJSON (showVersion v) - , T.pack "comments" .= map toJSON (moduleComments m) + [ "sourceSpan" .= sourceSpanToJSON (moduleSourceSpan m) + , "moduleName" .= moduleNameToJSON (moduleName m) + , "modulePath" .= toJSON (modulePath m) + , "imports" .= map importToJSON (moduleImports m) + , "exports" .= map identToJSON (moduleExports m) + , "reExports" .= reExportsToJSON (moduleReExports m) + , "foreign" .= map identToJSON (moduleForeign m) + , "decls" .= map bindToJSON (moduleDecls m) + , "builtWith" .= toJSON (showVersion v) + , "comments" .= map toJSON (moduleComments m) ] where importToJSON (ann,mn) = object - [ T.pack "annotation" .= annToJSON ann - , T.pack "moduleName" .= moduleNameToJSON mn + [ "annotation" .= annToJSON ann + , "moduleName" .= moduleNameToJSON mn ] reExportsToJSON :: M.Map ModuleName [Ident] -> Value @@ -129,19 +136,19 @@ moduleToJSON v m = object bindToJSON :: Bind Ann -> Value bindToJSON (NonRec ann n e) = object - [ T.pack "bindType" .= "NonRec" - , T.pack "annotation" .= annToJSON ann - , T.pack "identifier" .= identToJSON n - , T.pack "expression" .= exprToJSON e + [ "bindType" .= "NonRec" + , "annotation" .= annToJSON ann + , "identifier" .= identToJSON n + , "expression" .= exprToJSON e ] bindToJSON (Rec bs) = object - [ T.pack "bindType" .= "Rec" - , T.pack "binds" .= map (\((ann, n), e) + [ "bindType" .= "Rec" + , "binds" .= map (\((ann, n), e) -> object - [ T.pack "identifier" .= identToJSON n - , T.pack "annotation" .= annToJSON ann - , T.pack "expression" .= exprToJSON e + [ "identifier" .= identToJSON n + , "annotation" .= annToJSON ann + , "expression" .= exprToJSON e ]) bs ] @@ -149,86 +156,86 @@ recordToJSON :: (a -> Value) -> [(PSString, a)] -> Value recordToJSON f = toJSON . map (toJSON *** f) exprToJSON :: Expr Ann -> Value -exprToJSON (Var ann i) = object [ T.pack "type" .= toJSON "Var" - , T.pack "annotation" .= annToJSON ann - , T.pack "value" .= qualifiedToJSON runIdent i +exprToJSON (Var ann i) = object [ "type" .= toJSON "Var" + , "annotation" .= annToJSON ann + , "value" .= qualifiedToJSON runIdent i ] -exprToJSON (Literal ann l) = object [ T.pack "type" .= "Literal" - , T.pack "annotation" .= annToJSON ann - , T.pack "value" .= literalToJSON exprToJSON l +exprToJSON (Literal ann l) = object [ "type" .= "Literal" + , "annotation" .= annToJSON ann + , "value" .= literalToJSON exprToJSON l ] -exprToJSON (Constructor ann d c is) = object [ T.pack "type" .= "Constructor" - , T.pack "annotation" .= annToJSON ann - , T.pack "typeName" .= properNameToJSON d - , T.pack "constructorName" .= properNameToJSON c - , T.pack "fieldNames" .= map identToJSON is +exprToJSON (Constructor ann d c is) = object [ "type" .= "Constructor" + , "annotation" .= annToJSON ann + , "typeName" .= properNameToJSON d + , "constructorName" .= properNameToJSON c + , "fieldNames" .= map identToJSON is ] -exprToJSON (Accessor ann f r) = object [ T.pack "type" .= "Accessor" - , T.pack "annotation" .= annToJSON ann - , T.pack "fieldName" .= f - , T.pack "expression" .= exprToJSON r +exprToJSON (Accessor ann f r) = object [ "type" .= "Accessor" + , "annotation" .= annToJSON ann + , "fieldName" .= f + , "expression" .= exprToJSON r ] -exprToJSON (ObjectUpdate ann r fs) = object [ T.pack "type" .= "ObjectUpdate" - , T.pack "annotation" .= annToJSON ann - , T.pack "expression" .= exprToJSON r - , T.pack "updates" .= recordToJSON exprToJSON fs +exprToJSON (ObjectUpdate ann r fs) = object [ "type" .= "ObjectUpdate" + , "annotation" .= annToJSON ann + , "expression" .= exprToJSON r + , "updates" .= recordToJSON exprToJSON fs ] -exprToJSON (Abs ann p b) = object [ T.pack "type" .= "Abs" - , T.pack "annotation" .= annToJSON ann - , T.pack "argument" .= identToJSON p - , T.pack "body" .= exprToJSON b +exprToJSON (Abs ann p b) = object [ "type" .= "Abs" + , "annotation" .= annToJSON ann + , "argument" .= identToJSON p + , "body" .= exprToJSON b ] -exprToJSON (App ann f x) = object [ T.pack "type" .= "App" - , T.pack "annotation" .= annToJSON ann - , T.pack "abstraction" .= exprToJSON f - , T.pack "argument" .= exprToJSON x +exprToJSON (App ann f x) = object [ "type" .= "App" + , "annotation" .= annToJSON ann + , "abstraction" .= exprToJSON f + , "argument" .= exprToJSON x ] -exprToJSON (Case ann ss cs) = object [ T.pack "type" .= "Case" - , T.pack "annotation" .= annToJSON ann - , T.pack "caseExpressions" +exprToJSON (Case ann ss cs) = object [ "type" .= "Case" + , "annotation" .= annToJSON ann + , "caseExpressions" .= map exprToJSON ss - , T.pack "caseAlternatives" + , "caseAlternatives" .= map caseAlternativeToJSON cs ] -exprToJSON (Let ann bs e) = object [ T.pack "type" .= "Let" - , T.pack "annotation" .= annToJSON ann - , T.pack "binds" .= map bindToJSON bs - , T.pack "expression" .= exprToJSON e +exprToJSON (Let ann bs e) = object [ "type" .= "Let" + , "annotation" .= annToJSON ann + , "binds" .= map bindToJSON bs + , "expression" .= exprToJSON e ] caseAlternativeToJSON :: CaseAlternative Ann -> Value caseAlternativeToJSON (CaseAlternative bs r') = let isGuarded = isLeft r' in object - [ T.pack "binders" .= toJSON (map binderToJSON bs) - , T.pack "isGuarded" .= toJSON isGuarded - , T.pack (if isGuarded then "expressions" else "expression") + [ "binders" .= toJSON (map binderToJSON bs) + , "isGuarded" .= toJSON isGuarded + , (if isGuarded then "expressions" else "expression") .= case r' of - Left rs -> toJSON $ map (\(g, e) -> object [ T.pack "guard" .= exprToJSON g, T.pack "expression" .= exprToJSON e]) rs + Left rs -> toJSON $ map (\(g, e) -> object [ "guard" .= exprToJSON g, "expression" .= exprToJSON e]) rs Right r -> exprToJSON r ] binderToJSON :: Binder Ann -> Value -binderToJSON (VarBinder ann v) = object [ T.pack "binderType" .= "VarBinder" - , T.pack "annotation" .= annToJSON ann - , T.pack "identifier" .= identToJSON v +binderToJSON (VarBinder ann v) = object [ "binderType" .= "VarBinder" + , "annotation" .= annToJSON ann + , "identifier" .= identToJSON v ] -binderToJSON (NullBinder ann) = object [ T.pack "binderType" .= "NullBinder" - , T.pack "annotation" .= annToJSON ann +binderToJSON (NullBinder ann) = object [ "binderType" .= "NullBinder" + , "annotation" .= annToJSON ann ] -binderToJSON (LiteralBinder ann l) = object [ T.pack "binderType" .= "LiteralBinder" - , T.pack "annotation" .= annToJSON ann - , T.pack "literal" .= literalToJSON binderToJSON l +binderToJSON (LiteralBinder ann l) = object [ "binderType" .= "LiteralBinder" + , "annotation" .= annToJSON ann + , "literal" .= literalToJSON binderToJSON l ] -binderToJSON (ConstructorBinder ann d c bs) = object [ T.pack "binderType" .= "ConstructorBinder" - , T.pack "annotation" .= annToJSON ann - , T.pack "typeName" .= qualifiedToJSON runProperName d - , T.pack "constructorName" +binderToJSON (ConstructorBinder ann d c bs) = object [ "binderType" .= "ConstructorBinder" + , "annotation" .= annToJSON ann + , "typeName" .= qualifiedToJSON runProperName d + , "constructorName" .= qualifiedToJSON runProperName c - , T.pack "binders" .= map binderToJSON bs + , "binders" .= map binderToJSON bs ] -binderToJSON (NamedBinder ann n b) = object [ T.pack "binderType" .= "NamedBinder" - , T.pack "annotation" .= annToJSON ann - , T.pack "identifier" .= identToJSON n - , T.pack "binder" .= binderToJSON b +binderToJSON (NamedBinder ann n b) = object [ "binderType" .= "NamedBinder" + , "annotation" .= annToJSON ann + , "identifier" .= identToJSON n + , "binder" .= binderToJSON b ] diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 836e2afc86..fd5e4bd1b6 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -10,6 +10,7 @@ import Prelude (String, unlines, lookup) import Control.Arrow ((***)) import Data.Aeson ((.=)) +import qualified Data.Aeson.Key as A.Key import Data.Aeson.BetterErrors (Parse, keyOrDefault, throwCustomError, key, asText, keyMay, withString, eachInArray, asNull, (.!), toAesonParser, toAesonParser', @@ -776,10 +777,10 @@ instance A.ToJSON a => A.ToJSON (Package a) where , "version" .= showVersion pkgVersion , "versionTag" .= pkgVersionTag , "modules" .= pkgModules - , "moduleMap" .= assocListToJSON P.runModuleName + , "moduleMap" .= assocListToJSON (A.Key.fromText . P.runModuleName) runPackageName (Map.toList pkgModuleMap) - , "resolvedDependencies" .= assocListToJSON runPackageName + , "resolvedDependencies" .= assocListToJSON (A.Key.fromText . runPackageName) (T.pack . showVersion) pkgResolvedDependencies , "github" .= pkgGithub @@ -865,7 +866,7 @@ instance A.ToJSON GithubRepo where -- -- For example: -- @assocListToJSON T.pack T.pack [("a", "b")]@ will give @{"a": "b"}@. -assocListToJSON :: (a -> Text) -> (b -> Text) -> [(a, b)] -> A.Value +assocListToJSON :: (a -> A.Key) -> (b -> Text) -> [(a, b)] -> A.Value assocListToJSON f g xs = A.object (map (uncurry (.=) . (f *** g)) xs) instance A.ToJSON a => A.ToJSON (InPackage a) where diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index ced1f7b1cf..00c3170774 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -39,9 +39,9 @@ data JSONResult = JSONResult } deriving (Show, Eq) $(A.deriveJSON A.defaultOptions ''ErrorPosition) +$(A.deriveJSON A.defaultOptions ''ErrorSuggestion) $(A.deriveJSON A.defaultOptions ''JSONError) $(A.deriveJSON A.defaultOptions ''JSONResult) -$(A.deriveJSON A.defaultOptions ''ErrorSuggestion) toJSONErrors :: Bool -> P.Level -> P.MultipleErrors -> [JSONError] toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErrors diff --git a/src/Language/PureScript/Graph.hs b/src/Language/PureScript/Graph.hs index ca092be193..c8b079f3ce 100644 --- a/src/Language/PureScript/Graph.hs +++ b/src/Language/PureScript/Graph.hs @@ -3,7 +3,8 @@ module Language.PureScript.Graph (graph) where import Prelude.Compat import qualified Data.Aeson as Json -import qualified Data.HashMap.Strict as HashMap +import qualified Data.Aeson.Key as Json.Key +import qualified Data.Aeson.KeyMap as Json.Map import qualified Data.Map as Map import Control.Monad (forM) @@ -44,7 +45,7 @@ moduleGraphToJSON moduleGraphToJSON paths = Json.Object . foldl' insert mempty where insert :: Json.Object -> (ModuleName, [ModuleName]) -> Json.Object - insert obj (mn, depends) = HashMap.insert (runModuleName mn) value obj + insert obj (mn, depends) = Json.Map.insert (Json.Key.fromText (runModuleName mn)) value obj where path = fromMaybe (Crash.internalError "missing module name in graph") $ Map.lookup mn paths value = Json.object diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index e31f20700d..56a37a3f3d 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -19,7 +19,7 @@ module Language.PureScript.Ide.Error import Data.Aeson import qualified Data.Aeson.Types as Aeson -import qualified Data.HashMap.Lazy as HM +import qualified Data.Aeson.KeyMap as KM import qualified Data.Text as T import qualified Language.PureScript as P import Language.PureScript.Errors.JSON @@ -57,7 +57,7 @@ encodeRebuildErrors = toJSON . map encodeRebuildError . P.runMultipleErrors insertTSCompletions name idents fields (Aeson.Object value) = Aeson.Object - (HM.insert "pursIde" + (KM.insert "pursIde" (object [ "name" .= name , "completions" .= ordNub (map identCompletion idents ++ map fieldCompletion fields) ]) value) diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 50c3330425..94088e28e8 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -260,10 +260,6 @@ isQualifiedWith :: ModuleName -> Qualified a -> Bool isQualifiedWith mn (Qualified (Just mn') _) = mn == mn' isQualifiedWith _ _ = False -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified) -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident) -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''InternalIdentData) - instance ToJSON ModuleName where toJSON (ModuleName name) = toJSON (T.splitOn "." name) @@ -277,3 +273,7 @@ instance ToJSONKey ModuleName where instance FromJSONKey ModuleName where fromJSONKey = fmap moduleNameFromString fromJSONKey + +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''InternalIdentData) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident) +$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified) \ No newline at end of file diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 67de6e7aeb..83d346d0b4 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -866,7 +866,7 @@ pairwiseM _ [] = pure () pairwiseM _ [_] = pure () pairwiseM p (x : xs) = traverse (p x) xs *> pairwiseM p xs --- | Return all nonempty suffixes of a nonempty list. For example: +-- | Return all nonempty tails of a nonempty list. For example: -- -- tails1 (fromList [1]) == fromList [fromList [1]] -- tails1 (fromList [1,2]) == fromList [fromList [1,2], fromList [2]] @@ -874,14 +874,10 @@ pairwiseM p (x : xs) = traverse (p x) xs *> pairwiseM p xs tails1 :: NonEmpty a -> NonEmpty (NonEmpty a) tails1 = -- NEL.fromList is an unsafe function, but this usage should be safe, since: - -- - -- * `tails xs = [xs, tail xs, tail (tail xs), ..., []]` - -- - -- * If `xs` is nonempty, it follows that `tails xs` contains at least one nonempty - -- list, since `head (tails xs) = xs`. - -- - -- * The only empty element of `tails xs` is the last one (by the definition of `tails`) - -- - -- * Therefore, if we take all but the last element of `tails xs` i.e. - -- `init (tails xs)`, we have a nonempty list of nonempty lists + -- * `tails xs = [xs, tail xs, tail (tail xs), ..., []]` + -- * If `xs` is nonempty, it follows that `tails xs` contains at least one nonempty + -- list, since `head (tails xs) = xs`. + -- * The only empty element of `tails xs` is the last one (by the definition of `tails`) + -- * Therefore, if we take all but the last element of `tails xs` i.e. + -- `init (tails xs)`, we have a nonempty list of nonempty lists NEL.fromList . map NEL.fromList . init . tails . NEL.toList diff --git a/stack.yaml b/stack.yaml index e93abd1edf..ac0a546b08 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ # Please update Haskell image versions under .github/workflows/ci.yml together to use the same GHC version # (or the CI build will fail) -resolver: lts-18.15 +resolver: nightly-2022-06-09 pvp-bounds: both packages: - '.' @@ -13,17 +13,20 @@ extra-deps: # `async` to be used as an object key: # https://github.com/erikd/language-javascript/issues/131 - language-javascript-0.7.0.0 -# The ./.hspec file uses the --times flag, which was added in hspec-2.8.0. -# LTS-18 has only hspec-2.7. -- hspec-2.8.3 -- hspec-core-2.8.3 -- hspec-discover-2.8.3 # Fix issue with libtinfo. # See https://github.com/purescript/purescript/issues/4253 - process-1.6.13.1 -- Cabal-3.2.1.0 -# Not included in Stackage until the lts-19 series -- monoidal-containers-0.6.2.0 +# The Cabal library is not in Stackage +- Cabal-3.6.3.0 +# Protolude is not yet in resolver snapshot +- protolude-0.3.1 +# hspec@2.9.3 is the first version that starts depending on ghc +# ghc depends on terminfo by default, but that can be ignored +# if one uses the '-terminfo' flag. +# Unfortunately, hspec doesn't expose a similar flag. +- hspec-2.9.2 +- hspec-core-2.9.2 +- hspec-discover-2.9.2 nix: packages: - zlib diff --git a/tests/TestGraph.hs b/tests/TestGraph.hs index e9c361a37a..b82b8d2cda 100644 --- a/tests/TestGraph.hs +++ b/tests/TestGraph.hs @@ -4,11 +4,8 @@ import Prelude () import Prelude.Compat import Test.Hspec -import System.IO.UTF8 (readUTF8FileT) import Data.Either (isLeft) -import qualified Data.ByteString.Lazy as ByteString -import qualified Data.Text.Encoding as Text import qualified Data.Aeson as Json import qualified Language.PureScript as P @@ -20,13 +17,11 @@ spec = do let modulePaths = (sourcesDir <>) <$> ["Module.purs", "Module2.purs", "Module3.purs"] let graphFixtureName = "graph.json" - graphFixture <- readUTF8FileT (baseDir <> graphFixtureName) + graphFixture <- Json.decodeFileStrict' (baseDir <> graphFixtureName) eitherGraph <- fst <$> P.graph modulePaths case eitherGraph of Left err -> error $ "Graph creation failed. Errors: " <> show err - Right res -> do - let graphFixture' = Json.decode $ ByteString.fromStrict $ Text.encodeUtf8 graphFixture - graphFixture' `shouldBe` Just res + Right res -> graphFixture `shouldBe` Just res it "should fail when trying to include non-existing modules in the graph" $ do let modulePath = sourcesDir <> "ModuleFailing.purs" diff --git a/tests/purs/sourcemaps/Bug4034.out.js.map b/tests/purs/sourcemaps/Bug4034.out.js.map index 04087de7ff..3e89a756b1 100644 --- a/tests/purs/sourcemaps/Bug4034.out.js.map +++ b/tests/purs/sourcemaps/Bug4034.out.js.map @@ -1 +1 @@ -{"mappings":";;;;;;;;AA2BA,eAAA;;WAAA;kCACwB;;;;;;AAXxB,cAAA;;WAAA;iCACsB;;;;;;AA6BtB,eAAA;;WAAA;kCACwB;;;;;;AAXxB,gBAAA;;WAAA;mCAC0B;;;;;;AAmB1B,gBAAA;;WAAA;mCAC0B","sources":["../../tests/purs/sourcemaps/Bug4034.purs"],"names":[],"version":3,"file":"index.js"} \ No newline at end of file +{"file":"index.js","mappings":";;;;;;;;AA2BA,eAAA;;WAAA;kCACwB;;;;;;AAXxB,cAAA;;WAAA;iCACsB;;;;;;AA6BtB,eAAA;;WAAA;kCACwB;;;;;;AAXxB,gBAAA;;WAAA;mCAC0B;;;;;;AAmB1B,gBAAA;;WAAA;mCAC0B","names":[],"sources":["../../tests/purs/sourcemaps/Bug4034.purs"],"version":3} \ No newline at end of file diff --git a/tests/purs/sourcemaps/Recipe.out.js.map b/tests/purs/sourcemaps/Recipe.out.js.map index 500c26441e..b296ffd692 100644 --- a/tests/purs/sourcemaps/Recipe.out.js.map +++ b/tests/purs/sourcemaps/Recipe.out.js.map @@ -1 +1 @@ -{"mappings":"","sources":[],"names":[],"version":3,"file":"index.js"} \ No newline at end of file +{"file":"index.js","mappings":"","names":[],"sources":[],"version":3} \ No newline at end of file From 78786130e3c595b3084d57e0b46581477d741cfb Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Thu, 23 Jun 2022 12:50:36 +0800 Subject: [PATCH 1482/1580] Qualify locally-bound names with source spans (#4293) --- CHANGELOG.d/internal_local_qualification.md | 6 ++ src/Language/PureScript/AST/Declarations.hs | 18 ++-- src/Language/PureScript/AST/Traversals.hs | 2 +- src/Language/PureScript/AST/Utils.hs | 6 +- src/Language/PureScript/CST/Convert.hs | 4 +- src/Language/PureScript/CodeGen/JS.hs | 10 +-- .../PureScript/Constants/Data/Generic/Rep.hs | 23 +++--- .../PureScript/Constants/Data/Newtype.hs | 3 +- src/Language/PureScript/Constants/Prelude.hs | 36 ++++---- src/Language/PureScript/Constants/Prim.hs | 60 +++++++------- src/Language/PureScript/CoreFn/CSE.hs | 6 +- src/Language/PureScript/CoreFn/Desugar.hs | 8 +- src/Language/PureScript/CoreFn/FromJSON.hs | 16 +++- src/Language/PureScript/CoreFn/Laziness.hs | 12 +-- src/Language/PureScript/CoreFn/Optimizer.hs | 4 +- src/Language/PureScript/CoreFn/ToJSON.hs | 16 ++-- src/Language/PureScript/Docs/Convert.hs | 6 +- .../PureScript/Docs/Convert/ReExports.hs | 2 +- src/Language/PureScript/Docs/Render.hs | 4 +- .../PureScript/Docs/RenderedCode/Types.hs | 8 +- src/Language/PureScript/Environment.hs | 6 +- src/Language/PureScript/Errors.hs | 54 ++++++------ src/Language/PureScript/Externs.hs | 26 +++--- src/Language/PureScript/Ide/Error.hs | 4 +- src/Language/PureScript/Ide/State.hs | 8 +- src/Language/PureScript/Ide/Usage.hs | 4 +- src/Language/PureScript/Interactive.hs | 2 +- src/Language/PureScript/Interactive/Module.hs | 6 +- src/Language/PureScript/Linter.hs | 2 +- src/Language/PureScript/Linter/Exhaustive.hs | 2 +- src/Language/PureScript/Linter/Imports.hs | 2 +- src/Language/PureScript/Names.hs | 62 +++++++++++--- src/Language/PureScript/Renamer.hs | 6 +- src/Language/PureScript/Sugar/AdoNotation.hs | 8 +- .../PureScript/Sugar/BindingGroups.hs | 16 ++-- .../PureScript/Sugar/CaseDeclarations.hs | 8 +- src/Language/PureScript/Sugar/DoNotation.hs | 6 +- src/Language/PureScript/Sugar/Names.hs | 82 +++++++++++++------ src/Language/PureScript/Sugar/Names/Env.hs | 19 +++-- .../PureScript/Sugar/Names/Exports.hs | 6 +- .../PureScript/Sugar/Names/Imports.hs | 6 +- .../PureScript/Sugar/ObjectWildcards.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 20 ++--- src/Language/PureScript/Sugar/TypeClasses.hs | 10 +-- .../PureScript/Sugar/TypeClasses/Deriving.hs | 14 ++-- src/Language/PureScript/TypeChecker.hs | 54 ++++++------ .../PureScript/TypeChecker/Deriving.hs | 12 +-- .../PureScript/TypeChecker/Entailment.hs | 24 +++--- .../TypeChecker/Entailment/Coercible.hs | 4 +- src/Language/PureScript/TypeChecker/Kinds.hs | 12 +-- src/Language/PureScript/TypeChecker/Monad.hs | 32 ++++---- src/Language/PureScript/TypeChecker/Roles.hs | 6 +- .../PureScript/TypeChecker/TypeSearch.hs | 4 +- src/Language/PureScript/TypeChecker/Types.hs | 34 ++++---- tests/Language/PureScript/Ide/FilterSpec.hs | 4 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 2 +- .../Language/PureScript/Ide/SourceFileSpec.hs | 8 +- tests/Language/PureScript/Ide/StateSpec.hs | 8 +- tests/TestAst.hs | 2 +- tests/TestCoreFn.hs | 22 ++--- tests/TestHierarchy.hs | 2 +- 61 files changed, 479 insertions(+), 382 deletions(-) create mode 100644 CHANGELOG.d/internal_local_qualification.md diff --git a/CHANGELOG.d/internal_local_qualification.md b/CHANGELOG.d/internal_local_qualification.md new file mode 100644 index 0000000000..269b2e31cf --- /dev/null +++ b/CHANGELOG.d/internal_local_qualification.md @@ -0,0 +1,6 @@ +* Add qualification for locally-bound names + + This change makes it so that `Qualified` names can now be qualified by either + a `ModuleName` for module-level declarations or the starting `SourcePos` for + bindings introduced locally. This makes disambiguation between references to + local bindings much easier in AST-driven analysis. diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 5e7bd060ad..07eb3c69da 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -130,13 +130,15 @@ getModuleDeclarations (Module _ _ _ declarations _) = declarations addDefaultImport :: Qualified ModuleName -> Module -> Module addDefaultImport (Qualified toImportAs toImport) m@(Module ss coms mn decls exps) = if isExistingImport `any` decls || mn == toImport then m - else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit toImportAs : decls) exps + else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit toImportAs' : decls) exps where + toImportAs' = toMaybeModuleName toImportAs + isExistingImport (ImportDeclaration _ mn' _ as') | mn' == toImport = - case toImportAs of + case toImportAs' of Nothing -> True - _ -> as' == toImportAs + _ -> as' == toImportAs' isExistingImport _ = False -- | Adds import declarations to a module for an implicit Prim import and Prim @@ -146,8 +148,8 @@ importPrim = let primModName = C.Prim in - addDefaultImport (Qualified (Just primModName) primModName) - . addDefaultImport (Qualified Nothing primModName) + addDefaultImport (Qualified (ByModuleName primModName) primModName) + . addDefaultImport (Qualified ByNullSourcePos primModName) data NameSource = UserNamed | CompilerNamed deriving (Show, Generic, NFData, Serialise) @@ -720,7 +722,7 @@ data Expr -- instance type, and the type class dictionaries in scope. -- | TypeClassDictionary SourceConstraint - (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))) + (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))) [ErrorMessageHint] -- | -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking @@ -834,8 +836,8 @@ $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDe isTrueExpr :: Expr -> Bool isTrueExpr (Literal _ (BooleanLiteral True)) = True -isTrueExpr (Var _ (Qualified (Just (ModuleName "Prelude")) (Ident "otherwise"))) = True -isTrueExpr (Var _ (Qualified (Just (ModuleName "Data.Boolean")) (Ident "otherwise"))) = True +isTrueExpr (Var _ (Qualified (ByModuleName (ModuleName "Prelude")) (Ident "otherwise"))) = True +isTrueExpr (Var _ (Qualified (ByModuleName (ModuleName "Data.Boolean")) (Ident "otherwise"))) = True isTrueExpr (TypedValue _ e _) = isTrueExpr e isTrueExpr (PositionedValue _ _ e) = isTrueExpr e isTrueExpr _ = False diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index d35f073530..1e76f15766 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -691,4 +691,4 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' g other = other updateDict fn dict = dict { tcdInstanceTypes = fn (tcdInstanceTypes dict) } updateScope = fmap . fmap . fmap . fmap $ updateDict $ fmap f - updateCtx = M.alter updateScope Nothing + updateCtx = M.alter updateScope ByNullSourcePos diff --git a/src/Language/PureScript/AST/Utils.hs b/src/Language/PureScript/AST/Utils.hs index 638ce26f0d..4e28f6e6ef 100644 --- a/src/Language/PureScript/AST/Utils.hs +++ b/src/Language/PureScript/AST/Utils.hs @@ -19,7 +19,7 @@ mkRef :: Qualified Ident -> Expr mkRef = Var nullSourceSpan mkVarMn :: Maybe ModuleName -> Ident -> Expr -mkVarMn mn = mkRef . Qualified mn +mkVarMn mn = mkRef . Qualified (byMaybeModuleName mn) mkVar :: Ident -> Expr mkVar = mkVarMn Nothing @@ -31,10 +31,10 @@ mkLit :: Literal Expr -> Expr mkLit = Literal nullSourceSpan mkCtor :: ModuleName -> ProperName 'ConstructorName -> Expr -mkCtor mn name = Constructor nullSourceSpan (Qualified (Just mn) name) +mkCtor mn name = Constructor nullSourceSpan (Qualified (ByModuleName mn) name) mkCtorBinder :: ModuleName -> ProperName 'ConstructorName -> [Binder] -> Binder -mkCtorBinder mn name = ConstructorBinder nullSourceSpan (Qualified (Just mn) name) +mkCtorBinder mn name = ConstructorBinder nullSourceSpan (Qualified (ByModuleName mn) name) unguarded :: Expr -> [GuardedExpr] unguarded e = [MkUnguarded e] diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index 077db41867..d0be2c92d4 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -90,7 +90,9 @@ moduleName = \case go ns = Just $ N.ModuleName $ Text.intercalate "." ns qualified :: QualifiedName a -> N.Qualified a -qualified q = N.Qualified (qualModule q) (qualName q) +qualified q = N.Qualified qb (qualName q) + where + qb = maybe N.ByNullSourcePos N.ByModuleName $ qualModule q ident :: Ident -> N.Ident ident = N.Ident . getIdent diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index c483180fe8..7894ae9194 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -265,7 +265,7 @@ moduleBindToJs mn = bindToJs guessEffects :: Expr Ann -> AST.InitializerEffects guessEffects = \case - Var _ (Qualified Nothing _) -> NoEffects + Var _ (Qualified (BySourcePos _) _) -> NoEffects App (_, _, _, Just IsSyntheticApp) _ _ -> NoEffects _ -> UnknownEffects @@ -318,7 +318,7 @@ moduleBindToJs mn = bindToJs unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann]) unApp (App _ val arg) args = unApp val (arg : args) unApp other args = (other, args) - valueToJs' (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) = + valueToJs' (Var (_, _, _, Just IsForeign) qi@(Qualified (ByModuleName mn') ident)) = return $ if mn' == mn then foreignIdent ident else varToJs qi @@ -387,14 +387,14 @@ moduleBindToJs mn = bindToJs -- | Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable. varToJs :: Qualified Ident -> AST - varToJs (Qualified Nothing ident) = var ident + varToJs (Qualified (BySourcePos _) ident) = var ident varToJs qual = qualifiedToJS id qual -- | Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable that may have a qualified name. qualifiedToJS :: (a -> Ident) -> Qualified a -> AST - qualifiedToJS f (Qualified (Just C.Prim) a) = AST.Var Nothing . runIdent $ f a - qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = AST.ModuleAccessor Nothing mn' . mkString . T.concatMap identCharToText . runIdent $ f a + qualifiedToJS f (Qualified (ByModuleName C.Prim) a) = AST.Var Nothing . runIdent $ f a + qualifiedToJS f (Qualified (ByModuleName mn') a) | mn /= mn' = AST.ModuleAccessor Nothing mn' . mkString . T.concatMap identCharToText . runIdent $ f a qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToJs (f a) foreignIdent :: Ident -> AST diff --git a/src/Language/PureScript/Constants/Data/Generic/Rep.hs b/src/Language/PureScript/Constants/Data/Generic/Rep.hs index c4327903fb..9d0b493f32 100644 --- a/src/Language/PureScript/Constants/Data/Generic/Rep.hs +++ b/src/Language/PureScript/Constants/Data/Generic/Rep.hs @@ -1,40 +1,39 @@ module Language.PureScript.Constants.Data.Generic.Rep where -import Prelude.Compat import Language.PureScript.Names pattern DataGenericRep :: ModuleName pattern DataGenericRep = ModuleName "Data.Generic.Rep" pattern Generic :: Qualified (ProperName 'ClassName) -pattern Generic = Qualified (Just DataGenericRep) (ProperName "Generic") +pattern Generic = Qualified (ByModuleName DataGenericRep) (ProperName "Generic") to :: Qualified Ident -to = Qualified (Just DataGenericRep) (Ident "to") +to = Qualified (ByModuleName DataGenericRep) (Ident "to") from :: Qualified Ident -from = Qualified (Just DataGenericRep) (Ident "from") +from = Qualified (ByModuleName DataGenericRep) (Ident "from") pattern NoConstructors :: Qualified (ProperName a) -pattern NoConstructors = Qualified (Just DataGenericRep) (ProperName "NoConstructors") +pattern NoConstructors = Qualified (ByModuleName DataGenericRep) (ProperName "NoConstructors") pattern NoArguments :: Qualified (ProperName a) -pattern NoArguments = Qualified (Just DataGenericRep) (ProperName "NoArguments") +pattern NoArguments = Qualified (ByModuleName DataGenericRep) (ProperName "NoArguments") pattern Sum :: Qualified (ProperName a) -pattern Sum = Qualified (Just DataGenericRep) (ProperName "Sum") +pattern Sum = Qualified (ByModuleName DataGenericRep) (ProperName "Sum") pattern Inl :: Qualified (ProperName a) -pattern Inl = Qualified (Just DataGenericRep) (ProperName "Inl") +pattern Inl = Qualified (ByModuleName DataGenericRep) (ProperName "Inl") pattern Inr :: Qualified (ProperName a) -pattern Inr = Qualified (Just DataGenericRep) (ProperName "Inr") +pattern Inr = Qualified (ByModuleName DataGenericRep) (ProperName "Inr") pattern Product :: Qualified (ProperName a) -pattern Product = Qualified (Just DataGenericRep) (ProperName "Product") +pattern Product = Qualified (ByModuleName DataGenericRep) (ProperName "Product") pattern Constructor :: Qualified (ProperName a) -pattern Constructor = Qualified (Just DataGenericRep) (ProperName "Constructor") +pattern Constructor = Qualified (ByModuleName DataGenericRep) (ProperName "Constructor") pattern Argument :: Qualified (ProperName a) -pattern Argument = Qualified (Just DataGenericRep) (ProperName "Argument") +pattern Argument = Qualified (ByModuleName DataGenericRep) (ProperName "Argument") diff --git a/src/Language/PureScript/Constants/Data/Newtype.hs b/src/Language/PureScript/Constants/Data/Newtype.hs index fcb51ba863..620f305de0 100644 --- a/src/Language/PureScript/Constants/Data/Newtype.hs +++ b/src/Language/PureScript/Constants/Data/Newtype.hs @@ -1,7 +1,6 @@ module Language.PureScript.Constants.Data.Newtype where -import Prelude.Compat import Language.PureScript.Names pattern Newtype :: Qualified (ProperName 'ClassName) -pattern Newtype = Qualified (Just (ModuleName "Data.Newtype")) (ProperName "Newtype") +pattern Newtype = Qualified (ByModuleName (ModuleName "Data.Newtype")) (ProperName "Newtype") diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index 1bc229442c..29b20b0039 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -1,8 +1,6 @@ -- | Various constants which refer to things in the Prelude module Language.PureScript.Constants.Prelude where -import Prelude.Compat hiding (compare, map) - import Data.String (IsString) import Language.PureScript.PSString (PSString) import Language.PureScript.Names @@ -25,7 +23,7 @@ discard :: forall a. (IsString a) => a discard = "discard" pattern Discard :: Qualified (ProperName 'ClassName) -pattern Discard = Qualified (Just ControlBind) (ProperName "Discard") +pattern Discard = Qualified (ByModuleName ControlBind) (ProperName "Discard") add :: forall a. (IsString a) => a add = "add" @@ -277,13 +275,13 @@ pattern DataSymbol :: ModuleName pattern DataSymbol = ModuleName "Data.Symbol" pattern IsSymbol :: Qualified (ProperName 'ClassName) -pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol") +pattern IsSymbol = Qualified (ByModuleName DataSymbol) (ProperName "IsSymbol") pattern DataReflectable :: ModuleName pattern DataReflectable = ModuleName "Data.Reflectable" pattern Reflectable :: Qualified (ProperName 'ClassName) -pattern Reflectable = Qualified (Just DataReflectable) (ProperName "Reflectable") +pattern Reflectable = Qualified (ByModuleName DataReflectable) (ProperName "Reflectable") pattern DataOrdering :: ModuleName pattern DataOrdering = ModuleName "Data.Ordering" @@ -295,16 +293,16 @@ pattern PartialUnsafe :: ModuleName pattern PartialUnsafe = ModuleName "Partial.Unsafe" pattern Ordering :: Qualified (ProperName 'TypeName) -pattern Ordering = Qualified (Just DataOrdering) (ProperName "Ordering") +pattern Ordering = Qualified (ByModuleName DataOrdering) (ProperName "Ordering") pattern LT :: Qualified (ProperName 'ConstructorName) -pattern LT = Qualified (Just DataOrdering) (ProperName "LT") +pattern LT = Qualified (ByModuleName DataOrdering) (ProperName "LT") pattern EQ :: Qualified (ProperName 'ConstructorName) -pattern EQ = Qualified (Just DataOrdering) (ProperName "EQ") +pattern EQ = Qualified (ByModuleName DataOrdering) (ProperName "EQ") pattern GT :: Qualified (ProperName 'ConstructorName) -pattern GT = Qualified (Just DataOrdering) (ProperName "GT") +pattern GT = Qualified (ByModuleName DataOrdering) (ProperName "GT") pattern DataArray :: ModuleName pattern DataArray = ModuleName "Data.Array" @@ -349,40 +347,40 @@ pattern DataEq :: ModuleName pattern DataEq = ModuleName "Data.Eq" pattern Eq :: Qualified (ProperName 'ClassName) -pattern Eq = Qualified (Just DataEq) (ProperName "Eq") +pattern Eq = Qualified (ByModuleName DataEq) (ProperName "Eq") pattern Eq1 :: Qualified (ProperName 'ClassName) -pattern Eq1 = Qualified (Just DataEq) (ProperName "Eq1") +pattern Eq1 = Qualified (ByModuleName DataEq) (ProperName "Eq1") identEq :: Qualified Ident -identEq = Qualified (Just DataEq) (Ident eq) +identEq = Qualified (ByModuleName DataEq) (Ident eq) identEq1 :: Qualified Ident -identEq1 = Qualified (Just DataEq) (Ident eq1) +identEq1 = Qualified (ByModuleName DataEq) (Ident eq1) pattern DataOrd :: ModuleName pattern DataOrd = ModuleName "Data.Ord" pattern Ord :: Qualified (ProperName 'ClassName) -pattern Ord = Qualified (Just DataOrd) (ProperName "Ord") +pattern Ord = Qualified (ByModuleName DataOrd) (ProperName "Ord") pattern Ord1 :: Qualified (ProperName 'ClassName) -pattern Ord1 = Qualified (Just DataOrd) (ProperName "Ord1") +pattern Ord1 = Qualified (ByModuleName DataOrd) (ProperName "Ord1") identCompare :: Qualified Ident -identCompare = Qualified (Just DataOrd) (Ident compare) +identCompare = Qualified (ByModuleName DataOrd) (Ident compare) identCompare1 :: Qualified Ident -identCompare1 = Qualified (Just DataOrd) (Ident compare1) +identCompare1 = Qualified (ByModuleName DataOrd) (Ident compare1) pattern DataFunctor :: ModuleName pattern DataFunctor = ModuleName "Data.Functor" pattern Functor :: Qualified (ProperName 'ClassName) -pattern Functor = Qualified (Just DataFunctor) (ProperName "Functor") +pattern Functor = Qualified (ByModuleName DataFunctor) (ProperName "Functor") identMap :: Qualified Ident -identMap = Qualified (Just DataFunctor) (Ident map) +identMap = Qualified (ByModuleName DataFunctor) (Ident map) pattern DataSemiring :: ModuleName pattern DataSemiring = ModuleName "Data.Semiring" diff --git a/src/Language/PureScript/Constants/Prim.hs b/src/Language/PureScript/Constants/Prim.hs index ad5a15ab0d..aa2d468022 100644 --- a/src/Language/PureScript/Constants/Prim.hs +++ b/src/Language/PureScript/Constants/Prim.hs @@ -1,8 +1,6 @@ -- | Various constants which refer to things in Prim module Language.PureScript.Constants.Prim where -import Prelude.Compat - import Data.String (IsString) import Language.PureScript.Names @@ -17,25 +15,25 @@ pattern Prim :: ModuleName pattern Prim = ModuleName "Prim" pattern Partial :: Qualified (ProperName 'ClassName) -pattern Partial = Qualified (Just Prim) (ProperName "Partial") +pattern Partial = Qualified (ByModuleName Prim) (ProperName "Partial") pattern Record :: Qualified (ProperName 'TypeName) -pattern Record = Qualified (Just Prim) (ProperName "Record") +pattern Record = Qualified (ByModuleName Prim) (ProperName "Record") pattern Type :: Qualified (ProperName 'TypeName) -pattern Type = Qualified (Just Prim) (ProperName "Type") +pattern Type = Qualified (ByModuleName Prim) (ProperName "Type") pattern Constraint :: Qualified (ProperName 'TypeName) -pattern Constraint = Qualified (Just Prim) (ProperName "Constraint") +pattern Constraint = Qualified (ByModuleName Prim) (ProperName "Constraint") pattern Function :: Qualified (ProperName 'TypeName) -pattern Function = Qualified (Just Prim) (ProperName "Function") +pattern Function = Qualified (ByModuleName Prim) (ProperName "Function") pattern Array :: Qualified (ProperName 'TypeName) -pattern Array = Qualified (Just Prim) (ProperName "Array") +pattern Array = Qualified (ByModuleName Prim) (ProperName "Array") pattern Row :: Qualified (ProperName 'TypeName) -pattern Row = Qualified (Just Prim) (ProperName "Row") +pattern Row = Qualified (ByModuleName Prim) (ProperName "Row") -- Prim.Boolean @@ -43,10 +41,10 @@ pattern PrimBoolean :: ModuleName pattern PrimBoolean = ModuleName "Prim.Boolean" booleanTrue :: Qualified (ProperName 'TypeName) -booleanTrue = Qualified (Just PrimBoolean) (ProperName "True") +booleanTrue = Qualified (ByModuleName PrimBoolean) (ProperName "True") booleanFalse :: Qualified (ProperName 'TypeName) -booleanFalse = Qualified (Just PrimBoolean) (ProperName "False") +booleanFalse = Qualified (ByModuleName PrimBoolean) (ProperName "False") -- Prim.Coerce @@ -54,7 +52,7 @@ pattern PrimCoerce :: ModuleName pattern PrimCoerce = ModuleName "Prim.Coerce" pattern Coercible :: Qualified (ProperName 'ClassName) -pattern Coercible = Qualified (Just PrimCoerce) (ProperName "Coercible") +pattern Coercible = Qualified (ByModuleName PrimCoerce) (ProperName "Coercible") -- Prim.Ordering @@ -62,13 +60,13 @@ pattern PrimOrdering :: ModuleName pattern PrimOrdering = ModuleName "Prim.Ordering" orderingLT :: Qualified (ProperName 'TypeName) -orderingLT = Qualified (Just PrimOrdering) (ProperName "LT") +orderingLT = Qualified (ByModuleName PrimOrdering) (ProperName "LT") orderingEQ :: Qualified (ProperName 'TypeName) -orderingEQ = Qualified (Just PrimOrdering) (ProperName "EQ") +orderingEQ = Qualified (ByModuleName PrimOrdering) (ProperName "EQ") orderingGT :: Qualified (ProperName 'TypeName) -orderingGT = Qualified (Just PrimOrdering) (ProperName "GT") +orderingGT = Qualified (ByModuleName PrimOrdering) (ProperName "GT") -- Prim.Row @@ -76,16 +74,16 @@ pattern PrimRow :: ModuleName pattern PrimRow = ModuleName "Prim.Row" pattern RowUnion :: Qualified (ProperName 'ClassName) -pattern RowUnion = Qualified (Just PrimRow) (ProperName "Union") +pattern RowUnion = Qualified (ByModuleName PrimRow) (ProperName "Union") pattern RowNub :: Qualified (ProperName 'ClassName) -pattern RowNub = Qualified (Just PrimRow) (ProperName "Nub") +pattern RowNub = Qualified (ByModuleName PrimRow) (ProperName "Nub") pattern RowCons :: Qualified (ProperName 'ClassName) -pattern RowCons = Qualified (Just PrimRow) (ProperName "Cons") +pattern RowCons = Qualified (ByModuleName PrimRow) (ProperName "Cons") pattern RowLacks :: Qualified (ProperName 'ClassName) -pattern RowLacks = Qualified (Just PrimRow) (ProperName "Lacks") +pattern RowLacks = Qualified (ByModuleName PrimRow) (ProperName "Lacks") -- Prim.RowList @@ -93,13 +91,13 @@ pattern PrimRowList :: ModuleName pattern PrimRowList = ModuleName "Prim.RowList" pattern RowToList :: Qualified (ProperName 'ClassName) -pattern RowToList = Qualified (Just PrimRowList) (ProperName "RowToList") +pattern RowToList = Qualified (ByModuleName PrimRowList) (ProperName "RowToList") pattern RowListNil :: Qualified (ProperName 'TypeName) -pattern RowListNil = Qualified (Just PrimRowList) (ProperName "Nil") +pattern RowListNil = Qualified (ByModuleName PrimRowList) (ProperName "Nil") pattern RowListCons :: Qualified (ProperName 'TypeName) -pattern RowListCons = Qualified (Just PrimRowList) (ProperName "Cons") +pattern RowListCons = Qualified (ByModuleName PrimRowList) (ProperName "Cons") -- Prim.Int @@ -107,16 +105,16 @@ pattern PrimInt :: ModuleName pattern PrimInt = ModuleName "Prim.Int" pattern IntAdd :: Qualified (ProperName 'ClassName) -pattern IntAdd = Qualified (Just PrimInt) (ProperName "Add") +pattern IntAdd = Qualified (ByModuleName PrimInt) (ProperName "Add") pattern IntCompare :: Qualified (ProperName 'ClassName) -pattern IntCompare = Qualified (Just PrimInt) (ProperName "Compare") +pattern IntCompare = Qualified (ByModuleName PrimInt) (ProperName "Compare") pattern IntMul :: Qualified (ProperName 'ClassName) -pattern IntMul = Qualified (Just PrimInt) (ProperName "Mul") +pattern IntMul = Qualified (ByModuleName PrimInt) (ProperName "Mul") pattern IntToString :: Qualified (ProperName 'ClassName) -pattern IntToString = Qualified (Just PrimInt) (ProperName "ToString") +pattern IntToString = Qualified (ByModuleName PrimInt) (ProperName "ToString") -- Prim.Symbol @@ -124,13 +122,13 @@ pattern PrimSymbol :: ModuleName pattern PrimSymbol = ModuleName "Prim.Symbol" pattern SymbolCompare :: Qualified (ProperName 'ClassName) -pattern SymbolCompare = Qualified (Just PrimSymbol) (ProperName "Compare") +pattern SymbolCompare = Qualified (ByModuleName PrimSymbol) (ProperName "Compare") pattern SymbolAppend :: Qualified (ProperName 'ClassName) -pattern SymbolAppend = Qualified (Just PrimSymbol) (ProperName "Append") +pattern SymbolAppend = Qualified (ByModuleName PrimSymbol) (ProperName "Append") pattern SymbolCons :: Qualified (ProperName 'ClassName) -pattern SymbolCons = Qualified (Just PrimSymbol) (ProperName "Cons") +pattern SymbolCons = Qualified (ByModuleName PrimSymbol) (ProperName "Cons") -- Prim.TypeError @@ -138,10 +136,10 @@ pattern PrimTypeError :: ModuleName pattern PrimTypeError = ModuleName "Prim.TypeError" pattern Fail :: Qualified (ProperName 'ClassName) -pattern Fail = Qualified (Just PrimTypeError) (ProperName "Fail") +pattern Fail = Qualified (ByModuleName PrimTypeError) (ProperName "Fail") pattern Warn :: Qualified (ProperName 'ClassName) -pattern Warn = Qualified (Just PrimTypeError) (ProperName "Warn") +pattern Warn = Qualified (ByModuleName PrimTypeError) (ProperName "Warn") primModules :: [ModuleName] primModules = [Prim, PrimBoolean, PrimCoerce, PrimOrdering, PrimRow, PrimRowList, PrimSymbol, PrimInt, PrimTypeError] diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index 83a1beca2e..01a6b76dcc 100644 --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -261,7 +261,7 @@ nullAnn = (nullSourceSpan, [], Nothing, Nothing) replaceLocals :: M.Map Ident (Expr Ann) -> [Bind Ann] -> [Bind Ann] replaceLocals m = if M.null m then identity else map f' where (f', g', _) = everywhereOnValues identity f identity - f e@(Var _ (Qualified Nothing ident)) = maybe e g' $ ident `M.lookup` m + f e@(Var _ (Qualified (BySourcePos _) ident)) = maybe e g' $ ident `M.lookup` m f e = e -- | @@ -280,7 +280,7 @@ floatExpr = \case let w' = w & (if isNew then newBindings %~ addToScope deepestScope [(ident, (_plurality, e))] else identity) & plurality .~ PluralityMap (M.singleton ident False) - pure (Var nullAnn (Qualified Nothing ident), w') + pure (Var nullAnn (Qualified ByNullSourcePos ident), w') (e, w) -> pure (e, w) -- | @@ -331,7 +331,7 @@ summarizeName mn (Qualified mn' ident) = do m <- view bound let (s, bt) = fromMaybe (0, NonRecursive) $ - guard (all (== mn) mn') *> ident `M.lookup` m + guard (all (== mn) (toMaybeModuleName mn')) *> ident `M.lookup` m tell $ mempty & scopesUsed .~ IS.singleton s & noFloatWithin .~ (guard (bt == Recursive) $> Min s) diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 8e6f75c922..37209c6602 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -63,7 +63,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = declToCoreFn :: A.Declaration -> [Bind Ann] declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [ctor]) = [NonRec (ss, [], Nothing, declMeta) (properToIdent $ A.dataCtorName ctor) $ - Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ Qualified Nothing (Ident "x"))] + Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ Qualified ByNullSourcePos (Ident "x"))] where declMeta = isDictTypeName (A.dataCtorName ctor) `orEmpty` IsTypeClassConstructor declToCoreFn d@(A.DataDeclaration _ Newtype _ _ _) = @@ -72,7 +72,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = flip fmap ctors $ \ctorDecl -> let ctor = A.dataCtorName ctorDecl - (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor) + (_, _, _, fields) = lookupConstructor env (Qualified (ByModuleName mn) ctor) in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields declToCoreFn (A.DataBindingGroupDeclaration ds) = concatMap declToCoreFn ds @@ -109,7 +109,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = A.Unused{} -> True _ -> False exprToCoreFn ss com ty (A.Unused _) = - Var (ss, com, ty, Nothing) (Qualified (Just C.Prim) (Ident C.undefined)) + Var (ss, com, ty, Nothing) (Qualified (ByModuleName C.Prim) (Ident C.undefined)) exprToCoreFn _ com ty (A.Var ss ident) = Var (ss, com, ty, getValueMeta ident) ident exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) = @@ -201,7 +201,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = typeConstructor :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) -> (ModuleName, ProperName 'TypeName) - typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) + typeConstructor (Qualified (ByModuleName mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) typeConstructor _ = internalError "Invalid argument to typeConstructor" -- | Find module names from qualified references to values. This is used to diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index b3c2d52fa9..10e6fca0e0 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -9,6 +9,8 @@ module Language.PureScript.CoreFn.FromJSON import Prelude.Compat +import Control.Applicative ((<|>)) + import Data.Aeson import Data.Aeson.Types (Parser, listParser) import qualified Data.Map.Strict as M @@ -17,7 +19,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import Data.Version (Version, parseVersion) -import Language.PureScript.AST.SourcePos (SourceSpan(SourceSpan)) +import Language.PureScript.AST.SourcePos (SourceSpan(..)) import Language.PureScript.AST.Literals import Language.PureScript.CoreFn.Ann import Language.PureScript.CoreFn @@ -111,10 +113,16 @@ properNameFromJSON = fmap ProperName . parseJSON qualifiedFromJSON :: (Text -> a) -> Value -> Parser (Qualified a) qualifiedFromJSON f = withObject "Qualified" qualifiedFromObj where - qualifiedFromObj o = do - mn <- o .:? "moduleName" >>= traverse moduleNameFromJSON + qualifiedFromObj o = + qualifiedByModuleFromObj o <|> qualifiedBySourcePosFromObj o + qualifiedByModuleFromObj o = do + mn <- o .: "moduleName" >>= moduleNameFromJSON + i <- o .: "identifier" >>= withText "Ident" (return . f) + pure $ Qualified (ByModuleName mn) i + qualifiedBySourcePosFromObj o = do + ss <- o .: "sourcePos" i <- o .: "identifier" >>= withText "Ident" (return . f) - return $ Qualified mn i + pure $ Qualified (BySourcePos ss) i moduleNameFromJSON :: Value -> Parser ModuleName moduleNameFromJSON v = ModuleName . T.intercalate "." <$> listParser parseJSON v diff --git a/src/Language/PureScript/CoreFn/Laziness.hs b/src/Language/PureScript/CoreFn/Laziness.hs index fbe7ffb9fb..600fce7316 100644 --- a/src/Language/PureScript/CoreFn/Laziness.hs +++ b/src/Language/PureScript/CoreFn/Laziness.hs @@ -128,7 +128,7 @@ onVarsWithDelayAndForce f = snd . go 0 $ Just 0 Var a i -> f delay force a i Abs a i e -> Abs a i <$> snd (if force == Just 0 then go (succ delay) force else go delay $ fmap pred force) e -- A clumsy hack to preserve TCO in a particular idiom of unsafePartial once seen in Data.Map.Internal, possibly still used elsewhere. - App a1 e1@(Var _ (Qualified (Just C.PartialUnsafe) (Ident up))) (Abs a2 i e2) | up == C.unsafePartial + App a1 e1@(Var _ (Qualified (ByModuleName C.PartialUnsafe) (Ident up))) (Abs a2 i e2) | up == C.unsafePartial -> App a1 e1 . Abs a2 i <$> handleExpr' e2 App a e1 e2 -> -- `handleApp` is just to handle the constructor application exception @@ -433,7 +433,7 @@ applyLazinessTransform mn rawItems = let -- A B (keys) C (keys) D findReferences :: Expr Ann -> IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int))) findReferences = (getConst .) . onVarsWithDelayAndForce $ \delay force _ -> \case - Qualified mn' ident | all (== mn) mn', Just i <- ident `S.lookupIndex` names + Qualified qb ident | all (== mn) (toMaybeModuleName qb), Just i <- ident `S.lookupIndex` names -> Const . IM.singleton delay . IM.singleton i $ coerceForce force _ -> Const IM.empty @@ -517,7 +517,7 @@ applyLazinessTransform mn rawItems = let Nothing -> pair Just m -> let rewriteExpr = (runIdentity .) . onVarsWithDelayAndForce $ \delay _ ann -> pure . \case - Qualified mn' ident' | all (== mn) mn', any (all (>= Max delay) . getAp) $ ident' `M.lookup` m + Qualified qb ident' | all (== mn) (toMaybeModuleName qb), any (all (>= Max delay) . getAp) $ ident' `M.lookup` m -> makeForceCall ann ident' q -> Var ann q in (ident, rewriteExpr <$> item) @@ -532,8 +532,8 @@ applyLazinessTransform mn rawItems = let where nullAnn = ssAnn nullSourceSpan - runtimeLazy = Var nullAnn . Qualified Nothing $ InternalIdent RuntimeLazyFactory - runFn3 = Var nullAnn . Qualified (Just C.DataFunctionUncurried) . Ident $ C.runFn <> "3" + runtimeLazy = Var nullAnn . Qualified ByNullSourcePos $ InternalIdent RuntimeLazyFactory + runFn3 = Var nullAnn . Qualified (ByModuleName C.DataFunctionUncurried) . Ident $ C.runFn <> "3" strLit = Literal nullAnn . StringLiteral . mkString lazifyIdent = \case @@ -546,7 +546,7 @@ applyLazinessTransform mn rawItems = let -- argument: the line number on which this reference is made. The runtime -- code uses this number to generate a message that identifies where the -- evaluation looped. - = App nullAnn (Var nullAnn . Qualified Nothing $ lazifyIdent ident) + = App nullAnn (Var nullAnn . Qualified ByNullSourcePos $ lazifyIdent ident) . Literal nullAnn . NumericLiteral . Left . toInteger . sourcePosLine $ spanStart ss diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index d44f18add9..e74feb2eaa 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -11,7 +11,7 @@ import Language.PureScript.CoreFn.CSE import Language.PureScript.CoreFn.Expr import Language.PureScript.CoreFn.Module import Language.PureScript.CoreFn.Traversals -import Language.PureScript.Names (Ident(..), Qualified(..)) +import Language.PureScript.Names (Ident(..), QualifiedBy(..), Qualified(..)) import Language.PureScript.Label import Language.PureScript.Types import qualified Language.PureScript.Constants.Prelude as C @@ -54,7 +54,7 @@ closedRecordFields _ = Nothing optimizeDataFunctionApply :: Expr a -> Expr a optimizeDataFunctionApply e = case e of - (App a (App _ (Var _ (Qualified (Just C.DataFunction) (Ident fn))) x) y) + (App a (App _ (Var _ (Qualified (ByModuleName C.DataFunction) (Ident fn))) x) y) | fn == C.apply -> App a x y | fn == C.applyFlipped -> App a y x _ -> e diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index bcff76776f..62d1bf0b37 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -21,7 +21,7 @@ import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.AST.Literals -import Language.PureScript.AST.SourcePos (SourceSpan(SourceSpan)) +import Language.PureScript.AST.SourcePos (SourceSpan(..)) import Language.PureScript.CoreFn import Language.PureScript.Names import Language.PureScript.PSString (PSString) @@ -102,10 +102,16 @@ properNameToJSON :: ProperName a -> Value properNameToJSON = toJSON . runProperName qualifiedToJSON :: (a -> Text) -> Qualified a -> Value -qualifiedToJSON f (Qualified mn a) = object - [ "moduleName" .= maybe Null moduleNameToJSON mn - , "identifier" .= toJSON (f a) - ] +qualifiedToJSON f (Qualified qb a) = + case qb of + ByModuleName mn -> object + [ "moduleName" .= moduleNameToJSON mn + , "identifier" .= toJSON (f a) + ] + BySourcePos ss -> object + [ "sourcePos" .= toJSON ss + , "identifier" .= toJSON (f a) + ] moduleNameToJSON :: ModuleName -> Value moduleNameToJSON (ModuleName name) = toJSON (T.splitOn (T.pack ".") name) diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 965b349163..446e10510f 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -84,7 +84,7 @@ insertValueTypesAndAdjustKinds env m = where inferredRoles :: [P.Role] inferredRoles = do - let key = P.Qualified (Just (modName m)) (P.ProperName (declTitle d)) + let key = P.Qualified (P.ByModuleName (modName m)) (P.ProperName (declTitle d)) case Map.lookup key (P.types env) of Just (_, tyKind) -> case tyKind of P.DataType _ tySourceTyRole _ -> @@ -164,7 +164,7 @@ insertValueTypesAndAdjustKinds env m = either (err . ("failed to parse Ident: " ++)) identity . runParser CST.parseIdent lookupName name = - let key = P.Qualified (Just (modName m)) name + let key = P.Qualified (P.ByModuleName (modName m)) name in case Map.lookup key (P.names env) of Just (ty, _, _) -> ty @@ -217,7 +217,7 @@ insertValueTypesAndAdjustKinds env m = insertInferredKind :: Declaration -> Text -> P.KindSignatureFor -> Declaration insertInferredKind d name keyword = let - key = P.Qualified (Just (modName m)) (P.ProperName name) + key = P.Qualified (P.ByModuleName (modName m)) (P.ProperName name) in case Map.lookup key (P.types env) of Just (inferredKind, _) -> if isUninteresting keyword inferredKind' diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index e308c556ef..80e3a3e035 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -512,7 +512,7 @@ typeClassConstraintFor :: Declaration -> Maybe Constraint' typeClassConstraintFor Declaration{..} = case declInfo of TypeClassDeclaration tyArgs _ _ -> - Just (P.Constraint () (P.Qualified Nothing (P.ProperName declTitle)) [] (mkConstraint tyArgs) Nothing) + Just (P.Constraint () (P.Qualified P.ByNullSourcePos (P.ProperName declTitle)) [] (mkConstraint tyArgs) Nothing) _ -> Nothing where diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index ee105a4dc6..1212f0497d 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -123,10 +123,10 @@ renderConstraints constraints (map renderConstraint constraints) notQualified :: Text -> P.Qualified (P.ProperName a) -notQualified = P.Qualified Nothing . P.ProperName +notQualified = P.Qualified P.ByNullSourcePos . P.ProperName ident' :: Text -> RenderedCode -ident' = ident . P.Qualified Nothing . P.Ident +ident' = ident . P.Qualified P.ByNullSourcePos . P.Ident dataCtor' :: Text -> RenderedCode dataCtor' = dataCtor . notQualified diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index c3f37b5201..459260174c 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -117,8 +117,8 @@ maybeToContainingModule Nothing = ThisModule maybeToContainingModule (Just mn) = OtherModule mn fromQualified :: Qualified a -> (ContainingModule, a) -fromQualified (Qualified mn x) = - (maybeToContainingModule mn, x) +fromQualified (Qualified (ByModuleName mn) x) = (OtherModule mn, x) +fromQualified (Qualified _ x) = (ThisModule, x) data Link = NoLink @@ -296,9 +296,9 @@ aliasName for name' = in case ns of ValueLevel -> - ident (Qualified Nothing (Ident name)) + ident (Qualified ByNullSourcePos (Ident name)) TypeLevel -> - typeCtor (Qualified Nothing (ProperName name)) + typeCtor (Qualified ByNullSourcePos (ProperName name)) -- | Converts a FixityAlias into a different representation which is more -- useful to other functions in this module. diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index aa907a30a6..87dd56ecdc 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -37,7 +37,7 @@ data Environment = Environment -- constructor name, argument types and return type. , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType) -- ^ Type synonyms currently in scope - , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) + , typeClassDictionaries :: M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) -- ^ Available type class dictionaries. When looking up 'Nothing' in the -- outer map, this returns the map of type class dictionaries in local -- scope (ie dictionaries brought in by a constrained type). @@ -242,12 +242,12 @@ instance A.FromJSON DataDeclType where -- | Construct a ProperName in the Prim module primName :: Text -> Qualified (ProperName a) -primName = Qualified (Just C.Prim) . ProperName +primName = Qualified (ByModuleName C.Prim) . ProperName -- | Construct a 'ProperName' in the @Prim.NAME@ module. primSubName :: Text -> Text -> Qualified (ProperName a) primSubName sub = - Qualified (Just $ ModuleName $ C.prim <> "." <> sub) . ProperName + Qualified (ByModuleName $ ModuleName $ C.prim <> "." <> sub) . ProperName primKind :: Text -> SourceType primKind = primTy diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 7fb5a5d15d..6b4e5efded 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -741,35 +741,35 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "The role declaration for " <> markCode (runProperName nm) <> " should follow its definition." renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" - renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident i)))) | i `elem` [ C.bind, C.discard ] = + renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident i)))) | i `elem` [ C.bind, C.discard ] = line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode "bind" <> " and " <> markCode "discard" <> " functions. Please import " <> markCode i <> " from module " <> markCode "Prelude" - renderSimpleErrorMessage (UnknownName name@(Qualified Nothing (IdentName (Ident i)))) | i == C.negate = + renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident i)))) | i == C.negate = line $ "Unknown " <> printName name <> ". You're probably using numeric negation (the unary " <> markCode "-" <> " operator), which the compiler replaces with calls to the " <> markCode i <> " function. Please import " <> markCode i <> " from module " <> markCode "Prelude" renderSimpleErrorMessage (UnknownName name) = line $ "Unknown " <> printName name renderSimpleErrorMessage (UnknownImport mn name) = - paras [ line $ "Cannot import " <> printName (Qualified Nothing name) <> " from module " <> markCode (runModuleName mn) + paras [ line $ "Cannot import " <> printName (Qualified ByNullSourcePos name) <> " from module " <> markCode (runModuleName mn) , line "It either does not exist or the module does not export it." ] renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) = line $ "Module " <> runModuleName mn <> " does not export data constructor " <> markCode (runProperName dcon) <> " for type " <> markCode (runProperName tcon) renderSimpleErrorMessage (UnknownExport name) = - line $ "Cannot export unknown " <> printName (Qualified Nothing name) + line $ "Cannot export unknown " <> printName (Qualified ByNullSourcePos name) renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) = line $ "Cannot export data constructor " <> markCode (runProperName dcon) <> " for type " <> markCode (runProperName tcon) <> ", as it has not been declared." renderSimpleErrorMessage (ScopeConflict nm ms) = - paras [ line $ "Conflicting definitions are in scope for " <> printName (Qualified Nothing nm) <> " from the following modules:" + paras [ line $ "Conflicting definitions are in scope for " <> printName (Qualified ByNullSourcePos nm) <> " from the following modules:" , indent $ paras $ map (line . markCode . runModuleName) ms ] renderSimpleErrorMessage (ScopeShadowing nm exmn ms) = - paras [ line $ "Shadowed definitions are in scope for " <> printName (Qualified Nothing nm) <> " from the following open imports:" + paras [ line $ "Shadowed definitions are in scope for " <> printName (Qualified ByNullSourcePos nm) <> " from the following open imports:" , indent $ paras $ map (line . markCode . ("import " <>) . runModuleName) ms , line $ "These will be ignored and the " <> case exmn of Just exmn' -> "declaration from " <> markCode (runModuleName exmn') <> " will be used." Nothing -> "local declaration will be used." ] renderSimpleErrorMessage (DeclConflict new existing) = - line $ "Declaration for " <> printName (Qualified Nothing new) <> " conflicts with an existing " <> nameType existing <> " of the same name." + line $ "Declaration for " <> printName (Qualified ByNullSourcePos new) <> " conflicts with an existing " <> nameType existing <> " of the same name." renderSimpleErrorMessage (ExportConflict new existing) = line $ "Export for " <> printName new <> " conflicts with " <> printName existing renderSimpleErrorMessage (DuplicateModule mn) = @@ -1152,7 +1152,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) = paras [ line $ "The import of module " <> markCode (runModuleName mn) <> " contains the following unused references:" - , indent $ paras $ map (line . markCode . runName . Qualified Nothing) names + , indent $ paras $ map (line . markCode . runName . Qualified ByNullSourcePos) names , line "It could be replaced with:" , indent $ line $ markCode $ showSuggestion msg ] @@ -1176,10 +1176,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl line $ "Duplicate import of " <> markCode (prettyPrintImport name imp qual) renderSimpleErrorMessage (DuplicateImportRef name) = - line $ "Import list contains multiple references to " <> printName (Qualified Nothing name) + line $ "Import list contains multiple references to " <> printName (Qualified ByNullSourcePos name) renderSimpleErrorMessage (DuplicateExportRef name) = - line $ "Export list contains multiple references to " <> printName (Qualified Nothing name) + line $ "Export list contains multiple references to " <> printName (Qualified ByNullSourcePos name) renderSimpleErrorMessage (IntOutOfRange value backend lo hi) = paras [ line $ "Integer value " <> markCode (T.pack (show value)) <> " is out of range for the " <> backend <> " backend." @@ -1596,19 +1596,19 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl nameType (ModName _) = "module" runName :: Qualified Name -> Text - runName (Qualified mn (IdentName name)) = - showQualified showIdent (Qualified mn name) - runName (Qualified mn (ValOpName op)) = - showQualified showOp (Qualified mn op) - runName (Qualified mn (TyName name)) = - showQualified runProperName (Qualified mn name) - runName (Qualified mn (TyOpName op)) = - showQualified showOp (Qualified mn op) - runName (Qualified mn (DctorName name)) = - showQualified runProperName (Qualified mn name) - runName (Qualified mn (TyClassName name)) = - showQualified runProperName (Qualified mn name) - runName (Qualified Nothing (ModName name)) = + runName (Qualified qb (IdentName name)) = + showQualified showIdent (Qualified qb name) + runName (Qualified qb (ValOpName op)) = + showQualified showOp (Qualified qb op) + runName (Qualified qb (TyName name)) = + showQualified runProperName (Qualified qb name) + runName (Qualified qb (TyOpName op)) = + showQualified showOp (Qualified qb op) + runName (Qualified qb (DctorName name)) = + showQualified runProperName (Qualified qb name) + runName (Qualified qb (TyClassName name)) = + showQualified runProperName (Qualified qb name) + runName (Qualified (BySourcePos _) (ModName name)) = runModuleName name runName (Qualified _ ModName{}) = internalError "qualified ModName in runName" @@ -1713,13 +1713,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl prettyInstanceName :: Qualified (Either SourceType Ident) -> Box.Box prettyInstanceName = \case - Qualified maybeMn (Left ty) -> + Qualified qb (Left ty) -> "instance " - Box.<> (case maybeMn of - Just mn -> "in module " + Box.<> (case qb of + ByModuleName mn -> "in module " Box.<> line (markCode $ runModuleName mn) Box.<> " " - Nothing -> Box.nullBox) + _ -> Box.nullBox) Box.<> "with type " Box.<> markCodeBox (prettyType ty) Box.<> " " diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index c10d96c2f4..394f0640cc 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -173,13 +173,13 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) } applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) } applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } - applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } + applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (ByModuleName efModuleName) ident) (ty, External, Defined) (names env) } applyDecl env (EDClass pn args members cs deps tcIsEmpty) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) } applyDecl env (EDInstance className ident vars kinds tys cs ch idx ns ss) = env { typeClassDictionaries = updateMap (updateMap (M.insertWith (<>) (qual ident) (pure dict)) className) - (Just efModuleName) (typeClassDictionaries env) } + (ByModuleName efModuleName) (typeClassDictionaries env) } where dict :: NamedDict dict = TypeClassDictionaryInScope ch idx (qual ident) [] className vars kinds tys cs instTy @@ -193,7 +193,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar UserNamed -> Nothing qual :: a -> Qualified a - qual = Qualified (Just efModuleName) + qual = Qualified (ByModuleName efModuleName) -- | Generate an externs file for all declarations in a module. -- @@ -231,26 +231,26 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration] toExternsDeclaration (TypeRef _ pn dctors) = - case Qualified (Just mn) pn `M.lookup` types env of + case Qualified (ByModuleName mn) pn `M.lookup` types env of Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration" Just (kind, TypeSynonym) - | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ] + | Just (args, synTy) <- Qualified (ByModuleName mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ] Just (kind, ExternData rs) -> [ EDType pn kind (ExternData rs) ] Just (kind, tk@(DataType _ _ tys)) -> EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args | dctor <- fromMaybe (map fst tys) dctors - , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env) + , (dty, _, ty, args) <- maybeToList (Qualified (ByModuleName mn) dctor `M.lookup` dataConstructors env) ] _ -> internalError "toExternsDeclaration: Invalid input" toExternsDeclaration (ValueRef _ ident) - | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env + | Just (ty, _, _) <- Qualified (ByModuleName mn) ident `M.lookup` names env = [ EDValue (lookupRenamedIdent ident) ty ] toExternsDeclaration (TypeClassRef _ className) | let dictName = dictTypeName . coerceProperName $ className - , Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env - , Just (kind, tk) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env - , Just (dictKind, dictData@(DataType _ _ [(dctor, _)])) <- Qualified (Just mn) dictName `M.lookup` types env - , Just (dty, _, ty, args) <- Qualified (Just mn) dctor `M.lookup` dataConstructors env + , Just TypeClassData{..} <- Qualified (ByModuleName mn) className `M.lookup` typeClasses env + , Just (kind, tk) <- Qualified (ByModuleName mn) (coerceProperName className) `M.lookup` types env + , Just (dictKind, dictData@(DataType _ _ [(dctor, _)])) <- Qualified (ByModuleName mn) dictName `M.lookup` types env + , Just (dty, _, ty, args) <- Qualified (ByModuleName mn) dctor `M.lookup` dataConstructors env = [ EDType (coerceProperName className) kind tk , EDType dictName dictKind dictData , EDDataConstructor dctor dty dictName ty args @@ -258,9 +258,9 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF ] toExternsDeclaration (TypeInstanceRef ss' ident ns) = [ EDInstance tcdClassName (lookupRenamedIdent ident) tcdForAll tcdInstanceKinds tcdInstanceTypes tcdDependencies tcdChain tcdIndex ns ss' - | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env)) + | m1 <- maybeToList (M.lookup (ByModuleName mn) (typeClassDictionaries env)) , m2 <- M.elems m1 - , nel <- maybeToList (M.lookup (Qualified (Just mn) ident) m2) + , nel <- maybeToList (M.lookup (Qualified (ByModuleName mn) ident) m2) , TypeClassDictionaryInScope{..} <- NEL.toList nel ] toExternsDeclaration _ = [] diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 56a37a3f3d..ee99948638 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -65,13 +65,13 @@ encodeRebuildErrors = toJSON . map encodeRebuildError . P.runMultipleErrors identCompletion (P.Qualified mn i, ty) = Completion - { complModule = maybe "" P.runModuleName mn + { complModule = maybe "" P.runModuleName $ P.toMaybeModuleName mn , complIdentifier = i , complType = prettyPrintTypeSingleLine ty , complExpandedType = prettyPrintTypeSingleLine ty , complLocation = Nothing , complDocumentation = Nothing - , complExportedFrom = toList mn + , complExportedFrom = toList $ P.toMaybeModuleName mn , complDeclarationType = Nothing } fieldCompletion (label, ty) = diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index fed4dd6579..764b234f5c 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -360,7 +360,7 @@ resolveInstances externs declarations = where extractInstances mn P.EDInstance{..} = case edInstanceClassName of - P.Qualified (Just classModule) className -> + P.Qualified (P.ByModuleName classModule) className -> Just (IdeInstance mn edInstanceName edInstanceTypes @@ -405,14 +405,14 @@ resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) & map discardAnn resolveOperator (IdeDeclValueOperator op) - | (P.Qualified (Just mn) (Left ident)) <- op ^. ideValueOpAlias = + | (P.Qualified (P.ByModuleName mn) (Left ident)) <- op ^. ideValueOpAlias = let t = getDeclarations mn & mapMaybe (preview _IdeDeclValue) & filter (anyOf ideValueIdent (== ident)) & map (view ideValueType) & listToMaybe in IdeDeclValueOperator (op & ideValueOpType .~ t) - | (P.Qualified (Just mn) (Right dtor)) <- op ^. ideValueOpAlias = + | (P.Qualified (P.ByModuleName mn) (Right dtor)) <- op ^. ideValueOpAlias = let t = getDeclarations mn & mapMaybe (preview _IdeDeclDataConstructor) & filter (anyOf ideDtorName (== dtor)) @@ -420,7 +420,7 @@ resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) & listToMaybe in IdeDeclValueOperator (op & ideValueOpType .~ t) resolveOperator (IdeDeclTypeOperator op) - | P.Qualified (Just mn) properName <- op ^. ideTypeOpAlias = + | P.Qualified (P.ByModuleName mn) properName <- op ^. ideTypeOpAlias = let k = getDeclarations mn & mapMaybe (preview _IdeDeclType) & filter (anyOf ideTypeName (== properName)) diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index 0694b6f523..ded282c071 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -67,7 +67,7 @@ directDependants declaration modules mn = Map.mapMaybe (nonEmpty . go) modules go = foldMap isImporting . P.getModuleDeclarations isImporting d = case d of - P.ImportDeclaration _ mn' it qual | mn == mn' -> P.Qualified qual <$> case it of + P.ImportDeclaration _ mn' it qual | mn == mn' -> P.Qualified (P.byMaybeModuleName qual) <$> case it of P.Implicit -> pure declaration P.Explicit refs | any (declaration `matchesRef`) refs -> pure declaration @@ -120,7 +120,7 @@ eligibleModules -> ModuleMap (NonEmpty Search) eligibleModules query@(moduleName, declaration) decls modules = let - searchDefiningModule = P.Qualified Nothing declaration :| [] + searchDefiningModule = P.Qualified P.ByNullSourcePos declaration :| [] in Map.insert moduleName searchDefiningModule $ foldMap (directDependants declaration modules) (moduleName :| findReexportingModules query decls) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index a88534b3e4..fdfe83af71 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -292,7 +292,7 @@ handleKindOf print' typ = do case e of Left errs -> printErrors errs Right (_, env') -> - case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of + case M.lookup (P.Qualified (P.ByModuleName mName) $ P.ProperName "IT") (P.typeSynonyms env') of Just (_, typ') -> do let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName } k = check (snd <$> P.kindOf typ') chk diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index c0ca5c1b53..d0d74bae7c 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -40,14 +40,14 @@ createTemporaryModule exec st val = effModuleName = P.ModuleName "Effect" effImport = (effModuleName, P.Implicit, Just (P.ModuleName "$Effect")) supportImport = (fst (psciInteractivePrint st), P.Implicit, Just (P.ModuleName "$Support")) - eval = P.Var internalSpan (P.Qualified (Just (P.ModuleName "$Support")) (snd (psciInteractivePrint st))) - mainValue = P.App eval (P.Var internalSpan (P.Qualified Nothing (P.Ident "it"))) + eval = P.Var internalSpan (P.Qualified (P.ByModuleName (P.ModuleName "$Support")) (snd (psciInteractivePrint st))) + mainValue = P.App eval (P.Var internalSpan (P.Qualified P.ByNullSourcePos (P.Ident "it"))) itDecl = P.ValueDecl (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val] typeDecl = P.TypeDeclaration (P.TypeDeclarationData (internalSpan, []) (P.Ident "$main") (P.srcTypeApp (P.srcTypeConstructor - (P.Qualified (Just (P.ModuleName "$Effect")) (P.ProperName "Effect"))) + (P.Qualified (P.ByModuleName (P.ModuleName "$Effect")) (P.ProperName "Effect"))) P.srcTypeWildcard)) mainDecl = P.ValueDecl (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 74b538d311..e669cb2825 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -187,7 +187,7 @@ lintUnused (Module modSS _ mn modDecls exports) = goDecl _ = mempty go :: Expr -> (S.Set Ident, MultipleErrors) - go (Var _ (Qualified Nothing v)) = (S.singleton v, mempty) + go (Var _ (Qualified (BySourcePos _) v)) = (S.singleton v, mempty) go (Var _ _) = (S.empty, mempty) go (Let _ ds e) = onDecls ds (go e) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index f78586bbb7..70f720d1c0 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -50,7 +50,7 @@ qualifyName -> ModuleName -> Qualified (ProperName b) -> Qualified (ProperName a) -qualifyName n defmn qn = Qualified (Just mn) n +qualifyName n defmn qn = Qualified (ByModuleName mn) n where (mn, _) = qualify defmn qn diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 6fa297b2c2..9ce8554f36 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -196,7 +196,7 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do _ -> Nothing | isQualifiedWith k q = case importName (head is) of - Qualified (Just mn') name -> Just (mn', Qualified mnq (toName name)) + Qualified (ByModuleName mn') name -> Just (mn', Qualified mnq (toName name)) _ -> internalError "unqualified name in extractByQual" go _ = Nothing diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 94088e28e8..0564aa23da 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -8,6 +8,7 @@ module Language.PureScript.Names where import Prelude.Compat import Codec.Serialise (Serialise) +import Control.Applicative ((<|>)) import Control.Monad.Supply.Class import Control.DeepSeq (NFData) import Data.Functor.Contravariant (contramap) @@ -19,6 +20,8 @@ import Data.Aeson.TH import Data.Text (Text) import qualified Data.Text as T +import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos) + -- | A sum of the possible name types, useful for error and lint messages. data Name = IdentName Ident @@ -199,34 +202,57 @@ moduleNameFromString = ModuleName isBuiltinModuleName :: ModuleName -> Bool isBuiltinModuleName (ModuleName mn) = mn == "Prim" || "Prim." `T.isPrefixOf` mn +data QualifiedBy + = BySourcePos SourcePos + | ByModuleName ModuleName + deriving (Show, Eq, Ord, Generic) + +pattern ByNullSourcePos :: QualifiedBy +pattern ByNullSourcePos = BySourcePos (SourcePos 0 0) + +instance NFData QualifiedBy +instance Serialise QualifiedBy + +isBySourcePos :: QualifiedBy -> Bool +isBySourcePos (BySourcePos _) = True +isBySourcePos _ = False + +byMaybeModuleName :: Maybe ModuleName -> QualifiedBy +byMaybeModuleName (Just mn) = ByModuleName mn +byMaybeModuleName Nothing = ByNullSourcePos + +toMaybeModuleName :: QualifiedBy -> Maybe ModuleName +toMaybeModuleName (ByModuleName mn) = Just mn +toMaybeModuleName (BySourcePos _) = Nothing + -- | -- A qualified name, i.e. a name with an optional module name -- -data Qualified a = Qualified (Maybe ModuleName) a +data Qualified a = Qualified QualifiedBy a deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) instance NFData a => NFData (Qualified a) instance Serialise a => Serialise (Qualified a) showQualified :: (a -> Text) -> Qualified a -> Text -showQualified f (Qualified Nothing a) = f a -showQualified f (Qualified (Just name) a) = runModuleName name <> "." <> f a +showQualified f (Qualified (BySourcePos _) a) = f a +showQualified f (Qualified (ByModuleName name) a) = runModuleName name <> "." <> f a getQual :: Qualified a -> Maybe ModuleName -getQual (Qualified mn _) = mn +getQual (Qualified qb _) = toMaybeModuleName qb -- | -- Provide a default module name, if a name is unqualified -- qualify :: ModuleName -> Qualified a -> (ModuleName, a) -qualify m (Qualified Nothing a) = (m, a) -qualify _ (Qualified (Just m) a) = (m, a) +qualify m (Qualified (BySourcePos _) a) = (m, a) +qualify _ (Qualified (ByModuleName m) a) = (m, a) -- | -- Makes a qualified value from a name and module name. -- mkQualified :: a -> ModuleName -> Qualified a -mkQualified name mn = Qualified (Just mn) name +mkQualified name mn = Qualified (ByModuleName mn) name -- | Remove the module name from a qualified name disqualify :: Qualified a -> a @@ -237,14 +263,14 @@ disqualify (Qualified _ a) = a -- module name. -- disqualifyFor :: Maybe ModuleName -> Qualified a -> Maybe a -disqualifyFor mn (Qualified mn' a) | mn == mn' = Just a +disqualifyFor mn (Qualified qb a) | mn == toMaybeModuleName qb = Just a disqualifyFor _ _ = Nothing -- | -- Checks whether a qualified value is actually qualified with a module reference -- isQualified :: Qualified a -> Bool -isQualified (Qualified Nothing _) = False +isQualified (Qualified (BySourcePos _) _) = False isQualified _ = True -- | @@ -257,9 +283,24 @@ isUnqualified = not . isQualified -- Checks whether a qualified value is qualified with a particular module -- isQualifiedWith :: ModuleName -> Qualified a -> Bool -isQualifiedWith mn (Qualified (Just mn') _) = mn == mn' +isQualifiedWith mn (Qualified (ByModuleName mn') _) = mn == mn' isQualifiedWith _ _ = False +instance ToJSON a => ToJSON (Qualified a) where + toJSON (Qualified qb a) = case qb of + ByModuleName mn -> toJSON2 (mn, a) + BySourcePos ss -> toJSON2 (ss, a) + +instance FromJSON a => FromJSON (Qualified a) where + parseJSON v = byModule <|> bySourcePos + where + byModule = do + (mn, a) <- parseJSON2 v + pure $ Qualified (ByModuleName mn) a + bySourcePos = do + (ss, a) <- parseJSON2 v + pure $ Qualified (BySourcePos ss) a + instance ToJSON ModuleName where toJSON (ModuleName name) = toJSON (T.splitOn "." name) @@ -276,4 +317,3 @@ instance FromJSONKey ModuleName where $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''InternalIdentData) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Ident) -$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''Qualified) \ No newline at end of file diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index d9835bb9a1..cb09c0910f 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -9,7 +9,7 @@ import Control.Monad.State import Data.Functor ((<&>)) import Data.List (find) -import Data.Maybe (fromJust, fromMaybe, isNothing) +import Data.Maybe (fromJust, fromMaybe) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T @@ -172,12 +172,12 @@ renameInValue (Abs ann name v) = newScope $ Abs ann <$> updateScope name <*> renameInValue v renameInValue (App ann v1 v2) = App ann <$> renameInValue v1 <*> renameInValue v2 -renameInValue (Var ann (Qualified mn name)) | isNothing mn || not (isPlainIdent name) = +renameInValue (Var ann (Qualified qb name)) | isBySourcePos qb || not (isPlainIdent name) = -- This should only rename identifiers local to the current module: either -- they aren't qualified, or they are but they have a name that should not -- have appeared in a module's externs, so they must be from this module's -- top-level scope. - Var ann . Qualified mn <$> lookupIdent name + Var ann . Qualified qb <$> lookupIdent name renameInValue v@Var{} = return v renameInValue (Case ann vs alts) = newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs index 5225e1a5b8..dd851f20a2 100644 --- a/src/Language/PureScript/Sugar/AdoNotation.hs +++ b/src/Language/PureScript/Sugar/AdoNotation.hs @@ -28,13 +28,13 @@ desugarAdo d = in rethrowWithPosition ss $ f d where pure' :: SourceSpan -> Maybe ModuleName -> Expr - pure' ss m = Var ss (Qualified m (Ident C.pure')) + pure' ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.pure')) map' :: SourceSpan -> Maybe ModuleName -> Expr - map' ss m = Var ss (Qualified m (Ident C.map)) + map' ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.map)) apply :: SourceSpan -> Maybe ModuleName -> Expr - apply ss m = Var ss (Qualified m (Ident C.apply)) + apply ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.apply)) replace :: SourceSpan -> Expr -> m Expr replace pos (Ado m els yield) = do @@ -53,7 +53,7 @@ desugarAdo d = go ss (yield, args) (DoNotationBind binder val) = do ident <- freshIdent' let abs = Abs (VarBinder ss ident) - (Case [Var ss (Qualified Nothing ident)] + (Case [Var ss (Qualified ByNullSourcePos ident)] [CaseAlternative [binder] [MkUnguarded yield]]) return (abs, val : args) go _ (yield, args) (DoNotationLet ds) = do diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 67f78ce96d..6900b30325 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -145,9 +145,9 @@ usedIdents moduleName = ordNub . usedIdents' S.empty . valdeclExpression (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def usedNamesE :: S.Set ScopedIdent -> Expr -> [Ident] - usedNamesE scope (Var _ (Qualified Nothing name)) + usedNamesE scope (Var _ (Qualified (BySourcePos _) name)) | LocalIdent name `S.notMember` scope = [name] - usedNamesE scope (Var _ (Qualified (Just moduleName') name)) + usedNamesE scope (Var _ (Qualified (ByModuleName moduleName') name)) | moduleName == moduleName' && ToplevelIdent name `S.notMember` scope = [name] usedNamesE _ _ = [] @@ -159,8 +159,8 @@ usedImmediateIdents moduleName = def s _ = (s, []) usedNamesE :: Bool -> Expr -> (Bool, [Ident]) - usedNamesE True (Var _ (Qualified Nothing name)) = (True, [name]) - usedNamesE True (Var _ (Qualified (Just moduleName') name)) + usedNamesE True (Var _ (Qualified (BySourcePos _) name)) = (True, [name]) + usedNamesE True (Var _ (Qualified (ByModuleName moduleName') name)) | moduleName == moduleName' = (True, [name]) usedNamesE True (Abs _ _) = (False, []) usedNamesE scope _ = (scope, []) @@ -175,12 +175,12 @@ usedTypeNames moduleName = go usedNames :: SourceType -> [ProperName 'TypeName] usedNames (ConstrainedType _ con _) = usedConstraint con - usedNames (TypeConstructor _ (Qualified (Just moduleName') name)) + usedNames (TypeConstructor _ (Qualified (ByModuleName moduleName') name)) | moduleName == moduleName' = [name] usedNames _ = [] usedConstraint :: SourceConstraint -> [ProperName 'TypeName] - usedConstraint (Constraint _ (Qualified (Just moduleName') name) _ _ _) + usedConstraint (Constraint _ (Qualified (ByModuleName moduleName') name) _ _ _) | moduleName == moduleName' = [coerceProperName name] usedConstraint _ = [] @@ -248,8 +248,8 @@ toDataBindingGroup (CyclicSCC ds') $ typeSynonymCycles | otherwise = return . DataBindingGroupDeclaration . NEL.fromList $ getDecl <$> ds' where - kindDecl (KindDeclaration sa _ pn _) = [(fst sa, Qualified Nothing pn)] - kindDecl (ExternDataDeclaration sa pn _) = [(fst sa, Qualified Nothing pn)] + kindDecl (KindDeclaration sa _ pn _) = [(fst sa, Qualified ByNullSourcePos pn)] + kindDecl (ExternDataDeclaration sa pn _) = [(fst sa, Qualified ByNullSourcePos pn)] kindDecl _ = [] getDecl (decl, _, _) = decl diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 918287f1e4..bb213bc481 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -64,7 +64,7 @@ desugarGuardedExprs ss (Case scrut alternatives) -- We bind the scrutinee to Vars here to mitigate this case. (scrut', scrut_decls) <- unzip <$> forM scrut (\e -> do scrut_id <- freshIdent' - pure ( Var ss (Qualified Nothing scrut_id) + pure ( Var ss (Qualified ByNullSourcePos scrut_id) , ValueDecl (ss, []) scrut_id Private [] [MkUnguarded e] ) ) @@ -226,7 +226,7 @@ desugarGuardedExprs ss (Case scrut alternatives) = let goto_rem_case :: Expr - goto_rem_case = Var ss (Qualified Nothing rem_case_id) + goto_rem_case = Var ss (Qualified ByNullSourcePos rem_case_id) `App` Literal ss (BooleanLiteral True) alt_fail :: Int -> [CaseAlternative] alt_fail n = [CaseAlternative (replicate n NullBinder) [MkUnguarded goto_rem_case]] @@ -313,7 +313,7 @@ desugarAbs = flip parU f pure (Abs (VarBinder ss i) val) replace (Abs binder val) = do ident <- freshIdent' - return $ Abs (VarBinder nullSourceSpan ident) $ Case [Var nullSourceSpan (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded val]] + return $ Abs (VarBinder nullSourceSpan ident) $ Case [Var nullSourceSpan (Qualified ByNullSourcePos ident)] [CaseAlternative [binder] [MkUnguarded val]] replace other = return other stripPositioned :: Binder -> Binder @@ -381,7 +381,7 @@ makeCaseDeclaration ss ident alternatives = do args <- if allUnique (catMaybes argNames) then mapM argName argNames else replicateM (length argNames) freshIdent' - let vars = map (Var ss . Qualified Nothing) args + let vars = map (Var ss . Qualified ByNullSourcePos) args binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] let value = foldr (Abs . VarBinder ss) (Case vars binders) args diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 1bd74f7f29..902eaa3682 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -30,10 +30,10 @@ desugarDo d = in rethrowWithPosition ss $ f d where bind :: SourceSpan -> Maybe ModuleName -> Expr - bind ss m = Var ss (Qualified m (Ident C.bind)) + bind ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.bind)) discard :: SourceSpan -> Maybe ModuleName -> Expr - discard ss m = Var ss (Qualified m (Ident C.discard)) + discard ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.discard)) replace :: SourceSpan -> Expr -> m Expr replace pos (Do m els) = go pos m els @@ -70,7 +70,7 @@ desugarDo d = return $ App (App (bind pos m) val) (Abs (VarBinder ss ident) rest') _ -> do ident <- freshIdent' - return $ App (App (bind pos m) val) (Abs (VarBinder pos ident) (Case [Var pos (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']])) + return $ App (App (bind pos m) val) (Abs (VarBinder pos ident) (Case [Var pos (Qualified ByNullSourcePos ident)] [CaseAlternative [binder] [MkUnguarded rest']])) go _ _ [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet go pos m (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 5d6137e850..288376be60 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -10,7 +10,7 @@ module Language.PureScript.Sugar.Names ) where import Prelude.Compat -import Protolude (ordNub, sortOn) +import Protolude (ordNub, sortOn, swap, foldl') import Control.Arrow (first, second) import Control.Monad @@ -174,7 +174,7 @@ renameInModule imports (Module modSS coms mn decls exps) = (go, _, _, _, _) = everywhereWithContextOnValuesM - (modSS, []) + (modSS, M.empty) (\(_, bound) d -> (\(bound', d') -> ((declSourceSpan d', bound'), d')) <$> updateDecl bound d) updateValue updateBinder @@ -182,9 +182,9 @@ renameInModule imports (Module modSS coms mn decls exps) = defS updateDecl - :: [Ident] + :: M.Map Ident SourcePos -> Declaration - -> m ([Ident], Declaration) + -> m (M.Map Ident SourcePos, Declaration) updateDecl bound (DataDeclaration sa dtype name args dctors) = fmap (bound,) $ DataDeclaration sa dtype name @@ -218,7 +218,7 @@ renameInModule imports (Module modSS coms mn decls exps) = TypeDeclaration . TypeDeclarationData sa name <$> updateTypesEverywhere ty updateDecl bound (ExternDeclaration sa name ty) = - fmap (name : bound,) $ + fmap (M.insert name (spanStart $ fst sa) bound,) $ ExternDeclaration sa name <$> updateTypesEverywhere ty updateDecl bound (ExternDataDeclaration sa name ki) = @@ -244,22 +244,37 @@ renameInModule imports (Module modSS coms mn decls exps) = return (b, d) updateValue - :: (SourceSpan, [Ident]) + :: (SourceSpan, M.Map Ident SourcePos) -> Expr - -> m ((SourceSpan, [Ident]), Expr) + -> m ((SourceSpan, M.Map Ident SourcePos), Expr) updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((pos', bound), v) updateValue (pos, bound) (Abs (VarBinder ss arg) val') = - return ((pos, arg : bound), Abs (VarBinder ss arg) val') + return ((pos, M.insert arg (spanStart ss) bound), Abs (VarBinder ss arg) val') updateValue (pos, bound) (Let w ds val') = do let args = mapMaybe letBoundVariable ds unless (length (ordNub args) == length args) . throwError . errorMessage' pos $ OverlappingNamesInLet - return ((pos, args ++ bound), Let w ds val') - updateValue (_, bound) (Var ss name'@(Qualified Nothing ident)) | ident `notElem` bound = - ((ss, bound), ) <$> (Var ss <$> updateValueName name' ss) - updateValue (_, bound) (Var ss name'@(Qualified (Just _) _)) = - ((ss, bound), ) <$> (Var ss <$> updateValueName name' ss) + return ((pos, declarationsToMap ds `M.union` bound), Let w ds val') + updateValue (_, bound) (Var ss name'@(Qualified qualifiedBy ident)) = + ((ss, bound), ) <$> case (M.lookup ident bound, qualifiedBy) of + -- bound idents that have yet to be locally qualified. + (Just sourcePos, ByNullSourcePos) -> + pure $ Var ss (Qualified (BySourcePos sourcePos) ident) + -- unbound idents are likely import unqualified imports, so we + -- handle them through updateValueName if they don't exist as a + -- local binding. + (Nothing, ByNullSourcePos) -> + Var ss <$> updateValueName name' ss + -- bound/unbound idents with explicit qualification is still + -- handled through updateValueName, as it fully resolves the + -- ModuleName. + (_, ByModuleName _) -> + Var ss <$> updateValueName name' ss + -- encountering non-null source spans may be a bug in previous + -- desugaring steps or with the AST traversals. + (_, BySourcePos _) -> + internalError "updateValue: ident is locally-qualified by a non-null source position" updateValue (_, bound) (Op ss op) = ((ss, bound), ) <$> (Op ss <$> updateValueOpName op ss) updateValue (_, bound) (Constructor ss name) = @@ -269,9 +284,9 @@ renameInModule imports (Module modSS coms mn decls exps) = updateValue s v = return (s, v) updateBinder - :: (SourceSpan, [Ident]) + :: (SourceSpan, M.Map Ident SourcePos) -> Binder - -> m ((SourceSpan, [Ident]), Binder) + -> m ((SourceSpan, M.Map Ident SourcePos), Binder) updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((pos, bound), v) updateBinder (_, bound) (ConstructorBinder ss name b) = @@ -285,23 +300,38 @@ renameInModule imports (Module modSS coms mn decls exps) = return (s, v) updateCase - :: (SourceSpan, [Ident]) + :: (SourceSpan, M.Map Ident SourcePos) -> CaseAlternative - -> m ((SourceSpan, [Ident]), CaseAlternative) + -> m ((SourceSpan, M.Map Ident SourcePos), CaseAlternative) updateCase (pos, bound) c@(CaseAlternative bs gs) = - return ((pos, concatMap binderNames bs ++ updateGuard gs ++ bound), c) + return ((pos, updateGuard gs `M.union` rUnionMap binderNamesWithSpans' bs `M.union` bound), c) where - updateGuard :: [GuardedExpr] -> [Ident] - updateGuard [] = [] + updateGuard :: [GuardedExpr] -> M.Map Ident SourcePos + updateGuard [] = M.empty updateGuard (GuardedExpr g _ : xs) = - concatMap updatePatGuard g ++ updateGuard xs + updateGuard xs `M.union` rUnionMap updatePatGuard g where - updatePatGuard (PatternGuard b _) = binderNames b - updatePatGuard _ = [] + updatePatGuard (PatternGuard b _) = binderNamesWithSpans' b + updatePatGuard _ = M.empty + + rUnionMap f = foldl' (flip (M.union . f)) M.empty + + binderNamesWithSpans' + = M.fromList + . fmap (second spanStart . swap) + . binderNamesWithSpans letBoundVariable :: Declaration -> Maybe Ident letBoundVariable = fmap valdeclIdent . getValueDeclaration + declarationsToMap :: [Declaration] -> M.Map Ident SourcePos + declarationsToMap = foldl goDTM M.empty + where + goDTM a (ValueDeclaration ValueDeclarationData {..}) = + M.insert valdeclIdent (spanStart $ fst valdeclSourceAnn) a + goDTM a _ = + a + updateTypeArguments :: (Traversable f, Traversable g) => f (a, g SourceType) -> m (f (a, g SourceType)) @@ -382,16 +412,16 @@ renameInModule imports (Module modSS coms mn decls exps) = (mnNew, mnOrig) <- checkImportConflicts pos mn toName options modify $ \usedImports -> M.insertWith (++) mnNew [fmap toName qname] usedImports - return $ Qualified (Just mnOrig) name + return $ Qualified (ByModuleName mnOrig) name -- If the name wasn't found in our imports but was qualified then we need -- to check whether it's a failed import from a "pseudo" module (created -- by qualified importing). If that's not the case, then we just need to -- check it refers to a symbol in another module. - (Nothing, Just mn'') -> + (Nothing, ByModuleName mn'') -> if mn'' `S.member` importedQualModules imports || mn'' `S.member` importedModules imports then throwUnknown - else throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn'' + else throwError . errorMessage . UnknownName . Qualified ByNullSourcePos $ ModName mn'' -- If neither of the above cases are true then it's an undefined or -- unimported symbol. diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 5abcf8f04d..7e2240a040 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -27,7 +27,7 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Function (on) import Data.Foldable (find) import Data.List (groupBy, sortOn, delete) -import Data.Maybe (fromJust, mapMaybe) +import Data.Maybe (mapMaybe) import Safe (headMay) import qualified Data.Map as M import qualified Data.Set as S @@ -229,13 +229,18 @@ mkPrimExports ts cs = , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys cs } where - mkTypeEntry (Qualified mn name) = (name, ([], primExportSource mn)) - mkClassEntry (Qualified mn name) = (name, primExportSource mn) + mkTypeEntry (Qualified (ByModuleName mn) name) = (name, ([], primExportSource mn)) + mkTypeEntry _ = internalError + "mkPrimExports.mkTypeEntry: a name is qualified BySourcePos instead of ByModuleName" + + mkClassEntry (Qualified (ByModuleName mn) name) = (name, primExportSource mn) + mkClassEntry _ = internalError + "mkPrimExports.mkClassEntry: a name is qualified BySourcePos instead of ByModuleName" primExportSource mn = ExportSource { exportSourceImportedFrom = Nothing - , exportSourceDefinedIn = fromJust mn + , exportSourceDefinedIn = mn } -- | Environment which only contains the Prim modules. @@ -458,7 +463,7 @@ throwExportConflict' -> m a throwExportConflict' ss new existing newName existingName = throwError . errorMessage' ss $ - ExportConflict (Qualified (Just new) newName) (Qualified (Just existing) existingName) + ExportConflict (Qualified (ByModuleName new) newName) (Qualified (ByModuleName existing) existingName) -- | -- When reading a value from the imports, check that there are no conflicts in @@ -482,7 +487,7 @@ checkImportConflicts ss currentModule toName xs = in if length groups > 1 then case nonImplicit of - [ImportRecord (Qualified (Just mnNew) _) mnOrig _ _] -> do + [ImportRecord (Qualified (ByModuleName mnNew) _) mnOrig _ _] -> do let warningModule = if mnNew == currentModule then Nothing else Just mnNew ss' = maybe nullSourceSpan importSourceSpan . headMay . filter ((== FromImplicit) . importProvenance) $ xs tell . errorMessage' ss' $ ScopeShadowing name warningModule $ delete mnNew conflictModules @@ -490,7 +495,7 @@ checkImportConflicts ss currentModule toName xs = _ -> throwError . errorMessage' ss $ ScopeConflict name conflictModules else case head byOrig of - ImportRecord (Qualified (Just mnNew) _) mnOrig _ _ -> + ImportRecord (Qualified (ByModuleName mnNew) _) mnOrig _ _ -> return (mnNew, mnOrig) _ -> internalError "checkImportConflicts: ImportRecord should be qualified" diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index cceb94a0d6..1ab7194309 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -170,7 +170,7 @@ resolveExports env ss mn imps exps refs = go :: Qualified (ProperName 'TypeName) -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ExportSource) - go (Qualified (Just mn'') name) = + go (Qualified (ByModuleName mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do exps' <- envModuleExports <$> mn'' `M.lookup` env (dctors', src) <- name `M.lookup` exportedTypes exps' @@ -179,7 +179,7 @@ resolveExports env ss mn imps exps refs = ( (name, relevantDctors `intersect` dctors') , src { exportSourceImportedFrom = Just mn'' } ) - go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports" + go (Qualified _ _) = internalError "Unqualified value in resolveTypeExports" -- Looks up an imported type operator and re-qualifies it with the original -- module it came from. @@ -214,7 +214,7 @@ resolveExports env ss mn imps exps refs = => (Exports -> M.Map a ExportSource) -> Qualified a -> Maybe (a, ExportSource) - resolve f (Qualified (Just mn'') a) = do + resolve f (Qualified (ByModuleName mn'') a) = do exps' <- envModuleExports <$> mn'' `M.lookup` env src <- a `M.lookup` f exps' return (a, src { exportSourceImportedFrom = Just mn'' }) diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index d82745bc37..2d1af437f3 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -69,7 +69,7 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps go ie' (ss, typ, impQual) = do modExports <- maybe - (throwError . errorMessage' ss . UnknownName . Qualified Nothing $ ModName mn) + (throwError . errorMessage' ss . UnknownName . Qualified ByNullSourcePos $ ModName mn) (return . envModuleExports) (mn `M.lookup` env) let impModules = importedModules ie' @@ -221,9 +221,9 @@ resolveImport importModule exps imps impQual = resolveByType updateImports imps' exps' expName name ss prov = let src = maybe (internalError "Invalid state in updateImports") expName (name `M.lookup` exps') - rec = ImportRecord (Qualified (Just importModule) name) (exportSourceDefinedIn src) ss prov + rec = ImportRecord (Qualified (ByModuleName importModule) name) (exportSourceDefinedIn src) ss prov in M.alter (\currNames -> Just $ rec : fromMaybe [] currNames) - (Qualified impQual name) + (Qualified (byMaybeModuleName impQual) name) imps' diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index e0a0613561..34d2c6d287 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -98,4 +98,4 @@ desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d | otherwise = return Nothing argToExpr :: Ident -> Expr - argToExpr = Var nullSourceSpan . Qualified Nothing + argToExpr = Var nullSourceSpan . Qualified ByNullSourcePos diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 1cba3d0bf5..dc8fac9b9b 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -50,7 +50,7 @@ desugarSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts where (f', _, _) = everywhereOnValues id go id - go (UnaryMinus ss' val) = App (Var ss' (Qualified Nothing (Ident C.negate))) val + go (UnaryMinus ss' val) = App (Var ss' (Qualified ByNullSourcePos (Ident C.negate))) val go other = other -- | @@ -252,9 +252,9 @@ removeBinaryNoParens u where err = throwError . errorMessage $ IncorrectAnonymousArgument removeBinaryNoParens (Parens (stripPositionInfo -> BinaryNoParens op l r)) | isAnonymousArgument r = do arg <- freshIdent' - return $ Abs (VarBinder nullSourceSpan arg) $ App (App op l) (Var nullSourceSpan (Qualified Nothing arg)) + return $ Abs (VarBinder nullSourceSpan arg) $ App (App op l) (Var nullSourceSpan (Qualified ByNullSourcePos arg)) | isAnonymousArgument l = do arg <- freshIdent' - return $ Abs (VarBinder nullSourceSpan arg) $ App (App op (Var nullSourceSpan (Qualified Nothing arg))) r + return $ Abs (VarBinder nullSourceSpan arg) $ App (App op (Var nullSourceSpan (Qualified ByNullSourcePos arg))) r removeBinaryNoParens (BinaryNoParens op l r) = return $ App (App op l) r removeBinaryNoParens e = return e @@ -301,7 +301,7 @@ externsFixities ExternsFile{..} = -> Either ValueFixityRecord TypeFixityRecord fromFixity (ExternsFixity assoc prec op name) = Left - ( Qualified (Just efModuleName) op + ( Qualified (ByModuleName efModuleName) op , internalModuleSourceSpan "" , Fixity assoc prec , name @@ -312,7 +312,7 @@ externsFixities ExternsFile{..} = -> Either ValueFixityRecord TypeFixityRecord fromTypeFixity (ExternsTypeFixity assoc prec op name) = Right - ( Qualified (Just efModuleName) op + ( Qualified (ByModuleName efModuleName) op , internalModuleSourceSpan "" , Fixity assoc prec , name @@ -323,9 +323,9 @@ collectFixities (Module _ _ moduleName ds _) = concatMap collect ds where collect :: Declaration -> [Either ValueFixityRecord TypeFixityRecord] collect (ValueFixityDeclaration (ss, _) fixity name op) = - [Left (Qualified (Just moduleName) op, ss, fixity, name)] + [Left (Qualified (ByModuleName moduleName) op, ss, fixity, name)] collect (TypeFixityDeclaration (ss, _) fixity name op) = - [Right (Qualified (Just moduleName) op, ss, fixity, name)] + [Right (Qualified (ByModuleName moduleName) op, ss, fixity, name)] collect _ = [] ensureNoDuplicates @@ -337,7 +337,7 @@ ensureNoDuplicates toError m = go $ sortOn fst m where go [] = return () go [_] = return () - go ((x@(Qualified (Just mn) op), _) : (y, pos) : _) | x == y = + go ((x@(Qualified (ByModuleName mn) op), _) : (y, pos) : _) | x == y = rethrow (addHint (ErrorInModule mn)) $ rethrowWithPosition pos $ throwError . errorMessage $ toError op go (_ : rest) = go rest @@ -459,7 +459,7 @@ checkFixityExports m@(Module ss _ mn ds (Just exps)) = getTypeOpAlias op = listToMaybe (mapMaybe (either (const Nothing) go <=< getFixityDecl) ds) where - go (TypeFixity _ (Qualified (Just mn') ident) op') + go (TypeFixity _ (Qualified (ByModuleName mn') ident) op') | mn == mn' && op == op' = Just ident go _ = Nothing @@ -471,7 +471,7 @@ checkFixityExports m@(Module ss _ mn ds (Just exps)) = getValueOpAlias op = listToMaybe (mapMaybe (either go (const Nothing) <=< getFixityDecl) ds) where - go (ValueFixity _ (Qualified (Just mn') ident) op') + go (ValueFixity _ (Qualified (ByModuleName mn') ident) op') | mn == mn' && op == op' = Just ident go _ = Nothing diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 8c376ffd84..4b1ad466a2 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -100,7 +100,7 @@ desugarModule (Module ss coms name decls (Just exps)) = do constraintName (Constraint _ cName _ _ _) = cName classDeclName :: Declaration -> Qualified (ProperName 'ClassName) - classDeclName (TypeClassDeclaration _ pn _ _ _ _) = Qualified (Just name) pn + classDeclName (TypeClassDeclaration _ pn _ _ _ _) = Qualified (ByModuleName name) pn classDeclName _ = internalError "Expected TypeClassDeclaration" desugarModule _ = internalError "Exports should have been elaborated in name desugaring" @@ -250,7 +250,7 @@ desugarDecl mn exps = go :: (ProperName a -> [DeclarationRef] -> Bool) -> Qualified (ProperName a) -> Bool - isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps + isExported test (Qualified (ByModuleName mn') pn) = mn /= mn' || test pn exps isExported _ _ = internalError "Names should have been qualified in name desugaring" matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool @@ -296,14 +296,14 @@ typeClassMemberToDictionaryAccessor -> Declaration -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarationData sa@(ss, _) ident ty)) = - let className = Qualified (Just mn) name + let className = Qualified (ByModuleName mn) name dictIdent = Ident "dict" dictObjIdent = Ident "v" ctor = ConstructorBinder ss (coerceProperName . dictTypeName <$> className) [VarBinder ss dictObjIdent] - acsr = Accessor (mkString $ runIdent ident) (Var ss (Qualified Nothing dictObjIdent)) + acsr = Accessor (mkString $ runIdent ident) (Var ss (Qualified ByNullSourcePos dictObjIdent)) in ValueDecl sa ident Private [] [MkUnguarded ( - TypedValue False (Abs (VarBinder ss dictIdent) (Case [Var ss $ Qualified Nothing dictIdent] [CaseAlternative [ctor] [MkUnguarded acsr]])) $ + TypedValue False (Abs (VarBinder ss dictIdent) (Case [Var ss $ Qualified ByNullSourcePos dictIdent] [CaseAlternative [ctor] [MkUnguarded acsr]])) $ moveQuantifiersToFront (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty)) )] typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index aa318fcdd0..2b9c8cfafa 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -50,7 +50,7 @@ deriveInstance mn ds decl = binaryWildcardClass :: (Declaration -> [SourceType] -> m ([Declaration], SourceType)) -> m Declaration binaryWildcardClass f = case tys of [ty1, ty2] -> case unwrapTypeConstructor ty1 of - Just (Qualified (Just mn') tyCon, _, args) | mn == mn' -> do + Just (Qualified (ByModuleName mn') tyCon, _, args) | mn == mn' -> do checkIsWildcard ss tyCon ty2 tyConDecl <- findTypeDecl ss tyCon ds (members, ty2') <- f tyConDecl args @@ -84,13 +84,13 @@ deriveGenericRep ss mn tyCon tyConArgs = lamCase x [ CaseAlternative [NullBinder] - (unguarded (App (Var ss DataGenericRep.to) (Var ss' (Qualified Nothing x)))) + (unguarded (App (Var ss DataGenericRep.to) (Var ss' (Qualified ByNullSourcePos x)))) ] , ValueDecl (ss', []) (Ident "from") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] - (unguarded (App (Var ss DataGenericRep.from) (Var ss' (Qualified Nothing x)))) + (unguarded (App (Var ss DataGenericRep.from) (Var ss' (Qualified ByNullSourcePos x)))) ] ] | otherwise = @@ -133,8 +133,8 @@ deriveGenericRep ss mn tyCon tyConArgs = (srcTypeLevelString $ mkString (runProperName ctorName))) ctorTy , CaseAlternative [ ConstructorBinder ss DataGenericRep.Constructor [matchProduct] ] - (unguarded (foldl' App (Constructor ss (Qualified (Just mn) ctorName)) ctorArgs)) - , CaseAlternative [ ConstructorBinder ss (Qualified (Just mn) ctorName) matchCtor ] + (unguarded (foldl' App (Constructor ss (Qualified (ByModuleName mn) ctorName)) ctorArgs)) + , CaseAlternative [ ConstructorBinder ss (Qualified (ByModuleName mn) ctorName) matchCtor ] (unguarded (App (Constructor ss DataGenericRep.Constructor) mkProduct)) ) @@ -157,9 +157,9 @@ deriveGenericRep ss mn tyCon tyConArgs = argName <- freshIdent "arg" pure ( srcTypeApp (srcTypeConstructor DataGenericRep.Argument) arg , ConstructorBinder ss DataGenericRep.Argument [ VarBinder ss argName ] - , Var ss (Qualified Nothing argName) + , Var ss (Qualified (BySourcePos $ spanStart ss) argName) , VarBinder ss argName - , App (Constructor ss DataGenericRep.Argument) (Var ss (Qualified Nothing argName)) + , App (Constructor ss DataGenericRep.Argument) (Var ss (Qualified (BySourcePos $ spanStart ss) argName)) ) underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 33c531da84..e73748e8b4 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -60,7 +60,7 @@ addDataType addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv let mapDataCtor (DataConstructorDeclaration _ ctorName vars) = (ctorName, snd <$> vars) - qualName = Qualified (Just moduleName) name + qualName = Qualified (ByModuleName moduleName) name hasSig = qualName `M.member` types env putEnv $ env { types = M.insert qualName (ctorKind, DataType dtype args (map (mapDataCtor . fst) dctors)) (types env) } unless (hasSig || isDictTypeName name || not (containsForAll ctorKind)) $ do @@ -82,7 +82,7 @@ addDataConstructor moduleName dtype name dctor dctorArgs polyType = do let fields = fst <$> dctorArgs env <- getEnv checkTypeSynonyms polyType - putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } + putEnv $ env { dataConstructors = M.insert (Qualified (ByModuleName moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } checkRoleDeclaration :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) @@ -92,7 +92,7 @@ checkRoleDeclaration checkRoleDeclaration moduleName (RoleDeclarationData (ss, _) name declaredRoles) = do warnAndRethrow (addHint (ErrorInRoleDeclaration name) . addHint (positionedError ss)) $ do env <- getEnv - let qualName = Qualified (Just moduleName) name + let qualName = Qualified (ByModuleName moduleName) name case M.lookup qualName (types env) of Just (kind, DataType dtype args dctors) -> do checkRoleDeclarationArity name declaredRoles (length args) @@ -115,7 +115,7 @@ addTypeSynonym addTypeSynonym moduleName name args ty kind = do env <- getEnv checkTypeSynonyms ty - let qualName = Qualified (Just moduleName) name + let qualName = Qualified (ByModuleName moduleName) name hasSig = qualName `M.member` types env unless (hasSig || not (containsForAll kind)) $ do tell . errorMessage $ MissingKindDeclaration TypeSynonymSig name kind @@ -129,7 +129,7 @@ valueIsNotDefined -> m () valueIsNotDefined moduleName name = do env <- getEnv - case M.lookup (Qualified (Just moduleName) name) (names env) of + case M.lookup (Qualified (ByModuleName moduleName) name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name Nothing -> return () @@ -142,7 +142,7 @@ addValue -> m () addValue moduleName name ty nameKind = do env <- getEnv - putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, nameKind, Defined) (names env) }) + putEnv (env { names = M.insert (Qualified (ByModuleName moduleName) name) (ty, nameKind, Defined) (names env) }) addTypeClass :: forall m @@ -206,7 +206,7 @@ addTypeClass _ qualifiedClassName args implies dependencies ds kind = do addTypeClassDictionaries :: (MonadState CheckState m) - => Maybe ModuleName + => QualifiedBy -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)) -> m () addTypeClassDictionaries mn entries = @@ -318,7 +318,7 @@ typeCheckAll moduleName = traverse go addDataType moduleName dtype name args'' dataCtors ctorKind for_ roleDecls $ checkRoleDeclaration moduleName for_ (zip clss cls_ks) $ \((deps, (sa, pn, _, _, _)), (args', implies', tys', kind)) -> do - let qualifiedClassName = Qualified (Just moduleName) pn + let qualifiedClassName = Qualified (ByModuleName moduleName) pn guardWith (errorMessage (DuplicateTypeClass pn (fst sa))) $ not (M.member qualifiedClassName (typeClasses env)) addTypeClass moduleName qualifiedClassName (fmap Just <$> args') implies' deps tys' kind @@ -343,7 +343,7 @@ typeCheckAll moduleName = traverse go warnAndRethrow (addHint (ErrorInKindDeclaration name) . addHint (positionedError ss)) $ do elabTy <- withFreshSubstitution $ checkKindDeclaration moduleName ty env <- getEnv - putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (elabTy, LocalTypeVariable) (types env) } + putEnv $ env { types = M.insert (Qualified (ByModuleName moduleName) name) (elabTy, LocalTypeVariable) (types env) } return $ KindDeclaration sa kindFor name elabTy go d@(RoleDeclaration rdd) = do checkRoleDeclaration moduleName rdd @@ -382,7 +382,7 @@ typeCheckAll moduleName = traverse go warnAndRethrow (addHint (ErrorInForeignImportData name) . addHint (positionedError ss)) $ do elabKind <- withFreshSubstitution $ checkKindDeclaration moduleName kind env <- getEnv - let qualName = Qualified (Just moduleName) name + let qualName = Qualified (ByModuleName moduleName) name roles = nominalRolesForKind elabKind putEnv $ env { types = M.insert qualName (elabKind, ExternData roles) (types env) } return d @@ -394,16 +394,16 @@ typeCheckAll moduleName = traverse go ty'' <- varIfUnknown unks ty' pure (ty'', kind) checkTypeKind elabTy kind - case M.lookup (Qualified (Just moduleName) name) (names env) of + case M.lookup (Qualified (ByModuleName moduleName) name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name - Nothing -> putEnv (env { names = M.insert (Qualified (Just moduleName) name) (elabTy, External, Defined) (names env) }) + Nothing -> putEnv (env { names = M.insert (Qualified (ByModuleName moduleName) name) (elabTy, External, Defined) (names env) }) return d go d@FixityDeclaration{} = return d go d@ImportDeclaration{} = return d go d@(TypeClassDeclaration sa@(ss, _) pn args implies deps tys) = do warnAndRethrow (addHint (ErrorInTypeClassDeclaration pn) . addHint (positionedError ss)) $ do env <- getEnv - let qualifiedClassName = Qualified (Just moduleName) pn + let qualifiedClassName = Qualified (ByModuleName moduleName) pn guardWith (errorMessage (DuplicateTypeClass pn ss)) $ not (M.member qualifiedClassName (typeClasses env)) (args', implies', tys', kind) <- kindOfClass moduleName (sa, pn, args, implies, tys) @@ -413,7 +413,7 @@ typeCheckAll moduleName = traverse go go d@(TypeInstanceDeclaration sa@(ss, _) ch idx (Right dictName) deps className tys body) = rethrow (addHint (ErrorInInstance className tys) . addHint (positionedError ss)) $ do env <- getEnv - let qualifiedDictName = Qualified (Just moduleName) dictName + let qualifiedDictName = Qualified (ByModuleName moduleName) dictName flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries -> guardWith (errorMessage (DuplicateInstance dictName ss)) $ not (M.member qualifiedDictName dictionaries) @@ -433,7 +433,7 @@ typeCheckAll moduleName = traverse go let dict = TypeClassDictionaryInScope chainId idx qualifiedDictName [] className vars kinds' tys'' (Just deps'') $ if isPlainIdent dictName then Nothing else Just $ srcInstanceType ss vars className tys'' - addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict) + addTypeClassDictionaries (ByModuleName moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict) return d checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [SourceType] -> m () @@ -465,7 +465,7 @@ typeCheckAll moduleName = traverse go -> TypeClassData -> [SourceType] -> S.Set ModuleName - findNonOrphanModules (Qualified (Just mn') _) typeClass tys' = nonOrphanModules + findNonOrphanModules (Qualified (ByModuleName mn') _) typeClass tys' = nonOrphanModules where nonOrphanModules :: S.Set ModuleName nonOrphanModules = S.insert mn' nonOrphanModules' @@ -474,8 +474,8 @@ typeCheckAll moduleName = traverse go typeModule (TypeVar _ _) = Nothing typeModule (TypeLevelString _ _) = Nothing typeModule (TypeLevelInt _ _) = Nothing - typeModule (TypeConstructor _ (Qualified (Just mn'') _)) = Just mn'' - typeModule (TypeConstructor _ (Qualified Nothing _)) = internalError "Unqualified type name in findNonOrphanModules" + typeModule (TypeConstructor _ (Qualified (ByModuleName mn'') _)) = Just mn'' + typeModule (TypeConstructor _ (Qualified (BySourcePos _) _)) = internalError "Unqualified type name in findNonOrphanModules" typeModule (TypeApp _ t1 _) = typeModule t1 typeModule (KindApp _ t1 _) = typeModule t1 typeModule (KindedType _ t1 _) = typeModule t1 @@ -515,7 +515,7 @@ typeCheckAll moduleName = traverse go -> m () checkOverlappingInstance ss ch dictName vars className typeClass tys' nonOrphanModules = do for_ nonOrphanModules $ \m -> do - dicts <- M.toList <$> lookupTypeClassDictionariesForClass (Just m) className + dicts <- M.toList <$> lookupTypeClassDictionariesForClass (ByModuleName m) className for_ dicts $ \(Qualified mn' ident, dictNel) -> do for_ dictNel $ \dict -> do @@ -529,7 +529,7 @@ typeCheckAll moduleName = traverse go throwError . errorMessage $ OverlappingInstances className tys' - [that, Qualified (Just moduleName) this] + [that, Qualified (ByModuleName moduleName) this] instancesAreApart :: S.Set (S.Set Int) @@ -649,13 +649,13 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = ImportDeclaration sa moduleName importDeclarationType asModuleName qualify' :: a -> Qualified a - qualify' = Qualified (Just mn) + qualify' = Qualified (ByModuleName mn) getSuperClassExportCheck = do classesToSuperClasses <- gets ( M.map ( S.fromList - . filter (\(Qualified mn' _) -> mn' == Just mn) + . filter (\(Qualified mn' _) -> mn' == ByModuleName mn) . fmap constraintClass . typeClassSuperclasses ) @@ -692,7 +692,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = for_ (M.lookup (qualify' name) (types env)) $ \(k, _) -> do -- TODO: remove? -- let findModuleKinds = everythingOnTypes (++) $ \case - -- TypeConstructor _ (Qualified (Just mn') kindName) | mn' == mn -> [kindName] + -- TypeConstructor _ (Qualified (ByModuleName mn') kindName) | mn' == mn -> [kindName] -- _ -> [] checkExport dr (extract k) for_ (M.lookup (qualify' name) (typeSynonyms env)) $ \(_, ty) -> @@ -751,7 +751,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = findTcons :: SourceType -> [DeclarationRef] findTcons = everythingOnTypes (++) go where - go (TypeConstructor _ (Qualified (Just mn') name)) | mn' == mn = + go (TypeConstructor _ (Qualified (ByModuleName mn') name)) | mn' == mn = [TypeRef (declRefSourceSpan ref) name (internalError "Data constructors unused in checkTypesAreExported")] go _ = [] @@ -766,7 +766,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = go (ConstrainedType _ c _) = (fmap (TypeClassRef (declRefSourceSpan ref)) . extractCurrentModuleClass . constraintClass) c go _ = [] extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> [ProperName 'ClassName] - extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = [name] + extractCurrentModuleClass (Qualified (ByModuleName mn') name) | mn == mn' = [name] extractCurrentModuleClass _ = [] checkClassMembersAreExported :: DeclarationRef -> m () @@ -794,7 +794,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = ] $ \className -> do env <- getEnv let dicts = foldMap (foldMap NEL.toList) $ - M.lookup (Just mn) (typeClassDictionaries env) >>= M.lookup className + M.lookup (ByModuleName mn) (typeClassDictionaries env) >>= M.lookup className when (any isDictOfTypeRef dicts) $ tell . errorMessage' ss' $ HiddenConstructors dr className | otherwise = do @@ -808,7 +808,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = isDictOfTypeRef :: TypeClassDictionaryInScope a -> Bool isDictOfTypeRef dict | (TypeConstructor _ qualTyName, _, _) : _ <- unapplyTypes <$> tcdInstanceTypes dict - , qualTyName == Qualified (Just mn) name + , qualTyName == Qualified (ByModuleName mn) name = True isDictOfTypeRef _ = False getDataConstructorNames :: TypeKind -> Maybe [ProperName 'ConstructorName] diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index dfb8b8bdb1..a24f97616e 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -60,7 +60,7 @@ deriveInstance instType className strategy = do unaryClass :: (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]) -> m Expr unaryClass f = case tys of [ty] -> case unwrapTypeConstructor ty of - Just (Qualified (Just mn') tyCon, _, _) | mn == mn' -> do + Just (Qualified (ByModuleName mn') tyCon, _, _) | mn == mn' -> do let superclassesDicts = flip map typeClassSuperclasses $ \(Constraint _ superclass _ suTyArgs _) -> let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs in lam UnusedIdent (DeferredDictionary superclass tyArgs) @@ -81,7 +81,7 @@ deriveInstance instType className strategy = do NewtypeStrategy -> case tys of - _ : _ | Just (Qualified (Just mn') tyCon, kargs, args) <- unwrapTypeConstructor (last tys) + _ : _ | Just (Qualified (ByModuleName mn') tyCon, kargs, args) <- unwrapTypeConstructor (last tys) , mn == mn' -> deriveNewtypeInstance mn className tys tyCon kargs args | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys (last tys) @@ -164,12 +164,12 @@ deriveNewtypeInstance mn className tys tyConNm dkargs dargs = do -- newtype-derived; see #3168. The whole verifySuperclasses feature -- is pretty sketchy, and could use a thorough review and probably rewrite. hasNewtypeSuperclassInstance (suModule, suClass) nt@(newtypeModule, _) dicts = - let su = Qualified (Just suModule) suClass + let su = Qualified (ByModuleName suModule) suClass lookIn mn' = elem nt . (toList . extractNewtypeName mn' . tcdInstanceTypes <=< foldMap toList . M.elems - <=< toList . (M.lookup su <=< M.lookup (Just mn'))) + <=< toList . (M.lookup su <=< M.lookup (ByModuleName mn'))) $ dicts in lookIn suModule || lookIn newtypeModule @@ -332,11 +332,11 @@ lookupTypeDecl lookupTypeDecl mn typeName = do env <- getEnv note (errorMessage $ CannotFindDerivingType typeName) $ do - (kind, DataType _ args dctors) <- Qualified (Just mn) typeName `M.lookup` types env + (kind, DataType _ args dctors) <- Qualified (ByModuleName mn) typeName `M.lookup` types env (kargs, _) <- completeBinderList kind let dtype = do (ctorName, _) <- headMay dctors - (a, _, _, _) <- Qualified (Just mn) ctorName `M.lookup` dataConstructors env + (a, _, _, _) <- Qualified (ByModuleName mn) ctorName `M.lookup` dataConstructors env pure a pure (dtype, fst . snd <$> kargs, map (\(v, k, _) -> (v, k)) args, dctors) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 83d346d0b4..c93d4d5aa9 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -90,7 +90,7 @@ namedInstanceIdentifier _ = Nothing type TypeClassDict = TypeClassDictionaryInScope Evidence -- | The 'InstanceContext' tracks those constraints which can be satisfied. -type InstanceContext = M.Map (Maybe ModuleName) +type InstanceContext = M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NonEmpty NamedDict))) @@ -198,7 +198,7 @@ entails SolverOptions{..} constraint context hints = forClassName _ ctx cn@C.Warn _ [msg] = -- Prefer a warning dictionary in scope if there is one available. -- This allows us to defer a warning by propagating the constraint. - findDicts ctx cn Nothing ++ [TypeClassDictionaryInScope Nothing 0 (WarnInstance msg) [] C.Warn [] [] [msg] Nothing Nothing] + findDicts ctx cn ByNullSourcePos ++ [TypeClassDictionaryInScope Nothing 0 (WarnInstance msg) [] C.Warn [] [] [msg] Nothing Nothing] forClassName _ _ C.IsSymbol _ args | Just dicts <- solveIsSymbol args = dicts forClassName _ _ C.SymbolCompare _ args | Just dicts <- solveSymbolCompare args = dicts forClassName _ _ C.SymbolAppend _ args | Just dicts <- solveSymbolAppend args = dicts @@ -213,22 +213,22 @@ entails SolverOptions{..} constraint context hints = forClassName _ _ C.RowLacks kinds args | Just dicts <- solveLacks kinds args = dicts forClassName _ _ C.RowCons kinds args | Just dicts <- solveRowCons kinds args = dicts forClassName _ _ C.RowToList kinds args | Just dicts <- solveRowToList kinds args = dicts - forClassName _ ctx cn@(Qualified (Just mn) _) _ tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) + forClassName _ ctx cn@(Qualified (ByModuleName mn) _) _ tys = concatMap (findDicts ctx cn) (ordNub (ByNullSourcePos : ByModuleName mn : map ByModuleName (mapMaybe ctorModules tys))) forClassName _ _ _ _ _ = internalError "forClassName: expected qualified class name" ctorModules :: SourceType -> Maybe ModuleName - ctorModules (TypeConstructor _ (Qualified (Just mn) _)) = Just mn - ctorModules (TypeConstructor _ (Qualified Nothing _)) = internalError "ctorModules: unqualified type name" + ctorModules (TypeConstructor _ (Qualified (ByModuleName mn) _)) = Just mn + ctorModules (TypeConstructor _ (Qualified (BySourcePos _) _)) = internalError "ctorModules: unqualified type name" ctorModules (TypeApp _ ty _) = ctorModules ty ctorModules (KindApp _ ty _) = ctorModules ty ctorModules (KindedType _ ty _) = ctorModules ty ctorModules _ = Nothing - findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDict] + findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> QualifiedBy -> [TypeClassDict] findDicts ctx cn = fmap (fmap NamedInstance) . foldMap NEL.toList . foldMap M.elems . (>>= M.lookup cn) . flip M.lookup ctx valUndefined :: Expr - valUndefined = Var nullSourceSpan (Qualified (Just C.Prim) (Ident C.undefined)) + valUndefined = Var nullSourceSpan (Qualified (ByModuleName C.Prim) (Ident C.undefined)) solve :: SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr solve = go 0 hints @@ -306,7 +306,7 @@ entails SolverOptions{..} constraint context hints = Unsolved unsolved -> do -- Generate a fresh name for the unsolved constraint's new dictionary ident <- freshIdent ("dict" <> runProperName (disqualify (constraintClass unsolved))) - let qident = Qualified Nothing ident + let qident = Qualified ByNullSourcePos ident -- Store the new dictionary in the InstanceContext so that we can solve this goal in -- future. newDicts <- lift . lift $ newDictionaries [] qident unsolved @@ -371,7 +371,7 @@ entails SolverOptions{..} constraint context hints = tcdToInstanceDescription TypeClassDictionaryInScope{ tcdDescription, tcdValue } = let nii = namedInstanceIdentifier tcdValue in case tcdDescription of - Just ty -> flip Qualified (Left ty) <$> fmap getQual nii + Just ty -> flip Qualified (Left ty) <$> fmap (byMaybeModuleName . getQual) nii Nothing -> fmap Right <$> nii canBeGeneralized :: Type a -> Bool @@ -432,7 +432,7 @@ entails SolverOptions{..} constraint context hints = solveCoercible :: Environment -> InstanceContext -> [SourceType] -> [SourceType] -> m (Maybe [TypeClassDict]) solveCoercible env ctx kinds [a, b] = do - let coercibleDictsInScope = findDicts ctx C.Coercible Nothing + let coercibleDictsInScope = findDicts ctx C.Coercible ByNullSourcePos givens = flip mapMaybe coercibleDictsInScope $ \case dict | [a', b'] <- tcdInstanceTypes dict -> Just (a', b') | otherwise -> Nothing @@ -560,7 +560,7 @@ entails SolverOptions{..} constraint context hints = args' = [arg0, arg1, srcTypeConstructor ordering] in pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.IntCompare [] [] args' Nothing Nothing] solveIntCompare ctx args@[a, b, _] = do - let compareDictsInScope = findDicts ctx C.IntCompare Nothing + let compareDictsInScope = findDicts ctx C.IntCompare ByNullSourcePos givens = flip mapMaybe compareDictsInScope $ \case dict | [a', b', c'] <- tcdInstanceTypes dict -> mkRelation a' b' c' | otherwise -> Nothing @@ -847,7 +847,7 @@ newDictionaries path name (Constraint _ className instanceKinds instanceTy _) = mkContext :: [NamedDict] -> InstanceContext mkContext = foldr combineContexts M.empty . map fromDict where - fromDict d = M.singleton Nothing (M.singleton (tcdClassName d) (M.singleton (tcdValue d) (pure d))) + fromDict d = M.singleton ByNullSourcePos (M.singleton (tcdClassName d) (M.singleton (tcdValue d) (pure d))) -- | Check all pairs of values in a list match a predicate pairwiseAll :: Monoid m => (a -> a -> m) -> [a] -> m diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index ba06ea55c7..6f68bb5570 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -690,11 +690,11 @@ lookupNewtypeConstructorInScope env currentModuleName currentModuleImports quali let fromModule = find isNewtypeCtorImported currentModuleImports fromModuleName = (\(_, n, _, _, _) -> n) <$> fromModule asModuleName = (\(_, _, _, n, _) -> n) =<< fromModule - isDefinedInCurrentModule = newtypeModuleName == currentModuleName + isDefinedInCurrentModule = toMaybeModuleName newtypeModuleName == currentModuleName isImported = isJust fromModule inScope = isDefinedInCurrentModule || isImported (tvs, ctorName, wrappedTy) <- lookupNewtypeConstructor env qualifiedNewtypeName ks - pure (inScope, fromModuleName, tvs, Qualified asModuleName ctorName, wrappedTy) + pure (inScope, fromModuleName, tvs, Qualified (byMaybeModuleName asModuleName) ctorName, wrappedTy) where isNewtypeCtorImported (_, _, importDeclType, _, exportedTypes) = case M.lookup newtypeName exportedTypes of diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 9066455ca9..11e5483172 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -189,7 +189,7 @@ inferKind = \tyToInfer -> pure (ty, E.tyInt $> ann) ty@(TypeVar ann v) -> do moduleName <- unsafeCheckCurrentModule - kind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing $ ProperName v) + kind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ ProperName v) pure (ty, kind $> ann) ty@(Skolem ann _ mbK _ _) -> do kind <- apply $ fromMaybe (internalError "Skolem has no kind") mbK @@ -528,7 +528,7 @@ elaborateKind = \case ($> ann) <$> apply kind TypeVar ann a -> do moduleName <- unsafeCheckCurrentModule - kind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing $ ProperName a) + kind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ ProperName a) pure (kind $> ann) (Skolem ann _ mbK _ _) -> do kind <- apply $ fromMaybe (internalError "Skolem has no kind") mbK @@ -640,7 +640,7 @@ inferDataDeclaration -> DataDeclarationArgs -> m [(DataConstructorDeclaration, SourceType)] inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do - tyKind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing tyName) + tyKind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos tyName) let (sigBinders, tyKind') = fromJust . completeBinderList $ tyKind bindLocalTypeVariables moduleName (first ProperName . snd <$> sigBinders) $ do tyArgs' <- for tyArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< checkIsSaturatedType @@ -691,7 +691,7 @@ inferTypeSynonym -> TypeDeclarationArgs -> m SourceType inferTypeSynonym moduleName (ann, tyName, tyArgs, tyBody) = do - tyKind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing tyName) + tyKind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos tyName) let (sigBinders, tyKind') = fromJust . completeBinderList $ tyKind bindLocalTypeVariables moduleName (first ProperName . snd <$> sigBinders) $ do kindRes <- freshKind (fst ann) @@ -808,7 +808,7 @@ inferClassDeclaration -> ClassDeclarationArgs -> m ([(Text, SourceType)], [SourceConstraint], [Declaration]) inferClassDeclaration moduleName (ann, clsName, clsArgs, superClasses, decls) = do - clsKind <- apply =<< lookupTypeVariable moduleName (Qualified Nothing $ coerceProperName clsName) + clsKind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ coerceProperName clsName) let (sigBinders, clsKind') = fromJust . completeBinderList $ clsKind bindLocalTypeVariables moduleName (first ProperName . snd <$> sigBinders) $ do clsArgs' <- for clsArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< checkIsSaturatedType @@ -939,7 +939,7 @@ existingSignatureOrFreshKind -> m SourceType existingSignatureOrFreshKind moduleName ss name = do env <- getEnv - case M.lookup (Qualified (Just moduleName) name) (E.types env) of + case M.lookup (Qualified (ByModuleName moduleName) name) (E.types env) of Nothing -> freshKind ss Just (kind, _) -> pure kind diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index b4fafa9fa8..2b591e5020 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -149,9 +149,9 @@ withScopedTypeVars withScopedTypeVars mn ks ma = do orig <- get forM_ ks $ \(name, _) -> - when (Qualified (Just mn) (ProperName name) `M.member` types (checkEnv orig)) $ + when (Qualified (ByModuleName mn) (ProperName name) `M.member` types (checkEnv orig)) $ tell . errorMessage $ ShadowedTypeVar name - bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma + bindTypes (M.fromList (map (\(name, k) -> (Qualified (ByModuleName mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma withErrorMessageHint :: (MonadState CheckState m, MonadError MultipleErrors m) @@ -196,8 +196,8 @@ withTypeClassDictionaries entries action = do let mentries = M.fromListWith (M.unionWith (M.unionWith (<>))) - [ (mn, M.singleton className (M.singleton (tcdValue entry) (pure entry))) - | entry@TypeClassDictionaryInScope{ tcdValue = Qualified mn _, tcdClassName = className } + [ (qb, M.singleton className (M.singleton tcdValue (pure entry))) + | entry@TypeClassDictionaryInScope{ tcdValue = tcdValue@(Qualified qb _), tcdClassName = className } <- entries ] @@ -209,20 +209,20 @@ withTypeClassDictionaries entries action = do -- | Get the currently available map of type class dictionaries getTypeClassDictionaries :: (MonadState CheckState m) - => m (M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))) + => m (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))) getTypeClassDictionaries = gets $ typeClassDictionaries . checkEnv -- | Lookup type class dictionaries in a module. lookupTypeClassDictionaries :: (MonadState CheckState m) - => Maybe ModuleName + => QualifiedBy -> m (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) lookupTypeClassDictionaries mn = gets $ fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv -- | Lookup type class dictionaries in a module. lookupTypeClassDictionariesForClass :: (MonadState CheckState m) - => Maybe ModuleName + => QualifiedBy -> Qualified (ProperName 'ClassName) -> m (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)) lookupTypeClassDictionariesForClass mn cn = fromMaybe M.empty . M.lookup cn <$> lookupTypeClassDictionaries mn @@ -230,11 +230,11 @@ lookupTypeClassDictionariesForClass mn cn = fromMaybe M.empty . M.lookup cn <$> -- | Temporarily bind a collection of names to local variables bindLocalVariables :: (MonadState CheckState m) - => [(Ident, SourceType, NameVisibility)] + => [(SourceSpan, Ident, SourceType, NameVisibility)] -> m a -> m a bindLocalVariables bindings = - bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> (Qualified Nothing name, (ty, Private, visibility))) + bindNames (M.fromList $ flip map bindings $ \(ss, name, ty, visibility) -> (Qualified (BySourcePos $ spanStart ss) name, (ty, Private, visibility))) -- | Temporarily bind a collection of names to local type variables bindLocalTypeVariables @@ -244,7 +244,7 @@ bindLocalTypeVariables -> m a -> m a bindLocalTypeVariables moduleName bindings = - bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable))) + bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (ByModuleName moduleName) pn, (kind, LocalTypeVariable))) -- | Update the visibility of all names to Defined makeBindingGroupVisible :: (MonadState CheckState m) => m () @@ -301,11 +301,15 @@ lookupTypeVariable => ModuleName -> Qualified (ProperName 'TypeName) -> m SourceType -lookupTypeVariable currentModule (Qualified moduleName name) = do +lookupTypeVariable currentModule (Qualified qb name) = do env <- getEnv - case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of + case M.lookup (Qualified qb' name) (types env) of Nothing -> throwError . errorMessage $ UndefinedTypeVariable name Just (k, _) -> return k + where + qb' = ByModuleName $ case qb of + ByModuleName m -> m + BySourcePos _ -> currentModule -- | Get the current @Environment@ getEnv :: (MonadState CheckState m) => m Environment @@ -315,7 +319,7 @@ getEnv = gets checkEnv getLocalContext :: MonadState CheckState m => m Context getLocalContext = do env <- getEnv - return [ (ident, ty') | (Qualified Nothing ident@Ident{}, (ty', _, Defined)) <- M.toList (names env) ] + return [ (ident, ty') | (Qualified (BySourcePos _) ident@Ident{}, (ty', _, Defined)) <- M.toList (names env) ] -- | Update the @Environment@ putEnv :: (MonadState CheckState m) => Environment -> m () @@ -440,7 +444,7 @@ debugTypeClassDictionaries = go . typeClassDictionaries (className, instances) <- M.toList classes (ident, dicts) <- M.toList instances let - moduleName = maybe "" (\m -> "[" <> runModuleName m <> "] ") mbModuleName + moduleName = maybe "" (\m -> "[" <> runModuleName m <> "] ") (toMaybeModuleName mbModuleName) className' = showQualified runProperName className ident' = showQualified runIdent ident kds = unwords $ fmap ((\a -> "@(" <> a <> ")") . debugType) $ tcdInstanceKinds $ NEL.head dicts diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index 4366afb2f1..a34cc0dbcb 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -140,12 +140,12 @@ inferDataBindingGroupRoles -> [(Text, Maybe SourceType)] -> [Role] inferDataBindingGroupRoles env moduleName roleDeclarations group = - let declaredRoleEnv = M.fromList $ map (Qualified (Just moduleName) . rdeclIdent &&& rdeclRoles) roleDeclarations + let declaredRoleEnv = M.fromList $ map (Qualified (ByModuleName moduleName) . rdeclIdent &&& rdeclRoles) roleDeclarations inferredRoleEnv = getRoleEnv env initialRoleEnv = declaredRoleEnv `M.union` inferredRoleEnv inferredRoleEnv' = inferDataBindingGroupRoles' moduleName group initialRoleEnv in \tyName tyArgs -> - let qualTyName = Qualified (Just moduleName) tyName + let qualTyName = Qualified (ByModuleName moduleName) tyName inferredRoles = M.lookup qualTyName inferredRoleEnv' in fromMaybe (Phantom <$ tyArgs) inferredRoles @@ -177,7 +177,7 @@ inferDataDeclarationRoles -> RoleEnv -> (Any, RoleEnv) inferDataDeclarationRoles moduleName (tyName, tyArgs, ctors) roleEnv = - let qualTyName = Qualified (Just moduleName) tyName + let qualTyName = Qualified (ByModuleName moduleName) tyName ctorRoles = getRoleMap . foldMap (walk mempty . snd) $ ctors >>= dataCtorFields inferredRoles = map (\(arg, _) -> fromMaybe Phantom (M.lookup arg ctorRoles)) tyArgs in updateRoleEnv qualTyName inferredRoles roleEnv diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index 95b9be56d2..6a8afa685c 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -59,7 +59,7 @@ checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do userT' <- initializeSkolems userT envT' <- initializeSkolems envT - let dummyExpression = P.Var nullSourceSpan (P.Qualified Nothing (P.Ident "x")) + let dummyExpression = P.Var nullSourceSpan (P.Qualified P.ByNullSourcePos (P.Ident "x")) elab <- subsumes envT' userT' subst <- gets TC.checkSubstitution @@ -127,7 +127,7 @@ typeSearch unsolved env st type' = runPlainIdent (Qualified m (Ident k), v) = Just (Qualified m k, v) runPlainIdent _ = Nothing in - ( (first (P.Qualified Nothing . ("_." <>) . P.prettyPrintLabel) <$> matchingLabels) + ( (first (P.Qualified P.ByNullSourcePos . ("_." <>) . P.prettyPrintLabel) <$> matchingLabels) <> mapMaybe runPlainIdent (Map.toList matchingNames) <> (first (map P.runProperName) <$> Map.toList matchingConstructors) , if null allLabels then Nothing else Just allLabels) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 83958949fb..59c73e66e8 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -266,8 +266,8 @@ typeDictionaryForBindingGroup moduleName vals = do return ((sai, ty), (sai, (expr, ty))) -- Create the dictionary of all name/type pairs, which will be added to the -- environment during type checking - let dict = M.fromList [ (Qualified moduleName ident, (ty, Private, Undefined)) - | ((_, ident), ty) <- typedDict <> untypedDict + let dict = M.fromList [ (Qualified (maybe (BySourcePos $ spanStart ss) ByModuleName moduleName) ident, (ty, Private, Undefined)) + | (((ss, _), ident), ty) <- typedDict <> untypedDict ] return (SplitBindingGroup untyped' typed' dict) where @@ -409,7 +409,7 @@ infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val pro infer' (Abs binder ret) | VarBinder ss arg <- binder = do ty <- freshTypeWithKind kindType - withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do + withBindingGroupVisible $ bindLocalVariables [(ss, arg, ty, Defined)] $ do body@(TypedValue' _ _ bodyTy) <- infer' ret (body', bodyTy') <- instantiatePolyTypeWithUnknowns (tvToExpr body) bodyTy return $ TypedValue' True (Abs (VarBinder ss arg) body') (function ty bodyTy') @@ -487,20 +487,20 @@ inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (Typed TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do ((args, elabTy), kind) <- kindOfWithScopedVars ty checkTypeKind ty kind - let dict = M.singleton (Qualified Nothing ident) (elabTy, nameKind, Undefined) + let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (elabTy, nameKind, Undefined) ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return (TypedValue' checkType val elabTy) - bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) + bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = do valTy <- freshTypeWithKind kindType TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do - let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined) + let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) bindNames dict $ infer val warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' - bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) + bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do moduleName <- unsafeCheckCurrentModule @@ -519,14 +519,14 @@ inferBinder . (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => SourceType -> Binder - -> m (M.Map Ident SourceType) + -> m (M.Map Ident (SourceSpan, SourceType)) inferBinder _ NullBinder = return M.empty inferBinder val (LiteralBinder _ (StringLiteral _)) = unifyTypes val tyString >> return M.empty inferBinder val (LiteralBinder _ (CharLiteral _)) = unifyTypes val tyChar >> return M.empty inferBinder val (LiteralBinder _ (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty inferBinder val (LiteralBinder _ (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty inferBinder val (LiteralBinder _ (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty -inferBinder val (VarBinder _ name) = return $ M.singleton name val +inferBinder val (VarBinder ss name) = return $ M.singleton name (ss, val) inferBinder val (ConstructorBinder ss ctor binders) = do env <- getEnv case M.lookup ctor (dataConstructors env) of @@ -553,7 +553,7 @@ inferBinder val (LiteralBinder _ (ObjectLiteral props)) = do unifyTypes val (srcTypeApp tyRecord row) return m1 where - inferRowProperties :: SourceType -> SourceType -> [(PSString, Binder)] -> m (M.Map Ident SourceType) + inferRowProperties :: SourceType -> SourceType -> [(PSString, Binder)] -> m (M.Map Ident (SourceSpan, SourceType)) inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty inferRowProperties nrow row ((name, binder):binders) = do propTy <- freshTypeWithKind kindType @@ -568,7 +568,7 @@ inferBinder val (LiteralBinder _ (ArrayLiteral binders)) = do inferBinder val (NamedBinder ss name binder) = warnAndRethrowWithPositionTC ss $ do m <- inferBinder val binder - return $ M.insert name val m + return $ M.insert name (ss, val) m inferBinder val (PositionedBinder pos _ binder) = warnAndRethrowWithPositionTC pos $ inferBinder val binder inferBinder val (TypedBinder ty binder) = do @@ -623,7 +623,7 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do guardWith (errorMessage $ OverlappingArgNames Nothing) $ let ns = concatMap binderNames binders in length (ordNub ns) == length ns m1 <- M.unions <$> zipWithM inferBinder nvals binders - r <- bindLocalVariables [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $ + r <- bindLocalVariables [ (ss, name, ty, Defined) | (name, (ss, ty)) <- M.toList m1 ] $ CaseAlternative binders <$> forM result (\ge -> checkGuardedRhs ge ret) rs <- checkBinders nvals ret bs return $ r : rs @@ -643,8 +643,8 @@ checkGuardedRhs (GuardedExpr (ConditionGuard cond : guards) rhs) ret = do checkGuardedRhs (GuardedExpr (PatternGuard binder expr : guards) rhs) ret = do tv@(TypedValue' _ _ ty) <- infer expr variables <- inferBinder ty binder - GuardedExpr guards' rhs' <- bindLocalVariables [ (name, bty, Defined) - | (name, bty) <- M.toList variables + GuardedExpr guards' rhs' <- bindLocalVariables [ (ss, name, bty, Defined) + | (name, (ss, bty)) <- M.toList variables ] $ checkGuardedRhs (GuardedExpr guards rhs) ret return $ GuardedExpr (PatternGuard binder (tvToExpr tv) : guards') rhs' @@ -682,7 +682,7 @@ check' val (ForAll ann ident mbK ty _) = do -- an undefined type variable that happens to clash with the variable we -- want to skolemize. This can happen due to synonym expansion (see 2542). skVal - | Just _ <- M.lookup (Qualified mn (ProperName ident)) $ types env = + | Just _ <- M.lookup (Qualified (byMaybeModuleName mn) (ProperName ident)) $ types env = skolemizeTypesInValue ss ident mbK sko scope val | otherwise = val val' <- tvToExpr <$> check skVal sk @@ -692,7 +692,7 @@ check' val t@(ConstrainedType _ con@(Constraint _ cls@(Qualified _ (ProperName c -- An empty class dictionary is never used; see code in `TypeChecker.Entailment` -- that wraps empty dictionary solutions in `Unused`. dictName <- if typeClassIsEmpty then pure UnusedIdent else freshIdent ("dict" <> className) - dicts <- newDictionaries [] (Qualified Nothing dictName) con + dicts <- newDictionaries [] (Qualified ByNullSourcePos dictName) con val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty return $ TypedValue' True (Abs (VarBinder nullSourceSpan dictName) (tvToExpr val')) t check' val u@(TUnknown _ _) = do @@ -718,7 +718,7 @@ check' (Literal ss (ArrayLiteral vals)) t@(TypeApp _ a ty) = do check' (Abs binder ret) ty@(TypeApp _ (TypeApp _ t argTy) retTy) | VarBinder ss arg <- binder = do unifyTypes t tyFunction - ret' <- withBindingGroupVisible $ bindLocalVariables [(arg, argTy, Defined)] $ check ret retTy + ret' <- withBindingGroupVisible $ bindLocalVariables [(ss, arg, argTy, Defined)] $ check ret retTy return $ TypedValue' True (Abs (VarBinder ss arg) (tvToExpr ret')) ty | otherwise = internalError "Binder was not desugared" check' (App f arg) ret = do diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index 6544d14216..ea397c5bbf 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -20,8 +20,8 @@ moduleD = (P.moduleNameFromString "Module.D", [T.ideType "kind1" Nothing []]) moduleE = (P.moduleNameFromString "Module.E", [T.ideSynonym "SFType" Nothing Nothing `annLoc` synonymSS]) moduleF = (P.moduleNameFromString "Module.F", [T.ideDtor "DtorA" "TypeA" Nothing]) moduleG = (P.moduleNameFromString "Module.G", [T.ideTypeClass "MyClass" P.kindType []]) -moduleH = (P.moduleNameFromString "Module.H", [T.ideValueOp "<$>" (P.Qualified Nothing (Left "")) 0 Nothing Nothing]) -moduleI = (P.moduleNameFromString "Module.I", [T.ideTypeOp "~>" (P.Qualified Nothing "") 0 Nothing Nothing]) +moduleH = (P.moduleNameFromString "Module.H", [T.ideValueOp "<$>" (P.Qualified P.ByNullSourcePos (Left "")) 0 Nothing Nothing]) +moduleI = (P.moduleNameFromString "Module.I", [T.ideTypeOp "~>" (P.Qualified P.ByNullSourcePos "") 0 Nothing Nothing]) modules :: ModuleMap [IdeDeclarationAnn] modules = Map.fromList [moduleA, moduleB] diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index bf7c40e07a..e56f23a857 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -113,7 +113,7 @@ spec = do addValueImport i mn q is = prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValue i Nothing)) mn q is) addOpImport op mn q is = - prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValueOp op (P.Qualified q (Left "")) 2 Nothing Nothing)) mn q is) + prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValueOp op (P.Qualified (P.byMaybeModuleName q) (Left "")) 2 Nothing Nothing)) mn q is) addDtorImport i t mn q is = prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideDtor i t Nothing)) mn q is) addTypeImport i mn q is = diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index a34131825a..a196f50484 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -29,13 +29,13 @@ valueFixity = P.ValueFixityDeclaration ann1 (P.Fixity P.Infix 0) - (P.Qualified Nothing (Left (P.Ident ""))) + (P.Qualified P.ByNullSourcePos (Left (P.Ident ""))) (P.OpName "<$>") typeFixity = P.TypeFixityDeclaration ann1 (P.Fixity P.Infix 0) - (P.Qualified Nothing (P.ProperName "")) + (P.Qualified P.ByNullSourcePos (P.ProperName "")) (P.OpName "~>") foreign1 = P.ExternDeclaration ann1 (P.Ident "foreign1") P.srcREmpty foreign2 = P.ExternDataDeclaration ann1 (P.ProperName "Foreign2") P.kindType @@ -106,9 +106,9 @@ getLocation s = do , ideDtor "SFTwo" "SFData" Nothing `annLoc` typeSS , ideDtor "SFThree" "SFData" Nothing `annLoc` typeSS , ideTypeClass "SFClass" P.kindType [] `annLoc` classSS - , ideValueOp "<$>" (P.Qualified Nothing (Left "")) 0 Nothing Nothing + , ideValueOp "<$>" (P.Qualified P.ByNullSourcePos (Left "")) 0 Nothing Nothing `annLoc` valueOpSS - , ideTypeOp "~>" (P.Qualified Nothing "") 0 Nothing Nothing + , ideTypeOp "~>" (P.Qualified P.ByNullSourcePos "") 0 Nothing Nothing `annLoc` typeOpSS ]) ] diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index e1e0611a04..9ba778650b 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -11,15 +11,15 @@ import qualified Data.Map as Map valueOperator :: Maybe P.SourceType -> IdeDeclarationAnn valueOperator = - ideValueOp "<$>" (P.Qualified (Just (mn "Test")) (Left "function")) 2 Nothing + ideValueOp "<$>" (P.Qualified (P.ByModuleName (mn "Test")) (Left "function")) 2 Nothing ctorOperator :: Maybe P.SourceType -> IdeDeclarationAnn ctorOperator = - ideValueOp ":" (P.Qualified (Just (mn "Test")) (Right "Cons")) 2 Nothing + ideValueOp ":" (P.Qualified (P.ByModuleName (mn "Test")) (Right "Cons")) 2 Nothing typeOperator :: Maybe P.SourceType -> IdeDeclarationAnn typeOperator = - ideTypeOp ":" (P.Qualified (Just (mn "Test")) "List") 2 Nothing + ideTypeOp ":" (P.Qualified (P.ByModuleName (mn "Test")) "List") 2 Nothing testModule :: (P.ModuleName, [IdeDeclarationAnn]) testModule = @@ -53,7 +53,7 @@ ef = P.ExternsFile --, efDeclarations = [ P.EDInstance -- { edInstanceClassName = - (P.Qualified (Just (mn "ClassModule")) (P.ProperName "MyClass")) + (P.Qualified (P.ByModuleName (mn "ClassModule")) (P.ProperName "MyClass")) -- , edInstanceName = (P.Ident "myClassInstance") -- . edInstanceForAll = diff --git a/tests/TestAst.hs b/tests/TestAst.hs index a7d0439d2e..75095b239f 100644 --- a/tests/TestAst.hs +++ b/tests/TestAst.hs @@ -73,7 +73,7 @@ genTypeAnnotatedWith genTypeAnn genConstraintAnn = genType where genConstraintData = genericArbitraryUG generatorEnvironment genQualified :: forall b. (Text -> b) -> Gen (Qualified b) - genQualified ctor = Qualified Nothing . ctor <$> genText + genQualified ctor = Qualified ByNullSourcePos . ctor <$> genText genSkolemScope :: Gen SkolemScope genSkolemScope = SkolemScope <$> arbitrary diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index bb809b796f..b865567102 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -136,7 +136,7 @@ spec = context "CoreFnFromJson" $ do specify "should parse Abs" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "abs") - $ Abs ann (Ident "x") (Var ann (Qualified (Just mn) (Ident "x"))) + $ Abs ann (Ident "x") (Var ann (Qualified (ByModuleName mn) (Ident "x"))) ] parseMod m `shouldSatisfy` isSuccess @@ -144,13 +144,13 @@ spec = context "CoreFnFromJson" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "app") $ App ann - (Abs ann (Ident "x") (Var ann (Qualified Nothing (Ident "x")))) + (Abs ann (Ident "x") (Var ann (Qualified ByNullSourcePos (Ident "x")))) (Literal ann (CharLiteral 'c')) ] parseMod m `shouldSatisfy` isSuccess specify "should parse UnusedIdent in Abs" $ do - let i = NonRec ann (Ident "f") (Abs ann UnusedIdent (Var ann (Qualified Nothing (Ident "x")))) + let i = NonRec ann (Ident "f") (Abs ann UnusedIdent (Var ann (Qualified ByNullSourcePos (Ident "x")))) let r = parseMod $ Module ss [] mn mp [] [] M.empty [] [i] r `shouldSatisfy` isSuccess case r of @@ -161,7 +161,7 @@ spec = context "CoreFnFromJson" $ do specify "should parse Case" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ - Case ann [Var ann (Qualified Nothing (Ident "x"))] + Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))] [ CaseAlternative [ NullBinder ann ] (Right (Literal ann (CharLiteral 'a'))) @@ -172,7 +172,7 @@ spec = context "CoreFnFromJson" $ do specify "should parse Case with guards" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ - Case ann [Var ann (Qualified Nothing (Ident "x"))] + Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))] [ CaseAlternative [ NullBinder ann ] (Left [(Literal ann (BooleanLiteral True), Literal ann (CharLiteral 'a'))]) @@ -184,7 +184,7 @@ spec = context "CoreFnFromJson" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ Let ann - [ Rec [((ann, Ident "a"), Var ann (Qualified Nothing (Ident "x")))] ] + [ Rec [((ann, Ident "a"), Var ann (Qualified ByNullSourcePos (Ident "x")))] ] (Literal ann (BooleanLiteral True)) ] parseMod m `shouldSatisfy` isSuccess @@ -222,7 +222,7 @@ spec = context "CoreFnFromJson" $ do specify "should parse LiteralBinder" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ - Case ann [Var ann (Qualified Nothing (Ident "x"))] + Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))] [ CaseAlternative [ LiteralBinder ann (BooleanLiteral True) ] (Right (Literal ann (CharLiteral 'a'))) @@ -233,12 +233,12 @@ spec = context "CoreFnFromJson" $ do specify "should parse VarBinder" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ - Case ann [Var ann (Qualified Nothing (Ident "x"))] + Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))] [ CaseAlternative [ ConstructorBinder ann - (Qualified (Just (ModuleName "Data.Either")) (ProperName "Either")) - (Qualified Nothing (ProperName "Left")) + (Qualified (ByModuleName (ModuleName "Data.Either")) (ProperName "Either")) + (Qualified ByNullSourcePos (ProperName "Left")) [VarBinder ann (Ident "z")] ] (Right (Literal ann (CharLiteral 'a'))) @@ -249,7 +249,7 @@ spec = context "CoreFnFromJson" $ do specify "should parse NamedBinder" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ - Case ann [Var ann (Qualified Nothing (Ident "x"))] + Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))] [ CaseAlternative [ NamedBinder ann (Ident "w") (NamedBinder ann (Ident "w'") (VarBinder ann (Ident "w''"))) ] (Right (Literal ann (CharLiteral 'a'))) diff --git a/tests/TestHierarchy.hs b/tests/TestHierarchy.hs index 05c6e75a99..7d6559bf2a 100644 --- a/tests/TestHierarchy.hs +++ b/tests/TestHierarchy.hs @@ -51,7 +51,7 @@ spec = describe "hierarchy" $ do (P.internalModuleSourceSpan "", []) (P.ProperName "B") [] - [P.srcConstraint (P.Qualified Nothing $ P.ProperName "A") [] [] Nothing] + [P.srcConstraint (P.Qualified P.ByNullSourcePos $ P.ProperName "A") [] [] Nothing] [] [] ] From 8201875e6c3b3439ef8496911a8a3e145078385e Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 24 Jun 2022 08:09:47 -0500 Subject: [PATCH 1483/1580] Make v0.15.3 release (#4356) * Run make license-generator * Manually add licenses that got 404s * Update version to 0.15.3 * Run stack update-changelog.hs * Tweak credits to include people missed by tool * Tweak formatting of some changelog entries --- .../feature_cse-for-typeclass-dicts.md | 10 - CHANGELOG.d/feature_support-module-shebang.md | 15 -- ...ix_4034-stop-emitting-null-source-spans.md | 1 - .../fix_4298-stop-requiring-dev-deps.md | 1 - ...ternal_accommodate-initial-digit-idents.md | 1 - .../internal_enable-more-ghc-warnings.md | 3 - CHANGELOG.d/internal_golden_json_tests.md | 4 - CHANGELOG.d/internal_local_qualification.md | 6 - ...ternal_remove-unused-error-constructors.md | 1 - ...l_setup-source-maps-test-infrastructure.md | 1 - .../internal_test_suite_version_bounds.md | 1 - CHANGELOG.d/internal_update-to-ghc-9.2.3.md | 1 - CHANGELOG.md | 67 +++++++ LICENSE | 187 ++++++++++++++---- npm-package/package.json | 4 +- purescript.cabal | 2 +- 16 files changed, 218 insertions(+), 87 deletions(-) delete mode 100644 CHANGELOG.d/feature_cse-for-typeclass-dicts.md delete mode 100644 CHANGELOG.d/feature_support-module-shebang.md delete mode 100644 CHANGELOG.d/fix_4034-stop-emitting-null-source-spans.md delete mode 100644 CHANGELOG.d/fix_4298-stop-requiring-dev-deps.md delete mode 100644 CHANGELOG.d/internal_accommodate-initial-digit-idents.md delete mode 100644 CHANGELOG.d/internal_enable-more-ghc-warnings.md delete mode 100644 CHANGELOG.d/internal_golden_json_tests.md delete mode 100644 CHANGELOG.d/internal_local_qualification.md delete mode 100644 CHANGELOG.d/internal_remove-unused-error-constructors.md delete mode 100644 CHANGELOG.d/internal_setup-source-maps-test-infrastructure.md delete mode 100644 CHANGELOG.d/internal_test_suite_version_bounds.md delete mode 100644 CHANGELOG.d/internal_update-to-ghc-9.2.3.md diff --git a/CHANGELOG.d/feature_cse-for-typeclass-dicts.md b/CHANGELOG.d/feature_cse-for-typeclass-dicts.md deleted file mode 100644 index 4846ef0323..0000000000 --- a/CHANGELOG.d/feature_cse-for-typeclass-dicts.md +++ /dev/null @@ -1,10 +0,0 @@ -* Float compiler-synthesized function applications - - This is a limited implementation of common subexpression elimination for - expressions created by the compiler in the process of creating and using - typeclass dictionaries. Users can expect code that heavily uses typeclasses - to produce JavaScript that is shorter, simpler, and faster. - - Common subexpression elimination is not applied to any expressions explicitly - written by users. If you want those floated to a higher scope, you have to do - so manually. diff --git a/CHANGELOG.d/feature_support-module-shebang.md b/CHANGELOG.d/feature_support-module-shebang.md deleted file mode 100644 index ea918eba9b..0000000000 --- a/CHANGELOG.d/feature_support-module-shebang.md +++ /dev/null @@ -1,15 +0,0 @@ -* Add support for optional shebang lines - - One or more shebang line are only allowed as the first lines of a file - - ```purs - #! a shebang line - #! another shebang line - -- | module doc comment - -- other comment - module MyModule where - - #! Using a shebang here will fail to parse - foo :: String - foo = "" - ``` \ No newline at end of file diff --git a/CHANGELOG.d/fix_4034-stop-emitting-null-source-spans.md b/CHANGELOG.d/fix_4034-stop-emitting-null-source-spans.md deleted file mode 100644 index 1d7a2112f6..0000000000 --- a/CHANGELOG.d/fix_4034-stop-emitting-null-source-spans.md +++ /dev/null @@ -1 +0,0 @@ -* Stop emitting source spans with negative line/column numbers \ No newline at end of file diff --git a/CHANGELOG.d/fix_4298-stop-requiring-dev-deps.md b/CHANGELOG.d/fix_4298-stop-requiring-dev-deps.md deleted file mode 100644 index 26bb0aeb4c..0000000000 --- a/CHANGELOG.d/fix_4298-stop-requiring-dev-deps.md +++ /dev/null @@ -1 +0,0 @@ -* Stop requiring `bower.json` `devDependencies` when publishing \ No newline at end of file diff --git a/CHANGELOG.d/internal_accommodate-initial-digit-idents.md b/CHANGELOG.d/internal_accommodate-initial-digit-idents.md deleted file mode 100644 index d5e162db70..0000000000 --- a/CHANGELOG.d/internal_accommodate-initial-digit-idents.md +++ /dev/null @@ -1 +0,0 @@ -* Accommodate internally-generated identifiers that start with digits diff --git a/CHANGELOG.d/internal_enable-more-ghc-warnings.md b/CHANGELOG.d/internal_enable-more-ghc-warnings.md deleted file mode 100644 index 3ba9db1519..0000000000 --- a/CHANGELOG.d/internal_enable-more-ghc-warnings.md +++ /dev/null @@ -1,3 +0,0 @@ -* Update purescript.cabal so that the PureScript compiler is built with the - flags -Wincomplete-uni-patterns and -Wincomplete-record-updates enabled by - default. diff --git a/CHANGELOG.d/internal_golden_json_tests.md b/CHANGELOG.d/internal_golden_json_tests.md deleted file mode 100644 index 73fa1f23e1..0000000000 --- a/CHANGELOG.d/internal_golden_json_tests.md +++ /dev/null @@ -1,4 +0,0 @@ -* Compare json files through `aeson` in tests - - This fixes the tests for the graph and source map outputs, as the - ordering is inconsistent between `stack test` and `cabal test`. diff --git a/CHANGELOG.d/internal_local_qualification.md b/CHANGELOG.d/internal_local_qualification.md deleted file mode 100644 index 269b2e31cf..0000000000 --- a/CHANGELOG.d/internal_local_qualification.md +++ /dev/null @@ -1,6 +0,0 @@ -* Add qualification for locally-bound names - - This change makes it so that `Qualified` names can now be qualified by either - a `ModuleName` for module-level declarations or the starting `SourcePos` for - bindings introduced locally. This makes disambiguation between references to - local bindings much easier in AST-driven analysis. diff --git a/CHANGELOG.d/internal_remove-unused-error-constructors.md b/CHANGELOG.d/internal_remove-unused-error-constructors.md deleted file mode 100644 index b6e1998420..0000000000 --- a/CHANGELOG.d/internal_remove-unused-error-constructors.md +++ /dev/null @@ -1 +0,0 @@ -* Removed a couple of unused SimpleErrorMessage constructors diff --git a/CHANGELOG.d/internal_setup-source-maps-test-infrastructure.md b/CHANGELOG.d/internal_setup-source-maps-test-infrastructure.md deleted file mode 100644 index 794dcd6630..0000000000 --- a/CHANGELOG.d/internal_setup-source-maps-test-infrastructure.md +++ /dev/null @@ -1 +0,0 @@ -* Setup infrastructure for testing source maps \ No newline at end of file diff --git a/CHANGELOG.d/internal_test_suite_version_bounds.md b/CHANGELOG.d/internal_test_suite_version_bounds.md deleted file mode 100644 index 01a8a71733..0000000000 --- a/CHANGELOG.d/internal_test_suite_version_bounds.md +++ /dev/null @@ -1 +0,0 @@ -* Add version bounds to the test suite's `build-depends`. diff --git a/CHANGELOG.d/internal_update-to-ghc-9.2.3.md b/CHANGELOG.d/internal_update-to-ghc-9.2.3.md deleted file mode 100644 index ea0d4dc2f1..0000000000 --- a/CHANGELOG.d/internal_update-to-ghc-9.2.3.md +++ /dev/null @@ -1 +0,0 @@ -* Update GHC to 9.2.3 \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md index daec42a74e..bfd4fddf67 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,73 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.3 + +New features: + +* Float compiler-synthesized function applications (#3915 by @rhendric) + + This is a limited implementation of common subexpression elimination for + expressions created by the compiler in the process of creating and using + typeclass dictionaries. Users can expect code that heavily uses typeclasses + to produce JavaScript that is shorter, simpler, and faster. + + Common subexpression elimination is not applied to any expressions explicitly + written by users. If you want those floated to a higher scope, you have to do + so manually. + +* Add support for optional shebang lines (#4214 by @colinwahl and @JordanMartinez) + + One or more shebang line are only allowed as the first lines of a file + + ```purs + #! a shebang line + #! another shebang line + -- | module doc comment + -- other comment + module MyModule where + + #! Using a shebang here will fail to parse + foo :: String + foo = "" + ``` + +Bugfixes: + +* Stop requiring `bower.json` `devDependencies` when publishing (#4332 by @JordanMartinez) + +* Stop emitting source spans with negative line/column numbers (#4343 by @j-nava and @JordanMartinez) + +Internal: + +* Accommodate internally-generated identifiers that start with digits (#4334 by @rhendric) + +* Enable `-Wincomplete-uni-patterns` and `-Wincomplete-record-updates` by default (#4336 by @hdgarrood) + + Update `purescript.cabal` so that the PureScript compiler is built with the + flags `-Wincomplete-uni-patterns` and `-Wincomplete-record-updates` + enabled by default. + +* Setup infrastructure for testing source maps (#4335 by @JordanMartinez) + +* Removed a couple of unused `SimpleErrorMessage` constructors (#4344 by @hdgarrood) + +* Compare json files through `aeson` in tests (#4354 by @PureFunctor) + + This fixes the tests for the graph and source map outputs, as the + ordering is inconsistent between `stack test` and `cabal test`. + +* Add version bounds to the test suite's `build-depends`. (#4354 by @PureFunctor) + +* Update GHC to 9.2.3 (#4351 by @hdgarrood and @JordanMartinez) + +* Add qualification for locally-bound names (#4293 by @PureFunctor) + + This change makes it so that `Qualified` names can now be qualified by either + a `ModuleName` for module-level declarations or the starting `SourcePos` for + bindings introduced locally. This makes disambiguation between references to + local bindings much easier in AST-driven analysis. + ## 0.15.2 New features: diff --git a/LICENSE b/LICENSE index 4b6dcc8159..0012f04c11 100644 --- a/LICENSE +++ b/LICENSE @@ -16,6 +16,8 @@ PureScript uses the following Haskell library packages. Their license files foll Cabal Glob + OneTuple + QuickCheck StateVar adjunctions aeson @@ -42,7 +44,6 @@ PureScript uses the following Haskell library packages. Their license files foll bower-json boxes bytestring - cabal-doctest call-stack case-insensitive cborg @@ -77,6 +78,7 @@ PureScript uses the following Haskell library packages. Their license files foll filepath free fsnotify + ghc-bignum ghc-prim half happy @@ -141,6 +143,7 @@ PureScript uses the following Haskell library packages. Their license files foll tagsoup template-haskell text + text-short th-abstraction th-compat these @@ -168,8 +171,11 @@ PureScript uses the following Haskell library packages. Their license files foll Cabal LICENSE file: - Copyright (c) 2003-2017, Cabal Development Team. + Copyright (c) 2003-2020, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. + + See */LICENSE for the copyright holders of the subcomponents. + All rights reserved. Redistribution and use in source and binary forms, with or without @@ -231,6 +237,75 @@ Glob LICENSE file: OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +OneTuple LICENSE file: + + + Copyright (c) 2008, John A. Dorsey. + All rights reserved. + + Redistribution and use of this software in source and binary forms, + with or without modification, are permitted provided that the + following conditions are met: + + * Redistributions of source code must retain the above + copyright notice, this list of conditions and the + following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the + following disclaimer in the documentation and/or other + materials provided with the distribution. + + * Neither the name of John Dorsey nor the names of its + contributors may be used to endorse or promote products + derived from this software without specific prior + written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED + TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, + OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY + OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +QuickCheck LICENSE file: + + (The following is the 3-clause BSD license.) + + Copyright (c) 2000-2019, Koen Claessen + Copyright (c) 2006-2008, Björn Bringert + Copyright (c) 2009-2019, Nick Smallbone + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + - Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + - Neither the names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + StateVar LICENSE file: Copyright (c) 2014-2015, Edward Kmett @@ -1080,6 +1155,7 @@ bytestring LICENSE file: (c) Duncan Coutts 2006-2015 (c) David Roundy 2003-2005 (c) Simon Meier 2010-2011 + (c) Koz Ross 2021 All rights reserved. @@ -1107,39 +1183,6 @@ bytestring LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -cabal-doctest LICENSE file: - - Copyright (c) 2017, Oleg Grenrus - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Oleg Grenrus nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - call-stack LICENSE file: Copyright (c) 2016-2021 Simon Hengel @@ -2084,7 +2127,7 @@ file-embed LICENSE file: filepath LICENSE file: - Copyright Neil Mitchell 2005-2018. + Copyright Neil Mitchell 2005-2020. All rights reserved. Redistribution and use in source and binary forms, with or without @@ -2181,6 +2224,40 @@ fsnotify LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +ghc-bignum LICENSE file: + + The Glasgow Haskell Compiler License + + Copyright 2020, The University Court of the University of Glasgow. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. + ghc-prim LICENSE file: This library (libraries/ghc-prim) is derived from code from several @@ -3593,8 +3670,6 @@ reflection LICENSE file: regex-base LICENSE file: - This modile is under this "3 clause" BSD license: - Copyright (c) 2007, Christopher Kuklewicz All rights reserved. @@ -3602,6 +3677,7 @@ regex-base LICENSE file: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + * The names of the contributors may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. @@ -4348,6 +4424,39 @@ text LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +text-short LICENSE file: + + Copyright (c) 2017, Herbert Valerio Riedel + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Herbert Valerio Riedel nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + th-abstraction LICENSE file: Copyright (c) 2017-2020 Eric Mertens @@ -4432,7 +4541,7 @@ these LICENSE file: time LICENSE file: - TimeLib is Copyright (c) Ashley Yakeley, 2004-2014. All rights reserved. + TimeLib is Copyright (c) Ashley Yakeley and contributors, 2004-2020. All rights reserved. Certain sections are Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/npm-package/package.json b/npm-package/package.json index 6d4610b315..caa3e760c4 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.2", + "version": "0.15.3", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.2", + "postinstall": "install-purescript --purs-ver=0.15.3", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index df0a14e30e..c3eb68cf69 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.2 +version: 0.15.3 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 9cfc6c0b9e56b6b806a01a2d27f4f088e54c5917 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 24 Jun 2022 09:13:48 -0500 Subject: [PATCH 1484/1580] Increase rendered typed holes to max of 30 (#4341) --- CHANGELOG.d/feature_increase-type-holes-amount.md | 1 + src/Language/PureScript/Errors.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/feature_increase-type-holes-amount.md diff --git a/CHANGELOG.d/feature_increase-type-holes-amount.md b/CHANGELOG.d/feature_increase-type-holes-amount.md new file mode 100644 index 0000000000..a40ab70057 --- /dev/null +++ b/CHANGELOG.d/feature_increase-type-holes-amount.md @@ -0,0 +1 @@ +* Increases the max number of typed holes displayed from 5 up to 30 \ No newline at end of file diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 6b4e5efded..7f12d5774d 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1579,7 +1579,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl [ Box.hcat Box.left [ Box.text (T.unpack (showIdent ident) ++ " :: ") , markCodeBox $ typeAsBox prettyDepth ty' ] - | (ident, ty') <- take 5 ctx + | (ident, ty') <- take 30 ctx ] ] From f7070428764d81863bdd6ad5a879d0266b04cebd Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Thu, 30 Jun 2022 19:40:08 -0500 Subject: [PATCH 1485/1580] Merge `0.15.4-next` branch (#4361) * Fix name clash in guard clauses (#4358) * Bump version to 0.15.4 Co-authored-by: Justin Garcia --- CHANGELOG.md | 24 ++++++++++++++ npm-package/package.json | 4 +-- purescript.cabal | 2 +- src/Language/PureScript/AST/Traversals.hs | 27 ++++++++++++--- src/Language/PureScript/Linter/Wildcards.hs | 2 +- src/Language/PureScript/Sugar/Names.hs | 33 ++++++++++--------- src/Language/PureScript/Sugar/Operators.hs | 6 ++-- src/Language/PureScript/Traversals.hs | 3 ++ .../PureScript/TypeChecker/Skolems.hs | 2 +- tests/purs/passing/4357.purs | 29 ++++++++++++++++ 10 files changed, 106 insertions(+), 26 deletions(-) create mode 100644 tests/purs/passing/4357.purs diff --git a/CHANGELOG.md b/CHANGELOG.md index bfd4fddf67..d6f7f5bf9c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,30 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.4 + +Bugfixes: + +* Fix name clash in guard clauses introduced in #4293 (#4385 by @PureFunctor) + + As a consequence, a problem with the compiler not being able to see + imported names if they're shadowed by a guard binder is also solved. + ```purs + import Data.Foldable (fold) + import Data.Maybe (Maybe(..)) + import Data.Monoid.Additive (Additive(..)) + + test :: Maybe Int -> Int + test = case _ of + m | Just fold <- m -> fold + -- Previously would complain about `fold` being undefined + | otherwise -> case fold [] of Additive x -> x + ``` + +Internal: + +* Add `Guard` handler for the `everywhereWithContextOnValuesM` traversal. (#4385 by @PureFunctor) + ## 0.15.3 New features: diff --git a/npm-package/package.json b/npm-package/package.json index caa3e760c4..ce29f45dac 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.3", + "version": "0.15.4", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.3", + "postinstall": "install-purescript --purs-ver=0.15.4", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index c3eb68cf69..86eeea46cf 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.3 +version: 0.15.4 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 1e76f15766..ee115297ce 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -4,8 +4,10 @@ module Language.PureScript.AST.Traversals where import Prelude.Compat +import Protolude (swap) import Control.Monad +import Control.Monad.Trans.State import Data.Foldable (fold) import Data.Functor.Identity (runIdentity) @@ -424,15 +426,17 @@ everywhereWithContextOnValues -> (s -> Binder -> (s, Binder)) -> (s -> CaseAlternative -> (s, CaseAlternative)) -> (s -> DoNotationElement -> (s, DoNotationElement)) + -> (s -> Guard -> (s, Guard)) -> ( Declaration -> Declaration , Expr -> Expr , Binder -> Binder , CaseAlternative -> CaseAlternative , DoNotationElement -> DoNotationElement + , Guard -> Guard ) -everywhereWithContextOnValues s f g h i j = (runIdentity . f', runIdentity . g', runIdentity . h', runIdentity . i', runIdentity . j') +everywhereWithContextOnValues s f g h i j k = (runIdentity . f', runIdentity . g', runIdentity . h', runIdentity . i', runIdentity . j', runIdentity . k') where - (f', g', h', i', j') = everywhereWithContextOnValuesM s (wrap f) (wrap g) (wrap h) (wrap i) (wrap j) + (f', g', h', i', j', k') = everywhereWithContextOnValuesM s (wrap f) (wrap g) (wrap h) (wrap i) (wrap j) (wrap k) wrap = ((pure .) .) everywhereWithContextOnValuesM @@ -444,13 +448,15 @@ everywhereWithContextOnValuesM -> (s -> Binder -> m (s, Binder)) -> (s -> CaseAlternative -> m (s, CaseAlternative)) -> (s -> DoNotationElement -> m (s, DoNotationElement)) + -> (s -> Guard -> m (s, Guard)) -> ( Declaration -> m Declaration , Expr -> m Expr , Binder -> m Binder , CaseAlternative -> m CaseAlternative , DoNotationElement -> m DoNotationElement + , Guard -> m Guard ) -everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0) +everywhereWithContextOnValuesM s0 f g h i j k = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0, k'' s0) where f'' s = uncurry f' <=< f s @@ -501,7 +507,18 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j i'' s = uncurry i' <=< i s - i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val + i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> traverse (guardedExprM' s) val + + -- A specialized `guardedExprM` that keeps track of the context `s` + -- after traversing `guards`, such that it's also exposed to `expr`. + guardedExprM' :: s -> GuardedExpr -> m GuardedExpr + guardedExprM' s (GuardedExpr guards expr) = do + (guards', s') <- runStateT (traverse (StateT . goGuard) guards) s + GuardedExpr guards' <$> g'' s' expr + + -- Like k'', but `s` is tracked. + goGuard :: Guard -> s -> m (Guard, s) + goGuard x s = k s x >>= fmap swap . sndM' k' j'' s = uncurry j' <=< j s @@ -510,6 +527,8 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1 + k'' s = uncurry k' <=< k s + k' s (ConditionGuard e) = ConditionGuard <$> g'' s e k' s (PatternGuard b e) = PatternGuard <$> h'' s b <*> g'' s e diff --git a/src/Language/PureScript/Linter/Wildcards.hs b/src/Language/PureScript/Linter/Wildcards.hs index 06f1ddf6fb..f224af6860 100644 --- a/src/Language/PureScript/Linter/Wildcards.hs +++ b/src/Language/PureScript/Linter/Wildcards.hs @@ -22,7 +22,7 @@ import Language.PureScript.Types ignoreWildcardsUnderCompleteTypeSignatures :: Declaration -> Declaration ignoreWildcardsUnderCompleteTypeSignatures = onDecl where - (onDecl, _, _, _, _) = everywhereWithContextOnValues False (,) handleExpr handleBinder (,) (,) + (onDecl, _, _, _, _, _) = everywhereWithContextOnValues False (,) handleExpr handleBinder (,) (,) (,) handleExpr isCovered = \case tv@(TypedValue chk v ty) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 288376be60..7b672025a0 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -172,7 +172,7 @@ renameInModule imports (Module modSS coms mn decls exps) = Module modSS coms mn <$> parU decls go <*> pure exps where - (go, _, _, _, _) = + (go, _, _, _, _, _) = everywhereWithContextOnValuesM (modSS, M.empty) (\(_, bound) d -> (\(bound', d') -> ((declSourceSpan d', bound'), d')) <$> updateDecl bound d) @@ -180,6 +180,7 @@ renameInModule imports (Module modSS coms mn decls exps) = updateBinder updateCase defS + updateGuard updateDecl :: M.Map Ident SourcePos @@ -303,23 +304,25 @@ renameInModule imports (Module modSS coms mn decls exps) = :: (SourceSpan, M.Map Ident SourcePos) -> CaseAlternative -> m ((SourceSpan, M.Map Ident SourcePos), CaseAlternative) - updateCase (pos, bound) c@(CaseAlternative bs gs) = - return ((pos, updateGuard gs `M.union` rUnionMap binderNamesWithSpans' bs `M.union` bound), c) + updateCase (pos, bound) c@(CaseAlternative bs _) = + return ((pos, rUnionMap binderNamesWithSpans' bs `M.union` bound), c) where - updateGuard :: [GuardedExpr] -> M.Map Ident SourcePos - updateGuard [] = M.empty - updateGuard (GuardedExpr g _ : xs) = - updateGuard xs `M.union` rUnionMap updatePatGuard g - where - updatePatGuard (PatternGuard b _) = binderNamesWithSpans' b - updatePatGuard _ = M.empty - rUnionMap f = foldl' (flip (M.union . f)) M.empty - binderNamesWithSpans' - = M.fromList - . fmap (second spanStart . swap) - . binderNamesWithSpans + updateGuard + :: (SourceSpan, M.Map Ident SourcePos) + -> Guard + -> m ((SourceSpan, M.Map Ident SourcePos), Guard) + updateGuard (pos, bound) g@(ConditionGuard _) = + return ((pos, bound), g) + updateGuard (pos, bound) g@(PatternGuard b _) = + return ((pos, binderNamesWithSpans' b `M.union` bound), g) + + binderNamesWithSpans' :: Binder -> M.Map Ident SourcePos + binderNamesWithSpans' + = M.fromList + . fmap (second spanStart . swap) + . binderNamesWithSpans letBoundVariable :: Declaration -> Maybe Ident letBoundVariable = fmap valdeclIdent . getValueDeclaration diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index dc8fac9b9b..3ce7d0986f 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -136,7 +136,7 @@ rebracketFiltered !caller pred_ externs m = do Module ss coms mn <$> mapM (usingPredicate pred_ f') ds <*> pure exts where (goDecl', goExpr', goBinder') = updateTypes goType - (f', _, _, _, _) = + (f', _, _, _, _, _) = everywhereWithContextOnValuesM ss (\_ d -> (declSourceSpan d,) <$> goDecl' d) @@ -144,6 +144,7 @@ rebracketFiltered !caller pred_ externs m = do (\pos -> uncurry goBinder <=< goBinder' pos) defS defS + defS goExpr :: SourceSpan -> Expr -> m (SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (pos, e) @@ -225,7 +226,7 @@ rebracketModule !caller pred_ valueOpTable typeOpTable (Module ss coms mn ds ext CalledByDocs -> f CalledByCompile -> g <=< f - (f, _, _, _, _) = + (f, _, _, _, _, _) = everywhereWithContextOnValuesM ss (\_ d -> (declSourceSpan d,) <$> goDecl d) @@ -233,6 +234,7 @@ rebracketModule !caller pred_ valueOpTable typeOpTable (Module ss coms mn ds ext (\pos -> wrap (matchBinderOperators valueOpTable) <=< goBinder' pos) defS defS + defS (g, _, _) = everywhereOnValuesTopDownM pure removeBinaryNoParens pure diff --git a/src/Language/PureScript/Traversals.hs b/src/Language/PureScript/Traversals.hs index 25b426b15a..bdb70c5d83 100644 --- a/src/Language/PureScript/Traversals.hs +++ b/src/Language/PureScript/Traversals.hs @@ -6,6 +6,9 @@ import Prelude.Compat sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c) sndM f (a, b) = (a, ) <$> f b +sndM' :: (Functor f) => (a -> b -> f c) -> (a, b) -> f (a, c) +sndM' f (a, b) = (a, ) <$> f a b + thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d) thirdM f (a, b, c) = (a, b, ) <$> f c diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 89ba0262d8..7a11949331 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -56,7 +56,7 @@ skolemizeTypesInValue ann ident mbK sko scope = runIdentity . onExpr' where onExpr' :: Expr -> Identity Expr - (_, onExpr', _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS + (_, onExpr', _, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS defS onExpr :: [Text] -> Expr -> Identity ([Text], Expr) onExpr sco (DeferredDictionary c ts) diff --git a/tests/purs/passing/4357.purs b/tests/purs/passing/4357.purs new file mode 100644 index 0000000000..65678d7c48 --- /dev/null +++ b/tests/purs/passing/4357.purs @@ -0,0 +1,29 @@ +module Main where + +import Prelude + +import Data.Foldable (fold) +import Data.Maybe (Maybe(..)) +import Data.Monoid.Additive (Additive(..)) +import Effect.Console (log) + +data Foo = Foo Int | Bar Int + +g :: Foo -> Int +g = + case _ of + a + | Bar z <- a + -> z + | Foo z <- a + -> z + | otherwise + -> 42 + +-- solved as a consequence of #4358 +test :: Maybe Int -> Int +test = case _ of + m | Just fold <- m -> fold + | otherwise -> case fold [] of Additive x -> x + +main = log "Done" From acc5ad0e02538c20f53bf4f08e84842771a67705 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 8 Jul 2022 07:12:26 -0500 Subject: [PATCH 1486/1580] Enable OverloadedRecordDot extension (#4355) * Add OverloadedRecordDot extension to common ones * Fix issues: `foo.bar` -> `foo . bar` * Add changelog entry --- CHANGELOG.d/internal_overloaded-record-dot.md | 1 + purescript.cabal | 1 + src/Language/PureScript/CST/Positions.hs | 2 +- src/Language/PureScript/Ide/Completion.hs | 2 +- src/Language/PureScript/Ide/Externs.hs | 4 ++-- src/Language/PureScript/Ide/Reexports.hs | 2 +- src/Language/PureScript/Ide/State.hs | 4 ++-- src/Language/PureScript/TypeChecker.hs | 2 +- 8 files changed, 10 insertions(+), 8 deletions(-) create mode 100644 CHANGELOG.d/internal_overloaded-record-dot.md diff --git a/CHANGELOG.d/internal_overloaded-record-dot.md b/CHANGELOG.d/internal_overloaded-record-dot.md new file mode 100644 index 0000000000..c85ec1c01d --- /dev/null +++ b/CHANGELOG.d/internal_overloaded-record-dot.md @@ -0,0 +1 @@ +* Enable `OverloadedRecordDot` extension throughout codebase \ No newline at end of file diff --git a/purescript.cabal b/purescript.cabal index 86eeea46cf..1382737e46 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -84,6 +84,7 @@ common defaults PatternSynonyms RankNTypes RecordWildCards + OverloadedRecordDot OverloadedStrings ScopedTypeVariables TupleSections diff --git a/src/Language/PureScript/CST/Positions.hs b/src/Language/PureScript/CST/Positions.hs index 88630805f9..34e13cacbe 100644 --- a/src/Language/PureScript/CST/Positions.hs +++ b/src/Language/PureScript/CST/Positions.hs @@ -191,7 +191,7 @@ dataCtorRange (DataCtor _ name fields) classHeadRange :: ClassHead a -> TokenRange classHeadRange (ClassHead kw _ name vars fdeps) - | Just (_, fs) <- fdeps = (kw, snd .classFundepRange $ sepLast fs) + | Just (_, fs) <- fdeps = (kw, snd . classFundepRange $ sepLast fs) | [] <- vars = (kw, snd $ nameRange name) | otherwise = (kw, snd . typeVarBindingRange $ last vars) diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 206d905b6d..516015a702 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -96,7 +96,7 @@ groupCompletionReexports initial = (Namespaced (namespaceForDeclaration decl) (P.runModuleName origin <> "." <> identifierFromIdeDeclaration decl)) insertDeclaration moduleName origin d old = case old of - Nothing -> Just ( Match (origin, d & idaAnnotation.annExportedFrom .~ Nothing) + Nothing -> Just ( Match (origin, d & idaAnnotation . annExportedFrom .~ Nothing) , [moduleName] ) Just x -> Just (second (moduleName :) x) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 4ca2d7a6c8..e23010f0cb 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -70,14 +70,14 @@ resolveSynonymsAndClasses trs decls = foldr go decls trs acc Just tyDecl -> IdeDeclTypeClass (IdeTypeClass tcn (tyDecl^.ideTypeKind) []) - : filter (not . anyOf (_IdeDeclType.ideTypeName) (== P.coerceProperName tcn)) acc + : filter (not . anyOf (_IdeDeclType . ideTypeName) (== P.coerceProperName tcn)) acc SynonymToResolve tn ty -> case findType tn acc of Nothing -> acc Just tyDecl -> IdeDeclTypeSynonym (IdeTypeSynonym tn ty (tyDecl^.ideTypeKind)) - : filter (not . anyOf (_IdeDeclType.ideTypeName) (== tn)) acc + : filter (not . anyOf (_IdeDeclType . ideTypeName) (== tn)) acc findType :: P.ProperName 'P.TypeName -> [IdeDeclaration] -> Maybe IdeType findType tn decls = diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index bc717d16d2..50f7acb549 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -85,7 +85,7 @@ resolveReexports' modules refs = Nothing -> Left x Just decls' -> let - setExportedFrom = set (idaAnnotation.annExportedFrom) . Just + setExportedFrom = set (idaAnnotation . annExportedFrom) . Just in bimap (mn,) (map (setExportedFrom mn)) (resolveRef decls' r) diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 764b234f5c..644e40c107 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -442,12 +442,12 @@ resolveDataConstructorsForModule decls = resolveDataConstructors :: IdeDeclaration -> IdeDeclaration resolveDataConstructors decl = case decl of IdeDeclType ty -> - IdeDeclType (ty & ideTypeDtors .~ fromMaybe [] (Map.lookup (ty^.ideTypeName) dtors)) + IdeDeclType (ty & ideTypeDtors .~ fromMaybe [] (Map.lookup (ty ^. ideTypeName) dtors)) _ -> decl dtors = decls - & mapMaybe (preview (idaDeclaration._IdeDeclDataConstructor)) + & mapMaybe (preview (idaDeclaration . _IdeDeclDataConstructor)) & foldr (\(IdeDataConstructor name typeName type') -> Map.insertWith (<>) typeName [(name, type')]) Map.empty diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index e73748e8b4..91911662dd 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -297,7 +297,7 @@ typeCheckAll moduleName = traverse go dataDecls = mapMaybe toDataDecl tysList roleDecls = mapMaybe toRoleDecl tysList clss = mapMaybe toClassDecl tysList - bindingGroupNames = ordNub ((syns^..traverse._2) ++ (dataDecls^..traverse._2._2) ++ fmap coerceProperName (clss^..traverse._2._2)) + bindingGroupNames = ordNub ((syns ^.. traverse . _2) ++ (dataDecls ^.. traverse . _2 . _2) ++ fmap coerceProperName (clss ^.. traverse . _2 . _2)) sss = fmap declSourceSpan tys warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames) . addHint (PositionedError sss)) $ do env <- getEnv From 123e2e72c57d6eb9f9fc265392affca781e9f698 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 14 Jul 2022 09:20:32 -0400 Subject: [PATCH 1487/1580] Qualify references to top-level floated expressions (#4364) --- CHANGELOG.d/fix_4363.md | 1 + src/Language/PureScript/CoreFn/CSE.hs | 44 ++++++++++++++++++--------- 2 files changed, 30 insertions(+), 15 deletions(-) create mode 100644 CHANGELOG.d/fix_4363.md diff --git a/CHANGELOG.d/fix_4363.md b/CHANGELOG.d/fix_4363.md new file mode 100644 index 0000000000..ed2b32d7cd --- /dev/null +++ b/CHANGELOG.d/fix_4363.md @@ -0,0 +1 @@ +* Qualify references to expressions floated to the top level of a module by the compiler diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index 01a6b76dcc..a87c0cf5aa 100644 --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -157,6 +157,9 @@ data CSEEnvironment = CSEEnvironment { _depth :: Int -- ^ number of enclosing binding scopes (this includes not only Abs, but -- Let and CaseAlternative bindings) + , _deepestTopLevelScope :: Int + -- ^ number of enclosing binding scopes outside the first Abs; used to + -- decide whether to qualify floated identifiers , _bound :: M.Map Ident (Int, BindingType) -- ^ map from identifiers to depth in which they are bound and whether -- or not the binding is recursive @@ -186,7 +189,7 @@ type HasCSEState = MonadState CSEState -- didn't end up needing to be floated. -- runCSEMonad :: CSEMonad a -> Supply (a, M.Map Ident (Expr Ann)) -runCSEMonad x = second (^. toBeReinlined) <$> evalRWST x (CSEEnvironment 0 M.empty) IM.empty +runCSEMonad x = second (^. toBeReinlined) <$> evalRWST x (CSEEnvironment 0 0 M.empty) IM.empty -- | -- Mark all expressions floated out of this computation as "plural". This pass @@ -201,14 +204,20 @@ enterAbs = censor $ plurality %~ PluralityMap . fmap (const True) . getPlurality -- | -- Run the provided computation in a new scope. -- -newScope :: (HasCSEReader m, HasCSEWriter m) => (Int -> m a) -> m a -newScope body = local (depth %~ succ) $ do +newScope :: (HasCSEReader m, HasCSEWriter m) => Bool -> (Int -> m a) -> m a +newScope isAbs body = local goDeeper $ do d <- view depth censor (filterToDepth d) (body d) where filterToDepth d = (scopesUsed %~ IS.filter (< d)) . (noFloatWithin %~ find (< Min d)) + goDeeper env@CSEEnvironment{..} = + if isAbs || _deepestTopLevelScope /= _depth + then env{ _depth = depth' } + else env{ _depth = depth', _deepestTopLevelScope = depth' } + where + depth' = succ _depth -- | -- Record a list of identifiers as being bound in the given scope. @@ -220,8 +229,8 @@ withBoundIdents idents t = local (bound %~ flip (foldl' (flip (flip M.insert t)) -- Run the provided computation in a new scope in which the provided -- identifiers are bound non-recursively. -- -newScopeWithIdents :: (HasCSEReader m, HasCSEWriter m) => [Ident] -> m a -> m a -newScopeWithIdents idents = newScope . flip (withBoundIdents idents . (, NonRecursive)) +newScopeWithIdents :: (HasCSEReader m, HasCSEWriter m) => Bool -> [Ident] -> m a -> m a +newScopeWithIdents isAbs idents = newScope isAbs . flip (withBoundIdents idents . (, NonRecursive)) -- | -- Produce, or retrieve from the state, an identifier for referencing the given @@ -261,7 +270,7 @@ nullAnn = (nullSourceSpan, [], Nothing, Nothing) replaceLocals :: M.Map Ident (Expr Ann) -> [Bind Ann] -> [Bind Ann] replaceLocals m = if M.null m then identity else map f' where (f', g', _) = everywhereOnValues identity f identity - f e@(Var _ (Qualified (BySourcePos _) ident)) = maybe e g' $ ident `M.lookup` m + f e@(Var _ (Qualified _ ident)) = maybe e g' $ ident `M.lookup` m f e = e -- | @@ -270,17 +279,20 @@ replaceLocals m = if M.null m then identity else map f' where -- replacement. -- floatExpr - :: (HasCSEState m, MonadSupply m) - => (Expr Ann, CSESummary) + :: (HasCSEReader m, HasCSEState m, MonadSupply m) + => QualifiedBy + -> (Expr Ann, CSESummary) -> m (Expr Ann, CSESummary) -floatExpr = \case +floatExpr topLevelQB = \case (e, w@CSESummary{ _noFloatWithin = Nothing, .. }) -> do let deepestScope = if IS.null _scopesUsed then 0 else IS.findMax _scopesUsed (isNew, ident) <- generateIdentFor deepestScope (void e) + topLevel <- view deepestTopLevelScope + let qb = if deepestScope > topLevel then ByNullSourcePos else topLevelQB let w' = w & (if isNew then newBindings %~ addToScope deepestScope [(ident, (_plurality, e))] else identity) & plurality .~ PluralityMap (M.singleton ident False) - pure (Var nullAnn (Qualified ByNullSourcePos ident), w') + pure (Var nullAnn (Qualified qb ident), w') (e, w) -> pure (e, w) -- | @@ -388,16 +400,18 @@ optimizeCommonSubexpressions mn (handleBind, handleExprDefault, handleBinder, _) = traverseCoreFn handleBind handleExpr handleBinder handleCaseAlternative + topLevelQB = ByModuleName mn + handleExpr :: Expr Ann -> CSEMonad (Expr Ann) - handleExpr = discuss (ifM (shouldFloatExpr . fst) floatExpr pure) . \case - Abs a ident e -> enterAbs $ Abs a ident <$> newScopeWithIdents [ident] (handleAndWrapExpr e) + handleExpr = discuss (ifM (shouldFloatExpr . fst) (floatExpr topLevelQB) pure) . \case + Abs a ident e -> enterAbs $ Abs a ident <$> newScopeWithIdents True [ident] (handleAndWrapExpr e) v@(Var _ qname) -> summarizeName mn qname $> v Let a bs e -> uncurry (Let a) <$> handleBinds (handleExpr e) bs x -> handleExprDefault x handleCaseAlternative :: CaseAlternative Ann -> CSEMonad (CaseAlternative Ann) handleCaseAlternative (CaseAlternative bs x) = CaseAlternative bs <$> do - newScopeWithIdents (identsFromBinders bs) $ + newScopeWithIdents False (identsFromBinders bs) $ bitraverse (traverse $ bitraverse handleAndWrapExpr handleAndWrapExpr) handleAndWrapExpr x handleBinds :: forall a. CSEMonad a -> [Bind Ann] -> CSEMonad ([Bind Ann], a) @@ -409,14 +423,14 @@ optimizeCommonSubexpressions mn -- inner thing all these Binds are applied to. NonRec a ident e -> do e' <- handleExpr e - newScopeWithIdents [ident] $ + newScopeWithIdents False [ident] $ prependToNewBindsFromInner $ NonRec a ident e' Rec es -> -- For a Rec Bind, the bound expressions need a new scope in which all -- these identifiers are bound recursively; then the remaining Binds -- and the inner thing can be traversed in the same scope with the same -- identifiers now bound non-recursively. - newScope $ \d -> do + newScope False $ \d -> do let idents = map (snd . fst) es es' <- withBoundIdents idents (d, Recursive) $ traverse (traverse handleExpr) es withBoundIdents idents (d, NonRecursive) $ From 3d6b8bf7ffee6c6be85580b7daa765a9b54d0564 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Wed, 27 Jul 2022 20:26:46 +0800 Subject: [PATCH 1488/1580] Bump actions environment to macOS-11 (#4372) --- .github/workflows/ci.yml | 2 +- CHANGELOG.d/misc_macos_11_runner.md | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/misc_macos_11_runner.md diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 39f611ac5a..0ae51e25fe 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -39,7 +39,7 @@ jobs: - # If upgrading the Haskell image, also upgrade it in the lint job below os: "ubuntu-latest" image: "ghcr.io/purescript/haskell:9.2.3-stretch@sha256:70fd2b6255deb5daa961e6983591a0e21e9ac1e793923bee54aa2cc62e01f867" - - os: "macOS-10.15" + - os: "macOS-11" - os: "windows-2019" runs-on: "${{ matrix.os }}" diff --git a/CHANGELOG.d/misc_macos_11_runner.md b/CHANGELOG.d/misc_macos_11_runner.md new file mode 100644 index 0000000000..56cb417010 --- /dev/null +++ b/CHANGELOG.d/misc_macos_11_runner.md @@ -0,0 +1 @@ +* Bump actions environment to `macOS-11` From ea118aec3d54a4918825b1e438d3ae4bb9181447 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Thu, 28 Jul 2022 21:31:21 +0800 Subject: [PATCH 1489/1580] Fix replicated type hole suggestions (#4374) --- CHANGELOG.d/fix_4373.md | 15 ++++++ .../PureScript/Sugar/CaseDeclarations.hs | 20 +++---- tests/purs/failing/TypedHole4.out | 52 +++++++++++++++++++ tests/purs/failing/TypedHole4.purs | 9 ++++ 4 files changed, 86 insertions(+), 10 deletions(-) create mode 100644 CHANGELOG.d/fix_4373.md create mode 100644 tests/purs/failing/TypedHole4.out create mode 100644 tests/purs/failing/TypedHole4.purs diff --git a/CHANGELOG.d/fix_4373.md b/CHANGELOG.d/fix_4373.md new file mode 100644 index 0000000000..421a0db67d --- /dev/null +++ b/CHANGELOG.d/fix_4373.md @@ -0,0 +1,15 @@ +* Fix replicated type hole suggestions due to malformed source spans + + In PureScript `0.15.4`, the following code will produce multiple entries in + the type hole suggestions. This is due to malformed source spans that are + generated when desugaring value declarations into case expressions. + + ```purs + module Main where + + data F = X | Y + + f :: forall a. F -> a -> a + f X b = ?help + f Y b = ?help + ``` diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index bb213bc481..5215bb42d7 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -380,10 +380,10 @@ makeCaseDeclaration ss ident alternatives = do argNames = foldl1 resolveNames namedArgs args <- if allUnique (catMaybes argNames) then mapM argName argNames - else replicateM (length argNames) freshIdent' - let vars = map (Var ss . Qualified ByNullSourcePos) args + else replicateM (length argNames) ((nullSourceSpan, ) <$> freshIdent') + let vars = map (Var ss . Qualified ByNullSourcePos . snd) args binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] - let value = foldr (Abs . VarBinder ss) (Case vars binders) args + let value = foldr (Abs . uncurry VarBinder) (Case vars binders) args return $ ValueDecl (ss, []) ident Public [] [MkUnguarded value] where @@ -391,8 +391,8 @@ makeCaseDeclaration ss ident alternatives = do -- VarBinders will become Just _ which is a potential name. -- Everything else becomes Nothing, which indicates that we -- have to generate a name. - findName :: Binder -> Maybe Ident - findName (VarBinder _ name) = Just name + findName :: Binder -> Maybe (SourceSpan, Ident) + findName (VarBinder ss' name) = Just (ss', name) findName (PositionedBinder _ _ binder) = findName binder findName _ = Nothing @@ -401,18 +401,18 @@ makeCaseDeclaration ss ident alternatives = do allUnique :: (Ord a) => [a] -> Bool allUnique xs = length xs == length (ordNub xs) - argName :: Maybe Ident -> m Ident - argName (Just name) = return name - argName _ = freshIdent' + argName :: Maybe (SourceSpan, Ident) -> m (SourceSpan, Ident) + argName (Just (ss', name)) = return (ss', name) + argName _ = (nullSourceSpan, ) <$> freshIdent' -- Combine two lists of potential names from two case alternatives -- by zipping corresponding columns. - resolveNames :: [Maybe Ident] -> [Maybe Ident] -> [Maybe Ident] + resolveNames :: [Maybe (SourceSpan, Ident)] -> [Maybe (SourceSpan, Ident)] -> [Maybe (SourceSpan, Ident)] resolveNames = zipWith resolveName -- Resolve a pair of names. VarBinder beats NullBinder, and everything -- else results in Nothing. - resolveName :: Maybe Ident -> Maybe Ident -> Maybe Ident + resolveName :: Maybe (SourceSpan, Ident) -> Maybe (SourceSpan, Ident) -> Maybe (SourceSpan, Ident) resolveName (Just a) (Just b) | a == b = Just a | otherwise = Nothing diff --git a/tests/purs/failing/TypedHole4.out b/tests/purs/failing/TypedHole4.out new file mode 100644 index 0000000000..ee25e2c2d5 --- /dev/null +++ b/tests/purs/failing/TypedHole4.out @@ -0,0 +1,52 @@ +Error 1 of 2: + + in module Main + at tests/purs/failing/TypedHole4.purs:8:9 - 8:14 (line 8, column 9 - line 8, column 14) + + Hole 'help' has the inferred type +   +  a0 +   + You could substitute the hole with one of these values: +   +  b :: a0 +   + in the following context: + + b :: a0 + + + in value declaration f + + where a0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/HoleInferredType.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module Main + at tests/purs/failing/TypedHole4.purs:9:9 - 9:14 (line 9, column 9 - line 9, column 14) + + Hole 'help' has the inferred type +   +  a0 +   + You could substitute the hole with one of these values: +   +  b :: a0 +   + in the following context: + + b :: a0 + + + in value declaration f + + where a0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/HoleInferredType.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/failing/TypedHole4.purs b/tests/purs/failing/TypedHole4.purs new file mode 100644 index 0000000000..3b8043069c --- /dev/null +++ b/tests/purs/failing/TypedHole4.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith HoleInferredType +-- @shouldFailWith HoleInferredType +module Main where + +data F = X | Y + +f :: forall a. F -> a -> a +f X b = ?help +f Y b = ?help From 0b5a87e08f77ce90884a8696f15ef87d725879c9 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sat, 30 Jul 2022 17:44:18 -0500 Subject: [PATCH 1490/1580] Sort on kind levels only, not lvls and txt (#4369) * Sort on kind levels only, not lvls and txt * Add changelog entry --- CHANGELOG.d/internal_fix-free-type-variables.md | 1 + src/Language/PureScript/Types.hs | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) create mode 100644 CHANGELOG.d/internal_fix-free-type-variables.md diff --git a/CHANGELOG.d/internal_fix-free-type-variables.md b/CHANGELOG.d/internal_fix-free-type-variables.md new file mode 100644 index 0000000000..603e1759a8 --- /dev/null +++ b/CHANGELOG.d/internal_fix-free-type-variables.md @@ -0,0 +1 @@ +* Ensure order of args remain unchanged in `freeTypeVariables` \ No newline at end of file diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 5a23ca146f..d3b0c62300 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -17,7 +17,7 @@ import qualified Data.Aeson as A import qualified Data.Aeson.Types as A import Data.Foldable (fold, foldl') import qualified Data.IntSet as IS -import Data.List (sort, sortOn) +import Data.List (sortOn) import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) import qualified Data.Text as T @@ -511,7 +511,7 @@ usedTypeVariables = ordNub . everythingOnTypes (++) go where -- | Collect all free type variables appearing in a type freeTypeVariables :: Type a -> [Text] -freeTypeVariables = ordNub . fmap snd . sort . go 0 [] where +freeTypeVariables = ordNub . fmap snd . sortOn fst . go 0 [] where -- Tracks kind levels so that variables appearing in kind annotations are listed first. go :: Int -> [Text] -> Type a -> [(Int, Text)] go lvl bound (TypeVar _ v) | v `notElem` bound = [(lvl, v)] From e09ba0d676c1231cf8ba5c9f935f0f7c51532e44 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 24 Sep 2022 21:29:28 -0400 Subject: [PATCH 1491/1580] Bump HLint to 3.5 --- .github/workflows/ci.yml | 10 ++++++++-- .hlint.yaml | 7 +++++++ 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 0ae51e25fe..af05bccb69 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -166,7 +166,13 @@ jobs: lint: runs-on: "ubuntu-latest" - container: "ghcr.io/purescript/haskell:9.2.3-stretch@sha256:70fd2b6255deb5daa961e6983591a0e21e9ac1e793923bee54aa2cc62e01f867" + # At the moment, this is a different image from the image used for + # compilation, though the GHC versions match. This is because the + # compilation image uses an old version of glibc, which we want because it + # means our published binaries will work on the widest number of platforms. + # But the HLint binary downloaded by this job requires a newer glibc + # version. + container: "haskell:9.2.3-buster@sha256:51e250369e4671a15c247cdc5047397be88d7eb8e95b97b0fd9f417854a78bec" steps: - # We need a proper Git repository, but the checkout step will unpack a tarball instead of doing a clone @@ -190,7 +196,7 @@ jobs: - run: "ci/fix-home ci/run-hlint.sh --git" env: - VERSION: "2.2.11" + VERSION: "3.5" # Note: the weeder version will need to be updated when we next update our version # of GHC. diff --git a/.hlint.yaml b/.hlint.yaml index 545de81c6a..9d25cd5ce6 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -18,6 +18,13 @@ - ignore: {name: "Avoid lambda using `infix`"} - ignore: {name: "Fuse mapM/map"} - ignore: {name: "Eta reduce"} # This warning will often make suggestions that are no longer valid due to simplified subsumption +- ignore: {name: "Redundant fmap"} +- ignore: {name: "Redundant <$>"} +- ignore: {name: "Use any"} +- ignore: {name: "Use fromRight"} +- ignore: {name: "Use maybe"} +- ignore: {name: "Use unzip"} +- ignore: {name: "Use <=<"} # Specify additional command line arguments From cdff9d5bfaed37bce2a129e738c9a7a42bb80888 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 24 Sep 2022 21:32:41 -0400 Subject: [PATCH 1492/1580] HLint fix: "Redundant fmap" --- .hlint.yaml | 1 - src/Language/PureScript/Linter/Imports.hs | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 9d25cd5ce6..64ceeb40f0 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -18,7 +18,6 @@ - ignore: {name: "Avoid lambda using `infix`"} - ignore: {name: "Fuse mapM/map"} - ignore: {name: "Eta reduce"} # This warning will often make suggestions that are no longer valid due to simplified subsumption -- ignore: {name: "Redundant fmap"} - ignore: {name: "Redundant <$>"} - ignore: {name: "Use any"} - ignore: {name: "Use fromRight"} diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 9ce8554f36..737ce2c3ff 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -300,7 +300,7 @@ lintImportDecl env mni qualifierName names ss declType allowImplicit = dtys :: ModuleName -> M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource) - dtys mn = maybe M.empty exportedTypes $ envModuleExports <$> mn `M.lookup` env + dtys mn = foldMap (exportedTypes . envModuleExports) $ mn `M.lookup` env dctorsForType :: ModuleName From 09f9ba39a52a65f10c4140d696010392dd9b8988 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 24 Sep 2022 21:37:12 -0400 Subject: [PATCH 1493/1580] HLint fix: "Use any" --- .hlint.yaml | 1 - src/Language/PureScript/Linter/Exhaustive.hs | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 64ceeb40f0..8a86448870 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -19,7 +19,6 @@ - ignore: {name: "Fuse mapM/map"} - ignore: {name: "Eta reduce"} # This warning will often make suggestions that are no longer valid due to simplified subsumption - ignore: {name: "Redundant <$>"} -- ignore: {name: "Use any"} - ignore: {name: "Use fromRight"} - ignore: {name: "Use maybe"} - ignore: {name: "Use unzip"} diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 70f720d1c0..dca9e5a62a 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -204,7 +204,7 @@ missingCasesMultiple env mn = go isExhaustiveGuard :: Environment -> ModuleName -> [GuardedExpr] -> Bool isExhaustiveGuard _ _ [MkUnguarded _] = True isExhaustiveGuard env moduleName gs = - not . null $ filter (\(GuardedExpr grd _) -> isExhaustive grd) gs + any (\(GuardedExpr grd _) -> isExhaustive grd) gs where isExhaustive :: [Guard] -> Bool isExhaustive = all checkGuard From 3b7a771ce927639cfab1037577cf351df4021422 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 24 Sep 2022 21:44:16 -0400 Subject: [PATCH 1494/1580] HLint fix: "Use fromRight" --- .hlint.yaml | 1 - src/Language/PureScript/Linter/Exhaustive.hs | 2 +- src/Language/PureScript/PSString.hs | 3 ++- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 8a86448870..e0b2e54a24 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -19,7 +19,6 @@ - ignore: {name: "Fuse mapM/map"} - ignore: {name: "Eta reduce"} # This warning will often make suggestions that are no longer valid due to simplified subsumption - ignore: {name: "Redundant <$>"} -- ignore: {name: "Use fromRight"} - ignore: {name: "Use maybe"} - ignore: {name: "Use unzip"} - ignore: {name: "Use <=<"} diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index dca9e5a62a..a55e766f87 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -255,7 +255,7 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' in (missed', ( if null approx then liftA2 (&&) cond nec else Left Incomplete - , if either (const True) id cond + , if and cond then redundant else caseAlternativeBinders ca : redundant ) diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index 61cfd77efa..96379e9890 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -17,6 +17,7 @@ import Control.Exception (try, evaluate) import Control.Applicative ((<|>)) import qualified Data.Char as Char import Data.Bits (shiftR) +import Data.Either (fromRight) import Data.List (unfoldr) import Data.Scientific (toBoundedInteger) import Data.String (IsString(..)) @@ -72,7 +73,7 @@ codePoints = map (either (Char.chr . fromIntegral) id) . decodeStringEither -- U+FFFD REPLACEMENT CHARACTER -- decodeStringWithReplacement :: PSString -> String -decodeStringWithReplacement = map (either (const '\xFFFD') id) . decodeStringEither +decodeStringWithReplacement = map (fromRight '\xFFFD') . decodeStringEither -- | -- Decode a PSString as UTF-16. Lone surrogates in the input are represented in From f8e2cfad89aced513705406b9d0f18d1d5fce8ee Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 24 Sep 2022 21:47:23 -0400 Subject: [PATCH 1495/1580] HLint fix: "Use maybe" --- .hlint.yaml | 1 - src/Language/PureScript/Ide/State.hs | 3 +-- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index e0b2e54a24..27e9656bc7 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -19,7 +19,6 @@ - ignore: {name: "Fuse mapM/map"} - ignore: {name: "Eta reduce"} # This warning will often make suggestions that are no longer valid due to simplified subsumption - ignore: {name: "Redundant <$>"} -- ignore: {name: "Use maybe"} - ignore: {name: "Use unzip"} - ignore: {name: "Use <=<"} diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 644e40c107..eaa1683d99 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -401,8 +401,7 @@ resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) getDeclarations :: P.ModuleName -> [IdeDeclaration] getDeclarations moduleName = Map.lookup moduleName modules - & fromMaybe [] - & map discardAnn + & foldMap (map discardAnn) resolveOperator (IdeDeclValueOperator op) | (P.Qualified (P.ByModuleName mn) (Left ident)) <- op ^. ideValueOpAlias = From 7ac3f6e05cf705587da83a7be358c25d0e770b87 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 24 Sep 2022 22:08:17 -0400 Subject: [PATCH 1496/1580] HLint fix: "Use unzip" --- .hlint.yaml | 1 - src/Language/PureScript/Ide/State.hs | 6 +++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 27e9656bc7..1c884c64eb 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -19,7 +19,6 @@ - ignore: {name: "Fuse mapM/map"} - ignore: {name: "Eta reduce"} # This warning will often make suggestions that are no longer valid due to simplified subsumption - ignore: {name: "Redundant <$>"} -- ignore: {name: "Use unzip"} - ignore: {name: "Use <=<"} diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index eaa1683d99..7f947a91b3 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -37,15 +37,15 @@ module Language.PureScript.Ide.State , resolveDataConstructorsForModule ) where -import Protolude hiding (moduleName) +import Protolude hiding (moduleName, unzip) -import Control.Arrow import Control.Concurrent.STM import Control.Lens hiding (anyOf, op, (&)) import "monad-logger" Control.Monad.Logger import Data.IORef import qualified Data.Map.Lazy as Map import Data.Time.Clock (UTCTime) +import Data.Zip (unzip) import qualified Language.PureScript as P import Language.PureScript.Docs.Convert.Single (convertComments) import Language.PureScript.Externs @@ -225,7 +225,7 @@ populateVolatileStateSTM ref = do -- through the repopulation rebuildCache <- vsCachedRebuild <$> getVolatileStateSTM ref let asts = map (extractAstInformation . fst) modules - let (moduleDeclarations, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs) + let (moduleDeclarations, reexportRefs) = unzip (Map.map convertExterns externs) results = moduleDeclarations & map resolveDataConstructorsForModule From 7aa22d4923831cdf0e608b308561a619ce999652 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 24 Sep 2022 22:16:42 -0400 Subject: [PATCH 1497/1580] HLint fix: "Use <=<" --- .hlint.yaml | 1 - src/Language/PureScript/Docs/Convert/ReExports.hs | 6 +++--- src/Language/PureScript/TypeChecker/Entailment.hs | 2 +- 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 1c884c64eb..cd4df2a65f 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -19,7 +19,6 @@ - ignore: {name: "Fuse mapM/map"} - ignore: {name: "Eta reduce"} # This warning will often make suggestions that are no longer valid due to simplified subsumption - ignore: {name: "Redundant <$>"} -- ignore: {name: "Use <=<"} # Specify additional command line arguments diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 80e3a3e035..c2594749fd 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -12,9 +12,9 @@ import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.State.Strict (execState) import Data.Either -import Data.Foldable (traverse_) +import Data.Foldable (fold, traverse_) import Data.Map (Map) -import Data.Maybe (mapMaybe, fromMaybe) +import Data.Maybe (mapMaybe) import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T @@ -177,7 +177,7 @@ collectDeclarations reExports = do mapMaybe (\(exportSrc, ref) -> (,exportSrc) <$> f ref) reExports expCtors :: [P.ProperName 'P.ConstructorName] - expCtors = concatMap (fromMaybe [] . (>>= snd) . P.getTypeRef . snd) reExports + expCtors = concatMap (fold . (snd <=< P.getTypeRef . snd)) reExports lookupValueDeclaration :: forall m. diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index c93d4d5aa9..f0c55e3b79 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -225,7 +225,7 @@ entails SolverOptions{..} constraint context hints = ctorModules _ = Nothing findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> QualifiedBy -> [TypeClassDict] - findDicts ctx cn = fmap (fmap NamedInstance) . foldMap NEL.toList . foldMap M.elems . (>>= M.lookup cn) . flip M.lookup ctx + findDicts ctx cn = fmap (fmap NamedInstance) . foldMap NEL.toList . foldMap M.elems . (M.lookup cn <=< flip M.lookup ctx) valUndefined :: Expr valUndefined = Var nullSourceSpan (Qualified (ByModuleName C.Prim) (Ident C.undefined)) From ffabc646945430430f9d8447dda887c7035cbf4a Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 24 Sep 2022 22:32:27 -0400 Subject: [PATCH 1498/1580] Add changelog file --- CHANGELOG.d/internal_address-hlint-3-hints.md | 1 + 1 file changed, 1 insertion(+) create mode 100644 CHANGELOG.d/internal_address-hlint-3-hints.md diff --git a/CHANGELOG.d/internal_address-hlint-3-hints.md b/CHANGELOG.d/internal_address-hlint-3-hints.md new file mode 100644 index 0000000000..e8cdca7a29 --- /dev/null +++ b/CHANGELOG.d/internal_address-hlint-3-hints.md @@ -0,0 +1 @@ +* Bump HLint to version 3.5 and address most of the new hints From 6357697a0a5280a4572f66ba7c3e69fed6693a49 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Sun, 25 Sep 2022 15:10:09 +0800 Subject: [PATCH 1499/1580] Improve error spans for class and instance declarations (#4383) --- CHANGELOG.d/fix_4382.md | 40 ++++++++++++++ src/Language/PureScript/AST/Declarations.hs | 9 ++- src/Language/PureScript/AST/Exported.hs | 2 +- src/Language/PureScript/AST/Traversals.hs | 16 +++--- src/Language/PureScript/CST/Convert.hs | 12 +++- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- .../PureScript/Docs/Convert/Single.hs | 4 +- src/Language/PureScript/Linter.hs | 2 +- .../PureScript/Sugar/CaseDeclarations.hs | 4 +- src/Language/PureScript/Sugar/Names.hs | 14 ++--- src/Language/PureScript/Sugar/Operators.hs | 4 +- src/Language/PureScript/Sugar/TypeClasses.hs | 4 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 4 +- .../PureScript/Sugar/TypeDeclarations.hs | 4 +- src/Language/PureScript/TypeChecker.hs | 4 +- tests/purs/failing/4382.out | 55 +++++++++++++++++++ tests/purs/failing/4382.purs | 20 +++++++ 17 files changed, 163 insertions(+), 37 deletions(-) create mode 100644 CHANGELOG.d/fix_4382.md create mode 100644 tests/purs/failing/4382.out create mode 100644 tests/purs/failing/4382.purs diff --git a/CHANGELOG.d/fix_4382.md b/CHANGELOG.d/fix_4382.md new file mode 100644 index 0000000000..8f4e9ed3d4 --- /dev/null +++ b/CHANGELOG.d/fix_4382.md @@ -0,0 +1,40 @@ +* Improve error spans for class and instance declarations + + This improves the error spans for class and instance + declarations. Instead of highlighting the entire class or instance + declaration when `UnknownName` is thrown, the compiler now + highlights the class name and its arguments. + + Before: + ```purs + [1/2 UnknownName] + + 5 class G a <= F a + ^^^^^^^^^^^^^^^^ + + Unknown type class G + + [2/2 UnknownName] + + 7 instance G a => F a + ^^^^^^^^^^^^^^^^^^^ + + Unknown type class G + ``` + + After: + ```purs + [1/2 UnknownName] + + 5 class G a <= F a + ^^^ + + Unknown type class G + + [2/2 UnknownName] + + 7 instance G a => F a + ^^^ + + Unknown type class G + ``` diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 07eb3c69da..d1617bb172 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -428,7 +428,10 @@ data Declaration -- A type instance declaration (instance chain, chain index, name, -- dependencies, class name, instance types, member declarations) -- - | TypeInstanceDeclaration SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody + -- The first @SourceAnn@ serves as the annotation for the entire + -- declaration, while the second @SourceAnn@ serves as the + -- annotation for the type class and its arguments. + | TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody deriving (Show) data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName) @@ -491,7 +494,7 @@ declSourceAnn (ExternDataDeclaration sa _ _) = sa declSourceAnn (FixityDeclaration sa _) = sa declSourceAnn (ImportDeclaration sa _ _ _) = sa declSourceAnn (TypeClassDeclaration sa _ _ _ _ _) = sa -declSourceAnn (TypeInstanceDeclaration sa _ _ _ _ _ _ _) = sa +declSourceAnn (TypeInstanceDeclaration sa _ _ _ _ _ _ _ _) = sa declSourceSpan :: Declaration -> SourceSpan declSourceSpan = fst . declSourceAnn @@ -508,7 +511,7 @@ declName (ExternDataDeclaration _ n _) = Just (TyName n) declName (FixityDeclaration _ (Left (ValueFixity _ _ n))) = Just (ValOpName n) declName (FixityDeclaration _ (Right (TypeFixity _ _ n))) = Just (TyOpName n) declName (TypeClassDeclaration _ n _ _ _ _) = Just (TyClassName n) -declName (TypeInstanceDeclaration _ _ _ n _ _ _ _) = IdentName <$> hush n +declName (TypeInstanceDeclaration _ _ _ _ n _ _ _ _) = IdentName <$> hush n declName (RoleDeclaration RoleDeclarationData{..}) = Just (TyName rdeclIdent) declName ImportDeclaration{} = Nothing declName BindingGroupDeclaration{} = Nothing diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index 831149d8ef..c284cde1bf 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -104,7 +104,7 @@ filterInstances mn (Just exps) = -- Get all type and type class names referenced by a type instance declaration. -- typeInstanceConstituents :: Declaration -> [Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))] -typeInstanceConstituents (TypeInstanceDeclaration _ _ _ _ constraints className tys _) = +typeInstanceConstituents (TypeInstanceDeclaration _ _ _ _ _ constraints className tys _) = Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys) where diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index ee115297ce..a8df39c648 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -62,7 +62,7 @@ everywhereOnValues f g h = (f', g', h') f' (BoundValueDeclaration sa b expr) = f (BoundValueDeclaration sa (h' b) (g' expr)) f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (fmap (\(name, nameKind, val) -> (name, nameKind, g' val)) ds)) f' (TypeClassDeclaration sa name args implies deps ds) = f (TypeClassDeclaration sa name args implies deps (fmap f' ds)) - f' (TypeInstanceDeclaration sa ch idx name cs className args ds) = f (TypeInstanceDeclaration sa ch idx name cs className args (mapTypeInstanceBody (fmap f') ds)) + f' (TypeInstanceDeclaration sa na ch idx name cs className args ds) = f (TypeInstanceDeclaration sa na ch idx name cs className args (mapTypeInstanceBody (fmap f') ds)) f' other = f other g' :: Expr -> Expr @@ -135,7 +135,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) ValueDecl sa name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (name, nameKind, ) <$> (g val >>= g')) ds f' (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f' <=< f) ds - f' (TypeInstanceDeclaration sa ch idx name cs className args ds) = TypeInstanceDeclaration sa ch idx name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds + f' (TypeInstanceDeclaration sa na ch idx name cs className args ds) = TypeInstanceDeclaration sa na ch idx name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds f' (BoundValueDeclaration sa b expr) = BoundValueDeclaration sa <$> (h' <=< h) b <*> (g' <=< g) expr f' other = f other @@ -205,7 +205,7 @@ everywhereOnValuesM f g h = (f', g', h') f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (name, nameKind, ) <$> g' val) ds) >>= f f' (BoundValueDeclaration sa b expr) = (BoundValueDeclaration sa <$> h' b <*> g' expr) >>= f f' (TypeClassDeclaration sa name args implies deps ds) = (TypeClassDeclaration sa name args implies deps <$> traverse f' ds) >>= f - f' (TypeInstanceDeclaration sa ch idx name cs className args ds) = (TypeInstanceDeclaration sa ch idx name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f + f' (TypeInstanceDeclaration sa na ch idx name cs className args ds) = (TypeInstanceDeclaration sa na ch idx name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f f' other = f other g' :: Expr -> m Expr @@ -276,7 +276,7 @@ everythingOnValues (<>.) f g h i j = (f', g', h', i', j') f' d@(ValueDeclaration vd) = foldl (<>.) (f d) (fmap h' (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) (valdeclExpression vd)) f' d@(BindingGroupDeclaration ds) = foldl (<>.) (f d) (fmap (\(_, _, val) -> g' val) ds) f' d@(TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>.) (f d) (fmap f' ds) - f' d@(TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>.) (f d) (fmap f' ds) + f' d@(TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>.) (f d) (fmap f' ds) f' d@(BoundValueDeclaration _ b expr) = f d <>. h' b <>. g' expr f' d = f d @@ -355,7 +355,7 @@ everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i f' s (ValueDeclaration vd) = foldl (<>.) r0 (fmap (h'' s) (valdeclBinders vd) ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) (valdeclExpression vd)) f' s (BindingGroupDeclaration ds) = foldl (<>.) r0 (fmap (\(_, _, val) -> g'' s val) ds) f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>.) r0 (fmap (f'' s) ds) - f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>.) r0 (fmap (f'' s) ds) + f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>.) r0 (fmap (f'' s) ds) f' _ _ = r0 g'' :: s -> Expr -> r @@ -465,7 +465,7 @@ everywhereWithContextOnValuesM s0 f g h i j k = (f'' s0, g'' s0, h'' s0, i'' s0, ValueDecl sa name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds f' s (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f'' s) ds - f' s (TypeInstanceDeclaration sa ch idx name cs className args ds) = TypeInstanceDeclaration sa ch idx name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds + f' s (TypeInstanceDeclaration sa na ch idx name cs className args ds) = TypeInstanceDeclaration sa na ch idx name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds f' _ other = return other g'' s = uncurry g' <=< g s @@ -569,7 +569,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> ToplevelIdent name) ds))) in foldMap (\(_, _, val) -> g'' s' val) ds f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldMap (f'' s) ds - f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds + f' s (TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds f' _ _ = mempty g'' :: S.Set ScopedIdent -> Expr -> r @@ -677,7 +677,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues forBinders (const m forDecls (TypeClassDeclaration _ _ args implies _ _) = foldMap (foldMap (foldMap f)) args <> foldMap (foldMap f . constraintArgs) implies - forDecls (TypeInstanceDeclaration _ _ _ _ cs _ tys _) = + forDecls (TypeInstanceDeclaration _ _ _ _ _ cs _ tys _) = foldMap (foldMap f . constraintArgs) cs <> foldMap f tys forDecls (TypeSynonymDeclaration _ _ args ty) = foldMap (foldMap f . snd) args <> diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index d0be2c92d4..3b750e2fd9 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -477,7 +477,8 @@ convertDeclaration fileName decl = case decl of chainId = mkChainId fileName $ startSourcePos $ instKeyword $ instHead $ sepHead insts goInst ix inst@(Instance (InstanceHead _ nameSep ctrs cls args) bd) = do let ann' = uncurry (sourceAnnCommented fileName) $ instanceRange inst - AST.TypeInstanceDeclaration ann' chainId ix + clsAnn = findInstanceAnn cls args + AST.TypeInstanceDeclaration ann' clsAnn chainId ix (mkPartialInstanceName nameSep cls args) (convertConstraint fileName <$> maybe [] (toList . fst) ctrs) (qualified cls) @@ -491,7 +492,8 @@ convertDeclaration fileName decl = case decl of instTy | isJust new = AST.NewtypeInstance | otherwise = AST.DerivedInstance - pure $ AST.TypeInstanceDeclaration ann chainId 0 name' + clsAnn = findInstanceAnn cls args + pure $ AST.TypeInstanceDeclaration ann clsAnn chainId 0 name' (convertConstraint fileName <$> maybe [] (toList . fst) ctrs) (qualified cls) (convertType fileName <$> args) @@ -601,6 +603,12 @@ convertDeclaration fileName decl = case decl of let ann' = uncurry (sourceAnnCommented fileName) $ instanceBindingRange binding convertValueBindingFields fileName ann' fields + findInstanceAnn cls args = uncurry (sourceAnnCommented fileName) $ + if null args then + qualRange cls + else + (fst $ qualRange cls, snd $ typeRange $ last args) + convertSignature :: String -> Labeled (Name Ident) (Type a) -> AST.Declaration convertSignature fileName (Labeled a _ b) = do let diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 37209c6602..e881d0545f 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -213,7 +213,7 @@ findQualModules decls = in f `concatMap` decls where fqDecls :: A.Declaration -> [ModuleName] - fqDecls (A.TypeInstanceDeclaration _ _ _ _ _ q _ _) = getQual' q + fqDecls (A.TypeInstanceDeclaration _ _ _ _ _ _ q _ _) = getQual' q fqDecls (A.ValueFixityDeclaration _ _ q _) = getQual' q fqDecls (A.TypeFixityDeclaration _ _ q _) = getQual' q fqDecls _ = [] diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index a86603ca94..8cd99da145 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -134,7 +134,7 @@ getDeclarationTitle (P.DataDeclaration _ _ name _ _) = Just (P.runProperName nam getDeclarationTitle (P.ExternDataDeclaration _ name _) = Just (P.runProperName name) getDeclarationTitle (P.TypeSynonymDeclaration _ name _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeClassDeclaration _ name _ _ _ _) = Just (P.runProperName name) -getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ name _ _ _ _) = Just $ either (const "") P.showIdent name +getDeclarationTitle (P.TypeInstanceDeclaration _ _ _ _ name _ _ _ _) = Just $ either (const "") P.showIdent name getDeclarationTitle (P.TypeFixityDeclaration _ _ _ op) = Just ("type " <> P.showOp op) getDeclarationTitle (P.ValueFixityDeclaration _ _ _ op) = Just (P.showOp op) getDeclarationTitle (P.KindDeclaration _ _ n _) = Just (P.runProperName n) @@ -187,7 +187,7 @@ convertDeclaration (P.TypeClassDeclaration sa _ args implies fundeps ds) title = ChildDeclaration (P.showIdent ident') (convertComments com) (Just ss) (ChildTypeClassMember (ty $> ())) convertClassMember _ = P.internalError "convertDeclaration: Invalid argument to convertClassMember." -convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ _ _ constraints className tys _) title = +convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ _ _ _ constraints className tys _) title = Just (Left ((classNameString, AugmentClass) : map (, AugmentType) typeNameStrings, AugmentChild childDecl)) where classNameString = unQual className diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index e669cb2825..90c2928d92 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -183,7 +183,7 @@ lintUnused (Module modSS _ mn modDecls exports) = in (vars, errs') - goDecl (TypeInstanceDeclaration _ _ _ _ _ _ _ (ExplicitInstance decls)) = mconcat $ map goDecl decls + goDecl (TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance decls)) = mconcat $ map goDecl decls goDecl _ = mempty go :: Expr -> (S.Set Ident, MultipleErrors) diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 5215bb42d7..b4767006c4 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -327,8 +327,8 @@ desugarCases :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Decla desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup where desugarRest :: [Declaration] -> m [Declaration] - desugarRest (TypeInstanceDeclaration sa cd idx name constraints className tys ds : rest) = - (:) <$> (TypeInstanceDeclaration sa cd idx name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest + desugarRest (TypeInstanceDeclaration sa na cd idx name constraints className tys ds : rest) = + (:) <$> (TypeInstanceDeclaration sa na cd idx name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest desugarRest (ValueDecl sa name nameKind bs result : rest) = let (_, f, _) = everywhereOnValuesTopDownM return go return f' = mapM (\(GuardedExpr gs e) -> GuardedExpr gs <$> f e) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 7b672025a0..0e1eed109e 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -196,17 +196,17 @@ renameInModule imports (Module modSS coms mn decls exps) = TypeSynonymDeclaration sa name <$> updateTypeArguments ps <*> updateTypesEverywhere ty - updateDecl bound (TypeClassDeclaration sa@(ss, _) className args implies deps ds) = + updateDecl bound (TypeClassDeclaration sa className args implies deps ds) = fmap (bound,) $ TypeClassDeclaration sa className <$> updateTypeArguments args - <*> updateConstraints ss implies + <*> updateConstraints implies <*> pure deps <*> pure ds - updateDecl bound (TypeInstanceDeclaration sa@(ss, _) ch idx name cs cn ts ds) = + updateDecl bound (TypeInstanceDeclaration sa na@(ss, _) ch idx name cs cn ts ds) = fmap (bound,) $ - TypeInstanceDeclaration sa ch idx name - <$> updateConstraints ss cs + TypeInstanceDeclaration sa na ch idx name + <$> updateConstraints cs <*> updateClassName cn ss <*> traverse updateTypesEverywhere ts <*> pure ds @@ -352,8 +352,8 @@ renameInModule imports (Module modSS coms mn decls exps) = updateInConstraint (Constraint ann@(ss, _) name ks ts info) = Constraint ann <$> updateClassName name ss <*> pure ks <*> pure ts <*> pure info - updateConstraints :: SourceSpan -> [SourceConstraint] -> m [SourceConstraint] - updateConstraints pos = traverse $ \(Constraint ann name ks ts info) -> + updateConstraints :: [SourceConstraint] -> m [SourceConstraint] + updateConstraints = traverse $ \(Constraint ann@(pos, _) name ks ts info) -> Constraint ann <$> updateClassName name pos <*> traverse updateTypesEverywhere ks diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 3ce7d0986f..9542d4b669 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -380,10 +380,10 @@ updateTypes goType = (goDecl, goExpr, goBinder) implies' <- traverse (overConstraintArgs (traverse (goType' ss))) implies args' <- traverse (traverse (traverse (goType' ss))) args return $ TypeClassDeclaration sa name args' implies' deps decls - goDecl (TypeInstanceDeclaration sa@(ss, _) ch idx name cs className tys impls) = do + goDecl (TypeInstanceDeclaration sa@(ss, _) na ch idx name cs className tys impls) = do cs' <- traverse (overConstraintArgs (traverse (goType' ss))) cs tys' <- traverse (goType' ss) tys - return $ TypeInstanceDeclaration sa ch idx name cs' className tys' impls + return $ TypeInstanceDeclaration sa na ch idx name cs' className tys' impls goDecl (TypeSynonymDeclaration sa@(ss, _) name args ty) = TypeSynonymDeclaration sa name <$> traverse (traverse (traverse (goType' ss))) args diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 4b1ad466a2..62168d39f1 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -206,9 +206,9 @@ desugarDecl mn exps = go go d@(TypeClassDeclaration sa name args implies deps members) = do modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False)) return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) - go (TypeInstanceDeclaration sa chainId idx name deps className tys body) = do + go (TypeInstanceDeclaration sa na chainId idx name deps className tys body) = do name' <- desugarInstName name - let d = TypeInstanceDeclaration sa chainId idx (Right name') deps className tys body + let d = TypeInstanceDeclaration sa na chainId idx (Right name') deps className tys body let explicitOrNot = case body of DerivedInstance -> Left $ DerivedInstancePlaceholder className KnownClassStrategy NewtypeInstance -> Left $ DerivedInstancePlaceholder className NewtypeStrategy diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 2b9c8cfafa..ebec719d75 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -46,7 +46,7 @@ deriveInstance -> m Declaration deriveInstance mn ds decl = case decl of - TypeInstanceDeclaration sa@(ss, _) ch idx nm deps className tys DerivedInstance -> let + TypeInstanceDeclaration sa@(ss, _) na ch idx nm deps className tys DerivedInstance -> let binaryWildcardClass :: (Declaration -> [SourceType] -> m ([Declaration], SourceType)) -> m Declaration binaryWildcardClass f = case tys of [ty1, ty2] -> case unwrapTypeConstructor ty1 of @@ -54,7 +54,7 @@ deriveInstance mn ds decl = checkIsWildcard ss tyCon ty2 tyConDecl <- findTypeDecl ss tyCon ds (members, ty2') <- f tyConDecl args - pure $ TypeInstanceDeclaration sa ch idx nm deps className [ty1, ty2'] (ExplicitInstance members) + pure $ TypeInstanceDeclaration sa na ch idx nm deps className [ty1, ty2'] (ExplicitInstance members) _ -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty1 _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 19c0abbdd5..acd3eed142 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -51,8 +51,8 @@ desugarTypeDeclarationsModule (Module modSS coms name ds exps) = where go (Let w ds' val') = Let w <$> desugarTypeDeclarations ds' <*> pure val' go other = return other - desugarTypeDeclarations (TypeInstanceDeclaration sa ch idx nm deps cls args (ExplicitInstance ds') : rest) = - (:) <$> (TypeInstanceDeclaration sa ch idx nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds') + desugarTypeDeclarations (TypeInstanceDeclaration sa na ch idx nm deps cls args (ExplicitInstance ds') : rest) = + (:) <$> (TypeInstanceDeclaration sa na ch idx nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds') <*> desugarTypeDeclarations rest desugarTypeDeclarations (d:rest) = (:) d <$> desugarTypeDeclarations rest desugarTypeDeclarations [] = return [] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 91911662dd..9caba12fc3 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -409,8 +409,8 @@ typeCheckAll moduleName = traverse go (args', implies', tys', kind) <- kindOfClass moduleName (sa, pn, args, implies, tys) addTypeClass moduleName qualifiedClassName (fmap Just <$> args') implies' deps tys' kind return d - go (TypeInstanceDeclaration _ _ _ (Left _) _ _ _ _) = internalError "typeCheckAll: type class instance generated name should have been desugared" - go d@(TypeInstanceDeclaration sa@(ss, _) ch idx (Right dictName) deps className tys body) = + go (TypeInstanceDeclaration _ _ _ _ (Left _) _ _ _ _) = internalError "typeCheckAll: type class instance generated name should have been desugared" + go d@(TypeInstanceDeclaration sa@(ss, _) _ ch idx (Right dictName) deps className tys body) = rethrow (addHint (ErrorInInstance className tys) . addHint (positionedError ss)) $ do env <- getEnv let qualifiedDictName = Qualified (ByModuleName moduleName) dictName diff --git a/tests/purs/failing/4382.out b/tests/purs/failing/4382.out new file mode 100644 index 0000000000..2e3ccee3fc --- /dev/null +++ b/tests/purs/failing/4382.out @@ -0,0 +1,55 @@ +Error 1 of 5: + + in module Main + at tests/purs/failing/4382.purs:10:7 - 10:14 (line 10, column 7 - line 10, column 14) + + Unknown type class Rinku + + + See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, + or to contribute content related to this error. + +Error 2 of 5: + + in module Main + at tests/purs/failing/4382.purs:13:10 - 13:17 (line 13, column 10 - line 13, column 17) + + Unknown type class Rinku + + + See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, + or to contribute content related to this error. + +Error 3 of 5: + + in module Main + at tests/purs/failing/4382.purs:16:10 - 16:17 (line 16, column 10 - line 16, column 17) + + Unknown type class Rinku + + + See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, + or to contribute content related to this error. + +Error 4 of 5: + + in module Main + at tests/purs/failing/4382.purs:18:17 - 18:28 (line 18, column 17 - line 18, column 28) + + Unknown type class Rinku + + + See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, + or to contribute content related to this error. + +Error 5 of 5: + + in module Main + at tests/purs/failing/4382.purs:20:25 - 20:36 (line 20, column 25 - line 20, column 36) + + Unknown type class Rinku + + + See https://github.com/purescript/documentation/blob/master/errors/UnknownName.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/failing/4382.purs b/tests/purs/failing/4382.purs new file mode 100644 index 0000000000..f1ebae9da0 --- /dev/null +++ b/tests/purs/failing/4382.purs @@ -0,0 +1,20 @@ +-- @shouldFailWith UnknownName +-- @shouldFailWith UnknownName +-- @shouldFailWith UnknownName +-- @shouldFailWith UnknownName +-- @shouldFailWith UnknownName +module Main where + +newtype T a = T a + +class Rinku a <= Maho a where + tPose :: a -> a + +instance Rinku a => Maho a where + tPose = \a -> a + +instance Rinku a + +derive instance Rinku (T a) + +derive newtype instance Rinku (T a) From 58290ce89c11f580759e6fde45bdb93f646f0430 Mon Sep 17 00:00:00 2001 From: Erik Mattfolk Date: Tue, 27 Sep 2022 04:51:16 +0200 Subject: [PATCH 1500/1580] Add note about tests that do not produce warnings (#4393) --- CONTRIBUTING.md | 12 +++++++++++- CONTRIBUTORS.md | 1 + 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 45e72f452c..219f7ba701 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -23,12 +23,22 @@ If you would like to contribute, please consider the issues in the current miles When submitting a pull request, please follow the following guidelines: -- Add at least a test to `tests/purs/passing/` and possibly to `tests/purs/failing/`. +- Add tests according to the next section - Build the binaries and libraries with `stack build --fast`. The `--fast` flag is recommended but not required; it disables optimizations, which can speed things up quite a bit. - Make sure that all test suites are passing. Run the test suites with `stack test --fast`. - Please try to keep changes small and isolated: smaller pull requests which only address one issue are much easier to review. - For any code change, please append a copyright and licensing notice to the [CONTRIBUTORS.md](CONTRIBUTORS.md) file if your name is not in there already. +### Writing Tests + +When writing tests, try to have at least one passing test and one failing test, if applicable. + +- Passing tests go in `tests/purs/passing/` +- Failing tests go in `tests/purs/failing/` +- Tests that check warnings go in `tests/purs/warning/` + +Passing tests may produce warnings. Tests in `tests/purs/warning/` can ensure no warning is emitted by having no annotations and an empty `.out` file. + ### Running Tests Run all test suites with `stack test`. You will need `npm`, `bower` and `node` on your PATH to run the tests. diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 68aafb4bff..760fd5d044 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -44,6 +44,7 @@ If you would prefer to use different terms, please use the section below instead | [@kleeneplus](https://github.com/dgendill) | Dominick Gendill | [MIT license](http://opensource.org/licenses/MIT) | | [@ealmansi](https://github.com/ealmansi) | Emilio Almansi | MIT license | | [@eamelink](https://github.com/eamelink) | Erik Bakker | MIT license | +| [@EMattfolk](https://github.com/EMattfolk) | Erik Mattfolk | [MIT license](http://opensource.org/licenses/MIT) | | [@epost](https://github.com/epost) | Erik Post | MIT license | | [@erdeszt](https://github.com/erdeszt) | Tibor Erdesz | [MIT license](http://opensource.org/licenses/MIT) | | [@etrepum](https://github.com/etrepum) | Bob Ippolito | [MIT license](http://opensource.org/licenses/MIT) | From 61393c5c8b7561f4f3c3a3cbf549fc38735103b2 Mon Sep 17 00:00:00 2001 From: Pete Murphy <26548438+ptrfrncsmrph@users.noreply.github.com> Date: Mon, 26 Sep 2022 23:03:18 -0400 Subject: [PATCH 1501/1580] Remove purescript-cst from Makefile (#4389) --- CHANGELOG.d/internal_remove-purescript-cst-from-makefile.md | 1 + Makefile | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) create mode 100644 CHANGELOG.d/internal_remove-purescript-cst-from-makefile.md diff --git a/CHANGELOG.d/internal_remove-purescript-cst-from-makefile.md b/CHANGELOG.d/internal_remove-purescript-cst-from-makefile.md new file mode 100644 index 0000000000..cc7ef30758 --- /dev/null +++ b/CHANGELOG.d/internal_remove-purescript-cst-from-makefile.md @@ -0,0 +1 @@ +* Remove `purescript-cst` from Makefile \ No newline at end of file diff --git a/Makefile b/Makefile index 2cba9b5918..53da1f3710 100644 --- a/Makefile +++ b/Makefile @@ -19,10 +19,10 @@ help: ## Print documentation @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' ghcid: ## Run ghcid to quickly reload code on save. - ghcid --command "stack ghci purescript:exe:purs purescript:lib purescript:test:tests purescript-cst --main-is purescript:exe:purs --ghci-options -fno-code" + ghcid --command "stack ghci purescript:exe:purs purescript:lib purescript:test:tests --main-is purescript:exe:purs --ghci-options -fno-code" ghcid-test: ## Run ghcid to quickly reload code and run tests on save. - ghcid --command "stack ghci purescript:lib purescript:test:tests purescript-cst --ghci-options -fobject-code" \ + ghcid --command "stack ghci purescript:lib purescript:test:tests --ghci-options -fobject-code" \ --test "Main.main" build: ## Build the package. From 5c3055bb6d3493842ff8ca93aeaf76f44e2b34d8 Mon Sep 17 00:00:00 2001 From: Cotton Hou Date: Tue, 27 Sep 2022 11:12:59 +0800 Subject: [PATCH 1502/1580] Bump depend NPM purescript-installer to ^0.3.1 (#4353) --- CHANGELOG.d/internal_bump-npm-purescript-installer-0-3-1.md | 1 + CONTRIBUTORS.md | 1 + npm-package/package.json | 2 +- 3 files changed, 3 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/internal_bump-npm-purescript-installer-0-3-1.md diff --git a/CHANGELOG.d/internal_bump-npm-purescript-installer-0-3-1.md b/CHANGELOG.d/internal_bump-npm-purescript-installer-0-3-1.md new file mode 100644 index 0000000000..7d9d1b48e9 --- /dev/null +++ b/CHANGELOG.d/internal_bump-npm-purescript-installer-0-3-1.md @@ -0,0 +1 @@ +* Bump depend NPM purescript-installer to ^0.3.1 \ No newline at end of file diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 760fd5d044..a4898e4b69 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -158,6 +158,7 @@ If you would prefer to use different terms, please use the section below instead | [@i-am-the-slime](https://github.com/i-am-the-slime) | Mark Eibes | [MIT license](http://opensource.org/licenses/MIT) | | [@sd-yip](https://github.com/sd-yip) | Nicholas Yip | [MIT license](http://opensource.org/licenses/MIT) | | [@j-nava](https://github.com/j-nava) | Jesse Nava | [MIT license](http://opensource.org/licenses/MIT) | +| [@imcotton](https://github.com/imcotton) | Cotton Hou | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/npm-package/package.json b/npm-package/package.json index ce29f45dac..78d7e4a12d 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -15,7 +15,7 @@ "purs": "purs.bin" }, "dependencies": { - "purescript-installer": "^0.2.6" + "purescript-installer": "^0.3.1" }, "homepage": "https://github.com/purescript/purescript", "repository": { From 782c836a4f4fd70294c4d9a614b997c5d1fa2096 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Tue, 27 Sep 2022 20:11:25 +0800 Subject: [PATCH 1503/1580] Invalidate the CI cache when containers are changed (#4394) * Include job.container.id in cache key --- .github/workflows/ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index af05bccb69..8eb1a72572 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -84,7 +84,7 @@ jobs: path: | /root/.stack ${{ steps.haskell.outputs.stack-root }} - key: "${{ runner.os }}-MdyPsf-${{ hashFiles('stack.yaml') }}" + key: "${{ runner.os }}-${{ job.container.id }}-MdyPsf-${{ hashFiles('stack.yaml') }}" - name: "(Windows only) Configure Stack to store its programs in STACK_ROOT" # This ensures that the local GHC and MSYS binaries that Stack installs @@ -192,7 +192,7 @@ jobs: with: path: | /root/.stack - key: "${{ runner.os }}-UnWw0N-lint-${{ hashFiles('stack.yaml') }}" + key: "${{ runner.os }}-${{ job.container.id }}-UnWw0N-lint-${{ hashFiles('stack.yaml') }}" - run: "ci/fix-home ci/run-hlint.sh --git" env: From 052446335169fd0e36eace4a61c2f2aaf02ebcec Mon Sep 17 00:00:00 2001 From: Mike Solomon Date: Thu, 29 Sep 2022 20:11:45 +0300 Subject: [PATCH 1504/1580] Optimize mkST and runST family of functions (#4386) --- CHANGELOG.d/feature_optimize-uncurried-st.md | 1 + CONTRIBUTORS.md | 1 + src/Language/PureScript/Constants/Prelude.hs | 9 +++++++ .../PureScript/CoreImp/Optimizer/Inliner.hs | 3 ++- tests/purs/optimize/4386.out.js | 26 +++++++++++++++++++ tests/purs/optimize/4386.purs | 25 ++++++++++++++++++ tests/support/bower.json | 2 +- 7 files changed, 65 insertions(+), 2 deletions(-) create mode 100644 CHANGELOG.d/feature_optimize-uncurried-st.md create mode 100644 tests/purs/optimize/4386.out.js create mode 100644 tests/purs/optimize/4386.purs diff --git a/CHANGELOG.d/feature_optimize-uncurried-st.md b/CHANGELOG.d/feature_optimize-uncurried-st.md new file mode 100644 index 0000000000..66311a0633 --- /dev/null +++ b/CHANGELOG.d/feature_optimize-uncurried-st.md @@ -0,0 +1 @@ +* Add a compiler optimization for `ST` functions with up to 10 arity, similar to `Effect` optimizations. \ No newline at end of file diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index a4898e4b69..60e0b6fb31 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -76,6 +76,7 @@ If you would prefer to use different terms, please use the section below instead | [@matthewleon](https://github.com/matthewleon) | Matthew Leon | [MIT license](http://opensource.org/licenses/MIT) | | [@mcoffin](https://github.com/mcoffin) | Matt Coffin | [MIT license](http://opensource.org/licenses/MIT) | | [@mhcurylo](https://github.com/mhcurylo) | Mateusz Curylo | [MIT license](http://opensource.org/licenses/MIT) | +| [@mikesol](https://github.com/mikesol) | Mike Solomon | [MIT license](http://opensource.org/licenses/MIT) | | [@MiracleBlue](https://github.com/MiracleBlue) | Nicholas Kircher | [MIT license](http://opensource.org/licenses/MIT) | | [@mrkgnao](https://github.com/mrkgnao) | Soham Chowdhury | [MIT license](http://opensource.org/licenses/MIT) | | [@mgmeier](https://github.com/mgmeier) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index 29b20b0039..fd69bab0ae 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -169,6 +169,12 @@ mkEffectFn = "mkEffectFn" runEffectFn :: forall a. (IsString a) => a runEffectFn = "runEffectFn" +mkSTFn :: forall a. (IsString a) => a +mkSTFn = "mkSTFn" + +runSTFn :: forall a. (IsString a) => a +runSTFn = "runSTFn" + -- Type Class Dictionary Names data EffectDictionaries = EffectDictionaries @@ -334,6 +340,9 @@ pattern ControlMonadEffUncurried = ModuleName "Control.Monad.Eff.Uncurried" pattern EffectUncurried :: ModuleName pattern EffectUncurried = ModuleName "Effect.Uncurried" +pattern ControlMonadSTUncurried :: ModuleName +pattern ControlMonadSTUncurried = ModuleName "Control.Monad.ST.Uncurried" + pattern DataBounded :: ModuleName pattern DataBounded = ModuleName "Data.Bounded" diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index dc8f330fe4..51747467ed 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -171,7 +171,8 @@ inlineCommonOperators expander = everywhereTopDown $ applyAll $ ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++ [ fn | i <- [0..10], fn <- [ mkEffFn C.ControlMonadEffUncurried C.mkEffFn i, runEffFn C.ControlMonadEffUncurried C.runEffFn i ] ] ++ - [ fn | i <- [0..10], fn <- [ mkEffFn C.EffectUncurried C.mkEffectFn i, runEffFn C.EffectUncurried C.runEffectFn i ] ] + [ fn | i <- [0..10], fn <- [ mkEffFn C.EffectUncurried C.mkEffectFn i, runEffFn C.EffectUncurried C.runEffectFn i ] ] ++ + [ fn | i <- [0..10], fn <- [ mkEffFn C.ControlMonadSTUncurried C.mkSTFn i, runEffFn C.ControlMonadSTUncurried C.runSTFn i ] ] where binary :: (ModuleName, PSString) -> (ModuleName, PSString) -> BinaryOperator -> AST -> AST binary dict fns op = convert where diff --git a/tests/purs/optimize/4386.out.js b/tests/purs/optimize/4386.out.js new file mode 100644 index 0000000000..e2a2f80c7b --- /dev/null +++ b/tests/purs/optimize/4386.out.js @@ -0,0 +1,26 @@ +var mySTFn2 = function (a, b) { + return a + b | 0; +}; +var mySTFn1 = function (a) { + return a + 1 | 0; +}; +var myInt2 = function () { + return mySTFn2(0, 1); +}; +var myInt1 = function () { + return mySTFn1(0); +}; +var otherTest = function __do() { + var a = mySTFn2(0, 1); + var b = mySTFn1(2); + var c = myInt1(); + var d = myInt2(); + return ((a + b | 0) + c | 0) + d | 0; +}; +export { + mySTFn1, + mySTFn2, + myInt1, + myInt2, + otherTest +}; diff --git a/tests/purs/optimize/4386.purs b/tests/purs/optimize/4386.purs new file mode 100644 index 0000000000..be3832cce1 --- /dev/null +++ b/tests/purs/optimize/4386.purs @@ -0,0 +1,25 @@ +module Main where + +import Prelude +import Control.Monad.ST (ST) +import Control.Monad.ST.Uncurried (STFn1, STFn2, mkSTFn1, mkSTFn2, runSTFn1, runSTFn2) + +mySTFn1 :: forall r. STFn1 Int r Int +mySTFn1 = mkSTFn1 \a -> pure (a + 1) + +mySTFn2 :: forall r. STFn2 Int Int r Int +mySTFn2 = mkSTFn2 \a b -> pure (a + b) + +myInt1 :: forall r. ST r Int +myInt1 = runSTFn1 mySTFn1 0 + +myInt2 :: forall r. ST r Int +myInt2 = runSTFn2 mySTFn2 0 1 + +otherTest :: forall r. ST r Int +otherTest = do + a <- runSTFn2 mySTFn2 0 1 + b <- runSTFn1 mySTFn1 2 + c <- myInt1 + d <- myInt2 + pure $ a + b + c + d diff --git a/tests/support/bower.json b/tests/support/bower.json index dd4d3edec7..a0cd88be21 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -27,7 +27,7 @@ "purescript-psci-support": "^6.0.0", "purescript-refs": "^6.0.0", "purescript-safe-coerce": "^2.0.0", - "purescript-st": "^6.0.0", + "purescript-st": "^6.1.0", "purescript-strings": "^6.0.0", "purescript-tailrec": "^6.1.0", "purescript-tuples": "^7.0.0", From 51cefb716b86b1ace0aa843f257589209d1562f6 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Fri, 30 Sep 2022 01:01:46 -0400 Subject: [PATCH 1505/1580] Derive Foldable and Traversable (#4392) Enable the compiler to derive `Foldable` and `Traversable` instances. These instances follow the same rules as derived `Functor` instances. Co-authored-by: Jordan Martinez --- CHANGELOG.d/feature_derive-traversable.md | 4 + purescript.cabal | 2 + src/Language/PureScript/AST/Declarations.hs | 1 + .../PureScript/Constants/Data/Foldable.hs | 28 + .../PureScript/Constants/Data/Traversable.hs | 19 + src/Language/PureScript/Constants/Prelude.hs | 39 + src/Language/PureScript/Errors.hs | 13 + .../PureScript/TypeChecker/Deriving.hs | 297 ++++- tests/purs/failing/FoldableInstance1.out | 24 + tests/purs/failing/FoldableInstance1.purs | 9 + tests/purs/failing/FoldableInstance10.out | 38 + tests/purs/failing/FoldableInstance10.purs | 12 + tests/purs/failing/FoldableInstance2.out | 24 + tests/purs/failing/FoldableInstance2.purs | 10 + tests/purs/failing/FoldableInstance3.out | 24 + tests/purs/failing/FoldableInstance3.purs | 9 + tests/purs/failing/FoldableInstance4.out | 23 + tests/purs/failing/FoldableInstance4.purs | 8 + tests/purs/failing/FoldableInstance5.out | 18 + tests/purs/failing/FoldableInstance5.purs | 9 + tests/purs/failing/FoldableInstance6.out | 18 + tests/purs/failing/FoldableInstance6.purs | 8 + tests/purs/failing/FoldableInstance7.out | 18 + tests/purs/failing/FoldableInstance7.purs | 9 + tests/purs/failing/FoldableInstance8.out | 21 + tests/purs/failing/FoldableInstance8.purs | 8 + tests/purs/failing/FoldableInstance9.out | 1180 +++++++++++++++++ tests/purs/failing/FoldableInstance9.purs | 97 ++ tests/purs/passing/DerivingFoldable.purs | 89 ++ tests/purs/passing/DerivingFunctor.purs | 114 +- tests/purs/passing/DerivingTraversable.purs | 110 ++ 31 files changed, 2214 insertions(+), 69 deletions(-) create mode 100644 CHANGELOG.d/feature_derive-traversable.md create mode 100644 src/Language/PureScript/Constants/Data/Foldable.hs create mode 100644 src/Language/PureScript/Constants/Data/Traversable.hs create mode 100644 tests/purs/failing/FoldableInstance1.out create mode 100644 tests/purs/failing/FoldableInstance1.purs create mode 100644 tests/purs/failing/FoldableInstance10.out create mode 100644 tests/purs/failing/FoldableInstance10.purs create mode 100644 tests/purs/failing/FoldableInstance2.out create mode 100644 tests/purs/failing/FoldableInstance2.purs create mode 100644 tests/purs/failing/FoldableInstance3.out create mode 100644 tests/purs/failing/FoldableInstance3.purs create mode 100644 tests/purs/failing/FoldableInstance4.out create mode 100644 tests/purs/failing/FoldableInstance4.purs create mode 100644 tests/purs/failing/FoldableInstance5.out create mode 100644 tests/purs/failing/FoldableInstance5.purs create mode 100644 tests/purs/failing/FoldableInstance6.out create mode 100644 tests/purs/failing/FoldableInstance6.purs create mode 100644 tests/purs/failing/FoldableInstance7.out create mode 100644 tests/purs/failing/FoldableInstance7.purs create mode 100644 tests/purs/failing/FoldableInstance8.out create mode 100644 tests/purs/failing/FoldableInstance8.purs create mode 100644 tests/purs/failing/FoldableInstance9.out create mode 100644 tests/purs/failing/FoldableInstance9.purs create mode 100644 tests/purs/passing/DerivingFoldable.purs create mode 100644 tests/purs/passing/DerivingTraversable.purs diff --git a/CHANGELOG.d/feature_derive-traversable.md b/CHANGELOG.d/feature_derive-traversable.md new file mode 100644 index 0000000000..c4e559fd62 --- /dev/null +++ b/CHANGELOG.d/feature_derive-traversable.md @@ -0,0 +1,4 @@ +* Enable the compiler to derive `Foldable` and `Traversable` instances + + These instances follow the same rules as derived `Functor` instances. + For details, see [the PureScript language reference](https://github.com/purescript/documentation/blob/master/language/Type-Classes.md#functor-foldable-and-traversable). diff --git a/purescript.cabal b/purescript.cabal index 1382737e46..65fa328ffc 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -212,8 +212,10 @@ library Language.PureScript.CodeGen.JS.Common Language.PureScript.CodeGen.JS.Printer Language.PureScript.Constants.Prelude + Language.PureScript.Constants.Data.Foldable Language.PureScript.Constants.Data.Generic.Rep Language.PureScript.Constants.Data.Newtype + Language.PureScript.Constants.Data.Traversable Language.PureScript.CoreFn Language.PureScript.CoreFn.Ann Language.PureScript.CoreFn.Binders diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index d1617bb172..dfd5efcd34 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -88,6 +88,7 @@ data ErrorMessageHint | ErrorSolvingConstraint SourceConstraint | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName)) | PositionedError (NEL.NonEmpty SourceSpan) + | ErrorUnderLabel PSString deriving (Show) -- | Categories of hints diff --git a/src/Language/PureScript/Constants/Data/Foldable.hs b/src/Language/PureScript/Constants/Data/Foldable.hs new file mode 100644 index 0000000000..f0692cd9f1 --- /dev/null +++ b/src/Language/PureScript/Constants/Data/Foldable.hs @@ -0,0 +1,28 @@ +module Language.PureScript.Constants.Data.Foldable where + +import Data.String (IsString) +import Language.PureScript.Names + +foldl :: forall a. (IsString a) => a +foldl = "foldl" + +foldr :: forall a. (IsString a) => a +foldr = "foldr" + +foldMap :: forall a. (IsString a) => a +foldMap = "foldMap" + +pattern DataFoldable :: ModuleName +pattern DataFoldable = ModuleName "Data.Foldable" + +pattern Foldable :: Qualified (ProperName 'ClassName) +pattern Foldable = Qualified (ByModuleName DataFoldable) (ProperName "Foldable") + +identFoldl :: Qualified Ident +identFoldl = Qualified (ByModuleName DataFoldable) (Ident foldl) + +identFoldr :: Qualified Ident +identFoldr = Qualified (ByModuleName DataFoldable) (Ident foldr) + +identFoldMap :: Qualified Ident +identFoldMap = Qualified (ByModuleName DataFoldable) (Ident foldMap) diff --git a/src/Language/PureScript/Constants/Data/Traversable.hs b/src/Language/PureScript/Constants/Data/Traversable.hs new file mode 100644 index 0000000000..668ab43890 --- /dev/null +++ b/src/Language/PureScript/Constants/Data/Traversable.hs @@ -0,0 +1,19 @@ +module Language.PureScript.Constants.Data.Traversable where + +import Data.String (IsString) +import Language.PureScript.Names + +traverse :: forall a. (IsString a) => a +traverse = "traverse" + +sequence :: forall a. (IsString a) => a +sequence = "sequence" + +pattern DataTraversable :: ModuleName +pattern DataTraversable = ModuleName "Data.Traversable" + +pattern Traversable :: Qualified (ProperName 'ClassName) +pattern Traversable = Qualified (ByModuleName DataTraversable) (ProperName "Traversable") + +identTraverse :: Qualified Ident +identTraverse = Qualified (ByModuleName DataTraversable) (Ident traverse) diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs index fd69bab0ae..2ae16c2e87 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ b/src/Language/PureScript/Constants/Prelude.hs @@ -16,6 +16,9 @@ applyFlipped = "applyFlipped" append :: forall a. (IsString a) => a append = "append" +mempty :: forall a. (IsString a) => a +mempty = "mempty" + bind :: forall a. (IsString a) => a bind = "bind" @@ -322,9 +325,24 @@ pattern Effect = ModuleName "Effect" pattern ST :: ModuleName pattern ST = ModuleName "Control.Monad.ST.Internal" +pattern ControlApply :: ModuleName +pattern ControlApply = ModuleName "Control.Apply" + +pattern Apply :: Qualified (ProperName 'ClassName) +pattern Apply = Qualified (ByModuleName ControlApply) (ProperName "Apply") + +identApply :: Qualified Ident +identApply = Qualified (ByModuleName ControlApply) (Ident apply) + pattern ControlApplicative :: ModuleName pattern ControlApplicative = ModuleName "Control.Applicative" +pattern Applicative :: Qualified (ProperName 'ClassName) +pattern Applicative = Qualified (ByModuleName ControlApplicative) (ProperName "Applicative") + +identPure :: Qualified Ident +identPure = Qualified (ByModuleName ControlApplicative) (Ident pure') + pattern ControlSemigroupoid :: ModuleName pattern ControlSemigroupoid = ModuleName "Control.Semigroupoid" @@ -334,6 +352,12 @@ pattern ControlBind = ModuleName "Control.Bind" pattern ControlCategory :: ModuleName pattern ControlCategory = ModuleName "Control.Category" +pattern Category :: Qualified (ProperName 'ClassName) +pattern Category = Qualified (ByModuleName ControlCategory) (ProperName "Category") + +identIdentity :: Qualified Ident +identIdentity = Qualified (ByModuleName ControlCategory) (Ident identity) + pattern ControlMonadEffUncurried :: ModuleName pattern ControlMonadEffUncurried = ModuleName "Control.Monad.Eff.Uncurried" @@ -349,6 +373,15 @@ pattern DataBounded = ModuleName "Data.Bounded" pattern DataSemigroup :: ModuleName pattern DataSemigroup = ModuleName "Data.Semigroup" +identAppend :: Qualified Ident +identAppend = Qualified (ByModuleName DataSemigroup) (Ident append) + +pattern DataMonoid :: ModuleName +pattern DataMonoid = ModuleName "Data.Monoid" + +identMempty :: Qualified Ident +identMempty = Qualified (ByModuleName DataMonoid) (Ident mempty) + pattern DataHeytingAlgebra :: ModuleName pattern DataHeytingAlgebra = ModuleName "Data.HeytingAlgebra" @@ -403,6 +436,12 @@ pattern DataEuclideanRing = ModuleName "Data.EuclideanRing" pattern DataFunction :: ModuleName pattern DataFunction = ModuleName "Data.Function" +identFlip :: Qualified Ident +identFlip = Qualified (ByModuleName DataFunction) (Ident flip) + +flip :: forall a. (IsString a) => a +flip = "flip" + pattern DataIntBits :: ModuleName pattern DataIntBits = ModuleName "Data.Int.Bits" diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 7f12d5774d..c633a5ca60 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -188,6 +188,7 @@ data SimpleErrorMessage | UnsupportedRoleDeclaration | RoleDeclarationArityMismatch (ProperName 'TypeName) Int Int | DuplicateRoleDeclaration (ProperName 'TypeName) + | CannotDeriveInvalidConstructorArg Text SourceSpan deriving (Show) data ErrorMessage = ErrorMessage @@ -353,6 +354,7 @@ errorCode em = case unwrapErrorMessage em of UnsupportedRoleDeclaration {} -> "UnsupportedRoleDeclaration" RoleDeclarationArityMismatch {} -> "RoleDeclarationArityMismatch" DuplicateRoleDeclaration {} -> "DuplicateRoleDeclaration" + CannotDeriveInvalidConstructorArg{} -> "CannotDeriveInvalidConstructorArg" -- | A stack trace for an error newtype MultipleErrors = MultipleErrors @@ -1367,6 +1369,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (DuplicateRoleDeclaration name) = line $ "Duplicate role declaration for " <> markCode (runProperName name) <> "." + renderSimpleErrorMessage (CannotDeriveInvalidConstructorArg tyVarName ss) = + paras + [ line $ "The type variable `" <> tyVarName <> "` must only be used as the last argument in a data type:" + , indent $ line $ displaySourceSpan relPath ss + ] + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1@RCons{} t2@RCons{}) detail = let (row1Box, row2Box) = printRows t1 t2 @@ -1531,6 +1539,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line $ "at " <> displaySourceSpan relPath (NEL.head srcSpan) , detail ] + renderHint (ErrorUnderLabel lbl) detail = + paras + [ detail + , line $ "under the label `" <> markCode (T.pack (decodeStringWithReplacement lbl)) <> "`" + ] printRow :: (Int -> Type a -> Box.Box) -> Type a -> Box.Box printRow f = markCodeBox . indent . f prettyDepth . diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index a24f97616e..eda0fb5daf 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -1,20 +1,26 @@ +{- HLINT ignore "Unused LANGUAGE pragma" -} -- HLint doesn't recognize that TypeApplications is used in a pattern +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} module Language.PureScript.TypeChecker.Deriving (deriveInstance) where import Protolude hiding (Type) -import Control.Monad.Writer.Class (MonadWriter(..)) -import Data.Foldable (foldl1) +import Control.Monad.Trans.Writer (Writer, WriterT, runWriter, runWriterT) +import Control.Monad.Writer.Class (MonadWriter(..), censor) +import Data.Foldable (foldl1, foldr1) import Data.List (init, last, zipWith3, (!!)) import qualified Data.Map as M import Control.Monad.Supply.Class import Language.PureScript.AST import Language.PureScript.AST.Utils +import qualified Language.PureScript.Constants.Data.Foldable as Foldable +import qualified Language.PureScript.Constants.Data.Traversable as Traversable import qualified Language.PureScript.Constants.Prelude as Prelude import qualified Language.PureScript.Constants.Prim as Prim import Language.PureScript.Crash import Language.PureScript.Environment -import Language.PureScript.Errors +import Language.PureScript.Errors hiding (nonEmpty) import Language.PureScript.Label (Label(..)) import Language.PureScript.Names import Language.PureScript.PSString @@ -65,16 +71,19 @@ deriveInstance instType className strategy = do let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs in lam UnusedIdent (DeferredDictionary superclass tyArgs) let superclasses = map mkString (superClassDictionaryNames typeClassSuperclasses) `zip` superclassesDicts - App (Constructor nullSourceSpan ctorName) . mkLit . ObjectLiteral . (++ superclasses) <$> f mn tyCon + rethrow (addHint $ ErrorInInstance className tys) $ + App (Constructor nullSourceSpan ctorName) . mkLit . ObjectLiteral . (++ superclasses) <$> f mn tyCon _ -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 in case className of + Foldable.Foldable -> unaryClass deriveFoldable Prelude.Eq -> unaryClass deriveEq Prelude.Eq1 -> unaryClass $ \_ _ -> deriveEq1 Prelude.Functor -> unaryClass deriveFunctor Prelude.Ord -> unaryClass deriveOrd Prelude.Ord1 -> unaryClass $ \_ _ -> deriveOrd1 + Traversable.Traversable -> unaryClass deriveTraversable -- See L.P.Sugar.TypeClasses.Deriving for the classes that can be -- derived prior to type checking. _ -> throwError . errorMessage $ CannotDerive className tys @@ -359,6 +368,128 @@ decomposeRec' = sortOn fst . go where go (RCons _ str typ typs) = (str, typ) : go typs go _ = [] +data ParamUsage + = IsParam + | MentionsParam ParamUsage + | IsRecord (NonEmpty (PSString, ParamUsage)) + +type ParamErrorData = [([Either (ProperName 'ConstructorName) PSString], SourceSpan)] + +validateParamsInTypeConstructors + :: forall m + . MonadError MultipleErrors m + => MonadState CheckState m + => ModuleName + -> ProperName 'TypeName + -> m [(ProperName 'ConstructorName, [Maybe ParamUsage])] +validateParamsInTypeConstructors mn tyConNm = do + (_, _, tyArgNames, ctors) <- lookupTypeDecl mn tyConNm + param <- note (errorMessage $ KindsDoNotUnify (kindType -:> kindType) kindType) . lastMay $ map fst tyArgNames + ctors' <- traverse (traverse $ traverse replaceAllTypeSynonyms) ctors + let (ctorUsages, errors) = runWriter $ traverse (addCtorHint . traverse . traverse $ typeToUsageOf param) ctors' + unless (null errors) $ + throwError . flip foldMap (sortOn snd $ ordNub errors) $ \(hints, ss) -> + addHints (either ErrorInDataConstructor ErrorUnderLabel <$> hints) $ + errorMessage $ CannotDeriveInvalidConstructorArg param ss + pure ctorUsages + where + consHintData :: a -> Writer [([a], b)] c -> Writer [([a], b)] c + consHintData a = censor (map $ first (a :)) + + addCtorHint :: ((ProperName 'ConstructorName, a) -> Writer ParamErrorData b) -> (ProperName 'ConstructorName, a) -> Writer ParamErrorData b + addCtorHint f ctor = consHintData (Left $ fst ctor) $ f ctor + + typeToUsageOf :: Text -> SourceType -> Writer ParamErrorData (Maybe ParamUsage) + typeToUsageOf param = go + where + assertNoParamUsedIn :: SourceType -> Writer ParamErrorData () + assertNoParamUsedIn = everythingOnTypes (*>) $ \case + TypeVar (ss, _) name | name == param -> tell [([], ss)] + _ -> pure () + + go = \case + ForAll _ name _ ty _ -> + if name == param then pure Nothing else go ty + + ConstrainedType _ _ ty -> + go ty + + TypeApp _ (TypeConstructor _ Prim.Record) row -> + fmap (fmap IsRecord . nonEmpty . catMaybes) . for (decomposeRec' row) $ \(Label lbl, ty) -> + consHintData (Right lbl) $ + fmap (lbl, ) <$> go ty + + TypeApp _ tyFn tyArg -> do + assertNoParamUsedIn tyFn + fmap MentionsParam <$> go tyArg + + TypeVar _ name -> + pure $ (name == param) `orEmpty` IsParam + + ty -> + assertNoParamUsedIn ty $> Nothing + +usingLamIdent :: forall m. MonadSupply m => (Expr -> m Expr) -> m Expr +usingLamIdent cb = do + ident <- freshIdent "v" + lam ident <$> cb (mkVar ident) + +traverseFields :: forall f. Applicative f => (ParamUsage -> Expr -> f Expr) -> NonEmpty (PSString, ParamUsage) -> Expr -> f Expr +traverseFields f fields r = fmap (ObjectUpdate r) . for (toList fields) $ \(lbl, usage) -> (lbl, ) <$> f usage (Accessor lbl r) + +unnestRecords :: forall f. Applicative f => (ParamUsage -> Expr -> f Expr) -> ParamUsage -> Expr -> f Expr +unnestRecords f = fix $ \go -> \case + IsRecord fields -> traverseFields go fields + usage -> f usage + +mkCasesForTraversal + :: forall f m + . Applicative f -- this effect distinguishes the semantics of maps, folds, and traversals + => MonadSupply m + => ModuleName + -> (ParamUsage -> Expr -> f Expr) -- how to handle constructor arguments + -> (f Expr -> m Expr) -- resolve the applicative effect into an expression + -> [(ProperName 'ConstructorName, [Maybe ParamUsage])] + -> m Expr +mkCasesForTraversal mn handleArg extractExpr ctors = do + m <- freshIdent "m" + fmap (lamCase m) . for ctors $ \(ctorName, ctorUsages) -> do + ctorArgs <- for ctorUsages $ \usage -> freshIdent "v" <&> (, usage) + let ctor = mkCtor mn ctorName + let caseBinder = mkCtorBinder mn ctorName $ map (mkBinder . fst) ctorArgs + fmap (CaseAlternative [caseBinder] . unguarded) . extractExpr $ + fmap (foldl' App ctor) . for ctorArgs $ \(ident, mbUsage) -> maybe pure handleArg mbUsage $ mkVar ident + +data TraversalOps m = forall f. Applicative f => TraversalOps + { visitExpr :: m Expr -> f Expr -- lift an expression into the applicative effect defining the traversal + , extractExpr :: f Expr -> m Expr -- resolve the applicative effect into an expression + } + +mkTraversal + :: forall m + . MonadSupply m + => ModuleName + -> Expr -- a var representing map, foldMap, or traverse, for handling structured values + -> TraversalOps m + -> [(ProperName 'ConstructorName, [Maybe ParamUsage])] + -> m Expr +mkTraversal mn recurseVar (TraversalOps @_ @f visitExpr extractExpr) ctors = do + f <- freshIdent "f" + let + handleValue :: ParamUsage -> Expr -> f Expr + handleValue = unnestRecords $ \usage inputExpr -> visitExpr $ flip App inputExpr <$> mkFnExprForValue usage + + mkFnExprForValue :: ParamUsage -> m Expr + mkFnExprForValue = \case + IsParam -> + pure $ mkVar f + MentionsParam innerUsage -> + App recurseVar <$> mkFnExprForValue innerUsage + IsRecord fields -> + usingLamIdent $ extractExpr . traverseFields handleValue fields + + lam f <$> mkCasesForTraversal mn handleValue extractExpr ctors + deriveFunctor :: forall m . MonadError MultipleErrors m @@ -368,64 +499,118 @@ deriveFunctor -> ProperName 'TypeName -> m [(PSString, Expr)] deriveFunctor mn tyConNm = do - (_, _, tys, ctors) <- lookupTypeDecl mn tyConNm - mapFun <- mkMapFunction tys ctors + ctors <- validateParamsInTypeConstructors mn tyConNm + mapFun <- mkTraversal mn mapVar (TraversalOps identity identity) ctors pure [(Prelude.map, mapFun)] where - mkMapFunction :: [(Text, Maybe SourceType)] -> [(ProperName 'ConstructorName, [SourceType])] -> m Expr - mkMapFunction tys ctors = case reverse tys of - [] -> throwError . errorMessage $ KindsDoNotUnify (kindType -:> kindType) kindType - ((iTy, _) : _) -> do - f <- freshIdent "f" - m <- freshIdent "m" - lam f . lamCase m <$> mapM (mkCtorClause iTy f) ctors - - mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [SourceType]) -> m CaseAlternative - mkCtorClause iTyName f (ctorName, ctorTys) = do - idents <- replicateM (length ctorTys) (freshIdent "v") - ctorTys' <- mapM replaceAllTypeSynonyms ctorTys - args <- zipWithM transformArg idents ctorTys' - let ctor = mkCtor mn ctorName - rebuilt = foldl' App ctor args - caseBinder = mkCtorBinder mn ctorName $ map mkBinder idents - return $ CaseAlternative [caseBinder] (unguarded rebuilt) - where - fVar = mkVar f - mapVar = mkRef Prelude.identMap - - transformArg :: Ident -> SourceType -> m Expr - transformArg ident = fmap (foldr App (mkVar ident)) . goType where - - goType :: SourceType -> m (Maybe Expr) - -- argument matches the index type - goType (TypeVar _ t) | t == iTyName = return (Just fVar) + mapVar = mkRef Prelude.identMap - -- records - goType recTy | Just row <- objectType recTy = - traverse buildUpdate (decomposeRec' row) >>= (traverse buildRecord . justUpdates) - where - justUpdates :: [Maybe (Label, Expr)] -> Maybe [(Label, Expr)] - justUpdates = foldMap (fmap return) +toConst :: forall f a b. f a -> Const [f a] b +toConst = Const . pure - buildUpdate :: (Label, SourceType) -> m (Maybe (Label, Expr)) - buildUpdate (lbl, ty) = do upd <- goType ty - return ((lbl,) <$> upd) +consumeConst :: forall f a b c. Applicative f => ([a] -> b) -> Const [f a] c -> f b +consumeConst f = fmap f . sequenceA . getConst - buildRecord :: [(Label, Expr)] -> m Expr - buildRecord updates = do - arg <- freshIdent "o" - let argVar = mkVar arg - mkAssignment (Label l, x) = (l, App x (Accessor l argVar)) - return (lam arg (ObjectUpdate argVar (mkAssignment <$> updates))) +applyWhen :: forall a. Bool -> (a -> a) -> a -> a +applyWhen cond f = if cond then f else identity - -- quantifiers - goType (ForAll _ scopedVar _ t _) | scopedVar /= iTyName = goType t +deriveFoldable + :: forall m + . MonadError MultipleErrors m + => MonadState CheckState m + => MonadSupply m + => ModuleName + -> ProperName 'TypeName + -> m [(PSString, Expr)] +deriveFoldable mn tyConNm = do + ctors <- validateParamsInTypeConstructors mn tyConNm + foldlFun <- mkAsymmetricFoldFunction False foldlVar ctors + foldrFun <- mkAsymmetricFoldFunction True foldrVar ctors + foldMapFun <- mkTraversal mn foldMapVar foldMapOps ctors + pure [(Foldable.foldl, foldlFun), (Foldable.foldr, foldrFun), (Foldable.foldMap, foldMapFun)] + where + foldlVar = mkRef Foldable.identFoldl + foldrVar = mkRef Foldable.identFoldr + foldMapVar = mkRef Foldable.identFoldMap + flipVar = mkRef Prelude.identFlip + + mkAsymmetricFoldFunction :: Bool -> Expr -> [(ProperName 'ConstructorName, [Maybe ParamUsage])] -> m Expr + mkAsymmetricFoldFunction isRightFold recurseVar ctors = do + f <- freshIdent "f" + z <- freshIdent "z" + let + appCombiner :: (Bool, Expr) -> Expr -> Expr -> Expr + appCombiner (isFlipped, fn) = applyWhen (isFlipped == isRightFold) flip $ App . App fn + + mkCombinerExpr :: ParamUsage -> m Expr + mkCombinerExpr = fmap (uncurry $ \isFlipped -> applyWhen isFlipped $ App flipVar) . getCombiner + + handleValue :: ParamUsage -> Expr -> Const [m (Expr -> Expr)] Expr + handleValue = unnestRecords $ \usage inputExpr -> toConst $ flip appCombiner inputExpr <$> getCombiner usage + + getCombiner :: ParamUsage -> m (Bool, Expr) + getCombiner = \case + IsParam -> + pure (False, mkVar f) + MentionsParam innerUsage -> + (isRightFold, ) . App recurseVar <$> mkCombinerExpr innerUsage + IsRecord fields -> do + let foldFieldsOf = traverseFields handleValue fields + fmap (False, ) . usingLamIdent $ \lVar -> + usingLamIdent $ + if isRightFold + then flip extractExprStartingWith $ foldFieldsOf lVar + else extractExprStartingWith lVar . foldFieldsOf + + extractExprStartingWith :: Expr -> Const [m (Expr -> Expr)] Expr -> m Expr + extractExprStartingWith = consumeConst . if isRightFold then foldr ($) else foldl' (&) + + lam f . lam z <$> mkCasesForTraversal mn handleValue (extractExprStartingWith $ mkVar z) ctors + +foldMapOps :: forall m. Applicative m => TraversalOps m +foldMapOps = TraversalOps { visitExpr = toConst, .. } + where + appendVar = mkRef Prelude.identAppend + memptyVar = mkRef Prelude.identMempty - -- constraints - goType (ConstrainedType _ _ t) = goType t + extractExpr :: Const [m Expr] Expr -> m Expr + extractExpr = consumeConst $ \case + [] -> memptyVar + exprs -> foldr1 (App . App appendVar) exprs - -- under a `* -> *`, just assume functor for now - goType (TypeApp _ _ t) = fmap (App mapVar) <$> goType t +deriveTraversable + :: forall m + . MonadError MultipleErrors m + => MonadState CheckState m + => MonadSupply m + => ModuleName + -> ProperName 'TypeName + -> m [(PSString, Expr)] +deriveTraversable mn tyConNm = do + ctors <- validateParamsInTypeConstructors mn tyConNm + traverseFun <- mkTraversal mn traverseVar traverseOps ctors + sequenceFun <- usingLamIdent $ pure . App (App traverseVar identityVar) + pure [(Traversable.traverse, traverseFun), (Traversable.sequence, sequenceFun)] + where + traverseVar = mkRef Traversable.identTraverse + identityVar = mkRef Prelude.identIdentity - -- otherwise do nothing - will fail type checking if type does actually contain index - goType _ = return Nothing +traverseOps :: forall m. MonadSupply m => TraversalOps m +traverseOps = TraversalOps { .. } + where + pureVar = mkRef Prelude.identPure + mapVar = mkRef Prelude.identMap + applyVar = mkRef Prelude.identApply + + visitExpr :: m Expr -> WriterT [(Ident, m Expr)] m Expr + visitExpr traversedExpr = do + ident <- freshIdent "v" + tell [(ident, traversedExpr)] $> mkVar ident + + extractExpr :: WriterT [(Ident, m Expr)] m Expr -> m Expr + extractExpr = runWriterT >=> \(result, unzip -> (ctx, args)) -> flip mkApps (foldr lam result ctx) <$> sequenceA args + + mkApps :: [Expr] -> Expr -> Expr + mkApps = \case + [] -> App pureVar + h : t -> \l -> foldl' (App . App applyVar) (App (App mapVar l) h) t diff --git a/tests/purs/failing/FoldableInstance1.out b/tests/purs/failing/FoldableInstance1.out new file mode 100644 index 0000000000..0066c5f5bc --- /dev/null +++ b/tests/purs/failing/FoldableInstance1.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/FoldableInstance1.purs:9:26 - 9:29 (line 9, column 26 - line 9, column 29) + + Could not match kind +   +  Type +   + with kind +   +  Type -> Type +   + +while checking that type Foo + has kind Type -> Type +while inferring the kind of Foldable Foo +in type class instance +  + Data.Foldable.Foldable Foo +  + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/FoldableInstance1.purs b/tests/purs/failing/FoldableInstance1.purs new file mode 100644 index 0000000000..d8c230c714 --- /dev/null +++ b/tests/purs/failing/FoldableInstance1.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +import Prelude +import Data.Foldable (class Foldable) + +data Foo = Bar + +derive instance Foldable Foo diff --git a/tests/purs/failing/FoldableInstance10.out b/tests/purs/failing/FoldableInstance10.out new file mode 100644 index 0000000000..330d1de1e5 --- /dev/null +++ b/tests/purs/failing/FoldableInstance10.out @@ -0,0 +1,38 @@ +Error 1 of 2: + + in module FoldableInstance10 + at tests/purs/failing/FoldableInstance10.purs:12:1 - 12:30 (line 12, column 1 - line 12, column 30) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance10.purs:11:38 - 11:39 (line 11, column 38 - line 11, column 39) + + + in data constructor Test + in type class instance +   +  Data.Foldable.Foldable Test +   + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module FoldableInstance10 + at tests/purs/failing/FoldableInstance10.purs:12:1 - 12:30 (line 12, column 1 - line 12, column 30) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance10.purs:11:56 - 11:57 (line 11, column 56 - line 11, column 57) + + + in data constructor Test + in type class instance +   +  Data.Foldable.Foldable Test +   + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/failing/FoldableInstance10.purs b/tests/purs/failing/FoldableInstance10.purs new file mode 100644 index 0000000000..17b05ec337 --- /dev/null +++ b/tests/purs/failing/FoldableInstance10.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +module FoldableInstance10 where + +import Prelude +import Data.Tuple (Tuple) +import Data.Foldable (class Foldable) + +foreign import data Variant :: Row Type -> Type + +data Test a = Test (Variant (left :: a, right :: Array a)) +derive instance Foldable Test diff --git a/tests/purs/failing/FoldableInstance2.out b/tests/purs/failing/FoldableInstance2.out new file mode 100644 index 0000000000..c5ac122c50 --- /dev/null +++ b/tests/purs/failing/FoldableInstance2.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/FoldableInstance2.purs:10:26 - 10:29 (line 10, column 26 - line 10, column 29) + + Could not match kind +   +  Type +   + with kind +   +  Type -> Type +   + +while checking that type Foo + has kind Type -> Type +while inferring the kind of Foldable Foo +in type class instance +  + Data.Foldable.Foldable Foo +  + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/FoldableInstance2.purs b/tests/purs/failing/FoldableInstance2.purs new file mode 100644 index 0000000000..477033c0b4 --- /dev/null +++ b/tests/purs/failing/FoldableInstance2.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +import Prelude +import Data.Foldable (class Foldable) + +data Foo :: (Type -> Type) -> Type +data Foo a = Bar + +derive instance Foldable Foo diff --git a/tests/purs/failing/FoldableInstance3.out b/tests/purs/failing/FoldableInstance3.out new file mode 100644 index 0000000000..e64875d220 --- /dev/null +++ b/tests/purs/failing/FoldableInstance3.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/FoldableInstance3.purs:9:26 - 9:29 (line 9, column 26 - line 9, column 29) + + Could not match kind +   +  Type +   + with kind +   +  Type -> Type +   + +while checking that type Foo + has kind Type -> Type +while inferring the kind of Foldable Foo +in type class instance +  + Data.Foldable.Foldable Foo +  + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/FoldableInstance3.purs b/tests/purs/failing/FoldableInstance3.purs new file mode 100644 index 0000000000..7ce3298aee --- /dev/null +++ b/tests/purs/failing/FoldableInstance3.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +import Prelude +import Data.Foldable (class Foldable) + +data Foo f = Bar (f Int) + +derive instance Foldable Foo diff --git a/tests/purs/failing/FoldableInstance4.out b/tests/purs/failing/FoldableInstance4.out new file mode 100644 index 0000000000..4e53669e6b --- /dev/null +++ b/tests/purs/failing/FoldableInstance4.out @@ -0,0 +1,23 @@ +Error found: +in module FoldableInstance4 +at tests/purs/failing/FoldableInstance4.purs:8:1 - 8:27 (line 8, column 1 - line 8, column 27) + + No type class instance was found for +   +  Data.Foldable.Foldable (Function t3) +   + The instance head contains unknown type variables. Consider adding a type annotation. + +while applying a function foldl + of type Foldable t0 => (t1 -> t2 -> t1) -> t1 -> t0 t2 -> t1 + to argument $f1 +while inferring the type of foldl $f1 + +where t0 is an unknown type + t2 is an unknown type + t1 is an unknown type + t3 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/FoldableInstance4.purs b/tests/purs/failing/FoldableInstance4.purs new file mode 100644 index 0000000000..6dd856540f --- /dev/null +++ b/tests/purs/failing/FoldableInstance4.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith NoInstanceFound +module FoldableInstance4 where + +import Prelude +import Data.Foldable (class Foldable) + +data T a = T (forall t. Show t => t -> a) +derive instance Foldable T diff --git a/tests/purs/failing/FoldableInstance5.out b/tests/purs/failing/FoldableInstance5.out new file mode 100644 index 0000000000..f98d951708 --- /dev/null +++ b/tests/purs/failing/FoldableInstance5.out @@ -0,0 +1,18 @@ +Error found: +in module FoldableInstance5 +at tests/purs/failing/FoldableInstance5.purs:9:1 - 9:30 (line 9, column 1 - line 9, column 30) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance5.purs:8:27 - 8:28 (line 8, column 27 - line 8, column 28) + + +in data constructor Test +in type class instance +  + Data.Foldable.Foldable Test +  + +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/FoldableInstance5.purs b/tests/purs/failing/FoldableInstance5.purs new file mode 100644 index 0000000000..cf86966245 --- /dev/null +++ b/tests/purs/failing/FoldableInstance5.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith CannotDeriveInvalidConstructorArg +module FoldableInstance5 where + +import Prelude +import Data.Foldable (class Foldable) +import Data.Tuple (Tuple(..)) + +data Test a = Test (Tuple a Int) +derive instance Foldable Test diff --git a/tests/purs/failing/FoldableInstance6.out b/tests/purs/failing/FoldableInstance6.out new file mode 100644 index 0000000000..dfa6bfb92f --- /dev/null +++ b/tests/purs/failing/FoldableInstance6.out @@ -0,0 +1,18 @@ +Error found: +in module FoldableInstance6 +at tests/purs/failing/FoldableInstance6.purs:8:1 - 8:30 (line 8, column 1 - line 8, column 30) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance6.purs:7:21 - 7:22 (line 7, column 21 - line 7, column 22) + + +in data constructor Test +in type class instance +  + Data.Foldable.Foldable Test +  + +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/FoldableInstance6.purs b/tests/purs/failing/FoldableInstance6.purs new file mode 100644 index 0000000000..cba388ae23 --- /dev/null +++ b/tests/purs/failing/FoldableInstance6.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith CannotDeriveInvalidConstructorArg +module FoldableInstance6 where + +import Prelude +import Data.Foldable (class Foldable) + +data Test a = Test (a -> Int) +derive instance Foldable Test diff --git a/tests/purs/failing/FoldableInstance7.out b/tests/purs/failing/FoldableInstance7.out new file mode 100644 index 0000000000..214911ef6b --- /dev/null +++ b/tests/purs/failing/FoldableInstance7.out @@ -0,0 +1,18 @@ +Error found: +in module FoldableInstance6 +at tests/purs/failing/FoldableInstance7.purs:9:1 - 9:30 (line 9, column 1 - line 9, column 30) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance7.purs:8:27 - 8:28 (line 8, column 27 - line 8, column 28) + + +in data constructor Test +in type class instance +  + Data.Foldable.Foldable Test +  + +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/FoldableInstance7.purs b/tests/purs/failing/FoldableInstance7.purs new file mode 100644 index 0000000000..ce11d35547 --- /dev/null +++ b/tests/purs/failing/FoldableInstance7.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith CannotDeriveInvalidConstructorArg +module FoldableInstance6 where + +import Prelude +import Data.Tuple (Tuple(..)) +import Data.Foldable (class Foldable) + +data Test a = Test (Tuple a a) +derive instance Foldable Test diff --git a/tests/purs/failing/FoldableInstance8.out b/tests/purs/failing/FoldableInstance8.out new file mode 100644 index 0000000000..dcd3b02f89 --- /dev/null +++ b/tests/purs/failing/FoldableInstance8.out @@ -0,0 +1,21 @@ +Error found: +in module FoldableInstance6 +at tests/purs/failing/FoldableInstance8.purs:8:1 - 8:34 (line 8, column 1 - line 8, column 34) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance8.purs:7:25 - 7:26 (line 7, column 25 - line 7, column 26) + + +in data constructor Test +in type class instance +  + Data.Foldable.Foldable (Test @Type f0) +  + +where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/FoldableInstance8.purs b/tests/purs/failing/FoldableInstance8.purs new file mode 100644 index 0000000000..1ae6cebe6f --- /dev/null +++ b/tests/purs/failing/FoldableInstance8.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith CannotDeriveInvalidConstructorArg +module FoldableInstance6 where + +import Prelude +import Data.Foldable (class Foldable) + +data Test f a = Test (f a a) +derive instance Foldable (Test f) diff --git a/tests/purs/failing/FoldableInstance9.out b/tests/purs/failing/FoldableInstance9.out new file mode 100644 index 0000000000..5a2e0af85f --- /dev/null +++ b/tests/purs/failing/FoldableInstance9.out @@ -0,0 +1,1180 @@ +Error 1 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:60:14 - 60:15 (line 60, column 14 - line 60, column 15) + + + in data constructor Test1 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 2 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:60:16 - 60:17 (line 60, column 16 - line 60, column 17) + + + in data constructor Test1 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 3 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:60:28 - 60:29 (line 60, column 28 - line 60, column 29) + + + in data constructor Test1 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 4 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:60:36 - 60:37 (line 60, column 36 - line 60, column 37) + + + in data constructor Test1 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 5 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:60:38 - 60:39 (line 60, column 38 - line 60, column 39) + + + in data constructor Test1 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 6 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:60:52 - 60:53 (line 60, column 52 - line 60, column 53) + + + in data constructor Test1 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 7 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:61:22 - 61:23 (line 61, column 22 - line 61, column 23) + + + under the label `all` + in data constructor Test2 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 8 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:61:24 - 61:25 (line 61, column 24 - line 61, column 25) + + + under the label `all` + in data constructor Test2 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 9 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:62:29 - 62:30 (line 62, column 29 - line 62, column 30) + + + under the label `rights` + in data constructor Test2 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 10 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:63:24 - 63:25 (line 63, column 24 - line 63, column 25) + + + under the label `lefts` + in data constructor Test2 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 11 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:63:26 - 63:27 (line 63, column 26 - line 63, column 27) + + + under the label `lefts` + in data constructor Test2 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 12 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:64:29 - 64:30 (line 64, column 29 - line 64, column 30) + + + under the label `middle` + in data constructor Test2 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 13 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:68:24 - 68:25 (line 68, column 24 - line 68, column 25) + + + in data constructor Test3 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 14 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:68:26 - 68:27 (line 68, column 26 - line 68, column 27) + + + in data constructor Test3 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 15 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:68:28 - 68:29 (line 68, column 28 - line 68, column 29) + + + in data constructor Test3 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 16 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:69:31 - 69:32 (line 69, column 31 - line 69, column 32) + + + in data constructor Test3 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 17 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:69:33 - 69:34 (line 69, column 33 - line 69, column 34) + + + in data constructor Test3 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 18 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:70:26 - 70:27 (line 70, column 26 - line 70, column 27) + + + in data constructor Test3 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 19 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:70:28 - 70:29 (line 70, column 28 - line 70, column 29) + + + in data constructor Test3 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 20 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:71:31 - 71:32 (line 71, column 31 - line 71, column 32) + + + in data constructor Test3 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 21 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:77:28 - 77:29 (line 77, column 28 - line 77, column 29) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 22 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:77:30 - 77:31 (line 77, column 30 - line 77, column 31) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 23 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:77:32 - 77:33 (line 77, column 32 - line 77, column 33) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 24 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:78:35 - 78:36 (line 78, column 35 - line 78, column 36) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 25 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:78:37 - 78:38 (line 78, column 37 - line 78, column 38) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 26 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:79:30 - 79:31 (line 79, column 30 - line 79, column 31) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 27 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:79:32 - 79:33 (line 79, column 32 - line 79, column 33) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 28 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:80:35 - 80:36 (line 80, column 35 - line 80, column 36) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 29 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:85:30 - 85:31 (line 85, column 30 - line 85, column 31) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 30 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:85:32 - 85:33 (line 85, column 32 - line 85, column 33) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 31 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:85:34 - 85:35 (line 85, column 34 - line 85, column 35) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 32 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:86:37 - 86:38 (line 86, column 37 - line 86, column 38) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 33 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:86:39 - 86:40 (line 86, column 39 - line 86, column 40) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 34 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:87:32 - 87:33 (line 87, column 32 - line 87, column 33) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 35 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:87:34 - 87:35 (line 87, column 34 - line 87, column 35) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 36 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:88:37 - 88:38 (line 88, column 37 - line 88, column 38) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 37 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:91:19 - 91:20 (line 91, column 19 - line 91, column 20) + + + in data constructor Test4 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 38 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:94:18 - 94:19 (line 94, column 18 - line 94, column 19) + + + under the label `all` + in data constructor Test5 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 39 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:94:18 - 94:19 (line 94, column 18 - line 94, column 19) + + + under the label `lefts` + in data constructor Test5 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 40 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:94:18 - 94:19 (line 94, column 18 - line 94, column 19) + + + under the label `middle` + in data constructor Test5 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 41 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:94:18 - 94:19 (line 94, column 18 - line 94, column 19) + + + under the label `rights` + in data constructor Test5 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 42 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:95:21 - 95:22 (line 95, column 21 - line 95, column 22) + + + in data constructor Test6 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 43 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:96:33 - 96:34 (line 96, column 33 - line 96, column 34) + + + in data constructor Test7 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 44 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:96:56 - 96:57 (line 96, column 56 - line 96, column 57) + + + in data constructor Test7 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + +Error 45 of 45: + + in module FoldableInstance9 + at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) + + The type variable `a` must only be used as the last argument in a data type: + + tests/purs/failing/FoldableInstance9.purs:96:59 - 96:60 (line 96, column 59 - line 96, column 60) + + + in data constructor Test7 + in type class instance +   +  Data.Foldable.Foldable (Test f0 g1 h2) +   + + where f0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + g1 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + h2 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + + See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/failing/FoldableInstance9.purs b/tests/purs/failing/FoldableInstance9.purs new file mode 100644 index 0000000000..e9c90891c5 --- /dev/null +++ b/tests/purs/failing/FoldableInstance9.purs @@ -0,0 +1,97 @@ +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +-- @shouldFailWith CannotDeriveInvalidConstructorArg +module FoldableInstance9 where + +import Prelude +import Data.Tuple (Tuple) +import Data.Foldable (class Foldable) + +type Rec f a = + { all :: f a a a + , rights :: f Int a a + , lefts :: f a a Int + , middle :: f Int a Int + , none :: f Int Int Int + } +data Test f g h a + = Test1 (f a a a) (f Int a a) (f a a Int) (f Int a Int) (f Int Int Int) + | Test2 { all :: f a a a + , rights :: f Int a a + , lefts :: f a a Int + , middle :: f Int a Int + , none :: f Int Int Int + } + | Test3 (g + { all :: f a a a + , rights :: f Int a a + , lefts :: f a a Int + , middle :: f Int a Int + , none :: f Int Int Int + } + a) + | Test4 (h + { nested1 :: + { all :: f a a a + , rights :: f Int a a + , lefts :: f a a Int + , middle :: f Int a Int + , none :: f Int Int Int + } + , nested2 :: + g + { all :: f a a a + , rights :: f Int a a + , lefts :: f a a Int + , middle :: f Int a Int + , none :: f Int Int Int + } + a + } + a) + | Test5 (Rec f a) + | Test6 (g (Rec f a) a) + | Test7 (h { nested1 :: Rec f a, nested2 :: g (Rec f a) a } a) +derive instance Foldable (Test f g h) diff --git a/tests/purs/passing/DerivingFoldable.purs b/tests/purs/passing/DerivingFoldable.purs new file mode 100644 index 0000000000..0b9461c660 --- /dev/null +++ b/tests/purs/passing/DerivingFoldable.purs @@ -0,0 +1,89 @@ +module Main where + +import Prelude +import Effect.Console (log) +import Data.Foldable (class Foldable, foldl, foldr, foldMap) +import Test.Assert + +-- Fold is done in alphabetical ordering of labels, +-- not their order in definition +type RecordFields f a = + { a :: a + , zArrayA :: Array a + , fa :: f a + , ignore :: Int + , arrayIgnore :: Array Int + , fIgnore :: f Int + } + +data M f a + = M0 + | M1 a (Array a) + | M2 Int (forall a. Array a -> Array a) + | M3 (f a) + | M4 (RecordFields f a) + | M5 { nested :: RecordFields f a } + | M6 Int a (Array Int) (Array a) (f a) (f Int) (RecordFields f a) { nested :: RecordFields f a } + | M7 (f (f { nested :: RecordFields f a })) + +derive instance foldableM :: Foldable f => Foldable (M f) + +type MArrStr = M Array String + +foldlStr :: forall f. Foldable f => f String -> String +foldlStr = foldl (\acc next -> acc <> "<" <> next) "Start" + +foldrStr :: forall f. Foldable f => f String -> String +foldrStr = foldr (\next acc -> next <> ">" <> acc) "Start" + +foldMapStr :: forall f. Foldable f => f String -> String +foldMapStr = foldMap identity + +m0 = M0 :: MArrStr +m1 = M1 "a" ["b", "c"] :: MArrStr +m2 = M2 0 identity :: MArrStr +m3 = M3 ["a", "b", "c"] :: MArrStr +m4 = M4 recordValue :: MArrStr +m5 = M5 { nested: recordValue } :: MArrStr +m6 = M6 1 "a" [] ["b"] ["c"] [] recordValue { nested: recordValue } :: MArrStr +m7 = M7 [[{ nested: recordValue }]] :: MArrStr + +recordValue :: RecordFields Array String +recordValue = + { a: "a" + , zArrayA: ["c"] + , fa: ["b"] + , ignore: 1 + , arrayIgnore: [2, 3] + , fIgnore: [4] + } + +main = do + assertEqual' "foldl - M0" { expected: "Start", actual: foldlStr m0 } + assertEqual' "foldl - M1" { expected: "Startb>c>Start", actual: foldrStr m1 } + assertEqual' "foldr - M2" { expected: "Start", actual: foldrStr m2 } + assertEqual' "foldr - M3" { expected: "a>b>c>Start", actual: foldrStr m3 } + assertEqual' "foldr - M4" { expected: "a>b>c>Start", actual: foldrStr m4 } + assertEqual' "foldr - M5" { expected: "a>b>c>Start", actual: foldrStr m5 } + assertEqual' "foldr - M6" { expected: "a>b>c>a>b>c>a>b>c>Start", actual: foldrStr m6 } + assertEqual' "foldr - M7" { expected: "a>b>c>Start", actual: foldrStr m7 } + + assertEqual' "foldMap - M0" { expected: "", actual: foldMapStr m0 } + assertEqual' "foldMap - M1" { expected: "abc", actual: foldMapStr m1 } + assertEqual' "foldMap - M2" { expected: "", actual: foldMapStr m2 } + assertEqual' "foldMap - M3" { expected: "abc", actual: foldMapStr m3 } + assertEqual' "foldMap - M4" { expected: "abc", actual: foldMapStr m4 } + assertEqual' "foldMap - M5" { expected: "abc", actual: foldMapStr m5 } + assertEqual' "foldMap - M6" { expected: "abcabcabc", actual: foldMapStr m6 } + assertEqual' "foldMap - M7" { expected: "abc", actual: foldMapStr m7 } + + log "Done" diff --git a/tests/purs/passing/DerivingFunctor.purs b/tests/purs/passing/DerivingFunctor.purs index f46c7c8d5f..de40593ad2 100644 --- a/tests/purs/passing/DerivingFunctor.purs +++ b/tests/purs/passing/DerivingFunctor.purs @@ -3,34 +3,122 @@ module Main where import Prelude import Data.Eq (class Eq1) import Effect.Console (log) +import Data.List (List(..), (:)) +import Data.Tuple (Tuple(..)) import Test.Assert -type MyRecord a = { myField :: a } +type RecordFields f a = + { a :: a + , zArrayA :: Array a + , fa :: f a + , ignore :: Int + , recursiveA :: Array (Tuple Int (Array a)) + , arrayIgnore :: Array Int + , fIgnore :: f Int + , empty :: {} + } data M f a = M0 a (Array a) | M1 Int | M2 (f a) - | M3 { foo :: Int, bar :: a, baz :: f a } - | M4 (MyRecord a) + | M3 (RecordFields f a) + | M4 { nested :: RecordFields f a } + | M5 Int a (Array Int) (Array a) (f a) (f Int) (RecordFields f a) { nested :: RecordFields f a } + | M6 (Array (Array (Array a))) derive instance eqM :: (Eq1 f, Eq a) => Eq (M f a) derive instance functorM :: Functor f => Functor (M f) +type MA = M Array + +m0L = M0 0 [1, 2] :: MA Int +m0R = M0 "0" ["1", "2"] :: MA String + +m1L = M1 0 :: MA Int +m1R = M1 0 :: MA String + +m2L = M2 [0, 1] :: MA Int +m2R = M2 ["0", "1"] :: MA String + +m3L = M3 recordValueL :: MA Int +m3R = M3 recordValueR :: MA String + +m4L = M4 { nested: recordValueL } :: MA Int +m4R = M4 { nested: recordValueR } :: MA String + +m5L = M5 0 1 [2, 3] [3, 4] [5, 6] [7, 8] recordValueL { nested: recordValueL } :: MA Int +m5R = M5 0 "1" [2, 3] ["3", "4"] ["5", "6"] [7, 8] recordValueR { nested: recordValueR } :: MA String + +recordValueL :: RecordFields Array Int +recordValueL = { a: 71, zArrayA: [72], fa: [73], ignore: 91, recursiveA: [ Tuple 1 [1], Tuple 2 [2] ], arrayIgnore: [92, 93], fIgnore: [94], empty: {} } + +recordValueR :: RecordFields Array String +recordValueR = { a: "71", zArrayA: ["72"], fa: ["73"], ignore: 91, recursiveA: [ Tuple 1 ["1"], Tuple 2 ["2"] ], arrayIgnore: [92, 93], fIgnore: [94], empty: {} } + +m6L = M6 [[[1, 2]]] :: MA Int +m6R = M6 [[["1", "2"]]] :: MA String + +maTests = do + assert' "map - M0" $ map show m0L == m0R + assert' "map - M1" $ map show m1L == m1R + assert' "map - M2" $ map show m2L == m2R + assert' "map - M3" $ map show m3L == m3R + assert' "map - M4" $ map show m4L == m4R + assert' "map - M5" $ map show m5L == m5R + assert' "map - M6" $ map show m6L == m6R + +data Fun1 a = Fun1 (Int -> Int -> a) +derive instance Functor Fun1 + +f1Test = do + assert' "map - Fun1" do + let + fn = show + left a b = a + b + right a b = fn $ left a b + Fun1 left' = map fn $ Fun1 left + left' 1 2 == right 1 2 + +data Fun2 a = Fun2 (Int -> Int -> Array (Array a)) +derive instance Functor Fun2 + +f2Test = do + assert' "map - Fun2" do + let + fn = show + left a b = [[a + b]] + right a b = map (map fn) $ left a b + Fun2 left' = map fn $ Fun2 left + left' 1 2 == right 1 2 + +data Fun3 f a = Fun3 (Unit -> Array (f (Array { nested :: RecordFields f a }))) +derive instance Functor f => Functor (Fun3 f) + +f3Test = do + assert' "map - Fun3" do + let + left _ = [[[{ nested: recordValueL }]]] + right _ = [[[{ nested: recordValueR }]]] + Fun3 left' = map show $ Fun3 left + left' unit == right unit + data T a = T (forall t. Show t => t -> a) derive instance functorT :: Functor T -type MA = M Array +taTests = do + case map show (T \_ -> 42) of + T f -> assert' "map show T" $ f "hello" == "42" + _ -> assert' "map show T" false -main = do - assert $ map show (M0 0 [1, 2] :: MA Int) == M0 "0" ["1", "2"] - assert $ map show (M1 0 :: MA Int) == M1 0 - assert $ map show (M2 [0, 1] :: MA Int) == M2 ["0", "1"] - assert $ map show (M3 {foo: 0, bar: 1, baz: [2, 3]} :: MA Int) == M3 {foo: 0, bar: "1", baz: ["2", "3"]} - assert $ map show (M4 { myField: 42 }) == (M4 { myField: "42" } :: MA String) +funTests = do + f1Test + f2Test + f3Test + taTests - case map show (T \_ -> 42) of - T f -> assert $ f "hello" == "42" - _ -> assert false +main = do + maTests + funTests log "Done" diff --git a/tests/purs/passing/DerivingTraversable.purs b/tests/purs/passing/DerivingTraversable.purs new file mode 100644 index 0000000000..c7ef3cb8a7 --- /dev/null +++ b/tests/purs/passing/DerivingTraversable.purs @@ -0,0 +1,110 @@ +module Main where + +import Prelude + +import Effect.Console (log) +import Data.Eq (class Eq1) +import Data.Foldable (class Foldable) +import Data.Traversable (class Traversable, traverse, sequence) +import Test.Assert + +-- Traverse order is done in alphabetical ordering of labels, +-- not their order in definition +type RecordFields f a = + { a :: a + , zArrayA :: Array a + , fa :: f a + , ignore :: Int + , arrayIgnore :: Array Int + , fIgnore :: f Int + } + +data M f a + = M0 + | M1 a (Array a) + | M2 Int + | M3 (f a) + | M4 (RecordFields f a) + | M5 { nested :: RecordFields f a } + | M6 Int a (Array Int) (Array a) (f a) (f Int) (RecordFields f a) { nested :: RecordFields f a } + | M7 (f (f { nested :: RecordFields f a })) + +-- Note: all 4 of these constraints are needed to compile this code +derive instance + ( Eq1 f + , Eq (f (f { nested :: RecordFields f a })) + , Eq (f { nested :: RecordFields f a }) + , Eq a + ) => Eq (M f a) +derive instance Functor f => Functor (M f) +derive instance Foldable f => Foldable (M f) +derive instance Traversable f => Traversable (M f) + +type MArrStr = M Array String + +traverseStr :: forall f. Traversable f => f String -> Array (f String) +traverseStr = traverse pure + +sequenceStr :: forall f. Traversable f => f (Array String) -> Array (f String) +sequenceStr = sequence + +m0 = M0 :: MArrStr +m1 = M1 "a" ["b", "c"] :: MArrStr +m2 = M2 0 :: MArrStr +m3 = M3 ["a", "b", "c"] :: MArrStr +m4 = M4 recordValue :: MArrStr +m5 = M5 { nested: recordValue } :: MArrStr +m6 = M6 1 "a" [] ["b"] ["c"] [] recordValue { nested: recordValue } :: MArrStr +m7 = M7 [ [ { nested: recordValue } ] ] :: MArrStr + +recordValue :: RecordFields Array String +recordValue = + { a: "a" + , zArrayA: ["c"] + , fa: ["b"] + , ignore: 1 + , arrayIgnore: [2, 3] + , fIgnore: [4] + } + +type MArrArrStr = M Array (Array String) + +m0' = M0 :: MArrArrStr +m1' = M1 ["a"] [["b"], ["c"]] :: MArrArrStr +m2' = M2 0 :: MArrArrStr +m3' = M3 [["a"], ["b"], ["c"]] :: MArrArrStr +m4' = M4 recordValue' :: MArrArrStr +m5' = M5 { nested: recordValue' } :: MArrArrStr +m6' = M6 1 ["a"] [] [["b"]] [["c"]] [] recordValue' { nested: recordValue' } :: MArrArrStr +m7' = M7 [ [ { nested: recordValue' } ] ] :: MArrArrStr + +recordValue' :: RecordFields Array (Array String) +recordValue' = + { a: ["a"] + , zArrayA: [["c"]] + , fa: [["b"]] + , ignore: 1 + , arrayIgnore: [2, 3] + , fIgnore: [4] + } + +main = do + assert' "traverse - m0" $ traverseStr m0 == [m0] + assert' "traverse - m1" $ traverseStr m1 == [m1] + assert' "traverse - m2" $ traverseStr m2 == [m2] + assert' "traverse - m3" $ traverseStr m3 == [m3] + assert' "traverse - m4" $ traverseStr m4 == [m4] + assert' "traverse - m5" $ traverseStr m5 == [m5] + assert' "traverse - m6" $ traverseStr m6 == [m6] + assert' "traverse - m7" $ traverseStr m7 == [m7] + + assert' "sequence - m0" $ sequenceStr m0' == [m0] + assert' "sequence - m1" $ sequenceStr m1' == [m1] + assert' "sequence - m2" $ sequenceStr m2' == [m2] + assert' "sequence - m3" $ sequenceStr m3' == [m3] + assert' "sequence - m4" $ sequenceStr m4' == [m4] + assert' "sequence - m5" $ sequenceStr m5' == [m5] + assert' "sequence - m6" $ sequenceStr m6' == [m6] + assert' "sequence - m7" $ sequenceStr m7' == [m7] + + log "Done" From 405c82d69c45593dbac450a8fac2ab289806a3e8 Mon Sep 17 00:00:00 2001 From: Verity Scheel Date: Sat, 1 Oct 2022 08:35:30 -0400 Subject: [PATCH 1506/1580] New algorithm for computing covering sets (#4195) Add implementation by @rhendric, minimize covering sets at the end --- CHANGELOG.d/fix_4194.md | 3 + src/Language/PureScript/Environment.hs | 135 ++++++++++++------- tests/purs/passing/4194.purs | 14 ++ tests/purs/passing/SingleInstanceFundep.purs | 21 +++ 4 files changed, 125 insertions(+), 48 deletions(-) create mode 100644 CHANGELOG.d/fix_4194.md create mode 100644 tests/purs/passing/4194.purs create mode 100644 tests/purs/passing/SingleInstanceFundep.purs diff --git a/CHANGELOG.d/fix_4194.md b/CHANGELOG.d/fix_4194.md new file mode 100644 index 0000000000..5bfabe769b --- /dev/null +++ b/CHANGELOG.d/fix_4194.md @@ -0,0 +1,3 @@ +* Fix a bug where the compiler did not consider interactions of all functional dependencies in classes. + In particular, combinations of multiple parameters determining other parameter(s) were not handled properly, + affecting overlapping instance checks and the selection of which parameters are fully determined. diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 87dd56ecdc..45d3428969 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -1,21 +1,22 @@ module Language.PureScript.Environment where import Prelude.Compat -import Protolude (ordNub) import GHC.Generics (Generic) import Control.DeepSeq (NFData) +import Control.Monad (unless) import Codec.Serialise (Serialise) import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A +import Data.Foldable (find, fold) +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS import qualified Data.Map as M import qualified Data.Set as S -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe) +import Data.Semigroup (First(..)) import Data.Text (Text) import qualified Data.Text as T -import Data.Tree (Tree, rootLabel) -import qualified Data.Graph as G -import Data.Foldable (toList) import qualified Data.List.NonEmpty as NEL import Language.PureScript.AST.SourcePos @@ -129,49 +130,87 @@ makeTypeClassData -> TypeClassData makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs coveringSets where - argumentIndices = [0 .. length args - 1] - - -- each argument determines themselves - identities = (\i -> (i, [i])) <$> argumentIndices - - -- list all the edges in the graph: for each fundep an edge exists for each determiner to each determined - contributingDeps = M.fromListWith (++) $ identities ++ do - fd <- deps - src <- fdDeterminers fd - (src, fdDetermined fd) : map (, []) (fdDetermined fd) - - -- build a graph of which arguments determine other arguments - (depGraph, fromVertex, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, ordNub v)) <$> M.toList contributingDeps) - - -- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to - isFunDepDetermined :: Int -> Bool - isFunDepDetermined arg = case fromKey arg of - Nothing -> internalError "Unknown argument index in makeTypeClassData" - Just v -> let contributesToVar = G.reachable (G.transposeG depGraph) v - varContributesTo = G.reachable depGraph v - in any (`notElem` varContributesTo) contributesToVar - - -- find all the arguments that are determined - determinedArgs :: S.Set Int - determinedArgs = S.fromList $ filter isFunDepDetermined argumentIndices - - argFromVertex :: G.Vertex -> Int - argFromVertex index = let (_, arg, _) = fromVertex index in arg - - isVertexDetermined :: G.Vertex -> Bool - isVertexDetermined = isFunDepDetermined . argFromVertex - - -- from an scc find the non-determined args - sccNonDetermined :: Tree G.Vertex -> Maybe [Int] - sccNonDetermined tree - -- if any arg in an scc is determined then all of them are - | isVertexDetermined (rootLabel tree) = Nothing - | otherwise = Just (argFromVertex <$> toList tree) - - -- find the covering sets - coveringSets :: S.Set (S.Set Int) - coveringSets = let funDepSets = sequence (mapMaybe sccNonDetermined (G.scc depGraph)) - in S.fromList (S.fromList <$> funDepSets) + ( determinedArgs, coveringSets ) = computeCoveringSets (length args) deps + +-- A moving frontier of sets to consider, along with the fundeps that can be +-- applied in each case. At each stage, all sets in the frontier will be the +-- same size, decreasing by 1 each time. +type Frontier = M.Map IS.IntSet (First (IM.IntMap (NEL.NonEmpty IS.IntSet))) +-- ^ ^ ^ ^ +-- when *these* parameters | | | +-- are still needed, | | | +-- *these* parameters | | +-- can be determined | | +-- from a non-zero | +-- number of fundeps, | +-- which accept *these* +-- parameters as inputs. + +computeCoveringSets :: Int -> [FunctionalDependency] -> (S.Set Int, S.Set (S.Set Int)) +computeCoveringSets nargs deps = ( determinedArgs, coveringSets ) + where + argumentIndices = S.fromList [0 .. nargs - 1] + + -- Compute all sets of arguments that determine the remaining arguments via + -- functional dependencies. This is done in stages, where each stage + -- considers sets of the same size to share work. + allCoveringSets :: S.Set (S.Set Int) + allCoveringSets = S.map (S.fromDistinctAscList . IS.toAscList) $ fst $ search $ + -- The initial frontier consists of just the set of all parameters and all + -- fundeps organized into the map structure. + M.singleton + (IS.fromList [0 .. nargs - 1]) $ + First $ IM.fromListWith (<>) $ do + fd <- deps + let srcs = pure (IS.fromList (fdDeterminers fd)) + tgt <- fdDetermined fd + pure (tgt, srcs) + + where + + -- Recursively advance the frontier until all frontiers are exhausted + -- and coverings sets found. The covering sets found during the process + -- are locally-minimal, in that none can be reduced by a fundep, but + -- there may be subsets found from other frontiers. + search :: Frontier -> (S.Set IS.IntSet, ()) + search frontier = unless (null frontier) $ M.foldMapWithKey step frontier >>= search + + -- The input set from the frontier is known to cover all parameters, but + -- it may be able to be reduced by more fundeps. + step :: IS.IntSet -> First (IM.IntMap (NEL.NonEmpty IS.IntSet)) -> (S.Set IS.IntSet, Frontier) + step needed (First inEdges) + -- If there are no applicable fundeps, record it as a locally minimal + -- covering set. This has already been reduced to only applicable fundeps + | IM.null inEdges = (S.singleton needed, M.empty) + | otherwise = (S.empty, foldMap removeParameter paramsToTry) + + where + + determined = IM.keys inEdges + -- If there is an acyclically determined functional dependency, prefer + -- it to reduce the number of cases to check. That is a dependency + -- that does not help determine other parameters. + acycDetermined = find (`IS.notMember` (IS.unions $ concatMap NEL.toList $ IM.elems inEdges)) determined + paramsToTry = maybe determined pure acycDetermined + + -- For each parameter to be removed to build the next frontier, + -- delete the fundeps that determine it and filter out the fundeps + -- that make use of it. Of course, if it an acyclic fundep we already + -- found that there are none that use it. + removeParameter :: Int -> Frontier + removeParameter y = + M.singleton + (IS.delete y needed) $ + case acycDetermined of + Just _ -> First $ IM.delete y inEdges + Nothing -> + First $ IM.mapMaybe (NEL.nonEmpty . NEL.filter (y `IS.notMember`)) $ IM.delete y inEdges + + -- Reduce to the inclusion-minimal sets + coveringSets = S.filter (\v -> not (any (\c -> c `S.isProperSubsetOf` v) allCoveringSets)) allCoveringSets + + -- An argument is determined if it is in no covering set + determinedArgs = argumentIndices `S.difference` fold coveringSets -- | The visibility of a name in scope data NameVisibility diff --git a/tests/purs/passing/4194.purs b/tests/purs/passing/4194.purs new file mode 100644 index 0000000000..30ecb21e6b --- /dev/null +++ b/tests/purs/passing/4194.purs @@ -0,0 +1,14 @@ +module Main where + +import Effect.Console (log) + +data Identity a +data Maybe a + +class ErrorSemigroup o m w | w -> o m, o m -> w + +instance ErrorSemigroup (Identity o) (Identity m) (Identity w) + +instance ErrorSemigroup o (Maybe m) (Maybe w) + +main = log "Done" diff --git a/tests/purs/passing/SingleInstanceFundep.purs b/tests/purs/passing/SingleInstanceFundep.purs new file mode 100644 index 0000000000..6b60504291 --- /dev/null +++ b/tests/purs/passing/SingleInstanceFundep.purs @@ -0,0 +1,21 @@ +module Main where + +import Prelude +import Effect.Console (log) +import Type.Proxy (Proxy(..)) + +-- This class can only have a single instance due to the functional dependency +class SingleInstanceFundep (r :: Row Type) | -> r where + unified :: Proxy r + +-- The row literal is valid in this instance head since it is fully determined +instance SingleInstanceFundep ( x :: Unit ) where + unified = Proxy + +-- This should infer `test :: Proxy ( x :: Unit )` by committing to the instance +test :: Proxy _ +test = unified + +main = do + let (Proxy :: Proxy ( x :: Unit )) = test + log "Done" From a3beca3ccc17e3b0b645d52a1ccc4f521c02a019 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Fri, 7 Oct 2022 08:07:15 -0400 Subject: [PATCH 1507/1580] Revise CannotDeriveInvalidConstructorArg errors (#4395) --- app/Command/Compile.hs | 14 +- app/Command/Graph.hs | 4 +- purescript.cabal | 3 +- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/Errors.hs | 127 +- src/Language/PureScript/Errors/JSON.hs | 10 +- src/Language/PureScript/Ide/Error.hs | 16 +- src/Language/PureScript/Ide/Rebuild.hs | 6 +- src/Language/PureScript/Ide/Types.hs | 2 +- .../PureScript/TypeChecker/Deriving.hs | 64 +- tests/TestCompiler.hs | 36 +- tests/TestSourceMaps.hs | 5 +- tests/TestUtils.hs | 71 +- tests/purs/failing/FoldableInstance10.out | 44 +- tests/purs/failing/FoldableInstance10.purs | 1 - tests/purs/failing/FoldableInstance5.out | 14 +- tests/purs/failing/FoldableInstance6.out | 14 +- tests/purs/failing/FoldableInstance7.out | 14 +- tests/purs/failing/FoldableInstance8.out | 17 +- tests/purs/failing/FoldableInstance9.out | 1227 +---------------- tests/purs/failing/FoldableInstance9.purs | 44 - 21 files changed, 314 insertions(+), 1421 deletions(-) diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 4383e6b8e4..3972994194 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -33,11 +33,11 @@ data PSCMakeOptions = PSCMakeOptions } -- | Arguments: verbose, use JSON, warnings, errors -printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO () -printWarningsAndErrors verbose False warnings errors = do +printWarningsAndErrors :: Bool -> Bool -> [(FilePath, T.Text)] -> P.MultipleErrors -> Either P.MultipleErrors a -> IO () +printWarningsAndErrors verbose False files warnings errors = do pwd <- getCurrentDirectory cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stdout - let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose, P.ppeRelativeDirectory = pwd } + let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose, P.ppeRelativeDirectory = pwd, P.ppeFileContents = files } when (P.nonEmpty warnings) $ putStrLn (P.prettyPrintMultipleWarnings ppeOpts warnings) case errors of @@ -45,10 +45,10 @@ printWarningsAndErrors verbose False warnings errors = do putStrLn (P.prettyPrintMultipleErrors ppeOpts errs) exitFailure Right _ -> return () -printWarningsAndErrors verbose True warnings errors = do +printWarningsAndErrors verbose True files warnings errors = do putStrLn . LBU8.toString . A.encode $ - JSONResult (toJSONErrors verbose P.Warning warnings) - (either (toJSONErrors verbose P.Error) (const []) errors) + JSONResult (toJSONErrors verbose P.Warning files warnings) + (either (toJSONErrors verbose P.Error files) (const []) errors) either (const exitFailure) (const (return ())) errors compile :: PSCMakeOptions -> IO () @@ -66,7 +66,7 @@ compile PSCMakeOptions{..} = do foreigns <- inferForeignModules filePathMap let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix P.make makeActions (map snd ms) - printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors + printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors exitSuccess warnFileTypeNotFound :: String -> IO () diff --git a/app/Command/Graph.hs b/app/Command/Graph.hs index ca2b5d7060..7d8467a7e8 100644 --- a/app/Command/Graph.hs +++ b/app/Command/Graph.hs @@ -79,8 +79,8 @@ printWarningsAndErrors False warnings errors = do printWarningsAndErrors True warnings errors = do let verbose = True hPutStrLn stderr . LBU8.toString . Json.encode $ - JSONResult (toJSONErrors verbose P.Warning warnings) - (either (toJSONErrors verbose P.Error) (const []) errors) + JSONResult (toJSONErrors verbose P.Warning [] warnings) + (either (toJSONErrors verbose P.Error []) (const []) errors) case errors of Left _errs -> exitFailure Right res -> pure res diff --git a/purescript.cabal b/purescript.cabal index 65fa328ffc..b3e1fd43eb 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -186,7 +186,8 @@ common defaults typed-process >=0.2.10.1 && <0.3, unordered-containers >=0.2.19.1 && <0.3, utf8-string >=1.0.2 && <1.1, - vector >=0.12.3.1 && <0.13 + vector >=0.12.3.1 && <0.13, + witherable >=0.4.2 && <0.5 library import: defaults diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index dfd5efcd34..a4ae107ce5 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -88,7 +88,7 @@ data ErrorMessageHint | ErrorSolvingConstraint SourceConstraint | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName)) | PositionedError (NEL.NonEmpty SourceSpan) - | ErrorUnderLabel PSString + | RelatedPositions (NEL.NonEmpty SourceSpan) deriving (Show) -- | Categories of hints diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index c633a5ca60..87e4dbcd1f 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -7,6 +7,7 @@ import Prelude.Compat import Control.Arrow ((&&&)) import Control.Exception (displayException) +import Control.Lens (both, head1, over) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.State.Lazy @@ -14,18 +15,22 @@ import Control.Monad.Writer import Data.Bifunctor (first, second) import Data.Bitraversable (bitraverse) import Data.Char (isSpace) +import Data.Containers.ListUtils (nubOrdOn) import Data.Either (partitionEithers) import Data.Foldable (fold) +import Data.Function (on) +import Data.Functor (($>)) import Data.Functor.Identity (Identity(..)) -import Data.List (transpose, nubBy, partition, dropWhileEnd, sortOn) +import Data.List (transpose, nubBy, partition, dropWhileEnd, sortOn, uncons) import qualified Data.List.NonEmpty as NEL import Data.List.NonEmpty (NonEmpty((:|))) -import Data.Maybe (maybeToList, fromMaybe, mapMaybe) +import Data.Maybe (maybeToList, fromMaybe, isJust, mapMaybe) import qualified Data.Map as M import Data.Ord (Down(..)) import qualified Data.Set as S import qualified Data.Text as T import Data.Text (Text) +import Data.Traversable (for) import qualified GHC.Stack import Language.PureScript.AST import qualified Language.PureScript.Bundle as Bundle @@ -45,7 +50,9 @@ import Language.PureScript.Traversals import Language.PureScript.Types import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers import qualified System.Console.ANSI as ANSI +import System.FilePath (makeRelative) import qualified Text.PrettyPrint.Boxes as Box +import Witherable (wither) -- | A type of error messages data SimpleErrorMessage @@ -188,7 +195,7 @@ data SimpleErrorMessage | UnsupportedRoleDeclaration | RoleDeclarationArityMismatch (ProperName 'TypeName) Int Int | DuplicateRoleDeclaration (ProperName 'TypeName) - | CannotDeriveInvalidConstructorArg Text SourceSpan + | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) deriving (Show) data ErrorMessage = ErrorMessage @@ -200,10 +207,12 @@ newtype ErrorSuggestion = ErrorSuggestion Text -- | Get the source span for an error errorSpan :: ErrorMessage -> Maybe (NEL.NonEmpty SourceSpan) -errorSpan = findHint matchSpan +errorSpan = findHint matchPE <> findHint matchRP where - matchSpan (PositionedError ss) = Just ss - matchSpan _ = Nothing + matchPE (PositionedError sss) = Just sss + matchPE _ = Nothing + matchRP (RelatedPositions sss) = Just sss + matchRP _ = Nothing -- | Get the module name for an error errorModule :: ErrorMessage -> Maybe ModuleName @@ -579,7 +588,6 @@ colorCodeBox codeColor b = case codeColor of , Box.vcat Box.top $ replicate (Box.rows b) $ Box.text ansiColorReset ] - -- | Default color intensity and color for code defaultCodeColor :: (ANSI.ColorIntensity, ANSI.Color) defaultCodeColor = (ANSI.Dull, ANSI.Yellow) @@ -591,6 +599,7 @@ data PPEOptions = PPEOptions , ppeLevel :: Level -- ^ Should this report an error or a warning? , ppeShowDocs :: Bool -- ^ Should show a link to error message's doc page? , ppeRelativeDirectory :: FilePath -- ^ FilePath to which the errors are relative + , ppeFileContents :: [(FilePath, Text)] -- ^ Unparsed contents of source files } -- | Default options for PPEOptions @@ -601,11 +610,12 @@ defaultPPEOptions = PPEOptions , ppeLevel = Error , ppeShowDocs = True , ppeRelativeDirectory = mempty + , ppeFileContents = [] } -- | Pretty print a single error, simplifying if necessary prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box -prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = flip evalState defaultUnknownMap $ do +prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileContents) e = flip evalState defaultUnknownMap $ do em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) um <- get return (prettyPrintErrorMessage um em) @@ -1369,10 +1379,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl renderSimpleErrorMessage (DuplicateRoleDeclaration name) = line $ "Duplicate role declaration for " <> markCode (runProperName name) <> "." - renderSimpleErrorMessage (CannotDeriveInvalidConstructorArg tyVarName ss) = + renderSimpleErrorMessage (CannotDeriveInvalidConstructorArg className) = paras - [ line $ "The type variable `" <> tyVarName <> "` must only be used as the last argument in a data type:" - , indent $ line $ displaySourceSpan relPath ss + [ line $ "One or more type variables are in positions that prevent " <> markCode (runProperName $ disqualify className) <> " from being derived." + , line $ "To derive this class, make sure that these variables are only used as the final arguments to type constructors, " + <> "and that those type constructors themselves have instances of " <> markCode (runProperName $ disqualify className) <> "." ] renderHint :: ErrorMessageHint -> Box.Box -> Box.Box @@ -1539,10 +1550,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line $ "at " <> displaySourceSpan relPath (NEL.head srcSpan) , detail ] - renderHint (ErrorUnderLabel lbl) detail = + renderHint (RelatedPositions srcSpans) detail = paras [ detail - , line $ "under the label `" <> markCode (T.pack (decodeStringWithReplacement lbl)) <> "`" + , Box.moveRight 2 $ showSourceSpansInContext srcSpans ] printRow :: (Int -> Type a -> Box.Box) -> Type a -> Box.Box @@ -1648,7 +1659,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl Error -> "error" Warning -> "warning" - paras :: [Box.Box] -> Box.Box + paras :: forall f. Foldable f => f Box.Box -> Box.Box paras = Box.vcat Box.left -- | Simplify an error message @@ -1739,6 +1750,94 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl Box.<> (line . displayStartEndPos . fst $ getAnnForType ty) Qualified mn (Right inst) -> line . markCode . showQualified showIdent $ Qualified mn inst + -- | As of this writing, this function assumes that all provided SourceSpans + -- are non-overlapping (except for exact duplicates) and span no line breaks. A + -- more sophisticated implementation without this limitation would be possible + -- but isn't yet needed. + showSourceSpansInContext :: NonEmpty SourceSpan -> Box.Box + showSourceSpansInContext + = maybe Box.nullBox (paras . fmap renderFile . NEL.groupWith1 spanName . NEL.sort) + . NEL.nonEmpty + . NEL.filter ((> 0) . sourcePosLine . spanStart) + where + renderFile :: NonEmpty SourceSpan -> Box.Box + renderFile sss = maybe Box.nullBox (linesToBox . T.lines) $ lookup fileName fileContents + where + fileName = spanName $ NEL.head sss + header = lineS . (<> ":") . makeRelative relPath $ fileName + lineBlocks = makeLineBlocks $ NEL.groupWith1 (sourcePosLine . spanStart) sss + + linesToBox fileLines = Box.moveUp 1 $ header Box.// body + where + body + = Box.punctuateV Box.left (lineNumberStyle "...") + . map (paras . fmap renderLine) + . flip evalState (fileLines, 1) + . traverse (wither (\(i, x) -> fmap (i, , x) <$> ascLookupInState i) . NEL.toList) + $ NEL.toList lineBlocks + + makeLineBlocks :: NonEmpty (NonEmpty SourceSpan) -> NonEmpty (NonEmpty (Int, [SourceSpan])) + makeLineBlocks = startBlock + where + startBlock (h :| t) = over head1 (NEL.cons (pred $ headLineNumber h, [])) $ continueBlock h t + + continueBlock :: NonEmpty SourceSpan -> [NonEmpty SourceSpan] -> NonEmpty (NonEmpty (Int, [SourceSpan])) + continueBlock lineGroup = \case + [] -> + endBlock lineGroup [] + nextGroup : groups -> case pred $ ((-) `on` headLineNumber) nextGroup lineGroup of + n | n <= 3 -> + over head1 (appendExtraLines n lineGroup <>) $ continueBlock nextGroup groups + _ -> + endBlock lineGroup . NEL.toList . startBlock $ nextGroup :| groups + + endBlock :: NonEmpty SourceSpan -> [NonEmpty (Int, [SourceSpan])] -> NonEmpty (NonEmpty (Int, [SourceSpan])) + endBlock h t = appendExtraLines 1 h :| t + + headLineNumber = sourcePosLine . spanStart . NEL.head + + appendExtraLines :: Int -> NonEmpty SourceSpan -> NonEmpty (Int, [SourceSpan]) + appendExtraLines n lineGroup = (lineNum, NEL.toList lineGroup) :| [(lineNum + i, []) | i <- [1..n]] + where + lineNum = headLineNumber lineGroup + + renderLine :: (Int, Text, [SourceSpan]) -> Box.Box + renderLine (lineNum, text, sss) = numBox Box.<+> lineBox + where + colSpans = nubOrdOn fst $ map (over both (pred . sourcePosColumn) . (spanStart &&& spanEnd)) sss + numBox = lineNumberStyle $ show lineNum + lineBox = + if isJust codeColor + then colorCodeBox codeColor $ line $ foldr highlightSpan text colSpans + else line text Box.// line (finishUnderline $ foldr underlineSpan (T.length text, "") colSpans) + + highlightSpan :: (Int, Int) -> Text -> Text + highlightSpan (startCol, endCol) text + = prefix + <> T.pack (ANSI.setSGRCode [ANSI.SetSwapForegroundBackground True]) + <> spanText + <> T.pack (ANSI.setSGRCode [ANSI.SetSwapForegroundBackground False]) + <> suffix + where + (prefix, rest) = T.splitAt startCol text + (spanText, suffix) = T.splitAt (endCol - startCol) rest + + underlineSpan :: (Int, Int) -> (Int, Text) -> (Int, Text) + underlineSpan (startCol, endCol) (len, accum) = (startCol, T.replicate (endCol - startCol) "^" <> T.replicate (len - endCol) " " <> accum) + + finishUnderline :: (Int, Text) -> Text + finishUnderline (len, accum) = T.replicate len " " <> accum + + lineNumberStyle :: String -> Box.Box + lineNumberStyle = colorCodeBox (codeColor $> (ANSI.Vivid, ANSI.Black)) . Box.alignHoriz Box.right 5 . lineS + + -- | Lookup the nth element of a list, but without retraversing the list every + -- time, by instead keeping a tail of the list and the current element number + -- in State. Only works if the argument provided is strictly ascending over + -- the life of the State. + ascLookupInState :: forall a. Int -> State ([a], Int) (Maybe a) + ascLookupInState j = get >>= \(as, i) -> for (uncons $ drop (j - i) as) $ \(a, as') -> put (as', succ j) $> a + -- Pretty print and export declaration prettyPrintExport :: DeclarationRef -> Text prettyPrintExport (TypeRef _ pn _) = runProperName pn diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index 00c3170774..09e565b7a9 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -43,13 +43,13 @@ $(A.deriveJSON A.defaultOptions ''ErrorSuggestion) $(A.deriveJSON A.defaultOptions ''JSONError) $(A.deriveJSON A.defaultOptions ''JSONResult) -toJSONErrors :: Bool -> P.Level -> P.MultipleErrors -> [JSONError] -toJSONErrors verbose level = map (toJSONError verbose level) . P.runMultipleErrors +toJSONErrors :: Bool -> P.Level -> [(FilePath, Text)] -> P.MultipleErrors -> [JSONError] +toJSONErrors verbose level files = map (toJSONError verbose level files) . P.runMultipleErrors -toJSONError :: Bool -> P.Level -> P.ErrorMessage -> JSONError -toJSONError verbose level e = +toJSONError :: Bool -> P.Level -> [(FilePath, Text)] -> P.ErrorMessage -> JSONError +toJSONError verbose level files e = JSONError (toErrorPosition <$> fmap NEL.head spans) - (P.renderBox (P.prettyPrintSingleError (P.PPEOptions Nothing verbose level False mempty) (P.stripModuleAndSpan e))) + (P.renderBox (P.prettyPrintSingleError (P.PPEOptions Nothing verbose level False mempty files) (P.stripModuleAndSpan e))) (P.errorCode e) (P.errorDocUri e) (P.spanName <$> fmap NEL.head spans) diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index ee99948638..523c335412 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -31,29 +31,29 @@ data IdeError | NotFound Text | ModuleNotFound ModuleIdent | ModuleFileNotFound ModuleIdent - | RebuildError P.MultipleErrors + | RebuildError [(FilePath, Text)] P.MultipleErrors deriving (Show) instance ToJSON IdeError where - toJSON (RebuildError errs) = object + toJSON (RebuildError files errs) = object [ "resultType" .= ("error" :: Text) - , "result" .= encodeRebuildErrors errs + , "result" .= encodeRebuildErrors files errs ] toJSON err = object [ "resultType" .= ("error" :: Text) , "result" .= textError err ] -encodeRebuildErrors :: P.MultipleErrors -> Value -encodeRebuildErrors = toJSON . map encodeRebuildError . P.runMultipleErrors +encodeRebuildErrors :: [(FilePath, Text)] -> P.MultipleErrors -> Value +encodeRebuildErrors files = toJSON . map encodeRebuildError . P.runMultipleErrors where encodeRebuildError err = case err of (P.ErrorMessage _ ((P.HoleInferredType name _ _ (Just P.TSAfter{tsAfterIdentifiers=idents, tsAfterRecordFields=fields})))) -> - insertTSCompletions name idents (fromMaybe [] fields) (toJSON (toJSONError False P.Error err)) + insertTSCompletions name idents (fromMaybe [] fields) (toJSON (toJSONError False P.Error files err)) _ -> - (toJSON . toJSONError False P.Error) err + (toJSON . toJSONError False P.Error files) err insertTSCompletions name idents fields (Aeson.Object value) = Aeson.Object @@ -91,7 +91,7 @@ textError (GeneralError msg) = msg textError (NotFound ident) = "Symbol '" <> ident <> "' not found." textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found." textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found" -textError (RebuildError err) = show err +textError (RebuildError _ err) = show err prettyPrintTypeSingleLine :: P.Type a -> Text prettyPrintTypeSingleLine = T.unwords . map T.strip . T.lines . T.pack . P.prettyPrintTypeWithUnicode maxBound diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index ac06b6e1e3..52a74a4d01 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -55,7 +55,7 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do let fp' = fromMaybe fp actualFile (pwarnings, m) <- case sequence $ CST.parseFromFile fp' input of Left parseError -> - throwError $ RebuildError $ CST.toMultipleErrors fp' parseError + throwError $ RebuildError [(fp', input)] $ CST.toMultipleErrors fp' parseError Right m -> pure m let moduleName = P.getModuleName m -- Externs files must be sorted ahead of time, so that they get applied @@ -75,7 +75,7 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do pure newExterns case result of Left errors -> - throwError (RebuildError errors) + throwError (RebuildError [(fp', input)] errors) Right newExterns -> do insertModule (fromMaybe file actualFile, m) insertExterns newExterns @@ -193,7 +193,7 @@ sortExterns m ex = do . M.delete (P.getModuleName m) $ ex case sorted' of Left err -> - throwError (RebuildError err) + throwError (RebuildError [] err) Right (sorted, graph) -> do let deps = fromJust (List.lookup (P.getModuleName m) graph) pure $ mapMaybe getExtern (deps `inOrderOf` map P.getModuleName sorted) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 8464a08c4c..f2748cdb50 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -287,7 +287,7 @@ instance ToJSON Success where ] ] ModuleList modules -> encodeSuccess modules - RebuildSuccess warnings -> encodeSuccess (P.toJSONErrors False P.Warning warnings) + RebuildSuccess warnings -> encodeSuccess (P.toJSONErrors False P.Warning [] warnings) encodeImport :: (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName) -> Aeson.Value encodeImport (P.runModuleName -> mn, importType, map P.runModuleName -> qualifier) = case importType of diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index eda0fb5daf..ca45877223 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -6,7 +6,7 @@ module Language.PureScript.TypeChecker.Deriving (deriveInstance) where import Protolude hiding (Type) import Control.Monad.Trans.Writer (Writer, WriterT, runWriter, runWriterT) -import Control.Monad.Writer.Class (MonadWriter(..), censor) +import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Foldable (foldl1, foldr1) import Data.List (init, last, zipWith3, (!!)) import qualified Data.Map as M @@ -71,19 +71,20 @@ deriveInstance instType className strategy = do let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs in lam UnusedIdent (DeferredDictionary superclass tyArgs) let superclasses = map mkString (superClassDictionaryNames typeClassSuperclasses) `zip` superclassesDicts - rethrow (addHint $ ErrorInInstance className tys) $ - App (Constructor nullSourceSpan ctorName) . mkLit . ObjectLiteral . (++ superclasses) <$> f mn tyCon + App (Constructor nullSourceSpan ctorName) . mkLit . ObjectLiteral . (++ superclasses) <$> f mn tyCon _ -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 + unaryClass' f = unaryClass (f className) + in case className of - Foldable.Foldable -> unaryClass deriveFoldable + Foldable.Foldable -> unaryClass' deriveFoldable Prelude.Eq -> unaryClass deriveEq Prelude.Eq1 -> unaryClass $ \_ _ -> deriveEq1 - Prelude.Functor -> unaryClass deriveFunctor + Prelude.Functor -> unaryClass' deriveFunctor Prelude.Ord -> unaryClass deriveOrd Prelude.Ord1 -> unaryClass $ \_ _ -> deriveOrd1 - Traversable.Traversable -> unaryClass deriveTraversable + Traversable.Traversable -> unaryClass' deriveTraversable -- See L.P.Sugar.TypeClasses.Deriving for the classes that can be -- derived prior to type checking. _ -> throwError . errorMessage $ CannotDerive className tys @@ -373,38 +374,29 @@ data ParamUsage | MentionsParam ParamUsage | IsRecord (NonEmpty (PSString, ParamUsage)) -type ParamErrorData = [([Either (ProperName 'ConstructorName) PSString], SourceSpan)] - validateParamsInTypeConstructors :: forall m . MonadError MultipleErrors m => MonadState CheckState m - => ModuleName + => Qualified (ProperName 'ClassName) + -> ModuleName -> ProperName 'TypeName -> m [(ProperName 'ConstructorName, [Maybe ParamUsage])] -validateParamsInTypeConstructors mn tyConNm = do +validateParamsInTypeConstructors derivingClass mn tyConNm = do (_, _, tyArgNames, ctors) <- lookupTypeDecl mn tyConNm param <- note (errorMessage $ KindsDoNotUnify (kindType -:> kindType) kindType) . lastMay $ map fst tyArgNames ctors' <- traverse (traverse $ traverse replaceAllTypeSynonyms) ctors - let (ctorUsages, errors) = runWriter $ traverse (addCtorHint . traverse . traverse $ typeToUsageOf param) ctors' - unless (null errors) $ - throwError . flip foldMap (sortOn snd $ ordNub errors) $ \(hints, ss) -> - addHints (either ErrorInDataConstructor ErrorUnderLabel <$> hints) $ - errorMessage $ CannotDeriveInvalidConstructorArg param ss + let (ctorUsages, problemSpans) = runWriter $ traverse (traverse . traverse $ typeToUsageOf param) ctors' + for_ (nonEmpty $ ordNub problemSpans) $ \sss -> + throwError . addHint (RelatedPositions sss) . errorMessage $ CannotDeriveInvalidConstructorArg derivingClass pure ctorUsages where - consHintData :: a -> Writer [([a], b)] c -> Writer [([a], b)] c - consHintData a = censor (map $ first (a :)) - - addCtorHint :: ((ProperName 'ConstructorName, a) -> Writer ParamErrorData b) -> (ProperName 'ConstructorName, a) -> Writer ParamErrorData b - addCtorHint f ctor = consHintData (Left $ fst ctor) $ f ctor - - typeToUsageOf :: Text -> SourceType -> Writer ParamErrorData (Maybe ParamUsage) + typeToUsageOf :: Text -> SourceType -> Writer [SourceSpan] (Maybe ParamUsage) typeToUsageOf param = go where - assertNoParamUsedIn :: SourceType -> Writer ParamErrorData () + assertNoParamUsedIn :: SourceType -> Writer [SourceSpan] () assertNoParamUsedIn = everythingOnTypes (*>) $ \case - TypeVar (ss, _) name | name == param -> tell [([], ss)] + TypeVar (ss, _) name | name == param -> tell [ss] _ -> pure () go = \case @@ -416,8 +408,7 @@ validateParamsInTypeConstructors mn tyConNm = do TypeApp _ (TypeConstructor _ Prim.Record) row -> fmap (fmap IsRecord . nonEmpty . catMaybes) . for (decomposeRec' row) $ \(Label lbl, ty) -> - consHintData (Right lbl) $ - fmap (lbl, ) <$> go ty + fmap (lbl, ) <$> go ty TypeApp _ tyFn tyArg -> do assertNoParamUsedIn tyFn @@ -495,11 +486,12 @@ deriveFunctor . MonadError MultipleErrors m => MonadState CheckState m => MonadSupply m - => ModuleName + => Qualified (ProperName 'ClassName) + -> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)] -deriveFunctor mn tyConNm = do - ctors <- validateParamsInTypeConstructors mn tyConNm +deriveFunctor nm mn tyConNm = do + ctors <- validateParamsInTypeConstructors nm mn tyConNm mapFun <- mkTraversal mn mapVar (TraversalOps identity identity) ctors pure [(Prelude.map, mapFun)] where @@ -519,11 +511,12 @@ deriveFoldable . MonadError MultipleErrors m => MonadState CheckState m => MonadSupply m - => ModuleName + => Qualified (ProperName 'ClassName) + -> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)] -deriveFoldable mn tyConNm = do - ctors <- validateParamsInTypeConstructors mn tyConNm +deriveFoldable nm mn tyConNm = do + ctors <- validateParamsInTypeConstructors nm mn tyConNm foldlFun <- mkAsymmetricFoldFunction False foldlVar ctors foldrFun <- mkAsymmetricFoldFunction True foldrVar ctors foldMapFun <- mkTraversal mn foldMapVar foldMapOps ctors @@ -583,11 +576,12 @@ deriveTraversable . MonadError MultipleErrors m => MonadState CheckState m => MonadSupply m - => ModuleName + => Qualified (ProperName 'ClassName) + -> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)] -deriveTraversable mn tyConNm = do - ctors <- validateParamsInTypeConstructors mn tyConNm +deriveTraversable nm mn tyConNm = do + ctors <- validateParamsInTypeConstructors nm mn tyConNm traverseFun <- mkTraversal mn traverseVar traverseOps ctors sequenceFun <- usingLamIdent $ pure . App (App traverseVar identityVar) pure [(Traversable.traverse, traverseFun), (Traversable.sequence, sequenceFun)] diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index dbda973cf2..8dda567d4b 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -135,9 +135,10 @@ assertCompiles -> Handle -> Expectation assertCompiles support inputFiles outputFile = do - (result, _) <- compile (Just IsMain) support inputFiles + (fileContents, (result, _)) <- compile (Just IsMain) support inputFiles + let errorOptions = P.defaultPPEOptions { P.ppeFileContents = fileContents } case result of - Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs + Left errs -> expectationFailure . P.prettyPrintMultipleErrors errorOptions $ errs Right _ -> do let entryPoint = modulesDir "index.js" writeFile entryPoint "import('./Main/index.js').then(({ main }) => main());" @@ -157,15 +158,16 @@ assertCompilesWithWarnings -> [String] -> Expectation assertCompilesWithWarnings support inputFiles shouldWarnWith = do - result'@(result, warnings) <- compile Nothing support inputFiles + (fileContents, result'@(result, warnings)) <- compile Nothing support inputFiles + let errorOptions = P.defaultPPEOptions { P.ppeFileContents = fileContents } case result of Left errs -> - expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs + expectationFailure . P.prettyPrintMultipleErrors errorOptions $ errs Right _ -> do - checkShouldReport shouldWarnWith (P.prettyPrintMultipleWarnings P.defaultPPEOptions) warnings + checkShouldReport shouldWarnWith (P.prettyPrintMultipleWarnings errorOptions) warnings goldenVsString (replaceExtension (getTestMain inputFiles) ".out") - (return . T.encodeUtf8 . T.pack $ printDiagnosticsForGoldenTest result') + (return . T.encodeUtf8 . T.pack $ printDiagnosticsForGoldenTest fileContents result') assertDoesNotCompile :: SupportModules @@ -173,7 +175,8 @@ assertDoesNotCompile -> [String] -> Expectation assertDoesNotCompile support inputFiles shouldFailWith = do - result <- compile Nothing support inputFiles + (fileContents, result) <- compile Nothing support inputFiles + let errorOptions = P.defaultPPEOptions { P.ppeFileContents = fileContents } case fst result of Left errs -> do when (null shouldFailWith) @@ -181,10 +184,10 @@ assertDoesNotCompile support inputFiles shouldFailWith = do "shouldFailWith declaration is missing (errors were: " ++ show (map P.errorCode (P.runMultipleErrors errs)) ++ ")") - checkShouldReport shouldFailWith (P.prettyPrintMultipleErrors P.defaultPPEOptions) errs + checkShouldReport shouldFailWith (P.prettyPrintMultipleErrors errorOptions) errs goldenVsString (replaceExtension (getTestMain inputFiles) ".out") - (return . T.encodeUtf8 . T.pack $ printDiagnosticsForGoldenTest result) + (return . T.encodeUtf8 . T.pack $ printDiagnosticsForGoldenTest fileContents result) Right _ -> expectationFailure "Should not have compiled" @@ -193,9 +196,10 @@ assertCompilesToExpectedOutput -> [FilePath] -> Expectation assertCompilesToExpectedOutput support inputFiles = do - (result, _) <- compile Nothing support inputFiles + (fileContents, (result, _)) <- compile Nothing support inputFiles + let errorOptions = P.defaultPPEOptions { P.ppeFileContents = fileContents } case result of - Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs + Left errs -> expectationFailure . P.prettyPrintMultipleErrors errorOptions $ errs Right _ -> goldenVsString (replaceExtension (getTestMain inputFiles) ".out.js") @@ -203,14 +207,16 @@ assertCompilesToExpectedOutput support inputFiles = do -- Prints a set of diagnostics (i.e. errors or warnings) as a string, in order -- to compare it to the contents of a golden test file. -printDiagnosticsForGoldenTest :: (Either P.MultipleErrors a, P.MultipleErrors) -> String -printDiagnosticsForGoldenTest (result, warnings) = +printDiagnosticsForGoldenTest :: [(FilePath, T.Text)] -> (Either P.MultipleErrors a, P.MultipleErrors) -> String +printDiagnosticsForGoldenTest fileContents (result, warnings) = normalizePaths $ case result of Left errs -> -- TODO: should probably include warnings when failing? - P.prettyPrintMultipleErrors P.defaultPPEOptions errs + P.prettyPrintMultipleErrors errorOptions errs Right _ -> - P.prettyPrintMultipleWarnings P.defaultPPEOptions warnings + P.prettyPrintMultipleWarnings errorOptions warnings + where + errorOptions = P.defaultPPEOptions { P.ppeFileContents = fileContents } -- Replaces Windows-style paths in an error or warning with POSIX paths normalizePaths :: String -> String diff --git a/tests/TestSourceMaps.hs b/tests/TestSourceMaps.hs index 347b0ce28a..ff8e7f26be 100644 --- a/tests/TestSourceMaps.hs +++ b/tests/TestSourceMaps.hs @@ -52,9 +52,10 @@ assertCompilesToExpectedValidOutput support inputFiles = do let modulePath = getTestMain inputFiles - (result, _) <- compile' compilationOptions (Just (IsSourceMap modulePath)) support inputFiles + (fileContents, (result, _)) <- compile' compilationOptions (Just (IsSourceMap modulePath)) support inputFiles + let errorOptions = P.defaultPPEOptions { P.ppeFileContents = fileContents } case result of - Left errs -> expectationFailure . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs + Left errs -> expectationFailure . P.prettyPrintMultipleErrors errorOptions $ errs Right actualSourceMapFile -> do let readAndDecode :: FilePath -> IO (Maybe Json.Value) diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 9ed7401a12..11c99d16de 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -189,7 +189,7 @@ compile :: Maybe ExpectedModuleName -> SupportModules -> [FilePath] - -> IO (Either P.MultipleErrors FilePath, P.MultipleErrors) + -> IO ([(FilePath, T.Text)], (Either P.MultipleErrors FilePath, P.MultipleErrors)) compile = compile' P.defaultOptions compile' @@ -197,41 +197,42 @@ compile' -> Maybe ExpectedModuleName -> SupportModules -> [FilePath] - -> IO (Either P.MultipleErrors FilePath, P.MultipleErrors) -compile' options expectedModule SupportModules{..} inputFiles = P.runMake options $ do + -> IO ([(FilePath, T.Text)], (Either P.MultipleErrors FilePath, P.MultipleErrors)) +compile' options expectedModule SupportModules{..} inputFiles = do -- Sorting the input files makes some messages (e.g., duplicate module) deterministic - fs <- liftIO $ readInput (sort inputFiles) - msWithWarnings <- CST.parseFromFiles id fs - tell $ foldMap (\(fp, (ws, _)) -> CST.toMultipleWarnings fp ws) msWithWarnings - let ms = fmap snd <$> msWithWarnings - foreigns <- inferForeignModules ms - let - actions = makeActions supportModules (foreigns `M.union` supportForeigns) - (hasExpectedModuleName, expectedModuleName, compiledModulePath) = case expectedModule of - -- Check if there is one (and only one) module called "Main" - Just IsMain -> - let - moduleName = "Main" - compiledPath = modulesDir moduleName "index.js" - in ((==) 1 $ length $ filter (== moduleName) $ fmap (T.unpack . getPsModuleName) ms, moduleName, compiledPath) - -- Check if main sourcemap module starts with "SourceMaps." and matches its file name - Just (IsSourceMap modulePath) -> - let - moduleName = "SourceMaps." <> (dropExtensions . takeFileName $ modulePath) - compiledPath = modulesDir moduleName "index.js.map" - in (maybe False ((==) moduleName . T.unpack . getPsModuleName) (find ((==) modulePath . fst) ms), moduleName, compiledPath) - Nothing -> (True, mempty, mempty) - - case ms of - [singleModule] -> do - unless hasExpectedModuleName $ - error ("While testing a single PureScript file, the expected module name was '" <> expectedModuleName <> - "' but got '" <> T.unpack (getPsModuleName singleModule) <> "'.") - compiledModulePath <$ P.rebuildModule actions supportExterns (snd singleModule) - _ -> do - unless hasExpectedModuleName $ - error $ "While testing multiple PureScript files, the expected main module was not found: '" <> expectedModuleName <> "'." - compiledModulePath <$ P.make actions (CST.pureResult <$> supportModules ++ map snd ms) + fs <- readInput (sort inputFiles) + fmap (fs, ) . P.runMake options $ do + msWithWarnings <- CST.parseFromFiles id fs + tell $ foldMap (\(fp, (ws, _)) -> CST.toMultipleWarnings fp ws) msWithWarnings + let ms = fmap snd <$> msWithWarnings + foreigns <- inferForeignModules ms + let + actions = makeActions supportModules (foreigns `M.union` supportForeigns) + (hasExpectedModuleName, expectedModuleName, compiledModulePath) = case expectedModule of + -- Check if there is one (and only one) module called "Main" + Just IsMain -> + let + moduleName = "Main" + compiledPath = modulesDir moduleName "index.js" + in ((==) 1 $ length $ filter (== moduleName) $ fmap (T.unpack . getPsModuleName) ms, moduleName, compiledPath) + -- Check if main sourcemap module starts with "SourceMaps." and matches its file name + Just (IsSourceMap modulePath) -> + let + moduleName = "SourceMaps." <> (dropExtensions . takeFileName $ modulePath) + compiledPath = modulesDir moduleName "index.js.map" + in (maybe False ((==) moduleName . T.unpack . getPsModuleName) (find ((==) modulePath . fst) ms), moduleName, compiledPath) + Nothing -> (True, mempty, mempty) + + case ms of + [singleModule] -> do + unless hasExpectedModuleName $ + error ("While testing a single PureScript file, the expected module name was '" <> expectedModuleName <> + "' but got '" <> T.unpack (getPsModuleName singleModule) <> "'.") + compiledModulePath <$ P.rebuildModule actions supportExterns (snd singleModule) + _ -> do + unless hasExpectedModuleName $ + error $ "While testing multiple PureScript files, the expected main module was not found: '" <> expectedModuleName <> "'." + compiledModulePath <$ P.make actions (CST.pureResult <$> supportModules ++ map snd ms) getPsModuleName :: (a, AST.Module) -> T.Text getPsModuleName psModule = case snd psModule of diff --git a/tests/purs/failing/FoldableInstance10.out b/tests/purs/failing/FoldableInstance10.out index 330d1de1e5..d05c441e19 100644 --- a/tests/purs/failing/FoldableInstance10.out +++ b/tests/purs/failing/FoldableInstance10.out @@ -1,38 +1,16 @@ -Error 1 of 2: +Error found: +in module FoldableInstance10 +at tests/purs/failing/FoldableInstance10.purs:11:1 - 11:30 (line 11, column 1 - line 11, column 30) - in module FoldableInstance10 - at tests/purs/failing/FoldableInstance10.purs:12:1 - 12:30 (line 12, column 1 - line 12, column 30) + One or more type variables are in positions that prevent Foldable from being derived. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. - The type variable `a` must only be used as the last argument in a data type: + tests/purs/failing/FoldableInstance10.purs: +  9  +  10 data Test a = Test (Variant (left :: a, right :: Array a)) +  11 derive instance Foldable Test - tests/purs/failing/FoldableInstance10.purs:11:38 - 11:39 (line 11, column 38 - line 11, column 39) - - in data constructor Test - in type class instance -   -  Data.Foldable.Foldable Test -   - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 2 of 2: - - in module FoldableInstance10 - at tests/purs/failing/FoldableInstance10.purs:12:1 - 12:30 (line 12, column 1 - line 12, column 30) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance10.purs:11:56 - 11:57 (line 11, column 56 - line 11, column 57) - - - in data constructor Test - in type class instance -   -  Data.Foldable.Foldable Test -   - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, +or to contribute content related to this error. diff --git a/tests/purs/failing/FoldableInstance10.purs b/tests/purs/failing/FoldableInstance10.purs index 17b05ec337..c191a4d46b 100644 --- a/tests/purs/failing/FoldableInstance10.purs +++ b/tests/purs/failing/FoldableInstance10.purs @@ -1,5 +1,4 @@ -- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg module FoldableInstance10 where import Prelude diff --git a/tests/purs/failing/FoldableInstance5.out b/tests/purs/failing/FoldableInstance5.out index f98d951708..485007f557 100644 --- a/tests/purs/failing/FoldableInstance5.out +++ b/tests/purs/failing/FoldableInstance5.out @@ -2,17 +2,15 @@ Error found: in module FoldableInstance5 at tests/purs/failing/FoldableInstance5.purs:9:1 - 9:30 (line 9, column 1 - line 9, column 30) - The type variable `a` must only be used as the last argument in a data type: + One or more type variables are in positions that prevent Foldable from being derived. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. - tests/purs/failing/FoldableInstance5.purs:8:27 - 8:28 (line 8, column 27 - line 8, column 28) + tests/purs/failing/FoldableInstance5.purs: +  7  +  8 data Test a = Test (Tuple a Int) +  9 derive instance Foldable Test -in data constructor Test -in type class instance -  - Data.Foldable.Foldable Test -  - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/FoldableInstance6.out b/tests/purs/failing/FoldableInstance6.out index dfa6bfb92f..148f229dad 100644 --- a/tests/purs/failing/FoldableInstance6.out +++ b/tests/purs/failing/FoldableInstance6.out @@ -2,17 +2,15 @@ Error found: in module FoldableInstance6 at tests/purs/failing/FoldableInstance6.purs:8:1 - 8:30 (line 8, column 1 - line 8, column 30) - The type variable `a` must only be used as the last argument in a data type: + One or more type variables are in positions that prevent Foldable from being derived. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. - tests/purs/failing/FoldableInstance6.purs:7:21 - 7:22 (line 7, column 21 - line 7, column 22) + tests/purs/failing/FoldableInstance6.purs: +  6  +  7 data Test a = Test (a -> Int) +  8 derive instance Foldable Test -in data constructor Test -in type class instance -  - Data.Foldable.Foldable Test -  - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/FoldableInstance7.out b/tests/purs/failing/FoldableInstance7.out index 214911ef6b..2a8ebf28dd 100644 --- a/tests/purs/failing/FoldableInstance7.out +++ b/tests/purs/failing/FoldableInstance7.out @@ -2,17 +2,15 @@ Error found: in module FoldableInstance6 at tests/purs/failing/FoldableInstance7.purs:9:1 - 9:30 (line 9, column 1 - line 9, column 30) - The type variable `a` must only be used as the last argument in a data type: + One or more type variables are in positions that prevent Foldable from being derived. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. - tests/purs/failing/FoldableInstance7.purs:8:27 - 8:28 (line 8, column 27 - line 8, column 28) + tests/purs/failing/FoldableInstance7.purs: +  7  +  8 data Test a = Test (Tuple a a) +  9 derive instance Foldable Test -in data constructor Test -in type class instance -  - Data.Foldable.Foldable Test -  - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/FoldableInstance8.out b/tests/purs/failing/FoldableInstance8.out index dcd3b02f89..c5fdd33b3f 100644 --- a/tests/purs/failing/FoldableInstance8.out +++ b/tests/purs/failing/FoldableInstance8.out @@ -2,20 +2,15 @@ Error found: in module FoldableInstance6 at tests/purs/failing/FoldableInstance8.purs:8:1 - 8:34 (line 8, column 1 - line 8, column 34) - The type variable `a` must only be used as the last argument in a data type: + One or more type variables are in positions that prevent Foldable from being derived. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. - tests/purs/failing/FoldableInstance8.purs:7:25 - 7:26 (line 7, column 25 - line 7, column 26) + tests/purs/failing/FoldableInstance8.purs: +  6  +  7 data Test f a = Test (f a a) +  8 derive instance Foldable (Test f) -in data constructor Test -in type class instance -  - Data.Foldable.Foldable (Test @Type f0) -  - -where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/FoldableInstance9.out b/tests/purs/failing/FoldableInstance9.out index 5a2e0af85f..862543eda1 100644 --- a/tests/purs/failing/FoldableInstance9.out +++ b/tests/purs/failing/FoldableInstance9.out @@ -1,1180 +1,49 @@ -Error 1 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:60:14 - 60:15 (line 60, column 14 - line 60, column 15) - - - in data constructor Test1 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 2 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:60:16 - 60:17 (line 60, column 16 - line 60, column 17) - - - in data constructor Test1 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 3 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:60:28 - 60:29 (line 60, column 28 - line 60, column 29) - - - in data constructor Test1 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 4 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:60:36 - 60:37 (line 60, column 36 - line 60, column 37) - - - in data constructor Test1 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 5 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:60:38 - 60:39 (line 60, column 38 - line 60, column 39) - - - in data constructor Test1 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 6 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:60:52 - 60:53 (line 60, column 52 - line 60, column 53) - - - in data constructor Test1 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 7 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:61:22 - 61:23 (line 61, column 22 - line 61, column 23) - - - under the label `all` - in data constructor Test2 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 8 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:61:24 - 61:25 (line 61, column 24 - line 61, column 25) - - - under the label `all` - in data constructor Test2 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 9 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:62:29 - 62:30 (line 62, column 29 - line 62, column 30) - - - under the label `rights` - in data constructor Test2 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 10 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:63:24 - 63:25 (line 63, column 24 - line 63, column 25) - - - under the label `lefts` - in data constructor Test2 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 11 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:63:26 - 63:27 (line 63, column 26 - line 63, column 27) - - - under the label `lefts` - in data constructor Test2 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 12 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:64:29 - 64:30 (line 64, column 29 - line 64, column 30) - - - under the label `middle` - in data constructor Test2 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 13 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:68:24 - 68:25 (line 68, column 24 - line 68, column 25) - - - in data constructor Test3 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 14 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:68:26 - 68:27 (line 68, column 26 - line 68, column 27) - - - in data constructor Test3 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 15 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:68:28 - 68:29 (line 68, column 28 - line 68, column 29) - - - in data constructor Test3 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 16 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:69:31 - 69:32 (line 69, column 31 - line 69, column 32) - - - in data constructor Test3 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 17 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:69:33 - 69:34 (line 69, column 33 - line 69, column 34) - - - in data constructor Test3 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 18 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:70:26 - 70:27 (line 70, column 26 - line 70, column 27) - - - in data constructor Test3 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 19 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:70:28 - 70:29 (line 70, column 28 - line 70, column 29) - - - in data constructor Test3 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 20 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:71:31 - 71:32 (line 71, column 31 - line 71, column 32) - - - in data constructor Test3 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 21 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:77:28 - 77:29 (line 77, column 28 - line 77, column 29) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 22 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:77:30 - 77:31 (line 77, column 30 - line 77, column 31) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 23 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:77:32 - 77:33 (line 77, column 32 - line 77, column 33) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 24 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:78:35 - 78:36 (line 78, column 35 - line 78, column 36) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 25 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:78:37 - 78:38 (line 78, column 37 - line 78, column 38) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 26 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:79:30 - 79:31 (line 79, column 30 - line 79, column 31) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 27 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:79:32 - 79:33 (line 79, column 32 - line 79, column 33) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 28 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:80:35 - 80:36 (line 80, column 35 - line 80, column 36) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 29 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:85:30 - 85:31 (line 85, column 30 - line 85, column 31) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 30 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:85:32 - 85:33 (line 85, column 32 - line 85, column 33) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 31 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:85:34 - 85:35 (line 85, column 34 - line 85, column 35) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 32 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:86:37 - 86:38 (line 86, column 37 - line 86, column 38) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 33 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:86:39 - 86:40 (line 86, column 39 - line 86, column 40) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 34 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:87:32 - 87:33 (line 87, column 32 - line 87, column 33) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 35 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:87:34 - 87:35 (line 87, column 34 - line 87, column 35) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 36 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:88:37 - 88:38 (line 88, column 37 - line 88, column 38) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 37 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:91:19 - 91:20 (line 91, column 19 - line 91, column 20) - - - in data constructor Test4 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 38 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:94:18 - 94:19 (line 94, column 18 - line 94, column 19) - - - under the label `all` - in data constructor Test5 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 39 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:94:18 - 94:19 (line 94, column 18 - line 94, column 19) - - - under the label `lefts` - in data constructor Test5 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 40 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:94:18 - 94:19 (line 94, column 18 - line 94, column 19) - - - under the label `middle` - in data constructor Test5 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 41 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:94:18 - 94:19 (line 94, column 18 - line 94, column 19) - - - under the label `rights` - in data constructor Test5 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 42 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:95:21 - 95:22 (line 95, column 21 - line 95, column 22) - - - in data constructor Test6 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 43 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:96:33 - 96:34 (line 96, column 33 - line 96, column 34) - - - in data constructor Test7 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 44 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:96:56 - 96:57 (line 96, column 56 - line 96, column 57) - - - in data constructor Test7 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. - -Error 45 of 45: - - in module FoldableInstance9 - at tests/purs/failing/FoldableInstance9.purs:97:1 - 97:38 (line 97, column 1 - line 97, column 38) - - The type variable `a` must only be used as the last argument in a data type: - - tests/purs/failing/FoldableInstance9.purs:96:59 - 96:60 (line 96, column 59 - line 96, column 60) - - - in data constructor Test7 - in type class instance -   -  Data.Foldable.Foldable (Test f0 g1 h2) -   - - where f0 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - g1 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - h2 is a rigid type variable - bound at (line 0, column 0 - line 0, column 0) - - See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, - or to contribute content related to this error. +Error found: +in module FoldableInstance9 +at tests/purs/failing/FoldableInstance9.purs:53:1 - 53:38 (line 53, column 1 - line 53, column 38) + + One or more type variables are in positions that prevent Foldable from being derived. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. + + tests/purs/failing/FoldableInstance9.purs: +  15 data Test f g h a +  16  = Test1 (f a a a) (f Int a a) (f a a Int) (f Int a Int) (f Int Int Int) +  17  | Test2 { all :: f a a a +  18  , rights :: f Int a a +  19  , lefts :: f a a Int +  20  , middle :: f Int a Int +  21  , none :: f Int Int Int +  22  } +  23  | Test3 (g +  24  { all :: f a a a +  25  , rights :: f Int a a +  26  , lefts :: f a a Int +  27  , middle :: f Int a Int +  28  , none :: f Int Int Int +  ... +  32  { nested1 :: +  33  { all :: f a a a +  34  , rights :: f Int a a +  35  , lefts :: f a a Int +  36  , middle :: f Int a Int +  37  , none :: f Int Int Int +  ... +  40  g +  41  { all :: f a a a +  42  , rights :: f Int a a +  43  , lefts :: f a a Int +  44  , middle :: f Int a Int +  45  , none :: f Int Int Int +  46  } +  47  a +  48  } +  49  a) +  50  | Test5 (Rec f a) +  51  | Test6 (g (Rec f a) a) +  52  | Test7 (h { nested1 :: Rec f a, nested2 :: g (Rec f a) a } a) +  53 derive instance Foldable (Test f g h) + + +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, +or to contribute content related to this error. diff --git a/tests/purs/failing/FoldableInstance9.purs b/tests/purs/failing/FoldableInstance9.purs index e9c90891c5..164c6858b3 100644 --- a/tests/purs/failing/FoldableInstance9.purs +++ b/tests/purs/failing/FoldableInstance9.purs @@ -1,48 +1,4 @@ -- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg --- @shouldFailWith CannotDeriveInvalidConstructorArg module FoldableInstance9 where import Prelude From 02bd6ae60bcd18cbfa892f268ef6359d84ed7c9b Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Fri, 7 Oct 2022 20:09:05 +0800 Subject: [PATCH 1508/1580] Remove base-compat as a dependency (#4384) --- CHANGELOG.d/internal_remove_base_compat.md | 1 + app/Command/REPL.hs | 3 +-- purescript.cabal | 1 - src/Control/Monad/Logger.hs | 2 +- src/Control/Monad/Supply.hs | 2 +- src/Control/Monad/Supply/Class.hs | 2 +- src/Language/PureScript/AST/Binders.hs | 2 +- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/AST/Exported.hs | 2 +- src/Language/PureScript/AST/Literals.hs | 2 +- src/Language/PureScript/AST/Operators.hs | 2 +- src/Language/PureScript/AST/SourcePos.hs | 2 +- src/Language/PureScript/AST/Traversals.hs | 2 +- src/Language/PureScript/Bundle.hs | 2 +- src/Language/PureScript/CodeGen/JS.hs | 2 +- src/Language/PureScript/CodeGen/JS/Common.hs | 2 +- src/Language/PureScript/CodeGen/JS/Printer.hs | 2 +- src/Language/PureScript/Comments.hs | 2 +- src/Language/PureScript/CoreFn/Ann.hs | 2 +- src/Language/PureScript/CoreFn/Binders.hs | 2 +- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- src/Language/PureScript/CoreFn/Expr.hs | 2 +- src/Language/PureScript/CoreFn/FromJSON.hs | 2 +- src/Language/PureScript/CoreFn/Meta.hs | 2 +- src/Language/PureScript/CoreFn/Module.hs | 2 +- src/Language/PureScript/CoreFn/ToJSON.hs | 2 +- src/Language/PureScript/CoreFn/Traversals.hs | 2 +- src/Language/PureScript/CoreImp/AST.hs | 2 +- src/Language/PureScript/CoreImp/Optimizer.hs | 2 +- .../PureScript/CoreImp/Optimizer/Blocks.hs | 2 +- .../PureScript/CoreImp/Optimizer/Common.hs | 2 +- .../PureScript/CoreImp/Optimizer/Inliner.hs | 2 +- .../PureScript/CoreImp/Optimizer/MagicDo.hs | 2 +- .../PureScript/CoreImp/Optimizer/TCO.hs | 2 +- .../PureScript/CoreImp/Optimizer/Unused.hs | 2 +- src/Language/PureScript/Crash.hs | 19 +++---------------- src/Language/PureScript/Docs/AsMarkdown.hs | 2 +- .../PureScript/Docs/Convert/ReExports.hs | 2 +- src/Language/PureScript/Docs/Prim.hs | 2 +- src/Language/PureScript/Docs/Render.hs | 2 +- .../Docs/RenderedCode/RenderType.hs | 2 +- .../PureScript/Docs/RenderedCode/Types.hs | 2 +- src/Language/PureScript/Environment.hs | 2 +- src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/Errors/JSON.hs | 2 +- src/Language/PureScript/Externs.hs | 2 +- src/Language/PureScript/Graph.hs | 2 +- src/Language/PureScript/Hierarchy.hs | 2 +- src/Language/PureScript/Interactive.hs | 3 +-- .../PureScript/Interactive/Completion.hs | 2 +- .../PureScript/Interactive/Directive.hs | 2 +- src/Language/PureScript/Interactive/IO.hs | 2 +- .../PureScript/Interactive/Message.hs | 2 +- src/Language/PureScript/Interactive/Module.hs | 2 +- src/Language/PureScript/Interactive/Parser.hs | 2 +- .../PureScript/Interactive/Printer.hs | 2 +- src/Language/PureScript/Interactive/Types.hs | 2 +- src/Language/PureScript/Label.hs | 2 +- src/Language/PureScript/Linter.hs | 2 +- src/Language/PureScript/Linter/Exhaustive.hs | 2 +- src/Language/PureScript/Linter/Imports.hs | 2 +- src/Language/PureScript/Make.hs | 2 +- src/Language/PureScript/Names.hs | 2 +- src/Language/PureScript/Options.hs | 2 +- src/Language/PureScript/PSString.hs | 2 +- src/Language/PureScript/Pretty/Common.hs | 2 +- src/Language/PureScript/Pretty/Types.hs | 2 +- src/Language/PureScript/Pretty/Values.hs | 2 +- .../PureScript/Publish/BoxesHelpers.hs | 2 +- .../PureScript/Publish/ErrorsWarnings.hs | 2 +- src/Language/PureScript/Publish/Utils.hs | 2 +- src/Language/PureScript/Renamer.hs | 2 +- src/Language/PureScript/Roles.hs | 2 +- src/Language/PureScript/Sugar/AdoNotation.hs | 2 +- .../PureScript/Sugar/BindingGroups.hs | 2 +- .../PureScript/Sugar/CaseDeclarations.hs | 2 +- src/Language/PureScript/Sugar/DoNotation.hs | 2 +- src/Language/PureScript/Sugar/LetPattern.hs | 2 +- src/Language/PureScript/Sugar/Names.hs | 2 +- src/Language/PureScript/Sugar/Names/Common.hs | 2 +- src/Language/PureScript/Sugar/Names/Env.hs | 2 +- .../PureScript/Sugar/Names/Exports.hs | 2 +- .../PureScript/Sugar/Names/Imports.hs | 2 +- .../PureScript/Sugar/ObjectWildcards.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 2 +- .../PureScript/Sugar/Operators/Binders.hs | 2 +- .../PureScript/Sugar/Operators/Common.hs | 2 +- .../PureScript/Sugar/Operators/Expr.hs | 2 +- .../PureScript/Sugar/Operators/Types.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 2 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 2 +- .../PureScript/Sugar/TypeDeclarations.hs | 2 +- src/Language/PureScript/Traversals.hs | 2 +- src/Language/PureScript/TypeChecker.hs | 2 +- .../PureScript/TypeChecker/Entailment.hs | 2 +- .../TypeChecker/Entailment/Coercible.hs | 2 +- src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- src/Language/PureScript/TypeChecker/Monad.hs | 2 +- src/Language/PureScript/TypeChecker/Roles.hs | 2 +- .../PureScript/TypeChecker/Skolems.hs | 2 +- .../PureScript/TypeChecker/Subsumption.hs | 2 +- .../PureScript/TypeChecker/Synonyms.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 2 +- src/Language/PureScript/TypeChecker/Unify.hs | 2 +- .../PureScript/TypeClassDictionaries.hs | 2 +- src/Language/PureScript/Types.hs | 2 +- src/System/IO/UTF8.hs | 2 +- tests/Main.hs | 3 +-- tests/TestCompiler.hs | 3 +-- tests/TestCoreFn.hs | 3 +-- tests/TestDocs.hs | 3 +-- tests/TestGraph.hs | 3 +-- tests/TestMake.hs | 3 +-- tests/TestPsci.hs | 1 - tests/TestPsci/CommandTest.hs | 3 +-- tests/TestPsci/CompletionTest.hs | 3 +-- tests/TestPsci/EvalTest.hs | 3 +-- tests/TestPsci/TestEnv.hs | 3 +-- tests/TestUtils.hs | 3 +-- 119 files changed, 119 insertions(+), 146 deletions(-) create mode 100644 CHANGELOG.d/internal_remove_base_compat.md diff --git a/CHANGELOG.d/internal_remove_base_compat.md b/CHANGELOG.d/internal_remove_base_compat.md new file mode 100644 index 0000000000..6d1296bd58 --- /dev/null +++ b/CHANGELOG.d/internal_remove_base_compat.md @@ -0,0 +1 @@ +* Remove base-compat as a dependency diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index ee1e49f245..dede7db03e 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -3,8 +3,7 @@ module Command.REPL (command) where -import Prelude () -import Prelude.Compat +import Prelude import Control.Applicative (many, (<|>)) import Control.Monad import Control.Monad.Catch (MonadMask) diff --git a/purescript.cabal b/purescript.cabal index b3e1fd43eb..43a2fa17ba 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -131,7 +131,6 @@ common defaults ansi-terminal >=0.11.3 && <0.12, array >=0.5.4.0 && <0.6, base >=4.16.2.0 && <4.17, - base-compat >=0.12.1 && <0.13, blaze-html >=0.9.1.2 && <0.10, bower-json >=1.1.0.0 && <1.2, boxes >=0.1.5 && <0.2, diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs index c5c051dfe3..23469082a3 100644 --- a/src/Control/Monad/Logger.hs +++ b/src/Control/Monad/Logger.hs @@ -3,7 +3,7 @@ -- module Control.Monad.Logger where -import Prelude.Compat +import Prelude import Control.Monad (ap) import Control.Monad.Base (MonadBase(..)) diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs index 1ddb3e8a92..1941fcf9b8 100644 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -3,7 +3,7 @@ -- module Control.Monad.Supply where -import Prelude.Compat +import Prelude import Control.Applicative import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index 4642efcc19..ff80893b31 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -4,7 +4,7 @@ module Control.Monad.Supply.Class where -import Prelude.Compat +import Prelude import Control.Monad.RWS import Control.Monad.State diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index a4b9c8a79b..748bb64bfb 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -3,7 +3,7 @@ -- module Language.PureScript.AST.Binders where -import Prelude.Compat +import Prelude import Language.PureScript.AST.SourcePos import Language.PureScript.AST.Literals diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index a4ae107ce5..5d97ed8b83 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -6,7 +6,7 @@ -- module Language.PureScript.AST.Declarations where -import Prelude.Compat +import Prelude import Protolude.Exceptions (hush) import Codec.Serialise (Serialise) diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index c284cde1bf..287060a5d5 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -3,7 +3,7 @@ module Language.PureScript.AST.Exported , isExported ) where -import Prelude.Compat +import Prelude import Protolude (sortOn) import Control.Category ((>>>)) diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs index a161fd82ab..cfa2e880e8 100644 --- a/src/Language/PureScript/AST/Literals.hs +++ b/src/Language/PureScript/AST/Literals.hs @@ -3,7 +3,7 @@ -- module Language.PureScript.AST.Literals where -import Prelude.Compat +import Prelude import Language.PureScript.PSString (PSString) -- | diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs index aa7ad57304..347729e1ce 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -3,7 +3,7 @@ -- module Language.PureScript.AST.Operators where -import Prelude.Compat +import Prelude import Codec.Serialise (Serialise) import GHC.Generics (Generic) diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 5fcb784325..e266680175 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -4,7 +4,7 @@ -- module Language.PureScript.AST.SourcePos where -import Prelude.Compat +import Prelude import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index a8df39c648..c5c181b917 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -3,7 +3,7 @@ -- module Language.PureScript.AST.Traversals where -import Prelude.Compat +import Prelude import Protolude (swap) import Control.Monad diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 26b319f40f..dbfaa610e3 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -16,7 +16,7 @@ module Language.PureScript.Bundle , Module ) where -import Prelude.Compat +import Prelude import Control.Monad.Error.Class diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 7894ae9194..b1f87ad4cc 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -6,7 +6,7 @@ module Language.PureScript.CodeGen.JS , moduleToJs ) where -import Prelude.Compat +import Prelude import Protolude (ordNub) import Control.Applicative (liftA2) diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index cdb34d3e36..9d82a19776 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -1,7 +1,7 @@ -- | Common code generation utility functions module Language.PureScript.CodeGen.JS.Common where -import Prelude.Compat +import Prelude import Data.Char import Data.Text (Text) diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index 5cba6c7b3b..901bf4c178 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -4,7 +4,7 @@ module Language.PureScript.CodeGen.JS.Printer , prettyPrintJSWithSourceMaps ) where -import Prelude.Compat +import Prelude import Control.Arrow ((<+>)) import Control.Monad (forM, mzero) diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs index 468e794d34..b53b06774a 100644 --- a/src/Language/PureScript/Comments.hs +++ b/src/Language/PureScript/Comments.hs @@ -5,7 +5,7 @@ -- module Language.PureScript.Comments where -import Prelude.Compat +import Prelude import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Data.Text (Text) diff --git a/src/Language/PureScript/CoreFn/Ann.hs b/src/Language/PureScript/CoreFn/Ann.hs index cb536cc2f7..f6e70bd6e4 100644 --- a/src/Language/PureScript/CoreFn/Ann.hs +++ b/src/Language/PureScript/CoreFn/Ann.hs @@ -1,6 +1,6 @@ module Language.PureScript.CoreFn.Ann where -import Prelude.Compat +import Prelude import Language.PureScript.AST.SourcePos import Language.PureScript.Comments diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index c43763f80f..997fff50a9 100644 --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -3,7 +3,7 @@ -- module Language.PureScript.CoreFn.Binders where -import Prelude.Compat +import Prelude import Language.PureScript.AST.Literals import Language.PureScript.Names diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index e881d0545f..1326504e72 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -1,6 +1,6 @@ module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where -import Prelude.Compat +import Prelude import Protolude (ordNub, orEmpty) import Control.Arrow (second) diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index ab56446701..b2bb3441e7 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -3,7 +3,7 @@ -- module Language.PureScript.CoreFn.Expr where -import Prelude.Compat +import Prelude import Control.Arrow ((***)) diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 10e6fca0e0..3d42bb727a 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -7,7 +7,7 @@ module Language.PureScript.CoreFn.FromJSON , parseVersion' ) where -import Prelude.Compat +import Prelude import Control.Applicative ((<|>)) diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs index 028f641b95..cc70425e03 100644 --- a/src/Language/PureScript/CoreFn/Meta.hs +++ b/src/Language/PureScript/CoreFn/Meta.hs @@ -3,7 +3,7 @@ -- module Language.PureScript.CoreFn.Meta where -import Prelude.Compat +import Prelude import Language.PureScript.Names diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index 3466245e81..ee6feff8d3 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -1,6 +1,6 @@ module Language.PureScript.CoreFn.Module where -import Prelude.Compat +import Prelude import Data.Map.Strict (Map) diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 62d1bf0b37..9a8a600f83 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -7,7 +7,7 @@ module Language.PureScript.CoreFn.ToJSON ( moduleToJSON ) where -import Prelude.Compat +import Prelude import Control.Arrow ((***)) import Data.Either (isLeft) diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs index e69ccb87d3..c223e37adc 100644 --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -3,7 +3,7 @@ -- module Language.PureScript.CoreFn.Traversals where -import Prelude.Compat +import Prelude import Control.Arrow (second, (***), (+++)) import Data.Bitraversable (bitraverse) diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs index d7a8a8f441..5812bfd284 100644 --- a/src/Language/PureScript/CoreImp/AST.hs +++ b/src/Language/PureScript/CoreImp/AST.hs @@ -1,7 +1,7 @@ -- | Data types for the imperative core AST module Language.PureScript.CoreImp.AST where -import Prelude.Compat +import Prelude import Control.Monad ((>=>)) import Control.Monad.Identity (Identity(..), runIdentity) diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs index c4af2658bd..4892df9b20 100644 --- a/src/Language/PureScript/CoreImp/Optimizer.hs +++ b/src/Language/PureScript/CoreImp/Optimizer.hs @@ -19,7 +19,7 @@ -- * Inlining primitive JavaScript operators module Language.PureScript.CoreImp.Optimizer (optimize) where -import Prelude.Compat +import Prelude import Data.Text (Text) diff --git a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs index 04febf2039..c4e8c40af9 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs @@ -4,7 +4,7 @@ module Language.PureScript.CoreImp.Optimizer.Blocks , collapseNestedIfs ) where -import Prelude.Compat +import Prelude import Language.PureScript.CoreImp.AST diff --git a/src/Language/PureScript/CoreImp/Optimizer/Common.hs b/src/Language/PureScript/CoreImp/Optimizer/Common.hs index 32879e6249..6c4834c36b 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Common.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Common.hs @@ -1,7 +1,7 @@ -- | Common functions used by the various optimizer phases module Language.PureScript.CoreImp.Optimizer.Common where -import Prelude.Compat +import Prelude import Data.Text (Text) import Data.List (foldl') diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index 51747467ed..da9f29383a 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -12,7 +12,7 @@ module Language.PureScript.CoreImp.Optimizer.Inliner , evaluateIifes ) where -import Prelude.Compat +import Prelude import Control.Monad.Supply.Class (MonadSupply, freshName) diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs index cdcf0138b0..449c2be79c 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs @@ -2,7 +2,7 @@ -- and bind for the Eff monad, as well as some of its actions. module Language.PureScript.CoreImp.Optimizer.MagicDo (magicDoEffect, magicDoEff, magicDoST, inlineST) where -import Prelude.Compat +import Prelude import Protolude (ordNub) import Data.Maybe (fromJust, isJust) diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index c109afd333..f9bb433514 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -1,7 +1,7 @@ -- | This module implements tail call elimination. module Language.PureScript.CoreImp.Optimizer.TCO (tco) where -import Prelude.Compat +import Prelude import Control.Applicative (empty, liftA2) import Control.Monad (guard) diff --git a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs index 13c4c9f374..cd11de4eca 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs @@ -5,7 +5,7 @@ module Language.PureScript.CoreImp.Optimizer.Unused , removeUnusedEffectFreeVars ) where -import Prelude.Compat +import Prelude import Control.Monad (filterM) import Data.Monoid (Any(..)) diff --git a/src/Language/PureScript/Crash.hs b/src/Language/PureScript/Crash.hs index 858c7361a9..9b04126202 100644 --- a/src/Language/PureScript/Crash.hs +++ b/src/Language/PureScript/Crash.hs @@ -1,21 +1,8 @@ -{-# LANGUAGE CPP #-} +module Language.PureScript.Crash (HasCallStack, internalError) where -module Language.PureScript.Crash where +import Prelude -import Prelude.Compat - -import qualified GHC.Stack - --- | A compatibility wrapper for the @GHC.Stack.HasCallStack@ constraint. -#if __GLASGOW_HASKELL__ >= 800 -type HasCallStack = GHC.Stack.HasCallStack -#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) -type HasCallStack = (?callStack :: GHC.Stack.CallStack) -#else -import GHC.Exts (Constraint) --- CallStack wasn't present in GHC 7.10.1 -type HasCallStack = (() :: Constraint) -#endif +import GHC.Stack (HasCallStack) -- | Exit with an error message and a crash report link. internalError :: HasCallStack => String -> a diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 38748ec263..efe15b0252 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -5,7 +5,7 @@ module Language.PureScript.Docs.AsMarkdown , codeToString ) where -import Prelude.Compat +import Prelude import Control.Monad (unless, zipWithM_) import Control.Monad.Writer (Writer, tell, execWriter) diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index c2594749fd..6400eced8b 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -2,7 +2,7 @@ module Language.PureScript.Docs.Convert.ReExports ( updateReExports ) where -import Prelude.Compat +import Prelude import Control.Arrow ((&&&), first, second) import Control.Monad diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 7a57db813b..a8021c9ddc 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -6,7 +6,7 @@ module Language.PureScript.Docs.Prim , primModules ) where -import Prelude.Compat hiding (fail) +import Prelude hiding (fail) import Data.Functor (($>)) import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 1212f0497d..0dc548f763 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -9,7 +9,7 @@ module Language.PureScript.Docs.Render where -import Prelude.Compat +import Prelude import Data.Maybe (maybeToList) import Data.Text (Text) diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index deae4be7bc..7234778bc0 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -12,7 +12,7 @@ module Language.PureScript.Docs.RenderedCode.RenderType , renderRow ) where -import Prelude.Compat +import Prelude import Data.Maybe (fromMaybe) import Data.Text (Text, pack) diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 459260174c..f4844dc754 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -32,7 +32,7 @@ module Language.PureScript.Docs.RenderedCode.Types , aliasName ) where -import Prelude.Compat +import Prelude import GHC.Generics (Generic) import Control.DeepSeq (NFData) diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 45d3428969..fc32591eb7 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -1,6 +1,6 @@ module Language.PureScript.Environment where -import Prelude.Compat +import Prelude import GHC.Generics (Generic) import Control.DeepSeq (NFData) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 87e4dbcd1f..eecbfc3ce3 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -3,7 +3,7 @@ module Language.PureScript.Errors , module Language.PureScript.Errors ) where -import Prelude.Compat +import Prelude import Control.Arrow ((&&&)) import Control.Exception (displayException) diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index 09e565b7a9..924e452309 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -2,7 +2,7 @@ module Language.PureScript.Errors.JSON where -import Prelude.Compat +import Prelude import qualified Data.Aeson.TH as A import qualified Data.List.NonEmpty as NEL diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 394f0640cc..477c2e68f4 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -14,7 +14,7 @@ module Language.PureScript.Externs , externsFileName ) where -import Prelude.Compat +import Prelude import Codec.Serialise (Serialise) import Control.Monad (join) diff --git a/src/Language/PureScript/Graph.hs b/src/Language/PureScript/Graph.hs index c8b079f3ce..9c2c6e09d2 100644 --- a/src/Language/PureScript/Graph.hs +++ b/src/Language/PureScript/Graph.hs @@ -1,6 +1,6 @@ module Language.PureScript.Graph (graph) where -import Prelude.Compat +import Prelude import qualified Data.Aeson as Json import qualified Data.Aeson.Key as Json.Key diff --git a/src/Language/PureScript/Hierarchy.hs b/src/Language/PureScript/Hierarchy.hs index dea22eda6d..fb9a25f018 100644 --- a/src/Language/PureScript/Hierarchy.hs +++ b/src/Language/PureScript/Hierarchy.hs @@ -15,7 +15,7 @@ module Language.PureScript.Hierarchy where -import Prelude.Compat +import Prelude import Protolude (ordNub) import Data.List (sort) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index fdfe83af71..bae794517c 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -9,8 +9,7 @@ module Language.PureScript.Interactive , runMake ) where -import Prelude () -import Prelude.Compat +import Prelude import Protolude (ordNub) import Data.List (sort, find, foldl') diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index eccbcfcf2d..d79627801a 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -6,7 +6,7 @@ module Language.PureScript.Interactive.Completion , formatCompletions ) where -import Prelude.Compat +import Prelude import Protolude (ordNub) import Control.Monad.IO.Class (MonadIO(..)) diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs index 40daec6cb0..35c064001c 100644 --- a/src/Language/PureScript/Interactive/Directive.hs +++ b/src/Language/PureScript/Interactive/Directive.hs @@ -3,7 +3,7 @@ -- module Language.PureScript.Interactive.Directive where -import Prelude.Compat +import Prelude import Data.Maybe (fromJust) import Data.List (isPrefixOf) diff --git a/src/Language/PureScript/Interactive/IO.hs b/src/Language/PureScript/Interactive/IO.hs index 1b0ba2fc00..34c9a287a5 100644 --- a/src/Language/PureScript/Interactive/IO.hs +++ b/src/Language/PureScript/Interactive/IO.hs @@ -2,7 +2,7 @@ module Language.PureScript.Interactive.IO (findNodeProcess, readNodeProcessWithExitCode, getHistoryFilename) where -import Prelude.Compat +import Prelude import Control.Monad (msum, void) import Control.Monad.Error.Class (throwError) diff --git a/src/Language/PureScript/Interactive/Message.hs b/src/Language/PureScript/Interactive/Message.hs index 24a5b3737a..17488149b8 100644 --- a/src/Language/PureScript/Interactive/Message.hs +++ b/src/Language/PureScript/Interactive/Message.hs @@ -1,6 +1,6 @@ module Language.PureScript.Interactive.Message where -import Prelude.Compat +import Prelude import Data.List (intercalate) import Data.Version (showVersion) diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index d0d74bae7c..9c90a890af 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -1,6 +1,6 @@ module Language.PureScript.Interactive.Module where -import Prelude.Compat +import Prelude import qualified Language.PureScript as P import qualified Language.PureScript.CST as CST diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index efa510a5c5..4f55bfb566 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -6,7 +6,7 @@ module Language.PureScript.Interactive.Parser , parseCommand ) where -import Prelude.Compat hiding (lex) +import Prelude import Control.Monad (join) import Data.Bifunctor (bimap) diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index 64f6e1df67..e1775a6997 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -1,6 +1,6 @@ module Language.PureScript.Interactive.Printer where -import Prelude.Compat +import Prelude import Data.List (intersperse) import qualified Data.Map as M diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index cadd7f62ad..c6257fed3a 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -28,7 +28,7 @@ module Language.PureScript.Interactive.Types , Directive(..) ) where -import Prelude.Compat +import Prelude import qualified Language.PureScript as P import qualified Data.Map as M diff --git a/src/Language/PureScript/Label.hs b/src/Language/PureScript/Label.hs index e2e0dc8093..f3d257b0fa 100644 --- a/src/Language/PureScript/Label.hs +++ b/src/Language/PureScript/Label.hs @@ -1,6 +1,6 @@ module Language.PureScript.Label (Label(..)) where -import Prelude.Compat hiding (lex) +import Prelude import GHC.Generics (Generic) import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 90c2928d92..54571a6272 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -3,7 +3,7 @@ -- module Language.PureScript.Linter (lint, module L) where -import Prelude.Compat +import Prelude import Control.Monad.Writer.Class diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index a55e766f87..145cffce95 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -8,7 +8,7 @@ module Language.PureScript.Linter.Exhaustive ( checkExhaustiveExpr ) where -import Prelude.Compat +import Prelude import Protolude (ordNub) import Control.Applicative diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 737ce2c3ff..e79f942227 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -4,7 +4,7 @@ module Language.PureScript.Linter.Imports , UsedImports() ) where -import Prelude.Compat +import Prelude import Protolude (ordNub) import Control.Monad (join, unless, foldM, (<=<)) diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 3b5d7912ae..d9e7157f16 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -9,7 +9,7 @@ module Language.PureScript.Make , module Actions ) where -import Prelude.Compat +import Prelude import Control.Concurrent.Lifted as C import Control.Exception.Base (onException) diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 0564aa23da..03fd10a8b3 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -5,7 +5,7 @@ -- module Language.PureScript.Names where -import Prelude.Compat +import Prelude import Codec.Serialise (Serialise) import Control.Applicative ((<|>)) diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index 323cdcc504..b0e44bc16d 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -1,7 +1,7 @@ -- | The data type of compiler options module Language.PureScript.Options where -import Prelude.Compat +import Prelude import qualified Data.Set as S import Data.Map (Map) import qualified Data.Map as Map diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index 96379e9890..44a617e73a 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -9,7 +9,7 @@ module Language.PureScript.PSString , mkString ) where -import Prelude.Compat +import Prelude import GHC.Generics (Generic) import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 6a40bd6b39..2f841c534b 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -3,7 +3,7 @@ -- module Language.PureScript.Pretty.Common where -import Prelude.Compat +import Prelude import Control.Monad.State (StateT, modify, get) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 8988b4226e..d7c90374c3 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -19,7 +19,7 @@ module Language.PureScript.Pretty.Types , prettyPrintObjectKey ) where -import Prelude.Compat hiding ((<>)) +import Prelude hiding ((<>)) import Control.Arrow ((<+>)) import Control.PatternArrows as PA diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 31002baf22..24638f6932 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -7,7 +7,7 @@ module Language.PureScript.Pretty.Values , prettyPrintBinderAtom ) where -import Prelude.Compat hiding ((<>)) +import Prelude hiding ((<>)) import Control.Arrow (second) diff --git a/src/Language/PureScript/Publish/BoxesHelpers.hs b/src/Language/PureScript/Publish/BoxesHelpers.hs index 536e5bf8a7..b37e794ab6 100644 --- a/src/Language/PureScript/Publish/BoxesHelpers.hs +++ b/src/Language/PureScript/Publish/BoxesHelpers.hs @@ -4,7 +4,7 @@ module Language.PureScript.Publish.BoxesHelpers , module Language.PureScript.Publish.BoxesHelpers ) where -import Prelude.Compat +import Prelude import Data.Text (Text) import qualified Data.Text as T diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 84087f55c0..b4f48949e1 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -12,7 +12,7 @@ module Language.PureScript.Publish.ErrorsWarnings , renderWarnings ) where -import Prelude.Compat +import Prelude import Control.Exception (IOException) diff --git a/src/Language/PureScript/Publish/Utils.hs b/src/Language/PureScript/Publish/Utils.hs index 46c736d5e8..881af28904 100644 --- a/src/Language/PureScript/Publish/Utils.hs +++ b/src/Language/PureScript/Publish/Utils.hs @@ -1,6 +1,6 @@ module Language.PureScript.Publish.Utils where -import Prelude.Compat +import Prelude import System.Directory import System.FilePath.Glob (Pattern, compile, globDir1) diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index cb09c0910f..a822b2081c 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -3,7 +3,7 @@ -- module Language.PureScript.Renamer (renameInModule) where -import Prelude.Compat +import Prelude import Control.Monad.State diff --git a/src/Language/PureScript/Roles.hs b/src/Language/PureScript/Roles.hs index e680ceecd4..498a899d48 100644 --- a/src/Language/PureScript/Roles.hs +++ b/src/Language/PureScript/Roles.hs @@ -8,7 +8,7 @@ module Language.PureScript.Roles , displayRole ) where -import Prelude.Compat +import Prelude import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs index dd851f20a2..8dfdf59301 100644 --- a/src/Language/PureScript/Sugar/AdoNotation.hs +++ b/src/Language/PureScript/Sugar/AdoNotation.hs @@ -3,7 +3,7 @@ module Language.PureScript.Sugar.AdoNotation (desugarAdoModule) where -import Prelude.Compat hiding (abs) +import Prelude hiding (abs) import Control.Monad (foldM) import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 6900b30325..ab78f79d8c 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -8,7 +8,7 @@ module Language.PureScript.Sugar.BindingGroups , collapseBindingGroups ) where -import Prelude.Compat +import Prelude import Protolude (ordNub) import Control.Monad ((<=<), guard) diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index b4767006c4..925bf3d484 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -8,7 +8,7 @@ module Language.PureScript.Sugar.CaseDeclarations , desugarCaseGuards ) where -import Prelude.Compat +import Prelude import Protolude (ordNub) import Data.List (groupBy, foldl1') diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 902eaa3682..0f7c3457b5 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -3,7 +3,7 @@ module Language.PureScript.Sugar.DoNotation (desugarDoModule) where -import Prelude.Compat +import Prelude import Control.Applicative ((<|>)) import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Sugar/LetPattern.hs b/src/Language/PureScript/Sugar/LetPattern.hs index 6db0936783..b9b23575a8 100644 --- a/src/Language/PureScript/Sugar/LetPattern.hs +++ b/src/Language/PureScript/Sugar/LetPattern.hs @@ -4,7 +4,7 @@ -- module Language.PureScript.Sugar.LetPattern (desugarLetPatternModule) where -import Prelude.Compat +import Prelude import Data.List (groupBy) import Data.Function (on) diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 0e1eed109e..03968af376 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -9,7 +9,7 @@ module Language.PureScript.Sugar.Names , Exports(..) ) where -import Prelude.Compat +import Prelude import Protolude (ordNub, sortOn, swap, foldl') import Control.Arrow (first, second) diff --git a/src/Language/PureScript/Sugar/Names/Common.hs b/src/Language/PureScript/Sugar/Names/Common.hs index 0be439c5fc..4382342eea 100644 --- a/src/Language/PureScript/Sugar/Names/Common.hs +++ b/src/Language/PureScript/Sugar/Names/Common.hs @@ -1,6 +1,6 @@ module Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) where -import Prelude.Compat +import Prelude import Protolude (ordNub) import Control.Monad.Writer (MonadWriter(..)) diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 7e2240a040..31543eba9a 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -18,7 +18,7 @@ module Language.PureScript.Sugar.Names.Env , checkImportConflicts ) where -import Prelude.Compat +import Prelude import Control.Monad import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 1ab7194309..c87e17d3eb 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -3,7 +3,7 @@ module Language.PureScript.Sugar.Names.Exports , resolveExports ) where -import Prelude.Compat +import Prelude import Control.Monad import Control.Monad.Writer.Class (MonadWriter(..)) diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 2d1af437f3..846b03e19b 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -5,7 +5,7 @@ module Language.PureScript.Sugar.Names.Imports , findImports ) where -import Prelude.Compat +import Prelude import Control.Monad import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 34d2c6d287..51bbb48016 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -3,7 +3,7 @@ module Language.PureScript.Sugar.ObjectWildcards , desugarDecl ) where -import Prelude.Compat +import Prelude import Control.Monad (forM) import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 9542d4b669..ca3c282d3a 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -13,7 +13,7 @@ module Language.PureScript.Sugar.Operators , checkFixityExports ) where -import Prelude.Compat +import Prelude import Language.PureScript.AST import Language.PureScript.Crash diff --git a/src/Language/PureScript/Sugar/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs index c3f54e7384..2b36230d8a 100644 --- a/src/Language/PureScript/Sugar/Operators/Binders.hs +++ b/src/Language/PureScript/Sugar/Operators/Binders.hs @@ -1,6 +1,6 @@ module Language.PureScript.Sugar.Operators.Binders where -import Prelude.Compat +import Prelude import Control.Monad.Except diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index cdc9cbafe6..0d7fdaaa8f 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -1,6 +1,6 @@ module Language.PureScript.Sugar.Operators.Common where -import Prelude.Compat +import Prelude import Control.Monad.State import Control.Monad.Except diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index 4fb12acbc1..a53390b99e 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -1,6 +1,6 @@ module Language.PureScript.Sugar.Operators.Expr where -import Prelude.Compat +import Prelude import Control.Monad.Except import Data.Functor.Identity diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs index ce274b2f33..2f9d242acb 100644 --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -1,6 +1,6 @@ module Language.PureScript.Sugar.Operators.Types where -import Prelude.Compat +import Prelude import Control.Monad.Except import Language.PureScript.AST diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 62168d39f1..cd1dd4caae 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -8,7 +8,7 @@ module Language.PureScript.Sugar.TypeClasses , superClassDictionaryNames ) where -import Prelude.Compat +import Prelude import Control.Arrow (first, second) import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index ebec719d75..70db418116 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -1,7 +1,7 @@ -- | This module implements the generic deriving elaboration that takes place during desugaring. module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where -import Prelude.Compat +import Prelude import Protolude (note) import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index acd3eed142..25e3f63910 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -6,7 +6,7 @@ module Language.PureScript.Sugar.TypeDeclarations ( desugarTypeDeclarationsModule ) where -import Prelude.Compat +import Prelude import Control.Monad (unless) import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Traversals.hs b/src/Language/PureScript/Traversals.hs index bdb70c5d83..1226342c71 100644 --- a/src/Language/PureScript/Traversals.hs +++ b/src/Language/PureScript/Traversals.hs @@ -1,7 +1,7 @@ -- | Common functions for implementing generic traversals module Language.PureScript.Traversals where -import Prelude.Compat +import Prelude sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c) sndM f (a, b) = (a, ) <$> f b diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 9caba12fc3..ba8cfd3543 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -7,7 +7,7 @@ module Language.PureScript.TypeChecker , checkNewtype ) where -import Prelude.Compat +import Prelude import Protolude (headMay, maybeToLeft, ordNub) import Control.Lens ((^..), _2) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index f0c55e3b79..b7d774d4ef 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -9,7 +9,7 @@ module Language.PureScript.TypeChecker.Entailment , entails ) where -import Prelude.Compat +import Prelude import Protolude (ordNub) import Control.Arrow (second, (&&&)) diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 6f68bb5570..ab6a2338a2 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -13,7 +13,7 @@ module Language.PureScript.TypeChecker.Entailment.Coercible , insoluble ) where -import Prelude.Compat hiding (interact) +import Prelude hiding (interact) import Control.Applicative ((<|>), empty) import Control.Arrow ((&&&)) diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 11e5483172..4c9e8555a1 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -25,7 +25,7 @@ module Language.PureScript.TypeChecker.Kinds , freshKindWithKind ) where -import Prelude.Compat +import Prelude import Control.Arrow ((***)) import Control.Lens ((^.), _1, _2, _3) diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 2b591e5020..7db6cbeb5e 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -5,7 +5,7 @@ -- module Language.PureScript.TypeChecker.Monad where -import Prelude.Compat +import Prelude import Control.Arrow (second) import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index a34cc0dbcb..effb5c265a 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -11,7 +11,7 @@ module Language.PureScript.TypeChecker.Roles , inferDataBindingGroupRoles ) where -import Prelude.Compat +import Prelude import Control.Arrow ((&&&)) import Control.Monad (unless, when, zipWithM_) diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 7a11949331..2f5567ccf7 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -8,7 +8,7 @@ module Language.PureScript.TypeChecker.Skolems , skolemEscapeCheck ) where -import Prelude.Compat +import Prelude import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets, modify) diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index f4e0da99c4..be6e9f292c 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -5,7 +5,7 @@ module Language.PureScript.TypeChecker.Subsumption ( subsumes ) where -import Prelude.Compat +import Prelude import Control.Monad (when) import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 7b76b21cb3..80e1407f31 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -10,7 +10,7 @@ module Language.PureScript.TypeChecker.Synonyms , replaceAllTypeSynonymsM ) where -import Prelude.Compat +import Prelude import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 59c73e66e8..9e9bc44443 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -23,7 +23,7 @@ module Language.PureScript.TypeChecker.Types Check a function of a given type returns a value of another type when applied to its arguments -} -import Prelude.Compat +import Prelude import Protolude (ordNub, fold, atMay) import Control.Arrow (first, second, (***)) diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index f976fce43b..38e181b365 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -14,7 +14,7 @@ module Language.PureScript.TypeChecker.Unify , varIfUnknown ) where -import Prelude.Compat +import Prelude import Control.Monad import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 3c8306ac43..dc3bfad14f 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -1,6 +1,6 @@ module Language.PureScript.TypeClassDictionaries where -import Prelude.Compat +import Prelude import GHC.Generics (Generic) import Control.DeepSeq (NFData) diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index d3b0c62300..c98f94459b 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -3,7 +3,7 @@ -- module Language.PureScript.Types where -import Prelude.Compat +import Prelude import Protolude (ordNub) import Codec.Serialise (Serialise) diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs index 3414503f12..d999b0969b 100644 --- a/src/System/IO/UTF8.hs +++ b/src/System/IO/UTF8.hs @@ -1,6 +1,6 @@ module System.IO.UTF8 where -import Prelude.Compat +import Prelude import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL diff --git a/tests/Main.hs b/tests/Main.hs index 3da8f99a35..4063bab544 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -2,8 +2,7 @@ module Main (main) where -import Prelude () -import Prelude.Compat +import Prelude import Test.Hspec diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 8dda567d4b..484bc8c3c3 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -22,8 +22,7 @@ module TestCompiler where -- missing, and can be updated by setting the "HSPEC_ACCEPT" environment -- variable, e.g. by running `HSPEC_ACCEPT=true stack test`. -import Prelude () -import Prelude.Compat +import Prelude import qualified Language.PureScript as P import Language.PureScript.Interactive.IO (readNodeProcessWithExitCode) diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index b865567102..263ba795b1 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -2,8 +2,7 @@ module TestCoreFn (spec) where -import Prelude () -import Prelude.Compat +import Prelude import Data.Aeson import Data.Aeson.Types as Aeson diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 046a2784da..cecd6c0e8f 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -1,7 +1,6 @@ module TestDocs where -import Prelude () -import Prelude.Compat +import Prelude import Data.Bifunctor (first) import Data.List (findIndex) diff --git a/tests/TestGraph.hs b/tests/TestGraph.hs index b82b8d2cda..8e7d6cb0f6 100644 --- a/tests/TestGraph.hs +++ b/tests/TestGraph.hs @@ -1,7 +1,6 @@ module TestGraph where -import Prelude () -import Prelude.Compat +import Prelude import Test.Hspec import Data.Either (isLeft) diff --git a/tests/TestMake.hs b/tests/TestMake.hs index 70ac4550ad..75f422e8ac 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -3,8 +3,7 @@ module TestMake where -import Prelude () -import Prelude.Compat +import Prelude import qualified Language.PureScript as P import qualified Language.PureScript.CST as CST diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index 9f7d9fa27c..0d9394f817 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -1,6 +1,5 @@ module TestPsci where -import Prelude () import TestPsci.CommandTest (commandTests) import TestPsci.CompletionTest (completionTests) diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs index cde4b3df91..9e148f779c 100644 --- a/tests/TestPsci/CommandTest.hs +++ b/tests/TestPsci/CommandTest.hs @@ -1,7 +1,6 @@ module TestPsci.CommandTest where -import Prelude () -import Prelude.Compat +import Prelude import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.RWS.Strict (get) diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index b8f1667af6..20bc64c843 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -1,7 +1,6 @@ module TestPsci.CompletionTest where -import Prelude () -import Prelude.Compat +import Prelude import Test.Hspec diff --git a/tests/TestPsci/EvalTest.hs b/tests/TestPsci/EvalTest.hs index 171a03fa1b..622208d9c5 100644 --- a/tests/TestPsci/EvalTest.hs +++ b/tests/TestPsci/EvalTest.hs @@ -1,7 +1,6 @@ module TestPsci.EvalTest where -import Prelude () -import Prelude.Compat +import Prelude import Control.Monad (forM_, foldM_) import Control.Monad.IO.Class (liftIO) diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index 8b8d5d7eb7..bf0ccf8a70 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -1,7 +1,6 @@ module TestPsci.TestEnv where -import Prelude () -import Prelude.Compat +import Prelude import Control.Exception.Lifted (bracket_) import Control.Monad (void, when) diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 11c99d16de..896c42866c 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -1,7 +1,6 @@ module TestUtils where -import Prelude () -import Prelude.Compat +import Prelude import qualified Language.PureScript as P import qualified Language.PureScript.CST as CST From c109b23ea7d859785903caa0ec07715ee1a5b9a0 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Mon, 10 Oct 2022 21:19:53 +0800 Subject: [PATCH 1509/1580] Prepare PureScript 0.15.5 Release (#4398) --- CHANGELOG.d/feature_derive-traversable.md | 4 - .../feature_increase-type-holes-amount.md | 1 - CHANGELOG.d/feature_optimize-uncurried-st.md | 1 - CHANGELOG.d/fix_4194.md | 3 - CHANGELOG.d/fix_4363.md | 1 - CHANGELOG.d/fix_4373.md | 15 -- CHANGELOG.d/fix_4382.md | 40 ----- CHANGELOG.d/internal_address-hlint-3-hints.md | 1 - ...nal_bump-npm-purescript-installer-0-3-1.md | 1 - .../internal_fix-free-type-variables.md | 1 - CHANGELOG.d/internal_overloaded-record-dot.md | 1 - ...nal_remove-purescript-cst-from-makefile.md | 1 - CHANGELOG.d/internal_remove_base_compat.md | 1 - CHANGELOG.d/misc_macos_11_runner.md | 1 - CHANGELOG.md | 96 ++++++++++++ INSTALL.md | 4 +- LICENSE | 140 ++++++++---------- npm-package/package.json | 4 +- purescript.cabal | 2 +- 19 files changed, 159 insertions(+), 159 deletions(-) delete mode 100644 CHANGELOG.d/feature_derive-traversable.md delete mode 100644 CHANGELOG.d/feature_increase-type-holes-amount.md delete mode 100644 CHANGELOG.d/feature_optimize-uncurried-st.md delete mode 100644 CHANGELOG.d/fix_4194.md delete mode 100644 CHANGELOG.d/fix_4363.md delete mode 100644 CHANGELOG.d/fix_4373.md delete mode 100644 CHANGELOG.d/fix_4382.md delete mode 100644 CHANGELOG.d/internal_address-hlint-3-hints.md delete mode 100644 CHANGELOG.d/internal_bump-npm-purescript-installer-0-3-1.md delete mode 100644 CHANGELOG.d/internal_fix-free-type-variables.md delete mode 100644 CHANGELOG.d/internal_overloaded-record-dot.md delete mode 100644 CHANGELOG.d/internal_remove-purescript-cst-from-makefile.md delete mode 100644 CHANGELOG.d/internal_remove_base_compat.md delete mode 100644 CHANGELOG.d/misc_macos_11_runner.md diff --git a/CHANGELOG.d/feature_derive-traversable.md b/CHANGELOG.d/feature_derive-traversable.md deleted file mode 100644 index c4e559fd62..0000000000 --- a/CHANGELOG.d/feature_derive-traversable.md +++ /dev/null @@ -1,4 +0,0 @@ -* Enable the compiler to derive `Foldable` and `Traversable` instances - - These instances follow the same rules as derived `Functor` instances. - For details, see [the PureScript language reference](https://github.com/purescript/documentation/blob/master/language/Type-Classes.md#functor-foldable-and-traversable). diff --git a/CHANGELOG.d/feature_increase-type-holes-amount.md b/CHANGELOG.d/feature_increase-type-holes-amount.md deleted file mode 100644 index a40ab70057..0000000000 --- a/CHANGELOG.d/feature_increase-type-holes-amount.md +++ /dev/null @@ -1 +0,0 @@ -* Increases the max number of typed holes displayed from 5 up to 30 \ No newline at end of file diff --git a/CHANGELOG.d/feature_optimize-uncurried-st.md b/CHANGELOG.d/feature_optimize-uncurried-st.md deleted file mode 100644 index 66311a0633..0000000000 --- a/CHANGELOG.d/feature_optimize-uncurried-st.md +++ /dev/null @@ -1 +0,0 @@ -* Add a compiler optimization for `ST` functions with up to 10 arity, similar to `Effect` optimizations. \ No newline at end of file diff --git a/CHANGELOG.d/fix_4194.md b/CHANGELOG.d/fix_4194.md deleted file mode 100644 index 5bfabe769b..0000000000 --- a/CHANGELOG.d/fix_4194.md +++ /dev/null @@ -1,3 +0,0 @@ -* Fix a bug where the compiler did not consider interactions of all functional dependencies in classes. - In particular, combinations of multiple parameters determining other parameter(s) were not handled properly, - affecting overlapping instance checks and the selection of which parameters are fully determined. diff --git a/CHANGELOG.d/fix_4363.md b/CHANGELOG.d/fix_4363.md deleted file mode 100644 index ed2b32d7cd..0000000000 --- a/CHANGELOG.d/fix_4363.md +++ /dev/null @@ -1 +0,0 @@ -* Qualify references to expressions floated to the top level of a module by the compiler diff --git a/CHANGELOG.d/fix_4373.md b/CHANGELOG.d/fix_4373.md deleted file mode 100644 index 421a0db67d..0000000000 --- a/CHANGELOG.d/fix_4373.md +++ /dev/null @@ -1,15 +0,0 @@ -* Fix replicated type hole suggestions due to malformed source spans - - In PureScript `0.15.4`, the following code will produce multiple entries in - the type hole suggestions. This is due to malformed source spans that are - generated when desugaring value declarations into case expressions. - - ```purs - module Main where - - data F = X | Y - - f :: forall a. F -> a -> a - f X b = ?help - f Y b = ?help - ``` diff --git a/CHANGELOG.d/fix_4382.md b/CHANGELOG.d/fix_4382.md deleted file mode 100644 index 8f4e9ed3d4..0000000000 --- a/CHANGELOG.d/fix_4382.md +++ /dev/null @@ -1,40 +0,0 @@ -* Improve error spans for class and instance declarations - - This improves the error spans for class and instance - declarations. Instead of highlighting the entire class or instance - declaration when `UnknownName` is thrown, the compiler now - highlights the class name and its arguments. - - Before: - ```purs - [1/2 UnknownName] - - 5 class G a <= F a - ^^^^^^^^^^^^^^^^ - - Unknown type class G - - [2/2 UnknownName] - - 7 instance G a => F a - ^^^^^^^^^^^^^^^^^^^ - - Unknown type class G - ``` - - After: - ```purs - [1/2 UnknownName] - - 5 class G a <= F a - ^^^ - - Unknown type class G - - [2/2 UnknownName] - - 7 instance G a => F a - ^^^ - - Unknown type class G - ``` diff --git a/CHANGELOG.d/internal_address-hlint-3-hints.md b/CHANGELOG.d/internal_address-hlint-3-hints.md deleted file mode 100644 index e8cdca7a29..0000000000 --- a/CHANGELOG.d/internal_address-hlint-3-hints.md +++ /dev/null @@ -1 +0,0 @@ -* Bump HLint to version 3.5 and address most of the new hints diff --git a/CHANGELOG.d/internal_bump-npm-purescript-installer-0-3-1.md b/CHANGELOG.d/internal_bump-npm-purescript-installer-0-3-1.md deleted file mode 100644 index 7d9d1b48e9..0000000000 --- a/CHANGELOG.d/internal_bump-npm-purescript-installer-0-3-1.md +++ /dev/null @@ -1 +0,0 @@ -* Bump depend NPM purescript-installer to ^0.3.1 \ No newline at end of file diff --git a/CHANGELOG.d/internal_fix-free-type-variables.md b/CHANGELOG.d/internal_fix-free-type-variables.md deleted file mode 100644 index 603e1759a8..0000000000 --- a/CHANGELOG.d/internal_fix-free-type-variables.md +++ /dev/null @@ -1 +0,0 @@ -* Ensure order of args remain unchanged in `freeTypeVariables` \ No newline at end of file diff --git a/CHANGELOG.d/internal_overloaded-record-dot.md b/CHANGELOG.d/internal_overloaded-record-dot.md deleted file mode 100644 index c85ec1c01d..0000000000 --- a/CHANGELOG.d/internal_overloaded-record-dot.md +++ /dev/null @@ -1 +0,0 @@ -* Enable `OverloadedRecordDot` extension throughout codebase \ No newline at end of file diff --git a/CHANGELOG.d/internal_remove-purescript-cst-from-makefile.md b/CHANGELOG.d/internal_remove-purescript-cst-from-makefile.md deleted file mode 100644 index cc7ef30758..0000000000 --- a/CHANGELOG.d/internal_remove-purescript-cst-from-makefile.md +++ /dev/null @@ -1 +0,0 @@ -* Remove `purescript-cst` from Makefile \ No newline at end of file diff --git a/CHANGELOG.d/internal_remove_base_compat.md b/CHANGELOG.d/internal_remove_base_compat.md deleted file mode 100644 index 6d1296bd58..0000000000 --- a/CHANGELOG.d/internal_remove_base_compat.md +++ /dev/null @@ -1 +0,0 @@ -* Remove base-compat as a dependency diff --git a/CHANGELOG.d/misc_macos_11_runner.md b/CHANGELOG.d/misc_macos_11_runner.md deleted file mode 100644 index 56cb417010..0000000000 --- a/CHANGELOG.d/misc_macos_11_runner.md +++ /dev/null @@ -1 +0,0 @@ -* Bump actions environment to `macOS-11` diff --git a/CHANGELOG.md b/CHANGELOG.md index d6f7f5bf9c..987299a1d6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,102 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.5 + +New features: + +* Increases the max number of typed holes displayed from 5 up to 30 (#4341 by @JordanMartinez) + +* Add a compiler optimization for `ST` functions with up to 10 arity, similar to `Effect` optimizations. (#4386 by @mikesol) + +* Enable the compiler to derive `Foldable` and `Traversable` instances (#4392 by @rhendric) + + These instances follow the same rules as derived `Functor` instances. + For details, see [the PureScript language reference](https://github.com/purescript/documentation/blob/master/language/Type-Classes.md#functor-foldable-and-traversable). + +Bugfixes: + +* Qualify references to expressions floated to the top level of a module by the compiler (#4364 by @rhendric) + +* Fix replicated type hole suggestions due to malformed source spans (#4374 by @PureFunctor) + + In PureScript `0.15.4`, the following code will produce multiple entries in + the type hole suggestions. This is due to malformed source spans that are + generated when desugaring value declarations into case expressions. + + ```purs + module Main where + + data F = X | Y + + f :: forall a. F -> a -> a + f X b = ?help + f Y b = ?help + ``` + +* Improve error spans for class and instance declarations (#4383 and #4391 by @PureFunctor and @rhendric) + + This improves the error spans for class and instance + declarations. Instead of highlighting the entire class or instance + declaration when `UnknownName` is thrown, the compiler now + highlights the class name and its arguments. + + Before: + ```purs + [1/2 UnknownName] + + 5 class G a <= F a + ^^^^^^^^^^^^^^^^ + + Unknown type class G + + [2/2 UnknownName] + + 7 instance G a => F a + ^^^^^^^^^^^^^^^^^^^ + + Unknown type class G + ``` + + After: + ```purs + [1/2 UnknownName] + + 5 class G a <= F a + ^^^ + + Unknown type class G + + [2/2 UnknownName] + + 7 instance G a => F a + ^^^ + + Unknown type class G + ``` + +* Fix a bug where the compiler did not consider interactions of all functional dependencies in classes. (#4195 by @MonoidMusician) + In particular, combinations of multiple parameters determining other parameter(s) were not handled properly, + affecting overlapping instance checks and the selection of which parameters are fully determined. + +Other improvements: + +* Bump actions environment to `macOS-11` (#4372 by @PureFunctor) + +Internal: + +* Enable `OverloadedRecordDot` extension throughout codebase (#4355 by @JordanMartinez) + +* Ensure order of args remain unchanged in `freeTypeVariables` (#4369 by @JordanMartinez) + +* Bump HLint to version 3.5 and address most of the new hints (#4391 by @rhendric) + +* Remove `purescript-cst` from Makefile (#4389 by @ptrfrncsmrph) + +* Bump depend NPM purescript-installer to ^0.3.1 (#4353 by @imcotton) + +* Remove base-compat as a dependency (#4384 by @PureFunctor) + ## 0.15.4 Bugfixes: diff --git a/INSTALL.md b/INSTALL.md index 0adba49e91..29175f9af6 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -4,12 +4,12 @@ If you are having difficulty installing the PureScript compiler, feel free to as ## Requirements -The PureScript compiler is built using GHC 8.10.7, and should be able to run on any operating system supported by GHC 8.10.7. In particular: +The PureScript compiler is built using GHC 9.2.3, and should be able to run on any operating system supported by GHC 9.2.3. In particular: * for Windows users, versions predating Vista are not officially supported, * for macOS / OS X users, versions predating Mac OS X 10.7 (Lion) are not officially supported. -See also for more details about the operating systems which GHC 8.10.7 supports. +See also for more details about the operating systems which GHC 9.2.3 supports. ## Official prebuilt binaries diff --git a/LICENSE b/LICENSE index 0012f04c11..0acf73c6ea 100644 --- a/LICENSE +++ b/LICENSE @@ -47,6 +47,7 @@ PureScript uses the following Haskell library packages. Their license files foll call-stack case-insensitive cborg + cereal cheapskate clock colour @@ -71,7 +72,6 @@ PureScript uses the following Haskell library packages. Their license files foll dlist easy-file edit-distance - enclosed-exceptions exceptions fast-logger file-embed @@ -84,7 +84,7 @@ PureScript uses the following Haskell library packages. Their license files foll happy hashable haskeline - hinotify + hfsevents http-types indexed-traversable indexed-traversable-instances @@ -129,7 +129,6 @@ PureScript uses the following Haskell library packages. Their license files foll semigroupoids semigroups serialise - shelly sourcemap split splitmix @@ -1275,6 +1274,39 @@ cborg LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +cereal LICENSE file: + + Copyright (c) Lennart Kolmodin, Galois, Inc. + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + cheapskate LICENSE file: Copyright (c) 2013, John MacFarlane @@ -2008,29 +2040,6 @@ edit-distance LICENSE file: IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -enclosed-exceptions LICENSE file: - - Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ - - Permission is hereby granted, free of charge, to any person obtaining - a copy of this software and associated documentation files (the - "Software"), to deal in the Software without restriction, including - without limitation the rights to use, copy, modify, merge, publish, - distribute, sublicense, and/or sell copies of the Software, and to - permit persons to whom the Software is furnished to do so, subject to - the following conditions: - - The above copyright notice and this permission notice shall be - included in all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE - LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION - OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - exceptions LICENSE file: Copyright 2013-2015 Edward Kmett @@ -2447,38 +2456,38 @@ haskeline LICENSE file: OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -hinotify LICENSE file: +hfsevents LICENSE file: - Copyright (c) Lennart Kolmodin + Copyright (c) 2012, Luite Stegeman All rights reserved. Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: + modification, are permitted provided that the following conditions are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + * Neither the name of Luite Stegeman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS - OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. http-types LICENSE file: @@ -3920,39 +3929,6 @@ serialise LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -shelly LICENSE file: - - Copyright (c) 2017, Petr Rockai - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Petr Rockai nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - sourcemap LICENSE file: Copyright (c) 2012, Chris Done diff --git a/npm-package/package.json b/npm-package/package.json index 78d7e4a12d..921bc13790 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.4", + "version": "0.15.5", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.4", + "postinstall": "install-purescript --purs-ver=0.15.5", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index 43a2fa17ba..bcbdc62ebf 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.4 +version: 0.15.5 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From a2b047656be3c7bae7f46af232307b09ba644552 Mon Sep 17 00:00:00 2001 From: Pete Murphy <26548438+ptrfrncsmrph@users.noreply.github.com> Date: Mon, 17 Oct 2022 10:23:17 -0400 Subject: [PATCH 1510/1580] Make FromJSON instance for Qualified backwards compatible (#4403) * Make FromJSON (Qualified a) backwards compatible * Add purescript-prelude-5.0.1.json to golden tests --- .../fix_make-fromjson-backwards-compatible.md | 12 ++++++++++++ src/Language/PureScript/Names.hs | 5 ++++- tests/json-compat/v0.14.0/prelude-5.0.1.json | 1 + 3 files changed, 17 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/fix_make-fromjson-backwards-compatible.md create mode 100644 tests/json-compat/v0.14.0/prelude-5.0.1.json diff --git a/CHANGELOG.d/fix_make-fromjson-backwards-compatible.md b/CHANGELOG.d/fix_make-fromjson-backwards-compatible.md new file mode 100644 index 0000000000..a4baf4f540 --- /dev/null +++ b/CHANGELOG.d/fix_make-fromjson-backwards-compatible.md @@ -0,0 +1,12 @@ +* Make `FromJSON` instance for `Qualified` backwards compatible + + Prior to #4293, `Qualified` was encoded to JSON such that + + ```haskell + >>> encode $ Qualified Nothing "foo" + [null,"foo"] + >>> encode $ Qualified (Just $ ModuleName "A") "bar" + ["A","bar"] + ``` + + The type of `Qualified` has changed so that `null` no longer appears in JSON output, but for sake of backwards-compatibility with JSON that was produced prior to those changes (pre-`v0.15.2`), we need to accept `null`, which will be interpreted as `Qualified ByNullSourcePos`. diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 03fd10a8b3..16dda5e1bb 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -292,7 +292,7 @@ instance ToJSON a => ToJSON (Qualified a) where BySourcePos ss -> toJSON2 (ss, a) instance FromJSON a => FromJSON (Qualified a) where - parseJSON v = byModule <|> bySourcePos + parseJSON v = byModule <|> bySourcePos <|> byMaybeModuleName' where byModule = do (mn, a) <- parseJSON2 v @@ -300,6 +300,9 @@ instance FromJSON a => FromJSON (Qualified a) where bySourcePos = do (ss, a) <- parseJSON2 v pure $ Qualified (BySourcePos ss) a + byMaybeModuleName' = do + (mn, a) <- parseJSON2 v + pure $ Qualified (byMaybeModuleName mn) a instance ToJSON ModuleName where toJSON (ModuleName name) = toJSON (T.splitOn "." name) diff --git a/tests/json-compat/v0.14.0/prelude-5.0.1.json b/tests/json-compat/v0.14.0/prelude-5.0.1.json new file mode 100644 index 0000000000..cdfa5a0930 --- /dev/null +++ b/tests/json-compat/v0.14.0/prelude-5.0.1.json @@ -0,0 +1 @@ +{"uploader":"thomashoneyman","packageMeta":{"homepage":"https://github.com/purescript/purescript-prelude","repository":{"url":"https://github.com/purescript/purescript-prelude.git","type":"git"},"ignore":["**/.*","bower_components","node_modules","output","test","bower.json","package.json"],"name":"purescript-prelude","license":["BSD-3-Clause"],"description":"The PureScript Prelude"},"tagTime":"2021-05-11T21:10:31+0000","modules":[{"reExports":[{"moduleName":{"package":null,"item":["Control","Apply"]},"declarations":[{"children":[{"comments":null,"title":"apply","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]},null]},null]}},"sourceSpan":{"start":[46,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[46,48]}},{"comments":null,"title":"applyFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[50,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[51,26]}},{"comments":null,"title":"applyArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[54,21]}},{"comments":null,"title":"applyProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[58,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[59,20]}}],"comments":"The `Apply` class provides the `(<*>)` which is used to apply a function\nto an argument under a type constructor.\n\n`Apply` can be used to lift functions of two or more arguments to work on\nvalues wrapped with the type constructor `f`. It might also be understood\nin terms of the `lift2` function:\n\n```purescript\nlift2 :: forall f a b c. Apply f => (a -> b -> c) -> f a -> f b -> f c\nlift2 f a b = f <$> a <*> b\n```\n\n`(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts\nthe function application operator `($)` to arguments wrapped with the\ntype constructor `f`.\n\nPut differently...\n```\nfoo =\n functionTakingNArguments <$> computationProducingArg1\n <*> computationProducingArg2\n <*> ...\n <*> computationProducingArgN\n```\n\nInstances must satisfy the following law in addition to the `Functor`\nlaws:\n\n- Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`\n\nFormally, `Apply` represents a strong lax semi-monoidal endofunctor.\n","title":"Apply","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[45,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[46,48]}},{"children":[],"comments":null,"title":"(<*>)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"apply"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[48,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[48,22]}},{"children":[],"comments":null,"title":"(<*)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"applyFirst"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[65,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[65,26]}},{"children":[],"comments":null,"title":"(*>)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"applySecond"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[71,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[71,27]}}]},{"moduleName":{"package":null,"item":["Data","Functor"]},"declarations":[{"children":[{"comments":null,"title":"map","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]},null]},null]}},"sourceSpan":{"start":[26,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[26,44]}},{"comments":null,"title":"functorFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[41,16]}},{"comments":null,"title":"functorArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[44,17]}},{"comments":null,"title":"functorProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[47,18]}}],"comments":"A `Functor` is a type constructor which supports a mapping operation\n`map`.\n\n`map` can be used to turn functions `a -> b` into functions\n`f a -> f b` whose argument and return types use the type constructor `f`\nto represent some computational context.\n\nInstances must satisfy the following laws:\n\n- Identity: `map identity = identity`\n- Composition: `map (f <<< g) = map f <<< map g`\n","title":"Functor","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[26,44]}},{"children":[],"comments":"The `void` function is used to ignore the type wrapped by a\n[`Functor`](#functor), replacing it with `Unit` and keeping only the type\ninformation provided by the type constructor itself.\n\n`void` is often useful when using `do` notation to change the return type\nof a monadic computation:\n\n```purescript\nmain = forE 1 10 \\n -> void do\n print n\n print (n * n)\n```\n","title":"void","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]},null]},null]}},"sourceSpan":{"start":[63,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[63,47]}},{"children":[],"comments":null,"title":"(<$>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"map"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[28,20]}},{"children":[],"comments":null,"title":"(<$)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"voidRight"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[71,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[71,25]}},{"children":[],"comments":null,"title":"(<#>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"mapFlipped"}}}],"fixity":{"associativity":"infixl","precedence":1}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[38,27]}},{"children":[],"comments":null,"title":"($>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"voidLeft"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[77,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[77,24]}}]}],"name":"Control.Applicative","comments":null,"declarations":[{"children":[{"comments":null,"title":"pure","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]}},"sourceSpan":{"start":[34,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[34,29]}},{"comments":null,"title":"applicativeFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[37,15]}},{"comments":null,"title":"applicativeArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[40,15]}},{"comments":null,"title":"applicativeProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[42,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[43,17]}}],"comments":"The `Applicative` type class extends the [`Apply`](#apply) type class\nwith a `pure` function, which can be used to create values of type `f a`\nfrom values of type `a`.\n\nWhere [`Apply`](#apply) provides the ability to lift functions of two or\nmore arguments to functions whose arguments are wrapped using `f`, and\n[`Functor`](#functor) provides the ability to lift functions of one\nargument, `pure` can be seen as the function which lifts functions of\n_zero_ arguments. That is, `Applicative` functors support a lifting\noperation for any number of function arguments.\n\nInstances must satisfy the following laws in addition to the `Apply`\nlaws:\n\n- Identity: `(pure identity) <*> v = v`\n- Composition: `pure (<<<) <*> f <*> g <*> h = f <*> (g <*> h)`\n- Homomorphism: `(pure f) <*> (pure x) = pure (f x)`\n- Interchange: `u <*> (pure y) = (pure (_ $ y)) <*> u`\n","title":"Applicative","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Control","Apply"],"Apply"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[33,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[34,29]}},{"children":[],"comments":"`liftA1` provides a default implementation of `(<$>)` for any\n[`Applicative`](#applicative) functor, without using `(<$>)` as provided\nby the [`Functor`](#functor)-[`Applicative`](#applicative) superclass\nrelationship.\n\n`liftA1` can therefore be used to write [`Functor`](#functor) instances\nas follows:\n\n```purescript\ninstance functorF :: Functor F where\n map = liftA1\n```\n","title":"liftA1","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Applicative"],"Applicative"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[57,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[57,64]}},{"children":[],"comments":"Perform an applicative action unless a condition is true.\n","title":"unless","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Applicative"],"Applicative"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]}]},null]}},"sourceSpan":{"start":[66,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[66,65]}},{"children":[],"comments":"Perform an applicative action when a condition is true.\n","title":"when","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Applicative"],"Applicative"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]}]},null]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[61,63]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Data","Functor"]},"declarations":[{"children":[{"comments":null,"title":"map","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]},null]},null]}},"sourceSpan":{"start":[26,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[26,44]}},{"comments":null,"title":"functorFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[41,16]}},{"comments":null,"title":"functorArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[44,17]}},{"comments":null,"title":"functorProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[47,18]}}],"comments":"A `Functor` is a type constructor which supports a mapping operation\n`map`.\n\n`map` can be used to turn functions `a -> b` into functions\n`f a -> f b` whose argument and return types use the type constructor `f`\nto represent some computational context.\n\nInstances must satisfy the following laws:\n\n- Identity: `map identity = identity`\n- Composition: `map (f <<< g) = map f <<< map g`\n","title":"Functor","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[26,44]}},{"children":[],"comments":"The `void` function is used to ignore the type wrapped by a\n[`Functor`](#functor), replacing it with `Unit` and keeping only the type\ninformation provided by the type constructor itself.\n\n`void` is often useful when using `do` notation to change the return type\nof a monadic computation:\n\n```purescript\nmain = forE 1 10 \\n -> void do\n print n\n print (n * n)\n```\n","title":"void","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]},null]},null]}},"sourceSpan":{"start":[63,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[63,47]}},{"children":[],"comments":null,"title":"(<$>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"map"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[28,20]}},{"children":[],"comments":null,"title":"(<$)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"voidRight"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[71,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[71,25]}},{"children":[],"comments":null,"title":"(<#>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"mapFlipped"}}}],"fixity":{"associativity":"infixl","precedence":1}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[38,27]}},{"children":[],"comments":null,"title":"($>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"voidLeft"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[77,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[77,24]}}]}],"name":"Control.Apply","comments":null,"declarations":[{"children":[{"comments":null,"title":"apply","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]},null]},null]}},"sourceSpan":{"start":[46,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[46,48]}},{"comments":null,"title":"applyFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[50,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[51,26]}},{"comments":null,"title":"applyArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[54,21]}},{"comments":null,"title":"applyProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[58,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[59,20]}}],"comments":"The `Apply` class provides the `(<*>)` which is used to apply a function\nto an argument under a type constructor.\n\n`Apply` can be used to lift functions of two or more arguments to work on\nvalues wrapped with the type constructor `f`. It might also be understood\nin terms of the `lift2` function:\n\n```purescript\nlift2 :: forall f a b c. Apply f => (a -> b -> c) -> f a -> f b -> f c\nlift2 f a b = f <$> a <*> b\n```\n\n`(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts\nthe function application operator `($)` to arguments wrapped with the\ntype constructor `f`.\n\nPut differently...\n```\nfoo =\n functionTakingNArguments <$> computationProducingArg1\n <*> computationProducingArg2\n <*> ...\n <*> computationProducingArgN\n```\n\nInstances must satisfy the following law in addition to the `Functor`\nlaws:\n\n- Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`\n\nFormally, `Apply` represents a strong lax semi-monoidal endofunctor.\n","title":"Apply","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[45,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[46,48]}},{"children":[],"comments":null,"title":"(<*>)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"apply"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[48,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[48,22]}},{"children":[],"comments":"Combine two effectful actions, keeping only the result of the first.\n","title":"applyFirst","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Apply"],"Apply"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[62,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[62,57]}},{"children":[],"comments":null,"title":"(<*)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"applyFirst"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[65,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[65,26]}},{"children":[],"comments":"Combine two effectful actions, keeping only the result of the second.\n","title":"applySecond","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Apply"],"Apply"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[68,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[68,58]}},{"children":[],"comments":null,"title":"(*>)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"applySecond"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[71,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[71,27]}},{"children":[],"comments":"Lift a function of two arguments to a function which accepts and returns\nvalues wrapped with the type constructor `f`.\n\n```purescript\nlift2 add (Just 1) (Just 2) == Just 3\nlift2 add Nothing (Just 2) == Nothing\n```\n\n","title":"lift2","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["c",{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Apply"],"Apply"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]}]}]}]},null]},null]},null]},null]}},"sourceSpan":{"start":[81,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[81,71]}},{"children":[],"comments":"Lift a function of three arguments to a function which accepts and returns\nvalues wrapped with the type constructor `f`.\n","title":"lift3","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["c",{"annotation":[],"tag":"ForAll","contents":["d",{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Apply"],"Apply"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"c"}]},{"annotation":[],"tag":"TypeVar","contents":"d"}]}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"d"}]}]}]}]}]}]},null]},null]},null]},null]},null]}},"sourceSpan":{"start":[86,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[86,85]}},{"children":[],"comments":"Lift a function of four arguments to a function which accepts and returns\nvalues wrapped with the type constructor `f`.\n","title":"lift4","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["c",{"annotation":[],"tag":"ForAll","contents":["d",{"annotation":[],"tag":"ForAll","contents":["e",{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Apply"],"Apply"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"c"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"d"}]},{"annotation":[],"tag":"TypeVar","contents":"e"}]}]}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"d"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"e"}]}]}]}]}]}]}]},null]},null]},null]},null]},null]},null]}},"sourceSpan":{"start":[91,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[91,99]}},{"children":[],"comments":"Lift a function of five arguments to a function which accepts and returns\nvalues wrapped with the type constructor `f`.\n","title":"lift5","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["c",{"annotation":[],"tag":"ForAll","contents":["d",{"annotation":[],"tag":"ForAll","contents":["e",{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["g",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Apply"],"Apply"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"c"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"d"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"e"}]},{"annotation":[],"tag":"TypeVar","contents":"g"}]}]}]}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"d"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"e"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"g"}]}]}]}]}]}]}]}]},null]},null]},null]},null]},null]},null]},null]}},"sourceSpan":{"start":[96,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[96,113]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Control","Applicative"]},"declarations":[{"children":[{"comments":null,"title":"pure","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]}},"sourceSpan":{"start":[34,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[34,29]}},{"comments":null,"title":"applicativeFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[37,15]}},{"comments":null,"title":"applicativeArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[40,15]}},{"comments":null,"title":"applicativeProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[42,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[43,17]}}],"comments":"The `Applicative` type class extends the [`Apply`](#apply) type class\nwith a `pure` function, which can be used to create values of type `f a`\nfrom values of type `a`.\n\nWhere [`Apply`](#apply) provides the ability to lift functions of two or\nmore arguments to functions whose arguments are wrapped using `f`, and\n[`Functor`](#functor) provides the ability to lift functions of one\nargument, `pure` can be seen as the function which lifts functions of\n_zero_ arguments. That is, `Applicative` functors support a lifting\noperation for any number of function arguments.\n\nInstances must satisfy the following laws in addition to the `Apply`\nlaws:\n\n- Identity: `(pure identity) <*> v = v`\n- Composition: `pure (<<<) <*> f <*> g <*> h = f <*> (g <*> h)`\n- Homomorphism: `(pure f) <*> (pure x) = pure (f x)`\n- Interchange: `u <*> (pure y) = (pure (_ $ y)) <*> u`\n","title":"Applicative","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Control","Apply"],"Apply"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[33,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[34,29]}},{"children":[],"comments":"Perform an applicative action when a condition is true.\n","title":"when","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Applicative"],"Applicative"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]}]},null]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[61,63]}},{"children":[],"comments":"Perform an applicative action unless a condition is true.\n","title":"unless","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Applicative"],"Applicative"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]}]},null]}},"sourceSpan":{"start":[66,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[66,65]}},{"children":[],"comments":"`liftA1` provides a default implementation of `(<$>)` for any\n[`Applicative`](#applicative) functor, without using `(<$>)` as provided\nby the [`Functor`](#functor)-[`Applicative`](#applicative) superclass\nrelationship.\n\n`liftA1` can therefore be used to write [`Functor`](#functor) instances\nas follows:\n\n```purescript\ninstance functorF :: Functor F where\n map = liftA1\n```\n","title":"liftA1","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Applicative"],"Applicative"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[57,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[57,64]}}]},{"moduleName":{"package":null,"item":["Control","Apply"]},"declarations":[{"children":[{"comments":null,"title":"apply","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]},null]},null]}},"sourceSpan":{"start":[46,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[46,48]}},{"comments":null,"title":"applyFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[50,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[51,26]}},{"comments":null,"title":"applyArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[54,21]}},{"comments":null,"title":"applyProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[58,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[59,20]}}],"comments":"The `Apply` class provides the `(<*>)` which is used to apply a function\nto an argument under a type constructor.\n\n`Apply` can be used to lift functions of two or more arguments to work on\nvalues wrapped with the type constructor `f`. It might also be understood\nin terms of the `lift2` function:\n\n```purescript\nlift2 :: forall f a b c. Apply f => (a -> b -> c) -> f a -> f b -> f c\nlift2 f a b = f <$> a <*> b\n```\n\n`(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts\nthe function application operator `($)` to arguments wrapped with the\ntype constructor `f`.\n\nPut differently...\n```\nfoo =\n functionTakingNArguments <$> computationProducingArg1\n <*> computationProducingArg2\n <*> ...\n <*> computationProducingArgN\n```\n\nInstances must satisfy the following law in addition to the `Functor`\nlaws:\n\n- Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`\n\nFormally, `Apply` represents a strong lax semi-monoidal endofunctor.\n","title":"Apply","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[45,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[46,48]}},{"children":[],"comments":null,"title":"(<*>)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"apply"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[48,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[48,22]}},{"children":[],"comments":null,"title":"(<*)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"applyFirst"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[65,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[65,26]}},{"children":[],"comments":null,"title":"(*>)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"applySecond"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[71,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[71,27]}}]},{"moduleName":{"package":null,"item":["Data","Functor"]},"declarations":[{"children":[{"comments":null,"title":"map","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]},null]},null]}},"sourceSpan":{"start":[26,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[26,44]}},{"comments":null,"title":"functorFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[41,16]}},{"comments":null,"title":"functorArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[44,17]}},{"comments":null,"title":"functorProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[47,18]}}],"comments":"A `Functor` is a type constructor which supports a mapping operation\n`map`.\n\n`map` can be used to turn functions `a -> b` into functions\n`f a -> f b` whose argument and return types use the type constructor `f`\nto represent some computational context.\n\nInstances must satisfy the following laws:\n\n- Identity: `map identity = identity`\n- Composition: `map (f <<< g) = map f <<< map g`\n","title":"Functor","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[26,44]}},{"children":[],"comments":"The `void` function is used to ignore the type wrapped by a\n[`Functor`](#functor), replacing it with `Unit` and keeping only the type\ninformation provided by the type constructor itself.\n\n`void` is often useful when using `do` notation to change the return type\nof a monadic computation:\n\n```purescript\nmain = forE 1 10 \\n -> void do\n print n\n print (n * n)\n```\n","title":"void","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]},null]},null]}},"sourceSpan":{"start":[63,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[63,47]}},{"children":[],"comments":null,"title":"(<$>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"map"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[28,20]}},{"children":[],"comments":null,"title":"(<$)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"voidRight"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[71,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[71,25]}},{"children":[],"comments":null,"title":"(<#>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"mapFlipped"}}}],"fixity":{"associativity":"infixl","precedence":1}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[38,27]}},{"children":[],"comments":null,"title":"($>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"voidLeft"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[77,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[77,24]}}]}],"name":"Control.Bind","comments":null,"declarations":[{"children":[{"comments":null,"title":"bind","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]},null]},null]}},"sourceSpan":{"start":[51,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[51,47]}},{"comments":null,"title":"bindFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[65,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[66,25]}},{"comments":"The `bind`/`>>=` function for `Array` works by applying a function to\neach element in the array, and flattening the results into a single,\nnew array.\n\nArray's `bind`/`>>=` works like a nested for loop. Each `bind` adds\nanother level of nesting in the loop. For example:\n```\nfoo :: Array String\nfoo =\n [\"a\", \"b\"] >>= \\eachElementInArray1 ->\n [\"c\", \"d\"] >>= \\eachElementInArray2\n pure (eachElementInArray1 <> eachElementInArray2)\n\n-- In other words...\nfoo\n-- ... is the same as...\n[ (\"a\" <> \"c\"), (\"a\" <> \"d\"), (\"b\" <> \"c\"), (\"b\" <> \"d\") ]\n-- which simplifies to...\n[ \"ac\", \"ad\", \"bc\", \"bd\" ]\n```\n","title":"bindArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[88,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[89,19]}},{"comments":null,"title":"bindProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[93,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[94,19]}}],"comments":"The `Bind` type class extends the [`Apply`](#apply) type class with a\n\"bind\" operation `(>>=)` which composes computations in sequence, using\nthe return value of one computation to determine the next computation.\n\nThe `>>=` operator can also be expressed using `do` notation, as follows:\n\n```purescript\nx >>= f = do y <- x\n f y\n```\n\nwhere the function argument of `f` is given the name `y`.\n\nInstances must satisfy the following laws in addition to the `Apply`\nlaws:\n\n- Associativity: `(x >>= f) >>= g = x >>= (\\k -> f k >>= g)`\n- Apply Superclass: `apply f x = f >>= \\f’ -> map f’ x`\n\nAssociativity tells us that we can regroup operations which use `do`\nnotation so that we can unambiguously write, for example:\n\n```purescript\ndo x <- m1\n y <- m2 x\n m3 x y\n```\n","title":"Bind","info":{"fundeps":[],"arguments":[["m",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Control","Apply"],"Apply"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[50,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[51,47]}},{"children":[],"comments":null,"title":"(>>=)","info":{"declType":"alias","alias":[["Control","Bind"],{"Right":{"Left":{"Ident":"bind"}}}],"fixity":{"associativity":"infixl","precedence":1}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[53,21]}},{"children":[],"comments":"`bindFlipped` is `bind` with its arguments reversed. For example:\n\n```purescript\nprint =<< random\n```\n","title":"bindFlipped","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Bind"],"Bind"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[60,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[60,64]}},{"children":[],"comments":null,"title":"(=<<)","info":{"declType":"alias","alias":[["Control","Bind"],{"Right":{"Left":{"Ident":"bindFlipped"}}}],"fixity":{"associativity":"infixr","precedence":1}},"sourceSpan":{"start":[63,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[63,28]}},{"children":[{"comments":null,"title":"discard","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Bind"],"Bind"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]}},"sourceSpan":{"start":[102,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[102,60]}},{"comments":null,"title":"discardUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Discard"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[104,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[105,17]}},{"comments":null,"title":"discardProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Discard"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[107,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[108,17]}},{"comments":null,"title":"discardProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Discard"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[110,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[111,17]}},{"comments":null,"title":"discardProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Discard"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[113,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[114,17]}}],"comments":"A class for types whose values can safely be discarded\nin a `do` notation block.\n\nAn example is the `Unit` type, since there is only one\npossible value which can be returned.\n","title":"Discard","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[101,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[102,60]}},{"children":[],"comments":"Collapse two applications of a monadic type constructor into one.\n","title":"join","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Bind"],"Bind"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]},null]},null]}},"sourceSpan":{"start":[117,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[117,45]}},{"children":[],"comments":"Forwards Kleisli composition.\n\nFor example:\n\n```purescript\nimport Data.Array (head, tail)\n\nthird = tail >=> tail >=> head\n```\n","title":"composeKleisli","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["c",{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Bind"],"Bind"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]}]}]}]},null]},null]},null]},null]}},"sourceSpan":{"start":[129,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[129,81]}},{"children":[],"comments":null,"title":"(>=>)","info":{"declType":"alias","alias":[["Control","Bind"],{"Right":{"Left":{"Ident":"composeKleisli"}}}],"fixity":{"associativity":"infixr","precedence":1}},"sourceSpan":{"start":[132,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[132,31]}},{"children":[],"comments":"Backwards Kleisli composition.\n","title":"composeKleisliFlipped","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["c",{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Bind"],"Bind"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]}]}]}]},null]},null]},null]},null]}},"sourceSpan":{"start":[135,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[135,88]}},{"children":[],"comments":null,"title":"(<=<)","info":{"declType":"alias","alias":[["Control","Bind"],{"Right":{"Left":{"Ident":"composeKleisliFlipped"}}}],"fixity":{"associativity":"infixr","precedence":1}},"sourceSpan":{"start":[138,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[138,38]}},{"children":[],"comments":"Execute a monadic action if a condition holds.\n\nFor example:\n\n```purescript\nmain = ifM ((< 0.5) <$> random)\n (trace \"Heads\")\n (trace \"Tails\")\n```\n","title":"ifM","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Bind"],"Bind"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]}]},null]},null]}},"sourceSpan":{"start":[149,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[149,60]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Control","Semigroupoid"]},"declarations":[{"children":[{"comments":null,"title":"compose","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["c",{"annotation":[],"tag":"ForAll","contents":["d",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"c"}]},{"annotation":[],"tag":"TypeVar","contents":"d"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"d"}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[14,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[14,51]}},{"comments":null,"title":"semigroupoidFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Semigroupoid"],"Semigroupoid"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]}]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[17,26]}}],"comments":null,"title":"Semigroupoid","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[14,51]}},{"children":[],"comments":null,"title":"(>>>)","info":{"declType":"alias","alias":[["Control","Semigroupoid"],{"Right":{"Left":{"Ident":"composeFlipped"}}}],"fixity":{"associativity":"infixr","precedence":9}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[25,31]}},{"children":[],"comments":null,"title":"(<<<)","info":{"declType":"alias","alias":[["Control","Semigroupoid"],{"Right":{"Left":{"Ident":"compose"}}}],"fixity":{"associativity":"infixr","precedence":9}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[19,24]}}]}],"name":"Control.Category","comments":null,"declarations":[{"children":[{"comments":null,"title":"identity","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["t",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"t"}]},{"annotation":[],"tag":"TypeVar","contents":"t"}]},null]}},"sourceSpan":{"start":[18,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Category.purs","end":[18,30]}},{"comments":null,"title":"categoryFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Category"],"Category"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]}]}},"sourceSpan":{"start":[20,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Category.purs","end":[21,17]}}],"comments":null,"title":"Category","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Control","Semigroupoid"],"Semigroupoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[17,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Category.purs","end":[18,30]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Control","Applicative"]},"declarations":[{"children":[{"comments":null,"title":"pure","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]}},"sourceSpan":{"start":[34,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[34,29]}},{"comments":null,"title":"applicativeFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[37,15]}},{"comments":null,"title":"applicativeArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[40,15]}},{"comments":null,"title":"applicativeProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[42,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[43,17]}}],"comments":"The `Applicative` type class extends the [`Apply`](#apply) type class\nwith a `pure` function, which can be used to create values of type `f a`\nfrom values of type `a`.\n\nWhere [`Apply`](#apply) provides the ability to lift functions of two or\nmore arguments to functions whose arguments are wrapped using `f`, and\n[`Functor`](#functor) provides the ability to lift functions of one\nargument, `pure` can be seen as the function which lifts functions of\n_zero_ arguments. That is, `Applicative` functors support a lifting\noperation for any number of function arguments.\n\nInstances must satisfy the following laws in addition to the `Apply`\nlaws:\n\n- Identity: `(pure identity) <*> v = v`\n- Composition: `pure (<<<) <*> f <*> g <*> h = f <*> (g <*> h)`\n- Homomorphism: `(pure f) <*> (pure x) = pure (f x)`\n- Interchange: `u <*> (pure y) = (pure (_ $ y)) <*> u`\n","title":"Applicative","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Control","Apply"],"Apply"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[33,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[34,29]}},{"children":[],"comments":"Perform an applicative action when a condition is true.\n","title":"when","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Applicative"],"Applicative"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]}]},null]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[61,63]}},{"children":[],"comments":"Perform an applicative action unless a condition is true.\n","title":"unless","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Applicative"],"Applicative"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]}]},null]}},"sourceSpan":{"start":[66,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[66,65]}},{"children":[],"comments":"`liftA1` provides a default implementation of `(<$>)` for any\n[`Applicative`](#applicative) functor, without using `(<$>)` as provided\nby the [`Functor`](#functor)-[`Applicative`](#applicative) superclass\nrelationship.\n\n`liftA1` can therefore be used to write [`Functor`](#functor) instances\nas follows:\n\n```purescript\ninstance functorF :: Functor F where\n map = liftA1\n```\n","title":"liftA1","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Applicative"],"Applicative"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[57,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[57,64]}}]},{"moduleName":{"package":null,"item":["Control","Apply"]},"declarations":[{"children":[{"comments":null,"title":"apply","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]},null]},null]}},"sourceSpan":{"start":[46,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[46,48]}},{"comments":null,"title":"applyFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[50,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[51,26]}},{"comments":null,"title":"applyArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[54,21]}},{"comments":null,"title":"applyProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[58,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[59,20]}}],"comments":"The `Apply` class provides the `(<*>)` which is used to apply a function\nto an argument under a type constructor.\n\n`Apply` can be used to lift functions of two or more arguments to work on\nvalues wrapped with the type constructor `f`. It might also be understood\nin terms of the `lift2` function:\n\n```purescript\nlift2 :: forall f a b c. Apply f => (a -> b -> c) -> f a -> f b -> f c\nlift2 f a b = f <$> a <*> b\n```\n\n`(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts\nthe function application operator `($)` to arguments wrapped with the\ntype constructor `f`.\n\nPut differently...\n```\nfoo =\n functionTakingNArguments <$> computationProducingArg1\n <*> computationProducingArg2\n <*> ...\n <*> computationProducingArgN\n```\n\nInstances must satisfy the following law in addition to the `Functor`\nlaws:\n\n- Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`\n\nFormally, `Apply` represents a strong lax semi-monoidal endofunctor.\n","title":"Apply","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[45,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[46,48]}},{"children":[],"comments":null,"title":"(<*>)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"apply"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[48,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[48,22]}},{"children":[],"comments":null,"title":"(<*)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"applyFirst"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[65,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[65,26]}},{"children":[],"comments":null,"title":"(*>)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"applySecond"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[71,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[71,27]}}]},{"moduleName":{"package":null,"item":["Control","Bind"]},"declarations":[{"children":[{"comments":null,"title":"bind","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]},null]},null]}},"sourceSpan":{"start":[51,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[51,47]}},{"comments":null,"title":"bindFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[65,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[66,25]}},{"comments":"The `bind`/`>>=` function for `Array` works by applying a function to\neach element in the array, and flattening the results into a single,\nnew array.\n\nArray's `bind`/`>>=` works like a nested for loop. Each `bind` adds\nanother level of nesting in the loop. For example:\n```\nfoo :: Array String\nfoo =\n [\"a\", \"b\"] >>= \\eachElementInArray1 ->\n [\"c\", \"d\"] >>= \\eachElementInArray2\n pure (eachElementInArray1 <> eachElementInArray2)\n\n-- In other words...\nfoo\n-- ... is the same as...\n[ (\"a\" <> \"c\"), (\"a\" <> \"d\"), (\"b\" <> \"c\"), (\"b\" <> \"d\") ]\n-- which simplifies to...\n[ \"ac\", \"ad\", \"bc\", \"bd\" ]\n```\n","title":"bindArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[88,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[89,19]}},{"comments":null,"title":"bindProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[93,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[94,19]}}],"comments":"The `Bind` type class extends the [`Apply`](#apply) type class with a\n\"bind\" operation `(>>=)` which composes computations in sequence, using\nthe return value of one computation to determine the next computation.\n\nThe `>>=` operator can also be expressed using `do` notation, as follows:\n\n```purescript\nx >>= f = do y <- x\n f y\n```\n\nwhere the function argument of `f` is given the name `y`.\n\nInstances must satisfy the following laws in addition to the `Apply`\nlaws:\n\n- Associativity: `(x >>= f) >>= g = x >>= (\\k -> f k >>= g)`\n- Apply Superclass: `apply f x = f >>= \\f’ -> map f’ x`\n\nAssociativity tells us that we can regroup operations which use `do`\nnotation so that we can unambiguously write, for example:\n\n```purescript\ndo x <- m1\n y <- m2 x\n m3 x y\n```\n","title":"Bind","info":{"fundeps":[],"arguments":[["m",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Control","Apply"],"Apply"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[50,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[51,47]}},{"children":[],"comments":"Collapse two applications of a monadic type constructor into one.\n","title":"join","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Bind"],"Bind"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]},null]},null]}},"sourceSpan":{"start":[117,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[117,45]}},{"children":[],"comments":"Execute a monadic action if a condition holds.\n\nFor example:\n\n```purescript\nmain = ifM ((< 0.5) <$> random)\n (trace \"Heads\")\n (trace \"Tails\")\n```\n","title":"ifM","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Bind"],"Bind"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]}]},null]},null]}},"sourceSpan":{"start":[149,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[149,60]}},{"children":[],"comments":null,"title":"(>>=)","info":{"declType":"alias","alias":[["Control","Bind"],{"Right":{"Left":{"Ident":"bind"}}}],"fixity":{"associativity":"infixl","precedence":1}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[53,21]}},{"children":[],"comments":null,"title":"(>=>)","info":{"declType":"alias","alias":[["Control","Bind"],{"Right":{"Left":{"Ident":"composeKleisli"}}}],"fixity":{"associativity":"infixr","precedence":1}},"sourceSpan":{"start":[132,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[132,31]}},{"children":[],"comments":null,"title":"(=<<)","info":{"declType":"alias","alias":[["Control","Bind"],{"Right":{"Left":{"Ident":"bindFlipped"}}}],"fixity":{"associativity":"infixr","precedence":1}},"sourceSpan":{"start":[63,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[63,28]}},{"children":[],"comments":null,"title":"(<=<)","info":{"declType":"alias","alias":[["Control","Bind"],{"Right":{"Left":{"Ident":"composeKleisliFlipped"}}}],"fixity":{"associativity":"infixr","precedence":1}},"sourceSpan":{"start":[138,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[138,38]}}]},{"moduleName":{"package":null,"item":["Data","Functor"]},"declarations":[{"children":[{"comments":null,"title":"map","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]},null]},null]}},"sourceSpan":{"start":[26,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[26,44]}},{"comments":null,"title":"functorFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[41,16]}},{"comments":null,"title":"functorArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[44,17]}},{"comments":null,"title":"functorProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[47,18]}}],"comments":"A `Functor` is a type constructor which supports a mapping operation\n`map`.\n\n`map` can be used to turn functions `a -> b` into functions\n`f a -> f b` whose argument and return types use the type constructor `f`\nto represent some computational context.\n\nInstances must satisfy the following laws:\n\n- Identity: `map identity = identity`\n- Composition: `map (f <<< g) = map f <<< map g`\n","title":"Functor","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[26,44]}},{"children":[],"comments":"The `void` function is used to ignore the type wrapped by a\n[`Functor`](#functor), replacing it with `Unit` and keeping only the type\ninformation provided by the type constructor itself.\n\n`void` is often useful when using `do` notation to change the return type\nof a monadic computation:\n\n```purescript\nmain = forE 1 10 \\n -> void do\n print n\n print (n * n)\n```\n","title":"void","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]},null]},null]}},"sourceSpan":{"start":[63,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[63,47]}},{"children":[],"comments":null,"title":"(<$>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"map"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[28,20]}},{"children":[],"comments":null,"title":"(<$)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"voidRight"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[71,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[71,25]}},{"children":[],"comments":null,"title":"(<#>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"mapFlipped"}}}],"fixity":{"associativity":"infixl","precedence":1}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[38,27]}},{"children":[],"comments":null,"title":"($>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"voidLeft"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[77,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[77,24]}}]}],"name":"Control.Monad","comments":null,"declarations":[{"children":[{"comments":null,"title":"monadFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Monad"],"Monad"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[33,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[33,35]}},{"comments":null,"title":"monadArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Monad"],"Monad"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[35,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[35,35]}},{"comments":null,"title":"monadProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Monad"],"Monad"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[37,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[37,35]}}],"comments":"The `Monad` type class combines the operations of the `Bind` and\n`Applicative` type classes. Therefore, `Monad` instances represent type\nconstructors which support sequential composition, and also lifting of\nfunctions of arbitrary arity.\n\nInstances must satisfy the following laws in addition to the\n`Applicative` and `Bind` laws:\n\n- Left Identity: `pure x >>= f = f x`\n- Right Identity: `x >>= pure = x`\n","title":"Monad","info":{"fundeps":[],"arguments":[["m",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Control","Applicative"],"Applicative"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Control","Bind"],"Bind"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[31,41]}},{"children":[],"comments":"`liftM1` provides a default implementation of `(<$>)` for any\n[`Monad`](#monad), without using `(<$>)` as provided by the\n[`Functor`](#functor)-[`Monad`](#monad) superclass relationship.\n\n`liftM1` can therefore be used to write [`Functor`](#functor) instances\nas follows:\n\n```purescript\ninstance functorF :: Functor F where\n map = liftM1\n```\n","title":"liftM1","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Monad"],"Monad"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[50,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[50,58]}},{"children":[],"comments":"Perform a monadic action when a condition is true, where the conditional\nvalue is also in a monadic context.\n","title":"whenM","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Monad"],"Monad"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]}]},null]}},"sourceSpan":{"start":[57,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[57,60]}},{"children":[],"comments":"Perform a monadic action unless a condition is true, where the conditional\nvalue is also in a monadic context.\n","title":"unlessM","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Monad"],"Monad"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]}]},null]}},"sourceSpan":{"start":[64,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[64,62]}},{"children":[],"comments":"`ap` provides a default implementation of `(<*>)` for any `Monad`, without\nusing `(<*>)` as provided by the `Apply`-`Monad` superclass relationship.\n\n`ap` can therefore be used to write `Apply` instances as follows:\n\n```purescript\ninstance applyF :: Apply F where\n apply = ap\n```\n","title":"ap","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Monad"],"Monad"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[82,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[82,56]}}]},{"reExports":[],"name":"Control.Semigroupoid","comments":null,"declarations":[{"children":[{"comments":null,"title":"compose","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["c",{"annotation":[],"tag":"ForAll","contents":["d",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"c"}]},{"annotation":[],"tag":"TypeVar","contents":"d"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"d"}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[14,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[14,51]}},{"comments":null,"title":"semigroupoidFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Semigroupoid"],"Semigroupoid"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]}]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[17,26]}}],"comments":null,"title":"Semigroupoid","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[14,51]}},{"children":[],"comments":null,"title":"(<<<)","info":{"declType":"alias","alias":[["Control","Semigroupoid"],{"Right":{"Left":{"Ident":"compose"}}}],"fixity":{"associativity":"infixr","precedence":9}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[19,24]}},{"children":[],"comments":"Forwards composition, or `compose` with its arguments reversed.\n","title":"composeFlipped","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["c",{"annotation":[],"tag":"ForAll","contents":["d",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Semigroupoid"],"Semigroupoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"c"}]},{"annotation":[],"tag":"TypeVar","contents":"d"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"d"}]}]}]}]},null]},null]},null]},null]}},"sourceSpan":{"start":[22,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[22,76]}},{"children":[],"comments":null,"title":"(>>>)","info":{"declType":"alias","alias":[["Control","Semigroupoid"],{"Right":{"Left":{"Ident":"composeFlipped"}}}],"fixity":{"associativity":"infixr","precedence":9}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[25,31]}}]},{"reExports":[],"name":"Data.Boolean","comments":null,"declarations":[{"children":[],"comments":"An alias for `true`, which can be useful in guard clauses:\n\n```purescript\nmax x y | x >= y = x\n | otherwise = y\n```\n","title":"otherwise","info":{"declType":"value","type":{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}},"sourceSpan":{"start":[9,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Boolean.purs","end":[9,21]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Data","HeytingAlgebra"]},"declarations":[{"children":[{"comments":null,"title":"ff","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[39,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[39,10]}},{"comments":null,"title":"tt","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[40,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[40,10]}},{"comments":null,"title":"implies","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[41,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[41,25]}},{"comments":null,"title":"conj","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[42,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[42,22]}},{"comments":null,"title":"disj","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[43,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[43,22]}},{"comments":null,"title":"not","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}},"sourceSpan":{"start":[44,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[44,16]}},{"comments":null,"title":"heytingAlgebraBoolean","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[55,16]}},{"comments":null,"title":"heytingAlgebraUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[57,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[63,15]}},{"comments":null,"title":"heytingAlgebraFunction","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[65,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[71,22]}},{"comments":null,"title":"heytingAlgebraProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[73,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[79,13]}},{"comments":null,"title":"heytingAlgebraProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[81,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[87,14]}},{"comments":null,"title":"heytingAlgebraProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[89,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[95,14]}},{"comments":null,"title":"heytingAlgebraRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebraRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[97,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[103,41]}}],"comments":"The `HeytingAlgebra` type class represents types that are bounded lattices with\nan implication operator such that the following laws hold:\n\n- Associativity:\n - `a || (b || c) = (a || b) || c`\n - `a && (b && c) = (a && b) && c`\n- Commutativity:\n - `a || b = b || a`\n - `a && b = b && a`\n- Absorption:\n - `a || (a && b) = a`\n - `a && (a || b) = a`\n- Idempotent:\n - `a || a = a`\n - `a && a = a`\n- Identity:\n - `a || ff = a`\n - `a && tt = a`\n- Implication:\n - ``a `implies` a = tt``\n - ``a && (a `implies` b) = a && b``\n - ``b && (a `implies` b) = b``\n - ``a `implies` (b && c) = (a `implies` b) && (a `implies` c)``\n- Complemented:\n - ``not a = a `implies` ff``\n","title":"HeytingAlgebra","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[44,16]}},{"children":[{"comments":null,"title":"heytingAlgebraRecordNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebraRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"REmpty"}]}},"sourceSpan":{"start":[120,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[126,20]}},{"comments":null,"title":"heytingAlgebraRecordCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebraRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebraRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}},"sourceSpan":{"start":[128,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[174,55]}}],"comments":null,"title":"HeytingAlgebraRecord","info":{"fundeps":[[["rowlist"],["subrow"]]],"arguments":[["rowlist",null],["row",null],["subrow",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[112,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[118,78]}},{"children":[],"comments":null,"title":"(||)","info":{"declType":"alias","alias":[["Data","HeytingAlgebra"],{"Right":{"Left":{"Ident":"disj"}}}],"fixity":{"associativity":"infixr","precedence":2}},"sourceSpan":{"start":[47,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[47,20]}},{"children":[],"comments":null,"title":"(&&)","info":{"declType":"alias","alias":[["Data","HeytingAlgebra"],{"Right":{"Left":{"Ident":"conj"}}}],"fixity":{"associativity":"infixr","precedence":3}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[46,20]}}]}],"name":"Data.BooleanAlgebra","comments":null,"declarations":[{"children":[{"comments":null,"title":"booleanAlgebraBoolean","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[24,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[24,57]}},{"comments":null,"title":"booleanAlgebraUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[25,51]}},{"comments":null,"title":"booleanAlgebraFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","BooleanAlgebra"],"BooleanAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[26,73]}},{"comments":null,"title":"booleanAlgebraRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","BooleanAlgebra"],"BooleanAlgebraRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[27,123]}},{"comments":null,"title":"booleanAlgebraProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[28,57]}},{"comments":null,"title":"booleanAlgebraProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[29,59]}},{"comments":null,"title":"booleanAlgebraProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[30,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[30,59]}}],"comments":"The `BooleanAlgebra` type class represents types that behave like boolean\nvalues.\n\nInstances should satisfy the following laws in addition to the\n`HeytingAlgebra` law:\n\n- Excluded middle:\n - `a || not a = tt`\n","title":"BooleanAlgebra","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[22,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[22,43]}},{"children":[{"comments":null,"title":"booleanAlgebraRecordNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebraRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"REmpty"}]}},"sourceSpan":{"start":[37,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[37,71]}},{"comments":null,"title":"booleanAlgebraRecordCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","BooleanAlgebra"],"BooleanAlgebraRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","BooleanAlgebra"],"BooleanAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebraRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[45,71]}}],"comments":null,"title":"BooleanAlgebraRecord","info":{"fundeps":[[["rowlist"],["subrow"]]],"arguments":[["rowlist",null],["row",null],["subrow",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebraRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlist"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[35,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[35,109]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Data","Ord"]},"declarations":[{"children":[{"comments":null,"title":"LT","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"GT","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"EQ","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"eqOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[15,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[19,19]}},{"comments":null,"title":"semigroupOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[21,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[24,18]}},{"comments":null,"title":"showOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[29,17]}}],"comments":"The `Ordering` data type represents the three possible outcomes of\ncomparing two values:\n\n`LT` - The first value is _less than_ the second.\n`GT` - The first value is _greater than_ the second.\n`EQ` - The first value is _equal to_ the second.\n","title":"Ordering","info":{"declType":"data","dataDeclType":"data","typeArguments":[]},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[13,29]}},{"children":[{"comments":null,"title":"compare","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}]}},"sourceSpan":{"start":[38,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[38,32]}},{"comments":null,"title":"ordBoolean","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[41,36]}},{"comments":null,"title":"ordInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[44,32]}},{"comments":null,"title":"ordNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[47,35]}},{"comments":null,"title":"ordString","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[50,35]}},{"comments":null,"title":"ordChar","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Char"]}]}},"sourceSpan":{"start":[52,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[53,33]}},{"comments":null,"title":"ordUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[55,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[56,19]}},{"comments":null,"title":"ordVoid","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Void"],"Void"]}]}},"sourceSpan":{"start":[58,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[59,19]}},{"comments":null,"title":"ordProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[62,19]}},{"comments":null,"title":"ordProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[64,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[65,19]}},{"comments":null,"title":"ordProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[67,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[68,19]}},{"comments":null,"title":"ordArray","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[70,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[77,17]}},{"comments":null,"title":"ordOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[121,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[128,21]}},{"comments":null,"title":"ordRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ord"],"OrdRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[249,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[254,48]}}],"comments":"The `Ord` type class represents types which support comparisons with a\n_total order_.\n\n`Ord` instances should satisfy the laws of total orderings:\n\n- Reflexivity: `a <= a`\n- Antisymmetry: if `a <= b` and `b <= a` then `a = b`\n- Transitivity: if `a <= b` and `b <= c` then `a <= c`\n","title":"Ord","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[37,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[38,32]}},{"children":[{"comments":null,"title":"ordRecordNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"OrdRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}},"sourceSpan":{"start":[230,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[231,27]}},{"comments":null,"title":"ordRecordCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"OrdRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"rowTail"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"OrdRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}},"sourceSpan":{"start":[233,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[247,59]}}],"comments":null,"title":"OrdRecord","info":{"fundeps":[],"arguments":[["rowlist",null],["row",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"EqRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlist"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[227,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[228,91]}},{"children":[],"comments":null,"title":"(>=)","info":{"declType":"alias","alias":[["Data","Ord"],{"Right":{"Left":{"Ident":"greaterThanOrEq"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[157,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[157,31]}},{"children":[],"comments":null,"title":"(>)","info":{"declType":"alias","alias":[["Data","Ord"],{"Right":{"Left":{"Ident":"greaterThan"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[156,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[156,26]}},{"children":[],"comments":null,"title":"(<=)","info":{"declType":"alias","alias":[["Data","Ord"],{"Right":{"Left":{"Ident":"lessThanOrEq"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[155,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[155,28]}},{"children":[],"comments":null,"title":"(<)","info":{"declType":"alias","alias":[["Data","Ord"],{"Right":{"Left":{"Ident":"lessThan"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[154,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[154,23]}}]}],"name":"Data.Bounded","comments":null,"declarations":[{"children":[{"comments":null,"title":"top","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[24,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[24,11]}},{"comments":null,"title":"bottom","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[25,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[25,14]}},{"comments":null,"title":"boundedBoolean","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[29,17]}},{"comments":"The `Bounded` `Int` instance has `top :: Int` equal to 2^31 - 1,\nand `bottom :: Int` equal to -2^31, since these are the largest and smallest\nintegers representable by twos-complement 32-bit integers, respectively.\n","title":"boundedInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[36,21]}},{"comments":"Characters fall within the Unicode range.\n","title":"boundedChar","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Char"]}]}},"sourceSpan":{"start":[42,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[44,22]}},{"comments":null,"title":"boundedOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[51,14]}},{"comments":null,"title":"boundedUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[55,16]}},{"comments":null,"title":"boundedNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[60,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[62,24]}},{"comments":null,"title":"boundedProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[64,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[66,14]}},{"comments":null,"title":"boundedProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[68,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[70,15]}},{"comments":null,"title":"boundedProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[72,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[74,15]}},{"comments":null,"title":"boundedRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Bounded"],"BoundedRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[107,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[113,67]}}],"comments":"The `Bounded` type class represents totally ordered types that have an\nupper and lower boundary.\n\nInstances should satisfy the following law in addition to the `Ord` laws:\n\n- Bounded: `bottom <= a <= top`\n","title":"Bounded","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[25,14]}},{"children":[{"comments":null,"title":"topRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"ForAll","contents":["rproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rproxy"},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]}]},null]},null]}},"sourceSpan":{"start":[78,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[78,85]}},{"comments":null,"title":"bottomRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"ForAll","contents":["rproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rproxy"},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]}]},null]},null]}},"sourceSpan":{"start":[79,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[79,88]}},{"comments":null,"title":"boundedRecordNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"BoundedRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"REmpty"}]}},"sourceSpan":{"start":[81,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[83,24]}},{"comments":null,"title":"boundedRecordCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Bounded"],"Bounded"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"rowTail"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Bounded"],"BoundedRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"BoundedRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}},"sourceSpan":{"start":[85,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[105,64]}}],"comments":null,"title":"BoundedRecord","info":{"fundeps":[[["rowlist"],["subrow"]]],"arguments":[["rowlist",null],["row",null],["subrow",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"OrdRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlist"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[77,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[79,88]}}]},{"reExports":[],"name":"Data.Bounded.Generic","comments":null,"declarations":[{"children":[{"comments":null,"title":"genericBottom'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[15,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[15,22]}},{"comments":null,"title":"genericBottomNoArguments","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded","Generic"],"GenericBottom"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoArguments"]}]}},"sourceSpan":{"start":[17,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[18,31]}},{"comments":null,"title":"genericBottomArgument","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded"],"Bounded"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded","Generic"],"GenericBottom"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Argument"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[20,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[21,35]}},{"comments":null,"title":"genericBottomSum","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded","Generic"],"GenericBottom"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded","Generic"],"GenericBottom"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Sum"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[24,38]}},{"comments":null,"title":"genericBottomProduct","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded","Generic"],"GenericBottom"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Bounded","Generic"],"GenericBottom"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded","Generic"],"GenericBottom"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Product"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[27,57]}},{"comments":null,"title":"genericBottomConstructor","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded","Generic"],"GenericBottom"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded","Generic"],"GenericBottom"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Constructor"]},{"annotation":[],"tag":"TypeVar","contents":"name"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[30,46]}}],"comments":null,"title":"GenericBottom","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[14,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[15,22]}},{"children":[],"comments":"A `Generic` implementation of the `bottom` member from the `Bounded` type class.\n","title":"genericBottom","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Bounded","Generic"],"GenericBottom"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]},null]}},"sourceSpan":{"start":[51,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[51,71]}},{"children":[{"comments":null,"title":"genericTop'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[33,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[33,19]}},{"comments":null,"title":"genericTopNoArguments","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded","Generic"],"GenericTop"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoArguments"]}]}},"sourceSpan":{"start":[35,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[36,28]}},{"comments":null,"title":"genericTopArgument","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded"],"Bounded"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded","Generic"],"GenericTop"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Argument"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[39,29]}},{"comments":null,"title":"genericTopSum","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded","Generic"],"GenericTop"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded","Generic"],"GenericTop"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Sum"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[41,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[42,32]}},{"comments":null,"title":"genericTopProduct","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded","Generic"],"GenericTop"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Bounded","Generic"],"GenericTop"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded","Generic"],"GenericTop"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Product"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[44,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[45,48]}},{"comments":null,"title":"genericTopConstructor","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded","Generic"],"GenericTop"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded","Generic"],"GenericTop"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Constructor"]},{"annotation":[],"tag":"TypeVar","contents":"name"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[47,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[48,40]}}],"comments":null,"title":"GenericTop","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[32,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[33,19]}},{"children":[],"comments":"A `Generic` implementation of the `top` member from the `Bounded` type class.\n","title":"genericTop","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Bounded","Generic"],"GenericTop"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]},null]}},"sourceSpan":{"start":[55,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded/Generic.purs","end":[55,65]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Data","Ring"]},"declarations":[{"children":[{"comments":null,"title":"ringInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[29,15]}},{"comments":null,"title":"ringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[32,15]}},{"comments":null,"title":"ringUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[35,17]}},{"comments":null,"title":"ringFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[37,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[38,24]}},{"comments":null,"title":"ringProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[41,18]}},{"comments":null,"title":"ringProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[44,19]}},{"comments":null,"title":"ringProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[47,19]}},{"comments":null,"title":"ringRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ring"],"RingRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[50,40]}}],"comments":"The `Ring` class is for types that support addition, multiplication,\nand subtraction operations.\n\nInstances must satisfy the following laws in addition to the `Semiring`\nlaws:\n\n- Additive inverse: `a - a = zero`\n- Compatibility of `sub` and `negate`: `a - b = a + (zero - b)`\n","title":"Ring","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[24,21]}},{"children":[{"comments":null,"title":"ringRecordNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"RingRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"REmpty"}]}},"sourceSpan":{"start":[65,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[66,23]}},{"comments":null,"title":"ringRecordCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ring"],"RingRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"RingRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}},"sourceSpan":{"start":[68,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[80,58]}}],"comments":null,"title":"RingRecord","info":{"fundeps":[[["rowlist"],["subrow"]]],"arguments":[["rowlist",null],["row",null],["subrow",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"SemiringRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlist"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[62,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[63,92]}}]},{"moduleName":{"package":null,"item":["Data","Semiring"]},"declarations":[{"children":[{"comments":null,"title":"add","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[35,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[35,22]}},{"comments":null,"title":"zero","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[36,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[36,12]}},{"comments":null,"title":"mul","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[37,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[37,22]}},{"comments":null,"title":"one","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[38,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[38,12]}},{"comments":null,"title":"semiringInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[47,10]}},{"comments":null,"title":"semiringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[53,12]}},{"comments":null,"title":"semiringFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[55,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[59,18]}},{"comments":null,"title":"semiringUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[65,13]}},{"comments":null,"title":"semiringProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[67,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[71,15]}},{"comments":null,"title":"semiringProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[73,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[77,16]}},{"comments":null,"title":"semiringProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[79,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[83,16]}},{"comments":null,"title":"semiringRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"SemiringRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[85,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[89,63]}}],"comments":"The `Semiring` class is for types that support an addition and\nmultiplication operation.\n\nInstances must satisfy the following laws:\n\n- Commutative monoid under addition:\n - Associativity: `(a + b) + c = a + (b + c)`\n - Identity: `zero + a = a + zero = a`\n - Commutative: `a + b = b + a`\n- Monoid under multiplication:\n - Associativity: `(a * b) * c = a * (b * c)`\n - Identity: `one * a = a * one = a`\n- Multiplication distributes over addition:\n - Left distributivity: `a * (b + c) = (a * b) + (a * c)`\n - Right distributivity: `(a + b) * c = (a * c) + (b * c)`\n- Annihilation: `zero * a = a * zero = zero`\n\n**Note:** The `Number` and `Int` types are not fully law abiding\nmembers of this class hierarchy due to the potential for arithmetic\noverflows, and in the case of `Number`, the presence of `NaN` and\n`Infinity` values. The behaviour is unspecified in these cases.\n","title":"Semiring","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[38,12]}},{"children":[],"comments":null,"title":"(+)","info":{"declType":"alias","alias":[["Data","Semiring"],{"Right":{"Left":{"Ident":"add"}}}],"fixity":{"associativity":"infixl","precedence":6}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[40,18]}},{"children":[],"comments":null,"title":"(*)","info":{"declType":"alias","alias":[["Data","Semiring"],{"Right":{"Left":{"Ident":"mul"}}}],"fixity":{"associativity":"infixl","precedence":7}},"sourceSpan":{"start":[41,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[41,18]}}]}],"name":"Data.CommutativeRing","comments":null,"declarations":[{"children":[{"comments":null,"title":"commutativeRingInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[25,51]}},{"comments":null,"title":"commutativeRingNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[26,57]}},{"comments":null,"title":"commutativeRingUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[27,53]}},{"comments":null,"title":"commutativeRingFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","CommutativeRing"],"CommutativeRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[28,76]}},{"comments":null,"title":"commutativeRingRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","CommutativeRing"],"CommutativeRingRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[29,126]}},{"comments":null,"title":"commutativeRingProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[30,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[30,59]}},{"comments":null,"title":"commutativeRingProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[31,61]}},{"comments":null,"title":"commutativeRingProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[32,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[32,61]}}],"comments":"The `CommutativeRing` class is for rings where multiplication is\ncommutative.\n\nInstances must satisfy the following law in addition to the `Ring`\nlaws:\n\n- Commutative multiplication: `a * b = b * a`\n","title":"CommutativeRing","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[23,34]}},{"children":[{"comments":null,"title":"commutativeRingRecordNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRingRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"REmpty"}]}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[38,73]}},{"comments":null,"title":"commutativeRingRecordCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","CommutativeRing"],"CommutativeRingRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","CommutativeRing"],"CommutativeRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRingRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[46,72]}}],"comments":"A class for records where all fields have `CommutativeRing` instances, used\nto implement the `CommutativeRing` instance for records.\n","title":"CommutativeRingRecord","info":{"fundeps":[[["rowlist"],["subrow"]]],"arguments":[["rowlist",null],["row",null],["subrow",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"RingRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlist"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[36,100]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Data","Ring"]},"declarations":[{"children":[{"comments":null,"title":"sub","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[24,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[24,21]}},{"comments":null,"title":"ringInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[29,15]}},{"comments":null,"title":"ringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[32,15]}},{"comments":null,"title":"ringUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[35,17]}},{"comments":null,"title":"ringFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[37,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[38,24]}},{"comments":null,"title":"ringProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[41,18]}},{"comments":null,"title":"ringProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[44,19]}},{"comments":null,"title":"ringProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[47,19]}},{"comments":null,"title":"ringRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ring"],"RingRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[50,40]}}],"comments":"The `Ring` class is for types that support addition, multiplication,\nand subtraction operations.\n\nInstances must satisfy the following laws in addition to the `Semiring`\nlaws:\n\n- Additive inverse: `a - a = zero`\n- Compatibility of `sub` and `negate`: `a - b = a + (zero - b)`\n","title":"Ring","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[24,21]}},{"children":[],"comments":"`negate x` can be used as a shorthand for `zero - x`.\n","title":"negate","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[53,37]}}]},{"moduleName":{"package":null,"item":["Data","Semiring"]},"declarations":[{"children":[{"comments":null,"title":"add","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[35,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[35,22]}},{"comments":null,"title":"zero","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[36,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[36,12]}},{"comments":null,"title":"mul","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[37,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[37,22]}},{"comments":null,"title":"one","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[38,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[38,12]}},{"comments":null,"title":"semiringInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[47,10]}},{"comments":null,"title":"semiringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[53,12]}},{"comments":null,"title":"semiringFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[55,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[59,18]}},{"comments":null,"title":"semiringUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[65,13]}},{"comments":null,"title":"semiringProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[67,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[71,15]}},{"comments":null,"title":"semiringProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[73,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[77,16]}},{"comments":null,"title":"semiringProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[79,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[83,16]}},{"comments":null,"title":"semiringRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"SemiringRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[85,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[89,63]}}],"comments":"The `Semiring` class is for types that support an addition and\nmultiplication operation.\n\nInstances must satisfy the following laws:\n\n- Commutative monoid under addition:\n - Associativity: `(a + b) + c = a + (b + c)`\n - Identity: `zero + a = a + zero = a`\n - Commutative: `a + b = b + a`\n- Monoid under multiplication:\n - Associativity: `(a * b) * c = a * (b * c)`\n - Identity: `one * a = a * one = a`\n- Multiplication distributes over addition:\n - Left distributivity: `a * (b + c) = (a * b) + (a * c)`\n - Right distributivity: `(a + b) * c = (a * c) + (b * c)`\n- Annihilation: `zero * a = a * zero = zero`\n\n**Note:** The `Number` and `Int` types are not fully law abiding\nmembers of this class hierarchy due to the potential for arithmetic\noverflows, and in the case of `Number`, the presence of `NaN` and\n`Infinity` values. The behaviour is unspecified in these cases.\n","title":"Semiring","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[38,12]}},{"children":[],"comments":null,"title":"(+)","info":{"declType":"alias","alias":[["Data","Semiring"],{"Right":{"Left":{"Ident":"add"}}}],"fixity":{"associativity":"infixl","precedence":6}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[40,18]}},{"children":[],"comments":null,"title":"(*)","info":{"declType":"alias","alias":[["Data","Semiring"],{"Right":{"Left":{"Ident":"mul"}}}],"fixity":{"associativity":"infixl","precedence":7}},"sourceSpan":{"start":[41,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[41,18]}}]}],"name":"Data.DivisionRing","comments":null,"declarations":[{"children":[{"comments":null,"title":"recip","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}},"sourceSpan":{"start":[30,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/DivisionRing.purs","end":[30,18]}},{"comments":null,"title":"divisionringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","DivisionRing"],"DivisionRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[54,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/DivisionRing.purs","end":[55,20]}}],"comments":"The `DivisionRing` class is for non-zero rings in which every non-zero\nelement has a multiplicative inverse. Division rings are sometimes also\ncalled *skew fields*.\n\nInstances must satisfy the following laws in addition to the `Ring` laws:\n\n- Non-zero ring: `one /= zero`\n- Non-zero multiplicative inverse: `recip a * a = a * recip a = one` for\n all non-zero `a`\n\nThe result of `recip zero` is left undefined; individual instances may\nchoose how to handle this case.\n\nIf a type has both `DivisionRing` and `CommutativeRing` instances, then\nit is a field and should have a `Field` instance.\n","title":"DivisionRing","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/DivisionRing.purs","end":[30,18]}},{"children":[],"comments":"Left division, defined as `leftDiv a b = recip b * a`. Left and right\ndivision are distinct in this module because a `DivisionRing` is not\nnecessarily commutative.\n\nIf the type `a` is also a `EuclideanRing`, then this function is\nequivalent to `div` from the `EuclideanRing` class. When working\nabstractly, `div` should generally be preferred, unless you know that you\nneed your code to work with noncommutative rings.\n","title":"leftDiv","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","DivisionRing"],"DivisionRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]},null]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/DivisionRing.purs","end":[40,51]}},{"children":[],"comments":"Right division, defined as `rightDiv a b = a * recip b`. Left and right\ndivision are distinct in this module because a `DivisionRing` is not\nnecessarily commutative.\n\nIf the type `a` is also a `EuclideanRing`, then this function is\nequivalent to `div` from the `EuclideanRing` class. When working\nabstractly, `div` should generally be preferred, unless you know that you\nneed your code to work with noncommutative rings.\n","title":"rightDiv","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","DivisionRing"],"DivisionRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]},null]}},"sourceSpan":{"start":[51,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/DivisionRing.purs","end":[51,52]}}]},{"reExports":[],"name":"Data.Eq","comments":null,"declarations":[{"children":[{"comments":null,"title":"eq","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}},"sourceSpan":{"start":[29,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[29,26]}},{"comments":null,"title":"eqBoolean","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[41,21]}},{"comments":null,"title":"eqInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[44,17]}},{"comments":null,"title":"eqNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[47,20]}},{"comments":null,"title":"eqChar","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Char"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[50,18]}},{"comments":null,"title":"eqString","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[52,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[53,20]}},{"comments":null,"title":"eqUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[55,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[56,16]}},{"comments":null,"title":"eqVoid","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Void"],"Void"]}]}},"sourceSpan":{"start":[58,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[59,16]}},{"comments":null,"title":"eqArray","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[62,22]}},{"comments":null,"title":"eqRec","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Eq"],"EqRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[64,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[65,38]}},{"comments":null,"title":"eqProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[67,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[68,16]}},{"comments":null,"title":"eqProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[70,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[71,16]}},{"comments":null,"title":"eqProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[73,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[74,16]}}],"comments":"The `Eq` type class represents types which support decidable equality.\n\n`Eq` instances should satisfy the following laws:\n\n- Reflexivity: `x == x = true`\n- Symmetry: `x == y = y == x`\n- Transitivity: if `x == y` and `y == z` then `x == z`\n\n**Note:** The `Number` type is not an entirely law abiding member of this\nclass due to the presence of `NaN`, since `NaN /= NaN`. Additionally,\ncomputing with `Number` can result in a loss of precision, so sometimes\nvalues that should be equivalent are not.\n","title":"Eq","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[29,26]}},{"children":[],"comments":null,"title":"(==)","info":{"declType":"alias","alias":[["Data","Eq"],{"Right":{"Left":{"Ident":"eq"}}}],"fixity":{"associativity":"infix","precedence":4}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[31,17]}},{"children":[],"comments":"`notEq` tests whether one value is _not equal_ to another. Shorthand for\n`not (eq x y)`.\n","title":"notEq","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}]},null]}},"sourceSpan":{"start":[35,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[35,45]}},{"children":[],"comments":null,"title":"(/=)","info":{"declType":"alias","alias":[["Data","Eq"],{"Right":{"Left":{"Ident":"notEq"}}}],"fixity":{"associativity":"infix","precedence":4}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[38,20]}},{"children":[{"comments":null,"title":"eq1","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}]},null]}},"sourceSpan":{"start":[86,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[86,49]}},{"comments":null,"title":"eq1Array","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[88,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[89,11]}}],"comments":"The `Eq1` type class represents type constructors with decidable equality.\n","title":"Eq1","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[85,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[86,49]}},{"children":[],"comments":null,"title":"notEq1","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq1"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}]}]},null]},null]}},"sourceSpan":{"start":[91,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[91,61]}},{"children":[{"comments":null,"title":"eqRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}]},null]}},"sourceSpan":{"start":[98,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[98,85]}},{"comments":null,"title":"eqRowNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"EqRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}},"sourceSpan":{"start":[100,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[101,24]}},{"comments":null,"title":"eqRowCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"EqRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"rowTail"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"EqRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}},"sourceSpan":{"start":[103,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[114,57]}}],"comments":null,"title":"EqRecord","info":{"fundeps":[],"arguments":[["rowlist",null],["row",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[97,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[98,85]}}]},{"reExports":[],"name":"Data.Eq.Generic","comments":null,"declarations":[{"children":[{"comments":null,"title":"genericEq'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}},"sourceSpan":{"start":[11,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq/Generic.purs","end":[11,34]}},{"comments":null,"title":"genericEqNoConstructors","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq","Generic"],"GenericEq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoConstructors"]}]}},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq/Generic.purs","end":[14,24]}},{"comments":null,"title":"genericEqNoArguments","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq","Generic"],"GenericEq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoArguments"]}]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq/Generic.purs","end":[17,24]}},{"comments":null,"title":"genericEqSum","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq","Generic"],"GenericEq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Eq","Generic"],"GenericEq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq","Generic"],"GenericEq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Sum"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq/Generic.purs","end":[22,25]}},{"comments":null,"title":"genericEqProduct","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq","Generic"],"GenericEq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Eq","Generic"],"GenericEq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq","Generic"],"GenericEq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Product"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[24,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq/Generic.purs","end":[25,84]}},{"comments":null,"title":"genericEqConstructor","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq","Generic"],"GenericEq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq","Generic"],"GenericEq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Constructor"]},{"annotation":[],"tag":"TypeVar","contents":"name"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq/Generic.purs","end":[28,66]}},{"comments":null,"title":"genericEqArgument","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq","Generic"],"GenericEq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Argument"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[30,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq/Generic.purs","end":[31,52]}}],"comments":null,"title":"GenericEq","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[10,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq/Generic.purs","end":[11,34]}},{"children":[],"comments":"A `Generic` implementation of the `eq` member from the `Eq` type class.\n","title":"genericEq","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Eq","Generic"],"GenericEq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}]}]},null]},null]}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq/Generic.purs","end":[34,79]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Data","CommutativeRing"]},"declarations":[{"children":[{"comments":null,"title":"commutativeRingInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[25,51]}},{"comments":null,"title":"commutativeRingNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[26,57]}},{"comments":null,"title":"commutativeRingUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[27,53]}},{"comments":null,"title":"commutativeRingFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","CommutativeRing"],"CommutativeRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[28,76]}},{"comments":null,"title":"commutativeRingRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","CommutativeRing"],"CommutativeRingRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[29,126]}},{"comments":null,"title":"commutativeRingProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[30,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[30,59]}},{"comments":null,"title":"commutativeRingProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[31,61]}},{"comments":null,"title":"commutativeRingProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[32,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[32,61]}}],"comments":"The `CommutativeRing` class is for rings where multiplication is\ncommutative.\n\nInstances must satisfy the following law in addition to the `Ring`\nlaws:\n\n- Commutative multiplication: `a * b = b * a`\n","title":"CommutativeRing","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[23,34]}}]},{"moduleName":{"package":null,"item":["Data","Ring"]},"declarations":[{"children":[{"comments":null,"title":"sub","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[24,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[24,21]}},{"comments":null,"title":"ringInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[29,15]}},{"comments":null,"title":"ringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[32,15]}},{"comments":null,"title":"ringUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[35,17]}},{"comments":null,"title":"ringFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[37,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[38,24]}},{"comments":null,"title":"ringProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[41,18]}},{"comments":null,"title":"ringProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[44,19]}},{"comments":null,"title":"ringProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[47,19]}},{"comments":null,"title":"ringRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ring"],"RingRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[50,40]}}],"comments":"The `Ring` class is for types that support addition, multiplication,\nand subtraction operations.\n\nInstances must satisfy the following laws in addition to the `Semiring`\nlaws:\n\n- Additive inverse: `a - a = zero`\n- Compatibility of `sub` and `negate`: `a - b = a + (zero - b)`\n","title":"Ring","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[24,21]}},{"children":[],"comments":null,"title":"(-)","info":{"declType":"alias","alias":[["Data","Ring"],{"Right":{"Left":{"Ident":"sub"}}}],"fixity":{"associativity":"infixl","precedence":6}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[26,18]}}]},{"moduleName":{"package":null,"item":["Data","Semiring"]},"declarations":[{"children":[{"comments":null,"title":"add","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[35,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[35,22]}},{"comments":null,"title":"zero","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[36,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[36,12]}},{"comments":null,"title":"mul","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[37,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[37,22]}},{"comments":null,"title":"one","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[38,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[38,12]}},{"comments":null,"title":"semiringInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[47,10]}},{"comments":null,"title":"semiringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[53,12]}},{"comments":null,"title":"semiringFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[55,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[59,18]}},{"comments":null,"title":"semiringUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[65,13]}},{"comments":null,"title":"semiringProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[67,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[71,15]}},{"comments":null,"title":"semiringProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[73,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[77,16]}},{"comments":null,"title":"semiringProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[79,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[83,16]}},{"comments":null,"title":"semiringRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"SemiringRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[85,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[89,63]}}],"comments":"The `Semiring` class is for types that support an addition and\nmultiplication operation.\n\nInstances must satisfy the following laws:\n\n- Commutative monoid under addition:\n - Associativity: `(a + b) + c = a + (b + c)`\n - Identity: `zero + a = a + zero = a`\n - Commutative: `a + b = b + a`\n- Monoid under multiplication:\n - Associativity: `(a * b) * c = a * (b * c)`\n - Identity: `one * a = a * one = a`\n- Multiplication distributes over addition:\n - Left distributivity: `a * (b + c) = (a * b) + (a * c)`\n - Right distributivity: `(a + b) * c = (a * c) + (b * c)`\n- Annihilation: `zero * a = a * zero = zero`\n\n**Note:** The `Number` and `Int` types are not fully law abiding\nmembers of this class hierarchy due to the potential for arithmetic\noverflows, and in the case of `Number`, the presence of `NaN` and\n`Infinity` values. The behaviour is unspecified in these cases.\n","title":"Semiring","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[38,12]}},{"children":[],"comments":null,"title":"(+)","info":{"declType":"alias","alias":[["Data","Semiring"],{"Right":{"Left":{"Ident":"add"}}}],"fixity":{"associativity":"infixl","precedence":6}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[40,18]}},{"children":[],"comments":null,"title":"(*)","info":{"declType":"alias","alias":[["Data","Semiring"],{"Right":{"Left":{"Ident":"mul"}}}],"fixity":{"associativity":"infixl","precedence":7}},"sourceSpan":{"start":[41,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[41,18]}}]}],"name":"Data.EuclideanRing","comments":null,"declarations":[{"children":[{"comments":null,"title":"degree","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[64,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[64,21]}},{"comments":null,"title":"div","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[65,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[65,21]}},{"comments":null,"title":"mod","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[66,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[66,21]}},{"comments":null,"title":"euclideanRingInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","EuclideanRing"],"EuclideanRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[70,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[73,15]}},{"comments":null,"title":"euclideanRingNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","EuclideanRing"],"EuclideanRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[75,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[78,16]}}],"comments":"The `EuclideanRing` class is for commutative rings that support division.\nThe mathematical structure this class is based on is sometimes also called\na *Euclidean domain*.\n\nInstances must satisfy the following laws in addition to the `Ring`\nlaws:\n\n- Integral domain: `one /= zero`, and if `a` and `b` are both nonzero then\n so is their product `a * b`\n- Euclidean function `degree`:\n - Nonnegativity: For all nonzero `a`, `degree a >= 0`\n - Quotient/remainder: For all `a` and `b`, where `b` is nonzero,\n let `q = a / b` and ``r = a `mod` b``; then `a = q*b + r`, and also\n either `r = zero` or `degree r < degree b`\n- Submultiplicative euclidean function:\n - For all nonzero `a` and `b`, `degree a <= degree (a * b)`\n\nThe behaviour of division by `zero` is unconstrained by these laws,\nmeaning that individual instances are free to choose how to behave in this\ncase. Similarly, there are no restrictions on what the result of\n`degree zero` is; it doesn't make sense to ask for `degree zero` in the\nsame way that it doesn't make sense to divide by `zero`, so again,\nindividual instances may choose how to handle this case.\n\nFor any `EuclideanRing` which is also a `Field`, one valid choice\nfor `degree` is simply `const 1`. In fact, unless there's a specific\nreason not to, `Field` types should normally use this definition of\n`degree`.\n\nThe `EuclideanRing Int` instance is one of the most commonly used\n`EuclideanRing` instances and deserves a little more discussion. In\nparticular, there are a few different sensible law-abiding implementations\nto choose from, with slightly different behaviour in the presence of\nnegative dividends or divisors. The most common definitions are \"truncating\"\ndivision, where the result of `a / b` is rounded towards 0, and \"Knuthian\"\nor \"flooring\" division, where the result of `a / b` is rounded towards\nnegative infinity. A slightly less common, but arguably more useful, option\nis \"Euclidean\" division, which is defined so as to ensure that ``a `mod` b``\nis always nonnegative. With Euclidean division, `a / b` rounds towards\nnegative infinity if the divisor is positive, and towards positive infinity\nif the divisor is negative. Note that all three definitions are identical if\nwe restrict our attention to nonnegative dividends and divisors.\n\nIn versions 1.x, 2.x, and 3.x of the Prelude, the `EuclideanRing Int`\ninstance used truncating division. As of 4.x, the `EuclideanRing Int`\ninstance uses Euclidean division. Additional functions `quot` and `rem` are\nsupplied if truncating division is desired.\n","title":"EuclideanRing","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","CommutativeRing"],"CommutativeRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[63,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[66,21]}},{"children":[],"comments":null,"title":"(/)","info":{"declType":"alias","alias":[["Data","EuclideanRing"],{"Right":{"Left":{"Ident":"div"}}}],"fixity":{"associativity":"infixl","precedence":7}},"sourceSpan":{"start":[68,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[68,18]}},{"children":[],"comments":"The *greatest common divisor* of two values.\n","title":"gcd","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","EuclideanRing"],"EuclideanRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]}},"sourceSpan":{"start":[87,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[87,56]}},{"children":[],"comments":"The *least common multiple* of two values.\n","title":"lcm","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","EuclideanRing"],"EuclideanRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]}},"sourceSpan":{"start":[94,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[94,56]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Data","CommutativeRing"]},"declarations":[{"children":[{"comments":null,"title":"commutativeRingInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[25,51]}},{"comments":null,"title":"commutativeRingNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[26,57]}},{"comments":null,"title":"commutativeRingUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[27,53]}},{"comments":null,"title":"commutativeRingFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","CommutativeRing"],"CommutativeRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[28,76]}},{"comments":null,"title":"commutativeRingRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","CommutativeRing"],"CommutativeRingRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[29,126]}},{"comments":null,"title":"commutativeRingProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[30,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[30,59]}},{"comments":null,"title":"commutativeRingProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[31,61]}},{"comments":null,"title":"commutativeRingProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[32,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[32,61]}}],"comments":"The `CommutativeRing` class is for rings where multiplication is\ncommutative.\n\nInstances must satisfy the following law in addition to the `Ring`\nlaws:\n\n- Commutative multiplication: `a * b = b * a`\n","title":"CommutativeRing","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[23,34]}}]},{"moduleName":{"package":null,"item":["Data","DivisionRing"]},"declarations":[{"children":[{"comments":null,"title":"recip","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}},"sourceSpan":{"start":[30,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/DivisionRing.purs","end":[30,18]}},{"comments":null,"title":"divisionringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","DivisionRing"],"DivisionRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[54,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/DivisionRing.purs","end":[55,20]}}],"comments":"The `DivisionRing` class is for non-zero rings in which every non-zero\nelement has a multiplicative inverse. Division rings are sometimes also\ncalled *skew fields*.\n\nInstances must satisfy the following laws in addition to the `Ring` laws:\n\n- Non-zero ring: `one /= zero`\n- Non-zero multiplicative inverse: `recip a * a = a * recip a = one` for\n all non-zero `a`\n\nThe result of `recip zero` is left undefined; individual instances may\nchoose how to handle this case.\n\nIf a type has both `DivisionRing` and `CommutativeRing` instances, then\nit is a field and should have a `Field` instance.\n","title":"DivisionRing","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/DivisionRing.purs","end":[30,18]}}]},{"moduleName":{"package":null,"item":["Data","EuclideanRing"]},"declarations":[{"children":[{"comments":null,"title":"degree","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[64,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[64,21]}},{"comments":null,"title":"div","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[65,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[65,21]}},{"comments":null,"title":"mod","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[66,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[66,21]}},{"comments":null,"title":"euclideanRingInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","EuclideanRing"],"EuclideanRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[70,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[73,15]}},{"comments":null,"title":"euclideanRingNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","EuclideanRing"],"EuclideanRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[75,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[78,16]}}],"comments":"The `EuclideanRing` class is for commutative rings that support division.\nThe mathematical structure this class is based on is sometimes also called\na *Euclidean domain*.\n\nInstances must satisfy the following laws in addition to the `Ring`\nlaws:\n\n- Integral domain: `one /= zero`, and if `a` and `b` are both nonzero then\n so is their product `a * b`\n- Euclidean function `degree`:\n - Nonnegativity: For all nonzero `a`, `degree a >= 0`\n - Quotient/remainder: For all `a` and `b`, where `b` is nonzero,\n let `q = a / b` and ``r = a `mod` b``; then `a = q*b + r`, and also\n either `r = zero` or `degree r < degree b`\n- Submultiplicative euclidean function:\n - For all nonzero `a` and `b`, `degree a <= degree (a * b)`\n\nThe behaviour of division by `zero` is unconstrained by these laws,\nmeaning that individual instances are free to choose how to behave in this\ncase. Similarly, there are no restrictions on what the result of\n`degree zero` is; it doesn't make sense to ask for `degree zero` in the\nsame way that it doesn't make sense to divide by `zero`, so again,\nindividual instances may choose how to handle this case.\n\nFor any `EuclideanRing` which is also a `Field`, one valid choice\nfor `degree` is simply `const 1`. In fact, unless there's a specific\nreason not to, `Field` types should normally use this definition of\n`degree`.\n\nThe `EuclideanRing Int` instance is one of the most commonly used\n`EuclideanRing` instances and deserves a little more discussion. In\nparticular, there are a few different sensible law-abiding implementations\nto choose from, with slightly different behaviour in the presence of\nnegative dividends or divisors. The most common definitions are \"truncating\"\ndivision, where the result of `a / b` is rounded towards 0, and \"Knuthian\"\nor \"flooring\" division, where the result of `a / b` is rounded towards\nnegative infinity. A slightly less common, but arguably more useful, option\nis \"Euclidean\" division, which is defined so as to ensure that ``a `mod` b``\nis always nonnegative. With Euclidean division, `a / b` rounds towards\nnegative infinity if the divisor is positive, and towards positive infinity\nif the divisor is negative. Note that all three definitions are identical if\nwe restrict our attention to nonnegative dividends and divisors.\n\nIn versions 1.x, 2.x, and 3.x of the Prelude, the `EuclideanRing Int`\ninstance used truncating division. As of 4.x, the `EuclideanRing Int`\ninstance uses Euclidean division. Additional functions `quot` and `rem` are\nsupplied if truncating division is desired.\n","title":"EuclideanRing","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","CommutativeRing"],"CommutativeRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[63,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[66,21]}},{"children":[],"comments":"The *least common multiple* of two values.\n","title":"lcm","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","EuclideanRing"],"EuclideanRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]}},"sourceSpan":{"start":[94,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[94,56]}},{"children":[],"comments":"The *greatest common divisor* of two values.\n","title":"gcd","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","EuclideanRing"],"EuclideanRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]}},"sourceSpan":{"start":[87,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[87,56]}},{"children":[],"comments":null,"title":"(/)","info":{"declType":"alias","alias":[["Data","EuclideanRing"],{"Right":{"Left":{"Ident":"div"}}}],"fixity":{"associativity":"infixl","precedence":7}},"sourceSpan":{"start":[68,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[68,18]}}]},{"moduleName":{"package":null,"item":["Data","Ring"]},"declarations":[{"children":[{"comments":null,"title":"sub","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[24,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[24,21]}},{"comments":null,"title":"ringInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[29,15]}},{"comments":null,"title":"ringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[32,15]}},{"comments":null,"title":"ringUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[35,17]}},{"comments":null,"title":"ringFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[37,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[38,24]}},{"comments":null,"title":"ringProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[41,18]}},{"comments":null,"title":"ringProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[44,19]}},{"comments":null,"title":"ringProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[47,19]}},{"comments":null,"title":"ringRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ring"],"RingRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[50,40]}}],"comments":"The `Ring` class is for types that support addition, multiplication,\nand subtraction operations.\n\nInstances must satisfy the following laws in addition to the `Semiring`\nlaws:\n\n- Additive inverse: `a - a = zero`\n- Compatibility of `sub` and `negate`: `a - b = a + (zero - b)`\n","title":"Ring","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[24,21]}},{"children":[],"comments":"`negate x` can be used as a shorthand for `zero - x`.\n","title":"negate","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[53,37]}}]},{"moduleName":{"package":null,"item":["Data","Semiring"]},"declarations":[{"children":[{"comments":null,"title":"add","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[35,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[35,22]}},{"comments":null,"title":"zero","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[36,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[36,12]}},{"comments":null,"title":"mul","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[37,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[37,22]}},{"comments":null,"title":"one","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[38,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[38,12]}},{"comments":null,"title":"semiringInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[47,10]}},{"comments":null,"title":"semiringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[53,12]}},{"comments":null,"title":"semiringFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[55,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[59,18]}},{"comments":null,"title":"semiringUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[65,13]}},{"comments":null,"title":"semiringProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[67,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[71,15]}},{"comments":null,"title":"semiringProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[73,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[77,16]}},{"comments":null,"title":"semiringProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[79,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[83,16]}},{"comments":null,"title":"semiringRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"SemiringRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[85,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[89,63]}}],"comments":"The `Semiring` class is for types that support an addition and\nmultiplication operation.\n\nInstances must satisfy the following laws:\n\n- Commutative monoid under addition:\n - Associativity: `(a + b) + c = a + (b + c)`\n - Identity: `zero + a = a + zero = a`\n - Commutative: `a + b = b + a`\n- Monoid under multiplication:\n - Associativity: `(a * b) * c = a * (b * c)`\n - Identity: `one * a = a * one = a`\n- Multiplication distributes over addition:\n - Left distributivity: `a * (b + c) = (a * b) + (a * c)`\n - Right distributivity: `(a + b) * c = (a * c) + (b * c)`\n- Annihilation: `zero * a = a * zero = zero`\n\n**Note:** The `Number` and `Int` types are not fully law abiding\nmembers of this class hierarchy due to the potential for arithmetic\noverflows, and in the case of `Number`, the presence of `NaN` and\n`Infinity` values. The behaviour is unspecified in these cases.\n","title":"Semiring","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[38,12]}},{"children":[],"comments":null,"title":"(+)","info":{"declType":"alias","alias":[["Data","Semiring"],{"Right":{"Left":{"Ident":"add"}}}],"fixity":{"associativity":"infixl","precedence":6}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[40,18]}},{"children":[],"comments":null,"title":"(*)","info":{"declType":"alias","alias":[["Data","Semiring"],{"Right":{"Left":{"Ident":"mul"}}}],"fixity":{"associativity":"infixl","precedence":7}},"sourceSpan":{"start":[41,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[41,18]}}]}],"name":"Data.Field","comments":null,"declarations":[{"children":[{"comments":null,"title":"field","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","EuclideanRing"],"EuclideanRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","DivisionRing"],"DivisionRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Field"],"Field"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}},"sourceSpan":{"start":[41,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Field.purs","end":[41,63]}}],"comments":"The `Field` class is for types that are (commutative) fields.\n\nMathematically, a field is a ring which is commutative and in which every\nnonzero element has a multiplicative inverse; these conditions correspond\nto the `CommutativeRing` and `DivisionRing` classes in PureScript\nrespectively. However, the `Field` class has `EuclideanRing` and\n`DivisionRing` as superclasses, which seems like a stronger requirement\n(since `CommutativeRing` is a superclass of `EuclideanRing`). In fact, it\nis not stronger, since any type which has law-abiding `CommutativeRing`\nand `DivisionRing` instances permits exactly one law-abiding\n`EuclideanRing` instance. We use a `EuclideanRing` superclass here in\norder to ensure that a `Field` constraint on a function permits you to use\n`div` on that type, since `div` is a member of `EuclideanRing`.\n\nThis class has no laws or members of its own; it exists as a convenience,\nso a single constraint can be used when field-like behaviour is expected.\n\nThis module also defines a single `Field` instance for any type which has\nboth `EuclideanRing` and `DivisionRing` instances. Any other instance\nwould overlap with this instance, so no other `Field` instances should be\ndefined in libraries. Instead, simply define `EuclideanRing` and\n`DivisionRing` instances, and this will permit your type to be used with a\n`Field` constraint.\n","title":"Field","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","EuclideanRing"],"EuclideanRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","DivisionRing"],"DivisionRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Field.purs","end":[39,51]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Control","Category"]},"declarations":[{"children":[],"comments":null,"title":"compose","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["c",{"annotation":[],"tag":"ForAll","contents":["d",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[null,"Semigroupoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"c"}]},{"annotation":[],"tag":"TypeVar","contents":"d"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"d"}]}]}]}]},null]},null]},null]},null]}},"sourceSpan":{"start":[14,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[14,51]}},{"children":[],"comments":null,"title":"identity","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["t",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[null,"Category"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"t"}]},{"annotation":[],"tag":"TypeVar","contents":"t"}]}]},null]},null]}},"sourceSpan":{"start":[18,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Category.purs","end":[18,30]}},{"children":[],"comments":null,"title":"(>>>)","info":{"declType":"alias","alias":[["Control","Semigroupoid"],{"Right":{"Left":{"Ident":"composeFlipped"}}}],"fixity":{"associativity":"infixr","precedence":9}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[25,31]}},{"children":[],"comments":null,"title":"(<<<)","info":{"declType":"alias","alias":[["Control","Semigroupoid"],{"Right":{"Left":{"Ident":"compose"}}}],"fixity":{"associativity":"infixr","precedence":9}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[19,24]}}]}],"name":"Data.Function","comments":null,"declarations":[{"children":[],"comments":"Flips the order of the arguments to a function of two arguments.\n\n```purescript\nflip const 1 2 = const 2 1 = 2\n```\n","title":"flip","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["c",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[21,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Function.purs","end":[21,51]}},{"children":[],"comments":"Returns its first argument and ignores its second.\n\n```purescript\nconst 1 \"hello\" = 1\n```\n\nIt can also be thought of as creating a function that ignores its argument:\n\n```purescript\nconst 1 = \\_ -> 1\n```\n","title":"const","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]},null]}},"sourceSpan":{"start":[35,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Function.purs","end":[35,33]}},{"children":[],"comments":"Applies a function to an argument. This is primarily used as the operator\n`($)` which allows parentheses to be omitted in some cases, or as a\nnatural way to apply a chain of composed functions to a value.\n","title":"apply","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]},null]},null]}},"sourceSpan":{"start":[41,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Function.purs","end":[41,40]}},{"children":[],"comments":"Applies a function to an argument: the reverse of `(#)`.\n\n```purescript\nlength $ groupBy productCategory $ filter isInStock $ products\n```\n\nis equivalent to:\n\n```purescript\nlength (groupBy productCategory (filter isInStock products))\n```\n\nOr another alternative equivalent, applying chain of composed functions to\na value:\n\n```purescript\nlength <<< groupBy productCategory <<< filter isInStock $ products\n```\n","title":"($)","info":{"declType":"alias","alias":[["Data","Function"],{"Right":{"Left":{"Ident":"apply"}}}],"fixity":{"associativity":"infixr","precedence":0}},"sourceSpan":{"start":[62,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Function.purs","end":[62,20]}},{"children":[],"comments":"Applies an argument to a function. This is primarily used as the `(#)`\noperator, which allows parentheses to be omitted in some cases, or as a\nnatural way to apply a value to a chain of composed functions.\n","title":"applyFlipped","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]},null]},null]}},"sourceSpan":{"start":[67,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Function.purs","end":[67,47]}},{"children":[],"comments":"Applies an argument to a function: the reverse of `($)`.\n\n```purescript\nproducts # filter isInStock # groupBy productCategory # length\n```\n\nis equivalent to:\n\n```purescript\nlength (groupBy productCategory (filter isInStock products))\n```\n\nOr another alternative equivalent, applying a value to a chain of composed\nfunctions:\n\n```purescript\nproducts # filter isInStock >>> groupBy productCategory >>> length\n```\n","title":"(#)","info":{"declType":"alias","alias":[["Data","Function"],{"Right":{"Left":{"Ident":"applyFlipped"}}}],"fixity":{"associativity":"infixl","precedence":1}},"sourceSpan":{"start":[88,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Function.purs","end":[88,27]}},{"children":[],"comments":"`applyN f n` applies the function `f` to its argument `n` times.\n\nIf n is less than or equal to 0, the function is not applied.\n\n```purescript\napplyN (_ + 1) 10 0 == 10\n```\n","title":"applyN","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]},null]}},"sourceSpan":{"start":[97,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Function.purs","end":[97,46]}},{"children":[],"comments":"The `on` function is used to change the domain of a binary operator.\n\nFor example, we can create a function which compares two records based on the values of their `x` properties:\n\n```purescript\ncompareX :: forall r. { x :: Number | r } -> { x :: Number | r } -> Ordering\ncompareX = compare `on` _.x\n```\n","title":"on","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["c",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[112,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Function.purs","end":[112,61]}}]},{"reExports":[],"name":"Data.Functor","comments":null,"declarations":[{"children":[{"comments":null,"title":"map","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]},null]},null]}},"sourceSpan":{"start":[26,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[26,44]}},{"comments":null,"title":"functorFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[41,16]}},{"comments":null,"title":"functorArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[44,17]}},{"comments":null,"title":"functorProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[47,18]}}],"comments":"A `Functor` is a type constructor which supports a mapping operation\n`map`.\n\n`map` can be used to turn functions `a -> b` into functions\n`f a -> f b` whose argument and return types use the type constructor `f`\nto represent some computational context.\n\nInstances must satisfy the following laws:\n\n- Identity: `map identity = identity`\n- Composition: `map (f <<< g) = map f <<< map g`\n","title":"Functor","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[26,44]}},{"children":[],"comments":null,"title":"(<$>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"map"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[28,20]}},{"children":[],"comments":"`mapFlipped` is `map` with its arguments reversed. For example:\n\n```purescript\n[1, 2, 3] <#> \\n -> n * n\n```\n","title":"mapFlipped","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[35,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[35,64]}},{"children":[],"comments":null,"title":"(<#>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"mapFlipped"}}}],"fixity":{"associativity":"infixl","precedence":1}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[38,27]}},{"children":[],"comments":"The `void` function is used to ignore the type wrapped by a\n[`Functor`](#functor), replacing it with `Unit` and keeping only the type\ninformation provided by the type constructor itself.\n\n`void` is often useful when using `do` notation to change the return type\nof a monadic computation:\n\n```purescript\nmain = forE 1 10 \\n -> void do\n print n\n print (n * n)\n```\n","title":"void","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]},null]},null]}},"sourceSpan":{"start":[63,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[63,47]}},{"children":[],"comments":"Ignore the return value of a computation, using the specified return value\ninstead.\n","title":"voidRight","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[68,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[68,56]}},{"children":[],"comments":null,"title":"(<$)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"voidRight"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[71,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[71,25]}},{"children":[],"comments":"A version of `voidRight` with its arguments flipped.\n","title":"voidLeft","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[74,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[74,55]}},{"children":[],"comments":null,"title":"($>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"voidLeft"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[77,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[77,24]}},{"children":[],"comments":"Apply a value in a computational context to a value in no context.\n\nGeneralizes `flip`.\n\n```purescript\nlongEnough :: String -> Bool\nhasSymbol :: String -> Bool\nhasDigit :: String -> Bool\npassword :: String\n\nvalidate :: String -> Array Bool\nvalidate = flap [longEnough, hasSymbol, hasDigit]\n```\n\n```purescript\nflap (-) 3 4 == 1\nthreeve <$> Just 1 <@> 'a' <*> Just true == Just (threeve 1 'a' true)\n```\n","title":"flap","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[97,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[97,58]}},{"children":[],"comments":null,"title":"(<@>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"flap"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[100,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[100,21]}}]},{"reExports":[],"name":"Data.Generic.Rep","comments":null,"declarations":[{"children":[{"comments":null,"title":"to","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"rep"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}},"sourceSpan":{"start":[57,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[57,17]}},{"comments":null,"title":"from","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"rep"}]}},"sourceSpan":{"start":[58,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[58,19]}}],"comments":"The `Generic` class asserts the existence of a type function from types\nto their representations using the type constructors defined in this module.\n","title":"Generic","info":{"fundeps":[[["a"],["rep"]]],"arguments":[["a",null],["rep",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[56,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[58,19]}},{"children":[],"comments":null,"title":"repOf","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"rep"}]}]}]},null]},null]}},"sourceSpan":{"start":[60,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[60,61]}},{"children":[],"comments":"A representation for types with no constructors.\n","title":"NoConstructors","info":{"declType":"data","dataDeclType":"data","typeArguments":[]},"sourceSpan":{"start":[20,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[20,20]}},{"children":[{"comments":null,"title":"NoArguments","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"showNoArguments","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoArguments"]}]}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[26,25]}}],"comments":"A representation for constructors with no arguments.\n","title":"NoArguments","info":{"declType":"data","dataDeclType":"data","typeArguments":[]},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[23,31]}},{"children":[{"comments":null,"title":"Inl","info":{"arguments":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"Inr","info":{"arguments":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"showSum","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Sum"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[33,42]}}],"comments":"A representation for types with multiple constructors.\n","title":"Sum","info":{"declType":"data","dataDeclType":"data","typeArguments":[["a",null],["b",null]]},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[29,29]}},{"children":[{"comments":null,"title":"Product","info":{"arguments":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"b"}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"showProduct","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Product"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[39,69]}}],"comments":"A representation for constructors with multiple fields.\n","title":"Product","info":{"declType":"data","dataDeclType":"data","typeArguments":[["a",null],["b",null]]},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[36,31]}},{"children":[{"comments":null,"title":"Constructor","info":{"arguments":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"showConstructor","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"name"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Constructor"]},{"annotation":[],"tag":"TypeVar","contents":"name"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[45,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[46,112]}}],"comments":"A representation for constructors which includes the data constructor name\nas a type-level string.\n","title":"Constructor","info":{"declType":"data","dataDeclType":"newtype","typeArguments":[["name",{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Symbol"]}],["a",null]]},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[43,55]}},{"children":[{"comments":null,"title":"Argument","info":{"arguments":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"showArgument","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Argument"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[51,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[52,52]}}],"comments":"A representation for an argument in a data constructor.\n","title":"Argument","info":{"declType":"data","dataDeclType":"newtype","typeArguments":[["a",null]]},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Generic/Rep.purs","end":[49,32]}}]},{"reExports":[],"name":"Data.HeytingAlgebra","comments":null,"declarations":[{"children":[{"comments":null,"title":"ff","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[39,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[39,10]}},{"comments":null,"title":"tt","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[40,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[40,10]}},{"comments":null,"title":"implies","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[41,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[41,25]}},{"comments":null,"title":"conj","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[42,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[42,22]}},{"comments":null,"title":"disj","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[43,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[43,22]}},{"comments":null,"title":"not","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}},"sourceSpan":{"start":[44,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[44,16]}},{"comments":null,"title":"heytingAlgebraBoolean","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[55,16]}},{"comments":null,"title":"heytingAlgebraUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[57,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[63,15]}},{"comments":null,"title":"heytingAlgebraFunction","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[65,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[71,22]}},{"comments":null,"title":"heytingAlgebraProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[73,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[79,13]}},{"comments":null,"title":"heytingAlgebraProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[81,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[87,14]}},{"comments":null,"title":"heytingAlgebraProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[89,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[95,14]}},{"comments":null,"title":"heytingAlgebraRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebraRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[97,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[103,41]}}],"comments":"The `HeytingAlgebra` type class represents types that are bounded lattices with\nan implication operator such that the following laws hold:\n\n- Associativity:\n - `a || (b || c) = (a || b) || c`\n - `a && (b && c) = (a && b) && c`\n- Commutativity:\n - `a || b = b || a`\n - `a && b = b && a`\n- Absorption:\n - `a || (a && b) = a`\n - `a && (a || b) = a`\n- Idempotent:\n - `a || a = a`\n - `a && a = a`\n- Identity:\n - `a || ff = a`\n - `a && tt = a`\n- Implication:\n - ``a `implies` a = tt``\n - ``a && (a `implies` b) = a && b``\n - ``b && (a `implies` b) = b``\n - ``a `implies` (b && c) = (a `implies` b) && (a `implies` c)``\n- Complemented:\n - ``not a = a `implies` ff``\n","title":"HeytingAlgebra","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[44,16]}},{"children":[],"comments":null,"title":"(&&)","info":{"declType":"alias","alias":[["Data","HeytingAlgebra"],{"Right":{"Left":{"Ident":"conj"}}}],"fixity":{"associativity":"infixr","precedence":3}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[46,20]}},{"children":[],"comments":null,"title":"(||)","info":{"declType":"alias","alias":[["Data","HeytingAlgebra"],{"Right":{"Left":{"Ident":"disj"}}}],"fixity":{"associativity":"infixr","precedence":2}},"sourceSpan":{"start":[47,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[47,20]}},{"children":[{"comments":null,"title":"ffRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"ForAll","contents":["rproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rproxy"},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]}]},null]},null]}},"sourceSpan":{"start":[113,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[113,84]}},{"comments":null,"title":"ttRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"ForAll","contents":["rproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rproxy"},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]}]},null]},null]}},"sourceSpan":{"start":[114,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[114,84]}},{"comments":null,"title":"impliesRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]}]}]},null]}},"sourceSpan":{"start":[115,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[115,96]}},{"comments":null,"title":"disjRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]}]}]},null]}},"sourceSpan":{"start":[116,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[116,93]}},{"comments":null,"title":"conjRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]}]}]},null]}},"sourceSpan":{"start":[117,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[117,93]}},{"comments":null,"title":"notRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]}]},null]}},"sourceSpan":{"start":[118,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[118,78]}},{"comments":null,"title":"heytingAlgebraRecordNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebraRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"REmpty"}]}},"sourceSpan":{"start":[120,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[126,20]}},{"comments":null,"title":"heytingAlgebraRecordCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebraRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebraRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}},"sourceSpan":{"start":[128,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[174,55]}}],"comments":null,"title":"HeytingAlgebraRecord","info":{"fundeps":[[["rowlist"],["subrow"]]],"arguments":[["rowlist",null],["row",null],["subrow",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[112,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[118,78]}}]},{"reExports":[],"name":"Data.HeytingAlgebra.Generic","comments":null,"declarations":[{"children":[{"comments":null,"title":"genericFF'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[9,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[9,18]}},{"comments":null,"title":"genericTT'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[10,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[10,18]}},{"comments":null,"title":"genericImplies'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[11,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[11,33]}},{"comments":null,"title":"genericConj'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[12,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[12,30]}},{"comments":null,"title":"genericDisj'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[13,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[13,30]}},{"comments":null,"title":"genericNot'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}},"sourceSpan":{"start":[14,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[14,24]}},{"comments":null,"title":"genericHeytingAlgebraNoArguments","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra","Generic"],"GenericHeytingAlgebra"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoArguments"]}]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[22,30]}},{"comments":null,"title":"genericHeytingAlgebraArgument","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra","Generic"],"GenericHeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Argument"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[24,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[30,46]}},{"comments":null,"title":"genericHeytingAlgebraProduct","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra","Generic"],"GenericHeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra","Generic"],"GenericHeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra","Generic"],"GenericHeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Product"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[32,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[38,70]}},{"comments":null,"title":"genericHeytingAlgebraConstructor","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra","Generic"],"GenericHeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra","Generic"],"GenericHeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Constructor"]},{"annotation":[],"tag":"TypeVar","contents":"name"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[46,60]}}],"comments":null,"title":"GenericHeytingAlgebra","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[8,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[14,24]}},{"children":[],"comments":"A `Generic` implementation of the `ff` member from the `HeytingAlgebra` type class.\n","title":"genericFF","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra","Generic"],"GenericHeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]},null]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[49,75]}},{"children":[],"comments":"A `Generic` implementation of the `tt` member from the `HeytingAlgebra` type class.\n","title":"genericTT","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra","Generic"],"GenericHeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]},null]}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[53,75]}},{"children":[],"comments":"A `Generic` implementation of the `implies` member from the `HeytingAlgebra` type class.\n","title":"genericImplies","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra","Generic"],"GenericHeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]},null]}},"sourceSpan":{"start":[57,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[57,90]}},{"children":[],"comments":"A `Generic` implementation of the `conj` member from the `HeytingAlgebra` type class.\n","title":"genericConj","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra","Generic"],"GenericHeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]},null]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[61,87]}},{"children":[],"comments":"A `Generic` implementation of the `disj` member from the `HeytingAlgebra` type class.\n","title":"genericDisj","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra","Generic"],"GenericHeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]},null]}},"sourceSpan":{"start":[65,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[65,87]}},{"children":[],"comments":"A `Generic` implementation of the `not` member from the `HeytingAlgebra` type class.\n","title":"genericNot","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra","Generic"],"GenericHeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]},null]},null]}},"sourceSpan":{"start":[69,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra/Generic.purs","end":[69,81]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Data","Semigroup"]},"declarations":[{"children":[{"comments":null,"title":"semigroupString","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[37,24]}},{"comments":null,"title":"semigroupUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[40,20]}},{"comments":null,"title":"semigroupVoid","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Void"],"Void"]}]}},"sourceSpan":{"start":[42,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[43,20]}},{"comments":null,"title":"semigroupFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"Semigroup"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"s'"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"s"}]},{"annotation":[],"tag":"TypeVar","contents":"s'"}]}]}},"sourceSpan":{"start":[45,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[46,28]}},{"comments":null,"title":"semigroupArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[48,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[49,23]}},{"comments":null,"title":"semigroupProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[51,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[52,21]}},{"comments":null,"title":"semigroupProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[54,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[55,22]}},{"comments":null,"title":"semigroupProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[57,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[58,22]}},{"comments":null,"title":"semigroupRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"SemigroupRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[60,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[61,46]}}],"comments":"The `Semigroup` type class identifies an associative operation on a type.\n\nInstances are required to satisfy the following law:\n\n- Associativity: `(x <> y) <> z = x <> (y <> z)`\n\nOne example of a `Semigroup` is `String`, with `(<>)` defined as string\nconcatenation. Another example is `List a`, with `(<>)` defined as\nlist concatenation.\n\n### Newtypes for Semigroup\n\nThere are two other ways to implement an instance for this type class\nregardless of which type is used. These instances can be used by\nwrapping the values in one of the two newtypes below:\n1. `First` - Use the first argument every time: `append first _ = first`.\n2. `Last` - Use the last argument every time: `append _ last = last`.\n","title":"Semigroup","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[32,24]}},{"children":[{"comments":null,"title":"semigroupRecordNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"SemigroupRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"REmpty"}]}},"sourceSpan":{"start":[72,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[73,26]}},{"comments":null,"title":"semigroupRecordCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"SemigroupRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"Semigroup"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"SemigroupRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}},"sourceSpan":{"start":[75,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[87,61]}}],"comments":null,"title":"SemigroupRecord","info":{"fundeps":[[["rowlist"],["subrow"]]],"arguments":[["rowlist",null],["row",null],["subrow",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[69,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[70,95]}},{"children":[],"comments":null,"title":"(<>)","info":{"declType":"alias","alias":[["Data","Semigroup"],{"Right":{"Left":{"Ident":"append"}}}],"fixity":{"associativity":"infixr","precedence":5}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[34,22]}}]}],"name":"Data.Monoid","comments":null,"declarations":[{"children":[{"comments":null,"title":"mempty","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"m"}},"sourceSpan":{"start":[45,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[45,14]}},{"comments":null,"title":"monoidUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[47,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[48,16]}},{"comments":null,"title":"monoidOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[50,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[51,14]}},{"comments":null,"title":"monoidFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Monoid"],"Monoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[54,20]}},{"comments":null,"title":"monoidString","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[56,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[57,14]}},{"comments":null,"title":"monoidArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[59,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[60,14]}},{"comments":null,"title":"monoidRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Monoid"],"MonoidRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[62,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[63,46]}}],"comments":"A `Monoid` is a `Semigroup` with a value `mempty`, which is both a\nleft and right unit for the associative operation `<>`:\n\n- Left unit: `(mempty <> x) = x`\n- Right unit: `(x <> mempty) = x`\n\n`Monoid`s are commonly used as the result of fold operations, where\n`<>` is used to combine individual results, and `mempty` gives the result\nof folding an empty collection of elements.\n\n### Newtypes for Monoid\n\nSome types (e.g. `Int`, `Boolean`) can implement multiple law-abiding\ninstances for `Monoid`. Let's use `Int` as an example\n1. `<>` could be `+` and `mempty` could be `0`\n2. `<>` could be `*` and `mempty` could be `1`.\n\nTo clarify these ambiguous situations, one should use the newtypes\ndefined in `Data.Monoid.` modules.\n\nIn the above ambiguous situation, we could use `Additive`\nfor the first situation or `Multiplicative` for the second one.\n","title":"Monoid","info":{"fundeps":[],"arguments":[["m",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"Semigroup"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[44,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[45,14]}},{"children":[],"comments":"Append a value to itself a certain number of times. For the\n`Multiplicative` type, and for a non-negative power, this is the same as\nnormal number exponentiation.\n\nIf the second argument is negative this function will return `mempty`\n(*unlike* normal number exponentiation). The `Monoid` constraint alone\nis not enough to write a `power` function with the property that `power x\nn` cancels with `power x (-n)`, i.e. `power x n <> power x (-n) = mempty`.\nFor that, we would additionally need the ability to invert elements, i.e.\na Group.\n\n```purescript\npower [1,2] 3 == [1,2,1,2,1,2]\npower [1,2] 1 == [1,2]\npower [1,2] 0 == []\npower [1,2] (-3) == []\n```\n\n","title":"power","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Monoid"],"Monoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"m"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]},{"annotation":[],"tag":"TypeVar","contents":"m"}]}]}]},null]}},"sourceSpan":{"start":[83,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[83,45]}},{"children":[],"comments":"Allow or \"truncate\" a Monoid to its `mempty` value based on a condition.\n","title":"guard","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Monoid"],"Monoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"m"}]},{"annotation":[],"tag":"TypeVar","contents":"m"}]}]}]},null]}},"sourceSpan":{"start":[94,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[94,49]}},{"children":[{"comments":null,"title":"memptyRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]},null]}},"sourceSpan":{"start":[102,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[102,67]}},{"comments":null,"title":"monoidRecordNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"MonoidRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"REmpty"}]}},"sourceSpan":{"start":[104,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[105,22]}},{"comments":null,"title":"monoidRecordCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Monoid"],"Monoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Monoid"],"MonoidRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"MonoidRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}},"sourceSpan":{"start":[107,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[119,55]}}],"comments":null,"title":"MonoidRecord","info":{"fundeps":[[["rowlist"],["row","subrow"]]],"arguments":[["rowlist",null],["row",null],["subrow",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"SemigroupRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlist"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[101,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[102,67]}}]},{"reExports":[],"name":"Data.Monoid.Additive","comments":null,"declarations":[{"children":[{"comments":null,"title":"Additive","info":{"arguments":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"eqAdditive","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Additive"],"Additive"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Additive.purs","end":[16,62]}},{"comments":null,"title":"eq1Additive","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Additive"],"Additive"]}]}},"sourceSpan":{"start":[17,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Additive.purs","end":[17,44]}},{"comments":null,"title":"ordAdditive","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Additive"],"Additive"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Additive.purs","end":[19,65]}},{"comments":null,"title":"ord1Additive","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Additive"],"Additive"]}]}},"sourceSpan":{"start":[20,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Additive.purs","end":[20,46]}},{"comments":null,"title":"boundedAdditive","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded"],"Bounded"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Additive"],"Additive"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[22,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Additive.purs","end":[22,77]}},{"comments":null,"title":"showAdditive","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Additive"],"Additive"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[24,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Additive.purs","end":[25,52]}},{"comments":null,"title":"functorAdditive","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Additive"],"Additive"]}]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Additive.purs","end":[27,52]}},{"comments":null,"title":"applyAdditive","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Additive"],"Additive"]}]}},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Additive.purs","end":[30,51]}},{"comments":null,"title":"applicativeAdditive","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Additive"],"Additive"]}]}},"sourceSpan":{"start":[32,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Additive.purs","end":[33,18]}},{"comments":null,"title":"bindAdditive","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Additive"],"Additive"]}]}},"sourceSpan":{"start":[35,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Additive.purs","end":[36,28]}},{"comments":null,"title":"monadAdditive","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Monad"],"Monad"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Additive"],"Additive"]}]}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Additive.purs","end":[38,41]}},{"comments":null,"title":"semigroupAdditive","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Additive"],"Additive"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Additive.purs","end":[41,54]}},{"comments":null,"title":"monoidAdditive","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Additive"],"Additive"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Additive.purs","end":[44,25]}}],"comments":"Monoid and semigroup for semirings under addition.\n\n``` purescript\nAdditive x <> Additive y == Additive (x + y)\n(mempty :: Additive _) == Additive zero\n```\n","title":"Additive","info":{"declType":"data","dataDeclType":"newtype","typeArguments":[["a",null]]},"sourceSpan":{"start":[14,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Additive.purs","end":[14,32]}}]},{"reExports":[],"name":"Data.Monoid.Conj","comments":null,"declarations":[{"children":[{"comments":null,"title":"Conj","info":{"arguments":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"eqConj","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Conj"],"Conj"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[17,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[17,54]}},{"comments":null,"title":"eq1Conj","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Conj"],"Conj"]}]}},"sourceSpan":{"start":[18,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[18,36]}},{"comments":null,"title":"ordConj","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Conj"],"Conj"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[20,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[20,57]}},{"comments":null,"title":"ord1Conj","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Conj"],"Conj"]}]}},"sourceSpan":{"start":[21,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[21,38]}},{"comments":null,"title":"boundedConj","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded"],"Bounded"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Conj"],"Conj"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[23,69]}},{"comments":null,"title":"showConj","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Conj"],"Conj"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[26,44]}},{"comments":null,"title":"functorConj","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Conj"],"Conj"]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[28,44]}},{"comments":null,"title":"applyConj","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Conj"],"Conj"]}]}},"sourceSpan":{"start":[30,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[31,39]}},{"comments":null,"title":"applicativeConj","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Conj"],"Conj"]}]}},"sourceSpan":{"start":[33,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[34,14]}},{"comments":null,"title":"bindConj","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Conj"],"Conj"]}]}},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[37,24]}},{"comments":null,"title":"monadConj","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Monad"],"Monad"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Conj"],"Conj"]}]}},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[39,33]}},{"comments":null,"title":"semigroupConj","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Conj"],"Conj"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[41,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[42,45]}},{"comments":null,"title":"monoidConj","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Conj"],"Conj"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[44,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[45,19]}},{"comments":null,"title":"semiringConj","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Conj"],"Conj"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[47,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[51,42]}}],"comments":"Monoid and semigroup for conjunction.\n\n``` purescript\nConj x <> Conj y == Conj (x && y)\n(mempty :: Conj _) == Conj tt\n```\n","title":"Conj","info":{"declType":"data","dataDeclType":"newtype","typeArguments":[["a",null]]},"sourceSpan":{"start":[15,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Conj.purs","end":[15,24]}}]},{"reExports":[],"name":"Data.Monoid.Disj","comments":null,"declarations":[{"children":[{"comments":null,"title":"Disj","info":{"arguments":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"eqDisj","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Disj"],"Disj"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[17,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[17,54]}},{"comments":null,"title":"eq1Disj","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Disj"],"Disj"]}]}},"sourceSpan":{"start":[18,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[18,36]}},{"comments":null,"title":"ordDisj","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Disj"],"Disj"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[20,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[20,57]}},{"comments":null,"title":"ord1Disj","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Disj"],"Disj"]}]}},"sourceSpan":{"start":[21,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[21,38]}},{"comments":null,"title":"boundedDisj","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded"],"Bounded"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Disj"],"Disj"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[23,69]}},{"comments":null,"title":"showDisj","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Disj"],"Disj"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[26,44]}},{"comments":null,"title":"functorDisj","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Disj"],"Disj"]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[28,44]}},{"comments":null,"title":"applyDisj","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Disj"],"Disj"]}]}},"sourceSpan":{"start":[30,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[31,39]}},{"comments":null,"title":"applicativeDisj","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Disj"],"Disj"]}]}},"sourceSpan":{"start":[33,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[34,14]}},{"comments":null,"title":"bindDisj","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Disj"],"Disj"]}]}},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[37,24]}},{"comments":null,"title":"monadDisj","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Monad"],"Monad"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Disj"],"Disj"]}]}},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[39,33]}},{"comments":null,"title":"semigroupDisj","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Disj"],"Disj"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[41,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[42,45]}},{"comments":null,"title":"monoidDisj","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Disj"],"Disj"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[44,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[45,19]}},{"comments":null,"title":"semiringDisj","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Disj"],"Disj"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[47,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[51,42]}}],"comments":"Monoid and semigroup for disjunction.\n\n``` purescript\nDisj x <> Disj y == Disj (x || y)\n(mempty :: Disj _) == Disj bottom\n```\n","title":"Disj","info":{"declType":"data","dataDeclType":"newtype","typeArguments":[["a",null]]},"sourceSpan":{"start":[15,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Disj.purs","end":[15,24]}}]},{"reExports":[],"name":"Data.Monoid.Dual","comments":null,"declarations":[{"children":[{"comments":null,"title":"Dual","info":{"arguments":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"eqDual","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Dual"],"Dual"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Dual.purs","end":[16,54]}},{"comments":null,"title":"eq1Dual","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Dual"],"Dual"]}]}},"sourceSpan":{"start":[17,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Dual.purs","end":[17,36]}},{"comments":null,"title":"ordDual","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Dual"],"Dual"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Dual.purs","end":[19,57]}},{"comments":null,"title":"ord1Dual","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Dual"],"Dual"]}]}},"sourceSpan":{"start":[20,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Dual.purs","end":[20,38]}},{"comments":null,"title":"boundedDual","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded"],"Bounded"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Dual"],"Dual"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[22,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Dual.purs","end":[22,69]}},{"comments":null,"title":"showDual","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Dual"],"Dual"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[24,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Dual.purs","end":[25,44]}},{"comments":null,"title":"functorDual","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Dual"],"Dual"]}]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Dual.purs","end":[27,44]}},{"comments":null,"title":"applyDual","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Dual"],"Dual"]}]}},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Dual.purs","end":[30,39]}},{"comments":null,"title":"applicativeDual","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Dual"],"Dual"]}]}},"sourceSpan":{"start":[32,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Dual.purs","end":[33,14]}},{"comments":null,"title":"bindDual","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Dual"],"Dual"]}]}},"sourceSpan":{"start":[35,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Dual.purs","end":[36,24]}},{"comments":null,"title":"monadDual","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Monad"],"Monad"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Dual"],"Dual"]}]}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Dual.purs","end":[38,33]}},{"comments":null,"title":"semigroupDual","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"Semigroup"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Dual"],"Dual"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Dual.purs","end":[41,43]}},{"comments":null,"title":"monoidDual","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Monoid"],"Monoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Dual"],"Dual"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Dual.purs","end":[44,23]}}],"comments":"The dual of a monoid.\n\n``` purescript\nDual x <> Dual y == Dual (y <> x)\n(mempty :: Dual _) == Dual mempty\n```\n","title":"Dual","info":{"declType":"data","dataDeclType":"newtype","typeArguments":[["a",null]]},"sourceSpan":{"start":[14,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Dual.purs","end":[14,24]}}]},{"reExports":[],"name":"Data.Monoid.Endo","comments":null,"declarations":[{"children":[{"comments":null,"title":"Endo","info":{"arguments":[{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"c"},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"eqEndo","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"c"},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Endo"],"Endo"]},{"annotation":[],"tag":"TypeVar","contents":"c"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[17,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Endo.purs","end":[17,62]}},{"comments":null,"title":"ordEndo","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"c"},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Endo"],"Endo"]},{"annotation":[],"tag":"TypeVar","contents":"c"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Endo.purs","end":[19,65]}},{"comments":null,"title":"boundedEndo","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded"],"Bounded"],"constraintArgs":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"c"},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Endo"],"Endo"]},{"annotation":[],"tag":"TypeVar","contents":"c"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[21,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Endo.purs","end":[21,77]}},{"comments":null,"title":"showEndo","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"c"},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Endo"],"Endo"]},{"annotation":[],"tag":"TypeVar","contents":"c"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Endo.purs","end":[24,44]}},{"comments":null,"title":"semigroupEndo","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Control","Semigroupoid"],"Semigroupoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"c"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Endo"],"Endo"]},{"annotation":[],"tag":"TypeVar","contents":"c"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Endo.purs","end":[27,44]}},{"comments":null,"title":"monoidEndo","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Control","Category"],"Category"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"c"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Endo"],"Endo"]},{"annotation":[],"tag":"TypeVar","contents":"c"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Endo.purs","end":[30,25]}}],"comments":null,"title":"Endo","info":{"declType":"data","dataDeclType":"newtype","typeArguments":[["c",null],["a",null]]},"sourceSpan":{"start":[15,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Endo.purs","end":[15,32]}}]},{"reExports":[],"name":"Data.Monoid.Generic","comments":null,"declarations":[{"children":[{"comments":null,"title":"genericMempty'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[11,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Generic.purs","end":[11,22]}},{"comments":null,"title":"genericMonoidNoArguments","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Generic"],"GenericMonoid"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoArguments"]}]}},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Generic.purs","end":[14,31]}},{"comments":null,"title":"genericMonoidProduct","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Monoid","Generic"],"GenericMonoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Monoid","Generic"],"GenericMonoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Generic"],"GenericMonoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Product"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Generic.purs","end":[17,57]}},{"comments":null,"title":"genericMonoidConstructor","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Monoid","Generic"],"GenericMonoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Generic"],"GenericMonoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Constructor"]},{"annotation":[],"tag":"TypeVar","contents":"name"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Generic.purs","end":[20,46]}},{"comments":null,"title":"genericMonoidArgument","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Monoid"],"Monoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Generic"],"GenericMonoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Argument"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[22,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Generic.purs","end":[23,35]}}],"comments":null,"title":"GenericMonoid","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[10,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Generic.purs","end":[11,22]}},{"children":[],"comments":"A `Generic` implementation of the `mempty` member from the `Monoid` type class.\n","title":"genericMempty","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Monoid","Generic"],"GenericMonoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]},null]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Generic.purs","end":[26,71]}}]},{"reExports":[],"name":"Data.Monoid.Multiplicative","comments":null,"declarations":[{"children":[{"comments":null,"title":"Multiplicative","info":{"arguments":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"eqMultiplicative","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Multiplicative"],"Multiplicative"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Multiplicative.purs","end":[16,74]}},{"comments":null,"title":"eq1Multiplicative","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Multiplicative"],"Multiplicative"]}]}},"sourceSpan":{"start":[17,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Multiplicative.purs","end":[17,56]}},{"comments":null,"title":"ordMultiplicative","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Multiplicative"],"Multiplicative"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Multiplicative.purs","end":[19,77]}},{"comments":null,"title":"ord1Multiplicative","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Multiplicative"],"Multiplicative"]}]}},"sourceSpan":{"start":[20,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Multiplicative.purs","end":[20,58]}},{"comments":null,"title":"boundedMultiplicative","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded"],"Bounded"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Multiplicative"],"Multiplicative"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[22,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Multiplicative.purs","end":[22,89]}},{"comments":null,"title":"showMultiplicative","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Multiplicative"],"Multiplicative"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[24,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Multiplicative.purs","end":[25,64]}},{"comments":null,"title":"functorMultiplicative","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Multiplicative"],"Multiplicative"]}]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Multiplicative.purs","end":[27,64]}},{"comments":null,"title":"applyMultiplicative","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Multiplicative"],"Multiplicative"]}]}},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Multiplicative.purs","end":[30,69]}},{"comments":null,"title":"applicativeMultiplicative","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Multiplicative"],"Multiplicative"]}]}},"sourceSpan":{"start":[32,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Multiplicative.purs","end":[33,24]}},{"comments":null,"title":"bindMultiplicative","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Multiplicative"],"Multiplicative"]}]}},"sourceSpan":{"start":[35,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Multiplicative.purs","end":[36,34]}},{"comments":null,"title":"monadMultiplicative","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Monad"],"Monad"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Multiplicative"],"Multiplicative"]}]}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Multiplicative.purs","end":[38,53]}},{"comments":null,"title":"semigroupMultiplicative","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Multiplicative"],"Multiplicative"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Multiplicative.purs","end":[41,72]}},{"comments":null,"title":"monoidMultiplicative","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid","Multiplicative"],"Multiplicative"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Multiplicative.purs","end":[44,30]}}],"comments":"Monoid and semigroup for semirings under multiplication.\n\n``` purescript\nMultiplicative x <> Multiplicative y == Multiplicative (x * y)\n(mempty :: Multiplicative _) == Multiplicative one\n```\n","title":"Multiplicative","info":{"declType":"data","dataDeclType":"newtype","typeArguments":[["a",null]]},"sourceSpan":{"start":[14,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid/Multiplicative.purs","end":[14,44]}}]},{"reExports":[],"name":"Data.NaturalTransformation","comments":null,"declarations":[{"children":[],"comments":null,"title":"NaturalTransformation","info":{"arguments":[["f",null],["g",null]],"declType":"typeSynonym","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"g"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]}},"sourceSpan":{"start":[18,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/NaturalTransformation.purs","end":[18,54]}},{"children":[],"comments":null,"title":"type (~>)","info":{"declType":"alias","alias":[["Data","NaturalTransformation"],{"Left":"NaturalTransformation"}],"fixity":{"associativity":"infixr","precedence":4}},"sourceSpan":{"start":[20,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/NaturalTransformation.purs","end":[20,42]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Data","Ordering"]},"declarations":[{"children":[{"comments":null,"title":"LT","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"GT","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"EQ","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"eqOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[15,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[19,19]}},{"comments":null,"title":"semigroupOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[21,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[24,18]}},{"comments":null,"title":"showOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[29,17]}}],"comments":"The `Ordering` data type represents the three possible outcomes of\ncomparing two values:\n\n`LT` - The first value is _less than_ the second.\n`GT` - The first value is _greater than_ the second.\n`EQ` - The first value is _equal to_ the second.\n","title":"Ordering","info":{"declType":"data","dataDeclType":"data","typeArguments":[]},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[13,29]}}]}],"name":"Data.Ord","comments":null,"declarations":[{"children":[{"comments":null,"title":"compare","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}]}},"sourceSpan":{"start":[38,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[38,32]}},{"comments":null,"title":"ordBoolean","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[41,36]}},{"comments":null,"title":"ordInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[44,32]}},{"comments":null,"title":"ordNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[47,35]}},{"comments":null,"title":"ordString","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[50,35]}},{"comments":null,"title":"ordChar","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Char"]}]}},"sourceSpan":{"start":[52,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[53,33]}},{"comments":null,"title":"ordUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[55,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[56,19]}},{"comments":null,"title":"ordVoid","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Void"],"Void"]}]}},"sourceSpan":{"start":[58,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[59,19]}},{"comments":null,"title":"ordProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[62,19]}},{"comments":null,"title":"ordProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[64,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[65,19]}},{"comments":null,"title":"ordProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[67,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[68,19]}},{"comments":null,"title":"ordArray","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[70,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[77,17]}},{"comments":null,"title":"ordOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[121,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[128,21]}},{"comments":null,"title":"ordRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ord"],"OrdRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[249,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[254,48]}}],"comments":"The `Ord` type class represents types which support comparisons with a\n_total order_.\n\n`Ord` instances should satisfy the laws of total orderings:\n\n- Reflexivity: `a <= a`\n- Antisymmetry: if `a <= b` and `b <= a` then `a = b`\n- Transitivity: if `a <= b` and `b <= c` then `a <= c`\n","title":"Ord","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[37,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[38,32]}},{"children":[{"comments":null,"title":"compare1","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}]}]},null]}},"sourceSpan":{"start":[221,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[221,56]}},{"comments":null,"title":"ord1Array","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[223,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[224,21]}}],"comments":"The `Ord1` type class represents totally ordered type constructors.\n","title":"Ord1","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq1"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[220,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[221,56]}},{"children":[],"comments":"Test whether one value is _strictly less than_ another.\n","title":"lessThan","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}]},null]}},"sourceSpan":{"start":[131,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[131,49]}},{"children":[],"comments":null,"title":"(<)","info":{"declType":"alias","alias":[["Data","Ord"],{"Right":{"Left":{"Ident":"lessThan"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[154,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[154,23]}},{"children":[],"comments":"Test whether one value is _non-strictly less than_ another.\n","title":"lessThanOrEq","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}]},null]}},"sourceSpan":{"start":[143,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[143,53]}},{"children":[],"comments":null,"title":"(<=)","info":{"declType":"alias","alias":[["Data","Ord"],{"Right":{"Left":{"Ident":"lessThanOrEq"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[155,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[155,28]}},{"children":[],"comments":"Test whether one value is _strictly greater than_ another.\n","title":"greaterThan","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}]},null]}},"sourceSpan":{"start":[137,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[137,52]}},{"children":[],"comments":null,"title":"(>)","info":{"declType":"alias","alias":[["Data","Ord"],{"Right":{"Left":{"Ident":"greaterThan"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[156,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[156,26]}},{"children":[],"comments":"Test whether one value is _non-strictly greater than_ another.\n","title":"greaterThanOrEq","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}]},null]}},"sourceSpan":{"start":[149,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[149,56]}},{"children":[],"comments":null,"title":"(>=)","info":{"declType":"alias","alias":[["Data","Ord"],{"Right":{"Left":{"Ident":"greaterThanOrEq"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[157,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[157,31]}},{"children":[],"comments":"Compares two values by mapping them to a type with an `Ord` instance.\n","title":"comparing","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}]}}]}]},null]},null]}},"sourceSpan":{"start":[160,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[160,67]}},{"children":[],"comments":"Take the minimum of two values. If they are considered equal, the first\nargument is chosen.\n","title":"min","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]},null]}},"sourceSpan":{"start":[165,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[165,38]}},{"children":[],"comments":"Take the maximum of two values. If they are considered equal, the first\nargument is chosen.\n","title":"max","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]},null]}},"sourceSpan":{"start":[174,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[174,38]}},{"children":[],"comments":"Clamp a value between a minimum and a maximum. For example:\n\n``` purescript\nlet f = clamp 0 10\nf (-5) == 0\nf 5 == 5\nf 15 == 10\n```\n","title":"clamp","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]}},"sourceSpan":{"start":[189,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[189,45]}},{"children":[],"comments":"Test whether a value is between a minimum and a maximum (inclusive).\nFor example:\n\n``` purescript\nlet f = between 0 10\nf 0 == true\nf (-5) == false\nf 5 == true\nf 10 == true\nf 15 == false\n```\n","title":"between","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}]}]},null]}},"sourceSpan":{"start":[203,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[203,53]}},{"children":[],"comments":"The absolute value function. `abs x` is defined as `if x >= zero then x\nelse negate x`.\n","title":"abs","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]},null]}},"sourceSpan":{"start":[211,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[211,43]}},{"children":[],"comments":"The sign function; always evaluates to either `one` or `negate one`. For\nany `x`, we should have `signum x * abs x == x`.\n","title":"signum","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]},null]}},"sourceSpan":{"start":[216,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[216,46]}},{"children":[{"comments":null,"title":"compareRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}]}]},null]}},"sourceSpan":{"start":[228,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[228,91]}},{"comments":null,"title":"ordRecordNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"OrdRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}},"sourceSpan":{"start":[230,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[231,27]}},{"comments":null,"title":"ordRecordCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"OrdRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"rowTail"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"OrdRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}},"sourceSpan":{"start":[233,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[247,59]}}],"comments":null,"title":"OrdRecord","info":{"fundeps":[],"arguments":[["rowlist",null],["row",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"EqRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlist"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[227,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[228,91]}}]},{"reExports":[],"name":"Data.Ord.Generic","comments":null,"declarations":[{"children":[{"comments":null,"title":"genericCompare'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}]}},"sourceSpan":{"start":[11,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord/Generic.purs","end":[11,40]}},{"comments":null,"title":"genericOrdNoConstructors","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord","Generic"],"GenericOrd"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoConstructors"]}]}},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord/Generic.purs","end":[14,27]}},{"comments":null,"title":"genericOrdNoArguments","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord","Generic"],"GenericOrd"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoArguments"]}]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord/Generic.purs","end":[17,27]}},{"comments":null,"title":"genericOrdSum","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord","Generic"],"GenericOrd"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ord","Generic"],"GenericOrd"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord","Generic"],"GenericOrd"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Sum"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord/Generic.purs","end":[23,39]}},{"comments":null,"title":"genericOrdProduct","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord","Generic"],"GenericOrd"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ord","Generic"],"GenericOrd"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord","Generic"],"GenericOrd"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Product"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord/Generic.purs","end":[29,21]}},{"comments":null,"title":"genericOrdConstructor","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord","Generic"],"GenericOrd"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord","Generic"],"GenericOrd"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Constructor"]},{"annotation":[],"tag":"TypeVar","contents":"name"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord/Generic.purs","end":[32,76]}},{"comments":null,"title":"genericOrdArgument","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord","Generic"],"GenericOrd"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Argument"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord/Generic.purs","end":[35,62]}}],"comments":null,"title":"GenericOrd","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[10,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord/Generic.purs","end":[11,40]}},{"children":[],"comments":"A `Generic` implementation of the `compare` member from the `Ord` type class.\n","title":"genericCompare","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord","Generic"],"GenericOrd"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}]}]}]},null]},null]}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord/Generic.purs","end":[38,86]}}]},{"reExports":[],"name":"Data.Ordering","comments":null,"declarations":[{"children":[{"comments":null,"title":"LT","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"GT","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"EQ","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"eqOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[15,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[19,19]}},{"comments":null,"title":"semigroupOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[21,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[24,18]}},{"comments":null,"title":"showOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[29,17]}}],"comments":"The `Ordering` data type represents the three possible outcomes of\ncomparing two values:\n\n`LT` - The first value is _less than_ the second.\n`GT` - The first value is _greater than_ the second.\n`EQ` - The first value is _equal to_ the second.\n","title":"Ordering","info":{"declType":"data","dataDeclType":"data","typeArguments":[]},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[13,29]}},{"children":[],"comments":"Reverses an `Ordering` value, flipping greater than for less than while\npreserving equality.\n","title":"invert","info":{"declType":"value","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[33,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[33,31]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Data","Semiring"]},"declarations":[{"children":[{"comments":null,"title":"add","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[35,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[35,22]}},{"comments":null,"title":"zero","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[36,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[36,12]}},{"comments":null,"title":"mul","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[37,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[37,22]}},{"comments":null,"title":"one","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[38,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[38,12]}},{"comments":null,"title":"semiringInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[47,10]}},{"comments":null,"title":"semiringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[53,12]}},{"comments":null,"title":"semiringFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[55,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[59,18]}},{"comments":null,"title":"semiringUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[65,13]}},{"comments":null,"title":"semiringProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[67,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[71,15]}},{"comments":null,"title":"semiringProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[73,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[77,16]}},{"comments":null,"title":"semiringProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[79,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[83,16]}},{"comments":null,"title":"semiringRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"SemiringRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[85,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[89,63]}}],"comments":"The `Semiring` class is for types that support an addition and\nmultiplication operation.\n\nInstances must satisfy the following laws:\n\n- Commutative monoid under addition:\n - Associativity: `(a + b) + c = a + (b + c)`\n - Identity: `zero + a = a + zero = a`\n - Commutative: `a + b = b + a`\n- Monoid under multiplication:\n - Associativity: `(a * b) * c = a * (b * c)`\n - Identity: `one * a = a * one = a`\n- Multiplication distributes over addition:\n - Left distributivity: `a * (b + c) = (a * b) + (a * c)`\n - Right distributivity: `(a + b) * c = (a * c) + (b * c)`\n- Annihilation: `zero * a = a * zero = zero`\n\n**Note:** The `Number` and `Int` types are not fully law abiding\nmembers of this class hierarchy due to the potential for arithmetic\noverflows, and in the case of `Number`, the presence of `NaN` and\n`Infinity` values. The behaviour is unspecified in these cases.\n","title":"Semiring","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[38,12]}},{"children":[{"comments":null,"title":"semiringRecordNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"SemiringRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"REmpty"}]}},"sourceSpan":{"start":[105,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[109,22]}},{"comments":null,"title":"semiringRecordCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"SemiringRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"SemiringRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}},"sourceSpan":{"start":[111,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[142,76]}}],"comments":null,"title":"SemiringRecord","info":{"fundeps":[[["rowlist"],["subrow"]]],"arguments":[["rowlist",null],["row",null],["subrow",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[99,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[103,86]}},{"children":[],"comments":null,"title":"(+)","info":{"declType":"alias","alias":[["Data","Semiring"],{"Right":{"Left":{"Ident":"add"}}}],"fixity":{"associativity":"infixl","precedence":6}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[40,18]}},{"children":[],"comments":null,"title":"(*)","info":{"declType":"alias","alias":[["Data","Semiring"],{"Right":{"Left":{"Ident":"mul"}}}],"fixity":{"associativity":"infixl","precedence":7}},"sourceSpan":{"start":[41,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[41,18]}}]}],"name":"Data.Ring","comments":null,"declarations":[{"children":[{"comments":null,"title":"sub","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[24,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[24,21]}},{"comments":null,"title":"ringInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[29,15]}},{"comments":null,"title":"ringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[32,15]}},{"comments":null,"title":"ringUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[35,17]}},{"comments":null,"title":"ringFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[37,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[38,24]}},{"comments":null,"title":"ringProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[41,18]}},{"comments":null,"title":"ringProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[44,19]}},{"comments":null,"title":"ringProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[47,19]}},{"comments":null,"title":"ringRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ring"],"RingRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[50,40]}}],"comments":"The `Ring` class is for types that support addition, multiplication,\nand subtraction operations.\n\nInstances must satisfy the following laws in addition to the `Semiring`\nlaws:\n\n- Additive inverse: `a - a = zero`\n- Compatibility of `sub` and `negate`: `a - b = a + (zero - b)`\n","title":"Ring","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[24,21]}},{"children":[],"comments":"`negate x` can be used as a shorthand for `zero - x`.\n","title":"negate","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[53,37]}},{"children":[],"comments":null,"title":"(-)","info":{"declType":"alias","alias":[["Data","Ring"],{"Right":{"Left":{"Ident":"sub"}}}],"fixity":{"associativity":"infixl","precedence":6}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[26,18]}},{"children":[{"comments":null,"title":"subRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]}]}]},null]}},"sourceSpan":{"start":[63,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[63,92]}},{"comments":null,"title":"ringRecordNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"RingRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"REmpty"}]}},"sourceSpan":{"start":[65,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[66,23]}},{"comments":null,"title":"ringRecordCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ring"],"RingRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"RingRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}},"sourceSpan":{"start":[68,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[80,58]}}],"comments":null,"title":"RingRecord","info":{"fundeps":[[["rowlist"],["subrow"]]],"arguments":[["rowlist",null],["row",null],["subrow",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"SemiringRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlist"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[62,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[63,92]}}]},{"reExports":[],"name":"Data.Ring.Generic","comments":null,"declarations":[{"children":[{"comments":null,"title":"genericSub'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[8,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring/Generic.purs","end":[8,29]}},{"comments":null,"title":"genericRingNoArguments","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring","Generic"],"GenericRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoArguments"]}]}},"sourceSpan":{"start":[10,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring/Generic.purs","end":[11,32]}},{"comments":null,"title":"genericRingArgument","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring","Generic"],"GenericRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Argument"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring/Generic.purs","end":[14,61]}},{"comments":null,"title":"genericRingProduct","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ring","Generic"],"GenericRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ring","Generic"],"GenericRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring","Generic"],"GenericRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Product"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring/Generic.purs","end":[17,96]}},{"comments":null,"title":"genericRingConstructor","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ring","Generic"],"GenericRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring","Generic"],"GenericRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Constructor"]},{"annotation":[],"tag":"TypeVar","contents":"name"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring/Generic.purs","end":[20,82]}}],"comments":null,"title":"GenericRing","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[7,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring/Generic.purs","end":[8,29]}},{"children":[],"comments":"A `Generic` implementation of the `sub` member from the `Ring` type class.\n","title":"genericSub","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ring","Generic"],"GenericRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]},null]}},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring/Generic.purs","end":[23,76]}}]},{"reExports":[],"name":"Data.Semigroup","comments":null,"declarations":[{"children":[{"comments":null,"title":"append","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[32,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[32,24]}},{"comments":null,"title":"semigroupString","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[37,24]}},{"comments":null,"title":"semigroupUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[40,20]}},{"comments":null,"title":"semigroupVoid","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Void"],"Void"]}]}},"sourceSpan":{"start":[42,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[43,20]}},{"comments":null,"title":"semigroupFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"Semigroup"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"s'"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"s"}]},{"annotation":[],"tag":"TypeVar","contents":"s'"}]}]}},"sourceSpan":{"start":[45,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[46,28]}},{"comments":null,"title":"semigroupArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[48,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[49,23]}},{"comments":null,"title":"semigroupProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[51,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[52,21]}},{"comments":null,"title":"semigroupProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[54,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[55,22]}},{"comments":null,"title":"semigroupProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[57,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[58,22]}},{"comments":null,"title":"semigroupRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"SemigroupRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[60,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[61,46]}}],"comments":"The `Semigroup` type class identifies an associative operation on a type.\n\nInstances are required to satisfy the following law:\n\n- Associativity: `(x <> y) <> z = x <> (y <> z)`\n\nOne example of a `Semigroup` is `String`, with `(<>)` defined as string\nconcatenation. Another example is `List a`, with `(<>)` defined as\nlist concatenation.\n\n### Newtypes for Semigroup\n\nThere are two other ways to implement an instance for this type class\nregardless of which type is used. These instances can be used by\nwrapping the values in one of the two newtypes below:\n1. `First` - Use the first argument every time: `append first _ = first`.\n2. `Last` - Use the last argument every time: `append _ last = last`.\n","title":"Semigroup","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[32,24]}},{"children":[],"comments":null,"title":"(<>)","info":{"declType":"alias","alias":[["Data","Semigroup"],{"Right":{"Left":{"Ident":"append"}}}],"fixity":{"associativity":"infixr","precedence":5}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[34,22]}},{"children":[{"comments":null,"title":"appendRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]}]}]},null]}},"sourceSpan":{"start":[70,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[70,95]}},{"comments":null,"title":"semigroupRecordNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"SemigroupRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"REmpty"}]}},"sourceSpan":{"start":[72,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[73,26]}},{"comments":null,"title":"semigroupRecordCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"SemigroupRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"Semigroup"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"SemigroupRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}},"sourceSpan":{"start":[75,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[87,61]}}],"comments":null,"title":"SemigroupRecord","info":{"fundeps":[[["rowlist"],["subrow"]]],"arguments":[["rowlist",null],["row",null],["subrow",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[69,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[70,95]}}]},{"reExports":[],"name":"Data.Semigroup.First","comments":null,"declarations":[{"children":[{"comments":null,"title":"First","info":{"arguments":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"eqFirst","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","First"],"First"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[15,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/First.purs","end":[15,56]}},{"comments":null,"title":"eq1First","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","First"],"First"]}]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/First.purs","end":[16,38]}},{"comments":null,"title":"ordFirst","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","First"],"First"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[18,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/First.purs","end":[18,59]}},{"comments":null,"title":"ord1First","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","First"],"First"]}]}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/First.purs","end":[19,40]}},{"comments":null,"title":"boundedFirst","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded"],"Bounded"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","First"],"First"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[21,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/First.purs","end":[21,71]}},{"comments":null,"title":"showFirst","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","First"],"First"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/First.purs","end":[24,46]}},{"comments":null,"title":"functorFirst","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","First"],"First"]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/First.purs","end":[26,46]}},{"comments":null,"title":"applyFirst","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","First"],"First"]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/First.purs","end":[29,42]}},{"comments":null,"title":"applicativeFirst","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","First"],"First"]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/First.purs","end":[32,15]}},{"comments":null,"title":"bindFirst","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","First"],"First"]}]}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/First.purs","end":[35,25]}},{"comments":null,"title":"monadFirst","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Monad"],"Monad"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","First"],"First"]}]}},"sourceSpan":{"start":[37,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/First.purs","end":[37,35]}},{"comments":null,"title":"semigroupFirst","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","First"],"First"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/First.purs","end":[40,17]}}],"comments":"Semigroup where `append` always takes the first option.\n\n``` purescript\nFirst x <> First y == First x\n```\n","title":"First","info":{"declType":"data","dataDeclType":"newtype","typeArguments":[["a",null]]},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/First.purs","end":[13,26]}}]},{"reExports":[],"name":"Data.Semigroup.Generic","comments":null,"declarations":[{"children":[{"comments":null,"title":"genericAppend'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[11,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Generic.purs","end":[11,32]}},{"comments":null,"title":"genericSemigroupNoConstructors","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Generic"],"GenericSemigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoConstructors"]}]}},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Generic.purs","end":[14,25]}},{"comments":null,"title":"genericSemigroupNoArguments","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Generic"],"GenericSemigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoArguments"]}]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Generic.purs","end":[17,25]}},{"comments":null,"title":"genericSemigroupProduct","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semigroup","Generic"],"GenericSemigroup"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semigroup","Generic"],"GenericSemigroup"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Generic"],"GenericSemigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Product"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Generic.purs","end":[21,58]}},{"comments":null,"title":"genericSemigroupConstructor","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semigroup","Generic"],"GenericSemigroup"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Generic"],"GenericSemigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Constructor"]},{"annotation":[],"tag":"TypeVar","contents":"name"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Generic.purs","end":[24,88]}},{"comments":null,"title":"genericSemigroupArgument","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"Semigroup"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Generic"],"GenericSemigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Argument"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Generic.purs","end":[27,71]}}],"comments":null,"title":"GenericSemigroup","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[10,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Generic.purs","end":[11,32]}},{"children":[],"comments":"A `Generic` implementation of the `append` member from the `Semigroup` type class.\n","title":"genericAppend","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Semigroup","Generic"],"GenericSemigroup"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]},null]}},"sourceSpan":{"start":[30,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Generic.purs","end":[30,84]}}]},{"reExports":[],"name":"Data.Semigroup.Last","comments":null,"declarations":[{"children":[{"comments":null,"title":"Last","info":{"arguments":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"eqLast","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Last"],"Last"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[15,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Last.purs","end":[15,54]}},{"comments":null,"title":"eq1Last","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Last"],"Last"]}]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Last.purs","end":[16,36]}},{"comments":null,"title":"ordLast","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Last"],"Last"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[18,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Last.purs","end":[18,57]}},{"comments":null,"title":"ord1Last","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord1"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Last"],"Last"]}]}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Last.purs","end":[19,38]}},{"comments":null,"title":"boundedLast","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Bounded"],"Bounded"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Last"],"Last"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[21,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Last.purs","end":[21,69]}},{"comments":null,"title":"showLast","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Last"],"Last"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Last.purs","end":[24,44]}},{"comments":null,"title":"functorLast","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Last"],"Last"]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Last.purs","end":[26,44]}},{"comments":null,"title":"applyLast","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Last"],"Last"]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Last.purs","end":[29,39]}},{"comments":null,"title":"applicativeLast","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Last"],"Last"]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Last.purs","end":[32,14]}},{"comments":null,"title":"bindLast","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Last"],"Last"]}]}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Last.purs","end":[35,24]}},{"comments":null,"title":"monadLast","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Monad"],"Monad"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Last"],"Last"]}]}},"sourceSpan":{"start":[37,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Last.purs","end":[37,33]}},{"comments":null,"title":"semigroupLast","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup","Last"],"Last"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Last.purs","end":[40,17]}}],"comments":"Semigroup where `append` always takes the second option.\n\n``` purescript\nLast x <> Last y == Last y\n```\n","title":"Last","info":{"declType":"data","dataDeclType":"newtype","typeArguments":[["a",null]]},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup/Last.purs","end":[13,24]}}]},{"reExports":[],"name":"Data.Semiring","comments":null,"declarations":[{"children":[{"comments":null,"title":"add","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[35,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[35,22]}},{"comments":null,"title":"zero","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[36,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[36,12]}},{"comments":null,"title":"mul","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[37,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[37,22]}},{"comments":null,"title":"one","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[38,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[38,12]}},{"comments":null,"title":"semiringInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[47,10]}},{"comments":null,"title":"semiringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[53,12]}},{"comments":null,"title":"semiringFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[55,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[59,18]}},{"comments":null,"title":"semiringUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[65,13]}},{"comments":null,"title":"semiringProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[67,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[71,15]}},{"comments":null,"title":"semiringProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[73,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[77,16]}},{"comments":null,"title":"semiringProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[79,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[83,16]}},{"comments":null,"title":"semiringRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"SemiringRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[85,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[89,63]}}],"comments":"The `Semiring` class is for types that support an addition and\nmultiplication operation.\n\nInstances must satisfy the following laws:\n\n- Commutative monoid under addition:\n - Associativity: `(a + b) + c = a + (b + c)`\n - Identity: `zero + a = a + zero = a`\n - Commutative: `a + b = b + a`\n- Monoid under multiplication:\n - Associativity: `(a * b) * c = a * (b * c)`\n - Identity: `one * a = a * one = a`\n- Multiplication distributes over addition:\n - Left distributivity: `a * (b + c) = (a * b) + (a * c)`\n - Right distributivity: `(a + b) * c = (a * c) + (b * c)`\n- Annihilation: `zero * a = a * zero = zero`\n\n**Note:** The `Number` and `Int` types are not fully law abiding\nmembers of this class hierarchy due to the potential for arithmetic\noverflows, and in the case of `Number`, the presence of `NaN` and\n`Infinity` values. The behaviour is unspecified in these cases.\n","title":"Semiring","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[38,12]}},{"children":[],"comments":null,"title":"(+)","info":{"declType":"alias","alias":[["Data","Semiring"],{"Right":{"Left":{"Ident":"add"}}}],"fixity":{"associativity":"infixl","precedence":6}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[40,18]}},{"children":[],"comments":null,"title":"(*)","info":{"declType":"alias","alias":[["Data","Semiring"],{"Right":{"Left":{"Ident":"mul"}}}],"fixity":{"associativity":"infixl","precedence":7}},"sourceSpan":{"start":[41,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[41,18]}},{"children":[{"comments":null,"title":"addRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]}]}]},null]}},"sourceSpan":{"start":[100,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[100,92]}},{"comments":null,"title":"mulRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]}]}]},null]}},"sourceSpan":{"start":[101,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[101,92]}},{"comments":null,"title":"oneRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"ForAll","contents":["rproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rproxy"},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]}]},null]},null]}},"sourceSpan":{"start":[102,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[102,85]}},{"comments":null,"title":"zeroRecord","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"ForAll","contents":["rproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rproxy"},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}]}]},null]},null]}},"sourceSpan":{"start":[103,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[103,86]}},{"comments":null,"title":"semiringRecordNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"SemiringRecord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"REmpty"}]}},"sourceSpan":{"start":[105,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[109,22]}},{"comments":null,"title":"semiringRecordCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Prim","Row"],"Cons"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"},{"annotation":[],"tag":"TypeVar","contents":"focus"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"},{"annotation":[],"tag":"TypeVar","contents":"subrow"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"SemiringRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"subrowTail"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"SemiringRecord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]},{"annotation":[],"tag":"TypeVar","contents":"subrow"}]}},"sourceSpan":{"start":[111,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[142,76]}}],"comments":null,"title":"SemiringRecord","info":{"fundeps":[[["rowlist"],["subrow"]]],"arguments":[["rowlist",null],["row",null],["subrow",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[99,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[103,86]}}]},{"reExports":[],"name":"Data.Semiring.Generic","comments":null,"declarations":[{"children":[{"comments":null,"title":"genericAdd'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[8,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring/Generic.purs","end":[8,30]}},{"comments":null,"title":"genericZero'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[9,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring/Generic.purs","end":[9,20]}},{"comments":null,"title":"genericMul'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[10,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring/Generic.purs","end":[10,30]}},{"comments":null,"title":"genericOne'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[11,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring/Generic.purs","end":[11,20]}},{"comments":null,"title":"genericSemiringNoArguments","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring","Generic"],"GenericSemiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoArguments"]}]}},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring/Generic.purs","end":[17,28]}},{"comments":null,"title":"genericSemiringArgument","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring","Generic"],"GenericSemiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Argument"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring/Generic.purs","end":[23,29]}},{"comments":null,"title":"genericSemiringProduct","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semiring","Generic"],"GenericSemiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semiring","Generic"],"GenericSemiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring","Generic"],"GenericSemiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Product"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring/Generic.purs","end":[29,48]}},{"comments":null,"title":"genericSemiringConstructor","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semiring","Generic"],"GenericSemiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring","Generic"],"GenericSemiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Constructor"]},{"annotation":[],"tag":"TypeVar","contents":"name"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring/Generic.purs","end":[35,40]}}],"comments":null,"title":"GenericSemiring","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[7,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring/Generic.purs","end":[11,20]}},{"children":[],"comments":"A `Generic` implementation of the `zero` member from the `Semiring` type class.\n","title":"genericZero","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Semiring","Generic"],"GenericSemiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]},null]}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring/Generic.purs","end":[38,71]}},{"children":[],"comments":"A `Generic` implementation of the `one` member from the `Semiring` type class.\n","title":"genericOne","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Semiring","Generic"],"GenericSemiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]},null]}},"sourceSpan":{"start":[42,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring/Generic.purs","end":[42,70]}},{"children":[],"comments":"A `Generic` implementation of the `add` member from the `Semiring` type class.\n","title":"genericAdd","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Semiring","Generic"],"GenericSemiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]},null]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring/Generic.purs","end":[46,80]}},{"children":[],"comments":"A `Generic` implementation of the `mul` member from the `Semiring` type class.\n","title":"genericMul","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Semiring","Generic"],"GenericSemiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]},null]}},"sourceSpan":{"start":[50,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring/Generic.purs","end":[50,80]}}]},{"reExports":[],"name":"Data.Show","comments":null,"declarations":[{"children":[{"comments":null,"title":"show","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[18,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[18,22]}},{"comments":null,"title":"showBoolean","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[20,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[22,23]}},{"comments":null,"title":"showInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[24,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[25,21]}},{"comments":null,"title":"showNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[28,24]}},{"comments":null,"title":"showChar","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Char"]}]}},"sourceSpan":{"start":[30,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[31,22]}},{"comments":null,"title":"showString","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[33,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[34,24]}},{"comments":null,"title":"showArray","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[37,28]}},{"comments":null,"title":"showProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[40,19]}},{"comments":null,"title":"showProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[42,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[43,20]}},{"comments":null,"title":"showProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[45,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[46,20]}},{"comments":null,"title":"showRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rs"},{"annotation":[],"tag":"TypeVar","contents":"ls"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Show"],"ShowRecordFields"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"ls"},{"annotation":[],"tag":"TypeVar","contents":"rs"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"rs"}]}]}},"sourceSpan":{"start":[48,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[51,52]}}],"comments":"The `Show` type class represents those types which can be converted into\na human-readable `String` representation.\n\nWhile not required, it is recommended that for any expression `x`, the\nstring `show x` be executable PureScript code which evaluates to the same\nvalue as the expression `x`.\n","title":"Show","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[17,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[18,22]}},{"children":[{"comments":null,"title":"showRecordFields","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["rlproxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"rlproxy"},{"annotation":[],"tag":"TypeVar","contents":"rowlist"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}]}]},null]}},"sourceSpan":{"start":[57,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[57,84]}},{"comments":null,"title":"showRecordFieldsNil","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"ShowRecordFields"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Nil"]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}},"sourceSpan":{"start":[59,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[60,28]}},{"comments":null,"title":"showRecordFieldsCons","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"key"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Show"],"ShowRecordFields"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"focus"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"ShowRecordFields"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim","RowList"],"Cons"]},{"annotation":[],"tag":"TypeVar","contents":"key"}]},{"annotation":[],"tag":"TypeVar","contents":"focus"}]},{"annotation":[],"tag":"TypeVar","contents":"rowlistTail"}]}]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}},"sourceSpan":{"start":[62,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[73,66]}}],"comments":null,"title":"ShowRecordFields","info":{"fundeps":[],"arguments":[["rowlist",null],["row",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[56,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[57,84]}}]},{"reExports":[],"name":"Data.Show.Generic","comments":null,"declarations":[{"children":[{"comments":null,"title":"genericShow'","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[15,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show/Generic.purs","end":[15,30]}},{"comments":null,"title":"genericShowNoConstructors","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show","Generic"],"GenericShow"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoConstructors"]}]}},"sourceSpan":{"start":[20,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show/Generic.purs","end":[21,34]}},{"comments":null,"title":"genericShowSum","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show","Generic"],"GenericShow"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Show","Generic"],"GenericShow"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show","Generic"],"GenericShow"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Sum"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show/Generic.purs","end":[28,40]}},{"comments":null,"title":"genericShowConstructor","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show","Generic"],"GenericShowArgs"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"name"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show","Generic"],"GenericShow"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Constructor"]},{"annotation":[],"tag":"TypeVar","contents":"name"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[35,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show/Generic.purs","end":[44,49]}}],"comments":null,"title":"GenericShow","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[14,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show/Generic.purs","end":[15,30]}},{"children":[],"comments":"A `Generic` implementation of the `show` member from the `Show` type class.\n","title":"genericShow","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["rep",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Generic","Rep"],"Generic"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Show","Generic"],"GenericShow"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rep"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}]}]},null]},null]}},"sourceSpan":{"start":[50,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show/Generic.purs","end":[50,77]}},{"children":[{"comments":null,"title":"genericShowArgs","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}]}},"sourceSpan":{"start":[18,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show/Generic.purs","end":[18,39]}},{"comments":null,"title":"genericShowArgsNoArguments","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show","Generic"],"GenericShowArgs"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"NoArguments"]}]}},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show/Generic.purs","end":[24,25]}},{"comments":null,"title":"genericShowArgsProduct","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show","Generic"],"GenericShowArgs"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Show","Generic"],"GenericShowArgs"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show","Generic"],"GenericShowArgs"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Product"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[30,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show/Generic.purs","end":[33,73]}},{"comments":null,"title":"genericShowArgsArgument","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show","Generic"],"GenericShowArgs"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Generic","Rep"],"Argument"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show/Generic.purs","end":[47,42]}}],"comments":null,"title":"GenericShowArgs","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[17,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show/Generic.purs","end":[18,39]}}]},{"reExports":[],"name":"Data.Symbol","comments":null,"declarations":[{"children":[{"comments":null,"title":"reflectSymbol","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["proxy",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"proxy"},{"annotation":[],"tag":"TypeVar","contents":"sym"}]}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]},null]}},"sourceSpan":{"start":[24,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Symbol.purs","end":[24,53]}}],"comments":"A class for known symbols\n","title":"IsSymbol","info":{"fundeps":[],"arguments":[["sym",{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Symbol"]}]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Symbol.purs","end":[24,53]}},{"children":[],"comments":null,"title":"reifySymbol","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["proxy",{"annotation":[],"tag":"ForAll","contents":["r",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"ForAll","contents":["sym",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Symbol"],"IsSymbol"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"sym"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"proxy"},{"annotation":[],"tag":"TypeVar","contents":"sym"}]}]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]},null]}}]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]},null]},null]}},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Symbol.purs","end":[29,91]}},{"children":[{"comments":null,"title":"SProxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":null,"title":"SProxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["sym",null]]},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Symbol.purs","end":[13,25]}}]},{"reExports":[],"name":"Data.Unit","comments":null,"declarations":[{"children":[{"comments":null,"title":"showUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[18,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Unit.purs","end":[19,18]}}],"comments":"The `Unit` type has a single inhabitant, called `unit`. It represents\nvalues with no computational content.\n\n`Unit` is often used, wrapped in a monadic type constructor, as the\nreturn type of a computation where only the _effects_ are important.\n\nWhen returning a value of type `Unit` from an FFI function, it is\nrecommended to use `undefined`, or not return a value at all.\n","title":"Unit","info":{"kind":{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Type"]},"declType":"externData"},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Unit.purs","end":[13,33]}},{"children":[],"comments":"`unit` is the sole inhabitant of the `Unit` type.\n","title":"unit","info":{"declType":"value","type":{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Unit.purs","end":[16,28]}}]},{"reExports":[],"name":"Data.Void","comments":null,"declarations":[{"children":[{"comments":null,"title":"showVoid","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Void"],"Void"]}]}},"sourceSpan":{"start":[24,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Void.purs","end":[25,16]}}],"comments":"An uninhabited data type. In other words, one can never create\na runtime value of type `Void` becaue no such value exists.\n\n`Void` is useful to eliminate the possibility of a value being created.\nFor example, a value of type `Either Void Boolean` can never have\na Left value created in PureScript.\n\nThis should not be confused with the keyword `void` that commonly appears in\nC-family languages, such as Java:\n```\npublic class Foo {\n void doSomething() { System.out.println(\"hello world!\"); }\n}\n```\n\nIn PureScript, one often uses `Unit` to achieve similar effects as\nthe `void` of C-family languages above.\n","title":"Void","info":{"declType":"data","dataDeclType":"newtype","typeArguments":[]},"sourceSpan":{"start":[22,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Void.purs","end":[22,25]}},{"children":[],"comments":"Eliminator for the `Void` type.\nUseful for stating that some code branch is impossible because you've\n\"acquired\" a value of type `Void` (which you can't).\n\n```purescript\nrightOnly :: forall t . Either Void t -> t\nrightOnly (Left v) = absurd v\nrightOnly (Right t) = t\n```\n","title":"absurd","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Void"],"Void"]}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},null]}},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Void.purs","end":[36,30]}}]},{"reExports":[{"moduleName":{"package":null,"item":["Control","Applicative"]},"declarations":[{"children":[{"comments":null,"title":"pure","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]}},"sourceSpan":{"start":[34,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[34,29]}},{"comments":null,"title":"applicativeFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[37,15]}},{"comments":null,"title":"applicativeArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[40,15]}},{"comments":null,"title":"applicativeProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Applicative"],"Applicative"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[42,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[43,17]}}],"comments":"The `Applicative` type class extends the [`Apply`](#apply) type class\nwith a `pure` function, which can be used to create values of type `f a`\nfrom values of type `a`.\n\nWhere [`Apply`](#apply) provides the ability to lift functions of two or\nmore arguments to functions whose arguments are wrapped using `f`, and\n[`Functor`](#functor) provides the ability to lift functions of one\nargument, `pure` can be seen as the function which lifts functions of\n_zero_ arguments. That is, `Applicative` functors support a lifting\noperation for any number of function arguments.\n\nInstances must satisfy the following laws in addition to the `Apply`\nlaws:\n\n- Identity: `(pure identity) <*> v = v`\n- Composition: `pure (<<<) <*> f <*> g <*> h = f <*> (g <*> h)`\n- Homomorphism: `(pure f) <*> (pure x) = pure (f x)`\n- Interchange: `u <*> (pure y) = (pure (_ $ y)) <*> u`\n","title":"Applicative","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Control","Apply"],"Apply"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[33,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[34,29]}},{"children":[],"comments":"Perform an applicative action when a condition is true.\n","title":"when","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Applicative"],"Applicative"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]}]},null]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[61,63]}},{"children":[],"comments":"Perform an applicative action unless a condition is true.\n","title":"unless","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Applicative"],"Applicative"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]}]},null]}},"sourceSpan":{"start":[66,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[66,65]}},{"children":[],"comments":"`liftA1` provides a default implementation of `(<$>)` for any\n[`Applicative`](#applicative) functor, without using `(<$>)` as provided\nby the [`Functor`](#functor)-[`Applicative`](#applicative) superclass\nrelationship.\n\n`liftA1` can therefore be used to write [`Functor`](#functor) instances\nas follows:\n\n```purescript\ninstance functorF :: Functor F where\n map = liftA1\n```\n","title":"liftA1","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Applicative"],"Applicative"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[57,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Applicative.purs","end":[57,64]}}]},{"moduleName":{"package":null,"item":["Control","Apply"]},"declarations":[{"children":[{"comments":null,"title":"apply","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]},null]},null]}},"sourceSpan":{"start":[46,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[46,48]}},{"comments":null,"title":"applyFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[50,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[51,26]}},{"comments":null,"title":"applyArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[54,21]}},{"comments":null,"title":"applyProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Apply"],"Apply"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[58,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[59,20]}}],"comments":"The `Apply` class provides the `(<*>)` which is used to apply a function\nto an argument under a type constructor.\n\n`Apply` can be used to lift functions of two or more arguments to work on\nvalues wrapped with the type constructor `f`. It might also be understood\nin terms of the `lift2` function:\n\n```purescript\nlift2 :: forall f a b c. Apply f => (a -> b -> c) -> f a -> f b -> f c\nlift2 f a b = f <$> a <*> b\n```\n\n`(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts\nthe function application operator `($)` to arguments wrapped with the\ntype constructor `f`.\n\nPut differently...\n```\nfoo =\n functionTakingNArguments <$> computationProducingArg1\n <*> computationProducingArg2\n <*> ...\n <*> computationProducingArgN\n```\n\nInstances must satisfy the following law in addition to the `Functor`\nlaws:\n\n- Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`\n\nFormally, `Apply` represents a strong lax semi-monoidal endofunctor.\n","title":"Apply","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[45,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[46,48]}},{"children":[],"comments":null,"title":"(<*>)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"apply"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[48,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[48,22]}},{"children":[],"comments":null,"title":"(<*)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"applyFirst"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[65,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[65,26]}},{"children":[],"comments":null,"title":"(*>)","info":{"declType":"alias","alias":[["Control","Apply"],{"Right":{"Left":{"Ident":"applySecond"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[71,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Apply.purs","end":[71,27]}}]},{"moduleName":{"package":null,"item":["Control","Bind"]},"declarations":[{"children":[{"comments":null,"title":"bind","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]},null]},null]}},"sourceSpan":{"start":[51,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[51,47]}},{"comments":null,"title":"bindFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[65,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[66,25]}},{"comments":"The `bind`/`>>=` function for `Array` works by applying a function to\neach element in the array, and flattening the results into a single,\nnew array.\n\nArray's `bind`/`>>=` works like a nested for loop. Each `bind` adds\nanother level of nesting in the loop. For example:\n```\nfoo :: Array String\nfoo =\n [\"a\", \"b\"] >>= \\eachElementInArray1 ->\n [\"c\", \"d\"] >>= \\eachElementInArray2\n pure (eachElementInArray1 <> eachElementInArray2)\n\n-- In other words...\nfoo\n-- ... is the same as...\n[ (\"a\" <> \"c\"), (\"a\" <> \"d\"), (\"b\" <> \"c\"), (\"b\" <> \"d\") ]\n-- which simplifies to...\n[ \"ac\", \"ad\", \"bc\", \"bd\" ]\n```\n","title":"bindArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[88,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[89,19]}},{"comments":null,"title":"bindProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Bind"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[93,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[94,19]}}],"comments":"The `Bind` type class extends the [`Apply`](#apply) type class with a\n\"bind\" operation `(>>=)` which composes computations in sequence, using\nthe return value of one computation to determine the next computation.\n\nThe `>>=` operator can also be expressed using `do` notation, as follows:\n\n```purescript\nx >>= f = do y <- x\n f y\n```\n\nwhere the function argument of `f` is given the name `y`.\n\nInstances must satisfy the following laws in addition to the `Apply`\nlaws:\n\n- Associativity: `(x >>= f) >>= g = x >>= (\\k -> f k >>= g)`\n- Apply Superclass: `apply f x = f >>= \\f’ -> map f’ x`\n\nAssociativity tells us that we can regroup operations which use `do`\nnotation so that we can unambiguously write, for example:\n\n```purescript\ndo x <- m1\n y <- m2 x\n m3 x y\n```\n","title":"Bind","info":{"fundeps":[],"arguments":[["m",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Control","Apply"],"Apply"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[50,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[51,47]}},{"children":[{"comments":null,"title":"discard","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Bind"],"Bind"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]}},"sourceSpan":{"start":[102,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[102,60]}},{"comments":null,"title":"discardUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Discard"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[104,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[105,17]}},{"comments":null,"title":"discardProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Discard"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[107,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[108,17]}},{"comments":null,"title":"discardProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Discard"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[110,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[111,17]}},{"comments":null,"title":"discardProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Bind"],"Discard"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[113,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[114,17]}}],"comments":"A class for types whose values can safely be discarded\nin a `do` notation block.\n\nAn example is the `Unit` type, since there is only one\npossible value which can be returned.\n","title":"Discard","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[101,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[102,60]}},{"children":[],"comments":"Collapse two applications of a monadic type constructor into one.\n","title":"join","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Bind"],"Bind"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]},null]},null]}},"sourceSpan":{"start":[117,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[117,45]}},{"children":[],"comments":"Execute a monadic action if a condition holds.\n\nFor example:\n\n```purescript\nmain = ifM ((< 0.5) <$> random)\n (trace \"Heads\")\n (trace \"Tails\")\n```\n","title":"ifM","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Bind"],"Bind"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]}]},null]},null]}},"sourceSpan":{"start":[149,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[149,60]}},{"children":[],"comments":null,"title":"(>>=)","info":{"declType":"alias","alias":[["Control","Bind"],{"Right":{"Left":{"Ident":"bind"}}}],"fixity":{"associativity":"infixl","precedence":1}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[53,21]}},{"children":[],"comments":null,"title":"(>=>)","info":{"declType":"alias","alias":[["Control","Bind"],{"Right":{"Left":{"Ident":"composeKleisli"}}}],"fixity":{"associativity":"infixr","precedence":1}},"sourceSpan":{"start":[132,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[132,31]}},{"children":[],"comments":null,"title":"(=<<)","info":{"declType":"alias","alias":[["Control","Bind"],{"Right":{"Left":{"Ident":"bindFlipped"}}}],"fixity":{"associativity":"infixr","precedence":1}},"sourceSpan":{"start":[63,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[63,28]}},{"children":[],"comments":null,"title":"(<=<)","info":{"declType":"alias","alias":[["Control","Bind"],{"Right":{"Left":{"Ident":"composeKleisliFlipped"}}}],"fixity":{"associativity":"infixr","precedence":1}},"sourceSpan":{"start":[138,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Bind.purs","end":[138,38]}}]},{"moduleName":{"package":null,"item":["Control","Category"]},"declarations":[{"children":[{"comments":null,"title":"identity","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["t",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"t"}]},{"annotation":[],"tag":"TypeVar","contents":"t"}]},null]}},"sourceSpan":{"start":[18,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Category.purs","end":[18,30]}},{"comments":null,"title":"categoryFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Category"],"Category"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]}]}},"sourceSpan":{"start":[20,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Category.purs","end":[21,17]}}],"comments":null,"title":"Category","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Control","Semigroupoid"],"Semigroupoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[17,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Category.purs","end":[18,30]}}]},{"moduleName":{"package":null,"item":["Control","Monad"]},"declarations":[{"children":[{"comments":null,"title":"monadFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Monad"],"Monad"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[33,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[33,35]}},{"comments":null,"title":"monadArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Monad"],"Monad"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[35,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[35,35]}},{"comments":null,"title":"monadProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Monad"],"Monad"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[37,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[37,35]}}],"comments":"The `Monad` type class combines the operations of the `Bind` and\n`Applicative` type classes. Therefore, `Monad` instances represent type\nconstructors which support sequential composition, and also lifting of\nfunctions of arbitrary arity.\n\nInstances must satisfy the following laws in addition to the\n`Applicative` and `Bind` laws:\n\n- Left Identity: `pure x >>= f = f x`\n- Right Identity: `x >>= pure = x`\n","title":"Monad","info":{"fundeps":[],"arguments":[["m",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Control","Applicative"],"Applicative"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Control","Bind"],"Bind"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[31,41]}},{"children":[],"comments":"Perform a monadic action when a condition is true, where the conditional\nvalue is also in a monadic context.\n","title":"whenM","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Monad"],"Monad"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]}]},null]}},"sourceSpan":{"start":[57,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[57,60]}},{"children":[],"comments":"Perform a monadic action unless a condition is true, where the conditional\nvalue is also in a monadic context.\n","title":"unlessM","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Monad"],"Monad"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]}]},null]}},"sourceSpan":{"start":[64,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[64,62]}},{"children":[],"comments":"`liftM1` provides a default implementation of `(<$>)` for any\n[`Monad`](#monad), without using `(<$>)` as provided by the\n[`Functor`](#functor)-[`Monad`](#monad) superclass relationship.\n\n`liftM1` can therefore be used to write [`Functor`](#functor) instances\nas follows:\n\n```purescript\ninstance functorF :: Functor F where\n map = liftM1\n```\n","title":"liftM1","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Monad"],"Monad"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[50,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[50,58]}},{"children":[],"comments":"`ap` provides a default implementation of `(<*>)` for any `Monad`, without\nusing `(<*>)` as provided by the `Apply`-`Monad` superclass relationship.\n\n`ap` can therefore be used to write `Apply` instances as follows:\n\n```purescript\ninstance applyF :: Apply F where\n apply = ap\n```\n","title":"ap","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["m",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Control","Monad"],"Monad"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"m"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[82,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Monad.purs","end":[82,56]}}]},{"moduleName":{"package":null,"item":["Control","Semigroupoid"]},"declarations":[{"children":[{"comments":null,"title":"compose","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["c",{"annotation":[],"tag":"ForAll","contents":["d",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"c"}]},{"annotation":[],"tag":"TypeVar","contents":"d"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"a"},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"d"}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[14,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[14,51]}},{"comments":null,"title":"semigroupoidFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Control","Semigroupoid"],"Semigroupoid"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]}]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[17,26]}}],"comments":null,"title":"Semigroupoid","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[14,51]}},{"children":[],"comments":null,"title":"(>>>)","info":{"declType":"alias","alias":[["Control","Semigroupoid"],{"Right":{"Left":{"Ident":"composeFlipped"}}}],"fixity":{"associativity":"infixr","precedence":9}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[25,31]}},{"children":[],"comments":null,"title":"(<<<)","info":{"declType":"alias","alias":[["Control","Semigroupoid"],{"Right":{"Left":{"Ident":"compose"}}}],"fixity":{"associativity":"infixr","precedence":9}},"sourceSpan":{"start":[19,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Control/Semigroupoid.purs","end":[19,24]}}]},{"moduleName":{"package":null,"item":["Data","Boolean"]},"declarations":[{"children":[],"comments":"An alias for `true`, which can be useful in guard clauses:\n\n```purescript\nmax x y | x >= y = x\n | otherwise = y\n```\n","title":"otherwise","info":{"declType":"value","type":{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}},"sourceSpan":{"start":[9,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Boolean.purs","end":[9,21]}}]},{"moduleName":{"package":null,"item":["Data","BooleanAlgebra"]},"declarations":[{"children":[{"comments":null,"title":"booleanAlgebraBoolean","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[24,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[24,57]}},{"comments":null,"title":"booleanAlgebraUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[25,51]}},{"comments":null,"title":"booleanAlgebraFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","BooleanAlgebra"],"BooleanAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[26,73]}},{"comments":null,"title":"booleanAlgebraRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","BooleanAlgebra"],"BooleanAlgebraRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[27,123]}},{"comments":null,"title":"booleanAlgebraProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[28,57]}},{"comments":null,"title":"booleanAlgebraProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[29,59]}},{"comments":null,"title":"booleanAlgebraProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","BooleanAlgebra"],"BooleanAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[30,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[30,59]}}],"comments":"The `BooleanAlgebra` type class represents types that behave like boolean\nvalues.\n\nInstances should satisfy the following laws in addition to the\n`HeytingAlgebra` law:\n\n- Excluded middle:\n - `a || not a = tt`\n","title":"BooleanAlgebra","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[22,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/BooleanAlgebra.purs","end":[22,43]}}]},{"moduleName":{"package":null,"item":["Data","Bounded"]},"declarations":[{"children":[{"comments":null,"title":"top","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[24,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[24,11]}},{"comments":null,"title":"bottom","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[25,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[25,14]}},{"comments":null,"title":"boundedBoolean","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[29,17]}},{"comments":"The `Bounded` `Int` instance has `top :: Int` equal to 2^31 - 1,\nand `bottom :: Int` equal to -2^31, since these are the largest and smallest\nintegers representable by twos-complement 32-bit integers, respectively.\n","title":"boundedInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[36,21]}},{"comments":"Characters fall within the Unicode range.\n","title":"boundedChar","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Char"]}]}},"sourceSpan":{"start":[42,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[44,22]}},{"comments":null,"title":"boundedOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[51,14]}},{"comments":null,"title":"boundedUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[55,16]}},{"comments":null,"title":"boundedNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[60,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[62,24]}},{"comments":null,"title":"boundedProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[64,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[66,14]}},{"comments":null,"title":"boundedProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[68,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[70,15]}},{"comments":null,"title":"boundedProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[72,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[74,15]}},{"comments":null,"title":"boundedRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Bounded"],"BoundedRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Bounded"],"Bounded"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[107,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[113,67]}}],"comments":"The `Bounded` type class represents totally ordered types that have an\nupper and lower boundary.\n\nInstances should satisfy the following law in addition to the `Ord` laws:\n\n- Bounded: `bottom <= a <= top`\n","title":"Bounded","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Bounded.purs","end":[25,14]}}]},{"moduleName":{"package":null,"item":["Data","CommutativeRing"]},"declarations":[{"children":[{"comments":null,"title":"commutativeRingInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[25,51]}},{"comments":null,"title":"commutativeRingNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[26,57]}},{"comments":null,"title":"commutativeRingUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[27,53]}},{"comments":null,"title":"commutativeRingFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","CommutativeRing"],"CommutativeRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[28,76]}},{"comments":null,"title":"commutativeRingRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","CommutativeRing"],"CommutativeRingRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[29,126]}},{"comments":null,"title":"commutativeRingProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[30,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[30,59]}},{"comments":null,"title":"commutativeRingProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[31,61]}},{"comments":null,"title":"commutativeRingProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","CommutativeRing"],"CommutativeRing"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[32,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[32,61]}}],"comments":"The `CommutativeRing` class is for rings where multiplication is\ncommutative.\n\nInstances must satisfy the following law in addition to the `Ring`\nlaws:\n\n- Commutative multiplication: `a * b = b * a`\n","title":"CommutativeRing","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/CommutativeRing.purs","end":[23,34]}}]},{"moduleName":{"package":null,"item":["Data","DivisionRing"]},"declarations":[{"children":[{"comments":null,"title":"recip","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}},"sourceSpan":{"start":[30,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/DivisionRing.purs","end":[30,18]}},{"comments":null,"title":"divisionringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","DivisionRing"],"DivisionRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[54,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/DivisionRing.purs","end":[55,20]}}],"comments":"The `DivisionRing` class is for non-zero rings in which every non-zero\nelement has a multiplicative inverse. Division rings are sometimes also\ncalled *skew fields*.\n\nInstances must satisfy the following laws in addition to the `Ring` laws:\n\n- Non-zero ring: `one /= zero`\n- Non-zero multiplicative inverse: `recip a * a = a * recip a = one` for\n all non-zero `a`\n\nThe result of `recip zero` is left undefined; individual instances may\nchoose how to handle this case.\n\nIf a type has both `DivisionRing` and `CommutativeRing` instances, then\nit is a field and should have a `Field` instance.\n","title":"DivisionRing","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[29,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/DivisionRing.purs","end":[30,18]}}]},{"moduleName":{"package":null,"item":["Data","Eq"]},"declarations":[{"children":[{"comments":null,"title":"eq","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}},"sourceSpan":{"start":[29,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[29,26]}},{"comments":null,"title":"eqBoolean","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[41,21]}},{"comments":null,"title":"eqInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[44,17]}},{"comments":null,"title":"eqNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[47,20]}},{"comments":null,"title":"eqChar","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Char"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[50,18]}},{"comments":null,"title":"eqString","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[52,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[53,20]}},{"comments":null,"title":"eqUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[55,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[56,16]}},{"comments":null,"title":"eqVoid","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Void"],"Void"]}]}},"sourceSpan":{"start":[58,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[59,16]}},{"comments":null,"title":"eqArray","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[62,22]}},{"comments":null,"title":"eqRec","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Eq"],"EqRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[64,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[65,38]}},{"comments":null,"title":"eqProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[67,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[68,16]}},{"comments":null,"title":"eqProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[70,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[71,16]}},{"comments":null,"title":"eqProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[73,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[74,16]}}],"comments":"The `Eq` type class represents types which support decidable equality.\n\n`Eq` instances should satisfy the following laws:\n\n- Reflexivity: `x == x = true`\n- Symmetry: `x == y = y == x`\n- Transitivity: if `x == y` and `y == z` then `x == z`\n\n**Note:** The `Number` type is not an entirely law abiding member of this\nclass due to the presence of `NaN`, since `NaN /= NaN`. Additionally,\ncomputing with `Number` can result in a loss of precision, so sometimes\nvalues that should be equivalent are not.\n","title":"Eq","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[29,26]}},{"children":[],"comments":"`notEq` tests whether one value is _not equal_ to another. Shorthand for\n`not (eq x y)`.\n","title":"notEq","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}]},null]}},"sourceSpan":{"start":[35,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[35,45]}},{"children":[],"comments":null,"title":"(==)","info":{"declType":"alias","alias":[["Data","Eq"],{"Right":{"Left":{"Ident":"eq"}}}],"fixity":{"associativity":"infix","precedence":4}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[31,17]}},{"children":[],"comments":null,"title":"(/=)","info":{"declType":"alias","alias":[["Data","Eq"],{"Right":{"Left":{"Ident":"notEq"}}}],"fixity":{"associativity":"infix","precedence":4}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Eq.purs","end":[38,20]}}]},{"moduleName":{"package":null,"item":["Data","EuclideanRing"]},"declarations":[{"children":[{"comments":null,"title":"degree","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[64,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[64,21]}},{"comments":null,"title":"div","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[65,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[65,21]}},{"comments":null,"title":"mod","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[66,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[66,21]}},{"comments":null,"title":"euclideanRingInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","EuclideanRing"],"EuclideanRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[70,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[73,15]}},{"comments":null,"title":"euclideanRingNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","EuclideanRing"],"EuclideanRing"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[75,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[78,16]}}],"comments":"The `EuclideanRing` class is for commutative rings that support division.\nThe mathematical structure this class is based on is sometimes also called\na *Euclidean domain*.\n\nInstances must satisfy the following laws in addition to the `Ring`\nlaws:\n\n- Integral domain: `one /= zero`, and if `a` and `b` are both nonzero then\n so is their product `a * b`\n- Euclidean function `degree`:\n - Nonnegativity: For all nonzero `a`, `degree a >= 0`\n - Quotient/remainder: For all `a` and `b`, where `b` is nonzero,\n let `q = a / b` and ``r = a `mod` b``; then `a = q*b + r`, and also\n either `r = zero` or `degree r < degree b`\n- Submultiplicative euclidean function:\n - For all nonzero `a` and `b`, `degree a <= degree (a * b)`\n\nThe behaviour of division by `zero` is unconstrained by these laws,\nmeaning that individual instances are free to choose how to behave in this\ncase. Similarly, there are no restrictions on what the result of\n`degree zero` is; it doesn't make sense to ask for `degree zero` in the\nsame way that it doesn't make sense to divide by `zero`, so again,\nindividual instances may choose how to handle this case.\n\nFor any `EuclideanRing` which is also a `Field`, one valid choice\nfor `degree` is simply `const 1`. In fact, unless there's a specific\nreason not to, `Field` types should normally use this definition of\n`degree`.\n\nThe `EuclideanRing Int` instance is one of the most commonly used\n`EuclideanRing` instances and deserves a little more discussion. In\nparticular, there are a few different sensible law-abiding implementations\nto choose from, with slightly different behaviour in the presence of\nnegative dividends or divisors. The most common definitions are \"truncating\"\ndivision, where the result of `a / b` is rounded towards 0, and \"Knuthian\"\nor \"flooring\" division, where the result of `a / b` is rounded towards\nnegative infinity. A slightly less common, but arguably more useful, option\nis \"Euclidean\" division, which is defined so as to ensure that ``a `mod` b``\nis always nonnegative. With Euclidean division, `a / b` rounds towards\nnegative infinity if the divisor is positive, and towards positive infinity\nif the divisor is negative. Note that all three definitions are identical if\nwe restrict our attention to nonnegative dividends and divisors.\n\nIn versions 1.x, 2.x, and 3.x of the Prelude, the `EuclideanRing Int`\ninstance used truncating division. As of 4.x, the `EuclideanRing Int`\ninstance uses Euclidean division. Additional functions `quot` and `rem` are\nsupplied if truncating division is desired.\n","title":"EuclideanRing","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","CommutativeRing"],"CommutativeRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[63,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[66,21]}},{"children":[],"comments":"The *least common multiple* of two values.\n","title":"lcm","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","EuclideanRing"],"EuclideanRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]}},"sourceSpan":{"start":[94,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[94,56]}},{"children":[],"comments":"The *greatest common divisor* of two values.\n","title":"gcd","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","EuclideanRing"],"EuclideanRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]}},"sourceSpan":{"start":[87,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[87,56]}},{"children":[],"comments":null,"title":"(/)","info":{"declType":"alias","alias":[["Data","EuclideanRing"],{"Right":{"Left":{"Ident":"div"}}}],"fixity":{"associativity":"infixl","precedence":7}},"sourceSpan":{"start":[68,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/EuclideanRing.purs","end":[68,18]}}]},{"moduleName":{"package":null,"item":["Data","Field"]},"declarations":[{"children":[{"comments":null,"title":"field","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","EuclideanRing"],"EuclideanRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","DivisionRing"],"DivisionRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Field"],"Field"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}},"sourceSpan":{"start":[41,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Field.purs","end":[41,63]}}],"comments":"The `Field` class is for types that are (commutative) fields.\n\nMathematically, a field is a ring which is commutative and in which every\nnonzero element has a multiplicative inverse; these conditions correspond\nto the `CommutativeRing` and `DivisionRing` classes in PureScript\nrespectively. However, the `Field` class has `EuclideanRing` and\n`DivisionRing` as superclasses, which seems like a stronger requirement\n(since `CommutativeRing` is a superclass of `EuclideanRing`). In fact, it\nis not stronger, since any type which has law-abiding `CommutativeRing`\nand `DivisionRing` instances permits exactly one law-abiding\n`EuclideanRing` instance. We use a `EuclideanRing` superclass here in\norder to ensure that a `Field` constraint on a function permits you to use\n`div` on that type, since `div` is a member of `EuclideanRing`.\n\nThis class has no laws or members of its own; it exists as a convenience,\nso a single constraint can be used when field-like behaviour is expected.\n\nThis module also defines a single `Field` instance for any type which has\nboth `EuclideanRing` and `DivisionRing` instances. Any other instance\nwould overlap with this instance, so no other `Field` instances should be\ndefined in libraries. Instead, simply define `EuclideanRing` and\n`DivisionRing` instances, and this will permit your type to be used with a\n`Field` constraint.\n","title":"Field","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","EuclideanRing"],"EuclideanRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","DivisionRing"],"DivisionRing"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Field.purs","end":[39,51]}}]},{"moduleName":{"package":null,"item":["Data","Function"]},"declarations":[{"children":[],"comments":"Flips the order of the arguments to a function of two arguments.\n\n```purescript\nflip const 1 2 = const 2 1 = 2\n```\n","title":"flip","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["c",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"c"}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[21,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Function.purs","end":[21,51]}},{"children":[],"comments":"Returns its first argument and ignores its second.\n\n```purescript\nconst 1 \"hello\" = 1\n```\n\nIt can also be thought of as creating a function that ignores its argument:\n\n```purescript\nconst 1 = \\_ -> 1\n```\n","title":"const","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"b"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]},null]}},"sourceSpan":{"start":[35,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Function.purs","end":[35,33]}},{"children":[],"comments":"Applies a function to an argument: the reverse of `(#)`.\n\n```purescript\nlength $ groupBy productCategory $ filter isInStock $ products\n```\n\nis equivalent to:\n\n```purescript\nlength (groupBy productCategory (filter isInStock products))\n```\n\nOr another alternative equivalent, applying chain of composed functions to\na value:\n\n```purescript\nlength <<< groupBy productCategory <<< filter isInStock $ products\n```\n","title":"($)","info":{"declType":"alias","alias":[["Data","Function"],{"Right":{"Left":{"Ident":"apply"}}}],"fixity":{"associativity":"infixr","precedence":0}},"sourceSpan":{"start":[62,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Function.purs","end":[62,20]}},{"children":[],"comments":"Applies an argument to a function: the reverse of `($)`.\n\n```purescript\nproducts # filter isInStock # groupBy productCategory # length\n```\n\nis equivalent to:\n\n```purescript\nlength (groupBy productCategory (filter isInStock products))\n```\n\nOr another alternative equivalent, applying a value to a chain of composed\nfunctions:\n\n```purescript\nproducts # filter isInStock >>> groupBy productCategory >>> length\n```\n","title":"(#)","info":{"declType":"alias","alias":[["Data","Function"],{"Right":{"Left":{"Ident":"applyFlipped"}}}],"fixity":{"associativity":"infixl","precedence":1}},"sourceSpan":{"start":[88,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Function.purs","end":[88,27]}}]},{"moduleName":{"package":null,"item":["Data","Functor"]},"declarations":[{"children":[{"comments":null,"title":"map","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]},null]},null]}},"sourceSpan":{"start":[26,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[26,44]}},{"comments":null,"title":"functorFn","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[41,16]}},{"comments":null,"title":"functorArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[44,17]}},{"comments":null,"title":"functorProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Functor"],"Functor"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[47,18]}}],"comments":"A `Functor` is a type constructor which supports a mapping operation\n`map`.\n\n`map` can be used to turn functions `a -> b` into functions\n`f a -> f b` whose argument and return types use the type constructor `f`\nto represent some computational context.\n\nInstances must satisfy the following laws:\n\n- Identity: `map identity = identity`\n- Composition: `map (f <<< g) = map f <<< map g`\n","title":"Functor","info":{"fundeps":[],"arguments":[["f",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[25,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[26,44]}},{"children":[],"comments":"The `void` function is used to ignore the type wrapped by a\n[`Functor`](#functor), replacing it with `Unit` and keeping only the type\ninformation provided by the type constructor itself.\n\n`void` is often useful when using `do` notation to change the return type\nof a monadic computation:\n\n```purescript\nmain = forE 1 10 \\n -> void do\n print n\n print (n * n)\n```\n","title":"void","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}]}]},null]},null]}},"sourceSpan":{"start":[63,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[63,47]}},{"children":[],"comments":"Apply a value in a computational context to a value in no context.\n\nGeneralizes `flip`.\n\n```purescript\nlongEnough :: String -> Bool\nhasSymbol :: String -> Bool\nhasDigit :: String -> Bool\npassword :: String\n\nvalidate :: String -> Array Bool\nvalidate = flap [longEnough, hasSymbol, hasDigit]\n```\n\n```purescript\nflap (-) 3 4 == 1\nthreeve <$> Just 1 <@> 'a' <*> Just true == Just (threeve 1 'a' true)\n```\n","title":"flap","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["f",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Functor"],"Functor"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"f"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeVar","contents":"f"},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[97,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[97,58]}},{"children":[],"comments":null,"title":"(<@>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"flap"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[100,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[100,21]}},{"children":[],"comments":null,"title":"(<$>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"map"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[28,20]}},{"children":[],"comments":null,"title":"(<$)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"voidRight"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[71,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[71,25]}},{"children":[],"comments":null,"title":"(<#>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"mapFlipped"}}}],"fixity":{"associativity":"infixl","precedence":1}},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[38,27]}},{"children":[],"comments":null,"title":"($>)","info":{"declType":"alias","alias":[["Data","Functor"],{"Right":{"Left":{"Ident":"voidLeft"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[77,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Functor.purs","end":[77,24]}}]},{"moduleName":{"package":null,"item":["Data","HeytingAlgebra"]},"declarations":[{"children":[{"comments":null,"title":"conj","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[42,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[42,22]}},{"comments":null,"title":"disj","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[43,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[43,22]}},{"comments":null,"title":"not","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}},"sourceSpan":{"start":[44,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[44,16]}},{"comments":null,"title":"heytingAlgebraBoolean","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[55,16]}},{"comments":null,"title":"heytingAlgebraUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[57,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[63,15]}},{"comments":null,"title":"heytingAlgebraFunction","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebra"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[65,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[71,22]}},{"comments":null,"title":"heytingAlgebraProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[73,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[79,13]}},{"comments":null,"title":"heytingAlgebraProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[81,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[87,14]}},{"comments":null,"title":"heytingAlgebraProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[89,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[95,14]}},{"comments":null,"title":"heytingAlgebraRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","HeytingAlgebra"],"HeytingAlgebraRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","HeytingAlgebra"],"HeytingAlgebra"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[97,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[103,41]}}],"comments":"The `HeytingAlgebra` type class represents types that are bounded lattices with\nan implication operator such that the following laws hold:\n\n- Associativity:\n - `a || (b || c) = (a || b) || c`\n - `a && (b && c) = (a && b) && c`\n- Commutativity:\n - `a || b = b || a`\n - `a && b = b && a`\n- Absorption:\n - `a || (a && b) = a`\n - `a && (a || b) = a`\n- Idempotent:\n - `a || a = a`\n - `a && a = a`\n- Identity:\n - `a || ff = a`\n - `a && tt = a`\n- Implication:\n - ``a `implies` a = tt``\n - ``a && (a `implies` b) = a && b``\n - ``b && (a `implies` b) = b``\n - ``a `implies` (b && c) = (a `implies` b) && (a `implies` c)``\n- Complemented:\n - ``not a = a `implies` ff``\n","title":"HeytingAlgebra","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[38,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[44,16]}},{"children":[],"comments":null,"title":"(||)","info":{"declType":"alias","alias":[["Data","HeytingAlgebra"],{"Right":{"Left":{"Ident":"disj"}}}],"fixity":{"associativity":"infixr","precedence":2}},"sourceSpan":{"start":[47,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[47,20]}},{"children":[],"comments":null,"title":"(&&)","info":{"declType":"alias","alias":[["Data","HeytingAlgebra"],{"Right":{"Left":{"Ident":"conj"}}}],"fixity":{"associativity":"infixr","precedence":3}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/HeytingAlgebra.purs","end":[46,20]}}]},{"moduleName":{"package":null,"item":["Data","Monoid"]},"declarations":[{"children":[{"comments":null,"title":"mempty","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"m"}},"sourceSpan":{"start":[45,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[45,14]}},{"comments":null,"title":"monoidUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[47,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[48,16]}},{"comments":null,"title":"monoidOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[50,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[51,14]}},{"comments":null,"title":"monoidFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Monoid"],"Monoid"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[54,20]}},{"comments":null,"title":"monoidString","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[56,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[57,14]}},{"comments":null,"title":"monoidArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[59,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[60,14]}},{"comments":null,"title":"monoidRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Monoid"],"MonoidRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Monoid"],"Monoid"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[62,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[63,46]}}],"comments":"A `Monoid` is a `Semigroup` with a value `mempty`, which is both a\nleft and right unit for the associative operation `<>`:\n\n- Left unit: `(mempty <> x) = x`\n- Right unit: `(x <> mempty) = x`\n\n`Monoid`s are commonly used as the result of fold operations, where\n`<>` is used to combine individual results, and `mempty` gives the result\nof folding an empty collection of elements.\n\n### Newtypes for Monoid\n\nSome types (e.g. `Int`, `Boolean`) can implement multiple law-abiding\ninstances for `Monoid`. Let's use `Int` as an example\n1. `<>` could be `+` and `mempty` could be `0`\n2. `<>` could be `*` and `mempty` could be `1`.\n\nTo clarify these ambiguous situations, one should use the newtypes\ndefined in `Data.Monoid.` modules.\n\nIn the above ambiguous situation, we could use `Additive`\nfor the first situation or `Multiplicative` for the second one.\n","title":"Monoid","info":{"fundeps":[],"arguments":[["m",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"Semigroup"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"m"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[44,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Monoid.purs","end":[45,14]}}]},{"moduleName":{"package":null,"item":["Data","NaturalTransformation"]},"declarations":[{"children":[],"comments":null,"title":"type (~>)","info":{"declType":"alias","alias":[["Data","NaturalTransformation"],{"Left":"NaturalTransformation"}],"fixity":{"associativity":"infixr","precedence":4}},"sourceSpan":{"start":[20,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/NaturalTransformation.purs","end":[20,42]}}]},{"moduleName":{"package":null,"item":["Data","Ord"]},"declarations":[{"children":[{"comments":null,"title":"compare","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}]}},"sourceSpan":{"start":[38,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[38,32]}},{"comments":null,"title":"ordBoolean","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[41,36]}},{"comments":null,"title":"ordInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[44,32]}},{"comments":null,"title":"ordNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[47,35]}},{"comments":null,"title":"ordString","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[50,35]}},{"comments":null,"title":"ordChar","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Char"]}]}},"sourceSpan":{"start":[52,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[53,33]}},{"comments":null,"title":"ordUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[55,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[56,19]}},{"comments":null,"title":"ordVoid","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Void"],"Void"]}]}},"sourceSpan":{"start":[58,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[59,19]}},{"comments":null,"title":"ordProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[62,19]}},{"comments":null,"title":"ordProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[64,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[65,19]}},{"comments":null,"title":"ordProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[67,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[68,19]}},{"comments":null,"title":"ordArray","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[70,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[77,17]}},{"comments":null,"title":"ordOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[121,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[128,21]}},{"comments":null,"title":"ordRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ord"],"OrdRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ord"],"Ord"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[249,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[254,48]}}],"comments":"The `Ord` type class represents types which support comparisons with a\n_total order_.\n\n`Ord` instances should satisfy the laws of total orderings:\n\n- Reflexivity: `a <= a`\n- Antisymmetry: if `a <= b` and `b <= a` then `a = b`\n- Transitivity: if `a <= b` and `b <= c` then `a <= c`\n","title":"Ord","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Eq"],"Eq"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[37,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[38,32]}},{"children":[],"comments":"Take the minimum of two values. If they are considered equal, the first\nargument is chosen.\n","title":"min","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]},null]}},"sourceSpan":{"start":[165,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[165,38]}},{"children":[],"comments":"Take the maximum of two values. If they are considered equal, the first\nargument is chosen.\n","title":"max","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]},null]}},"sourceSpan":{"start":[174,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[174,38]}},{"children":[],"comments":"Compares two values by mapping them to a type with an `Ord` instance.\n","title":"comparing","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}}]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}]}}]}]},null]},null]}},"sourceSpan":{"start":[160,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[160,67]}},{"children":[],"comments":"Clamp a value between a minimum and a maximum. For example:\n\n``` purescript\nlet f = clamp 0 10\nf (-5) == 0\nf 5 == 5\nf 15 == 10\n```\n","title":"clamp","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}]}]},null]}},"sourceSpan":{"start":[189,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[189,45]}},{"children":[],"comments":"Test whether a value is between a minimum and a maximum (inclusive).\nFor example:\n\n``` purescript\nlet f = between 0 10\nf 0 == true\nf (-5) == false\nf 5 == true\nf 10 == true\nf 15 == false\n```\n","title":"between","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ord"],"Ord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]}]}]},null]}},"sourceSpan":{"start":[203,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[203,53]}},{"children":[],"comments":null,"title":"(>=)","info":{"declType":"alias","alias":[["Data","Ord"],{"Right":{"Left":{"Ident":"greaterThanOrEq"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[157,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[157,31]}},{"children":[],"comments":null,"title":"(>)","info":{"declType":"alias","alias":[["Data","Ord"],{"Right":{"Left":{"Ident":"greaterThan"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[156,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[156,26]}},{"children":[],"comments":null,"title":"(<=)","info":{"declType":"alias","alias":[["Data","Ord"],{"Right":{"Left":{"Ident":"lessThanOrEq"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[155,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[155,28]}},{"children":[],"comments":null,"title":"(<)","info":{"declType":"alias","alias":[["Data","Ord"],{"Right":{"Left":{"Ident":"lessThan"}}}],"fixity":{"associativity":"infixl","precedence":4}},"sourceSpan":{"start":[154,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ord.purs","end":[154,23]}}]},{"moduleName":{"package":null,"item":["Data","Ordering"]},"declarations":[{"children":[{"comments":null,"title":"LT","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"GT","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"EQ","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"eqOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Eq"],"Eq"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[15,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[19,19]}},{"comments":null,"title":"semigroupOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[21,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[24,18]}},{"comments":null,"title":"showOrdering","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ordering"],"Ordering"]}]}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[29,17]}}],"comments":"The `Ordering` data type represents the three possible outcomes of\ncomparing two values:\n\n`LT` - The first value is _less than_ the second.\n`GT` - The first value is _greater than_ the second.\n`EQ` - The first value is _equal to_ the second.\n","title":"Ordering","info":{"declType":"data","dataDeclType":"data","typeArguments":[]},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ordering.purs","end":[13,29]}}]},{"moduleName":{"package":null,"item":["Data","Ring"]},"declarations":[{"children":[{"comments":null,"title":"sub","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[24,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[24,21]}},{"comments":null,"title":"ringInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[28,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[29,15]}},{"comments":null,"title":"ringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[32,15]}},{"comments":null,"title":"ringUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[35,17]}},{"comments":null,"title":"ringFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[37,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[38,24]}},{"comments":null,"title":"ringProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[41,18]}},{"comments":null,"title":"ringProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[44,19]}},{"comments":null,"title":"ringProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[46,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[47,19]}},{"comments":null,"title":"ringRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Ring"],"RingRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Ring"],"Ring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[50,40]}}],"comments":"The `Ring` class is for types that support addition, multiplication,\nand subtraction operations.\n\nInstances must satisfy the following laws in addition to the `Semiring`\nlaws:\n\n- Additive inverse: `a - a = zero`\n- Compatibility of `sub` and `negate`: `a - b = a + (zero - b)`\n","title":"Ring","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}]},"sourceSpan":{"start":[23,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[24,21]}},{"children":[],"comments":"`negate x` can be used as a shorthand for `zero - x`.\n","title":"negate","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Data","Ring"],"Ring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]}},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[53,37]}},{"children":[],"comments":null,"title":"(-)","info":{"declType":"alias","alias":[["Data","Ring"],{"Right":{"Left":{"Ident":"sub"}}}],"fixity":{"associativity":"infixl","precedence":6}},"sourceSpan":{"start":[26,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Ring.purs","end":[26,18]}}]},{"moduleName":{"package":null,"item":["Data","Semigroup"]},"declarations":[{"children":[{"comments":null,"title":"append","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[32,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[32,24]}},{"comments":null,"title":"semigroupString","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[37,24]}},{"comments":null,"title":"semigroupUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[40,20]}},{"comments":null,"title":"semigroupVoid","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Void"],"Void"]}]}},"sourceSpan":{"start":[42,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[43,20]}},{"comments":null,"title":"semigroupFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"Semigroup"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"s'"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"s"}]},{"annotation":[],"tag":"TypeVar","contents":"s'"}]}]}},"sourceSpan":{"start":[45,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[46,28]}},{"comments":null,"title":"semigroupArray","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[48,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[49,23]}},{"comments":null,"title":"semigroupProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[51,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[52,21]}},{"comments":null,"title":"semigroupProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[54,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[55,22]}},{"comments":null,"title":"semigroupProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[57,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[58,22]}},{"comments":null,"title":"semigroupRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semigroup"],"SemigroupRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semigroup"],"Semigroup"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[60,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[61,46]}}],"comments":"The `Semigroup` type class identifies an associative operation on a type.\n\nInstances are required to satisfy the following law:\n\n- Associativity: `(x <> y) <> z = x <> (y <> z)`\n\nOne example of a `Semigroup` is `String`, with `(<>)` defined as string\nconcatenation. Another example is `List a`, with `(<>)` defined as\nlist concatenation.\n\n### Newtypes for Semigroup\n\nThere are two other ways to implement an instance for this type class\nregardless of which type is used. These instances can be used by\nwrapping the values in one of the two newtypes below:\n1. `First` - Use the first argument every time: `append first _ = first`.\n2. `Last` - Use the last argument every time: `append _ last = last`.\n","title":"Semigroup","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[31,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[32,24]}},{"children":[],"comments":null,"title":"(<>)","info":{"declType":"alias","alias":[["Data","Semigroup"],{"Right":{"Left":{"Ident":"append"}}}],"fixity":{"associativity":"infixr","precedence":5}},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semigroup.purs","end":[34,22]}}]},{"moduleName":{"package":null,"item":["Data","Semiring"]},"declarations":[{"children":[{"comments":null,"title":"add","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[35,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[35,22]}},{"comments":null,"title":"zero","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[36,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[36,12]}},{"comments":null,"title":"mul","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[37,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[37,22]}},{"comments":null,"title":"one","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[38,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[38,12]}},{"comments":null,"title":"semiringInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[43,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[47,10]}},{"comments":null,"title":"semiringNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[49,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[53,12]}},{"comments":null,"title":"semiringFn","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"Semiring"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}]}},"sourceSpan":{"start":[55,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[59,18]}},{"comments":null,"title":"semiringUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[61,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[65,13]}},{"comments":null,"title":"semiringProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[67,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[71,15]}},{"comments":null,"title":"semiringProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[73,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[77,16]}},{"comments":null,"title":"semiringProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[79,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[83,16]}},{"comments":null,"title":"semiringRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"list"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Semiring"],"SemiringRecord"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"list"},{"annotation":[],"tag":"TypeVar","contents":"row"},{"annotation":[],"tag":"TypeVar","contents":"row"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Semiring"],"Semiring"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"row"}]}]}},"sourceSpan":{"start":[85,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[89,63]}}],"comments":"The `Semiring` class is for types that support an addition and\nmultiplication operation.\n\nInstances must satisfy the following laws:\n\n- Commutative monoid under addition:\n - Associativity: `(a + b) + c = a + (b + c)`\n - Identity: `zero + a = a + zero = a`\n - Commutative: `a + b = b + a`\n- Monoid under multiplication:\n - Associativity: `(a * b) * c = a * (b * c)`\n - Identity: `one * a = a * one = a`\n- Multiplication distributes over addition:\n - Left distributivity: `a * (b + c) = (a * b) + (a * c)`\n - Right distributivity: `(a + b) * c = (a * c) + (b * c)`\n- Annihilation: `zero * a = a * zero = zero`\n\n**Note:** The `Number` and `Int` types are not fully law abiding\nmembers of this class hierarchy due to the potential for arithmetic\noverflows, and in the case of `Number`, the presence of `NaN` and\n`Infinity` values. The behaviour is unspecified in these cases.\n","title":"Semiring","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[34,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[38,12]}},{"children":[],"comments":null,"title":"(+)","info":{"declType":"alias","alias":[["Data","Semiring"],{"Right":{"Left":{"Ident":"add"}}}],"fixity":{"associativity":"infixl","precedence":6}},"sourceSpan":{"start":[40,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[40,18]}},{"children":[],"comments":null,"title":"(*)","info":{"declType":"alias","alias":[["Data","Semiring"],{"Right":{"Left":{"Ident":"mul"}}}],"fixity":{"associativity":"infixl","precedence":7}},"sourceSpan":{"start":[41,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Semiring.purs","end":[41,18]}}]},{"moduleName":{"package":null,"item":["Data","Show"]},"declarations":[{"children":[{"comments":null,"title":"show","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[18,3],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[18,22]}},{"comments":null,"title":"showBoolean","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}},"sourceSpan":{"start":[20,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[22,23]}},{"comments":null,"title":"showInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[24,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[25,21]}},{"comments":null,"title":"showNumber","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Number"]}]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[28,24]}},{"comments":null,"title":"showChar","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Char"]}]}},"sourceSpan":{"start":[30,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[31,22]}},{"comments":null,"title":"showString","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[33,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[34,24]}},{"comments":null,"title":"showArray","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Data","Show"],"Show"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Array"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[37,28]}},{"comments":null,"title":"showProxy","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[39,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[40,19]}},{"comments":null,"title":"showProxy2","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy2"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[42,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[43,20]}},{"comments":null,"title":"showProxy3","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Type","Proxy"],"Proxy3"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}},"sourceSpan":{"start":[45,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[46,20]}},{"comments":null,"title":"showRecord","info":{"declType":"instance","dependencies":[{"constraintAnn":[],"constraintClass":[["Prim","RowList"],"RowToList"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"rs"},{"annotation":[],"tag":"TypeVar","contents":"ls"}],"constraintKindArgs":[],"constraintData":null},{"constraintAnn":[],"constraintClass":[["Data","Show"],"ShowRecordFields"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"ls"},{"annotation":[],"tag":"TypeVar","contents":"rs"}],"constraintKindArgs":[],"constraintData":null}],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"rs"}]}]}},"sourceSpan":{"start":[48,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[51,52]}}],"comments":"The `Show` type class represents those types which can be converted into\na human-readable `String` representation.\n\nWhile not required, it is recommended that for any expression `x`, the\nstring `show x` be executable PureScript code which evaluates to the same\nvalue as the expression `x`.\n","title":"Show","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[17,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Show.purs","end":[18,22]}}]},{"moduleName":{"package":null,"item":["Data","Unit"]},"declarations":[{"children":[{"comments":null,"title":"showUnit","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}]}},"sourceSpan":{"start":[18,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Unit.purs","end":[19,18]}}],"comments":"The `Unit` type has a single inhabitant, called `unit`. It represents\nvalues with no computational content.\n\n`Unit` is often used, wrapped in a monadic type constructor, as the\nreturn type of a computation where only the _effects_ are important.\n\nWhen returning a value of type `Unit` from an FFI function, it is\nrecommended to use `undefined`, or not return a value at all.\n","title":"Unit","info":{"kind":{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Type"]},"declType":"externData"},"sourceSpan":{"start":[13,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Unit.purs","end":[13,33]}},{"children":[],"comments":"`unit` is the sole inhabitant of the `Unit` type.\n","title":"unit","info":{"declType":"value","type":{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Unit"],"Unit"]}},"sourceSpan":{"start":[16,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Unit.purs","end":[16,28]}}]},{"moduleName":{"package":null,"item":["Data","Void"]},"declarations":[{"children":[{"comments":null,"title":"showVoid","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Show"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Void"],"Void"]}]}},"sourceSpan":{"start":[24,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Void.purs","end":[25,16]}}],"comments":"An uninhabited data type. In other words, one can never create\na runtime value of type `Void` becaue no such value exists.\n\n`Void` is useful to eliminate the possibility of a value being created.\nFor example, a value of type `Either Void Boolean` can never have\na Left value created in PureScript.\n\nThis should not be confused with the keyword `void` that commonly appears in\nC-family languages, such as Java:\n```\npublic class Foo {\n void doSomething() { System.out.println(\"hello world!\"); }\n}\n```\n\nIn PureScript, one often uses `Unit` to achieve similar effects as\nthe `void` of C-family languages above.\n","title":"Void","info":{"declType":"data","dataDeclType":"newtype","typeArguments":[]},"sourceSpan":{"start":[22,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Void.purs","end":[22,25]}},{"children":[],"comments":"Eliminator for the `Void` type.\nUseful for stating that some code branch is impossible because you've\n\"acquired\" a value of type `Void` (which you can't).\n\n```purescript\nrightOnly :: forall t . Either Void t -> t\nrightOnly (Left v) = absurd v\nrightOnly (Right t) = t\n```\n","title":"absurd","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Data","Void"],"Void"]}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},null]}},"sourceSpan":{"start":[36,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Data/Void.purs","end":[36,30]}}]}],"name":"Prelude","comments":null,"declarations":[]},{"reExports":[],"name":"Record.Unsafe","comments":"The functions in this module are highly unsafe as they treat records like\nstringly-keyed maps and can coerce the row of labels that a record has.\n\nThese function are intended for situations where there is some other way of\nproving things about the structure of the record - for example, when using\n`RowToList`. **They should never be used for general record manipulation.**\n","declarations":[{"children":[],"comments":"Checks if a record has a key, using a string for the key.\n","title":"unsafeHas","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["r1",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"r1"}]}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Boolean"]}]}]},null]}},"sourceSpan":{"start":[10,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Record/Unsafe.purs","end":[10,70]}},{"children":[],"comments":"Unsafely gets a value from a record, using a string for the key.\n\nIf the key does not exist this will cause a runtime error elsewhere.\n","title":"unsafeGet","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["r",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"r"}]}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]},null]},null]}},"sourceSpan":{"start":[15,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Record/Unsafe.purs","end":[15,64]}},{"children":[],"comments":"Unsafely sets a value on a record, using a string for the key.\n\nThe output record's row is unspecified so can be coerced to any row. If the\noutput type is incorrect it will cause a runtime error elsewhere.\n","title":"unsafeSet","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["r1",{"annotation":[],"tag":"ForAll","contents":["r2",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"r1"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"r2"}]}]}]}]},null]},null]},null]}},"sourceSpan":{"start":[21,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Record/Unsafe.purs","end":[21,82]}},{"children":[],"comments":"Unsafely removes a value on a record, using a string for the key.\n\nThe output record's row is unspecified so can be coerced to any row. If the\noutput type is incorrect it will cause a runtime error elsewhere.\n","title":"unsafeDelete","info":{"declType":"value","type":{"annotation":[],"tag":"ForAll","contents":["r1",{"annotation":[],"tag":"ForAll","contents":["r2",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"r1"}]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[],"tag":"TypeVar","contents":"r2"}]}]}]},null]},null]}},"sourceSpan":{"start":[27,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Record/Unsafe.purs","end":[27,78]}}]},{"reExports":[],"name":"Type.Data.Row","comments":null,"declarations":[{"children":[{"comments":null,"title":"RProxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":null,"title":"RProxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["row",null]]},"sourceSpan":{"start":[22,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Type/Data/Row.purs","end":[22,25]}}]},{"reExports":[],"name":"Type.Data.RowList","comments":null,"declarations":[{"children":[{"comments":null,"title":"RLProxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":null,"title":"RLProxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["rowlist",null]]},"sourceSpan":{"start":[8,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Type/Data/RowList.purs","end":[8,31]}}]},{"reExports":[],"name":"Type.Proxy","comments":"The `Proxy` type and values are for situations where type information is\nrequired for an input to determine the type of an output, but where it is\nnot possible or convenient to provide a _value_ for the input.\n\nA hypothetical example: if you have a class that is used to handle the\nresult of an AJAX request, you may want to use this information to set the\nexpected content type of the request, so you might have a class something\nlike this:\n\n``` purescript\nclass AjaxResponse a where\n responseType :: a -> ResponseType\n fromResponse :: Foreign -> a\n```\n\nThe problem here is `responseType` requires a value of type `a`, but we\nwon't have a value of that type until the request has been completed. The\nsolution is to use a `Proxy` type instead:\n\n``` purescript\nclass AjaxResponse a where\n responseType :: Proxy a -> ResponseType\n fromResponse :: Foreign -> a\n```\n\nWe can now call `responseType (Proxy :: Proxy SomeContentType)` to produce\na `ResponseType` for `SomeContentType` without having to construct some\nempty version of `SomeContentType` first. In situations like this where\nthe `Proxy` type can be statically determined, it is recommended to pull\nout the definition to the top level and make a declaration like:\n\n``` purescript\n_SomeContentType :: Proxy SomeContentType\n_SomeContentType = Proxy\n```\n\nThat way the proxy value can be used as `responseType _SomeContentType`\nfor improved readability. However, this is not always possible, sometimes\nthe type required will be determined by a type variable. As PureScript has\nscoped type variables, we can do things like this:\n\n``` purescript\nmakeRequest :: URL -> ResponseType -> Aff _ Foreign\nmakeRequest = ...\n\nfetchData :: forall a. (AjaxResponse a) => URL -> Aff _ a\nfetchData url = fromResponse <$> makeRequest url (responseType (Proxy :: Proxy a))\n```\n","declarations":[{"children":[{"comments":null,"title":"Proxy","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":null,"title":"Proxy","info":{"declType":"data","dataDeclType":"data","typeArguments":[["a",null]]},"sourceSpan":{"start":[53,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Type/Proxy.purs","end":[53,21]}},{"children":[{"comments":null,"title":"Proxy2","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":null,"title":"Proxy2","info":{"declType":"data","dataDeclType":"data","typeArguments":[["f",null]]},"sourceSpan":{"start":[58,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Type/Proxy.purs","end":[58,23]}},{"children":[{"comments":null,"title":"Proxy3","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null}],"comments":"Value proxy for kind `Type -> Type -> Type` types.\n**Deprecated as of v0.14.0 PureScript release**: use `Proxy` instead.\n","title":"Proxy3","info":{"declType":"data","dataDeclType":"data","typeArguments":[["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Type"]}]},{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Type"]}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Type"]}]}]}]]},"sourceSpan":{"start":[62,1],"name":"/Users/trh/Desktop/release/purescript-prelude/src/Type/Proxy.purs","end":[62,49]}}]}],"resolvedDependencies":{},"version":"5.0.1","github":["purescript","purescript-prelude"],"versionTag":"v5.0.1","moduleMap":{},"compilerVersion":"0.14.0"} \ No newline at end of file From 7ba33daaa3566ab0c333e5445215cabbbbaf3c9f Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 17 Oct 2022 12:24:32 -0400 Subject: [PATCH 1511/1580] Fix extraneous qualifiers added during CSE (#4401) --- CHANGELOG.d/fix_4400.md | 1 + src/Language/PureScript/CoreFn/CSE.hs | 24 ++++++++++++------------ 2 files changed, 13 insertions(+), 12 deletions(-) create mode 100644 CHANGELOG.d/fix_4400.md diff --git a/CHANGELOG.d/fix_4400.md b/CHANGELOG.d/fix_4400.md new file mode 100644 index 0000000000..f4c682de88 --- /dev/null +++ b/CHANGELOG.d/fix_4400.md @@ -0,0 +1 @@ +* Fix extraneous qualifiers added to references to floated expressions diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index a87c0cf5aa..9109a4f233 100644 --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -205,7 +205,7 @@ enterAbs = censor $ plurality %~ PluralityMap . fmap (const True) . getPlurality -- Run the provided computation in a new scope. -- newScope :: (HasCSEReader m, HasCSEWriter m) => Bool -> (Int -> m a) -> m a -newScope isAbs body = local goDeeper $ do +newScope isTopLevel body = local goDeeper $ do d <- view depth censor (filterToDepth d) (body d) where @@ -213,9 +213,9 @@ newScope isAbs body = local goDeeper $ do = (scopesUsed %~ IS.filter (< d)) . (noFloatWithin %~ find (< Min d)) goDeeper env@CSEEnvironment{..} = - if isAbs || _deepestTopLevelScope /= _depth - then env{ _depth = depth' } - else env{ _depth = depth', _deepestTopLevelScope = depth' } + if isTopLevel + then env{ _depth = depth', _deepestTopLevelScope = depth' } + else env{ _depth = depth' } where depth' = succ _depth @@ -230,7 +230,7 @@ withBoundIdents idents t = local (bound %~ flip (foldl' (flip (flip M.insert t)) -- identifiers are bound non-recursively. -- newScopeWithIdents :: (HasCSEReader m, HasCSEWriter m) => Bool -> [Ident] -> m a -> m a -newScopeWithIdents isAbs idents = newScope isAbs . flip (withBoundIdents idents . (, NonRecursive)) +newScopeWithIdents isTopLevel idents = newScope isTopLevel . flip (withBoundIdents idents . (, NonRecursive)) -- | -- Produce, or retrieve from the state, an identifier for referencing the given @@ -378,7 +378,7 @@ optimizeCommonSubexpressions mn . fmap (uncurry (++)) . getNewBinds . fmap fst - . handleBinds (pure ()) + . handleBinds True (pure ()) where @@ -404,9 +404,9 @@ optimizeCommonSubexpressions mn handleExpr :: Expr Ann -> CSEMonad (Expr Ann) handleExpr = discuss (ifM (shouldFloatExpr . fst) (floatExpr topLevelQB) pure) . \case - Abs a ident e -> enterAbs $ Abs a ident <$> newScopeWithIdents True [ident] (handleAndWrapExpr e) + Abs a ident e -> enterAbs $ Abs a ident <$> newScopeWithIdents False [ident] (handleAndWrapExpr e) v@(Var _ qname) -> summarizeName mn qname $> v - Let a bs e -> uncurry (Let a) <$> handleBinds (handleExpr e) bs + Let a bs e -> uncurry (Let a) <$> handleBinds False (handleExpr e) bs x -> handleExprDefault x handleCaseAlternative :: CaseAlternative Ann -> CSEMonad (CaseAlternative Ann) @@ -414,8 +414,8 @@ optimizeCommonSubexpressions mn newScopeWithIdents False (identsFromBinders bs) $ bitraverse (traverse $ bitraverse handleAndWrapExpr handleAndWrapExpr) handleAndWrapExpr x - handleBinds :: forall a. CSEMonad a -> [Bind Ann] -> CSEMonad ([Bind Ann], a) - handleBinds = foldr go . fmap pure where + handleBinds :: forall a. Bool -> CSEMonad a -> [Bind Ann] -> CSEMonad ([Bind Ann], a) + handleBinds isTopLevel = foldr go . fmap pure where go :: Bind Ann -> CSEMonad ([Bind Ann], a) -> CSEMonad ([Bind Ann], a) go b inner = case b of -- For a NonRec Bind, traverse the bound expression in the current scope @@ -423,14 +423,14 @@ optimizeCommonSubexpressions mn -- inner thing all these Binds are applied to. NonRec a ident e -> do e' <- handleExpr e - newScopeWithIdents False [ident] $ + newScopeWithIdents isTopLevel [ident] $ prependToNewBindsFromInner $ NonRec a ident e' Rec es -> -- For a Rec Bind, the bound expressions need a new scope in which all -- these identifiers are bound recursively; then the remaining Binds -- and the inner thing can be traversed in the same scope with the same -- identifiers now bound non-recursively. - newScope False $ \d -> do + newScope isTopLevel $ \d -> do let idents = map (snd . fst) es es' <- withBoundIdents idents (d, Recursive) $ traverse (traverse handleExpr) es withBoundIdents idents (d, NonRecursive) $ From 9166355079a65288855b623f010c0a0b7a479b2e Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Mon, 17 Oct 2022 21:10:09 -0500 Subject: [PATCH 1512/1580] Release 0.15.6 (#4404) --- CHANGELOG.d/fix_4400.md | 1 - .../fix_make-fromjson-backwards-compatible.md | 12 ------------ CHANGELOG.md | 19 +++++++++++++++++++ npm-package/package.json | 4 ++-- purescript.cabal | 2 +- 5 files changed, 22 insertions(+), 16 deletions(-) delete mode 100644 CHANGELOG.d/fix_4400.md delete mode 100644 CHANGELOG.d/fix_make-fromjson-backwards-compatible.md diff --git a/CHANGELOG.d/fix_4400.md b/CHANGELOG.d/fix_4400.md deleted file mode 100644 index f4c682de88..0000000000 --- a/CHANGELOG.d/fix_4400.md +++ /dev/null @@ -1 +0,0 @@ -* Fix extraneous qualifiers added to references to floated expressions diff --git a/CHANGELOG.d/fix_make-fromjson-backwards-compatible.md b/CHANGELOG.d/fix_make-fromjson-backwards-compatible.md deleted file mode 100644 index a4baf4f540..0000000000 --- a/CHANGELOG.d/fix_make-fromjson-backwards-compatible.md +++ /dev/null @@ -1,12 +0,0 @@ -* Make `FromJSON` instance for `Qualified` backwards compatible - - Prior to #4293, `Qualified` was encoded to JSON such that - - ```haskell - >>> encode $ Qualified Nothing "foo" - [null,"foo"] - >>> encode $ Qualified (Just $ ModuleName "A") "bar" - ["A","bar"] - ``` - - The type of `Qualified` has changed so that `null` no longer appears in JSON output, but for sake of backwards-compatibility with JSON that was produced prior to those changes (pre-`v0.15.2`), we need to accept `null`, which will be interpreted as `Qualified ByNullSourcePos`. diff --git a/CHANGELOG.md b/CHANGELOG.md index 987299a1d6..f3dbe6af11 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,25 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.6 + +Bugfixes: + +* Make `FromJSON` instance for `Qualified` backwards compatible (#4403 by @ptrfrncsmrph) + + Prior to #4293, `Qualified` was encoded to JSON such that + + ```haskell + >>> encode $ Qualified Nothing "foo" + [null,"foo"] + >>> encode $ Qualified (Just $ ModuleName "A") "bar" + ["A","bar"] + ``` + + The type of `Qualified` has changed so that `null` no longer appears in JSON output, but for sake of backwards-compatibility with JSON that was produced prior to those changes (pre-`v0.15.2`), we need to accept `null`, which will be interpreted as `Qualified ByNullSourcePos`. + +* Fix extraneous qualifiers added to references to floated expressions (#4401 by @rhendric) + ## 0.15.5 New features: diff --git a/npm-package/package.json b/npm-package/package.json index 921bc13790..490202617a 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.5", + "version": "0.15.6", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.5", + "postinstall": "install-purescript --purs-ver=0.15.6", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index bcbdc62ebf..84458234c4 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.5 +version: 0.15.6 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From b7e05967ecec890c1d45d266e221bc877a87f184 Mon Sep 17 00:00:00 2001 From: Mark Eibes Date: Sun, 30 Oct 2022 04:54:49 +0100 Subject: [PATCH 1513/1580] Allow IDE module rebuilds without touching filesystem output/cache-db (#4399) Co-authored-by: wclr --- .../feature_ide-rebuild-without-filesystem.md | 4 ++ CONTRIBUTORS.md | 1 + psc-ide/PROTOCOL.md | 7 +-- src/Language/PureScript/Ide/Rebuild.hs | 29 +++++++++-- src/Language/PureScript/Make/Actions.hs | 51 ++++++++++++------- 5 files changed, 67 insertions(+), 25 deletions(-) create mode 100644 CHANGELOG.d/feature_ide-rebuild-without-filesystem.md diff --git a/CHANGELOG.d/feature_ide-rebuild-without-filesystem.md b/CHANGELOG.d/feature_ide-rebuild-without-filesystem.md new file mode 100644 index 0000000000..7bb4b533d6 --- /dev/null +++ b/CHANGELOG.d/feature_ide-rebuild-without-filesystem.md @@ -0,0 +1,4 @@ +* Allow IDE module rebuilds eschewing the filesystem + + This allows IDE clients to typecheck the module the user is currently typing in without modifying the output. + This allows for faster feedback cycles in editors and avoids producing a broken `/output` before the user actually saves the file. diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 60e0b6fb31..a891e1211b 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -160,6 +160,7 @@ If you would prefer to use different terms, please use the section below instead | [@sd-yip](https://github.com/sd-yip) | Nicholas Yip | [MIT license](http://opensource.org/licenses/MIT) | | [@j-nava](https://github.com/j-nava) | Jesse Nava | [MIT license](http://opensource.org/licenses/MIT) | | [@imcotton](https://github.com/imcotton) | Cotton Hou | [MIT license](http://opensource.org/licenses/MIT) | +| [@wclr](https://github.com/wclr) | Alex Osh | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index fba93d39f7..d42185483b 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -2,7 +2,7 @@ Communication with `purs ide server` is via a JSON protocol over a TCP connection: the server listens on a particular (configurable) port, and will accept a single line -of JSON input in the format described below, terminated by a newline, before giving +of JSON input in the format described below, terminated by a newline, before giving a JSON response and closing the connection. The `purs ide client` command can be used as a wrapper for the TCP connection, but @@ -80,7 +80,7 @@ The `complete` command looks up possible completions/corrections. If no matcher is given every candidate, that passes the filters, is returned in no particular order. - - `currentModule :: (optional) String`: The current modules name. Allows you + - `currentModule :: (optional) String`: The current modules name. Allows you to see module-private functions after a successful rebuild. If it matches with the rebuild cache non-exported modules will also be completed. You can fill the rebuild cache by using the "Rebuild" command. @@ -371,7 +371,8 @@ loaded. A successful rebuild will be stored to allow for completions of private identifiers. Arguments: - - `file :: String` the path to the module to rebuild + - `file :: String` the path to the module to rebuild **or** the complete + source code of the module to be compiled prefixed with `data:` - `actualFile :: Maybe String` Specifies the path to be used for location information and parse errors. This is useful in case a temp file is used as the source for a rebuild. diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 52a74a4d01..51d9dd996e 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -14,9 +14,12 @@ import qualified Data.Map.Lazy as M import Data.Maybe (fromJust) import qualified Data.Set as S import qualified Data.Time as Time +import qualified Data.Text as Text import qualified Language.PureScript as P +import Language.PureScript.Make (ffiCodegen') import Language.PureScript.Make.Cache (CacheInfo(..), normaliseForCache) import qualified Language.PureScript.CST as CST + import Language.PureScript.Ide.Error import Language.PureScript.Ide.Logging import Language.PureScript.Ide.State @@ -51,7 +54,10 @@ rebuildFile -- ^ A runner for the second build with open exports -> m Success rebuildFile file actualFile codegenTargets runOpenBuild = do - (fp, input) <- ideReadFile file + (fp, input) <- + case List.stripPrefix "data:" file of + Just source -> pure ("", Text.pack source) + _ -> ideReadFile file let fp' = fromMaybe fp actualFile (pwarnings, m) <- case sequence $ CST.parseFromFile fp' input of Left parseError -> @@ -65,13 +71,18 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do -- For rebuilding, we want to 'RebuildAlways', but for inferring foreign -- modules using their file paths, we need to specify the path in the 'Map'. let filePathMap = M.singleton moduleName (Left P.RebuildAlways) - foreigns <- P.inferForeignModules (M.singleton moduleName (Right file)) + let pureRebuild = fp == "" + let modulePath = if pureRebuild then fp' else file + foreigns <- P.inferForeignModules (M.singleton moduleName (Right modulePath)) let makeEnv = P.buildMakeActions outputDirectory filePathMap foreigns False + & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity) + & shushProgress -- Rebuild the single module using the cached externs (result, warnings) <- logPerf (labelTimespec "Rebuilding Module") $ liftIO $ P.runMake (P.defaultOptions { P.optionsCodegenTargets = codegenTargets }) do - newExterns <- P.rebuildModule (shushProgress makeEnv) externs m - updateCacheDb codegenTargets outputDirectory file actualFile moduleName + newExterns <- P.rebuildModule makeEnv externs m + unless pureRebuild + $ updateCacheDb codegenTargets outputDirectory file actualFile moduleName pure newExterns case result of Left errors -> @@ -176,6 +187,16 @@ shushCodegen ma = , P.ffiCodegen = \_ -> pure () } +-- | Enables foreign module check without actual codegen. +enableForeignCheck + :: M.Map P.ModuleName FilePath + -> S.Set P.CodegenTarget + -> P.MakeActions P.Make + -> P.MakeActions P.Make +enableForeignCheck foreigns codegenTargets ma = + ma { P.ffiCodegen = ffiCodegen' foreigns codegenTargets Nothing + } + -- | Returns a topologically sorted list of dependent ExternsFiles for the given -- module. Throws an error if there is a cyclic dependency within the -- ExternsFiles diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index ff50ba1d0c..27a173e754 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -8,6 +8,7 @@ module Language.PureScript.Make.Actions , cacheDbFile , readCacheDb' , writeCacheDb' + , ffiCodegen' ) where import Prelude @@ -280,23 +281,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = ffiCodegen :: CF.Module CF.Ann -> Make () ffiCodegen m = do codegenTargets <- asks optionsCodegenTargets - when (S.member JS codegenTargets) $ do - let mn = CF.moduleName m - case mn `M.lookup` foreigns of - Just path - | not $ requiresForeign m -> - tell $ errorMessage' (CF.moduleSourceSpan m) $ UnnecessaryFFIModule mn path - | otherwise -> do - checkResult <- checkForeignDecls m path - case checkResult of - Left _ -> copyFile path (outputFilename mn "foreign.js") - Right (ESModule, _) -> copyFile path (outputFilename mn "foreign.js") - Right (CJSModule, _) -> do - throwError $ errorMessage' (CF.moduleSourceSpan m) $ DeprecatedFFICommonJSModule mn path - - Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn - | otherwise -> return () - + ffiCodegen' foreigns codegenTargets (Just outputFilename) m genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do @@ -358,7 +343,7 @@ checkForeignDecls m path = do modSS = CF.moduleSourceSpan m checkFFI :: JS.JSAST -> Make (ForeignModuleType, S.Set Ident) - checkFFI js = do + checkFFI js = do (foreignModuleType, foreignIdentsStrs) <- case (,) <$> getForeignModuleExports js <*> getForeignModuleImports js of Left reason -> throwError $ errorParsingModule reason @@ -438,3 +423,33 @@ checkForeignDecls m path = do . CST.runTokenParser CST.parseIdent . CST.lex $ T.pack str + +-- | FFI check and codegen action. +-- If path maker is supplied copies foreign module to the output. +ffiCodegen' + :: M.Map ModuleName FilePath + -> S.Set CodegenTarget + -> Maybe (ModuleName -> String -> FilePath) + -> CF.Module CF.Ann + -> Make () +ffiCodegen' foreigns codegenTargets makeOutputPath m = do + when (S.member JS codegenTargets) $ do + let mn = CF.moduleName m + case mn `M.lookup` foreigns of + Just path + | not $ requiresForeign m -> + tell $ errorMessage' (CF.moduleSourceSpan m) $ UnnecessaryFFIModule mn path + | otherwise -> do + checkResult <- checkForeignDecls m path + case checkResult of + Left _ -> copyForeign path mn + Right (ESModule, _) -> copyForeign path mn + Right (CJSModule, _) -> do + throwError $ errorMessage' (CF.moduleSourceSpan m) $ DeprecatedFFICommonJSModule mn path + Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn + | otherwise -> return () + where + requiresForeign = not . null . CF.moduleForeign + + copyForeign path mn = + for_ makeOutputPath (\outputFilename -> copyFile path (outputFilename mn "foreign.js")) From 3b6630592e82ca039d8adec3ad4c8e1dbf0f53e3 Mon Sep 17 00:00:00 2001 From: Nicholas Wolverson Date: Wed, 2 Nov 2022 14:48:00 +0000 Subject: [PATCH 1514/1580] IDE dependencies filter - filter by import list (#4412) - Given a list of import lines, typically the import section of a module being edited, filter to the declarations brought into scope by those imports plus specified qualifier. --- CHANGELOG.d/feature_ide-dependency-filter.md | 6 + psc-ide/PROTOCOL.md | 14 +- purescript.cabal | 2 + src/Language/PureScript/Ide.hs | 3 +- src/Language/PureScript/Ide/Filter.hs | 32 ++- src/Language/PureScript/Ide/Filter/Imports.hs | 31 +++ src/Language/PureScript/Ide/Imports.hs | 241 +---------------- .../PureScript/Ide/Imports/Actions.hs | 251 ++++++++++++++++++ tests/Language/PureScript/Ide/FilterSpec.hs | 63 ++++- tests/Language/PureScript/Ide/ImportsSpec.hs | 1 + 10 files changed, 399 insertions(+), 245 deletions(-) create mode 100644 CHANGELOG.d/feature_ide-dependency-filter.md create mode 100644 src/Language/PureScript/Ide/Filter/Imports.hs create mode 100644 src/Language/PureScript/Ide/Imports/Actions.hs diff --git a/CHANGELOG.d/feature_ide-dependency-filter.md b/CHANGELOG.d/feature_ide-dependency-filter.md new file mode 100644 index 0000000000..66d9b6b1a4 --- /dev/null +++ b/CHANGELOG.d/feature_ide-dependency-filter.md @@ -0,0 +1,6 @@ +```markdown +* Add `purs ide` dependency/imports filter (#4412 by @nwolverson) + + This allows IDE tooling to filter type searches according to the imports of a given module, + restricting to identifiers in scope. +``` diff --git a/psc-ide/PROTOCOL.md b/psc-ide/PROTOCOL.md index d42185483b..e6cb5d1115 100644 --- a/psc-ide/PROTOCOL.md +++ b/psc-ide/PROTOCOL.md @@ -577,14 +577,22 @@ The Module filter only keeps identifiers that appear in the listed modules. ``` ### Dependency filter -The Dependency filter only keeps identifiers that appear in the listed modules -and in any of their dependencies/imports. +The Dependency filter only keeps identifiers that appear in the listed module or +are brought into scope by any of its imports. + +The module text is provided, though only the portion up until the end of the import section +need be provided. + +Parameters: +- `moduleText :: String` +- `qualifier :: String` (optional) ```json { "filter": "dependencies", "params": { - "modules": ["My.Module"] + "moduleText": "module My.Module where\nimport Foo as F\n", + "qualifier": "F" } } ``` diff --git a/purescript.cabal b/purescript.cabal index 84458234c4..4766e6ec50 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -286,7 +286,9 @@ library Language.PureScript.Ide.Externs Language.PureScript.Ide.Filter Language.PureScript.Ide.Filter.Declaration + Language.PureScript.Ide.Filter.Imports Language.PureScript.Ide.Imports + Language.PureScript.Ide.Imports.Actions Language.PureScript.Ide.Logging Language.PureScript.Ide.Matcher Language.PureScript.Ide.Prim diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index cf56b4d8b4..fdee5c6f4a 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -30,7 +30,8 @@ import Language.PureScript.Ide.Completion import Language.PureScript.Ide.Error import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Filter -import Language.PureScript.Ide.Imports hiding (Import) +import Language.PureScript.Ide.Imports hiding (Import) +import Language.PureScript.Ide.Imports.Actions import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Prim import Language.PureScript.Ide.Rebuild diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 4bca2e1275..a3086c9e0a 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -19,6 +19,7 @@ module Language.PureScript.Ide.Filter , exactFilter , prefixFilter , declarationTypeFilter + , dependencyFilter , applyFilters ) where @@ -31,8 +32,13 @@ import qualified Data.Set as Set import qualified Data.Map as Map import Language.PureScript.Ide.Filter.Declaration (DeclarationType) import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Imports import Language.PureScript.Ide.Util + import qualified Language.PureScript as P +import qualified Data.Text as T + +import Language.PureScript.Ide.Filter.Imports newtype Filter = Filter (Either (Set P.ModuleName) DeclarationFilter) deriving Show @@ -45,6 +51,7 @@ data DeclarationFilter | Exact Text | Namespace (Set IdeNamespace) | DeclType (Set DeclarationType) + | Dependencies { qualifier :: Maybe P.ModuleName, currentModuleName :: P.ModuleName, dependencyImports :: [Import] } deriving Show -- | Only keeps Declarations in the given modules @@ -67,6 +74,9 @@ prefixFilter t = Filter (Right (Prefix t)) declarationTypeFilter :: Set DeclarationType -> Filter declarationTypeFilter dts = Filter (Right (DeclType dts)) +dependencyFilter :: Maybe P.ModuleName -> P.ModuleName -> [Import] -> Filter +dependencyFilter q m f = Filter (Right (Dependencies q m f)) + optimizeFilters :: [Filter] -> (Maybe (Set P.ModuleName), [DeclarationFilter]) optimizeFilters = first smashModuleFilters . partitionEithers . map unFilter where @@ -88,17 +98,19 @@ applyDeclarationFilters -> ModuleMap [IdeDeclarationAnn] applyDeclarationFilters fs = Map.filter (not . null) - . Map.map (foldr (.) identity (map applyDeclarationFilter fs)) + . Map.mapWithKey (\modl decls -> foldr (.) identity (map (applyDeclarationFilter modl) fs) decls) applyDeclarationFilter - :: DeclarationFilter + :: P.ModuleName + -> DeclarationFilter -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] -applyDeclarationFilter f = case f of +applyDeclarationFilter modl f = case f of Prefix prefix -> prefixFilter' prefix Exact t -> exactFilter' t Namespace namespaces -> namespaceFilter' namespaces DeclType dts -> declarationTypeFilter' dts + Dependencies qual currentModuleName imps -> dependencyFilter' modl qual currentModuleName imps namespaceFilter' :: Set IdeNamespace -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] namespaceFilter' namespaces = @@ -116,6 +128,13 @@ declarationTypeFilter' :: Set DeclarationType -> [IdeDeclarationAnn] -> [IdeDecl declarationTypeFilter' declTypes = filter (\decl -> declarationType (discardAnn decl) `Set.member` declTypes) +dependencyFilter' :: P.ModuleName -> Maybe P.ModuleName -> P.ModuleName -> [Import] -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] +dependencyFilter' modl qual currentModuleName imports = + if modl == currentModuleName && isNothing qual then + identity + else + filter (\decl -> any (matchImport qual modl decl) imports) + instance FromJSON Filter where parseJSON = withObject "filter" $ \o -> do (filter' :: Text) <- o .: "filter" @@ -139,4 +158,11 @@ instance FromJSON Filter where "declarations" -> do declarations <- o.: "params" pure (declarationTypeFilter (Set.fromList declarations)) + "dependencies" -> do + params <- o.: "params" + moduleText <- params .: "moduleText" + qualifier <- fmap P.moduleNameFromString <$> params .:? "qualifier" + case sliceImportSection (T.lines moduleText) of + Left err -> fail ("Couldn't parse module imports: " <> T.unpack err) + Right (currentModuleName, _, imports, _ ) -> pure (dependencyFilter qualifier currentModuleName imports) s -> fail ("Unknown filter: " <> show s) diff --git a/src/Language/PureScript/Ide/Filter/Imports.hs b/src/Language/PureScript/Ide/Filter/Imports.hs new file mode 100644 index 0000000000..f1870b4d09 --- /dev/null +++ b/src/Language/PureScript/Ide/Filter/Imports.hs @@ -0,0 +1,31 @@ +module Language.PureScript.Ide.Filter.Imports where + + +import Protolude hiding (isPrefixOf) + +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Imports + +import qualified Language.PureScript as P + +matchImport :: Maybe P.ModuleName -> P.ModuleName -> IdeDeclarationAnn -> Import -> Bool +matchImport matchQualifier declMod (IdeDeclarationAnn _ decl) (Import importMod declTy qualifier) | declMod == importMod && matchQualifier == qualifier = + case declTy of + P.Implicit -> True + P.Explicit refs -> any (matchRef decl) refs + P.Hiding refs -> not $ any (matchRef decl) refs + where + matchRef (IdeDeclValue (IdeValue ident _)) (P.ValueRef _ ident') = ident == ident' + matchRef (IdeDeclType (IdeType tname _kind _dctors)) (P.TypeRef _ tname' _dctors') = tname == tname' + matchRef (IdeDeclTypeSynonym (IdeTypeSynonym tname _type _kind)) (P.TypeRef _ tname' _dctors) = tname == tname' -- Can this occur? + + matchRef (IdeDeclDataConstructor (IdeDataConstructor dcname tname _type)) (P.TypeRef _ tname' dctors) = + tname == tname' + && maybe True (dcname `elem`) dctors -- (..) or explicitly lists constructor + + matchRef (IdeDeclTypeClass (IdeTypeClass tcname _kind _instances)) (P.TypeClassRef _ tcname') = tcname == tcname' + matchRef (IdeDeclValueOperator (IdeValueOperator{ _ideValueOpName })) (P.ValueOpRef _ opname) = _ideValueOpName == opname + matchRef (IdeDeclTypeOperator (IdeTypeOperator{ _ideTypeOpName })) (P.TypeOpRef _ opname) = _ideTypeOpName == opname + matchRef _ _ = False + +matchImport _ _ _ _ = False diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 95fb37e383..94e6d78fd7 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -13,17 +13,11 @@ ----------------------------------------------------------------------------- module Language.PureScript.Ide.Imports - ( addImplicitImport - , addQualifiedImport - , addImportForIdentifier - , answerRequest - , parseImportsFromFile + ( parseImportsFromFile + , parseImportsFromFile' -- for tests , parseImport , prettyPrintImportSection - , addImplicitImport' - , addQualifiedImport' - , addExplicitImport' , sliceImportSection , prettyPrintImport' , Import(Import) @@ -32,22 +26,14 @@ module Language.PureScript.Ide.Imports import Protolude hiding (moduleName) -import Control.Lens ((^.), (%~), ix, has) -import Data.List (nubBy, partition) +import Control.Lens ((^.), (%~), ix) +import Data.List (partition) import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map import qualified Data.Text as T import qualified Language.PureScript as P -import qualified Language.PureScript.Constants.Prim as C import qualified Language.PureScript.CST as CST -import Language.PureScript.Ide.Completion import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Filter -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Prim -import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import System.IO.UTF8 (writeUTF8FileT) data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) deriving (Eq, Show) @@ -136,201 +122,6 @@ sliceImportSection fileLines = first (toS . CST.prettyPrintError . NE.head) $ do & ix 0 %~ T.drop (c1 - 1) & ix (l2 - l1) %~ T.take c2 --- | Adds an implicit import like @import Prelude@ to a Sourcefile. -addImplicitImport - :: (MonadIO m, MonadError IdeError m) - => FilePath -- ^ The source file read from - -> P.ModuleName -- ^ The module to import - -> m [Text] -addImplicitImport fp mn = do - (_, pre, imports, post) <- parseImportsFromFile' fp - let newImportSection = addImplicitImport' imports mn - pure $ joinSections (pre, newImportSection, post) - -addImplicitImport' :: [Import] -> P.ModuleName -> [Text] -addImplicitImport' imports mn = - prettyPrintImportSection (Import mn P.Implicit Nothing : imports) - --- | Adds a qualified import like @import Data.Map as Map@ to a source file. -addQualifiedImport - :: (MonadIO m, MonadError IdeError m) - => FilePath - -- ^ The sourcefile read from - -> P.ModuleName - -- ^ The module to import - -> P.ModuleName - -- ^ The qualifier under which to import - -> m [Text] -addQualifiedImport fp mn qualifier = do - (_, pre, imports, post) <- parseImportsFromFile' fp - let newImportSection = addQualifiedImport' imports mn qualifier - pure $ joinSections (pre, newImportSection, post) - -addQualifiedImport' :: [Import] -> P.ModuleName -> P.ModuleName -> [Text] -addQualifiedImport' imports mn qualifier = - prettyPrintImportSection (Import mn P.Implicit (Just qualifier) : imports) - --- | Adds an explicit import like @import Prelude (unit)@ to a Sourcefile. If an --- explicit import already exists for the given module, it adds the identifier --- to that imports list. --- --- So @addExplicitImport "/File.purs" "bind" "Prelude"@ with an already existing --- @import Prelude (bind)@ in the file File.purs returns @["import Prelude --- (bind, unit)"]@ -addExplicitImport :: (MonadIO m, MonadError IdeError m) => - FilePath -> IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> m [Text] -addExplicitImport fp decl moduleName qualifier = do - (mn, pre, imports, post) <- parseImportsFromFile' fp - let newImportSection = - -- TODO: Open an issue when this PR is merged, we should optimise this - -- so that this case does not write to disc - if mn == moduleName - then imports - else addExplicitImport' decl moduleName qualifier imports - pure $ joinSections (pre, prettyPrintImportSection newImportSection, post) - -addExplicitImport' :: IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> [Import] -> [Import] -addExplicitImport' decl moduleName qualifier imports = - let - isImplicitlyImported = - any (\case - Import mn P.Implicit qualifier' -> mn == moduleName && qualifier == qualifier' - _ -> False) imports - isNotExplicitlyImportedFromPrim = - moduleName == C.Prim && - not (any (\case - Import C.Prim (P.Explicit _) Nothing -> True - _ -> False) imports) - -- We can't import Modules from other modules - isModule = has _IdeDeclModule decl - - matches (Import mn (P.Explicit _) qualifier') = mn == moduleName && qualifier == qualifier' - matches _ = False - freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) qualifier - in - if isImplicitlyImported || isNotExplicitlyImportedFromPrim || isModule - then imports - else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports - where - refFromDeclaration (IdeDeclTypeClass tc) = - P.TypeClassRef ideSpan (tc ^. ideTCName) - refFromDeclaration (IdeDeclDataConstructor dtor) = - P.TypeRef ideSpan (dtor ^. ideDtorTypeName) Nothing - refFromDeclaration (IdeDeclType t) = - P.TypeRef ideSpan (t ^. ideTypeName) (Just []) - refFromDeclaration (IdeDeclValueOperator op) = - P.ValueOpRef ideSpan (op ^. ideValueOpName) - refFromDeclaration (IdeDeclTypeOperator op) = - P.TypeOpRef ideSpan (op ^. ideTypeOpName) - refFromDeclaration d = - P.ValueRef ideSpan (P.Ident (identifierFromIdeDeclaration d)) - - -- | Adds a declaration to an import: - -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) - insertDeclIntoImport :: IdeDeclaration -> Import -> Import - insertDeclIntoImport decl' (Import mn (P.Explicit refs) qual) = - Import mn (P.Explicit (sort (insertDeclIntoRefs decl' refs))) qual - insertDeclIntoImport _ is = is - - insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef] - insertDeclIntoRefs d@(IdeDeclDataConstructor dtor) refs = - updateAtFirstOrPrepend - (matchType (dtor ^. ideDtorTypeName)) - (insertDtor (dtor ^. ideDtorName)) - (refFromDeclaration d) - refs - insertDeclIntoRefs (IdeDeclType t) refs - | any matches refs = refs - where - matches (P.TypeRef _ typeName _) = _ideTypeName t == typeName - matches _ = False - insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) - - insertDtor _ (P.TypeRef ss tn' _) = P.TypeRef ss tn' Nothing - insertDtor _ refs = refs - - matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool - matchType tn (P.TypeRef _ n _) = tn == n - matchType _ _ = False - -ideSpan :: P.SourceSpan -ideSpan = P.internalModuleSourceSpan "" - --- | If none of the elements of the list satisfy the given predicate 'predicate', then prepend the default value 'def' --- to the given list. Otherwise, update the first element of the list that satisfies 'predicate' with the updating --- function 'update'. -updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a] -updateAtFirstOrPrepend predicate update def xs = - case break predicate xs of - (before, []) -> def : before - (before, x : after) -> before ++ [update x] ++ after - --- | Looks up the given identifier in the currently loaded modules. --- --- * Throws an error if the identifier cannot be found. --- --- * If exactly one match is found, adds an explicit import to the importsection --- --- * If more than one possible imports are found, reports the possibilities as a --- list of completions. -addImportForIdentifier - :: (Ide m, MonadError IdeError m) - => FilePath -- ^ The Sourcefile to read from - -> Text -- ^ The identifier to import - -> Maybe P.ModuleName -- ^ The optional qualifier under which to import - -> [Filter] -- ^ Filters to apply before searching for the identifier - -> m (Either [Match IdeDeclaration] [Text]) -addImportForIdentifier fp ident qual filters = do - let addPrim = Map.union idePrimDeclarations - modules <- getAllModules Nothing - let - matches = - getExactMatches ident filters (addPrim modules) - & map (fmap discardAnn) - & filter (\(Match (_, d)) -> not (has _IdeDeclModule d)) - - case matches of - [] -> - throwError (NotFound "Couldn't find the given identifier. \ - \Have you loaded the corresponding module?") - - -- Only one match was found for the given identifier, so we can insert it - -- right away - [Match (m, decl)] -> - Right <$> addExplicitImport fp decl m qual - - -- This case comes up for newtypes and dataconstructors. Because values and - -- types don't share a namespace we can get multiple matches from the same - -- module. This also happens for parameterized types, as these generate both - -- a type as well as a type synonym. - - ms@[Match (m1, d1), Match (m2, d2)] -> - if m1 /= m2 - -- If the modules don't line up we just ask the user to specify the - -- module - then pure (Left ms) - else case decideRedundantCase d1 d2 <|> decideRedundantCase d2 d1 of - -- If dataconstructor and type line up we just import the - -- dataconstructor as that will give us an unnecessary import warning at - -- worst - Just decl -> - Right <$> addExplicitImport fp decl m1 qual - -- Here we need the user to specify whether they wanted a - -- dataconstructor or a type - Nothing -> - throwError (GeneralError "Undecidable between type and dataconstructor") - - -- Multiple matches were found so we need to ask the user to clarify which - -- module they meant - xs -> - pure (Left xs) - where - decideRedundantCase d@(IdeDeclDataConstructor dtor) (IdeDeclType t) = - if dtor ^. ideDtorTypeName == t ^. ideTypeName then Just d else Nothing - decideRedundantCase IdeDeclType{} ts@IdeDeclTypeSynonym{} = - Just ts - decideRedundantCase _ _ = Nothing - prettyPrintImport' :: Import -> Text prettyPrintImport' (Import mn idt qual) = "import " <> P.prettyPrintImport mn idt qual @@ -352,18 +143,6 @@ prettyPrintImportSection imports = Import _ (P.Hiding _) Nothing -> True _ -> False - --- | Writes a list of lines to @Just filepath@ and responds with a @TextResult@, --- or returns the lines as a @MultilineTextResult@ if @Nothing@ was given as the --- first argument. -answerRequest :: (MonadIO m) => Maybe FilePath -> [Text] -> m Success -answerRequest outfp rs = - case outfp of - Nothing -> pure (MultilineTextResult rs) - Just outfp' -> do - liftIO (writeUTF8FileT outfp' (T.unlines rs)) - pure (TextResult ("Written to " <> T.pack outfp')) - -- | Test and ghci helper parseImport :: Text -> Maybe Import parseImport t = @@ -373,15 +152,3 @@ parseImport t = Right (_, mn, idt, mmn) -> Just (Import mn idt mmn) _ -> Nothing - -joinSections :: ([Text], [Text], [Text]) -> [Text] -joinSections (pre, decls, post) = pre `joinLine` (decls `joinLine` post) - where - isBlank = T.all (== ' ') - joinLine as bs - | Just ln1 <- lastMay as - , Just ln2 <- head bs - , not (isBlank ln1) && not (isBlank ln2) = - as ++ [""] ++ bs - | otherwise = - as ++ bs diff --git a/src/Language/PureScript/Ide/Imports/Actions.hs b/src/Language/PureScript/Ide/Imports/Actions.hs new file mode 100644 index 0000000000..9465d68033 --- /dev/null +++ b/src/Language/PureScript/Ide/Imports/Actions.hs @@ -0,0 +1,251 @@ +module Language.PureScript.Ide.Imports.Actions + ( addImplicitImport + , addQualifiedImport + , addImportForIdentifier + , answerRequest + + -- for tests + , addImplicitImport' + , addQualifiedImport' + , addExplicitImport' + ) +where + +import Protolude hiding (moduleName) + +import Control.Lens ((^.), has) +import Data.List (nubBy) +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Language.PureScript as P +import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.Ide.Completion +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Imports +import Language.PureScript.Ide.State +import Language.PureScript.Ide.Prim +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util +import System.IO.UTF8 (writeUTF8FileT) + +-- | Adds an implicit import like @import Prelude@ to a Sourcefile. +addImplicitImport + :: (MonadIO m, MonadError IdeError m) + => FilePath -- ^ The source file read from + -> P.ModuleName -- ^ The module to import + -> m [Text] +addImplicitImport fp mn = do + (_, pre, imports, post) <- parseImportsFromFile' fp + let newImportSection = addImplicitImport' imports mn + pure $ joinSections (pre, newImportSection, post) + +addImplicitImport' :: [Import] -> P.ModuleName -> [Text] +addImplicitImport' imports mn = + prettyPrintImportSection (Import mn P.Implicit Nothing : imports) + +-- | Adds a qualified import like @import Data.Map as Map@ to a source file. +addQualifiedImport + :: (MonadIO m, MonadError IdeError m) + => FilePath + -- ^ The sourcefile read from + -> P.ModuleName + -- ^ The module to import + -> P.ModuleName + -- ^ The qualifier under which to import + -> m [Text] +addQualifiedImport fp mn qualifier = do + (_, pre, imports, post) <- parseImportsFromFile' fp + let newImportSection = addQualifiedImport' imports mn qualifier + pure $ joinSections (pre, newImportSection, post) + +addQualifiedImport' :: [Import] -> P.ModuleName -> P.ModuleName -> [Text] +addQualifiedImport' imports mn qualifier = + prettyPrintImportSection (Import mn P.Implicit (Just qualifier) : imports) + +-- | Adds an explicit import like @import Prelude (unit)@ to a Sourcefile. If an +-- explicit import already exists for the given module, it adds the identifier +-- to that imports list. +-- +-- So @addExplicitImport "/File.purs" "bind" "Prelude"@ with an already existing +-- @import Prelude (bind)@ in the file File.purs returns @["import Prelude +-- (bind, unit)"]@ +addExplicitImport :: (MonadIO m, MonadError IdeError m) => + FilePath -> IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> m [Text] +addExplicitImport fp decl moduleName qualifier = do + (mn, pre, imports, post) <- parseImportsFromFile' fp + let newImportSection = + -- TODO: Open an issue when this PR is merged, we should optimise this + -- so that this case does not write to disc + if mn == moduleName + then imports + else addExplicitImport' decl moduleName qualifier imports + pure $ joinSections (pre, prettyPrintImportSection newImportSection, post) + +addExplicitImport' :: IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> [Import] -> [Import] +addExplicitImport' decl moduleName qualifier imports = + let + isImplicitlyImported = + any (\case + Import mn P.Implicit qualifier' -> mn == moduleName && qualifier == qualifier' + _ -> False) imports + isNotExplicitlyImportedFromPrim = + moduleName == C.Prim && + not (any (\case + Import C.Prim (P.Explicit _) Nothing -> True + _ -> False) imports) + -- We can't import Modules from other modules + isModule = has _IdeDeclModule decl + + matches (Import mn (P.Explicit _) qualifier') = mn == moduleName && qualifier == qualifier' + matches _ = False + freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) qualifier + in + if isImplicitlyImported || isNotExplicitlyImportedFromPrim || isModule + then imports + else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports + where + refFromDeclaration (IdeDeclTypeClass tc) = + P.TypeClassRef ideSpan (tc ^. ideTCName) + refFromDeclaration (IdeDeclDataConstructor dtor) = + P.TypeRef ideSpan (dtor ^. ideDtorTypeName) Nothing + refFromDeclaration (IdeDeclType t) = + P.TypeRef ideSpan (t ^. ideTypeName) (Just []) + refFromDeclaration (IdeDeclValueOperator op) = + P.ValueOpRef ideSpan (op ^. ideValueOpName) + refFromDeclaration (IdeDeclTypeOperator op) = + P.TypeOpRef ideSpan (op ^. ideTypeOpName) + refFromDeclaration d = + P.ValueRef ideSpan (P.Ident (identifierFromIdeDeclaration d)) + + -- | Adds a declaration to an import: + -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) + insertDeclIntoImport :: IdeDeclaration -> Import -> Import + insertDeclIntoImport decl' (Import mn (P.Explicit refs) qual) = + Import mn (P.Explicit (sort (insertDeclIntoRefs decl' refs))) qual + insertDeclIntoImport _ is = is + + insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef] + insertDeclIntoRefs d@(IdeDeclDataConstructor dtor) refs = + updateAtFirstOrPrepend + (matchType (dtor ^. ideDtorTypeName)) + (insertDtor (dtor ^. ideDtorName)) + (refFromDeclaration d) + refs + insertDeclIntoRefs (IdeDeclType t) refs + | any matches refs = refs + where + matches (P.TypeRef _ typeName _) = _ideTypeName t == typeName + matches _ = False + insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) + + insertDtor _ (P.TypeRef ss tn' _) = P.TypeRef ss tn' Nothing + insertDtor _ refs = refs + + matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool + matchType tn (P.TypeRef _ n _) = tn == n + matchType _ _ = False + + +-- | Looks up the given identifier in the currently loaded modules. +-- +-- * Throws an error if the identifier cannot be found. +-- +-- * If exactly one match is found, adds an explicit import to the importsection +-- +-- * If more than one possible imports are found, reports the possibilities as a +-- list of completions. +addImportForIdentifier + :: (Ide m, MonadError IdeError m) + => FilePath -- ^ The Sourcefile to read from + -> Text -- ^ The identifier to import + -> Maybe P.ModuleName -- ^ The optional qualifier under which to import + -> [Filter] -- ^ Filters to apply before searching for the identifier + -> m (Either [Match IdeDeclaration] [Text]) +addImportForIdentifier fp ident qual filters = do + let addPrim = Map.union idePrimDeclarations + modules <- getAllModules Nothing + let + matches = + getExactMatches ident filters (addPrim modules) + & map (fmap discardAnn) + & filter (\(Match (_, d)) -> not (has _IdeDeclModule d)) + + case matches of + [] -> + throwError (NotFound "Couldn't find the given identifier. \ + \Have you loaded the corresponding module?") + + -- Only one match was found for the given identifier, so we can insert it + -- right away + [Match (m, decl)] -> + Right <$> addExplicitImport fp decl m qual + + -- This case comes up for newtypes and dataconstructors. Because values and + -- types don't share a namespace we can get multiple matches from the same + -- module. This also happens for parameterized types, as these generate both + -- a type as well as a type synonym. + + ms@[Match (m1, d1), Match (m2, d2)] -> + if m1 /= m2 + -- If the modules don't line up we just ask the user to specify the + -- module + then pure (Left ms) + else case decideRedundantCase d1 d2 <|> decideRedundantCase d2 d1 of + -- If dataconstructor and type line up we just import the + -- dataconstructor as that will give us an unnecessary import warning at + -- worst + Just decl -> + Right <$> addExplicitImport fp decl m1 qual + -- Here we need the user to specify whether they wanted a + -- dataconstructor or a type + Nothing -> + throwError (GeneralError "Undecidable between type and dataconstructor") + + -- Multiple matches were found so we need to ask the user to clarify which + -- module they meant + xs -> + pure (Left xs) + where + decideRedundantCase d@(IdeDeclDataConstructor dtor) (IdeDeclType t) = + if dtor ^. ideDtorTypeName == t ^. ideTypeName then Just d else Nothing + decideRedundantCase IdeDeclType{} ts@IdeDeclTypeSynonym{} = + Just ts + decideRedundantCase _ _ = Nothing + +-- | Writes a list of lines to @Just filepath@ and responds with a @TextResult@, +-- or returns the lines as a @MultilineTextResult@ if @Nothing@ was given as the +-- first argument. +answerRequest :: (MonadIO m) => Maybe FilePath -> [Text] -> m Success +answerRequest outfp rs = + case outfp of + Nothing -> pure (MultilineTextResult rs) + Just outfp' -> do + liftIO (writeUTF8FileT outfp' (T.unlines rs)) + pure (TextResult ("Written to " <> T.pack outfp')) + + +-- | If none of the elements of the list satisfy the given predicate 'predicate', then prepend the default value 'def' +-- to the given list. Otherwise, update the first element of the list that satisfies 'predicate' with the updating +-- function 'update'. +updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a] +updateAtFirstOrPrepend predicate update def xs = + case break predicate xs of + (before, []) -> def : before + (before, x : after) -> before ++ [update x] ++ after + + +ideSpan :: P.SourceSpan +ideSpan = P.internalModuleSourceSpan "" + +joinSections :: ([Text], [Text], [Text]) -> [Text] +joinSections (pre, decls, post) = pre `joinLine` (decls `joinLine` post) + where + isBlank = T.all (== ' ') + joinLine as bs + | Just ln1 <- lastMay as + , Just ln2 <- head bs + , not (isBlank ln1) && not (isBlank ln2) = + as ++ [""] ++ bs + | otherwise = + as ++ bs diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index ea397c5bbf..2e4eb1f698 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -6,13 +6,14 @@ import qualified Data.Set as Set import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Filter.Declaration as D import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Imports import Language.PureScript.Ide.Test as T import qualified Language.PureScript as P import Test.Hspec type Module = (P.ModuleName, [IdeDeclarationAnn]) -moduleA, moduleB, moduleC, moduleD, moduleE, moduleF, moduleG, moduleH, moduleI :: Module +moduleA, moduleB, moduleC, moduleD, moduleE, moduleF, moduleG, moduleH, moduleI, moduleDCtors :: Module moduleA = (P.moduleNameFromString "Module.A", [T.ideValue "function1" Nothing]) moduleB = (P.moduleNameFromString "Module.B", [T.ideValue "data1" Nothing]) moduleC = (P.moduleNameFromString "Module.C", [T.ideType "List" Nothing []]) @@ -22,10 +23,14 @@ moduleF = (P.moduleNameFromString "Module.F", [T.ideDtor "DtorA" "TypeA" Nothing moduleG = (P.moduleNameFromString "Module.G", [T.ideTypeClass "MyClass" P.kindType []]) moduleH = (P.moduleNameFromString "Module.H", [T.ideValueOp "<$>" (P.Qualified P.ByNullSourcePos (Left "")) 0 Nothing Nothing]) moduleI = (P.moduleNameFromString "Module.I", [T.ideTypeOp "~>" (P.Qualified P.ByNullSourcePos "") 0 Nothing Nothing]) +moduleDCtors = (P.moduleNameFromString "Module.WithDC", [T.ideType "Foo" Nothing [(P.ProperName "A", P.tyString), (P.ProperName "B", P.tyString)] ]) modules :: ModuleMap [IdeDeclarationAnn] modules = Map.fromList [moduleA, moduleB] +allModules :: ModuleMap [IdeDeclarationAnn] +allModules = Map.fromList [moduleA, moduleB,moduleC,moduleD,moduleE,moduleF,moduleG,moduleH,moduleI,moduleDCtors] + runEq :: Text -> [Module] runEq s = Map.toList (applyFilters [exactFilter s] modules) @@ -41,6 +46,20 @@ runNamespace namespaces = Map.toList . applyFilters [namespaceFilter namespaces] runDeclaration :: [D.DeclarationType] -> [Module] -> [Module] runDeclaration decls = Map.toList . applyFilters [declarationTypeFilter (Set.fromList decls)] . Map.fromList +runDependency :: [Text] -> [Module] +runDependency = runDependency' "Whatever" + +runDependency' :: Text -> [Text] -> [Module] +runDependency' currentModuleName imports = Map.toList $ applyFilters [dependencyFilter Nothing (P.ModuleName currentModuleName) (testParseImports currentModuleName imports)] allModules + +runDependencyQualified :: Text -> [Text] -> [Module] +runDependencyQualified qualifier imports = Map.toList $ applyFilters [dependencyFilter (Just $ P.ModuleName qualifier) (P.ModuleName "Whatever") (testParseImports "Whatever" imports)] allModules + +testParseImports :: Text -> [Text] -> [Import] +testParseImports currentModuleName imports = either (const []) (\(_, _, x, _) -> x) $ sliceImportSection moduleLines + where + moduleLines = "module " <> currentModuleName <> " where" : (imports <> [ "", "blah = 42" ]) + spec :: Spec spec = do describe "equality Filter" $ do @@ -130,3 +149,45 @@ spec = do it "extracts modules by filtering `value`, and `valueoperator` declarations" $ runDeclaration [D.Value, D.ValueOperator] [moduleA, moduleB, moduleD, moduleG, moduleE, moduleH] `shouldBe` [moduleA, moduleB, moduleH] + describe "dependencyFilter" $ do + describe "import types" $ do + it "filters by implicit imports" $ do + runDependency ["import Module.A", "import Module.C"] `shouldBe` [moduleA, moduleC] + it "filters by matching explicit value import" $ do + runDependency ["import Module.A (function1)"] `shouldBe` [moduleA] + it "filters by matching explicit value import from correct module" $ do + runDependency ["import Module.B (function1)"] `shouldBe` [] + it "filters not matching explicit value import" $ do + runDependency ["import Module.A (function2)"] `shouldBe` [] + it "filters out names in hiding import" $ do + runDependency ["import Module.A hiding (function1)"] `shouldBe` [] + it "doesn't filter out not matching names in hiding import" $ do + runDependency ["import Module.A hiding (nonsense)"] `shouldBe` [moduleA] + it "filters by containing module" $ do + runDependency' "Module.A" ["import Module.Blah"] `shouldBe` [moduleA] + describe "declaration types" $ do + it "matches type" $ do + runDependency ["import Module.C (List)"] `shouldBe` [moduleC] + it "includes data constructor with (..)" $ do + runDependency ["import Module.F (TypeA(..))"] `shouldBe` [moduleF] + it "includes data constructor explicitly listed" $ do + runDependency ["import Module.F (TypeA(DtorA))"] `shouldBe` [moduleF] + it "does not include data constructor not explicitly listed" $ do + runDependency ["import Module.F (TypeA(BogusOtherConstructor))"] `shouldBe` [] + it "does not include data constructor when only the type is imported" $ do + runDependency ["import Module.F (TypeA)"] `shouldBe` [] + it "includes synonym" $ do + runDependency ["import Module.E (SFType)"] `shouldBe` [moduleE] + it "includes typeclass" $ do + runDependency ["import Module.G (class MyClass)"] `shouldBe` [moduleG] + it "includes value op" $ do + runDependency ["import Module.H ((<$>))"] `shouldBe` [moduleH] + it "includes type op" $ do + runDependency ["import Module.I (type (~>))"] `shouldBe` [moduleI] + describe "qualifiers" $ do + it "includes single qualified import and not unqualified things" $ do + runDependencyQualified "AA" [ "import Module.A as AA", "import Module.C"] `shouldBe` [moduleA] + it "includes multiple qualified imports" $ do + runDependencyQualified "Combined.Thing" [ "import Module.A as Combined.Thing", "import Module.C as Combined.Thing", "import Module.F"] `shouldBe` [moduleA, moduleC] + it "doesn't include qualified import when qualifier not specified" $ do + runDependency [ "import Module.AA as A"] `shouldBe` [] diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index e56f23a857..91c51c7045 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -8,6 +8,7 @@ import qualified Language.PureScript as P import Language.PureScript.Ide.Command as Command import Language.PureScript.Ide.Error import Language.PureScript.Ide.Imports +import Language.PureScript.Ide.Imports.Actions import Language.PureScript.Ide.Filter (moduleFilter) import qualified Language.PureScript.Ide.Test as Test import Language.PureScript.Ide.Types From 45cb5d55f08e45c2ac66dc9cd6f9c898a6c3da2e Mon Sep 17 00:00:00 2001 From: Verity Scheel Date: Wed, 2 Nov 2022 20:17:13 -0500 Subject: [PATCH 1515/1580] Add variable name, spans to DuplicateDeclarationsInLet error (#4405) Shows the last of the duplicate variable declarations first, since that seems to be preferred in psa and IDEs --- CHANGELOG.d/misc_overlapping-let.md | 1 + src/Language/PureScript/Errors.hs | 8 +++---- src/Language/PureScript/Sugar/Names.hs | 21 ++++++++++++------ .../failing/DuplicateDeclarationsInLet.out | 4 ++-- .../failing/DuplicateDeclarationsInLet.purs | 2 -- .../failing/DuplicateDeclarationsInLet2.out | 10 +++++++++ .../failing/DuplicateDeclarationsInLet2.purs | 10 +++++++++ .../failing/DuplicateDeclarationsInLet3.out | 22 +++++++++++++++++++ .../failing/DuplicateDeclarationsInLet3.purs | 16 ++++++++++++++ 9 files changed, 79 insertions(+), 15 deletions(-) create mode 100644 CHANGELOG.d/misc_overlapping-let.md create mode 100644 tests/purs/failing/DuplicateDeclarationsInLet2.out create mode 100644 tests/purs/failing/DuplicateDeclarationsInLet2.purs create mode 100644 tests/purs/failing/DuplicateDeclarationsInLet3.out create mode 100644 tests/purs/failing/DuplicateDeclarationsInLet3.purs diff --git a/CHANGELOG.d/misc_overlapping-let.md b/CHANGELOG.d/misc_overlapping-let.md new file mode 100644 index 0000000000..0100fe2e42 --- /dev/null +++ b/CHANGELOG.d/misc_overlapping-let.md @@ -0,0 +1 @@ +* Improve `DuplicateDeclarationsInLet` error so that it mentions what variable names were duplicated, reporting several in separate errors as necessary. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index eecbfc3ce3..872022d065 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -79,7 +79,7 @@ data SimpleErrorMessage | OrphanKindDeclaration (ProperName 'TypeName) | OrphanRoleDeclaration (ProperName 'TypeName) | RedefinedIdent Ident - | OverlappingNamesInLet + | OverlappingNamesInLet Ident | UnknownName (Qualified Name) | UnknownImport ModuleName Name | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName) @@ -258,7 +258,7 @@ errorCode em = case unwrapErrorMessage em of OrphanKindDeclaration{} -> "OrphanKindDeclaration" OrphanRoleDeclaration{} -> "OrphanRoleDeclaration" RedefinedIdent{} -> "RedefinedIdent" - OverlappingNamesInLet -> "OverlappingNamesInLet" + OverlappingNamesInLet{} -> "OverlappingNamesInLet" UnknownName{} -> "UnknownName" UnknownImport{} -> "UnknownImport" UnknownImportDataConstructor{} -> "UnknownImportDataConstructor" @@ -731,8 +731,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon line "The last statement in a 'do' block must be an expression, but this block ends with a binder." renderSimpleErrorMessage InvalidDoLet = line "The last statement in a 'do' block must be an expression, but this block ends with a let binding." - renderSimpleErrorMessage OverlappingNamesInLet = - line "The same name was used more than once in a let binding." + renderSimpleErrorMessage (OverlappingNamesInLet name) = + line $ "The name " <> markCode (showIdent name) <> " was defined multiple times in a binding group" renderSimpleErrorMessage (InfiniteType ty) = paras [ line "An infinite type was inferred for an expression: " , markCodeBox $ indent $ prettyType ty diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 03968af376..7c09126af8 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -10,14 +10,15 @@ module Language.PureScript.Sugar.Names ) where import Prelude -import Protolude (ordNub, sortOn, swap, foldl') +import Protolude (sortOn, swap, foldl') -import Control.Arrow (first, second) +import Control.Arrow (first, second, (&&&)) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Lazy import Control.Monad.Writer (MonadWriter(..)) +import qualified Data.List.NonEmpty as NEL import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -253,9 +254,15 @@ renameInModule imports (Module modSS coms mn decls exps) = updateValue (pos, bound) (Abs (VarBinder ss arg) val') = return ((pos, M.insert arg (spanStart ss) bound), Abs (VarBinder ss arg) val') updateValue (pos, bound) (Let w ds val') = do - let args = mapMaybe letBoundVariable ds - unless (length (ordNub args) == length args) . - throwError . errorMessage' pos $ OverlappingNamesInLet + let + args = mapMaybe letBoundVariable ds + groupByFst = map (\ts -> (fst (NEL.head ts), snd <$> ts)) . NEL.groupAllWith fst + duplicateArgsErrs = foldMap mkArgError $ groupByFst args + mkArgError (ident, poses) + | NEL.length poses < 2 = mempty + | otherwise = errorMessage'' (NEL.reverse poses) (OverlappingNamesInLet ident) + when (nonEmpty duplicateArgsErrs) $ + throwError duplicateArgsErrs return ((pos, declarationsToMap ds `M.union` bound), Let w ds val') updateValue (_, bound) (Var ss name'@(Qualified qualifiedBy ident)) = ((ss, bound), ) <$> case (M.lookup ident bound, qualifiedBy) of @@ -324,8 +331,8 @@ renameInModule imports (Module modSS coms mn decls exps) = . fmap (second spanStart . swap) . binderNamesWithSpans - letBoundVariable :: Declaration -> Maybe Ident - letBoundVariable = fmap valdeclIdent . getValueDeclaration + letBoundVariable :: Declaration -> Maybe (Ident, SourceSpan) + letBoundVariable = fmap (valdeclIdent &&& (fst . valdeclSourceAnn)) . getValueDeclaration declarationsToMap :: [Declaration] -> M.Map Ident SourcePos declarationsToMap = foldl goDTM M.empty diff --git a/tests/purs/failing/DuplicateDeclarationsInLet.out b/tests/purs/failing/DuplicateDeclarationsInLet.out index 831dad6fc2..038e5e23c9 100644 --- a/tests/purs/failing/DuplicateDeclarationsInLet.out +++ b/tests/purs/failing/DuplicateDeclarationsInLet.out @@ -1,8 +1,8 @@ Error found: in module Main -at tests/purs/failing/DuplicateDeclarationsInLet.purs:6:7 - 6:8 (line 6, column 7 - line 6, column 8) +at tests/purs/failing/DuplicateDeclarationsInLet.purs:9:3 - 9:14 (line 9, column 3 - line 9, column 14) - The same name was used more than once in a let binding. + The name a was defined multiple times in a binding group See https://github.com/purescript/documentation/blob/master/errors/OverlappingNamesInLet.md for more information, diff --git a/tests/purs/failing/DuplicateDeclarationsInLet.purs b/tests/purs/failing/DuplicateDeclarationsInLet.purs index fed163d7aa..861a607d42 100644 --- a/tests/purs/failing/DuplicateDeclarationsInLet.purs +++ b/tests/purs/failing/DuplicateDeclarationsInLet.purs @@ -1,8 +1,6 @@ -- @shouldFailWith OverlappingNamesInLet module Main where -import Prelude - foo = a where a :: Number diff --git a/tests/purs/failing/DuplicateDeclarationsInLet2.out b/tests/purs/failing/DuplicateDeclarationsInLet2.out new file mode 100644 index 0000000000..25957ecbc8 --- /dev/null +++ b/tests/purs/failing/DuplicateDeclarationsInLet2.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DuplicateDeclarationsInLet2.purs:10:3 - 10:24 (line 10, column 3 - line 10, column 24) + + The name interrupted was defined multiple times in a binding group + + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingNamesInLet.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DuplicateDeclarationsInLet2.purs b/tests/purs/failing/DuplicateDeclarationsInLet2.purs new file mode 100644 index 0000000000..98549b3b1f --- /dev/null +++ b/tests/purs/failing/DuplicateDeclarationsInLet2.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith OverlappingNamesInLet +module Main where + +foo = interrupted + where + interrupted true = 1 + + interrupter = 2 + + interrupted false = 3 diff --git a/tests/purs/failing/DuplicateDeclarationsInLet3.out b/tests/purs/failing/DuplicateDeclarationsInLet3.out new file mode 100644 index 0000000000..33d911057f --- /dev/null +++ b/tests/purs/failing/DuplicateDeclarationsInLet3.out @@ -0,0 +1,22 @@ +Error 1 of 2: + + in module Main + at tests/purs/failing/DuplicateDeclarationsInLet3.purs:9:3 - 9:11 (line 9, column 3 - line 9, column 11) + + The name a was defined multiple times in a binding group + + + See https://github.com/purescript/documentation/blob/master/errors/OverlappingNamesInLet.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module Main + at tests/purs/failing/DuplicateDeclarationsInLet3.purs:16:3 - 16:24 (line 16, column 3 - line 16, column 24) + + The name interrupted was defined multiple times in a binding group + + + See https://github.com/purescript/documentation/blob/master/errors/OverlappingNamesInLet.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/failing/DuplicateDeclarationsInLet3.purs b/tests/purs/failing/DuplicateDeclarationsInLet3.purs new file mode 100644 index 0000000000..9ca900ea58 --- /dev/null +++ b/tests/purs/failing/DuplicateDeclarationsInLet3.purs @@ -0,0 +1,16 @@ +-- @shouldFailWith OverlappingNamesInLet +-- @shouldFailWith OverlappingNamesInLet +module Main where + +-- Should see separate errors for `a` and `interrupted` +foo = interrupter + a + where + a = 0 + a :: Int + a = 0 + + interrupted true = 1 + + interrupter = 2 + + interrupted false = 3 From 10609242a269b4409fb7d4571fc905cd9fc999cb Mon Sep 17 00:00:00 2001 From: Ruslan Gadeev Date: Fri, 11 Nov 2022 03:08:56 +0300 Subject: [PATCH 1516/1580] Fix typos (#4415) --- CHANGELOG.d/misc_fix-typos.md | 1 + CONTRIBUTORS.md | 1 + psc-ide/DESIGN.org | 2 +- src/Language/PureScript/CST/Layout.hs | 2 +- src/Language/PureScript/Ide/Matcher.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 4 ++-- .../TypeChecker/Entailment/Coercible.hs | 16 ++++++++-------- src/Language/PureScript/TypeChecker/Kinds.hs | 2 +- src/Language/PureScript/Types.hs | 2 +- 9 files changed, 17 insertions(+), 15 deletions(-) create mode 100644 CHANGELOG.d/misc_fix-typos.md diff --git a/CHANGELOG.d/misc_fix-typos.md b/CHANGELOG.d/misc_fix-typos.md new file mode 100644 index 0000000000..6daaeb3cc1 --- /dev/null +++ b/CHANGELOG.d/misc_fix-typos.md @@ -0,0 +1 @@ +* Fix various typos in documentation and source comments. \ No newline at end of file diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index a891e1211b..9c62eee433 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -161,6 +161,7 @@ If you would prefer to use different terms, please use the section below instead | [@j-nava](https://github.com/j-nava) | Jesse Nava | [MIT license](http://opensource.org/licenses/MIT) | | [@imcotton](https://github.com/imcotton) | Cotton Hou | [MIT license](http://opensource.org/licenses/MIT) | | [@wclr](https://github.com/wclr) | Alex Osh | [MIT license](http://opensource.org/licenses/MIT) | +| [@Deltaspace0](https://github.com/Deltaspace0) | Ruslan Gadeev | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/psc-ide/DESIGN.org b/psc-ide/DESIGN.org index 432d40bcad..45b77f22a3 100644 --- a/psc-ide/DESIGN.org +++ b/psc-ide/DESIGN.org @@ -122,7 +122,7 @@ =ide= makes sure to not run into deadlocks or data races. However the current implementation of =purs ide server= runs all the commands - sequentially, because the commmands run fast enough at this point, and a + sequentially, because the commands run fast enough at this point, and a users interaction with his editor are mostly sequential anyway. * Commands The three most involved commands are completion, adding imports and rebuilding. diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs index 2b32704373..ea2dbfa769 100644 --- a/src/Language/PureScript/CST/Layout.hs +++ b/src/Language/PureScript/CST/Layout.hs @@ -82,7 +82,7 @@ -- ] of -- @ -- --- Which of the above 13 commas function as the separaters between the +-- Which of the above 13 commas function as the separators between the -- case binders (e.g. @one@) in the outermost @case ... of@ context? -- -- ### The Solution diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index 40b8283a02..9263abdb5e 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -94,7 +94,7 @@ flexRate p c = do -- Borrowed from: http://cdewaka.com/2013/06/fuzzy-pattern-matching-in-haskell/ -- -- By string =~ pattern we'll get the start of the match and the length of --- the matchas a (start, length) tuple if there's a match. +-- the matches a (start, length) tuple if there's a match. -- If match fails then it would be (-1,0) flexScore :: Text -> Text -> Maybe Double flexScore pat str = diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index ca3c282d3a..f830a31c09 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -184,7 +184,7 @@ rebracketFiltered !caller pred_ externs m = do -- | Indicates whether the `rebracketModule` -- is being called with the full desugar pass -- run via `purs compile` or whether --- only the partial desguar pass is run +-- only the partial desugar pass is run -- via `purs docs`. -- This indication is needed to prevent -- a `purs docs` error when using @@ -216,7 +216,7 @@ rebracketModule !caller pred_ valueOpTable typeOpTable (Module ss coms mn ds ext -- and only some of the desugar passes when generating docs. -- When generating docs, `case _ of` syntax used in an instance declaration -- can trigger the `IncorrectAnonymousArgument` error because it does not - -- run the same passes that the compile desguaring does. Since `purs docs` + -- run the same passes that the compile desugaring does. Since `purs docs` -- will only succeed once `purs compile` succeeds, we can ignore this check -- when running `purs docs`. -- See https://github.com/purescript/purescript/issues/4274#issuecomment-1087730651= diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index ab6a2338a2..666fc398c6 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -373,8 +373,8 @@ interactDiffTyVar env (_, tv1, ty1) (tv2, ty2) -- | A canonical constraint of the form @Coercible tv1 ty1@ can rewrite the -- right hand side of an irreducible constraint of the form @Coercible tv2 ty2@ --- by substituting @ty1@ for every occurence of @tv1@ at representational and --- phantom role in @ty2@. Nominal occurences are left untouched. +-- by substituting @ty1@ for every occurrence of @tv1@ at representational and +-- phantom role in @ty2@. Nominal occurrences are left untouched. rewrite :: Environment -> (SourceType, SourceType) -> SourceType -> Writer Any SourceType rewrite env (Skolem _ _ _ s1 _, ty1) | not $ occurs s1 ty1 = go where go (Skolem _ _ _ s2 _) | s1 == s2 = tell (Any True) $> ty1 @@ -506,7 +506,7 @@ canon env givens k a b = -- -- yield the wanted @Coercible (N Maybe a) (N Maybe b)@ which we cannot -- decompose because the second parameter of @N@ is nominal. On the other - -- hand, unwraping on both sides yields @Coercible (Maybe a) (Maybe b)@ + -- hand, unwrapping on both sides yields @Coercible (Maybe a) (Maybe b)@ -- which we can then decompose to @Coercible a b@ and discharge with the -- given. <|> canonNewtypeLeft env a b @@ -601,7 +601,7 @@ canonRow a b throwError . errorMessage $ TypesDoNotUnify (rowFromList rl1) (rowFromList rl2) | otherwise = empty --- | Unwraping a newtype can fails in two ways: +-- | Unwrapping a newtype can fails in two ways: data UnwrapNewtypeError = CannotUnwrapInfiniteNewtypeChain -- ^ The newtype might wrap an infinite newtype chain. We may think that this @@ -620,7 +620,7 @@ data UnwrapNewtypeError -- -- yield a wanted @Coercible (N a) (N b)@ that we can decompose to -- @Coercible a b@ then discharge with the given if the newtype - -- unwraping rules do not apply. + -- unwrapping rules do not apply. | CannotUnwrapConstructor -- ^ The constructor may not be in scope or may not belong to a newtype. @@ -709,7 +709,7 @@ lookupNewtypeConstructorInScope env currentModuleName currentModuleImports quali _ -> False -- | Constraints of the form @Coercible (N a_0 .. a_n) b@ yield a constraint --- @Coercible a b@ if unwraping the newtype yields @a@. +-- @Coercible a b@ if unwrapping the newtype yields @a@. canonNewtypeLeft :: MonadState CheckState m => MonadWriter [ErrorMessageHint] m @@ -724,7 +724,7 @@ canonNewtypeLeft env a b = Right a' -> pure . Canonicalized $ S.singleton (a', b) -- | Constraints of the form @Coercible a (N b_0 .. b_n)@ yield a constraint --- @Coercible a b@ if unwraping the newtype yields @b@. +-- @Coercible a b@ if unwrapping the newtype yields @b@. canonNewtypeRight :: MonadState CheckState m => MonadWriter [ErrorMessageHint] m @@ -829,7 +829,7 @@ canonDecompositionFailure env k a b -- Decomposing a given @Coercible (Const a a) (Const a b)@ constraint to -- @Coercible a b@ when @MkConst@ is out of scope would let us coerce arbitrary -- types in modules where @MkConst@ is imported, because the given is easily --- satisfied with the newtype unwraping rules. +-- satisfied with the newtype unwrapping rules. -- -- Moreover we do not decompose wanted constraints if they could be discharged -- by a given constraint. diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 4c9e8555a1..e9ddf6cd31 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -910,7 +910,7 @@ checkKindDeclaration _ ty = do checkQuantification finalTy checkValidKind finalTy where - -- When expanding type synoyms and generalizing, we need to generate more + -- When expanding type synonyms and generalizing, we need to generate more -- unique names so that they don't clash or shadow other names, or can -- be referenced (easily). freshVar arg = (arg <>) . T.pack . show <$> fresh diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index c98f94459b..6e394cd980 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -365,7 +365,7 @@ typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do "ParensInType" -> do b <- contents ParensInType a <$> go b - -- Backwards compatability for kinds + -- Backwards compatibility for kinds "KUnknown" -> TUnknown a <$> contents "Row" -> From 7f72c6939d564c24c2a0c075401af65748a93e17 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 10 Nov 2022 19:15:58 -0500 Subject: [PATCH 1517/1580] Document our evolving changelog principles (#4288) --- CHANGELOG.d/README.md | 35 +++++++++++++++++++++++++++-------- 1 file changed, 27 insertions(+), 8 deletions(-) diff --git a/CHANGELOG.d/README.md b/CHANGELOG.d/README.md index 2d9698909c..7fa2fa83e1 100644 --- a/CHANGELOG.d/README.md +++ b/CHANGELOG.d/README.md @@ -6,13 +6,32 @@ Maintainers: see update-changelog.hs for details of this process. Contributors: read on! -When you are preparing a new PR, add a new file to this directory. The file -should be named `{PREFIX}_{SLUG}.md`, where `{PREFIX}` is one of the following: -* `breaking`: for breaking changes -* `feature`: for new features -* `fix`: for bug fixes -* `internal`: for work that will not directly affect users of PureScript -* `misc`: for anything else that needs to be logged +Our guiding principle is that the changelog is a tool for users—people who +depend on PureScript as a compiler or as a library—who are considering +upgrading, or have recently upgraded, their PureScript compiler version. We ask +that when making changes that such users might need to know about, you help +them out by adding to our changelog. + +Work that doesn't change the compiler (such as updates to README.md) doesn't +need a changelog entry. But keep in mind that even parts of the project like +our CI workflow can introduce changes to the compiler we release. + +When you are preparing a new PR that does change the compiler, add a new file +to this directory. The file should be named `{PREFIX}_{SLUG}.md`, where +`{PREFIX}` is one of the following: +* `breaking`: for breaking changes to the compiler, for which a user may need to do + work to their project before or immediately upon upgrading +* `feature`: for new features, which might prevent a user from downgrading to an + earlier version +* `fix`: for bug fixes, which might motivate a user to upgrade +* `internal`: for work that is not expected to directly affect users; these + entries should usually be brief, but may serve as useful starting points for + investigations if a change ends up having unintended consequences + +(There is also a fifth prefix, `misc`. This is an escape hatch in case we have +something that somehow doesn't fit in the above categories but that we want to +include in the changelog, which frankly seems unlikely given how much of a +catch-all `internal` is. We'll tell you if you should use this one.) `{SLUG}` should be a short description of the work you've done. The name has no impact on the final CHANGELOG.md. @@ -20,7 +39,7 @@ impact on the final CHANGELOG.md. Some example names: * `fix_issue-9876.md` * `breaking_deprecate-classes.md` -* `misc_add-forum-to-readme.md` +* `internal_use-ubuntu-38.04-in-ci.md` The contents of the file can be as brief as: From 5f6a6659391563cdec3c41ac6a4b2ff5263d0f68 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Tue, 15 Nov 2022 22:32:07 -0500 Subject: [PATCH 1518/1580] Organize the compiler's internal constants files (#4406) --- CHANGELOG.d/internal_organize-constants.md | 1 + purescript.cabal | 8 +- src/Language/PureScript/AST/Declarations.hs | 2 +- src/Language/PureScript/CodeGen/JS.hs | 2 +- .../PureScript/Constants/Data/Foldable.hs | 28 -- .../PureScript/Constants/Data/Generic/Rep.hs | 39 -- .../PureScript/Constants/Data/Newtype.hs | 6 - .../PureScript/Constants/Data/Traversable.hs | 19 - src/Language/PureScript/Constants/Libs.hs | 235 +++++++++ src/Language/PureScript/Constants/Prelude.hs | 455 ------------------ src/Language/PureScript/Constants/Prim.hs | 240 ++------- src/Language/PureScript/Constants/TH.hs | 224 +++++++++ src/Language/PureScript/CoreFn/CSE.hs | 2 +- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- src/Language/PureScript/CoreFn/Laziness.hs | 7 +- src/Language/PureScript/CoreFn/Optimizer.hs | 9 +- .../PureScript/CoreImp/Optimizer/Common.hs | 15 +- .../PureScript/CoreImp/Optimizer/Inliner.hs | 357 +++++--------- .../PureScript/CoreImp/Optimizer/MagicDo.hs | 50 +- .../PureScript/CoreImp/Optimizer/Unused.hs | 2 +- src/Language/PureScript/Docs/Prim.hs | 135 +++--- src/Language/PureScript/Environment.hs | 178 +++---- src/Language/PureScript/Errors.hs | 33 +- .../PureScript/Ide/Imports/Actions.hs | 4 +- src/Language/PureScript/Ide/Prim.hs | 16 +- src/Language/PureScript/Linter.hs | 4 +- src/Language/PureScript/Linter/Imports.hs | 2 +- src/Language/PureScript/Sugar/AdoNotation.hs | 8 +- src/Language/PureScript/Sugar/DoNotation.hs | 10 +- src/Language/PureScript/Sugar/Names/Env.hs | 18 +- src/Language/PureScript/Sugar/Operators.hs | 4 +- src/Language/PureScript/Sugar/TypeClasses.hs | 14 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 43 +- src/Language/PureScript/TypeChecker.hs | 7 +- .../PureScript/TypeChecker/Deriving.hs | 66 ++- .../PureScript/TypeChecker/Entailment.hs | 32 +- .../TypeChecker/Entailment/IntCompare.hs | 14 +- weeder.dhall | 7 + 38 files changed, 949 insertions(+), 1349 deletions(-) create mode 100644 CHANGELOG.d/internal_organize-constants.md delete mode 100644 src/Language/PureScript/Constants/Data/Foldable.hs delete mode 100644 src/Language/PureScript/Constants/Data/Generic/Rep.hs delete mode 100644 src/Language/PureScript/Constants/Data/Newtype.hs delete mode 100644 src/Language/PureScript/Constants/Data/Traversable.hs create mode 100644 src/Language/PureScript/Constants/Libs.hs delete mode 100644 src/Language/PureScript/Constants/Prelude.hs create mode 100644 src/Language/PureScript/Constants/TH.hs diff --git a/CHANGELOG.d/internal_organize-constants.md b/CHANGELOG.d/internal_organize-constants.md new file mode 100644 index 0000000000..1d0f0103d5 --- /dev/null +++ b/CHANGELOG.d/internal_organize-constants.md @@ -0,0 +1 @@ +* Organize the compiler's internal constants files diff --git a/purescript.cabal b/purescript.cabal index 4766e6ec50..57da11080e 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -176,6 +176,7 @@ common defaults stm >=2.5.0.2 && <2.6, stringsearch >=0.3.6.6 && <0.4, syb >=0.7.2.1 && <0.8, + template-haskell >=2.18.0.0 && <2.19, text >=1.2.5.0 && <1.3, these >=1.1.1.1 && <1.2, time >=1.11.1.1 && <1.12, @@ -211,11 +212,7 @@ library Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.Common Language.PureScript.CodeGen.JS.Printer - Language.PureScript.Constants.Prelude - Language.PureScript.Constants.Data.Foldable - Language.PureScript.Constants.Data.Generic.Rep - Language.PureScript.Constants.Data.Newtype - Language.PureScript.Constants.Data.Traversable + Language.PureScript.Constants.Libs Language.PureScript.CoreFn Language.PureScript.CoreFn.Ann Language.PureScript.CoreFn.Binders @@ -373,6 +370,7 @@ library System.IO.UTF8 other-modules: Data.Text.PureScript + Language.PureScript.Constants.TH Paths_purescript autogen-modules: Paths_purescript diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 5d97ed8b83..2ac1ee1ded 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -147,7 +147,7 @@ addDefaultImport (Qualified toImportAs toImport) m@(Module ss coms mn decls exps importPrim :: Module -> Module importPrim = let - primModName = C.Prim + primModName = C.M_Prim in addDefaultImport (Qualified (ByModuleName primModName) primModName) . addDefaultImport (Qualified ByNullSourcePos primModName) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index b1f87ad4cc..f5a02fe8e3 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -393,7 +393,7 @@ moduleBindToJs mn = bindToJs -- | Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable that may have a qualified name. qualifiedToJS :: (a -> Ident) -> Qualified a -> AST - qualifiedToJS f (Qualified (ByModuleName C.Prim) a) = AST.Var Nothing . runIdent $ f a + qualifiedToJS f (Qualified (ByModuleName C.M_Prim) a) = AST.Var Nothing . runIdent $ f a qualifiedToJS f (Qualified (ByModuleName mn') a) | mn /= mn' = AST.ModuleAccessor Nothing mn' . mkString . T.concatMap identCharToText . runIdent $ f a qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToJs (f a) diff --git a/src/Language/PureScript/Constants/Data/Foldable.hs b/src/Language/PureScript/Constants/Data/Foldable.hs deleted file mode 100644 index f0692cd9f1..0000000000 --- a/src/Language/PureScript/Constants/Data/Foldable.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Language.PureScript.Constants.Data.Foldable where - -import Data.String (IsString) -import Language.PureScript.Names - -foldl :: forall a. (IsString a) => a -foldl = "foldl" - -foldr :: forall a. (IsString a) => a -foldr = "foldr" - -foldMap :: forall a. (IsString a) => a -foldMap = "foldMap" - -pattern DataFoldable :: ModuleName -pattern DataFoldable = ModuleName "Data.Foldable" - -pattern Foldable :: Qualified (ProperName 'ClassName) -pattern Foldable = Qualified (ByModuleName DataFoldable) (ProperName "Foldable") - -identFoldl :: Qualified Ident -identFoldl = Qualified (ByModuleName DataFoldable) (Ident foldl) - -identFoldr :: Qualified Ident -identFoldr = Qualified (ByModuleName DataFoldable) (Ident foldr) - -identFoldMap :: Qualified Ident -identFoldMap = Qualified (ByModuleName DataFoldable) (Ident foldMap) diff --git a/src/Language/PureScript/Constants/Data/Generic/Rep.hs b/src/Language/PureScript/Constants/Data/Generic/Rep.hs deleted file mode 100644 index 9d0b493f32..0000000000 --- a/src/Language/PureScript/Constants/Data/Generic/Rep.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Language.PureScript.Constants.Data.Generic.Rep where - -import Language.PureScript.Names - -pattern DataGenericRep :: ModuleName -pattern DataGenericRep = ModuleName "Data.Generic.Rep" - -pattern Generic :: Qualified (ProperName 'ClassName) -pattern Generic = Qualified (ByModuleName DataGenericRep) (ProperName "Generic") - -to :: Qualified Ident -to = Qualified (ByModuleName DataGenericRep) (Ident "to") - -from :: Qualified Ident -from = Qualified (ByModuleName DataGenericRep) (Ident "from") - -pattern NoConstructors :: Qualified (ProperName a) -pattern NoConstructors = Qualified (ByModuleName DataGenericRep) (ProperName "NoConstructors") - -pattern NoArguments :: Qualified (ProperName a) -pattern NoArguments = Qualified (ByModuleName DataGenericRep) (ProperName "NoArguments") - -pattern Sum :: Qualified (ProperName a) -pattern Sum = Qualified (ByModuleName DataGenericRep) (ProperName "Sum") - -pattern Inl :: Qualified (ProperName a) -pattern Inl = Qualified (ByModuleName DataGenericRep) (ProperName "Inl") - -pattern Inr :: Qualified (ProperName a) -pattern Inr = Qualified (ByModuleName DataGenericRep) (ProperName "Inr") - -pattern Product :: Qualified (ProperName a) -pattern Product = Qualified (ByModuleName DataGenericRep) (ProperName "Product") - -pattern Constructor :: Qualified (ProperName a) -pattern Constructor = Qualified (ByModuleName DataGenericRep) (ProperName "Constructor") - -pattern Argument :: Qualified (ProperName a) -pattern Argument = Qualified (ByModuleName DataGenericRep) (ProperName "Argument") diff --git a/src/Language/PureScript/Constants/Data/Newtype.hs b/src/Language/PureScript/Constants/Data/Newtype.hs deleted file mode 100644 index 620f305de0..0000000000 --- a/src/Language/PureScript/Constants/Data/Newtype.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Language.PureScript.Constants.Data.Newtype where - -import Language.PureScript.Names - -pattern Newtype :: Qualified (ProperName 'ClassName) -pattern Newtype = Qualified (ByModuleName (ModuleName "Data.Newtype")) (ProperName "Newtype") diff --git a/src/Language/PureScript/Constants/Data/Traversable.hs b/src/Language/PureScript/Constants/Data/Traversable.hs deleted file mode 100644 index 668ab43890..0000000000 --- a/src/Language/PureScript/Constants/Data/Traversable.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Language.PureScript.Constants.Data.Traversable where - -import Data.String (IsString) -import Language.PureScript.Names - -traverse :: forall a. (IsString a) => a -traverse = "traverse" - -sequence :: forall a. (IsString a) => a -sequence = "sequence" - -pattern DataTraversable :: ModuleName -pattern DataTraversable = ModuleName "Data.Traversable" - -pattern Traversable :: Qualified (ProperName 'ClassName) -pattern Traversable = Qualified (ByModuleName DataTraversable) (ProperName "Traversable") - -identTraverse :: Qualified Ident -identTraverse = Qualified (ByModuleName DataTraversable) (Ident traverse) diff --git a/src/Language/PureScript/Constants/Libs.hs b/src/Language/PureScript/Constants/Libs.hs new file mode 100644 index 0000000000..112a75ccb8 --- /dev/null +++ b/src/Language/PureScript/Constants/Libs.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TemplateHaskell #-} +-- | Various constants which refer to things in the Prelude and other core libraries +module Language.PureScript.Constants.Libs where + +import qualified Protolude as P + +import Data.String (IsString) +import Language.PureScript.PSString (PSString) +import qualified Language.PureScript.Constants.TH as TH + +-- Core lib values + +stRefValue :: forall a. IsString a => a +stRefValue = "value" + +-- Type Class Dictionary Names + +data EffectDictionaries = EffectDictionaries + { edApplicativeDict :: PSString + , edBindDict :: PSString + , edMonadDict :: PSString + , edWhile :: PSString + , edUntil :: PSString + } + +effDictionaries :: EffectDictionaries +effDictionaries = EffectDictionaries + { edApplicativeDict = "applicativeEff" + , edBindDict = "bindEff" + , edMonadDict = "monadEff" + , edWhile = "whileE" + , edUntil = "untilE" + } + +effectDictionaries :: EffectDictionaries +effectDictionaries = EffectDictionaries + { edApplicativeDict = "applicativeEffect" + , edBindDict = "bindEffect" + , edMonadDict = "monadEffect" + , edWhile = "whileE" + , edUntil = "untilE" + } + +stDictionaries :: EffectDictionaries +stDictionaries = EffectDictionaries + { edApplicativeDict = "applicativeST" + , edBindDict = "bindST" + , edMonadDict = "monadST" + , edWhile = "while" + , edUntil = "until" + } + +$(TH.declare do + + -- purescript-prelude + + TH.mod "Control.Apply" do + TH.asIdent do TH.asString do TH.var "apply" + + TH.mod "Control.Applicative" do + TH.asIdent do TH.asPair do TH.asString do TH.var "pure" + + TH.mod "Control.Bind" do + TH.asPair do + TH.asString do + TH.var "bind" + TH.cls "Discard" ; TH.var "discard" + + TH.var "discardUnit" + + TH.mod "Control.Category" do + TH.asPair do + TH.asIdent do TH.var "identity" + + TH.var "categoryFn" + + TH.mod "Control.Semigroupoid" do + TH.asPair do + TH.vars ["compose", "composeFlipped"] + TH.var "semigroupoidFn" + + TH.mod "Data.Bounded" do + TH.asPair do + TH.vars ["bottom", "top"] + TH.var "boundedBoolean" + + TH.mod "Data.Eq" do + TH.cls "Eq" ; TH.asIdent do TH.asPair do TH.asString do TH.var "eq" + TH.cls "Eq1" ; TH.asIdent do TH.asString do TH.var "eq1" + TH.asPair do + TH.var "notEq" + + TH.var "eqBoolean" + TH.var "eqChar" + TH.var "eqInt" + TH.var "eqNumber" + TH.var "eqString" + + TH.mod "Data.EuclideanRing" do + TH.asPair do + TH.var "div" + + TH.var "euclideanRingNumber" + + TH.mod "Data.Function" do + TH.prefixWith "function" do TH.asIdent do TH.vars ["apply", "applyFlipped"] + TH.asIdent do TH.var "flip" + + TH.mod "Data.Functor" do + TH.cls "Functor" ; TH.asIdent do TH.asString do TH.var "map" + + TH.mod "Data.Generic.Rep" do + TH.cls "Generic" ; TH.asIdent do TH.vars ["from", "to"] + TH.ntys ["Argument", "Constructor", "NoArguments", "NoConstructors", "Product"] + TH.dty "Sum" ["Inl", "Inr"] + + TH.mod "Data.HeytingAlgebra" do + TH.asPair do + TH.asIdent do TH.vars ["conj", "disj", "not"] + + TH.var "heytingAlgebraBoolean" + + TH.mod "Data.Monoid" do + TH.asIdent do TH.var "mempty" + + TH.mod "Data.Ord" do + TH.cls "Ord" ; TH.asIdent do TH.asString do TH.var "compare" + TH.cls "Ord1" ; TH.asIdent do TH.asString do TH.var "compare1" + TH.asPair do + TH.vars ["greaterThan", "greaterThanOrEq", "lessThan", "lessThanOrEq"] + + TH.var "ordBoolean" + TH.var "ordChar" + TH.var "ordInt" + TH.var "ordNumber" + TH.var "ordString" + + TH.mod "Data.Ordering" do + TH.dty "Ordering" ["EQ", "GT", "LT"] + + TH.mod "Data.Reflectable" do + TH.cls "Reflectable" + + TH.mod "Data.Ring" do + TH.asPair do + TH.asString do TH.vars ["negate", "sub"] + + TH.var "ringInt" + TH.var "ringNumber" + + TH.mod "Data.Semigroup" do + TH.asPair do + TH.asIdent do TH.var "append" + + TH.var "semigroupString" + + TH.mod "Data.Semiring" do + TH.asPair do + TH.vars ["add", "mul", "one", "zero"] + + TH.var "semiringInt" + TH.var "semiringNumber" + + TH.mod "Data.Symbol" do + TH.cls "IsSymbol" + + -- purescript-arrays + + TH.mod "Data.Array" do + TH.asPair do TH.var "unsafeIndex" + + -- purescript-eff + + TH.mod "Control.Monad.Eff" (P.pure ()) + + TH.mod "Control.Monad.Eff.Uncurried" do + TH.asPair do TH.vars ["mkEffFn", "runEffFn"] + + -- purescript-effect + + TH.mod "Effect" (P.pure ()) + + TH.mod "Effect.Uncurried" do + TH.asPair do TH.vars ["mkEffectFn", "runEffectFn"] + + -- purescript-foldable-traversable + + TH.mod "Data.Foldable" do + TH.cls "Foldable" ; TH.asIdent do TH.asString do TH.vars ["foldMap", "foldl", "foldr"] + + TH.mod "Data.Traversable" do + TH.cls "Traversable" ; TH.asString do TH.asIdent (TH.var "traverse") ; TH.var "sequence" + + -- purescript-functions + + TH.mod "Data.Function.Uncurried" do + TH.asPair do TH.asString do TH.vars ["mkFn", "runFn"] + + -- purescript-integers + + TH.mod "Data.Int.Bits" do + TH.asPair do + TH.var "and" + TH.var "complement" + TH.var "or" + TH.var "shl" + TH.var "shr" + TH.var "xor" + TH.var "zshr" + + -- purescript-newtype + + TH.mod "Data.Newtype" do + TH.cls "Newtype" + + -- purescript-partial + + TH.mod "Partial.Unsafe" do + TH.asIdent do TH.asPair do TH.var "unsafePartial" + + -- purescript-st + + TH.mod "Control.Monad.ST.Internal" do + TH.asPair do TH.vars ["modify", "new", "read", "run", "write"] + + TH.mod "Control.Monad.ST.Uncurried" do + TH.asPair do TH.vars ["mkSTFn", "runSTFn"] + + -- purescript-unsafe-coerce + + TH.mod "Unsafe.Coerce" do + TH.asPair do TH.var "unsafeCoerce" + + ) diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs deleted file mode 100644 index 2ae16c2e87..0000000000 --- a/src/Language/PureScript/Constants/Prelude.hs +++ /dev/null @@ -1,455 +0,0 @@ --- | Various constants which refer to things in the Prelude -module Language.PureScript.Constants.Prelude where - -import Data.String (IsString) -import Language.PureScript.PSString (PSString) -import Language.PureScript.Names - --- Operators - -apply :: forall a. (IsString a) => a -apply = "apply" - -applyFlipped :: forall a. (IsString a) => a -applyFlipped = "applyFlipped" - -append :: forall a. (IsString a) => a -append = "append" - -mempty :: forall a. (IsString a) => a -mempty = "mempty" - -bind :: forall a. (IsString a) => a -bind = "bind" - -discard :: forall a. (IsString a) => a -discard = "discard" - -pattern Discard :: Qualified (ProperName 'ClassName) -pattern Discard = Qualified (ByModuleName ControlBind) (ProperName "Discard") - -add :: forall a. (IsString a) => a -add = "add" - -sub :: forall a. (IsString a) => a -sub = "sub" - -mul :: forall a. (IsString a) => a -mul = "mul" - -div :: forall a. (IsString a) => a -div = "div" - -lessThan :: forall a. (IsString a) => a -lessThan = "lessThan" - -greaterThan :: forall a. (IsString a) => a -greaterThan = "greaterThan" - -lessThanOrEq :: forall a. (IsString a) => a -lessThanOrEq = "lessThanOrEq" - -greaterThanOrEq :: forall a. (IsString a) => a -greaterThanOrEq = "greaterThanOrEq" - -eq :: forall a. (IsString a) => a -eq = "eq" - -eq1 :: forall a. (IsString a) => a -eq1 = "eq1" - -notEq :: forall a. (IsString a) => a -notEq = "notEq" - -compare :: forall a. (IsString a) => a -compare = "compare" - -compare1 :: forall a. (IsString a) => a -compare1 = "compare1" - -conj :: forall a. (IsString a) => a -conj = "conj" - -disj :: forall a. (IsString a) => a -disj = "disj" - -unsafeIndex :: forall a. (IsString a) => a -unsafeIndex = "unsafeIndex" - -or :: forall a. (IsString a) => a -or = "or" - -and :: forall a. (IsString a) => a -and = "and" - -xor :: forall a. (IsString a) => a -xor = "xor" - -compose :: forall a. (IsString a) => a -compose = "compose" - -composeFlipped :: forall a. (IsString a) => a -composeFlipped = "composeFlipped" - -map :: forall a. (IsString a) => a -map = "map" - --- Functions - -negate :: forall a. (IsString a) => a -negate = "negate" - -not :: forall a. (IsString a) => a -not = "not" - -shl :: forall a. (IsString a) => a -shl = "shl" - -shr :: forall a. (IsString a) => a -shr = "shr" - -zshr :: forall a. (IsString a) => a -zshr = "zshr" - -complement :: forall a. (IsString a) => a -complement = "complement" - -identity :: forall a. (IsString a) => a -identity = "identity" - --- Prelude Values - -zero :: forall a. (IsString a) => a -zero = "zero" - -one :: forall a. (IsString a) => a -one = "one" - -bottom :: forall a. (IsString a) => a -bottom = "bottom" - -top :: forall a. (IsString a) => a -top = "top" - -pure' :: forall a. (IsString a) => a -pure' = "pure" - --- Core lib values - -runST :: forall a. (IsString a) => a -runST = "run" - -stRefValue :: forall a. (IsString a) => a -stRefValue = "value" - -newSTRef :: forall a. (IsString a) => a -newSTRef = "new" - -readSTRef :: forall a. (IsString a) => a -readSTRef = "read" - -writeSTRef :: forall a. (IsString a) => a -writeSTRef = "write" - -modifySTRef :: forall a. (IsString a) => a -modifySTRef = "modify" - -mkFn :: forall a. (IsString a) => a -mkFn = "mkFn" - -runFn :: forall a. (IsString a) => a -runFn = "runFn" - -mkEffFn :: forall a. (IsString a) => a -mkEffFn = "mkEffFn" - -runEffFn :: forall a. (IsString a) => a -runEffFn = "runEffFn" - -mkEffectFn :: forall a. (IsString a) => a -mkEffectFn = "mkEffectFn" - -runEffectFn :: forall a. (IsString a) => a -runEffectFn = "runEffectFn" - -mkSTFn :: forall a. (IsString a) => a -mkSTFn = "mkSTFn" - -runSTFn :: forall a. (IsString a) => a -runSTFn = "runSTFn" - --- Type Class Dictionary Names - -data EffectDictionaries = EffectDictionaries - { edApplicativeDict :: PSString - , edBindDict :: PSString - , edMonadDict :: PSString - , edWhile :: PSString - , edUntil :: PSString - } - -effDictionaries :: EffectDictionaries -effDictionaries = EffectDictionaries - { edApplicativeDict = "applicativeEff" - , edBindDict = "bindEff" - , edMonadDict = "monadEff" - , edWhile = "whileE" - , edUntil = "untilE" - } - -effectDictionaries :: EffectDictionaries -effectDictionaries = EffectDictionaries - { edApplicativeDict = "applicativeEffect" - , edBindDict = "bindEffect" - , edMonadDict = "monadEffect" - , edWhile = "whileE" - , edUntil = "untilE" - } - -stDictionaries :: EffectDictionaries -stDictionaries = EffectDictionaries - { edApplicativeDict = "applicativeST" - , edBindDict = "bindST" - , edMonadDict = "monadST" - , edWhile = "while" - , edUntil = "until" - } - -discardUnitDictionary :: forall a. (IsString a) => a -discardUnitDictionary = "discardUnit" - -semiringNumber :: forall a. (IsString a) => a -semiringNumber = "semiringNumber" - -semiringInt :: forall a. (IsString a) => a -semiringInt = "semiringInt" - -ringNumber :: forall a. (IsString a) => a -ringNumber = "ringNumber" - -ringInt :: forall a. (IsString a) => a -ringInt = "ringInt" - -euclideanRingNumber :: forall a. (IsString a) => a -euclideanRingNumber = "euclideanRingNumber" - -ordBoolean :: forall a. (IsString a) => a -ordBoolean = "ordBoolean" - -ordNumber :: forall a. (IsString a) => a -ordNumber = "ordNumber" - -ordInt :: forall a. (IsString a) => a -ordInt = "ordInt" - -ordString :: forall a. (IsString a) => a -ordString = "ordString" - -ordChar :: forall a. (IsString a) => a -ordChar = "ordChar" - -eqNumber :: forall a. (IsString a) => a -eqNumber = "eqNumber" - -eqInt :: forall a. (IsString a) => a -eqInt = "eqInt" - -eqString :: forall a. (IsString a) => a -eqString = "eqString" - -eqChar :: forall a. (IsString a) => a -eqChar = "eqChar" - -eqBoolean :: forall a. (IsString a) => a -eqBoolean = "eqBoolean" - -boundedBoolean :: forall a. (IsString a) => a -boundedBoolean = "boundedBoolean" - -heytingAlgebraBoolean :: forall a. (IsString a) => a -heytingAlgebraBoolean = "heytingAlgebraBoolean" - -semigroupString :: forall a. (IsString a) => a -semigroupString = "semigroupString" - -semigroupoidFn :: forall a. (IsString a) => a -semigroupoidFn = "semigroupoidFn" - -categoryFn :: forall a. (IsString a) => a -categoryFn = "categoryFn" - --- Data.Symbol - -pattern DataSymbol :: ModuleName -pattern DataSymbol = ModuleName "Data.Symbol" - -pattern IsSymbol :: Qualified (ProperName 'ClassName) -pattern IsSymbol = Qualified (ByModuleName DataSymbol) (ProperName "IsSymbol") - -pattern DataReflectable :: ModuleName -pattern DataReflectable = ModuleName "Data.Reflectable" - -pattern Reflectable :: Qualified (ProperName 'ClassName) -pattern Reflectable = Qualified (ByModuleName DataReflectable) (ProperName "Reflectable") - -pattern DataOrdering :: ModuleName -pattern DataOrdering = ModuleName "Data.Ordering" - -pattern DataFunctionUncurried :: ModuleName -pattern DataFunctionUncurried = ModuleName "Data.Function.Uncurried" - -pattern PartialUnsafe :: ModuleName -pattern PartialUnsafe = ModuleName "Partial.Unsafe" - -pattern Ordering :: Qualified (ProperName 'TypeName) -pattern Ordering = Qualified (ByModuleName DataOrdering) (ProperName "Ordering") - -pattern LT :: Qualified (ProperName 'ConstructorName) -pattern LT = Qualified (ByModuleName DataOrdering) (ProperName "LT") - -pattern EQ :: Qualified (ProperName 'ConstructorName) -pattern EQ = Qualified (ByModuleName DataOrdering) (ProperName "EQ") - -pattern GT :: Qualified (ProperName 'ConstructorName) -pattern GT = Qualified (ByModuleName DataOrdering) (ProperName "GT") - -pattern DataArray :: ModuleName -pattern DataArray = ModuleName "Data.Array" - -pattern Eff :: ModuleName -pattern Eff = ModuleName "Control.Monad.Eff" - -pattern Effect :: ModuleName -pattern Effect = ModuleName "Effect" - -pattern ST :: ModuleName -pattern ST = ModuleName "Control.Monad.ST.Internal" - -pattern ControlApply :: ModuleName -pattern ControlApply = ModuleName "Control.Apply" - -pattern Apply :: Qualified (ProperName 'ClassName) -pattern Apply = Qualified (ByModuleName ControlApply) (ProperName "Apply") - -identApply :: Qualified Ident -identApply = Qualified (ByModuleName ControlApply) (Ident apply) - -pattern ControlApplicative :: ModuleName -pattern ControlApplicative = ModuleName "Control.Applicative" - -pattern Applicative :: Qualified (ProperName 'ClassName) -pattern Applicative = Qualified (ByModuleName ControlApplicative) (ProperName "Applicative") - -identPure :: Qualified Ident -identPure = Qualified (ByModuleName ControlApplicative) (Ident pure') - -pattern ControlSemigroupoid :: ModuleName -pattern ControlSemigroupoid = ModuleName "Control.Semigroupoid" - -pattern ControlBind :: ModuleName -pattern ControlBind = ModuleName "Control.Bind" - -pattern ControlCategory :: ModuleName -pattern ControlCategory = ModuleName "Control.Category" - -pattern Category :: Qualified (ProperName 'ClassName) -pattern Category = Qualified (ByModuleName ControlCategory) (ProperName "Category") - -identIdentity :: Qualified Ident -identIdentity = Qualified (ByModuleName ControlCategory) (Ident identity) - -pattern ControlMonadEffUncurried :: ModuleName -pattern ControlMonadEffUncurried = ModuleName "Control.Monad.Eff.Uncurried" - -pattern EffectUncurried :: ModuleName -pattern EffectUncurried = ModuleName "Effect.Uncurried" - -pattern ControlMonadSTUncurried :: ModuleName -pattern ControlMonadSTUncurried = ModuleName "Control.Monad.ST.Uncurried" - -pattern DataBounded :: ModuleName -pattern DataBounded = ModuleName "Data.Bounded" - -pattern DataSemigroup :: ModuleName -pattern DataSemigroup = ModuleName "Data.Semigroup" - -identAppend :: Qualified Ident -identAppend = Qualified (ByModuleName DataSemigroup) (Ident append) - -pattern DataMonoid :: ModuleName -pattern DataMonoid = ModuleName "Data.Monoid" - -identMempty :: Qualified Ident -identMempty = Qualified (ByModuleName DataMonoid) (Ident mempty) - -pattern DataHeytingAlgebra :: ModuleName -pattern DataHeytingAlgebra = ModuleName "Data.HeytingAlgebra" - -pattern DataEq :: ModuleName -pattern DataEq = ModuleName "Data.Eq" - -pattern Eq :: Qualified (ProperName 'ClassName) -pattern Eq = Qualified (ByModuleName DataEq) (ProperName "Eq") - -pattern Eq1 :: Qualified (ProperName 'ClassName) -pattern Eq1 = Qualified (ByModuleName DataEq) (ProperName "Eq1") - -identEq :: Qualified Ident -identEq = Qualified (ByModuleName DataEq) (Ident eq) - -identEq1 :: Qualified Ident -identEq1 = Qualified (ByModuleName DataEq) (Ident eq1) - -pattern DataOrd :: ModuleName -pattern DataOrd = ModuleName "Data.Ord" - -pattern Ord :: Qualified (ProperName 'ClassName) -pattern Ord = Qualified (ByModuleName DataOrd) (ProperName "Ord") - -pattern Ord1 :: Qualified (ProperName 'ClassName) -pattern Ord1 = Qualified (ByModuleName DataOrd) (ProperName "Ord1") - -identCompare :: Qualified Ident -identCompare = Qualified (ByModuleName DataOrd) (Ident compare) - -identCompare1 :: Qualified Ident -identCompare1 = Qualified (ByModuleName DataOrd) (Ident compare1) - -pattern DataFunctor :: ModuleName -pattern DataFunctor = ModuleName "Data.Functor" - -pattern Functor :: Qualified (ProperName 'ClassName) -pattern Functor = Qualified (ByModuleName DataFunctor) (ProperName "Functor") - -identMap :: Qualified Ident -identMap = Qualified (ByModuleName DataFunctor) (Ident map) - -pattern DataSemiring :: ModuleName -pattern DataSemiring = ModuleName "Data.Semiring" - -pattern DataRing :: ModuleName -pattern DataRing = ModuleName "Data.Ring" - -pattern DataEuclideanRing :: ModuleName -pattern DataEuclideanRing = ModuleName "Data.EuclideanRing" - -pattern DataFunction :: ModuleName -pattern DataFunction = ModuleName "Data.Function" - -identFlip :: Qualified Ident -identFlip = Qualified (ByModuleName DataFunction) (Ident flip) - -flip :: forall a. (IsString a) => a -flip = "flip" - -pattern DataIntBits :: ModuleName -pattern DataIntBits = ModuleName "Data.Int.Bits" - -unsafePartial :: forall a. (IsString a) => a -unsafePartial = "unsafePartial" - -pattern UnsafeCoerce :: ModuleName -pattern UnsafeCoerce = ModuleName "Unsafe.Coerce" - -unsafeCoerceFn :: forall a. (IsString a) => a -unsafeCoerceFn = "unsafeCoerce" diff --git a/src/Language/PureScript/Constants/Prim.hs b/src/Language/PureScript/Constants/Prim.hs index aa2d468022..795dbffdd9 100644 --- a/src/Language/PureScript/Constants/Prim.hs +++ b/src/Language/PureScript/Constants/Prim.hs @@ -1,195 +1,57 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TemplateHaskell #-} -- | Various constants which refer to things in Prim module Language.PureScript.Constants.Prim where -import Data.String (IsString) import Language.PureScript.Names - --- Prim values - -undefined :: forall a. (IsString a) => a -undefined = "undefined" - --- Prim - -pattern Prim :: ModuleName -pattern Prim = ModuleName "Prim" - -pattern Partial :: Qualified (ProperName 'ClassName) -pattern Partial = Qualified (ByModuleName Prim) (ProperName "Partial") - -pattern Record :: Qualified (ProperName 'TypeName) -pattern Record = Qualified (ByModuleName Prim) (ProperName "Record") - -pattern Type :: Qualified (ProperName 'TypeName) -pattern Type = Qualified (ByModuleName Prim) (ProperName "Type") - -pattern Constraint :: Qualified (ProperName 'TypeName) -pattern Constraint = Qualified (ByModuleName Prim) (ProperName "Constraint") - -pattern Function :: Qualified (ProperName 'TypeName) -pattern Function = Qualified (ByModuleName Prim) (ProperName "Function") - -pattern Array :: Qualified (ProperName 'TypeName) -pattern Array = Qualified (ByModuleName Prim) (ProperName "Array") - -pattern Row :: Qualified (ProperName 'TypeName) -pattern Row = Qualified (ByModuleName Prim) (ProperName "Row") - --- Prim.Boolean - -pattern PrimBoolean :: ModuleName -pattern PrimBoolean = ModuleName "Prim.Boolean" - -booleanTrue :: Qualified (ProperName 'TypeName) -booleanTrue = Qualified (ByModuleName PrimBoolean) (ProperName "True") - -booleanFalse :: Qualified (ProperName 'TypeName) -booleanFalse = Qualified (ByModuleName PrimBoolean) (ProperName "False") - --- Prim.Coerce - -pattern PrimCoerce :: ModuleName -pattern PrimCoerce = ModuleName "Prim.Coerce" - -pattern Coercible :: Qualified (ProperName 'ClassName) -pattern Coercible = Qualified (ByModuleName PrimCoerce) (ProperName "Coercible") - --- Prim.Ordering - -pattern PrimOrdering :: ModuleName -pattern PrimOrdering = ModuleName "Prim.Ordering" - -orderingLT :: Qualified (ProperName 'TypeName) -orderingLT = Qualified (ByModuleName PrimOrdering) (ProperName "LT") - -orderingEQ :: Qualified (ProperName 'TypeName) -orderingEQ = Qualified (ByModuleName PrimOrdering) (ProperName "EQ") - -orderingGT :: Qualified (ProperName 'TypeName) -orderingGT = Qualified (ByModuleName PrimOrdering) (ProperName "GT") - --- Prim.Row - -pattern PrimRow :: ModuleName -pattern PrimRow = ModuleName "Prim.Row" - -pattern RowUnion :: Qualified (ProperName 'ClassName) -pattern RowUnion = Qualified (ByModuleName PrimRow) (ProperName "Union") - -pattern RowNub :: Qualified (ProperName 'ClassName) -pattern RowNub = Qualified (ByModuleName PrimRow) (ProperName "Nub") - -pattern RowCons :: Qualified (ProperName 'ClassName) -pattern RowCons = Qualified (ByModuleName PrimRow) (ProperName "Cons") - -pattern RowLacks :: Qualified (ProperName 'ClassName) -pattern RowLacks = Qualified (ByModuleName PrimRow) (ProperName "Lacks") - --- Prim.RowList - -pattern PrimRowList :: ModuleName -pattern PrimRowList = ModuleName "Prim.RowList" - -pattern RowToList :: Qualified (ProperName 'ClassName) -pattern RowToList = Qualified (ByModuleName PrimRowList) (ProperName "RowToList") - -pattern RowListNil :: Qualified (ProperName 'TypeName) -pattern RowListNil = Qualified (ByModuleName PrimRowList) (ProperName "Nil") - -pattern RowListCons :: Qualified (ProperName 'TypeName) -pattern RowListCons = Qualified (ByModuleName PrimRowList) (ProperName "Cons") - --- Prim.Int - -pattern PrimInt :: ModuleName -pattern PrimInt = ModuleName "Prim.Int" - -pattern IntAdd :: Qualified (ProperName 'ClassName) -pattern IntAdd = Qualified (ByModuleName PrimInt) (ProperName "Add") - -pattern IntCompare :: Qualified (ProperName 'ClassName) -pattern IntCompare = Qualified (ByModuleName PrimInt) (ProperName "Compare") - -pattern IntMul :: Qualified (ProperName 'ClassName) -pattern IntMul = Qualified (ByModuleName PrimInt) (ProperName "Mul") - -pattern IntToString :: Qualified (ProperName 'ClassName) -pattern IntToString = Qualified (ByModuleName PrimInt) (ProperName "ToString") - --- Prim.Symbol - -pattern PrimSymbol :: ModuleName -pattern PrimSymbol = ModuleName "Prim.Symbol" - -pattern SymbolCompare :: Qualified (ProperName 'ClassName) -pattern SymbolCompare = Qualified (ByModuleName PrimSymbol) (ProperName "Compare") - -pattern SymbolAppend :: Qualified (ProperName 'ClassName) -pattern SymbolAppend = Qualified (ByModuleName PrimSymbol) (ProperName "Append") - -pattern SymbolCons :: Qualified (ProperName 'ClassName) -pattern SymbolCons = Qualified (ByModuleName PrimSymbol) (ProperName "Cons") - --- Prim.TypeError - -pattern PrimTypeError :: ModuleName -pattern PrimTypeError = ModuleName "Prim.TypeError" - -pattern Fail :: Qualified (ProperName 'ClassName) -pattern Fail = Qualified (ByModuleName PrimTypeError) (ProperName "Fail") - -pattern Warn :: Qualified (ProperName 'ClassName) -pattern Warn = Qualified (ByModuleName PrimTypeError) (ProperName "Warn") +import qualified Language.PureScript.Constants.TH as TH + +$(TH.declare do + TH.mod "Prim" do + TH.cls "Partial" + TH.ty "Array" + TH.ty "Boolean" + TH.ty "Char" + TH.ty "Constraint" + TH.ty "Function" + TH.ty "Int" + TH.ty "Number" + TH.ty "Record" + TH.ty "Row" + TH.ty "String" + TH.ty "Symbol" + TH.ty "Type" + TH.asIdent do TH.asString do TH.var "undefined" + + TH.mod "Prim.Boolean" do + TH.tys ["False", "True"] + + TH.mod "Prim.Coerce" do + TH.cls "Coercible" + + TH.mod "Prim.Int" do + TH.prefixWith "Int" do TH.clss ["Add", "Compare", "Mul", "ToString"] + + TH.mod "Prim.Ordering" do + TH.prefixWith "Type" do TH.ty "Ordering" + TH.tys ["EQ", "GT", "LT"] + + TH.mod "Prim.Row" do + TH.prefixWith "Row" do TH.clss ["Cons", "Lacks", "Nub", "Union"] + + TH.mod "Prim.RowList" do + TH.ty "RowList" + TH.cls "RowToList" + TH.prefixWith "RowList" do TH.tys ["Cons", "Nil"] + + TH.mod "Prim.Symbol" do + TH.prefixWith "Symbol" do TH.clss ["Append", "Compare", "Cons"] + + TH.mod "Prim.TypeError" do + TH.clss ["Fail", "Warn"] + TH.tys ["Above", "Beside", "Doc", "Quote", "QuoteLabel", "Text"] + + ) primModules :: [ModuleName] -primModules = [Prim, PrimBoolean, PrimCoerce, PrimOrdering, PrimRow, PrimRowList, PrimSymbol, PrimInt, PrimTypeError] - -typ :: forall a. (IsString a) => a -typ = "Type" - -kindOrdering :: forall a. (IsString a) => a -kindOrdering = "Ordering" - -kindRowList :: forall a. (IsString a) => a -kindRowList = "RowList" - -symbol :: forall a. (IsString a) => a -symbol = "Symbol" - -doc :: forall a. (IsString a) => a -doc = "Doc" - -row :: forall a. (IsString a) => a -row = "Row" - -constraint :: forall a. (IsString a) => a -constraint = "Constraint" - --- Modules - -prim :: forall a. (IsString a) => a -prim = "Prim" - -moduleBoolean :: forall a. (IsString a) => a -moduleBoolean = "Boolean" - -moduleCoerce :: forall a. (IsString a) => a -moduleCoerce = "Coerce" - -moduleOrdering :: forall a. (IsString a) => a -moduleOrdering = "Ordering" - -moduleRow :: forall a. (IsString a) => a -moduleRow = "Row" - -moduleRowList :: forall a. (IsString a) => a -moduleRowList = "RowList" - -moduleSymbol :: forall a. (IsString a) => a -moduleSymbol = "Symbol" - -moduleInt :: forall a. (IsString a) => a -moduleInt = "Int" - -typeError :: forall a. (IsString a) => a -typeError = "TypeError" +primModules = [M_Prim, M_Prim_Boolean, M_Prim_Coerce, M_Prim_Ordering, M_Prim_Row, M_Prim_RowList, M_Prim_Symbol, M_Prim_Int, M_Prim_TypeError] diff --git a/src/Language/PureScript/Constants/TH.hs b/src/Language/PureScript/Constants/TH.hs new file mode 100644 index 0000000000..10ded13093 --- /dev/null +++ b/src/Language/PureScript/Constants/TH.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | This module implements an eDSL for compactly declaring pattern synonyms +-- representing known PureScript modules and their members. +-- +-- The following example assumes this module is imported qualified as TH and +-- the BlockArguments extension is used, both of which I recommend. +-- +-- > $(TH.declare do +-- > TH.mod "Data.Foo" do +-- > TH.ty "SomeType" +-- > TH.asIdent do +-- > TH.var "someVariable" +-- > ) +-- +-- will become: +-- +-- > pattern M_Data_Foo :: ModuleName +-- > pattern M_Data_Foo = ModuleName "Data.Foo" +-- > +-- > pattern SomeType :: Qualified (ProperName 'TypeName) +-- > pattern SomeType = Qualified (ByModuleName M_Data_Foo) (ProperName "SomeType") +-- > +-- > pattern I_someVariable :: Qualified Ident +-- > pattern I_someVariable = Qualified (ByModuleName M_Data_Foo) (Ident "someVariable") +-- +-- All pattern synonyms must start with an uppercase letter. To prevent +-- namespace collisions, different types of pattern are distinguished by a sort +-- of Hungarian notation convention: +-- +-- @ +-- SomeType -- a type or class name +-- C_Ctor -- a constructor name +-- I_name -- a Qualified Ident +-- M_Data_Foo -- a module name +-- P_name -- a (module name, polymorphic string) pair +-- S_name -- a lone polymorphic string (this doesn't contain any module information) +-- @ +-- +-- I_, P_, and S_ patterns are all optional and have to be enabled with +-- `asIdent`, `asPair`, and `asString` modifiers respectively. +-- +-- Finally, to disambiguate between identifiers with the same name (such as +-- Data.Function.apply and Data.Apply.apply), the `prefixWith` modifier will +-- modify the names of the patterns created within it. +-- +-- > TH.mod "Data.Function" do +-- > TH.prefixWith "function" do +-- > TH.asIdent do +-- > TH.var "apply" +-- +-- results in: +-- +-- > pattern I_functionApply :: Qualified Ident +-- > pattern I_functionApply = Qualified (ByModuleName (M_Data_Function) (Ident "apply") +-- +module Language.PureScript.Constants.TH + ( declare + , mod + , cls, clss + , dty + , nty, ntys + , ty, tys + , var, vars + , prefixWith + , asIdent + , asPair + , asString + ) where + +import Protolude hiding (Type, mod) + +import Control.Lens (over, _head) +import Control.Monad.Trans.RWS (RWS, execRWS) +import Control.Monad.Trans.Writer (Writer, execWriter) +import Control.Monad.Writer.Class (tell) +import Data.String (String) +import Language.Haskell.TH +import Language.PureScript.Names hiding (Name) + +-- | Generate pattern synonyms corresponding to the provided PureScript +-- declarations. +declare :: Writer (Q [Dec]) () -> Q [Dec] +declare = execWriter + +-- | Declare a module. +mod :: String -> ModDecs -> Writer (Q [Dec]) () +mod mnStr inner = do + -- pattern M_Data_Foo :: ModuleName + -- pattern M_Data_Foo = ModuleName "Data.Foo" + let mn = mkModuleName mnStr + tell $ typedPatSyn mn [t| ModuleName |] [p| ModuleName $(litP $ stringL mnStr) |] + tell $ snd $ execRWS inner (mn, "", []) () + +-- | Declare a type class. The resulting pattern will use the name of the class +-- and have type `Qualified (ProperName 'ClassName)`. +cls :: String -> ModDecs +cls cn = ask >>= \(mn, prefix, _) -> tell $ mkPnPat [t| 'ClassName |] mn prefix cn + +-- | Declare a list of type classes; shorthand for repeatedly calling `cls`. +clss :: [String] -> ModDecs +clss = traverse_ cls + +-- | Declare a data type, given the name of the type and a list of constructor +-- names. A pattern will be created using the name of the type and have type +-- `Qualified (ProperName 'TypeName)`. A pattern will also be created for each +-- constructor prefixed with "C_", having type `Qualified (ProperName +-- 'ConstructorName)`. +dty :: String -> [String] -> ModDecs +dty dn ctors = ask >>= \(mn, prefix, _) -> do + tell $ mkPnPat [t| 'TypeName |] mn prefix dn + tell $ map fold $ traverse (mkPnPat [t| 'ConstructorName |] mn $ "C_" <> prefix) ctors + +-- | Declare a data type with a singular constructor named the same as the +-- type, as is commonly the case with newtypes (but this does not require the +-- type to be a newtype in reality). Shorthand for calling `dty`. +nty :: String -> ModDecs +nty tn = dty tn [tn] + +-- | Declare a list of data types with singular constructors; shorthand for +-- repeatedly calling `nty`, which itself is shorthand for `dty`. +ntys :: [String] -> ModDecs +ntys = traverse_ nty + +-- | Declare a type. The resulting pattern will use the name of the type and have +-- type `Qualified (ProperName 'TypeName)`. +ty :: String -> ModDecs +ty tn = ask >>= \(mn, prefix, _) -> tell $ mkPnPat [t| 'TypeName |] mn prefix tn + +-- | Declare a list of types; shorthand for repeatedly calling `ty`. +tys :: [String] -> ModDecs +tys = traverse_ ty + +-- | Declare a variable, function, named instance, or generally a lower-case +-- value member of a module. The patterns created depend on which of `asPair`, +-- `asIdent`, or `asString` are used in the enclosing context. +var :: String -> ModDecs +var nm = ask >>= \(mn, prefix, vtds) -> tell $ foldMap (\f -> f mn prefix nm) vtds + +-- | Declare a list of variables; shorthand for repeatedly calling `var`. +vars :: [String] -> ModDecs +vars = traverse_ var + +-- | For every variable declared within, create a pattern synonym prefixed +-- with "P_" having type `forall a. (Eq a, IsString a) => (ModuleName, a)`. +asPair :: ModDecs -> ModDecs +asPair = local $ addToVars mkPairDec + +-- | For every variable declared within, cerate a pattern synonym prefixed +-- with "I_" having type `Qualified Ident`. +asIdent :: ModDecs -> ModDecs +asIdent = local $ addToVars mkIdentDec + +-- | For every variable declared within, cerate a pattern synonym prefixed +-- with "S_" having type `forall a. (Eq a, IsString a) => a`. +asString :: ModDecs -> ModDecs +asString = local $ addToVars mkStringDec + +-- | Prefix the names of all enclosed declarations with the provided string, to +-- prevent collisions with other identifiers. For example, +-- `prefixWith "function"` would turn `I_apply` into `I_functionApply`, and +-- `C_Example` into `C_FunctionExample`. +prefixWith :: String -> ModDecs -> ModDecs +prefixWith = local . applyPrefix + +-- Internals start here + +type ModDecs = RWS (Name, String, [VarToDec]) (Q [Dec]) () () +type VarToDec = Name -> String -> String -> Q [Dec] + +addToVars :: VarToDec -> (a, b, [VarToDec]) -> (a, b, [VarToDec]) +addToVars f (a, b, fs) = (a, b, f : fs) + +applyPrefix :: String -> (a, String, c) -> (a, String, c) +applyPrefix prefix (a, prefix', c) = (a, camelAppend prefix' prefix, c) + +cap :: String -> String +cap = over _head toUpper + +camelAppend :: String -> String -> String +camelAppend l r = if null l then r else l <> cap r + +-- "Data.Foo" -> M_Data_Foo +mkModuleName :: String -> Name +mkModuleName = mkName . ("M_" <>) . map (\case '.' -> '_'; other -> other) + +-- "I_" -> "fn" -> "foo" -> I_fnFoo +-- "I_" -> "" -> "foo" -> I_foo +mkPrefixedName :: String -> String -> String -> Name +mkPrefixedName tag prefix = mkName . (tag <>) . camelAppend prefix + +-- 'TypeName -> M_Data_Foo -> "Function" -> "Foo" -> +-- pattern FunctionFoo :: Qualified (ProperName 'TypeName) +-- pattern FunctionFoo = Qualified (ByModuleName M_Data_Foo) (ProperName "Foo") +mkPnPat :: Q Type -> VarToDec +mkPnPat pnType mn prefix str = typedPatSyn (mkName $ cap prefix <> str) + [t| Qualified (ProperName $pnType) |] + [p| Qualified (ByModuleName $(conP mn [])) (ProperName $(litP $ stringL str)) |] + +-- M_Data_Foo -> "function" -> "foo" -> +-- pattern I_functionFoo :: Qualified Ident +-- pattern I_functionFoo = Qualified (ByModuleName M_Data_Foo) (Ident "foo") +mkIdentDec :: VarToDec +mkIdentDec mn prefix str = typedPatSyn (mkPrefixedName "I_" prefix str) + [t| Qualified Ident |] + [p| Qualified (ByModuleName $(conP mn [])) (Ident $(litP $ stringL str)) |] + +-- M_Data_Foo -> "function" -> "foo" -> +-- pattern P_functionFoo :: forall a. (Eq a, IsString a) => (ModuleName, a) +-- pattern P_functionFoo = (M_Data_Foo, "foo") +mkPairDec :: VarToDec +mkPairDec mn prefix str = typedPatSyn (mkPrefixedName "P_" prefix str) + [t| forall a. (Eq a, IsString a) => (ModuleName, a) |] + [p| ($(conP mn []), $(litP $ stringL str)) |] + +-- _ -> "function" -> "foo" -> +-- pattern S_functionFoo :: forall a. (Eq a, IsString a) => a +-- pattern S_functionFoo = "foo" +mkStringDec :: VarToDec +mkStringDec _ prefix str = typedPatSyn (mkPrefixedName "S_" prefix str) + [t| forall a. (Eq a, IsString a) => a |] + (litP $ stringL str) + +typedPatSyn :: Name -> Q Type -> Q Pat -> Q [Dec] +typedPatSyn nm t p = sequence [patSynSigD nm t, patSynD nm (prefixPatSyn []) implBidir p] diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index 9109a4f233..0ea811a980 100644 --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -19,7 +19,7 @@ import Data.Semigroup.Generic (GenericSemigroupMonoid(..)) import Language.PureScript.AST.Literals import Language.PureScript.AST.SourcePos (nullSourceSpan) -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C import Language.PureScript.CoreFn.Ann (Ann) import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Expr diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 1326504e72..1cf6d5efe0 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -109,7 +109,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = A.Unused{} -> True _ -> False exprToCoreFn ss com ty (A.Unused _) = - Var (ss, com, ty, Nothing) (Qualified (ByModuleName C.Prim) (Ident C.undefined)) + Var (ss, com, ty, Nothing) C.I_undefined exprToCoreFn _ com ty (A.Var ss ident) = Var (ss, com, ty, getValueMeta ident) ident exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) = diff --git a/src/Language/PureScript/CoreFn/Laziness.hs b/src/Language/PureScript/CoreFn/Laziness.hs index 600fce7316..5055151596 100644 --- a/src/Language/PureScript/CoreFn/Laziness.hs +++ b/src/Language/PureScript/CoreFn/Laziness.hs @@ -17,7 +17,7 @@ import Data.Semigroup (Max(..)) import qualified Data.Set as S import Language.PureScript.AST.SourcePos -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C import Language.PureScript.CoreFn import Language.PureScript.Crash import Language.PureScript.Names @@ -128,8 +128,7 @@ onVarsWithDelayAndForce f = snd . go 0 $ Just 0 Var a i -> f delay force a i Abs a i e -> Abs a i <$> snd (if force == Just 0 then go (succ delay) force else go delay $ fmap pred force) e -- A clumsy hack to preserve TCO in a particular idiom of unsafePartial once seen in Data.Map.Internal, possibly still used elsewhere. - App a1 e1@(Var _ (Qualified (ByModuleName C.PartialUnsafe) (Ident up))) (Abs a2 i e2) | up == C.unsafePartial - -> App a1 e1 . Abs a2 i <$> handleExpr' e2 + App a1 e1@(Var _ C.I_unsafePartial) (Abs a2 i e2) -> App a1 e1 . Abs a2 i <$> handleExpr' e2 App a e1 e2 -> -- `handleApp` is just to handle the constructor application exception -- somewhat gracefully (i.e., without requiring a deep inspection of @@ -533,7 +532,7 @@ applyLazinessTransform mn rawItems = let nullAnn = ssAnn nullSourceSpan runtimeLazy = Var nullAnn . Qualified ByNullSourcePos $ InternalIdent RuntimeLazyFactory - runFn3 = Var nullAnn . Qualified (ByModuleName C.DataFunctionUncurried) . Ident $ C.runFn <> "3" + runFn3 = Var nullAnn . Qualified (ByModuleName C.M_Data_Function_Uncurried) . Ident $ C.S_runFn <> "3" strLit = Literal nullAnn . StringLiteral . mkString lazifyIdent = \case diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index e74feb2eaa..94d7b77a5a 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -11,10 +11,9 @@ import Language.PureScript.CoreFn.CSE import Language.PureScript.CoreFn.Expr import Language.PureScript.CoreFn.Module import Language.PureScript.CoreFn.Traversals -import Language.PureScript.Names (Ident(..), QualifiedBy(..), Qualified(..)) import Language.PureScript.Label import Language.PureScript.Types -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C import qualified Language.PureScript.Constants.Prim as C -- | @@ -54,7 +53,7 @@ closedRecordFields _ = Nothing optimizeDataFunctionApply :: Expr a -> Expr a optimizeDataFunctionApply e = case e of - (App a (App _ (Var _ (Qualified (ByModuleName C.DataFunction) (Ident fn))) x) y) - | fn == C.apply -> App a x y - | fn == C.applyFlipped -> App a y x + (App a (App _ (Var _ fn) x) y) + | C.I_functionApply <- fn -> App a x y + | C.I_functionApplyFlipped <- fn -> App a y x _ -> e diff --git a/src/Language/PureScript/CoreImp/Optimizer/Common.hs b/src/Language/PureScript/CoreImp/Optimizer/Common.hs index 6c4834c36b..b984fcf0a5 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Common.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Common.hs @@ -60,10 +60,13 @@ removeFromBlock :: ([AST] -> [AST]) -> AST -> AST removeFromBlock go (Block ss sts) = Block ss (go sts) removeFromBlock _ js = js -isDict :: (ModuleName, PSString) -> AST -> Bool -isDict (moduleName, dictName) (ModuleAccessor _ x y) = - x == moduleName && y == dictName -isDict _ _ = False +pattern Ref :: (ModuleName, PSString) -> AST +pattern Ref pair <- (refPatternHelper -> Just pair) +-- ideally: pattern Ref (moduleName, refName) <- ModuleAccessor _ moduleName refName +-- but: https://gitlab.haskell.org/ghc/ghc/-/issues/12203 +-- https://github.com/ghc-proposals/ghc-proposals/pull/138 -isDict' :: [(ModuleName, PSString)] -> AST -> Bool -isDict' xs js = any (`isDict` js) xs +refPatternHelper :: AST -> Maybe (ModuleName, PSString) +refPatternHelper = \case + ModuleAccessor _ moduleName refName -> Just (moduleName, refName) + _ -> Nothing diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index da9f29383a..77e5ea4c77 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -18,16 +18,15 @@ import Control.Monad.Supply.Class (MonadSupply, freshName) import Data.Either (rights) import Data.Maybe (fromMaybe) -import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Names (ModuleName) -import Language.PureScript.PSString (PSString) +import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Common import Language.PureScript.AST (SourceSpan(..)) -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C import qualified Language.PureScript.Constants.Prim as C -- TODO: Potential bug: @@ -72,7 +71,7 @@ evaluateIifes = everywhere convert convert :: AST -> AST convert (App _ (Function _ Nothing [] (Block _ [Return _ ret])) []) = ret convert (App _ (Function _ Nothing idents (Block _ [Return ss ret])) []) - | not (any (`isReassigned` ret) idents) = replaceIdents (map (, Var ss C.undefined) idents) ret + | not (any (`isReassigned` ret) idents) = replaceIdents (map (, Var ss C.S_undefined) idents) ret convert js = js inlineVariables :: AST -> AST @@ -89,129 +88,121 @@ inlineCommonValues :: (AST -> AST) -> AST -> AST inlineCommonValues expander = everywhere convert where convert :: AST -> AST - convert (expander -> App ss fn [dict]) - | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0) - | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1) - | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False - | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True - convert (App ss (expander -> App _ fn [dict]) [x]) - | isDict ringInt dict && isDict fnNegate fn = Binary ss BitwiseOr (Unary ss Negate x) (NumericLiteral ss (Left 0)) - convert (App ss (App _ (expander -> App _ fn [dict]) [x]) [y]) - | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add x y - | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply x y - | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract x y + convert (expander -> App ss (Ref fn) [Ref dict]) + | dict `elem` [C.P_semiringNumber, C.P_semiringInt], C.P_zero <- fn = NumericLiteral ss (Left 0) + | dict `elem` [C.P_semiringNumber, C.P_semiringInt], C.P_one <- fn = NumericLiteral ss (Left 1) + | C.P_boundedBoolean <- dict, C.P_bottom <- fn = BooleanLiteral ss False + | C.P_boundedBoolean <- dict, C.P_top <- fn = BooleanLiteral ss True + convert (App ss (expander -> App _ (Ref C.P_negate) [Ref C.P_ringInt]) [x]) + = Binary ss BitwiseOr (Unary ss Negate x) (NumericLiteral ss (Left 0)) + convert (App ss (App _ (expander -> App _ (Ref fn) [Ref dict]) [x]) [y]) + | C.P_semiringInt <- dict, C.P_add <- fn = intOp ss Add x y + | C.P_semiringInt <- dict, C.P_mul <- fn = intOp ss Multiply x y + | C.P_ringInt <- dict, C.P_sub <- fn = intOp ss Subtract x y convert other = other - fnZero = (C.DataSemiring, C.zero) - fnOne = (C.DataSemiring, C.one) - fnBottom = (C.DataBounded, C.bottom) - fnTop = (C.DataBounded, C.top) - fnAdd = (C.DataSemiring, C.add) - fnMultiply = (C.DataSemiring, C.mul) - fnSubtract = (C.DataRing, C.sub) - fnNegate = (C.DataRing, C.negate) intOp ss op x y = Binary ss BitwiseOr (Binary ss op x y) (NumericLiteral ss (Left 0)) inlineCommonOperators :: (AST -> AST) -> AST -> AST inlineCommonOperators expander = everywhereTopDown $ applyAll $ - [ binary semiringNumber opAdd Add - , binary semiringNumber opMul Multiply - - , binary ringNumber opSub Subtract - , unary ringNumber opNegate Negate - - , binary euclideanRingNumber opDiv Divide - - , binary eqNumber opEq EqualTo - , binary eqNumber opNotEq NotEqualTo - , binary eqInt opEq EqualTo - , binary eqInt opNotEq NotEqualTo - , binary eqString opEq EqualTo - , binary eqString opNotEq NotEqualTo - , binary eqChar opEq EqualTo - , binary eqChar opNotEq NotEqualTo - , binary eqBoolean opEq EqualTo - , binary eqBoolean opNotEq NotEqualTo - - , binary ordBoolean opLessThan LessThan - , binary ordBoolean opLessThanOrEq LessThanOrEqualTo - , binary ordBoolean opGreaterThan GreaterThan - , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo - , binary ordChar opLessThan LessThan - , binary ordChar opLessThanOrEq LessThanOrEqualTo - , binary ordChar opGreaterThan GreaterThan - , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo - , binary ordInt opLessThan LessThan - , binary ordInt opLessThanOrEq LessThanOrEqualTo - , binary ordInt opGreaterThan GreaterThan - , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo - , binary ordNumber opLessThan LessThan - , binary ordNumber opLessThanOrEq LessThanOrEqualTo - , binary ordNumber opGreaterThan GreaterThan - , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo - , binary ordString opLessThan LessThan - , binary ordString opLessThanOrEq LessThanOrEqualTo - , binary ordString opGreaterThan GreaterThan - , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo - - , binary semigroupString opAppend Add - - , binary heytingAlgebraBoolean opConj And - , binary heytingAlgebraBoolean opDisj Or - , unary heytingAlgebraBoolean opNot Not - - , binary' C.DataIntBits C.or BitwiseOr - , binary' C.DataIntBits C.and BitwiseAnd - , binary' C.DataIntBits C.xor BitwiseXor - , binary' C.DataIntBits C.shl ShiftLeft - , binary' C.DataIntBits C.shr ShiftRight - , binary' C.DataIntBits C.zshr ZeroFillShiftRight - , unary' C.DataIntBits C.complement BitwiseNot - - , inlineNonClassFunction (isModFnWithDict (C.DataArray, C.unsafeIndex)) $ flip (Indexer Nothing) + [ binary C.P_semiringNumber C.P_add Add + , binary C.P_semiringNumber C.P_mul Multiply + + , binary C.P_ringNumber C.P_sub Subtract + , unary C.P_ringNumber C.P_negate Negate + + , binary C.P_euclideanRingNumber C.P_div Divide + + , binary C.P_eqNumber C.P_eq EqualTo + , binary C.P_eqNumber C.P_notEq NotEqualTo + , binary C.P_eqInt C.P_eq EqualTo + , binary C.P_eqInt C.P_notEq NotEqualTo + , binary C.P_eqString C.P_eq EqualTo + , binary C.P_eqString C.P_notEq NotEqualTo + , binary C.P_eqChar C.P_eq EqualTo + , binary C.P_eqChar C.P_notEq NotEqualTo + , binary C.P_eqBoolean C.P_eq EqualTo + , binary C.P_eqBoolean C.P_notEq NotEqualTo + + , binary C.P_ordBoolean C.P_lessThan LessThan + , binary C.P_ordBoolean C.P_lessThanOrEq LessThanOrEqualTo + , binary C.P_ordBoolean C.P_greaterThan GreaterThan + , binary C.P_ordBoolean C.P_greaterThanOrEq GreaterThanOrEqualTo + , binary C.P_ordChar C.P_lessThan LessThan + , binary C.P_ordChar C.P_lessThanOrEq LessThanOrEqualTo + , binary C.P_ordChar C.P_greaterThan GreaterThan + , binary C.P_ordChar C.P_greaterThanOrEq GreaterThanOrEqualTo + , binary C.P_ordInt C.P_lessThan LessThan + , binary C.P_ordInt C.P_lessThanOrEq LessThanOrEqualTo + , binary C.P_ordInt C.P_greaterThan GreaterThan + , binary C.P_ordInt C.P_greaterThanOrEq GreaterThanOrEqualTo + , binary C.P_ordNumber C.P_lessThan LessThan + , binary C.P_ordNumber C.P_lessThanOrEq LessThanOrEqualTo + , binary C.P_ordNumber C.P_greaterThan GreaterThan + , binary C.P_ordNumber C.P_greaterThanOrEq GreaterThanOrEqualTo + , binary C.P_ordString C.P_lessThan LessThan + , binary C.P_ordString C.P_lessThanOrEq LessThanOrEqualTo + , binary C.P_ordString C.P_greaterThan GreaterThan + , binary C.P_ordString C.P_greaterThanOrEq GreaterThanOrEqualTo + + , binary C.P_semigroupString C.P_append Add + + , binary C.P_heytingAlgebraBoolean C.P_conj And + , binary C.P_heytingAlgebraBoolean C.P_disj Or + , unary C.P_heytingAlgebraBoolean C.P_not Not + + , binary' C.P_or BitwiseOr + , binary' C.P_and BitwiseAnd + , binary' C.P_xor BitwiseXor + , binary' C.P_shl ShiftLeft + , binary' C.P_shr ShiftRight + , binary' C.P_zshr ZeroFillShiftRight + , unary' C.P_complement BitwiseNot + + , inlineNonClassFunction (isModFnWithDict C.P_unsafeIndex) $ flip (Indexer Nothing) ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++ - [ fn | i <- [0..10], fn <- [ mkEffFn C.ControlMonadEffUncurried C.mkEffFn i, runEffFn C.ControlMonadEffUncurried C.runEffFn i ] ] ++ - [ fn | i <- [0..10], fn <- [ mkEffFn C.EffectUncurried C.mkEffectFn i, runEffFn C.EffectUncurried C.runEffectFn i ] ] ++ - [ fn | i <- [0..10], fn <- [ mkEffFn C.ControlMonadSTUncurried C.mkSTFn i, runEffFn C.ControlMonadSTUncurried C.runSTFn i ] ] + [ fn | i <- [0..10], fn <- [ mkEffFn C.P_mkEffFn i, runEffFn C.P_runEffFn i ] ] ++ + [ fn | i <- [0..10], fn <- [ mkEffFn C.P_mkEffectFn i, runEffFn C.P_runEffectFn i ] ] ++ + [ fn | i <- [0..10], fn <- [ mkEffFn C.P_mkSTFn i, runEffFn C.P_runSTFn i ] ] where binary :: (ModuleName, PSString) -> (ModuleName, PSString) -> BinaryOperator -> AST -> AST - binary dict fns op = convert where + binary dict fn op = convert where convert :: AST -> AST - convert (App ss (App _ (expander -> App _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = Binary ss op x y + convert (App ss (App _ (expander -> App _ (Ref fn') [Ref dict']) [x]) [y]) | dict == dict', fn == fn' = Binary ss op x y convert other = other - binary' :: ModuleName -> PSString -> BinaryOperator -> AST -> AST - binary' moduleName opString op = convert where + binary' :: (ModuleName, PSString) -> BinaryOperator -> AST -> AST + binary' fn op = convert where convert :: AST -> AST - convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op x y + convert (App ss (App _ (Ref fn') [x]) [y]) | fn == fn' = Binary ss op x y convert other = other unary :: (ModuleName, PSString) -> (ModuleName, PSString) -> UnaryOperator -> AST -> AST - unary dicts fns op = convert where + unary dict fn op = convert where convert :: AST -> AST - convert (App ss (expander -> App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op x + convert (App ss (expander -> App _ (Ref fn') [Ref dict']) [x]) | dict == dict', fn == fn' = Unary ss op x convert other = other - unary' :: ModuleName -> PSString -> UnaryOperator -> AST -> AST - unary' moduleName fnName op = convert where + unary' :: (ModuleName, PSString) -> UnaryOperator -> AST -> AST + unary' fn op = convert where convert :: AST -> AST - convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op x + convert (App ss (Ref fn') [x]) | fn == fn' = Unary ss op x convert other = other mkFn :: Int -> AST -> AST - mkFn = mkFn' C.DataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args js -> + mkFn = mkFn' C.P_mkFn $ \ss1 ss2 ss3 args js -> Function ss1 Nothing args (Block ss2 [Return ss3 js]) - mkEffFn :: ModuleName -> Text -> Int -> AST -> AST - mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args js -> + mkEffFn :: (ModuleName, PSString) -> Int -> AST -> AST + mkEffFn mkFn_ = mkFn' mkFn_ $ \ss1 ss2 ss3 args js -> Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 js [])]) - mkFn' :: ModuleName -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST - mkFn' modName fnName res 0 = convert where + mkFn' :: (ModuleName, PSString) -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST + mkFn' mkFn_ res 0 = convert where convert :: AST -> AST - convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 js])]) | isNFn modName fnName 0 mkFnN = + convert (App _ (Ref mkFnN) [Function s1 Nothing [_] (Block s2 [Return s3 js])]) | isNFn mkFn_ 0 mkFnN = res s1 s2 s3 [] js convert other = other - mkFn' modName fnName res n = convert where + mkFn' mkFn_ res n = convert where convert :: AST -> AST - convert orig@(App ss mkFnN [fn]) | isNFn modName fnName n mkFnN = + convert orig@(App ss (Ref mkFnN) [fn]) | isNFn mkFn_ n mkFnN = case collectArgs n [] fn of Just (args, [Return ss' ret]) -> res ss ss ss' args ret _ -> orig @@ -221,25 +212,23 @@ inlineCommonOperators expander = everywhereTopDown $ applyAll $ collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret collectArgs _ _ _ = Nothing - isNFn :: ModuleName -> Text -> Int -> AST -> Bool - isNFn expectMod prefix n (ModuleAccessor _ modName name) | modName == expectMod = - name == fromString (T.unpack prefix <> show n) - isNFn _ _ _ _ = False + isNFn :: (ModuleName, PSString) -> Int -> (ModuleName, PSString) -> Bool + isNFn prefix n fn = fmap (<> mkString (T.pack $ show n)) prefix == fn runFn :: Int -> AST -> AST - runFn = runFn' C.DataFunctionUncurried C.runFn App + runFn = runFn' C.P_runFn App - runEffFn :: ModuleName -> Text -> Int -> AST -> AST - runEffFn modName fnName = runFn' modName fnName $ \ss fn acc -> + runEffFn :: (ModuleName, PSString) -> Int -> AST -> AST + runEffFn runFn_ = runFn' runFn_ $ \ss fn acc -> Function ss Nothing [] (Block ss [Return ss (App ss fn acc)]) - runFn' :: ModuleName -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST - runFn' modName runFnName res n = convert where + runFn' :: (ModuleName, PSString) -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST + runFn' runFn_ res n = convert where convert :: AST -> AST convert js = fromMaybe js $ go n [] js go :: Int -> [AST] -> AST -> Maybe AST - go 0 acc (App ss runFnN [fn]) | isNFn modName runFnName n runFnN && length acc == n = + go 0 acc (App ss (Ref runFnN) [fn]) | isNFn runFn_ n runFnN && length acc == n = Just $ res ss fn acc go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs go _ _ _ = Nothing @@ -251,8 +240,7 @@ inlineCommonOperators expander = everywhereTopDown $ applyAll $ convert other = other isModFnWithDict :: (ModuleName, PSString) -> AST -> Bool - isModFnWithDict (m, op) (App _ (ModuleAccessor _ m' op') [Var _ _]) = - m == m' && op == op' + isModFnWithDict fn (App _ (Ref fn') [Var _ _]) = fn == fn' isModFnWithDict _ _ = False -- (f <<< g $ x) = f (g x) @@ -261,11 +249,11 @@ inlineFnComposition :: forall m. MonadSupply m => (AST -> AST) -> AST -> m AST inlineFnComposition expander = everywhereTopDownM convert where convert :: AST -> m AST - convert (App s1 (App s2 (App _ (expander -> App _ fn [dict']) [x]) [y]) [z]) - | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]] - | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]] - convert app@(App ss (App _ (expander -> App _ fn [dict']) _) _) - | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName + convert (App s1 (App s2 (App _ (expander -> App _ (Ref fn) [Ref C.P_semigroupoidFn]) [x]) [y]) [z]) + | C.P_compose <- fn = return $ App s1 x [App s2 y [z]] + | C.P_composeFlipped <- fn = return $ App s2 y [App s1 x [z]] + convert app@(App ss (App _ (expander -> App _ (Ref fn) [Ref C.P_semigroupoidFn]) _) _) + | fn `elem` [C.P_compose, C.P_composeFlipped] = mkApps ss <$> goApps app <*> freshName convert other = return other mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST @@ -279,151 +267,28 @@ inlineFnComposition expander = everywhereTopDownM convert mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name goApps :: AST -> m [Either AST (Text, AST)] - goApps (App _ (App _ (expander -> App _ fn [dict']) [x]) [y]) - | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y - | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x + goApps (App _ (App _ (expander -> App _ (Ref fn) [Ref C.P_semigroupoidFn]) [x]) [y]) + | C.P_compose <- fn = mappend <$> goApps x <*> goApps y + | C.P_composeFlipped <- fn = mappend <$> goApps y <*> goApps x goApps app@App {} = pure . Right . (,app) <$> freshName goApps other = pure [Left other] - isFnCompose :: AST -> AST -> Bool - isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn - - isFnComposeFlipped :: AST -> AST -> Bool - isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn - - fnCompose :: forall a. IsString a => (ModuleName, a) - fnCompose = (C.ControlSemigroupoid, C.compose) - - fnComposeFlipped :: forall a. IsString a => (ModuleName, a) - fnComposeFlipped = (C.ControlSemigroupoid, C.composeFlipped) - inlineFnIdentity :: (AST -> AST) -> AST -> AST inlineFnIdentity expander = everywhereTopDown convert where convert :: AST -> AST - convert (App _ (expander -> App _ fn [dict]) [x]) | isDict categoryFn dict && isDict fnIdentity fn = x + convert (App _ (expander -> App _ (Ref C.P_identity) [Ref C.P_categoryFn]) [x]) = x convert other = other - fnIdentity :: forall a. IsString a => (ModuleName, a) - fnIdentity = (C.ControlCategory, C.identity) - inlineUnsafeCoerce :: AST -> AST inlineUnsafeCoerce = everywhereTopDown convert where - convert (App _ (ModuleAccessor _ C.UnsafeCoerce unsafeCoerceFn) [ comp ]) - | unsafeCoerceFn == C.unsafeCoerceFn - = comp + convert (App _ (Ref C.P_unsafeCoerce) [ comp ]) = comp convert other = other inlineUnsafePartial :: AST -> AST inlineUnsafePartial = everywhereTopDown convert where - convert (App ss (ModuleAccessor _ C.PartialUnsafe unsafePartial) [ comp ]) - | unsafePartial == C.unsafePartial + convert (App ss (Ref C.P_unsafePartial) [ comp ]) -- Apply to undefined here, the application should be optimized away -- if it is safe to do so - = App ss comp [ Var ss C.undefined ] + = App ss comp [ Var ss C.S_undefined ] convert other = other - -semiringNumber :: forall a. IsString a => (ModuleName, a) -semiringNumber = (C.DataSemiring, C.semiringNumber) - -semiringInt :: forall a. IsString a => (ModuleName, a) -semiringInt = (C.DataSemiring, C.semiringInt) - -ringNumber :: forall a. IsString a => (ModuleName, a) -ringNumber = (C.DataRing, C.ringNumber) - -ringInt :: forall a. IsString a => (ModuleName, a) -ringInt = (C.DataRing, C.ringInt) - -euclideanRingNumber :: forall a. IsString a => (ModuleName, a) -euclideanRingNumber = (C.DataEuclideanRing, C.euclideanRingNumber) - -eqNumber :: forall a. IsString a => (ModuleName, a) -eqNumber = (C.DataEq, C.eqNumber) - -eqInt :: forall a. IsString a => (ModuleName, a) -eqInt = (C.DataEq, C.eqInt) - -eqString :: forall a. IsString a => (ModuleName, a) -eqString = (C.DataEq, C.eqString) - -eqChar :: forall a. IsString a => (ModuleName, a) -eqChar = (C.DataEq, C.eqChar) - -eqBoolean :: forall a. IsString a => (ModuleName, a) -eqBoolean = (C.DataEq, C.eqBoolean) - -ordBoolean :: forall a. IsString a => (ModuleName, a) -ordBoolean = (C.DataOrd, C.ordBoolean) - -ordNumber :: forall a. IsString a => (ModuleName, a) -ordNumber = (C.DataOrd, C.ordNumber) - -ordInt :: forall a. IsString a => (ModuleName, a) -ordInt = (C.DataOrd, C.ordInt) - -ordString :: forall a. IsString a => (ModuleName, a) -ordString = (C.DataOrd, C.ordString) - -ordChar :: forall a. IsString a => (ModuleName, a) -ordChar = (C.DataOrd, C.ordChar) - -semigroupString :: forall a. IsString a => (ModuleName, a) -semigroupString = (C.DataSemigroup, C.semigroupString) - -boundedBoolean :: forall a. IsString a => (ModuleName, a) -boundedBoolean = (C.DataBounded, C.boundedBoolean) - -heytingAlgebraBoolean :: forall a. IsString a => (ModuleName, a) -heytingAlgebraBoolean = (C.DataHeytingAlgebra, C.heytingAlgebraBoolean) - -semigroupoidFn :: forall a. IsString a => (ModuleName, a) -semigroupoidFn = (C.ControlSemigroupoid, C.semigroupoidFn) - -categoryFn :: forall a. IsString a => (ModuleName, a) -categoryFn = (C.ControlCategory, C.categoryFn) - -opAdd :: forall a. IsString a => (ModuleName, a) -opAdd = (C.DataSemiring, C.add) - -opMul :: forall a. IsString a => (ModuleName, a) -opMul = (C.DataSemiring, C.mul) - -opEq :: forall a. IsString a => (ModuleName, a) -opEq = (C.DataEq, C.eq) - -opNotEq :: forall a. IsString a => (ModuleName, a) -opNotEq = (C.DataEq, C.notEq) - -opLessThan :: forall a. IsString a => (ModuleName, a) -opLessThan = (C.DataOrd, C.lessThan) - -opLessThanOrEq :: forall a. IsString a => (ModuleName, a) -opLessThanOrEq = (C.DataOrd, C.lessThanOrEq) - -opGreaterThan :: forall a. IsString a => (ModuleName, a) -opGreaterThan = (C.DataOrd, C.greaterThan) - -opGreaterThanOrEq :: forall a. IsString a => (ModuleName, a) -opGreaterThanOrEq = (C.DataOrd, C.greaterThanOrEq) - -opAppend :: forall a. IsString a => (ModuleName, a) -opAppend = (C.DataSemigroup, C.append) - -opSub :: forall a. IsString a => (ModuleName, a) -opSub = (C.DataRing, C.sub) - -opNegate :: forall a. IsString a => (ModuleName, a) -opNegate = (C.DataRing, C.negate) - -opDiv :: forall a. IsString a => (ModuleName, a) -opDiv = (C.DataEuclideanRing, C.div) - -opConj :: forall a. IsString a => (ModuleName, a) -opConj = (C.DataHeytingAlgebra, C.conj) - -opDisj :: forall a. IsString a => (ModuleName, a) -opDisj = (C.DataHeytingAlgebra, C.disj) - -opNot :: forall a. IsString a => (ModuleName, a) -opNot = (C.DataHeytingAlgebra, C.not) diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs index 449c2be79c..fb9ed17ad5 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs @@ -11,7 +11,7 @@ import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Common import Language.PureScript.Names (ModuleName) import Language.PureScript.PSString (mkString) -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C -- | Inline type class dictionaries for >>= and return for the Eff monad -- @@ -28,13 +28,13 @@ import qualified Language.PureScript.Constants.Prelude as C -- ... -- } magicDoEff :: (AST -> AST) -> AST -> AST -magicDoEff = magicDo C.Eff C.effDictionaries +magicDoEff = magicDo C.M_Control_Monad_Eff C.effDictionaries magicDoEffect :: (AST -> AST) -> AST -> AST -magicDoEffect = magicDo C.Effect C.effectDictionaries +magicDoEffect = magicDo C.M_Effect C.effectDictionaries magicDoST :: (AST -> AST) -> AST -> AST -magicDoST = magicDo C.ST C.stDictionaries +magicDoST = magicDo C.M_Control_Monad_ST_Internal C.stDictionaries magicDo :: ModuleName -> C.EffectDictionaries -> (AST -> AST) -> AST -> AST magicDo effectModule C.EffectDictionaries{..} expander = everywhereTopDown convert @@ -68,25 +68,16 @@ magicDo effectModule C.EffectDictionaries{..} expander = everywhereTopDown conve App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) [] convert other = other -- Check if an expression represents a monomorphic call to >>= for the Eff monad - isBind (expander -> App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True + isBind (expander -> App _ (Ref C.P_bind) [Ref dict]) = (effectModule, edBindDict) == dict isBind _ = False -- Check if an expression represents a call to @discard@ - isDiscard (expander -> App _ (expander -> App _ fn [dict1]) [dict2]) - | isDict (C.ControlBind, C.discardUnitDictionary) dict1 && - isDict (effectModule, edBindDict) dict2 && - isDiscardPoly fn = True + isDiscard (expander -> App _ (expander -> App _ (Ref C.P_discard) [Ref C.P_discardUnit]) [Ref dict]) = (effectModule, edBindDict) == dict isDiscard _ = False -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative - isPure (expander -> App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True + isPure (expander -> App _ (Ref C.P_pure) [Ref dict]) = (effectModule, edApplicativeDict) == dict isPure _ = False - -- Check if an expression represents the polymorphic >>= function - isBindPoly = isDict (C.ControlBind, C.bind) - -- Check if an expression represents the polymorphic pure function - isPurePoly = isDict (C.ControlApplicative, C.pure') - -- Check if an expression represents the polymorphic discard function - isDiscardPoly = isDict (C.ControlBind, C.discard) -- Check if an expression represents a function in the Effect module - isEffFunc name (ModuleAccessor _ eff name') = eff == effectModule && name == name' + isEffFunc name (Ref fn) = (effectModule, name) == fn isEffFunc _ _ = False applyReturns :: AST -> AST @@ -102,10 +93,10 @@ magicDo effectModule C.EffectDictionaries{..} expander = everywhereTopDown conve inlineST :: AST -> AST inlineST = everywhere convertBlock where - -- Look for runST blocks and inline the STRefs there. - -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then + -- Look for run blocks and inline the STRefs there. + -- If all STRefs are used in the scope of the same run, only using { read, write, modify } then -- we can be more aggressive about inlining, and actually turn STRefs into local variables. - convertBlock (App s1 f [arg]) | isSTFunc C.runST f = + convertBlock (App s1 (Ref C.P_run) [arg]) = let refs = ordNub . findSTRefsIn $ arg usages = findAllSTUsagesIn arg allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages @@ -115,28 +106,25 @@ inlineST = everywhere convertBlock -- Convert a block in a safe way, preserving object wrappers of references, -- or in a more aggressive way, turning wrappers into local variables depending on the -- agg(ressive) parameter. - convert agg (App s1 f [arg]) | isSTFunc C.newSTRef f = + convert agg (App s1 (Ref C.P_new) [arg]) = Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]]) - convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f = + convert agg (App _ (App s1 (Ref C.P_read) [ref]) []) = if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref - convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f = + convert agg (App _ (App _ (App s1 (Ref C.P_write) [arg]) [ref]) []) = if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg - convert agg (App _ (App _ (App s1 f [func]) [ref]) []) | isSTFunc C.modifySTRef f = + convert agg (App _ (App _ (App s1 (Ref C.P_modify) [func]) [ref]) []) = if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref]) convert _ other = other - -- Check if an expression represents a function in the ST module - isSTFunc name (ModuleAccessor _ C.ST name') = name == name' - isSTFunc _ _ = False -- Find all ST Refs initialized in this block findSTRefsIn = everything (++) isSTRef where - isSTRef (VariableIntroduction _ ident (Just (_, App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident] + isSTRef (VariableIntroduction _ ident (Just (_, App _ (App _ (Ref C.P_new) [_]) []))) = [ident] isSTRef _ = [] - -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef + -- Find all STRefs used as arguments to read, write, modify findAllSTUsagesIn = everything (++) isSTUsage where - isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref] - isSTUsage (App _ (App _ (App _ f [_]) [ref]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref] + isSTUsage (App _ (App _ (Ref C.P_read) [ref]) []) = [ref] + isSTUsage (App _ (App _ (App _ (Ref f) [_]) [ref]) []) | f `elem` [C.P_write, C.P_modify] = [ref] isSTUsage _ = [] -- Find all uses of a variable appearingIn ref = everything (++) isVar diff --git a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs index cd11de4eca..f920d79af0 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs @@ -32,7 +32,7 @@ removeCodeAfterReturnStatements = everywhere (removeFromBlock go) removeUndefinedApp :: AST -> AST removeUndefinedApp = everywhere convert where - convert (App ss fn [Var _ arg]) | arg == C.undefined = App ss fn [] + convert (App ss fn [Var _ C.S_undefined]) = App ss fn [] convert js = js removeUnusedEffectFreeVars :: [Text] -> [[AST]] -> [[AST]] diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index a8021c9ddc..cd8a4697cd 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -13,6 +13,7 @@ import qualified Data.Text as T import qualified Data.Map as Map import Language.PureScript.Docs.Types +import qualified Language.PureScript.Constants.Prim as P import qualified Language.PureScript.Crash as P import qualified Language.PureScript.Environment as P import qualified Language.PureScript.Names as P @@ -158,27 +159,23 @@ primTypeErrorDocsModule = Module , modReExports = [] } -type NameGen a = Text -> P.Qualified (P.ProperName a) - -unsafeLookupOf +unsafeLookup :: forall v (a :: P.ProperNameType) - . NameGen a - -> Map.Map (P.Qualified (P.ProperName a)) v + . Map.Map (P.Qualified (P.ProperName a)) v -> String - -> Text + -> P.Qualified (P.ProperName a) -> v -unsafeLookupOf k m errorMsg name = go name +unsafeLookup m errorMsg name = go name where - go = fromJust' . flip Map.lookup m . k + go = fromJust' . flip Map.lookup m fromJust' (Just x) = x - fromJust' _ = P.internalError $ errorMsg ++ show name + fromJust' _ = P.internalError $ errorMsg ++ show (P.runProperName $ P.disqualify name) -lookupPrimTypeKindOf - :: NameGen 'P.TypeName - -> Text +lookupPrimTypeKind + :: P.Qualified (P.ProperName 'P.TypeName) -> Type' -lookupPrimTypeKindOf k = ($> ()) . fst . unsafeLookupOf k +lookupPrimTypeKind = ($> ()) . fst . unsafeLookup ( P.primTypes <> P.primBooleanTypes <> P.primOrderingTypes <> @@ -187,23 +184,20 @@ lookupPrimTypeKindOf k = ($> ()) . fst . unsafeLookupOf k P.primTypeErrorTypes ) "Docs.Prim: No such Prim type: " -primType :: Text -> Text -> Declaration -primType = primTypeOf P.primName - -primTypeOf :: NameGen 'P.TypeName -> Text -> Text -> Declaration -primTypeOf gen title comments = Declaration - { declTitle = title +primType :: P.Qualified (P.ProperName 'P.TypeName) -> Text -> Declaration +primType tn comments = Declaration + { declTitle = P.runProperName $ P.disqualify tn , declComments = Just comments , declSourceSpan = Nothing , declChildren = [] - , declInfo = ExternDataDeclaration (lookupPrimTypeKindOf gen title) [] + , declInfo = ExternDataDeclaration (lookupPrimTypeKind tn) [] , declKind = Nothing } -- | Lookup the TypeClassData of a Prim class. This function is specifically -- not exported because it is partial. -lookupPrimClassOf :: NameGen 'P.ClassName -> Text -> P.TypeClassData -lookupPrimClassOf g = unsafeLookupOf g +lookupPrimClass :: P.Qualified (P.ProperName 'P.ClassName) -> P.TypeClassData +lookupPrimClass = unsafeLookup ( P.primClasses <> P.primCoerceClasses <> P.primRowClasses <> @@ -213,18 +207,15 @@ lookupPrimClassOf g = unsafeLookupOf g P.primTypeErrorClasses ) "Docs.Prim: No such Prim class: " -primClass :: Text -> Text -> Declaration -primClass = primClassOf P.primName - -primClassOf :: NameGen 'P.ClassName -> Text -> Text -> Declaration -primClassOf gen title comments = Declaration - { declTitle = title +primClass :: P.Qualified (P.ProperName 'P.ClassName) -> Text -> Declaration +primClass cn comments = Declaration + { declTitle = P.runProperName $ P.disqualify cn , declComments = Just comments , declSourceSpan = Nothing , declChildren = [] , declInfo = let - tcd = lookupPrimClassOf gen title + tcd = lookupPrimClass cn args = fmap (fmap ($> ())) <$> P.typeClassArguments tcd superclasses = ($> ()) <$> P.typeClassSuperclasses tcd fundeps = convertFundepsToStrings args (P.typeClassDependencies tcd) @@ -234,13 +225,13 @@ primClassOf gen title comments = Declaration } kindType :: Declaration -kindType = primType "Type" $ T.unlines +kindType = primType P.Type $ T.unlines [ "`Type` is the kind of all proper types: those that classify value-level terms." , "For example the type `Boolean` has kind `Type`; denoted by `Boolean :: Type`." ] kindConstraint :: Declaration -kindConstraint = primType "Constraint" $ T.unlines +kindConstraint = primType P.Constraint $ T.unlines [ "`Constraint` is the kind of type class constraints." , "For example, a type class declaration like this:" , "" @@ -253,7 +244,7 @@ kindConstraint = primType "Constraint" $ T.unlines ] kindSymbol :: Declaration -kindSymbol = primType "Symbol" $ T.unlines +kindSymbol = primType P.Symbol $ T.unlines [ "`Symbol` is the kind of type-level strings." , "" , "Construct types of this kind using the same literal syntax as documented" @@ -265,7 +256,7 @@ kindSymbol = primType "Symbol" $ T.unlines ] kindRow :: Declaration -kindRow = primType "Row" $ T.unlines +kindRow = primType P.Row $ T.unlines [ "`Row` is the kind constructor of label-indexed types which map type-level strings to other types." , "The most common use of `Row` is `Row Type`, a row mapping labels to basic (of kind `Type`) types:" , "" @@ -277,7 +268,7 @@ kindRow = primType "Row" $ T.unlines ] function :: Declaration -function = primType "Function" $ T.unlines +function = primType P.Function $ T.unlines [ "A function, which takes values of the type specified by the first type" , "parameter, and returns values of the type specified by the second." , "In the JavaScript backend, this is a standard JavaScript Function." @@ -296,7 +287,7 @@ function = primType "Function" $ T.unlines ] array :: Declaration -array = primType "Array" $ T.unlines +array = primType P.Array $ T.unlines [ "An Array: a data structure supporting efficient random access. In" , "the JavaScript backend, values of this type are represented as JavaScript" , "Arrays at runtime." @@ -307,7 +298,7 @@ array = primType "Array" $ T.unlines ] record :: Declaration -record = primType "Record" $ T.unlines +record = primType P.Record $ T.unlines [ "The type of records whose fields are known at compile time. In the" , "JavaScript backend, values of this type are represented as JavaScript" , "Objects at runtime." @@ -329,7 +320,7 @@ record = primType "Record" $ T.unlines ] number :: Declaration -number = primType "Number" $ T.unlines +number = primType P.Number $ T.unlines [ "A double precision floating point number (IEEE 754)." , "" , "Construct values of this type with literals." @@ -342,7 +333,7 @@ number = primType "Number" $ T.unlines ] int :: Declaration -int = primType "Int" $ T.unlines +int = primType P.Int $ T.unlines [ "A 32-bit signed integer. See the `purescript-integers` package for details" , "of how this is accomplished when compiling to JavaScript." , "" @@ -375,7 +366,7 @@ int = primType "Int" $ T.unlines ] string :: Declaration -string = primType "String" $ T.unlines +string = primType P.String $ T.unlines [ "A String. As in JavaScript, String values represent sequences of UTF-16" , "code units, which are not required to form a valid encoding of Unicode" , "text (for example, lone surrogates are permitted)." @@ -397,7 +388,7 @@ string = primType "String" $ T.unlines ] char :: Declaration -char = primType "Char" $ T.unlines +char = primType P.Char $ T.unlines [ "A single character (UTF-16 code unit). The JavaScript representation is a" , "normal `String`, which is guaranteed to contain one code unit. This means" , "that astral plane characters (i.e. those with code point values greater" @@ -409,7 +400,7 @@ char = primType "Char" $ T.unlines ] boolean :: Declaration -boolean = primType "Boolean" $ T.unlines +boolean = primType P.Boolean $ T.unlines [ "A JavaScript Boolean value." , "" , "Construct values of this type with the literals `true` and `false`." @@ -418,7 +409,7 @@ boolean = primType "Boolean" $ T.unlines ] partial :: Declaration -partial = primClass "Partial" $ T.unlines +partial = primClass P.Partial $ T.unlines [ "The Partial type class is used to indicate that a function is *partial,*" , "that is, it is not defined for all inputs. In practice, attempting to use" , "a partial function with a bad input will usually cause an error to be" @@ -428,17 +419,17 @@ partial = primClass "Partial" $ T.unlines ] booleanTrue :: Declaration -booleanTrue = primTypeOf (P.primSubName "Boolean") "True" $ T.unlines +booleanTrue = primType P.True $ T.unlines [ "The 'True' boolean type." ] booleanFalse :: Declaration -booleanFalse = primTypeOf (P.primSubName "Boolean") "False" $ T.unlines +booleanFalse = primType P.False $ T.unlines [ "The 'False' boolean type." ] coercible :: Declaration -coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines +coercible = primClass P.Coercible $ T.unlines [ "Coercible is a two-parameter type class that has instances for types `a`" , "and `b` if the compiler can infer that they have the same representation." , "Coercible constraints are solved according to the following rules:" @@ -494,29 +485,29 @@ coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines ] kindOrdering :: Declaration -kindOrdering = primTypeOf (P.primSubName "Ordering") "Ordering" $ T.unlines +kindOrdering = primType P.TypeOrdering $ T.unlines [ "The `Ordering` kind represents the three possibilities of comparing two" , "types of the same kind: `LT` (less than), `EQ` (equal to), and" , "`GT` (greater than)." ] orderingLT :: Declaration -orderingLT = primTypeOf (P.primSubName "Ordering") "LT" $ T.unlines +orderingLT = primType P.LT $ T.unlines [ "The 'less than' ordering type." ] orderingEQ :: Declaration -orderingEQ = primTypeOf (P.primSubName "Ordering") "EQ" $ T.unlines +orderingEQ = primType P.EQ $ T.unlines [ "The 'equal to' ordering type." ] orderingGT :: Declaration -orderingGT = primTypeOf (P.primSubName "Ordering") "GT" $ T.unlines +orderingGT = primType P.GT $ T.unlines [ "The 'greater than' ordering type." ] union :: Declaration -union = primClassOf (P.primSubName "Row") "Union" $ T.unlines +union = primClass P.RowUnion $ T.unlines [ "The Union type class is used to compute the union of two rows of types" , "(left-biased, including duplicates)." , "" @@ -524,58 +515,58 @@ union = primClassOf (P.primSubName "Row") "Union" $ T.unlines ] nub :: Declaration -nub = primClassOf (P.primSubName "Row") "Nub" $ T.unlines +nub = primClass P.RowNub $ T.unlines [ "The Nub type class is used to remove duplicate labels from rows." ] lacks :: Declaration -lacks = primClassOf (P.primSubName "Row") "Lacks" $ T.unlines +lacks = primClass P.RowLacks $ T.unlines [ "The Lacks type class asserts that a label does not occur in a given row." ] rowCons :: Declaration -rowCons = primClassOf (P.primSubName "Row") "Cons" $ T.unlines +rowCons = primClass P.RowCons $ T.unlines [ "The Cons type class is a 4-way relation which asserts that one row of" , "types can be obtained from another by inserting a new label/type pair on" , "the left." ] kindRowList :: Declaration -kindRowList = primTypeOf (P.primSubName "RowList") "RowList" $ T.unlines +kindRowList = primType P.RowList $ T.unlines [ "A type level list representation of a row of types." ] rowListCons :: Declaration -rowListCons = primTypeOf (P.primSubName "RowList") "Cons" $ T.unlines +rowListCons = primType P.RowListCons $ T.unlines [ "Constructs a new `RowList` from a label, a type, and an existing tail" , "`RowList`. E.g: `Cons \"x\" Int (Cons \"y\" Int Nil)`." ] rowListNil :: Declaration -rowListNil = primTypeOf (P.primSubName "RowList") "Nil" $ T.unlines +rowListNil = primType P.RowListNil $ T.unlines [ "The empty `RowList`." ] rowToList :: Declaration -rowToList = primClassOf (P.primSubName "RowList") "RowToList" $ T.unlines +rowToList = primClass P.RowToList $ T.unlines [ "Compiler solved type class for generating a `RowList` from a closed row" , "of types. Entries are sorted by label and duplicates are preserved in" , "the order they appeared in the row." ] symbolAppend :: Declaration -symbolAppend = primClassOf (P.primSubName "Symbol") "Append" $ T.unlines +symbolAppend = primClass P.SymbolAppend $ T.unlines [ "Compiler solved type class for appending `Symbol`s together." ] symbolCompare :: Declaration -symbolCompare = primClassOf (P.primSubName "Symbol") "Compare" $ T.unlines +symbolCompare = primClass P.SymbolCompare $ T.unlines [ "Compiler solved type class for comparing two `Symbol`s." , "Produces an `Ordering`." ] symbolCons :: Declaration -symbolCons = primClassOf (P.primSubName "Symbol") "Cons" $ T.unlines +symbolCons = primClass P.SymbolCons $ T.unlines [ "Compiler solved type class for either splitting up a symbol into its" , "head and tail or for combining a head and tail into a new symbol." , "Requires the head to be a single character and the combined string" @@ -583,28 +574,28 @@ symbolCons = primClassOf (P.primSubName "Symbol") "Cons" $ T.unlines ] intAdd :: Declaration -intAdd = primClassOf (P.primSubName "Int") "Add" $ T.unlines +intAdd = primClass P.IntAdd $ T.unlines [ "Compiler solved type class for adding type-level `Int`s." ] intCompare :: Declaration -intCompare = primClassOf (P.primSubName "Int") "Compare" $ T.unlines +intCompare = primClass P.IntCompare $ T.unlines [ "Compiler solved type class for comparing two type-level `Int`s." , "Produces an `Ordering`." ] intMul :: Declaration -intMul = primClassOf (P.primSubName "Int") "Mul" $ T.unlines +intMul = primClass P.IntMul $ T.unlines [ "Compiler solved type class for multiplying type-level `Int`s." ] intToString :: Declaration -intToString = primClassOf (P.primSubName "Int") "ToString" $ T.unlines +intToString = primClass P.IntToString $ T.unlines [ "Compiler solved type class for converting a type-level `Int` into a type-level `String` (i.e. `Symbol`)." ] fail :: Declaration -fail = primClassOf (P.primSubName "TypeError") "Fail" $ T.unlines +fail = primClass P.Fail $ T.unlines [ "The Fail type class is part of the custom type errors feature. To provide" , "a custom type error when someone tries to use a particular instance," , "write that instance out with a Fail constraint." @@ -614,7 +605,7 @@ fail = primClassOf (P.primSubName "TypeError") "Fail" $ T.unlines ] warn :: Declaration -warn = primClassOf (P.primSubName "TypeError") "Warn" $ T.unlines +warn = primClass P.Warn $ T.unlines [ "The Warn type class allows a custom compiler warning to be displayed." , "" , "For more information, see" @@ -622,7 +613,7 @@ warn = primClassOf (P.primSubName "TypeError") "Warn" $ T.unlines ] kindDoc :: Declaration -kindDoc = primTypeOf (P.primSubName "TypeError") "Doc" $ T.unlines +kindDoc = primType P.Doc $ T.unlines [ "`Doc` is the kind of type-level documents." , "" , "This kind is used with the `Fail` and `Warn` type classes." @@ -630,7 +621,7 @@ kindDoc = primTypeOf (P.primSubName "TypeError") "Doc" $ T.unlines ] textDoc :: Declaration -textDoc = primTypeOf (P.primSubName "TypeError") "Text" $ T.unlines +textDoc = primType P.Text $ T.unlines [ "The Text type constructor makes a Doc from a Symbol" , "to be used in a custom type error." , "" @@ -639,7 +630,7 @@ textDoc = primTypeOf (P.primSubName "TypeError") "Text" $ T.unlines ] quoteDoc :: Declaration -quoteDoc = primTypeOf (P.primSubName "TypeError") "Quote" $ T.unlines +quoteDoc = primType P.Quote $ T.unlines [ "The Quote type constructor renders any concrete type as a Doc" , "to be used in a custom type error." , "" @@ -648,7 +639,7 @@ quoteDoc = primTypeOf (P.primSubName "TypeError") "Quote" $ T.unlines ] quoteLabelDoc :: Declaration -quoteLabelDoc = primTypeOf (P.primSubName "TypeError") "QuoteLabel" $ T.unlines +quoteLabelDoc = primType P.QuoteLabel $ T.unlines [ "The `QuoteLabel` type constructor will produce a `Doc` when given a `Symbol`. When the resulting `Doc` is rendered" , "for a `Warn` or `Fail` constraint, a syntactically valid label will be produced, escaping with quotes as needed." , "" @@ -657,7 +648,7 @@ quoteLabelDoc = primTypeOf (P.primSubName "TypeError") "QuoteLabel" $ T.unlines ] besideDoc :: Declaration -besideDoc = primTypeOf (P.primSubName "TypeError") "Beside" $ T.unlines +besideDoc = primType P.Beside $ T.unlines [ "The Beside type constructor combines two Docs horizontally" , "to be used in a custom type error." , "" @@ -666,7 +657,7 @@ besideDoc = primTypeOf (P.primSubName "TypeError") "Beside" $ T.unlines ] aboveDoc :: Declaration -aboveDoc = primTypeOf (P.primSubName "TypeError") "Above" $ T.unlines +aboveDoc = primType P.Above $ T.unlines [ "The Above type constructor combines two Docs vertically" , "in a custom type error." , "" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index fc32591eb7..96dd1d2215 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -9,6 +9,7 @@ import Codec.Serialise (Serialise) import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A import Data.Foldable (find, fold) +import Data.Functor ((<&>)) import qualified Data.IntMap as IM import qualified Data.IntSet as IS import qualified Data.Map as M @@ -279,81 +280,62 @@ instance A.FromJSON DataDeclType where "newtype" -> return Newtype other -> fail $ "invalid type: '" ++ T.unpack other ++ "'" --- | Construct a ProperName in the Prim module -primName :: Text -> Qualified (ProperName a) -primName = Qualified (ByModuleName C.Prim) . ProperName - --- | Construct a 'ProperName' in the @Prim.NAME@ module. -primSubName :: Text -> Text -> Qualified (ProperName a) -primSubName sub = - Qualified (ByModuleName $ ModuleName $ C.prim <> "." <> sub) . ProperName - -primKind :: Text -> SourceType -primKind = primTy - -primSubKind :: Text -> Text -> SourceType -primSubKind sub = TypeConstructor nullSourceAnn . primSubName sub - -- | Kind of ground types kindType :: SourceType -kindType = primKind C.typ +kindType = srcTypeConstructor C.Type kindConstraint :: SourceType -kindConstraint = primKind C.constraint +kindConstraint = srcTypeConstructor C.Constraint kindSymbol :: SourceType -kindSymbol = primKind C.symbol +kindSymbol = srcTypeConstructor C.Symbol kindDoc :: SourceType -kindDoc = primSubKind C.typeError C.doc +kindDoc = srcTypeConstructor C.Doc kindOrdering :: SourceType -kindOrdering = primSubKind C.moduleOrdering C.kindOrdering +kindOrdering = srcTypeConstructor C.TypeOrdering kindRowList :: SourceType -> SourceType -kindRowList = TypeApp nullSourceAnn (primSubKind C.moduleRowList C.kindRowList) +kindRowList = TypeApp nullSourceAnn (srcTypeConstructor C.RowList) kindRow :: SourceType -> SourceType -kindRow = TypeApp nullSourceAnn (primKind C.row) +kindRow = TypeApp nullSourceAnn (srcTypeConstructor C.Row) kindOfREmpty :: SourceType kindOfREmpty = tyForall "k" kindType (kindRow (tyVar "k")) --- | Construct a type in the Prim module -primTy :: Text -> SourceType -primTy = TypeConstructor nullSourceAnn . primName - -- | Type constructor for functions tyFunction :: SourceType -tyFunction = primTy "Function" +tyFunction = srcTypeConstructor C.Function -- | Type constructor for strings tyString :: SourceType -tyString = primTy "String" +tyString = srcTypeConstructor C.String -- | Type constructor for strings tyChar :: SourceType -tyChar = primTy "Char" +tyChar = srcTypeConstructor C.Char -- | Type constructor for numbers tyNumber :: SourceType -tyNumber = primTy "Number" +tyNumber = srcTypeConstructor C.Number -- | Type constructor for integers tyInt :: SourceType -tyInt = primTy "Int" +tyInt = srcTypeConstructor C.Int -- | Type constructor for booleans tyBoolean :: SourceType -tyBoolean = primTy "Boolean" +tyBoolean = srcTypeConstructor C.Boolean -- | Type constructor for arrays tyArray :: SourceType -tyArray = primTy "Array" +tyArray = srcTypeConstructor C.Array -- | Type constructor for records tyRecord :: SourceType -tyRecord = primTy "Record" +tyRecord = srcTypeConstructor C.Record tyVar :: Text -> SourceType tyVar = TypeVar nullSourceAnn @@ -370,12 +352,12 @@ function = TypeApp nullSourceAnn . TypeApp nullSourceAnn tyFunction (-:>) = function infixr 4 -:> -primClass :: Qualified (ProperName 'TypeName) -> (SourceType -> SourceType) -> [(Qualified (ProperName 'TypeName), (SourceType, TypeKind))] +primClass :: Qualified (ProperName 'ClassName) -> (SourceType -> SourceType) -> [(Qualified (ProperName 'TypeName), (SourceType, TypeKind))] primClass name mkKind = [ let k = mkKind kindConstraint - in (name, (k, ExternData (nominalRolesForKind k))) + in (coerceProperName <$> name, (k, ExternData (nominalRolesForKind k))) , let k = mkKind kindType - in (dictTypeName <$> name, (k, TypeSynonym)) + in (dictTypeName . coerceProperName <$> name, (k, TypeSynonym)) ] -- | The primitive types in the external environment with their @@ -384,19 +366,19 @@ primClass name mkKind = primTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primTypes = M.fromList - [ (primName "Type", (kindType, ExternData [])) - , (primName "Constraint", (kindType, ExternData [])) - , (primName "Symbol", (kindType, ExternData [])) - , (primName "Row", (kindType -:> kindType, ExternData [Phantom])) - , (primName "Function", (kindType -:> kindType -:> kindType, ExternData [Representational, Representational])) - , (primName "Array", (kindType -:> kindType, ExternData [Representational])) - , (primName "Record", (kindRow kindType -:> kindType, ExternData [Representational])) - , (primName "String", (kindType, ExternData [])) - , (primName "Char", (kindType, ExternData [])) - , (primName "Number", (kindType, ExternData [])) - , (primName "Int", (kindType, ExternData [])) - , (primName "Boolean", (kindType, ExternData [])) - , (primName "Partial", (kindConstraint, ExternData [])) + [ (C.Type, (kindType, ExternData [])) + , (C.Constraint, (kindType, ExternData [])) + , (C.Symbol, (kindType, ExternData [])) + , (C.Row, (kindType -:> kindType, ExternData [Phantom])) + , (C.Function, (kindType -:> kindType -:> kindType, ExternData [Representational, Representational])) + , (C.Array, (kindType -:> kindType, ExternData [Representational])) + , (C.Record, (kindRow kindType -:> kindType, ExternData [Representational])) + , (C.String, (kindType, ExternData [])) + , (C.Char, (kindType, ExternData [])) + , (C.Number, (kindType, ExternData [])) + , (C.Int, (kindType, ExternData [])) + , (C.Boolean, (kindType, ExternData [])) + , (C.Partial <&> coerceProperName, (kindConstraint, ExternData [])) ] -- | This 'Map' contains all of the prim types from all Prim modules. @@ -416,75 +398,75 @@ allPrimTypes = M.unions primBooleanTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primBooleanTypes = M.fromList - [ (primSubName C.moduleBoolean "True", (tyBoolean, ExternData [])) - , (primSubName C.moduleBoolean "False", (tyBoolean, ExternData [])) + [ (C.True, (tyBoolean, ExternData [])) + , (C.False, (tyBoolean, ExternData [])) ] primCoerceTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primCoerceTypes = M.fromList $ mconcat - [ primClass (primSubName C.moduleCoerce "Coercible") (\kind -> tyForall "k" kindType $ tyVar "k" -:> tyVar "k" -:> kind) + [ primClass C.Coercible (\kind -> tyForall "k" kindType $ tyVar "k" -:> tyVar "k" -:> kind) ] primOrderingTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primOrderingTypes = M.fromList - [ (primSubName C.moduleOrdering "Ordering", (kindType, ExternData [])) - , (primSubName C.moduleOrdering "LT", (kindOrdering, ExternData [])) - , (primSubName C.moduleOrdering "EQ", (kindOrdering, ExternData [])) - , (primSubName C.moduleOrdering "GT", (kindOrdering, ExternData [])) + [ (C.TypeOrdering, (kindType, ExternData [])) + , (C.LT, (kindOrdering, ExternData [])) + , (C.EQ, (kindOrdering, ExternData [])) + , (C.GT, (kindOrdering, ExternData [])) ] primRowTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primRowTypes = M.fromList $ mconcat - [ primClass (primSubName C.moduleRow "Union") (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) - , primClass (primSubName C.moduleRow "Nub") (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) - , primClass (primSubName C.moduleRow "Lacks") (\kind -> tyForall "k" kindType $ kindSymbol -:> kindRow (tyVar "k") -:> kind) - , primClass (primSubName C.moduleRow "Cons") (\kind -> tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) + [ primClass C.RowUnion (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) + , primClass C.RowNub (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) + , primClass C.RowLacks (\kind -> tyForall "k" kindType $ kindSymbol -:> kindRow (tyVar "k") -:> kind) + , primClass C.RowCons (\kind -> tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) ] primRowListTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primRowListTypes = M.fromList $ - [ (primSubName C.moduleRowList "RowList", (kindType -:> kindType, ExternData [Phantom])) - , (primSubName C.moduleRowList "Cons", (tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRowList (tyVar "k") -:> kindRowList (tyVar "k"), ExternData [Phantom, Phantom, Phantom])) - , (primSubName C.moduleRowList "Nil", (tyForall "k" kindType $ kindRowList (tyVar "k"), ExternData [])) + [ (C.RowList, (kindType -:> kindType, ExternData [Phantom])) + , (C.RowListCons, (tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRowList (tyVar "k") -:> kindRowList (tyVar "k"), ExternData [Phantom, Phantom, Phantom])) + , (C.RowListNil, (tyForall "k" kindType $ kindRowList (tyVar "k"), ExternData [])) ] <> mconcat - [ primClass (primSubName C.moduleRowList "RowToList") (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRowList (tyVar "k") -:> kind) + [ primClass C.RowToList (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRowList (tyVar "k") -:> kind) ] primSymbolTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primSymbolTypes = M.fromList $ mconcat - [ primClass (primSubName C.moduleSymbol "Append") (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind) - , primClass (primSubName C.moduleSymbol "Compare") (\kind -> kindSymbol -:> kindSymbol -:> kindOrdering -:> kind) - , primClass (primSubName C.moduleSymbol "Cons") (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind) + [ primClass C.SymbolAppend (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind) + , primClass C.SymbolCompare (\kind -> kindSymbol -:> kindSymbol -:> kindOrdering -:> kind) + , primClass C.SymbolCons (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind) ] primIntTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primIntTypes = M.fromList $ mconcat - [ primClass (primSubName C.moduleInt "Add") (\kind -> tyInt -:> tyInt -:> tyInt -:> kind) - , primClass (primSubName C.moduleInt "Compare") (\kind -> tyInt -:> tyInt -:> kindOrdering -:> kind) - , primClass (primSubName C.moduleInt "Mul") (\kind -> tyInt -:> tyInt -:> tyInt -:> kind) - , primClass (primSubName C.moduleInt "ToString") (\kind -> tyInt -:> kindSymbol -:> kind) + [ primClass C.IntAdd (\kind -> tyInt -:> tyInt -:> tyInt -:> kind) + , primClass C.IntCompare (\kind -> tyInt -:> tyInt -:> kindOrdering -:> kind) + , primClass C.IntMul (\kind -> tyInt -:> tyInt -:> tyInt -:> kind) + , primClass C.IntToString (\kind -> tyInt -:> kindSymbol -:> kind) ] primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primTypeErrorTypes = M.fromList $ - [ (primSubName C.typeError "Doc", (kindType, ExternData [])) - , (primSubName C.typeError "Fail", (kindDoc -:> kindConstraint, ExternData [Nominal])) - , (primSubName C.typeError "Warn", (kindDoc -:> kindConstraint, ExternData [Nominal])) - , (primSubName C.typeError "Text", (kindSymbol -:> kindDoc, ExternData [Phantom])) - , (primSubName C.typeError "Quote", (tyForall "k" kindType $ tyVar "k" -:> kindDoc, ExternData [Phantom])) - , (primSubName C.typeError "QuoteLabel", (kindSymbol -:> kindDoc, ExternData [Phantom])) - , (primSubName C.typeError "Beside", (kindDoc -:> kindDoc -:> kindDoc, ExternData [Phantom, Phantom])) - , (primSubName C.typeError "Above", (kindDoc -:> kindDoc -:> kindDoc, ExternData [Phantom, Phantom])) + [ (C.Doc, (kindType, ExternData [])) + , (C.Fail <&> coerceProperName, (kindDoc -:> kindConstraint, ExternData [Nominal])) + , (C.Warn <&> coerceProperName, (kindDoc -:> kindConstraint, ExternData [Nominal])) + , (C.Text, (kindSymbol -:> kindDoc, ExternData [Phantom])) + , (C.Quote, (tyForall "k" kindType $ tyVar "k" -:> kindDoc, ExternData [Phantom])) + , (C.QuoteLabel, (kindSymbol -:> kindDoc, ExternData [Phantom])) + , (C.Beside, (kindDoc -:> kindDoc -:> kindDoc, ExternData [Phantom, Phantom])) + , (C.Above, (kindDoc -:> kindDoc -:> kindDoc, ExternData [Phantom, Phantom])) ] <> mconcat - [ primClass (primSubName C.typeError "Fail") (\kind -> kindDoc -:> kind) - , primClass (primSubName C.typeError "Warn") (\kind -> kindDoc -:> kind) + [ primClass C.Fail (\kind -> kindDoc -:> kind) + , primClass C.Warn (\kind -> kindDoc -:> kind) ] -- | The primitive class map. This just contains the `Partial` class. @@ -492,7 +474,7 @@ primTypeErrorTypes = primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses = M.fromList - [ (primName "Partial", makeTypeClassData [] [] [] [] True) + [ (C.Partial, makeTypeClassData [] [] [] [] True) ] -- | This contains all of the type classes from all Prim modules. @@ -511,7 +493,7 @@ primCoerceClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primCoerceClasses = M.fromList -- class Coercible (a :: k) (b :: k) - [ (primSubName C.moduleCoerce "Coercible", makeTypeClassData + [ (C.Coercible, makeTypeClassData [ ("a", Just (tyVar "k")) , ("b", Just (tyVar "k")) ] [] [] [] True) @@ -521,7 +503,7 @@ primRowClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primRowClasses = M.fromList -- class Union (left :: Row k) (right :: Row k) (union :: Row k) | left right -> union, right union -> left, union left -> right - [ (primSubName C.moduleRow "Union", makeTypeClassData + [ (C.RowUnion, makeTypeClassData [ ("left", Just (kindRow (tyVar "k"))) , ("right", Just (kindRow (tyVar "k"))) , ("union", Just (kindRow (tyVar "k"))) @@ -532,7 +514,7 @@ primRowClasses = ] True) -- class Nub (original :: Row k) (nubbed :: Row k) | original -> nubbed - , (primSubName C.moduleRow "Nub", makeTypeClassData + , (C.RowNub, makeTypeClassData [ ("original", Just (kindRow (tyVar "k"))) , ("nubbed", Just (kindRow (tyVar "k"))) ] [] [] @@ -540,13 +522,13 @@ primRowClasses = ] True) -- class Lacks (label :: Symbol) (row :: Row k) - , (primSubName C.moduleRow "Lacks", makeTypeClassData + , (C.RowLacks, makeTypeClassData [ ("label", Just kindSymbol) , ("row", Just (kindRow (tyVar "k"))) ] [] [] [] True) -- class RowCons (label :: Symbol) (a :: k) (tail :: Row k) (row :: Row k) | label tail a -> row, label row -> tail a - , (primSubName C.moduleRow "Cons", makeTypeClassData + , (C.RowCons, makeTypeClassData [ ("label", Just kindSymbol) , ("a", Just (tyVar "k")) , ("tail", Just (kindRow (tyVar "k"))) @@ -561,7 +543,7 @@ primRowListClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primRowListClasses = M.fromList -- class RowToList (row :: Row k) (list :: RowList k) | row -> list - [ (primSubName C.moduleRowList "RowToList", makeTypeClassData + [ (C.RowToList, makeTypeClassData [ ("row", Just (kindRow (tyVar "k"))) , ("list", Just (kindRowList (tyVar "k"))) ] [] [] @@ -573,7 +555,7 @@ primSymbolClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primSymbolClasses = M.fromList -- class Append (left :: Symbol) (right :: Symbol) (appended :: Symbol) | left right -> appended, right appended -> left, appended left -> right - [ (primSubName C.moduleSymbol "Append", makeTypeClassData + [ (C.SymbolAppend, makeTypeClassData [ ("left", Just kindSymbol) , ("right", Just kindSymbol) , ("appended", Just kindSymbol) @@ -584,7 +566,7 @@ primSymbolClasses = ] True) -- class Compare (left :: Symbol) (right :: Symbol) (ordering :: Ordering) | left right -> ordering - , (primSubName C.moduleSymbol "Compare", makeTypeClassData + , (C.SymbolCompare, makeTypeClassData [ ("left", Just kindSymbol) , ("right", Just kindSymbol) , ("ordering", Just kindOrdering) @@ -593,7 +575,7 @@ primSymbolClasses = ] True) -- class Cons (head :: Symbol) (tail :: Symbol) (symbol :: Symbol) | head tail -> symbol, symbol -> head tail - , (primSubName C.moduleSymbol "Cons", makeTypeClassData + , (C.SymbolCons, makeTypeClassData [ ("head", Just kindSymbol) , ("tail", Just kindSymbol) , ("symbol", Just kindSymbol) @@ -607,7 +589,7 @@ primIntClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primIntClasses = M.fromList -- class Add (left :: Int) (right :: Int) (sum :: Int) | left right -> sum, left sum -> right, right sum -> left - [ (primSubName C.moduleInt "Add", makeTypeClassData + [ (C.IntAdd, makeTypeClassData [ ("left", Just tyInt) , ("right", Just tyInt) , ("sum", Just tyInt) @@ -618,7 +600,7 @@ primIntClasses = ] True) -- class Compare (left :: Int) (right :: Int) (ordering :: Ordering) | left right -> ordering - , (primSubName C.moduleInt "Compare", makeTypeClassData + , (C.IntCompare, makeTypeClassData [ ("left", Just tyInt) , ("right", Just tyInt) , ("ordering", Just kindOrdering) @@ -627,7 +609,7 @@ primIntClasses = ] True) -- class Mul (left :: Int) (right :: Int) (product :: Int) | left right -> product - , (primSubName C.moduleInt "Mul", makeTypeClassData + , (C.IntMul, makeTypeClassData [ ("left", Just tyInt) , ("right", Just tyInt) , ("product", Just tyInt) @@ -636,7 +618,7 @@ primIntClasses = ] True) -- class ToString (int :: Int) (string :: Symbol) | int -> string - , (primSubName C.moduleInt "ToString", makeTypeClassData + , (C.IntToString, makeTypeClassData [ ("int", Just tyInt) , ("string", Just kindSymbol) ] [] [] @@ -648,11 +630,11 @@ primTypeErrorClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primTypeErrorClasses = M.fromList -- class Fail (message :: Symbol) - [ (primSubName C.typeError "Fail", makeTypeClassData + [ (C.Fail, makeTypeClassData [("message", Just kindDoc)] [] [] [] True) -- class Warn (message :: Symbol) - , (primSubName C.typeError "Warn", makeTypeClassData + , (C.Warn, makeTypeClassData [("message", Just kindDoc)] [] [] [] True) ] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 872022d065..60228d3aa5 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -34,12 +34,11 @@ import Data.Traversable (for) import qualified GHC.Stack import Language.PureScript.AST import qualified Language.PureScript.Bundle as Bundle -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.Crash import qualified Language.PureScript.CST.Errors as CST import qualified Language.PureScript.CST.Print as CST -import Language.PureScript.Environment import Language.PureScript.Label (Label(..)) import Language.PureScript.Names import Language.PureScript.Pretty @@ -753,10 +752,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon line $ "The role declaration for " <> markCode (runProperName nm) <> " should follow its definition." renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" - renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident i)))) | i `elem` [ C.bind, C.discard ] = + renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident i)))) | i `elem` [ C.S_bind, C.S_discard ] = line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode "bind" <> " and " <> markCode "discard" <> " functions. Please import " <> markCode i <> " from module " <> markCode "Prelude" - renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident i)))) | i == C.negate = - line $ "Unknown " <> printName name <> ". You're probably using numeric negation (the unary " <> markCode "-" <> " operator), which the compiler replaces with calls to the " <> markCode i <> " function. Please import " <> markCode i <> " from module " <> markCode "Prelude" + renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident C.S_negate)))) = + line $ "Unknown " <> printName name <> ". You're probably using numeric negation (the unary " <> markCode "-" <> " operator), which the compiler replaces with calls to the " <> markCode C.S_negate <> " function. Please import " <> markCode C.S_negate <> " from module " <> markCode "Prelude" renderSimpleErrorMessage (UnknownName name) = line $ "Unknown " <> printName name renderSimpleErrorMessage (UnknownImport mn name) = @@ -1026,7 +1025,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon renderSimpleErrorMessage (ExtraneousClassMember ident className) = line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className) renderSimpleErrorMessage (ExpectedType ty kind) = - paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode C.typ <> "." + paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode (runProperName . disqualify $ C.Type) <> "." , line "The error arises from the type" , markCodeBox $ indent $ prettyType ty , line "having the kind" @@ -1941,18 +1940,16 @@ renderBox = unlines toTypelevelString :: Type a -> Maybe Box.Box toTypelevelString (TypeLevelString _ s) = Just . Box.text $ decodeStringWithReplacement s -toTypelevelString (TypeApp _ (TypeConstructor _ f) x) - | f == primSubName C.typeError "Text" = toTypelevelString x -toTypelevelString (TypeApp _ (KindApp _ (TypeConstructor _ f) _) x) - | f == primSubName C.typeError "Quote" = Just (typeAsBox maxBound x) -toTypelevelString (TypeApp _ (TypeConstructor _ f) (TypeLevelString _ x)) - | f == primSubName C.typeError "QuoteLabel" = Just . line . prettyPrintLabel . Label $ x -toTypelevelString (TypeApp _ (TypeApp _ (TypeConstructor _ f) x) ret) - | f == primSubName C.typeError "Beside" = - (Box.<>) <$> toTypelevelString x <*> toTypelevelString ret -toTypelevelString (TypeApp _ (TypeApp _ (TypeConstructor _ f) x) ret) - | f == primSubName C.typeError "Above" = - (Box.//) <$> toTypelevelString x <*> toTypelevelString ret +toTypelevelString (TypeApp _ (TypeConstructor _ C.Text) x) = + toTypelevelString x +toTypelevelString (TypeApp _ (KindApp _ (TypeConstructor _ C.Quote) _) x) = + Just (typeAsBox maxBound x) +toTypelevelString (TypeApp _ (TypeConstructor _ C.QuoteLabel) (TypeLevelString _ x)) = + Just . line . prettyPrintLabel . Label $ x +toTypelevelString (TypeApp _ (TypeApp _ (TypeConstructor _ C.Beside) x) ret) = + (Box.<>) <$> toTypelevelString x <*> toTypelevelString ret +toTypelevelString (TypeApp _ (TypeApp _ (TypeConstructor _ C.Above) x) ret) = + (Box.//) <$> toTypelevelString x <*> toTypelevelString ret toTypelevelString _ = Nothing -- | Rethrow an error with a more detailed error message in the case of failure diff --git a/src/Language/PureScript/Ide/Imports/Actions.hs b/src/Language/PureScript/Ide/Imports/Actions.hs index 9465d68033..6d69491587 100644 --- a/src/Language/PureScript/Ide/Imports/Actions.hs +++ b/src/Language/PureScript/Ide/Imports/Actions.hs @@ -90,9 +90,9 @@ addExplicitImport' decl moduleName qualifier imports = Import mn P.Implicit qualifier' -> mn == moduleName && qualifier == qualifier' _ -> False) imports isNotExplicitlyImportedFromPrim = - moduleName == C.Prim && + moduleName == C.M_Prim && not (any (\case - Import C.Prim (P.Explicit _) Nothing -> True + Import C.M_Prim (P.Explicit _) Nothing -> True _ -> False) imports) -- We can't import Modules from other modules isModule = has _IdeDeclModule decl diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index 1768b30784..c65e98447b 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -11,28 +11,28 @@ import Language.PureScript.Ide.Types idePrimDeclarations :: ModuleMap [IdeDeclarationAnn] idePrimDeclarations = Map.fromList - [ ( C.Prim + [ ( C.M_Prim , mconcat [primTypes, primClasses] ) - , ( C.PrimBoolean + , ( C.M_Prim_Boolean , mconcat [primBooleanTypes] ) - , ( C.PrimOrdering + , ( C.M_Prim_Ordering , mconcat [primOrderingTypes] ) - , ( C.PrimRow + , ( C.M_Prim_Row , mconcat [primRowTypes, primRowClasses] ) - , ( C.PrimRowList + , ( C.M_Prim_RowList , mconcat [primRowListTypes, primRowListClasses] ) - , ( C.PrimSymbol + , ( C.M_Prim_Symbol , mconcat [primSymbolTypes, primSymbolClasses] ) - , ( C.PrimInt + , ( C.M_Prim_Int , mconcat [primIntTypes, primIntClasses] ) - , ( C.PrimTypeError + , ( C.M_Prim_TypeError , mconcat [primTypeErrorTypes, primTypeErrorClasses] ) ] diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 54571a6272..15265fbf84 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -19,7 +19,7 @@ import Language.PureScript.Linter.Exhaustive as L import Language.PureScript.Linter.Imports as L import Language.PureScript.Names import Language.PureScript.Types -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C -- | Lint the PureScript AST. -- | @@ -162,7 +162,7 @@ lintUnused (Module modSS _ mn modDecls exports) = thisModuleRef _ = False rebindable :: S.Set Ident - rebindable = S.fromList [ Ident C.bind, Ident C.discard ] + rebindable = S.fromList [ Ident C.S_bind, Ident C.S_discard ] getDeclIdent :: Declaration -> Maybe Ident getDeclIdent = getIdentName <=< declName diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index e79f942227..9b81691411 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -142,7 +142,7 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do -- Checks whether a module is the Prim module - used to suppress any checks -- made, as Prim is always implicitly imported. isPrim :: ModuleName -> Bool - isPrim = (== C.Prim) + isPrim = (== C.M_Prim) -- Creates a map of virtual modules mapped to all the declarations that -- import to that module, with the corresponding source span, import type, diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs index 8dfdf59301..4e138f2c98 100644 --- a/src/Language/PureScript/Sugar/AdoNotation.hs +++ b/src/Language/PureScript/Sugar/AdoNotation.hs @@ -12,7 +12,7 @@ import Data.List (foldl') import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Names -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C -- | Replace all @AdoNotationBind@ and @AdoNotationValue@ constructors with -- applications of the pure and apply functions in scope, and all @AdoNotationLet@ @@ -28,13 +28,13 @@ desugarAdo d = in rethrowWithPosition ss $ f d where pure' :: SourceSpan -> Maybe ModuleName -> Expr - pure' ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.pure')) + pure' ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_pure)) map' :: SourceSpan -> Maybe ModuleName -> Expr - map' ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.map)) + map' ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_map)) apply :: SourceSpan -> Maybe ModuleName -> Expr - apply ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.apply)) + apply ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_apply)) replace :: SourceSpan -> Expr -> m Expr replace pos (Ado m els yield) = do diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 0f7c3457b5..008af901da 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -14,7 +14,7 @@ import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.Names -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C -- | Replace all @DoNotationBind@ and @DoNotationValue@ constructors with -- applications of the bind function in scope, and all @DoNotationLet@ @@ -30,10 +30,10 @@ desugarDo d = in rethrowWithPosition ss $ f d where bind :: SourceSpan -> Maybe ModuleName -> Expr - bind ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.bind)) + bind ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_bind)) discard :: SourceSpan -> Maybe ModuleName -> Expr - discard ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.discard)) + discard ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_discard)) replace :: SourceSpan -> Expr -> m Expr replace pos (Do m els) = go pos m els @@ -57,7 +57,7 @@ desugarDo d = go _ _ (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) = throwError . errorMessage $ CannotUseBindWithDo (Ident ident) where - fromIdent (Ident i) | i `elem` [ C.bind, C.discard ] = First (Just i) + fromIdent (Ident i) | i `elem` [ C.S_bind, C.S_discard ] = First (Just i) fromIdent _ = mempty go pos m (DoNotationBind binder val : rest) = do rest' <- go pos m rest @@ -75,7 +75,7 @@ desugarDo d = go pos m (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () checkBind (ValueDecl (ss, _) i@(Ident name) _ _ _) - | name `elem` [ C.bind, C.discard ] = throwError . errorMessage' ss $ CannotUseBindWithDo i + | name `elem` [ C.S_bind, C.S_discard ] = throwError . errorMessage' ss $ CannotUseBindWithDo i checkBind _ = pure () mapM_ checkBind ds rest' <- go pos m rest diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 31543eba9a..5b3616fdad 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -246,31 +246,31 @@ mkPrimExports ts cs = -- | Environment which only contains the Prim modules. primEnv :: Env primEnv = M.fromList - [ ( C.Prim + [ ( C.M_Prim , (internalModuleSourceSpan "", nullImports, primExports) ) - , ( C.PrimBoolean + , ( C.M_Prim_Boolean , (internalModuleSourceSpan "", nullImports, primBooleanExports) ) - , ( C.PrimCoerce + , ( C.M_Prim_Coerce , (internalModuleSourceSpan "", nullImports, primCoerceExports) ) - , ( C.PrimOrdering + , ( C.M_Prim_Ordering , (internalModuleSourceSpan "", nullImports, primOrderingExports) ) - , ( C.PrimRow + , ( C.M_Prim_Row , (internalModuleSourceSpan "", nullImports, primRowExports) ) - , ( C.PrimRowList + , ( C.M_Prim_RowList , (internalModuleSourceSpan "", nullImports, primRowListExports) ) - , ( C.PrimSymbol + , ( C.M_Prim_Symbol , (internalModuleSourceSpan "", nullImports, primSymbolExports) ) - , ( C.PrimInt + , ( C.M_Prim_Int , (internalModuleSourceSpan "", nullImports, primIntExports) ) - , ( C.PrimTypeError + , ( C.M_Prim_TypeError , (internalModuleSourceSpan "", nullImports, primTypeErrorExports) ) ] diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index f830a31c09..1009ce3fbd 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -40,7 +40,7 @@ import Data.Maybe (mapMaybe, listToMaybe) import qualified Data.Map as M import Data.Ord (Down(..)) -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C -- | -- Removes unary negation operators and replaces them with calls to `negate`. @@ -50,7 +50,7 @@ desugarSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts where (f', _, _) = everywhereOnValues id go id - go (UnaryMinus ss' val) = App (Var ss' (Qualified ByNullSourcePos (Ident C.negate))) val + go (UnaryMinus ss' val) = App (Var ss' (Qualified ByNullSourcePos (Ident C.S_negate))) val go other = other -- | diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index cd1dd4caae..28c633dfe5 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -53,13 +53,13 @@ desugarTypeClasses externs = flip evalStateT initialState . desugarModule initialState :: MemberMap initialState = mconcat - [ M.mapKeys (qualify C.Prim) primClasses - , M.mapKeys (qualify C.PrimCoerce) primCoerceClasses - , M.mapKeys (qualify C.PrimRow) primRowClasses - , M.mapKeys (qualify C.PrimRowList) primRowListClasses - , M.mapKeys (qualify C.PrimSymbol) primSymbolClasses - , M.mapKeys (qualify C.PrimInt) primIntClasses - , M.mapKeys (qualify C.PrimTypeError) primTypeErrorClasses + [ M.mapKeys (qualify C.M_Prim) primClasses + , M.mapKeys (qualify C.M_Prim_Coerce) primCoerceClasses + , M.mapKeys (qualify C.M_Prim_Row) primRowClasses + , M.mapKeys (qualify C.M_Prim_RowList) primRowListClasses + , M.mapKeys (qualify C.M_Prim_Symbol) primSymbolClasses + , M.mapKeys (qualify C.M_Prim_Int) primIntClasses + , M.mapKeys (qualify C.M_Prim_TypeError) primTypeErrorClasses , M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) ] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 70db418116..bcd401a5bc 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -9,8 +9,7 @@ import Control.Monad.Supply.Class (MonadSupply) import Data.List (foldl', find, unzip5) import Language.PureScript.AST import Language.PureScript.AST.Utils -import qualified Language.PureScript.Constants.Data.Generic.Rep as DataGenericRep -import qualified Language.PureScript.Constants.Data.Newtype as DataNewtype +import qualified Language.PureScript.Constants.Libs as Libs import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors @@ -59,8 +58,8 @@ deriveInstance mn ds decl = _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 in case className of - DataNewtype.Newtype -> binaryWildcardClass deriveNewtype - DataGenericRep.Generic -> binaryWildcardClass (deriveGenericRep ss mn) + Libs.Generic -> binaryWildcardClass (deriveGenericRep ss mn) + Libs.Newtype -> binaryWildcardClass deriveNewtype _ -> pure decl _ -> pure decl @@ -84,13 +83,13 @@ deriveGenericRep ss mn tyCon tyConArgs = lamCase x [ CaseAlternative [NullBinder] - (unguarded (App (Var ss DataGenericRep.to) (Var ss' (Qualified ByNullSourcePos x)))) + (unguarded (App (Var ss Libs.I_to) (Var ss' (Qualified ByNullSourcePos x)))) ] , ValueDecl (ss', []) (Ident "from") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] - (unguarded (App (Var ss DataGenericRep.from) (Var ss' (Qualified ByNullSourcePos x)))) + (unguarded (App (Var ss Libs.I_from) (Var ss' (Qualified ByNullSourcePos x)))) ] ] | otherwise = @@ -112,12 +111,12 @@ deriveGenericRep ss mn tyCon tyConArgs = select l r n = take (n - 1) (iterate (r .) l) ++ [compN (n - 1) r] sumBinders :: Int -> [Binder -> Binder] - sumBinders = select (ConstructorBinder ss DataGenericRep.Inl . pure) - (ConstructorBinder ss DataGenericRep.Inr . pure) + sumBinders = select (ConstructorBinder ss Libs.C_Inl . pure) + (ConstructorBinder ss Libs.C_Inr . pure) sumExprs :: Int -> [Expr -> Expr] - sumExprs = select (App (Constructor ss DataGenericRep.Inl)) - (App (Constructor ss DataGenericRep.Inr)) + sumExprs = select (App (Constructor ss Libs.C_Inl)) + (App (Constructor ss Libs.C_Inr)) compN :: Int -> (a -> a) -> a -> a compN 0 _ = id @@ -129,37 +128,37 @@ deriveGenericRep ss mn tyCon tyConArgs = makeInst (DataConstructorDeclaration _ ctorName args) = do let args' = map snd args (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args' - return ( srcTypeApp (srcTypeApp (srcTypeConstructor DataGenericRep.Constructor) + return ( srcTypeApp (srcTypeApp (srcTypeConstructor Libs.Constructor) (srcTypeLevelString $ mkString (runProperName ctorName))) ctorTy - , CaseAlternative [ ConstructorBinder ss DataGenericRep.Constructor [matchProduct] ] + , CaseAlternative [ ConstructorBinder ss Libs.C_Constructor [matchProduct] ] (unguarded (foldl' App (Constructor ss (Qualified (ByModuleName mn) ctorName)) ctorArgs)) , CaseAlternative [ ConstructorBinder ss (Qualified (ByModuleName mn) ctorName) matchCtor ] - (unguarded (App (Constructor ss DataGenericRep.Constructor) mkProduct)) + (unguarded (App (Constructor ss Libs.C_Constructor) mkProduct)) ) makeProduct :: [SourceType] -> m (SourceType, Binder, [Expr], [Binder], Expr) makeProduct [] = - pure (srcTypeConstructor DataGenericRep.NoArguments, NullBinder, [], [], Constructor ss DataGenericRep.NoArguments) + pure (srcTypeConstructor Libs.NoArguments, NullBinder, [], [], Constructor ss Libs.C_NoArguments) makeProduct args = do (tys, bs1, es1, bs2, es2) <- unzip5 <$> traverse makeArg args - pure ( foldr1 (\f -> srcTypeApp (srcTypeApp (srcTypeConstructor DataGenericRep.Product) f)) tys - , foldr1 (\b1 b2 -> ConstructorBinder ss DataGenericRep.Product [b1, b2]) bs1 + pure ( foldr1 (\f -> srcTypeApp (srcTypeApp (srcTypeConstructor Libs.Product) f)) tys + , foldr1 (\b1 b2 -> ConstructorBinder ss Libs.C_Product [b1, b2]) bs1 , es1 , bs2 - , foldr1 (\e1 -> App (App (Constructor ss DataGenericRep.Product) e1)) es2 + , foldr1 (\e1 -> App (App (Constructor ss Libs.C_Product) e1)) es2 ) makeArg :: SourceType -> m (SourceType, Binder, Expr, Binder, Expr) makeArg arg = do argName <- freshIdent "arg" - pure ( srcTypeApp (srcTypeConstructor DataGenericRep.Argument) arg - , ConstructorBinder ss DataGenericRep.Argument [ VarBinder ss argName ] + pure ( srcTypeApp (srcTypeConstructor Libs.Argument) arg + , ConstructorBinder ss Libs.C_Argument [ VarBinder ss argName ] , Var ss (Qualified (BySourcePos $ spanStart ss) argName) , VarBinder ss argName - , App (Constructor ss DataGenericRep.Argument) (Var ss (Qualified (BySourcePos $ spanStart ss) argName)) + , App (Constructor ss Libs.C_Argument) (Var ss (Qualified (BySourcePos $ spanStart ss) argName)) ) underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative @@ -170,9 +169,9 @@ deriveGenericRep ss mn tyCon tyConArgs = underExpr _ _ = internalError "underExpr: expected unguarded alternative" toRepTy :: [SourceType] -> SourceType - toRepTy [] = srcTypeConstructor DataGenericRep.NoConstructors + toRepTy [] = srcTypeConstructor Libs.NoConstructors toRepTy [only] = only - toRepTy ctors = foldr1 (\f -> srcTypeApp (srcTypeApp (srcTypeConstructor DataGenericRep.Sum) f)) ctors + toRepTy ctors = foldr1 (\f -> srcTypeApp (srcTypeApp (srcTypeConstructor Libs.Sum) f)) ctors checkIsWildcard :: MonadError MultipleErrors m => SourceSpan -> ProperName 'TypeName -> SourceType -> m () checkIsWildcard _ _ (TypeWildcard _ UnnamedWildcard) = return () diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index ba8cfd3543..e08be7b998 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -29,8 +29,7 @@ import qualified Data.Text as T import Language.PureScript.AST import Language.PureScript.AST.Declarations.ChainId (ChainId) -import qualified Language.PureScript.Constants.Data.Generic.Rep as DataGenericRep -import qualified Language.PureScript.Constants.Data.Newtype as DataNewtype +import qualified Language.PureScript.Constants.Libs as Libs import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors @@ -789,8 +788,8 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = checkDataConstructorsAreExported :: DeclarationRef -> m () checkDataConstructorsAreExported dr@(TypeRef ss' name (fromMaybe [] -> exportedDataConstructorsNames)) | null exportedDataConstructorsNames = for_ - [ DataGenericRep.Generic - , DataNewtype.Newtype + [ Libs.Generic + , Libs.Newtype ] $ \className -> do env <- getEnv let dicts = foldMap (foldMap NEL.toList) $ diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index ca45877223..48d8566416 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -14,9 +14,7 @@ import qualified Data.Map as M import Control.Monad.Supply.Class import Language.PureScript.AST import Language.PureScript.AST.Utils -import qualified Language.PureScript.Constants.Data.Foldable as Foldable -import qualified Language.PureScript.Constants.Data.Traversable as Traversable -import qualified Language.PureScript.Constants.Prelude as Prelude +import qualified Language.PureScript.Constants.Libs as Libs import qualified Language.PureScript.Constants.Prim as Prim import Language.PureScript.Crash import Language.PureScript.Environment @@ -78,13 +76,13 @@ deriveInstance instType className strategy = do unaryClass' f = unaryClass (f className) in case className of - Foldable.Foldable -> unaryClass' deriveFoldable - Prelude.Eq -> unaryClass deriveEq - Prelude.Eq1 -> unaryClass $ \_ _ -> deriveEq1 - Prelude.Functor -> unaryClass' deriveFunctor - Prelude.Ord -> unaryClass deriveOrd - Prelude.Ord1 -> unaryClass $ \_ _ -> deriveOrd1 - Traversable.Traversable -> unaryClass' deriveTraversable + Libs.Eq -> unaryClass deriveEq + Libs.Eq1 -> unaryClass $ \_ _ -> deriveEq1 + Libs.Foldable -> unaryClass' deriveFoldable + Libs.Functor -> unaryClass' deriveFunctor + Libs.Ord -> unaryClass deriveOrd + Libs.Ord1 -> unaryClass $ \_ _ -> deriveOrd1 + Libs.Traversable -> unaryClass' deriveTraversable -- See L.P.Sugar.TypeClasses.Deriving for the classes that can be -- derived prior to type checking. _ -> throwError . errorMessage $ CannotDerive className tys @@ -194,7 +192,7 @@ deriveEq deriveEq mn tyConNm = do (_, _, _, ctors) <- lookupTypeDecl mn tyConNm eqFun <- mkEqFunction ctors - pure [(Prelude.eq, eqFun)] + pure [(Libs.S_eq, eqFun)] where mkEqFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr mkEqFunction ctors = do @@ -203,13 +201,13 @@ deriveEq mn tyConNm = do lamCase2 x y . addCatch <$> mapM mkCtorClause ctors preludeConj :: Expr -> Expr -> Expr - preludeConj = App . App (mkVarMn (Just (ModuleName "Data.HeytingAlgebra")) (Ident Prelude.conj)) + preludeConj = App . App (mkRef Libs.I_conj) preludeEq :: Expr -> Expr -> Expr - preludeEq = App . App (mkRef Prelude.identEq) + preludeEq = App . App (mkRef Libs.I_eq) preludeEq1 :: Expr -> Expr -> Expr - preludeEq1 = App . App (mkRef Prelude.identEq1) + preludeEq1 = App . App (mkRef Libs.I_eq1) addCatch :: [CaseAlternative] -> [CaseAlternative] addCatch xs @@ -243,7 +241,7 @@ deriveEq mn tyConNm = do | otherwise = preludeEq l r deriveEq1 :: forall m. Applicative m => m [(PSString, Expr)] -deriveEq1 = pure [(Prelude.eq1, mkRef Prelude.identEq)] +deriveEq1 = pure [(Libs.S_eq1, mkRef Libs.I_eq)] deriveOrd :: forall m @@ -256,7 +254,7 @@ deriveOrd deriveOrd mn tyConNm = do (_, _, _, ctors) <- lookupTypeDecl mn tyConNm compareFun <- mkCompareFunction ctors - pure [(Prelude.compare, compareFun)] + pure [(Libs.S_compare, compareFun)] where mkCompareFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr mkCompareFunction ctors = do @@ -286,10 +284,10 @@ deriveOrd mn tyConNm = do orderingBinder name = mkCtorBinder orderingMod (ProperName name) [] ordCompare :: Expr -> Expr -> Expr - ordCompare = App . App (mkRef Prelude.identCompare) + ordCompare = App . App (mkRef Libs.I_compare) ordCompare1 :: Expr -> Expr -> Expr - ordCompare1 = App . App (mkRef Prelude.identCompare1) + ordCompare1 = App . App (mkRef Libs.I_compare1) mkCtorClauses :: ((ProperName 'ConstructorName, [SourceType]), Bool) -> m [CaseAlternative] mkCtorClauses ((ctorName, tys), isLast) = do @@ -330,7 +328,7 @@ deriveOrd mn tyConNm = do | otherwise = ordCompare l r deriveOrd1 :: forall m. Applicative m => m [(PSString, Expr)] -deriveOrd1 = pure [(Prelude.compare1, mkRef Prelude.identCompare)] +deriveOrd1 = pure [(Libs.S_compare1, mkRef Libs.I_compare)] lookupTypeDecl :: forall m @@ -493,9 +491,9 @@ deriveFunctor deriveFunctor nm mn tyConNm = do ctors <- validateParamsInTypeConstructors nm mn tyConNm mapFun <- mkTraversal mn mapVar (TraversalOps identity identity) ctors - pure [(Prelude.map, mapFun)] + pure [(Libs.S_map, mapFun)] where - mapVar = mkRef Prelude.identMap + mapVar = mkRef Libs.I_map toConst :: forall f a b. f a -> Const [f a] b toConst = Const . pure @@ -520,12 +518,12 @@ deriveFoldable nm mn tyConNm = do foldlFun <- mkAsymmetricFoldFunction False foldlVar ctors foldrFun <- mkAsymmetricFoldFunction True foldrVar ctors foldMapFun <- mkTraversal mn foldMapVar foldMapOps ctors - pure [(Foldable.foldl, foldlFun), (Foldable.foldr, foldrFun), (Foldable.foldMap, foldMapFun)] + pure [(Libs.S_foldl, foldlFun), (Libs.S_foldr, foldrFun), (Libs.S_foldMap, foldMapFun)] where - foldlVar = mkRef Foldable.identFoldl - foldrVar = mkRef Foldable.identFoldr - foldMapVar = mkRef Foldable.identFoldMap - flipVar = mkRef Prelude.identFlip + foldlVar = mkRef Libs.I_foldl + foldrVar = mkRef Libs.I_foldr + foldMapVar = mkRef Libs.I_foldMap + flipVar = mkRef Libs.I_flip mkAsymmetricFoldFunction :: Bool -> Expr -> [(ProperName 'ConstructorName, [Maybe ParamUsage])] -> m Expr mkAsymmetricFoldFunction isRightFold recurseVar ctors = do @@ -563,8 +561,8 @@ deriveFoldable nm mn tyConNm = do foldMapOps :: forall m. Applicative m => TraversalOps m foldMapOps = TraversalOps { visitExpr = toConst, .. } where - appendVar = mkRef Prelude.identAppend - memptyVar = mkRef Prelude.identMempty + appendVar = mkRef Libs.I_append + memptyVar = mkRef Libs.I_mempty extractExpr :: Const [m Expr] Expr -> m Expr extractExpr = consumeConst $ \case @@ -584,17 +582,17 @@ deriveTraversable nm mn tyConNm = do ctors <- validateParamsInTypeConstructors nm mn tyConNm traverseFun <- mkTraversal mn traverseVar traverseOps ctors sequenceFun <- usingLamIdent $ pure . App (App traverseVar identityVar) - pure [(Traversable.traverse, traverseFun), (Traversable.sequence, sequenceFun)] + pure [(Libs.S_traverse, traverseFun), (Libs.S_sequence, sequenceFun)] where - traverseVar = mkRef Traversable.identTraverse - identityVar = mkRef Prelude.identIdentity + traverseVar = mkRef Libs.I_traverse + identityVar = mkRef Libs.I_identity traverseOps :: forall m. MonadSupply m => TraversalOps m traverseOps = TraversalOps { .. } where - pureVar = mkRef Prelude.identPure - mapVar = mkRef Prelude.identMap - applyVar = mkRef Prelude.identApply + pureVar = mkRef Libs.I_pure + mapVar = mkRef Libs.I_map + applyVar = mkRef Libs.I_apply visitExpr :: m Expr -> WriterT [(Ident, m Expr)] m Expr visitExpr traversedExpr = do diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index b7d774d4ef..381f83fc0c 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -47,7 +47,7 @@ import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types import Language.PureScript.Label (Label(..)) import Language.PureScript.PSString (PSString, mkString, decodeString) -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C import qualified Language.PureScript.Constants.Prim as C -- | Describes what sort of dictionary to generate for type class instances @@ -77,9 +77,9 @@ asExpression = \case ReflectableString s -> Literal NullSourceSpan $ StringLiteral s ReflectableBoolean b -> Literal NullSourceSpan $ BooleanLiteral b ReflectableOrdering o -> Constructor NullSourceSpan $ case o of - LT -> C.LT - EQ -> C.EQ - GT -> C.GT + LT -> C.C_LT + EQ -> C.C_EQ + GT -> C.C_GT -- | Extract the identifier of a named instance namedInstanceIdentifier :: Evidence -> Maybe (Qualified Ident) @@ -228,7 +228,7 @@ entails SolverOptions{..} constraint context hints = findDicts ctx cn = fmap (fmap NamedInstance) . foldMap NEL.toList . foldMap M.elems . (M.lookup cn <=< flip M.lookup ctx) valUndefined :: Expr - valUndefined = Var nullSourceSpan (Qualified (ByModuleName C.Prim) (Ident C.undefined)) + valUndefined = Var nullSourceSpan C.I_undefined solve :: SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr solve = go 0 hints @@ -460,9 +460,9 @@ entails SolverOptions{..} constraint context hints = solveSymbolCompare :: [SourceType] -> Maybe [TypeClassDict] solveSymbolCompare [arg0@(TypeLevelString _ lhs), arg1@(TypeLevelString _ rhs), _] = let ordering = case compare lhs rhs of - LT -> C.orderingLT - EQ -> C.orderingEQ - GT -> C.orderingGT + LT -> C.LT + EQ -> C.EQ + GT -> C.GT args' = [arg0, arg1, srcTypeConstructor ordering] in Just [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolCompare [] [] args' Nothing Nothing] solveSymbolCompare _ = Nothing @@ -526,11 +526,11 @@ entails SolverOptions{..} constraint context hints = TypeLevelInt _ i -> pure (ReflectableInt i, tyInt) TypeLevelString _ s -> pure (ReflectableString s, tyString) TypeConstructor _ n - | n == C.booleanTrue -> pure (ReflectableBoolean True, tyBoolean) - | n == C.booleanFalse -> pure (ReflectableBoolean False, tyBoolean) - | n == C.orderingLT -> pure (ReflectableOrdering LT, srcTypeConstructor C.Ordering) - | n == C.orderingEQ -> pure (ReflectableOrdering EQ, srcTypeConstructor C.Ordering) - | n == C.orderingGT -> pure (ReflectableOrdering GT, srcTypeConstructor C.Ordering) + | n == C.True -> pure (ReflectableBoolean True, tyBoolean) + | n == C.False -> pure (ReflectableBoolean False, tyBoolean) + | n == C.LT -> pure (ReflectableOrdering LT, srcTypeConstructor C.Ordering) + | n == C.EQ -> pure (ReflectableOrdering EQ, srcTypeConstructor C.Ordering) + | n == C.GT -> pure (ReflectableOrdering GT, srcTypeConstructor C.Ordering) _ -> Nothing pure [TypeClassDictionaryInScope Nothing 0 (ReflectableInstance ref) [] C.Reflectable [] [] [typeLevel, typ] Nothing Nothing] solveReflectable _ = Nothing @@ -554,9 +554,9 @@ entails SolverOptions{..} constraint context hints = solveIntCompare :: InstanceContext -> [SourceType] -> Maybe [TypeClassDict] solveIntCompare _ [arg0@(TypeLevelInt _ a), arg1@(TypeLevelInt _ b), _] = let ordering = case compare a b of - EQ -> C.orderingEQ - LT -> C.orderingLT - GT -> C.orderingGT + EQ -> C.EQ + LT -> C.LT + GT -> C.GT args' = [arg0, arg1, srcTypeConstructor ordering] in pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.IntCompare [] [] args' Nothing Nothing] solveIntCompare ctx args@[a, b, _] = do diff --git a/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs b/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs index 50f2205ffb..fb21d989b4 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs @@ -46,18 +46,18 @@ type PSOrdering = P.Qualified (P.ProperName 'P.TypeName) solveRelation :: forall a. Ord a => Context a -> a -> a -> Maybe PSOrdering solveRelation context lhs rhs = if lhs == rhs then - pure P.orderingEQ + pure P.EQ else do let (graph, search) = inequalities lhs' <- search lhs rhs' <- search rhs case (G.path graph lhs' rhs', G.path graph rhs' lhs') of (True, True) -> - pure P.orderingEQ + pure P.EQ (True, False) -> - pure P.orderingLT + pure P.LT (False, True) -> - pure P.orderingGT + pure P.GT _ -> Nothing where @@ -79,9 +79,9 @@ solveRelation context lhs rhs = mkRelation :: P.Type a -> P.Type a -> P.Type a -> Maybe (Relation (P.Type a)) mkRelation lhs rhs rel = case rel of P.TypeConstructor _ ordering - | ordering == P.orderingEQ -> pure $ Equal lhs rhs - | ordering == P.orderingLT -> pure $ LessThan lhs rhs - | ordering == P.orderingGT -> pure $ LessThan rhs lhs + | ordering == P.EQ -> pure $ Equal lhs rhs + | ordering == P.LT -> pure $ LessThan lhs rhs + | ordering == P.GT -> pure $ LessThan rhs lhs _ -> Nothing diff --git a/weeder.dhall b/weeder.dhall index b681fde085..95686c45e8 100644 --- a/weeder.dhall +++ b/weeder.dhall @@ -21,6 +21,13 @@ , "^Language\\.PureScript\\.Ide\\.Imports\\.parseImport$" , "^Language\\.PureScript\\.TypeChecker\\.Monad\\.debug" + -- These declarations are used by Template Haskell code. + , "^Language\\.PureScript\\.Constants\\.TH\\." + + -- These declarations are produced by Template Haskell when generating + -- pattern synonyms; this confuses Weeder. + , "^Language\\.PureScript\\.Constants\\..*\\.\\$[bm]" + -- These declarations are unprincipled exceptions that we don't mind -- supporting just in case they're used now or in the future. , "^Language\\.PureScript\\.CST\\.Parser\\.parseExpr$" From ae25710acc27498d7382da675d17493e2250b2c9 Mon Sep 17 00:00:00 2001 From: Mark Eibes Date: Mon, 21 Nov 2022 02:45:32 +0100 Subject: [PATCH 1519/1580] Shorten error prefix of custom errors (#4418) --- CHANGELOG.d/feature_shorten-error-message.md | 3 +++ src/Language/PureScript/Errors.hs | 2 +- tests/purs/failing/2567.out | 2 +- .../failing/ProgrammablePolykindedTypeErrorsTypeString.out | 2 +- tests/purs/failing/ProgrammableTypeErrors.out | 2 +- tests/purs/failing/ProgrammableTypeErrorsTypeString.out | 2 +- 6 files changed, 8 insertions(+), 5 deletions(-) create mode 100644 CHANGELOG.d/feature_shorten-error-message.md diff --git a/CHANGELOG.d/feature_shorten-error-message.md b/CHANGELOG.d/feature_shorten-error-message.md new file mode 100644 index 0000000000..45697cdc2f --- /dev/null +++ b/CHANGELOG.d/feature_shorten-error-message.md @@ -0,0 +1,3 @@ +* Shorten the prefix for custom user defined error + messages to improve clarity and get to the relevant information + more quickly diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 60228d3aa5..283ac58910 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -883,7 +883,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon , line "because the class was not in scope. Perhaps it was not exported." ] renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Fail _ [ ty ] _) _ _) | Just box <- toTypelevelString ty = - paras [ line "A custom type error occurred while solving type class constraints:" + paras [ line "Custom error:" , indent box ] renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Partial diff --git a/tests/purs/failing/2567.out b/tests/purs/failing/2567.out index 04258502a7..76c6520f82 100644 --- a/tests/purs/failing/2567.out +++ b/tests/purs/failing/2567.out @@ -2,7 +2,7 @@ Error found: in module Main at tests/purs/failing/2567.purs:7:8 - 7:67 (line 7, column 8 - line 7, column 67) - A custom type error occurred while solving type class constraints: + Custom error: This constraint should be checked diff --git a/tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.out b/tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.out index 4968c73575..e938446ba6 100644 --- a/tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.out +++ b/tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.out @@ -2,7 +2,7 @@ Error found: in module Main at tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.purs:23:7 - 23:17 (line 23, column 7 - line 23, column 17) - A custom type error occurred while solving type class constraints: + Custom error: Don't want to show Just @Type String because. diff --git a/tests/purs/failing/ProgrammableTypeErrors.out b/tests/purs/failing/ProgrammableTypeErrors.out index 7e0069e7cc..3c48205c4c 100644 --- a/tests/purs/failing/ProgrammableTypeErrors.out +++ b/tests/purs/failing/ProgrammableTypeErrors.out @@ -2,7 +2,7 @@ Error found: in module Main at tests/purs/failing/ProgrammableTypeErrors.purs:17:13 - 17:27 (line 17, column 13 - line 17, column 27) - A custom type error occurred while solving type class constraints: + Custom error: Cannot show functions diff --git a/tests/purs/failing/ProgrammableTypeErrorsTypeString.out b/tests/purs/failing/ProgrammableTypeErrorsTypeString.out index d9c33ca38c..bb5045ce43 100644 --- a/tests/purs/failing/ProgrammableTypeErrorsTypeString.out +++ b/tests/purs/failing/ProgrammableTypeErrorsTypeString.out @@ -2,7 +2,7 @@ Error found: in module Main at tests/purs/failing/ProgrammableTypeErrorsTypeString.purs:24:9 - 24:24 (line 24, column 9 - line 24, column 24) - A custom type error occurred while solving type class constraints: + Custom error: Don't want to show MyType Int because. From 3e19a7c2d12bcd6a455e43a9865d10e382274eb4 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sun, 4 Dec 2022 21:20:21 -0500 Subject: [PATCH 1520/1580] Derive Bi*, Contravariant, and Profunctor (#4420) The compiler can now derive instances of `Bifunctor`, `Bifoldable`, `Bitraversable`, `Contravariant`, and `Profunctor`, as well as use those classes when deriving `Functor`, `Foldable`, and `Traversable`, enabling more instances to be derived. --- CHANGELOG.d/feature_derive-traversable-2.md | 4 + src/Language/PureScript/Constants/Libs.hs | 33 +- src/Language/PureScript/Errors.hs | 15 +- .../PureScript/TypeChecker/Deriving.hs | 345 ++++++++++++++---- .../PureScript/TypeChecker/Entailment.hs | 7 +- tests/purs/failing/BifunctorInstance1.out | 16 + tests/purs/failing/BifunctorInstance1.purs | 10 + tests/purs/failing/ContravariantInstance1.out | 16 + .../purs/failing/ContravariantInstance1.purs | 9 + tests/purs/failing/FoldableInstance10.out | 2 +- tests/purs/failing/FoldableInstance4.out | 21 +- tests/purs/failing/FoldableInstance4.purs | 2 +- tests/purs/failing/FoldableInstance5.out | 16 - tests/purs/failing/FoldableInstance5.purs | 9 - tests/purs/failing/FoldableInstance6.out | 2 +- tests/purs/failing/FoldableInstance7.out | 16 - tests/purs/failing/FoldableInstance7.purs | 9 - tests/purs/failing/FoldableInstance8.out | 4 +- tests/purs/failing/FoldableInstance9.out | 18 +- tests/purs/failing/FunctorInstance1.out | 16 + tests/purs/failing/FunctorInstance1.purs | 8 + tests/purs/passing/DerivingBifunctor.purs | 26 ++ tests/purs/passing/DerivingContravariant.purs | 20 + tests/purs/passing/DerivingFunctorFromBi.purs | 18 + .../passing/DerivingFunctorFromContra.purs | 13 + .../purs/passing/DerivingFunctorFromPro.purs | 16 + .../DerivingFunctorPrefersSimplerClasses.purs | 46 +++ tests/purs/passing/DerivingProfunctor.purs | 19 + 28 files changed, 586 insertions(+), 150 deletions(-) create mode 100644 CHANGELOG.d/feature_derive-traversable-2.md create mode 100644 tests/purs/failing/BifunctorInstance1.out create mode 100644 tests/purs/failing/BifunctorInstance1.purs create mode 100644 tests/purs/failing/ContravariantInstance1.out create mode 100644 tests/purs/failing/ContravariantInstance1.purs delete mode 100644 tests/purs/failing/FoldableInstance5.out delete mode 100644 tests/purs/failing/FoldableInstance5.purs delete mode 100644 tests/purs/failing/FoldableInstance7.out delete mode 100644 tests/purs/failing/FoldableInstance7.purs create mode 100644 tests/purs/failing/FunctorInstance1.out create mode 100644 tests/purs/failing/FunctorInstance1.purs create mode 100644 tests/purs/passing/DerivingBifunctor.purs create mode 100644 tests/purs/passing/DerivingContravariant.purs create mode 100644 tests/purs/passing/DerivingFunctorFromBi.purs create mode 100644 tests/purs/passing/DerivingFunctorFromContra.purs create mode 100644 tests/purs/passing/DerivingFunctorFromPro.purs create mode 100644 tests/purs/passing/DerivingFunctorPrefersSimplerClasses.purs create mode 100644 tests/purs/passing/DerivingProfunctor.purs diff --git a/CHANGELOG.d/feature_derive-traversable-2.md b/CHANGELOG.d/feature_derive-traversable-2.md new file mode 100644 index 0000000000..03d755aac2 --- /dev/null +++ b/CHANGELOG.d/feature_derive-traversable-2.md @@ -0,0 +1,4 @@ +* The compiler can now derive instances of `Bifunctor`, `Bifoldable`, + `Bitraversable`, `Contravariant`, and `Profunctor`, as well as use those + classes when deriving `Functor`, `Foldable`, and `Traversable`, enabling more + instances to be derived. diff --git a/src/Language/PureScript/Constants/Libs.hs b/src/Language/PureScript/Constants/Libs.hs index 112a75ccb8..3ec062a7d9 100644 --- a/src/Language/PureScript/Constants/Libs.hs +++ b/src/Language/PureScript/Constants/Libs.hs @@ -104,8 +104,10 @@ $(TH.declare do TH.var "euclideanRingNumber" TH.mod "Data.Function" do - TH.prefixWith "function" do TH.asIdent do TH.vars ["apply", "applyFlipped"] - TH.asIdent do TH.var "flip" + TH.asIdent do + TH.prefixWith "function" do TH.vars ["apply", "applyFlipped"] + TH.var "const" + TH.var "flip" TH.mod "Data.Functor" do TH.cls "Functor" ; TH.asIdent do TH.asString do TH.var "map" @@ -170,6 +172,17 @@ $(TH.declare do TH.mod "Data.Array" do TH.asPair do TH.var "unsafeIndex" + -- purescript-bifunctors + + TH.mod "Data.Bifunctor" do + TH.cls "Bifunctor" ; TH.asIdent do TH.asString do TH.var "bimap" + TH.asIdent do TH.vars ["lmap", "rmap"] + + -- purescript-contravariant + + TH.mod "Data.Functor.Contravariant" do + TH.cls "Contravariant" ; TH.asIdent do TH.asString do TH.var "cmap" + -- purescript-eff TH.mod "Control.Monad.Eff" (P.pure ()) @@ -186,6 +199,14 @@ $(TH.declare do -- purescript-foldable-traversable + TH.mod "Data.Bifoldable" do + TH.cls "Bifoldable" ; TH.asIdent do TH.asString do TH.vars ["bifoldMap", "bifoldl", "bifoldr"] + + TH.mod "Data.Bitraversable" do + TH.cls "Bitraversable" ; TH.asString do TH.asIdent (TH.var "bitraverse"); TH.var "bisequence" + TH.asIdent do + TH.vars ["ltraverse", "rtraverse"] + TH.mod "Data.Foldable" do TH.cls "Foldable" ; TH.asIdent do TH.asString do TH.vars ["foldMap", "foldl", "foldr"] @@ -219,6 +240,14 @@ $(TH.declare do TH.mod "Partial.Unsafe" do TH.asIdent do TH.asPair do TH.var "unsafePartial" + -- purescript-profunctor + + TH.mod "Data.Profunctor" do + TH.cls "Profunctor" ; TH.asIdent do TH.asString do TH.var "dimap" + TH.asIdent do + TH.var "lcmap" + TH.prefixWith "profunctor" do TH.var "rmap" + -- purescript-st TH.mod "Control.Monad.ST.Internal" do diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 283ac58910..3302625670 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -4,6 +4,7 @@ module Language.PureScript.Errors ) where import Prelude +import Protolude (unsnoc) import Control.Arrow ((&&&)) import Control.Exception (displayException) @@ -194,7 +195,7 @@ data SimpleErrorMessage | UnsupportedRoleDeclaration | RoleDeclarationArityMismatch (ProperName 'TypeName) Int Int | DuplicateRoleDeclaration (ProperName 'TypeName) - | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) + | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) [Qualified (ProperName 'ClassName)] Bool deriving (Show) data ErrorMessage = ErrorMessage @@ -587,6 +588,13 @@ colorCodeBox codeColor b = case codeColor of , Box.vcat Box.top $ replicate (Box.rows b) $ Box.text ansiColorReset ] +commasAndConjunction :: Text -> [Text] -> Text +commasAndConjunction conj = \case + [x] -> x + [x, y] -> x <> " " <> conj <> " " <> y + (unsnoc -> Just (rest, z)) -> foldMap (<> ", ") rest <> conj <> " " <> z + _ -> "" + -- | Default color intensity and color for code defaultCodeColor :: (ANSI.ColorIntensity, ANSI.Color) defaultCodeColor = (ANSI.Dull, ANSI.Yellow) @@ -1378,11 +1386,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon renderSimpleErrorMessage (DuplicateRoleDeclaration name) = line $ "Duplicate role declaration for " <> markCode (runProperName name) <> "." - renderSimpleErrorMessage (CannotDeriveInvalidConstructorArg className) = + renderSimpleErrorMessage (CannotDeriveInvalidConstructorArg className relatedClasses checkVariance) = paras [ line $ "One or more type variables are in positions that prevent " <> markCode (runProperName $ disqualify className) <> " from being derived." , line $ "To derive this class, make sure that these variables are only used as the final arguments to type constructors, " - <> "and that those type constructors themselves have instances of " <> markCode (runProperName $ disqualify className) <> "." + <> (if checkVariance then "that their variance matches the variance of " <> markCode (runProperName $ disqualify className) <> ", " else "") + <> "and that those type constructors themselves have instances of " <> commasAndConjunction "or" (markCode . showQualified runProperName <$> relatedClasses) <> "." ] renderHint :: ErrorMessageHint -> Box.Box -> Box.Box diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index 48d8566416..6c31cddcb6 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -5,11 +5,15 @@ module Language.PureScript.TypeChecker.Deriving (deriveInstance) where import Protolude hiding (Type) +import Control.Lens (both, over) +import Control.Monad.Error.Class (liftEither) import Control.Monad.Trans.Writer (Writer, WriterT, runWriter, runWriterT) import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Align (align, unalign) import Data.Foldable (foldl1, foldr1) import Data.List (init, last, zipWith3, (!!)) import qualified Data.Map as M +import Data.These (These(..), mergeTheseWith, these) import Control.Monad.Supply.Class import Language.PureScript.AST @@ -23,6 +27,7 @@ import Language.PureScript.Label (Label(..)) import Language.PureScript.Names import Language.PureScript.PSString import Language.PureScript.Sugar.TypeClasses +import Language.PureScript.TypeChecker.Entailment import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.TypeClassDictionaries @@ -76,13 +81,18 @@ deriveInstance instType className strategy = do unaryClass' f = unaryClass (f className) in case className of + Libs.Bifoldable -> unaryClass' $ deriveFoldable True + Libs.Bifunctor -> unaryClass' $ deriveFunctor (Just False) False Libs.S_bimap + Libs.Bitraversable -> unaryClass' $ deriveTraversable True + Libs.Contravariant -> unaryClass' $ deriveFunctor Nothing True Libs.S_cmap Libs.Eq -> unaryClass deriveEq Libs.Eq1 -> unaryClass $ \_ _ -> deriveEq1 - Libs.Foldable -> unaryClass' deriveFoldable - Libs.Functor -> unaryClass' deriveFunctor + Libs.Foldable -> unaryClass' $ deriveFoldable False + Libs.Functor -> unaryClass' $ deriveFunctor Nothing False Libs.S_map Libs.Ord -> unaryClass deriveOrd Libs.Ord1 -> unaryClass $ \_ _ -> deriveOrd1 - Libs.Traversable -> unaryClass' deriveTraversable + Libs.Profunctor -> unaryClass' $ deriveFunctor (Just True) False Libs.S_dimap + Libs.Traversable -> unaryClass' $ deriveTraversable False -- See L.P.Sugar.TypeClasses.Deriving for the classes that can be -- derived prior to type checking. _ -> throwError . errorMessage $ CannotDerive className tys @@ -367,78 +377,183 @@ decomposeRec' = sortOn fst . go where go (RCons _ str typ typs) = (str, typ) : go typs go _ = [] -data ParamUsage +-- | The parameter `c` is used to allow or forbid contravariance for different +-- type classes. When deriving a type class that is a variation on Functor, a +-- witness for `c` will be provided; when deriving a type class that is a +-- variation on Foldable or Traversable, `c` will be Void and the contravariant +-- ParamUsage constructor can be skipped in pattern matching. +data ParamUsage c = IsParam - | MentionsParam ParamUsage - | IsRecord (NonEmpty (PSString, ParamUsage)) + | IsLParam + -- ^ enables biparametric classes (of any variance) to be derived + | MentionsParam (ParamUsage c) + -- ^ enables monoparametric classes to be used in a derivation + | MentionsParamBi (These (ParamUsage c) (ParamUsage c)) + -- ^ enables biparametric classes to be used in a derivation + | MentionsParamContravariantly !c (ContravariantParamUsage c) + -- ^ enables contravariant classes (of either parametricity) to be used in a derivation + | IsRecord (NonEmpty (PSString, ParamUsage c)) + +data ContravariantParamUsage c + = MentionsParamContra (ParamUsage c) + -- ^ enables Contravariant to be used in a derivation + | MentionsParamPro (These (ParamUsage c) (ParamUsage c)) + -- ^ enables Profunctor to be used in a derivation + +data CovariantClasses = CovariantClasses + { monoClass :: Qualified (ProperName 'ClassName) + , biClass :: Qualified (ProperName 'ClassName) + } + +data ContravariantClasses = ContravariantClasses + { contraClass :: Qualified (ProperName 'ClassName) + , proClass :: Qualified (ProperName 'ClassName) + } + +data ContravarianceSupport c = ContravarianceSupport + { contravarianceWitness :: c + , paramIsContravariant :: Bool + , lparamIsContravariant :: Bool + , contravariantClasses :: ContravariantClasses + } + +-- | Return, if possible, a These the contents of which each satisfy the +-- predicate. +filterThese :: forall a. (a -> Bool) -> These a a -> Maybe (These a a) +filterThese p = uncurry align . over both (mfilter p) . unalign . Just validateParamsInTypeConstructors - :: forall m + :: forall c m . MonadError MultipleErrors m => MonadState CheckState m => Qualified (ProperName 'ClassName) -> ModuleName -> ProperName 'TypeName - -> m [(ProperName 'ConstructorName, [Maybe ParamUsage])] -validateParamsInTypeConstructors derivingClass mn tyConNm = do + -> Bool + -> CovariantClasses + -> Maybe (ContravarianceSupport c) + -> m [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])] +validateParamsInTypeConstructors derivingClass mn tyConNm isBi CovariantClasses{..} contravarianceSupport = do (_, _, tyArgNames, ctors) <- lookupTypeDecl mn tyConNm - param <- note (errorMessage $ KindsDoNotUnify (kindType -:> kindType) kindType) . lastMay $ map fst tyArgNames + (mbLParam, param) <- liftEither . first (errorMessage . flip KindsDoNotUnify kindType . (kindType -:>)) $ + case (isBi, reverse $ map fst tyArgNames) of + (False, x : _) -> Right (Nothing, x) + (False, _) -> Left kindType + (True, y : x : _) -> Right (Just x, y) + (True, _ : _) -> Left kindType + (True, _) -> Left $ kindType -:> kindType ctors' <- traverse (traverse $ traverse replaceAllTypeSynonyms) ctors - let (ctorUsages, problemSpans) = runWriter $ traverse (traverse . traverse $ typeToUsageOf param) ctors' + tcds <- getTypeClassDictionaries + let (ctorUsages, problemSpans) = runWriter $ traverse (traverse . traverse $ typeToUsageOf tcds (maybe That These mbLParam param) False) ctors' + let relatedClasses = [monoClass, biClass] ++ ([contraClass, proClass] <*> (contravariantClasses <$> toList contravarianceSupport)) for_ (nonEmpty $ ordNub problemSpans) $ \sss -> - throwError . addHint (RelatedPositions sss) . errorMessage $ CannotDeriveInvalidConstructorArg derivingClass + throwError . addHint (RelatedPositions sss) . errorMessage $ CannotDeriveInvalidConstructorArg derivingClass relatedClasses (isJust contravarianceSupport) pure ctorUsages + where - typeToUsageOf :: Text -> SourceType -> Writer [SourceSpan] (Maybe ParamUsage) - typeToUsageOf param = go - where + typeToUsageOf :: InstanceContext -> These Text Text -> Bool -> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c)) + typeToUsageOf tcds = fix $ \go params isNegative -> let + goCo = go params isNegative + goContra = go params $ not isNegative + assertNoParamUsedIn :: SourceType -> Writer [SourceSpan] () - assertNoParamUsedIn = everythingOnTypes (*>) $ \case + assertNoParamUsedIn ty = void $ both (flip assertParamNotUsedIn ty) params + + assertParamNotUsedIn :: Text -> SourceType -> Writer [SourceSpan] () + assertParamNotUsedIn param = everythingOnTypes (*>) $ \case TypeVar (ss, _) name | name == param -> tell [ss] _ -> pure () - go = \case + tryBiClasses ht tyLArg tyArg + | hasInstance tcds ht biClass + = goCo tyLArg >>= preferMonoClass MentionsParamBi + | Just (ContravarianceSupport c _ _ ContravariantClasses{..}) <- contravarianceSupport, hasInstance tcds ht proClass + = goContra tyLArg >>= preferMonoClass (MentionsParamContravariantly c . MentionsParamPro) + | otherwise + = assertNoParamUsedIn tyLArg *> tryMonoClasses ht tyArg + where + preferMonoClass f lUsage = + (if isNothing lUsage && hasInstance tcds ht monoClass then fmap MentionsParam else fmap f . align lUsage) <$> goCo tyArg + + tryMonoClasses ht tyArg + | hasInstance tcds ht monoClass + = fmap MentionsParam <$> goCo tyArg + | Just (ContravarianceSupport c _ _ ContravariantClasses{..}) <- contravarianceSupport, hasInstance tcds ht contraClass + = fmap (MentionsParamContravariantly c . MentionsParamContra) <$> goContra tyArg + | otherwise + = assertNoParamUsedIn tyArg $> Nothing + + in \case ForAll _ name _ ty _ -> - if name == param then pure Nothing else go ty + fmap join . traverse (\params' -> go params' isNegative ty) $ filterThese (/= name) params ConstrainedType _ _ ty -> - go ty + goCo ty TypeApp _ (TypeConstructor _ Prim.Record) row -> fmap (fmap IsRecord . nonEmpty . catMaybes) . for (decomposeRec' row) $ \(Label lbl, ty) -> - fmap (lbl, ) <$> go ty + fmap (lbl, ) <$> goCo ty - TypeApp _ tyFn tyArg -> do - assertNoParamUsedIn tyFn - fmap MentionsParam <$> go tyArg + TypeApp _ (TypeApp _ tyFn tyLArg) tyArg -> + assertNoParamUsedIn tyFn *> tryBiClasses (headOfType tyFn) tyLArg tyArg - TypeVar _ name -> - pure $ (name == param) `orEmpty` IsParam + TypeApp _ tyFn tyArg -> + assertNoParamUsedIn tyFn *> tryMonoClasses (headOfType tyFn) tyArg + + TypeVar (ss, _) name -> mergeTheseWith (checkName lparamIsContra IsLParam) (checkName paramIsContra IsParam) (liftA2 (<|>)) params + where + checkName thisParamIsContra usage param + | name == param = when (thisParamIsContra /= isNegative) (tell [ss]) $> Just usage + | otherwise = pure Nothing ty -> assertNoParamUsedIn ty $> Nothing + paramIsContra = any paramIsContravariant contravarianceSupport + lparamIsContra = any lparamIsContravariant contravarianceSupport + + hasInstance :: InstanceContext -> Qualified (Either Text (ProperName 'TypeName)) -> Qualified (ProperName 'ClassName) -> Bool + hasInstance tcds ht@(Qualified qb _) cn@(Qualified cqb _) = + any tcdAppliesToType $ concatMap (findDicts tcds cn) (ordNub [ByNullSourcePos, cqb, qb]) + where + tcdAppliesToType tcd = case tcdInstanceTypes tcd of + [headOfType -> ht'] -> ht == ht' + -- ^ It's possible that, if ht and ht' are Lefts, this might require + -- verifying that the name isn't shadowed by something in tcdForAll. I + -- can't devise a legal program that causes this issue, but if in the + -- future it seems like a good idea, it probably is. + _ -> False + + headOfType :: SourceType -> Qualified (Either Text (ProperName 'TypeName)) + headOfType = fix $ \go -> \case + TypeApp _ ty _ -> go ty + KindApp _ ty _ -> go ty + TypeVar _ nm -> Qualified ByNullSourcePos (Left nm) + Skolem _ nm _ _ _ -> Qualified ByNullSourcePos (Left nm) + TypeConstructor _ (Qualified qb nm) -> Qualified qb (Right nm) + ty -> internalError $ "headOfType missing a case: " <> show (void ty) + usingLamIdent :: forall m. MonadSupply m => (Expr -> m Expr) -> m Expr usingLamIdent cb = do ident <- freshIdent "v" lam ident <$> cb (mkVar ident) -traverseFields :: forall f. Applicative f => (ParamUsage -> Expr -> f Expr) -> NonEmpty (PSString, ParamUsage) -> Expr -> f Expr +traverseFields :: forall c f. Applicative f => (ParamUsage c -> Expr -> f Expr) -> NonEmpty (PSString, ParamUsage c) -> Expr -> f Expr traverseFields f fields r = fmap (ObjectUpdate r) . for (toList fields) $ \(lbl, usage) -> (lbl, ) <$> f usage (Accessor lbl r) -unnestRecords :: forall f. Applicative f => (ParamUsage -> Expr -> f Expr) -> ParamUsage -> Expr -> f Expr +unnestRecords :: forall c f. Applicative f => (ParamUsage c -> Expr -> f Expr) -> ParamUsage c -> Expr -> f Expr unnestRecords f = fix $ \go -> \case IsRecord fields -> traverseFields go fields usage -> f usage mkCasesForTraversal - :: forall f m + :: forall c f m . Applicative f -- this effect distinguishes the semantics of maps, folds, and traversals => MonadSupply m => ModuleName - -> (ParamUsage -> Expr -> f Expr) -- how to handle constructor arguments + -> (ParamUsage c -> Expr -> f Expr) -- how to handle constructor arguments -> (f Expr -> m Expr) -- resolve the applicative effect into an expression - -> [(ProperName 'ConstructorName, [Maybe ParamUsage])] + -> [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])] -> m Expr mkCasesForTraversal mn handleArg extractExpr ctors = do m <- freshIdent "m" @@ -449,51 +564,107 @@ mkCasesForTraversal mn handleArg extractExpr ctors = do fmap (CaseAlternative [caseBinder] . unguarded) . extractExpr $ fmap (foldl' App ctor) . for ctorArgs $ \(ident, mbUsage) -> maybe pure handleArg mbUsage $ mkVar ident +data TraversalExprs = TraversalExprs + { recurseVar :: Expr -- a var representing map, foldMap, or traverse, for handling structured values + , birecurseVar :: Expr -- same, but bimap, bifoldMap, or bitraverse + , lrecurseExpr :: Expr -- same, but lmap or ltraverse (there is no lfoldMap, but we can use `flip bifoldMap mempty`) + , rrecurseExpr :: Expr -- same, but rmap or rtraverse etc., which conceptually should be the same as recurseVar but the bi classes aren't subclasses of the mono classes + } + +data ContraversalExprs = ContraversalExprs + { crecurseVar :: Expr + , direcurseVar :: Expr + , lcrecurseVar :: Expr + , rprorecurseVar :: Expr + } + +appBirecurseExprs :: TraversalExprs -> These Expr Expr -> Expr +appBirecurseExprs TraversalExprs{..} = these (App lrecurseExpr) (App rrecurseExpr) (App . App birecurseVar) + +appDirecurseExprs :: ContraversalExprs -> These Expr Expr -> Expr +appDirecurseExprs ContraversalExprs{..} = these (App lcrecurseVar) (App rprorecurseVar) (App . App direcurseVar) + data TraversalOps m = forall f. Applicative f => TraversalOps { visitExpr :: m Expr -> f Expr -- lift an expression into the applicative effect defining the traversal , extractExpr :: f Expr -> m Expr -- resolve the applicative effect into an expression } mkTraversal - :: forall m + :: forall c m . MonadSupply m => ModuleName - -> Expr -- a var representing map, foldMap, or traverse, for handling structured values + -> Bool + -> TraversalExprs + -> (c -> ContraversalExprs) -> TraversalOps m - -> [(ProperName 'ConstructorName, [Maybe ParamUsage])] + -> [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])] -> m Expr -mkTraversal mn recurseVar (TraversalOps @_ @f visitExpr extractExpr) ctors = do +mkTraversal mn isBi te@TraversalExprs{..} getContraversalExprs (TraversalOps @_ @f visitExpr extractExpr) ctors = do f <- freshIdent "f" + g <- if isBi then freshIdent "g" else pure f let - handleValue :: ParamUsage -> Expr -> f Expr + handleValue :: ParamUsage c -> Expr -> f Expr handleValue = unnestRecords $ \usage inputExpr -> visitExpr $ flip App inputExpr <$> mkFnExprForValue usage - mkFnExprForValue :: ParamUsage -> m Expr + mkFnExprForValue :: ParamUsage c -> m Expr mkFnExprForValue = \case IsParam -> + pure $ mkVar g + IsLParam -> pure $ mkVar f MentionsParam innerUsage -> App recurseVar <$> mkFnExprForValue innerUsage + MentionsParamBi theseInnerUsages -> + appBirecurseExprs te <$> both mkFnExprForValue theseInnerUsages + MentionsParamContravariantly c contraUsage -> do + let ce@ContraversalExprs{..} = getContraversalExprs c + case contraUsage of + MentionsParamContra innerUsage -> + App crecurseVar <$> mkFnExprForValue innerUsage + MentionsParamPro theseInnerUsages -> + appDirecurseExprs ce <$> both mkFnExprForValue theseInnerUsages IsRecord fields -> usingLamIdent $ extractExpr . traverseFields handleValue fields - lam f <$> mkCasesForTraversal mn handleValue extractExpr ctors + lam f . applyWhen isBi (lam g) <$> mkCasesForTraversal mn handleValue extractExpr ctors deriveFunctor :: forall m . MonadError MultipleErrors m => MonadState CheckState m => MonadSupply m - => Qualified (ProperName 'ClassName) + => Maybe Bool -- does left parameter exist, and is it contravariant? + -> Bool -- is the (right) parameter contravariant? + -> PSString -- name of the map function for this functor type + -> Qualified (ProperName 'ClassName) -> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)] -deriveFunctor nm mn tyConNm = do - ctors <- validateParamsInTypeConstructors nm mn tyConNm - mapFun <- mkTraversal mn mapVar (TraversalOps identity identity) ctors - pure [(Libs.S_map, mapFun)] +deriveFunctor mbLParamIsContravariant paramIsContravariant mapName nm mn tyConNm = do + ctors <- validateParamsInTypeConstructors nm mn tyConNm isBi functorClasses $ Just $ ContravarianceSupport + { contravarianceWitness = () + , paramIsContravariant + , lparamIsContravariant = or mbLParamIsContravariant + , contravariantClasses + } + mapFun <- mkTraversal mn isBi mapExprs (const cmapExprs) (TraversalOps identity identity) ctors + pure [(mapName, mapFun)] where - mapVar = mkRef Libs.I_map + isBi = isJust mbLParamIsContravariant + mapExprs = TraversalExprs + { recurseVar = mkRef Libs.I_map + , birecurseVar = mkRef Libs.I_bimap + , lrecurseExpr = mkRef Libs.I_lmap + , rrecurseExpr = mkRef Libs.I_rmap + } + cmapExprs = ContraversalExprs + { crecurseVar = mkRef Libs.I_cmap + , direcurseVar = mkRef Libs.I_dimap + , lcrecurseVar = mkRef Libs.I_lcmap + , rprorecurseVar = mkRef Libs.I_profunctorRmap + } + functorClasses = CovariantClasses Libs.Functor Libs.Bifunctor + contravariantClasses = ContravariantClasses Libs.Contravariant Libs.Profunctor toConst :: forall f a b. f a -> Const [f a] b toConst = Const . pure @@ -509,42 +680,74 @@ deriveFoldable . MonadError MultipleErrors m => MonadState CheckState m => MonadSupply m - => Qualified (ProperName 'ClassName) + => Bool -- is there a left parameter (are we deriving Bifoldable)? + -> Qualified (ProperName 'ClassName) -> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)] -deriveFoldable nm mn tyConNm = do - ctors <- validateParamsInTypeConstructors nm mn tyConNm - foldlFun <- mkAsymmetricFoldFunction False foldlVar ctors - foldrFun <- mkAsymmetricFoldFunction True foldrVar ctors - foldMapFun <- mkTraversal mn foldMapVar foldMapOps ctors - pure [(Libs.S_foldl, foldlFun), (Libs.S_foldr, foldrFun), (Libs.S_foldMap, foldMapFun)] +deriveFoldable isBi nm mn tyConNm = do + ctors <- validateParamsInTypeConstructors nm mn tyConNm isBi foldableClasses Nothing + foldlFun <- mkAsymmetricFoldFunction False foldlExprs ctors + foldrFun <- mkAsymmetricFoldFunction True foldrExprs ctors + foldMapFun <- mkTraversal mn isBi foldMapExprs absurd foldMapOps ctors + pure + [ (if isBi then Libs.S_bifoldl else Libs.S_foldl, foldlFun) + , (if isBi then Libs.S_bifoldr else Libs.S_foldr, foldrFun) + , (if isBi then Libs.S_bifoldMap else Libs.S_foldMap, foldMapFun) + ] where - foldlVar = mkRef Libs.I_foldl - foldrVar = mkRef Libs.I_foldr - foldMapVar = mkRef Libs.I_foldMap + foldableClasses = CovariantClasses Libs.Foldable Libs.Bifoldable + foldlExprs = TraversalExprs + { recurseVar = mkRef Libs.I_foldl + , birecurseVar = bifoldlVar + , lrecurseExpr = App (App flipVar bifoldlVar) constVar + , rrecurseExpr = App bifoldlVar constVar + } + foldrExprs = TraversalExprs + { recurseVar = mkRef Libs.I_foldr + , birecurseVar = bifoldrVar + , lrecurseExpr = App (App flipVar bifoldrVar) (App constVar identityVar) + , rrecurseExpr = App bifoldrVar (App constVar identityVar) + } + foldMapExprs = TraversalExprs + { recurseVar = mkRef Libs.I_foldMap + , birecurseVar = bifoldMapVar + , lrecurseExpr = App (App flipVar bifoldMapVar) memptyVar + , rrecurseExpr = App bifoldMapVar memptyVar + } + bifoldlVar = mkRef Libs.I_bifoldl + bifoldrVar = mkRef Libs.I_bifoldr + bifoldMapVar = mkRef Libs.I_bifoldMap + constVar = mkRef Libs.I_const flipVar = mkRef Libs.I_flip + identityVar = mkRef Libs.I_identity + memptyVar = mkRef Libs.I_mempty - mkAsymmetricFoldFunction :: Bool -> Expr -> [(ProperName 'ConstructorName, [Maybe ParamUsage])] -> m Expr - mkAsymmetricFoldFunction isRightFold recurseVar ctors = do + mkAsymmetricFoldFunction :: Bool -> TraversalExprs -> [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])] -> m Expr + mkAsymmetricFoldFunction isRightFold te@TraversalExprs{..} ctors = do f <- freshIdent "f" + g <- if isBi then freshIdent "g" else pure f z <- freshIdent "z" let appCombiner :: (Bool, Expr) -> Expr -> Expr -> Expr appCombiner (isFlipped, fn) = applyWhen (isFlipped == isRightFold) flip $ App . App fn - mkCombinerExpr :: ParamUsage -> m Expr + mkCombinerExpr :: ParamUsage Void -> m Expr mkCombinerExpr = fmap (uncurry $ \isFlipped -> applyWhen isFlipped $ App flipVar) . getCombiner - handleValue :: ParamUsage -> Expr -> Const [m (Expr -> Expr)] Expr + handleValue :: ParamUsage Void -> Expr -> Const [m (Expr -> Expr)] Expr handleValue = unnestRecords $ \usage inputExpr -> toConst $ flip appCombiner inputExpr <$> getCombiner usage - getCombiner :: ParamUsage -> m (Bool, Expr) + getCombiner :: ParamUsage Void -> m (Bool, Expr) getCombiner = \case IsParam -> + pure (False, mkVar g) + IsLParam -> pure (False, mkVar f) MentionsParam innerUsage -> (isRightFold, ) . App recurseVar <$> mkCombinerExpr innerUsage + MentionsParamBi theseInnerUsages -> + (isRightFold, ) . appBirecurseExprs te <$> both mkCombinerExpr theseInnerUsages IsRecord fields -> do let foldFieldsOf = traverseFields handleValue fields fmap (False, ) . usingLamIdent $ \lVar -> @@ -556,7 +759,7 @@ deriveFoldable nm mn tyConNm = do extractExprStartingWith :: Expr -> Const [m (Expr -> Expr)] Expr -> m Expr extractExprStartingWith = consumeConst . if isRightFold then foldr ($) else foldl' (&) - lam f . lam z <$> mkCasesForTraversal mn handleValue (extractExprStartingWith $ mkVar z) ctors + lam f . applyWhen isBi (lam g) . lam z <$> mkCasesForTraversal mn handleValue (extractExprStartingWith $ mkVar z) ctors foldMapOps :: forall m. Applicative m => TraversalOps m foldMapOps = TraversalOps { visitExpr = toConst, .. } @@ -574,17 +777,29 @@ deriveTraversable . MonadError MultipleErrors m => MonadState CheckState m => MonadSupply m - => Qualified (ProperName 'ClassName) + => Bool -- is there a left parameter (are we deriving Bitraversable)? + -> Qualified (ProperName 'ClassName) -> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)] -deriveTraversable nm mn tyConNm = do - ctors <- validateParamsInTypeConstructors nm mn tyConNm - traverseFun <- mkTraversal mn traverseVar traverseOps ctors - sequenceFun <- usingLamIdent $ pure . App (App traverseVar identityVar) - pure [(Libs.S_traverse, traverseFun), (Libs.S_sequence, sequenceFun)] +deriveTraversable isBi nm mn tyConNm = do + ctors <- validateParamsInTypeConstructors nm mn tyConNm isBi traversableClasses Nothing + traverseFun <- mkTraversal mn isBi traverseExprs absurd traverseOps ctors + sequenceFun <- usingLamIdent $ pure . App (App (if isBi then App bitraverseVar identityVar else traverseVar) identityVar) + pure + [ (if isBi then Libs.S_bitraverse else Libs.S_traverse, traverseFun) + , (if isBi then Libs.S_bisequence else Libs.S_sequence, sequenceFun) + ] where + traversableClasses = CovariantClasses Libs.Traversable Libs.Bitraversable + traverseExprs = TraversalExprs + { recurseVar = traverseVar + , birecurseVar = bitraverseVar + , lrecurseExpr = mkRef Libs.I_ltraverse + , rrecurseExpr = mkRef Libs.I_rtraverse + } traverseVar = mkRef Libs.I_traverse + bitraverseVar = mkRef Libs.I_bitraverse identityVar = mkRef Libs.I_identity traverseOps :: forall m. MonadSupply m => TraversalOps m diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 381f83fc0c..d5b315d490 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -7,6 +7,7 @@ module Language.PureScript.TypeChecker.Entailment , replaceTypeClassDictionaries , newDictionaries , entails + , findDicts ) where import Prelude @@ -94,6 +95,9 @@ type InstanceContext = M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NonEmpty NamedDict))) +findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> QualifiedBy -> [TypeClassDict] +findDicts ctx cn = fmap (fmap NamedInstance) . foldMap NEL.toList . foldMap M.elems . (M.lookup cn <=< flip M.lookup ctx) + -- | A type substitution which makes an instance head match a list of types. -- -- Note: we store many types per type variable name. For any name, all types @@ -224,9 +228,6 @@ entails SolverOptions{..} constraint context hints = ctorModules (KindedType _ ty _) = ctorModules ty ctorModules _ = Nothing - findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> QualifiedBy -> [TypeClassDict] - findDicts ctx cn = fmap (fmap NamedInstance) . foldMap NEL.toList . foldMap M.elems . (M.lookup cn <=< flip M.lookup ctx) - valUndefined :: Expr valUndefined = Var nullSourceSpan C.I_undefined diff --git a/tests/purs/failing/BifunctorInstance1.out b/tests/purs/failing/BifunctorInstance1.out new file mode 100644 index 0000000000..db6922613c --- /dev/null +++ b/tests/purs/failing/BifunctorInstance1.out @@ -0,0 +1,16 @@ +Error found: +in module BifunctorInstance1 +at tests/purs/failing/BifunctorInstance1.purs:10:1 - 10:31 (line 10, column 1 - line 10, column 31) + + One or more type variables are in positions that prevent Bifunctor from being derived. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, that their variance matches the variance of Bifunctor, and that those type constructors themselves have instances of Data.Functor.Functor, Data.Bifunctor.Bifunctor, Data.Functor.Contravariant.Contravariant, or Data.Profunctor.Profunctor. + + tests/purs/failing/BifunctorInstance1.purs: +  8  +  9 data Test a b = Test (Tuple (Predicate a) (Predicate b)) (Tuple a b) +  10 derive instance Bifunctor Test + + +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/BifunctorInstance1.purs b/tests/purs/failing/BifunctorInstance1.purs new file mode 100644 index 0000000000..264cae5708 --- /dev/null +++ b/tests/purs/failing/BifunctorInstance1.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith CannotDeriveInvalidConstructorArg +module BifunctorInstance1 where + +import Prelude +import Data.Bifunctor (class Bifunctor) +import Data.Predicate (Predicate) +import Data.Tuple (Tuple) + +data Test a b = Test (Tuple (Predicate a) (Predicate b)) (Tuple a b) +derive instance Bifunctor Test diff --git a/tests/purs/failing/ContravariantInstance1.out b/tests/purs/failing/ContravariantInstance1.out new file mode 100644 index 0000000000..e539305cf8 --- /dev/null +++ b/tests/purs/failing/ContravariantInstance1.out @@ -0,0 +1,16 @@ +Error found: +in module ContravariantInstance1 +at tests/purs/failing/ContravariantInstance1.purs:9:1 - 9:35 (line 9, column 1 - line 9, column 35) + + One or more type variables are in positions that prevent Contravariant from being derived. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, that their variance matches the variance of Contravariant, and that those type constructors themselves have instances of Data.Functor.Functor, Data.Bifunctor.Bifunctor, Data.Functor.Contravariant.Contravariant, or Data.Profunctor.Profunctor. + + tests/purs/failing/ContravariantInstance1.purs: +  6  +  7 newtype Test a = Test (Predicate (Predicate a)) +  8  + + +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ContravariantInstance1.purs b/tests/purs/failing/ContravariantInstance1.purs new file mode 100644 index 0000000000..ddd318e0d9 --- /dev/null +++ b/tests/purs/failing/ContravariantInstance1.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith CannotDeriveInvalidConstructorArg +module ContravariantInstance1 where + +import Data.Functor.Contravariant (class Contravariant) +import Data.Predicate (Predicate) + +newtype Test a = Test (Predicate (Predicate a)) + +derive instance Contravariant Test diff --git a/tests/purs/failing/FoldableInstance10.out b/tests/purs/failing/FoldableInstance10.out index d05c441e19..089056df60 100644 --- a/tests/purs/failing/FoldableInstance10.out +++ b/tests/purs/failing/FoldableInstance10.out @@ -3,7 +3,7 @@ in module FoldableInstance10 at tests/purs/failing/FoldableInstance10.purs:11:1 - 11:30 (line 11, column 1 - line 11, column 30) One or more type variables are in positions that prevent Foldable from being derived. - To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Data.Foldable.Foldable or Data.Bifoldable.Bifoldable. tests/purs/failing/FoldableInstance10.purs:  9  diff --git a/tests/purs/failing/FoldableInstance4.out b/tests/purs/failing/FoldableInstance4.out index 4e53669e6b..693fa4b766 100644 --- a/tests/purs/failing/FoldableInstance4.out +++ b/tests/purs/failing/FoldableInstance4.out @@ -2,22 +2,15 @@ Error found: in module FoldableInstance4 at tests/purs/failing/FoldableInstance4.purs:8:1 - 8:27 (line 8, column 1 - line 8, column 27) - No type class instance was found for -   -  Data.Foldable.Foldable (Function t3) -   - The instance head contains unknown type variables. Consider adding a type annotation. + One or more type variables are in positions that prevent Foldable from being derived. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Data.Foldable.Foldable or Data.Bifoldable.Bifoldable. -while applying a function foldl - of type Foldable t0 => (t1 -> t2 -> t1) -> t1 -> t0 t2 -> t1 - to argument $f1 -while inferring the type of foldl $f1 + tests/purs/failing/FoldableInstance4.purs: +  6  +  7 data T a = T (forall t. Show t => t -> a) +  8 derive instance Foldable T -where t0 is an unknown type - t2 is an unknown type - t1 is an unknown type - t3 is an unknown type -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/FoldableInstance4.purs b/tests/purs/failing/FoldableInstance4.purs index 6dd856540f..ad01c8be93 100644 --- a/tests/purs/failing/FoldableInstance4.purs +++ b/tests/purs/failing/FoldableInstance4.purs @@ -1,4 +1,4 @@ --- @shouldFailWith NoInstanceFound +-- @shouldFailWith CannotDeriveInvalidConstructorArg module FoldableInstance4 where import Prelude diff --git a/tests/purs/failing/FoldableInstance5.out b/tests/purs/failing/FoldableInstance5.out deleted file mode 100644 index 485007f557..0000000000 --- a/tests/purs/failing/FoldableInstance5.out +++ /dev/null @@ -1,16 +0,0 @@ -Error found: -in module FoldableInstance5 -at tests/purs/failing/FoldableInstance5.purs:9:1 - 9:30 (line 9, column 1 - line 9, column 30) - - One or more type variables are in positions that prevent Foldable from being derived. - To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. - - tests/purs/failing/FoldableInstance5.purs: -  7  -  8 data Test a = Test (Tuple a Int) -  9 derive instance Foldable Test - - -See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/FoldableInstance5.purs b/tests/purs/failing/FoldableInstance5.purs deleted file mode 100644 index cf86966245..0000000000 --- a/tests/purs/failing/FoldableInstance5.purs +++ /dev/null @@ -1,9 +0,0 @@ --- @shouldFailWith CannotDeriveInvalidConstructorArg -module FoldableInstance5 where - -import Prelude -import Data.Foldable (class Foldable) -import Data.Tuple (Tuple(..)) - -data Test a = Test (Tuple a Int) -derive instance Foldable Test diff --git a/tests/purs/failing/FoldableInstance6.out b/tests/purs/failing/FoldableInstance6.out index 148f229dad..31028db8eb 100644 --- a/tests/purs/failing/FoldableInstance6.out +++ b/tests/purs/failing/FoldableInstance6.out @@ -3,7 +3,7 @@ in module FoldableInstance6 at tests/purs/failing/FoldableInstance6.purs:8:1 - 8:30 (line 8, column 1 - line 8, column 30) One or more type variables are in positions that prevent Foldable from being derived. - To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Data.Foldable.Foldable or Data.Bifoldable.Bifoldable. tests/purs/failing/FoldableInstance6.purs:  6  diff --git a/tests/purs/failing/FoldableInstance7.out b/tests/purs/failing/FoldableInstance7.out deleted file mode 100644 index 2a8ebf28dd..0000000000 --- a/tests/purs/failing/FoldableInstance7.out +++ /dev/null @@ -1,16 +0,0 @@ -Error found: -in module FoldableInstance6 -at tests/purs/failing/FoldableInstance7.purs:9:1 - 9:30 (line 9, column 1 - line 9, column 30) - - One or more type variables are in positions that prevent Foldable from being derived. - To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. - - tests/purs/failing/FoldableInstance7.purs: -  7  -  8 data Test a = Test (Tuple a a) -  9 derive instance Foldable Test - - -See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/FoldableInstance7.purs b/tests/purs/failing/FoldableInstance7.purs deleted file mode 100644 index ce11d35547..0000000000 --- a/tests/purs/failing/FoldableInstance7.purs +++ /dev/null @@ -1,9 +0,0 @@ --- @shouldFailWith CannotDeriveInvalidConstructorArg -module FoldableInstance6 where - -import Prelude -import Data.Tuple (Tuple(..)) -import Data.Foldable (class Foldable) - -data Test a = Test (Tuple a a) -derive instance Foldable Test diff --git a/tests/purs/failing/FoldableInstance8.out b/tests/purs/failing/FoldableInstance8.out index c5fdd33b3f..9199ad2211 100644 --- a/tests/purs/failing/FoldableInstance8.out +++ b/tests/purs/failing/FoldableInstance8.out @@ -3,11 +3,11 @@ in module FoldableInstance6 at tests/purs/failing/FoldableInstance8.purs:8:1 - 8:34 (line 8, column 1 - line 8, column 34) One or more type variables are in positions that prevent Foldable from being derived. - To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Data.Foldable.Foldable or Data.Bifoldable.Bifoldable. tests/purs/failing/FoldableInstance8.purs:  6  -  7 data Test f a = Test (f a a) +  7 data Test f a = Test (f a a)  8 derive instance Foldable (Test f) diff --git a/tests/purs/failing/FoldableInstance9.out b/tests/purs/failing/FoldableInstance9.out index 862543eda1..f48b5fc556 100644 --- a/tests/purs/failing/FoldableInstance9.out +++ b/tests/purs/failing/FoldableInstance9.out @@ -3,13 +3,13 @@ in module FoldableInstance9 at tests/purs/failing/FoldableInstance9.purs:53:1 - 53:38 (line 53, column 1 - line 53, column 38) One or more type variables are in positions that prevent Foldable from being derived. - To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Data.Foldable.Foldable or Data.Bifoldable.Bifoldable. tests/purs/failing/FoldableInstance9.purs:  15 data Test f g h a -  16  = Test1 (f a a a) (f Int a a) (f a a Int) (f Int a Int) (f Int Int Int) -  17  | Test2 { all :: f a a a -  18  , rights :: f Int a a +  16  = Test1 (f a a a) (f Int a a) (f a a Int) (f Int a Int) (f Int Int Int) +  17  | Test2 { all :: f a a a +  18  , rights :: f Int a a  19  , lefts :: f a a Int  20  , middle :: f Int a Int  21  , none :: f Int Int Int @@ -20,7 +20,9 @@ at tests/purs/failing/FoldableInstance9.purs:53:1 - 53:38 (line 53, column 1 - l  26  , lefts :: f a a Int  27  , middle :: f Int a Int  28  , none :: f Int Int Int -  ... +  29  } +  30  a) +  31  | Test4 (h  32  { nested1 ::  33  { all :: f a a a  34  , rights :: f Int a a @@ -37,10 +39,10 @@ at tests/purs/failing/FoldableInstance9.purs:53:1 - 53:38 (line 53, column 1 - l  46  }  47  a  48  } -  49  a) +  49  a)  50  | Test5 (Rec f a) -  51  | Test6 (g (Rec f a) a) -  52  | Test7 (h { nested1 :: Rec f a, nested2 :: g (Rec f a) a } a) +  51  | Test6 (g (Rec f a) a) +  52  | Test7 (h { nested1 :: Rec f a, nested2 :: g (Rec f a) a } a)  53 derive instance Foldable (Test f g h) diff --git a/tests/purs/failing/FunctorInstance1.out b/tests/purs/failing/FunctorInstance1.out new file mode 100644 index 0000000000..0f2e05c6d8 --- /dev/null +++ b/tests/purs/failing/FunctorInstance1.out @@ -0,0 +1,16 @@ +Error found: +in module FunctorInstance1 +at tests/purs/failing/FunctorInstance1.purs:8:1 - 8:29 (line 8, column 1 - line 8, column 29) + + One or more type variables are in positions that prevent Functor from being derived. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, that their variance matches the variance of Functor, and that those type constructors themselves have instances of Data.Functor.Functor, Data.Bifunctor.Bifunctor, Data.Functor.Contravariant.Contravariant, or Data.Profunctor.Profunctor. + + tests/purs/failing/FunctorInstance1.purs: +  6  +  7 data Test a = Test (Predicate a) +  8 derive instance Functor Test + + +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/FunctorInstance1.purs b/tests/purs/failing/FunctorInstance1.purs new file mode 100644 index 0000000000..2883d98528 --- /dev/null +++ b/tests/purs/failing/FunctorInstance1.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith CannotDeriveInvalidConstructorArg +module FunctorInstance1 where + +import Prelude +import Data.Predicate (Predicate) + +data Test a = Test (Predicate a) +derive instance Functor Test diff --git a/tests/purs/passing/DerivingBifunctor.purs b/tests/purs/passing/DerivingBifunctor.purs new file mode 100644 index 0000000000..e5f7fc86a8 --- /dev/null +++ b/tests/purs/passing/DerivingBifunctor.purs @@ -0,0 +1,26 @@ +module Main where + +import Prelude + +import Data.Bifoldable (class Bifoldable) +import Data.Bifunctor (class Bifunctor) +import Data.Bitraversable (class Bitraversable) +import Data.Predicate (Predicate) +import Data.Tuple (Tuple) +import Effect.Console (log) + +data Test f a b + = Test0 + | Test1 (Array a) b + | Test2 Int (forall a. Array a -> Array a) + | Test3 Int (f a b) (f a Int) (f Int b) + | Test4 (Array (Tuple a Int)) (Tuple b Int) + | Test5 { nested :: Array { x :: f { a :: a } { b :: b } } } +derive instance Bifunctor f => Bifunctor (Test f) +derive instance Bifoldable f => Bifoldable (Test f) +derive instance Bitraversable f => Bitraversable (Test f) + +data FromProAndContra a b = FromProAndContra (Predicate (a -> Int)) (Predicate b -> Int) +derive instance Bifunctor FromProAndContra + +main = log "Done" diff --git a/tests/purs/passing/DerivingContravariant.purs b/tests/purs/passing/DerivingContravariant.purs new file mode 100644 index 0000000000..7816e5b319 --- /dev/null +++ b/tests/purs/passing/DerivingContravariant.purs @@ -0,0 +1,20 @@ +module Main where + +import Prelude + +import Data.Functor.Contravariant (class Contravariant) +import Data.Predicate (Predicate) +import Data.Tuple (Tuple) +import Effect.Console (log) + +data Test f a + = Test0 + | Test1 (Predicate a) + | Test2 (Predicate (Predicate (Predicate a))) + | Test3 Int (forall a. Array a -> Array a) + | Test4 Int (f a) + | Test5 (Array (a -> Int)) (Tuple (Predicate a) Int) + | Test6 { nested :: Array { x :: f { a :: a } } } +derive instance Contravariant f => Contravariant (Test f) + +main = log "Done" diff --git a/tests/purs/passing/DerivingFunctorFromBi.purs b/tests/purs/passing/DerivingFunctorFromBi.purs new file mode 100644 index 0000000000..f19bc3c913 --- /dev/null +++ b/tests/purs/passing/DerivingFunctorFromBi.purs @@ -0,0 +1,18 @@ +module Main where + +import Prelude + +import Data.Foldable (class Foldable) +import Data.Traversable (class Traversable) +import Data.Tuple (Tuple) +import Effect.Console (log) + +data Test a + = Test1 (Tuple a Int) + | Test2 (Tuple (Array a) a) + | Test3 { x :: Tuple { a :: a } Int, y :: Tuple { a :: Array a } { a :: a } } +derive instance Functor Test +derive instance Foldable Test +derive instance Traversable Test + +main = log "Done" diff --git a/tests/purs/passing/DerivingFunctorFromContra.purs b/tests/purs/passing/DerivingFunctorFromContra.purs new file mode 100644 index 0000000000..0eed77feb8 --- /dev/null +++ b/tests/purs/passing/DerivingFunctorFromContra.purs @@ -0,0 +1,13 @@ +module Main where + +import Prelude + +import Data.Predicate (Predicate) +import Effect.Console (log) + +data Test a + = Test1 (Predicate (Predicate a)) + | Test2 { x :: Predicate { y :: Predicate a } } +derive instance Functor Test + +main = log "Done" diff --git a/tests/purs/passing/DerivingFunctorFromPro.purs b/tests/purs/passing/DerivingFunctorFromPro.purs new file mode 100644 index 0000000000..dc038e9c09 --- /dev/null +++ b/tests/purs/passing/DerivingFunctorFromPro.purs @@ -0,0 +1,16 @@ +module Main where + +-- Note that Data.Profunctor is not in the dependencies of any types imported +-- here. The package that contains that module must be a dependency of the test +-- project. + +import Prelude + +import Effect.Console (log) + +data Test a + = Test1 ((Array a -> Int) -> Int) + | Test2 { f :: ({ a :: a } -> Int) -> Int } +derive instance Functor Test + +main = log "Done" diff --git a/tests/purs/passing/DerivingFunctorPrefersSimplerClasses.purs b/tests/purs/passing/DerivingFunctorPrefersSimplerClasses.purs new file mode 100644 index 0000000000..5051f5d145 --- /dev/null +++ b/tests/purs/passing/DerivingFunctorPrefersSimplerClasses.purs @@ -0,0 +1,46 @@ +module Main where + +import Prelude + +import Data.Bifunctor (class Bifunctor) +import Data.Profunctor (class Profunctor) +import Effect (Effect) +import Effect.Console (log) +import Test.Assert (assert') + +newtype MonoAndBi a b = MonoAndBi (Effect Unit) +derive instance Functor (MonoAndBi a) +instance Bifunctor MonoAndBi where + bimap _ _ _ = MonoAndBi (assert' "Bifunctor instance was used but the Functor instance was expected" false) + +newtype Test1 a = Test1 (MonoAndBi Int a) +derive instance Functor Test1 + +data ExclusivelyBi a b +derive instance Bifunctor ExclusivelyBi + +newtype Test2 a = Test2 (ExclusivelyBi Int a) +derive instance Functor Test2 + +newtype MonoAndPro a b = MonoAndPro (Effect Unit) +derive instance Functor (MonoAndPro a) +instance Profunctor MonoAndPro where + dimap _ _ _ = MonoAndPro (assert' "Profunctor instance was used but the Functor instance was expected" false) + +newtype Test3 a = Test3 (MonoAndPro Int a) +derive instance Functor Test3 + +data ExclusivelyPro a b +derive instance Profunctor ExclusivelyPro + +newtype Test4 a = Test4 (ExclusivelyPro Int a) +derive instance Functor Test4 + +main = do + let t = Test1 (MonoAndBi (pure unit)) + let Test1 (MonoAndBi result1) = map identity t + result1 + let t = Test3 (MonoAndPro (pure unit)) + let Test3 (MonoAndPro result3) = map identity t + result3 + log "Done" diff --git a/tests/purs/passing/DerivingProfunctor.purs b/tests/purs/passing/DerivingProfunctor.purs new file mode 100644 index 0000000000..b8a1cf95b9 --- /dev/null +++ b/tests/purs/passing/DerivingProfunctor.purs @@ -0,0 +1,19 @@ +module Main where + +import Prelude + +import Data.Predicate (Predicate) +import Data.Profunctor (class Profunctor) +import Data.Tuple (Tuple) +import Effect.Console (log) + +data Test f a b + = Test0 + | Test1 (Predicate a) b + | Test2 Int (forall a. Array a -> Array a) + | Test3 Int (f a b) (f a Int) (f Int b) + | Test4 (Array (a -> Int)) (Tuple b Int) + | Test5 { nested :: Array { x :: f { a :: a } { b :: b } } } +derive instance Profunctor f => Profunctor (Test f) + +main = log "Done" From 0adf19643c9501d58d5490c686d9ed9baf50bb8d Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Mon, 5 Dec 2022 22:56:46 +0800 Subject: [PATCH 1521/1580] Upgrade to GHC 9.2.4 (#4422) * Bump container to haskell:9.2.4 * Bump Stackage snapshot to 2022-11-12 * Fix error in ci.yml * Bump stack version * 9.2.3 -> 9.2.4 --- .github/workflows/ci.yml | 6 +++--- CHANGELOG.d/misc_bump-ghc.md | 1 + INSTALL.md | 4 ++-- stack.yaml | 2 +- 4 files changed, 7 insertions(+), 6 deletions(-) create mode 100644 CHANGELOG.d/misc_bump-ghc.md diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 8eb1a72572..c12699776e 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -15,7 +15,7 @@ defaults: env: CI_PRERELEASE: "${{ github.event_name == 'push' }}" CI_RELEASE: "${{ github.event_name == 'release' }}" - STACK_VERSION: "2.7.5" + STACK_VERSION: "2.9.1" concurrency: # We never want two prereleases building at the same time, since they would @@ -38,7 +38,7 @@ jobs: include: - # If upgrading the Haskell image, also upgrade it in the lint job below os: "ubuntu-latest" - image: "ghcr.io/purescript/haskell:9.2.3-stretch@sha256:70fd2b6255deb5daa961e6983591a0e21e9ac1e793923bee54aa2cc62e01f867" + image: haskell:9.2.4@sha256:dceec00f8ad896c327c2b5c77ba91c9824bf3e26a837f538ccfb80fb379dc52f - os: "macOS-11" - os: "windows-2019" @@ -172,7 +172,7 @@ jobs: # means our published binaries will work on the widest number of platforms. # But the HLint binary downloaded by this job requires a newer glibc # version. - container: "haskell:9.2.3-buster@sha256:51e250369e4671a15c247cdc5047397be88d7eb8e95b97b0fd9f417854a78bec" + container: haskell:9.2.4@sha256:dceec00f8ad896c327c2b5c77ba91c9824bf3e26a837f538ccfb80fb379dc52f steps: - # We need a proper Git repository, but the checkout step will unpack a tarball instead of doing a clone diff --git a/CHANGELOG.d/misc_bump-ghc.md b/CHANGELOG.d/misc_bump-ghc.md new file mode 100644 index 0000000000..4ae15f7020 --- /dev/null +++ b/CHANGELOG.d/misc_bump-ghc.md @@ -0,0 +1 @@ +* Bump Stackage snapshot to 2022-11-12 and GHC to 9.2.4 diff --git a/INSTALL.md b/INSTALL.md index 29175f9af6..d928501371 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -4,12 +4,12 @@ If you are having difficulty installing the PureScript compiler, feel free to as ## Requirements -The PureScript compiler is built using GHC 9.2.3, and should be able to run on any operating system supported by GHC 9.2.3. In particular: +The PureScript compiler is built using GHC 9.2.4, and should be able to run on any operating system supported by GHC 9.2.4. In particular: * for Windows users, versions predating Vista are not officially supported, * for macOS / OS X users, versions predating Mac OS X 10.7 (Lion) are not officially supported. -See also for more details about the operating systems which GHC 9.2.3 supports. +See also for more details about the operating systems which GHC 9.2.4 supports. ## Official prebuilt binaries diff --git a/stack.yaml b/stack.yaml index ac0a546b08..397fc5894a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ # Please update Haskell image versions under .github/workflows/ci.yml together to use the same GHC version # (or the CI build will fail) -resolver: nightly-2022-06-09 +resolver: nightly-2022-11-12 pvp-bounds: both packages: - '.' From a564c5b0a111723868d8b621cd388e286bc0f93e Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 6 Dec 2022 13:11:36 -0600 Subject: [PATCH 1522/1580] Fix installer (#4425) * Update installer to 0.3.3 --- CHANGELOG.d/fix_docker-install.md | 1 + npm-package/package.json | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/fix_docker-install.md diff --git a/CHANGELOG.d/fix_docker-install.md b/CHANGELOG.d/fix_docker-install.md new file mode 100644 index 0000000000..43702cada7 --- /dev/null +++ b/CHANGELOG.d/fix_docker-install.md @@ -0,0 +1 @@ +* Update installer to `0.3.3` to fix a few installation issues \ No newline at end of file diff --git a/npm-package/package.json b/npm-package/package.json index 490202617a..e3eb7ab648 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -15,7 +15,7 @@ "purs": "purs.bin" }, "dependencies": { - "purescript-installer": "^0.3.1" + "purescript-installer": "^0.3.3" }, "homepage": "https://github.com/purescript/purescript", "repository": { From b71cb532c7d8d97505376cb528080ca3046615fe Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 12 Dec 2022 10:31:26 -0500 Subject: [PATCH 1523/1580] Enable more GHC warnings (#4429) --- CHANGELOG.d/internal_enable-ghc-warnings.md | 1 + purescript.cabal | 55 +++++++++++++------ src/Language/PureScript/CST/Lexer.hs | 4 +- src/Language/PureScript/CodeGen/JS.hs | 4 +- .../PureScript/Docs/Convert/ReExports.hs | 3 +- src/Language/PureScript/Ide/CaseSplit.hs | 4 +- src/Language/PureScript/Ide/Completion.hs | 2 +- src/Language/PureScript/Ide/Error.hs | 2 +- src/Language/PureScript/Ide/Externs.hs | 10 ++-- src/Language/PureScript/Ide/Filter.hs | 6 +- src/Language/PureScript/Ide/State.hs | 2 +- src/Language/PureScript/Ide/Usage.hs | 2 +- src/Language/PureScript/Interactive.hs | 8 +-- src/Language/PureScript/Linter/Exhaustive.hs | 5 +- src/Language/PureScript/Make.hs | 8 +-- src/Language/PureScript/Make/Actions.hs | 4 +- src/Language/PureScript/Make/BuildPlan.hs | 2 +- src/Language/PureScript/Pretty/Common.hs | 4 +- src/Language/PureScript/Sugar/Names/Common.hs | 2 +- .../PureScript/TypeChecker/Deriving.hs | 1 - .../TypeChecker/Entailment/Coercible.hs | 3 - tests/TestMake.hs | 4 +- 22 files changed, 76 insertions(+), 60 deletions(-) create mode 100644 CHANGELOG.d/internal_enable-ghc-warnings.md diff --git a/CHANGELOG.d/internal_enable-ghc-warnings.md b/CHANGELOG.d/internal_enable-ghc-warnings.md new file mode 100644 index 0000000000..ed226bbb36 --- /dev/null +++ b/CHANGELOG.d/internal_enable-ghc-warnings.md @@ -0,0 +1 @@ +* Enable more GHC warnings diff --git a/purescript.cabal b/purescript.cabal index 57da11080e..170f09a01a 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -53,12 +53,40 @@ flag release default: False common defaults - -- Note: -Wall-incomplete-uni-patterns and -Wincomplete-record-updates can be - -- removed once we upgrade to GHC 9.2.1 since they are now included in -Wall. ghc-options: - -Wall - -Wincomplete-uni-patterns - -Wincomplete-record-updates + -- This list taken from https://medium.com/mercury-bank/enable-all-the-warnings-a0517bc081c3 + -- Enable all warnings with -Weverything, then disable the ones we don’t care about + -Weverything + + -- missing-exported-signatures turns off the more strict -Wmissing-signatures. See https://ghc.haskell.org/trac/ghc/ticket/14794#ticket + -Wno-missing-exported-signatures + + -- Requires explicit imports of _every_ function (e.g. ‘$’); too strict + -Wno-missing-import-lists + + -- When GHC can’t specialize a polymorphic function. No big deal and requires fixing underlying libraries to solve. + -Wno-missed-specialisations + -Wno-all-missed-specialisations + + -- Don’t use Safe Haskell warnings + -Wno-unsafe + -Wno-safe + -Wno-trustworthy-safe + -Wno-inferred-safe-imports + -Wno-missing-safe-haskell-mode + + -- Warning for polymorphic local bindings; nothing wrong with those. + -Wno-missing-local-signatures + + -- Don’t warn if the monomorphism restriction is used + -Wno-monomorphism-restriction + + -- Remaining options don't come from the above blog post + -Wno-missing-deriving-strategies + -Wno-missing-export-lists + -Wno-missing-kind-signatures + -Wno-partial-fields + -Wno-prepositive-qualified-module default-language: Haskell2010 default-extensions: BangPatterns @@ -127,7 +155,6 @@ common defaults -- specific version. aeson >=2.0.3.0 && <2.1, aeson-better-errors >=0.9.1.1 && <0.10, - aeson-pretty >=0.8.9 && <0.9, ansi-terminal >=0.11.3 && <0.12, array >=0.5.4.0 && <0.6, base >=4.16.2.0 && <4.17, @@ -149,7 +176,6 @@ common defaults edit-distance >=0.2.2.1 && <0.3, file-embed >=0.0.15.0 && <0.1, filepath >=1.4.2.2 && <1.5, - fsnotify >=0.3.0.1 && <0.4, Glob >=0.10.2 && <0.11, haskeline >=0.8.2 && <0.9, language-javascript ==0.7.0.0, @@ -172,19 +198,14 @@ common defaults semigroups ==0.20.*, semialign >=1.2.0.1 && <1.3, sourcemap >=0.1.7 && <0.2, - split >=0.2.3.4 && <0.3, stm >=2.5.0.2 && <2.6, stringsearch >=0.3.6.6 && <0.4, - syb >=0.7.2.1 && <0.8, template-haskell >=2.18.0.0 && <2.19, text >=1.2.5.0 && <1.3, these >=1.1.1.1 && <1.2, time >=1.11.1.1 && <1.12, transformers >=0.5.6.2 && <0.6, transformers-base >=0.4.6 && <0.5, - transformers-compat >=0.7.1 && <0.8, - typed-process >=0.2.10.1 && <0.3, - unordered-containers >=0.2.19.1 && <0.3, utf8-string >=1.0.2 && <1.1, vector >=0.12.3.1 && <0.13, witherable >=0.4.2 && <0.5 @@ -379,12 +400,10 @@ executable purs import: defaults hs-source-dirs: app main-is: Main.hs - ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N + ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N -Wno-unused-packages build-depends: ansi-wl-pprint >=0.6.9 && <0.7, exceptions >=0.10.4 && <0.11, - file-embed >=0.0.13.0 && <0.1, - http-types >=0.12.3 && <0.13, network >=3.1.2.7 && <3.2, optparse-applicative >=0.17.0.0 && <0.18, purescript @@ -415,7 +434,7 @@ test-suite tests hs-source-dirs: tests main-is: Main.hs -- Not a problem for this warning to arise in tests - ghc-options: -Wno-incomplete-uni-patterns + ghc-options: -Wno-incomplete-uni-patterns -Wno-unused-packages build-depends: purescript, generic-random >=1.5.0.1 && <1.6, @@ -423,7 +442,9 @@ test-suite tests HUnit >=1.6.2.0 && <1.7, newtype >=0.2.2.0 && <0.3, QuickCheck >=2.14.2 && <2.15, - regex-base >=0.94.0.2 && <0.95 + regex-base >=0.94.0.2 && <0.95, + split >=0.2.3.4 && <0.3, + typed-process >=0.2.10.1 && <0.3 build-tool-depends: hspec-discover:hspec-discover -any -- we need the compiler's executable available for the ide tests diff --git a/src/Language/PureScript/CST/Lexer.hs b/src/Language/PureScript/CST/Lexer.hs index 5f71e2c5ae..ea9dba4827 100644 --- a/src/Language/PureScript/CST/Lexer.hs +++ b/src/Language/PureScript/CST/Lexer.hs @@ -201,7 +201,7 @@ breakComments = k0 [] goWs a _ = a goSpace a !n (' ' : ls) = goSpace a (n + 1) ls - goSpace a !n ls = goWs (Space n : a) ls + goSpace a n ls = goWs (Space n : a) ls isBlockComment = Parser $ \inp _ ksucc -> case Text.uncons inp of @@ -725,7 +725,7 @@ digitsToScientific :: String -> String -> (Integer, Int) digitsToScientific = go 0 . reverse where go !exp is [] = (digitsToInteger (reverse is), exp) - go !exp is (f : fs) = go (exp - 1) (f : is) fs + go exp is (f : fs) = go (exp - 1) (f : is) fs isSymbolChar :: Char -> Bool isSymbolChar c = (c `elem` (":!#$%&*+./<=>?@\\^|-~" :: String)) || (not (Char.isAscii c) && Char.isSymbol c) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index f5a02fe8e3..9d89092f55 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -52,7 +52,7 @@ import System.FilePath.Posix (()) -- module. moduleToJs :: forall m - . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) + . (MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) => Module Ann -> Maybe PSString -> m AST.Module @@ -232,7 +232,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = moduleBindToJs :: forall m - . (Monad m, MonadReader Options m, MonadSupply m, MonadWriter Any m, MonadError MultipleErrors m) + . (MonadReader Options m, MonadSupply m, MonadWriter Any m, MonadError MultipleErrors m) => ModuleName -> Bind Ann -> m [AST] diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 6400eced8b..7ef61d988f 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -147,8 +147,7 @@ collectDeclarations reExports = do where collect - :: (Eq a, Show a) - => (P.ModuleName -> a -> m (P.ModuleName, [b])) + :: (P.ModuleName -> a -> m (P.ModuleName, [b])) -> Map a P.ExportSource -> m (Map P.ModuleName [b]) collect lookup' exps = do diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 57b225f280..9643f642b1 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -91,8 +91,8 @@ splitTypeConstructor = go [] prettyCtor :: WildcardAnnotations -> Constructor -> Text prettyCtor _ (ctorName, []) = P.runProperName ctorName prettyCtor wsa (ctorName, ctorArgs) = - "("<> P.runProperName ctorName <> " " - <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")" + "(" <> P.runProperName ctorName <> " " + <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <> ")" prettyPrintWildcard :: WildcardAnnotations -> P.Type a -> Text prettyPrintWildcard (WildcardAnnotations True) = prettyWildcard diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 516015a702..6fa69d5c00 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -89,7 +89,7 @@ groupCompletionReexports initial = where go (Match (moduleName, d@(IdeDeclarationAnn ann decl))) = let - origin = fromMaybe moduleName (ann^.annExportedFrom) + origin = fromMaybe moduleName (ann ^. annExportedFrom) in Map.alter (insertDeclaration moduleName origin d) diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 523c335412..92ca14339b 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -90,7 +90,7 @@ textError :: IdeError -> Text textError (GeneralError msg) = msg textError (NotFound ident) = "Symbol '" <> ident <> "' not found." textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found." -textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found" +textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <> " could not be found" textError (RebuildError _ err) = show err prettyPrintTypeSingleLine :: P.Type a -> Text diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index e23010f0cb..70c780b8aa 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -69,14 +69,14 @@ resolveSynonymsAndClasses trs decls = foldr go decls trs Nothing -> acc Just tyDecl -> IdeDeclTypeClass - (IdeTypeClass tcn (tyDecl^.ideTypeKind) []) + (IdeTypeClass tcn (tyDecl ^. ideTypeKind) []) : filter (not . anyOf (_IdeDeclType . ideTypeName) (== P.coerceProperName tcn)) acc SynonymToResolve tn ty -> case findType tn acc of Nothing -> acc Just tyDecl -> - IdeDeclTypeSynonym (IdeTypeSynonym tn ty (tyDecl^.ideTypeKind)) + IdeDeclTypeSynonym (IdeTypeSynonym tn ty (tyDecl ^. ideTypeKind)) : filter (not . anyOf (_IdeDeclType . ideTypeName) (== tn)) acc findType :: P.ProperName 'P.TypeName -> [IdeDeclaration] -> Maybe IdeType @@ -103,14 +103,14 @@ convertDecl ed = case ed of -- because those are typechecker internal definitions that shouldn't -- be user facing P.EDType{..} -> Right do - guard (isNothing (Text.find (== '$') (edTypeName^.properNameT))) + guard (isNothing (Text.find (== '$') (edTypeName ^. properNameT))) Just (IdeDeclType (IdeType edTypeName edTypeKind [])) P.EDTypeSynonym{..} -> - if isNothing (Text.find (== '$') (edTypeSynonymName^.properNameT)) + if isNothing (Text.find (== '$') (edTypeSynonymName ^. properNameT)) then Left (SynonymToResolve edTypeSynonymName edTypeSynonymType) else Right Nothing P.EDDataConstructor{..} -> Right do - guard (isNothing (Text.find (== '$') (edDataCtorName^.properNameT))) + guard (isNothing (Text.find (== '$') (edDataCtorName ^. properNameT))) Just (IdeDeclDataConstructor (IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType)) diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index a3086c9e0a..1fd9df394f 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -148,7 +148,7 @@ instance FromJSON Filter where search <- params .: "search" pure (exactFilter search) "prefix" -> do - params <- o.: "params" + params <- o .: "params" search <- params .: "search" pure (prefixFilter search) "namespace" -> do @@ -156,10 +156,10 @@ instance FromJSON Filter where namespaces <- params .: "namespaces" pure (namespaceFilter (Set.fromList namespaces)) "declarations" -> do - declarations <- o.: "params" + declarations <- o .: "params" pure (declarationTypeFilter (Set.fromList declarations)) "dependencies" -> do - params <- o.: "params" + params <- o .: "params" moduleText <- params .: "moduleText" qualifier <- fmap P.moduleNameFromString <$> params .:? "qualifier" case sliceImportSection (T.lines moduleText) of diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 7f947a91b3..99e5515f17 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -207,7 +207,7 @@ populateVolatileStateSync = do (\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn))) (Map.filter reexportHasFailures results) -populateVolatileState :: (Ide m, MonadLogger m) => m (Async ()) +populateVolatileState :: Ide m => m (Async ()) populateVolatileState = do env <- ask let ll = confLogLevel (ideConfiguration env) diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index ded282c071..8616c55744 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -25,7 +25,7 @@ import Language.PureScript.Ide.Util -- module. -- 3. Apply the collected search specifications and collect the results findUsages - :: (MonadIO m, Ide m) + :: Ide m => IdeDeclaration -> P.ModuleName -> m (ModuleMap (NonEmpty P.SourceSpan)) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index bae794517c..e1552e2d07 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -178,7 +178,7 @@ handleDecls ds = do -- | Show actual loaded modules in psci. handleShowLoadedModules - :: (MonadState PSCiState m, MonadIO m) + :: MonadState PSCiState m => (String -> m ()) -> m () handleShowLoadedModules print' = do @@ -189,7 +189,7 @@ handleShowLoadedModules print' = do -- | Show the imported modules in psci. handleShowImportedModules - :: (MonadState PSCiState m, MonadIO m) + :: MonadState PSCiState m => (String -> m ()) -> m () handleShowImportedModules print' = do @@ -230,7 +230,7 @@ handleShowImportedModules print' = do commaList = T.intercalate ", " handleShowPrint - :: (MonadState PSCiState m, MonadIO m) + :: MonadState PSCiState m => (String -> m ()) -> m () handleShowPrint print' = do @@ -305,7 +305,7 @@ handleKindOf print' typ = do -- | Browse a module and displays its signature handleBrowse - :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + :: (MonadReader PSCiConfig m, MonadState PSCiState m) => (String -> m ()) -> P.ModuleName -> m () diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 145cffce95..db1373e686 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -15,7 +15,6 @@ import Control.Applicative import Control.Arrow (first, second) import Control.Monad (unless) import Control.Monad.Writer.Class -import Control.Monad.Supply.Class (MonadSupply) import Data.List (foldl', sortOn) import Data.Maybe (fromMaybe) @@ -237,7 +236,7 @@ missingAlternative env mn ca uncovered -- checkExhaustive :: forall m - . (MonadWriter MultipleErrors m, MonadSupply m) + . MonadWriter MultipleErrors m => SourceSpan -> Environment -> ModuleName @@ -292,7 +291,7 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' -- checkExhaustiveExpr :: forall m - . (MonadWriter MultipleErrors m, MonadSupply m) + . MonadWriter MultipleErrors m => SourceSpan -> Environment -> ModuleName diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index d9e7157f16..d5c0dd05f5 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -56,7 +56,7 @@ import System.FilePath (replaceExtension) -- This function is used for fast-rebuild workflows (PSCi and psc-ide are examples). rebuildModule :: forall m - . (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [ExternsFile] -> Module @@ -67,7 +67,7 @@ rebuildModule actions externs m = do rebuildModule' :: forall m - . (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> Env -> [ExternsFile] @@ -77,7 +77,7 @@ rebuildModule' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing rebuildModuleWithIndex :: forall m - . (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> Env -> [ExternsFile] @@ -136,7 +136,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ -- -- If timestamps or hashes have not changed, existing externs files can be used to provide upstream modules' types without -- having to typecheck those modules again. -make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +make :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [CST.PartialResult Module] -> m [ExternsFile] diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 27a173e754..485086b838 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -293,7 +293,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = map (\(SMap _ orig gen) -> Mapping { mapOriginal = Just $ convertPos $ add 0 (-1) orig , mapSourceFile = sourceFile - , mapGenerated = convertPos $ add (extraLines+1) 0 gen + , mapGenerated = convertPos $ add (extraLines + 1) 0 gen , mapName = Nothing }) mappings } @@ -301,7 +301,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = writeJSONFile mapFile mapping where add :: Int -> Int -> SourcePos -> SourcePos - add n m (SourcePos n' m') = SourcePos (n+n') (m+m') + add n m (SourcePos n' m') = SourcePos (n + n') (m + m') convertPos :: SourcePos -> Pos convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } = diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index cf9c2833a9..d79dc4e2f8 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -127,7 +127,7 @@ getResult buildPlan moduleName = -- The given MakeActions are used to collect various timestamps in order to -- determine whether a module needs rebuilding. construct - :: forall m. (Monad m, MonadBaseControl IO m) + :: forall m. MonadBaseControl IO m => MakeActions m -> CacheDb -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])]) diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 2f841c534b..04125f96e3 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -96,8 +96,8 @@ bumpPos :: SourcePos -> SMap -> SMap bumpPos p (SMap f s g) = SMap f s $ p `addPos` g addPos :: SourcePos -> SourcePos -> SourcePos -addPos (SourcePos n m) (SourcePos 0 m') = SourcePos n (m+m') -addPos (SourcePos n _) (SourcePos n' m') = SourcePos (n+n') m' +addPos (SourcePos n m) (SourcePos 0 m') = SourcePos n (m + m') +addPos (SourcePos n _) (SourcePos n' m') = SourcePos (n + n') m' data PrinterState = PrinterState { indent :: Int } diff --git a/src/Language/PureScript/Sugar/Names/Common.hs b/src/Language/PureScript/Sugar/Names/Common.hs index 4382342eea..9783d66dd3 100644 --- a/src/Language/PureScript/Sugar/Names/Common.hs +++ b/src/Language/PureScript/Sugar/Names/Common.hs @@ -40,7 +40,7 @@ warnDuplicateRefs pos toError refs = do -- but that requires additional changes in how warnings are printed. -- Example of keeping all duplicates (not what this code currently does): -- removeUnique [1,2,2,3,3,3,4] == [2,2,3,3,3] - removeUnique :: Eq a => Ord a => [a] -> [a] + removeUnique :: Ord a => [a] -> [a] removeUnique = concatMap (drop 1) . group . sort -- Deletes the constructor information from TypeRefs so that only the diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index 6c31cddcb6..375622a873 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -109,7 +109,6 @@ deriveNewtypeInstance :: forall m . MonadError MultipleErrors m => MonadState CheckState m - => MonadSupply m => MonadWriter MultipleErrors m => ModuleName -> Qualified (ProperName 'ClassName) diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 666fc398c6..d69e3cc7f6 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -779,7 +779,6 @@ decompose env tyName axs bxs = do -- @D@ is not a newtype, yield constraints on their arguments. canonDecomposition :: MonadError MultipleErrors m - => MonadState CheckState m => Environment -> SourceType -> SourceType @@ -797,7 +796,6 @@ canonDecomposition env a b -- newtypes, are insoluble. canonDecompositionFailure :: MonadError MultipleErrors m - => MonadState CheckState m => Environment -> SourceType -> SourceType @@ -847,7 +845,6 @@ canonDecompositionFailure env k a b -- to discharge it with the given. canonNewtypeDecomposition :: MonadError MultipleErrors m - => MonadState CheckState m => Environment -> Maybe [(SourceType, SourceType, SourceType)] -> SourceType diff --git a/tests/TestMake.hs b/tests/TestMake.hs index 75f422e8ac..7e41411e95 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -166,7 +166,7 @@ spec = do moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] } go opts = compileWithOptions opts [modulePath] >>= assertSuccess - oneSecond = 10^(6::Int) -- microseconds. + oneSecond = 10 ^ (6::Int) -- microseconds. writeFileWithTimestamp modulePath timestampA moduleContent1 go optsWithDocs `shouldReturn` moduleNames ["Module"] @@ -184,7 +184,7 @@ spec = do moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" optsCorefnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn } go opts = compileWithOptions opts [modulePath] >>= assertSuccess - oneSecond = 10^(6::Int) -- microseconds. + oneSecond = 10 ^ (6::Int) -- microseconds. writeFileWithTimestamp modulePath timestampA moduleContent1 go optsCorefnOnly `shouldReturn` moduleNames ["Module"] From df5fcff1c396d520e8543d5d85ce1455e56e2696 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Mon, 12 Dec 2022 10:17:31 -0600 Subject: [PATCH 1524/1580] Prep 0.15.7 release (#4428) --- CHANGELOG.d/feature_derive-traversable-2.md | 4 - CHANGELOG.d/feature_ide-dependency-filter.md | 6 - .../feature_ide-rebuild-without-filesystem.md | 4 - CHANGELOG.d/feature_shorten-error-message.md | 3 - CHANGELOG.d/fix_docker-install.md | 1 - CHANGELOG.d/internal_enable-ghc-warnings.md | 1 - CHANGELOG.d/internal_organize-constants.md | 1 - CHANGELOG.d/misc_bump-ghc.md | 1 - CHANGELOG.d/misc_fix-typos.md | 1 - CHANGELOG.d/misc_overlapping-let.md | 1 - CHANGELOG.md | 65 +++++- LICENSE | 206 ------------------ npm-package/package.json | 4 +- purescript.cabal | 2 +- 14 files changed, 60 insertions(+), 240 deletions(-) delete mode 100644 CHANGELOG.d/feature_derive-traversable-2.md delete mode 100644 CHANGELOG.d/feature_ide-dependency-filter.md delete mode 100644 CHANGELOG.d/feature_ide-rebuild-without-filesystem.md delete mode 100644 CHANGELOG.d/feature_shorten-error-message.md delete mode 100644 CHANGELOG.d/fix_docker-install.md delete mode 100644 CHANGELOG.d/internal_enable-ghc-warnings.md delete mode 100644 CHANGELOG.d/internal_organize-constants.md delete mode 100644 CHANGELOG.d/misc_bump-ghc.md delete mode 100644 CHANGELOG.d/misc_fix-typos.md delete mode 100644 CHANGELOG.d/misc_overlapping-let.md diff --git a/CHANGELOG.d/feature_derive-traversable-2.md b/CHANGELOG.d/feature_derive-traversable-2.md deleted file mode 100644 index 03d755aac2..0000000000 --- a/CHANGELOG.d/feature_derive-traversable-2.md +++ /dev/null @@ -1,4 +0,0 @@ -* The compiler can now derive instances of `Bifunctor`, `Bifoldable`, - `Bitraversable`, `Contravariant`, and `Profunctor`, as well as use those - classes when deriving `Functor`, `Foldable`, and `Traversable`, enabling more - instances to be derived. diff --git a/CHANGELOG.d/feature_ide-dependency-filter.md b/CHANGELOG.d/feature_ide-dependency-filter.md deleted file mode 100644 index 66d9b6b1a4..0000000000 --- a/CHANGELOG.d/feature_ide-dependency-filter.md +++ /dev/null @@ -1,6 +0,0 @@ -```markdown -* Add `purs ide` dependency/imports filter (#4412 by @nwolverson) - - This allows IDE tooling to filter type searches according to the imports of a given module, - restricting to identifiers in scope. -``` diff --git a/CHANGELOG.d/feature_ide-rebuild-without-filesystem.md b/CHANGELOG.d/feature_ide-rebuild-without-filesystem.md deleted file mode 100644 index 7bb4b533d6..0000000000 --- a/CHANGELOG.d/feature_ide-rebuild-without-filesystem.md +++ /dev/null @@ -1,4 +0,0 @@ -* Allow IDE module rebuilds eschewing the filesystem - - This allows IDE clients to typecheck the module the user is currently typing in without modifying the output. - This allows for faster feedback cycles in editors and avoids producing a broken `/output` before the user actually saves the file. diff --git a/CHANGELOG.d/feature_shorten-error-message.md b/CHANGELOG.d/feature_shorten-error-message.md deleted file mode 100644 index 45697cdc2f..0000000000 --- a/CHANGELOG.d/feature_shorten-error-message.md +++ /dev/null @@ -1,3 +0,0 @@ -* Shorten the prefix for custom user defined error - messages to improve clarity and get to the relevant information - more quickly diff --git a/CHANGELOG.d/fix_docker-install.md b/CHANGELOG.d/fix_docker-install.md deleted file mode 100644 index 43702cada7..0000000000 --- a/CHANGELOG.d/fix_docker-install.md +++ /dev/null @@ -1 +0,0 @@ -* Update installer to `0.3.3` to fix a few installation issues \ No newline at end of file diff --git a/CHANGELOG.d/internal_enable-ghc-warnings.md b/CHANGELOG.d/internal_enable-ghc-warnings.md deleted file mode 100644 index ed226bbb36..0000000000 --- a/CHANGELOG.d/internal_enable-ghc-warnings.md +++ /dev/null @@ -1 +0,0 @@ -* Enable more GHC warnings diff --git a/CHANGELOG.d/internal_organize-constants.md b/CHANGELOG.d/internal_organize-constants.md deleted file mode 100644 index 1d0f0103d5..0000000000 --- a/CHANGELOG.d/internal_organize-constants.md +++ /dev/null @@ -1 +0,0 @@ -* Organize the compiler's internal constants files diff --git a/CHANGELOG.d/misc_bump-ghc.md b/CHANGELOG.d/misc_bump-ghc.md deleted file mode 100644 index 4ae15f7020..0000000000 --- a/CHANGELOG.d/misc_bump-ghc.md +++ /dev/null @@ -1 +0,0 @@ -* Bump Stackage snapshot to 2022-11-12 and GHC to 9.2.4 diff --git a/CHANGELOG.d/misc_fix-typos.md b/CHANGELOG.d/misc_fix-typos.md deleted file mode 100644 index 6daaeb3cc1..0000000000 --- a/CHANGELOG.d/misc_fix-typos.md +++ /dev/null @@ -1 +0,0 @@ -* Fix various typos in documentation and source comments. \ No newline at end of file diff --git a/CHANGELOG.d/misc_overlapping-let.md b/CHANGELOG.d/misc_overlapping-let.md deleted file mode 100644 index 0100fe2e42..0000000000 --- a/CHANGELOG.d/misc_overlapping-let.md +++ /dev/null @@ -1 +0,0 @@ -* Improve `DuplicateDeclarationsInLet` error so that it mentions what variable names were duplicated, reporting several in separate errors as necessary. diff --git a/CHANGELOG.md b/CHANGELOG.md index f3dbe6af11..5314a5561e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,55 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.7 + +New features: + +* Allow IDE module rebuilds eschewing the filesystem (#4399 by @i-am-the-slime) + + This allows IDE clients to typecheck the module the user is currently typing in without modifying the output. + This allows for faster feedback cycles in editors and avoids producing a broken `/output` before the user actually saves the file. + +* Add `purs ide` dependency/imports filter (#4412 by @nwolverson) + + This allows IDE tooling to filter type searches according to the imports of a given module, + restricting to identifiers in scope. + +* Shorten custom user-defined error message's prefix (#4418 by @i-am-the-slime) + + Improves clarity and gets to the relevant information faster. + +* The compiler can now derive instances for more types and type classes (#4420 by @rhendric) + + New type classes that the compiler can derive: + - `Bifunctor` + - `Bifoldable` + - `Bitraversable` + - `Contravariant` + - `Profunctor` + + Moreover, the compiler can also use these classes when deriving + `Functor`, `Foldable`, and `Traversable`, enabling more instances to be derived + whereas before such instances would need to be written manually. + +Bugfixes: + +* Update installer to `0.3.3` to fix a few installation issues (#4425 by @JordanMartinez) + +Other improvements: + +* Improve `DuplicateDeclarationsInLet` error so that it mentions what variable names were duplicated, reporting several in separate errors as necessary. (#4405 by @MonoidMusician) + +* Fix various typos in documentation and source comments. (#4415 by @Deltaspace0) + +* Bump Stackage snapshot to 2022-11-12 and GHC to 9.2.4 (#4422 by @purefunctor) + +Internal: + +* Organize the compiler's internal constants files (#4406 by @rhendric) + +* Enable more GHC warnings (#4429 by @rhendric) + ## 0.15.6 Bugfixes: @@ -3194,14 +3243,14 @@ The way names are resolved has now been updated in a way that may result in some Some examples: -| Import statement | Exposed members | -| --- | --- | -| `import X` | `A`, `f` | -| `import X as Y` | `Y.A` `Y.f` | -| `import X (A)` | `A` | -| `import X (A) as Y` | `Y.A` | -| `import X hiding (f)` | `A` | -| `import Y hiding (f) as Y` | `Y.A` | +| Import statement | Exposed members | +| -------------------------- | --------------- | +| `import X` | `A`, `f` | +| `import X as Y` | `Y.A` `Y.f` | +| `import X (A)` | `A` | +| `import X (A) as Y` | `Y.A` | +| `import X hiding (f)` | `A` | +| `import Y hiding (f) as Y` | `Y.A` | Qualified references like `Control.Monad.Eff.Console.log` will no longer resolve unless there is a corresponding `import Control.Monad.Eff.Console as Control.Monad.Eff.Console`. Importing a module unqualified does not allow you to reference it with qualification, so `import X` does not allow references to `X.A` unless there is also an `import X as X`. diff --git a/LICENSE b/LICENSE index 0acf73c6ea..29d843bea4 100644 --- a/LICENSE +++ b/LICENSE @@ -22,7 +22,6 @@ PureScript uses the following Haskell library packages. Their license files foll adjunctions aeson aeson-better-errors - aeson-pretty alex ansi-terminal ansi-wl-pprint @@ -45,9 +44,7 @@ PureScript uses the following Haskell library packages. Their license files foll boxes bytestring call-stack - case-insensitive cborg - cereal cheapskate clock colour @@ -77,15 +74,12 @@ PureScript uses the following Haskell library packages. Their license files foll file-embed filepath free - fsnotify ghc-bignum ghc-prim half happy hashable haskeline - hfsevents - http-types indexed-traversable indexed-traversable-instances integer-gmp @@ -422,39 +416,6 @@ aeson-better-errors LICENSE file: TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -aeson-pretty LICENSE file: - - Copyright (c)2011, Falko Peters - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Falko Peters nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - alex LICENSE file: Copyright (c) 1995-2011, Chris Dornan and Simon Marlow @@ -1204,40 +1165,6 @@ call-stack LICENSE file: OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -case-insensitive LICENSE file: - - Copyright (c) 2011-2013 Bas van Dijk - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are - met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * The name of Bas van Dijk and the names of contributors may NOT - be used to endorse or promote products derived from this - software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - cborg LICENSE file: Copyright (c) 2015-2017 Duncan Coutts, @@ -1274,39 +1201,6 @@ cborg LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -cereal LICENSE file: - - Copyright (c) Lennart Kolmodin, Galois, Inc. - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - 3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS - OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - cheapskate LICENSE file: Copyright (c) 2013, John MacFarlane @@ -2200,39 +2094,6 @@ free LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -fsnotify LICENSE file: - - Copyright (c) 2012, Mark Dittmer - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Mark Dittmer nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - ghc-bignum LICENSE file: The Glasgow Haskell Compiler License @@ -2456,73 +2317,6 @@ haskeline LICENSE file: OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -hfsevents LICENSE file: - - Copyright (c) 2012, Luite Stegeman - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Luite Stegeman nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -http-types LICENSE file: - - Copyright (c) 2011, Aristid Breitkreuz - Copyright (c) 2011, Michael Snoyman - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Aristid Breitkreuz nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - indexed-traversable LICENSE file: Copyright 2012-2016 Edward Kmett diff --git a/npm-package/package.json b/npm-package/package.json index e3eb7ab648..1cb36d4747 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.6", + "version": "0.15.7", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.6", + "postinstall": "install-purescript --purs-ver=0.15.7", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index 170f09a01a..cefdd51b3c 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.6 +version: 0.15.7 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 3cf73939a4869090fb108d2e14de852ae513568b Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 9 Jan 2023 15:56:17 -0500 Subject: [PATCH 1525/1580] Fix instance deriving regression (#4432) --- CHANGELOG.d/fix_4431.purs | 1 + src/Language/PureScript/AST/Utils.hs | 14 ++- .../PureScript/Sugar/TypeClasses/Deriving.hs | 8 +- .../PureScript/TypeChecker/Deriving.hs | 118 ++++++++++-------- tests/purs/passing/4431-2.purs | 12 ++ tests/purs/passing/4431.purs | 11 ++ 6 files changed, 106 insertions(+), 58 deletions(-) create mode 100644 CHANGELOG.d/fix_4431.purs create mode 100644 tests/purs/passing/4431-2.purs create mode 100644 tests/purs/passing/4431.purs diff --git a/CHANGELOG.d/fix_4431.purs b/CHANGELOG.d/fix_4431.purs new file mode 100644 index 0000000000..05b8333c92 --- /dev/null +++ b/CHANGELOG.d/fix_4431.purs @@ -0,0 +1 @@ +* Fix instance deriving regression diff --git a/src/Language/PureScript/AST/Utils.hs b/src/Language/PureScript/AST/Utils.hs index 4e28f6e6ef..a62ed5593e 100644 --- a/src/Language/PureScript/AST/Utils.hs +++ b/src/Language/PureScript/AST/Utils.hs @@ -39,11 +39,21 @@ mkCtorBinder mn name = ConstructorBinder nullSourceSpan (Qualified (ByModuleName unguarded :: Expr -> [GuardedExpr] unguarded e = [MkUnguarded e] -unwrapTypeConstructor :: SourceType -> Maybe (Qualified (ProperName 'TypeName), [SourceType], [SourceType]) +data UnwrappedTypeConstructor = UnwrappedTypeConstructor + { utcModuleName :: ModuleName + , utcTyCon :: ProperName 'TypeName + , utcKindArgs :: [SourceType] + , utcArgs :: [SourceType] + } + +utcQTyCon :: UnwrappedTypeConstructor -> Qualified (ProperName 'TypeName) +utcQTyCon UnwrappedTypeConstructor{..} = Qualified (ByModuleName utcModuleName) utcTyCon + +unwrapTypeConstructor :: SourceType -> Maybe UnwrappedTypeConstructor unwrapTypeConstructor = go [] [] where go kargs args = \case - TypeConstructor _ tyCon -> Just (tyCon, kargs, args) + TypeConstructor _ (Qualified (ByModuleName mn) tyCon) -> Just (UnwrappedTypeConstructor mn tyCon kargs args) TypeApp _ ty arg -> go kargs (arg : args) ty KindApp _ ty karg -> go (karg : kargs) args ty _ -> Nothing diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index bcd401a5bc..2389831c1e 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -49,10 +49,10 @@ deriveInstance mn ds decl = binaryWildcardClass :: (Declaration -> [SourceType] -> m ([Declaration], SourceType)) -> m Declaration binaryWildcardClass f = case tys of [ty1, ty2] -> case unwrapTypeConstructor ty1 of - Just (Qualified (ByModuleName mn') tyCon, _, args) | mn == mn' -> do - checkIsWildcard ss tyCon ty2 - tyConDecl <- findTypeDecl ss tyCon ds - (members, ty2') <- f tyConDecl args + Just UnwrappedTypeConstructor{..} | mn == utcModuleName -> do + checkIsWildcard ss utcTyCon ty2 + tyConDecl <- findTypeDecl ss utcTyCon ds + (members, ty2') <- f tyConDecl utcArgs pure $ TypeInstanceDeclaration sa na ch idx nm deps className [ty1, ty2'] (ExplicitInstance members) _ -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty1 _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index 375622a873..8261802178 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -42,7 +42,7 @@ import Language.PureScript.Types -- we just match the newtype name. extractNewtypeName :: ModuleName -> [SourceType] -> Maybe (ModuleName, ProperName 'TypeName) extractNewtypeName mn - = fmap (\(n, _, _) -> qualify mn n) + = fmap (qualify mn . utcQTyCon) . (unwrapTypeConstructor <=< lastMay) deriveInstance @@ -58,7 +58,8 @@ deriveInstance deriveInstance instType className strategy = do mn <- unsafeCheckCurrentModule env <- getEnv - (fmap coerceProperName -> ctorName, _, tys) <- maybe (internalCompilerError "invalid instance type") pure $ unwrapTypeConstructor instType + instUtc@UnwrappedTypeConstructor{ utcArgs = tys } <- maybe (internalCompilerError "invalid instance type") pure $ unwrapTypeConstructor instType + let ctorName = coerceProperName <$> utcQTyCon instUtc TypeClassData{..} <- note (errorMessage . UnknownName $ fmap TyClassName className) $ @@ -66,15 +67,15 @@ deriveInstance instType className strategy = do case strategy of KnownClassStrategy -> let - unaryClass :: (ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)]) -> m Expr + unaryClass :: (UnwrappedTypeConstructor -> m [(PSString, Expr)]) -> m Expr unaryClass f = case tys of [ty] -> case unwrapTypeConstructor ty of - Just (Qualified (ByModuleName mn') tyCon, _, _) | mn == mn' -> do + Just utc | mn == utcModuleName utc -> do let superclassesDicts = flip map typeClassSuperclasses $ \(Constraint _ superclass _ suTyArgs _) -> let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs in lam UnusedIdent (DeferredDictionary superclass tyArgs) let superclasses = map mkString (superClassDictionaryNames typeClassSuperclasses) `zip` superclassesDicts - App (Constructor nullSourceSpan ctorName) . mkLit . ObjectLiteral . (++ superclasses) <$> f mn tyCon + App (Constructor nullSourceSpan ctorName) . mkLit . ObjectLiteral . (++ superclasses) <$> f utc _ -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 @@ -86,11 +87,11 @@ deriveInstance instType className strategy = do Libs.Bitraversable -> unaryClass' $ deriveTraversable True Libs.Contravariant -> unaryClass' $ deriveFunctor Nothing True Libs.S_cmap Libs.Eq -> unaryClass deriveEq - Libs.Eq1 -> unaryClass $ \_ _ -> deriveEq1 + Libs.Eq1 -> unaryClass $ const deriveEq1 Libs.Foldable -> unaryClass' $ deriveFoldable False Libs.Functor -> unaryClass' $ deriveFunctor Nothing False Libs.S_map Libs.Ord -> unaryClass deriveOrd - Libs.Ord1 -> unaryClass $ \_ _ -> deriveOrd1 + Libs.Ord1 -> unaryClass $ const deriveOrd1 Libs.Profunctor -> unaryClass' $ deriveFunctor (Just True) False Libs.S_dimap Libs.Traversable -> unaryClass' $ deriveTraversable False -- See L.P.Sugar.TypeClasses.Deriving for the classes that can be @@ -99,9 +100,9 @@ deriveInstance instType className strategy = do NewtypeStrategy -> case tys of - _ : _ | Just (Qualified (ByModuleName mn') tyCon, kargs, args) <- unwrapTypeConstructor (last tys) - , mn == mn' - -> deriveNewtypeInstance mn className tys tyCon kargs args + _ : _ | Just utc <- unwrapTypeConstructor (last tys) + , mn == utcModuleName utc + -> deriveNewtypeInstance className tys utc | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys (last tys) _ -> throwError . errorMessage $ InvalidNewtypeInstance className tys @@ -110,14 +111,11 @@ deriveNewtypeInstance . MonadError MultipleErrors m => MonadState CheckState m => MonadWriter MultipleErrors m - => ModuleName - -> Qualified (ProperName 'ClassName) - -> [SourceType] - -> ProperName 'TypeName - -> [SourceType] + => Qualified (ProperName 'ClassName) -> [SourceType] + -> UnwrappedTypeConstructor -> m Expr -deriveNewtypeInstance mn className tys tyConNm dkargs dargs = do +deriveNewtypeInstance className tys (UnwrappedTypeConstructor mn tyConNm dkargs dargs) = do verifySuperclasses (dtype, tyKindNames, tyArgNames, ctors) <- lookupTypeDecl mn tyConNm go dtype tyKindNames tyArgNames ctors @@ -190,17 +188,33 @@ deriveNewtypeInstance mn className tys tyConNm dkargs dargs = do $ dicts in lookIn suModule || lookIn newtypeModule +data TypeInfo = TypeInfo + { tiTypeParams :: [Text] + , tiCtors :: [(ProperName 'ConstructorName, [SourceType])] + , tiArgSubst :: [(Text, SourceType)] + } + +lookupTypeInfo + :: forall m + . MonadError MultipleErrors m + => MonadState CheckState m + => UnwrappedTypeConstructor + -> m TypeInfo +lookupTypeInfo UnwrappedTypeConstructor{..} = do + (_, kindParams, map fst -> tiTypeParams, tiCtors) <- lookupTypeDecl utcModuleName utcTyCon + let tiArgSubst = zip tiTypeParams utcArgs <> zip kindParams utcKindArgs + pure TypeInfo{..} + deriveEq :: forall m . MonadError MultipleErrors m => MonadState CheckState m => MonadSupply m - => ModuleName - -> ProperName 'TypeName + => UnwrappedTypeConstructor -> m [(PSString, Expr)] -deriveEq mn tyConNm = do - (_, _, _, ctors) <- lookupTypeDecl mn tyConNm - eqFun <- mkEqFunction ctors +deriveEq utc = do + TypeInfo{..} <- lookupTypeInfo utc + eqFun <- mkEqFunction tiCtors pure [(Libs.S_eq, eqFun)] where mkEqFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr @@ -233,7 +247,7 @@ deriveEq mn tyConNm = do let tests = zipWith3 toEqTest (map mkVar identsL) (map mkVar identsR) tys' return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (unguarded (conjAll tests)) where - caseBinder idents = mkCtorBinder mn ctorName $ map mkBinder idents + caseBinder idents = mkCtorBinder (utcModuleName utc) ctorName $ map mkBinder idents conjAll :: [Expr] -> Expr conjAll = \case @@ -257,12 +271,11 @@ deriveOrd . MonadError MultipleErrors m => MonadState CheckState m => MonadSupply m - => ModuleName - -> ProperName 'TypeName + => UnwrappedTypeConstructor -> m [(PSString, Expr)] -deriveOrd mn tyConNm = do - (_, _, _, ctors) <- lookupTypeDecl mn tyConNm - compareFun <- mkCompareFunction ctors +deriveOrd utc = do + TypeInfo{..} <- lookupTypeInfo utc + compareFun <- mkCompareFunction tiCtors pure [(Libs.S_compare, compareFun)] where mkCompareFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr @@ -315,6 +328,7 @@ deriveOrd mn tyConNm = do : extras where + mn = utcModuleName utc caseBinder idents = mkCtorBinder mn ctorName $ map mkBinder idents nullCaseBinder = mkCtorBinder mn ctorName $ replicate (length tys) NullBinder @@ -426,32 +440,31 @@ validateParamsInTypeConstructors . MonadError MultipleErrors m => MonadState CheckState m => Qualified (ProperName 'ClassName) - -> ModuleName - -> ProperName 'TypeName + -> UnwrappedTypeConstructor -> Bool -> CovariantClasses -> Maybe (ContravarianceSupport c) -> m [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])] -validateParamsInTypeConstructors derivingClass mn tyConNm isBi CovariantClasses{..} contravarianceSupport = do - (_, _, tyArgNames, ctors) <- lookupTypeDecl mn tyConNm +validateParamsInTypeConstructors derivingClass utc isBi CovariantClasses{..} contravarianceSupport = do + TypeInfo{..} <- lookupTypeInfo utc (mbLParam, param) <- liftEither . first (errorMessage . flip KindsDoNotUnify kindType . (kindType -:>)) $ - case (isBi, reverse $ map fst tyArgNames) of + case (isBi, reverse tiTypeParams) of (False, x : _) -> Right (Nothing, x) (False, _) -> Left kindType (True, y : x : _) -> Right (Just x, y) (True, _ : _) -> Left kindType (True, _) -> Left $ kindType -:> kindType - ctors' <- traverse (traverse $ traverse replaceAllTypeSynonyms) ctors + ctors <- traverse (traverse $ traverse replaceAllTypeSynonyms) tiCtors tcds <- getTypeClassDictionaries - let (ctorUsages, problemSpans) = runWriter $ traverse (traverse . traverse $ typeToUsageOf tcds (maybe That These mbLParam param) False) ctors' + let (ctorUsages, problemSpans) = runWriter $ traverse (traverse . traverse $ typeToUsageOf tcds tiArgSubst (maybe That These mbLParam param) False) ctors let relatedClasses = [monoClass, biClass] ++ ([contraClass, proClass] <*> (contravariantClasses <$> toList contravarianceSupport)) for_ (nonEmpty $ ordNub problemSpans) $ \sss -> throwError . addHint (RelatedPositions sss) . errorMessage $ CannotDeriveInvalidConstructorArg derivingClass relatedClasses (isJust contravarianceSupport) pure ctorUsages where - typeToUsageOf :: InstanceContext -> These Text Text -> Bool -> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c)) - typeToUsageOf tcds = fix $ \go params isNegative -> let + typeToUsageOf :: InstanceContext -> [(Text, SourceType)] -> These Text Text -> Bool -> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c)) + typeToUsageOf tcds subst = fix $ \go params isNegative -> let goCo = go params isNegative goContra = go params $ not isNegative @@ -482,6 +495,9 @@ validateParamsInTypeConstructors derivingClass mn tyConNm isBi CovariantClasses{ | otherwise = assertNoParamUsedIn tyArg $> Nothing + headOfTypeWithSubst :: SourceType -> Qualified (Either Text (ProperName 'TypeName)) + headOfTypeWithSubst = headOfType . replaceAllTypeVars subst + in \case ForAll _ name _ ty _ -> fmap join . traverse (\params' -> go params' isNegative ty) $ filterThese (/= name) params @@ -494,10 +510,10 @@ validateParamsInTypeConstructors derivingClass mn tyConNm isBi CovariantClasses{ fmap (lbl, ) <$> goCo ty TypeApp _ (TypeApp _ tyFn tyLArg) tyArg -> - assertNoParamUsedIn tyFn *> tryBiClasses (headOfType tyFn) tyLArg tyArg + assertNoParamUsedIn tyFn *> tryBiClasses (headOfTypeWithSubst tyFn) tyLArg tyArg TypeApp _ tyFn tyArg -> - assertNoParamUsedIn tyFn *> tryMonoClasses (headOfType tyFn) tyArg + assertNoParamUsedIn tyFn *> tryMonoClasses (headOfTypeWithSubst tyFn) tyArg TypeVar (ss, _) name -> mergeTheseWith (checkName lparamIsContra IsLParam) (checkName paramIsContra IsParam) (liftA2 (<|>)) params where @@ -636,17 +652,16 @@ deriveFunctor -> Bool -- is the (right) parameter contravariant? -> PSString -- name of the map function for this functor type -> Qualified (ProperName 'ClassName) - -> ModuleName - -> ProperName 'TypeName + -> UnwrappedTypeConstructor -> m [(PSString, Expr)] -deriveFunctor mbLParamIsContravariant paramIsContravariant mapName nm mn tyConNm = do - ctors <- validateParamsInTypeConstructors nm mn tyConNm isBi functorClasses $ Just $ ContravarianceSupport +deriveFunctor mbLParamIsContravariant paramIsContravariant mapName nm utc = do + ctors <- validateParamsInTypeConstructors nm utc isBi functorClasses $ Just $ ContravarianceSupport { contravarianceWitness = () , paramIsContravariant , lparamIsContravariant = or mbLParamIsContravariant , contravariantClasses } - mapFun <- mkTraversal mn isBi mapExprs (const cmapExprs) (TraversalOps identity identity) ctors + mapFun <- mkTraversal (utcModuleName utc) isBi mapExprs (const cmapExprs) (TraversalOps identity identity) ctors pure [(mapName, mapFun)] where isBi = isJust mbLParamIsContravariant @@ -681,11 +696,10 @@ deriveFoldable => MonadSupply m => Bool -- is there a left parameter (are we deriving Bifoldable)? -> Qualified (ProperName 'ClassName) - -> ModuleName - -> ProperName 'TypeName + -> UnwrappedTypeConstructor -> m [(PSString, Expr)] -deriveFoldable isBi nm mn tyConNm = do - ctors <- validateParamsInTypeConstructors nm mn tyConNm isBi foldableClasses Nothing +deriveFoldable isBi nm utc = do + ctors <- validateParamsInTypeConstructors nm utc isBi foldableClasses Nothing foldlFun <- mkAsymmetricFoldFunction False foldlExprs ctors foldrFun <- mkAsymmetricFoldFunction True foldrExprs ctors foldMapFun <- mkTraversal mn isBi foldMapExprs absurd foldMapOps ctors @@ -695,6 +709,7 @@ deriveFoldable isBi nm mn tyConNm = do , (if isBi then Libs.S_bifoldMap else Libs.S_foldMap, foldMapFun) ] where + mn = utcModuleName utc foldableClasses = CovariantClasses Libs.Foldable Libs.Bifoldable foldlExprs = TraversalExprs { recurseVar = mkRef Libs.I_foldl @@ -778,12 +793,11 @@ deriveTraversable => MonadSupply m => Bool -- is there a left parameter (are we deriving Bitraversable)? -> Qualified (ProperName 'ClassName) - -> ModuleName - -> ProperName 'TypeName + -> UnwrappedTypeConstructor -> m [(PSString, Expr)] -deriveTraversable isBi nm mn tyConNm = do - ctors <- validateParamsInTypeConstructors nm mn tyConNm isBi traversableClasses Nothing - traverseFun <- mkTraversal mn isBi traverseExprs absurd traverseOps ctors +deriveTraversable isBi nm utc = do + ctors <- validateParamsInTypeConstructors nm utc isBi traversableClasses Nothing + traverseFun <- mkTraversal (utcModuleName utc) isBi traverseExprs absurd traverseOps ctors sequenceFun <- usingLamIdent $ pure . App (App (if isBi then App bitraverseVar identityVar else traverseVar) identityVar) pure [ (if isBi then Libs.S_bitraverse else Libs.S_traverse, traverseFun) diff --git a/tests/purs/passing/4431-2.purs b/tests/purs/passing/4431-2.purs new file mode 100644 index 0000000000..5d0d9823d6 --- /dev/null +++ b/tests/purs/passing/4431-2.purs @@ -0,0 +1,12 @@ +module Main where + +import Prelude +import Data.Const (Const) +import Effect.Console (log) + +data TypedCache :: (Type -> Type) -> Type -> Type +data TypedCache key a = Get (key a) + +derive instance Functor (TypedCache (Const k)) + +main = log "Done" diff --git a/tests/purs/passing/4431.purs b/tests/purs/passing/4431.purs new file mode 100644 index 0000000000..682117ef52 --- /dev/null +++ b/tests/purs/passing/4431.purs @@ -0,0 +1,11 @@ +module Main where + +import Prelude +import Effect.Console (log) + +data TypedCache :: (Type -> Type) -> Type -> Type +data TypedCache key a = Get (key a) + +derive instance Functor k => Functor (TypedCache k) + +main = log "Done" From 7a5b2b81374b0ad48be1482fd5b1d7d02bff02ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Edvard=20Th=C3=B6rnros?= Date: Wed, 1 Feb 2023 15:35:38 +0100 Subject: [PATCH 1526/1580] Mention which row label the type error occurs on (#4411) Keep track of row labels as hints when recursing during unification and subsumption. --- .../fix_add-labels-in-type-mismatch-errors.md | 1 + CONTRIBUTORS.md | 1 + src/Language/PureScript/AST/Declarations.hs | 1 + src/Language/PureScript/Errors.hs | 6 ++++ .../PureScript/TypeChecker/Entailment.hs | 4 +-- .../TypeChecker/Entailment/Coercible.hs | 2 +- src/Language/PureScript/TypeChecker/Kinds.hs | 3 +- .../PureScript/TypeChecker/Subsumption.hs | 4 ++- src/Language/PureScript/TypeChecker/Unify.hs | 4 ++- src/Language/PureScript/Types.hs | 11 +++--- .../failing/NestedRecordLabelOnTypeError.out | 34 +++++++++++++++++++ .../failing/NestedRecordLabelOnTypeError.purs | 8 +++++ tests/purs/failing/RecordLabelOnTypeError.out | 26 ++++++++++++++ .../purs/failing/RecordLabelOnTypeError.purs | 8 +++++ .../RecordLabelOnTypeErrorImmediate.out | 22 ++++++++++++ .../RecordLabelOnTypeErrorImmediate.purs | 5 +++ 16 files changed, 129 insertions(+), 11 deletions(-) create mode 100644 CHANGELOG.d/fix_add-labels-in-type-mismatch-errors.md create mode 100644 tests/purs/failing/NestedRecordLabelOnTypeError.out create mode 100644 tests/purs/failing/NestedRecordLabelOnTypeError.purs create mode 100644 tests/purs/failing/RecordLabelOnTypeError.out create mode 100644 tests/purs/failing/RecordLabelOnTypeError.purs create mode 100644 tests/purs/failing/RecordLabelOnTypeErrorImmediate.out create mode 100644 tests/purs/failing/RecordLabelOnTypeErrorImmediate.purs diff --git a/CHANGELOG.d/fix_add-labels-in-type-mismatch-errors.md b/CHANGELOG.d/fix_add-labels-in-type-mismatch-errors.md new file mode 100644 index 0000000000..f658f51f9a --- /dev/null +++ b/CHANGELOG.d/fix_add-labels-in-type-mismatch-errors.md @@ -0,0 +1 @@ + * Outputs what label the type-error occurred on when types don't match diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 9c62eee433..d029c433af 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -160,6 +160,7 @@ If you would prefer to use different terms, please use the section below instead | [@sd-yip](https://github.com/sd-yip) | Nicholas Yip | [MIT license](http://opensource.org/licenses/MIT) | | [@j-nava](https://github.com/j-nava) | Jesse Nava | [MIT license](http://opensource.org/licenses/MIT) | | [@imcotton](https://github.com/imcotton) | Cotton Hou | [MIT license](http://opensource.org/licenses/MIT) | +| [@FredTheDino](https://github.com/FredTheDino) | Edvard Thörnros | [MIT license](http://opensource.org/licenses/MIT) | | [@wclr](https://github.com/wclr) | Alex Osh | [MIT license](http://opensource.org/licenses/MIT) | | [@Deltaspace0](https://github.com/Deltaspace0) | Ruslan Gadeev | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 2ac1ee1ded..87490404d2 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -66,6 +66,7 @@ data ErrorMessageHint | ErrorInModule ModuleName | ErrorInInstance (Qualified (ProperName 'ClassName)) [SourceType] | ErrorInSubsumption SourceType SourceType + | ErrorInRowLabel Label | ErrorCheckingAccessor Expr PSString | ErrorCheckingType Expr SourceType | ErrorCheckingKind SourceType SourceType diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 3302625670..824d5d0b7b 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1433,6 +1433,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon , markCodeBox $ typeAsBox prettyDepth t2 ] ] + renderHint (ErrorInRowLabel lb) detail = + paras [ detail + , Box.hsep 1 Box.top [ line "while matching label" + , markCodeBox $ line $ prettyPrintObjectKey (runLabel lb) + ] + ] renderHint (ErrorInInstance nm ts) detail = paras [ detail , line "in type class instance" diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index d5b315d490..393f637b6a 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -751,7 +751,7 @@ matches deps TypeClassDictionaryInScope{..} tys = typeHeadsAreEqual r1@RCons{} r2@RCons{} = foldr both (uncurry go rest) common where - (common, rest) = alignRowsWith typeHeadsAreEqual r1 r2 + (common, rest) = alignRowsWith (const typeHeadsAreEqual) r1 r2 go :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> (Matched (), Matching [Type a]) go (l, KindedType _ t1 _) (r, t2) = go (l, t1) (r, t2) @@ -796,7 +796,7 @@ matches deps TypeClassDictionaryInScope{..} tys = typesAreEqual (KindApp _ h1 t1) (KindApp _ h2 t2) = typesAreEqual h1 h2 <> typesAreEqual t1 t2 typesAreEqual (REmpty _) (REmpty _) = Match () typesAreEqual r1 r2 | isRCons r1 || isRCons r2 = - let (common, rest) = alignRowsWith typesAreEqual r1 r2 + let (common, rest) = alignRowsWith (const typesAreEqual) r1 r2 in fold common <> uncurry go rest where go :: ([RowListItem a], Type a) -> ([RowListItem a], Type a) -> Matched () diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index d69e3cc7f6..301e4b6e8d 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -584,7 +584,7 @@ canonRow -> MaybeT m Canonicalized canonRow a b | RCons{} <- a = - case alignRowsWith (,) a b of + case alignRowsWith (const (,)) a b of -- We throw early when a bare unknown remains on either side after -- aligning the rows because we don't know how to canonicalize them yet -- and the unification error thrown when the rows are misaligned should diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index e9ddf6cd31..56dc95aa06 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -419,6 +419,7 @@ unifyKindsWithFailure -> m () unifyKindsWithFailure onFailure = go where + goWithLabel l t1 t2 = withErrorMessageHint (ErrorInRowLabel l) $ go t1 t2 go = curry $ \case (TypeApp _ p1 p2, TypeApp _ p3 p4) -> do go p1 p3 @@ -444,7 +445,7 @@ unifyKindsWithFailure onFailure = go onFailure w1 w2 unifyRows r1 r2 = do - let (matches, rest) = alignRowsWith go r1 r2 + let (matches, rest) = alignRowsWith goWithLabel r1 r2 sequence_ matches unifyTails rest diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index be6e9f292c..8fdd798990 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -103,7 +103,8 @@ subsumes' SElaborate (ConstrainedType _ con ty1) ty2 = do let addDicts val = App val (TypeClassDictionary con dicts hints) return (elaborate . addDicts) subsumes' mode (TypeApp _ f1 r1) (TypeApp _ f2 r2) | eqType f1 tyRecord && eqType f2 tyRecord = do - let (common, ((ts1', r1'), (ts2', r2'))) = alignRowsWith (subsumes' SNoElaborate) r1 r2 + let goWithLabel l t1 t2 = withErrorMessageHint (ErrorInRowLabel l) $ subsumes' SNoElaborate t1 t2 + let (common, ((ts1', r1'), (ts2', r2'))) = alignRowsWith goWithLabel r1 r2 -- For { ts1 | r1 } to subsume { ts2 | r2 } when r1 is empty (= we're working with a closed row), -- every property in ts2 must appear in ts1. If not, then the candidate expression is missing a required property. -- Conversely, when r2 is empty, every property in ts1 must appear in ts2, or else the expression has @@ -114,6 +115,7 @@ subsumes' mode (TypeApp _ f1 r1) (TypeApp _ f2 r2) | eqType f1 tyRecord && eqTyp (for_ (firstMissingProp ts1' ts2') (throwError . errorMessage . AdditionalProperty . rowListLabel)) -- Check subsumption for common labels sequence_ common + -- Inject the info here unifyTypes (rowFromList (ts1', r1')) (rowFromList (ts2', r2')) -- Nothing was elaborated, return the default coercion return (defaultCoercion mode) diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 38e181b365..1d59876d88 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -162,7 +162,9 @@ unifyTypes t1 t2 = do -- trailing row unification variable, if appropriate. unifyRows :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) => SourceType -> SourceType -> m () unifyRows r1 r2 = sequence_ matches *> uncurry unifyTails rest where - (matches, rest) = alignRowsWith unifyTypes r1 r2 + unifyTypesWithLabel l t1 t2 = withErrorMessageHint (ErrorInRowLabel l) $ unifyTypes t1 t2 + + (matches, rest) = alignRowsWith unifyTypesWithLabel r1 r2 unifyTails :: ([RowListItem SourceAnn], SourceType) -> ([RowListItem SourceAnn], SourceType) -> m () unifyTails ([], TUnknown _ u) (sd, r) = solveType u (rowFromList (sd, r)) diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 6e394cd980..b9f2463aab 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -443,7 +443,7 @@ rowFromList (xs, r) = foldr (\(RowListItem ann name ty) -> RCons ann name ty) r -- -- Note: importantly, we preserve the order of the types with a given label. alignRowsWith - :: (Type a -> Type a -> r) + :: (Label -> Type a -> Type a -> r) -> Type a -> Type a -> ([r], (([RowListItem a], Type a), ([RowListItem a], Type a))) @@ -453,10 +453,11 @@ alignRowsWith f ty1 ty2 = go s1 s2 where go [] r = ([], (([], tail1), (r, tail2))) go r [] = ([], ((r, tail1), ([], tail2))) - go lhs@(RowListItem a1 l1 t1 : r1) rhs@(RowListItem a2 l2 t2 : r2) - | l1 < l2 = (second . first . first) (RowListItem a1 l1 t1 :) (go r1 rhs) - | l2 < l1 = (second . second . first) (RowListItem a2 l2 t2 :) (go lhs r2) - | otherwise = first (f t1 t2 :) (go r1 r2) + go lhs@(RowListItem a1 l1 t1 : r1) rhs@(RowListItem a2 l2 t2 : r2) = + case compare l1 l2 of + LT -> (second . first . first) (RowListItem a1 l1 t1 :) (go r1 rhs) + GT -> (second . second . first) (RowListItem a2 l2 t2 :) (go lhs r2) + EQ -> first (f l1 t1 t2 :) (go r1 r2) -- | Check whether a type is a monotype isMonoType :: Type a -> Bool diff --git a/tests/purs/failing/NestedRecordLabelOnTypeError.out b/tests/purs/failing/NestedRecordLabelOnTypeError.out new file mode 100644 index 0000000000..911ad038f4 --- /dev/null +++ b/tests/purs/failing/NestedRecordLabelOnTypeError.out @@ -0,0 +1,34 @@ +Error found: +in module NestedRecordLabelOnTypeError +at tests/purs/failing/NestedRecordLabelOnTypeError.purs:8:9 - 8:15 (line 8, column 9 - line 8, column 15) + + Could not match type +   +  Int +   + with type +   +  String +   + +while matching label c +while matching label b +while matching label a +while checking that type { a :: { b :: { c :: Int +  }  +  }  + }  + is at least as general as type { a :: { b :: { c :: String +  }  +  }  + }  +while checking that expression record + has type { a :: { b :: { c :: String +  }  +  }  + }  +in value declaration error + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/NestedRecordLabelOnTypeError.purs b/tests/purs/failing/NestedRecordLabelOnTypeError.purs new file mode 100644 index 0000000000..b91481cbe2 --- /dev/null +++ b/tests/purs/failing/NestedRecordLabelOnTypeError.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith TypesDoNotUnify +module NestedRecordLabelOnTypeError where + +record :: { a :: { b :: { c :: Int } } } +record = { a: { b: { c: 1 } } } + +error :: { a :: { b :: { c :: String } } } +error = record -- this should trigger an error, telling us there's a mismatch in the field `a > b > c` diff --git a/tests/purs/failing/RecordLabelOnTypeError.out b/tests/purs/failing/RecordLabelOnTypeError.out new file mode 100644 index 0000000000..78088babe2 --- /dev/null +++ b/tests/purs/failing/RecordLabelOnTypeError.out @@ -0,0 +1,26 @@ +Error found: +in module RecordLabelOnTypeError +at tests/purs/failing/RecordLabelOnTypeError.purs:8:5 - 8:6 (line 8, column 5 - line 8, column 6) + + Could not match type +   +  Int +   + with type +   +  String +   + +while matching label field +while checking that type { field :: Int + }  + is at least as general as type { field :: String + }  +while checking that expression a + has type { field :: String + }  +in value declaration b + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RecordLabelOnTypeError.purs b/tests/purs/failing/RecordLabelOnTypeError.purs new file mode 100644 index 0000000000..8c8fb5ce13 --- /dev/null +++ b/tests/purs/failing/RecordLabelOnTypeError.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith TypesDoNotUnify +module RecordLabelOnTypeError where + +a :: { field :: Int } +a = { field: 1 } + +b :: { field :: String } +b = a -- this should trigger an error, telling us the `field` tag where the type discrepancy happened diff --git a/tests/purs/failing/RecordLabelOnTypeErrorImmediate.out b/tests/purs/failing/RecordLabelOnTypeErrorImmediate.out new file mode 100644 index 0000000000..d846482602 --- /dev/null +++ b/tests/purs/failing/RecordLabelOnTypeErrorImmediate.out @@ -0,0 +1,22 @@ +Error found: +in module NestedRecordLabelOnTypeError +at tests/purs/failing/RecordLabelOnTypeErrorImmediate.purs:5:15 - 5:18 (line 5, column 15 - line 5, column 18) + + Could not match type +   +  String +   + with type +   +  Int +   + +while checking that type String + is at least as general as type Int +while checking that expression "a" + has type Int +in value declaration record + +See https://github.com/purescript/documentation/blob/master/errors/TypesDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/RecordLabelOnTypeErrorImmediate.purs b/tests/purs/failing/RecordLabelOnTypeErrorImmediate.purs new file mode 100644 index 0000000000..02333b244b --- /dev/null +++ b/tests/purs/failing/RecordLabelOnTypeErrorImmediate.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith TypesDoNotUnify +module NestedRecordLabelOnTypeError where + +record :: { a :: Int } +record = { a: "a" } -- Triggers an error, but the label is explicitly not added since it caused other errors to be worse. See https://github.com/purescript/purescript/pull/4411 for more information. From 4cdf6df1dd28fa941979ea5fda8d4c830c3ffde6 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 4 Feb 2023 11:32:14 +0700 Subject: [PATCH 1527/1580] Depend on `hspec-2.10.9` (#4435) --- purescript.cabal | 2 +- stack.yaml | 10 ++++++---- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index cefdd51b3c..b426757e8a 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -438,7 +438,7 @@ test-suite tests build-depends: purescript, generic-random >=1.5.0.1 && <1.6, - hspec ==2.9.2, + hspec >= 2.10.7 && < 3, HUnit >=1.6.2.0 && <1.7, newtype >=0.2.2.0 && <0.3, QuickCheck >=2.14.2 && <2.15, diff --git a/stack.yaml b/stack.yaml index 397fc5894a..268c062a08 100644 --- a/stack.yaml +++ b/stack.yaml @@ -20,13 +20,15 @@ extra-deps: - Cabal-3.6.3.0 # Protolude is not yet in resolver snapshot - protolude-0.3.1 -# hspec@2.9.3 is the first version that starts depending on ghc +# hspec versions 2.9.3 to 2.10.6 depend on ghc # ghc depends on terminfo by default, but that can be ignored # if one uses the '-terminfo' flag. # Unfortunately, hspec doesn't expose a similar flag. -- hspec-2.9.2 -- hspec-core-2.9.2 -- hspec-discover-2.9.2 +# +# Using hspec >= 2.10.7 addresses this. +- hspec-2.10.9 +- hspec-core-2.10.9 +- hspec-discover-2.10.9 nix: packages: - zlib From 7e448730da86c7e6605647fde54aff5227968348 Mon Sep 17 00:00:00 2001 From: Andy Date: Sun, 5 Feb 2023 08:11:06 +0100 Subject: [PATCH 1528/1580] Upgrade to GHC 9.2.5 (#4433) Co-authored-by: purefunctor --- .github/workflows/ci.yml | 6 +++--- CHANGELOG.d/misc_bump-ghc.md | 1 + CONTRIBUTORS.md | 1 + INSTALL.md | 4 ++-- stack.yaml | 4 +--- 5 files changed, 8 insertions(+), 8 deletions(-) create mode 100644 CHANGELOG.d/misc_bump-ghc.md diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index c12699776e..6500158fa6 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -15,7 +15,7 @@ defaults: env: CI_PRERELEASE: "${{ github.event_name == 'push' }}" CI_RELEASE: "${{ github.event_name == 'release' }}" - STACK_VERSION: "2.9.1" + STACK_VERSION: "2.9.3" concurrency: # We never want two prereleases building at the same time, since they would @@ -38,7 +38,7 @@ jobs: include: - # If upgrading the Haskell image, also upgrade it in the lint job below os: "ubuntu-latest" - image: haskell:9.2.4@sha256:dceec00f8ad896c327c2b5c77ba91c9824bf3e26a837f538ccfb80fb379dc52f + image: haskell:9.2.5@sha256:2597b0e2458165a6635906204f7fac43c22e7d2a46aca1235a811194bb6cd419 - os: "macOS-11" - os: "windows-2019" @@ -172,7 +172,7 @@ jobs: # means our published binaries will work on the widest number of platforms. # But the HLint binary downloaded by this job requires a newer glibc # version. - container: haskell:9.2.4@sha256:dceec00f8ad896c327c2b5c77ba91c9824bf3e26a837f538ccfb80fb379dc52f + container: haskell:9.2.5@sha256:2597b0e2458165a6635906204f7fac43c22e7d2a46aca1235a811194bb6cd419 steps: - # We need a proper Git repository, but the checkout step will unpack a tarball instead of doing a clone diff --git a/CHANGELOG.d/misc_bump-ghc.md b/CHANGELOG.d/misc_bump-ghc.md new file mode 100644 index 0000000000..165ac355c5 --- /dev/null +++ b/CHANGELOG.d/misc_bump-ghc.md @@ -0,0 +1 @@ +* Bump Stackage snapshot to lts-20.9 and GHC to 9.2.5 diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index d029c433af..a2c3142b83 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -19,6 +19,7 @@ If you would prefer to use different terms, please use the section below instead | [@alexbiehl](https://github.com/alexbiehl) | Alexander Biehl | [MIT license](http://opensource.org/licenses/MIT) | | [@andreypopp](https://github.com/andreypopp) | Andrey Popp | MIT license | | [@andyarvanitis](https://github.com/andyarvanitis) | Andy Arvanitis | [MIT license](http://opensource.org/licenses/MIT) | +| [@andys8](https://github.com/andys8) | andys8 | [MIT license](http://opensource.org/licenses/MIT) | | [@anthok88](https://github.com/anthok88) | anthoq88 | MIT license | | [@ardumont](https://github.com/ardumont) | Antoine R. Dumont | [MIT license](http://opensource.org/licenses/MIT) | | [@arrowd](https://github.com/arrowd) | Gleb Popov | [MIT license](http://opensource.org/licenses/MIT) | diff --git a/INSTALL.md b/INSTALL.md index d928501371..041cd3315d 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -4,12 +4,12 @@ If you are having difficulty installing the PureScript compiler, feel free to as ## Requirements -The PureScript compiler is built using GHC 9.2.4, and should be able to run on any operating system supported by GHC 9.2.4. In particular: +The PureScript compiler is built using GHC 9.2.5, and should be able to run on any operating system supported by GHC 9.2.5. In particular: * for Windows users, versions predating Vista are not officially supported, * for macOS / OS X users, versions predating Mac OS X 10.7 (Lion) are not officially supported. -See also for more details about the operating systems which GHC 9.2.4 supports. +See also for more details about the operating systems which GHC 9.2.5 supports. ## Official prebuilt binaries diff --git a/stack.yaml b/stack.yaml index 268c062a08..cbf7426e01 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ # Please update Haskell image versions under .github/workflows/ci.yml together to use the same GHC version # (or the CI build will fail) -resolver: nightly-2022-11-12 +resolver: lts-20.9 pvp-bounds: both packages: - '.' @@ -18,8 +18,6 @@ extra-deps: - process-1.6.13.1 # The Cabal library is not in Stackage - Cabal-3.6.3.0 -# Protolude is not yet in resolver snapshot -- protolude-0.3.1 # hspec versions 2.9.3 to 2.10.6 depend on ghc # ghc depends on terminfo by default, but that can be ignored # if one uses the '-terminfo' flag. From 042150325abf842064877ce9268fbce8df029e64 Mon Sep 17 00:00:00 2001 From: Andy Date: Sun, 5 Feb 2023 09:51:45 +0100 Subject: [PATCH 1529/1580] Single link reference to MIT license (#4434) --- CONTRIBUTORS.md | 325 ++++++++++++++++++++++++------------------------ 1 file changed, 164 insertions(+), 161 deletions(-) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index a2c3142b83..a4ad8416af 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -14,178 +14,181 @@ If you would prefer to use different terms, please use the section below instead | Username | Name | License | | :------- | :--- | :------ | -| [@5outh](https://github.com/5outh) | Benjamin Kovach | MIT license | -| [@actionshrimp](https://github.com/actionshrimp) | David Aitken | [MIT license](http://opensource.org/licenses/MIT) | -| [@alexbiehl](https://github.com/alexbiehl) | Alexander Biehl | [MIT license](http://opensource.org/licenses/MIT) | -| [@andreypopp](https://github.com/andreypopp) | Andrey Popp | MIT license | -| [@andyarvanitis](https://github.com/andyarvanitis) | Andy Arvanitis | [MIT license](http://opensource.org/licenses/MIT) | -| [@andys8](https://github.com/andys8) | andys8 | [MIT license](http://opensource.org/licenses/MIT) | -| [@anthok88](https://github.com/anthok88) | anthoq88 | MIT license | -| [@ardumont](https://github.com/ardumont) | Antoine R. Dumont | [MIT license](http://opensource.org/licenses/MIT) | -| [@arrowd](https://github.com/arrowd) | Gleb Popov | [MIT license](http://opensource.org/licenses/MIT) | -| [@aspidites](https://github.com/aspidites) | Edwin Marshall | [MIT license](http://opensource.org/licenses/MIT) | -| [@bagl](https://github.com/bagl) | Petr Vapenka | [MIT license](http://opensource.org/licenses/MIT) | -| [@balajirrao](https://github.com/balajirrao) | Balaji Rao | MIT license | -| [@bbqbaron](https://github.com/bbqbaron) | Eric Loren | [MIT license](http://opensource.org/licenses/MIT) | -| [@bergmark](https://github.com/bergmark) | Adam Bergmark | MIT license | -| [@bitemyapp](https://github.com/bitemyapp) | Chris Allen | [MIT license](http://opensource.org/licenses/MIT) | -| [@bmjames](https://github.com/bmjames) | Ben James | [MIT license](http://opensource.org/licenses/MIT) | -| [@Bogdanp](https://github.com/Bogdanp) | Bogdan Paul Popa | [MIT license](http://opensource.org/licenses/MIT) | -| [@brandonhamilton](https://github.com/brandonhamilton) | Brandon Hamilton | [MIT license](http://opensource.org/licenses/MIT) | -| [@bsermons](https://github.com/bsermons) | Brian Sermons | [MIT license](http://opensource.org/licenses/MIT) | -| [@cdepillabout](https://github.com/cdepillabout) | Dennis Gosnell | [MIT license](http://opensource.org/licenses/MIT) | -| [@chexxor](https://github.com/chexxor) | Alex Berg | [MIT license](http://opensource.org/licenses/MIT) | -| [@chrisdone](https://github.com/chrisdone) | Chris Done | MIT license | -| [@cmdv](https://github.com/cmdv) | Vincent Orr | MIT license | -| [@codedmart](https://github.com/codedmart) | Brandon Martin | [MIT license](http://opensource.org/licenses/MIT) | -| [@coot](https://github.com/coot) | Marcin Szamotulski | [MIT license](http://opensource.org/licenses/MIT) | -| [@davidchambers](https://github.com/davidchambers) | David Chambers | [MIT license](http://opensource.org/licenses/MIT) | -| [@DavidLindbom](https://github.com/DavidLindbom) | David Lindbom | [MIT license](http://opensource.org/licenses/MIT) | -| [@dckc](https://github.com/dckc) | Dan Connolly | [MIT license](http://opensource.org/licenses/MIT) | -| [@kleeneplus](https://github.com/dgendill) | Dominick Gendill | [MIT license](http://opensource.org/licenses/MIT) | -| [@ealmansi](https://github.com/ealmansi) | Emilio Almansi | MIT license | -| [@eamelink](https://github.com/eamelink) | Erik Bakker | MIT license | -| [@EMattfolk](https://github.com/EMattfolk) | Erik Mattfolk | [MIT license](http://opensource.org/licenses/MIT) | -| [@epost](https://github.com/epost) | Erik Post | MIT license | -| [@erdeszt](https://github.com/erdeszt) | Tibor Erdesz | [MIT license](http://opensource.org/licenses/MIT) | -| [@etrepum](https://github.com/etrepum) | Bob Ippolito | [MIT license](http://opensource.org/licenses/MIT) | -| [@faineance](https://github.com/faineance) | faineance | [MIT license](http://opensource.org/licenses/MIT) | -| [@fehrenbach](https://github.com/fehrenbach) | Stefan Fehrenbach | [MIT license](http://opensource.org/licenses/MIT) | -| [@felixSchl](https://github.com/felixSchl) | Felix Schlitter | [MIT license](http://opensource.org/licenses/MIT) | -| [@FrigoEU](https://github.com/FrigoEU) | Simon Van Casteren | [MIT license](http://opensource.org/licenses/MIT) | -| [@fsoikin](https://github.com/fsoikin) | Fyodor Soikin | [MIT license](http://opensource.org/licenses/MIT) | -| [@f-f](https://github.com/f-f) | Fabrizio Ferrai | [MIT license](http://opensource.org/licenses/MIT) | -| [@garyb](https://github.com/garyb) | Gary Burgess | [MIT license](http://opensource.org/licenses/MIT) | -| [@hdgarrood](https://github.com/hdgarrood) | Harry Garrood | [MIT license](http://opensource.org/licenses/MIT) | -| [@houli](https://github.com/houli) | Eoin Houlihan | [MIT license](http://opensource.org/licenses/MIT) | -| [@ianbollinger](https://github.com/ianbollinger) | Ian D. Bollinger | [MIT license](http://opensource.org/licenses/MIT) | -| [@ilovezfs](https://github.com/ilovezfs) | ilovezfs | MIT license | -| [@i-am-tom](https://github.com/i-am-tom) | i-am-tom | [MIT license](http://opensource.org/licenses/MIT) | -| [@izgzhen](https://github.com/izgzhen) | Zhen Zhang | [MIT license](http://opensource.org/licenses/MIT) | -| [@jacereda](https://github.com/jacereda) | Jorge Acereda | [MIT license](http://opensource.org/licenses/MIT) | -| [@japesinator](https://github.com/japesinator) | JP Smith | [MIT license](http://opensource.org/licenses/MIT) | -| [@jkachmar](https://github.com/jkachmar) | Joe Kachmar | MIT license | -| [@joneshf](https://github.com/joneshf) | Hardy Jones | MIT license | -| [@jy14898](https://github.com/jy14898) | Joseph Young | MIT license | -| [@kika](https://github.com/kika) | Kirill Pertsev | MIT license | -| [@kRITZCREEK](https://github.com/kRITZCREEK) | Christoph Hegemann | MIT license | -| [@L8D](https://github.com/L8D) | Tenor Biel | [MIT license](http://opensource.org/licenses/MIT) | -| [@legrostdg](https://github.com/legrostdg) | Félix Sipma | [MIT license](http://opensource.org/licenses/MIT) | -| [@LiamGoodacre](https://github.com/LiamGoodacre) | Liam Goodacre | [MIT license](http://opensource.org/licenses/MIT) | -| [@lukerandall](https://github.com/lukerandall) | Luke Randall | [MIT license](http://opensource.org/licenses/MIT) | -| [@lunaris](https://github.com/lunaris) | Will Jones | [MIT license](http://opensource.org/licenses/MIT) | -| [@matthewleon](https://github.com/matthewleon) | Matthew Leon | [MIT license](http://opensource.org/licenses/MIT) | -| [@mcoffin](https://github.com/mcoffin) | Matt Coffin | [MIT license](http://opensource.org/licenses/MIT) | -| [@mhcurylo](https://github.com/mhcurylo) | Mateusz Curylo | [MIT license](http://opensource.org/licenses/MIT) | -| [@mikesol](https://github.com/mikesol) | Mike Solomon | [MIT license](http://opensource.org/licenses/MIT) | -| [@MiracleBlue](https://github.com/MiracleBlue) | Nicholas Kircher | [MIT license](http://opensource.org/licenses/MIT) | -| [@mrkgnao](https://github.com/mrkgnao) | Soham Chowdhury | [MIT license](http://opensource.org/licenses/MIT) | -| [@mgmeier](https://github.com/mgmeier) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) | -| [@michaelficarra](https://github.com/michaelficarra) | Michael Ficarra | [MIT license](http://opensource.org/licenses/MIT) | -| [@MichaelXavier](https://github.com/MichaelXavier) | Michael Xavier | MIT license | -| [@milesfrain](https://github.com/milesfrain) | Miles Frain | [MIT license](http://opensource.org/licenses/MIT) | -| [@mjgpy3](https://github.com/mjgpy3) | Michael Gilliland | [MIT license](http://opensource.org/licenses/MIT) | -| [@mpietrzak](https://github.com/mpietrzak) | Maciej Pietrzak | [MIT license](http://opensource.org/licenses/MIT) | -| [@mrhania](https://github.com/mrhania) | Łukasz Hanuszczak | [MIT license](http://opensource.org/licenses/MIT) | -| [@natefaubion](https://github.com/natefaubion) | Nathan Faubion | [MIT license](http://opensource.org/licenses/MIT) | -| [@ncaq](https://github.com/ncaq) | ncaq | [MIT license](http://opensource.org/licenses/MIT) | -| [@NickMolloy](https://github.com/NickMolloy) | Nick Molloy | [MIT license](http://opensource.org/licenses/MIT) | -| [@nicodelpiano](https://github.com/nicodelpiano) | Nicolas Del Piano | [MIT license](http://opensource.org/licenses/MIT) | -| [@noraesae](https://github.com/noraesae) | Hyunje Jun | [MIT license](http://opensource.org/licenses/MIT) | -| [@nullobject](https://github.com/nullobject) | Josh Bassett | [MIT license](http://opensource.org/licenses/MIT) | -| [@osa1](https://github.com/osa1) | Ömer Sinan Ağacan | MIT license | -| [@paf31](https://github.com/paf31) | Phil Freeman | [MIT license](http://opensource.org/licenses/MIT) | -| [@parsonsmatt](https://github.com/parsonsmatt) | Matt Parsons | [MIT license](http://opensource.org/licenses/MIT) | -| [@passy](https://github.com/passy) | Pascal Hartig | [MIT license](http://opensource.org/licenses/MIT) | -| [@paulyoung](https://github.com/paulyoung) | Paul Young | [MIT license](http://opensource.org/licenses/MIT) | -| [@pelotom](https://github.com/pelotom) | Thomas Crockett | [MIT license](http://opensource.org/licenses/MIT) | -| [@peterbecich](https://github.com/peterbecich) | Peter Becich | [MIT license](http://opensource.org/licenses/MIT) | -| [@phadej](https://github.com/phadej) | Oleg Grenrus | [MIT license](http://opensource.org/licenses/MIT) | -| [@phiggins](https://github.com/phiggins) | Pete Higgins | [MIT license](http://opensource.org/licenses/MIT) | -| [@philopon](https://github.com/philopon) | Hirotomo Moriwaki | [MIT license](http://opensource.org/licenses/MIT) | -| [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license](http://opensource.org/licenses/MIT) | -| [@ptrfrncsmrph](https://github.com/ptrfrncsmrph) | Peter Murphy | [MIT license](http://opensource.org/licenses/MIT) | -| [@quesebifurcan](https://github.com/quesebifurcan) | Fredrik Wallberg | [MIT license](http://opensource.org/licenses/MIT) | -| [@radrow](https://github.com/radrow) | Radosław Rowicki | [MIT license](http://opensource.org/licenses/MIT) | -| [@rhendric](https://github.com/rhendric) | Ryan Hendrickson | [MIT license](http://opensource.org/licenses/MIT) | -| [@rightfold](https://github.com/rightfold) | rightfold | [MIT license](https://opensource.org/licenses/MIT) | -| [@rndnoise](https://www.github.com/rndnoise) | rndnoise | [MIT license](http://opensource.org/licenses/MIT) | -| [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license](http://opensource.org/licenses/MIT) | -| [@RossMeikleham](https://github.com/RossMeikleham) | Ross Meikleham | [MIT license](http://opensource.org/licenses/MIT) | -| [@Rufflewind](https://github.com/Rufflewind) | Phil Ruffwind | [MIT license](https://opensource.org/licenses/MIT) | -| [@rvion](https://github.com/rvion) | Rémi Vion | [MIT license](http://opensource.org/licenses/MIT) | -| [@RyanGlScott](https://github.com/RyanGlScott) | Ryan Scott | [MIT license](http://opensource.org/licenses/MIT) | -| [@sebastiaanvisser](https://github.com/sebastiaanvisser) | Sebastiaan Visser | MIT license | -| [@sectore](https://github.com/sectore) | Jens Krause | [MIT license](http://opensource.org/licenses/MIT) | -| [@senju](https://github.com/senju) | senju | [MIT license](http://opensource.org/licenses/MIT) | -| [@seungha-kim](https://github.com/seungha-kim) | Seungha Kim | [MIT license](http://opensource.org/licenses/MIT) | -| [@simonyangme](https://github.com/simonyangme) | Simon Yang | [MIT license](http://opensource.org/licenses/MIT) | -| [@sharkdp](https://github.com/sharkdp) | David Peter | [MIT license](http://opensource.org/licenses/MIT) | -| [@soupi](https://github.com/soupi) | Gil Mizrahi | [MIT license](http://opensource.org/licenses/MIT) | -| [@stefanholzmueller](https://github.com/stefanholzmueller) | Stefan Holzmüller | [MIT license](http://opensource.org/licenses/MIT) | -| [@sztupi](https://github.com/sztupi) | Attila Sztupak | [MIT license](http://opensource.org/licenses/MIT) | -| [@taktoa](https://github.com/taktoa) | Remy Goldschmidt | [MIT license](http://opensource.org/licenses/MIT) | -| [@taku0](https://github.com/taku0) | taku0 | [MIT license](http://opensource.org/licenses/MIT) | -| [@tfausak](https://github.com/tfausak) | Taylor Fausak | [MIT license](http://opensource.org/licenses/MIT) | -| [@thoradam](https://github.com/thoradam) | Thor Adam | [MIT license](http://opensource.org/licenses/MIT) | -| [@tmcgilchrist](https://github.com/tmcgilchrist) | Tim McGilchrist | [MIT license](http://opensource.org/licenses/MIT) | -| [@trofi](https://github.com/trofi) | Sergei Trofimovich | [MIT license](http://opensource.org/licenses/MIT) | -| [@utkarshkukreti](https://github.com/utkarshkukreti) | Utkarsh Kukreti | [MIT license](http://opensource.org/licenses/MIT) | -| [@vkorablin](https://github.com/vkorablin) | Vladimir Korablin | MIT license | -| [@vladciobanu](https://github.com/vladciobanu) | Vladimir Ciobanu | [MIT license](http://opensource.org/licenses/MIT) | -| [@zudov](https://github.com/zudov) | Konstantin Zudov | [MIT license](http://opensource.org/licenses/MIT) | -| [@b123400](https://github.com/b123400) | b123400 | [MIT license](https://opensource.org/licenses/MIT) | -| [@kcsongor](https://github.com/kcsongor) | Csongor Kiss | [MIT license](http://opensource.org/licenses/MIT) | -| [@drets](https://github.com/drets) | Dmytro Rets | [MIT license](http://opensource.org/licenses/MIT) | -| [@bjornmelgaaard](https://github.com/BjornMelgaard) | Sergey Homa | [MIT license](http://opensource.org/licenses/MIT) | -| [@thimoteus](https://github.com/Thimoteus) | thimoteus | [MIT license](http://opensource.org/licenses/MIT) | -| [@sloosch](https://github.com/sloosch) | Simon Looschen | [MIT license](http://opensource.org/licenses/MIT) | -| [@rgrinberg](https://github.com/rgrinberg) | Rudi Grinberg | [MIT license](http://opensource.org/licenses/MIT) | -| [@gabejohnson](https://github.com/gabejohnson) | Gabe Johnson | [MIT license](http://opensource.org/licenses/MIT) | -| [@dariooddenino](https://github.com/dariooddenino) | Dario Oddenino | [MIT license](http://opensource.org/licenses/MIT) | -| [@jordanmartinez](https://github.com/jordanmartinez) | Jordan Martinez | [MIT license](http://opensource.org/licenses/MIT) | -| [@Saulukass](https://github.com/Saulukass) | Saulius Skliutas | [MIT license](http://opensource.org/licenses/MIT) | -| [@adnelson](https://github.com/adnelson) | Allen Nelson | [MIT license](http://opensource.org/licenses/MIT) | -| [@dyerw](https://github.com/dyerw) | Liam Dyer | [MIT license](http://opensource.org/licenses/MIT) | -| [@marcosh](https://github.com/marcosh) | Marco Perone | [MIT license](http://opensource.org/licenses/MIT) | -| [@matthew-hilty](https://github.com/matthew-hilty) | Matthew Hilty | [MIT license](http://opensource.org/licenses/MIT) | -| [@woody88](https://github.com/woody88) | Woodson Delhia | [MIT license](http://opensource.org/licenses/MIT) | -| [@mhmdanas](https://github.com/mhmdanas) | Mohammed Anas | [MIT license](http://opensource.org/licenses/MIT) | -| [@kl0tl](https://github.com/kl0tl) | Cyril Sobierajewicz | [MIT license](http://opensource.org/licenses/MIT) | -| [@PureFunctor](https://github.com/PureFunctor), [@sjpgarcia](https://github.com/sjpgarcia) | Justin Garcia | [MIT license](http://opensource.org/licenses/MIT) | -| [@xgrommx](https://github.com/xgrommx) | Denis Stoyanov | [MIT license](http://opensource.org/licenses/MIT) | -| [@MonoidMusician](https://github.com/MonoidMusician) | Verity Scheel | [MIT license](http://opensource.org/licenses/MIT) | -| [@thomashoneyman](https://github.com/thomashoneyman) | Thomas Honeyman | [MIT license](http://opensource.org/licenses/MIT) | -| [@sigma-andex](https://github.com/sigma-andex) | Jan Schulte | [MIT license](http://opensource.org/licenses/MIT) | -| [@i-am-the-slime](https://github.com/i-am-the-slime) | Mark Eibes | [MIT license](http://opensource.org/licenses/MIT) | -| [@sd-yip](https://github.com/sd-yip) | Nicholas Yip | [MIT license](http://opensource.org/licenses/MIT) | -| [@j-nava](https://github.com/j-nava) | Jesse Nava | [MIT license](http://opensource.org/licenses/MIT) | -| [@imcotton](https://github.com/imcotton) | Cotton Hou | [MIT license](http://opensource.org/licenses/MIT) | -| [@FredTheDino](https://github.com/FredTheDino) | Edvard Thörnros | [MIT license](http://opensource.org/licenses/MIT) | -| [@wclr](https://github.com/wclr) | Alex Osh | [MIT license](http://opensource.org/licenses/MIT) | -| [@Deltaspace0](https://github.com/Deltaspace0) | Ruslan Gadeev | [MIT license](http://opensource.org/licenses/MIT) | +| [@5outh](https://github.com/5outh) | Benjamin Kovach | [MIT license] | +| [@actionshrimp](https://github.com/actionshrimp) | David Aitken | [MIT license] | +| [@adnelson](https://github.com/adnelson) | Allen Nelson | [MIT license] | +| [@alexbiehl](https://github.com/alexbiehl) | Alexander Biehl | [MIT license] | +| [@andreypopp](https://github.com/andreypopp) | Andrey Popp | [MIT license] | +| [@andyarvanitis](https://github.com/andyarvanitis) | Andy Arvanitis | [MIT license] | +| [@andys8](https://github.com/andys8) | andys8 | [MIT license] | +| [@anthok88](https://github.com/anthok88) | anthoq88 | [MIT license] | +| [@ardumont](https://github.com/ardumont) | Antoine R. Dumont | [MIT license] | +| [@arrowd](https://github.com/arrowd) | Gleb Popov | [MIT license] | +| [@aspidites](https://github.com/aspidites) | Edwin Marshall | [MIT license] | +| [@b123400](https://github.com/b123400) | b123400 | [MIT license] | +| [@bagl](https://github.com/bagl) | Petr Vapenka | [MIT license] | +| [@balajirrao](https://github.com/balajirrao) | Balaji Rao | [MIT license] | +| [@bbqbaron](https://github.com/bbqbaron) | Eric Loren | [MIT license] | +| [@bergmark](https://github.com/bergmark) | Adam Bergmark | [MIT license] | +| [@bitemyapp](https://github.com/bitemyapp) | Chris Allen | [MIT license] | +| [@bjornmelgaaard](https://github.com/BjornMelgaard) | Sergey Homa | [MIT license] | +| [@bmjames](https://github.com/bmjames) | Ben James | [MIT license] | +| [@Bogdanp](https://github.com/Bogdanp) | Bogdan Paul Popa | [MIT license] | +| [@brandonhamilton](https://github.com/brandonhamilton) | Brandon Hamilton | [MIT license] | +| [@bsermons](https://github.com/bsermons) | Brian Sermons | [MIT license] | +| [@cdepillabout](https://github.com/cdepillabout) | Dennis Gosnell | [MIT license] | +| [@chexxor](https://github.com/chexxor) | Alex Berg | [MIT license] | +| [@chrisdone](https://github.com/chrisdone) | Chris Done | [MIT license] | +| [@cmdv](https://github.com/cmdv) | Vincent Orr | [MIT license] | +| [@codedmart](https://github.com/codedmart) | Brandon Martin | [MIT license] | +| [@coot](https://github.com/coot) | Marcin Szamotulski | [MIT license] | +| [@dariooddenino](https://github.com/dariooddenino) | Dario Oddenino | [MIT license] | +| [@davidchambers](https://github.com/davidchambers) | David Chambers | [MIT license] | +| [@DavidLindbom](https://github.com/DavidLindbom) | David Lindbom | [MIT license] | +| [@dckc](https://github.com/dckc) | Dan Connolly | [MIT license] | +| [@Deltaspace0](https://github.com/Deltaspace0) | Ruslan Gadeev | [MIT license] | +| [@drets](https://github.com/drets) | Dmytro Rets | [MIT license] | +| [@dyerw](https://github.com/dyerw) | Liam Dyer | [MIT license] | +| [@ealmansi](https://github.com/ealmansi) | Emilio Almansi | [MIT license] | +| [@eamelink](https://github.com/eamelink) | Erik Bakker | [MIT license] | +| [@EMattfolk](https://github.com/EMattfolk) | Erik Mattfolk | [MIT license] | +| [@epost](https://github.com/epost) | Erik Post | [MIT license] | +| [@erdeszt](https://github.com/erdeszt) | Tibor Erdesz | [MIT license] | +| [@etrepum](https://github.com/etrepum) | Bob Ippolito | [MIT license] | +| [@f-f](https://github.com/f-f) | Fabrizio Ferrai | [MIT license] | +| [@faineance](https://github.com/faineance) | faineance | [MIT license] | +| [@fehrenbach](https://github.com/fehrenbach) | Stefan Fehrenbach | [MIT license] | +| [@felixSchl](https://github.com/felixSchl) | Felix Schlitter | [MIT license] | +| [@FredTheDino](https://github.com/FredTheDino) | Edvard Thörnros | [MIT license] | +| [@FrigoEU](https://github.com/FrigoEU) | Simon Van Casteren | [MIT license] | +| [@fsoikin](https://github.com/fsoikin) | Fyodor Soikin | [MIT license] | +| [@gabejohnson](https://github.com/gabejohnson) | Gabe Johnson | [MIT license] | +| [@garyb](https://github.com/garyb) | Gary Burgess | [MIT license] | +| [@hdgarrood](https://github.com/hdgarrood) | Harry Garrood | [MIT license] | +| [@houli](https://github.com/houli) | Eoin Houlihan | [MIT license] | +| [@i-am-the-slime](https://github.com/i-am-the-slime) | Mark Eibes | [MIT license] | +| [@i-am-tom](https://github.com/i-am-tom) | i-am-tom | [MIT license] | +| [@ianbollinger](https://github.com/ianbollinger) | Ian D. Bollinger | [MIT license] | +| [@ilovezfs](https://github.com/ilovezfs) | ilovezfs | [MIT license] | +| [@imcotton](https://github.com/imcotton) | Cotton Hou | [MIT license] | +| [@izgzhen](https://github.com/izgzhen) | Zhen Zhang | [MIT license] | +| [@j-nava](https://github.com/j-nava) | Jesse Nava | [MIT license] | +| [@jacereda](https://github.com/jacereda) | Jorge Acereda | [MIT license] | +| [@japesinator](https://github.com/japesinator) | JP Smith | [MIT license] | +| [@jkachmar](https://github.com/jkachmar) | Joe Kachmar | [MIT license] | +| [@joneshf](https://github.com/joneshf) | Hardy Jones | [MIT license] | +| [@jordanmartinez](https://github.com/jordanmartinez) | Jordan Martinez | [MIT license] | +| [@jy14898](https://github.com/jy14898) | Joseph Young | [MIT license] | +| [@kcsongor](https://github.com/kcsongor) | Csongor Kiss | [MIT license] | +| [@kika](https://github.com/kika) | Kirill Pertsev | [MIT license] | +| [@kl0tl](https://github.com/kl0tl) | Cyril Sobierajewicz | [MIT license] | +| [@kleeneplus](https://github.com/dgendill) | Dominick Gendill | [MIT license] | +| [@kRITZCREEK](https://github.com/kRITZCREEK) | Christoph Hegemann | [MIT license] | +| [@L8D](https://github.com/L8D) | Tenor Biel | [MIT license] | +| [@legrostdg](https://github.com/legrostdg) | Félix Sipma | [MIT license] | +| [@LiamGoodacre](https://github.com/LiamGoodacre) | Liam Goodacre | [MIT license] | +| [@lukerandall](https://github.com/lukerandall) | Luke Randall | [MIT license] | +| [@lunaris](https://github.com/lunaris) | Will Jones | [MIT license] | +| [@marcosh](https://github.com/marcosh) | Marco Perone | [MIT license] | +| [@matthew-hilty](https://github.com/matthew-hilty) | Matthew Hilty | [MIT license] | +| [@matthewleon](https://github.com/matthewleon) | Matthew Leon | [MIT license] | +| [@mcoffin](https://github.com/mcoffin) | Matt Coffin | [MIT license] | +| [@mgmeier](https://github.com/mgmeier) | Michael Gilliland | [MIT license] | +| [@mhcurylo](https://github.com/mhcurylo) | Mateusz Curylo | [MIT license] | +| [@mhmdanas](https://github.com/mhmdanas) | Mohammed Anas | [MIT license] | +| [@michaelficarra](https://github.com/michaelficarra) | Michael Ficarra | [MIT license] | +| [@MichaelXavier](https://github.com/MichaelXavier) | Michael Xavier | [MIT license] | +| [@mikesol](https://github.com/mikesol) | Mike Solomon | [MIT license] | +| [@milesfrain](https://github.com/milesfrain) | Miles Frain | [MIT license] | +| [@MiracleBlue](https://github.com/MiracleBlue) | Nicholas Kircher | [MIT license] | +| [@mjgpy3](https://github.com/mjgpy3) | Michael Gilliland | [MIT license] | +| [@MonoidMusician](https://github.com/MonoidMusician) | Verity Scheel | [MIT license] | +| [@mpietrzak](https://github.com/mpietrzak) | Maciej Pietrzak | [MIT license] | +| [@mrhania](https://github.com/mrhania) | Łukasz Hanuszczak | [MIT license] | +| [@mrkgnao](https://github.com/mrkgnao) | Soham Chowdhury | [MIT license] | +| [@natefaubion](https://github.com/natefaubion) | Nathan Faubion | [MIT license] | +| [@ncaq](https://github.com/ncaq) | ncaq | [MIT license] | +| [@NickMolloy](https://github.com/NickMolloy) | Nick Molloy | [MIT license] | +| [@nicodelpiano](https://github.com/nicodelpiano) | Nicolas Del Piano | [MIT license] | +| [@noraesae](https://github.com/noraesae) | Hyunje Jun | [MIT license] | +| [@nullobject](https://github.com/nullobject) | Josh Bassett | [MIT license] | +| [@osa1](https://github.com/osa1) | Ömer Sinan Ağacan | [MIT license] | +| [@paf31](https://github.com/paf31) | Phil Freeman | [MIT license] | +| [@parsonsmatt](https://github.com/parsonsmatt) | Matt Parsons | [MIT license] | +| [@passy](https://github.com/passy) | Pascal Hartig | [MIT license] | +| [@paulyoung](https://github.com/paulyoung) | Paul Young | [MIT license] | +| [@pelotom](https://github.com/pelotom) | Thomas Crockett | [MIT license] | +| [@peterbecich](https://github.com/peterbecich) | Peter Becich | [MIT license] | +| [@phadej](https://github.com/phadej) | Oleg Grenrus | [MIT license] | +| [@phiggins](https://github.com/phiggins) | Pete Higgins | [MIT license] | +| [@philopon](https://github.com/philopon) | Hirotomo Moriwaki | [MIT license] | +| [@pseudonom](https://github.com/pseudonom) | Eric Easley | [MIT license] | +| [@ptrfrncsmrph](https://github.com/ptrfrncsmrph) | Peter Murphy | [MIT license] | +| [@PureFunctor](https://github.com/PureFunctor), [@sjpgarcia](https://github.com/sjpgarcia) | Justin Garcia | [MIT license] | +| [@quesebifurcan](https://github.com/quesebifurcan) | Fredrik Wallberg | [MIT license] | +| [@radrow](https://github.com/radrow) | Radosław Rowicki | [MIT license] | +| [@rgrinberg](https://github.com/rgrinberg) | Rudi Grinberg | [MIT license] | +| [@rhendric](https://github.com/rhendric) | Ryan Hendrickson | [MIT license] | +| [@rightfold](https://github.com/rightfold) | rightfold | [MIT license] | +| [@rndnoise](https://www.github.com/rndnoise) | rndnoise | [MIT license] | +| [@robdaemon](https://github.com/robdaemon) | Robert Roland | [MIT license] | +| [@RossMeikleham](https://github.com/RossMeikleham) | Ross Meikleham | [MIT license] | +| [@Rufflewind](https://github.com/Rufflewind) | Phil Ruffwind | [MIT license] | +| [@rvion](https://github.com/rvion) | Rémi Vion | [MIT license] | +| [@RyanGlScott](https://github.com/RyanGlScott) | Ryan Scott | [MIT license] | +| [@Saulukass](https://github.com/Saulukass) | Saulius Skliutas | [MIT license] | +| [@sd-yip](https://github.com/sd-yip) | Nicholas Yip | [MIT license] | +| [@sebastiaanvisser](https://github.com/sebastiaanvisser) | Sebastiaan Visser | [MIT license] | +| [@sectore](https://github.com/sectore) | Jens Krause | [MIT license] | +| [@senju](https://github.com/senju) | senju | [MIT license] | +| [@seungha-kim](https://github.com/seungha-kim) | Seungha Kim | [MIT license] | +| [@sharkdp](https://github.com/sharkdp) | David Peter | [MIT license] | +| [@sigma-andex](https://github.com/sigma-andex) | Jan Schulte | [MIT license] | +| [@simonyangme](https://github.com/simonyangme) | Simon Yang | [MIT license] | +| [@sloosch](https://github.com/sloosch) | Simon Looschen | [MIT license] | +| [@soupi](https://github.com/soupi) | Gil Mizrahi | [MIT license] | +| [@stefanholzmueller](https://github.com/stefanholzmueller) | Stefan Holzmüller | [MIT license] | +| [@sztupi](https://github.com/sztupi) | Attila Sztupak | [MIT license] | +| [@taktoa](https://github.com/taktoa) | Remy Goldschmidt | [MIT license] | +| [@taku0](https://github.com/taku0) | taku0 | [MIT license] | +| [@tfausak](https://github.com/tfausak) | Taylor Fausak | [MIT license] | +| [@thimoteus](https://github.com/Thimoteus) | thimoteus | [MIT license] | +| [@thomashoneyman](https://github.com/thomashoneyman) | Thomas Honeyman | [MIT license] | +| [@thoradam](https://github.com/thoradam) | Thor Adam | [MIT license] | +| [@tmcgilchrist](https://github.com/tmcgilchrist) | Tim McGilchrist | [MIT license] | +| [@trofi](https://github.com/trofi) | Sergei Trofimovich | [MIT license] | +| [@utkarshkukreti](https://github.com/utkarshkukreti) | Utkarsh Kukreti | [MIT license] | +| [@vkorablin](https://github.com/vkorablin) | Vladimir Korablin | [MIT license] | +| [@vladciobanu](https://github.com/vladciobanu) | Vladimir Ciobanu | [MIT license] | +| [@wclr](https://github.com/wclr) | Alex Osh | [MIT license] | +| [@woody88](https://github.com/woody88) | Woodson Delhia | [MIT license] | +| [@xgrommx](https://github.com/xgrommx) | Denis Stoyanov | [MIT license] | +| [@zudov](https://github.com/zudov) | Konstantin Zudov | [MIT license] | + ### Contributors using Modified Terms | Username | Name | Terms | | :------- | :--- | :------ | -| [@charleso](https://github.com/charleso) | Charles O'Farrell | My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Charles O'Farrell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | -| [@chrissmoak](https://github.com/chrissmoak) | Chris Smoak | My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | +| [@charleso](https://github.com/charleso) | Charles O'Farrell | My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Charles O'Farrell, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license]. | +| [@chrissmoak](https://github.com/chrissmoak) | Chris Smoak | My existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Chris Smoak, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license]. | | [@citizengabe](https://github.com/citizengabe) | Gabe Johnson | All contributions I have or will make using the @citizengabe GitHub account are during employment at [CitizenNet Inc.](#companies) who owns the copyright. All of my existing or future contributions made using the @gabejohnson GitHub account are personal contributions and subject to the terms specified [above](#contributors-using-standard-terms). | -| [@dylex](https://github.com/dylex) | Dylan Simon | My existing and all future contributions to the PureScript compiler until further notice are Copyright Dylan Simon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | -| [@leighman](http://github.com/leighman) | Jack Leigh | My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | +| [@dylex](https://github.com/dylex) | Dylan Simon | My existing and all future contributions to the PureScript compiler until further notice are Copyright Dylan Simon, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license]. | +| [@leighman](http://github.com/leighman) | Jack Leigh | My existing contributions and all future contributions until further notice are Copyright Jack Leigh, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license]. | | [@nagisa](https://github.com/nagisa) | nagisa | I hereby release my [only contribution](https://github.com/purescript/purescript/commit/80287a5d0de619862d3b4cda9c1ee276d18fdcd8) into public domain. | | [@puffnfresh](https://github.com/puffnfresh) | Brian McKenna | All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler. | -| [@nwolverson](https://github.com/nwolverson) | Nicholas Wolverson | Contributions I made during March 2020 until further notice are in employment of [Id3as Company](#companies), who own the copyright. All other contributions remain Copyright Nicholas Wolverson, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | - +| [@nwolverson](https://github.com/nwolverson) | Nicholas Wolverson | Contributions I made during March 2020 until further notice are in employment of [Id3as Company](#companies), who own the copyright. All other contributions remain Copyright Nicholas Wolverson, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license]. | ### Companies | Username | Company | Terms | | :------- | :--- | :------ | -| [@citizennet](https://github.com/citizennet) | CitizenNet Inc. | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright CitizenNet Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@dbenyamin-cn](https://github.com/dbenyamin-cn) | -| [@slamdata](https://github.com/slamdata) | SlamData, Inc. | Speaking on behalf of SlamData for SlamData employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright SlamData Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - @jdegoes | -| [@qfpl](https://github.com/qfpl) | qfpl @ Data61 / CSIRO | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Data61 / CSIRO, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@lightandlight](https://github.com/lightandlight) | -| [@id3as](https://github.com/id3as) | id3as-company Ltd. | Speaking on behalf of id3as for id3as employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright id3as-company Ltd, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - @adrianroe | -| [@aeternity](https://aeternity.com/) | Aeternity Establishment | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Aeternity Establishment, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). | +| [@citizennet](https://github.com/citizennet) | CitizenNet Inc. | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright CitizenNet Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license]. - [@dbenyamin-cn](https://github.com/dbenyamin-cn) | +| [@slamdata](https://github.com/slamdata) | SlamData, Inc. | Speaking on behalf of SlamData for SlamData employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright SlamData Inc., and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license]. - @jdegoes | +| [@qfpl](https://github.com/qfpl) | qfpl @ Data61 / CSIRO | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Data61 / CSIRO, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license]. - [@lightandlight](https://github.com/lightandlight) | +| [@id3as](https://github.com/id3as) | id3as-company Ltd. | Speaking on behalf of id3as for id3as employees, our existing contributions and all future contributions to the PureScript compiler are, until further notice, Copyright id3as-company Ltd, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license]. - @adrianroe | +| [@aeternity](https://aeternity.com/) | Aeternity Establishment | Our existing contributions to the PureScript compiler and all future contributions to the PureScript compiler until further notice, are Copyright Aeternity Establishment, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license]. | + + +[MIT license]: https://opensource.org/licenses/MIT From ab15ae7ae938d5a78c4854e1057ebb9f1b221020 Mon Sep 17 00:00:00 2001 From: sometimes-i-send-pull-requests Date: Thu, 2 Mar 2023 01:40:25 -0800 Subject: [PATCH 1530/1580] Dark mode support for Pursuit documentation (#4438) * Dark mode support for Pursuit documentation * Add changelog entry --------- Co-authored-by: Alex Kirchhoff --- CHANGELOG.d/feature_pursuit-dark-theme.md | 5 + CONTRIBUTORS.md | 1 + app/static/pursuit.css | 205 +++++++++++++++++++++- app/static/pursuit.less | 198 +++++++++++++++++++-- 4 files changed, 383 insertions(+), 26 deletions(-) create mode 100644 CHANGELOG.d/feature_pursuit-dark-theme.md diff --git a/CHANGELOG.d/feature_pursuit-dark-theme.md b/CHANGELOG.d/feature_pursuit-dark-theme.md new file mode 100644 index 0000000000..f74097901f --- /dev/null +++ b/CHANGELOG.d/feature_pursuit-dark-theme.md @@ -0,0 +1,5 @@ +* Generated documentation now supports dark mode + + PureScript documentation has a new dark theme available. It will + automatically be used based on your browser or system's color scheme + preferences. diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index a4ad8416af..a4f8790422 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -146,6 +146,7 @@ If you would prefer to use different terms, please use the section below instead | [@sigma-andex](https://github.com/sigma-andex) | Jan Schulte | [MIT license] | | [@simonyangme](https://github.com/simonyangme) | Simon Yang | [MIT license] | | [@sloosch](https://github.com/sloosch) | Simon Looschen | [MIT license] | +| [@sometimes-i-send-pull-requests](https://github.com/sometimes-i-send-pull-requests) | Alexander Kirchhoff | [MIT license] | | [@soupi](https://github.com/soupi) | Gil Mizrahi | [MIT license] | | [@stefanholzmueller](https://github.com/stefanholzmueller) | Stefan Holzmüller | [MIT license] | | [@sztupi](https://github.com/sztupi) | Attila Sztupak | [MIT license] | diff --git a/app/static/pursuit.css b/app/static/pursuit.css index eba6222be5..d7641624e0 100644 --- a/app/static/pursuit.css +++ b/app/static/pursuit.css @@ -49,6 +49,9 @@ * ========================================================================== */ /* Section: Document Styles * ========================================================================== */ +:root { + color-scheme: light dark; +} html { box-sizing: border-box; /* This overflow rule prevents everything from shifting slightly to the side @@ -63,11 +66,17 @@ html { } body { background-color: #ffffff; - color: #000; + color: #000000; font-family: "Roboto", sans-serif; font-size: 87.5%; line-height: 1.563; } +@media (prefers-color-scheme: dark) { + body { + background-color: #141417; + color: #dedede; + } +} @media (min-width: 38em) { body { font-size: 100%; @@ -158,6 +167,12 @@ body { background-color: #1d222d; color: #f0f0f0; } +@media (prefers-color-scheme: dark) { + .footer { + background-color: #1d222d; + color: #f0f0f0; + } +} .footer * { margin-bottom: 0; } @@ -169,16 +184,32 @@ body { :target { background-color: #f1f5f9; } +@media (prefers-color-scheme: dark) { + :target { + background-color: #232327; + } +} a, a:visited { color: #c4953a; text-decoration: none; font-weight: bold; } +@media (prefers-color-scheme: dark) { + a, + a:visited { + color: #d8ac55; + } +} a:hover { color: #7b5904; text-decoration: none; } +@media (prefers-color-scheme: dark) { + a:hover { + color: #f0dcab; + } +} code, pre { background-color: #f1f5f9; @@ -187,10 +218,23 @@ pre { font-family: "Roboto Mono", monospace; font-size: 87.5%; } +@media (prefers-color-scheme: dark) { + code, + pre { + background-color: #232327; + color: #c1d3da; + } +} :target code, :target pre { background-color: #dfe8f1; } +@media (prefers-color-scheme: dark) { + :target code, + :target pre { + background-color: #2f2f34; + } +} code { padding: 0.2em 0; margin: 0; @@ -212,6 +256,11 @@ a > code::before { a:hover > code { color: #c4953a; } +@media (prefers-color-scheme: dark) { + a:hover > code { + color: #d8ac55; + } +} pre { margin-top: 0; margin-bottom: 0; @@ -255,14 +304,14 @@ h1 { h2 { font-size: 1.953em; font-weight: normal; - line-height: 1.250; + line-height: 1.25; margin-top: 3.052rem; margin-bottom: 1rem; } h3 { font-size: 1.563em; font-weight: normal; - line-height: 1.250; + line-height: 1.25; margin-top: 2.441rem; margin-bottom: 1rem; } @@ -285,6 +334,11 @@ hr { height: 1px; background-color: #cccccc; } +@media (prefers-color-scheme: dark) { + hr { + background-color: #43434e; + } +} img { border-style: none; max-width: 100%; @@ -302,6 +356,11 @@ table { margin-bottom: 1rem; width: 100%; } +@media (prefers-color-scheme: dark) { + table { + border-bottom-color: #43434e; + } +} td, th { text-align: left; @@ -310,6 +369,11 @@ th { td { border-top: 1px solid #cccccc; } +@media (prefers-color-scheme: dark) { + td { + border-top-color: #43434e; + } +} td:first-child, th:first-child { padding-left: 0; @@ -326,7 +390,7 @@ ul { } ul li { position: relative; - padding-left: 1.250em; + padding-left: 1.25em; } ul li::before { position: absolute; @@ -334,7 +398,12 @@ ul li::before { content: "–"; display: inline-block; margin-left: -1.25em; - width: 1.250em; + width: 1.25em; +} +@media (prefers-color-scheme: dark) { + ul li::before { + color: #a0a0a0; + } } /* Tying this tightly to ul at the moment because it's a slight variation thereof */ ul.ul--search li::before { @@ -345,7 +414,7 @@ ul.ul--search li::before { ol { margin-top: 1rem; margin-bottom: 1rem; - padding-left: 1.250em; + padding-left: 1.25em; } ol li { position: relative; @@ -359,9 +428,9 @@ ol li { position: relative; top: -0.1em; display: inline-block; - background-color: #000; + background-color: #000000; border-radius: 1.3em; - color: #fff; + color: #ffffff; font-size: 77%; font-weight: bold; line-height: 1.563; @@ -369,10 +438,21 @@ ol li { height: 1.5em; width: 1.5em; } +@media (prefers-color-scheme: dark) { + .badge { + background-color: #dedede; + color: #141417; + } +} .badge.badge--package { background-color: #c4953a; letter-spacing: -0.1em; } +@media (prefers-color-scheme: dark) { + .badge.badge--package { + background-color: #d8ac55; + } +} .badge.badge--module { background-color: #75B134; } @@ -396,9 +476,20 @@ ol li { left: -0.8em; color: #bababa; } +@media (prefers-color-scheme: dark) { + .decl__anchor, + .decl__anchor:visited { + color: #878787; + } +} .decl__anchor:hover { color: #c4953a; } +@media (prefers-color-scheme: dark) { + .decl__anchor:hover { + color: #d8ac55; + } +} .decl__signature { background-color: transparent; border-radius: 0; @@ -406,6 +497,12 @@ ol li { border-bottom: 1px solid #cccccc; padding: 0; } +@media (prefers-color-scheme: dark) { + .decl__signature { + border-top-color: #43434e; + border-bottom-color: #43434e; + } +} .decl__signature code { display: block; padding: 0.328em 0; @@ -437,6 +534,11 @@ ol li { .decl__kind { border-bottom: 1px solid #cccccc; } +@media (prefers-color-scheme: dark) { + .decl__kind { + border-bottom-color: #43434e; + } +} :target .decl__signature, :target .decl__signature code { /* We want the background to be transparent, even when the parent is a target */ @@ -444,7 +546,13 @@ ol li { } .decl__body .keyword, .decl__body .syntax { - color: #0B71B4; + color: #0b71b4; +} +@media (prefers-color-scheme: dark) { + .decl__body .keyword, + .decl__body .syntax { + color: #3796d5; + } } .decl__child_comments { margin-top: 1rem; @@ -465,12 +573,22 @@ ol li { font-size: 0.8em; line-height: 1; } +@media (prefers-color-scheme: dark) { + .deplink__version { + color: #a0a0a0; + } +} /* Component: Grouped List * -------------------------------------------------------------------------- */ .grouped-list { border-top: 1px solid #cccccc; margin: 0 0 2.44em 0; } +@media (prefers-color-scheme: dark) { + .grouped-list { + border-top-color: #43434e; + } +} .grouped-list__title { color: #666666; font-size: 0.8em; @@ -479,6 +597,11 @@ ol li { margin: 0.8em 0 -0.1em 0; text-transform: uppercase; } +@media (prefers-color-scheme: dark) { + .grouped-list__title { + border-top-color: #a0a0a0; + } +} .grouped-list__item { margin: 0; } @@ -493,10 +616,22 @@ ol li { background-color: #fff0f0; border-color: #c85050; } +@media (prefers-color-scheme: dark) { + .message.message--error { + background-color: #6b0e0e; + border-color: #c85050; + } +} .message.message--not-available { background-color: #f0f096; border-color: #e3e33d; } +@media (prefers-color-scheme: dark) { + .message.message--not-available { + background-color: #56560b; + border-color: #b0b017; + } +} /* Component: Multi Col * Multiple columns side by side * -------------------------------------------------------------------------- */ @@ -548,6 +683,11 @@ ol li { text-transform: uppercase; z-index: 1; } +@media (prefers-color-scheme: dark) { + .page-title__label { + color: #a0a0a0; + } +} /* Component: Top Banner * -------------------------------------------------------------------------- */ .top-banner { @@ -555,6 +695,12 @@ ol li { color: #f0f0f0; font-weight: normal; } +@media (prefers-color-scheme: dark) { + .top-banner { + background-color: #1d222d; + color: #f0f0f0; + } +} .top-banner__logo, .top-banner__logo:visited { float: left; @@ -564,6 +710,12 @@ ol li { line-height: 90px; margin: 0; } +@media (prefers-color-scheme: dark) { + .top-banner__logo, + .top-banner__logo:visited { + color: #f0f0f0; + } +} .top-banner__logo:hover { color: #c4953a; text-decoration: none; @@ -574,12 +726,20 @@ ol li { .top-banner__form input { border: 1px solid #1d222d; border-radius: 3px; + background-color: #ffffff; color: #1d222d; font-weight: 300; line-height: 2; padding: 0.21em 0.512em; width: 100%; } +@media (prefers-color-scheme: dark) { + .top-banner__form input { + border-color: #1d222d; + background-color: #141417; + color: #dedede; + } +} .top-banner__actions { float: right; text-align: right; @@ -597,9 +757,20 @@ ol li { .top-banner__actions__item a:visited { color: #f0f0f0; } +@media (prefers-color-scheme: dark) { + .top-banner__actions__item a, + .top-banner__actions__item a:visited { + color: #f0f0f0; + } +} .top-banner__actions__item a:hover { color: #c4953a; } +@media (prefers-color-scheme: dark) { + .top-banner__actions__item a:hover { + color: #d8ac55; + } +} @media (min-width: 38em) { .top-banner__logo { float: left; @@ -641,6 +812,12 @@ ol li { border-bottom: 1px solid #cccccc; padding: 0.328em 0; } +@media (prefers-color-scheme: dark) { + .result__signature { + border-top-color: #43434e; + border-bottom-color: #43434e; + } +} .result__signature code { display: block; padding-left: 2.441em; @@ -707,6 +884,11 @@ ol li { color: #777; border-left: 0.25em solid #ddd; } +@media (prefers-color-scheme: dark) { + .markdown-body blockquote { + border-left-color: #444; + } +} .markdown-body blockquote > :first-child { margin-top: 0; } @@ -721,6 +903,11 @@ ol li { /* Keyword */ color: #a0a0a0; } +@media (prefers-color-scheme: dark) { + .markdown-body .pl-k { + color: #676767; + } +} .markdown-body .pl-c1, .markdown-body .pl-en { /* Not really sure what this is */ diff --git a/app/static/pursuit.less b/app/static/pursuit.less index 5358322d41..2520590ca3 100644 --- a/app/static/pursuit.less +++ b/app/static/pursuit.less @@ -49,9 +49,9 @@ /* Section: Variables * ========================================================================== */ @background: rgb(255, 255, 255); +@foreground: rgb(0, 0, 0); @banner_background: rgb(29, 34, 45); -@package_banner_background: lighten(@banner_background, 30%); -@dark_foreground: rgb(240, 240, 240); +@dim_foreground: rgb(240, 240, 240); @link: rgb(196, 149, 58); @link_active: rgb(123, 89, 4); @error_background: rgb(255, 240, 240); @@ -59,12 +59,32 @@ @not_available_background: rgb(240, 240, 150); @code_foreground: rgb(25, 74, 91); @code_background: rgb(241, 245, 249); -@light_glyph: rgb(160, 160, 160); -@light_type: rgb(102, 102, 102); +@dim_glyph: rgb(160, 160, 160); +@dim_type: rgb(102, 102, 102); +@keyword: rgb(11, 113, 180); + +@dark_background: rgb(20, 20, 23); +@dark_foreground: rgb(222, 222, 222); +@dark_banner_background: rgb(29, 34, 45); +@dark_dim_foreground: rgb(240, 240, 240); +@dark_link: rgb(216, 172, 85); +@dark_link_active: rgb(240, 220, 171); +@dark_error_background: rgb(107, 14, 14); +@dark_error_border: rgb(200, 80, 80); +@dark_not_available_background: rgb(86, 86, 11); +@dark_code_foreground: rgb(193, 211, 218); +@dark_code_background: rgb(35, 35, 39); +@dark_dim_glyph: rgb(160, 160, 160); +@dark_dim_type: rgb(160, 160, 160); +@dark_keyword: rgb(55, 150, 213); /* Section: Document Styles * ========================================================================== */ +:root { + color-scheme: light dark; +} + html { box-sizing: border-box; @@ -80,10 +100,15 @@ html { body { background-color: @background; - color: #000; + color: @foreground; font-family: "Roboto", sans-serif; font-size: 87.5%; line-height: 1.563; + + @media (prefers-color-scheme: dark) { + background-color: @dark_background; + color: @dark_foreground; + } } @media (min-width: 38em) { @@ -193,7 +218,12 @@ html, body { width: 100%; text-align: center; background-color: @banner_background; - color: @dark_foreground; + color: @dim_foreground; + + @media (prefers-color-scheme: dark) { + background-color: @dark_banner_background; + color: @dark_dim_foreground; + } } .footer * { @@ -209,17 +239,29 @@ html, body { :target { background-color: @code_background; + + @media (prefers-color-scheme: dark) { + background-color: @dark_code_background; + } } a, a:visited { color: @link; text-decoration: none; font-weight: bold; + + @media (prefers-color-scheme: dark) { + color: @dark_link; + } } a:hover { color: @link_active; text-decoration: none; + + @media (prefers-color-scheme: dark) { + color: @dark_link_active; + } } code, pre { @@ -228,11 +270,20 @@ code, pre { color: @code_foreground; font-family: "Roboto Mono", monospace; font-size: 87.5%; + + @media (prefers-color-scheme: dark) { + background-color: @dark_code_background; + color: @dark_code_foreground; + } } :target code, :target pre { background-color: darken(@code_background, 5%); + + @media (prefers-color-scheme: dark) { + background-color: lighten(@dark_code_background, 5%); + } } code { @@ -259,6 +310,10 @@ a > code::before { a:hover > code { color: @link; + + @media (prefers-color-scheme: dark) { + color: @dark_link; + } } pre { @@ -341,6 +396,10 @@ hr { border: none; height: 1px; background-color: darken(@background, 20%); + + @media (prefers-color-scheme: dark) { + background-color: lighten(@dark_background, 20%); + } } img { @@ -361,6 +420,10 @@ table { margin-top: 1rem; margin-bottom: 1rem; width: 100%; + + @media (prefers-color-scheme: dark) { + border-bottom-color: lighten(@dark_background, 20%); + } } td, th { @@ -370,6 +433,10 @@ td, th { td { border-top: 1px solid darken(@background, 20%); + + @media (prefers-color-scheme: dark) { + border-top-color: lighten(@dark_background, 20%); + } } td:first-child, th:first-child { @@ -394,11 +461,15 @@ ul li { ul li::before { position: absolute; - color: @light_glyph; + color: @dim_glyph; content: "–"; display: inline-block; margin-left: -1.250em; width: 1.250em; + + @media (prefers-color-scheme: dark) { + color: @dark_dim_glyph; + } } /* Tying this tightly to ul at the moment because it's a slight variation thereof */ @@ -430,20 +501,29 @@ ol li { position: relative; top: -0.1em; display: inline-block; - background-color: #000; + background-color: @foreground; border-radius: 1.3em; - color: #fff; + color: @background; font-size: 77%; font-weight: bold; line-height: 1.563; text-align: center; height: 1.5em; width: 1.5em; + + @media (prefers-color-scheme: dark) { + background-color: @dark_foreground; + color: @dark_background; + } } .badge.badge--package { background-color: @link; letter-spacing: -0.1em; + + @media (prefers-color-scheme: dark) { + background-color: @dark_link; + } } .badge.badge--module { @@ -473,11 +553,19 @@ ol li { .decl__anchor, .decl__anchor:visited { position: absolute; left: -0.8em; - color: lighten(@light_glyph, 10%); + color: lighten(@dim_glyph, 10%); + + @media (prefers-color-scheme: dark) { + color: darken(@dark_dim_glyph, 10%); + } } .decl__anchor:hover { color: @link; + + @media (prefers-color-scheme: dark) { + color: @dark_link; + } } .decl__signature { @@ -486,6 +574,11 @@ ol li { border-top: 1px solid darken(@background, 20%); border-bottom: 1px solid darken(@background, 20%); padding: 0; + + @media (prefers-color-scheme: dark) { + border-top-color: lighten(@dark_background, 20%); + border-bottom-color: lighten(@dark_background, 20%); + } } .decl__signature code { @@ -524,6 +617,10 @@ ol li { .decl__kind { border-bottom: 1px solid darken(@background, 20%); + + @media (prefers-color-scheme: dark) { + border-bottom-color: lighten(@dark_background, 20%); + } } :target .decl__signature, @@ -534,7 +631,11 @@ ol li { .decl__body .keyword, .decl__body .syntax { - color: #0B71B4; + color: @keyword; + + @media (prefers-color-scheme: dark) { + color: @dark_keyword; + } } .decl__child_comments { @@ -553,10 +654,14 @@ ol li { } .deplink__version { - color: @light_type; + color: @dim_type; display: inline-block; font-size: 0.8em; line-height: 1; + + @media (prefers-color-scheme: dark) { + color: @dark_dim_type; + } } @@ -566,15 +671,23 @@ ol li { .grouped-list { border-top: 1px solid darken(@background, 20%); margin: 0 0 2.44em 0; + + @media (prefers-color-scheme: dark) { + border-top-color: lighten(@dark_background, 20%); + } } .grouped-list__title { - color: @light_type; + color: @dim_type; font-size: 0.8em; font-weight: 300; letter-spacing: 1px; margin: 0.8em 0 -0.1em 0; text-transform: uppercase; + + @media (prefers-color-scheme: dark) { + border-top-color: @dark_dim_type; + } } .grouped-list__item { @@ -594,11 +707,21 @@ ol li { .message.message--error { background-color: @error_background; border-color: @error_border; + + @media (prefers-color-scheme: dark) { + background-color: @dark_error_background; + border-color: @dark_error_border; + } } .message.message--not-available { background-color: @not_available_background; border-color: darken(@not_available_background, 20%); + + @media (prefers-color-scheme: dark) { + background-color: @dark_not_available_background; + border-color: lighten(@dark_not_available_background, 20%); + } } @@ -655,13 +778,17 @@ ol li { .page-title__label { position: relative; - color: @light_type; + color: @dim_type; font-size: 0.8rem; font-weight: 300; letter-spacing: 1px; margin-bottom: -0.8em; text-transform: uppercase; z-index: 1; + + @media (prefers-color-scheme: dark) { + color: @dark_dim_type; + } } @@ -670,18 +797,27 @@ ol li { .top-banner { background-color: @banner_background; - color: @dark_foreground; + color: @dim_foreground; font-weight: normal; + + @media (prefers-color-scheme: dark) { + background-color: @dark_banner_background; + color: @dark_dim_foreground; + } } .top-banner__logo, .top-banner__logo:visited { float: left; - color: @dark_foreground; + color: @dim_foreground; font-size: 2.44em; font-weight: 300; line-height: 90px; margin: 0; + + @media (prefers-color-scheme: dark) { + color: @dark_dim_foreground; + } } .top-banner__logo:hover { @@ -696,11 +832,18 @@ ol li { .top-banner__form input { border: 1px solid @banner_background; border-radius: 3px; + background-color: @background; color: @banner_background; font-weight: 300; line-height: 2; padding: 0.21em 0.512em; width: 100%; + + @media (prefers-color-scheme: dark) { + border-color: @dark_banner_background; + background-color: @dark_background; + color: @dark_foreground; + } } .top-banner__actions { @@ -721,11 +864,19 @@ ol li { .top-banner__actions__item a, .top-banner__actions__item a:visited { - color: @dark_foreground; + color: @dim_foreground; + + @media (prefers-color-scheme: dark) { + color: @dark_dim_foreground; + } } .top-banner__actions__item a:hover { color: @link; + + @media (prefers-color-scheme: dark) { + color: @dark_link; + } } @media (min-width: 38em) { @@ -780,6 +931,11 @@ ol li { border-top: 1px solid darken(@background, 20%); border-bottom: 1px solid darken(@background, 20%); padding: 0.328em 0; + + @media (prefers-color-scheme: dark) { + border-top-color: lighten(@dark_background, 20%); + border-bottom-color: lighten(@dark_background, 20%); + } } .result__signature code { @@ -864,6 +1020,10 @@ ol li { padding: 0 1em; color: #777; border-left: 0.25em solid #ddd; + + @media (prefers-color-scheme: dark) { + border-left-color: #444; + } } .markdown-body blockquote>:first-child { @@ -882,6 +1042,10 @@ ol li { .markdown-body .pl-k { /* Keyword */ color: #a0a0a0; + + @media (prefers-color-scheme: dark) { + color: #676767; + } } .markdown-body .pl-c1, From 2298c2fd07ab99b8e6bdd9149104424a71f534a9 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Sat, 4 Mar 2023 08:29:39 +0800 Subject: [PATCH 1531/1580] Account for typed holes when checking declarations (#4437) * Account for typed holes when checking declarations * Fix indentation * Float declaration info upwards * Add comment for implementation --- CHANGELOG.d/fix_4408.md | 49 +++++++++++++++++++ .../PureScript/Sugar/BindingGroups.hs | 37 ++++++++++++-- tests/purs/failing/4408Acyclic.out | 22 +++++++++ tests/purs/failing/4408Acyclic.purs | 22 +++++++++ tests/purs/failing/4408AcyclicRecursive.out | 23 +++++++++ tests/purs/failing/4408AcyclicRecursive.purs | 23 +++++++++ tests/purs/failing/4408Cyclic.out | 31 ++++++++++++ tests/purs/failing/4408Cyclic.purs | 29 +++++++++++ tests/purs/failing/4408CyclicTail.out | 26 ++++++++++ tests/purs/failing/4408CyclicTail.purs | 28 +++++++++++ tests/purs/failing/4408CyclicTriple.out | 32 ++++++++++++ tests/purs/failing/4408CyclicTriple.purs | 25 ++++++++++ 12 files changed, 343 insertions(+), 4 deletions(-) create mode 100644 CHANGELOG.d/fix_4408.md create mode 100644 tests/purs/failing/4408Acyclic.out create mode 100644 tests/purs/failing/4408Acyclic.purs create mode 100644 tests/purs/failing/4408AcyclicRecursive.out create mode 100644 tests/purs/failing/4408AcyclicRecursive.purs create mode 100644 tests/purs/failing/4408Cyclic.out create mode 100644 tests/purs/failing/4408Cyclic.purs create mode 100644 tests/purs/failing/4408CyclicTail.out create mode 100644 tests/purs/failing/4408CyclicTail.purs create mode 100644 tests/purs/failing/4408CyclicTriple.out create mode 100644 tests/purs/failing/4408CyclicTriple.purs diff --git a/CHANGELOG.d/fix_4408.md b/CHANGELOG.d/fix_4408.md new file mode 100644 index 0000000000..caf7f86f39 --- /dev/null +++ b/CHANGELOG.d/fix_4408.md @@ -0,0 +1,49 @@ +* Account for typed holes when checking value declarations + + The compiler now takes into account typed holes when ordering value declarations + for type checking, allowing more top-level values to be suggested instead of + being limited by reverse lexicographical ordering. + + Given: + ```purescript + module Main where + + newtype K = K Int + + aRinku :: Int -> K + aRinku = K + + bMaho :: K + bMaho = ?help 0 + + cMuni :: Int -> K + cMuni = K + + dRei :: Int -> K + dRei _ = bMaho + ``` + + Before: + ``` + Hole 'help' has the inferred type + + Int -> K + + You could substitute the hole with one of these values: + + Main.cMuni :: Int -> K + Main.K :: Int -> K + ``` + + After: + ``` + Hole 'help' has the inferred type + + Int -> K + + You could substitute the hole with one of these values: + + Main.aRinku :: Int -> K + Main.cMuni :: Int -> K + Main.K :: Int -> K + ``` diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index ab78f79d8c..b3e87e779e 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -9,7 +9,7 @@ module Language.PureScript.Sugar.BindingGroups ) where import Prelude -import Protolude (ordNub) +import Protolude (ordNub, swap) import Control.Monad ((<=<), guard) import Control.Monad.Error.Class (MonadError(..)) @@ -21,6 +21,7 @@ import Data.Foldable (find) import Data.Functor (($>)) import Data.Maybe (isJust, mapMaybe) import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as M import qualified Data.Set as S import Language.PureScript.AST @@ -103,9 +104,24 @@ createBindingGroups moduleName = mapM f <=< handleDecls in (d, (name, vty), self ++ deps) dataVerts = fmap mkVert allDecls dataBindingGroupDecls <- parU (stronglyConnCompR dataVerts) toDataBindingGroup - let allIdents = fmap valdeclIdent values - valueVerts = fmap (\d -> (d, valdeclIdent d, usedIdents moduleName d `intersect` allIdents)) values - bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName) + let + -- #4437 + -- + -- The idea here is to create a `Graph` whose `key` is a tuple: `(Bool, Ident)`, + -- where the `Bool` encodes the absence of a type hole. This relies on an implementation + -- detail for `stronglyConnComp` which allows identifiers with no type holes to "float" + -- and get checked before those that do, while preserving reverse topological sorting. + makeValueDeclarationKey = (,) <$> exprHasNoTypeHole . valdeclExpression <*> valdeclIdent + valueDeclarationKeys = makeValueDeclarationKey <$> values + + valueDeclarationInfo = M.fromList $ swap <$> valueDeclarationKeys + findDeclarationInfo i = (M.findWithDefault False i valueDeclarationInfo, i) + computeValueDependencies = (`intersect` valueDeclarationKeys) . fmap findDeclarationInfo . usedIdents moduleName + + makeValueDeclarationVert = (,,) <$> id <*> makeValueDeclarationKey <*> computeValueDependencies + valueDeclarationVerts = makeValueDeclarationVert <$> values + + bindingGroupDecls <- parU (stronglyConnComp valueDeclarationVerts) (toBindingGroup moduleName) return $ filter isImportDecl ds ++ dataBindingGroupDecls ++ filter isTypeClassInstanceDecl ds ++ @@ -116,6 +132,19 @@ createBindingGroups moduleName = mapM f <=< handleDecls extractGuardedExpr [MkUnguarded expr] = expr extractGuardedExpr _ = internalError "Expected Guards to have been desugared in handleDecls." + exprHasNoTypeHole :: Expr -> Bool + exprHasNoTypeHole = not . exprHasTypeHole + where + exprHasTypeHole :: Expr -> Bool + (_, exprHasTypeHole, _, _, _) = everythingOnValues (||) goDefault goExpr goDefault goDefault goDefault + where + goExpr :: Expr -> Bool + goExpr (Hole _) = True + goExpr _ = False + + goDefault :: forall a. a -> Bool + goDefault = const False + -- | -- Collapse all binding groups to individual declarations -- diff --git a/tests/purs/failing/4408Acyclic.out b/tests/purs/failing/4408Acyclic.out new file mode 100644 index 0000000000..b5decae42a --- /dev/null +++ b/tests/purs/failing/4408Acyclic.out @@ -0,0 +1,22 @@ +Error found: +in module Main +at tests/purs/failing/4408Acyclic.purs:16:9 - 16:14 (line 16, column 9 - line 16, column 14) + + Hole 'help' has the inferred type +   +  Int -> K +   + You could substitute the hole with one of these values: +   +  Main.aRinku :: Int -> K  +  Main.cMuni :: Int -> K  +  Safe.Coerce.coerce :: forall a b. Coercible a b => a -> b +  Unsafe.Coerce.unsafeCoerce :: forall a b. a -> b  +  Main.K :: Int -> K  +   + +in value declaration bMaho + +See https://github.com/purescript/documentation/blob/master/errors/HoleInferredType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4408Acyclic.purs b/tests/purs/failing/4408Acyclic.purs new file mode 100644 index 0000000000..df5a7ea8e3 --- /dev/null +++ b/tests/purs/failing/4408Acyclic.purs @@ -0,0 +1,22 @@ +-- @shouldFailWith HoleInferredType +module Main where + +-- Expected: +-- +-- aRinku+cMuni -> bMaho -> dRei +-- +-- Both aRinku and cMuni is suggested + +newtype K = K Int + +aRinku :: Int -> K +aRinku = K + +bMaho :: K +bMaho = ?help 0 + +cMuni :: Int -> K +cMuni = K + +dRei :: Int -> K +dRei _ = bMaho diff --git a/tests/purs/failing/4408AcyclicRecursive.out b/tests/purs/failing/4408AcyclicRecursive.out new file mode 100644 index 0000000000..fbfe1db8c8 --- /dev/null +++ b/tests/purs/failing/4408AcyclicRecursive.out @@ -0,0 +1,23 @@ +Error found: +in module Main +at tests/purs/failing/4408AcyclicRecursive.purs:17:11 - 17:16 (line 17, column 11 - line 17, column 16) + + Hole 'help' has the inferred type +   +  Int -> K +   + You could substitute the hole with one of these values: +   +  Main.aRinku :: Int -> K  +  Main.bMaho :: Int -> K  +  Main.cMuni :: Int -> K  +  Safe.Coerce.coerce :: forall a b. Coercible a b => a -> b +  Unsafe.Coerce.unsafeCoerce :: forall a b. a -> b  +  Main.K :: Int -> K  +   + +in value declaration bMaho + +See https://github.com/purescript/documentation/blob/master/errors/HoleInferredType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4408AcyclicRecursive.purs b/tests/purs/failing/4408AcyclicRecursive.purs new file mode 100644 index 0000000000..c4d7ad140b --- /dev/null +++ b/tests/purs/failing/4408AcyclicRecursive.purs @@ -0,0 +1,23 @@ +-- @shouldFailWith HoleInferredType +module Main where + +-- Expected: +-- +-- aRinku+cMuni -> bMaho -> dRei +-- +-- aRinku, cMuni, and bMaho are all suggested. +-- bMaho can be aware of itself during checking. + +newtype K = K Int + +aRinku :: Int -> K +aRinku = K + +bMaho :: Int -> K +bMaho _ = ?help 0 + +cMuni :: Int -> K +cMuni = K + +dRei :: Int -> K +dRei _ = bMaho diff --git a/tests/purs/failing/4408Cyclic.out b/tests/purs/failing/4408Cyclic.out new file mode 100644 index 0000000000..24aed1b1c1 --- /dev/null +++ b/tests/purs/failing/4408Cyclic.out @@ -0,0 +1,31 @@ +Error found: +in module Main +at tests/purs/failing/4408Cyclic.purs:23:29 - 23:34 (line 23, column 29 - line 23, column 34) + + Hole 'help' has the inferred type +   +  Int -> K +   + You could substitute the hole with one of these values: +   +  Main.aSaki :: Int -> K  +  Main.bNoa :: forall a. a -> K  +  Main.cTowa :: forall a. a -> K  +  Main.eSaki :: Int -> K  +  Safe.Coerce.coerce :: forall a b. Coercible a b => a -> b +  Unsafe.Coerce.unsafeCoerce :: forall a b. a -> b  +  Main.K :: Int -> K  +   + in the following context: + + a :: a0 + + +in binding group cTowa, bNoa + +where a0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + +See https://github.com/purescript/documentation/blob/master/errors/HoleInferredType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4408Cyclic.purs b/tests/purs/failing/4408Cyclic.purs new file mode 100644 index 0000000000..96d15e4532 --- /dev/null +++ b/tests/purs/failing/4408Cyclic.purs @@ -0,0 +1,29 @@ +-- @shouldFailWith HoleInferredType +module Main where + +-- Expected: +-- +-- aSaki/eSaki -> bNoa~cTowa -> dIbuki +-- +-- Only aSaki/eSaki, bNoa, and cTowa is suggested. +-- +-- The mutual recursion between bNoa and cTowa +-- ensures they exist "at the same time". dIbuki +-- depends on cTowa, so it's checked much later. + +newtype K = K Int + +aSaki :: Int -> K +aSaki = K + +bNoa :: forall a. a -> K +bNoa a = let _ = cTowa a in K 0 + +cTowa :: forall a. a -> K +cTowa a = let _ = bNoa a in ?help 0 + +dIbuki :: Int -> K +dIbuki = bNoa + +eSaki :: Int -> K +eSaki = K diff --git a/tests/purs/failing/4408CyclicTail.out b/tests/purs/failing/4408CyclicTail.out new file mode 100644 index 0000000000..9dfe2fa39d --- /dev/null +++ b/tests/purs/failing/4408CyclicTail.out @@ -0,0 +1,26 @@ +Error found: +in module Main +at tests/purs/failing/4408CyclicTail.purs:22:11 - 22:16 (line 22, column 11 - line 22, column 16) + + Hole 'help' has the inferred type +   +  Int -> K +   + You could substitute the hole with one of these values: +   +  Main.aKyoko :: Int -> K  +  Main.bShinobu :: forall a. a -> K  +  Main.cEsora :: forall a. a -> K  +  Main.dYuka :: Int -> K  +  Main.eShinobu :: forall a. a -> K  +  Main.fEsora :: forall a. a -> K  +  Safe.Coerce.coerce :: forall a b. Coercible a b => a -> b +  Unsafe.Coerce.unsafeCoerce :: forall a b. a -> b  +  Main.K :: Int -> K  +   + +in value declaration dYuka + +See https://github.com/purescript/documentation/blob/master/errors/HoleInferredType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4408CyclicTail.purs b/tests/purs/failing/4408CyclicTail.purs new file mode 100644 index 0000000000..17347d43b0 --- /dev/null +++ b/tests/purs/failing/4408CyclicTail.purs @@ -0,0 +1,28 @@ +-- @shouldFailWith HoleInferredType +module Main where + +-- Expected: +-- +-- aKyoko -> bShinobu~cEsora/eShinobu~fEsora -> dYuka +-- +-- All are suggested, as dYuka is also recursive. + +newtype K = K Int + +aKyoko :: Int -> K +aKyoko = K + +bShinobu :: forall a. a -> K +bShinobu a = let _ = cEsora a in K 0 + +cEsora :: forall a. a -> K +cEsora a = let _ = bShinobu a in K 0 + +dYuka :: Int -> K +dYuka _ = ?help 0 + +eShinobu :: forall a. a -> K +eShinobu a = let _ = fEsora a in K 0 + +fEsora :: forall a. a -> K +fEsora a = let _ = eShinobu a in K 0 diff --git a/tests/purs/failing/4408CyclicTriple.out b/tests/purs/failing/4408CyclicTriple.out new file mode 100644 index 0000000000..d6d0925b8a --- /dev/null +++ b/tests/purs/failing/4408CyclicTriple.out @@ -0,0 +1,32 @@ +Error found: +in module Main +at tests/purs/failing/4408CyclicTriple.purs:22:33 - 22:38 (line 22, column 33 - line 22, column 38) + + Hole 'help' has the inferred type +   +  Int -> K +   + You could substitute the hole with one of these values: +   +  Main.aHaruna :: Int -> K  +  Main.bMiyu :: forall a. a -> K  +  Main.cKurumi :: forall a. a -> K  +  Main.dMiiko :: forall a. a -> K  +  Main.eHaruna :: Int -> K  +  Safe.Coerce.coerce :: forall a b. Coercible a b => a -> b +  Unsafe.Coerce.unsafeCoerce :: forall a b. a -> b  +  Main.K :: Int -> K  +   + in the following context: + + a :: a0 + + +in binding group dMiiko, cKurumi, bMiyu + +where a0 is a rigid type variable + bound at (line 0, column 0 - line 0, column 0) + +See https://github.com/purescript/documentation/blob/master/errors/HoleInferredType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4408CyclicTriple.purs b/tests/purs/failing/4408CyclicTriple.purs new file mode 100644 index 0000000000..d0b3d35a80 --- /dev/null +++ b/tests/purs/failing/4408CyclicTriple.purs @@ -0,0 +1,25 @@ +-- @shouldFailWith HoleInferredType +module Main where + +-- Expected: +-- +-- aHaruna/eHaruna -> bMiyu~cKurumi~dMiiko +-- +-- All are suggested. + +newtype K = K Int + +aHaruna :: Int -> K +aHaruna = K + +bMiyu :: forall a. a -> K +bMiyu a = let _ = dMiiko a in K 0 + +cKurumi :: forall a. a -> K +cKurumi a = let _ = bMiyu a in K 0 + +dMiiko :: forall a. a -> K +dMiiko a = let _ = cKurumi a in ?help 0 + +eHaruna :: Int -> K +eHaruna = K From 85043bfbafad8064212c5ab6ca9ce4a729bb0025 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 3 Mar 2023 21:59:25 -0600 Subject: [PATCH 1532/1580] Update internal scripts to latest resolvers (#4445) * Update generator to latest resolver * Fix multiple packages define same module problem * Update changelog script to latest resolver; fix issues * Add changelog entry --- .../internal_update-script-resolvers.md | 1 + license-generator/generate.hs | 10 +++++- update-changelog.hs | 33 +++++++++++++------ 3 files changed, 33 insertions(+), 11 deletions(-) create mode 100644 CHANGELOG.d/internal_update-script-resolvers.md diff --git a/CHANGELOG.d/internal_update-script-resolvers.md b/CHANGELOG.d/internal_update-script-resolvers.md new file mode 100644 index 0000000000..6a913f5501 --- /dev/null +++ b/CHANGELOG.d/internal_update-script-resolvers.md @@ -0,0 +1 @@ +* Update license/changelog scrips to latest Stack resolver diff --git a/license-generator/generate.hs b/license-generator/generate.hs index 817d39c715..d000f2276c 100644 --- a/license-generator/generate.hs +++ b/license-generator/generate.hs @@ -1,5 +1,13 @@ #!/usr/bin/env stack --- stack --resolver lts-13.12 script +{- stack + --resolver lts-20.9 script + --package bytestring + --package http-client-tls + --package http-client + --package http-types + --package text + --package split +-} {-# LANGUAGE TupleSections #-} -- | diff --git a/update-changelog.hs b/update-changelog.hs index bb149ec903..b9296440d4 100755 --- a/update-changelog.hs +++ b/update-changelog.hs @@ -1,5 +1,18 @@ #!/usr/bin/env stack --- stack --resolver lts-17.6 script +{- stack + --resolver lts-20.9 script + --package bytestring + --package filepath + --package text + --package github-rest + --package directory + --package simple-cmd + --package time + --package bifunctors + --package attoparsec + --package aeson + --package protolude +-} {-# LANGUAGE DeriveFoldable , DeriveFunctor @@ -37,11 +50,11 @@ import qualified Protolude import Control.Monad.Fail (fail) import qualified Data.Aeson as JSON +import qualified Data.Aeson.KeyMap as KM import Data.Attoparsec.ByteString (maybeResult, parse) import "bifunctors" Data.Bifunctor.Flip (Flip(..)) import qualified Data.ByteString as BS -import qualified Data.HashMap.Lazy as HM import qualified Data.List.NonEmpty as NEL import Data.String (String) import qualified Data.String as String @@ -49,12 +62,12 @@ import qualified Data.Text as T import Data.Time.Clock (UTCTime) import Data.Time.Format.ISO8601 (iso8601ParseM) import Data.Time.LocalTime (zonedTimeToUTC) -import GitHub.REST (GHEndpoint(..), GitHubState(..), KeyValue(..), MonadGitHubREST, StdMethod(..), queryGitHub, runGitHubT) +import GitHub.REST (GHEndpoint(..), GitHubSettings(..), KeyValue(..), MonadGitHubREST, StdMethod(..), queryGitHub, runGitHubT) import qualified SimpleCmd.Git as IOGit import System.Directory (setCurrentDirectory) import System.FilePath (normalise, takeFileName, ()) -main = runGitHubT gitHubState $ do +main = runGitHubT gitHubSettings $ do git "rev-parse" ["--show-toplevel"] >>= liftIO . setCurrentDirectory entries <- String.lines <$> git "ls-tree" ["--name-only", "HEAD", "CHANGELOG.d/"] @@ -87,8 +100,8 @@ main = runGitHubT gitHubState $ do git_ "add" ["CHANGELOG.md"] git_ "rm" $ "-q" : entryFiles -gitHubState :: GitHubState -gitHubState = GitHubState Nothing "purescript/purescript update-changelog.hs" "v3" +gitHubSettings :: GitHubSettings +gitHubSettings = GitHubSettings Nothing "purescript/purescript update-changelog.hs" "v3" processEntriesStartingWith :: (MonadFail m, MonadGitHubREST m, MonadIO m) => String -> [String] -> m [ChangelogEntry] processEntriesStartingWith prefix @@ -126,8 +139,8 @@ updateEntry file = do parsePRNumber :: Text -> Maybe (CommitType, Int) parsePRNumber = liftA2 (<|>) - (fmap (MergeCommit, ) . readMaybe . toS . fst . T.breakOn " " <=< T.stripPrefix "Merge pull request #") - (fmap (SquashCommit, ) . readMaybe . toS <=< T.stripSuffix ")" . snd . T.breakOnEnd "(#") + (fmap (MergeCommit, ) . readMaybe . (toS :: T.Text -> String) . fst . T.breakOn " " <=< T.stripPrefix "Merge pull request #") + (fmap (SquashCommit, ) . readMaybe . (toS :: T.Text -> String) <=< T.stripSuffix ")" . snd . T.breakOnEnd "(#") -- | -- This function helps us exclude PRs that are just fixups of changelog @@ -149,7 +162,7 @@ lookupPRAuthor prNum = , ghData = [] } >>= \case - JSON.Object (HM.lookup "user" -> Just (JSON.Object (HM.lookup "login" -> Just (JSON.String name)))) -> pure name + JSON.Object (KM.lookup "user" -> Just (JSON.Object (KM.lookup "login" -> Just (JSON.String name)))) -> pure name _ -> fail "error accessing GitHub API" commaSeparate :: [Text] -> Text @@ -162,7 +175,7 @@ commaSeparate = \case getVersion :: (MonadFail m, MonadIO m) => m Text getVersion = (liftIO . BS.readFile) ("npm-package" "package.json") >>= \case - (maybeResult . parse JSON.json -> Just (JSON.Object (HM.lookup "version" -> Just (JSON.String v)))) -> pure v + (maybeResult . parse JSON.json -> Just (JSON.Object (KM.lookup "version" -> Just (JSON.String v)))) -> pure v _ -> fail "could not read version from npm-package/package.json" conditionalSection :: Text -> [ChangelogEntry] -> Text From f496fc4c09c90df181b361a3586962d36230e03f Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Mon, 6 Mar 2023 05:12:01 -0600 Subject: [PATCH 1533/1580] Prep 0.15.8 release (#4444) * Bump version to 0.15.8 * Update license * Update changelog --- CHANGELOG.d/feature_pursuit-dark-theme.md | 5 -- CHANGELOG.d/fix_4408.md | 49 ------------ CHANGELOG.d/fix_4431.purs | 1 - .../fix_add-labels-in-type-mismatch-errors.md | 1 - .../internal_update-script-resolvers.md | 1 - CHANGELOG.d/misc_bump-ghc.md | 1 - CHANGELOG.md | 74 +++++++++++++++++++ LICENSE | 34 +++++++++ npm-package/package.json | 4 +- purescript.cabal | 2 +- 10 files changed, 111 insertions(+), 61 deletions(-) delete mode 100644 CHANGELOG.d/feature_pursuit-dark-theme.md delete mode 100644 CHANGELOG.d/fix_4408.md delete mode 100644 CHANGELOG.d/fix_4431.purs delete mode 100644 CHANGELOG.d/fix_add-labels-in-type-mismatch-errors.md delete mode 100644 CHANGELOG.d/internal_update-script-resolvers.md delete mode 100644 CHANGELOG.d/misc_bump-ghc.md diff --git a/CHANGELOG.d/feature_pursuit-dark-theme.md b/CHANGELOG.d/feature_pursuit-dark-theme.md deleted file mode 100644 index f74097901f..0000000000 --- a/CHANGELOG.d/feature_pursuit-dark-theme.md +++ /dev/null @@ -1,5 +0,0 @@ -* Generated documentation now supports dark mode - - PureScript documentation has a new dark theme available. It will - automatically be used based on your browser or system's color scheme - preferences. diff --git a/CHANGELOG.d/fix_4408.md b/CHANGELOG.d/fix_4408.md deleted file mode 100644 index caf7f86f39..0000000000 --- a/CHANGELOG.d/fix_4408.md +++ /dev/null @@ -1,49 +0,0 @@ -* Account for typed holes when checking value declarations - - The compiler now takes into account typed holes when ordering value declarations - for type checking, allowing more top-level values to be suggested instead of - being limited by reverse lexicographical ordering. - - Given: - ```purescript - module Main where - - newtype K = K Int - - aRinku :: Int -> K - aRinku = K - - bMaho :: K - bMaho = ?help 0 - - cMuni :: Int -> K - cMuni = K - - dRei :: Int -> K - dRei _ = bMaho - ``` - - Before: - ``` - Hole 'help' has the inferred type - - Int -> K - - You could substitute the hole with one of these values: - - Main.cMuni :: Int -> K - Main.K :: Int -> K - ``` - - After: - ``` - Hole 'help' has the inferred type - - Int -> K - - You could substitute the hole with one of these values: - - Main.aRinku :: Int -> K - Main.cMuni :: Int -> K - Main.K :: Int -> K - ``` diff --git a/CHANGELOG.d/fix_4431.purs b/CHANGELOG.d/fix_4431.purs deleted file mode 100644 index 05b8333c92..0000000000 --- a/CHANGELOG.d/fix_4431.purs +++ /dev/null @@ -1 +0,0 @@ -* Fix instance deriving regression diff --git a/CHANGELOG.d/fix_add-labels-in-type-mismatch-errors.md b/CHANGELOG.d/fix_add-labels-in-type-mismatch-errors.md deleted file mode 100644 index f658f51f9a..0000000000 --- a/CHANGELOG.d/fix_add-labels-in-type-mismatch-errors.md +++ /dev/null @@ -1 +0,0 @@ - * Outputs what label the type-error occurred on when types don't match diff --git a/CHANGELOG.d/internal_update-script-resolvers.md b/CHANGELOG.d/internal_update-script-resolvers.md deleted file mode 100644 index 6a913f5501..0000000000 --- a/CHANGELOG.d/internal_update-script-resolvers.md +++ /dev/null @@ -1 +0,0 @@ -* Update license/changelog scrips to latest Stack resolver diff --git a/CHANGELOG.d/misc_bump-ghc.md b/CHANGELOG.d/misc_bump-ghc.md deleted file mode 100644 index 165ac355c5..0000000000 --- a/CHANGELOG.d/misc_bump-ghc.md +++ /dev/null @@ -1 +0,0 @@ -* Bump Stackage snapshot to lts-20.9 and GHC to 9.2.5 diff --git a/CHANGELOG.md b/CHANGELOG.md index 5314a5561e..d1c1c3d925 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,80 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.8 + +New features: + +* Generated documentation now supports dark mode (#4438 by @sometimes-i-send-pull-requests) + + PureScript documentation has a new dark theme available. It will + automatically be used based on your browser or system's color scheme + preferences. + +Bugfixes: + +* Fix instance deriving regression (#4432 by @rhendric) + +* Outputs what label the type-error occurred on when types don't match (#4411 by @FredTheDino) + +* Account for typed holes when checking value declarations (#4437 by @purefunctor) + + The compiler now takes into account typed holes when ordering value declarations + for type checking, allowing more top-level values to be suggested instead of + being limited by reverse lexicographical ordering. + + Given: + ```purescript + module Main where + + newtype K = K Int + + aRinku :: Int -> K + aRinku = K + + bMaho :: K + bMaho = ?help 0 + + cMuni :: Int -> K + cMuni = K + + dRei :: Int -> K + dRei _ = bMaho + ``` + + Before: + ``` + Hole 'help' has the inferred type + + Int -> K + + You could substitute the hole with one of these values: + + Main.cMuni :: Int -> K + Main.K :: Int -> K + ``` + + After: + ``` + Hole 'help' has the inferred type + + Int -> K + + You could substitute the hole with one of these values: + + Main.aRinku :: Int -> K + Main.cMuni :: Int -> K + Main.K :: Int -> K + ``` + +Other improvements: + +* Bump Stackage snapshot to lts-20.9 and GHC to 9.2.5 (#4422, #4428, and #4433 by @purefunctor, @JordanMartinez, and @andys8) + +Internal: + +* Update license/changelog scrips to latest Stack resolver (#4445 by @JordanMartinez) + ## 0.15.7 New features: diff --git a/LICENSE b/LICENSE index 29d843bea4..490ff3651c 100644 --- a/LICENSE +++ b/LICENSE @@ -56,6 +56,7 @@ PureScript uses the following Haskell library packages. Their license files foll contravariant cryptonite css-text + data-array-byte data-default data-default-class data-default-instances-containers @@ -1518,6 +1519,39 @@ css-text LICENSE file: OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +data-array-byte LICENSE file: + + Copyright (c) 2008-2009, Roman Leshchinskiy + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. + + data-default LICENSE file: Copyright (c) 2013 Lukas Mai diff --git a/npm-package/package.json b/npm-package/package.json index 1cb36d4747..b0ac8d355c 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.7", + "version": "0.15.8", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.7", + "postinstall": "install-purescript --purs-ver=0.15.8", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index b426757e8a..4f95bc4e43 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.7 +version: 0.15.8 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 5a79544af92e2a1247c015e7f9155400155e58c9 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 10 Mar 2023 19:29:17 -0600 Subject: [PATCH 1534/1580] Simplify imports with post qualified style (#4451) - Changes made across `app`, `src`, and `tests`: ```diff -import qualified Foo +import Foo qualified -import qualified Foo as F +import Foo qualified as F -import qualified Foo as F +import Foo qualified as F -import Foo +import Foo -import Foo (bar) +import Foo (bar) -import "monad-logger" Foo +import "monad-logger" Foo ``` - added `ImportQualifiedPost` extension - removed `-Wno-prepositive-qualified-module` --- CHANGELOG.d/internal_simplify-imports.md | 1 + app/Command/Bundle.hs | 6 +- app/Command/Compile.hs | 42 ++++---- app/Command/Docs.hs | 36 +++---- app/Command/Docs/Html.hs | 32 +++--- app/Command/Docs/Markdown.hs | 12 +-- app/Command/Graph.hs | 28 ++--- app/Command/Hierarchy.hs | 34 +++--- app/Command/Ide.hs | 44 ++++---- app/Command/Publish.hs | 18 ++-- app/Command/REPL.hs | 40 +++---- app/Main.hs | 30 +++--- app/Version.hs | 2 +- purescript.cabal | 2 +- src/Language/PureScript.hs | 2 +- src/Language/PureScript/AST/Declarations.hs | 6 +- .../PureScript/AST/Declarations/ChainId.hs | 2 +- src/Language/PureScript/AST/Exported.hs | 2 +- src/Language/PureScript/AST/Operators.hs | 2 +- src/Language/PureScript/AST/SourcePos.hs | 4 +- src/Language/PureScript/AST/Traversals.hs | 6 +- src/Language/PureScript/Bundle.hs | 4 +- src/Language/PureScript/CST.hs | 6 +- src/Language/PureScript/CST/Convert.hs | 18 ++-- src/Language/PureScript/CST/Errors.hs | 2 +- src/Language/PureScript/CST/Layout.hs | 2 +- src/Language/PureScript/CST/Lexer.hs | 10 +- src/Language/PureScript/CST/Monad.hs | 2 +- src/Language/PureScript/CST/Positions.hs | 4 +- src/Language/PureScript/CST/Print.hs | 4 +- src/Language/PureScript/CST/Types.hs | 4 +- src/Language/PureScript/CST/Utils.hs | 8 +- src/Language/PureScript/CodeGen/JS.hs | 16 +-- src/Language/PureScript/CodeGen/JS/Common.hs | 2 +- src/Language/PureScript/CodeGen/JS/Printer.hs | 6 +- src/Language/PureScript/Constants/Libs.hs | 4 +- src/Language/PureScript/Constants/Prim.hs | 2 +- src/Language/PureScript/CoreFn/CSE.hs | 8 +- src/Language/PureScript/CoreFn/Desugar.hs | 8 +- src/Language/PureScript/CoreFn/FromJSON.hs | 36 +++---- src/Language/PureScript/CoreFn/Laziness.hs | 12 +-- src/Language/PureScript/CoreFn/Optimizer.hs | 4 +- src/Language/PureScript/CoreFn/ToJSON.hs | 36 +++---- src/Language/PureScript/CoreImp/Module.hs | 2 +- .../PureScript/CoreImp/Optimizer/Inliner.hs | 6 +- .../PureScript/CoreImp/Optimizer/MagicDo.hs | 2 +- .../PureScript/CoreImp/Optimizer/TCO.hs | 2 +- .../PureScript/CoreImp/Optimizer/Unused.hs | 4 +- src/Language/PureScript/Docs/AsHtml.hs | 14 +-- src/Language/PureScript/Docs/AsMarkdown.hs | 6 +- src/Language/PureScript/Docs/Collect.hs | 28 ++--- src/Language/PureScript/Docs/Convert.hs | 28 ++--- .../PureScript/Docs/Convert/ReExports.hs | 18 ++-- .../PureScript/Docs/Convert/Single.hs | 14 +-- src/Language/PureScript/Docs/Prim.hs | 12 +-- src/Language/PureScript/Docs/Render.hs | 10 +- .../PureScript/Docs/RenderedCode/Types.hs | 8 +- src/Language/PureScript/Docs/Tags.hs | 8 +- src/Language/PureScript/Docs/Types.hs | 30 +++--- src/Language/PureScript/Environment.hs | 16 +-- src/Language/PureScript/Errors.hs | 100 +++++++++--------- src/Language/PureScript/Errors/JSON.hs | 6 +- src/Language/PureScript/Externs.hs | 6 +- src/Language/PureScript/Graph.hs | 42 ++++---- src/Language/PureScript/Hierarchy.hs | 10 +- src/Language/PureScript/Ide.hs | 50 ++++----- src/Language/PureScript/Ide/CaseSplit.hs | 24 ++--- src/Language/PureScript/Ide/Command.hs | 22 ++-- src/Language/PureScript/Ide/Completion.hs | 24 ++--- src/Language/PureScript/Ide/Error.hs | 16 +-- src/Language/PureScript/Ide/Externs.hs | 22 ++-- src/Language/PureScript/Ide/Filter.hs | 28 ++--- .../PureScript/Ide/Filter/Declaration.hs | 6 +- src/Language/PureScript/Ide/Filter/Imports.hs | 4 +- src/Language/PureScript/Ide/Imports.hs | 18 ++-- .../PureScript/Ide/Imports/Actions.hs | 34 +++--- src/Language/PureScript/Ide/Logging.hs | 12 +-- src/Language/PureScript/Ide/Matcher.hs | 20 ++-- src/Language/PureScript/Ide/Prim.hs | 14 +-- src/Language/PureScript/Ide/Rebuild.hs | 40 +++---- src/Language/PureScript/Ide/Reexports.hs | 12 +-- src/Language/PureScript/Ide/SourceFile.hs | 16 +-- src/Language/PureScript/Ide/State.hs | 38 +++---- src/Language/PureScript/Ide/Types.hs | 26 ++--- src/Language/PureScript/Ide/Usage.hs | 16 +-- src/Language/PureScript/Ide/Util.hs | 24 ++--- src/Language/PureScript/Interactive.hs | 66 ++++++------ .../PureScript/Interactive/Completion.hs | 22 ++-- .../PureScript/Interactive/Message.hs | 12 +-- src/Language/PureScript/Interactive/Module.hs | 14 +-- src/Language/PureScript/Interactive/Parser.hs | 26 ++--- .../PureScript/Interactive/Printer.hs | 18 ++-- src/Language/PureScript/Interactive/Types.hs | 16 +-- src/Language/PureScript/Label.hs | 2 +- src/Language/PureScript/Linter.hs | 6 +- src/Language/PureScript/Linter/Exhaustive.hs | 6 +- src/Language/PureScript/Linter/Imports.hs | 6 +- src/Language/PureScript/Make.hs | 80 +++++++------- src/Language/PureScript/Make/Actions.hs | 94 ++++++++-------- src/Language/PureScript/Make/BuildPlan.hs | 44 ++++---- src/Language/PureScript/Make/Cache.hs | 10 +- src/Language/PureScript/Make/Monad.hs | 56 +++++----- src/Language/PureScript/ModuleDependencies.hs | 18 ++-- src/Language/PureScript/Names.hs | 4 +- src/Language/PureScript/Options.hs | 4 +- src/Language/PureScript/PSString.hs | 12 +-- src/Language/PureScript/Pretty/Common.hs | 4 +- src/Language/PureScript/Pretty/Types.hs | 2 +- src/Language/PureScript/Pretty/Values.hs | 6 +- src/Language/PureScript/Publish.hs | 16 +-- .../PureScript/Publish/BoxesHelpers.hs | 4 +- .../PureScript/Publish/ErrorsWarnings.hs | 10 +- .../PureScript/Publish/Registry/Compat.hs | 4 +- src/Language/PureScript/Renamer.hs | 6 +- src/Language/PureScript/Roles.hs | 4 +- src/Language/PureScript/Sugar/AdoNotation.hs | 18 ++-- .../PureScript/Sugar/BindingGroups.hs | 6 +- src/Language/PureScript/Sugar/DoNotation.hs | 22 ++-- src/Language/PureScript/Sugar/Names.hs | 6 +- src/Language/PureScript/Sugar/Names/Env.hs | 6 +- .../PureScript/Sugar/Names/Exports.hs | 2 +- .../PureScript/Sugar/Names/Imports.hs | 4 +- .../PureScript/Sugar/ObjectWildcards.hs | 24 ++--- src/Language/PureScript/Sugar/Operators.hs | 4 +- .../PureScript/Sugar/Operators/Common.hs | 10 +- .../PureScript/Sugar/Operators/Expr.hs | 4 +- src/Language/PureScript/Sugar/TypeClasses.hs | 48 ++++----- .../PureScript/Sugar/TypeClasses/Deriving.hs | 32 +++--- src/Language/PureScript/TypeChecker.hs | 10 +- .../PureScript/TypeChecker/Deriving.hs | 6 +- .../PureScript/TypeChecker/Entailment.hs | 12 +-- .../TypeChecker/Entailment/Coercible.hs | 6 +- .../TypeChecker/Entailment/IntCompare.hs | 10 +- src/Language/PureScript/TypeChecker/Kinds.hs | 8 +- src/Language/PureScript/TypeChecker/Monad.hs | 6 +- src/Language/PureScript/TypeChecker/Roles.hs | 4 +- .../PureScript/TypeChecker/Synonyms.hs | 22 ++-- .../PureScript/TypeChecker/TypeSearch.hs | 40 +++---- src/Language/PureScript/TypeChecker/Types.hs | 8 +- src/Language/PureScript/TypeChecker/Unify.hs | 6 +- src/Language/PureScript/Types.hs | 10 +- src/System/IO/UTF8.hs | 14 +-- .../Language/PureScript/Ide/CompletionSpec.hs | 4 +- tests/Language/PureScript/Ide/FilterSpec.hs | 20 ++-- tests/Language/PureScript/Ide/ImportsSpec.hs | 26 ++--- tests/Language/PureScript/Ide/MatcherSpec.hs | 12 +-- tests/Language/PureScript/Ide/RebuildSpec.hs | 24 ++--- .../Language/PureScript/Ide/ReexportsSpec.hs | 16 +-- .../Language/PureScript/Ide/SourceFileSpec.hs | 14 +-- tests/Language/PureScript/Ide/StateSpec.hs | 16 +-- tests/Language/PureScript/Ide/Test.hs | 28 ++--- tests/Language/PureScript/Ide/UsageSpec.hs | 18 ++-- tests/Main.hs | 30 +++--- tests/TestCompiler.hs | 8 +- tests/TestCst.hs | 6 +- tests/TestDocs.hs | 12 +-- tests/TestGraph.hs | 4 +- tests/TestHierarchy.hs | 2 +- tests/TestIde.hs | 10 +- tests/TestMake.hs | 10 +- tests/TestPrimDocs.hs | 8 +- tests/TestPscPublish.hs | 8 +- tests/TestPsci/CompletionTest.hs | 16 +-- tests/TestPsci/EvalTest.hs | 22 ++-- tests/TestPsci/TestEnv.hs | 30 +++--- tests/TestSourceMaps.hs | 8 +- tests/TestUtils.hs | 18 ++-- 167 files changed, 1339 insertions(+), 1338 deletions(-) create mode 100644 CHANGELOG.d/internal_simplify-imports.md diff --git a/CHANGELOG.d/internal_simplify-imports.md b/CHANGELOG.d/internal_simplify-imports.md new file mode 100644 index 0000000000..13bf406888 --- /dev/null +++ b/CHANGELOG.d/internal_simplify-imports.md @@ -0,0 +1 @@ +* Refactor module imports to make identifiers' origins obvious diff --git a/app/Command/Bundle.hs b/app/Command/Bundle.hs index 266e91a708..99c72312b9 100644 --- a/app/Command/Bundle.hs +++ b/app/Command/Bundle.hs @@ -3,9 +3,9 @@ module Command.Bundle (command) where import Prelude -import System.Exit (exitFailure) -import System.IO (stderr, hPutStrLn) -import qualified Options.Applicative as Opts +import System.Exit (exitFailure) +import System.IO (stderr, hPutStrLn) +import Options.Applicative qualified as Opts app :: IO () app = do diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 3972994194..f5c82186e2 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -2,27 +2,27 @@ module Command.Compile (command) where import Prelude -import Control.Applicative -import Control.Monad -import qualified Data.Aeson as A -import Data.Bool (bool) -import qualified Data.ByteString.Lazy.UTF8 as LBU8 -import Data.List (intercalate) -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Text as T -import Data.Traversable (for) -import qualified Language.PureScript as P -import qualified Language.PureScript.CST as CST -import Language.PureScript.Errors.JSON -import Language.PureScript.Make -import qualified Options.Applicative as Opts -import qualified System.Console.ANSI as ANSI -import System.Exit (exitSuccess, exitFailure) -import System.Directory (getCurrentDirectory) -import System.FilePath.Glob (glob) -import System.IO (hPutStr, hPutStrLn, stderr, stdout) -import System.IO.UTF8 (readUTF8FilesT) +import Control.Applicative +import Control.Monad +import Data.Aeson qualified as A +import Data.Bool (bool) +import Data.ByteString.Lazy.UTF8 qualified as LBU8 +import Data.List (intercalate) +import Data.Map qualified as M +import Data.Set qualified as S +import Data.Text qualified as T +import Data.Traversable (for) +import Language.PureScript qualified as P +import Language.PureScript.CST qualified as CST +import Language.PureScript.Errors.JSON +import Language.PureScript.Make +import Options.Applicative qualified as Opts +import System.Console.ANSI qualified as ANSI +import System.Exit (exitSuccess, exitFailure) +import System.Directory (getCurrentDirectory) +import System.FilePath.Glob (glob) +import System.IO (hPutStr, hPutStrLn, stderr, stdout) +import System.IO.UTF8 (readUTF8FilesT) data PSCMakeOptions = PSCMakeOptions { pscmInput :: [FilePath] diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index cd73eda4eb..bb30171afb 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -3,24 +3,24 @@ module Command.Docs (command, infoModList) where import Prelude -import Command.Docs.Html -import Command.Docs.Markdown -import Control.Applicative -import Control.Monad.Writer -import Control.Monad.Trans.Except (runExceptT) -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import qualified Language.PureScript as P -import qualified Language.PureScript.Docs as D -import Language.PureScript.Docs.Tags (dumpCtags, dumpEtags) -import qualified Options.Applicative as Opts -import qualified Text.PrettyPrint.ANSI.Leijen as PP -import System.Directory (getCurrentDirectory, createDirectoryIfMissing, removeFile) -import System.Exit (exitFailure) -import System.FilePath (()) -import System.FilePath.Glob (compile, glob, globDir1) -import System.IO (hPutStrLn, stderr) -import System.IO.UTF8 (writeUTF8FileT) +import Command.Docs.Html +import Command.Docs.Markdown +import Control.Applicative +import Control.Monad.Writer +import Control.Monad.Trans.Except (runExceptT) +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Language.PureScript qualified as P +import Language.PureScript.Docs qualified as D +import Language.PureScript.Docs.Tags (dumpCtags, dumpEtags) +import Options.Applicative qualified as Opts +import Text.PrettyPrint.ANSI.Leijen qualified as PP +import System.Directory (getCurrentDirectory, createDirectoryIfMissing, removeFile) +import System.Exit (exitFailure) +import System.FilePath (()) +import System.FilePath.Glob (compile, glob, globDir1) +import System.IO (hPutStrLn, stderr) +import System.IO.UTF8 (writeUTF8FileT) -- | Available output formats data Format diff --git a/app/Command/Docs/Html.hs b/app/Command/Docs/Html.hs index f49cdf9305..18fcb93720 100644 --- a/app/Command/Docs/Html.hs +++ b/app/Command/Docs/Html.hs @@ -7,22 +7,22 @@ module Command.Docs.Html import Prelude -import Control.Applicative -import Control.Arrow ((&&&)) -import Control.Monad.Writer -import Data.List (sort) -import Data.Text (Text) -import Data.Text.Lazy (toStrict) -import qualified Data.Text as T -import qualified Language.PureScript as P -import qualified Language.PureScript.Docs as D -import qualified Language.PureScript.Docs.AsHtml as D -import Text.Blaze.Html5 (Html, (!), toMarkup) -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as A -import qualified Text.Blaze.Html.Renderer.Text as Blaze -import System.IO.UTF8 (writeUTF8FileT) -import Version (versionString) +import Control.Applicative +import Control.Arrow ((&&&)) +import Control.Monad.Writer +import Data.List (sort) +import Data.Text (Text) +import Data.Text.Lazy (toStrict) +import Data.Text qualified as T +import Language.PureScript qualified as P +import Language.PureScript.Docs qualified as D +import Language.PureScript.Docs.AsHtml qualified as D +import Text.Blaze.Html5 (Html, (!), toMarkup) +import Text.Blaze.Html5 qualified as H +import Text.Blaze.Html5.Attributes qualified as A +import Text.Blaze.Html.Renderer.Text qualified as Blaze +import System.IO.UTF8 (writeUTF8FileT) +import Version (versionString) writeHtmlModules :: FilePath -> [(P.ModuleName, D.HtmlOutputModule Html)] -> IO () writeHtmlModules outputDir modules = do diff --git a/app/Command/Docs/Markdown.hs b/app/Command/Docs/Markdown.hs index e14a4e408a..1a05590d3f 100644 --- a/app/Command/Docs/Markdown.hs +++ b/app/Command/Docs/Markdown.hs @@ -5,12 +5,12 @@ module Command.Docs.Markdown import Prelude -import Data.Text (Text) -import qualified Data.Text as T -import qualified Language.PureScript as P -import qualified Language.PureScript.Docs as D -import qualified Language.PureScript.Docs.AsMarkdown as D -import System.IO.UTF8 (writeUTF8FileT) +import Data.Text (Text) +import Data.Text qualified as T +import Language.PureScript qualified as P +import Language.PureScript.Docs qualified as D +import Language.PureScript.Docs.AsMarkdown qualified as D +import System.IO.UTF8 (writeUTF8FileT) asMarkdown :: D.Module -> (P.ModuleName, Text) asMarkdown m = (D.modName m, D.runDocs . D.moduleAsMarkdown $ m) diff --git a/app/Command/Graph.hs b/app/Command/Graph.hs index 7d8467a7e8..338a303c8e 100644 --- a/app/Command/Graph.hs +++ b/app/Command/Graph.hs @@ -2,20 +2,20 @@ module Command.Graph (command) where import Prelude -import Control.Applicative (many) -import Control.Monad (unless, when) -import qualified Data.Aeson as Json -import Data.Bool (bool) -import qualified Data.ByteString.Lazy as LB -import qualified Data.ByteString.Lazy.UTF8 as LBU8 -import qualified Language.PureScript as P -import Language.PureScript.Errors.JSON -import qualified Options.Applicative as Opts -import qualified System.Console.ANSI as ANSI -import System.Exit (exitFailure) -import System.Directory (getCurrentDirectory) -import System.FilePath.Glob (glob) -import System.IO (hPutStr, hPutStrLn, stderr) +import Control.Applicative (many) +import Control.Monad (unless, when) +import Data.Aeson qualified as Json +import Data.Bool (bool) +import Data.ByteString.Lazy qualified as LB +import Data.ByteString.Lazy.UTF8 qualified as LBU8 +import Language.PureScript qualified as P +import Language.PureScript.Errors.JSON +import Options.Applicative qualified as Opts +import System.Console.ANSI qualified as ANSI +import System.Exit (exitFailure) +import System.Directory (getCurrentDirectory) +import System.FilePath.Glob (glob) +import System.IO (hPutStr, hPutStrLn, stderr) data GraphOptions = GraphOptions { graphInput :: [FilePath] diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs index f7690599aa..4da946ba1f 100644 --- a/app/Command/Hierarchy.hs +++ b/app/Command/Hierarchy.hs @@ -15,24 +15,24 @@ module Command.Hierarchy (command) where -import Prelude -import Protolude (catMaybes) +import Prelude +import Protolude (catMaybes) -import Control.Applicative (optional) -import Data.Foldable (for_) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Options.Applicative (Parser) -import qualified Options.Applicative as Opts -import System.Directory (createDirectoryIfMissing) -import System.FilePath (()) -import System.FilePath.Glob (glob) -import System.Exit (exitFailure, exitSuccess) -import System.IO (hPutStr, stderr) -import System.IO.UTF8 (readUTF8FilesT) -import qualified Language.PureScript as P -import qualified Language.PureScript.CST as CST -import Language.PureScript.Hierarchy (Graph(..), _unDigraph, _unGraphName, typeClasses) +import Control.Applicative (optional) +import Data.Foldable (for_) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Options.Applicative (Parser) +import Options.Applicative qualified as Opts +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import System.FilePath.Glob (glob) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hPutStr, stderr) +import System.IO.UTF8 (readUTF8FilesT) +import Language.PureScript qualified as P +import Language.PureScript.CST qualified as CST +import Language.PureScript.Hierarchy (Graph(..), _unDigraph, _unGraphName, typeClasses) data HierarchyOptions = HierarchyOptions { _hierarchyInput :: FilePath diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index 5da186a7c0..cbb5270a9b 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -17,28 +17,28 @@ module Command.Ide (command) where -import Protolude - -import qualified Data.Aeson as Aeson -import Control.Concurrent.STM -import "monad-logger" Control.Monad.Logger -import Data.IORef -import qualified Data.Text.IO as T -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy.Char8 as BSL8 -import GHC.IO.Exception (IOErrorType(..), IOException(..)) -import Language.PureScript.Ide -import Language.PureScript.Ide.Command -import Language.PureScript.Ide.Util -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.State (updateCacheTimestamp) -import Language.PureScript.Ide.Types -import qualified Network.Socket as Network -import qualified Options.Applicative as Opts -import System.Directory -import System.FilePath -import System.IO hiding (putStrLn, print) -import System.IO.Error (isEOFError) +import Protolude + +import Data.Aeson qualified as Aeson +import Control.Concurrent.STM +import "monad-logger" Control.Monad.Logger +import Data.IORef +import Data.Text.IO qualified as T +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy.Char8 qualified as BSL8 +import GHC.IO.Exception (IOErrorType(..), IOException(..)) +import Language.PureScript.Ide +import Language.PureScript.Ide.Command +import Language.PureScript.Ide.Util +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.State (updateCacheTimestamp) +import Language.PureScript.Ide.Types +import Network.Socket qualified as Network +import Options.Applicative qualified as Opts +import System.Directory +import System.FilePath +import System.IO hiding (putStrLn, print) +import System.IO.Error (isEOFError) listenOnLocalhost :: Network.PortNumber -> IO Network.Socket listenOnLocalhost port = do diff --git a/app/Command/Publish.hs b/app/Command/Publish.hs index 930d48a79c..95e5f42ca0 100644 --- a/app/Command/Publish.hs +++ b/app/Command/Publish.hs @@ -2,15 +2,15 @@ module Command.Publish (command) where import Prelude -import Control.Monad.IO.Class (liftIO) -import qualified Data.Aeson as A -import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Time.Clock (getCurrentTime) -import Data.Version (Version(..)) -import Language.PureScript.Publish -import Language.PureScript.Publish.ErrorsWarnings -import Options.Applicative (Parser) -import qualified Options.Applicative as Opts +import Control.Monad.IO.Class (liftIO) +import Data.Aeson qualified as A +import Data.ByteString.Lazy.Char8 qualified as BL +import Data.Time.Clock (getCurrentTime) +import Data.Version (Version(..)) +import Language.PureScript.Publish +import Language.PureScript.Publish.ErrorsWarnings +import Options.Applicative (Parser) +import Options.Applicative qualified as Opts data PublishOptionsCLI = PublishOptionsCLI { cliManifestPath :: FilePath diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index dede7db03e..194e2cc236 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -3,26 +3,26 @@ module Command.REPL (command) where -import Prelude -import Control.Applicative (many, (<|>)) -import Control.Monad -import Control.Monad.Catch (MonadMask) -import Control.Monad.IO.Class (liftIO, MonadIO) -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except (ExceptT(..), runExceptT) -import Control.Monad.Trans.State.Strict (StateT, evalStateT) -import Control.Monad.Trans.Reader (ReaderT, runReaderT) -import Data.Foldable (for_) -import qualified Language.PureScript as P -import qualified Language.PureScript.CST as CST -import Language.PureScript.Interactive -import qualified Options.Applicative as Opts -import System.Console.Haskeline -import System.IO.UTF8 (readUTF8File) -import System.Exit -import System.Directory (doesFileExist, getCurrentDirectory) -import System.FilePath (()) -import qualified System.FilePath.Glob as Glob +import Prelude +import Control.Applicative (many, (<|>)) +import Control.Monad +import Control.Monad.Catch (MonadMask) +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) +import Control.Monad.Trans.State.Strict (StateT, evalStateT) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import Data.Foldable (for_) +import Language.PureScript qualified as P +import Language.PureScript.CST qualified as CST +import Language.PureScript.Interactive +import Options.Applicative qualified as Opts +import System.Console.Haskeline +import System.IO.UTF8 (readUTF8File) +import System.Exit +import System.Directory (doesFileExist, getCurrentDirectory) +import System.FilePath (()) +import System.FilePath.Glob qualified as Glob import System.IO (hPutStrLn, stderr) -- | Command line options diff --git a/app/Main.hs b/app/Main.hs index 757ef645d6..c925a4a313 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,21 +2,21 @@ module Main where import Prelude -import qualified Command.Bundle as Bundle -import qualified Command.Compile as Compile -import qualified Command.Docs as Docs -import qualified Command.Graph as Graph -import qualified Command.Hierarchy as Hierarchy -import qualified Command.Ide as Ide -import qualified Command.Publish as Publish -import qualified Command.REPL as REPL -import Control.Monad (join) -import Data.Foldable (fold) -import qualified Options.Applicative as Opts -import System.Environment (getArgs) -import qualified System.IO as IO -import qualified Text.PrettyPrint.ANSI.Leijen as Doc -import Version (versionString) +import Command.Bundle qualified as Bundle +import Command.Compile qualified as Compile +import Command.Docs qualified as Docs +import Command.Graph qualified as Graph +import Command.Hierarchy qualified as Hierarchy +import Command.Ide qualified as Ide +import Command.Publish qualified as Publish +import Command.REPL qualified as REPL +import Control.Monad (join) +import Data.Foldable (fold) +import Options.Applicative qualified as Opts +import System.Environment (getArgs) +import System.IO qualified as IO +import Text.PrettyPrint.ANSI.Leijen qualified as Doc +import Version (versionString) main :: IO () diff --git a/app/Version.hs b/app/Version.hs index 633a0d8053..35f620b127 100644 --- a/app/Version.hs +++ b/app/Version.hs @@ -9,7 +9,7 @@ import Data.Version (showVersion) import Paths_purescript as Paths #ifndef RELEASE -import qualified Development.GitRev as GitRev +import Development.GitRev qualified as GitRev #endif -- Unfortunately, Cabal doesn't support prerelease identifiers on versions. To diff --git a/purescript.cabal b/purescript.cabal index 4f95bc4e43..859126a658 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -86,7 +86,6 @@ common defaults -Wno-missing-export-lists -Wno-missing-kind-signatures -Wno-partial-fields - -Wno-prepositive-qualified-module default-language: Haskell2010 default-extensions: BangPatterns @@ -103,6 +102,7 @@ common defaults FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving + ImportQualifiedPost KindSignatures LambdaCase MultiParamTypeClasses diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index d1e70f73d2..f2309f3549 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -30,7 +30,7 @@ import Language.PureScript.Sugar as P import Language.PureScript.TypeChecker as P import Language.PureScript.Types as P -import qualified Paths_purescript as Paths +import Paths_purescript qualified as Paths version :: Version version = Paths.version diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 87490404d2..22ee15ed26 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -14,9 +14,9 @@ import Control.DeepSeq (NFData) import Data.Functor.Identity import Data.Aeson.TH -import qualified Data.Map as M +import Data.Map qualified as M import Data.Text (Text) -import qualified Data.List.NonEmpty as NEL +import Data.List.NonEmpty qualified as NEL import GHC.Generics (Generic) import Language.PureScript.AST.Binders @@ -32,7 +32,7 @@ import Language.PureScript.Roles import Language.PureScript.TypeClassDictionaries import Language.PureScript.Comments import Language.PureScript.Environment -import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.Constants.Prim qualified as C -- | A map of locally-bound names in scope. type Context = [(Ident, SourceType)] diff --git a/src/Language/PureScript/AST/Declarations/ChainId.hs b/src/Language/PureScript/AST/Declarations/ChainId.hs index a5b47f6d37..aacfc11fe8 100644 --- a/src/Language/PureScript/AST/Declarations/ChainId.hs +++ b/src/Language/PureScript/AST/Declarations/ChainId.hs @@ -4,7 +4,7 @@ module Language.PureScript.AST.Declarations.ChainId ) where import Prelude -import qualified Language.PureScript.AST.SourcePos as Pos +import Language.PureScript.AST.SourcePos qualified as Pos import Control.DeepSeq (NFData) import Codec.Serialise (Serialise) diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index 287060a5d5..20f963ee06 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -10,7 +10,7 @@ import Control.Category ((>>>)) import Control.Applicative ((<|>)) import Data.Maybe (mapMaybe) -import qualified Data.Map as M +import Data.Map qualified as M import Language.PureScript.AST.Declarations import Language.PureScript.Types diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs index 347729e1ce..9d3364f681 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -9,7 +9,7 @@ import Codec.Serialise (Serialise) import GHC.Generics (Generic) import Control.DeepSeq (NFData) import Data.Aeson ((.=)) -import qualified Data.Aeson as A +import Data.Aeson qualified as A import Language.PureScript.Crash diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index e266680175..31811d8cb7 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -12,8 +12,8 @@ import Data.Aeson ((.=), (.:)) import Data.Text (Text) import GHC.Generics (Generic) import Language.PureScript.Comments -import qualified Data.Aeson as A -import qualified Data.Text as T +import Data.Aeson qualified as A +import Data.Text qualified as T import System.FilePath (makeRelative) -- | Source annotation - position information and comments. diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index c5c181b917..cda37d8e7b 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -13,9 +13,9 @@ import Data.Foldable (fold) import Data.Functor.Identity (runIdentity) import Data.List (mapAccumL) import Data.Maybe (mapMaybe) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as M -import qualified Data.Set as S +import Data.List.NonEmpty qualified as NEL +import Data.Map qualified as M +import Data.Set qualified as S import Language.PureScript.AST.Binders import Language.PureScript.AST.Declarations diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index dbfaa610e3..3f612e7b9b 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -24,8 +24,8 @@ import Data.Aeson ((.=)) import Data.Char (chr, digitToInt) import Data.Foldable (fold) import Data.Maybe (mapMaybe, maybeToList) -import qualified Data.Aeson as A -import qualified Data.Text.Lazy as LT +import Data.Aeson qualified as A +import Data.Text.Lazy qualified as LT import Language.JavaScript.Parser import Language.JavaScript.Parser.AST diff --git a/src/Language/PureScript/CST.hs b/src/Language/PureScript/CST.hs index eaa6de4daa..b8e895fb20 100644 --- a/src/Language/PureScript/CST.hs +++ b/src/Language/PureScript/CST.hs @@ -22,10 +22,10 @@ import Prelude hiding (lex) import Control.Monad.Error.Class (MonadError(..)) import Control.Parallel.Strategies (withStrategy, parList, evalTuple2, r0, rseq) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Text (Text) -import qualified Language.PureScript.AST as AST -import qualified Language.PureScript.Errors as E +import Language.PureScript.AST qualified as AST +import Language.PureScript.Errors qualified as E import Language.PureScript.CST.Convert import Language.PureScript.CST.Errors import Language.PureScript.CST.Lexer diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index 3b750e2fd9..b70754f897 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -21,19 +21,19 @@ import Data.Bifunctor (bimap, first) import Data.Char (toLower) import Data.Foldable (foldl', toList) import Data.Functor (($>)) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Maybe (isJust, fromJust, mapMaybe) -import qualified Data.Text as Text -import qualified Language.PureScript.AST as AST +import Data.Text qualified as Text +import Language.PureScript.AST qualified as AST import Language.PureScript.AST.Declarations.ChainId (mkChainId) -import qualified Language.PureScript.AST.SourcePos as Pos -import qualified Language.PureScript.Comments as C +import Language.PureScript.AST.SourcePos qualified as Pos +import Language.PureScript.Comments qualified as C import Language.PureScript.Crash (internalError) -import qualified Language.PureScript.Environment as Env -import qualified Language.PureScript.Label as L -import qualified Language.PureScript.Names as N +import Language.PureScript.Environment qualified as Env +import Language.PureScript.Label qualified as L +import Language.PureScript.Names qualified as N import Language.PureScript.PSString (mkString, prettyPrintStringJS) -import qualified Language.PureScript.Types as T +import Language.PureScript.Types qualified as T import Language.PureScript.CST.Positions import Language.PureScript.CST.Print (printToken) import Language.PureScript.CST.Types diff --git a/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs index ce776c87c2..fdea6dcefa 100644 --- a/src/Language/PureScript/CST/Errors.hs +++ b/src/Language/PureScript/CST/Errors.hs @@ -11,7 +11,7 @@ module Language.PureScript.CST.Errors import Prelude -import qualified Data.Text as Text +import Data.Text qualified as Text import Data.Char (isSpace, toUpper) import Language.PureScript.CST.Layout import Language.PureScript.CST.Print diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs index ea2dbfa769..6ab82153ec 100644 --- a/src/Language/PureScript/CST/Layout.hs +++ b/src/Language/PureScript/CST/Layout.hs @@ -171,7 +171,7 @@ module Language.PureScript.CST.Layout where import Prelude import Data.DList (snoc) -import qualified Data.DList as DList +import Data.DList qualified as DList import Data.Foldable (find) import Data.Function ((&)) import Language.PureScript.CST.Types diff --git a/src/Language/PureScript/CST/Lexer.hs b/src/Language/PureScript/CST/Lexer.hs index ea9dba4827..bb8ec99571 100644 --- a/src/Language/PureScript/CST/Lexer.hs +++ b/src/Language/PureScript/CST/Lexer.hs @@ -10,15 +10,15 @@ module Language.PureScript.CST.Lexer import Prelude hiding (lex, exp, exponent, lines) import Control.Monad (join) -import qualified Data.Char as Char -import qualified Data.DList as DList +import Data.Char qualified as Char +import Data.DList qualified as DList import Data.Foldable (foldl') import Data.Functor (($>)) -import qualified Data.Scientific as Sci +import Data.Scientific qualified as Sci import Data.String (fromString) import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.PureScript as Text +import Data.Text qualified as Text +import Data.Text.PureScript qualified as Text import Language.PureScript.CST.Errors import Language.PureScript.CST.Monad hiding (token) import Language.PureScript.CST.Layout diff --git a/src/Language/PureScript/CST/Monad.hs b/src/Language/PureScript/CST/Monad.hs index 038c4137d8..9245c59dff 100644 --- a/src/Language/PureScript/CST/Monad.hs +++ b/src/Language/PureScript/CST/Monad.hs @@ -3,7 +3,7 @@ module Language.PureScript.CST.Monad where import Prelude import Data.List (sortOn) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Ord (comparing) import Data.Text (Text) import Language.PureScript.CST.Errors diff --git a/src/Language/PureScript/CST/Positions.hs b/src/Language/PureScript/CST/Positions.hs index 34e13cacbe..f8b6167d51 100644 --- a/src/Language/PureScript/CST/Positions.hs +++ b/src/Language/PureScript/CST/Positions.hs @@ -8,11 +8,11 @@ module Language.PureScript.CST.Positions where import Prelude import Data.Foldable (foldl') -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Void (Void) -import qualified Data.Text as Text +import Data.Text qualified as Text import Language.PureScript.CST.Types advanceToken :: SourcePos -> Token -> SourcePos diff --git a/src/Language/PureScript/CST/Print.hs b/src/Language/PureScript/CST/Print.hs index 5cbb3467dd..9becaaf24c 100644 --- a/src/Language/PureScript/CST/Print.hs +++ b/src/Language/PureScript/CST/Print.hs @@ -12,9 +12,9 @@ module Language.PureScript.CST.Print import Prelude -import qualified Data.DList as DList +import Data.DList qualified as DList import Data.Text (Text) -import qualified Data.Text as Text +import Data.Text qualified as Text import Language.PureScript.CST.Types import Language.PureScript.CST.Flatten (flattenModule) diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs index 7450058e61..d4dec40c04 100644 --- a/src/Language/PureScript/CST/Types.hs +++ b/src/Language/PureScript/CST/Types.hs @@ -13,8 +13,8 @@ import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import Data.Void (Void) import GHC.Generics (Generic) -import qualified Language.PureScript.Names as N -import qualified Language.PureScript.Roles as R +import Language.PureScript.Names qualified as N +import Language.PureScript.Roles qualified as R import Language.PureScript.PSString (PSString) data SourcePos = SourcePos diff --git a/src/Language/PureScript/CST/Utils.hs b/src/Language/PureScript/CST/Utils.hs index 8ffb536f9e..2d7a152e2f 100644 --- a/src/Language/PureScript/CST/Utils.hs +++ b/src/Language/PureScript/CST/Utils.hs @@ -6,17 +6,17 @@ import Control.Monad (unless) import Data.Coerce (coerce) import Data.Foldable (for_) import Data.Functor (($>)) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Set (Set) -import qualified Data.Set as Set +import Data.Set qualified as Set import Data.Text (Text) -import qualified Data.Text as Text +import Data.Text qualified as Text import Language.PureScript.CST.Errors import Language.PureScript.CST.Monad import Language.PureScript.CST.Positions import Language.PureScript.CST.Traversals.Type import Language.PureScript.CST.Types -import qualified Language.PureScript.Names as N +import Language.PureScript.Names qualified as N import Language.PureScript.PSString (PSString, mkString) -- | diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 9d89092f55..c801dc22d8 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -18,21 +18,21 @@ import Control.Monad.Writer (MonadWriter, runWriterT, writer) import Data.Bifunctor (first) import Data.List ((\\), intersect) -import qualified Data.List.NonEmpty as NEL (nonEmpty) -import qualified Data.Foldable as F -import qualified Data.Map as M -import qualified Data.Set as S +import Data.List.NonEmpty qualified as NEL (nonEmpty) +import Data.Foldable qualified as F +import Data.Map qualified as M +import Data.Set qualified as S import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.Monoid (Any(..)) import Data.String (fromString) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Language.PureScript.AST.SourcePos import Language.PureScript.CodeGen.JS.Common as Common import Language.PureScript.CoreImp.AST (AST, InitializerEffects(..), everywhere, everywhereTopDownM, withSourceSpan) -import qualified Language.PureScript.CoreImp.AST as AST -import qualified Language.PureScript.CoreImp.Module as AST +import Language.PureScript.CoreImp.AST qualified as AST +import Language.PureScript.CoreImp.Module qualified as AST import Language.PureScript.CoreImp.Optimizer import Language.PureScript.CoreFn import Language.PureScript.CoreFn.Laziness (applyLazinessTransform) @@ -44,7 +44,7 @@ import Language.PureScript.Names import Language.PureScript.Options import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Traversals (sndM) -import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.Constants.Prim qualified as C import System.FilePath.Posix (()) diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 9d82a19776..2e17518e2e 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -5,7 +5,7 @@ import Prelude import Data.Char import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Language.PureScript.Crash import Language.PureScript.Names diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index 901bf4c178..905cc34b63 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -10,12 +10,12 @@ import Control.Arrow ((<+>)) import Control.Monad (forM, mzero) import Control.Monad.State (StateT, evalStateT) import Control.PatternArrows -import qualified Control.Arrow as A +import Control.Arrow qualified as A import Data.Maybe (fromMaybe) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.List.NonEmpty as NEL (toList) +import Data.Text qualified as T +import Data.List.NonEmpty qualified as NEL (toList) import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.CodeGen.JS.Common diff --git a/src/Language/PureScript/Constants/Libs.hs b/src/Language/PureScript/Constants/Libs.hs index 3ec062a7d9..75c7385e0e 100644 --- a/src/Language/PureScript/Constants/Libs.hs +++ b/src/Language/PureScript/Constants/Libs.hs @@ -3,11 +3,11 @@ -- | Various constants which refer to things in the Prelude and other core libraries module Language.PureScript.Constants.Libs where -import qualified Protolude as P +import Protolude qualified as P import Data.String (IsString) import Language.PureScript.PSString (PSString) -import qualified Language.PureScript.Constants.TH as TH +import Language.PureScript.Constants.TH qualified as TH -- Core lib values diff --git a/src/Language/PureScript/Constants/Prim.hs b/src/Language/PureScript/Constants/Prim.hs index 795dbffdd9..bd8580e748 100644 --- a/src/Language/PureScript/Constants/Prim.hs +++ b/src/Language/PureScript/Constants/Prim.hs @@ -4,7 +4,7 @@ module Language.PureScript.Constants.Prim where import Language.PureScript.Names -import qualified Language.PureScript.Constants.TH as TH +import Language.PureScript.Constants.TH qualified as TH $(TH.declare do TH.mod "Prim" do diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index 0ea811a980..225f7a616e 100644 --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -10,16 +10,16 @@ import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.RWS (MonadWriter, RWST, censor, evalRWST, listen, pass, tell) import Data.Bitraversable (bitraverse) import Data.Functor.Compose (Compose(..)) -import qualified Data.IntMap.Monoidal as IM -import qualified Data.IntSet as IS -import qualified Data.Map as M +import Data.IntMap.Monoidal qualified as IM +import Data.IntSet qualified as IS +import Data.Map qualified as M import Data.Maybe (fromJust) import Data.Semigroup (Min(..)) import Data.Semigroup.Generic (GenericSemigroupMonoid(..)) import Language.PureScript.AST.Literals import Language.PureScript.AST.SourcePos (nullSourceSpan) -import qualified Language.PureScript.Constants.Libs as C +import Language.PureScript.Constants.Libs qualified as C import Language.PureScript.CoreFn.Ann (Ann) import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Expr diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 1cf6d5efe0..29303e05c4 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -8,8 +8,8 @@ import Control.Arrow (second) import Data.Function (on) import Data.Maybe (mapMaybe) import Data.Tuple (swap) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as M +import Data.List.NonEmpty qualified as NEL +import Data.Map qualified as M import Language.PureScript.AST.Literals import Language.PureScript.AST.SourcePos @@ -24,8 +24,8 @@ import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Names import Language.PureScript.Types -import qualified Language.PureScript.AST as A -import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.AST qualified as A +import Language.PureScript.Constants.Prim qualified as C -- | Desugars a module from AST to CoreFn representation. moduleToCoreFn :: Environment -> A.Module -> Module Ann diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 3d42bb727a..50b5010259 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -9,24 +9,24 @@ module Language.PureScript.CoreFn.FromJSON import Prelude -import Control.Applicative ((<|>)) - -import Data.Aeson -import Data.Aeson.Types (Parser, listParser) -import qualified Data.Map.Strict as M -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Vector as V -import Data.Version (Version, parseVersion) - -import Language.PureScript.AST.SourcePos (SourceSpan(..)) -import Language.PureScript.AST.Literals -import Language.PureScript.CoreFn.Ann -import Language.PureScript.CoreFn -import Language.PureScript.Names -import Language.PureScript.PSString (PSString) - -import Text.ParserCombinators.ReadP (readP_to_S) +import Control.Applicative ((<|>)) + +import Data.Aeson +import Data.Aeson.Types (Parser, listParser) +import Data.Map.Strict qualified as M +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector qualified as V +import Data.Version (Version, parseVersion) + +import Language.PureScript.AST.SourcePos (SourceSpan(..)) +import Language.PureScript.AST.Literals +import Language.PureScript.CoreFn.Ann +import Language.PureScript.CoreFn +import Language.PureScript.Names +import Language.PureScript.PSString (PSString) + +import Text.ParserCombinators.ReadP (readP_to_S) parseVersion' :: String -> Maybe Version parseVersion' str = diff --git a/src/Language/PureScript/CoreFn/Laziness.hs b/src/Language/PureScript/CoreFn/Laziness.hs index 5055151596..24d7290108 100644 --- a/src/Language/PureScript/CoreFn/Laziness.hs +++ b/src/Language/PureScript/CoreFn/Laziness.hs @@ -6,18 +6,18 @@ import Protolude hiding (force) import Protolude.Unsafe (unsafeHead) import Control.Arrow ((&&&)) -import qualified Data.Array as A +import Data.Array qualified as A import Data.Coerce (coerce) import Data.Graph (SCC(..), stronglyConnComp) import Data.List (foldl1', (!!)) -import qualified Data.IntMap.Monoidal as IM -import qualified Data.IntSet as IS -import qualified Data.Map.Monoidal as M +import Data.IntMap.Monoidal qualified as IM +import Data.IntSet qualified as IS +import Data.Map.Monoidal qualified as M import Data.Semigroup (Max(..)) -import qualified Data.Set as S +import Data.Set qualified as S import Language.PureScript.AST.SourcePos -import qualified Language.PureScript.Constants.Libs as C +import Language.PureScript.Constants.Libs qualified as C import Language.PureScript.CoreFn import Language.PureScript.Crash import Language.PureScript.Names diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 94d7b77a5a..40a31ed3dc 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -13,8 +13,8 @@ import Language.PureScript.CoreFn.Module import Language.PureScript.CoreFn.Traversals import Language.PureScript.Label import Language.PureScript.Types -import qualified Language.PureScript.Constants.Libs as C -import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.Constants.Libs qualified as C +import Language.PureScript.Constants.Prim qualified as C -- | -- CoreFn optimization pass. diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 9a8a600f83..ea71162176 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -7,24 +7,24 @@ module Language.PureScript.CoreFn.ToJSON ( moduleToJSON ) where -import Prelude - -import Control.Arrow ((***)) -import Data.Either (isLeft) -import qualified Data.Map.Strict as M -import Data.Aeson hiding ((.=)) -import qualified Data.Aeson -import qualified Data.Aeson.Key -import Data.Aeson.Types (Pair) -import Data.Version (Version, showVersion) -import Data.Text (Text) -import qualified Data.Text as T - -import Language.PureScript.AST.Literals -import Language.PureScript.AST.SourcePos (SourceSpan(..)) -import Language.PureScript.CoreFn -import Language.PureScript.Names -import Language.PureScript.PSString (PSString) +import Prelude + +import Control.Arrow ((***)) +import Data.Either (isLeft) +import Data.Map.Strict qualified as M +import Data.Aeson hiding ((.=)) +import Data.Aeson qualified +import Data.Aeson.Key qualified +import Data.Aeson.Types (Pair) +import Data.Version (Version, showVersion) +import Data.Text (Text) +import Data.Text qualified as T + +import Language.PureScript.AST.Literals +import Language.PureScript.AST.SourcePos (SourceSpan(..)) +import Language.PureScript.CoreFn +import Language.PureScript.Names +import Language.PureScript.PSString (PSString) constructorTypeToJSON :: ConstructorType -> Value constructorTypeToJSON ProductType = toJSON "ProductType" diff --git a/src/Language/PureScript/CoreImp/Module.hs b/src/Language/PureScript/CoreImp/Module.hs index efd591508f..5460a012cd 100644 --- a/src/Language/PureScript/CoreImp/Module.hs +++ b/src/Language/PureScript/CoreImp/Module.hs @@ -1,7 +1,7 @@ module Language.PureScript.CoreImp.Module where import Protolude -import qualified Data.List.NonEmpty as NEL (NonEmpty) +import Data.List.NonEmpty qualified as NEL (NonEmpty) import Language.PureScript.Comments import Language.PureScript.CoreImp.AST diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index 77e5ea4c77..0e3dd5a8c5 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -19,15 +19,15 @@ import Control.Monad.Supply.Class (MonadSupply, freshName) import Data.Either (rights) import Data.Maybe (fromMaybe) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Language.PureScript.Names (ModuleName) import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Common import Language.PureScript.AST (SourceSpan(..)) -import qualified Language.PureScript.Constants.Libs as C -import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.Constants.Libs qualified as C +import Language.PureScript.Constants.Prim qualified as C -- TODO: Potential bug: -- Shouldn't just inline this case: { var x = 0; x.toFixed(10); } diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs index fb9ed17ad5..5b933c2cdb 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs @@ -11,7 +11,7 @@ import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Common import Language.PureScript.Names (ModuleName) import Language.PureScript.PSString (mkString) -import qualified Language.PureScript.Constants.Libs as C +import Language.PureScript.Constants.Libs qualified as C -- | Inline type class dictionaries for >>= and return for the Eff monad -- diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index f9bb433514..bd85924eae 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -7,7 +7,7 @@ import Control.Applicative (empty, liftA2) import Control.Monad (guard) import Control.Monad.State (State, evalState, get, modify) import Data.Functor (($>), (<&>)) -import qualified Data.Set as S +import Data.Set qualified as S import Data.Text (Text, pack) import Language.PureScript.CoreImp.AST import Language.PureScript.AST.SourcePos (SourceSpan) diff --git a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs index f920d79af0..a06eaf5660 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs @@ -9,12 +9,12 @@ import Prelude import Control.Monad (filterM) import Data.Monoid (Any(..)) -import qualified Data.Set as S +import Data.Set qualified as S import Data.Text (Text) import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Common -import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.Constants.Prim qualified as C removeCodeAfterReturnStatements :: AST -> AST removeCodeAfterReturnStatements = everywhere (removeFromBlock go) diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index ed4e12498a..e05cf220aa 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -19,24 +19,24 @@ import Control.Monad (unless) import Data.Bifunctor (bimap) import Data.Char (isUpper) import Data.Either (isRight) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) import Data.Foldable (for_) import Data.String (fromString) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Text.Blaze.Html5 as H hiding (map) -import qualified Text.Blaze.Html5.Attributes as A -import qualified Cheapskate +import Text.Blaze.Html5.Attributes qualified as A +import Cheapskate qualified -import qualified Language.PureScript as P +import Language.PureScript qualified as P import Language.PureScript.Docs.Types import Language.PureScript.Docs.RenderedCode hiding (sp) -import qualified Language.PureScript.Docs.Render as Render -import qualified Language.PureScript.CST as CST +import Language.PureScript.Docs.Render qualified as Render +import Language.PureScript.CST qualified as CST data HtmlOutput a = HtmlOutput { htmlIndex :: [(Maybe Char, a)] diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index efe15b0252..530feba933 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -13,12 +13,12 @@ import Control.Monad.Writer (Writer, tell, execWriter) import Data.Foldable (for_) import Data.List (partition) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Language.PureScript.Docs.RenderedCode import Language.PureScript.Docs.Types -import qualified Language.PureScript as P -import qualified Language.PureScript.Docs.Render as Render +import Language.PureScript qualified as P +import Language.PureScript.Docs.Render qualified as Render moduleAsMarkdown :: Module -> Docs moduleAsMarkdown Module{..} = do diff --git a/src/Language/PureScript/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs index 32bece3738..3570ecf2fe 100644 --- a/src/Language/PureScript/Docs/Collect.hs +++ b/src/Language/PureScript/Docs/Collect.hs @@ -6,12 +6,12 @@ module Language.PureScript.Docs.Collect import Protolude hiding (check) import Control.Arrow ((&&&)) -import qualified Data.Aeson.BetterErrors as ABE -import qualified Data.ByteString as BS -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.IO as TIO +import Data.Aeson.BetterErrors qualified as ABE +import Data.ByteString qualified as BS +import Data.Map qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Text.IO qualified as TIO import System.FilePath (()) import System.IO.UTF8 (readUTF8FileT, readUTF8FilesT) @@ -19,14 +19,14 @@ import Language.PureScript.Docs.Convert.ReExports (updateReExports) import Language.PureScript.Docs.Prim (primModules) import Language.PureScript.Docs.Types -import qualified Language.PureScript.AST as P -import qualified Language.PureScript.CST as P -import qualified Language.PureScript.Crash as P -import qualified Language.PureScript.Errors as P -import qualified Language.PureScript.Externs as P -import qualified Language.PureScript.Make as P -import qualified Language.PureScript.Names as P -import qualified Language.PureScript.Options as P +import Language.PureScript.AST qualified as P +import Language.PureScript.CST qualified as P +import Language.PureScript.Crash qualified as P +import Language.PureScript.Errors qualified as P +import Language.PureScript.Externs qualified as P +import Language.PureScript.Make qualified as P +import Language.PureScript.Names qualified as P +import Language.PureScript.Options qualified as P import Web.Bower.PackageMeta (PackageName) diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 446e10510f..ce25a9102b 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -10,24 +10,24 @@ import Protolude hiding (check) import Control.Category ((>>>)) import Control.Monad.Writer.Strict (runWriterT) import Control.Monad.Supply (evalSupplyT) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as Map import Data.String (String) -import qualified Data.Text as T +import Data.Text qualified as T import Language.PureScript.Docs.Convert.Single (convertSingleModule) import Language.PureScript.Docs.Types -import qualified Language.PureScript.CST as CST -import qualified Language.PureScript.AST as P -import qualified Language.PureScript.Crash as P -import qualified Language.PureScript.Errors as P -import qualified Language.PureScript.Externs as P -import qualified Language.PureScript.Environment as P -import qualified Language.PureScript.Names as P -import qualified Language.PureScript.Roles as P -import qualified Language.PureScript.Sugar as P -import qualified Language.PureScript.Types as P -import qualified Language.PureScript.Constants.Prim as Prim +import Language.PureScript.CST qualified as CST +import Language.PureScript.AST qualified as P +import Language.PureScript.Crash qualified as P +import Language.PureScript.Errors qualified as P +import Language.PureScript.Externs qualified as P +import Language.PureScript.Environment qualified as P +import Language.PureScript.Names qualified as P +import Language.PureScript.Roles qualified as P +import Language.PureScript.Sugar qualified as P +import Language.PureScript.Types qualified as P +import Language.PureScript.Constants.Prim qualified as Prim import Language.PureScript.Sugar (RebracketCaller(CalledByDocs)) -- | diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 7ef61d988f..9ce51d4433 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -15,19 +15,19 @@ import Data.Either import Data.Foldable (fold, traverse_) import Data.Map (Map) import Data.Maybe (mapMaybe) -import qualified Data.Map as Map +import Data.Map qualified as Map import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Language.PureScript.Docs.Types -import qualified Language.PureScript.AST as P -import qualified Language.PureScript.Crash as P -import qualified Language.PureScript.Errors as P -import qualified Language.PureScript.Externs as P -import qualified Language.PureScript.ModuleDependencies as P -import qualified Language.PureScript.Names as P -import qualified Language.PureScript.Types as P +import Language.PureScript.AST qualified as P +import Language.PureScript.Crash qualified as P +import Language.PureScript.Errors qualified as P +import Language.PureScript.Externs qualified as P +import Language.PureScript.ModuleDependencies qualified as P +import Language.PureScript.Names qualified as P +import Language.PureScript.Types qualified as P -- | diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 8cd99da145..50a6fe0c88 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -7,16 +7,16 @@ import Protolude hiding (moduleName) import Control.Category ((>>>)) -import qualified Data.Text as T +import Data.Text qualified as T import Language.PureScript.Docs.Types -import qualified Language.PureScript.AST as P -import qualified Language.PureScript.Comments as P -import qualified Language.PureScript.Crash as P -import qualified Language.PureScript.Names as P -import qualified Language.PureScript.Roles as P -import qualified Language.PureScript.Types as P +import Language.PureScript.AST qualified as P +import Language.PureScript.Comments qualified as P +import Language.PureScript.Crash qualified as P +import Language.PureScript.Names qualified as P +import Language.PureScript.Roles qualified as P +import Language.PureScript.Types qualified as P -- | -- Convert a single Module, but ignore re-exports; any re-exported types or diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index cd8a4697cd..4b19adbac3 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -9,14 +9,14 @@ module Language.PureScript.Docs.Prim import Prelude hiding (fail) import Data.Functor (($>)) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Map as Map +import Data.Text qualified as T +import Data.Map qualified as Map import Language.PureScript.Docs.Types -import qualified Language.PureScript.Constants.Prim as P -import qualified Language.PureScript.Crash as P -import qualified Language.PureScript.Environment as P -import qualified Language.PureScript.Names as P +import Language.PureScript.Constants.Prim qualified as P +import Language.PureScript.Crash qualified as P +import Language.PureScript.Environment qualified as P +import Language.PureScript.Names qualified as P primModules :: [Module] primModules = diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 0dc548f763..31629d0fe8 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -13,16 +13,16 @@ import Prelude import Data.Maybe (maybeToList) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Language.PureScript.Docs.RenderedCode import Language.PureScript.Docs.Types import Language.PureScript.Docs.Utils.MonoidExtras -import qualified Language.PureScript.AST as P -import qualified Language.PureScript.Environment as P -import qualified Language.PureScript.Names as P -import qualified Language.PureScript.Types as P +import Language.PureScript.AST qualified as P +import Language.PureScript.Environment qualified as P +import Language.PureScript.Names qualified as P +import Language.PureScript.Types qualified as P renderKindSig :: Text -> KindInfo -> RenderedCode renderKindSig declTitle KindInfo{..} = diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index f4844dc754..9b8c6f9b5b 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -39,11 +39,11 @@ import Control.DeepSeq (NFData) import Control.Monad.Error.Class (MonadError(..)) import Data.Aeson.BetterErrors (Parse, nth, withText, withValue, toAesonParser, perhaps, asText) -import qualified Data.Aeson as A +import Data.Aeson qualified as A import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.ByteString.Lazy as BS -import qualified Data.Text.Encoding as TE +import Data.Text qualified as T +import Data.ByteString.Lazy qualified as BS +import Data.Text.Encoding qualified as TE import Language.PureScript.Names import Language.PureScript.AST (Associativity(..)) diff --git a/src/Language/PureScript/Docs/Tags.hs b/src/Language/PureScript/Docs/Tags.hs index 95d4b07faf..2b9a2b0172 100644 --- a/src/Language/PureScript/Docs/Tags.hs +++ b/src/Language/PureScript/Docs/Tags.hs @@ -6,10 +6,10 @@ module Language.PureScript.Docs.Tags import Prelude -import Control.Arrow (first) -import Data.List (sort) -import Data.Maybe (mapMaybe) -import qualified Data.Text as T +import Control.Arrow (first) +import Data.List (sort) +import Data.Maybe (mapMaybe) +import Data.Text qualified as T import Language.PureScript.AST (SourceSpan, sourcePosLine, spanStart) import Language.PureScript.Docs.Types diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index fd5e4bd1b6..d9ac6ab849 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -10,28 +10,28 @@ import Prelude (String, unlines, lookup) import Control.Arrow ((***)) import Data.Aeson ((.=)) -import qualified Data.Aeson.Key as A.Key +import Data.Aeson.Key qualified as A.Key import Data.Aeson.BetterErrors (Parse, keyOrDefault, throwCustomError, key, asText, keyMay, withString, eachInArray, asNull, (.!), toAesonParser, toAesonParser', fromAesonParser, perhaps, withText, asIntegral, nth, eachInObjectWithKey, asString) -import qualified Data.Map as Map +import Data.Map qualified as Map import Data.Time.Clock (UTCTime) -import qualified Data.Time.Format as TimeFormat +import Data.Time.Format qualified as TimeFormat import Data.Version -import qualified Data.Aeson as A -import qualified Data.Text as T -import qualified Data.Vector as V - -import qualified Language.PureScript.AST as P -import qualified Language.PureScript.CoreFn.FromJSON as P -import qualified Language.PureScript.Crash as P -import qualified Language.PureScript.Environment as P -import qualified Language.PureScript.Names as P -import qualified Language.PureScript.Roles as P -import qualified Language.PureScript.Types as P -import qualified Paths_purescript as Paths +import Data.Aeson qualified as A +import Data.Text qualified as T +import Data.Vector qualified as V + +import Language.PureScript.AST qualified as P +import Language.PureScript.CoreFn.FromJSON qualified as P +import Language.PureScript.Crash qualified as P +import Language.PureScript.Environment qualified as P +import Language.PureScript.Names qualified as P +import Language.PureScript.Roles qualified as P +import Language.PureScript.Types qualified as P +import Paths_purescript qualified as Paths import Web.Bower.PackageMeta hiding (Version, displayError) diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 96dd1d2215..ab995eb12e 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -7,18 +7,18 @@ import Control.DeepSeq (NFData) import Control.Monad (unless) import Codec.Serialise (Serialise) import Data.Aeson ((.=), (.:)) -import qualified Data.Aeson as A +import Data.Aeson qualified as A import Data.Foldable (find, fold) import Data.Functor ((<&>)) -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Map as M -import qualified Data.Set as S +import Data.IntMap qualified as IM +import Data.IntSet qualified as IS +import Data.Map qualified as M +import Data.Set qualified as S import Data.Maybe (fromMaybe) import Data.Semigroup (First(..)) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.List.NonEmpty as NEL +import Data.Text qualified as T +import Data.List.NonEmpty qualified as NEL import Language.PureScript.AST.SourcePos import Language.PureScript.Crash @@ -26,7 +26,7 @@ import Language.PureScript.Names import Language.PureScript.Roles import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types -import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.Constants.Prim qualified as C -- | The @Environment@ defines all values and types which are currently in scope: data Environment = Environment diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 824d5d0b7b..49a4348a3b 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -3,56 +3,56 @@ module Language.PureScript.Errors , module Language.PureScript.Errors ) where -import Prelude -import Protolude (unsnoc) - -import Control.Arrow ((&&&)) -import Control.Exception (displayException) -import Control.Lens (both, head1, over) -import Control.Monad -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Trans.State.Lazy -import Control.Monad.Writer -import Data.Bifunctor (first, second) -import Data.Bitraversable (bitraverse) -import Data.Char (isSpace) -import Data.Containers.ListUtils (nubOrdOn) -import Data.Either (partitionEithers) -import Data.Foldable (fold) -import Data.Function (on) -import Data.Functor (($>)) -import Data.Functor.Identity (Identity(..)) -import Data.List (transpose, nubBy, partition, dropWhileEnd, sortOn, uncons) -import qualified Data.List.NonEmpty as NEL -import Data.List.NonEmpty (NonEmpty((:|))) -import Data.Maybe (maybeToList, fromMaybe, isJust, mapMaybe) -import qualified Data.Map as M -import Data.Ord (Down(..)) -import qualified Data.Set as S -import qualified Data.Text as T -import Data.Text (Text) -import Data.Traversable (for) -import qualified GHC.Stack -import Language.PureScript.AST -import qualified Language.PureScript.Bundle as Bundle -import qualified Language.PureScript.Constants.Libs as C -import qualified Language.PureScript.Constants.Prim as C -import Language.PureScript.Crash -import qualified Language.PureScript.CST.Errors as CST -import qualified Language.PureScript.CST.Print as CST -import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names -import Language.PureScript.Pretty -import Language.PureScript.Pretty.Common (endWith) -import Language.PureScript.PSString (decodeStringWithReplacement) -import Language.PureScript.Roles -import Language.PureScript.Traversals -import Language.PureScript.Types -import qualified Language.PureScript.Publish.BoxesHelpers as BoxHelpers -import qualified System.Console.ANSI as ANSI -import System.FilePath (makeRelative) -import qualified Text.PrettyPrint.Boxes as Box -import Witherable (wither) +import Prelude +import Protolude (unsnoc) + +import Control.Arrow ((&&&)) +import Control.Exception (displayException) +import Control.Lens (both, head1, over) +import Control.Monad +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Trans.State.Lazy +import Control.Monad.Writer +import Data.Bifunctor (first, second) +import Data.Bitraversable (bitraverse) +import Data.Char (isSpace) +import Data.Containers.ListUtils (nubOrdOn) +import Data.Either (partitionEithers) +import Data.Foldable (fold) +import Data.Function (on) +import Data.Functor (($>)) +import Data.Functor.Identity (Identity(..)) +import Data.List (transpose, nubBy, partition, dropWhileEnd, sortOn, uncons) +import Data.List.NonEmpty qualified as NEL +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Maybe (maybeToList, fromMaybe, isJust, mapMaybe) +import Data.Map qualified as M +import Data.Ord (Down(..)) +import Data.Set qualified as S +import Data.Text qualified as T +import Data.Text (Text) +import Data.Traversable (for) +import GHC.Stack qualified +import Language.PureScript.AST +import Language.PureScript.Bundle qualified as Bundle +import Language.PureScript.Constants.Libs qualified as C +import Language.PureScript.Constants.Prim qualified as C +import Language.PureScript.Crash +import Language.PureScript.CST.Errors qualified as CST +import Language.PureScript.CST.Print qualified as CST +import Language.PureScript.Label (Label(..)) +import Language.PureScript.Names +import Language.PureScript.Pretty +import Language.PureScript.Pretty.Common (endWith) +import Language.PureScript.PSString (decodeStringWithReplacement) +import Language.PureScript.Roles +import Language.PureScript.Traversals +import Language.PureScript.Types +import Language.PureScript.Publish.BoxesHelpers qualified as BoxHelpers +import System.Console.ANSI qualified as ANSI +import System.FilePath (makeRelative) +import Text.PrettyPrint.Boxes qualified as Box +import Witherable (wither) -- | A type of error messages data SimpleErrorMessage diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index 924e452309..9e2af78668 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -4,11 +4,11 @@ module Language.PureScript.Errors.JSON where import Prelude -import qualified Data.Aeson.TH as A -import qualified Data.List.NonEmpty as NEL +import Data.Aeson.TH qualified as A +import Data.List.NonEmpty qualified as NEL import Data.Text (Text) -import qualified Language.PureScript as P +import Language.PureScript qualified as P data ErrorPosition = ErrorPosition { startLine :: Int diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 477c2e68f4..83cd88147f 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -23,10 +23,10 @@ import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.List (foldl', find) import Data.Foldable (fold) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Version (showVersion) -import qualified Data.Map as M -import qualified Data.List.NonEmpty as NEL +import Data.Map qualified as M +import Data.List.NonEmpty qualified as NEL import Language.PureScript.AST import Language.PureScript.AST.Declarations.ChainId (ChainId) diff --git a/src/Language/PureScript/Graph.hs b/src/Language/PureScript/Graph.hs index 9c2c6e09d2..fc2ae68fcb 100644 --- a/src/Language/PureScript/Graph.hs +++ b/src/Language/PureScript/Graph.hs @@ -2,27 +2,27 @@ module Language.PureScript.Graph (graph) where import Prelude -import qualified Data.Aeson as Json -import qualified Data.Aeson.Key as Json.Key -import qualified Data.Aeson.KeyMap as Json.Map -import qualified Data.Map as Map - -import Control.Monad (forM) -import Data.Aeson ((.=)) -import Data.Foldable (foldl') -import Data.Map (Map) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import System.IO.UTF8 (readUTF8FileT) - -import qualified Language.PureScript.Crash as Crash -import qualified Language.PureScript.CST as CST -import qualified Language.PureScript.Make as Make -import qualified Language.PureScript.ModuleDependencies as Dependencies -import qualified Language.PureScript.Options as Options - -import Language.PureScript.Errors (MultipleErrors) -import Language.PureScript.Names (ModuleName, runModuleName) +import Data.Aeson qualified as Json +import Data.Aeson.Key qualified as Json.Key +import Data.Aeson.KeyMap qualified as Json.Map +import Data.Map qualified as Map + +import Control.Monad (forM) +import Data.Aeson ((.=)) +import Data.Foldable (foldl') +import Data.Map (Map) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import System.IO.UTF8 (readUTF8FileT) + +import Language.PureScript.Crash qualified as Crash +import Language.PureScript.CST qualified as CST +import Language.PureScript.Make qualified as Make +import Language.PureScript.ModuleDependencies qualified as Dependencies +import Language.PureScript.Options qualified as Options + +import Language.PureScript.Errors (MultipleErrors) +import Language.PureScript.Names (ModuleName, runModuleName) -- | Given a set of filepaths, try to build the dependency graph and return diff --git a/src/Language/PureScript/Hierarchy.hs b/src/Language/PureScript/Hierarchy.hs index fb9a25f018..c4919fb60d 100644 --- a/src/Language/PureScript/Hierarchy.hs +++ b/src/Language/PureScript/Hierarchy.hs @@ -15,12 +15,12 @@ module Language.PureScript.Hierarchy where -import Prelude -import Protolude (ordNub) +import Prelude +import Protolude (ordNub) -import Data.List (sort) -import qualified Data.Text as T -import qualified Language.PureScript as P +import Data.List (sort) +import Data.Text qualified as T +import Language.PureScript qualified as P newtype SuperMap = SuperMap { _unSuperMap :: Either (P.ProperName 'P.ClassName) (P.ProperName 'P.ClassName, P.ProperName 'P.ClassName) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index fdee5c6f4a..a7b4eb5095 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -18,31 +18,31 @@ module Language.PureScript.Ide ( handleCommand ) where -import Protolude hiding (moduleName) - -import "monad-logger" Control.Monad.Logger -import qualified Data.Map as Map -import qualified Data.Text as T -import qualified Language.PureScript as P -import qualified Language.PureScript.Ide.CaseSplit as CS -import Language.PureScript.Ide.Command -import Language.PureScript.Ide.Completion -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Externs -import Language.PureScript.Ide.Filter -import Language.PureScript.Ide.Imports hiding (Import) -import Language.PureScript.Ide.Imports.Actions -import Language.PureScript.Ide.Matcher -import Language.PureScript.Ide.Prim -import Language.PureScript.Ide.Rebuild -import Language.PureScript.Ide.SourceFile -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util -import Language.PureScript.Ide.Usage (findUsages) -import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist, doesFileExist) -import System.FilePath ((), normalise) -import System.FilePath.Glob (glob) +import Protolude hiding (moduleName) + +import "monad-logger" Control.Monad.Logger +import Data.Map qualified as Map +import Data.Text qualified as T +import Language.PureScript qualified as P +import Language.PureScript.Ide.CaseSplit qualified as CS +import Language.PureScript.Ide.Command +import Language.PureScript.Ide.Completion +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Externs +import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Imports hiding (Import) +import Language.PureScript.Ide.Imports.Actions +import Language.PureScript.Ide.Matcher +import Language.PureScript.Ide.Prim +import Language.PureScript.Ide.Rebuild +import Language.PureScript.Ide.SourceFile +import Language.PureScript.Ide.State +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util +import Language.PureScript.Ide.Usage (findUsages) +import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist, doesFileExist) +import System.FilePath ((), normalise) +import System.FilePath.Glob (glob) -- | Accepts a Command and runs it against psc-ide's State. This is the main -- entry point for the server. diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 9643f642b1..db2174ebe1 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -21,18 +21,18 @@ module Language.PureScript.Ide.CaseSplit , caseSplit ) where -import Protolude hiding (Constructor) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import qualified Data.Text as T -import qualified Language.PureScript as P -import qualified Language.PureScript.CST as CST - -import Language.PureScript.Externs -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Types +import Protolude hiding (Constructor) + +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Text qualified as T +import Language.PureScript qualified as P +import Language.PureScript.CST qualified as CST + +import Language.PureScript.Externs +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.State +import Language.PureScript.Ide.Types type Constructor = (P.ProperName 'P.ConstructorName, [P.SourceType]) diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index 185474f11e..ace3a05a1e 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -14,18 +14,18 @@ module Language.PureScript.Ide.Command where -import Protolude +import Protolude -import Control.Monad.Fail (fail) -import Data.Aeson -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Language.PureScript as P -import Language.PureScript.Ide.CaseSplit -import Language.PureScript.Ide.Completion -import Language.PureScript.Ide.Filter -import Language.PureScript.Ide.Matcher -import Language.PureScript.Ide.Types +import Control.Monad.Fail (fail) +import Data.Aeson +import Data.Map qualified as Map +import Data.Set qualified as Set +import Language.PureScript qualified as P +import Language.PureScript.Ide.CaseSplit +import Language.PureScript.Ide.Completion +import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Matcher +import Language.PureScript.Ide.Types data Command = Load [P.ModuleName] diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 6fa69d5c00..78edbf6a96 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -9,18 +9,18 @@ module Language.PureScript.Ide.Completion , applyCompletionOptions ) where -import Protolude hiding ((<&>), moduleName) - -import Control.Lens hiding (op, (&)) -import Data.Aeson -import qualified Data.Map as Map -import qualified Data.Text as T -import qualified Language.PureScript as P -import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine) -import Language.PureScript.Ide.Filter -import Language.PureScript.Ide.Matcher -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util +import Protolude hiding ((<&>), moduleName) + +import Control.Lens hiding (op, (&)) +import Data.Aeson +import Data.Map qualified as Map +import Data.Text qualified as T +import Language.PureScript qualified as P +import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine) +import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Matcher +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util -- | Applies the CompletionFilters and the Matcher to the given Modules -- and sorts the found Completions according to the Matching Score diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 92ca14339b..cb7105358d 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -17,14 +17,14 @@ module Language.PureScript.Ide.Error , prettyPrintTypeSingleLine ) where -import Data.Aeson -import qualified Data.Aeson.Types as Aeson -import qualified Data.Aeson.KeyMap as KM -import qualified Data.Text as T -import qualified Language.PureScript as P -import Language.PureScript.Errors.JSON -import Language.PureScript.Ide.Types (ModuleIdent, Completion(..)) -import Protolude +import Data.Aeson +import Data.Aeson.Types qualified as Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.Text qualified as T +import Language.PureScript qualified as P +import Language.PureScript.Errors.JSON +import Language.PureScript.Ide.Types (ModuleIdent, Completion(..)) +import Protolude data IdeError = GeneralError Text diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index 70c780b8aa..df9edabcb1 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -5,18 +5,18 @@ module Language.PureScript.Ide.Externs , convertExterns ) where -import Protolude hiding (to, from, (&)) +import Protolude hiding (to, from, (&)) -import Codec.CBOR.Term as Term -import Control.Lens hiding (anyOf) -import "monad-logger" Control.Monad.Logger -import Data.Version (showVersion) -import qualified Data.Text as Text -import qualified Language.PureScript as P -import qualified Language.PureScript.Make.Monad as Make -import Language.PureScript.Ide.Error (IdeError (..)) -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util (properNameT) +import Codec.CBOR.Term as Term +import Control.Lens hiding (anyOf) +import "monad-logger" Control.Monad.Logger +import Data.Version (showVersion) +import Data.Text qualified as Text +import Language.PureScript qualified as P +import Language.PureScript.Make.Monad qualified as Make +import Language.PureScript.Ide.Error (IdeError (..)) +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util (properNameT) readExternFile :: (MonadIO m, MonadError IdeError m, MonadLogger m) diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index 1fd9df394f..f3c693673c 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -23,20 +23,20 @@ module Language.PureScript.Ide.Filter , applyFilters ) where -import Protolude hiding (isPrefixOf, Prefix) - -import Control.Monad.Fail (fail) -import Data.Aeson -import Data.Text (isPrefixOf) -import qualified Data.Set as Set -import qualified Data.Map as Map -import Language.PureScript.Ide.Filter.Declaration (DeclarationType) -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Imports -import Language.PureScript.Ide.Util - -import qualified Language.PureScript as P -import qualified Data.Text as T +import Protolude hiding (isPrefixOf, Prefix) + +import Control.Monad.Fail (fail) +import Data.Aeson +import Data.Text (isPrefixOf) +import Data.Set qualified as Set +import Data.Map qualified as Map +import Language.PureScript.Ide.Filter.Declaration (DeclarationType) +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Imports +import Language.PureScript.Ide.Util + +import Language.PureScript qualified as P +import Data.Text qualified as T import Language.PureScript.Ide.Filter.Imports diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs index 563bd151e2..c3bd6fead3 100644 --- a/src/Language/PureScript/Ide/Filter/Declaration.hs +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -2,10 +2,10 @@ module Language.PureScript.Ide.Filter.Declaration ( DeclarationType(..) ) where -import Protolude hiding (isPrefixOf) +import Protolude hiding (isPrefixOf) -import Control.Monad.Fail (fail) -import Data.Aeson +import Control.Monad.Fail (fail) +import Data.Aeson data DeclarationType = Value diff --git a/src/Language/PureScript/Ide/Filter/Imports.hs b/src/Language/PureScript/Ide/Filter/Imports.hs index f1870b4d09..fcdf0fcab7 100644 --- a/src/Language/PureScript/Ide/Filter/Imports.hs +++ b/src/Language/PureScript/Ide/Filter/Imports.hs @@ -1,12 +1,12 @@ module Language.PureScript.Ide.Filter.Imports where -import Protolude hiding (isPrefixOf) +import Protolude hiding (isPrefixOf) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Imports -import qualified Language.PureScript as P +import Language.PureScript qualified as P matchImport :: Maybe P.ModuleName -> P.ModuleName -> IdeDeclarationAnn -> Import -> Bool matchImport matchQualifier declMod (IdeDeclarationAnn _ decl) (Import importMod declTy qualifier) | declMod == importMod && matchQualifier == qualifier = diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 94e6d78fd7..cc788308c4 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -24,16 +24,16 @@ module Language.PureScript.Ide.Imports ) where -import Protolude hiding (moduleName) +import Protolude hiding (moduleName) -import Control.Lens ((^.), (%~), ix) -import Data.List (partition) -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T -import qualified Language.PureScript as P -import qualified Language.PureScript.CST as CST -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Util +import Control.Lens ((^.), (%~), ix) +import Data.List (partition) +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T +import Language.PureScript qualified as P +import Language.PureScript.CST qualified as CST +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Util data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) deriving (Eq, Show) diff --git a/src/Language/PureScript/Ide/Imports/Actions.hs b/src/Language/PureScript/Ide/Imports/Actions.hs index 6d69491587..af48677df7 100644 --- a/src/Language/PureScript/Ide/Imports/Actions.hs +++ b/src/Language/PureScript/Ide/Imports/Actions.hs @@ -11,23 +11,23 @@ module Language.PureScript.Ide.Imports.Actions ) where -import Protolude hiding (moduleName) - -import Control.Lens ((^.), has) -import Data.List (nubBy) -import qualified Data.Map as Map -import qualified Data.Text as T -import qualified Language.PureScript as P -import qualified Language.PureScript.Constants.Prim as C -import Language.PureScript.Ide.Completion -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Filter -import Language.PureScript.Ide.Imports -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Prim -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util -import System.IO.UTF8 (writeUTF8FileT) +import Protolude hiding (moduleName) + +import Control.Lens ((^.), has) +import Data.List (nubBy) +import Data.Map qualified as Map +import Data.Text qualified as T +import Language.PureScript qualified as P +import Language.PureScript.Constants.Prim qualified as C +import Language.PureScript.Ide.Completion +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Imports +import Language.PureScript.Ide.State +import Language.PureScript.Ide.Prim +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util +import System.IO.UTF8 (writeUTF8FileT) -- | Adds an implicit import like @import Prelude@ to a Sourcefile. addImplicitImport diff --git a/src/Language/PureScript/Ide/Logging.hs b/src/Language/PureScript/Ide/Logging.hs index 9ffaafa278..4b1159deb8 100644 --- a/src/Language/PureScript/Ide/Logging.hs +++ b/src/Language/PureScript/Ide/Logging.hs @@ -7,13 +7,13 @@ module Language.PureScript.Ide.Logging , labelTimespec ) where -import Protolude +import Protolude -import "monad-logger" Control.Monad.Logger -import qualified Data.Text as T -import Language.PureScript.Ide.Types -import System.Clock -import Text.Printf +import "monad-logger" Control.Monad.Logger +import Data.Text qualified as T +import Language.PureScript.Ide.Types +import System.Clock +import Text.Printf runLogger :: MonadIO m => IdeLogLevel -> LoggingT m a -> m a runLogger logLevel' = diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index 9263abdb5e..a959c103dd 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -19,16 +19,16 @@ module Language.PureScript.Ide.Matcher , flexMatcher ) where -import Protolude - -import Control.Monad.Fail (fail) -import Data.Aeson -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util -import Text.EditDistance -import Text.Regex.TDFA ((=~)) +import Protolude + +import Control.Monad.Fail (fail) +import Data.Aeson +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util +import Text.EditDistance +import Text.Regex.TDFA ((=~)) type ScoredMatch a = (Match a, Double) diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index c65e98447b..ff60533d8f 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -1,13 +1,13 @@ module Language.PureScript.Ide.Prim (idePrimDeclarations) where -import Protolude +import Protolude -import qualified Data.Text as T -import qualified Data.Map as Map -import qualified Language.PureScript as P -import qualified Language.PureScript.Constants.Prim as C -import qualified Language.PureScript.Environment as PEnv -import Language.PureScript.Ide.Types +import Data.Text qualified as T +import Data.Map qualified as Map +import Language.PureScript qualified as P +import Language.PureScript.Constants.Prim qualified as C +import Language.PureScript.Environment qualified as PEnv +import Language.PureScript.Ide.Types idePrimDeclarations :: ModuleMap [IdeDeclarationAnn] idePrimDeclarations = Map.fromList diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 51d9dd996e..d9eccc9d57 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -6,26 +6,26 @@ module Language.PureScript.Ide.Rebuild , rebuildFile ) where -import Protolude hiding (moduleName) - -import "monad-logger" Control.Monad.Logger -import qualified Data.List as List -import qualified Data.Map.Lazy as M -import Data.Maybe (fromJust) -import qualified Data.Set as S -import qualified Data.Time as Time -import qualified Data.Text as Text -import qualified Language.PureScript as P -import Language.PureScript.Make (ffiCodegen') -import Language.PureScript.Make.Cache (CacheInfo(..), normaliseForCache) -import qualified Language.PureScript.CST as CST - -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Logging -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util -import System.Directory (getCurrentDirectory) +import Protolude hiding (moduleName) + +import "monad-logger" Control.Monad.Logger +import Data.List qualified as List +import Data.Map.Lazy qualified as M +import Data.Maybe (fromJust) +import Data.Set qualified as S +import Data.Time qualified as Time +import Data.Text qualified as Text +import Language.PureScript qualified as P +import Language.PureScript.Make (ffiCodegen') +import Language.PureScript.Make.Cache (CacheInfo(..), normaliseForCache) +import Language.PureScript.CST qualified as CST + +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Logging +import Language.PureScript.Ide.State +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util +import System.Directory (getCurrentDirectory) -- | Given a filepath performs the following steps: -- diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index 50f7acb549..c862c63c87 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -22,13 +22,13 @@ module Language.PureScript.Ide.Reexports , resolveReexports' ) where -import Protolude hiding (moduleName) +import Protolude hiding (moduleName) -import Control.Lens hiding (anyOf, (&)) -import qualified Data.Map as Map -import qualified Language.PureScript as P -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util +import Control.Lens hiding (anyOf, (&)) +import Data.Map qualified as Map +import Language.PureScript qualified as P +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util -- | Contains the module with resolved reexports, and possible failures data ReexportResult a diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 61dfcb4e14..333101a025 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -20,15 +20,15 @@ module Language.PureScript.Ide.SourceFile , extractTypeAnnotations ) where -import Protolude +import Protolude -import Control.Parallel.Strategies (withStrategy, parList, rseq) -import qualified Data.Map as Map -import qualified Language.PureScript as P -import qualified Language.PureScript.CST as CST -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util +import Control.Parallel.Strategies (withStrategy, parList, rseq) +import Data.Map qualified as Map +import Language.PureScript qualified as P +import Language.PureScript.CST qualified as CST +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util parseModule :: FilePath -> Text -> Either FilePath (FilePath, P.Module) parseModule path file = diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 99e5515f17..03bb241d8d 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -37,25 +37,25 @@ module Language.PureScript.Ide.State , resolveDataConstructorsForModule ) where -import Protolude hiding (moduleName, unzip) - -import Control.Concurrent.STM -import Control.Lens hiding (anyOf, op, (&)) -import "monad-logger" Control.Monad.Logger -import Data.IORef -import qualified Data.Map.Lazy as Map -import Data.Time.Clock (UTCTime) -import Data.Zip (unzip) -import qualified Language.PureScript as P -import Language.PureScript.Docs.Convert.Single (convertComments) -import Language.PureScript.Externs -import Language.PureScript.Make.Actions (cacheDbFile) -import Language.PureScript.Ide.Externs -import Language.PureScript.Ide.Reexports -import Language.PureScript.Ide.SourceFile -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util -import System.Directory (getModificationTime) +import Protolude hiding (moduleName, unzip) + +import Control.Concurrent.STM +import Control.Lens hiding (anyOf, op, (&)) +import "monad-logger" Control.Monad.Logger +import Data.IORef +import Data.Map.Lazy qualified as Map +import Data.Time.Clock (UTCTime) +import Data.Zip (unzip) +import Language.PureScript qualified as P +import Language.PureScript.Docs.Convert.Single (convertComments) +import Language.PureScript.Externs +import Language.PureScript.Make.Actions (cacheDbFile) +import Language.PureScript.Ide.Externs +import Language.PureScript.Ide.Reexports +import Language.PureScript.Ide.SourceFile +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util +import System.Directory (getModificationTime) -- | Resets all State inside psc-ide resetIdeState :: Ide m => m () diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index f2748cdb50..b8fcda9dd5 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -5,19 +5,19 @@ module Language.PureScript.Ide.Types where -import Protolude hiding (moduleName) - -import Control.Concurrent.STM (TVar) -import Control.Lens hiding (op, (.=)) -import Control.Monad.Fail (fail) -import Data.Aeson (ToJSON, FromJSON, (.=)) -import qualified Data.Aeson as Aeson -import Data.IORef (IORef) -import Data.Time.Clock (UTCTime) -import qualified Data.Map.Lazy as M -import qualified Language.PureScript as P -import qualified Language.PureScript.Errors.JSON as P -import Language.PureScript.Ide.Filter.Declaration (DeclarationType(..)) +import Protolude hiding (moduleName) + +import Control.Concurrent.STM (TVar) +import Control.Lens hiding (op, (.=)) +import Control.Monad.Fail (fail) +import Data.Aeson (ToJSON, FromJSON, (.=)) +import Data.Aeson qualified as Aeson +import Data.IORef (IORef) +import Data.Time.Clock (UTCTime) +import Data.Map.Lazy qualified as M +import Language.PureScript qualified as P +import Language.PureScript.Errors.JSON qualified as P +import Language.PureScript.Ide.Filter.Declaration (DeclarationType(..)) type ModuleIdent = Text type ModuleMap a = Map P.ModuleName a diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index 8616c55744..5d04654a3c 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -6,15 +6,15 @@ module Language.PureScript.Ide.Usage , findUsages ) where -import Protolude hiding (moduleName) +import Protolude hiding (moduleName) -import Control.Lens (preview) -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Language.PureScript as P -import Language.PureScript.Ide.State (getAllModules, getFileState) -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util +import Control.Lens (preview) +import Data.Map qualified as Map +import Data.Set qualified as Set +import Language.PureScript qualified as P +import Language.PureScript.Ide.State (getAllModules, getFileState) +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util -- | -- How we find usages, given an IdeDeclaration and the module it was defined in: diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 5f13157ed2..f7f90f5236 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -29,20 +29,20 @@ module Language.PureScript.Ide.Util , module Language.PureScript.Ide.Logging ) where -import Protolude hiding (decodeUtf8, +import Protolude hiding (decodeUtf8, encodeUtf8, to) -import Control.Lens hiding (op, (&)) -import Data.Aeson -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import Data.Text.Lazy.Encoding as TLE -import qualified Language.PureScript as P -import Language.PureScript.Ide.Error (IdeError(..)) -import Language.PureScript.Ide.Logging -import Language.PureScript.Ide.Types -import System.IO.UTF8 (readUTF8FileT) -import System.Directory (makeAbsolute) +import Control.Lens hiding (op, (&)) +import Data.Aeson +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding as TLE +import Language.PureScript qualified as P +import Language.PureScript.Ide.Error (IdeError(..)) +import Language.PureScript.Ide.Logging +import Language.PureScript.Ide.Types +import System.IO.UTF8 (readUTF8FileT) +import System.Directory (makeAbsolute) identifierFromIdeDeclaration :: IdeDeclaration -> Text identifierFromIdeDeclaration d = case d of diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index e1552e2d07..820aefc080 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -9,39 +9,39 @@ module Language.PureScript.Interactive , runMake ) where -import Prelude -import Protolude (ordNub) - -import Data.List (sort, find, foldl') -import Data.Maybe (fromMaybe, mapMaybe) -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.State.Class -import Control.Monad.Reader.Class -import Control.Monad.Trans.Except (ExceptT(..), runExceptT) -import Control.Monad.Trans.State.Strict (StateT, runStateT, evalStateT) -import Control.Monad.Writer.Strict (Writer(), runWriter) - -import qualified Language.PureScript as P -import qualified Language.PureScript.CST as CST -import qualified Language.PureScript.Names as N -import qualified Language.PureScript.Constants.Prim as C - -import Language.PureScript.Interactive.Completion as Interactive -import Language.PureScript.Interactive.IO as Interactive -import Language.PureScript.Interactive.Message as Interactive -import Language.PureScript.Interactive.Module as Interactive -import Language.PureScript.Interactive.Parser as Interactive -import Language.PureScript.Interactive.Printer as Interactive -import Language.PureScript.Interactive.Types as Interactive - -import System.Directory (getCurrentDirectory) -import System.FilePath (()) -import System.FilePath.Glob (glob) +import Prelude +import Protolude (ordNub) + +import Data.List (sort, find, foldl') +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Map qualified as M +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified as T + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.State.Class +import Control.Monad.Reader.Class +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) +import Control.Monad.Trans.State.Strict (StateT, runStateT, evalStateT) +import Control.Monad.Writer.Strict (Writer(), runWriter) + +import Language.PureScript qualified as P +import Language.PureScript.CST qualified as CST +import Language.PureScript.Names qualified as N +import Language.PureScript.Constants.Prim qualified as C + +import Language.PureScript.Interactive.Completion as Interactive +import Language.PureScript.Interactive.IO as Interactive +import Language.PureScript.Interactive.Message as Interactive +import Language.PureScript.Interactive.Module as Interactive +import Language.PureScript.Interactive.Parser as Interactive +import Language.PureScript.Interactive.Printer as Interactive +import Language.PureScript.Interactive.Types as Interactive + +import System.Directory (getCurrentDirectory) +import System.FilePath (()) +import System.FilePath.Glob (glob) -- | Pretty-print errors printErrors :: MonadIO m => P.MultipleErrors -> m () diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index d79627801a..d4fd68d770 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -9,17 +9,17 @@ module Language.PureScript.Interactive.Completion import Prelude import Protolude (ordNub) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.State.Class (MonadState(..)) -import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) -import Data.List (nub, isPrefixOf, isInfixOf, isSuffixOf, sortBy, stripPrefix) -import Data.Map (keys) -import Data.Maybe (mapMaybe) -import qualified Data.Text as T -import qualified Language.PureScript as P -import qualified Language.PureScript.Interactive.Directive as D -import Language.PureScript.Interactive.Types -import System.Console.Haskeline +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) +import Data.List (nub, isPrefixOf, isInfixOf, isSuffixOf, sortBy, stripPrefix) +import Data.Map (keys) +import Data.Maybe (mapMaybe) +import Data.Text qualified as T +import Language.PureScript qualified as P +import Language.PureScript.Interactive.Directive qualified as D +import Language.PureScript.Interactive.Types +import System.Console.Haskeline -- Completions may read the state, but not modify it. type CompletionM = ReaderT PSCiState IO diff --git a/src/Language/PureScript/Interactive/Message.hs b/src/Language/PureScript/Interactive/Message.hs index 17488149b8..f99aabbe86 100644 --- a/src/Language/PureScript/Interactive/Message.hs +++ b/src/Language/PureScript/Interactive/Message.hs @@ -1,12 +1,12 @@ module Language.PureScript.Interactive.Message where -import Prelude +import Prelude -import Data.List (intercalate) -import Data.Version (showVersion) -import qualified Paths_purescript as Paths -import qualified Language.PureScript.Interactive.Directive as D -import Language.PureScript.Interactive.Types +import Data.List (intercalate) +import Data.Version (showVersion) +import Paths_purescript qualified as Paths +import Language.PureScript.Interactive.Directive qualified as D +import Language.PureScript.Interactive.Types -- Messages diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 9c90a890af..3230a44321 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -1,13 +1,13 @@ module Language.PureScript.Interactive.Module where -import Prelude +import Prelude -import qualified Language.PureScript as P -import qualified Language.PureScript.CST as CST -import Language.PureScript.Interactive.Types -import System.Directory (getCurrentDirectory) -import System.FilePath (pathSeparator, makeRelative) -import System.IO.UTF8 (readUTF8FilesT) +import Language.PureScript qualified as P +import Language.PureScript.CST qualified as CST +import Language.PureScript.Interactive.Types +import System.Directory (getCurrentDirectory) +import System.FilePath (pathSeparator, makeRelative) +import System.IO.UTF8 (readUTF8FilesT) -- * Support Module diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index 4f55bfb566..0347064dd7 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -6,19 +6,19 @@ module Language.PureScript.Interactive.Parser , parseCommand ) where -import Prelude - -import Control.Monad (join) -import Data.Bifunctor (bimap) -import Data.Char (isSpace) -import Data.List (intercalate) -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T -import qualified Language.PureScript as P -import qualified Language.PureScript.CST as CST -import qualified Language.PureScript.CST.Monad as CSTM -import qualified Language.PureScript.Interactive.Directive as D -import Language.PureScript.Interactive.Types +import Prelude + +import Control.Monad (join) +import Data.Bifunctor (bimap) +import Data.Char (isSpace) +import Data.List (intercalate) +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T +import Language.PureScript qualified as P +import Language.PureScript.CST qualified as CST +import Language.PureScript.CST.Monad qualified as CSTM +import Language.PureScript.Interactive.Directive qualified as D +import Language.PureScript.Interactive.Types -- | -- Parses a limited set of commands from from .purs-repl diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index e1775a6997..cd0b8f58f3 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -1,14 +1,14 @@ module Language.PureScript.Interactive.Printer where -import Prelude - -import Data.List (intersperse) -import qualified Data.Map as M -import Data.Maybe (mapMaybe) -import qualified Data.Text as T -import Data.Text (Text) -import qualified Language.PureScript as P -import qualified Text.PrettyPrint.Boxes as Box +import Prelude + +import Data.List (intersperse) +import Data.Map qualified as M +import Data.Maybe (mapMaybe) +import Data.Text qualified as T +import Data.Text (Text) +import Language.PureScript qualified as P +import Text.PrettyPrint.Boxes qualified as Box -- TODO (Christoph): Text version of boxes textT :: Text -> Box.Box diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs index c6257fed3a..83fedf811d 100644 --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -30,14 +30,14 @@ module Language.PureScript.Interactive.Types import Prelude -import qualified Language.PureScript as P -import qualified Data.Map as M -import Data.List (foldl') -import Language.PureScript.Sugar.Names.Env (nullImports, primExports) -import Control.Monad (foldM) -import Control.Monad.Trans.Except (runExceptT) -import Control.Monad.Trans.State (execStateT) -import Control.Monad.Writer.Strict (runWriterT) +import Language.PureScript qualified as P +import Data.Map qualified as M +import Data.List (foldl') +import Language.PureScript.Sugar.Names.Env (nullImports, primExports) +import Control.Monad (foldM) +import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.State (execStateT) +import Control.Monad.Writer.Strict (runWriterT) -- | The PSCI configuration. diff --git a/src/Language/PureScript/Label.hs b/src/Language/PureScript/Label.hs index f3d257b0fa..a5d080a76c 100644 --- a/src/Language/PureScript/Label.hs +++ b/src/Language/PureScript/Label.hs @@ -6,7 +6,7 @@ import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Data.Monoid () import Data.String (IsString(..)) -import qualified Data.Aeson as A +import Data.Aeson qualified as A import Language.PureScript.PSString (PSString) diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 15265fbf84..bffde54883 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -8,9 +8,9 @@ import Prelude import Control.Monad.Writer.Class import Data.Maybe (mapMaybe) -import qualified Data.Set as S +import Data.Set qualified as S import Data.Text (Text) -import qualified Data.Text as Text +import Data.Text qualified as Text import Control.Monad ((<=<)) import Language.PureScript.AST @@ -19,7 +19,7 @@ import Language.PureScript.Linter.Exhaustive as L import Language.PureScript.Linter.Imports as L import Language.PureScript.Names import Language.PureScript.Types -import qualified Language.PureScript.Constants.Libs as C +import Language.PureScript.Constants.Libs qualified as C -- | Lint the PureScript AST. -- | diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index db1373e686..60a20ff3cf 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -18,8 +18,8 @@ import Control.Monad.Writer.Class import Data.List (foldl', sortOn) import Data.Maybe (fromMaybe) -import qualified Data.Map as M -import qualified Data.Text as T +import Data.Map qualified as M +import Data.Text qualified as T import Language.PureScript.AST.Binders import Language.PureScript.AST.Declarations @@ -31,7 +31,7 @@ import Language.PureScript.Names as P import Language.PureScript.Pretty.Values (prettyPrintBinderAtom) import Language.PureScript.Traversals import Language.PureScript.Types as P -import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.Constants.Prim qualified as C -- | There are two modes of failure for the redundancy check: -- diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 9b81691411..9c88597978 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -16,8 +16,8 @@ import Data.List (find, intersect, groupBy, sort, sortOn, (\\)) import Data.Maybe (mapMaybe) import Data.Monoid (Sum(..)) import Data.Traversable (forM) -import qualified Data.Text as T -import qualified Data.Map as M +import Data.Text qualified as T +import Data.Map qualified as M import Language.PureScript.AST.Declarations import Language.PureScript.AST.SourcePos @@ -27,7 +27,7 @@ import Language.PureScript.Names import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) import Language.PureScript.Sugar.Names.Env import Language.PureScript.Sugar.Names.Imports -import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.Constants.Prim qualified as C -- | -- Map of module name to list of imported names from that module which have diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index d5c0dd05f5..ad361342c5 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -9,47 +9,47 @@ module Language.PureScript.Make , module Actions ) where -import Prelude +import Prelude -import Control.Concurrent.Lifted as C -import Control.Exception.Base (onException) -import Control.Monad hiding (sequence) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.IO.Class -import Control.Monad.Supply -import Control.Monad.Trans.Control (MonadBaseControl(..), control) -import Control.Monad.Trans.State (runStateT) -import Control.Monad.Writer.Class (MonadWriter(..), censor) -import Control.Monad.Writer.Strict (runWriterT) -import Data.Function (on) -import Data.Foldable (fold, for_) -import Data.List (foldl', sortOn) -import qualified Data.List.NonEmpty as NEL -import Data.Maybe (fromMaybe) -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Text as T -import Language.PureScript.AST -import Language.PureScript.Crash -import qualified Language.PureScript.CST as CST -import qualified Language.PureScript.Docs.Convert as Docs -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Externs -import Language.PureScript.Linter -import Language.PureScript.ModuleDependencies -import Language.PureScript.Names -import Language.PureScript.Renamer -import Language.PureScript.Sugar -import Language.PureScript.TypeChecker -import Language.PureScript.Make.BuildPlan -import qualified Language.PureScript.Make.BuildPlan as BuildPlan -import qualified Language.PureScript.Make.Cache as Cache -import Language.PureScript.Make.Actions as Actions -import Language.PureScript.Make.Monad as Monad -import qualified Language.PureScript.CoreFn as CF -import System.Directory (doesFileExist) -import System.FilePath (replaceExtension) +import Control.Concurrent.Lifted as C +import Control.Exception.Base (onException) +import Control.Monad hiding (sequence) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.IO.Class +import Control.Monad.Supply +import Control.Monad.Trans.Control (MonadBaseControl(..), control) +import Control.Monad.Trans.State (runStateT) +import Control.Monad.Writer.Class (MonadWriter(..), censor) +import Control.Monad.Writer.Strict (runWriterT) +import Data.Function (on) +import Data.Foldable (fold, for_) +import Data.List (foldl', sortOn) +import Data.List.NonEmpty qualified as NEL +import Data.Maybe (fromMaybe) +import Data.Map qualified as M +import Data.Set qualified as S +import Data.Text qualified as T +import Language.PureScript.AST +import Language.PureScript.Crash +import Language.PureScript.CST qualified as CST +import Language.PureScript.Docs.Convert qualified as Docs +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Externs +import Language.PureScript.Linter +import Language.PureScript.ModuleDependencies +import Language.PureScript.Names +import Language.PureScript.Renamer +import Language.PureScript.Sugar +import Language.PureScript.TypeChecker +import Language.PureScript.Make.BuildPlan +import Language.PureScript.Make.BuildPlan qualified as BuildPlan +import Language.PureScript.Make.Cache qualified as Cache +import Language.PureScript.Make.Actions as Actions +import Language.PureScript.Make.Monad as Monad +import Language.PureScript.CoreFn qualified as CF +import System.Directory (doesFileExist) +import System.FilePath (replaceExtension) -- | Rebuild a single module. -- diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 485086b838..6c6d251bae 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -11,53 +11,53 @@ module Language.PureScript.Make.Actions , ffiCodegen' ) where -import Prelude - -import Control.Monad hiding (sequence) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.IO.Class -import Control.Monad.Reader (asks) -import Control.Monad.Supply -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) -import Data.Aeson (Value(String), (.=), object) -import Data.Bifunctor (bimap, first) -import Data.Either (partitionEithers) -import Data.Foldable (for_) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as M -import Data.Maybe (fromMaybe, maybeToList) -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import qualified Data.Text.Encoding as TE -import Data.Time.Clock (UTCTime) -import Data.Version (showVersion) -import qualified Language.JavaScript.Parser as JS -import Language.PureScript.AST -import qualified Language.PureScript.Bundle as Bundle -import qualified Language.PureScript.CodeGen.JS as J -import Language.PureScript.CodeGen.JS.Printer -import qualified Language.PureScript.CoreFn as CF -import qualified Language.PureScript.CoreFn.ToJSON as CFJ -import Language.PureScript.Crash -import qualified Language.PureScript.CST as CST -import qualified Language.PureScript.Docs.Prim as Docs.Prim -import qualified Language.PureScript.Docs.Types as Docs -import Language.PureScript.Errors -import Language.PureScript.Externs (ExternsFile, externsFileName) -import Language.PureScript.Make.Monad -import Language.PureScript.Make.Cache -import Language.PureScript.Names -import Language.PureScript.Options hiding (codegenTargets) -import Language.PureScript.Pretty.Common (SMap(..)) -import qualified Paths_purescript as Paths -import SourceMap -import SourceMap.Types -import System.Directory (getCurrentDirectory) -import System.FilePath ((), makeRelative, splitPath, normalise, splitDirectories) -import qualified System.FilePath.Posix as Posix -import System.IO (stderr) +import Prelude + +import Control.Monad hiding (sequence) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.IO.Class +import Control.Monad.Reader (asks) +import Control.Monad.Supply +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Aeson (Value(String), (.=), object) +import Data.Bifunctor (bimap, first) +import Data.Either (partitionEithers) +import Data.Foldable (for_) +import Data.List.NonEmpty qualified as NEL +import Data.Map qualified as M +import Data.Maybe (fromMaybe, maybeToList) +import Data.Set qualified as S +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import Data.Text.Encoding qualified as TE +import Data.Time.Clock (UTCTime) +import Data.Version (showVersion) +import Language.JavaScript.Parser qualified as JS +import Language.PureScript.AST +import Language.PureScript.Bundle qualified as Bundle +import Language.PureScript.CodeGen.JS qualified as J +import Language.PureScript.CodeGen.JS.Printer +import Language.PureScript.CoreFn qualified as CF +import Language.PureScript.CoreFn.ToJSON qualified as CFJ +import Language.PureScript.Crash +import Language.PureScript.CST qualified as CST +import Language.PureScript.Docs.Prim qualified as Docs.Prim +import Language.PureScript.Docs.Types qualified as Docs +import Language.PureScript.Errors +import Language.PureScript.Externs (ExternsFile, externsFileName) +import Language.PureScript.Make.Monad +import Language.PureScript.Make.Cache +import Language.PureScript.Names +import Language.PureScript.Options hiding (codegenTargets) +import Language.PureScript.Pretty.Common (SMap(..)) +import Paths_purescript qualified as Paths +import SourceMap +import SourceMap.Types +import System.Directory (getCurrentDirectory) +import System.FilePath ((), makeRelative, splitPath, normalise, splitDirectories) +import System.FilePath.Posix qualified as Posix +import System.IO (stderr) -- | Determines when to rebuild a module data RebuildPolicy diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index d79dc4e2f8..7ac97532f1 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -9,28 +9,28 @@ module Language.PureScript.Make.BuildPlan , needsRebuild ) where -import Prelude - -import Control.Concurrent.Async.Lifted as A -import Control.Concurrent.Lifted as C -import Control.Monad.Base (liftBase) -import Control.Monad hiding (sequence) -import Control.Monad.Trans.Control (MonadBaseControl(..)) -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) -import Data.Foldable (foldl') -import qualified Data.Map as M -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Time.Clock (UTCTime) -import Language.PureScript.AST -import Language.PureScript.Crash -import qualified Language.PureScript.CST as CST -import Language.PureScript.Errors -import Language.PureScript.Externs -import Language.PureScript.Make.Actions as Actions -import Language.PureScript.Make.Cache -import Language.PureScript.Names (ModuleName) -import Language.PureScript.Sugar.Names.Env -import System.Directory (getCurrentDirectory) +import Prelude + +import Control.Concurrent.Async.Lifted as A +import Control.Concurrent.Lifted as C +import Control.Monad.Base (liftBase) +import Control.Monad hiding (sequence) +import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Data.Foldable (foldl') +import Data.Map qualified as M +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Time.Clock (UTCTime) +import Language.PureScript.AST +import Language.PureScript.Crash +import Language.PureScript.CST qualified as CST +import Language.PureScript.Errors +import Language.PureScript.Externs +import Language.PureScript.Make.Actions as Actions +import Language.PureScript.Make.Cache +import Language.PureScript.Names (ModuleName) +import Language.PureScript.Sugar.Names.Env +import System.Directory (getCurrentDirectory) -- | The BuildPlan tracks information about our build progress, and holds all -- prebuilt modules for incremental builds. diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs index b56261951f..092544fa73 100644 --- a/src/Language/PureScript/Make/Cache.hs +++ b/src/Language/PureScript/Make/Cache.hs @@ -13,13 +13,13 @@ import Prelude import Control.Category ((>>>)) import Control.Monad ((>=>)) import Crypto.Hash (HashAlgorithm, Digest, SHA512) -import qualified Crypto.Hash as Hash -import qualified Data.Aeson as Aeson +import Crypto.Hash qualified as Hash +import Data.Aeson qualified as Aeson import Data.Align (align) import Data.ByteArray.Encoding (Base(Base16), convertToBase, convertFromBase) -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS import Data.Map (Map) -import qualified Data.Map as Map +import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Monoid (All(..)) import Data.Set (Set) @@ -28,7 +28,7 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.These (These(..)) import Data.Time.Clock (UTCTime) import Data.Traversable (for) -import qualified System.FilePath as FilePath +import System.FilePath qualified as FilePath import Language.PureScript.Names (ModuleName) diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index cea5fa882f..dbb7c0607b 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -19,34 +19,34 @@ module Language.PureScript.Make.Monad , copyFile ) where -import Prelude - -import Codec.Serialise (Serialise) -import qualified Codec.Serialise as Serialise -import Control.Exception (fromException, tryJust) -import Control.Monad (join, guard) -import Control.Monad.Base (MonadBase(..)) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.IO.Class -import Control.Monad.Logger -import Control.Monad.Reader (MonadReader(..), ReaderT(..)) -import Control.Monad.Trans.Control (MonadBaseControl(..)) -import Control.Monad.Trans.Except -import Control.Monad.Writer.Class (MonadWriter(..)) -import qualified Data.Aeson as Aeson -import qualified Data.ByteString as B -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Time.Clock (UTCTime) -import Language.PureScript.Errors -import Language.PureScript.Externs (ExternsFile, externsIsCurrentVersion) -import Language.PureScript.Make.Cache (ContentHash, hash) -import Language.PureScript.Options -import System.Directory (createDirectoryIfMissing, getModificationTime) -import qualified System.Directory as Directory -import System.FilePath (takeDirectory) -import System.IO.Error (tryIOError, isDoesNotExistError) -import System.IO.UTF8 (readUTF8FileT) +import Prelude + +import Codec.Serialise (Serialise) +import Codec.Serialise qualified as Serialise +import Control.Exception (fromException, tryJust) +import Control.Monad (join, guard) +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.IO.Class +import Control.Monad.Logger +import Control.Monad.Reader (MonadReader(..), ReaderT(..)) +import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Control.Monad.Trans.Except +import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Aeson qualified as Aeson +import Data.ByteString qualified as B +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Time.Clock (UTCTime) +import Language.PureScript.Errors +import Language.PureScript.Externs (ExternsFile, externsIsCurrentVersion) +import Language.PureScript.Make.Cache (ContentHash, hash) +import Language.PureScript.Options +import System.Directory (createDirectoryIfMissing, getModificationTime) +import System.Directory qualified as Directory +import System.FilePath (takeDirectory) +import System.IO.Error (tryIOError, isDoesNotExistError) +import System.IO.UTF8 (readUTF8FileT) -- | A monad for running make actions newtype Make a = Make diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 909f5046f9..ae55e1138f 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -7,16 +7,16 @@ module Language.PureScript.ModuleDependencies , moduleSignature ) where -import Protolude hiding (head) +import Protolude hiding (head) -import Data.Array ((!)) -import Data.Graph -import qualified Data.Set as S -import Language.PureScript.AST -import qualified Language.PureScript.Constants.Prim as C -import Language.PureScript.Crash -import Language.PureScript.Errors hiding (nonEmpty) -import Language.PureScript.Names +import Data.Array ((!)) +import Data.Graph +import Data.Set qualified as S +import Language.PureScript.AST +import Language.PureScript.Constants.Prim qualified as C +import Language.PureScript.Crash +import Language.PureScript.Errors hiding (nonEmpty) +import Language.PureScript.Names -- | A list of modules with their transitive dependencies type ModuleGraph = [(ModuleName, [ModuleName])] diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 16dda5e1bb..4783f4f165 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -12,13 +12,13 @@ import Control.Applicative ((<|>)) import Control.Monad.Supply.Class import Control.DeepSeq (NFData) import Data.Functor.Contravariant (contramap) -import qualified Data.Vector as V +import Data.Vector qualified as V import GHC.Generics (Generic) import Data.Aeson import Data.Aeson.TH import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos) diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index b0e44bc16d..d94d344cf0 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -2,9 +2,9 @@ module Language.PureScript.Options where import Prelude -import qualified Data.Set as S +import Data.Set qualified as S import Data.Map (Map) -import qualified Data.Map as Map +import Data.Map qualified as Map -- | The data type of compiler options data Options = Options diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index 44a617e73a..2ceb481181 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -15,24 +15,24 @@ import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Control.Exception (try, evaluate) import Control.Applicative ((<|>)) -import qualified Data.Char as Char +import Data.Char qualified as Char import Data.Bits (shiftR) import Data.Either (fromRight) import Data.List (unfoldr) import Data.Scientific (toBoundedInteger) import Data.String (IsString(..)) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Text.Encoding (decodeUtf16BE) import Data.Text.Encoding.Error (UnicodeException) -import qualified Data.Vector as V +import Data.Vector qualified as V import Data.Word (Word16, Word8) import Numeric (showHex) import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Aeson as A -import qualified Data.Aeson.Types as A +import Data.Aeson qualified as A +import Data.Aeson.Types qualified as A -- | -- Strings in PureScript are sequences of UTF-16 code units, which do not diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 04125f96e3..2f32e7bcbc 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -9,13 +9,13 @@ import Control.Monad.State (StateT, modify, get) import Data.List (elemIndices, intersperse) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Language.PureScript.AST (SourcePos(..), SourceSpan(..), nullSourceSpan) import Language.PureScript.CST.Lexer (isUnquotedKey) import Text.PrettyPrint.Boxes hiding ((<>)) -import qualified Text.PrettyPrint.Boxes as Box +import Text.PrettyPrint.Boxes qualified as Box parensT :: Text -> Text parensT s = "(" <> s <> ")" diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index d7c90374c3..e26f3cb131 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -27,7 +27,7 @@ import Control.PatternArrows as PA import Data.Bifunctor (first) import Data.Maybe (fromMaybe, catMaybes) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Language.PureScript.Crash import Language.PureScript.Environment diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 24638f6932..d0b0f823f2 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -12,9 +12,9 @@ import Prelude hiding ((<>)) import Control.Arrow (second) import Data.Text (Text) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Monoid as Monoid ((<>)) -import qualified Data.Text as T +import Data.List.NonEmpty qualified as NEL +import Data.Monoid qualified as Monoid ((<>)) +import Data.Text qualified as T import Language.PureScript.AST import Language.PureScript.Crash diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index cc4f94cae1..58b502cb84 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -23,29 +23,29 @@ import Control.Arrow ((***)) import Control.Category ((>>>)) import Control.Monad.Writer.Strict (MonadWriter, WriterT, runWriterT, tell) -import qualified Data.ByteString.Lazy as BL +import Data.ByteString.Lazy qualified as BL import Data.String (String, lines) import Data.List (stripPrefix, (\\)) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Version -import qualified Distribution.SPDX as SPDX -import qualified Distribution.Parsec as CabalParsec +import Distribution.SPDX qualified as SPDX +import Distribution.Parsec qualified as CabalParsec import System.Directory (doesFileExist) import System.FilePath.Glob (globDir1) import System.Process (readProcess) import Web.Bower.PackageMeta (PackageMeta(..), PackageName, Repository(..)) -import qualified Web.Bower.PackageMeta as Bower +import Web.Bower.PackageMeta qualified as Bower import Language.PureScript.Publish.ErrorsWarnings import Language.PureScript.Publish.Registry.Compat import Language.PureScript.Publish.Utils -import qualified Language.PureScript as P (version, ModuleName) -import qualified Language.PureScript.CoreFn.FromJSON as P -import qualified Language.PureScript.Docs as D +import Language.PureScript qualified as P (version, ModuleName) +import Language.PureScript.CoreFn.FromJSON qualified as P +import Language.PureScript.Docs qualified as D import Data.Aeson.BetterErrors (Parse, withString, eachInObjectWithKey, asString, key, keyMay, parse, mapError) import Language.PureScript.Docs.Types (ManifestError(BowerManifest, PursManifest)) diff --git a/src/Language/PureScript/Publish/BoxesHelpers.hs b/src/Language/PureScript/Publish/BoxesHelpers.hs index b37e794ab6..36d9a180b9 100644 --- a/src/Language/PureScript/Publish/BoxesHelpers.hs +++ b/src/Language/PureScript/Publish/BoxesHelpers.hs @@ -7,10 +7,10 @@ module Language.PureScript.Publish.BoxesHelpers import Prelude import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import System.IO (hPutStr, stderr) -import qualified Text.PrettyPrint.Boxes as Boxes +import Text.PrettyPrint.Boxes qualified as Boxes width :: Int width = 79 diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index b4f48949e1..ef08193b34 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -22,16 +22,16 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe import Data.Monoid import Data.Version -import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty qualified as NonEmpty import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T -import qualified Language.PureScript.Docs.Types as D -import qualified Language.PureScript as P +import Language.PureScript.Docs.Types qualified as D +import Language.PureScript qualified as P import Language.PureScript.Publish.BoxesHelpers import Web.Bower.PackageMeta (PackageName, runPackageName, showBowerError) -import qualified Web.Bower.PackageMeta as Bower +import Web.Bower.PackageMeta qualified as Bower import Language.PureScript.Docs.Types (showManifestError) -- | An error which meant that it was not possible to retrieve metadata for a diff --git a/src/Language/PureScript/Publish/Registry/Compat.hs b/src/Language/PureScript/Publish/Registry/Compat.hs index d9bf5038ae..a1a01ed9a4 100644 --- a/src/Language/PureScript/Publish/Registry/Compat.hs +++ b/src/Language/PureScript/Publish/Registry/Compat.hs @@ -8,8 +8,8 @@ module Language.PureScript.Publish.Registry.Compat where import Protolude -import qualified Data.Map as Map -import qualified Web.Bower.PackageMeta as Bower +import Data.Map qualified as Map +import Web.Bower.PackageMeta qualified as Bower import Data.Bitraversable (Bitraversable(..)) import Data.Aeson.BetterErrors (key, asText, keyMay, eachInObject, Parse, throwCustomError) diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index a822b2081c..369ba80486 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -10,9 +10,9 @@ import Control.Monad.State import Data.Functor ((<&>)) import Data.List (find) import Data.Maybe (fromJust, fromMaybe) -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Text as T +import Data.Map qualified as M +import Data.Set qualified as S +import Data.Text qualified as T import Language.PureScript.CoreFn import Language.PureScript.Names diff --git a/src/Language/PureScript/Roles.hs b/src/Language/PureScript/Roles.hs index 498a899d48..7a73062993 100644 --- a/src/Language/PureScript/Roles.hs +++ b/src/Language/PureScript/Roles.hs @@ -12,8 +12,8 @@ import Prelude import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) -import qualified Data.Aeson as A -import qualified Data.Aeson.TH as A +import Data.Aeson qualified as A +import Data.Aeson.TH qualified as A import Data.Text (Text) import GHC.Generics (Generic) diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs index 4e138f2c98..047d413edb 100644 --- a/src/Language/PureScript/Sugar/AdoNotation.hs +++ b/src/Language/PureScript/Sugar/AdoNotation.hs @@ -3,16 +3,16 @@ module Language.PureScript.Sugar.AdoNotation (desugarAdoModule) where -import Prelude hiding (abs) +import Prelude hiding (abs) -import Control.Monad (foldM) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class -import Data.List (foldl') -import Language.PureScript.AST -import Language.PureScript.Errors -import Language.PureScript.Names -import qualified Language.PureScript.Constants.Libs as C +import Control.Monad (foldM) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class +import Data.List (foldl') +import Language.PureScript.AST +import Language.PureScript.Errors +import Language.PureScript.Names +import Language.PureScript.Constants.Libs qualified as C -- | Replace all @AdoNotationBind@ and @AdoNotationValue@ constructors with -- applications of the pure and apply functions in scope, and all @AdoNotationLet@ diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index b3e87e779e..61de1090ca 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -20,9 +20,9 @@ import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty) import Data.Foldable (find) import Data.Functor (($>)) import Data.Maybe (isJust, mapMaybe) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as M -import qualified Data.Set as S +import Data.List.NonEmpty qualified as NEL +import Data.Map qualified as M +import Data.Set qualified as S import Language.PureScript.AST import Language.PureScript.Crash diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 008af901da..f6b9a819ec 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -3,18 +3,18 @@ module Language.PureScript.Sugar.DoNotation (desugarDoModule) where -import Prelude +import Prelude -import Control.Applicative ((<|>)) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class -import Data.Maybe (fromMaybe) -import Data.Monoid (First(..)) -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Errors -import Language.PureScript.Names -import qualified Language.PureScript.Constants.Libs as C +import Control.Applicative ((<|>)) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class +import Data.Maybe (fromMaybe) +import Data.Monoid (First(..)) +import Language.PureScript.AST +import Language.PureScript.Crash +import Language.PureScript.Errors +import Language.PureScript.Names +import Language.PureScript.Constants.Libs qualified as C -- | Replace all @DoNotationBind@ and @DoNotationValue@ constructors with -- applications of the bind function in scope, and all @DoNotationLet@ diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 7c09126af8..2fc947c738 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -18,10 +18,10 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Lazy import Control.Monad.Writer (MonadWriter(..)) -import qualified Data.List.NonEmpty as NEL +import Data.List.NonEmpty qualified as NEL import Data.Maybe (fromMaybe, mapMaybe) -import qualified Data.Map as M -import qualified Data.Set as S +import Data.Map qualified as M +import Data.Set qualified as S import Language.PureScript.AST import Language.PureScript.Crash diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 5b3616fdad..a83c555144 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -29,10 +29,10 @@ import Data.Foldable (find) import Data.List (groupBy, sortOn, delete) import Data.Maybe (mapMaybe) import Safe (headMay) -import qualified Data.Map as M -import qualified Data.Set as S +import Data.Map qualified as M +import Data.Set qualified as S -import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Environment diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index c87e17d3eb..70f0402fcb 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -13,7 +13,7 @@ import Data.Function (on) import Data.Foldable (traverse_) import Data.List (intersect, groupBy, sortOn) import Data.Maybe (fromMaybe, mapMaybe) -import qualified Data.Map as M +import Data.Map qualified as M import Language.PureScript.AST import Language.PureScript.Crash diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 846b03e19b..91577f83af 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -12,8 +12,8 @@ import Control.Monad.Error.Class (MonadError(..)) import Data.Foldable (for_, traverse_) import Data.Maybe (fromMaybe) -import qualified Data.Map as M -import qualified Data.Set as S +import Data.Map qualified as M +import Data.Set qualified as S import Language.PureScript.AST import Language.PureScript.Crash diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 51bbb48016..01e46e74b9 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -3,19 +3,19 @@ module Language.PureScript.Sugar.ObjectWildcards , desugarDecl ) where -import Prelude +import Prelude -import Control.Monad (forM) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class -import Data.Foldable (toList) -import Data.List (foldl') -import Data.Maybe (catMaybes) -import Language.PureScript.AST -import Language.PureScript.Environment (NameKind(..)) -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.PSString (PSString) +import Control.Monad (forM) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class +import Data.Foldable (toList) +import Data.List (foldl') +import Data.Maybe (catMaybes) +import Language.PureScript.AST +import Language.PureScript.Environment (NameKind(..)) +import Language.PureScript.Errors +import Language.PureScript.Names +import Language.PureScript.PSString (PSString) desugarObjectConstructors diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 1009ce3fbd..6b807d344b 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -37,10 +37,10 @@ import Data.Functor (($>)) import Data.Functor.Identity (Identity(..), runIdentity) import Data.List (groupBy, sortOn) import Data.Maybe (mapMaybe, listToMaybe) -import qualified Data.Map as M +import Data.Map qualified as M import Data.Ord (Down(..)) -import qualified Language.PureScript.Constants.Libs as C +import Language.PureScript.Constants.Libs qualified as C -- | -- Removes unary negation operators and replaces them with calls to `negate`. diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index 0d7fdaaa8f..fe65bb342b 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -9,12 +9,12 @@ import Data.Either (rights) import Data.Functor.Identity import Data.List (sortOn) import Data.Maybe (mapMaybe, fromJust) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as M +import Data.List.NonEmpty qualified as NEL +import Data.Map qualified as M -import qualified Text.Parsec as P -import qualified Text.Parsec.Pos as P -import qualified Text.Parsec.Expr as P +import Text.Parsec qualified as P +import Text.Parsec.Pos qualified as P +import Text.Parsec.Expr qualified as P import Language.PureScript.AST import Language.PureScript.Crash diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index a53390b99e..efb3842bfd 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -5,8 +5,8 @@ import Prelude import Control.Monad.Except import Data.Functor.Identity -import qualified Text.Parsec as P -import qualified Text.Parsec.Expr as P +import Text.Parsec qualified as P +import Text.Parsec.Expr qualified as P import Language.PureScript.AST import Language.PureScript.Names diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 28c633dfe5..9a279ba375 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -10,30 +10,30 @@ module Language.PureScript.Sugar.TypeClasses import Prelude -import Control.Arrow (first, second) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State -import Control.Monad.Supply.Class -import Data.Graph -import Data.List (find, partition) -import Data.List.NonEmpty (nonEmpty) -import qualified Data.Map as M -import Data.Maybe (catMaybes, mapMaybe, isJust) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Set as S -import Data.Text (Text) -import Data.Traversable (for) -import qualified Language.PureScript.Constants.Prim as C -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Errors hiding (isExported, nonEmpty) -import Language.PureScript.Externs -import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names -import Language.PureScript.PSString (mkString) -import Language.PureScript.Sugar.CaseDeclarations -import Language.PureScript.TypeClassDictionaries (superclassName) -import Language.PureScript.Types +import Control.Arrow (first, second) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State +import Control.Monad.Supply.Class +import Data.Graph +import Data.List (find, partition) +import Data.List.NonEmpty (nonEmpty) +import Data.Map qualified as M +import Data.Maybe (catMaybes, mapMaybe, isJust) +import Data.List.NonEmpty qualified as NEL +import Data.Set qualified as S +import Data.Text (Text) +import Data.Traversable (for) +import Language.PureScript.Constants.Prim qualified as C +import Language.PureScript.Crash +import Language.PureScript.Environment +import Language.PureScript.Errors hiding (isExported, nonEmpty) +import Language.PureScript.Externs +import Language.PureScript.Label (Label(..)) +import Language.PureScript.Names +import Language.PureScript.PSString (mkString) +import Language.PureScript.Sugar.CaseDeclarations +import Language.PureScript.TypeClassDictionaries (superclassName) +import Language.PureScript.Types type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 2389831c1e..622d872874 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -1,22 +1,22 @@ -- | This module implements the generic deriving elaboration that takes place during desugaring. module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where -import Prelude -import Protolude (note) - -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class (MonadSupply) -import Data.List (foldl', find, unzip5) -import Language.PureScript.AST -import Language.PureScript.AST.Utils -import qualified Language.PureScript.Constants.Libs as Libs -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.PSString (mkString) -import Language.PureScript.Types -import Language.PureScript.TypeChecker (checkNewtype) +import Prelude +import Protolude (note) + +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class (MonadSupply) +import Data.List (foldl', find, unzip5) +import Language.PureScript.AST +import Language.PureScript.AST.Utils +import Language.PureScript.Constants.Libs qualified as Libs +import Language.PureScript.Crash +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Names +import Language.PureScript.PSString (mkString) +import Language.PureScript.Types +import Language.PureScript.TypeChecker (checkNewtype) -- | Elaborates deriving instance declarations by code generation. deriveInstances diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index e08be7b998..dec85ada99 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -22,14 +22,14 @@ import Data.List (nub, nubBy, (\\), sort, group) import Data.Maybe import Data.Either (partitionEithers) import Data.Text (Text) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Text as T +import Data.List.NonEmpty qualified as NEL +import Data.Map qualified as M +import Data.Set qualified as S +import Data.Text qualified as T import Language.PureScript.AST import Language.PureScript.AST.Declarations.ChainId (ChainId) -import qualified Language.PureScript.Constants.Libs as Libs +import Language.PureScript.Constants.Libs qualified as Libs import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index 8261802178..3381cd649f 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -12,14 +12,14 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Align (align, unalign) import Data.Foldable (foldl1, foldr1) import Data.List (init, last, zipWith3, (!!)) -import qualified Data.Map as M +import Data.Map qualified as M import Data.These (These(..), mergeTheseWith, these) import Control.Monad.Supply.Class import Language.PureScript.AST import Language.PureScript.AST.Utils -import qualified Language.PureScript.Constants.Libs as Libs -import qualified Language.PureScript.Constants.Prim as Prim +import Language.PureScript.Constants.Libs qualified as Libs +import Language.PureScript.Constants.Prim qualified as Prim import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors hiding (nonEmpty) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 393f637b6a..bf775042c7 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -25,13 +25,13 @@ import Data.Function (on) import Data.Functor (($>)) import Data.List (delete, findIndices, minimumBy, nubBy, sortOn, tails) import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) -import qualified Data.Map as M -import qualified Data.Set as S +import Data.Map qualified as M +import Data.Set qualified as S import Data.Traversable (for) import Data.Text (Text, stripPrefix, stripSuffix) -import qualified Data.Text as T +import Data.Text qualified as T import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NEL +import Data.List.NonEmpty qualified as NEL import Language.PureScript.AST import Language.PureScript.Crash @@ -48,8 +48,8 @@ import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types import Language.PureScript.Label (Label(..)) import Language.PureScript.PSString (PSString, mkString, decodeString) -import qualified Language.PureScript.Constants.Libs as C -import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.Constants.Libs qualified as C +import Language.PureScript.Constants.Prim qualified as C -- | Describes what sort of dictionary to generate for type class instances data Evidence diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 301e4b6e8d..648a3aa696 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -32,8 +32,8 @@ import Data.Maybe (fromMaybe, isJust) import Data.Monoid (Any(..)) import Data.Text (Text) -import qualified Data.Map as M -import qualified Data.Set as S +import Data.Map qualified as M +import Data.Set qualified as S import Language.PureScript.Crash import Language.PureScript.Environment @@ -46,7 +46,7 @@ import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.TypeChecker.Unify import Language.PureScript.Roles import Language.PureScript.Types -import qualified Language.PureScript.Constants.Prim as Prim +import Language.PureScript.Constants.Prim qualified as Prim -- | State of the given constraints solver. data GivenSolverState = diff --git a/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs b/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs index fb21d989b4..802e9d611e 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs @@ -6,12 +6,12 @@ module Language.PureScript.TypeChecker.Entailment.IntCompare where import Protolude -import qualified Data.Graph as G -import qualified Data.Map as M +import Data.Graph qualified as G +import Data.Map qualified as M -import qualified Language.PureScript.Names as P -import qualified Language.PureScript.Types as P -import qualified Language.PureScript.Constants.Prim as P +import Language.PureScript.Names qualified as P +import Language.PureScript.Types qualified as P +import Language.PureScript.Constants.Prim qualified as P data Relation a = Equal a a diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 56dc95aa06..fe1a582b4d 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -39,16 +39,16 @@ import Data.Bitraversable (bitraverse) import Data.Foldable (for_, traverse_) import Data.Function (on) import Data.Functor (($>)) -import qualified Data.IntSet as IS +import Data.IntSet qualified as IS import Data.List (nubBy, sortOn, (\\)) -import qualified Data.Map as M +import Data.Map qualified as M import Data.Maybe (fromJust, fromMaybe) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Traversable (for) import Language.PureScript.Crash -import qualified Language.PureScript.Environment as E +import Language.PureScript.Environment qualified as E import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.TypeChecker.Monad diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 7db6cbeb5e..fb02264de5 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -13,10 +13,10 @@ import Control.Monad.State import Control.Monad.Writer.Class (MonadWriter(..), censor) import Data.Maybe -import qualified Data.Map as M -import qualified Data.Set as S +import Data.Map qualified as M +import Data.Set qualified as S import Data.Text (Text, isPrefixOf, unpack) -import qualified Data.List.NonEmpty as NEL +import Data.List.NonEmpty qualified as NEL import Language.PureScript.Crash (internalError) import Language.PureScript.Environment diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index effb5c265a..885d3f8c11 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -18,9 +18,9 @@ import Control.Monad (unless, when, zipWithM_) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State (MonadState(..), runState, state) import Data.Coerce (coerce) -import qualified Data.Map as M +import Data.Map qualified as M import Data.Maybe (fromMaybe) -import qualified Data.Set as S +import Data.Set qualified as S import Data.Semigroup (Any(..)) import Data.Text (Text) diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 80e1407f31..90e6da28f6 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -10,18 +10,18 @@ module Language.PureScript.TypeChecker.Synonyms , replaceAllTypeSynonymsM ) where -import Prelude +import Prelude -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State -import Data.Maybe (fromMaybe) -import qualified Data.Map as M -import Data.Text (Text) -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.TypeChecker.Monad -import Language.PureScript.Types +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State +import Data.Maybe (fromMaybe) +import Data.Map qualified as M +import Data.Text (Text) +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Names +import Language.PureScript.TypeChecker.Monad +import Language.PureScript.Types -- | Type synonym information (arguments with kinds, aliased type), indexed by name type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType) diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index 6a8afa685c..5b40636ece 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -2,26 +2,26 @@ module Language.PureScript.TypeChecker.TypeSearch ( typeSearch ) where -import Protolude - -import Control.Monad.Writer (WriterT, runWriterT) -import qualified Data.Map as Map -import qualified Language.PureScript.TypeChecker.Entailment as Entailment - -import qualified Language.PureScript.TypeChecker.Monad as TC -import Language.PureScript.TypeChecker.Subsumption -import Language.PureScript.TypeChecker.Unify as P - -import Control.Monad.Supply as P -import Language.PureScript.AST as P -import Language.PureScript.Environment as P -import Language.PureScript.Errors as P -import Language.PureScript.Label -import Language.PureScript.Names as P -import Language.PureScript.Pretty.Types as P -import Language.PureScript.TypeChecker.Skolems as Skolem -import Language.PureScript.TypeChecker.Synonyms as P -import Language.PureScript.Types as P +import Protolude + +import Control.Monad.Writer (WriterT, runWriterT) +import Data.Map qualified as Map +import Language.PureScript.TypeChecker.Entailment qualified as Entailment + +import Language.PureScript.TypeChecker.Monad qualified as TC +import Language.PureScript.TypeChecker.Subsumption +import Language.PureScript.TypeChecker.Unify as P + +import Control.Monad.Supply as P +import Language.PureScript.AST as P +import Language.PureScript.Environment as P +import Language.PureScript.Errors as P +import Language.PureScript.Label +import Language.PureScript.Names as P +import Language.PureScript.Pretty.Types as P +import Language.PureScript.TypeChecker.Skolems as Skolem +import Language.PureScript.TypeChecker.Synonyms as P +import Language.PureScript.Types as P checkInEnvironment :: Environment diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 9e9bc44443..7947a4d2f2 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -40,10 +40,10 @@ import Data.List (transpose, (\\), partition, delete) import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Traversable (for) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.IntSet as IS +import Data.List.NonEmpty qualified as NEL +import Data.Map qualified as M +import Data.Set qualified as S +import Data.IntSet qualified as IS import Language.PureScript.AST import Language.PureScript.Crash diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 1d59876d88..98af9804da 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -23,11 +23,11 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Foldable (traverse_) import Data.Maybe (fromMaybe) -import qualified Data.Map as M -import qualified Data.Text as T +import Data.Map qualified as M +import Data.Text qualified as T import Language.PureScript.Crash -import qualified Language.PureScript.Environment as E +import Language.PureScript.Environment qualified as E import Language.PureScript.Errors import Language.PureScript.TypeChecker.Kinds (elaborateKind, instantiateKind, unifyKinds') import Language.PureScript.TypeChecker.Monad diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index b9f2463aab..2f11ea4062 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -13,18 +13,18 @@ import Control.DeepSeq (NFData) import Control.Lens (Lens', (^.), set) import Control.Monad ((<=<), (>=>)) import Data.Aeson ((.:), (.:?), (.!=), (.=)) -import qualified Data.Aeson as A -import qualified Data.Aeson.Types as A +import Data.Aeson qualified as A +import Data.Aeson.Types qualified as A import Data.Foldable (fold, foldl') -import qualified Data.IntSet as IS +import Data.IntSet qualified as IS import Data.List (sortOn) import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import GHC.Generics (Generic) import Language.PureScript.AST.SourcePos -import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.Names import Language.PureScript.Label (Label) import Language.PureScript.PSString (PSString) diff --git a/src/System/IO/UTF8.hs b/src/System/IO/UTF8.hs index d999b0969b..9ac916cf93 100644 --- a/src/System/IO/UTF8.hs +++ b/src/System/IO/UTF8.hs @@ -2,13 +2,13 @@ module System.IO.UTF8 where import Prelude -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Search as BSS -import qualified Data.ByteString.UTF8 as UTF8 -import Data.Text (Text) -import qualified Data.Text.Encoding as TE -import Protolude (ordNub) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.ByteString.Search qualified as BSS +import Data.ByteString.UTF8 qualified as UTF8 +import Data.Text (Text) +import Data.Text.Encoding qualified as TE +import Protolude (ordNub) -- | Unfortunately ByteString's readFile does not convert line endings on -- Windows, so we have to do it ourselves diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs index d8704ed78a..3b838badb7 100644 --- a/tests/Language/PureScript/Ide/CompletionSpec.hs +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -2,11 +2,11 @@ module Language.PureScript.Ide.CompletionSpec where import Protolude -import qualified Language.PureScript as P +import Language.PureScript qualified as P import Language.PureScript.Ide.Test as Test import Language.PureScript.Ide.Command as Command import Language.PureScript.Ide.Completion -import qualified Language.PureScript.Ide.Filter.Declaration as DeclarationType +import Language.PureScript.Ide.Filter.Declaration qualified as DeclarationType import Language.PureScript.Ide.Types import Test.Hspec diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index 2e4eb1f698..2ead8749d8 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -1,15 +1,15 @@ module Language.PureScript.Ide.FilterSpec where -import Protolude -import qualified Data.Map as Map -import qualified Data.Set as Set -import Language.PureScript.Ide.Filter -import Language.PureScript.Ide.Filter.Declaration as D -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Imports -import Language.PureScript.Ide.Test as T -import qualified Language.PureScript as P -import Test.Hspec +import Protolude +import Data.Map qualified as Map +import Data.Set qualified as Set +import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Filter.Declaration as D +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Imports +import Language.PureScript.Ide.Test as T +import Language.PureScript qualified as P +import Test.Hspec type Module = (P.ModuleName, [IdeDeclarationAnn]) diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index 91c51c7045..a060ca3edf 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -1,19 +1,19 @@ module Language.PureScript.Ide.ImportsSpec where -import Protolude hiding (moduleName) -import Data.Maybe (fromJust) -import qualified Data.Set as Set +import Protolude hiding (moduleName) +import Data.Maybe (fromJust) +import Data.Set qualified as Set -import qualified Language.PureScript as P -import Language.PureScript.Ide.Command as Command -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Imports -import Language.PureScript.Ide.Imports.Actions -import Language.PureScript.Ide.Filter (moduleFilter) -import qualified Language.PureScript.Ide.Test as Test -import Language.PureScript.Ide.Types -import System.FilePath -import Test.Hspec +import Language.PureScript qualified as P +import Language.PureScript.Ide.Command as Command +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Imports +import Language.PureScript.Ide.Imports.Actions +import Language.PureScript.Ide.Filter (moduleFilter) +import Language.PureScript.Ide.Test qualified as Test +import Language.PureScript.Ide.Types +import System.FilePath +import Test.Hspec noImportsFile :: [Text] noImportsFile = diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs index f792c4ce94..90b1a8dd4d 100644 --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -1,12 +1,12 @@ module Language.PureScript.Ide.MatcherSpec where -import Protolude +import Protolude -import qualified Language.PureScript as P -import Language.PureScript.Ide.Matcher -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util -import Test.Hspec +import Language.PureScript qualified as P +import Language.PureScript.Ide.Matcher +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util +import Test.Hspec value :: Text -> IdeDeclarationAnn value s = withEmptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.srcREmpty)) diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index 6f32c3e112..24364f2310 100644 --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -1,18 +1,18 @@ module Language.PureScript.Ide.RebuildSpec where -import Protolude +import Protolude -import qualified Data.Set as Set -import qualified Language.PureScript as P -import Language.PureScript.AST.SourcePos (spanName) -import Language.PureScript.Ide.Command -import Language.PureScript.Ide.Completion -import Language.PureScript.Ide.Matcher -import Language.PureScript.Ide.Types -import qualified Language.PureScript.Ide.Test as Test -import System.FilePath -import System.Directory (doesFileExist, removePathForcibly) -import Test.Hspec +import Data.Set qualified as Set +import Language.PureScript qualified as P +import Language.PureScript.AST.SourcePos (spanName) +import Language.PureScript.Ide.Command +import Language.PureScript.Ide.Completion +import Language.PureScript.Ide.Matcher +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Test qualified as Test +import System.FilePath +import System.Directory (doesFileExist, removePathForcibly) +import Test.Hspec defaultTarget :: Set P.CodegenTarget defaultTarget = Set.singleton P.JS diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index cbc2e6e88d..fced678692 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -1,13 +1,13 @@ module Language.PureScript.Ide.ReexportsSpec where -import Protolude - -import qualified Data.Map as Map -import Language.PureScript.Ide.Reexports -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Test -import qualified Language.PureScript as P -import Test.Hspec +import Protolude + +import Data.Map qualified as Map +import Language.PureScript.Ide.Reexports +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Test +import Language.PureScript qualified as P +import Test.Hspec valueA, typeA, synonymA, classA, dtorA1, dtorA2, kindA :: IdeDeclarationAnn valueA = ideValue "valueA" Nothing diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index a196f50484..12c8e8d234 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -1,13 +1,13 @@ module Language.PureScript.Ide.SourceFileSpec where -import Protolude +import Protolude -import qualified Language.PureScript as P -import Language.PureScript.Ide.Command -import Language.PureScript.Ide.SourceFile -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Test -import Test.Hspec +import Language.PureScript qualified as P +import Language.PureScript.Ide.Command +import Language.PureScript.Ide.SourceFile +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Test +import Test.Hspec span1, span2 :: P.SourceSpan span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2) diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index 9ba778650b..2c28dc22d3 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -1,13 +1,13 @@ module Language.PureScript.Ide.StateSpec where -import Protolude -import Control.Lens hiding (anyOf, (&)) -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Test -import qualified Language.PureScript as P -import Test.Hspec -import qualified Data.Map as Map +import Protolude +import Control.Lens hiding (anyOf, (&)) +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.State +import Language.PureScript.Ide.Test +import Language.PureScript qualified as P +import Test.Hspec +import Data.Map qualified as Map valueOperator :: Maybe P.SourceType -> IdeDeclarationAnn valueOperator = diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index 923bc38bf8..d9b58ca091 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -1,20 +1,20 @@ {-# LANGUAGE PackageImports #-} module Language.PureScript.Ide.Test where -import Control.Concurrent.STM -import "monad-logger" Control.Monad.Logger -import Data.IORef -import qualified Data.Map as Map -import Language.PureScript.Ide -import Language.PureScript.Ide.Command -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Types -import Protolude -import System.Directory -import System.FilePath -import System.Process - -import qualified Language.PureScript as P +import Control.Concurrent.STM +import "monad-logger" Control.Monad.Logger +import Data.IORef +import Data.Map qualified as Map +import Language.PureScript.Ide +import Language.PureScript.Ide.Command +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Types +import Protolude +import System.Directory +import System.FilePath +import System.Process + +import Language.PureScript qualified as P defConfig :: IdeConfiguration defConfig = diff --git a/tests/Language/PureScript/Ide/UsageSpec.hs b/tests/Language/PureScript/Ide/UsageSpec.hs index 51f3f7ac63..97c5c379d7 100644 --- a/tests/Language/PureScript/Ide/UsageSpec.hs +++ b/tests/Language/PureScript/Ide/UsageSpec.hs @@ -1,15 +1,15 @@ module Language.PureScript.Ide.UsageSpec where -import Protolude +import Protolude -import qualified Data.Text as Text -import Language.PureScript.Ide.Command -import Language.PureScript.Ide.Types -import qualified Language.PureScript.Ide.Test as Test -import qualified Language.PureScript as P -import Test.Hspec -import Data.Text.Read (decimal) -import System.FilePath +import Data.Text qualified as Text +import Language.PureScript.Ide.Command +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Test qualified as Test +import Language.PureScript qualified as P +import Test.Hspec +import Data.Text.Read (decimal) +import System.FilePath load :: [Text] -> Command load = LoadSync . map Test.mn diff --git a/tests/Main.hs b/tests/Main.hs index 4063bab544..b8f6ea979e 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -6,21 +6,21 @@ import Prelude import Test.Hspec -import qualified TestAst -import qualified TestCompiler -import qualified TestCoreFn -import qualified TestCst -import qualified TestDocs -import qualified TestHierarchy -import qualified TestPrimDocs -import qualified TestPsci -import qualified TestIde -import qualified TestPscPublish -import qualified TestSourceMaps --- import qualified TestBundle -import qualified TestMake -import qualified TestUtils -import qualified TestGraph +import TestAst qualified +import TestCompiler qualified +import TestCoreFn qualified +import TestCst qualified +import TestDocs qualified +import TestHierarchy qualified +import TestPrimDocs qualified +import TestPsci qualified +import TestIde qualified +import TestPscPublish qualified +import TestSourceMaps qualified +-- import TestBundle qualified +import TestMake qualified +import TestUtils qualified +import TestGraph qualified import System.IO (hSetEncoding, stdout, stderr, utf8) diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 484bc8c3c3..8a08024ceb 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -24,16 +24,16 @@ module TestCompiler where import Prelude -import qualified Language.PureScript as P +import Language.PureScript qualified as P import Language.PureScript.Interactive.IO (readNodeProcessWithExitCode) import Control.Arrow ((>>>)) -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS import Data.Function (on) import Data.List (sort, stripPrefix, minimumBy) import Data.Maybe (mapMaybe) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Control.Monad diff --git a/tests/TestCst.hs b/tests/TestCst.hs index fb62f768e7..b051d540a0 100644 --- a/tests/TestCst.hs +++ b/tests/TestCst.hs @@ -5,9 +5,9 @@ import Prelude import Control.Monad (when, forM_) import Data.Maybe (fromMaybe) import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Text.IO as Text +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Text.IO qualified as Text import Test.Hspec import Test.QuickCheck import TestUtils diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index cecd6c0e8f..4e9dcad8e4 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -6,17 +6,17 @@ import Data.Bifunctor (first) import Data.List (findIndex) import Data.Foldable import Safe (headMay) -import qualified Data.Map as Map +import Data.Map qualified as Map import Data.Maybe (fromMaybe, isNothing, mapMaybe) import Data.Monoid import Data.Text (Text) -import qualified Data.Text as T -import qualified Text.PrettyPrint.Boxes as Boxes +import Data.Text qualified as T +import Text.PrettyPrint.Boxes qualified as Boxes -import qualified Language.PureScript as P -import qualified Language.PureScript.Docs as Docs +import Language.PureScript qualified as P +import Language.PureScript.Docs qualified as Docs import Language.PureScript.Docs.AsMarkdown (codeToString) -import qualified Language.PureScript.Publish.ErrorsWarnings as Publish +import Language.PureScript.Publish.ErrorsWarnings qualified as Publish import Web.Bower.PackageMeta (parsePackageName, runPackageName) diff --git a/tests/TestGraph.hs b/tests/TestGraph.hs index 8e7d6cb0f6..92233b439a 100644 --- a/tests/TestGraph.hs +++ b/tests/TestGraph.hs @@ -5,8 +5,8 @@ import Prelude import Test.Hspec import Data.Either (isLeft) -import qualified Data.Aeson as Json -import qualified Language.PureScript as P +import Data.Aeson qualified as Json +import Language.PureScript qualified as P spec :: Spec spec = do diff --git a/tests/TestHierarchy.hs b/tests/TestHierarchy.hs index 7d6559bf2a..18832a8d7c 100644 --- a/tests/TestHierarchy.hs +++ b/tests/TestHierarchy.hs @@ -3,7 +3,7 @@ module TestHierarchy where import Prelude import Language.PureScript.Hierarchy -import qualified Language.PureScript as P +import Language.PureScript qualified as P import Test.Hspec diff --git a/tests/TestIde.hs b/tests/TestIde.hs index 2ed41af7ff..1d505456c9 100644 --- a/tests/TestIde.hs +++ b/tests/TestIde.hs @@ -1,11 +1,11 @@ module TestIde where -import Prelude +import Prelude -import Control.Monad (unless) -import Language.PureScript.Ide.Test -import qualified PscIdeSpec -import Test.Hspec +import Control.Monad (unless) +import Language.PureScript.Ide.Test +import PscIdeSpec qualified +import Test.Hspec spec :: Spec spec = diff --git a/tests/TestMake.hs b/tests/TestMake.hs index 7e41411e95..051abb373d 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -5,8 +5,8 @@ module TestMake where import Prelude -import qualified Language.PureScript as P -import qualified Language.PureScript.CST as CST +import Language.PureScript qualified as P +import Language.PureScript.CST qualified as CST import Control.Concurrent (threadDelay) import Control.Monad @@ -15,10 +15,10 @@ import Control.Monad.IO.Class (liftIO) import Control.Concurrent.MVar (readMVar, newMVar, modifyMVar_) import Data.Time.Calendar import Data.Time.Clock -import qualified Data.Text as T +import Data.Text qualified as T import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Map as M +import Data.Set qualified as Set +import Data.Map qualified as M import System.FilePath import System.Directory diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index 4a4eeee53d..d59232f6b6 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -5,10 +5,10 @@ import Prelude import Data.List (sort) import Control.Exception (evaluate) import Control.DeepSeq (force) -import qualified Data.Map as Map -import qualified Data.Text as Text -import qualified Language.PureScript as P -import qualified Language.PureScript.Docs as D +import Data.Map qualified as Map +import Data.Text qualified as Text +import Language.PureScript qualified as P +import Language.PureScript.Docs qualified as D import Test.Hspec diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 86c5b3b116..dcd621946e 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -7,18 +7,18 @@ import Control.Monad (void, guard) import Control.Monad.IO.Class (liftIO) import Data.ByteString.Lazy (ByteString) import Data.Time.Clock (getCurrentTime) -import qualified Data.Aeson as A +import Data.Aeson qualified as A import Data.Version import Data.Foldable (forM_) -import qualified Text.PrettyPrint.Boxes as Boxes +import Text.PrettyPrint.Boxes qualified as Boxes import System.Directory (listDirectory, removeDirectoryRecursive) import System.FilePath (()) import System.IO.Error (isDoesNotExistError) import Language.PureScript.Docs import Language.PureScript.Publish (PublishOptions(..), defaultPublishOptions) -import qualified Language.PureScript.Publish as Publish -import qualified Language.PureScript.Publish.ErrorsWarnings as Publish +import Language.PureScript.Publish qualified as Publish +import Language.PureScript.Publish.ErrorsWarnings qualified as Publish import Test.Hspec import TestUtils hiding (inferForeignModules, makeActions) diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index 20bc64c843..0305d703fa 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -4,14 +4,14 @@ import Prelude import Test.Hspec -import Control.Monad.Trans.State.Strict (evalStateT) -import Data.Functor ((<&>)) -import Data.List (sort) -import qualified Data.Text as T -import qualified Language.PureScript as P -import Language.PureScript.Interactive -import TestPsci.TestEnv (initTestPSCiEnv) -import TestUtils (getSupportModuleNames) +import Control.Monad.Trans.State.Strict (evalStateT) +import Data.Functor ((<&>)) +import Data.List (sort) +import Data.Text qualified as T +import Language.PureScript qualified as P +import Language.PureScript.Interactive +import TestPsci.TestEnv (initTestPSCiEnv) +import TestUtils (getSupportModuleNames) completionTests :: Spec completionTests = context "completionTests" $ diff --git a/tests/TestPsci/EvalTest.hs b/tests/TestPsci/EvalTest.hs index 622208d9c5..61323ec6ea 100644 --- a/tests/TestPsci/EvalTest.hs +++ b/tests/TestPsci/EvalTest.hs @@ -2,17 +2,17 @@ module TestPsci.EvalTest where import Prelude -import Control.Monad (forM_, foldM_) -import Control.Monad.IO.Class (liftIO) -import Data.List (stripPrefix, intercalate) -import Data.List.Split (splitOn) -import System.Directory (getCurrentDirectory) -import System.Exit (exitFailure) -import System.FilePath ((), takeFileName) -import qualified System.FilePath.Glob as Glob -import System.IO.UTF8 (readUTF8File) -import Test.Hspec -import TestPsci.TestEnv +import Control.Monad (forM_, foldM_) +import Control.Monad.IO.Class (liftIO) +import Data.List (stripPrefix, intercalate) +import Data.List.Split (splitOn) +import System.Directory (getCurrentDirectory) +import System.Exit (exitFailure) +import System.FilePath ((), takeFileName) +import System.FilePath.Glob qualified as Glob +import System.IO.UTF8 (readUTF8File) +import Test.Hspec +import TestPsci.TestEnv evalTests :: Spec evalTests = context "evalTests" $ do diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index bf0ccf8a70..b255052656 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -2,21 +2,21 @@ module TestPsci.TestEnv where import Prelude -import Control.Exception.Lifted (bracket_) -import Control.Monad (void, when) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.RWS.Strict (evalRWST, asks, local, RWST) -import Data.Foldable (traverse_) -import Data.List (isSuffixOf) -import qualified Data.Text as T -import qualified Language.PureScript as P -import qualified Language.PureScript.CST as CST -import Language.PureScript.Interactive -import System.Directory (getCurrentDirectory, doesPathExist, removeFile) -import System.Exit -import System.FilePath ((), pathSeparator) -import qualified System.FilePath.Glob as Glob -import Test.Hspec (shouldBe, Expectation) +import Control.Exception.Lifted (bracket_) +import Control.Monad (void, when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.RWS.Strict (evalRWST, asks, local, RWST) +import Data.Foldable (traverse_) +import Data.List (isSuffixOf) +import Data.Text qualified as T +import Language.PureScript qualified as P +import Language.PureScript.CST qualified as CST +import Language.PureScript.Interactive +import System.Directory (getCurrentDirectory, doesPathExist, removeFile) +import System.Exit +import System.FilePath ((), pathSeparator) +import System.FilePath.Glob qualified as Glob +import Test.Hspec (shouldBe, Expectation) -- | A monad transformer for handle PSCi actions in tests type TestPSCi a = RWST PSCiConfig () PSCiState IO a diff --git a/tests/TestSourceMaps.hs b/tests/TestSourceMaps.hs index ff8e7f26be..178680a4db 100644 --- a/tests/TestSourceMaps.hs +++ b/tests/TestSourceMaps.hs @@ -6,12 +6,12 @@ import Control.Monad (void, forM_) import Data.Aeson as Json import Test.Hspec import System.FilePath (replaceExtension, takeFileName, (), (<.>)) -import qualified Language.PureScript as P -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS +import Language.PureScript qualified as P +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS import Data.Foldable (fold) import TestUtils (getTestFiles, SupportModules (..), compile', ExpectedModuleName (IsSourceMap)) -import qualified Data.Set as Set +import Data.Set qualified as Set import TestCompiler (getTestMain) import System.Process.Typed (proc, readProcess_) diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 896c42866c..6a313c1a47 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -2,10 +2,10 @@ module TestUtils where import Prelude -import qualified Language.PureScript as P -import qualified Language.PureScript.CST as CST -import qualified Language.PureScript.AST as AST -import qualified Language.PureScript.Names as N +import Language.PureScript qualified as P +import Language.PureScript.CST qualified as CST +import Language.PureScript.AST qualified as AST +import Language.PureScript.Names qualified as N import Language.PureScript.Interactive.IO (findNodeProcess) import Control.Arrow ((***), (>>>)) @@ -16,14 +16,14 @@ import Control.Monad.Trans.Maybe import Control.Monad.Writer.Class (tell) import Control.Exception import Data.ByteString (ByteString) -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS import Data.Char (isSpace) import Data.Function (on) import Data.List (sort, sortBy, stripPrefix, groupBy, find) -import qualified Data.Map as M +import Data.Map qualified as M import Data.Maybe (isJust) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Data.Time.Clock (UTCTime(), diffUTCTime, getCurrentTime, nominalDay) import Data.Tuple (swap) import System.Directory @@ -33,7 +33,7 @@ import System.FilePath import System.IO.Error (isDoesNotExistError) import System.IO.UTF8 (readUTF8FileT) import System.Process hiding (cwd) -import qualified System.FilePath.Glob as Glob +import System.FilePath.Glob qualified as Glob import System.IO import Test.Hspec From 4754e8c9e4a50c643910d09ba2a5716a5e33ca2b Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Tue, 21 Mar 2023 07:25:54 +0200 Subject: [PATCH 1535/1580] Add ARM64 builds/releases for Linux and macOS (#4455) --- .github/workflows/ci.yml | 54 +++++++++++++++++++++++-------- CHANGELOG.d/feature_arm_builds.md | 1 + 2 files changed, 41 insertions(+), 14 deletions(-) create mode 100644 CHANGELOG.d/feature_arm_builds.md diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 6500158fa6..6cee437bc1 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -13,7 +13,7 @@ defaults: shell: "bash" env: - CI_PRERELEASE: "${{ github.event_name == 'push' }}" + CI_PRERELEASE: "${{ github.event_name == 'push' && github.ref == 'refs/heads/master' }}" CI_RELEASE: "${{ github.event_name == 'release' }}" STACK_VERSION: "2.9.3" @@ -37,10 +37,12 @@ jobs: matrix: include: - # If upgrading the Haskell image, also upgrade it in the lint job below - os: "ubuntu-latest" + os: ["ubuntu-latest"] image: haskell:9.2.5@sha256:2597b0e2458165a6635906204f7fac43c22e7d2a46aca1235a811194bb6cd419 - - os: "macOS-11" - - os: "windows-2019" + - os: ["macOS-11"] + - os: ["windows-2019"] + - os: ["self-hosted", "macos", "ARM64"] + - os: ["self-hosted", "Linux", "ARM64"] runs-on: "${{ matrix.os }}" container: "${{ matrix.image }}" @@ -53,20 +55,22 @@ jobs: - # We need a proper Git repository, but the checkout step will unpack a tarball instead of doing a clone # if the Git version is less than 2.18. name: "(Linux only) Install a newer version of Git" - if: "${{ runner.os == 'Linux' }}" + if: "contains(matrix.os, 'ubuntu-latest')" run: | . /etc/os-release echo deb http://deb.debian.org/debian "$VERSION_CODENAME"-backports main >> /etc/apt/sources.list apt-get update && apt-get install -y git/"$VERSION_CODENAME"-backports - uses: "actions/checkout@v2" - - uses: "actions/setup-node@v2" with: - node-version: "14" + node-version: "16" - id: "haskell" name: "(Non-Linux only) Install Haskell" - if: "${{ runner.os != 'Linux' }}" + # Note: here we exclude the self-hosted runners because this action does not work on ARM + # and their Haskell environment is instead provided by a nix-shell + # See https://github.com/purescript/purescript/pulls/4455 + if: "!contains(matrix.os, 'ubuntu-latest') && !contains(matrix.os, 'self-hosted')" uses: "haskell/actions/setup@v1" with: enable-stack: true @@ -74,7 +78,7 @@ jobs: stack-no-global: true - name: "(Linux only) Check Stack version and fix working directory ownership" - if: "${{ runner.os == 'Linux' }}" + if: "contains(matrix.os, 'ubuntu-latest')" run: | [ "$(stack --numeric-version)" = "$STACK_VERSION" ] chown root:root . @@ -99,7 +103,7 @@ jobs: run: "ci/fix-home ci/build.sh" - name: "(Linux only) Build the entire package set" - if: "${{ runner.os == 'Linux' }}" + if: "contains(matrix.os, 'ubuntu-latest')" # We build in this directory in build.sh, so this is where we need to # launch `stack exec`. The actual package-set building happens in a # temporary directory. @@ -116,7 +120,7 @@ jobs: ../ci/fix-home stack --haddock exec ../ci/build-package-set.sh - name: Verify that 'libtinfo' isn't in binary - if: runner.os == 'Linux' + if: "runner.os == 'Linux'" working-directory: "sdist-test" run: | if [ $(ldd $(../ci/fix-home stack path --local-doc-root)/../bin/purs | grep 'libtinfo' | wc -l) -ge 1 ]; then @@ -125,15 +129,37 @@ jobs: exit 1 fi + - name: "(Self-hosted Linux ARM64 only) Patch the binary to work on non-Nix systems" + if: "runner.os == 'Linux' && runner.arch == 'ARM64'" + working-directory: "sdist-test" + # The self-hosted build happens inside a nix-shell that provides a working stack binary + # on ARM systems, and while the macOS binary is fine - because macOS binaries are almost + # statically linked), the linux ones are all pointing at the nix store. + # So here we first point the binary to the right linker that should work on a generic linux, + # and then fix the RUNPATH with the right location to load the shared libraries from + run: | + patchelf --set-interpreter /usr/lib/ld-linux-aarch64.so.1 --set-rpath /usr/lib/aarch64-linux-gnu $(stack path --local-doc-root)/../bin/purs + - name: "(Release/prerelease only) Create bundle" if: "${{ env.CI_RELEASE == 'true' || env.CI_PRERELEASE == 'true' && steps.build.outputs.do-not-prerelease != 'true' }}" run: | os_name="${{ runner.os }}" + os_arch="${{ runner.arch }}" case "$os_name" in Linux) - bundle_os=linux64;; + case "$os_arch" in + ARM64) + bundle_os=linux-arm64;; + *) + bundle_os=linux64;; + esac;; macOS) - bundle_os=macos;; + case "$os_arch" in + ARM64) + bundle_os=macos-arm64;; + *) + bundle_os=macos;; + esac;; Windows) bundle_os=win64;; *) @@ -147,7 +173,7 @@ jobs: if: "${{ env.CI_PRERELEASE == 'true' && steps.build.outputs.do-not-prerelease != 'true' }}" uses: "actions/upload-artifact@v3" with: - name: "${{ runner.os }}-bundle" + name: "${{ runner.os }}-${{ runner.arch }}-bundle" path: | sdist-test/bundle/*.sha sdist-test/bundle/*.tar.gz diff --git a/CHANGELOG.d/feature_arm_builds.md b/CHANGELOG.d/feature_arm_builds.md new file mode 100644 index 0000000000..7429fe3445 --- /dev/null +++ b/CHANGELOG.d/feature_arm_builds.md @@ -0,0 +1 @@ +* Add release artifacts for Linux and macOS running on the ARM64 architecture. From 94ef29e853a0f5ba22a1b0c10be4e14e47da14c0 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Tue, 21 Mar 2023 04:31:54 -0400 Subject: [PATCH 1536/1580] Require comments not to cause Haddock warnings (#4456) --- CHANGELOG.d/internal_no-haddock-warnings.md | 1 + ci/build.sh | 4 ++- src/Language/PureScript/AST/Declarations.hs | 4 +-- src/Language/PureScript/CodeGen/JS.hs | 36 +++++++++---------- src/Language/PureScript/CoreFn/Desugar.hs | 18 +++++----- .../PureScript/CoreImp/Optimizer/TCO.hs | 4 +-- src/Language/PureScript/Docs/Convert.hs | 4 --- src/Language/PureScript/Errors.hs | 8 ++--- .../PureScript/Ide/Imports/Actions.hs | 2 +- src/Language/PureScript/Linter/Exhaustive.hs | 2 +- src/Language/PureScript/Pretty/Common.hs | 4 --- .../PureScript/Sugar/BindingGroups.hs | 2 -- src/Language/PureScript/Sugar/LetPattern.hs | 6 ++-- src/Language/PureScript/Sugar/Operators.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 1 - src/Language/PureScript/TypeChecker.hs | 1 - .../PureScript/TypeChecker/Deriving.hs | 8 ++--- .../PureScript/TypeChecker/Entailment.hs | 25 +++++++------ src/Language/PureScript/TypeChecker/Types.hs | 10 +++--- 19 files changed, 65 insertions(+), 77 deletions(-) create mode 100644 CHANGELOG.d/internal_no-haddock-warnings.md diff --git a/CHANGELOG.d/internal_no-haddock-warnings.md b/CHANGELOG.d/internal_no-haddock-warnings.md new file mode 100644 index 0000000000..8d661b6cf6 --- /dev/null +++ b/CHANGELOG.d/internal_no-haddock-warnings.md @@ -0,0 +1 @@ +* Require comments not to cause Haddock warnings diff --git a/ci/build.sh b/ci/build.sh index a01c953c30..5bcb7d4950 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -162,7 +162,9 @@ tar -xzf sdist-test/purescript-*.tar.gz -C sdist-test --strip-components=1 (echo "::endgroup::"; echo "::group::Build and test PureScript") 2>/dev/null pushd sdist-test -$STACK build $STACK_OPTS +# Haddock -Werror goes here to keep us honest but prevent failing on +# documentation errors in dependencies +$STACK build $STACK_OPTS --haddock-arguments --optghc=-Werror popd (echo "::endgroup::") 2>/dev/null diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 22ee15ed26..8112521acd 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -42,14 +42,14 @@ data TypeSearch = TSBefore Environment -- ^ An Environment captured for later consumption by type directed search | TSAfter + -- ^ Results of applying type directed search to the previously captured + -- Environment { tsAfterIdentifiers :: [(Qualified Text, SourceType)] -- ^ The identifiers that fully satisfy the subsumption check , tsAfterRecordFields :: Maybe [(Label, SourceType)] -- ^ Record fields that are available on the first argument to the typed -- hole } - -- ^ Results of applying type directed search to the previously captured - -- Environment deriving Show onTypeSearchTypes :: (SourceType -> SourceType) -> TypeSearch -> TypeSearch diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index c801dc22d8..dae389474a 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -83,7 +83,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = return $ AST.Module header (foreign' ++ jsImports) renamedModuleBody jsExports where - -- | Adds purity annotations to top-level values for bundlers. + -- Adds purity annotations to top-level values for bundlers. -- The semantics here derive from treating top-level module evaluation as pure, which lets -- us remove any unreferenced top-level declarations. To achieve this, we wrap any non-trivial -- top-level values in an IIFE marked with a pure annotation. @@ -92,14 +92,14 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = where annotateOrWrap = liftA2 fromMaybe pureIife maybePure - -- | If the JS is potentially effectful (in the eyes of a bundler that + -- If the JS is potentially effectful (in the eyes of a bundler that -- doesn't know about PureScript), return Nothing. Otherwise, return Just -- the JS with any needed pure annotations added, and, in the case of a -- variable declaration, an IIFE to be annotated. maybePure :: AST -> Maybe AST maybePure = maybePureGen False - -- | Like maybePure, but doesn't add a pure annotation to App. This exists + -- Like maybePure, but doesn't add a pure annotation to App. This exists -- to prevent from doubling up on annotation comments on curried -- applications; from experimentation, it turns out that a comment on the -- outermost App is sufficient for the entire curried chain to be @@ -131,12 +131,12 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = pureApp :: Maybe SourceSpan -> AST -> [AST] -> AST pureApp ss f = AST.Comment AST.PureAnnotation . AST.App ss f - -- | Extracts all declaration names from a binding group. + -- Extracts all declaration names from a binding group. getNames :: Bind Ann -> [Ident] getNames (NonRec _ ident _) = [ident] getNames (Rec vals) = map (snd . fst) vals - -- | Creates alternative names for each module to ensure they don't collide + -- Creates alternative names for each module to ensure they don't collide -- with declaration names. renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName Text renameImports = go M.empty @@ -157,19 +157,19 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = then freshModuleName (i + 1) mn' used else newName - -- | Generates JavaScript code for a module import, binding the required module + -- Generates JavaScript code for a module import, binding the required module -- to the alternative importToJs :: M.Map ModuleName Text -> ModuleName -> AST.Import importToJs mnLookup mn' = let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup in AST.Import mnSafe (moduleImportPath mn') - -- | Generates JavaScript code for exporting at least one identifier, + -- Generates JavaScript code for exporting at least one identifier, -- eventually from another module. exportsToJs :: Maybe PSString -> [Ident] -> Maybe AST.Export exportsToJs from = fmap (flip AST.Export from) . NEL.nonEmpty . fmap runIdent - -- | Generates JavaScript code for re-exporting at least one identifier from + -- Generates JavaScript code for re-exporting at least one identifier from -- from another module. reExportsToJs :: (ModuleName, [Ident]) -> Maybe AST.Export reExportsToJs = uncurry exportsToJs . first (Just . moduleImportPath) @@ -177,7 +177,7 @@ moduleToJs (Module _ coms mn _ imps exps reExps foreigns decls) foreignInclude = moduleImportPath :: ModuleName -> PSString moduleImportPath mn' = fromString (".." T.unpack (runModuleName mn') "index.js") - -- | Replaces the `ModuleAccessor`s in the AST with `Indexer`s, ensuring that + -- Replaces the `ModuleAccessor`s in the AST with `Indexer`s, ensuring that -- the generated code refers to the collision-avoiding renamed module -- imports. Also returns set of used module names. replaceModuleAccessors :: M.Map ModuleName Text -> AST -> (S.Set ModuleName, AST) @@ -238,9 +238,7 @@ moduleBindToJs -> m [AST] moduleBindToJs mn = bindToJs where - -- | -- Generate code in the simplified JavaScript intermediate representation for a declaration - -- bindToJs :: Bind Ann -> m [AST] bindToJs (NonRec (_, _, _, Just IsTypeClassConstructor) _ _) = pure [] -- Unlike other newtype constructors, type class constructors are only @@ -249,7 +247,7 @@ moduleBindToJs mn = bindToJs bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val bindToJs (Rec vals) = writer (applyLazinessTransform mn vals) >>= traverse (uncurry . uncurry $ nonRecToJS) - -- | Generate code in the simplified JavaScript intermediate representation for a single non-recursive + -- Generate code in the simplified JavaScript intermediate representation for a single non-recursive -- declaration. -- -- The main purpose of this function is to handle code generation for comments. @@ -276,12 +274,12 @@ moduleBindToJs mn = bindToJs then withSourceSpan ss js else js - -- | Generate code in the simplified JavaScript intermediate representation for a variable based on a + -- Generate code in the simplified JavaScript intermediate representation for a variable based on a -- PureScript identifier. var :: Ident -> AST var = AST.Var Nothing . identToJs - -- | Generate code in the simplified JavaScript intermediate representation for a value or expression. + -- Generate code in the simplified JavaScript intermediate representation for a value or expression. valueToJs :: Expr Ann -> m AST valueToJs e = let (ss, _, _, _) = extractAnn e in @@ -364,7 +362,7 @@ moduleBindToJs mn = bindToJs literalToValueJS ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToJs xs literalToValueJS ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToJs) ps - -- | Shallow copy an object. + -- Shallow copy an object. extendObj :: AST -> [(PSString, AST)] -> m AST extendObj obj sts = do newObj <- freshName @@ -384,13 +382,13 @@ moduleBindToJs mn = bindToJs extend = map stToAssign sts return $ AST.App Nothing (AST.Function Nothing Nothing [] block) [] - -- | Generate code in the simplified JavaScript intermediate representation for a reference to a + -- Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable. varToJs :: Qualified Ident -> AST varToJs (Qualified (BySourcePos _) ident) = var ident varToJs qual = qualifiedToJS id qual - -- | Generate code in the simplified JavaScript intermediate representation for a reference to a + -- Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable that may have a qualified name. qualifiedToJS :: (a -> Ident) -> Qualified a -> AST qualifiedToJS f (Qualified (ByModuleName C.M_Prim) a) = AST.Var Nothing . runIdent $ f a @@ -400,7 +398,7 @@ moduleBindToJs mn = bindToJs foreignIdent :: Ident -> AST foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing FFINamespace) - -- | Generate code in the simplified JavaScript intermediate representation for pattern match binders + -- Generate code in the simplified JavaScript intermediate representation for pattern match binders -- and guards. bindersToJs :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST bindersToJs ss binders vals = do @@ -447,7 +445,7 @@ moduleBindToJs mn = bindToJs let (ss, _, _, _) = extractBinderAnn binder in traverse (withPos ss) =<< binderToJs' s done binder - -- | Generate code in the simplified JavaScript intermediate representation for a pattern match + -- Generate code in the simplified JavaScript intermediate representation for a pattern match -- binder. binderToJs' :: Text -> [AST] -> Binder Ann -> m [AST] binderToJs' _ done NullBinder{} = return done diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 29303e05c4..c5edfd6151 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -40,7 +40,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = decls' = concatMap declToCoreFn decls in Module modSS coms mn (spanName modSS) imports' exps' reExps externs decls' where - -- | Creates a map from a module name to the re-export references defined in + -- Creates a map from a module name to the re-export references defined in -- that module. reExportsToCoreFn :: (ModuleName, A.DeclarationRef) -> M.Map ModuleName [Ident] reExportsToCoreFn (mn', ref') = M.singleton mn' (exportToCoreFn ref') @@ -52,14 +52,14 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = (A.exportSourceImportedFrom src) toReExportRef _ = Nothing - -- | Remove duplicate imports + -- Remove duplicate imports dedupeImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)] dedupeImports = fmap swap . M.toList . M.fromListWith const . fmap swap ssA :: SourceSpan -> Ann ssA ss = (ss, [], Nothing, Nothing) - -- | Desugars member declarations from AST to CoreFn representation. + -- Desugars member declarations from AST to CoreFn representation. declToCoreFn :: A.Declaration -> [Bind Ann] declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [ctor]) = [NonRec (ss, [], Nothing, declMeta) (properToIdent $ A.dataCtorName ctor) $ @@ -82,7 +82,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = [Rec . NEL.toList $ fmap (\(((ss, com), name), _, e) -> ((ssA ss, name), exprToCoreFn ss com Nothing e)) ds] declToCoreFn _ = [] - -- | Desugars expressions from AST to CoreFn representation. + -- Desugars expressions from AST to CoreFn representation. exprToCoreFn :: SourceSpan -> [Comment] -> Maybe SourceType -> A.Expr -> Expr Ann exprToCoreFn _ com ty (A.Literal ss lit) = Literal (ss, com, ty, Nothing) (fmap (exprToCoreFn ss com Nothing) lit) @@ -131,7 +131,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = exprToCoreFn _ _ _ e = error $ "Unexpected value in exprToCoreFn mn: " ++ show e - -- | Desugars case alternatives from AST to CoreFn representation. + -- Desugars case alternatives from AST to CoreFn representation. altToCoreFn :: SourceSpan -> A.CaseAlternative -> CaseAlternative Ann altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs) where @@ -147,7 +147,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = guardToExpr [A.ConditionGuard cond] = cond guardToExpr _ = internalError "Guard not correctly desugared" - -- | Desugars case binders from AST to CoreFn representation. + -- Desugars case binders from AST to CoreFn representation. binderToCoreFn :: SourceSpan -> [Comment] -> A.Binder -> Binder Ann binderToCoreFn _ com (A.LiteralBinder ss lit) = LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit) @@ -171,19 +171,19 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = binderToCoreFn _ _ A.ParensInBinder{} = internalError "ParensInBinder should have been desugared before binderToCoreFn" - -- | Gets metadata for let bindings. + -- Gets metadata for let bindings. getLetMeta :: A.WhereProvenance -> Maybe Meta getLetMeta A.FromWhere = Just IsWhere getLetMeta A.FromLet = Nothing - -- | Gets metadata for values. + -- Gets metadata for values. getValueMeta :: Qualified Ident -> Maybe Meta getValueMeta name = case lookupValue env name of Just (_, External, _) -> Just IsForeign _ -> Nothing - -- | Gets metadata for data constructors. + -- Gets metadata for data constructors. getConstructorMeta :: Qualified (ProperName 'ConstructorName) -> Meta getConstructorMeta ctor = case lookupConstructor env ctor of diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index bd85924eae..7defbe66c3 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -40,8 +40,8 @@ tco = flip evalState 0 . everywhereTopDownM convert where innerArgs = headDef [] argss outerArgs = concat . reverse $ tailSafe argss arity = length argss - -- ^ this is the number of calls, not the number of arguments, if there's - -- ever a practical difference. + -- this is the number of calls, not the number of arguments, if there's + -- ever a practical difference. (argss, body', replace) = topCollectAllFunctionArgs [] id fn convert js = pure js diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index ce25a9102b..094577f80a 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -66,7 +66,6 @@ insertValueTypesAndAdjustKinds :: insertValueTypesAndAdjustKinds env m = m { modDeclarations = map (go . insertInferredRoles . convertFFIDecl) (modDeclarations m) } where - -- | -- Convert FFI declarations into data declaration -- by generating the type parameters' names based on its kind signature. -- Note: `Prim` modules' docs don't go through this conversion process @@ -99,7 +98,6 @@ insertValueTypesAndAdjustKinds env m = insertInferredRoles other = other - -- | -- Given an FFI declaration like this -- ``` -- foreign import data Foo @@ -171,7 +169,6 @@ insertValueTypesAndAdjustKinds env m = Nothing -> err ("name not found: " ++ show key) - -- | -- Extracts the keyword for a declaration (if there is one) extractKeyword :: DeclarationInfo -> Maybe P.KindSignatureFor extractKeyword = \case @@ -182,7 +179,6 @@ insertValueTypesAndAdjustKinds env m = TypeClassDeclaration _ _ _ -> Just P.ClassSig _ -> Nothing - -- | -- Returns True if the kind signature is "uninteresting", which -- is a kind that follows this form: -- - `Type` diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 49a4348a3b..bcdfee61d2 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1676,7 +1676,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon paras :: forall f. Foldable f => f Box.Box -> Box.Box paras = Box.vcat Box.left - -- | Simplify an error message + -- Simplify an error message simplifyErrorMessage :: ErrorMessage -> ErrorMessage simplifyErrorMessage (ErrorMessage hints simple) = ErrorMessage (simplifyHints hints) simple where @@ -1692,7 +1692,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon (_, OtherHint) -> False (c1, c2) -> c1 == c2 - -- | See https://github.com/purescript/purescript/issues/1802 + -- See https://github.com/purescript/purescript/issues/1802 stripRedundantHints :: SimpleErrorMessage -> [ErrorMessageHint] -> [ErrorMessageHint] stripRedundantHints ExprDoesNotHaveType{} = stripFirst isCheckHint where @@ -1764,7 +1764,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon Box.<> (line . displayStartEndPos . fst $ getAnnForType ty) Qualified mn (Right inst) -> line . markCode . showQualified showIdent $ Qualified mn inst - -- | As of this writing, this function assumes that all provided SourceSpans + -- As of this writing, this function assumes that all provided SourceSpans -- are non-overlapping (except for exact duplicates) and span no line breaks. A -- more sophisticated implementation without this limitation would be possible -- but isn't yet needed. @@ -1845,7 +1845,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon lineNumberStyle :: String -> Box.Box lineNumberStyle = colorCodeBox (codeColor $> (ANSI.Vivid, ANSI.Black)) . Box.alignHoriz Box.right 5 . lineS - -- | Lookup the nth element of a list, but without retraversing the list every + -- Lookup the nth element of a list, but without retraversing the list every -- time, by instead keeping a tail of the list and the current element number -- in State. Only works if the argument provided is strictly ascending over -- the life of the State. diff --git a/src/Language/PureScript/Ide/Imports/Actions.hs b/src/Language/PureScript/Ide/Imports/Actions.hs index af48677df7..38d80148bc 100644 --- a/src/Language/PureScript/Ide/Imports/Actions.hs +++ b/src/Language/PureScript/Ide/Imports/Actions.hs @@ -118,7 +118,7 @@ addExplicitImport' decl moduleName qualifier imports = refFromDeclaration d = P.ValueRef ideSpan (P.Ident (identifierFromIdeDeclaration d)) - -- | Adds a declaration to an import: + -- Adds a declaration to an import: -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) insertDeclIntoImport :: IdeDeclaration -> Import -> Import insertDeclIntoImport decl' (Import mn (P.Explicit refs) qual) = diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 60a20ff3cf..43dc0f80e9 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -273,7 +273,7 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' tellRedundant = tell . errorMessage' ss . uncurry OverlappingPattern . second null . splitAt 5 $ bss' tellIncomplete = tell . errorMessage' ss $ IncompleteExhaustivityCheck - -- | We add a Partial constraint by annotating the expression to have type `Partial => _`. + -- We add a Partial constraint by annotating the expression to have type `Partial => _`. -- -- The binder information is provided so that it can be embedded in the constraint, -- and then included in the error message. diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 2f32e7bcbc..6a30adb4e5 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -61,9 +61,7 @@ instance Monoid StrPos where plus (a, c) (StrPos (a', _, c')) = (a `addPos` a', (bumpPos a <$> c') : c) instance Emit StrPos where - -- | -- Augment a string with its length (rows/column) - -- emit str = -- TODO(Christoph): get rid of T.unpack let newlines = elemIndices '\n' (T.unpack str) @@ -71,9 +69,7 @@ instance Emit StrPos where in StrPos (SourcePos { sourcePosLine = length newlines, sourcePosColumn = T.length str - index }, str, []) - -- | -- Add a new mapping entry for given source position with initially zero generated position - -- addMapping ss@SourceSpan { spanName = file, spanStart = startPos } = StrPos (zeroPos, mempty, [ mapping | ss /= nullSourceSpan ]) where mapping = SMap (T.pack file) startPos zeroPos diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 61de1090ca..6298e2eefe 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -62,9 +62,7 @@ createBindingGroups moduleName = mapM f <=< handleDecls handleExprs (Let w ds val) = (\ds' -> Let w ds' val) <$> handleDecls ds handleExprs other = return other - -- | -- Replace all sets of mutually-recursive declarations with binding groups - -- handleDecls :: [Declaration] -> m [Declaration] handleDecls ds = do let values = mapMaybe (fmap (fmap extractGuardedExpr) . getValueDeclaration) ds diff --git a/src/Language/PureScript/Sugar/LetPattern.hs b/src/Language/PureScript/Sugar/LetPattern.hs index b9b23575a8..2d4b01d8f3 100644 --- a/src/Language/PureScript/Sugar/LetPattern.hs +++ b/src/Language/PureScript/Sugar/LetPattern.hs @@ -28,11 +28,11 @@ desugarLetPattern decl = replace other = other go :: WhereProvenance - -- ^ Metadata about whether the let-in was a where clause + -- Metadata about whether the let-in was a where clause -> [Either [Declaration] (SourceAnn, Binder, Expr)] - -- ^ Declarations to desugar + -- Declarations to desugar -> Expr - -- ^ The original let-in result expression + -- The original let-in result expression -> Expr go _ [] e = e go w (Right ((pos, com), binder, boundE) : ds) e = diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 6b807d344b..3531380ed0 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -212,7 +212,7 @@ rebracketModule !caller pred_ valueOpTable typeOpTable (Module ss coms mn ds ext fmap (map (\d -> if pred_ d then removeParens d else d)) . flip parU (usingPredicate pred_ h) - -- | The AST will run through all the desugar passes when compiling + -- The AST will run through all the desugar passes when compiling -- and only some of the desugar passes when generating docs. -- When generating docs, `case _ of` syntax used in an instance declaration -- can trigger the `IncorrectAnonymousArgument` error because it does not diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 9a279ba375..b5ed36bb14 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -229,7 +229,6 @@ desugarDecl mn exps = go return (expRef name' className tys, [d, dictDecl]) go other = return (Nothing, [other]) - -- | -- Completes the name generation for type class instances that do not have -- a unique name defined in source code. desugarInstName :: MonadSupply m => Either Text Ident -> Desugar m Ident diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index dec85ada99..8d210bac86 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -561,7 +561,6 @@ typeCheckAll moduleName = traverse go | moduleName `S.member` nonOrphanModules = return () | otherwise = throwError . errorMessage $ OrphanInstance dictName className nonOrphanModules tys' - -- | -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, -- extracted from the kind of the type constructor itself. -- diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index 3381cd649f..533910bb14 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -533,10 +533,10 @@ validateParamsInTypeConstructors derivingClass utc isBi CovariantClasses{..} con where tcdAppliesToType tcd = case tcdInstanceTypes tcd of [headOfType -> ht'] -> ht == ht' - -- ^ It's possible that, if ht and ht' are Lefts, this might require - -- verifying that the name isn't shadowed by something in tcdForAll. I - -- can't devise a legal program that causes this issue, but if in the - -- future it seems like a good idea, it probably is. + -- It's possible that, if ht and ht' are Lefts, this might require + -- verifying that the name isn't shadowed by something in tcdForAll. I + -- can't devise a legal program that causes this issue, but if in the + -- future it seems like a good idea, it probably is. _ -> False headOfType :: SourceType -> Qualified (Either Text (ProperName 'TypeName)) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index bf775042c7..5774f578f2 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -321,7 +321,7 @@ entails SolverOptions{..} constraint context hints = -- with no unsolved constraints. Hopefully, we can solve this later. return (TypeClassDictionary (srcConstraint className' kinds'' tys'' conInfo) context hints') where - -- | When checking functional dependencies, we need to use unification to make + -- When checking functional dependencies, we need to use unification to make -- sure it is safe to use the selected instance. We will unify the solved type with -- the type in the instance head under the substitution inferred from its instantiation. -- As an example, when solving MonadState t0 (State Int), we choose the @@ -380,7 +380,6 @@ entails SolverOptions{..} constraint context hints = canBeGeneralized (KindedType _ t _) = canBeGeneralized t canBeGeneralized _ = False - -- | -- Check if two dictionaries are overlapping -- -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have @@ -475,7 +474,7 @@ entails SolverOptions{..} constraint context hints = pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolAppend [] [] args' Nothing Nothing] solveSymbolAppend _ = Nothing - -- | Append type level symbols, or, run backwards, strip a prefix or suffix + -- Append type level symbols, or, run backwards, strip a prefix or suffix appendSymbols :: SourceType -> SourceType -> SourceType -> Maybe (SourceType, SourceType, SourceType) appendSymbols arg0@(TypeLevelString _ lhs) arg1@(TypeLevelString _ rhs) _ = Just (arg0, arg1, srcTypeLevelString (lhs <> rhs)) appendSymbols arg0@(TypeLevelString _ lhs) _ arg2@(TypeLevelString _ out) = do @@ -544,11 +543,11 @@ entails SolverOptions{..} constraint context hints = solveIntAdd _ = Nothing addInts :: SourceType -> SourceType -> SourceType -> Maybe (SourceType, SourceType, SourceType) - -- | l r -> o, l + r = o + -- l r -> o, l + r = o addInts arg0@(TypeLevelInt _ l) arg1@(TypeLevelInt _ r) _ = pure (arg0, arg1, srcTypeLevelInt (l + r)) - -- | l o -> r, o - l = r + -- l o -> r, o - l = r addInts arg0@(TypeLevelInt _ l) _ arg2@(TypeLevelInt _ o) = pure (arg0, srcTypeLevelInt (o - l), arg2) - -- | r o -> l, o - r = l + -- r o -> l, o - r = l addInts _ arg1@(TypeLevelInt _ r) arg2@(TypeLevelInt _ o) = pure (srcTypeLevelInt (o - r), arg1, arg2) addInts _ _ _ = Nothing @@ -582,7 +581,7 @@ entails SolverOptions{..} constraint context hints = pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowUnion vars kinds [lOut, rOut, uOut] cst Nothing ] solveUnion _ _ = Nothing - -- | Left biased union of two row types + -- Left biased union of two row types unionRows :: [SourceType] -> SourceType -> SourceType -> SourceType -> Maybe (SourceType, SourceType, SourceType, Maybe [SourceConstraint], [(Text, SourceType)]) unionRows kinds l r u = @@ -643,7 +642,7 @@ entails SolverOptions{..} constraint context hints = pure [ TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.RowToList [] [kind] [r, entries] Nothing Nothing ] solveRowToList _ _ = Nothing - -- | Convert a closed row to a sorted list of entries + -- Convert a closed row to a sorted list of entries rowToRowList :: SourceType -> SourceType -> Maybe SourceType rowToRowList kind r = guard (isREmpty rest) $> @@ -705,7 +704,7 @@ matches deps TypeClassDictionaryInScope{..} tys = solved = map snd . filter ((`S.notMember` determinedSet) . fst) $ zipWith (\(_, ts) i -> (i, ts)) matched [0..] in verifySubstitution (M.unionsWith (++) solved) where - -- | Find the closure of a set of functional dependencies. + -- Find the closure of a set of functional dependencies. covers :: [(Matched (), subst)] -> Bool covers ms = finalSet == S.fromList [0..length ms - 1] where @@ -875,10 +874,10 @@ pairwiseM p (x : xs) = traverse (p x) xs *> pairwiseM p xs tails1 :: NonEmpty a -> NonEmpty (NonEmpty a) tails1 = -- NEL.fromList is an unsafe function, but this usage should be safe, since: - -- * `tails xs = [xs, tail xs, tail (tail xs), ..., []]` - -- * If `xs` is nonempty, it follows that `tails xs` contains at least one nonempty + -- - `tails xs = [xs, tail xs, tail (tail xs), ..., []]` + -- - If `xs` is nonempty, it follows that `tails xs` contains at least one nonempty -- list, since `head (tails xs) = xs`. - -- * The only empty element of `tails xs` is the last one (by the definition of `tails`) - -- * Therefore, if we take all but the last element of `tails xs` i.e. + -- - The only empty element of `tails xs` is the last one (by the definition of `tails`) + -- - Therefore, if we take all but the last element of `tails xs` i.e. -- `init (tails xs)`, we have a nonempty list of nonempty lists NEL.fromList . map NEL.fromList . init . tails . NEL.toList diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 7947a4d2f2..7a82f22214 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -197,12 +197,12 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do -> ErrorMessage replaceTypes subst = onTypesInErrorMessage (substituteType subst) - -- | Run type search to complete any typed hole error messages + -- Run type search to complete any typed hole error messages runTypeSearch :: Maybe [(Ident, InstanceContext, SourceConstraint)] - -- ^ Any unsolved constraints which we need to continue to satisfy + -- Any unsolved constraints which we need to continue to satisfy -> CheckState - -- ^ The final type checker state + -- The final type checker state -> ErrorMessage -> ErrorMessage runTypeSearch cons st = \case @@ -214,7 +214,7 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do in ErrorMessage hints (HoleInferredType x ty y (Just searchResult)) other -> other - -- | Add any unsolved constraints + -- Add any unsolved constraints constrain cs ty = foldr srcConstrainedType ty (map (\(_, _, x) -> x) cs) -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values @@ -271,7 +271,7 @@ typeDictionaryForBindingGroup moduleName vals = do ] return (SplitBindingGroup untyped' typed' dict) where - -- | Check if a value contains a type annotation, and if so, separate it + -- Check if a value contains a type annotation, and if so, separate it -- from the value itself. splitTypeAnnotation :: (a, Expr) -> Either (a, Expr) (a, (Expr, SourceType, Bool)) splitTypeAnnotation (a, TypedValue checkType value ty) = Right (a, (value, ty, checkType)) From be8e32f27255fd689f858be9e9eb2d3c86d03bbd Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Thu, 23 Mar 2023 21:41:33 -0400 Subject: [PATCH 1537/1580] Make unqualified imports explicit (#4454) This applies only to import lists with fewer than fifteen items. This also skips imports that have any `as` clause whatsoever, some of which still introduce implicit identifiers into the namespace. --- app/Command/Compile.hs | 8 ++-- app/Command/Docs.hs | 8 ++-- app/Command/Docs/Html.hs | 4 +- app/Command/Graph.hs | 2 +- app/Command/Ide.hs | 22 +++++----- app/Command/Publish.hs | 4 +- app/Command/REPL.hs | 8 ++-- src/Control/Monad/Logger.hs | 6 +-- src/Control/Monad/Supply.hs | 10 ++--- src/Control/Monad/Supply/Class.hs | 8 ++-- src/Language/PureScript/AST/Binders.hs | 10 ++--- src/Language/PureScript/AST/Declarations.hs | 24 +++++----- src/Language/PureScript/AST/Exported.hs | 6 +-- src/Language/PureScript/AST/Operators.hs | 2 +- src/Language/PureScript/AST/SourcePos.hs | 2 +- src/Language/PureScript/AST/Traversals.hs | 16 +++---- src/Language/PureScript/AST/Utils.hs | 6 +-- src/Language/PureScript/Bundle.hs | 8 ++-- src/Language/PureScript/CST/Errors.hs | 6 +-- src/Language/PureScript/CST/Flatten.hs | 2 +- src/Language/PureScript/CST/Layout.hs | 2 +- src/Language/PureScript/CST/Lexer.hs | 10 ++--- src/Language/PureScript/CST/Monad.hs | 8 ++-- src/Language/PureScript/CST/Print.hs | 2 +- src/Language/PureScript/CST/Traversals.hs | 2 +- .../PureScript/CST/Traversals/Type.hs | 4 +- src/Language/PureScript/CST/Utils.hs | 8 ++-- src/Language/PureScript/CodeGen/JS.hs | 14 +++--- src/Language/PureScript/CodeGen/JS/Common.hs | 6 +-- src/Language/PureScript/CodeGen/JS/Printer.hs | 14 +++--- src/Language/PureScript/Comments.hs | 2 +- src/Language/PureScript/Constants/Prim.hs | 2 +- src/Language/PureScript/Constants/TH.hs | 4 +- src/Language/PureScript/CoreFn/Ann.hs | 8 ++-- src/Language/PureScript/CoreFn/Binders.hs | 4 +- src/Language/PureScript/CoreFn/CSE.hs | 12 ++--- src/Language/PureScript/CoreFn/Desugar.hs | 26 +++++------ src/Language/PureScript/CoreFn/Expr.hs | 6 +-- src/Language/PureScript/CoreFn/FromJSON.hs | 10 ++--- src/Language/PureScript/CoreFn/Laziness.hs | 8 ++-- src/Language/PureScript/CoreFn/Meta.hs | 2 +- src/Language/PureScript/CoreFn/Module.hs | 8 ++-- src/Language/PureScript/CoreFn/Optimizer.hs | 18 ++++---- src/Language/PureScript/CoreFn/ToJSON.hs | 8 ++-- src/Language/PureScript/CoreFn/Traversals.hs | 6 +-- src/Language/PureScript/CoreImp/AST.hs | 4 +- src/Language/PureScript/CoreImp/Module.hs | 4 +- src/Language/PureScript/CoreImp/Optimizer.hs | 14 +++--- .../PureScript/CoreImp/Optimizer/Blocks.hs | 2 +- .../PureScript/CoreImp/Optimizer/Common.hs | 4 +- .../PureScript/CoreImp/Optimizer/Inliner.hs | 4 +- .../PureScript/CoreImp/Optimizer/MagicDo.hs | 4 +- .../PureScript/CoreImp/Optimizer/TCO.hs | 2 +- .../PureScript/CoreImp/Optimizer/Unused.hs | 4 +- src/Language/PureScript/Docs/AsHtml.hs | 2 +- src/Language/PureScript/Docs/AsMarkdown.hs | 4 +- src/Language/PureScript/Docs/Collect.hs | 2 +- src/Language/PureScript/Docs/Convert.hs | 2 +- .../PureScript/Docs/Convert/ReExports.hs | 4 +- .../PureScript/Docs/Convert/Single.hs | 2 +- src/Language/PureScript/Docs/Prim.hs | 2 +- src/Language/PureScript/Docs/Render.hs | 4 +- .../Docs/RenderedCode/RenderType.hs | 16 +++---- .../PureScript/Docs/RenderedCode/Types.hs | 2 +- src/Language/PureScript/Docs/Tags.hs | 2 +- src/Language/PureScript/Docs/Types.hs | 4 +- .../PureScript/Docs/Utils/MonoidExtras.hs | 2 +- src/Language/PureScript/Environment.hs | 12 ++--- src/Language/PureScript/Errors.hs | 16 +++---- src/Language/PureScript/Externs.hs | 12 ++--- src/Language/PureScript/Ide.hs | 30 ++++++------- src/Language/PureScript/Ide/CaseSplit.hs | 8 ++-- src/Language/PureScript/Ide/Command.hs | 12 ++--- src/Language/PureScript/Ide/Completion.hs | 10 ++--- src/Language/PureScript/Ide/Error.hs | 4 +- src/Language/PureScript/Ide/Externs.hs | 6 +-- src/Language/PureScript/Ide/Filter.hs | 10 ++--- .../PureScript/Ide/Filter/Declaration.hs | 2 +- src/Language/PureScript/Ide/Filter/Imports.hs | 4 +- src/Language/PureScript/Ide/Imports.hs | 4 +- .../PureScript/Ide/Imports/Actions.hs | 16 +++---- src/Language/PureScript/Ide/Logging.hs | 8 ++-- src/Language/PureScript/Ide/Matcher.hs | 8 ++-- src/Language/PureScript/Ide/Prim.hs | 2 +- src/Language/PureScript/Ide/Rebuild.hs | 12 ++--- src/Language/PureScript/Ide/Reexports.hs | 4 +- src/Language/PureScript/Ide/SourceFile.hs | 6 +-- src/Language/PureScript/Ide/State.hs | 18 ++++---- src/Language/PureScript/Ide/Types.hs | 2 +- src/Language/PureScript/Ide/Usage.hs | 2 +- src/Language/PureScript/Ide/Util.hs | 6 +-- src/Language/PureScript/Interactive.hs | 4 +- .../PureScript/Interactive/Completion.hs | 4 +- .../PureScript/Interactive/Directive.hs | 2 +- .../PureScript/Interactive/Message.hs | 2 +- src/Language/PureScript/Interactive/Module.hs | 2 +- src/Language/PureScript/Interactive/Parser.hs | 2 +- src/Language/PureScript/Linter.hs | 8 ++-- src/Language/PureScript/Linter/Exhaustive.hs | 18 ++++---- src/Language/PureScript/Linter/Imports.hs | 14 +++--- src/Language/PureScript/Linter/Wildcards.hs | 4 +- src/Language/PureScript/Make.hs | 30 ++++++------- src/Language/PureScript/Make/Actions.hs | 26 +++++------ src/Language/PureScript/Make/BuildPlan.hs | 14 +++--- src/Language/PureScript/Make/Monad.hs | 10 ++--- src/Language/PureScript/ModuleDependencies.hs | 10 ++--- src/Language/PureScript/Names.hs | 6 +-- src/Language/PureScript/Pretty/Common.hs | 2 +- src/Language/PureScript/Pretty/Types.hs | 15 +++---- src/Language/PureScript/Pretty/Values.hs | 10 ++--- src/Language/PureScript/Publish.hs | 8 ++-- .../PureScript/Publish/ErrorsWarnings.hs | 8 ++-- src/Language/PureScript/Publish/Utils.hs | 2 +- src/Language/PureScript/Renamer.hs | 8 ++-- src/Language/PureScript/Sugar.hs | 10 ++--- src/Language/PureScript/Sugar/AdoNotation.hs | 8 ++-- .../PureScript/Sugar/BindingGroups.hs | 12 ++--- .../PureScript/Sugar/CaseDeclarations.hs | 10 ++--- src/Language/PureScript/Sugar/DoNotation.hs | 10 ++--- src/Language/PureScript/Sugar/LetPattern.hs | 4 +- src/Language/PureScript/Sugar/Names.hs | 24 +++++----- src/Language/PureScript/Sugar/Names/Common.hs | 6 +-- src/Language/PureScript/Sugar/Names/Env.hs | 10 ++--- .../PureScript/Sugar/Names/Exports.hs | 10 ++--- .../PureScript/Sugar/Names/Imports.hs | 12 ++--- .../PureScript/Sugar/ObjectWildcards.hs | 6 +-- src/Language/PureScript/Sugar/Operators.hs | 16 +++---- .../PureScript/Sugar/Operators/Binders.hs | 10 ++--- .../PureScript/Sugar/Operators/Common.hs | 14 +++--- .../PureScript/Sugar/Operators/Expr.hs | 12 ++--- .../PureScript/Sugar/Operators/Types.hs | 12 ++--- src/Language/PureScript/Sugar/TypeClasses.hs | 16 +++---- .../PureScript/Sugar/TypeClasses/Deriving.hs | 14 +++--- .../PureScript/Sugar/TypeDeclarations.hs | 8 ++-- src/Language/PureScript/TypeChecker.hs | 20 ++++----- .../PureScript/TypeChecker/Deriving.hs | 28 ++++++------ .../PureScript/TypeChecker/Entailment.hs | 24 +++++----- .../TypeChecker/Entailment/Coercible.hs | 22 +++++----- src/Language/PureScript/TypeChecker/Kinds.hs | 16 +++---- src/Language/PureScript/TypeChecker/Monad.hs | 18 ++++---- src/Language/PureScript/TypeChecker/Roles.hs | 10 ++--- .../PureScript/TypeChecker/Skolems.hs | 10 ++--- .../PureScript/TypeChecker/Subsumption.hs | 16 +++---- .../PureScript/TypeChecker/Synonyms.hs | 12 ++--- .../PureScript/TypeChecker/TypeSearch.hs | 4 +- src/Language/PureScript/TypeChecker/Types.hs | 26 +++++------ src/Language/PureScript/TypeChecker/Unify.hs | 12 ++--- .../PureScript/TypeClassDictionaries.hs | 4 +- src/Language/PureScript/Types.hs | 4 +- .../Language/PureScript/Ide/CompletionSpec.hs | 6 +-- tests/Language/PureScript/Ide/FilterSpec.hs | 8 ++-- tests/Language/PureScript/Ide/ImportsSpec.hs | 12 ++--- tests/Language/PureScript/Ide/MatcherSpec.hs | 8 ++-- tests/Language/PureScript/Ide/RebuildSpec.hs | 12 ++--- .../Language/PureScript/Ide/ReexportsSpec.hs | 8 ++-- .../Language/PureScript/Ide/SourceFileSpec.hs | 8 ++-- tests/Language/PureScript/Ide/StateSpec.hs | 10 ++--- tests/Language/PureScript/Ide/Test.hs | 18 ++++---- tests/Language/PureScript/Ide/UsageSpec.hs | 8 ++-- tests/TestAst.hs | 16 +++---- tests/TestCompiler.hs | 14 +++--- tests/TestCoreFn.hs | 44 +++++++++---------- tests/TestCst.hs | 8 ++-- tests/TestDocs.hs | 6 +-- tests/TestGraph.hs | 2 +- tests/TestHierarchy.hs | 4 +- tests/TestMake.hs | 12 ++--- tests/TestPrimDocs.hs | 2 +- tests/TestPscPublish.hs | 8 ++-- tests/TestPsci.hs | 2 +- tests/TestPsci/CommandTest.hs | 6 +-- tests/TestPsci/CompletionTest.hs | 4 +- tests/TestPsci/EvalTest.hs | 4 +- tests/TestPsci/TestEnv.hs | 2 +- tests/TestSourceMaps.hs | 2 +- tests/TestUtils.hs | 20 ++++----- 176 files changed, 785 insertions(+), 788 deletions(-) diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index f5c82186e2..27fbb39d01 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -2,8 +2,8 @@ module Command.Compile (command) where import Prelude -import Control.Applicative -import Control.Monad +import Control.Applicative (Alternative(..)) +import Control.Monad (when) import Data.Aeson qualified as A import Data.Bool (bool) import Data.ByteString.Lazy.UTF8 qualified as LBU8 @@ -14,8 +14,8 @@ import Data.Text qualified as T import Data.Traversable (for) import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST -import Language.PureScript.Errors.JSON -import Language.PureScript.Make +import Language.PureScript.Errors.JSON (JSONResult(..), toJSONErrors) +import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake) import Options.Applicative qualified as Opts import System.Console.ANSI qualified as ANSI import System.Exit (exitSuccess, exitFailure) diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index bb30171afb..38c875083c 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -3,10 +3,10 @@ module Command.Docs (command, infoModList) where import Prelude -import Command.Docs.Html -import Command.Docs.Markdown -import Control.Applicative -import Control.Monad.Writer +import Command.Docs.Html (asHtml, writeHtmlModules) +import Command.Docs.Markdown (asMarkdown, writeMarkdownModules) +import Control.Applicative (Alternative(..), optional) +import Control.Monad.Writer (when) import Control.Monad.Trans.Except (runExceptT) import Data.Maybe (fromMaybe) import Data.Text qualified as T diff --git a/app/Command/Docs/Html.hs b/app/Command/Docs/Html.hs index 18fcb93720..6ad51041f3 100644 --- a/app/Command/Docs/Html.hs +++ b/app/Command/Docs/Html.hs @@ -7,9 +7,9 @@ module Command.Docs.Html import Prelude -import Control.Applicative +import Control.Applicative (Alternative(..)) import Control.Arrow ((&&&)) -import Control.Monad.Writer +import Control.Monad.Writer (guard) import Data.List (sort) import Data.Text (Text) import Data.Text.Lazy (toStrict) diff --git a/app/Command/Graph.hs b/app/Command/Graph.hs index 338a303c8e..4e3c905d9b 100644 --- a/app/Command/Graph.hs +++ b/app/Command/Graph.hs @@ -9,7 +9,7 @@ import Data.Bool (bool) import Data.ByteString.Lazy qualified as LB import Data.ByteString.Lazy.UTF8 qualified as LBU8 import Language.PureScript qualified as P -import Language.PureScript.Errors.JSON +import Language.PureScript.Errors.JSON (JSONResult(..), toJSONErrors) import Options.Applicative qualified as Opts import System.Console.ANSI qualified as ANSI import System.Exit (exitFailure) diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index cbb5270a9b..cfb563be4e 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -20,24 +20,24 @@ module Command.Ide (command) where import Protolude import Data.Aeson qualified as Aeson -import Control.Concurrent.STM -import "monad-logger" Control.Monad.Logger -import Data.IORef +import Control.Concurrent.STM (newTVarIO) +import "monad-logger" Control.Monad.Logger (MonadLogger, logDebug, logError, logInfo) +import Data.IORef (newIORef) import Data.Text.IO qualified as T import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy.Char8 qualified as BSL8 import GHC.IO.Exception (IOErrorType(..), IOException(..)) -import Language.PureScript.Ide -import Language.PureScript.Ide.Command -import Language.PureScript.Ide.Util -import Language.PureScript.Ide.Error +import Language.PureScript.Ide (handleCommand) +import Language.PureScript.Ide.Command (Command(..), commandName) +import Language.PureScript.Ide.Util (decodeT, displayTimeSpec, encodeT, logPerf, runLogger) +import Language.PureScript.Ide.Error (IdeError(..)) import Language.PureScript.Ide.State (updateCacheTimestamp) -import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Types (Ide, IdeConfiguration(..), IdeEnvironment(..), IdeLogLevel(..), emptyIdeState) import Network.Socket qualified as Network import Options.Applicative qualified as Opts -import System.Directory -import System.FilePath -import System.IO hiding (putStrLn, print) +import System.Directory (doesDirectoryExist, getCurrentDirectory, setCurrentDirectory) +import System.FilePath (()) +import System.IO (BufferMode(..), hClose, hFlush, hSetBuffering, hSetEncoding, utf8) import System.IO.Error (isEOFError) listenOnLocalhost :: Network.PortNumber -> IO Network.Socket diff --git a/app/Command/Publish.hs b/app/Command/Publish.hs index 95e5f42ca0..b63d366c91 100644 --- a/app/Command/Publish.hs +++ b/app/Command/Publish.hs @@ -7,8 +7,8 @@ import Data.Aeson qualified as A import Data.ByteString.Lazy.Char8 qualified as BL import Data.Time.Clock (getCurrentTime) import Data.Version (Version(..)) -import Language.PureScript.Publish -import Language.PureScript.Publish.ErrorsWarnings +import Language.PureScript.Publish (PublishOptions(..), defaultPublishOptions, unsafePreparePackage, warn) +import Language.PureScript.Publish.ErrorsWarnings (PackageWarning(..)) import Options.Applicative (Parser) import Options.Applicative qualified as Opts diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index 194e2cc236..eb254be45c 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -5,10 +5,10 @@ module Command.REPL (command) where import Prelude import Control.Applicative (many, (<|>)) -import Control.Monad +import Control.Monad (unless, when) import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class (liftIO, MonadIO) -import Control.Monad.Trans.Class +import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.State.Strict (StateT, evalStateT) import Control.Monad.Trans.Reader (ReaderT, runReaderT) @@ -17,9 +17,9 @@ import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST import Language.PureScript.Interactive import Options.Applicative qualified as Opts -import System.Console.Haskeline +import System.Console.Haskeline (InputT, Settings(..), defaultSettings, getInputLine, handleInterrupt, outputStrLn, runInputT, setComplete, withInterrupt) import System.IO.UTF8 (readUTF8File) -import System.Exit +import System.Exit (ExitCode(..), exitFailure) import System.Directory (doesFileExist, getCurrentDirectory) import System.FilePath (()) import System.FilePath.Glob qualified as Glob diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs index 23469082a3..a3ed57b0da 100644 --- a/src/Control/Monad/Logger.hs +++ b/src/Control/Monad/Logger.hs @@ -7,11 +7,11 @@ import Prelude import Control.Monad (ap) import Control.Monad.Base (MonadBase(..)) -import Control.Monad.IO.Class +import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Control (MonadBaseControl(..)) -import Control.Monad.Writer.Class +import Control.Monad.Writer.Class (MonadWriter(..)) -import Data.IORef +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) -- | A replacement for WriterT IO which uses mutable references. newtype Logger w a = Logger { runLogger :: IORef w -> IO a } diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs index 1941fcf9b8..8c64fd2524 100644 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -5,13 +5,13 @@ module Control.Monad.Supply where import Prelude -import Control.Applicative +import Control.Applicative (Alternative) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer +import Control.Monad.Reader (MonadPlus, MonadReader, MonadTrans) +import Control.Monad.State (StateT(..)) +import Control.Monad.Writer (MonadWriter) -import Data.Functor.Identity +import Data.Functor.Identity (Identity(..)) newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r, Alternative, MonadPlus) diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index ff80893b31..e8656f0c69 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -6,10 +6,10 @@ module Control.Monad.Supply.Class where import Prelude -import Control.Monad.RWS -import Control.Monad.State -import Control.Monad.Supply -import Control.Monad.Writer +import Control.Monad.RWS (MonadState(..), MonadTrans(..), RWST) +import Control.Monad.State (StateT) +import Control.Monad.Supply (SupplyT(..)) +import Control.Monad.Writer (WriterT) import Data.Text (Text, pack) class Monad m => MonadSupply m where diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index 748bb64bfb..6d88ff3d97 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -5,11 +5,11 @@ module Language.PureScript.AST.Binders where import Prelude -import Language.PureScript.AST.SourcePos -import Language.PureScript.AST.Literals -import Language.PureScript.Names -import Language.PureScript.Comments -import Language.PureScript.Types +import Language.PureScript.AST.SourcePos (SourceSpan) +import Language.PureScript.AST.Literals (Literal(..)) +import Language.PureScript.Names (Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified) +import Language.PureScript.Comments (Comment) +import Language.PureScript.Types (SourceType) -- | -- Data type for binders diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 8112521acd..5d8555cdbd 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -11,27 +11,27 @@ import Protolude.Exceptions (hush) import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) -import Data.Functor.Identity +import Data.Functor.Identity (Identity(..)) -import Data.Aeson.TH +import Data.Aeson.TH (Options(..), SumEncoding(..), defaultOptions, deriveJSON) import Data.Map qualified as M import Data.Text (Text) import Data.List.NonEmpty qualified as NEL import GHC.Generics (Generic) -import Language.PureScript.AST.Binders -import Language.PureScript.AST.Literals -import Language.PureScript.AST.Operators -import Language.PureScript.AST.SourcePos +import Language.PureScript.AST.Binders (Binder) +import Language.PureScript.AST.Literals (Literal(..)) +import Language.PureScript.AST.Operators (Fixity) +import Language.PureScript.AST.SourcePos (SourceAnn, SourceSpan) import Language.PureScript.AST.Declarations.ChainId (ChainId) -import Language.PureScript.Types +import Language.PureScript.Types (SourceConstraint, SourceType) import Language.PureScript.PSString (PSString) import Language.PureScript.Label (Label) -import Language.PureScript.Names -import Language.PureScript.Roles -import Language.PureScript.TypeClassDictionaries -import Language.PureScript.Comments -import Language.PureScript.Environment +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), toMaybeModuleName) +import Language.PureScript.Roles (Role) +import Language.PureScript.TypeClassDictionaries (NamedDict) +import Language.PureScript.Comments (Comment) +import Language.PureScript.Environment (DataDeclType, Environment, FunctionalDependency, NameKind) import Language.PureScript.Constants.Prim qualified as C -- | A map of locally-bound names in scope. diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index 20f963ee06..8ca960bb95 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -12,9 +12,9 @@ import Control.Applicative ((<|>)) import Data.Maybe (mapMaybe) import Data.Map qualified as M -import Language.PureScript.AST.Declarations -import Language.PureScript.Types -import Language.PureScript.Names +import Language.PureScript.AST.Declarations (DataConstructorDeclaration(..), Declaration(..), DeclarationRef(..), Module(..), declName, declRefName, flattenDecls) +import Language.PureScript.Types (Constraint(..), Type(..), everythingOnTypes) +import Language.PureScript.Names (ModuleName, Name(..), ProperName, ProperNameType(..), Qualified, coerceProperName, disqualify, isQualified, isQualifiedWith) -- | -- Return a list of all declarations which are exported from a module. diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs index 9d3364f681..eb217a2444 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -11,7 +11,7 @@ import Control.DeepSeq (NFData) import Data.Aeson ((.=)) import Data.Aeson qualified as A -import Language.PureScript.Crash +import Language.PureScript.Crash (internalError) -- | -- A precedence level for an infix operator diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 31811d8cb7..262d44b6a1 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -11,7 +11,7 @@ import Control.DeepSeq (NFData) import Data.Aeson ((.=), (.:)) import Data.Text (Text) import GHC.Generics (Generic) -import Language.PureScript.Comments +import Language.PureScript.Comments (Comment) import Data.Aeson qualified as A import Data.Text qualified as T import System.FilePath (makeRelative) diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index cda37d8e7b..8aa8808a85 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -6,8 +6,8 @@ module Language.PureScript.AST.Traversals where import Prelude import Protolude (swap) -import Control.Monad -import Control.Monad.Trans.State +import Control.Monad ((<=<), (>=>)) +import Control.Monad.Trans.State (StateT(..)) import Data.Foldable (fold) import Data.Functor.Identity (runIdentity) @@ -17,13 +17,13 @@ import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M import Data.Set qualified as S -import Language.PureScript.AST.Binders -import Language.PureScript.AST.Declarations -import Language.PureScript.AST.Literals -import Language.PureScript.Names -import Language.PureScript.Traversals +import Language.PureScript.AST.Binders (Binder(..), binderNames) +import Language.PureScript.AST.Declarations (CaseAlternative(..), DataConstructorDeclaration(..), Declaration(..), DoNotationElement(..), Expr(..), Guard(..), GuardedExpr(..), TypeDeclarationData(..), TypeInstanceBody(..), pattern ValueDecl, ValueDeclarationData(..), mapTypeInstanceBody, traverseTypeInstanceBody) +import Language.PureScript.AST.Literals (Literal(..)) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident) +import Language.PureScript.Traversals (sndM, sndM', thirdM) import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..)) -import Language.PureScript.Types +import Language.PureScript.Types (Constraint(..), SourceType, mapConstraintArgs) guardedExprM :: Applicative m => (Guard -> m Guard) diff --git a/src/Language/PureScript/AST/Utils.hs b/src/Language/PureScript/AST/Utils.hs index a62ed5593e..d768a884fd 100644 --- a/src/Language/PureScript/AST/Utils.hs +++ b/src/Language/PureScript/AST/Utils.hs @@ -2,9 +2,9 @@ module Language.PureScript.AST.Utils where import Protolude -import Language.PureScript.AST -import Language.PureScript.Names -import Language.PureScript.Types +import Language.PureScript.AST (Binder(..), CaseAlternative, Expr(..), GuardedExpr, Literal, pattern MkUnguarded, nullSourceSpan) +import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName) +import Language.PureScript.Types (SourceType, Type(..)) lam :: Ident -> Expr -> Expr lam = Abs . mkBinder diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 3f612e7b9b..26b932323f 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -18,7 +18,7 @@ module Language.PureScript.Bundle import Prelude -import Control.Monad.Error.Class +import Control.Monad.Error.Class (MonadError(..)) import Data.Aeson ((.=)) import Data.Char (chr, digitToInt) @@ -27,9 +27,9 @@ import Data.Maybe (mapMaybe, maybeToList) import Data.Aeson qualified as A import Data.Text.Lazy qualified as LT -import Language.JavaScript.Parser -import Language.JavaScript.Parser.AST -import Language.JavaScript.Process.Minify +import Language.JavaScript.Parser (JSAST(..), JSAnnot(..), JSAssignOp(..), JSExpression(..), JSStatement(..), renderToText) +import Language.JavaScript.Parser.AST (JSCommaList(..), JSCommaTrailingList(..), JSExportClause(..), JSExportDeclaration(..), JSExportSpecifier(..), JSFromClause(..), JSIdent(..), JSImportDeclaration(..), JSModuleItem(..), JSObjectProperty(..), JSObjectPropertyList, JSPropertyName(..), JSVarInitializer(..)) +import Language.JavaScript.Process.Minify (minifyJS) -- | The type of error messages. We separate generation and rendering of errors using a data -- type, in case we need to match on error types later. diff --git a/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs index fdea6dcefa..5cdea343ef 100644 --- a/src/Language/PureScript/CST/Errors.hs +++ b/src/Language/PureScript/CST/Errors.hs @@ -13,9 +13,9 @@ import Prelude import Data.Text qualified as Text import Data.Char (isSpace, toUpper) -import Language.PureScript.CST.Layout -import Language.PureScript.CST.Print -import Language.PureScript.CST.Types +import Language.PureScript.CST.Layout (LayoutStack) +import Language.PureScript.CST.Print (printToken) +import Language.PureScript.CST.Types (SourcePos(..), SourceRange(..), SourceToken(..), Token(..)) import Text.Printf (printf) data ParserErrorType diff --git a/src/Language/PureScript/CST/Flatten.hs b/src/Language/PureScript/CST/Flatten.hs index fe20adecd3..c6e1b8c80a 100644 --- a/src/Language/PureScript/CST/Flatten.hs +++ b/src/Language/PureScript/CST/Flatten.hs @@ -4,7 +4,7 @@ import Prelude import Data.DList (DList) import Language.PureScript.CST.Types -import Language.PureScript.CST.Positions +import Language.PureScript.CST.Positions (advanceLeading, moduleRange, srcRange) flattenModule :: Module a -> DList SourceToken flattenModule m@(Module _ a b c d e f g) = diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs index 6ab82153ec..989cf1563d 100644 --- a/src/Language/PureScript/CST/Layout.hs +++ b/src/Language/PureScript/CST/Layout.hs @@ -174,7 +174,7 @@ import Data.DList (snoc) import Data.DList qualified as DList import Data.Foldable (find) import Data.Function ((&)) -import Language.PureScript.CST.Types +import Language.PureScript.CST.Types (Comment, LineFeed, SourcePos(..), SourceRange(..), SourceToken(..), Token(..), TokenAnn(..)) type LayoutStack = [(SourcePos, LayoutDelim)] diff --git a/src/Language/PureScript/CST/Lexer.hs b/src/Language/PureScript/CST/Lexer.hs index bb8ec99571..726a76f26a 100644 --- a/src/Language/PureScript/CST/Lexer.hs +++ b/src/Language/PureScript/CST/Lexer.hs @@ -19,11 +19,11 @@ import Data.String (fromString) import Data.Text (Text) import Data.Text qualified as Text import Data.Text.PureScript qualified as Text -import Language.PureScript.CST.Errors -import Language.PureScript.CST.Monad hiding (token) -import Language.PureScript.CST.Layout -import Language.PureScript.CST.Positions -import Language.PureScript.CST.Types +import Language.PureScript.CST.Errors (ParserErrorInfo(..), ParserErrorType(..)) +import Language.PureScript.CST.Monad (LexResult, LexState(..), ParserM(..), throw) +import Language.PureScript.CST.Layout (LayoutDelim(..), insertLayout, lytToken, unwindLayout) +import Language.PureScript.CST.Positions (advanceLeading, advanceToken, advanceTrailing, applyDelta, textDelta) +import Language.PureScript.CST.Types (Comment(..), LineFeed(..), SourcePos(..), SourceRange(..), SourceStyle(..), SourceToken(..), Token(..), TokenAnn(..)) -- | Stops at the first lexing error and replaces it with TokEof. Otherwise, -- the parser will fail when it attempts to draw a lookahead token. diff --git a/src/Language/PureScript/CST/Monad.hs b/src/Language/PureScript/CST/Monad.hs index 9245c59dff..31887c890a 100644 --- a/src/Language/PureScript/CST/Monad.hs +++ b/src/Language/PureScript/CST/Monad.hs @@ -6,10 +6,10 @@ import Data.List (sortOn) import Data.List.NonEmpty qualified as NE import Data.Ord (comparing) import Data.Text (Text) -import Language.PureScript.CST.Errors -import Language.PureScript.CST.Layout -import Language.PureScript.CST.Positions -import Language.PureScript.CST.Types +import Language.PureScript.CST.Errors (ParserError, ParserErrorInfo(..), ParserErrorType(..), ParserWarning, ParserWarningType) +import Language.PureScript.CST.Layout (LayoutStack) +import Language.PureScript.CST.Positions (widen) +import Language.PureScript.CST.Types (Comment, LineFeed, SourcePos(..), SourceRange(..), SourceToken(..), Token, TokenAnn(..)) type LexResult = Either (LexState, ParserError) SourceToken diff --git a/src/Language/PureScript/CST/Print.hs b/src/Language/PureScript/CST/Print.hs index 9becaaf24c..f6d300ab67 100644 --- a/src/Language/PureScript/CST/Print.hs +++ b/src/Language/PureScript/CST/Print.hs @@ -15,7 +15,7 @@ import Prelude import Data.DList qualified as DList import Data.Text (Text) import Data.Text qualified as Text -import Language.PureScript.CST.Types +import Language.PureScript.CST.Types (Comment(..), LineFeed(..), Module, SourceStyle(..), SourceToken(..), Token(..), TokenAnn(..)) import Language.PureScript.CST.Flatten (flattenModule) printToken :: Token -> Text diff --git a/src/Language/PureScript/CST/Traversals.hs b/src/Language/PureScript/CST/Traversals.hs index 6d5627f8ac..23532915f1 100644 --- a/src/Language/PureScript/CST/Traversals.hs +++ b/src/Language/PureScript/CST/Traversals.hs @@ -2,7 +2,7 @@ module Language.PureScript.CST.Traversals where import Prelude -import Language.PureScript.CST.Types +import Language.PureScript.CST.Types (Separated(..)) everythingOnSeparated :: (r -> r -> r) -> (a -> r) -> Separated a -> r everythingOnSeparated op k (Separated hd tl) = go hd tl diff --git a/src/Language/PureScript/CST/Traversals/Type.hs b/src/Language/PureScript/CST/Traversals/Type.hs index c3e6c97ef4..c61e65ca3e 100644 --- a/src/Language/PureScript/CST/Traversals/Type.hs +++ b/src/Language/PureScript/CST/Traversals/Type.hs @@ -2,8 +2,8 @@ module Language.PureScript.CST.Traversals.Type where import Prelude -import Language.PureScript.CST.Types -import Language.PureScript.CST.Traversals +import Language.PureScript.CST.Types (Constraint(..), Labeled(..), Row(..), Type(..), Wrapped(..)) +import Language.PureScript.CST.Traversals (everythingOnSeparated) everythingOnTypes :: (r -> r -> r) -> (Type a -> r) -> Type a -> r everythingOnTypes op k = goTy diff --git a/src/Language/PureScript/CST/Utils.hs b/src/Language/PureScript/CST/Utils.hs index 2d7a152e2f..3d17a03ea2 100644 --- a/src/Language/PureScript/CST/Utils.hs +++ b/src/Language/PureScript/CST/Utils.hs @@ -11,10 +11,10 @@ import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text -import Language.PureScript.CST.Errors -import Language.PureScript.CST.Monad -import Language.PureScript.CST.Positions -import Language.PureScript.CST.Traversals.Type +import Language.PureScript.CST.Errors (ParserErrorType(..)) +import Language.PureScript.CST.Monad (Parser, addFailure, parseFail, pushBack) +import Language.PureScript.CST.Positions (TokenRange, binderRange, importDeclRange, recordUpdateRange, typeRange) +import Language.PureScript.CST.Traversals.Type (everythingOnTypes) import Language.PureScript.CST.Types import Language.PureScript.Names qualified as N import Language.PureScript.PSString (PSString, mkString) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index dae389474a..14d3e66610 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -13,7 +13,7 @@ import Control.Applicative (liftA2) import Control.Monad (forM, replicateM, void) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, asks) -import Control.Monad.Supply.Class +import Control.Monad.Supply.Class (MonadSupply, freshName) import Control.Monad.Writer (MonadWriter, runWriterT, writer) import Data.Bifunctor (first) @@ -28,20 +28,20 @@ import Data.String (fromString) import Data.Text (Text) import Data.Text qualified as T -import Language.PureScript.AST.SourcePos +import Language.PureScript.AST.SourcePos (SourceSpan, displayStartEndPos) import Language.PureScript.CodeGen.JS.Common as Common import Language.PureScript.CoreImp.AST (AST, InitializerEffects(..), everywhere, everywhereTopDownM, withSourceSpan) import Language.PureScript.CoreImp.AST qualified as AST import Language.PureScript.CoreImp.Module qualified as AST -import Language.PureScript.CoreImp.Optimizer -import Language.PureScript.CoreFn +import Language.PureScript.CoreImp.Optimizer (optimize) +import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Guard, Literal(..), Meta(..), Module(..), extractAnn, extractBinderAnn, modifyAnn, removeComments) import Language.PureScript.CoreFn.Laziness (applyLazinessTransform) -import Language.PureScript.Crash +import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..), MultipleErrors(..), rethrow, errorMessage, errorMessage', rethrowWithPosition, addHint) -import Language.PureScript.Names -import Language.PureScript.Options +import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), Qualified(..), QualifiedBy(..), runIdent, runModuleName, showIdent, showQualified) +import Language.PureScript.Options (CodegenTarget(..), Options(..)) import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Traversals (sndM) import Language.PureScript.Constants.Prim qualified as C diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index 2e17518e2e..e029468908 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -3,12 +3,12 @@ module Language.PureScript.CodeGen.JS.Common where import Prelude -import Data.Char +import Data.Char (isAlpha, isAlphaNum, isDigit, ord) import Data.Text (Text) import Data.Text qualified as T -import Language.PureScript.Crash -import Language.PureScript.Names +import Language.PureScript.Crash (internalError) +import Language.PureScript.Names (Ident(..), InternalIdentData(..), ModuleName(..), ProperName(..), unusedIdent) moduleNameToJs :: ModuleName -> Text moduleNameToJs (ModuleName mn) = diff --git a/src/Language/PureScript/CodeGen/JS/Printer.hs b/src/Language/PureScript/CodeGen/JS/Printer.hs index 905cc34b63..6740e2a7a1 100644 --- a/src/Language/PureScript/CodeGen/JS/Printer.hs +++ b/src/Language/PureScript/CodeGen/JS/Printer.hs @@ -9,7 +9,7 @@ import Prelude import Control.Arrow ((<+>)) import Control.Monad (forM, mzero) import Control.Monad.State (StateT, evalStateT) -import Control.PatternArrows +import Control.PatternArrows (Operator(..), OperatorTable(..), Pattern(..), buildPrettyPrinter, mkPattern, mkPattern') import Control.Arrow qualified as A import Data.Maybe (fromMaybe) @@ -18,12 +18,12 @@ import Data.Text qualified as T import Data.List.NonEmpty qualified as NEL (toList) import Language.PureScript.AST (SourceSpan(..)) -import Language.PureScript.CodeGen.JS.Common -import Language.PureScript.CoreImp.AST -import Language.PureScript.CoreImp.Module -import Language.PureScript.Comments -import Language.PureScript.Crash -import Language.PureScript.Pretty.Common +import Language.PureScript.CodeGen.JS.Common (identCharToText, isValidJsIdentifier, nameIsJsBuiltIn, nameIsJsReserved) +import Language.PureScript.CoreImp.AST (AST(..), BinaryOperator(..), CIComments(..), UnaryOperator(..), getSourceSpan) +import Language.PureScript.CoreImp.Module (Export(..), Import(..), Module(..)) +import Language.PureScript.Comments (Comment(..)) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Pretty.Common (Emit(..), PrinterState(..), SMap, StrPos(..), addMapping', currentIndent, intercalate, parensPos, runPlainString, withIndent) import Language.PureScript.PSString (PSString, decodeString, prettyPrintStringJS) -- TODO (Christoph): Get rid of T.unpack / pack diff --git a/src/Language/PureScript/Comments.hs b/src/Language/PureScript/Comments.hs index b53b06774a..ee05cd9c31 100644 --- a/src/Language/PureScript/Comments.hs +++ b/src/Language/PureScript/Comments.hs @@ -11,7 +11,7 @@ import Control.DeepSeq (NFData) import Data.Text (Text) import GHC.Generics (Generic) -import Data.Aeson.TH +import Data.Aeson.TH (Options(..), SumEncoding(..), defaultOptions, deriveJSON) data Comment = LineComment Text diff --git a/src/Language/PureScript/Constants/Prim.hs b/src/Language/PureScript/Constants/Prim.hs index bd8580e748..08391155da 100644 --- a/src/Language/PureScript/Constants/Prim.hs +++ b/src/Language/PureScript/Constants/Prim.hs @@ -3,7 +3,7 @@ -- | Various constants which refer to things in Prim module Language.PureScript.Constants.Prim where -import Language.PureScript.Names +import Language.PureScript.Names (ModuleName) import Language.PureScript.Constants.TH qualified as TH $(TH.declare do diff --git a/src/Language/PureScript/Constants/TH.hs b/src/Language/PureScript/Constants/TH.hs index 10ded13093..2bc8a56d84 100644 --- a/src/Language/PureScript/Constants/TH.hs +++ b/src/Language/PureScript/Constants/TH.hs @@ -74,8 +74,8 @@ import Control.Monad.Trans.RWS (RWS, execRWS) import Control.Monad.Trans.Writer (Writer, execWriter) import Control.Monad.Writer.Class (tell) import Data.String (String) -import Language.Haskell.TH -import Language.PureScript.Names hiding (Name) +import Language.Haskell.TH (Dec, Name, Pat, Q, Type, conP, implBidir, litP, mkName, patSynD, patSynSigD, prefixPatSyn, stringL) +import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..)) -- | Generate pattern synonyms corresponding to the provided PureScript -- declarations. diff --git a/src/Language/PureScript/CoreFn/Ann.hs b/src/Language/PureScript/CoreFn/Ann.hs index f6e70bd6e4..851f0da376 100644 --- a/src/Language/PureScript/CoreFn/Ann.hs +++ b/src/Language/PureScript/CoreFn/Ann.hs @@ -2,10 +2,10 @@ module Language.PureScript.CoreFn.Ann where import Prelude -import Language.PureScript.AST.SourcePos -import Language.PureScript.Comments -import Language.PureScript.CoreFn.Meta -import Language.PureScript.Types +import Language.PureScript.AST.SourcePos (SourceSpan) +import Language.PureScript.Comments (Comment) +import Language.PureScript.CoreFn.Meta (Meta) +import Language.PureScript.Types (SourceType) -- | -- Type alias for basic annotations diff --git a/src/Language/PureScript/CoreFn/Binders.hs b/src/Language/PureScript/CoreFn/Binders.hs index 997fff50a9..4b64b97c49 100644 --- a/src/Language/PureScript/CoreFn/Binders.hs +++ b/src/Language/PureScript/CoreFn/Binders.hs @@ -5,8 +5,8 @@ module Language.PureScript.CoreFn.Binders where import Prelude -import Language.PureScript.AST.Literals -import Language.PureScript.Names +import Language.PureScript.AST.Literals (Literal) +import Language.PureScript.Names (Ident, ProperName, ProperNameType(..), Qualified) -- | -- Data type for binders diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index 225f7a616e..6b339f7911 100644 --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -4,7 +4,7 @@ module Language.PureScript.CoreFn.CSE (optimizeCommonSubexpressions) where import Protolude hiding (pass) -import Control.Lens +import Control.Lens (At(..), makeLenses, non, view, (%~), (.=), (.~), (<>~), (^.)) import Control.Monad.Supply (Supply) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.RWS (MonadWriter, RWST, censor, evalRWST, listen, pass, tell) @@ -17,16 +17,16 @@ import Data.Maybe (fromJust) import Data.Semigroup (Min(..)) import Data.Semigroup.Generic (GenericSemigroupMonoid(..)) -import Language.PureScript.AST.Literals +import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.AST.SourcePos (nullSourceSpan) import Language.PureScript.Constants.Libs qualified as C import Language.PureScript.CoreFn.Ann (Ann) -import Language.PureScript.CoreFn.Binders -import Language.PureScript.CoreFn.Expr +import Language.PureScript.CoreFn.Binders (Binder(..)) +import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..)) import Language.PureScript.CoreFn.Meta (Meta(IsSyntheticApp)) -import Language.PureScript.CoreFn.Traversals +import Language.PureScript.CoreFn.Traversals (everywhereOnValues, traverseCoreFn) import Language.PureScript.Environment (dictTypeName) -import Language.PureScript.Names +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), Qualified(..), QualifiedBy(..), freshIdent, runIdent, toMaybeModuleName) import Language.PureScript.PSString (decodeString) -- | diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index c5edfd6151..5b0f821be4 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -11,19 +11,19 @@ import Data.Tuple (swap) import Data.List.NonEmpty qualified as NEL import Data.Map qualified as M -import Language.PureScript.AST.Literals -import Language.PureScript.AST.SourcePos -import Language.PureScript.AST.Traversals -import Language.PureScript.Comments -import Language.PureScript.CoreFn.Ann -import Language.PureScript.CoreFn.Binders -import Language.PureScript.CoreFn.Expr -import Language.PureScript.CoreFn.Meta -import Language.PureScript.CoreFn.Module -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Names -import Language.PureScript.Types +import Language.PureScript.AST.Literals (Literal(..)) +import Language.PureScript.AST.SourcePos (pattern NullSourceSpan, SourceSpan(..)) +import Language.PureScript.AST.Traversals (everythingOnValues) +import Language.PureScript.Comments (Comment) +import Language.PureScript.CoreFn.Ann (Ann, ssAnn) +import Language.PureScript.CoreFn.Binders (Binder(..)) +import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard) +import Language.PureScript.CoreFn.Meta (ConstructorType(..), Meta(..)) +import Language.PureScript.CoreFn.Module (Module(..)) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual) +import Language.PureScript.Types (SourceType) import Language.PureScript.AST qualified as A import Language.PureScript.Constants.Prim qualified as C diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index b2bb3441e7..aa8b13b942 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -7,9 +7,9 @@ import Prelude import Control.Arrow ((***)) -import Language.PureScript.AST.Literals -import Language.PureScript.CoreFn.Binders -import Language.PureScript.Names +import Language.PureScript.AST.Literals (Literal) +import Language.PureScript.CoreFn.Binders (Binder) +import Language.PureScript.Names (Ident, ProperName, ProperNameType(..), Qualified) import Language.PureScript.PSString (PSString) -- | diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 50b5010259..04b4eda425 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -11,7 +11,7 @@ import Prelude import Control.Applicative ((<|>)) -import Data.Aeson +import Data.Aeson (FromJSON(..), Object, Value(..), withObject, withText, (.:)) import Data.Aeson.Types (Parser, listParser) import Data.Map.Strict qualified as M import Data.Text (Text) @@ -20,10 +20,10 @@ import Data.Vector qualified as V import Data.Version (Version, parseVersion) import Language.PureScript.AST.SourcePos (SourceSpan(..)) -import Language.PureScript.AST.Literals -import Language.PureScript.CoreFn.Ann -import Language.PureScript.CoreFn -import Language.PureScript.Names +import Language.PureScript.AST.Literals (Literal(..)) +import Language.PureScript.CoreFn.Ann (Ann) +import Language.PureScript.CoreFn (Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Guard, Meta(..), Module(..)) +import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..), unusedIdent) import Language.PureScript.PSString (PSString) import Text.ParserCombinators.ReadP (readP_to_S) diff --git a/src/Language/PureScript/CoreFn/Laziness.hs b/src/Language/PureScript/CoreFn/Laziness.hs index 24d7290108..42197f88d2 100644 --- a/src/Language/PureScript/CoreFn/Laziness.hs +++ b/src/Language/PureScript/CoreFn/Laziness.hs @@ -16,11 +16,11 @@ import Data.Map.Monoidal qualified as M import Data.Semigroup (Max(..)) import Data.Set qualified as S -import Language.PureScript.AST.SourcePos +import Language.PureScript.AST.SourcePos (SourcePos(..), SourceSpan(..), nullSourceSpan) import Language.PureScript.Constants.Libs qualified as C -import Language.PureScript.CoreFn -import Language.PureScript.Crash -import Language.PureScript.Names +import Language.PureScript.CoreFn (Ann, Bind, Expr(..), Literal(..), Meta(..), ssAnn, traverseCoreFn) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), InternalIdentData(..), ModuleName, Qualified(..), QualifiedBy(..), runIdent, runModuleName, toMaybeModuleName) import Language.PureScript.PSString (mkString) -- This module is responsible for ensuring that the bindings in recursive diff --git a/src/Language/PureScript/CoreFn/Meta.hs b/src/Language/PureScript/CoreFn/Meta.hs index cc70425e03..0baddca29b 100644 --- a/src/Language/PureScript/CoreFn/Meta.hs +++ b/src/Language/PureScript/CoreFn/Meta.hs @@ -5,7 +5,7 @@ module Language.PureScript.CoreFn.Meta where import Prelude -import Language.PureScript.Names +import Language.PureScript.Names (Ident) -- | -- Metadata annotations diff --git a/src/Language/PureScript/CoreFn/Module.hs b/src/Language/PureScript/CoreFn/Module.hs index ee6feff8d3..09f5189c4a 100644 --- a/src/Language/PureScript/CoreFn/Module.hs +++ b/src/Language/PureScript/CoreFn/Module.hs @@ -4,10 +4,10 @@ import Prelude import Data.Map.Strict (Map) -import Language.PureScript.AST.SourcePos -import Language.PureScript.Comments -import Language.PureScript.CoreFn.Expr -import Language.PureScript.Names +import Language.PureScript.AST.SourcePos (SourceSpan) +import Language.PureScript.Comments (Comment) +import Language.PureScript.CoreFn.Expr (Bind) +import Language.PureScript.Names (Ident, ModuleName) -- | -- The CoreFn module representation diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 40a31ed3dc..340815be32 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -4,15 +4,15 @@ import Protolude hiding (Type, moduleName) import Control.Monad.Supply (Supply) import Data.List (lookup) -import Language.PureScript.AST.Literals -import Language.PureScript.AST.SourcePos -import Language.PureScript.CoreFn.Ann -import Language.PureScript.CoreFn.CSE -import Language.PureScript.CoreFn.Expr -import Language.PureScript.CoreFn.Module -import Language.PureScript.CoreFn.Traversals -import Language.PureScript.Label -import Language.PureScript.Types +import Language.PureScript.AST.Literals (Literal(..)) +import Language.PureScript.AST.SourcePos (nullSourceSpan) +import Language.PureScript.CoreFn.Ann (Ann) +import Language.PureScript.CoreFn.CSE (optimizeCommonSubexpressions) +import Language.PureScript.CoreFn.Expr (Bind, Expr(..)) +import Language.PureScript.CoreFn.Module (Module(..)) +import Language.PureScript.CoreFn.Traversals (everywhereOnValues) +import Language.PureScript.Label (Label(..)) +import Language.PureScript.Types (pattern REmptyKinded, Type(..)) import Language.PureScript.Constants.Libs qualified as C import Language.PureScript.Constants.Prim qualified as C diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index ea71162176..cae56cd016 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -12,7 +12,7 @@ import Prelude import Control.Arrow ((***)) import Data.Either (isLeft) import Data.Map.Strict qualified as M -import Data.Aeson hiding ((.=)) +import Data.Aeson (ToJSON(..), Value(..), object) import Data.Aeson qualified import Data.Aeson.Key qualified import Data.Aeson.Types (Pair) @@ -20,10 +20,10 @@ import Data.Version (Version, showVersion) import Data.Text (Text) import Data.Text qualified as T -import Language.PureScript.AST.Literals +import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.AST.SourcePos (SourceSpan(..)) -import Language.PureScript.CoreFn -import Language.PureScript.Names +import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Meta(..), Module(..)) +import Language.PureScript.Names (Ident, ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..), runIdent) import Language.PureScript.PSString (PSString) constructorTypeToJSON :: ConstructorType -> Value diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs index c223e37adc..16d6a34003 100644 --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -8,9 +8,9 @@ import Prelude import Control.Arrow (second, (***), (+++)) import Data.Bitraversable (bitraverse) -import Language.PureScript.AST.Literals -import Language.PureScript.CoreFn.Binders -import Language.PureScript.CoreFn.Expr +import Language.PureScript.AST.Literals (Literal(..)) +import Language.PureScript.CoreFn.Binders (Binder(..)) +import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..)) everywhereOnValues :: (Bind a -> Bind a) -> (Expr a -> Expr a) -> diff --git a/src/Language/PureScript/CoreImp/AST.hs b/src/Language/PureScript/CoreImp/AST.hs index 5812bfd284..9711890a3e 100644 --- a/src/Language/PureScript/CoreImp/AST.hs +++ b/src/Language/PureScript/CoreImp/AST.hs @@ -8,10 +8,10 @@ import Control.Monad.Identity (Identity(..), runIdentity) import Data.Text (Text) import Language.PureScript.AST (SourceSpan(..)) -import Language.PureScript.Comments +import Language.PureScript.Comments (Comment) import Language.PureScript.Names (ModuleName) import Language.PureScript.PSString (PSString) -import Language.PureScript.Traversals +import Language.PureScript.Traversals (sndM) -- | Built-in unary operators data UnaryOperator diff --git a/src/Language/PureScript/CoreImp/Module.hs b/src/Language/PureScript/CoreImp/Module.hs index 5460a012cd..bdf4b8185d 100644 --- a/src/Language/PureScript/CoreImp/Module.hs +++ b/src/Language/PureScript/CoreImp/Module.hs @@ -3,8 +3,8 @@ module Language.PureScript.CoreImp.Module where import Protolude import Data.List.NonEmpty qualified as NEL (NonEmpty) -import Language.PureScript.Comments -import Language.PureScript.CoreImp.AST +import Language.PureScript.Comments (Comment) +import Language.PureScript.CoreImp.AST (AST) import Language.PureScript.PSString (PSString) data Module = Module diff --git a/src/Language/PureScript/CoreImp/Optimizer.hs b/src/Language/PureScript/CoreImp/Optimizer.hs index 4892df9b20..e59738df76 100644 --- a/src/Language/PureScript/CoreImp/Optimizer.hs +++ b/src/Language/PureScript/CoreImp/Optimizer.hs @@ -24,13 +24,13 @@ import Prelude import Data.Text (Text) import Control.Monad.Supply.Class (MonadSupply) -import Language.PureScript.CoreImp.AST -import Language.PureScript.CoreImp.Optimizer.Blocks -import Language.PureScript.CoreImp.Optimizer.Common -import Language.PureScript.CoreImp.Optimizer.Inliner -import Language.PureScript.CoreImp.Optimizer.MagicDo -import Language.PureScript.CoreImp.Optimizer.TCO -import Language.PureScript.CoreImp.Optimizer.Unused +import Language.PureScript.CoreImp.AST (AST(..), InitializerEffects(..)) +import Language.PureScript.CoreImp.Optimizer.Blocks (collapseNestedBlocks, collapseNestedIfs) +import Language.PureScript.CoreImp.Optimizer.Common (applyAll, replaceIdents) +import Language.PureScript.CoreImp.Optimizer.Inliner (etaConvert, evaluateIifes, inlineCommonOperators, inlineCommonValues, inlineFnComposition, inlineFnIdentity, inlineUnsafeCoerce, inlineUnsafePartial, inlineVariables, unThunk) +import Language.PureScript.CoreImp.Optimizer.MagicDo (inlineST, magicDoEff, magicDoEffect, magicDoST) +import Language.PureScript.CoreImp.Optimizer.TCO (tco) +import Language.PureScript.CoreImp.Optimizer.Unused (removeCodeAfterReturnStatements, removeUndefinedApp, removeUnusedEffectFreeVars) -- | Apply a series of optimizer passes to simplified JavaScript code optimize :: forall m. MonadSupply m => [Text] -> [[AST]] -> m [[AST]] diff --git a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs index c4e8c40af9..add5d7c953 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Blocks.hs @@ -6,7 +6,7 @@ module Language.PureScript.CoreImp.Optimizer.Blocks import Prelude -import Language.PureScript.CoreImp.AST +import Language.PureScript.CoreImp.AST (AST(..), BinaryOperator(..), everywhere) -- | Collapse blocks which appear nested directly below another block collapseNestedBlocks :: AST -> AST diff --git a/src/Language/PureScript/CoreImp/Optimizer/Common.hs b/src/Language/PureScript/CoreImp/Optimizer/Common.hs index b984fcf0a5..ac63f6a2bb 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Common.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Common.hs @@ -7,8 +7,8 @@ import Data.Text (Text) import Data.List (foldl') import Data.Maybe (fromMaybe) -import Language.PureScript.Crash -import Language.PureScript.CoreImp.AST +import Language.PureScript.Crash (internalError) +import Language.PureScript.CoreImp.AST (AST(..), everything, everywhere) import Language.PureScript.Names (ModuleName) import Language.PureScript.PSString (PSString) diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs index 0e3dd5a8c5..e7314df971 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -23,8 +23,8 @@ import Data.Text qualified as T import Language.PureScript.Names (ModuleName) import Language.PureScript.PSString (PSString, mkString) -import Language.PureScript.CoreImp.AST -import Language.PureScript.CoreImp.Optimizer.Common +import Language.PureScript.CoreImp.AST (AST(..), BinaryOperator(..), InitializerEffects(..), UnaryOperator(..), everywhere, everywhereTopDown, everywhereTopDownM, getSourceSpan) +import Language.PureScript.CoreImp.Optimizer.Common (pattern Ref, applyAll, isReassigned, isRebound, isUpdated, removeFromBlock, replaceIdent, replaceIdents) import Language.PureScript.AST (SourceSpan(..)) import Language.PureScript.Constants.Libs qualified as C import Language.PureScript.Constants.Prim qualified as C diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs index 5b933c2cdb..b591675793 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs @@ -7,8 +7,8 @@ import Protolude (ordNub) import Data.Maybe (fromJust, isJust) -import Language.PureScript.CoreImp.AST -import Language.PureScript.CoreImp.Optimizer.Common +import Language.PureScript.CoreImp.AST (AST(..), InitializerEffects(..), UnaryOperator(..), everything, everywhere, everywhereTopDown) +import Language.PureScript.CoreImp.Optimizer.Common (pattern Ref) import Language.PureScript.Names (ModuleName) import Language.PureScript.PSString (mkString) import Language.PureScript.Constants.Libs qualified as C diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index 7defbe66c3..34746ae3db 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -9,7 +9,7 @@ import Control.Monad.State (State, evalState, get, modify) import Data.Functor (($>), (<&>)) import Data.Set qualified as S import Data.Text (Text, pack) -import Language.PureScript.CoreImp.AST +import Language.PureScript.CoreImp.AST (AST(..), InitializerEffects(..), UnaryOperator(..), everything, everywhereTopDownM) import Language.PureScript.AST.SourcePos (SourceSpan) import Safe (headDef, tailSafe) diff --git a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs index a06eaf5660..7b7acd1279 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs @@ -12,8 +12,8 @@ import Data.Monoid (Any(..)) import Data.Set qualified as S import Data.Text (Text) -import Language.PureScript.CoreImp.AST -import Language.PureScript.CoreImp.Optimizer.Common +import Language.PureScript.CoreImp.AST (AST(..), InitializerEffects(..), everything, everywhere) +import Language.PureScript.CoreImp.Optimizer.Common (removeFromBlock) import Language.PureScript.Constants.Prim qualified as C removeCodeAfterReturnStatements :: AST -> AST diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index e05cf220aa..e4460183af 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -34,7 +34,7 @@ import Cheapskate qualified import Language.PureScript qualified as P import Language.PureScript.Docs.Types -import Language.PureScript.Docs.RenderedCode hiding (sp) +import Language.PureScript.Docs.RenderedCode (Link(..), outputWith) import Language.PureScript.Docs.Render qualified as Render import Language.PureScript.CST qualified as CST diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index 530feba933..82139ccbe4 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -15,8 +15,8 @@ import Data.List (partition) import Data.Text (Text) import Data.Text qualified as T -import Language.PureScript.Docs.RenderedCode -import Language.PureScript.Docs.Types +import Language.PureScript.Docs.RenderedCode (RenderedCode, RenderedCodeElement(..), outputWith) +import Language.PureScript.Docs.Types (ChildDeclaration(..), ChildDeclarationInfo(..), Declaration(..), Module(..), ignorePackage) import Language.PureScript qualified as P import Language.PureScript.Docs.Render qualified as Render diff --git a/src/Language/PureScript/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs index 3570ecf2fe..0da65d2251 100644 --- a/src/Language/PureScript/Docs/Collect.hs +++ b/src/Language/PureScript/Docs/Collect.hs @@ -17,7 +17,7 @@ import System.IO.UTF8 (readUTF8FileT, readUTF8FilesT) import Language.PureScript.Docs.Convert.ReExports (updateReExports) import Language.PureScript.Docs.Prim (primModules) -import Language.PureScript.Docs.Types +import Language.PureScript.Docs.Types (InPackage(..), Module(..), asModule, displayPackageError, ignorePackage) import Language.PureScript.AST qualified as P import Language.PureScript.CST qualified as P diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 094577f80a..9e3ff10cf6 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -16,7 +16,7 @@ import Data.String (String) import Data.Text qualified as T import Language.PureScript.Docs.Convert.Single (convertSingleModule) -import Language.PureScript.Docs.Types +import Language.PureScript.Docs.Types (Declaration(..), DeclarationInfo(..), KindInfo(..), Module(..), Type') import Language.PureScript.CST qualified as CST import Language.PureScript.AST qualified as P import Language.PureScript.Crash qualified as P diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 9ce51d4433..9574f0fe7d 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -5,13 +5,13 @@ module Language.PureScript.Docs.Convert.ReExports import Prelude import Control.Arrow ((&&&), first, second) -import Control.Monad +import Control.Monad (foldM, (<=<)) import Control.Monad.Reader.Class (MonadReader, ask) import Control.Monad.State.Class (MonadState, gets, modify) import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.State.Strict (execState) -import Data.Either +import Data.Either (partitionEithers) import Data.Foldable (fold, traverse_) import Data.Map (Map) import Data.Maybe (mapMaybe) diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 50a6fe0c88..b3b15e7b4f 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -9,7 +9,7 @@ import Control.Category ((>>>)) import Data.Text qualified as T -import Language.PureScript.Docs.Types +import Language.PureScript.Docs.Types (ChildDeclaration(..), ChildDeclarationInfo(..), Declaration(..), DeclarationInfo(..), KindInfo(..), Module(..), Type', convertFundepsToStrings, isType, isTypeClass) import Language.PureScript.AST qualified as P import Language.PureScript.Comments qualified as P diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 4b19adbac3..801a64bc6f 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -11,7 +11,7 @@ import Data.Functor (($>)) import Data.Text (Text) import Data.Text qualified as T import Data.Map qualified as Map -import Language.PureScript.Docs.Types +import Language.PureScript.Docs.Types (Declaration(..), DeclarationInfo(..), Module(..), Type', convertFundepsToStrings) import Language.PureScript.Constants.Prim qualified as P import Language.PureScript.Crash qualified as P diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 31629d0fe8..3a0038d989 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -16,8 +16,8 @@ import Data.Text (Text) import Data.Text qualified as T import Language.PureScript.Docs.RenderedCode -import Language.PureScript.Docs.Types -import Language.PureScript.Docs.Utils.MonoidExtras +import Language.PureScript.Docs.Types (ChildDeclaration(..), ChildDeclarationInfo(..), Constraint', Declaration(..), DeclarationInfo(..), KindInfo(..), Type', isTypeClassMember, kindSignatureForKeyword) +import Language.PureScript.Docs.Utils.MonoidExtras (mintersperse) import Language.PureScript.AST qualified as P import Language.PureScript.Environment qualified as P diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index 7234778bc0..a0d55988d9 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -21,16 +21,16 @@ import Data.List (uncons) import Control.Arrow ((<+>)) import Control.PatternArrows as PA -import Language.PureScript.Crash -import Language.PureScript.Label -import Language.PureScript.Names -import Language.PureScript.Pretty.Types -import Language.PureScript.Roles -import Language.PureScript.Types +import Language.PureScript.Crash (internalError) +import Language.PureScript.Label (Label) +import Language.PureScript.Names (coerceProperName) +import Language.PureScript.Pretty.Types (PrettyPrintConstraint, PrettyPrintType(..), convertPrettyPrintType, prettyPrintLabel) +import Language.PureScript.Roles (Role, displayRole) +import Language.PureScript.Types (Type) import Language.PureScript.PSString (prettyPrintString) -import Language.PureScript.Docs.RenderedCode.Types -import Language.PureScript.Docs.Utils.MonoidExtras +import Language.PureScript.Docs.RenderedCode.Types (RenderedCode, keywordForall, roleAnn, sp, syntax, typeCtor, typeOp, typeVar) +import Language.PureScript.Docs.Utils.MonoidExtras (mintersperse) typeLiterals :: Pattern () PrettyPrintType RenderedCode typeLiterals = mkPattern match diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 9b8c6f9b5b..c1374899f5 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -45,7 +45,7 @@ import Data.Text qualified as T import Data.ByteString.Lazy qualified as BS import Data.Text.Encoding qualified as TE -import Language.PureScript.Names +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), moduleNameFromString, runIdent, runModuleName) import Language.PureScript.AST (Associativity(..)) -- | Given a list of actions, attempt them all, returning the first success. diff --git a/src/Language/PureScript/Docs/Tags.hs b/src/Language/PureScript/Docs/Tags.hs index 2b9a2b0172..e3651c9fa0 100644 --- a/src/Language/PureScript/Docs/Tags.hs +++ b/src/Language/PureScript/Docs/Tags.hs @@ -11,7 +11,7 @@ import Data.List (sort) import Data.Maybe (mapMaybe) import Data.Text qualified as T import Language.PureScript.AST (SourceSpan, sourcePosLine, spanStart) -import Language.PureScript.Docs.Types +import Language.PureScript.Docs.Types (ChildDeclaration(..), Declaration(..), Module(..)) tags :: Module -> [(String, Int)] tags = map (first T.unpack) . concatMap dtags . modDeclarations diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index d9ac6ab849..c4e6cbecaa 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -19,7 +19,7 @@ import Data.Aeson.BetterErrors import Data.Map qualified as Map import Data.Time.Clock (UTCTime) import Data.Time.Format qualified as TimeFormat -import Data.Version +import Data.Version (Version(..), showVersion) import Data.Aeson qualified as A import Data.Text qualified as T import Data.Vector qualified as V @@ -33,7 +33,7 @@ import Language.PureScript.Roles qualified as P import Language.PureScript.Types qualified as P import Paths_purescript qualified as Paths -import Web.Bower.PackageMeta hiding (Version, displayError) +import Web.Bower.PackageMeta (BowerError, PackageMeta(..), PackageName, asPackageMeta, parsePackageName, runPackageName, showBowerError) import Language.PureScript.Docs.RenderedCode as ReExports (RenderedCode, diff --git a/src/Language/PureScript/Docs/Utils/MonoidExtras.hs b/src/Language/PureScript/Docs/Utils/MonoidExtras.hs index 0d4d0bfd7f..6f2bf370e7 100644 --- a/src/Language/PureScript/Docs/Utils/MonoidExtras.hs +++ b/src/Language/PureScript/Docs/Utils/MonoidExtras.hs @@ -1,6 +1,6 @@ module Language.PureScript.Docs.Utils.MonoidExtras where -import Data.Monoid +import Data.Monoid (Monoid(..), (<>)) mintersperse :: (Monoid m) => m -> [m] -> m mintersperse _ [] = mempty diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index ab995eb12e..a1ef8c3fbe 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -20,12 +20,12 @@ import Data.Text (Text) import Data.Text qualified as T import Data.List.NonEmpty qualified as NEL -import Language.PureScript.AST.SourcePos -import Language.PureScript.Crash -import Language.PureScript.Names -import Language.PureScript.Roles -import Language.PureScript.TypeClassDictionaries -import Language.PureScript.Types +import Language.PureScript.AST.SourcePos (nullSourceAnn) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, QualifiedBy, coerceProperName) +import Language.PureScript.Roles (Role(..)) +import Language.PureScript.TypeClassDictionaries (NamedDict) +import Language.PureScript.Types (SourceConstraint, SourceType, Type(..), eqType, srcTypeConstructor) import Language.PureScript.Constants.Prim qualified as C -- | The @Environment@ defines all values and types which are currently in scope: diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index bcdfee61d2..4fc63d4419 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -9,10 +9,10 @@ import Protolude (unsnoc) import Control.Arrow ((&&&)) import Control.Exception (displayException) import Control.Lens (both, head1, over) -import Control.Monad +import Control.Monad (forM, unless) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Trans.State.Lazy -import Control.Monad.Writer +import Control.Monad.Trans.State.Lazy (State, evalState, get, put) +import Control.Monad.Writer (Last(..), MonadWriter(..), censor) import Data.Bifunctor (first, second) import Data.Bitraversable (bitraverse) import Data.Char (isSpace) @@ -37,17 +37,17 @@ import Language.PureScript.AST import Language.PureScript.Bundle qualified as Bundle import Language.PureScript.Constants.Libs qualified as C import Language.PureScript.Constants.Prim qualified as C -import Language.PureScript.Crash +import Language.PureScript.Crash (internalError) import Language.PureScript.CST.Errors qualified as CST import Language.PureScript.CST.Print qualified as CST import Language.PureScript.Label (Label(..)) import Language.PureScript.Names -import Language.PureScript.Pretty +import Language.PureScript.Pretty (prettyPrintBinderAtom, prettyPrintLabel, prettyPrintObjectKey, prettyPrintSuggestedType, prettyPrintValue, typeAsBox, typeAtomAsBox, typeDiffAsBox) import Language.PureScript.Pretty.Common (endWith) import Language.PureScript.PSString (decodeStringWithReplacement) -import Language.PureScript.Roles -import Language.PureScript.Traversals -import Language.PureScript.Types +import Language.PureScript.Roles (Role, displayRole) +import Language.PureScript.Traversals (sndM) +import Language.PureScript.Types (Constraint(..), ConstraintData(..), RowListItem(..), SourceConstraint, SourceType, Type(..), eraseForAllKindAnnotations, eraseKindApps, everywhereOnTypesTopDownM, getAnnForType, overConstraintArgs, rowFromList, rowToList, srcTUnknown) import Language.PureScript.Publish.BoxesHelpers qualified as BoxHelpers import System.Console.ANSI qualified as ANSI import System.FilePath (makeRelative) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 83cd88147f..12838a1bcd 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -28,13 +28,13 @@ import Data.Version (showVersion) import Data.Map qualified as M import Data.List.NonEmpty qualified as NEL -import Language.PureScript.AST +import Language.PureScript.AST (Associativity, Declaration(..), DeclarationRef(..), Fixity(..), ImportDeclarationType, Module(..), NameSource(..), Precedence, SourceSpan, pattern TypeFixityDeclaration, pattern ValueFixityDeclaration, getTypeOpRef, getValueOpRef) import Language.PureScript.AST.Declarations.ChainId (ChainId) -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Names -import Language.PureScript.TypeClassDictionaries -import Language.PureScript.Types +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (DataDeclType, Environment(..), FunctionalDependency, NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..), dictTypeName, makeTypeClassData) +import Language.PureScript.Names (Ident, ModuleName, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, isPlainIdent) +import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) +import Language.PureScript.Types (SourceConstraint, SourceType, srcInstanceType) import Paths_purescript as Paths diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index a7b4eb5095..746eec259b 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -20,25 +20,25 @@ module Language.PureScript.Ide import Protolude hiding (moduleName) -import "monad-logger" Control.Monad.Logger +import "monad-logger" Control.Monad.Logger (MonadLogger, logWarnN) import Data.Map qualified as Map import Data.Text qualified as T import Language.PureScript qualified as P import Language.PureScript.Ide.CaseSplit qualified as CS -import Language.PureScript.Ide.Command -import Language.PureScript.Ide.Completion -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Externs -import Language.PureScript.Ide.Filter -import Language.PureScript.Ide.Imports hiding (Import) -import Language.PureScript.Ide.Imports.Actions -import Language.PureScript.Ide.Matcher -import Language.PureScript.Ide.Prim -import Language.PureScript.Ide.Rebuild -import Language.PureScript.Ide.SourceFile -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util +import Language.PureScript.Ide.Command (Command(..), ImportCommand(..), ListType(..)) +import Language.PureScript.Ide.Completion (CompletionOptions, completionFromMatch, getCompletions, getExactCompletions, simpleExport) +import Language.PureScript.Ide.Error (IdeError(..)) +import Language.PureScript.Ide.Externs (readExternFile) +import Language.PureScript.Ide.Filter (Filter) +import Language.PureScript.Ide.Imports (parseImportsFromFile) +import Language.PureScript.Ide.Imports.Actions (addImplicitImport, addImportForIdentifier, addQualifiedImport, answerRequest) +import Language.PureScript.Ide.Matcher (Matcher) +import Language.PureScript.Ide.Prim (idePrimDeclarations) +import Language.PureScript.Ide.Rebuild (rebuildFileAsync, rebuildFileSync) +import Language.PureScript.Ide.SourceFile (parseModulesFromFiles) +import Language.PureScript.Ide.State (getAllModules, getLoadedModulenames, insertExterns, insertModule, populateVolatileState, populateVolatileStateSync, resetIdeState) +import Language.PureScript.Ide.Types (Annotation(..), Ide, IdeConfiguration(..), IdeDeclarationAnn(..), IdeEnvironment(..), Success(..)) +import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration, namespaceForDeclaration, withEmptyAnn) import Language.PureScript.Ide.Usage (findUsages) import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist, doesFileExist) import System.FilePath ((), normalise) diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index db2174ebe1..56cb464f05 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -29,10 +29,10 @@ import Data.Text qualified as T import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST -import Language.PureScript.Externs -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Types +import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..)) +import Language.PureScript.Ide.Error (IdeError(..)) +import Language.PureScript.Ide.State (cachedRebuild, getExternFiles) +import Language.PureScript.Ide.Types (Ide) type Constructor = (P.ProperName 'P.ConstructorName, [P.SourceType]) diff --git a/src/Language/PureScript/Ide/Command.hs b/src/Language/PureScript/Ide/Command.hs index ace3a05a1e..ae4b6c9d8e 100644 --- a/src/Language/PureScript/Ide/Command.hs +++ b/src/Language/PureScript/Ide/Command.hs @@ -17,15 +17,15 @@ module Language.PureScript.Ide.Command where import Protolude import Control.Monad.Fail (fail) -import Data.Aeson +import Data.Aeson (FromJSON(..), withObject, (.!=), (.:), (.:?)) import Data.Map qualified as Map import Data.Set qualified as Set import Language.PureScript qualified as P -import Language.PureScript.Ide.CaseSplit -import Language.PureScript.Ide.Completion -import Language.PureScript.Ide.Filter -import Language.PureScript.Ide.Matcher -import Language.PureScript.Ide.Types +import Language.PureScript.Ide.CaseSplit (WildcardAnnotations, explicitAnnotations, noAnnotations) +import Language.PureScript.Ide.Completion (CompletionOptions, defaultCompletionOptions) +import Language.PureScript.Ide.Filter (Filter) +import Language.PureScript.Ide.Matcher (Matcher) +import Language.PureScript.Ide.Types (IdeDeclarationAnn, IdeNamespace) data Command = Load [P.ModuleName] diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs index 78edbf6a96..87fe81de9b 100644 --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -11,16 +11,16 @@ module Language.PureScript.Ide.Completion import Protolude hiding ((<&>), moduleName) -import Control.Lens hiding (op, (&)) -import Data.Aeson +import Control.Lens ((.~), (<&>), (^.)) +import Data.Aeson (FromJSON(..), withObject, (.!=), (.:?)) import Data.Map qualified as Map import Data.Text qualified as T import Language.PureScript qualified as P import Language.PureScript.Ide.Error (prettyPrintTypeSingleLine) -import Language.PureScript.Ide.Filter -import Language.PureScript.Ide.Matcher +import Language.PureScript.Ide.Filter (Filter, applyFilters, exactFilter) +import Language.PureScript.Ide.Matcher (Matcher, runMatcher) import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util +import Language.PureScript.Ide.Util (identT, identifierFromIdeDeclaration, namespaceForDeclaration, properNameT, typeOperatorAliasT, valueOperatorAliasT) -- | Applies the CompletionFilters and the Matcher to the given Modules -- and sorts the found Completions according to the Matching Score diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index cb7105358d..8a23f574e0 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -17,12 +17,12 @@ module Language.PureScript.Ide.Error , prettyPrintTypeSingleLine ) where -import Data.Aeson +import Data.Aeson (KeyValue(..), ToJSON(..), Value, object) import Data.Aeson.Types qualified as Aeson import Data.Aeson.KeyMap qualified as KM import Data.Text qualified as T import Language.PureScript qualified as P -import Language.PureScript.Errors.JSON +import Language.PureScript.Errors.JSON (toJSONError) import Language.PureScript.Ide.Types (ModuleIdent, Completion(..)) import Protolude diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index df9edabcb1..120c2da4f6 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -8,14 +8,14 @@ module Language.PureScript.Ide.Externs import Protolude hiding (to, from, (&)) import Codec.CBOR.Term as Term -import Control.Lens hiding (anyOf) -import "monad-logger" Control.Monad.Logger +import Control.Lens (preview, view, (&), (^.)) +import "monad-logger" Control.Monad.Logger (MonadLogger, logErrorN) import Data.Version (showVersion) import Data.Text qualified as Text import Language.PureScript qualified as P import Language.PureScript.Make.Monad qualified as Make import Language.PureScript.Ide.Error (IdeError (..)) -import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Types (IdeDataConstructor(..), IdeDeclaration(..), IdeDeclarationAnn(..), IdeType(..), IdeTypeClass(..), IdeTypeOperator(..), IdeTypeSynonym(..), IdeValue(..), IdeValueOperator(..), _IdeDeclType, anyOf, emptyAnn, ideTypeKind, ideTypeName) import Language.PureScript.Ide.Util (properNameT) readExternFile diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs index f3c693673c..9bb29d6e49 100644 --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -26,19 +26,19 @@ module Language.PureScript.Ide.Filter import Protolude hiding (isPrefixOf, Prefix) import Control.Monad.Fail (fail) -import Data.Aeson +import Data.Aeson (FromJSON(..), withObject, (.:), (.:?)) import Data.Text (isPrefixOf) import Data.Set qualified as Set import Data.Map qualified as Map import Language.PureScript.Ide.Filter.Declaration (DeclarationType) -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Imports -import Language.PureScript.Ide.Util +import Language.PureScript.Ide.Types (IdeDeclarationAnn, IdeNamespace, ModuleMap, declarationType) +import Language.PureScript.Ide.Imports (Import, sliceImportSection) +import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration, namespaceForDeclaration) import Language.PureScript qualified as P import Data.Text qualified as T -import Language.PureScript.Ide.Filter.Imports +import Language.PureScript.Ide.Filter.Imports (matchImport) newtype Filter = Filter (Either (Set P.ModuleName) DeclarationFilter) deriving Show diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs index c3bd6fead3..7875f7851c 100644 --- a/src/Language/PureScript/Ide/Filter/Declaration.hs +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -5,7 +5,7 @@ module Language.PureScript.Ide.Filter.Declaration import Protolude hiding (isPrefixOf) import Control.Monad.Fail (fail) -import Data.Aeson +import Data.Aeson (FromJSON(..), ToJSON(..), withText) data DeclarationType = Value diff --git a/src/Language/PureScript/Ide/Filter/Imports.hs b/src/Language/PureScript/Ide/Filter/Imports.hs index fcdf0fcab7..bd1d70065d 100644 --- a/src/Language/PureScript/Ide/Filter/Imports.hs +++ b/src/Language/PureScript/Ide/Filter/Imports.hs @@ -3,8 +3,8 @@ module Language.PureScript.Ide.Filter.Imports where import Protolude hiding (isPrefixOf) -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Imports +import Language.PureScript.Ide.Types (IdeDataConstructor(..), IdeDeclaration(..), IdeDeclarationAnn(..), IdeType(..), IdeTypeClass(..), IdeTypeOperator(..), IdeTypeSynonym(..), IdeValue(..), IdeValueOperator(..)) +import Language.PureScript.Ide.Imports (Import(..)) import Language.PureScript qualified as P diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index cc788308c4..b96f090a7f 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -32,8 +32,8 @@ import Data.List.NonEmpty qualified as NE import Data.Text qualified as T import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Util +import Language.PureScript.Ide.Error (IdeError(..)) +import Language.PureScript.Ide.Util (ideReadFile) data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) deriving (Eq, Show) diff --git a/src/Language/PureScript/Ide/Imports/Actions.hs b/src/Language/PureScript/Ide/Imports/Actions.hs index 38d80148bc..bc79f2184d 100644 --- a/src/Language/PureScript/Ide/Imports/Actions.hs +++ b/src/Language/PureScript/Ide/Imports/Actions.hs @@ -19,14 +19,14 @@ import Data.Map qualified as Map import Data.Text qualified as T import Language.PureScript qualified as P import Language.PureScript.Constants.Prim qualified as C -import Language.PureScript.Ide.Completion -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Filter -import Language.PureScript.Ide.Imports -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Prim -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util +import Language.PureScript.Ide.Completion (getExactMatches) +import Language.PureScript.Ide.Error (IdeError(..)) +import Language.PureScript.Ide.Filter (Filter) +import Language.PureScript.Ide.Imports (Import(..), parseImportsFromFile', prettyPrintImportSection) +import Language.PureScript.Ide.State (getAllModules) +import Language.PureScript.Ide.Prim (idePrimDeclarations) +import Language.PureScript.Ide.Types (Ide, IdeDeclaration(..), IdeType(..), Match(..), Success(..), _IdeDeclModule, ideDtorName, ideDtorTypeName, ideTCName, ideTypeName, ideTypeOpName, ideValueOpName) +import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration) import System.IO.UTF8 (writeUTF8FileT) -- | Adds an implicit import like @import Prelude@ to a Sourcefile. diff --git a/src/Language/PureScript/Ide/Logging.hs b/src/Language/PureScript/Ide/Logging.hs index 4b1159deb8..925881b2d0 100644 --- a/src/Language/PureScript/Ide/Logging.hs +++ b/src/Language/PureScript/Ide/Logging.hs @@ -9,11 +9,11 @@ module Language.PureScript.Ide.Logging import Protolude -import "monad-logger" Control.Monad.Logger +import "monad-logger" Control.Monad.Logger (LogLevel(..), LoggingT, MonadLogger, filterLogger, logOtherN, runStdoutLoggingT) import Data.Text qualified as T -import Language.PureScript.Ide.Types -import System.Clock -import Text.Printf +import Language.PureScript.Ide.Types (IdeLogLevel(..)) +import System.Clock (Clock(..), TimeSpec, diffTimeSpec, getTime, toNanoSecs) +import Text.Printf (printf) runLogger :: MonadIO m => IdeLogLevel -> LoggingT m a -> m a runLogger logLevel' = diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs index a959c103dd..d77516bd32 100644 --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -22,12 +22,12 @@ module Language.PureScript.Ide.Matcher import Protolude import Control.Monad.Fail (fail) -import Data.Aeson +import Data.Aeson (FromJSON(..), withObject, (.:), (.:?)) import Data.Text qualified as T import Data.Text.Encoding qualified as TE -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util -import Text.EditDistance +import Language.PureScript.Ide.Types (IdeDeclarationAnn, Match) +import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration, unwrapMatch) +import Text.EditDistance (defaultEditCosts, levenshteinDistance) import Text.Regex.TDFA ((=~)) diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index ff60533d8f..398c013755 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -7,7 +7,7 @@ import Data.Map qualified as Map import Language.PureScript qualified as P import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.Environment qualified as PEnv -import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Types (IdeDeclaration(..), IdeDeclarationAnn(..), IdeType(..), IdeTypeClass(..), ModuleMap, emptyAnn) idePrimDeclarations :: ModuleMap [IdeDeclarationAnn] idePrimDeclarations = Map.fromList diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index d9eccc9d57..ebc34339eb 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -8,7 +8,7 @@ module Language.PureScript.Ide.Rebuild import Protolude hiding (moduleName) -import "monad-logger" Control.Monad.Logger +import "monad-logger" Control.Monad.Logger (LoggingT, MonadLogger, logDebug) import Data.List qualified as List import Data.Map.Lazy qualified as M import Data.Maybe (fromJust) @@ -20,11 +20,11 @@ import Language.PureScript.Make (ffiCodegen') import Language.PureScript.Make.Cache (CacheInfo(..), normaliseForCache) import Language.PureScript.CST qualified as CST -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Logging -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util +import Language.PureScript.Ide.Error (IdeError(..)) +import Language.PureScript.Ide.Logging (labelTimespec, logPerf, runLogger) +import Language.PureScript.Ide.State (cacheRebuild, getExternFiles, insertExterns, insertModule, populateVolatileState, updateCacheTimestamp) +import Language.PureScript.Ide.Types (Ide, IdeConfiguration(..), IdeEnvironment(..), ModuleMap, Success(..)) +import Language.PureScript.Ide.Util (ideReadFile) import System.Directory (getCurrentDirectory) -- | Given a filepath performs the following steps: diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index c862c63c87..a50b9de7a9 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -24,11 +24,11 @@ module Language.PureScript.Ide.Reexports import Protolude hiding (moduleName) -import Control.Lens hiding (anyOf, (&)) +import Control.Lens (set) import Data.Map qualified as Map import Language.PureScript qualified as P import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util +import Language.PureScript.Ide.Util (discardAnn) -- | Contains the module with resolved reexports, and possible failures data ReexportResult a diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index 333101a025..ea49fd6a55 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -26,9 +26,9 @@ import Control.Parallel.Strategies (withStrategy, parList, rseq) import Data.Map qualified as Map import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util +import Language.PureScript.Ide.Error (IdeError) +import Language.PureScript.Ide.Types (DefinitionSites, IdeNamespace(..), IdeNamespaced(..), TypeAnnotations) +import Language.PureScript.Ide.Util (ideReadFile) parseModule :: FilePath -> Text -> Either FilePath (FilePath, P.Module) parseModule path file = diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 03bb241d8d..06eed507e4 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -39,22 +39,22 @@ module Language.PureScript.Ide.State import Protolude hiding (moduleName, unzip) -import Control.Concurrent.STM -import Control.Lens hiding (anyOf, op, (&)) -import "monad-logger" Control.Monad.Logger -import Data.IORef +import Control.Concurrent.STM (TVar, modifyTVar, readTVar, readTVarIO, writeTVar) +import Control.Lens (Ixed(..), preview, view, (%~), (.~), (^.)) +import "monad-logger" Control.Monad.Logger (MonadLogger, logWarnN) +import Data.IORef (readIORef, writeIORef) import Data.Map.Lazy qualified as Map import Data.Time.Clock (UTCTime) import Data.Zip (unzip) import Language.PureScript qualified as P import Language.PureScript.Docs.Convert.Single (convertComments) -import Language.PureScript.Externs +import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..)) import Language.PureScript.Make.Actions (cacheDbFile) -import Language.PureScript.Ide.Externs -import Language.PureScript.Ide.Reexports -import Language.PureScript.Ide.SourceFile +import Language.PureScript.Ide.Externs (convertExterns) +import Language.PureScript.Ide.Reexports (ReexportResult(..), prettyPrintReexportResult, reexportHasFailures, resolveReexports) +import Language.PureScript.Ide.SourceFile (extractAstInformation) import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util +import Language.PureScript.Ide.Util (discardAnn, displayTimeSpec, logPerf, opNameT, properNameT, runLogger) import System.Directory (getModificationTime) -- | Resets all State inside psc-ide diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index b8fcda9dd5..db17094a29 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -8,7 +8,7 @@ module Language.PureScript.Ide.Types where import Protolude hiding (moduleName) import Control.Concurrent.STM (TVar) -import Control.Lens hiding (op, (.=)) +import Control.Lens (Getting, Traversal', makeLenses) import Control.Monad.Fail (fail) import Data.Aeson (ToJSON, FromJSON, (.=)) import Data.Aeson qualified as Aeson diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index 5d04654a3c..3e773efe5a 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -14,7 +14,7 @@ import Data.Set qualified as Set import Language.PureScript qualified as P import Language.PureScript.Ide.State (getAllModules, getFileState) import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util +import Language.PureScript.Ide.Util (identifierFromIdeDeclaration, namespaceForDeclaration) -- | -- How we find usages, given an IdeDeclaration and the module it was defined in: diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index f7f90f5236..854391dcae 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -32,15 +32,15 @@ module Language.PureScript.Ide.Util import Protolude hiding (decodeUtf8, encodeUtf8, to) -import Control.Lens hiding (op, (&)) -import Data.Aeson +import Control.Lens (Getting, to, (^.)) +import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode) import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding as TLE import Language.PureScript qualified as P import Language.PureScript.Ide.Error (IdeError(..)) import Language.PureScript.Ide.Logging -import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Types (IdeDeclaration(..), IdeDeclarationAnn(..), IdeNamespace(..), Match(..), emptyAnn, ideDtorName, ideSynonymName, ideTCName, ideTypeName, ideTypeOpName, ideValueIdent, ideValueOpName) import System.IO.UTF8 (readUTF8FileT) import System.Directory (makeAbsolute) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 820aefc080..5f88b079c3 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -20,8 +20,8 @@ import Data.Text (Text) import Data.Text qualified as T import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.State.Class -import Control.Monad.Reader.Class +import Control.Monad.State.Class (MonadState(..), gets, modify) +import Control.Monad.Reader.Class (MonadReader, asks) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.State.Strict (StateT, runStateT, evalStateT) import Control.Monad.Writer.Strict (Writer(), runWriter) diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs index d4fd68d770..d9e61e9cca 100644 --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -18,8 +18,8 @@ import Data.Maybe (mapMaybe) import Data.Text qualified as T import Language.PureScript qualified as P import Language.PureScript.Interactive.Directive qualified as D -import Language.PureScript.Interactive.Types -import System.Console.Haskeline +import Language.PureScript.Interactive.Types (Directive(..), PSCiState, psciExports, psciImports, psciLoadedExterns, replQueryStrings) +import System.Console.Haskeline (Completion(..), CompletionFunc, completeWordWithPrev, listFiles, simpleCompletion) -- Completions may read the state, but not modify it. type CompletionM = ReaderT PSCiState IO diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs index 35c064001c..4a75f0f362 100644 --- a/src/Language/PureScript/Interactive/Directive.hs +++ b/src/Language/PureScript/Interactive/Directive.hs @@ -9,7 +9,7 @@ import Data.Maybe (fromJust) import Data.List (isPrefixOf) import Data.Tuple (swap) -import Language.PureScript.Interactive.Types +import Language.PureScript.Interactive.Types (Directive(..)) -- | -- A mapping of directives to the different strings that can be used to invoke diff --git a/src/Language/PureScript/Interactive/Message.hs b/src/Language/PureScript/Interactive/Message.hs index f99aabbe86..800b614758 100644 --- a/src/Language/PureScript/Interactive/Message.hs +++ b/src/Language/PureScript/Interactive/Message.hs @@ -6,7 +6,7 @@ import Data.List (intercalate) import Data.Version (showVersion) import Paths_purescript qualified as Paths import Language.PureScript.Interactive.Directive qualified as D -import Language.PureScript.Interactive.Types +import Language.PureScript.Interactive.Types (Directive) -- Messages diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 3230a44321..61083eee2e 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -4,7 +4,7 @@ import Prelude import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST -import Language.PureScript.Interactive.Types +import Language.PureScript.Interactive.Types (ImportedModule, PSCiState, initialInteractivePrint, psciImportedModules, psciInteractivePrint, psciLetBindings) import System.Directory (getCurrentDirectory) import System.FilePath (pathSeparator, makeRelative) import System.IO.UTF8 (readUTF8FilesT) diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index 0347064dd7..d888683b6d 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -18,7 +18,7 @@ import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST import Language.PureScript.CST.Monad qualified as CSTM import Language.PureScript.Interactive.Directive qualified as D -import Language.PureScript.Interactive.Types +import Language.PureScript.Interactive.Types (Command(..), Directive(..), ReplQuery(..), parseReplQuery, replQueryStrings) -- | -- Parses a limited set of commands from from .purs-repl diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index bffde54883..c77d66c1d4 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -5,7 +5,7 @@ module Language.PureScript.Linter (lint, module L) where import Prelude -import Control.Monad.Writer.Class +import Control.Monad.Writer.Class (MonadWriter(..), censor) import Data.Maybe (mapMaybe) import Data.Set qualified as S @@ -14,11 +14,11 @@ import Data.Text qualified as Text import Control.Monad ((<=<)) import Language.PureScript.AST -import Language.PureScript.Errors +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage') import Language.PureScript.Linter.Exhaustive as L import Language.PureScript.Linter.Imports as L -import Language.PureScript.Names -import Language.PureScript.Types +import Language.PureScript.Names (Ident(..), Qualified(..), QualifiedBy(..), getIdentName, runIdent) +import Language.PureScript.Types (Constraint(..), SourceType, Type(..), everythingWithContextOnTypes) import Language.PureScript.Constants.Libs qualified as C -- | Lint the PureScript AST. diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 43dc0f80e9..0521eda985 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -11,25 +11,25 @@ module Language.PureScript.Linter.Exhaustive import Prelude import Protolude (ordNub) -import Control.Applicative +import Control.Applicative (Applicative(..)) import Control.Arrow (first, second) import Control.Monad (unless) -import Control.Monad.Writer.Class +import Control.Monad.Writer.Class (MonadWriter(..), censor) import Data.List (foldl', sortOn) import Data.Maybe (fromMaybe) import Data.Map qualified as M import Data.Text qualified as T -import Language.PureScript.AST.Binders -import Language.PureScript.AST.Declarations -import Language.PureScript.AST.Literals -import Language.PureScript.Crash -import Language.PureScript.Environment hiding (tyVar) -import Language.PureScript.Errors +import Language.PureScript.AST.Binders (Binder(..)) +import Language.PureScript.AST.Declarations (CaseAlternative(..), Declaration(..), ErrorMessageHint(..), Expr(..), Guard(..), GuardedExpr(..), pattern MkUnguarded, pattern ValueDecl, isTrueExpr) +import Language.PureScript.AST.Literals (Literal(..)) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (DataDeclType, Environment(..), TypeKind(..)) +import Language.PureScript.Errors (MultipleErrors, pattern NullSourceAnn, SimpleErrorMessage(..), SourceSpan, addHint, errorMessage') import Language.PureScript.Names as P import Language.PureScript.Pretty.Values (prettyPrintBinderAtom) -import Language.PureScript.Traversals +import Language.PureScript.Traversals (sndM) import Language.PureScript.Types as P import Language.PureScript.Constants.Prim qualified as C diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 9c88597978..e8a2eb0f2c 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -8,7 +8,7 @@ import Prelude import Protolude (ordNub) import Control.Monad (join, unless, foldM, (<=<)) -import Control.Monad.Writer.Class +import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Function (on) import Data.Foldable (for_) @@ -19,14 +19,14 @@ import Data.Traversable (forM) import Data.Text qualified as T import Data.Map qualified as M -import Language.PureScript.AST.Declarations -import Language.PureScript.AST.SourcePos -import Language.PureScript.Crash -import Language.PureScript.Errors +import Language.PureScript.AST.Declarations (Declaration(..), DeclarationRef(..), ExportSource, ImportDeclarationType(..), Module(..), getTypeRef, isExplicit) +import Language.PureScript.AST.SourcePos (SourceSpan) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage') import Language.PureScript.Names import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) -import Language.PureScript.Sugar.Names.Env -import Language.PureScript.Sugar.Names.Imports +import Language.PureScript.Sugar.Names.Env (Env, Exports(..), ImportRecord(..), Imports(..), envModuleExports, nullImports) +import Language.PureScript.Sugar.Names.Imports (ImportDef, findImports) import Language.PureScript.Constants.Prim qualified as C -- | diff --git a/src/Language/PureScript/Linter/Wildcards.hs b/src/Language/PureScript/Linter/Wildcards.hs index f224af6860..a8b5fcf23e 100644 --- a/src/Language/PureScript/Linter/Wildcards.hs +++ b/src/Language/PureScript/Linter/Wildcards.hs @@ -4,8 +4,8 @@ module Language.PureScript.Linter.Wildcards import Protolude hiding (Type) -import Language.PureScript.AST -import Language.PureScript.Types +import Language.PureScript.AST (Binder(..), Declaration, Expr(..), everywhereWithContextOnValues) +import Language.PureScript.Types (Type(..), WildcardData(..), everythingOnTypes, everywhereOnTypes) -- | -- Replaces `TypeWildcard _ UnnamedWildcard` with diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index ad361342c5..8340d77caa 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -13,10 +13,10 @@ import Prelude import Control.Concurrent.Lifted as C import Control.Exception.Base (onException) -import Control.Monad hiding (sequence) +import Control.Monad (foldM, unless, when) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.IO.Class -import Control.Monad.Supply +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Supply (evalSupplyT, runSupply, runSupplyT) import Control.Monad.Trans.Control (MonadBaseControl(..), control) import Control.Monad.Trans.State (runStateT) import Control.Monad.Writer.Class (MonadWriter(..), censor) @@ -29,20 +29,20 @@ import Data.Maybe (fromMaybe) import Data.Map qualified as M import Data.Set qualified as S import Data.Text qualified as T -import Language.PureScript.AST -import Language.PureScript.Crash +import Language.PureScript.AST (ErrorMessageHint(..), Module(..), SourceSpan(..), getModuleName, getModuleSourceSpan, importPrim) +import Language.PureScript.Crash (internalError) import Language.PureScript.CST qualified as CST import Language.PureScript.Docs.Convert qualified as Docs -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Externs -import Language.PureScript.Linter -import Language.PureScript.ModuleDependencies -import Language.PureScript.Names -import Language.PureScript.Renamer -import Language.PureScript.Sugar -import Language.PureScript.TypeChecker -import Language.PureScript.Make.BuildPlan +import Language.PureScript.Environment (initEnvironment) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors) +import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment, moduleToExternsFile) +import Language.PureScript.Linter (Name(..), lint, lintImports) +import Language.PureScript.ModuleDependencies (DependencyDepth(..), moduleSignature, sortModules) +import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName) +import Language.PureScript.Renamer (renameInModule) +import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv) +import Language.PureScript.TypeChecker (CheckState(..), emptyCheckState, typeCheckModule) +import Language.PureScript.Make.BuildPlan (BuildJobResult(..), BuildPlan(..), getResult) import Language.PureScript.Make.BuildPlan qualified as BuildPlan import Language.PureScript.Make.Cache qualified as Cache import Language.PureScript.Make.Actions as Actions diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 6c6d251bae..f138327c8d 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -13,11 +13,11 @@ module Language.PureScript.Make.Actions import Prelude -import Control.Monad hiding (sequence) +import Control.Monad (unless, when) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.IO.Class +import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (asks) -import Control.Monad.Supply +import Control.Monad.Supply (SupplyT) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Aeson (Value(String), (.=), object) @@ -34,26 +34,26 @@ import Data.Text.Encoding qualified as TE import Data.Time.Clock (UTCTime) import Data.Version (showVersion) import Language.JavaScript.Parser qualified as JS -import Language.PureScript.AST +import Language.PureScript.AST (SourcePos(..)) import Language.PureScript.Bundle qualified as Bundle import Language.PureScript.CodeGen.JS qualified as J -import Language.PureScript.CodeGen.JS.Printer +import Language.PureScript.CodeGen.JS.Printer (prettyPrintJS, prettyPrintJSWithSourceMaps) import Language.PureScript.CoreFn qualified as CF import Language.PureScript.CoreFn.ToJSON qualified as CFJ -import Language.PureScript.Crash +import Language.PureScript.Crash (internalError) import Language.PureScript.CST qualified as CST import Language.PureScript.Docs.Prim qualified as Docs.Prim import Language.PureScript.Docs.Types qualified as Docs -import Language.PureScript.Errors +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage') import Language.PureScript.Externs (ExternsFile, externsFileName) -import Language.PureScript.Make.Monad -import Language.PureScript.Make.Cache -import Language.PureScript.Names -import Language.PureScript.Options hiding (codegenTargets) +import Language.PureScript.Make.Monad (Make, copyFile, getTimestamp, getTimestampMaybe, hashFile, makeIO, readExternsFile, readJSONFile, readTextFile, writeCborFile, writeJSONFile, writeTextFile) +import Language.PureScript.Make.Cache (CacheDb, ContentHash, normaliseForCache) +import Language.PureScript.Names (Ident(..), ModuleName, runModuleName) +import Language.PureScript.Options (CodegenTarget(..), Options(..)) import Language.PureScript.Pretty.Common (SMap(..)) import Paths_purescript qualified as Paths -import SourceMap -import SourceMap.Types +import SourceMap (generate) +import SourceMap.Types (Mapping(..), Pos(..), SourceMapping(..)) import System.Directory (getCurrentDirectory) import System.FilePath ((), makeRelative, splitPath, normalise, splitDirectories) import System.FilePath.Posix qualified as Posix diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 7ac97532f1..3eba2359a3 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -14,22 +14,22 @@ import Prelude import Control.Concurrent.Async.Lifted as A import Control.Concurrent.Lifted as C import Control.Monad.Base (liftBase) -import Control.Monad hiding (sequence) +import Control.Monad (foldM) import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.Foldable (foldl') import Data.Map qualified as M import Data.Maybe (fromMaybe, mapMaybe) import Data.Time.Clock (UTCTime) -import Language.PureScript.AST -import Language.PureScript.Crash +import Language.PureScript.AST (Module, getModuleName) +import Language.PureScript.Crash (internalError) import Language.PureScript.CST qualified as CST -import Language.PureScript.Errors -import Language.PureScript.Externs +import Language.PureScript.Errors (MultipleErrors(..)) +import Language.PureScript.Externs (ExternsFile) import Language.PureScript.Make.Actions as Actions -import Language.PureScript.Make.Cache +import Language.PureScript.Make.Cache (CacheDb, CacheInfo, checkChanged) import Language.PureScript.Names (ModuleName) -import Language.PureScript.Sugar.Names.Env +import Language.PureScript.Sugar.Names.Env (Env, primEnv) import System.Directory (getCurrentDirectory) -- | The BuildPlan tracks information about our build progress, and holds all diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index dbb7c0607b..d8326ee129 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -27,21 +27,21 @@ import Control.Exception (fromException, tryJust) import Control.Monad (join, guard) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.IO.Class -import Control.Monad.Logger +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Logger (Logger, runLogger') import Control.Monad.Reader (MonadReader(..), ReaderT(..)) import Control.Monad.Trans.Control (MonadBaseControl(..)) -import Control.Monad.Trans.Except +import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Aeson qualified as Aeson import Data.ByteString qualified as B import Data.Text (Text) import Data.Text qualified as Text import Data.Time.Clock (UTCTime) -import Language.PureScript.Errors +import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), singleError) import Language.PureScript.Externs (ExternsFile, externsIsCurrentVersion) import Language.PureScript.Make.Cache (ContentHash, hash) -import Language.PureScript.Options +import Language.PureScript.Options (Options) import System.Directory (createDirectoryIfMissing, getModificationTime) import System.Directory qualified as Directory import System.FilePath (takeDirectory) diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index ae55e1138f..3bcb914fb6 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -10,13 +10,13 @@ module Language.PureScript.ModuleDependencies import Protolude hiding (head) import Data.Array ((!)) -import Data.Graph +import Data.Graph (SCC(..), graphFromEdges, reachable, stronglyConnComp) import Data.Set qualified as S -import Language.PureScript.AST +import Language.PureScript.AST (Declaration(..), ErrorMessageHint(..), Module(..), SourceSpan) import Language.PureScript.Constants.Prim qualified as C -import Language.PureScript.Crash -import Language.PureScript.Errors hiding (nonEmpty) -import Language.PureScript.Names +import Language.PureScript.Crash (internalError) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage', errorMessage'', parU) +import Language.PureScript.Names (ModuleName) -- | A list of modules with their transitive dependencies type ModuleGraph = [(ModuleName, [ModuleName])] diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 4783f4f165..e5df3610bf 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -9,14 +9,14 @@ import Prelude import Codec.Serialise (Serialise) import Control.Applicative ((<|>)) -import Control.Monad.Supply.Class +import Control.Monad.Supply.Class (MonadSupply(..)) import Control.DeepSeq (NFData) import Data.Functor.Contravariant (contramap) import Data.Vector qualified as V import GHC.Generics (Generic) -import Data.Aeson -import Data.Aeson.TH +import Data.Aeson (FromJSON(..), FromJSONKey(..), Options(..), SumEncoding(..), ToJSON(..), ToJSONKey(..), defaultOptions, parseJSON2, toJSON2, withArray) +import Data.Aeson.TH (deriveJSON) import Data.Text (Text) import Data.Text qualified as T diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index 6a30adb4e5..a62e776cad 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -14,7 +14,7 @@ import Data.Text qualified as T import Language.PureScript.AST (SourcePos(..), SourceSpan(..), nullSourceSpan) import Language.PureScript.CST.Lexer (isUnquotedKey) -import Text.PrettyPrint.Boxes hiding ((<>)) +import Text.PrettyPrint.Boxes (Box(..), emptyBox, text, top, vcat, (//)) import Text.PrettyPrint.Boxes qualified as Box parensT :: Text -> Text diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index e26f3cb131..e318d352f5 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -1,6 +1,3 @@ --- HLint is confused by the identifier `pattern` if PatternSynonyms is enabled. -{-# LANGUAGE NoPatternSynonyms #-} - -- | -- Pretty printer for Types -- @@ -29,15 +26,15 @@ import Data.Maybe (fromMaybe, catMaybes) import Data.Text (Text) import Data.Text qualified as T -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Names -import Language.PureScript.Pretty.Common -import Language.PureScript.Types +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (tyFunction, tyRecord) +import Language.PureScript.Names (OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified, coerceProperName, disqualify, showQualified) +import Language.PureScript.Pretty.Common (before, objectKeyRequiresQuoting) +import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), Type(..), WildcardData(..), eqType, rowToSortedList) import Language.PureScript.PSString (PSString, prettyPrintString, decodeString) import Language.PureScript.Label (Label(..)) -import Text.PrettyPrint.Boxes hiding ((<+>)) +import Text.PrettyPrint.Boxes (Box(..), hcat, hsep, left, moveRight, nullBox, render, text, top, vcat, (<>)) data PrettyPrintType = PPTUnknown Int diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index d0b0f823f2..85b6638fdc 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -16,15 +16,15 @@ import Data.List.NonEmpty qualified as NEL import Data.Monoid qualified as Monoid ((<>)) import Data.Text qualified as T -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Names -import Language.PureScript.Pretty.Common +import Language.PureScript.AST (AssocList(..), Binder(..), CaseAlternative(..), Declaration(..), DoNotationElement(..), Expr(..), Guard(..), GuardedExpr(..), Literal(..), PathNode(..), PathTree(..), TypeDeclarationData(..), pattern ValueDecl, WhereProvenance(..)) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Names (OpName(..), ProperName(..), Qualified(..), disqualify, runModuleName, showIdent) +import Language.PureScript.Pretty.Common (before, beforeWithSpace, parensT) import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox, prettyPrintObjectKey) import Language.PureScript.Types (Constraint(..)) import Language.PureScript.PSString (PSString, prettyPrintString) -import Text.PrettyPrint.Boxes +import Text.PrettyPrint.Boxes (Box, left, moveRight, text, vcat, vsep, (//), (<>)) -- TODO(Christoph): remove T.unpack s diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 58b502cb84..ed3dd4aba6 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -29,7 +29,7 @@ import Data.List (stripPrefix, (\\)) import Data.Text qualified as T import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Version +import Data.Version (Version) import Distribution.SPDX qualified as SPDX import Distribution.Parsec qualified as CabalParsec @@ -40,9 +40,9 @@ import System.Process (readProcess) import Web.Bower.PackageMeta (PackageMeta(..), PackageName, Repository(..)) import Web.Bower.PackageMeta qualified as Bower -import Language.PureScript.Publish.ErrorsWarnings -import Language.PureScript.Publish.Registry.Compat -import Language.PureScript.Publish.Utils +import Language.PureScript.Publish.ErrorsWarnings (InternalError(..), OtherError(..), PackageError(..), PackageWarning(..), RepositoryFieldError(..), UserError(..), printError, printWarnings) +import Language.PureScript.Publish.Registry.Compat (asPursJson, toBowerPackage) +import Language.PureScript.Publish.Utils (globRelative, purescriptSourceFiles) import Language.PureScript qualified as P (version, ModuleName) import Language.PureScript.CoreFn.FromJSON qualified as P import Language.PureScript.Docs qualified as D diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index ef08193b34..b855f68a41 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -19,16 +19,16 @@ import Control.Exception (IOException) import Data.Aeson.BetterErrors (ParseError, displayError) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe -import Data.Monoid -import Data.Version +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid (Any(..)) +import Data.Version (Version, showVersion) import Data.List.NonEmpty qualified as NonEmpty import Data.Text (Text) import Data.Text qualified as T import Language.PureScript.Docs.Types qualified as D import Language.PureScript qualified as P -import Language.PureScript.Publish.BoxesHelpers +import Language.PureScript.Publish.BoxesHelpers (Box, bulletedList, bulletedListT, indented, nullBox, para, printToStderr, spacer, successivelyIndented, vcat) import Web.Bower.PackageMeta (PackageName, runPackageName, showBowerError) import Web.Bower.PackageMeta qualified as Bower diff --git a/src/Language/PureScript/Publish/Utils.hs b/src/Language/PureScript/Publish/Utils.hs index 881af28904..3760729518 100644 --- a/src/Language/PureScript/Publish/Utils.hs +++ b/src/Language/PureScript/Publish/Utils.hs @@ -2,7 +2,7 @@ module Language.PureScript.Publish.Utils where import Prelude -import System.Directory +import System.Directory (getCurrentDirectory) import System.FilePath.Glob (Pattern, compile, globDir1) -- | Glob relative to the current directory, and produce relative pathnames. diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index 369ba80486..780095d039 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -5,7 +5,7 @@ module Language.PureScript.Renamer (renameInModule) where import Prelude -import Control.Monad.State +import Control.Monad.State (MonadState(..), State, gets, modify, runState, (>=>)) import Data.Functor ((<&>)) import Data.List (find) @@ -14,9 +14,9 @@ import Data.Map qualified as M import Data.Set qualified as S import Data.Text qualified as T -import Language.PureScript.CoreFn -import Language.PureScript.Names -import Language.PureScript.Traversals +import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), Expr(..), Literal(..), Module(..)) +import Language.PureScript.Names (Ident(..), Qualified(..), isBySourcePos, isPlainIdent, runIdent, showIdent) +import Language.PureScript.Traversals (eitherM, pairM, sndM) -- | -- The state object used in this module diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 91bbc4624e..4d713d5418 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -4,16 +4,16 @@ module Language.PureScript.Sugar (desugar, module S) where import Control.Category ((>>>)) -import Control.Monad +import Control.Monad ((>=>)) import Control.Monad.Error.Class (MonadError) import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.State.Class (MonadState) import Control.Monad.Writer.Class (MonadWriter) -import Language.PureScript.AST -import Language.PureScript.Errors -import Language.PureScript.Externs -import Language.PureScript.Linter.Imports +import Language.PureScript.AST (Module) +import Language.PureScript.Errors (MultipleErrors) +import Language.PureScript.Externs (ExternsFile) +import Language.PureScript.Linter.Imports (UsedImports) import Language.PureScript.Sugar.BindingGroups as S import Language.PureScript.Sugar.CaseDeclarations as S import Language.PureScript.Sugar.DoNotation as S diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs index 047d413edb..3ac5373621 100644 --- a/src/Language/PureScript/Sugar/AdoNotation.hs +++ b/src/Language/PureScript/Sugar/AdoNotation.hs @@ -7,11 +7,11 @@ import Prelude hiding (abs) import Control.Monad (foldM) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class +import Control.Monad.Supply.Class (MonadSupply) import Data.List (foldl') -import Language.PureScript.AST -import Language.PureScript.Errors -import Language.PureScript.Names +import Language.PureScript.AST (Binder(..), CaseAlternative(..), Declaration, DoNotationElement(..), Expr(..), pattern MkUnguarded, Module(..), SourceSpan, WhereProvenance(..), declSourceSpan, everywhereOnValuesM) +import Language.PureScript.Errors (MultipleErrors, parU, rethrowWithPosition) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Qualified(..), byMaybeModuleName, freshIdent') import Language.PureScript.Constants.Libs qualified as C -- | Replace all @AdoNotationBind@ and @AdoNotationValue@ constructors with diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 6298e2eefe..d2f9aebf2b 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -14,7 +14,7 @@ import Protolude (ordNub, swap) import Control.Monad ((<=<), guard) import Control.Monad.Error.Class (MonadError(..)) -import Data.Graph +import Data.Graph (SCC(..), stronglyConnComp, stronglyConnCompR) import Data.List (intersect, (\\)) import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty) import Data.Foldable (find) @@ -25,11 +25,11 @@ import Data.Map qualified as M import Data.Set qualified as S import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Errors hiding (nonEmpty) -import Language.PureScript.Names -import Language.PureScript.Types +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (NameKind) +import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors(..), SimpleErrorMessage(..), errorMessage', parU, positionedError) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName) +import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), everythingOnTypes) data VertexType = VertexDefinition diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 925bf3d484..bcae767715 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -16,13 +16,13 @@ import Data.Maybe (catMaybes, mapMaybe) import Control.Monad ((<=<), forM, replicateM, join, unless) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class +import Control.Monad.Supply.Class (MonadSupply) import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Names +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (NameKind(..)) +import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors(..), SimpleErrorMessage(..), addHint, errorMessage', parU, rethrow, withPosition) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident, Qualified(..), freshIdent') import Language.PureScript.TypeChecker.Monad (guardWith) -- | diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index f6b9a819ec..8542a5a790 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -7,13 +7,13 @@ import Prelude import Control.Applicative ((<|>)) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class +import Control.Monad.Supply.Class (MonadSupply) import Data.Maybe (fromMaybe) import Data.Monoid (First(..)) -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Errors -import Language.PureScript.Names +import Language.PureScript.AST (Binder(..), CaseAlternative(..), Declaration, DoNotationElement(..), Expr(..), pattern MkUnguarded, Module(..), SourceSpan, pattern ValueDecl, WhereProvenance(..), binderNames, declSourceSpan, everywhereOnValuesM) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage', parU, rethrowWithPosition) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Qualified(..), byMaybeModuleName, freshIdent') import Language.PureScript.Constants.Libs qualified as C -- | Replace all @DoNotationBind@ and @DoNotationValue@ constructors with diff --git a/src/Language/PureScript/Sugar/LetPattern.hs b/src/Language/PureScript/Sugar/LetPattern.hs index 2d4b01d8f3..519487d912 100644 --- a/src/Language/PureScript/Sugar/LetPattern.hs +++ b/src/Language/PureScript/Sugar/LetPattern.hs @@ -9,8 +9,8 @@ import Prelude import Data.List (groupBy) import Data.Function (on) -import Language.PureScript.AST -import Language.PureScript.Crash +import Language.PureScript.AST (Binder, CaseAlternative(..), Declaration(..), Expr(..), pattern MkUnguarded, Module(..), SourceAnn, WhereProvenance, everywhereOnValues) +import Language.PureScript.Crash (internalError) -- | Replace every @BoundValueDeclaration@ in @Let@ expressions with @Case@ -- expressions. diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 2fc947c738..2202633667 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -13,9 +13,9 @@ import Prelude import Protolude (sortOn, swap, foldl') import Control.Arrow (first, second, (&&&)) -import Control.Monad +import Control.Monad (foldM, when, (>=>)) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State.Lazy +import Control.Monad.State.Lazy (MonadState, StateT(..), gets, modify) import Control.Monad.Writer (MonadWriter(..)) import Data.List.NonEmpty qualified as NEL @@ -24,16 +24,16 @@ import Data.Map qualified as M import Data.Set qualified as S import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Errors -import Language.PureScript.Externs -import Language.PureScript.Linter.Imports -import Language.PureScript.Names -import Language.PureScript.Sugar.Names.Env -import Language.PureScript.Sugar.Names.Exports -import Language.PureScript.Sugar.Names.Imports -import Language.PureScript.Traversals -import Language.PureScript.Types +import Language.PureScript.Crash (internalError) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage'', nonEmpty, parU, warnAndRethrow, warnAndRethrowWithPosition) +import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..), ExternsImport(..)) +import Language.PureScript.Linter.Imports (Name(..), UsedImports) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..)) +import Language.PureScript.Sugar.Names.Env (Env, Exports(..), ImportProvenance(..), ImportRecord(..), Imports(..), checkImportConflicts, nullImports, primEnv) +import Language.PureScript.Sugar.Names.Exports (findExportable, resolveExports) +import Language.PureScript.Sugar.Names.Imports (resolveImports, resolveModuleImport) +import Language.PureScript.Traversals (defS, sndM) +import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), everywhereOnTypesM) -- | -- Replaces all local names with qualified names. diff --git a/src/Language/PureScript/Sugar/Names/Common.hs b/src/Language/PureScript/Sugar/Names/Common.hs index 9783d66dd3..572d35eb23 100644 --- a/src/Language/PureScript/Sugar/Names/Common.hs +++ b/src/Language/PureScript/Sugar/Names/Common.hs @@ -9,9 +9,9 @@ import Data.Foldable (for_) import Data.List (group, sort, (\\)) import Data.Maybe (mapMaybe) -import Language.PureScript.AST -import Language.PureScript.Errors -import Language.PureScript.Names +import Language.PureScript.AST (DeclarationRef(..), SourceSpan) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage, errorMessage, warnWithPosition) +import Language.PureScript.Names (Name(..)) -- | -- Warns about duplicate values in a list of declaration refs. diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index a83c555144..2ab8b00d5c 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -20,7 +20,7 @@ module Language.PureScript.Sugar.Names.Env import Prelude -import Control.Monad +import Control.Monad (forM_, when) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -33,11 +33,11 @@ import Data.Map qualified as M import Data.Set qualified as S import Language.PureScript.Constants.Prim qualified as C -import Language.PureScript.AST -import Language.PureScript.Crash +import Language.PureScript.AST (ExportSource(..), SourceSpan, internalModuleSourceSpan, nullSourceSpan) +import Language.PureScript.Crash (internalError) import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Names +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage') +import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, getQual) -- | -- The details for an import: the name of the thing that is being imported diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 70f0402fcb..cbe273f828 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -5,7 +5,7 @@ module Language.PureScript.Sugar.Names.Exports import Prelude -import Control.Monad +import Control.Monad (filterM, foldM, liftM2, unless, void, when) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Error.Class (MonadError(..)) @@ -16,10 +16,10 @@ import Data.Maybe (fromMaybe, mapMaybe) import Data.Map qualified as M import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.Sugar.Names.Env +import Language.PureScript.Crash (internalError) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage', rethrow, rethrowWithPosition, warnAndRethrow) +import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), disqualifyFor, isQualifiedWith, isUnqualified) +import Language.PureScript.Sugar.Names.Env (Env, ExportMode(..), Exports(..), ImportRecord(..), Imports(..), checkImportConflicts, envModuleExports, exportType, exportTypeClass, exportTypeOp, exportValue, exportValueOp, nullExports) import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) -- | diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 91577f83af..3a43faf7fd 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -7,7 +7,7 @@ module Language.PureScript.Sugar.Names.Imports import Prelude -import Control.Monad +import Control.Monad (foldM, when) import Control.Monad.Error.Class (MonadError(..)) import Data.Foldable (for_, traverse_) @@ -15,11 +15,11 @@ import Data.Maybe (fromMaybe) import Data.Map qualified as M import Data.Set qualified as S -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.Sugar.Names.Env +import Language.PureScript.AST (Declaration(..), DeclarationRef(..), ErrorMessageHint(..), ExportSource(..), ImportDeclarationType(..), Module(..), SourceSpan, internalModuleSourceSpan) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage', rethrow) +import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName) +import Language.PureScript.Sugar.Names.Env (Env, Exports(..), ImportProvenance(..), ImportRecord(..), Imports(..), envModuleExports, nullImports) type ImportDef = (SourceSpan, ImportDeclarationType, Maybe ModuleName) diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 01e46e74b9..88b93b899c 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -7,14 +7,14 @@ import Prelude import Control.Monad (forM) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class +import Control.Monad.Supply.Class (MonadSupply) import Data.Foldable (toList) import Data.List (foldl') import Data.Maybe (catMaybes) import Language.PureScript.AST import Language.PureScript.Environment (NameKind(..)) -import Language.PureScript.Errors -import Language.PureScript.Names +import Language.PureScript.Errors (MultipleErrors, rethrowWithPosition) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident, Qualified(..), freshIdent') import Language.PureScript.PSString (PSString) diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 3531380ed0..bb06486e82 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -16,15 +16,15 @@ module Language.PureScript.Sugar.Operators import Prelude import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Errors -import Language.PureScript.Externs -import Language.PureScript.Names -import Language.PureScript.Sugar.Operators.Binders -import Language.PureScript.Sugar.Operators.Expr -import Language.PureScript.Sugar.Operators.Types +import Language.PureScript.Crash (internalError) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage', parU, rethrow, rethrowWithPosition) +import Language.PureScript.Externs (ExternsFile(..), ExternsFixity(..), ExternsTypeFixity(..)) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), freshIdent') +import Language.PureScript.Sugar.Operators.Binders (matchBinderOperators) +import Language.PureScript.Sugar.Operators.Expr (matchExprOperators) +import Language.PureScript.Sugar.Operators.Types (matchTypeOperators) import Language.PureScript.Traversals (defS, sndM) -import Language.PureScript.Types +import Language.PureScript.Types (Constraint(..), SourceType, Type(..), everywhereOnTypesTopDownM, overConstraintArgs) import Control.Monad (unless, (<=<)) import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Sugar/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs index 2b36230d8a..29725c711a 100644 --- a/src/Language/PureScript/Sugar/Operators/Binders.hs +++ b/src/Language/PureScript/Sugar/Operators/Binders.hs @@ -2,12 +2,12 @@ module Language.PureScript.Sugar.Operators.Binders where import Prelude -import Control.Monad.Except +import Control.Monad.Except (MonadError) -import Language.PureScript.AST -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.Sugar.Operators.Common +import Language.PureScript.AST (Associativity, Binder(..), SourceSpan) +import Language.PureScript.Errors (MultipleErrors) +import Language.PureScript.Names (OpName(..), OpNameType(..), Qualified(..)) +import Language.PureScript.Sugar.Operators.Common (matchOperators) matchBinderOperators :: MonadError MultipleErrors m diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index fe65bb342b..1a18f88014 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -2,11 +2,11 @@ module Language.PureScript.Sugar.Operators.Common where import Prelude -import Control.Monad.State -import Control.Monad.Except +import Control.Monad.State (guard, join) +import Control.Monad.Except (MonadError(..)) import Data.Either (rights) -import Data.Functor.Identity +import Data.Functor.Identity (Identity) import Data.List (sortOn) import Data.Maybe (mapMaybe, fromJust) import Data.List.NonEmpty qualified as NEL @@ -16,10 +16,10 @@ import Text.Parsec qualified as P import Text.Parsec.Pos qualified as P import Text.Parsec.Expr qualified as P -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Errors -import Language.PureScript.Names +import Language.PureScript.AST (Associativity(..), ErrorMessageHint(..), SourceSpan) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors(..), SimpleErrorMessage(..)) +import Language.PureScript.Names (OpName, Qualified, eraseOpName) type Chain a = [Either a a] diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index efb3842bfd..0815eb1610 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -2,16 +2,16 @@ module Language.PureScript.Sugar.Operators.Expr where import Prelude -import Control.Monad.Except -import Data.Functor.Identity +import Control.Monad.Except (MonadError) +import Data.Functor.Identity (Identity) import Text.Parsec qualified as P import Text.Parsec.Expr qualified as P -import Language.PureScript.AST -import Language.PureScript.Names -import Language.PureScript.Sugar.Operators.Common -import Language.PureScript.Errors +import Language.PureScript.AST (Associativity, Expr(..), SourceSpan) +import Language.PureScript.Names (OpName(..), OpNameType(..), Qualified(..)) +import Language.PureScript.Sugar.Operators.Common (Chain, matchOperators, token) +import Language.PureScript.Errors (MultipleErrors) matchExprOperators :: MonadError MultipleErrors m diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs index 2f9d242acb..81001511cb 100644 --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -2,12 +2,12 @@ module Language.PureScript.Sugar.Operators.Types where import Prelude -import Control.Monad.Except -import Language.PureScript.AST -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.Sugar.Operators.Common -import Language.PureScript.Types +import Control.Monad.Except (MonadError) +import Language.PureScript.AST (Associativity, SourceSpan) +import Language.PureScript.Errors (MultipleErrors) +import Language.PureScript.Names (OpName(..), OpNameType(..), Qualified(..)) +import Language.PureScript.Sugar.Operators.Common (matchOperators) +import Language.PureScript.Types (SourceType, Type(..), srcTypeApp) matchTypeOperators :: MonadError MultipleErrors m diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index b5ed36bb14..a5bfa59b90 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -12,9 +12,9 @@ import Prelude import Control.Arrow (first, second) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State -import Control.Monad.Supply.Class -import Data.Graph +import Control.Monad.State (MonadState(..), StateT, evalStateT, modify) +import Control.Monad.Supply.Class (MonadSupply) +import Data.Graph (SCC(..), stronglyConnComp) import Data.List (find, partition) import Data.List.NonEmpty (nonEmpty) import Data.Map qualified as M @@ -24,14 +24,14 @@ import Data.Set qualified as S import Data.Text (Text) import Data.Traversable (for) import Language.PureScript.Constants.Prim qualified as C -import Language.PureScript.Crash -import Language.PureScript.Environment +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (DataDeclType(..), NameKind(..), TypeClassData(..), dictTypeName, function, makeTypeClassData, primClasses, primCoerceClasses, primIntClasses, primRowClasses, primRowListClasses, primSymbolClasses, primTypeErrorClasses, tyRecord) import Language.PureScript.Errors hiding (isExported, nonEmpty) -import Language.PureScript.Externs +import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..)) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, runIdent) import Language.PureScript.PSString (mkString) -import Language.PureScript.Sugar.CaseDeclarations +import Language.PureScript.Sugar.CaseDeclarations (desugarCases) import Language.PureScript.TypeClassDictionaries (superclassName) import Language.PureScript.Types diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 622d872874..3b4c019521 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -7,15 +7,15 @@ import Protolude (note) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class (MonadSupply) import Data.List (foldl', find, unzip5) -import Language.PureScript.AST -import Language.PureScript.AST.Utils +import Language.PureScript.AST (Binder(..), CaseAlternative(..), DataConstructorDeclaration(..), Declaration(..), Expr(..), pattern MkUnguarded, Module(..), SourceSpan(..), TypeInstanceBody(..), pattern ValueDecl) +import Language.PureScript.AST.Utils (UnwrappedTypeConstructor(..), lamCase, unguarded, unwrapTypeConstructor) import Language.PureScript.Constants.Libs qualified as Libs -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Names +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (DataDeclType(..), NameKind(..)) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage') +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), freshIdent) import Language.PureScript.PSString (mkString) -import Language.PureScript.Types +import Language.PureScript.Types (SourceType, Type(..), WildcardData(..), replaceAllTypeVars, srcTypeApp, srcTypeConstructor, srcTypeLevelString) import Language.PureScript.TypeChecker (checkNewtype) -- | Elaborates deriving instance declarations by code generation. diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 25e3f63910..ef00748d67 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -11,10 +11,10 @@ import Prelude import Control.Monad (unless) import Control.Monad.Error.Class (MonadError(..)) -import Language.PureScript.AST -import Language.PureScript.Names -import Language.PureScript.Environment -import Language.PureScript.Errors +import Language.PureScript.AST (Declaration(..), ErrorMessageHint(..), Expr(..), GuardedExpr(..), KindSignatureFor(..), pattern MkUnguarded, Module(..), RoleDeclarationData(..), TypeDeclarationData(..), TypeInstanceBody(..), pattern ValueDecl, declSourceSpan, everywhereOnValuesTopDownM) +import Language.PureScript.Names (Ident, coerceProperName) +import Language.PureScript.Environment (DataDeclType(..), NameKind) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage', rethrow) -- | -- Replace all top level type declarations in a module with type annotations diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 8d210bac86..3f5043ad24 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -19,7 +19,7 @@ import Control.Monad.Writer.Class (MonadWriter, tell) import Data.Foldable (for_, traverse_, toList) import Data.List (nub, nubBy, (\\), sort, group) -import Data.Maybe +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Either (partitionEithers) import Data.Text (Text) import Data.List.NonEmpty qualified as NEL @@ -30,13 +30,13 @@ import Data.Text qualified as T import Language.PureScript.AST import Language.PureScript.AST.Declarations.ChainId (ChainId) import Language.PureScript.Constants.Libs qualified as Libs -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Linter -import Language.PureScript.Linter.Wildcards -import Language.PureScript.Names -import Language.PureScript.Roles +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (DataDeclType(..), Environment(..), FunctionalDependency, NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..), isDictTypeName, kindArity, makeTypeClassData, nominalRolesForKind, tyFunction) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage', positionedError, rethrow, warnAndRethrow) +import Language.PureScript.Linter (checkExhaustiveExpr) +import Language.PureScript.Linter.Wildcards (ignoreWildcardsUnderCompleteTypeSignatures) +import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, isPlainIdent, mkQualified) +import Language.PureScript.Roles (Role) import Language.PureScript.Sugar.Names.Env (Exports(..)) import Language.PureScript.TypeChecker.Kinds as T import Language.PureScript.TypeChecker.Monad as T @@ -44,8 +44,8 @@ import Language.PureScript.TypeChecker.Roles as T import Language.PureScript.TypeChecker.Synonyms as T import Language.PureScript.TypeChecker.Types as T import Language.PureScript.TypeChecker.Unify (varIfUnknown) -import Language.PureScript.TypeClassDictionaries -import Language.PureScript.Types +import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) +import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), containsForAll, eqType, everythingOnTypes, freeTypeVariables, overConstraintArgs, srcInstanceType, unapplyTypes) addDataType :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index 533910bb14..b0114618bf 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -15,23 +15,23 @@ import Data.List (init, last, zipWith3, (!!)) import Data.Map qualified as M import Data.These (These(..), mergeTheseWith, these) -import Control.Monad.Supply.Class -import Language.PureScript.AST -import Language.PureScript.AST.Utils +import Control.Monad.Supply.Class (MonadSupply) +import Language.PureScript.AST (Binder(..), CaseAlternative(..), ErrorMessageHint(..), Expr(..), InstanceDerivationStrategy(..), Literal(..), SourceSpan, nullSourceSpan) +import Language.PureScript.AST.Utils (UnwrappedTypeConstructor(..), lam, lamCase, lamCase2, mkBinder, mkCtor, mkCtorBinder, mkLit, mkRef, mkVar, unguarded, unwrapTypeConstructor, utcQTyCon) import Language.PureScript.Constants.Libs qualified as Libs import Language.PureScript.Constants.Prim qualified as Prim -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Errors hiding (nonEmpty) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (DataDeclType(..), Environment(..), FunctionalDependency(..), TypeClassData(..), TypeKind(..), kindType, (-:>)) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, internalCompilerError) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names -import Language.PureScript.PSString -import Language.PureScript.Sugar.TypeClasses -import Language.PureScript.TypeChecker.Entailment -import Language.PureScript.TypeChecker.Monad -import Language.PureScript.TypeChecker.Synonyms -import Language.PureScript.TypeClassDictionaries -import Language.PureScript.Types +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify) +import Language.PureScript.PSString (PSString, mkString) +import Language.PureScript.Sugar.TypeClasses (superClassDictionaryNames) +import Language.PureScript.TypeChecker.Entailment (InstanceContext, findDicts) +import Language.PureScript.TypeChecker.Monad (CheckState, getEnv, getTypeClassDictionaries, unsafeCheckCurrentModule) +import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) +import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..)) +import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, SourceType, Type(..), completeBinderList, eqType, everythingOnTypes, replaceAllTypeVars, srcTypeVar, usedTypeVariables) -- | Extract the name of the newtype appearing in the last type argument of -- a derived newtype instance. diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 5774f578f2..74d70a3aa7 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -15,9 +15,9 @@ import Protolude (ordNub) import Control.Arrow (second, (&&&)) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State +import Control.Monad.State (MonadState(..), MonadTrans(..), StateT(..), evalStateT, execStateT, foldM, gets, guard, join, modify, zipWithM, zipWithM_, (<=<)) import Control.Monad.Supply.Class (MonadSupply(..)) -import Control.Monad.Writer +import Control.Monad.Writer (Any(..), MonadWriter(..), WriterT(..)) import Data.Either (lefts, partitionEithers) import Data.Foldable (for_, fold, toList) @@ -33,18 +33,18 @@ import Data.Text qualified as T import Data.List.NonEmpty (NonEmpty(..)) import Data.List.NonEmpty qualified as NEL -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.TypeChecker.Entailment.Coercible -import Language.PureScript.TypeChecker.Entailment.IntCompare +import Language.PureScript.AST (Binder(..), ErrorMessageHint(..), Expr(..), Literal(..), pattern NullSourceSpan, everywhereOnValuesTopDownM, nullSourceSpan) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (Environment(..), FunctionalDependency(..), TypeClassData(..), dictTypeName, kindRow, tyBoolean, tyInt, tyString) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, addHints, errorMessage, rethrow) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual) +import Language.PureScript.TypeChecker.Entailment.Coercible (GivenSolverState(..), WantedSolverState(..), initialGivenSolverState, initialWantedSolverState, insoluble, solveGivens, solveWanteds) +import Language.PureScript.TypeChecker.Entailment.IntCompare (mkFacts, mkRelation, solveRelation) import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds') -import Language.PureScript.TypeChecker.Monad +import Language.PureScript.TypeChecker.Monad (CheckState(..), withErrorMessageHint) import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) -import Language.PureScript.TypeChecker.Unify -import Language.PureScript.TypeClassDictionaries +import Language.PureScript.TypeChecker.Unify (freshTypeWithKind, substituteType, unifyTypes) +import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..), superclassName) import Language.PureScript.Types import Language.PureScript.Label (Label(..)) import Language.PureScript.PSString (PSString, mkString, decodeString) diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 648a3aa696..bbc0e49411 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -35,17 +35,17 @@ import Data.Text (Text) import Data.Map qualified as M import Data.Set qualified as S -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Errors hiding (inScope) -import Language.PureScript.Names -import Language.PureScript.TypeChecker.Kinds hiding (kindOf) -import Language.PureScript.TypeChecker.Monad -import Language.PureScript.TypeChecker.Roles -import Language.PureScript.TypeChecker.Synonyms -import Language.PureScript.TypeChecker.Unify -import Language.PureScript.Roles -import Language.PureScript.Types +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (DataDeclType(..), Environment(..), TypeKind(..), unapplyKinds) +import Language.PureScript.Errors (DeclarationRef(..), ErrorMessageHint(..), ExportSource, ImportDeclarationType(..), MultipleErrors, SimpleErrorMessage(..), SourceAnn, errorMessage) +import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), byMaybeModuleName, toMaybeModuleName) +import Language.PureScript.TypeChecker.Kinds (elaborateKind, freshKindWithKind, unifyKinds') +import Language.PureScript.TypeChecker.Monad (CheckState(..)) +import Language.PureScript.TypeChecker.Roles (lookupRoles) +import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) +import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, substituteType) +import Language.PureScript.Roles (Role(..)) +import Language.PureScript.Types (Constraint(..), SourceType, Type(..), completeBinderList, containsUnknowns, everythingOnTypes, isMonoType, replaceAllTypeVars, rowFromList, srcConstraint, srcTypeApp, unapplyTypes) import Language.PureScript.Constants.Prim qualified as Prim -- | State of the given constraints solver. diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index fe1a582b4d..b39d980c3e 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -29,10 +29,10 @@ import Prelude import Control.Arrow ((***)) import Control.Lens ((^.), _1, _2, _3) -import Control.Monad +import Control.Monad (join, unless, void, when, (<=<)) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State -import Control.Monad.Supply.Class +import Control.Monad.State (MonadState, gets, modify) +import Control.Monad.Supply.Class (MonadSupply(..)) import Data.Bifunctor (first) import Data.Bitraversable (bitraverse) @@ -47,15 +47,15 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Traversable (for) -import Language.PureScript.Crash +import Language.PureScript.Crash (HasCallStack, internalError) import Language.PureScript.Environment qualified as E import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.TypeChecker.Monad +import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified) +import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScope, skolemize) -import Language.PureScript.TypeChecker.Synonyms +import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) import Language.PureScript.Types -import Language.PureScript.Pretty.Types +import Language.PureScript.Pretty.Types (prettyPrintType) generalizeUnknowns :: [(Unknown, SourceType)] -> SourceType -> SourceType generalizeUnknowns unks ty = diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index fb02264de5..ba27d0299b 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -9,23 +9,23 @@ import Prelude import Control.Arrow (second) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State +import Control.Monad.State (MonadState(..), StateT(..), forM_, gets, guard, join, modify, when, (<=<)) import Control.Monad.Writer.Class (MonadWriter(..), censor) -import Data.Maybe +import Data.Maybe (fromMaybe) import Data.Map qualified as M import Data.Set qualified as S import Data.Text (Text, isPrefixOf, unpack) import Data.List.NonEmpty qualified as NEL import Language.PureScript.Crash (internalError) -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.Pretty.Types -import Language.PureScript.Pretty.Values -import Language.PureScript.TypeClassDictionaries -import Language.PureScript.Types +import Language.PureScript.Environment (Environment(..), NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..)) +import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition) +import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName) +import Language.PureScript.Pretty.Types (prettyPrintType) +import Language.PureScript.Pretty.Values (prettyPrintValue) +import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) +import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar) import Text.PrettyPrint.Boxes (render) newtype UnkLevel = UnkLevel (NEL.NonEmpty Unknown) diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index 885d3f8c11..fb43b2e821 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -24,11 +24,11 @@ import Data.Set qualified as S import Data.Semigroup (Any(..)) import Data.Text (Text) -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.Roles -import Language.PureScript.Types +import Language.PureScript.Environment (Environment(..), TypeKind(..)) +import Language.PureScript.Errors (DataConstructorDeclaration(..), MultipleErrors, RoleDeclarationData(..), SimpleErrorMessage(..), errorMessage) +import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..)) +import Language.PureScript.Roles (Role(..)) +import Language.PureScript.Types (Constraint(..), SourceType, Type(..), freeTypeVariables, unapplyTypes) -- | -- A map of a type's formal parameter names to their roles. This type's diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 2f5567ccf7..3c49d2bf36 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -16,12 +16,12 @@ import Data.Foldable (traverse_) import Data.Functor.Identity (Identity(), runIdentity) import Data.Set (Set, fromList, notMember) import Data.Text (Text) -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Errors +import Language.PureScript.AST (Binder(..), ErrorMessageHint(..), Expr(..), SourceAnn, SourceSpan, everythingWithContextOnValues, everywhereWithContextOnValuesM, nonEmptySpan) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), positionedError, singleError) import Language.PureScript.Traversals (defS) -import Language.PureScript.TypeChecker.Monad -import Language.PureScript.Types +import Language.PureScript.TypeChecker.Monad (CheckState(..)) +import Language.PureScript.Types (SkolemScope(..), SourceType, Type(..), everythingOnTypes, everywhereOnTypesM, replaceTypeVars) -- | Generate a new skolem constant newSkolemConstant :: MonadState CheckState m => m Int diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 8fdd798990..e99f1c829c 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -16,14 +16,14 @@ import Data.List (uncons) import Data.List.Ordered (minusBy') import Data.Ord (comparing) -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.TypeChecker.Monad -import Language.PureScript.TypeChecker.Skolems -import Language.PureScript.TypeChecker.Unify -import Language.PureScript.Types +import Language.PureScript.AST (ErrorMessageHint(..), Expr(..), pattern NullSourceAnn) +import Language.PureScript.Crash (internalError) +import Language.PureScript.Environment (tyFunction, tyRecord) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, internalCompilerError) +import Language.PureScript.TypeChecker.Monad (CheckState, getHints, getTypeClassDictionaries, withErrorMessageHint) +import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize) +import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, unifyTypes) +import Language.PureScript.Types (RowListItem(..), SourceType, Type(..), eqType, isREmpty, replaceTypeVars, rowFromList) -- | Subsumption can operate in two modes: -- diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 90e6da28f6..dc7b0522d4 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -13,15 +13,15 @@ module Language.PureScript.TypeChecker.Synonyms import Prelude import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State +import Control.Monad.State (MonadState) import Data.Maybe (fromMaybe) import Data.Map qualified as M import Data.Text (Text) -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.TypeChecker.Monad -import Language.PureScript.Types +import Language.PureScript.Environment (Environment(..), TypeKind) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), SourceSpan, errorMessage') +import Language.PureScript.Names (ProperName, ProperNameType(..), Qualified) +import Language.PureScript.TypeChecker.Monad (CheckState, getEnv) +import Language.PureScript.Types (SourceType, Type(..), completeBinderList, everywhereOnTypesTopDownM, getAnnForType, replaceAllTypeVars) -- | Type synonym information (arguments with kinds, aliased type), indexed by name type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType) diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index 5b40636ece..6158f48a82 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -9,14 +9,14 @@ import Data.Map qualified as Map import Language.PureScript.TypeChecker.Entailment qualified as Entailment import Language.PureScript.TypeChecker.Monad qualified as TC -import Language.PureScript.TypeChecker.Subsumption +import Language.PureScript.TypeChecker.Subsumption (subsumes) import Language.PureScript.TypeChecker.Unify as P import Control.Monad.Supply as P import Language.PureScript.AST as P import Language.PureScript.Environment as P import Language.PureScript.Errors as P -import Language.PureScript.Label +import Language.PureScript.Label (Label) import Language.PureScript.Names as P import Language.PureScript.Pretty.Types as P import Language.PureScript.TypeChecker.Skolems as Skolem diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 7a82f22214..c8615e6b42 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -27,7 +27,7 @@ import Prelude import Protolude (ordNub, fold, atMay) import Control.Arrow (first, second, (***)) -import Control.Monad +import Control.Monad (forM, forM_, guard, replicateM, unless, when, zipWithM, (<=<)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets) import Control.Monad.Supply.Class (MonadSupply) @@ -46,20 +46,20 @@ import Data.Set qualified as S import Data.IntSet qualified as IS import Language.PureScript.AST -import Language.PureScript.Crash +import Language.PureScript.Crash (internalError) import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.Traversals -import Language.PureScript.TypeChecker.Deriving -import Language.PureScript.TypeChecker.Entailment -import Language.PureScript.TypeChecker.Kinds +import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage', escalateWarningWhen, internalCompilerError, onErrorMessages, onTypesInErrorMessage, parU) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent) +import Language.PureScript.Traversals (sndM) +import Language.PureScript.TypeChecker.Deriving (deriveInstance) +import Language.PureScript.TypeChecker.Entailment (InstanceContext, newDictionaries, replaceTypeClassDictionaries) +import Language.PureScript.TypeChecker.Kinds (checkConstraint, checkTypeKind, kindOf, kindOfWithScopedVars, unifyKinds', unknownsWithKinds) import Language.PureScript.TypeChecker.Monad -import Language.PureScript.TypeChecker.Skolems -import Language.PureScript.TypeChecker.Subsumption -import Language.PureScript.TypeChecker.Synonyms -import Language.PureScript.TypeChecker.TypeSearch -import Language.PureScript.TypeChecker.Unify +import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope, newSkolemConstant, newSkolemScope, skolemEscapeCheck, skolemize, skolemizeTypesInValue) +import Language.PureScript.TypeChecker.Subsumption (subsumes) +import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) +import Language.PureScript.TypeChecker.TypeSearch (typeSearch) +import Language.PureScript.TypeChecker.Unify (freshTypeWithKind, replaceTypeWildcards, substituteType, unifyTypes, unknownsInType, varIfUnknown) import Language.PureScript.Types import Language.PureScript.Label (Label(..)) import Language.PureScript.PSString (PSString) diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 98af9804da..b58c8d78a7 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -16,7 +16,7 @@ module Language.PureScript.TypeChecker.Unify import Prelude -import Control.Monad +import Control.Monad (forM_, void) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets, modify, state) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -26,13 +26,13 @@ import Data.Maybe (fromMaybe) import Data.Map qualified as M import Data.Text qualified as T -import Language.PureScript.Crash +import Language.PureScript.Crash (internalError) import Language.PureScript.Environment qualified as E -import Language.PureScript.Errors +import Language.PureScript.Errors (ErrorMessageHint(..), MultipleErrors, SimpleErrorMessage(..), SourceAnn, errorMessage, internalCompilerError, onErrorMessages, rethrow, warnWithPosition, withoutPosition) import Language.PureScript.TypeChecker.Kinds (elaborateKind, instantiateKind, unifyKinds') -import Language.PureScript.TypeChecker.Monad -import Language.PureScript.TypeChecker.Skolems -import Language.PureScript.Types +import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, getLocalContext, guardWith, lookupUnkName, withErrorMessageHint) +import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize) +import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), SourceType, Type(..), WildcardData(..), alignRowsWith, everythingOnTypes, everywhereOnTypes, everywhereOnTypesM, getAnnForType, mkForAll, rowFromList, srcTUnknown) -- | Generate a fresh type variable with an unknown kind. Avoid this if at all possible. freshType :: (MonadState CheckState m) => m SourceType diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index dc3bfad14f..593e8c1a8d 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -7,8 +7,8 @@ import Control.DeepSeq (NFData) import Data.Text (Text, pack) import Language.PureScript.AST.Declarations.ChainId (ChainId) -import Language.PureScript.Names -import Language.PureScript.Types +import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, disqualify) +import Language.PureScript.Types (SourceConstraint, SourceType) -- -- Data representing a type class dictionary which is in scope diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 2f11ea4062..6e7552521f 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -23,9 +23,9 @@ import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) -import Language.PureScript.AST.SourcePos +import Language.PureScript.AST.SourcePos (pattern NullSourceAnn, SourceAnn, SourceSpan) import Language.PureScript.Constants.Prim qualified as C -import Language.PureScript.Names +import Language.PureScript.Names (OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified, coerceProperName) import Language.PureScript.Label (Label) import Language.PureScript.PSString (PSString) diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs index 3b838badb7..6ab1d89585 100644 --- a/tests/Language/PureScript/Ide/CompletionSpec.hs +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -5,10 +5,10 @@ import Protolude import Language.PureScript qualified as P import Language.PureScript.Ide.Test as Test import Language.PureScript.Ide.Command as Command -import Language.PureScript.Ide.Completion +import Language.PureScript.Ide.Completion (CompletionOptions(..), applyCompletionOptions, defaultCompletionOptions) import Language.PureScript.Ide.Filter.Declaration qualified as DeclarationType -import Language.PureScript.Ide.Types -import Test.Hspec +import Language.PureScript.Ide.Types (Completion(..), IdeDeclarationAnn, Match(..), Success(..)) +import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList, shouldSatisfy) reexportMatches :: [Match IdeDeclarationAnn] reexportMatches = diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index 2ead8749d8..80eb127bd8 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -3,13 +3,13 @@ module Language.PureScript.Ide.FilterSpec where import Protolude import Data.Map qualified as Map import Data.Set qualified as Set -import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Filter (applyFilters, declarationTypeFilter, dependencyFilter, exactFilter, moduleFilter, namespaceFilter, prefixFilter) import Language.PureScript.Ide.Filter.Declaration as D -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Imports +import Language.PureScript.Ide.Types (IdeDeclarationAnn, IdeNamespace(..), ModuleMap) +import Language.PureScript.Ide.Imports (Import, sliceImportSection) import Language.PureScript.Ide.Test as T import Language.PureScript qualified as P -import Test.Hspec +import Test.Hspec (Spec, describe, it, shouldBe) type Module = (P.ModuleName, [IdeDeclarationAnn]) diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index a060ca3edf..b12aeea352 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -6,14 +6,14 @@ import Data.Set qualified as Set import Language.PureScript qualified as P import Language.PureScript.Ide.Command as Command -import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Imports -import Language.PureScript.Ide.Imports.Actions +import Language.PureScript.Ide.Error (IdeError) +import Language.PureScript.Ide.Imports (Import, parseImport, prettyPrintImport', prettyPrintImportSection, sliceImportSection) +import Language.PureScript.Ide.Imports.Actions (addExplicitImport', addImplicitImport', addQualifiedImport') import Language.PureScript.Ide.Filter (moduleFilter) import Language.PureScript.Ide.Test qualified as Test -import Language.PureScript.Ide.Types -import System.FilePath -import Test.Hspec +import Language.PureScript.Ide.Types (IdeDeclarationAnn(..), Success(..)) +import System.FilePath (()) +import Test.Hspec (Expectation, Spec, describe, it, shouldBe, shouldSatisfy) noImportsFile :: [Text] noImportsFile = diff --git a/tests/Language/PureScript/Ide/MatcherSpec.hs b/tests/Language/PureScript/Ide/MatcherSpec.hs index 90b1a8dd4d..306e3ca321 100644 --- a/tests/Language/PureScript/Ide/MatcherSpec.hs +++ b/tests/Language/PureScript/Ide/MatcherSpec.hs @@ -3,10 +3,10 @@ module Language.PureScript.Ide.MatcherSpec where import Protolude import Language.PureScript qualified as P -import Language.PureScript.Ide.Matcher -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util -import Test.Hspec +import Language.PureScript.Ide.Matcher (flexMatcher, runMatcher) +import Language.PureScript.Ide.Types (IdeDeclaration(..), IdeDeclarationAnn, IdeValue(..), Match(..)) +import Language.PureScript.Ide.Util (withEmptyAnn) +import Test.Hspec (Spec, describe, it, shouldBe) value :: Text -> IdeDeclarationAnn value s = withEmptyAnn (IdeDeclValue (IdeValue (P.Ident (toS s)) P.srcREmpty)) diff --git a/tests/Language/PureScript/Ide/RebuildSpec.hs b/tests/Language/PureScript/Ide/RebuildSpec.hs index 24364f2310..93a0cabe51 100644 --- a/tests/Language/PureScript/Ide/RebuildSpec.hs +++ b/tests/Language/PureScript/Ide/RebuildSpec.hs @@ -5,14 +5,14 @@ import Protolude import Data.Set qualified as Set import Language.PureScript qualified as P import Language.PureScript.AST.SourcePos (spanName) -import Language.PureScript.Ide.Command -import Language.PureScript.Ide.Completion -import Language.PureScript.Ide.Matcher -import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Command (Command(..)) +import Language.PureScript.Ide.Completion (defaultCompletionOptions) +import Language.PureScript.Ide.Matcher (flexMatcher) +import Language.PureScript.Ide.Types (Completion(..), Success(..), emptyIdeState) import Language.PureScript.Ide.Test qualified as Test -import System.FilePath +import System.FilePath (()) import System.Directory (doesFileExist, removePathForcibly) -import Test.Hspec +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) defaultTarget :: Set P.CodegenTarget defaultTarget = Set.singleton P.JS diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index fced678692..77265987d1 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -3,11 +3,11 @@ module Language.PureScript.Ide.ReexportsSpec where import Protolude import Data.Map qualified as Map -import Language.PureScript.Ide.Reexports -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Test +import Language.PureScript.Ide.Reexports (ReexportResult(..), reexportHasFailures, resolveReexports') +import Language.PureScript.Ide.Types (IdeDeclarationAnn, ModuleMap) +import Language.PureScript.Ide.Test (annExp, ideDtor, ideKind, ideSynonym, ideType, ideTypeClass, ideValue, mn) import Language.PureScript qualified as P -import Test.Hspec +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) valueA, typeA, synonymA, classA, dtorA1, dtorA2, kindA :: IdeDeclarationAnn valueA = ideValue "valueA" Nothing diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index 12c8e8d234..f7de445c0e 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -3,11 +3,11 @@ module Language.PureScript.Ide.SourceFileSpec where import Protolude import Language.PureScript qualified as P -import Language.PureScript.Ide.Command -import Language.PureScript.Ide.SourceFile -import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Command (Command(..)) +import Language.PureScript.Ide.SourceFile (extractSpans, extractTypeAnnotations) +import Language.PureScript.Ide.Types (Completion(..), IdeNamespace(..), IdeNamespaced(..), Success(..), emptyIdeState) import Language.PureScript.Ide.Test -import Test.Hspec +import Test.Hspec (Spec, describe, it, shouldBe) span1, span2 :: P.SourceSpan span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2) diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index 2c28dc22d3..5ece522c34 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -1,12 +1,12 @@ module Language.PureScript.Ide.StateSpec where import Protolude -import Control.Lens hiding (anyOf, (&)) -import Language.PureScript.Ide.Types -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Test +import Control.Lens (Ixed(..), folded) +import Language.PureScript.Ide.Types (IdeDeclarationAnn, IdeInstance(..), ModuleMap, _IdeDeclTypeClass, anyOf, idaDeclaration, ideTCInstances) +import Language.PureScript.Ide.State (resolveDataConstructorsForModule, resolveInstances, resolveOperatorsForModule) +import Language.PureScript.Ide.Test (ideDtor, ideType, ideTypeClass, ideTypeOp, ideValue, ideValueOp, mn) import Language.PureScript qualified as P -import Test.Hspec +import Test.Hspec (Spec, describe, it, shouldSatisfy) import Data.Map qualified as Map valueOperator :: Maybe P.SourceType -> IdeDeclarationAnn diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index d9b58ca091..7092b1cf53 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -1,18 +1,18 @@ {-# LANGUAGE PackageImports #-} module Language.PureScript.Ide.Test where -import Control.Concurrent.STM -import "monad-logger" Control.Monad.Logger -import Data.IORef +import Control.Concurrent.STM (newTVarIO, readTVarIO) +import "monad-logger" Control.Monad.Logger (NoLoggingT(..)) +import Data.IORef (newIORef) import Data.Map qualified as Map -import Language.PureScript.Ide -import Language.PureScript.Ide.Command -import Language.PureScript.Ide.Error +import Language.PureScript.Ide (handleCommand) +import Language.PureScript.Ide.Command (Command) +import Language.PureScript.Ide.Error (IdeError) import Language.PureScript.Ide.Types import Protolude -import System.Directory -import System.FilePath -import System.Process +import System.Directory (doesDirectoryExist, getCurrentDirectory, makeAbsolute, removeDirectoryRecursive, setCurrentDirectory) +import System.FilePath (()) +import System.Process (createProcess, getProcessExitCode, shell) import Language.PureScript qualified as P diff --git a/tests/Language/PureScript/Ide/UsageSpec.hs b/tests/Language/PureScript/Ide/UsageSpec.hs index 97c5c379d7..0c399dfbf7 100644 --- a/tests/Language/PureScript/Ide/UsageSpec.hs +++ b/tests/Language/PureScript/Ide/UsageSpec.hs @@ -3,13 +3,13 @@ module Language.PureScript.Ide.UsageSpec where import Protolude import Data.Text qualified as Text -import Language.PureScript.Ide.Command -import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Command (Command(..)) +import Language.PureScript.Ide.Types (IdeNamespace(..), Success(..)) import Language.PureScript.Ide.Test qualified as Test import Language.PureScript qualified as P -import Test.Hspec +import Test.Hspec (Expectation, Spec, describe, it, shouldBe) import Data.Text.Read (decimal) -import System.FilePath +import System.FilePath (()) load :: [Text] -> Command load = LoadSync . map Test.mn diff --git a/tests/TestAst.hs b/tests/TestAst.hs index 75095b239f..88801e14f9 100644 --- a/tests/TestAst.hs +++ b/tests/TestAst.hs @@ -5,14 +5,14 @@ import Protolude hiding (Constraint, Type, (:+)) import Control.Lens ((+~)) import Control.Newtype (ala') -import Generic.Random -import Test.Hspec -import Test.QuickCheck - -import Language.PureScript.Label -import Language.PureScript.Names -import Language.PureScript.PSString -import Language.PureScript.Types +import Generic.Random (genericArbitraryRecG, genericArbitraryUG, listOf', uniform, withBaseCase, (:+)(..)) +import Test.Hspec (Spec, describe, it) +import Test.QuickCheck (Arbitrary(..), Gen, Property, Testable, counterexample, forAllShrink, subterms, (===)) + +import Language.PureScript.Label (Label(..)) +import Language.PureScript.Names (pattern ByNullSourcePos, OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified(..)) +import Language.PureScript.PSString (PSString) +import Language.PureScript.Types (Constraint, ConstraintData, SkolemScope(..), Type(..), WildcardData, annForType, everythingOnTypes, everythingWithContextOnTypes, everywhereOnTypes, everywhereOnTypesM, everywhereOnTypesTopDownM, getAnnForType) spec :: Spec spec = do diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 8a08024ceb..c13ca20104 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -36,18 +36,18 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as T -import Control.Monad +import Control.Monad (forM_, when) -import System.Exit -import System.FilePath -import System.IO +import System.Exit (ExitCode(..)) +import System.FilePath (pathSeparator, replaceExtension, takeFileName, ()) +import System.IO (Handle, hPutStr, hPutStrLn) import System.IO.UTF8 (readUTF8File) -import Text.Regex.Base +import Text.Regex.Base (RegexContext(..), RegexMaker(..)) import Text.Regex.TDFA (Regex) -import TestUtils -import Test.Hspec +import TestUtils (ExpectedModuleName(..), SupportModules, compile, createOutputFile, getTestFiles, goldenVsString, modulesDir, trim) +import Test.Hspec (Expectation, SpecWith, beforeAllWith, describe, expectationFailure, it, runIO) spec :: SpecWith SupportModules spec = do diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index 263ba795b1..eb71f13b90 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -4,21 +4,21 @@ module TestCoreFn (spec) where import Prelude -import Data.Aeson -import Data.Aeson.Types as Aeson +import Data.Aeson (Result(..), Value) +import Data.Aeson.Types (parse) import Data.Map as M -import Data.Version +import Data.Version (Version(..)) -import Language.PureScript.AST.Literals -import Language.PureScript.AST.SourcePos -import Language.PureScript.Comments -import Language.PureScript.CoreFn -import Language.PureScript.CoreFn.FromJSON -import Language.PureScript.CoreFn.ToJSON -import Language.PureScript.Names -import Language.PureScript.PSString +import Language.PureScript.AST.Literals (Literal(..)) +import Language.PureScript.AST.SourcePos (SourcePos(..), SourceSpan(..)) +import Language.PureScript.Comments (Comment(..)) +import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Meta(..), Module(..), ssAnn) +import Language.PureScript.CoreFn.FromJSON (moduleFromJSON) +import Language.PureScript.CoreFn.ToJSON (moduleToJSON) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..)) +import Language.PureScript.PSString (mkString) -import Test.Hspec +import Test.Hspec (Spec, context, shouldBe, shouldSatisfy, specify) parseModule :: Value -> Result (Version, Module Ann) parseModule = parse moduleFromJSON @@ -30,7 +30,7 @@ parseMod m = in snd <$> parseModule (moduleToJSON v m) isSuccess :: Result a -> Bool -isSuccess (Aeson.Success _) = True +isSuccess (Success _) = True isSuccess _ = False spec :: Spec @@ -47,49 +47,49 @@ spec = context "CoreFnFromJson" $ do r `shouldSatisfy` isSuccess case r of Error _ -> return () - Aeson.Success v' -> v' `shouldBe` v + Success v' -> v' `shouldBe` v specify "should parse an empty module" $ do let r = parseMod $ Module ss [] mn mp [] [] M.empty [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () - Aeson.Success m -> moduleName m `shouldBe` mn + Success m -> moduleName m `shouldBe` mn specify "should parse source span" $ do let r = parseMod $ Module ss [] mn mp [] [] M.empty [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () - Aeson.Success m -> moduleSourceSpan m `shouldBe` ss + Success m -> moduleSourceSpan m `shouldBe` ss specify "should parse module path" $ do let r = parseMod $ Module ss [] mn mp [] [] M.empty [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () - Aeson.Success m -> modulePath m `shouldBe` mp + Success m -> modulePath m `shouldBe` mp specify "should parse imports" $ do let r = parseMod $ Module ss [] mn mp [(ann, mn)] [] M.empty [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () - Aeson.Success m -> moduleImports m `shouldBe` [(ann, mn)] + Success m -> moduleImports m `shouldBe` [(ann, mn)] specify "should parse exports" $ do let r = parseMod $ Module ss [] mn mp [] [Ident "exp"] M.empty [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () - Aeson.Success m -> moduleExports m `shouldBe` [Ident "exp"] + Success m -> moduleExports m `shouldBe` [Ident "exp"] specify "should parse re-exports" $ do let r = parseMod $ Module ss [] mn mp [] [] (M.singleton (ModuleName "Example.A") [Ident "exp"]) [] [] r `shouldSatisfy` isSuccess case r of Error _ -> return () - Aeson.Success m -> moduleReExports m `shouldBe` M.singleton (ModuleName "Example.A") [Ident "exp"] + Success m -> moduleReExports m `shouldBe` M.singleton (ModuleName "Example.A") [Ident "exp"] specify "should parse foreign" $ do @@ -97,7 +97,7 @@ spec = context "CoreFnFromJson" $ do r `shouldSatisfy` isSuccess case r of Error _ -> return () - Aeson.Success m -> moduleForeign m `shouldBe` [Ident "exp"] + Success m -> moduleForeign m `shouldBe` [Ident "exp"] context "Expr" $ do specify "should parse literals" $ do @@ -154,7 +154,7 @@ spec = context "CoreFnFromJson" $ do r `shouldSatisfy` isSuccess case r of Error _ -> pure () - Aeson.Success Module{..} -> + Success Module{..} -> moduleDecls `shouldBe` [i] specify "should parse Case" $ do diff --git a/tests/TestCst.hs b/tests/TestCst.hs index b051d540a0..6f4a227e63 100644 --- a/tests/TestCst.hs +++ b/tests/TestCst.hs @@ -8,14 +8,14 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Text.IO qualified as Text -import Test.Hspec -import Test.QuickCheck -import TestUtils +import Test.Hspec (Spec, describe, it, runIO, specify) +import Test.QuickCheck (Arbitrary(..), Gen, Testable(..), arbitrarySizedNatural, arbitraryUnicodeChar, discard, elements, frequency, listOf, listOf1, oneof, resize) +import TestUtils (getTestFiles, goldenVsString) import Text.Read (readMaybe) import Language.PureScript.CST.Errors as CST import Language.PureScript.CST.Lexer as CST import Language.PureScript.CST.Print as CST -import Language.PureScript.CST.Types +import Language.PureScript.CST.Types (SourceToken(..), Token(..)) import System.FilePath (takeBaseName, replaceExtension) spec :: Spec diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 4e9dcad8e4..cb9f67066a 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -4,11 +4,11 @@ import Prelude import Data.Bifunctor (first) import Data.List (findIndex) -import Data.Foldable +import Data.Foldable (find, forM_) import Safe (headMay) import Data.Map qualified as Map import Data.Maybe (fromMaybe, isNothing, mapMaybe) -import Data.Monoid +import Data.Monoid (Any(..), First(..)) import Data.Text (Text) import Data.Text qualified as T import Text.PrettyPrint.Boxes qualified as Boxes @@ -22,7 +22,7 @@ import Web.Bower.PackageMeta (parsePackageName, runPackageName) import TestPscPublish (preparePackage) -import Test.Hspec +import Test.Hspec (Spec, beforeAll, context, expectationFailure, it) spec :: Spec spec = beforeAll (handleDocPrepFailure <$> preparePackage "tests/purs/docs" "purs.json" "resolutions.json") $ diff --git a/tests/TestGraph.hs b/tests/TestGraph.hs index 92233b439a..087bbc3601 100644 --- a/tests/TestGraph.hs +++ b/tests/TestGraph.hs @@ -2,7 +2,7 @@ module TestGraph where import Prelude -import Test.Hspec +import Test.Hspec (Spec, it, shouldBe, shouldSatisfy) import Data.Either (isLeft) import Data.Aeson qualified as Json diff --git a/tests/TestHierarchy.hs b/tests/TestHierarchy.hs index 18832a8d7c..2ba3e82946 100644 --- a/tests/TestHierarchy.hs +++ b/tests/TestHierarchy.hs @@ -2,10 +2,10 @@ module TestHierarchy where import Prelude -import Language.PureScript.Hierarchy +import Language.PureScript.Hierarchy (Digraph(..), Graph(..), GraphName(..), SuperMap(..), prettyPrint, typeClassGraph) import Language.PureScript qualified as P -import Test.Hspec +import Test.Hspec (Spec, describe, it, shouldBe) spec :: Spec spec = describe "hierarchy" $ do diff --git a/tests/TestMake.hs b/tests/TestMake.hs index 051abb373d..610e8465c8 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -9,23 +9,23 @@ import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST import Control.Concurrent (threadDelay) -import Control.Monad +import Control.Monad (guard, void) import Control.Exception (tryJust) import Control.Monad.IO.Class (liftIO) import Control.Concurrent.MVar (readMVar, newMVar, modifyMVar_) -import Data.Time.Calendar -import Data.Time.Clock +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime(..), secondsToDiffTime) import Data.Text qualified as T import Data.Set (Set) import Data.Set qualified as Set import Data.Map qualified as M -import System.FilePath -import System.Directory +import System.FilePath (()) +import System.Directory (createDirectory, removeDirectoryRecursive, removeFile, setModificationTime) import System.IO.Error (isDoesNotExistError) import System.IO.UTF8 (readUTF8FilesT, writeUTF8FileT) -import Test.Hspec +import Test.Hspec (Spec, before_, it, shouldReturn) utcMidnightOnDate :: Integer -> Int -> Int -> UTCTime utcMidnightOnDate year month day = UTCTime (fromGregorian year month day) (secondsToDiffTime 0) diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index d59232f6b6..3e702786a0 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -10,7 +10,7 @@ import Data.Text qualified as Text import Language.PureScript qualified as P import Language.PureScript.Docs qualified as D -import Test.Hspec +import Test.Hspec (Spec, it, shouldBe) spec :: Spec spec = do diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index dcd621946e..d6a0f70bb5 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -8,20 +8,20 @@ import Control.Monad.IO.Class (liftIO) import Data.ByteString.Lazy (ByteString) import Data.Time.Clock (getCurrentTime) import Data.Aeson qualified as A -import Data.Version +import Data.Version (Version(..)) import Data.Foldable (forM_) import Text.PrettyPrint.Boxes qualified as Boxes import System.Directory (listDirectory, removeDirectoryRecursive) import System.FilePath (()) import System.IO.Error (isDoesNotExistError) -import Language.PureScript.Docs +import Language.PureScript.Docs (UploadedPackage, VerifiedPackage) import Language.PureScript.Publish (PublishOptions(..), defaultPublishOptions) import Language.PureScript.Publish qualified as Publish import Language.PureScript.Publish.ErrorsWarnings qualified as Publish -import Test.Hspec -import TestUtils hiding (inferForeignModules, makeActions) +import Test.Hspec (Expectation, Spec, context, expectationFailure, it, runIO) +import TestUtils (pushd) spec :: Spec spec = do diff --git a/tests/TestPsci.hs b/tests/TestPsci.hs index 0d9394f817..b2dfa0dbd5 100644 --- a/tests/TestPsci.hs +++ b/tests/TestPsci.hs @@ -5,7 +5,7 @@ import TestPsci.CommandTest (commandTests) import TestPsci.CompletionTest (completionTests) import TestPsci.EvalTest (evalTests) -import Test.Hspec +import Test.Hspec (Spec) spec :: Spec spec = do diff --git a/tests/TestPsci/CommandTest.hs b/tests/TestPsci/CommandTest.hs index 9e148f779c..da68b9cd3a 100644 --- a/tests/TestPsci/CommandTest.hs +++ b/tests/TestPsci/CommandTest.hs @@ -5,11 +5,11 @@ import Prelude import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.RWS.Strict (get) import Language.PureScript (moduleNameFromString) -import Language.PureScript.Interactive +import Language.PureScript.Interactive (psciImportedModules, psciInteractivePrint) import System.FilePath (()) import System.Directory (getCurrentDirectory) -import Test.Hspec -import TestPsci.TestEnv +import Test.Hspec (Spec, context, shouldContain, shouldNotContain, specify) +import TestPsci.TestEnv (TestPSCi, equalsTo, execTestPSCi, printed, prints, run, simulateModuleEdit) specPSCi :: String -> TestPSCi () -> Spec specPSCi label = specify label . execTestPSCi diff --git a/tests/TestPsci/CompletionTest.hs b/tests/TestPsci/CompletionTest.hs index 0305d703fa..e1fe2af592 100644 --- a/tests/TestPsci/CompletionTest.hs +++ b/tests/TestPsci/CompletionTest.hs @@ -2,14 +2,14 @@ module TestPsci.CompletionTest where import Prelude -import Test.Hspec +import Test.Hspec (Spec, SpecWith, beforeAll, context, shouldBe, specify) import Control.Monad.Trans.State.Strict (evalStateT) import Data.Functor ((<&>)) import Data.List (sort) import Data.Text qualified as T import Language.PureScript qualified as P -import Language.PureScript.Interactive +import Language.PureScript.Interactive (CompletionM, PSCiState, completion', formatCompletions, liftCompletionM, updateImportedModules) import TestPsci.TestEnv (initTestPSCiEnv) import TestUtils (getSupportModuleNames) diff --git a/tests/TestPsci/EvalTest.hs b/tests/TestPsci/EvalTest.hs index 61323ec6ea..b46b3492f9 100644 --- a/tests/TestPsci/EvalTest.hs +++ b/tests/TestPsci/EvalTest.hs @@ -11,8 +11,8 @@ import System.Exit (exitFailure) import System.FilePath ((), takeFileName) import System.FilePath.Glob qualified as Glob import System.IO.UTF8 (readUTF8File) -import Test.Hspec -import TestPsci.TestEnv +import Test.Hspec (Spec, context, runIO, specify) +import TestPsci.TestEnv (TestPSCi, evaluatesTo, execTestPSCi, run) evalTests :: Spec evalTests = context "evalTests" $ do diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs index b255052656..b79b4c2220 100644 --- a/tests/TestPsci/TestEnv.hs +++ b/tests/TestPsci/TestEnv.hs @@ -11,7 +11,7 @@ import Data.List (isSuffixOf) import Data.Text qualified as T import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST -import Language.PureScript.Interactive +import Language.PureScript.Interactive (Command(..), PSCiConfig(..), PSCiState, handleCommand, indexFile, initialPSCiState, loadAllModules, make, modulesDir, parseCommand, readNodeProcessWithExitCode, runMake, updateLoadedExterns) import System.Directory (getCurrentDirectory, doesPathExist, removeFile) import System.Exit import System.FilePath ((), pathSeparator) diff --git a/tests/TestSourceMaps.hs b/tests/TestSourceMaps.hs index 178680a4db..5b91017d52 100644 --- a/tests/TestSourceMaps.hs +++ b/tests/TestSourceMaps.hs @@ -4,7 +4,7 @@ import Prelude import Control.Monad (void, forM_) import Data.Aeson as Json -import Test.Hspec +import Test.Hspec (Expectation, SpecWith, describe, expectationFailure, it, runIO, shouldBe) import System.FilePath (replaceExtension, takeFileName, (), (<.>)) import Language.PureScript qualified as P import Data.ByteString qualified as BS diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 6a313c1a47..146093c452 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -9,12 +9,12 @@ import Language.PureScript.Names qualified as N import Language.PureScript.Interactive.IO (findNodeProcess) import Control.Arrow ((***), (>>>)) -import Control.Monad -import Control.Monad.Reader -import Control.Monad.Trans.Except -import Control.Monad.Trans.Maybe +import Control.Monad (forM, guard, unless) +import Control.Monad.Reader (MonadIO(..), MonadTrans(..)) +import Control.Monad.Trans.Except (ExceptT(..), runExceptT) +import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Writer.Class (tell) -import Control.Exception +import Control.Exception (IOException, catch, throw, throwIO, try, tryJust) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Char (isSpace) @@ -26,16 +26,16 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Time.Clock (UTCTime(), diffUTCTime, getCurrentTime, nominalDay) import Data.Tuple (swap) -import System.Directory +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, getCurrentDirectory, getModificationTime, getTemporaryDirectory, listDirectory, setCurrentDirectory, withCurrentDirectory) import System.Exit (exitFailure) import System.Environment (lookupEnv) -import System.FilePath +import System.FilePath (dropExtensions, makeRelative, takeDirectory, takeExtensions, takeFileName, ()) import System.IO.Error (isDoesNotExistError) import System.IO.UTF8 (readUTF8FileT) -import System.Process hiding (cwd) +import System.Process (callCommand, callProcess) import System.FilePath.Glob qualified as Glob -import System.IO -import Test.Hspec +import System.IO (Handle, IOMode(..), hPutStrLn, openFile, stderr) +import Test.Hspec (Expectation, HasCallStack, expectationFailure, pendingWith) -- | -- Fetches code necessary to run the tests with. The resulting support code From 7026f64a79103ea87f69da6429e0908c8b0c0fc5 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Wed, 29 Mar 2023 09:32:09 -0400 Subject: [PATCH 1538/1580] Fix prerelease version number on macOS (#4461) * Migrate deprecated set-output commands in GitHub https://github.blog/changelog/2022-10-11-github-actions-deprecating-save-state-and-set-output-commands/ * Fix prerelease version number on macOS --- CHANGELOG.d/fix_4460.md | 1 + ci/build.sh | 29 ++++++++++++++++++++++++----- 2 files changed, 25 insertions(+), 5 deletions(-) create mode 100644 CHANGELOG.d/fix_4460.md diff --git a/CHANGELOG.d/fix_4460.md b/CHANGELOG.d/fix_4460.md new file mode 100644 index 0000000000..f86926fef2 --- /dev/null +++ b/CHANGELOG.d/fix_4460.md @@ -0,0 +1 @@ +* Fix prerelease version number on macOS diff --git a/ci/build.sh b/ci/build.sh index 5bcb7d4950..b2ef51251e 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -52,7 +52,7 @@ then then echo "Skipping prerelease because no input affecting the published package was" echo "changed since the last prerelease" - echo "::set-output name=do-not-prerelease::true" + echo "do-not-prerelease=true" >> $GITHUB_OUTPUT else do_prerelease=true fi @@ -82,6 +82,16 @@ fi if [ "$do_prerelease" ] then + # (some versions of?) macOS have an old FreeBSD sed that requires -i to be followed with an argument + if sed --version >/dev/null + then + # Probably GNU sed + sedi=(sed -i) + else + # Probably FreeBSD sed + sedi=(sed -i '') + fi + function largest-matching-git-tag { grep -E "^${1//./\\.}(\\.|$)" "$git_tags" | head -n 1 } @@ -127,11 +137,11 @@ then build_version=${build_version#v} else # (current version has not been published) build_version=$package_version - echo "::set-output name=do-not-prerelease::true" + echo "do-not-prerelease=true" >> $GITHUB_OUTPUT fi fi - echo "::set-output name=version::$build_version" + echo "version=$build_version" >> $GITHUB_OUTPUT popd @@ -142,8 +152,8 @@ then # We don't need to update the install-purescript command before we build; # we'll do that when we publish. All we need to update here are the files # that affect the purs binary. - sed -i -e "s/^\\(version:\\s*\\)${package_release_version//./\\.}/\1$build_release_version/" purescript.cabal - sed -i -e "s/^prerelease = \"${package_prerelease_suffix//./\\.}\"$/prerelease = \"${build_prerelease_suffix}\"/" app/Version.hs + "${sedi[@]}" -e "s/^\\(version:[[:blank:]]*\\)${package_release_version//./\\.}/\1$build_release_version/" purescript.cabal + "${sedi[@]}" -e "s/^prerelease = \"${package_prerelease_suffix//./\\.}\"$/prerelease = \"${build_prerelease_suffix}\"/" app/Version.hs fi fi @@ -165,6 +175,15 @@ pushd sdist-test # Haddock -Werror goes here to keep us honest but prevent failing on # documentation errors in dependencies $STACK build $STACK_OPTS --haddock-arguments --optghc=-Werror + +if [ "$do_prerelease" ] +then + if [ "$($STACK exec -- purs --version)" != "$build_version" ] + then + echo "purs --version doesn't equal the expected value" + exit 1 + fi +fi popd (echo "::endgroup::") 2>/dev/null From d7785056014cec498634cb1103365740c9b0b290 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Berk=20=C3=96zk=C3=BCt=C3=BCk?= Date: Sun, 2 Apr 2023 04:01:32 +0200 Subject: [PATCH 1539/1580] Consider fixity declarations during linting (#4462) * Consider fixity declarations during linting --- CHANGELOG.d/fix_4414.md | 1 + CONTRIBUTORS.md | 1 + src/Language/PureScript/Linter.hs | 2 ++ tests/purs/warning/4414.out | 0 tests/purs/warning/4414.purs | 21 +++++++++++++++++++++ 5 files changed, 25 insertions(+) create mode 100644 CHANGELOG.d/fix_4414.md create mode 100644 tests/purs/warning/4414.out create mode 100644 tests/purs/warning/4414.purs diff --git a/CHANGELOG.d/fix_4414.md b/CHANGELOG.d/fix_4414.md new file mode 100644 index 0000000000..8d4e8209c7 --- /dev/null +++ b/CHANGELOG.d/fix_4414.md @@ -0,0 +1 @@ +* Consider fixity declarations during linting diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index a4f8790422..18d0ad69ac 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -113,6 +113,7 @@ If you would prefer to use different terms, please use the section below instead | [@noraesae](https://github.com/noraesae) | Hyunje Jun | [MIT license] | | [@nullobject](https://github.com/nullobject) | Josh Bassett | [MIT license] | | [@osa1](https://github.com/osa1) | Ömer Sinan Ağacan | [MIT license] | +| [@ozkutuk](https://github.com/ozkutuk) | Berk Özkütük | [MIT license] | | [@paf31](https://github.com/paf31) | Phil Freeman | [MIT license] | | [@parsonsmatt](https://github.com/parsonsmatt) | Matt Parsons | [MIT license] | | [@passy](https://github.com/passy) | Pascal Hartig | [MIT license] | diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index c77d66c1d4..95f4029cdf 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -183,6 +183,8 @@ lintUnused (Module modSS _ mn modDecls exports) = in (vars, errs') + goDecl (ValueFixityDeclaration _ _ (Qualified _ (Left v)) _) = (S.singleton v, mempty) + goDecl (TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance decls)) = mconcat $ map goDecl decls goDecl _ = mempty diff --git a/tests/purs/warning/4414.out b/tests/purs/warning/4414.out new file mode 100644 index 0000000000..e69de29bb2 diff --git a/tests/purs/warning/4414.purs b/tests/purs/warning/4414.purs new file mode 100644 index 0000000000..7d9ecb2d05 --- /dev/null +++ b/tests/purs/warning/4414.purs @@ -0,0 +1,21 @@ +module Main + ( something + , main + ) + where + +import Prelude + +import Effect (Effect) +import Effect.Console (log) + +something :: Boolean +something = 42 .?.?. 1 + +foo :: forall a. a -> a -> Boolean +foo _ _ = true + +infix 7 foo as .?.?. + +main :: Effect Unit +main = log "Done" From 284cefc60f757eef9ed6f58f083917ad49fc9038 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Sat, 22 Apr 2023 12:59:08 +0800 Subject: [PATCH 1540/1580] Defer monomorphization for data constructors (#4376) --- CHANGELOG.d/fix_polymorhic_constructors.md | 40 ++++++ src/Language/PureScript/TypeChecker/Types.hs | 134 ++++++++++++++----- tests/purs/passing/4376.purs | 29 ++++ tests/purs/warning/4376.out | 16 +++ tests/purs/warning/4376.purs | 6 + 5 files changed, 188 insertions(+), 37 deletions(-) create mode 100644 CHANGELOG.d/fix_polymorhic_constructors.md create mode 100644 tests/purs/passing/4376.purs create mode 100644 tests/purs/warning/4376.out create mode 100644 tests/purs/warning/4376.purs diff --git a/CHANGELOG.d/fix_polymorhic_constructors.md b/CHANGELOG.d/fix_polymorhic_constructors.md new file mode 100644 index 0000000000..ad77cb1c82 --- /dev/null +++ b/CHANGELOG.d/fix_polymorhic_constructors.md @@ -0,0 +1,40 @@ +* Defer monomorphization for data constructors + + In `0.15.4` and earlier, the compiler monomorphizes type + constructors early, yielding the following type: + + ```purs + > :t Nothing + forall (a1 :: Type). Maybe a1 + + > :t { a : Nothing } + forall (a1 :: Type). + { a :: Maybe a1 + } + ``` + + With this change, the monomorphization introduced in + [#835](https://github.com/purescript/purescript/pull/835) is + deferred to only when it's needed, such as when constructors are + used as values inside of records. + + ```purs + > :t Nothing + forall a. Maybe a + + > :t { a : Nothing } + forall (a1 :: Type). + { a :: Maybe a1 + } + ``` + + Also as a consequence, record updates should not throw + `ConstrainedTypeUnified` in cases such as: + + ```purs + v1 :: { a :: Maybe Unit } + v1 = { a : Just Unit } + + v2 :: { a :: Maybe Unit } + v2 = let v3 = v1 { a = mempty } in v3 + ``` diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index c8615e6b42..ab532057e8 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -50,7 +50,6 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Environment import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage', escalateWarningWhen, internalCompilerError, onErrorMessages, onTypesInErrorMessage, parU) import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent) -import Language.PureScript.Traversals (sndM) import Language.PureScript.TypeChecker.Deriving (deriveInstance) import Language.PureScript.TypeChecker.Entailment (InstanceContext, newDictionaries, replaceTypeClassDictionaries) import Language.PureScript.TypeChecker.Kinds (checkConstraint, checkTypeKind, kindOf, kindOfWithScopedVars, unifyKinds', unknownsWithKinds) @@ -369,38 +368,62 @@ infer' (Literal ss (ArrayLiteral vals)) = do return $ TypedValue' True (Literal ss (ArrayLiteral ts')) (srcTypeApp tyArray els) infer' (Literal ss (ObjectLiteral ps)) = do ensureNoDuplicateProperties ps - -- We make a special case for Vars in record labels, since these are the - -- only types of expressions for which 'infer' can return a polymorphic type. - -- They need to be instantiated here. - let shouldInstantiate :: Expr -> Bool - shouldInstantiate Var{} = True - shouldInstantiate (PositionedValue _ _ e) = shouldInstantiate e - shouldInstantiate _ = False - - inferProperty :: (PSString, Expr) -> m (PSString, (Expr, SourceType)) - inferProperty (name, val) = do - TypedValue' _ val' ty <- infer val - valAndType <- if shouldInstantiate val - then instantiatePolyTypeWithUnknowns val' ty - else pure (val', ty) - pure (name, valAndType) - - toRowListItem (lbl, (_, ty)) = srcRowListItem (Label lbl) ty - - fields <- forM ps inferProperty - let ty = srcTypeApp tyRecord $ rowFromList (map toRowListItem fields, srcKindApp srcREmpty kindType) - return $ TypedValue' True (Literal ss (ObjectLiteral (map (fmap (uncurry (TypedValue True))) fields))) ty -infer' (ObjectUpdate o ps) = do + typedFields <- inferProperties ps + let + toRowListItem :: (PSString, (Expr, SourceType)) -> RowListItem SourceAnn + toRowListItem (l, (_, t)) = srcRowListItem (Label l) t + + recordType :: SourceType + recordType = srcTypeApp tyRecord $ rowFromList (toRowListItem <$> typedFields, srcKindApp srcREmpty kindType) + + typedProperties :: [(PSString, Expr)] + typedProperties = fmap (fmap (uncurry (TypedValue True))) typedFields + pure $ TypedValue' True (Literal ss (ObjectLiteral typedProperties)) recordType +infer' (ObjectUpdate ob ps) = do ensureNoDuplicateProperties ps - row <- freshTypeWithKind (kindRow kindType) - typedVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps - let toRowListItem = uncurry srcRowListItem - let newTys = map (\(name, TypedValue' _ _ ty) -> (Label name, ty)) typedVals - oldTys <- zip (map (Label . fst) ps) <$> replicateM (length ps) (freshTypeWithKind kindType) - let oldTy = srcTypeApp tyRecord $ rowFromList (toRowListItem <$> oldTys, row) - o' <- TypedValue True <$> (tvToExpr <$> check o oldTy) <*> pure oldTy - let newVals = map (fmap tvToExpr) typedVals - return $ TypedValue' True (ObjectUpdate o' newVals) $ srcTypeApp tyRecord $ rowFromList (toRowListItem <$> newTys, row) + -- This "tail" holds all other fields not being updated. + rowType <- freshTypeWithKind (kindRow kindType) + let updateLabels = Label . fst <$> ps + -- Generate unification variables for each field in ps. + -- + -- Given: + -- + -- ob { a = 0, b = 0 } + -- + -- Then: + -- + -- obTypes = [(a, ?0), (b, ?1)] + obTypes <- zip updateLabels <$> replicateM (length updateLabels) (freshTypeWithKind kindType) + let obItems :: [RowListItem SourceAnn] + obItems = uncurry srcRowListItem <$> obTypes + -- Create a record type that contains the unification variables. + -- + -- obRecordType = Record ( a :: ?0, b :: ?1 | rowType ) + obRecordType :: SourceType + obRecordType = srcTypeApp tyRecord $ rowFromList (obItems, rowType) + -- Check ob against obRecordType. + -- + -- Given: + -- + -- ob : { a :: Int, b :: Int } + -- + -- Then: + -- + -- ?0 ~ Int + -- ?1 ~ Int + -- ob' : { a :: ?0, b :: ?1 } + ob' <- TypedValue True <$> (tvToExpr <$> check ob obRecordType) <*> pure obRecordType + -- Infer the types of the values used for the record update. + typedFields <- inferProperties ps + let newItems :: [RowListItem SourceAnn] + newItems = (\(l, (_, t)) -> srcRowListItem (Label l) t) <$> typedFields + + ps' :: [(PSString, Expr)] + ps' = (\(l, (e, t)) -> (l, TypedValue True e t)) <$> typedFields + + newRecordType :: SourceType + newRecordType = srcTypeApp tyRecord $ rowFromList (newItems, rowType) + pure $ TypedValue' True (ObjectUpdate ob' ps') newRecordType infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do field <- freshTypeWithKind kindType rest <- freshTypeWithKind (kindRow kindType) @@ -431,8 +454,7 @@ infer' v@(Constructor _ c) = do env <- getEnv case M.lookup c (dataConstructors env) of Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c - Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty - return $ TypedValue' True v' ty' + Just (_, _, ty, _) -> TypedValue' True v <$> (introduceSkolemScope <=< replaceAllTypeSynonyms $ ty) infer' (Case vals binders) = do (vals', ts) <- instantiateForBinders vals binders ret <- freshTypeWithKind kindType @@ -474,6 +496,44 @@ infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do return $ TypedValue' t (PositionedValue pos c v) ty infer' v = internalError $ "Invalid argument to infer: " ++ show v +-- | +-- Infer the types of named record fields. +inferProperties + :: ( MonadSupply m + , MonadState CheckState m + , MonadError MultipleErrors m + , MonadWriter MultipleErrors m + ) + => [(PSString, Expr)] + -> m [(PSString, (Expr, SourceType))] +inferProperties = traverse (traverse inferWithinRecord) + +-- | +-- Infer the type of a value when used as a record field. +inferWithinRecord + :: ( MonadSupply m + , MonadState CheckState m + , MonadError MultipleErrors m + , MonadWriter MultipleErrors m + ) + => Expr + -> m (Expr, SourceType) +inferWithinRecord e = do + TypedValue' _ v t <- infer e + if propertyShouldInstantiate e + then instantiatePolyTypeWithUnknowns v t + else pure (v, t) + +-- | +-- Determines if a value's type needs to be monomorphized when +-- used inside of a record. +propertyShouldInstantiate :: Expr -> Bool +propertyShouldInstantiate = \case + Var{} -> True + Constructor{} -> True + PositionedValue _ _ e -> propertyShouldInstantiate e + _ -> False + inferLetBinding :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] @@ -795,7 +855,7 @@ check' v@(Constructor _ c) ty = do Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c Just (_, _, ty1, _) -> do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 - ty' <- introduceSkolemScope ty + ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty elaborate <- subsumes repl ty' return $ TypedValue' True (elaborate v) ty' check' (Let w ds val) ty = do @@ -841,11 +901,11 @@ checkProperties expr ps row lax = convert <$> go ps (toRowPair <$> ts') r' where go ((p,v):ps') ts r = case lookup (Label p) ts of Nothing -> do - v'@(TypedValue' _ _ ty) <- infer v + (v', ty) <- inferWithinRecord v rest <- freshTypeWithKind (kindRow kindType) unifyTypes r (srcRCons (Label p) ty rest) ps'' <- go ps' ts rest - return $ (p, v') : ps'' + return $ (p, TypedValue' True v' ty) : ps'' Just ty -> do v' <- check v ty ps'' <- go ps' (delete (Label p, ty) ts) r diff --git a/tests/purs/passing/4376.purs b/tests/purs/passing/4376.purs new file mode 100644 index 0000000000..46c3463a00 --- /dev/null +++ b/tests/purs/passing/4376.purs @@ -0,0 +1,29 @@ +module Main where + +import Prelude +import Prim.Row (class Union) + +import Data.Maybe (Maybe(..)) +import Data.Monoid (mempty) +import Effect.Console (log) +import Type.Proxy (Proxy(..)) + +-- Make sure that record updates get monomorphized. +asNothing :: forall a. { a :: Maybe a } -> { a :: Maybe a } +asNothing = _ { a = Nothing } + +union :: forall a b c. Union a b c => Record a -> Record b -> Proxy c +union _ _ = Proxy + +-- This fails to solve if neither is monomorphized. +shouldSolve :: forall a b. Proxy ( a :: Maybe a, b :: Maybe b ) +shouldSolve = { a: Nothing } `union` { b: Nothing } + +-- Removes ConstrainedTypeUnified +v1 :: { a :: Maybe Unit } +v1 = { a : Just unit } + +v2 :: { a :: Maybe Unit } +v2 = let v3 = v1 { a = mempty } in v3 + +main = log "Done" diff --git a/tests/purs/warning/4376.out b/tests/purs/warning/4376.out new file mode 100644 index 0000000000..a7107df7e1 --- /dev/null +++ b/tests/purs/warning/4376.out @@ -0,0 +1,16 @@ +Warning found: +in module Main +at tests/purs/warning/4376.purs:6:1 - 6:16 (line 6, column 1 - line 6, column 16) + + No type declaration was provided for the top-level declaration of value. + It is good practice to provide type declarations as a form of documentation. + The inferred type of value was: +   +  forall a. Maybe a +   + +in value declaration value + +See https://github.com/purescript/documentation/blob/master/errors/MissingTypeDeclaration.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/4376.purs b/tests/purs/warning/4376.purs new file mode 100644 index 0000000000..0a6d4d535a --- /dev/null +++ b/tests/purs/warning/4376.purs @@ -0,0 +1,6 @@ +-- @shouldWarnWith MissingTypeDeclaration +module Main where + +data Maybe a = Just a | Nothing + +value = Nothing From 198a49ed7ba650a626c1d0f73839bc1a89af5d7c Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Wed, 26 Apr 2023 04:20:20 -0400 Subject: [PATCH 1541/1580] Update installer to version 0.3.4 (#4468) --- CHANGELOG.d/fix_bump-installer.md | 1 + npm-package/package.json | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/fix_bump-installer.md diff --git a/CHANGELOG.d/fix_bump-installer.md b/CHANGELOG.d/fix_bump-installer.md new file mode 100644 index 0000000000..7ed009fc8c --- /dev/null +++ b/CHANGELOG.d/fix_bump-installer.md @@ -0,0 +1 @@ +* Update installer to version 0.3.4 to support ARM builds diff --git a/npm-package/package.json b/npm-package/package.json index b0ac8d355c..54e59edfc0 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -15,7 +15,7 @@ "purs": "purs.bin" }, "dependencies": { - "purescript-installer": "^0.3.3" + "purescript-installer": "^0.3.4" }, "homepage": "https://github.com/purescript/purescript", "repository": { From d8abcf00de7ec2bf6e4807e5a843d00ae1751c5b Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Wed, 26 Apr 2023 15:46:48 -0400 Subject: [PATCH 1542/1580] Update installer to version 0.3.5 (#4469) --- CHANGELOG.d/fix_bump-installer.md | 2 +- npm-package/package.json | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.d/fix_bump-installer.md b/CHANGELOG.d/fix_bump-installer.md index 7ed009fc8c..a8d722d304 100644 --- a/CHANGELOG.d/fix_bump-installer.md +++ b/CHANGELOG.d/fix_bump-installer.md @@ -1 +1 @@ -* Update installer to version 0.3.4 to support ARM builds +* Update installer to version 0.3.5 to support ARM builds diff --git a/npm-package/package.json b/npm-package/package.json index 54e59edfc0..4e7fad21ee 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -15,7 +15,7 @@ "purs": "purs.bin" }, "dependencies": { - "purescript-installer": "^0.3.4" + "purescript-installer": "^0.3.5" }, "homepage": "https://github.com/purescript/purescript", "repository": { From 5b9031ae7e97873fa8ff4ba38aa2208abd60c9a7 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Thu, 27 Apr 2023 03:47:58 +0800 Subject: [PATCH 1543/1580] Fix exhaustiveness checking to account for case guards (#4467) --- CHANGELOG.d/fix_4466.md | 1 + src/Language/PureScript/Linter/Exhaustive.hs | 49 ++++++-------------- tests/purs/failing/4466.out | 24 ++++++++++ tests/purs/failing/4466.purs | 16 +++++++ 4 files changed, 54 insertions(+), 36 deletions(-) create mode 100644 CHANGELOG.d/fix_4466.md create mode 100644 tests/purs/failing/4466.out create mode 100644 tests/purs/failing/4466.purs diff --git a/CHANGELOG.d/fix_4466.md b/CHANGELOG.d/fix_4466.md new file mode 100644 index 0000000000..c14b2f07d4 --- /dev/null +++ b/CHANGELOG.d/fix_4466.md @@ -0,0 +1 @@ +* Fix exhaustiveness checking to account for case guards diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 0521eda985..697fefe8a0 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -14,7 +14,7 @@ import Protolude (ordNub) import Control.Applicative (Applicative(..)) import Control.Arrow (first, second) import Control.Monad (unless) -import Control.Monad.Writer.Class (MonadWriter(..), censor) +import Control.Monad.Writer.Class (MonadWriter(..)) import Data.List (foldl', sortOn) import Data.Maybe (fromMaybe) @@ -22,14 +22,14 @@ import Data.Map qualified as M import Data.Text qualified as T import Language.PureScript.AST.Binders (Binder(..)) -import Language.PureScript.AST.Declarations (CaseAlternative(..), Declaration(..), ErrorMessageHint(..), Expr(..), Guard(..), GuardedExpr(..), pattern MkUnguarded, pattern ValueDecl, isTrueExpr) +import Language.PureScript.AST.Declarations (CaseAlternative(..), Expr(..), Guard(..), GuardedExpr(..), pattern MkUnguarded, isTrueExpr) import Language.PureScript.AST.Literals (Literal(..)) +import Language.PureScript.AST.Traversals (everywhereOnValuesM) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType, Environment(..), TypeKind(..)) -import Language.PureScript.Errors (MultipleErrors, pattern NullSourceAnn, SimpleErrorMessage(..), SourceSpan, addHint, errorMessage') +import Language.PureScript.Errors (MultipleErrors, pattern NullSourceAnn, SimpleErrorMessage(..), SourceSpan, errorMessage') import Language.PureScript.Names as P import Language.PureScript.Pretty.Values (prettyPrintBinderAtom) -import Language.PureScript.Traversals (sndM) import Language.PureScript.Types as P import Language.PureScript.Constants.Prim qualified as C @@ -297,36 +297,13 @@ checkExhaustiveExpr -> ModuleName -> Expr -> m Expr -checkExhaustiveExpr initSS env mn = onExpr initSS +checkExhaustiveExpr ss env mn = onExpr' where - onDecl :: Declaration -> m Declaration - onDecl (BindingGroupDeclaration bs) = BindingGroupDeclaration <$> mapM (\(sai@((ss, _), _), nk, expr) -> (sai, nk,) <$> onExpr ss expr) bs - onDecl (ValueDecl sa@(ss, _) name x y [MkUnguarded e]) = - ValueDecl sa name x y . mkUnguardedExpr <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr ss e) - onDecl decl = return decl - - onExpr :: SourceSpan -> Expr -> m Expr - onExpr _ (UnaryMinus ss e) = UnaryMinus ss <$> onExpr ss e - onExpr _ (Literal ss (ArrayLiteral es)) = Literal ss . ArrayLiteral <$> mapM (onExpr ss) es - onExpr _ (Literal ss (ObjectLiteral es)) = Literal ss . ObjectLiteral <$> mapM (sndM (onExpr ss)) es - onExpr ss (Accessor x e) = Accessor x <$> onExpr ss e - onExpr ss (ObjectUpdate o es) = ObjectUpdate <$> onExpr ss o <*> mapM (sndM (onExpr ss)) es - onExpr ss (Abs x e) = Abs x <$> onExpr ss e - onExpr ss (App e1 e2) = App <$> onExpr ss e1 <*> onExpr ss e2 - onExpr ss (IfThenElse e1 e2 e3) = IfThenElse <$> onExpr ss e1 <*> onExpr ss e2 <*> onExpr ss e3 - onExpr ss (Case es cas) = do - case' <- Case <$> mapM (onExpr ss) es <*> mapM (onCaseAlternative ss) cas - checkExhaustive ss env mn (length es) cas case' - onExpr ss (TypedValue x e y) = TypedValue x <$> onExpr ss e <*> pure y - onExpr ss (Let w ds e) = Let w <$> mapM onDecl ds <*> onExpr ss e - onExpr _ (PositionedValue ss x e) = PositionedValue ss x <$> onExpr ss e - onExpr _ expr = return expr - - onCaseAlternative :: SourceSpan -> CaseAlternative -> m CaseAlternative - onCaseAlternative ss (CaseAlternative x [MkUnguarded e]) = CaseAlternative x . mkUnguardedExpr <$> onExpr ss e - onCaseAlternative ss (CaseAlternative x es) = CaseAlternative x <$> mapM (onGuardedExpr ss) es - - onGuardedExpr :: SourceSpan -> GuardedExpr -> m GuardedExpr - onGuardedExpr ss (GuardedExpr guard rhs) = GuardedExpr guard <$> onExpr ss rhs - - mkUnguardedExpr = pure . MkUnguarded + (_, onExpr', _) = everywhereOnValuesM pure onExpr pure + + onExpr :: Expr -> m Expr + onExpr e = case e of + Case es cas -> + checkExhaustive ss env mn (length es) cas e + _ -> + pure e diff --git a/tests/purs/failing/4466.out b/tests/purs/failing/4466.out new file mode 100644 index 0000000000..77b1cf3ea8 --- /dev/null +++ b/tests/purs/failing/4466.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/4466.purs:15:44 - 15:67 (line 15, column 44 - line 15, column 67) + + A case expression could not be determined to cover all inputs. + The following additional cases are required to cover all inputs: + + { sound: Quack } + { sound: Bark } + + Alternatively, add a Partial constraint to the type of the enclosing value. + +while checking that type Partial => t0 + is at least as general as type Boolean +while checking that expression case $0 of  +  { sound: Moo } -> true + has type Boolean +in value declaration animalFunc + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4466.purs b/tests/purs/failing/4466.purs new file mode 100644 index 0000000000..1c3d75db36 --- /dev/null +++ b/tests/purs/failing/4466.purs @@ -0,0 +1,16 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Prelude + +import Data.Array as Array +import Data.Maybe (Maybe(..)) + +data Sound = Moo | Quack | Bark + +type Animal = { sound :: Sound } + +animalFunc :: Array Animal -> Unit +animalFunc animals + | Just { sound } <- animals # Array.find \{ sound: Moo } -> true = unit + | otherwise = unit From b1825f9bb1eb3dcc508848507a2f838049a4fb19 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Sun, 30 Apr 2023 01:02:39 +0800 Subject: [PATCH 1544/1580] Prepare 0.15.9 release (#4470) --- CHANGELOG.d/feature_arm_builds.md | 1 - CHANGELOG.d/fix_4414.md | 1 - CHANGELOG.d/fix_4460.md | 1 - CHANGELOG.d/fix_4466.md | 1 - CHANGELOG.d/fix_bump-installer.md | 1 - CHANGELOG.d/fix_polymorhic_constructors.md | 40 ------------- CHANGELOG.d/internal_no-haddock-warnings.md | 1 - CHANGELOG.d/internal_simplify-imports.md | 1 - CHANGELOG.md | 63 +++++++++++++++++++++ npm-package/package.json | 4 +- purescript.cabal | 2 +- 11 files changed, 66 insertions(+), 50 deletions(-) delete mode 100644 CHANGELOG.d/feature_arm_builds.md delete mode 100644 CHANGELOG.d/fix_4414.md delete mode 100644 CHANGELOG.d/fix_4460.md delete mode 100644 CHANGELOG.d/fix_4466.md delete mode 100644 CHANGELOG.d/fix_bump-installer.md delete mode 100644 CHANGELOG.d/fix_polymorhic_constructors.md delete mode 100644 CHANGELOG.d/internal_no-haddock-warnings.md delete mode 100644 CHANGELOG.d/internal_simplify-imports.md diff --git a/CHANGELOG.d/feature_arm_builds.md b/CHANGELOG.d/feature_arm_builds.md deleted file mode 100644 index 7429fe3445..0000000000 --- a/CHANGELOG.d/feature_arm_builds.md +++ /dev/null @@ -1 +0,0 @@ -* Add release artifacts for Linux and macOS running on the ARM64 architecture. diff --git a/CHANGELOG.d/fix_4414.md b/CHANGELOG.d/fix_4414.md deleted file mode 100644 index 8d4e8209c7..0000000000 --- a/CHANGELOG.d/fix_4414.md +++ /dev/null @@ -1 +0,0 @@ -* Consider fixity declarations during linting diff --git a/CHANGELOG.d/fix_4460.md b/CHANGELOG.d/fix_4460.md deleted file mode 100644 index f86926fef2..0000000000 --- a/CHANGELOG.d/fix_4460.md +++ /dev/null @@ -1 +0,0 @@ -* Fix prerelease version number on macOS diff --git a/CHANGELOG.d/fix_4466.md b/CHANGELOG.d/fix_4466.md deleted file mode 100644 index c14b2f07d4..0000000000 --- a/CHANGELOG.d/fix_4466.md +++ /dev/null @@ -1 +0,0 @@ -* Fix exhaustiveness checking to account for case guards diff --git a/CHANGELOG.d/fix_bump-installer.md b/CHANGELOG.d/fix_bump-installer.md deleted file mode 100644 index a8d722d304..0000000000 --- a/CHANGELOG.d/fix_bump-installer.md +++ /dev/null @@ -1 +0,0 @@ -* Update installer to version 0.3.5 to support ARM builds diff --git a/CHANGELOG.d/fix_polymorhic_constructors.md b/CHANGELOG.d/fix_polymorhic_constructors.md deleted file mode 100644 index ad77cb1c82..0000000000 --- a/CHANGELOG.d/fix_polymorhic_constructors.md +++ /dev/null @@ -1,40 +0,0 @@ -* Defer monomorphization for data constructors - - In `0.15.4` and earlier, the compiler monomorphizes type - constructors early, yielding the following type: - - ```purs - > :t Nothing - forall (a1 :: Type). Maybe a1 - - > :t { a : Nothing } - forall (a1 :: Type). - { a :: Maybe a1 - } - ``` - - With this change, the monomorphization introduced in - [#835](https://github.com/purescript/purescript/pull/835) is - deferred to only when it's needed, such as when constructors are - used as values inside of records. - - ```purs - > :t Nothing - forall a. Maybe a - - > :t { a : Nothing } - forall (a1 :: Type). - { a :: Maybe a1 - } - ``` - - Also as a consequence, record updates should not throw - `ConstrainedTypeUnified` in cases such as: - - ```purs - v1 :: { a :: Maybe Unit } - v1 = { a : Just Unit } - - v2 :: { a :: Maybe Unit } - v2 = let v3 = v1 { a = mempty } in v3 - ``` diff --git a/CHANGELOG.d/internal_no-haddock-warnings.md b/CHANGELOG.d/internal_no-haddock-warnings.md deleted file mode 100644 index 8d661b6cf6..0000000000 --- a/CHANGELOG.d/internal_no-haddock-warnings.md +++ /dev/null @@ -1 +0,0 @@ -* Require comments not to cause Haddock warnings diff --git a/CHANGELOG.d/internal_simplify-imports.md b/CHANGELOG.d/internal_simplify-imports.md deleted file mode 100644 index 13bf406888..0000000000 --- a/CHANGELOG.d/internal_simplify-imports.md +++ /dev/null @@ -1 +0,0 @@ -* Refactor module imports to make identifiers' origins obvious diff --git a/CHANGELOG.md b/CHANGELOG.md index d1c1c3d925..00ad84751d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,69 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.9 + +New features: + +* Add release artifacts for Linux and macOS running on the ARM64 architecture. (#4455 by @f-f) + +Bugfixes: + +* Fix prerelease version number on macOS (#4461 by @rhendric) + +* Consider fixity declarations during linting (#4462 by @ozkutuk) + +* Defer monomorphization for data constructors (#4376 by @purefunctor) + + In `0.15.4` and earlier, the compiler monomorphizes type + constructors early, yielding the following type: + + ```purs + > :t Nothing + forall (a1 :: Type). Maybe a1 + + > :t { a : Nothing } + forall (a1 :: Type). + { a :: Maybe a1 + } + ``` + + With this change, the monomorphization introduced in + [#835](https://github.com/purescript/purescript/pull/835) is + deferred to only when it's needed, such as when constructors are + used as values inside of records. + + ```purs + > :t Nothing + forall a. Maybe a + + > :t { a : Nothing } + forall (a1 :: Type). + { a :: Maybe a1 + } + ``` + + Also as a consequence, record updates should not throw + `ConstrainedTypeUnified` in cases such as: + + ```purs + v1 :: { a :: Maybe Unit } + v1 = { a : Just Unit } + + v2 :: { a :: Maybe Unit } + v2 = let v3 = v1 { a = mempty } in v3 + ``` + +* Update installer to version 0.3.5 to support ARM builds (#4468 and #4469 by @rhendric) + +* Fix exhaustiveness checking to account for case guards (#4467 by @purefunctor) + +Internal: + +* Refactor module imports to make identifiers' origins obvious (#4451 by @JordanMartinez) + +* Require comments not to cause Haddock warnings (#4456 by @rhendric) + ## 0.15.8 New features: diff --git a/npm-package/package.json b/npm-package/package.json index 4e7fad21ee..3f391d5f43 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.8", + "version": "0.15.9", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.8", + "postinstall": "install-purescript --purs-ver=0.15.9", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index 859126a658..383264482d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.8 +version: 0.15.9 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 0d337102b30f35f793d33d0293228790e0e71d2f Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Tue, 30 May 2023 22:28:29 +0800 Subject: [PATCH 1545/1580] RE: Visible Type Applications (#4436) * Defer monomorphization for data constructors * Add test case for ConstrainedTypeUnified * Initial parsing rules for type applications * Add branches for AST traversals * Add type variable visibility * Better typing rule for visible type applications * Add visibility to constructors * Add visibility to type class methods * Instantiate constraints before subsumption * Implement type application skipping * Check type argument kind against type variable * Add pre-processing for the type argument * Update code for tests * Expand type synonyms after kind checking * Fix pretty-printing; regenerate golden tests * Add initial passing tests for type applications * Fold tyArg''' into tyArg'' * Initial errors and golden tests for errors * Add test case for type classes and data types * Move visibility parameter before the variable name * Include at-sign when flattening * Improve docstring for VisibleTypeApp Co-authored-by: Mark Eibes * Update error message for failed type applications * Add comments to clarify ForAll deserialization * Encode and decode ForAll as an object * Fix import in TestAst.hs * Simplify conversion in mkForAll --------- Co-authored-by: Mark Eibes --- src/Language/PureScript/AST/Declarations.hs | 4 + src/Language/PureScript/AST/Traversals.hs | 8 ++ src/Language/PureScript/CST/Convert.hs | 19 +-- src/Language/PureScript/CST/Flatten.hs | 7 +- src/Language/PureScript/CST/Parser.y | 17 ++- src/Language/PureScript/CST/Positions.hs | 3 +- src/Language/PureScript/CST/Types.hs | 5 +- src/Language/PureScript/CST/Utils.hs | 4 +- src/Language/PureScript/Docs/Convert.hs | 6 +- .../Docs/RenderedCode/RenderType.hs | 14 +- src/Language/PureScript/Environment.hs | 6 +- src/Language/PureScript/Errors.hs | 32 ++++- src/Language/PureScript/Ide/CaseSplit.hs | 2 +- src/Language/PureScript/Linter.hs | 5 +- src/Language/PureScript/Pretty/Types.hs | 18 +-- src/Language/PureScript/Pretty/Values.hs | 1 + src/Language/PureScript/Sugar/Names.hs | 2 + src/Language/PureScript/Sugar/TypeClasses.hs | 3 +- src/Language/PureScript/TypeChecker.hs | 2 +- .../PureScript/TypeChecker/Deriving.hs | 2 +- .../TypeChecker/Entailment/Coercible.hs | 2 +- src/Language/PureScript/TypeChecker/Kinds.hs | 35 ++--- src/Language/PureScript/TypeChecker/Roles.hs | 2 +- .../PureScript/TypeChecker/Skolems.hs | 8 +- .../PureScript/TypeChecker/Subsumption.hs | 4 +- src/Language/PureScript/TypeChecker/Types.hs | 48 ++++++- src/Language/PureScript/TypeChecker/Unify.hs | 4 +- src/Language/PureScript/Types.hs | 125 +++++++++++++----- tests/TestAst.hs | 6 +- tests/TestDocs.hs | 2 +- tests/purs/failing/3329.out | 2 +- tests/purs/failing/ConstraintFailure.out | 2 +- tests/purs/failing/TypedHole.out | 2 +- tests/purs/failing/TypedHole3.out | 10 +- .../purs/failing/VisibleTypeApplications1.out | 20 +++ .../failing/VisibleTypeApplications1.purs | 7 + .../purs/failing/VisibleTypeApplications2.out | 19 +++ .../failing/VisibleTypeApplications2.purs | 7 + .../purs/passing/VisibleTypeApplications.purs | 40 ++++++ tests/purs/warning/4376.out | 6 +- 40 files changed, 384 insertions(+), 127 deletions(-) create mode 100644 tests/purs/failing/VisibleTypeApplications1.out create mode 100644 tests/purs/failing/VisibleTypeApplications1.purs create mode 100644 tests/purs/failing/VisibleTypeApplications2.out create mode 100644 tests/purs/failing/VisibleTypeApplications2.purs create mode 100644 tests/purs/passing/VisibleTypeApplications.purs diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 5d8555cdbd..f9ca32b3a1 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -676,6 +676,10 @@ data Expr -- | App Expr Expr -- | + -- A type application (e.g. `f @Int`) + -- + | VisibleTypeApp Expr SourceType + -- | -- Hint that an expression is unused. -- This is used to ignore type class dictionaries that are necessarily empty. -- The inner expression lets us solve subgoals before eliminating the whole expression. diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 8aa8808a85..abbe6e5a15 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -75,6 +75,7 @@ everywhereOnValues f g h = (f', g', h') g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs)) g' (Abs binder v) = g (Abs (h' binder) (g' v)) g' (App v1 v2) = g (App (g' v1) (g' v2)) + g' (VisibleTypeApp v ty) = g (VisibleTypeApp (g' v) ty) g' (Unused v) = g (Unused (g' v)) g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3)) g' (Case vs alts) = g (Case (fmap g' vs) (fmap handleCaseAlternative alts)) @@ -149,6 +150,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> (g obj >>= g') <*> traverse (g' <=< g) vs g' (Abs binder v) = Abs <$> (h binder >>= h') <*> (g v >>= g') g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g') + g' (VisibleTypeApp v ty) = VisibleTypeApp <$> (g v >>= g') <*> pure ty g' (Unused v) = Unused <$> (g v >>= g') g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g') g' (Case vs alts) = Case <$> traverse (g' <=< g) vs <*> traverse handleCaseAlternative alts @@ -218,6 +220,7 @@ everywhereOnValuesM f g h = (f', g', h') g' (ObjectUpdateNested obj vs) = (ObjectUpdateNested <$> g' obj <*> traverse g' vs) >>= g g' (Abs binder v) = (Abs <$> h' binder <*> g' v) >>= g g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g + g' (VisibleTypeApp v ty) = (VisibleTypeApp <$> g' v <*> pure ty) >>= g g' (Unused v) = (Unused <$> g' v) >>= g g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g g' (Case vs alts) = (Case <$> traverse g' vs <*> traverse handleCaseAlternative alts) >>= g @@ -290,6 +293,7 @@ everythingOnValues (<>.) f g h i j = (f', g', h', i', j') g' v@(ObjectUpdateNested obj vs) = foldl (<>.) (g v <>. g' obj) (fmap g' vs) g' v@(Abs b v1) = g v <>. h' b <>. g' v1 g' v@(App v1 v2) = g v <>. g' v1 <>. g' v2 + g' v@(VisibleTypeApp v' _) = g v <>. g' v' g' v@(Unused v1) = g v <>. g' v1 g' v@(IfThenElse v1 v2 v3) = g v <>. g' v1 <>. g' v2 <>. g' v3 g' v@(Case vs alts) = foldl (<>.) (foldl (<>.) (g v) (fmap g' vs)) (fmap i' alts) @@ -371,6 +375,7 @@ everythingWithContextOnValues s0 r0 (<>.) f g h i j = (f'' s0, g'' s0, h'' s0, i g' s (ObjectUpdateNested obj vs) = foldl (<>.) (g'' s obj) (fmap (g'' s) vs) g' s (Abs binder v1) = h'' s binder <>. g'' s v1 g' s (App v1 v2) = g'' s v1 <>. g'' s v2 + g' s (VisibleTypeApp v _) = g'' s v g' s (Unused v) = g'' s v g' s (IfThenElse v1 v2 v3) = g'' s v1 <>. g'' s v2 <>. g'' s v3 g' s (Case vs alts) = foldl (<>.) (foldl (<>.) r0 (fmap (g'' s) vs)) (fmap (i'' s) alts) @@ -479,6 +484,7 @@ everywhereWithContextOnValuesM s0 f g h i j k = (f'' s0, g'' s0, h'' s0, i'' s0, g' s (ObjectUpdateNested obj vs) = ObjectUpdateNested <$> g'' s obj <*> traverse (g'' s) vs g' s (Abs binder v) = Abs <$> h' s binder <*> g'' s v g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2 + g' s (VisibleTypeApp v ty) = VisibleTypeApp <$> g'' s v <*> pure ty g' s (Unused v) = Unused <$> g'' s v g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3 g' s (Case vs alts) = Case <$> traverse (g'' s) vs <*> traverse (i'' s) alts @@ -587,6 +593,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s) let s' = S.union (S.fromList (localBinderNames b)) s in h'' s b <> g'' s' v1 g' s (App v1 v2) = g'' s v1 <> g'' s v2 + g' s (VisibleTypeApp v _) = g'' s v g' s (Unused v) = g'' s v g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 g' s (Case vs alts) = foldMap (g'' s) vs <> foldMap (i'' s) alts @@ -689,6 +696,7 @@ accumTypes f = everythingOnValues mappend forDecls forValues forBinders (const m forValues (TypeClassDictionary c _ _) = foldMap f (constraintArgs c) forValues (DeferredDictionary _ tys) = foldMap f tys forValues (TypedValue _ _ ty) = f ty + forValues (VisibleTypeApp _ ty) = f ty forValues _ = mempty forBinders (TypedBinder ty _) = f ty diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index b70754f897..1cbe9ef31d 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -136,11 +136,11 @@ convertType fileName = go T.TypeApp ann (Env.tyRecord $> annRec) $ goRow row b TypeForall _ kw bindings _ ty -> do let - mkForAll a b t = do + mkForAll a b v t = do let ann' = widenLeft (tokAnn $ nameTok a) $ T.getAnnForType t - T.ForAll ann' (getIdent $ nameValue a) b t Nothing - k (TypeVarKinded (Wrapped _ (Labeled a _ b) _)) = mkForAll a (Just (go b)) - k (TypeVarName a) = mkForAll a Nothing + T.ForAll ann' (maybe T.TypeVarInvisible (const T.TypeVarVisible) v) (getIdent $ nameValue a) b t Nothing + k (TypeVarKinded (Wrapped _ (Labeled (v, a) _ b) _)) = mkForAll a (Just (go b)) v + k (TypeVarName (v, a)) = mkForAll a Nothing v ty' = foldr k (go ty) bindings ann = widenLeft (tokAnn kw) $ T.getAnnForType ty' T.setAnnForType ann ty' @@ -335,6 +335,9 @@ convertExpr fileName = go expr@(ExprApp _ a b) -> do let ann = uncurry (sourceAnn fileName) $ exprRange expr positioned ann $ AST.App (go a) (go b) + expr@(ExprVisibleTypeApp _ a _ b) -> do + let ann = uncurry (sourceAnn fileName) $ exprRange expr + positioned ann $ AST.VisibleTypeApp (go a) (convertType fileName b) expr@(ExprLambda _ (Lambda _ as _ b)) -> do let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr positioned ann @@ -455,8 +458,8 @@ convertDeclaration fileName decl = case decl of pure $ AST.DataDeclaration ann Env.Newtype (nameValue a) (goTypeVar <$> vars) ctrs DeclClass _ (ClassHead _ sup name vars fdeps) bd -> do let - goTyVar (TypeVarKinded (Wrapped _ (Labeled a _ _) _)) = nameValue a - goTyVar (TypeVarName a) = nameValue a + goTyVar (TypeVarKinded (Wrapped _ (Labeled (_, a) _ _) _)) = nameValue a + goTyVar (TypeVarName (_, a)) = nameValue a vars' = zip (toList $ goTyVar <$> vars) [0..] goName = fromJust . flip lookup vars' . nameValue goFundep (FundepDetermined _ bs) = Env.FunctionalDependency [] (goName <$> NE.toList bs) @@ -593,8 +596,8 @@ convertDeclaration fileName decl = case decl of TypeUnaryRow{} -> "Row" goTypeVar = \case - TypeVarKinded (Wrapped _ (Labeled x _ y) _) -> (getIdent $ nameValue x, Just $ convertType fileName y) - TypeVarName x -> (getIdent $ nameValue x, Nothing) + TypeVarKinded (Wrapped _ (Labeled (_, x) _ y) _) -> (getIdent $ nameValue x, Just $ convertType fileName y) + TypeVarName (_, x) -> (getIdent $ nameValue x, Nothing) goInstanceBinding = \case InstanceBindingSignature _ lbl -> diff --git a/src/Language/PureScript/CST/Flatten.hs b/src/Language/PureScript/CST/Flatten.hs index c6e1b8c80a..890614070d 100644 --- a/src/Language/PureScript/CST/Flatten.hs +++ b/src/Language/PureScript/CST/Flatten.hs @@ -151,6 +151,7 @@ flattenExpr = \case ExprRecordAccessor _ a -> flattenRecordAccessor a ExprRecordUpdate _ a b -> flattenExpr a <> flattenWrapped (flattenSeparated flattenRecordUpdate) b ExprApp _ a b -> flattenExpr a <> flattenExpr b + ExprVisibleTypeApp _ a b c -> flattenExpr a <> pure b <> flattenType c ExprLambda _ a -> flattenLambda a ExprIf _ a -> flattenIfThenElse a ExprCase _ a -> flattenCaseOf a @@ -303,8 +304,10 @@ flattenRow (Row lbls tl) = flattenTypeVarBinding :: TypeVarBinding a -> DList SourceToken flattenTypeVarBinding = \case - TypeVarKinded a -> flattenWrapped (flattenLabeled (pure . nameTok) flattenType) a - TypeVarName a -> pure $ nameTok a + TypeVarKinded a -> flattenWrapped (flattenLabeled go flattenType) a + TypeVarName a -> go a + where + go (a, b) = maybe mempty pure a <> pure (nameTok b) flattenConstraint :: Constraint a -> DList SourceToken flattenConstraint = \case diff --git a/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y index 7785298c0e..edb60d93ec 100644 --- a/src/Language/PureScript/CST/Parser.y +++ b/src/Language/PureScript/CST/Parser.y @@ -347,8 +347,14 @@ rowLabel :: { Labeled Label (Type ()) } : label '::' type { Labeled $1 $2 $3 } typeVarBinding :: { TypeVarBinding () } - : ident { TypeVarName $1 } - | '(' ident '::' type ')' {% checkNoWildcards $4 *> pure (TypeVarKinded (Wrapped $1 (Labeled $2 $3 $4) $5)) } + : ident { TypeVarName (Nothing, $1) } + | '@' ident { TypeVarName (Just $1, $2) } + | '(' ident '::' type ')' {% checkNoWildcards $4 *> pure (TypeVarKinded (Wrapped $1 (Labeled (Nothing, $2) $3 $4) $5)) } + | '(' '@' ident '::' type ')' {% checkNoWildcards $5 *> pure (TypeVarKinded (Wrapped $1 (Labeled (Just $2, $3) $4 $5) $6)) } + +typeVarBindingPlain :: { TypeVarBinding () } + : ident { TypeVarName (Nothing, $1) } + | '(' ident '::' type ')' {% checkNoWildcards $4 *> pure (TypeVarKinded (Wrapped $1 (Labeled (Nothing, $2) $3 $4) $5)) } forall :: { SourceToken } : 'forall' { $1 } @@ -388,6 +394,7 @@ expr4 :: { Expr () } ExprApp () (ExprApp () $1 lhs) rhs _ -> ExprApp () $1 $2 } + | expr4 '@' typeAtom { ExprVisibleTypeApp () $1 $2 $3 } expr5 :: { Expr () } : expr6 { $1 } @@ -675,13 +682,13 @@ decl :: { Declaration () } | 'type' 'role' properName many(role) { DeclRole () $1 $2 (getProperName $3) $4 } dataHead :: { DataHead () } - : 'data' properName manyOrEmpty(typeVarBinding) { DataHead $1 (getProperName $2) $3 } + : 'data' properName manyOrEmpty(typeVarBindingPlain) { DataHead $1 (getProperName $2) $3 } typeHead :: { DataHead () } - : 'type' properName manyOrEmpty(typeVarBinding) { DataHead $1 (getProperName $2) $3 } + : 'type' properName manyOrEmpty(typeVarBindingPlain) { DataHead $1 (getProperName $2) $3 } newtypeHead :: { DataHead () } - : 'newtype' properName manyOrEmpty(typeVarBinding) { DataHead $1 (getProperName $2) $3 } + : 'newtype' properName manyOrEmpty(typeVarBindingPlain) { DataHead $1 (getProperName $2) $3 } dataCtor :: { DataCtor () } : properName manyOrEmpty(typeAtom) diff --git a/src/Language/PureScript/CST/Positions.hs b/src/Language/PureScript/CST/Positions.hs index f8b6167d51..20d5724271 100644 --- a/src/Language/PureScript/CST/Positions.hs +++ b/src/Language/PureScript/CST/Positions.hs @@ -269,7 +269,7 @@ constraintRange = \case typeVarBindingRange :: TypeVarBinding a -> TokenRange typeVarBindingRange = \case TypeVarKinded a -> wrappedRange a - TypeVarName a -> nameRange a + TypeVarName (atSign, a) -> (fromMaybe (nameTok a) atSign, nameTok a) exprRange :: Expr a -> TokenRange exprRange = \case @@ -292,6 +292,7 @@ exprRange = \case ExprRecordAccessor _ (RecordAccessor a _ b) -> (fst $ exprRange a, lblTok $ sepLast b) ExprRecordUpdate _ a b -> (fst $ exprRange a, snd $ wrappedRange b) ExprApp _ a b -> (fst $ exprRange a, snd $ exprRange b) + ExprVisibleTypeApp _ a _ b -> (fst $ exprRange a, snd $ typeRange b) ExprLambda _ (Lambda a _ _ b) -> (a, snd $ exprRange b) ExprIf _ (IfThenElse a _ _ _ _ b) -> (a, snd $ exprRange b) ExprCase _ (CaseOf a _ _ c) -> (a, snd . guardedRange . snd $ NE.last c) diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs index d4dec40c04..a89532f1fa 100644 --- a/src/Language/PureScript/CST/Types.hs +++ b/src/Language/PureScript/CST/Types.hs @@ -153,8 +153,8 @@ data Type a deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) data TypeVarBinding a - = TypeVarKinded (Wrapped (Labeled (Name Ident) (Type a))) - | TypeVarName (Name Ident) + = TypeVarKinded (Wrapped (Labeled (Maybe SourceToken, Name Ident) (Type a))) + | TypeVarName (Maybe SourceToken, Name Ident) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) data Constraint a @@ -337,6 +337,7 @@ data Expr a | ExprRecordAccessor a (RecordAccessor a) | ExprRecordUpdate a (Expr a) (DelimitedNonEmpty (RecordUpdate a)) | ExprApp a (Expr a) (Expr a) + | ExprVisibleTypeApp a (Expr a) SourceToken (Type a) | ExprLambda a (Lambda a) | ExprIf a (IfThenElse a) | ExprCase a (CaseOf a) diff --git a/src/Language/PureScript/CST/Utils.hs b/src/Language/PureScript/CST/Utils.hs index 3d17a03ea2..b941cf5fcf 100644 --- a/src/Language/PureScript/CST/Utils.hs +++ b/src/Language/PureScript/CST/Utils.hs @@ -248,8 +248,8 @@ checkFundeps :: ClassHead a -> Parser () checkFundeps (ClassHead _ _ _ _ Nothing) = pure () checkFundeps (ClassHead _ _ _ vars (Just (_, fundeps))) = do let - k (TypeVarKinded (Wrapped _ (Labeled a _ _) _)) = getIdent $ nameValue a - k (TypeVarName a) = getIdent $ nameValue a + k (TypeVarKinded (Wrapped _ (Labeled (_, a) _ _) _)) = getIdent $ nameValue a + k (TypeVarName (_, a)) = getIdent $ nameValue a names = k <$> vars check a | getIdent (nameValue a) `elem` names = pure () diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 9e3ff10cf6..a7dc1758c7 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -119,7 +119,7 @@ insertValueTypesAndAdjustKinds env m = where countParams :: Int -> Type' -> Int countParams acc = \case - P.ForAll _ _ _ rest _ -> + P.ForAll _ _ _ _ rest _ -> countParams acc rest P.TypeApp _ f a | isFunctionApplication f -> @@ -232,8 +232,8 @@ insertValueTypesAndAdjustKinds env m = -- changes `forall (k :: Type). k -> ...` -- to `forall k . k -> ...` dropTypeSortAnnotation = \case - P.ForAll sa txt (Just (P.TypeConstructor _ Prim.Type)) rest skol -> - P.ForAll sa txt Nothing (dropTypeSortAnnotation rest) skol + P.ForAll sa vis txt (Just (P.TypeConstructor _ Prim.Type)) rest skol -> + P.ForAll sa vis txt Nothing (dropTypeSortAnnotation rest) skol rest -> rest Nothing -> diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index a0d55988d9..a082b4b833 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -26,7 +26,7 @@ import Language.PureScript.Label (Label) import Language.PureScript.Names (coerceProperName) import Language.PureScript.Pretty.Types (PrettyPrintConstraint, PrettyPrintType(..), convertPrettyPrintType, prettyPrintLabel) import Language.PureScript.Roles (Role, displayRole) -import Language.PureScript.Types (Type) +import Language.PureScript.Types (Type, TypeVarVisibility, typeVarVisibilityPrefix) import Language.PureScript.PSString (prettyPrintString) import Language.PureScript.Docs.RenderedCode.Types (RenderedCode, keywordForall, roleAnn, sp, syntax, typeCtor, typeOp, typeVar) @@ -149,7 +149,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom , [ Wrap explicitParens $ \_ ty -> ty ] ] -forall_ :: Pattern () PrettyPrintType ([(Text, Maybe PrettyPrintType)], PrettyPrintType) +forall_ :: Pattern () PrettyPrintType ([(TypeVarVisibility, Text, Maybe PrettyPrintType)], PrettyPrintType) forall_ = mkPattern match where match (PPForAll mbKindedIdents ty) = Just (mbKindedIdents, ty) @@ -235,13 +235,13 @@ renderType' = fromMaybe (internalError "Incomplete pattern") . PA.pattern matchType () -renderTypeVars :: [(Text, Maybe PrettyPrintType)] -> RenderedCode +renderTypeVars :: [(TypeVarVisibility, Text, Maybe PrettyPrintType)] -> RenderedCode renderTypeVars tyVars = mintersperse sp (map renderTypeVar tyVars) -renderTypeVar :: (Text, Maybe PrettyPrintType) -> RenderedCode -renderTypeVar (v, mbK) = case mbK of - Nothing -> typeVar v - Just k -> mintersperse sp [ mconcat [syntax "(", typeVar v], syntax "::", mconcat [renderType' k, syntax ")"] ] +renderTypeVar :: (TypeVarVisibility, Text, Maybe PrettyPrintType) -> RenderedCode +renderTypeVar (vis, v, mbK) = case mbK of + Nothing -> syntax (typeVarVisibilityPrefix vis) <> typeVar v + Just k -> mintersperse sp [ mconcat [syntax "(", syntax $ typeVarVisibilityPrefix vis, typeVar v], syntax "::", mconcat [renderType' k, syntax ")"] ] -- | -- Render code representing a Type, as it should appear inside parentheses diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index a1ef8c3fbe..de1b35d3c9 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -25,7 +25,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, QualifiedBy, coerceProperName) import Language.PureScript.Roles (Role(..)) import Language.PureScript.TypeClassDictionaries (NamedDict) -import Language.PureScript.Types (SourceConstraint, SourceType, Type(..), eqType, srcTypeConstructor) +import Language.PureScript.Types (SourceConstraint, SourceType, Type(..), TypeVarVisibility(..), eqType, srcTypeConstructor) import Language.PureScript.Constants.Prim qualified as C -- | The @Environment@ defines all values and types which are currently in scope: @@ -341,7 +341,7 @@ tyVar :: Text -> SourceType tyVar = TypeVar nullSourceAnn tyForall :: Text -> SourceType -> SourceType -> SourceType -tyForall var k ty = ForAll nullSourceAnn var (Just k) ty Nothing +tyForall var k ty = ForAll nullSourceAnn TypeVarInvisible var (Just k) ty Nothing -- | Smart constructor for function types function :: SourceType -> SourceType -> SourceType @@ -669,5 +669,5 @@ unapplyKinds :: Type a -> ([Type a], Type a) unapplyKinds = go [] where go kinds (TypeApp _ (TypeApp _ fn k1) k2) | eqType fn tyFunction = go (k1 : kinds) k2 - go kinds (ForAll _ _ _ k _) = go kinds k + go kinds (ForAll _ _ _ _ k _) = go kinds k go kinds k = (reverse kinds, k) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 4fc63d4419..972e6b69a8 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -47,7 +47,7 @@ import Language.PureScript.Pretty.Common (endWith) import Language.PureScript.PSString (decodeStringWithReplacement) import Language.PureScript.Roles (Role, displayRole) import Language.PureScript.Traversals (sndM) -import Language.PureScript.Types (Constraint(..), ConstraintData(..), RowListItem(..), SourceConstraint, SourceType, Type(..), eraseForAllKindAnnotations, eraseKindApps, everywhereOnTypesTopDownM, getAnnForType, overConstraintArgs, rowFromList, rowToList, srcTUnknown) +import Language.PureScript.Types (Constraint(..), ConstraintData(..), RowListItem(..), SourceConstraint, SourceType, Type(..), eraseForAllKindAnnotations, eraseKindApps, everywhereOnTypesTopDownM, getAnnForType, isMonoType, overConstraintArgs, rowFromList, rowToList, srcTUnknown) import Language.PureScript.Publish.BoxesHelpers qualified as BoxHelpers import System.Console.ANSI qualified as ANSI import System.FilePath (makeRelative) @@ -196,6 +196,8 @@ data SimpleErrorMessage | RoleDeclarationArityMismatch (ProperName 'TypeName) Int Int | DuplicateRoleDeclaration (ProperName 'TypeName) | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) [Qualified (ProperName 'ClassName)] Bool + | CannotSkipTypeApplication SourceType + | CannotApplyExpressionOfTypeOnType SourceType SourceType deriving (Show) data ErrorMessage = ErrorMessage @@ -364,6 +366,8 @@ errorCode em = case unwrapErrorMessage em of RoleDeclarationArityMismatch {} -> "RoleDeclarationArityMismatch" DuplicateRoleDeclaration {} -> "DuplicateRoleDeclaration" CannotDeriveInvalidConstructorArg{} -> "CannotDeriveInvalidConstructorArg" + CannotSkipTypeApplication{} -> "CannotSkipTypeApplication" + CannotApplyExpressionOfTypeOnType{} -> "CannotApplyExpressionOfTypeOnType" -- | A stack trace for an error newtype MultipleErrors = MultipleErrors @@ -1394,6 +1398,32 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon <> "and that those type constructors themselves have instances of " <> commasAndConjunction "or" (markCode . showQualified runProperName <$> relatedClasses) <> "." ] + renderSimpleErrorMessage (CannotSkipTypeApplication tyFn) = + paras + [ "An expression of type:" + , markCodeBox $ indent $ prettyType tyFn + , "cannot be skipped." + ] + + renderSimpleErrorMessage (CannotApplyExpressionOfTypeOnType tyFn tyAr) = + paras $ infoLine <> + [ markCodeBox $ indent $ prettyType tyFn + , "cannot be applied to:" + , markCodeBox $ indent $ prettyType tyAr + ] + where + infoLine = + if isMonoType tyFn then + [ "An expression of monomorphic type:" ] + else + [ "An expression of polymorphic type" + , line $ "with the invisible type variable " <> markCode typeVariable <> ":" + ] + + typeVariable = case tyFn of + ForAll _ _ v _ _ _ -> v + _ -> internalError "renderSimpleErrorMessage: Impossible!" + renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1@RCons{} t2@RCons{}) detail = let (row1Box, row2Box) = printRows t1 t2 diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs index 56cb464f05..8c66f55457 100644 --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -148,7 +148,7 @@ splitFunctionType t = fromMaybe [] arguments where arguments = initMay splitted splitted = splitType' t - splitType' (P.ForAll _ _ _ t' _) = splitType' t' + splitType' (P.ForAll _ _ _ _ t' _) = splitType' t' splitType' (P.ConstrainedType _ _ t') = splitType' t' splitType' (P.TypeApp _ (P.TypeApp _ t' lhs) rhs) | P.eqType t' P.tyFunction = lhs : splitType' rhs diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 95f4029cdf..9bce1909de 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -86,7 +86,7 @@ lint modl@(Module _ _ mn ds _) = do where step :: S.Set Text -> SourceType -> (S.Set Text, MultipleErrors) - step s (ForAll _ tv _ _ _) = bindVar s tv + step s (ForAll _ _ tv _ _ _) = bindVar s tv step s _ = (s, mempty) bindVar :: S.Set Text -> Text -> (S.Set Text, MultipleErrors) @@ -97,7 +97,7 @@ lint modl@(Module _ _ mn ds _) = do -- Recursively walk the type and prune used variables from `unused` go :: S.Set Text -> SourceType -> (S.Set Text, MultipleErrors) go unused (TypeVar _ v) = (S.delete v unused, mempty) - go unused (ForAll _ tv mbK t1 _) = + go unused (ForAll _ _ tv mbK t1 _) = let (nowUnused, errors) | Just k <- mbK = go unused k `combine` go (S.insert tv unused) t1 | otherwise = go (S.insert tv unused) t1 @@ -212,6 +212,7 @@ lintUnused (Module modSS _ mn modDecls exports) = goNode (Branch val) = goTree val go (App v1 v2) = go v1 <> go v2 + go (VisibleTypeApp v _) = go v go (Unused v) = go v go (IfThenElse v1 v2 v3) = go v1 <> go v2 <> go v3 go (Case vs alts) = diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index e318d352f5..20de0ed9e2 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -19,9 +19,9 @@ module Language.PureScript.Pretty.Types import Prelude hiding ((<>)) import Control.Arrow ((<+>)) +import Control.Lens (_2, (%~)) import Control.PatternArrows as PA -import Data.Bifunctor (first) import Data.Maybe (fromMaybe, catMaybes) import Data.Text (Text) import Data.Text qualified as T @@ -30,7 +30,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (tyFunction, tyRecord) import Language.PureScript.Names (OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified, coerceProperName, disqualify, showQualified) import Language.PureScript.Pretty.Common (before, objectKeyRequiresQuoting) -import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), Type(..), WildcardData(..), eqType, rowToSortedList) +import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), Type(..), TypeVarVisibility(..), WildcardData(..), eqType, rowToSortedList, typeVarVisibilityPrefix) import Language.PureScript.PSString (PSString, prettyPrintString, decodeString) import Language.PureScript.Label (Label(..)) @@ -51,7 +51,7 @@ data PrettyPrintType | PPKindedType PrettyPrintType PrettyPrintType | PPBinaryNoParensType PrettyPrintType PrettyPrintType PrettyPrintType | PPParensInType PrettyPrintType - | PPForAll [(Text, Maybe PrettyPrintType)] PrettyPrintType + | PPForAll [(TypeVarVisibility, Text, Maybe PrettyPrintType)] PrettyPrintType | PPFunction PrettyPrintType PrettyPrintType | PPRecord [(Label, PrettyPrintType)] (Maybe PrettyPrintType) | PPRow [(Label, PrettyPrintType)] (Maybe PrettyPrintType) @@ -81,11 +81,11 @@ convertPrettyPrintType = go go d (BinaryNoParensType _ ty1 ty2 ty3) = PPBinaryNoParensType (go (d-1) ty1) (go (d-1) ty2) (go (d-1) ty3) go d (ParensInType _ ty) = PPParensInType (go (d-1) ty) go d ty@RCons{} = uncurry PPRow (goRow d ty) - go d (ForAll _ v mbK ty _) = goForAll d [(v, fmap (go (d-1)) mbK)] ty + go d (ForAll _ vis v mbK ty _) = goForAll d [(vis, v, fmap (go (d-1)) mbK)] ty go d (TypeApp _ a b) = goTypeApp d a b go d (KindApp _ a b) = PPTypeApp (go (d-1) a) (PPKindArg (go (d-1) b)) - goForAll d vs (ForAll _ v mbK ty _) = goForAll d ((v, fmap (go (d-1)) mbK) : vs) ty + goForAll d vs (ForAll _ vis v mbK ty _) = goForAll d ((vis, v, fmap (go (d-1)) mbK) : vs) ty goForAll d vs ty = PPForAll (reverse vs) (go (d-1) ty) goRow d ty = @@ -219,8 +219,8 @@ matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where forall' = if troUnicode tro then "∀" else "forall" doubleColon = if troUnicode tro then "∷" else "::" - printMbKindedType (v, Nothing) = text v - printMbKindedType (v, Just k) = text ("(" ++ v ++ " " ++ doubleColon ++ " ") <> typeAsBox' k <> text ")" + printMbKindedType (vis, v, Nothing) = text (T.unpack $ typeVarVisibilityPrefix vis) <> text v + printMbKindedType (vis, v, Just k) = text ("(" ++ T.unpack (typeVarVisibilityPrefix vis) ++ v ++ " " ++ doubleColon ++ " ") <> typeAsBox' k <> text ")" -- If both boxes span a single line, keep them on the same line, or else -- use the specified function to modify the second box, then combine vertically. @@ -229,10 +229,10 @@ matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where | rows b1 > 1 || rows b2 > 1 = vcat left [ b1, f b2 ] | otherwise = hcat top [ b1, text " ", b2] -forall_ :: Pattern () PrettyPrintType ([(String, Maybe PrettyPrintType)], PrettyPrintType) +forall_ :: Pattern () PrettyPrintType ([(TypeVarVisibility, String, Maybe PrettyPrintType)], PrettyPrintType) forall_ = mkPattern match where - match (PPForAll idents ty) = Just (map (first T.unpack) idents, ty) + match (PPForAll idents ty) = Just ((_2 %~ T.unpack) <$> idents, ty) match _ = Nothing typeAtomAsBox' :: PrettyPrintType -> Box diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 85b6638fdc..4d5a5ec604 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -66,6 +66,7 @@ prettyPrintValue d (ObjectUpdateNested o ps) = prettyPrintValueAtom (d - 1) o `b printNode (key, Leaf val) = prettyPrintUpdateEntry d key val printNode (key, Branch val) = textT (prettyPrintObjectKey key) `beforeWithSpace` prettyPrintUpdate val prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg +prettyPrintValue d (VisibleTypeApp val _) = prettyPrintValueAtom (d - 1) val prettyPrintValue d (Unused val) = prettyPrintValue d val prettyPrintValue d (Abs arg val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (Case values binders) = diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 2202633667..d081764d7f 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -289,6 +289,8 @@ renameInModule imports (Module modSS coms mn decls exps) = ((ss, bound), ) <$> (Constructor ss <$> updateDataConstructorName name ss) updateValue s (TypedValue check val ty) = (s, ) <$> (TypedValue check val <$> updateTypesEverywhere ty) + updateValue s (VisibleTypeApp val ty) = + (s, ) <$> VisibleTypeApp val <$> updateTypesEverywhere ty updateValue s v = return (s, v) updateBinder diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index a5bfa59b90..ca7a901f6f 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -300,10 +300,11 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarati dictObjIdent = Ident "v" ctor = ConstructorBinder ss (coerceProperName . dictTypeName <$> className) [VarBinder ss dictObjIdent] acsr = Accessor (mkString $ runIdent ident) (Var ss (Qualified ByNullSourcePos dictObjIdent)) + visibility = second (const TypeVarVisible) <$> args in ValueDecl sa ident Private [] [MkUnguarded ( TypedValue False (Abs (VarBinder ss dictIdent) (Case [Var ss $ Qualified ByNullSourcePos dictIdent] [CaseAlternative [ctor] [MkUnguarded acsr]])) $ - moveQuantifiersToFront (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty)) + addVisibility visibility (moveQuantifiersToFront (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty))) )] typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 3f5043ad24..3030750db2 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -566,7 +566,7 @@ typeCheckAll moduleName = traverse go -- withKinds :: [(Text, Maybe SourceType)] -> SourceType -> [(Text, Maybe SourceType)] withKinds [] _ = [] - withKinds ss (ForAll _ _ _ k _) = withKinds ss k + withKinds ss (ForAll _ _ _ _ k _) = withKinds ss k withKinds (s@(_, Just _):ss) (TypeApp _ (TypeApp _ tyFn _) k2) | eqType tyFn tyFunction = s : withKinds ss k2 withKinds ((s, Nothing):ss) (TypeApp _ (TypeApp _ tyFn k1) k2) | eqType tyFn tyFunction = (s, Just k1) : withKinds ss k2 withKinds _ _ = internalError "Invalid arguments to withKinds" diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index b0114618bf..8d5dcde9b6 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -499,7 +499,7 @@ validateParamsInTypeConstructors derivingClass utc isBi CovariantClasses{..} con headOfTypeWithSubst = headOfType . replaceAllTypeVars subst in \case - ForAll _ name _ ty _ -> + ForAll _ _ name _ ty _ -> fmap join . traverse (\params' -> go params' isNegative ty) $ filterThese (/= name) params ConstrainedType _ _ ty -> diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index bbc0e49411..c8abb597c8 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -383,7 +383,7 @@ rewrite env (Skolem _ _ _ s1 _, ty1) | not $ occurs s1 ty1 = go where | (TypeConstructor _ tyName, _, _) <- unapplyTypes ty2 = do rewriteTyConApp go (lookupRoles env tyName) ty2 go (KindApp sa ty k) = KindApp sa <$> go ty <*> pure k - go (ForAll sa tv k ty scope) = ForAll sa tv k <$> go ty <*> pure scope + go (ForAll sa vis tv k ty scope) = ForAll sa vis tv k <$> go ty <*> pure scope go (ConstrainedType sa Constraint{..} ty) | s1 `S.notMember` foldMap skolems constraintArgs = ConstrainedType sa Constraint{..} <$> go ty go (RCons sa label ty rest) = RCons sa label <$> go ty <*> go rest diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index b39d980c3e..5be87c0057 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -34,7 +34,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State (MonadState, gets, modify) import Control.Monad.Supply.Class (MonadSupply(..)) -import Data.Bifunctor (first) +import Data.Bifunctor (first, second) import Data.Bitraversable (bitraverse) import Data.Foldable (for_, traverse_) import Data.Function (on) @@ -215,7 +215,7 @@ inferKind = \tyToInfer -> KindApp ann t1 t2 -> do (t1', kind) <- bitraverse pure apply =<< go t1 case kind of - ForAll _ arg (Just argKind) resKind _ -> do + ForAll _ _ arg (Just argKind) resKind _ -> do t2' <- checkKind t2 argKind pure (KindApp ann t1' t2', replaceTypeVars arg t2' resKind) _ -> @@ -225,7 +225,7 @@ inferKind = \tyToInfer -> t1' <- checkKind t1 t2' t2'' <- apply t2' pure (t1', t2'') - ForAll ann arg mbKind ty sc -> do + ForAll ann vis arg mbKind ty sc -> do moduleName <- unsafeCheckCurrentModule kind <- case mbKind of Just k -> replaceAllTypeSynonyms =<< checkIsSaturatedType k @@ -235,7 +235,7 @@ inferKind = \tyToInfer -> unks <- unknownsWithKinds . IS.toList $ unknowns ty' pure (ty', unks) for_ unks . uncurry $ addUnsolved Nothing - pure (ForAll ann arg (Just kind) ty' sc, E.kindType $> ann) + pure (ForAll ann vis arg (Just kind) ty' sc, E.kindType $> ann) ParensInType _ ty -> go ty ty -> @@ -261,7 +261,7 @@ inferAppKind ann (fn, fnKind) arg = case fnKind of solve u $ (TUnknown ann u1 E.-:> TUnknown ann u2) $> ann arg' <- checkKind arg $ TUnknown ann u1 pure (TypeApp ann fn arg', TUnknown ann u2) - ForAll _ a (Just k) ty _ -> do + ForAll _ _ a (Just k) ty _ -> do u <- freshUnknown addUnsolved Nothing u k inferAppKind ann (KindApp ann fn (TUnknown ann u), replaceTypeVars a (TUnknown ann u) ty) arg @@ -336,7 +336,7 @@ instantiateKind -> SourceType -> m SourceType instantiateKind (ty, kind1) kind2 = case kind1 of - ForAll _ a (Just k) t _ | shouldInstantiate kind2 -> do + ForAll _ _ a (Just k) t _ | shouldInstantiate kind2 -> do let ann = getAnnForType ty u <- freshKindWithKind (fst ann) k instantiateKind (KindApp ann ty u, replaceTypeVars a u t) kind2 @@ -345,7 +345,7 @@ instantiateKind (ty, kind1) kind2 = case kind1 of pure ty where shouldInstantiate = not . \case - ForAll _ _ _ _ _ -> True + ForAll _ _ _ _ _ _ -> True _ -> False subsumesKind @@ -361,11 +361,11 @@ subsumesKind = go , eqType arr2 E.tyFunction -> do go b1 a1 join $ go <$> apply a2 <*> apply b2 - (a, ForAll ann var mbKind b mbScope) -> do + (a, ForAll ann _ var mbKind b mbScope) -> do scope <- maybe newSkolemScope pure mbScope skolc <- newSkolemConstant go a $ skolemize ann var mbKind skolc scope b - (ForAll ann var (Just kind) a _, b) -> do + (ForAll ann _ var (Just kind) a _, b) -> do a' <- freshKindWithKind (fst ann) kind go (replaceTypeVars var a' a) b (TUnknown ann u, b@(TypeApp _ (TypeApp _ arr _) _)) @@ -559,11 +559,11 @@ elaborateKind = \case KindApp ann t1 t2 -> do k1 <- elaborateKind t1 case k1 of - ForAll _ a _ n _ -> do + ForAll _ _ a _ n _ -> do flip (replaceTypeVars a) n . ($> ann) <$> apply t2 _ -> cannotApplyKindToType t1 t2 - ForAll ann _ _ _ _ -> do + ForAll ann _ _ _ _ _ -> do pure $ E.kindType $> ann ConstrainedType ann _ _ -> pure $ E.kindType $> ann @@ -651,8 +651,9 @@ inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do tyCtor = foldl (\ty -> srcKindApp ty . srcTypeVar . fst . snd) tyCtorName sigBinders tyCtor' = foldl (\ty -> srcTypeApp ty . srcTypeVar . fst) tyCtor tyArgs' ctorBinders = fmap (fmap (fmap Just)) $ sigBinders <> fmap (nullSourceAnn,) tyArgs' + visibility = second (const TypeVarVisible) <$> tyArgs for ctors $ - fmap (fmap (mkForAll ctorBinders)) . inferDataConstructor tyCtor' + fmap (fmap (addVisibility visibility . mkForAll ctorBinders)) . inferDataConstructor tyCtor' inferDataConstructor :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) @@ -767,7 +768,7 @@ checkTypeQuantification = unknownsInKinds False _ = (False, []) unknownsInKinds _ ty = case ty of - ForAll sa _ _ _ _ | unks <- unknowns ty, not (IS.null unks) -> + ForAll sa _ _ _ _ _ | unks <- unknowns ty, not (IS.null unks) -> (False, [(fst sa, unks, ty)]) KindApp sa _ _ | unks <- unknowns ty, not (IS.null unks) -> (False, [(fst sa, unks, ty)]) @@ -916,15 +917,15 @@ checkKindDeclaration _ ty = do -- be referenced (easily). freshVar arg = (arg <>) . T.pack . show <$> fresh freshenForAlls = curry $ \case - (ForAll _ v1 _ ty1 _, ForAll a2 v2 k2 ty2 sc2) | v1 == v2 -> do + (ForAll _ _ v1 _ ty1 _, ForAll a2 vis v2 k2 ty2 sc2) | v1 == v2 -> do ty2' <- freshenForAlls ty1 ty2 - pure $ ForAll a2 v2 k2 ty2' sc2 + pure $ ForAll a2 vis v2 k2 ty2' sc2 (_, ty2) -> go ty2 where go = \case - ForAll a' v' k' ty' sc' -> do + ForAll a' vis v' k' ty' sc' -> do v'' <- freshVar v' ty'' <- go (replaceTypeVars v' (TypeVar a' v'') ty') - pure $ ForAll a' v'' k' ty'' sc' + pure $ ForAll a' vis v'' k' ty'' sc' other -> pure other checkValidKind = everywhereOnTypesM $ \case diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index fb43b2e821..7b38a317b7 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -195,7 +195,7 @@ inferDataDeclarationRoles moduleName (tyName, tyArgs, ctors) roleEnv = mempty | otherwise = RoleMap $ M.singleton v Representational - walk btvs (ForAll _ tv _ t _) = + walk btvs (ForAll _ _ tv _ t _) = -- We can walk under universal quantifiers as long as we make note of the -- variables that they bind. For instance, given a definition -- @data T z = T (forall z. z -> z)@, we will make note that @z@ is bound diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index 3c49d2bf36..aa49997fd6 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -34,7 +34,7 @@ newSkolemConstant = do introduceSkolemScope :: MonadState CheckState m => Type a -> m (Type a) introduceSkolemScope = everywhereOnTypesM go where - go (ForAll ann ident mbK ty Nothing) = ForAll ann ident mbK ty <$> (Just <$> newSkolemScope) + go (ForAll ann vis ident mbK ty Nothing) = ForAll ann vis ident mbK ty <$> (Just <$> newSkolemScope) go other = return other -- | Generate a new skolem scope @@ -63,6 +63,8 @@ skolemizeTypesInValue ann ident mbK sko scope = | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ann ident mbK sko scope) ts)) onExpr sco (TypedValue check val ty) | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ann ident mbK sko scope ty)) + onExpr sco (VisibleTypeApp val ty) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, VisibleTypeApp val (skolemize ann ident mbK sko scope ty)) onExpr sco other = return (sco, other) onBinder :: [Text] -> Binder -> Identity ([Text], Binder) @@ -71,7 +73,7 @@ skolemizeTypesInValue ann ident mbK sko scope = onBinder sco other = return (sco, other) peelTypeVars :: SourceType -> [Text] - peelTypeVars (ForAll _ i _ ty _) = i : peelTypeVars ty + peelTypeVars (ForAll _ _ i _ ty _) = i : peelTypeVars ty peelTypeVars _ = [] -- | Ensure skolem variables do not escape their scope @@ -116,7 +118,7 @@ skolemEscapeCheck expr@TypedValue{} = -- Collect any scopes appearing in quantifiers at the top level collectScopes :: SourceType -> [SkolemScope] - collectScopes (ForAll _ _ _ t (Just sco)) = sco : collectScopes t + collectScopes (ForAll _ _ _ _ t (Just sco)) = sco : collectScopes t collectScopes ForAll{} = internalError "skolemEscapeCheck: No skolem scope" collectScopes _ = [] diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index e99f1c829c..26da5e980f 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -74,11 +74,11 @@ subsumes' -> SourceType -> SourceType -> m (Coercion mode) -subsumes' mode (ForAll _ ident mbK ty1 _) ty2 = do +subsumes' mode (ForAll _ _ ident mbK ty1 _) ty2 = do u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK let replaced = replaceTypeVars ident u ty1 subsumes' mode replaced ty2 -subsumes' mode ty1 (ForAll _ ident mbK ty2 sco) = +subsumes' mode ty1 (ForAll _ _ ident mbK ty2 sco) = case sco of Just sco' -> do sko <- newSkolemConstant diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index ab532057e8..04f7de22fe 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -52,7 +52,7 @@ import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleError import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent) import Language.PureScript.TypeChecker.Deriving (deriveInstance) import Language.PureScript.TypeChecker.Entailment (InstanceContext, newDictionaries, replaceTypeClassDictionaries) -import Language.PureScript.TypeChecker.Kinds (checkConstraint, checkTypeKind, kindOf, kindOfWithScopedVars, unifyKinds', unknownsWithKinds) +import Language.PureScript.TypeChecker.Kinds (checkConstraint, checkKind, checkTypeKind, kindOf, kindOfWithScopedVars, unifyKinds', unknownsWithKinds) import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Skolems (introduceSkolemScope, newSkolemConstant, newSkolemScope, skolemEscapeCheck, skolemize, skolemizeTypesInValue) import Language.PureScript.TypeChecker.Subsumption (subsumes) @@ -325,7 +325,7 @@ instantiatePolyTypeWithUnknowns => Expr -> SourceType -> m (Expr, SourceType) -instantiatePolyTypeWithUnknowns val (ForAll _ ident mbK ty _) = do +instantiatePolyTypeWithUnknowns val (ForAll _ _ ident mbK ty _) = do u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK insertUnkName' u ident instantiatePolyTypeWithUnknowns val $ replaceTypeVars ident u ty @@ -335,6 +335,24 @@ instantiatePolyTypeWithUnknowns val (ConstrainedType _ con ty) = do instantiatePolyTypeWithUnknowns (App val (TypeClassDictionary con dicts hints)) ty instantiatePolyTypeWithUnknowns val ty = return (val, ty) +instantiatePolyTypeWithUnknownsUntilVisible + :: (MonadState CheckState m, MonadError MultipleErrors m) + => Expr + -> SourceType + -> m (Expr, SourceType) +instantiatePolyTypeWithUnknownsUntilVisible val (ForAll _ TypeVarInvisible ident mbK ty _) = do + u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK + insertUnkName' u ident + instantiatePolyTypeWithUnknownsUntilVisible val $ replaceTypeVars ident u ty +instantiatePolyTypeWithUnknownsUntilVisible val ty = return (val, ty) + +instantiateConstraint :: MonadState CheckState m => Expr -> Type SourceAnn -> m (Expr, Type SourceAnn) +instantiateConstraint val (ConstrainedType _ con ty) = do + dicts <- getTypeClassDictionaries + hints <- getHints + instantiateConstraint (App val (TypeClassDictionary con dicts hints)) ty +instantiateConstraint val ty = pure (val, ty) + -- | Match against TUnknown and call insertUnkName, failing otherwise. insertUnkName' :: (MonadState CheckState m, MonadError MultipleErrors m) => SourceType -> Text -> m () insertUnkName' (TUnknown _ i) n = insertUnkName i n @@ -441,6 +459,26 @@ infer' (App f arg) = do f'@(TypedValue' _ _ ft) <- infer f (ret, app) <- checkFunctionApplication (tvToExpr f') ft arg return $ TypedValue' True app ret +infer' (VisibleTypeApp valFn (TypeWildcard _ _)) = do + TypedValue' _ valFn' valTy <- infer valFn + (valFn'', valTy') <- instantiatePolyTypeWithUnknownsUntilVisible valFn' valTy + case valTy' of + ForAll qAnn _ qName qKind qBody qSko -> do + pure $ TypedValue' True valFn'' (ForAll qAnn TypeVarInvisible qName qKind qBody qSko) + _ -> + throwError $ errorMessage $ CannotSkipTypeApplication valTy' +infer' (VisibleTypeApp valFn tyArg) = do + TypedValue' _ valFn' valTy <- infer valFn + tyArg' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ tyArg + (valFn'', valTy') <- instantiatePolyTypeWithUnknownsUntilVisible valFn' valTy + case valTy' of + ForAll _ _ qName (Just qKind) qBody _ -> do + tyArg'' <- replaceAllTypeSynonyms <=< checkKind tyArg' $ qKind + let resTy = replaceTypeVars qName tyArg'' qBody + (valFn''', resTy') <- instantiateConstraint valFn'' resTy + pure $ TypedValue' True valFn''' resTy' + _ -> + throwError $ errorMessage $ CannotApplyExpressionOfTypeOnType valTy tyArg infer' (Var ss var) = do checkVisibility var ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable $ var @@ -728,7 +766,7 @@ check' => Expr -> SourceType -> m TypedValue' -check' val (ForAll ann ident mbK ty _) = do +check' val (ForAll ann vis ident mbK ty _) = do env <- getEnv mn <- gets checkCurrentModule scope <- newSkolemScope @@ -746,7 +784,7 @@ check' val (ForAll ann ident mbK ty _) = do skolemizeTypesInValue ss ident mbK sko scope val | otherwise = val val' <- tvToExpr <$> check skVal sk - return $ TypedValue' True val' (ForAll ann ident mbK ty (Just scope)) + return $ TypedValue' True val' (ForAll ann vis ident mbK ty (Just scope)) check' val t@(ConstrainedType _ con@(Constraint _ cls@(Qualified _ (ProperName className)) _ _ _) ty) = do TypeClassData{ typeClassIsEmpty } <- lookupTypeClass cls -- An empty class dictionary is never used; see code in `TypeChecker.Entailment` @@ -950,7 +988,7 @@ checkFunctionApplication' fn (TypeApp _ (TypeApp _ tyFunction' argTy) retTy) arg unifyTypes tyFunction' tyFunction arg' <- tvToExpr <$> check arg argTy return (retTy, App fn arg') -checkFunctionApplication' fn (ForAll _ ident mbK ty _) arg = do +checkFunctionApplication' fn (ForAll _ _ ident mbK ty _) arg = do u <- maybe (internalCompilerError "Unelaborated forall") freshTypeWithKind mbK insertUnkName' u ident let replaced = replaceTypeVars ident u ty diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index b58c8d78a7..e4f1040ebf 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -114,7 +114,7 @@ unifyTypes t1 t2 = do unifyTypes' (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = return () unifyTypes' (TUnknown _ u) t = solveType u t unifyTypes' t (TUnknown _ u) = solveType u t - unifyTypes' (ForAll ann1 ident1 mbK1 ty1 sc1) (ForAll ann2 ident2 mbK2 ty2 sc2) = + unifyTypes' (ForAll ann1 _ ident1 mbK1 ty1 sc1) (ForAll ann2 _ ident2 mbK2 ty2 sc2) = case (sc1, sc2) of (Just sc1', Just sc2') -> do sko <- newSkolemConstant @@ -122,7 +122,7 @@ unifyTypes t1 t2 = do let sk2 = skolemize ann2 ident2 mbK2 sko sc2' ty2 sk1 `unifyTypes` sk2 _ -> internalError "unifyTypes: unspecified skolem scope" - unifyTypes' (ForAll ann ident mbK ty1 (Just sc)) ty2 = do + unifyTypes' (ForAll ann _ ident mbK ty1 (Just sc)) ty2 = do sko <- newSkolemConstant let sk = skolemize ann ident mbK sko sc ty1 sk `unifyTypes` ty2 diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 6e7552521f..ad5e207882 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -53,6 +53,19 @@ data WildcardData = HoleWildcard Text | UnnamedWildcard | IgnoredWildcard instance NFData WildcardData instance Serialise WildcardData +data TypeVarVisibility + = TypeVarVisible + | TypeVarInvisible + deriving (Show, Eq, Ord, Generic) + +instance NFData TypeVarVisibility +instance Serialise TypeVarVisibility + +typeVarVisibilityPrefix :: TypeVarVisibility -> Text +typeVarVisibilityPrefix = \case + TypeVarVisible -> "@" + TypeVarInvisible -> mempty + -- | -- The type of types -- @@ -77,7 +90,7 @@ data Type a -- | Explicit kind application | KindApp a (Type a) (Type a) -- | Forall quantifier - | ForAll a Text (Maybe (Type a)) (Type a) (Maybe SkolemScope) + | ForAll a TypeVarVisibility Text (Maybe (Type a)) (Type a) (Maybe SkolemScope) -- | A type with a set of type class constraints | ConstrainedType a (Constraint a) (Type a) -- | A skolem constant @@ -126,7 +139,7 @@ srcTypeApp = TypeApp NullSourceAnn srcKindApp :: SourceType -> SourceType -> SourceType srcKindApp = KindApp NullSourceAnn -srcForAll :: Text -> Maybe SourceType -> SourceType -> Maybe SkolemScope -> SourceType +srcForAll :: TypeVarVisibility -> Text -> Maybe SourceType -> SourceType -> Maybe SkolemScope -> SourceType srcForAll = ForAll NullSourceAnn srcConstrainedType :: SourceConstraint -> SourceType -> SourceType @@ -219,6 +232,11 @@ constraintToJSON annToJSON Constraint {..} = , "constraintData" .= fmap constraintDataToJSON constraintData ] +typeVarVisToJSON :: TypeVarVisibility -> A.Value +typeVarVisToJSON = \case + TypeVarVisible -> A.toJSON ("TypeVarVisible" :: Text) + TypeVarInvisible -> A.toJSON ("TypeVarInvisible" :: Text) + typeToJSON :: forall a. (a -> A.Value) -> Type a -> A.Value typeToJSON annToJSON ty = case ty of @@ -240,10 +258,14 @@ typeToJSON annToJSON ty = variant "TypeApp" a (go b, go c) KindApp a b c -> variant "KindApp" a (go b, go c) - ForAll a b c d e -> - case c of - Nothing -> variant "ForAll" a (b, go d, e) - Just k -> variant "ForAll" a (b, go k, go d, e) + ForAll a b c d e f -> + variant "ForAll" a $ A.object + [ "visibility" .= b + , "identifier" .= c + , "kind" .= fmap go d + , "type" .= go e + , "skolem" .= f + ] ConstrainedType a b c -> variant "ConstrainedType" a (constraintToJSON annToJSON b, go c) Skolem a b c d e -> @@ -292,6 +314,9 @@ instance A.ToJSON a => A.ToJSON (Constraint a) where instance A.ToJSON ConstraintData where toJSON = constraintDataToJSON +instance A.ToJSON TypeVarVisibility where + toJSON = typeVarVisToJSON + constraintDataFromJSON :: A.Value -> A.Parser ConstraintData constraintDataFromJSON = A.withObject "PartialConstraintData" $ \o -> do (bs, trunc) <- o .: "contents" @@ -306,6 +331,14 @@ constraintFromJSON defaultAnn annFromJSON = A.withObject "Constraint" $ \o -> do constraintData <- o .: "constraintData" >>= traverse constraintDataFromJSON pure $ Constraint {..} +typeVarVisFromJSON :: A.Value -> A.Parser TypeVarVisibility +typeVarVisFromJSON v = do + v' <- A.parseJSON v + case v' of + "TypeVarVisible" -> pure TypeVarVisible + "TypeVarInvisible" -> pure TypeVarInvisible + _ -> fail $ "Unrecognized TypeVarVisibility: " <> v' + typeFromJSON :: forall a. A.Parser a -> (A.Value -> A.Parser a) -> A.Value -> A.Parser (Type a) typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do tag <- o .: "tag" @@ -337,13 +370,23 @@ typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do KindApp a <$> go b <*> go c "ForAll" -> do let + asObject = do + f <- contents + v <- f .: "visibility" + i <- f .: "identifier" + k <- f .:? "kind" + t <- f .: "type" + s <- f .: "skolem" + ForAll a v i <$> traverse go k <*> go t <*> pure s + withoutMbKind = do (b, c, d) <- contents - ForAll a b Nothing <$> go c <*> pure d + ForAll a TypeVarInvisible b Nothing <$> go c <*> pure d + withMbKind = do (b, c, d, e) <- contents - ForAll a b <$> (Just <$> go c) <*> go d <*> pure e - withMbKind <|> withoutMbKind + ForAll a TypeVarInvisible b <$> (Just <$> go c) <*> go d <*> pure e + asObject <|> withMbKind <|> withoutMbKind "ConstrainedType" -> do (b, c) <- contents ConstrainedType a <$> constraintFromJSON defaultAnn annFromJSON b <*> go c @@ -411,6 +454,9 @@ instance A.FromJSON WildcardData where A.Null -> pure UnnamedWildcard _ -> fail "Unrecognized WildcardData" +instance A.FromJSON TypeVarVisibility where + parseJSON = typeVarVisFromJSON + data RowListItem a = RowListItem { rowListAnn :: a , rowListLabel :: Label @@ -468,7 +514,7 @@ isMonoType _ = True -- | Universally quantify a type mkForAll :: [(a, (Text, Maybe (Type a)))] -> Type a -> Type a -mkForAll args ty = foldr (\(ann, (arg, mbK)) t -> ForAll ann arg mbK t Nothing) ty args +mkForAll args ty = foldr (\(ann, (arg, mbK)) t -> ForAll ann TypeVarInvisible arg mbK t Nothing) ty args -- | Replace a type variable, taking into account variable shadowing replaceTypeVars :: Text -> Type a -> Type a -> Type a @@ -481,13 +527,13 @@ replaceAllTypeVars = go [] where go _ m (TypeVar ann v) = fromMaybe (TypeVar ann v) (v `lookup` m) go bs m (TypeApp ann t1 t2) = TypeApp ann (go bs m t1) (go bs m t2) go bs m (KindApp ann t1 t2) = KindApp ann (go bs m t1) (go bs m t2) - go bs m (ForAll ann v mbK t sco) - | v `elem` keys = go bs (filter ((/= v) . fst) m) $ ForAll ann v mbK' t sco + go bs m (ForAll ann vis v mbK t sco) + | v `elem` keys = go bs (filter ((/= v) . fst) m) $ ForAll ann vis v mbK' t sco | v `elem` usedVars = let v' = genName v (keys ++ bs ++ usedVars) t' = go bs [(v, TypeVar ann v')] t - in ForAll ann v' mbK' (go (v' : bs) m t') sco - | otherwise = ForAll ann v mbK' (go (v : bs) m t) sco + in ForAll ann vis v' mbK' (go (v' : bs) m t') sco + | otherwise = ForAll ann vis v mbK' (go (v : bs) m t) sco where mbK' = go bs m <$> mbK keys = map fst m @@ -504,6 +550,17 @@ replaceAllTypeVars = go [] where try' n | (orig <> T.pack (show n)) `elem` inUse = try' (n + 1) | otherwise = orig <> T.pack (show n) +-- | Add visible type abstractions to top-level foralls. +addVisibility :: [(Text, TypeVarVisibility)] -> Type a -> Type a +addVisibility v = go where + go (ForAll ann vis arg mbK ty sco) = case lookup arg v of + Just vis' -> + ForAll ann vis' arg mbK (go ty) sco + Nothing -> + ForAll ann vis arg mbK (go ty) sco + go (ParensInType ann ty) = ParensInType ann (go ty) + go ty = ty + -- | Collect all type variables appearing in a type usedTypeVariables :: Type a -> [Text] usedTypeVariables = ordNub . everythingOnTypes (++) go where @@ -518,7 +575,7 @@ freeTypeVariables = ordNub . fmap snd . sortOn fst . go 0 [] where go lvl bound (TypeVar _ v) | v `notElem` bound = [(lvl, v)] go lvl bound (TypeApp _ t1 t2) = go lvl bound t1 ++ go lvl bound t2 go lvl bound (KindApp _ t1 t2) = go lvl bound t1 ++ go (lvl - 1) bound t2 - go lvl bound (ForAll _ v mbK t _) = foldMap (go (lvl - 1) bound) mbK ++ go lvl (v : bound) t + go lvl bound (ForAll _ _ v mbK t _) = foldMap (go (lvl - 1) bound) mbK ++ go lvl (v : bound) t go lvl bound (ConstrainedType _ c t) = foldMap (go (lvl - 1) bound) (constraintKindArgs c) ++ foldMap (go lvl bound) (constraintArgs c) ++ go lvl bound t go lvl bound (RCons _ _ t r) = go lvl bound t ++ go lvl bound r go lvl bound (KindedType _ t k) = go lvl bound t ++ go (lvl - 1) bound k @@ -531,20 +588,20 @@ completeBinderList :: Type a -> Maybe ([(a, (Text, Type a))], Type a) completeBinderList = go [] where go acc = \case - ForAll _ _ Nothing _ _ -> Nothing - ForAll ann var (Just k) ty _ -> go ((ann, (var, k)) : acc) ty + ForAll _ _ _ Nothing _ _ -> Nothing + ForAll ann _ var (Just k) ty _ -> go ((ann, (var, k)) : acc) ty ty -> Just (reverse acc, ty) -- | Universally quantify over all type variables appearing free in a type quantify :: Type a -> Type a -quantify ty = foldr (\arg t -> ForAll (getAnnForType ty) arg Nothing t Nothing) ty $ freeTypeVariables ty +quantify ty = foldr (\arg t -> ForAll (getAnnForType ty) TypeVarInvisible arg Nothing t Nothing) ty $ freeTypeVariables ty -- | Move all universal quantifiers to the front of a type moveQuantifiersToFront :: Type a -> Type a moveQuantifiersToFront = go [] [] where - go qs cs (ForAll ann q mbK ty sco) = go ((ann, q, sco, mbK) : qs) cs ty + go qs cs (ForAll ann vis q mbK ty sco) = go ((ann, q, sco, mbK, vis) : qs) cs ty go qs cs (ConstrainedType ann c ty) = go qs ((ann, c) : cs) ty - go qs cs ty = foldl (\ty' (ann, q, sco, mbK) -> ForAll ann q mbK ty' sco) (foldl (\ty' (ann, c) -> ConstrainedType ann c ty') ty cs) qs + go qs cs ty = foldl (\ty' (ann, q, sco, mbK, vis) -> ForAll ann vis q mbK ty' sco) (foldl (\ty' (ann, c) -> ConstrainedType ann c ty') ty cs) qs -- | Check if a type contains `forall` containsForAll :: Type a -> Bool @@ -580,12 +637,12 @@ eraseForAllKindAnnotations :: Type a -> Type a eraseForAllKindAnnotations = removeAmbiguousVars . removeForAllKinds where removeForAllKinds = everywhereOnTypes $ \case - ForAll ann arg _ ty sco -> - ForAll ann arg Nothing ty sco + ForAll ann vis arg _ ty sco -> + ForAll ann vis arg Nothing ty sco other -> other removeAmbiguousVars = everywhereOnTypes $ \case - fa@(ForAll _ arg _ ty _) + fa@(ForAll _ _ arg _ ty _) | arg `elem` freeTypeVariables ty -> fa | otherwise -> ty other -> other @@ -615,7 +672,7 @@ srcInstanceType -> SourceType srcInstanceType ss vars className tys = setAnnForType (ss, []) - . flip (foldr $ \(tv, k) ty -> srcForAll tv (Just k) ty Nothing) vars + . flip (foldr $ \(tv, k) ty -> srcForAll TypeVarInvisible tv (Just k) ty Nothing) vars . flip (foldl' srcTypeApp) tys $ srcTypeConstructor $ coerceProperName <$> className @@ -623,7 +680,7 @@ everywhereOnTypes :: (Type a -> Type a) -> Type a -> Type a everywhereOnTypes f = go where go (TypeApp ann t1 t2) = f (TypeApp ann (go t1) (go t2)) go (KindApp ann t1 t2) = f (KindApp ann (go t1) (go t2)) - go (ForAll ann arg mbK ty sco) = f (ForAll ann arg (go <$> mbK) (go ty) sco) + go (ForAll ann vis arg mbK ty sco) = f (ForAll ann vis arg (go <$> mbK) (go ty) sco) go (ConstrainedType ann c ty) = f (ConstrainedType ann (mapConstraintArgsAll (map go) c) (go ty)) go (Skolem ann name mbK i sc) = f (Skolem ann name (go <$> mbK) i sc) go (RCons ann name ty rest) = f (RCons ann name (go ty) (go rest)) @@ -636,7 +693,7 @@ everywhereOnTypesM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (Type a) everywhereOnTypesM f = go where go (TypeApp ann t1 t2) = (TypeApp ann <$> go t1 <*> go t2) >>= f go (KindApp ann t1 t2) = (KindApp ann <$> go t1 <*> go t2) >>= f - go (ForAll ann arg mbK ty sco) = (ForAll ann arg <$> traverse go mbK <*> go ty <*> pure sco) >>= f + go (ForAll ann vis arg mbK ty sco) = (ForAll ann vis arg <$> traverse go mbK <*> go ty <*> pure sco) >>= f go (ConstrainedType ann c ty) = (ConstrainedType ann <$> overConstraintArgsAll (mapM go) c <*> go ty) >>= f go (Skolem ann name mbK i sc) = (Skolem ann name <$> traverse go mbK <*> pure i <*> pure sc) >>= f go (RCons ann name ty rest) = (RCons ann name <$> go ty <*> go rest) >>= f @@ -649,7 +706,7 @@ everywhereOnTypesTopDownM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (T everywhereOnTypesTopDownM f = go <=< f where go (TypeApp ann t1 t2) = TypeApp ann <$> (f t1 >>= go) <*> (f t2 >>= go) go (KindApp ann t1 t2) = KindApp ann <$> (f t1 >>= go) <*> (f t2 >>= go) - go (ForAll ann arg mbK ty sco) = ForAll ann arg <$> traverse (f >=> go) mbK <*> (f ty >>= go) <*> pure sco + go (ForAll ann vis arg mbK ty sco) = ForAll ann vis arg <$> traverse (f >=> go) mbK <*> (f ty >>= go) <*> pure sco go (ConstrainedType ann c ty) = ConstrainedType ann <$> overConstraintArgsAll (mapM (go <=< f)) c <*> (f ty >>= go) go (Skolem ann name mbK i sc) = Skolem ann name <$> traverse (f >=> go) mbK <*> pure i <*> pure sc go (RCons ann name ty rest) = RCons ann name <$> (f ty >>= go) <*> (f rest >>= go) @@ -662,8 +719,8 @@ everythingOnTypes :: (r -> r -> r) -> (Type a -> r) -> Type a -> r everythingOnTypes (<+>) f = go where go t@(TypeApp _ t1 t2) = f t <+> go t1 <+> go t2 go t@(KindApp _ t1 t2) = f t <+> go t1 <+> go t2 - go t@(ForAll _ _ (Just k) ty _) = f t <+> go k <+> go ty - go t@(ForAll _ _ _ ty _) = f t <+> go ty + go t@(ForAll _ _ _ (Just k) ty _) = f t <+> go k <+> go ty + go t@(ForAll _ _ _ _ ty _) = f t <+> go ty go t@(ConstrainedType _ c ty) = foldl (<+>) (f t) (map go (constraintKindArgs c) ++ map go (constraintArgs c)) <+> go ty go t@(Skolem _ _ (Just k) _ _) = f t <+> go k go t@(RCons _ _ ty rest) = f t <+> go ty <+> go rest @@ -677,8 +734,8 @@ everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 where go' s t = let (s', r) = f s t in r <+> go s' t go s (TypeApp _ t1 t2) = go' s t1 <+> go' s t2 go s (KindApp _ t1 t2) = go' s t1 <+> go' s t2 - go s (ForAll _ _ (Just k) ty _) = go' s k <+> go' s ty - go s (ForAll _ _ _ ty _) = go' s ty + go s (ForAll _ _ _ (Just k) ty _) = go' s k <+> go' s ty + go s (ForAll _ _ _ _ ty _) = go' s ty go s (ConstrainedType _ c ty) = foldl (<+>) r0 (map (go' s) (constraintKindArgs c) ++ map (go' s) (constraintArgs c)) <+> go' s ty go s (Skolem _ _ (Just k) _ _) = go' s k go s (RCons _ _ ty rest) = go' s ty <+> go' s rest @@ -697,7 +754,7 @@ annForType k (TypeConstructor a b) = (\z -> TypeConstructor z b) <$> k a annForType k (TypeOp a b) = (\z -> TypeOp z b) <$> k a annForType k (TypeApp a b c) = (\z -> TypeApp z b c) <$> k a annForType k (KindApp a b c) = (\z -> KindApp z b c) <$> k a -annForType k (ForAll a b c d e) = (\z -> ForAll z b c d e) <$> k a +annForType k (ForAll a b c d e f) = (\z -> ForAll z b c d e f) <$> k a annForType k (ConstrainedType a b c) = (\z -> ConstrainedType z b c) <$> k a annForType k (Skolem a b c d e) = (\z -> Skolem z b c d e) <$> k a annForType k (REmpty a) = REmpty <$> k a @@ -728,7 +785,7 @@ eqType (TypeConstructor _ a) (TypeConstructor _ a') = a == a' eqType (TypeOp _ a) (TypeOp _ a') = a == a' eqType (TypeApp _ a b) (TypeApp _ a' b') = eqType a a' && eqType b b' eqType (KindApp _ a b) (KindApp _ a' b') = eqType a a' && eqType b b' -eqType (ForAll _ a b c d) (ForAll _ a' b' c' d') = a == a' && eqMaybeType b b' && eqType c c' && d == d' +eqType (ForAll _ _ a b c d) (ForAll _ _ a' b' c' d') = a == a' && eqMaybeType b b' && eqType c c' && d == d' eqType (ConstrainedType _ a b) (ConstrainedType _ a' b') = eqConstraint a a' && eqType b b' eqType (Skolem _ a b c d) (Skolem _ a' b' c' d') = a == a' && eqMaybeType b b' && c == c' && d == d' eqType (REmpty _) (REmpty _) = True @@ -753,7 +810,7 @@ compareType (TypeConstructor _ a) (TypeConstructor _ a') = compare a a' compareType (TypeOp _ a) (TypeOp _ a') = compare a a' compareType (TypeApp _ a b) (TypeApp _ a' b') = compareType a a' <> compareType b b' compareType (KindApp _ a b) (KindApp _ a' b') = compareType a a' <> compareType b b' -compareType (ForAll _ a b c d) (ForAll _ a' b' c' d') = compare a a' <> compareMaybeType b b' <> compareType c c' <> compare d d' +compareType (ForAll _ _ a b c d) (ForAll _ _ a' b' c' d') = compare a a' <> compareMaybeType b b' <> compareType c c' <> compare d d' compareType (ConstrainedType _ a b) (ConstrainedType _ a' b') = compareConstraint a a' <> compareType b b' compareType (Skolem _ a b c d) (Skolem _ a' b' c' d') = compare a a' <> compareMaybeType b b' <> compare c c' <> compare d d' compareType (REmpty _) (REmpty _) = EQ diff --git a/tests/TestAst.hs b/tests/TestAst.hs index 88801e14f9..bb2e880443 100644 --- a/tests/TestAst.hs +++ b/tests/TestAst.hs @@ -12,7 +12,7 @@ import Test.QuickCheck (Arbitrary(..), Gen, Property, Testable, counterexample, import Language.PureScript.Label (Label(..)) import Language.PureScript.Names (pattern ByNullSourcePos, OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified(..)) import Language.PureScript.PSString (PSString) -import Language.PureScript.Types (Constraint, ConstraintData, SkolemScope(..), Type(..), WildcardData, annForType, everythingOnTypes, everythingWithContextOnTypes, everywhereOnTypes, everywhereOnTypesM, everywhereOnTypesTopDownM, getAnnForType) +import Language.PureScript.Types (Constraint, ConstraintData, SkolemScope(..), Type(..), TypeVarVisibility(..), WildcardData, annForType, everythingOnTypes, everythingWithContextOnTypes, everywhereOnTypes, everywhereOnTypesM, everywhereOnTypesTopDownM, getAnnForType) spec :: Spec spec = do @@ -65,6 +65,7 @@ genTypeAnnotatedWith genTypeAnn genConstraintAnn = genType where :+ listOf' genType :+ maybeOf genType :+ genWildcardData + :+ genVisibility genConstraint :: Gen (Constraint a) genConstraint = genericArbitraryUG (genConstraintAnn :+ generatorEnvironment) @@ -92,3 +93,6 @@ genTypeAnnotatedWith genTypeAnn genConstraintAnn = genType where genPSString :: Gen PSString genPSString = pure "x" -- Ditto. + + genVisibility :: Gen TypeVarVisibility + genVisibility = pure TypeVarInvisible diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index cb9f67066a..d2b805ff0e 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -647,7 +647,7 @@ checkConstrained ty tyClass = P.ConstrainedType _ c ty' | matches tyClass c -> True | otherwise -> checkConstrained ty' tyClass - P.ForAll _ _ _ ty' _ -> + P.ForAll _ _ _ _ ty' _ -> checkConstrained ty' tyClass _ -> False diff --git a/tests/purs/failing/3329.out b/tests/purs/failing/3329.out index ce9bbe6c77..d176c58889 100644 --- a/tests/purs/failing/3329.out +++ b/tests/purs/failing/3329.out @@ -12,7 +12,7 @@ at tests/purs/failing/3329.purs:24:8 - 24:11 (line 24, column 8 - line 24, colum Main.injectLeft -while checking that type forall (f :: Type) (g :: Type). Inject f g => f -> g +while checking that type forall (@f :: Type) (@g :: Type). Inject f g => f -> g is at least as general as type g0 -> Either f1 g0 while checking that expression inj has type g0 -> Either f1 g0 diff --git a/tests/purs/failing/ConstraintFailure.out b/tests/purs/failing/ConstraintFailure.out index 17d2c94bad..f6207999b7 100644 --- a/tests/purs/failing/ConstraintFailure.out +++ b/tests/purs/failing/ConstraintFailure.out @@ -7,7 +7,7 @@ at tests/purs/failing/ConstraintFailure.purs:12:8 - 12:12 (line 12, column 8 - l  Data.Show.Show Foo   -while checking that type forall (a :: Type). Show a => a -> String +while checking that type forall (@a :: Type). Show a => a -> String is at least as general as type t0 t1 t2 while checking that expression show has type t0 t1 t2 diff --git a/tests/purs/failing/TypedHole.out b/tests/purs/failing/TypedHole.out index 9153ca38fc..8cc1bcb38b 100644 --- a/tests/purs/failing/TypedHole.out +++ b/tests/purs/failing/TypedHole.out @@ -8,7 +8,7 @@ at tests/purs/failing/TypedHole.purs:8:8 - 8:13 (line 8, column 8 - line 8, colu   You could substitute the hole with one of these values:   -  Data.Monoid.mempty :: forall m. Monoid m => m  +  Data.Monoid.mempty :: forall @m. Monoid m => m   Effect.Class.Console.clear :: forall m. MonadEffect m => m Unit  Effect.Console.clear :: Effect Unit   Main.main :: Effect Unit  diff --git a/tests/purs/failing/TypedHole3.out b/tests/purs/failing/TypedHole3.out index db08ba593b..02677b82b9 100644 --- a/tests/purs/failing/TypedHole3.out +++ b/tests/purs/failing/TypedHole3.out @@ -8,21 +8,21 @@ at tests/purs/failing/TypedHole3.purs:4:10 - 4:15 (line 4, column 10 - line 4, c   You could substitute the hole with one of these values:   -  Control.Alt.alt :: forall f a. Alt f => f a -> f a -> f a  +  Control.Alt.alt :: forall @f a. Alt f => f a -> f a -> f a   Control.Alternative.guard :: forall m. Alternative m => Boolean -> m Unit   Control.Applicative.liftA1 :: forall f a b. Applicative f => (a -> b) -> f a -> f b  -  Control.Applicative.pure :: forall f a. Applicative f => a -> f a  +  Control.Applicative.pure :: forall @f a. Applicative f => a -> f a   Control.Applicative.unless :: forall m. Applicative m => Boolean -> m Unit -> m Unit   Control.Applicative.when :: forall m. Applicative m => Boolean -> m Unit -> m Unit  -  Control.Apply.apply :: forall f a b. Apply f => f (a -> b) -> f a -> f b  +  Control.Apply.apply :: forall @f a b. Apply f => f (a -> b) -> f a -> f b   Control.Apply.applyFirst :: forall a b f. Apply f => f a -> f b -> f a   Control.Apply.applySecond :: forall a b f. Apply f => f a -> f b -> f b   Control.Apply.lift2 :: forall a b c f. Apply f => (a -> b -> c) -> f a -> ... -> ...   Control.Apply.lift3 :: forall a b c d f. Apply f => (a -> b -> ...) -> f a -> ... -> ...   Control.Apply.lift4 :: forall a b c d e f. Apply f => (a -> b -> ...) -> f a -> ... -> ...   Control.Apply.lift5 :: forall a b c d e f g. Apply f => (a -> b -> ...) -> f a -> ... -> ... -  Control.Biapplicative.bipure :: forall w a b. Biapplicative w => a -> b -> w a b  -  Control.Biapply.biapply :: forall w a b c d. Biapply w => w (a -> b) (c -> d) -> w a c -> w b d  +  Control.Biapplicative.bipure :: forall @w a b. Biapplicative w => a -> b -> w a b  +  Control.Biapply.biapply :: forall @w a b c d. Biapply w => w (a -> b) (c -> d) -> w a c -> w b d   in value declaration fn diff --git a/tests/purs/failing/VisibleTypeApplications1.out b/tests/purs/failing/VisibleTypeApplications1.out new file mode 100644 index 0000000000..db1974405c --- /dev/null +++ b/tests/purs/failing/VisibleTypeApplications1.out @@ -0,0 +1,20 @@ +Error found: +in module Main +at tests/purs/failing/VisibleTypeApplications1.purs:7:11 - 7:18 (line 7, column 11 - line 7, column 18) + + An expression of polymorphic type + with the invisible type variable a: +   +  forall a. a -> a +   + cannot be applied to: +   +  Int +   + +while inferring the type of id +in value declaration failOne + +See https://github.com/purescript/documentation/blob/master/errors/CannotApplyExpressionOfTypeOnType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/VisibleTypeApplications1.purs b/tests/purs/failing/VisibleTypeApplications1.purs new file mode 100644 index 0000000000..463750fdf3 --- /dev/null +++ b/tests/purs/failing/VisibleTypeApplications1.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith CannotApplyExpressionOfTypeOnType +module Main where + +id :: forall a. a -> a +id a = a + +failOne = id @Int diff --git a/tests/purs/failing/VisibleTypeApplications2.out b/tests/purs/failing/VisibleTypeApplications2.out new file mode 100644 index 0000000000..bb14c33dfd --- /dev/null +++ b/tests/purs/failing/VisibleTypeApplications2.out @@ -0,0 +1,19 @@ +Error found: +in module Main +at tests/purs/failing/VisibleTypeApplications2.purs:7:11 - 7:18 (line 7, column 11 - line 7, column 18) + + An expression of monomorphic type: +   +  Int -> Int +   + cannot be applied to: +   +  Int +   + +while inferring the type of id +in value declaration failTwo + +See https://github.com/purescript/documentation/blob/master/errors/CannotApplyExpressionOfTypeOnType.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/VisibleTypeApplications2.purs b/tests/purs/failing/VisibleTypeApplications2.purs new file mode 100644 index 0000000000..9cd202b221 --- /dev/null +++ b/tests/purs/failing/VisibleTypeApplications2.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith CannotApplyExpressionOfTypeOnType +module Main where + +id :: Int -> Int +id a = a + +failTwo = id @Int diff --git a/tests/purs/passing/VisibleTypeApplications.purs b/tests/purs/passing/VisibleTypeApplications.purs new file mode 100644 index 0000000000..ea555a386e --- /dev/null +++ b/tests/purs/passing/VisibleTypeApplications.purs @@ -0,0 +1,40 @@ +module Main where + +import Prelude +import Effect.Console (log) + +foreign import data Id :: forall (a :: Type). a -> a + +identityCheck :: forall (@f :: forall (a :: Type). a -> a). Int +identityCheck = 0 + +identityPass :: Int +identityPass = identityCheck @Id + +foreign import data Const :: forall a b. a -> b -> a + +constCheck :: forall (a :: Type) (@f :: forall (b :: Type). b -> a). Int +constCheck = 0 + +constPass :: Int +constPass = constCheck @(Const Int) + +-- Type variables in class heads and data declarations are always visible. + +class ConstClass a where + constClass :: forall @b. a -> b -> a + +instance ConstClass a where + constClass a _ = a + +constClassInt = constClass @Int @Number + +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +treeInt :: Int -> Tree Int +treeInt = Leaf @Int + +treeInt' :: Tree Int -> Tree Int -> Tree Int +treeInt' = Branch @Int + +main = log "Done" diff --git a/tests/purs/warning/4376.out b/tests/purs/warning/4376.out index a7107df7e1..31006de8a6 100644 --- a/tests/purs/warning/4376.out +++ b/tests/purs/warning/4376.out @@ -5,9 +5,9 @@ at tests/purs/warning/4376.purs:6:1 - 6:16 (line 6, column 1 - line 6, column 16 No type declaration was provided for the top-level declaration of value. It is good practice to provide type declarations as a form of documentation. The inferred type of value was: -   -  forall a. Maybe a -   +   +  forall @a. Maybe a +   in value declaration value From 1e4e0f248cb0f16b15f72892d585974f662a7f4d Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Thu, 1 Jun 2023 20:58:59 +0800 Subject: [PATCH 1546/1580] Add CHANGELOG.d entry for visible type applications (#4476) --- .../feature_visible_type_applications.md | 113 ++++++++++++++++++ 1 file changed, 113 insertions(+) create mode 100644 CHANGELOG.d/feature_visible_type_applications.md diff --git a/CHANGELOG.d/feature_visible_type_applications.md b/CHANGELOG.d/feature_visible_type_applications.md new file mode 100644 index 0000000000..5013b4fea1 --- /dev/null +++ b/CHANGELOG.d/feature_visible_type_applications.md @@ -0,0 +1,113 @@ +* Implement visible type applications + + The compiler now supports visible type applications, allowing the user to instantiate one or more "visible" type variables to a specific type. + + A "visible" type variable is a type variable in a `forall` binder that appears prefixed with an `@`, like the following example: + + ```purescript + id :: forall @a. a -> a -- or with kinds: `forall (@a :: Type). a -> a` + id a = a + ``` + + We can then use type application syntax to instantiate this binding to a specific type: + + ```purescript + idInt :: Int -> Int + idInt = id @Int + + example :: Int + example = id @Int 0 + ``` + + Type variables appearing in `class` or `data` are automatically visible, meaning that they do not require annotations: + + ```purescript + data Maybe a = Just a | Nothing + + nothingInt :: Maybe Int + nothingInt = Nothing @Int + + class Identity a where + identity :: a -> a + + instance Identity Int where + identity a = a + + identityInt = identity @Int + + -- This throws a `NoInstanceFound` error. + identityNumber = identity @Number + ``` + + Lastly, visible type variables can also be skipped with a wildcard (i.e. `_`) + + ```purescript + data Either a b = Left a | Right b + + example = Left @_ @Number 0 + ``` + + Note that performing a type application with a type that has no visible type variables throws an error: + + ```purescript + module Main where + + id :: forall a. a -> a + id a = a + + idInt = id @Int + + {- + Error found: + in module Main + at Main.purs:6:9 - 6:16 (line 6, column 9 - line 6, column 16) + + An expression of polymorphic type + with the invisible type variable a: + + forall a. a -> a + + cannot be applied to: + + Int + + + while inferring the type of id + in value declaration idInt + + See https://github.com/purescript/documentation/blob/master/errors/CannotApplyExpressionOfTypeOnType.md for more information, + or to contribute content related to this error. + -} + ``` + + Similarly, monomorphic types also cannot be used for type applications: + + ```purescript + module Main where + + idInt :: Int -> Int + idInt a = a + + example = idInt @Int + + {- + Error found: + in module Main + at Main.purs:6:11 - 6:21 (line 6, column 11 - line 6, column 21) + + An expression of monomorphic type: + + Int -> Int + + cannot be applied to: + + Int + + + while inferring the type of idInt + in value declaration example + + See https://github.com/purescript/documentation/blob/master/errors/CannotApplyExpressionOfTypeOnType.md for more information, + or to contribute content related to this error. + -} + ``` From a6f6dcc05bd535937f680d48950220acbb10b5ff Mon Sep 17 00:00:00 2001 From: Mark Eibes Date: Mon, 3 Jul 2023 12:43:32 +0200 Subject: [PATCH 1547/1580] Add option to exclude globs from given input (#4480) --- ...eature_exclude_files_from_compile_input.md | 45 +++++++++++++++++++ app/Command/Compile.hs | 14 +++++- 2 files changed, 57 insertions(+), 2 deletions(-) create mode 100644 CHANGELOG.d/feature_exclude_files_from_compile_input.md diff --git a/CHANGELOG.d/feature_exclude_files_from_compile_input.md b/CHANGELOG.d/feature_exclude_files_from_compile_input.md new file mode 100644 index 0000000000..357596f96f --- /dev/null +++ b/CHANGELOG.d/feature_exclude_files_from_compile_input.md @@ -0,0 +1,45 @@ +* Exclude files from compiler input + + The compiler now supports excluding files from the globs given to it as input. + This means there's now a new option for `purs compile`, namely + `--exclude-files` (or the short version `-x`): + +```sh +> purs compile --help +Usage: purs compile [FILE] [-x|--exclude-files ARG] [-o|--output ARG] ... + + Compile PureScript source files + +Available options: + -h,--help Show this help text + FILE The input .purs file(s). + -x,--exclude-files ARG Glob of .purs files to exclude from the supplied + files. + ... +``` + +This allows you to keep related files closer together (that is, [colocate](https://kentcdodds.com/blog/colocation) them). + +Consider a setup like the following: + +```sh +src/ + Main.purs + View/ + LoginPage.purs + LoginPageTest.purs + LoginPageStories.purs +``` + +In order to exclude the files in the example above you can now invoke `purs` +like this and it will only compile `LoginPage.purs`: + +```sh +purs compile "src/**/*.purs" --exclude-files "src/**/*Stories.purs" -x "src/**/*Test.purs" +``` + +With `spago`, the equivalent command is: + +```sh +spago build --purs-args '-x "src/**/*Test.purs" -x "src/**/*Stories.purs"' +``` diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 27fbb39d01..8f348da9dd 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -7,7 +7,7 @@ import Control.Monad (when) import Data.Aeson qualified as A import Data.Bool (bool) import Data.ByteString.Lazy.UTF8 qualified as LBU8 -import Data.List (intercalate) +import Data.List (intercalate, (\\)) import Data.Map qualified as M import Data.Set qualified as S import Data.Text qualified as T @@ -26,6 +26,7 @@ import System.IO.UTF8 (readUTF8FilesT) data PSCMakeOptions = PSCMakeOptions { pscmInput :: [FilePath] + , pscmExclude :: [FilePath] , pscmOutputDir :: FilePath , pscmOpts :: P.Options , pscmUsePrefix :: Bool @@ -53,7 +54,9 @@ printWarningsAndErrors verbose True files warnings errors = do compile :: PSCMakeOptions -> IO () compile PSCMakeOptions{..} = do - input <- globWarningOnMisses warnFileTypeNotFound pscmInput + included <- globWarningOnMisses warnFileTypeNotFound pscmInput + excluded <- globWarningOnMisses warnFileTypeNotFound pscmExclude + let input = included \\ excluded when (null input) $ do hPutStr stderr $ unlines [ "purs compile: No input files." , "Usage: For basic information, try the `--help' option." @@ -86,6 +89,12 @@ inputFile = Opts.strArgument $ Opts.metavar "FILE" <> Opts.help "The input .purs file(s)." +excludedFiles :: Opts.Parser FilePath +excludedFiles = Opts.strOption $ + Opts.short 'x' + <> Opts.long "exclude-files" + <> Opts.help "Glob of .purs files to exclude from the supplied files." + outputDirectory :: Opts.Parser FilePath outputDirectory = Opts.strOption $ Opts.short 'o' @@ -153,6 +162,7 @@ options = pscMakeOptions :: Opts.Parser PSCMakeOptions pscMakeOptions = PSCMakeOptions <$> many inputFile + <*> many excludedFiles <*> outputDirectory <*> options <*> (not <$> noPrefix) From 193977ed819f6cc957a4c253e8a89e3784da0c5b Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 18 Jul 2023 16:11:16 -0500 Subject: [PATCH 1548/1580] Prep v0.15.10 release (#4484) * Update version to 0.15.10 * Update changelog --- ...eature_exclude_files_from_compile_input.md | 45 ----- .../feature_visible_type_applications.md | 113 ------------ CHANGELOG.md | 164 ++++++++++++++++++ npm-package/package.json | 4 +- purescript.cabal | 2 +- 5 files changed, 167 insertions(+), 161 deletions(-) delete mode 100644 CHANGELOG.d/feature_exclude_files_from_compile_input.md delete mode 100644 CHANGELOG.d/feature_visible_type_applications.md diff --git a/CHANGELOG.d/feature_exclude_files_from_compile_input.md b/CHANGELOG.d/feature_exclude_files_from_compile_input.md deleted file mode 100644 index 357596f96f..0000000000 --- a/CHANGELOG.d/feature_exclude_files_from_compile_input.md +++ /dev/null @@ -1,45 +0,0 @@ -* Exclude files from compiler input - - The compiler now supports excluding files from the globs given to it as input. - This means there's now a new option for `purs compile`, namely - `--exclude-files` (or the short version `-x`): - -```sh -> purs compile --help -Usage: purs compile [FILE] [-x|--exclude-files ARG] [-o|--output ARG] ... - - Compile PureScript source files - -Available options: - -h,--help Show this help text - FILE The input .purs file(s). - -x,--exclude-files ARG Glob of .purs files to exclude from the supplied - files. - ... -``` - -This allows you to keep related files closer together (that is, [colocate](https://kentcdodds.com/blog/colocation) them). - -Consider a setup like the following: - -```sh -src/ - Main.purs - View/ - LoginPage.purs - LoginPageTest.purs - LoginPageStories.purs -``` - -In order to exclude the files in the example above you can now invoke `purs` -like this and it will only compile `LoginPage.purs`: - -```sh -purs compile "src/**/*.purs" --exclude-files "src/**/*Stories.purs" -x "src/**/*Test.purs" -``` - -With `spago`, the equivalent command is: - -```sh -spago build --purs-args '-x "src/**/*Test.purs" -x "src/**/*Stories.purs"' -``` diff --git a/CHANGELOG.d/feature_visible_type_applications.md b/CHANGELOG.d/feature_visible_type_applications.md deleted file mode 100644 index 5013b4fea1..0000000000 --- a/CHANGELOG.d/feature_visible_type_applications.md +++ /dev/null @@ -1,113 +0,0 @@ -* Implement visible type applications - - The compiler now supports visible type applications, allowing the user to instantiate one or more "visible" type variables to a specific type. - - A "visible" type variable is a type variable in a `forall` binder that appears prefixed with an `@`, like the following example: - - ```purescript - id :: forall @a. a -> a -- or with kinds: `forall (@a :: Type). a -> a` - id a = a - ``` - - We can then use type application syntax to instantiate this binding to a specific type: - - ```purescript - idInt :: Int -> Int - idInt = id @Int - - example :: Int - example = id @Int 0 - ``` - - Type variables appearing in `class` or `data` are automatically visible, meaning that they do not require annotations: - - ```purescript - data Maybe a = Just a | Nothing - - nothingInt :: Maybe Int - nothingInt = Nothing @Int - - class Identity a where - identity :: a -> a - - instance Identity Int where - identity a = a - - identityInt = identity @Int - - -- This throws a `NoInstanceFound` error. - identityNumber = identity @Number - ``` - - Lastly, visible type variables can also be skipped with a wildcard (i.e. `_`) - - ```purescript - data Either a b = Left a | Right b - - example = Left @_ @Number 0 - ``` - - Note that performing a type application with a type that has no visible type variables throws an error: - - ```purescript - module Main where - - id :: forall a. a -> a - id a = a - - idInt = id @Int - - {- - Error found: - in module Main - at Main.purs:6:9 - 6:16 (line 6, column 9 - line 6, column 16) - - An expression of polymorphic type - with the invisible type variable a: - - forall a. a -> a - - cannot be applied to: - - Int - - - while inferring the type of id - in value declaration idInt - - See https://github.com/purescript/documentation/blob/master/errors/CannotApplyExpressionOfTypeOnType.md for more information, - or to contribute content related to this error. - -} - ``` - - Similarly, monomorphic types also cannot be used for type applications: - - ```purescript - module Main where - - idInt :: Int -> Int - idInt a = a - - example = idInt @Int - - {- - Error found: - in module Main - at Main.purs:6:11 - 6:21 (line 6, column 11 - line 6, column 21) - - An expression of monomorphic type: - - Int -> Int - - cannot be applied to: - - Int - - - while inferring the type of idInt - in value declaration example - - See https://github.com/purescript/documentation/blob/master/errors/CannotApplyExpressionOfTypeOnType.md for more information, - or to contribute content related to this error. - -} - ``` diff --git a/CHANGELOG.md b/CHANGELOG.md index 00ad84751d..94592161bd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,170 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.10 + +New features: + +* Implement visible type applications + + The compiler now supports visible type applications, allowing the user to instantiate one or more "visible" type variables to a specific type. + + A "visible" type variable is a type variable in a `forall` binder that appears prefixed with an `@`, like the following example: + + ```purescript + id :: forall @a. a -> a -- or with kinds: `forall (@a :: Type). a -> a` + id a = a + ``` + + We can then use type application syntax to instantiate this binding to a specific type: + + ```purescript + idInt :: Int -> Int + idInt = id @Int + + example :: Int + example = id @Int 0 + ``` + + Type variables appearing in `class` or `data` are automatically visible, meaning that they do not require annotations: + + ```purescript + data Maybe a = Just a | Nothing + + nothingInt :: Maybe Int + nothingInt = Nothing @Int + + class Identity a where + identity :: a -> a + + instance Identity Int where + identity a = a + + identityInt = identity @Int + + -- This throws a `NoInstanceFound` error. + identityNumber = identity @Number + ``` + + Lastly, visible type variables can also be skipped with a wildcard (i.e. `_`) + + ```purescript + data Either a b = Left a | Right b + + example = Left @_ @Number 0 + ``` + + Note that performing a type application with a type that has no visible type variables throws an error: + + ```purescript + module Main where + + id :: forall a. a -> a + id a = a + + idInt = id @Int + + {- + Error found: + in module Main + at Main.purs:6:9 - 6:16 (line 6, column 9 - line 6, column 16) + + An expression of polymorphic type + with the invisible type variable a: + + forall a. a -> a + + cannot be applied to: + + Int + + + while inferring the type of id + in value declaration idInt + + See https://github.com/purescript/documentation/blob/master/errors/CannotApplyExpressionOfTypeOnType.md for more information, + or to contribute content related to this error. + -} + ``` + + Similarly, monomorphic types also cannot be used for type applications: + + ```purescript + module Main where + + idInt :: Int -> Int + idInt a = a + + example = idInt @Int + + {- + Error found: + in module Main + at Main.purs:6:11 - 6:21 (line 6, column 11 - line 6, column 21) + + An expression of monomorphic type: + + Int -> Int + + cannot be applied to: + + Int + + + while inferring the type of idInt + in value declaration example + + See https://github.com/purescript/documentation/blob/master/errors/CannotApplyExpressionOfTypeOnType.md for more information, + or to contribute content related to this error. + -} + ``` + +* Exclude files from compiler input (#4480 by @i-am-the-slime) + + The compiler now supports excluding files from the globs given to it as input. + This means there's now a new option for `purs compile`, namely + `--exclude-files` (or the short version `-x`): + + ```sh + > purs compile --help + Usage: purs compile [FILE] [-x|--exclude-files ARG] [-o|--output ARG] ... + + Compile PureScript source files + + Available options: + -h,--help Show this help text + FILE The input .purs file(s). + -x,--exclude-files ARG Glob of .purs files to exclude from the supplied + files. + ... + ``` + + This allows you to keep related files closer together (that is, [colocate](https://kentcdodds.com/blog/colocation) them). + + Consider a setup like the following: + + ```sh + src/ + Main.purs + View/ + LoginPage.purs + LoginPageTest.purs + LoginPageStories.purs + ``` + + In order to exclude the files in the example above you can now invoke `purs` + like this and it will only compile `LoginPage.purs`: + + ```sh + purs compile "src/**/*.purs" --exclude-files "src/**/*Stories.purs" -x "src/**/*Test.purs" + ``` + + With `spago`, the equivalent command is: + + ```sh + spago build --purs-args '-x "src/**/*Test.purs" -x "src/**/*Stories.purs"' + ``` + ## 0.15.9 New features: diff --git a/npm-package/package.json b/npm-package/package.json index 3f391d5f43..8159571081 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.9", + "version": "0.15.10", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.9", + "postinstall": "install-purescript --purs-ver=0.15.10", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index 383264482d..ec35ef3938 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.9 +version: 0.15.10 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From cf530188d726976f75885e57a9c9b78b008080ec Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 22 Jul 2023 10:27:34 -0400 Subject: [PATCH 1549/1580] Move the closed record update optimization (#4489) For consumers of CoreFn like alternate backends, the optimization of replacing a closed record update with an object literal has now been moved to the point of desugaring CoreFn into JS. The `ObjectUpdate` expression constructor now contains a `Maybe` field holding a list of record labels to be copied as-is, for backends that want to perform this optimization also. This optimization was the last use of the `Maybe SourceType` member of the `Ann` tuple, so it has been removed. CoreFn is now fully untyped in both its serialized and in-memory forms (previously it was partially typed in memory). --- CHANGELOG.d/feature_closed-record-update.md | 7 ++ src/Language/PureScript/CodeGen/JS.hs | 45 ++++++------ src/Language/PureScript/CoreFn/Ann.hs | 7 +- src/Language/PureScript/CoreFn/CSE.hs | 6 +- src/Language/PureScript/CoreFn/Desugar.hs | 77 ++++++++++++-------- src/Language/PureScript/CoreFn/Expr.hs | 24 +++--- src/Language/PureScript/CoreFn/FromJSON.hs | 5 +- src/Language/PureScript/CoreFn/Laziness.hs | 4 +- src/Language/PureScript/CoreFn/Optimizer.hs | 30 +------- src/Language/PureScript/CoreFn/ToJSON.hs | 10 ++- src/Language/PureScript/CoreFn/Traversals.hs | 4 +- src/Language/PureScript/Renamer.hs | 4 +- tests/TestCoreFn.hs | 11 +-- tests/purs/optimize/ObjectUpdate.out.js | 27 +++++++ tests/purs/optimize/ObjectUpdate.purs | 10 +++ 15 files changed, 153 insertions(+), 118 deletions(-) create mode 100644 CHANGELOG.d/feature_closed-record-update.md create mode 100644 tests/purs/optimize/ObjectUpdate.out.js create mode 100644 tests/purs/optimize/ObjectUpdate.purs diff --git a/CHANGELOG.d/feature_closed-record-update.md b/CHANGELOG.d/feature_closed-record-update.md new file mode 100644 index 0000000000..c3534373c6 --- /dev/null +++ b/CHANGELOG.d/feature_closed-record-update.md @@ -0,0 +1,7 @@ +* Move the closed record update optimization + + For consumers of CoreFn like alternate backends, the optimization of + replacing a closed record update with an object literal has now been moved to + the point of desugaring CoreFn into JS. The `ObjectUpdate` expression + constructor now contains a `Maybe` field holding a list of record labels to + be copied as-is, for backends that want to perform this optimization also. diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 14d3e66610..14d122a37d 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -240,7 +240,7 @@ moduleBindToJs mn = bindToJs where -- Generate code in the simplified JavaScript intermediate representation for a declaration bindToJs :: Bind Ann -> m [AST] - bindToJs (NonRec (_, _, _, Just IsTypeClassConstructor) _ _) = pure [] + bindToJs (NonRec (_, _, Just IsTypeClassConstructor) _ _) = pure [] -- Unlike other newtype constructors, type class constructors are only -- ever applied; it's not possible to use them as values. So it's safe to -- erase them. @@ -252,20 +252,20 @@ moduleBindToJs mn = bindToJs -- -- The main purpose of this function is to handle code generation for comments. nonRecToJS :: Ann -> Ident -> Expr Ann -> m AST - nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do + nonRecToJS a i e@(extractAnn -> (_, com, _)) | not (null com) = do withoutComment <- asks optionsNoComments if withoutComment then nonRecToJS a i (modifyAnn removeComments e) else AST.Comment (AST.SourceComments com) <$> nonRecToJS a i (modifyAnn removeComments e) - nonRecToJS (ss, _, _, _) ident val = do + nonRecToJS (ss, _, _) ident val = do js <- valueToJs val withPos ss $ AST.VariableIntroduction Nothing (identToJs ident) (Just (guessEffects val, js)) guessEffects :: Expr Ann -> AST.InitializerEffects guessEffects = \case - Var _ (Qualified (BySourcePos _) _) -> NoEffects - App (_, _, _, Just IsSyntheticApp) _ _ -> NoEffects - _ -> UnknownEffects + Var _ (Qualified (BySourcePos _) _) -> NoEffects + App (_, _, Just IsSyntheticApp) _ _ -> NoEffects + _ -> UnknownEffects withPos :: SourceSpan -> AST -> m AST withPos ss js = do @@ -282,22 +282,25 @@ moduleBindToJs mn = bindToJs -- Generate code in the simplified JavaScript intermediate representation for a value or expression. valueToJs :: Expr Ann -> m AST valueToJs e = - let (ss, _, _, _) = extractAnn e in + let (ss, _, _) = extractAnn e in withPos ss =<< valueToJs' e valueToJs' :: Expr Ann -> m AST - valueToJs' (Literal (pos, _, _, _) l) = + valueToJs' (Literal (pos, _, _) l) = rethrowWithPosition pos $ literalToValueJS pos l - valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) = + valueToJs' (Var (_, _, Just (IsConstructor _ [])) name) = return $ accessorString "value" $ qualifiedToJS id name - valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) = + valueToJs' (Var (_, _, Just (IsConstructor _ _)) name) = return $ accessorString "create" $ qualifiedToJS id name valueToJs' (Accessor _ prop val) = accessorString prop <$> valueToJs val - valueToJs' (ObjectUpdate _ o ps) = do + valueToJs' (ObjectUpdate (pos, _, _) o copy ps) = do obj <- valueToJs o sts <- mapM (sndM valueToJs) ps - extendObj obj sts + case copy of + Nothing -> extendObj obj sts + Just names -> pure $ AST.ObjectLiteral (Just pos) (map f names ++ sts) + where f name = (name, accessorString name obj) valueToJs' (Abs _ arg val) = do ret <- valueToJs val let jsArg = case arg of @@ -308,29 +311,29 @@ moduleBindToJs mn = bindToJs let (f, args) = unApp e [] args' <- mapM valueToJs args case f of - Var (_, _, _, Just IsNewtype) _ -> return (head args') - Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields -> + Var (_, _, Just IsNewtype) _ -> return (head args') + Var (_, _, Just (IsConstructor _ fields)) name | length args == length fields -> return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args' _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToJs f where unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann]) unApp (App _ val arg) args = unApp val (arg : args) unApp other args = (other, args) - valueToJs' (Var (_, _, _, Just IsForeign) qi@(Qualified (ByModuleName mn') ident)) = + valueToJs' (Var (_, _, Just IsForeign) qi@(Qualified (ByModuleName mn') ident)) = return $ if mn' == mn then foreignIdent ident else varToJs qi - valueToJs' (Var (_, _, _, Just IsForeign) ident) = + valueToJs' (Var (_, _, Just IsForeign) ident) = internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident) valueToJs' (Var _ ident) = return $ varToJs ident - valueToJs' (Case (ss, _, _, _) values binders) = do + valueToJs' (Case (ss, _, _) values binders) = do vals <- mapM valueToJs values bindersToJs ss binders vals valueToJs' (Let _ ds val) = do ds' <- concat <$> mapM bindToJs ds ret <- valueToJs val return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (ds' ++ [AST.Return Nothing ret]))) [] - valueToJs' (Constructor (_, _, _, Just IsNewtype) _ ctor _) = + valueToJs' (Constructor (_, _, Just IsNewtype) _ ctor _) = return $ AST.VariableIntroduction Nothing (properToJs ctor) (Just . (UnknownEffects, ) $ AST.ObjectLiteral Nothing [("create", AST.Function Nothing Nothing ["value"] @@ -442,7 +445,7 @@ moduleBindToJs mn = bindToJs binderToJs :: Text -> [AST] -> Binder Ann -> m [AST] binderToJs s done binder = - let (ss, _, _, _) = extractBinderAnn binder in + let (ss, _, _) = extractBinderAnn binder in traverse (withPos ss) =<< binderToJs' s done binder -- Generate code in the simplified JavaScript intermediate representation for a pattern match @@ -453,9 +456,9 @@ moduleBindToJs mn = bindToJs literalToBinderJS varName done l binderToJs' varName done (VarBinder _ ident) = return (AST.VariableIntroduction Nothing (identToJs ident) (Just (NoEffects, AST.Var Nothing varName)) : done) - binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) = + binderToJs' varName done (ConstructorBinder (_, _, Just IsNewtype) _ _ [b]) = binderToJs varName done b - binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do + binderToJs' varName done (ConstructorBinder (_, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do js <- go (zip fields bs) done return $ case ctorType of ProductType -> js diff --git a/src/Language/PureScript/CoreFn/Ann.hs b/src/Language/PureScript/CoreFn/Ann.hs index 851f0da376..185f8beb5b 100644 --- a/src/Language/PureScript/CoreFn/Ann.hs +++ b/src/Language/PureScript/CoreFn/Ann.hs @@ -5,21 +5,20 @@ import Prelude import Language.PureScript.AST.SourcePos (SourceSpan) import Language.PureScript.Comments (Comment) import Language.PureScript.CoreFn.Meta (Meta) -import Language.PureScript.Types (SourceType) -- | -- Type alias for basic annotations -- -type Ann = (SourceSpan, [Comment], Maybe SourceType, Maybe Meta) +type Ann = (SourceSpan, [Comment], Maybe Meta) -- | -- An annotation empty of metadata aside from a source span. -- ssAnn :: SourceSpan -> Ann -ssAnn ss = (ss, [], Nothing, Nothing) +ssAnn ss = (ss, [], Nothing) -- | -- Remove the comments from an annotation -- removeComments :: Ann -> Ann -removeComments (ss, _, ty, meta) = (ss, [], ty, meta) +removeComments (ss, _, meta) = (ss, [], meta) diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index 6b339f7911..576243c252 100644 --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -262,7 +262,7 @@ generateIdentFor d e = at d . non mempty . at e %%<~ \case _ -> "ref" nullAnn :: Ann -nullAnn = (nullSourceSpan, [], Nothing, Nothing) +nullAnn = (nullSourceSpan, [], Nothing) -- | -- Use a map to substitute local Vars in a list of Binds. @@ -386,8 +386,8 @@ optimizeCommonSubexpressions mn -- common subexpression elimination pass. shouldFloatExpr :: Expr Ann -> Bool shouldFloatExpr = \case - App (_, _, _, Just IsSyntheticApp) e _ -> isSimple e - _ -> False + App (_, _, Just IsSyntheticApp) e _ -> isSimple e + _ -> False isSimple :: Expr Ann -> Bool isSimple = \case diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 5b0f821be4..34bf08f1f3 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -22,8 +22,10 @@ import Language.PureScript.CoreFn.Meta (ConstructorType(..), Meta(..)) import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue) +import Language.PureScript.Label (Label(..)) import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual) -import Language.PureScript.Types (SourceType) +import Language.PureScript.PSString (PSString) +import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) import Language.PureScript.AST qualified as A import Language.PureScript.Constants.Prim qualified as C @@ -57,13 +59,13 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = dedupeImports = fmap swap . M.toList . M.fromListWith const . fmap swap ssA :: SourceSpan -> Ann - ssA ss = (ss, [], Nothing, Nothing) + ssA ss = (ss, [], Nothing) -- Desugars member declarations from AST to CoreFn representation. declToCoreFn :: A.Declaration -> [Bind Ann] declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [ctor]) = - [NonRec (ss, [], Nothing, declMeta) (properToIdent $ A.dataCtorName ctor) $ - Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ Qualified ByNullSourcePos (Ident "x"))] + [NonRec (ss, [], declMeta) (properToIdent $ A.dataCtorName ctor) $ + Abs (ss, com, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ Qualified ByNullSourcePos (Ident "x"))] where declMeta = isDictTypeName (A.dataCtorName ctor) `orEmpty` IsTypeClassConstructor declToCoreFn d@(A.DataDeclaration _ Newtype _ _ _) = @@ -73,7 +75,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = let ctor = A.dataCtorName ctorDecl (_, _, _, fields) = lookupConstructor env (Qualified (ByModuleName mn) ctor) - in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields + in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing) tyName ctor fields declToCoreFn (A.DataBindingGroupDeclaration ds) = concatMap declToCoreFn ds declToCoreFn (A.ValueDecl (ss, com) name _ _ [A.MkUnguarded e]) = @@ -84,18 +86,29 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = -- Desugars expressions from AST to CoreFn representation. exprToCoreFn :: SourceSpan -> [Comment] -> Maybe SourceType -> A.Expr -> Expr Ann - exprToCoreFn _ com ty (A.Literal ss lit) = - Literal (ss, com, ty, Nothing) (fmap (exprToCoreFn ss com Nothing) lit) - exprToCoreFn ss com ty (A.Accessor name v) = - Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) + exprToCoreFn _ com _ (A.Literal ss lit) = + Literal (ss, com, Nothing) (fmap (exprToCoreFn ss com Nothing) lit) + exprToCoreFn ss com _ (A.Accessor name v) = + Accessor (ss, com, Nothing) name (exprToCoreFn ss [] Nothing v) exprToCoreFn ss com ty (A.ObjectUpdate obj vs) = - ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ fmap (second (exprToCoreFn ss [] Nothing)) vs - exprToCoreFn ss com ty (A.Abs (A.VarBinder _ name) v) = - Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) + ObjectUpdate (ss, com, Nothing) (exprToCoreFn ss [] Nothing obj) (ty >>= unchangedRecordFields (fmap fst vs)) $ fmap (second (exprToCoreFn ss [] Nothing)) vs + where + -- Return the unchanged labels of a closed record, or Nothing for other types or open records. + unchangedRecordFields :: [PSString] -> Type a -> Maybe [PSString] + unchangedRecordFields updated (TypeApp _ (TypeConstructor _ C.Record) row) = + collect row + where + collect :: Type a -> Maybe [PSString] + collect (REmptyKinded _ _) = Just [] + collect (RCons _ (Label l) _ r) = (if l `elem` updated then id else (l :)) <$> collect r + collect _ = Nothing + unchangedRecordFields _ _ = Nothing + exprToCoreFn ss com _ (A.Abs (A.VarBinder _ name) v) = + Abs (ss, com, Nothing) name (exprToCoreFn ss [] Nothing v) exprToCoreFn _ _ _ (A.Abs _ _) = internalError "Abs with Binder argument was not desugared before exprToCoreFn mn" - exprToCoreFn ss com ty (A.App v1 v2) = - App (ss, com, ty, (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) v1' v2' + exprToCoreFn ss com _ (A.App v1 v2) = + App (ss, com, (isDictCtor v1 || isSynthetic v2) `orEmpty` IsSyntheticApp) v1' v2' where v1' = exprToCoreFn ss [] Nothing v1 v2' = exprToCoreFn ss [] Nothing v2 @@ -108,24 +121,24 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = A.Var NullSourceSpan _ -> True A.Unused{} -> True _ -> False - exprToCoreFn ss com ty (A.Unused _) = - Var (ss, com, ty, Nothing) C.I_undefined - exprToCoreFn _ com ty (A.Var ss ident) = - Var (ss, com, ty, getValueMeta ident) ident - exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) = - Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1] + exprToCoreFn ss com _ (A.Unused _) = + Var (ss, com, Nothing) C.I_undefined + exprToCoreFn _ com _ (A.Var ss ident) = + Var (ss, com, getValueMeta ident) ident + exprToCoreFn ss com _ (A.IfThenElse v1 v2 v3) = + Case (ss, com, Nothing) [exprToCoreFn ss [] Nothing v1] [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True] (Right $ exprToCoreFn ss [] Nothing v2) , CaseAlternative [NullBinder (ssAnn ss)] (Right $ exprToCoreFn ss [] Nothing v3) ] - exprToCoreFn _ com ty (A.Constructor ss name) = - Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name - exprToCoreFn ss com ty (A.Case vs alts) = - Case (ss, com, ty, Nothing) (fmap (exprToCoreFn ss [] Nothing) vs) (fmap (altToCoreFn ss) alts) + exprToCoreFn _ com _ (A.Constructor ss name) = + Var (ss, com, Just $ getConstructorMeta name) $ fmap properToIdent name + exprToCoreFn ss com _ (A.Case vs alts) = + Case (ss, com, Nothing) (fmap (exprToCoreFn ss [] Nothing) vs) (fmap (altToCoreFn ss) alts) exprToCoreFn ss com _ (A.TypedValue _ v ty) = exprToCoreFn ss com (Just ty) v - exprToCoreFn ss com ty (A.Let w ds v) = - Let (ss, com, ty, getLetMeta w) (concatMap declToCoreFn ds) (exprToCoreFn ss [] Nothing v) + exprToCoreFn ss com _ (A.Let w ds v) = + Let (ss, com, getLetMeta w) (concatMap declToCoreFn ds) (exprToCoreFn ss [] Nothing v) exprToCoreFn _ com ty (A.PositionedValue ss com1 v) = exprToCoreFn ss (com ++ com1) ty v exprToCoreFn _ _ _ e = @@ -150,16 +163,16 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = -- Desugars case binders from AST to CoreFn representation. binderToCoreFn :: SourceSpan -> [Comment] -> A.Binder -> Binder Ann binderToCoreFn _ com (A.LiteralBinder ss lit) = - LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit) + LiteralBinder (ss, com, Nothing) (fmap (binderToCoreFn ss com) lit) binderToCoreFn ss com A.NullBinder = - NullBinder (ss, com, Nothing, Nothing) + NullBinder (ss, com, Nothing) binderToCoreFn _ com (A.VarBinder ss name) = - VarBinder (ss, com, Nothing, Nothing) name + VarBinder (ss, com, Nothing) name binderToCoreFn _ com (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = let (_, tctor, _, _) = lookupConstructor env dctor - in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (fmap (binderToCoreFn ss []) bs) + in ConstructorBinder (ss, com, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (fmap (binderToCoreFn ss []) bs) binderToCoreFn _ com (A.NamedBinder ss name b) = - NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b) + NamedBinder (ss, com, Nothing) name (binderToCoreFn ss [] b) binderToCoreFn _ com (A.PositionedBinder ss com1 b) = binderToCoreFn ss (com ++ com1) b binderToCoreFn ss com (A.TypedBinder _ b) = @@ -232,7 +245,7 @@ findQualModules decls = -- | Desugars import declarations from AST to CoreFn representation. importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName) -importToCoreFn (A.ImportDeclaration (ss, com) name _ _) = Just ((ss, com, Nothing, Nothing), name) +importToCoreFn (A.ImportDeclaration (ss, com) name _ _) = Just ((ss, com, Nothing), name) importToCoreFn _ = Nothing -- | Desugars foreign declarations from AST to CoreFn representation. diff --git a/src/Language/PureScript/CoreFn/Expr.hs b/src/Language/PureScript/CoreFn/Expr.hs index aa8b13b942..20ab333011 100644 --- a/src/Language/PureScript/CoreFn/Expr.hs +++ b/src/Language/PureScript/CoreFn/Expr.hs @@ -29,9 +29,9 @@ data Expr a -- | Accessor a PSString (Expr a) -- | - -- Partial record update + -- Partial record update (original value, fields to copy (if known), fields to update) -- - | ObjectUpdate a (Expr a) [(PSString, Expr a)] + | ObjectUpdate a (Expr a) (Maybe [PSString]) [(PSString, Expr a)] -- | -- Function introduction -- @@ -99,7 +99,7 @@ extractAnn :: Expr a -> a extractAnn (Literal a _) = a extractAnn (Constructor a _ _ _) = a extractAnn (Accessor a _ _) = a -extractAnn (ObjectUpdate a _ _) = a +extractAnn (ObjectUpdate a _ _ _) = a extractAnn (Abs a _ _) = a extractAnn (App a _ _) = a extractAnn (Var a _) = a @@ -111,12 +111,12 @@ extractAnn (Let a _ _) = a -- Modify the annotation on a term -- modifyAnn :: (a -> a) -> Expr a -> Expr a -modifyAnn f (Literal a b) = Literal (f a) b -modifyAnn f (Constructor a b c d) = Constructor (f a) b c d -modifyAnn f (Accessor a b c) = Accessor (f a) b c -modifyAnn f (ObjectUpdate a b c) = ObjectUpdate (f a) b c -modifyAnn f (Abs a b c) = Abs (f a) b c -modifyAnn f (App a b c) = App (f a) b c -modifyAnn f (Var a b) = Var (f a) b -modifyAnn f (Case a b c) = Case (f a) b c -modifyAnn f (Let a b c) = Let (f a) b c +modifyAnn f (Literal a b) = Literal (f a) b +modifyAnn f (Constructor a b c d) = Constructor (f a) b c d +modifyAnn f (Accessor a b c) = Accessor (f a) b c +modifyAnn f (ObjectUpdate a b c d) = ObjectUpdate (f a) b c d +modifyAnn f (Abs a b c) = Abs (f a) b c +modifyAnn f (App a b c) = App (f a) b c +modifyAnn f (Var a b) = Var (f a) b +modifyAnn f (Case a b c) = Case (f a) b c +modifyAnn f (Let a b c) = Let (f a) b c diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 04b4eda425..d0426b6f8d 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -70,7 +70,7 @@ annFromJSON modulePath = withObject "Ann" annFromObj annFromObj o = do ss <- o .: "sourceSpan" >>= sourceSpanFromJSON modulePath mm <- o .: "meta" >>= metaFromJSON - return (ss, [], Nothing, mm) + return (ss, [], mm) sourceSpanFromJSON :: FilePath -> Value -> Parser SourceSpan sourceSpanFromJSON modulePath = withObject "SourceSpan" $ \o -> @@ -228,8 +228,9 @@ exprFromJSON modulePath = withObject "Expr" exprFromObj objectUpdateFromObj o = do ann <- o .: "annotation" >>= annFromJSON modulePath e <- o .: "expression" >>= exprFromJSON modulePath + copy <- o .: "copy" >>= parseJSON us <- o .: "updates" >>= recordFromJSON (exprFromJSON modulePath) - return $ ObjectUpdate ann e us + return $ ObjectUpdate ann e copy us absFromObj o = do ann <- o .: "annotation" >>= annFromJSON modulePath diff --git a/src/Language/PureScript/CoreFn/Laziness.hs b/src/Language/PureScript/CoreFn/Laziness.hs index 42197f88d2..9941fd41c5 100644 --- a/src/Language/PureScript/CoreFn/Laziness.hs +++ b/src/Language/PureScript/CoreFn/Laziness.hs @@ -142,7 +142,7 @@ onVarsWithDelayAndForce f = snd . go 0 $ Just 0 handleApp len args = \case App a e1 e2 -> handleApp (len + 1) ((a, e2) : args) e1 - Var a@(_, _, _, Just meta) i | isConstructorLike meta + Var a@(_, _, Just meta) i | isConstructorLike meta -> foldl (\e1 (a2, e2) -> App a2 <$> e1 <*> handleExpr' e2) (f delay force a i) args e -> foldl (\e1 (a2, e2) -> App a2 <$> e1 <*> snd (go delay Nothing) e2) (snd (go delay (fmap (+ len) force)) e) args isConstructorLike = \case @@ -540,7 +540,7 @@ applyLazinessTransform mn rawItems = let _ -> internalError "Unexpected argument to lazifyIdent" makeForceCall :: Ann -> Ident -> Expr Ann - makeForceCall (ss, _, _, _) ident + makeForceCall (ss, _, _) ident -- We expect the functions produced by `runtimeLazy` to accept one -- argument: the line number on which this reference is made. The runtime -- code uses this number to generate a message that identifies where the diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs index 340815be32..722893c439 100644 --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -3,18 +3,12 @@ module Language.PureScript.CoreFn.Optimizer (optimizeCoreFn) where import Protolude hiding (Type, moduleName) import Control.Monad.Supply (Supply) -import Data.List (lookup) -import Language.PureScript.AST.Literals (Literal(..)) -import Language.PureScript.AST.SourcePos (nullSourceSpan) import Language.PureScript.CoreFn.Ann (Ann) import Language.PureScript.CoreFn.CSE (optimizeCommonSubexpressions) import Language.PureScript.CoreFn.Expr (Bind, Expr(..)) import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.CoreFn.Traversals (everywhereOnValues) -import Language.PureScript.Label (Label(..)) -import Language.PureScript.Types (pattern REmptyKinded, Type(..)) import Language.PureScript.Constants.Libs qualified as C -import Language.PureScript.Constants.Prim qualified as C -- | -- CoreFn optimization pass. @@ -27,29 +21,7 @@ optimizeModuleDecls = map transformBinds where (transformBinds, _, _) = everywhereOnValues identity transformExprs identity transformExprs - = optimizeClosedRecordUpdate - . optimizeDataFunctionApply - -optimizeClosedRecordUpdate :: Expr Ann -> Expr Ann -optimizeClosedRecordUpdate ou@(ObjectUpdate a@(_, _, Just t, _) r updatedFields) = - case closedRecordFields t of - Nothing -> ou - Just allFields -> Literal a (ObjectLiteral (map f allFields)) - where f (Label l) = case lookup l updatedFields of - Nothing -> (l, Accessor (nullSourceSpan, [], Nothing, Nothing) l r) - Just e -> (l, e) -optimizeClosedRecordUpdate e = e - --- | Return the labels of a closed record, or Nothing for other types or open records. -closedRecordFields :: Type a -> Maybe [Label] -closedRecordFields (TypeApp _ (TypeConstructor _ C.Record) row) = - collect row - where - collect :: Type a -> Maybe [Label] - collect (REmptyKinded _ _) = Just [] - collect (RCons _ l _ r) = (l :) <$> collect r - collect _ = Nothing -closedRecordFields _ = Nothing + = optimizeDataFunctionApply optimizeDataFunctionApply :: Expr a -> Expr a optimizeDataFunctionApply e = case e of diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index cae56cd016..1b20ac4e65 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -54,9 +54,9 @@ sourceSpanToJSON (SourceSpan _ spanStart spanEnd) = ] annToJSON :: Ann -> Value -annToJSON (ss, _, _, m) = object [ "sourceSpan" .= sourceSpanToJSON ss - , "meta" .= maybe Null metaToJSON m - ] +annToJSON (ss, _, m) = object [ "sourceSpan" .= sourceSpanToJSON ss + , "meta" .= maybe Null metaToJSON m + ] literalToJSON :: (a -> Value) -> Literal a -> Value literalToJSON _ (NumericLiteral (Left n)) @@ -181,9 +181,11 @@ exprToJSON (Accessor ann f r) = object [ "type" .= "Accessor" , "fieldName" .= f , "expression" .= exprToJSON r ] -exprToJSON (ObjectUpdate ann r fs) = object [ "type" .= "ObjectUpdate" +exprToJSON (ObjectUpdate ann r copy fs) + = object [ "type" .= "ObjectUpdate" , "annotation" .= annToJSON ann , "expression" .= exprToJSON r + , "copy" .= toJSON copy , "updates" .= recordToJSON exprToJSON fs ] exprToJSON (Abs ann p b) = object [ "type" .= "Abs" diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs index 16d6a34003..f0684d34d5 100644 --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -23,7 +23,7 @@ everywhereOnValues f g h = (f', g', h') g' (Literal ann e) = g (Literal ann (handleLiteral g' e)) g' (Accessor ann prop e) = g (Accessor ann prop (g' e)) - g' (ObjectUpdate ann obj vs) = g (ObjectUpdate ann (g' obj) (map (fmap g') vs)) + g' (ObjectUpdate ann obj copy vs) = g (ObjectUpdate ann (g' obj) copy (map (fmap g') vs)) g' (Abs ann name e) = g (Abs ann name (g' e)) g' (App ann v1 v2) = g (App ann (g' v1) (g' v2)) g' (Case ann vs alts) = g (Case ann (map g' vs) (map handleCaseAlternative alts)) @@ -66,7 +66,7 @@ traverseCoreFn f g h i = (f', g', h', i') g' (Literal ann e) = Literal ann <$> handleLiteral g e g' (Accessor ann prop e) = Accessor ann prop <$> g e - g' (ObjectUpdate ann obj vs) = ObjectUpdate ann <$> g obj <*> traverse (traverse g) vs + g' (ObjectUpdate ann obj copy vs) = (\obj' -> ObjectUpdate ann obj' copy) <$> g obj <*> traverse (traverse g) vs g' (Abs ann name e) = Abs ann name <$> g e g' (App ann v1 v2) = App ann <$> g v1 <*> g v2 g' (Case ann vs alts) = Case ann <$> traverse g vs <*> traverse i alts diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index 780095d039..a54e39f1e1 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -166,8 +166,8 @@ renameInValue (Literal ann l) = renameInValue c@Constructor{} = return c renameInValue (Accessor ann prop v) = Accessor ann prop <$> renameInValue v -renameInValue (ObjectUpdate ann obj vs) = - ObjectUpdate ann <$> renameInValue obj <*> traverse (\(name, v) -> (name, ) <$> renameInValue v) vs +renameInValue (ObjectUpdate ann obj copy vs) = + (\obj' -> ObjectUpdate ann obj' copy) <$> renameInValue obj <*> traverse (\(name, v) -> (name, ) <$> renameInValue v) vs renameInValue (Abs ann name v) = newScope $ Abs ann <$> updateScope name <*> renameInValue v renameInValue (App ann v1 v2) = diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index eb71f13b90..588c6817b4 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -128,6 +128,7 @@ spec = context "CoreFnFromJson" $ do [ NonRec ann (Ident "objectUpdate") $ ObjectUpdate ann (Literal ann $ ObjectLiteral [(mkString "field", Literal ann (StringLiteral (mkString "abc")))]) + (Just [mkString "unchangedField"]) [(mkString "field", Literal ann (StringLiteral (mkString "xyz")))] ] parseMod m `shouldSatisfy` isSuccess @@ -191,28 +192,28 @@ spec = context "CoreFnFromJson" $ do context "Meta" $ do specify "should parse IsConstructor" $ do let m = Module ss [] mn mp [] [] M.empty [] - [ NonRec (ss, [], Nothing, Just (IsConstructor ProductType [Ident "x"])) (Ident "x") $ - Literal (ss, [], Nothing, Just (IsConstructor SumType [])) (CharLiteral 'a') + [ NonRec (ss, [], Just (IsConstructor ProductType [Ident "x"])) (Ident "x") $ + Literal (ss, [], Just (IsConstructor SumType [])) (CharLiteral 'a') ] parseMod m `shouldSatisfy` isSuccess specify "should parse IsNewtype" $ do let m = Module ss [] mn mp [] [] M.empty [] - [ NonRec (ss, [], Nothing, Just IsNewtype) (Ident "x") $ + [ NonRec (ss, [], Just IsNewtype) (Ident "x") $ Literal ann (CharLiteral 'a') ] parseMod m `shouldSatisfy` isSuccess specify "should parse IsTypeClassConstructor" $ do let m = Module ss [] mn mp [] [] M.empty [] - [ NonRec (ss, [], Nothing, Just IsTypeClassConstructor) (Ident "x") $ + [ NonRec (ss, [], Just IsTypeClassConstructor) (Ident "x") $ Literal ann (CharLiteral 'a') ] parseMod m `shouldSatisfy` isSuccess specify "should parse IsForeign" $ do let m = Module ss [] mn mp [] [] M.empty [] - [ NonRec (ss, [], Nothing, Just IsForeign) (Ident "x") $ + [ NonRec (ss, [], Just IsForeign) (Ident "x") $ Literal ann (CharLiteral 'a') ] parseMod m `shouldSatisfy` isSuccess diff --git a/tests/purs/optimize/ObjectUpdate.out.js b/tests/purs/optimize/ObjectUpdate.out.js new file mode 100644 index 0000000000..37356ae668 --- /dev/null +++ b/tests/purs/optimize/ObjectUpdate.out.js @@ -0,0 +1,27 @@ +var staticUpdate2 = function (x) { + return { + alpha: x.alpha, + bravo: true + }; +}; +var staticUpdate1 = function (x) { + return { + alpha: x.alpha, + bravo: "replaced" + }; +}; +var dynamicUpdate1 = function (x) { + var $3 = {}; + for (var $4 in x) { + if ({}.hasOwnProperty.call(x, $4)) { + $3[$4] = x[$4]; + }; + }; + $3.bravo = true; + return $3; +}; +export { + staticUpdate1, + staticUpdate2, + dynamicUpdate1 +}; diff --git a/tests/purs/optimize/ObjectUpdate.purs b/tests/purs/optimize/ObjectUpdate.purs new file mode 100644 index 0000000000..862638fa83 --- /dev/null +++ b/tests/purs/optimize/ObjectUpdate.purs @@ -0,0 +1,10 @@ +module Main where + +staticUpdate1 :: { alpha :: Int, bravo :: String } -> { alpha :: Int, bravo :: String } +staticUpdate1 x = x { bravo = "replaced" } + +staticUpdate2 :: { alpha :: Int, bravo :: String } -> { alpha :: Int, bravo :: Boolean } +staticUpdate2 x = x { bravo = true } + +dynamicUpdate1 :: forall r. { alpha :: Int, bravo :: String | r } -> { alpha :: Int, bravo :: Boolean | r } +dynamicUpdate1 x = x { bravo = true } From 6431cd32119e50ac08243cb441c5e122fd9a5800 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Sat, 22 Jul 2023 10:28:34 -0400 Subject: [PATCH 1550/1580] Allow instances that require `Fail` to be empty (#4490) A class instance declaration that has `Prim.TypeError.Fail` as a constraint will never be used. In light of this, such instances are now allowed to have empty bodies even if the class has members. (Such instances are still allowed to declare all of their members, and it is still an error to specify some but not all members.) --- CHANGELOG.d/feature_empty-fail-instances.md | 8 ++++ src/Language/PureScript/Sugar/TypeClasses.hs | 48 ++++++++++++-------- tests/purs/failing/4483.out | 14 ++++++ tests/purs/failing/4483.purs | 13 ++++++ tests/purs/passing/4483.purs | 12 +++++ 5 files changed, 75 insertions(+), 20 deletions(-) create mode 100644 CHANGELOG.d/feature_empty-fail-instances.md create mode 100644 tests/purs/failing/4483.out create mode 100644 tests/purs/failing/4483.purs create mode 100644 tests/purs/passing/4483.purs diff --git a/CHANGELOG.d/feature_empty-fail-instances.md b/CHANGELOG.d/feature_empty-fail-instances.md new file mode 100644 index 0000000000..56e34d5ce5 --- /dev/null +++ b/CHANGELOG.d/feature_empty-fail-instances.md @@ -0,0 +1,8 @@ +* Allow instances that require `Fail` to be empty + + A class instance declaration that has `Prim.TypeError.Fail` as a constraint + will never be used. In light of this, such instances are now allowed to have + empty bodies even if the class has members. + + (Such instances are still allowed to declare all of their members, and it is + still an error to specify some but not all members.) diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index ca7a901f6f..ae70919b5f 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -11,6 +11,7 @@ module Language.PureScript.Sugar.TypeClasses import Prelude import Control.Arrow (first, second) +import Control.Monad (unless) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State (MonadState(..), StateT, evalStateT, modify) import Control.Monad.Supply.Class (MonadSupply) @@ -336,26 +337,33 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = let declaredMembers = S.fromList $ mapMaybe declIdent decls - case filter (\(ident, _) -> not $ S.member ident declaredMembers) memberTypes of - hd : tl -> throwError . errorMessage' ss $ MissingClassMember (hd NEL.:| tl) - [] -> do - -- Create values for the type instance members - members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls - - -- Create the type of the dictionary - -- The type is a record type, but depending on type instance dependencies, may be constrained. - -- The dictionary itself is a record literal. - superclassesDicts <- for typeClassSuperclasses $ \(Constraint _ superclass _ suTyArgs _) -> do - let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs - pure $ Abs (VarBinder ss UnusedIdent) (DeferredDictionary superclass tyArgs) - let superclasses = superClassDictionaryNames typeClassSuperclasses `zip` superclassesDicts - - let props = Literal ss $ ObjectLiteral $ map (first mkString) (members ++ superclasses) - dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictTypeName) className)) tys - constrainedTy = quantify (foldr srcConstrainedType dictTy deps) - dict = App (Constructor ss (fmap (coerceProperName . dictTypeName) className)) props - result = ValueDecl sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)] - return result + -- Instance declarations with a Fail constraint are unreachable code, so + -- we allow them to be empty. + let unreachable = any ((C.Fail ==) . constraintClass) deps && null decls + + unless unreachable $ + case filter (\(ident, _) -> not $ S.member ident declaredMembers) memberTypes of + hd : tl -> throwError . errorMessage' ss $ MissingClassMember (hd NEL.:| tl) + [] -> pure () + + -- Create values for the type instance members + members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls + + -- Create the type of the dictionary + -- The type is a record type, but depending on type instance dependencies, may be constrained. + -- The dictionary itself is a record literal (unless unreachable, in which case it's undefined). + superclassesDicts <- for typeClassSuperclasses $ \(Constraint _ superclass _ suTyArgs _) -> do + let tyArgs = map (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) suTyArgs + pure $ Abs (VarBinder ss UnusedIdent) (DeferredDictionary superclass tyArgs) + let superclasses = superClassDictionaryNames typeClassSuperclasses `zip` superclassesDicts + + let props = Literal ss $ ObjectLiteral $ map (first mkString) (members ++ superclasses) + dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictTypeName) className)) tys + constrainedTy = quantify (foldr srcConstrainedType dictTy deps) + dict = App (Constructor ss (fmap (coerceProperName . dictTypeName) className)) props + mkTV = if unreachable then TypedValue False (Var nullSourceSpan C.I_undefined) else TypedValue True dict + result = ValueDecl sa name Private [] [MkUnguarded (mkTV constrainedTy)] + return result where diff --git a/tests/purs/failing/4483.out b/tests/purs/failing/4483.out new file mode 100644 index 0000000000..ccc01dfb59 --- /dev/null +++ b/tests/purs/failing/4483.out @@ -0,0 +1,14 @@ +Error found: +at tests/purs/failing/4483.purs:10:1 - 11:24 (line 10, column 1 - line 11, column 24) + + The following type class members have not been implemented: + bar :: Int -> Int + +in type class instance +  + Main.Foo Int +  + +See https://github.com/purescript/documentation/blob/master/errors/MissingClassMember.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4483.purs b/tests/purs/failing/4483.purs new file mode 100644 index 0000000000..970c7887e1 --- /dev/null +++ b/tests/purs/failing/4483.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith MissingClassMember +module Main where + +import Prim.TypeError + +class Foo t where + foo :: t -> String + bar :: Int -> t + +instance fooInt :: Fail (Text "can't use this") => Foo Int where + foo _ = "unreachable" + -- bar is missing; you can get away with an empty instance here but not a + -- half-implemented one diff --git a/tests/purs/passing/4483.purs b/tests/purs/passing/4483.purs new file mode 100644 index 0000000000..f2f202e304 --- /dev/null +++ b/tests/purs/passing/4483.purs @@ -0,0 +1,12 @@ +module Main where + +import Effect.Console (log) +import Prim.TypeError + +class Foo t where + foo :: t -> String + bar :: Int -> t + +instance fooInt :: Fail (Text "can't use this") => Foo Int + +main = log "Done" From 9074fc6611987147a5909be9a3aa5d2c52dfc8a1 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Mon, 24 Jul 2023 11:31:51 -0400 Subject: [PATCH 1551/1580] Use `gh` for release artifacts (#4493) --- .github/workflows/ci.yml | 14 +++++--------- .../internal_use-gh-for-release-artifacts.md | 1 + 2 files changed, 6 insertions(+), 9 deletions(-) create mode 100644 CHANGELOG.d/internal_use-gh-for-release-artifacts.md diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 6cee437bc1..e76caa8fdf 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -180,15 +180,11 @@ jobs: - name: "(Release only) Publish bundle" if: "${{ env.CI_RELEASE == 'true' }}" - # Astonishingly, GitHub doesn't currently maintain a first-party action - # for uploading assets to GitHub releases! This is the best third-party - # one I could find, but as this step handles a token, it seems - # particularly important that we lock it down to a specific audited - # version, instead of a tag like the other steps. - uses: "AButler/upload-release-assets@ec6d3263266dc57eb6645b5f75e827987f7c217d" - with: - repo-token: "${{ secrets.GITHUB_TOKEN }}" - files: "sdist-test/bundle/*.{tar.gz,sha}" + # This requires the gh command line tool to be installed on our + # self-hosted runners + env: + GITHUB_TOKEN: "${{ secrets.GITHUB_TOKEN }}" + run: "gh release upload --clobber ${{ github.ref_name }} sdist-test/bundle/*.{tar.gz,sha}" lint: runs-on: "ubuntu-latest" diff --git a/CHANGELOG.d/internal_use-gh-for-release-artifacts.md b/CHANGELOG.d/internal_use-gh-for-release-artifacts.md new file mode 100644 index 0000000000..cb66d500f0 --- /dev/null +++ b/CHANGELOG.d/internal_use-gh-for-release-artifacts.md @@ -0,0 +1 @@ +* Use `gh` for release artifacts From 4afea2fbefeebd5e89c67d5a951efee870bcf2f2 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 25 Jul 2023 07:01:28 -0700 Subject: [PATCH 1552/1580] Fix VTAs wildcard inferred warning (#4492) The problem initially arises when we convert the [`ExprVisibleApp` (CST value) into `VisibleTypeApp` (AST value)](https://github.com/purescript/purescript/blob/master/src/Language/PureScript/CST/Convert.hs#L338-L340). Using [`convertType`](https://github.com/purescript/purescript/blob/master/src/Language/PureScript/CST/Convert.hs#L122-L123), whenever we come across a wildcard, we always convert the resulting value into an `UnnamedWildcard`. Later, [right before we typecheck a module's declarations](https://github.com/purescript/purescript/blob/master/src/Language/PureScript/TypeChecker.hs#L614), we update all `UnnamedWildcard` to `IgnoreWildcard` if they appear in a specific context via [`ignoreWildcardsUnderCompleteTypeSignatures`](https://github.com/purescript/purescript/blob/master/src/Language/PureScript/Linter/Wildcards.hs#L10-L47). Because Visible Type Applications are a separate concept, they aren't converted here. Presumably, while typechecking, the compiler emits a warning for each `UnnamedWildcard` found, which produces the issue. Thus, there are two ways to resolve this: 1. (this PR) we update `convertType` to take another arg indicating whether it was called while converting an `ExprVisibleApp` into a `VisibleTypeApp`. If it was, then convert any wildcards into `IgnoreWildcard` in the first place. This solves the root of the problem but any other usages of `convertType` don't have this special rule in place. 1. (not this PR) we update the `ignoreWildcards*` function to also account for `VisibleTypeApp`. This is a smaller change but comes at the cost of another traversal through the AST. AFAICT, `convertType` is only used in two other places, both of which I think aren't affected by this change: - [Ide/CaseSplit.hs](https://github.com/purescript/purescript/blob/master/src/Language/PureScript/Ide/CaseSplit.hs#L128) - [Interactive/Parser.hs](https://github.com/purescript/purescript/blob/master/src/Language/PureScript/Interactive/Parser.hs#L108) Lastly, we call into `convertType` via the conversion of `ExprVisibleApp` to `VisibleTypeApp`, However, `convertType` can also call `convertConstraint`, which calls `convertType`. Thus, `convertConstraint` needs to propagate the `withinVta` arg as well. --- CHANGELOG.d/fix_vtas-wildcard-inferred.md | 12 +++++++++ src/Language/PureScript/CST/Convert.hs | 26 +++++++++++------- tests/purs/warning/VTAsWildcardInferred.out | 0 tests/purs/warning/VTAsWildcardInferred.purs | 28 ++++++++++++++++++++ 4 files changed, 56 insertions(+), 10 deletions(-) create mode 100644 CHANGELOG.d/fix_vtas-wildcard-inferred.md create mode 100644 tests/purs/warning/VTAsWildcardInferred.out create mode 100644 tests/purs/warning/VTAsWildcardInferred.purs diff --git a/CHANGELOG.d/fix_vtas-wildcard-inferred.md b/CHANGELOG.d/fix_vtas-wildcard-inferred.md new file mode 100644 index 0000000000..98899b5102 --- /dev/null +++ b/CHANGELOG.d/fix_vtas-wildcard-inferred.md @@ -0,0 +1,12 @@ +* Stop emitting warnings for wildcards in Visible Type Applications + + Previously, the below usage of a wildcard (i.e. `_`) would + incorrectly cause the compiler to emit a warning. + + ```purs + f :: forall @a. a -> a + f = identity + + x :: { x :: Int } + x = f @{ x :: _ } { x: 42 } + ``` diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index 1cbe9ef31d..c75d333dcc 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -98,7 +98,13 @@ ident :: Ident -> N.Ident ident = N.Ident . getIdent convertType :: String -> Type a -> T.SourceType -convertType fileName = go +convertType = convertType' False + +convertVtaType :: String -> Type a -> T.SourceType +convertVtaType = convertType' True + +convertType' :: Bool -> String -> Type a -> T.SourceType +convertType' withinVta fileName = go where goRow (Row labels tl) b = do let @@ -120,7 +126,7 @@ convertType fileName = go TypeConstructor _ a -> T.TypeConstructor (sourceQualName fileName a) $ qualified a TypeWildcard _ a -> - T.TypeWildcard (sourceAnnCommented fileName a a) T.UnnamedWildcard + T.TypeWildcard (sourceAnnCommented fileName a a) $ if withinVta then T.IgnoredWildcard else T.UnnamedWildcard TypeHole _ a -> T.TypeWildcard (sourceName fileName a) . T.HoleWildcard . getIdent $ nameValue a TypeString _ a b -> @@ -182,7 +188,7 @@ convertType fileName = go Env.tyFunction $> sourceAnnCommented fileName a a TypeConstrained _ a _ b -> do let - a' = convertConstraint fileName a + a' = convertConstraint withinVta fileName a b' = go b ann = Pos.widenSourceAnn (T.constraintAnn a') (T.getAnnForType b') T.ConstrainedType ann a' b' @@ -195,13 +201,13 @@ convertType fileName = go ann = uncurry (sourceAnnCommented fileName) rng T.setAnnForType ann $ Env.kindRow a' -convertConstraint :: String -> Constraint a -> T.SourceConstraint -convertConstraint fileName = go +convertConstraint :: Bool -> String -> Constraint a -> T.SourceConstraint +convertConstraint withinVta fileName = go where go = \case cst@(Constraint _ name args) -> do let ann = uncurry (sourceAnnCommented fileName) $ constraintRange cst - T.Constraint ann (qualified name) [] (convertType fileName <$> args) Nothing + T.Constraint ann (qualified name) [] (convertType' withinVta fileName <$> args) Nothing ConstraintParens _ (Wrapped _ c _) -> go c convertGuarded :: String -> Guarded a -> [AST.GuardedExpr] @@ -337,7 +343,7 @@ convertExpr fileName = go positioned ann $ AST.App (go a) (go b) expr@(ExprVisibleTypeApp _ a _ b) -> do let ann = uncurry (sourceAnn fileName) $ exprRange expr - positioned ann $ AST.VisibleTypeApp (go a) (convertType fileName b) + positioned ann $ AST.VisibleTypeApp (go a) (convertVtaType fileName b) expr@(ExprLambda _ (Lambda _ as _ b)) -> do let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr positioned ann @@ -472,7 +478,7 @@ convertDeclaration fileName decl = case decl of pure $ AST.TypeClassDeclaration ann (nameValue name) (goTypeVar <$> vars) - (convertConstraint fileName <$> maybe [] (toList . fst) sup) + (convertConstraint False fileName <$> maybe [] (toList . fst) sup) (goFundep <$> maybe [] (toList . snd) fdeps) (goSig <$> maybe [] (NE.toList . snd) bd) DeclInstanceChain _ insts -> do @@ -483,7 +489,7 @@ convertDeclaration fileName decl = case decl of clsAnn = findInstanceAnn cls args AST.TypeInstanceDeclaration ann' clsAnn chainId ix (mkPartialInstanceName nameSep cls args) - (convertConstraint fileName <$> maybe [] (toList . fst) ctrs) + (convertConstraint False fileName <$> maybe [] (toList . fst) ctrs) (qualified cls) (convertType fileName <$> args) (AST.ExplicitInstance $ goInstanceBinding <$> maybe [] (NE.toList . snd) bd) @@ -497,7 +503,7 @@ convertDeclaration fileName decl = case decl of | otherwise = AST.DerivedInstance clsAnn = findInstanceAnn cls args pure $ AST.TypeInstanceDeclaration ann clsAnn chainId 0 name' - (convertConstraint fileName <$> maybe [] (toList . fst) ctrs) + (convertConstraint False fileName <$> maybe [] (toList . fst) ctrs) (qualified cls) (convertType fileName <$> args) instTy diff --git a/tests/purs/warning/VTAsWildcardInferred.out b/tests/purs/warning/VTAsWildcardInferred.out new file mode 100644 index 0000000000..e69de29bb2 diff --git a/tests/purs/warning/VTAsWildcardInferred.purs b/tests/purs/warning/VTAsWildcardInferred.purs new file mode 100644 index 0000000000..4a5da616d1 --- /dev/null +++ b/tests/purs/warning/VTAsWildcardInferred.purs @@ -0,0 +1,28 @@ +-- See https://github.com/purescript/purescript/issues/4487 +module Main where + +import Prelude +import Effect (Effect) +import Effect.Console (log) + +f :: forall @a. a -> a +f = identity + +test1 :: { x :: Int } +test1 = f @{ x :: _ } { x: 42 } + +class Foo :: Type -> Type -> Type -> Constraint +class Foo a b c | a -> b c where + fooMember :: a -> b + +wrap :: forall @a. Array a -> Array (Array a) +wrap as = [as] + +arrFooMember :: forall c. Array (Foo Int Boolean c => Int -> Boolean) +arrFooMember = [fooMember] + +test2 :: forall c. Array (Array (Foo Int Boolean c => Int -> Boolean)) +test2 = wrap @(Foo Int Boolean _ => _) arrFooMember -- neither wildcard should warn IMO + +main :: Effect Unit +main = log "Done" From 0662cccfb938181305149c7d52cd6ef5d80b3e77 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 8 Aug 2023 13:15:08 -0500 Subject: [PATCH 1553/1580] Fix record type inference involving visible type applications (#4501) --- CHANGELOG.d/fix_vtas-record-inference.md | 14 ++++++++++++++ src/Language/PureScript/TypeChecker/Types.hs | 1 + tests/purs/passing/4500.purs | 15 +++++++++++++++ 3 files changed, 30 insertions(+) create mode 100644 CHANGELOG.d/fix_vtas-record-inference.md create mode 100644 tests/purs/passing/4500.purs diff --git a/CHANGELOG.d/fix_vtas-record-inference.md b/CHANGELOG.d/fix_vtas-record-inference.md new file mode 100644 index 0000000000..92e0b18285 --- /dev/null +++ b/CHANGELOG.d/fix_vtas-record-inference.md @@ -0,0 +1,14 @@ +* Infer types using VTA inside a record + + Previously, `use` would fail to compile + because the `v` type variable would not be inferred + to `String`. Now the below code compiles: + + ```purs + reflect :: forall @t v . Reflectable t v => v + reflect = reflectType (Proxy @t) + + use :: String + use = show { asdf: reflect @"asdf" } + ``` + diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 04f7de22fe..3f758805c6 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -569,6 +569,7 @@ propertyShouldInstantiate :: Expr -> Bool propertyShouldInstantiate = \case Var{} -> True Constructor{} -> True + VisibleTypeApp e _ -> propertyShouldInstantiate e PositionedValue _ _ e -> propertyShouldInstantiate e _ -> False diff --git a/tests/purs/passing/4500.purs b/tests/purs/passing/4500.purs new file mode 100644 index 0000000000..2e11a30d44 --- /dev/null +++ b/tests/purs/passing/4500.purs @@ -0,0 +1,15 @@ +module Main where + +import Prelude + +import Data.Reflectable (class Reflectable, reflectType) +import Type.Proxy (Proxy(..)) +import Effect.Console (log) + +reflect :: forall @t v . Reflectable t v => v +reflect = reflectType (Proxy @t) + +use :: String +use = show { asdf: reflect @"asdf" } + +main = log "Done" From 8ede652b6f040dcaadff8a59f9cfb118993f7986 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Tue, 8 Aug 2023 13:42:17 -0500 Subject: [PATCH 1554/1580] Stop triggering CI on non-code-related changes (#4502) --- .github/workflows/ci.yml | 17 +++++++++++++++++ ...l_stop-building-if-non-significant-change.md | 1 + 2 files changed, 18 insertions(+) create mode 100644 CHANGELOG.d/internal_stop-building-if-non-significant-change.md diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index e76caa8fdf..0460c5762a 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -5,6 +5,23 @@ on: branches: [ "master" ] pull_request: branches: [ "master" ] + paths: + - .github/workflows/**/*.yml + - app/**/* + - bundle/**/* + - ci/**/* + - license-generator/**/* + - src/**/* + - test/**/* + - .gitignore + - .hlint.yaml + - .hspec + - cabal.project + - purescript.cabal + - Setup.hs + - stack.yaml + - update-changelog.hs + - weeder.dhall release: types: [ "published" ] diff --git a/CHANGELOG.d/internal_stop-building-if-non-significant-change.md b/CHANGELOG.d/internal_stop-building-if-non-significant-change.md new file mode 100644 index 0000000000..f635c7e88e --- /dev/null +++ b/CHANGELOG.d/internal_stop-building-if-non-significant-change.md @@ -0,0 +1 @@ +* Stop triggering CI on non-code-related changes (e.g. Readme) From 843c1097bab3fa9fe25e1f661f6af3ab95d3141c Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 29 Sep 2023 09:05:23 -0500 Subject: [PATCH 1555/1580] Prep 0.15.11 release (#4507) * Update changelog * Update versions to 0.15.11 --- CHANGELOG.d/feature_closed-record-update.md | 7 --- CHANGELOG.d/feature_empty-fail-instances.md | 8 --- CHANGELOG.d/fix_vtas-record-inference.md | 14 ----- CHANGELOG.d/fix_vtas-wildcard-inferred.md | 12 ---- ...stop-building-if-non-significant-change.md | 1 - .../internal_use-gh-for-release-artifacts.md | 1 - CHANGELOG.md | 56 +++++++++++++++++++ npm-package/package.json | 4 +- purescript.cabal | 2 +- 9 files changed, 59 insertions(+), 46 deletions(-) delete mode 100644 CHANGELOG.d/feature_closed-record-update.md delete mode 100644 CHANGELOG.d/feature_empty-fail-instances.md delete mode 100644 CHANGELOG.d/fix_vtas-record-inference.md delete mode 100644 CHANGELOG.d/fix_vtas-wildcard-inferred.md delete mode 100644 CHANGELOG.d/internal_stop-building-if-non-significant-change.md delete mode 100644 CHANGELOG.d/internal_use-gh-for-release-artifacts.md diff --git a/CHANGELOG.d/feature_closed-record-update.md b/CHANGELOG.d/feature_closed-record-update.md deleted file mode 100644 index c3534373c6..0000000000 --- a/CHANGELOG.d/feature_closed-record-update.md +++ /dev/null @@ -1,7 +0,0 @@ -* Move the closed record update optimization - - For consumers of CoreFn like alternate backends, the optimization of - replacing a closed record update with an object literal has now been moved to - the point of desugaring CoreFn into JS. The `ObjectUpdate` expression - constructor now contains a `Maybe` field holding a list of record labels to - be copied as-is, for backends that want to perform this optimization also. diff --git a/CHANGELOG.d/feature_empty-fail-instances.md b/CHANGELOG.d/feature_empty-fail-instances.md deleted file mode 100644 index 56e34d5ce5..0000000000 --- a/CHANGELOG.d/feature_empty-fail-instances.md +++ /dev/null @@ -1,8 +0,0 @@ -* Allow instances that require `Fail` to be empty - - A class instance declaration that has `Prim.TypeError.Fail` as a constraint - will never be used. In light of this, such instances are now allowed to have - empty bodies even if the class has members. - - (Such instances are still allowed to declare all of their members, and it is - still an error to specify some but not all members.) diff --git a/CHANGELOG.d/fix_vtas-record-inference.md b/CHANGELOG.d/fix_vtas-record-inference.md deleted file mode 100644 index 92e0b18285..0000000000 --- a/CHANGELOG.d/fix_vtas-record-inference.md +++ /dev/null @@ -1,14 +0,0 @@ -* Infer types using VTA inside a record - - Previously, `use` would fail to compile - because the `v` type variable would not be inferred - to `String`. Now the below code compiles: - - ```purs - reflect :: forall @t v . Reflectable t v => v - reflect = reflectType (Proxy @t) - - use :: String - use = show { asdf: reflect @"asdf" } - ``` - diff --git a/CHANGELOG.d/fix_vtas-wildcard-inferred.md b/CHANGELOG.d/fix_vtas-wildcard-inferred.md deleted file mode 100644 index 98899b5102..0000000000 --- a/CHANGELOG.d/fix_vtas-wildcard-inferred.md +++ /dev/null @@ -1,12 +0,0 @@ -* Stop emitting warnings for wildcards in Visible Type Applications - - Previously, the below usage of a wildcard (i.e. `_`) would - incorrectly cause the compiler to emit a warning. - - ```purs - f :: forall @a. a -> a - f = identity - - x :: { x :: Int } - x = f @{ x :: _ } { x: 42 } - ``` diff --git a/CHANGELOG.d/internal_stop-building-if-non-significant-change.md b/CHANGELOG.d/internal_stop-building-if-non-significant-change.md deleted file mode 100644 index f635c7e88e..0000000000 --- a/CHANGELOG.d/internal_stop-building-if-non-significant-change.md +++ /dev/null @@ -1 +0,0 @@ -* Stop triggering CI on non-code-related changes (e.g. Readme) diff --git a/CHANGELOG.d/internal_use-gh-for-release-artifacts.md b/CHANGELOG.d/internal_use-gh-for-release-artifacts.md deleted file mode 100644 index cb66d500f0..0000000000 --- a/CHANGELOG.d/internal_use-gh-for-release-artifacts.md +++ /dev/null @@ -1 +0,0 @@ -* Use `gh` for release artifacts diff --git a/CHANGELOG.md b/CHANGELOG.md index 94592161bd..81547a9ff3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,62 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.11 + +New features: + +* Move the closed record update optimization (#4489 by @rhendric) + + For consumers of CoreFn like alternate backends, the optimization of + replacing a closed record update with an object literal has now been moved to + the point of desugaring CoreFn into JS. The `ObjectUpdate` expression + constructor now contains a `Maybe` field holding a list of record labels to + be copied as-is, for backends that want to perform this optimization also. + +* Allow instances that require `Fail` to be empty (#4490 by @rhendric) + + A class instance declaration that has `Prim.TypeError.Fail` as a constraint + will never be used. In light of this, such instances are now allowed to have + empty bodies even if the class has members. + + (Such instances are still allowed to declare all of their members, and it is + still an error to specify some but not all members.) + +Bugfixes: + +* Stop emitting warnings for wildcards in Visible Type Applications (#4492 by @JordanMartinez) + + Previously, the below usage of a wildcard (i.e. `_`) would + incorrectly cause the compiler to emit a warning. + + ```purs + f :: forall @a. a -> a + f = identity + + x :: { x :: Int } + x = f @{ x :: _ } { x: 42 } + ``` + +* Infer types using VTA inside a record (#4501 by @JordanMartinez) + + Previously, `use` would fail to compile + because the `v` type variable would not be inferred + to `String`. Now the below code compiles: + + ```purs + reflect :: forall @t v . Reflectable t v => v + reflect = reflectType (Proxy @t) + + use :: String + use = show { asdf: reflect @"asdf" } + ``` + +Internal: + +* Use `gh` for release artifacts (#4493 by @rhendric) + +* Stop triggering CI on non-code-related changes (e.g. Readme) (#4502 by @JordanMartinez) + ## 0.15.10 New features: diff --git a/npm-package/package.json b/npm-package/package.json index 8159571081..86e278e6f5 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.10", + "version": "0.15.11", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.10", + "postinstall": "install-purescript --purs-ver=0.15.11", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index ec35ef3938..2e4451d88f 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.10 +version: 0.15.11 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 2412101a8301f2d63e8fb8b316a23ac8ff6463e6 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Sat, 7 Oct 2023 06:21:50 -0500 Subject: [PATCH 1556/1580] Install gh on ubuntu-latest run; prep 0.15.12 release (#4509) * Install gh on ubuntu-latest run * Prep 0.15.12 release --- .github/workflows/ci.yml | 11 +++++++++++ CHANGELOG.md | 9 +++++++-- npm-package/package.json | 4 ++-- purescript.cabal | 2 +- 4 files changed, 21 insertions(+), 5 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 0460c5762a..07a3155e80 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -77,6 +77,17 @@ jobs: . /etc/os-release echo deb http://deb.debian.org/debian "$VERSION_CODENAME"-backports main >> /etc/apt/sources.list apt-get update && apt-get install -y git/"$VERSION_CODENAME"-backports + + - # We need `gh` installed on the Linux version. Otherwise, release artifacts won't be uploaded. + name: "(Linux only) Install gh" + if: "contains(matrix.os, 'ubuntu-latest')" + run: | + curl -fsSL https://cli.github.com/packages/githubcli-archive-keyring.gpg | dd of=/usr/share/keyrings/githubcli-archive-keyring.gpg + chmod go+r /usr/share/keyrings/githubcli-archive-keyring.gpg + echo "deb [arch=$(dpkg --print-architecture) signed-by=/usr/share/keyrings/githubcli-archive-keyring.gpg] https://cli.github.com/packages stable main" | tee /etc/apt/sources.list.d/github-cli.list > /dev/null + apt-get update + apt-get install gh + - uses: "actions/checkout@v2" - uses: "actions/setup-node@v2" with: diff --git a/CHANGELOG.md b/CHANGELOG.md index 81547a9ff3..67eae177e8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,7 +2,7 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). -## 0.15.11 +## 0.15.12 New features: @@ -54,10 +54,15 @@ Bugfixes: Internal: -* Use `gh` for release artifacts (#4493 by @rhendric) +* Use `gh` for release artifacts (#4493 by @rhendric, #4509 by @JordanMartinez) * Stop triggering CI on non-code-related changes (e.g. Readme) (#4502 by @JordanMartinez) + +## 0.15.11 + +Please use `0.15.12` instead of this release. There was an issue with the Linux build. This release notes were moved into `0.15.12`'s release notes. + ## 0.15.10 New features: diff --git a/npm-package/package.json b/npm-package/package.json index 86e278e6f5..9ab1997120 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.11", + "version": "0.15.12", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.11", + "postinstall": "install-purescript --purs-ver=0.15.12", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index 2e4451d88f..bd1595adec 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.11 +version: 0.15.12 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 4f4672d26d024ee4eb855eccd93dc48e6f5eb036 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Fri, 3 Nov 2023 11:03:36 -0500 Subject: [PATCH 1557/1580] Drop UnusableDeclaration; update NoInstanceFound error (#4513) With the advent of visible type applications (VTAs), all type class instances can be determined via VTAs. This PR removes the `UnusableDeclaration` error. Whereas before, the code would throw the above error when type variables in the type class head are not mentioned in the type class member's type signature, now we simply track these "VTA-required" args. These args represent type variables that must be disambiguated using VTAs. If VTAs are used, the instance should be found. If they are not used, an updated `NoInstanceFound` error is thrown that notifies the user of these "VTA-required" args if possible. When a `NoInstanceFound` error is thrown, we do not attempt to do anything other than notify the user of the "VTA-required" args. In a previous and problematic approach, we did try to do more but found a number of difficult problems with this approach: - Suggesting a correct usage of `coerce` with VTAs in all of its complex cases - When a user does supply a VTA arg, assuming that that arg refers to a corresponding type in a valid type class instance: `foo @Int` when there is no `Foo Int` instance - User confusion due to a difference in order of VTA args with their usage within the type class member's type signature: `foo @1 @2` when `foo :: forall one two. two -> one` A side effect of dropping the `UnusableDeclaration` error is a scoping bug that was revealed in `moveQuantifiersToFront`. This bug has also been fixed. Other notes: - `replaceAllTypeSynonymsM` is removed as it's no longer used by anything. - The Externs files do not store the "VTA-required" args and instead recompute them after being loaded. - The "VTA-required" args are tracked via their indices so as to print them in their corresponding order later. --- .../bug_fix-moveQuantifiersToFront-scoping.md | 23 ++ .../feature_replace-unused-declarations.md | 71 +++++++ src/Language/PureScript/AST/Declarations.hs | 11 + .../PureScript/Docs/Convert/ReExports.hs | 2 +- src/Language/PureScript/Environment.hs | 26 ++- src/Language/PureScript/Errors.hs | 54 ++--- src/Language/PureScript/Externs.hs | 2 +- .../PureScript/Interactive/Printer.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 7 +- src/Language/PureScript/TypeChecker.hs | 26 +-- .../PureScript/TypeChecker/Entailment.hs | 56 ++++- .../TypeChecker/Entailment/Coercible.hs | 5 +- .../PureScript/TypeChecker/Synonyms.hs | 10 - src/Language/PureScript/Types.hs | 39 ++-- tests/purs/failing/ClassHeadNoVTA1.out | 25 +++ tests/purs/failing/ClassHeadNoVTA1.purs | 8 + tests/purs/failing/ClassHeadNoVTA2.out | 27 +++ tests/purs/failing/ClassHeadNoVTA2.purs | 11 + tests/purs/failing/ClassHeadNoVTA3.out | 28 +++ tests/purs/failing/ClassHeadNoVTA3.purs | 9 + tests/purs/failing/ClassHeadNoVTA4.out | 27 +++ tests/purs/failing/ClassHeadNoVTA4.purs | 8 + tests/purs/failing/ClassHeadNoVTA5.out | 29 +++ tests/purs/failing/ClassHeadNoVTA5.purs | 10 + tests/purs/failing/ClassHeadNoVTA6a.out | 37 ++++ tests/purs/failing/ClassHeadNoVTA6a.purs | 12 ++ tests/purs/failing/ClassHeadNoVTA6b.out | 50 +++++ tests/purs/failing/ClassHeadNoVTA6b.purs | 16 ++ tests/purs/failing/ClassHeadNoVTA6c.out | 50 +++++ tests/purs/failing/ClassHeadNoVTA6c.purs | 16 ++ tests/purs/failing/ClassHeadNoVTA7.out | 25 +++ tests/purs/failing/ClassHeadNoVTA7.purs | 12 ++ tests/purs/failing/TypedHole.out | 14 +- .../purs/failing/UnusableTypeClassMethod.out | 12 -- .../purs/failing/UnusableTypeClassMethod.purs | 7 - ...nusableTypeClassMethodConflictingIdent.out | 12 -- ...usableTypeClassMethodConflictingIdent.purs | 7 - .../UnusableTypeClassMethodSynonym.out | 12 -- .../UnusableTypeClassMethodSynonym.purs | 9 - tests/purs/passing/VTAsClassHeads.purs | 196 ++++++++++++++++++ tests/purs/warning/TypeClassMethodSynonym.out | 11 + .../purs/warning/TypeClassMethodSynonym.purs | 8 + 42 files changed, 864 insertions(+), 158 deletions(-) create mode 100644 CHANGELOG.d/bug_fix-moveQuantifiersToFront-scoping.md create mode 100644 CHANGELOG.d/feature_replace-unused-declarations.md create mode 100644 tests/purs/failing/ClassHeadNoVTA1.out create mode 100644 tests/purs/failing/ClassHeadNoVTA1.purs create mode 100644 tests/purs/failing/ClassHeadNoVTA2.out create mode 100644 tests/purs/failing/ClassHeadNoVTA2.purs create mode 100644 tests/purs/failing/ClassHeadNoVTA3.out create mode 100644 tests/purs/failing/ClassHeadNoVTA3.purs create mode 100644 tests/purs/failing/ClassHeadNoVTA4.out create mode 100644 tests/purs/failing/ClassHeadNoVTA4.purs create mode 100644 tests/purs/failing/ClassHeadNoVTA5.out create mode 100644 tests/purs/failing/ClassHeadNoVTA5.purs create mode 100644 tests/purs/failing/ClassHeadNoVTA6a.out create mode 100644 tests/purs/failing/ClassHeadNoVTA6a.purs create mode 100644 tests/purs/failing/ClassHeadNoVTA6b.out create mode 100644 tests/purs/failing/ClassHeadNoVTA6b.purs create mode 100644 tests/purs/failing/ClassHeadNoVTA6c.out create mode 100644 tests/purs/failing/ClassHeadNoVTA6c.purs create mode 100644 tests/purs/failing/ClassHeadNoVTA7.out create mode 100644 tests/purs/failing/ClassHeadNoVTA7.purs delete mode 100644 tests/purs/failing/UnusableTypeClassMethod.out delete mode 100644 tests/purs/failing/UnusableTypeClassMethod.purs delete mode 100644 tests/purs/failing/UnusableTypeClassMethodConflictingIdent.out delete mode 100644 tests/purs/failing/UnusableTypeClassMethodConflictingIdent.purs delete mode 100644 tests/purs/failing/UnusableTypeClassMethodSynonym.out delete mode 100644 tests/purs/failing/UnusableTypeClassMethodSynonym.purs create mode 100644 tests/purs/passing/VTAsClassHeads.purs create mode 100644 tests/purs/warning/TypeClassMethodSynonym.out create mode 100644 tests/purs/warning/TypeClassMethodSynonym.purs diff --git a/CHANGELOG.d/bug_fix-moveQuantifiersToFront-scoping.md b/CHANGELOG.d/bug_fix-moveQuantifiersToFront-scoping.md new file mode 100644 index 0000000000..5d701a22cb --- /dev/null +++ b/CHANGELOG.d/bug_fix-moveQuantifiersToFront-scoping.md @@ -0,0 +1,23 @@ +* Fix scoping issues in `moveQuantifiersToFront` + +As a side effect of replacing `UnusableDeclaration` with +an updated `NoInstanceFound` error, a bug appeared in how +scoping is handled when constraints are involved. + +```purs +-- | a0 +class Foo a where +-- | a1 + foo :: forall a. a +``` +Before this fix, `foo`'s type signature was being transformed to +`foo :: forall @a a. Foo a => a` +where two type variables with the same identifier +are present rather than the correct signature of +`foo :: forall @a0. Foo a0 => (forall a1. a1)`. + +With this fix, the above type class declaration +will now compile and trigger a `ShadowedName` +warning since the type class member's `a` +(i.e. `a1` above) shadows the type class head's `a` +(i.e. `a0` above). diff --git a/CHANGELOG.d/feature_replace-unused-declarations.md b/CHANGELOG.d/feature_replace-unused-declarations.md new file mode 100644 index 0000000000..4bc3b11273 --- /dev/null +++ b/CHANGELOG.d/feature_replace-unused-declarations.md @@ -0,0 +1,71 @@ +* Replace `UnusableDeclaration` with updated `NoInstanceFound` + + Previously, the following type class would be invalid + because there was no way for the compiler to infer + which type class instance to select because + the type variable in the class head `a` was + not mentioned in `bar`'s type signature: + + ```purs + class Foo a where + bar :: Int + ``` + + The recently-added visible type applications (VTAs) + can now be used to guide the compiler in such cases: + + ```purs + class Foo a where bar :: Int + instance Foo String where bar = 0 + someInt = bar @String -- use the `String` instance + ``` + + Without VTAs, the compiler + will still produce an `InstanceNotFound` error, but this error + has been updated to note which type variables in the class head + can only be disambiguated via visible type applications. + Given the following code + + ```purs + class Single tyVarDoesNotAppearInBody where + useSingle :: Int + + single :: Int + single = useSingle + ``` + + The error reported for `useSingle` will be: + + ``` + No type class instance was found for + + Main.Single t0 + + The instance head contains unknown type variables. + + + Note: The following type class members found in the expression require visible type applications + to be unambiguous (e.g. tyClassMember @Int). + Main.useSingle + tyNotAppearInBody + ``` + + For a multiparameter typeclass with functional dependencies... + + ```purs + class MultiFdBidi a b | a -> b, b -> a where + useMultiFdBidi :: Int + + multiFdBidi :: Int + multiFdBidi = useMultiFdBidi + ``` + + ...the "Note" part is updated to read + ``` + Note: The following type class members found in the expression require visible type applications + to be unambiguous (e.g. tyClassMember @Int). + Main.useMultiFdBidi + One of the following sets of type variables: + a + b + ``` diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index f9ca32b3a1..e6d13c74aa 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -103,6 +103,17 @@ data HintCategory | OtherHint deriving (Show, Eq) +-- | +-- In constraint solving, indicates whether there were `TypeUnknown`s that prevented +-- an instance from being found, and whether VTAs are required +-- due to type class members not referencing all the type class +-- head's type variables. +data UnknownsHint + = NoUnknowns + | Unknowns + | UnknownsWithVtaRequiringArgs (NEL.NonEmpty (Qualified Ident, [[Text]])) + deriving (Show) + -- | -- A module declaration, consisting of comments about the module, a module name, -- a list of declarations, and a list of the declarations that are diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 9574f0fe7d..600b343a5b 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -441,7 +441,7 @@ handleEnv TypeClassEnv{..} = ++ T.unpack cdeclTitle) addConstraint constraint = - P.quantify . P.moveQuantifiersToFront . P.ConstrainedType () constraint + P.quantify . P.moveQuantifiersToFront () . P.ConstrainedType () constraint splitMap :: Map k (v1, v2) -> (Map k v1, Map k v2) splitMap = fmap fst &&& fmap snd diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index de1b35d3c9..e1f857031f 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -14,7 +14,7 @@ import Data.IntMap qualified as IM import Data.IntSet qualified as IS import Data.Map qualified as M import Data.Set qualified as S -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Semigroup (First(..)) import Data.Text (Text) import Data.Text qualified as T @@ -25,7 +25,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, QualifiedBy, coerceProperName) import Language.PureScript.Roles (Role(..)) import Language.PureScript.TypeClassDictionaries (NamedDict) -import Language.PureScript.Types (SourceConstraint, SourceType, Type(..), TypeVarVisibility(..), eqType, srcTypeConstructor) +import Language.PureScript.Types (SourceConstraint, SourceType, Type(..), TypeVarVisibility(..), eqType, srcTypeConstructor, freeTypeVariables) import Language.PureScript.Constants.Prim qualified as C -- | The @Environment@ defines all values and types which are currently in scope: @@ -54,9 +54,10 @@ data TypeClassData = TypeClassData { typeClassArguments :: [(Text, Maybe SourceType)] -- ^ A list of type argument names, and their kinds, where kind annotations -- were provided. - , typeClassMembers :: [(Ident, SourceType)] - -- ^ A list of type class members and their types. Type arguments listed above - -- are considered bound in these types. + , typeClassMembers :: [(Ident, SourceType, Maybe (S.Set (NEL.NonEmpty Int)))] + -- ^ A list of type class members and their types and whether or not + -- they have type variables that must be defined using Visible Type Applications. + -- Type arguments listed above are considered bound in these types. , typeClassSuperclasses :: [SourceConstraint] -- ^ A list of superclasses of this type class. Type arguments listed above -- are considered bound in the types appearing in these constraints. @@ -129,10 +130,23 @@ makeTypeClassData -> [FunctionalDependency] -> Bool -> TypeClassData -makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs coveringSets +makeTypeClassData args m s deps = TypeClassData args m' s deps determinedArgs coveringSets where ( determinedArgs, coveringSets ) = computeCoveringSets (length args) deps + coveringSets' = S.toList coveringSets + + m' = map (\(a, b) -> (a, b, addVtaInfo b)) m + + addVtaInfo :: SourceType -> Maybe (S.Set (NEL.NonEmpty Int)) + addVtaInfo memberTy = do + let mentionedArgIndexes = S.fromList (mapMaybe argToIndex $ freeTypeVariables memberTy) + let leftovers = map (`S.difference` mentionedArgIndexes) coveringSets' + S.fromList <$> traverse (NEL.nonEmpty . S.toList) leftovers + + argToIndex :: Text -> Maybe Int + argToIndex = flip M.lookup $ M.fromList (zipWith ((,) . fst) args [0..]) + -- A moving frontier of sets to consider, along with the fundeps that can be -- applied in each case. At each stage, all sets in the frontier will be the -- same size, decreasing by 1 each time. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 972e6b69a8..2d8225f324 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -111,7 +111,7 @@ data SimpleErrorMessage | NoInstanceFound SourceConstraint -- ^ constraint that could not be solved [Qualified (Either SourceType Ident)] -- ^ a list of instances that stopped further progress in instance chains due to ambiguity - Bool -- ^ whether eliminating unknowns with annotations might help + UnknownsHint -- ^ whether eliminating unknowns with annotations might help or if visible type applications are required | AmbiguousTypeVariables SourceType [(Text, Int)] | UnknownClass (Qualified (ProperName 'ClassName)) | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [SourceType] @@ -177,8 +177,6 @@ data SimpleErrorMessage | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int -- | a user-defined warning raised by using the Warn type class | UserDefinedWarning SourceType - -- | a declaration couldn't be used because it contained free variables - | UnusableDeclaration Ident [[Text]] | CannotDefinePrimModules ModuleName | MixedAssociativityError (NEL.NonEmpty (Qualified (OpName 'AnyOpName), Associativity)) | NonAssociativeError (NEL.NonEmpty (Qualified (OpName 'AnyOpName))) @@ -352,7 +350,6 @@ errorCode em = case unwrapErrorMessage em of CannotUseBindWithDo{} -> "CannotUseBindWithDo" ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch" UserDefinedWarning{} -> "UserDefinedWarning" - UnusableDeclaration{} -> "UnusableDeclaration" CannotDefinePrimModules{} -> "CannotDefinePrimModules" MixedAssociativityError{} -> "MixedAssociativityError" NonAssociativeError{} -> "NonAssociativeError" @@ -917,7 +914,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon , line ("You can use " <> markCode "_ <- ..." <> " to explicitly discard the result.") ] renderSimpleErrorMessage (NoInstanceFound (Constraint _ nm _ ts _) ambiguous unks) = - paras [ line "No type class instance was found for" + paras $ + [ line "No type class instance was found for" , markCodeBox $ indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm) , Box.vcat Box.left (map prettyTypeAtom ts) @@ -930,10 +928,32 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon [] -> [] [_] -> useMessage "The following instance partially overlaps the above constraint, which means the rest of its instance chain will not be considered:" _ -> useMessage "The following instances partially overlap the above constraint, which means the rest of their instance chains will not be considered:" - , paras [ line "The instance head contains unknown type variables. Consider adding a type annotation." - | unks - ] - ] + ] <> case unks of + NoUnknowns -> + [] + Unknowns -> + [ line "The instance head contains unknown type variables. Consider adding a type annotation." ] + UnknownsWithVtaRequiringArgs tyClassMembersRequiringVtas -> + let + renderSingleTyClassMember (tyClassMember, argsRequiringVtas) = + Box.moveRight 2 $ paras $ + [ line $ markCode (showQualified showIdent tyClassMember) ] + <> case argsRequiringVtas of + [required] -> + [ Box.moveRight 2 $ line $ T.intercalate ", " required ] + options -> + [ Box.moveRight 2 $ line "One of the following sets of type variables:" + , Box.moveRight 2 $ paras $ + map (\set -> Box.moveRight 2 $ line $ T.intercalate ", " set) options + ] + in + [ paras + [ line "The instance head contains unknown type variables." + , Box.moveDown 1 $ paras $ + [ line $ "Note: The following type class members found in the expression require visible type applications to be unambiguous (e.g. " <> markCode "tyClassMember @Int" <> ")."] + <> map renderSingleTyClassMember (NEL.toList tyClassMembersRequiringVtas) + ] + ] renderSimpleErrorMessage (AmbiguousTypeVariables t uis) = paras [ line "The inferred type" , markCodeBox $ indent $ prettyType t @@ -1277,22 +1297,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon , indent msg ] - renderSimpleErrorMessage (UnusableDeclaration ident unexplained) = - paras $ - [ line $ "The declaration " <> markCode (showIdent ident) <> " contains arguments that couldn't be determined." - ] <> - - case unexplained of - [required] -> - [ line $ "These arguments are: { " <> T.intercalate ", " required <> " }" - ] - - options -> - [ line "To fix this, one of the following sets of variables must be determined:" - , Box.moveRight 2 . Box.vsep 0 Box.top $ - map (\set -> line $ "{ " <> T.intercalate ", " set <> " }") options - ] - renderSimpleErrorMessage (CannotDefinePrimModules mn) = paras [ line $ "The module name " <> markCode (runModuleName mn) <> " is in the Prim namespace." diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 12838a1bcd..29d15ec8cd 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -254,7 +254,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF = [ EDType (coerceProperName className) kind tk , EDType dictName dictKind dictData , EDDataConstructor dctor dty dictName ty args - , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies typeClassIsEmpty + , EDClass className typeClassArguments ((\(a, b, _) -> (a, b)) <$> typeClassMembers) typeClassSuperclasses typeClassDependencies typeClassIsEmpty ] toExternsDeclaration (TypeInstanceRef ss' ident ns) = [ EDInstance tcdClassName (lookupRenamedIdent ident) tcdForAll tcdInstanceKinds tcdInstanceTypes tcdDependencies tcdChain tcdIndex ns ss' diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index cd0b8f58f3..ed2d145219 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -69,7 +69,7 @@ printModuleSignatures moduleName P.Environment{..} = textT (P.runProperName name) Box.<> textT (foldMap ((" " <>) . fst) typeClassArguments) classBody = - Box.vcat Box.top (map (\(i, t) -> textT (P.showIdent i <> " ::") Box.<+> P.typeAsBox maxBound t) typeClassMembers) + Box.vcat Box.top (map (\(i, t, _) -> textT (P.showIdent i <> " ::") Box.<+> P.typeAsBox maxBound t) typeClassMembers) in Just $ diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index ae70919b5f..4f3129baf8 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -305,7 +305,7 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarati in ValueDecl sa ident Private [] [MkUnguarded ( TypedValue False (Abs (VarBinder ss dictIdent) (Case [Var ss $ Qualified ByNullSourcePos dictIdent] [CaseAlternative [ctor] [MkUnguarded acsr]])) $ - addVisibility visibility (moveQuantifiersToFront (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty))) + addVisibility visibility (moveQuantifiersToFront NullSourceAnn (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty))) )] typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" @@ -333,7 +333,7 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = M.lookup (qualify mn className) m -- Replace the type arguments with the appropriate types in the member types - let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers + let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) . tuple3To2) typeClassMembers let declaredMembers = S.fromList $ mapMaybe declIdent decls @@ -386,3 +386,6 @@ superClassDictionaryNames supers = [ superclassName pn index | (index, Constraint _ pn _ _ _) <- zip [0..] supers ] + +tuple3To2 :: (a, b, c) -> (a, b) +tuple3To2 (a, b, _) = (a, b) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 3030750db2..479a01f012 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -18,7 +18,7 @@ import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Writer.Class (MonadWriter, tell) import Data.Foldable (for_, traverse_, toList) -import Data.List (nub, nubBy, (\\), sort, group) +import Data.List (nubBy, (\\), sort, group) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Either (partitionEithers) import Data.Text (Text) @@ -45,7 +45,7 @@ import Language.PureScript.TypeChecker.Synonyms as T import Language.PureScript.TypeChecker.Types as T import Language.PureScript.TypeChecker.Unify (varIfUnknown) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) -import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), containsForAll, eqType, everythingOnTypes, freeTypeVariables, overConstraintArgs, srcInstanceType, unapplyTypes) +import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), containsForAll, eqType, everythingOnTypes, overConstraintArgs, srcInstanceType, unapplyTypes) addDataType :: (MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) @@ -161,7 +161,6 @@ addTypeClass _ qualifiedClassName args implies dependencies ds kind = do hasSig = qualName `M.member` types env unless (hasSig || not (containsForAll kind)) $ do tell . errorMessage $ MissingKindDeclaration ClassSig (disqualify qualName) kind - traverse_ (checkMemberIsUsable newClass (typeSynonyms env) (types env)) classMembers putEnv $ env { types = M.insert qualName (kind, ExternData (nominalRolesForKind kind)) (types env) , typeClasses = M.insert qualifiedClassName newClass (typeClasses env) } where @@ -179,30 +178,9 @@ addTypeClass _ qualifiedClassName args implies dependencies ds kind = do Just tcd -> tcd Nothing -> internalError "Unknown super class in TypeClassDeclaration" - coveringSets :: TypeClassData -> [S.Set Int] - coveringSets = S.toList . typeClassCoveringSets - - argToIndex :: Text -> Maybe Int - argToIndex = flip M.lookup $ M.fromList (zipWith ((,) . fst) args [0..]) - toPair (TypeDeclaration (TypeDeclarationData _ ident ty)) = (ident, ty) toPair _ = internalError "Invalid declaration in TypeClassDeclaration" - -- Currently we are only checking usability based on the type class currently - -- being defined. If the mentioned arguments don't include a covering set, - -- then we won't be able to find a instance. - checkMemberIsUsable :: TypeClassData -> T.SynonymMap -> T.KindMap -> (Ident, SourceType) -> m () - checkMemberIsUsable newClass syns kinds (ident, memberTy) = do - memberTy' <- T.replaceAllTypeSynonymsM syns kinds memberTy - let mentionedArgIndexes = S.fromList (mapMaybe argToIndex (freeTypeVariables memberTy')) - let leftovers = map (`S.difference` mentionedArgIndexes) (coveringSets newClass) - - unless (any null leftovers) . throwError . errorMessage $ - let - solutions = map (map (fst . (args !!)) . S.toList) leftovers - in - UnusableDeclaration ident (nub solutions) - addTypeClassDictionaries :: (MonadState CheckState m) => QualifiedBy diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 74d70a3aa7..7a3872c1c8 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -11,7 +11,7 @@ module Language.PureScript.TypeChecker.Entailment ) where import Prelude -import Protolude (ordNub) +import Protolude (ordNub, headMay) import Control.Arrow (second, (&&&)) import Control.Monad.Error.Class (MonadError(..)) @@ -22,7 +22,7 @@ import Control.Monad.Writer (Any(..), MonadWriter(..), WriterT(..)) import Data.Either (lefts, partitionEithers) import Data.Foldable (for_, fold, toList) import Data.Function (on) -import Data.Functor (($>)) +import Data.Functor (($>), (<&>)) import Data.List (delete, findIndices, minimumBy, nubBy, sortOn, tails) import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) import Data.Map qualified as M @@ -33,7 +33,8 @@ import Data.Text qualified as T import Data.List.NonEmpty (NonEmpty(..)) import Data.List.NonEmpty qualified as NEL -import Language.PureScript.AST (Binder(..), ErrorMessageHint(..), Expr(..), Literal(..), pattern NullSourceSpan, everywhereOnValuesTopDownM, nullSourceSpan) +import Language.PureScript.AST (Binder(..), ErrorMessageHint(..), Expr(..), Literal(..), pattern NullSourceSpan, everywhereOnValuesTopDownM, nullSourceSpan, everythingOnValues) +import Language.PureScript.AST.Declarations (UnknownsHint(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (Environment(..), FunctionalDependency(..), TypeClassData(..), dictTypeName, kindRow, tyBoolean, tyInt, tyString) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, addHints, errorMessage, rethrow) @@ -250,9 +251,11 @@ entails SolverOptions{..} constraint context hints = env <- lift . lift $ gets checkEnv let classesInScope = typeClasses env TypeClassData - { typeClassDependencies + { typeClassArguments + , typeClassDependencies , typeClassIsEmpty , typeClassCoveringSets + , typeClassMembers } <- case M.lookup className' classesInScope of Nothing -> throwError . errorMessage $ UnknownClass className' Just tcd -> pure tcd @@ -276,7 +279,9 @@ entails SolverOptions{..} constraint context hints = else Left (Left (tcdToInstanceDescription tcd)) -- can't continue with this chain yet, need proof of apartness lefts [found] - solution <- lift . lift $ unique kinds'' tys'' ambiguous instances (unknownsInAllCoveringSets tys'' typeClassCoveringSets) + solution <- lift . lift + $ unique kinds'' tys'' ambiguous instances + $ unknownsInAllCoveringSets (fst . (typeClassArguments !!)) typeClassMembers tys'' typeClassCoveringSets case solution of Solved substs tcd -> do -- Note that we solved something. @@ -354,7 +359,7 @@ entails SolverOptions{..} constraint context hints = (substituteType currentSubst . replaceAllTypeVars (M.toList subst) $ instKind) (substituteType currentSubst tyKind) - unique :: [SourceType] -> [SourceType] -> [Qualified (Either SourceType Ident)] -> [(a, TypeClassDict)] -> Bool -> m (EntailsResult a) + unique :: [SourceType] -> [SourceType] -> [Qualified (Either SourceType Ident)] -> [(a, TypeClassDict)] -> UnknownsHint -> m (EntailsResult a) unique kindArgs tyArgs ambiguous [] unks | solverDeferErrors = return Deferred -- We need a special case for nullary type classes, since we want @@ -421,9 +426,42 @@ entails SolverOptions{..} constraint context hints = let fields = [ ("reflectType", Abs (VarBinder nullSourceSpan UnusedIdent) (asExpression ref)) ] in pure $ App (Constructor nullSourceSpan (coerceProperName . dictTypeName <$> C.Reflectable)) (Literal nullSourceSpan (ObjectLiteral fields)) - unknownsInAllCoveringSets :: [SourceType] -> S.Set (S.Set Int) -> Bool - unknownsInAllCoveringSets tyArgs = all (\s -> any (`S.member` s) unkIndices) - where unkIndices = findIndices containsUnknowns tyArgs + unknownsInAllCoveringSets :: (Int -> Text) -> [(Ident, SourceType, Maybe (S.Set (NEL.NonEmpty Int)))] -> [SourceType] -> S.Set (S.Set Int) -> UnknownsHint + unknownsInAllCoveringSets indexToArgText tyClassMembers tyArgs coveringSets = do + let unkIndices = findIndices containsUnknowns tyArgs + if all (\s -> any (`S.member` s) unkIndices) coveringSets then + fromMaybe Unknowns unknownsRequiringVtas + else + NoUnknowns + where + unknownsRequiringVtas = do + tyClassModuleName <- getQual className' + let + tyClassMemberVta :: M.Map (Qualified Ident) [[Text]] + tyClassMemberVta = M.fromList $ mapMaybe qualifyAndFilter tyClassMembers + where + -- Only keep type class members that need VTAs to resolve their type class instances + qualifyAndFilter (ident, _, mbVtaRequiredArgs) = mbVtaRequiredArgs <&> \vtaRequiredArgs -> + (Qualified (ByModuleName tyClassModuleName) ident, map (map indexToArgText . NEL.toList) $ S.toList vtaRequiredArgs) + + tyClassMembersInExpr :: Expr -> [(Qualified Ident, [[Text]])] + tyClassMembersInExpr = getVars + where + (_, getVars, _, _, _) = everythingOnValues (++) ignore getVarIdents ignore ignore ignore + ignore = const [] + getVarIdents = \case + Var _ ident | Just vtas <- M.lookup ident tyClassMemberVta -> + [(ident, vtas)] + _ -> + [] + + getECTExpr = \case + ErrorCheckingType expr _ -> Just expr + _ -> Nothing + + tyClassMembers' <- headMay $ mapMaybe (fmap tyClassMembersInExpr . getECTExpr) hints + membersWithVtas <- NEL.nonEmpty tyClassMembers' + pure $ UnknownsWithVtaRequiringArgs membersWithVtas -- Turn a DictionaryValue into a Expr subclassDictionaryValue :: Expr -> Qualified (ProperName 'ClassName) -> Integer -> Expr diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index c8abb597c8..8abaac31ca 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -37,7 +37,7 @@ import Data.Set qualified as S import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), TypeKind(..), unapplyKinds) -import Language.PureScript.Errors (DeclarationRef(..), ErrorMessageHint(..), ExportSource, ImportDeclarationType(..), MultipleErrors, SimpleErrorMessage(..), SourceAnn, errorMessage) +import Language.PureScript.Errors (DeclarationRef(..), ErrorMessageHint(..), ExportSource, ImportDeclarationType(..), MultipleErrors, SimpleErrorMessage(..), SourceAnn, errorMessage, UnknownsHint(..)) import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), byMaybeModuleName, toMaybeModuleName) import Language.PureScript.TypeChecker.Kinds (elaborateKind, freshKindWithKind, unifyKinds') import Language.PureScript.TypeChecker.Monad (CheckState(..)) @@ -531,7 +531,8 @@ insoluble k a b = -- "Consider adding a type annotation" hint, because annotating kinds to -- instantiate unknowns in Coercible constraints should never resolve -- NoInstanceFound errors. - errorMessage $ NoInstanceFound (srcConstraint Prim.Coercible [k] [a, b] Nothing) [] (any containsUnknowns [a, b]) + errorMessage $ NoInstanceFound (srcConstraint Prim.Coercible [k] [a, b] Nothing) [] + $ if any containsUnknowns [a, b] then Unknowns else NoUnknowns -- | Constraints of the form @Coercible a b@ can be solved if the two arguments -- are the same. Since we currently don't support higher-rank arguments in diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index dc7b0522d4..567ae415ef 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -7,7 +7,6 @@ module Language.PureScript.TypeChecker.Synonyms ( SynonymMap , KindMap , replaceAllTypeSynonyms - , replaceAllTypeSynonymsM ) where import Prelude @@ -61,12 +60,3 @@ replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadErr replaceAllTypeSynonyms d = do env <- getEnv either throwError return $ replaceAllTypeSynonyms' (typeSynonyms env) (types env) d - --- | Replace fully applied type synonyms by explicitly providing a 'SynonymMap'. -replaceAllTypeSynonymsM - :: MonadError MultipleErrors m - => SynonymMap - -> KindMap - -> SourceType - -> m SourceType -replaceAllTypeSynonymsM syns kinds = either throwError pure . replaceAllTypeSynonyms' syns kinds diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index ad5e207882..ef00e21a07 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -4,7 +4,7 @@ module Language.PureScript.Types where import Prelude -import Protolude (ordNub) +import Protolude (ordNub, fromMaybe) import Codec.Serialise (Serialise) import Control.Applicative ((<|>)) @@ -18,7 +18,7 @@ import Data.Aeson.Types qualified as A import Data.Foldable (fold, foldl') import Data.IntSet qualified as IS import Data.List (sortOn) -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (isJust) import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) @@ -530,7 +530,7 @@ replaceAllTypeVars = go [] where go bs m (ForAll ann vis v mbK t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) $ ForAll ann vis v mbK' t sco | v `elem` usedVars = - let v' = genName v (keys ++ bs ++ usedVars) + let v' = genPureName v (keys ++ bs ++ usedVars) t' = go bs [(v, TypeVar ann v')] t in ForAll ann vis v' mbK' (go (v' : bs) m t') sco | otherwise = ForAll ann vis v mbK' (go (v : bs) m t) sco @@ -545,10 +545,12 @@ replaceAllTypeVars = go [] where go bs m (ParensInType ann t) = ParensInType ann (go bs m t) go _ _ ty = ty - genName orig inUse = try' 0 where - try' :: Integer -> Text - try' n | (orig <> T.pack (show n)) `elem` inUse = try' (n + 1) - | otherwise = orig <> T.pack (show n) +genPureName :: Text -> [Text] -> Text +genPureName orig inUse = try' 0 + where + try' :: Integer -> Text + try' n | (orig <> T.pack (show n)) `elem` inUse = try' (n + 1) + | otherwise = orig <> T.pack (show n) -- | Add visible type abstractions to top-level foralls. addVisibility :: [(Text, TypeVarVisibility)] -> Type a -> Type a @@ -597,11 +599,24 @@ quantify :: Type a -> Type a quantify ty = foldr (\arg t -> ForAll (getAnnForType ty) TypeVarInvisible arg Nothing t Nothing) ty $ freeTypeVariables ty -- | Move all universal quantifiers to the front of a type -moveQuantifiersToFront :: Type a -> Type a -moveQuantifiersToFront = go [] [] where - go qs cs (ForAll ann vis q mbK ty sco) = go ((ann, q, sco, mbK, vis) : qs) cs ty - go qs cs (ConstrainedType ann c ty) = go qs ((ann, c) : cs) ty - go qs cs ty = foldl (\ty' (ann, q, sco, mbK, vis) -> ForAll ann vis q mbK ty' sco) (foldl (\ty' (ann, c) -> ConstrainedType ann c ty') ty cs) qs +moveQuantifiersToFront :: a -> Type a -> Type a +moveQuantifiersToFront syntheticAnn = go [] [] + where + go qs cs = \case + ForAll ann vis q mbK ty sco -> do + let + cArgs :: [Text] = cs >>= constraintArgs . snd >>= freeTypeVariables + (q'', ty') + | q `elem` cArgs = do + let q' = genPureName q $ cArgs <> freeTypeVariables ty + (q', replaceTypeVars q (TypeVar syntheticAnn q') ty) + | otherwise = + (q, ty) + go ((ann, q'', sco, mbK, vis) : qs) cs ty' + ConstrainedType ann c ty -> + go qs ((ann, c) : cs) ty + ty -> + foldl (\ty' (ann, q, sco, mbK, vis) -> ForAll ann vis q mbK ty' sco) (foldl (\ty' (ann, c) -> ConstrainedType ann c ty') ty cs) qs -- | Check if a type contains `forall` containsForAll :: Type a -> Bool diff --git a/tests/purs/failing/ClassHeadNoVTA1.out b/tests/purs/failing/ClassHeadNoVTA1.out new file mode 100644 index 0000000000..dc5cde2c6d --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA1.out @@ -0,0 +1,25 @@ +Error found: +in module Main +at tests/purs/failing/ClassHeadNoVTA1.purs:8:10 - 8:19 (line 8, column 10 - line 8, column 19) + + No type class instance was found for +   +  Main.Single t0 +   + The instance head contains unknown type variables. + + Note: The following type class members found in the expression require visible type applications to be unambiguous (e.g. tyClassMember @Int). + Main.useSingle + tyNotAppearInBody + +while checking that type forall (t12 :: Type) (@tyNotAppearInBody :: t12). Single @t12 tyNotAppearInBody => Int + is at least as general as type Int +while checking that expression useSingle + has type Int +in value declaration single + +where t0 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ClassHeadNoVTA1.purs b/tests/purs/failing/ClassHeadNoVTA1.purs new file mode 100644 index 0000000000..0c297337b8 --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA1.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +class Single tyNotAppearInBody where + useSingle :: Int + +single :: Int +single = useSingle diff --git a/tests/purs/failing/ClassHeadNoVTA2.out b/tests/purs/failing/ClassHeadNoVTA2.out new file mode 100644 index 0000000000..c0d5fd94c1 --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA2.out @@ -0,0 +1,27 @@ +Error found: +in module Main +at tests/purs/failing/ClassHeadNoVTA2.purs:10:9 - 10:17 (line 10, column 9 - line 10, column 17) + + No type class instance was found for +   +  Main.Multi t0 +  t1 +   + The instance head contains unknown type variables. + + Note: The following type class members found in the expression require visible type applications to be unambiguous (e.g. tyClassMember @Int). + Main.useMulti + tyNotAppearInBody, norThisOne + +while checking that type forall (t20 :: Type) (t21 :: Type) (@tyNotAppearInBody :: t20) (@norThisOne :: t21). Multi @t20 @t21 tyNotAppearInBody norThisOne => Int + is at least as general as type Int +while checking that expression useMulti + has type Int +in value declaration multi + +where t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ClassHeadNoVTA2.purs b/tests/purs/failing/ClassHeadNoVTA2.purs new file mode 100644 index 0000000000..8efba3f771 --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA2.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +import Prelude + +class Multi tyNotAppearInBody norThisOne where + useMulti :: Int + +multi :: Int +multi = useMulti + diff --git a/tests/purs/failing/ClassHeadNoVTA3.out b/tests/purs/failing/ClassHeadNoVTA3.out new file mode 100644 index 0000000000..7e8edd3209 --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA3.out @@ -0,0 +1,28 @@ +Error found: +in module Main +at tests/purs/failing/ClassHeadNoVTA3.purs:8:16 - 8:36 (line 8, column 16 - line 8, column 36) + + No type class instance was found for +   +  Main.MultiMissing Int +  t2  +   + The instance head contains unknown type variables. + + Note: The following type class members found in the expression require visible type applications to be unambiguous (e.g. tyClassMember @Int). + Main.useMultiMissing + tyNotAppearInBody, norThisOne + +while checking that type forall (@norThisOne :: t0). MultiMissing @t1 @t0 Int norThisOne => Int + is at least as general as type Int +while checking that expression useMultiMissing + has type Int +in value declaration multiMissing + +where t1 is an unknown type + t0 is an unknown type + t2 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ClassHeadNoVTA3.purs b/tests/purs/failing/ClassHeadNoVTA3.purs new file mode 100644 index 0000000000..00179dd9b5 --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA3.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +class MultiMissing tyNotAppearInBody norThisOne where + useMultiMissing :: Int + +multiMissing :: Int +multiMissing = useMultiMissing @Int + diff --git a/tests/purs/failing/ClassHeadNoVTA4.out b/tests/purs/failing/ClassHeadNoVTA4.out new file mode 100644 index 0000000000..010993f201 --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA4.out @@ -0,0 +1,27 @@ +Error found: +in module Main +at tests/purs/failing/ClassHeadNoVTA4.purs:8:11 - 8:21 (line 8, column 11 - line 8, column 21) + + No type class instance was found for +   +  Main.MultiFd t0 +  t1 +   + The instance head contains unknown type variables. + + Note: The following type class members found in the expression require visible type applications to be unambiguous (e.g. tyClassMember @Int). + Main.useMultiFd + tyNotAppearInBody + +while checking that type forall (t20 :: Type) (t21 :: Type) (@tyNotAppearInBody :: t20) (@norThisOne :: t21). MultiFd @t20 @t21 tyNotAppearInBody norThisOne => Int + is at least as general as type Int +while checking that expression useMultiFd + has type Int +in value declaration multiFd + +where t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ClassHeadNoVTA4.purs b/tests/purs/failing/ClassHeadNoVTA4.purs new file mode 100644 index 0000000000..f0444af0c6 --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA4.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +class MultiFd tyNotAppearInBody norThisOne | tyNotAppearInBody -> norThisOne where + useMultiFd :: Int + +multiFd :: Int +multiFd = useMultiFd diff --git a/tests/purs/failing/ClassHeadNoVTA5.out b/tests/purs/failing/ClassHeadNoVTA5.out new file mode 100644 index 0000000000..cfe69013dd --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA5.out @@ -0,0 +1,29 @@ +Error found: +in module Main +at tests/purs/failing/ClassHeadNoVTA5.purs:10:15 - 10:29 (line 10, column 15 - line 10, column 29) + + No type class instance was found for +   +  Main.MultiFdBidi t0 +  t1 +   + The instance head contains unknown type variables. + + Note: The following type class members found in the expression require visible type applications to be unambiguous (e.g. tyClassMember @Int). + Main.useMultiFdBidi + One of the following sets of type variables: + tyNotAppearInBody + norThisOne + +while checking that type forall (t20 :: Type) (t21 :: Type) (@tyNotAppearInBody :: t20) (@norThisOne :: t21). MultiFdBidi @t20 @t21 tyNotAppearInBody norThisOne => Int + is at least as general as type Int +while checking that expression useMultiFdBidi + has type Int +in value declaration multiFdBidi + +where t0 is an unknown type + t1 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ClassHeadNoVTA5.purs b/tests/purs/failing/ClassHeadNoVTA5.purs new file mode 100644 index 0000000000..421b2c8590 --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA5.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +-- Verify that args in output match order defined here: +-- `tyNotAppearInBody` appears before `norThisOne` +class MultiFdBidi tyNotAppearInBody norThisOne | tyNotAppearInBody -> norThisOne, norThisOne -> tyNotAppearInBody where + useMultiFdBidi :: Int + +multiFdBidi :: Int +multiFdBidi = useMultiFdBidi diff --git a/tests/purs/failing/ClassHeadNoVTA6a.out b/tests/purs/failing/ClassHeadNoVTA6a.out new file mode 100644 index 0000000000..9827276902 --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA6a.out @@ -0,0 +1,37 @@ +Error found: +in module Main +at tests/purs/failing/ClassHeadNoVTA6a.purs:12:15 - 12:25 (line 12, column 15 - line 12, column 25) + + No type class instance was found for +   +  Main.MultiCoveringSets t0 +  t1 +  t2 +  t3 +  t4 +  t5 +   + The instance head contains unknown type variables. + + Note: The following type class members found in the expression require visible type applications to be unambiguous (e.g. tyClassMember @Int). + Main.noneOfSets + One of the following sets of type variables: + a, b + e, f + +while checking that type forall (t82 :: Type) (t83 :: Type) (@a :: Type) (@b :: t82) (@c :: Type) (@d :: Type) (@e :: t83) (@f :: Type). MultiCoveringSets @t82 @t83 a b c d e f => Int + is at least as general as type Int +while checking that expression noneOfSets + has type Int +in value declaration noneOfSets' + +where t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + t3 is an unknown type + t4 is an unknown type + t5 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ClassHeadNoVTA6a.purs b/tests/purs/failing/ClassHeadNoVTA6a.purs new file mode 100644 index 0000000000..b3aef76875 --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA6a.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +class MultiCoveringSets a b c d e f | a b -> c d e f, f e -> a b c d where + noneOfSets :: Int + + partialOfABSet :: a -> { c :: c, d :: d } + + partialOfFESet :: f -> { c :: c, d :: d } + +noneOfSets' :: Int +noneOfSets' = noneOfSets diff --git a/tests/purs/failing/ClassHeadNoVTA6b.out b/tests/purs/failing/ClassHeadNoVTA6b.out new file mode 100644 index 0000000000..ea4034dc77 --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA6b.out @@ -0,0 +1,50 @@ +Error found: +in module Main +at tests/purs/failing/ClassHeadNoVTA6b.purs:16:19 - 16:33 (line 16, column 19 - line 16, column 33) + + No type class instance was found for +   +  Main.MultiCoveringSets a0 +  t3 +  c1 +  d2 +  t4 +  t5 +   + The instance head contains unknown type variables. + + Note: The following type class members found in the expression require visible type applications to be unambiguous (e.g. tyClassMember @Int). + Main.partialOfABSet + One of the following sets of type variables: + b + e, f + +while checking that type forall (t70 :: Type) (t71 :: Type) (@a :: Type) (@b :: t70) (@c :: Type) (@d :: Type) (@e :: t71) (@f :: Type). +  MultiCoveringSets @t70 @t71 a b c d e f => a  +  -> { c :: c  +  , d :: d  +  }  + is at least as general as type a0  + -> { c :: c1 +  , d :: d2 +  }  +while checking that expression partialOfABSet + has type a0  + -> { c :: c1 +  , d :: d2 +  }  +in value declaration partialOfABSet' + +where a0 is a rigid type variable + bound at (line 16, column 19 - line 16, column 33) + c1 is a rigid type variable + bound at (line 16, column 19 - line 16, column 33) + d2 is a rigid type variable + bound at (line 16, column 19 - line 16, column 33) + t3 is an unknown type + t4 is an unknown type + t5 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ClassHeadNoVTA6b.purs b/tests/purs/failing/ClassHeadNoVTA6b.purs new file mode 100644 index 0000000000..3da5823d0d --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA6b.purs @@ -0,0 +1,16 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +class MultiCoveringSets a b c d e f | a b -> c d e f, f e -> a b c d where + noneOfSets :: Int + + partialOfABSet :: a -> { c :: c, d :: d } + + partialOfFESet :: f -> { c :: c, d :: d } + +partialOfABSet' + :: forall a b c d e f + . MultiCoveringSets a b c d e f + => a + -> { c :: c, d :: d } +partialOfABSet' = partialOfABSet diff --git a/tests/purs/failing/ClassHeadNoVTA6c.out b/tests/purs/failing/ClassHeadNoVTA6c.out new file mode 100644 index 0000000000..b8e3d95daf --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA6c.out @@ -0,0 +1,50 @@ +Error found: +in module Main +at tests/purs/failing/ClassHeadNoVTA6c.purs:16:19 - 16:33 (line 16, column 19 - line 16, column 33) + + No type class instance was found for +   +  Main.MultiCoveringSets t3 +  t4 +  c1 +  d2 +  t5 +  f0 +   + The instance head contains unknown type variables. + + Note: The following type class members found in the expression require visible type applications to be unambiguous (e.g. tyClassMember @Int). + Main.partialOfFESet + One of the following sets of type variables: + a, b + e + +while checking that type forall (t58 :: Type) (t59 :: Type) (@a :: Type) (@b :: t58) (@c :: Type) (@d :: Type) (@e :: t59) (@f :: Type). +  MultiCoveringSets @t58 @t59 a b c d e f => f  +  -> { c :: c  +  , d :: d  +  }  + is at least as general as type f0  + -> { c :: c1 +  , d :: d2 +  }  +while checking that expression partialOfFESet + has type f0  + -> { c :: c1 +  , d :: d2 +  }  +in value declaration partialOfFESet' + +where c1 is a rigid type variable + bound at (line 16, column 19 - line 16, column 33) + d2 is a rigid type variable + bound at (line 16, column 19 - line 16, column 33) + f0 is a rigid type variable + bound at (line 16, column 19 - line 16, column 33) + t3 is an unknown type + t4 is an unknown type + t5 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ClassHeadNoVTA6c.purs b/tests/purs/failing/ClassHeadNoVTA6c.purs new file mode 100644 index 0000000000..9d6710d26f --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA6c.purs @@ -0,0 +1,16 @@ +-- @shouldFailWith NoInstanceFound +module Main where + +class MultiCoveringSets a b c d e f | a b -> c d e f, f e -> a b c d where + noneOfSets :: Int + + partialOfABSet :: a -> { c :: c, d :: d } + + partialOfFESet :: f -> { c :: c, d :: d } + +partialOfFESet' + :: forall a b c d e f + . MultiCoveringSets a b c d e f + => f + -> { c :: c, d :: d } +partialOfFESet' = partialOfFESet diff --git a/tests/purs/failing/ClassHeadNoVTA7.out b/tests/purs/failing/ClassHeadNoVTA7.out new file mode 100644 index 0000000000..b44c3e8f44 --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA7.out @@ -0,0 +1,25 @@ +Error found: +in module ClassHeadNoVTA7 +at tests/purs/failing/ClassHeadNoVTA7.purs:12:8 - 12:26 (line 12, column 8 - line 12, column 26) + + No type class instance was found for +   +  ClassHeadNoVTA7.TestClass t1 +  t2 +   + The instance head contains unknown type variables. Consider adding a type annotation. + +while applying a function testMethod + of type TestClass @t0 t1 t2 => Maybe t1 -> Int + to argument Nothing +while checking that expression testMethod Nothing + has type Int +in value declaration test + +where t0 is an unknown type + t1 is an unknown type + t2 is an unknown type + +See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ClassHeadNoVTA7.purs b/tests/purs/failing/ClassHeadNoVTA7.purs new file mode 100644 index 0000000000..d492ce722d --- /dev/null +++ b/tests/purs/failing/ClassHeadNoVTA7.purs @@ -0,0 +1,12 @@ +-- @shouldFailWith NoInstanceFound +module ClassHeadNoVTA7 where + +import Prelude + +import Data.Maybe (Maybe(..)) + +class TestClass a b | a -> b, b -> a where + testMethod :: Maybe a -> Int + +test :: Int +test = testMethod Nothing diff --git a/tests/purs/failing/TypedHole.out b/tests/purs/failing/TypedHole.out index 8cc1bcb38b..f502390e07 100644 --- a/tests/purs/failing/TypedHole.out +++ b/tests/purs/failing/TypedHole.out @@ -7,12 +7,14 @@ at tests/purs/failing/TypedHole.purs:8:8 - 8:13 (line 8, column 8 - line 8, colu  Effect Unit   You could substitute the hole with one of these values: -   -  Data.Monoid.mempty :: forall @m. Monoid m => m  -  Effect.Class.Console.clear :: forall m. MonadEffect m => m Unit -  Effect.Console.clear :: Effect Unit  -  Main.main :: Effect Unit  -   +   +  Data.Monoid.mempty :: forall @m. Monoid m => m  +  Effect.Class.Console.clear :: forall m. MonadEffect m => m Unit +  Effect.Class.Console.groupEnd :: forall m. MonadEffect m => m Unit +  Effect.Console.clear :: Effect Unit  +  Effect.Console.groupEnd :: Effect Unit  +  Main.main :: Effect Unit  +   in value declaration main diff --git a/tests/purs/failing/UnusableTypeClassMethod.out b/tests/purs/failing/UnusableTypeClassMethod.out deleted file mode 100644 index 62924705dd..0000000000 --- a/tests/purs/failing/UnusableTypeClassMethod.out +++ /dev/null @@ -1,12 +0,0 @@ -Error found: -in module Main -at tests/purs/failing/UnusableTypeClassMethod.purs:4:1 - 6:9 (line 4, column 1 - line 6, column 9) - - The declaration c contains arguments that couldn't be determined. - These arguments are: { a } - -in type class declaration for C - -See https://github.com/purescript/documentation/blob/master/errors/UnusableDeclaration.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/UnusableTypeClassMethod.purs b/tests/purs/failing/UnusableTypeClassMethod.purs deleted file mode 100644 index 058f504338..0000000000 --- a/tests/purs/failing/UnusableTypeClassMethod.purs +++ /dev/null @@ -1,7 +0,0 @@ --- @shouldFailWith UnusableDeclaration -module Main where - -class C a b where - -- type doesn't contain `a`, which is also required to determine an instance - c :: b - diff --git a/tests/purs/failing/UnusableTypeClassMethodConflictingIdent.out b/tests/purs/failing/UnusableTypeClassMethodConflictingIdent.out deleted file mode 100644 index f7acded5fc..0000000000 --- a/tests/purs/failing/UnusableTypeClassMethodConflictingIdent.out +++ /dev/null @@ -1,12 +0,0 @@ -Error found: -in module Main -at tests/purs/failing/UnusableTypeClassMethodConflictingIdent.purs:4:1 - 6:19 (line 4, column 1 - line 6, column 19) - - The declaration c contains arguments that couldn't be determined. - These arguments are: { a } - -in type class declaration for C - -See https://github.com/purescript/documentation/blob/master/errors/UnusableDeclaration.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/UnusableTypeClassMethodConflictingIdent.purs b/tests/purs/failing/UnusableTypeClassMethodConflictingIdent.purs deleted file mode 100644 index 08ed602ab8..0000000000 --- a/tests/purs/failing/UnusableTypeClassMethodConflictingIdent.purs +++ /dev/null @@ -1,7 +0,0 @@ --- @shouldFailWith UnusableDeclaration -module Main where - -class C a where - -- type doesn't contain the type class var `a` - c :: forall a. a - diff --git a/tests/purs/failing/UnusableTypeClassMethodSynonym.out b/tests/purs/failing/UnusableTypeClassMethodSynonym.out deleted file mode 100644 index 6adb687c04..0000000000 --- a/tests/purs/failing/UnusableTypeClassMethodSynonym.out +++ /dev/null @@ -1,12 +0,0 @@ -Error found: -in module Main -at tests/purs/failing/UnusableTypeClassMethodSynonym.purs:6:1 - 8:11 (line 6, column 1 - line 8, column 11) - - The declaration c contains arguments that couldn't be determined. - These arguments are: { a } - -in type class declaration for C - -See https://github.com/purescript/documentation/blob/master/errors/UnusableDeclaration.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/UnusableTypeClassMethodSynonym.purs b/tests/purs/failing/UnusableTypeClassMethodSynonym.purs deleted file mode 100644 index aae1e3379c..0000000000 --- a/tests/purs/failing/UnusableTypeClassMethodSynonym.purs +++ /dev/null @@ -1,9 +0,0 @@ --- @shouldFailWith UnusableDeclaration -module Main where - -type M x = forall a. a - -class C a where - -- after synonym expansion, the type doesn't actually contain an `a` - c :: M a - diff --git a/tests/purs/passing/VTAsClassHeads.purs b/tests/purs/passing/VTAsClassHeads.purs new file mode 100644 index 0000000000..a25d7c4564 --- /dev/null +++ b/tests/purs/passing/VTAsClassHeads.purs @@ -0,0 +1,196 @@ +module Main where + +import Prelude +import Data.Array as Array +import Data.Array.NonEmpty as NEA +import Data.Maybe (Maybe(..)) +import Data.Either (Either(..), either) +import Data.Foldable (traverse_) +import Data.Traversable (sequence) +import Effect (Effect) +import Effect.Console (log) + +class Singleton x where + singleton :: String + +instance Singleton Int where + singleton = "int" + +instance Singleton String where + singleton = "string" + +singletonWorks :: Effect (Maybe String) +singletonWorks = do + let + left = singleton @Int + right = singleton @String + pure if left /= right then Nothing else Just "Singleton failed" + +class ConflictingIdent :: Type -> Constraint +class ConflictingIdent a where + -- The `a` in the type below should refer to the `a` + -- introduced by the `forall`, not the class head. + conflictingIdent :: forall a. a -> Int + +instance ConflictingIdent String where + conflictingIdent _ = 1 + +instance ConflictingIdent Int where + conflictingIdent _ = 2 + +conflictingIdentWorks :: Effect (Maybe String) +conflictingIdentWorks = do + pure if (1 == conflictingIdent @String 4) then Nothing else Just "ConflictingIdent failed" + +type M :: Type -> Type +type M x = forall a. a -> Int + +class ConflictingIdentSynonym :: Type -> Constraint +class ConflictingIdentSynonym a where + -- The `a` in the type below should refer to the `a` + -- introduced by the `forall`, not the class head. + conflictingIdentSynonym :: M a + +instance ConflictingIdentSynonym String where + conflictingIdentSynonym _ = 1 + +instance ConflictingIdentSynonym Int where + conflictingIdentSynonym _ = 2 + +conflictingIdentSynonymWorks :: Effect (Maybe String) +conflictingIdentSynonymWorks = do + pure if (1 == conflictingIdentSynonym @String 4) then Nothing else Just "ConflictingIdentSynonym failed" + +class MultiNoFDs a b where + multiNoFds :: Int + +instance MultiNoFDs Int Int where + multiNoFds = 0 + +instance MultiNoFDs String Int where + multiNoFds = 1 + +multiNoFdsWorks :: Effect (Maybe String) +multiNoFdsWorks = do + let + left = multiNoFds @Int @Int + right = multiNoFds @String @Int + pure if left /= right then Nothing else Just "MultiNoFDs failed" + +class MultiWithFDs a b | a -> b where + multiWithFDs :: Int + +instance MultiWithFDs Int Int where + multiWithFDs = 0 + +instance MultiWithFDs String Int where + multiWithFDs = 1 + +multiWithFdsWorks :: Effect (Maybe String) +multiWithFdsWorks = do + let + left = multiWithFDs @Int + right = multiWithFDs @String + pure if left /= right then Nothing else Just "MultiWithFds failed" + +class MultiWithBidiFDs a b | a -> b, b -> a where + multiWithBidiFDs :: Int + +instance MultiWithBidiFDs Int Int where + multiWithBidiFDs = 0 + +instance MultiWithBidiFDs String String where + multiWithBidiFDs = 1 + +multiWithBidiFDsLeftWorks :: Effect (Maybe String) +multiWithBidiFDsLeftWorks = do + let + left = multiWithBidiFDs @Int + right = multiWithBidiFDs @String + pure if left /= right then Nothing else Just "MultiWithFds failed" + +multiWithBidiFDsRightWorks :: Effect (Maybe String) +multiWithBidiFDsRightWorks = do + let + left = multiWithBidiFDs @_ @Int + right = multiWithBidiFDs @_ @String + pure if left /= right then Nothing else Just "MultiWithFds failed" + +class Superclass a where + superClassValue :: a + +class Superclass a <= MainClass a where + mainClassInt :: Int + +data A2 = A2 + +derive instance Eq A2 + +instance Superclass A2 where + superClassValue = A2 + +instance MainClass A2 where + mainClassInt = 0 + +data B2 = B2 + +derive instance Eq B2 + +instance Superclass B2 where + superClassValue = B2 + +instance MainClass B2 where + mainClassInt = 3 + +mainClassWorks :: Effect (Maybe String) +mainClassWorks = do + let + test1 = 0 == mainClassInt @A2 + test2 = A2 == superClassValue @A2 + pure if test1 && test2 then Nothing else Just "MainClass failed" + +class MultiCoveringSets a b c d e f | a b -> c d e f, f e -> a b c d where + noneOfSets :: Int + + partialOfABSet :: a -> { c :: c, d :: d } + + partialOfFESet :: f -> { c :: c, d :: d } + +instance MultiCoveringSets Boolean Boolean String String Int Int where + noneOfSets = 1 + partialOfABSet a = { c: if a then "101" else "100", d: "1" } + partialOfFESet f = { c: show f, d: "1" } + +instance MultiCoveringSets Int Int String String Boolean Boolean where + noneOfSets = 2 + partialOfABSet a = { c: show a, d: "2" } + partialOfFESet f = { c: show f, d: "2" } + +multiCoveringSetsWorks :: Effect (Maybe String) +multiCoveringSetsWorks = do + let + test1a = 1 == noneOfSets @Boolean @Boolean + test1b = "101" == (partialOfABSet @Boolean @Boolean true).c + test1c = show 3 == (partialOfFESet @_ @_ @_ @_ @Int @Int 3).c + test2a = 2 == noneOfSets @_ @_ @_ @_ @Boolean @Boolean + test2b = show 20 == (partialOfABSet @_ @_ @_ @_ @Boolean @Boolean 20).c + test2c = show false == (partialOfFESet @_ @_ @_ @_ @Boolean @Boolean false).c + passes = test1a && test1b && test1c && test2a && test2b && test2c + pure if passes then Nothing else Just "MultiCoveringSets failed" + +main = do + arr' <- sequence + [ singletonWorks + , conflictingIdentWorks + , conflictingIdentSynonymWorks + , multiNoFdsWorks + , multiWithFdsWorks + , multiWithBidiFDsLeftWorks + , multiWithBidiFDsRightWorks + , mainClassWorks + ] + case NEA.fromArray $ Array.catMaybes arr' of + Just errs -> + log $ "Errors..." <> (Array.intercalate "\n" $ NEA.toArray errs) + Nothing -> + log "Done" diff --git a/tests/purs/warning/TypeClassMethodSynonym.out b/tests/purs/warning/TypeClassMethodSynonym.out new file mode 100644 index 0000000000..47bb4c0796 --- /dev/null +++ b/tests/purs/warning/TypeClassMethodSynonym.out @@ -0,0 +1,11 @@ +Warning found: +in module Main +at tests/purs/warning/TypeClassMethodSynonym.purs:8:3 - 8:19 (line 8, column 3 - line 8, column 19) + + Type variable a was shadowed. + +in type declaration for c + +See https://github.com/purescript/documentation/blob/master/errors/ShadowedTypeVar.md for more information, +or to contribute content related to this warning. + diff --git a/tests/purs/warning/TypeClassMethodSynonym.purs b/tests/purs/warning/TypeClassMethodSynonym.purs new file mode 100644 index 0000000000..d290524ecc --- /dev/null +++ b/tests/purs/warning/TypeClassMethodSynonym.purs @@ -0,0 +1,8 @@ +-- @shouldWarnWith ShadowedTypeVar +module Main where + +class C :: Type -> Constraint +class C a where + -- The `a` in the type below should refer to the `a` + -- introduced by the `forall`, not the class head. + c :: forall a. a From 6b49918b9646863e73bbedd1d47f474ba3783408 Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Fri, 3 Nov 2023 22:29:17 -0400 Subject: [PATCH 1558/1580] Drop container ID from CI cache key, use image (#4516) --- .github/workflows/ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 07a3155e80..d88257ed07 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -116,7 +116,7 @@ jobs: path: | /root/.stack ${{ steps.haskell.outputs.stack-root }} - key: "${{ runner.os }}-${{ job.container.id }}-MdyPsf-${{ hashFiles('stack.yaml') }}" + key: "${{ matrix.image || runner.os }}--MdyPsf-${{ hashFiles('stack.yaml') }}" - name: "(Windows only) Configure Stack to store its programs in STACK_ROOT" # This ensures that the local GHC and MSYS binaries that Stack installs @@ -242,7 +242,7 @@ jobs: with: path: | /root/.stack - key: "${{ runner.os }}-${{ job.container.id }}-UnWw0N-lint-${{ hashFiles('stack.yaml') }}" + key: "lint-${{ hashFiles('stack.yaml') }}" - run: "ci/fix-home ci/run-hlint.sh --git" env: From a6feba021f6513b3f2dedc3b20384f6c23ec739a Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Mon, 20 Nov 2023 11:19:20 -0600 Subject: [PATCH 1559/1580] Prep 0.15.13 (#4520) * Update versions * Regenerate changelog --- .../feature_replace-unused-declarations.md | 71 ----------------- CHANGELOG.md | 76 +++++++++++++++++++ npm-package/package.json | 4 +- purescript.cabal | 2 +- 4 files changed, 79 insertions(+), 74 deletions(-) delete mode 100644 CHANGELOG.d/feature_replace-unused-declarations.md diff --git a/CHANGELOG.d/feature_replace-unused-declarations.md b/CHANGELOG.d/feature_replace-unused-declarations.md deleted file mode 100644 index 4bc3b11273..0000000000 --- a/CHANGELOG.d/feature_replace-unused-declarations.md +++ /dev/null @@ -1,71 +0,0 @@ -* Replace `UnusableDeclaration` with updated `NoInstanceFound` - - Previously, the following type class would be invalid - because there was no way for the compiler to infer - which type class instance to select because - the type variable in the class head `a` was - not mentioned in `bar`'s type signature: - - ```purs - class Foo a where - bar :: Int - ``` - - The recently-added visible type applications (VTAs) - can now be used to guide the compiler in such cases: - - ```purs - class Foo a where bar :: Int - instance Foo String where bar = 0 - someInt = bar @String -- use the `String` instance - ``` - - Without VTAs, the compiler - will still produce an `InstanceNotFound` error, but this error - has been updated to note which type variables in the class head - can only be disambiguated via visible type applications. - Given the following code - - ```purs - class Single tyVarDoesNotAppearInBody where - useSingle :: Int - - single :: Int - single = useSingle - ``` - - The error reported for `useSingle` will be: - - ``` - No type class instance was found for - - Main.Single t0 - - The instance head contains unknown type variables. - - - Note: The following type class members found in the expression require visible type applications - to be unambiguous (e.g. tyClassMember @Int). - Main.useSingle - tyNotAppearInBody - ``` - - For a multiparameter typeclass with functional dependencies... - - ```purs - class MultiFdBidi a b | a -> b, b -> a where - useMultiFdBidi :: Int - - multiFdBidi :: Int - multiFdBidi = useMultiFdBidi - ``` - - ...the "Note" part is updated to read - ``` - Note: The following type class members found in the expression require visible type applications - to be unambiguous (e.g. tyClassMember @Int). - Main.useMultiFdBidi - One of the following sets of type variables: - a - b - ``` diff --git a/CHANGELOG.md b/CHANGELOG.md index 67eae177e8..d8052d14cf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,82 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.13 + +New features: + +* Replace `UnusableDeclaration` with updated `NoInstanceFound` (#4513 by @JordanMartinez) + + Previously, the following type class would be invalid + because there was no way for the compiler to infer + which type class instance to select because + the type variable in the class head `a` was + not mentioned in `bar`'s type signature: + + ```purs + class Foo a where + bar :: Int + ``` + + The recently-added visible type applications (VTAs) + can now be used to guide the compiler in such cases: + + ```purs + class Foo a where bar :: Int + instance Foo String where bar = 0 + someInt = bar @String -- use the `String` instance + ``` + + Without VTAs, the compiler + will still produce an `InstanceNotFound` error, but this error + has been updated to note which type variables in the class head + can only be disambiguated via visible type applications. + Given the following code + + ```purs + class Single tyVarDoesNotAppearInBody where + useSingle :: Int + + single :: Int + single = useSingle + ``` + + The error reported for `useSingle` will be: + + ``` + No type class instance was found for + + Main.Single t0 + + The instance head contains unknown type variables. + + + Note: The following type class members found in the expression require visible type applications + to be unambiguous (e.g. tyClassMember @Int). + Main.useSingle + tyNotAppearInBody + ``` + + For a multiparameter typeclass with functional dependencies... + + ```purs + class MultiFdBidi a b | a -> b, b -> a where + useMultiFdBidi :: Int + + multiFdBidi :: Int + multiFdBidi = useMultiFdBidi + ``` + + ...the "Note" part is updated to read + ``` + Note: The following type class members found in the expression require visible type applications + to be unambiguous (e.g. tyClassMember @Int). + Main.useMultiFdBidi + One of the following sets of type variables: + a + b + ``` + ## 0.15.12 New features: diff --git a/npm-package/package.json b/npm-package/package.json index 9ab1997120..b24866695b 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.12", + "version": "0.15.13", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.12", + "postinstall": "install-purescript --purs-ver=0.15.13", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index bd1595adec..a608c61cac 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.12 +version: 0.15.13 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From a915253de357239e62265953f364460bf22d0328 Mon Sep 17 00:00:00 2001 From: Matt Russell Date: Fri, 24 Nov 2023 03:04:57 -0800 Subject: [PATCH 1560/1580] Uses strict Map to fix a compile time regression (#4521) For extremely large files (14K lines) with a lot of types and instances memory increases dramatically using Lazy Maps, causing swapping and an big increase in compilation time. Switching to a strict map brings compilation performance close to 15.2 levels. Fixes #4491 --- CHANGELOG.d/fix_compilation_regression-4491.md | 8 ++++++++ CONTRIBUTORS.md | 1 + src/Language/PureScript/CoreFn/CSE.hs | 4 ++-- 3 files changed, 11 insertions(+), 2 deletions(-) create mode 100644 CHANGELOG.d/fix_compilation_regression-4491.md diff --git a/CHANGELOG.d/fix_compilation_regression-4491.md b/CHANGELOG.d/fix_compilation_regression-4491.md new file mode 100644 index 0000000000..a2fbc45f4e --- /dev/null +++ b/CHANGELOG.d/fix_compilation_regression-4491.md @@ -0,0 +1,8 @@ +* Fix a compilation memory regression for very large files + + When compiling a a very large file (>12K lines) + the CSE pass could balloon memory and result in increased + compilation times. + + This fix uses a strict Map instead of a lazy Map to avoid + building up unnecessary thunks during the optimization pass. diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 18d0ad69ac..7213ef9c67 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -102,6 +102,7 @@ If you would prefer to use different terms, please use the section below instead | [@milesfrain](https://github.com/milesfrain) | Miles Frain | [MIT license] | | [@MiracleBlue](https://github.com/MiracleBlue) | Nicholas Kircher | [MIT license] | | [@mjgpy3](https://github.com/mjgpy3) | Michael Gilliland | [MIT license] | +| [@mjrussell](https://github.com/mjrussell) | Matthew Russell | [MIT license] | | [@MonoidMusician](https://github.com/MonoidMusician) | Verity Scheel | [MIT license] | | [@mpietrzak](https://github.com/mpietrzak) | Maciej Pietrzak | [MIT license] | | [@mrhania](https://github.com/mrhania) | Łukasz Hanuszczak | [MIT license] | diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index 576243c252..e3e59bddad 100644 --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -12,7 +12,7 @@ import Data.Bitraversable (bitraverse) import Data.Functor.Compose (Compose(..)) import Data.IntMap.Monoidal qualified as IM import Data.IntSet qualified as IS -import Data.Map qualified as M +import Data.Map.Strict qualified as M import Data.Maybe (fromJust) import Data.Semigroup (Min(..)) import Data.Semigroup.Generic (GenericSemigroupMonoid(..)) @@ -216,7 +216,7 @@ newScope isTopLevel body = local goDeeper $ do if isTopLevel then env{ _depth = depth', _deepestTopLevelScope = depth' } else env{ _depth = depth' } - where + where depth' = succ _depth -- | From bff8c575ab7edd669b3d2002e03ee8c5b3ae6967 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Thu, 14 Dec 2023 09:48:36 -0600 Subject: [PATCH 1561/1580] Fix ty var parsing on class head (#4523) * Fix ty var parsing on class head --- CHANGELOG.d/fix_fix-class-head-ty-var.md | 1 + src/Language/PureScript/CST/Parser.y | 2 +- tests/purs/failing/4522.out | 10 ++++++++++ tests/purs/failing/4522.purs | 4 ++++ 4 files changed, 16 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/fix_fix-class-head-ty-var.md create mode 100644 tests/purs/failing/4522.out create mode 100644 tests/purs/failing/4522.purs diff --git a/CHANGELOG.d/fix_fix-class-head-ty-var.md b/CHANGELOG.d/fix_fix-class-head-ty-var.md new file mode 100644 index 0000000000..12a3f8ab11 --- /dev/null +++ b/CHANGELOG.d/fix_fix-class-head-ty-var.md @@ -0,0 +1 @@ +* Fix parsing bug where `@var` was allowed in type class head \ No newline at end of file diff --git a/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y index edb60d93ec..55aa95da79 100644 --- a/src/Language/PureScript/CST/Parser.y +++ b/src/Language/PureScript/CST/Parser.y @@ -722,7 +722,7 @@ classSuper :: { (OneOrDelimited (Constraint ()), SourceToken) } : constraints '<=' {%^ revert $ pure ($1, $2) } classNameAndFundeps :: { (Name (N.ProperName 'N.ClassName), [TypeVarBinding ()], Maybe (SourceToken, Separated ClassFundep)) } - : properName manyOrEmpty(typeVarBinding) fundeps {%^ revert $ pure (getProperName $1, $2, $3) } + : properName manyOrEmpty(typeVarBindingPlain) fundeps {%^ revert $ pure (getProperName $1, $2, $3) } fundeps :: { Maybe (SourceToken, Separated ClassFundep) } : {- empty -} { Nothing } diff --git a/tests/purs/failing/4522.out b/tests/purs/failing/4522.out new file mode 100644 index 0000000000..75e072315d --- /dev/null +++ b/tests/purs/failing/4522.out @@ -0,0 +1,10 @@ +Error found: +at tests/purs/failing/4522.purs:4:11 - 4:12 (line 4, column 11 - line 4, column 12) + + Unable to parse module: + Unexpected token '@' + + +See https://github.com/purescript/documentation/blob/master/errors/ErrorParsingModule.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/4522.purs b/tests/purs/failing/4522.purs new file mode 100644 index 0000000000..78fc65f03a --- /dev/null +++ b/tests/purs/failing/4522.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith ErrorParsingModule +module Main where + +class Foo @a \ No newline at end of file From e826bfff901c7b778e1c0457334f980a4ee186fc Mon Sep 17 00:00:00 2001 From: Verity Scheel Date: Tue, 19 Dec 2023 20:04:32 -0600 Subject: [PATCH 1562/1580] Fix space leak between modules during compilation (#4517) * Fix space leak between modules during compilation For builds with a lot of warnings, memory usage grows drastically since it appears that the thunks for the warnings hang onto a lot of memory from compiling the module itself. The goal of this change is to get memory usage for full builds back in line with partial builds. * Limit concurrent builds to getNumCapabilities This ensures that modules are fully built in one pass, to avoid partial builds being interrupted and holding onto memory in the meantime. * Use Data.Map.Strict in CSE * Add script for traces in eventlog * Add changelog entry --- CHANGELOG.d/fix_module-space-leak.md | 11 + debug/eventlog.js | 215 ++++++++++++++++++++ src/Language/PureScript/AST/Binders.hs | 5 +- src/Language/PureScript/AST/Declarations.hs | 48 ++--- src/Language/PureScript/AST/Literals.hs | 5 +- src/Language/PureScript/Bundle.hs | 11 +- src/Language/PureScript/CST/Errors.hs | 9 +- src/Language/PureScript/CST/Layout.hs | 5 +- src/Language/PureScript/CST/Types.hs | 18 +- src/Language/PureScript/Errors.hs | 18 +- src/Language/PureScript/Externs.hs | 14 +- src/Language/PureScript/Make.hs | 49 +++-- src/Language/PureScript/Make/Monad.hs | 4 +- 13 files changed, 342 insertions(+), 70 deletions(-) create mode 100644 CHANGELOG.d/fix_module-space-leak.md create mode 100644 debug/eventlog.js diff --git a/CHANGELOG.d/fix_module-space-leak.md b/CHANGELOG.d/fix_module-space-leak.md new file mode 100644 index 0000000000..2cb86e8562 --- /dev/null +++ b/CHANGELOG.d/fix_module-space-leak.md @@ -0,0 +1,11 @@ +* Fix two space leaks while compiling many modules + + The first would interleave compilation of too many modules at once, which + would increase memory usage, especially for single threaded builds with + `+RTS -N1 -RTS`. Now the number of concurrent modules is limited to + the number of threads available to the + [GHC runtime system](https://downloads.haskell.org/ghc/latest/docs/users_guide/using-concurrent.html#rts-options-for-smp-parallelism). + + The second would hold on to memory from modules that compiled with warnings + until the end of the build when the warnings were printed and the memory freed. + This is now fixed with additional `NFData` instances. diff --git a/debug/eventlog.js b/debug/eventlog.js new file mode 100644 index 0000000000..43aa4f7221 --- /dev/null +++ b/debug/eventlog.js @@ -0,0 +1,215 @@ +// Debug compilation times of modules from eventlog profiling +// +// Build and run purs with profiling enabled: +// cabal build --enable-profiling +// cabal exec -- purs ...... +// Or with stack: +// stack build --profile +// stack --profile exec -- purs ...... +// Run a command like this to generate purs.eventlog: +// purs +RTS -l-agu -i1.5 -hc -RTS compile -g corefn $(spago sources) +// (If you want accurate stats for individual modules, add -N1.) +// Process it with +// eventlog2html --json purs.eventlog +// node eventlog.js purs.eventlog.json +// +// See the GHC docs for descriptions of the RTS flags: +// - https://downloads.haskell.org/ghc/latest/docs/users_guide/profiling.html#rts-options-for-heap-profiling +// - https://downloads.haskell.org/ghc/latest/docs/users_guide/runtime_control.html#rts-eventlog +// - https://downloads.haskell.org/ghc/latest/docs/users_guide/using-concurrent.html?highlight=threaded#rts-options-for-smp-parallelism +var mainFile = process.argv[2]; +if (!mainFile) throw new Error("Provide a file name"); + +var name_length = 0; + +function summarizeEventlog(filename) { + var eventlog = JSON.parse(require("fs").readFileSync(filename, "utf-8")); + // eventlog.heap + // c: Set(3) { 'Heap Size', 'Live Bytes', 'Blocks Size' } + // eventlog.samples + // eventlog.traces + + var traces = {}; + var minTx = Infinity; + var maxTx = -Infinity; + var maxMem = -Infinity; + var total = 0; + var con = []; + var max_cons = [[]]; + var cursor = 0; + + // I guess some buffering makes it out of order? + eventlog.traces.sort(({tx: tx1}, {tx: tx2}) => tx1 - tx2); + + for (let trace of eventlog.traces) { + var m = /^([\w.]+) (start|end)$/.exec(trace.desc); + if (!m) continue; + var name = m[1]; + if (!(name in traces)) traces[name] = {}; + if (name.length > name_length) name_length = name.length; + var ev = m[2]; + + if (traces[name][ev]) { + if (traces[name].time === 0) { + console.log("Warn: start after end", name, traces[name].start, trace.tx); + } else { + console.log("Warn: duplicate event", trace.desc); + } + continue; + } + + var time = trace.tx; + if (time < minTx) minTx = time; + if (time > maxTx) maxTx = time; + + while (cursor < eventlog.heap.length && eventlog.heap[cursor].x < trace.tx) { + cursor++; + if (eventlog.heap[cursor].c !== 'Heap Size') { + cursor = eventlog.heap.length; + } + } + if (ev === "start") { + traces[name].cursor = cursor; + } + + traces[name][ev] = time; + if (ev === "end" && !("start" in traces[name])) { + console.log("Warn: missing start for", name); + traces[name].start = time; + traces[name].time = 0; + continue; + } + if ("start" in traces[name] && "end" in traces[name]) { + traces[name].time = traces[name].end - traces[name].start; + var mems = eventlog.heap.slice(traces[name].cursor, cursor).map(e => e.y); + var mem_min = Math.min(...mems); + var mem_max = Math.max(...mems); + var maxMem = Math.max(maxMem, mem_max); + Object.assign(traces[name], {mem_min,mem_max}); + total += traces[name].time; + } + + if (ev === "start") con = con.concat([name]); + if (ev === "end") { + var l = con.length; + con = con.filter(n => n !== name); + if (con.length !== l - 1) { + console.log(con, name); + } + } + if (con.length >= max_cons[0].length) { + if (con.length > max_cons[0].length) + max_cons = []; + max_cons.push(con); + } + } + + var timespan = maxTx - minTx; + + return { traces, total, minTx, maxTx, timespan, max_cons, maxMem }; +} + +var mainFiles = process.argv.slice(2); + +if (mainFiles.length > 1) { + for (let file of mainFiles) { + console.log(file); + var { traces, total, timespan, max_cons, maxMem } = summarizeEventlog(file); + if (timespan === -Infinity && total === 0 && max_cons[0].length === 0) continue; + var max_con_time = 0; + var concurrencies = max_cons.map(max_con => { + if (max_con.length !== max_cons[0].length) + throw new Error("max_con length error"); + var modules = max_con.map(name => [name, traces[name]]); + var start = Math.max(...modules.map(([name, {start}]) => start)); + var end = Math.min(...modules.map(([name, {end}]) => end)); + var time = end - start; + max_con_time += time; + return { + modules, + start, + end, + time, + }; + }); + console.log("timespan ", timespan); + console.log("ratio (avg concurrency?) ", total/timespan); + console.log("max concurrency ", max_cons[0].length); + console.log("time at max concurrency (%)", 100*max_con_time/timespan); + console.log("peak heap size ", space(maxMem)); + } + process.exit(0); +} + +var { traces, total, timespan, max_cons } = summarizeEventlog(mainFile); + +var timings = []; +for (let name in traces) { + let trace = traces[name]; + if (!("time" in trace)) { + console.log("Warn: missing timing for", name, trace); + } else if (trace.time > 0) { + timings.push([name, trace.time]); + } +} + +timings.sort(([n1,t1,_1,m1], [n2,t2,_2,m2]) => t1 - t2); + +timings.push(["stats", "-----"]); +timings.push(["total", total]); +timings.push(["timespan", timespan]); +timings.push(["ratio (avg concurrency?)", total/timespan]); +var max_con_time = 0; +var concurrencies = max_cons.map(max_con => { + if (max_con.length !== max_cons[0].length) + throw new Error("max_con length error"); + var modules = max_con.map(name => [name, traces[name]]); + var start = Math.max(...modules.map(([name, {start}]) => start)); + var end = Math.min(...modules.map(([name, {end}]) => end)); + var time = end - start; + max_con_time += time; + return { + modules, + start, + end, + time, + }; +}); +timings.push(["max concurrency", max_cons[0].length]); +timings.push(["time at max concurrency (s)", max_con_time]); +timings.push(["time at max concurrency (%)", 100*max_con_time/timespan]); + +for (let [name, time] of timings) { + // console.log(name.padEnd(name_length, " "), (""+time).substring(0, 5).padStart(5, " ")); + console.log(name.padEnd(name_length, " "), time); +} + +//require("fs").writeFileSync("concurrencies.json", JSON.stringify(concurrencies, null, 2), "utf-8"); + + +function space(v) { + if (!isFinite(v)) return "----"; + if (v === Infinity) return "+Inf"; + if (v === -Infinity) return "-Inf"; + if (v !== v) return " NaN"; + var sizes = [ + [1_000_000_000, "G"], + [1_000_000, "M"], + [1_000, "K"], + [0, ""], + ] + for (let [value, suffix] of sizes) { + if (v < value) continue; + if (!suffix) return (""+v).padStart(4, " "); + var adj = v/value; + var str = ""+adj; + if (adj >= 100) return str.substring(0,3)+suffix; + if (adj >= 10) return " "+str.substring(0,2)+suffix; + return str.substring(0,3)+suffix; + } +} +function signed(fmt, v) { + if (!isFinite(v)) return " "+fmt(v); + if (v < 0) return "-"+fmt(-v); + return "+"+fmt(v); +} diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index 6d88ff3d97..1f427755f0 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} -- | -- Case binders -- @@ -5,6 +6,8 @@ module Language.PureScript.AST.Binders where import Prelude +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) import Language.PureScript.AST.SourcePos (SourceSpan) import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.Names (Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified) @@ -61,7 +64,7 @@ data Binder -- A binder with a type annotation -- | TypedBinder SourceType Binder - deriving (Show) + deriving (Show, Generic, NFData) -- Manual Eq and Ord instances for `Binder` were added on 2018-03-05. Comparing -- the `SourceSpan` values embedded in some of the data constructors of `Binder` diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index e6d13c74aa..cf0c83a42d 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -50,7 +50,7 @@ data TypeSearch -- ^ Record fields that are available on the first argument to the typed -- hole } - deriving Show + deriving (Show, Generic, NFData) onTypeSearchTypes :: (SourceType -> SourceType) -> TypeSearch -> TypeSearch onTypeSearchTypes f = runIdentity . onTypeSearchTypesM (Identity . f) @@ -90,7 +90,7 @@ data ErrorMessageHint | MissingConstructorImportForCoercible (Qualified (ProperName 'ConstructorName)) | PositionedError (NEL.NonEmpty SourceSpan) | RelatedPositions (NEL.NonEmpty SourceSpan) - deriving (Show) + deriving (Show, Generic, NFData) -- | Categories of hints data HintCategory @@ -105,14 +105,14 @@ data HintCategory -- | -- In constraint solving, indicates whether there were `TypeUnknown`s that prevented --- an instance from being found, and whether VTAs are required +-- an instance from being found, and whether VTAs are required -- due to type class members not referencing all the type class -- head's type variables. data UnknownsHint = NoUnknowns | Unknowns | UnknownsWithVtaRequiringArgs (NEL.NonEmpty (Qualified Ident, [[Text]])) - deriving (Show) + deriving (Show, Generic, NFData) -- | -- A module declaration, consisting of comments about the module, a module name, @@ -306,7 +306,7 @@ data ImportDeclarationType -- An import with a list of references to hide: `import M hiding (foo)` -- | Hiding [DeclarationRef] - deriving (Eq, Show, Generic, Serialise) + deriving (Eq, Show, Generic, Serialise, NFData) isExplicit :: ImportDeclarationType -> Bool isExplicit (Explicit _) = True @@ -323,7 +323,7 @@ data RoleDeclarationData = RoleDeclarationData { rdeclSourceAnn :: !SourceAnn , rdeclIdent :: !(ProperName 'TypeName) , rdeclRoles :: ![Role] - } deriving (Show, Eq) + } deriving (Show, Eq, Generic, NFData) -- | A type declaration assigns a type to an identifier, eg: -- @@ -334,7 +334,7 @@ data TypeDeclarationData = TypeDeclarationData { tydeclSourceAnn :: !SourceAnn , tydeclIdent :: !Ident , tydeclType :: !SourceType - } deriving (Show, Eq) + } deriving (Show, Eq, Generic, NFData) getTypeDeclaration :: Declaration -> Maybe TypeDeclarationData getTypeDeclaration (TypeDeclaration d) = Just d @@ -356,7 +356,7 @@ data ValueDeclarationData a = ValueDeclarationData -- ^ Whether or not this value is exported/visible , valdeclBinders :: ![Binder] , valdeclExpression :: !a - } deriving (Show, Functor, Foldable, Traversable) + } deriving (Show, Functor, Generic, NFData, Foldable, Traversable) getValueDeclaration :: Declaration -> Maybe (ValueDeclarationData [GuardedExpr]) getValueDeclaration (ValueDeclaration d) = Just d @@ -370,7 +370,7 @@ data DataConstructorDeclaration = DataConstructorDeclaration { dataCtorAnn :: !SourceAnn , dataCtorName :: !(ProperName 'ConstructorName) , dataCtorFields :: ![(Ident, SourceType)] - } deriving (Show, Eq) + } deriving (Show, Eq, Generic, NFData) mapDataCtorFields :: ([(Ident, SourceType)] -> [(Ident, SourceType)]) -> DataConstructorDeclaration -> DataConstructorDeclaration mapDataCtorFields f DataConstructorDeclaration{..} = DataConstructorDeclaration { dataCtorFields = f dataCtorFields, .. } @@ -445,13 +445,13 @@ data Declaration -- declaration, while the second @SourceAnn@ serves as the -- annotation for the type class and its arguments. | TypeInstanceDeclaration SourceAnn SourceAnn ChainId Integer (Either Text Ident) [SourceConstraint] (Qualified (ProperName 'ClassName)) [SourceType] TypeInstanceBody - deriving (Show) + deriving (Show, Generic, NFData) data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName) - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic, NFData) data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName) - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic, NFData) pattern ValueFixityDeclaration :: SourceAnn -> Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration pattern ValueFixityDeclaration sa fixity name op = FixityDeclaration sa (Left (ValueFixity fixity name op)) @@ -462,7 +462,7 @@ pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (T data InstanceDerivationStrategy = KnownClassStrategy | NewtypeStrategy - deriving (Show) + deriving (Show, Generic, NFData) -- | The members of a type class instance declaration data TypeInstanceBody @@ -472,7 +472,7 @@ data TypeInstanceBody -- ^ This is an instance derived from a newtype | ExplicitInstance [Declaration] -- ^ This is a regular (explicit) instance - deriving (Show) + deriving (Show, Generic, NFData) mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f) @@ -488,9 +488,7 @@ data KindSignatureFor | NewtypeSig | TypeSynonymSig | ClassSig - deriving (Eq, Ord, Show, Generic) - -instance NFData KindSignatureFor + deriving (Eq, Ord, Show, Generic, NFData) declSourceAnn :: Declaration -> SourceAnn declSourceAnn (DataDeclaration sa _ _ _ _) = sa @@ -627,13 +625,13 @@ flattenDecls = concatMap flattenOne -- data Guard = ConditionGuard Expr | PatternGuard Binder Expr - deriving (Show) + deriving (Show, Generic, NFData) -- | -- The right hand side of a binder in value declarations -- and case expressions. data GuardedExpr = GuardedExpr [Guard] Expr - deriving (Show) + deriving (Show, Generic, NFData) pattern MkUnguarded :: Expr -> GuardedExpr pattern MkUnguarded e = GuardedExpr [] e @@ -764,7 +762,7 @@ data Expr -- A value with source position information -- | PositionedValue SourceSpan [Comment] Expr - deriving (Show) + deriving (Show, Generic, NFData) -- | -- Metadata that tells where a let binding originated @@ -778,7 +776,7 @@ data WhereProvenance -- The let binding was always a let binding -- | FromLet - deriving (Show) + deriving (Show, Generic, NFData) -- | -- An alternative in a case statement @@ -792,7 +790,7 @@ data CaseAlternative = CaseAlternative -- The result expression or a collect of guarded expressions -- , caseAlternativeResult :: [GuardedExpr] - } deriving (Show) + } deriving (Show, Generic, NFData) -- | -- A statement in a do-notation block @@ -814,7 +812,7 @@ data DoNotationElement -- A do notation element with source position information -- | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement - deriving (Show) + deriving (Show, Generic, NFData) -- For a record update such as: @@ -842,12 +840,14 @@ data DoNotationElement newtype PathTree t = PathTree (AssocList PSString (PathNode t)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable) + deriving newtype NFData data PathNode t = Leaf t | Branch (PathTree t) - deriving (Show, Eq, Ord, Functor, Foldable, Traversable) + deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable, Traversable) newtype AssocList k t = AssocList { runAssocList :: [(k, t)] } deriving (Show, Eq, Ord, Foldable, Functor, Traversable) + deriving newtype NFData $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''NameSource) $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExportSource) diff --git a/src/Language/PureScript/AST/Literals.hs b/src/Language/PureScript/AST/Literals.hs index cfa2e880e8..05e06ab8f9 100644 --- a/src/Language/PureScript/AST/Literals.hs +++ b/src/Language/PureScript/AST/Literals.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE DeriveAnyClass #-} -- | -- The core functional representation for literal values. -- module Language.PureScript.AST.Literals where import Prelude +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) import Language.PureScript.PSString (PSString) -- | @@ -35,4 +38,4 @@ data Literal a -- An object literal -- | ObjectLiteral [(PSString, a)] - deriving (Eq, Ord, Show, Functor) + deriving (Eq, Ord, Show, Functor, Generic, NFData) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 26b932323f..f40cc44e9f 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -4,6 +4,7 @@ -- This module takes as input the individual generated modules from 'Language.PureScript.Make' and -- performs dead code elimination, filters empty modules, -- and generates the final JavaScript bundle. +{-# LANGUAGE DeriveAnyClass #-} module Language.PureScript.Bundle ( ModuleIdentifier(..) , ModuleType(..) @@ -18,6 +19,7 @@ module Language.PureScript.Bundle import Prelude +import Control.DeepSeq (NFData) import Control.Monad.Error.Class (MonadError(..)) import Data.Aeson ((.=)) @@ -27,6 +29,8 @@ import Data.Maybe (mapMaybe, maybeToList) import Data.Aeson qualified as A import Data.Text.Lazy qualified as LT +import GHC.Generics (Generic) + import Language.JavaScript.Parser (JSAST(..), JSAnnot(..), JSAssignOp(..), JSExpression(..), JSStatement(..), renderToText) import Language.JavaScript.Parser.AST (JSCommaList(..), JSCommaTrailingList(..), JSExportClause(..), JSExportDeclaration(..), JSExportSpecifier(..), JSFromClause(..), JSIdent(..), JSImportDeclaration(..), JSModuleItem(..), JSObjectProperty(..), JSObjectPropertyList, JSPropertyName(..), JSVarInitializer(..)) import Language.JavaScript.Process.Minify (minifyJS) @@ -42,21 +46,22 @@ data ErrorMessage | ErrorInModule ModuleIdentifier ErrorMessage | MissingEntryPoint String | MissingMainModule String - deriving (Show) + deriving (Show, Generic, NFData) -- | Modules are either "regular modules" (i.e. those generated by the PureScript compiler) or -- foreign modules. data ModuleType = Regular | Foreign - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic, NFData) showModuleType :: ModuleType -> String showModuleType Regular = "Regular" showModuleType Foreign = "Foreign" -- | A module is identified by its module name and its type. -data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Eq, Ord) +data ModuleIdentifier = ModuleIdentifier String ModuleType + deriving (Show, Eq, Ord, Generic, NFData) instance A.ToJSON ModuleIdentifier where toJSON (ModuleIdentifier name mt) = diff --git a/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs index 5cdea343ef..3682f2f0a5 100644 --- a/src/Language/PureScript/CST/Errors.hs +++ b/src/Language/PureScript/CST/Errors.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} module Language.PureScript.CST.Errors ( ParserErrorInfo(..) , ParserErrorType(..) @@ -11,8 +12,10 @@ module Language.PureScript.CST.Errors import Prelude +import Control.DeepSeq (NFData) import Data.Text qualified as Text import Data.Char (isSpace, toUpper) +import GHC.Generics (Generic) import Language.PureScript.CST.Layout (LayoutStack) import Language.PureScript.CST.Print (printToken) import Language.PureScript.CST.Types (SourcePos(..), SourceRange(..), SourceToken(..), Token(..)) @@ -56,7 +59,7 @@ data ParserErrorType | ErrConstraintInForeignImportSyntax | ErrEof | ErrCustom String - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic, NFData) data ParserWarningType = WarnDeprecatedRowSyntax @@ -64,14 +67,14 @@ data ParserWarningType | WarnDeprecatedKindImportSyntax | WarnDeprecatedKindExportSyntax | WarnDeprecatedCaseOfOffsideSyntax - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic, NFData) data ParserErrorInfo a = ParserErrorInfo { errRange :: SourceRange , errToks :: [SourceToken] , errStack :: LayoutStack , errType :: a - } deriving (Show, Eq) + } deriving (Show, Eq, Generic, NFData) type ParserError = ParserErrorInfo ParserErrorType type ParserWarning = ParserErrorInfo ParserWarningType diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs index 989cf1563d..2f41df6b4f 100644 --- a/src/Language/PureScript/CST/Layout.hs +++ b/src/Language/PureScript/CST/Layout.hs @@ -166,14 +166,17 @@ -- "body of a case of expression" by pushing 'LytOf' onto the layout stack. -- Insert the @of@ token into the stream of tokens. -- +{-# LANGUAGE DeriveAnyClass #-} module Language.PureScript.CST.Layout where import Prelude +import Control.DeepSeq (NFData) import Data.DList (snoc) import Data.DList qualified as DList import Data.Foldable (find) import Data.Function ((&)) +import GHC.Generics (Generic) import Language.PureScript.CST.Types (Comment, LineFeed, SourcePos(..), SourceRange(..), SourceToken(..), Token(..), TokenAnn(..)) type LayoutStack = [(SourcePos, LayoutDelim)] @@ -201,7 +204,7 @@ data LayoutDelim | LytOf | LytDo | LytAdo - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic, NFData) isIndented :: LayoutDelim -> Bool isIndented = \case diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs index a89532f1fa..ba90f7e95b 100644 --- a/src/Language/PureScript/CST/Types.hs +++ b/src/Language/PureScript/CST/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} -- | This module contains data types for the entire PureScript surface language. Every -- token is represented in the tree, and every token is annotated with -- whitespace and comments (both leading and trailing). This means one can write @@ -9,6 +10,7 @@ module Language.PureScript.CST.Types where import Prelude +import Control.DeepSeq (NFData) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import Data.Void (Void) @@ -20,30 +22,30 @@ import Language.PureScript.PSString (PSString) data SourcePos = SourcePos { srcLine :: {-# UNPACK #-} !Int , srcColumn :: {-# UNPACK #-} !Int - } deriving (Show, Eq, Ord, Generic) + } deriving (Show, Eq, Ord, Generic, NFData) data SourceRange = SourceRange { srcStart :: !SourcePos , srcEnd :: !SourcePos - } deriving (Show, Eq, Ord, Generic) + } deriving (Show, Eq, Ord, Generic, NFData) data Comment l = Comment !Text | Space {-# UNPACK #-} !Int | Line !l - deriving (Show, Eq, Ord, Generic, Functor) + deriving (Show, Eq, Ord, Generic, Functor, NFData) data LineFeed = LF | CRLF - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, NFData) data TokenAnn = TokenAnn { tokRange :: !SourceRange , tokLeadingComments :: ![Comment LineFeed] , tokTrailingComments :: ![Comment Void] - } deriving (Show, Eq, Ord, Generic) + } deriving (Show, Eq, Ord, Generic, NFData) data SourceStyle = ASCII | Unicode - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, NFData) data Token = TokLeftParen @@ -79,12 +81,12 @@ data Token | TokLayoutSep | TokLayoutEnd | TokEof - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, NFData) data SourceToken = SourceToken { tokAnn :: !TokenAnn , tokValue :: !Token - } deriving (Show, Eq, Ord, Generic) + } deriving (Show, Eq, Ord, Generic, NFData) data Ident = Ident { getIdent :: Text diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 2d8225f324..56d962b3c7 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} module Language.PureScript.Errors ( module Language.PureScript.AST , module Language.PureScript.Errors @@ -7,7 +8,7 @@ import Prelude import Protolude (unsnoc) import Control.Arrow ((&&&)) -import Control.Exception (displayException) +import Control.DeepSeq (NFData) import Control.Lens (both, head1, over) import Control.Monad (forM, unless) import Control.Monad.Error.Class (MonadError(..)) @@ -32,6 +33,7 @@ import Data.Set qualified as S import Data.Text qualified as T import Data.Text (Text) import Data.Traversable (for) +import GHC.Generics (Generic) import GHC.Stack qualified import Language.PureScript.AST import Language.PureScript.Bundle qualified as Bundle @@ -70,7 +72,7 @@ data SimpleErrorMessage | DeprecatedFFICommonJSModule ModuleName FilePath | UnsupportedFFICommonJSExports ModuleName [Text] | UnsupportedFFICommonJSImports ModuleName [Text] - | FileIOError Text IOError -- ^ A description of what we were trying to do, and the error which occurred + | FileIOError Text Text -- ^ A description of what we were trying to do, and the error which occurred | InfiniteType SourceType | InfiniteKind SourceType | MultipleValueOpFixities (OpName 'ValueOpName) @@ -196,12 +198,12 @@ data SimpleErrorMessage | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) [Qualified (ProperName 'ClassName)] Bool | CannotSkipTypeApplication SourceType | CannotApplyExpressionOfTypeOnType SourceType SourceType - deriving (Show) + deriving (Show, Generic, NFData) data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage - deriving (Show) + deriving (Show, Generic, NFData) newtype ErrorSuggestion = ErrorSuggestion Text @@ -369,7 +371,9 @@ errorCode em = case unwrapErrorMessage em of -- | A stack trace for an error newtype MultipleErrors = MultipleErrors { runMultipleErrors :: [ErrorMessage] - } deriving (Show, Semigroup, Monoid) + } + deriving stock (Show) + deriving newtype (Semigroup, Monoid, NFData) -- | Check whether a collection of errors is empty or not. nonEmpty :: MultipleErrors -> Bool @@ -679,7 +683,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon ] renderSimpleErrorMessage (FileIOError doWhat err) = paras [ line $ "I/O error while trying to " <> doWhat - , indent . lineS $ displayException err + , indent . line $ err ] renderSimpleErrorMessage (ErrorParsingFFIModule path extra) = paras $ [ line "Unable to parse foreign module:" @@ -941,7 +945,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon <> case argsRequiringVtas of [required] -> [ Box.moveRight 2 $ line $ T.intercalate ", " required ] - options -> + options -> [ Box.moveRight 2 $ line "One of the following sets of type variables:" , Box.moveRight 2 $ paras $ map (\set -> Box.moveRight 2 $ line $ T.intercalate ", " set) options diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 29d15ec8cd..a9669a9995 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -1,3 +1,4 @@ +{-# Language DeriveAnyClass #-} -- | -- This module generates code for \"externs\" files, i.e. files containing only -- foreign import declarations. @@ -17,8 +18,8 @@ module Language.PureScript.Externs import Prelude import Codec.Serialise (Serialise) +import Control.DeepSeq (NFData) import Control.Monad (join) -import GHC.Generics (Generic) import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.List (foldl', find) import Data.Foldable (fold) @@ -27,6 +28,7 @@ import Data.Text qualified as T import Data.Version (showVersion) import Data.Map qualified as M import Data.List.NonEmpty qualified as NEL +import GHC.Generics (Generic) import Language.PureScript.AST (Associativity, Declaration(..), DeclarationRef(..), Fixity(..), ImportDeclarationType, Module(..), NameSource(..), Precedence, SourceSpan, pattern TypeFixityDeclaration, pattern ValueFixityDeclaration, getTypeOpRef, getValueOpRef) import Language.PureScript.AST.Declarations.ChainId (ChainId) @@ -59,7 +61,7 @@ data ExternsFile = ExternsFile -- ^ List of type and value declaration , efSourceSpan :: SourceSpan -- ^ Source span for error reporting - } deriving (Show, Generic) + } deriving (Show, Generic, NFData) instance Serialise ExternsFile @@ -72,7 +74,7 @@ data ExternsImport = ExternsImport , eiImportType :: ImportDeclarationType -- | The imported-as name, for qualified imports , eiImportedAs :: Maybe ModuleName - } deriving (Show, Generic) + } deriving (Show, Generic, NFData) instance Serialise ExternsImport @@ -87,7 +89,7 @@ data ExternsFixity = ExternsFixity , efOperator :: OpName 'ValueOpName -- | The value the operator is an alias for , efAlias :: Qualified (Either Ident (ProperName 'ConstructorName)) - } deriving (Show, Generic) + } deriving (Show, Generic, NFData) instance Serialise ExternsFixity @@ -102,7 +104,7 @@ data ExternsTypeFixity = ExternsTypeFixity , efTypeOperator :: OpName 'TypeOpName -- | The value the operator is an alias for , efTypeAlias :: Qualified (ProperName 'TypeName) - } deriving (Show, Generic) + } deriving (Show, Generic, NFData) instance Serialise ExternsTypeFixity @@ -155,7 +157,7 @@ data ExternsDeclaration = , edInstanceNameSource :: NameSource , edInstanceSourceSpan :: SourceSpan } - deriving (Show, Generic) + deriving (Show, Generic, NFData) instance Serialise ExternsDeclaration diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 8340d77caa..5228dc86e6 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -12,12 +12,14 @@ module Language.PureScript.Make import Prelude import Control.Concurrent.Lifted as C -import Control.Exception.Base (onException) -import Control.Monad (foldM, unless, when) +import Control.DeepSeq (force) +import Control.Exception.Lifted (onException, bracket_, evaluate) +import Control.Monad (foldM, unless, when, (<=<)) +import Control.Monad.Base (MonadBase(liftBase)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Supply (evalSupplyT, runSupply, runSupplyT) -import Control.Monad.Trans.Control (MonadBaseControl(..), control) +import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Trans.State (runStateT) import Control.Monad.Writer.Class (MonadWriter(..), censor) import Control.Monad.Writer.Strict (runWriterT) @@ -29,6 +31,7 @@ import Data.Maybe (fromMaybe) import Data.Map qualified as M import Data.Set qualified as S import Data.Text qualified as T +import Debug.Trace (traceMarkerIO) import Language.PureScript.AST (ErrorMessageHint(..), Module(..), SourceSpan(..), getModuleName, getModuleSourceSpan, importPrim) import Language.PureScript.Crash (internalError) import Language.PureScript.CST qualified as CST @@ -56,7 +59,7 @@ import System.FilePath (replaceExtension) -- This function is used for fast-rebuild workflows (PSCi and psc-ide are examples). rebuildModule :: forall m - . (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [ExternsFile] -> Module @@ -67,7 +70,7 @@ rebuildModule actions externs m = do rebuildModule' :: forall m - . (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> Env -> [ExternsFile] @@ -77,7 +80,7 @@ rebuildModule' act env ext mdl = rebuildModuleWithIndex act env ext mdl Nothing rebuildModuleWithIndex :: forall m - . (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> Env -> [ExternsFile] @@ -148,12 +151,21 @@ make ma@MakeActions{..} ms = do (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph) + -- Limit concurrent module builds to the number of capabilities as + -- (by default) inferred from `+RTS -N -RTS` or set explicitly like `-N4`. + -- This is to ensure that modules complete fully before moving on, to avoid + -- holding excess memory during compilation from modules that were paused + -- by the Haskell runtime. + capabilities <- getNumCapabilities + let concurrency = max 1 capabilities + lock <- C.newQSem concurrency + let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted let totalModuleCount = length toBeRebuilt for_ toBeRebuilt $ \m -> fork $ do let moduleName = getModuleName . CST.resPartial $ m let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph) - buildModule buildPlan moduleName totalModuleCount + buildModule lock buildPlan moduleName totalModuleCount (spanName . getModuleSourceSpan . CST.resPartial $ m) (fst $ CST.resFull m) (fmap importPrim . snd $ CST.resFull m) @@ -161,7 +173,7 @@ make ma@MakeActions{..} ms = do -- Prevent hanging on other modules when there is an internal error -- (the exception is thrown, but other threads waiting on MVars are released) - `onExceptionLifted` BuildPlan.markComplete buildPlan moduleName (BuildJobFailed mempty) + `onException` BuildPlan.markComplete buildPlan moduleName (BuildJobFailed mempty) -- Wait for all threads to complete, and collect results (and errors). (failures, successes) <- @@ -227,8 +239,8 @@ make ma@MakeActions{..} ms = do inOrderOf :: (Ord a) => [a] -> [a] -> [a] inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys - buildModule :: BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m () - buildModule buildPlan moduleName cnt fp pwarnings mres deps = do + buildModule :: QSem -> BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m () + buildModule lock buildPlan moduleName cnt fp pwarnings mres deps = do result <- flip catchError (return . BuildJobFailed) $ do let pwarnings' = CST.toMultipleWarnings fp pwarnings tell pwarnings' @@ -252,15 +264,24 @@ make ma@MakeActions{..} ms = do env <- C.readMVar (bpEnv buildPlan) idx <- C.takeMVar (bpIndex buildPlan) C.putMVar (bpIndex buildPlan) (idx + 1) - (exts, warnings) <- listen $ rebuildModuleWithIndex ma env externs m (Just (idx, cnt)) + + -- Bracket all of the per-module work behind the semaphore, including + -- forcing the result. This is done to limit concurrency and keep + -- memory usage down; see comments above. + (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do + -- Eventlog markers for profiling; see debug/eventlog.js + liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start" + -- Force the externs and warnings to avoid retaining excess module + -- data after the module is finished compiling. + extsAndWarnings <- evaluate . force <=< listen $ do + rebuildModuleWithIndex ma env externs m (Just (idx, cnt)) + liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end" + return extsAndWarnings return $ BuildJobSucceeded (pwarnings' <> warnings) exts Nothing -> return BuildJobSkipped BuildPlan.markComplete buildPlan moduleName result - onExceptionLifted :: m a -> m b -> m a - onExceptionLifted l r = control $ \runInIO -> runInIO l `onException` runInIO r - -- | Infer the module name for a module by looking for the same filename with -- a .js extension. inferForeignModules diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index d8326ee129..8c86144e9a 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -23,7 +23,7 @@ import Prelude import Codec.Serialise (Serialise) import Codec.Serialise qualified as Serialise -import Control.Exception (fromException, tryJust) +import Control.Exception (fromException, tryJust, Exception (displayException)) import Control.Monad (join, guard) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Error.Class (MonadError(..)) @@ -71,7 +71,7 @@ runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake makeIO :: (MonadIO m, MonadError MultipleErrors m) => Text -> IO a -> m a makeIO description io = do res <- liftIO (tryIOError io) - either (throwError . singleError . ErrorMessage [] . FileIOError description) pure res + either (throwError . singleError . ErrorMessage [] . FileIOError description . Text.pack . displayException) pure res -- | Get a file's modification time in the 'Make' monad, capturing any errors -- using the 'MonadError' instance. From e25c476c08c2e134f5d369326060be2f0d9ef583 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Wed, 3 Jan 2024 07:58:55 -0800 Subject: [PATCH 1563/1580] Prep 0.15.14 release (#4526) * Update version to 0.15.14 * Update changelog --- .../fix_compilation_regression-4491.md | 8 ----- CHANGELOG.d/fix_fix-class-head-ty-var.md | 1 - CHANGELOG.d/fix_module-space-leak.md | 11 ------- CHANGELOG.md | 29 +++++++++++++++++++ npm-package/package.json | 4 +-- purescript.cabal | 2 +- 6 files changed, 32 insertions(+), 23 deletions(-) delete mode 100644 CHANGELOG.d/fix_compilation_regression-4491.md delete mode 100644 CHANGELOG.d/fix_fix-class-head-ty-var.md delete mode 100644 CHANGELOG.d/fix_module-space-leak.md diff --git a/CHANGELOG.d/fix_compilation_regression-4491.md b/CHANGELOG.d/fix_compilation_regression-4491.md deleted file mode 100644 index a2fbc45f4e..0000000000 --- a/CHANGELOG.d/fix_compilation_regression-4491.md +++ /dev/null @@ -1,8 +0,0 @@ -* Fix a compilation memory regression for very large files - - When compiling a a very large file (>12K lines) - the CSE pass could balloon memory and result in increased - compilation times. - - This fix uses a strict Map instead of a lazy Map to avoid - building up unnecessary thunks during the optimization pass. diff --git a/CHANGELOG.d/fix_fix-class-head-ty-var.md b/CHANGELOG.d/fix_fix-class-head-ty-var.md deleted file mode 100644 index 12a3f8ab11..0000000000 --- a/CHANGELOG.d/fix_fix-class-head-ty-var.md +++ /dev/null @@ -1 +0,0 @@ -* Fix parsing bug where `@var` was allowed in type class head \ No newline at end of file diff --git a/CHANGELOG.d/fix_module-space-leak.md b/CHANGELOG.d/fix_module-space-leak.md deleted file mode 100644 index 2cb86e8562..0000000000 --- a/CHANGELOG.d/fix_module-space-leak.md +++ /dev/null @@ -1,11 +0,0 @@ -* Fix two space leaks while compiling many modules - - The first would interleave compilation of too many modules at once, which - would increase memory usage, especially for single threaded builds with - `+RTS -N1 -RTS`. Now the number of concurrent modules is limited to - the number of threads available to the - [GHC runtime system](https://downloads.haskell.org/ghc/latest/docs/users_guide/using-concurrent.html#rts-options-for-smp-parallelism). - - The second would hold on to memory from modules that compiled with warnings - until the end of the build when the warnings were printed and the memory freed. - This is now fixed with additional `NFData` instances. diff --git a/CHANGELOG.md b/CHANGELOG.md index d8052d14cf..309b8ac703 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,31 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.14 + +Bugfixes: + +* Fix a compilation memory regression for very large files (#4521 by @mjrussell) + + When compiling a a very large file (>12K lines) + the CSE pass could balloon memory and result in increased + compilation times. + + This fix uses a strict Map instead of a lazy Map to avoid + building up unnecessary thunks during the optimization pass. + +* Fix two space leaks while compiling many modules (#4517 by @MonoidMusician) + + The first would interleave compilation of too many modules at once, which + would increase memory usage, especially for single threaded builds with + `+RTS -N1 -RTS`. Now the number of concurrent modules is limited to + the number of threads available to the + [GHC runtime system](https://downloads.haskell.org/ghc/latest/docs/users_guide/using-concurrent.html#rts-options-for-smp-parallelism). + + The second would hold on to memory from modules that compiled with warnings + until the end of the build when the warnings were printed and the memory freed. + This is now fixed with additional `NFData` instances. + ## 0.15.13 New features: @@ -78,6 +103,10 @@ New features: b ``` +Bugfixes: + +* Fix parsing bug where `@var` was allowed in type class head (#4523 by @JordanMartinez) + ## 0.15.12 New features: diff --git a/npm-package/package.json b/npm-package/package.json index b24866695b..8470f00e4c 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.13", + "version": "0.15.14", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.13", + "postinstall": "install-purescript --purs-ver=0.15.14", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index a608c61cac..496e669a81 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.13 +version: 0.15.14 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From 5dcd000363c3c27e29f2bb8e6848c7782c17a40d Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Wed, 7 Feb 2024 10:02:42 -0600 Subject: [PATCH 1564/1580] Add support for `--source-globs-file` CLI arg in relevant `purs` commands (#4530) * Enable passing source input globs via `--source-globs-file path/to/file` `--source-globs-file` support has been added to the following commands: `compile`, `docs`, `graph`, `ide`, and `publish`. Due to a [shell character limitation on Windows](https://learn.microsoft.com/en-us/troubleshoot/windows-client/shell-experience/command-line-string-limitation) where a large list of source globs cannot be passed (e.g. `purs compile ... glob1000/src/**/*.purs`), source globs can be stored in a file according to the format below and the file is passed in instead via `purs compile ---source-globs-file path/to/file`. ``` # Lines starting with '#' are comments. # Blank lines are ignored. # Otherwise, every line is a glob. .spago/foo-1.2.3/src/**/*.purs .spago/bar-2.3.3/src/**/*.purs my-package/src/**/*.purs my-package/tests/**/*.purs ``` `--source-globs-file` is an optional argument. Mixing it with the normal source globs is fine. Assuming `.spago/source-globs` contains `src/**/*.purs`, each command below will use the same input globs: ```sh purs compile src/**/*.purs purs compile --source-globs .spago/source-globs purs compile --source-globs .spago/source-globs src/**/*.purs ``` In the command... ``` purs compile inputGlob1 inputGlob2 --source-globs-file fileWithMoreGlobs --exclude-files excludeGlob1 ``` the files passed to the compiler are: all the files found by `inputGlob1`, `inputGlob2`, and all the globs listed in `fileWithMoreGlobs` minus the files found by `excludeGlob1`. * Add `--exclude-file` to more commands While implementing the fix above, I discovered that the `--exclude-file` CLI arg wasn't included in other `purs` commands where such a usage would be relevant (e.g. `docs`, `repl`, `graph`, and `ide`). This PR also rectifies that problem. --- .github/workflows/ci.yml | 9 ++ ...ature_add-exclude-file-to-more-commands.md | 5 + CHANGELOG.d/feature_glob-input-files.md | 38 ++++++ app/Command/Compile.hs | 45 +++---- app/Command/Docs.hs | 28 +++-- app/Command/Graph.hs | 42 +++---- app/Command/Ide.hs | 11 +- app/Command/REPL.hs | 21 ++-- app/SharedCLI.hs | 24 ++++ glob-test.sh | 113 ++++++++++++++++++ purescript.cabal | 2 + src/Language/PureScript/Glob.hs | 44 +++++++ src/Language/PureScript/Ide.hs | 12 +- src/Language/PureScript/Ide/Types.hs | 2 + tests/Language/PureScript/Ide/Test.hs | 2 + 15 files changed, 317 insertions(+), 81 deletions(-) create mode 100644 CHANGELOG.d/feature_add-exclude-file-to-more-commands.md create mode 100644 CHANGELOG.d/feature_glob-input-files.md create mode 100644 app/SharedCLI.hs create mode 100644 glob-test.sh create mode 100644 src/Language/PureScript/Glob.hs diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index d88257ed07..8efd13812b 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -130,6 +130,15 @@ jobs: - id: "build" run: "ci/fix-home ci/build.sh" + - name: "(Linux only) Glob tests" + if: "contains(matrix.os, 'ubuntu-latest')" + working-directory: "sdist-test" + # We build in this directory in build.sh, so this is where we need to + # launch `stack exec`. The actual glob checks happen in a temporary directory. + run: | + apt-get install tree + ../ci/fix-home stack exec bash ../glob-test.sh + - name: "(Linux only) Build the entire package set" if: "contains(matrix.os, 'ubuntu-latest')" # We build in this directory in build.sh, so this is where we need to diff --git a/CHANGELOG.d/feature_add-exclude-file-to-more-commands.md b/CHANGELOG.d/feature_add-exclude-file-to-more-commands.md new file mode 100644 index 0000000000..b613e791c3 --- /dev/null +++ b/CHANGELOG.d/feature_add-exclude-file-to-more-commands.md @@ -0,0 +1,5 @@ +* Add `--exclude-file` to more commands + + This CLI arg was added to the `compile` command, but not to other commands + where such a usage would be relevant (e.g. `docs`, `repl`, `graph`, and `ide`). + \ No newline at end of file diff --git a/CHANGELOG.d/feature_glob-input-files.md b/CHANGELOG.d/feature_glob-input-files.md new file mode 100644 index 0000000000..076b94cf4c --- /dev/null +++ b/CHANGELOG.d/feature_glob-input-files.md @@ -0,0 +1,38 @@ +* Enable passing source input globs via `--source-globs-file path/to/file` + + `--source-globs-file` support has been added to the following commands: + `compile`, `docs`, `graph`, `ide`, and `publish`. + + Due to a [shell character limitation on Windows](https://learn.microsoft.com/en-us/troubleshoot/windows-client/shell-experience/command-line-string-limitation) where a large list of + source globs cannot be passed (e.g. `purs compile ... glob1000/src/**/*.purs`), + source globs can be stored in a file according to the format below + and the file is passed in instead via `purs compile ---source-globs-file path/to/file`. + + ``` + # Lines starting with '#' are comments. + # Blank lines are ignored. + # Otherwise, every line is a glob. + + .spago/foo-1.2.3/src/**/*.purs + .spago/bar-2.3.3/src/**/*.purs + my-package/src/**/*.purs + my-package/tests/**/*.purs + ``` + + `--source-globs-file` is an optional argument. Mixing it with the normal source globs is fine. + Assuming `.spago/source-globs` contains `src/**/*.purs`, each command below will use + the same input globs: + ```sh + purs compile src/**/*.purs + purs compile --source-globs .spago/source-globs + purs compile --source-globs .spago/source-globs src/**/*.purs + ``` + + In the command... + ``` + purs compile inputGlob1 inputGlob2 --source-globs-file fileWithMoreGlobs --exclude-files excludeGlob1 + ``` + the files passed to the compiler are: all the files found by + `inputGlob1`, `inputGlob2`, and all the globs listed in `fileWithMoreGlobs` + minus the files found by `excludeGlob1`. + \ No newline at end of file diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs index 8f348da9dd..d81dd75c07 100644 --- a/app/Command/Compile.hs +++ b/app/Command/Compile.hs @@ -7,7 +7,7 @@ import Control.Monad (when) import Data.Aeson qualified as A import Data.Bool (bool) import Data.ByteString.Lazy.UTF8 qualified as LBU8 -import Data.List (intercalate, (\\)) +import Data.List (intercalate) import Data.Map qualified as M import Data.Set qualified as S import Data.Text qualified as T @@ -15,17 +15,19 @@ import Data.Traversable (for) import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST import Language.PureScript.Errors.JSON (JSONResult(..), toJSONErrors) +import Language.PureScript.Glob (toInputGlobs, PSCGlobs(..), warnFileTypeNotFound) import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake) import Options.Applicative qualified as Opts +import SharedCLI qualified import System.Console.ANSI qualified as ANSI import System.Exit (exitSuccess, exitFailure) import System.Directory (getCurrentDirectory) -import System.FilePath.Glob (glob) -import System.IO (hPutStr, hPutStrLn, stderr, stdout) +import System.IO (hPutStr, stderr, stdout) import System.IO.UTF8 (readUTF8FilesT) data PSCMakeOptions = PSCMakeOptions { pscmInput :: [FilePath] + , pscmInputFromFile :: Maybe FilePath , pscmExclude :: [FilePath] , pscmOutputDir :: FilePath , pscmOpts :: P.Options @@ -54,9 +56,12 @@ printWarningsAndErrors verbose True files warnings errors = do compile :: PSCMakeOptions -> IO () compile PSCMakeOptions{..} = do - included <- globWarningOnMisses warnFileTypeNotFound pscmInput - excluded <- globWarningOnMisses warnFileTypeNotFound pscmExclude - let input = included \\ excluded + input <- toInputGlobs $ PSCGlobs + { pscInputGlobs = pscmInput + , pscInputGlobsFromFile = pscmInputFromFile + , pscExcludeGlobs = pscmExclude + , pscWarnFileTypeNotFound = warnFileTypeNotFound "compile" + } when (null input) $ do hPutStr stderr $ unlines [ "purs compile: No input files." , "Usage: For basic information, try the `--help' option." @@ -72,29 +77,6 @@ compile PSCMakeOptions{..} = do printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors exitSuccess -warnFileTypeNotFound :: String -> IO () -warnFileTypeNotFound = hPutStrLn stderr . ("purs compile: No files found using pattern: " ++) - -globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath] -globWarningOnMisses warn = concatMapM globWithWarning - where - globWithWarning pattern' = do - paths <- glob pattern' - when (null paths) $ warn pattern' - return paths - concatMapM f = fmap concat . mapM f - -inputFile :: Opts.Parser FilePath -inputFile = Opts.strArgument $ - Opts.metavar "FILE" - <> Opts.help "The input .purs file(s)." - -excludedFiles :: Opts.Parser FilePath -excludedFiles = Opts.strOption $ - Opts.short 'x' - <> Opts.long "exclude-files" - <> Opts.help "Glob of .purs files to exclude from the supplied files." - outputDirectory :: Opts.Parser FilePath outputDirectory = Opts.strOption $ Opts.short 'o' @@ -161,8 +143,9 @@ options = handleTargets ts = S.fromList (if P.JSSourceMap `elem` ts then P.JS : ts else ts) pscMakeOptions :: Opts.Parser PSCMakeOptions -pscMakeOptions = PSCMakeOptions <$> many inputFile - <*> many excludedFiles +pscMakeOptions = PSCMakeOptions <$> many SharedCLI.inputFile + <*> SharedCLI.globInputFile + <*> many SharedCLI.excludeFiles <*> outputDirectory <*> options <*> (not <$> noPrefix) diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index 38c875083c..f0b6711b09 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -13,12 +13,14 @@ import Data.Text qualified as T import Language.PureScript qualified as P import Language.PureScript.Docs qualified as D import Language.PureScript.Docs.Tags (dumpCtags, dumpEtags) +import Language.PureScript.Glob (PSCGlobs(..), toInputGlobs, warnFileTypeNotFound) import Options.Applicative qualified as Opts import Text.PrettyPrint.ANSI.Leijen qualified as PP +import SharedCLI qualified import System.Directory (getCurrentDirectory, createDirectoryIfMissing, removeFile) import System.Exit (exitFailure) import System.FilePath (()) -import System.FilePath.Glob (compile, glob, globDir1) +import System.FilePath.Glob (compile, globDir1) import System.IO (hPutStrLn, stderr) import System.IO.UTF8 (writeUTF8FileT) @@ -35,12 +37,19 @@ data PSCDocsOptions = PSCDocsOptions , _pscdOutput :: Maybe FilePath , _pscdCompileOutputDir :: FilePath , _pscdInputFiles :: [FilePath] + , _pscdInputFromFile :: Maybe FilePath + , _pscdExcludeFiles :: [FilePath] } deriving (Show) docgen :: PSCDocsOptions -> IO () -docgen (PSCDocsOptions fmt moutput compileOutput inputGlob) = do - input <- concat <$> mapM glob inputGlob +docgen (PSCDocsOptions fmt moutput compileOutput inputGlob inputGlobFromFile excludeGlob) = do + input <- toInputGlobs $ PSCGlobs + { pscInputGlobs = inputGlob + , pscInputGlobsFromFile = inputGlobFromFile + , pscExcludeGlobs = excludeGlob + , pscWarnFileTypeNotFound = warnFileTypeNotFound "docs" + } when (null input) $ do hPutStrLn stderr "purs docs: no input files." exitFailure @@ -104,7 +113,13 @@ defaultOutputForFormat fmt = Ctags -> "tags" pscDocsOptions :: Opts.Parser PSCDocsOptions -pscDocsOptions = PSCDocsOptions <$> format <*> output <*> compileOutputDir <*> many inputFile +pscDocsOptions = + PSCDocsOptions <$> format + <*> output + <*> compileOutputDir + <*> many SharedCLI.inputFile + <*> SharedCLI.globInputFile + <*> many SharedCLI.excludeFiles where format :: Opts.Parser Format format = Opts.option Opts.auto $ @@ -128,11 +143,6 @@ pscDocsOptions = PSCDocsOptions <$> format <*> output <*> compileOutputDir <*> m <> Opts.metavar "DIR" <> Opts.help "Compiler output directory" - inputFile :: Opts.Parser FilePath - inputFile = Opts.strArgument $ - Opts.metavar "FILE" - <> Opts.help "The input .purs file(s)" - command :: Opts.Parser (IO ()) command = docgen <$> (Opts.helper <*> pscDocsOptions) diff --git a/app/Command/Graph.hs b/app/Command/Graph.hs index 4e3c905d9b..43cb1e2591 100644 --- a/app/Command/Graph.hs +++ b/app/Command/Graph.hs @@ -10,21 +10,30 @@ import Data.ByteString.Lazy qualified as LB import Data.ByteString.Lazy.UTF8 qualified as LBU8 import Language.PureScript qualified as P import Language.PureScript.Errors.JSON (JSONResult(..), toJSONErrors) +import Language.PureScript.Glob (PSCGlobs(..), toInputGlobs, warnFileTypeNotFound) import Options.Applicative qualified as Opts +import SharedCLI qualified import System.Console.ANSI qualified as ANSI import System.Exit (exitFailure) import System.Directory (getCurrentDirectory) -import System.FilePath.Glob (glob) import System.IO (hPutStr, hPutStrLn, stderr) data GraphOptions = GraphOptions { graphInput :: [FilePath] + , graphInputFromFile :: Maybe FilePath + , graphExclude :: [FilePath] , graphJSONErrors :: Bool } graph :: GraphOptions -> IO () graph GraphOptions{..} = do - input <- globWarningOnMisses (unless graphJSONErrors . warnFileTypeNotFound) graphInput + input <- toInputGlobs $ PSCGlobs + { pscInputGlobs = graphInput + , pscInputGlobsFromFile = graphInputFromFile + , pscExcludeGlobs = graphExclude + , pscWarnFileTypeNotFound = unless graphJSONErrors . warnFileTypeNotFound "graph" + } + when (null input && not graphJSONErrors) $ do hPutStr stderr $ unlines [ "purs graph: No input files." @@ -37,26 +46,16 @@ graph GraphOptions{..} = do printWarningsAndErrors graphJSONErrors makeWarnings makeResult >>= (LB.putStr . Json.encode) - where - warnFileTypeNotFound :: String -> IO () - warnFileTypeNotFound = - hPutStrLn stderr . ("purs graph: No files found using pattern: " <>) - - command :: Opts.Parser (IO ()) command = graph <$> (Opts.helper <*> graphOptions) where graphOptions :: Opts.Parser GraphOptions graphOptions = - GraphOptions <$> many inputFile + GraphOptions <$> many SharedCLI.inputFile + <*> SharedCLI.globInputFile + <*> many SharedCLI.excludeFiles <*> jsonErrors - inputFile :: Opts.Parser FilePath - inputFile = - Opts.strArgument $ - Opts.metavar "FILE" <> - Opts.help "The input .purs file(s)." - jsonErrors :: Opts.Parser Bool jsonErrors = Opts.switch $ @@ -84,16 +83,3 @@ printWarningsAndErrors True warnings errors = do case errors of Left _errs -> exitFailure Right res -> pure res - - -globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath] -globWarningOnMisses warn = concatMapM globWithWarning - where - globWithWarning :: String -> IO [FilePath] - globWithWarning pattern' = do - paths <- glob pattern' - when (null paths) $ warn pattern' - return paths - - concatMapM :: (a -> IO [b]) -> [a] -> IO [b] - concatMapM f = fmap concat . mapM f diff --git a/app/Command/Ide.hs b/app/Command/Ide.hs index cfb563be4e..f5a501af75 100644 --- a/app/Command/Ide.hs +++ b/app/Command/Ide.hs @@ -35,6 +35,7 @@ import Language.PureScript.Ide.State (updateCacheTimestamp) import Language.PureScript.Ide.Types (Ide, IdeConfiguration(..), IdeEnvironment(..), IdeLogLevel(..), emptyIdeState) import Network.Socket qualified as Network import Options.Applicative qualified as Opts +import SharedCLI qualified import System.Directory (doesDirectoryExist, getCurrentDirectory, setCurrentDirectory) import System.FilePath (()) import System.IO (BufferMode(..), hClose, hFlush, hSetBuffering, hSetEncoding, utf8) @@ -59,6 +60,8 @@ listenOnLocalhost port = do data ServerOptions = ServerOptions { _serverDirectory :: Maybe FilePath , _serverGlobs :: [FilePath] + , _serverGlobsFromFile :: Maybe FilePath + , _serverGlobsExcluded :: [FilePath] , _serverOutputPath :: FilePath , _serverPort :: Network.PortNumber , _serverLoglevel :: IdeLogLevel @@ -110,7 +113,7 @@ command = Opts.helper <*> subcommands where Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer)) server :: ServerOptions -> IO () - server opts'@(ServerOptions dir globs outputPath port logLevel editorMode polling noWatch) = do + server opts'@(ServerOptions dir globs globsFromFile globsExcluded outputPath port logLevel editorMode polling noWatch) = do when (logLevel == LogDebug || logLevel == LogAll) (putText "Parsed Options:" *> print opts') maybe (pure ()) setCurrentDirectory dir @@ -136,6 +139,8 @@ command = Opts.helper <*> subcommands where { confLogLevel = logLevel , confOutputPath = outputPath , confGlobs = globs + , confGlobsFromFile = globsFromFile + , confGlobsExclude = globsExcluded } ts <- newIORef Nothing let @@ -150,7 +155,9 @@ command = Opts.helper <*> subcommands where serverOptions = ServerOptions <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd')) - <*> many (Opts.argument Opts.str (Opts.metavar "Source GLOBS...")) + <*> many SharedCLI.inputFile + <*> SharedCLI.globInputFile + <*> many SharedCLI.excludeFiles <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/") <*> (fromIntegral <$> Opts.option Opts.auto (Opts.long "port" `mappend` Opts.short 'p' `mappend` Opts.value (4242 :: Integer))) diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs index eb254be45c..4d73c2303c 100644 --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -15,27 +15,25 @@ import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Data.Foldable (for_) import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST +import Language.PureScript.Glob (PSCGlobs(..), toInputGlobs, warnFileTypeNotFound) import Language.PureScript.Interactive import Options.Applicative qualified as Opts +import SharedCLI qualified import System.Console.Haskeline (InputT, Settings(..), defaultSettings, getInputLine, handleInterrupt, outputStrLn, runInputT, setComplete, withInterrupt) import System.IO.UTF8 (readUTF8File) import System.Exit (ExitCode(..), exitFailure) import System.Directory (doesFileExist, getCurrentDirectory) import System.FilePath (()) -import System.FilePath.Glob qualified as Glob import System.IO (hPutStrLn, stderr) -- | Command line options data PSCiOptions = PSCiOptions { psciInputGlob :: [String] + , psciInputFromFile :: Maybe String + , psciExclude :: [String] , psciBackend :: Backend } -inputFile :: Opts.Parser FilePath -inputFile = Opts.strArgument $ - Opts.metavar "FILES" - <> Opts.help "Optional .purs files to load on start" - nodePathOption :: Opts.Parser (Maybe FilePath) nodePathOption = Opts.optional . Opts.strOption $ Opts.metavar "FILE" @@ -63,7 +61,9 @@ backend = <|> (nodeBackend <$> nodePathOption <*> nodeFlagsOption) psciOptions :: Opts.Parser PSCiOptions -psciOptions = PSCiOptions <$> many inputFile +psciOptions = PSCiOptions <$> many SharedCLI.inputFile + <*> SharedCLI.globInputFile + <*> many SharedCLI.excludeFiles <*> backend -- | Parses the input and returns either a command, or an error as a 'String'. @@ -132,7 +132,12 @@ command = loop <$> options where loop :: PSCiOptions -> IO () loop PSCiOptions{..} = do - inputFiles <- concat <$> traverse Glob.glob psciInputGlob + inputFiles <- toInputGlobs $ PSCGlobs + { pscInputGlobs = psciInputGlob + , pscInputGlobsFromFile = psciInputFromFile + , pscExcludeGlobs = psciExclude + , pscWarnFileTypeNotFound = warnFileTypeNotFound "repl" + } e <- runExceptT $ do modules <- ExceptT (loadAllModules inputFiles) when (null modules) . liftIO $ do diff --git a/app/SharedCLI.hs b/app/SharedCLI.hs new file mode 100644 index 0000000000..0aa85469d4 --- /dev/null +++ b/app/SharedCLI.hs @@ -0,0 +1,24 @@ +module SharedCLI where + +import Prelude + +import Options.Applicative qualified as Opts + +inputFile :: Opts.Parser FilePath +inputFile = Opts.strArgument $ + Opts.metavar "GLOB" + <> Opts.help "A glob for input .purs file(s)." + +globInputFile :: Opts.Parser (Maybe FilePath) +globInputFile = Opts.optional $ Opts.strOption $ + Opts.long "source-globs-file" + <> Opts.metavar "FILE" + <> Opts.help "A file containing a line-separated list of input .purs globs." + +excludeFiles :: Opts.Parser FilePath +excludeFiles = Opts.strOption $ + Opts.short 'x' + <> Opts.long "exclude-files" + <> Opts.metavar "GLOB" + <> Opts.help "A glob of .purs files to exclude from the input .purs files." + diff --git a/glob-test.sh b/glob-test.sh new file mode 100644 index 0000000000..aba4432f31 --- /dev/null +++ b/glob-test.sh @@ -0,0 +1,113 @@ +#!/usr/bin/env bash + +# This script assumes `ci/build.sh && cd sdist-test` has been run +# and that the program `tree` has been installed. + +# Creates the following structure +# Foo.purs +# src/Bar.purs +# src/Bar/Baz.purs +# +# and verifies that the two kinds of input globs interact consistently. + +set -eu -o pipefail +shopt -s nullglob + +PURS="$(stack path --local-doc-root)/../bin/purs" + +tmpdir=$(mktemp -d) +trap 'rm -rf "$tmpdir"' EXIT +cd "$tmpdir" + +echo ::group::Environment info +echo "purs: ${PURS}" +echo "purs --version" +"${PURS}" --version +echo ::endgroup:: + +echo ::group::Setting up structure +mkdir -p "src/Bar" + +cat > "Foo.purs" < "src/Bar.purs" < "src/Bar/Baz.purs" < "globsAll" < "globsNoFoo" <&1 +EXPECTED=$(cd out1 && tree . 2>&1) + +"${PURS}" compile --output "out2" --source-globs-file globsAll 2>&1 +SOURCE_GLOBS=$(cd out2 && tree . 2>&1) + +"${PURS}" compile --output "out3" --source-globs-file globsAll 'Foo.purs' 2>&1 +MIXED_ALL=$(cd out3 && tree . 2>&1) + +"${PURS}" compile --output "out4" --source-globs-file globsNoFoo 'Foo.purs' 2>&1 +MIXED_NO_FOO=$(cd out4 && tree . 2>&1) +echo ::endgroup:: + +echo ::group::Running checks +if [ "${EXPECTED}" = "" ] ; then + echo "'purs compile' output should not be empty" + exit 1 +fi + +if [ "${EXPECTED}" = "${SOURCE_GLOBS}" ]; then + echo "SOURCE_GLOBS is correct" +else + echo "SOURCE_GLOBS output different from EXPECTED" + echo "Expected: ${EXPECTED}" + echo "SOURCE_GLOBS: ${SOURCE_GLOBS}" + exit 1 +fi + +if [ "${EXPECTED}" = "${MIXED_ALL}" ]; then + echo "MIXED_ALL is correct" +else + echo "MIXED_ALL output different from EXPECTED" + echo "Expected: ${MIXED_ALL}" + echo "MIXED_ALL: ${MIXED_ALL}" + exit 1 +fi + +if [ "${EXPECTED}" = "${MIXED_NO_FOO}" ]; then + echo "MIXED_NO_FOO is correct" +else + echo "MIXED_NO_FOO output different from EXPECTED" + echo "Expected: ${MIXED_NO_FOO}" + echo "MIXED_NO_FOO: ${MIXED_NO_FOO}" + exit 1 +fi + +echo "Tests passed" +echo ::endgroup:: +exit 0 diff --git a/purescript.cabal b/purescript.cabal index 496e669a81..5403791867 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -294,6 +294,7 @@ library Language.PureScript.Errors Language.PureScript.Errors.JSON Language.PureScript.Externs + Language.PureScript.Glob Language.PureScript.Graph Language.PureScript.Hierarchy Language.PureScript.Ide @@ -423,6 +424,7 @@ executable purs Command.Ide Command.Publish Command.REPL + SharedCLI Version Paths_purescript autogen-modules: diff --git a/src/Language/PureScript/Glob.hs b/src/Language/PureScript/Glob.hs new file mode 100644 index 0000000000..3493cd969d --- /dev/null +++ b/src/Language/PureScript/Glob.hs @@ -0,0 +1,44 @@ +module Language.PureScript.Glob where + +import Prelude + +import Control.Monad (when) +import Data.List (nub, (\\)) +import Data.Text qualified as T +import System.FilePath.Glob (glob) +import System.IO (hPutStrLn, stderr) +import System.IO.UTF8 (readUTF8FileT) + +data PSCGlobs = PSCGlobs + { pscInputGlobs :: [FilePath] + , pscInputGlobsFromFile :: Maybe FilePath + , pscExcludeGlobs :: [FilePath] + , pscWarnFileTypeNotFound :: FilePath -> IO () + } + +toInputGlobs :: PSCGlobs -> IO [FilePath] +toInputGlobs (PSCGlobs {..}) = do + globsFromFile <- inputGlobsFromFile pscInputGlobsFromFile + included <- globWarningOnMisses pscWarnFileTypeNotFound $ nub $ pscInputGlobs <> globsFromFile + excluded <- globWarningOnMisses pscWarnFileTypeNotFound pscExcludeGlobs + pure $ included \\ excluded + +inputGlobsFromFile :: Maybe FilePath -> IO [FilePath] +inputGlobsFromFile globsFromFile = do + mbInputsFromFile <- traverse readUTF8FileT globsFromFile + let + excludeBlankLines = not . T.null . T.strip + excludeComments = not . T.isPrefixOf "#" + toInputs = map (T.unpack . T.strip) . filter (\x -> excludeBlankLines x && excludeComments x) . T.lines + pure $ foldMap toInputs mbInputsFromFile + +globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath] +globWarningOnMisses warn = foldMap globWithWarning + where + globWithWarning pattern' = do + paths <- glob pattern' + when (null paths) $ warn pattern' + return paths + +warnFileTypeNotFound :: String -> String -> IO () +warnFileTypeNotFound pursCmd = hPutStrLn stderr . ("purs " <> pursCmd <> ": No files found using pattern: " ++) diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs index 746eec259b..57601c3d45 100644 --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -24,6 +24,7 @@ import "monad-logger" Control.Monad.Logger (MonadLogger, logWarnN) import Data.Map qualified as Map import Data.Text qualified as T import Language.PureScript qualified as P +import Language.PureScript.Glob (toInputGlobs, PSCGlobs(..)) import Language.PureScript.Ide.CaseSplit qualified as CS import Language.PureScript.Ide.Command (Command(..), ImportCommand(..), ListType(..)) import Language.PureScript.Ide.Completion (CompletionOptions, completionFromMatch, getCompletions, getExactCompletions, simpleExport) @@ -42,7 +43,6 @@ import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration, n import Language.PureScript.Ide.Usage (findUsages) import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist, doesFileExist) import System.FilePath ((), normalise) -import System.FilePath.Glob (glob) -- | Accepts a Command and runs it against psc-ide's State. This is the main -- entry point for the server. @@ -179,8 +179,14 @@ findAvailableExterns = do -- | Finds all matches for the globs specified at the commandline findAllSourceFiles :: Ide m => m [FilePath] findAllSourceFiles = do - globs <- confGlobs . ideConfiguration <$> ask - liftIO (concatMapM glob globs) + IdeConfiguration{..} <- ideConfiguration <$> ask + liftIO $ toInputGlobs $ PSCGlobs + { pscInputGlobs = confGlobs + , pscInputGlobsFromFile = confGlobsFromFile + , pscExcludeGlobs = confGlobsExclude + , pscWarnFileTypeNotFound = const $ pure () + } + -- | Looks up the ExternsFiles for the given Modulenames and loads them into the -- server state. Then proceeds to parse all the specified sourcefiles and diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index db17094a29..5fa304166b 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -162,6 +162,8 @@ data IdeConfiguration = { confOutputPath :: FilePath , confLogLevel :: IdeLogLevel , confGlobs :: [FilePath] + , confGlobsFromFile :: Maybe FilePath + , confGlobsExclude :: [FilePath] } data IdeEnvironment = diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index 7092b1cf53..17998d63d1 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -22,6 +22,8 @@ defConfig = { confLogLevel = LogNone , confOutputPath = "output/" , confGlobs = ["src/**/*.purs"] + , confGlobsFromFile = Nothing + , confGlobsExclude = [] } runIde' :: IdeConfiguration -> IdeState -> [Command] -> IO ([Either IdeError Success], IdeState) From 5589e81af15819023c60c99d3d10b8a19901e4e3 Mon Sep 17 00:00:00 2001 From: JordanMartinez Date: Wed, 7 Feb 2024 11:22:40 -0600 Subject: [PATCH 1565/1580] Prep 0.15.15 (#4533) * Drop old bug entry * Update version to 0.15.15 * Update changelog --- .../bug_fix-moveQuantifiersToFront-scoping.md | 23 --------- ...ature_add-exclude-file-to-more-commands.md | 5 -- CHANGELOG.d/feature_glob-input-files.md | 38 --------------- CHANGELOG.md | 47 +++++++++++++++++++ npm-package/package.json | 4 +- purescript.cabal | 2 +- 6 files changed, 50 insertions(+), 69 deletions(-) delete mode 100644 CHANGELOG.d/bug_fix-moveQuantifiersToFront-scoping.md delete mode 100644 CHANGELOG.d/feature_add-exclude-file-to-more-commands.md delete mode 100644 CHANGELOG.d/feature_glob-input-files.md diff --git a/CHANGELOG.d/bug_fix-moveQuantifiersToFront-scoping.md b/CHANGELOG.d/bug_fix-moveQuantifiersToFront-scoping.md deleted file mode 100644 index 5d701a22cb..0000000000 --- a/CHANGELOG.d/bug_fix-moveQuantifiersToFront-scoping.md +++ /dev/null @@ -1,23 +0,0 @@ -* Fix scoping issues in `moveQuantifiersToFront` - -As a side effect of replacing `UnusableDeclaration` with -an updated `NoInstanceFound` error, a bug appeared in how -scoping is handled when constraints are involved. - -```purs --- | a0 -class Foo a where --- | a1 - foo :: forall a. a -``` -Before this fix, `foo`'s type signature was being transformed to -`foo :: forall @a a. Foo a => a` -where two type variables with the same identifier -are present rather than the correct signature of -`foo :: forall @a0. Foo a0 => (forall a1. a1)`. - -With this fix, the above type class declaration -will now compile and trigger a `ShadowedName` -warning since the type class member's `a` -(i.e. `a1` above) shadows the type class head's `a` -(i.e. `a0` above). diff --git a/CHANGELOG.d/feature_add-exclude-file-to-more-commands.md b/CHANGELOG.d/feature_add-exclude-file-to-more-commands.md deleted file mode 100644 index b613e791c3..0000000000 --- a/CHANGELOG.d/feature_add-exclude-file-to-more-commands.md +++ /dev/null @@ -1,5 +0,0 @@ -* Add `--exclude-file` to more commands - - This CLI arg was added to the `compile` command, but not to other commands - where such a usage would be relevant (e.g. `docs`, `repl`, `graph`, and `ide`). - \ No newline at end of file diff --git a/CHANGELOG.d/feature_glob-input-files.md b/CHANGELOG.d/feature_glob-input-files.md deleted file mode 100644 index 076b94cf4c..0000000000 --- a/CHANGELOG.d/feature_glob-input-files.md +++ /dev/null @@ -1,38 +0,0 @@ -* Enable passing source input globs via `--source-globs-file path/to/file` - - `--source-globs-file` support has been added to the following commands: - `compile`, `docs`, `graph`, `ide`, and `publish`. - - Due to a [shell character limitation on Windows](https://learn.microsoft.com/en-us/troubleshoot/windows-client/shell-experience/command-line-string-limitation) where a large list of - source globs cannot be passed (e.g. `purs compile ... glob1000/src/**/*.purs`), - source globs can be stored in a file according to the format below - and the file is passed in instead via `purs compile ---source-globs-file path/to/file`. - - ``` - # Lines starting with '#' are comments. - # Blank lines are ignored. - # Otherwise, every line is a glob. - - .spago/foo-1.2.3/src/**/*.purs - .spago/bar-2.3.3/src/**/*.purs - my-package/src/**/*.purs - my-package/tests/**/*.purs - ``` - - `--source-globs-file` is an optional argument. Mixing it with the normal source globs is fine. - Assuming `.spago/source-globs` contains `src/**/*.purs`, each command below will use - the same input globs: - ```sh - purs compile src/**/*.purs - purs compile --source-globs .spago/source-globs - purs compile --source-globs .spago/source-globs src/**/*.purs - ``` - - In the command... - ``` - purs compile inputGlob1 inputGlob2 --source-globs-file fileWithMoreGlobs --exclude-files excludeGlob1 - ``` - the files passed to the compiler are: all the files found by - `inputGlob1`, `inputGlob2`, and all the globs listed in `fileWithMoreGlobs` - minus the files found by `excludeGlob1`. - \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md index 309b8ac703..27a87cc478 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,53 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.15 + +New features: + +* Add `--exclude-file` to more commands (#4530 by @JordanMartinez) + + This CLI arg was added to the `compile` command, but not to other commands + where such a usage would be relevant (e.g. `docs`, `repl`, `graph`, and `ide`). + +* Enable passing source input globs via `--source-globs-file path/to/file` (#4530 by @JordanMartinez) + + `--source-globs-file` support has been added to the following commands: + `compile`, `docs`, `graph`, `ide`, and `publish`. + + Due to a [shell character limitation on Windows](https://learn.microsoft.com/en-us/troubleshoot/windows-client/shell-experience/command-line-string-limitation) where a large list of + source globs cannot be passed (e.g. `purs compile ... glob1000/src/**/*.purs`), + source globs can be stored in a file according to the format below + and the file is passed in instead via `purs compile ---source-globs-file path/to/file`. + + ``` + # Lines starting with '#' are comments. + # Blank lines are ignored. + # Otherwise, every line is a glob. + + .spago/foo-1.2.3/src/**/*.purs + .spago/bar-2.3.3/src/**/*.purs + my-package/src/**/*.purs + my-package/tests/**/*.purs + ``` + + `--source-globs-file` is an optional argument. Mixing it with the normal source globs is fine. + Assuming `.spago/source-globs` contains `src/**/*.purs`, each command below will use + the same input globs: + ```sh + purs compile src/**/*.purs + purs compile --source-globs .spago/source-globs + purs compile --source-globs .spago/source-globs src/**/*.purs + ``` + + In the command... + ``` + purs compile inputGlob1 inputGlob2 --source-globs-file fileWithMoreGlobs --exclude-files excludeGlob1 + ``` + the files passed to the compiler are: all the files found by + `inputGlob1`, `inputGlob2`, and all the globs listed in `fileWithMoreGlobs` + minus the files found by `excludeGlob1`. + ## 0.15.14 Bugfixes: diff --git a/npm-package/package.json b/npm-package/package.json index 8470f00e4c..56772d2b55 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.14", + "version": "0.15.15", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.14", + "postinstall": "install-purescript --purs-ver=0.15.15", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index 5403791867..6550a803dd 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.14 +version: 0.15.15 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language From debfc2e4e1e859bde3f679850767acd545a0d0f4 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Tue, 27 Feb 2024 03:16:09 +0800 Subject: [PATCH 1566/1580] Fix compiler crash when a type operator is used in a type argument (#4536) Add missing traversal branch for VisibleTypeApp in updateTypes --- CHANGELOG.d/fix_issue-4535.md | 1 + src/Language/PureScript/Sugar/Operators.hs | 3 ++ tests/purs/passing/4535.purs | 43 ++++++++++++++++++++++ 3 files changed, 47 insertions(+) create mode 100644 CHANGELOG.d/fix_issue-4535.md create mode 100644 tests/purs/passing/4535.purs diff --git a/CHANGELOG.d/fix_issue-4535.md b/CHANGELOG.d/fix_issue-4535.md new file mode 100644 index 0000000000..77341885a9 --- /dev/null +++ b/CHANGELOG.d/fix_issue-4535.md @@ -0,0 +1 @@ +* Fix compiler crash when a type operator is used in a type argument diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index bb06486e82..93028d7e22 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -409,6 +409,9 @@ updateTypes goType = (goDecl, goExpr, goBinder) goExpr pos (TypedValue check v ty) = do ty' <- goType' pos ty return (pos, TypedValue check v ty') + goExpr pos (VisibleTypeApp v ty) = do + ty' <- goType' pos ty + return (pos, VisibleTypeApp v ty') goExpr pos other = return (pos, other) goBinder :: SourceSpan -> Binder -> m (SourceSpan, Binder) diff --git a/tests/purs/passing/4535.purs b/tests/purs/passing/4535.purs new file mode 100644 index 0000000000..424ba6e7e5 --- /dev/null +++ b/tests/purs/passing/4535.purs @@ -0,0 +1,43 @@ +module Main where + +import Prelude + +import Data.Maybe (Maybe(..)) +import Data.Tuple.Nested ((/\), type (/\)) +import Effect (Effect) +import Effect.Console (log) +import Type.Proxy (Proxy(..)) + +singleArgument :: forall @a. a -> Unit +singleArgument _ = unit + +multiArgument :: forall @a @b. a -> b -> Unit +multiArgument _ _ = unit + +singleApplication :: Int /\ Number -> Unit +singleApplication = singleArgument @(Int /\ Number) + +-- Like expression applications, visible type applications are left-associative. +-- This test accounts for subsequent type applications nested in this manner. +appNestingWorks :: Int /\ Number -> Number /\ Int -> Unit +appNestingWorks = multiArgument @(Int /\ Number) @(Number /\ Int) + +-- This test accounts for type applications nested within other AST nodes. +otherNestingWorks :: Array (Maybe (Int /\ Number)) +otherNestingWorks = [Just @(Int /\ Number) (0 /\ 0.0), Just @(Int /\ Number) (1 /\ 1.0)] + +type InSynonym = Int /\ Number + +-- This test accounts for type synonyms used as type arguments. +-- Since expansion happens during checking, InSynonym would expand +-- to an already-desugared type operator. This test exists for the +-- sake of redundancy. +inSynonym :: InSynonym -> Unit +inSynonym = singleArgument @InSynonym + +-- This test accounts for type operators used as type arguments directly. +operatorAsArgument :: Proxy (/\) +operatorAsArgument = Proxy @(/\) + +main :: Effect Unit +main = log "Done" From 851291e0fff69c24ef714f24653defa978c381e5 Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Tue, 16 Apr 2024 12:47:39 +0800 Subject: [PATCH 1567/1580] Upgrade to GHC 9.2.8 (#4537) * Update resolver to lts-20.26 * Update haskell/action to haskell-action --- .github/workflows/ci.yml | 8 ++++---- CHANGELOG.d/misc_ghc-bump.md | 1 + INSTALL.md | 4 ++-- purescript.cabal | 2 +- stack.yaml | 2 +- 5 files changed, 9 insertions(+), 8 deletions(-) create mode 100644 CHANGELOG.d/misc_ghc-bump.md diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 8efd13812b..25636a7a3c 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -32,7 +32,7 @@ defaults: env: CI_PRERELEASE: "${{ github.event_name == 'push' && github.ref == 'refs/heads/master' }}" CI_RELEASE: "${{ github.event_name == 'release' }}" - STACK_VERSION: "2.9.3" + STACK_VERSION: "2.15.1" concurrency: # We never want two prereleases building at the same time, since they would @@ -55,7 +55,7 @@ jobs: include: - # If upgrading the Haskell image, also upgrade it in the lint job below os: ["ubuntu-latest"] - image: haskell:9.2.5@sha256:2597b0e2458165a6635906204f7fac43c22e7d2a46aca1235a811194bb6cd419 + image: haskell:9.2.8@sha256:b3b2f3909c7381bb96b8f18766f9407a3d6f61e0f07ea95e812583ac4f442cbb - os: ["macOS-11"] - os: ["windows-2019"] - os: ["self-hosted", "macos", "ARM64"] @@ -99,7 +99,7 @@ jobs: # and their Haskell environment is instead provided by a nix-shell # See https://github.com/purescript/purescript/pulls/4455 if: "!contains(matrix.os, 'ubuntu-latest') && !contains(matrix.os, 'self-hosted')" - uses: "haskell/actions/setup@v1" + uses: "haskell-actions/setup@v2" with: enable-stack: true stack-version: "${{ env.STACK_VERSION }}" @@ -231,7 +231,7 @@ jobs: # means our published binaries will work on the widest number of platforms. # But the HLint binary downloaded by this job requires a newer glibc # version. - container: haskell:9.2.5@sha256:2597b0e2458165a6635906204f7fac43c22e7d2a46aca1235a811194bb6cd419 + container: haskell:9.2.8@sha256:b3b2f3909c7381bb96b8f18766f9407a3d6f61e0f07ea95e812583ac4f442cbb steps: - # We need a proper Git repository, but the checkout step will unpack a tarball instead of doing a clone diff --git a/CHANGELOG.d/misc_ghc-bump.md b/CHANGELOG.d/misc_ghc-bump.md new file mode 100644 index 0000000000..a1222cf6d0 --- /dev/null +++ b/CHANGELOG.d/misc_ghc-bump.md @@ -0,0 +1 @@ +* Update Stackage snapshot to lts-20.26 and GHC to 9.2.8 diff --git a/INSTALL.md b/INSTALL.md index 041cd3315d..0bccc516c7 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -4,12 +4,12 @@ If you are having difficulty installing the PureScript compiler, feel free to as ## Requirements -The PureScript compiler is built using GHC 9.2.5, and should be able to run on any operating system supported by GHC 9.2.5. In particular: +The PureScript compiler is built using GHC 9.2.8, and should be able to run on any operating system supported by GHC 9.2.8. In particular: * for Windows users, versions predating Vista are not officially supported, * for macOS / OS X users, versions predating Mac OS X 10.7 (Lion) are not officially supported. -See also for more details about the operating systems which GHC 9.2.5 supports. +See also for more details about the operating systems which GHC 9.2.8 supports. ## Official prebuilt binaries diff --git a/purescript.cabal b/purescript.cabal index 6550a803dd..0d32ce4814 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -119,7 +119,7 @@ common defaults TypeFamilies ViewPatterns build-tool-depends: - happy:happy ==1.20.0 + happy:happy ==1.20.1.1 build-depends: -- NOTE: Please do not edit these version constraints manually. They are -- deliberately made narrow because changing the dependency versions in diff --git a/stack.yaml b/stack.yaml index cbf7426e01..88b27b1a46 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ # Please update Haskell image versions under .github/workflows/ci.yml together to use the same GHC version # (or the CI build will fail) -resolver: lts-20.9 +resolver: lts-20.26 pvp-bounds: both packages: - '.' From 2070d479d133da9a7c33f7572ca7adb45a4c7aee Mon Sep 17 00:00:00 2001 From: Ryan Hendrickson Date: Tue, 16 Apr 2024 15:25:55 -0400 Subject: [PATCH 1568/1580] Remove Git upgrade step from CI (#4541) buster-backports no longer exists in debian/dists and it's breaking CI. The currently available version of Git in this container is 2.20.1, so we don't need this. --- .github/workflows/ci.yml | 16 ---------------- .../internal_remove-git-upgrade-step-in-ci.md | 1 + 2 files changed, 1 insertion(+), 16 deletions(-) create mode 100644 CHANGELOG.d/internal_remove-git-upgrade-step-in-ci.md diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 25636a7a3c..e2991a9118 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -69,15 +69,6 @@ jobs: version: "${{ steps.build.outputs.version }}" steps: - - # We need a proper Git repository, but the checkout step will unpack a tarball instead of doing a clone - # if the Git version is less than 2.18. - name: "(Linux only) Install a newer version of Git" - if: "contains(matrix.os, 'ubuntu-latest')" - run: | - . /etc/os-release - echo deb http://deb.debian.org/debian "$VERSION_CODENAME"-backports main >> /etc/apt/sources.list - apt-get update && apt-get install -y git/"$VERSION_CODENAME"-backports - - # We need `gh` installed on the Linux version. Otherwise, release artifacts won't be uploaded. name: "(Linux only) Install gh" if: "contains(matrix.os, 'ubuntu-latest')" @@ -234,13 +225,6 @@ jobs: container: haskell:9.2.8@sha256:b3b2f3909c7381bb96b8f18766f9407a3d6f61e0f07ea95e812583ac4f442cbb steps: - - # We need a proper Git repository, but the checkout step will unpack a tarball instead of doing a clone - # if the Git version is less than 2.18. - name: "Install a newer version of Git" - run: | - . /etc/os-release - echo deb http://deb.debian.org/debian "$VERSION_CODENAME"-backports main >> /etc/apt/sources.list - apt-get update && apt-get install -y git/"$VERSION_CODENAME"-backports - uses: "actions/checkout@v2" - name: "Fix working directory ownership" diff --git a/CHANGELOG.d/internal_remove-git-upgrade-step-in-ci.md b/CHANGELOG.d/internal_remove-git-upgrade-step-in-ci.md new file mode 100644 index 0000000000..f7f622a96e --- /dev/null +++ b/CHANGELOG.d/internal_remove-git-upgrade-step-in-ci.md @@ -0,0 +1 @@ +* Remove the step that upgraded Git from the CI workflow From 08b6c758b53fface1769c05ca8bcf119db5c114c Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Thu, 25 Jul 2024 01:10:02 +0300 Subject: [PATCH 1569/1580] Upgrade macOS runner to 14 (#4548) Since the beginning of July GitHub has deprecated the macOS-11 runners that we were using, see [the announcement](https://github.blog/changelog/2024-05-20-actions-upcoming-changes-to-github-hosted-macos-runners/) --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index e2991a9118..2cd314dbf1 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -56,7 +56,7 @@ jobs: - # If upgrading the Haskell image, also upgrade it in the lint job below os: ["ubuntu-latest"] image: haskell:9.2.8@sha256:b3b2f3909c7381bb96b8f18766f9407a3d6f61e0f07ea95e812583ac4f442cbb - - os: ["macOS-11"] + - os: ["macOS-14"] - os: ["windows-2019"] - os: ["self-hosted", "macos", "ARM64"] - os: ["self-hosted", "Linux", "ARM64"] From e06b9ccb7cbf31633d25e55531d70dcda7ec28b2 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Thu, 25 Jul 2024 01:50:43 +0200 Subject: [PATCH 1570/1580] Fix imports for newer mtl versions (#4547) Newer mtl does not re-export Control.Monad and Data.Monoid anymore. So we fix that by splitting the imports manually. --- app/Command/Docs.hs | 2 +- app/Command/Docs/Html.hs | 2 +- src/Control/Monad/Supply.hs | 3 ++- src/Language/PureScript/Errors.hs | 3 ++- src/Language/PureScript/Renamer.hs | 3 ++- src/Language/PureScript/Sugar/Operators/Common.hs | 2 +- src/Language/PureScript/TypeChecker/Entailment.hs | 6 ++++-- src/Language/PureScript/TypeChecker/Monad.hs | 3 ++- 8 files changed, 15 insertions(+), 9 deletions(-) diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index f0b6711b09..987023c98c 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -6,7 +6,7 @@ import Prelude import Command.Docs.Html (asHtml, writeHtmlModules) import Command.Docs.Markdown (asMarkdown, writeMarkdownModules) import Control.Applicative (Alternative(..), optional) -import Control.Monad.Writer (when) +import Control.Monad (when) import Control.Monad.Trans.Except (runExceptT) import Data.Maybe (fromMaybe) import Data.Text qualified as T diff --git a/app/Command/Docs/Html.hs b/app/Command/Docs/Html.hs index 6ad51041f3..116cf0f7a7 100644 --- a/app/Command/Docs/Html.hs +++ b/app/Command/Docs/Html.hs @@ -9,7 +9,7 @@ import Prelude import Control.Applicative (Alternative(..)) import Control.Arrow ((&&&)) -import Control.Monad.Writer (guard) +import Control.Monad (guard) import Data.List (sort) import Data.Text (Text) import Data.Text.Lazy (toStrict) diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs index 8c64fd2524..dd447a9c39 100644 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -7,7 +7,8 @@ import Prelude import Control.Applicative (Alternative) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Reader (MonadPlus, MonadReader, MonadTrans) +import Control.Monad.Reader (MonadReader, MonadTrans) +import Control.Monad (MonadPlus) import Control.Monad.State (StateT(..)) import Control.Monad.Writer (MonadWriter) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 56d962b3c7..6a15c3690c 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -13,7 +13,8 @@ import Control.Lens (both, head1, over) import Control.Monad (forM, unless) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.State.Lazy (State, evalState, get, put) -import Control.Monad.Writer (Last(..), MonadWriter(..), censor) +import Control.Monad.Writer (MonadWriter(..), censor) +import Data.Monoid (Last(..)) import Data.Bifunctor (first, second) import Data.Bitraversable (bitraverse) import Data.Char (isSpace) diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index a54e39f1e1..aff42ca288 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -5,7 +5,8 @@ module Language.PureScript.Renamer (renameInModule) where import Prelude -import Control.Monad.State (MonadState(..), State, gets, modify, runState, (>=>)) +import Control.Monad.State (MonadState(..), State, gets, modify, runState) +import Control.Monad ((>=>)) import Data.Functor ((<&>)) import Data.List (find) diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index 1a18f88014..7fd6df9645 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -2,7 +2,7 @@ module Language.PureScript.Sugar.Operators.Common where import Prelude -import Control.Monad.State (guard, join) +import Control.Monad (guard, join) import Control.Monad.Except (MonadError(..)) import Data.Either (rights) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 7a3872c1c8..85bdfee4aa 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -15,9 +15,11 @@ import Protolude (ordNub, headMay) import Control.Arrow (second, (&&&)) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State (MonadState(..), MonadTrans(..), StateT(..), evalStateT, execStateT, foldM, gets, guard, join, modify, zipWithM, zipWithM_, (<=<)) +import Control.Monad.State (MonadState(..), MonadTrans(..), StateT(..), evalStateT, execStateT, gets, modify) +import Control.Monad (foldM, guard, join, zipWithM, zipWithM_, (<=<)) import Control.Monad.Supply.Class (MonadSupply(..)) -import Control.Monad.Writer (Any(..), MonadWriter(..), WriterT(..)) +import Control.Monad.Writer (MonadWriter(..), WriterT(..)) +import Data.Monoid (Any(..)) import Data.Either (lefts, partitionEithers) import Data.Foldable (for_, fold, toList) diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index ba27d0299b..b6382e6707 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -9,7 +9,8 @@ import Prelude import Control.Arrow (second) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State (MonadState(..), StateT(..), forM_, gets, guard, join, modify, when, (<=<)) +import Control.Monad.State (MonadState(..), StateT(..), gets, modify) +import Control.Monad (forM_, guard, join, when, (<=<)) import Control.Monad.Writer.Class (MonadWriter(..), censor) import Data.Maybe (fromMaybe) From fc3fa8897916de1a3973de976eaea1fba23b4df9 Mon Sep 17 00:00:00 2001 From: Rory Campbell Date: Sun, 29 Sep 2024 07:55:41 +0200 Subject: [PATCH 1571/1580] IDE: don't force state results (#4546) --- CHANGELOG.d/fix_issue-4545.md | 1 + CONTRIBUTORS.md | 1 + src/Language/PureScript/Ide/Reexports.hs | 3 +-- src/Language/PureScript/Ide/State.hs | 9 +++----- src/Language/PureScript/Ide/Types.hs | 28 ++++++++++++------------ 5 files changed, 20 insertions(+), 22 deletions(-) create mode 100644 CHANGELOG.d/fix_issue-4545.md diff --git a/CHANGELOG.d/fix_issue-4545.md b/CHANGELOG.d/fix_issue-4545.md new file mode 100644 index 0000000000..1d6462ee9c --- /dev/null +++ b/CHANGELOG.d/fix_issue-4545.md @@ -0,0 +1 @@ +* Speed up IDE performance on large projects diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 7213ef9c67..aa5ddefd3f 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -167,6 +167,7 @@ If you would prefer to use different terms, please use the section below instead | [@woody88](https://github.com/woody88) | Woodson Delhia | [MIT license] | | [@xgrommx](https://github.com/xgrommx) | Denis Stoyanov | [MIT license] | | [@zudov](https://github.com/zudov) | Konstantin Zudov | [MIT license] | +| [@roryc89](https://github.com/roryc89) | Rory Campbell | [MIT license] | ### Contributors using Modified Terms diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs index a50b9de7a9..3da2a0a82e 100644 --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -35,9 +35,8 @@ data ReexportResult a = ReexportResult { reResolved :: a , reFailed :: [(P.ModuleName, P.DeclarationRef)] - } deriving (Show, Eq, Functor, Generic) + } deriving (Show, Eq, Functor) -instance NFData a => NFData (ReexportResult a) -- | Uses the passed formatter to format the resolved module, and adds possible -- failures diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 06eed507e4..32478d7000 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -54,7 +54,7 @@ import Language.PureScript.Ide.Externs (convertExterns) import Language.PureScript.Ide.Reexports (ReexportResult(..), prettyPrintReexportResult, reexportHasFailures, resolveReexports) import Language.PureScript.Ide.SourceFile (extractAstInformation) import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util (discardAnn, displayTimeSpec, logPerf, opNameT, properNameT, runLogger) +import Language.PureScript.Ide.Util (discardAnn, opNameT, properNameT, runLogger) import System.Directory (getModificationTime) -- | Resets all State inside psc-ide @@ -199,10 +199,7 @@ cachedRebuild = vsCachedRebuild <$> getVolatileState populateVolatileStateSync :: (Ide m, MonadLogger m) => m () populateVolatileStateSync = do st <- ideStateVar <$> ask - let message duration = "Finished populating volatile state in: " <> displayTimeSpec duration - results <- logPerf message $ do - !r <- liftIO (atomically (populateVolatileStateSTM st)) - pure r + results <- liftIO (atomically (populateVolatileStateSTM st)) void $ Map.traverseWithKey (\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn))) (Map.filter reexportHasFailures results) @@ -235,7 +232,7 @@ populateVolatileStateSTM ref = do & resolveOperators & resolveReexports reexportRefs setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) rebuildCache) - pure (force results) + pure results resolveLocations :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations) diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 5fa304166b..41532a3c51 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -31,43 +31,43 @@ data IdeDeclaration | IdeDeclValueOperator IdeValueOperator | IdeDeclTypeOperator IdeTypeOperator | IdeDeclModule P.ModuleName - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord) data IdeValue = IdeValue { _ideValueIdent :: P.Ident , _ideValueType :: P.SourceType - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord) data IdeType = IdeType { _ideTypeName :: P.ProperName 'P.TypeName , _ideTypeKind :: P.SourceType , _ideTypeDtors :: [(P.ProperName 'P.ConstructorName, P.SourceType)] - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord) data IdeTypeSynonym = IdeTypeSynonym { _ideSynonymName :: P.ProperName 'P.TypeName , _ideSynonymType :: P.SourceType , _ideSynonymKind :: P.SourceType - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord) data IdeDataConstructor = IdeDataConstructor { _ideDtorName :: P.ProperName 'P.ConstructorName , _ideDtorTypeName :: P.ProperName 'P.TypeName , _ideDtorType :: P.SourceType - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord) data IdeTypeClass = IdeTypeClass { _ideTCName :: P.ProperName 'P.ClassName , _ideTCKind :: P.SourceType , _ideTCInstances :: [IdeInstance] - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord) data IdeInstance = IdeInstance { _ideInstanceModule :: P.ModuleName , _ideInstanceName :: P.Ident , _ideInstanceTypes :: [P.SourceType] , _ideInstanceConstraints :: Maybe [P.SourceConstraint] - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord) data IdeValueOperator = IdeValueOperator { _ideValueOpName :: P.OpName 'P.ValueOpName @@ -75,7 +75,7 @@ data IdeValueOperator = IdeValueOperator , _ideValueOpPrecedence :: P.Precedence , _ideValueOpAssociativity :: P.Associativity , _ideValueOpType :: Maybe P.SourceType - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord) data IdeTypeOperator = IdeTypeOperator { _ideTypeOpName :: P.OpName 'P.TypeOpName @@ -83,7 +83,7 @@ data IdeTypeOperator = IdeTypeOperator , _ideTypeOpPrecedence :: P.Precedence , _ideTypeOpAssociativity :: P.Associativity , _ideTypeOpKind :: Maybe P.SourceType - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord) _IdeDeclValue :: Traversal' IdeDeclaration IdeValue _IdeDeclValue f (IdeDeclValue x) = map IdeDeclValue (f x) @@ -131,7 +131,7 @@ makeLenses ''IdeTypeOperator data IdeDeclarationAnn = IdeDeclarationAnn { _idaAnnotation :: Annotation , _idaDeclaration :: IdeDeclaration - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord) data Annotation = Annotation @@ -139,7 +139,7 @@ data Annotation , _annExportedFrom :: Maybe P.ModuleName , _annTypeAnnotation :: Maybe P.SourceType , _annDocumentation :: Maybe Text - } deriving (Show, Eq, Ord, Generic, NFData) + } deriving (Show, Eq, Ord) makeLenses ''Annotation makeLenses ''IdeDeclarationAnn @@ -152,7 +152,7 @@ type TypeAnnotations = Map P.Ident P.SourceType newtype AstData a = AstData (ModuleMap (DefinitionSites a, TypeAnnotations)) -- ^ SourceSpans for the definition sites of values and types as well as type -- annotations found in a module - deriving (Show, Eq, Ord, Generic, NFData, Functor, Foldable) + deriving (Show, Eq, Ord, Functor, Foldable) data IdeLogLevel = LogDebug | LogPerf | LogAll | LogDefault | LogNone deriving (Show, Eq) @@ -313,7 +313,7 @@ encodeImport (P.runModuleName -> mn, importType, map P.runModuleName -> qualifie -- | Denotes the different namespaces a name in PureScript can reside in. data IdeNamespace = IdeNSValue | IdeNSType | IdeNSModule - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord) instance FromJSON IdeNamespace where parseJSON = Aeson.withText "Namespace" $ \case @@ -324,4 +324,4 @@ instance FromJSON IdeNamespace where -- | A name tagged with a namespace data IdeNamespaced = IdeNamespaced IdeNamespace Text - deriving (Show, Eq, Ord, Generic, NFData) + deriving (Show, Eq, Ord) From 48be80d01d904bd3b2cf575ef0e61057c640ea22 Mon Sep 17 00:00:00 2001 From: Adrian Sieber <36796532+ad-si@users.noreply.github.com> Date: Thu, 10 Apr 2025 10:37:23 +0000 Subject: [PATCH 1572/1580] Upgrade to GHC 9.6.6 (#4568) * Upgrade CI * Back to the previous haskell image * Use new spavo * Upgrade node to latest supported lts * Upgrade to GHC 9.6.6 - Switch from `ansi-wl-pprint` to `prettyprinter` - Add several `extra-deps` * Upgrade CI to use GHC 9.6.6 * Upgrade GitHub Actions * CI: Upgrade to macos-15, specify exact version of Ubuntu * CI: Upgrade Stack from 2.15.1 to 3.3.1 * CI: Include stack.yaml.lock file and use it for the cache's file hashes * CI: Also include `purescript.cabal` in cache's file hashes * Update documentation * CI: Remove obsolete directory ownership changes * CI: Add safe.directory configuration for Ubuntu 24.04 * CI: Fix container ownership issues in workflow configuration * CI: Simplify container configuration and fix working directory ownership for Ubuntu 24.04 * Update version ranges of dependencies * Update Cabal version range and allow newer dependencies in stack configuration * Update Cabal version to 3.10.3.0 in stack configuration * Enable allow-newer option in stack configuration * Update dependency versions in purescript.cabal and stack.yaml * Update weeder installation and streamline CI workflow * Fix wrapping of run commands * Remove obsolete quotes * Add missing `--name` flag to `spago init` * Add Adrian Sieber to contributors * Add changelog entry for GHC upgrade * Use new weeder.toml config file format * Install missing `jq` dependency * CI: Use `-y` flag for all `apt-get install` runs * Vendor pattern-arrows * Run haskell container on ubuntu-latest, use macos-13 and macos-14 * CI: Use strings instead of arrays for matrix.os * Fix Hlint warnings * Add arm64 Linux to testing matrix * Correctly match only self-hosted Linux runner * Don't use self-hosted runners anymore, as GitHub runners cover all cases * Mention glibc bump from `2.28` to `2.31` in changelog * Upgrade to latest version of aeson-better-errors from Hackage * Remove obsolete `allow-newer` section, delete .stack-work on make clean * Re-add `allow-newer` block, improve dependency bounds * Downgrade haskeline to 0.8.2 to avoid libtinfo issues * Update aeson-better-errors and use cheapskate fork * Fix build errors in stack These errors are present in the Cabal build and seem to be caused by Cabal and Stack using different versions of mtl, with 2.3.x notably changing re-exports for certain modules. --------- Co-authored-by: Fabrizio Ferrai Co-authored-by: Justin Garcia --- .github/workflows/ci.yml | 121 +++++++----------- .gitignore | 1 - CHANGELOG.d/internal_upgrade_to_ghc_9.6.md | 2 + CONTRIBUTORS.md | 1 + INSTALL.md | 5 +- LICENSE | 24 ---- Makefile | 5 + app/Command/Docs.hs | 15 ++- app/Main.hs | 9 +- cabal.project | 5 + ci/build-package-set.sh | 16 +-- purescript.cabal | 47 +++---- src/Control/Monad/Supply/Class.hs | 2 + src/Control/PatternArrows.hs | 118 +++++++++++++++++ src/Language/PureScript/CodeGen/JS.hs | 1 - .../PureScript/CoreImp/Optimizer/TCO.hs | 2 +- .../Docs/RenderedCode/RenderType.hs | 4 +- src/Language/PureScript/Linter/Exhaustive.hs | 1 - src/Language/PureScript/Pretty/Types.hs | 4 +- .../PureScript/Sugar/BindingGroups.hs | 6 +- src/Language/PureScript/TypeChecker/Monad.hs | 1 + .../PureScript/TypeChecker/Synonyms.hs | 1 + stack.yaml | 30 ++--- stack.yaml.lock | 58 +++++++++ update-changelog.hs | 3 +- weeder.dhall | 41 ------ weeder.toml | 40 ++++++ 27 files changed, 347 insertions(+), 216 deletions(-) create mode 100644 CHANGELOG.d/internal_upgrade_to_ghc_9.6.md create mode 100644 src/Control/PatternArrows.hs create mode 100644 stack.yaml.lock delete mode 100644 weeder.dhall create mode 100644 weeder.toml diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 2cd314dbf1..3557db1a6f 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -20,6 +20,7 @@ on: - purescript.cabal - Setup.hs - stack.yaml + - stack.yaml.lock - update-changelog.hs - weeder.dhall release: @@ -32,7 +33,7 @@ defaults: env: CI_PRERELEASE: "${{ github.event_name == 'push' && github.ref == 'refs/heads/master' }}" CI_RELEASE: "${{ github.event_name == 'release' }}" - STACK_VERSION: "2.15.1" + STACK_VERSION: "3.3.1" concurrency: # We never want two prereleases building at the same time, since they would @@ -53,16 +54,18 @@ jobs: fail-fast: false # do not cancel builds for other OSes if one fails matrix: include: - - # If upgrading the Haskell image, also upgrade it in the lint job below - os: ["ubuntu-latest"] - image: haskell:9.2.8@sha256:b3b2f3909c7381bb96b8f18766f9407a3d6f61e0f07ea95e812583ac4f442cbb - - os: ["macOS-14"] - - os: ["windows-2019"] - - os: ["self-hosted", "macos", "ARM64"] - - os: ["self-hosted", "Linux", "ARM64"] + - image: haskell:9.6.6 # Also upgrade version in the lint job below + os: ubuntu-latest # Exact version is not important, as it's only the container host) + + - image: haskell:9.6.6 + os: ubuntu-24.04-arm # Exact version is not important, as it's only the container host + + - os: macos-13 # x64 + - os: macos-14 # arm64 + - os: windows-2019 # x64 runs-on: "${{ matrix.os }}" - container: "${{ matrix.image }}" + container: "${{ matrix.image }}" outputs: do-not-prerelease: "${{ steps.build.outputs.do-not-prerelease }}" @@ -71,43 +74,40 @@ jobs: steps: - # We need `gh` installed on the Linux version. Otherwise, release artifacts won't be uploaded. name: "(Linux only) Install gh" - if: "contains(matrix.os, 'ubuntu-latest')" + if: startsWith(matrix.image, 'haskell') run: | curl -fsSL https://cli.github.com/packages/githubcli-archive-keyring.gpg | dd of=/usr/share/keyrings/githubcli-archive-keyring.gpg chmod go+r /usr/share/keyrings/githubcli-archive-keyring.gpg echo "deb [arch=$(dpkg --print-architecture) signed-by=/usr/share/keyrings/githubcli-archive-keyring.gpg] https://cli.github.com/packages stable main" | tee /etc/apt/sources.list.d/github-cli.list > /dev/null apt-get update - apt-get install gh + apt-get install -y gh - - uses: "actions/checkout@v2" - - uses: "actions/setup-node@v2" + - uses: "actions/checkout@v4" + - uses: "actions/setup-node@v4" with: - node-version: "16" + node-version: "22" - id: "haskell" name: "(Non-Linux only) Install Haskell" - # Note: here we exclude the self-hosted runners because this action does not work on ARM - # and their Haskell environment is instead provided by a nix-shell - # See https://github.com/purescript/purescript/pulls/4455 - if: "!contains(matrix.os, 'ubuntu-latest') && !contains(matrix.os, 'self-hosted')" + if: startsWith(matrix.os, 'macos') || startsWith(matrix.os, 'windows') uses: "haskell-actions/setup@v2" with: + ghc-version: "9.6.6" enable-stack: true stack-version: "${{ env.STACK_VERSION }}" stack-no-global: true - - name: "(Linux only) Check Stack version and fix working directory ownership" - if: "contains(matrix.os, 'ubuntu-latest')" + - name: "(Linux only) Fix working directory ownership" + if: startsWith(matrix.image, 'haskell') run: | - [ "$(stack --numeric-version)" = "$STACK_VERSION" ] chown root:root . - - uses: "actions/cache@v2" + - uses: "actions/cache@v4" with: path: | /root/.stack ${{ steps.haskell.outputs.stack-root }} - key: "${{ matrix.image || runner.os }}--MdyPsf-${{ hashFiles('stack.yaml') }}" + key: "${{ matrix.image || runner.os }}--MdyPsf-${{ hashFiles('stack.yaml.lock', 'purescript.cabal') }}" - name: "(Windows only) Configure Stack to store its programs in STACK_ROOT" # This ensures that the local GHC and MSYS binaries that Stack installs @@ -122,16 +122,16 @@ jobs: run: "ci/fix-home ci/build.sh" - name: "(Linux only) Glob tests" - if: "contains(matrix.os, 'ubuntu-latest')" + if: startsWith(matrix.image, 'haskell') working-directory: "sdist-test" # We build in this directory in build.sh, so this is where we need to # launch `stack exec`. The actual glob checks happen in a temporary directory. run: | - apt-get install tree + apt-get install -y tree ../ci/fix-home stack exec bash ../glob-test.sh - name: "(Linux only) Build the entire package set" - if: "contains(matrix.os, 'ubuntu-latest')" + if: startsWith(matrix.image, 'haskell') # We build in this directory in build.sh, so this is where we need to # launch `stack exec`. The actual package-set building happens in a # temporary directory. @@ -144,11 +144,11 @@ jobs: # Moreover, npm has a hook issue that will cause spago to fail to install # We upgrade npm to fix this run: | - npm i -g npm@8.8.0 + apt-get install -y jq ../ci/fix-home stack --haddock exec ../ci/build-package-set.sh - name: Verify that 'libtinfo' isn't in binary - if: "runner.os == 'Linux'" + if: runner.os == 'Linux' working-directory: "sdist-test" run: | if [ $(ldd $(../ci/fix-home stack path --local-doc-root)/../bin/purs | grep 'libtinfo' | wc -l) -ge 1 ]; then @@ -157,17 +157,6 @@ jobs: exit 1 fi - - name: "(Self-hosted Linux ARM64 only) Patch the binary to work on non-Nix systems" - if: "runner.os == 'Linux' && runner.arch == 'ARM64'" - working-directory: "sdist-test" - # The self-hosted build happens inside a nix-shell that provides a working stack binary - # on ARM systems, and while the macOS binary is fine - because macOS binaries are almost - # statically linked), the linux ones are all pointing at the nix store. - # So here we first point the binary to the right linker that should work on a generic linux, - # and then fix the RUNPATH with the right location to load the shared libraries from - run: | - patchelf --set-interpreter /usr/lib/ld-linux-aarch64.so.1 --set-rpath /usr/lib/aarch64-linux-gnu $(stack path --local-doc-root)/../bin/purs - - name: "(Release/prerelease only) Create bundle" if: "${{ env.CI_RELEASE == 'true' || env.CI_PRERELEASE == 'true' && steps.build.outputs.do-not-prerelease != 'true' }}" run: | @@ -199,7 +188,7 @@ jobs: - name: "(Prerelease only) Upload bundle" if: "${{ env.CI_PRERELEASE == 'true' && steps.build.outputs.do-not-prerelease != 'true' }}" - uses: "actions/upload-artifact@v3" + uses: "actions/upload-artifact@v4.6.0" with: name: "${{ runner.os }}-${{ runner.arch }}-bundle" path: | @@ -208,59 +197,39 @@ jobs: - name: "(Release only) Publish bundle" if: "${{ env.CI_RELEASE == 'true' }}" - # This requires the gh command line tool to be installed on our - # self-hosted runners env: GITHUB_TOKEN: "${{ secrets.GITHUB_TOKEN }}" run: "gh release upload --clobber ${{ github.ref_name }} sdist-test/bundle/*.{tar.gz,sha}" lint: - runs-on: "ubuntu-latest" - # At the moment, this is a different image from the image used for - # compilation, though the GHC versions match. This is because the - # compilation image uses an old version of glibc, which we want because it - # means our published binaries will work on the widest number of platforms. - # But the HLint binary downloaded by this job requires a newer glibc - # version. - container: haskell:9.2.8@sha256:b3b2f3909c7381bb96b8f18766f9407a3d6f61e0f07ea95e812583ac4f442cbb + container: haskell:9.6.6 + runs-on: ubuntu-latest # Exact version is not important, as it's only the container host steps: - - uses: "actions/checkout@v2" + - uses: "actions/checkout@v4" - name: "Fix working directory ownership" run: | chown root:root . - - uses: "actions/cache@v2" + - uses: "actions/cache@v4" with: path: | /root/.stack - key: "lint-${{ hashFiles('stack.yaml') }}" + key: "lint-${{ hashFiles('stack.yaml.lock', 'purescript.cabal') }}" - run: "ci/fix-home ci/run-hlint.sh --git" env: VERSION: "3.5" - # Note: the weeder version will need to be updated when we next update our version - # of GHC. - # - # weeder-2.2.0 has somewhat strange version deps. It doesn't appear to - # support the exact versions of dhall and generic-lens in LTS-18. - # However, forcing it to use the versions of dhall and generic-lens in - # LTS-18 doesn't cause any problems when building, so the following - # commands build weeder while ignoring version constraints. - name: Install weeder run: | - # The `stack.yaml` file is copied to a separate file so that - # adding `allow-newer: true` doesn't affect any subsequant - # calls to `stack`. - cp stack.yaml stack-weeder.yaml - # `allow-newer: true` is needed so that weeder-2.2.0 can be - # installed with the dependencies present in LTS-18. - echo 'allow-newer: true' >> stack-weeder.yaml - ci/fix-home stack --no-terminal --jobs=2 build --copy-compiler-tool --stack-yaml ./stack-weeder.yaml weeder-2.4.0 + ci/fix-home stack --no-terminal --jobs=2 \ + build --copy-compiler-tool weeder-2.8.0 - - run: "ci/fix-home stack --no-terminal --jobs=2 build --fast --ghc-options -fwrite-ide-info" + - run: | + ci/fix-home stack --no-terminal --jobs=2 \ + build --fast --ghc-options -fwrite-ide-info - run: "ci/fix-home stack exec weeder" @@ -268,26 +237,28 @@ jobs: # reference from our test suite to count in the above check; the fact # that a function is tested is not evidence that it's needed. But we also # don't want to leave weeds lying around in our test suite either. - - run: "ci/fix-home stack --no-terminal --jobs=2 build --fast --test --no-run-tests --ghc-options -fwrite-ide-info" + - run: | + ci/fix-home stack --no-terminal --jobs=2 \ + build --fast --test --no-run-tests --ghc-options -fwrite-ide-info - run: "ci/fix-home stack exec weeder" make-prerelease: - runs-on: "ubuntu-latest" + runs-on: ubuntu-latest needs: - "build" - "lint" if: "${{ github.event_name == 'push' && needs.build.outputs.do-not-prerelease != 'true' }}" steps: - - uses: "actions/download-artifact@v3" + - uses: "actions/download-artifact@v4" - uses: "ncipollo/release-action@v1.10.0" with: tag: "v${{ needs.build.outputs.version }}" artifacts: "*-bundle/*" prerelease: true body: "This is an automated preview release. Get the latest stable release [here](https://github.com/purescript/purescript/releases/latest)." - - uses: "actions/checkout@v3" - - uses: "actions/setup-node@v3" + - uses: "actions/checkout@v4" + - uses: "actions/setup-node@v4" with: node-version: "16.x" registry-url: "https://registry.npmjs.org" diff --git a/.gitignore b/.gitignore index 0454beffcb..73b2b4678f 100644 --- a/.gitignore +++ b/.gitignore @@ -3,7 +3,6 @@ bin dist cabal-dev .cabal-sandbox -stack.yaml.lock cabal.sandbox.config dist-newstyle/ cabal.project.local* diff --git a/CHANGELOG.d/internal_upgrade_to_ghc_9.6.md b/CHANGELOG.d/internal_upgrade_to_ghc_9.6.md new file mode 100644 index 0000000000..6622b6baed --- /dev/null +++ b/CHANGELOG.d/internal_upgrade_to_ghc_9.6.md @@ -0,0 +1,2 @@ +* Upgrade GHC to [`9.6.6`](https://downloads.haskell.org/~ghc/9.6.6/docs/users_guide/9.6.6-notes.html), Stackage LTS `22.43` +* Minimum required glibc version is bumped from [`2.28` to `2.31`](https://sourceware.org/glibc/wiki/Glibc%20Timeline) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index aa5ddefd3f..cfbb98e362 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -16,6 +16,7 @@ If you would prefer to use different terms, please use the section below instead | :------- | :--- | :------ | | [@5outh](https://github.com/5outh) | Benjamin Kovach | [MIT license] | | [@actionshrimp](https://github.com/actionshrimp) | David Aitken | [MIT license] | +| [@ad-si](https://github.com/ad-si) | Adrian Sieber | [MIT license] | | [@adnelson](https://github.com/adnelson) | Allen Nelson | [MIT license] | | [@alexbiehl](https://github.com/alexbiehl) | Alexander Biehl | [MIT license] | | [@andreypopp](https://github.com/andreypopp) | Andrey Popp | [MIT license] | diff --git a/INSTALL.md b/INSTALL.md index 0bccc516c7..03f7748636 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -4,12 +4,13 @@ If you are having difficulty installing the PureScript compiler, feel free to as ## Requirements -The PureScript compiler is built using GHC 9.2.8, and should be able to run on any operating system supported by GHC 9.2.8. In particular: +The PureScript compiler is built using GHC 9.6.6, and should be able to run on any operating system supported by GHC 9.6.6. +In particular: * for Windows users, versions predating Vista are not officially supported, * for macOS / OS X users, versions predating Mac OS X 10.7 (Lion) are not officially supported. -See also for more details about the operating systems which GHC 9.2.8 supports. +See also for more details about the operating systems which GHC 9.6.6 supports. ## Official prebuilt binaries diff --git a/LICENSE b/LICENSE index 490ff3651c..713d3371a3 100644 --- a/LICENSE +++ b/LICENSE @@ -107,7 +107,6 @@ PureScript uses the following Haskell library packages. Their license files foll optparse-applicative parallel parsec - pattern-arrows pretty primitive process @@ -3186,29 +3185,6 @@ parsec LICENSE file: negligence or otherwise) arising in any way out of the use of this software, even if advised of the possibility of such damage. -pattern-arrows LICENSE file: - - The MIT License (MIT) - - Copyright (c) 2013 Phil Freeman - - Permission is hereby granted, free of charge, to any person obtaining a copy of - this software and associated documentation files (the "Software"), to deal in - the Software without restriction, including without limitation the rights to - use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of - the Software, and to permit persons to whom the Software is furnished to do so, - subject to the following conditions: - - The above copyright notice and this permission notice shall be included in all - copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS - FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR - COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER - IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN - CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - pretty LICENSE file: This library (libraries/pretty) is derived from code from diff --git a/Makefile b/Makefile index 53da1f3710..91235d9c8f 100644 --- a/Makefile +++ b/Makefile @@ -4,6 +4,7 @@ package = purescript exe_target = purs stack_yaml = STACK_YAML="stack.yaml" stack = $(stack_yaml) stack +stack_dir = .stack-work .DEFAULT_GOAL := help @@ -14,6 +15,10 @@ $(bin_dir)/hlint: ci/install-hlint.sh clean: ## Remove build artifacts rm -fr $(bin_dir) rm -fr $(build_dir) + rm -fr $(stack_dir) + rm -fr dist-newstyle + rm -fr .psci_modules + rm -fr .test_modules help: ## Print documentation @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs index 987023c98c..22bd6bdd3f 100644 --- a/app/Command/Docs.hs +++ b/app/Command/Docs.hs @@ -15,7 +15,8 @@ import Language.PureScript.Docs qualified as D import Language.PureScript.Docs.Tags (dumpCtags, dumpEtags) import Language.PureScript.Glob (PSCGlobs(..), toInputGlobs, warnFileTypeNotFound) import Options.Applicative qualified as Opts -import Text.PrettyPrint.ANSI.Leijen qualified as PP +import Prettyprinter qualified as PP +import Prettyprinter.Render.Terminal (AnsiStyle) import SharedCLI qualified import System.Directory (getCurrentDirectory, createDirectoryIfMissing, removeFile) import System.Exit (exitFailure) @@ -113,10 +114,10 @@ defaultOutputForFormat fmt = Ctags -> "tags" pscDocsOptions :: Opts.Parser PSCDocsOptions -pscDocsOptions = - PSCDocsOptions <$> format - <*> output - <*> compileOutputDir +pscDocsOptions = + PSCDocsOptions <$> format + <*> output + <*> compileOutputDir <*> many SharedCLI.inputFile <*> SharedCLI.globInputFile <*> many SharedCLI.excludeFiles @@ -150,9 +151,9 @@ infoModList :: Opts.InfoMod a infoModList = Opts.fullDesc <> footerInfo where footerInfo = Opts.footerDoc $ Just examples -examples :: PP.Doc +examples :: PP.Doc AnsiStyle examples = - PP.vcat $ map PP.text + PP.vcat [ "Examples:" , " write documentation for all modules to ./generated-docs:" , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\"" diff --git a/app/Main.hs b/app/Main.hs index c925a4a313..ff4e04ab6d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -13,9 +13,10 @@ import Command.REPL qualified as REPL import Control.Monad (join) import Data.Foldable (fold) import Options.Applicative qualified as Opts +import Prettyprinter qualified as Doc +import Prettyprinter.Render.Terminal (AnsiStyle) import System.Environment (getArgs) import System.IO qualified as IO -import Text.PrettyPrint.ANSI.Leijen qualified as Doc import Version (versionString) @@ -39,11 +40,11 @@ main = do "For example, `purs compile --help` displays options specific to the `compile` command." , Doc.hardline , Doc.hardline - , Doc.text $ "purs " ++ versionString + , Doc.pretty $ "purs " ++ versionString ] - para :: String -> Doc.Doc - para = foldr (Doc.) Doc.empty . map Doc.text . words + para :: String -> Doc.Doc AnsiStyle + para = foldr (\x y -> x <> Doc.softline <> y) mempty . map Doc.pretty . words -- | Displays full command help when invoked with no arguments. execParserPure :: Opts.ParserInfo a -> [String] -> Opts.ParserResult a diff --git a/cabal.project b/cabal.project index 51c7ecb87d..61c5c9bd35 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,7 @@ packages: purescript.cabal + +source-repository-package + type: git + location: https://github.com/purescript/cheapskate.git + tag: 8bfaf4beeb108e97a274ed51303f278905979e87 diff --git a/ci/build-package-set.sh b/ci/build-package-set.sh index 12a6fcb34c..f11b556871 100755 --- a/ci/build-package-set.sh +++ b/ci/build-package-set.sh @@ -5,7 +5,7 @@ shopt -s nullglob psroot=$(dirname "$(dirname "$(realpath "$0")")") -if [[ "${CI:-}" && "$(echo $psroot/CHANGELOG.d/breaking_*)" ]]; then +if [[ "${CI:-}" && "$(echo "$psroot"/CHANGELOG.d/breaking_*)" ]]; then echo "Skipping package-set build due to unreleased breaking changes" exit 0 fi @@ -16,23 +16,17 @@ export PATH="$tmpdir/node_modules/.bin:$PATH" cd "$tmpdir" echo ::group::Ensure Spago is available -which spago || npm install spago@0.20.8 +which spago || npm install spago@0.93.43 echo ::endgroup:: echo ::group::Create dummy project -echo 'let upstream = https://github.com/purescript/package-sets/releases/download/XXX/packages.dhall in upstream' > packages.dhall -echo '{ name = "my-project", dependencies = [] : List Text, packages = ./packages.dhall, sources = [] : List Text }' > spago.dhall -spago upgrade-set -# Override the `metadata` package's version to match `purs` version -# so that `spago build` actually works -sed -i'' "\$c in upstream with metadata.version = \"v$(purs --version | { read v z && echo $v; })\"" packages.dhall -spago install $(spago ls packages | while read name z; do if [[ $name != metadata ]]; then echo $name; fi; done) +spago init --name purescript-dummy echo ::endgroup:: echo ::group::Compile package set -spago build +spago ls packages --json | jq -r 'keys[]' | xargs spago install echo ::endgroup:: echo ::group::Document package set -spago docs --no-search +spago docs echo ::endgroup:: diff --git a/purescript.cabal b/purescript.cabal index 0d32ce4814..93b02ebbc9 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -153,18 +153,17 @@ common defaults -- modules must be parseable by this library otherwise the compiler -- will reject them. It should therefore always be pinned to a single -- specific version. - aeson >=2.0.3.0 && <2.1, - aeson-better-errors >=0.9.1.1 && <0.10, - ansi-terminal >=0.11.3 && <0.12, + aeson >=2.0.3.0 && <2.2, + aeson-better-errors >=0.9.1.3 && <0.10, + ansi-terminal >=0.11.3 && <1.1, array >=0.5.4.0 && <0.6, - base >=4.16.2.0 && <4.17, + base >=4.16.2.0 && <4.19, blaze-html >=0.9.1.2 && <0.10, bower-json >=1.1.0.0 && <1.2, boxes >=0.1.5 && <0.2, bytestring >=0.11.3.1 && <0.12, - Cabal >=3.6.3.0 && <3.7, + Cabal >=3.10.3.0 && <3.11, cborg >=0.2.7.0 && <0.3, - serialise >=0.2.5.0 && <0.3, cheapskate >=0.1.1.2 && <0.2, clock >=0.8.3 && <0.9, containers >=0.6.5.1 && <0.7, @@ -177,38 +176,38 @@ common defaults file-embed >=0.0.15.0 && <0.1, filepath >=1.4.2.2 && <1.5, Glob >=0.10.2 && <0.11, - haskeline >=0.8.2 && <0.9, + haskeline ==0.8.2, language-javascript ==0.7.0.0, - lens >=5.1.1 && <5.2, + lens >=5.1.1 && <5.3, lifted-async >=0.10.2.2 && <0.11, lifted-base >=0.2.3.12 && <0.3, - memory >=0.17.0 && <0.18, + memory >=0.17.0 && <0.19, monad-control >=1.0.3.1 && <1.1, monad-logger >=0.3.36 && <0.4, monoidal-containers >=0.6.2.0 && <0.7, - mtl >=2.2.2 && <2.3, + mtl >=2.2.2 && <2.4, parallel >=3.2.2.0 && <3.3, parsec >=3.1.15.0 && <3.2, - pattern-arrows >=0.0.2 && <0.1, - process ==1.6.13.1, + process >=1.6.19.0 && <1.7, protolude >=0.3.1 && <0.4, regex-tdfa >=1.3.1.2 && <1.4, safe >=0.3.19 && <0.4, scientific >=0.3.7.0 && <0.4, + semialign >=1.2.0.1 && <1.4, semigroups ==0.20.*, - semialign >=1.2.0.1 && <1.3, + serialise >=0.2.5.0 && <0.3, sourcemap >=0.1.7 && <0.2, stm >=2.5.0.2 && <2.6, stringsearch >=0.3.6.6 && <0.4, - template-haskell >=2.18.0.0 && <2.19, - text >=1.2.5.0 && <1.3, - these >=1.1.1.1 && <1.2, - time >=1.11.1.1 && <1.12, - transformers >=0.5.6.2 && <0.6, + template-haskell >=2.18.0.0 && <2.21, + text >=1.2.5.0 && <2.1, + these >=1.1.1.1 && <1.3, + time >=1.11.1.1 && <1.13, + transformers >=0.5.6.2 && <0.7, transformers-base >=0.4.6 && <0.5, utf8-string >=1.0.2 && <1.1, - vector >=0.12.3.1 && <0.13, - witherable >=0.4.2 && <0.5 + vector >=0.12.3.1 && <0.14, + witherable >=0.4.2 && <0.5, library import: defaults @@ -217,6 +216,7 @@ library Control.Monad.Logger Control.Monad.Supply Control.Monad.Supply.Class + Control.PatternArrows Language.PureScript Language.PureScript.AST Language.PureScript.AST.Binders @@ -403,10 +403,11 @@ executable purs main-is: Main.hs ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N -Wno-unused-packages build-depends: - ansi-wl-pprint >=0.6.9 && <0.7, + prettyprinter >=1.6 && <1.8, + prettyprinter-ansi-terminal >=1.1.1 && <1.2, exceptions >=0.10.4 && <0.11, network >=3.1.2.7 && <3.2, - optparse-applicative >=0.17.0.0 && <0.18, + optparse-applicative >=0.17.0.0 && <0.19, purescript if flag(release) cpp-options: -DRELEASE @@ -440,7 +441,7 @@ test-suite tests build-depends: purescript, generic-random >=1.5.0.1 && <1.6, - hspec >= 2.10.7 && < 3, + hspec >= 2.11.10 && < 3, HUnit >=1.6.2.0 && <1.7, newtype >=0.2.2.0 && <0.3, QuickCheck >=2.14.2 && <2.15, diff --git a/src/Control/Monad/Supply/Class.hs b/src/Control/Monad/Supply/Class.hs index e8656f0c69..b10b42d549 100644 --- a/src/Control/Monad/Supply/Class.hs +++ b/src/Control/Monad/Supply/Class.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeOperators #-} + -- | -- A class for monads supporting a supply of fresh names -- diff --git a/src/Control/PatternArrows.hs b/src/Control/PatternArrows.hs new file mode 100644 index 0000000000..b01d1cccdc --- /dev/null +++ b/src/Control/PatternArrows.hs @@ -0,0 +1,118 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.PatternArrows +-- Copyright : (c) Phil Freeman 2013 +-- License : MIT +-- +-- Maintainer : Phil Freeman +-- Stability : experimental +-- Portability : +-- +-- | +-- Arrows for Pretty Printing +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-} + +module Control.PatternArrows where + +import Prelude + +import Control.Arrow ((***), (<+>)) +import Control.Arrow qualified as A +import Control.Category ((>>>)) +import Control.Category qualified as C +import Control.Monad.State +import Control.Monad.Fix (fix) + +-- | +-- A first-order pattern match +-- +-- A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state. +-- +newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (A.Arrow, A.ArrowZero, A.ArrowPlus) + +instance C.Category (Pattern u) where + id = Pattern C.id + Pattern p1 . Pattern p2 = Pattern (p1 C.. p2) + +instance Functor (Pattern u a) where + fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p + +-- | +-- Run a pattern with an input and initial user state +-- +-- Returns Nothing if the pattern fails to match +-- +pattern_ :: Pattern u a b -> u -> a -> Maybe b +pattern_ p u = flip evalStateT u . A.runKleisli (runPattern p) + +-- | +-- Construct a pattern from a function +-- +mkPattern :: (a -> Maybe b) -> Pattern u a b +mkPattern f = Pattern $ A.Kleisli (lift . f) + +-- | +-- Construct a pattern from a stateful function +-- +mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b +mkPattern' = Pattern . A.Kleisli + +-- | +-- Construct a pattern which recursively matches on the left-hand-side +-- +chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r +chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f) + +-- | +-- Construct a pattern which recursively matches on the right-hand side +-- +chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r +chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f) + +-- | +-- Construct a pattern which recursively matches on one-side of a tuple +-- +wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r +wrap g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f) + +-- | +-- Construct a pattern which matches a part of a tuple +-- +split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r +split s f = s >>> A.arr (uncurry f) + +-- | +-- A table of operators +-- +data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] } + +-- | +-- An operator: +-- +-- [@AssocL@] A left-associative operator +-- +-- [@AssocR@] A right-associative operator +-- +-- [@Wrap@] A prefix-like or postfix-like operator +-- +-- [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand +-- +data Operator u a r where + AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r + AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r + Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r + Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r + +-- | +-- Build a pretty printer from an operator table and an indecomposable pattern +-- +buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r +buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \case + AssocL pat g -> chainl pat g p' + AssocR pat g -> chainr pat g p' + Wrap pat g -> wrap pat g p' + Split pat g -> split pat g + ) <+> p') p $ runOperatorTable table diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 14d122a37d..3a4e371187 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -9,7 +9,6 @@ module Language.PureScript.CodeGen.JS import Prelude import Protolude (ordNub) -import Control.Applicative (liftA2) import Control.Monad (forM, replicateM, void) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Reader (MonadReader, asks) diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index 34746ae3db..a1d4a47c2b 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -3,7 +3,7 @@ module Language.PureScript.CoreImp.Optimizer.TCO (tco) where import Prelude -import Control.Applicative (empty, liftA2) +import Control.Applicative (empty) import Control.Monad (guard) import Control.Monad.State (State, evalState, get, modify) import Data.Functor (($>), (<&>)) diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index a082b4b833..c6a985b09b 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -233,7 +233,7 @@ renderTypeWithRole = \case renderType' :: PrettyPrintType -> RenderedCode renderType' = fromMaybe (internalError "Incomplete pattern") - . PA.pattern matchType () + . PA.pattern_ matchType () renderTypeVars :: [(TypeVarVisibility, Text, Maybe PrettyPrintType)] -> RenderedCode renderTypeVars tyVars = mintersperse sp (map renderTypeVar tyVars) @@ -252,4 +252,4 @@ renderTypeAtom = renderTypeAtom' . convertPrettyPrintType maxBound renderTypeAtom' :: PrettyPrintType -> RenderedCode renderTypeAtom' = fromMaybe (internalError "Incomplete pattern") - . PA.pattern matchTypeAtom () + . PA.pattern_ matchTypeAtom () diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 697fefe8a0..eb03da41e0 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -11,7 +11,6 @@ module Language.PureScript.Linter.Exhaustive import Prelude import Protolude (ordNub) -import Control.Applicative (Applicative(..)) import Control.Arrow (first, second) import Control.Monad (unless) import Control.Monad.Writer.Class (MonadWriter(..)) diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 20de0ed9e2..9b3be46937 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -238,7 +238,7 @@ forall_ = mkPattern match typeAtomAsBox' :: PrettyPrintType -> Box typeAtomAsBox' = fromMaybe (internalError "Incomplete pattern") - . PA.pattern (matchTypeAtom defaultOptions) () + . PA.pattern_ (matchTypeAtom defaultOptions) () typeAtomAsBox :: Int -> Type a -> Box typeAtomAsBox maxDepth = typeAtomAsBox' . convertPrettyPrintType maxDepth @@ -280,7 +280,7 @@ unicodeOptions = TypeRenderOptions False True False typeAsBoxImpl :: TypeRenderOptions -> PrettyPrintType -> Box typeAsBoxImpl tro = fromMaybe (internalError "Incomplete pattern") - . PA.pattern (matchType tro) () + . PA.pattern_ (matchType tro) () -- | Generate a pretty-printed string representing a 'Type' prettyPrintType :: Int -> Type a -> String diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index d2f9aebf2b..835e775f81 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -114,8 +114,8 @@ createBindingGroups moduleName = mapM f <=< handleDecls valueDeclarationInfo = M.fromList $ swap <$> valueDeclarationKeys findDeclarationInfo i = (M.findWithDefault False i valueDeclarationInfo, i) - computeValueDependencies = (`intersect` valueDeclarationKeys) . fmap findDeclarationInfo . usedIdents moduleName - + computeValueDependencies = (`intersect` valueDeclarationKeys) . fmap findDeclarationInfo . usedIdents moduleName + makeValueDeclarationVert = (,,) <$> id <*> makeValueDeclarationKey <*> computeValueDependencies valueDeclarationVerts = makeValueDeclarationVert <$> values @@ -267,7 +267,7 @@ toDataBindingGroup -> m Declaration toDataBindingGroup (AcyclicSCC (d, _, _)) = return d toDataBindingGroup (CyclicSCC ds') - | Just kds@((ss, _):|_) <- nonEmpty $ concatMap (kindDecl . getDecl) ds' = throwError . errorMessage' ss . CycleInKindDeclaration $ fmap snd kds + | Just kds@((ss, _) :| _) <- nonEmpty $ concatMap (kindDecl . getDecl) ds' = throwError . errorMessage' ss . CycleInKindDeclaration $ fmap snd kds | not (null typeSynonymCycles) = throwError . MultipleErrors diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index b6382e6707..b33127200d 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} -- | -- Monads for type checking and type inference and associated data types diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 567ae415ef..8d2cf7886c 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} -- | -- Functions for replacing fully applied type synonyms diff --git a/stack.yaml b/stack.yaml index 88b27b1a46..afbac89bca 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ # Please update Haskell image versions under .github/workflows/ci.yml together to use the same GHC version # (or the CI build will fail) -resolver: lts-20.26 +resolver: lts-22.43 pvp-bounds: both packages: - '.' @@ -13,20 +13,14 @@ extra-deps: # `async` to be used as an object key: # https://github.com/erikd/language-javascript/issues/131 - language-javascript-0.7.0.0 -# Fix issue with libtinfo. -# See https://github.com/purescript/purescript/issues/4253 -- process-1.6.13.1 -# The Cabal library is not in Stackage -- Cabal-3.6.3.0 -# hspec versions 2.9.3 to 2.10.6 depend on ghc -# ghc depends on terminfo by default, but that can be ignored -# if one uses the '-terminfo' flag. -# Unfortunately, hspec doesn't expose a similar flag. -# -# Using hspec >= 2.10.7 addresses this. -- hspec-2.10.9 -- hspec-core-2.10.9 -- hspec-discover-2.10.9 +- bower-json-1.1.0.0 +- haskeline-0.8.2 +- these-1.2.1 +- aeson-better-errors-0.9.1.3 + +- github: purescript/cheapskate + commit: 8bfaf4beeb108e97a274ed51303f278905979e87 + nix: packages: - zlib @@ -37,8 +31,10 @@ nix: flags: aeson-pretty: lib-only: true - these: - assoc: false haskeline: # Avoids a libtinfo dynamic library dependency terminfo: false + +allow-newer: true +allow-newer-deps: +- haskeline diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000000..0af2cebb41 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,58 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/topics/lock_files + +packages: +- completed: + hackage: language-javascript-0.7.0.0@sha256:3eab0262b8ac5621936a4beab6a0f97d0e00a63455a8b0e3ac1547b4088dae7d,3898 + pantry-tree: + sha256: b0f28d836cb3fbde203fd7318a896c3a20acd8653a905e1950ae2d9a64bccebf + size: 2244 + original: + hackage: language-javascript-0.7.0.0 +- completed: + hackage: bower-json-1.1.0.0@sha256:a136aaca67bf0d15c336f5864f7e9d40ebe046ca2cb4b25bc4895617ea35f9f6,1864 + pantry-tree: + sha256: 3acd48e7012f246ad44c7c17cd6340362b1dc448c1d93156280814e76d9e0589 + size: 419 + original: + hackage: bower-json-1.1.0.0 +- completed: + hackage: haskeline-0.8.2@sha256:3b4b594095d64f5fa199b07bdca7d6b790313ed7f380a1b061845507e6563880,6005 + pantry-tree: + sha256: 17ee6b093c5135399b8e6bc3a63d9c6a4b0bc2100b495d2d974bc1464769de39 + size: 2955 + original: + hackage: haskeline-0.8.2 +- completed: + hackage: these-1.2.1@sha256:35c57aede96c15ea1fed559ac287b1168eb2b2869d79e62ed8c845780b7ea136,2294 + pantry-tree: + sha256: dc6366ac715dfdf5338a615f71b9ed0542c403a6afcbedcddbc879e947aea6b3 + size: 351 + original: + hackage: these-1.2.1 +- completed: + hackage: aeson-better-errors-0.9.1.3@sha256:1bfdda3982368cafc7317b9f0c1f7267a6b0bbac9515ae1fad37f2b19178f567,2071 + pantry-tree: + sha256: 1c14247866dfb8052506c179e4725b8a7ce1472a4fb227d61576d862d9494551 + size: 492 + original: + hackage: aeson-better-errors-0.9.1.3 +- completed: + name: cheapskate + pantry-tree: + sha256: a2253619f50d26f0137a802e51e5e7103ee52b1f71bc060d93a0979dcbefa2c8 + size: 12069 + sha256: 959fc7a6ca7e0a743b06b0c287aa4a1c3ec7fc740e5830a4a841d43e925a6d73 + size: 62502 + url: https://github.com/purescript/cheapskate/archive/8bfaf4beeb108e97a274ed51303f278905979e87.tar.gz + version: 0.1.1.2 + original: + url: https://github.com/purescript/cheapskate/archive/8bfaf4beeb108e97a274ed51303f278905979e87.tar.gz +snapshots: +- completed: + sha256: 08bd13ce621b41a8f5e51456b38d5b46d7783ce114a50ab604d6bbab0d002146 + size: 720271 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/43.yaml + original: lts-22.43 diff --git a/update-changelog.hs b/update-changelog.hs index b9296440d4..291160ceca 100755 --- a/update-changelog.hs +++ b/update-changelog.hs @@ -25,7 +25,8 @@ , RecordWildCards , TupleSections , ViewPatterns -#-} + #-} -- Hlint requires this leading space + -- | -- This script updates CHANGELOG.md with the contents of CHANGELOG.d, and -- empties CHANGELOG.d. It takes care of: diff --git a/weeder.dhall b/weeder.dhall deleted file mode 100644 index 95686c45e8..0000000000 --- a/weeder.dhall +++ /dev/null @@ -1,41 +0,0 @@ -{ roots = - [ "^Main\\.main$" - , "^PscIdeSpec\\.main$" - - -- These declarations are used in Pursuit. (The Types declarations are - -- reexported in the L.P.Docs module, and referenced from there, but Weeder - -- isn't that smart.) - , "^Language\\.PureScript\\.Docs\\.AsHtml\\.packageAsHtml$" - , "^Language\\.PureScript\\.Docs\\.Types\\.asUploadedPackage$" - , "^Language\\.PureScript\\.Docs\\.Types\\.getLink$" - , "^Language\\.PureScript\\.Docs\\.Types\\.getLinksContext$" - , "^Language\\.PureScript\\.Docs\\.Types\\.packageName$" - , "^Language\\.PureScript\\.Docs\\.Types\\.verifyPackage$" - - -- These declarations are believed to be used in other projects that we want - -- to continue to support. - , "^Language\\.PureScript\\.CoreFn\\.FromJSON\\.moduleFromJSON$" - , "^Language\\.PureScript\\.CST\\.Print\\.printModule$" - - -- These declarations are there to be used during development or testing. - , "^Language\\.PureScript\\.Ide\\.Imports\\.parseImport$" - , "^Language\\.PureScript\\.TypeChecker\\.Monad\\.debug" - - -- These declarations are used by Template Haskell code. - , "^Language\\.PureScript\\.Constants\\.TH\\." - - -- These declarations are produced by Template Haskell when generating - -- pattern synonyms; this confuses Weeder. - , "^Language\\.PureScript\\.Constants\\..*\\.\\$[bm]" - - -- These declarations are unprincipled exceptions that we don't mind - -- supporting just in case they're used now or in the future. - , "^Language\\.PureScript\\.CST\\.Parser\\.parseExpr$" - - -- These declarations are generated by tools; it doesn't matter if they're - -- unused because we can't do anything about them. - , "^Language\\.PureScript\\.CST\\.Parser\\.happy" - , "^Paths_purescript?\\." - ] -, type-class-roots = True -} diff --git a/weeder.toml b/weeder.toml new file mode 100644 index 0000000000..1a8249a2e2 --- /dev/null +++ b/weeder.toml @@ -0,0 +1,40 @@ +roots = [ + "^Main\\.main$", + "^PscIdeSpec\\.main$", + + # These declarations are used in Pursuit. (The Types declarations are + # reexported in the L.P.Docs module, and referenced from there, but Weeder + # isn't that smart.) + "^Language\\.PureScript\\.Docs\\.AsHtml\\.packageAsHtml$", + "^Language\\.PureScript\\.Docs\\.Types\\.asUploadedPackage$", + "^Language\\.PureScript\\.Docs\\.Types\\.getLink$", + "^Language\\.PureScript\\.Docs\\.Types\\.getLinksContext$", + "^Language\\.PureScript\\.Docs\\.Types\\.packageName$", + "^Language\\.PureScript\\.Docs\\.Types\\.verifyPackage$", + + # These declarations are believed to be used in other projects that we want + # to continue to support. + "^Language\\.PureScript\\.CoreFn\\.FromJSON\\.moduleFromJSON$", + "^Language\\.PureScript\\.CST\\.Print\\.printModule$", + + # These declarations are there to be used during development or testing. + "^Language\\.PureScript\\.Ide\\.Imports\\.parseImport$", + "^Language\\.PureScript\\.TypeChecker\\.Monad\\.debug", + + # These declarations are used by Template Haskell code. + "^Language\\.PureScript\\.Constants\\.TH\\.", + + # These declarations are produced by Template Haskell when generating + # pattern synonyms; this confuses Weeder. + "^Language\\.PureScript\\.Constants\\..*\\.\\$[bm]", + + # These declarations are unprincipled exceptions that we don't mind + # supporting just in case they're used now or in the future. + "^Language\\.PureScript\\.CST\\.Parser\\.parseExpr$", + + # These declarations are generated by tools; it doesn't matter if they're + # unused because we can't do anything about them. + "^Language\\.PureScript\\.CST\\.Parser\\.happy", + "^Paths_purescript?\\.", +] +type-class-roots = true From 377bdbde43d5aea46debbb9e90aa833ab6442f41 Mon Sep 17 00:00:00 2001 From: Adrian Sieber <36796532+ad-si@users.noreply.github.com> Date: Wed, 14 May 2025 19:21:26 +0000 Subject: [PATCH 1573/1580] Upgrade to GHC 9.8.4 (#4574) * Use latest HLint version in CI workflow * Upgrade to latest version of Cheapskate * Allow newer deps for weeder * Use `NonEmpty String` for `directiveStrings` --- .github/workflows/ci.yml | 10 +- CHANGELOG.d/internal_upgrade_to_ghc_9.8.md | 2 + INSTALL.md | 4 +- cabal.project | 2 +- purescript.cabal | 102 +++++++++--------- src/Language/PureScript/CST/Convert.hs | 5 +- src/Language/PureScript/CST/Monad.hs | 8 +- src/Language/PureScript/CST/Utils.hs | 13 ++- src/Language/PureScript/CodeGen/JS.hs | 5 +- .../PureScript/CoreImp/Optimizer/TCO.hs | 6 +- src/Language/PureScript/Docs/AsHtml.hs | 4 +- src/Language/PureScript/Docs/Types.hs | 2 +- .../PureScript/Interactive/Directive.hs | 35 +++--- src/Language/PureScript/Linter/Imports.hs | 6 +- src/Language/PureScript/Sugar/Names/Env.hs | 13 +-- .../PureScript/Sugar/Names/Exports.hs | 4 +- .../PureScript/Sugar/Names/Imports.hs | 4 +- src/Language/PureScript/Sugar/TypeClasses.hs | 3 +- src/Language/PureScript/TypeChecker.hs | 10 +- .../PureScript/TypeChecker/Deriving.hs | 3 +- .../PureScript/TypeChecker/Entailment.hs | 22 ++-- src/Language/PureScript/TypeChecker/Kinds.hs | 7 +- stack.yaml | 5 +- stack.yaml.lock | 18 ++-- tests/Main.hs | 2 + tests/TestDocs.hs | 3 +- tests/TestInteractive.hs | 97 +++++++++++++++++ 27 files changed, 259 insertions(+), 136 deletions(-) create mode 100644 CHANGELOG.d/internal_upgrade_to_ghc_9.8.md create mode 100644 tests/TestInteractive.hs diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 3557db1a6f..d3c9aca938 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -54,10 +54,10 @@ jobs: fail-fast: false # do not cancel builds for other OSes if one fails matrix: include: - - image: haskell:9.6.6 # Also upgrade version in the lint job below + - image: haskell:9.8.4 # Also upgrade version in the lint job below os: ubuntu-latest # Exact version is not important, as it's only the container host) - - image: haskell:9.6.6 + - image: haskell:9.8.4 os: ubuntu-24.04-arm # Exact version is not important, as it's only the container host - os: macos-13 # x64 @@ -92,7 +92,7 @@ jobs: if: startsWith(matrix.os, 'macos') || startsWith(matrix.os, 'windows') uses: "haskell-actions/setup@v2" with: - ghc-version: "9.6.6" + ghc-version: "9.8.4" enable-stack: true stack-version: "${{ env.STACK_VERSION }}" stack-no-global: true @@ -202,7 +202,7 @@ jobs: run: "gh release upload --clobber ${{ github.ref_name }} sdist-test/bundle/*.{tar.gz,sha}" lint: - container: haskell:9.6.6 + container: haskell:9.8.4 runs-on: ubuntu-latest # Exact version is not important, as it's only the container host steps: @@ -220,7 +220,7 @@ jobs: - run: "ci/fix-home ci/run-hlint.sh --git" env: - VERSION: "3.5" + VERSION: "3.10" - name: Install weeder run: | diff --git a/CHANGELOG.d/internal_upgrade_to_ghc_9.8.md b/CHANGELOG.d/internal_upgrade_to_ghc_9.8.md new file mode 100644 index 0000000000..7f3fb0e074 --- /dev/null +++ b/CHANGELOG.d/internal_upgrade_to_ghc_9.8.md @@ -0,0 +1,2 @@ +* Upgrade GHC to [`9.8.4`](https://downloads.haskell.org/~ghc/9.8.4/docs/users_guide/9.8.4-notes.html), Stackage LTS `23.18` +* Use [HLint 3.10](https://github.com/ndmitchell/hlint/blob/master/CHANGES.txt) in CI diff --git a/INSTALL.md b/INSTALL.md index 03f7748636..6854652cb3 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -4,13 +4,13 @@ If you are having difficulty installing the PureScript compiler, feel free to as ## Requirements -The PureScript compiler is built using GHC 9.6.6, and should be able to run on any operating system supported by GHC 9.6.6. +The PureScript compiler is built using GHC 9.8.4, and should be able to run on any operating system supported by GHC 9.8.4. In particular: * for Windows users, versions predating Vista are not officially supported, * for macOS / OS X users, versions predating Mac OS X 10.7 (Lion) are not officially supported. -See also for more details about the operating systems which GHC 9.6.6 supports. +See also for more details about the operating systems which GHC 9.8.4 supports. ## Official prebuilt binaries diff --git a/cabal.project b/cabal.project index 61c5c9bd35..453d64732d 100644 --- a/cabal.project +++ b/cabal.project @@ -4,4 +4,4 @@ packages: source-repository-package type: git location: https://github.com/purescript/cheapskate.git - tag: 8bfaf4beeb108e97a274ed51303f278905979e87 + tag: 633c69024e061ad956f1aecfc137fb99a7a7a20b diff --git a/purescript.cabal b/purescript.cabal index 93b02ebbc9..5cecca41fc 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -86,6 +86,7 @@ common defaults -Wno-missing-export-lists -Wno-missing-kind-signatures -Wno-partial-fields + -Wno-missing-role-annotations default-language: Haskell2010 default-extensions: BangPatterns @@ -118,8 +119,6 @@ common defaults TupleSections TypeFamilies ViewPatterns - build-tool-depends: - happy:happy ==1.20.1.1 build-depends: -- NOTE: Please do not edit these version constraints manually. They are -- deliberately made narrow because changing the dependency versions in @@ -153,61 +152,61 @@ common defaults -- modules must be parseable by this library otherwise the compiler -- will reject them. It should therefore always be pinned to a single -- specific version. - aeson >=2.0.3.0 && <2.2, + aeson >=2.2.3.0 && <2.3, aeson-better-errors >=0.9.1.3 && <0.10, - ansi-terminal >=0.11.3 && <1.1, - array >=0.5.4.0 && <0.6, - base >=4.16.2.0 && <4.19, - blaze-html >=0.9.1.2 && <0.10, + ansi-terminal >=1.1.2 && <1.2, + array >=0.5.8.0 && <0.6, + base >=4.19.2.0 && <4.20, + blaze-html >=0.9.2.0 && <0.10, bower-json >=1.1.0.0 && <1.2, boxes >=0.1.5 && <0.2, - bytestring >=0.11.3.1 && <0.12, + bytestring >=0.12.1.0 && <0.13, Cabal >=3.10.3.0 && <3.11, - cborg >=0.2.7.0 && <0.3, + cborg >=0.2.10.0 && <0.3, cheapskate >=0.1.1.2 && <0.2, - clock >=0.8.3 && <0.9, - containers >=0.6.5.1 && <0.7, - cryptonite ==0.30.*, + clock >=0.8.4 && <0.9, + containers >=0.6.8 && <0.7, + cryptonite >=0.30 && <0.31, data-ordlist >=0.4.7.0 && <0.5, - deepseq >=1.4.6.1 && <1.5, - directory >=1.3.6.2 && <1.4, - dlist ==1.0.*, + deepseq >=1.5.1.0 && <1.6, + directory >=1.3.8.5 && <1.4, + dlist >=1.0 && <1.1, edit-distance >=0.2.2.1 && <0.3, - file-embed >=0.0.15.0 && <0.1, - filepath >=1.4.2.2 && <1.5, + file-embed >=0.0.16.0 && <0.1, + filepath >=1.4.301.0 && <1.5, Glob >=0.10.2 && <0.11, haskeline ==0.8.2, language-javascript ==0.7.0.0, - lens >=5.1.1 && <5.3, - lifted-async >=0.10.2.2 && <0.11, + lens >=5.3.4 && <5.4, + lifted-async >=0.10.2.7 && <0.11, lifted-base >=0.2.3.12 && <0.3, - memory >=0.17.0 && <0.19, + memory >=0.18.0 && <0.19, monad-control >=1.0.3.1 && <1.1, - monad-logger >=0.3.36 && <0.4, - monoidal-containers >=0.6.2.0 && <0.7, - mtl >=2.2.2 && <2.4, + monad-logger >=0.3.42 && <0.4, + monoidal-containers >=0.6.6.0 && <0.7, + mtl >=2.3.1 && <2.4, parallel >=3.2.2.0 && <3.3, - parsec >=3.1.15.0 && <3.2, - process >=1.6.19.0 && <1.7, - protolude >=0.3.1 && <0.4, - regex-tdfa >=1.3.1.2 && <1.4, - safe >=0.3.19 && <0.4, - scientific >=0.3.7.0 && <0.4, - semialign >=1.2.0.1 && <1.4, - semigroups ==0.20.*, - serialise >=0.2.5.0 && <0.3, + parsec >=3.1.17.0 && <3.2, + process >=1.6.25.0 && <1.7, + protolude >=0.3.4 && <0.4, + regex-tdfa >=1.3.2.3 && <1.4, + safe >=0.3.21 && <0.4, + scientific >=0.3.8.0 && <0.4, + semialign >=1.3.1 && <1.4, + semigroups >=0.20 && <0.21, + serialise >=0.2.6.1 && <0.3, sourcemap >=0.1.7 && <0.2, - stm >=2.5.0.2 && <2.6, + stm >=2.5.3.1 && <2.6, stringsearch >=0.3.6.6 && <0.4, - template-haskell >=2.18.0.0 && <2.21, - text >=1.2.5.0 && <2.1, - these >=1.1.1.1 && <1.3, - time >=1.11.1.1 && <1.13, - transformers >=0.5.6.2 && <0.7, + template-haskell >=2.21.0.0 && <2.22, + text >=2.1.1 && <2.2, + these >=1.2.1 && <1.3, + time >=1.12.2 && <1.13, + transformers >=0.6.1.0 && <0.7, transformers-base >=0.4.6 && <0.5, utf8-string >=1.0.2 && <1.1, - vector >=0.12.3.1 && <0.14, - witherable >=0.4.2 && <0.5, + vector >=0.13.2.0 && <0.14, + witherable >=0.5 && <0.6, library import: defaults @@ -403,17 +402,17 @@ executable purs main-is: Main.hs ghc-options: -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N -Wno-unused-packages build-depends: - prettyprinter >=1.6 && <1.8, - prettyprinter-ansi-terminal >=1.1.1 && <1.2, - exceptions >=0.10.4 && <0.11, - network >=3.1.2.7 && <3.2, - optparse-applicative >=0.17.0.0 && <0.19, + prettyprinter >=1.7.1 && <1.8, + prettyprinter-ansi-terminal >=1.1.3 && <1.2, + exceptions >=0.10.7 && <0.11, + network >=3.2.7.0 && <3.3, + optparse-applicative >=0.18.1.0 && <0.19, purescript if flag(release) cpp-options: -DRELEASE else build-depends: - gitrev >=1.2.0 && <1.4 + gitrev >=1.3.1 && <1.4, other-modules: Command.Bundle Command.Compile @@ -441,13 +440,13 @@ test-suite tests build-depends: purescript, generic-random >=1.5.0.1 && <1.6, - hspec >= 2.11.10 && < 3, + hspec >=2.11.12 && <2.12, HUnit >=1.6.2.0 && <1.7, newtype >=0.2.2.0 && <0.3, - QuickCheck >=2.14.2 && <2.15, - regex-base >=0.94.0.2 && <0.95, - split >=0.2.3.4 && <0.3, - typed-process >=0.2.10.1 && <0.3 + QuickCheck >=2.14.3 && <2.15, + regex-base >=0.94.0.3 && <0.95, + split >=0.2.5 && <0.3, + typed-process >=0.2.12.0 && <0.3, build-tool-depends: hspec-discover:hspec-discover -any -- we need the compiler's executable available for the ide tests @@ -472,6 +471,7 @@ test-suite tests TestGraph TestHierarchy TestIde + TestInteractive TestMake TestPrimDocs TestPsci diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index c75d333dcc..59b68adf1d 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -16,6 +16,7 @@ module Language.PureScript.CST.Convert ) where import Prelude hiding (take) +import Protolude (headDef) import Data.Bifunctor (bimap, first) import Data.Char (toLower) @@ -446,7 +447,7 @@ convertDeclaration :: String -> Declaration a -> [AST.Declaration] convertDeclaration fileName decl = case decl of DeclData _ (DataHead _ a vars) bd -> do let - ctrs :: SourceToken -> DataCtor a -> [(SourceToken, DataCtor a)] -> [AST.DataConstructorDeclaration] + ctrs :: SourceToken -> DataCtor b -> [(SourceToken, DataCtor b)] -> [AST.DataConstructorDeclaration] ctrs st (DataCtor _ name fields) tl = AST.DataConstructorDeclaration (sourceAnnCommented fileName st (nameTok name)) (nameValue name) (zip ctrFields $ convertType fileName <$> fields) : (case tl of @@ -460,7 +461,7 @@ convertDeclaration fileName decl = case decl of (goTypeVar <$> vars) (convertType fileName bd) DeclNewtype _ (DataHead _ a vars) st x ys -> do - let ctrs = [AST.DataConstructorDeclaration (sourceAnnCommented fileName st (snd $ declRange decl)) (nameValue x) [(head ctrFields, convertType fileName ys)]] + let ctrs = [AST.DataConstructorDeclaration (sourceAnnCommented fileName st (snd $ declRange decl)) (nameValue x) [(headDef (internalError "No constructor name") ctrFields, convertType fileName ys)]] pure $ AST.DataDeclaration ann Env.Newtype (nameValue a) (goTypeVar <$> vars) ctrs DeclClass _ (ClassHead _ sup name vars fdeps) bd -> do let diff --git a/src/Language/PureScript/CST/Monad.hs b/src/Language/PureScript/CST/Monad.hs index 31887c890a..2b79f1a9b3 100644 --- a/src/Language/PureScript/CST/Monad.hs +++ b/src/Language/PureScript/CST/Monad.hs @@ -102,9 +102,11 @@ mkParserError stack toks ty = , errType = ty } where - range = case toks of - [] -> SourceRange (SourcePos 0 0) (SourcePos 0 0) - _ -> widen (tokRange . tokAnn $ head toks) (tokRange . tokAnn $ last toks) + range = case NE.nonEmpty toks of + Nothing -> SourceRange (SourcePos 0 0) (SourcePos 0 0) + Just neToks -> widen + (tokRange . tokAnn $ NE.head neToks) + (tokRange . tokAnn $ NE.last neToks) addFailure :: [SourceToken] -> ParserErrorType -> Parser () addFailure toks ty = Parser $ \st _ ksucc -> diff --git a/src/Language/PureScript/CST/Utils.hs b/src/Language/PureScript/CST/Utils.hs index b941cf5fcf..68dcf7d87c 100644 --- a/src/Language/PureScript/CST/Utils.hs +++ b/src/Language/PureScript/CST/Utils.hs @@ -1,6 +1,7 @@ module Language.PureScript.CST.Utils where import Prelude +import Protolude (headDef) import Control.Monad (unless) import Data.Coerce (coerce) @@ -86,16 +87,20 @@ unexpectedLabel :: SourceToken -> Label unexpectedLabel tok = Label tok "" unexpectedExpr :: Monoid a => [SourceToken] -> Expr a -unexpectedExpr toks = ExprIdent mempty (unexpectedQual (head toks)) +unexpectedExpr toks = + ExprIdent mempty (unexpectedQual (headDef placeholder toks)) unexpectedBinder :: Monoid a => [SourceToken] -> Binder a -unexpectedBinder toks = BinderVar mempty (unexpectedName (head toks)) +unexpectedBinder toks = + BinderVar mempty (unexpectedName (headDef placeholder toks)) unexpectedRecordUpdate :: Monoid a => [SourceToken] -> RecordUpdate a -unexpectedRecordUpdate toks = RecordUpdateLeaf (unexpectedLabel (head toks)) (head toks) (unexpectedExpr toks) +unexpectedRecordUpdate toks = + RecordUpdateLeaf (unexpectedLabel (headDef placeholder toks)) (headDef placeholder toks) (unexpectedExpr toks) unexpectedRecordLabeled :: [SourceToken] -> RecordLabeled a -unexpectedRecordLabeled toks = RecordPun (unexpectedName (head toks)) +unexpectedRecordLabeled toks = + RecordPun (unexpectedName (headDef placeholder toks)) rangeToks :: TokenRange -> [SourceToken] rangeToks (a, b) = [a, b] diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 3a4e371187..890cc1cd27 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -7,7 +7,7 @@ module Language.PureScript.CodeGen.JS ) where import Prelude -import Protolude (ordNub) +import Protolude (ordNub, headDef) import Control.Monad (forM, replicateM, void) import Control.Monad.Except (MonadError, throwError) @@ -310,7 +310,8 @@ moduleBindToJs mn = bindToJs let (f, args) = unApp e [] args' <- mapM valueToJs args case f of - Var (_, _, Just IsNewtype) _ -> return (head args') + Var (_, _, Just IsNewtype) _ -> + return (headDef (internalError "Newtype constructor without constructor name") args') Var (_, _, Just (IsConstructor _ fields)) name | length args == length fields -> return $ AST.Unary Nothing AST.New $ AST.App Nothing (qualifiedToJS id name) args' _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToJs f diff --git a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs index a1d4a47c2b..db133f5ac8 100644 --- a/src/Language/PureScript/CoreImp/Optimizer/TCO.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/TCO.hs @@ -5,8 +5,8 @@ import Prelude import Control.Applicative (empty) import Control.Monad (guard) -import Control.Monad.State (State, evalState, get, modify) -import Data.Functor (($>), (<&>)) +import Control.Monad.State (State, evalState, gets, modify) +import Data.Functor (($>)) import Data.Set qualified as S import Data.Text (Text, pack) import Language.PureScript.CoreImp.AST (AST(..), InitializerEffects(..), UnaryOperator(..), everything, everywhereTopDownM) @@ -23,7 +23,7 @@ tco = flip evalState 0 . everywhereTopDownM convert where copyVar arg = "$copy_" <> arg tcoDoneM :: State Int Text - tcoDoneM = get <&> \count -> "$tco_done" <> + tcoDoneM = gets $ \count -> "$tco_done" <> if count == 0 then "" else pack . show $ count tcoLoop :: Text diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index e4460183af..e03ccabc31 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -67,7 +67,7 @@ nullRenderContext = HtmlRenderContext packageAsHtml :: (InPackage P.ModuleName -> Maybe HtmlRenderContext) - -> Package a + -> Package x -> HtmlOutput Html packageAsHtml getHtmlCtx Package{..} = HtmlOutput indexFile modules @@ -242,7 +242,7 @@ codeAsHtml r = outputWith elemAsHtml isOp = isRight . runParser CST.parseOperator - runParser :: CST.Parser a -> Text -> Either String a + runParser :: CST.Parser x -> Text -> Either String x runParser p' = bimap (CST.prettyPrintError . NE.head) snd . CST.runTokenParser p' diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index c4e6cbecaa..ea13066556 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -875,7 +875,7 @@ instance A.ToJSON a => A.ToJSON (InPackage a) where Local y -> withPackage (Nothing :: Maybe ()) y FromDep pn y -> withPackage (Just pn) y where - withPackage :: (A.ToJSON p, A.ToJSON x) => p -> x -> A.Value + withPackage :: (A.ToJSON p, A.ToJSON y) => p -> y -> A.Value withPackage p y = A.object [ "package" .= p , "item" .= y diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs index 4a75f0f362..a8a0ce1307 100644 --- a/src/Language/PureScript/Interactive/Directive.hs +++ b/src/Language/PureScript/Interactive/Directive.hs @@ -8,6 +8,8 @@ import Prelude import Data.Maybe (fromJust) import Data.List (isPrefixOf) import Data.Tuple (swap) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty qualified as NEL import Language.PureScript.Interactive.Types (Directive(..)) @@ -15,40 +17,40 @@ import Language.PureScript.Interactive.Types (Directive(..)) -- A mapping of directives to the different strings that can be used to invoke -- them. -- -directiveStrings :: [(Directive, [String])] +directiveStrings :: [(Directive, NonEmpty String)] directiveStrings = - [ (Help , ["?", "help"]) - , (Quit , ["quit"]) - , (Reload , ["reload"]) - , (Clear , ["clear"]) - , (Browse , ["browse"]) - , (Type , ["type"]) - , (Kind , ["kind"]) - , (Show , ["show"]) - , (Paste , ["paste"]) - , (Complete , ["complete"]) - , (Print , ["print"]) + [ (Help , NEL.fromList ["?", "help"]) + , (Quit , NEL.singleton "quit") + , (Reload , NEL.singleton "reload") + , (Clear , NEL.singleton "clear") + , (Browse , NEL.singleton "browse") + , (Type , NEL.singleton "type") + , (Kind , NEL.singleton "kind") + , (Show , NEL.singleton "show") + , (Paste , NEL.singleton "paste") + , (Complete , NEL.singleton "complete") + , (Print , NEL.singleton "print") ] -- | --- Like directiveStrings, but the other way around. +-- Like `directiveStrings`, but the other way around. -- directiveStrings' :: [(String, Directive)] directiveStrings' = concatMap go directiveStrings where - go (dir, strs) = map (, dir) strs + go (dir, strs) = map (, dir) $ NEL.toList strs -- | -- Returns all possible string representations of a directive. -- -stringsFor :: Directive -> [String] +stringsFor :: Directive -> NonEmpty String stringsFor d = fromJust (lookup d directiveStrings) -- | -- Returns the default string representation of a directive. -- stringFor :: Directive -> String -stringFor = head . stringsFor +stringFor = NEL.head . stringsFor -- | -- Returns the list of directives which could be expanded from the string @@ -84,4 +86,3 @@ help = , (Complete, "", "Show completions for as if pressing tab") , (Print, "", "Set the repl's printing function to (which must be fully qualified)") ] - diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index e8a2eb0f2c..10f0aec7a7 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -5,7 +5,7 @@ module Language.PureScript.Linter.Imports ) where import Prelude -import Protolude (ordNub) +import Protolude (ordNub, tailDef, headDef) import Control.Monad (join, unless, foldM, (<=<)) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -91,7 +91,7 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do let unwarned = imps \\ warned duplicates = join - . map tail + . map (tailDef $ internalError "lintImports: duplicates") . filter ((> 1) . length) . groupBy ((==) `on` defQual) . sortOn defQual @@ -195,7 +195,7 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do Just (Qualified _ name) -> Just (k, Qualified mnq (toName name)) _ -> Nothing | isQualifiedWith k q = - case importName (head is) of + case importName (headDef (internalError "extractByQual: empty import list") is) of Qualified (ByModuleName mn') name -> Just (mn', Qualified mnq (toName name)) _ -> internalError "unqualified name in extractByQual" go _ = Nothing diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 2ab8b00d5c..092b8e2478 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -20,7 +20,7 @@ module Language.PureScript.Sugar.Names.Env import Prelude -import Control.Monad (forM_, when) +import Control.Monad (forM_, when, (>=>)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -28,7 +28,7 @@ import Data.Function (on) import Data.Foldable (find) import Data.List (groupBy, sortOn, delete) import Data.Maybe (mapMaybe) -import Safe (headMay) +import Safe (headMay, headDef) import Data.Map qualified as M import Data.Set qualified as S @@ -482,8 +482,9 @@ checkImportConflicts ss currentModule toName xs = byOrig = sortOn importSourceModule xs groups = groupBy ((==) `on` importSourceModule) byOrig nonImplicit = filter ((/= FromImplicit) . importProvenance) xs - name = toName . disqualify . importName $ head xs - conflictModules = mapMaybe (getQual . importName . head) groups + name = toName . disqualify . importName $ + headDef (internalError "checkImportConflicts: No imports found") xs + conflictModules = mapMaybe (headMay >=> (getQual . importName)) groups in if length groups > 1 then case nonImplicit of @@ -494,8 +495,8 @@ checkImportConflicts ss currentModule toName xs = return (mnNew, mnOrig) _ -> throwError . errorMessage' ss $ ScopeConflict name conflictModules else - case head byOrig of - ImportRecord (Qualified (ByModuleName mnNew) _) mnOrig _ _ -> + case headMay byOrig of + Just (ImportRecord (Qualified (ByModuleName mnNew) _) mnOrig _ _) -> return (mnNew, mnOrig) _ -> internalError "checkImportConflicts: ImportRecord should be qualified" diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index cbe273f828..67b1560a77 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -4,6 +4,7 @@ module Language.PureScript.Sugar.Names.Exports ) where import Prelude +import Protolude (headDef) import Control.Monad (filterM, foldM, liftM2, unless, void, when) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -127,7 +128,8 @@ resolveExports env ss mn imps exps refs = -> (a -> Name) -> M.Map (Qualified a) [ImportRecord a] -> m [Qualified a] - extract ss' useQual name toName = fmap (map (importName . head . snd)) . go . M.toList + extract ss' useQual name toName = + fmap (map (importName . headDef (internalError "Missing value in extract") . snd)) . go . M.toList where go = filterM $ \(name', options) -> do let isMatch = if useQual then isQualifiedWith name name' else any (checkUnqual name') options diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 3a43faf7fd..77c65ba3c5 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -7,7 +7,7 @@ module Language.PureScript.Sugar.Names.Imports import Prelude -import Control.Monad (foldM, when) +import Control.Monad (foldM, when, unless) import Control.Monad.Error.Class (MonadError(..)) import Data.Foldable (for_, traverse_) @@ -147,7 +147,7 @@ resolveImport importModule exps imps impQual = resolveByType -> ProperName 'ConstructorName -> m () checkDctorExists ss tcon exports dctor - = when (dctor `notElem` exports) + = unless (dctor `elem` exports) . throwError . errorMessage' ss $ UnknownImportDataConstructor importModule tcon dctor diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 4f3129baf8..d24485e044 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -237,7 +237,8 @@ desugarDecl mn exps = go expRef :: Ident -> Qualified (ProperName 'ClassName) -> [SourceType] -> Maybe DeclarationRef expRef name className tys - | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef genSpan name UserNamed + | isExportedClass className && all (all isExportedType . getConstructors) tys = + Just $ TypeInstanceRef genSpan name UserNamed | otherwise = Nothing isExportedClass :: Qualified (ProperName 'ClassName) -> Bool diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 479a01f012..d0d122206a 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -8,7 +8,7 @@ module Language.PureScript.TypeChecker ) where import Prelude -import Protolude (headMay, maybeToLeft, ordNub) +import Protolude (headMay, maybeToLeft, ordNub, headDef) import Control.Lens ((^..), _2) import Control.Monad (when, unless, void, forM, zipWithM_) @@ -422,7 +422,9 @@ typeCheckAll moduleName = traverse go checkInstanceMembers :: [Declaration] -> m [Declaration] checkInstanceMembers instDecls = do - let idents = sort . map head . group . map memberName $ instDecls + let idents = sort + . map (headDef $ internalError "checkInstanceMembers: Empty instance declaration list") + . group . map memberName $ instDecls for_ (firstDuplicate idents) $ \ident -> throwError . errorMessage $ DuplicateValueDeclaration ident return instDecls @@ -747,7 +749,9 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = checkClassMembersAreExported :: DeclarationRef -> m () checkClassMembersAreExported dr@(TypeClassRef ss' name) = do - let members = ValueRef ss' `map` head (mapMaybe findClassMembers decls) + let members = ValueRef ss' `map` + (headDef $ internalError "checkClassMembersAreExported: Empty class member list") + (mapMaybe findClassMembers decls) let missingMembers = members \\ exps unless (null missingMembers) . throwError . errorMessage' ss' $ TransitiveExportError dr missingMembers where diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index 8d5dcde9b6..eaac3cff51 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -1,6 +1,7 @@ {- HLINT ignore "Unused LANGUAGE pragma" -} -- HLint doesn't recognize that TypeApplications is used in a pattern {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeAbstractions #-} module Language.PureScript.TypeChecker.Deriving (deriveInstance) where import Protolude hiding (Type) @@ -529,7 +530,7 @@ validateParamsInTypeConstructors derivingClass utc isBi CovariantClasses{..} con hasInstance :: InstanceContext -> Qualified (Either Text (ProperName 'TypeName)) -> Qualified (ProperName 'ClassName) -> Bool hasInstance tcds ht@(Qualified qb _) cn@(Qualified cqb _) = - any tcdAppliesToType $ concatMap (findDicts tcds cn) (ordNub [ByNullSourcePos, cqb, qb]) + any (any tcdAppliesToType . findDicts tcds cn) (ordNub [ByNullSourcePos, cqb, qb]) where tcdAppliesToType tcd = case tcdInstanceTypes tcd of [headOfType -> ht'] -> ht == ht' diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 85bdfee4aa..6cdd98c407 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -11,7 +11,7 @@ module Language.PureScript.TypeChecker.Entailment ) where import Prelude -import Protolude (ordNub, headMay) +import Protolude (ordNub, headMay, headDef) import Control.Arrow (second, (&&&)) import Control.Monad.Error.Class (MonadError(..)) @@ -257,7 +257,7 @@ entails SolverOptions{..} constraint context hints = , typeClassDependencies , typeClassIsEmpty , typeClassCoveringSets - , typeClassMembers + , typeClassMembers } <- case M.lookup className' classesInScope of Nothing -> throwError . errorMessage $ UnknownClass className' Just tcd -> pure tcd @@ -281,8 +281,8 @@ entails SolverOptions{..} constraint context hints = else Left (Left (tcdToInstanceDescription tcd)) -- can't continue with this chain yet, need proof of apartness lefts [found] - solution <- lift . lift - $ unique kinds'' tys'' ambiguous instances + solution <- lift . lift + $ unique kinds'' tys'' ambiguous instances $ unknownsInAllCoveringSets (fst . (typeClassArguments !!)) typeClassMembers tys'' typeClassCoveringSets case solution of Solved substs tcd -> do @@ -293,7 +293,7 @@ entails SolverOptions{..} constraint context hints = -- Now enforce any functional dependencies, using unification -- Note: we need to generate fresh types for any unconstrained -- type variables before unifying. - let subst = fmap head substs + let subst = fmap (headDef $ internalError "entails: empty substitution") substs currentSubst <- lift . lift $ gets checkSubstitution subst' <- lift . lift $ withFreshTypes tcd (fmap (substituteType currentSubst) subst) lift . lift $ zipWithM_ (\t1 t2 -> do @@ -431,9 +431,9 @@ entails SolverOptions{..} constraint context hints = unknownsInAllCoveringSets :: (Int -> Text) -> [(Ident, SourceType, Maybe (S.Set (NEL.NonEmpty Int)))] -> [SourceType] -> S.Set (S.Set Int) -> UnknownsHint unknownsInAllCoveringSets indexToArgText tyClassMembers tyArgs coveringSets = do let unkIndices = findIndices containsUnknowns tyArgs - if all (\s -> any (`S.member` s) unkIndices) coveringSets then + if all (\s -> any (`S.member` s) unkIndices) coveringSets then fromMaybe Unknowns unknownsRequiringVtas - else + else NoUnknowns where unknownsRequiringVtas = do @@ -452,15 +452,15 @@ entails SolverOptions{..} constraint context hints = (_, getVars, _, _, _) = everythingOnValues (++) ignore getVarIdents ignore ignore ignore ignore = const [] getVarIdents = \case - Var _ ident | Just vtas <- M.lookup ident tyClassMemberVta -> + Var _ ident | Just vtas <- M.lookup ident tyClassMemberVta -> [(ident, vtas)] - _ -> + _ -> [] getECTExpr = \case ErrorCheckingType expr _ -> Just expr _ -> Nothing - + tyClassMembers' <- headMay $ mapMaybe (fmap tyClassMembersInExpr . getECTExpr) hints membersWithVtas <- NEL.nonEmpty tyClassMembers' pure $ UnknownsWithVtaRequiringArgs membersWithVtas @@ -668,7 +668,7 @@ entails SolverOptions{..} constraint context hints = , l, r , rowFromList (fixed, rowVar) , Just [ srcConstraint C.RowUnion kinds [rest, r, rowVar] Nothing ] - , [("r", kindRow (head kinds))] + , [("r", kindRow (headDef (internalError "unionRows: empty kinds") kinds))] ) solveRowCons :: [SourceType] -> [SourceType] -> Maybe [TypeClassDict] diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 5be87c0057..1a758aab48 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -26,6 +26,7 @@ module Language.PureScript.TypeChecker.Kinds ) where import Prelude +import Protolude (headDef) import Control.Arrow ((***)) import Control.Lens ((^.), _1, _2, _3) @@ -633,7 +634,7 @@ kindOfData -> DataDeclarationArgs -> m DataDeclarationResult kindOfData moduleName dataDecl = - head . (^. _2) <$> kindsOfAll moduleName [] [dataDecl] [] + headDef (internalError "kindOfData: empty list") . (^. _2) <$> kindsOfAll moduleName [] [dataDecl] [] inferDataDeclaration :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) @@ -685,7 +686,7 @@ kindOfTypeSynonym -> TypeDeclarationArgs -> m TypeDeclarationResult kindOfTypeSynonym moduleName typeDecl = - head . (^. _1) <$> kindsOfAll moduleName [typeDecl] [] [] + headDef (internalError "kindOfTypeSynonym: empty list") . (^. _1) <$> kindsOfAll moduleName [typeDecl] [] [] inferTypeSynonym :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) @@ -802,7 +803,7 @@ kindOfClass -> ClassDeclarationArgs -> m ClassDeclarationResult kindOfClass moduleName clsDecl = - head . (^. _3) <$> kindsOfAll moduleName [] [] [clsDecl] + headDef (internalError "kindOfClass: empty list") . (^. _3) <$> kindsOfAll moduleName [] [] [clsDecl] inferClassDeclaration :: forall m. (MonadError MultipleErrors m, MonadState CheckState m) diff --git a/stack.yaml b/stack.yaml index afbac89bca..500fd823cf 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ # Please update Haskell image versions under .github/workflows/ci.yml together to use the same GHC version # (or the CI build will fail) -resolver: lts-22.43 +resolver: lts-23.18 pvp-bounds: both packages: - '.' @@ -19,7 +19,7 @@ extra-deps: - aeson-better-errors-0.9.1.3 - github: purescript/cheapskate - commit: 8bfaf4beeb108e97a274ed51303f278905979e87 + commit: 633c69024e061ad956f1aecfc137fb99a7a7a20b nix: packages: @@ -38,3 +38,4 @@ flags: allow-newer: true allow-newer-deps: - haskeline +- weeder diff --git a/stack.yaml.lock b/stack.yaml.lock index 0af2cebb41..8a4853c3fa 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -42,17 +42,17 @@ packages: - completed: name: cheapskate pantry-tree: - sha256: a2253619f50d26f0137a802e51e5e7103ee52b1f71bc060d93a0979dcbefa2c8 + sha256: b130a35ad29a61ac64c2d29bb09309ddf07b139342c67ef01ccc59ad4167d529 size: 12069 - sha256: 959fc7a6ca7e0a743b06b0c287aa4a1c3ec7fc740e5830a4a841d43e925a6d73 - size: 62502 - url: https://github.com/purescript/cheapskate/archive/8bfaf4beeb108e97a274ed51303f278905979e87.tar.gz + sha256: 2b495e2b6d571c33b91ebb76c1b7fe9c9b56ff90ca0804106a3260f2bbdc9a9a + size: 62489 + url: https://github.com/purescript/cheapskate/archive/633c69024e061ad956f1aecfc137fb99a7a7a20b.tar.gz version: 0.1.1.2 original: - url: https://github.com/purescript/cheapskate/archive/8bfaf4beeb108e97a274ed51303f278905979e87.tar.gz + url: https://github.com/purescript/cheapskate/archive/633c69024e061ad956f1aecfc137fb99a7a7a20b.tar.gz snapshots: - completed: - sha256: 08bd13ce621b41a8f5e51456b38d5b46d7783ce114a50ab604d6bbab0d002146 - size: 720271 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/43.yaml - original: lts-22.43 + sha256: d133abe75e408a407cce3f032c96ac1bbadf474a93b5156ebf4135b53382d56b + size: 683827 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/18.yaml + original: lts-23.18 diff --git a/tests/Main.hs b/tests/Main.hs index b8f6ea979e..a01dc09e1b 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -12,6 +12,7 @@ import TestCoreFn qualified import TestCst qualified import TestDocs qualified import TestHierarchy qualified +import TestInteractive qualified import TestPrimDocs qualified import TestPsci qualified import TestIde qualified @@ -40,6 +41,7 @@ main = do describe "sourcemaps" TestSourceMaps.spec describe "make" TestMake.spec describe "psci" TestPsci.spec + describe "interactive" TestInteractive.spec describe "corefn" TestCoreFn.spec describe "docs" TestDocs.spec describe "prim-docs" TestPrimDocs.spec diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index d2b805ff0e..09a76ceb7a 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -1,6 +1,7 @@ module TestDocs where import Prelude +import Protolude (tailDef) import Data.Bifunctor (first) import Data.List (findIndex) @@ -952,7 +953,7 @@ testCases = codeToString (Docs.renderType ty) == expected shouldBeOrdered mn declNames = - zipWith (ShouldComeBefore mn) declNames (tail declNames) + zipWith (ShouldComeBefore mn) declNames (tailDef mempty declNames) testTagsCases :: [(Text, [TagsAssertion])] testTagsCases = diff --git a/tests/TestInteractive.hs b/tests/TestInteractive.hs new file mode 100644 index 0000000000..13fdb806ce --- /dev/null +++ b/tests/TestInteractive.hs @@ -0,0 +1,97 @@ +module TestInteractive where + +import Prelude + +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) +import Data.List.NonEmpty qualified as NEL +import Data.List (nub) + +import Language.PureScript.Interactive.Directive + ( directiveStrings + , directiveStrings' + , stringsFor + , stringFor + , directivesFor + , directivesFor' + , help + ) +import Language.PureScript.Interactive.Types (Directive(..)) + +spec :: Spec +spec = do + describe "Interactive.Directive" $ do + directiveStringsTests + directiveStrings'Tests + stringsForTests + stringForTests + directivesFor'Tests + directivesForTests + helpTests + +directiveStringsTests :: Spec +directiveStringsTests = describe "directiveStrings" $ do + it "should have non-empty string lists for each directive" $ do + let allHaveElements = not (any (null . NEL.toList . snd) directiveStrings) + allHaveElements `shouldBe` True + +directiveStrings'Tests :: Spec +directiveStrings'Tests = describe "directiveStrings'" $ do + it "should be a flattened version of directiveStrings" $ do + let expectedLength = sum (length . NEL.toList . snd <$> directiveStrings) + length directiveStrings' `shouldBe` expectedLength + + it "should contain appropriate directives" $ do + lookup "help" directiveStrings' `shouldBe` Just Help + lookup "?" directiveStrings' `shouldBe` Just Help + lookup "quit" directiveStrings' `shouldBe` Just Quit + lookup "reload" directiveStrings' `shouldBe` Just Reload + +stringsForTests :: Spec +stringsForTests = describe "stringsFor" $ do + it "should return all strings for a directive" $ do + NEL.toList (stringsFor Help) `shouldBe` ["?", "help"] + NEL.toList (stringsFor Quit) `shouldBe` ["quit"] + NEL.toList (stringsFor Reload) `shouldBe` ["reload"] + +stringForTests :: Spec +stringForTests = describe "stringFor" $ do + it "should return the first string for a directive" $ do + stringFor Help `shouldBe` "?" + stringFor Quit `shouldBe` "quit" + stringFor Reload `shouldBe` "reload" + +directivesFor'Tests :: Spec +directivesFor'Tests = describe "directivesFor'" $ do + it "should return matching directives and their string representations" $ do + directivesFor' "h" `shouldBe` [(Help, "help")] + directivesFor' "he" `shouldBe` [(Help, "help")] + directivesFor' "?" `shouldBe` [(Help, "?")] + directivesFor' "q" `shouldBe` [(Quit, "quit")] + + it "should handle ambiguous prefixes" $ do + directivesFor' "" `shouldSatisfy` (not . null) + length (directivesFor' "") `shouldBe` length directiveStrings' + + it "should return empty list for non-matching prefixes" $ do + directivesFor' "xyz" `shouldBe` [] + +directivesForTests :: Spec +directivesForTests = describe "directivesFor" $ do + it "should return just the directive part" $ do + directivesFor "h" `shouldBe` [Help] + directivesFor "q" `shouldBe` [Quit] + directivesFor "xyz" `shouldBe` [] + +helpTests :: Spec +helpTests = describe "help" $ do + it "should contain help for all directives" $ do + let helpDirectives = map (\(d, _, _) -> d) help + length (nub helpDirectives) `shouldBe` length directiveStrings + + it "should contain descriptive help text" $ do + let helpTexts = map (\(_, _, text) -> text) help + not (any null helpTexts) `shouldBe` True + + it "should include parameters where needed" $ do + lookup Browse (map (\(d, a, _) -> (d, a)) help) `shouldBe` Just "" + lookup Type (map (\(d, a, _) -> (d, a)) help) `shouldBe` Just "" From 94cec4f3292add490be0d935b43b90dc5a750883 Mon Sep 17 00:00:00 2001 From: Adrian Sieber <36796532+ad-si@users.noreply.github.com> Date: Sun, 8 Jun 2025 11:40:52 +0000 Subject: [PATCH 1574/1580] Fix double click select of titles in documentation (#4579) Full explanation: https://stackoverflow.com/questions/69291860 --- src/Language/PureScript/Docs/AsHtml.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs index e03ccabc31..df7b55f3e3 100644 --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -133,8 +133,7 @@ declAsHtml r d@Declaration{..} = do h3 ! A.class_ "decl__title clearfix" $ do a ! A.class_ "decl__anchor" ! A.href (v declFragment) $ "#" H.span $ text declTitle - text " " -- prevent browser from treating - -- declTitle + linkToSource as one word + text "\x200b" -- Zero-width space to allow double-click selection of title for_ declSourceSpan (linkToSource r) H.div ! A.class_ "decl__body" $ do From 2b7164ff852b7243cd6d25529bc43a37162099ef Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Sun, 22 Jun 2025 19:01:01 +0300 Subject: [PATCH 1575/1580] Move to windows-2022 in CI (#4583) GitHub is sunsetting the `windows-2019` runner that we use in CI --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index d3c9aca938..149fe63496 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -62,7 +62,7 @@ jobs: - os: macos-13 # x64 - os: macos-14 # arm64 - - os: windows-2019 # x64 + - os: windows-2022 # x64 runs-on: "${{ matrix.os }}" container: "${{ matrix.image }}" From 9dd761a3805a0c04b90db915599c1c6d8a3bb68e Mon Sep 17 00:00:00 2001 From: Justin Garcia Date: Fri, 27 Jun 2025 13:21:06 +0800 Subject: [PATCH 1576/1580] Build fully static compiler binary using ghc-musl (#4573) * Build statically-linked binaries with ghc-musl * Compliance for LGPL terms * Add changelog entry * Update dependencies * Update LICENSE * Update weeder * Fix weeder * Add more changelog entries * Argument passthrough * Update license * Update license * Build images for ARM * Checkout after Node installation * Only mount volumes for static * Drop static prefix for now * Force purge cache * Remove builds against ubuntu * Use matrix.os for cache key * Fix linux only * Set CI_STATIC to true * CI_STATIC on Linux only * Fix more linux only checks --- .github/workflows/ci.yml | 77 +- CHANGELOG.d/internal_tool_updates.md | 2 + CHANGELOG.d/misc_static_linking.md | 4 + LICENSE | 1057 +++++++++++++++++++------- ci/build.sh | 6 +- license-generator/generate.hs | 5 + license-generator/header.txt | 13 + license-generator/lgpl.txt | 158 ++++ purescript.cabal | 11 +- stack.yaml | 9 - stack.yaml.lock | 7 - 11 files changed, 1027 insertions(+), 322 deletions(-) create mode 100644 CHANGELOG.d/internal_tool_updates.md create mode 100644 CHANGELOG.d/misc_static_linking.md create mode 100644 license-generator/lgpl.txt diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 149fe63496..15532faa32 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -54,38 +54,52 @@ jobs: fail-fast: false # do not cancel builds for other OSes if one fails matrix: include: - - image: haskell:9.8.4 # Also upgrade version in the lint job below - os: ubuntu-latest # Exact version is not important, as it's only the container host) + - image: quay.io/benz0li/ghc-musl:9.8.4 + os: ubuntu-latest - - image: haskell:9.8.4 - os: ubuntu-24.04-arm # Exact version is not important, as it's only the container host + - image: quay.io/benz0li/ghc-musl:9.8.4 + os: ubuntu-24.04-arm - os: macos-13 # x64 - os: macos-14 # arm64 - os: windows-2022 # x64 runs-on: "${{ matrix.os }}" - container: "${{ matrix.image }}" + container: + image: "${{ matrix.image }}" + # https://github.com/actions/runner/issues/801#issuecomment-2976165281 + # This workaround also requires a special installation step for Node.js on arm64 + volumes: + - "${{ contains(matrix.os, 'arm') && '/opt:/opt:rw,rshared' || ' ' }}" + - "${{ contains(matrix.os, 'arm') && '/opt:/__e/node20:ro,rshared' || ' ' }}" + env: + CI_STATIC: "${{ startsWith(matrix.os, 'ubuntu') }}" outputs: do-not-prerelease: "${{ steps.build.outputs.do-not-prerelease }}" version: "${{ steps.build.outputs.version }}" steps: - - # We need `gh` installed on the Linux version. Otherwise, release artifacts won't be uploaded. - name: "(Linux only) Install gh" - if: startsWith(matrix.image, 'haskell') + # We need `gh` installed on the Linux version. Otherwise, release artifacts won't be uploaded. + - name: "(Linux only) Install gh" + if: "${{ startsWith(matrix.os, 'ubuntu') }}" run: | - curl -fsSL https://cli.github.com/packages/githubcli-archive-keyring.gpg | dd of=/usr/share/keyrings/githubcli-archive-keyring.gpg - chmod go+r /usr/share/keyrings/githubcli-archive-keyring.gpg - echo "deb [arch=$(dpkg --print-architecture) signed-by=/usr/share/keyrings/githubcli-archive-keyring.gpg] https://cli.github.com/packages stable main" | tee /etc/apt/sources.list.d/github-cli.list > /dev/null - apt-get update - apt-get install -y gh + apk add github-cli + + - name: "(Linux only / x64) Install Node" + if: "${{ startsWith(matrix.os, 'ubuntu') && ! contains(matrix.os, 'arm') }}" + run: | + apk add nodejs npm + + - name: "(Linux only / arm64) Install Node" + if: "${{ startsWith(matrix.os, 'ubuntu') && contains(matrix.os, 'arm') }}" + run: | + sed -i "/^ID=/s/alpine/NotpineForGHA/" /etc/os-release + apk add nodejs npm --update-cache + mkdir /opt/bin + ln -s /usr/bin/node /opt/bin/node - uses: "actions/checkout@v4" - - uses: "actions/setup-node@v4" - with: - node-version: "22" - id: "haskell" name: "(Non-Linux only) Install Haskell" @@ -98,7 +112,7 @@ jobs: stack-no-global: true - name: "(Linux only) Fix working directory ownership" - if: startsWith(matrix.image, 'haskell') + if: "${{ startsWith(matrix.os, 'ubuntu') }}" run: | chown root:root . @@ -107,7 +121,7 @@ jobs: path: | /root/.stack ${{ steps.haskell.outputs.stack-root }} - key: "${{ matrix.image || runner.os }}--MdyPsf-${{ hashFiles('stack.yaml.lock', 'purescript.cabal') }}" + key: "${{ matrix.image || matrix.os }}-v3-${{ hashFiles('stack.yaml.lock', 'purescript.cabal') }}" - name: "(Windows only) Configure Stack to store its programs in STACK_ROOT" # This ensures that the local GHC and MSYS binaries that Stack installs @@ -118,20 +132,26 @@ jobs: mkdir -p "$STACK_ROOT" echo "local-programs-path: $STACK_ROOT/programs" > $STACK_ROOT/config.yaml + - name: "(Linux only) Configure Stack" + if: "${{ startsWith(matrix.os, 'ubuntu') }}" + run: | + ci/fix-home stack config set system-ghc --global true + ci/fix-home stack config set install-ghc --global false + - id: "build" run: "ci/fix-home ci/build.sh" - name: "(Linux only) Glob tests" - if: startsWith(matrix.image, 'haskell') + if: "${{ startsWith(matrix.os, 'ubuntu') }}" working-directory: "sdist-test" # We build in this directory in build.sh, so this is where we need to # launch `stack exec`. The actual glob checks happen in a temporary directory. run: | - apt-get install -y tree + apk add tree ../ci/fix-home stack exec bash ../glob-test.sh - name: "(Linux only) Build the entire package set" - if: startsWith(matrix.image, 'haskell') + if: "${{ startsWith(matrix.os, 'ubuntu') }}" # We build in this directory in build.sh, so this is where we need to # launch `stack exec`. The actual package-set building happens in a # temporary directory. @@ -144,11 +164,11 @@ jobs: # Moreover, npm has a hook issue that will cause spago to fail to install # We upgrade npm to fix this run: | - apt-get install -y jq + apk add jq ../ci/fix-home stack --haddock exec ../ci/build-package-set.sh - name: Verify that 'libtinfo' isn't in binary - if: runner.os == 'Linux' + if: ${{ runner.os == 'Linux' }} working-directory: "sdist-test" run: | if [ $(ldd $(../ci/fix-home stack path --local-doc-root)/../bin/purs | grep 'libtinfo' | wc -l) -ge 1 ]; then @@ -157,6 +177,11 @@ jobs: exit 1 fi + - name: "(Linux only) Install perl-utils" + if: "${{ startsWith(matrix.os, 'ubuntu') }}" + run: | + apk add perl-utils + - name: "(Release/prerelease only) Create bundle" if: "${{ env.CI_RELEASE == 'true' || env.CI_PRERELEASE == 'true' && steps.build.outputs.do-not-prerelease != 'true' }}" run: | @@ -225,13 +250,13 @@ jobs: - name: Install weeder run: | ci/fix-home stack --no-terminal --jobs=2 \ - build --copy-compiler-tool weeder-2.8.0 + build --copy-compiler-tool weeder-2.9.0 - run: | ci/fix-home stack --no-terminal --jobs=2 \ build --fast --ghc-options -fwrite-ide-info - - run: "ci/fix-home stack exec weeder" + - run: "ci/fix-home stack exec weeder -- --hie-directory .stack-work" # Now do it again, with the test suite included. We don't want a # reference from our test suite to count in the above check; the fact @@ -241,7 +266,7 @@ jobs: ci/fix-home stack --no-terminal --jobs=2 \ build --fast --test --no-run-tests --ghc-options -fwrite-ide-info - - run: "ci/fix-home stack exec weeder" + - run: "ci/fix-home stack exec weeder -- --hie-directory .stack-work" make-prerelease: runs-on: ubuntu-latest diff --git a/CHANGELOG.d/internal_tool_updates.md b/CHANGELOG.d/internal_tool_updates.md new file mode 100644 index 0000000000..3dcd762162 --- /dev/null +++ b/CHANGELOG.d/internal_tool_updates.md @@ -0,0 +1,2 @@ +* Update weeder version in CI to 2.9.0 +* Add happy ==2.0.2 as build-tool-depends diff --git a/CHANGELOG.d/misc_static_linking.md b/CHANGELOG.d/misc_static_linking.md new file mode 100644 index 0000000000..3a4ec56549 --- /dev/null +++ b/CHANGELOG.d/misc_static_linking.md @@ -0,0 +1,4 @@ +* Enable statically-linked binaries using [ghc-musl](https://github.com/benz0li/ghc-musl) +* Update haskeline version bounds to >=0.8.2.1 && <0.9 + + Consequently, this fixes Cabal-based builds on GHC 9.8.4 diff --git a/LICENSE b/LICENSE index 713d3371a3..86b917570e 100644 --- a/LICENSE +++ b/LICENSE @@ -12,9 +12,23 @@ Redistribution and use in source and binary forms, with or without modification, THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +PureScript executables for Linux distributed under the Releases tab of its GitHub +repository (https://github.com/purescript/purescript) may be statically-linked to +a version of GMP, licensed under the GNU Lesser General Public License Version 3, +29 June 2007. + +The full source code of PureScript is available in the aforementioned repository, +https://github.com/purescript/purescript, allowing you to modify and relink the +GMP portion if desired. + +GMP source code is available at: https://gmplib.org/ + +A copy of the LGPL is reproduced below. + PureScript uses the following Haskell library packages. Their license files follow. Cabal + Cabal-syntax Glob OneTuple QuickCheck @@ -24,27 +38,28 @@ PureScript uses the following Haskell library packages. Their license files foll aeson-better-errors alex ansi-terminal - ansi-wl-pprint + ansi-terminal-types array assoc async attoparsec auto-update base - base-compat - base-compat-batteries base-orphans basement bifunctors binary + bitvec blaze-builder blaze-html blaze-markup + boring bower-json boxes bytestring call-stack cborg + character-ps cheapskate clock colour @@ -56,7 +71,6 @@ PureScript uses the following Haskell library packages. Their license files foll contravariant cryptonite css-text - data-array-byte data-default data-default-class data-default-instances-containers @@ -75,14 +89,17 @@ PureScript uses the following Haskell library packages. Their license files foll file-embed filepath free + generically ghc-bignum ghc-prim half happy + happy-lib hashable haskeline indexed-traversable indexed-traversable-instances + integer-conversion integer-gmp integer-logarithms invariant @@ -105,9 +122,12 @@ PureScript uses the following Haskell library packages. Their license files foll old-locale old-time optparse-applicative + os-string parallel parsec pretty + prettyprinter + prettyprinter-ansi-terminal primitive process profunctors @@ -134,8 +154,11 @@ PureScript uses the following Haskell library packages. Their license files foll syb tagged tagsoup + tasty template-haskell + terminfo text + text-iso8601 text-short th-abstraction th-compat @@ -145,7 +168,6 @@ PureScript uses the following Haskell library packages. Their license files foll transformers transformers-base transformers-compat - type-equality typed-process uniplate unix @@ -157,6 +179,7 @@ PureScript uses the following Haskell library packages. Their license files foll uuid-types vector vector-algorithms + vector-stream void witherable xss-sanitize @@ -164,7 +187,44 @@ PureScript uses the following Haskell library packages. Their license files foll Cabal LICENSE file: - Copyright (c) 2003-2020, Cabal Development Team. + Copyright (c) 2003-2023, Cabal Development Team. + See the AUTHORS file for the full list of copyright holders. + + See */LICENSE for the copyright holders of the subcomponents. + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +Cabal-syntax LICENSE file: + + Copyright (c) 2003-2023, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents. @@ -454,53 +514,56 @@ ansi-terminal LICENSE file: Copyright (c) 2008, Maximilian Bolingbroke All rights reserved. - Redistribution and use in source and binary forms, with or without modification, are permitted - provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, this list of - conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, this list of - conditions and the following disclaimer in the documentation and/or other materials - provided with the distribution. - * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to - endorse or promote products derived from this software without specific prior written permission. + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR - CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER - IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT - OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this + list of conditions and the following disclaimer in the documentation and/or + other materials provided with the distribution. + * Neither the name of Maximilian Bolingbroke nor the names of other contributors + may be used to endorse or promote products derived from this software without + specific prior written permission. -ansi-wl-pprint LICENSE file: + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - Copyright 2008, Daan Leijen and Max Bolingbroke. All rights reserved. +ansi-terminal-types LICENSE file: - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are - met: + Copyright (c) 2008, Maximilian Bolingbroke + All rights reserved. - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. + * Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Maximilian Bolingbroke nor the names of other contributors + may be used to endorse or promote products derived from this software without + specific prior written permission. - This software is provided by the copyright holders "as is" and any - express or implied warranties, including, but not limited to, the - implied warranties of merchantability and fitness for a particular - purpose are disclaimed. In no event shall the copyright holders be - liable for any direct, indirect, incidental, special, exemplary, or - consequential damages (including, but not limited to, procurement of - substitute goods or services; loss of use, data, or profits; or - business interruption) however caused and on any theory of liability, - whether in contract, strict liability, or tort (including negligence - or otherwise) arising in any way out of the use of this software, even - if advised of the possibility of such damage. + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. array LICENSE file: @@ -797,50 +860,6 @@ base LICENSE file: ----------------------------------------------------------------------------- -base-compat LICENSE file: - - Copyright (c) 2012-2018 Simon Hengel and Ryan Scott - - Permission is hereby granted, free of charge, to any person obtaining a copy - of this software and associated documentation files (the "Software"), to deal - in the Software without restriction, including without limitation the rights - to use, copy, modify, merge, publish, distribute, sublicense, and/or sell - copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN - THE SOFTWARE. - -base-compat-batteries LICENSE file: - - Copyright (c) 2012-2018 Simon Hengel and Ryan Scott - - Permission is hereby granted, free of charge, to any person obtaining a copy - of this software and associated documentation files (the "Software"), to deal - in the Software without restriction, including without limitation the rights - to use, copy, modify, merge, publish, distribute, sublicense, and/or sell - copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in - all copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN - THE SOFTWARE. - base-orphans LICENSE file: Copyright (c) 2015-2017 Simon Hengel , João Cristóvão , Ryan Scott @@ -957,6 +976,39 @@ binary LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +bitvec LICENSE file: + + Copyright (c) 2019-2022 Andrew Lelechenko, 2012-2016 James Cook + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of the contributors may not be used to endorse may be + used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + blaze-builder LICENSE file: Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 2011 @@ -1056,6 +1108,39 @@ blaze-markup LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +boring LICENSE file: + + Copyright (c) 2017, Oleg Grenrus + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + bower-json LICENSE file: Copyright (c) 2015 Harry Garrood @@ -1201,6 +1286,39 @@ cborg LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +character-ps LICENSE file: + + Copyright (c) 2023, Oleg Grenrus + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + cheapskate LICENSE file: Copyright (c) 2013, John MacFarlane @@ -1236,8 +1354,7 @@ cheapskate LICENSE file: clock LICENSE file: - Copyright (c) 2009-2012, Cetin Sert - Copyright (c) 2010, Eugene Kirpichov + Copyright (c) 2009-2022, Clock Contributors All rights reserved. @@ -1518,183 +1635,170 @@ css-text LICENSE file: OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -data-array-byte LICENSE file: +data-default LICENSE file: + + Copyright (c) 2013, Lukas Mai - Copyright (c) 2008-2009, Roman Leshchinskiy All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - - Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - - - Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - - - Neither name of the University nor the names of its contributors may be - used to endorse or promote products derived from this software without - specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF - GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, - INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE - UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH - DAMAGE. - - -data-default LICENSE file: - - Copyright (c) 2013 Lukas Mai - - All rights reserved. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - Redistribution and use in source and binary forms, with or without modification, - are permitted provided that the following conditions are met: + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + * Neither the name of Lukas Mai nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. data-default-class LICENSE file: - Copyright (c) 2013 Lukas Mai + Copyright (c) 2013, Lukas Mai All rights reserved. - Redistribution and use in source and binary forms, with or without modification, - are permitted provided that the following conditions are met: + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Lukas Mai nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. data-default-instances-containers LICENSE file: - Copyright (c) 2013 Lukas Mai + Copyright (c) 2013, Lukas Mai All rights reserved. - Redistribution and use in source and binary forms, with or without modification, - are permitted provided that the following conditions are met: + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - THIS SOFTWARE IS PROVIDED BY LUKAS MAI AND CONTRIBUTORS "AS IS" AND ANY - EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY - DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Lukas Mai nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. data-default-instances-dlist LICENSE file: - Copyright (c) 2013 Lukas Mai + Copyright (c) 2013, Lukas Mai All rights reserved. - Redistribution and use in source and binary forms, with or without modification, - are permitted provided that the following conditions are met: + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - THIS SOFTWARE IS PROVIDED BY LUKAS MAI AND CONTRIBUTORS "AS IS" AND ANY - EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY - DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Lukas Mai nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. data-default-instances-old-locale LICENSE file: - Copyright (c) 2013 Lukas Mai + Copyright (c) 2013, Lukas Mai All rights reserved. - Redistribution and use in source and binary forms, with or without modification, - are permitted provided that the following conditions are met: + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - THIS SOFTWARE IS PROVIDED BY LUKAS MAI AND CONTRIBUTORS "AS IS" AND ANY - EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY - DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES - (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; - LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS - SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Lukas Mai nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. data-fix LICENSE file: @@ -2127,6 +2231,37 @@ free LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +generically LICENSE file: + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Herbert Valerio Riedel nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ghc-bignum LICENSE file: The Glasgow Haskell Compiler License @@ -2392,21 +2527,54 @@ indexed-traversable-instances LICENSE file: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + +integer-conversion LICENSE file: + + Copyright (c) 2023, Oleg Grenrus + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. - THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED - WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. integer-gmp LICENSE file: @@ -3119,6 +3287,39 @@ optparse-applicative LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +os-string LICENSE file: + + Copyright Neil Mitchell 2005-2020. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Neil Mitchell nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + parallel LICENSE file: This library (libraries/parallel) is derived from code from @@ -3227,6 +3428,58 @@ pretty LICENSE file: ----------------------------------------------------------------------------- +prettyprinter LICENSE file: + + Copyright 2008, Daan Leijen and Max Bolingbroke, 2016 David Luposchainsky. All + rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + This software is provided by the copyright holders "as is" and any express or + implied warranties, including, but not limited to, the implied warranties of + merchantability and fitness for a particular purpose are disclaimed. In no event + shall the copyright holders be liable for any direct, indirect, incidental, + special, exemplary, or consequential damages (including, but not limited to, + procurement of substitute goods or services; loss of use, data, or profits; or + business interruption) however caused and on any theory of liability, whether in + contract, strict liability, or tort (including negligence or otherwise) arising + in any way out of the use of this software, even if advised of the possibility + of such damage. + +prettyprinter-ansi-terminal LICENSE file: + + Copyright 2008, Daan Leijen and Max Bolingbroke, 2016 David Luposchainsky. All + rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + This software is provided by the copyright holders "as is" and any express or + implied warranties, including, but not limited to, the implied warranties of + merchantability and fitness for a particular purpose are disclaimed. In no event + shall the copyright holders be liable for any direct, indirect, incidental, + special, exemplary, or consequential damages (including, but not limited to, + procurement of substitute goods or services; loss of use, data, or profits; or + business interruption) however caused and on any theory of liability, whether in + contract, strict liability, or tort (including negligence or otherwise) arising + in any way out of the use of this software, even if advised of the possibility + of such damage. + primitive LICENSE file: Copyright (c) 2008-2009, Roman Leshchinskiy @@ -3497,7 +3750,7 @@ regex-base LICENSE file: regex-tdfa LICENSE file: - This modile is under this "3 clause" BSD license: + This module is under this "3 clause" BSD license: Copyright (c) 2007-2009, Christopher Kuklewicz All rights reserved. @@ -3545,7 +3798,7 @@ resourcet LICENSE file: safe LICENSE file: - Copyright Neil Mitchell 2007-2020. + Copyright Neil Mitchell 2007-2024. All rights reserved. Redistribution and use in source and binary forms, with or without @@ -4139,6 +4392,28 @@ tagsoup LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +tasty LICENSE file: + + Copyright (c) 2013 Roman Cheplyaka + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + THE SOFTWARE. + template-haskell LICENSE file: @@ -4175,6 +4450,35 @@ template-haskell LICENSE file: DAMAGE. +terminfo LICENSE file: + + Copyright 2007, Judah Jacobson. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + 3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, + OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + text LICENSE file: Copyright (c) 2008-2009, Tom Harper @@ -4204,6 +4508,39 @@ text LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +text-iso8601 LICENSE file: + + Copyright (c) 2023 Oleg Grenrus + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR + ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN + ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + POSSIBILITY OF SUCH DAMAGE. + text-short LICENSE file: Copyright (c) 2017, Herbert Valerio Riedel @@ -4321,7 +4658,7 @@ these LICENSE file: time LICENSE file: - TimeLib is Copyright (c) Ashley Yakeley and contributors, 2004-2020. All rights reserved. + TimeLib is Copyright (c) Ashley Yakeley and contributors, 2004-2022. All rights reserved. Certain sections are Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: @@ -4462,39 +4799,6 @@ transformers-compat LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -type-equality LICENSE file: - - Copyright (c) 2009 Erik Hesselink, 2019 Oleg Grenrus, Ryan Scott - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of authors nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT - OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - typed-process LICENSE file: Copyright (c) 2016 FP Complete, https://www.fpcomplete.com/ @@ -4587,6 +4891,8 @@ unix LICENSE file: unix-compat LICENSE file: + BSD 3-Clause License + Copyright (c) 2007-2008, Björn Bringert Copyright (c) 2007-2009, Duncan Coutts Copyright (c) 2010-2011, Jacob Stanley @@ -4766,6 +5072,9 @@ uuid-types LICENSE file: vector LICENSE file: Copyright (c) 2008-2012, Roman Leshchinskiy + 2020-2022, Alexey Kuleshevich + 2020-2022, Aleksey Khudyakov + 2020-2022, Andrew Lelechenko All rights reserved. Redistribution and use in source and binary forms, with or without @@ -4795,7 +5104,6 @@ vector LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - vector-algorithms LICENSE file: Copyright (c) 2015 Dan Doel @@ -4833,7 +5141,7 @@ vector-algorithms LICENSE file: ------------------------------------------------------------------------------ The code in Data.Array.Vector.Algorithms.Mutable.Optimal is adapted from a C - algorithm for the same purpose. The folowing is the copyright notice for said + algorithm for the same purpose. The following is the copyright notice for said C code: Copyright (c) 2004 Paul Hsieh @@ -4865,6 +5173,41 @@ vector-algorithms LICENSE file: ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +vector-stream LICENSE file: + + Copyright (c) 2008-2012, Roman Leshchinskiy + 2020-2022, Alexey Kuleshevich + 2020-2022, Aleksey Khudyakov + 2020-2022, Andrew Lelechenko + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + - Neither name of the University nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, + INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH + DAMAGE. + void LICENSE file: Copyright 2015 Edward Kmett @@ -4986,3 +5329,161 @@ zlib LICENSE file: ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +============================================================================ + +GNU LESSER GENERAL PUBLIC LICENSE +Version 3, 29 June 2007 + +Copyright (C) 2007 Free Software Foundation, Inc. + +Everyone is permitted to copy and distribute verbatim copies of this license +document, but changing it is not allowed. + +This version of the GNU Lesser General Public License incorporates the terms +and conditions of version 3 of the GNU General Public License, supplemented +by the additional permissions listed below. + +0. Additional Definitions. + +As used herein, “this License” refers to version 3 of the GNU Lesser General +Public License, and the “GNU GPL” refers to version 3 of the +GNU General Public License. + +“The Library” refers to a covered work governed by this License, other than +an Application or a Combined Work as defined below. + +An “Application” is any work that makes use of an interface provided by the +Library, but which is not otherwise based on the Library. Defining a subclass +of a class defined by the Library is deemed a mode of using an interface +provided by the Library. + +A “Combined Work” is a work produced by combining or linking an Application +with the Library. The particular version of the Library with which the +Combined Work was made is also called the “Linked Version”. + +The “Minimal Corresponding Source” for a Combined Work means the Corresponding +Source for the Combined Work, excluding any source code for portions of the +Combined Work that, considered in isolation, are based on the Application, +and not on the Linked Version. + +The “Corresponding Application Code” for a Combined Work means the object code +and/or source code for the Application, including any data and utility programs +needed for reproducing the Combined Work from the Application, but excluding +the System Libraries of the Combined Work. + +1. Exception to Section 3 of the GNU GPL. + +You may convey a covered work under sections 3 and 4 of this License without +being bound by section 3 of the GNU GPL. + +2. Conveying Modified Versions. + +If you modify a copy of the Library, and, in your modifications, a facility +refers to a function or data to be supplied by an Application that uses the +facility (other than as an argument passed when the facility is invoked), +then you may convey a copy of the modified version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the function or + data, the facility still operates, and performs whatever part of its + purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of this + License applicable to that copy. + +3. Object Code Incorporating Material from Library Header Files. + +The object code form of an Application may incorporate material from a header +file that is part of the Library. You may convey such object code under terms +of your choice, provided that, if the incorporated material is not limited to +numerical parameters, data structure layouts and accessors, or small macros, +inline functions and templates (ten or fewer lines in length), +you do both of the following: + + a) Give prominent notice with each copy of the object code that the Library + is used in it and that the Library and its use are covered by this License. + + b) Accompany the object code with a copy of the GNU GPL + and this license document. + +4. Combined Works. + +You may convey a Combined Work under terms of your choice that, taken together, +effectively do not restrict modification of the portions of the Library +contained in the Combined Work and reverse engineering for debugging such +modifications, if you also do each of the following: + + a) Give prominent notice with each copy of the Combined Work that the + Library is used in it and that the Library and its use are covered + by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and + this license document. + + c) For a Combined Work that displays copyright notices during execution, + include the copyright notice for the Library among these notices, as well + as a reference directing the user to the copies of the GNU GPL + and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form suitable + for, and under terms that permit, the user to recombine or relink + the Application with a modified version of the Linked Version to + produce a modified Combined Work, in the manner specified by section 6 + of the GNU GPL for conveying Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time a + copy of the Library already present on the user's computer system, + and (b) will operate properly with a modified version of the Library + that is interface-compatible with the Linked Version. + + e) Provide Installation Information, but only if you would otherwise be + required to provide such information under section 6 of the GNU GPL, and + only to the extent that such information is necessary to install and + execute a modified version of the Combined Work produced by recombining + or relinking the Application with a modified version of the Linked Version. + (If you use option 4d0, the Installation Information must accompany the + Minimal Corresponding Source and Corresponding Application Code. If you + use option 4d1, you must provide the Installation Information in the + manner specified by section 6 of the GNU GPL for + conveying Corresponding Source.) + +5. Combined Libraries. + +You may place library facilities that are a work based on the Library side by +side in a single library together with other library facilities that are not +Applications and are not covered by this License, and convey such a combined +library under terms of your choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based on + the Library, uncombined with any other library facilities, conveyed under + the terms of this License. + + b) Give prominent notice with the combined library that part of it is a + work based on the Library, and explaining where to find the accompanying + uncombined form of the same work. + +6. Revised Versions of the GNU Lesser General Public License. + +The Free Software Foundation may publish revised and/or new versions of the +GNU Lesser General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Library as you +received it specifies that a certain numbered version of the GNU Lesser +General Public License “or any later version” applies to it, you have the +option of following the terms and conditions either of that published version +or of any later version published by the Free Software Foundation. If the +Library as you received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser General +Public License ever published by the Free Software Foundation. + +If the Library as you received it specifies that a proxy can decide whether +future versions of the GNU Lesser General Public License shall apply, that +proxy's public statement of acceptance of any version is permanent +authorization for you to choose that version for the Library. + diff --git a/ci/build.sh b/ci/build.sh index b2ef51251e..c551dfd51a 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -25,7 +25,7 @@ set -ex # We test with --haddock because haddock generation can fail if there is invalid doc-comment syntax, # and these failures are very easy to miss otherwise. -STACK="stack --no-terminal --haddock --jobs=2" +STACK="stack --no-terminal --haddock --jobs=4" STACK_OPTS="--test" if [ "$CI_RELEASE" = "true" -o "$CI_PRERELEASE" = "true" ] @@ -34,6 +34,10 @@ then else STACK_OPTS="$STACK_OPTS --fast" fi +if [ "$CI_STATIC" = "true" ] +then + STACK_OPTS="$STACK_OPTS --flag=purescript:static" +fi (echo "::endgroup::"; echo "::group::Set version number for build") 2>/dev/null diff --git a/license-generator/generate.hs b/license-generator/generate.hs index d000f2276c..f755ee8c2d 100644 --- a/license-generator/generate.hs +++ b/license-generator/generate.hs @@ -47,6 +47,7 @@ main = do putStrLn "" manager <- newManager tlsManagerSettings results <- traverse (\d -> (d,) <$> depsLicense manager d) deps + echoLgpl let failures = filter (not . snd) results if not (null failures) then do @@ -63,6 +64,10 @@ echoHeader :: IO () echoHeader = readFile "license-generator/header.txt" >>= putStr +echoLgpl :: IO () +echoLgpl = + readFile "license-generator/lgpl.txt" >>= putStr + depsNamesAndVersions :: IO [(String, String)] depsNamesAndVersions = do contents <- lines <$> getContents diff --git a/license-generator/header.txt b/license-generator/header.txt index cdebf0bb84..9ce87381dd 100644 --- a/license-generator/header.txt +++ b/license-generator/header.txt @@ -12,4 +12,17 @@ Redistribution and use in source and binary forms, with or without modification, THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +PureScript executables for Linux distributed under the Releases tab of its GitHub +repository (https://github.com/purescript/purescript) may be statically-linked to +a version of GMP, licensed under the GNU Lesser General Public License Version 3, +29 June 2007. + +The full source code of PureScript is available in the aforementioned repository, +https://github.com/purescript/purescript, allowing you to modify and relink the +GMP portion if desired. + +GMP source code is available at: https://gmplib.org/ + +A copy of the LGPL is reproduced below. + PureScript uses the following Haskell library packages. Their license files follow. diff --git a/license-generator/lgpl.txt b/license-generator/lgpl.txt new file mode 100644 index 0000000000..12fad8bef5 --- /dev/null +++ b/license-generator/lgpl.txt @@ -0,0 +1,158 @@ +============================================================================ + +GNU LESSER GENERAL PUBLIC LICENSE +Version 3, 29 June 2007 + +Copyright (C) 2007 Free Software Foundation, Inc. + +Everyone is permitted to copy and distribute verbatim copies of this license +document, but changing it is not allowed. + +This version of the GNU Lesser General Public License incorporates the terms +and conditions of version 3 of the GNU General Public License, supplemented +by the additional permissions listed below. + +0. Additional Definitions. + +As used herein, “this License” refers to version 3 of the GNU Lesser General +Public License, and the “GNU GPL” refers to version 3 of the +GNU General Public License. + +“The Library” refers to a covered work governed by this License, other than +an Application or a Combined Work as defined below. + +An “Application” is any work that makes use of an interface provided by the +Library, but which is not otherwise based on the Library. Defining a subclass +of a class defined by the Library is deemed a mode of using an interface +provided by the Library. + +A “Combined Work” is a work produced by combining or linking an Application +with the Library. The particular version of the Library with which the +Combined Work was made is also called the “Linked Version”. + +The “Minimal Corresponding Source” for a Combined Work means the Corresponding +Source for the Combined Work, excluding any source code for portions of the +Combined Work that, considered in isolation, are based on the Application, +and not on the Linked Version. + +The “Corresponding Application Code” for a Combined Work means the object code +and/or source code for the Application, including any data and utility programs +needed for reproducing the Combined Work from the Application, but excluding +the System Libraries of the Combined Work. + +1. Exception to Section 3 of the GNU GPL. + +You may convey a covered work under sections 3 and 4 of this License without +being bound by section 3 of the GNU GPL. + +2. Conveying Modified Versions. + +If you modify a copy of the Library, and, in your modifications, a facility +refers to a function or data to be supplied by an Application that uses the +facility (other than as an argument passed when the facility is invoked), +then you may convey a copy of the modified version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the function or + data, the facility still operates, and performs whatever part of its + purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of this + License applicable to that copy. + +3. Object Code Incorporating Material from Library Header Files. + +The object code form of an Application may incorporate material from a header +file that is part of the Library. You may convey such object code under terms +of your choice, provided that, if the incorporated material is not limited to +numerical parameters, data structure layouts and accessors, or small macros, +inline functions and templates (ten or fewer lines in length), +you do both of the following: + + a) Give prominent notice with each copy of the object code that the Library + is used in it and that the Library and its use are covered by this License. + + b) Accompany the object code with a copy of the GNU GPL + and this license document. + +4. Combined Works. + +You may convey a Combined Work under terms of your choice that, taken together, +effectively do not restrict modification of the portions of the Library +contained in the Combined Work and reverse engineering for debugging such +modifications, if you also do each of the following: + + a) Give prominent notice with each copy of the Combined Work that the + Library is used in it and that the Library and its use are covered + by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and + this license document. + + c) For a Combined Work that displays copyright notices during execution, + include the copyright notice for the Library among these notices, as well + as a reference directing the user to the copies of the GNU GPL + and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form suitable + for, and under terms that permit, the user to recombine or relink + the Application with a modified version of the Linked Version to + produce a modified Combined Work, in the manner specified by section 6 + of the GNU GPL for conveying Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time a + copy of the Library already present on the user's computer system, + and (b) will operate properly with a modified version of the Library + that is interface-compatible with the Linked Version. + + e) Provide Installation Information, but only if you would otherwise be + required to provide such information under section 6 of the GNU GPL, and + only to the extent that such information is necessary to install and + execute a modified version of the Combined Work produced by recombining + or relinking the Application with a modified version of the Linked Version. + (If you use option 4d0, the Installation Information must accompany the + Minimal Corresponding Source and Corresponding Application Code. If you + use option 4d1, you must provide the Installation Information in the + manner specified by section 6 of the GNU GPL for + conveying Corresponding Source.) + +5. Combined Libraries. + +You may place library facilities that are a work based on the Library side by +side in a single library together with other library facilities that are not +Applications and are not covered by this License, and convey such a combined +library under terms of your choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based on + the Library, uncombined with any other library facilities, conveyed under + the terms of this License. + + b) Give prominent notice with the combined library that part of it is a + work based on the Library, and explaining where to find the accompanying + uncombined form of the same work. + +6. Revised Versions of the GNU Lesser General Public License. + +The Free Software Foundation may publish revised and/or new versions of the +GNU Lesser General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Library as you +received it specifies that a certain numbered version of the GNU Lesser +General Public License “or any later version” applies to it, you have the +option of following the terms and conditions either of that published version +or of any later version published by the Free Software Foundation. If the +Library as you received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser General +Public License ever published by the Free Software Foundation. + +If the Library as you received it specifies that a proxy can decide whether +future versions of the GNU Lesser General Public License shall apply, that +proxy's public statement of acceptance of any version is permanent +authorization for you to choose that version for the Library. + diff --git a/purescript.cabal b/purescript.cabal index 5cecca41fc..7601ec3954 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -175,7 +175,7 @@ common defaults file-embed >=0.0.16.0 && <0.1, filepath >=1.4.301.0 && <1.5, Glob >=0.10.2 && <0.11, - haskeline ==0.8.2, + haskeline >=0.8.2.1 && <0.9, language-javascript ==0.7.0.0, lens >=5.3.4 && <5.4, lifted-async >=0.10.2.7 && <0.11, @@ -395,6 +395,8 @@ library Paths_purescript autogen-modules: Paths_purescript + build-tool-depends: + happy:happy ==2.0.2 executable purs import: defaults @@ -429,6 +431,8 @@ executable purs Paths_purescript autogen-modules: Paths_purescript + if flag(static) + ld-options: -static -pthread test-suite tests import: defaults @@ -483,3 +487,8 @@ test-suite tests TestSourceMaps TestUtils Paths_purescript + +flag static + description: Builds a statically-linked version of the PureScript compiler. + manual: True + default: False diff --git a/stack.yaml b/stack.yaml index 500fd823cf..0fc0132869 100644 --- a/stack.yaml +++ b/stack.yaml @@ -14,7 +14,6 @@ extra-deps: # https://github.com/erikd/language-javascript/issues/131 - language-javascript-0.7.0.0 - bower-json-1.1.0.0 -- haskeline-0.8.2 - these-1.2.1 - aeson-better-errors-0.9.1.3 @@ -31,11 +30,3 @@ nix: flags: aeson-pretty: lib-only: true - haskeline: - # Avoids a libtinfo dynamic library dependency - terminfo: false - -allow-newer: true -allow-newer-deps: -- haskeline -- weeder diff --git a/stack.yaml.lock b/stack.yaml.lock index 8a4853c3fa..57dab5ca82 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -18,13 +18,6 @@ packages: size: 419 original: hackage: bower-json-1.1.0.0 -- completed: - hackage: haskeline-0.8.2@sha256:3b4b594095d64f5fa199b07bdca7d6b790313ed7f380a1b061845507e6563880,6005 - pantry-tree: - sha256: 17ee6b093c5135399b8e6bc3a63d9c6a4b0bc2100b495d2d974bc1464769de39 - size: 2955 - original: - hackage: haskeline-0.8.2 - completed: hackage: these-1.2.1@sha256:35c57aede96c15ea1fed559ac287b1168eb2b2869d79e62ed8c845780b7ea136,2294 pantry-tree: From 8ac0fb2962a7df318a74216872465dc2868c6064 Mon Sep 17 00:00:00 2001 From: seastian Date: Sat, 18 Oct 2025 16:24:57 +0200 Subject: [PATCH 1577/1580] Use -fspecialize-aggressively to improve performance by 30% on ACME build (#4584) * Use -fspecialize-aggressively to improve performance * add fspecialize to cabal project --- cabal.project | 9 ++++++--- stack.yaml | 2 +- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/cabal.project b/cabal.project index 453d64732d..d6a4a8e102 100644 --- a/cabal.project +++ b/cabal.project @@ -2,6 +2,9 @@ packages: purescript.cabal source-repository-package - type: git - location: https://github.com/purescript/cheapskate.git - tag: 633c69024e061ad956f1aecfc137fb99a7a7a20b + type: git + location: https://github.com/purescript/cheapskate.git + tag: 633c69024e061ad956f1aecfc137fb99a7a7a20b + +package purescript + ghc-options: -fspecialize-aggressively -fexpose-all-unfoldings diff --git a/stack.yaml b/stack.yaml index 0fc0132869..e87d094bcf 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,7 +6,7 @@ packages: - '.' ghc-options: # Build with advanced optimizations enabled by default - "$locals": -O2 -Werror + "$locals": -O2 -Werror -fspecialize-aggressively -fexpose-all-unfoldings extra-deps: # As of 2021-11-08, the latest release of `language-javascript` is 0.7.1.0, # but it has a problem with parsing the `async` keyword. It doesn't allow From 4c66c05a59a08b698ba5c34b48e8bf7744ecb9f6 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Sat, 14 Mar 2026 12:28:12 +0200 Subject: [PATCH 1578/1580] Prepare 0.15.16 release (#4591) * Bump version to 0.15.16 * Add missing changelog entries * Prepare changelog and licenses for 0.15.16 * Add autogen modules for cabal>2.0 * Replace deprecated macos-13 with macos-15-intel * Update to latest spago 1.0.3 for the package-set build * Install coreutils on the Alpine CI to get GNU env --- .github/workflows/ci.yml | 4 +-- CHANGELOG.d/fix_issue-4535.md | 1 - CHANGELOG.d/fix_issue-4545.md | 1 - .../internal_remove-git-upgrade-step-in-ci.md | 1 - CHANGELOG.d/internal_tool_updates.md | 2 -- CHANGELOG.d/internal_upgrade_to_ghc_9.6.md | 2 -- CHANGELOG.d/internal_upgrade_to_ghc_9.8.md | 2 -- CHANGELOG.d/misc_ghc-bump.md | 1 - CHANGELOG.d/misc_static_linking.md | 4 --- CHANGELOG.md | 34 +++++++++++++++++++ LICENSE | 1 - ci/build-package-set.sh | 2 +- license-generator/generate.hs | 1 + npm-package/package.json | 4 +-- purescript.cabal | 4 ++- 15 files changed, 43 insertions(+), 21 deletions(-) delete mode 100644 CHANGELOG.d/fix_issue-4535.md delete mode 100644 CHANGELOG.d/fix_issue-4545.md delete mode 100644 CHANGELOG.d/internal_remove-git-upgrade-step-in-ci.md delete mode 100644 CHANGELOG.d/internal_tool_updates.md delete mode 100644 CHANGELOG.d/internal_upgrade_to_ghc_9.6.md delete mode 100644 CHANGELOG.d/internal_upgrade_to_ghc_9.8.md delete mode 100644 CHANGELOG.d/misc_ghc-bump.md delete mode 100644 CHANGELOG.d/misc_static_linking.md diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 15532faa32..b73b5cbdd3 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -60,7 +60,7 @@ jobs: - image: quay.io/benz0li/ghc-musl:9.8.4 os: ubuntu-24.04-arm - - os: macos-13 # x64 + - os: macos-15-intel # x64 - os: macos-14 # arm64 - os: windows-2022 # x64 @@ -164,7 +164,7 @@ jobs: # Moreover, npm has a hook issue that will cause spago to fail to install # We upgrade npm to fix this run: | - apk add jq + apk add jq coreutils ../ci/fix-home stack --haddock exec ../ci/build-package-set.sh - name: Verify that 'libtinfo' isn't in binary diff --git a/CHANGELOG.d/fix_issue-4535.md b/CHANGELOG.d/fix_issue-4535.md deleted file mode 100644 index 77341885a9..0000000000 --- a/CHANGELOG.d/fix_issue-4535.md +++ /dev/null @@ -1 +0,0 @@ -* Fix compiler crash when a type operator is used in a type argument diff --git a/CHANGELOG.d/fix_issue-4545.md b/CHANGELOG.d/fix_issue-4545.md deleted file mode 100644 index 1d6462ee9c..0000000000 --- a/CHANGELOG.d/fix_issue-4545.md +++ /dev/null @@ -1 +0,0 @@ -* Speed up IDE performance on large projects diff --git a/CHANGELOG.d/internal_remove-git-upgrade-step-in-ci.md b/CHANGELOG.d/internal_remove-git-upgrade-step-in-ci.md deleted file mode 100644 index f7f622a96e..0000000000 --- a/CHANGELOG.d/internal_remove-git-upgrade-step-in-ci.md +++ /dev/null @@ -1 +0,0 @@ -* Remove the step that upgraded Git from the CI workflow diff --git a/CHANGELOG.d/internal_tool_updates.md b/CHANGELOG.d/internal_tool_updates.md deleted file mode 100644 index 3dcd762162..0000000000 --- a/CHANGELOG.d/internal_tool_updates.md +++ /dev/null @@ -1,2 +0,0 @@ -* Update weeder version in CI to 2.9.0 -* Add happy ==2.0.2 as build-tool-depends diff --git a/CHANGELOG.d/internal_upgrade_to_ghc_9.6.md b/CHANGELOG.d/internal_upgrade_to_ghc_9.6.md deleted file mode 100644 index 6622b6baed..0000000000 --- a/CHANGELOG.d/internal_upgrade_to_ghc_9.6.md +++ /dev/null @@ -1,2 +0,0 @@ -* Upgrade GHC to [`9.6.6`](https://downloads.haskell.org/~ghc/9.6.6/docs/users_guide/9.6.6-notes.html), Stackage LTS `22.43` -* Minimum required glibc version is bumped from [`2.28` to `2.31`](https://sourceware.org/glibc/wiki/Glibc%20Timeline) diff --git a/CHANGELOG.d/internal_upgrade_to_ghc_9.8.md b/CHANGELOG.d/internal_upgrade_to_ghc_9.8.md deleted file mode 100644 index 7f3fb0e074..0000000000 --- a/CHANGELOG.d/internal_upgrade_to_ghc_9.8.md +++ /dev/null @@ -1,2 +0,0 @@ -* Upgrade GHC to [`9.8.4`](https://downloads.haskell.org/~ghc/9.8.4/docs/users_guide/9.8.4-notes.html), Stackage LTS `23.18` -* Use [HLint 3.10](https://github.com/ndmitchell/hlint/blob/master/CHANGES.txt) in CI diff --git a/CHANGELOG.d/misc_ghc-bump.md b/CHANGELOG.d/misc_ghc-bump.md deleted file mode 100644 index a1222cf6d0..0000000000 --- a/CHANGELOG.d/misc_ghc-bump.md +++ /dev/null @@ -1 +0,0 @@ -* Update Stackage snapshot to lts-20.26 and GHC to 9.2.8 diff --git a/CHANGELOG.d/misc_static_linking.md b/CHANGELOG.d/misc_static_linking.md deleted file mode 100644 index 3a4ec56549..0000000000 --- a/CHANGELOG.d/misc_static_linking.md +++ /dev/null @@ -1,4 +0,0 @@ -* Enable statically-linked binaries using [ghc-musl](https://github.com/benz0li/ghc-musl) -* Update haskeline version bounds to >=0.8.2.1 && <0.9 - - Consequently, this fixes Cabal-based builds on GHC 9.8.4 diff --git a/CHANGELOG.md b/CHANGELOG.md index 27a87cc478..d2dbd016b3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,40 @@ Notable changes to this project are documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## 0.15.16 + +Bugfixes: + +* Fix compiler crash when a type operator is used in a type argument (#4536 by @purefunctor) + +* Speed up IDE performance on large projects (#4546 by @roryc89) + +* Fix double click select of titles in generated documentation (#4579 by @ad-si) + +Other improvements: + +* Update Stackage snapshot to lts-20.26 and GHC to 9.2.8 (#4537 by @purefunctor) + +* Enable statically-linked binaries using [ghc-musl](https://github.com/benz0li/ghc-musl) (#4573 by @purefunctor) +* Update haskeline version bounds to >=0.8.2.1 && <0.9 + + Consequently, this fixes Cabal-based builds on GHC 9.8.4 + +Internal: + +* Remove the step that upgraded Git from the CI workflow (#4541 by @rhendric) + +* Upgrade GHC to [`9.6.6`](https://downloads.haskell.org/~ghc/9.6.6/docs/users_guide/9.6.6-notes.html), Stackage LTS `22.43` (#4568 by @ad-si) +* Minimum required glibc version is bumped from [`2.28` to `2.31`](https://sourceware.org/glibc/wiki/Glibc%20Timeline) + +* Upgrade GHC to [`9.8.4`](https://downloads.haskell.org/~ghc/9.8.4/docs/users_guide/9.8.4-notes.html), Stackage LTS `23.18` (#4574 by @ad-si) +* Use [HLint 3.10](https://github.com/ndmitchell/hlint/blob/master/CHANGES.txt) in CI + +* Update weeder version in CI to 2.9.0 (#4573 by @purefunctor) +* Add happy ==2.0.2 as build-tool-depends + +* Use `-fspecialize-aggressively` GHC option to improve compiler performance by ~30% on large builds (#4584 by @seastian) + ## 0.15.15 New features: diff --git a/LICENSE b/LICENSE index 86b917570e..6b8251ded8 100644 --- a/LICENSE +++ b/LICENSE @@ -94,7 +94,6 @@ PureScript uses the following Haskell library packages. Their license files foll ghc-prim half happy - happy-lib hashable haskeline indexed-traversable diff --git a/ci/build-package-set.sh b/ci/build-package-set.sh index f11b556871..174757d384 100755 --- a/ci/build-package-set.sh +++ b/ci/build-package-set.sh @@ -16,7 +16,7 @@ export PATH="$tmpdir/node_modules/.bin:$PATH" cd "$tmpdir" echo ::group::Ensure Spago is available -which spago || npm install spago@0.93.43 +which spago || npm install spago echo ::endgroup:: echo ::group::Create dummy project diff --git a/license-generator/generate.hs b/license-generator/generate.hs index f755ee8c2d..09f7ab89b6 100644 --- a/license-generator/generate.hs +++ b/license-generator/generate.hs @@ -79,6 +79,7 @@ depsNamesAndVersions = do name == "purescript" || name == "rts" || name == "ghc-boot-th" + || name == "happy-lib" parse line = case splitOn " " line of diff --git a/npm-package/package.json b/npm-package/package.json index 56772d2b55..a1bbc7f452 100644 --- a/npm-package/package.json +++ b/npm-package/package.json @@ -1,6 +1,6 @@ { "name": "purescript", - "version": "0.15.15", + "version": "0.15.16", "license": "ISC", "description": "PureScript wrapper that makes it available as a local dependency", "author": { @@ -43,7 +43,7 @@ ], "scripts": { "prepublishOnly": "node -e \"require('fs').copyFileSync('purs.bin.placeholder', 'purs.bin');\"", - "postinstall": "install-purescript --purs-ver=0.15.15", + "postinstall": "install-purescript --purs-ver=0.15.16", "test": "echo 'Error: no test specified' && exit 1" } } diff --git a/purescript.cabal b/purescript.cabal index 7601ec3954..0a36e8c0b4 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -2,7 +2,7 @@ cabal-version: 2.4 name: purescript -- Note: don't add prerelease identifiers here! Add them in app/Version.hs and npm-package/package.json instead. -version: 0.15.15 +version: 0.15.16 synopsis: PureScript Programming Language Compiler description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. category: Language @@ -487,6 +487,8 @@ test-suite tests TestSourceMaps TestUtils Paths_purescript + autogen-modules: + Paths_purescript flag static description: Builds a statically-linked version of the PureScript compiler. From c4a35b34b99af5feaa706ca0dadcb568788aff33 Mon Sep 17 00:00:00 2001 From: drathier Date: Wed, 25 Mar 2026 00:27:47 +0100 Subject: [PATCH 1579/1580] Fix typo in CoreFn traversal function (#4561) --- CHANGELOG.d/internal_fix-typo-in-traversal.md | 1 + CONTRIBUTORS.md | 1 + src/Language/PureScript/CoreFn/Traversals.hs | 2 +- 3 files changed, 3 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG.d/internal_fix-typo-in-traversal.md diff --git a/CHANGELOG.d/internal_fix-typo-in-traversal.md b/CHANGELOG.d/internal_fix-typo-in-traversal.md new file mode 100644 index 0000000000..98dfa19747 --- /dev/null +++ b/CHANGELOG.d/internal_fix-typo-in-traversal.md @@ -0,0 +1 @@ +* Fix typo in CoreFn.Traversals.traverseCoreFn which caused it to not recurse into Let bodies diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index cfbb98e362..3a4fb44ab8 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -169,6 +169,7 @@ If you would prefer to use different terms, please use the section below instead | [@xgrommx](https://github.com/xgrommx) | Denis Stoyanov | [MIT license] | | [@zudov](https://github.com/zudov) | Konstantin Zudov | [MIT license] | | [@roryc89](https://github.com/roryc89) | Rory Campbell | [MIT license] | +| [@drathier](https://github.com/drathier) | Drathier | [MIT license] | ### Contributors using Modified Terms diff --git a/src/Language/PureScript/CoreFn/Traversals.hs b/src/Language/PureScript/CoreFn/Traversals.hs index f0684d34d5..4b5faa10cd 100644 --- a/src/Language/PureScript/CoreFn/Traversals.hs +++ b/src/Language/PureScript/CoreFn/Traversals.hs @@ -70,7 +70,7 @@ traverseCoreFn f g h i = (f', g', h', i') g' (Abs ann name e) = Abs ann name <$> g e g' (App ann v1 v2) = App ann <$> g v1 <*> g v2 g' (Case ann vs alts) = Case ann <$> traverse g vs <*> traverse i alts - g' (Let ann ds e) = Let ann <$> traverse f ds <*> g' e + g' (Let ann ds e) = Let ann <$> traverse f ds <*> g e g' e = pure e h' (LiteralBinder a b) = LiteralBinder a <$> handleLiteral h b From cb3c4965c8468d26c9b14cf0319db6dbd06ee4ff Mon Sep 17 00:00:00 2001 From: Mark Eibes Date: Sun, 7 Jun 2026 17:31:51 +0200 Subject: [PATCH 1580/1580] Add attached derive clauses to data and newtype declarations (#4594) --- ci/build.sh | 8 ++- src/Language/PureScript/CST/Convert.hs | 59 ++++++++++++------- src/Language/PureScript/CST/Flatten.hs | 19 ++++-- src/Language/PureScript/CST/Parser.y | 12 +++- src/Language/PureScript/CST/Positions.hs | 11 +++- src/Language/PureScript/CST/Types.hs | 13 +++- .../PureScript/Sugar/TypeClasses/Deriving.hs | 24 ++++++-- .../purs/failing/DeriveClauseCannotDerive.out | 14 +++++ .../failing/DeriveClauseCannotDerive.purs | 7 +++ tests/purs/failing/DeriveClauseEither2.out | 24 ++++++++ tests/purs/failing/DeriveClauseEither2.purs | 7 +++ .../purs/failing/DeriveClauseKindMismatch.out | 24 ++++++++ .../failing/DeriveClauseKindMismatch.purs | 7 +++ .../failing/DeriveClauseNewtypeOverlap.out | 24 ++++++++ .../failing/DeriveClauseNewtypeOverlap.purs | 13 ++++ tests/purs/passing/DerivingClause.purs | 53 +++++++++++++++++ 16 files changed, 279 insertions(+), 40 deletions(-) create mode 100644 tests/purs/failing/DeriveClauseCannotDerive.out create mode 100644 tests/purs/failing/DeriveClauseCannotDerive.purs create mode 100644 tests/purs/failing/DeriveClauseEither2.out create mode 100644 tests/purs/failing/DeriveClauseEither2.purs create mode 100644 tests/purs/failing/DeriveClauseKindMismatch.out create mode 100644 tests/purs/failing/DeriveClauseKindMismatch.purs create mode 100644 tests/purs/failing/DeriveClauseNewtypeOverlap.out create mode 100644 tests/purs/failing/DeriveClauseNewtypeOverlap.purs create mode 100644 tests/purs/passing/DerivingClause.purs diff --git a/ci/build.sh b/ci/build.sh index c551dfd51a..180c3545a3 100755 --- a/ci/build.sh +++ b/ci/build.sh @@ -176,9 +176,11 @@ tar -xzf sdist-test/purescript-*.tar.gz -C sdist-test --strip-components=1 (echo "::endgroup::"; echo "::group::Build and test PureScript") 2>/dev/null pushd sdist-test -# Haddock -Werror goes here to keep us honest but prevent failing on -# documentation errors in dependencies -$STACK build $STACK_OPTS --haddock-arguments --optghc=-Werror +# --ghc-options -Werror applies only to local packages, catching our own +# haddock doc-comment errors without failing on warnings in dependencies. +# (--haddock-arguments --optghc=-Werror would pass -Werror to all packages +# via haddock, which breaks when the dependency cache is cold.) +$STACK build $STACK_OPTS --ghc-options -Werror if [ "$do_prerelease" ] then diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index 59b68adf1d..db1a5ff5ff 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -445,7 +445,7 @@ convertBinder fileName = go convertDeclaration :: String -> Declaration a -> [AST.Declaration] convertDeclaration fileName decl = case decl of - DeclData _ (DataHead _ a vars) bd -> do + DeclData _ (DataHead _ a vars) bd deriveClauses -> do let ctrs :: SourceToken -> DataCtor b -> [(SourceToken, DataCtor b)] -> [AST.DataConstructorDeclaration] ctrs st (DataCtor _ name fields) tl @@ -454,15 +454,17 @@ convertDeclaration fileName decl = case decl of [] -> [] (st', ctor) : tl' -> ctrs st' ctor tl' ) - pure $ AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) (maybe [] (\(st, Separated hd tl) -> ctrs st hd tl) bd) + AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) (maybe [] (\(st, Separated hd tl) -> ctrs st hd tl) bd) + : convertDeriveClauses fileName (nameValue a) deriveClauses DeclType _ (DataHead _ a vars) _ bd -> pure $ AST.TypeSynonymDeclaration ann (nameValue a) (goTypeVar <$> vars) (convertType fileName bd) - DeclNewtype _ (DataHead _ a vars) st x ys -> do + DeclNewtype _ (DataHead _ a vars) st x ys deriveClauses -> do let ctrs = [AST.DataConstructorDeclaration (sourceAnnCommented fileName st (snd $ declRange decl)) (nameValue x) [(headDef (internalError "No constructor name") ctrFields, convertType fileName ys)]] - pure $ AST.DataDeclaration ann Env.Newtype (nameValue a) (goTypeVar <$> vars) ctrs + AST.DataDeclaration ann Env.Newtype (nameValue a) (goTypeVar <$> vars) ctrs + : convertDeriveClauses fileName (nameValue a) deriveClauses DeclClass _ (ClassHead _ sup name vars fdeps) bd -> do let goTyVar (TypeVarKinded (Wrapped _ (Labeled (_, a) _ _) _)) = nameValue a @@ -553,25 +555,8 @@ convertDeclaration fileName decl = case decl of mkPartialInstanceName :: Maybe (Name Ident, SourceToken) -> QualifiedName (N.ProperName 'N.ClassName) -> [Type a] -> Either Text.Text N.Ident mkPartialInstanceName nameSep cls args = - maybe (Left genName) (Right . ident . nameValue . fst) nameSep + maybe (Left (genInstanceName cls (foldMap argName args))) (Right . ident . nameValue . fst) nameSep where - -- truncate to 25 chars to reduce verbosity - -- of name and still keep it readable - -- name will be used to create a GenIdent - -- in desugaring process - genName :: Text.Text - genName = Text.take 25 (className <> typeArgs) - - className :: Text.Text - className - = foldMap (uncurry Text.cons . first toLower) - . Text.uncons - . N.runProperName - $ qualName cls - - typeArgs :: Text.Text - typeArgs = foldMap argName args - argName :: Type a -> Text.Text argName = \case -- These are only useful to disambiguate between overlapping instances @@ -619,6 +604,36 @@ convertDeclaration fileName decl = case decl of else (fst $ qualRange cls, snd $ typeRange $ last args) +convertDeriveClauses + :: String + -> N.ProperName 'N.TypeName + -> [DeriveClause] + -> [AST.Declaration] +convertDeriveClauses fileName tyName = concatMap go + where + go (DeriveClause _ (Wrapped _ classes _)) = map convertClass (toList classes) + convertClass (DeriveClass cls) = + AST.TypeInstanceDeclaration clsAnn clsAnn chainId 0 (Left genName) + [] + (qualified cls) + [tyCon] + AST.DerivedInstance + where + clsAnn = uncurry (sourceAnnCommented fileName) (qualRange cls) + chainId = mkChainId fileName (Pos.spanStart (fst clsAnn)) + tyCon = T.TypeConstructor clsAnn (N.Qualified N.ByNullSourcePos tyName) + genName = genInstanceName cls (N.runProperName tyName) + +genInstanceName :: QualifiedName (N.ProperName 'N.ClassName) -> Text.Text -> Text.Text +genInstanceName cls typeArgs = Text.take 25 (className <> typeArgs) + where + className :: Text.Text + className + = foldMap (uncurry Text.cons . first toLower) + . Text.uncons + . N.runProperName + $ qualName cls + convertSignature :: String -> Labeled (Name Ident) (Type a) -> AST.Declaration convertSignature fileName (Labeled a _ b) = do let diff --git a/src/Language/PureScript/CST/Flatten.hs b/src/Language/PureScript/CST/Flatten.hs index 890614070d..3f2e4cda94 100644 --- a/src/Language/PureScript/CST/Flatten.hs +++ b/src/Language/PureScript/CST/Flatten.hs @@ -205,11 +205,12 @@ flattenRole = pure . roleTok flattenDeclaration :: Declaration a -> DList SourceToken flattenDeclaration = \case - DeclData _ a b -> + DeclData _ a b drvs -> flattenDataHead a <> - foldMap (\(t, cs) -> pure t <> flattenSeparated flattenDataCtor cs) b - DeclType _ a b c ->flattenDataHead a <> pure b <> flattenType c - DeclNewtype _ a b c d -> flattenDataHead a <> pure b <> flattenName c <> flattenType d + foldMap (\(t, ctrs) -> pure t <> flattenSeparated flattenDataCtor ctrs) b <> + foldMap flattenDeriveClause drvs + DeclType _ a b c -> flattenDataHead a <> pure b <> flattenType c + DeclNewtype _ a b c d drvs -> flattenDataHead a <> pure b <> flattenName c <> flattenType d <> foldMap flattenDeriveClause drvs DeclClass _ a b -> flattenClassHead a <> foldMap (\(c, d) -> pure c <> foldMap (flattenLabeled flattenName flattenType) d) b @@ -222,6 +223,16 @@ flattenDeclaration = \case DeclRole _ a b c d -> pure a <> pure b <> flattenName c <> foldMap flattenRole d DeclValue _ a -> flattenValueBindingFields a + where + flattenDeriveClass :: DeriveClass -> DList SourceToken + flattenDeriveClass (DeriveClass cls) = + flattenQualifiedName cls + + flattenDeriveClause :: DeriveClause -> DList SourceToken + flattenDeriveClause (DeriveClause kw classes) = + pure kw <> + flattenWrapped (flattenSeparated flattenDeriveClass) classes + flattenQualifiedName :: QualifiedName a -> DList SourceToken flattenQualifiedName = pure . qualTok diff --git a/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y index 55aa95da79..9560619a4a 100644 --- a/src/Language/PureScript/CST/Parser.y +++ b/src/Language/PureScript/CST/Parser.y @@ -661,10 +661,10 @@ import :: { Import () } | 'class' properName { ImportClass () $1 (getProperName $2) } decl :: { Declaration () } - : dataHead { DeclData () $1 Nothing } - | dataHead '=' sep(dataCtor, '|') { DeclData () $1 (Just ($2, $3)) } + : dataHead manyOrEmpty(deriveClause) { DeclData () $1 Nothing $2 } + | dataHead '=' sep(dataCtor, '|') manyOrEmpty(deriveClause) { DeclData () $1 (Just ($2, $3)) $4 } | typeHead '=' type {% checkNoWildcards $3 *> pure (DeclType () $1 $2 $3) } - | newtypeHead '=' properName typeAtom {% checkNoWildcards $4 *> pure (DeclNewtype () $1 $2 (getProperName $3) $4) } + | newtypeHead '=' properName typeAtom manyOrEmpty(deriveClause) {% checkNoWildcards $4 *> pure (DeclNewtype () $1 $2 (getProperName $3) $4 $5) } | classHead { either id (\h -> DeclClass () h Nothing) $1 } | classHead 'where' '\{' manySep(classMember, '\;') '\}' {% either (const (parseError $2)) (\h -> pure $ DeclClass () h (Just ($2, $4))) $1 } | instHead { DeclInstanceChain () (Separated (Instance $1 Nothing) []) } @@ -681,6 +681,12 @@ decl :: { Declaration () } | 'foreign' 'import' 'data' properName '::' type { DeclForeign () $1 $2 (ForeignData $3 (Labeled (getProperName $4) $5 $6)) } | 'type' 'role' properName many(role) { DeclRole () $1 $2 (getProperName $3) $4 } +deriveClause :: { DeriveClause } + : 'derive' '(' sep(deriveClass, ',') ')' { DeriveClause $1 (Wrapped $2 $3 $4) } + +deriveClass :: { DeriveClass } + : qualProperName { DeriveClass (getQualifiedProperName $1) } + dataHead :: { DataHead () } : 'data' properName manyOrEmpty(typeVarBindingPlain) { DataHead $1 (getProperName $2) $3 } diff --git a/src/Language/PureScript/CST/Positions.hs b/src/Language/PureScript/CST/Positions.hs index 20d5724271..63282e4bef 100644 --- a/src/Language/PureScript/CST/Positions.hs +++ b/src/Language/PureScript/CST/Positions.hs @@ -157,14 +157,21 @@ dataMembersRange = \case DataAll _ a -> (a, a) DataEnumerated _ (Wrapped a _ b) -> (a, b) +deriveClauseRange :: DeriveClause -> TokenRange +deriveClauseRange (DeriveClause kw classes) = (kw, wrpClose classes) + declRange :: Declaration a -> TokenRange declRange = \case - DeclData _ hd ctors + DeclData _ hd ctors drvs + | _:_ <- drvs -> (fst start, snd . deriveClauseRange $ last drvs) | Just (_, cs) <- ctors -> (fst start, snd . dataCtorRange $ sepLast cs) | otherwise -> start where start = dataHeadRange hd DeclType _ a _ b -> (fst $ dataHeadRange a, snd $ typeRange b) - DeclNewtype _ a _ _ b -> (fst $ dataHeadRange a, snd $ typeRange b) + DeclNewtype _ a _ _ b drvs + | _:_ <- drvs -> (fst start, snd . deriveClauseRange $ last drvs) + | otherwise -> start + where start = (fst $ dataHeadRange a, snd $ typeRange b) DeclClass _ hd body | Just (_, ts) <- body -> (fst start, snd . typeRange . lblValue $ NE.last ts) | otherwise -> start diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs index ba90f7e95b..cf4345e5de 100644 --- a/src/Language/PureScript/CST/Types.hs +++ b/src/Language/PureScript/CST/Types.hs @@ -194,10 +194,19 @@ data DataMembers a | DataEnumerated a (Delimited (Name (N.ProperName 'N.ConstructorName))) deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +data DeriveClass = DeriveClass + { dcClass :: QualifiedName (N.ProperName 'N.ClassName) + } deriving (Show, Eq, Ord, Generic) + +data DeriveClause = DeriveClause + { dclKeyword :: SourceToken + , dclClasses :: Wrapped (Separated DeriveClass) + } deriving (Show, Eq, Ord, Generic) + data Declaration a - = DeclData a (DataHead a) (Maybe (SourceToken, Separated (DataCtor a))) + = DeclData a (DataHead a) (Maybe (SourceToken, Separated (DataCtor a))) [DeriveClause] | DeclType a (DataHead a) SourceToken (Type a) - | DeclNewtype a (DataHead a) SourceToken (Name (N.ProperName 'N.ConstructorName)) (Type a) + | DeclNewtype a (DataHead a) SourceToken (Name (N.ProperName 'N.ConstructorName)) (Type a) [DeriveClause] | DeclClass a (ClassHead a) (Maybe (SourceToken, NonEmpty (Labeled (Name Ident) (Type a)))) | DeclInstanceChain a (Separated (Instance a)) | DeclDerive a SourceToken (Maybe SourceToken) (InstanceHead a) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 3b4c019521..ddbc9097a0 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -15,7 +15,7 @@ import Language.PureScript.Environment (DataDeclType(..), NameKind(..)) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage') import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), freshIdent) import Language.PureScript.PSString (mkString) -import Language.PureScript.Types (SourceType, Type(..), WildcardData(..), replaceAllTypeVars, srcTypeApp, srcTypeConstructor, srcTypeLevelString) +import Language.PureScript.Types (SourceType, Type(..), WildcardData(..), replaceAllTypeVars, srcTypeApp, srcTypeConstructor, srcTypeLevelString, srcTypeVar) import Language.PureScript.TypeChecker (checkNewtype) -- | Elaborates deriving instance declarations by code generation. @@ -46,16 +46,32 @@ deriveInstance deriveInstance mn ds decl = case decl of TypeInstanceDeclaration sa@(ss, _) na ch idx nm deps className tys DerivedInstance -> let + -- Attached `derive (Generic)` / `derive (Newtype)` produces `[T]`. + -- These two classes need the fully-applied type plus a trailing + -- wildcard, so pad the args before falling into the standard handler. + paddedTys = case tys of + [bareTy] + | className == Libs.Generic || className == Libs.Newtype + , Just utc <- unwrapTypeConstructor bareTy + , mn == utcModuleName utc + , null (utcArgs utc) + , Just (DataDeclaration _ _ _ tyVars _) <- find (matchesTyName (utcTyCon utc)) ds -> + let applied = foldl srcTypeApp bareTy (map (srcTypeVar . fst) tyVars) + in [applied, TypeWildcard sa UnnamedWildcard] + _ -> tys + matchesTyName n (DataDeclaration _ _ n' _ _) = n == n' + matchesTyName _ _ = False + binaryWildcardClass :: (Declaration -> [SourceType] -> m ([Declaration], SourceType)) -> m Declaration - binaryWildcardClass f = case tys of + binaryWildcardClass f = case paddedTys of [ty1, ty2] -> case unwrapTypeConstructor ty1 of Just UnwrappedTypeConstructor{..} | mn == utcModuleName -> do checkIsWildcard ss utcTyCon ty2 tyConDecl <- findTypeDecl ss utcTyCon ds (members, ty2') <- f tyConDecl utcArgs pure $ TypeInstanceDeclaration sa na ch idx nm deps className [ty1, ty2'] (ExplicitInstance members) - _ -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty1 - _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 + _ -> throwError . errorMessage' ss $ ExpectedTypeConstructor className paddedTys ty1 + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className paddedTys 2 in case className of Libs.Generic -> binaryWildcardClass (deriveGenericRep ss mn) diff --git a/tests/purs/failing/DeriveClauseCannotDerive.out b/tests/purs/failing/DeriveClauseCannotDerive.out new file mode 100644 index 0000000000..a654d7db7e --- /dev/null +++ b/tests/purs/failing/DeriveClauseCannotDerive.out @@ -0,0 +1,14 @@ +Error found: +in module Main +at tests/purs/failing/DeriveClauseCannotDerive.purs:7:11 - 7:18 (line 7, column 11 - line 7, column 18) + + Cannot derive a type class instance for +   +  Main.MyClass Foo +   + since instances of this type class are not derivable. + + +See https://github.com/purescript/documentation/blob/master/errors/CannotDerive.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeriveClauseCannotDerive.purs b/tests/purs/failing/DeriveClauseCannotDerive.purs new file mode 100644 index 0000000000..7ca01a293e --- /dev/null +++ b/tests/purs/failing/DeriveClauseCannotDerive.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith CannotDerive +module Main where + +class MyClass a + +data Foo a = Foo a + derive (MyClass) diff --git a/tests/purs/failing/DeriveClauseEither2.out b/tests/purs/failing/DeriveClauseEither2.out new file mode 100644 index 0000000000..9ed2a40315 --- /dev/null +++ b/tests/purs/failing/DeriveClauseEither2.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/DeriveClauseEither2.purs:7:11 - 7:13 (line 7, column 11 - line 7, column 13) + + Could not match kind +   +  Type -> Type -> Type +   + with kind +   +  Type +   + +while checking that type Either2 + has kind Type +while inferring the kind of Eq Either2 +in type class instance +  + Data.Eq.Eq Either2 +  + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeriveClauseEither2.purs b/tests/purs/failing/DeriveClauseEither2.purs new file mode 100644 index 0000000000..24a0c00053 --- /dev/null +++ b/tests/purs/failing/DeriveClauseEither2.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +import Prelude + +data Either2 a b = Left2 a | Right2 b + derive (Eq) diff --git a/tests/purs/failing/DeriveClauseKindMismatch.out b/tests/purs/failing/DeriveClauseKindMismatch.out new file mode 100644 index 0000000000..65799ec128 --- /dev/null +++ b/tests/purs/failing/DeriveClauseKindMismatch.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/DeriveClauseKindMismatch.purs:7:11 - 7:13 (line 7, column 11 - line 7, column 13) + + Could not match kind +   +  Type -> Type +   + with kind +   +  Type +   + +while checking that type Box + has kind Type +while inferring the kind of Eq Box +in type class instance +  + Data.Eq.Eq Box +  + +See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeriveClauseKindMismatch.purs b/tests/purs/failing/DeriveClauseKindMismatch.purs new file mode 100644 index 0000000000..5404a49dee --- /dev/null +++ b/tests/purs/failing/DeriveClauseKindMismatch.purs @@ -0,0 +1,7 @@ +-- @shouldFailWith KindsDoNotUnify +module Main where + +import Prelude + +data Box a = Box a + derive (Eq) diff --git a/tests/purs/failing/DeriveClauseNewtypeOverlap.out b/tests/purs/failing/DeriveClauseNewtypeOverlap.out new file mode 100644 index 0000000000..fcbfbb733e --- /dev/null +++ b/tests/purs/failing/DeriveClauseNewtypeOverlap.out @@ -0,0 +1,24 @@ +Error found: +in module Main +at tests/purs/failing/DeriveClauseNewtypeOverlap.purs:10:1 - 10:34 (line 10, column 1 - line 10, column 34) + + Overlapping type class instances found for +   +  Data.Newtype.Newtype Wrapper +  String  +   + The following instances were found: + + instance in module Main with type Newtype Wrapper String (line 8, column 11 - line 8, column 18) + instance in module Main with type Newtype Wrapper String (line 10, column 1 - line 10, column 34) + + +in type class instance +  + Data.Newtype.Newtype Wrapper + String  +  + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingInstances.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DeriveClauseNewtypeOverlap.purs b/tests/purs/failing/DeriveClauseNewtypeOverlap.purs new file mode 100644 index 0000000000..0ba9b83cfb --- /dev/null +++ b/tests/purs/failing/DeriveClauseNewtypeOverlap.purs @@ -0,0 +1,13 @@ +-- @shouldFailWith OverlappingInstances +module Main where + +import Prelude +import Data.Newtype (class Newtype, unwrap) + +newtype Wrapper = Wrapper String + derive (Newtype) + +derive instance Newtype Wrapper _ + +value :: String +value = unwrap (Wrapper "hi") diff --git a/tests/purs/passing/DerivingClause.purs b/tests/purs/passing/DerivingClause.purs new file mode 100644 index 0000000000..a7f5ed2adb --- /dev/null +++ b/tests/purs/passing/DerivingClause.purs @@ -0,0 +1,53 @@ +module Main where + +import Prelude + +import Data.Bifunctor (class Bifunctor, bimap) +import Data.Generic.Rep (class Generic) +import Data.Newtype (class Newtype) +import Data.Foldable (class Foldable, foldMap) +import Data.Traversable (class Traversable) +import Effect (Effect) +import Effect.Console (log) +import Test.Assert + +data Color = Red | Green | Blue + derive (Eq, Ord) + +newtype Name = Name String + derive (Eq, Ord) + +data List a = Nil | Cons a (List a) + derive (Functor, Foldable, Traversable) + +data Either2 a b = Left2 a | Right2 b + derive (Bifunctor) + +derive instance Eq a => Eq (Either2 a a) + +data Direction = North | South | East | West + derive (Generic) + +newtype Wrapper = Wrapper String + derive (Newtype) + +data Pair a = Pair a a + derive (Functor) + +data Box a = Empty | Full a + derive (Functor) + +derive instance Eq a => Eq (Box a) + +main :: Effect Unit +main = do + assert $ Red == Red + assert $ Red < Green + assert $ Name "Alice" == Name "Alice" + assert $ foldMap show (Cons 1 (Cons 2 Nil)) == "12" + assert $ bimap (_ + 1) (_ * 2) (Left2 3) == Left2 4 + assert $ map (_ + 1) (Full 1) == Full 2 + assert $ case map (_ + 1) (Pair 1 2) of + Pair 2 3 -> true + _ -> false + log "Done"